From 82a9c6d4befe90f782e06ce451a355538052f467 Mon Sep 17 00:00:00 2001 From: Greg Lucas Date: Thu, 26 Jan 2023 11:50:25 -0700 Subject: [PATCH 1/6] FIX: Ensure rank-1 arrays rather than scalars as input to splin2 --- src/gsm/libutil/module_gfs_tropp.F90 | 2 +- src/phys/co2hc.f | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/gsm/libutil/module_gfs_tropp.F90 b/src/gsm/libutil/module_gfs_tropp.F90 index 89c910d..dd8adb4 100644 --- a/src/gsm/libutil/module_gfs_tropp.F90 +++ b/src/gsm/libutil/module_gfs_tropp.F90 @@ -157,7 +157,7 @@ subroutine tpause(km,p,u,v,t,h,ptp,utp,vtp,ttp,htp,shrtp) integer klim(2),k,kd,ktp, kd_array(1) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! find tropopause level - call rsearch1(km-2,p(2),2,ptplim(1),klim(1)) + call rsearch1(km-2,p(2),2,ptplim(1:1),klim(1)) ! klim(1)=klim(1)+2 klim(1)=klim(1)+1 ! klim(2)=klim(2)+1 diff --git a/src/phys/co2hc.f b/src/phys/co2hc.f index 502fb5f..1cc8511 100644 --- a/src/phys/co2hc.f +++ b/src/phys/co2hc.f @@ -841,9 +841,9 @@ subroutine co2cc(im,jm,xtemp,temp,ltemp,xhr,hrate,lhr,mu,ro1, ! Calculate composition on Victor grid above x=12.5 (index 50) for ! recurrent formula ! - call splin2(xhr,mu,xvic0(51),vicmu,lhr,itm50,im,jm) - call splin2(xhr,rn2,xvic0(51),vicn2,lhr,itm50,im,jm) - call splin2(xhr,ro2,xvic0(51),vico2,lhr,itm50,im,jm) + call splin2(xhr,mu,xvic0(51:51),vicmu,lhr,itm50,im,jm) + call splin2(xhr,rn2,xvic0(51:51),vicn2,lhr,itm50,im,jm) + call splin2(xhr,ro2,xvic0(51:51),vico2,lhr,itm50,im,jm) ! ! Feb 28, 2008 ! idea change: the following portion of the code commented out and @@ -871,7 +871,7 @@ subroutine co2cc(im,jm,xtemp,temp,ltemp,xhr,hrate,lhr,mu,ro1, ! call splin2(xhr(iwork),ro1(1:im,iwork:),xvic0(51),vico1, ! & lhr-iwork+1,itm50,im,jm) ! - call splin2(xhr,ro1,xvic0(51),vico1,lhr,itm50,im,jm) + call splin2(xhr,ro1,xvic0(51:51),vico1,lhr,itm50,im,jm) ! ! idea add: make sure O is non-negative ! From b1612c045e0b4a74d28c88218090e92b756b6458 Mon Sep 17 00:00:00 2001 From: Greg Lucas Date: Tue, 7 Feb 2023 09:55:34 -0700 Subject: [PATCH 2/6] FIX: Change hex numbers to Z instead of X Fortran 90+ should use boz markers for bytes/hex numbers, so update accordingly. gfortran 10+ warns/errors for this. --- src/fim/FIMsrc/fim/framework/nems/kind.inc | 4 +- src/fim/FIMsrc/w3/w3fi32.f | 34 ++++---- src/fim/FIMsrc/w3/w3fp06.f | 90 +++++++++++----------- src/share/kind.inc | 4 +- 4 files changed, 66 insertions(+), 66 deletions(-) diff --git a/src/fim/FIMsrc/fim/framework/nems/kind.inc b/src/fim/FIMsrc/fim/framework/nems/kind.inc index 9f7d32e..f4da7c4 100644 --- a/src/fim/FIMsrc/fim/framework/nems/kind.inc +++ b/src/fim/FIMsrc/fim/framework/nems/kind.inc @@ -13,7 +13,7 @@ integer,parameter:: & !JR PPP doesn't like the hex constants so remove them #if 0 -real (kind=kfpt),parameter :: r4_in=x'ffbfffff' -real (kind=kdbl),parameter :: r8_in=x'fff7ffffffffffff' +real (kind=kfpt),parameter :: r4_in=z'ffbfffff' +real (kind=kdbl),parameter :: r8_in=z'fff7ffffffffffff' #endif integer(kind=kint),parameter :: i4_in=-999 ! -huge(1) diff --git a/src/fim/FIMsrc/w3/w3fi32.f b/src/fim/FIMsrc/w3/w3fi32.f index 8ee5f71..3edf000 100644 --- a/src/fim/FIMsrc/w3/w3fi32.f +++ b/src/fim/FIMsrc/w3/w3fi32.f @@ -61,23 +61,23 @@ SUBROUTINE W3FI32(LARRAY,KIDNT) C SAVE C - DATA ITABLE/X'0000000000340C01',X'0000000000280C01', - & X'0000000000200801',X'00000000001C0401', - & X'0000000001081401',X'0000000001000801', - & X'00000000003C0402',X'0000000000340802', - & X'0000000000280C02',X'0000000000200802', - & X'00000000001C0402',X'0000000001081402', - & X'0000000001000802',X'0000000000380803', - & X'0000000000300803',X'0000000000280803', - & X'0000000000200803',X'00000000001C0403', - & X'0000000000100C03',X'0000000000001003', - & X'0000000000380804',X'0000000000300804', - & X'0000000000280804',X'0000000000200804', - & X'0000000000180804',X'0000000000100804', - & X'0000000000001004'/ - DATA KX /X'00000000FFFFFFFF'/ - DATA MASK /X'00000000000000FF'/ - DATA MASK16/X'FFFFFFFFFFFF0000'/ + DATA ITABLE/Z'0000000000340C01',Z'0000000000280C01', + & Z'0000000000200801',Z'00000000001C0401', + & Z'0000000001081401',Z'0000000001000801', + & Z'00000000003C0402',Z'0000000000340802', + & Z'0000000000280C02',Z'0000000000200802', + & Z'00000000001C0402',Z'0000000001081402', + & Z'0000000001000802',Z'0000000000380803', + & Z'0000000000300803',Z'0000000000280803', + & Z'0000000000200803',Z'00000000001C0403', + & Z'0000000000100C03',Z'0000000000001003', + & Z'0000000000380804',Z'0000000000300804', + & Z'0000000000280804',Z'0000000000200804', + & Z'0000000000180804',Z'0000000000100804', + & Z'0000000000001004'/ + DATA KX /Z'00000000FFFFFFFF'/ + DATA MASK /Z'00000000000000FF'/ + DATA MASK16/Z'FFFFFFFFFFFF0000'/ C C MAKE KIDNT = 0 C diff --git a/src/fim/FIMsrc/w3/w3fp06.f b/src/fim/FIMsrc/w3/w3fp06.f index 00fb826..247bc61 100644 --- a/src/fim/FIMsrc/w3/w3fp06.f +++ b/src/fim/FIMsrc/w3/w3fp06.f @@ -55,14 +55,14 @@ SUBROUTINE W3FP06(ID,KTITLE,N) C CHARACTER * 324 KTITLE C - DATA MASK(1)/X'0000000F'/ - DATA MASK(2)/X'000000FF'/ - DATA MASK(3)/X'00000FFF'/ - DATA MASK(4)/X'0000FFFF'/ - DATA MASK(5)/X'000FFFFF'/ - DATA MASK(6)/X'00FFFFFF'/ - DATA MASK(7)/X'0FFFFFFF'/ - DATA MASK(8)/X'FFFFFFFF'/ + DATA MASK(1)/Z'0000000F'/ + DATA MASK(2)/Z'000000FF'/ + DATA MASK(3)/Z'00000FFF'/ + DATA MASK(4)/Z'0000FFFF'/ + DATA MASK(5)/Z'000FFFFF'/ + DATA MASK(6)/Z'00FFFFFF'/ + DATA MASK(7)/Z'0FFFFFFF'/ + DATA MASK(8)/Z'FFFFFFFF'/ C CALL LINE01(ID,MASK,KTITLE) IF (N.GT.1) GO TO 10 @@ -154,23 +154,23 @@ SUBROUTINE LINE01(ID,MASK,KTITLE) C C IDWORDS: MASK CONTROL (INTEGER) C - DATA SHFMSK( 1)/X'20020100'/ - DATA SHFMSK( 2)/X'28020400'/ - DATA SHFMSK( 3)/X'30020400'/ - DATA SHFMSK( 4)/X'38020400'/ - DATA SHFMSK( 5)/X'08050100'/ - DATA SHFMSK( 6)/X'00020100'/ - DATA SHFMSK( 7)/X'08050200'/ - DATA SHFMSK( 8)/X'00020200'/ - DATA SHFMSK( 9)/X'3C010200'/ - DATA SHFMSK(10)/X'28030100'/ - DATA SHFMSK(11)/X'28030200'/ - DATA SHFMSK(12)/X'34030100'/ - DATA SHFMSK(13)/X'20020400'/ - DATA SHFMSK(14)/X'30020400'/ - DATA SHFMSK(15)/X'1C010100'/ - DATA SHFMSK(16)/X'1C010200'/ - DATA SHFMSK(17)/X'20020200'/ + DATA SHFMSK( 1)/Z'20020100'/ + DATA SHFMSK( 2)/Z'28020400'/ + DATA SHFMSK( 3)/Z'30020400'/ + DATA SHFMSK( 4)/Z'38020400'/ + DATA SHFMSK( 5)/Z'08050100'/ + DATA SHFMSK( 6)/Z'00020100'/ + DATA SHFMSK( 7)/Z'08050200'/ + DATA SHFMSK( 8)/Z'00020200'/ + DATA SHFMSK( 9)/Z'3C010200'/ + DATA SHFMSK(10)/Z'28030100'/ + DATA SHFMSK(11)/Z'28030200'/ + DATA SHFMSK(12)/Z'34030100'/ + DATA SHFMSK(13)/Z'20020400'/ + DATA SHFMSK(14)/Z'30020400'/ + DATA SHFMSK(15)/Z'1C010100'/ + DATA SHFMSK(16)/Z'1C010200'/ + DATA SHFMSK(17)/Z'20020200'/ C C REFERENCE TABLE FOR SNAME. C @@ -907,25 +907,25 @@ SUBROUTINE LINE02(ID,MASK,KTITLE) C C IDWORDS: MASK CONTROL (INTEGER) C - DATA MASKN /X'FFFFFFFFFFFF0000'/ - DATA MASK32/X'00000000FFFFFFFF'/ - DATA SHFMSK( 1)/X'3C010200'/ - DATA SHFMSK( 2)/X'1C010100'/ - DATA SHFMSK( 3)/X'1C010200'/ - DATA SHFMSK( 4)/X'20020100'/ - DATA SHFMSK( 5)/X'20020200'/ - DATA SHFMSK( 6)/X'38020300'/ - DATA SHFMSK( 7)/X'30020300'/ - DATA SHFMSK( 8)/X'28020300'/ - DATA SHFMSK( 9)/X'20020300'/ - DATA SHFMSK(10)/X'3C010300'/ - DATA SHFMSK(11)/X'18020400'/ - DATA SHFMSK(12)/X'10020400'/ - DATA SHFMSK(13)/X'00040400'/ - DATA SHFMSK(14)/X'30040500'/ - DATA SHFMSK(15)/X'00040500'/ - DATA SHFMSK(16)/X'00080500'/ - DATA SHFMSK(17)/X'20040600'/ + DATA MASKN /Z'FFFFFFFFFFFF0000'/ + DATA MASK32/Z'00000000FFFFFFFF'/ + DATA SHFMSK( 1)/Z'3C010200'/ + DATA SHFMSK( 2)/Z'1C010100'/ + DATA SHFMSK( 3)/Z'1C010200'/ + DATA SHFMSK( 4)/Z'20020100'/ + DATA SHFMSK( 5)/Z'20020200'/ + DATA SHFMSK( 6)/Z'38020300'/ + DATA SHFMSK( 7)/Z'30020300'/ + DATA SHFMSK( 8)/Z'28020300'/ + DATA SHFMSK( 9)/Z'20020300'/ + DATA SHFMSK(10)/Z'3C010300'/ + DATA SHFMSK(11)/Z'18020400'/ + DATA SHFMSK(12)/Z'10020400'/ + DATA SHFMSK(13)/Z'00040400'/ + DATA SHFMSK(14)/Z'30040500'/ + DATA SHFMSK(15)/Z'00040500'/ + DATA SHFMSK(16)/Z'00080500'/ + DATA SHFMSK(17)/Z'20040600'/ C 100 FORMAT(' M=',I2,' T=',I2,' N=',I2,' F1=',I3,' F2=',I3,' CD=',I3, 1' CM=',I3,' KS=',I3,' K=',I3,' GES=',I2,' R=',I3,' G=',I3, @@ -1008,7 +1008,7 @@ SUBROUTINE LINE03(ID,KTITLE) C CHARACTER * 324 KTITLE C - DATA MASK32/X'00000000FFFFFFFF'/ + DATA MASK32/Z'00000000FFFFFFFF'/ C C FORTRAN INTERNAL WRITE STATEMENT REPLACES ENCODE C diff --git a/src/share/kind.inc b/src/share/kind.inc index 7e47ad1..90a217e 100644 --- a/src/share/kind.inc +++ b/src/share/kind.inc @@ -10,6 +10,6 @@ integer,parameter:: & ,kfpt=single & ,kdbl=double -real (kind=kfpt),parameter :: r4_in=x'ffbfffff' -real (kind=kdbl),parameter :: r8_in=x'fff7ffffffffffff' +real (kind=kfpt),parameter :: r4_in=z'ffbfffff' +real (kind=kdbl),parameter :: r8_in=z'fff7ffffffffffff' integer(kind=kint),parameter :: i4_in=-999 ! -huge(1) From dc4c5f8977495bb7aa8d6649f4b699edea8ff35e Mon Sep 17 00:00:00 2001 From: Adam Kubaryk Date: Wed, 29 Mar 2023 20:44:43 +0000 Subject: [PATCH 3/6] Removing FIM and NMM source from our tree, and fixing build warnings. Build warnings related to statement functions INDLSEV and INDLSOD, as well as ifort remark 8291. --- aclocal.m4 | 7 +- build-aux/config.guess | 156 +- build-aux/config.sub | 2 +- configure | 8 +- configure.ac | 2 - src/Makefile.am | 6 +- src/Makefile.in | 14 +- src/fim/FIMrun/FIMnamelist.FIM.njet | 209 - src/fim/FIMrun/FIMnamelist.FIM.tjet | 210 - src/fim/FIMrun/FIMnamelist.FIM7.tjet | 215 - src/fim/FIMrun/FIMnamelist.FIM9.tjet | 215 - src/fim/FIMrun/FIMnamelist.FIMCES.tjet | 206 - src/fim/FIMrun/FIMnamelist.FIMCO2.tjet | 207 - src/fim/FIMrun/FIMnamelist.FIMX.tjet | 232 - src/fim/FIMrun/FIMnamelist.FIMY.tjet | 212 - src/fim/FIMrun/FIMnamelist.FIMYENS.tjet | 216 - src/fim/FIMrun/FIMnamelist.FIMY_ENKF.tjet | 211 - src/fim/FIMrun/FIMnamelist.FIMZ.tjet | 214 - src/fim/FIMrun/FIMnamelist.bluefire | 205 - src/fim/FIMrun/FIMnamelist.default | 207 - src/fim/FIMrun/FIMnamelist.devccs | 209 - src/fim/FIMrun/FIMnamelist.frostintel | 202 - src/fim/FIMrun/FIMnamelist.jaguargnu.xt5 | 204 - src/fim/FIMrun/FIMnamelist.jaguarintel.xt5 | 204 - src/fim/FIMrun/FIMnamelist.linuxpcgnu | 201 - src/fim/FIMrun/FIMnamelist.macgnu | 201 - src/fim/FIMrun/FIMnamelist.nems | 206 - src/fim/FIMrun/FIMnamelist.nemsdevccs | 209 - src/fim/FIMrun/FIMnamelist.retro.tjet | 207 - src/fim/FIMrun/FIMnamelist.test.tjet | 205 - src/fim/FIMrun/FIMnamelist.vapor | 206 - src/fim/FIMrun/README | 5 - src/fim/FIMrun/REDUCEinput | 7 - src/fim/FIMrun/SMSnamelist | 21 - src/fim/FIMrun/atmos.configure | 1 - src/fim/FIMrun/batchTemplate | 30 - src/fim/FIMrun/batchTemplate-FIMY_ENKF-files | 79 - src/fim/FIMrun/batchTemplate-fim | 275 - src/fim/FIMrun/batchTemplate-grib12 | 47 - src/fim/FIMrun/batchTemplate-grib21 | 49 - src/fim/FIMrun/batchTemplate-interp | 45 - src/fim/FIMrun/batchTemplate-ncl | 798 - src/fim/FIMrun/batchTemplate-ncldiff | 416 - src/fim/FIMrun/batchTemplate-ncldiff-new | 413 - src/fim/FIMrun/batchTemplate-pop | 80 - src/fim/FIMrun/batchTemplate-post | 151 - src/fim/FIMrun/batchTemplate-postall | 333 - src/fim/FIMrun/batchTemplate-postncldiff | 88 - src/fim/FIMrun/batchTemplate-postncldiff-new | 88 - src/fim/FIMrun/batchTemplate-prep | 335 - src/fim/FIMrun/batchTemplate-prep-ens | 337 - src/fim/FIMrun/batchTemplate-restart | 62 - src/fim/FIMrun/batchTemplate-setup | 217 - src/fim/FIMrun/batchTemplate-tracker | 196 - src/fim/FIMrun/bsubfim | 174 - src/fim/FIMrun/chem_functions.ksh | 230 - src/fim/FIMrun/dpsig100.txt | 100 - src/fim/FIMrun/dpsig38.txt | 38 - src/fim/FIMrun/dpsig50.txt | 50 - src/fim/FIMrun/dpsig64.txt | 41 - src/fim/FIMrun/dpsig64_10.txt | 41 - src/fim/FIMrun/dpsig64_15.txt | 41 - src/fim/FIMrun/dpsig64_20.txt | 41 - src/fim/FIMrun/fim.configure.G4 | 277 - src/fim/FIMrun/fim.configure.G5 | 277 - src/fim/FIMrun/fim_gribtable | 135 - src/fim/FIMrun/fim_gribtable_FIMCES | 103 - src/fim/FIMrun/fim_gribtable_FIMCO2 | 103 - src/fim/FIMrun/fimxrsync.rb | 56 - src/fim/FIMrun/functions.ksh | 454 - src/fim/FIMrun/get_buildconfig.ksh | 15 - src/fim/FIMrun/llsubmitfim | 241 - src/fim/FIMrun/model_configure | 48 - src/fim/FIMrun/output_isobaric_levs.txt | 3 - src/fim/FIMrun/qsubfim | 127 - src/fim/FIMrun/qsubfim.frost | 138 - src/fim/FIMrun/qsubfim.jaguar | 138 - src/fim/FIMrun/runfim | 121 - src/fim/FIMrun/set_task_geometry.ksh | 187 - src/fim/FIMrun/theta_coor100.txt | 100 - src/fim/FIMrun/theta_coor38.txt | 4 - src/fim/FIMrun/theta_coor50.txt | 50 - src/fim/FIMrun/theta_coor64.txt | 7 - src/fim/FIMrun/top_grid | 12 - src/fim/FIMsrc/Makefile | 520 - src/fim/FIMsrc/Makesub | 49 - src/fim/FIMsrc/bacio/Makefile | 35 - src/fim/FIMsrc/bacio/bacio.v1.3.c | 623 - src/fim/FIMsrc/bacio/baciof.f | 525 - src/fim/FIMsrc/bacio/baciof.h | 11 - src/fim/FIMsrc/bacio/clib.h.sav | 27 - src/fim/FIMsrc/bacio/clib4.h | 27 - src/fim/FIMsrc/bacio/clib4.h.sav | 27 - src/fim/FIMsrc/bacio/clib8.h | 27 - src/fim/FIMsrc/bacio/clib8.h.sav | 27 - src/fim/FIMsrc/bacio/test.c | 540 - src/fim/FIMsrc/cntl/Makefile | 27 - src/fim/FIMsrc/cntl/module_chem_variables.F90 | 52 - src/fim/FIMsrc/cntl/module_constants.F90 | 93 - src/fim/FIMsrc/cntl/module_control.F90 | 370 - src/fim/FIMsrc/cntl/module_decomp.F90 | 3 - src/fim/FIMsrc/cntl/module_sfc_variables.F90 | 74 - src/fim/FIMsrc/cntl/module_variables.F90 | 97 - src/fim/FIMsrc/cntl/module_wrf_control.F90 | 93 - src/fim/FIMsrc/cntl/module_wrf_variables.F90 | 19 - src/fim/FIMsrc/cntl/units.F90 | 94 - src/fim/FIMsrc/fim/Makefile | 40 - src/fim/FIMsrc/fim/column/Makefile | 42 - src/fim/FIMsrc/fim/column/akbk_hyb_def.f | 11 - src/fim/FIMsrc/fim/column/astronomy.f | 636 - src/fim/FIMsrc/fim/column/calpreciptype.f | 1683 - src/fim/FIMsrc/fim/column/cnvcld_v.f | 90 - src/fim/FIMsrc/fim/column/co2tab_sw.h | 1303 - src/fim/FIMsrc/fim/column/conrad.f | 89 - src/fim/FIMsrc/fim/column/coordinate_def.f | 15 - src/fim/FIMsrc/fim/column/copy.ksh | 15 - src/fim/FIMsrc/fim/column/coundummy.f | 28 - src/fim/FIMsrc/fim/column/crhtab.f | 282 - src/fim/FIMsrc/fim/column/date_def.f | 10 - src/fim/FIMsrc/fim/column/dcyc2_v.f | 74 - src/fim/FIMsrc/fim/column/dcyc2_v.pre.rad.f | 73 - src/fim/FIMsrc/fim/column/delnpe.f | 169 - src/fim/FIMsrc/fim/column/delnpo.f | 183 - src/fim/FIMsrc/fim/column/dezouv.f | 259 - src/fim/FIMsrc/fim/column/dozeuv.f | 257 - src/fim/FIMsrc/fim/column/funcphys_v.F90 | 2899 -- src/fim/FIMsrc/fim/column/function2 | 5 - src/fim/FIMsrc/fim/column/gbphys_v.f | 2431 -- src/fim/FIMsrc/fim/column/get_prs_v.f | 366 - src/fim/FIMsrc/fim/column/getaer.f | 63 - src/fim/FIMsrc/fim/column/getozn.f | 138 - src/fim/FIMsrc/fim/column/gg_def.f | 10 - src/fim/FIMsrc/fim/column/gloopr.f | 1098 - src/fim/FIMsrc/fim/column/grrad.f | 1148 - src/fim/FIMsrc/fim/column/gscond_v.f | 296 - src/fim/FIMsrc/fim/column/gsmcolumn_v.f | 1568 - src/fim/FIMsrc/fim/column/gsmddrive_v.f | 567 - src/fim/FIMsrc/fim/column/gwdc.f | 1089 - src/fim/FIMsrc/fim/column/gwdps_v.F90 | 863 - src/fim/FIMsrc/fim/column/hpmdummy.f | 14 - src/fim/FIMsrc/fim/column/hyb2press.f | 73 - src/fim/FIMsrc/fim/column/iounitdef.f | 92 - src/fim/FIMsrc/fim/column/layout1.f | 32 - src/fim/FIMsrc/fim/column/lrgsclr_v.f | 289 - src/fim/FIMsrc/fim/column/lwave.f | 3095 -- src/fim/FIMsrc/fim/column/machine.f | 15 - src/fim/FIMsrc/fim/column/module.f | 328 - .../FIMsrc/fim/column/module_bfmicrophysics.f | 3221 -- src/fim/FIMsrc/fim/column/module_nsst_model.f | 517 - .../fim/column/module_nsst_parameters.f | 118 - .../fim/column/module_nsst_water_prop.f | 435 - src/fim/FIMsrc/fim/column/moninp1_v.f | 615 - src/fim/FIMsrc/fim/column/moninp_v.f | 700 - src/fim/FIMsrc/fim/column/moninq_v.f | 864 - src/fim/FIMsrc/fim/column/mstadb_v.f | 81 - src/fim/FIMsrc/fim/column/namelist_def.f | 31 - src/fim/FIMsrc/fim/column/namelist_soilveg.f | 178 - src/fim/FIMsrc/fim/column/noblas.f | 3489 -- src/fim/FIMsrc/fim/column/omegas.f | 80 - src/fim/FIMsrc/fim/column/omegtes.f | 123 - src/fim/FIMsrc/fim/column/ozphys_v.f | 115 - src/fim/FIMsrc/fim/column/physcons_v.F90 | 55 - src/fim/FIMsrc/fim/column/precpd_v.f | 499 - src/fim/FIMsrc/fim/column/progt2_v.f | 246 - src/fim/FIMsrc/fim/column/progtm_module.f | 93 - .../FIMsrc/fim/column/radiation_aerosols.f | 2332 -- .../FIMsrc/fim/column/radiation_astronomy.f | 760 - src/fim/FIMsrc/fim/column/radiation_clouds.f | 2456 -- src/fim/FIMsrc/fim/column/radiation_gases.f | 730 - src/fim/FIMsrc/fim/column/radiation_surface.f | 731 - src/fim/FIMsrc/fim/column/radlw_datatb.f | 29531 ---------------- src/fim/FIMsrc/fim/column/radlw_main.f | 4220 --- src/fim/FIMsrc/fim/column/radlw_param.f | 207 - src/fim/FIMsrc/fim/column/radsw_datatb.f | 20975 ----------- src/fim/FIMsrc/fim/column/radsw_main.f | 3581 -- src/fim/FIMsrc/fim/column/radsw_param.f | 190 - src/fim/FIMsrc/fim/column/rascnvv2_v.f | 4696 --- src/fim/FIMsrc/fim/column/resol_def.F90 | 43 - src/fim/FIMsrc/fim/column/sascnv_v.f | 1720 - src/fim/FIMsrc/fim/column/sascnvn_v.f | 1814 - src/fim/FIMsrc/fim/column/sfc_diag.f | 104 - src/fim/FIMsrc/fim/column/sfc_diff.f | 294 - src/fim/FIMsrc/fim/column/sfc_drv.f | 453 - src/fim/FIMsrc/fim/column/sfc_land.f | 1066 - src/fim/FIMsrc/fim/column/sfc_nsstac.f | 333 - src/fim/FIMsrc/fim/column/sfc_ocean.f | 135 - src/fim/FIMsrc/fim/column/sfc_sice.f | 587 - src/fim/FIMsrc/fim/column/sflx.f | 5046 --- src/fim/FIMsrc/fim/column/shalcnv_v.f | 1112 - src/fim/FIMsrc/fim/column/shalcv_v.f | 237 - src/fim/FIMsrc/fim/column/shalcv_v_opr.f | 165 - src/fim/FIMsrc/fim/column/sig2press.f | 42 - src/fim/FIMsrc/fim/column/swave.f | 2272 -- .../FIMsrc/fim/column/tracer_const_h-new.f | 38 - src/fim/FIMsrc/fim/column/vert_def.f | 11 - .../fim/column_chem/FIM_COLUMNC_OBJECTS | 34 - src/fim/FIMsrc/fim/column_chem/Makefile | 31 - .../FIMsrc/fim/column_chem/convert_gocart.F | 400 - .../fim/column_chem/module_aer_opt_out.F90 | 110 - .../FIMsrc/fim/column_chem/module_aer_ra.F90 | 97 - .../module_chem_plumerise_scalar.F90 | 2231 -- .../fim/column_chem/module_chem_prep_fim.F90 | 778 - .../fim/column_chem/module_chemvars.F90 | 206 - .../fim/column_chem/module_ctrans_grell.F90 | 1759 - .../FIMsrc/fim/column_chem/module_cu_g3.F90 | 5256 --- .../column_chem/module_data_gocart_chem.F90 | 24 - .../column_chem/module_data_gocart_dust.F90 | 19 - .../column_chem/module_data_gocart_seas.F90 | 8 - .../column_chem/module_data_rrtmgaeropt.F90 | 138 - .../fim/column_chem/module_data_sorgam.F90 | 1222 - .../fim/column_chem/module_dry_dep_driver.F90 | 320 - .../column_chem/module_gocart_aerosols.F90 | 307 - .../fim/column_chem/module_gocart_chem.F90 | 820 - .../fim/column_chem/module_gocart_dmsemis.F90 | 222 - .../fim/column_chem/module_gocart_drydep.F90 | 301 - .../fim/column_chem/module_gocart_dust.F90 | 388 - .../column_chem/module_gocart_dust_afwa.F90 | 464 - .../fim/column_chem/module_gocart_opt.F90 | 8712 ----- .../fim/column_chem/module_gocart_seasalt.F90 | 315 - .../column_chem/module_gocart_settling.F90 | 502 - .../module_initial_chem_namelist_defaults.F90 | 406 - .../column_chem/module_optical_averaging.F90 | 5577 --- .../fim/column_chem/module_optical_driver.F90 | 146 - .../fim/column_chem/module_peg_util.F90 | 84 - .../fim/column_chem/module_phot_mad.F90 | 3237 -- .../fim/column_chem/module_plumerise1.F90 | 302 - .../fim/column_chem/module_species_decs.F90 | 8 - .../fim/column_chem/module_vash_settling.F90 | 550 - .../fim/column_chem/module_vertmx_wrf.F90 | 201 - .../fim/column_chem/module_wetdep_ls.F90 | 104 - .../column_chem/module_zero_plumegen_coms.F90 | 60 - src/fim/FIMsrc/fim/framework/README | 17 - .../fim/framework/doc/FIM_DYN_PHY_States.txt | 77 - .../FIMsrc/fim/framework/doc/FIM_Plans.txt | 100 - .../fim/framework/doc/FIM_Questions.txt | 11 - .../nems/ENS_CplComp_ESMFMod_STUB.f90 | 222 - .../fim/framework/nems/ESMFVersionDefine.h | 17 - .../framework/nems/ESMFVersionDefine_ESMF_3.h | 17 - .../framework/nems/ESMFVersionDefine_ESMF_4.h | 17 - .../framework/nems/ESMFVersionDefine_ESMF_5.h | 17 - .../nems/ESMFVersionDefine_ESMF_520rbs.h | 17 - .../fim/framework/nems/ESMFVersionLogic.h | 25 - .../FIMsrc/fim/framework/nems/MAIN_NEMS.F90 | 678 - .../fim/framework/nems/fim_grid_comp.F90 | 664 - .../fim/framework/nems/fim_internal_state.F90 | 45 - src/fim/FIMsrc/fim/framework/nems/kind.inc | 19 - .../framework/nems/module_ATM_GRID_COMP.F90 | 697 - .../nems/module_ATM_INTERNAL_STATE.F90 | 47 - .../nems/module_DYNAMICS_GRID_COMP.F90 | 1302 - .../nems/module_DYN_PHY_CPL_COMP.F90 | 1224 - .../framework/nems/module_EARTH_GRID_COMP.F90 | 537 - .../nems/module_EARTH_INTERNAL_STATE.F90 | 55 - .../fim/framework/nems/module_ERR_MSG.F90 | 151 - .../framework/nems/module_FIM_INTEGRATE.F90 | 157 - .../framework/nems/module_NEMS_GRID_COMP.F90 | 1098 - .../nems/module_NEMS_INTERNAL_STATE.F90 | 45 - .../nems/module_PHYSICS_GRID_COMP.F90 | 1544 - .../FIMsrc/fim/horizontal/FIM_HORIZONTAL_OBJS | 106 - .../fim/horizontal/FIM_HORIZONTAL_OBJS_TOP | 2 - src/fim/FIMsrc/fim/horizontal/GetGrid.F90 | 176 - .../FIMsrc/fim/horizontal/GetIpnGlobal.F90 | 18 - .../FIMsrc/fim/horizontal/IncrementTimer.F90 | 7 - src/fim/FIMsrc/fim/horizontal/Makefile | 114 - src/fim/FIMsrc/fim/horizontal/Makefile.sms-r8 | 67 - src/fim/FIMsrc/fim/horizontal/OutTime.F90 | 488 - .../fim/horizontal/PhysicsGetIpnItsMype.F90 | 21 - .../fim/horizontal/SMS_Module_Lookup.txt | 53 - src/fim/FIMsrc/fim/horizontal/StartTimer.F90 | 6 - src/fim/FIMsrc/fim/horizontal/abstart.F90 | 68 - src/fim/FIMsrc/fim/horizontal/chem_alloc.F90 | 308 - .../FIMsrc/fim/horizontal/chem_finalize.F90 | 22 - src/fim/FIMsrc/fim/horizontal/chem_init.F90 | 1052 - src/fim/FIMsrc/fim/horizontal/chem_output.F90 | 317 - src/fim/FIMsrc/fim/horizontal/cnuity.F90 | 507 - src/fim/FIMsrc/fim/horizontal/copy.ksh | 95 - .../FIMsrc/fim/horizontal/cpl_finalize.F90 | 19 - src/fim/FIMsrc/fim/horizontal/cpl_init.F90 | 205 - src/fim/FIMsrc/fim/horizontal/cpl_run.F90 | 375 - src/fim/FIMsrc/fim/horizontal/datetime.F90 | 17 - src/fim/FIMsrc/fim/horizontal/dffusn.F90 | 156 - src/fim/FIMsrc/fim/horizontal/diag.F90 | 87 - src/fim/FIMsrc/fim/horizontal/diagnoise.F90 | 108 - src/fim/FIMsrc/fim/horizontal/digifilt.F90 | 248 - src/fim/FIMsrc/fim/horizontal/dissip.F90 | 153 - .../fim/horizontal/do_physics_one_step.F90 | 757 - .../horizontal/do_physics_one_step_chem.F90 | 41 - src/fim/FIMsrc/fim/horizontal/dyn_alloc.F90 | 376 - .../FIMsrc/fim/horizontal/dyn_finalize.F90 | 25 - src/fim/FIMsrc/fim/horizontal/dyn_init.F90 | 938 - src/fim/FIMsrc/fim/horizontal/dyn_run.F90 | 439 - src/fim/FIMsrc/fim/horizontal/edgvar.F90 | 226 - src/fim/FIMsrc/fim/horizontal/fct3d.F90 | 463 - src/fim/FIMsrc/fim/horizontal/filename.F90 | 27 - src/fim/FIMsrc/fim/horizontal/fim.F90 | 52 - src/fim/FIMsrc/fim/horizontal/fimcore.F90 | 758 - src/fim/FIMsrc/fim/horizontal/finalize.F90 | 38 - src/fim/FIMsrc/fim/horizontal/findmxmn.F90 | 511 - .../gfs_physics_internal_state_mod.F90 | 176 - .../horizontal/gfs_physics_namelist_mod.F90 | 136 - .../horizontal/gfs_physics_sfc_flx_mod.F90 | 127 - .../gfs_physics_sfc_flx_set_mod.F90 | 225 - src/fim/FIMsrc/fim/horizontal/globsum.F90 | 118 - src/fim/FIMsrc/fim/horizontal/hybgen.F90 | 1847 - src/fim/FIMsrc/fim/horizontal/hystat.F90 | 122 - src/fim/FIMsrc/fim/horizontal/infnan.F90 | 15 - src/fim/FIMsrc/fim/horizontal/init.F90 | 57 - src/fim/FIMsrc/fim/horizontal/its2string.F90 | 35 - src/fim/FIMsrc/fim/horizontal/its2time.F90 | 21 - .../FIMsrc/fim/horizontal/linebuf_stdout.c | 12 - .../fim/horizontal/module_chem_constants.F90 | 9 - .../fim/horizontal/module_chem_driver.F90 | 525 - .../FIMsrc/fim/horizontal/module_header.F90 | 68 - .../fim/horizontal/module_outvar_enkf.F90 | 96 - .../FIMsrc/fim/horizontal/module_savesfc.F90 | 66 - src/fim/FIMsrc/fim/horizontal/momtum.F90 | 214 - src/fim/FIMsrc/fim/horizontal/op_diag.F90 | 484 - src/fim/FIMsrc/fim/horizontal/out2D.F90 | 28 - src/fim/FIMsrc/fim/horizontal/out4d_mn.F90 | 53 - src/fim/FIMsrc/fim/horizontal/outDiags.F90 | 118 - src/fim/FIMsrc/fim/horizontal/outFMTed.F90 | 59 - src/fim/FIMsrc/fim/horizontal/output.F90 | 332 - src/fim/FIMsrc/fim/horizontal/outqv.F90 | 116 - src/fim/FIMsrc/fim/horizontal/outqv_mn.F90 | 53 - .../FIMsrc/fim/horizontal/outqv_mn_lat.F90 | 72 - .../fim/horizontal/outqv_mn_lat_abs.F90 | 73 - .../fim/horizontal/outqv_mn_lat_land.F90 | 73 - src/fim/FIMsrc/fim/horizontal/outqv_wsp.F90 | 107 - .../FIMsrc/fim/horizontal/phy_finalize.F90 | 19 - src/fim/FIMsrc/fim/horizontal/phy_init.F90 | 692 - src/fim/FIMsrc/fim/horizontal/phy_run.F90 | 249 - src/fim/FIMsrc/fim/horizontal/physics.F90 | 119 - src/fim/FIMsrc/fim/horizontal/printMAXMIN.F90 | 27 - src/fim/FIMsrc/fim/horizontal/profout.F90 | 48 - src/fim/FIMsrc/fim/horizontal/readGLVL.F90 | 26 - src/fim/FIMsrc/fim/horizontal/readINI.F90 | 36 - .../fim/horizontal/read_restart_dyn.F90 | 97 - .../fim/horizontal/read_restart_phy.F90 | 246 - src/fim/FIMsrc/fim/horizontal/readarr32.F90 | 27 - src/fim/FIMsrc/fim/horizontal/readarr64.F90 | 27 - src/fim/FIMsrc/fim/horizontal/readcase.F90 | 33 - src/fim/FIMsrc/fim/horizontal/restart.F90 | 139 - src/fim/FIMsrc/fim/horizontal/run.F90 | 289 - .../FIMsrc/fim/horizontal/stencilprint.F90 | 299 - .../FIMsrc/fim/horizontal/stenedgprint.F90 | 265 - src/fim/FIMsrc/fim/horizontal/transp3d.F90 | 220 - src/fim/FIMsrc/fim/horizontal/trcadv.F90 | 406 - .../FIMsrc/fim/horizontal/wrf_error_fatal.F90 | 10 - src/fim/FIMsrc/fim/horizontal/wrf_output.F90 | 77 - .../fim/horizontal/wrf_phy_finalize.F90 | 22 - .../FIMsrc/fim/horizontal/wrf_phy_init.F90 | 134 - src/fim/FIMsrc/fim/horizontal/wrf_phy_run.F90 | 46 - src/fim/FIMsrc/fim/horizontal/wrf_share.F90 | 62 - .../FIMsrc/fim/horizontal/wrfphys_alloc.F90 | 103 - src/fim/FIMsrc/fim/horizontal/wrfphysics.F90 | 320 - .../fim/horizontal/write_restart_dyn.F90 | 97 - .../fim/horizontal/write_restart_phy.F90 | 246 - src/fim/FIMsrc/fim/horizontal/writearr32.F90 | 28 - src/fim/FIMsrc/fim/horizontal/writearr64.F90 | 25 - src/fim/FIMsrc/fim/wrfphys/FIM_WRFP_OBJECTS | 22 - src/fim/FIMsrc/fim/wrfphys/Makefile | 31 - src/fim/FIMsrc/fim/wrfphys/libmassv.F | 385 - src/fim/FIMsrc/fim/wrfphys/module_cu_bmj.F | 2104 -- src/fim/FIMsrc/fim/wrfphys/module_cu_g3.F | 4836 --- src/fim/FIMsrc/fim/wrfphys/module_cu_gd.F | 4748 --- src/fim/FIMsrc/fim/wrfphys/module_cu_kf.F | 2631 -- src/fim/FIMsrc/fim/wrfphys/module_cu_kfeta.F | 2944 -- src/fim/FIMsrc/fim/wrfphys/module_cu_sas.F | 2506 -- .../fim/wrfphys/module_cumulus_driver.F | 515 - .../fim/wrfphys/module_microphysics_driver.F | 812 - .../FIMsrc/fim/wrfphys/module_mixactivate.F | 2618 -- src/fim/FIMsrc/fim/wrfphys/module_mp_etanew.F | 2593 -- .../FIMsrc/fim/wrfphys/module_mp_gsfcgce.F | 2820 -- .../FIMsrc/fim/wrfphys/module_mp_kessler.F | 244 - src/fim/FIMsrc/fim/wrfphys/module_mp_lin.F | 2629 -- .../fim/wrfphys/module_mp_morr_two_moment.F | 4036 --- .../FIMsrc/fim/wrfphys/module_mp_thompson.F | 3426 -- .../FIMsrc/fim/wrfphys/module_mp_thompson07.F | 3196 -- src/fim/FIMsrc/fim/wrfphys/module_mp_wdm5.F | 1625 - src/fim/FIMsrc/fim/wrfphys/module_mp_wdm6.F | 1932 - src/fim/FIMsrc/fim/wrfphys/module_mp_wsm3.F | 1014 - src/fim/FIMsrc/fim/wrfphys/module_mp_wsm5.F | 1301 - src/fim/FIMsrc/fim/wrfphys/module_mp_wsm6.F | 1552 - .../FIMsrc/fim/wrfphys/module_set_wrfphys.F | 155 - .../fim/wrfphys/module_wrfphys_prep_fim.F | 220 - .../FIMsrc/fim/wrfphys/module_wrfphysvars.F | 83 - src/fim/FIMsrc/fim_setup.ksh | 165 - src/fim/FIMsrc/fimtopo/Makefile | 36 - src/fim/FIMsrc/fimtopo/README | 21 - src/fim/FIMsrc/fimtopo/fimtopo.f90 | 711 - src/fim/FIMsrc/fimtopo/fimtopo.nl | 6 - src/fim/FIMsrc/icosio/Makefile | 15 - src/fim/FIMsrc/icosio/icosio.F90 | 1790 - src/fim/FIMsrc/macros.make.bluefire | 82 - src/fim/FIMsrc/macros.make.debug | 80 - src/fim/FIMsrc/macros.make.devccs | 82 - src/fim/FIMsrc/macros.make.frostintel | 81 - src/fim/FIMsrc/macros.make.jaguargnu | 81 - src/fim/FIMsrc/macros.make.jaguarintel | 81 - src/fim/FIMsrc/macros.make.lahey | 81 - src/fim/FIMsrc/macros.make.linuxpcgnu | 81 - src/fim/FIMsrc/macros.make.macgnu | 81 - src/fim/FIMsrc/macros.make.mvapich | 81 - src/fim/FIMsrc/macros.make.nems | 81 - src/fim/FIMsrc/macros.make.openmpi | 81 - src/fim/FIMsrc/macros.make.ranger | 81 - src/fim/FIMsrc/macros.make.vapor | 82 - src/fim/FIMsrc/makefim | 117 - src/fim/FIMsrc/post/Makefile | 20 - src/fim/FIMsrc/post/gribio/Makefile | 44 - src/fim/FIMsrc/post/gribio/grib_datastru.F90 | 11 - src/fim/FIMsrc/post/gribio/gribroutines.F90 | 419 - .../FIMsrc/post/gribio/gribroutines.F90.old | 362 - src/fim/FIMsrc/post/gribio/io_utils.c | 727 - src/fim/FIMsrc/post/pop/Makefile | 43 - src/fim/FIMsrc/post/pop/fimnc.F90 | 939 - src/fim/FIMsrc/post/pop/get_gribout.F90 | 30 - src/fim/FIMsrc/post/pop/pop.F90 | 720 - src/fim/FIMsrc/post/pop/post.F90 | 457 - src/fim/FIMsrc/post/pop/postdata.F90 | 99 - src/fim/FIMsrc/post/pop/smooth.F90 | 36 - src/fim/FIMsrc/post/vlint/Makefile | 19 - src/fim/FIMsrc/post/vlint/vlint.F90 | 242 - src/fim/FIMsrc/post/wrfio/Makefile | 31 - .../FIMsrc/post/wrfio/ext_ncd_get_dom_ti.code | 157 - .../FIMsrc/post/wrfio/ext_ncd_get_var_td.code | 227 - .../FIMsrc/post/wrfio/ext_ncd_get_var_ti.code | 174 - .../FIMsrc/post/wrfio/ext_ncd_put_dom_ti.code | 164 - .../FIMsrc/post/wrfio/ext_ncd_put_var_td.code | 233 - .../FIMsrc/post/wrfio/ext_ncd_put_var_ti.code | 144 - src/fim/FIMsrc/post/wrfio/field_routines.F90 | 175 - src/fim/FIMsrc/post/wrfio/transpose.code | 34 - src/fim/FIMsrc/post/wrfio/wrf_io.F90 | 3362 -- src/fim/FIMsrc/post/wrfio/wrf_io_flags.h | 14 - src/fim/FIMsrc/post/wrfio/wrf_status_codes.h | 133 - src/fim/FIMsrc/prep/Makefile | 46 - src/fim/FIMsrc/prep/gfsenkf/Makefile | 13 - src/fim/FIMsrc/prep/gfsenkf/README | 2 - .../prep/gfsenkf/global_sfchdr.fd/Makefile | 13 - .../prep/gfsenkf/global_sfchdr.fd/sfchdr.f | 212 - .../prep/gfsenkf/global_sighdr.fd/Makefile | 13 - .../prep/gfsenkf/global_sighdr.fd/sighdr.f | 374 - src/fim/FIMsrc/prep/grid/GetRegions.F90 | 43 - src/fim/FIMsrc/prep/grid/GridGen.F90 | 805 - src/fim/FIMsrc/prep/grid/GridStat.F90 | 87 - src/fim/FIMsrc/prep/grid/IJblockLayout.F90 | 68 - src/fim/FIMsrc/prep/grid/Makefile | 52 - src/fim/FIMsrc/prep/grid/SquareDecomp.F90 | 86 - src/fim/FIMsrc/prep/grid/SquareLayout.F90 | 73 - src/fim/FIMsrc/prep/grid/avg.F90 | 54 - src/fim/FIMsrc/prep/grid/bisect_triangle.F90 | 664 - src/fim/FIMsrc/prep/grid/datastru.F90 | 36 - src/fim/FIMsrc/prep/grid/dnspl.F90 | 90 - src/fim/FIMsrc/prep/grid/getlvl.F90 | 347 - src/fim/FIMsrc/prep/grid/grid.nl | 5 - src/fim/FIMsrc/prep/grid/gridst.F90 | 99 - src/fim/FIMsrc/prep/grid/hilbert.F90 | 71 - src/fim/FIMsrc/prep/grid/icos.F90 | 212 - src/fim/FIMsrc/prep/grid/ijblock.F90 | 56 - src/fim/FIMsrc/prep/grid/ll2xy.F90 | 44 - src/fim/FIMsrc/prep/grid/middle.F90 | 72 - src/fim/FIMsrc/prep/grid/mpi_stubs.F90 | 18 - src/fim/FIMsrc/prep/grid/perm.F90 | 84 - src/fim/FIMsrc/prep/grid/rotate.F90 | 92 - src/fim/FIMsrc/prep/grid/third.F90 | 73 - src/fim/FIMsrc/prep/grid/top_gridpoints.F90 | 108 - src/fim/FIMsrc/prep/grid/top_triangles.F90 | 84 - src/fim/FIMsrc/prep/grid/triang.F90 | 97 - src/fim/FIMsrc/prep/grid/trisect.F90 | 74 - src/fim/FIMsrc/prep/grid/trisect_triangle.F90 | 218 - src/fim/FIMsrc/prep/sfcio/Makefile | 22 - src/fim/FIMsrc/prep/sfcio/sfcio_module.F90 | 2278 -- src/fim/FIMsrc/prep/sigio/Makefile | 39 - src/fim/FIMsrc/prep/sigio/bafrio.f | 187 - src/fim/FIMsrc/prep/sigio/sigio_module.F90 | 1309 - src/fim/FIMsrc/prep/sigio/sigio_r_module.F90 | 2128 -- src/fim/FIMsrc/prep/slint/Makefile | 46 - src/fim/FIMsrc/prep/slint/README | 8 - src/fim/FIMsrc/prep/slint/ints_test.F90 | 27 - src/fim/FIMsrc/prep/slint/kd.F90 | 517 - src/fim/FIMsrc/prep/slint/kd_datastru.F90 | 27 - src/fim/FIMsrc/prep/slint/slint.F90 | 978 - src/fim/FIMsrc/prep/slint/slint.F90.jin | 406 - src/fim/FIMsrc/prep/slint/slintdatastru.F90 | 17 - src/fim/FIMsrc/prep/slint/slintest.F90 | 38 - src/fim/FIMsrc/prep/sp/Makefile | 50 - src/fim/FIMsrc/prep/sp/bll2ps.f | 315 - src/fim/FIMsrc/prep/sp/ncpus.f | 32 - src/fim/FIMsrc/prep/sp/spanaly.f | 89 - src/fim/FIMsrc/prep/sp/spdz2uv.f | 85 - src/fim/FIMsrc/prep/sp/speps.f | 67 - src/fim/FIMsrc/prep/sp/spfft.f | 93 - src/fim/FIMsrc/prep/sp/spfft1.f | 79 - src/fim/FIMsrc/prep/sp/spffte.f | 1058 - src/fim/FIMsrc/prep/sp/spffte.f.IBM | 146 - src/fim/FIMsrc/prep/sp/spfftpt.f | 64 - src/fim/FIMsrc/prep/sp/spgradq.f | 76 - src/fim/FIMsrc/prep/sp/spgradx.f | 86 - src/fim/FIMsrc/prep/sp/spgrady.f | 67 - src/fim/FIMsrc/prep/sp/splaplac.f | 61 - src/fim/FIMsrc/prep/sp/splat.f | 196 - src/fim/FIMsrc/prep/sp/splegend.f | 134 - src/fim/FIMsrc/prep/sp/splib.doc | 2621 -- src/fim/FIMsrc/prep/sp/sppad.f | 49 - src/fim/FIMsrc/prep/sp/spsynth.f | 165 - src/fim/FIMsrc/prep/sp/sptez.f | 82 - src/fim/FIMsrc/prep/sp/sptezd.f | 75 - src/fim/FIMsrc/prep/sp/sptezm.f | 83 - src/fim/FIMsrc/prep/sp/sptezmd.f | 78 - src/fim/FIMsrc/prep/sp/sptezmv.f | 95 - src/fim/FIMsrc/prep/sp/sptezv.f | 94 - src/fim/FIMsrc/prep/sp/sptgpm.f | 137 - src/fim/FIMsrc/prep/sp/sptgpmd.f | 96 - src/fim/FIMsrc/prep/sp/sptgpmv.f | 152 - src/fim/FIMsrc/prep/sp/sptgps.f | 540 - src/fim/FIMsrc/prep/sp/sptgpsd.f | 104 - src/fim/FIMsrc/prep/sp/sptgpsv.f | 931 - src/fim/FIMsrc/prep/sp/sptgpt.f | 112 - src/fim/FIMsrc/prep/sp/sptgptd.f | 83 - src/fim/FIMsrc/prep/sp/sptgptsd.f | 138 - src/fim/FIMsrc/prep/sp/sptgptv.f | 130 - src/fim/FIMsrc/prep/sp/sptgptvd.f | 168 - src/fim/FIMsrc/prep/sp/sptran.f | 130 - src/fim/FIMsrc/prep/sp/sptrand.f | 164 - src/fim/FIMsrc/prep/sp/sptranf.f | 177 - src/fim/FIMsrc/prep/sp/sptranf0.f | 80 - src/fim/FIMsrc/prep/sp/sptranf1.f | 99 - src/fim/FIMsrc/prep/sp/sptranfv.f | 208 - src/fim/FIMsrc/prep/sp/sptranv.f | 139 - src/fim/FIMsrc/prep/sp/sptrun.f | 113 - src/fim/FIMsrc/prep/sp/sptrund.f | 121 - src/fim/FIMsrc/prep/sp/sptrung.f | 104 - src/fim/FIMsrc/prep/sp/sptrungv.f | 153 - src/fim/FIMsrc/prep/sp/sptrunl.f | 127 - src/fim/FIMsrc/prep/sp/sptrunm.f | 117 - src/fim/FIMsrc/prep/sp/sptrunmv.f | 165 - src/fim/FIMsrc/prep/sp/sptruns.f | 109 - src/fim/FIMsrc/prep/sp/sptrunsv.f | 166 - src/fim/FIMsrc/prep/sp/sptrunv.f | 177 - src/fim/FIMsrc/prep/sp/spuv2dz.f | 94 - src/fim/FIMsrc/prep/sp/spvar.f | 48 - src/fim/FIMsrc/prep/sp/spwget.f | 41 - src/fim/FIMsrc/prep/ss2icos/fimini.F90 | 265 - src/fim/FIMsrc/prep/ss2icos/lay2lay.F90 | 546 - src/fim/FIMsrc/prep/ss2icos/lin2stp.F90 | 80 - src/fim/FIMsrc/prep/ss2icos/mktopo.F90 | 545 - src/fim/FIMsrc/prep/ss2icos/readenkfanal.F90 | 510 - src/fim/FIMsrc/prep/ss2icos/ss2icos.F90 | 748 - src/fim/FIMsrc/prep/ssfc2icos/Makefile | 41 - src/fim/FIMsrc/prep/ssfc2icos/newname.F90 | 271 - src/fim/FIMsrc/prep/ssfc2icos/read_mtnvar.F90 | 17 - src/fim/FIMsrc/prep/ssfc2icos/ssfc2icos.F90 | 405 - src/fim/FIMsrc/sys_share/Makefile | 23 - src/fim/FIMsrc/sys_share/sys_share.F90 | 27 - src/fim/FIMsrc/tools/mkDepends | 357 - src/fim/FIMsrc/utils/GetChemEnabled.F90 | 11 - src/fim/FIMsrc/utils/GetComputeTasks.F90 | 7 - src/fim/FIMsrc/utils/GetDATADIR.F90 | 6 - src/fim/FIMsrc/utils/GetDATADR2.F90 | 6 - src/fim/FIMsrc/utils/GetFIMDIR.F90 | 6 - src/fim/FIMsrc/utils/GetGLVL.F90 | 8 - src/fim/FIMsrc/utils/GetNIP.F90 | 8 - src/fim/FIMsrc/utils/GetNVL.F90 | 8 - src/fim/FIMsrc/utils/GetPREPDIR.F90 | 6 - src/fim/FIMsrc/utils/GetParallelism.F90 | 9 - src/fim/FIMsrc/utils/GetQueueTime.F90 | 7 - src/fim/FIMsrc/utils/GetSRCDIR.F90 | 6 - src/fim/FIMsrc/utils/GetWRFcuEnabled.F90 | 11 - src/fim/FIMsrc/utils/GetWRFmpEnabled.F90 | 11 - src/fim/FIMsrc/utils/GetWriteTaskInfo.F90 | 19 - src/fim/FIMsrc/utils/Makefile | 87 - src/fim/FIMsrc/utils/extract_atcf.F90 | 352 - src/fim/FIMsrc/utils/get_num_cores.F90 | 125 - src/fim/FIMsrc/utils/headers.F90 | 62 - .../utils/module_initial_chem_namelists.F90 | 3295 -- src/fim/FIMsrc/utils/read_queue_namelist.F90 | 172 - src/fim/FIMsrc/utils/reduce.F90 | 142 - src/fim/FIMsrc/utils/wtinfo.F90 | 195 - src/fim/FIMsrc/w3/CFILES/dbn_alert.c | 258 - src/fim/FIMsrc/w3/CFILES/mova2i.c | 40 - src/fim/FIMsrc/w3/CFILES/summary.c | 40 - src/fim/FIMsrc/w3/GetJdate.f | 22 - src/fim/FIMsrc/w3/Makefile | 42 - src/fim/FIMsrc/w3/MovChar.F90 | 9 - src/fim/FIMsrc/w3/README.w3 | 167 - src/fim/FIMsrc/w3/aea.f | 117 - src/fim/FIMsrc/w3/args_mod.f | 45 - src/fim/FIMsrc/w3/errexit.f | 34 - src/fim/FIMsrc/w3/errmsg.f | 29 - src/fim/FIMsrc/w3/fparsei.f | 39 - src/fim/FIMsrc/w3/fparser.f | 39 - src/fim/FIMsrc/w3/gblevents.f | 2436 -- src/fim/FIMsrc/w3/gbyte.f | 108 - src/fim/FIMsrc/w3/gbytes.f | 144 - src/fim/FIMsrc/w3/gbytes_char.f | 127 - src/fim/FIMsrc/w3/getbit.f | 87 - src/fim/FIMsrc/w3/getgb.f | 213 - src/fim/FIMsrc/w3/getgb1.f | 197 - src/fim/FIMsrc/w3/getgb1r.f | 75 - src/fim/FIMsrc/w3/getgb1re.f | 81 - src/fim/FIMsrc/w3/getgb1s.f | 185 - src/fim/FIMsrc/w3/getgbe.f | 223 - src/fim/FIMsrc/w3/getgbeh.f | 215 - src/fim/FIMsrc/w3/getgbem.f | 275 - src/fim/FIMsrc/w3/getgbemh.f | 265 - src/fim/FIMsrc/w3/getgbemn.f | 277 - src/fim/FIMsrc/w3/getgbemp.f | 271 - src/fim/FIMsrc/w3/getgbens.f | 207 - src/fim/FIMsrc/w3/getgbep.f | 219 - src/fim/FIMsrc/w3/getgbex.f | 233 - src/fim/FIMsrc/w3/getgbexm.f | 284 - src/fim/FIMsrc/w3/getgbh.f | 206 - src/fim/FIMsrc/w3/getgbm.f | 270 - src/fim/FIMsrc/w3/getgbmh.f | 258 - src/fim/FIMsrc/w3/getgbmp.f | 264 - src/fim/FIMsrc/w3/getgbp.f | 209 - src/fim/FIMsrc/w3/getgi.f | 88 - src/fim/FIMsrc/w3/getgir.f | 90 - src/fim/FIMsrc/w3/gtbits.f | 83 - src/fim/FIMsrc/w3/hostname.f | 32 - src/fim/FIMsrc/w3/idsdef.f | 285 - src/fim/FIMsrc/w3/instrument.f | 113 - src/fim/FIMsrc/w3/isrchne.f | 45 - src/fim/FIMsrc/w3/iw3jdn.f | 62 - src/fim/FIMsrc/w3/iw3mat.f | 47 - src/fim/FIMsrc/w3/iw3pds.f | 177 - src/fim/FIMsrc/w3/iw3unp29.f | 5002 --- src/fim/FIMsrc/w3/ixgb.f | 155 - src/fim/FIMsrc/w3/jdate.F90 | 10 - src/fim/FIMsrc/w3/lengds.f | 40 - src/fim/FIMsrc/w3/makwmo.f | 89 - src/fim/FIMsrc/w3/mersenne_twister.f | 498 - src/fim/FIMsrc/w3/mkfldsep.f | 105 - src/fim/FIMsrc/w3/mova2i.f | 52 - src/fim/FIMsrc/w3/orders.f | 276 - src/fim/FIMsrc/w3/pdsens.f | 76 - src/fim/FIMsrc/w3/pdseup.f | 74 - src/fim/FIMsrc/w3/putgb.f | 202 - src/fim/FIMsrc/w3/putgbe.f | 213 - src/fim/FIMsrc/w3/putgben.f | 223 - src/fim/FIMsrc/w3/putgbens.f | 167 - src/fim/FIMsrc/w3/putgbex.f | 222 - src/fim/FIMsrc/w3/putgbn.f | 209 - src/fim/FIMsrc/w3/q9ie32.f | 139 - src/fim/FIMsrc/w3/r63w72.f | 125 - src/fim/FIMsrc/w3/sbyte.f | 107 - src/fim/FIMsrc/w3/sbytes.f | 138 - src/fim/FIMsrc/w3/skgb.f | 77 - src/fim/FIMsrc/w3/start.f | 2 - src/fim/FIMsrc/w3/summary.c.sav | 465 - src/fim/FIMsrc/w3/summary.f | 2 - src/fim/FIMsrc/w3/w3ai00.f | 505 - src/fim/FIMsrc/w3/w3ai01.f | 120 - src/fim/FIMsrc/w3/w3ai08.f | 2848 -- src/fim/FIMsrc/w3/w3ai15.f | 124 - src/fim/FIMsrc/w3/w3ai18.f | 113 - src/fim/FIMsrc/w3/w3ai19.f | 127 - src/fim/FIMsrc/w3/w3ai24.f | 49 - src/fim/FIMsrc/w3/w3ai38.f | 84 - src/fim/FIMsrc/w3/w3ai39.f | 81 - src/fim/FIMsrc/w3/w3ai40.f | 101 - src/fim/FIMsrc/w3/w3ai41.f | 90 - src/fim/FIMsrc/w3/w3aq15.f | 66 - src/fim/FIMsrc/w3/w3as00.f | 315 - src/fim/FIMsrc/w3/w3ctzdat.f | 63 - src/fim/FIMsrc/w3/w3difdat.f | 55 - src/fim/FIMsrc/w3/w3doxdat.f | 40 - src/fim/FIMsrc/w3/w3fa01.f | 100 - src/fim/FIMsrc/w3/w3fa03.f | 82 - src/fim/FIMsrc/w3/w3fa03v.f | 95 - src/fim/FIMsrc/w3/w3fa04.f | 95 - src/fim/FIMsrc/w3/w3fa06.f | 126 - src/fim/FIMsrc/w3/w3fa09.f | 71 - src/fim/FIMsrc/w3/w3fa11.f | 65 - src/fim/FIMsrc/w3/w3fa12.f | 89 - src/fim/FIMsrc/w3/w3fa13.f | 94 - src/fim/FIMsrc/w3/w3fb00.f | 64 - src/fim/FIMsrc/w3/w3fb01.f | 77 - src/fim/FIMsrc/w3/w3fb02.f | 81 - src/fim/FIMsrc/w3/w3fb03.f | 73 - src/fim/FIMsrc/w3/w3fb04.f | 81 - src/fim/FIMsrc/w3/w3fb05.f | 90 - src/fim/FIMsrc/w3/w3fb06.f | 98 - src/fim/FIMsrc/w3/w3fb07.f | 115 - src/fim/FIMsrc/w3/w3fb08.f | 65 - src/fim/FIMsrc/w3/w3fb09.f | 64 - src/fim/FIMsrc/w3/w3fb10.f | 237 - src/fim/FIMsrc/w3/w3fb11.f | 122 - src/fim/FIMsrc/w3/w3fb12.f | 174 - src/fim/FIMsrc/w3/w3fc02.f | 78 - src/fim/FIMsrc/w3/w3fc05.f | 68 - src/fim/FIMsrc/w3/w3fc06.f | 53 - src/fim/FIMsrc/w3/w3fc07.f | 69 - src/fim/FIMsrc/w3/w3fc08.f | 74 - src/fim/FIMsrc/w3/w3fi01.f | 33 - src/fim/FIMsrc/w3/w3fi02.f | 43 - src/fim/FIMsrc/w3/w3fi03.f | 48 - src/fim/FIMsrc/w3/w3fi04.f | 122 - src/fim/FIMsrc/w3/w3fi18.f | 59 - src/fim/FIMsrc/w3/w3fi19.f | 55 - src/fim/FIMsrc/w3/w3fi20.f | 74 - src/fim/FIMsrc/w3/w3fi32.f | 156 - src/fim/FIMsrc/w3/w3fi47.f | 80 - src/fim/FIMsrc/w3/w3fi48.f | 84 - src/fim/FIMsrc/w3/w3fi52.f | 355 - src/fim/FIMsrc/w3/w3fi58.f | 124 - src/fim/FIMsrc/w3/w3fi59.f | 129 - src/fim/FIMsrc/w3/w3fi61.f | 204 - src/fim/FIMsrc/w3/w3fi62.f | 215 - src/fim/FIMsrc/w3/w3fi63.f | 3817 -- src/fim/FIMsrc/w3/w3fi64.f | 760 - src/fim/FIMsrc/w3/w3fi65.f | 397 - src/fim/FIMsrc/w3/w3fi66.f | 134 - src/fim/FIMsrc/w3/w3fi67.f | 2808 -- src/fim/FIMsrc/w3/w3fi68.f | 178 - src/fim/FIMsrc/w3/w3fi69.f | 149 - src/fim/FIMsrc/w3/w3fi70.f | 855 - src/fim/FIMsrc/w3/w3fi71.f | 1418 - src/fim/FIMsrc/w3/w3fi72.f | 468 - src/fim/FIMsrc/w3/w3fi73.f | 100 - src/fim/FIMsrc/w3/w3fi74.f | 412 - src/fim/FIMsrc/w3/w3fi75.f | 1637 - src/fim/FIMsrc/w3/w3fi76.f | 131 - src/fim/FIMsrc/w3/w3fi78.f | 2947 -- src/fim/FIMsrc/w3/w3fi81.f.sav | 2300 -- src/fim/FIMsrc/w3/w3fi81.f.save | 2300 -- src/fim/FIMsrc/w3/w3fi82.f | 97 - src/fim/FIMsrc/w3/w3fi83.f | 108 - src/fim/FIMsrc/w3/w3fi85.f | 2680 -- src/fim/FIMsrc/w3/w3fi88.f | 4750 --- src/fim/FIMsrc/w3/w3fi92.f | 216 - src/fim/FIMsrc/w3/w3fm07.f | 120 - src/fim/FIMsrc/w3/w3fm08.f | 64 - src/fim/FIMsrc/w3/w3fp04.f | 476 - src/fim/FIMsrc/w3/w3fp05.f | 614 - src/fim/FIMsrc/w3/w3fp06.f | 1163 - src/fim/FIMsrc/w3/w3fp10.f | 714 - src/fim/FIMsrc/w3/w3fp11.f | 762 - src/fim/FIMsrc/w3/w3fp12.f | 612 - src/fim/FIMsrc/w3/w3fp13.f | 920 - src/fim/FIMsrc/w3/w3fq07.f | 498 - src/fim/FIMsrc/w3/w3fs13.f | 52 - src/fim/FIMsrc/w3/w3fs15.f | 212 - src/fim/FIMsrc/w3/w3fs21.f | 77 - src/fim/FIMsrc/w3/w3fs26.f | 87 - src/fim/FIMsrc/w3/w3ft00.f | 171 - src/fim/FIMsrc/w3/w3ft01.f | 177 - src/fim/FIMsrc/w3/w3ft02.f | 217 - src/fim/FIMsrc/w3/w3ft03.f | 92 - src/fim/FIMsrc/w3/w3ft05.f | 248 - src/fim/FIMsrc/w3/w3ft05v.f | 273 - src/fim/FIMsrc/w3/w3ft06.f | 242 - src/fim/FIMsrc/w3/w3ft06v.f | 273 - src/fim/FIMsrc/w3/w3ft07.f | 232 - src/fim/FIMsrc/w3/w3ft08.f | 99 - src/fim/FIMsrc/w3/w3ft09.f | 111 - src/fim/FIMsrc/w3/w3ft10.f | 103 - src/fim/FIMsrc/w3/w3ft11.f | 112 - src/fim/FIMsrc/w3/w3ft12.f | 238 - src/fim/FIMsrc/w3/w3ft16.f | 221 - src/fim/FIMsrc/w3/w3ft17.f | 222 - src/fim/FIMsrc/w3/w3ft201.f | 270 - src/fim/FIMsrc/w3/w3ft202.f | 214 - src/fim/FIMsrc/w3/w3ft203.f | 269 - src/fim/FIMsrc/w3/w3ft204.f | 198 - src/fim/FIMsrc/w3/w3ft205.f | 232 - src/fim/FIMsrc/w3/w3ft206.f | 180 - src/fim/FIMsrc/w3/w3ft207.f | 264 - src/fim/FIMsrc/w3/w3ft208.f | 198 - src/fim/FIMsrc/w3/w3ft209.f | 182 - src/fim/FIMsrc/w3/w3ft21.f | 105 - src/fim/FIMsrc/w3/w3ft210.f | 197 - src/fim/FIMsrc/w3/w3ft211.f | 181 - src/fim/FIMsrc/w3/w3ft212.f | 182 - src/fim/FIMsrc/w3/w3ft213.f | 264 - src/fim/FIMsrc/w3/w3ft214.f | 264 - src/fim/FIMsrc/w3/w3ft26.f | 129 - src/fim/FIMsrc/w3/w3ft32.f | 1235 - src/fim/FIMsrc/w3/w3ft33.f | 146 - src/fim/FIMsrc/w3/w3ft38.f | 105 - src/fim/FIMsrc/w3/w3ft39.f | 117 - src/fim/FIMsrc/w3/w3ft40.f | 109 - src/fim/FIMsrc/w3/w3ft41.f | 118 - src/fim/FIMsrc/w3/w3ft43v.f | 270 - src/fim/FIMsrc/w3/w3locdat.f | 43 - src/fim/FIMsrc/w3/w3log.f | 2 - src/fim/FIMsrc/w3/w3miscan.f | 1854 - src/fim/FIMsrc/w3/w3movdat.f | 53 - src/fim/FIMsrc/w3/w3nogds.f | 446 - src/fim/FIMsrc/w3/w3pradat.f | 78 - src/fim/FIMsrc/w3/w3prrdat.f | 61 - src/fim/FIMsrc/w3/w3reddat.f | 144 - src/fim/FIMsrc/w3/w3tagb.f | 119 - src/fim/FIMsrc/w3/w3trnarg.f | 172 - src/fim/FIMsrc/w3/w3unpk77.f | 2580 -- src/fim/FIMsrc/w3/w3utcdat.f | 67 - src/fim/FIMsrc/w3/w3valdat.f | 50 - src/fim/FIMsrc/w3/w3ymdh4.f | 119 - src/fim/FIMsrc/w3/xdopen.f | 59 - src/fim/FIMsrc/w3/xmovex.f | 19 - src/fim/FIMsrc/w3/xstore.f | 44 - src/fim/Makefile.am | 14 - src/fim/Makefile.in | 589 - src/fim/diffsrc.ksh | 18 - src/fim/fim_grid_comp.F90 | 664 - src/fim/fim_grid_comp_stub.F90 | 89 - src/fim/fim_internal_state.F90 | 45 - src/fim/module_DYNAMICS_GRID_COMP.F90 | 1302 - src/fim/module_DYN_PHY_CPL_COMP.F90 | 1224 - src/fim/module_FIM_INTEGRATE.F90 | 157 - src/fim/module_PHYSICS_GRID_COMP.F90 | 1544 - src/gsm/dyn/do_dynamics_one_loop.f | 3 +- src/gsm/dyn/do_dynamics_two_loop.f | 2 +- src/gsm/dyn/filter1eo.f | 2 - src/gsm/dyn/filter1eo_noq.f | 2 - src/gsm/dyn/filter2eo.f | 2 - src/gsm/dyn/filter2eo_noq.f | 2 - src/gsm/dyn/filtereo.f | 2 - src/gsm/dyn/filtereo_noq.f | 2 - src/gsm/dyn/get_topo_grid_grad.f | 3 - src/gsm/dyn/grid_to_spect.f | 2 - src/gsm/dyn/grid_to_spect_inp.f | 2 - src/gsm/dyn/grid_to_spect_inp_1.f | 2 - src/gsm/dyn/grid_to_spect_inp_slg.f | 2 - src/gsm/dyn/grid_to_spect_rqt.f | 2 - src/gsm/dyn/grid_to_spect_slg.f | 2 - src/gsm/dyn/impadj_hyb.locl_gc.f | 4 +- src/gsm/dyn/indlmod.f | 15 + src/gsm/dyn/sicdif_hyb.f | 5 +- src/gsm/dyn/sicdif_hyb_gc.f | 5 +- src/gsm/dyn/sicdif_hyb_gcdp.f | 5 +- src/gsm/dyn/sicdif_hyb_slg.f | 2 +- src/gsm/dyn/sicdif_sig.f | 5 +- src/gsm/dyn/treadeo.io_iau.f | 2 - src/gsm/dyn/treadeo_nemsio_iau.f | 2 - src/gsm/phys/Makefile.am | 4 +- src/gsm/phys/Makefile.in | 4 +- src/gsm/phys/function2 | 5 - src/gsm/phys/function_indlsev | 3 - src/gsm/phys/function_indlsod | 3 - src/gsm/phys/getcon_physics.f | 5 +- src/gsm/phys/indlmod.f | 9 + src/nmm/Makefile.am | 14 - src/nmm/Makefile.in | 589 - src/nmm/module_BGRID_INTERP.F90 | 691 - src/nmm/module_CLOCKTIMES.F90 | 323 - src/nmm/module_CONSTANTS.F90 | 68 - src/nmm/module_CONTROL.F90 | 2318 -- src/nmm/module_CONVECTION.F90 | 675 - src/nmm/module_DERIVED_TYPES.F90 | 278 - src/nmm/module_DIAGNOSE.F90 | 3001 -- src/nmm/module_DIGITAL_FILTER_NMM.F90 | 806 - src/nmm/module_DM_PARALLEL.F90 | 1981 -- src/nmm/module_DOMAIN_GRID_COMP.F90 | 11142 ------ src/nmm/module_DOMAIN_INTERNAL_STATE.F90 | 168 - src/nmm/module_DOMAIN_NUOPC_SET.F90 | 1528 - src/nmm/module_DOMAIN_TASK_SPECS.F90 | 75 - src/nmm/module_DYNAMICS_ROUTINES.F90 | 5246 --- src/nmm/module_ERROR_MSG.F90 | 31 - src/nmm/module_EXCHANGE.F90 | 4574 --- src/nmm/module_FLTBNDS.F90 | 7019 ---- src/nmm/module_GET_CONFIG.F90 | 2082 -- src/nmm/module_GET_CONFIG_WRITE.F90 | 419 - src/nmm/module_GWD.F90 | 1140 - src/nmm/module_H_TO_V.F90 | 232 - src/nmm/module_INIT_READ_BIN.F90 | 2919 -- src/nmm/module_INIT_READ_NEMSIO.F90 | 4221 --- src/nmm/module_MICROPHYSICS.F90 | 565 - src/nmm/module_MY_DOMAIN_SPECS.F90 | 216 - src/nmm/module_NESTING.F90 | 13183 ------- src/nmm/module_NMM_GRID_COMP.F90 | 7141 ---- src/nmm/module_NMM_GRID_COMP_stub.F90 | 174 - src/nmm/module_NMM_INTEGRATE.F90 | 1965 - src/nmm/module_NMM_INTERNAL_STATE.F90 | 79 - src/nmm/module_OUTPUT.F90 | 390 - src/nmm/module_PARENT_CHILD_CPL_COMP.F90 | 24848 ------------- src/nmm/module_PRECIP_ADJUST.F90 | 342 - src/nmm/module_QUASIPOST.F90 | 854 - src/nmm/module_RADIATION.F90 | 1141 - src/nmm/module_REDUCTION.F90 | 557 - src/nmm/module_RELAX4E.F90 | 130 - src/nmm/module_SOLVER_GRID_COMP.F90 | 12125 ------- src/nmm/module_SOLVER_INTERNAL_STATE.F90 | 1679 - src/nmm/module_TIMESERIES.F90 | 612 - src/nmm/module_TRACKER.F90 | 1985 -- src/nmm/module_TURBULENCE.F90 | 1470 - src/nmm/module_VARS.F90 | 509 - src/nmm/module_VARS_STATE.F90 | 927 - src/nmm/module_WRITE_GRID_COMP.F90 | 5941 ---- src/nmm/module_WRITE_INTERNAL_STATE.F90 | 324 - src/nmm/module_WRITE_ROUTINES.F90 | 5248 --- src/nmm/n_compns_physics.f | 415 - src/nmm/n_layout1.f | 23 - src/nmm/n_module_gfs_mpi_def.f | 20 - src/nmm/n_mpi_def.f | 40 - src/nmm/n_mpi_quit.f | 12 - src/nmm/n_namelist_physics_def.f | 46 - src/nmm/n_resol_def.f | 47 - src/phys/idea_ion_input.f | 2 +- src/wamCap.F90 | 14 +- 899 files changed, 133 insertions(+), 511140 deletions(-) delete mode 100644 src/fim/FIMrun/FIMnamelist.FIM.njet delete mode 100644 src/fim/FIMrun/FIMnamelist.FIM.tjet delete mode 100644 src/fim/FIMrun/FIMnamelist.FIM7.tjet delete mode 100644 src/fim/FIMrun/FIMnamelist.FIM9.tjet delete mode 100644 src/fim/FIMrun/FIMnamelist.FIMCES.tjet delete mode 100644 src/fim/FIMrun/FIMnamelist.FIMCO2.tjet delete mode 100644 src/fim/FIMrun/FIMnamelist.FIMX.tjet delete mode 100644 src/fim/FIMrun/FIMnamelist.FIMY.tjet delete mode 100644 src/fim/FIMrun/FIMnamelist.FIMYENS.tjet delete mode 100644 src/fim/FIMrun/FIMnamelist.FIMY_ENKF.tjet delete mode 100644 src/fim/FIMrun/FIMnamelist.FIMZ.tjet delete mode 100644 src/fim/FIMrun/FIMnamelist.bluefire delete mode 100644 src/fim/FIMrun/FIMnamelist.default delete mode 100644 src/fim/FIMrun/FIMnamelist.devccs delete mode 100644 src/fim/FIMrun/FIMnamelist.frostintel delete mode 100644 src/fim/FIMrun/FIMnamelist.jaguargnu.xt5 delete mode 100644 src/fim/FIMrun/FIMnamelist.jaguarintel.xt5 delete mode 100644 src/fim/FIMrun/FIMnamelist.linuxpcgnu delete mode 100644 src/fim/FIMrun/FIMnamelist.macgnu delete mode 100644 src/fim/FIMrun/FIMnamelist.nems delete mode 100644 src/fim/FIMrun/FIMnamelist.nemsdevccs delete mode 100644 src/fim/FIMrun/FIMnamelist.retro.tjet delete mode 100644 src/fim/FIMrun/FIMnamelist.test.tjet delete mode 100644 src/fim/FIMrun/FIMnamelist.vapor delete mode 100644 src/fim/FIMrun/README delete mode 100644 src/fim/FIMrun/REDUCEinput delete mode 100644 src/fim/FIMrun/SMSnamelist delete mode 100644 src/fim/FIMrun/atmos.configure delete mode 100755 src/fim/FIMrun/batchTemplate delete mode 100755 src/fim/FIMrun/batchTemplate-FIMY_ENKF-files delete mode 100755 src/fim/FIMrun/batchTemplate-fim delete mode 100755 src/fim/FIMrun/batchTemplate-grib12 delete mode 100755 src/fim/FIMrun/batchTemplate-grib21 delete mode 100755 src/fim/FIMrun/batchTemplate-interp delete mode 100755 src/fim/FIMrun/batchTemplate-ncl delete mode 100755 src/fim/FIMrun/batchTemplate-ncldiff delete mode 100755 src/fim/FIMrun/batchTemplate-ncldiff-new delete mode 100755 src/fim/FIMrun/batchTemplate-pop delete mode 100755 src/fim/FIMrun/batchTemplate-post delete mode 100755 src/fim/FIMrun/batchTemplate-postall delete mode 100755 src/fim/FIMrun/batchTemplate-postncldiff delete mode 100755 src/fim/FIMrun/batchTemplate-postncldiff-new delete mode 100755 src/fim/FIMrun/batchTemplate-prep delete mode 100755 src/fim/FIMrun/batchTemplate-prep-ens delete mode 100755 src/fim/FIMrun/batchTemplate-restart delete mode 100755 src/fim/FIMrun/batchTemplate-setup delete mode 100755 src/fim/FIMrun/batchTemplate-tracker delete mode 100755 src/fim/FIMrun/bsubfim delete mode 100644 src/fim/FIMrun/chem_functions.ksh delete mode 100644 src/fim/FIMrun/dpsig100.txt delete mode 100644 src/fim/FIMrun/dpsig38.txt delete mode 100644 src/fim/FIMrun/dpsig50.txt delete mode 100644 src/fim/FIMrun/dpsig64.txt delete mode 100644 src/fim/FIMrun/dpsig64_10.txt delete mode 100644 src/fim/FIMrun/dpsig64_15.txt delete mode 100644 src/fim/FIMrun/dpsig64_20.txt delete mode 100644 src/fim/FIMrun/fim.configure.G4 delete mode 100644 src/fim/FIMrun/fim.configure.G5 delete mode 100644 src/fim/FIMrun/fim_gribtable delete mode 100644 src/fim/FIMrun/fim_gribtable_FIMCES delete mode 100644 src/fim/FIMrun/fim_gribtable_FIMCO2 delete mode 100755 src/fim/FIMrun/fimxrsync.rb delete mode 100644 src/fim/FIMrun/functions.ksh delete mode 100755 src/fim/FIMrun/get_buildconfig.ksh delete mode 100755 src/fim/FIMrun/llsubmitfim delete mode 100644 src/fim/FIMrun/model_configure delete mode 100644 src/fim/FIMrun/output_isobaric_levs.txt delete mode 100755 src/fim/FIMrun/qsubfim delete mode 100755 src/fim/FIMrun/qsubfim.frost delete mode 100755 src/fim/FIMrun/qsubfim.jaguar delete mode 100755 src/fim/FIMrun/runfim delete mode 100755 src/fim/FIMrun/set_task_geometry.ksh delete mode 100644 src/fim/FIMrun/theta_coor100.txt delete mode 100644 src/fim/FIMrun/theta_coor38.txt delete mode 100644 src/fim/FIMrun/theta_coor50.txt delete mode 100644 src/fim/FIMrun/theta_coor64.txt delete mode 100644 src/fim/FIMrun/top_grid delete mode 100644 src/fim/FIMsrc/Makefile delete mode 100644 src/fim/FIMsrc/Makesub delete mode 100644 src/fim/FIMsrc/bacio/Makefile delete mode 100755 src/fim/FIMsrc/bacio/bacio.v1.3.c delete mode 100644 src/fim/FIMsrc/bacio/baciof.f delete mode 100755 src/fim/FIMsrc/bacio/baciof.h delete mode 100755 src/fim/FIMsrc/bacio/clib.h.sav delete mode 100755 src/fim/FIMsrc/bacio/clib4.h delete mode 100755 src/fim/FIMsrc/bacio/clib4.h.sav delete mode 100755 src/fim/FIMsrc/bacio/clib8.h delete mode 100755 src/fim/FIMsrc/bacio/clib8.h.sav delete mode 100755 src/fim/FIMsrc/bacio/test.c delete mode 100644 src/fim/FIMsrc/cntl/Makefile delete mode 100644 src/fim/FIMsrc/cntl/module_chem_variables.F90 delete mode 100644 src/fim/FIMsrc/cntl/module_constants.F90 delete mode 100644 src/fim/FIMsrc/cntl/module_control.F90 delete mode 100644 src/fim/FIMsrc/cntl/module_decomp.F90 delete mode 100644 src/fim/FIMsrc/cntl/module_sfc_variables.F90 delete mode 100644 src/fim/FIMsrc/cntl/module_variables.F90 delete mode 100644 src/fim/FIMsrc/cntl/module_wrf_control.F90 delete mode 100644 src/fim/FIMsrc/cntl/module_wrf_variables.F90 delete mode 100644 src/fim/FIMsrc/cntl/units.F90 delete mode 100644 src/fim/FIMsrc/fim/Makefile delete mode 100644 src/fim/FIMsrc/fim/column/Makefile delete mode 100644 src/fim/FIMsrc/fim/column/akbk_hyb_def.f delete mode 100644 src/fim/FIMsrc/fim/column/astronomy.f delete mode 100644 src/fim/FIMsrc/fim/column/calpreciptype.f delete mode 100644 src/fim/FIMsrc/fim/column/cnvcld_v.f delete mode 100755 src/fim/FIMsrc/fim/column/co2tab_sw.h delete mode 100644 src/fim/FIMsrc/fim/column/conrad.f delete mode 100755 src/fim/FIMsrc/fim/column/coordinate_def.f delete mode 100755 src/fim/FIMsrc/fim/column/copy.ksh delete mode 100644 src/fim/FIMsrc/fim/column/coundummy.f delete mode 100644 src/fim/FIMsrc/fim/column/crhtab.f delete mode 100644 src/fim/FIMsrc/fim/column/date_def.f delete mode 100644 src/fim/FIMsrc/fim/column/dcyc2_v.f delete mode 100644 src/fim/FIMsrc/fim/column/dcyc2_v.pre.rad.f delete mode 100644 src/fim/FIMsrc/fim/column/delnpe.f delete mode 100644 src/fim/FIMsrc/fim/column/delnpo.f delete mode 100644 src/fim/FIMsrc/fim/column/dezouv.f delete mode 100644 src/fim/FIMsrc/fim/column/dozeuv.f delete mode 100644 src/fim/FIMsrc/fim/column/funcphys_v.F90 delete mode 100644 src/fim/FIMsrc/fim/column/function2 delete mode 100644 src/fim/FIMsrc/fim/column/gbphys_v.f delete mode 100644 src/fim/FIMsrc/fim/column/get_prs_v.f delete mode 100644 src/fim/FIMsrc/fim/column/getaer.f delete mode 100644 src/fim/FIMsrc/fim/column/getozn.f delete mode 100644 src/fim/FIMsrc/fim/column/gg_def.f delete mode 100644 src/fim/FIMsrc/fim/column/gloopr.f delete mode 100644 src/fim/FIMsrc/fim/column/grrad.f delete mode 100644 src/fim/FIMsrc/fim/column/gscond_v.f delete mode 100644 src/fim/FIMsrc/fim/column/gsmcolumn_v.f delete mode 100644 src/fim/FIMsrc/fim/column/gsmddrive_v.f delete mode 100755 src/fim/FIMsrc/fim/column/gwdc.f delete mode 100644 src/fim/FIMsrc/fim/column/gwdps_v.F90 delete mode 100644 src/fim/FIMsrc/fim/column/hpmdummy.f delete mode 100644 src/fim/FIMsrc/fim/column/hyb2press.f delete mode 100644 src/fim/FIMsrc/fim/column/iounitdef.f delete mode 100644 src/fim/FIMsrc/fim/column/layout1.f delete mode 100644 src/fim/FIMsrc/fim/column/lrgsclr_v.f delete mode 100644 src/fim/FIMsrc/fim/column/lwave.f delete mode 100644 src/fim/FIMsrc/fim/column/machine.f delete mode 100644 src/fim/FIMsrc/fim/column/module.f delete mode 100644 src/fim/FIMsrc/fim/column/module_bfmicrophysics.f delete mode 100644 src/fim/FIMsrc/fim/column/module_nsst_model.f delete mode 100644 src/fim/FIMsrc/fim/column/module_nsst_parameters.f delete mode 100644 src/fim/FIMsrc/fim/column/module_nsst_water_prop.f delete mode 100644 src/fim/FIMsrc/fim/column/moninp1_v.f delete mode 100644 src/fim/FIMsrc/fim/column/moninp_v.f delete mode 100755 src/fim/FIMsrc/fim/column/moninq_v.f delete mode 100644 src/fim/FIMsrc/fim/column/mstadb_v.f delete mode 100644 src/fim/FIMsrc/fim/column/namelist_def.f delete mode 100644 src/fim/FIMsrc/fim/column/namelist_soilveg.f delete mode 100644 src/fim/FIMsrc/fim/column/noblas.f delete mode 100644 src/fim/FIMsrc/fim/column/omegas.f delete mode 100644 src/fim/FIMsrc/fim/column/omegtes.f delete mode 100644 src/fim/FIMsrc/fim/column/ozphys_v.f delete mode 100644 src/fim/FIMsrc/fim/column/physcons_v.F90 delete mode 100644 src/fim/FIMsrc/fim/column/precpd_v.f delete mode 100755 src/fim/FIMsrc/fim/column/progt2_v.f delete mode 100755 src/fim/FIMsrc/fim/column/progtm_module.f delete mode 100644 src/fim/FIMsrc/fim/column/radiation_aerosols.f delete mode 100644 src/fim/FIMsrc/fim/column/radiation_astronomy.f delete mode 100644 src/fim/FIMsrc/fim/column/radiation_clouds.f delete mode 100644 src/fim/FIMsrc/fim/column/radiation_gases.f delete mode 100644 src/fim/FIMsrc/fim/column/radiation_surface.f delete mode 100644 src/fim/FIMsrc/fim/column/radlw_datatb.f delete mode 100644 src/fim/FIMsrc/fim/column/radlw_main.f delete mode 100644 src/fim/FIMsrc/fim/column/radlw_param.f delete mode 100644 src/fim/FIMsrc/fim/column/radsw_datatb.f delete mode 100644 src/fim/FIMsrc/fim/column/radsw_main.f delete mode 100644 src/fim/FIMsrc/fim/column/radsw_param.f delete mode 100644 src/fim/FIMsrc/fim/column/rascnvv2_v.f delete mode 100644 src/fim/FIMsrc/fim/column/resol_def.F90 delete mode 100644 src/fim/FIMsrc/fim/column/sascnv_v.f delete mode 100755 src/fim/FIMsrc/fim/column/sascnvn_v.f delete mode 100644 src/fim/FIMsrc/fim/column/sfc_diag.f delete mode 100644 src/fim/FIMsrc/fim/column/sfc_diff.f delete mode 100644 src/fim/FIMsrc/fim/column/sfc_drv.f delete mode 100644 src/fim/FIMsrc/fim/column/sfc_land.f delete mode 100755 src/fim/FIMsrc/fim/column/sfc_nsstac.f delete mode 100644 src/fim/FIMsrc/fim/column/sfc_ocean.f delete mode 100644 src/fim/FIMsrc/fim/column/sfc_sice.f delete mode 100644 src/fim/FIMsrc/fim/column/sflx.f delete mode 100755 src/fim/FIMsrc/fim/column/shalcnv_v.f delete mode 100644 src/fim/FIMsrc/fim/column/shalcv_v.f delete mode 100755 src/fim/FIMsrc/fim/column/shalcv_v_opr.f delete mode 100644 src/fim/FIMsrc/fim/column/sig2press.f delete mode 100644 src/fim/FIMsrc/fim/column/swave.f delete mode 100755 src/fim/FIMsrc/fim/column/tracer_const_h-new.f delete mode 100644 src/fim/FIMsrc/fim/column/vert_def.f delete mode 100644 src/fim/FIMsrc/fim/column_chem/FIM_COLUMNC_OBJECTS delete mode 100644 src/fim/FIMsrc/fim/column_chem/Makefile delete mode 100644 src/fim/FIMsrc/fim/column_chem/convert_gocart.F delete mode 100644 src/fim/FIMsrc/fim/column_chem/module_aer_opt_out.F90 delete mode 100644 src/fim/FIMsrc/fim/column_chem/module_aer_ra.F90 delete mode 100644 src/fim/FIMsrc/fim/column_chem/module_chem_plumerise_scalar.F90 delete mode 100644 src/fim/FIMsrc/fim/column_chem/module_chem_prep_fim.F90 delete mode 100644 src/fim/FIMsrc/fim/column_chem/module_chemvars.F90 delete mode 100644 src/fim/FIMsrc/fim/column_chem/module_ctrans_grell.F90 delete mode 100644 src/fim/FIMsrc/fim/column_chem/module_cu_g3.F90 delete mode 100644 src/fim/FIMsrc/fim/column_chem/module_data_gocart_chem.F90 delete mode 100644 src/fim/FIMsrc/fim/column_chem/module_data_gocart_dust.F90 delete mode 100644 src/fim/FIMsrc/fim/column_chem/module_data_gocart_seas.F90 delete mode 100644 src/fim/FIMsrc/fim/column_chem/module_data_rrtmgaeropt.F90 delete mode 100644 src/fim/FIMsrc/fim/column_chem/module_data_sorgam.F90 delete mode 100644 src/fim/FIMsrc/fim/column_chem/module_dry_dep_driver.F90 delete mode 100644 src/fim/FIMsrc/fim/column_chem/module_gocart_aerosols.F90 delete mode 100644 src/fim/FIMsrc/fim/column_chem/module_gocart_chem.F90 delete mode 100644 src/fim/FIMsrc/fim/column_chem/module_gocart_dmsemis.F90 delete mode 100644 src/fim/FIMsrc/fim/column_chem/module_gocart_drydep.F90 delete mode 100644 src/fim/FIMsrc/fim/column_chem/module_gocart_dust.F90 delete mode 100755 src/fim/FIMsrc/fim/column_chem/module_gocart_dust_afwa.F90 delete mode 100644 src/fim/FIMsrc/fim/column_chem/module_gocart_opt.F90 delete mode 100644 src/fim/FIMsrc/fim/column_chem/module_gocart_seasalt.F90 delete mode 100644 src/fim/FIMsrc/fim/column_chem/module_gocart_settling.F90 delete mode 100644 src/fim/FIMsrc/fim/column_chem/module_initial_chem_namelist_defaults.F90 delete mode 100644 src/fim/FIMsrc/fim/column_chem/module_optical_averaging.F90 delete mode 100644 src/fim/FIMsrc/fim/column_chem/module_optical_driver.F90 delete mode 100644 src/fim/FIMsrc/fim/column_chem/module_peg_util.F90 delete mode 100644 src/fim/FIMsrc/fim/column_chem/module_phot_mad.F90 delete mode 100644 src/fim/FIMsrc/fim/column_chem/module_plumerise1.F90 delete mode 100644 src/fim/FIMsrc/fim/column_chem/module_species_decs.F90 delete mode 100644 src/fim/FIMsrc/fim/column_chem/module_vash_settling.F90 delete mode 100644 src/fim/FIMsrc/fim/column_chem/module_vertmx_wrf.F90 delete mode 100644 src/fim/FIMsrc/fim/column_chem/module_wetdep_ls.F90 delete mode 100644 src/fim/FIMsrc/fim/column_chem/module_zero_plumegen_coms.F90 delete mode 100644 src/fim/FIMsrc/fim/framework/README delete mode 100644 src/fim/FIMsrc/fim/framework/doc/FIM_DYN_PHY_States.txt delete mode 100644 src/fim/FIMsrc/fim/framework/doc/FIM_Plans.txt delete mode 100644 src/fim/FIMsrc/fim/framework/doc/FIM_Questions.txt delete mode 100644 src/fim/FIMsrc/fim/framework/nems/ENS_CplComp_ESMFMod_STUB.f90 delete mode 100644 src/fim/FIMsrc/fim/framework/nems/ESMFVersionDefine.h delete mode 100644 src/fim/FIMsrc/fim/framework/nems/ESMFVersionDefine_ESMF_3.h delete mode 100644 src/fim/FIMsrc/fim/framework/nems/ESMFVersionDefine_ESMF_4.h delete mode 100644 src/fim/FIMsrc/fim/framework/nems/ESMFVersionDefine_ESMF_5.h delete mode 100644 src/fim/FIMsrc/fim/framework/nems/ESMFVersionDefine_ESMF_520rbs.h delete mode 100644 src/fim/FIMsrc/fim/framework/nems/ESMFVersionLogic.h delete mode 100644 src/fim/FIMsrc/fim/framework/nems/MAIN_NEMS.F90 delete mode 100644 src/fim/FIMsrc/fim/framework/nems/fim_grid_comp.F90 delete mode 100644 src/fim/FIMsrc/fim/framework/nems/fim_internal_state.F90 delete mode 100644 src/fim/FIMsrc/fim/framework/nems/kind.inc delete mode 100644 src/fim/FIMsrc/fim/framework/nems/module_ATM_GRID_COMP.F90 delete mode 100644 src/fim/FIMsrc/fim/framework/nems/module_ATM_INTERNAL_STATE.F90 delete mode 100644 src/fim/FIMsrc/fim/framework/nems/module_DYNAMICS_GRID_COMP.F90 delete mode 100644 src/fim/FIMsrc/fim/framework/nems/module_DYN_PHY_CPL_COMP.F90 delete mode 100644 src/fim/FIMsrc/fim/framework/nems/module_EARTH_GRID_COMP.F90 delete mode 100644 src/fim/FIMsrc/fim/framework/nems/module_EARTH_INTERNAL_STATE.F90 delete mode 100644 src/fim/FIMsrc/fim/framework/nems/module_ERR_MSG.F90 delete mode 100644 src/fim/FIMsrc/fim/framework/nems/module_FIM_INTEGRATE.F90 delete mode 100644 src/fim/FIMsrc/fim/framework/nems/module_NEMS_GRID_COMP.F90 delete mode 100644 src/fim/FIMsrc/fim/framework/nems/module_NEMS_INTERNAL_STATE.F90 delete mode 100644 src/fim/FIMsrc/fim/framework/nems/module_PHYSICS_GRID_COMP.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/FIM_HORIZONTAL_OBJS delete mode 100644 src/fim/FIMsrc/fim/horizontal/FIM_HORIZONTAL_OBJS_TOP delete mode 100644 src/fim/FIMsrc/fim/horizontal/GetGrid.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/GetIpnGlobal.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/IncrementTimer.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/Makefile delete mode 100644 src/fim/FIMsrc/fim/horizontal/Makefile.sms-r8 delete mode 100644 src/fim/FIMsrc/fim/horizontal/OutTime.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/PhysicsGetIpnItsMype.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/SMS_Module_Lookup.txt delete mode 100644 src/fim/FIMsrc/fim/horizontal/StartTimer.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/abstart.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/chem_alloc.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/chem_finalize.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/chem_init.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/chem_output.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/cnuity.F90 delete mode 100755 src/fim/FIMsrc/fim/horizontal/copy.ksh delete mode 100644 src/fim/FIMsrc/fim/horizontal/cpl_finalize.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/cpl_init.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/cpl_run.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/datetime.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/dffusn.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/diag.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/diagnoise.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/digifilt.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/dissip.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/do_physics_one_step.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/do_physics_one_step_chem.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/dyn_alloc.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/dyn_finalize.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/dyn_init.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/dyn_run.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/edgvar.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/fct3d.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/filename.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/fim.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/fimcore.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/finalize.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/findmxmn.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/gfs_physics_internal_state_mod.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/gfs_physics_namelist_mod.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/gfs_physics_sfc_flx_mod.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/gfs_physics_sfc_flx_set_mod.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/globsum.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/hybgen.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/hystat.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/infnan.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/init.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/its2string.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/its2time.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/linebuf_stdout.c delete mode 100644 src/fim/FIMsrc/fim/horizontal/module_chem_constants.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/module_chem_driver.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/module_header.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/module_outvar_enkf.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/module_savesfc.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/momtum.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/op_diag.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/out2D.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/out4d_mn.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/outDiags.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/outFMTed.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/output.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/outqv.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/outqv_mn.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/outqv_mn_lat.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/outqv_mn_lat_abs.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/outqv_mn_lat_land.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/outqv_wsp.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/phy_finalize.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/phy_init.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/phy_run.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/physics.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/printMAXMIN.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/profout.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/readGLVL.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/readINI.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/read_restart_dyn.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/read_restart_phy.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/readarr32.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/readarr64.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/readcase.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/restart.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/run.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/stencilprint.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/stenedgprint.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/transp3d.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/trcadv.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/wrf_error_fatal.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/wrf_output.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/wrf_phy_finalize.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/wrf_phy_init.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/wrf_phy_run.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/wrf_share.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/wrfphys_alloc.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/wrfphysics.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/write_restart_dyn.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/write_restart_phy.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/writearr32.F90 delete mode 100644 src/fim/FIMsrc/fim/horizontal/writearr64.F90 delete mode 100644 src/fim/FIMsrc/fim/wrfphys/FIM_WRFP_OBJECTS delete mode 100644 src/fim/FIMsrc/fim/wrfphys/Makefile delete mode 100644 src/fim/FIMsrc/fim/wrfphys/libmassv.F delete mode 100644 src/fim/FIMsrc/fim/wrfphys/module_cu_bmj.F delete mode 100644 src/fim/FIMsrc/fim/wrfphys/module_cu_g3.F delete mode 100644 src/fim/FIMsrc/fim/wrfphys/module_cu_gd.F delete mode 100644 src/fim/FIMsrc/fim/wrfphys/module_cu_kf.F delete mode 100644 src/fim/FIMsrc/fim/wrfphys/module_cu_kfeta.F delete mode 100644 src/fim/FIMsrc/fim/wrfphys/module_cu_sas.F delete mode 100644 src/fim/FIMsrc/fim/wrfphys/module_cumulus_driver.F delete mode 100644 src/fim/FIMsrc/fim/wrfphys/module_microphysics_driver.F delete mode 100644 src/fim/FIMsrc/fim/wrfphys/module_mixactivate.F delete mode 100644 src/fim/FIMsrc/fim/wrfphys/module_mp_etanew.F delete mode 100644 src/fim/FIMsrc/fim/wrfphys/module_mp_gsfcgce.F delete mode 100644 src/fim/FIMsrc/fim/wrfphys/module_mp_kessler.F delete mode 100644 src/fim/FIMsrc/fim/wrfphys/module_mp_lin.F delete mode 100644 src/fim/FIMsrc/fim/wrfphys/module_mp_morr_two_moment.F delete mode 100644 src/fim/FIMsrc/fim/wrfphys/module_mp_thompson.F delete mode 100644 src/fim/FIMsrc/fim/wrfphys/module_mp_thompson07.F delete mode 100644 src/fim/FIMsrc/fim/wrfphys/module_mp_wdm5.F delete mode 100644 src/fim/FIMsrc/fim/wrfphys/module_mp_wdm6.F delete mode 100644 src/fim/FIMsrc/fim/wrfphys/module_mp_wsm3.F delete mode 100644 src/fim/FIMsrc/fim/wrfphys/module_mp_wsm5.F delete mode 100644 src/fim/FIMsrc/fim/wrfphys/module_mp_wsm6.F delete mode 100644 src/fim/FIMsrc/fim/wrfphys/module_set_wrfphys.F delete mode 100644 src/fim/FIMsrc/fim/wrfphys/module_wrfphys_prep_fim.F delete mode 100644 src/fim/FIMsrc/fim/wrfphys/module_wrfphysvars.F delete mode 100644 src/fim/FIMsrc/fim_setup.ksh delete mode 100644 src/fim/FIMsrc/fimtopo/Makefile delete mode 100644 src/fim/FIMsrc/fimtopo/README delete mode 100644 src/fim/FIMsrc/fimtopo/fimtopo.f90 delete mode 100644 src/fim/FIMsrc/fimtopo/fimtopo.nl delete mode 100644 src/fim/FIMsrc/icosio/Makefile delete mode 100644 src/fim/FIMsrc/icosio/icosio.F90 delete mode 100644 src/fim/FIMsrc/macros.make.bluefire delete mode 100644 src/fim/FIMsrc/macros.make.debug delete mode 100644 src/fim/FIMsrc/macros.make.devccs delete mode 100644 src/fim/FIMsrc/macros.make.frostintel delete mode 100644 src/fim/FIMsrc/macros.make.jaguargnu delete mode 100644 src/fim/FIMsrc/macros.make.jaguarintel delete mode 100644 src/fim/FIMsrc/macros.make.lahey delete mode 100644 src/fim/FIMsrc/macros.make.linuxpcgnu delete mode 100644 src/fim/FIMsrc/macros.make.macgnu delete mode 100644 src/fim/FIMsrc/macros.make.mvapich delete mode 100644 src/fim/FIMsrc/macros.make.nems delete mode 100644 src/fim/FIMsrc/macros.make.openmpi delete mode 100644 src/fim/FIMsrc/macros.make.ranger delete mode 100644 src/fim/FIMsrc/macros.make.vapor delete mode 100755 src/fim/FIMsrc/makefim delete mode 100644 src/fim/FIMsrc/post/Makefile delete mode 100644 src/fim/FIMsrc/post/gribio/Makefile delete mode 100644 src/fim/FIMsrc/post/gribio/grib_datastru.F90 delete mode 100644 src/fim/FIMsrc/post/gribio/gribroutines.F90 delete mode 100644 src/fim/FIMsrc/post/gribio/gribroutines.F90.old delete mode 100644 src/fim/FIMsrc/post/gribio/io_utils.c delete mode 100644 src/fim/FIMsrc/post/pop/Makefile delete mode 100644 src/fim/FIMsrc/post/pop/fimnc.F90 delete mode 100644 src/fim/FIMsrc/post/pop/get_gribout.F90 delete mode 100644 src/fim/FIMsrc/post/pop/pop.F90 delete mode 100644 src/fim/FIMsrc/post/pop/post.F90 delete mode 100644 src/fim/FIMsrc/post/pop/postdata.F90 delete mode 100644 src/fim/FIMsrc/post/pop/smooth.F90 delete mode 100644 src/fim/FIMsrc/post/vlint/Makefile delete mode 100644 src/fim/FIMsrc/post/vlint/vlint.F90 delete mode 100644 src/fim/FIMsrc/post/wrfio/Makefile delete mode 100644 src/fim/FIMsrc/post/wrfio/ext_ncd_get_dom_ti.code delete mode 100644 src/fim/FIMsrc/post/wrfio/ext_ncd_get_var_td.code delete mode 100644 src/fim/FIMsrc/post/wrfio/ext_ncd_get_var_ti.code delete mode 100644 src/fim/FIMsrc/post/wrfio/ext_ncd_put_dom_ti.code delete mode 100644 src/fim/FIMsrc/post/wrfio/ext_ncd_put_var_td.code delete mode 100644 src/fim/FIMsrc/post/wrfio/ext_ncd_put_var_ti.code delete mode 100644 src/fim/FIMsrc/post/wrfio/field_routines.F90 delete mode 100644 src/fim/FIMsrc/post/wrfio/transpose.code delete mode 100644 src/fim/FIMsrc/post/wrfio/wrf_io.F90 delete mode 100644 src/fim/FIMsrc/post/wrfio/wrf_io_flags.h delete mode 100644 src/fim/FIMsrc/post/wrfio/wrf_status_codes.h delete mode 100644 src/fim/FIMsrc/prep/Makefile delete mode 100644 src/fim/FIMsrc/prep/gfsenkf/Makefile delete mode 100644 src/fim/FIMsrc/prep/gfsenkf/README delete mode 100755 src/fim/FIMsrc/prep/gfsenkf/global_sfchdr.fd/Makefile delete mode 100755 src/fim/FIMsrc/prep/gfsenkf/global_sfchdr.fd/sfchdr.f delete mode 100755 src/fim/FIMsrc/prep/gfsenkf/global_sighdr.fd/Makefile delete mode 100755 src/fim/FIMsrc/prep/gfsenkf/global_sighdr.fd/sighdr.f delete mode 100644 src/fim/FIMsrc/prep/grid/GetRegions.F90 delete mode 100644 src/fim/FIMsrc/prep/grid/GridGen.F90 delete mode 100644 src/fim/FIMsrc/prep/grid/GridStat.F90 delete mode 100644 src/fim/FIMsrc/prep/grid/IJblockLayout.F90 delete mode 100644 src/fim/FIMsrc/prep/grid/Makefile delete mode 100644 src/fim/FIMsrc/prep/grid/SquareDecomp.F90 delete mode 100644 src/fim/FIMsrc/prep/grid/SquareLayout.F90 delete mode 100644 src/fim/FIMsrc/prep/grid/avg.F90 delete mode 100644 src/fim/FIMsrc/prep/grid/bisect_triangle.F90 delete mode 100644 src/fim/FIMsrc/prep/grid/datastru.F90 delete mode 100644 src/fim/FIMsrc/prep/grid/dnspl.F90 delete mode 100644 src/fim/FIMsrc/prep/grid/getlvl.F90 delete mode 100644 src/fim/FIMsrc/prep/grid/grid.nl delete mode 100644 src/fim/FIMsrc/prep/grid/gridst.F90 delete mode 100644 src/fim/FIMsrc/prep/grid/hilbert.F90 delete mode 100644 src/fim/FIMsrc/prep/grid/icos.F90 delete mode 100644 src/fim/FIMsrc/prep/grid/ijblock.F90 delete mode 100644 src/fim/FIMsrc/prep/grid/ll2xy.F90 delete mode 100644 src/fim/FIMsrc/prep/grid/middle.F90 delete mode 100644 src/fim/FIMsrc/prep/grid/mpi_stubs.F90 delete mode 100644 src/fim/FIMsrc/prep/grid/perm.F90 delete mode 100644 src/fim/FIMsrc/prep/grid/rotate.F90 delete mode 100644 src/fim/FIMsrc/prep/grid/third.F90 delete mode 100644 src/fim/FIMsrc/prep/grid/top_gridpoints.F90 delete mode 100644 src/fim/FIMsrc/prep/grid/top_triangles.F90 delete mode 100644 src/fim/FIMsrc/prep/grid/triang.F90 delete mode 100644 src/fim/FIMsrc/prep/grid/trisect.F90 delete mode 100644 src/fim/FIMsrc/prep/grid/trisect_triangle.F90 delete mode 100755 src/fim/FIMsrc/prep/sfcio/Makefile delete mode 100644 src/fim/FIMsrc/prep/sfcio/sfcio_module.F90 delete mode 100644 src/fim/FIMsrc/prep/sigio/Makefile delete mode 100644 src/fim/FIMsrc/prep/sigio/bafrio.f delete mode 100644 src/fim/FIMsrc/prep/sigio/sigio_module.F90 delete mode 100644 src/fim/FIMsrc/prep/sigio/sigio_r_module.F90 delete mode 100644 src/fim/FIMsrc/prep/slint/Makefile delete mode 100644 src/fim/FIMsrc/prep/slint/README delete mode 100644 src/fim/FIMsrc/prep/slint/ints_test.F90 delete mode 100644 src/fim/FIMsrc/prep/slint/kd.F90 delete mode 100644 src/fim/FIMsrc/prep/slint/kd_datastru.F90 delete mode 100644 src/fim/FIMsrc/prep/slint/slint.F90 delete mode 100644 src/fim/FIMsrc/prep/slint/slint.F90.jin delete mode 100644 src/fim/FIMsrc/prep/slint/slintdatastru.F90 delete mode 100644 src/fim/FIMsrc/prep/slint/slintest.F90 delete mode 100644 src/fim/FIMsrc/prep/sp/Makefile delete mode 100644 src/fim/FIMsrc/prep/sp/bll2ps.f delete mode 100644 src/fim/FIMsrc/prep/sp/ncpus.f delete mode 100644 src/fim/FIMsrc/prep/sp/spanaly.f delete mode 100644 src/fim/FIMsrc/prep/sp/spdz2uv.f delete mode 100644 src/fim/FIMsrc/prep/sp/speps.f delete mode 100644 src/fim/FIMsrc/prep/sp/spfft.f delete mode 100644 src/fim/FIMsrc/prep/sp/spfft1.f delete mode 100644 src/fim/FIMsrc/prep/sp/spffte.f delete mode 100644 src/fim/FIMsrc/prep/sp/spffte.f.IBM delete mode 100644 src/fim/FIMsrc/prep/sp/spfftpt.f delete mode 100644 src/fim/FIMsrc/prep/sp/spgradq.f delete mode 100644 src/fim/FIMsrc/prep/sp/spgradx.f delete mode 100644 src/fim/FIMsrc/prep/sp/spgrady.f delete mode 100644 src/fim/FIMsrc/prep/sp/splaplac.f delete mode 100644 src/fim/FIMsrc/prep/sp/splat.f delete mode 100644 src/fim/FIMsrc/prep/sp/splegend.f delete mode 100644 src/fim/FIMsrc/prep/sp/splib.doc delete mode 100644 src/fim/FIMsrc/prep/sp/sppad.f delete mode 100644 src/fim/FIMsrc/prep/sp/spsynth.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptez.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptezd.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptezm.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptezmd.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptezmv.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptezv.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptgpm.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptgpmd.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptgpmv.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptgps.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptgpsd.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptgpsv.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptgpt.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptgptd.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptgptsd.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptgptv.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptgptvd.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptran.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptrand.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptranf.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptranf0.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptranf1.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptranfv.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptranv.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptrun.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptrund.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptrung.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptrungv.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptrunl.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptrunm.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptrunmv.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptruns.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptrunsv.f delete mode 100644 src/fim/FIMsrc/prep/sp/sptrunv.f delete mode 100644 src/fim/FIMsrc/prep/sp/spuv2dz.f delete mode 100644 src/fim/FIMsrc/prep/sp/spvar.f delete mode 100644 src/fim/FIMsrc/prep/sp/spwget.f delete mode 100644 src/fim/FIMsrc/prep/ss2icos/fimini.F90 delete mode 100644 src/fim/FIMsrc/prep/ss2icos/lay2lay.F90 delete mode 100644 src/fim/FIMsrc/prep/ss2icos/lin2stp.F90 delete mode 100644 src/fim/FIMsrc/prep/ss2icos/mktopo.F90 delete mode 100644 src/fim/FIMsrc/prep/ss2icos/readenkfanal.F90 delete mode 100644 src/fim/FIMsrc/prep/ss2icos/ss2icos.F90 delete mode 100644 src/fim/FIMsrc/prep/ssfc2icos/Makefile delete mode 100644 src/fim/FIMsrc/prep/ssfc2icos/newname.F90 delete mode 100644 src/fim/FIMsrc/prep/ssfc2icos/read_mtnvar.F90 delete mode 100644 src/fim/FIMsrc/prep/ssfc2icos/ssfc2icos.F90 delete mode 100644 src/fim/FIMsrc/sys_share/Makefile delete mode 100644 src/fim/FIMsrc/sys_share/sys_share.F90 delete mode 100755 src/fim/FIMsrc/tools/mkDepends delete mode 100644 src/fim/FIMsrc/utils/GetChemEnabled.F90 delete mode 100644 src/fim/FIMsrc/utils/GetComputeTasks.F90 delete mode 100644 src/fim/FIMsrc/utils/GetDATADIR.F90 delete mode 100644 src/fim/FIMsrc/utils/GetDATADR2.F90 delete mode 100644 src/fim/FIMsrc/utils/GetFIMDIR.F90 delete mode 100644 src/fim/FIMsrc/utils/GetGLVL.F90 delete mode 100644 src/fim/FIMsrc/utils/GetNIP.F90 delete mode 100644 src/fim/FIMsrc/utils/GetNVL.F90 delete mode 100644 src/fim/FIMsrc/utils/GetPREPDIR.F90 delete mode 100644 src/fim/FIMsrc/utils/GetParallelism.F90 delete mode 100644 src/fim/FIMsrc/utils/GetQueueTime.F90 delete mode 100644 src/fim/FIMsrc/utils/GetSRCDIR.F90 delete mode 100644 src/fim/FIMsrc/utils/GetWRFcuEnabled.F90 delete mode 100644 src/fim/FIMsrc/utils/GetWRFmpEnabled.F90 delete mode 100644 src/fim/FIMsrc/utils/GetWriteTaskInfo.F90 delete mode 100644 src/fim/FIMsrc/utils/Makefile delete mode 100755 src/fim/FIMsrc/utils/extract_atcf.F90 delete mode 100644 src/fim/FIMsrc/utils/get_num_cores.F90 delete mode 100644 src/fim/FIMsrc/utils/headers.F90 delete mode 100644 src/fim/FIMsrc/utils/module_initial_chem_namelists.F90 delete mode 100644 src/fim/FIMsrc/utils/read_queue_namelist.F90 delete mode 100644 src/fim/FIMsrc/utils/reduce.F90 delete mode 100644 src/fim/FIMsrc/utils/wtinfo.F90 delete mode 100644 src/fim/FIMsrc/w3/CFILES/dbn_alert.c delete mode 100644 src/fim/FIMsrc/w3/CFILES/mova2i.c delete mode 100755 src/fim/FIMsrc/w3/CFILES/summary.c delete mode 100644 src/fim/FIMsrc/w3/GetJdate.f delete mode 100644 src/fim/FIMsrc/w3/Makefile delete mode 100644 src/fim/FIMsrc/w3/MovChar.F90 delete mode 100644 src/fim/FIMsrc/w3/README.w3 delete mode 100644 src/fim/FIMsrc/w3/aea.f delete mode 100644 src/fim/FIMsrc/w3/args_mod.f delete mode 100644 src/fim/FIMsrc/w3/errexit.f delete mode 100644 src/fim/FIMsrc/w3/errmsg.f delete mode 100644 src/fim/FIMsrc/w3/fparsei.f delete mode 100644 src/fim/FIMsrc/w3/fparser.f delete mode 100644 src/fim/FIMsrc/w3/gblevents.f delete mode 100644 src/fim/FIMsrc/w3/gbyte.f delete mode 100644 src/fim/FIMsrc/w3/gbytes.f delete mode 100644 src/fim/FIMsrc/w3/gbytes_char.f delete mode 100644 src/fim/FIMsrc/w3/getbit.f delete mode 100644 src/fim/FIMsrc/w3/getgb.f delete mode 100644 src/fim/FIMsrc/w3/getgb1.f delete mode 100644 src/fim/FIMsrc/w3/getgb1r.f delete mode 100644 src/fim/FIMsrc/w3/getgb1re.f delete mode 100644 src/fim/FIMsrc/w3/getgb1s.f delete mode 100644 src/fim/FIMsrc/w3/getgbe.f delete mode 100644 src/fim/FIMsrc/w3/getgbeh.f delete mode 100644 src/fim/FIMsrc/w3/getgbem.f delete mode 100644 src/fim/FIMsrc/w3/getgbemh.f delete mode 100644 src/fim/FIMsrc/w3/getgbemn.f delete mode 100644 src/fim/FIMsrc/w3/getgbemp.f delete mode 100644 src/fim/FIMsrc/w3/getgbens.f delete mode 100644 src/fim/FIMsrc/w3/getgbep.f delete mode 100644 src/fim/FIMsrc/w3/getgbex.f delete mode 100644 src/fim/FIMsrc/w3/getgbexm.f delete mode 100644 src/fim/FIMsrc/w3/getgbh.f delete mode 100644 src/fim/FIMsrc/w3/getgbm.f delete mode 100644 src/fim/FIMsrc/w3/getgbmh.f delete mode 100644 src/fim/FIMsrc/w3/getgbmp.f delete mode 100644 src/fim/FIMsrc/w3/getgbp.f delete mode 100644 src/fim/FIMsrc/w3/getgi.f delete mode 100644 src/fim/FIMsrc/w3/getgir.f delete mode 100644 src/fim/FIMsrc/w3/gtbits.f delete mode 100644 src/fim/FIMsrc/w3/hostname.f delete mode 100644 src/fim/FIMsrc/w3/idsdef.f delete mode 100644 src/fim/FIMsrc/w3/instrument.f delete mode 100644 src/fim/FIMsrc/w3/isrchne.f delete mode 100644 src/fim/FIMsrc/w3/iw3jdn.f delete mode 100644 src/fim/FIMsrc/w3/iw3mat.f delete mode 100644 src/fim/FIMsrc/w3/iw3pds.f delete mode 100644 src/fim/FIMsrc/w3/iw3unp29.f delete mode 100644 src/fim/FIMsrc/w3/ixgb.f delete mode 100644 src/fim/FIMsrc/w3/jdate.F90 delete mode 100644 src/fim/FIMsrc/w3/lengds.f delete mode 100644 src/fim/FIMsrc/w3/makwmo.f delete mode 100644 src/fim/FIMsrc/w3/mersenne_twister.f delete mode 100644 src/fim/FIMsrc/w3/mkfldsep.f delete mode 100644 src/fim/FIMsrc/w3/mova2i.f delete mode 100644 src/fim/FIMsrc/w3/orders.f delete mode 100644 src/fim/FIMsrc/w3/pdsens.f delete mode 100644 src/fim/FIMsrc/w3/pdseup.f delete mode 100644 src/fim/FIMsrc/w3/putgb.f delete mode 100644 src/fim/FIMsrc/w3/putgbe.f delete mode 100644 src/fim/FIMsrc/w3/putgben.f delete mode 100644 src/fim/FIMsrc/w3/putgbens.f delete mode 100644 src/fim/FIMsrc/w3/putgbex.f delete mode 100644 src/fim/FIMsrc/w3/putgbn.f delete mode 100644 src/fim/FIMsrc/w3/q9ie32.f delete mode 100644 src/fim/FIMsrc/w3/r63w72.f delete mode 100644 src/fim/FIMsrc/w3/sbyte.f delete mode 100644 src/fim/FIMsrc/w3/sbytes.f delete mode 100644 src/fim/FIMsrc/w3/skgb.f delete mode 100644 src/fim/FIMsrc/w3/start.f delete mode 100644 src/fim/FIMsrc/w3/summary.c.sav delete mode 100644 src/fim/FIMsrc/w3/summary.f delete mode 100644 src/fim/FIMsrc/w3/w3ai00.f delete mode 100644 src/fim/FIMsrc/w3/w3ai01.f delete mode 100644 src/fim/FIMsrc/w3/w3ai08.f delete mode 100644 src/fim/FIMsrc/w3/w3ai15.f delete mode 100644 src/fim/FIMsrc/w3/w3ai18.f delete mode 100644 src/fim/FIMsrc/w3/w3ai19.f delete mode 100644 src/fim/FIMsrc/w3/w3ai24.f delete mode 100644 src/fim/FIMsrc/w3/w3ai38.f delete mode 100644 src/fim/FIMsrc/w3/w3ai39.f delete mode 100644 src/fim/FIMsrc/w3/w3ai40.f delete mode 100644 src/fim/FIMsrc/w3/w3ai41.f delete mode 100644 src/fim/FIMsrc/w3/w3aq15.f delete mode 100644 src/fim/FIMsrc/w3/w3as00.f delete mode 100644 src/fim/FIMsrc/w3/w3ctzdat.f delete mode 100644 src/fim/FIMsrc/w3/w3difdat.f delete mode 100644 src/fim/FIMsrc/w3/w3doxdat.f delete mode 100644 src/fim/FIMsrc/w3/w3fa01.f delete mode 100644 src/fim/FIMsrc/w3/w3fa03.f delete mode 100644 src/fim/FIMsrc/w3/w3fa03v.f delete mode 100644 src/fim/FIMsrc/w3/w3fa04.f delete mode 100644 src/fim/FIMsrc/w3/w3fa06.f delete mode 100644 src/fim/FIMsrc/w3/w3fa09.f delete mode 100644 src/fim/FIMsrc/w3/w3fa11.f delete mode 100644 src/fim/FIMsrc/w3/w3fa12.f delete mode 100644 src/fim/FIMsrc/w3/w3fa13.f delete mode 100644 src/fim/FIMsrc/w3/w3fb00.f delete mode 100644 src/fim/FIMsrc/w3/w3fb01.f delete mode 100644 src/fim/FIMsrc/w3/w3fb02.f delete mode 100644 src/fim/FIMsrc/w3/w3fb03.f delete mode 100644 src/fim/FIMsrc/w3/w3fb04.f delete mode 100644 src/fim/FIMsrc/w3/w3fb05.f delete mode 100644 src/fim/FIMsrc/w3/w3fb06.f delete mode 100644 src/fim/FIMsrc/w3/w3fb07.f delete mode 100644 src/fim/FIMsrc/w3/w3fb08.f delete mode 100644 src/fim/FIMsrc/w3/w3fb09.f delete mode 100644 src/fim/FIMsrc/w3/w3fb10.f delete mode 100644 src/fim/FIMsrc/w3/w3fb11.f delete mode 100644 src/fim/FIMsrc/w3/w3fb12.f delete mode 100644 src/fim/FIMsrc/w3/w3fc02.f delete mode 100644 src/fim/FIMsrc/w3/w3fc05.f delete mode 100644 src/fim/FIMsrc/w3/w3fc06.f delete mode 100644 src/fim/FIMsrc/w3/w3fc07.f delete mode 100644 src/fim/FIMsrc/w3/w3fc08.f delete mode 100644 src/fim/FIMsrc/w3/w3fi01.f delete mode 100644 src/fim/FIMsrc/w3/w3fi02.f delete mode 100644 src/fim/FIMsrc/w3/w3fi03.f delete mode 100644 src/fim/FIMsrc/w3/w3fi04.f delete mode 100644 src/fim/FIMsrc/w3/w3fi18.f delete mode 100644 src/fim/FIMsrc/w3/w3fi19.f delete mode 100644 src/fim/FIMsrc/w3/w3fi20.f delete mode 100644 src/fim/FIMsrc/w3/w3fi32.f delete mode 100644 src/fim/FIMsrc/w3/w3fi47.f delete mode 100644 src/fim/FIMsrc/w3/w3fi48.f delete mode 100644 src/fim/FIMsrc/w3/w3fi52.f delete mode 100644 src/fim/FIMsrc/w3/w3fi58.f delete mode 100644 src/fim/FIMsrc/w3/w3fi59.f delete mode 100644 src/fim/FIMsrc/w3/w3fi61.f delete mode 100644 src/fim/FIMsrc/w3/w3fi62.f delete mode 100644 src/fim/FIMsrc/w3/w3fi63.f delete mode 100644 src/fim/FIMsrc/w3/w3fi64.f delete mode 100644 src/fim/FIMsrc/w3/w3fi65.f delete mode 100644 src/fim/FIMsrc/w3/w3fi66.f delete mode 100644 src/fim/FIMsrc/w3/w3fi67.f delete mode 100644 src/fim/FIMsrc/w3/w3fi68.f delete mode 100644 src/fim/FIMsrc/w3/w3fi69.f delete mode 100644 src/fim/FIMsrc/w3/w3fi70.f delete mode 100644 src/fim/FIMsrc/w3/w3fi71.f delete mode 100644 src/fim/FIMsrc/w3/w3fi72.f delete mode 100644 src/fim/FIMsrc/w3/w3fi73.f delete mode 100644 src/fim/FIMsrc/w3/w3fi74.f delete mode 100644 src/fim/FIMsrc/w3/w3fi75.f delete mode 100644 src/fim/FIMsrc/w3/w3fi76.f delete mode 100644 src/fim/FIMsrc/w3/w3fi78.f delete mode 100644 src/fim/FIMsrc/w3/w3fi81.f.sav delete mode 100644 src/fim/FIMsrc/w3/w3fi81.f.save delete mode 100644 src/fim/FIMsrc/w3/w3fi82.f delete mode 100644 src/fim/FIMsrc/w3/w3fi83.f delete mode 100644 src/fim/FIMsrc/w3/w3fi85.f delete mode 100644 src/fim/FIMsrc/w3/w3fi88.f delete mode 100644 src/fim/FIMsrc/w3/w3fi92.f delete mode 100644 src/fim/FIMsrc/w3/w3fm07.f delete mode 100644 src/fim/FIMsrc/w3/w3fm08.f delete mode 100644 src/fim/FIMsrc/w3/w3fp04.f delete mode 100644 src/fim/FIMsrc/w3/w3fp05.f delete mode 100644 src/fim/FIMsrc/w3/w3fp06.f delete mode 100644 src/fim/FIMsrc/w3/w3fp10.f delete mode 100644 src/fim/FIMsrc/w3/w3fp11.f delete mode 100644 src/fim/FIMsrc/w3/w3fp12.f delete mode 100644 src/fim/FIMsrc/w3/w3fp13.f delete mode 100644 src/fim/FIMsrc/w3/w3fq07.f delete mode 100644 src/fim/FIMsrc/w3/w3fs13.f delete mode 100644 src/fim/FIMsrc/w3/w3fs15.f delete mode 100644 src/fim/FIMsrc/w3/w3fs21.f delete mode 100644 src/fim/FIMsrc/w3/w3fs26.f delete mode 100644 src/fim/FIMsrc/w3/w3ft00.f delete mode 100644 src/fim/FIMsrc/w3/w3ft01.f delete mode 100644 src/fim/FIMsrc/w3/w3ft02.f delete mode 100644 src/fim/FIMsrc/w3/w3ft03.f delete mode 100644 src/fim/FIMsrc/w3/w3ft05.f delete mode 100644 src/fim/FIMsrc/w3/w3ft05v.f delete mode 100644 src/fim/FIMsrc/w3/w3ft06.f delete mode 100644 src/fim/FIMsrc/w3/w3ft06v.f delete mode 100644 src/fim/FIMsrc/w3/w3ft07.f delete mode 100644 src/fim/FIMsrc/w3/w3ft08.f delete mode 100644 src/fim/FIMsrc/w3/w3ft09.f delete mode 100644 src/fim/FIMsrc/w3/w3ft10.f delete mode 100644 src/fim/FIMsrc/w3/w3ft11.f delete mode 100644 src/fim/FIMsrc/w3/w3ft12.f delete mode 100644 src/fim/FIMsrc/w3/w3ft16.f delete mode 100644 src/fim/FIMsrc/w3/w3ft17.f delete mode 100644 src/fim/FIMsrc/w3/w3ft201.f delete mode 100644 src/fim/FIMsrc/w3/w3ft202.f delete mode 100644 src/fim/FIMsrc/w3/w3ft203.f delete mode 100644 src/fim/FIMsrc/w3/w3ft204.f delete mode 100644 src/fim/FIMsrc/w3/w3ft205.f delete mode 100644 src/fim/FIMsrc/w3/w3ft206.f delete mode 100644 src/fim/FIMsrc/w3/w3ft207.f delete mode 100644 src/fim/FIMsrc/w3/w3ft208.f delete mode 100644 src/fim/FIMsrc/w3/w3ft209.f delete mode 100644 src/fim/FIMsrc/w3/w3ft21.f delete mode 100644 src/fim/FIMsrc/w3/w3ft210.f delete mode 100644 src/fim/FIMsrc/w3/w3ft211.f delete mode 100644 src/fim/FIMsrc/w3/w3ft212.f delete mode 100644 src/fim/FIMsrc/w3/w3ft213.f delete mode 100644 src/fim/FIMsrc/w3/w3ft214.f delete mode 100644 src/fim/FIMsrc/w3/w3ft26.f delete mode 100644 src/fim/FIMsrc/w3/w3ft32.f delete mode 100644 src/fim/FIMsrc/w3/w3ft33.f delete mode 100644 src/fim/FIMsrc/w3/w3ft38.f delete mode 100644 src/fim/FIMsrc/w3/w3ft39.f delete mode 100644 src/fim/FIMsrc/w3/w3ft40.f delete mode 100644 src/fim/FIMsrc/w3/w3ft41.f delete mode 100644 src/fim/FIMsrc/w3/w3ft43v.f delete mode 100644 src/fim/FIMsrc/w3/w3locdat.f delete mode 100644 src/fim/FIMsrc/w3/w3log.f delete mode 100644 src/fim/FIMsrc/w3/w3miscan.f delete mode 100644 src/fim/FIMsrc/w3/w3movdat.f delete mode 100644 src/fim/FIMsrc/w3/w3nogds.f delete mode 100644 src/fim/FIMsrc/w3/w3pradat.f delete mode 100644 src/fim/FIMsrc/w3/w3prrdat.f delete mode 100644 src/fim/FIMsrc/w3/w3reddat.f delete mode 100644 src/fim/FIMsrc/w3/w3tagb.f delete mode 100644 src/fim/FIMsrc/w3/w3trnarg.f delete mode 100644 src/fim/FIMsrc/w3/w3unpk77.f delete mode 100644 src/fim/FIMsrc/w3/w3utcdat.f delete mode 100644 src/fim/FIMsrc/w3/w3valdat.f delete mode 100644 src/fim/FIMsrc/w3/w3ymdh4.f delete mode 100644 src/fim/FIMsrc/w3/xdopen.f delete mode 100644 src/fim/FIMsrc/w3/xmovex.f delete mode 100644 src/fim/FIMsrc/w3/xstore.f delete mode 100644 src/fim/Makefile.am delete mode 100644 src/fim/Makefile.in delete mode 100755 src/fim/diffsrc.ksh delete mode 100644 src/fim/fim_grid_comp.F90 delete mode 100644 src/fim/fim_grid_comp_stub.F90 delete mode 100644 src/fim/fim_internal_state.F90 delete mode 100644 src/fim/module_DYNAMICS_GRID_COMP.F90 delete mode 100644 src/fim/module_DYN_PHY_CPL_COMP.F90 delete mode 100644 src/fim/module_FIM_INTEGRATE.F90 delete mode 100644 src/fim/module_PHYSICS_GRID_COMP.F90 create mode 100644 src/gsm/dyn/indlmod.f delete mode 100644 src/gsm/phys/function2 delete mode 100755 src/gsm/phys/function_indlsev delete mode 100755 src/gsm/phys/function_indlsod create mode 100644 src/gsm/phys/indlmod.f delete mode 100644 src/nmm/Makefile.am delete mode 100644 src/nmm/Makefile.in delete mode 100644 src/nmm/module_BGRID_INTERP.F90 delete mode 100644 src/nmm/module_CLOCKTIMES.F90 delete mode 100644 src/nmm/module_CONSTANTS.F90 delete mode 100644 src/nmm/module_CONTROL.F90 delete mode 100644 src/nmm/module_CONVECTION.F90 delete mode 100644 src/nmm/module_DERIVED_TYPES.F90 delete mode 100644 src/nmm/module_DIAGNOSE.F90 delete mode 100644 src/nmm/module_DIGITAL_FILTER_NMM.F90 delete mode 100644 src/nmm/module_DM_PARALLEL.F90 delete mode 100644 src/nmm/module_DOMAIN_GRID_COMP.F90 delete mode 100644 src/nmm/module_DOMAIN_INTERNAL_STATE.F90 delete mode 100644 src/nmm/module_DOMAIN_NUOPC_SET.F90 delete mode 100644 src/nmm/module_DOMAIN_TASK_SPECS.F90 delete mode 100644 src/nmm/module_DYNAMICS_ROUTINES.F90 delete mode 100644 src/nmm/module_ERROR_MSG.F90 delete mode 100644 src/nmm/module_EXCHANGE.F90 delete mode 100644 src/nmm/module_FLTBNDS.F90 delete mode 100644 src/nmm/module_GET_CONFIG.F90 delete mode 100644 src/nmm/module_GET_CONFIG_WRITE.F90 delete mode 100644 src/nmm/module_GWD.F90 delete mode 100644 src/nmm/module_H_TO_V.F90 delete mode 100644 src/nmm/module_INIT_READ_BIN.F90 delete mode 100644 src/nmm/module_INIT_READ_NEMSIO.F90 delete mode 100644 src/nmm/module_MICROPHYSICS.F90 delete mode 100644 src/nmm/module_MY_DOMAIN_SPECS.F90 delete mode 100644 src/nmm/module_NESTING.F90 delete mode 100644 src/nmm/module_NMM_GRID_COMP.F90 delete mode 100644 src/nmm/module_NMM_GRID_COMP_stub.F90 delete mode 100644 src/nmm/module_NMM_INTEGRATE.F90 delete mode 100644 src/nmm/module_NMM_INTERNAL_STATE.F90 delete mode 100644 src/nmm/module_OUTPUT.F90 delete mode 100644 src/nmm/module_PARENT_CHILD_CPL_COMP.F90 delete mode 100644 src/nmm/module_PRECIP_ADJUST.F90 delete mode 100644 src/nmm/module_QUASIPOST.F90 delete mode 100644 src/nmm/module_RADIATION.F90 delete mode 100644 src/nmm/module_REDUCTION.F90 delete mode 100644 src/nmm/module_RELAX4E.F90 delete mode 100644 src/nmm/module_SOLVER_GRID_COMP.F90 delete mode 100644 src/nmm/module_SOLVER_INTERNAL_STATE.F90 delete mode 100644 src/nmm/module_TIMESERIES.F90 delete mode 100644 src/nmm/module_TRACKER.F90 delete mode 100644 src/nmm/module_TURBULENCE.F90 delete mode 100644 src/nmm/module_VARS.F90 delete mode 100644 src/nmm/module_VARS_STATE.F90 delete mode 100644 src/nmm/module_WRITE_GRID_COMP.F90 delete mode 100644 src/nmm/module_WRITE_INTERNAL_STATE.F90 delete mode 100644 src/nmm/module_WRITE_ROUTINES.F90 delete mode 100644 src/nmm/n_compns_physics.f delete mode 100644 src/nmm/n_layout1.f delete mode 100644 src/nmm/n_module_gfs_mpi_def.f delete mode 100644 src/nmm/n_mpi_def.f delete mode 100644 src/nmm/n_mpi_quit.f delete mode 100644 src/nmm/n_namelist_physics_def.f delete mode 100644 src/nmm/n_resol_def.f diff --git a/aclocal.m4 b/aclocal.m4 index 4da2f9a..0741330 100644 --- a/aclocal.m4 +++ b/aclocal.m4 @@ -162,9 +162,10 @@ AC_SUBST([AR])dnl # configured tree to be moved without reconfiguration. AC_DEFUN([AM_AUX_DIR_EXPAND], -[AC_REQUIRE([AC_CONFIG_AUX_DIR_DEFAULT])dnl -# Expand $ac_aux_dir to an absolute path. -am_aux_dir=`cd "$ac_aux_dir" && pwd` +[dnl Rely on autoconf to set up CDPATH properly. +AC_PREREQ([2.50])dnl +# expand $ac_aux_dir to an absolute path +am_aux_dir=`cd $ac_aux_dir && pwd` ]) # AM_CONDITIONAL -*- Autoconf -*- diff --git a/build-aux/config.guess b/build-aux/config.guess index c6fad2f..b79252d 100755 --- a/build-aux/config.guess +++ b/build-aux/config.guess @@ -153,16 +153,6 @@ Linux|GNU|GNU/*) ;; esac -case "${UNAME_MACHINE}" in - i?86) - test -z "$VENDOR" && VENDOR=pc - ;; - *) - test -z "$VENDOR" && VENDOR=unknown - ;; -esac -test -f /etc/SuSE-release -o -f /.buildenv && VENDOR=suse - # Note: order is significant - the case branches are not exclusive. case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in @@ -227,23 +217,23 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in exit ;; *:Bitrig:*:*) UNAME_MACHINE_ARCH=`arch | sed 's/Bitrig.//'` - echo ${UNAME_MACHINE_ARCH}-${VENDOR}-bitrig${UNAME_RELEASE} + echo ${UNAME_MACHINE_ARCH}-unknown-bitrig${UNAME_RELEASE} exit ;; *:OpenBSD:*:*) UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'` - echo ${UNAME_MACHINE_ARCH}-${VENDOR}-openbsd${UNAME_RELEASE} + echo ${UNAME_MACHINE_ARCH}-unknown-openbsd${UNAME_RELEASE} exit ;; *:ekkoBSD:*:*) - echo ${UNAME_MACHINE}-${VENDOR}-ekkobsd${UNAME_RELEASE} + echo ${UNAME_MACHINE}-unknown-ekkobsd${UNAME_RELEASE} exit ;; *:SolidBSD:*:*) - echo ${UNAME_MACHINE}-${VENDOR}-solidbsd${UNAME_RELEASE} + echo ${UNAME_MACHINE}-unknown-solidbsd${UNAME_RELEASE} exit ;; macppc:MirBSD:*:*) - echo powerpc-${VENDOR}-mirbsd${UNAME_RELEASE} + echo powerpc-unknown-mirbsd${UNAME_RELEASE} exit ;; *:MirBSD:*:*) - echo ${UNAME_MACHINE}-${VENDOR}-mirbsd${UNAME_RELEASE} + echo ${UNAME_MACHINE}-unknown-mirbsd${UNAME_RELEASE} exit ;; alpha:OSF1:*:*) case $UNAME_RELEASE in @@ -311,13 +301,13 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in echo alpha-dec-winnt3.5 exit ;; Amiga*:UNIX_System_V:4.0:*) - echo m68k-${VENDOR}-sysv4 + echo m68k-unknown-sysv4 exit ;; *:[Aa]miga[Oo][Ss]:*:*) - echo ${UNAME_MACHINE}-${VENDOR}-amigaos + echo ${UNAME_MACHINE}-unknown-amigaos exit ;; *:[Mm]orph[Oo][Ss]:*:*) - echo ${UNAME_MACHINE}-${VENDOR}-morphos + echo ${UNAME_MACHINE}-unknown-morphos exit ;; *:OS/390:*:*) echo i370-ibm-openedition @@ -332,7 +322,7 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in echo arm-acorn-riscix${UNAME_RELEASE} exit ;; arm*:riscos:*:*|arm*:RISCOS:*:*) - echo arm-${VENDOR}-riscos + echo arm-unknown-riscos exit ;; SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*) echo hppa1.1-hitachi-hiuxmpp @@ -440,7 +430,7 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in echo m68k-hades-mint${UNAME_RELEASE} exit ;; *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*) - echo m68k-${VENDOR}-mint${UNAME_RELEASE} + echo m68k-unknown-mint${UNAME_RELEASE} exit ;; m68k:machten:*:*) echo m68k-apple-machten${UNAME_RELEASE} @@ -751,9 +741,9 @@ EOF exit ;; i*86:OSF1:*:*) if [ -x /usr/sbin/sysversion ] ; then - echo ${UNAME_MACHINE}-${VENDOR}-osf1mk + echo ${UNAME_MACHINE}-unknown-osf1mk else - echo ${UNAME_MACHINE}-${VENDOR}-osf1 + echo ${UNAME_MACHINE}-unknown-osf1 fi exit ;; parisc*:Lites*:*:*) @@ -813,18 +803,18 @@ EOF echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE} exit ;; sparc*:BSD/OS:*:*) - echo sparc-${VENDOR}-bsdi${UNAME_RELEASE} + echo sparc-unknown-bsdi${UNAME_RELEASE} exit ;; *:BSD/OS:*:*) - echo ${UNAME_MACHINE}-${VENDOR}-bsdi${UNAME_RELEASE} + echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} exit ;; *:FreeBSD:*:*) UNAME_PROCESSOR=`/usr/bin/uname -p` case ${UNAME_PROCESSOR} in amd64) - echo x86_64-${VENDOR}-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; + echo x86_64-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; *) - echo ${UNAME_PROCESSOR}-${VENDOR}-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; + echo ${UNAME_PROCESSOR}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; esac exit ;; i*:CYGWIN*:*) @@ -852,10 +842,10 @@ EOF echo i586-pc-interix${UNAME_RELEASE} exit ;; authenticamd | genuineintel | EM64T) - echo x86_64-${VENDOR}-interix${UNAME_RELEASE} + echo x86_64-unknown-interix${UNAME_RELEASE} exit ;; IA64) - echo ia64-${VENDOR}-interix${UNAME_RELEASE} + echo ia64-unknown-interix${UNAME_RELEASE} exit ;; esac ;; [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*) @@ -874,31 +864,31 @@ EOF echo ${UNAME_MACHINE}-pc-uwin exit ;; amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*) - echo x86_64-${VENDOR}-cygwin + echo x86_64-unknown-cygwin exit ;; p*:CYGWIN*:*) - echo powerpcle-${VENDOR}-cygwin + echo powerpcle-unknown-cygwin exit ;; prep*:SunOS:5.*:*) - echo powerpcle-${VENDOR}-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; *:GNU:*:*) # the GNU system - echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-${VENDOR}-${LIBC}`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` + echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-${LIBC}`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` exit ;; *:GNU/*:*:*) # other systems with GNU libc and userland - echo ${UNAME_MACHINE}-${VENDOR}-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-${LIBC} + echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-${LIBC} exit ;; i*86:Minix:*:*) echo ${UNAME_MACHINE}-pc-minix exit ;; aarch64:Linux:*:*) - echo ${UNAME_MACHINE}-${VENDOR}-linux-${LIBC} + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; aarch64_be:Linux:*:*) UNAME_MACHINE=aarch64_be - echo ${UNAME_MACHINE}-${VENDOR}-linux-${LIBC} + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; alpha:Linux:*:*) case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in @@ -912,29 +902,29 @@ EOF esac objdump --private-headers /bin/sh | grep -q ld.so.1 if test "$?" = 0 ; then LIBC="gnulibc1" ; fi - echo ${UNAME_MACHINE}-${VENDOR}-linux-${LIBC} + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; arc:Linux:*:* | arceb:Linux:*:*) - echo ${UNAME_MACHINE}-${VENDOR}-linux-${LIBC} + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; arm*:Linux:*:*) eval $set_cc_for_build if echo __ARM_EABI__ | $CC_FOR_BUILD -E - 2>/dev/null \ | grep -q __ARM_EABI__ then - echo ${UNAME_MACHINE}-${VENDOR}-linux-${LIBC} + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} else if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \ | grep -q __ARM_PCS_VFP then - echo ${UNAME_MACHINE}-${VENDOR}-linux-${LIBC}eabi + echo ${UNAME_MACHINE}-unknown-linux-${LIBC}eabi else - echo ${UNAME_MACHINE}-${VENDOR}-linux-${LIBC}eabihf + echo ${UNAME_MACHINE}-unknown-linux-${LIBC}eabihf fi fi exit ;; avr32*:Linux:*:*) - echo ${UNAME_MACHINE}-${VENDOR}-linux-${LIBC} + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; cris:Linux:*:*) echo ${UNAME_MACHINE}-axis-linux-${LIBC} @@ -943,22 +933,22 @@ EOF echo ${UNAME_MACHINE}-axis-linux-${LIBC} exit ;; frv:Linux:*:*) - echo ${UNAME_MACHINE}-${VENDOR}-linux-${LIBC} + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; hexagon:Linux:*:*) - echo ${UNAME_MACHINE}-${VENDOR}-linux-${LIBC} + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; i*86:Linux:*:*) echo ${UNAME_MACHINE}-pc-linux-${LIBC} exit ;; ia64:Linux:*:*) - echo ${UNAME_MACHINE}-${VENDOR}-linux-${LIBC} + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; m32r*:Linux:*:*) - echo ${UNAME_MACHINE}-${VENDOR}-linux-${LIBC} + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; m68*:Linux:*:*) - echo ${UNAME_MACHINE}-${VENDOR}-linux-${LIBC} + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; mips:Linux:*:* | mips64:Linux:*:*) eval $set_cc_for_build @@ -977,63 +967,63 @@ EOF #endif EOF eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^CPU'` - test x"${CPU}" != x && { echo "${CPU}-${VENDOR}-linux-${LIBC}"; exit; } + test x"${CPU}" != x && { echo "${CPU}-unknown-linux-${LIBC}"; exit; } ;; or1k:Linux:*:*) - echo ${UNAME_MACHINE}-${VENDOR}-linux-${LIBC} + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; or32:Linux:*:*) - echo ${UNAME_MACHINE}-${VENDOR}-linux-${LIBC} + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; padre:Linux:*:*) - echo sparc-${VENDOR}-linux-${LIBC} + echo sparc-unknown-linux-${LIBC} exit ;; parisc64:Linux:*:* | hppa64:Linux:*:*) - echo hppa64-${VENDOR}-linux-${LIBC} + echo hppa64-unknown-linux-${LIBC} exit ;; parisc:Linux:*:* | hppa:Linux:*:*) # Look for CPU level case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in - PA7*) echo hppa1.1-${VENDOR}-linux-${LIBC} ;; - PA8*) echo hppa2.0-${VENDOR}-linux-${LIBC} ;; - *) echo hppa-${VENDOR}-linux-${LIBC} ;; + PA7*) echo hppa1.1-unknown-linux-${LIBC} ;; + PA8*) echo hppa2.0-unknown-linux-${LIBC} ;; + *) echo hppa-unknown-linux-${LIBC} ;; esac exit ;; ppc64:Linux:*:*) - echo powerpc64-${VENDOR}-linux-${LIBC} + echo powerpc64-unknown-linux-${LIBC} exit ;; ppc:Linux:*:*) - echo powerpc-${VENDOR}-linux-${LIBC} + echo powerpc-unknown-linux-${LIBC} exit ;; ppc64le:Linux:*:*) - echo powerpc64le-${VENDOR}-linux-${LIBC} + echo powerpc64le-unknown-linux-${LIBC} exit ;; ppcle:Linux:*:*) - echo powerpcle-${VENDOR}-linux-${LIBC} + echo powerpcle-unknown-linux-${LIBC} exit ;; s390:Linux:*:* | s390x:Linux:*:*) echo ${UNAME_MACHINE}-ibm-linux-${LIBC} exit ;; sh64*:Linux:*:*) - echo ${UNAME_MACHINE}-${VENDOR}-linux-${LIBC} + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; sh*:Linux:*:*) - echo ${UNAME_MACHINE}-${VENDOR}-linux-${LIBC} + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; sparc:Linux:*:* | sparc64:Linux:*:*) - echo ${UNAME_MACHINE}-${VENDOR}-linux-${LIBC} + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; tile*:Linux:*:*) - echo ${UNAME_MACHINE}-${VENDOR}-linux-${LIBC} + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; vax:Linux:*:*) echo ${UNAME_MACHINE}-dec-linux-${LIBC} exit ;; x86_64:Linux:*:*) - echo ${UNAME_MACHINE}-${VENDOR}-linux-${LIBC} + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; xtensa*:Linux:*:*) - echo ${UNAME_MACHINE}-${VENDOR}-linux-${LIBC} + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; i*86:DYNIX/ptx:4*:*) # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. @@ -1055,16 +1045,16 @@ EOF echo ${UNAME_MACHINE}-pc-os2-emx exit ;; i*86:XTS-300:*:STOP) - echo ${UNAME_MACHINE}-${VENDOR}-stop + echo ${UNAME_MACHINE}-unknown-stop exit ;; i*86:atheos:*:*) - echo ${UNAME_MACHINE}-${VENDOR}-atheos + echo ${UNAME_MACHINE}-unknown-atheos exit ;; i*86:syllable:*:*) echo ${UNAME_MACHINE}-pc-syllable exit ;; i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.[02]*:*) - echo i386-${VENODR}-lynxos${UNAME_RELEASE} + echo i386-unknown-lynxos${UNAME_RELEASE} exit ;; i*86:*DOS:*:*) echo ${UNAME_MACHINE}-pc-msdosdjgpp @@ -1084,7 +1074,7 @@ EOF *Pentium) UNAME_MACHINE=i586 ;; *Pent*|*Celeron) UNAME_MACHINE=i686 ;; esac - echo ${UNAME_MACHINE}-${VENDOR}-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} + echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} exit ;; i*86:*:3.2:*) if test -f /usr/options/cb.name; then @@ -1123,7 +1113,7 @@ EOF if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4 else # Add other i860-SVR4 vendors below as they are discovered. - echo i860-${VENODR}-sysv${UNAME_RELEASE} # Unknown i860-SVR4 + echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4 fi exit ;; mini*:CTIX:SYS*5:*) @@ -1160,19 +1150,19 @@ EOF /bin/uname -p 2>/dev/null | /bin/grep pteron >/dev/null \ && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*) - echo m68k-${VENDOR}-lynxos${UNAME_RELEASE} + echo m68k-unknown-lynxos${UNAME_RELEASE} exit ;; mc68030:UNIX_System_V:4.*:*) echo m68k-atari-sysv4 exit ;; TSUNAMI:LynxOS:2.*:*) - echo sparc-${VENDOR}-lynxos${UNAME_RELEASE} + echo sparc-unknown-lynxos${UNAME_RELEASE} exit ;; rs6000:LynxOS:2.*:*) - echo rs6000-${VENDOR}-lynxos${UNAME_RELEASE} + echo rs6000-unknown-lynxos${UNAME_RELEASE} exit ;; PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.[02]*:*) - echo powerpc-${VENDOR}-lynxos${UNAME_RELEASE} + echo powerpc-unknown-lynxos${UNAME_RELEASE} exit ;; SM[BE]S:UNIX_SV:*:*) echo mips-dde-sysv${UNAME_RELEASE} @@ -1222,7 +1212,7 @@ EOF if [ -d /usr/nec ]; then echo mips-nec-sysv${UNAME_RELEASE} else - echo mips-${VENDOR}-sysv${UNAME_RELEASE} + echo mips-unknown-sysv${UNAME_RELEASE} fi exit ;; BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. @@ -1238,7 +1228,7 @@ EOF echo i586-pc-haiku exit ;; x86_64:Haiku:*:*) - echo x86_64-${VENDOR}-haiku + echo x86_64-unknown-haiku exit ;; SX-4:SUPER-UX:*:*) echo sx4-nec-superux${UNAME_RELEASE} @@ -1321,13 +1311,13 @@ EOF else UNAME_MACHINE="$cputype" fi - echo ${UNAME_MACHINE}-${VENDOR}-plan9 + echo ${UNAME_MACHINE}-unknown-plan9 exit ;; *:TOPS-10:*:*) - echo pdp10-${VENDOR}-tops10 + echo pdp10-unknown-tops10 exit ;; *:TENEX:*:*) - echo pdp10-${VENDOR}-tenex + echo pdp10-unknown-tenex exit ;; KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*) echo pdp10-dec-tops20 @@ -1336,16 +1326,16 @@ EOF echo pdp10-xkl-tops20 exit ;; *:TOPS-20:*:*) - echo pdp10-${VENDOR}-tops20 + echo pdp10-unknown-tops20 exit ;; *:ITS:*:*) - echo pdp10-${VENDOR}-its + echo pdp10-unknown-its exit ;; SEI:*:*:SEIUX) echo mips-sei-seiux${UNAME_RELEASE} exit ;; *:DragonFly:*:*) - echo ${UNAME_MACHINE}-${VENDOR}-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` + echo ${UNAME_MACHINE}-unknown-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` exit ;; *:*VMS:*:*) UNAME_MACHINE=`(uname -p) 2>/dev/null` @@ -1367,7 +1357,7 @@ EOF echo ${UNAME_MACHINE}-pc-aros exit ;; x86_64:VMkernel:*:*) - echo ${UNAME_MACHINE}-${VENDOR}-esx + echo ${UNAME_MACHINE}-unknown-esx exit ;; esac diff --git a/build-aux/config.sub b/build-aux/config.sub index 8b612ab..c765b34 100755 --- a/build-aux/config.sub +++ b/build-aux/config.sub @@ -1006,7 +1006,7 @@ case $basic_machine in ;; ppc64) basic_machine=powerpc64-unknown ;; - ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'` + ppc64-* | ppc64p7-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'` ;; ppc64le | powerpc64little | ppc64-le | powerpc64-little) basic_machine=powerpc64le-unknown diff --git a/configure b/configure index 65c350d..f806265 100755 --- a/configure +++ b/configure @@ -2508,8 +2508,8 @@ test "$program_suffix" != NONE && ac_script='s/[\\$]/&&/g;s/;s,x,x,$//' program_transform_name=`$as_echo "$program_transform_name" | sed "$ac_script"` -# Expand $ac_aux_dir to an absolute path. -am_aux_dir=`cd "$ac_aux_dir" && pwd` +# expand $ac_aux_dir to an absolute path +am_aux_dir=`cd $ac_aux_dir && pwd` if test x"${MISSING+set}" != xset; then case $am_aux_dir in @@ -8983,7 +8983,7 @@ esac # Output Makefiles -ac_config_files="$ac_config_files Makefile src/Makefile src/fim/Makefile src/gen/Makefile src/gsm/Makefile src/gsm/dyn/Makefile src/gsm/libutil/Makefile src/gsm/phys/Makefile src/io/Makefile src/nmm/Makefile src/phys/Makefile src/post/Makefile src/share/Makefile" +ac_config_files="$ac_config_files Makefile src/Makefile src/gen/Makefile src/gsm/Makefile src/gsm/dyn/Makefile src/gsm/libutil/Makefile src/gsm/phys/Makefile src/io/Makefile src/phys/Makefile src/post/Makefile src/share/Makefile" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure @@ -9737,14 +9737,12 @@ do "depfiles") CONFIG_COMMANDS="$CONFIG_COMMANDS depfiles" ;; "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;; "src/Makefile") CONFIG_FILES="$CONFIG_FILES src/Makefile" ;; - "src/fim/Makefile") CONFIG_FILES="$CONFIG_FILES src/fim/Makefile" ;; "src/gen/Makefile") CONFIG_FILES="$CONFIG_FILES src/gen/Makefile" ;; "src/gsm/Makefile") CONFIG_FILES="$CONFIG_FILES src/gsm/Makefile" ;; "src/gsm/dyn/Makefile") CONFIG_FILES="$CONFIG_FILES src/gsm/dyn/Makefile" ;; "src/gsm/libutil/Makefile") CONFIG_FILES="$CONFIG_FILES src/gsm/libutil/Makefile" ;; "src/gsm/phys/Makefile") CONFIG_FILES="$CONFIG_FILES src/gsm/phys/Makefile" ;; "src/io/Makefile") CONFIG_FILES="$CONFIG_FILES src/io/Makefile" ;; - "src/nmm/Makefile") CONFIG_FILES="$CONFIG_FILES src/nmm/Makefile" ;; "src/phys/Makefile") CONFIG_FILES="$CONFIG_FILES src/phys/Makefile" ;; "src/post/Makefile") CONFIG_FILES="$CONFIG_FILES src/post/Makefile" ;; "src/share/Makefile") CONFIG_FILES="$CONFIG_FILES src/share/Makefile" ;; diff --git a/configure.ac b/configure.ac index 0a9a6c1..dd5bede 100644 --- a/configure.ac +++ b/configure.ac @@ -271,14 +271,12 @@ AM_PROG_AR # Output Makefiles AC_CONFIG_FILES([Makefile src/Makefile - src/fim/Makefile src/gen/Makefile src/gsm/Makefile src/gsm/dyn/Makefile src/gsm/libutil/Makefile src/gsm/phys/Makefile src/io/Makefile - src/nmm/Makefile src/phys/Makefile src/post/Makefile src/share/Makefile]) diff --git a/src/Makefile.am b/src/Makefile.am index ed89d22..360e653 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -1,22 +1,20 @@ -SUBDIRS = post share phys io fim gen gsm nmm . +SUBDIRS = post share phys io gen gsm . lib_LIBRARIES = libwam.a libwam_a_SOURCES = module_ATM_INTERNAL_STATE.F90 wamCap.F90 libwam_a_FCFLAGS = -I $(top_srcdir)/include \ - $(FC_MODINC) fim $(FC_MODINC) gen $(FC_MODINC) gsm $(FC_MODINC) nmm \ + $(FC_MODINC) gen $(FC_MODINC) gsm \ $(FC_MODINC) share $(FC_MODINC) phys $(FC_MODINC) io libwam_a_LIBADD = \ - fim/*.$(OBJEXT) \ gen/*.$(OBJEXT) \ gsm/*.$(OBJEXT) \ gsm/dyn/*.$(OBJEXT) \ gsm/libutil/*.$(OBJEXT) \ gsm/phys/*.$(OBJEXT) \ io/*.$(OBJEXT) \ - nmm/*.$(OBJEXT) \ phys/*.$(OBJEXT) \ post/*.$(OBJEXT) \ share/*.$(OBJEXT) diff --git a/src/Makefile.in b/src/Makefile.in index b400637..fb659e3 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -129,10 +129,10 @@ am__v_AR_ = $(am__v_AR_@AM_DEFAULT_V@) am__v_AR_0 = @echo " AR " $@; am__v_AR_1 = libwam_a_AR = $(AR) $(ARFLAGS) -libwam_a_DEPENDENCIES = fim/*.$(OBJEXT) gen/*.$(OBJEXT) \ - gsm/*.$(OBJEXT) gsm/dyn/*.$(OBJEXT) gsm/libutil/*.$(OBJEXT) \ - gsm/phys/*.$(OBJEXT) io/*.$(OBJEXT) nmm/*.$(OBJEXT) \ - phys/*.$(OBJEXT) post/*.$(OBJEXT) share/*.$(OBJEXT) +libwam_a_DEPENDENCIES = gen/*.$(OBJEXT) gsm/*.$(OBJEXT) \ + gsm/dyn/*.$(OBJEXT) gsm/libutil/*.$(OBJEXT) \ + gsm/phys/*.$(OBJEXT) io/*.$(OBJEXT) phys/*.$(OBJEXT) \ + post/*.$(OBJEXT) share/*.$(OBJEXT) am_libwam_a_OBJECTS = libwam_a-module_ATM_INTERNAL_STATE.$(OBJEXT) \ libwam_a-wamCap.$(OBJEXT) libwam_a_OBJECTS = $(am_libwam_a_OBJECTS) @@ -385,22 +385,20 @@ target_alias = @target_alias@ top_build_prefix = @top_build_prefix@ top_builddir = @top_builddir@ top_srcdir = @top_srcdir@ -SUBDIRS = post share phys io fim gen gsm nmm . +SUBDIRS = post share phys io gen gsm . lib_LIBRARIES = libwam.a libwam_a_SOURCES = module_ATM_INTERNAL_STATE.F90 wamCap.F90 libwam_a_FCFLAGS = -I $(top_srcdir)/include \ - $(FC_MODINC) fim $(FC_MODINC) gen $(FC_MODINC) gsm $(FC_MODINC) nmm \ + $(FC_MODINC) gen $(FC_MODINC) gsm \ $(FC_MODINC) share $(FC_MODINC) phys $(FC_MODINC) io libwam_a_LIBADD = \ - fim/*.$(OBJEXT) \ gen/*.$(OBJEXT) \ gsm/*.$(OBJEXT) \ gsm/dyn/*.$(OBJEXT) \ gsm/libutil/*.$(OBJEXT) \ gsm/phys/*.$(OBJEXT) \ io/*.$(OBJEXT) \ - nmm/*.$(OBJEXT) \ phys/*.$(OBJEXT) \ post/*.$(OBJEXT) \ share/*.$(OBJEXT) diff --git a/src/fim/FIMrun/FIMnamelist.FIM.njet b/src/fim/FIMrun/FIMnamelist.FIM.njet deleted file mode 100644 index 112e229..0000000 --- a/src/fim/FIMrun/FIMnamelist.FIM.njet +++ /dev/null @@ -1,209 +0,0 @@ - &QUEUEnamelist - ComputeTasks = '240' ! Number of compute tasks for FIM (S for Serial) - MaxQueueTime = '08:00:00' ! Run time for complete job (HH:MM:SS) [ Ignored by WFM ] - SRCDIR = '/lfs1/projects/rtfim/FIM/FIMsrc_mvapich' ! FIM source location * MUST BE SET * [ WFM: use absolute pathname! ] - PREPDIR = 'nodir' ! If exists, use for prep otherwise calculate prep - FIMDIR = 'nodir' ! If exists, use for FIM otherwise calculate FIM - DATADIR = '/whome/rtfim/fimdata' ! Location of gfsltln and global_mtnvar files - DATADR2 = '/public/data/grids/gfs/spectral' ! Location of the sanl file and the sfcanl file - chem_datadir = '/lfs1/projects/fim/fimdata' ! Location of chemistry data files -/ - &TOPOnamelist - topodatfile = '/whome/rtfim/fimdata/wrf5mintopo.dat' -/ - &CNTLnamelist - glvl = 8 ! Grid level - SubdivNum = 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ! Subdivision numbers for each recursive refinement(2: bisection, 3: trisection, etc.) - nvl = 64 ! Number of atmospheric layers -/ - &PREPnamelist - curve = 2 ! 0: ij order; 1: Hilbert curve order (only for all-bisection refinement); 2:ij block order - NumCacheBlocksPerPE = 4 ! Number of cache blocks per processor. Only applies to ij block order - alt_topo = .true. ! if true, use alternate srf.height field - aerosol_file = 'climaeropac_global.txt' ! filename relative to DATADIR - co2_2008_file = 'co2historicaldata_2008.txt' ! filename relative to DATADIR - co2_glb_file = 'co2historicaldata_glob.txt' ! filename relative to DATADIR - gfsltln_file = 'no_such_file' ! Correct value will be set by run automation - mtnvar_file = 'no_such_file' ! Correct value will be set by run automation -/ - &DIAGnamelist - PrintIpnDiag = -1 ! ipn at which to print diagnostics (-1 means no print) - PrintDiagProgVars = 24 ! Hourly increment to print diagnostic prognosis variables (-1=>none, 0=>every step) - PrintDiagNoise = 1 ! Hourly increment to print diagnostic gravity wave noise (-1=>none, 0=>every step) - PrintDiags = .false. ! True means print diagnostic messages -/ - &MODELnamelist - nts = 0 ! number of time steps - UpdateSST = .false. ! True means update sst and sea ice by reading in a file during integration - rleigh_light = 0.0 ! rayleigh damping time scale (days^-1) if top-layer wind < 100 m/s - rleigh_heavy = 0.5 ! rayleigh damping time scale (days^-1) if top-layer wind > 100 m/s - veldff_bkgnd = 1. ! diffusion velocity (=diffusion/mesh size) - ptop = 50. ! pressure (Pa) at top of model domain - thktop = 50. ! min.thknss of uppermost model layer - intfc_smooth = 50. ! [diffusivity/mesh size] (m/s) for intfc smoothing (0 = no smoothing) - slak = 0.5 ! intfc movement retardation coeff (1 = no retardation) - pure_sig = .false. ! if true, use GFS sigma-p coordinate -/ - &PHYSICSnamelist - PhysicsInterval = 180 ! Interval in seconds to call non-radiation physics (0=every step) - RadiationInterval = 3600 ! Interval in seconds to call radiation physics (0=every step) - SSTInterval = 86400 ! Interval in seconds to call update_sst (0=every step) - GravityWaveDrag = .true. ! True means calculate gravity wave drag - ras = .false. ! false means call SAS - num_p3d = 4 ! 4 means call Zhao/Carr/Sundqvist Microphysics -/ - &TIMEnamelist - yyyymmddhhmm = "200707170000" ! date of the model run -/ - &OUTPUTnamelist - ArchvTimeUnit = "hr" ! ts:timestep; mi:minute; hr:hour; dy:day; mo:month - TotalTime = 240 ! Total integration time in ArchvTimeUnit - ArchvIntvl = 6 ! Archive interval in ArchvTimeUnit - readrestart = .false. ! True means start by reading restart file (rpointer) - restart_freq = 480 ! Restart interval in ArchvTimeUnit - PrintMAXMINtimes = .true. ! True means print MAX MIN routine times, false means print for each PE - TimingBarriers = .false. ! True means turn on timed barriers to measure task skew, set to .false. for production runs - FixedGridOrder = .false. ! True: always output in the same order(IJ), False: order determined by curve. Does not apply to IJorder -/ - &ISOBARICnamelist - isobaric_levels_file = "output_isobaric_levs.txt" ! file containing pressure levels, in FIMrun directory - / -! WRITETASKnamelist is used to optionally create a separate group of -! FIM-specific write tasks to speed up FIM model output by overlapping disk -! writes with computation. By default this feature is turned off. When enabled, -! write tasks intercept FIM output and write to disk while the main compute -! tasks continue with model computation. In NEMS lingo, write tasks are called -! "quilt" tasks. -! -! WRITETASKnamelist is ignored for a serial run. -! - &WRITETASKnamelist - abort_on_bad_task_distrib = .true. ! Abort FIM when node names are not as expected - cpn = 8 ! Number of cores per node - debugmsg_on = .false. ! Print verbose debug messages - max_write_tasks_per_node = 8 ! Maximum number of write tasks to place on a single node - num_write_tasks = 1 ! Use: 0 = no write tasks, 1 = one, 21 = one write task per output file - root_own_node = .true. ! whether root process has node to himself -/ -! -! Namelist file for post processing -! -! Ning Wang, June 2007 -! - &POSTnamelist -! -! input and output specifications: -! - datadir = "../fim" - outputdir = "." -! input = "/tg2/projects/fim/jlee/PREP/mdrag5h.dat" - input = "" -! if input has content, it overwrites the datadir -! output = "/p72/fim/wang/nc_files/mdrag5h.nc" - output = "" -! if output has content, it overwrites the outputdir - output_fmt = "grib" ! "nc" --netCDF file, "grib" --GRIB file - multiple_output_files = .true. ! -- multiple grib outputfiles (assumed true when post in fim) -! -! grid specifications: -! - gribtable = "fim_gribtable" ! only used by grib output file(s) - grid_id = 4 ! 228(144, 73), 45(288, 145), - ! 3(360, 181), 4(720, 361); only for grib output file. - mx = 720 ! only used by netcdf output file - my = 360 ! only used by netcdf output file - latlonfld = .true. ! true -- create lat lon field in grib output file -! -! post processing specifications: -! - is = 1 ! interpolation scheme: - ! 0 -- no interpolation: native grid; - ! 1 -- horizontal interpo. on native vertical coord.; - ! 2 -- horizontal interpo. + vertical interpo. on std. pressure levels; - ! 3 -- horizontal interpo. + vertical interpo. on 10mb inc. pressure levels; - vres = 111 ! only used in vertical interpolation - mode = "linear" ! step or linear interpolation for vertical column -! -! variable specifications: -! -! var_list = 'mp3d', 'th3d', 'us3d', 'vs3d', 'rn2d', 'rc2d', 'sw2d', 'lw2d', 'ts2d' - var_list = 'hgtP', 'tmpP', 'rp3P', 'up3P', 'vp3P', 'pr3D', 'ph3D', 'tk3D', 'td3D', 'ws3D', - 'rh3D', 'us3D', 'vs3D', 'rn2D', 'rc2D', 'r12D', 'r22D', 'rg2D', 'pw2D', 'ts2D', - 'us2D', 'hf2D', 'qf2D', 'sw2D', 'lw2D', 'ms2D', 'sn2D', 'cb2D', 'ct2D', 'u12D', 'v12D' - nsmooth_var = 4, 1, 1, 1, 1, 0, 4, 1, 1, 1, - 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, - 1, 0, 0, 0, 0, 4, 0, 0, 0, 0, 0 - fimout = .true. ! whether to write FIM binary output files - gribout = .true. ! whether to write GRIB output files from FIM - t1 = 0 - t2 = 168 - delta_t = 3 - -/ - -&chemwrf - chem_opt = 0 ! chem option, 0=off, 300=on - chemdt = 30. - kemit = 1 - DUST_OPT = 1, - DMSEMIS_OPT = 1, - SEAS_OPT = 0, - BIO_EMISS_OPT = 0, - BIOMASS_BURN_OPT = 1, - PLUMERISEFIRE_FRQ = 30, - EMISS_INPT_OPT = 1, - GAS_BC_OPT = 0, - GAS_IC_OPT = 0, - AER_BC_OPT = 0, - AER_IC_OPT = 0, -/ - -&wrfphysics - mp_physics = 0, ! 0=off, 2=on - cu_physics = 0, ! 0=off, 3=on -/ - -! -! System specific parameters for MPI, task geometry, etc. -! - &SYSTEMnamelist - MPIRUNCMD='mpirun -np' ! MPIRUNCMD should be defined as follows: - ! SGE 'mpirun -np' || torque 'aprun -n' || intel 'mpiexec_mpt -n' - ! load-leveler 'poe' || NCAR 'mpirun.lsf /usr/local/bin/launch' -/ - -! Everything below this line is of interest only to Workflow Manager users - -&WFMnamelist - max_run_time_prep='00:05:00' - max_run_time_fim='03:50:00' - max_run_time_pop='00:30:00' - batch_size='3' - ac_model_name='FIMDC' - anx_model_names='GFS' - stats_model_name='FIM' - sounding_model_name='FIM' - ncl_model_name='EXPER FIM-8' - ncl_diff_model_name='FIM-FIMX' - realtime='T' - rtfim_home='/whome/rtfim' - pe='nhfip' - serialpe='nhfip' - service='service' - mss='mss' - pes_no_x=240 - cycle='*' - GFSSANLDIR = '/public/data/grids/gfs/spectral' ! Location of the sanl file and the sfcanl file - ENKFSFCANLDIR = '/lfs1/projects/fim/whitaker/gfsenkf_hybrid' ! Location of the sanl file and the sfcanl file - init_file='gfs' - create_diff_plots='false' - ! Post processing: run the following tasks? (set to F to disable) - run_pop='T' ! Other post processing relies on pop to run - run_interp='T' - run_grib12='T' - run_tracker='T' - run_ncl='T' - project='rtfim-njet' - fim_reservation='T' - -/ diff --git a/src/fim/FIMrun/FIMnamelist.FIM.tjet b/src/fim/FIMrun/FIMnamelist.FIM.tjet deleted file mode 100644 index 7c636a5..0000000 --- a/src/fim/FIMrun/FIMnamelist.FIM.tjet +++ /dev/null @@ -1,210 +0,0 @@ - &QUEUEnamelist - ComputeTasks = '240' ! Number of compute tasks for FIM (S for Serial) - MaxQueueTime = '08:00:00' ! Run time for complete job (HH:MM:SS) [ Ignored by WFM ] - SRCDIR = '/lfs1/projects/rtfim/FIM/FIMsrc_mvapich' ! FIM source location * MUST BE SET * [ WFM: use absolute pathname! ] - PREPDIR = 'nodir' ! If exists, use for prep otherwise calculate prep - FIMDIR = 'nodir' ! If exists, use for FIM otherwise calculate FIM - DATADIR = '/whome/rtfim/fimdata' ! Location of gfsltln and global_mtnvar files - DATADR2 = '/public/data/grids/gfs/spectral' ! Location of the sanl file and the sfcanl file - chem_datadir = '/lfs1/projects/fim/fimdata' ! Location of chemistry data files -/ - &TOPOnamelist - topodatfile = '/whome/rtfim/fimdata/wrf5mintopo.dat' -/ - &CNTLnamelist - glvl = 8 ! Grid level - SubdivNum = 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ! Subdivision numbers for each recursive refinement(2: bisection, 3: trisection, etc.) - nvl = 64 ! Number of atmospheric layers -/ - &PREPnamelist - curve = 2 ! 0: ij order; 1: Hilbert curve order (only for all-bisection refinement); 2:ij block order - NumCacheBlocksPerPE = 4 ! Number of cache blocks per processor. Only applies to ij block order - alt_topo = .true. ! if true, use alternate srf.height field - aerosol_file = 'climaeropac_global.txt' ! filename relative to DATADIR - co2_2008_file = 'co2historicaldata_2008.txt' ! filename relative to DATADIR - co2_glb_file = 'co2historicaldata_glob.txt' ! filename relative to DATADIR - gfsltln_file = 'no_such_file' ! Correct value will be set by run automation - mtnvar_file = 'no_such_file' ! Correct value will be set by run automation -/ - &DIAGnamelist - PrintIpnDiag = -1 ! ipn at which to print diagnostics (-1 means no print) - PrintDiagProgVars = 24 ! Hourly increment to print diagnostic prognosis variables (-1=>none, 0=>every step) - PrintDiagNoise = 1 ! Hourly increment to print diagnostic gravity wave noise (-1=>none, 0=>every step) - PrintDiags = .false. ! True means print diagnostic messages -/ - &MODELnamelist - nts = 0 ! number of time steps - UpdateSST = .false. ! True means update sst and sea ice by reading in a file during integration - rleigh_light = 0.0 ! rayleigh damping time scale (days^-1) if top-layer wind < 100 m/s - rleigh_heavy = 0.5 ! rayleigh damping time scale (days^-1) if top-layer wind > 100 m/s - veldff_bkgnd = 1. ! diffusion velocity (=diffusion/mesh size) - ptop = 50. ! pressure (Pa) at top of model domain - thktop = 50. ! min.thknss of uppermost model layer - intfc_smooth = 50. ! [diffusivity/mesh size] (m/s) for intfc smoothing (0 = no smoothing) - slak = 0.5 ! intfc movement retardation coeff (1 = no retardation) - pure_sig = .false. ! if true, use GFS sigma-p coordinate -/ - &PHYSICSnamelist - PhysicsInterval = 180 ! Interval in seconds to call non-radiation physics (0=every step) - RadiationInterval = 3600 ! Interval in seconds to call radiation physics (0=every step) - SSTInterval = 86400 ! Interval in seconds to call update_sst (0=every step) - GravityWaveDrag = .true. ! True means calculate gravity wave drag - ras = .false. ! false means call SAS - num_p3d = 4 ! 4 means call Zhao/Carr/Sundqvist Microphysics -/ - &TIMEnamelist - yyyymmddhhmm = "200707170000" ! date of the model run -/ - &OUTPUTnamelist - ArchvTimeUnit = "hr" ! ts:timestep; mi:minute; hr:hour; dy:day; mo:month - TotalTime = 240 ! Total integration time in ArchvTimeUnit - ArchvIntvl = 6 ! Archive interval in ArchvTimeUnit - readrestart = .false. ! True means start by reading restart file (rpointer) - restart_freq = 480 ! Restart interval in ArchvTimeUnit - PrintMAXMINtimes = .true. ! True means print MAX MIN routine times, false means print for each PE - TimingBarriers = .false. ! True means turn on timed barriers to measure task skew, set to .false. for production runs - FixedGridOrder = .false. ! True: always output in the same order(IJ), False: order determined by curve. Does not apply to IJorder -/ - &ISOBARICnamelist - isobaric_levels_file = "output_isobaric_levs.txt" ! file containing pressure levels, in FIMrun directory - / -! WRITETASKnamelist is used to optionally create a separate group of -! FIM-specific write tasks to speed up FIM model output by overlapping disk -! writes with computation. By default this feature is turned off. When enabled, -! write tasks intercept FIM output and write to disk while the main compute -! tasks continue with model computation. In NEMS lingo, write tasks are called -! "quilt" tasks. -! -! WRITETASKnamelist is ignored for a serial run. -! - &WRITETASKnamelist - abort_on_bad_task_distrib = .true. ! Abort FIM when node names are not as expected - cpn = 12 ! Number of cores per node - debugmsg_on = .false. ! Print verbose debug messages - max_write_tasks_per_node = 8 ! Maximum number of write tasks to place on a single node - num_write_tasks = 1 ! Use: 0 = no write tasks, 1 = one, 21 = one write task per output file - root_own_node = .true. ! whether root process has node to himself -/ -! -! Namelist file for post processing -! -! Ning Wang, June 2007 -! - &POSTnamelist -! -! input and output specifications: -! - datadir = "../fim" - outputdir = "." -! input = "/tg2/projects/fim/jlee/PREP/mdrag5h.dat" - input = "" -! if input has content, it overwrites the datadir -! output = "/p72/fim/wang/nc_files/mdrag5h.nc" - output = "" -! if output has content, it overwrites the outputdir - output_fmt = "grib" ! "nc" --netCDF file, "grib" --GRIB file - multiple_output_files = .true. ! -- multiple grib outputfiles (assumed true when post in fim) -! -! grid specifications: -! - gribtable = "fim_gribtable" ! only used by grib output file(s) - grid_id = 4 ! 228(144, 73), 45(288, 145), - ! 3(360, 181), 4(720, 361); only for grib output file. - mx = 720 ! only used by netcdf output file - my = 360 ! only used by netcdf output file - latlonfld = .true. ! true -- create lat lon field in grib output file -! -! post processing specifications: -! - is = 1 ! interpolation scheme: - ! 0 -- no interpolation: native grid; - ! 1 -- horizontal interpo. on native vertical coord.; - ! 2 -- horizontal interpo. + vertical interpo. on std. pressure levels; - ! 3 -- horizontal interpo. + vertical interpo. on 10mb inc. pressure levels; - vres = 111 ! only used in vertical interpolation - mode = "linear" ! step or linear interpolation for vertical column -! -! variable specifications: -! -! var_list = 'mp3d', 'th3d', 'us3d', 'vs3d', 'rn2d', 'rc2d', 'sw2d', 'lw2d', 'ts2d' - var_list = 'hgtP', 'tmpP', 'rp3P', 'up3P', 'vp3P', 'pr3D', 'ph3D', 'tk3D', 'td3D', 'ws3D', - 'rh3D', 'us3D', 'vs3D', 'rn2D', 'rc2D', 'r12D', 'r22D', 'rg2D', 'pw2D', 'ts2D', - 'us2D', 'hf2D', 'qf2D', 'sw2D', 'lw2D', 'ms2D', 'sn2D', 'cb2D', 'ct2D', 'u12D', 'v12D' - - nsmooth_var = 4, 1, 1, 1, 1, 0, 4, 1, 1, 1, - 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, - 1, 0, 0, 0, 0, 4, 0, 0, 0, 0, 0 - fimout = .true. ! whether to write FIM binary output files - gribout = .true. ! whether to write GRIB output files from FIM - t1 = 0 - t2 = 168 - delta_t = 3 - -/ - -&chemwrf - chem_opt = 0 ! chem option, 0=off, 300=on - chemdt = 30. - kemit = 1 - DUST_OPT = 1, - DMSEMIS_OPT = 1, - SEAS_OPT = 0, - BIO_EMISS_OPT = 0, - BIOMASS_BURN_OPT = 1, - PLUMERISEFIRE_FRQ = 30, - EMISS_INPT_OPT = 1, - GAS_BC_OPT = 0, - GAS_IC_OPT = 0, - AER_BC_OPT = 0, - AER_IC_OPT = 0, -/ - -&wrfphysics - mp_physics = 0, ! 0=off, 2=on - cu_physics = 0, ! 0=off, 3=on -/ - -! -! System specific parameters for MPI, task geometry, etc. -! - &SYSTEMnamelist - MPIRUNCMD='mpirun -np' ! MPIRUNCMD should be defined as follows: - ! SGE 'mpirun -np' || torque 'aprun -n' || intel 'mpiexec_mpt -n' - ! load-leveler 'poe' || NCAR 'mpirun.lsf /usr/local/bin/launch' -/ - -! Everything below this line is of interest only to Workflow Manager users - -&WFMnamelist - max_run_time_prep='00:05:00' - max_run_time_fim='06:00:00' - max_run_time_pop='00:30:00' - batch_size='3' - ac_model_name='FIMDC' - anx_model_names='GFS' - stats_model_name='FIM' - sounding_model_name='FIM' - ncl_model_name='EXPER FIM-8' - ncl_diff_model_name='FIM-FIMX' - realtime='T' - rtfim_home='/whome/rtfim' - pe='thfip' - serialpe='thfip' - service='service' - mss='mss' - pes_no_x=240 - cycle='*' - GFSSANLDIR = '/public/data/grids/gfs/spectral' ! Location of the sanl file and the sfcanl file - ENKFSFCANLDIR = '/lfs1/projects/fim/whitaker/gfsenkf_hybrid' ! Location of the sanl file and the sfcanl file - init_file='gfs' - create_diff_plots='false' - ! Post processing: run the following tasks? (set to F to disable) - run_pop='T' ! Other post processing relies on pop to run - run_interp='T' - run_grib12='T' - run_tracker='T' - run_ncl='T' - project='fim-njet' - fim_reservation='F' - -/ diff --git a/src/fim/FIMrun/FIMnamelist.FIM7.tjet b/src/fim/FIMrun/FIMnamelist.FIM7.tjet deleted file mode 100644 index a1d5682..0000000 --- a/src/fim/FIMrun/FIMnamelist.FIM7.tjet +++ /dev/null @@ -1,215 +0,0 @@ - &QUEUEnamelist -! ComputeTasks = '240' ! Number of compute tasks for FIM (S for Serial) - ComputeTasks = '120' ! Number of compute tasks for FIM (S for Serial) - MaxQueueTime = '06:00:00' ! Run time for complete job (HH:MM:SS) [ Ignored by WFM ] - SRCDIR = '/lfs1/projects/rtfim/FIM7/FIMsrc_mvapich' ! FIM source location * MUST BE SET * [ WFM: use absolute pathname! ] - PREPDIR = 'nodir' ! If exists, use for prep otherwise calculate prep - FIMDIR = 'nodir' ! If exists, use for FIM otherwise calculate FIM - DATADIR = '/whome/rtfim/fimdata' ! Location of gfsltln and global_mtnvar files - DATADR2 = '/public/data/grids/gfs/spectral' ! Location of the sanl file and the sfcanl file - chem_datadir = '/whome/rtfim/fimdata_chem_G7'! Location of chemistry data files -/ - &TOPOnamelist - topodatfile = '/whome/rtfim/fimdata/wrf5mintopo.dat' - / - - &CNTLnamelist - glvl = 7 ! Grid level - SubdivNum = 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ! Subdivision numbers for each recursive refinement(2: bisection, 3: trisection, etc.) - nvl = 64 ! Number of atmospheric layers -/ - &PREPnamelist - curve = 0 ! 0: ij order; 1: Hilbert curve order (only for all-bisection refinement); 2:ij block order - NumCacheBlocksPerPE = 1 ! Number of cache blocks per processor. Only applies to ij block order - alt_topo = .true. ! if true, use alternate srf.height field - aerosol_file = 'climaeropac_global.txt' ! filename relative to DATADIR - co2_2008_file = 'co2historicaldata_2008.txt' ! filename relative to DATADIR - co2_glb_file = 'co2historicaldata_glob.txt' ! filename relative to DATADIR - gfsltln_file = 'no_such_file' ! Correct value will be set by run automation - mtnvar_file = 'no_such_file' ! Correct value will be set by run automation -/ - &DIAGnamelist - PrintIpnDiag = -1 ! ipn at which to print diagnostics (-1 means no print) - PrintDiagProgVars = 12 ! Hourly increment to print diagnostic prognosis variables (-1=>none, 0=>every step) - PrintDiagNoise = 1 ! Hourly increment to print diagnostic gravity wave noise (-1=>none, 0=>every step) - PrintDiags = .false. ! True means print diagnostic messages -/ - &MODELnamelist - nts = 0 ! number of time steps - rleigh_light = 0.0 ! rayleigh damping time scale (days^-1) if top-layer wind < 100 m/s - rleigh_heavy = 0.5 ! rayleigh damping time scale (days^-1) if top-layer wind > 100 m/s - veldff_bkgnd = 1. ! diffusion velocity (=diffusion/mesh size) - ptop = 50. ! pressure (Pa) at top of model domain - thktop = 50. ! min.thknss of uppermost model layer - intfc_smooth = 50. ! diffusivity (m/s) for intfc smoothing (0 = no smoothing) - slak = 0.5 ! intfc movement retardation coeff (1 = no retardation) - pure_sig = .false. ! if true, use pure sigma coord. -/ - &PHYSICSnamelist - PhysicsInterval = 180 ! Interval in seconds to call non-radiation physics (0=every step) - RadiationInterval = 1800 ! Interval in seconds to call radiation physics (0=every step) - GravityWaveDrag = .true. ! True means calculate gravity wave drag - ras = .false. - num_p3d = 4 -/ - &TIMEnamelist - yyyymmddhhmm = "200707170000" ! date of the model run -/ - &OUTPUTnamelist - ArchvTimeUnit = "hr" ! ts:timestep; mi:minute; hr:hour; dy:day; mo:month - TotalTime = 168 ! Total integration time in ArchvTimeUnit - ArchvIntvl = 6 ! Archive interval in ArchvTimeUnit - readrestart = .false. ! True means start by reading restart file (rpointer) - restart_freq = 240 ! Restart interval in ArchvTimeUnit - PrintMAXMINtimes = .true. ! True means print MAX MIN routine times, false means print for each PE - TimingBarriers = .false. ! True means turn on timed barriers to measure task skew, set to .false. for production runs - FixedGridOrder = .false. ! True: always output in the same order(IJ), False: order determined by curve. Does not apply to IJorder -/ - &ISOBARICnamelist - isobaric_levels_file = "output_isobaric_levs.txt" ! file containing pressure levels, in FIMrun directory - / -! -! WRITETASKnamelist is used to optionally create a separate group of -! FIM-specific write tasks to speed up FIM model output by overlapping disk -! writes with computation. By default this feature is turned off. When enabled, -! write tasks intercept FIM output and write to disk while the main compute -! tasks continue with model computation. In NEMS lingo, write tasks are called -! "quilt" tasks. -! -! WRITETASKnamelist is ignored for a serial run. -! - &WRITETASKnamelist - abort_on_bad_task_distrib = .true. ! Abort FIM when node names are not as expected - cpn = 12 ! Number of cores per node - debugmsg_on = .false. ! Print verbose debug messages - max_write_tasks_per_node = 8 ! Maximum number of write tasks to place on a single node - num_write_tasks = 1 ! Use: 0 = no write tasks, 1 = one, 21 = one write task per output file - root_own_node = .true. ! whether root process has node to himself -/ -! -! Namelist file for post processing -! -! Ning Wang, June 2007 -! - &POSTnamelist -! -! input and output specifications: -! - datadir = "../fim" - outputdir = "." -! input = "/tg2/projects/fim/jlee/PREP/mdrag5h.dat" - input = "" -! if input has content, it overwrites the datadir -! output = "/p72/fim/wang/nc_files/mdrag5h.nc" - output = "" -! if output has content, it overwrites the outputdir - output_fmt = "grib" ! "nc" --netCDF file, "grib" --GRIB file - multiple_output_files = .true. ! -- multiple grib outputfiles (assumed true when post in fim) -! -! grid specifications: -! - gribtable = "fim_gribtable" ! only used by grib output file(s) - grid_id = 4 ! 228(144, 73), 45(288, 145), - ! 3(360, 181), 4(720, 361); only for grib output file. - mx = 720 ! only used by netcdf output file - my = 360 ! only used by netcdf output file - latlonfld = .true. ! true -- create lat lon field in grib output file -! -! post processing specifications: -! - is = 1 ! interpolation scheme: - ! 0 -- no interpolation: native grid; - ! 1 -- horizontal interpo. on native vertical coord.; - ! 2 -- horizontal interpo. + vertical interpo. on std. pressure levels; - ! 3 -- horizontal interpo. + vertical interpo. on 10mb inc. pressure levels; - vres = 111 ! only used in vertical interpolation - mode = "linear" ! step or linear interpolation for vertical column -! -! variable specifications: -! -! var_list = 'mp3d', 'th3d', 'us3d', 'vs3d', 'rn2d', 'rc2d', 'sw2d', 'lw2d', 'ts2d' - var_list = 'hgtP', 'tmpP', 'rp3P', 'up3P', 'vp3P', 'pr3D', 'ph3D', 'tk3D', 'td3D', 'ws3D', - 'rh3D', 'us3D', 'vs3D', 'rn2D', 'rc2D', 'r12D', 'r22D', 'rg2D', 'pw2D', 'ts2D', - 'us2D', 'hf2D', 'qf2D', 'sw2D', 'lw2D', 'ms2D', 'sn2D', 'cb2D', 'ct2D' - nsmooth_var = 4, 1, 1, 1, 1, 0, 4, 1, 1, 1, - 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, - 1, 0, 0, 0, 0, 4, 0, 0, 0 - fimout = .true. ! whether to write FIM binary output files - gribout = .true. ! whether to write GRIB output files from FIM - t1 = 0 - t2 = 168 - delta_t = 6 - -/ - -&chemwrf - chem_opt = 0 ! chem option, 0=off, 300=on - chemdt = 60. - chem_in_opt = 1 - kemit = 1 - aer_ra_feedback = 1, -! ash_height = 7000., -! ash_mass = 3500., - ash_height = 0., - ash_mass = 0., - DUST_OPT = 1, - DMSEMIS_OPT = 1, - SEAS_OPT = 1, - BIO_EMISS_OPT = 0, - BIOMASS_BURN_OPT = 1, - PLUMERISEFIRE_FRQ = 30, - EMISS_INPT_OPT = 1, - GAS_BC_OPT = 0, - GAS_IC_OPT = 0, - AER_BC_OPT = 0, - AER_IC_OPT = 0, -/ - -&wrfphysics - mp_physics = 0, ! 0=off, 2=on - cu_physics = 0, ! 0=off, 3=on -/ - -! -! System specific parameters for MPI, task geometry, etc. -! - &SYSTEMnamelist - MPIRUNCMD='mpirun -np' ! MPIRUNCMD should be defined as follows: - ! SGE 'mpirun -np' || torque 'aprun -n' || intel 'mpiexec_mpt -n' - ! load-leveler 'poe' || NCAR 'mpirun.lsf /usr/local/bin/launch' -/ - -! Everything below this line is of interest only to Workflow Manager users - -&WFMnamelist - max_run_time_prep='00:05:00' - max_run_time_fim='03:15:00' - max_run_time_fim_12hr_fcst='01:00:00' - max_run_time_pop='00:45:00' - batch_size='3' - ac_model_name='FIM7DC' - anx_model_names='GFS' - stats_model_name='FIM7' - sounding_model_name='FIM7' - ncl_model_name='FIM7' - ncl_diff_model_name='FIM7-FIMX' - realtime='T' - rtfim_home='/whome/rtfim' - pe='thfip' - serialpe='thfip' - service='service' - mss='mss' - cycle='*' - pes_no_x=120 - GFSSANLDIR = '/public/data/grids/gfs/spectral' ! Location of the sanl file and the sfcanl file - ENKFSFCANLDIR = '/lfs1/projects/fim/whitaker/gfsenkf_hybrid' ! Location of the sanl file and the sfcanl file - init_file='gfs' - create_diff_plots='false' - ! Post processing: run the following tasks? (set to F to disable) - run_pop='T' ! Other post processing relies on pop to run - run_interp='T' - run_grib12='T' - run_tracker='T' - run_ncl='T' - -/ diff --git a/src/fim/FIMrun/FIMnamelist.FIM9.tjet b/src/fim/FIMrun/FIMnamelist.FIM9.tjet deleted file mode 100644 index b79958d..0000000 --- a/src/fim/FIMrun/FIMnamelist.FIM9.tjet +++ /dev/null @@ -1,215 +0,0 @@ - &QUEUEnamelist - ComputeTasks = '264' ! Number of compute tasks for FIM (S for Serial) - MaxQueueTime = '08:00:00' ! Run time for complete job (HH:MM:SS) [ Ignored by WFM ] - SRCDIR = '/lfs1/projects/rtfim/FIM9/FIMsrc_mvapich' ! FIM source location * MUST BE SET * [ WFM: use absolute pathname! ] - PREPDIR = 'nodir' ! If exists, use for prep otherwise calculate prep - FIMDIR = 'nodir' ! If exists, use for FIM otherwise calculate FIM - DATADIR = '/whome/rtfim/fimdata' ! Location of gfsltln and global_mtnvar files - DATADR2 = '/lfs1/projects/fim/whitaker/gfsenkf_t574' ! Location of the sanl file and the sfcanl file - chem_datadir = '/lfs1/projects/fim/fimdata' ! Location of chemistry data files -/ - &TOPOnamelist - topodatfile = '/whome/rtfim/fimdata/wrf5mintopo.dat' -/ - &CNTLnamelist - glvl = 9 ! Grid level - SubdivNum = 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ! Subdivision numbers for each recursive refinement(2: bisection, 3: trisection, etc.) - nvl = 64 ! Number of atmospheric layers -/ - &PREPnamelist - curve = 2 ! 0: ij order; 1: Hilbert curve order (only for all-bisection refinement); 2:ij block order - NumCacheBlocksPerPE = 4 ! Number of cache blocks per processor. Only applies to ij block order - alt_topo = .true. ! if true, use alternate srf.height field - aerosol_file = 'climaeropac_global.txt' ! filename relative to DATADIR - co2_2008_file = 'co2historicaldata_2008.txt' ! filename relative to DATADIR - co2_glb_file = 'co2historicaldata_glob.txt' ! filename relative to DATADIR - gfsltln_file = 'no_such_file' ! Correct value will be set by run automation - mtnvar_file = 'no_such_file' ! Correct value will be set by run automation -/ - &DIAGnamelist - PrintIpnDiag = -1 ! ipn at which to print diagnostics (-1 means no print) - PrintDiagProgVars = 24 ! Hourly increment to print diagnostic prognosis variables (-1=>none, 0=>every step) - PrintDiagNoise = 1 ! Hourly increment to print diagnostic gravity wave noise (-1=>none, 0=>every step) - PrintDiags = .false. ! True means print diagnostic messages -/ - &MODELnamelist - nts = 0 ! number of time steps - rleigh_light = 0.0 ! rayleigh damping time scale (days^-1) if top-layer wind < 100 m/s - rleigh_heavy = 0.5 ! rayleigh damping time scale (days^-1) if top-layer wind > 100 m/s - veldff_bkgnd = 1. ! diffusion velocity (=diffusion/mesh size) - ptop = 50. ! pressure (Pa) at top of model domain - thktop = 50. ! min.thknss of uppermost model layer - intfc_smooth = 50. ! diffusivity (m/s) for intfc smoothing (0 = no smoothing) - slak = 0.5 ! intfc movement retardation coeff (1 = no retardation) - pure_sig = .false. ! if true, use pure sigma coord. -/ - &PHYSICSnamelist - PhysicsInterval = 180 ! Interval in seconds to call non-radiation physics (0=every step) - RadiationInterval = 3600 ! Interval in seconds to call radiation physics (0=every step) - GravityWaveDrag = .true. ! True means calculate gravity wave drag - ras = .false. ! false means call SAS - num_p3d = 4 ! 4 means call Zhao/Carr/Sundqvist Microphysics -/ - &TIMEnamelist - yyyymmddhhmm = "200707170000" ! date of the model run -/ - &OUTPUTnamelist - ArchvTimeUnit = "hr" ! ts:timestep; mi:minute; hr:hour; dy:day; mo:month - TotalTime = 240 ! Total integration time in ArchvTimeUnit - ArchvIntvl = 6 ! Archive interval in ArchvTimeUnit - readrestart = .false. ! True means start by reading restart file (rpointer) - restart_freq = 480 ! Restart interval in ArchvTimeUnit - PrintMAXMINtimes = .true. ! True means print MAX MIN routine times, false means print for each PE - TimingBarriers = .false. ! True means turn on timed barriers to measure task skew, set to .false. for production runs - FixedGridOrder = .false. ! True: always output in the same order(IJ), False: order determined by curve. Does not apply to IJorder -/ - &ISOBARICnamelist - isobaric_levels_file = "output_isobaric_levs.txt" ! file containing pressure levels, in FIMrun directory - / - -! WRITETASKnamelist is used to optionally create a separate group of -! FIM-specific write tasks to speed up FIM model output by overlapping disk -! writes with computation. By default this feature is turned off. When enabled, -! write tasks intercept FIM output and write to disk while the main compute -! tasks continue with model computation. In NEMS lingo, write tasks are called -! "quilt" tasks. -! -! WRITETASKnamelist is ignored for a serial run. -! - &WRITETASKnamelist - abort_on_bad_task_distrib = .true. ! Abort FIM when node names are not as expected - cpn = 12 ! Number of cores per node - debugmsg_on = .false. ! Print verbose debug messages - max_write_tasks_per_node = 8 ! Maximum number of write tasks to place on a single node - num_write_tasks = 1 ! Use: 0 = no write tasks, 1 = one, 21 = one write task per output file - root_own_node = .true. ! whether root process has node to himself -/ -! -! Namelist file for post processing -! -! Ning Wang, June 2007 -! - &POSTnamelist -! -! input and output specifications: -! - datadir = "../fim" - outputdir = "." -! input = "/tg2/projects/fim/jlee/PREP/mdrag5h.dat" - input = "" -! if input has content, it overwrites the datadir -! output = "/p72/fim/wang/nc_files/mdrag5h.nc" - output = "" -! if output has content, it overwrites the outputdir - output_fmt = "grib" ! "nc" --netCDF file, "grib" --GRIB file - multiple_output_files = .true. ! -- multiple grib outputfiles (assumed true when post in fim) -! -! grid specifications: -! - gribtable = "fim_gribtable" ! only used by grib output file(s) - grid_id = 4 ! 228(144, 73), 45(288, 145), - ! 3(360, 181), 4(720, 361); only for grib output file. - mx = 720 ! only used by netcdf output file - my = 360 ! only used by netcdf output file - latlonfld = .true. ! true -- create lat lon field in grib output file -! -! post processing specifications: -! - is = 1 ! interpolation scheme: - ! 0 -- no interpolation: native grid; - ! 1 -- horizontal interpo. on native vertical coord.; - ! 2 -- horizontal interpo. + vertical interpo. on std. pressure levels; - ! 3 -- horizontal interpo. + vertical interpo. on 10mb inc. pressure levels; - vres = 111 ! only used in vertical interpolation - mode = "linear" ! step or linear interpolation for vertical column -! -! variable specifications: -! -! var_list = 'mp3d', 'th3d', 'us3d', 'vs3d', 'rn2d', 'rc2d', 'sw2d', 'lw2d', 'ts2d' - var_list = 'hgtP', 'tmpP', 'rp3P', 'up3P', 'vp3P', 'pr3D', 'ph3D', 'tk3D', 'td3D', 'ws3D', - 'rh3D', 'us3D', 'vs3D', 'rn2D', 'rc2D', 'r12D', 'r22D', 'rg2D', 'pw2D', 'ts2D', - 'us2D', 'hf2D', 'qf2D', 'sw2D', 'lw2D', 'ms2D', 'sn2D', 'cb2D', 'ct2D' - nsmooth_var = 4, 1, 1, 1, 1, 0, 4, 1, 1, 1, - 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, - 1, 0, 0, 0, 0, 4, 0, 0, 0 - fimout = .true. ! whether to write FIM binary output files - gribout = .true. ! whether to write GRIB output files from FIM - t1 = 0 - t2 = 168 - delta_t = 6 - -/ - -&chemwrf - chem_opt = 0 ! chem option, 0=off, 300=on - chemdt = 30. - kemit = 1 - DUST_OPT = 1, - DMSEMIS_OPT = 1, - SEAS_OPT = 0, - BIO_EMISS_OPT = 0, - BIOMASS_BURN_OPT = 1, - PLUMERISEFIRE_FRQ = 30, - EMISS_INPT_OPT = 1, - GAS_BC_OPT = 0, - GAS_IC_OPT = 0, - AER_BC_OPT = 0, - AER_IC_OPT = 0, -/ - -&wrfphysics - mp_physics = 0, ! 0=off, 2=on - cu_physics = 0, ! 0=off, 3=on -/ - -! gptlnl modifies the behavior of the GPTL timing library, if enabled - -&gptlnl - print_method = 'full_tree' ! print full call tree -! utr = 'nanotime' ! fastest available underlying timer (Intel processors only) -! eventlist = 'PAPI_FP_OPS','GPTL_CI' ! PAPI-based counters (only if PAPI is available) -/ - -! -! System specific parameters for MPI, task geometry, etc. -! - &SYSTEMnamelist - MPIRUNCMD='mpirun -np' ! MPIRUNCMD should be defined as follows: - ! SGE 'mpirun -np' || torque 'aprun -n' || intel 'mpiexec_mpt -n' - ! load-leveler 'poe' || NCAR 'mpirun.lsf /usr/local/bin/launch' -/ - -! Everything below this line is of interest only to Workflow Manager users - -&WFMnamelist - max_run_time_prep='00:05:00' - max_run_time_fim='04:50:00' - max_run_time_pop='00:30:00' - batch_size='3' - ac_model_name='FIM9DC' - anx_model_names='ENKF' - stats_model_name='FIM9' - sounding_model_name='FIM9' - ncl_model_name='EXPER FIM9' - ncl_diff_model_name='FIM-FIM9' - realtime='T' - rtfim_home='/whome/rtfim' - pe='thfip' - serialpe='thfip' - service='service' - mss='mss' - pes_no_x=800 - cycle='*' - GFSSANLDIR = '/public/data/grids/gfs/spectral' ! Location of the sanl file and the sfcanl file - ENKFSFCANLDIR = '/lfs1/projects/fim/whitaker/gfsenkf_t574' ! Location of the sanl file and the sfcanl file - init_file='enkf' - create_diff_plots='false' - project='rtfim-njet' - ! Post processing: run the following tasks? (set to F to disable) - run_pop='T' ! Other post processing relies on pop to run - run_interp='T' - run_grib12='T' - run_tracker='T' - run_ncl='T' - fim_reservation='T' -/ diff --git a/src/fim/FIMrun/FIMnamelist.FIMCES.tjet b/src/fim/FIMrun/FIMnamelist.FIMCES.tjet deleted file mode 100644 index 2dc0e3a..0000000 --- a/src/fim/FIMrun/FIMnamelist.FIMCES.tjet +++ /dev/null @@ -1,206 +0,0 @@ - &QUEUEnamelist - ComputeTasks = '240' ! Number of compute tasks for FIM (S for Serial) - MaxQueueTime = '08:00:00' ! Run time for complete job (HH:MM:SS) [ Ignored by WFM ] - SRCDIR = '/whome/rtfim/FIMCES/FIMsrc_mvapich' ! FIM source location * MUST BE SET * [ WFM: use absolute pathname! ] - PREPDIR = 'nodir' ! If exists, use for prep otherwise calculate prep - FIMDIR = 'nodir' ! If exists, use for FIM otherwise calculate FIM - DATADIR = '/whome/rtfim/fimdata' ! Location of gfsltln and global_mtnvar files - DATADR2 = '/public/data/grids/gfs/spectral' ! Location of the sanl file and the sfcanl file - chem_datadir = '/whome/rtfim/fimdata_chem' -/ - &TOPOnamelist - topodatfile = '/whome/rtfim/fimdata/wrf5mintopo.dat' -/ - &CNTLnamelist - glvl = 8 ! Grid level - SubdivNum = 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ! Subdivision numbers for each recursive refinement(2: bisection, 3: trisection, etc.) - nvl = 64 ! Number of atmospheric layers -/ - &PREPnamelist - curve = 2 ! 0: ij order; 1: Hilbert curve order (only for all-bisection refinement); 2:ij block order - NumCacheBlocksPerPE = 4 ! Number of cache blocks per processor. Only applies to ij block order - alt_topo = .true. ! if true, use alternate srf.height field - gfsltln_file = 'no_such_file' ! Correct value will be set by run automation - mtnvar_file = 'no_such_file' ! Correct value will be set by run automation -/ - &DIAGnamelist - PrintIpnDiag = -1 ! ipn at which to print diagnostics (-1 means no print) - PrintDiagProgVars = 24 ! Hourly increment to print diagnostic prognosis variables (-1=>none, 0=>every step) - PrintDiagNoise = 1 ! Hourly increment to print diagnostic gravity wave noise (-1=>none, 0=>every step) - PrintDiags = .false. ! True means print diagnostic messages -/ - &MODELnamelist - nts = 0 ! number of time steps - rleigh_light = 0.0 ! rayleigh damping time scale (days^-1) if top-layer wind < 100 m/s - rleigh_heavy = 0.5 ! rayleigh damping time scale (days^-1) if top-layer wind > 100 m/s - veldff_bkgnd = 1. ! diffusion velocity (=diffusion/mesh size) - ptop = 50. ! pressure (Pa) at top of model domain - thktop = 50. ! min.thknss of uppermost model layer - intfc_smooth = 50. ! diffusivity (m/s) for intfc smoothing (0 = no smoothing) - slak = 0.5 ! intfc movement retardation coeff (1 = no retardation) - pure_sig = .false. ! if true, use pure sigma coord. -/ - &PHYSICSnamelist - PhysicsInterval = 180 ! Interval in seconds to call non-radiation physics (0=every step) - RadiationInterval = 3600 ! Interval in seconds to call radiation physics (0=every step) - GravityWaveDrag = .true. ! True means calculate gravity wave drag -/ - &TIMEnamelist - yyyymmddhhmm = "200707170000" ! date of the model run -/ - &OUTPUTnamelist - ArchvTimeUnit = "hr" ! ts:timestep; mi:minute; hr:hour; dy:day; mo:month - TotalTime = 168 ! Total integration time in ArchvTimeUnit - ArchvIntvl = 6 ! Archive interval in ArchvTimeUnit - readrestart = .false. ! True means start by reading restart file (rpointer) - restart_freq = 240 ! Restart interval in ArchvTimeUnit - PrintMAXMINtimes = .true. ! True means print MAX MIN routine times, false means print for each PE - TimingBarriers = .false. ! True means turn on timed barriers to measure task skew, set to .false. for production runs - FixedGridOrder = .false. ! True: always output in the same order(IJ), False: order determined by curve. Does not apply to IJorder -/ - &ISOBARICnamelist - isobaric_levels_file = "output_isobaric_levs.txt" ! file containing pressure levels, in FIMrun directory - / - -! WRITETASKnamelist is used to optionally create a separate group of -! FIM-specific write tasks to speed up FIM model output by overlapping disk -! writes with computation. By default this feature is turned off. When enabled, -! write tasks intercept FIM output and write to disk while the main compute -! tasks continue with model computation. In NEMS lingo, write tasks are called -! "quilt" tasks. -! -! WRITETASKnamelist is ignored for a serial run. -! - &WRITETASKnamelist - abort_on_bad_task_distrib = .true. ! Abort FIM when node names are not as expected - cpn = 12 ! Number of cores per node - debugmsg_on = .false. ! Print verbose debug messages - max_write_tasks_per_node = 8 ! Maximum number of write tasks to place on a single node - num_write_tasks = 1 ! Use: 0 = no write tasks, 1 = one, 21 = one write task per output file - root_own_node = .true. ! whether root process has node to himself -/ -! -! Namelist file for post processing -! -! Ning Wang, June 2007 -! - &POSTnamelist -! -! input and output specifications: -! - datadir = "../fim" - outputdir = "." -! input = "/tg2/projects/fim/jlee/PREP/mdrag5h.dat" - input = "" -! if input has content, it overwrites the datadir -! output = "/p72/fim/wang/nc_files/mdrag5h.nc" - output = "" -! if output has content, it overwrites the outputdir - output_fmt = "grib" ! "nc" --netCDF file, "grib" --GRIB file - multiple_output_files = 1 ! 1 -- multiple grib outputfiles. -! -! grid specifications: -! - gribtable = "fim_gribtable" ! only used by grib output file(s) - grid_id = 4 ! 228(144, 73), 45(288, 145), - ! 3(360, 181), 4(720, 361); only for grib output file. - mx = 720 ! only used by netcdf output file - my = 360 ! only used by netcdf output file - latlonfld = 1 ! 1 -- create lat lon field in grib output file, 0 -- otherwise -! -! post processing specifications: -! - is = 1 ! interpolation scheme: - ! 0 -- no interpolation: native grid; - ! 1 -- horizontal interpo. on native vertical coord.; - ! 2 -- horizontal interpo. + vertical interpo. on std. pressure levels; - ! 3 -- horizontal interpo. + vertical interpo. on 10mb inc. pressure levels; - vres = 111 ! only used in vertical interpolation - mode = "linear" ! step or linear interpolation for vertical column -! -! variable specifications: -! -! var_list = "mp3d th3d us3d vs3d rn2d rc2d sw2d lw2d ts2d " -! var_list = "hgtP tmpP rp3P up3P vp3P pr3D ph3D tk3D td3D ws3D rh3D us3D vs3D c13D c23D rn2D rc2D r12D r22D rg2D pw2D ts2D us2D hf2D qf2D sw2D lw2D ms2D sn2D cb2D ct2D" - var_list = 'hgtP','tmpP','rp3P','up3P','vp3P','pr3D','ph3D','tk3D','td3D','ws3D', - 'rh3D','us3D','vs3D','c13D','c23D','rn2D','rc2D','r12D','r22D','rg2D', - 'pw2D','ts2D','us2D','hf2D','qf2D','sw2D','lw2D','ms2D','sn2D','cb2D,'ct2D' - nsmooth_var = 4, 1, 1, 1, 1, 0, 4, 1, 1, 1, - 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, - 1, 0, 0, 0, 0, 4, 0, 0, 0, 0, 0 - fimout = .true. ! whether to write FIM binary output files - gribout = .true. ! whether to write GRIB output files from FIM - nvars = 32 ! ignored by WFM - overwritten by batchTemplate-pop - t1 = 0 - t2 = 168 - delta_t = 3 - -/ - -&chemwrf - chem_opt = 500 ! chem option, 0=off, 300=chem, 500=radiation - chemdt = 30. - kemit = 64 - chem_in_opt = 1, - DUST_OPT = 0, - DMSEMIS_OPT = 0, - SEAS_OPT = 0, - BIO_EMISS_OPT = 0, - BIOMASS_BURN_OPT = 0, - PLUMERISEFIRE_FRQ = 30, - EMISS_INPT_OPT = 1, - GAS_BC_OPT = 0, - GAS_IC_OPT = 0, - AER_BC_OPT = 0, - AER_IC_OPT = 0, - tr_mass = 1000., - tr_height = 200., -/ - -&wrfphysics - mp_physics = 0, ! 0=off, 2=on - cu_physics = 0, ! 0=off, 3=on -/ - -! -! System specific parameters for MPI, task geometry, etc. -! - &SYSTEMnamelist - MPIRUNCMD='mpirun -np' ! MPIRUNCMD should be defined as follows: - ! SGE 'mpirun -np' || torque 'aprun -n' || intel 'mpiexec_mpt -n' - ! load-leveler 'poe' || NCAR 'mpirun.lsf /usr/local/bin/launch' -/ - -! Everything below this line is of interest only to Workflow Manager users - -&WFMnamelist - max_run_time_prep='00:05:00' - max_run_time_fim='06:00:00' - max_run_time_pop='00:30:00' - batch_size='3' - ac_model_name='FIMCES' - anx_model_names='GFS' - stats_model_name='FIMCES' - sounding_model_name='FIMCES' - ncl_model_name='FIMCES Experimental: Not For Official Guidance ' - ncl_diff_model_name='FIMCES-FIM' - realtime='T' - rtfim_home='/whome/rtfim' - pe='thfip' - serialpe='thfip' - service='service' - mss='mss' - pes_no_x=240 - cycle='*' - GFSSANLDIR = '/public/data/grids/gfs/spectral' ! Location of the sanl file and the sfcanl file - ENKFSFCANLDIR = '/lfs1/projects/fim/whitaker/gfsenkf_t254' ! Location of the sanl file and the sfcanl file - init_file='gfs' - create_diff_plots='false' - ! Post processing: run the following tasks? (set to F to disable) - run_pop='T' ! Other post processing relies on pop to run - run_interp='T' - run_grib12='T' - run_tracker='T' - run_ncl='T' - -/ diff --git a/src/fim/FIMrun/FIMnamelist.FIMCO2.tjet b/src/fim/FIMrun/FIMnamelist.FIMCO2.tjet deleted file mode 100644 index 5b90c58..0000000 --- a/src/fim/FIMrun/FIMnamelist.FIMCO2.tjet +++ /dev/null @@ -1,207 +0,0 @@ - &QUEUEnamelist - ComputeTasks = '240' ! Number of compute tasks for FIM (S for Serial) - MaxQueueTime = '08:00:00' ! Run time for complete job (HH:MM:SS) [ Ignored by WFM ] - SRCDIR = '/lfs1/projects/rtfim/FIMCO2/FIMsrc_mvapich' ! FIM source location * MUST BE SET * [ WFM: use absolute pathname! ] - PREPDIR = 'nodir' ! If exists, use for prep otherwise calculate prep - FIMDIR = 'nodir' ! If exists, use for FIM otherwise calculate FIM - DATADIR = '/whome/rtfim/fimdata' ! Location of gfsltln and global_mtnvar files - DATADR2 = '/public/data/grids/gfs/spectral' ! Location of the sanl file and the sfcanl file - chem_datadir = '/whome/rtfim/fimdata_chem_G7' -/ - &TOPOnamelist - topodatfile = '/whome/rtfim/fimdata/wrf5mintopo.dat' -/ - &CNTLnamelist - glvl = 7 ! Grid level - SubdivNum = 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ! Subdivision numbers for each recursive refinement(2: bisection, 3: trisection, etc.) - nvl = 64 ! Number of atmospheric layers -/ - &PREPnamelist - curve = 0 ! 0: ij order; 1: Hilbert curve order (only for all-bisection refinement); 2:ij block order - NumCacheBlocksPerPE = 4 ! Number of cache blocks per processor. Only applies to ij block order - alt_topo = .true. ! if true, use alternate srf.height field - aerosol_file = 'climaeropac_global.txt' ! filename relative to DATADIR - co2_2008_file = 'co2historicaldata_2008.txt' ! filename relative to DATADIR - co2_glb_file = 'co2historicaldata_glob.txt' ! filename relative to DATADIR - gfsltln_file = 'no_such_file' ! Correct value will be set by run automation - mtnvar_file = 'no_such_file' ! Correct value will be set by run automation -/ - &DIAGnamelist - PrintIpnDiag = -1 ! ipn at which to print diagnostics (-1 means no print) - PrintDiagProgVars = 24 ! Hourly increment to print diagnostic prognosis variables (-1=>none, 0=>every step) - PrintDiagNoise = 1 ! Hourly increment to print diagnostic gravity wave noise (-1=>none, 0=>every step) - PrintDiags = .false. ! True means print diagnostic messages -/ - &MODELnamelist - nts = 0 ! number of time steps - rleigh_light = 0.0 ! rayleigh damping time scale (days^-1) if top-layer wind < 100 m/s - rleigh_heavy = 0.5 ! rayleigh damping time scale (days^-1) if top-layer wind > 100 m/s - veldff_bkgnd = 1. ! diffusion velocity (=diffusion/mesh size) - ptop = 50. ! pressure (Pa) at top of model domain - thktop = 50. ! min.thknss of uppermost model layer - intfc_smooth = 50. ! diffusivity (m/s) for intfc smoothing (0 = no smoothing) - slak = 0.5 ! intfc movement retardation coeff (1 = no retardation) - pure_sig = .false. ! if true, use pure sigma coord. -/ - &PHYSICSnamelist - PhysicsInterval = 180 ! Interval in seconds to call non-radiation physics (0=every step) - RadiationInterval = 3600 ! Interval in seconds to call radiation physics (0=every step) - GravityWaveDrag = .true. ! True means calculate gravity wave drag -/ - &TIMEnamelist - yyyymmddhhmm = "200707170000" ! date of the model run -/ - &OUTPUTnamelist - ArchvTimeUnit = "hr" ! ts:timestep; mi:minute; hr:hour; dy:day; mo:month - TotalTime = 24 ! Total integration time in ArchvTimeUnit - ArchvIntvl = 1 ! Archive interval in ArchvTimeUnit - readrestart = .false. ! True means start by reading restart file (rpointer) - restart_freq = 240 ! Restart interval in ArchvTimeUnit - PrintMAXMINtimes = .true. ! True means print MAX MIN routine times, false means print for each PE - TimingBarriers = .false. ! True means turn on timed barriers to measure task skew, set to .false. for production runs - FixedGridOrder = .false. ! True: always output in the same order(IJ), False: order determined by curve. Does not apply to IJorder -/ - &ISOBARICnamelist - isobaric_levels_file = "output_isobaric_levs.txt" ! file containing pressure levels, in FIMrun directory - / - -! WRITETASKnamelist is used to optionally create a separate group of -! FIM-specific write tasks to speed up FIM model output by overlapping disk -! writes with computation. By default this feature is turned off. When enabled, -! write tasks intercept FIM output and write to disk while the main compute -! tasks continue with model computation. In NEMS lingo, write tasks are called -! "quilt" tasks. -! -! WRITETASKnamelist is ignored for a serial run. -! - &WRITETASKnamelist - abort_on_bad_task_distrib = .true. ! Abort FIM when node names are not as expected - cpn = 12 ! Number of cores per node - debugmsg_on = .false. ! Print verbose debug messages - max_write_tasks_per_node = 8 ! Maximum number of write tasks to place on a single node - num_write_tasks = 1 ! Use: 0 = no write tasks, 1 = one, 21 = one write task per output file - root_own_node = .true. ! whether root process has node to himself -/ -! -! Namelist file for post processing -! -! Ning Wang, June 2007 -! - &POSTnamelist -! -! input and output specifications: -! - datadir = "../fim" - outputdir = "." -! input = "/tg2/projects/fim/jlee/PREP/mdrag5h.dat" - input = "" -! if input has content, it overwrites the datadir -! output = "/p72/fim/wang/nc_files/mdrag5h.nc" - output = "" -! if output has content, it overwrites the outputdir - output_fmt = "grib" ! "nc" --netCDF file, "grib" --GRIB file - multiple_output_files = .true. ! -- multiple grib outputfiles (assumed true when post in fim) -! -! grid specifications: -! - gribtable = "fim_gribtable" ! only used by grib output file(s) - grid_id = 4 ! 228(144, 73), 45(288, 145), - ! 3(360, 181), 4(720, 361); only for grib output file. - mx = 720 ! only used by netcdf output file - my = 360 ! only used by netcdf output file - latlonfld = .true. ! 1 -- create lat lon field in grib output file, 0 -- otherwise -! -! post processing specifications: -! - is = 1 ! interpolation scheme: - ! 0 -- no interpolation: native grid; - ! 1 -- horizontal interpo. on native vertical coord.; - ! 2 -- horizontal interpo. + vertical interpo. on std. pressure levels; - ! 3 -- horizontal interpo. + vertical interpo. on 10mb inc. pressure levels; - vres = 111 ! only used in vertical interpolation - mode = "linear" ! step or linear interpolation for vertical column -! -! variable specifications: -! -! var_list = "mp3d th3d us3d vs3d rn2d rc2d sw2d lw2d ts2d " -! var_list = "hgtP tmpP rp3P up3P vp3P pr3D ph3D tk3D td3D ws3D rh3D us3D vs3D c13D c23D rn2D rc2D r12D r22D rg2D pw2D ts2D us2D hf2D qf2D sw2D lw2D ms2D sn2D cb2D ct2D fl2D" - var_list = 'hgtP','tmpP','rp3P','up3P','vp3P','pr3D','ph3D','tk3D','td3D','ws3D','rh3D', - 'us3D','vs3D','c13D','c23D','rn2D','rc2D','r12D','r22D','rg2D','pw2D','ts2D', - 'us2D','hf2D','qf2D','sw2D','lw2D','ms2D','sn2D','cb2D','ct2D','fl2D' - nsmooth_var = 4, 1, 1, 1, 1, 0, 4, 1, 1, 1, 1 , - 1, 1, 0, 0, 0 0, 0, 0, 0, 1, 0 , - 0, 0, 0, 4, 0, 0, 0, 0, 0, 0 - t1 = 0 - t2 = 24 - delta_t = 1 - gribout = .true. ! whether to write GRIB output files from FIM - fimout = .true. ! whether to write FIM binary output files -/ - -&chemwrf - chem_opt = 500 ! chem option, 0=off, 300=chem, 500=radiation - chemdt = 30. - kemit = 1 - chem_in_opt = 0 - DUST_OPT = 0, - DMSEMIS_OPT = 0, - SEAS_OPT = 0, - BIO_EMISS_OPT = 0, - BIOMASS_BURN_OPT = 0, - PLUMERISEFIRE_FRQ = 30, - EMISS_INPT_OPT = 1, - GAS_BC_OPT = 0, - GAS_IC_OPT = 0, - AER_BC_OPT = 0, - AER_IC_OPT = 0, - tr_mass = 1000., - tr_height = 200., -/ - -&wrfphysics - mp_physics = 0, ! 0=off, 2=on - cu_physics = 0, ! 0=off, 3=on -/ - -! -! System specific parameters for MPI, task geometry, etc. -! - &SYSTEMnamelist - MPIRUNCMD='mpirun -np' ! MPIRUNCMD should be defined as follows: - ! SGE 'mpirun -np' || torque 'aprun -n' || intel 'mpiexec_mpt -n' - ! load-leveler 'poe' || NCAR 'mpirun.lsf /usr/local/bin/launch' -/ - -! Everything below this line is of interest only to Workflow Manager users - -&WFMnamelist - max_run_time_prep='00:05:00' - max_run_time_fim='00:45:00' - max_run_time_pop='00:50:00' - batch_size='3' - ac_model_name='FIMCO2' - anx_model_names='GFS' - stats_model_name='FIMCO2' - sounding_model_name='FIMCO2' - ncl_model_name='EXPER FIMCO2' - ncl_diff_model_name='FIMCO2-FIM' - realtime='T' - rtfim_home='/whome/rtfim' - pe='thfip' - serialpe='thfip' - service='service' - mss='mss' - pes_no_x=240 - cycle='*' - GFSSANLDIR = '/public/data/grids/gfs/spectral' ! Location of the sanl file and the sfcanl file - ENKFSFCANLDIR = '/lfs1/projects/fim/whitaker/gfsenkf_t254' ! Location of the sanl file and the sfcanl file - init_file='gfs' - create_diff_plots='false' - ! Post processing: run the following tasks? (set to F to disable) - run_pop='T' ! Other post processing relies on pop to run - run_interp='T' - run_grib12='T' - run_tracker='T' - run_ncl='T' - -/ diff --git a/src/fim/FIMrun/FIMnamelist.FIMX.tjet b/src/fim/FIMrun/FIMnamelist.FIMX.tjet deleted file mode 100644 index 5191b8f..0000000 --- a/src/fim/FIMrun/FIMnamelist.FIMX.tjet +++ /dev/null @@ -1,232 +0,0 @@ - &QUEUEnamelist - ComputeTasks = '240' ! Number of compute tasks for FIM (S for Serial) -! ComputeTasks = '120' ! Number of compute tasks for FIM (S for Serial) - MaxQueueTime = '11:00:00' ! Run time for complete job (HH:MM:SS) [ Ignored by WFM ] - SRCDIR = '/lfs1/projects/rtfim/FIMX/FIMsrc_mvapich' ! FIM source location * MUST BE SET * [ WFM: use absolute pathname! ] - PREPDIR = 'nodir' ! If exists, use for prep otherwise calculate prep - FIMDIR = 'nodir' ! If exists, use for FIM otherwise calculate FIM - DATADIR = '/whome/rtfim/fimdata' ! Location of gfsltln and global_mtnvar files - DATADR2 = '/public/data/grids/gfs/spectral' ! Location of the sanl file and the sfcanl file - chem_datadir = '/whome/rtfim/fimdata_chem_G7'! Location of chemistry data files -/ - &TOPOnamelist - topodatfile = '/whome/rtfim/fimdata/wrf5mintopo.dat' - / -! &TOPOnamelist -! topodatdir = '/whome/rtfim/fimdata/' -!/ - &CNTLnamelist - glvl = 7 ! Grid level - SubdivNum = 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ! Subdivision numbers for each recursive refinement(2: bisection, 3: trisection, etc.) - nvl = 64 ! Number of atmospheric layers -/ - &PREPnamelist - curve = 0 ! 0: ij order; 1: Hilbert curve order (only for all-bisection refinement); 2:ij block order - NumCacheBlocksPerPE = 1 ! Number of cache blocks per processor. Only applies to ij block order - alt_topo = .true. ! if true, use alternate srf.height field - aerosol_file = 'climaeropac_global.txt' ! filename relative to DATADIR - co2_2008_file = 'co2historicaldata_2008.txt' ! filename relative to DATADIR - co2_glb_file = 'co2historicaldata_glob.txt' ! filename relative to DATADIR - gfsltln_file = 'no_such_file' ! Correct value will be set by run automation - mtnvar_file = 'no_such_file' ! Correct value will be set by run automation -/ - &DIAGnamelist - PrintIpnDiag = -1 ! ipn at which to print diagnostics (-1 means no print) - PrintDiagProgVars = 12 ! Hourly increment to print diagnostic prognosis variables (-1=>none, 0=>every step) - PrintDiagNoise = 1 ! Hourly increment to print diagnostic gravity wave noise (-1=>none, 0=>every step) - PrintDiags = .false. ! True means print diagnostic messages -/ - &MODELnamelist - nts = 0 ! number of time steps - rleigh_light = 0.0 ! rayleigh damping time scale (days^-1) if top-layer wind < 100 m/s - rleigh_heavy = 0.5 ! rayleigh damping time scale (days^-1) if top-layer wind > 100 m/s - veldff_bkgnd = 1. ! diffusion velocity (=diffusion/mesh size) - ptop = 50. ! pressure (Pa) at top of model domain - thktop = 50. ! min.thknss of uppermost model layer - intfc_smooth = 50. ! diffusivity (m/s) for intfc smoothing (0 = no smoothing) - slak = 0.5 ! intfc movement retardation coeff (1 = no retardation) - pure_sig = .false. ! if true, use pure sigma coord. -/ - &PHYSICSnamelist - PhysicsInterval = 180 ! Interval in seconds to call non-radiation physics (0=every step) - RadiationInterval = 1800 ! Interval in seconds to call radiation physics (0=every step) - GravityWaveDrag = .true. ! True means calculate gravity wave drag - ras = .false. - num_p3d = 4 -/ - &TIMEnamelist - yyyymmddhhmm = "200707170000" ! date of the model run -/ - &OUTPUTnamelist - ArchvTimeUnit = "hr" ! ts:timestep; mi:minute; hr:hour; dy:day; mo:month - TotalTime = 168 ! Total integration time in ArchvTimeUnit - ArchvIntvl = 6 ! Archive interval in ArchvTimeUnit - readrestart = .false. ! True means start by reading restart file (rpointer) - restart_freq = 240 ! Restart interval in ArchvTimeUnit - PrintMAXMINtimes = .true. ! True means print MAX MIN routine times, false means print for each PE - TimingBarriers = .false. ! True means turn on timed barriers to measure task skew, set to .false. for production runs - FixedGridOrder = .false. ! True: always output in the same order(IJ), False: order determined by curve. Does not apply to IJorder -/ - &ISOBARICnamelist - isobaric_levels_file = "output_isobaric_levs.txt" ! file containing pressure levels, in FIMrun directory - / -! -! WRITETASKnamelist is used to optionally create a separate group of -! FIM-specific write tasks to speed up FIM model output by overlapping disk -! writes with computation. By default this feature is turned off. When enabled, -! write tasks intercept FIM output and write to disk while the main compute -! tasks continue with model computation. In NEMS lingo, write tasks are called -! "quilt" tasks. -! -! WRITETASKnamelist is ignored for a serial run. -! - &WRITETASKnamelist - num_write_tasks = 1 ! Use: 0 = no write tasks, 1 = one, 21 = one write task per output file - max_write_tasks_per_node = 8 ! Maximum number of write tasks to place on a single node - cpn = 12 ! Number of cores per node - root_own_node = .true. ! whether root process has node to himself - abort_on_bad_task_distrib = .true. ! Abort FIM when node names are not as expected -/ - &DEBUGMSGnamelist - debugmsg_threshold = 0 ! Debug messages with priorities < threshold not printed (0=disable) -/ -! -! Namelist file for post processing -! -! Ning Wang, June 2007 -! - &POSTnamelist -! -! input and output specifications: -! - datadir = "../fim" - outputdir = "." -! input = "/tg2/projects/fim/jlee/PREP/mdrag5h.dat" - input = "" -! if input has content, it overwrites the datadir -! output = "/p72/fim/wang/nc_files/mdrag5h.nc" - output = "" -! if output has content, it overwrites the outputdir - output_fmt = "grib" ! "nc" --netCDF file, "grib" --GRIB file - multiple_output_files = .true. ! -- multiple grib outputfiles (assumed true when post in fim) -! -! grid specifications: -! - gribtable = "fim_gribtable" ! only used by grib output file(s) - grid_id = 4 ! 228(144, 73), 45(288, 145), - ! 3(360, 181), 4(720, 361); only for grib output file. - mx = 720 ! only used by netcdf output file - my = 360 ! only used by netcdf output file - latlonfld = .true. ! true -- create lat lon field in grib output file -! -! post processing specifications: -! - is = 1 ! interpolation scheme: - ! 0 -- no interpolation: native grid; - ! 1 -- horizontal interpo. on native vertical coord.; - ! 2 -- horizontal interpo. + vertical interpo. on std. pressure levels; - ! 3 -- horizontal interpo. + vertical interpo. on 10mb inc. pressure levels; - vres = 111 ! only used in vertical interpolation - mode = "linear" ! step or linear interpolation for vertical column -! -! variable specifications: -! -! var_list = "mp3d th3d us3d vs3d rn2d rc2d sw2d lw2d ts2d " -! var_list = 'td3D us3D ia2D id2d io2d ib2d vs3D ph3D pr3D sw2D lw2D ms2D sn2D' - var_list = 'hgtP', 'tmpP', 'rp3P', 'up3P', 'vp3P', 'pr3D', 'ph3D', 'tk3D', 'td3D', 'ws3D', - 'rh3D', 'us3D', 'vs3D', 'rn2D', 'rc2D', 'r12D', 'r22D', 'rg2D', 'pw2D', 'ts2D', - 'us2D', 'hf2D', 'qf2D', 'sw2D', 'lw2D', 'ms2D', 'sn2D', 'cb2D', 'ct2D', 'ia2D', -! 'ib2D', 'io2D', 'is2D', 'id2D', 'ao2D', 'ash1', 'ash2', 'ash3', 'ash4', 'iash', - 'ib2D', 'io2D', 'is2D', 'id2D', 'ao2D', - 'oc1P', 'oc2P', 'bc1P', 'bc2P', 'so2P', 'slfP', 'd1sP', 'd2sP', 'd3sP', 'd4sP', - 'd5sP', 's1sP', 's2sP', 's3sP', 's4sP', 'dmsP', 'msaP', 'p25P' - - nsmooth_var = 4, 1, 1, 1, 1, 0, 4, 1, 1, 1, - 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, - 1, 0, 0, 0, 0, 4, 0, 0, 0, 0, -! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0 - - fimout = .true. ! whether to write FIM binary output files - gribout = .true. ! whether to write GRIB output files from FIM - t1 = 0 - t2 = 168 - delta_t = 6 - -/ - -&chemwrf - chem_opt = 300 ! chem option, 0=off, 300=on - chemdt = 60. - chem_in_opt = 1 - kemit = 1 - aer_ra_feedback = 1, -! ash_height = 7000., -! ash_mass = 3500., - ash_height = 0., - ash_mass = 0., - DUST_OPT = 3, - DMSEMIS_OPT = 1, - SEAS_OPT = 1, - BIO_EMISS_OPT = 0, - BIOMASS_BURN_OPT = 1, - PLUMERISEFIRE_FRQ = 30, - EMISS_INPT_OPT = 1, - GAS_BC_OPT = 0, - GAS_IC_OPT = 0, - AER_BC_OPT = 0, - AER_IC_OPT = 0, -/ - -&wrfphysics - mp_physics = 0, ! 0=off, 2=on - cu_physics = 0, ! 0=off, 3=on -/ - -! -! System specific parameters for MPI, task geometry, etc. -! - &SYSTEMnamelist - MPIRUNCMD='mpirun -np' ! MPIRUNCMD should be defined as follows: - ! SGE 'mpirun -np' || torque 'aprun -n' || intel 'mpiexec_mpt -n' - ! load-leveler 'poe' || NCAR 'mpirun.lsf /usr/local/bin/launch' -/ - -! Everything below this line is of interest only to Workflow Manager users - -&WFMnamelist - project='fim-njet' - max_run_time_prep='00:05:00' - max_run_time_fim='02:15:00' - max_run_time_fim_12hr_fcst='01:00:00' - max_run_time_pop='01:15:00' - batch_size='3' - ac_model_name='FIMXDC' - anx_model_names='GFS' - stats_model_name='FIMX' - sounding_model_name='FIMX' - ncl_model_name='FIMX' - ncl_diff_model_name='FIM7-FIMX' - realtime='T' - rtfim_home='/whome/rtfim' - fim_home_no_x='/lfs1/projects/rtfim/FIM7' - pe='thfip' - serialpe='thfip' - service='service' - mss='mss' - cycle='*' - pes_no_x=120 - GFSSANLDIR = '/public/data/grids/gfs/spectral' ! Location of the sanl file and the sfcanl file - ENKFSFCANLDIR = '/lfs1/projects/fim/whitaker/gfsenkf_hybrid' ! Location of the sanl file and the sfcanl file - init_file='gfs' - create_diff_plots='true' - ! Post processing: run the following tasks? (set to F to disable) - run_pop='T' ! Other post processing relies on pop to run - run_interp='T' - run_grib12='T' - run_tracker='T' - run_ncl='T' - -/ diff --git a/src/fim/FIMrun/FIMnamelist.FIMY.tjet b/src/fim/FIMrun/FIMnamelist.FIMY.tjet deleted file mode 100644 index b09e5e0..0000000 --- a/src/fim/FIMrun/FIMnamelist.FIMY.tjet +++ /dev/null @@ -1,212 +0,0 @@ - &QUEUEnamelist - ComputeTasks = '600' ! Number of compute tasks for FIM (S for Serial) -! ComputeTasks = '24' ! Number of compute tasks for FIM (S for Serial) - MaxQueueTime = '09:00:00' ! Run time for complete job (HH:MM:SS) [ Ignored by WFM ] - SRCDIR = '/lfs0/projects/rtfim/FIMY/FIMsrc_mvapich' ! FIM source location * MUST BE SET * [ WFM: use absolute pathname! ] - PREPDIR = 'nodir' ! If exists, use for prep otherwise calculate prep - FIMDIR = 'nodir' ! If exists, use for FIM otherwise calculate FIM - DATADIR = '/whome/rtfim/fimdata' ! Location of gfsltln and global_mtnvar files - DATADR2 = '/lfs1/projects/fim/whitaker/gfsenkf_t574' ! Location of the sanl file and the sfcanl file - chem_datadir = '/lfs1/projects/fim/fimdata' ! Location of chemistry data files -/ - &TOPOnamelist - topodatfile = '/whome/rtfim/fimdata/wrf5mintopo.dat' -/ - &CNTLnamelist - glvl = 8 ! Grid level - SubdivNum = 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ! Subdivision numbers for each recursive refinement(2: bisection, 3: trisection, etc.) - nvl = 64 ! Number of atmospheric layers -/ - &PREPnamelist - curve = 2 ! 0: ij order; 1: Hilbert curve order (only for all-bisection refinement); 2:ij block order - NumCacheBlocksPerPE = 4 ! Number of cache blocks per processor. Only applies to ij block order - alt_topo = .true. ! if true, use alternate srf.height field - aerosol_file = 'climaeropac_global.txt' ! filename relative to DATADIR - co2_2008_file = 'co2historicaldata_2008.txt' ! filename relative to DATADIR - co2_glb_file = 'co2historicaldata_glob.txt' ! filename relative to DATADIR - gfsltln_file = 'no_such_file' ! Correct value will be set by run automation - mtnvar_file = 'no_such_file' ! Correct value will be set by run automation -/ - &DIAGnamelist - PrintIpnDiag = -1 ! ipn at which to print diagnostics (-1 means no print) - PrintDiagProgVars = 24 ! Hourly increment to print diagnostic prognosis variables (-1=>none, 0=>every step) - PrintDiagNoise = 1 ! Hourly increment to print diagnostic gravity wave noise (-1=>none, 0=>every step) - PrintDiags = .false. ! True means print diagnostic messages -/ - &MODELnamelist - nts = 0 ! number of time steps - UpdateSST = .false. ! True means update sst and sea ice by reading in a file during integration - rleigh_light = 0.0 ! rayleigh damping time scale (days^-1) if top-layer wind < 100 m/s - rleigh_heavy = 0.5 ! rayleigh damping time scale (days^-1) if top-layer wind > 100 m/s - veldff_bkgnd = 1. ! diffusion velocity (=diffusion/mesh size) - ptop = 50. ! pressure (Pa) at top of model domain - thktop = 50. ! min.thknss of uppermost model layer - intfc_smooth = 50. ! diffusivity (m/s) for intfc smoothing (0 = no smoothing) - slak = 0.5 ! intfc movement retardation coeff (1 - pure_sig = .false. ! if true, use pure sigma coord. -/ - &PHYSICSnamelist - PhysicsInterval = 180 ! Interval in seconds to call non-radiation physics (0=every step) - RadiationInterval = 3600 ! Interval in seconds to call radiation physics (0=every step) - SSTInterval = 86400 ! Interval in seconds to call update_sst (0=every step) - GravityWaveDrag = .true. ! True means calculate gravity wave drag -/ - &TIMEnamelist - yyyymmddhhmm = "201106080000" ! date of the model run -/ - &OUTPUTnamelist - ArchvTimeUnit = "hr" ! ts:timestep; mi:minute; hr:hour; dy:day; mo:month - TotalTime = 240 ! Total integration time in ArchvTimeUnit - ArchvIntvl = 6 ! Archive interval in ArchvTimeUnit - readrestart = .false. ! True means start by reading restart file (rpointer) - restart_freq = 480 ! Restart interval in ArchvTimeUnit - PrintMAXMINtimes = .true. ! True means print MAX MIN routine times, false means print for each PE - TimingBarriers = .false. ! True means turn on timed barriers to measure task skew, set to .false. for production runs - FixedGridOrder = .false. ! True: always output in the same order(IJ), False: order determined by curve. Does not apply to IJorder -/ - &ISOBARICnamelist - isobaric_levels_file = "output_isobaric_levs.txt" ! file containing pressure levels, in FIMrun directory - / -! -! WRITETASKnamelist is used to optionally create a separate group of -! FIM-specific write tasks to speed up FIM model output by overlapping disk -! writes with computation. By default this feature is turned off. When enabled, -! write tasks intercept FIM output and write to disk while the main compute -! tasks continue with model computation. In NEMS lingo, write tasks are called -! "quilt" tasks. -! -! WRITETASKnamelist is ignored for a serial run. -! - &WRITETASKnamelist - num_write_tasks = 1 ! Use: 0 = no write tasks, 1 = one, 21 = one write task per output file - max_write_tasks_per_node = 8 ! Maximum number of write tasks to place on a single node - cpn = 12 ! Number of cores per node - root_own_node = .true. ! whether root process has node to himself - abort_on_bad_task_distrib = .true. ! Abort FIM when node names are not as expected -/ - &DEBUGMSGnamelist - debugmsg_threshold = 0 ! Debug messages with priorities < threshold not printed (0=disable) -/ -! -! Namelist file for post processing -! -! Ning Wang, June 2007 -! - &POSTnamelist -! -! input and output specifications: -! - datadir = "../fim" - outputdir = "." -! input = "/tg2/projects/fim/jlee/PREP/mdrag5h.dat" - input = "" -! if input has content, it overwrites the datadir -! output = "/p72/fim/wang/nc_files/mdrag5h.nc" - output = "" -! if output has content, it overwrites the outputdir - output_fmt = "grib" ! "nc" --netCDF file, "grib" --GRIB file - multiple_output_files = .true. ! -- multiple grib outputfiles (assumed true when post in fim) -! -! grid specifications: -! - gribtable = "fim_gribtable" ! only used by grib output file(s) - grid_id = 4 ! 228(144, 73), 45(288, 145), - ! 3(360, 181), 4(720, 361); only for grib output file. - mx = 720 ! only used by netcdf output file - my = 360 ! only used by netcdf output file - latlonfld = .true. ! true -- create lat lon field in grib output file -! -! post processing specifications: -! - is = 1 ! interpolation scheme: - ! 0 -- no interpolation: native grid; - ! 1 -- horizontal interpo. on native vertical coord.; - ! 2 -- horizontal interpo. + vertical interpo. on std. pressure levels; - ! 3 -- horizontal interpo. + vertical interpo. on 10mb inc. pressure levels; - vres = 111 ! only used in vertical interpolation - mode = "linear" ! step or linear interpolation for vertical column -! -! variable specifications: -! -! var_list = 'mp3d', 'th3d', 'us3d', 'vs3d', 'rn2d', 'rc2d', 'sw2d', 'lw2d', 'ts2d' - var_list = 'hgtP', 'tmpP', 'rp3P', 'up3P', 'vp3P', 'pr3D', 'ph3D', 'tk3D', 'td3D', 'ws3D', - 'rh3D', 'us3D', 'vs3D', 'rn2D', 'rc2D', 'r12D', 'r22D', 'rg2D', 'pw2D', 'ts2D', - 'us2D', 'hf2D', 'qf2D', 'sw2D', 'lw2D', 'ms2D', 'sn2D', 'cb2D', 'ct2D', 'u12D', 'v12D' - - nsmooth_var = 4, 1, 1, 1, 1, 0, 4, 1, 1, 1, - 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, - 1, 0, 0, 0, 0, 4, 0, 0, 0, 0, 0 - fimout = .true. ! whether to write FIM binary output files - gribout = .true. ! whether to write GRIB output files from FIM - t1 = 0 - t2 = 240 - delta_t = 3 - -/ - -&chemwrf - chem_opt = 0 ! chem option, 0=off, 300=on - chemdt = 30. - kemit = 1 - DUST_OPT = 1, - DMSEMIS_OPT = 1, - SEAS_OPT = 0, - BIO_EMISS_OPT = 0, - BIOMASS_BURN_OPT = 1, - PLUMERISEFIRE_FRQ = 30, - EMISS_INPT_OPT = 1, - GAS_BC_OPT = 0, - GAS_IC_OPT = 0, - AER_BC_OPT = 0, - AER_IC_OPT = 0, -/ - -&wrfphysics - mp_physics = 0, ! 0=off, 2=on - cu_physics = 0, ! 0=off, 3=on -/ - -! -! System specific parameters for MPI, task geometry, etc. -! - &SYSTEMnamelist - MPIRUNCMD='mpirun -hostfile $hostfilein -np' ! MPIRUNCMD should be defined as follows: - ! SGE 'mpirun -np' || torque 'aprun -n' || intel 'mpiexec_mpt -n' - ! load-leveler 'poe' || NCAR 'mpirun.lsf /usr/local/bin/launch' -/ - -! Everything below this line is of interest only to Workflow Manager users - -&WFMnamelist - max_run_time_prep='00:05:00' - max_run_time_fim='05:30:00' - max_run_time_pop='00:30:00' - batch_size='3' - ac_model_name='FIMY' -! anx_model_names='ENKF:GFS' - anx_model_names='ENKF' - stats_model_name='FIMY' - sounding_model_name='FIMY' - ncl_model_name='EXPER FIMY-8' - ncl_diff_model_name='FIM-FIMY' - realtime='T' - rtfim_home='/whome/rtfim' - fim_home_no_x='/lfs0/projects/rtfim/FIM' - pe='thfip' - serialpe='thfip' - service='service' - mss='mss' - pes_no_x=240 - cycle='*' - GFSSANLDIR = '/public/data/grids/gfs/spectral' ! Location of the sanl file and the sfcanl file - ENKFSFCANLDIR = '/lfs1/projects/fim/whitaker/gfsenkf_t574' ! Location of the sanl file and the sfcanl file - init_file='enkf' - create_diff_plots='true' - ! Post processing: run the following tasks? (set to F to disable) - run_pop='T' ! Other post processing relies on pop to run - run_interp='T' - run_grib12='T' - run_tracker='T' - run_ncl='T' - -/ diff --git a/src/fim/FIMrun/FIMnamelist.FIMYENS.tjet b/src/fim/FIMrun/FIMnamelist.FIMYENS.tjet deleted file mode 100644 index c482d24..0000000 --- a/src/fim/FIMrun/FIMnamelist.FIMYENS.tjet +++ /dev/null @@ -1,216 +0,0 @@ - &QUEUEnamelist - ComputeTasks = '96' ! Number of compute tasks for FIM (S for Serial) -! ComputeTasks = '24' ! Number of compute tasks for FIM (S for Serial) - MaxQueueTime = '09:00:00' ! Run time for complete job (HH:MM:SS) [ Ignored by WFM ] - SRCDIR = '/lfs1/projects/rtfim/FIMYENS/FIMsrc_mvapich' ! FIM source location * MUST BE SET * [ WFM: use absolute pathname! ] - PREPDIR = 'nodir' ! If exists, use for prep otherwise calculate prep - FIMDIR = 'nodir' ! If exists, use for FIM otherwise calculate FIM - DATADIR = '/whome/rtfim/fimdata' ! Location of gfsltln and global_mtnvar files - DATADR2 = '/lfs1/projects/gfsenkf/gfsenkf_t574' ! Location of the sanl file and the sfcanl file - chem_datadir = '/lfs1/projects/fim/fimdata' ! Location of chemistry data files -/ - &TOPOnamelist - topodatfile = '/whome/rtfim/fimdata/wrf5mintopo.dat' -/ - &CNTLnamelist - glvl = 7 ! Grid level - SubdivNum = 2 2 2 2 2 3 3 2 2 2 2 2 2 2 2 2 2 2 2 2 ! Subdivision numbers for each recursive refinement(2: bisection, 3: trisection, etc.) - nvl = 64 ! Number of atmospheric layers -/ - &PREPnamelist - curve = 2 ! 0: ij order; 1: Hilbert curve order (only for all-bisection refinement); 2:ij block order - NumCacheBlocksPerPE = 4 ! Number of cache blocks per processor. Only applies to ij block order - alt_topo = .true. ! if true, use alternate srf.height field - aerosol_file = 'climaeropac_global.txt' ! filename relative to DATADIR - co2_2008_file = 'co2historicaldata_2008.txt' ! filename relative to DATADIR - co2_glb_file = 'co2historicaldata_glob.txt' ! filename relative to DATADIR -! gfsltln_file = 'no_such_file' ! Correct value will be set by run automation -! mtnvar_file = 'no_such_file' ! Correct value will be set by run automation - gfsltln_file = 'gfsltln_t254.dat' ! FIMY Ensemble run - mtnvar_file = 'global_mtnvar.t254' ! FIMY Ensemble run -/ - &DIAGnamelist - PrintIpnDiag = -1 ! ipn at which to print diagnostics (-1 means no print) - PrintDiagProgVars = 24 ! Hourly increment to print diagnostic prognosis variables (-1=>none, 0=>every step) - PrintDiagNoise = 1 ! Hourly increment to print diagnostic gravity wave noise (-1=>none, 0=>every step) - PrintDiags = .false. ! True means print diagnostic messages -/ - &MODELnamelist - nts = 0 ! number of time steps - UpdateSST = .false. ! True means update sst and sea ice by reading in a file during integration - rleigh_light = 0.0 ! rayleigh damping time scale (days^-1) if top-layer wind < 100 m/s - rleigh_heavy = 0.5 ! rayleigh damping time scale (days^-1) if top-layer wind > 100 m/s - veldff_bkgnd = 1. ! diffusion velocity (=diffusion/mesh size) - ptop = 50. ! pressure (Pa) at top of model domain - thktop = 50. ! min.thknss of uppermost model layer - intfc_smooth = 50. ! diffusivity (m/s) for intfc smoothing (0 = no smoothing) - slak = 0.5 ! intfc movement retardation coeff (1 - pure_sig = .false. ! if true, use pure sigma coord. -/ - &PHYSICSnamelist - PhysicsInterval = 180 ! Interval in seconds to call non-radiation physics (0=every step) - RadiationInterval = 3600 ! Interval in seconds to call radiation physics (0=every step) - SSTInterval = 86400 ! Interval in seconds to call update_sst (0=every step) - GravityWaveDrag = .true. ! True means calculate gravity wave drag -/ - &TIMEnamelist - yyyymmddhhmm = "201108240000" ! date of the model run -/ - &OUTPUTnamelist - ArchvTimeUnit = "hr" ! ts:timestep; mi:minute; hr:hour; dy:day; mo:month - TotalTime = 162 ! Total integration time in ArchvTimeUnit - ArchvIntvl = 6 ! Archive interval in ArchvTimeUnit - readrestart = .false. ! True means start by reading restart file (rpointer) - restart_freq = 240 ! Restart interval in ArchvTimeUnit - PrintMAXMINtimes = .true. ! True means print MAX MIN routine times, false means print for each PE - TimingBarriers = .false. ! True means turn on timed barriers to measure task skew, set to .false. for production runs - FixedGridOrder = .false. ! True: always output in the same order(IJ), False: order determined by curve. Does not apply to IJorder -/ - &ISOBARICnamelist - isobaric_levels_file = "output_isobaric_levs.txt" ! file containing pressure levels, in FIMrun directory - / -! -! WRITETASKnamelist is used to optionally create a separate group of -! FIM-specific write tasks to speed up FIM model output by overlapping disk -! writes with computation. By default this feature is turned off. When enabled, -! write tasks intercept FIM output and write to disk while the main compute -! tasks continue with model computation. In NEMS lingo, write tasks are called -! "quilt" tasks. -! -! WRITETASKnamelist is ignored for a serial run. -! - &WRITETASKnamelist - num_write_tasks = 1 ! Use: 0 = no write tasks, 1 = one, 21 = one write task per output file - max_write_tasks_per_node = 8 ! Maximum number of write tasks to place on a single node - cpn = 12 ! Number of cores per node - root_own_node = .true. ! whether root process has node to himself - abort_on_bad_task_distrib = .true. ! Abort FIM when node names are not as expected -/ - &DEBUGMSGnamelist - debugmsg_threshold = 0 ! Debug messages with priorities < threshold not printed (0=disable) -/ -! -! Namelist file for post processing -! -! Ning Wang, June 2007 -! - &POSTnamelist -! -! input and output specifications: -! - datadir = "../fim" - outputdir = "." -! input = "/tg2/projects/fim/jlee/PREP/mdrag5h.dat" - input = "" -! if input has content, it overwrites the datadir -! output = "/p72/fim/wang/nc_files/mdrag5h.nc" - output = "" -! if output has content, it overwrites the outputdir - output_fmt = "grib" ! "nc" --netCDF file, "grib" --GRIB file - multiple_output_files = .true. ! -- multiple grib outputfiles (assumed true when post in fim) -! -! grid specifications: -! - gribtable = "fim_gribtable" ! only used by grib output file(s) - grid_id = 4 ! 228(144, 73), 45(288, 145), - ! 3(360, 181), 4(720, 361); only for grib output file. - mx = 720 ! only used by netcdf output file - my = 360 ! only used by netcdf output file - latlonfld = .true. ! true -- create lat lon field in grib output file -! -! post processing specifications: -! - is = 1 ! interpolation scheme: - ! 0 -- no interpolation: native grid; - ! 1 -- horizontal interpo. on native vertical coord.; - ! 2 -- horizontal interpo. + vertical interpo. on std. pressure levels; - ! 3 -- horizontal interpo. + vertical interpo. on 10mb inc. pressure levels; - vres = 111 ! only used in vertical interpolation - mode = "linear" ! step or linear interpolation for vertical column -! -! variable specifications: -! -! var_list = 'mp3d', 'th3d', 'us3d', 'vs3d', 'rn2d', 'rc2d', 'sw2d', 'lw2d', 'ts2d' - var_list = 'hgtP', 'tmpP', 'rp3P', 'up3P', 'vp3P', 'pr3D', 'ph3D', 'tk3D', 'td3D', 'ws3D', - 'rh3D', 'us3D', 'vs3D', 'rn2D', 'rc2D', 'r12D', 'r22D', 'rg2D', 'pw2D', 'ts2D', - 'us2D', 'hf2D', 'qf2D', 'sw2D', 'lw2D', 'ms2D', 'sn2D', 'cb2D', 'ct2D', 'u12D', 'v12D' - - nsmooth_var = 4, 1, 1, 1, 1, 0, 4, 1, 1, 1, - 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, - 1, 0, 0, 0, 0, 4, 0, 0, 0, 0, 0 - fimout = .true. ! whether to write FIM binary output files - gribout = .true. ! whether to write GRIB output files from FIM - t1 = 0 - t2 = 240 - delta_t = 3 - -/ - -&chemwrf - chem_opt = 0 ! chem option, 0=off, 300=on - chemdt = 30. - kemit = 1 - DUST_OPT = 1, - DMSEMIS_OPT = 1, - SEAS_OPT = 0, - BIO_EMISS_OPT = 0, - BIOMASS_BURN_OPT = 1, - PLUMERISEFIRE_FRQ = 30, - EMISS_INPT_OPT = 1, - GAS_BC_OPT = 0, - GAS_IC_OPT = 0, - AER_BC_OPT = 0, - AER_IC_OPT = 0, -/ - -&wrfphysics - mp_physics = 0, ! 0=off, 2=on - cu_physics = 0, ! 0=off, 3=on -/ - -! -! System specific parameters for MPI, task geometry, etc. -! - &SYSTEMnamelist - MPIRUNCMD='mpirun -np' - ! MPIRUNCMD='mpirun -hostfile $hostfilein -np' ! MPIRUNCMD should be defined as follows: - ! SGE 'mpirun -np' || torque 'aprun -n' || intel 'mpiexec_mpt -n' - ! load-leveler 'poe' || NCAR 'mpirun.lsf /usr/local/bin/launch' -/ - -! Everything below this line is of interest only to Workflow Manager users - -&WFMnamelist - max_run_time_prep='00:05:00' - max_run_time_fim='08:35:00' - max_run_time_pop='00:30:00' - batch_size='3' - ac_model_name='FIMYENS' -! anx_model_names='ENKF:GFS' - anx_model_names='ENKF' - stats_model_name='FIMYENS' - sounding_model_name='FIMYENS' - ncl_model_name='EXPER FIMYENS-8' - ncl_diff_model_name='FIM-FIMYENS' - realtime='T' - rtfim_home='/whome/rtfim' - fim_home_no_x='/lfs1/projects/rtfim/FIM' - pe='thfip' - serialpe='thfip' - service='service' - mss='mss' - pes_no_x=240 - cycle='*' - GFSSANLDIR = '/public/data/grids/gfs/spectral' ! Location of the sanl file and the sfcanl file - ENKFSFCANLDIR = '/lfs1/projects/fim/whitaker/gfsenkf_t574' ! Location of the sanl file and the sfcanl file - init_file='ens' - create_diff_plots='false' - ! Post processing: run the following tasks? (set to F to disable) - run_pop='T' ! Other post processing relies on pop to run - run_interp='F' - run_grib12='F' - run_tracker='T' - run_ncl='F' - project='rtfim-njet' - fim_reservation='T' -/ diff --git a/src/fim/FIMrun/FIMnamelist.FIMY_ENKF.tjet b/src/fim/FIMrun/FIMnamelist.FIMY_ENKF.tjet deleted file mode 100644 index e80c21f..0000000 --- a/src/fim/FIMrun/FIMnamelist.FIMY_ENKF.tjet +++ /dev/null @@ -1,211 +0,0 @@ - &QUEUEnamelist - ComputeTasks = '600' ! Number of compute tasks for FIM (S for Serial) -! ComputeTasks = '24' ! Number of compute tasks for FIM (S for Serial) - MaxQueueTime = '09:00:00' ! Run time for complete job (HH:MM:SS) [ Ignored by WFM ] - SRCDIR = '/lfs0/projects/rtfim/FIMY_ENKF/FIMsrc_mvapich' ! FIM source location * MUST BE SET * [ WFM: use absolute pathname! ] - PREPDIR = 'nodir' ! If exists, use for prep otherwise calculate prep - FIMDIR = 'nodir' ! If exists, use for FIM otherwise calculate FIM - DATADIR = '/whome/rtfim/fimdata' ! Location of gfsltln and global_mtnvar files - DATADR2 = '/lfs1/projects/fim/whitaker/gfsenkf_t574' ! Location of the sanl file and the sfcanl file - chem_datadir = '/lfs1/projects/fim/fimdata' ! Location of chemistry data files -/ - &TOPOnamelist - topodatfile = '/whome/rtfim/fimdata/wrf5mintopo.dat' -/ - &CNTLnamelist - glvl = 8 ! Grid level - SubdivNum = 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ! Subdivision numbers for each recursive refinement(2: bisection, 3: trisection, etc.) - nvl = 64 ! Number of atmospheric layers -/ - &PREPnamelist - curve = 2 ! 0: ij order; 1: Hilbert curve order (only for all-bisection refinement); 2:ij block order - NumCacheBlocksPerPE = 4 ! Number of cache blocks per processor. Only applies to ij block order - alt_topo = .true. ! if true, use alternate srf.height field - aerosol_file = 'climaeropac_global.txt' ! filename relative to DATADIR - co2_2008_file = 'co2historicaldata_2008.txt' ! filename relative to DATADIR - co2_glb_file = 'co2historicaldata_glob.txt' ! filename relative to DATADIR - gfsltln_file = 'no_such_file' ! Correct value will be set by run automation - mtnvar_file = 'no_such_file' ! Correct value will be set by run automation -/ - &DIAGnamelist - PrintIpnDiag = -1 ! ipn at which to print diagnostics (-1 means no print) - PrintDiagProgVars = 24 ! Hourly increment to print diagnostic prognosis variables (-1=>none, 0=>every step) - PrintDiagNoise = 1 ! Hourly increment to print diagnostic gravity wave noise (-1=>none, 0=>every step) - PrintDiags = .false. ! True means print diagnostic messages -/ - &MODELnamelist - nts = 0 ! number of time steps - UpdateSST = .false. ! True means update sst and sea ice by reading in a file during integration - rleigh_light = 0.0 ! rayleigh damping time scale (days^-1) if top-layer wind < 100 m/s - rleigh_heavy = 0.5 ! rayleigh damping time scale (days^-1) if top-layer wind > 100 m/s - veldff_bkgnd = 1. ! diffusion velocity (=diffusion/mesh size) - ptop = 50. ! pressure (Pa) at top of model domain - thktop = 50. ! min.thknss of uppermost model layer - intfc_smooth = 50. ! diffusivity (m/s) for intfc smoothing (0 = no smoothing) - slak = 0.5 ! intfc movement retardation coeff (1 - pure_sig = .false. ! if true, use pure sigma coord. -/ - &PHYSICSnamelist - PhysicsInterval = 180 ! Interval in seconds to call non-radiation physics (0=every step) - RadiationInterval = 3600 ! Interval in seconds to call radiation physics (0=every step) - SSTInterval = 86400 ! Interval in seconds to call update_sst (0=every step) - GravityWaveDrag = .true. ! True means calculate gravity wave drag -/ - &TIMEnamelist - yyyymmddhhmm = "201106080000" ! date of the model run -/ - &OUTPUTnamelist - ArchvTimeUnit = "hr" ! ts:timestep; mi:minute; hr:hour; dy:day; mo:month - TotalTime = 240 ! Total integration time in ArchvTimeUnit - ArchvIntvl = 6 ! Archive interval in ArchvTimeUnit - readrestart = .false. ! True means start by reading restart file (rpointer) - restart_freq = 480 ! Restart interval in ArchvTimeUnit - PrintMAXMINtimes = .true. ! True means print MAX MIN routine times, false means print for each PE - TimingBarriers = .false. ! True means turn on timed barriers to measure task skew, set to .false. for production runs - FixedGridOrder = .false. ! True: always output in the same order(IJ), False: order determined by curve. Does not apply to IJorder -/ - &ISOBARICnamelist - isobaric_levels_file = "output_isobaric_levs.txt" ! file containing pressure levels, in FIMrun directory - / -! -! WRITETASKnamelist is used to optionally create a separate group of -! FIM-specific write tasks to speed up FIM model output by overlapping disk -! writes with computation. By default this feature is turned off. When enabled, -! write tasks intercept FIM output and write to disk while the main compute -! tasks continue with model computation. In NEMS lingo, write tasks are called -! "quilt" tasks. -! -! WRITETASKnamelist is ignored for a serial run. -! - &WRITETASKnamelist - num_write_tasks = 1 ! Use: 0 = no write tasks, 1 = one, 21 = one write task per output file - max_write_tasks_per_node = 8 ! Maximum number of write tasks to place on a single node - cpn = 12 ! Number of cores per node - root_own_node = .true. ! whether root process has node to himself - abort_on_bad_task_distrib = .true. ! Abort FIM when node names are not as expected -/ - &DEBUGMSGnamelist - debugmsg_threshold = 0 ! Debug messages with priorities < threshold not printed (0=disable) -/ -! -! Namelist file for post processing -! -! Ning Wang, June 2007 -! - &POSTnamelist -! -! input and output specifications: -! - datadir = "../fim" - outputdir = "." -! input = "/tg2/projects/fim/jlee/PREP/mdrag5h.dat" - input = "" -! if input has content, it overwrites the datadir -! output = "/p72/fim/wang/nc_files/mdrag5h.nc" - output = "" -! if output has content, it overwrites the outputdir - output_fmt = "grib" ! "nc" --netCDF file, "grib" --GRIB file - multiple_output_files = .true. ! -- multiple grib outputfiles (assumed true when post in fim) -! -! grid specifications: -! - gribtable = "fim_gribtable" ! only used by grib output file(s) - grid_id = 4 ! 228(144, 73), 45(288, 145), - ! 3(360, 181), 4(720, 361); only for grib output file. - mx = 720 ! only used by netcdf output file - my = 360 ! only used by netcdf output file - latlonfld = .true. ! true -- create lat lon field in grib output file -! -! post processing specifications: -! - is = 1 ! interpolation scheme: - ! 0 -- no interpolation: native grid; - ! 1 -- horizontal interpo. on native vertical coord.; - ! 2 -- horizontal interpo. + vertical interpo. on std. pressure levels; - ! 3 -- horizontal interpo. + vertical interpo. on 10mb inc. pressure levels; - vres = 111 ! only used in vertical interpolation - mode = "linear" ! step or linear interpolation for vertical column -! -! variable specifications: -! -! var_list = 'mp3d', 'th3d', 'us3d', 'vs3d', 'rn2d', 'rc2d', 'sw2d', 'lw2d', 'ts2d' - var_list = 'hgtP', 'tmpP', 'rp3P', 'up3P', 'vp3P', 'pr3D', 'ph3D', 'tk3D', 'td3D', 'ws3D', - 'rh3D', 'us3D', 'vs3D', 'rn2D', 'rc2D', 'r12D', 'r22D', 'rg2D', 'pw2D', 'ts2D', - 'us2D', 'hf2D', 'qf2D', 'sw2D', 'lw2D', 'ms2D', 'sn2D', 'cb2D', 'ct2D' - nsmooth_var = 4, 1, 1, 1, 1, 0, 4, 1, 1, 1, - 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, - 1, 0, 0, 0, 0, 4, 0, 0, 0 - fimout = .true. ! whether to write FIM binary output files - gribout = .true. ! whether to write GRIB output files from FIM - t1 = 0 - t2 = 240 - delta_t = 3 - -/ - -&chemwrf - chem_opt = 0 ! chem option, 0=off, 300=on - chemdt = 30. - kemit = 1 - DUST_OPT = 1, - DMSEMIS_OPT = 1, - SEAS_OPT = 0, - BIO_EMISS_OPT = 0, - BIOMASS_BURN_OPT = 1, - PLUMERISEFIRE_FRQ = 30, - EMISS_INPT_OPT = 1, - GAS_BC_OPT = 0, - GAS_IC_OPT = 0, - AER_BC_OPT = 0, - AER_IC_OPT = 0, -/ - -&wrfphysics - mp_physics = 0, ! 0=off, 2=on - cu_physics = 0, ! 0=off, 3=on -/ - -! -! System specific parameters for MPI, task geometry, etc. -! - &SYSTEMnamelist - MPIRUNCMD='mpirun -hostfile $hostfilein -np' ! MPIRUNCMD should be defined as follows: - ! SGE 'mpirun -np' || torque 'aprun -n' || intel 'mpiexec_mpt -n' - ! load-leveler 'poe' || NCAR 'mpirun.lsf /usr/local/bin/launch' -/ - -! Everything below this line is of interest only to Workflow Manager users - -&WFMnamelist - max_run_time_prep='00:05:00' - max_run_time_fim='05:30:00' - max_run_time_pop='00:30:00' - batch_size='3' - ac_model_name='FIMY_ENKF' -! anx_model_names='ENKF:GFS' - anx_model_names='ENKF' - stats_model_name='FIMY_ENKF' - sounding_model_name='FIMY_ENKF' - ncl_model_name='EXPER FIMY_ENKF-8' - ncl_diff_model_name='FIM-FIMY_ENKF' - realtime='T' - rtfim_home='/whome/rtfim' - fim_home_no_x='/lfs0/projects/rtfim/FIM' - pe='thfip' - serialpe='thfip' - service='service' - mss='mss' - pes_no_x=240 - cycle='*' - GFSSANLDIR = '/public/data/grids/gfs/spectral' ! Location of the sanl file and the sfcanl file - ENKFSFCANLDIR = '/lfs1/projects/fim/whitaker/gfsenkf_t574' ! Location of the sanl file and the sfcanl file - init_file='enkf' - create_diff_plots='true' - ! Post processing: run the following tasks? (set to F to disable) - run_pop='T' ! Other post processing relies on pop to run - run_interp='T' - run_grib12='T' - run_tracker='T' - run_ncl='T' - -/ diff --git a/src/fim/FIMrun/FIMnamelist.FIMZ.tjet b/src/fim/FIMrun/FIMnamelist.FIMZ.tjet deleted file mode 100644 index ec1f443..0000000 --- a/src/fim/FIMrun/FIMnamelist.FIMZ.tjet +++ /dev/null @@ -1,214 +0,0 @@ - &QUEUEnamelist - ComputeTasks = '240' ! Number of compute tasks for FIM (S for Serial) - MaxQueueTime = '08:00:00' ! Run time for complete job (HH:MM:SS) [ Ignored by WFM ] - SRCDIR = '/lfs0/projects/rtfim/FIMZ/FIMsrc_mvapich' ! FIM source location * MUST BE SET * [ WFM: use absolute pathname! ] - PREPDIR = 'nodir' ! If exists, use for prep otherwise calculate prep - FIMDIR = 'nodir' ! If exists, use for FIM otherwise calculate FIM - DATADIR = '/whome/rtfim/fimdata' ! Location of gfsltln and global_mtnvar files - DATADR2 = '/public/data/grids/gfs/spectral' ! Location of the sanl file and the sfcanl file - chem_datadir = '/lfs1/projects/fim/fimdata' ! Location of chemistry data files -/ - &TOPOnamelist - topodatfile = '/whome/rtfim/fimdata/wrf5mintopo.dat' -/ - &CNTLnamelist - glvl = 8 ! Grid level - SubdivNum = 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ! Subdivision numbers for each recursive refinement(2: bisection, 3: trisection, etc.) - nvl = 64 ! Number of atmospheric layers -/ - &PREPnamelist - curve = 2 ! 0: ij order; 1: Hilbert curve order (only for all-bisection refinement); 2:ij block order - NumCacheBlocksPerPE = 4 ! Number of cache blocks per processor. Only applies to ij block order - alt_topo = .true. ! if true, use alternate srf.height field - aerosol_file = 'climaeropac_global.txt' ! filename relative to DATADIR - co2_2008_file = 'co2historicaldata_2008.txt' ! filename relative to DATADIR - co2_glb_file = 'co2historicaldata_glob.txt' ! filename relative to DATADIR - gfsltln_file = 'no_such_file' ! Correct value will be set by run automation - mtnvar_file = 'no_such_file' ! Correct value will be set by run automation -/ - &DIAGnamelist - PrintIpnDiag = -1 ! ipn at which to print diagnostics (-1 means no print) - PrintDiagProgVars = 24 ! Hourly increment to print diagnostic prognosis variables (-1=>none, 0=>every step) - PrintDiagNoise = 1 ! Hourly increment to print diagnostic gravity wave noise (-1=>none, 0=>every step) - PrintDiags = .false. ! True means print diagnostic messages -/ - &MODELnamelist - nts = 0 ! number of time steps - rleigh_light = 0.0 ! rayleigh damping time scale (days^-1) if top-layer wind < 100 m/s - rleigh_heavy = 0.5 ! rayleigh damping time scale (days^-1) if top-layer wind > 100 m/s - veldff_bkgnd = 1. ! diffusion velocity (=diffusion/mesh size) - ptop = 50. ! pressure (Pa) at top of model domain - thktop = 50. ! min.thknss of uppermost model layer - intfc_smooth = 50. ! diffusivity (m/s) for intfc smoothing (0 = no smoothing) - slak = 0.5 ! intfc movement retardation coeff (1 = no retardation) - pure_sig = .false. ! if true, use pure sigma coord. -/ - &PHYSICSnamelist - PhysicsInterval = 180 ! Interval in seconds to call non-radiation physics (0=every step) - RadiationInterval = 3600 ! Interval in seconds to call radiation physics (0=every step) - GravityWaveDrag = .true. ! True means calculate gravity wave drag - ras = .false. ! false means call SAS - num_p3d = 4 ! 4 means call Zhao/Carr/Sundqvist Microphysics -/ - &TIMEnamelist - yyyymmddhhmm = "200707170000" ! date of the model run -/ - &OUTPUTnamelist - ArchvTimeUnit = "hr" ! ts:timestep; mi:minute; hr:hour; dy:day; mo:month - TotalTime = 240 ! Total integration time in ArchvTimeUnit - ArchvIntvl = 6 ! Archive interval in ArchvTimeUnit - readrestart = .false. ! True means start by reading restart file (rpointer) - restart_freq = 480 ! Restart interval in ArchvTimeUnit - PrintMAXMINtimes = .true. ! True means print MAX MIN routine times, false means print for each PE - TimingBarriers = .false. ! True means turn on timed barriers to measure task skew, set to .false. for production runs - FixedGridOrder = .false. ! True: always output in the same order(IJ), False: order determined by curve. Does not apply to IJorder -/ - &ISOBARICnamelist - isobaric_levels_file = "output_isobaric_levs.txt" ! file containing pressure levels, in FIMrun directory - / -! WRITETASKnamelist is used to optionally create a separate group of -! FIM-specific write tasks to speed up FIM model output by overlapping disk -! writes with computation. By default this feature is turned off. When enabled, -! write tasks intercept FIM output and write to disk while the main compute -! tasks continue with model computation. In NEMS lingo, write tasks are called -! "quilt" tasks. -! -! WRITETASKnamelist is ignored for a serial run. -! - &WRITETASKnamelist - abort_on_bad_task_distrib = .true. ! Abort FIM when node names are not as expected - cpn = 12 ! Number of cores per node - debugmsg_on = .false. ! Print verbose debug messages - max_write_tasks_per_node = 8 ! Maximum number of write tasks to place on a single node - num_write_tasks = 1 ! Use: 0 = no write tasks, 1 = one, 21 = one write task per output file - root_own_node = .true. ! whether root process has node to himself -/ -! -! Namelist file for post processing -! -! Ning Wang, June 2007 -! - &POSTnamelist -! -! input and output specifications: -! - datadir = "../fim" - outputdir = "." -! input = "/tg2/projects/fim/jlee/PREP/mdrag5h.dat" - input = "" -! if input has content, it overwrites the datadir -! output = "/p72/fim/wang/nc_files/mdrag5h.nc" - output = "" -! if output has content, it overwrites the outputdir - output_fmt = "grib" ! "nc" --netCDF file, "grib" --GRIB file - multiple_output_files = .true. ! -- multiple grib outputfiles (assumed true when post in fim) -! -! grid specifications: -! - gribtable = "fim_gribtable" ! only used by grib output file(s) - grid_id = 4 ! 228(144, 73), 45(288, 145), - ! 3(360, 181), 4(720, 361); only for grib output file. - mx = 720 ! only used by netcdf output file - my = 360 ! only used by netcdf output file - latlonfld = .true. ! true -- create lat lon field in grib output file -! -! post processing specifications: -! - is = 1 ! interpolation scheme: - ! 0 -- no interpolation: native grid; - ! 1 -- horizontal interpo. on native vertical coord.; - ! 2 -- horizontal interpo. + vertical interpo. on std. pressure levels; - ! 3 -- horizontal interpo. + vertical interpo. on 10mb inc. pressure levels; - vres = 111 ! only used in vertical interpolation - mode = "linear" ! step or linear interpolation for vertical column -! -! variable specifications: -! -! var_list = 'mp3d', 'th3d', 'us3d', 'vs3d', 'rn2d', 'rc2d', 'sw2d', 'lw2d', 'ts2d' - var_list = 'hgtP', 'tmpP', 'rp3P', 'up3P', 'vp3P', 'pr3D', 'ph3D', 'tk3D', 'td3D', 'ws3D', - 'rh3D', 'us3D', 'vs3D', 'rn2D', 'rc2D', 'r12D', 'r22D', 'rg2D', 'pw2D', 'ts2D', - 'us2D', 'hf2D', 'qf2D', 'sw2D', 'lw2D', 'ms2D', 'sn2D', 'cb2D', 'ct2D' - nsmooth_var = 4, 1, 1, 1, 1, 0, 4, 1, 1, 1, - 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, - 1, 0, 0, 0, 0, 4, 0, 0, 0 - fimout = .true. ! whether to write FIM binary output files - gribout = .true. ! whether to write GRIB output files from FIM - t1 = 0 - t2 = 168 - delta_t = 6 - -/ - -&chemwrf - chem_opt = 0 ! chem option, 0=off, 300=on - chemdt = 30. - kemit = 1 - DUST_OPT = 1, - DMSEMIS_OPT = 1, - SEAS_OPT = 0, - BIO_EMISS_OPT = 0, - BIOMASS_BURN_OPT = 1, - PLUMERISEFIRE_FRQ = 30, - EMISS_INPT_OPT = 1, - GAS_BC_OPT = 0, - GAS_IC_OPT = 0, - AER_BC_OPT = 0, - AER_IC_OPT = 0, -/ - -&wrfphysics - mp_physics = 0, ! 0=off, 2=on - cu_physics = 0, ! 0=off, 3=on -/ - -! gptlnl modifies the behavior of the GPTL timing library, if enabled - -&gptlnl - print_method = 'full_tree' ! print full call tree -! utr = 'nanotime' ! fastest available underlying timer (Intel processors only) -! eventlist = 'PAPI_FP_OPS','GPTL_CI' ! PAPI-based counters (only if PAPI is available) -/ - -! -! System specific parameters for MPI, task geometry, etc. -! - &SYSTEMnamelist - MPIRUNCMD='mpirun -np' ! MPIRUNCMD should be defined as follows: - ! SGE 'mpirun -np' || torque 'aprun -n' || intel 'mpiexec_mpt -n' - ! load-leveler 'poe' || NCAR 'mpirun.lsf /usr/local/bin/launch' -/ - -! Everything below this line is of interest only to Workflow Manager users - -&WFMnamelist - max_run_time_prep='00:05:00' - max_run_time_fim='08:00:00' - max_run_time_pop='00:30:00' - batch_size='3' - ac_model_name='FIMZDC' - anx_model_names='GFS' - stats_model_name='FIMZ' - sounding_model_name='FIMZ' - ncl_model_name='EXPER FIMZ' - ncl_diff_model_name='FIM-FIMZ' - realtime='T' - rtfim_home='/whome/rtfim' - fim_home_no_x='/lfs0/projects/rtfim/FIM' - pe='thfip' - serialpe='thfip' - service='service' - mss='mss' - pes_no_x=240 - cycle='*' - GFSSANLDIR = '/public/data/grids/gfs/spectral' ! Location of the sanl file and the sfcanl file - ENKFSFCANLDIR = '/lfs1/projects/fim/whitaker/gfsenkf_t254' ! Location of the sanl file and the sfcanl file - init_file='gfs' - create_diff_plots='true' - ! Post processing: run the following tasks? (set to F to disable) - run_pop='T' ! Other post processing relies on pop to run - run_interp='T' - run_grib12='T' - run_tracker='T' - run_ncl='T' - -/ diff --git a/src/fim/FIMrun/FIMnamelist.bluefire b/src/fim/FIMrun/FIMnamelist.bluefire deleted file mode 100644 index 22ba82f..0000000 --- a/src/fim/FIMrun/FIMnamelist.bluefire +++ /dev/null @@ -1,205 +0,0 @@ - &QUEUEnamelist - ComputeTasks = '64' ! Number of compute tasks for FIM (S for Serial) - MaxQueueTime = '00:30:00' ! Run time for complete job (HH:MM:SS) [ Ignored by WFM ] - SRCDIR = '../FIMsrc_bluefire' ! FIM source location * MUST BE SET * [ WFM: use absolute pathname! ] - PREPDIR = 'nodir' ! If exists, use for prep otherwise calculate prep - FIMDIR = 'nodir' ! If exists, use for FIM otherwise calculate FIM - DATADIR = '/ptmp/rosinski/fimdata' ! Location of gfsltln and global_mtnvar files - DATADR2 = '/ptmp/rosinski/fimdata' ! Location of the sanl file and the sfcanl file - chem_datadir = '/lfs1/projects/fim/fimdata' ! Location of chemistry data files -/ - &TOPOnamelist - topodatfile = '/ptmp/rosinski/fimdata/wrf5mintopo.dat' -/ - &CNTLnamelist - glvl = 5 ! Grid level - SubdivNum = 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ! Subdivision numbers for each recursive refinement(2: bisection, 3: trisection, etc.) - nvl = 64 ! Number of atmospheric layers -/ - &PREPnamelist - curve = 2 ! 0: ij order, 1: Hilbert curve order (only for all-bisection refinement), 2:ij block order, 3: Square Layout - NumCacheBlocksPerPE = 1 ! Number of cache blocks per processor. Only applies to ij block order - alt_topo = .true. ! if true, use alternate srf.height field - aerosol_file = 'climaeropac_global.txt' ! filename relative to DATADIR - co2_2008_file = 'co2historicaldata_2008.txt' ! filename relative to DATADIR - co2_glb_file = 'co2historicaldata_glob.txt' ! filename relative to DATADIR - gfsltln_file = 'no_such_file' ! Correct value will be set by run automation - mtnvar_file = 'no_such_file' ! Correct value will be set by run automation -/ - &DIAGnamelist - PrintIpnDiag = -1 ! ipn at which to print diagnostics (-1 means no print) - PrintDiagProgVars = 12 ! Hourly increment to print diagnostic prognosis variables (-1=>none, 0=>every step) - PrintDiagNoise = 1 ! Hourly increment to print diagnostic gravity wave noise (-1=>none, 0=>every step) - PrintDiags = .false. ! True means print diagnostic messages -/ - &MODELnamelist - nts = 0 ! number of time steps - rleigh_light = 0.0 ! rayleigh damping time scale (days^-1) if top-layer wind < 100 m/s - rleigh_heavy = 0.5 ! rayleigh damping time scale (days^-1) if top-layer wind > 100 m/s - veldff_bkgnd = 1. ! diffusion velocity (=diffusion/mesh size) - ptop = 50. ! pressure (Pa) at top of model domain - thktop = 50. ! min.thknss (Pa) of uppermost model layer - intfc_smooth = 50. ! diffusivity (m/s) for intfc smoothing (0 = no smoothing) - slak = 0.5 ! intfc movement retardation coeff (1 = no retardation) - pure_sig = .false. ! if true, use pure sigma coord. -/ - &PHYSICSnamelist - PhysicsInterval = 180 ! Interval in seconds to call non-radiation physics (0=every step) - RadiationInterval = 3600 ! Interval in seconds to call radiation physics (0=every step) - GravityWaveDrag = .true. ! True means calculate gravity wave drag - ras = .false. ! false means call SAS - num_p3d = 4 ! 4 means call Zhao/Carr/Sundqvist Microphysics -/ - &TIMEnamelist - yyyymmddhhmm = "200707170000" ! date of the model run -/ - &OUTPUTnamelist - ArchvTimeUnit = 'hr' ! ts:timestep; mi:minute; hr:hour; dy:day; mo:month - TotalTime = 24 ! Total integration time in ArchvTimeUnit - ArchvIntvl = 6 ! Archive interval in ArchvTimeUnit - readrestart = .false. ! True means start by reading restart file (rpointer) - restart_freq = 240 ! Restart interval in ArchvTimeUnit - PrintMAXMINtimes = .true. ! True means print MAX MIN routine times, false means print for each PE - TimingBarriers = .false. ! True means turn on timed barriers to measure task skew, set to .false. for production runs - FixedGridOrder = .false. ! True: always output in the same order(IJ), False: order determined by curve. Does not apply to IJorder -/ - &ISOBARICnamelist - isobaric_levels_file = "output_isobaric_levs.txt" ! file containing pressure levels, in FIMrun directory - / -! -! WRITETASKnamelist is used to optionally create a separate group of -! FIM-specific write tasks to speed up FIM model output by overlapping disk -! writes with computation. By default this feature is turned off. When enabled, -! write tasks intercept FIM output and write to disk while the main compute -! tasks continue with model computation. In NEMS lingo, write tasks are called -! "quilt" tasks. -! -! WRITETASKnamelist is ignored for a serial run. -! - &WRITETASKnamelist - abort_on_bad_task_distrib = .true. ! Abort FIM when node names are not as expected - cpn = 64 ! Number of cores per node - debugmsg_on = .false. ! Print verbose debug messages - max_write_tasks_per_node = 21 ! Maximum number of write tasks to place on a single node - num_write_tasks = 0 ! Use: 0 = no write tasks, 1 = one, 21 = one write task per output file - root_own_node = .false. ! whether root process has node to himself -/ -! -! Namelist file for post processing -! -! Ning Wang, June 2007 -! - &POSTnamelist -! -! input and output specifications: -! - datadir = "../fim" - outputdir = "." -! input = "/tg2/projects/fim/jlee/PREP/mdrag5h.dat" - input = "" -! if input has content, it overwrites the datadir -! output = "/p72/fim/wang/nc_files/mdrag5h.nc" - output = "" -! if output has content, it overwrites the outputdir - output_fmt = "grib" ! "nc" --netCDF file, "grib" --GRIB file - multiple_output_files = .true. ! -- multiple grib outputfiles (assumed true when post in fim) -! -! grid specifications: -! - gribtable = "fim_gribtable" ! only used by grib output file(s) - grid_id = 228 ! 228(144, 73), 45(288, 145), - ! 3(360, 181), 4(720, 361); only for grib output file. - mx = 720 ! only used by netcdf output file - my = 360 ! only used by netcdf output file - latlonfld = .true. ! true -- create lat lon field in grib output file -! -! post processing specifications: -! - is = 1 ! interpolation scheme: - ! 0 -- no interpolation: native grid; - ! 1 -- horizontal interpo. on native vertical coord.; - ! 2 -- horizontal interpo. + vertical interpo. on std. pressure levels; - ! 3 -- horizontal interpo. + vertical interpo. on 10mb inc. pressure levels; - vres = 111 ! only used in vertical interpolation - mode = "linear" ! step or linear interpolation for vertical column -! -! variable specifications: -! -! var_list = 'mp3d', 'th3d', 'us3d', 'vs3d', 'rn2d', 'rc2d', 'sw2d', 'lw2d', 'ts2d' - var_list = 'td3D', 'us3D', 'vs3D', 'ph3D', 'pr3D', 'sw2D', 'lw2D', 'ms2D', 'sn2D' - nsmooth_var = 1, 1, 1, 2, 2, 0, 0, 1, 0 - fimout = .true. ! whether to write FIM binary output files - gribout = .false. ! whether to write GRIB output files from FIM -! These settings are *required* for real-time fim runs. -! However, they break the test suite. -! We will update the test suite shortly and restore these settings. -! Until then please use FIMnamelist.realtime for real-time runs. -! t1 = 0 -! t2 = 24 -! delta_t = 6 -/ - -&chemwrf - chem_opt = 0 ! chem option, 0=off, 300=on - chemdt = 30. - kemit = 1 - DUST_OPT = 1, - DMSEMIS_OPT = 1, - SEAS_OPT = 0, - BIO_EMISS_OPT = 0, - BIOMASS_BURN_OPT = 1, - PLUMERISEFIRE_FRQ = 30, - EMISS_INPT_OPT = 1, - GAS_BC_OPT = 0, - GAS_IC_OPT = 0, - AER_BC_OPT = 0, - AER_IC_OPT = 0, -/ - -&wrfphysics - mp_physics = 0, ! 0=off, 2=on - cu_physics = 0, ! 0=off, 3=on -/ - -! gptlnl modifies the behavior of the GPTL timing library, if enabled - -&gptlnl - print_method = 'full_tree' ! print full call tree -! utr = 'nanotime' ! fastest available underlying timer (Intel processors only) -! eventlist = 'PAPI_FP_OPS','GPTL_CI' ! PAPI-based counters (only if PAPI is available) -/ - -! -! System specific parameters for MPI, task geometry, etc. -! - &SYSTEMnamelist -! TARGET_CPU_LIST from http://www.cisl.ucar.edu/docs/bluefire/be_quickstart.html#binding - TARGET_CPU_LIST="-1" -! WFM currently has no way of setting up task geometry. If this feature is added -! the variable LSB_PJL_TASK_GEOMETRY will need to be defined here - MPIRUNCMD='mpirun.lsf /usr/local/bin/launch' ! MPIRUNCMD should be defined as follows: - ! SGE 'mpirun -np' || torque 'aprun -n' || intel 'mpiexec_mpt -n' - ! load-leveler 'poe' || NCAR 'mpirun.lsf /usr/local/bin/launch' -/ - -! Everything below this line is of interest only to Workflow Manager users - -&WFMnamelist - max_run_time_prep='00:05:00' - max_run_time_fim='00:30:00' - max_run_time_pop='00:30:00' - batch_size='3' - ac_model_name='FIMXDC' - stats_model_name='FIMX' - sounding_model_name='FIMX' - ncl_model_name='FIMX' - ncl_diff_model_name='FIM-FIMX' - realtime='F' - ! Post processing: run the following tasks? (set to F to disable) - run_pop='T' ! Other post processing relies on pop to run - run_interp='T' - run_grib12='T' - run_tracker='T' - run_ncl='T' - -/ diff --git a/src/fim/FIMrun/FIMnamelist.default b/src/fim/FIMrun/FIMnamelist.default deleted file mode 100644 index 6e41499..0000000 --- a/src/fim/FIMrun/FIMnamelist.default +++ /dev/null @@ -1,207 +0,0 @@ - &QUEUEnamelist - ComputeTasks = '10' ! Number of compute tasks for FIM (S for Serial) - MaxQueueTime = '00:10:00' ! Run time for complete job (HH:MM:SS) [ Ignored by WFM ] - SRCDIR = '../FIMsrc_openmpi' ! FIM source location * MUST BE SET * [ WFM: use absolute pathname! ] - PREPDIR = 'nodir' ! If exists, use for prep otherwise calculate prep - FIMDIR = 'nodir' ! If exists, use for FIM otherwise calculate FIM - DATADIR = '/lfs1/projects/fim/fimdata' ! Location of gfsltln and global_mtnvar files - DATADR2 = '/lfs1/projects/fim/fimdata' ! Location of the sanl file and the sfcanl file - chem_datadir = '/lfs1/projects/fim/fimdata' ! Location of chemistry data files -/ - &TOPOnamelist - topodatfile = '/whome/rtfim/fimdata/wrf5mintopo.dat' -/ - &CNTLnamelist - glvl = 5 ! Grid level - SubdivNum = 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ! Subdivision numbers for each recursive refinement(2: bisection, 3: trisection, etc.) - nvl = 64 ! Number of atmospheric layers -/ - &PREPnamelist - curve = 0 ! 0: ij order, 1: Hilbert curve order (only for all-bisection refinement), 2:ij block order, 3: Square Layout - NumCacheBlocksPerPE = 1 ! Number of cache blocks per processor. Only applies to ij block order - alt_topo = .true. ! if true, use alternate srf.height field - aerosol_file = 'climaeropac_global.txt' ! filename relative to DATADIR - co2_2008_file = 'co2historicaldata_2008.txt' ! filename relative to DATADIR - co2_glb_file = 'co2historicaldata_glob.txt' ! filename relative to DATADIR - gfsltln_file = 'no_such_file' ! Correct value will be set by run automation - mtnvar_file = 'no_such_file' ! Correct value will be set by run automation -/ - &DIAGnamelist - PrintIpnDiag = -1 ! ipn at which to print diagnostics (-1 means no print) - PrintDiagProgVars = 12 ! Hourly increment to print diagnostic prognosis variables (-1=>none, 0=>every step) - PrintDiagNoise = 1 ! Hourly increment to print diagnostic gravity wave noise (-1=>none, 0=>every step) - PrintDiags = .false. ! True means print diagnostic messages -/ - &MODELnamelist - nts = 0 ! number of time steps - UpdateSST = .false. ! True means update sst and sea ice by reading in a file during integration - rleigh_light = 0.0 ! rayleigh damping time scale (days^-1) if top-layer wind < 100 m/s - rleigh_heavy = 0.5 ! rayleigh damping time scale (days^-1) if top-layer wind > 100 m/s - veldff_bkgnd = 1. ! diffusion velocity (=diffusion/mesh size) - ptop = 50. ! pressure (Pa) at top of model domain - thktop = 50. ! min.thknss (Pa) of uppermost model layer - intfc_smooth = 50. ! [diffusivity/mesh size] (m/s) for intfc smoothing (0 = no smoothing) - slak = 0.5 ! intfc movement retardation coeff (1 = no retardation) - pure_sig = .false. ! if true, use GFS sigma-p coordinate - digifilt = .false. ! DFI - digital filter initalization - tfiltwin = 5400 ! 1/2 length duration of DFI (s) - wts_type = 3 ! type of digital filter (1=Lanczos,2=Hamming,3=Dolph) - -/ - &PHYSICSnamelist - PhysicsInterval = 180 ! Interval in seconds to call non-radiation physics (0=every step) - RadiationInterval = 3600 ! Interval in seconds to call radiation physics (0=every step) - SSTInterval = 86400 ! Interval in seconds to call update_sst (0=every step) - GravityWaveDrag = .true. ! True means calculate gravity wave drag - ras = .false. ! false means call SAS - num_p3d = 4 ! 4 means call Zhao/Carr/Sundqvist Microphysics -/ - &TIMEnamelist - yyyymmddhhmm = "200707170000" ! date of the model run -/ - &OUTPUTnamelist - ArchvTimeUnit = 'hr' ! ts:timestep; mi:minute; hr:hour; dy:day; mo:month - TotalTime = 24 ! Total integration time in ArchvTimeUnit - ArchvIntvl = 6 ! Archive interval in ArchvTimeUnit - readrestart = .false. ! True means start by reading restart file (rpointer) - restart_freq = 24 ! Restart interval in ArchvTimeUnit - PrintMAXMINtimes = .true. ! True means print MAX MIN routine times, false means print for each PE - TimingBarriers = .false. ! True means turn on timed barriers to measure task skew, set to .false. for production runs - FixedGridOrder = .false. ! True: always output in the same order(IJ), False: order determined by curve. Does not apply to IJorder -/ - &ISOBARICnamelist - isobaric_levels_file = "output_isobaric_levs.txt" ! file containing pressure levels, in FIMrun directory - / - -! -! WRITETASKnamelist is used to optionally create a separate group of -! FIM-specific write tasks to speed up FIM model output by overlapping disk -! writes with computation. By default this feature is turned off. When enabled, -! write tasks intercept FIM output and write to disk while the main compute -! tasks continue with model computation. In NEMS lingo, write tasks are called -! "quilt" tasks. -! -! WRITETASKnamelist is ignored for a serial run. -! - &WRITETASKnamelist - abort_on_bad_task_distrib = .true. ! Abort FIM when node names are not as expected - cpn = 8 ! Number of cores per node - debugmsg_on = .false. ! Print verbose debug messages - max_write_tasks_per_node = 4 ! Maximum number of write tasks to place on a single node - num_write_tasks = 0 ! Use: 0 = no write tasks, 1 = one, 21 = one write task per output file - root_own_node = .true. ! whether root process has node to himself -/ -! -! Namelist file for post processing -! -! Ning Wang, June 2007 -! - &POSTnamelist -! -! input and output specifications: -! - datadir = "../fim" - outputdir = "." -! input = "/tg2/projects/fim/jlee/PREP/mdrag5h.dat" - input = "" -! if input has content, it overwrites the datadir -! output = "/p72/fim/wang/nc_files/mdrag5h.nc" - output = "" -! if output has content, it overwrites the outputdir - output_fmt = "grib" ! "nc" --netCDF file, "grib" --GRIB file - multiple_output_files = .true. ! -- multiple grib outputfiles (assumed true when post in fim) -! -! grid specifications: -! - gribtable = "fim_gribtable" ! only used by grib output file(s) - grid_id = 228 ! 228(144, 73), 45(288, 145), - ! 3(360, 181), 4(720, 361); only for grib output file. - mx = 720 ! only used by netcdf output file - my = 360 ! only used by netcdf output file - latlonfld = .true. ! true -- create lat lon field in grib output file -! -! post processing specifications: -! - is = 1 ! interpolation scheme: - ! 0 -- no interpolation: native grid; - ! 1 -- horizontal interpo. on native vertical coord.; - ! 2 -- horizontal interpo. + vertical interpo. on std. pressure levels; - ! 3 -- horizontal interpo. + vertical interpo. on 10mb inc. pressure levels; - vres = 111 ! only used in vertical interpolation - mode = "linear" ! step or linear interpolation for vertical column -! -! variable specifications: -! -! var_list = 'mp3d', 'th3d', 'us3d', 'vs3d', 'rn2d', 'rc2d', 'sw2d', 'lw2d', 'ts2d' - var_list = 'td3D', 'us3D', 'vs3D', 'ph3D', 'pr3D', 'sw2D', 'lw2D', 'ms2D', 'sn2D' - nsmooth_var = 1, 1, 1, 2, 2, 0, 0, 1, 0 - fimout = .true. ! whether to write FIM binary output files - gribout = .false. ! whether to write GRIB output files from FIM -! These settings are *required* for real-time fim runs. -! However, they break the test suite. -! We will update the test suite shortly and restore these settings. -! Until then please use FIMnamelist.realtime for real-time runs. -! t1 = 0 -! t2 = 24 -! delta_t = 6 -/ - -&chemwrf - chem_opt = 0 ! chem option, 0=off, 300=on - chemdt = 30. - kemit = 1 - DUST_OPT = 1, - DMSEMIS_OPT = 1, - SEAS_OPT = 0, - BIO_EMISS_OPT = 0, - BIOMASS_BURN_OPT = 1, - PLUMERISEFIRE_FRQ = 30, - EMISS_INPT_OPT = 1, - GAS_BC_OPT = 0, - GAS_IC_OPT = 0, - AER_BC_OPT = 0, - AER_IC_OPT = 0, -/ - -&wrfphysics - mp_physics = 0, ! 0=off, 2=on - cu_physics = 0, ! 0=off, 3=on -/ - -! gptlnl modifies the behavior of the GPTL timing library, if enabled - -&gptlnl - print_method = 'full_tree' ! print full call tree -! utr = 'nanotime' ! fastest available underlying timer (Intel processors only) -! eventlist = 'PAPI_FP_OPS','GPTL_CI' ! PAPI-based counters (only if PAPI is available) -/ - -! -! System specific parameters for MPI, task geometry, etc. -! - &SYSTEMnamelist - MPIRUNCMD='mpirun -np' ! MPIRUNCMD should be defined as follows: - ! SGE 'mpirun -np' || torque 'aprun -n' || intel 'mpiexec_mpt -n' - ! load-leveler 'poe' || NCAR 'mpirun.lsf /usr/local/bin/launch' -/ - -! Everything below this line is of interest only to Workflow Manager users - -&WFMnamelist - max_run_time_prep='00:05:00' - max_run_time_fim='00:30:00' - max_run_time_pop='00:30:00' - batch_size='3' - ac_model_name='FIMXDC' - stats_model_name='FIMX' - sounding_model_name='FIMX' - ncl_model_name='FIMX' - ncl_diff_model_name='FIM-FIMX' - realtime='F' - ! Post processing: run the following tasks? (set to F to disable) - run_pop='T' ! Other post processing relies on pop to run - run_interp='T' - run_grib12='T' - run_tracker='T' - run_ncl='T' -/ diff --git a/src/fim/FIMrun/FIMnamelist.devccs b/src/fim/FIMrun/FIMnamelist.devccs deleted file mode 100644 index 7fdf4dd..0000000 --- a/src/fim/FIMrun/FIMnamelist.devccs +++ /dev/null @@ -1,209 +0,0 @@ - &QUEUEnamelist - ComputeTasks = '64' ! Number of compute tasks for FIM (S for Serial) - MaxQueueTime = '00:15:00' ! Run time for complete job (HH:MM:SS) [ Ignored by WFM ] - SRCDIR = '/gpfs/t3/global/save/wx20tbh/FIM/FIM_r1910/FIMsrc_devccs/' ! FIM source location * MUST BE SET * [ WFM: use absolute pathname! ] - PREPDIR = 'nodir' ! If exists, use for prep otherwise calculate prep - FIMDIR = 'nodir' ! If exists, use for FIM otherwise calculate FIM - DATADIR = '/gpfs/t2c/global/noscrub/wx20tbh/fimdata/' ! Location of gfsltln and global_mtnvar files - DATADR2 = '/gpfs/t2c/global/noscrub/wx20tbh/fimdata/' ! Location of the sanl file and the sfcanl file - chem_datadir = '/gpfs/t2c/global/noscrub/wx20tbh/fimdata/' ! Location of chemistry data files -/ - &TOPOnamelist - topodatfile = '/gpfs/t2c/global/noscrub/wx20tbh/fimdata/wrf5mintopo.dat' -/ - &CNTLnamelist - glvl = 5 ! Grid level - SubdivNum = 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ! Subdivision numbers for each recursive refinement(2: bisection, 3: trisection, etc.) - nvl = 38 ! Number of atmospheric layers -/ - &PREPnamelist - curve = 2 ! 0: ij order, 1: Hilbert curve order (only for all-bisection refinement), 2:ij block order, 3: Square Layout - NumCacheBlocksPerPE = 1 ! Number of cache blocks per processor. Only applies to ij block order - alt_topo = .true. ! if true, use alternate srf.height field - aerosol_file = 'climaeropac_global.txt' ! filename relative to DATADIR - co2_2008_file = 'co2historicaldata_2008.txt' ! filename relative to DATADIR - co2_glb_file = 'co2historicaldata_glob.txt' ! filename relative to DATADIR -!JR Currently MUST set these 2 on vapor or FIM will not run - gfsltln_file = 'gfsltln_t382.dat' ! filename relative to DATADIR; date < 201007281200 - mtnvar_file = 'global_mtnvar.t382' ! filename relative to DATADIR; date < 201007281200 -/ - &DIAGnamelist - PrintIpnDiag = -1 ! ipn at which to print diagnostics (-1 means no print) - PrintDiagProgVars = 12 ! Hourly increment to print diagnostic prognosis variables (-1=>none, 0=>every step) - PrintDiagNoise = 1 ! Hourly increment to print diagnostic gravity wave noise (-1=>none, 0=>every step) - PrintDiags = .false. ! True means print diagnostic messages -/ - &MODELnamelist - nts = 0 ! number of time steps - UpdateSST = .false. ! True means update sst and sea ice by reading in a file during integration - rleigh_light = 0.0 ! rayleigh damping time scale (days^-1) if top-layer wind < 100 m/s - rleigh_heavy = 0.5 ! rayleigh damping time scale (days^-1) if top-layer wind > 100 m/s - veldff_bkgnd = 1. ! diffusion velocity (=diffusion/mesh size) - ptop = 50. ! pressure (Pa) at top of model domain - thktop = 50. ! min.thknss (Pa) of uppermost model layer - intfc_smooth = 50. ! [diffusivity/mesh size] (m/s) for intfc smoothing (0 = no smoothing) - slak = 0.5 ! intfc movement retardation coeff (1 = no retardation) - pure_sig = .false. ! if true, use GFS sigma-p coordinate - digifilt = .false. ! DFI - digital filter initalization - tfiltwin = 5400 ! 1/2 length duration of DFI (s) - wts_type = 3 ! type of digital filter (1=Lanczos,2=Hamming,3=Dolph) -/ - &PHYSICSnamelist - PhysicsInterval = 180 ! Interval in seconds to call non-radiation physics (0=every step) - RadiationInterval = 3600 ! Interval in seconds to call radiation physics (0=every step) - SSTInterval = 86400 ! Interval in seconds to call update_sst (0=every step) - GravityWaveDrag = .true. ! True means calculate gravity wave drag - ras = .false. ! false means call SAS - num_p3d = 4 ! 4 means call Zhao/Carr/Sundqvist Microphysics -/ - &TIMEnamelist - yyyymmddhhmm = "200707170000" ! date of the model run -/ - &OUTPUTnamelist - ArchvTimeUnit = 'hr' ! ts:timestep; mi:minute; hr:hour; dy:day; mo:month - TotalTime = 24 ! Total integration time in ArchvTimeUnit - ArchvIntvl = 3 ! Archive interval in ArchvTimeUnit - readrestart = .false. ! True means start by reading restart file (rpointer) - restart_freq = 240 ! Restart interval in ArchvTimeUnit - PrintMAXMINtimes = .true. ! True means print MAX MIN routine times, false means print for each PE - TimingBarriers = .false. ! True means turn on timed barriers to measure task skew, set to .false. for production runs - FixedGridOrder = .false. ! True: always output in the same order(IJ), False: order determined by curve. Does not apply to IJorder -/ - &ISOBARICnamelist - isobaric_levels_file = "output_isobaric_levs.txt" ! file containing pressure levels, in FIMrun directory - / - -! -! WRITETASKnamelist is used to optionally create a separate group of -! FIM-specific write tasks to speed up FIM model output by overlapping disk -! writes with computation. By default this feature is turned off. When enabled, -! write tasks intercept FIM output and write to disk while the main compute -! tasks continue with model computation. In NEMS lingo, write tasks are called -! "quilt" tasks. -! -! WRITETASKnamelist is ignored for a serial run. -! - &WRITETASKnamelist - abort_on_bad_task_distrib = .true. ! Abort FIM when node names are not as expected - cpn = 64 ! Number of cores per node - debugmsg_on = .false. ! Print verbose debug messages - max_write_tasks_per_node = 7 ! Maximum number of write tasks to place on a single node - num_write_tasks = 0 ! Use: 0 = no write tasks, 1 = one, 21 = one write task per output file - root_own_node = .false. ! whether root process has node to himself -/ -! -! Namelist file for post processing -! -! Ning Wang, June 2007 -! - &POSTnamelist -! -! input and output specifications: -! - datadir = "../fim" - outputdir = "." -! input = "/tg2/projects/fim/jlee/PREP/mdrag5h.dat" - input = "" -! if input has content, it overwrites the datadir -! output = "/p72/fim/wang/nc_files/mdrag5h.nc" - output = "" -! if output has content, it overwrites the outputdir - output_fmt = "grib" ! "nc" --netCDF file, "grib" --GRIB file - multiple_output_files = .true. ! -- multiple grib outputfiles (assumed true when post in fim) -! -! grid specifications: -! - gribtable = "fim_gribtable" ! only used by grib output file(s) - grid_id = 228 ! 228(144, 73), 45(288, 145), - ! 3(360, 181), 4(720, 361); only for grib output file. - mx = 720 ! only used by netcdf output file - my = 360 ! only used by netcdf output file - latlonfld = .true. ! true -- create lat lon field in grib output file -! -! post processing specifications: -! - is = 1 ! interpolation scheme: - ! 0 -- no interpolation: native grid; - ! 1 -- horizontal interpo. on native vertical coord.; - ! 2 -- horizontal interpo. + vertical interpo. on std. pressure levels; - ! 3 -- horizontal interpo. + vertical interpo. on 10mb inc. pressure levels; - vres = 111 ! only used in vertical interpolation - mode = "linear" ! step or linear interpolation for vertical column -! -! variable specifications: -! -! var_list = 'mp3d', 'th3d', 'us3d', 'vs3d', 'rn2d', 'rc2d', 'sw2d', 'lw2d', 'ts2d' - var_list = 'td3D', 'us3D', 'vs3D', 'ph3D', 'pr3D', 'sw2D', 'lw2D', 'ms2D', 'sn2D' - nsmooth_var = 1, 1, 1, 2, 2, 0, 0, 1, 0 - fimout = .true. ! whether to write FIM binary output files - gribout = .false. ! whether to write GRIB output files from FIM -! These settings are *required* for real-time fim runs. -! However, they break the test suite. -! We will update the test suite shortly and restore these settings. -! Until then please use FIMnamelist.realtime for real-time runs. -! t1 = 0 -! t2 = 24 -! delta_t = 6 -/ - -&chemwrf - chem_opt = 0 ! chem option, 0=off, 300=on - chemdt = 30. - kemit = 1 - DUST_OPT = 1, - DMSEMIS_OPT = 1, - SEAS_OPT = 0, - BIO_EMISS_OPT = 0, - BIOMASS_BURN_OPT = 1, - PLUMERISEFIRE_FRQ = 30, - EMISS_INPT_OPT = 1, - GAS_BC_OPT = 0, - GAS_IC_OPT = 0, - AER_BC_OPT = 0, - AER_IC_OPT = 0, -/ - -&wrfphysics - mp_physics = 0, ! 0=off, 2=on - cu_physics = 0, ! 0=off, 3=on -/ - -! gptlnl modifies the behavior of the GPTL timing library, if enabled - -&gptlnl - print_method = 'full_tree' ! print full call tree -! utr = 'nanotime' ! fastest available underlying timer (Intel processors only) -! eventlist = 'PAPI_FP_OPS','GPTL_CI' ! PAPI-based counters (only if PAPI is available) -/ - -! -! System specific parameters for MPI, task geometry, etc. -! - &SYSTEMnamelist - MPIRUNCMD='poe' ! MPIRUNCMD should be defined as follows: - ! SGE 'mpirun -np' || torque 'aprun -n' || intel 'mpiexec_mpt -n' - ! load-leveler 'poe' || NCAR 'mpirun.lsf /usr/local/bin/launch' -! Vapor-specific requirement - MP_LABELIO="yes" -/ - -! Everything below this line is of interest only to Workflow Manager users - -&WFMnamelist - max_run_time_prep='00:05:00' - max_run_time_fim='00:30:00' - max_run_time_pop='00:30:00' - batch_size='3' - ac_model_name='FIMXDC' - stats_model_name='FIMX' - sounding_model_name='FIMX' - ncl_model_name='FIMX' - ncl_diff_model_name='FIM-FIMX' - realtime='F' - ! Post processing: run the following tasks? (set to F to disable) - run_pop='T' ! Other post processing relies on pop to run - run_interp='T' - run_grib12='T' - run_tracker='T' - run_ncl='T' -/ diff --git a/src/fim/FIMrun/FIMnamelist.frostintel b/src/fim/FIMrun/FIMnamelist.frostintel deleted file mode 100644 index 25c3112..0000000 --- a/src/fim/FIMrun/FIMnamelist.frostintel +++ /dev/null @@ -1,202 +0,0 @@ - &QUEUEnamelist - ComputeTasks = '10' ! Number of compute tasks for FIM (S for Serial) - MaxQueueTime = '00:10:00' ! Run time for complete job (HH:MM:SS) [ Ignored by WFM ] - SRCDIR = '../FIMsrc_frostintel' ! FIM source location * MUST BE SET * [ WFM: use absolute pathname! ] - PREPDIR = 'nodir' ! If exists, use for prep otherwise calculate prep - FIMDIR = 'nodir' ! If exists, use for FIM otherwise calculate FIM - DATADIR = '/tmp/proj/atm001/rosinski/fimdata' ! Location of gfsltln and global_mtnvar files - DATADR2 = '/tmp/proj/atm001/rosinski/fimdata' ! Location of the sanl file and the sfcanl file - chem_datadir = '/lfs1/projects/fim/fimdata' ! Location of chemistry data files -/ - &TOPOnamelist - topodatfile = '/tmp/proj/atm001/rosinski/fimdata/wrf5mintopo.dat' -/ - &CNTLnamelist - glvl = 5 ! Grid level - SubdivNum = 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ! Subdivision numbers for each recursive refinement(2: bisection, 3: trisection, etc.) - nvl = 64 ! Number of atmospheric layers -/ - &PREPnamelist - curve = 2 ! 0: ij order, 1: Hilbert curve order (only for all-bisection refinement), 2:ij block order, 3: Square Layout - NumCacheBlocksPerPE = 1 ! Number of cache blocks per processor. Only applies to ij block order - alt_topo = .true. ! if true, use alternate srf.height field - aerosol_file = 'climaeropac_global.txt' ! filename relative to DATADIR - co2_2008_file = 'co2historicaldata_2008.txt' ! filename relative to DATADIR - co2_glb_file = 'co2historicaldata_glob.txt' ! filename relative to DATADIR - gfsltln_file = 'no_such_file' ! Correct value will be set by run automation - mtnvar_file = 'no_such_file' ! Correct value will be set by run automation -/ - &DIAGnamelist - PrintIpnDiag = -1 ! ipn at which to print diagnostics (-1 means no print) - PrintDiagProgVars = 12 ! Hourly increment to print diagnostic prognosis variables (-1=>none, 0=>every step) - PrintDiagNoise = 1 ! Hourly increment to print diagnostic gravity wave noise (-1=>none, 0=>every step) - PrintDiags = .false. ! True means print diagnostic messages -/ - &MODELnamelist - nts = 0 ! number of time steps - rleigh_light = 0.0 ! rayleigh damping time scale (days^-1) if top-layer wind < 100 m/s - rleigh_heavy = 0.5 ! rayleigh damping time scale (days^-1) if top-layer wind > 100 m/s - veldff_bkgnd = 1. ! diffusion velocity (=diffusion/mesh size) - ptop = 50. ! pressure (Pa) at top of model domain - thktop = 50. ! min.thknss (Pa) of uppermost model layer - intfc_smooth = 50. ! diffusivity (m/s) for intfc smoothing (0 = no smoothing) - slak = 0.5 ! intfc movement retardation coeff (1 = no retardation) - pure_sig = .false. ! if true, use pure sigma coord. -/ - &PHYSICSnamelist - PhysicsInterval = 180 ! Interval in seconds to call non-radiation physics (0=every step) - RadiationInterval = 3600 ! Interval in seconds to call radiation physics (0=every step) - GravityWaveDrag = .true. ! True means calculate gravity wave drag - ras = .false. ! false means call SAS - num_p3d = 4 ! 4 means call Zhao/Carr/Sundqvist Microphysics -/ - &TIMEnamelist - yyyymmddhhmm = "200707170000" ! date of the model run -/ - &OUTPUTnamelist - ArchvTimeUnit = 'hr' ! ts:timestep; mi:minute; hr:hour; dy:day; mo:month - TotalTime = 24 ! Total integration time in ArchvTimeUnit - ArchvIntvl = 6 ! Archive interval in ArchvTimeUnit - readrestart = .false. ! True means start by reading restart file (rpointer) - restart_freq = 240 ! Restart interval in ArchvTimeUnit - PrintMAXMINtimes = .true. ! True means print MAX MIN routine times, false means print for each PE - TimingBarriers = .false. ! True means turn on timed barriers to measure task skew, set to .false. for production runs - FixedGridOrder = .false. ! True: always output in the same order(IJ), False: order determined by curve. Does not apply to IJorder -/ - &ISOBARICnamelist - isobaric_levels_file = "output_isobaric_levs.txt" ! file containing pressure levels, in FIMrun directory - / - -! -! WRITETASKnamelist is used to optionally create a separate group of -! FIM-specific write tasks to speed up FIM model output by overlapping disk -! writes with computation. By default this feature is turned off. When enabled, -! write tasks intercept FIM output and write to disk while the main compute -! tasks continue with model computation. In NEMS lingo, write tasks are called -! "quilt" tasks. -! -! WRITETASKnamelist is ignored for a serial run. -! - &WRITETASKnamelist - abort_on_bad_task_distrib = .true. ! Abort FIM when node names are not as expected - cpn = 4 ! Number of cores per node - debugmsg_on = .false. ! Print verbose debug messages - max_write_tasks_per_node = 4 ! Maximum number of write tasks to place on a single node - num_write_tasks = 0 ! Use: 0 = no write tasks, 1 = one, 21 = one write task per output file - root_own_node = .true. ! whether root process has node to himself -/ -! -! Namelist file for post processing -! -! Ning Wang, June 2007 -! - &POSTnamelist -! -! input and output specifications: -! - datadir = "../fim" - outputdir = "." -! input = "/tg2/projects/fim/jlee/PREP/mdrag5h.dat" - input = "" -! if input has content, it overwrites the datadir -! output = "/p72/fim/wang/nc_files/mdrag5h.nc" - output = "" -! if output has content, it overwrites the outputdir - output_fmt = "grib" ! "nc" --netCDF file, "grib" --GRIB file - multiple_output_files = .true. ! -- multiple grib outputfiles (assumed true when post in fim) -! -! grid specifications: -! - gribtable = "fim_gribtable" ! only used by grib output file(s) - grid_id = 228 ! 228(144, 73), 45(288, 145), - ! 3(360, 181), 4(720, 361); only for grib output file. - mx = 720 ! only used by netcdf output file - my = 360 ! only used by netcdf output file - latlonfld = .true. ! true -- create lat lon field in grib output file -! -! post processing specifications: -! - is = 1 ! interpolation scheme: - ! 0 -- no interpolation: native grid; - ! 1 -- horizontal interpo. on native vertical coord.; - ! 2 -- horizontal interpo. + vertical interpo. on std. pressure levels; - ! 3 -- horizontal interpo. + vertical interpo. on 10mb inc. pressure levels; - vres = 111 ! only used in vertical interpolation - mode = "linear" ! step or linear interpolation for vertical column -! -! variable specifications: -! -! var_list = 'mp3d', 'th3d', 'us3d', 'vs3d', 'rn2d', 'rc2d', 'sw2d', 'lw2d', 'ts2d' - var_list = 'td3D', 'us3D', 'vs3D', 'ph3D', 'pr3D', 'sw2D', 'lw2D', 'ms2D', 'sn2D' - nsmooth_var = 1, 1, 1, 2, 2, 0, 0, 1, 0 - fimout = .true. ! whether to write FIM binary output files - gribout = .false. ! whether to write GRIB output files from FIM -! These settings are *required* for real-time fim runs. -! However, they break the test suite. -! We will update the test suite shortly and restore these settings. -! Until then please use FIMnamelist.realtime for real-time runs. -! t1 = 0 -! t2 = 24 -! delta_t = 6 -/ - -! gptlnl modifies the behavior of the GPTL timing library, if enabled - -&gptlnl - print_method = 'full_tree' ! print full call tree - utr = 'nanotime' ! fastest available underlying timer (Intel processors only) -! eventlist = 'PAPI_FP_OPS','GPTL_CI' ! PAPI-based counters (only if PAPI is available) -/ - -&chemwrf - chem_opt = 0 ! chem option, 0=off, 300=on - chemdt = 30. - kemit = 1 - DUST_OPT = 1, - DMSEMIS_OPT = 1, - SEAS_OPT = 0, - BIO_EMISS_OPT = 0, - BIOMASS_BURN_OPT = 1, - PLUMERISEFIRE_FRQ = 30, - EMISS_INPT_OPT = 1, - GAS_BC_OPT = 0, - GAS_IC_OPT = 0, - AER_BC_OPT = 0, - AER_IC_OPT = 0, -/ - -&wrfphysics - mp_physics = 0, ! 0=off, 2=on - cu_physics = 0, ! 0=off, 3=on -/ - -! -! System specific parameters for MPI, task geometry, etc. -! - &SYSTEMnamelist - MPIRUNCMD='mpiexec_mpt -n' ! MPIRUNCMD should be defined as follows: - ! SGE 'mpirun -np' || torque 'aprun -n' || intel 'mpiexec_mpt -n' - ! load-leveler 'poe' || NCAR 'mpirun.lsf /usr/local/bin/launch' -/ - -! Everything below this line is of interest only to Workflow Manager users - -&WFMnamelist - max_run_time_prep='00:05:00' - max_run_time_fim='00:30:00' - max_run_time_pop='00:30:00' - batch_size='3' - ac_model_name='FIMXDC' - stats_model_name='FIMX' - sounding_model_name='FIMX' - ncl_model_name='FIMX' - ncl_diff_model_name='FIM-FIMX' - realtime='F' - ! Post processing: run the following tasks? (set to F to disable) - run_pop='T' ! Other post processing relies on pop to run - run_interp='T' - run_grib12='T' - run_tracker='T' - run_ncl='T' - -/ diff --git a/src/fim/FIMrun/FIMnamelist.jaguargnu.xt5 b/src/fim/FIMrun/FIMnamelist.jaguargnu.xt5 deleted file mode 100644 index c93e219..0000000 --- a/src/fim/FIMrun/FIMnamelist.jaguargnu.xt5 +++ /dev/null @@ -1,204 +0,0 @@ - &QUEUEnamelist - ComputeTasks = '10' ! Number of compute tasks for FIM (S for Serial) - MaxQueueTime = '00:10:00' ! Run time for complete job (HH:MM:SS) [ Ignored by WFM ] - SRCDIR = '../FIMsrc_jaguargnu' ! FIM source location * MUST BE SET * [ WFM: use absolute pathname! ] - PREPDIR = 'nodir' ! If exists, use for prep otherwise calculate prep - FIMDIR = 'nodir' ! If exists, use for FIM otherwise calculate FIM - DATADIR = '/tmp/proj/atm001/rosinski/fimdata' ! Location of gfsltln and global_mtnvar files - DATADR2 = '/tmp/proj/atm001/rosinski/fimdata' ! Location of the sanl file and the sfcanl file - chem_datadir = '/lfs1/projects/fim/fimdata' ! Location of chemistry data files -/ - &TOPOnamelist - topodatfile = '/tmp/proj/atm001/rosinski/fimdata/wrf5mintopo.dat' -/ - &CNTLnamelist - glvl = 5 ! Grid level - SubdivNum = 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ! Subdivision numbers for each recursive refinement(2: bisection, 3: trisection, etc.) - nvl = 64 ! Number of atmospheric layers -/ - &PREPnamelist - curve = 2 ! 0: ij order, 1: Hilbert curve order (only for all-bisection refinement), 2:ij block order, 3: Square Layout - NumCacheBlocksPerPE = 1 ! Number of cache blocks per processor. Only applies to ij block order - alt_topo = .true. ! if true, use alternate srf.height field - aerosol_file = 'climaeropac_global.txt' ! filename relative to DATADIR - co2_2008_file = 'co2historicaldata_2008.txt' ! filename relative to DATADIR - co2_glb_file = 'co2historicaldata_glob.txt' ! filename relative to DATADIR - gfsltln_file = 'no_such_file' ! Correct value will be set by run automation - mtnvar_file = 'no_such_file' ! Correct value will be set by run automation -/ - &DIAGnamelist - PrintIpnDiag = -1 ! ipn at which to print diagnostics (-1 means no print) - PrintDiagProgVars = 12 ! Hourly increment to print diagnostic prognosis variables (-1=>none, 0=>every step) - PrintDiagNoise = 1 ! Hourly increment to print diagnostic gravity wave noise (-1=>none, 0=>every step) - PrintDiags = .false. ! True means print diagnostic messages -/ - &MODELnamelist - nts = 0 ! number of time steps - rleigh_light = 0.0 ! rayleigh damping time scale (days^-1) if top-layer wind < 100 m/s - rleigh_heavy = 0.5 ! rayleigh damping time scale (days^-1) if top-layer wind > 100 m/s - veldff_bkgnd = 1. ! diffusion velocity (=diffusion/mesh size) - ptop = 50. ! pressure (Pa) at top of model domain - thktop = 50. ! min.thknss (Pa) of uppermost model layer - intfc_smooth = 50. ! diffusivity (m/s) for intfc smoothing (0 = no smoothing) - slak = 0.5 ! intfc movement retardation coeff (1 = no retardation) - pure_sig = .false. ! if true, use pure sigma coord. -/ - &PHYSICSnamelist - PhysicsInterval = 180 ! Interval in seconds to call non-radiation physics (0=every step) - RadiationInterval = 3600 ! Interval in seconds to call radiation physics (0=every step) - GravityWaveDrag = .true. ! True means calculate gravity wave drag - ras = .false. ! false means call SAS - num_p3d = 4 ! 4 means call Zhao/Carr/Sundqvist Microphysics -/ - &TIMEnamelist - yyyymmddhhmm = "200707170000" ! date of the model run -/ - &OUTPUTnamelist - ArchvTimeUnit = 'hr' ! ts:timestep; mi:minute; hr:hour; dy:day; mo:month - TotalTime = 24 ! Total integration time in ArchvTimeUnit - ArchvIntvl = 6 ! Archive interval in ArchvTimeUnit - readrestart = .false. ! True means start by reading restart file (rpointer) - restart_freq = 24 ! Restart interval in ArchvTimeUnit - PrintMAXMINtimes = .true. ! True means print MAX MIN routine times, false means print for each PE - TimingBarriers = .false. ! True means turn on timed barriers to measure task skew, set to .false. for production runs - FixedGridOrder = .false. ! True: always output in the same order(IJ), False: order determined by curve. Does not apply to IJorder -/ - &ISOBARICnamelist - isobaric_levels_file = "output_isobaric_levs.txt" ! file containing pressure levels, in FIMrun directory - / -! -! WRITETASKnamelist is used to optionally create a separate group of -! FIM-specific write tasks to speed up FIM model output by overlapping disk -! writes with computation. By default this feature is turned off. When enabled, -! write tasks intercept FIM output and write to disk while the main compute -! tasks continue with model computation. In NEMS lingo, write tasks are called -! "quilt" tasks. -! -! WRITETASKnamelist is ignored for a serial run. -! - &WRITETASKnamelist - abort_on_bad_task_distrib = .true. ! Abort FIM when node names are not as expected - cpn = 12 ! Number of cores per node - debugmsg_on = .false. ! Print verbose debug messages - max_write_tasks_per_node = 7 ! Maximum number of write tasks to place on a single node - num_write_tasks = 0 ! Use: 0 = no write tasks, 1 = one, 21 = one write task per output file - root_own_node = .true. ! whether root process has node to himself -/ -! -! Namelist file for post processing -! -! Ning Wang, June 2007 -! - &POSTnamelist -! -! input and output specifications: -! - datadir = "../fim" - outputdir = "." -! input = "/tg2/projects/fim/jlee/PREP/mdrag5h.dat" - input = "" -! if input has content, it overwrites the datadir -! output = "/p72/fim/wang/nc_files/mdrag5h.nc" - output = "" -! if output has content, it overwrites the outputdir - output_fmt = "grib" ! "nc" --netCDF file, "grib" --GRIB file - multiple_output_files = .true. ! -- multiple grib outputfiles (assumed true when post in fim) -! -! grid specifications: -! - gribtable = "fim_gribtable" ! only used by grib output file(s) - grid_id = 228 ! 228(144, 73), 45(288, 145), - ! 3(360, 181), 4(720, 361); only for grib output file. - mx = 720 ! only used by netcdf output file - my = 360 ! only used by netcdf output file - latlonfld = .true. ! true -- create lat lon field in grib output file -! -! post processing specifications: -! - is = 1 ! interpolation scheme: - ! 0 -- no interpolation: native grid; - ! 1 -- horizontal interpo. on native vertical coord.; - ! 2 -- horizontal interpo. + vertical interpo. on std. pressure levels; - ! 3 -- horizontal interpo. + vertical interpo. on 10mb inc. pressure levels; - vres = 111 ! only used in vertical interpolation - mode = "linear" ! step or linear interpolation for vertical column -! -! variable specifications: -! -! var_list = 'mp3d', 'th3d', 'us3d', 'vs3d', 'rn2d', 'rc2d', 'sw2d', 'lw2d', 'ts2d' - var_list = 'td3D', 'us3D', 'vs3D', 'ph3D', 'pr3D', 'sw2D', 'lw2D', 'ms2D', 'sn2D' - nsmooth_var = 1, 1, 1, 2, 2, 0, 0, 1, 0 - fimout = .true. ! whether to write FIM binary output files - gribout = .false. ! whether to write GRIB output files from FIM -! These settings are *required* for real-time fim runs. -! However, they break the test suite. -! We will update the test suite shortly and restore these settings. -! Until then please use FIMnamelist.realtime for real-time runs. -! t1 = 0 -! t2 = 24 -! delta_t = 6 -/ - -&chemwrf - chem_opt = 0 ! chem option, 0=off, 300=on - chemdt = 30. - kemit = 1 - DUST_OPT = 1, - DMSEMIS_OPT = 1, - SEAS_OPT = 0, - BIO_EMISS_OPT = 0, - BIOMASS_BURN_OPT = 1, - PLUMERISEFIRE_FRQ = 30, - EMISS_INPT_OPT = 1, - GAS_BC_OPT = 0, - GAS_IC_OPT = 0, - AER_BC_OPT = 0, - AER_IC_OPT = 0, -/ - -&wrfphysics - mp_physics = 0, ! 0=off, 2=on - cu_physics = 0, ! 0=off, 3=on -/ - -! gptlnl modifies the behavior of the GPTL timing library, if enabled - -&gptlnl - print_method = 'full_tree' ! print full call tree - utr = 'nanotime' ! fastest available underlying timer (Intel processors only) -! eventlist = 'PAPI_FP_OPS','GPTL_CI' ! PAPI-based counters (only if PAPI is available) -/ - -! -! System specific parameters for MPI, task geometry, etc. -! - &SYSTEMnamelist -! These MPICH settings work for G8 on 248 MPI tasks on Jaguar - MPICH_PTL_UNEX_EVENTS=40960 ! Disable for Frost - MPICH_UNEX_BUFFER_SIZE=320000000 ! Disable for Frost - MPIRUNCMD='aprun -n' ! MPIRUNCMD should be defined as follows: - ! SGE 'mpirun -np' || torque 'aprun -n' || intel 'mpiexec_mpt -n' - ! load-leveler 'poe' || NCAR 'mpirun.lsf /usr/local/bin/launch' -/ - -! Everything below this line is of interest only to Workflow Manager users - -&WFMnamelist - max_run_time_prep='00:05:00' - max_run_time_fim='00:30:00' - max_run_time_pop='00:30:00' - batch_size='3' - ac_model_name='FIMXDC' - stats_model_name='FIMX' - sounding_model_name='FIMX' - ncl_model_name='FIMX' - ncl_diff_model_name='FIM-FIMX' - realtime='F' - ! Post processing: run the following tasks? (set to F to disable) - run_pop='T' ! Other post processing relies on pop to run - run_interp='T' - run_grib12='T' - run_tracker='T' - run_ncl='T' - -/ diff --git a/src/fim/FIMrun/FIMnamelist.jaguarintel.xt5 b/src/fim/FIMrun/FIMnamelist.jaguarintel.xt5 deleted file mode 100644 index 20ec582..0000000 --- a/src/fim/FIMrun/FIMnamelist.jaguarintel.xt5 +++ /dev/null @@ -1,204 +0,0 @@ - &QUEUEnamelist - ComputeTasks = '10' ! Number of compute tasks for FIM (S for Serial) - MaxQueueTime = '00:10:00' ! Run time for complete job (HH:MM:SS) [ Ignored by WFM ] - SRCDIR = '../FIMsrc_jaguarintel' ! FIM source location * MUST BE SET * [ WFM: use absolute pathname! ] - PREPDIR = 'nodir' ! If exists, use for prep otherwise calculate prep - FIMDIR = 'nodir' ! If exists, use for FIM otherwise calculate FIM - DATADIR = '/tmp/proj/atm001/rosinski/fimdata' ! Location of gfsltln and global_mtnvar files - DATADR2 = '/tmp/proj/atm001/rosinski/fimdata' ! Location of the sanl file and the sfcanl file - chem_datadir = '/lfs1/projects/fim/fimdata' ! Location of chemistry data files -/ - &TOPOnamelist - topodatfile = '/tmp/proj/atm001/rosinski/fimdata/wrf5mintopo.dat' -/ - &CNTLnamelist - glvl = 5 ! Grid level - SubdivNum = 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ! Subdivision numbers for each recursive refinement(2: bisection, 3: trisection, etc.) - nvl = 64 ! Number of atmospheric layers -/ - &PREPnamelist - curve = 2 ! 0: ij order, 1: Hilbert curve order (only for all-bisection refinement), 2:ij block order, 3: Square Layout - NumCacheBlocksPerPE = 1 ! Number of cache blocks per processor. Only applies to ij block order - alt_topo = .true. ! if true, use alternate srf.height field - aerosol_file = 'climaeropac_global.txt' ! filename relative to DATADIR - co2_2008_file = 'co2historicaldata_2008.txt' ! filename relative to DATADIR - co2_glb_file = 'co2historicaldata_glob.txt' ! filename relative to DATADIR - gfsltln_file = 'no_such_file' ! Correct value will be set by run automation - mtnvar_file = 'no_such_file' ! Correct value will be set by run automation -/ - &DIAGnamelist - PrintIpnDiag = -1 ! ipn at which to print diagnostics (-1 means no print) - PrintDiagProgVars = 12 ! Hourly increment to print diagnostic prognosis variables (-1=>none, 0=>every step) - PrintDiagNoise = 1 ! Hourly increment to print diagnostic gravity wave noise (-1=>none, 0=>every step) - PrintDiags = .false. ! True means print diagnostic messages -/ - &MODELnamelist - nts = 0 ! number of time steps - rleigh_light = 0.0 ! rayleigh damping time scale (days^-1) if top-layer wind < 100 m/s - rleigh_heavy = 0.5 ! rayleigh damping time scale (days^-1) if top-layer wind > 100 m/s - veldff_bkgnd = 1. ! diffusion velocity (=diffusion/mesh size) - ptop = 50. ! pressure (Pa) at top of model domain - thktop = 50. ! min.thknss (Pa) of uppermost model layer - intfc_smooth = 50. ! diffusivity (m/s) for intfc smoothing (0 = no smoothing) - slak = 0.5 ! intfc movement retardation coeff (1 = no retardation) - pure_sig = .false. ! if true, use pure sigma coord. -/ - &PHYSICSnamelist - PhysicsInterval = 180 ! Interval in seconds to call non-radiation physics (0=every step) - RadiationInterval = 3600 ! Interval in seconds to call radiation physics (0=every step) - GravityWaveDrag = .true. ! True means calculate gravity wave drag - ras = .false. ! false means call SAS - num_p3d = 4 ! 4 means call Zhao/Carr/Sundqvist Microphysics -/ - &TIMEnamelist - yyyymmddhhmm = "200707170000" ! date of the model run -/ - &OUTPUTnamelist - ArchvTimeUnit = 'hr' ! ts:timestep; mi:minute; hr:hour; dy:day; mo:month - TotalTime = 24 ! Total integration time in ArchvTimeUnit - ArchvIntvl = 6 ! Archive interval in ArchvTimeUnit - readrestart = .false. ! True means start by reading restart file (rpointer) - restart_freq = 4 ! Restart interval in ArchvTimeUnit - PrintMAXMINtimes = .true. ! True means print MAX MIN routine times, false means print for each PE - TimingBarriers = .false. ! True means turn on timed barriers to measure task skew, set to .false. for production runs - FixedGridOrder = .false. ! True: always output in the same order(IJ), False: order determined by curve. Does not apply to IJorder -/ - &ISOBARICnamelist - isobaric_levels_file = "output_isobaric_levs.txt" ! file containing pressure levels, in FIMrun directory - / -! -! WRITETASKnamelist is used to optionally create a separate group of -! FIM-specific write tasks to speed up FIM model output by overlapping disk -! writes with computation. By default this feature is turned off. When enabled, -! write tasks intercept FIM output and write to disk while the main compute -! tasks continue with model computation. In NEMS lingo, write tasks are called -! "quilt" tasks. -! -! WRITETASKnamelist is ignored for a serial run. -! - &WRITETASKnamelist - abort_on_bad_task_distrib = .true. ! Abort FIM when node names are not as expected - cpn = 12 ! Number of cores per node - debugmsg_on = .false. ! Print verbose debug messages - max_write_tasks_per_node = 7 ! Maximum number of write tasks to place on a single node - num_write_tasks = 0 ! Use: 0 = no write tasks, 1 = one, 21 = one write task per output file - root_own_node = .true. ! whether root process has node to himself -/ -! -! Namelist file for post processing -! -! Ning Wang, June 2007 -! - &POSTnamelist -! -! input and output specifications: -! - datadir = "../fim" - outputdir = "." -! input = "/tg2/projects/fim/jlee/PREP/mdrag5h.dat" - input = "" -! if input has content, it overwrites the datadir -! output = "/p72/fim/wang/nc_files/mdrag5h.nc" - output = "" -! if output has content, it overwrites the outputdir - output_fmt = "grib" ! "nc" --netCDF file, "grib" --GRIB file - multiple_output_files = .true. ! -- multiple grib outputfiles (assumed true when post in fim) -! -! grid specifications: -! - gribtable = "fim_gribtable" ! only used by grib output file(s) - grid_id = 228 ! 228(144, 73), 45(288, 145), - ! 3(360, 181), 4(720, 361); only for grib output file. - mx = 720 ! only used by netcdf output file - my = 360 ! only used by netcdf output file - latlonfld = .true. ! true -- create lat lon field in grib output file -! -! post processing specifications: -! - is = 1 ! interpolation scheme: - ! 0 -- no interpolation: native grid; - ! 1 -- horizontal interpo. on native vertical coord.; - ! 2 -- horizontal interpo. + vertical interpo. on std. pressure levels; - ! 3 -- horizontal interpo. + vertical interpo. on 10mb inc. pressure levels; - vres = 111 ! only used in vertical interpolation - mode = "linear" ! step or linear interpolation for vertical column -! -! variable specifications: -! -! var_list = 'mp3d', 'th3d', 'us3d', 'vs3d', 'rn2d', 'rc2d', 'sw2d', 'lw2d', 'ts2d' - var_list = 'td3D', 'us3D', 'vs3D', 'ph3D', 'pr3D', 'sw2D', 'lw2D', 'ms2D', 'sn2D' - nsmooth_var = 1, 1, 1, 2, 2, 0, 0, 1, 0 - fimout = .true. ! whether to write FIM binary output files - gribout = .false. ! whether to write GRIB output files from FIM -! These settings are *required* for real-time fim runs. -! However, they break the test suite. -! We will update the test suite shortly and restore these settings. -! Until then please use FIMnamelist.realtime for real-time runs. -! t1 = 0 -! t2 = 24 -! delta_t = 6 -/ - -! gptlnl modifies the behavior of the GPTL timing library, if enabled - -&gptlnl - print_method = 'full_tree' ! print full call tree - utr = 'nanotime' ! fastest available underlying timer (Intel processors only) -! eventlist = 'PAPI_FP_OPS','GPTL_CI' ! PAPI-based counters (only if PAPI is available) -/ - -&chemwrf - chem_opt = 0 ! chem option, 0=off, 300=on - chemdt = 30. - kemit = 1 - DUST_OPT = 1, - DMSEMIS_OPT = 1, - SEAS_OPT = 0, - BIO_EMISS_OPT = 0, - BIOMASS_BURN_OPT = 1, - PLUMERISEFIRE_FRQ = 30, - EMISS_INPT_OPT = 1, - GAS_BC_OPT = 0, - GAS_IC_OPT = 0, - AER_BC_OPT = 0, - AER_IC_OPT = 0, -/ - -&wrfphysics - mp_physics = 0, ! 0=off, 2=on - cu_physics = 0, ! 0=off, 3=on -/ - -! -! System specific parameters for MPI, task geometry, etc. -! - &SYSTEMnamelist -! These MPICH settings work for G8 on 248 MPI tasks on Jaguar - MPICH_PTL_UNEX_EVENTS=40960 ! Disable for Frost - MPICH_UNEX_BUFFER_SIZE=320000000 ! Disable for Frost - MPIRUNCMD='aprun -n' ! MPIRUNCMD should be defined as follows: - ! SGE 'mpirun -np' || torque 'aprun -n' || intel 'mpiexec_mpt -n' - ! load-leveler 'poe' || NCAR 'mpirun.lsf /usr/local/bin/launch' -/ - -! Everything below this line is of interest only to Workflow Manager users - -&WFMnamelist - max_run_time_prep='00:05:00' - max_run_time_fim='00:30:00' - max_run_time_pop='00:30:00' - batch_size='3' - ac_model_name='FIMXDC' - stats_model_name='FIMX' - sounding_model_name='FIMX' - ncl_model_name='FIMX' - ncl_diff_model_name='FIM-FIMX' - realtime='F' - ! Post processing: run the following tasks? (set to F to disable) - run_pop='T' ! Other post processing relies on pop to run - run_interp='T' - run_grib12='T' - run_tracker='T' - run_ncl='T' - -/ diff --git a/src/fim/FIMrun/FIMnamelist.linuxpcgnu b/src/fim/FIMrun/FIMnamelist.linuxpcgnu deleted file mode 100644 index 50bddf8..0000000 --- a/src/fim/FIMrun/FIMnamelist.linuxpcgnu +++ /dev/null @@ -1,201 +0,0 @@ - &QUEUEnamelist - ComputeTasks = '2' ! Number of compute tasks for FIM (S for Serial) - MaxQueueTime = '00:10:00' ! Run time for complete job (HH:MM:SS) [ Ignored by WFM ] - SRCDIR = '../FIMsrc_linuxpcgnu' ! FIM source location * MUST BE SET * [ WFM: use absolute pathname! ] - PREPDIR = 'nodir' ! If exists, use for prep otherwise calculate prep - FIMDIR = 'nodir' ! If exists, use for FIM otherwise calculate FIM - DATADIR = '/export/rosinski/fimdata' ! Location of gfsltln and global_mtnvar files - DATADR2 = '/export/rosinski/fimdata' ! Location of the sanl file and the sfcanl file - chem_datadir = '/export/rosinski/fimdata' ! Location of chemistry data files -/ - &TOPOnamelist - topodatfile = '/export/rosinski/fimdata/wrf5mintopo.dat' -/ - &CNTLnamelist - glvl = 4 ! Grid level - SubdivNum = 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ! Subdivision numbers for each recursive refinement(2: bisection, 3: trisection, etc.) - nvl = 64 ! Number of atmospheric layers -/ - &PREPnamelist - curve = 2 ! 0: ij order, 1: Hilbert curve order (only for all-bisection refinement), 2:ij block order, 3: Square Layout - NumCacheBlocksPerPE = 1 ! Number of cache blocks per processor. Only applies to ij block order - alt_topo = .true. ! if true, use alternate srf.height field - aerosol_file = 'climaeropac_global.txt' ! filename relative to DATADIR - co2_2008_file = 'co2historicaldata_2008.txt' ! filename relative to DATADIR - co2_glb_file = 'co2historicaldata_glob.txt' ! filename relative to DATADIR - gfsltln_file = 'no_such_file' ! Correct value will be set by run automation - mtnvar_file = 'no_such_file' ! Correct value will be set by run automation -/ - &DIAGnamelist - PrintIpnDiag = -1 ! ipn at which to print diagnostics (-1 means no print) - PrintDiagProgVars = 12 ! Hourly increment to print diagnostic prognosis variables (-1=>none, 0=>every step) - PrintDiagNoise = 1 ! Hourly increment to print diagnostic gravity wave noise (-1=>none, 0=>every step) - PrintDiags = .false. ! True means print diagnostic messages -/ - &MODELnamelist - nts = 0 ! number of time steps - rleigh_light = 0.0 ! rayleigh damping time scale (days^-1) if top-layer wind < 100 m/s - rleigh_heavy = 0.5 ! rayleigh damping time scale (days^-1) if top-layer wind > 100 m/s - veldff_bkgnd = 1. ! diffusion velocity (=diffusion/mesh size) - ptop = 50. ! pressure (Pa) at top of model domain - thktop = 50. ! min.thknss (Pa) of uppermost model layer - intfc_smooth = 50. ! diffusivity (m/s) for intfc smoothing (0 = no smoothing) - slak = 0.5 ! intfc movement retardation coeff (1 = no retardation) - pure_sig = .false. ! if true, use pure sigma coord. -/ - &PHYSICSnamelist - PhysicsInterval = 180 ! Interval in seconds to call non-radiation physics (0=every step) - RadiationInterval = 3600 ! Interval in seconds to call radiation physics (0=every step) - GravityWaveDrag = .true. ! True means calculate gravity wave drag - ras = .false. ! false means call SAS - num_p3d = 4 ! 4 means call Zhao/Carr/Sundqvist Microphysics -/ - &TIMEnamelist - yyyymmddhhmm = "200707170000" ! date of the model run -/ - &OUTPUTnamelist - ArchvTimeUnit = 'hr' ! ts:timestep; mi:minute; hr:hour; dy:day; mo:month - TotalTime = 6 ! Total integration time in ArchvTimeUnit - ArchvIntvl = 6 ! Archive interval in ArchvTimeUnit - readrestart = .false. ! True means start by reading restart file (rpointer) - restart_freq = 6 ! Restart interval in ArchvTimeUnit - PrintMAXMINtimes = .true. ! True means print MAX MIN routine times, false means print for each PE - TimingBarriers = .false. ! True means turn on timed barriers to measure task skew, set to .false. for production runs - FixedGridOrder = .false. ! True: always output in the same order(IJ), False: order determined by curve. Does not apply to IJorder -/ - &ISOBARICnamelist - isobaric_levels_file = "output_isobaric_levs.txt" ! file containing pressure levels, in FIMrun directory - / -! -! WRITETASKnamelist is used to optionally create a separate group of -! FIM-specific write tasks to speed up FIM model output by overlapping disk -! writes with computation. By default this feature is turned off. When enabled, -! write tasks intercept FIM output and write to disk while the main compute -! tasks continue with model computation. In NEMS lingo, write tasks are called -! "quilt" tasks. -! -! WRITETASKnamelist is ignored for a serial run. -! - &WRITETASKnamelist - abort_on_bad_task_distrib = .true. ! Abort FIM when node names are not as expected - cpn = 2 ! Number of cores per node - debugmsg_on = .false. ! Print verbose debug messages - max_write_tasks_per_node = 2 ! Maximum number of write tasks to place on a single node - num_write_tasks = 0 ! Use: 0 = no write tasks, 1 = one, 21 = one write task per output file - root_own_node = .false. ! whether root process has node to himself -/ -! -! Namelist file for post processing -! -! Ning Wang, June 2007 -! - &POSTnamelist -! -! input and output specifications: -! - datadir = "../fim" - outputdir = "." -! input = "/tg2/projects/fim/jlee/PREP/mdrag5h.dat" - input = "" -! if input has content, it overwrites the datadir -! output = "/p72/fim/wang/nc_files/mdrag5h.nc" - output = "" -! if output has content, it overwrites the outputdir - output_fmt = "grib" ! "nc" --netCDF file, "grib" --GRIB file - multiple_output_files = .true. ! -- multiple grib outputfiles (assumed true when post in fim) -! -! grid specifications: -! - gribtable = "fim_gribtable" ! only used by grib output file(s) - grid_id = 228 ! 228(144, 73), 45(288, 145), - ! 3(360, 181), 4(720, 361); only for grib output file. - mx = 720 ! only used by netcdf output file - my = 360 ! only used by netcdf output file - latlonfld = .true. ! true -- create lat lon field in grib output file -! -! post processing specifications: -! - is = 1 ! interpolation scheme: - ! 0 -- no interpolation: native grid; - ! 1 -- horizontal interpo. on native vertical coord.; - ! 2 -- horizontal interpo. + vertical interpo. on std. pressure levels; - ! 3 -- horizontal interpo. + vertical interpo. on 10mb inc. pressure levels; - vres = 111 ! only used in vertical interpolation - mode = "linear" ! step or linear interpolation for vertical column -! -! variable specifications: -! -! var_list = 'mp3d', 'th3d', 'us3d', 'vs3d', 'rn2d', 'rc2d', 'sw2d', 'lw2d', 'ts2d' - var_list = 'td3D', 'us3D', 'vs3D', 'ph3D', 'pr3D', 'sw2D', 'lw2D', 'ms2D', 'sn2D' - nsmooth_var = 1, 1, 1, 2, 2, 0, 0, 1, 0 - fimout = .true. ! whether to write FIM binary output files - gribout = .false. ! whether to write GRIB output files from FIM -! These settings are *required* for real-time fim runs. -! However, they break the test suite. -! We will update the test suite shortly and restore these settings. -! Until then please use FIMnamelist.realtime for real-time runs. -! t1 = 0 -! t2 = 24 -! delta_t = 6 -/ - -! gptlnl modifies the behavior of the GPTL timing library, if enabled - -&gptlnl - print_method = 'full_tree' ! print full call tree - utr = 'nanotime' ! fastest available underlying timer (Intel processors only) -! eventlist = 'PAPI_FP_OPS','GPTL_CI' ! PAPI-based counters (only if PAPI is available) -/ - -&chemwrf - chem_opt = 0 ! chem option, 0=off, 300=on - chemdt = 30. - kemit = 1 - DUST_OPT = 1, - DMSEMIS_OPT = 1, - SEAS_OPT = 0, - BIO_EMISS_OPT = 0, - BIOMASS_BURN_OPT = 1, - PLUMERISEFIRE_FRQ = 30, - EMISS_INPT_OPT = 1, - GAS_BC_OPT = 0, - GAS_IC_OPT = 0, - AER_BC_OPT = 0, - AER_IC_OPT = 0, -/ - -&wrfphysics - mp_physics = 0, ! 0=off, 2=on - cu_physics = 0, ! 0=off, 3=on -/ - -! -! System specific parameters for MPI, task geometry, etc. -! - &SYSTEMnamelist - MPIRUNCMD='mpirun -np' ! MPIRUNCMD should be defined as follows: - ! SGE 'mpirun -np' || torque 'aprun -n' || intel 'mpiexec_mpt -n' - ! load-leveler 'poe' || NCAR 'mpirun.lsf /usr/local/bin/launch' -/ - -! Everything below this line is of interest only to Workflow Manager users - -&WFMnamelist - max_run_time_prep='00:05:00' - max_run_time_fim='00:30:00' - max_run_time_pop='00:30:00' - batch_size='3' - ac_model_name='FIMXDC' - stats_model_name='FIMX' - sounding_model_name='FIMX' - ncl_model_name='FIMX' - ncl_diff_model_name='FIM-FIMX' - realtime='F' - ! Post processing: run the following tasks? (set to F to disable) - run_pop='T' ! Other post processing relies on pop to run - run_interp='T' - run_grib12='T' - run_tracker='T' - run_ncl='T' - -/ diff --git a/src/fim/FIMrun/FIMnamelist.macgnu b/src/fim/FIMrun/FIMnamelist.macgnu deleted file mode 100644 index 8305586..0000000 --- a/src/fim/FIMrun/FIMnamelist.macgnu +++ /dev/null @@ -1,201 +0,0 @@ - &QUEUEnamelist - ComputeTasks = '2' ! Number of compute tasks for FIM (S for Serial) - MaxQueueTime = '00:10:00' ! Run time for complete job (HH:MM:SS) [ Ignored by WFM ] - SRCDIR = '../FIMsrc_macgnu' ! FIM source location * MUST BE SET * [ WFM: use absolute pathname! ] - PREPDIR = 'nodir' ! If exists, use for prep otherwise calculate prep - FIMDIR = 'nodir' ! If exists, use for FIM otherwise calculate FIM - DATADIR = '/Volumes/scratch/rosinski/fimdata' ! Location of gfsltln and global_mtnvar files - DATADR2 = '/Volumes/scratch/rosinski/fimdata' ! Location of the sanl file and the sfcanl file - chem_datadir = '/lfs1/projects/fim/fimdata' ! Location of chemistry data files -/ - &TOPOnamelist - topodatfile = '/Volumes/scratch/rosinski/fimdata/wrf5mintopo.dat' -/ - &CNTLnamelist - glvl = 5 ! Grid level - SubdivNum = 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ! Subdivision numbers for each recursive refinement(2: bisection, 3: trisection, etc.) - nvl = 64 ! Number of atmospheric layers -/ - &PREPnamelist - curve = 2 ! 0: ij order, 1: Hilbert curve order (only for all-bisection refinement), 2:ij block order, 3: Square Layout - NumCacheBlocksPerPE = 1 ! Number of cache blocks per processor. Only applies to ij block order - alt_topo = .true. ! if true, use alternate srf.height field - aerosol_file = 'climaeropac_global.txt' ! filename relative to DATADIR - co2_2008_file = 'co2historicaldata_2008.txt' ! filename relative to DATADIR - co2_glb_file = 'co2historicaldata_glob.txt' ! filename relative to DATADIR - gfsltln_file = 'no_such_file' ! Correct value will be set by run automation - mtnvar_file = 'no_such_file' ! Correct value will be set by run automation -/ - &DIAGnamelist - PrintIpnDiag = -1 ! ipn at which to print diagnostics (-1 means no print) - PrintDiagProgVars = 12 ! Hourly increment to print diagnostic prognosis variables (-1=>none, 0=>every step) - PrintDiagNoise = 1 ! Hourly increment to print diagnostic gravity wave noise (-1=>none, 0=>every step) - PrintDiags = .false. ! True means print diagnostic messages -/ - &MODELnamelist - nts = 0 ! number of time steps - rleigh_light = 0.0 ! rayleigh damping time scale (days^-1) if top-layer wind < 100 m/s - rleigh_heavy = 0.5 ! rayleigh damping time scale (days^-1) if top-layer wind > 100 m/s - veldff_bkgnd = 1. ! diffusion velocity (=diffusion/mesh size) - ptop = 50. ! pressure (Pa) at top of model domain - thktop = 50. ! min.thknss (Pa) of uppermost model layer - intfc_smooth = 50. ! diffusivity (m/s) for intfc smoothing (0 = no smoothing) - slak = 0.5 ! intfc movement retardation coeff (1 = no retardation) - pure_sig = .false. ! if true, use pure sigma coord. -/ - &PHYSICSnamelist - PhysicsInterval = 180 ! Interval in seconds to call non-radiation physics (0=every step) - RadiationInterval = 3600 ! Interval in seconds to call radiation physics (0=every step) - GravityWaveDrag = .true. ! True means calculate gravity wave drag - ras = .false. ! false means call SAS - num_p3d = 4 ! 4 means call Zhao/Carr/Sundqvist Microphysics -/ - &TIMEnamelist - yyyymmddhhmm = "200707170000" ! date of the model run -/ - &OUTPUTnamelist - ArchvTimeUnit = 'hr' ! ts:timestep; mi:minute; hr:hour; dy:day; mo:month - TotalTime = 24 ! Total integration time in ArchvTimeUnit - ArchvIntvl = 6 ! Archive interval in ArchvTimeUnit - readrestart = .false. ! True means start by reading restart file (rpointer) - restart_freq = 4 ! Restart interval in ArchvTimeUnit - PrintMAXMINtimes = .true. ! True means print MAX MIN routine times, false means print for each PE - TimingBarriers = .false. ! True means turn on timed barriers to measure task skew, set to .false. for production runs - FixedGridOrder = .false. ! True: always output in the same order(IJ), False: order determined by curve. Does not apply to IJorder -/ - &ISOBARICnamelist - isobaric_levels_file = "output_isobaric_levs.txt" ! file containing pressure levels, in FIMrun directory - / -! -! WRITETASKnamelist is used to optionally create a separate group of -! FIM-specific write tasks to speed up FIM model output by overlapping disk -! writes with computation. By default this feature is turned off. When enabled, -! write tasks intercept FIM output and write to disk while the main compute -! tasks continue with model computation. In NEMS lingo, write tasks are called -! "quilt" tasks. -! -! WRITETASKnamelist is ignored for a serial run. -! - &WRITETASKnamelist - abort_on_bad_task_distrib = .true. ! Abort FIM when node names are not as expected - cpn = 2 ! Number of cores per node - debugmsg_on = .false. ! Print verbose debug messages - max_write_tasks_per_node = 2 ! Maximum number of write tasks to place on a single node - num_write_tasks = 0 ! Use: 0 = no write tasks, 1 = one, 21 = one write task per output file - root_own_node = .false. ! whether root process has node to himself -/ -! -! Namelist file for post processing -! -! Ning Wang, June 2007 -! - &POSTnamelist -! -! input and output specifications: -! - datadir = "../fim" - outputdir = "." -! input = "/tg2/projects/fim/jlee/PREP/mdrag5h.dat" - input = "" -! if input has content, it overwrites the datadir -! output = "/p72/fim/wang/nc_files/mdrag5h.nc" - output = "" -! if output has content, it overwrites the outputdir - output_fmt = "grib" ! "nc" --netCDF file, "grib" --GRIB file - multiple_output_files = .true. ! -- multiple grib outputfiles (assumed true when post in fim) -! -! grid specifications: -! - gribtable = "fim_gribtable" ! only used by grib output file(s) - grid_id = 228 ! 228(144, 73), 45(288, 145), - ! 3(360, 181), 4(720, 361); only for grib output file. - mx = 720 ! only used by netcdf output file - my = 360 ! only used by netcdf output file - latlonfld = .true. ! true -- create lat lon field in grib output file -! -! post processing specifications: -! - is = 1 ! interpolation scheme: - ! 0 -- no interpolation: native grid; - ! 1 -- horizontal interpo. on native vertical coord.; - ! 2 -- horizontal interpo. + vertical interpo. on std. pressure levels; - ! 3 -- horizontal interpo. + vertical interpo. on 10mb inc. pressure levels; - vres = 111 ! only used in vertical interpolation - mode = "linear" ! step or linear interpolation for vertical column -! -! variable specifications: -! -! var_list = 'mp3d', 'th3d', 'us3d', 'vs3d', 'rn2d', 'rc2d', 'sw2d', 'lw2d', 'ts2d' - var_list = 'td3D', 'us3D', 'vs3D', 'ph3D', 'pr3D', 'sw2D', 'lw2D', 'ms2D', 'sn2D' - nsmooth_var = 1, 1, 1, 2, 2, 0, 0, 1, 0 - fimout = .true. ! whether to write FIM binary output files - gribout = .false. ! whether to write GRIB output files from FIM -! These settings are *required* for real-time fim runs. -! However, they break the test suite. -! We will update the test suite shortly and restore these settings. -! Until then please use FIMnamelist.realtime for real-time runs. -! t1 = 0 -! t2 = 24 -! delta_t = 6 -/ - -! gptlnl modifies the behavior of the GPTL timing library, if enabled - -&gptlnl - print_method = 'full_tree' ! print full call tree - utr = 'nanotime' ! fastest available underlying timer (Intel processors only) -! eventlist = 'PAPI_FP_OPS','GPTL_CI' ! PAPI-based counters (only if PAPI is available) -/ - -&chemwrf - chem_opt = 0 ! chem option, 0=off, 300=on - chemdt = 30. - kemit = 1 - DUST_OPT = 1, - DMSEMIS_OPT = 1, - SEAS_OPT = 0, - BIO_EMISS_OPT = 0, - BIOMASS_BURN_OPT = 1, - PLUMERISEFIRE_FRQ = 30, - EMISS_INPT_OPT = 1, - GAS_BC_OPT = 0, - GAS_IC_OPT = 0, - AER_BC_OPT = 0, - AER_IC_OPT = 0, -/ - -&wrfphysics - mp_physics = 0, ! 0=off, 2=on - cu_physics = 0, ! 0=off, 3=on -/ - -! -! System specific parameters for MPI, task geometry, etc. -! - &SYSTEMnamelist - MPIRUNCMD='mpirun -np' ! MPIRUNCMD should be defined as follows: - ! SGE 'mpirun -np' || torque 'aprun -n' || intel 'mpiexec_mpt -n' - ! load-leveler 'poe' || NCAR 'mpirun.lsf /usr/local/bin/launch' -/ - -! Everything below this line is of interest only to Workflow Manager users - -&WFMnamelist - max_run_time_prep='00:05:00' - max_run_time_fim='00:30:00' - max_run_time_pop='00:30:00' - batch_size='3' - ac_model_name='FIMXDC' - stats_model_name='FIMX' - sounding_model_name='FIMX' - ncl_model_name='FIMX' - ncl_diff_model_name='FIM-FIMX' - realtime='F' - ! Post processing: run the following tasks? (set to F to disable) - run_pop='T' ! Other post processing relies on pop to run - run_interp='T' - run_grib12='T' - run_tracker='T' - run_ncl='T' - -/ diff --git a/src/fim/FIMrun/FIMnamelist.nems b/src/fim/FIMrun/FIMnamelist.nems deleted file mode 100644 index 2317818..0000000 --- a/src/fim/FIMrun/FIMnamelist.nems +++ /dev/null @@ -1,206 +0,0 @@ - &QUEUEnamelist - ComputeTasks = '64' ! Number of compute tasks for FIM (S for Serial) - MaxQueueTime = '00:30:00' ! Run time for complete job (HH:MM:SS) [ Ignored by WFM ] - SRCDIR = '_SORCDIR_/src/atmos/fim/_FIMSRC_' ! FIM source location * MUST BE SET * [ WFM: use absolute pathname! ] - PREPDIR = 'nodir' ! If exists, use for prep otherwise calculate prep - FIMDIR = 'nodir' ! If exists, use for FIM otherwise calculate FIM - DATADIR = '_DATDIR_' ! Location of gfsltln and global_mtnvar files - DATADR2 = '_DATDIR_' ! Location of the sanl file and the sfcanl file - chem_datadir = '_DATDIR_' ! Location of chemistry data files -/ - &TOPOnamelist - topodatfile = '_DATDIR_/wrf5mintopo.dat' -/ - &CNTLnamelist - glvl = 5 ! Grid level - SubdivNum = 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ! Subdivision numbers for each recursive refinement(2: bisection, 3: trisection, etc.) - nvl = 38 ! Number of atmospheric layers -/ - &PREPnamelist - curve = 2 ! 0: ij order, 1: Hilbert curve order (only for all-bisection refinement), 2:ij block order, 3: Square Layout - NumCacheBlocksPerPE = 1 ! Number of cache blocks per processor. Only applies to ij block order - alt_topo = .true. ! if true, use alternate srf.height field - aerosol_file = 'climaeropac_global.txt' ! filename relative to DATADIR - co2_2008_file = 'co2historicaldata_2008.txt' ! filename relative to DATADIR - co2_glb_file = 'co2historicaldata_glob.txt' ! filename relative to DATADIR -!JR Currently MUST set these 2 on NCEP IBMs or FIM will not run - gfsltln_file = 'gfsltln_t382.dat' ! filename relative to DATADIR; date < 201007281200 - mtnvar_file = 'global_mtnvar.t382' ! filename relative to DATADIR; date < 201007281200 -/ - &DIAGnamelist - PrintIpnDiag = -1 ! ipn at which to print diagnostics (-1 means no print) - PrintDiagProgVars = 12 ! Hourly increment to print diagnostic prognosis variables (-1=>none, 0=>every step) - PrintDiagNoise = 1 ! Hourly increment to print diagnostic gravity wave noise (-1=>none, 0=>every step) - PrintDiags = .false. ! True means print diagnostic messages -/ - &MODELnamelist - nts = 0 ! number of time steps - UpdateSST = .false. ! True means update sst and sea ice by reading in a file during integration - rleigh_light = 0.0 ! rayleigh damping time scale (days^-1) if top-layer wind < 100 m/s - rleigh_heavy = 0.5 ! rayleigh damping time scale (days^-1) if top-layer wind > 100 m/s - veldff_bkgnd = 1. ! diffusion velocity (=diffusion/mesh size) - ptop = 50. ! pressure (Pa) at top of model domain - thktop = 50. ! min.thknss (Pa) of uppermost model layer - intfc_smooth = 50. ! [diffusivity/mesh size] (m/s) for intfc smoothing (0 = no smoothing) - slak = 0.5 ! intfc movement retardation coeff (1 = no retardation) - pure_sig = .false. ! if true, use GFS sigma-p coordinate -/ - &PHYSICSnamelist - PhysicsInterval = 180 ! Interval in seconds to call non-radiation physics (0=every step) - RadiationInterval = 3600 ! Interval in seconds to call radiation physics (0=every step) - SSTInterval = 86400 ! Interval in seconds to call update_sst (0=every step) - GravityWaveDrag = .true. ! True means calculate gravity wave drag - ras = .false. ! false means call SAS - num_p3d = 4 ! 4 means call Zhao/Carr/Sundqvist Microphysics -/ - &TIMEnamelist - yyyymmddhhmm = "200707170000" ! date of the model run -/ - &OUTPUTnamelist - ArchvTimeUnit = 'hr' ! ts:timestep; mi:minute; hr:hour; dy:day; mo:month - TotalTime = 24 ! Total integration time in ArchvTimeUnit - ArchvIntvl = 1 ! Archive interval in ArchvTimeUnit - readrestart = .false. ! True means start by reading restart file (rpointer) - restart_freq = 240 ! Restart interval in ArchvTimeUnit - PrintMAXMINtimes = .true. ! True means print MAX MIN routine times, false means print for each PE - TimingBarriers = .false. ! True means turn on timed barriers to measure task skew, set to .false. for production runs - FixedGridOrder = .false. ! True: always output in the same order(IJ), False: order determined by curve. Does not apply to IJorder -/ - &ISOBARICnamelist - isobaric_levels_file = "output_isobaric_levs.txt" ! file containing pressure levels, in FIMrun directory - / - -! -! WRITETASKnamelist is used to optionally create a separate group of -! FIM-specific write tasks to speed up FIM model output by overlapping disk -! writes with computation. By default this feature is turned off. When enabled, -! write tasks intercept FIM output and write to disk while the main compute -! tasks continue with model computation. In NEMS lingo, write tasks are called -! "quilt" tasks. -! -! WRITETASKnamelist is ignored for a serial run. -! - &WRITETASKnamelist - abort_on_bad_task_distrib = .true. ! Abort FIM when node names are not as expected - cpn = 64 ! Number of cores per node - debugmsg_on = .false. ! Print verbose debug messages - max_write_tasks_per_node = 7 ! Maximum number of write tasks to place on a single node - num_write_tasks = 0 ! Use: 0 = no write tasks, 1 = one, 21 = one write task per output file - root_own_node = .false. ! whether root process has node to himself -/ -! -! Namelist file for post processing -! -! Ning Wang, June 2007 -! - &POSTnamelist -! -! input and output specifications: -! - datadir = "../fim" - outputdir = "." -! input = "/tg2/projects/fim/jlee/PREP/mdrag5h.dat" - input = "" -! if input has content, it overwrites the datadir -! output = "/p72/fim/wang/nc_files/mdrag5h.nc" - output = "" -! if output has content, it overwrites the outputdir - output_fmt = "grib" ! "nc" --netCDF file, "grib" --GRIB file - multiple_output_files = .true. ! -- multiple grib outputfiles (assumed true when post in fim) -! -! grid specifications: -! - gribtable = "fim_gribtable" ! only used by grib output file(s) - grid_id = 228 ! 228(144, 73), 45(288, 145), - ! 3(360, 181), 4(720, 361); only for grib output file. - mx = 720 ! only used by netcdf output file - my = 360 ! only used by netcdf output file - latlonfld = .true. ! true -- create lat lon field in grib output file -! -! post processing specifications: -! - is = 1 ! interpolation scheme: - ! 0 -- no interpolation: native grid; - ! 1 -- horizontal interpo. on native vertical coord.; - ! 2 -- horizontal interpo. + vertical interpo. on std. pressure levels; - ! 3 -- horizontal interpo. + vertical interpo. on 10mb inc. pressure levels; - vres = 111 ! only used in vertical interpolation - mode = "linear" ! step or linear interpolation for vertical column -! -! variable specifications: -! -! var_list = 'mp3d', 'th3d', 'us3d', 'vs3d', 'rn2d', 'rc2d', 'sw2d', 'lw2d', 'ts2d' - var_list = 'td3D', 'us3D', 'vs3D', 'ph3D', 'pr3D', 'sw2D', 'lw2D', 'ms2D', 'sn2D' - nsmooth_var = 1, 1, 1, 2, 2, 0, 0, 1, 0 - fimout = .true. ! whether to write FIM binary output files - gribout = .false. ! whether to write GRIB output files from FIM -! These settings are *required* for real-time fim runs. -! However, they break the test suite. -! We will update the test suite shortly and restore these settings. -! Until then please use FIMnamelist.realtime for real-time runs. -! t1 = 0 -! t2 = 24 -! delta_t = 6 -/ - -&chemwrf - chem_opt = 0 ! chem option, 0=off, 300=on - chemdt = 30. - kemit = 1 - DUST_OPT = 1, - DMSEMIS_OPT = 1, - SEAS_OPT = 0, - BIO_EMISS_OPT = 0, - BIOMASS_BURN_OPT = 1, - PLUMERISEFIRE_FRQ = 30, - EMISS_INPT_OPT = 1, - GAS_BC_OPT = 0, - GAS_IC_OPT = 0, - AER_BC_OPT = 0, - AER_IC_OPT = 0, -/ - -&wrfphysics - mp_physics = 0, ! 0=off, 2=on - cu_physics = 0, ! 0=off, 3=on -/ - -! gptlnl modifies the behavior of the GPTL timing library, if enabled - -&gptlnl - print_method = 'full_tree' ! print full call tree -! utr = 'nanotime' ! fastest available underlying timer (Intel processors only) -! eventlist = 'PAPI_FP_OPS','GPTL_CI' ! PAPI-based counters (only if PAPI is available) -/ - -! -! System specific parameters for MPI, task geometry, etc. -! - &SYSTEMnamelist - MPIRUNCMD='poe' ! MPIRUNCMD should be defined as follows: - ! SGE 'mpirun -np' || torque 'aprun -n' || intel 'mpiexec_mpt -n' - ! load-leveler 'poe' || NCAR 'mpirun.lsf /usr/local/bin/launch' -! Vapor-specific requirement - MP_LABELIO="yes" -/ - -! Everything below this line is of interest only to Workflow Manager users - -&WFMnamelist - max_run_time_prep='00:05:00' - max_run_time_fim='00:30:00' - max_run_time_pop='00:30:00' - batch_size='3' - ac_model_name='FIMXDC' - stats_model_name='FIMX' - sounding_model_name='FIMX' - ncl_model_name='FIMX' - ncl_diff_model_name='FIM-FIMX' - realtime='F' - ! Post processing: run the following tasks? (set to F to disable) - run_pop='T' ! Other post processing relies on pop to run - run_interp='T' - run_grib12='T' - run_tracker='T' - run_ncl='T' -/ diff --git a/src/fim/FIMrun/FIMnamelist.nemsdevccs b/src/fim/FIMrun/FIMnamelist.nemsdevccs deleted file mode 100644 index 8c9f15a..0000000 --- a/src/fim/FIMrun/FIMnamelist.nemsdevccs +++ /dev/null @@ -1,209 +0,0 @@ - &QUEUEnamelist - ComputeTasks = '40' ! Number of compute tasks for FIM (S for Serial) - MaxQueueTime = '00:15:00' ! Run time for complete job (HH:MM:SS) [ Ignored by WFM ] - SRCDIR = '_SORCDIR_/src/atmos/fim/FIMsrc_devccs/' ! FIM source location * MUST BE SET * [ WFM: use absolute pathname! ] - PREPDIR = 'nodir' ! If exists, use for prep otherwise calculate prep - FIMDIR = 'nodir' ! If exists, use for FIM otherwise calculate FIM - DATADIR = '_DATDIR_' ! Location of gfsltln and global_mtnvar files - DATADR2 = '_DATDIR_' ! Location of the sanl file and the sfcanl file - chem_datadir = '_DATDIR_' ! Location of chemistry data files -/ - &TOPOnamelist - topodatfile = '_DATDIR_/wrf5mintopo.dat' -/ - &CNTLnamelist - glvl = 4 ! Grid level - SubdivNum = 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ! Subdivision numbers for each recursive refinement(2: bisection, 3: trisection, etc.) - nvl = 38 ! Number of atmospheric layers -/ - &PREPnamelist - curve = 2 ! 0: ij order, 1: Hilbert curve order (only for all-bisection refinement), 2:ij block order, 3: Square Layout - NumCacheBlocksPerPE = 1 ! Number of cache blocks per processor. Only applies to ij block order - alt_topo = .true. ! if true, use alternate srf.height field - aerosol_file = 'climaeropac_global.txt' ! filename relative to DATADIR - co2_2008_file = 'co2historicaldata_2008.txt' ! filename relative to DATADIR - co2_glb_file = 'co2historicaldata_glob.txt' ! filename relative to DATADIR -!JR Currently MUST set these 2 on vapor or FIM will not run - gfsltln_file = 'gfsltln_t382.dat' ! filename relative to DATADIR; date < 201007281200 - mtnvar_file = 'global_mtnvar.t382' ! filename relative to DATADIR; date < 201007281200 -/ - &DIAGnamelist - PrintIpnDiag = -1 ! ipn at which to print diagnostics (-1 means no print) - PrintDiagProgVars = 12 ! Hourly increment to print diagnostic prognosis variables (-1=>none, 0=>every step) - PrintDiagNoise = 1 ! Hourly increment to print diagnostic gravity wave noise (-1=>none, 0=>every step) - PrintDiags = .false. ! True means print diagnostic messages -/ - &MODELnamelist - nts = 0 ! number of time steps - UpdateSST = .false. ! True means update sst and sea ice by reading in a file during integration - rleigh_light = 0.0 ! rayleigh damping time scale (days^-1) if top-layer wind < 100 m/s - rleigh_heavy = 0.5 ! rayleigh damping time scale (days^-1) if top-layer wind > 100 m/s - veldff_bkgnd = 1. ! diffusion velocity (=diffusion/mesh size) - ptop = 50. ! pressure (Pa) at top of model domain - thktop = 50. ! min.thknss (Pa) of uppermost model layer - intfc_smooth = 50. ! [diffusivity/mesh size] (m/s) for intfc smoothing (0 = no smoothing) - slak = 0.5 ! intfc movement retardation coeff (1 = no retardation) - pure_sig = .false. ! if true, use GFS sigma-p coordinate - digifilt = .false. ! DFI - digital filter initalization - tfiltwin = 5400 ! 1/2 length duration of DFI (s) - wts_type = 3 ! type of digital filter (1=Lanczos,2=Hamming,3=Dolph) -/ - &PHYSICSnamelist - PhysicsInterval = 180 ! Interval in seconds to call non-radiation physics (0=every step) - RadiationInterval = 3600 ! Interval in seconds to call radiation physics (0=every step) - SSTInterval = 86400 ! Interval in seconds to call update_sst (0=every step) - GravityWaveDrag = .true. ! True means calculate gravity wave drag - ras = .false. ! false means call SAS - num_p3d = 4 ! 4 means call Zhao/Carr/Sundqvist Microphysics -/ - &TIMEnamelist - yyyymmddhhmm = "200707170000" ! date of the model run -/ - &OUTPUTnamelist - ArchvTimeUnit = 'hr' ! ts:timestep; mi:minute; hr:hour; dy:day; mo:month - TotalTime = 24 ! Total integration time in ArchvTimeUnit - ArchvIntvl = 3 ! Archive interval in ArchvTimeUnit - readrestart = .false. ! True means start by reading restart file (rpointer) - restart_freq = 240 ! Restart interval in ArchvTimeUnit - PrintMAXMINtimes = .true. ! True means print MAX MIN routine times, false means print for each PE - TimingBarriers = .false. ! True means turn on timed barriers to measure task skew, set to .false. for production runs - FixedGridOrder = .false. ! True: always output in the same order(IJ), False: order determined by curve. Does not apply to IJorder -/ - &ISOBARICnamelist - isobaric_levels_file = "output_isobaric_levs.txt" ! file containing pressure levels, in FIMrun directory - / - -! -! WRITETASKnamelist is used to optionally create a separate group of -! FIM-specific write tasks to speed up FIM model output by overlapping disk -! writes with computation. By default this feature is turned off. When enabled, -! write tasks intercept FIM output and write to disk while the main compute -! tasks continue with model computation. In NEMS lingo, write tasks are called -! "quilt" tasks. -! -! WRITETASKnamelist is ignored for a serial run. -! - &WRITETASKnamelist - abort_on_bad_task_distrib = .true. ! Abort FIM when node names are not as expected - cpn = 40 ! Number of cores per node - debugmsg_on = .false. ! Print verbose debug messages - max_write_tasks_per_node = 7 ! Maximum number of write tasks to place on a single node - num_write_tasks = 0 ! Use: 0 = no write tasks, 1 = one, 21 = one write task per output file - root_own_node = .false. ! whether root process has node to himself -/ -! -! Namelist file for post processing -! -! Ning Wang, June 2007 -! - &POSTnamelist -! -! input and output specifications: -! - datadir = "../fim" - outputdir = "." -! input = "/tg2/projects/fim/jlee/PREP/mdrag5h.dat" - input = "" -! if input has content, it overwrites the datadir -! output = "/p72/fim/wang/nc_files/mdrag5h.nc" - output = "" -! if output has content, it overwrites the outputdir - output_fmt = "grib" ! "nc" --netCDF file, "grib" --GRIB file - multiple_output_files = .true. ! -- multiple grib outputfiles (assumed true when post in fim) -! -! grid specifications: -! - gribtable = "fim_gribtable" ! only used by grib output file(s) - grid_id = 228 ! 228(144, 73), 45(288, 145), - ! 3(360, 181), 4(720, 361); only for grib output file. - mx = 720 ! only used by netcdf output file - my = 360 ! only used by netcdf output file - latlonfld = .true. ! true -- create lat lon field in grib output file -! -! post processing specifications: -! - is = 1 ! interpolation scheme: - ! 0 -- no interpolation: native grid; - ! 1 -- horizontal interpo. on native vertical coord.; - ! 2 -- horizontal interpo. + vertical interpo. on std. pressure levels; - ! 3 -- horizontal interpo. + vertical interpo. on 10mb inc. pressure levels; - vres = 111 ! only used in vertical interpolation - mode = "linear" ! step or linear interpolation for vertical column -! -! variable specifications: -! -! var_list = 'mp3d', 'th3d', 'us3d', 'vs3d', 'rn2d', 'rc2d', 'sw2d', 'lw2d', 'ts2d' - var_list = 'td3D', 'us3D', 'vs3D', 'ph3D', 'pr3D', 'sw2D', 'lw2D', 'ms2D', 'sn2D' - nsmooth_var = 1, 1, 1, 2, 2, 0, 0, 1, 0 - fimout = .true. ! whether to write FIM binary output files - gribout = .true. ! whether to write GRIB output files from FIM -! These settings are *required* for real-time fim runs. -! However, they break the test suite. -! We will update the test suite shortly and restore these settings. -! Until then please use FIMnamelist.realtime for real-time runs. -! t1 = 0 -! t2 = 24 -! delta_t = 6 -/ - -&chemwrf - chem_opt = 0 ! chem option, 0=off, 300=on - chemdt = 30. - kemit = 1 - DUST_OPT = 1, - DMSEMIS_OPT = 1, - SEAS_OPT = 0, - BIO_EMISS_OPT = 0, - BIOMASS_BURN_OPT = 1, - PLUMERISEFIRE_FRQ = 30, - EMISS_INPT_OPT = 1, - GAS_BC_OPT = 0, - GAS_IC_OPT = 0, - AER_BC_OPT = 0, - AER_IC_OPT = 0, -/ - -&wrfphysics - mp_physics = 0, ! 0=off, 2=on - cu_physics = 0, ! 0=off, 3=on -/ - -! gptlnl modifies the behavior of the GPTL timing library, if enabled - -&gptlnl - print_method = 'full_tree' ! print full call tree -! utr = 'nanotime' ! fastest available underlying timer (Intel processors only) -! eventlist = 'PAPI_FP_OPS','GPTL_CI' ! PAPI-based counters (only if PAPI is available) -/ - -! -! System specific parameters for MPI, task geometry, etc. -! - &SYSTEMnamelist - MPIRUNCMD='poe' ! MPIRUNCMD should be defined as follows: - ! SGE 'mpirun -np' || torque 'aprun -n' || intel 'mpiexec_mpt -n' - ! load-leveler 'poe' || NCAR 'mpirun.lsf /usr/local/bin/launch' -! Vapor-specific requirement - MP_LABELIO="yes" -/ - -! Everything below this line is of interest only to Workflow Manager users - -&WFMnamelist - max_run_time_prep='00:05:00' - max_run_time_fim='00:30:00' - max_run_time_pop='00:30:00' - batch_size='3' - ac_model_name='FIMXDC' - stats_model_name='FIMX' - sounding_model_name='FIMX' - ncl_model_name='FIMX' - ncl_diff_model_name='FIM-FIMX' - realtime='F' - ! Post processing: run the following tasks? (set to F to disable) - run_pop='T' ! Other post processing relies on pop to run - run_interp='T' - run_grib12='T' - run_tracker='T' - run_ncl='T' -/ diff --git a/src/fim/FIMrun/FIMnamelist.retro.tjet b/src/fim/FIMrun/FIMnamelist.retro.tjet deleted file mode 100644 index 308f2ee..0000000 --- a/src/fim/FIMrun/FIMnamelist.retro.tjet +++ /dev/null @@ -1,207 +0,0 @@ - &QUEUEnamelist - ComputeTasks = '120' ! Number of compute tasks for FIM (S for Serial) - MaxQueueTime = '06:00:00' ! Run time for complete job (HH:MM:SS) [ Ignored by WFM ] - SRCDIR = '/lfs0/projects/rtfim/FIMRETRO1422_GFS/FIMsrc_mvapich' ! FIM source location * MUST BE SET * [ WFM: use absolute pathname! ] - PREPDIR = 'nodir' ! If exists, use for prep otherwise calculate prep - FIMDIR = 'nodir' ! If exists, use for FIM otherwise calculate FIM - DATADIR = '/whome/rtfim/fimdata' ! Location of gfsltln and global_mtnvar files - DATADR2 = '/lfs0/projects/rtfim/GFS_RETRO_FILES' ! - chem_datadir = '/lfs1/projects/fim/fimdata' ! Location of chemistry data files -/ - &TOPOnamelist - topodatfile = '/whome/rtfim/fimdata/wrf5mintopo.dat' -/ - &CNTLnamelist - glvl = 8 ! Grid level - SubdivNum = 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ! Subdivision numbers for each recursive refinement(2: bisection, 3: trisection, etc.) - nvl = 64 ! Number of atmospheric layers -/ - &PREPnamelist - curve = 2 ! 0: ij order; 1: Hilbert curve order (only for all-bisection refinement); 2:ij block order - NumCacheBlocksPerPE = 4 ! Number of cache blocks per processor. Only applies to ij block order - alt_topo = .true. ! if true, use alternate srf.height field - aerosol_file = 'climaeropac_global.txt' ! filename relative to DATADIR - co2_2008_file = 'co2historicaldata_2008.txt' ! filename relative to DATADIR - co2_glb_file = 'co2historicaldata_glob.txt' ! filename relative to DATADIR - gfsltln_file = 'no_such_file' ! Correct value will be set by run automation - mtnvar_file = 'no_such_file' ! Correct value will be set by run automation -/ - &DIAGnamelist - PrintIpnDiag = -1 ! ipn at which to print diagnostics (-1 means no print) - PrintDiagProgVars = 24 ! Hourly increment to print diagnostic prognosis variables (-1=>none, 0=>every step) - PrintDiagNoise = 1 ! Hourly increment to print diagnostic gravity wave noise (-1=>none, 0=>every step) - PrintDiags = .false. ! True means print diagnostic messages -/ - &MODELnamelist - nts = 0 ! number of time steps - rleigh_light = 0.0 ! rayleigh damping time scale (days^-1) if top-layer wind < 100 m/s - rleigh_heavy = 0.5 ! rayleigh damping time scale (days^-1) if top-layer wind > 100 m/s - veldff_bkgnd = 1. ! diffusion velocity (=diffusion/mesh size) - ptop = 50. ! pressure (Pa) at top of model domain - thktop = 50. ! min.thknss of uppermost model layer - intfc_smooth = 50. ! diffusivity (m/s) for intfc smoothing (0 = no smoothing) - slak = 0.5 ! intfc movement retardation coeff (1 = no retardation) - pure_sig = .false. ! if true, use pure sigma coord. -/ - &PHYSICSnamelist - PhysicsInterval = 180 ! Interval in seconds to call non-radiation physics (0=every step) - RadiationInterval = 3600 ! Interval in seconds to call radiation physics (0=every step) - GravityWaveDrag = .true. ! True means calculate gravity wave drag - ras = .false. ! false means call SAS - num_p3d = 4 ! 4 means call Zhao/Carr/Sundqvist Microphysics -/ - &TIMEnamelist - yyyymmddhhmm = "200707170000" ! date of the model run -/ - &OUTPUTnamelist - ArchvTimeUnit = "hr" ! ts:timestep; mi:minute; hr:hour; dy:day; mo:month - TotalTime = 168 ! Total integration time in ArchvTimeUnit - ArchvIntvl = 6 ! Archive interval in ArchvTimeUnit - readrestart = .false. ! True means start by reading restart file (rpointer) - restart_freq = 240 ! Restart interval in ArchvTimeUnit - PrintMAXMINtimes = .true. ! True means print MAX MIN routine times, false means print for each PE - TimingBarriers = .false. ! True means turn on timed barriers to measure task skew, set to .false. for production runs - FixedGridOrder = .false. ! True: always output in the same order(IJ), False: order determined by curve. Does not apply to IJorder -/ - &ISOBARICnamelist - isobaric_levels_file = "output_isobaric_levs.txt" ! file containing pressure levels, in FIMrun directory - / -! WRITETASKnamelist is used to optionally create a separate group of -! FIM-specific write tasks to speed up FIM model output by overlapping disk -! writes with computation. By default this feature is turned off. When enabled, -! write tasks intercept FIM output and write to disk while the main compute -! tasks continue with model computation. In NEMS lingo, write tasks are called -! "quilt" tasks. -! -! WRITETASKnamelist is ignored for a serial run. -! - &WRITETASKnamelist - abort_on_bad_task_distrib = .true. ! Abort FIM when node names are not as expected - cpn = 12 ! Number of cores per node - debugmsg_on = .false. ! Print verbose debug messages - max_write_tasks_per_node = 7 ! Maximum number of write tasks to place on a single node - num_write_tasks = 1 ! Use: 0 = no write tasks, 1 = one, 21 = one write task per output file - root_own_node = .true. ! whether root process has node to himself -/ -! -! Namelist file for post processing -! -! Ning Wang, June 2007 -! - &POSTnamelist -! -! input and output specifications: -! - datadir = "../fim" - outputdir = "." -! input = "/tg2/projects/fim/jlee/PREP/mdrag5h.dat" - input = "" -! if input has content, it overwrites the datadir -! output = "/p72/fim/wang/nc_files/mdrag5h.nc" - output = "" -! if output has content, it overwrites the outputdir - output_fmt = "grib" ! "nc" --netCDF file, "grib" --GRIB file - multiple_output_files = .true. ! -- multiple grib outputfiles (assumed true when post in fim) -! -! grid specifications: -! - gribtable = "fim_gribtable" ! only used by grib output file(s) - grid_id = 4 ! 228(144, 73), 45(288, 145), - ! 3(360, 181), 4(720, 361); only for grib output file. - mx = 720 ! only used by netcdf output file - my = 360 ! only used by netcdf output file - latlonfld = .true. ! true -- create lat lon field in grib output file -! -! post processing specifications: -! - is = 1 ! interpolation scheme: - ! 0 -- no interpolation: native grid; - ! 1 -- horizontal interpo. on native vertical coord.; - ! 2 -- horizontal interpo. + vertical interpo. on std. pressure levels; - ! 3 -- horizontal interpo. + vertical interpo. on 10mb inc. pressure levels; - vres = 111 ! only used in vertical interpolation - mode = "linear" ! step or linear interpolation for vertical column -! -! variable specifications: -! -! var_list = 'mp3d', 'th3d', 'us3d', 'vs3d', 'rn2d', 'rc2d', 'sw2d', 'lw2d', 'ts2d' - var_list = 'hgtP', 'tmpP', 'rp3P', 'up3P', 'vp3P', 'pr3D', 'ph3D', 'tk3D', 'td3D', 'ws3D', - 'rh3D', 'us3D', 'vs3D', 'rn2D', 'rc2D', 'r12D', 'r22D', 'rg2D', 'pw2D', 'ts2D', - 'us2D', 'hf2D', 'qf2D', 'sw2D', 'lw2D', 'ms2D', 'sn2D', 'cb2D', 'ct2D' - nsmooth_var = 4, 1, 1, 1, 1, 0, 4, 1, 1, 1, - 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, - 1, 0, 0, 0, 0, 4, 0, 0, 0 - fimout = .false. ! whether to write FIM binary output files - gribout = .true. ! whether to write GRIB output files from FIM - t1 = 0 - t2 = 168 - delta_t = 6 - -/ - -&chemwrf - chem_opt = 0 ! chem option, 0=off, 300=on - chemdt = 30. - kemit = 1 - DUST_OPT = 1, - DMSEMIS_OPT = 1, - SEAS_OPT = 0, - BIO_EMISS_OPT = 0, - BIOMASS_BURN_OPT = 1, - PLUMERISEFIRE_FRQ = 30, - EMISS_INPT_OPT = 1, - GAS_BC_OPT = 0, - GAS_IC_OPT = 0, - AER_BC_OPT = 0, - AER_IC_OPT = 0, -/ - -&wrfphysics - mp_physics = 0, ! 0=off, 2=on - cu_physics = 0, ! 0=off, 3=on -/ - -! gptlnl modifies the behavior of the GPTL timing library, if enabled - -&gptlnl - print_method = 'full_tree' ! print full call tree -! utr = 'nanotime' ! fastest available underlying timer (Intel processors only) -! eventlist = 'PAPI_FP_OPS','GPTL_CI' ! PAPI-based counters (only if PAPI is available) -/ - -! -! System specific parameters for MPI, task geometry, etc. -! - &SYSTEMnamelist - MPIRUNCMD='mpirun -np' ! MPIRUNCMD should be defined as follows: - ! SGE 'mpirun -np' || torque 'aprun -n' || intel 'mpiexec_mpt -n' - ! load-leveler 'poe' || NCAR 'mpirun.lsf /usr/local/bin/launch' -/ - -! Everything below this line is of interest only to Workflow Manager users - -&WFMnamelist - max_run_time_prep='00:05:00' - max_run_time_fim='05:00:00' - max_run_time_pop='00:30:00' - batch_size='3' - ac_model_name='FIMRETRO1422_GFS' - anx_model_names='GFS' - stats_model_name='FIMRETRO1422_GFS' - sounding_model_name='FIMRETRO1422_GFS' - ncl_model_name='EXPER FIMRETRO1422_GFS' - ncl_diff_model_name='FIM-FIMRETRO1422_GFS' - realtime='F' - rtfim_home='/whome/rtfim' - pe='thfip' - serialpe='thfip' - service='service' - mss='mss' - cycle='*' - pes_no_x=240 - GFSSANLDIR = '/lfs0/projects/rtfim/GFS_RETRO_FILES' - ENKFSFCANLDIR = '/lfs0/projects/rtfim/ENKF_RETRO_FILES' ! Location of the sanl file and the sfcanl file - init_file='gfs' - create_diff_plots='false' - run_ncl='F' -/ diff --git a/src/fim/FIMrun/FIMnamelist.test.tjet b/src/fim/FIMrun/FIMnamelist.test.tjet deleted file mode 100644 index 2b6633e..0000000 --- a/src/fim/FIMrun/FIMnamelist.test.tjet +++ /dev/null @@ -1,205 +0,0 @@ - &QUEUEnamelist - ComputeTasks = '120' ! Number of compute tasks for FIM (S for Serial) - MaxQueueTime = '01:00:00' ! Run time for complete job (HH:MM:SS) [ Ignored by WFM ] - SRCDIR = '!!!!!!!!!!!!!!!!!!!!! YOUR FULL DIRECTORY PATH HERE/FIMsrc_mvapich' ! FIM source location * MUST BE SET * [ WFM: use absolute pathname! ] - PREPDIR = 'nodir' ! If exists, use for prep otherwise calculate prep - FIMDIR = 'nodir' ! If exists, use for FIM otherwise calculate FIM - DATADIR = '/whome/rtfim/fimdata' ! Location of gfsltln and global_mtnvar files - DATADR2 = '/public/data/grids/gfs/spectral' ! Location of the sanl file and the sfcanl file - chem_datadir = '/lfs1/projects/fim/fimdata' ! Location of chemistry data files -/ - &TOPOnamelist - topodatfile = '/whome/rtfim/fimdata/wrf5mintopo.dat' -/ - &CNTLnamelist - glvl = 8 ! Grid level - SubdivNum = 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ! Subdivision numbers for each recursive refinement(2: bisection, 3: trisection, etc.) - nvl = 64 ! Number of atmospheric layers -/ - &PREPnamelist - curve = 2 ! 0: ij order; 1: Hilbert curve order (only for all-bisection refinement); 2:ij block order - NumCacheBlocksPerPE = 4 ! Number of cache blocks per processor. Only applies to ij block order - alt_topo = .true. ! if true, use alternate srf.height field - aerosol_file = 'climaeropac_global.txt' ! filename relative to DATADIR - co2_2008_file = 'co2historicaldata_2008.txt' ! filename relative to DATADIR - co2_glb_file = 'co2historicaldata_glob.txt' ! filename relative to DATADIR - gfsltln_file = 'no_such_file' ! Correct value will be set by run automation - mtnvar_file = 'no_such_file' ! Correct value will be set by run automation -/ - &DIAGnamelist - PrintIpnDiag = -1 ! ipn at which to print diagnostics (-1 means no print) - PrintDiagProgVars = 24 ! Hourly increment to print diagnostic prognosis variables (-1=>none, 0=>every step) - PrintDiagNoise = 1 ! Hourly increment to print diagnostic gravity wave noise (-1=>none, 0=>every step) - PrintDiags = .false. ! True means print diagnostic messages -/ - &MODELnamelist - nts = 0 ! number of time steps - rleigh_light = 0.0 ! rayleigh damping time scale (days^-1) if top-layer wind < 100 m/s - rleigh_heavy = 0.5 ! rayleigh damping time scale (days^-1) if top-layer wind > 100 m/s - veldff_bkgnd = 1. ! diffusion velocity (=diffusion/mesh size) - ptop = 50. ! pressure (Pa) at top of model domain - thktop = 50. ! min.thknss of uppermost model layer - intfc_smooth = 50. ! diffusivity (m/s) for intfc smoothing (0 = no smoothing) - slak = 0.5 ! intfc movement retardation coeff (1 - pure_sig = .false. ! if true, use pure sigma coord. -/ - &PHYSICSnamelist - PhysicsInterval = 180 ! Interval in seconds to call non-radiation physics (0=every step) - RadiationInterval = 3600 ! Interval in seconds to call radiation physics (0=every step) - GravityWaveDrag = .true. ! True means calculate gravity wave drag -/ - &TIMEnamelist - yyyymmddhhmm = "200707170000" ! date of the model run -/ - &OUTPUTnamelist - ArchvTimeUnit = "hr" ! ts:timestep; mi:minute; hr:hour; dy:day; mo:month - TotalTime = 24 ! Total integration time in ArchvTimeUnit - ArchvIntvl = 6 ! Archive interval in ArchvTimeUnit - readrestart = .false. ! True means start by reading restart file (rpointer) - restart_freq = 240 ! Restart interval in ArchvTimeUnit - PrintMAXMINtimes = .true. ! True means print MAX MIN routine times, false means print for each PE - TimingBarriers = .false. ! True means turn on timed barriers to measure task skew, set to .false. for production runs - FixedGridOrder = .false. ! True: always output in the same order(IJ), False: order determined by curve. Does not apply to IJorder -/ - &ISOBARICnamelist - isobaric_levels_file = "output_isobaric_levs.txt" ! file containing pressure levels, in FIMrun directory - / -! -! WRITETASKnamelist is used to optionally create a separate group of -! FIM-specific write tasks to speed up FIM model output by overlapping disk -! writes with computation. By default this feature is turned off. When enabled, -! write tasks intercept FIM output and write to disk while the main compute -! tasks continue with model computation. In NEMS lingo, write tasks are called -! "quilt" tasks. -! -! WRITETASKnamelist is ignored for a serial run. -! - &WRITETASKnamelist - abort_on_bad_task_distrib = .true. ! Abort FIM when node names are not as expected - cpn = 12 ! Number of cores per node - debugmsg_on = .false. ! Print verbose debug messages - max_write_tasks_per_node = 8 ! Maximum number of write tasks to place on a single node - num_write_tasks = 1 ! Use: 0 = no write tasks, 1 = one, 21 = one write task per output file - root_own_node = .true. ! whether root process has node to himself -/ -! -! Namelist file for post processing -! -! Ning Wang, June 2007 -! - &POSTnamelist -! -! input and output specifications: -! - datadir = "../fim" - outputdir = "." -! input = "/tg2/projects/fim/jlee/PREP/mdrag5h.dat" - input = "" -! if input has content, it overwrites the datadir -! output = "/p72/fim/wang/nc_files/mdrag5h.nc" - output = "" -! if output has content, it overwrites the outputdir - output_fmt = "grib" ! "nc" --netCDF file, "grib" --GRIB file - multiple_output_files = .true. ! -- multiple grib outputfiles (assumed true when post in fim) -! -! grid specifications: -! - gribtable = "fim_gribtable" ! only used by grib output file(s) - grid_id = 4 ! 228(144, 73), 45(288, 145), - ! 3(360, 181), 4(720, 361); only for grib output file. - mx = 720 ! only used by netcdf output file - my = 360 ! only used by netcdf output file - latlonfld = .true. ! true -- create lat lon field in grib output file -! -! post processing specifications: -! - is = 1 ! interpolation scheme: - ! 0 -- no interpolation: native grid; - ! 1 -- horizontal interpo. on native vertical coord.; - ! 2 -- horizontal interpo. + vertical interpo. on std. pressure levels; - ! 3 -- horizontal interpo. + vertical interpo. on 10mb inc. pressure levels; - vres = 111 ! only used in vertical interpolation - mode = "linear" ! step or linear interpolation for vertical column -! -! variable specifications: -! -! var_list = 'mp3d', 'th3d', 'us3d', 'vs3d', 'rn2d', 'rc2d', 'sw2d', 'lw2d', 'ts2d' - var_list = 'hgtP', 'tmpP', 'rp3P', 'up3P', 'vp3P', 'pr3D', 'ph3D', 'tk3D', 'td3D', 'ws3D', - 'rh3D', 'us3D', 'vs3D', 'rn2D', 'rc2D', 'r12D', 'r22D', 'rg2D', 'pw2D', 'ts2D', - 'us2D', 'hf2D', 'qf2D', 'sw2D', 'lw2D', 'ms2D', 'sn2D', 'cb2D', 'ct2D' - nsmooth_var = 4, 1, 1, 1, 1, 0, 4, 1, 1, 1, - 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, - 1, 0, 0, 0, 0, 4, 0, 0, 0 - fimout = .true. ! whether to write FIM binary output files - gribout = .false. ! whether to write GRIB output files from FIM - t1 = 0 - t2 = 240 - delta_t = 3 - -/ - -&chemwrf - chem_opt = 0 ! chem option, 0=off, 300=on - chemdt = 30. - kemit = 1 - DUST_OPT = 1, - DMSEMIS_OPT = 1, - SEAS_OPT = 0, - BIO_EMISS_OPT = 0, - BIOMASS_BURN_OPT = 1, - PLUMERISEFIRE_FRQ = 30, - EMISS_INPT_OPT = 1, - GAS_BC_OPT = 0, - GAS_IC_OPT = 0, - AER_BC_OPT = 0, - AER_IC_OPT = 0, -/ - -&wrfphysics - mp_physics = 0, ! 0=off, 2=on - cu_physics = 0, ! 0=off, 3=on -/ - -! -! System specific parameters for MPI, task geometry, etc. -! - &SYSTEMnamelist - MPIRUNCMD='mpirun -np' ! MPIRUNCMD should be defined as follows: - ! SGE 'mpirun -np' || torque 'aprun -n' || intel 'mpiexec_mpt -n' - ! load-leveler 'poe' || NCAR 'mpirun.lsf /usr/local/bin/launch' -/ - -! Everything below this line is of interest only to Workflow Manager users - -&WFMnamelist - max_run_time_prep='00:05:00' - max_run_time_fim='01:00:00' - max_run_time_pop='00:30:00' - batch_size='3' - ac_model_name='MY_TEST' -! anx_model_names='ENKF:GFS' - anx_model_names='GFS' - stats_model_name='MY_TEST' - sounding_model_name='MY_TEST' - ncl_model_name='EXPER MY_TEST' - ncl_diff_model_name='FIM-MYTEST' - realtime='F' - rtfim_home='/whome/rtfim' - fim_home_no_x='/lfs0/projects/rtfim/FIM' - pe='thfip' - serialpe='thfip' - service='service' - mss='mss' - pes_no_x=120 - cycle='*' - GFSSANLDIR = '/public/data/grids/gfs/spectral' ! Location of the sanl file and the sfcanl file - ENKFSFCANLDIR = '/lfs1/projects/fim/whitaker/gfsenkf_t574' ! Location of the sanl file and the sfcanl file - init_file='gfs' - create_diff_plots='true' - ! Post processing: run the following tasks? (set to F to disable) - run_pop='T' ! Other post processing relies on pop to run - run_interp='T' - run_grib12='T' - run_tracker='T' - run_ncl='T' -/ diff --git a/src/fim/FIMrun/FIMnamelist.vapor b/src/fim/FIMrun/FIMnamelist.vapor deleted file mode 100644 index 30847c4..0000000 --- a/src/fim/FIMrun/FIMnamelist.vapor +++ /dev/null @@ -1,206 +0,0 @@ - &QUEUEnamelist - ComputeTasks = '64' ! Number of compute tasks for FIM (S for Serial) - MaxQueueTime = '00:30:00' ! Run time for complete job (HH:MM:SS) [ Ignored by WFM ] - SRCDIR = '../FIMsrc_vapor' ! FIM source location * MUST BE SET * [ WFM: use absolute pathname! ] - PREPDIR = 'nodir' ! If exists, use for prep otherwise calculate prep - FIMDIR = 'nodir' ! If exists, use for FIM otherwise calculate FIM - DATADIR = '/mtb/noscrub/wx22jmr/fimdata' ! Location of gfsltln and global_mtnvar files - DATADR2 = '/mtb/noscrub/wx22jmr/fimdata' ! Location of the sanl file and the sfcanl file - chem_datadir = '/lfs1/projects/fim/fimdata' ! Location of chemistry data files -/ - &TOPOnamelist - topodatfile = '/mtb/noscrub/wx22jmr/fimdata/wrf5mintopo.dat' -/ - &CNTLnamelist - glvl = 5 ! Grid level - SubdivNum = 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ! Subdivision numbers for each recursive refinement(2: bisection, 3: trisection, etc.) - nvl = 38 ! Number of atmospheric layers -/ - &PREPnamelist - curve = 2 ! 0: ij order, 1: Hilbert curve order (only for all-bisection refinement), 2:ij block order, 3: Square Layout - NumCacheBlocksPerPE = 1 ! Number of cache blocks per processor. Only applies to ij block order - alt_topo = .true. ! if true, use alternate srf.height field - aerosol_file = 'climaeropac_global.txt' ! filename relative to DATADIR - co2_2008_file = 'co2historicaldata_2008.txt' ! filename relative to DATADIR - co2_glb_file = 'co2historicaldata_glob.txt' ! filename relative to DATADIR -!JR Currently MUST set these 2 on vapor or FIM will not run - gfsltln_file = 'gfsltln_t382.dat' ! filename relative to DATADIR; date < 201007281200 - mtnvar_file = 'global_mtnvar.t382' ! filename relative to DATADIR; date < 201007281200 -/ - &DIAGnamelist - PrintIpnDiag = -1 ! ipn at which to print diagnostics (-1 means no print) - PrintDiagProgVars = 12 ! Hourly increment to print diagnostic prognosis variables (-1=>none, 0=>every step) - PrintDiagNoise = 1 ! Hourly increment to print diagnostic gravity wave noise (-1=>none, 0=>every step) - PrintDiags = .false. ! True means print diagnostic messages -/ - &MODELnamelist - nts = 0 ! number of time steps - UpdateSST = .false. ! True means update sst and sea ice by reading in a file during integration - rleigh_light = 0.0 ! rayleigh damping time scale (days^-1) if top-layer wind < 100 m/s - rleigh_heavy = 0.5 ! rayleigh damping time scale (days^-1) if top-layer wind > 100 m/s - veldff_bkgnd = 1. ! diffusion velocity (=diffusion/mesh size) - ptop = 50. ! pressure (Pa) at top of model domain - thktop = 50. ! min.thknss (Pa) of uppermost model layer - intfc_smooth = 50. ! [diffusivity/mesh size] (m/s) for intfc smoothing (0 = no smoothing) - slak = 0.5 ! intfc movement retardation coeff (1 = no retardation) - pure_sig = .false. ! if true, use GFS sigma-p coordinate -/ - &PHYSICSnamelist - PhysicsInterval = 180 ! Interval in seconds to call non-radiation physics (0=every step) - RadiationInterval = 3600 ! Interval in seconds to call radiation physics (0=every step) - SSTInterval = 86400 ! Interval in seconds to call update_sst (0=every step) - GravityWaveDrag = .true. ! True means calculate gravity wave drag - ras = .false. ! false means call SAS - num_p3d = 4 ! 4 means call Zhao/Carr/Sundqvist Microphysics -/ - &TIMEnamelist - yyyymmddhhmm = "200707170000" ! date of the model run -/ - &OUTPUTnamelist - ArchvTimeUnit = 'hr' ! ts:timestep; mi:minute; hr:hour; dy:day; mo:month - TotalTime = 24 ! Total integration time in ArchvTimeUnit - ArchvIntvl = 1 ! Archive interval in ArchvTimeUnit - readrestart = .false. ! True means start by reading restart file (rpointer) - restart_freq = 240 ! Restart interval in ArchvTimeUnit - PrintMAXMINtimes = .true. ! True means print MAX MIN routine times, false means print for each PE - TimingBarriers = .false. ! True means turn on timed barriers to measure task skew, set to .false. for production runs - FixedGridOrder = .false. ! True: always output in the same order(IJ), False: order determined by curve. Does not apply to IJorder -/ - &ISOBARICnamelist - isobaric_levels_file = "output_isobaric_levs.txt" ! file containing pressure levels, in FIMrun directory - / - -! -! WRITETASKnamelist is used to optionally create a separate group of -! FIM-specific write tasks to speed up FIM model output by overlapping disk -! writes with computation. By default this feature is turned off. When enabled, -! write tasks intercept FIM output and write to disk while the main compute -! tasks continue with model computation. In NEMS lingo, write tasks are called -! "quilt" tasks. -! -! WRITETASKnamelist is ignored for a serial run. -! - &WRITETASKnamelist - abort_on_bad_task_distrib = .true. ! Abort FIM when node names are not as expected - cpn = 64 ! Number of cores per node - debugmsg_on = .false. ! Print verbose debug messages - max_write_tasks_per_node = 7 ! Maximum number of write tasks to place on a single node - num_write_tasks = 0 ! Use: 0 = no write tasks, 1 = one, 21 = one write task per output file - root_own_node = .false. ! whether root process has node to himself -/ -! -! Namelist file for post processing -! -! Ning Wang, June 2007 -! - &POSTnamelist -! -! input and output specifications: -! - datadir = "../fim" - outputdir = "." -! input = "/tg2/projects/fim/jlee/PREP/mdrag5h.dat" - input = "" -! if input has content, it overwrites the datadir -! output = "/p72/fim/wang/nc_files/mdrag5h.nc" - output = "" -! if output has content, it overwrites the outputdir - output_fmt = "grib" ! "nc" --netCDF file, "grib" --GRIB file - multiple_output_files = .true. ! -- multiple grib outputfiles (assumed true when post in fim) -! -! grid specifications: -! - gribtable = "fim_gribtable" ! only used by grib output file(s) - grid_id = 228 ! 228(144, 73), 45(288, 145), - ! 3(360, 181), 4(720, 361); only for grib output file. - mx = 720 ! only used by netcdf output file - my = 360 ! only used by netcdf output file - latlonfld = .true. ! true -- create lat lon field in grib output file -! -! post processing specifications: -! - is = 1 ! interpolation scheme: - ! 0 -- no interpolation: native grid; - ! 1 -- horizontal interpo. on native vertical coord.; - ! 2 -- horizontal interpo. + vertical interpo. on std. pressure levels; - ! 3 -- horizontal interpo. + vertical interpo. on 10mb inc. pressure levels; - vres = 111 ! only used in vertical interpolation - mode = "linear" ! step or linear interpolation for vertical column -! -! variable specifications: -! -! var_list = 'mp3d', 'th3d', 'us3d', 'vs3d', 'rn2d', 'rc2d', 'sw2d', 'lw2d', 'ts2d' - var_list = 'td3D', 'us3D', 'vs3D', 'ph3D', 'pr3D', 'sw2D', 'lw2D', 'ms2D', 'sn2D' - nsmooth_var = 1, 1, 1, 2, 2, 0, 0, 1, 0 - fimout = .true. ! whether to write FIM binary output files - gribout = .false. ! whether to write GRIB output files from FIM -! These settings are *required* for real-time fim runs. -! However, they break the test suite. -! We will update the test suite shortly and restore these settings. -! Until then please use FIMnamelist.realtime for real-time runs. -! t1 = 0 -! t2 = 24 -! delta_t = 6 -/ - -&chemwrf - chem_opt = 0 ! chem option, 0=off, 300=on - chemdt = 30. - kemit = 1 - DUST_OPT = 1, - DMSEMIS_OPT = 1, - SEAS_OPT = 0, - BIO_EMISS_OPT = 0, - BIOMASS_BURN_OPT = 1, - PLUMERISEFIRE_FRQ = 30, - EMISS_INPT_OPT = 1, - GAS_BC_OPT = 0, - GAS_IC_OPT = 0, - AER_BC_OPT = 0, - AER_IC_OPT = 0, -/ - -&wrfphysics - mp_physics = 0, ! 0=off, 2=on - cu_physics = 0, ! 0=off, 3=on -/ - -! gptlnl modifies the behavior of the GPTL timing library, if enabled - -&gptlnl - print_method = 'full_tree' ! print full call tree -! utr = 'nanotime' ! fastest available underlying timer (Intel processors only) -! eventlist = 'PAPI_FP_OPS','GPTL_CI' ! PAPI-based counters (only if PAPI is available) -/ - -! -! System specific parameters for MPI, task geometry, etc. -! - &SYSTEMnamelist - MPIRUNCMD='poe' ! MPIRUNCMD should be defined as follows: - ! SGE 'mpirun -np' || torque 'aprun -n' || intel 'mpiexec_mpt -n' - ! load-leveler 'poe' || NCAR 'mpirun.lsf /usr/local/bin/launch' -! Vapor-specific requirement - MP_LABELIO="yes" -/ - -! Everything below this line is of interest only to Workflow Manager users - -&WFMnamelist - max_run_time_prep='00:05:00' - max_run_time_fim='00:30:00' - max_run_time_pop='00:30:00' - batch_size='3' - ac_model_name='FIMXDC' - stats_model_name='FIMX' - sounding_model_name='FIMX' - ncl_model_name='FIMX' - ncl_diff_model_name='FIM-FIMX' - realtime='F' - ! Post processing: run the following tasks? (set to F to disable) - run_pop='T' ! Other post processing relies on pop to run - run_interp='T' - run_grib12='T' - run_tracker='T' - run_ncl='T' -/ diff --git a/src/fim/FIMrun/README b/src/fim/FIMrun/README deleted file mode 100644 index 8e224d8..0000000 --- a/src/fim/FIMrun/README +++ /dev/null @@ -1,5 +0,0 @@ - -NOTE: The FIM test suite and run automation ignore any subdirectories of FIMrun. - If it is ever necessary to introduce a hierarchy of directories here, - changes to the test suite and run automation will also be required. - diff --git a/src/fim/FIMrun/REDUCEinput b/src/fim/FIMrun/REDUCEinput deleted file mode 100644 index 6a7bc8c..0000000 --- a/src/fim/FIMrun/REDUCEinput +++ /dev/null @@ -1,7 +0,0 @@ -'../fim/' !Pathname - path to where the variables are -5 !Nvars - the number of variables to process (max 5) -up vp hg tm rp !Var - variables -2 !Ntimes - the number of output times to process -12 24 !Time - output times (hours) -2 !NumLevels - the number of pressure levels to output -1000 850 !Pressure - pressure levels (mb) diff --git a/src/fim/FIMrun/SMSnamelist b/src/fim/FIMrun/SMSnamelist deleted file mode 100644 index 9e1ea77..0000000 --- a/src/fim/FIMrun/SMSnamelist +++ /dev/null @@ -1,21 +0,0 @@ -!------------------------------------------------------------------------------ -! SMSnamelist is an optional file used to control SMS run-time options. If -! it is not present SMS will use default values for all options. -!------------------------------------------------------------------------------ - !--------------------------------------------------------------------------- - ! When compare_var_on==.true., execute two copies of the SMS program. The - ! first copy uses compare_var_ntasks_1 tasks. The second copy uses - ! compare_var_ntasks_2 tasks. The total number of MPI tasks assigned to - ! SMS must equal compare_var_ntasks_1+compare_var_ntasks_2. Results are - ! cross-checked whenever a COMPARE_VAR directive is encountered. If a - ! difference is found, the program will exit with an error message. - !--------------------------------------------------------------------------- - &SMSnamelist - compare_var_on = .false., - compare_var_ntasks_1 = 0, - compare_var_ntasks_2 = 0 -/ -!------------------------------------------------------------------------------ -! See the SMSnamelist file in the SMS source for additional options not -! normally used by FIM. -!------------------------------------------------------------------------------ diff --git a/src/fim/FIMrun/atmos.configure b/src/fim/FIMrun/atmos.configure deleted file mode 100644 index a43bfc3..0000000 --- a/src/fim/FIMrun/atmos.configure +++ /dev/null @@ -1 +0,0 @@ -core: fim diff --git a/src/fim/FIMrun/batchTemplate b/src/fim/FIMrun/batchTemplate deleted file mode 100755 index 26066b3..0000000 --- a/src/fim/FIMrun/batchTemplate +++ /dev/null @@ -1,30 +0,0 @@ -#!/bin/ksh - -CONTEXT="batchTemplate" - -. ./functions.ksh # Most function definitions can be found here. - -ksh_insist # Ensure that we are running in ksh93 - -let "stime=$(date +%s)" -print "Starting batchTemplate-prep at $(date)" -xsource ./batchTemplate-prep -let "etime=$(date +%s)" -let "delta=$etime-$stime" -print "batchTemplate-prep took $delta seconds" - -let "stime=$etime" -print "Starting batchTemplate-fim at $(date)" -xsource ./batchTemplate-fim -let "etime=$(date +%s)" -let "delta=$etime-$stime" -print "batchTemplate-fim took $delta seconds" - -let "stime=$etime" -print "Starting batchTemplate-post at $(date)" -xsource ./batchTemplate-post -let "etime=$(date +%s)" -let "delta=$etime-$stime" -print "batchTemplate-post took $delta seconds" - -return 0 diff --git a/src/fim/FIMrun/batchTemplate-FIMY_ENKF-files b/src/fim/FIMrun/batchTemplate-FIMY_ENKF-files deleted file mode 100755 index c7c9282..0000000 --- a/src/fim/FIMrun/batchTemplate-FIMY_ENKF-files +++ /dev/null @@ -1,79 +0,0 @@ -#!/bin/ksh - -# Note: When run by Workflow Manager, this script's output can be found in -# FIMwfm/logs/pop. Also see FIMwfm/logs/workflow for general WFM messages. - -CONTEXT="batchTemplate-FIMY_ENKF-files" - -# Source functions.ksh if needed. - -if [[ -z "$functions_sourced" ]] -then - test -n "$WFM" && prefix=$FIM_HOME/FIMrun || prefix=. - . $prefix/functions.ksh # Most function definitions can be found here. -fi - -ksh_insist # Ensure that we are running in ksh93 - -# Run batchTemplate-setup if it has not already been run. - -test -z "$batchTemplate_setup_ran" && xsource ./batchTemplate-setup - -# get files from run directory - -FIM_POST_GRIB1_DIR=$POST/fim/NAT/grib1 -print "in batchTemplate-FIMY_ENKF-files" -print "ENKF_DIR: $ENKF_DIR" -print "PREP: $PREP" -print "RUNDIR: $RUNDIR" -print "MEMBER_ID: $MEMBER_ID" -if [[ ! -d "$PREP" ]] -then - mkdir -p "$PREP" || fail "Cannot make directory $PREP." -fi -if [[ ! -d $RUNDIR/fim_$MEMBER_ID ]] -then - mkdir -p "$RUNDIR/fim_$MEMBER_ID" || fail "Cannot make directory $RUNDIR/fim_$MEMBER_ID." -fi - -get_nl_value_unquoted $fimnamelist ISOBARICnamelist isobaric_levels_file ISOBARIC_LEVELS_FILE - -cp "$ENKF_DIR/fim_C/$ISOBARIC_LEVELS_FILE" $RUNDIR/prep_$MEMBER_ID/$ISOBARIC_LEVELS_FILE || print "cannot copy $ENKF_DIR/prep_C/$ISOBARIC_LEVELS_FILE" -cp "$ENKF_DIR/fim_C/$ISOBARIC_LEVELS_FILE" $RUNDIR/fim_$MEMBER_ID/$ISOBARIC_LEVELS_FILE || print "cannot copy $ENKF_DIR/fim_C/$ISOBARIC_LEVELS_FILE" -cp "$ENKF_DIR/fim_C/FIMnamelist" $PREP/FIMnamelist || fail "cannot copy $ENKF_DIR/prep_C/FIMnamelist" -cp "$PREP/FIMnamelist" $RUNDIR/fim_$MEMBER_ID/FIMnamelist || fail "cannot copy $PREP/FIMnamelist $RUNDIR/fim_$MEMBER_ID/FIMnamelist" -cp "$ENKF_DIR/fim_C/fim_gribtable" $RUNDIR/fim_$MEMBER_ID/fim_gribtable || fail "cannot copy $ENKF_DIR/fim_C/fim_gribtable" -cp "$ENKF_DIR/prep_C/icos_grid_info_level.dat" $RUNDIR/prep_$MEMBER_ID/icos_grid_info_level.dat || fail "cannot copy $ENKF_DIR/prep_C/icos_grid_info_level.dat" - # copy grib files -ENKF_FILE=$ENKF_DIR/fim_C/$ENKF_FILE_NAME -fcst=$T1 -typeset -Z3 tmp_fcst -while [[ $fcst -le $T2 ]] -do - tmp_fcst=$fcst - print "in grib loop: after format fcst: $fcst tmp_fcst: $tmp_fcst" - FILE_NAME=${ENKF_FILE}${tmp_fcst} - OUT_FILE_NAME=${ENKF_FILE_NAME}${tmp_fcst} - print "!!filename: $FILE_NAME out_file_name: $OUT_FILE_NAME" - if [[ -s $FILE_NAME ]] - then - cp $FILE_NAME $FIM_POST_GRIB1_DIR/$OUT_FILE_NAME - else - print "error $FILE_NAME does not exist" - fi - fcst=$(expr ${fcst} + 6) -done - - # copy fim files -fcst=$T1 -while [[ $fcst -le $T2 ]] -do - tmp_fcst=$fcst - print "after format fcst: $fcst tmp_fcst: $tmp_fcst" - str=fim_out*${tmp_fcst}hr - # find $ENKF_DIR/fim_C/ -name "fim_out*${tmp_fcst}hr" -exec cp {} $RUNDIR/fim_$MEMBER_ID \; - find $ENKF_DIR/fim_C/ -name "$str" -exec cp {} $RUNDIR/fim_$MEMBER_ID \; - fcst=$(expr ${fcst} + 6) -done - -return 0 diff --git a/src/fim/FIMrun/batchTemplate-fim b/src/fim/FIMrun/batchTemplate-fim deleted file mode 100755 index 09da253..0000000 --- a/src/fim/FIMrun/batchTemplate-fim +++ /dev/null @@ -1,275 +0,0 @@ -#!/bin/ksh - -# NOTE: When run by Workflow Manager, this script's output can be found in -# FIMwfm/logs/fim. Also see FIMwfm/logs/workflow for general WFM messages. - -CONTEXT="batchTemplate-fim" - -# Source functions.ksh if needed. - -if [[ -z "$functions_sourced" ]] -then - test -n "$WFM" && prefix=$FIM_HOME/FIMrun || prefix=. - . $prefix/functions.ksh # Most function definitions can be found here. -fi - -ksh_insist # Ensure that we are running in ksh93 - -# For WFM runs, enter the appropriate FIMrun directory. - -if [[ -n "$WFM" && -n "$FIM_HOME" ]] -then - cd $FIM_HOME/FIMrun || fail "Cannot cd to $FIM_HOME/FIMrun." -fi - -# Run batchTemplate-setup if it has not already been run. - -test -z "$batchTemplate_setup_ran" && xsource ./batchTemplate-setup - -# Enter the appropriate run directory (as defined by batchTemplate-setup). - -FIMRUN="$PWD" -cd $DIR || fail "Cannot cd to $DIR." - -# Preserve a pre-existing WFM fim dir by renaming with a timestamp. - -if [[ -n "$WFM" && -d "$FIM" ]] -then - ls -ld --time-style=+%Y%m%d%H%M%S $FIM | awk '{print $6}' | \ - read timestamp || fail "Cannot ls $FIM." - test -z "$timestamp" && fail "Cannot determine timestamp for $FIM." - mv $FIM $FIM.$timestamp || fail "Cannot move $FIM -> $FIM.$timestamp." -fi - -# Make the fim directory if it doesn't already exist (which it will -# if this is a restart run) - -if [[ ! -d $FIM ]] -then -mkdir $FIM || fail "Cannot make directory $FIM." -fi - -# If a pre-existing fim directory was identified, link its contents. - -if [[ -d "$FIMDIR" ]] -then - linksafe $FIMDIR/* $FIM -else - - # Copy needed items. - - if [[ -d "$PREPDIR" ]] - then - cp $fimnamelist $FIM/$NLFILE || \ - fail "Cannot copy $fimnamelist -> $FIM/$NLFILE." - else - cp $PREP/$NLFILE $FIM || fail "Cannot copy $PREP/$NLFILE -> $FIM." - fi - # NEMS configuration files -#TODO: At present, FIMnamelist must be kept in sync with fim.configure -#TODO: by hand. Automate. - cp ../model_configure $FIM || \ - fail "Cannot copy ../model_configure -> $FIM" - cp ../atmos.configure $FIM || \ - fail "Cannot copy ../atmos.configure -> $FIM" - cp ../fim.configure.G${GLVL} $FIM/fim.configure || \ - fail "Cannot copy ../fim.configure.G${GLVL} -> $FIM/fim.configure" - - if [[ -f "../$smsnamelist" ]] - then - cp ../$smsnamelist $FIM/SMSnamelist || \ - fail "Cannot copy $smsnamelist -> $FIM/SMSnamelist." - fi - - # Enter the fim directory. - - cd $FIM || fail "Cannot cd to $FIM." - - # Link items. - - linksafe $BINDIR/$FIMEXE -#TBH: $NEMSX is full path to NEMS executable (/foo/bar/NEMS.x) - if [[ -n "$NEMSX" ]] - then - linksafe $NEMSX - FIMEXEBASE=$(basename $NEMSX) - fi - - #JR fim will need the gribtable if post is being run as a part of the model proper - cp ../$fimgribtable $FIM || \ - fail "Cannot copy ../$fimgribtable -> $FIM" - -#JR Need $INFO_FILE in $FIM in case post is being run as part of fim - test -f "$INFO_FILE" || linksafe $PREP/$INFO_FILE - - # For ensemble runs, we overwrote these variables, so restore them - if [[ "$WFM" == "ENSEMBLE" ]] - then - sanlFile=$sanlFilename - sfcanlFile=$sfcanlFilename - fi - get_nl_value_unquoted $fimnamelist PREPnamelist gfsltln_file GFSLTLNFILE - test -z "$GFSLTLNFILE" && fail "Could not get gfsltln filename from $fimnamelist." - get_nl_value_unquoted $fimnamelist PREPnamelist aerosol_file AEROSOLFILE - test -z "$AEROSOLFILE" && fail "Could not get aerosol filename from $fimnamelist." - get_nl_value_unquoted $fimnamelist PREPnamelist co2_2008_file CO2_2008FILE - test -z "$CO2_2008FILE" && fail "Could not get co2_2008 filename from $fimnamelist." - get_nl_value_unquoted $fimnamelist PREPnamelist co2_glb_file CO2_GLBFILE - test -z "$CO2_GLBFILE" && fail "Could not get co2_glb filename from $fimnamelist." - get_nl_value_unquoted $fimnamelist ISOBARICnamelist isobaric_levels_file ISOBARIC_LEVELS_FILE - test -z "$ISOBARIC_LEVELS_FILE" && fail "Could not get isobaric_levels_file filename from $fimnamelist." - - for file in $LATLON_FILE $GLVL_FILE $sanlFile $GFSLTLNFILE gfsfc.dat \ - theta_coor.txt dpsig.txt top_grid $AEROSOLFILE $CO2_2008FILE $CO2_GLBFILE sst_dat ocean_bcs_ltln \ - $ISOBARIC_LEVELS_FILE - do - linksafe $PREP/$file - done - - # If COMPARE_VAR is enabled, link two DecompInfo*.dat files; otherwise link - # link only one. - - for taskcount in $taskcounts - do - decompfile="$PREP/DecompInfo_$taskcount.dat" - linksafe $decompfile - done # for taskcount in $taskcounts - - endian_big 82 - endian_little 30 - - chem_fim_setup - - # Sets environment variables (including MPIRUNCMD) from FIMnamelist's - # SYSTEMnamelist. - - export_nl $fimnamelist SYSTEMnamelist - - if [[ "$parallelism" == "serial" ]] - then # serial run - print "$CONTEXT on host $(hostname) running: ./$FIMEXEBASE" >stdout - print "Current directory is $PWD" >>stdout - ./$FIMEXEBASE >>stdout 2>&1 || fail "./$FIMEXEBASE failed." - print "\n$FIMEXEBASE finished\n" - elif [[ "$parallelism" == "parallel" ]] - then # parallel run - - # Get number of cores for mpirun. - - $BINDIR/get_num_cores | grep "num_cores_mpirun:" | sed 's/^.*://' | read PES_ARG || fail "Could not get num_cores_mpirun." - - # Set PES_ARG and MPIRUNENV depending on target. - - case "$FC" in - "bluefire") - PES_ARG="" - MPIRUNENV="" - ;; - "debug") - PES_ARG=$PES_ARG - MPIRUNENV="$(endian_big 82) $(endian_little 30)" - ;; - "frostintel") - PES_ARG=$PES_ARG - MPIRUNENV="" - ;; - "jaguargnu") - PES_ARG=$PES_ARG - MPIRUNENV="" - ;; - "jaguarintel") - PES_ARG=$PES_ARG - MPIRUNENV="" - ;; - "lahey") - PES_ARG=$PES_ARG - MPIRUNENV="$(endian_big 82) $(endian_little 30)" - ;; - "linuxpcgnu") - PES_ARG=$PES_ARG - MPIRUNENV="" - ;; - "macgnu") - PES_ARG=$PES_ARG - MPIRUNENV="" - ;; - "mvapich") - PES_ARG=$PES_ARG - MPIRUNENV="$(endian_big 82) $(endian_little 30)" - ;; - "nems") - PES_ARG=$PES_ARG - MPIRUNENV="$(endian_big 82) $(endian_little 30)" - ;; - "openmpi") - PES_ARG=$PES_ARG - MPIRUNENV="" - ;; - "ranger") - #JR This is a GUESS! - PES_ARG=$PES_ARG - MPIRUNENV="" - ;; - "serial") - PES_ARG="" - MPIRUNENV="" - ;; - "vapor") - PES_ARG="" - MPIRUNENV="" - ;; - "devccs") - PES_ARG="" - MPIRUNENV="" - ;; - *) - print "$0: Unknown build configuration: $FC" - exit 1 - ;; - esac - - # The exit status of some MPI run commands is unreliable, so disable trapping. - - trap_off - - # Run FIM (PES_ARG may be blank). - - print "$CONTEXT on host $(hostname) running: $MPIRUNCMD $PES_ARG $MPIRUNENV ./$FIMEXEBASE" > stdout - print "Current directory is $PWD" >> stdout - $MPIRUNCMD $PES_ARG $MPIRUNENV ./$FIMEXEBASE >> stdout 2>&1 - - # Re-enable error trapping. - - trap_on - - # Check for completion messages in stdout file. - - fimstatus="fail" - # normal completion message - grep 'Program exited normally' stdout && fimstatus="ok" - # NEMS completion message - grep 'PROGRAM nems HAS ENDED' stdout && fimstatus="ok" - - if [[ "$fimstatus" == "fail" ]] - then - fail "$FIMEXEBASE failed." - else - print "\n$FIMEXEBASE finished\n" - fi - - else # neither "serial" or "parallel" was specified - fail "Parallelism error." - - fi # if serial/parallel - - endian_reset - -fi # if [[ -d "$FIMDIR" ]] - -cat stdout || fail "Cannot cat stdout." - -cd $FIMRUN || fail "Cannot cd to $FIMRUN." - -print "\nDone with fim\n" - -return 0 diff --git a/src/fim/FIMrun/batchTemplate-grib12 b/src/fim/FIMrun/batchTemplate-grib12 deleted file mode 100755 index d84c325..0000000 --- a/src/fim/FIMrun/batchTemplate-grib12 +++ /dev/null @@ -1,47 +0,0 @@ -#!/bin/ksh - -# Set ISDIR -if [ $IS -eq 1 ]; then - ISDIR="NAT" -elif [ $IS -eq 2 ]; then - ISDIR="PRS" -else - echo "Unsupported vertical coordinate option: $IS" - exit 1 -fi - -# Set the path to the run directory -grib1dir=${FIM_HOME}/FIMrun/fim_${GLVL}_${NVL}_${PES}_${yyyymmddhhmm}/post_${MEMBER_ID}/${GRID_NAME}/${ISDIR}/grib1 -grib2dir=${FIM_HOME}/FIMrun/fim_${GLVL}_${NVL}_${PES}_${yyyymmddhhmm}/post_${MEMBER_ID}/${GRID_NAME}/${ISDIR}/grib2 - -# Create grib2 dir -if [ ! -d ${grib2dir} ]; then - mkdir -p ${grib2dir} -fi - -# Change to the grib1 dir -cd ${grib1dir} - -#Get yyjjjHHMM -datestr=`echo ${yyyymmddhhmm} | sed 's/^\([0-9]\{4\}\)\([0-9]\{2\}\)\([0-9]\{2\}\)\([0-9]\{2\}\)\([0-9]\{2\}\)/\1\/\2\/\3 \4\:\5/'` -yyjjjhhmm=`date +%y%j%H%M -d "${datestr}"` - -# Convert grib1 file to grib2 -file=`printf "${yyjjjhhmm}%04d" ${T}` -${CNVGRIB} -p40 -g12 ${file} ${grib2dir}/${file}.tmp -error=$? -# if [ ${error} -ne 0 ]; then - echo "ERROR: ${CNVGRIB} -p40 -g12 ${file} ${grib2dir}/${file}.tmp failed! Exit status=${error}" -# exit ${error} -# else - mv ${grib2dir}/${file}.tmp ${grib2dir}/${file} -# fi - -# Check to make sure all files were converted -file=`printf "${yyjjjhhmm}%04d" ${T}` -if [ ! -s "${grib2dir}/${file}" ]; then - echo "ERROR: ${grib2dir}/${file} is missing!" -# exit 1 -fi - -exit 0 diff --git a/src/fim/FIMrun/batchTemplate-grib21 b/src/fim/FIMrun/batchTemplate-grib21 deleted file mode 100755 index 410ecf8..0000000 --- a/src/fim/FIMrun/batchTemplate-grib21 +++ /dev/null @@ -1,49 +0,0 @@ -#!/bin/ksh - -IS=1 -# Set ISDIR -if [ $IS -eq 1 ]; then - ISDIR="NAT" -elif [ $IS -eq 2 ]; then - ISDIR="PRS" -else - echo "Unsupported vertical coordinate option: $IS" - exit 1 -fi - -# Set the path to the run directory -grib1dir=${FIM_HOME}/FIMrun/fim_${GLVL}_${NVL}_${PES}_${yyyymmddhhmm}/post_${MEMBER_ID}/${GRID_NAME}/${ISDIR}/grib1 -grib2dir=${FIM_HOME}/FIMrun/fim_${GLVL}_${NVL}_${PES}_${yyyymmddhhmm}/post_${MEMBER_ID}/${GRID_NAME}/${ISDIR}/grib2 - -# Create grib1 dir -if [ ! -d ${grib1dir} ]; then - mkdir -p ${grib1dir} -fi - -# Change to the grib1 dir -cd ${grib2dir} - -#Get yyjjjHHMM -datestr=`echo ${yyyymmddhhmm} | sed 's/^\([0-9]\{4\}\)\([0-9]\{2\}\)\([0-9]\{2\}\)\([0-9]\{2\}\)\([0-9]\{2\}\)/\1\/\2\/\3 \4\:\5/'` -yyjjjhhmm=`date +%y%j%H%M -d "${datestr}"` - - -# Convert grib2 file to grib1 -file="${yyjjjhhmm}0${T}" -echo "T: ${T} file: ${file}" -echo "cmd: ${CNVGRIB} -p40 -g21 ${grib2dir}/${file} ${grib1dir}/${file}" - -${CNVGRIB} -p40 -g21 ${grib2dir}/${file} ${grib1dir}/${file} -error=$? -if [ ${error} -ne 0 ]; then - echo "ERROR: ${CNVGRIB} -p40 -g21 ${grib2dir}/${file} ${grib1dir}/${file} failed! Exit status=${error}" - exit ${error} -fi - -# Check to make sure all files were converted -if [ ! -s "${grib1dir}/${file}" ]; then - echo "ERROR: ${grib1dir}/${file} is missing!" - exit 1 -fi - -exit 0 diff --git a/src/fim/FIMrun/batchTemplate-interp b/src/fim/FIMrun/batchTemplate-interp deleted file mode 100755 index adb0b37..0000000 --- a/src/fim/FIMrun/batchTemplate-interp +++ /dev/null @@ -1,45 +0,0 @@ -#!/bin/ksh - -# Set ISDIR -if [ $IS -eq 1 ]; then - ISDIR="NAT" -elif [ $IS -eq 2 ]; then - ISDIR="PRS" -else - echo "Unsupported vertical coordinate option: $IS" - exit 1 -fi - -# Set the path to the run directory -postdir=${FIM_HOME}/FIMrun/fim_${GLVL}_${NVL}_${PES}_${yyyymmddhhmm}/post_${MEMBER_ID}/fim/${ISDIR}/grib1 -workdir=${FIM_HOME}/FIMrun/fim_${GLVL}_${NVL}_${PES}_${yyyymmddhhmm}/post_${MEMBER_ID}/${GRID_NAME}/${ISDIR}/grib1 - -# Create grid dir -if [ ! -d ${workdir} ]; then - mkdir -p ${workdir} -fi - -# Change to the post dir -cd ${postdir} - -#Get yyjjjHHMM -datestr=`echo ${yyyymmddhhmm} | sed 's/^\([0-9]\{4\}\)\([0-9]\{2\}\)\([0-9]\{2\}\)\([0-9]\{2\}\)\([0-9]\{2\}\)/\1\/\2\/\3 \4\:\5/'` -yyjjjhhmm=`date +%y%j%H%M -d "${datestr}"` - -# Interpolate onto grid specified by $GRID_SPEC -file=`printf "${yyjjjhhmm}%04d" ${T}` -${COPYGB} -g"${GRID_SPEC}" -x ${file} ${workdir}/${file} -error=$? -if [ ${error} -ne 0 ]; then - echo "ERROR: ${COPYGB} -g'${GRID_SPEC}' -x ${file} ${workdir}/${file} failed! Exit status=${error}" - exit ${error} -fi - -# Check to make sure all files were interpolated -file=`printf "${yyjjjhhmm}%04d" ${T}` -if [ ! -s "${workdir}/${file}" ]; then - echo "ERROR: ${workdir}/${file} is missing!" - exit 1 -fi - -exit 0 diff --git a/src/fim/FIMrun/batchTemplate-ncl b/src/fim/FIMrun/batchTemplate-ncl deleted file mode 100755 index f70daab..0000000 --- a/src/fim/FIMrun/batchTemplate-ncl +++ /dev/null @@ -1,798 +0,0 @@ -#!/bin/ksh -l -#dis -#dis Open Source License/Disclaimer, Forecast Systems Laboratory -#dis NOAA/OAR/FSL, 325 Broadway Boulder, CO 80305 -#dis -#dis This software is distributed under the Open Source Definition, -#dis which may be found at http://www.opensource.org/osd.html. -#dis -#dis In particular, redistribution and use in source and binary forms, -#dis with or without modification, are permitted provided that the -#dis following conditions are met: -#dis -#dis - Redistributions of source code must retain this notice, this -#dis list of conditions and the following disclaimer. -#dis -#dis - Redistributions in binary form must provide access to this -#dis notice, this list of conditions and the following disclaimer, and -#dis the underlying source code. -#dis -#dis - All modifications to this software must be clearly documented, -#dis and are solely the responsibility of the agent making the -#dis modifications. -#dis -#dis - If significant modifications or enhancements are made to this -#dis software, the FSL Software Policy Manager -#dis (softwaremgr@fsl.noaa.gov) should be notified. -#dis -#dis THIS SOFTWARE AND ITS DOCUMENTATION ARE IN THE PUBLIC DOMAIN -#dis AND ARE FURNISHED "AS IS." THE AUTHORS, THE UNITED STATES -#dis GOVERNMENT, ITS INSTRUMENTALITIES, OFFICERS, EMPLOYEES, AND -#dis AGENTS MAKE NO WARRANTY, EXPRESS OR IMPLIED, AS TO THE USEFULNESS -#dis OF THE SOFTWARE AND DOCUMENTATION FOR ANY PURPOSE. THEY ASSUME -#dis NO RESPONSIBILITY (1) FOR THE USE OF THE SOFTWARE AND -#dis DOCUMENTATION; OR (2) TO PROVIDE TECHNICAL SUPPORT TO USERS. -#dis -#dis - -########################################################################## -# -#Script Name: ncl.ksh -# -# Author: Christopher Harrop -# Forecast Systems Laboratory -# 325 Broadway R/FST -# Boulder, CO. 80305 -# -# Released: 10/30/2003 -# Version: 1.0 -# Changes: None -# -# Purpose: This script generates NCL graphics from wrf output. -# -# EXE_ROOT = The full path of the ncl executables -# MOAD_DATAROOT = Top level directory of wrf output and -# configuration data. -# START_TIME = The cycle time to use for the initial time. -# If not set, the system clock is used. -# FCST_TIME = The two-digit forecast that is to be ncled -# -# A short and simple "control" script could be written to call this script -# or to submit this script to a batch queueing system. Such a "control" -# script could also be used to set the above environment variables as -# appropriate for a particular experiment. Batch queueing options can -# be specified on the command line or as directives at the top of this -# script. A set of default batch queueing directives is provided. -# -########################################################################## - -. ${FIM_HOME}/FIMrun/chem_functions.ksh -chem_on && CHEMFLAG="true" || CHEMFLAG="false" - -chem_opt_value=$(get_chem_opt_value) - -echo "chem_opt_value: $chem_opt_value" -echo "************** in ncl MODL: $MODL" - - -# Make sure we are using GMT time zone for time computations -export TZ="GMT" - -# Execute module command to use newest version of NCL -# module switch ncarg ncl - -export UDUNITS2_XML_PATH=${NCARG_ROOT}/lib/ncarg/udunits/udunits2.xml - -# Set up paths to shell commands -LS=/bin/ls -LN=/bin/ln -RM=/bin/rm -MKDIR=/bin/mkdir -CP=/bin/cp -MV=/bin/mv -ECHO=/bin/echo -CAT=/bin/cat -GREP=/bin/grep -CUT=/bin/cut -AWK="/bin/gawk --posix" -SED=/bin/sed -DATE=/bin/date -BC=/usr/bin/bc -NCL=ncl -CTRANS=ctrans -PS2PDF=/usr/bin/ps2pdf -CONVERT=/usr/bin/convert -MONTAGE=/usr/bin/montage -PATH=${NCARG_ROOT}/bin:${PATH} - -#. /work/01033/harrop/jettools.sh - -# Set ISDIR -if [ ${IS} -eq 1 ]; then - ISDIR="NAT" -elif [ ${IS} -eq 2 ]; then - ISDIR="PRS" -else - echo "Unsupported vertical coordinate option: ${IS}" - exit 1 -fi - -# Location of NCL graphics scripts -NCL_ROOT=${FIM_HOME}/FIMwfm/ncl/fimall - -typeset -Z3 FCST_TIME - -# Get yyjjjHHMM -datestr=`echo ${yyyymmddhhmm} | sed 's/^\([0-9]\{4\}\)\([0-9]\{2\}\)\([0-9]\{2\}\)\([0-9]\{2\}\)\([0-9]\{2\}\)/\1\/\2\/\3 \4\:\5/'` -yyjjjhhmm=`date +%y%j%H%M -d "${datestr}"` - -# Generate the ATCFNAME for this member -#ATCFNAME=`echo ${ATCFNAME} | sed 's/NN/${MEMBER_ID}/'` -ATCFNAME=`echo ${ATCFNAME} | sed "s/NN/${MEMBER_ID}/"` - - -FCST_TIME=${T} - -# Print run parameters -${ECHO} -${ECHO} "nclfim.ksh started at `${DATE}`" -${ECHO} -${ECHO} " GLVL=${GLVL}" -${ECHO} " NVL=${NVL}" -${ECHO} " PES=${PES}" -${ECHO} " FCST_TIME=${FCST_TIME}" -${ECHO} " ISDIR=${ISDIR}" -${ECHO} - -# Set up the work directory and cd into it -workdir=${FIM_HOME}/FIMrun/fim_${GLVL}_${NVL}_${PES}_${yyyymmddhhmm}/ncl_${MEMBER_ID}/${GRID_NAME}/${ISDIR}_${FCST_TIME} -${RM} -rf ${workdir} -${MKDIR} -p ${workdir} -cd ${workdir} - -# Link to input file -${LN} -s ${FIM_HOME}/FIMrun/fim_${GLVL}_${NVL}_${PES}_${yyyymmddhhmm}/post_${MEMBER_ID}/${GRID_NAME}/${ISDIR}/grib1/${yyjjjhhmm}0${FCST_TIME} fim.grb -${ECHO} "fim.grb" > arw_file.txt - -# Setup domain file -${ECHO} ${GRID_NAME} > domain.txt - -# Link to tracker file -if [ -s ${FIM_HOME}/FIMrun/fim_${GLVL}_${NVL}_${PES}_${yyyymmddhhmm}/tracker_${MEMBER_ID}/${T}/track.${yyyymmddhhmm}.${ATCFNAME} ]; then - ${CAT} ${FIM_HOME}/FIMrun/fim_${GLVL}_${NVL}_${PES}_${yyyymmddhhmm}/tracker_${MEMBER_ID}/${T}/track.${yyyymmddhhmm}.${ATCFNAME} | ${SED} 's/\*\*\*/ 0/' > ./track.${yyyymmddhhmm} - ${ECHO} ./track.${yyyymmddhhmm} > track_file.txt -fi - -modelFound=0 - -if [ "${ISDIR}" == "NAT" ]; then - - if [[ "$MODL" = *FIMCES* ]]; then - - echo "This is FIMCES" - modelFound=1 - - set -A ncgms sfc_temp \ - sfc_Cs1 \ - sfc_Cs2 \ - int_Cs1 \ - int_Cs2 \ - int_Cs1b \ - int_Cs2b \ - ua_wind \ - ua_wmag \ - sfc_pwtr \ - sfc_mslp \ - 500_temp \ - 700_temp \ - 850_temp \ - 925_temp \ - 500_hgt \ - ua_rh \ - ua_rh8 \ - ua_vort \ - sfc_shtfl \ - sfc_lhtfl \ - sfc_swr \ - 2m_temp \ - 2ds_temp \ - 2m_dewp \ - 10m_wind \ - sfc_totp \ - sfc_acp \ - sfc_acpcp \ - sfc_weasd \ - ua_ceil \ - ua_ctop - - set -A pngs sfc_temp.png \ - sfc_Cs1.png \ - sfc_Cs2.png \ - int_Cs1.png \ - int_Cs2.png \ - int_Cs1b.png \ - int_Cs2b.png \ - ua_wind-0.png \ - ua_wind-1.png \ - ua_wmag-0.png \ - ua_wmag-1.png \ - sfc_pwtr.png \ - sfc_mslp.png \ - 500_temp.png \ - 700_temp.png \ - 850_temp.png \ - 925_temp.png \ - 500_hgt.png \ - ua_rh.png \ - ua_rh8.png \ - ua_vort.png \ - sfc_shtfl.png \ - sfc_lhtfl.png \ - sfc_swr.png \ - 2m_temp.png \ - 2ds_temp.png \ - 2m_dewp.png \ - 10m_wind.png \ - sfc_totp.png \ - sfc_acp.png \ - sfc_acpcp.png \ - sfc_weasd.png \ - ua_ceil.png \ - ua_ctop.png - - set -A monpngs montage.png - - set -A webnames temp_sfc \ - Cs1_sfc \ - Cs2_sfc \ - Cs1_int \ - Cs2_int \ - Cs1b_int \ - Cs2b_int \ - wind_850 \ - wind_250 \ - wmag_850 \ - wmag_250 \ - pwtr_sfc \ - mslp_sfc \ - temp_500 \ - temp_700 \ - temp_850 \ - temp_925 \ - hgt_500 \ - rh_500 \ - rh_850 \ - vort_500 \ - shtfl_sfc \ - lhtfl_sfc \ - swr_sfc \ - temp_2m \ - temp_2ds \ - dewp_2m \ - wind_10m \ - totp_sfc \ - 3hap_sfc \ - acpcp_sfc \ - weasd_sfc \ - ceil \ - ctop - - set -A webmon montage - - fi - - if [[ "$MODL" = *FIMCO2* ]]; then - - echo "This is FIMCO2" - modelFound=1 - - set -A ncgms sfc_temp \ - sfc_CO2 \ - 3m1_CO2 \ - ua_wind \ - ua_wmag \ - sfc_pwtr \ - sfc_mslp \ - 500_temp \ - 700_temp \ - 850_temp \ - 925_temp \ - 500_hgt \ - ua_rh \ - ua_rh8 \ - ua_vort \ - sfc_shtfl \ - sfc_lhtfl \ - sfc_swr \ - 2m_temp \ - 2ds_temp \ - 2m_dewp \ - 10m_wind \ - sfc_totp \ - sfc_acp \ - sfc_acpcp \ - sfc_weasd \ - ua_ceil \ - ua_ctop - - set -A pngs sfc_temp.png \ - sfc_CO2.png \ - 3m1_CO2.png \ - ua_wind-0.png \ - ua_wind-1.png \ - ua_wmag-0.png \ - ua_wmag-1.png \ - sfc_pwtr.png \ - sfc_mslp.png \ - 500_temp.png \ - 700_temp.png \ - 850_temp.png \ - 925_temp.png \ - 500_hgt.png \ - ua_rh.png \ - ua_rh8.png \ - ua_vort.png \ - sfc_shtfl.png \ - sfc_lhtfl.png \ - sfc_swr.png \ - 2m_temp.png \ - 2ds_temp.png \ - 2m_dewp.png \ - 10m_wind.png \ - sfc_totp.png \ - sfc_acp.png \ - sfc_acpcp.png \ - sfc_weasd.png \ - ua_ceil.png \ - ua_ctop.png - - set -A monpngs montage.png - - set -A webnames temp_sfc \ - CO2_sfc \ - CO2_3m1 \ - wind_850 \ - wind_250 \ - wmag_850 \ - wmag_250 \ - pwtr_sfc \ - mslp_sfc \ - temp_500 \ - temp_700 \ - temp_850 \ - temp_925 \ - hgt_500 \ - rh_500 \ - rh_850 \ - vort_500 \ - shtfl_sfc \ - lhtfl_sfc \ - swr_sfc \ - temp_2m \ - temp_2ds \ - dewp_2m \ - wind_10m \ - totp_sfc \ - 3hap_sfc \ - acpcp_sfc \ - weasd_sfc \ - ceil \ - ctop - - set -A webmon montage - - fi # FIMCO2 - - if [[ "$MODL" = *FIMX* ]]; then - - modelFound=1 - echo "This is FIMX" - - set -A ncgms sfc_temp \ - ua_wind \ - ua_wmag \ - sfc_pwtr \ - sfc_mslp \ - 500_temp \ - 700_temp \ - 850_temp \ - 925_temp \ - 500_hgt \ - ua_rh \ - ua_rh8 \ - ua_vort \ - sfc_shtfl \ - sfc_lhtfl \ - 2m_temp \ - 2ds_temp \ - 2m_dewp \ - 10m_wind \ - sfc_totp \ - sfc_acp \ - sfc_acpcp \ - sfc_weasd \ - ua_ceil \ - ua_ctop \ - int_PM25 \ - int_ash \ - int_bc \ - int_fd \ - int_oc \ - int_sulf \ - ua_ash \ - sfc_aod - - set -A pngs sfc_temp.png \ - ua_wind-0.png \ - ua_wind-1.png \ - ua_wind-2.png \ - ua_wind-3.png \ - ua_wind-4.png \ - ua_wind-5.png \ - ua_wmag-0.png \ - ua_wmag-1.png \ - ua_wmag-2.png \ - ua_wmag-3.png \ - ua_wmag-4.png \ - ua_wmag-5.png \ - sfc_pwtr.png \ - sfc_mslp.png \ - 500_temp.png \ - 700_temp.png \ - 850_temp.png \ - 925_temp.png \ - 500_hgt.png \ - ua_rh.png \ - ua_rh8.png \ - ua_vort.png \ - sfc_shtfl.png \ - sfc_lhtfl.png \ - 2m_temp.png \ - 2ds_temp.png \ - 2m_dewp.png \ - 10m_wind.png \ - sfc_totp.png \ - sfc_acp.png \ - sfc_acpcp.png \ - sfc_weasd.png \ - ua_ceil.png \ - ua_ctop.png \ - int_PM25.png \ - int_ash.png \ - int_bc.png \ - int_fd.png \ - int_oc.png \ - int_sulf.png \ - ua_ash-0.png \ - ua_ash-1.png \ - ua_ash-2.png \ - sfc_aod.png - - set -A monpngs montage.png - - set -A webnames temp_sfc \ - wind_850 \ - wind_250 \ - wind_25 \ - wind_20 \ - wind_10 \ - wind_5 \ - wmag_850 \ - wmag_250 \ - wmag_25 \ - wmag_20 \ - wmag_10 \ - wmag_5 \ - pwtr_sfc \ - mslp_sfc \ - temp_500 \ - temp_700 \ - temp_850 \ - temp_925 \ - hgt_500 \ - rh_500 \ - rh_850 \ - vort_500 \ - shtfl_sfc \ - lhtfl_sfc \ - temp_2m \ - temp_2ds \ - dewp_2m \ - wind_10m \ - totp_sfc \ - 3hap_sfc \ - acpcp_sfc \ - weasd_sfc \ - ceil \ - ctop \ - PM25_int \ - ash_int \ - bc_int \ - fd_int \ - oc_int \ - sulf_int \ - ash_sfc20 \ - ash_2035 \ - ash_3550 \ - aod_sfc - - set -A webmon montage - - fi # FIMX - - if [[ $modelFound -eq 0 ]]; then - - echo "This is FIM" - - set -A ncgms sfc_temp \ - ua_wind \ - ua_wmag \ - sfc_pwtr \ - sfc_mslp \ - 500_temp \ - 700_temp \ - 850_temp \ - 925_temp \ - 500_hgt \ - ua_rh \ - ua_rh8 \ - ua_vort \ - sfc_shtfl \ - sfc_lhtfl \ - sfc_swr \ - 2m_temp \ - 2ds_temp \ - 2m_dewp \ - 10m_wind \ - sfc_totp \ - sfc_acp \ - sfc_acpcp \ - sfc_weasd \ - sfc_rhpw \ - ua_ceil \ - ua_ctop - - set -A pngs sfc_temp.png \ - ua_wind-0.png \ - ua_wind-1.png \ - ua_wind-2.png \ - ua_wind-3.png \ - ua_wind-4.png \ - ua_wind-5.png \ - ua_wmag-0.png \ - ua_wmag-1.png \ - ua_wmag-2.png \ - ua_wmag-3.png \ - ua_wmag-4.png \ - ua_wmag-5.png \ - sfc_pwtr.png \ - sfc_mslp.png \ - 500_temp.png \ - 700_temp.png \ - 850_temp.png \ - 925_temp.png \ - 500_hgt.png \ - ua_rh.png \ - ua_rh8.png \ - ua_vort.png \ - sfc_shtfl.png \ - sfc_lhtfl.png \ - sfc_swr.png \ - 2m_temp.png \ - 2ds_temp.png \ - 2m_dewp.png \ - 10m_wind.png \ - sfc_totp.png \ - sfc_acp.png \ - sfc_acpcp.png \ - sfc_weasd.png \ - sfc_rhpw.png \ - ua_ceil.png \ - ua_ctop.png - - set -A monpngs montage.png - - set -A webnames temp_sfc \ - wind_850 \ - wind_250 \ - wind_25 \ - wind_20 \ - wind_10 \ - wind_5 \ - wmag_850 \ - wmag_250 \ - wmag_25 \ - wmag_20 \ - wmag_10 \ - wmag_5 \ - pwtr_sfc \ - mslp_sfc \ - temp_500 \ - temp_700 \ - temp_850 \ - temp_925 \ - hgt_500 \ - rh_500 \ - rh_850 \ - vort_500 \ - shtfl_sfc \ - lhtfl_sfc \ - swr_sfc \ - temp_2m \ - temp_2ds \ - dewp_2m \ - wind_10m \ - totp_sfc \ - 3hap_sfc \ - acpcp_sfc \ - weasd_sfc \ - rhpw_sfc \ - ceil \ - ctop - - set -A webmon montage - - fi # FIM - -fi # nat == 1 - -ncl_error=0 - -# Run the NCL scripts for each plot -i=0 -while [ ${i} -lt ${#ncgms[@]} ]; do - - plot=${ncgms[${i}]} - ${ECHO} "Starting fim_${plot}.ncl at `${DATE}`" - ${NCL} < ${NCL_ROOT}/fim_${plot}.ncl - error=$? - if [ ${error} -ne 0 ]; then - ${ECHO} "ERROR: ${plot} crashed! Exit status=${error}" - ncl_error=${error} - fi - ${ECHO} "Finished fim_${plot}.ncl at `${DATE}`" - - (( i=i + 1 )) - -done - -# Run ctrans on all the .ncgm files to translate them into Sun Raster files -# NOTE: ctrans ONLY works for 32-bit versions of NCL -i=0 -while [ ${i} -lt ${#ncgms[@]} ]; do - - plot=${ncgms[${i}]} - ${ECHO} "Starting ctrans for ${plot}.ncgm at `${DATE}`" - - # normal image - ${CTRANS} -d sun ${plot}.ncgm -resolution 1132x906 > ${plot}.ras - error=$? - if [ ${error} -ne 0 ]; then - ${ECHO} "ERROR: ctrans ${plot}.ncgm crashed! Exit status=${error}" - ncl_error=${error} - fi - - if [ "${ISDIR}" == "NAT" ]; then - - # montage image - ${CTRANS} -d sun ${plot}.ncgm -resolution 2176x1360 > ${plot}_mon.ras - error=$? - if [ ${error} -ne 0 ]; then - ${ECHO} "ERROR: ctrans ${plot}.ncgm crashed! Exit status=${error}" - ncl_error=${error} - fi - ls -al ${plot}_mon.ras - if [ -s ${plot}_mon.ras ]; then - ${CONVERT} -trim -border 30x12 -bordercolor black ${plot}_mon.ras ${plot}_mon.ras - error=$? - if [ ${error} -ne 0 ]; then - ${ECHO} "ERROR: convert ${plot}_mon.ras crashed! Exit status=${error}" - ncl_error=${error} - fi - else - ${ECHO} "No file to convert, exit gracefully" - ncl_error=0 - fi - - fi - - ${ECHO} "Finished ctrans for ${plot}.ncgm at `${DATE}`" - - (( i=i + 1 )) - -done - -# Convert the .ras files into .png files -i=0 -while [ ${i} -lt ${#ncgms[@]} ]; do - - plot=${ncgms[${i}]} - ${ECHO} "Starting convert for ${plot}.ras at `${DATE}`" - - # normal image - ls -al ${plot}.ras - if [ -s ${plot}.ras ]; then - ${CONVERT} -colors 128 -trim -border 25x25 -bordercolor black ${plot}.ras ${plot}.png - error=$? - if [ ${error} -ne 0 ]; then - ${ECHO} "ERROR: convert ${plot}.ras crashed! Exit status=${error}" - ncl_error=${error} - fi - else - ${ECHO} "No file to convert, exit gracefully" - ncl_error=0 - fi - - if [ "${ISDIR}" == "NAT" ]; then - # montage image - ls -al ${plot}_mon.ras - if [ -s ${plot}_mon.ras ]; then - ${CONVERT} ${plot}_mon.ras ${plot}_mon.png - error=$? - if [ ${error} -ne 0 ]; then - ${ECHO} "ERROR: convert ${plot}_mon.ras crashed! Exit status=${error}" - ncl_error=${error} - fi - else - ${ECHO} "No file to convert, exit gracefully" - ncl_error=0 - fi - fi - - ${ECHO} "Finished convert for ${plot}.ras at `${DATE}`" - - (( i=i + 1 )) - -done - -if [ "${ISDIR}" == "NAT" ]; then - - # put together the montage images - # -geometry formerly 1240x775+20+1 - if [[ -s ua_wind_mon-1.png || -s sfc_pwtr_mon.png || -s 850_temp_mon.png || -s sfc_totp_mon.png ]]; then - ${MONTAGE} ua_wind_mon-1.png sfc_pwtr_mon.png 850_temp_mon.png sfc_totp_mon.png -tile 2x2 -geometry 1240x775+21+4 -background black montage.png - error=$? - if [ ${error} -ne 0 ]; then - ${ECHO} "ERROR: montage crashed! Exit status=${error}" - ncl_error=${error} - fi - else - ${ECHO} "No files available to montage, exit gracefully" - ncl_error=0 - fi -fi - -# Copy png files to their proper names -i=0 -while [ ${i} -lt ${#pngs[@]} ]; do - pngfile=${pngs[${i}]} - webfile=${FIM_HOME}/FIMrun/fim_${GLVL}_${NVL}_${PES}_${yyyymmddhhmm}/ncl_${MEMBER_ID}/${GRID_NAME}/${webnames[${i}]}_f${FCST_TIME}.png - ${MV} ${pngfile} ${webfile} - (( i=i + 1 )) -done - -if [ "${ISDIR}" == "NAT" ]; then - - # Copy montage files to their proper names - i=0 - while [ ${i} -lt ${#monpngs[@]} ]; do - pngfile=${monpngs[${i}]} - webfile=${FIM_HOME}/FIMrun/fim_${GLVL}_${NVL}_${PES}_${yyyymmddhhmm}/ncl_${MEMBER_ID}/${GRID_NAME}/${webmon[${i}]}_f${FCST_TIME}.png - ${MV} ${pngfile} ${webfile} - (( i=i + 1 )) - done - -fi - -# Remove the workdir -cd ../ -${RM} -rf ${workdir} - -# Hack to prevent errors for analysis file from crashing the whole thing -if [[ ${FCST_TIME} -eq 0 ]]; then - ncl_error=0 -fi - -${ECHO} "ncl.ksh completed at `${DATE}`" - -exit ${ncl_error} diff --git a/src/fim/FIMrun/batchTemplate-ncldiff b/src/fim/FIMrun/batchTemplate-ncldiff deleted file mode 100755 index 0d17e6e..0000000 --- a/src/fim/FIMrun/batchTemplate-ncldiff +++ /dev/null @@ -1,416 +0,0 @@ -#!/bin/ksh -l -#dis -#dis Open Source License/Disclaimer, Forecast Systems Laboratory -#dis NOAA/OAR/FSL, 325 Broadway Boulder, CO 80305 -#dis -#dis This software is distributed under the Open Source Definition, -#dis which may be found at http://www.opensource.org/osd.html. -#dis -#dis In particular, redistribution and use in source and binary forms, -#dis with or without modification, are permitted provided that the -#dis following conditions are met: -#dis -#dis - Redistributions of source code must retain this notice, this -#dis list of conditions and the following disclaimer. -#dis -#dis - Redistributions in binary form must provide access to this -#dis notice, this list of conditions and the following disclaimer, and -#dis the underlying source code. -#dis -#dis - All modifications to this software must be clearly documented, -#dis and are solely the responsibility of the agent making the -#dis modifications. -#dis -#dis - If significant modifications or enhancements are made to this -#dis software, the FSL Software Policy Manager -#dis (softwaremgr@fsl.noaa.gov) should be notified. -#dis -#dis THIS SOFTWARE AND ITS DOCUMENTATION ARE IN THE PUBLIC DOMAIN -#dis AND ARE FURNISHED "AS IS." THE AUTHORS, THE UNITED STATES -#dis GOVERNMENT, ITS INSTRUMENTALITIES, OFFICERS, EMPLOYEES, AND -#dis AGENTS MAKE NO WARRANTY, EXPRESS OR IMPLIED, AS TO THE USEFULNESS -#dis OF THE SOFTWARE AND DOCUMENTATION FOR ANY PURPOSE. THEY ASSUME -#dis NO RESPONSIBILITY (1) FOR THE USE OF THE SOFTWARE AND -#dis DOCUMENTATION; OR (2) TO PROVIDE TECHNICAL SUPPORT TO USERS. -#dis -#dis - -########################################################################## -# -#Script Name: ncl.ksh -# -# Author: Christopher Harrop -# Forecast Systems Laboratory -# 325 Broadway R/FST -# Boulder, CO. 80305 -# -# Released: 10/30/2003 -# Version: 1.0 -# Changes: None -# -# Purpose: This script generates NCL graphics from wrf output. -# -# EXE_ROOT = The full path of the ncl executables -# MOAD_DATAROOT = Top level directory of wrf output and -# configuration data. -# START_TIME = The cycle time to use for the initial time. -# If not set, the system clock is used. -# FCST_TIME = The two-digit forecast that is to be ncled -# -# A short and simple "control" script could be written to call this script -# or to submit this script to a batch queueing system. Such a "control" -# script could also be used to set the above environment variables as -# appropriate for a particular experiment. Batch queueing options can -# be specified on the command line or as directives at the top of this -# script. A set of default batch queueing directives is provided. -# -########################################################################## - -# Set the SGE queueing options -#$ -S /bin/ksh -#$ -pe serial 1 -#$ -l h_rt=1:00:00 -#$ -N ncl_rr -#$ -j y -#$ -V - -# Make sure we are using GMT time zone for time computations -export TZ="GMT" -export MODL=${MODL} -export NCL_HOME=${NCL_HOME} -export UDUNITS2_XML_PATH=${NCARG_ROOT}/lib/ncarg/udunits/udunits2.xml - - -# Execute module command to use newest version of NCL -#module switch ncarg ncl - -# Set up paths to shell commands -LS=/bin/ls -LN=/bin/ln -RM=/bin/rm -MKDIR=/bin/mkdir -CP=/bin/cp -MV=/bin/mv -ECHO=/bin/echo -CAT=/bin/cat -GREP=/bin/grep -CUT=/bin/cut -AWK="/bin/gawk --posix" -SED=/bin/sed -DATE=/bin/date -BC=/usr/bin/bc -#NCL=${NCARG_ROOT}/bin/ncl -#NCL=/misc/whome/wrfruc/ncl-4.3.1/bin/ncl -NCL=ncl -#CTRANS=/misc/whome/dtcrt/CT2007/ncl-4.3.0_32/bin/ctrans -CTRANS=ctrans -PS2PDF=/usr/bin/ps2pdf -CONVERT=/usr/bin/convert -#CONVERT=/whome/harrop/ImageMagick/bin/convert -MONTAGE=/usr/bin/montage -#MONTAGE=/whome/harrop/ImageMagick/bin/montage -PATH=${NCARG_ROOT}/bin:${PATH} - -#. /work/01033/harrop/jettools.sh - -# Set ID -if [ ! "${ID}" ]; then - ID="" -fi - -# Set ISDIR -if [ ${IS} -eq 1 ]; then - ISDIR="NAT" -elif [ ${IS} -eq 2 ]; then - ISDIR="PRS" -else - echo "Unsupported vertical coordinate option: ${IS}" - exit 1 -fi - -# Location of NCL graphics scripts -#NCL_ROOT=${FIM_HOME}/FIMwfm/ncl/fimalldiff - -typeset -Z3 FCST_TIME - -# Get yyjjjHHMM -datestr=`echo ${yyyymmddhhmm} | sed 's/^\([0-9]\{4\}\)\([0-9]\{2\}\)\([0-9]\{2\}\)\([0-9]\{2\}\)\([0-9]\{2\}\)/\1\/\2\/\3 \4\:\5/'` -yyjjjhhmm=`date +%y%j%H%M -d "${datestr}"` - -# Generate the ATCFNAME for this member -#ATCFNAME=`echo ${ATCFNAME} | sed 's/NN/${MEMBER_ID}/'` -ATCFNAME=`echo ${ATCFNAME} | sed "s/NN/${MEMBER_ID}/"` - -FCST_TIME=${T} - -# Print run parameters -${ECHO} -${ECHO} "nclfimalldiff.ksh started at `${DATE}`" -${ECHO} -${ECHO} " GLVL=${GLVL}" -${ECHO} " NVL=${NVL}" -${ECHO} " PES=${PES}" -${ECHO} " FCST_TIME=${FCST_TIME}" -${ECHO} " ISDIR=${ISDIR}" -${ECHO} " NCL_ROOT=${NCL_ROOT}" -${ECHO} " MODL=${MODL}" -${ECHO} " NCL_HOME=${NCL_HOME}" -${ECHO} - -# Set up the work directory and cd into it -workdir=${FIM_HOME}/FIMrun/fim_${GLVL}_${NVL}_${PES}_${yyyymmddhhmm}/ncldiff_${MEMBER_ID}/${GRID_NAME}/${ISDIR}_${FCST_TIME} -${RM} -rf ${workdir} -${MKDIR} -p ${workdir} -cd ${workdir} - -# Link to input file -# subtrack FIM - FIMX -${LN} -s ${FIM_HOME_NO_X}/FIMrun/fim_${GLVL}_${NVL}_${PES_NO_X}_${yyyymmddhhmm}/post_${MEMBER_ID}/${GRID_NAME}/${ISDIR}/grib1/${yyjjjhhmm}0${FCST_TIME} fim.grb -${ECHO} "fim.grb" > arw_file.txt -${LN} -s ${FIM_HOME}/FIMrun/fim_${GLVL}_${NVL}_${PES}_${yyyymmddhhmm}/post_${MEMBER_ID}/${GRID_NAME}/${ISDIR}/grib1/${yyjjjhhmm}0${FCST_TIME} fim2.grb -${ECHO} "fim2.grb" > arw_file2.txt -# ${ECHO} "${MODL}" > modl.txt - -# Setup domain file -${ECHO} ${GRID_NAME} > domain.txt - -# Link to FIMX tracker file -if [ -s ${FIM_HOME}/FIMrun/fim_${GLVL}_${NVL}_${PES}_${yyyymmddhhmm}/tracker_${MEMBER_ID}/${T}/track.${yyyymmddhhmm}.${ATCFNAME} ]; then - ${CAT} ${FIM_HOME}/FIMrun/fim_${GLVL}_${NVL}_${PES}_${yyyymmddhhmm}/tracker_${MEMBER_ID}/${T}/track.${yyyymmddhhmm}.${ATCFNAME} | ${SED} 's/\*\*\*/ 0/' > ./track.${yyyymmddhhmm} - ${ECHO} ./track.${yyyymmddhhmm} > track_file.txt -fi - -# Link to FIM tracker file -if [ -s ${FIM_HOME_NO_X}/FIMrun/fim_${GLVL}_${NVL}_${PES_NO_X}_${yyyymmddhhmm}/tracker_${MEMBER_ID}/${T}/track.${yyyymmddhhmm}.${ATCFNAME} ]; then - ${CAT} ${FIM_HOME_NO_X}/FIMrun/fim_${GLVL}_${NVL}_${PES_NO_X}_${yyyymmddhhmm}/tracker_${MEMBER_ID}/${T}/track.${yyyymmddhhmm}.${ATCFNAME} | ${SED} 's/\*\*\*/ 0/' > ./track2.${yyyymmddhhmm} - ${ECHO} ./track2.${yyyymmddhhmm} > track_file2.txt -fi - -if [ "${ISDIR}" == "NAT" ]; then - - set -A ncgms sfc_temp \ - ua_wind \ - ua_wmag \ - sfc_pwtr \ - sfc_mslp \ - 500_temp \ - 700_temp \ - 850_temp \ - 925_temp \ - 500_hgt \ - ua_rh \ - ua_rh8 \ - ua_vort \ - sfc_shtfl \ - sfc_lhtfl \ - 2m_temp \ - 2ds_temp \ - 2m_dewp \ - 10m_wind \ - sfc_totp \ - sfc_acp \ - sfc_acpcp \ - sfc_weasd \ - ua_ceil \ - ua_ctop - - set -A pngs sfc_temp.png \ - ua_wind-0.png \ - ua_wind-1.png \ - ua_wmag-0.png \ - ua_wmag-1.png \ - sfc_pwtr.png \ - sfc_mslp.png \ - 500_temp.png \ - 700_temp.png \ - 850_temp.png \ - 925_temp.png \ - 500_hgt.png \ - ua_rh.png \ - ua_rh8.png \ - ua_vort.png \ - sfc_shtfl.png \ - sfc_lhtfl.png \ - 2m_temp.png \ - 2ds_temp.png \ - 2m_dewp.png \ - 10m_wind.png \ - sfc_totp.png \ - sfc_acp.png \ - sfc_acpcp.png \ - sfc_weasd.png \ - ua_ceil.png \ - ua_ctop.png - -# set -A monpngs montage.png - - set -A webnames temp_sfc \ - wind_850 \ - wind_250 \ - wmag_850 \ - wmag_250 \ - pwtr_sfc \ - mslp_sfc \ - temp_500 \ - temp_700 \ - temp_850 \ - temp_925 \ - hgt_500 \ - rh_500 \ - rh_850 \ - vort_500 \ - shtfl_sfc \ - lhtfl_sfc \ - temp_2m \ - temp_2ds \ - dewp_2m \ - wind_10m \ - totp_sfc \ - 3hap_sfc \ - acpcp_sfc \ - weasd_sfc \ - ceil \ - ctop - -# set -A webmon montage - -fi - -ncl_error=0 - -# Run the NCL scripts for each plot -i=0 -while [ ${i} -lt ${#ncgms[@]} ]; do - - plot=${ncgms[${i}]} - ${ECHO} "Starting fim_${plot}.ncl at `${DATE}`" - ${NCL} < ${NCL_ROOT}/fim_${plot}.ncl - error=$? - if [ ${error} -ne 0 ]; then - ${ECHO} "ERROR: ${plot} crashed! Exit status=${error}" - ncl_error=${error} - fi - ${ECHO} "Finished fim_${plot}.ncl at `${DATE}`" - - (( i=i + 1 )) - -done - -# Run ctrans on all the .ncgm files to translate them into Sun Raster files -# NOTE: ctrans ONLY works for 32-bit versions of NCL -i=0 -while [ ${i} -lt ${#ncgms[@]} ]; do - - plot=${ncgms[${i}]} - ${ECHO} "Starting ctrans for ${plot}.ncgm at `${DATE}`" - - # normal image - ${CTRANS} -d sun ${plot}.ncgm -resolution 1132x906 > ${plot}.ras - error=$? - if [ ${error} -ne 0 ]; then - ${ECHO} "ERROR: ctrans ${plot}.ncgm crashed! Exit status=${error}" - ncl_error=${error} - fi - -# if [ "${ISDIR}" == "NAT" ]; then -# -# # montage image -# ${CTRANS} -d sun ${plot}.ncgm -resolution 2176x1360 > ${plot}_mon.ras -# error=$? -# if [ ${error} -ne 0 ]; then -# ${ECHO} "ERROR: ctrans ${plot}.ncgm crashed! Exit status=${error}" -# ncl_error=${error} -# fi -# ${CONVERT} -trim -border 30x12 -bordercolor black ${plot}_mon.ras ${plot}_mon.ras -# error=$? -# if [ ${error} -ne 0 ]; then -# ${ECHO} "ERROR: convert ${plot}_mon.ras crashed! Exit status=${error}" -# ncl_error=${error} -# fi -# -# fi - - ${ECHO} "Finished ctrans for ${plot}.ncgm at `${DATE}`" - - (( i=i + 1 )) - -done - -# Convert the .ras files into .png files -i=0 -while [ ${i} -lt ${#ncgms[@]} ]; do - - plot=${ncgms[${i}]} - ${ECHO} "Starting convert for ${plot}.ras at `${DATE}`" - - # normal image - ${CONVERT} -colors 128 -trim -border 25x25 -bordercolor black ${plot}.ras ${plot}.png - error=$? - if [ ${error} -ne 0 ]; then - ${ECHO} "ERROR: convert ${plot}.ras crashed! Exit status=${error}" - ncl_error=${error} - fi - -# if [ "${ISDIR}" == "NAT" ]; then -# # montage image -# ${CONVERT} ${plot}_mon.ras ${plot}_mon.png -# error=$? -# if [ ${error} -ne 0 ]; then -# ${ECHO} "ERROR: convert ${plot}_mon.ras crashed! Exit status=${error}" -# ncl_error=${error} -# fi -# fi - - ${ECHO} "Finished convert for ${plot}.ras at `${DATE}`" - - (( i=i + 1 )) - -done - -#if [ "${ISDIR}" == "NAT" ]; then -# -# # put together the montage images -# # -geometry formerly 1240x775+20+1 -# ${MONTAGE} ua_wind_mon-1.png sfc_pwtr_mon.png ua_temp_mon-0.png sfc_totp_mon.png -tile 2x2 -geometry 1240x775+21+4 -background black montage.png -# error=$? -# if [ ${error} -ne 0 ]; then -# ${ECHO} "ERROR: montage crashed! Exit status=${error}" -# ncl_error=${error} -# fi -# -#fi - -# Copy png files to their proper names -i=0 -while [ ${i} -lt ${#pngs[@]} ]; do - pngfile=${pngs[${i}]} - webfile=${FIM_HOME}/FIMrun/fim_${GLVL}_${NVL}_${PES}_${yyyymmddhhmm}/ncldiff_${MEMBER_ID}/${GRID_NAME}/${webnames[${i}]}_f${FCST_TIME}.png - ${MV} ${pngfile} ${webfile} - (( i=i + 1 )) -done - -#if [ "${ISDIR}" == "NAT" ]; then -# -# # Copy montage files to their proper names -# i=0 -# while [ ${i} -lt ${#monpngs[@]} ]; do -# pngfile=${monpngs[${i}]} -# webfile=${FIM_HOME}/FIMrun/fim_${GLVL}_${NVL}_${PES}_${yyyymmddhhmm}/ncldiff_${MEMBER_ID}/${GRID_NAME}/${webmon[${i}]}_f${FCST_TIME}.png -# ${MV} ${pngfile} ${webfile} -# (( i=i + 1 )) -# done -# -#fi - -# Remove the workdir -cd ../ -${RM} -rf ${workdir} - -# Hack to prevent errors for analysis file from crashing the whole thing -if [ ${FCST_TIME} -eq 0 ]; then - ncl_error=0 -fi - -${ECHO} "nclfimx.ksh completed at `${DATE}`" - -exit ${ncl_error} diff --git a/src/fim/FIMrun/batchTemplate-ncldiff-new b/src/fim/FIMrun/batchTemplate-ncldiff-new deleted file mode 100755 index 1bd01e5..0000000 --- a/src/fim/FIMrun/batchTemplate-ncldiff-new +++ /dev/null @@ -1,413 +0,0 @@ -#!/bin/ksh -l -#dis -#dis Open Source License/Disclaimer, Forecast Systems Laboratory -#dis NOAA/OAR/FSL, 325 Broadway Boulder, CO 80305 -#dis -#dis This software is distributed under the Open Source Definition, -#dis which may be found at http://www.opensource.org/osd.html. -#dis -#dis In particular, redistribution and use in source and binary forms, -#dis with or without modification, are permitted provided that the -#dis following conditions are met: -#dis -#dis - Redistributions of source code must retain this notice, this -#dis list of conditions and the following disclaimer. -#dis -#dis - Redistributions in binary form must provide access to this -#dis notice, this list of conditions and the following disclaimer, and -#dis the underlying source code. -#dis -#dis - All modifications to this software must be clearly documented, -#dis and are solely the responsibility of the agent making the -#dis modifications. -#dis -#dis - If significant modifications or enhancements are made to this -#dis software, the FSL Software Policy Manager -#dis (softwaremgr@fsl.noaa.gov) should be notified. -#dis -#dis THIS SOFTWARE AND ITS DOCUMENTATION ARE IN THE PUBLIC DOMAIN -#dis AND ARE FURNISHED "AS IS." THE AUTHORS, THE UNITED STATES -#dis GOVERNMENT, ITS INSTRUMENTALITIES, OFFICERS, EMPLOYEES, AND -#dis AGENTS MAKE NO WARRANTY, EXPRESS OR IMPLIED, AS TO THE USEFULNESS -#dis OF THE SOFTWARE AND DOCUMENTATION FOR ANY PURPOSE. THEY ASSUME -#dis NO RESPONSIBILITY (1) FOR THE USE OF THE SOFTWARE AND -#dis DOCUMENTATION; OR (2) TO PROVIDE TECHNICAL SUPPORT TO USERS. -#dis -#dis - -########################################################################## -# -#Script Name: ncl.ksh -# -# Author: Christopher Harrop -# Forecast Systems Laboratory -# 325 Broadway R/FST -# Boulder, CO. 80305 -# -# Released: 10/30/2003 -# Version: 1.0 -# Changes: None -# -# Purpose: This script generates NCL graphics from wrf output. -# -# EXE_ROOT = The full path of the ncl executables -# MOAD_DATAROOT = Top level directory of wrf output and -# configuration data. -# START_TIME = The cycle time to use for the initial time. -# If not set, the system clock is used. -# FCST_TIME = The two-digit forecast that is to be ncled -# -# A short and simple "control" script could be written to call this script -# or to submit this script to a batch queueing system. Such a "control" -# script could also be used to set the above environment variables as -# appropriate for a particular experiment. Batch queueing options can -# be specified on the command line or as directives at the top of this -# script. A set of default batch queueing directives is provided. -# -########################################################################## - -# Set the SGE queueing options -#$ -S /bin/ksh -#$ -pe serial 1 -#$ -l h_rt=1:00:00 -#$ -N ncl_rr -#$ -j y -#$ -V - -# Make sure we are using GMT time zone for time computations -export TZ="GMT" -export MODL=${MODL} -export NCL_HOME=${NCL_HOME} - -# Execute module command to use newest version of NCL -module switch ncarg ncl - -# Set up paths to shell commands -LS=/bin/ls -LN=/bin/ln -RM=/bin/rm -MKDIR=/bin/mkdir -CP=/bin/cp -MV=/bin/mv -ECHO=/bin/echo -CAT=/bin/cat -GREP=/bin/grep -CUT=/bin/cut -AWK="/bin/gawk --posix" -SED=/bin/sed -DATE=/bin/date -BC=/usr/bin/bc -#NCL=${NCARG_ROOT}/bin/ncl -#NCL=/misc/whome/wrfruc/ncl-4.3.1/bin/ncl -NCL=ncl -CTRANS=/misc/whome/dtcrt/CT2007/ncl-4.3.0_32/bin/ctrans -PS2PDF=/usr/bin/ps2pdf -CONVERT=/usr/bin/convert -#CONVERT=/whome/harrop/ImageMagick/bin/convert -MONTAGE=/usr/bin/montage -#MONTAGE=/whome/harrop/ImageMagick/bin/montage -PATH=${NCARG_ROOT}/bin:${PATH} - -#. /work/01033/harrop/jettools.sh - -# Set ID -if [ ! "${ID}" ]; then - ID="" -fi - -# Set ISDIR -if [ ${IS} -eq 1 ]; then - ISDIR="NAT" -elif [ ${IS} -eq 2 ]; then - ISDIR="PRS" -else - echo "Unsupported vertical coordinate option: ${IS}" - exit 1 -fi - -# Location of NCL graphics scripts -#NCL_ROOT=${FIM_HOME}/FIMwfm/ncl/fimalldiff - -typeset -Z3 FCST_TIME - -# Get yyjjjHHMM -datestr=`echo ${yyyymmddhhmm} | sed 's/^\([0-9]\{4\}\)\([0-9]\{2\}\)\([0-9]\{2\}\)\([0-9]\{2\}\)\([0-9]\{2\}\)/\1\/\2\/\3 \4\:\5/'` -yyjjjhhmm=`date +%y%j%H%M -d "${datestr}"` - -# Generate the ATCFNAME for this member -#ATCFNAME=`echo ${ATCFNAME} | sed 's/NN/${MEMBER_ID}/'` -ATCFNAME=`echo ${ATCFNAME} | sed "s/NN/${MEMBER_ID}/"` - -FCST_TIME=${T} - -# Print run parameters -${ECHO} -${ECHO} "nclfimalldiff.ksh started at `${DATE}`" -${ECHO} -${ECHO} " GLVL=${GLVL}" -${ECHO} " NVL=${NVL}" -${ECHO} " PES=${PES}" -${ECHO} " FCST_TIME=${FCST_TIME}" -${ECHO} " ISDIR=${ISDIR}" -${ECHO} " NCL_ROOT=${NCL_ROOT}" -${ECHO} " MODL=${MODL}" -${ECHO} " NCL_HOME=${NCL_HOME}" -${ECHO} - -# Set up the work directory and cd into it -workdir=${FIM_HOME}/FIMrun/fim_${GLVL}_${NVL}_${PES}_${yyyymmddhhmm}/ncldiff_${MEMBER_ID}/${GRID_NAME}/${ISDIR}_${FCST_TIME} -${RM} -rf ${workdir} -${MKDIR} -p ${workdir} -cd ${workdir} - -# Link to input file -# subtrack FIM - FIMX -${LN} -s ${FIM_HOME_NO_X}/FIMrun/fim_${GLVL}_${NVL}_${PES_NO_X}_${yyyymmddhhmm}/post_${MEMBER_ID}/${GRID_NAME}/${ISDIR}/grib1/${yyjjjhhmm}0${FCST_TIME} fim.grb -${ECHO} "fim.grb" > arw_file.txt -${LN} -s ${FIM_HOME}/FIMrun/fim_${GLVL}_${NVL}_${PES}_${yyyymmddhhmm}/post_${MEMBER_ID}/${GRID_NAME}/${ISDIR}/grib1/${yyjjjhhmm}0${FCST_TIME} fim2.grb -${ECHO} "fim2.grb" > arw_file2.txt -# ${ECHO} "${MODL}" > modl.txt - -# Setup domain file -${ECHO} ${GRID_NAME} > domain.txt - -# Link to FIMX tracker file -if [ -s ${FIM_HOME}/FIMrun/fim_${GLVL}_${NVL}_${PES}_${yyyymmddhhmm}/tracker_${MEMBER_ID}/${T}/track.${yyyymmddhhmm}.${ATCFNAME} ]; then - ${CAT} ${FIM_HOME}/FIMrun/fim_${GLVL}_${NVL}_${PES}_${yyyymmddhhmm}/tracker_${MEMBER_ID}/${T}/track.${yyyymmddhhmm}.${ATCFNAME} | ${SED} 's/\*\*\*/ 0/' > ./track.${yyyymmddhhmm} - ${ECHO} ./track.${yyyymmddhhmm} > track_file.txt -fi - -# Link to FIM tracker file -if [ -s ${FIM_HOME_NO_X}/FIMrun/fim_${GLVL}_${NVL}_${PES_NO_X}_${yyyymmddhhmm}/tracker_${MEMBER_ID}/${T}/track.${yyyymmddhhmm}.${ATCFNAME} ]; then - ${CAT} ${FIM_HOME_NO_X}/FIMrun/fim_${GLVL}_${NVL}_${PES_NO_X}_${yyyymmddhhmm}/tracker_${MEMBER_ID}/${T}/track.${yyyymmddhhmm}.${ATCFNAME} | ${SED} 's/\*\*\*/ 0/' > ./track2.${yyyymmddhhmm} - ${ECHO} ./track2.${yyyymmddhhmm} > track_file2.txt -fi - -if [ "${ISDIR}" == "NAT" ]; then - - set -A ncgms sfc_temp \ - ua_wind \ - ua_wmag \ - sfc_pwtr \ - sfc_mslp \ - 500_temp \ - 700_temp \ - 850_temp \ - 925_temp \ - 500_hgt \ - ua_rh \ - ua_rh8 \ - ua_vort \ - sfc_shtfl \ - sfc_lhtfl \ - 2m_temp \ - 2ds_temp \ - 2m_dewp \ - 10m_wind \ - sfc_totp \ - sfc_acp \ - sfc_acpcp \ - sfc_weasd \ - ua_ceil \ - ua_ctop - - set -A pngs sfc_temp.png \ - ua_wind-0.png \ - ua_wind-1.png \ - ua_wmag-0.png \ - ua_wmag-1.png \ - sfc_pwtr.png \ - sfc_mslp.png \ - 500_temp.png \ - 700_temp.png \ - 850_temp.png \ - 925_temp.png \ - 500_hgt.png \ - ua_rh.png \ - ua_rh8.png \ - ua_vort.png \ - sfc_shtfl.png \ - sfc_lhtfl.png \ - 2m_temp.png \ - 2ds_temp.png \ - 2m_dewp.png \ - 10m_wind.png \ - sfc_totp.png \ - sfc_acp.png \ - sfc_acpcp.png \ - sfc_weasd.png \ - ua_ceil.png \ - ua_ctop.png - -# set -A monpngs montage.png - - set -A webnames temp_sfc \ - wind_850 \ - wind_250 \ - wmag_850 \ - wmag_250 \ - pwtr_sfc \ - mslp_sfc \ - temp_500 \ - temp_700 \ - temp_850 \ - temp_925 \ - hgt_500 \ - rh_500 \ - rh_850 \ - vort_500 \ - shtfl_sfc \ - lhtfl_sfc \ - temp_2m \ - temp_2ds \ - dewp_2m \ - wind_10m \ - totp_sfc \ - 3hap_sfc \ - acpcp_sfc \ - weasd_sfc \ - ceil \ - ctop - -# set -A webmon montage - -fi - -ncl_error=0 - -# Run the NCL scripts for each plot -i=0 -while [ ${i} -lt ${#ncgms[@]} ]; do - - plot=${ncgms[${i}]} - ${ECHO} "Starting fim_${plot}.ncl at `${DATE}`" - ${NCL} < ${NCL_ROOT}/fim_${plot}.ncl - error=$? - if [ ${error} -ne 0 ]; then - ${ECHO} "ERROR: ${plot} crashed! Exit status=${error}" - ncl_error=${error} - fi - ${ECHO} "Finished fim_${plot}.ncl at `${DATE}`" - - (( i=i + 1 )) - -done - -# Run ctrans on all the .ncgm files to translate them into Sun Raster files -# NOTE: ctrans ONLY works for 32-bit versions of NCL -i=0 -while [ ${i} -lt ${#ncgms[@]} ]; do - - plot=${ncgms[${i}]} - ${ECHO} "Starting ctrans for ${plot}.ncgm at `${DATE}`" - - # normal image - ${CTRANS} -d sun ${plot}.ncgm -resolution 1132x906 > ${plot}.ras - error=$? - if [ ${error} -ne 0 ]; then - ${ECHO} "ERROR: ctrans ${plot}.ncgm crashed! Exit status=${error}" - ncl_error=${error} - fi - -# if [ "${ISDIR}" == "NAT" ]; then -# -# # montage image -# ${CTRANS} -d sun ${plot}.ncgm -resolution 2176x1360 > ${plot}_mon.ras -# error=$? -# if [ ${error} -ne 0 ]; then -# ${ECHO} "ERROR: ctrans ${plot}.ncgm crashed! Exit status=${error}" -# ncl_error=${error} -# fi -# ${CONVERT} -trim -border 30x12 -bordercolor black ${plot}_mon.ras ${plot}_mon.ras -# error=$? -# if [ ${error} -ne 0 ]; then -# ${ECHO} "ERROR: convert ${plot}_mon.ras crashed! Exit status=${error}" -# ncl_error=${error} -# fi -# -# fi - - ${ECHO} "Finished ctrans for ${plot}.ncgm at `${DATE}`" - - (( i=i + 1 )) - -done - -# Convert the .ras files into .png files -i=0 -while [ ${i} -lt ${#ncgms[@]} ]; do - - plot=${ncgms[${i}]} - ${ECHO} "Starting convert for ${plot}.ras at `${DATE}`" - - # normal image - ${CONVERT} -colors 128 -trim -border 25x25 -bordercolor black ${plot}.ras ${plot}.png - error=$? - if [ ${error} -ne 0 ]; then - ${ECHO} "ERROR: convert ${plot}.ras crashed! Exit status=${error}" - ncl_error=${error} - fi - -# if [ "${ISDIR}" == "NAT" ]; then -# # montage image -# ${CONVERT} ${plot}_mon.ras ${plot}_mon.png -# error=$? -# if [ ${error} -ne 0 ]; then -# ${ECHO} "ERROR: convert ${plot}_mon.ras crashed! Exit status=${error}" -# ncl_error=${error} -# fi -# fi - - ${ECHO} "Finished convert for ${plot}.ras at `${DATE}`" - - (( i=i + 1 )) - -done - -#if [ "${ISDIR}" == "NAT" ]; then -# -# # put together the montage images -# # -geometry formerly 1240x775+20+1 -# ${MONTAGE} ua_wind_mon-1.png sfc_pwtr_mon.png ua_temp_mon-0.png sfc_totp_mon.png -tile 2x2 -geometry 1240x775+21+4 -background black montage.png -# error=$? -# if [ ${error} -ne 0 ]; then -# ${ECHO} "ERROR: montage crashed! Exit status=${error}" -# ncl_error=${error} -# fi -# -#fi - -# Copy png files to their proper names -i=0 -while [ ${i} -lt ${#pngs[@]} ]; do - pngfile=${pngs[${i}]} - webfile=${FIM_HOME}/FIMrun/fim_${GLVL}_${NVL}_${PES}_${yyyymmddhhmm}/ncldiff_${MEMBER_ID}/${GRID_NAME}/${webnames[${i}]}_f${FCST_TIME}.png - ${MV} ${pngfile} ${webfile} - (( i=i + 1 )) -done - -#if [ "${ISDIR}" == "NAT" ]; then -# -# # Copy montage files to their proper names -# i=0 -# while [ ${i} -lt ${#monpngs[@]} ]; do -# pngfile=${monpngs[${i}]} -# webfile=${FIM_HOME}/FIMrun/fim_${GLVL}_${NVL}_${PES}_${yyyymmddhhmm}/ncldiff_${MEMBER_ID}/${GRID_NAME}/${webmon[${i}]}_f${FCST_TIME}.png -# ${MV} ${pngfile} ${webfile} -# (( i=i + 1 )) -# done -# -#fi - -# Remove the workdir -cd ../ -${RM} -rf ${workdir} - -# Hack to prevent errors for analysis file from crashing the whole thing -if [ ${FCST_TIME} -eq 0 ]; then - ncl_error=0 -fi - -${ECHO} "nclfimx.ksh completed at `${DATE}`" - -exit ${ncl_error} diff --git a/src/fim/FIMrun/batchTemplate-pop b/src/fim/FIMrun/batchTemplate-pop deleted file mode 100755 index 76061dd..0000000 --- a/src/fim/FIMrun/batchTemplate-pop +++ /dev/null @@ -1,80 +0,0 @@ -#!/bin/ksh - -# Set ISDIR -if [ "$IS" -eq 1 ]; then - ISDIR="NAT" -elif [ "$IS" -eq 2 ]; then - ISDIR="PRS" -else - echo "Unsupported vertical coordinate option: $IS" - exit 1 -fi - -# Set the path to the run directory -workdir=${POST}/fim/${ISDIR}/grib1/pop_${T} - -# Move pre-existing workdir to a new name with a time stamp -if [ -d $workdir ]; then - timestamp=`/bin/ls -ld --time-style=+%Y%m%d%H%M%S $workdir | awk '{print $6}'` - /bin/mv $workdir $workdir.$timestamp -fi - -if [[ -z "$functions_sourced" ]] -then - test -n "$WFM" && prefix=$FIM_HOME/FIMrun || prefix=. - . $prefix/functions.ksh # Most function definitions can be found here. -fi - -# Create post dir, enter it and copy in needed files -mkdir -p $workdir -cd $workdir -cp $PREP/FIMnamelist . -cp $FIM_HOME/FIMwfm/fim_gribtable . -cp $SRCDIR/bin/pop . - -get_nl_value_unquoted $workdir/FIMnamelist ISOBARICnamelist isobaric_levels_file ISOBARIC_LEVELS_FILE - -if [ -f "$POST/$ISOBARIC_LEVELS_FILE" ]; then - cp $POST/$ISOBARIC_LEVELS_FILE . -else - echo "$POST/$ISOBARIC_LEVELS_FILE not found: aborting" - exit 1 -fi - -# Set variables -datestr=`echo $yyyymmddhhmm | sed 's/^\([0-9]\{4\}\)\([0-9]\{2\}\)\([0-9]\{2\}\)\([0-9]\{2\}\)\([0-9]\{2\}\)/\1\/\2\/\3 \4\:\5/'` -yyjjjhhmm=`date +%y%j%H%M -d "$datestr"` - -# Link files -(. $FIM_HOME/FIMrun/functions.ksh ; linksafe $PREP/glvl.dat; linksafe $PREP/icos_grid_info_level.dat) - -# Modify the namelist -nlh="$FIM_HOME/FIMwfm/xml/namelist/namelistHandler.rb" -$nlh FIMnamelist POSTnamelist datadir "'$FIM'" -$nlh FIMnamelist POSTnamelist delta_t $FCST_INTERVAL -$nlh FIMnamelist POSTnamelist is $IS -$nlh FIMnamelist POSTnamelist nsmooth_var "$SMOOTH_VAR" -$nlh FIMnamelist POSTnamelist t1 $T -$nlh FIMnamelist POSTnamelist t2 $T -$nlh FIMnamelist POSTnamelist var_list "$VAR_LIST" - -# Run pop -./pop # run pop in foreground -status=$? -if [ $status != 0 ]; then - echo "pop${GLVL}_${NVL} failed" - exit 1 -fi - -# Move the output to the output dir -filename=`printf "$POST/fim/$ISDIR/grib1/pop_$T/${yyjjjhhmm}%04d" $T` -mv $filename $POST/fim/$ISDIR/grib1 - -# Check to see if all the output made it to the output dir -filename=`printf "$POST/fim/${ISDIR}/grib1/${yyjjjhhmm}%04d" $T` -if [ ! -s "$filename" ]; then - echo "ERROR: Output file, '$filename', is missing or is empty!" - exit 1 -fi - -exit 0 diff --git a/src/fim/FIMrun/batchTemplate-post b/src/fim/FIMrun/batchTemplate-post deleted file mode 100755 index 9ea9001..0000000 --- a/src/fim/FIMrun/batchTemplate-post +++ /dev/null @@ -1,151 +0,0 @@ -#!/bin/ksh -v - -# Note: When run by Workflow Manager, this script's output can be found in -# FIMwfm/logs/pop. Also see FIMwfm/logs/workflow for general WFM messages. - -CONTEXT="batchTemplate-post" - -# Source functions.ksh if needed. - -if [[ -z "$functions_sourced" ]] -then - test -n "$WFM" && prefix=$FIM_HOME/FIMrun || prefix=. - . $prefix/functions.ksh # Most function definitions can be found here. -fi - -ksh_insist # Ensure that we are running in ksh93 - -# The fim output files produced by COMPARE_VAR-enabled runs cannot be (reliably) -# processed by pop, so don't try. - -if [[ "$COMPARE_VAR_ON" == ".true." ]] -then - print "COMPARE_VAR is enabled: skipping post..." - return 0 -fi - -# For WFM runs, enter the appropriate FIMrun directory. - -if [[ -n "$WFM" && -n "$FIM_HOME" ]] -then - cd $FIM_HOME/FIMrun || fail "Cannot cd to $FIM_HOME/FIMrun." -fi - -# Run batchTemplate-setup if it has not already been run. - -test -z "$batchTemplate_setup_ran" && xsource ./batchTemplate-setup - -# Run batchTemplate-FIMY_ENKF-files if appropriate. - -print $PWD | grep -v "/FIMYENS/" | grep -q "/FIMY/" && xsource ./batchTemplate-FIMY_ENKF-files - -# Enter the appropriate run directory (as defined by batchTemplate-setup). - -FIMRUN="$PWD" -cd $DIR || fail "Cannot cd to $DIR." - -# Make the post directory. For WFM runs, the post directory should already -# exist except for the first incremental batch and mkdir's -p option exits -# with success if the directory already exists. - -mkdir -p $POST || fail "Cannot make directory $POST." - -# Copy namelist from the appropriate fim directory. - -if [[ -d "$FIMDIR" ]] -then - cp $fimnamelist $POST/$NLFILE || \ - fail "Cannot copy $fimnamelist -> $POST/$NLFILE." -else - cp $FIM/$NLFILE $POST || fail "Cannot copy $FIM/$NLFILE -> $POST." -fi - -cp $fimgribtable $POST/fim_gribtable || \ - fail "Cannot copy $fimgribtable $POST/fim_gribtable." - -cp $reduceinput $POST/REDUCEinput || \ - fail "Cannot copy $reduceinput $POST/REDUCEinput." - -# Enter the post directory. - -cd $POST || fail "Cannot cd to $POST." - -get_nl_value_unquoted $fimnamelist ISOBARICnamelist isobaric_levels_file ISOBARIC_LEVELS_FILE -cp $PREP/$ISOBARIC_LEVELS_FILE $POST/$ISOBARIC_LEVELS_FILE || \ - fail "Cannot copy $ISOBARIC_LEVELS_FILE $POST/$ISOBARIC_LEVELS_FILE." - -# Link files. - -test -f pop || linksafe $BINDIR/pop -test -f reduce || linksafe $BINDIR/reduce -test -f "$INFO_FILE" || linksafe $PREP/$INFO_FILE - -$BINDIR/get_gribout | grep "gribout:" | sed 's/^.*://' | read GRIBOUT || \ - fail "Could not get gribout." - -$BINDIR/get_gribout | grep "fimout:" | sed 's/^.*://' | read FIMOUT || \ - fail "Could not get fimout." - - -# For WFM runs, for now just run as always, regardless of the value of gribout. -# Will soon want to modify post/postall for WFM case to not run pop - -if [[ -n "$WFM" ]] -then -# do WFM post sequence - if [[ "$GRIBOUT" == "TRUE" ]] - then - FIM_POST_GRIB1_DIR=$POST/fim/NAT/grib1 - if [[ ! -d "$FIM_POST_GRIB1_DIR" ]] - then - fail "$FIM_POST_GRIB1_DIR should have been created by batchTemplate-setup - NOT HERE!!!!" - fi - # not fimy_enkf - print $PWD | grep -v "/FIMYENS/" | grep -q "/FIMY/" - if [[ $? -eq 1 ]]; then - - # mv grib files to post directory - T1=$(print $T1 | sed 's/^0\{1,2\}\(.*\)/\1/') - T2=$(print $T2 | sed 's/^0\{1,2\}\(.*\)/\1/') - test -z "$T1" && T1=0 - test -z "$T2" && T2=0 - print "T1=$T1" - print "T2=$T2" - t=$T1 - #Get yyjjjHHMM - datestr=$(print ${yyyymmddhhmm} | sed 's/^\([0-9]\{4\}\)\([0-9]\{2\}\)\([0-9]\{2\}\)\([0-9]\{2\}\)\([0-9]\{2\}\)/\1\/\2\/\3 \4\:\5/') - yyjjjhhmm=$(date +%y%j%H%M -d "${datestr}") - while [ $t -le $T2 ]; do - # Move the output to the post dir - filename=$(printf "${yyjjjhhmm}%04d" $t) - print "file to be moved to post: $filename" - mv $DIR/fim_$MEMBER_ID/$filename $FIM_POST_GRIB1_DIR/$filename - (( t=t+${FCST_INTERVAL} )) - done - fi - fi # not FIMY_ENKF - if [[ "$FIMOUT" == "TRUE" || "$GRIBOUT" == "TRUE" ]] - then - xsource $FIM_HOME/FIMrun/batchTemplate-postall - else - fail "cannot run batchTemplate-postall when GRIBOUT == FALSE and FIMOUT == FALSE" - fi -else -# qsubfim case: if gribout was set, just link the grib files. -# Otherwise, run pop as before to create the grib files. - if [[ "$GRIBOUT" == "TRUE" ]] - then - ln -s ../fim/[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9] . - elif [[ "$FIMOUT" == "TRUE" ]] - then - ./pop || fail "pop failed." - else - fail "cannot run pop when FIMOUT == FALSE." - fi -fi - -cd $FIMRUN || fail "Cannot cd to $FIMRUN." - -print "\npop finished\n" - -return 0 diff --git a/src/fim/FIMrun/batchTemplate-postall b/src/fim/FIMrun/batchTemplate-postall deleted file mode 100755 index 52f0d3d..0000000 --- a/src/fim/FIMrun/batchTemplate-postall +++ /dev/null @@ -1,333 +0,0 @@ -#!/bin/ksh - -CONTEXT="batchTemplate-postall" - -#Check SGE system variables for core count -if [ "${NCORES}x" == "x" ]; then - if [ "${NSLOTS}x" == "x" ]; then - #Check PBS system variables for core count - if [[ -n "$PBS_NNODES" ]]; then - NCORES=$PBS_NNODES - else - #Otherwise, assume 4 cores as the greatest common factor - echo "ERROR: Cannot determine how many cores are available on this node" - NCORES=4 - fi - else - NCORES=${NSLOTS} - fi -fi -echo "Assuming there are $NCORES cores available on this node" - -$BINDIR/get_gribout | grep "gribout:" | sed 's/^.*://' | read GRIBOUT || \ - fail "Could not get GRIBOUT." - -# Set these variables from FIMnamelist if they are not already in the -# environment. -nlh="$FIM_HOME/FIMwfm/xml/namelist/namelistHandler.rb" -test -z "$IS" && IS=$($nlh FIMnamelist POSTnamelist is) -test -z "$SMOOTH_VAR" && SMOOTH_VAR=$($nlh FIMnamelist POSTnamelist nsmooth_var) -test -z "$VAR_LIST" && VAR_LIST=$($nlh FIMnamelist POSTnamelist var_list) - -# Export variables -export GLVL IS NVL PES SMOOTH_VAR SRCDIR VAR_LIST - -# Build array of grid names and specs to process -grididx=1 -for grid in ${GRID_NAMES}; do - grid_names[${grididx}]=${grid} - grid_specs[${grididx}]=`echo -n ${GRID_SPECS} | cut -d: -f ${grididx}` - echo "${grid_names[${grididx}]} ${grid_specs[${grididx}]}" - (( grididx=grididx+1 )) -done - -# Build array of cases to process out of grid names, grid specs, and the forecast time range -T1=`echo $T1 | sed 's/^0\{1,2\}\(.*\)/\1/'` -T2=`echo $T2 | sed 's/^0\{1,2\}\(.*\)/\1/'` -test -z "$T1" && T1=0 -test -z "$T2" && T2=0 -echo "T1=$T1" -echo "T2=$T2" -t=$T1 -caseidx=0 -while [ $t -le $T2 ]; do - echo "Generating cases for forecast time ${t}" - grididx=1 - while [ ${grididx} -le ${#grid_names[*]} ]; do - echo " Domain ${grid_names[${grididx}]}:${grid_specs[${grididx}]}" - case="$t:${grid_names[${grididx}]}:${grid_specs[${grididx}]}" - cases[${caseidx}]=$case - (( caseidx=caseidx+1 )) - (( grididx=grididx+1 )) - done - (( t=t+${FCST_INTERVAL} )) -done - -# Run all the pops -n=0 -caseidx=0 -unset case_pids -unset case_logfiles - -# User can choose to skip pop (e.g. when rerunning only part of postall) -get_nl_value_unquoted $fimnamelist WFMnamelist run_pop RUN_POP -if [[ "$RUN_POP" != "F" ]] # T or undefined -then - while [ $caseidx -lt ${#cases[*]} ]; do # Loop over all cases - jobs=0 - startidx=$caseidx - (( endidx=$startidx -1 )) - # Fork a batch of cases off in the background - # Batch size is equal to the number of cores on the node - while [ $caseidx -lt ${#cases[*]} -a $jobs -lt $NCORES ]; do - - export T=`echo ${cases[${caseidx}]} | cut -d: -f 1` - export GRID_NAME=`echo -n ${cases[${caseidx}]} | cut -d: -f 2` - export GRID_SPEC=`echo -n ${cases[${caseidx}]} | cut -d: -f 3` - - # Run pop here - if [[ "${GRID_NAME}" == "fim" && "${GRIBOUT}" == "FALSE" ]]; then - echo "$jobs: Running pop: $T:$GRID_NAME:$GRID_SPEC" - # Export variables provided by batchTemplate-setup and needed by batchTemplate-pop - export FIM POST PREP - ${FIM_HOME}/FIMrun/batchTemplate-pop > ${FIM_HOME}/FIMwfm/log/pop/pop_NAT_${MEMBER_ID}_${T}_${yyyymmddhhmm}.log 2>&1 & - status=$? - if [ ${status} -ne 0 ]; then - echo "pop FIM failed! Exit status=${status}" - echo "See log at ${FIM_HOME}/FIMwfm/log/pop/pop_NAT_${MEMBER_ID}_${T}_${yyyymmddhhmm}.log " - return ${status} - fi - case_pids[${caseidx}]=$! - case_logfiles[${caseidx}]=${FIM_HOME}/FIMwfm/log/pop/pop_NAT_${MEMBER_ID}_${T}_${yyyymmddhhmm}.log - (( jobs=jobs+1 )) - else - case_pids[${caseidx}]=0 - fi - (( caseidx=caseidx+1 )) - (( endidx=endidx+1 )) - done - (( n=n+1 )) - - # Wait for the cases to finish before doing another batch - waitidx=$startidx - while [ $waitidx -le $endidx ]; do - if [ ${case_pids[${waitidx}]} -ne 0 ]; then - echo "Waiting for pop ${cases[${waitidx}]} pid=${case_pids[${waitidx}]}..." - wait ${case_pids[${waitidx}]} - status=$? - if [ ${status} -ne 0 ]; then - echo "pop ${cases[${waitidx}]} failed! Exit status=${status}" - echo "See log at ${case_logfiles[${waitidx}]}" - return ${status} - fi - fi - (( waitidx=waitidx+1 )) - done - done -fi - -get_nl_value_unquoted $fimnamelist WFMnamelist run_interp RUN_INTERP -if [[ "$RUN_INTERP" != "F" ]] # T or undefined -then - # Run all the interps - n=0 - caseidx=0 - unset case_pids - unset case_logfiles - while [ $caseidx -lt ${#cases[*]} ]; do # Loop over all cases - jobs=0 - startidx=$caseidx - (( endidx=$startidx -1 )) - # Fork a batch of cases off in the background - # Batch size is equal to the number of cores on the node - while [ $caseidx -lt ${#cases[*]} -a $jobs -lt $NCORES ]; do - - export T=`echo ${cases[${caseidx}]} | cut -d: -f 1` - export GRID_NAME=`echo -n ${cases[${caseidx}]} | cut -d: -f 2` - export GRID_SPEC=`echo -n ${cases[${caseidx}]} | cut -d: -f 3` - - # Run interp here - if [ "${GRID_NAME}" != "fim" ]; then - echo "$jobs: Running interp: $T:$GRID_NAME:$GRID_SPEC" - ${FIM_HOME}/FIMrun/batchTemplate-interp > ${FIM_HOME}/FIMwfm/log/interp/interp_NAT_${MEMBER_ID}_${GRID_NAME}_${T}_${yyyymmddhhmm}.log 2>&1 & - case_pids[${caseidx}]=$! - case_logfiles[${caseidx}]=${FIM_HOME}/FIMwfm/log/interp/interp_NAT_${MEMBER_ID}_${GRID_NAME}_${T}_${yyyymmddhhmm}.log - (( jobs=jobs+1 )) - else - case_pids[${caseidx}]=0 - fi - (( caseidx=caseidx+1 )) - (( endidx=endidx+1 )) - done - (( n=n+1 )) - - # Wait for the cases to finish before doing another batch - waitidx=$startidx - while [ $waitidx -le $endidx ]; do - if [ ${case_pids[${waitidx}]} -ne 0 ]; then - echo "Waiting for interp ${cases[${waitidx}]} pid=${case_pids[${waitidx}]}..." - wait ${case_pids[${waitidx}]} - status=$? - if [ ${status} -ne 0 ]; then - echo "Interp ${cases[${waitidx}]} failed! Exit status=${status}" - echo "See log at ${case_logfiles[${waitidx}]}" - return ${status} - fi - fi - (( waitidx=waitidx+1 )) - done - done -fi - -get_nl_value_unquoted $fimnamelist WFMnamelist run_grib12 RUN_GRIB12 -if [[ "$RUN_GRIB12" != "F" ]] # T or undefined -then - # Run all the grib12s - n=0 - caseidx=0 - unset case_pids - unset case_logfiles - while [ $caseidx -lt ${#cases[*]} ]; do # Loop over all cases - jobs=0 - startidx=$caseidx - (( endidx=$startidx -1 )) - # Fork a batch of cases off in the background - # Batch size is equal to the number of cores on the node - while [ $caseidx -lt ${#cases[*]} -a $jobs -lt $NCORES ]; do - - export T=`echo ${cases[${caseidx}]} | cut -d: -f 1` - export GRID_NAME=`echo -n ${cases[${caseidx}]} | cut -d: -f 2` - export GRID_SPEC=`echo -n ${cases[${caseidx}]} | cut -d: -f 3` - - # Run grib12 here - echo "$jobs: Running grib12: $T:$GRID_NAME:$GRID_SPEC" - ${FIM_HOME}/FIMrun/batchTemplate-grib12 > ${FIM_HOME}/FIMwfm/log/grib12/grib12_NAT_${MEMBER_ID}_${GRID_NAME}_${T}_${yyyymmddhhmm}.log 2>&1 & - case_pids[${caseidx}]=$! - case_logfiles[${caseidx}]=${FIM_HOME}/FIMwfm/log/grib12/grib12_NAT_${MEMBER_ID}_${GRID_NAME}_${T}_${yyyymmddhhmm}.log - (( jobs=jobs+1 )) - (( caseidx=caseidx+1 )) - (( endidx=endidx+1 )) - done - (( n=n+1 )) - - # Wait for the cases to finish before doing another batch - waitidx=$startidx - while [ $waitidx -le $endidx ]; do - if [ ${case_pids[${waitidx}]} -ne 0 ]; then - echo "Waiting for grib12 ${cases[${waitidx}]} pid=${case_pids[${waitidx}]}..." - wait ${case_pids[${waitidx}]} - status=$? - if [ ${status} -ne 0 ]; then - echo "Grib12 ${cases[${waitidx}]} failed! Exit status=${status}" - echo "See log at ${case_logfiles[${waitidx}]}" - return ${status} - fi - fi - (( waitidx=waitidx+1 )) - done - done -fi - -get_nl_value_unquoted $fimnamelist WFMnamelist run_tracker RUN_TRACKER -if [[ "$RUN_TRACKER" != "F" ]] # T or undefined -then - # Run all the trackers - n=0 - caseidx=0 - unset case_pids - unset case_logfiles - while [ $caseidx -lt ${#cases[*]} ]; do # Loop over all cases - jobs=0 - startidx=$caseidx - (( endidx=$startidx -1 )) - # Fork a batch of cases off in the background - # Batch size is equal to the number of cores on the node - while [ $caseidx -lt ${#cases[*]} -a $jobs -lt $NCORES ]; do - - export T=`echo ${cases[${caseidx}]} | cut -d: -f 1` - export GRID_NAME=`echo -n ${cases[${caseidx}]} | cut -d: -f 2` - export GRID_SPEC=`echo -n ${cases[${caseidx}]} | cut -d: -f 3` - - # Run tracker here - if [ "${GRID_NAME}" == "fim" ]; then - echo "$jobs: Running tracker: $T:$GRID_NAME:$GRID_SPEC" - ${FIM_HOME}/FIMrun/batchTemplate-tracker > ${FIM_HOME}/FIMwfm/log/tracker/tracker_NAT_${MEMBER_ID}_${T}_${yyyymmddhhmm}.log 2>&1 & - case_pids[${caseidx}]=$! - case_logfiles[${caseidx}]=${FIM_HOME}/FIMwfm/log/tracker/tracker_NAT_${MEMBER_ID}_${T}_${yyyymmddhhmm}.log - (( jobs=jobs+1 )) - else - case_pids[${caseidx}]=0 - fi - (( caseidx=caseidx+1 )) - (( endidx=endidx+1 )) - done - (( n=n+1 )) - - # Wait for the cases to finish before doing another batch - waitidx=$startidx - while [ $waitidx -le $endidx ]; do - if [ ${case_pids[${waitidx}]} -ne 0 ]; then - echo "Waiting for tracker ${cases[${waitidx}]} pid=${case_pids[${waitidx}]}..." - wait ${case_pids[${waitidx}]} - status=$? - if [ ${status} -ne 0 ]; then - echo "tracker ${cases[${waitidx}]} failed! Exit status=${status}" - echo "See log at ${case_logfiles[${waitidx}]}" - return ${status} - fi - fi - (( waitidx=waitidx+1 )) - done - done -fi - -get_nl_value_unquoted $fimnamelist WFMnamelist run_ncl RUN_NCL -if [[ "$RUN_NCL" != "F" ]] #RUN_NCL=T or RUN_NCL undefined -then - # Run all the ncls - n=0 - caseidx=0 - unset case_pids - unset case_logfiles - while [ $caseidx -lt ${#cases[*]} ]; do # Loop over all cases - jobs=0 - startidx=$caseidx - (( endidx=$startidx -1 )) - # Fork a batch of cases off in the background - # Batch size is equal to the number of cores on the node - while [ $caseidx -lt ${#cases[*]} -a $jobs -lt $NCORES ]; do - - export T=`echo ${cases[${caseidx}]} | cut -d: -f 1` - export GRID_NAME=`echo -n ${cases[${caseidx}]} | cut -d: -f 2` - export GRID_SPEC=`echo -n ${cases[${caseidx}]} | cut -d: -f 3` - - # Run ncl here - echo "$jobs: Running ncl: $T:$GRID_NAME:$GRID_SPEC" - ${FIM_HOME}/FIMrun/batchTemplate-ncl > ${FIM_HOME}/FIMwfm/log/ncl/ncl_NAT_${MEMBER_ID}_${GRID_NAME}_${T}_${yyyymmddhhmm}.log 2>&1 & - case_pids[${caseidx}]=$! - case_logfiles[${caseidx}]=${FIM_HOME}/FIMwfm/log/ncl/ncl_NAT_${MEMBER_ID}_${GRID_NAME}_${T}_${yyyymmddhhmm}.log - (( jobs=jobs+1 )) - (( caseidx=caseidx+1 )) - (( endidx=endidx+1 )) - done - (( n=n+1 )) - - # Wait for the cases to finish before doing another batch - waitidx=$startidx - while [ $waitidx -le $endidx ]; do - if [ ${case_pids[${waitidx}]} -ne 0 ]; then - echo "Waiting for ncl ${cases[${waitidx}]} pid=${case_pids[${waitidx}]}..." - wait ${case_pids[${waitidx}]} - status=$? - if [ ${status} -ne 0 ]; then - echo "Ncl ${cases[${waitidx}]} failed! Exit status=${status}" - echo "See log at ${case_logfiles[${waitidx}]}" - return ${status} - fi - fi - (( waitidx=waitidx+1 )) - done - done -fi - -return 0 diff --git a/src/fim/FIMrun/batchTemplate-postncldiff b/src/fim/FIMrun/batchTemplate-postncldiff deleted file mode 100755 index a6faf4b..0000000 --- a/src/fim/FIMrun/batchTemplate-postncldiff +++ /dev/null @@ -1,88 +0,0 @@ -#!/bin/ksh - -if [ "${NCORES}x" == "x" ]; then - if [ "${NSLOTS}x" == "x" ]; then - echo "ERROR: Cannot determine how many cores are available on this node" - exit 1 - else - NCORES=${NSLOTS} - fi -fi -echo "Assuming there are $NCORES cores available on this node" - -# Build array of grid names and specs to process -grididx=1 -for grid in ${GRID_NAMES}; do - grid_names[${grididx}]=${grid} - grid_specs[${grididx}]=`echo -n ${GRID_SPECS} | cut -d: -f ${grididx}` - echo "${grid_names[${grididx}]} ${grid_specs[${grididx}]}" - (( grididx=grididx+1 )) -done - -# Build array of cases to process out of grid names, grid specs, and the forecast time range -T1=`echo $T1 | sed 's/^0\{1,2\}\(.*\)/\1/'` -T2=`echo $T2 | sed 's/^0\{1,2\}\(.*\)/\1/'` -echo "T1=$T1" -echo "T2=$T2" -t=$T1 -caseidx=0 -while [ $t -le $T2 ]; do - echo "Generating cases for forecast time ${t}" - grididx=1 - while [ ${grididx} -le ${#grid_names[*]} ]; do - echo " Domain ${grid_names[${grididx}]}:${grid_specs[${grididx}]}" - case="$t:${grid_names[${grididx}]}:${grid_specs[${grididx}]}" - cases[${caseidx}]=$case - (( caseidx=caseidx+1 )) - (( grididx=grididx+1 )) - done - (( t=t+${FCST_INTERVAL} )) -done - -# Run all the ncl diffs -n=0 -caseidx=0 -unset case_pids -unset case_logfiles -while [ $caseidx -lt ${#cases[*]} ]; do # Loop over all cases - jobs=0 - startidx=$caseidx - (( endidx=$startidx -1 )) - # Fork a batch of cases off in the background - # Batch size is equal to the number of cores on the node - while [ $caseidx -lt ${#cases[*]} -a $jobs -lt $NCORES ]; do - - export T=`echo ${cases[${caseidx}]} | cut -d: -f 1` - export GRID_NAME=`echo -n ${cases[${caseidx}]} | cut -d: -f 2` - export GRID_SPEC=`echo -n ${cases[${caseidx}]} | cut -d: -f 3` - - # Run ncldiff here - echo "$jobs: Running ncldiff: $T:$GRID_NAME:$GRID_SPEC" - ${FIM_HOME}/FIMrun/batchTemplate-ncldiff > ${FIM_HOME}/FIMwfm/log/ncldiff/ncldiff_NAT_${MEMBER_ID}_${GRID_NAME}_${T}_${yyyymmddhhmm}.log 2>&1 & - case_pids[${caseidx}]=$! - case_logfiles[${caseidx}]=${FIM_HOME}/FIMwfm/log/ncldiff/ncldiff_NAT_${MEMBER_ID}_${GRID_NAME}_${T}_${yyyymmddhhmm}.log - (( jobs=jobs+1 )) - (( caseidx=caseidx+1 )) - (( endidx=endidx+1 )) - done - (( n=n+1 )) - - # Wait for the cases to finish before doing another batch - waitidx=$startidx - while [ $waitidx -le $endidx ]; do - if [ ${case_pids[${waitidx}]} -ne 0 ]; then - echo "Waiting for ncldiff ${cases[${waitidx}]} pid=${case_pids[${waitidx}]}..." - wait ${case_pids[${waitidx}]} - status=$? - if [ ${status} -ne 0 ]; then - echo "Ncldiff ${cases[${waitidx}]} failed! Exit status=${status}" - echo "See log at ${case_logfiles[${waitidx}]}" - exit ${status} - fi - fi - (( waitidx=waitidx+1 )) - done - -done - -exit 0 diff --git a/src/fim/FIMrun/batchTemplate-postncldiff-new b/src/fim/FIMrun/batchTemplate-postncldiff-new deleted file mode 100755 index f2cead2..0000000 --- a/src/fim/FIMrun/batchTemplate-postncldiff-new +++ /dev/null @@ -1,88 +0,0 @@ -#!/bin/ksh - -if [ "${NCORES}x" == "x" ]; then - if [ "${NSLOTS}x" == "x" ]; then - echo "ERROR: Cannot determine how many cores are available on this node" - exit 1 - else - NCORES=${NSLOTS} - fi -fi -echo "Assuming there are $NCORES cores available on this node" - -# Build array of grid names and specs to process -grididx=1 -for grid in ${GRID_NAMES}; do - grid_names[${grididx}]=${grid} - grid_specs[${grididx}]=`echo -n ${GRID_SPECS} | cut -d: -f ${grididx}` - echo "${grid_names[${grididx}]} ${grid_specs[${grididx}]}" - (( grididx=grididx+1 )) -done - -# Build array of cases to process out of grid names, grid specs, and the forecast time range -T1=`echo $T1 | sed 's/^0\{1,2\}\(.*\)/\1/'` -T2=`echo $T2 | sed 's/^0\{1,2\}\(.*\)/\1/'` -echo "T1=$T1" -echo "T2=$T2" -t=$T1 -caseidx=0 -while [ $t -le $T2 ]; do - echo "Generating cases for forecast time ${t}" - grididx=1 - while [ ${grididx} -le ${#grid_names[*]} ]; do - echo " Domain ${grid_names[${grididx}]}:${grid_specs[${grididx}]}" - case="$t:${grid_names[${grididx}]}:${grid_specs[${grididx}]}" - cases[${caseidx}]=$case - (( caseidx=caseidx+1 )) - (( grididx=grididx+1 )) - done - (( t=t+${FCST_INTERVAL} )) -done - -# Run all the ncl diffs -n=0 -caseidx=0 -unset case_pids -unset case_logfiles -while [ $caseidx -lt ${#cases[*]} ]; do # Loop over all cases - jobs=0 - startidx=$caseidx - (( endidx=$startidx -1 )) - # Fork a batch of cases off in the background - # Batch size is equal to the number of cores on the node - while [ $caseidx -lt ${#cases[*]} -a $jobs -lt $NCORES ]; do - - export T=`echo ${cases[${caseidx}]} | cut -d: -f 1` - export GRID_NAME=`echo -n ${cases[${caseidx}]} | cut -d: -f 2` - export GRID_SPEC=`echo -n ${cases[${caseidx}]} | cut -d: -f 3` - - # Run ncldiff here - echo "$jobs: Running ncldiff: $T:$GRID_NAME:$GRID_SPEC" - ${FIM_HOME}/FIMrun/batchTemplate-ncldiff-new > ${FIM_HOME}/FIMwfm/log/ncldiff/ncldiff_NAT_${MEMBER_ID}_${GRID_NAME}_${T}_${yyyymmddhhmm}.log 2>&1 & - case_pids[${caseidx}]=$! - case_logfiles[${caseidx}]=${FIM_HOME}/FIMwfm/log/ncldiff/ncldiff_NAT_${MEMBER_ID}_${GRID_NAME}_${T}_${yyyymmddhhmm}.log - (( jobs=jobs+1 )) - (( caseidx=caseidx+1 )) - (( endidx=endidx+1 )) - done - (( n=n+1 )) - - # Wait for the cases to finish before doing another batch - waitidx=$startidx - while [ $waitidx -le $endidx ]; do - if [ ${case_pids[${waitidx}]} -ne 0 ]; then - echo "Waiting for ncldiff ${cases[${waitidx}]} pid=${case_pids[${waitidx}]}..." - wait ${case_pids[${waitidx}]} - status=$? - if [ ${status} -ne 0 ]; then - echo "Ncldiff ${cases[${waitidx}]} failed! Exit status=${status}" - echo "See log at ${case_logfiles[${waitidx}]}" - exit ${status} - fi - fi - (( waitidx=waitidx+1 )) - done - -done - -exit 0 diff --git a/src/fim/FIMrun/batchTemplate-prep b/src/fim/FIMrun/batchTemplate-prep deleted file mode 100755 index 3bbc01d..0000000 --- a/src/fim/FIMrun/batchTemplate-prep +++ /dev/null @@ -1,335 +0,0 @@ -#!/bin/ksh - -# NOTE: When run by Workflow Manager, this script's output can be found in -# FIMwfm/logs/prep. Also see FIMwfm/logs/workflow for general WFM messages. - -CONTEXT="batchTemplate-prep" - -# Source functions.ksh if needed. - -if [[ -z "$functions_sourced" ]] -then - test -n "$WFM" && prefix=$FIM_HOME/FIMrun || prefix=. - . $prefix/functions.ksh # Most function definitions can be found here. -fi - -ksh_insist # Ensure that we are running in ksh93 - -# When run in the WFM with ENSEMBLE, sets up an ensemble run. - -test "$WFM" == "ENSEMBLE" && print "This is an ensemble run." - -# FIM_HOME must be defined for WFM-driven runs. - -test -n "$WFM" -a ! -d "$FIM_HOME" && fail "Define FIM_HOME for WFM runs." - -# For WFM runs, enter the appropriate FIMrun directory. - -if [[ -n "$WFM" ]] -then - cd $FIM_HOME/FIMrun || fail -fi - -# Run batchTemplate-setup if it has not already been run. - -test -z "$batchTemplate_setup_ran" && xsource ./batchTemplate-setup - -# Enter the appropriate run directory (as defined by batchTemplate-setup). - -FIMRUN="$PWD" -cd $DIR || fail - -# Preserve a pre-existing WFM prep dir by renaming with a timestamp. - -if [[ -n "$WFM" && -d "$PREP" ]] -then - ls -ld --time-style=+%Y%m%d%H%M%S $PREP | awk '{print $6}' | \ - read timestamp || fail "Cannot ls $PREP." - test -z "$timestamp" && fail "Cannot determine timestamp for $PREP." - mv $PREP $PREP.$timestamp || fail "Cannot move $PREP -> $PREP.$timestamp." -fi - -# Make the prep directory. - -mkdir $PREP || fail - -# If a pre-existing prep directory was identified, link its contents. - -if [[ -d "$PREPDIR" ]] -then - test "$COMPARE_VAR_ON" == ".true." && \ - fail "Cannot use PREPDIR and COMPARE_VAR together." - linksafe $PREPDIR/* $PREP -else - # Copy/link needed items. - cp $fimnamelist $PREP/$NLFILE || fail - cp $thetacoor $PREP/theta_coor.txt || fail - cp $dpsig $PREP/dpsig.txt || fail - cp $topgrid $PREP/top_grid || fail - cp $DATADIR/HADISST_MONTHLY.1991-2009 $PREP/sst_dat || fail - cp $DATADIR/ocean_bcs_ltln.360x180.dat $PREP/ocean_bcs_ltln || fail - test -d "$DATADIR" || fail "$DATADIR does not exist." - fimnamelist_dir="$PREP" - fimnamelist="$PREP/$NLFILE" - # If it has not already been created by pre-processing scripts, create - # the ensics directory for WFM runs. - ENSICS=$PREP/../ensics - test -n "$WFM" -a ! -d $ENSICS && linksafe $DATADR2 $ENSICS - - print $PWD | grep -q "/FIMtest/" && test_suite=1 || test_suite=0 - - get_nl_value_unquoted "$fimnamelist" ISOBARICnamelist isobaric_levels_file \ - ISOBARIC_LEVELS_FILE - - if [[ -n "$WFM" && -f "$FIM_HOME/FIMrun/$ISOBARIC_LEVELS_FILE" ]] - then - cp $FIM_HOME/FIMrun/$ISOBARIC_LEVELS_FILE $PREP/$ISOBARIC_LEVELS_FILE - elif [[ -f "../$ISOBARIC_LEVELS_FILE" ]] - then - cp "../$ISOBARIC_LEVELS_FILE" $PREP/$ISOBARIC_LEVELS_FILE - else - fail "$ISOBARIC_LEVELS_FILE not found." - fi - - # TODO The following two blocks are almost identical. It'd be nice to combine - # TODO them in a single function and supply arguments to control the specifics. - - # Check and (potentially) set gfsltln_file value in namelist file. - - get_nl_value_unquoted "$fimnamelist" PREPnamelist gfsltln_file GFSLTLNFILE - test -z "$GFSLTLNFILE" && fail "Cannot find gfsltln_file in $fimnamelist." - if [[ "$GFSLTLNFILE" == "no_such_file" ]] - then - if [[ "$test_suite" -eq 1 ]] - then # this is a test-suite run and gfsltln_file is erroneously unspecified - fail "Test suite runs must specify gfsltln_file in $fimnamelist." - else # this is a non-test-suite run, so determine and set gfsltln_file - test -n "$WFM" && sanlFile_dir=$PWD/ensics || sanlFile_dir=$DATADR2 - file2test=$sanlFile_dir/$sanlFile - cmd="$BINDIR/global_sighdr $file2test jcap" - endian_big 11 - sanl_size=$($cmd) - endian_reset - if [[ "$sanl_size" -ne "382" && "$sanl_size" -ne "574" ]] - then - fail "Unexpected value ($sanl_size) found in $file2test." - fi - GFSLTLNFILE="gfsltln_t${sanl_size}.dat" - re='\(^[ \t]*gfsltln_file[ \t]*=[ \t]*\).*' - sed "s/$re/\1'$GFSLTLNFILE'/" $fimnamelist > sed.tmp || fail - mv sed.tmp $fimnamelist || fail - get_nl_value_unquoted "$fimnamelist" PREPnamelist gfsltln_file GFSLTLNFILE - if [[ "$GFSLTLNFILE" == "no_such_file" ]] - then - fail "Failed to set gfsltln_file in $fimnamelist." - fi - fi - fi - - # Check and (potentially) set mtnvar_file value in namelist file. - - get_nl_value_unquoted "$fimnamelist" PREPnamelist mtnvar_file MTNVARFILE - test -z "$MTNVARFILE" && fail "Cannot find mtnvar_file in $fimnamelist." - if [[ "$MTNVARFILE" == "no_such_file" ]] - then - if [[ "$test_suite" -eq 1 ]] - then # this is a test-suite run and mtnvar_file is erroneously unspecified - fail "Test suite runs must specify mtnvar_file in $fimnamelist." - else # this is a non-test-suite run, so determine and set mtnvar_file - test -n "$WFM" && sfcanlFile_dir=$PWD/ensics || sfcanlFile_dir=$DATADR2 - file2test=$sfcanlFile_dir/$sfcanlFile - cmd="$BINDIR/global_sfchdr $file2test lonb" - endian_big 11 - ret=$($cmd) - endian_reset - if [[ "$ret" -ne "1152" && "$ret" -ne "1760" ]] - then - fail "Unexpected value ($ret) found in $file2test." - fi - test "$ret" -eq "1152" && sfcanl_size=382 || sfcanl_size=574 - MTNVARFILE="global_mtnvar.t${sfcanl_size}" - re='\(^[ \t]*mtnvar_file[ \t]*=[ \t]*\).*' - sed "s/$re/\1'$MTNVARFILE'/" $fimnamelist > sed.tmp || fail - mv sed.tmp $fimnamelist || fail - get_nl_value_unquoted "$fimnamelist" PREPnamelist mtnvar_file MTNVARFILE - if [[ "$MTNVARFILE" == "no_such_file" ]] - then - fail "Failed to set mtnvar_file in $fimnamelist." - fi - fi - fi - - get_nl_value_unquoted "$fimnamelist" PREPnamelist aerosol_file AEROSOLFILE - test -z "$AEROSOLFILE" && fail "Cannot get aerosol filename from $fimnamelist." - - get_nl_value_unquoted "$fimnamelist" PREPnamelist co2_2008_file CO2_2008FILE - test -z "$CO2_2008FILE" && fail "Cannot get co2_2008 filename from \ -$fimnamelist." - - get_nl_value_unquoted "$fimnamelist" PREPnamelist co2_glb_file CO2_GLBFILE - test -z "$CO2_GLBFILE" && fail "Cannot get co2_glb filename from $fimnamelist." - - if [[ "$test_suite" -eq 1 ]] - then - linksafe $DATADIR/$GFSLTLNFILE $PREP - linksafe $DATADIR/$MTNVARFILE $PREP - linksafe $DATADIR/$AEROSOLFILE $PREP - linksafe $DATADIR/$CO2_2008FILE $PREP - linksafe $DATADIR/$CO2_GLBFILE $PREP - else - cp $DATADIR/$GFSLTLNFILE $PREP || fail - cp $DATADIR/$MTNVARFILE $PREP || fail - cp $DATADIR/$AEROSOLFILE $PREP || fail - cp $DATADIR/$CO2_2008FILE $PREP || fail - cp $DATADIR/$CO2_GLBFILE $PREP || fail - fi - - if [[ -n "$WFM" ]] - then - if [[ "$WFM" == "ENSEMBLE" ]] - then - linksafe $sanlFile $PREP/$sanlFilename - linksafe $sfcanlFile $PREP/$sfcanlFilename - else - test -d $PWD/ensics && linksafe $PWD/ensics/$sanlFile $PREP || \ - linksafe $DATADR2/$sanlFile $PREP - test -d $PWD/ensics && linksafe $PWD/ensics/$sfcanlFile $PREP || \ - linksafe $DATADR2/$sfcanlFile $PREP - fi - else - test -d "$DATADR2" || fail "$DATADR2 does not exist." - if [[ "$TEST_SUITE_RUN" == "yes" ]] - then - linksafe $DATADR2/$sanlFile $PREP - linksafe $DATADR2/$sfcanlFile $PREP - else - cp $DATADR2/$sanlFile $PREP || fail - cp $DATADR2/$sfcanlFile $PREP || fail - fi - fi - - # For WFM runs, set yyyymmddhhmm in the namelist file's TIMEnamelist to the - # value in WFM-exported environment variable yyyymmddhhmm. - - if [[ -n "$WFM" ]] - then - re='^\([^\!]*yyyymmddhhmm[ \t]*=[ \t]*\)[^ \t][^ \t]*\(.*\)$' - sed "s/$re/\1'$yyyymmddhhmm'\2/g" $fimnamelist > sed.tmp || fail - mv sed.tmp $fimnamelist || fail - fi - - # Enter the prep directory. - - cd $PREP || fail "Cannot cd to $PREP." - - # Link files - - for file in grid ginfo getlvl ssfc2icos - do - linksafe $BINDIR/$file - done - - chem_prep_setup - - # If COMPARE_VAR is enabled, use $prepoutfiles to list prep output files that - # will be compared as a sanity check when prep is finished. - - test "$COMPARE_VAR_ON" == ".true." && \ - prepoutfiles="$GFSFC_FILE $GLVL_FILE $INFO_FILE $GRID_FILE $LATLON_FILE" - - # If COMPARE_VAR is enabled, run prep twice using task counts - # $COMPARE_VAR_NTASKS_1 and $COMPARE_VAR_NTASKS_2. Otherwise run prep once - # using $PES for task count. - - for taskcount in $taskcounts - do - # If COMPARE_VAR is enabled, edit the namelist file to replace value of - # ComputeTasks with either $COMPARE_VAR_NTASKS_1 or $COMPARE_VAR_NTASKS_2. - if [[ "$COMPARE_VAR_ON" == ".true." ]] - then - # Modify ComputeTasks in the namelist file after saving old version. - orignl="$NLFILE.orig" - test "$taskcount" == "$COMPARE_VAR_NTASKS_1" && prevnl="$orignl" - test "$taskcount" == "$COMPARE_VAR_NTASKS_2" && \ - prevnl="$NLFILE.$COMPARE_VAR_NTASKS_1" - # Save previous version first. - mv -f $NLFILE $prevnl || fail "Cannot move $NLFILE -> $prevnl." - # Set ComputeTasks = $taskcount. Note that this substitution would fail if - # ComputeTasks = 'S' but fortunately qsubfim disallows use of COMPARE_VAR - # with a serial run. - sed -e "s/^ *ComputeTasks *= *'*[0-9][0-9]*'*/ ComputeTasks = \ -'$taskcount'/g" $prevnl > $NLFILE || \ - fail "sed failed." - fi - - # grid - - ./grid || fail "grid failed." - [[ -f "$GRID_FILE" && -n "$GRID_FILE" ]] || fail "grid no file $GRID_FILE." - print "grid finished" - - # ginfo - - ./ginfo || fail "ginfo failed." - [[ -f "$INFO_FILE" && -n "$INFO_FILE" ]] || fail "grid no file $INFO_FILE." - print "ginfo finished" - - # getlvl - - ./getlvl || fail "getlvl failed." - [[ -f "$GLVL_FILE" && -n "$GLVL_FILE" ]] || fail "grid no file $GLVL_FILE." - print "getlvl finished" - - chem_prep_newname - - # ssfc2icos - - endian_big 11 21 - endian_little 30 - ./ssfc2icos || fail "ssfc2icos failed." - endian_reset - - [[ -f "$GFSFC_FILE" && -n "$GFSFC_FILE" ]] || fail "grid: no file \ -$GFSFC_FILE." - print "ssfc2icos finished" - - if [[ "$COMPARE_VAR_ON" == ".true." ]] - then - # Prepare for second prep needed by second COMPARE_VAR run. - if [[ "$taskcount" == "$COMPARE_VAR_NTASKS_1" ]] - then - for prepoutfile in $prepoutfiles - do - # Move prep output files to versions with special names for - # comparison after second prep run. - mv -f $prepoutfile $prepoutfile.$COMPARE_VAR_NTASKS_1 || \ - fail "Cannot move $prepoutfile -> \ -$prepoutfile.$COMPARE_VAR_NTASKS_1." - done - fi - if [[ "$taskcount" == "$COMPARE_VAR_NTASKS_2" ]] - then - # Compare prep output files with first run. All the files in the - # $prepoutfiles list are expected to match. - for prepoutfile in $prepoutfiles - do - cmp -s $prepoutfile $prepoutfile.$COMPARE_VAR_NTASKS_1 || \ - fail "$prepoutfile does not match \ -$prepoutfile.$COMPARE_VAR_NTASKS_1 after 2nd COMPARE_VAR prep run. Should it?" - done - # Restore original namelist file so humans looking in the fim - # directory will see the correct number of tasks. - prevnl="$NLFILE.$COMPARE_VAR_NTASKS_2" - # Save previous version first. - mv -f $NLFILE $prevnl || fail "Cannot move $NLFILE $prevnl." - cp $orignl $NLFILE || fail "Cannot copy $orignl $NLFILE." - fi - fi - done -fi # if [[ -d "$PREPDIR" ]] - -cd $FIMRUN || fail "Cannot cd to $FIMRUN." - -print "\nprep finished\n" - -return 0 diff --git a/src/fim/FIMrun/batchTemplate-prep-ens b/src/fim/FIMrun/batchTemplate-prep-ens deleted file mode 100755 index a14688b..0000000 --- a/src/fim/FIMrun/batchTemplate-prep-ens +++ /dev/null @@ -1,337 +0,0 @@ -#!/bin/ksh - -# NOTE: When run by Workflow Manager, this script's output can be found in -# FIMwfm/logs/prep. Also see FIMwfm/logs/workflow for general WFM messages. - -CONTEXT="batchTemplate-prep" - -# Source functions.ksh if needed. -print "in batchTemplate-prep.ens fimnamelist: $fimnamelist" - -if [[ -z "$functions_sourced" ]] -then - test -n "$WFM" && prefix=$FIM_HOME/FIMrun || prefix=. - . $prefix/functions.ksh # Most function definitions can be found here. -fi - -ksh_insist # Ensure that we are running in ksh93 - -# When run in the WFM with ENSEMBLE, sets up an ensemble run. - -test "$WFM" == "ENSEMBLE" && print "This is an ensemble run." - -# FIM_HOME must be defined for WFM-driven runs. - -test -n "$WFM" -a ! -d "$FIM_HOME" && fail "Define FIM_HOME for WFM runs." - -# For WFM runs, enter the appropriate FIMrun directory. - -if [[ -n "$WFM" ]] -then - cd $FIM_HOME/FIMrun || fail -fi - -# Run batchTemplate-setup if it has not already been run. - -test -z "$batchTemplate_setup_ran" && xsource ./batchTemplate-setup - -# Enter the appropriate run directory (as defined by batchTemplate-setup). - -FIMRUN="$PWD" -cd $DIR || fail - -# Preserve a pre-existing WFM prep dir by renaming with a timestamp. - -if [[ -n "$WFM" && -d "$PREP" ]] -then - ls -ld --time-style=+%Y%m%d%H%M%S $PREP | awk '{print $6}' | \ - read timestamp || fail "Cannot ls $PREP." - test -z "$timestamp" && fail "Cannot determine timestamp for $PREP." - mv $PREP $PREP.$timestamp || fail "Cannot move $PREP -> $PREP.$timestamp." -fi - -# Make the prep directory. - -mkdir $PREP || fail - -# If a pre-existing prep directory was identified, link its contents. - -if [[ -d "$PREPDIR" ]] -then - test "$COMPARE_VAR_ON" == ".true." && \ - fail "Cannot use PREPDIR and COMPARE_VAR together." - linksafe $PREPDIR/* $PREP -else - # Copy/link needed items. - cp $fimnamelist $PREP/$NLFILE || fail - cp $thetacoor $PREP/theta_coor.txt || fail - cp $dpsig $PREP/dpsig.txt || fail - cp $topgrid $PREP/top_grid || fail - cp $DATADIR/HADISST_MONTHLY.1991-2009 $PREP/sst_dat || fail - cp $DATADIR/ocean_bcs_ltln.360x180.dat $PREP/ocean_bcs_ltln || fail - test -d "$DATADIR" || fail "$DATADIR does not exist." - fimnamelist_dir="$PREP" - fimnamelist="$PREP/$NLFILE" - # If it has not already been created by pre-processing scripts, create - # the ensics directory for WFM runs. - ENSICS=$PREP/../ensics_${MEMBER_ID} - test -n "$WFM" -a ! -d $ENSICS && linksafe $DATADR2 $ENSICS - - print $PWD | grep -q "/FIMtest/" && test_suite=1 || test_suite=0 - - get_nl_value_unquoted "$fimnamelist" ISOBARICnamelist isobaric_levels_file \ - ISOBARIC_LEVELS_FILE - - if [[ -n "$WFM" && -f "$FIM_HOME/FIMrun/$ISOBARIC_LEVELS_FILE" ]] - then - cp $FIM_HOME/FIMrun/$ISOBARIC_LEVELS_FILE $PREP/$ISOBARIC_LEVELS_FILE - elif [[ -f "../$ISOBARIC_LEVELS_FILE" ]] - then - cp "../$ISOBARIC_LEVELS_FILE" $PREP/$ISOBARIC_LEVELS_FILE - else - fail "$ISOBARIC_LEVELS_FILE not found." - fi - - # TODO The following two blocks are almost identical. It'd be nice to combine - # TODO them in a single function and supply arguments to control the specifics. - - # Check and (potentially) set gfsltln_file value in namelist file. - - get_nl_value_unquoted "$fimnamelist" PREPnamelist gfsltln_file GFSLTLNFILE - test -z "$GFSLTLNFILE" && fail "Cannot find gfsltln_file in $fimnamelist." - if [[ "$GFSLTLNFILE" == "no_such_file" ]] - then - if [[ "$test_suite" -eq 1 ]] - then # this is a test-suite run and gfsltln_file is erroneously unspecified - fail "Test suite runs must specify gfsltln_file in $fimnamelist." - else # this is a non-test-suite run, so determine and set gfsltln_file - test -n "$WFM" && sanlFile_dir=$PWD/ensics_${MEMBER_ID} || sanlFile_dir=$DATADIR - file2test=$sanlFile_dir/$sanlFile - cmd="$BINDIR/global_sighdr $file2test jcap" - endian_big 11 - sanl_size=$($cmd) - endian_reset - if [[ "$sanl_size" -ne "382" && "$sanl_size" -ne "574" ]] - then - fail "Unexpected value ($sanl_size) found in $file2test." - fi - GFSLTLNFILE="gfsltln_t${sanl_size}.dat" - re='\(^[ \t]*gfsltln_file[ \t]*=[ \t]*\).*' - sed "s/$re/\1'$GFSLTLNFILE'/" $fimnamelist > $fimnamelist.tmp || fail - mv $fimnamelist.tmp $fimnamelist || fail - get_nl_value_unquoted "$fimnamelist" PREPnamelist gfsltln_file GFSLTLNFILE - if [[ "$GFSLTLNFILE" == "no_such_file" ]] - then - fail "Failed to set gfsltln_file in $fimnamelist." - fi - fi - fi - - # Check and (potentially) set mtnvar_file value in namelist file. - - get_nl_value_unquoted "$fimnamelist" PREPnamelist mtnvar_file MTNVARFILE - test -z "$MTNVARFILE" && fail "Cannot find mtnvar_file in $fimnamelist." - if [[ "$MTNVARFILE" == "no_such_file" ]] - then - if [[ "$test_suite" -eq 1 ]] - then # this is a test-suite run and mtnvar_file is erroneously unspecified - fail "Test suite runs must specify mtnvar_file in $fimnamelist." - else # this is a non-test-suite run, so determine and set mtnvar_file - test -n "$WFM" && sfcanlFile_dir=$PWD/ensics_${MEMBER_ID} || sfcanlFile_dir=$DATADIR - file2test=$sfcanlFile_dir/$sfcanlFile - cmd="$BINDIR/global_sfchdr $file2test lonb" - endian_big 11 - ret=$($cmd) - endian_reset - if [[ "$ret" -ne "1152" && "$ret" -ne "1760" ]] - then - fail "Unexpected value ($ret) found in $file2test." - fi - test "$ret" -eq "1152" && sfcanl_size=382 || sfcanl_size=574 - MTNVARFILE="global_mtnvar.t${sfcanl_size}" - re='\(^[ \t]*mtnvar_file[ \t]*=[ \t]*\).*' - sed "s/$re/\1'$MTNVARFILE'/" $fimnamelist > $fimnamelist.tmp || fail - mv $fimnamelist.tmp $fimnamelist || fail - get_nl_value_unquoted "$fimnamelist" PREPnamelist mtnvar_file MTNVARFILE - if [[ "$MTNVARFILE" == "no_such_file" ]] - then - fail "Failed to set mtnvar_file in $fimnamelist." - fi - fi - fi - - get_nl_value_unquoted "$fimnamelist" PREPnamelist aerosol_file AEROSOLFILE - test -z "$AEROSOLFILE" && fail "Cannot get aerosol filename from $fimnamelist." - - get_nl_value_unquoted "$fimnamelist" PREPnamelist co2_2008_file CO2_2008FILE - test -z "$CO2_2008FILE" && fail "Cannot get co2_2008 filename from \ -$fimnamelist." - - get_nl_value_unquoted "$fimnamelist" PREPnamelist co2_glb_file CO2_GLBFILE - test -z "$CO2_GLBFILE" && fail "Cannot get co2_glb filename from $fimnamelist." - - if [[ "$test_suite" -eq 1 ]] - then - linksafe $DATADIR/$GFSLTLNFILE $PREP - linksafe $DATADIR/$MTNVARFILE $PREP - linksafe $DATADIR/$AEROSOLFILE $PREP - linksafe $DATADIR/$CO2_2008FILE $PREP - linksafe $DATADIR/$CO2_GLBFILE $PREP - else - cp $DATADIR/$GFSLTLNFILE $PREP || fail - cp $DATADIR/$MTNVARFILE $PREP || fail - cp $DATADIR/$AEROSOLFILE $PREP || fail - cp $DATADIR/$CO2_2008FILE $PREP || fail - cp $DATADIR/$CO2_GLBFILE $PREP || fail - fi - - if [[ -n "$WFM" ]] - then - if [[ "$WFM" == "ENSEMBLE" ]] - then - linksafe $sanlFile $PREP/$sanlFilename - linksafe $sfcanlFile $PREP/$sfcanlFilename - else - test -d $PWD/ensics_${MEMBER_ID} && linksafe $PWD/ensics_${MEMBER_ID}/$sanlFile $PREP || \ - linksafe $DATADR2/$sanlFile $PREP - test -d $PWD/ensics_${MEMBER_ID} && linksafe $PWD/ensics_${MEMBER_ID}/$sfcanlFile $PREP || \ - linksafe $DATADR2/$sfcanlFile $PREP - fi - else - test -d "$DATADR2" || fail "$DATADR2 does not exist." - if [[ "$TEST_SUITE_RUN" == "yes" ]] - then - linksafe $DATADR2/$sanlFile $PREP - linksafe $DATADR2/$sfcanlFile $PREP - else - cp $DATADR2/$sanlFile $PREP || fail - cp $DATADR2/$sfcanlFile $PREP || fail - fi - fi - - # For WFM runs, set yyyymmddhhmm in the namelist file's TIMEnamelist to the - # value in WFM-exported environment variable yyyymmddhhmm. - - if [[ -n "$WFM" ]] - then - re='^\([^\!]*yyyymmddhhmm[ \t]*=[ \t]*\)[^ \t][^ \t]*\(.*\)$' - print "before sed: fimnamelist: $fimnamelist" - sed "s/$re/\1'$yyyymmddhhmm'\2/g" $fimnamelist > $fimnamelist.tmp || fail - mv $fimnamelist.tmp $fimnamelist || fail - fi - - # Enter the prep directory. - - cd $PREP || fail "Cannot cd to $PREP." - - # Link files - - for file in grid ginfo getlvl ssfc2icos - do - linksafe $BINDIR/$file - done - - chem_prep_setup - - # If COMPARE_VAR is enabled, use $prepoutfiles to list prep output files that - # will be compared as a sanity check when prep is finished. - - test "$COMPARE_VAR_ON" == ".true." && \ - prepoutfiles="$GFSFC_FILE $GLVL_FILE $INFO_FILE $GRID_FILE $LATLON_FILE" - - # If COMPARE_VAR is enabled, run prep twice using task counts - # $COMPARE_VAR_NTASKS_1 and $COMPARE_VAR_NTASKS_2. Otherwise run prep once - # using $PES for task count. - - for taskcount in $taskcounts - do - # If COMPARE_VAR is enabled, edit the namelist file to replace value of - # ComputeTasks with either $COMPARE_VAR_NTASKS_1 or $COMPARE_VAR_NTASKS_2. - if [[ "$COMPARE_VAR_ON" == ".true." ]] - then - # Modify ComputeTasks in the namelist file after saving old version. - orignl="$NLFILE.orig" - test "$taskcount" == "$COMPARE_VAR_NTASKS_1" && prevnl="$orignl" - test "$taskcount" == "$COMPARE_VAR_NTASKS_2" && \ - prevnl="$NLFILE.$COMPARE_VAR_NTASKS_1" - # Save previous version first. - mv -f $NLFILE $prevnl || fail "Cannot move $NLFILE -> $prevnl." - # Set ComputeTasks = $taskcount. Note that this substitution would fail if - # ComputeTasks = 'S' but fortunately qsubfim disallows use of COMPARE_VAR - # with a serial run. - sed -e "s/^ *ComputeTasks *= *'*[0-9][0-9]*'*/ ComputeTasks = \ -'$taskcount'/g" $prevnl > $NLFILE || \ - fail "sed failed." - fi - - # grid - - ./grid || fail "grid failed." - [[ -f "$GRID_FILE" && -n "$GRID_FILE" ]] || fail "grid no file $GRID_FILE." - print "grid finished" - - # ginfo - - ./ginfo || fail "ginfo failed." - [[ -f "$INFO_FILE" && -n "$INFO_FILE" ]] || fail "grid no file $INFO_FILE." - print "ginfo finished" - - # getlvl - - ./getlvl || fail "getlvl failed." - [[ -f "$GLVL_FILE" && -n "$GLVL_FILE" ]] || fail "grid no file $GLVL_FILE." - print "getlvl finished" - - chem_prep_newname - - # ssfc2icos - - endian_big 11 21 - endian_little 30 - ./ssfc2icos || fail "ssfc2icos failed." - endian_reset - - [[ -f "$GFSFC_FILE" && -n "$GFSFC_FILE" ]] || fail "grid: no file \ -$GFSFC_FILE." - print "ssfc2icos finished" - - if [[ "$COMPARE_VAR_ON" == ".true." ]] - then - # Prepare for second prep needed by second COMPARE_VAR run. - if [[ "$taskcount" == "$COMPARE_VAR_NTASKS_1" ]] - then - for prepoutfile in $prepoutfiles - do - # Move prep output files to versions with special names for - # comparison after second prep run. - mv -f $prepoutfile $prepoutfile.$COMPARE_VAR_NTASKS_1 || \ - fail "Cannot move $prepoutfile -> \ -$prepoutfile.$COMPARE_VAR_NTASKS_1." - done - fi - if [[ "$taskcount" == "$COMPARE_VAR_NTASKS_2" ]] - then - # Compare prep output files with first run. All the files in the - # $prepoutfiles list are expected to match. - for prepoutfile in $prepoutfiles - do - cmp -s $prepoutfile $prepoutfile.$COMPARE_VAR_NTASKS_1 || \ - fail "$prepoutfile does not match \ -$prepoutfile.$COMPARE_VAR_NTASKS_1 after 2nd COMPARE_VAR prep run. Should it?" - done - # Restore original namelist file so humans looking in the fim - # directory will see the correct number of tasks. - prevnl="$NLFILE.$COMPARE_VAR_NTASKS_2" - # Save previous version first. - mv -f $NLFILE $prevnl || fail "Cannot move $NLFILE $prevnl." - cp $orignl $NLFILE || fail "Cannot copy $orignl $NLFILE." - fi - fi - done -fi # if [[ -d "$PREPDIR" ]] - -cd $FIMRUN || fail "Cannot cd to $FIMRUN." - -print "\nprep finished\n" - -return 0 diff --git a/src/fim/FIMrun/batchTemplate-restart b/src/fim/FIMrun/batchTemplate-restart deleted file mode 100755 index 28e5687..0000000 --- a/src/fim/FIMrun/batchTemplate-restart +++ /dev/null @@ -1,62 +0,0 @@ -#!/bin/ksh -v - -# This file started the same as batchTemplate, but modified to exclude -# running the prep portion because that has already happened in a restart -# run. Added the code (below) to modify contents of FIMnamelist to do a -# restart, and rename previous stdout file as well as FIMnamelist. - -CONTEXT="batchTemplate-restart" - -. ./functions.ksh # Most function definitions can be found here. - -ksh_insist # Ensure that we are running in ksh93 - -let "stime=$(date +%s)" -print "Starting batchTemplate-fim at $(date)" - -# Run batchTemplate-setup if it has not already been run. -# It provides settings for things like $PREP, $FIM, etc. - -test -z "$batchTemplate_setup_ran" && xsource ./batchTemplate-setup - -# Save off previous FIMnamelists and stdout files to preserve the history of the run -#JR Don't add "|| fail" to these "mv" cmds in case a previous restart already moved the files - -mv ./FIMnamelist ./FIMnamelist.$$ -mv $PREP/FIMnamelist $PREP/FIMnamelist.$$ -mv $FIM/FIMnamelist $FIM/FIMnamelist.$$ -mv $FIM/stdout $FIM/stdout.$$ -mv $POST/FIMnamelist $POST/FIMnamelist.$$ - -#JR CRITICAL!!!! The value of $fimnamelist as provided by batchTemplate-setup is -#JR WRONG at this point in the run, since things like MTNVARFILE and GFSLTLNFILE -#JR may have been modified to change the value of things like no_such_file!!! The -#JR most up-to-date FIMnamelist is currently in $PREP. Edit that one here to change -#JR the value of readrestart. - -#JR Before running batchTemplate-fim, ensure FIMnamelist is set up to do a restart. -#JR Also: save the existing FIMnamelist in the fim/ directory to keep a trail of -#JR bread crumbs. - -#JR vapor doesn't have a case-insensitive sed, so assume case-sensitivity here!!! -re='\(^[ \t]*[Rr][Ee][Aa][Dd][Rr][Ee][Ss][Tt][Aa][Rr][Tt][ \t]*=[ \t]*\).*' -sed "s/$re/\1 .true./" $PREP/FIMnamelist.$$ > sed.tmp || fail -mv -f sed.tmp FIMnamelist || fail - -#JR CRITICAL to cp FIMnamelist to $PREP because batchTemplate-fim copies it from -#JR there to $FIM!!! -cp FIMnamelist $PREP || fail "Cannot cp $fimnamelist $PREP" - -xsource ./batchTemplate-fim -let "etime=$(date +%s)" -let "delta=$etime-$stime" -print "batchTemplate-fim took $delta seconds" - -let "stime=$etime" -print "Starting batchTemplate-post at $(date)" -xsource ./batchTemplate-post -let "etime=$(date +%s)" -let "delta=$etime-$stime" -print "batchTemplate-post took $delta seconds" - -return 0 diff --git a/src/fim/FIMrun/batchTemplate-setup b/src/fim/FIMrun/batchTemplate-setup deleted file mode 100755 index e510b2a..0000000 --- a/src/fim/FIMrun/batchTemplate-setup +++ /dev/null @@ -1,217 +0,0 @@ -#!/bin/ksh - -CONTEXT="batchTemplate-setup" - -# Source functions.ksh if needed. - -if [[ -z "$functions_sourced" ]] -then - test -n "$WFM" && prefix=$FIM_HOME/FIMrun || prefix=. - . $prefix/functions.ksh # Most function definitions can be found here. -fi - -ksh_insist # Ensure that we are running in ksh93 - -xsource ./chem_functions.ksh - -# Set fimnamelist to the absolute pathname of our FIMnamelist. If we're running -# via WFM, this should already be set, in which case we retain the preset value. -# Otherwise, we're running via qsubfim and use FIMnamelist in the current -# qsubfim_* directory. - -test -n "$NLFILE" && fimnamelist="$NLFILE" || set_fimnamelist - -# From here on, NLFILE refers to the standard filename of FIM's namelist file, -# and fimnamelist refers to the absolute path to the run's master version of -# that file. - -NLFILE="FIMnamelist" - -# If the FIMnamelist has been copied to the prep dir, use the copy there -# For WFM runs, this keeps us from continuing to read the copy in the FIMrun dir, -# which could be overwritten at any time - -if [[ -n "$WFM" && "$(context_peek)" != "batchTemplate-prep" ]] -then # PREP and RUNDIR are as assigned below - RUNDIR="$FIM_HOME/FIMrun/fim_${GLVL}_${NVL}_${PES}_$yyyymmddhhmm" - PREP="$RUNDIR/prep_$MEMBER_ID" - test -r $PREP/$NLFILE && fimnamelist="$PREP/$NLFILE" -fi - -print "Using FIMnamelist at $fimnamelist" - -# Read variable values from the FIMnamelist - -get_srcdir # Read SRCDIR - Always do this before any other reads -get_from_nl GLVL # Read GLVL -get_from_nl NVL # Read NVL -get_fc # Read FC (i.e. BUILDCONFIG) - -if [[ -n "$WFM" ]] # WFM provides SRCDIR -then - BINDIR="$SRCDIR/bin" - FIMSETUP="$SRCDIR/fim_setup.ksh" -else - BINDIR="$PWD" - FIMSETUP="$BINDIR/fim_setup.ksh" -fi - -# Set up run-time environment and print results via "verbose" - -xsource_notrace $FIMSETUP $FC "verbose" - -# Non-WFM runs need to set yyyymmddhhmm (which is exported as an environment -# variable by WFM) to the value specified in the namelist. - -if [[ -z "$WFM" ]] -then - get_nl_value_unquoted $fimnamelist TIMEnamelist yyyymmddhhmm yyyymmddhhmm - test -z "$yyyymmddhhmm" && fail "Cannot determine yyyymmddhhmm from $fimnamelist." - yyyymmddhhmm=$(print $yyyymmddhhmm | tr -d '"' | tr -d "'") -fi - -get_from_nl DATADIR -get_from_nl DATADR2 -get_from_nl FIMDIR -get_from_nl PREPDIR -get_from_nl Parallelism as parallelism - -chem_on && CHEMFLAG="true" || CHEMFLAG="false" - -# Put test on chemistry true and readrestart true in here because subroutine chem_init may not -# successfully kill all MPI tasks in its similar test (because the write tasks don't execute -# chem_init(). Delete the code in both spots when chemistry works with restart. - -if [[ "$CHEMFLAG" == "true" ]] -then - get_nl_value $fimnamelist OUTPUTnamelist readrestart READRESTART - test "$READRESTART" != ".false." && \ - fail "Cannot enable chemistry with READRESTART." -fi - -print $(cd $fimnamelist_dir;$BINDIR/GetWriteTaskInfo | grep "max_write_tasks_per_node") | sed 's/^.*://' | \ - read mwtpn || fail "Could not get max_write_tasks_per_node." - -# jdate binary gives no trailing newline => "read" fails => execute in subshell - -JDATE=$($BINDIR/jdate $yyyymmddhhmm) || \ - fail "Cannot extract Julian date from $yyyymmddhhmm." - -print $JDATE | cut -c6-7 | read hh || \ - fail "Cannot derive hours from Julian date $JDATE." -test -z "$hh" && fail "Cannot determine hour from $JDATE." - -# Set variables - -yyyymmddhh=$(print $yyyymmddhhmm | cut -c1-10) -sanlFile="${JDATE}.gfs.t${hh}z.sanl" -sfcanlFile="${JDATE}.gfs.t${hh}z.sfcanl" -if [[ "$WFM" == "ENSEMBLE" ]] -then - print "Setting up environment variables for Ensemble Run" - sanlFilename=$sanlFile - sfcanlFilename=$sfcanlFile - if [[ "$MEMBER_ID" == "EM" ]] - then - print "This is the Ensemble Mean" - sfcanlFile=${DATADR2}/${yyyymmddhh}/ens20/sfcanl60_${yyyymmddhh}_ensmean - sanlFile=${DATADR2}/${yyyymmddhh}/ens20/sanl60_${yyyymmddhh}_ensmean - else - sfcanlFile=${DATADR2}/${yyyymmddhh}/ens20/sfcanl_${yyyymmddhh}_mem0${MEMBER_ID} - sanlFile=${DATADR2}/${yyyymmddhh}/ens20/sanl_${yyyymmddhh}_mem0${MEMBER_ID} - fi -fi -GMPIENVVAR="F_UFMTENDIAN" -dpsig="../dpsig${NVL}.txt" -fimgribtable="../fim_gribtable" -REDUCE="../reduce" -reduceinput="../REDUCEinput" -smsnamelist="../SMSnamelist" # optional: controls SMS run-time options -thetacoor="../theta_coor${NVL}.txt" -topgrid="../top_grid" - -# Output subversion information for logging purposes. - -if [[ -x "$(whence svn)" ]] -then - (cd $SRCDIR && svn info 2>/dev/null && svn diff --diff-cmd diff 2>/dev/null) -fi - -get_from_nl ComputeTasks as PES -compare_var_setup - -# Set various paths for WFM and non-WFM runs - -if [[ -n "$WFM" ]] -then - RUNDIR="$FIM_HOME/FIMrun/fim_${GLVL}_${NVL}_${PES}_$yyyymmddhhmm" - PREP="$RUNDIR/prep_$MEMBER_ID" - FIM="$RUNDIR/fim_$MEMBER_ID" - POST="$RUNDIR/post_$MEMBER_ID" - COMPARE_VAR_ON="false" - DIR="$RUNDIR" -else - if [[ "$parallelism" == "serial" ]] - then - DIR="$BINDIR/fim${GLVL}_${NVL}_S" - else - if [[ "$COMPARE_VAR_ON" == ".true." ]] - then - # a more descriptive directory name... - DIR="$BINDIR/fim${GLVL}_${NVL}_cv.${COMPARE_VAR_NTASKS_1}.vs.${COMPARE_VAR_NTASKS_2}" - else - DIR="$BINDIR/fim${GLVL}_${NVL}_${PES}" - fi - fi - PREP="$DIR/prep" - FIM="$DIR/fim" - POST="$DIR/post" -fi - -#JR Removed "rm -Rf $DIR" to enable restart to work. - -# Create run directory - -if [[ ! -d "$DIR" ]] -then - mkdir $DIR || fail "Cannot make directory $DIR." -fi - -# Make directory for where FIM might make GRIB1 files. -if [[ -n "$WFM" && ! -d "$POST/fim/NAT/grib1" ]] -then - mkdir -p "$POST/fim/NAT/grib1" || fail "Cannot make directory $POST/fim/NAT/grib1." -fi - -# Which fim executable should be used? - -test "$parallelism" == "serial" && FIMEXEBASE="fimS" || FIMEXEBASE="fim" - -FIMEXE="$FIMEXEBASE" -GRID_FILE="icos_grid_level.dat" #intermediate file -INFO_FILE="icos_grid_info_level.dat" #intermediate file -LATLON_FILE="latlonIJ.dat" #needed by fim for post -GLVL_FILE="glvl.dat" #needed by fim -GFSFC_FILE="gfsfc.dat" #needed by fim - -check_nems - -# When COMPARE_VAR is enabled, $taskcounts iterates through numbers of MPI tasks -# assigned to each concurrent run. Otherwise $taskcounts just contains $PES. - -if [[ "$COMPARE_VAR_ON" == ".true." ]] -then - taskcounts="$COMPARE_VAR_NTASKS_1 $COMPARE_VAR_NTASKS_2" -else - taskcounts="$PES" -fi - -# The batchTemplate-[prep|fim|post] scripts check if batchTemplate_setup_ran is -# set and only call batchTemplate-setup if it is not. So, if those scripts are -# sourced inline by batchTemplate, batchTemplate-setup is only called once. For -# WFM runs, where batchTemplate-[prep|fim|post] are each called independently, -# batchTemplate-setup is called to initialize each of them. - -batchTemplate_setup_ran=1 - -return 0 diff --git a/src/fim/FIMrun/batchTemplate-tracker b/src/fim/FIMrun/batchTemplate-tracker deleted file mode 100755 index a2a170b..0000000 --- a/src/fim/FIMrun/batchTemplate-tracker +++ /dev/null @@ -1,196 +0,0 @@ -#!/bin/ksh - -# Make sure we are using GMT time zone for time computations -export TZ="GMT" - -# Set up paths to system commands -MKDIR=/bin/mkdir -LN=/bin/ln -ECHO=/bin/echo -RM=/bin/rm -CAT=/bin/cat -CUT=/bin/cut -TR=/usr/bin/tr -DATE=/bin/date -TAIL=/usr/bin/tail -SORT="/bin/sort -n" -#WGRIB="/share/home/01033/harrop/wgrib/wgrib" -#WGRIB="/work/01033/harrop/wgrib/wgrib" -WGRIB=/opt/grads/2.0.a2/bin/wgrib -WC=/usr/bin/wc -UNIQ=/usr/bin/uniq -AWK=/bin/awk -GRIBTAB='' - -# Set up arrays of fields and corresponding levels needed -set -A fields \ - HGT \ - UGRD \ - UGRD \ - UGRD \ - UGRD \ - UGRD \ - VGRD \ - VGRD \ - VGRD \ - VGRD \ - VGRD \ - TMP \ - ACPCP \ - NCPCP \ - MSLMA - -set -A levels \ - "500 mb" \ - "850 mb" \ - "700 mb" \ - "250 mb" \ - "200 mb" \ - "hybrid lev 1" \ - "850 mb" \ - "700 mb" \ - "250 mb" \ - "200 mb" \ - "hybrid lev 1" \ - "700 mb" \ - "sfc" \ - "sfc" \ - "MSL" - -# Set up paths to executables -GRBINDEX=${TRACKER}/bin/grbindex -GETTRK=${TRACKER}/bin/gettrk - -# Set up the work directory and cd into it -workdir=${FIM_HOME}/FIMrun/fim_${GLVL}_${NVL}_${PES}_${yyyymmddhhmm}/tracker_${MEMBER_ID}/${T} -${RM} -rf ${workdir} -${MKDIR} -p ${workdir} -cd ${workdir} - -# Extract initialization time components -YYYY=`${ECHO} ${yyyymmddhhmm} | ${CUT} -c1-4` -MM=`${ECHO} ${yyyymmddhhmm} | ${CUT} -c5-6` -DD=`${ECHO} ${yyyymmddhhmm} | ${CUT} -c7-8` -HH=`${ECHO} ${yyyymmddhhmm} | ${CUT} -c9-10` -YY=`${DATE} -u +%y -d "${MM}/${DD}/${YYYY}"` -JJJ=`${DATE} -u +%j -d "${MM}/${DD}/${YYYY}"` - -# Generate the ATCFNAME for this member -ATCFNAME=`echo ${ATCFNAME} | sed "s/NN/${MEMBER_ID}/"` - -# Extract fields needed by tracker for each output time and concatenate them together to produce a big forecast file -fcst_file=./${yyyymmddhhmm}.grib.${ATCFNAME} -rm -f ${fcst_file} -typeset -Z4 fcst -fcst=0 -while [ ${fcst} -le ${T} ]; do - - # Get name of the post file - postfile=${FIM_HOME}/FIMrun/fim_${GLVL}_${NVL}_${PES}_${yyyymmddhhmm}/post_${MEMBER_ID}/fim/NAT/grib1/${YY}${JJJ}${HH}00${fcst} - - # Extract fields from the post file and append them to the fcst_file - ${WGRIB} -v ${postfile} | egrep "(HGT:500 mb|UGRD:500 mb|UGRD:850 mb|UGRD:700 mb|UGRD:250 mb|UGRD:200 mb|UGRD:hybrid lev 1:|VGRD:500 mb|VGRD:850 mb|VGRD:700 mb|VGRD:250 mb|VGRD:200 mb|VGRD:hybrid lev 1:|TMP:700 mb|ACPCP:sfc|NCPCP:sfc|MSLMA:MSL)" | ${WGRIB} -i ${postfile} -append -grib -o ${fcst_file} - - (( fcst = ${fcst} + ${FCST_INTERVAL} )) - -done - -# Run grbindex to get a grib index file -${GRBINDEX} ${fcst_file} ${fcst_file}.ix - -# Extract the tcvital record -#tcvital=${TCVITALS}/syndat_tcvitals.${YYYY} -#tcvital=${TCVITALS}/${yyyymmddhhmm}.tcvitals -#tcvital=${TCVITALS}/tcvitals.${yyyymmddhhmm}* -tcvital=${TCVITALS}/tcvitals.${YYYY}${MM}${DD}${HH}.txt -${CAT} ${tcvital} | grep "${YYYY}${MM}${DD} ${HH}00" | ${SORT} | ${UNIQ} > tcvital.txt - -# Create link for output track -${LN} -s track.${yyyymmddhhmm}.${ATCFNAME} fort.64 - -# Determine the length of the forecast -fcst_length=`${WGRIB} ${fcst_file} | ${CUT} -d":" -f 9 | ${CUT} -d"=" -f 2 | ${SORT} | ${TAIL} -1` - -# Generate a list of forecast times to process based on what's in the input grib file -i=0 -while [ ${i} -lt 65 ]; do - (( fcst = i * 6 )) - if [ ${fcst} -gt ${fcst_length} ]; then - itmphrs[i]=99 - else - itmphrs[i]=${fcst} - fi - (( i=i+1 )) -done - -# Generate stswitch based on how many storms there are in the tcvital file -nstorms=`${CAT} tcvital.txt | ${AWK} '{print $2}' | ${SORT} | ${UNIQ} | ${WC} -l` - -i=0 -while [ ${i} -lt 15 ]; do - if [ ${i} -lt ${nstorms} ]; then - stswitch[i]=1 - else - stswitch[i]=3 - fi - (( i=i+1 )) -done - -# Generate the namelist -${CAT} < namelist -&datein - inp%byy=${YY}, - inp%bmm=${MM}, - inp%bdd=${DD}, - inp%bhh=${HH}, - inp%model=7 -/ -&stormlist - stswitch = ${stswitch[*]} -/ -&fhlist - itmphrs = ${itmphrs[*]} -/ -&atcfinfo - atcfnum=81, - atcfname='${ATCFNAME}', - atcfymdh=${YYYY}${MM}${DD}${HH} -/ -&phaseinfo - phaseflag='n', - phasescheme='cps' -/ -&structinfo - structflag='n', - ikeflag='n' -/ - -EOF - -# Create an empty track file -touch track.${yyyymmddhhmm}.${ATCFNAME} - -# Run gettrk -${RM} -f fort.11 -${RM} -f fort.12 -${RM} -f fort.31 -${LN} -s ${fcst_file} fort.11 -${LN} -s ${fcst_file}.ix fort.31 -${LN} -s tcvital.txt fort.12 -${GETTRK} < namelist -error=$? -if [ ${error} -ne 0 ]; then - ${ECHO} "ERROR: ${GETTRK} crashed Exit status=${error}" - exit ${error} -fi - -# Create individual track files for each storm -stormids=`${CAT} track.${yyyymmddhhmm}.${ATCFNAME} | ${AWK} '{print $1 $2}' | ${TR} -d , | ${SORT} | ${UNIQ}` -${ECHO} $stormids -for storm in ${stormids[*]}; do - area=`${ECHO} ${storm} | ${CUT} -c1-2` - num=`${ECHO} ${storm} | ${CUT} -c3-4` - ${AWK} "/${area}, ${num}/" track.${yyyymmddhhmm}.${ATCFNAME} > ${area}${num}-${yyyymmddhhmm}.tracker.${ATCFNAME} -done - -exit 0 diff --git a/src/fim/FIMrun/bsubfim b/src/fim/FIMrun/bsubfim deleted file mode 100755 index 6b4005e..0000000 --- a/src/fim/FIMrun/bsubfim +++ /dev/null @@ -1,174 +0,0 @@ -#!/bin/ksh - -# Usage: bsubfim [directory] -# -#TODO: Need a better naming convention since "bsubfim" -#TODO: addresses LSF-specific and bluefire site-specific -#TODO: issues. -# -# submits FIM job to LSF on bluefire -# -# If directory argument is present, assume we are running via test automation, cd -# to the specified directory, set the sync option, submit FIM job to LSF and wait -# until it finishes. -# -# All other variables are set the FIMnamelist file. - -#TODO: Remove duplication with other ?subfim scripts! - -CONTEXT="bsubfim" - -# Source shared-functions code & set up tracing -. ./functions.ksh # Most function definitions can be found here. -set +o xtrace # comment out to enable verbose bsubfim trace - -ksh_check # Verify that ksh93 is running/available. - -if [[ "$#" -eq 0 ]] # Not a test-suite run -then - sync="" -elif [[ "$#" -eq 1 ]] # Test-suite run -then - test -d "$1" || fail "Run directory not found: $1." - cd $1 || fail "Cannot cd to $1." - sync="-K" -else - fail "Too many arguments." -fi - -set_fimnamelist - -FIMSETUP="fim_setup.ksh" - -# Make sure FIMnamelist exists -test -f "$fimnamelist" || \ - fail "Please \"cp ${fimnamelist}.default $fimnamelist\" and edit the latter \ -appropriately." - -# Get SRCDIR & make absolute -get_srcdir # This must always come before any other get_* calls -cd $SRCDIR || fail "Cannot cd to $SRCDIR" -SRCDIR="$PWD" -cd - - -# Set up run directory -rundir="bsubfim_$$" -mkdir $rundir || fail "Cannot make directory $rundir" -print "Made directory $rundir." -copyfiles $PWD $rundir || fail "Cannot copy contents of $PWD -> $rundir" -copyfiles $SRCDIR/bin $rundir || \ - fail "Cannot copy contents of $SRCDIR/bin -> $rundir" -cp $SRCDIR/$FIMSETUP $rundir || \ - fail "Cannot cpy $SRCDIR/$FIMSETUP -> $rundir." -cd $rundir || fail "Cannot cd to $rundir." - -ksh_fix # Modify run scripts to use ksh93, if necessary. - -# Get number of cores to ask for (on IBM this is the number of cores to pass to MPI) -./get_num_cores | grep "num_cores_mpirun:" | sed 's/^.*://' | read N || \ - fail "Could not get num_cores_mpirun." - -get_from_nl ComputeTasks as PES - -# Find out if we'll run serial or parallel and set up appropriately -get_from_nl Parallelism as parallelism -if [[ "$parallelism" == "parallel" ]] -then - FIM="fim" - ParaSuffix="$PES" - if (( PES <= 0 )) ; then - fail "ComputeTasks must be positive" - fi -else - FIM="fimS" - ParaSuffix="S" -fi - -# Set up run-time environment -get_fc || fail "$0: Could not set FC." -xsource_notrace ./$FIMSETUP $FC - -# Determine other runtime parameters -get_from_nl GLVL -get_from_nl NVL -# for bluefire IBM, strip ":SS" off of "HH:MM:SS" in $QT -./GetQueueTime | cut -f-2 -d":" | read QT || fail "GetQueueTime failed" - -# Choose a run queue -#Q="regular" -Q="debug" - -# Do COMPARE_VAR setup -compare_var_setup - -#JR Currently use_task_geometry must be false. Allocation of cores to compute tasks -#JR and write tasks is handled internally to FIM -# If use_task_geometry is enabled, uncomment the following section -use_task_geometry="no" - -## Set up "task geometry" -## Map MPI tasks to IBM nodes using "LSB_PJL_TASK_GEOMETRY" -## See ./set_task_geometry.ksh for details. -## Set mctpn = "maximum compute tasks per node" -## For the moment, limit mctpn to number of cores per node. -##TODO: Try (( mctpn = 2 * cpn )) for SMT once hybrid MPI-OpenMP works. -##TODO: SMT reference: http://www.cisl.ucar.edu/docs/bluefire/be_quickstart.html#smt -#if [[ $use_task_geometry == "yes" ]] -#then -# (( mctpn = cpn )) -# task_geometry=$( ./set_task_geometry.ksh $PES $nwt $mwtpn $mctpn ) -# if (( $? != 0 )) ; then -# fail "task_geometry" -# fi -# sed -i 's:\(SYSTEMnamelist.*$\):\1\n! Set automatically by bsubfim\n LSB_PJL_TASK_GEOMETRY="$task_geometry":' FIMnamelist -#fi - -# Diagnostics - -check_nems - -./get_num_cores | grep "num_cores_donothing:" | sed 's/^.*://' | read dnt || \ - fail "Could not get num_cores_donothing." - -./get_num_cores | grep "num_nodes_wt:" | sed 's/^.*://' | read num_nodes_wt || \ - fail "Could not get num_nodes_wt." - -./get_num_cores | grep "num_cores_notattached:" | sed 's/^.*://' | read num_cores_notattached || \ - fail "Could not get num_cores_notattached." - -./get_num_cores | grep "num_cores_batch:" | sed 's/^.*://' | read num_cores_batch || \ - fail "Could not get num_cores_batch." - -print "Submitting job to queue $Q" -print "compute tasks: $PES" -print "write tasks: $nwt (write nodes: $num_nodes_wt)" -print "do_nothing tasks: $dnt" -print "total core request: $num_cores_batch (no partial nodes)" -print "cores unattached: $num_cores_notattached" - -SUBMIT_CMD="bsub" -SUBMIT_ARGS="-P 46660020 \ - -n $N \ - -J fim${GLVL}_${NVL}_${ParaSuffix} \ - -o fim${GLVL}_${NVL}_${ParaSuffix}.o%J \ - -e fim${GLVL}_${NVL}_${ParaSuffix}.e%J \ - -q $Q \ - -W $QT \ - $sync \ - -R 'span[ptile=64]'" - -# Create script for later potential submission to restart the job -cat > bsubfim.restart < prep_chem_sources.inp - ./prep_chem_sources || fail "ERROR: prep_chem_sources failed." - linksafe FIM-T-${emiss_date}0000-plume.bin plumestuff.dat - linksafe FIM-T-${emiss_date}0000-OC-bb.bin ebu_oc.dat - linksafe FIM-T-${emiss_date}0000-BC-bb.bin ebu_bc.dat - linksafe FIM-T-${emiss_date}0000-PM25-bb.bin ebu_pm25.dat - linksafe FIM-T-${emiss_date}0000-PM10-bb.bin ebu_pm10.dat - linksafe FIM-T-${emiss_date}0000-SO2-bb.bin ebu_so2.dat - linksafe FIM-T-${emiss_date}0000-SULF-bb.bin ebu_sulf.dat - if [[ $test_suite -eq 0 ]] - then - if [[ -s "FIM-T-${emiss_date}0000-g1-volc.bin" ]] - then - linksafe FIM-T-${emiss_date}0000-g1-volc.bin volcanic.dat - fi - fi - - print "chem_opt_value: $chem_opt_value" - chem_in_opt_value=$(get_chem_in_opt_value) - print "chem_in_opt_value: $chem_in_opt_value" - if [[ $chem_in_opt_value == "1" ]] - then - if [[ -n "$WFM" && $init_date_dir != "NOT FOUND" ]] - then - if [[ $chem_opt_value == "317" ]] - then - linksafe ${init_date_dir}/fim_out_ash1000${fcst}${ARCHVTIMEUNIT} vash1.in - linksafe ${init_date_dir}/fim_out_ash2000${fcst}${ARCHVTIMEUNIT} vash2.in - linksafe ${init_date_dir}/fim_out_ash3000${fcst}${ARCHVTIMEUNIT} vash3.in - linksafe ${init_date_dir}/fim_out_ash4000${fcst}${ARCHVTIMEUNIT} vash4.in - fi - if [[ $chem_opt_value == "502" ]] - then - linksafe ${init_date_dir}/fim_out_ash1000${fcst}${ARCHVTIMEUNIT} vash1.in - linksafe ${init_date_dir}/fim_out_ash2000${fcst}${ARCHVTIMEUNIT} vash2.in - linksafe ${init_date_dir}/fim_out_ash3000${fcst}${ARCHVTIMEUNIT} vash3.in - linksafe ${init_date_dir}/fim_out_ash4000${fcst}${ARCHVTIMEUNIT} vash4.in - fi - if [[ $chem_opt_value -ge "300" && $chem_opt_value -lt "400" ]] - then - linksafe ${init_date_dir}/fim_out_s4ea000${fcst}${ARCHVTIMEUNIT} seas4.in - linksafe ${init_date_dir}/fim_out_s3ea000${fcst}${ARCHVTIMEUNIT} seas3.in - linksafe ${init_date_dir}/fim_out_s2ea000${fcst}${ARCHVTIMEUNIT} seas2.in - linksafe ${init_date_dir}/fim_out_s1ea000${fcst}${ARCHVTIMEUNIT} seas1.in - linksafe ${init_date_dir}/fim_out_sulf000${fcst}${ARCHVTIMEUNIT} sulf.in - linksafe ${init_date_dir}/fim_out_pso2000${fcst}${ARCHVTIMEUNIT} so2.in - linksafe ${init_date_dir}/fim_out_pbc2000${fcst}${ARCHVTIMEUNIT} bc2.in - linksafe ${init_date_dir}/fim_out_pbc1000${fcst}${ARCHVTIMEUNIT} bc1.in - linksafe ${init_date_dir}/fim_out_obc2000${fcst}${ARCHVTIMEUNIT} oc2.in - linksafe ${init_date_dir}/fim_out_obc1000${fcst}${ARCHVTIMEUNIT} oc1.in - linksafe ${init_date_dir}/fim_out_d5st000${fcst}${ARCHVTIMEUNIT} dust5.in - linksafe ${init_date_dir}/fim_out_d4st000${fcst}${ARCHVTIMEUNIT} dust4.in - linksafe ${init_date_dir}/fim_out_d3st000${fcst}${ARCHVTIMEUNIT} dust3.in - linksafe ${init_date_dir}/fim_out_d2st000${fcst}${ARCHVTIMEUNIT} dust2.in - linksafe ${init_date_dir}/fim_out_d1st000${fcst}${ARCHVTIMEUNIT} dust1.in - linksafe ${init_date_dir}/fim_out_pp25000${fcst}${ARCHVTIMEUNIT} p25.in - linksafe ${init_date_dir}/fim_out_pp10000${fcst}${ARCHVTIMEUNIT} p10.in - linksafe ${init_date_dir}/fim_out_dms1000${fcst}${ARCHVTIMEUNIT} dms.in - linksafe ${init_date_dir}/fim_out_pmsa000${fcst}${ARCHVTIMEUNIT} msa.in - fi - if [[ $chem_opt_value == "500" ]] - then - linksafe ${init_date_dir}/fim_out_c13D000${fcst}${ARCHVTIMEUNIT} tr1.in - linksafe ${init_date_dir}/fim_out_c23D000${fcst}${ARCHVTIMEUNIT} tr2.in - fi - fi - fi - fi -} - -function get_runtime -{ - yr=$(expr substr $yyyymmddhhmm 1 4) - mm=$(expr substr $yyyymmddhhmm 5 2) - dd=$(expr substr $yyyymmddhhmm 7 2) - hh=$(expr substr $yyyymmddhhmm 9 2) -} - -function get_last_run_date -{ - get_runtime - print "in get_last_run_date: yr: $yr mm: $mm dd: $dd hh: $hh" - typeset -Z3 tmp_fcst - tmp_fcst=0 - found=0 - while [[ $found -eq 0 ]] - do - tmp_fcst=$(expr ${tmp_fcst} + 12) - dirDate=$(date +%Y%m%d%H -u -d "$mm/$dd/$yr $hh:00 $tmp_fcst hours ago") - dir=$FIM_HOME/FIMrun/fim_${GLVL}_${NVL}_${PES}_${dirDate}00/fim_${MEMBER_ID} - print "checking: ${dir}/fim_out_dms1000${tmp_fcst}${ARCHVTIMEUNIT}" - if [[ -s ${dir}/fim_out_hgtP000${tmp_fcst}${ARCHVTIMEUNIT} ]] - then - found=1 - init_date_dir=$dir - print "FOUND init_date_dir: $init_date_dir" - fi - fcst=$tmp_fcst - if [[ $fcst -gt 120 ]] - then - print "ERROR " - init_date_dir="NOT FOUND" - found=1 - fi - done -} - -function chem_prep_newname -{ - test $CHEMFLAG == "true" && (./newname.exe || fail "newname failed") -} - -function chem_prep_setup -{ - if [[ $CHEMFLAG == "true" ]] - then - test -z "$CHEM_DATADIR" && get_nl_value_unquoted $NLFILE QUEUEnamelist chem_datadir CHEM_DATADIR - test_suite && linksafe $CHEM_DATADIR/volcanic.dat - for x in erod_binary gocart_backgd_littlee dm0_binary anthro_binary \ - chemltln.dat - do - linksafe $CHEM_DATADIR/$x - done - linksafe $BINDIR/newname.exe - fi -} diff --git a/src/fim/FIMrun/dpsig100.txt b/src/fim/FIMrun/dpsig100.txt deleted file mode 100644 index 6c0c5b1..0000000 --- a/src/fim/FIMrun/dpsig100.txt +++ /dev/null @@ -1,100 +0,0 @@ - 250.0000 - 250.0000 - 250.0000 - 250.0000 - 275.0000 - 300.0000 - 350.0000 - 400.0000 - 437.5000 - 475.0000 - 512.5000 - 550.0000 - 587.5000 - 625.0000 - 662.5000 - 700.0000 - 737.5000 - 775.0000 - 812.5000 - 850.0000 - 887.5000 - 925.0000 - 962.5000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 - 1000.000 diff --git a/src/fim/FIMrun/dpsig38.txt b/src/fim/FIMrun/dpsig38.txt deleted file mode 100644 index 8447a15..0000000 --- a/src/fim/FIMrun/dpsig38.txt +++ /dev/null @@ -1,38 +0,0 @@ - 330 510 800 1000 1200 1500 2000 2000 2000 2000 -2000 2000 2000 2000 2000 2000 2000 2000 2000 2000 -2000 2000 2000 2000 2000 2000 2000 2000 2000 2000 -2000 2000 2000 2000 2000 2000 2000 2000 ----------------------------------------------------------- -other choices: - - 300 400 500 600 700 800 900 1000 1000 1000 -1000 1000 1000 1000 1000 1000 1000 1000 1000 1000 -1000 1000 1000 1000 1000 1000 1000 1000 1000 1000 -1000 1000 1000 1000 1000 1000 1000 1000 1000 1000 -1000 1000 1000 1000 1000 1000 1000 1000 1000 1000 -1000 1000 1000 1000 1000 1000 1000 1000 1000 1000 -1000 1000 1000 1000 - - 330 510 675 825 960 1080 1185 1275 1350 1410 -1455 1485 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 - - 250 500 650 800 950 1100 1250 1400 1550 1700 -1850 2000 2000 2000 2000 2000 2000 2000 2000 2000 -2000 2000 2000 2000 2000 2000 2000 2000 2000 2000 -2000 2000 2000 2000 2000 2000 2000 2000 2000 2000 -2000 2000 2000 2000 2000 2000 2000 2000 2000 2000 -2000 2000 2000 2000 2000 2000 2000 2000 2000 2000 -2000 2000 2000 2000 - - 200 300 400 500 500 500 500 500 500 500 - 500 500 500 500 500 500 500 500 500 500 - 500 500 500 500 500 500 500 500 500 500 - 500 500 500 500 500 500 500 500 500 500 - 500 500 500 500 500 500 500 500 500 500 - 500 500 500 500 500 500 500 500 500 500 - 500 500 500 500 diff --git a/src/fim/FIMrun/dpsig50.txt b/src/fim/FIMrun/dpsig50.txt deleted file mode 100644 index 6282835..0000000 --- a/src/fim/FIMrun/dpsig50.txt +++ /dev/null @@ -1,50 +0,0 @@ -250. -500. -650. -800. -950. -1100. -1250. -1400. -1550. -1700. -1850. -2000. -2000. -2000. -2000. -2000. -2000. -2000. -2000. -2000. -2000. -2000. -2000. -2000. -2000. -2000. -2000. -2000. -2000. -2000. -2000. -2000. -2000. -2000. -2000. -2000. -2000. -2000. -2000. -2000. -2000. -2000. -2000. -2000. -2000. -2000. -2000. -2000. -2000. -2000. diff --git a/src/fim/FIMrun/dpsig64.txt b/src/fim/FIMrun/dpsig64.txt deleted file mode 100644 index 4901796..0000000 --- a/src/fim/FIMrun/dpsig64.txt +++ /dev/null @@ -1,41 +0,0 @@ - 330 510 675 825 960 1080 1185 1275 1350 1410 -1455 1485 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 ----------------------------------------------------------- -other choices: - - 300 400 500 600 700 800 900 1000 1000 1000 -1000 1000 1000 1000 1000 1000 1000 1000 1000 1000 -1000 1000 1000 1000 1000 1000 1000 1000 1000 1000 -1000 1000 1000 1000 1000 1000 1000 1000 1000 1000 -1000 1000 1000 1000 1000 1000 1000 1000 1000 1000 -1000 1000 1000 1000 1000 1000 1000 1000 1000 1000 -1000 1000 1000 1000 - - 330 510 675 825 960 1080 1185 1275 1350 1410 -1455 1485 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 - - 250 500 650 800 950 1100 1250 1400 1550 1700 -1850 2000 2000 2000 2000 2000 2000 2000 2000 2000 -2000 2000 2000 2000 2000 2000 2000 2000 2000 2000 -2000 2000 2000 2000 2000 2000 2000 2000 2000 2000 -2000 2000 2000 2000 2000 2000 2000 2000 2000 2000 -2000 2000 2000 2000 2000 2000 2000 2000 2000 2000 -2000 2000 2000 2000 - - 200 300 400 500 500 500 500 500 500 500 - 500 500 500 500 500 500 500 500 500 500 - 500 500 500 500 500 500 500 500 500 500 - 500 500 500 500 500 500 500 500 500 500 - 500 500 500 500 500 500 500 500 500 500 - 500 500 500 500 500 500 500 500 500 500 - 500 500 500 500 diff --git a/src/fim/FIMrun/dpsig64_10.txt b/src/fim/FIMrun/dpsig64_10.txt deleted file mode 100644 index 22cb374..0000000 --- a/src/fim/FIMrun/dpsig64_10.txt +++ /dev/null @@ -1,41 +0,0 @@ - 300 400 500 600 700 800 900 1000 1000 1000 -1000 1000 1000 1000 1000 1000 1000 1000 1000 1000 -1000 1000 1000 1000 1000 1000 1000 1000 1000 1000 -1000 1000 1000 1000 1000 1000 1000 1000 1000 1000 -1000 1000 1000 1000 1000 1000 1000 1000 1000 1000 -1000 1000 1000 1000 1000 1000 1000 1000 1000 1000 -1000 1000 1000 1000 ----------------------------------------------------------- -other choices: - - 300 400 500 600 700 800 900 1000 1000 1000 -1000 1000 1000 1000 1000 1000 1000 1000 1000 1000 -1000 1000 1000 1000 1000 1000 1000 1000 1000 1000 -1000 1000 1000 1000 1000 1000 1000 1000 1000 1000 -1000 1000 1000 1000 1000 1000 1000 1000 1000 1000 -1000 1000 1000 1000 1000 1000 1000 1000 1000 1000 -1000 1000 1000 1000 - - 330 510 675 825 960 1080 1185 1275 1350 1410 -1455 1485 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 - - 250 500 650 800 950 1100 1250 1400 1550 1700 -1850 2000 2000 2000 2000 2000 2000 2000 2000 2000 -2000 2000 2000 2000 2000 2000 2000 2000 2000 2000 -2000 2000 2000 2000 2000 2000 2000 2000 2000 2000 -2000 2000 2000 2000 2000 2000 2000 2000 2000 2000 -2000 2000 2000 2000 2000 2000 2000 2000 2000 2000 -2000 2000 2000 2000 - - 200 300 400 500 500 500 500 500 500 500 - 500 500 500 500 500 500 500 500 500 500 - 500 500 500 500 500 500 500 500 500 500 - 500 500 500 500 500 500 500 500 500 500 - 500 500 500 500 500 500 500 500 500 500 - 500 500 500 500 500 500 500 500 500 500 - 500 500 500 500 diff --git a/src/fim/FIMrun/dpsig64_15.txt b/src/fim/FIMrun/dpsig64_15.txt deleted file mode 100644 index 4901796..0000000 --- a/src/fim/FIMrun/dpsig64_15.txt +++ /dev/null @@ -1,41 +0,0 @@ - 330 510 675 825 960 1080 1185 1275 1350 1410 -1455 1485 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 ----------------------------------------------------------- -other choices: - - 300 400 500 600 700 800 900 1000 1000 1000 -1000 1000 1000 1000 1000 1000 1000 1000 1000 1000 -1000 1000 1000 1000 1000 1000 1000 1000 1000 1000 -1000 1000 1000 1000 1000 1000 1000 1000 1000 1000 -1000 1000 1000 1000 1000 1000 1000 1000 1000 1000 -1000 1000 1000 1000 1000 1000 1000 1000 1000 1000 -1000 1000 1000 1000 - - 330 510 675 825 960 1080 1185 1275 1350 1410 -1455 1485 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 - - 250 500 650 800 950 1100 1250 1400 1550 1700 -1850 2000 2000 2000 2000 2000 2000 2000 2000 2000 -2000 2000 2000 2000 2000 2000 2000 2000 2000 2000 -2000 2000 2000 2000 2000 2000 2000 2000 2000 2000 -2000 2000 2000 2000 2000 2000 2000 2000 2000 2000 -2000 2000 2000 2000 2000 2000 2000 2000 2000 2000 -2000 2000 2000 2000 - - 200 300 400 500 500 500 500 500 500 500 - 500 500 500 500 500 500 500 500 500 500 - 500 500 500 500 500 500 500 500 500 500 - 500 500 500 500 500 500 500 500 500 500 - 500 500 500 500 500 500 500 500 500 500 - 500 500 500 500 500 500 500 500 500 500 - 500 500 500 500 diff --git a/src/fim/FIMrun/dpsig64_20.txt b/src/fim/FIMrun/dpsig64_20.txt deleted file mode 100644 index 1a98106..0000000 --- a/src/fim/FIMrun/dpsig64_20.txt +++ /dev/null @@ -1,41 +0,0 @@ - 250 500 650 800 950 1100 1250 1400 1550 1700 -1850 2000 2000 2000 2000 2000 2000 2000 2000 2000 -2000 2000 2000 2000 2000 2000 2000 2000 2000 2000 -2000 2000 2000 2000 2000 2000 2000 2000 2000 2000 -2000 2000 2000 2000 2000 2000 2000 2000 2000 2000 -2000 2000 2000 2000 2000 2000 2000 2000 2000 2000 -2000 2000 2000 2000 ----------------------------------------------------------- -other choices: - - 300 400 500 600 700 800 900 1000 1000 1000 -1000 1000 1000 1000 1000 1000 1000 1000 1000 1000 -1000 1000 1000 1000 1000 1000 1000 1000 1000 1000 -1000 1000 1000 1000 1000 1000 1000 1000 1000 1000 -1000 1000 1000 1000 1000 1000 1000 1000 1000 1000 -1000 1000 1000 1000 1000 1000 1000 1000 1000 1000 -1000 1000 1000 1000 - - 330 510 675 825 960 1080 1185 1275 1350 1410 -1455 1485 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 1500 1500 1500 1500 1500 1500 -1500 1500 1500 1500 - - 250 500 650 800 950 1100 1250 1400 1550 1700 -1850 2000 2000 2000 2000 2000 2000 2000 2000 2000 -2000 2000 2000 2000 2000 2000 2000 2000 2000 2000 -2000 2000 2000 2000 2000 2000 2000 2000 2000 2000 -2000 2000 2000 2000 2000 2000 2000 2000 2000 2000 -2000 2000 2000 2000 2000 2000 2000 2000 2000 2000 -2000 2000 2000 2000 - - 200 300 400 500 500 500 500 500 500 500 - 500 500 500 500 500 500 500 500 500 500 - 500 500 500 500 500 500 500 500 500 500 - 500 500 500 500 500 500 500 500 500 500 - 500 500 500 500 500 500 500 500 500 500 - 500 500 500 500 500 500 500 500 500 500 - 500 500 500 500 diff --git a/src/fim/FIMrun/fim.configure.G4 b/src/fim/FIMrun/fim.configure.G4 deleted file mode 100644 index 47fd97c..0000000 --- a/src/fim/FIMrun/fim.configure.G4 +++ /dev/null @@ -1,277 +0,0 @@ - -#TBH: Note that settings in this file work for a -#TBH: G5 24-hour run. We need a way to generate this file -#TBH: automatically from FIMnamelist. And a way to set -#TBH: "dt_int" and its duplicate "deltim", during the model -#TBH: run since FIM computes these on-the-fly. . - -#TBH: I have commented out any field not needed by FIM. -#TBH: Eventually remove them after debugging. - -############################### -######## Debug Prints ######### -############################### -# turns on "iprint" in module_ERR_MSG.F90 for loquacious prints -iprint: false - -############################### -######## Model Core ########### -############################### - -core: fim # The dynamic core options: - # nmm - # gfs - # fim - # arw - - -############################### -##### Grid Specifications ##### -############################### - -#im: 230 # I gridpoints -#jm: 141 # J gridpoints -#lm: 60 # Number of atmospheric layers - -#tph0d: 40. # Central geographic latitude of grid (degrees) -#tlm0d: -100. # Central geographic longitude of grid (degrees, positive east) - -#wbd: -22.9 # Grid's western boundary (rotated degrees) -#sbd: -14.0 # Grid's southern boundary (rotated degrees) - - -############################## -##### Grid Decomposition ##### -############################## - -#inpes: 04 # Number of compute tasks in the I direction -#jnpes: 03 # Number of compute tasks in the J direction - - -############################### -#### Specify the I/O tasks #### -############################### - -#quilting: false # Do you want asynchronous quilting/history writes? -#read_groups: 0 -#read_tasks_per_group: 0 -#write_groups: 3 -#write_tasks_per_group: 1 - - -########################################## -##### Fundamental Timestep (seconds) ##### -########################################## - -dt_int: 720 # Integer seconds -dt_num: 0 # Numerator of fractional second -dt_den: 1 # Denominator of fractional second - - -############################### -##### Forecast Start Time ##### -############################### - -start_year: 2007 -###start_month: 04 -###start_day: 15 -###start_hour: 12 -start_month: 07 -start_day: 17 -start_hour: 00 -start_minute: 0 -start_second: 0 - -tstart: 0. # The starting forecast hour - - -########################### -##### Forecast Length ##### -########################### - -nhours_fcst: 24 # Length of the forecast (hours) - -#TBH: this replaces nhours_history in nems r11258 -#nhours_history: 01 # Frequency of history output (hours) -nfhout: 1 -#TBH: specify output frequency in time steps if nsout>0 -nsout: 0 -#TBH: seems redundant with dt_int, see job/exglobal_fcst.sh.sms_nems -deltim: 720.0 # real seconds, deltim="${dt_int}.0" - -#restart: false # True--> A restarted run - - -######################### -##### General modes ##### -######################### - -#global: true # True--> Global ; False--> Regional -#hydro: false # True--> Hydrostatic ; False--> Nonhydrostatic -#JR adiabatic true not yet implemented -adiabatic: false # True--> Adiabatic ; False--> Diabatic - - -############################## -##### Lateral Boundaries ##### -############################## - -#specified: true -#nested: false - - -#################### -##### Dynamics ##### -#################### - -#secadv: true # True--> 2nd order advection ; False--> 4th order advection - -#secdif: true # True--> 2nd order diffusion ; False--> 4th order diffusion -#smag2: 0.2 # Smagorinsky constant for 2nd order diffusion -#smag4: 1.3 # Smagorinsky constant for 4th order diffusion - -#codamp: 9.0 # Divergence damping constant -#wcor: 0.0075 # Divergence correction factor - -#pwrc: 1.0 # Fourier filter factor - -#idtad: 2 # Number of adjustment timesteps between passive advection calls - -#advect_tracers: false # Will tracers be advected? -#idtadt: 4 # Number of adjustment timesteps between tracer advection calls (normally 1) - -#num_tracers_met: 4 # Number of specified meterological "tracer" scalars (e.g., water) -#num_tracers_chem: 0 # Number of specified chem/aerosol "tracer" scalars - -######################################## -##### Read/Write Global Summations ##### -######################################## - -#read_global_sums: false # Read in global summations or not -#write_global_sums: false # Write out global summations or not - - -################################## -### Precipitation Assimilation#### -################################## - -#pcpflg: false # True--> assimilation on ; False--> assimilation off - - -################################## -##### Physics Scheme Options ##### -################################## -#--------------------------------- -#shortwave: gfdl # Radiation schemes -#longwave: gfdl - # gfdl--> GFDL (shortwave and longwave) - # gsfc--> Goddard shortwave - # dudh--> Dudhia shortwave - # rrtm--> RRTM longwave - -#co2tf: 1 # co2tf--> Read (0) or generate internally (1) - # the GFDL CO2 transmission functions - -#--------------------------------- -#convection: bmj # Convection scheme - # bmj--> Betts-Miller-Janjic - # kf--> Kain-Fritsch - # sas--> Simplified Arakawa-Schubert - # gd--> Grell-Devenyi - -#--------------------------------- -#microphysics: fer # Microphysics scheme - # fer--> Ferrier - # kes--> Kessler - # lin--> Lin - # tho--> Thompson - -#--------------------------------- -#turbulence: myj # Turbulence schemes - # fer--> Ferrier - # kes--> Kessler - # lin--> Lin - # tho--> Thompson - -#--------------------------------- - -#sfc_layer: myj # Surface layer schemes - # myj--> Mellor-Yamada-Jamnjic - # mm5--> MM5 sfc layer - -#--------------------------------- - -#land_surface: noah # Land surface schemes - # nmm--> LSM NMM - # noah--> NOAH scheme - -#ucmcall: 0 # Use (1) or do not use (0) the Urban Canopy Model - -#--------------------------------- - -#gfs: false # Select entire GFS physics suite - - -############################# -##### Physics Timesteps ##### -############################# - -#nrads: 100 # Number of dynamics timesteps between calls to shortwave -#nradl: 100 # Number of dynamics timesteps between calls to longwave - -#nphs: 4 # Number of dynamics timesteps between calls to landsurface and turbulence - -#nprecip: 4 # Number of dynamics timesteps between calls to convection and microphysics - -#nhrs_prec: 6 # Frequency in hours between times when precip arrays are emptied -#nhrs_heat: 3 # Frequency in hours between times when heating arrays are emptied -#nhrs_clod: 3 # Frequency in hours between times when cloud arrays are emptied -#nhrs_rdlw: 3 # Frequency in hours between times when LW radiation arrays are emptied -#nhrs_rdsw: 3 # Frequency in hours between times when SW radiation arrays are emptied -#nhrs_srfc: 3 # Frequency in hours between times when sfc evap/flux arrays are emptied - - -####################################### -#### Write History Specifications #### -####################################### - -#write_flag: .TRUE. # True--> Yes write history files - -#io_unit: -999 -#io_file: 'DEFERRED' - -#------------------------------------------------- -# If IO_FILE == 'DEFERRED', use FILENAME_BASE -# as the first part of the history file names. -#------------------------------------------------- -#filename_base: 'nmm_b_history.' -#io_status: 'REPLACE' -#io_access: 'SEQUENTIAL' -#io_form: 'UNFORMATTED' -#io_recl: 100 -#io_position: ' ' -#io_action: 'WRITE' -#io_delim: ' ' -#io_pad: ' ' - -####################################### -#### timing info #### -####################################### -nhours_clocktime: 1 # Frequency in hours between clocktime diagnostic prints. -npe_print: 1 # The MPI task that will provide the clocktimes. - - -# -# New config flags from nems r11258 -# TODO: eliminate obsolete flags above... -# - -########################## -#### Ensemble flags #### -########################## - -ENS_SPS: .FALSE. -total_member: 1 -RUN_CONTINUE: .FALSE. - - diff --git a/src/fim/FIMrun/fim.configure.G5 b/src/fim/FIMrun/fim.configure.G5 deleted file mode 100644 index 6544d95..0000000 --- a/src/fim/FIMrun/fim.configure.G5 +++ /dev/null @@ -1,277 +0,0 @@ - -#TBH: Note that settings in this file work for a -#TBH: G5 24-hour run. We need a way to generate this file -#TBH: automatically from FIMnamelist. And a way to set -#TBH: "dt_int" and its duplicate "deltim", during the model -#TBH: run since FIM computes these on-the-fly. . - -#TBH: I have commented out any field not needed by FIM. -#TBH: Eventually remove them after debugging. - -############################### -######## Debug Prints ######### -############################### -# turns on "iprint" in module_ERR_MSG.F90 for loquacious prints -iprint: false - -############################### -######## Model Core ########### -############################### - -core: fim # The dynamic core options: - # nmm - # gfs - # fim - # arw - - -############################### -##### Grid Specifications ##### -############################### - -#im: 230 # I gridpoints -#jm: 141 # J gridpoints -#lm: 60 # Number of atmospheric layers - -#tph0d: 40. # Central geographic latitude of grid (degrees) -#tlm0d: -100. # Central geographic longitude of grid (degrees, positive east) - -#wbd: -22.9 # Grid's western boundary (rotated degrees) -#sbd: -14.0 # Grid's southern boundary (rotated degrees) - - -############################## -##### Grid Decomposition ##### -############################## - -#inpes: 04 # Number of compute tasks in the I direction -#jnpes: 03 # Number of compute tasks in the J direction - - -############################### -#### Specify the I/O tasks #### -############################### - -#quilting: false # Do you want asynchronous quilting/history writes? -#read_groups: 0 -#read_tasks_per_group: 0 -#write_groups: 3 -#write_tasks_per_group: 1 - - -########################################## -##### Fundamental Timestep (seconds) ##### -########################################## - -dt_int: 360 # Integer seconds -dt_num: 0 # Numerator of fractional second -dt_den: 1 # Denominator of fractional second - - -############################### -##### Forecast Start Time ##### -############################### - -start_year: 2007 -###start_month: 04 -###start_day: 15 -###start_hour: 12 -start_month: 07 -start_day: 17 -start_hour: 00 -start_minute: 0 -start_second: 0 - -tstart: 0. # The starting forecast hour - - -########################### -##### Forecast Length ##### -########################### - -nhours_fcst: 24 # Length of the forecast (hours) - -#TBH: this replaces nhours_history in nems r11258 -#nhours_history: 01 # Frequency of history output (hours) -nfhout: 1 -#TBH: specify output frequency in time steps if nsout>0 -nsout: 0 -#TBH: seems redundant with dt_int, see job/exglobal_fcst.sh.sms_nems -deltim: 720.0 # real seconds, deltim="${dt_int}.0" - -#restart: false # True--> A restarted run - - -######################### -##### General modes ##### -######################### - -#global: true # True--> Global ; False--> Regional -#hydro: false # True--> Hydrostatic ; False--> Nonhydrostatic -#JR adiabatic true not yet implemented -adiabatic: false # True--> Adiabatic ; False--> Diabatic - - -############################## -##### Lateral Boundaries ##### -############################## - -#specified: true -#nested: false - - -#################### -##### Dynamics ##### -#################### - -#secadv: true # True--> 2nd order advection ; False--> 4th order advection - -#secdif: true # True--> 2nd order diffusion ; False--> 4th order diffusion -#smag2: 0.2 # Smagorinsky constant for 2nd order diffusion -#smag4: 1.3 # Smagorinsky constant for 4th order diffusion - -#codamp: 9.0 # Divergence damping constant -#wcor: 0.0075 # Divergence correction factor - -#pwrc: 1.0 # Fourier filter factor - -#idtad: 2 # Number of adjustment timesteps between passive advection calls - -#advect_tracers: false # Will tracers be advected? -#idtadt: 4 # Number of adjustment timesteps between tracer advection calls (normally 1) - -#num_tracers_met: 4 # Number of specified meterological "tracer" scalars (e.g., water) -#num_tracers_chem: 0 # Number of specified chem/aerosol "tracer" scalars - -######################################## -##### Read/Write Global Summations ##### -######################################## - -#read_global_sums: false # Read in global summations or not -#write_global_sums: false # Write out global summations or not - - -################################## -### Precipitation Assimilation#### -################################## - -#pcpflg: false # True--> assimilation on ; False--> assimilation off - - -################################## -##### Physics Scheme Options ##### -################################## -#--------------------------------- -#shortwave: gfdl # Radiation schemes -#longwave: gfdl - # gfdl--> GFDL (shortwave and longwave) - # gsfc--> Goddard shortwave - # dudh--> Dudhia shortwave - # rrtm--> RRTM longwave - -#co2tf: 1 # co2tf--> Read (0) or generate internally (1) - # the GFDL CO2 transmission functions - -#--------------------------------- -#convection: bmj # Convection scheme - # bmj--> Betts-Miller-Janjic - # kf--> Kain-Fritsch - # sas--> Simplified Arakawa-Schubert - # gd--> Grell-Devenyi - -#--------------------------------- -#microphysics: fer # Microphysics scheme - # fer--> Ferrier - # kes--> Kessler - # lin--> Lin - # tho--> Thompson - -#--------------------------------- -#turbulence: myj # Turbulence schemes - # fer--> Ferrier - # kes--> Kessler - # lin--> Lin - # tho--> Thompson - -#--------------------------------- - -#sfc_layer: myj # Surface layer schemes - # myj--> Mellor-Yamada-Jamnjic - # mm5--> MM5 sfc layer - -#--------------------------------- - -#land_surface: noah # Land surface schemes - # nmm--> LSM NMM - # noah--> NOAH scheme - -#ucmcall: 0 # Use (1) or do not use (0) the Urban Canopy Model - -#--------------------------------- - -#gfs: false # Select entire GFS physics suite - - -############################# -##### Physics Timesteps ##### -############################# - -#nrads: 100 # Number of dynamics timesteps between calls to shortwave -#nradl: 100 # Number of dynamics timesteps between calls to longwave - -#nphs: 4 # Number of dynamics timesteps between calls to landsurface and turbulence - -#nprecip: 4 # Number of dynamics timesteps between calls to convection and microphysics - -#nhrs_prec: 6 # Frequency in hours between times when precip arrays are emptied -#nhrs_heat: 3 # Frequency in hours between times when heating arrays are emptied -#nhrs_clod: 3 # Frequency in hours between times when cloud arrays are emptied -#nhrs_rdlw: 3 # Frequency in hours between times when LW radiation arrays are emptied -#nhrs_rdsw: 3 # Frequency in hours between times when SW radiation arrays are emptied -#nhrs_srfc: 3 # Frequency in hours between times when sfc evap/flux arrays are emptied - - -####################################### -#### Write History Specifications #### -####################################### - -#write_flag: .TRUE. # True--> Yes write history files - -#io_unit: -999 -#io_file: 'DEFERRED' - -#------------------------------------------------- -# If IO_FILE == 'DEFERRED', use FILENAME_BASE -# as the first part of the history file names. -#------------------------------------------------- -#filename_base: 'nmm_b_history.' -#io_status: 'REPLACE' -#io_access: 'SEQUENTIAL' -#io_form: 'UNFORMATTED' -#io_recl: 100 -#io_position: ' ' -#io_action: 'WRITE' -#io_delim: ' ' -#io_pad: ' ' - -####################################### -#### timing info #### -####################################### -nhours_clocktime: 1 # Frequency in hours between clocktime diagnostic prints. -npe_print: 1 # The MPI task that will provide the clocktimes. - - -# -# New config flags from nems r11258 -# TODO: eliminate obsolete flags above... -# - -########################## -#### Ensemble flags #### -########################## - -ENS_SPS: .FALSE. -total_member: 1 -RUN_CONTINUE: .FALSE. - - diff --git a/src/fim/FIMrun/fim_gribtable b/src/fim/FIMrun/fim_gribtable deleted file mode 100644 index b89ad88..0000000 --- a/src/fim/FIMrun/fim_gribtable +++ /dev/null @@ -1,135 +0,0 @@ - FIM Table 1: variable definitions for GRIB - (note: * indicates NCEP needs to permanatly assign number) - GRIB GRIB - iparm ztype iz1 iz2 itr iscale ABBREV UNITS - -u-component of wind - b 33 109 1 US3D_B m/s -v-component of wind - b 34 109 1 VS3D_B m/s -height - b 7 109 1 PH3D_B gpm -pressure - b 1 109 0 PR3D_B Pa -virtual potential temperature - b 189 109 2 TH3D_B K -temperature - b 11 109 1 TK3D_B K -dew-point temperature - b 17 109 1 TD3D_B K -water vapor mixing ratio - b 53 109 5 QV3D_B -vertical velocity - b 39 109 1 WS3D_B Pa/s -cloud water mixing ratio - b 153 109 6 QW3D_B Kg/Kg -ozone mixing ratio - b 154 109 8 OZ3D_B Kg/Kg -u-component of wind - p 33 100 1 US3D_P m/s -v-component of wind - p 34 100 1 VS3D_P m/s -height - p 7 100 1 PH3D_P gpm -pressure - p 1 100 0 PR3D_P Pa -virtual potential temperature - p 189 100 2 TH3D_P K -temperature - p 11 100 1 TK3D_P K -dew-point temperature - p 17 100 1 TD3D_P K -water vapor mixing ratio - p 53 100 5 QV3D_P -vertical velocity - p 39 100 1 WS3D_P Pa/s -cloud water mixing ratio - p 153 100 6 QW3D_P Kg/Kg -ozone mixing ratio - p 154 100 8 OZ3D_P Kg/Kg -sensible heat flux 122 1 1 HF2D W/m**2 -latent heat flux 121 1 1 QF2D W/m**2 -outgoing top of atmosphere LW flux 123 1 1 ol2D W/m**2 -soil temperature at level 1 below surface 85 111 5 2 ST_1 K -soil temperature at level 2 below surface 85 111 20 2 ST_2 K -soil temperature at level 3 below surface 85 111 40 2 ST_3 K -soil temperature at level 4 below surface 85 111 160 2 ST_4 K -soil moisture content at level 1 86 111 5 4 SM_1 kg/m**2 -soil moisture content at level 2 86 111 20 4 SM_2 kg/m**2 -soil moisture content at level 3 86 111 40 4 SM_3 kg/m**2 -soil moisture content at level 4 86 111 160 4 SM_4 kg/m**2 -water equivalent of snow depth 65 1 5 SN2D m -net longwave radiation at surface 112 1 1 LW2D W/m**2 -net shortwave radiation at surface 111 1 1 SW2D W/m**2 -relative humidity - b 52 109 2 RH3D_B % -montgomery stream function - b 37 109 2 MP3D_B m**2/s**2 -pressure thickness - b 172 109 1 DP3D_B Pa -relative humidity - p 52 100 2 RP3D % -montgomery stream function - p 37 100 2 MP3D_P m**2/s**2 -pressure thickness - p 172 100 1 DP3D_P Pa -total precipitation accumulative 61 1 4 2 RN2D mm -total precipitation 61 1 2 R12D mm -grid scale precipitation accumulative 62 1 4 2 RG2D mm -grid scale precipitation 62 1 2 R32D mm -convective precipitation accumulative 63 1 4 2 RC2D mm -convective precipitation 63 1 2 R22D mm -precipitable water 54 1 1 PW2D kg/m**2 -skin temperature 11 1 2 TS2D K -Friction velocity 253 1 1 US2D m/s -MAPS mean sea level pressure 129 102 -1 MS2D Pa -u-component of wind - p 33 100 1 UP3P m/s -v-component of wind - p 34 100 1 VP3P m/s -u-component of wind, 10m fixed height 33 105 10 1 U12D m/s -v-component of wind, 10m fixed height 34 105 10 1 V12D m/s -height - p 7 100 1 HGTP gpm -relative humidity - p 52 100 2 RP3P % -relative humidity - p 52 100 2 RP3P_B % -temperature - p 11 100 1 TMPP K -grid point latitude 207 1 5 LAT deg -grid point longitude 208 1 5 LON deg -PBL height 221 1 0 -gust wind speed 180 1 0 -cloud base height 7 2 0 CB2D m -cloud top height 7 3 0 CT2D m -visibility 20 1 0 -maximum equivalent potential temperature pressure 1 246 2 -convective cloud top height 7 243 1 -equilibrium level height 7 247 1 -convective cloud mass flux 231 1 2 -wet-bulb zero height 7 245 1 -radar reflectivity - max 212 200 8 1 -radar reflectivity - 1km 211 105 1000 8 1 -radar reflectivity - 4km 211 105 4000 8 1 -relative humidity w.r.t. precipitable water 223 200 8 2 RP2D % -soil type 224 1 0 -hydrophobic organic carbon - b 136 109 3 OBC1_B ug/kg -hydrophillic organic carbon - b 137 109 3 OBC2_B ug/kg -hydrophobic black carbon - b 138 109 3 PBC1_B ug/kg -hydrophillic black carbon - b 139 109 3 PBC2_B ug/kg -prmary pm25 - b 140 109 3 PP25_B ug/kg -sulfate - b 141 109 7 SULF_B ppm -so2 - b 142 109 7 PSO2_B ppm -dms - b 143 109 7 DMS1_B ppm -fine dust - b 145 109 3 D1ST_B ug/kg -coarse dust - b 146 109 3 D2ST_B ug/kg -hydrophobic organic carbon - p 136 100 3 OBC1_P ug/kg -hydrophillic organic carbon - p 137 100 3 OBC2_P ug/kg -hydrophobic black carbon - p 138 100 3 PBC1_P ug/kg -hydrophillic black carbon - p 139 100 3 PBC2_P ug/kg -prmary pm25 - p 140 100 3 PP25_P ug/kg -sulfate - p 141 100 7 SULF_P ppm -so2 - p 142 100 7 PSO2_P ppm -dms - p 143 100 7 DMS1_P ppm -fine dust - p 145 100 3 D1ST_P ug/kg -coarse dust - p 146 100 3 D2ST_P ug/kg -Integrated PM25 130 1 3 IA2D ug/m3 -Integrated organic carbon 131 1 3 IO2D ug/kg -Integrated black carbon 132 1 3 IB2D ug/kg -Integrated sulf 133 1 7 IS2D ppm -Integrated fine dust 134 1 3 ID2D ug/kg -Aerosol Optical Depth 135 1 2 AO2D ug/kg -Ash1 160 109 3 ASH1_B ug/kg -Ash2 161 109 3 ASH2_B ug/kg -Ash3 162 109 3 ASH3_B ug/kg -Ash4 163 109 3 ASH4_B ug/kg -Integrated Ash 164 1 3 IASH ug/kg -Ces1 165 109 3 C13D_B ug/kg -Ces2 166 109 3 C23D_B ug/kg -fallout 167 1 3 FL2D ug/kg -hydrophillic organic carbon - p 233 100 3 OC1P ug/kg -hydrophillic organic carbon - p 234 100 3 OC2P ug/kg -hydrophobic black carbon - p 235 100 3 BC1P ug/kg -hydrophobic black carbon - p 236 100 3 BC2P ug/kg -so2 - p 237 100 7 SO2P ppm -sulfate - p 238 100 7 SLFP ppm -dust1 - p 239 100 3 D1SP ppm -dust2 - p 240 100 3 D2SP ppm -dust3 - p 241 100 3 D3SP ppm -dust4 - p 242 100 3 D4SP ppm -dust5 - p 244 100 3 D5SP ppm -seasalt1 - p 248 100 3 S1SP ppm -seasalt2 - p 249 100 3 S2SP ppm -seasalt3 - p 250 100 3 S3SP ppm -seasalt4 - p 251 100 3 S4SP ppm -dms - p 252 100 7 DMSP ppm -msa - p 254 100 7 MSAP ppm -prmary pm25 - p 155 100 3 P25P ug/kg -prmary pm10 - p 156 100 3 P10P ug/kg diff --git a/src/fim/FIMrun/fim_gribtable_FIMCES b/src/fim/FIMrun/fim_gribtable_FIMCES deleted file mode 100644 index 888dc90..0000000 --- a/src/fim/FIMrun/fim_gribtable_FIMCES +++ /dev/null @@ -1,103 +0,0 @@ - FIM Table 1: variable definitions for GRIB - (note: * indicates NCEP needs to permanatly assign number) - GRIB GRIB - iparm ztype iz1 iz2 itr iscale ABBREV UNITS - -u-component of wind - b 33 109 1 US3D_B m/s -v-component of wind - b 34 109 1 VS3D_B m/s -height - b 7 109 1 PH3D_B gpm -pressure - b 1 109 0 PR3D_B Pa -virtual potential temperature - b 189 109 2 TH3D_B K -temperature - b 11 109 1 TK3D_B K -dew-point temperature - b 17 109 1 TD3D_B K -water vapor mixing ratio - b 53 109 5 QV3D_B -vertical velocity - b 39 109 1 WS3D_B Pa/s -cloud water mixing ratio - b 153 109 6 QW3D_B Kg/Kg -ozone mixing ratio - b 154 109 8 OZ3D_B Kg/Kg -u-component of wind - p 33 100 1 US3D_P m/s -v-component of wind - p 34 100 1 VS3D_P m/s -height - p 7 100 1 PH3D_P gpm -pressure - p 1 100 0 PR3D_P Pa -virtual potential temperature - p 189 100 2 TH3D_P K -temperature - p 11 100 1 TK3D_P K -dew-point temperature - p 17 100 1 TD3D_P K -water vapor mixing ratio - p 53 100 5 QV3D_P -vertical velocity - p 39 100 1 WS3D_P Pa/s -cloud water mixing ratio - p 153 100 6 QW3D_P Kg/Kg -ozone mixing ratio - p 154 100 8 OZ3D_P Kg/Kg -sensible heat flux 122 1 1 HF2D W/m**2 -latent heat flux 121 1 1 QF2D W/m**2 -soil temperature at level 1 below surface 85 111 5 2 ST_1 K -soil temperature at level 2 below surface 85 111 20 2 ST_2 K -soil temperature at level 3 below surface 85 111 40 2 ST_3 K -soil temperature at level 4 below surface 85 111 160 2 ST_4 K -soil moisture content at level 1 86 111 5 4 SM_1 kg/m**2 -soil moisture content at level 2 86 111 20 4 SM_2 kg/m**2 -soil moisture content at level 3 86 111 40 4 SM_3 kg/m**2 -soil moisture content at level 4 86 111 160 4 SM_4 kg/m**2 -water equivalent of snow depth 65 1 5 SN2D m -net longwave radiation at surface 112 1 1 LW2D W/m**2 -net shortwave radiation at surface 111 1 1 SW2D W/m**2 -relative humidity - b 52 109 2 RH3D_B % -montgomery stream function - b 37 109 2 MP3D_B m**2/s**2 -pressure thickness - b 172 109 1 DP3D_B Pa -relative humidity - p 52 100 2 RP3D % -montgomery stream function - p 37 100 2 MP3D_P m**2/s**2 -pressure thickness - p 172 100 1 DP3D_P Pa -total precipitation accumulative 61 1 4 2 RN2D mm -total precipitation 61 1 2 R12D mm -grid scale precipitation accumulative 62 1 4 2 RG2D mm -grid scale precipitation 62 1 2 R32D mm -convective precipitation accumulative 63 1 4 2 RC2D mm -convective precipitation 63 1 2 R22D mm -precipitable water 54 1 1 PW2D kg/m**2 -skin temperature 11 1 2 TS2D K -Friction velocity 253 1 1 US2D m/s -MAPS mean sea level pressure 129 102 -1 MS2D Pa -u-component of wind - p 33 100 1 UP3P m/s -v-component of wind - p 34 100 1 VP3P m/s -height - p 7 100 1 HGTP gpm -relative humidity - p 52 100 2 RP3P % -relative humidity - p 52 100 2 RP3P_B % -temperature - p 11 100 1 TMPP K -grid point latitude 207 1 5 LAT deg -grid point longitude 208 1 5 LON deg -PBL height 221 1 0 -gust wind speed 180 1 0 -cloud base height 7 2 0 CB2D m -cloud top height 7 3 0 CT2D m -visibility 20 1 0 -maximum equivalent potential temperature pressure 1 246 2 -convective cloud top height 7 243 1 -equilibrium level height 7 247 1 -convective cloud mass flux 231 1 2 -wet-bulb zero height 7 245 1 -radar reflectivity - max 212 200 8 1 -radar reflectivity - 1km 211 105 1000 8 1 -radar reflectivity - 4km 211 105 4000 8 1 -relative humidity w.r.t. precipitable water 223 200 8 2 -soil type 224 1 0 -hydrophobic organic carbon - b 136 109 3 OBC1_B ug/kg -hydrophillic organic carbon - b 137 109 3 OBC2_B ug/kg -hydrophobic black carbon - b 138 109 3 PBC1_B ug/kg -hydrophillic black carbon - b 139 109 3 PBC2_B ug/kg -prmary pm25 - b 140 109 3 PP25_B ug/kg -sulfate - b 141 109 7 SULF_B ppm -so2 - b 142 109 7 PSO2_B ppm -dms - b 143 109 7 DMS1_B ppm -fine dust - b 145 109 3 D1ST_B ug/kg -coarse dust - b 146 109 3 D2ST_B ug/kg -Integrated PM25 130 1 3 IA2D ug/m3 -Integrated organic carbon 131 1 3 IO2D ug/kg -Integrated black carbon 132 1 3 IB2D ug/kg -Integrated sulf 133 1 7 IS2D ppm -Integrated fine dust 134 1 3 ID2D ug/kg -Aerosol Optical Depth 135 1 2 AO2D ug/kg -Ash1 160 109 3 ASH1_B ug/kg -Ash2 161 109 3 ASH2_B ug/kg -Ash3 162 109 3 ASH3_B ug/kg -Ash4 163 109 3 ASH4_B ug/kg -Integrated Ash 164 1 3 IASH ug/kg -Ces1 165 109 3 C13D_B ug/kg -Ces2 166 109 3 C23D_B ug/kg -fallout 167 1 3 FL2D ug/kg diff --git a/src/fim/FIMrun/fim_gribtable_FIMCO2 b/src/fim/FIMrun/fim_gribtable_FIMCO2 deleted file mode 100644 index 888dc90..0000000 --- a/src/fim/FIMrun/fim_gribtable_FIMCO2 +++ /dev/null @@ -1,103 +0,0 @@ - FIM Table 1: variable definitions for GRIB - (note: * indicates NCEP needs to permanatly assign number) - GRIB GRIB - iparm ztype iz1 iz2 itr iscale ABBREV UNITS - -u-component of wind - b 33 109 1 US3D_B m/s -v-component of wind - b 34 109 1 VS3D_B m/s -height - b 7 109 1 PH3D_B gpm -pressure - b 1 109 0 PR3D_B Pa -virtual potential temperature - b 189 109 2 TH3D_B K -temperature - b 11 109 1 TK3D_B K -dew-point temperature - b 17 109 1 TD3D_B K -water vapor mixing ratio - b 53 109 5 QV3D_B -vertical velocity - b 39 109 1 WS3D_B Pa/s -cloud water mixing ratio - b 153 109 6 QW3D_B Kg/Kg -ozone mixing ratio - b 154 109 8 OZ3D_B Kg/Kg -u-component of wind - p 33 100 1 US3D_P m/s -v-component of wind - p 34 100 1 VS3D_P m/s -height - p 7 100 1 PH3D_P gpm -pressure - p 1 100 0 PR3D_P Pa -virtual potential temperature - p 189 100 2 TH3D_P K -temperature - p 11 100 1 TK3D_P K -dew-point temperature - p 17 100 1 TD3D_P K -water vapor mixing ratio - p 53 100 5 QV3D_P -vertical velocity - p 39 100 1 WS3D_P Pa/s -cloud water mixing ratio - p 153 100 6 QW3D_P Kg/Kg -ozone mixing ratio - p 154 100 8 OZ3D_P Kg/Kg -sensible heat flux 122 1 1 HF2D W/m**2 -latent heat flux 121 1 1 QF2D W/m**2 -soil temperature at level 1 below surface 85 111 5 2 ST_1 K -soil temperature at level 2 below surface 85 111 20 2 ST_2 K -soil temperature at level 3 below surface 85 111 40 2 ST_3 K -soil temperature at level 4 below surface 85 111 160 2 ST_4 K -soil moisture content at level 1 86 111 5 4 SM_1 kg/m**2 -soil moisture content at level 2 86 111 20 4 SM_2 kg/m**2 -soil moisture content at level 3 86 111 40 4 SM_3 kg/m**2 -soil moisture content at level 4 86 111 160 4 SM_4 kg/m**2 -water equivalent of snow depth 65 1 5 SN2D m -net longwave radiation at surface 112 1 1 LW2D W/m**2 -net shortwave radiation at surface 111 1 1 SW2D W/m**2 -relative humidity - b 52 109 2 RH3D_B % -montgomery stream function - b 37 109 2 MP3D_B m**2/s**2 -pressure thickness - b 172 109 1 DP3D_B Pa -relative humidity - p 52 100 2 RP3D % -montgomery stream function - p 37 100 2 MP3D_P m**2/s**2 -pressure thickness - p 172 100 1 DP3D_P Pa -total precipitation accumulative 61 1 4 2 RN2D mm -total precipitation 61 1 2 R12D mm -grid scale precipitation accumulative 62 1 4 2 RG2D mm -grid scale precipitation 62 1 2 R32D mm -convective precipitation accumulative 63 1 4 2 RC2D mm -convective precipitation 63 1 2 R22D mm -precipitable water 54 1 1 PW2D kg/m**2 -skin temperature 11 1 2 TS2D K -Friction velocity 253 1 1 US2D m/s -MAPS mean sea level pressure 129 102 -1 MS2D Pa -u-component of wind - p 33 100 1 UP3P m/s -v-component of wind - p 34 100 1 VP3P m/s -height - p 7 100 1 HGTP gpm -relative humidity - p 52 100 2 RP3P % -relative humidity - p 52 100 2 RP3P_B % -temperature - p 11 100 1 TMPP K -grid point latitude 207 1 5 LAT deg -grid point longitude 208 1 5 LON deg -PBL height 221 1 0 -gust wind speed 180 1 0 -cloud base height 7 2 0 CB2D m -cloud top height 7 3 0 CT2D m -visibility 20 1 0 -maximum equivalent potential temperature pressure 1 246 2 -convective cloud top height 7 243 1 -equilibrium level height 7 247 1 -convective cloud mass flux 231 1 2 -wet-bulb zero height 7 245 1 -radar reflectivity - max 212 200 8 1 -radar reflectivity - 1km 211 105 1000 8 1 -radar reflectivity - 4km 211 105 4000 8 1 -relative humidity w.r.t. precipitable water 223 200 8 2 -soil type 224 1 0 -hydrophobic organic carbon - b 136 109 3 OBC1_B ug/kg -hydrophillic organic carbon - b 137 109 3 OBC2_B ug/kg -hydrophobic black carbon - b 138 109 3 PBC1_B ug/kg -hydrophillic black carbon - b 139 109 3 PBC2_B ug/kg -prmary pm25 - b 140 109 3 PP25_B ug/kg -sulfate - b 141 109 7 SULF_B ppm -so2 - b 142 109 7 PSO2_B ppm -dms - b 143 109 7 DMS1_B ppm -fine dust - b 145 109 3 D1ST_B ug/kg -coarse dust - b 146 109 3 D2ST_B ug/kg -Integrated PM25 130 1 3 IA2D ug/m3 -Integrated organic carbon 131 1 3 IO2D ug/kg -Integrated black carbon 132 1 3 IB2D ug/kg -Integrated sulf 133 1 7 IS2D ppm -Integrated fine dust 134 1 3 ID2D ug/kg -Aerosol Optical Depth 135 1 2 AO2D ug/kg -Ash1 160 109 3 ASH1_B ug/kg -Ash2 161 109 3 ASH2_B ug/kg -Ash3 162 109 3 ASH3_B ug/kg -Ash4 163 109 3 ASH4_B ug/kg -Integrated Ash 164 1 3 IASH ug/kg -Ces1 165 109 3 C13D_B ug/kg -Ces2 166 109 3 C23D_B ug/kg -fallout 167 1 3 FL2D ug/kg diff --git a/src/fim/FIMrun/fimxrsync.rb b/src/fim/FIMrun/fimxrsync.rb deleted file mode 100755 index 7735a27..0000000 --- a/src/fim/FIMrun/fimxrsync.rb +++ /dev/null @@ -1,56 +0,0 @@ -#!/usr/bin/ruby - -RSYNC="/usr/bin/rsync -vrLpgoDu -e ssh" -#BASEDIR="/lfs0/projects/rtfim/FIM/FIMrun" -BASEDIR="/lfs0/projects/rtfim/FIMX/FIMrun" -DEBUG=true -KEEP=2 - -# Get most recent run -now=Time.now.to_i -last_run=Time.at(now - now % (3600*12)) - -0.upto(KEEP-1) { |i| - - yyyymmddhhmm=(last_run - (i*3600*12)).strftime("%Y%m%d%H%M") - hh=(last_run - (i*3600*12)).strftime("%H").to_i - - Dir["#{BASEDIR}/fim_[0-9]*_[0-9]*_[0-9]*_#{yyyymmddhhmm}/post_C/fim/NAT/grib1"].each { |dir| - cmd="#{RSYNC} #{dir}/[0-9]* /rt/fimx/nat/grib1" - output=`#{cmd} 2>&1` - error=$?.exitstatus - puts output if DEBUG - if error != 0 - puts "ERROR: #{cmd} failed! Exit status=#{error}" - puts output - end - - } - - # Only rsync grib2 files that are valid at 00Z and 12Z - Dir["#{BASEDIR}/fim_[0-9]*_[0-9]*_[0-9]*_#{yyyymmddhhmm}/post_C/fim/NAT/grib2"].each { |dir| - files12Z=Dir["#{dir}/[0-9]*[0-9]"].delete_if {|file| (file.slice(-4,4).to_i % 12) != 0 }.join(" ") - cmd="#{RSYNC} #{files12Z} /rt/fimx/nat/grib2" - output=`#{cmd} 2>&1` - error=$?.exitstatus - puts output if DEBUG - if error != 0 - puts "ERROR: #{cmd} failed! Exit status=#{error}" - puts output - next - end - - } - - if File.exists?("#{BASEDIR}/fim_7_64_240_#{yyyymmddhhmm}/tracker_C/168") - cmd="#{RSYNC} --include '*track*' --include '*.grib.F7C' --include '*/' --exclude '*' #{BASEDIR}/fim_7_64_*_#{yyyymmddhhmm}/tracker_C/168/* /rt/fimx/tracker" - output=`#{cmd} 2>&1` - error=$?.exitstatus - puts output if DEBUG - if error != 0 - puts "ERROR: #{cmd} failed! Exit status=#{error}" - puts output - end - end - -} diff --git a/src/fim/FIMrun/functions.ksh b/src/fim/FIMrun/functions.ksh deleted file mode 100644 index d586543..0000000 --- a/src/fim/FIMrun/functions.ksh +++ /dev/null @@ -1,454 +0,0 @@ -# This code provides shared ksh functions for the run-automation scripts. - -function check_nems -{ - # Check that run configuration is NEMS-compatible - test -z "$FC" && fail "$0: FC undefined." - test -z "$COMPARE_VAR_ON" && fail "$0: COMPARE_VAR_ON undefined." - if [[ "$FC" == "nems" ]] - then - test "$COMPARE_VAR_ON" == ".true." && \ - fail "Cannot use NEMS with COMPARE_VAR." - # NEMS doesnt yet work when restart enabled - get_nl_value $fimnamelist OUTPUTnamelist readrestart READRESTART - test "$READRESTART" != ".false." && \ - fail "Cannot use NEMS with READRESTART." - fi -} - -function compare_var_setup -{ - # Please see ../README for a description of how to set up FIM to work with the - # SMS COMPARE_VAR feature. - - # TODO Replace this with encapsulated calls to SMS utility programs! - - COMPARE_VAR_ON="false" - COMPARE_VAR_NTASKS_1="0" - COMPARE_VAR_NTASKS_2="0" - smsnamelist="SMSnamelist" - - if [[ -f "$smsnamelist" ]] - then - get_nl_value_unquoted $smsnamelist SMSnamelist compare_var_on COMPARE_VAR_ON - test -z "$COMPARE_VAR_ON" && \ - fail "Cannot determine compare_var_on from $smsnamelist." - if [[ "$COMPARE_VAR_ON" == ".true." ]] - then - # sed: remove everything before ':' - print $(cd $fimnamelist_dir && $SRCDIR/bin/get_num_cores | \ - grep "root_own_node:") | sed 's/^.*://' | read TF || \ - fail "Could not get root_own_node." - test "$TF" == "TRUE" && \ - fail "COMPARE_VAR requires root_own_node to be false." - get_nl_value_unquoted $smsnamelist SMSnamelist compare_var_ntasks_1 \ - COMPARE_VAR_NTASKS_1 - test -z "$COMPARE_VAR_NTASKS_1" && \ - fail "Cannot determine compare_var_ntasks_1 from $smsnamelist." - get_nl_value_unquoted $smsnamelist SMSnamelist compare_var_ntasks_2 \ - COMPARE_VAR_NTASKS_2 - test -z "$COMPARE_VAR_NTASKS_2" && \ - fail "Cannot determine compare_var_ntasks_2 from $smsnamelist." - fi - fi - - # Write task info: needed only for compare_var test and diagnostic print - # sed: remove everything before ':' - print $(cd $fimnamelist_dir && $SRCDIR/bin/GetWriteTaskInfo | \ - grep "num_write_tasks") | sed 's/^.*://' | read nwt || \ - fail "Could not get num_write_tasks." - - # Perform error-checks on COMPARE_VAR options if COMPARE_VAR is enabled - if [[ "$COMPARE_VAR_ON" == ".true." ]] - then - # Cannot use COMPARE_VAR with write tasks - test "$nwt" -gt 0 && fail "Cannot use write tasks with COMPARE_VAR." - # Verify that FIMnamelist and SMSnamelist are set so that - # ComputeTasks == (COMPARE_VAR_NTASKS_1 + COMPARE_VAR_NTASKS_2) - let "testcomputetasks=$COMPARE_VAR_NTASKS_1+$COMPARE_VAR_NTASKS_2" || \ - fail "Arithmetic error." - test "$testcomputetasks" -ne "$PES" && \ - fail "COMPARE_VAR requires that ComputeTasks (in FIMnamelist) == \ -COMPARE_VAR_NTASKS_1 + COMPARE_VAR_NTASKS_2 (in SMSnamelist). Please correct." - # Cannot use COMPARE_VAR in a serial run - test "$parallelism" == "serial" && \ - fail "Cannot execute serial code with COMPARE_VAR yet." - fi - - # Create a more informative job name if COMPARE_VAR is used - test "$COMPARE_VAR_ON" == ".true." && \ - ParaSuffix="cv.$COMPARE_VAR_NTASKS_1.vs.$COMPARE_VAR_NTASKS_2" - -} - -function context_peek -{ - # Print the CONTEXT name most recently pushed onto the stack. - print $CONSTCK | sed "s/^\([^:][^:]*\).*/\1/" -} - -function context_pop -{ - # Pop a value of the context stack and set CONTEXT to its value. - CONTEXT=$(context_peek) - CONSTCK=$(print $CONSTCK | sed "s/^$CONTEXT[:]*//") -} - -function context_push -{ - # Push a context value onto the stack. - test -z "$1" && fail "No argument to push supplied." - test -z "$CONSTCK" && CONSTCK=$1 || CONSTCK="$1:$CONSTCK" -} - -function copyfiles -{ - test ! -d "$2" && fail "$2 is not a directory." - for fil in $(ls -1 $1) - do - pfil="${1}/${fil}" - if [[ -f "$pfil" ]] - then - cp $pfil $2 || fail "Cannot cp $pfil -> $2." - fi - done -} - -function endian_big -{ - # Enable big-endian handling of the space-separated list of logical unit - # numbers given as the function's argument. - # sed: replace spaces with commas - typeset luns1=$(print "$@" | sed 's/ /,/g') - # sed: insert '-T' at the beginning and ',-T' anywhere a space is found - typeset luns2=$(print "$@" | sed 's/^/-T/;s/ /,-T/g') - export F_UFMTENDIAN="big:$luns1" # intel - export FORT90L="-Wl,$luns2" # lahey - export GFORTRAN_CONVERT_UNIT="big_endian:$luns1" # gfortran - print "F_UFMTENDIAN=$F_UFMTENDIAN FORT90L=$FORT90L \ -GFORTRAN_CONVERT_UNIT=$GFORTRAN_CONVERT_UNIT" -} - -function endian_little -{ - # Enable little-endian handling of the space-separated list of logical unit - # numbers given as the function's argument. - # sed: replace spaces with commas - typeset luns1=$(print "$@" | sed 's/ /,/g') - export XLFRTEOPTS="ufmt_littleendian=$luns1" # ibm - print "XLFRTEOPTS=$XLFRTEOPTS" -} - -function endian_reset -{ - # Disable all endianness control variables. - unset F_UFMTENDIAN # intel - unset FORT90L # lahey - unset GFORTRAN_CONVERT_UNIT # gfortran - unset XLFRTEOPTS # ibm -} - -function errhandler -{ - # Handle trapped errors. The line number where the error occurred is expected - # as the sole argument. Print an error message including the failed line - # number, then re-enable xtrace, which presumably was disabled by trap_on(). - # This function is meant to be called by the trap mechanism, not directly by - # the sourcing script. It is also expected that the sourcing script will exit - # with an informative error message after this function returns. For example: - # - # cd /no/such/directory || fail "Cannot cd to /no/such/directory" - # - # will trigger errhandler() if trap_on() has previously been called. The - # failed line number will be reported and command passed back to the sourcing - # script, which will then fail with a more-informative message. - typeset LINE=$1 - print "$CONTEXT[$LINE]: An error occurred, see stdout" >&2 - set -o xtrace -} - -function fail -{ - # Print a failure message and terminate. - test -n "$1" && print "ERROR: $@" - exit 1 -} - -function get_nl_value -{ - # Return, in the specified variable, the value corresponding to the given - # namelist file, namelist and key. Any leading or trailing double or single - # quotes are removed. - # - # usage: get_nl_value namelist_file namelist key variable_to_set - # - # NOTE: This is a naive method for dealing with namelists. For example, a '!' - # inside a string value will be seen as the start of a comment, which - # will be deleted from that line. It's assumed that namelist names in - # the form '&namelist' are on lines by themselves, though the standard - # does not require this. And the wholesale conversion of tabs to spaces - # will modify strings containing literal tabs. This is ok now for FIM, - # but may someday need to be generalized. - - # Check the provided arguments. - test -f "$1" || fail "$0: namelist file '$1' not found." - test -z "$2" && fail "$0: no namelist supplied." - test -z "$3" && fail "$0: no key supplied." - test -z "$4" && fail "$0: no output variable name supplied." - # AIX sed does not recognize '\t'. Convert tabs to spaces, then consider only - # spaces as whitespace. - value="" - cat $1 | tr '\t' ' ' | while read line - do - # sed delete: 1. comments, 2. leading whitespace, 3. trailing whitespace, - # 4. namelist-termination lines, 5. blank lines. - x=$(print "$line" | sed "s/\!.*$//g;s/^ *//g;s/ *$//g;/^\//d;/^$/d") - # Try to recognize this line as a namelist name. - newnl=$(print "$x" | grep "^&[^ ][^ ]*" | sed 's/^&//') - # If namelist-name recognition succeeded, remember this name as the namelist - # we're currently in and loop back to consider the next line. - test -n "$newnl" && nl=$newnl && continue - # If we're here, the line doesn't look like a namelist name, so see if it - # contains the key we're looking for. If not, loop back for the next line. - print "$nl" | grep -qi $2 || continue - # If we're here, we're in the right namelist... - print "$x" | grep -qi "^$3 *=" || continue - # ...and if we're here, we've found the right key. Extract the value from - # the right of the equals sign. - value=$(print "$x" | sed "s/^$3 *= *//") - # We've got the value, so break out of the do loop. - break - done - # Set the specified variable name to the found value. - eval "$4=\"$value\"" -} - -function get_nl_value_unquoted -{ - # Get value via get_nl_value, then strip double and single quotes. - get_nl_value $* - eval "$4=\$(print \$$4 | tr -d '\"' | tr -d \"'\")" -} - -function export_nl -{ - # Export all variables defined in a namelist - # exports key=value pairs, where value is the whole string after the equals - # assignment and before any comments - # - # usage: export_nl namelist_file namelist - test -f "$1" || fail "$0: namelist file '$1' not found." - test -z "$2" && fail "$0: no namelist supplied." - # AIX sed does not recognize '\t'. Convert tabs to spaces, then consider only - # spaces as whitespace. - cat $1 | tr '\t' ' ' | while read line - do - # sed: 1. remove comments, 2. remove leading whitespace, 3. remove trailing - # whitespace, 4. delete blank lines, 5. delete namelist-termination - # lines (those starting with '/'), 6. delete blank lines. - x=$(print "$line" | sed 's/\!.*$//g;s/^ *//g;s/ *$//g;/^\//d;/^$/d') - # grep: look for an & followed by one or more non-whitespace characters - # sed: then, remove the leading & - newnl=$(print "$x" | grep "^&[^ ][^ ]*" | sed 's/^&//') - test -n "$newnl" && nl=$newnl && continue - print "$nl" | grep -qi $2 || continue - # sed: look for var=[something] and remove any extraneous whitespace - print "$x" | sed "s/^ *\(.[^ ]*\) *= *\(.[^\!]*\).*$/\1=\2/" | read y - eval "export $y" - done -} - -function get_fc -{ - # Special case not covered by get_from_nl - test -z "$SRCDIR" && fail "$0: SRCDIR undefined." - ./get_buildconfig.ksh $SRCDIR | read FC || fail "$FC" -} - -function get_from_nl -{ - # Extract namelist variables using the old Get* functions. Call as - # 'get_from_nl variable' OR 'get_from_nl function_name as variable', e.g. - # 'get_from_nl ComputeTasks as PES'. - test -z "$1" && fail "$0: no variable supplied." - if [[ -n "$2" && -z "$3" ]] - then - fail "Bad call to get_from_nl. Please call using one of the following \ -formats: 'get_from_nl GLVL', 'get_from_nl ComputeTasks as PES'." - elif [[ -z "$2" ]] - then - set "$1" "$1" "$1" # set $1, $2, and $3 to the value of $1 - elif [[ "$2" != "as" ]] - then - fail "Bad call to get_from_nl. When calling with multiple arguments, must \ -be in the format 'get_from_nl function_name as variable', e.g. 'get_from_nl \ -ComputeTasks as PES'." - fi - print $(cd $fimnamelist_dir && $SRCDIR/bin/Get$1) | read $3 || \ - fail "Get$1 failed (in $SRCDIR/bin/)." -} - -function get_srcdir -{ - # If $fimnamelist points to a readable file, try to extract SRCDIR from it - # using the wrapper binary. If the extracted value isn't a valid directory, - # suppose that we're running via qsubfim and are a level deeper (in a qsubfim_* - # directory) than expected and adjust for that. If we *still* don't have a - # directory, abort. WFM-driven runs are supposed to supply an absolute path - # for SRCDIR. Things would be simpler if we insisted on absolute paths across - # the board (TODO?) - test -r "$fimnamelist" || fail "$0: Cannot read file $fimnamelist" - fimnamelist_dir=$(print $fimnamelist | sed s:[^/]*$::) - get_nl_value_unquoted $fimnamelist QUEUEnamelist SRCDIR SRCDIR - test -d "$SRCDIR" || SRCDIR="$fimnamelist_dir/../$SRCDIR" - test -d "$SRCDIR" || fail "$0: Cannot set SRCDIR: $SRCDIR not found." - SRCDIR=$(cd $SRCDIR && print $PWD) -} - -function ksh_check -{ - # Check ksh version. If it is ksh93 (regardless of its name), simply return. - # Otherwise, see if a 'ksh93' binary is available: If so, we can later call - # ksh_fix() to use ksh93; if not, fail with an informative message. - test "$(ksh_version)" == "93" && return 0 - test -z $(whence ksh93) && ksh_insist -} - -function ksh_fix -{ - # If 'ksh93' is available on the user's path, modify the copied run-automation - # scripts to use it. - ksh_check && return - typeset KSH93 tmp x - KSH93=$(whence ksh93) - tmp=sed.tmp - for x in $(ls) - do - grep -q "^#!.*ksh" $x || continue - sed "s:^#\!.*ksh\(.*\):#\!$KSH93\1:" $x > $tmp || fail - mv $tmp $x || fail - chmod +x $x || fail - done -} - -function ksh_insist -{ - if [[ "$(ksh_version)" == "88" ]] - then - print " -FIM run automation requires ksh93. This appears to be ksh88. If you are running -via a queue-submission script, it may be sufficient to make 'ksh93' available on -your path (perhaps via a symbolic link) and re-run this script. If you are -calling run-automation scripts (e.g. batchTemplate-prep, via Workflow Manager) -directly, you may need to modify the scripts' initial #! lines to specify the -path to a ksh93 binary. -" - fail # Comment out to permit ksh88 use, at your own risk. - fi -} - -function ksh_version -{ - # SECONDS contains decimal in ksh93, but an integer in ksh88 and pdksh. - print $SECONDS | grep -q "\." && print 93 || print 88 -} - -function linksafe -{ - # Safely link files, throwing an error if the file to be linked is not found - # It allows both two- and one-argument use. In the latter case, the item gets - # linked into the current directory with the same name as the target (e.g. - # "linksafe /etc/passwd" would create a symlink called "passwd" in the current - # directory). - # TBH: This function now creates the link even if the source file is not - # found. And it attempts retries with delay first. See comments - # below. - test -z "$1" && fail "usage: linksafe target [link]" - test -z "$2" && link="$PWD" || link="$2" - typeset msg="Cannot link ($link -> $1)" - typeset nodename=$(uname -n) - # Introduce retries with delay here because the workflow manager retries an - # entire job step from scratch, re-creating directories. Thus any delay - # due to slow file systems will likely occur again. Delay here improves - # chances of success, although it is not possible to be fault-tolerant in - # the presence of file system misbehavior. - typeset delay=30 # delay time between retries (seconds) - typeset attempts_left=6 # number of times to try - while (( ${attempts_left} > 0 )); do - (( attempts_left -= 1 )) - test -e "$1" - if (( $? != 0 )) ; then - # For the moment, just warn because the source file may become - # visible on the desired node before we need it (parallel file - # systems, ick). - print "WARNING $msg: $1 not visible from $nodename at [$(date)]" - # fail "$msg: $1 not found" - if (( ${attempts_left} == 0 )); then - print "WARNING $msg: Creating dangling link anyway..." - else - sleep $delay - fi - else - (( attempts_left = 0 )) - fi - done - ln -s "$1" "$link" > /dev/null 2>&1 -} - -function set_fimnamelist -{ - fimnamelist="$PWD/FIMnamelist" -} - -function trap_off -{ - # Disable error trapping. - trap - ERR -} - -function trap_on -{ - # Enable error trapping. ksh issues the fake signal ERR when any command - # returns a non-zero status. When this function is called to enable trapping, - # subsequent commands in the sourcing script that return a non-zero status - # will trigger the trap. The trap 1) disables xtrace to prevent verbose - # tracing inside the error handler, and 2) calls the error handler with the - # line number of the failed command as its argument. - trap 'set +o xtrace;errhandler $LINENO' ERR -} - -function xsource -{ - # Save the current context, source the argument(s), then restore the previous - # context. Works recursively due to context stack. - test -z "$CONTEXT" && CONTEXT="unknown" - print $CONTEXT | grep -q ':' && fail "Colon not allowed in CONTEXT '$CONTEXT'." - context_push $CONTEXT - test -z "$XSOURCE_NOTRACE" && set -o xtrace - . $* || fail "Problem sourcing $1." - set +o xtrace - context_pop - set -o xtrace -} - -function xsource_notrace -{ - # Perform xsource but do not enable tracing of sourced script. - XSOURCE_NOTRACE=1 - xsource $* - unset XSOURCE_NOTRACE -} - -PS4='$CONTEXT[$LINENO]: ' - -# Turn on error trapping. - -trap_on - -# Record that this script has been sourced. - -functions_sourced="true" - -# Turn on xtrace. - -set -o xtrace diff --git a/src/fim/FIMrun/get_buildconfig.ksh b/src/fim/FIMrun/get_buildconfig.ksh deleted file mode 100755 index bd8eff6..0000000 --- a/src/fim/FIMrun/get_buildconfig.ksh +++ /dev/null @@ -1,15 +0,0 @@ -#!/bin/ksh -# -# Extracts FIM build configuration from $1, which must end with "FIMsrc_*", -# where "*" is the actual FIM build configuration (i.e. "openmpi", "lahey", -# etc.). - -function fail { print $@; exit 1; } - -test "$#" -ge 1 || fail "SRCDIR is empty: Please fix in namelist." -buildconfig=$(basename $1) -print $buildconfig | grep -q FIMsrc_..* || fail "Could not extract buildconfig \ -from SRCDIR in namelist: SRCDIR must end with FIMsrc_*." -print $buildconfig | cut -d_ -f2- - -return 0 diff --git a/src/fim/FIMrun/llsubmitfim b/src/fim/FIMrun/llsubmitfim deleted file mode 100755 index abc4597..0000000 --- a/src/fim/FIMrun/llsubmitfim +++ /dev/null @@ -1,241 +0,0 @@ -#!/bin/ksh - -# Usage: llsubmitfim [directory] -# -#TODO: Need a better naming convention since "llsubmitfim" -#TODO: addresses LoadLeveler-specific and devccs site-specific -#TODO: issues. -# -# submits FIM job to LoadLeveler on devccs (cirrus/stratus) -# -# If directory argument is present, assume we are running via test automation, cd -# to the specified directory, set the sync option, submit FIM job to LoadLeveler and wait -# until it finishes. -# -# All other variables are set the FIMnamelist file. - -#TODO: Remove duplication with other *fim job submission scripts! - -CONTEXT="llsubmitfim" - -# Source shared-functions code & set up tracing -. ./functions.ksh # Most function definitions can be found here. -set +o xtrace # comment out for verbose trace (ksh93 required) - -ksh_check # Verify that ksh93 is running/available. - -if [[ "$#" -eq 0 ]] # Not a test-suite run -then - sync="" -elif [[ "$#" -eq 1 ]] # Test-suite run -then - test -d "$1" || fail "Run directory not found: $1." - cd $1 || fail "Cannot cd to $1." - sync="-s" -else - fail "Too many arguments." -fi - -set_fimnamelist - -FIMSETUP="fim_setup.ksh" - -# Make sure FIMnamelist exists -test -f "$fimnamelist" || \ - fail "Please \"cp ${fimnamelist}.default $fimnamelist\" and edit the latter \ -appropriately." - -# Get SRCDIR & make absolute -get_srcdir # This must always come before any other get_* calls -cd $SRCDIR || fail "Cannot cd to $SRCDIR" -SRCDIR="$PWD" -cd - - -# Set up run directory -rundir="llsubmitfim_$$" -mkdir $rundir || fail "Cannot make directory $rundir" -print "Made directory $rundir" -copyfiles $PWD $rundir || fail "Cannot copy contents of $PWD -> $rundir" -copyfiles $SRCDIR/bin $rundir || \ - fail "Cannot copy contents of $SRCDIR/bin -> $rundir" -cp $SRCDIR/$FIMSETUP $rundir || \ - fail "Cannot cpy $SRCDIR/$FIMSETUP -> $rundir." -cd $rundir || fail "Cannot cd to $rundir." - -ksh_fix # Modify run scripts to use ksh93, if necessary. - -# Get number of cores to ask for (on IBM this is the number of cores to pass to MPI) -./get_num_cores | grep "num_cores_mpirun:" | sed 's/^.*://' | read N || \ - fail "Could not get num_cores_mpirun." - -get_from_nl ComputeTasks as PES - -# Find out if we'll run serial or parallel and set up appropriately -get_from_nl Parallelism as parallelism -if [[ "$parallelism" == "parallel" ]] -then - FIM="fim" - ParaSuffix="$PES" - if (( PES <= 0 )) ; then - fail "ComputeTasks must be positive" - fi -else - FIM="fimS" - ParaSuffix="S" -fi - -# Set up run-time environment -get_fc || fail "$0: Could not set FC." -xsource_notrace ./$FIMSETUP $FC - -# Determine other runtime parameters -get_from_nl GLVL -get_from_nl NVL -# HH:MM:SS -./GetQueueTime | read QT || fail "GetQueueTime failed" - -# Choose a run queue -Qgroup="mtb" -#Qclass="mtb" -Qclass="debug" - -# Do COMPARE_VAR setup -compare_var_setup - -#JR Currently use_task_geometry must be false. Allocation of cores to compute tasks -#JR and write tasks is handled internally to FIM -use_task_geometry="no" - -# Set up "task geometry" -# Map MPI tasks to IBM nodes using "LSB_PJL_TASK_GEOMETRY" -# See ./set_task_geometry.ksh for details. -# Set mctpn = "maximum compute tasks per node" -# For the moment, limit mctpn to number of cores per node. -#TODO: Try (( mctpn = 2 * cpn )) for SMT once hybrid MPI-OpenMP works. -#TODO: SMT references: http://www.cisl.ucar.edu/docs/bluefire/be_quickstart.html#smt -#TODO: https://userdocs.rdhpcs.noaa.gov/NCEP/ -#if [[ $use_task_geometry == "yes" ]] -#then -# (( mctpn = cpn )) -# task_geometry=$( ./set_task_geometry.ksh $compute_tasks $nwt $mwtpn $mctpn ) -# if (( $? != 0 )) ; then -# fail "task_geometry" -# fi -#fi - -#TODO: turn on #@task_geometry for devccs if applicable and see notes below - -## site-specific additions to $ENV_SETUP -# cat >> env_setup.ksh << EOF2 -## Doris Pan says we do not need TARGET_CPU_LIST anymore... -## TARGET_CPU_LIST from NEMS_r6890/job/runglobal -##export TARGET_CPU_LIST="-1" -#export MP_LABELIO="yes" -#EOF2 - -#TODO: fix $llnode to match #@task_geometry -#TODO: replace #@total_tasks=$N with task_geometry - -# Get number of nodes for llsubmit -./get_num_cores | grep "tot_nodes:" | sed 's/^.*://' | read tot_nodes || fail "Could not get tot_nodes." - -# Thanks to Doris Pan for much helpful advice about these site-specific settings for vapor. -# Doris Pan says: For runs that use all (or most) cores on a node, use the following -# settings: -# #@ node_usage=not_shared -# # do not set #@blocking -# #@ node_resources = ConsumableMemory (110GB) -# # do not set #@resources -# #@ node = -# FOR non-SMT MPI-only runs with 32 tasks per node: -# #@ task_affinity=core(1) -# FOR SMT MPI-only runs with 64 tasks per node: -# #@ task_affinity=cpu(1) -#TODO: fully implement the above rules -case $Qclass in - "debug") - llnode_usage="#@ node_usage = shared" - llnode="##@ node = 1" - llblocking="#@ blocking=unlimited" - llresources="#@ resources= ConsumableMemory (1GB)" - lltask_affinity="#@ task_affinity=cpu(1)" - ;; - "mtb") - llnode_usage="#@ node_usage = not_shared" - llnode="#@ node = $tot_nodes" - llblocking="##@ blocking=unlimited" - llresources="#@ node_resources= ConsumableMemory(110GB)" - lltask_affinity="#@ task_affinity=cpu(1)" - ;; - *) - fail "Unknown queue class: $Qclass" - ;; -esac - -cat > ll_preamble <> btwrapper.init || fail "echo ./batchTemplate >> btwrapper.init failed" -echo "./batchTemplate-restart" >> btwrapper.restart || fail "echo ./batchTemplate >> btwrapper.restart failed" - -chmod a+x btwrapper.init btwrapper.restart || fail "chmod btwrapper.init btwrapper.restart failed" - -# Diagnostics - -check_nems - -./get_num_cores | grep "num_cores_donothing:" | sed 's/^.*://' | read dnt || \ - fail "Could not get num_cores_donothing." - -./get_num_cores | grep "num_nodes_wt:" | sed 's/^.*://' | read num_nodes_wt || \ - fail "Could not get num_nodes_wt." - -./get_num_cores | grep "num_cores_notattached:" | sed 's/^.*://' | read num_cores_notattached || \ - fail "Could not get num_cores_notattached." - -./get_num_cores | grep "num_cores_batch:" | sed 's/^.*://' | read num_cores_batch || \ - fail "Could not get num_cores_batch." - -print "Submitting job to queue $Q" -print "compute tasks: $PES" -print "write tasks: $nwt (write nodes: $num_nodes_wt)" -print "do_nothing tasks: $dnt" -print "total core request: $num_cores_batch (no partial nodes)" -print "cores unattached: $num_cores_notattached" - -SUBMIT_CMD="llsubmit" - -$SUBMIT_CMD $sync btwrapper.init || fail "$SUBMIT_CMD failed" - -return 0 diff --git a/src/fim/FIMrun/model_configure b/src/fim/FIMrun/model_configure deleted file mode 100644 index 2ad6e79..0000000 --- a/src/fim/FIMrun/model_configure +++ /dev/null @@ -1,48 +0,0 @@ -####################### -#### Model Core ##### -####################### - -core: fim # Introduce ourselves to the NEMS - - -################################# -#### Specify the I/O tasks #### -################################# - -quilting: .false. # Do you want asynchronous quilting/history writes? -read_groups: 0 -read_tasks_per_group: 0 -write_groups: 0 -write_tasks_per_group: 0 - - -################################# -##### Forecast Start Time ##### -################################# - -start_year: 2007 -start_month: 07 -start_day: 17 -start_hour: 00 -start_minute: 0 -start_second: 0 - -tstart: 0. # The starting forecast hour - - -############################################################# -##### Forecast Length / Restarting / Output Frequency ##### -############################################################# - -nhours_fcst: 24 # Length of the forecast (hours) - - -########################## -#### Ensemble flags #### -########################## - -ENS_SPS: .FALSE. -total_member: 1 -RUN_CONTINUE: .FALSE. -PE_MEMBER01: 0 - diff --git a/src/fim/FIMrun/output_isobaric_levs.txt b/src/fim/FIMrun/output_isobaric_levs.txt deleted file mode 100644 index e46d025..0000000 --- a/src/fim/FIMrun/output_isobaric_levs.txt +++ /dev/null @@ -1,3 +0,0 @@ -43 -1000 975 950 925 900 875 850 825 800 775 750 725 700 675 650 625 600 575 550 -525 500 475 450 425 400 375 350 325 300 275 250 225 200 175 150 125 100 75 50 25 20 10 5 diff --git a/src/fim/FIMrun/qsubfim b/src/fim/FIMrun/qsubfim deleted file mode 100755 index 1c60aea..0000000 --- a/src/fim/FIMrun/qsubfim +++ /dev/null @@ -1,127 +0,0 @@ -#!/bin/ksh - -# Usage: qsubfim [directory] -# -# submits FIM job to SGE -# -# If directory argument is present, assume we are running via test automation -# and cd to the specified directory before submitting the job. -# -# All other variables are set the FIMnamelist file. - -# TODO Remove duplication with other ?subfim scripts! - -CONTEXT="qsubfim" - -# Source shared-functions code & set up tracing -. ./functions.ksh # Most function definitions can be found here. -set +o xtrace # Comment out to enable verbose qsubfim trace. - -ksh_check # Verify that ksh93 is running/available. - -test "$#" -gt 1 && fail "Too many arguments." - -if [[ "$#" -eq 1 ]] # assume this is a test-suite run -then - rundir="$1" - test -d "$rundir" || fail "Run directory not found: $rundir." - cd "$rundir" || fail "Cannot cd to $rundir." - Q="debug" -else - Q="ncomp" -fi - -set_fimnamelist - -FIMSETUP="fim_setup.ksh" - -# Make sure FIMnamelist exists -test -f "$fimnamelist" || \ - fail "Please \"cp ${fimnamelist}.default $fimnamelist\" and edit the latter \ -appropriately." - -# Get SRCDIR -get_srcdir # This must always come before any other get_* calls - -# Set up run directory -rundir="qsubfim_$$" -mkdir $rundir || fail "Cannot make directory $rundir." -print "Made directory $rundir" -copyfiles $PWD $rundir || fail "Cannot copy contents of $PWD -> $rundir." -copyfiles $SRCDIR/bin $rundir || \ - fail "Cannot copy contents of $SRCDIR/bin -> $rundir." -cp $SRCDIR/$FIMSETUP $rundir || \ - fail "Cannot cpy $SRCDIR/$FIMSETUP -> $rundir." -cd $rundir || fail "Cannot cd to $rundir." - -ksh_fix # Modify run scripts to use ksh93, if necessary. - -# Get number of cores to ask for -./get_num_cores | grep "num_cores_batch:" | sed 's/^.*://' | read N || \ - fail "Could not get num_cores_batch. $(./get_num_cores)" - -# Find out if we'll run serial or parallel and set up appropriately -get_from_nl ComputeTasks as PES || fail "$0: Could not set PES." -get_from_nl Parallelism as parallelism || fail "$0: Could not set parallelism." -if [[ "$parallelism" == "parallel" ]] -then - FIM="fim" - ParaSuffix="$PES" -else - FIM="fimS" - ParaSuffix="S" -fi - -# Set up run-time environment -get_fc || fail "$0: Could not set FC." -xsource_notrace ./$FIMSETUP $FC - -# Determine other runtime parameters -get_from_nl GLVL -get_from_nl NVL -./GetQueueTime | read QT || fail "GetQueueTime failed." - -# Do COMPARE_VAR setup -compare_var_setup - -# Diagnostics - -check_nems - -./get_num_cores | grep "num_cores_donothing:" | sed 's/^.*://' | read dnt || \ - fail "Could not get num_cores_donothing." - -./get_num_cores | grep "num_nodes_wt:" | sed 's/^.*://' | read num_nodes_wt || \ - fail "Could not get num_nodes_wt." - -./get_num_cores | grep "num_cores_notattached:" | sed 's/^.*://' | read num_cores_notattached || \ - fail "Could not get num_cores_notattached." - -print "Submitting job to queue $Q:" -print "compute tasks: $PES" -print "write tasks: $nwt (write nodes: $num_nodes_wt)" -print "do_nothing tasks: $dnt" -print "total core request: $N (no partial nodes)" -print "cores unattached: $num_cores_notattached" - -# Craig Tierney says "use this one" -SUBMIT_CMD="/usr/local/esrl/bin/qsub" -SUBMIT_ARGS="-A fim \ - -cwd \ - -j y \ - -l h_rt=$QT \ - -N fim${GLVL}_${NVL}_${ParaSuffix} \ - -pe $Q $N \ - -r y" - -# Create script for later potential submission to restart the job -cat > qsubfim.restart < $rundir." -copyfiles $SRCDIR/bin $rundir || \ - fail "Cannot copy contents of $SRCDIR/bin -> $rundir." -cp $SRCDIR/$FIMSETUP $rundir || \ - fail "Cannot cpy $SRCDIR/$FIMSETUP -> $rundir" -cd $rundir || fail "Cannot cd to $rundir" - -ksh_fix # Modify run scripts to use ksh93, if necessary. - -# Get number of cores to ask for -./get_num_cores | grep "num_cores_batch:" | sed 's/^.*://' | read N || \ - fail "Could not get num_cores_batch." - -# Find out if we'll run serial or parallel and set up appropriately -get_from_nl ComputeTasks as PES -get_from_nl Parallelism as parallelism -if [[ "$parallelism" == "parallel" ]] -then - FIM="fim" - ParaSuffix="$PES" -else - FIM="fimS" - ParaSuffix="S" -fi - -# Get build configuration from $SRCDIR -./get_buildconfig.ksh $SRCDIR | read FC || fail "$FC" - -# Set up run-time environment -xsource_notrace ./$FIMSETUP $FC - -# Determine other runtime parameters -get_from_nl GLVL -get_from_nl NVL -./GetQueueTime | read QT || fail "GetQueueTime failed." - -# Choose a run queue -# debug queue gives faster turnaround M-Th 9-5 Eastern. Time limit is 1 hour -Q="debug" -Q="batch" - -# Do COMPARE_VAR setup -compare_var_setup - -# Diagnostics - -check_nems - -./get_num_cores | grep "num_cores_donothing:" | sed 's/^.*://' | read dnt || \ - fail "Could not get num_cores_donothing." - -./get_num_cores | grep "num_nodes_wt:" | sed 's/^.*://' | read num_nodes_wt || \ - fail "Could not get num_nodes_wt." - -./get_num_cores | grep "num_cores_notattached:" | sed 's/^.*://' | read num_cores_notattached || \ - fail "Could not get num_cores_notattached." - -print "Submitting job to queue $Q:" -print "compute tasks: $PES" -print "write tasks: $nwt (write nodes: $num_nodes_wt)" -print "do_nothing tasks: $dnt" -print "total core request: $N (no partial nodes)" -print "cores unattached: $num_cores_notattached" - -SUBMIT_CMD="qsub" -SUBMIT_ARGS="-N fim${GLVL}_${NVL}_${ParaSuffix} \ - -q $Q \ - -lnodes=$NODES:ppn=$cpn \ - -l walltime=$QT \ - -A csc025fsc \ - -d $PWD" - -# Create script for later potential submission to restart the job -cat > qsubfim.restart < $rundir." -copyfiles $SRCDIR/bin $rundir || \ - fail "Cannot copy contents of $SRCDIR/bin -> $rundir." -cp $SRCDIR/$FIMSETUP $rundir || \ - fail "Cannot cpy $SRCDIR/$FIMSETUP -> $rundir" -cd $rundir || fail "Cannot cd to $rundir" - -ksh_fix # Modify run scripts to use ksh93, if necessary. - -# Get number of cores to ask for -./get_num_cores | grep "num_cores_batch:" | sed 's/^.*://' | read N || \ - fail "Could not get num_cores_batch." - -# Find out if we'll run serial or parallel and set up appropriately -get_from_nl ComputeTasks as PES -get_from_nl Parallelism as parallelism -if [[ "$parallelism" == "parallel" ]] -then - FIM="fim" - ParaSuffix="$PES" -else - FIM="fimS" - ParaSuffix="S" -fi - -# Get build configuration from $SRCDIR -./get_buildconfig.ksh $SRCDIR | read FC || fail "$FC" - -# Set up run-time environment -xsource_notrace ./$FIMSETUP $FC - -# Determine other runtime parameters -get_from_nl GLVL -get_from_nl NVL -./GetQueueTime | read QT || fail "GetQueueTime failed." - -# Choose a run queue -# debug queue gives faster turnaround M-Th 9-5 Eastern. Time limit is 1 hour -Q="debug" -Q="batch" - -# Do COMPARE_VAR setup -compare_var_setup - -# Diagnostics - -check_nems - -./get_num_cores | grep "num_cores_donothing:" | sed 's/^.*://' | read dnt || \ - fail "Could not get num_cores_donothing." - -./get_num_cores | grep "num_nodes_wt:" | sed 's/^.*://' | read num_nodes_wt || \ - fail "Could not get num_nodes_wt." - -./get_num_cores | grep "num_cores_notattached:" | sed 's/^.*://' | read num_cores_notattached || \ - fail "Could not get num_cores_notattached." - -print "Submitting job to queue $Q:" -print "compute tasks: $PES" -print "write tasks: $nwt (write nodes: $num_nodes_wt)" -print "do_nothing tasks: $dnt" -print "total core request: $N (no partial nodes)" -print "cores unattached: $num_cores_notattached" - -SUBMIT_CMD="qsub" -SUBMIT_ARGS="-N fim${GLVL}_${NVL}_${ParaSuffix} \ - -q $Q \ - -l size=$N \ - -l walltime=$QT \ - -A ATM001 \ - -d $PWD" - -# Create script for later potential submission to restart the job -cat > qsubfim.restart < $rundir" -copyfiles $SRCDIR/bin $rundir || \ - fail "Cannot copy contents of $SRCDIR/bin -> $rundir" -cp $SRCDIR/$FIMSETUP $rundir || \ - fail "Cannot cpy $SRCDIR/$FIMSETUP -> $rundir." -cd $rundir || fail "Cannot cd to $rundir." - -ksh_fix # Modify run scripts to use ksh93, if necessary. - -# Get number of cores to ask for -./get_num_cores | grep "num_cores_batch:" | sed 's/^.*://' | read N || \ - fail "Could not get num_cores_batch." - -get_pes - -# Find out if we'll run serial or parallel and set up appropriately -./GetParallelism | read parallelism || fail "GetParallelism failed." -if [[ "$parallelism" == "parallel" ]] -then - FIM="fim" - ParaSuffix="$PES" -else - FIM="fimS" - ParaSuffix="S" -fi - -# Set up run-time environment -get_fc || fail "$0: Could not set FC." -xsource_notrace ./$FIMSETUP $FC - -# Determine other runtime parameters -get_glvl -get_nvl -# HH:MM:SS -./GetQueueTime | read QT || fail "GetQueueTime failed" - -# No batch system so no run queue - - -# Do COMPARE_VAR setup -compare_var_setup - - -# Diagnostics - -check_nems - -./get_num_cores | grep "num_cores_donothing:" | sed 's/^.*://' | read dnt || \ - fail "Could not get num_cores_donothing." - -./get_num_cores | grep "num_nodes_wt:" | sed 's/^.*://' | read num_nodes_wt || \ - fail "Could not get num_nodes_wt." - -print "compute tasks: $PES" -print "write tasks: $nwt (write nodes: $num_nodes_wt)" -print "do_nothing tasks: $dnt" - -# Create script for later potential submission to restart the job -cat > runfim.restart < 0 )) ; then - (( num_nodes += 1 )) - fi - (( base_tasks_per_node = num_tasks / num_nodes )) - (( extra_tasks = num_tasks % num_nodes )) - if [[ $VERBOSE == "true" ]] ; then - print " DistributeTasks: num_nodes = $num_nodes" - print " DistributeTasks: extra_tasks = $extra_tasks" - print " DistributeTasks: base_tasks_per_node = $base_tasks_per_node" - fi - dist_tasks="(" - typeset task_count=0 - typeset node_task_count=0 - typeset this_tasks_per_node=0 - if (( base_tasks_per_node > 0 )) ; then -# refactor to remove duplication - if (( extra_tasks > 0 )) ; then - (( this_tasks_per_node = base_tasks_per_node + 1 )) - (( extra_tasks -= 1 )) - else - (( this_tasks_per_node = base_tasks_per_node )) - fi - else - (( this_tasks_per_node = extra_tasks )) - fi - while (( task_count < num_tasks )) ; do - if (( node_task_count == this_tasks_per_node )) ; then - # start a new node - dist_tasks="$dist_tasks)($current_task" - node_task_count=0 - if (( extra_tasks > 0 )) ; then - (( this_tasks_per_node = base_tasks_per_node + 1 )) - (( extra_tasks -= 1 )) - else - (( this_tasks_per_node = base_tasks_per_node )) - fi - else - if (( node_task_count > 0 )) ; then - dist_tasks="$dist_tasks," - fi - dist_tasks="$dist_tasks$current_task" - fi - (( node_task_count += 1 )) - (( current_task += 1 )) - (( task_count += 1 )) - done - dist_tasks="$dist_tasks)" - fi -} - - -# Map MPI tasks to LSF IBM nodes using "LSB_PJL_TASK_GEOMETRY" syntax: -# export LSB_PJL_TASK_GEOMETRY="{(taskid,taskid,...)(taskid,taskid,...)... }" -# In this syntax each "()" encloses a node and each "taskid" is an MPI task ID -# in MPI_COMM_WORLD. -# This syntax also matches LoadLeveler's #@task_geometry keyword. -# -# Nodes are filled as evenly as possible. -# -# Arguments are: -# compute_tasks Number of compute tasks. -# nwt Number of write tasks. -# mwtpn Maximum number of write tasks per node. -# mctpn Maximum number of compute tasks per node. -# -# Global (instance) variables used: -# $dist_tasks Return value from function DistributeTasks. -# $current_task Next unused MPI task ID, updated by function -# DistributeTasks. -# -# Return value is printed. -# -function SetTaskGeometry -{ - # local variables - typeset compute_tasks="$1"; shift - typeset nwt=$1; shift - typeset mwtpn=$1; shift - typeset mctpn=$1; shift - - if [[ $VERBOSE == "true" ]] ; then - print "Begin SetTaskGeometry: compute_tasks = $compute_tasks" - print "Begin SetTaskGeometry: nwt = $nwt" - print "Begin SetTaskGeometry: mwtpn = $mwtpn" - print "Begin SetTaskGeometry: mctpn = $mctpn" - fi - - # First MPI task is compute root which lives on its own separate node - current_task=0 - DistributeTasks 1 $mctpn - typeset task_geometry="$dist_tasks" - # Next set of MPI tasks are write tasks: - DistributeTasks $nwt $mwtpn - task_geometry=$task_geometry$dist_tasks - # Remaining tasks are compute tasks, distribute among nodes as evenly as - # possible. - (( remaining_ct = compute_tasks - 1 )) - DistributeTasks $remaining_ct $mctpn - task_geometry=$task_geometry$dist_tasks - print "{$task_geometry}" -} - - -#set -x - -usagestr="Usage: ${0} compute_tasks [nwt [mwtpn [mctpn]]]" - -nwt=0 -mctpn=32 -(( mwtpn = mctpn )) -case $# in - 1) compute_tasks="$1";; - 2) compute_tasks="$1"; nwt=$2;; - 3) compute_tasks="$1"; nwt=$2; mwtpn=$3;; - 4) compute_tasks="$1"; nwt=$2; mwtpn=$3; mctpn=$4;; - *) fail "${usagestr}";; -esac - -if (( compute_tasks <= 0 )) ; then - fail "${usagestr}, compute_tasks must be a positive integer" -fi - - if [[ $VERBOSE == "true" ]] ; then - print " compute_tasks = $compute_tasks" - print " nwt = $nwt" - print " mwtpn = $mwtpn" - print " mctpn = $mctpn" - fi - -SetTaskGeometry $compute_tasks $nwt $mwtpn $mctpn - diff --git a/src/fim/FIMrun/theta_coor100.txt b/src/fim/FIMrun/theta_coor100.txt deleted file mode 100644 index 988b2a3..0000000 --- a/src/fim/FIMrun/theta_coor100.txt +++ /dev/null @@ -1,100 +0,0 @@ - 220.0000 - 224.0000 - 228.0000 - 232.0000 - 236.0000 - 240.0000 - 242.5000 - 245.0000 - 247.5000 - 250.0000 - 252.5000 - 255.0000 - 257.5000 - 260.0000 - 262.5000 - 265.0000 - 267.5000 - 270.0000 - 271.5000 - 273.0000 - 274.5000 - 276.0000 - 277.5000 - 279.0000 - 280.5000 - 282.0000 - 283.5000 - 285.0000 - 286.5000 - 288.0000 - 289.5000 - 291.0000 - 292.0000 - 293.0000 - 294.0000 - 295.0000 - 296.0000 - 297.0000 - 298.0000 - 299.0000 - 300.0000 - 301.0000 - 302.0000 - 303.0000 - 304.0000 - 305.0000 - 306.0000 - 307.0000 - 308.0000 - 309.0000 - 310.0000 - 311.0000 - 312.0000 - 313.0000 - 314.0000 - 315.0000 - 316.0000 - 317.0000 - 318.0000 - 319.0000 - 320.0000 - 321.0000 - 322.0000 - 323.0000 - 324.0000 - 325.0000 - 326.5000 - 328.0000 - 330.0000 - 332.0000 - 334.5000 - 337.0000 - 340.0000 - 343.0000 - 346.5000 - 350.0000 - 354.0000 - 358.0000 - 362.5000 - 367.0000 - 372.0000 - 377.0000 - 382.5000 - 388.0000 - 394.0000 - 400.0000 - 406.5000 - 413.0000 - 420.0000 - 427.0000 - 435.0000 - 443.0000 - 452.5000 - 462.0000 - 473.5000 - 485.0000 - 499.0000 - 513.0000 - 530.0000 - 547.0000 diff --git a/src/fim/FIMrun/theta_coor38.txt b/src/fim/FIMrun/theta_coor38.txt deleted file mode 100644 index 56bd0b9..0000000 --- a/src/fim/FIMrun/theta_coor38.txt +++ /dev/null @@ -1,4 +0,0 @@ - 224 236 245 252 260 268 275 281 285 289 - 293 297 301 305 309 313 317 321 325 329 - 334 340 347 355 370 385 400 420 450 490 - 540 600 670 750 900 1100 1500 2200 diff --git a/src/fim/FIMrun/theta_coor50.txt b/src/fim/FIMrun/theta_coor50.txt deleted file mode 100644 index de967e4..0000000 --- a/src/fim/FIMrun/theta_coor50.txt +++ /dev/null @@ -1,50 +0,0 @@ -224. -232. -240. -245. -250. -255. -260. -265. -270. -273. -276. -279. -282. -285. -288. -291. -293. -295. -297. -299. -301. -303. -305. -307. -309. -311. -313. -315. -317. -319. -321. -323. -325. -328. -332. -337. -343. -350. -358. -367. -377. -388. -400. -413. -427. -443. -462. -485. -513. -547. diff --git a/src/fim/FIMrun/theta_coor64.txt b/src/fim/FIMrun/theta_coor64.txt deleted file mode 100644 index 4ea78dc..0000000 --- a/src/fim/FIMrun/theta_coor64.txt +++ /dev/null @@ -1,7 +0,0 @@ - 224 232 240 245 250 255 260 265 270 273 - 276 279 282 285 288 291 293 295 297 299 - 301 303 305 307 309 311 313 315 317 319 - 321 323 325 328 332 337 343 350 358 367 - 377 388 400 413 427 443 462 485 513 547 - 590 638 692 746 800 850 900 960 1030 1100 - 1200 1350 1700 2200 diff --git a/src/fim/FIMrun/top_grid b/src/fim/FIMrun/top_grid deleted file mode 100644 index 7bbbc74..0000000 --- a/src/fim/FIMrun/top_grid +++ /dev/null @@ -1,12 +0,0 @@ - 90.0000000000000 0.000000000000000E+000 - 26.5650520324707 10.0000000000000 - 26.5650520324707 82.0000000000000 - 26.5650520324707 154.000000000000 - 26.5650520324707 226.000000000000 - 26.5650520324707 298.000000000000 - -90.0000000000000 0.000000000000000E+000 - -26.5650520324707 46.0000000000000 - -26.5650520324707 118.000000000000 - -26.5650520324707 190.000000000000 - -26.5650520324707 262.000000000000 - -26.5650520324707 334.000000000000 diff --git a/src/fim/FIMsrc/Makefile b/src/fim/FIMsrc/Makefile deleted file mode 100644 index 85df1b7..0000000 --- a/src/fim/FIMsrc/Makefile +++ /dev/null @@ -1,520 +0,0 @@ -SHELL = /bin/sh -# Makefile for the FIM system -# Please use the "makefim" script to build FIM rather than the "make" command. -# See makefim and fim_setup.ksh for details on how to build FIM. - -#NOTE: We will eventually need the following gmake subst for IBM but not yet! -# Set up special characters -# Yes, GNU make is *required* -#null := -#space := $(null) $(null) -#comma := $(null),$(null) -# For IBM, use gmake "subst" to convert from cpp "-DFOO -DBAR" to xlf "-WF,-DFOO,-DBAR" -# Only one "-WF" is allowed by xlf so we must append all "-D" flags together before -# applying this method. Method borrowed shamelessly from CAM. -#VaporCPPDEF := "-DFOO -DBAR" -#VaporFPPDEF := -WF,$(subst $(space),$(comma),$(VaporCPPDEF)) - -# FIM_ESMF_INSTALL_LIBDIR_ABSPATH is now defined in fim_setup.ksh -ifdef FIM_ESMF_INSTALL_LIBDIR_ABSPATH -# Include makefile fragment "esmf.mk" for ESMF, used by the nems target. -# Note that all variables defined in esmf.mk begin with "ESMF_" and -# should not conflict with other make variables even when nems target -# is not being built. -include $(FIM_ESMF_INSTALL_LIBDIR_ABSPATH)/esmf.mk -endif - -# TODO: separate Intel-openmpi vs. Intel-mvapich vs. ifort here... -FCserialintel = ifort -FC = mpif90 - -# TODO: separate Intel-openmpi vs. Intel-mvapich vs. ifort here... -EJET_VEC_FFLAGS = -O3 -xW -vec-report3 -EJET_VEC_FFLAGS = -O3 -xP -#JET_VEC_FFLAGS = -O3 -xT -fp-model precise -#JET_VEC_FFLAGS = -O3 -xT -#JET_VEC_FFLAGS = -O3 -xW -#JET_VEC_FFLAGS = -O3 -xT -fp-model precise -vec-report3 -JET_VEC_FFLAGS = -O3 -#JET_VEC_FFLAGS = -O0 -g -traceback -C -fpe0 -#JET_VEC_FFLAGS = -O0 -g -traceback -C -#VEC_FFLAGS = $(EJET_VEC_FFLAGS) -VEC_FFLAGS = $(JET_VEC_FFLAGS) -#INTEL_FFLAGS = -O2 -DVERBOSE -#INTEL_FFLAGS = $(VEC_FFLAGS) -INTEL_FFLAGS = $(VEC_FFLAGS) -#INTEL_FFLAGS = $(VEC_FFLAGS) -r8 - -# generic settings -# netcdf: rely on NETCDF environment variable by default, if present -ifdef NETCDF -LIBNETCDF = "-L$(NETCDF)/lib -lnetcdf" -INCNETCDF = "-I$(NETCDF)/include" -endif -# ESMF -LINK_FLAGS_NOESMF = "" -LINK_LIBS_NOESMF = "" -LINK_FLAGS_ESMF = "$(ESMF_F90LINKPATHS) $(ESMF_F90LINKRPATHS)" -LINK_LIBS_ESMF = "$(ESMF_F90ESMFLINKLIBS)" -#JR changed this: LINK_LIBS puts at end of mpif90 stmt which works -#JR LINK_FLAGS puts at beginning which fails - -JAGUAR_LINK_LIBS_NOESMF = "" -FROST_LINK_LIBS_NOESMF = "" - -# Intel settings -INTEL_FMVAPICH = $(VEC_FFLAGS) -INTEL_COL_FFLAGS = $(VEC_FFLAGS) -r8 -INTEL_ESMF_FFLAGS = "$(INTEL_FFLAGS) $(ESMF_F90COMPILEPATHS)" -PREP_FFLAGS = "-O2" -INTEL_SP_FFLAGS = "-O2" -#PREP_FFLAGS= "-O0 -g -traceback -C -fpe0" -POST_FFLAGS = "-O2" -CCintel = "cc" -CFLAGS= "-O2" -INTEL_FDEBUG = "-O0 -g -traceback -C -fpe0 -ftz" -INTEL_COL_FDEBUG = "-O0 -g -traceback -C -fpe0 -ftz -r8" -INTEL_PREP_DEBUG = "-O0 -g -traceback -C -fpe0 -ftz" -INTEL_POST_DEBUG = "-O0 -g -traceback -C -fpe0 -ftz" -INTEL_GRIBIO_CPP_FLAGS = "-DSUN" -INTEL_FREEFLAG = "-free" -INTEL_FIXEDFLAG = "-fixed" -CDEBUG = "-g" -INTEL_STATIC_FLAG = "-static" -# byte-swapping handled by env flags -INTEL_BYTE_SWAP_FLAG = "" -INTEL_FLUSH_DEF = "" - -# Lahey settings -# The sigio library and other libaries are not TKR consistent so they cannot -# use --chkglobal. However --chkglobal must be used in all routines if it is -# used at all so it cannot be used anywhere. -# The sigio and other libraries should be made TKR consistent. -FCseriallahey = lf95 -#LAHEY_FDEBUG = "--chk -g --trace --info" -#LAHEY_FDEBUG = "--chk a,e,s,u,x -O0 -g --trace --info" -#LAHEY_FDEBUG = "--chkglobal -g --info" -#LAHEY_COL_FDEBUG= "--chkglobal -g --info --dbl" -LAHEY_FDEBUG = "--chk -g --trap --trace --info" -LAHEY_COL_FDEBUG = "--chk -g --trap --trace --info --dbl" -LAHEY_PREP_DEBUG = "--chk -g --trap --trace --info" -# sp lib has underflow... -LAHEY_SP_FFLAGS = "" -LAHEY_FFLAGS_NO_DEBUG = "-g" -LAHEY_POST_DEBUG = "--chk -g --trap --trace --info" -CClahey = "cc" -CFLAGSlahey = "-O2" -LAHEY_GRIBIO_CPP_FLAGS = "-DSUN" -LAHEY_FREEFLAG = "-Free" -LAHEY_FIXEDFLAG = "-Fixed" -LAHEY_STATIC_FLAG = "-static" -# byte-swapping handled by env flags -LAHEY_BYTE_SWAP_FLAG = "" -LAHEY_FLUSH_DEF = "" - -# PGI settings -# TODO: integrate and then test PGI settings -PGI_FCserial = pgf90 -PGI_OPT_FFLAGS = -O2 -PGI_FREEFLAG = "-Mfree" -PGI_FIXEDFLAG = "-Mfixed" -PGI_BYTE_SWAP_FLAG = "-byteswapio" -PGI_STATIC_FLAG = "" - -# IBM settings -FCserialibm = xlf90_r -FCibm = mpxlf90_r -CCibm = mpcc_r -FCserialvapor = $(FCserialibm) -FCvapor = $(FCibm) -FCserialbluefire = $(FCserialibm) -FCbluefire = $(FCibm) -# Use -qnostrict for similar behavior to other compilers (loosen IEEE restrictions) -IBM_archflags = -q64 -qnostrict -qarch=auto -qspill=32767 -qmaxmem=32767 -IBM_FFLAGS = $(IBM_archflags) -IBM_COL_FFLAGS = $(IBM_FFLAGS) -qrealsize=8 -qintsize=4 -O3 -IBM_ESMF_FFLAGS ="$(IBM_FFLAGS) $(ESMF_F90COMPILEPATHS)" -IBM_FIM_FFLAGS = $(IBM_FFLAGS) -O3 -IBM_ICOSIO_FFLAGS = $(IBM_FFLAGS) -O3 -IBM_PREP_FFLAGS = $(IBM_FFLAGS) -O2 -IBM_SP_FFLAGS = $(IBM_FFLAGS) -O3 -IBM_POST_FFLAGS = $(IBM_FFLAGS) -O2 -IBM_GRIBIO_CPP_FLAGS = "-DIBM" -IBM_CFLAGS = $(IBM_archflags) -O2 -IBM_FREEFLAG = "-qfree=f90" -IBM_FIXEDFLAG = "-qfixed" -IBM_CDEBUG = "$(IBM_archflags) -g" -# no need to byte swap on IBM -IBM_BYTE_SWAP_FLAG = "" -# try IBM without static linking -IBM_STATIC_FLAG = "" -IBM_FLUSH_DEF = "-WF,-DNO_FLUSH" -# NCEP netcdf paths are special -IBM_LIBNETCDFvapor = "-L/nwprod/lib -lnetcdf_64" -IBM_INCNETCDFvapor = "-I/nwprod/lib/sorc/netcdf/netcdf-3.5.0/include" - -#JR gfortran flags (used by linuxpcgnu and macgnu targets) -GF_SP_FFLAGS = "-O2" -GF_FFLAGS = -O2 -ffree-line-length-none -GF_POST_FFLAGS = "-O2" -GF_CC = "cc" -GF_CFLAGS = "-O2" -#JR Most users won't have a gfortran named "gfortran44". -#JR This is special for me on nix, where I needed to have -#JR the most recent compiler installed. -GF_FCserial = gfortran44 -GF_COL_FFLAGS = -fdefault-real-8 -O2 -GF_FREEFLAG = "-ffree-form" -GF_FIXEDFLAG = "-ffixed-form" -#JR Putting these flags in 2 places is BAD (it's also in macros.make.linuxpcgnu) -#JR For now it'll have to wait till we do some cleanup of the targets -GF_PREP_FFLAGS = "-O2 -frecord-marker=4 -fno-range-check" - -MAC_FCserial = gfortran - -# generic paths -CWD = $(shell pwd) -LIBDIR = $(CWD)/lib -BINDIR = $(CWD)/bin - -# path to mkDepends -MKDEPENDS = $(CWD)/tools/mkDepends - -#TODO: Fix ginfo to eliminate need to link it with SMS at all. This -#TODO: will require *all* input and output files to *always* use the -#TODO: "ij" curve, ALWAYS. Which will make Rainer and Mike Fiorino -#TODO: happier. And inv_perm will have to be used on input if -#TODO: curve != "ij". Non-"ij" curves will only be used for performance -#TODO: testing unless there is a compelling reason to do otherwise -#TODO: (like a large performance boost due to other curves). -#TODO: Then eliminate FCginfo here and replace FCginfo with FCserial -#TODO: in prep/grid/Makefile . - -.PHONY: openmpi -openmpi: - $(MAKE) -f Makesub MAKE=$(MAKE) \ - PREP_FFLAGS=$(PREP_FFLAGS) \ - FFLAGS_NO_DEBUG="$(PREP_FFLAGS)" \ - SP_FFLAGS="$(INTEL_SP_FFLAGS)" \ - BYTE_SWAP_FLAG="$(INTEL_BYTE_SWAP_FLAG)" \ - STATIC_FLAG="$(INTEL_STATIC_FLAG)" \ - FIM_FFLAGS="$(INTEL_FFLAGS)" \ - POST_FFLAGS=$(POST_FFLAGS) \ - CC=$(CCintel) CFLAGS=$(CFLAGS) \ - GRIBIO_CPP_FLAGS=$(INTEL_GRIBIO_CPP_FLAGS) \ - FC=$(FC) LIBDIR=$(LIBDIR) BINDIR=$(BINDIR) \ - FCginfo=$(FC) \ - FCserial=$(FCserialintel) \ - LIBNETCDF=$(LIBNETCDF) INCNETCDF=$(INCNETCDF) \ - COL_FFLAGS="$(INTEL_COL_FFLAGS)" \ - FREEFLAG=$(INTEL_FREEFLAG) \ - FIXEDFLAG=$(INTEL_FIXEDFLAG) \ - LINKFLAGS=$(LINK_FLAGS_NOESMF) \ - LINKLIBS=$(LINK_LIBS_NOESMF) NEMS="" \ - FLUSH_DEF=$(INTEL_FLUSH_DEF) MKDEPENDS=$(MKDEPENDS) - -.PHONY: mvapich -mvapich: - $(MAKE) -f Makesub MAKE=$(MAKE) \ - PREP_FFLAGS=$(PREP_FFLAGS) \ - FFLAGS_NO_DEBUG="$(PREP_FFLAGS)" \ - SP_FFLAGS="$(INTEL_SP_FFLAGS)" \ - BYTE_SWAP_FLAG="$(INTEL_BYTE_SWAP_FLAG)" \ - STATIC_FLAG="$(INTEL_STATIC_FLAG)" \ - FIM_FFLAGS="$(INTEL_FMVAPICH)" \ - POST_FFLAGS=$(POST_FFLAGS) \ - CC=$(CCintel) CFLAGS=$(CFLAGS) \ - GRIBIO_CPP_FLAGS=$(INTEL_GRIBIO_CPP_FLAGS) \ - FC=$(FC) LIBDIR=$(LIBDIR) BINDIR=$(BINDIR) \ - FCginfo=$(FC) \ - FCserial=$(FCserialintel) \ - LIBNETCDF=$(LIBNETCDF) INCNETCDF=$(INCNETCDF) \ - COL_FFLAGS="$(INTEL_COL_FFLAGS)" \ - FREEFLAG=$(INTEL_FREEFLAG) \ - FIXEDFLAG=$(INTEL_FIXEDFLAG) \ - LINKFLAGS=$(LINK_FLAGS_NOESMF) \ - LINKLIBS=$(LINK_LIBS_NOESMF) NEMS="" \ - FLUSH_DEF=$(INTEL_FLUSH_DEF) MKDEPENDS=$(MKDEPENDS) - -.PHONY: debug -debug: - $(MAKE) -f Makesub MAKE=$(MAKE) \ - PREP_FFLAGS=$(INTEL_PREP_DEBUG) \ - FFLAGS_NO_DEBUG="$(PREP_FFLAGS)" \ - SP_FFLAGS="$(INTEL_SP_FFLAGS)" \ - BYTE_SWAP_FLAG="$(INTEL_BYTE_SWAP_FLAG)" \ - STATIC_FLAG="$(INTEL_STATIC_FLAG)" \ - FIM_FFLAGS=$(INTEL_FDEBUG) \ - POST_FFLAGS=$(INTEL_POST_DEBUG) \ - CC=$(CCintel) CFLAGS=$(CDEBUG) \ - GRIBIO_CPP_FLAGS=$(INTEL_GRIBIO_CPP_FLAGS) \ - FC=$(FC) LIBDIR=$(LIBDIR) BINDIR=$(BINDIR) \ - FCginfo=$(FC) \ - FCserial=$(FCserialintel) \ - LIBNETCDF=$(LIBNETCDF) INCNETCDF=$(INCNETCDF) \ - COL_FFLAGS=$(INTEL_COL_FDEBUG) \ - FREEFLAG=$(INTEL_FREEFLAG) \ - FIXEDFLAG=$(INTEL_FIXEDFLAG) \ - LINKFLAGS=$(LINK_FLAGS_NOESMF) \ - LINKLIBS=$(LINK_LIBS_NOESMF) NEMS="" \ - FLUSH_DEF=$(INTEL_FLUSH_DEF) MKDEPENDS=$(MKDEPENDS) - -.PHONY: nems -nems: - $(MAKE) -f Makesub MAKE=$(MAKE) \ - PREP_FFLAGS=$(PREP_FFLAGS) \ - FFLAGS_NO_DEBUG="$(PREP_FFLAGS)" \ - SP_FFLAGS="$(INTEL_SP_FFLAGS)" \ - BYTE_SWAP_FLAG="$(INTEL_BYTE_SWAP_FLAG)" \ - STATIC_FLAG="$(INTEL_STATIC_FLAG)" \ - FIM_FFLAGS=$(INTEL_ESMF_FFLAGS) \ - POST_FFLAGS=$(POST_FFLAGS) \ - CC=$(CCintel) CFLAGS=$(CFLAGS) \ - GRIBIO_CPP_FLAGS=$(INTEL_GRIBIO_CPP_FLAGS) \ - FC=$(FC) LIBDIR=$(LIBDIR) BINDIR=$(BINDIR) \ - FCginfo=$(FC) \ - FCserial=$(FCserialintel) \ - LIBNETCDF=$(LIBNETCDF) INCNETCDF=$(INCNETCDF) \ - COL_FFLAGS="$(INTEL_COL_FFLAGS)" \ - FREEFLAG=$(INTEL_FREEFLAG) \ - FIXEDFLAG=$(INTEL_FIXEDFLAG) \ - LINKFLAGS=$(LINK_FLAGS_ESMF) \ - LINKLIBS=$(LINK_LIBS_ESMF) NEMS="nems" \ - FLUSH_DEF=$(INTEL_FLUSH_DEF) MKDEPENDS=$(MKDEPENDS) - -.PHONY: lahey -lahey: - $(MAKE) -f Makesub MAKE=$(MAKE) \ - PREP_FFLAGS=$(LAHEY_PREP_DEBUG) \ - FFLAGS_NO_DEBUG="$(LAHEY_FFLAGS_NO_DEBUG)" \ - SP_FFLAGS="$(LAHEY_SP_FFLAGS)" \ - BYTE_SWAP_FLAG="$(LAHEY_BYTE_SWAP_FLAG)" \ - STATIC_FLAG="$(LAHEY_STATIC_FLAG)" \ - FIM_FFLAGS=$(LAHEY_FDEBUG) \ - POST_FFLAGS=$(LAHEY_POST_DEBUG) \ - CC=$(CClahey) CFLAGS=$(CDEBUG) \ - GRIBIO_CPP_FLAGS=$(LAHEY_GRIBIO_CPP_FLAGS) \ - FC=$(FC) LIBDIR=$(LIBDIR) BINDIR=$(BINDIR) \ - FCginfo=$(FC) \ - FCserial=$(FCseriallahey) \ - LIBNETCDF=$(LIBNETCDF) INCNETCDF=$(INCNETCDF) \ - COL_FFLAGS=$(LAHEY_COL_FDEBUG) \ - FREEFLAG=$(LAHEY_FREEFLAG) \ - FIXEDFLAG=$(LAHEY_FIXEDFLAG) \ - LINKFLAGS=$(LINK_FLAGS_NOESMF) \ - LINKLIBS=$(LINK_LIBS_NOESMF) NEMS="" \ - FLUSH_DEF=$(LAHEY_FLUSH_DEF) MKDEPENDS=$(MKDEPENDS) - -.PHONY: ranger -ranger: - $(MAKE) -f Makesub MAKE=$(MAKE) \ - PREP_FFLAGS=$(PREP_FFLAGS) \ - FFLAGS_NO_DEBUG="$(PREP_FFLAGS)" \ - SP_FFLAGS="$(INTEL_SP_FFLAGS)" \ - BYTE_SWAP_FLAG="$(INTEL_BYTE_SWAP_FLAG)" \ - STATIC_FLAG="$(INTEL_STATIC_FLAG)" \ - FIM_FFLAGS="$(INTEL_FFLAGS)" \ - POST_FFLAGS=$(POST_FFLAGS) \ - CC=$(CCintel) CFLAGS=$(CFLAGS) \ - GRIBIO_CPP_FLAGS=$(INTEL_GRIBIO_CPP_FLAGS) \ - FC=$(FC) LIBDIR=$(LIBDIR) BINDIR=$(BINDIR) \ - FCginfo=$(FC) \ - FCserial=$(FCserialintel) \ - LIBNETCDF="-L$(TACC_NETCDF_DIR)/lib -lnetcdf" \ - INCNETCDF="-I$(TACC_NETCDF_DIR)/include" \ - COL_FFLAGS="$(INTEL_COL_FFLAGS)" \ - FREEFLAG=$(INTEL_FREEFLAG) \ - FIXEDFLAG=$(INTEL_FIXEDFLAG) \ - LINKFLAGS=$(LINK_FLAGS_NOESMF) \ - LINKLIBS=$(LINK_LIBS_NOESMF) NEMS="" \ - FLUSH_DEF=$(INTEL_FLUSH_DEF) MKDEPENDS=$(MKDEPENDS) - -.PHONY: devccs -devccs: vapor - -.PHONY: vapor -vapor: - $(MAKE) -f Makesub MAKE=$(MAKE) \ - ICOSIO_FFLAGS="$(IBM_ICOSIO_FFLAGS)" \ - PREP_FFLAGS="$(IBM_PREP_FFLAGS)" \ - FFLAGS_NO_DEBUG="$(IBM_PREP_FFLAGS)" \ - SP_FFLAGS="$(IBM_SP_FFLAGS)" \ - BYTE_SWAP_FLAG="$(IBM_BYTE_SWAP_FLAG)" \ - STATIC_FLAG="$(IBM_STATIC_FLAG)" \ - FIM_FFLAGS="$(IBM_FIM_FFLAGS)" \ - POST_FFLAGS="$(IBM_POST_FFLAGS)" \ - GRIBIO_CPP_FLAGS=$(IBM_GRIBIO_CPP_FLAGS) \ - CC=$(CCibm) CFLAGS="$(IBM_CFLAGS)" \ - FC=$(FCvapor) LIBDIR=$(LIBDIR) BINDIR=$(BINDIR) \ - FCginfo=$(FCserialvapor) \ - FCserial=$(FCserialvapor) \ - LIBNETCDF=$(IBM_LIBNETCDFvapor) \ - INCNETCDF=$(IBM_INCNETCDFvapor) \ - COL_FFLAGS="$(IBM_COL_FFLAGS)" \ - FREEFLAG=$(IBM_FREEFLAG) \ - FIXEDFLAG=$(IBM_FIXEDFLAG) \ - LINKFLAGS=$(LINK_FLAGS_NOESMF) \ - LINKLIBS=$(LINK_LIBS_NOESMF) NEMS="" \ - FLUSH_DEF=$(IBM_FLUSH_DEF) MKDEPENDS=$(MKDEPENDS) - -.PHONY: bluefire -bluefire: - $(MAKE) -f Makesub MAKE=$(MAKE) \ - ICOSIO_FFLAGS="$(IBM_ICOSIO_FFLAGS)" \ - PREP_FFLAGS="$(IBM_PREP_FFLAGS)" \ - FFLAGS_NO_DEBUG="$(IBM_PREP_FFLAGS)" \ - SP_FFLAGS="$(IBM_SP_FFLAGS)" \ - BYTE_SWAP_FLAG="$(IBM_BYTE_SWAP_FLAG)" \ - STATIC_FLAG="$(IBM_STATIC_FLAG)" \ - FIM_FFLAGS="$(IBM_FIM_FFLAGS)" \ - POST_FFLAGS="$(IBM_POST_FFLAGS)" \ - GRIBIO_CPP_FLAGS=$(IBM_GRIBIO_CPP_FLAGS) \ - CC=$(CCibm) CFLAGS="$(IBM_CFLAGS)" \ - FC=$(FCbluefire) LIBDIR=$(LIBDIR) BINDIR=$(BINDIR) \ - FCginfo=$(FCserialbluefire) \ - FCserial=$(FCserialbluefire) \ - LIBNETCDF=$(LIBNETCDF) INCNETCDF=$(INCNETCDF) \ - COL_FFLAGS="$(IBM_COL_FFLAGS)" \ - FREEFLAG=$(IBM_FREEFLAG) \ - FIXEDFLAG=$(IBM_FIXEDFLAG) \ - LINKFLAGS=$(LINK_FLAGS_NOESMF) \ - LINKLIBS=$(LINK_LIBS_NOESMF) NEMS="" \ - FLUSH_DEF=$(IBM_FLUSH_DEF) MKDEPENDS=$(MKDEPENDS) - -.PHONY: linuxpcgnu -linuxpcgnu: - $(MAKE) -f Makesub MAKE=$(MAKE) \ - PREP_FFLAGS=$(GF_PREP_FFLAGS) \ - FFLAGS_NO_DEBUG="$(PREP_FFLAGS)" \ - SP_FFLAGS="$(GF_SP_FFLAGS)" \ - BYTE_SWAP_FLAG="" \ - STATIC_FLAG="" \ - FIM_FFLAGS="$(GF_FFLAGS)" \ - POST_FFLAGS=$(GF_POST_FFLAGS) \ - CC=$(GF_CC) CFLAGS=$(GF_CFLAGS) \ - GRIBIO_CPP_FLAGS=$(INTEL_GRIBIO_CPP_FLAGS) \ - FC=$(FC) LIBDIR=$(LIBDIR) BINDIR=$(BINDIR) \ - FCginfo=$(FC) \ - FCserial=$(GF_FCserial) LIBNETCDF=$(LIBNETCDF) \ - LIBNETCDF=$(LIBNETCDF) INCNETCDF=$(INCNETCDF) \ - COL_FFLAGS="$(GF_COL_FFLAGS)" \ - FREEFLAG=$(GF_FREEFLAG) \ - FIXEDFLAG=$(GF_FIXEDFLAG) \ - LINKFLAGS=$(LINK_FLAGS_NOESMF) \ - LINKLIBS=$(LINK_LIBS_NOESMF) NEMS="" \ - FLUSH_DEF=$(INTEL_FLUSH_DEF) MKDEPENDS=$(MKDEPENDS) - -.PHONY: macgnu -macgnu: - $(MAKE) -f Makesub MAKE=$(MAKE) \ - PREP_FFLAGS=$(GF_PREP_FFLAGS) \ - FFLAGS_NO_DEBUG="$(PREP_FFLAGS)" \ - SP_FFLAGS="$(GF_SP_FFLAGS)" \ - BYTE_SWAP_FLAG="" \ - STATIC_FLAG="" \ - FIM_FFLAGS="$(GF_FFLAGS)" \ - POST_FFLAGS=$(GF_POST_FFLAGS) \ - CC=$(GF_CC) CFLAGS=$(GF_CFLAGS) \ - GRIBIO_CPP_FLAGS=$(INTEL_GRIBIO_CPP_FLAGS) \ - FC=$(FC) LIBDIR=$(LIBDIR) BINDIR=$(BINDIR) \ - FCginfo=$(FC) \ - FCserial=$(MAC_FCserial) LIBNETCDF=$(LIBNETCDF) \ - LIBNETCDF=$(LIBNETCDF) INCNETCDF=$(INCNETCDF) \ - COL_FFLAGS="$(GF_COL_FFLAGS)" \ - FREEFLAG=$(GF_FREEFLAG) \ - FIXEDFLAG=$(GF_FIXEDFLAG) \ - LINKFLAGS=$(LINK_FLAGS_NOESMF) \ - LINKLIBS=$(LINK_LIBS_NOESMF) NEMS="" \ - FLUSH_DEF=$(INTEL_FLUSH_DEF) MKDEPENDS=$(MKDEPENDS) - -.PHONY: jaguarintel -jaguarintel: - $(MAKE) -f Makesub MAKE=$(MAKE) \ - PREP_FFLAGS=$(PREP_FFLAGS) \ - FFLAGS_NO_DEBUG="$(PREP_FFLAGS)" \ - SP_FFLAGS="$(INTEL_SP_FFLAGS)" \ - BYTE_SWAP_FLAG="$(INTEL_BYTE_SWAP_FLAG)" \ - STATIC_FLAG="$(INTEL_STATIC_FLAG)" \ - FIM_FFLAGS="$(INTEL_FFLAGS)" \ - POST_FFLAGS=$(POST_FFLAGS) \ - CC=cc CFLAGS=$(CFLAGS) \ - GRIBIO_CPP_FLAGS=$(INTEL_GRIBIO_CPP_FLAGS) \ - FC=ftn LIBDIR=$(LIBDIR) BINDIR=$(BINDIR) \ - FCginfo=ftn \ - FCserial=ftn \ - LIBNETCDF="" \ - INCNETCDF="" \ - COL_FFLAGS="$(INTEL_COL_FFLAGS)" \ - FREEFLAG=$(INTEL_FREEFLAG) \ - FIXEDFLAG=$(INTEL_FIXEDFLAG) \ - LINKFLAGS=$(JAGUAR_LINK_FLAGS_NOESMF) \ - LINKLIBS=$(JAGUAR_LINK_LIBS_NOESMF) NEMS="" \ - FLUSH_DEF=$(INTEL_FLUSH_DEF) MKDEPENDS=$(MKDEPENDS) - -.PHONY: jaguargnu -jaguargnu: - $(MAKE) -f Makesub MAKE=$(MAKE) \ - PREP_FFLAGS=$(GF_PREP_FFLAGS) \ - FFLAGS_NO_DEBUG="$(PREP_FFLAGS)" \ - SP_FFLAGS="$(GF_SP_FFLAGS)" \ - BYTE_SWAP_FLAG="" \ - STATIC_FLAG="" \ - FIM_FFLAGS="$(GF_FFLAGS)" \ - POST_FFLAGS=$(GF_POST_FFLAGS) \ - CC=cc CFLAGS=$(GF_CFLAGS) \ - GRIBIO_CPP_FLAGS=$(INTEL_GRIBIO_CPP_FLAGS) \ - FC=ftn LIBDIR=$(LIBDIR) BINDIR=$(BINDIR) \ - FCginfo=ftn \ - FCserial=ftn \ - LIBNETCDF="" \ - INCNETCDF="" \ - COL_FFLAGS="$(GF_COL_FFLAGS)" \ - FREEFLAG=$(GF_FREEFLAG) \ - FIXEDFLAG=$(GF_FIXEDFLAG) \ - LINKFLAGS=$(JAGUAR_LINK_FLAGS_NOESMF) \ - LINKLIBS=$(JAGUAR_LINK_LIBS_NOESMF) NEMS="" \ - FLUSH_DEF=$(INTEL_FLUSH_DEF) MKDEPENDS=$(MKDEPENDS) - -.PHONY: frostintel -frostintel: - $(MAKE) -f Makesub MAKE=$(MAKE) \ - PREP_FFLAGS=$(PREP_FFLAGS) \ - FFLAGS_NO_DEBUG="$(PREP_FFLAGS)" \ - SP_FFLAGS="$(INTEL_SP_FFLAGS)" \ - BYTE_SWAP_FLAG="$(INTEL_BYTE_SWAP_FLAG)" \ - STATIC_FLAG="$(INTEL_STATIC_FLAG)" \ - FIM_FFLAGS="$(INTEL_FFLAGS)" \ - POST_FFLAGS=$(POST_FFLAGS) \ - CC=cc CFLAGS=$(CFLAGS) \ - GRIBIO_CPP_FLAGS=$(INTEL_GRIBIO_CPP_FLAGS) \ - FC=ifort LIBDIR=$(LIBDIR) BINDIR=$(BINDIR) \ - FCginfo=ifort \ - FCserial=ifort \ - LIBNETCDF="-L/ccs/home/rosinski/frost/intel/lib -lnetcdf" \ - INCNETCDF="-I/ccs/home/rosinski/frost/intel/include" \ - COL_FFLAGS="$(INTEL_COL_FFLAGS)" \ - FREEFLAG=$(INTEL_FREEFLAG) \ - FIXEDFLAG=$(INTEL_FIXEDFLAG) \ - LINKFLAGS=$(FROST_LINK_FLAGS_NOESMF) \ - LINKLIBS=$(FROST_LINK_LIBS_NOESMF) NEMS="" \ - FLUSH_DEF=$(INTEL_FLUSH_DEF) MKDEPENDS=$(MKDEPENDS) - -.PHONY: cleanall -cleanall: clean -.PHONY: clean -clean: - $(RM) -rf ../FIMsrc_* macros.make - -# Do not use this unless you know what you are doing. -.PHONY: cleanbelow -cleanbelow: - (cd bin && rm -f *) - (cd lib && rm -f *) - (cd icosio && $(MAKE) clean) - (cd cntl && $(MAKE) clean) - (cd bacio && $(MAKE) clean) - (cd w3 && $(MAKE) clean) - (cd utils && $(MAKE) clean) - (cd prep && $(MAKE) clean) - (cd fim && $(MAKE) clean) - (cd post && $(MAKE) clean) diff --git a/src/fim/FIMsrc/Makesub b/src/fim/FIMsrc/Makesub deleted file mode 100644 index 2a64306..0000000 --- a/src/fim/FIMsrc/Makesub +++ /dev/null @@ -1,49 +0,0 @@ -# Makesub - -SHELL = /bin/sh - -include macros.make - -all: - (cd icosio && $(MAKE) CPP="$(CPP)" CPP_FLAGS="$(CPP_FLAGS)" \ - FFLAGS="$(ICOSIO_FFLAGS)" FC="$(FC)" GPTL_FFLAGS="$(GPTL_FFLAGS)") || \ - (echo "Make failure in icosio/" && exit 1) - - (cd sys_share && $(MAKE) MAKE=$(MAKE) FC=$(FC) FFLAGS="$(PREP_FFLAGS)") || \ - (echo "make failure in sys_share/" && exit 1) - - (cd utils && $(MAKE) $(GMAKEMINUSJ) MAKE=$(MAKE) FC=$(FCserial) \ - FFLAGS="$(PREP_FFLAGS)" BINDIR=$(BINDIR) FREEFLAG=$(FREEFLAG) \ - STATIC_FLAG=$(STATIC_FLAG)) || \ - (echo "make failure in utils/" && exit 1) - - (cd cntl && $(MAKE) MAKE=$(MAKE) FC=$(FC) FFLAGS="$(PREP_FFLAGS)") || \ - (echo "make failure in cntl/" && exit 1) - - (cd bacio && $(MAKE) $(GMAKEMINUSJ) MAKE=$(MAKE) CC=$(CC) FC=$(FC) \ - FOPT="$(PREP_FFLAGS)" FREEFLAG=$(FREEFLAG) FIXEDFLAG=$(FIXEDFLAG) \ - COPT="$(CFLAGS)") || \ - (echo "make failure in bacio/" && exit 1) - - (cd w3 && $(MAKE) $(GMAKEMINUSJ) MAKE=$(MAKE) FC=$(FC) FCserial=$(FCserial) \ - FFLAGS="$(PREP_FFLAGS)" FREEFLAG=$(FREEFLAG) FIXEDFLAG=$(FIXEDFLAG) \ - LIBDIR=$(LIBDIR)) || \ - (echo "make failure in w3/" && exit 1) - - (cd prep && $(MAKE) MAKE=$(MAKE) FC=$(FC) FCserial=$(FCserial) \ - FFLAGS="$(PREP_FFLAGS)" SP_FFLAGS="$(SP_FFLAGS)" \ - FFLAGS_NO_DEBUG="$(FFLAGS_NO_DEBUG)" BYTE_SWAP_FLAG=$(BYTE_SWAP_FLAG) \ - FREEFLAG=$(FREEFLAG) FIXEDFLAG=$(FIXEDFLAG) CFLAGS="$(CFLAGS)" \ - SMS=$(SMS)) || \ - (echo "make failure in prep/" && exit 1) - -#JR Compile post before fim because fim links in stuff from post - - (cd post && $(MAKE) MAKE=$(MAKE) FC=$(FCserial) FFLAGS="$(POST_FFLAGS)" \ - INCNETCDF=$(INCNETCDF) LIBNETCDF="$(LIBNETCDF)") || \ - (echo "make failure in post/" && exit 1) - - (cd fim && $(MAKE) MAKE=$(MAKE) FC=$(FC) FFLAGS="$(FIM_FFLAGS)" \ - COLFLAGS="$(COL_FFLAGS)" FREEFLAG=$(FREEFLAG) SMS=$(SMS) \ - LINKFLAGS="$(LINKFLAGS)" LINKLIBS="$(LINKLIBS)" NEMS=$(NEMS)) || \ - (echo "make failure in fim/" && exit 1) diff --git a/src/fim/FIMsrc/bacio/Makefile b/src/fim/FIMsrc/bacio/Makefile deleted file mode 100644 index e3e4201..0000000 --- a/src/fim/FIMsrc/bacio/Makefile +++ /dev/null @@ -1,35 +0,0 @@ -# bacio Makefile - -SHELL=/bin/sh -############################################################### -# -# AUTHOR: Gilbert - W/NP11 -# -# DATE: 01/11/1999 -# -# PURPOSE: This script uses the make utility to update the bacio -# archive libraries. -# -############################################################### - -AFLAGS = -CFLAGS = $(COPT) -FFLAGS = $(FOPT) -INC = clib4.h -LIBB = $(LIBDIR)/libbacio_4.a -OBJS = baciof.o bacio.v1.3.o - -$(LIBB): $(OBJS) - ar ruv $(AFLAGS) $(LIBB) $(OBJS) - -bacio.v1.3.o: bacio.v1.3.c -#JR Make soft link so can work on non-local file systems - ln -s $(INC) clib.h - $(CC) -c $(CFLAGS) $< - $(RM) clib.h - -baciof.o: baciof.f - $(FC) -c $(FFLAGS) $(FIXEDFLAG) $< - -clean: - $(RM) *.o *.mod $(LIBB) diff --git a/src/fim/FIMsrc/bacio/bacio.v1.3.c b/src/fim/FIMsrc/bacio/bacio.v1.3.c deleted file mode 100755 index ddfb224..0000000 --- a/src/fim/FIMsrc/bacio/bacio.v1.3.c +++ /dev/null @@ -1,623 +0,0 @@ -/* Fortran-callable routines to read and write characther (bacio) and */ -/* numeric (banio) data byte addressably */ -/* Robert Grumbine 16 March 1998 */ -/* v1.1: Put diagnostic output under control of define VERBOSE or QUIET */ -/* Add option of non-seeking read/write */ -/* Return code for fewer data read/written than requested */ -/* v1.2: Add cray compatibility 20 April 1998 */ - -#include -#include -#include -#include -#include -/*JR changed malloc.h to stdlib.h (not found on Mac) */ -#include -#include -#include - -/* Include the C library file for definition/control */ -/* Things that might be changed for new systems are there. */ -/* This source file should not (need to) be edited, merely recompiled */ -#include "clib.h" - - -/* Return Codes: */ -/* 0 All was well */ -/* -1 Tried to open read only _and_ write only */ -/* -2 Tried to read and write in the same call */ -/* -3 Internal failure in name processing */ -/* -4 Failure in opening file */ -/* -5 Tried to read on a write-only file */ -/* -6 Failed in read to find the 'start' location */ -/* -7 Tried to write to a read only file */ -/* -8 Failed in write to find the 'start' location */ -/* -9 Error in close */ -/* -10 Read or wrote fewer data than requested */ - -/* Note: In your Fortran code, call bacio, not bacio_. */ -/*int bacio_(int * mode, int * start, int * size, int * no, int * nactual, */ -/* int * fdes, const char *fname, char *data, int namelen, */ -/* int datanamelen) */ -/* Arguments: */ -/* Mode is the integer specifying operations to be performed */ -/* see the clib.inc file for the values. Mode is obtained */ -/* by adding together the values corresponding to the operations */ -/* The best method is to include the clib.inc file and refer to the */ -/* names for the operations rather than rely on hard-coded values */ -/* Start is the byte number to start your operation from. 0 is the first */ -/* byte in the file, not 1. */ -/* Newpos is the position in the file after a read or write has been */ -/* performed. You'll need this if you're doing 'seeking' read/write */ -/* Size is the size of the objects you are trying to read. Rely on the */ -/* values in the locale.inc file. Types are CHARACTER, INTEGER, REAL, */ -/* COMPLEX. Specify the correct value by using SIZEOF_type, where type */ -/* is one of these. (After having included the locale.inc file) */ -/* no is the number of things to read or write (characters, integers, */ -/* whatever) */ -/* nactual is the number of things actually read or written. Check that */ -/* you got what you wanted. */ -/* fdes is an integer 'file descriptor'. This is not a Fortran Unit Number */ -/* You can use it, however, to refer to files you've previously opened. */ -/* fname is the name of the file. This only needs to be defined when you */ -/* are opening a file. It must be (on the Fortran side) declared as */ -/* CHARACTER*N, where N is a length greater than or equal to the length */ -/* of the file name. CHARACTER*1 fname[80] (for example) will fail. */ -/* data is the name of the entity (variable, vector, array) that you want */ -/* to write data out from or read it in to. The fact that C is declaring */ -/* it to be a char * does not affect your fortran. */ -/* namelen - Do NOT specify this. It is created automagically by the */ -/* Fortran compiler */ -/* datanamelen - Ditto */ - - -/* What is going on here is that although the Fortran caller will always */ -/* be calling bacio, the called C routine name will change from system */ -/* to system. */ -#ifdef CRAY90 - #include - int BACIO - (int * mode, int * start, int *newpos, int * size, int * no, - int * nactual, int * fdes, - _fcd fcd_fname, _fcd fcd_datary) { - char *fname, *datary; - int namelen; -#endif -#ifdef HP - int bacio - (int * mode, int * start, int *newpos, int * size, int * no, - int * nactual, int * fdes, const char *fname, char *datary, - int namelen, int datanamelen) { -#endif -#ifdef SGI - int bacio_ - (int * mode, int * start, int *newpos, int * size, int * no, - int * nactual, int * fdes, const char *fname, char *datary, - int namelen, int datanamelen) { -#endif -#ifdef LINUX - int bacio_ - (int * mode, int * start, int *newpos, int * size, int * no, - int * nactual, int * fdes, const char *fname, char *datary, - int namelen, int datanamelen) { -#endif -#ifdef LINUXF90 - int BACIO - (int * mode, int * start, int *newpos, int * size, int * no, - int * nactual, int * fdes, const char *fname, char *datary, - int namelen, int datanamelen) { -#endif -#ifdef IBM4 - int bacio - (int * mode, int * start, int *newpos, int * size, int * no, - int * nactual, int * fdes, const char *fname, char *datary, - int namelen, int datanamelen) { -#endif -#ifdef IBM8 - long long int bacio - (long long int * mode, long long int * start, long long int *newpos, - long long int * size, long long int * no, - long long int * nactual, long long int * fdes, const char *fname, - char *datary, - long long int namelen, long long int datanamelen) { -#endif - int i, j, jret, seekret; - char *realname, *tempchar; - int tcharval; - size_t count; - -/* Initialization(s) */ - *nactual = 0; - -/* Check for illegal combinations of options */ - if (( BAOPEN_RONLY & *mode) && - ( (BAOPEN_WONLY & *mode) || (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) ) ) { - #ifdef VERBOSE - printf("illegal -- trying to open both read only and write only\n"); - #endif - return -1; - } - if ( (BAREAD & *mode ) && (BAWRITE & *mode) ) { - #ifdef VERBOSE - printf("illegal -- trying to both read and write in the same call\n"); - #endif - return -2; - } - -/* This section handles Fortran to C translation of strings so as to */ -/* be able to open the files Fortran is expecting to be opened. */ - #ifdef CRAY90 - namelen = _fcdlen(fcd_fname); - fname = _fcdtocp(fcd_fname); - #endif - if ( (BAOPEN_RONLY & *mode) || (BAOPEN_WONLY & *mode) || - (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) || - (BAOPEN_RW & *mode) ) { - #ifdef VERBOSE - printf("Will be opening a file %s %d\n", fname, namelen); fflush(stdout); - printf("Strlen %d namelen %d\n", strlen(fname), namelen); fflush(stdout); - #endif - realname = (char *) malloc( namelen * sizeof(char) ) ; - if (realname == NULL) { - #ifdef VERBOSE - printf("failed to mallocate realname %d = namelen\n", namelen); - fflush(stdout); - #endif - return -3; - } - tempchar = (char *) malloc(sizeof(char) * 1 ) ; - i = 0; - j = 0; - *tempchar = fname[i]; - tcharval = *tempchar; - while (i == j && i < namelen ) { - fflush(stdout); - if ( isgraph(tcharval) ) { - realname[j] = fname[i]; - j += 1; - } - i += 1; - *tempchar = fname[i]; - tcharval = *tempchar; - } - #ifdef VERBOSE - printf("i,j = %d %d\n",i,j); fflush(stdout); - #endif - realname[j] = '\0'; - } - -/* Open files with correct read/write and file permission. */ - if (BAOPEN_RONLY & *mode) { - #ifdef VERBOSE - printf("open read only %s\n", realname); - #endif - *fdes = open(realname, O_RDONLY , S_IRWXU | S_IRWXG | S_IRWXO ); - } - else if (BAOPEN_WONLY & *mode ) { - #ifdef VERBOSE - printf("open write only %s\n", realname); - #endif - *fdes = open(realname, O_WRONLY | O_CREAT , S_IRWXU | S_IRWXG | S_IRWXO ); - } - else if (BAOPEN_WONLY_TRUNC & *mode ) { - #ifdef VERBOSE - printf("open write only with truncation %s\n", realname); - #endif - *fdes = open(realname, O_WRONLY | O_CREAT | O_TRUNC , S_IRWXU | S_IRWXG | S_IRWXO ); - } - else if (BAOPEN_WONLY_APPEND & *mode ) { - #ifdef VERBOSE - printf("open write only with append %s\n", realname); - #endif - *fdes = open(realname, O_WRONLY | O_CREAT | O_APPEND , S_IRWXU | S_IRWXG | S_IRWXO ); - } - else if (BAOPEN_RW & *mode) { - #ifdef VERBOSE - printf("open read-write %s\n", realname); - #endif - *fdes = open(realname, O_RDWR | O_CREAT , S_IRWXU | S_IRWXG | S_IRWXO ); - } - else { - #ifdef VERBOSE - printf("no openings\n"); - #endif - } - if (*fdes < 0) { - #ifdef VERBOSE - printf("error in file descriptor! *fdes %d\n", *fdes); - #endif - return -4; - } - else { - #ifdef VERBOSE - printf("file descriptor = %d\n",*fdes ); - #endif - } - - -/* Read data as requested */ - if (BAREAD & *mode && - ( (BAOPEN_WONLY & *mode) || (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) ) ) { - #ifdef VERBOSE - printf("Error, trying to read while in write only mode!\n"); - #endif - return -5; - } - else if (BAREAD & *mode ) { - /* Read in some data */ - if (! (*mode & NOSEEK) ) { - seekret = lseek(*fdes, *start, SEEK_SET); - if (seekret == -1) { - #ifdef VERBOSE - printf("error in seeking to %d\n",*start); - #endif - return -6; - } - #ifdef VERBOSE - else { - printf("Seek successful, seek ret %d, start %d\n", seekret, *start); - } - #endif - } - #ifdef CRAY90 - datary = _fcdtocp(fcd_datary); - #endif - if (datary == NULL) { - printf("Massive catastrophe -- datary pointer is NULL\n"); - return -666; - } - #ifdef VERBOSE - printf("file descriptor, datary = %d %d\n", *fdes, (int) datary); - #endif - count = (size_t) *no; - jret = read(*fdes, (void *) datary, count); - if (jret != *no) { - #ifdef VERBOSE - printf("did not read in the requested number of bytes\n"); - printf("read in %d bytes instead of %d \n",jret, *no); - #endif - } - else { - #ifdef VERBOSE - printf("read in %d bytes requested \n", *no); - #endif - } - *nactual = jret; - *newpos = *start + jret; - } -/* Done with reading */ - -/* See if we should be writing */ - if ( BAWRITE & *mode && BAOPEN_RONLY & *mode ) { - #ifdef VERBOSE - printf("Trying to write on a read only file \n"); - #endif - return -7; - } - else if ( BAWRITE & *mode ) { - if (! (*mode & NOSEEK) ) { - seekret = lseek(*fdes, *start, SEEK_SET); - if (seekret == -1) { - #ifdef VERBOSE - printf("error in seeking to %d\n",*start); - #endif - return -8; - } - } - #ifdef CRAY90 - datary = _fcdtocp(fcd_datary); - #endif - if (datary == NULL) { - printf("Massive catastrophe -- datary pointer is NULL\n"); - return -666; - } - #ifdef VERBOSE - printf("write file descriptor, datary = %d %d\n", *fdes, (int) datary); - #endif - count = (size_t) *no; - jret = write(*fdes, (void *) datary, count); - if (jret != *no) { - #ifdef VERBOSE - printf("did not write out the requested number of bytes\n"); - printf("wrote %d bytes instead\n", jret); - #endif - *nactual = jret; - *newpos = *start + jret; - } - else { - #ifdef VERBOSE - printf("wrote %d bytes \n", jret); - #endif - *nactual = jret; - *newpos = *start + jret; - } - } -/* Done with writing */ - - -/* Close file if requested */ - if (BACLOSE & *mode ) { - jret = close(*fdes); - if (jret != 0) { - #ifdef VERBOSE - printf("close failed! jret = %d\n",jret); - #endif - return -9; - } - } -/* Done closing */ - -/* Check that if we were reading or writing, that we actually got what */ -/* we expected, else return a -10. Return 0 (success) if we're here */ -/* and weren't reading or writing */ - if ( (*mode & BAREAD || *mode & BAWRITE) && (*nactual != *no) ) { - return -10; - } - else { - return 0; - } -} -#ifdef CRAY90 - #include - int BANIO - (int * mode, int * start, int *newpos, int * size, int * no, - int * nactual, int * fdes, _fcd fcd_fname, void *datary) { - char *fname; - int namelen; -#endif -#ifdef HP - int banio - (int * mode, int * start, int *newpos, int * size, int * no, - int * nactual, int * fdes, const char *fname, char *datary, - int namelen ) { -#endif -#ifdef SGI - int banio_ - (int * mode, int * start, int *newpos, int * size, int * no, - int * nactual, int * fdes, const char *fname, char *datary, - int namelen ) { -#endif -#ifdef LINUX - int banio_ - (int * mode, int * start, int *newpos, int * size, int * no, - int * nactual, int * fdes, const char *fname, char *datary, - int namelen ) { -#endif -#ifdef LINUXF90 - int BANIO - (int * mode, int * start, int *newpos, int * size, int * no, - int * nactual, int * fdes, const char *fname, char *datary, - int namelen ) { -#endif -#ifdef IBM4 - int banio - (int * mode, int * start, int *newpos, int * size, int * no, - int * nactual, int * fdes, const char *fname, char *datary, - int namelen ) { -#endif -#ifdef IBM8 - long long int banio - (long long int * mode, long long int * start, long long int *newpos, - long long int * size, long long int * no, - long long int * nactual, long long int * fdes, const char *fname, - char *datary, - long long int namelen ) { -#endif - int i, j, jret, seekret; - char *realname, *tempchar; - int tcharval; - -/* Initialization(s) */ - *nactual = 0; - -/* Check for illegal combinations of options */ - if (( BAOPEN_RONLY & *mode) && - ( (BAOPEN_WONLY & *mode) || (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) ) ) { - #ifdef VERBOSE - printf("illegal -- trying to open both read only and write only\n"); - #endif - return -1; - } - if ( (BAREAD & *mode ) && (BAWRITE & *mode) ) { - #ifdef VERBOSE - printf("illegal -- trying to both read and write in the same call\n"); - #endif - return -2; - } - -/* This section handles Fortran to C translation of strings so as to */ -/* be able to open the files Fortran is expecting to be opened. */ - #ifdef CRAY90 - namelen = _fcdlen(fcd_fname); - fname = _fcdtocp(fcd_fname); - #endif - if ( (BAOPEN_RONLY & *mode) || (BAOPEN_WONLY & *mode) || - (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) || - (BAOPEN_RW & *mode) ) { - #ifdef VERBOSE - printf("Will be opening a file %s %d\n", fname, namelen); fflush(stdout); - printf("Strlen %d namelen %d\n", strlen(fname), namelen); fflush(stdout); - #endif - realname = (char *) malloc( namelen * sizeof(char) ) ; - if (realname == NULL) { - #ifdef VERBOSE - printf("failed to mallocate realname %d = namelen\n", namelen); - fflush(stdout); - #endif - return -3; - } - tempchar = (char *) malloc(sizeof(char) * 1 ) ; - i = 0; - j = 0; - *tempchar = fname[i]; - tcharval = *tempchar; - while (i == j && i < namelen ) { - fflush(stdout); - if ( isgraph(tcharval) ) { - realname[j] = fname[i]; - j += 1; - } - i += 1; - *tempchar = fname[i]; - tcharval = *tempchar; - } - #ifdef VERBOSE - printf("i,j = %d %d\n",i,j); fflush(stdout); - #endif - realname[j] = '\0'; - } - -/* Open files with correct read/write and file permission. */ - if (BAOPEN_RONLY & *mode) { - #ifdef VERBOSE - printf("open read only %s\n", realname); - #endif - *fdes = open(realname, O_RDONLY , S_IRWXU | S_IRWXG | S_IRWXO ); - } - else if (BAOPEN_WONLY & *mode ) { - #ifdef VERBOSE - printf("open write only %s\n", realname); - #endif - *fdes = open(realname, O_WRONLY | O_CREAT , S_IRWXU | S_IRWXG | S_IRWXO ); - } - else if (BAOPEN_WONLY_TRUNC & *mode ) { - #ifdef VERBOSE - printf("open write only with truncation %s\n", realname); - #endif - *fdes = open(realname, O_WRONLY | O_CREAT | O_TRUNC , S_IRWXU | S_IRWXG | S_IRWXO ); - } - else if (BAOPEN_WONLY_APPEND & *mode ) { - #ifdef VERBOSE - printf("open write only with append %s\n", realname); - #endif - *fdes = open(realname, O_WRONLY | O_CREAT | O_APPEND , S_IRWXU | S_IRWXG | S_IRWXO ); - } - else if (BAOPEN_RW & *mode) { - #ifdef VERBOSE - printf("open read-write %s\n", realname); - #endif - *fdes = open(realname, O_RDWR | O_CREAT , S_IRWXU | S_IRWXG | S_IRWXO ); - } - else { - #ifdef VERBOSE - printf("no openings\n"); - #endif - } - if (*fdes < 0) { - #ifdef VERBOSE - printf("error in file descriptor! *fdes %d\n", *fdes); - #endif - return -4; - } - else { - #ifdef VERBOSE - printf("file descriptor = %d\n",*fdes ); - #endif - } - - -/* Read data as requested */ - if (BAREAD & *mode && - ( (BAOPEN_WONLY & *mode) || (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) ) ) { - #ifdef VERBOSE - printf("Error, trying to read while in write only mode!\n"); - #endif - return -5; - } - else if (BAREAD & *mode ) { - /* Read in some data */ - if (! (*mode & NOSEEK) ) { - seekret = lseek(*fdes, *start, SEEK_SET); - if (seekret == -1) { - #ifdef VERBOSE - printf("error in seeking to %d\n",*start); - #endif - return -6; - } - #ifdef VERBOSE - else { - printf("Seek successful, seek ret %d, start %d\n", seekret, *start); - } - #endif - } - jret = read(*fdes, datary, *no*(*size) ); - if (jret != *no*(*size) ) { - #ifdef VERBOSE - printf("did not read in the requested number of items\n"); - printf("read in %d items of %d \n",jret/(*size), *no); - #endif - *nactual = jret/(*size); - *newpos = *start + jret; - } - #ifdef VERBOSE - printf("read in %d items \n", jret/(*size)); - #endif - *nactual = jret/(*size); - *newpos = *start + jret; - } -/* Done with reading */ - -/* See if we should be writing */ - if ( BAWRITE & *mode && BAOPEN_RONLY & *mode ) { - #ifdef VERBOSE - printf("Trying to write on a read only file \n"); - #endif - return -7; - } - else if ( BAWRITE & *mode ) { - if (! (*mode & NOSEEK) ) { - seekret = lseek(*fdes, *start, SEEK_SET); - if (seekret == -1) { - #ifdef VERBOSE - printf("error in seeking to %d\n",*start); - #endif - return -8; - } - #ifdef VERBOSE - else { - printf("Seek successful, seek ret %d, start %d\n", seekret, *start); - } - #endif - } - jret = write(*fdes, datary, *no*(*size)); - if (jret != *no*(*size)) { - #ifdef VERBOSE - printf("did not write out the requested number of items\n"); - printf("wrote %d items instead\n", jret/(*size) ); - #endif - *nactual = jret/(*size) ; - *newpos = *start + jret; - } - else { - #ifdef VERBOSE - printf("wrote %d items \n", jret/(*size) ); - #endif - *nactual = jret/(*size) ; - *newpos = *start + jret; - } - } -/* Done with writing */ - - -/* Close file if requested */ - if (BACLOSE & *mode ) { - jret = close(*fdes); - if (jret != 0) { - #ifdef VERBOSE - printf("close failed! jret = %d\n",jret); - #endif - return -9; - } - } -/* Done closing */ - -/* Check that if we were reading or writing, that we actually got what */ -/* we expected, else return a -10. Return 0 (success) if we're here */ -/* and weren't reading or writing */ - if ( (*mode & BAREAD || *mode & BAWRITE) && (*nactual != *no) ) { - return -10; - } - else { - return 0; - } -} diff --git a/src/fim/FIMsrc/bacio/baciof.f b/src/fim/FIMsrc/bacio/baciof.f deleted file mode 100644 index 6e80cbb..0000000 --- a/src/fim/FIMsrc/bacio/baciof.f +++ /dev/null @@ -1,525 +0,0 @@ -C----------------------------------------------------------------------- - MODULE BACIO_MODULE -C$$$ F90-MODULE DOCUMENTATION BLOCK -C -C F90-MODULE: BACIO_MODULE BYTE-ADDRESSABLE I/O MODULE -C PRGMMR: IREDELL ORG: NP23 DATE: 98-06-04 -C -C ABSTRACT: MODULE TO SHARE FILE DESCRIPTORS -C IN THE BYTE-ADDESSABLE I/O PACKAGE. -C -C PROGRAM HISTORY LOG: -C 98-06-04 IREDELL -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - INTEGER,EXTERNAL:: BACIO - INTEGER,DIMENSION(999),SAVE:: FD=999*0 - INTEGER,DIMENSION(20),SAVE:: BAOPTS=0 - INCLUDE 'baciof.h' - END -C----------------------------------------------------------------------- - SUBROUTINE BASETO(NOPT,VOPT) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BASETO BYTE-ADDRESSABLE SET OPTIONS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 -C -C ABSTRACT: SET OPTIONS FOR BYTE-ADDRESSABLE I/O. -C ALL OPTIONS DEFAULT TO 0. -C OPTION 1: BLOCKED READING OPTION -C IF THE OPTION VALUE IS 1, THEN THE READING IS BLOCKED -C INTO FOUR 4096-BYTE BUFFERS. THIS MAY BE EFFICIENT IF -C THE READS WILL BE REQUESTED IN MUCH SMALLER CHUNKS. -C OTHERWISE, EACH CALL TO BAREAD INITIATES A PHYSICAL READ. -C -C PROGRAM HISTORY LOG: -C 1998-06-04 IREDELL -C -C USAGE: CALL BASETO(NOPT,VOPT) -C INPUT ARGUMENTS: -C NOPT INTEGER OPTION NUMBER -C VOPT INTEGER OPTION VALUE -C -C MODULES USED: -C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - USE BACIO_MODULE - INTEGER NOPT,VOPT -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(NOPT.GE.1.AND.NOPT.LE.20) BAOPTS(NOPT)=VOPT -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END -C----------------------------------------------------------------------- - SUBROUTINE BAOPEN(LU,CFN,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BAOPEN BYTE-ADDRESSABLE OPEN -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 -C -C ABSTRACT: OPEN A BYTE-ADDRESSABLE FILE. -C -C PROGRAM HISTORY LOG: -C 1998-06-04 IREDELL -C -C USAGE: CALL BAOPEN(LU,CFN,IRET) -C INPUT ARGUMENTS: -C LU INTEGER UNIT TO OPEN -C CFN CHARACTER FILENAME TO OPEN -C (CONSISTING OF NONBLANK PRINTABLE CHARACTERS) -C OUTPUT ARGUMENTS: -C IRET INTEGER RETURN CODE -C -C MODULES USED: -C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE -C -C SUBPROGRAMS CALLED: -C BACIO BYTE-ADDRESSABLE I/O C PACKAGE -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - USE BACIO_MODULE - CHARACTER CFN*(*) - CHARACTER(80) CMSG -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(LU.LT.001.OR.LU.GT.999) THEN - IRET=6 - RETURN - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IRET=BACIO(BACIO_OPENRW,IB,JB,1,NB,KA,FD(LU),CFN,A) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END -C----------------------------------------------------------------------- - SUBROUTINE BAOPENR(LU,CFN,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BAOPENR BYTE-ADDRESSABLE OPEN -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 -C -C ABSTRACT: OPEN A BYTE-ADDRESSABLE FILE FOR READ ONLY. -C -C PROGRAM HISTORY LOG: -C 1998-06-04 IREDELL -C -C USAGE: CALL BAOPENR(LU,CFN,IRET) -C INPUT ARGUMENTS: -C LU INTEGER UNIT TO OPEN -C CFN CHARACTER FILENAME TO OPEN -C (CONSISTING OF NONBLANK PRINTABLE CHARACTERS) -C OUTPUT ARGUMENTS: -C IRET INTEGER RETURN CODE -C -C MODULES USED: -C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE -C -C SUBPROGRAMS CALLED: -C BACIO BYTE-ADDRESSABLE I/O C PACKAGE -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - USE BACIO_MODULE - CHARACTER CFN*(*) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(LU.LT.001.OR.LU.GT.999) THEN - IRET=6 - RETURN - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IRET=BACIO(BACIO_OPENR,IB,JB,1,NB,KA,FD(LU),CFN,A) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END -C----------------------------------------------------------------------- - SUBROUTINE BAOPENW(LU,CFN,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BAOPENW BYTE-ADDRESSABLE OPEN -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 -C -C ABSTRACT: OPEN A BYTE-ADDRESSABLE FILE FOR WRITE ONLY. -C -C PROGRAM HISTORY LOG: -C 1998-06-04 IREDELL -C -C USAGE: CALL BAOPENW(LU,CFN,IRET) -C INPUT ARGUMENTS: -C LU INTEGER UNIT TO OPEN -C CFN CHARACTER FILENAME TO OPEN -C (CONSISTING OF NONBLANK PRINTABLE CHARACTERS) -C OUTPUT ARGUMENTS: -C IRET INTEGER RETURN CODE -C -C MODULES USED: -C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE -C -C SUBPROGRAMS CALLED: -C BACIO BYTE-ADDRESSABLE I/O C PACKAGE -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - USE BACIO_MODULE - CHARACTER CFN*(*) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(LU.LT.001.OR.LU.GT.999) THEN - IRET=6 - RETURN - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IRET=BACIO(BACIO_OPENW,IB,JB,1,NB,KA,FD(LU),CFN,A) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END -C----------------------------------------------------------------------- - SUBROUTINE BAOPENWT(LU,CFN,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BAOPENWT BYTE-ADDRESSABLE OPEN -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 -C -C ABSTRACT: OPEN A BYTE-ADDRESSABLE FILE FOR WRITE ONLY WITH TRUNCATION. -C -C PROGRAM HISTORY LOG: -C 1998-06-04 IREDELL -C -C USAGE: CALL BAOPENWT(LU,CFN,IRET) -C INPUT ARGUMENTS: -C LU INTEGER UNIT TO OPEN -C CFN CHARACTER FILENAME TO OPEN -C (CONSISTING OF NONBLANK PRINTABLE CHARACTERS) -C OUTPUT ARGUMENTS: -C IRET INTEGER RETURN CODE -C -C MODULES USED: -C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE -C -C SUBPROGRAMS CALLED: -C BACIO BYTE-ADDRESSABLE I/O C PACKAGE -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - USE BACIO_MODULE - CHARACTER CFN*(*) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(LU.LT.001.OR.LU.GT.999) THEN - IRET=6 - RETURN - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IRET=BACIO(BACIO_OPENWT,IB,JB,1,NB,KA,FD(LU),CFN,A) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END -C----------------------------------------------------------------------- - SUBROUTINE BAOPENWA(LU,CFN,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BAOPENWA BYTE-ADDRESSABLE OPEN -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 -C -C ABSTRACT: OPEN A BYTE-ADDRESSABLE FILE FOR WRITE ONLY WITH APPEND. -C -C PROGRAM HISTORY LOG: -C 1998-06-04 IREDELL -C -C USAGE: CALL BAOPENWA(LU,CFN,IRET) -C INPUT ARGUMENTS: -C LU INTEGER UNIT TO OPEN -C CFN CHARACTER FILENAME TO OPEN -C (CONSISTING OF NONBLANK PRINTABLE CHARACTERS) -C OUTPUT ARGUMENTS: -C IRET INTEGER RETURN CODE -C -C MODULES USED: -C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE -C -C SUBPROGRAMS CALLED: -C BACIO BYTE-ADDRESSABLE I/O C PACKAGE -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - USE BACIO_MODULE - CHARACTER CFN*(*) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(LU.LT.001.OR.LU.GT.999) THEN - IRET=6 - RETURN - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IRET=BACIO(BACIO_OPENWA,IB,JB,1,NB,KA,FD(LU),CFN,A) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END -C----------------------------------------------------------------------- - SUBROUTINE BACLOSE(LU,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BACLOSE BYTE-ADDRESSABLE CLOSE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 -C -C ABSTRACT: CLOSE A BYTE-ADDRESSABLE FILE. -C -C PROGRAM HISTORY LOG: -C 1998-06-04 IREDELL -C -C USAGE: CALL BACLOSE(LU,IRET) -C INPUT ARGUMENTS: -C LU INTEGER UNIT TO CLOSE -C OUTPUT ARGUMENTS: -C IRET INTEGER RETURN CODE -C -C MODULES USED: -C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE -C -C SUBPROGRAMS CALLED: -C BACIO BYTE-ADDRESSABLE I/O C PACKAGE -C -C REMARKS: A BAOPEN MUST HAVE ALREADY BEEN CALLED. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - USE BACIO_MODULE -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(LU.LT.001.OR.LU.GT.999) THEN - IRET=6 - RETURN - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IRET=BACIO(BACIO_CLOSE,IB,JB,1,NB,KA,FD(LU),CFN,A) - IF(IRET.EQ.0) FD(LU)=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END -C----------------------------------------------------------------------- - SUBROUTINE BAREAD(LU,IB,NB,KA,A) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BAREAD BYTE-ADDRESSABLE READ -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 -C -C ABSTRACT: READ A GIVEN NUMBER OF BYTES FROM AN UNBLOCKED FILE, -C SKIPPING A GIVEN NUMBER OF BYTES. -C THE PHYSICAL I/O IS BLOCKED INTO FOUR 4096-BYTE BUFFERS -C IF THE BYTE-ADDRESSABLE OPTION 1 HAS BEEN SET TO 1 BY BASETO. -C THIS BUFFERED READING IS INCOMPATIBLE WITH NO-SEEK READING. -C -C PROGRAM HISTORY LOG: -C 1998-06-04 IREDELL -C -C USAGE: CALL BAREAD(LU,IB,NB,KA,A) -C INPUT ARGUMENTS: -C LU INTEGER UNIT TO READ -C IB INTEGER NUMBER OF BYTES TO SKIP -C (IF IB<0, THEN THE FILE IS ACCESSED WITH NO SEEKING) -C NB INTEGER NUMBER OF BYTES TO READ -C OUTPUT ARGUMENTS: -C KA INTEGER NUMBER OF BYTES ACTUALLY READ -C A CHARACTER*1 (NB) DATA READ -C -C MODULES USED: -C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE -C -C SUBPROGRAMS CALLED: -C BACIO BYTE-ADDRESSABLE I/O C PACKAGE -C -C REMARKS: A BAOPEN MUST HAVE ALREADY BEEN CALLED. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - USE BACIO_MODULE - CHARACTER A(NB) - CHARACTER CFN - PARAMETER(NY=4096,MY=4) - INTEGER NS(MY),NN(MY) - CHARACTER Y(NY,MY) - DATA LUX/0/ - SAVE JY,NS,NN,Y,LUX -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(FD(LU).LE.0) THEN - KA=0 - RETURN - ENDIF - IF(IB.LT.0.AND.BAOPTS(1).EQ.1) THEN - KA=0 - RETURN - ENDIF - IF(NB.LE.0) THEN - KA=0 - RETURN - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C UNBUFFERED I/O - IF(BAOPTS(1).NE.1) THEN - IF(IB.GE.0) THEN - IRET=BACIO(BACIO_READ,IB,JB,1,NB,KA,FD(LU),CFN,A) - ELSE - IRET=BACIO(BACIO_READ+BACIO_NOSEEK,0,JB,1,NB,KA,FD(LU),CFN,A) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C BUFFERED I/O -C GET DATA FROM PREVIOUS CALL IF POSSIBLE - ELSE - KA=0 - IF(LUX.NE.LU) THEN - JY=0 - NS=0 - NN=0 - ELSE - DO I=1,MY - IY=MOD(JY+I-1,MY)+1 - KY=IB+KA-NS(IY) - IF(KA.LT.NB.AND.KY.GE.0.AND.KY.LT.NN(IY)) THEN - K=MIN(NB-KA,NN(IY)-KY) - A(KA+1:KA+K)=Y(KY+1:KY+K,IY) - KA=KA+K - ENDIF - ENDDO - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SET POSITION AND READ BUFFER AND GET DATA - IF(KA.LT.NB) THEN - LUX=ABS(LU) - JY=MOD(JY,MY)+1 - NS(JY)=IB+KA - IRET=BACIO(BACIO_READ,NS(JY),JB,1,NY,NN(JY), - & FD(LUX),CFN,Y(1,JY)) - IF(NN(JY).GT.0) THEN - K=MIN(NB-KA,NN(JY)) - A(KA+1:KA+K)=Y(1:K,JY) - KA=KA+K - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CONTINUE TO READ BUFFER AND GET DATA - DOWHILE(NN(JY).EQ.NY.AND.KA.LT.NB) - JY=MOD(JY,MY)+1 - NS(JY)=NS(JY)+NN(JY) - IRET=BACIO(BACIO_READ+BACIO_NOSEEK,NS(JY),JB,1,NY,NN(JY), - & FD(LUX),CFN,Y(1,JY)) - IF(NN(JY).GT.0) THEN - K=MIN(NB-KA,NN(JY)) - A(KA+1:KA+K)=Y(1:K,JY) - KA=KA+K - ENDIF - ENDDO - ENDIF - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END -C----------------------------------------------------------------------- - SUBROUTINE BAWRITE(LU,IB,NB,KA,A) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BAWRITE BYTE-ADDRESSABLE WRITE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 -C -C ABSTRACT: WRITE A GIVEN NUMBER OF BYTES TO AN UNBLOCKED FILE, -C SKIPPING A GIVEN NUMBER OF BYTES. -C -C PROGRAM HISTORY LOG: -C 1998-06-04 IREDELL -C -C USAGE: CALL BAWRITE(LU,IB,NB,KA,A) -C INPUT ARGUMENTS: -C LU INTEGER UNIT TO WRITE -C IB INTEGER NUMBER OF BYTES TO SKIP -C (IF IB<0, THEN THE FILE IS ACCESSED WITH NO SEEKING) -C NB INTEGER NUMBER OF BYTES TO WRITE -C A CHARACTER*1 (NB) DATA TO WRITE -C OUTPUT ARGUMENTS: -C KA INTEGER NUMBER OF BYTES ACTUALLY WRITTEN -C -C MODULES USED: -C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE -C -C SUBPROGRAMS CALLED: -C BACIO BYTE-ADDRESSABLE I/O C PACKAGE -C -C REMARKS: A BAOPEN MUST HAVE ALREADY BEEN CALLED. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - USE BACIO_MODULE - CHARACTER A(NB) - CHARACTER CFN -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(FD(LU).LE.0) THEN - KA=0 - RETURN - ENDIF - IF(NB.LE.0) THEN - KA=0 - RETURN - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(IB.GE.0) THEN - IRET=BACIO(BACIO_WRITE,IB,JB,1,NB,KA,FD(LU),CFN,A) - ELSE - IRET=BACIO(BACIO_WRITE+BACIO_NOSEEK,0,JB,1,NB,KA,FD(LU),CFN,A) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END -C----------------------------------------------------------------------- - SUBROUTINE WRYTE(LU,NB,A) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: WRYTE WRITE DATA OUT BY BYTES -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 -C -C ABSTRACT: WRITE A GIVEN NUMBER OF BYTES TO AN UNBLOCKED FILE. -C -C PROGRAM HISTORY LOG: -C 92-10-31 IREDELL -C 95-10-31 IREDELL WORKSTATION VERSION -C 1998-06-04 IREDELL BACIO VERSION -C -C USAGE: CALL WRYTE(LU,NB,A) -C INPUT ARGUMENTS: -C LU INTEGER UNIT TO WHICH TO WRITE -C NB INTEGER NUMBER OF BYTES TO WRITE -C A CHARACTER*1 (NB) DATA TO WRITE -C -C MODULES USED: -C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE -C -C SUBPROGRAMS CALLED: -C BACIO BYTE-ADDRESSABLE I/O C PACKAGE -C -C REMARKS: A BAOPEN MUST HAVE ALREADY BEEN CALLED. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - USE BACIO_MODULE - CHARACTER A(NB) - CHARACTER CFN -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(FD(LU).LE.0) THEN - RETURN - ENDIF - IF(NB.LE.0) THEN - RETURN - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -CJLEE IRET=BACIO(BACIO_WRITE+BACIO_NOSEEK,0,JB,1,NB,KA,FD(LU),CFN,A) - write(LU) A -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/bacio/baciof.h b/src/fim/FIMsrc/bacio/baciof.h deleted file mode 100755 index 4153e27..0000000 --- a/src/fim/FIMsrc/bacio/baciof.h +++ /dev/null @@ -1,11 +0,0 @@ -! Include file to define variables for Fortran to C interface(s) -! Robert Grumbine 16 March 1998 - INTEGER,PARAMETER:: BACIO_OPENR=1 ! Open file for read only - INTEGER,PARAMETER:: BACIO_OPENW=2 ! Open file for write only - INTEGER,PARAMETER:: BACIO_OPENRW=4 ! Open file for read or write - INTEGER,PARAMETER:: BACIO_CLOSE=8 ! Close file - INTEGER,PARAMETER:: BACIO_READ=16 ! Read from the file - INTEGER,PARAMETER:: BACIO_WRITE=32 ! Write to the file - INTEGER,PARAMETER:: BACIO_NOSEEK=64 ! Start I/O from previous spot - INTEGER,PARAMETER:: BACIO_OPENWT=128 ! Open for write only with truncation - INTEGER,PARAMETER:: BACIO_OPENWA=256 ! Open for write only with append diff --git a/src/fim/FIMsrc/bacio/clib.h.sav b/src/fim/FIMsrc/bacio/clib.h.sav deleted file mode 100755 index 9ba22e5..0000000 --- a/src/fim/FIMsrc/bacio/clib.h.sav +++ /dev/null @@ -1,27 +0,0 @@ -/* Include file to define variables for Fortran to C interface(s) */ -/* Robert Grumbine 16 March 1998 */ -/* NOSEEK added 25 March 1998 */ -/* CRAY compatibility added 20 April 1998 */ - -/* The following line should be either undef or define VERBOSE */ -/* The latter gives noisy debugging output, while the former */ -/* relies solely on the return codes */ -#undef VERBOSE - -/* Declare the system type, supported options are: */ -/* LINUX, SGI, HP, CRAY90, IBM4, IBM8, LINUXF90 */ -#define IBM8 -#include - -/* Do not change things below here yourself */ - -/* IO-related (bacio.c, banio.c) */ -#define BAOPEN_RONLY 1 -#define BAOPEN_WONLY 2 -#define BAOPEN_RW 4 -#define BACLOSE 8 -#define BAREAD 16 -#define BAWRITE 32 -#define NOSEEK 64 -#define BAOPEN_WONLY_TRUNC 128 -#define BAOPEN_WONLY_APPEND 256 diff --git a/src/fim/FIMsrc/bacio/clib4.h b/src/fim/FIMsrc/bacio/clib4.h deleted file mode 100755 index 05ecbd6..0000000 --- a/src/fim/FIMsrc/bacio/clib4.h +++ /dev/null @@ -1,27 +0,0 @@ -/* Include file to define variables for Fortran to C interface(s) */ -/* Robert Grumbine 16 March 1998 */ -/* NOSEEK added 25 March 1998 */ -/* CRAY compatibility added 20 April 1998 */ - -/* The following line should be either undef or define VERBOSE */ -/* The latter gives noisy debugging output, while the former */ -/* relies solely on the return codes */ -#undef VERBOSE - -/* Declare the system type, supported options are: */ -/* LINUX, SGI, HP, CRAY90, IBM4, IBM8, LINUXF90 */ -#define LINUX -#include - -/* Do not change things below here yourself */ - -/* IO-related (bacio.c, banio.c) */ -#define BAOPEN_RONLY 1 -#define BAOPEN_WONLY 2 -#define BAOPEN_RW 4 -#define BACLOSE 8 -#define BAREAD 16 -#define BAWRITE 32 -#define NOSEEK 64 -#define BAOPEN_WONLY_TRUNC 128 -#define BAOPEN_WONLY_APPEND 256 diff --git a/src/fim/FIMsrc/bacio/clib4.h.sav b/src/fim/FIMsrc/bacio/clib4.h.sav deleted file mode 100755 index 6200596..0000000 --- a/src/fim/FIMsrc/bacio/clib4.h.sav +++ /dev/null @@ -1,27 +0,0 @@ -/* Include file to define variables for Fortran to C interface(s) */ -/* Robert Grumbine 16 March 1998 */ -/* NOSEEK added 25 March 1998 */ -/* CRAY compatibility added 20 April 1998 */ - -/* The following line should be either undef or define VERBOSE */ -/* The latter gives noisy debugging output, while the former */ -/* relies solely on the return codes */ -#undef VERBOSE - -/* Declare the system type, supported options are: */ -/* LINUX, SGI, HP, CRAY90, IBM4, IBM8, LINUXF90 */ -#define IBM4 -#include - -/* Do not change things below here yourself */ - -/* IO-related (bacio.c, banio.c) */ -#define BAOPEN_RONLY 1 -#define BAOPEN_WONLY 2 -#define BAOPEN_RW 4 -#define BACLOSE 8 -#define BAREAD 16 -#define BAWRITE 32 -#define NOSEEK 64 -#define BAOPEN_WONLY_TRUNC 128 -#define BAOPEN_WONLY_APPEND 256 diff --git a/src/fim/FIMsrc/bacio/clib8.h b/src/fim/FIMsrc/bacio/clib8.h deleted file mode 100755 index 05ecbd6..0000000 --- a/src/fim/FIMsrc/bacio/clib8.h +++ /dev/null @@ -1,27 +0,0 @@ -/* Include file to define variables for Fortran to C interface(s) */ -/* Robert Grumbine 16 March 1998 */ -/* NOSEEK added 25 March 1998 */ -/* CRAY compatibility added 20 April 1998 */ - -/* The following line should be either undef or define VERBOSE */ -/* The latter gives noisy debugging output, while the former */ -/* relies solely on the return codes */ -#undef VERBOSE - -/* Declare the system type, supported options are: */ -/* LINUX, SGI, HP, CRAY90, IBM4, IBM8, LINUXF90 */ -#define LINUX -#include - -/* Do not change things below here yourself */ - -/* IO-related (bacio.c, banio.c) */ -#define BAOPEN_RONLY 1 -#define BAOPEN_WONLY 2 -#define BAOPEN_RW 4 -#define BACLOSE 8 -#define BAREAD 16 -#define BAWRITE 32 -#define NOSEEK 64 -#define BAOPEN_WONLY_TRUNC 128 -#define BAOPEN_WONLY_APPEND 256 diff --git a/src/fim/FIMsrc/bacio/clib8.h.sav b/src/fim/FIMsrc/bacio/clib8.h.sav deleted file mode 100755 index 9ba22e5..0000000 --- a/src/fim/FIMsrc/bacio/clib8.h.sav +++ /dev/null @@ -1,27 +0,0 @@ -/* Include file to define variables for Fortran to C interface(s) */ -/* Robert Grumbine 16 March 1998 */ -/* NOSEEK added 25 March 1998 */ -/* CRAY compatibility added 20 April 1998 */ - -/* The following line should be either undef or define VERBOSE */ -/* The latter gives noisy debugging output, while the former */ -/* relies solely on the return codes */ -#undef VERBOSE - -/* Declare the system type, supported options are: */ -/* LINUX, SGI, HP, CRAY90, IBM4, IBM8, LINUXF90 */ -#define IBM8 -#include - -/* Do not change things below here yourself */ - -/* IO-related (bacio.c, banio.c) */ -#define BAOPEN_RONLY 1 -#define BAOPEN_WONLY 2 -#define BAOPEN_RW 4 -#define BACLOSE 8 -#define BAREAD 16 -#define BAWRITE 32 -#define NOSEEK 64 -#define BAOPEN_WONLY_TRUNC 128 -#define BAOPEN_WONLY_APPEND 256 diff --git a/src/fim/FIMsrc/bacio/test.c b/src/fim/FIMsrc/bacio/test.c deleted file mode 100755 index 01e7725..0000000 --- a/src/fim/FIMsrc/bacio/test.c +++ /dev/null @@ -1,540 +0,0 @@ -/* Fortran-callable routines to read and write characther (bacio) and */ -/* numeric (banio) data byte addressably */ -/* Robert Grumbine 16 March 1998 */ -/* v1.1: Put diagnostic output under control of define VERBOSE or QUIET */ -/* Add option of non-seeking read/write */ -/* Return code for fewer data read/written than requested */ -/* v1.2: Add cray compatibility 20 April 1998 */ - -#include -#include -#include -#include -#include -/*JR changed malloc.h to stdlib.h (not found on Mac) */ -#include -#include -#include - -/* Include the C library file for definition/control */ -/* Things that might be changed for new systems are there. */ -/* This source file should not (need to) be edited, merely recompiled */ -#include "clib.h" - - -/* Return Codes: */ -/* 0 All was well */ -/* -1 Tried to open read only _and_ write only */ -/* -2 Tried to read and write in the same call */ -/* -3 Internal failure in name processing */ -/* -4 Failure in opening file */ -/* -5 Tried to read on a write-only file */ -/* -6 Failed in read to find the 'start' location */ -/* -7 Tried to write to a read only file */ -/* -8 Failed in write to find the 'start' location */ -/* -9 Error in close */ -/* -10 Read or wrote fewer data than requested */ - -/* Note: In your Fortran code, call bacio, not bacio_. */ -/*int bacio_(int * mode, int * start, int * size, int * no, int * nactual, */ -/* int * fdes, const char *fname, char *data, int namelen, */ -/* int datanamelen) */ -/* Arguments: */ -/* Mode is the integer specifying operations to be performed */ -/* see the clib.inc file for the values. Mode is obtained */ -/* by adding together the values corresponding to the operations */ -/* The best method is to include the clib.inc file and refer to the */ -/* names for the operations rather than rely on hard-coded values */ -/* Start is the byte number to start your operation from. 0 is the first */ -/* byte in the file, not 1. */ -/* Newpos is the position in the file after a read or write has been */ -/* performed. You'll need this if you're doing 'seeking' read/write */ -/* Size is the size of the objects you are trying to read. Rely on the */ -/* values in the locale.inc file. Types are CHARACTER, INTEGER, REAL, */ -/* COMPLEX. Specify the correct value by using SIZEOF_type, where type */ -/* is one of these. (After having included the locale.inc file) */ -/* no is the number of things to read or write (characters, integers, */ -/* whatever) */ -/* nactual is the number of things actually read or written. Check that */ -/* you got what you wanted. */ -/* fdes is an integer 'file descriptor'. This is not a Fortran Unit Number */ -/* You can use it, however, to refer to files you've previously opened. */ -/* fname is the name of the file. This only needs to be defined when you */ -/* are opening a file. It must be (on the Fortran side) declared as */ -/* CHARACTER*N, where N is a length greater than or equal to the length */ -/* of the file name. CHARACTER*1 fname[80] (for example) will fail. */ -/* data is the name of the entity (variable, vector, array) that you want */ -/* to write data out from or read it in to. The fact that C is declaring */ -/* it to be a char * does not affect your fortran. */ -/* namelen - Do NOT specify this. It is created automagically by the */ -/* Fortran compiler */ -/* datanamelen - Ditto */ - - -/* What is going on here is that although the Fortran caller will always */ -/* be calling bacio, the called C routine name will change from system */ -/* to system. */ -#ifdef LINUX - int bacio_ - (int * mode, int * start, int *newpos, int * size, int * no, - int * nactual, int * fdes, const char *fname, char *datary, - int namelen, int datanamelen) { -#endif - int i, j, jret, seekret; - char *realname, *tempchar; - int tcharval; - size_t count; - -/* Initialization(s) */ - *nactual = 0; - -/* Check for illegal combinations of options */ - if (( BAOPEN_RONLY & *mode) && - ( (BAOPEN_WONLY & *mode) || (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) ) ) { - #ifdef VERBOSE - printf("illegal -- trying to open both read only and write only\n"); - #endif - return -1; - } - if ( (BAREAD & *mode ) && (BAWRITE & *mode) ) { - #ifdef VERBOSE - printf("illegal -- trying to both read and write in the same call\n"); - #endif - return -2; - } - -/* This section handles Fortran to C translation of strings so as to */ -/* be able to open the files Fortran is expecting to be opened. */ - #ifdef CRAY90 - namelen = _fcdlen(fcd_fname); - fname = _fcdtocp(fcd_fname); - #endif - if ( (BAOPEN_RONLY & *mode) || (BAOPEN_WONLY & *mode) || - (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) || - (BAOPEN_RW & *mode) ) { - #ifdef VERBOSE - printf("Will be opening a file %s %d\n", fname, namelen); fflush(stdout); - printf("Strlen %d namelen %d\n", strlen(fname), namelen); fflush(stdout); - #endif - realname = (char *) malloc( namelen * sizeof(char) ) ; - if (realname == NULL) { - #ifdef VERBOSE - printf("failed to mallocate realname %d = namelen\n", namelen); - fflush(stdout); - #endif - return -3; - } - tempchar = (char *) malloc(sizeof(char) * 1 ) ; - i = 0; - j = 0; - *tempchar = fname[i]; - tcharval = *tempchar; - while (i == j && i < namelen ) { - fflush(stdout); - if ( isgraph(tcharval) ) { - realname[j] = fname[i]; - j += 1; - } - i += 1; - *tempchar = fname[i]; - tcharval = *tempchar; - } - #ifdef VERBOSE - printf("i,j = %d %d\n",i,j); fflush(stdout); - #endif - realname[j] = '\0'; - } - -/* Open files with correct read/write and file permission. */ - if (BAOPEN_RONLY & *mode) { - #ifdef VERBOSE - printf("open read only %s\n", realname); - #endif - *fdes = open(realname, O_RDONLY , S_IRWXU | S_IRWXG | S_IRWXO ); - } - else if (BAOPEN_WONLY & *mode ) { - #ifdef VERBOSE - printf("open write only %s\n", realname); - #endif - *fdes = open(realname, O_WRONLY | O_CREAT , S_IRWXU | S_IRWXG | S_IRWXO ); - } - else if (BAOPEN_WONLY_TRUNC & *mode ) { - #ifdef VERBOSE - printf("open write only with truncation %s\n", realname); - #endif - *fdes = open(realname, O_WRONLY | O_CREAT | O_TRUNC , S_IRWXU | S_IRWXG | S_IRWXO ); - } - else if (BAOPEN_WONLY_APPEND & *mode ) { - #ifdef VERBOSE - printf("open write only with append %s\n", realname); - #endif - *fdes = open(realname, O_WRONLY | O_CREAT | O_APPEND , S_IRWXU | S_IRWXG | S_IRWXO ); - } - else if (BAOPEN_RW & *mode) { - #ifdef VERBOSE - printf("open read-write %s\n", realname); - #endif - *fdes = open(realname, O_RDWR | O_CREAT , S_IRWXU | S_IRWXG | S_IRWXO ); - } - else { - #ifdef VERBOSE - printf("no openings\n"); - #endif - } - if (*fdes < 0) { - #ifdef VERBOSE - printf("error in file descriptor! *fdes %d\n", *fdes); - #endif - return -4; - } - else { - #ifdef VERBOSE - printf("file descriptor = %d\n",*fdes ); - #endif - } - - -/* Read data as requested */ - if (BAREAD & *mode && - ( (BAOPEN_WONLY & *mode) || (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) ) ) { - #ifdef VERBOSE - printf("Error, trying to read while in write only mode!\n"); - #endif - return -5; - } - else if (BAREAD & *mode ) { - /* Read in some data */ - if (! (*mode & NOSEEK) ) { - seekret = lseek(*fdes, *start, SEEK_SET); - if (seekret == -1) { - #ifdef VERBOSE - printf("error in seeking to %d\n",*start); - #endif - return -6; - } - #ifdef VERBOSE - else { - printf("Seek successful, seek ret %d, start %d\n", seekret, *start); - } - #endif - } - #ifdef CRAY90 - datary = _fcdtocp(fcd_datary); - #endif - if (datary == NULL) { - printf("Massive catastrophe -- datary pointer is NULL\n"); - return -666; - } - #ifdef VERBOSE - printf("file descriptor, datary = %d %d\n", *fdes, (int) datary); - #endif - count = (size_t) *no; - jret = read(*fdes, (void *) datary, count); - if (jret != *no) { - #ifdef VERBOSE - printf("did not read in the requested number of bytes\n"); - printf("read in %d bytes instead of %d \n",jret, *no); - #endif - } - else { - #ifdef VERBOSE - printf("read in %d bytes requested \n", *no); - #endif - } - *nactual = jret; - *newpos = *start + jret; - } -/* Done with reading */ - -/* See if we should be writing */ - if ( BAWRITE & *mode && BAOPEN_RONLY & *mode ) { - #ifdef VERBOSE - printf("Trying to write on a read only file \n"); - #endif - return -7; - } - else if ( BAWRITE & *mode ) { - if (! (*mode & NOSEEK) ) { - seekret = lseek(*fdes, *start, SEEK_SET); - if (seekret == -1) { - #ifdef VERBOSE - printf("error in seeking to %d\n",*start); - #endif - return -8; - } - } - #ifdef CRAY90 - datary = _fcdtocp(fcd_datary); - #endif - if (datary == NULL) { - printf("Massive catastrophe -- datary pointer is NULL\n"); - return -666; - } - #ifdef VERBOSE - printf("write file descriptor, datary = %d %d\n", *fdes, (int) datary); - #endif - count = (size_t) *no; - jret = write(*fdes, (void *) datary, count); - if (jret != *no) { - #ifdef VERBOSE - printf("did not write out the requested number of bytes\n"); - printf("wrote %d bytes instead\n", jret); - #endif - *nactual = jret; - *newpos = *start + jret; - } - else { - #ifdef VERBOSE - printf("wrote %d bytes \n", jret); - #endif - *nactual = jret; - *newpos = *start + jret; - } - } -/* Done with writing */ - - -/* Close file if requested */ - if (BACLOSE & *mode ) { - jret = close(*fdes); - if (jret != 0) { - #ifdef VERBOSE - printf("close failed! jret = %d\n",jret); - #endif - return -9; - } - } -/* Done closing */ - -/* Check that if we were reading or writing, that we actually got what */ -/* we expected, else return a -10. Return 0 (success) if we're here */ -/* and weren't reading or writing */ - if ( (*mode & BAREAD || *mode & BAWRITE) && (*nactual != *no) ) { - return -10; - } - else { - return 0; - } -} - int banio_ - (int * mode, int * start, int *newpos, int * size, int * no, - int * nactual, int * fdes, const char *fname, char *datary, - int namelen ) { - int i, j, jret, seekret; - char *realname, *tempchar; - int tcharval; - -/* Initialization(s) */ - *nactual = 0; - -/* Check for illegal combinations of options */ - if (( BAOPEN_RONLY & *mode) && - ( (BAOPEN_WONLY & *mode) || (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) ) ) { - #ifdef VERBOSE - printf("illegal -- trying to open both read only and write only\n"); - #endif - return -1; - } - if ( (BAREAD & *mode ) && (BAWRITE & *mode) ) { - #ifdef VERBOSE - printf("illegal -- trying to both read and write in the same call\n"); - #endif - return -2; - } - -/* This section handles Fortran to C translation of strings so as to */ -/* be able to open the files Fortran is expecting to be opened. */ - #ifdef CRAY90 - namelen = _fcdlen(fcd_fname); - fname = _fcdtocp(fcd_fname); - #endif - if ( (BAOPEN_RONLY & *mode) || (BAOPEN_WONLY & *mode) || - (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) || - (BAOPEN_RW & *mode) ) { - #ifdef VERBOSE - printf("Will be opening a file %s %d\n", fname, namelen); fflush(stdout); - printf("Strlen %d namelen %d\n", strlen(fname), namelen); fflush(stdout); - #endif - realname = (char *) malloc( namelen * sizeof(char) ) ; - if (realname == NULL) { - #ifdef VERBOSE - printf("failed to mallocate realname %d = namelen\n", namelen); - fflush(stdout); - #endif - return -3; - } - tempchar = (char *) malloc(sizeof(char) * 1 ) ; - i = 0; - j = 0; - *tempchar = fname[i]; - tcharval = *tempchar; - while (i == j && i < namelen ) { - fflush(stdout); - if ( isgraph(tcharval) ) { - realname[j] = fname[i]; - j += 1; - } - i += 1; - *tempchar = fname[i]; - tcharval = *tempchar; - } - #ifdef VERBOSE - printf("i,j = %d %d\n",i,j); fflush(stdout); - #endif - realname[j] = '\0'; - } - -/* Open files with correct read/write and file permission. */ - if (BAOPEN_RONLY & *mode) { - #ifdef VERBOSE - printf("open read only %s\n", realname); - #endif - *fdes = open(realname, O_RDONLY , S_IRWXU | S_IRWXG | S_IRWXO ); - } - else if (BAOPEN_WONLY & *mode ) { - #ifdef VERBOSE - printf("open write only %s\n", realname); - #endif - *fdes = open(realname, O_WRONLY | O_CREAT , S_IRWXU | S_IRWXG | S_IRWXO ); - } - else if (BAOPEN_WONLY_TRUNC & *mode ) { - #ifdef VERBOSE - printf("open write only with truncation %s\n", realname); - #endif - *fdes = open(realname, O_WRONLY | O_CREAT | O_TRUNC , S_IRWXU | S_IRWXG | S_IRWXO ); - } - else if (BAOPEN_WONLY_APPEND & *mode ) { - #ifdef VERBOSE - printf("open write only with append %s\n", realname); - #endif - *fdes = open(realname, O_WRONLY | O_CREAT | O_APPEND , S_IRWXU | S_IRWXG | S_IRWXO ); - } - else if (BAOPEN_RW & *mode) { - #ifdef VERBOSE - printf("open read-write %s\n", realname); - #endif - *fdes = open(realname, O_RDWR | O_CREAT , S_IRWXU | S_IRWXG | S_IRWXO ); - } - else { - #ifdef VERBOSE - printf("no openings\n"); - #endif - } - if (*fdes < 0) { - #ifdef VERBOSE - printf("error in file descriptor! *fdes %d\n", *fdes); - #endif - return -4; - } - else { - #ifdef VERBOSE - printf("file descriptor = %d\n",*fdes ); - #endif - } - - -/* Read data as requested */ - if (BAREAD & *mode && - ( (BAOPEN_WONLY & *mode) || (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) ) ) { - #ifdef VERBOSE - printf("Error, trying to read while in write only mode!\n"); - #endif - return -5; - } - else if (BAREAD & *mode ) { - /* Read in some data */ - if (! (*mode & NOSEEK) ) { - seekret = lseek(*fdes, *start, SEEK_SET); - if (seekret == -1) { - #ifdef VERBOSE - printf("error in seeking to %d\n",*start); - #endif - return -6; - } - #ifdef VERBOSE - else { - printf("Seek successful, seek ret %d, start %d\n", seekret, *start); - } - #endif - } - jret = read(*fdes, datary, *no*(*size) ); - if (jret != *no*(*size) ) { - #ifdef VERBOSE - printf("did not read in the requested number of items\n"); - printf("read in %d items of %d \n",jret/(*size), *no); - #endif - *nactual = jret/(*size); - *newpos = *start + jret; - } - #ifdef VERBOSE - printf("read in %d items \n", jret/(*size)); - #endif - *nactual = jret/(*size); - *newpos = *start + jret; - } -/* Done with reading */ - -/* See if we should be writing */ - if ( BAWRITE & *mode && BAOPEN_RONLY & *mode ) { - #ifdef VERBOSE - printf("Trying to write on a read only file \n"); - #endif - return -7; - } - else if ( BAWRITE & *mode ) { - if (! (*mode & NOSEEK) ) { - seekret = lseek(*fdes, *start, SEEK_SET); - if (seekret == -1) { - #ifdef VERBOSE - printf("error in seeking to %d\n",*start); - #endif - return -8; - } - #ifdef VERBOSE - else { - printf("Seek successful, seek ret %d, start %d\n", seekret, *start); - } - #endif - } - jret = write(*fdes, datary, *no*(*size)); - if (jret != *no*(*size)) { - #ifdef VERBOSE - printf("did not write out the requested number of items\n"); - printf("wrote %d items instead\n", jret/(*size) ); - #endif - *nactual = jret/(*size) ; - *newpos = *start + jret; - } - else { - #ifdef VERBOSE - printf("wrote %d items \n", jret/(*size) ); - #endif - *nactual = jret/(*size) ; - *newpos = *start + jret; - } - } -/* Done with writing */ - - -/* Close file if requested */ - if (BACLOSE & *mode ) { - jret = close(*fdes); - if (jret != 0) { - #ifdef VERBOSE - printf("close failed! jret = %d\n",jret); - #endif - return -9; - } - } -/* Done closing */ - -/* Check that if we were reading or writing, that we actually got what */ -/* we expected, else return a -10. Return 0 (success) if we're here */ -/* and weren't reading or writing */ - if ( (*mode & BAREAD || *mode & BAWRITE) && (*nactual != *no) ) { - return -10; - } - else { - return 0; - } -} diff --git a/src/fim/FIMsrc/cntl/Makefile b/src/fim/FIMsrc/cntl/Makefile deleted file mode 100644 index 5cb4ccd..0000000 --- a/src/fim/FIMsrc/cntl/Makefile +++ /dev/null @@ -1,27 +0,0 @@ -# cntl Makefile - -SHELL = /bin/sh - -include ../macros.make - -FLAGS = $(FFLAGS) $(INCS) -INCS = -I $(UTILDIR) -LIBCNTL = $(LIBDIR)/libcntl.a -OBJS = module_control.o units.o module_constants.o module_wrf_control.o -UTILDIR = ../utils - -.SUFFIXES: -.SUFFIXES: .F90 .o - -.F90.o: - $(FC) -c $(FLAGS) $< - -all: $(LIBCNTL) - -$(LIBCNTL): $(OBJS) - $(AR) ruv $@ $(OBJS) - -module_control.o: module_wrf_control.o units.o - -clean: - $(RM) -r *.o *.mod diff --git a/src/fim/FIMsrc/cntl/module_chem_variables.F90 b/src/fim/FIMsrc/cntl/module_chem_variables.F90 deleted file mode 100644 index 7234c17..0000000 --- a/src/fim/FIMsrc/cntl/module_chem_variables.F90 +++ /dev/null @@ -1,52 +0,0 @@ -!********************************************************************* -module module_chem_variables -! This module specifies chem variables. -!********************************************************************* - -save - -!SMS$DISTRIBUTE(dh,2) BEGIN -real,allocatable :: tr1_tavg (:,:)! tracer time average -real,allocatable :: pm25 (:,:) ! pm2.5 -real,allocatable :: p10 (:,:) ! pm10 -!real,allocatable :: exch (:,:) ! exchange coeffs for chemistry transport -real,allocatable :: oh_backgd(:,:) ! OH background for GOCART -real,allocatable :: h2o2_backgd(:,:) ! H2O2 background for GOCART -real,allocatable :: no3_backgd(:,:) ! NO3 background for GOCART -real,allocatable :: sscal (:,:,:) ! aerosol single scattering albedo -real,allocatable :: ext_cof (:,:,:) ! aerosol extinction coefficients -real,allocatable :: extlw_cof (:,:,:) ! aerosol extinction coefficients -real,allocatable :: asymp (:,:,:) ! aerosol asymetry parameter - -!SMS$DISTRIBUTE END -!SMS$DISTRIBUTE(dh,1) BEGIN -real,allocatable :: rcav(:) ! accumulated convective precipitation since last chem call -real,allocatable :: rnav(:) ! accumulated ls precipitation since last chem call -!real,allocatable :: pb2d(:) ! Boundary layer height -real,allocatable :: ero1(:) ! dust erosion factor -real,allocatable :: ero2(:) ! dust erosion factor -real,allocatable :: ero3(:) ! dust erosion factor -real,allocatable :: clayfrac(:) ! clay fraction (AFWA dust scheme) -real,allocatable :: sandfrac(:) ! sand fraction (AFWA dust scheme) -real,allocatable :: dm0(:) ! dms reference emissions -real,allocatable :: emiss_ab(:,:) ! emissions for all available species -real,allocatable :: emiss_abu(:,:)! emissions for all available species -real,allocatable :: trfall(:,:) ! emissions for all available species -real,allocatable :: emiss_ash_mass(:) ! emissions for -real,allocatable :: emiss_ash_height(:) ! emissions for -real,allocatable :: emiss_ash_dt(:) ! emissions for -real,allocatable :: emiss_tr_mass(:) ! emissions for -real,allocatable :: emiss_tr_height(:) ! emissions for -real,allocatable :: emiss_tr_dt(:) ! emissions for -real,allocatable :: emiss_co2(:) ! emissions for co2, 8 time slices -real,allocatable :: emiss_sf6(:) ! emissions for sf6, 8 time slices ? -real,allocatable :: plumestuff(:,:) ! fire info -real,allocatable :: aod2d(:) ! aerosol optical depth -real,allocatable :: dustfall(:) ! dust fall (g/m2) -real,allocatable :: ashfall(: ) ! volcanic ash fall (g/m2) -real,allocatable :: emiss_oc(:) ! emissions for organic carbon -real,allocatable :: emiss_bc(:) ! emissions for black carbon -real,allocatable :: emiss_sulf(:) ! emissions for sulfate -!SMS$DISTRIBUTE END - -end module module_chem_variables diff --git a/src/fim/FIMsrc/cntl/module_constants.F90 b/src/fim/FIMsrc/cntl/module_constants.F90 deleted file mode 100644 index 69b0162..0000000 --- a/src/fim/FIMsrc/cntl/module_constants.F90 +++ /dev/null @@ -1,93 +0,0 @@ -MODULE module_constants -!******************************************************************** -! This module specifies model constants for fim -! A. E. MacDonald October 11, 2004 -! J. LEE September, 2005 -! J. LEE: values for physical constants are taken from RUC (METCON) -!******************************************************************** -implicit none - -!.................................................................. -! Sec. 1 Math and Physics Constants -!.................................................................. - -real, parameter :: pi = 3.14159265 -real, parameter :: degrad = pi/180. -real, parameter :: raddeg = 180./pi -real, parameter :: ae = 6371220. ! earth radius (m) -real, parameter :: omegx2 = 1.4584e-4! 2 x earth rotation rate (s^-1) -real, parameter :: grvity = 9.80665 ! acceleration from earth gravity (m/(s^2)) -real, parameter :: p1000 = 100000. ! p at 1000mb (pascals) -real, parameter :: cp = 1004.6855 ! specific heat at const pres -real, parameter :: rd = 287.0586 ! spec gas constant for dry air -real, parameter :: rv = 461.50 ! gas constant for H2O -real, parameter :: qvmin = 1.e-10 -real, parameter :: qwmin = 1.e-10 - -!.................................................................. -! Sec. 2. Grid Descriptive Variables -!.................................................................. -real, allocatable :: dpsig (:) ! list of minimum layer thknss (Pa) -real, allocatable :: thetac(:) ! target theta for hybgen -real, allocatable :: sigak(:) ! sigma coordinate formula (used -real, allocatable :: sigbk(:) ! ...only if pure_sig = true) - -!SMS$DISTRIBUTE(dh,3) BEGIN -! velocity transform constants for projection from cell edges -real,allocatable :: cs(:,:,:),sn(:,:,:) - -! Variables to describe the icos grid in xy (local stereographic) -real,allocatable :: sidevec_c(:,:,:) ! side vectors projected from center -real,allocatable :: sidevec_e(:,:,:) ! side vectors projected from edge -!SMS$DISTRIBUTE END - -!SMS$DISTRIBUTE(dh,2) BEGIN -real,allocatable :: sideln ( :,:) ! the length of side vectors (m) -real,allocatable :: rsideln ( :,:) ! reciprocal of "sideln" (m**-1) -real,allocatable :: rprox_ln ( :,:) ! reciprocal of distance cell cent to prox pts -!SMS$DISTRIBUTE END -!SMS$DISTRIBUTE(dh,1) BEGIN -real,allocatable :: area ( :) ! the area of cell polygon (m**2) -real,allocatable :: rarea ( :) ! reciprocal of the "area" -!SMS$DISTRIBUTE END - -!................................................................. -! Sec. 3. Geographic Indices -!................................................................. - -!SMS$DISTRIBUTE(dh,2) BEGIN -integer,allocatable :: prox (:,:) ! Holds index of proximity points -integer,allocatable :: proxs (:,:) ! Holds index of proximity sides -! permedge stores a look-up table for edge indexes. -! For a serial case, permedge does nothing: -! permedge(:,ipn) = 1, 2, 3, ... nprox(ipn) -! For a parallel case, permedge does nothing on "interior" cells. -! For a parallel case, permedge skips "missing" edges on "halo" cells. -integer,allocatable :: permedge (:,:) -!SMS$DISTRIBUTE END -!SMS$DISTRIBUTE(dh,1) BEGIN -integer,allocatable :: nprox ( :) ! Holds number of proximity points -integer,allocatable,target :: inv_perm ( :) ! inverse permutation of the grid -! nedge holds the number of edges valid at each grid cell on this task. -! For a serial ! case, nedge == nprox. -! For a parallel case, nedge == nprox on "interior" cells -! and, nedge < nprox on "halo" cells. -integer,allocatable :: nedge (:) -integer,allocatable :: actual (:) ! actual ipn of halo points (others too) - -!..................................................................... -! Sec. 4. Geo Variables: -!..................................................................... - -real,allocatable :: corio (:) ! Coriolis acceleration -real,allocatable :: lat(:), lon(:) ! lat and lon in radians -real,allocatable :: deg_lat(:),deg_lon(:) ! lat and lon in degrees -character(20) :: StartDate = '2000:07:26::15:25:28' -!SMS$DISTRIBUTE END - -!..................................................................... -! Other variables -!..................................................................... -real,parameter :: spval_p = 999999. - -END MODULE module_constants diff --git a/src/fim/FIMsrc/cntl/module_control.F90 b/src/fim/FIMsrc/cntl/module_control.F90 deleted file mode 100644 index 72ddcb2..0000000 --- a/src/fim/FIMsrc/cntl/module_control.F90 +++ /dev/null @@ -1,370 +0,0 @@ -module module_control -!******************************************************************** -! This module specifies control variables for the global fim -! A. E. MacDonald October 11, 2004 -! J. LEE September, 2005 -!******************************************************************** - -implicit none -save - -! MODEL GRID LEVEL: glvl - -! Grid levels for the globe are: - -! glvl Number of grid points Linear Scale (km) -! 0 12 7,071 -! 1 42 3,779 -! 2 162 1,174 -! 3 642 891 -! 4 2562 446 -! 5 10,242 223 -! 6 40,962 111 -! 7 163,842 56 -! 8 655,362 28 -! 9 2,621,442 14 -! 10 10,485,762 7 -! 11 41,943,042 3.5 -! 12 167,772,162 1.75 - -integer , parameter :: nr=10 ! number of rhombi -integer , parameter :: npp=6 ! number of proximity points(max) -integer , parameter :: nd=2 ! number of directions (x,y) -integer , parameter :: nabl=3 ! number adams bashforth levels -integer , parameter :: VarNameLen=4 ! length of variable names for output routines -integer , parameter :: filename_len=80 ! max length of output filenames -!integer :: ntr=4 ! # of tracers, 1=theta, 2=qv, 3=qw, 4=O3 -integer :: ntra=4 ! # of tracers advected on small dt, 1=theta, 2=qv, 3=qw, 4=O3 -integer :: ntrb=0 ! # of tracers advected on large dt (will include chemistry) -!integer , parameter :: nvarp=5 ! # of isobaric variables, 1=height, 2=temp, 3=RH,4=U,5=V -integer :: nvarp=5 ! # of isobaric variables, 1=height, 2=temp, 3=RH,4=U,5=V -integer , parameter :: kbl=2 ! number of thin layers in surface boundary lyr -! integer , parameter :: nvlp = 40 ! number of isobaric levels - 1000-25 hPa -integer , parameter :: nvar2d = 6 ! number of extra 2d diagnostic variables for output -integer :: stencl_frst=0 ! lowest layer for stencl diagnostics -integer :: stencl_last=0 ! uppermost layer for stencl diagnostics -integer :: stencl_step=0 ! layer increment in stencl diagnostics -integer :: nvlp = 0 ! number of isobaric vertical levels - ex. 1000-25 hPa -integer, allocatable :: pres_hpa(:) ! Holds isobaric vertical levels (hPa) -integer, allocatable :: pres_pa(:) ! Holds isobaric vertical levels (Pa) - -! namelist variables -!------------------- -integer :: glvl ! the grid level defined in the Makefile -integer :: nvl ! number of vertical native layers -integer :: curve=1 ! 0: ij order; 1: Hilbert curve order; 2: ij block order, 3: Square Layout -integer :: NumCacheBlocksPerPE=1 ! Number of cache blocks per processor. Used only for ij block order -logical :: alt_topo=.false. ! if true: use non-GFS surface height -character(2) :: ArchvTimeUnit='hr' ! ts:timestep; mi:minute; hr:hour; dy:day; mo:month -integer :: TotalTime=5 ! total integration time in ArchvTimeUnit -integer :: ArchvIntvl=6 ! archive interval in ArchvTimeUnit -integer :: ArchvStep=1 ! archive interval in time steps -real :: hrs_in_month=730. ! length of month in hrs (=24*365/12) -integer :: nts = -999 ! number of time steps to run: init to bad value - -! OUTPUTnamelist items related to restart -integer :: restart_freq = 999999 ! Interval (units=ArchvTimeUnit) to write restart file -integer :: itsStart = 1 ! index of starting time step (is and always has been 1) -logical :: readrestart = .false. ! True means start by reading a restart file (default false) -! End of OUTPUTnamelist items related to restart - -logical :: UpdateSST = .false. ! True means update SST field with interpolated monthly SST and Sea Ice Fraction (redef in FIMnamelist) -logical :: EnKFAnl = .false. ! True means start by reading an EnKF analysis file (redef in FIMnamelist) -logical :: EnKFIO = .false. ! True means special IO for EnKF analysis. -integer :: PrintIpnDiag = -1 ! Global ipn value at which to print diagnostics (-1 means no print) -integer :: PrintDiagProgVars= 6 ! Hourly increment to print diagnostic prognosis variables (-1=>none, 0=>every step) -integer :: PrintDiagNoise = 1 ! Hourly increment to print diagnostic gravity wave noise (-1=>none, 0=>every step) -logical :: PrintDiags = .false. ! True means print diagnostic messages (redef in FIMnamelist) -integer :: PhysicsInterval = 0 ! Interval in seconds to call physics, 0 => every time step -integer :: RadiationInterval=3600 ! Interval in seconds to call radiation, 0 => every time step -integer :: SSTInterval=-999 ! Interval in seconds to call sst, 0 => every time step (redef in FIMnamelist) -character(12) :: yyyymmddhhmm ! Forecast initial time -logical :: GravityWaveDrag=.true. ! True means calculate gravity wave drag -logical :: digifilt=.false. ! True means use digitial filter - -logical :: ras = .false. ! false means call SAS -integer :: num_p3d = 4 ! 4 means call Zhao/Carr/Sundqvist Microphysics -character(80) :: EnKFFileName='enkf.anal' ! Name of the EnKF analysis file -character(80) :: FGFileName ='fg.hybrid' ! Name of the EnKF analysis file -character(80) :: FGFileNameSig='fg.sigma' ! Name of the EnKF analysis file -character(80) :: sst_dat='HADISST_MONTHLY.1991-2009' ! Name of SST file -character(80) :: ocean_bcs_ltln='ocean_bcs_ltln.360x180.dat' -logical :: PrintMAXMINtimes=.true.! True means print MAX MIN routine times, false means print for each PE -logical :: TimingBarriers=.false. ! True means insert timed barriers to measure task skew, will slow down model -logical :: FixedGridOrder=.true. ! True => always output in the same order (IJ), False => order determined by curve -!Control variables calculated in init.F90 from namelist variables -integer :: CallPhysics ! Timestep interval to call physics -integer :: CallRadiation ! Timestep interval to call radiation -integer :: CallSST ! Timestep interval to call radiation -integer :: ipnDiagLocal = 0 ! Local ipn value at which to print diagnostics -integer :: ipnDiagPE = -1 ! Processor on which ipnDiag resides. -integer :: TestDiagProgVars ! Calculated test value for printing diagnostic prognosis variables -integer :: TestDiagNoise ! Calculated test value for printing diagnostic gravity wave noise - -integer :: nip ! # of icosahedral points -integer :: nvlp1 ! # of vertical levels (= layers+1) -real :: dt ! model time step (seconds) -integer :: dtratio = 6 ! tracer B / tracer A timestep ratio -real :: tfiltwin ! length of digital filter window (secs) -integer :: wts_type=3 ! type of digital filter window (1=Lanczos,2=Hamming,3=Dolph) -integer :: numphr ! # of time steps/hr -integer :: nx ! rhombus x dimension -integer :: ny ! rhombus y dimension -real :: rleigh_light = 0. ! rayleigh damping time scale (days^-1) if top-layer wind < 100 m/s -real :: rleigh_heavy = 0.2 ! rayleigh damping time scale (days^-1) if top-layer wind > 100 m/s -real :: ptop= 10. ! pres at top of model domain (Pa) -real :: thktop = 0. ! min.thickness (Pa) of uppermost layer -integer :: prev_date(4),next_date(4) ! time information for SST and ICE FRACTION slices held in memory -logical :: have_next_sst=.false. ! true when day = mid month, and sst's have been updated to next month - - -!TOPOnamelist -integer :: toponpass=0 ! number of passes of shuman smoother-desmoother of input 5' wrf topo grid -real :: toposmoothfact=1.25 ! radius of influence factor in grid lengths -character(120):: topodatfile='/no_such_file' ! path to topo dat file (set in FIMnamelist) -character(120):: topoglvldir='./' ! dir of glvl.dat -character(len=80):: gfsltln_file ='NO_SUCH_FILE' -character(len=80):: mtnvar_file ='NO_SUCH_FILE' -character(len=80):: aerosol_file ='NO_SUCH_FILE' -character(len=80):: co2_2008_file='NO_SUCH_FILE' -character(len=80):: co2_glb_file ='NO_SUCH_FILE' -character(len=80) :: isobaric_levels_file='NO_SUCH_FILE' - -logical :: pure_sig = .false. ! if true, use pure sigma coord. -real :: intfc_smooth = 50. ! diffusivity (m/s) for intfc smoothing -real :: slak = 0.5 ! intfc movement retardation coeff. -real :: veldff_bkgnd = 0. ! diffusion velocity (=diffusion/mesh size) -real :: veldff_boost = 0. ! veldff at model top (linear ramp-up over several layers) -real :: dt_reducer_numerator = 8. ! dt = dt * dt_reducer_numerator/dt_reducer_denominator -real :: dt_reducer_denominator = 9. - -integer :: i = 0 - -contains - -subroutine control(quiet_arg) -!SMS$ignore begin -use read_queue_namelist,only: ReturnGLVL,ReturnNVL,ReturnNIP,ReturnDT,GetWRFOn -use module_wrf_control, only: wrf_control ! to re-compute ntra if needed -use units, only: getunit, returnunit -!SMS$ignore end -! arguments -logical, optional, intent(in) :: quiet_arg - -! local variables -logical :: quiet -logical :: wrf_flag -integer :: unitno -!integer :: ioerr -! Define and read in the namelists -NAMELIST /PREPnamelist/ curve,NumCacheBLocksPerPE,alt_topo,gfsltln_file,mtnvar_file & - ,aerosol_file,co2_2008_file,co2_glb_file -NAMELIST /DIAGnamelist/ PrintIpnDiag,PrintDiagProgVars,PrintDiagNoise,PrintDiags -NAMELIST /MODELnamelist/ nts, & - digifilt,wts_type,tfiltwin, & - rleigh_light,rleigh_heavy,ptop,thktop, & - pure_sig,intfc_smooth,slak,veldff_bkgnd, & - veldff_boost,UpdateSST,dt_reducer_numerator, & - dt_reducer_denominator, & - EnKFAnl,EnKFIO,sst_dat,ocean_bcs_ltln,dtratio -NAMELIST /TIMEnamelist/ yyyymmddhhmm -NAMELIST /OUTPUTnamelist/TotalTime,ArchvTimeUnit,ArchvIntvl,PrintMAXMINtimes, & - FixedGridOrder,TimingBarriers, & - restart_freq, readrestart, itsStart - -NAMELIST /ISOBARICnamelist/isobaric_levels_file -! namelist for calculating topo from wrf 5' data -namelist /TOPOnamelist/ toponpass,toposmoothfact,topodatfile,topoglvldir - -quiet = .false. -if (present(quiet_arg)) then - quiet = quiet_arg -end if - -unitno = getunit () -if (unitno < 0) then - print*,'control: getunit failed for namelist files. Stopping' - stop -end if - -! Note: REWIND required by IBM! -! TODO: Using open-read-close in place of REWIND until SMS is updated -!JR The following commented "open" call DOES NOT WORK! SMS puts a if(iam_root) around the -!JR iostat=ioerr, meaning the test on slave nodes uses an uninitialized value! Instead use -!JR antiquated "err=" feature. -!OPEN (10, file="./FIMnamelist", status='old', action='read', iostat=ioerr) -!TODO: Fix the requirement to use antiquated f77 features - -open (unitno, file="./FIMnamelist", status='old', action='read', err=70) -write(6,*) 'control: successfully opened FIMnamelist' -read (unitno, NML=PREPnamelist, err=90) -close (unitno) - -!TODO: If we're reading a restart file, skip reading the other namelists and read from disk -open (unitno, file="./FIMnamelist", status='old', action='read', err=70) -read (unitno, NML=DIAGnamelist, err=90) -close (unitno) - -open (unitno, file="./FIMnamelist", status='old', action='read', err=70) -read (unitno, NML=MODELnamelist, err=90) -close (unitno) - -open (unitno, file="./FIMnamelist", status='old', action='read', err=70) -read (unitno, NML=TIMEnamelist, err=90) -close (unitno) - -open (unitno, file="./FIMnamelist", status='old', action='read', err=70) -read (unitno, NML=OUTPUTnamelist, err=90) -close (unitno) - -!JR Isnt it OK to enforce that toponamelist has to be there, but it can be empty? -open (unitno, file="./FIMnamelist", status='old', action='read') -read (unitno, NML=TOPOnamelist) ! OK to use defaults if /TOPOnamelist/ not present -close (unitno) - -open (unitno, file="./FIMnamelist", status='old', action='read', err=70) -read (unitno, NML=ISOBARICnamelist, err=75) -close (unitno) -! need to read file and do initialization here because this is needed by both fim and pop -open (unitno, file="./"//isobaric_levels_file, form="formatted", status="old", err=80) -print *, 'module_control: opened: ', isobaric_levels_file -read (unitno, *, err=81) nvlp - -if (readrestart) then - if (updatesst) then - write(6,*)'control: restart does not yet work with updatesst=.true.' - call flush(6) - stop - end if - - if (enkfanl) then - write(6,*)'control: restart does not yet work with enkfanl=.true.' - call flush(6) - stop - end if - - if (digifilt) then - write(6,*)'control: restart does not yet work with digifilt=.true.' - call flush(6) - stop - end if -end if - -allocate (pres_hpa(nvlp)) -allocate (pres_pa(nvlp)) -read (unitno, *, err=82) pres_hpa -close (unitno) -call returnunit (unitno) - -do i=1,nvlp - pres_pa(i) = pres_hpa(i) * 100 -end do - -print *, '*** nvlp: ', nvlp -print '(a/(10i4))','pres (hPa):',pres_hpa -print '(a/(10i7))','pres (pa):',pres_pa - -if (.not.quiet) then - write(*, NML=PREPnamelist) - write(*, NML=DIAGnamelist) - write(*, NML=MODELnamelist) - write(*, NML=TIMEnamelist) - write(*, NML=OUTPUTnamelist) - write(*, NML=TOPOnamelist) - write(*, NML=ISOBARICnamelist) -end if - -!SMS$serial begin -call ReturnGLVL(glvl) -call ReturnNVL ( nvl) -call ReturnNIP (nip) -call ReturnDT(dt) -call GetWRFOn(wrf_flag) -!SMS$serial end - -if (glvl>=7) dt = dt * dt_reducer_numerator / dt_reducer_denominator -nvlp1 = nvl+1 ! # of vertical levels (= layers+1) -!dt = 5760./2**(glvl-1) ! model time step (seconds) -numphr = nint(3600./dt) ! # of time steps/hr -!dt = 3600./float(numphr) -nx = 2**glvl ! rhombus x dimension -ny = 2**glvl ! rhombus y dimension - -if (wrf_flag) then - ! add WRF variables to ntr-dimensioned arrays, if needed - call wrf_control(nvarp,ntrb) -end if -!ntra = ntr - -if (curve == 0) then !The grid order is already IJ for curve=0. - FixedGridOrder=.false. -end if - -if (ArchvTimeUnit == 'ts') then - nts = TotalTime - ArchvStep = ArchvIntvl -else if (ArchvTimeUnit == 'mi') then - nts = TotalTime*numphr/60 - ArchvStep = nint(60.*ArchvIntvl/dt) - restart_freq = restart_freq*numphr/60 -else if (ArchvTimeUnit == 'hr') then - nts = TotalTime*numphr - ArchvStep = nint(3600.*ArchvIntvl/dt) - restart_freq = restart_freq*numphr -else if (ArchvTimeUnit == 'dy') then - nts = TotalTime*24*numphr - ArchvStep = nint(86400.*ArchvIntvl/dt) - restart_freq = restart_freq*numphr*24 -else if (ArchvTimeUnit == 'mo') then - nts = TotalTime*hrs_in_month*numphr - ArchvStep = nint(hrs_in_month*3600.*ArchvIntvl/dt) - restart_freq = restart_freq*numphr*30*24 -else - write (*,'(a,a)') 'ERROR in module_control unrecognized output time unit: ',ArchvTimeUnit - stop -end if - -if (PrintDiagProgVars == 0) then - TestDiagProgVars = 1 -else if (PrintDiagProgVars < 0) then - TestDiagProgVars = 2*nts -else - TestDiagProgVars = PrintDiagProgVars*numphr -end if - -if (PrintDiagNoise == 0) then - TestDiagNoise = 1 -else if (PrintDiagNoise < 0) then - TestDiagNoise = 2*nts -else - TestDiagNoise = PrintDiagNoise*numphr -end if - -return - -70 write(6,*)'control: error opening ./FIMnamelist' -call flush(6) -stop - -75 write(6,*)'control: error reading ./ISOBARICnamelist' -call flush(6) -stop - -80 write(6,*)'module_control: error reading isobaric_levels_file: COULD NOT OPEN: ', isobaric_levels_file, ' program aborted' -call flush(6) -stop - -81 write(6,*)'module_control: error reading isobaric_levels_file - nvlp - program aborted' -call flush(6) -stop - -82 write(6,*)'module_control: error reading isobaric_levels_file - pres_ha - program aborted' -call flush(6) -stop - -90 write(6,*)'control: error reading one of the namelists in ./FIMnamelist' -call flush(6) -stop - -end subroutine control -end module module_control diff --git a/src/fim/FIMsrc/cntl/module_decomp.F90 b/src/fim/FIMsrc/cntl/module_decomp.F90 deleted file mode 100644 index 32fe92c..0000000 --- a/src/fim/FIMsrc/cntl/module_decomp.F90 +++ /dev/null @@ -1,3 +0,0 @@ -module module_decomp -!SMS$DECLARE_DECOMP(dh,1:unstructured) -end module module_decomp diff --git a/src/fim/FIMsrc/cntl/module_sfc_variables.F90 b/src/fim/FIMsrc/cntl/module_sfc_variables.F90 deleted file mode 100644 index 6f81417..0000000 --- a/src/fim/FIMsrc/cntl/module_sfc_variables.F90 +++ /dev/null @@ -1,74 +0,0 @@ -module module_sfc_variables -!********************************************************************* -! Single-precision storage for dynamics versions of physics -! variables passed from PHY to DYN via CPL for FIM diagnostics -! and output *only*. -!********************************************************************* - -save - -!SMS$DISTRIBUTE (dh,1) BEGIN -!JR Moved these 5 things from output.F90 so they can be written to the restart file. -real,allocatable :: rn2d0(:) ! ? -real,allocatable :: rc2d0(:) ! ? -real,allocatable :: rg2d0(:) ! ? -real,allocatable :: flxswavg2d(:) ! ? -real,allocatable :: flxlwavg2d(:) ! ? - -real,allocatable :: rn2d(:) ! accumulated total precipitation/rainfall -real,allocatable :: rc2d(:) ! accumulated convective precipitation/rainfall -real,allocatable :: ts2d(:) ! skin temperature -real,allocatable :: us2d(:) ! friction velocity/equivalent momentum flux -real,allocatable :: hf2d(:) ! sensible heat flux -real,allocatable :: qf2d(:) ! water vapor/equivalent latent heat flux -real,allocatable :: sheleg2d(:) -real,allocatable :: canopy2d(:) -real,allocatable :: hice2d(:) -real,allocatable :: fice2d(:) -real,allocatable :: sst_prev(:) ! skin temperature previous month (sst holder) -real,allocatable :: sst_next(:) ! skin temperature next month (sst holder) -real,allocatable :: fice2d_prev(:) ! holder for previous months ice fraction -real,allocatable :: fice2d_next(:) ! holder for next months ice fra -real,allocatable :: sw2d(:) ! downward short-wave radiation flux -real,allocatable :: lw2d(:) ! downward long-wave radiation flux -real,allocatable :: t2m2d(:) ! 2-meter temp. -real,allocatable :: q2m2d(:) ! 2-meter spfh (JR: accumulated precip/rainfall?) -real,allocatable :: slmsk2d(:) -real,allocatable :: flxlwtoa2d(:) ! time-mean downward lw radiation flux at TOA -!!! added for digitial filter -real,allocatable :: zorl2d(:) -real,allocatable :: vfrac2d(:) -real,allocatable :: vtype2d(:) -real,allocatable :: stype2d(:) -real,allocatable :: srflag2d(:) -real,allocatable :: tg32d(:) -real,allocatable :: cv2d(:) -real,allocatable :: cvb2d(:) -real,allocatable :: cvt2d(:) -real,allocatable :: alvsf2d(:) -real,allocatable :: alvwf2d(:) -real,allocatable :: alnsf2d(:) -real,allocatable :: alnwf2d(:) -real,allocatable :: f10m2d(:) -real,allocatable :: facsf2d(:) -real,allocatable :: facwf2d(:) -real,allocatable :: uustar2d(:) -real,allocatable :: ffmm2d(:) -real,allocatable :: ffhh2d(:) -real,allocatable :: slc2d(:) -real,allocatable :: snwdph2d(:) -real,allocatable :: shdmin2d(:) -real,allocatable :: shdmax2d(:) -real,allocatable :: slope2d(:) -real,allocatable :: snoalb2d(:) -real,allocatable :: tprcp2d(:) ! precip rate (1000*kg/m**2) - -!SMS$DISTRIBUTE END -!SMS$DISTRIBUTE (dh,2) BEGIN -real,allocatable :: st3d(:,:) ! soil temperature -real,allocatable :: sm3d(:,:) ! soil moisture -real,allocatable :: slc3d(:,:) ! soil liquid content -real,allocatable :: hprm2d(:,:) ! hprm2d(14,nip) -!SMS$DISTRIBUTE END - -end module module_sfc_variables diff --git a/src/fim/FIMsrc/cntl/module_variables.F90 b/src/fim/FIMsrc/cntl/module_variables.F90 deleted file mode 100644 index 71caa4c..0000000 --- a/src/fim/FIMsrc/cntl/module_variables.F90 +++ /dev/null @@ -1,97 +0,0 @@ -module module_variables -!********************************************************************* -! This module specifies the variables used in the fim -! A. E. MacDonald October 11 2004 -! J. Lee September 2004 -! R. Bleck Cleanup April 2008 -! Middlecoff Dynamic allocation October 2008 -! Henderson Move PHY vars. to June 2009 -! module_sfc_variables. -!********************************************************************* - -implicit none -save -!..................................................................... -! Sec. 1. 3D Primary Variables -!..................................................................... -! State variables at center point of cell for 3D grid: - -! Layer variables are defined in the middle of the layer -!SMS$DISTRIBUTE(dh,2) BEGIN -real,pointer :: us3d (:,:) ! zonal wind (m/s) -real,pointer :: vs3d (:,:) ! meridional wind (m/s) -real,pointer :: ws3d (:,:) ! vertical wind (Pa/s) -real,allocatable :: dp3d (:,:) ! del p between coord levels (pascals) -real,allocatable :: dpinit(:,:) ! lyr thknss for class B tracer transport -real,allocatable :: mp3d (:,:) ! Montgomery Potential (m^2/s^2) -real,allocatable :: tk3d (:,:) ! temperature, kelvin -real,allocatable :: vor (:,:) ! absolute vorticity (s^-1) -real,pointer :: tr3d (:,:,:) ! 1=pot.temp,2=water vapor,3=cloud water,4=ozone -real,allocatable :: trdp (:,:,:) ! (tracer x thknss) for tracer transport eq. -real,allocatable :: rh3d (:,:) ! relative humidity from 0 to 1 -real,allocatable :: qs3d (:,:) ! saturation specific humidity -!SMS$DISTRIBUTE END -!SMS$DISTRIBUTE(dh,1) BEGIN -real,allocatable :: pw2d(:) ! precipitable water -!SMS$DISTRIBUTE END - -!SMS$DISTRIBUTE(dh,2) BEGIN -! Level variables defined at layer interfaces -real,pointer :: pr3d(:,:) ! pressure (pascal) -real,allocatable :: ex3d(:,:) ! exner function -real,allocatable :: ph3d(:,:) ! geopotential (=gz), m^2/s^2 -real,allocatable :: sdot(:,:) ! mass flux across interfaces, sdot*(dp/ds) - -!..................................................................... -! Sec. 3. Forcing (tendency) Variables -!..................................................................... -integer :: curr_write_time = 0 ! For time avg'd output vars: restart will overwrite -integer :: nf,of,vof ! Adams Bashforth time slots -real :: adbash1,adbash2,adbash3 ! Adams Bashforth weights -real,allocatable :: u_tdcy (:,:,:) ! forcing of u -real,allocatable :: v_tdcy (:,:,:) ! forcing of v -real,allocatable :: dp_tdcy (:,:,:) ! forcing of dp -real,allocatable :: dpl_tdcy(:,:,:) ! forcing dp, low order -real,allocatable :: trc_tdcy(:,:,:,:) ! forcing of tracers -real,allocatable :: trl_tdcy(:,:,:,:) ! forcing of tracers, low order -real,allocatable :: massflx(:,:,:) -real,allocatable :: u_tdcy_phy (:,:) ! physics forcing of u -real,allocatable :: v_tdcy_phy (:,:) ! physics forcing of v -real,allocatable :: trc_tdcy_phy(:,:,:) ! physics forcing of tracers -!SMS$DISTRIBUTE END - -!SMS$DISTRIBUTE(dh,3) BEGIN -!.................................................................. -! Sec. 4. Edge Variables -!.................................................................. -! Variables carried at the midpoints of the 6(5) sides of each cell -real,allocatable :: u_edg (:,:,:) ! u on edge -real,allocatable :: v_edg (:,:,:) ! v on edge -real,allocatable :: dp_edg (:,:,:) ! dp on edge -real,allocatable :: trc_edg (:,:,:,:) ! tracers on edge -real,allocatable :: lp_edg (:,:,:) ! mid-layer pressure on edge -real,allocatable :: bnll_edg(:,:,:) ! bernoulli fct (montg + kin energy) on edge -real,allocatable :: massfx (:,:,:,:) ! mass fluxes on edge at 3 time levels -real,allocatable :: cumufx (:,:,:) ! time-integrated mass fluxes on edges -!SMS$DISTRIBUTE END - -!.................................................................... -! Sec. 5. Misc. arrays -!.................................................................... -!SMS$DISTRIBUTE(dh,1) BEGIN -real ,allocatable :: work2d (: ) -integer,allocatable :: iwork2d(: ) -real ,allocatable :: psrf (: ) ! surface pressure -real ,allocatable :: ptdcy (:,:) ! sfc.pres.tdcy at 2 consec.time levels -!SMS$DISTRIBUTE END - -!SMS$DISTRIBUTE(dh,2) BEGIN -real ,allocatable :: worka (:,:) ! 3d work array -real ,allocatable :: workb (:,:) ! 3d work array -!SMS$DISTRIBUTE END - -!SMS$DISTRIBUTE(dh,2) BEGIN -real ,allocatable :: diaga (:,:) ! 3d diagnosic array -real ,allocatable :: diagb (:,:) ! 3d diagnosic array -!SMS$DISTRIBUTE END -end module module_variables diff --git a/src/fim/FIMsrc/cntl/module_wrf_control.F90 b/src/fim/FIMsrc/cntl/module_wrf_control.F90 deleted file mode 100644 index 57c968c..0000000 --- a/src/fim/FIMsrc/cntl/module_wrf_control.F90 +++ /dev/null @@ -1,93 +0,0 @@ -module module_wrf_control -implicit none - -!******************************************************************** -! This module specifies control variables for wrf physics -! and chemistry. -!******************************************************************** - -! standard WRF index bounds -integer :: ims ! =1 -integer :: ime ! =1 -integer :: ids ! =1 -integer :: ide ! =1 -integer :: its ! =1 -integer :: ite ! =1 -integer :: jms ! =1 -integer :: jme ! =nip -integer :: jds ! =1 -integer :: jde ! =nip -integer :: jts ! =1 -integer :: jte ! =nip -integer :: kms ! =1 -integer :: kme ! =nvl+1 -integer :: kds ! =1 -integer :: kde ! =nvl+1 -integer :: kts ! =1 -integer :: kte ! =nvl - -! WRF physics and chem parameters -integer, parameter :: numgas=1 ! # of tracers for gas phase chemistry -! -! GFS physics _ gocart very light for fim -! -!integer, parameter :: num_moist=2+1 -!integer, parameter :: num_chem=13 -!integer, parameter :: num_emis_ant = 6 -! -! followig for Lin et al. + regular GOCART -! -!integer, parameter :: num_moist=6+1 -!integer, parameter :: num_chem=18 -!integer, parameter :: num_emis_ant = 6 -!integer, parameter :: num_emis_vol = 0 -! -! volcanic ash only -!integer, parameter :: num_moist=2+1 -!integer, parameter :: num_chem=23 -!integer, parameter :: num_emis_ant = 6 -!integer, parameter :: num_emis_vol = 10 -! -! light gocart + reduced volcanic ash only (4 size bins) -integer, parameter :: num_moist=2+1 -integer, parameter :: num_chem=17 -integer, parameter :: num_emis_ant = 6 -integer, parameter :: num_emis_vol = 4 -! volcanic ash only (4 size bins) -!integer, parameter :: num_moist=2+1 -!integer, parameter :: num_chem=4 -!integer, parameter :: num_emis_ant = 0 -!integer, parameter :: num_emis_vol = 4 -! Pure GOCART (volcanic ash included in p25 and p10) -!integer, parameter :: num_moist=2+1 -!integer, parameter :: num_chem=19 -!integer, parameter :: num_emis_ant = 6 -!integer, parameter :: num_emis_vol = 4 -! -! -integer, parameter :: nbands=14 -integer, parameter :: nbandlw=16 -integer, parameter :: num_soil_layers=4 -integer, parameter :: num_scalar=1 -integer, parameter :: nvl_gocart=55 ! number of input levels from gocart file -integer, parameter :: num_ext_coef = 5 -integer, parameter :: num_bscat_coef = 3 -integer, parameter :: num_asym_par = 3 - -! namelist variables -! not yet used -integer :: ChemistryInterval = 0 ! Interval in seconds to call chemistry, 0 => every time step -!Control variables calculated in init.F90 from namelist variables -integer :: CallChemistry ! Timestep interval to call chemistry -integer :: CallBiom ! Timestep interval to call biomass burning plumerise - -contains - -subroutine wrf_control(nvarp,ntrb) - integer, intent(inout) :: nvarp,ntrb - ! add WRF variables to ntrb-dimensioned arrays - ntrb=ntrb+num_moist+num_chem-3 ! # of tracers + num_moist-3, num_chem, num_scalar(if larger than 1) - nvarp=nvarp+num_chem -end subroutine wrf_control - -end module module_wrf_control diff --git a/src/fim/FIMsrc/cntl/module_wrf_variables.F90 b/src/fim/FIMsrc/cntl/module_wrf_variables.F90 deleted file mode 100644 index 99e7e42..0000000 --- a/src/fim/FIMsrc/cntl/module_wrf_variables.F90 +++ /dev/null @@ -1,19 +0,0 @@ -!********************************************************************* -module module_wrf_variables -! This module specifies WRF physics variables. -!********************************************************************* - -implicit none - -save - -!SMS$DISTRIBUTE(dh,2) BEGIN -real,allocatable :: phys3dwrf(:,:,:) ! Physics diagnostic variable -real,allocatable :: exch (:,:) ! exchange coeffs -!SMS$DISTRIBUTE END -!SMS$DISTRIBUTE(dh,1) BEGIN -real,allocatable :: phys2dwrf(:,:) ! Physics diagnostic variable -real,allocatable :: pb2d(:) ! Boundary layer height -!SMS$DISTRIBUTE END - -end module module_wrf_variables diff --git a/src/fim/FIMsrc/cntl/units.F90 b/src/fim/FIMsrc/cntl/units.F90 deleted file mode 100644 index 53dc472..0000000 --- a/src/fim/FIMsrc/cntl/units.F90 +++ /dev/null @@ -1,94 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! module units contains these public entities -! getunit: obtain an available fortran unit number -! returnunit: return a fortran unit number to the list of available units -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -module units -!SMS$IGNORE BEGIN - implicit none - - private - public :: getunit ! obtain a Fortran unit number for use - public :: returnunit ! return a Fortran unit number to the pot - - integer, parameter :: maxunits = 99 ! Not all Fortran compilers allow more than 2 digits for units - integer :: i ! index for "isinuse" array which follows - logical, save :: isinuse(maxunits) = (/(.false.,i=1,maxunits)/) ! internal state of unit assignments -! The following units will be given only to callers that specifically ask for them, e.g. for situations -! where invoking scripts need to specify special handling via unit numbers for byte swapping - integer, parameter :: mustask(4) = (/11,21,30,82/) - -contains - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! getunit: provide the caller a unit number they can use for I/O -! Arguments: -! unitno: Optional: If present, see if the requested unit number is available. If not available, -! return an error code. -! Return value: unit number to use, or -1 if a unit number cannot be provided -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - integer function getunit (unitno) - integer, intent(in), optional :: unitno ! requested unit number (if present) - - integer :: i ! index over unit numbers - - getunit = -1 ! initialize to bad return value - -! If optional argument "unitno" is present, give the requestor that unit if it is available. - - if (present (unitno)) then - if (unitno > maxunits .or. unitno < 1 .or. unitno == 5 .or. unitno == 6) then - write(6,*) 'getunit: Unit ', unitno, ' is not valid' - return - end if - - if (isinuse (unitno)) then - write(6,*) 'getunit: Unit ', unitno, ' is already in use' - return - end if - - isinuse (unitno) = .true. - getunit = unitno - return - end if - -! Don't allocate units 5 (stdin), 6 (stdout), or any of the special units normally reserved -! for byte-swapping. - - do i=1,maxunits - if (.not. isinuse (i) .and. i /= mustask(1) .and. i /= mustask(2) .and. & - i /= mustask(3) .and. i /= mustask(4) .and. i /= 5 .and. i /= 6) then - isinuse(i) = .true. - getunit = i - return - end if - end do - - write(6,*) 'getunit: No more Fortran unit numbers available!' - return - end function getunit - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! returnunit: return unitno to the pile of available units -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine returnunit (unitno) - integer, intent(in) :: unitno - - if (unitno > maxunits .or. unitno < 1) then - write(6,*) 'returnunit: Unit ', unitno, ' is not valid' - return - end if - - if (.not. isinuse(unitno)) then - write(6,*) 'returnunit: WARNING--unit ', unitno, ' is not in use' - return - end if - - isinuse(unitno) = .false. - return - end subroutine returnunit -!SMS$IGNORE END -end module units diff --git a/src/fim/FIMsrc/fim/Makefile b/src/fim/FIMsrc/fim/Makefile deleted file mode 100644 index b0acd5c..0000000 --- a/src/fim/FIMsrc/fim/Makefile +++ /dev/null @@ -1,40 +0,0 @@ -# fim Makefile - -include ../macros.make - -CNTLMODDIR = ../../cntl/incmod -FIMEXE = $(BINDIR)/fim$(P) -FIMLIBBASE = fim$(P) -FIMLIB = $(LIBDIR)/lib$(FIMLIBBASE).a -FIMHRZL = Horizontal$(P) -SHELL = /bin/sh - -#JR Invoke parallel capability of gmake where possible. - -all: - (cd column && ./copy.ksh && $(MAKE) $(GMAKEMINUSJ) FC=$(FC) \ - FLAGS="$(COLFLAGS)" FREEFLAG=$(FREEFLAG) FIXEDFLAG=$(FIXEDFLAG)) || \ - (echo "Make failure in column/" && exit 1) - - (cd column_chem && $(MAKE) $(GMAKEMINUSJ) FC=$(FC) FLAGS="$(FFLAGS) \ - -I../column -I$(CNTLMODDIR)" FREEFLAG=$(FREEFLAG)) || \ - (echo "Make failure in column_chem/" && exit 1) - - (cd wrfphys && $(MAKE) $(GMAKEMINUSJ) FC=$(FC) FLAGS="$(FFLAGS) -I../column \ - -I$(CNTLMODDIR)" FREEFLAG=$(FREEFLAG)) || \ - (echo "Make failure in wrfphys/" && exit 1) - - mkdir -p $(FIMHRZL) - - (cd $(FIMHRZL) && env NEMS=$(NEMS) ../horizontal/copy.ksh && $(MAKE) \ - MAKE=$(MAKE) FC=$(FC) FFLAGS="$(FFLAGS) -I../column -I../column_chem \ - -I../wrfphys -I../../w3" FIMEXE=$(FIMEXE) FREEFLAG=$(FREEFLAG) SMS=$(SMS) \ - LINKFLAGS="$(LINKFLAGS)" LINKLIBS="$(LINKLIBS)" LIBWRFP=$(LIBWRFP) \ - FIMLIB=$(FIMLIB) FIMLIBBASE=$(FIMLIBBASE)) || \ - (echo "Make failure in $(FIMHRZL)" && exit 1) - -clean: - (cd column && $(MAKE) clean) - (cd column_chem && $(MAKE) clean) - (cd wrfphys && $(MAKE) clean) - ($(RM) -rf Horizontal*) diff --git a/src/fim/FIMsrc/fim/column/Makefile b/src/fim/FIMsrc/fim/column/Makefile deleted file mode 100644 index dc928d6..0000000 --- a/src/fim/FIMsrc/fim/column/Makefile +++ /dev/null @@ -1,42 +0,0 @@ -# column Makefile - -SHELL = /bin/sh - -include ../../macros.make - -OBJS = $(addsuffix .o, $(basename $(SRCS))) -SRCS = $(shell ls *.f *.F90) - -.SUFFIXES: -.SUFFIXES: .o .f .F90 - -ifeq ($(NEED_SINDCOSD),yes) - LOCDEF = -DNEED_SINDCOSD -endif - -LOCFLAGS = $(FLAGS) -ifeq ($(DEBUG),yes) - LOCFLAGS += -g -endif - -.f.o: - $(FC) -c -I../../cntl $(GPTL_FFLAGS) $(LOCFLAGS) $(FIXEDFLAG) $(RCWFLAG) $(OPTFLAGS) $< -.F90.o: - $(FC) -c $(GPTL_CPPFLAGS) $(GPTL_FFLAGS) $(LOCDEF) $(LOCFLAGS) $(FREEFLAG) $(RCWFLAG) $(OPTFLAGS) $< - -#JR Generate FIM_COLUMN_DEPENDENCIES automatically. -#JR That is why it was removed from the repository. -#JR Also: No longer build a library from the column .o files. They are now -#JR called out directly in the "make" procedure in horizontal/. -all: FIM_COLUMN_DEPENDENCIES $(OBJS) - -FIM_COLUMN_DEPENDENCIES: - $(RM) -f Filepath Srcfiles - echo "." > Filepath - ls -1 *.f *.F90 > Srcfiles - $(MKDEPENDS) -m Filepath Srcfiles > $@ - --include FIM_COLUMN_DEPENDENCIES - -clean: - $(RM) *.o *.mod iw3jdn.f w3fs26.f w3movdat.f w3reddat.f FIM_COLUMN_DEPENDENCIES diff --git a/src/fim/FIMsrc/fim/column/akbk_hyb_def.f b/src/fim/FIMsrc/fim/column/akbk_hyb_def.f deleted file mode 100644 index 6052329..0000000 --- a/src/fim/FIMsrc/fim/column/akbk_hyb_def.f +++ /dev/null @@ -1,11 +0,0 @@ - module akbk_hyb_def -! use resol_def - use machine - implicit none - save - real(kind=kind_evod) , allocatable :: - . AK5(:),BK5(:),CK(:),DBK(:),bkl(:), - . AMHYB(:,:),BMHYB(:,:),SVHYB(:),tor_hyb(:), - . D_HYB_m(:,:,:) - - end module akbk_hyb_def diff --git a/src/fim/FIMsrc/fim/column/astronomy.f b/src/fim/FIMsrc/fim/column/astronomy.f deleted file mode 100644 index db84f27..0000000 --- a/src/fim/FIMsrc/fim/column/astronomy.f +++ /dev/null @@ -1,636 +0,0 @@ - - SUBROUTINE ASTRONOMY(lonl2,latd,nlats,lons_lar,sinlat,coslat, - & xlon,fhswr,idate,phour,lsswr,lslwr, - & SOLC,RSIN1,RCOS1,RCOS2,slag,sdec,cdec,COSZEN,coszdg, - & global_lats_r) - - USE MACHINE , ONLY :kind_rad - -cc - use resol_def - use layout1 - implicit none - - integer global_lats_r(latr) - integer latd,nlats,lons_lar(latr),idate(4),lonl2 - integer JDNMC,kyear,jd,IMON,IDAY,IZTIM,IHR - integer IM,ID,IYEAR - integer lonsperlar(latr) - logical lsswr,lslwr - character*4 munth -c - integer loz,jmr,jmout - parameter (jmr=18,loz=17,jmout=37) -c - real(kind=kind_rad) O3CLIM(JMR,LOZ,12), - 1 o3out(jmout,loz),pstr(loz) -c - real (kind=kind_rad) sinlat(latr),coslat(latr),xlon(LONL2,latd) - real (kind=kind_rad) fhswr,phour - real (kind=kind_rad) slag,sdec,cdec,solhr,fjdnmc,sc - real (kind=kind_rad) COSZDG(LONL2,latd),COSZEN(LONL2,latd) - real (kind=kind_rad) FJD,DLT,R1,ALF,XMIN - real (kind=kind_rad) SOLC,RSIN1,RCOS1,RCOS2 -cc -cc-------------------------------------------------------------------- -cc - real(kind=kind_rad), parameter :: cons_24=24.0d0 -cc -c@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -c - SOLHR=MOD(PHOUR+IDATE(1),cons_24) - -!sela if(me.eq.0) PRINT 1001, JCAP, LEVS - 1001 FORMAT (1H0,'GFDL/HOU REDCRAD',I2,I2,'became oper. june 15 1998') -C -C **************************************************************** -C... * ASTRONOMY CALCULATIONS-ONCE FOR EACH NEW RADIATION interval * -C **************************************************************** -C.. GET 4 DIGIT YEAR FOR JULIAN DAY COMPUTATION - kyear = IDATE(4) - IMON = IDATE(2) - IDAY = IDATE(3) - IZTIM = IDATE(1) - CALL COMPJD(KYEAR,IMON,IDAY,IZTIM,0,JDNMC,FJDNMC) - CALL FCSTIM(PHOUR,IMON,IDAY,IZTIM,JDNMC,FJDNMC, - 1 RSIN1,RCOS1,RCOS2,JD,FJD) -C..************************** - IF(lsswr) THEN - CALL SOLAR(JD,FJD,R1,DLT,ALF,SLAG,SDEC,CDEC) -c if(me.eq.0)print*,'in astronomy completed sr solar' - CALL COSZMN(fhswr,SOLHR,SINLAT,COSLAT,SDEC,CDEC,SLAG, - & XLON,LONL2,latd,COSZEN,.TRUE.,COSZDG,nlats,lons_lar, - & global_lats_r) -c if(me.eq.0)print*,'in astronomy completed sr coszmn' -C -C CALCULATE SOLAR INPUT APPROPRIATE FOR DATE - sc=2. - SOLC=SC/(R1*R1) - ENDIF - - CALL CDATE(JD,FJD,MUNTH,IM,ID,IYEAR,IHR,XMIN) -c if(me.eq.0)print*,'in astronomy completed sr cdate' -!JFM IF (me.eq.0) CALL PRTIME(ID,MUNTH,IYEAR,IHR,XMIN, -!JFM & JD,FJD,DLT,ALF,R1,SLAG,SOLC) -c if(me.eq.0)print*,'in astronomy completed sr prtime' -c -!JFM call o3intpnasa(phour,idate,o3clim,pstr,o3out) -c if(me.eq.0)print*,'completed sr o3intpnasa and astronomy!!!' - - RETURN - END -c -c*********************************************************************** -c - SUBROUTINE CDATE(JD,FJD,MUNTH,IM,ID,IYEAR,IHR,XMIN) -CFPP$ NOCONCUR R -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: CDATE COMPUTES DAY,MONTH,YR FROM JULIAN DAY -C PRGMMR: KENNETH CAMPANA ORG: W/NMC23 DATE: 89-07-07 -C -C ABSTRACT: COMPUTES MONTH,DAY,YEAR FROM JULIAN DAY. -C -C PROGRAM HISTORY LOG: -C 77-06-07 ROBERT WHITE,GFDL -C 98-05-15 IREDELL Y2K COMPLIANCE -C -C USAGE: CALL CDATE(JD,FJD,MUNTH,IM,ID,IYEAR,IHR,XMIN) -C INPUT ARGUMENT LIST: -C JD - JULIAN DAY FOR CURRENT FCST HOUR. -C FJD - FRACTION OF THE JULIAN DAY. -C OUTPUT ARGUMENT LIST: -C MUNTH - MONTH (CHARACTER). -C IM - MONTH (INTEGER). -C ID - DAY OF THE MONTH. -C IYEAR - YEAR. -C IHR - HOUR OF THE DAY. -C XMIN - MINUTE OF THE HOUR. -C -C SUBPROGRAMS CALLED: -C W3FS26 YEAR, MONTH, DAY FROM JULIAN DAY NUMBER -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN. -C -C$$$ - USE MACHINE , ONLY :kind_rad - implicit none - - character*4 month(12),munth - integer JD,IM,ID,IYEAR,IHR - integer jda,mfjd,idaywk,idayyr - - real (kind=kind_rad) fjd,xmin - - DATA MONTH /'JAN.','FEB.','MAR.','APR.','MAY ','JUNE', - & 'JULY','AUG.','SEP.','OCT.','NOV ','DEC.'/ - IF(FJD.GE.0.5) THEN - JDA=JD+1 - MFJD=NINT(FJD*1440.) - IHR=MFJD/60-12 - XMIN=MFJD-(IHR+12)*60 - ELSE - JDA=JD - MFJD=NINT(FJD*1440.) - IHR=MFJD/60+12 - XMIN=MFJD-(IHR-12)*60 - ENDIF - CALL W3FS26(JDA,IYEAR,IM,ID,IDAYWK,IDAYYR) - MUNTH=MONTH(IM) - END -c -c*********************************************************************** -c - SUBROUTINE COMPJD(JYR,JMNTH,JDAY,JHR,JMN,JD,FJD) -CFPP$ NOCONCUR R -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: COMPJD COMPUTES JULIAN DAY AND FRACTION -C PRGMMR: KENNETH CAMPANA ORG: W/NMC23 DATE: 89-07-07 -C -C ABSTRACT: COMPUTES JULIAN DAY AND FRACTION -C FROM YEAR, MONTH, DAY AND TIME UTC. -C -C PROGRAM HISTORY LOG: -C 77-05-06 RAY ORZOL,GFDL -C 98-05-15 IREDELL Y2K COMPLIANCE -C -C USAGE: CALL COMPJD(JYR,JMNTH,JDAY,JHR,JMN,JD,FJD) -C INPUT ARGUMENT LIST: -C JYR - YEAR (4 DIGITS)-INTIAL FCST TIME. -C JMNTH - MONTH-INITIAL FCST TIME. -C JDAY - DAY-INITIAL FCST TIME. -C JHR - Z-TIME OF INITIAL FCST TIME. -C JMN - MINUTES (ZERO PASSED FROM CALLING PROGRAM). -C OUTPUT ARGUMENT LIST: -C JD - JULIAN DAY. -C FJD - FRACTION OF THE JULIAN DAY. -C -C SUBPROGRAMS CALLED: -C IW3JDN COMPUTE JULIAN DAY NUMBER -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN. -C -C$$$ - USE MACHINE , ONLY :kind_rad - implicit none -! - integer JYR,JMNTH,JDAY,JHR,JMN,JD - integer IW3JDN - - real (kind=kind_rad) FJD - - JD=IW3JDN(JYR,JMNTH,JDAY) - IF(JHR.LT.12) THEN - JD=JD-1 - FJD=0.5+JHR/24.+JMN/1440. - ELSE - FJD=(JHR-12)/24.+JMN/1440. - ENDIF - END -c -c*********************************************************************** -c - SUBROUTINE COSZMN(DTSWAV,SOLHR,SINLAT,COSLAT,SDEC,CDEC,SLAG, - 1 XLON,NLON2,latd,COSZEN,LDG,COSZDG,nlats,lons_lar, - & global_lats_r) -c -c*********************************************************************** -c -C===> COMPUTE MEAN COS SOLAR ZEN ANGL OVER DTSWAV HRS -C.... COSINE OF SOLAR ZEN ANGL FOR BOTH N. AND S. HEMISPHERES. -C SOLHR=TIME(HRS) AFTER 00Z (GREENWICH TIME).. -C XLON IS EAST LONG(RADIANS).. -C SINLAT, COSLAT ARE SIN AND COS OF LATITUDE (N. HEMISPHERE) -C SDEC, CDEC = THE SINE AND COSINE OF THE SOLAR DECLINATION. -C SLAG = EQUATION OF TIME -C - USE MACHINE , ONLY :kind_rad - - use resol_def - use layout1 - implicit none - integer global_lats_r(latr) - integer nlats,lons_lar(latr) - integer NLON2,latd - integer ISTSUN(NLON2) - integer nstp,istp - integer i,it,j,nlon,lat - LOGICAL LDG - real (kind=kind_rad) DTSWAV,SOLHR,SDEC,CDEC,SLAG - real (kind=kind_rad) XLON(NLON2,latd),COSZEN(NLON2,latd) - real (kind=kind_rad) COSZDG(NLON2,latd) - real (kind=kind_rad) SINLAT(latr),COSLAT(latr),COSZN(NLON2) - real (kind=kind_rad) PID12,CNS,SS,CC -cc -cc-------------------------------------------------------------------- -cc - real(kind=kind_rad), parameter :: cons_0=0.0d0 -cc -c @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -c - NLON=NLON2/2 - NSTP = 6 - ISTP = 1 ! jbao NSTP*DTSWAV - PID12 = (2.E0 * ASIN(1.E0)) / 12.E0 - - DO j=1,nlats - DO i=1,NLON2 - COSZEN(i,j) = 0.E0 - ISTSUN(i) = 0 - ENDDO - DO IT=1,ISTP - CNS = PID12 * (SOLHR-12.E0+(IT-1)*1.E0/NSTP) +SLAG - lat = global_lats_r(ipt_lats_node_r-1+j) - SS= SINLAT(lat)*SDEC - CC= COSLAT(lat)*CDEC -cjfe DO i=1,lonsinpe(0,j) - DO i=1,lons_lar(lat) - COSZN(i) = SS + CC * COS(CNS + XLON(i,j)) - COSZEN(i,j) = COSZEN(i,j) + MAX (cons_0, COSZN(i)) - IF(COSZN(i).GT.0.E0) ISTSUN(i) = ISTSUN(i) + 1 - ENDDO -cjfe SS=-SS -cjfe DO I=NLON+1,NLON+lonsinpe(0,j) -cjfe COSZN(i) = SS + CC * COS(CNS + XLON(i,j)) -cjfe COSZEN(i,j) = COSZEN(i,j) + AMAX1(0.E0, COSZN(i)) -cjfe IF(COSZN(i).GT.0.E0) ISTSUN(i) = ISTSUN(i) + 1 -cjfe ENDDO - ENDDO - DO i=1,NLON2 - IF(LDG) COSZDG(i,j) = COSZEN(i,j) / ISTP - IF(ISTSUN(i).GT.0) COSZEN(i,j) = COSZEN(i,j) / ISTSUN(i) - ENDDO - ENDDO - - RETURN - END -c -c*********************************************************************** -c - SUBROUTINE FCSTIM(FHOUR,IMON,IDAY,IZTIM,JDNMC,FJDNMC, - 1 RSIN1,RCOS1,RCOS2,JD,FJD) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FCSTIM SET FORECAST ORBIT PARMS AND JULIAN DAY. -C PRGMMR: KENNETH CAMPANA ORG: W/NMC23 DATE: 89-07-07 -C -C ABSTRACT: FOR A GIVEN FORECAST HOUR AND INITIAL JULIAN DAY, -C THREE ORBIT PARAMETERS AND THE FORECAST JULIAN DAY ARE COMPUTED. -C -C PROGRAM HISTORY LOG: -C 98-05-15 IREDELL Y2K COMPLIANCE -C -C USAGE: CALL FCSTIM(FHOUR,IMON,IDAY,IZTIM,JDNMC,FJDNMC, -C 1 RSIN1,RCOS1,RCOS2,JD,FJD) -C INPUT ARGUMENT LIST: -C FHOUR - FORECAST HOUR -C IMON - NOT USED -C IDAY - NOT USED -C IZTIM - NOT USED -C JDNMC - INITIAL JULIAN DAY. -C FJDNMC - INITIAL FRACTION OF THE JULIAN DAY. -C RLAG - DAY OF PERIHELION? -C YEAR - DAYS IN YEAR -C OUTPUT ARGUMENT LIST: -C RSIN1 - ORBIT PARAMETER -C RCOS1 - ORBIT PARAMETER -C RCOS2 - ORBIT PARAMETER -C JD - FORECAST JULIAN DAY. -C FJD - FORECAST FRACTION OF THE JULIAN DAY. -C -C SUBPROGRAMS CALLED: -C W3FS26 YEAR, MONTH, DAY FROM JULIAN DAY NUMBER -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN. -C -C$$$ - USE MACHINE , ONLY :kind_rad - implicit none - - integer IMON,IDAY,IZTIM,JDNMC,JD - integer JDA,IYEAR,IM,ID,IDAYWK,IDAYYR - real (kind=kind_rad) TPI - PARAMETER (TPI=2.E0*3.141593E+0) - - real (kind=kind_rad) FHOUR,FJDNMC,RSIN1,RCOS1,RCOS2,FJD - real (kind=kind_rad) XDA,DYINC,DYFCST,rlag,year,RANG - - IF(FJDNMC.GE.0.5) THEN - JDA=JDNMC+1 - XDA=FJDNMC-0.5 - ELSE - JDA=JDNMC - XDA=FJDNMC+0.5 - ENDIF - CALL W3FS26(JDA,IYEAR,IM,ID,IDAYWK,IDAYYR) - DYINC=FHOUR/24 - DYFCST=IDAYYR+XDA+DYINC - rlag=14.8125 - year=365.25 - RANG=TPI*(DYFCST-RLAG)/YEAR - RSIN1=SIN(RANG) - RCOS1=COS(RANG) - RCOS2=COS(2*RANG) - JD=JDNMC+FJDNMC+DYINC - FJD=JDNMC+FJDNMC+DYINC-JD - END -c -c*********************************************************************** -c - SUBROUTINE PRTIME(ID,MUNTH,IYEAR,IHR,XMIN,JD,FJD, - 1 DLT,ALF,R1,SLAG,SOLC) - - use machine - use physcons, pi => con_pi - implicit none - - character*4 munth - integer ID,IYEAR,IHR,JD - integer LTD,LTM,IHALP,IYY - integer SIGN,SIGB,DSIG - real (kind=kind_rad) XMIN,FJD,DLT,ALF,R1,SLAG,SOLC - real (kind=kind_rad) DEGRAD,HPI,ZERO,SIX,SIXTY,Q22855 - real (kind=kind_rad) DLTD,DLTM,DLTS,HALP,YMIN,ASEC,EQT,EQSEC - - PARAMETER (DEGRAD=180.E0/PI,HPI=0.5E0*PI) - DATA SIGN/1H-/, SIGB/1H / - DATA ZERO,SIX,SIXTY,Q22855/0.0,6.0,60.0,228.55735/ - SAVE SIGN,ZERO,SIX,SIXTY,Q22855 - DLTD=DEGRAD*DLT - LTD=DLTD - DLTM=SIXTY*(ABS(DLTD)-ABS(FLOAT(LTD))) - LTM=DLTM - DLTS=SIXTY*(DLTM-FLOAT(LTM)) - DSIG=SIGB - IF((DLTD.LT.ZERO).AND.(LTD.EQ.0)) DSIG=SIGN - HALP=SIX*ALF/HPI - IHALP=HALP - YMIN=ABS(HALP-FLOAT(IHALP))*SIXTY - IYY=YMIN - ASEC=(YMIN-FLOAT(IYY))*SIXTY - EQT=Q22855*SLAG - EQSEC=SIXTY*EQT -!jbao PRINT 1004, ID,MUNTH,IYEAR,IHR,XMIN,JD,FJD,R1,HALP,IHALP, -!jbao 1 IYY,ASEC,DLTD,DSIG,LTD,LTM,DLTS,EQT,EQSEC,SLAG,SOLC - 1004 FORMAT('0 FORECAST DATE',9X,I3,A5,I6,' AT',I3,' HRS',F6.2,' MINS'/ - 1 ' JULIAN DAY',12X,I8,2X,'PLUS',F11.6/ - 2 ' RADIUS VECTOR',9X,F10.7/ - 3 ' RIGHT ASCENSION OF SUN',F12.7,' HRS, OR',I4,' HRS',I4, - 4 ' MINS',F6.1,' SECS'/ - 5 ' DECLINATION OF THE SUN',F12.7,' DEGS, OR',A2,I3, - 6 ' DEGS',I4,' MINS',F6.1,' SECS'/ - 7 ' EQUATION OF TIME',6X,F12.7,' MINS, OR',F10.2,' SECS, OR' - 8 ,F9.6,' RADIANS'/ - 9 ' SOLAR CONSTANT',8X,F12.7//) - RETURN - END -c -c*********************************************************************** -c - SUBROUTINE SOLAR(JD,FJD,R,DLT,ALP,SLAG,SDEC,CDEC) -C -C -C ******************************************************************* -C * S O L A R * -C... * PATTERNED AFTER ORIGINAL GFDL CODE--- * -C... * BUT NO CALCULATION OF LATITUDE MEAN COS SOLAR ZENITH ANGLE..* -C... * ZENITH ANGLE CALCULATIONS DONE IN SR ZENITH IN THIS CASE..* -C... * HR ANGLE,MEAN COSZ,AND MEAN TAUDA CALC REMOVED--K.A.C. MAR 89 * -C * UPDATES BY HUALU PAN TO LIMIT ITERATIONS IN NEWTON METHOD AND * -C * ALSO CCR REDUCED FROM(1.3E-7)--BOTH TO AVOID NONCONVERGENCE IN * -C * NMC S HALF PRECISION VERSION OF GFDL S CODE ---- FALL 1988 * -C ******************************************************************* -C -C.....SOLAR COMPUTES RADIUS VECTOR, DECLINATION AND RIGHT ASCENSION OF -C.....SUN, EQUATION OF TIME -C - USE MACHINE , ONLY :kind_rad,kind_phys - use physcons, pi => con_pi - implicit none -c - real(kind=kind_rad) CYEAR,SVT6,CCR,TPP - integer JDOR - D A T A - 1 CYEAR/365.25/, CCR/1.3E-6/ -C -C.....TPP = DAYS BETWEEN EPOCH AND PERIHELION PASSAGE OF 1900 -C.....SVT6 = DAYS BETWEEN PERIHELION PASSAGE AND MARCH EQUINOX OF 1900 -C.....JDOR = JD OF EPOCH WHICH IS JANUARY 0, 1900 AT 12 HOURS UT -C - D A T A - 1 TPP/1.55/, SVT6/78.035/, JDOR/2415020/ -C -C ******************************************************************* - - - real(kind=kind_rad) TPI,HPI,RAD - PARAMETER (TPI=2.0*PI,HPI=0.5*PI,RAD=180.0/PI) - integer JD,JDOE,ITER - real(kind=kind_rad) FJD,R,DLT,ALP,SLAG,SDEC,CDEC - real(kind=kind_rad) DAT,T,YEAR,TYEAR,EC,ANGIN,ADOR,DELEQN - real(kind=kind_rad) SNI,TINI,ER,QQ,E,EP,CD,HE,EQ,DATE - real(kind=kind_rad) EM,CR,W,TST,SUN -C - DAT=FLOAT(JD-JDOR)-TPP+FJD -C COMPUTES TIME IN JULIAN CENTURIES AFTER EPOCH - T=FLOAT(JD-JDOR)/36525.E0 -C COMPUTES LENGTH OF ANOMALISTIC AND TROPICAL YEARS (MINUS 365 DAYS) - YEAR=.25964134E0+.304E-5*T - TYEAR=.24219879E0-.614E-5*T -C COMPUTES ORBIT ECCENTRICITY AND ANGLE OF EARTH'S INCLINATION FROM T - EC=.01675104E0-(.418E-4+.126E-6*T)*T - ANGIN=23.452294E0-(.0130125E0+.164E-5*T)*T - ADOR=JDOR - JDOE=ADOR+(SVT6*CYEAR)/(YEAR-TYEAR) -C DELEQN=UPDATED SVT6 FOR CURRENT DATE - DELEQN=FLOAT(JDOE-JD)*(YEAR-TYEAR)/CYEAR - YEAR=YEAR+365.E0 - SNI=SIN(ANGIN/RAD) - TINI=1.E0/TAN(ANGIN/RAD) - ER=SQRT((1.E0+EC)/(1.E0-EC)) - QQ=DELEQN*TPI/YEAR -C DETERMINE TRUE ANOMALY AT EQUINOX - E=1.E0 - ITER = 0 - 32 EP=E-(E-EC*SIN(E)-QQ)/(1.E0-EC*COS(E)) - CD=ABS(E-EP) - E=EP - ITER = ITER + 1 - IF(ITER.GT.10) THEN - WRITE(6,*) ' ITERATION COUNT FOR LOOP 32 =', ITER - WRITE(6,*) ' E, EP, CD =', E, EP, CD - ENDIF - IF(ITER.GT.10) GOTO 1032 - IF(CD.GT.CCR) GO TO 32 - 1032 CONTINUE - HE=.5E0*E - EQ=2.E0*ATAN(ER*TAN(HE)) -C DATE=DAYS SINCE LAST PERIHELION PASSAGE - DATE = MOD(DAT,YEAR) -C SOLVE ORBIT EQUATIONS BY NEWTON'S METHOD - EM=TPI*DATE/YEAR - E=1.E0 - ITER = 0 - 31 EP=E-(E-EC*SIN(E)-EM)/(1.E0-EC*COS(E)) - CR=ABS(E-EP) - E=EP - ITER = ITER + 1 - IF(ITER.GT.10) THEN - WRITE(6,*) ' ITERATION COUNT FOR LOOP 31 =', ITER - ENDIF - IF(ITER.GT.10) GOTO 1031 - IF(CR.GT.CCR) GO TO 31 - 1031 CONTINUE - R=1.E0-EC*COS(E) - HE=.5E0*E - W=2.E0*ATAN(ER*TAN(HE)) -C>YH SIND=SNI*SIN(W-EQ) -C>YH DLT=ASIN(SIND) - SDEC=SNI*SIN(W-EQ) - CDEC=SQRT(1.E0 - SDEC*SDEC) - DLT=ASIN(SDEC) - ALP=ASIN(TAN(DLT)*TINI) - TST=COS(W-EQ) - IF(TST.LT.0.E0) ALP=PI-ALP - IF(ALP.LT.0.E0) ALP=ALP+TPI - SUN=TPI*(DATE-DELEQN)/YEAR - IF(SUN.LT.0.E0) SUN=SUN+TPI - SLAG=SUN-ALP-.03255E0 - RETURN - END -c -c*********************************************************************** -c - subroutine o3intpnasa(fhour,idate,o3clim,pstr,o3out) -c ******************************************************** -c * COMPUTES O3 CLIMO FROM 12 MONTH DATASET, LINEARLY * -c * INTERPOLATED TO DAY,MON OF THE FCST. THEN CREATE * -c * A 5 DEG ARRAY FROM THE 10 DEG CLIMATOLOGY...FOR * -c * EASE WHEN DOING A LATITUDINAL INTERPOLATION * -c * THANKS TO S MOORTHI for NEW O3 CLIMO...KAC DEC 1996* -c * INPUT: * -c * idate=NMC date-time * -c * fhour=forecast hour * -c * o3clim=10-deg O3 climo for each month(np->spole) * -c * OUTPUT : * -c * o3out=5-deg O3 climo for forecast date(np->spole) * -c ******************************************************** -c GEOS ozone data - USE MACHINE , ONLY :kind_rad - implicit none - integer loz,jmr,jmout - parameter (jmr=18,loz=17,jmout=37) -C - INTEGER DAYS(12),idate(4) - integer ida,imo,numdyz,imo1,jday,nmdtot,ndayr,mday - integer monL,monC,monR,midL,midC,midR,jmr1,j1,j2 - integer l,j,ken - - real(kind=kind_rad) fhour - real(kind=kind_rad) O3CLIM(JMR,LOZ,12),O3TMP(jmr,loz) - real(kind=kind_rad) o3out(jmout,loz),pstr(loz) - real(kind=kind_rad) difL,difR,delday -c -CCCC common /o3nasaclim/o3clim,pstr,o3out - DATA DAYS/31,28,31,30,31,30,31,31,30,31,30,31/ -C... BEGIN HERE ...... - ida=idate(3) - imo=idate(2) -c... FIND current day and month, initial values in ida,imo! -c will not worry about leap year, since it will take a -c 120-year (WHAT?) forecast to be off by 1 month. If this -c is deemed a problem, need to redo this calculation. -c - if (fhour.ge.24.) then -c... number of days into the forecast - numdyz=fhour/24.0 + 0.01 -c... get day-of-year, remember climate runs are for years - imo1=imo-1 - jday = ida - if (imo1.gt.0) then - jday=0 - do 7 ken=1,imo1 - jday=jday+days(ken) - 7 continue - jday=jday+ida - end if - nmdtot = jday+numdyz - ndayr = mod(nmdtot,365) - if (ndayr.eq.0) ndayr=365 -c... now get month from day-of-year - mday=0 - do 8 ken=1,11 - mday=mday+days(ken) - imo=ken - if (ndayr.le.mday) then - ida=ndayr-(mday-days(imo)) - go to 9 - end if - 8 continue - imo=12 - 9 continue -ccc print 66,fhour,numdyz,jday,nmdtot,ndayr - 66 format(' SBUVO3 climo hr=',f10.1, - 1 ' numdyz,jday,nmdtot,ndayr=',4i8) - end if -C -c... do a linear interpolation in time, where we assume that -c the ozone data is valid for mid-month -c monL is the preceeding month, monC for current mo, and -c monR is the future month.. - monL=imo-1 - monC=imo - monR=imo+1 - if (monL.lt.1) monL=12 - if (monR.gt.12) monR=1 -c... difL=number of days beteen mid-months of the current and -c preceeding mo, difR=same for current and future mo.. -c... delL=number of days between current day and mon, -c delR=same for current day and next month. -c sign convention as if we were using day of year calculations. - midL=days(monL)/2 - midC=days(monC)/2 - midR=days(monR)/2 - difL=-(days(monL)-midL+midC) - difR= (days(monC)-midC+midR) - delday=ida-midC - if (ida.gt.midC) then - do 60 j=1,jmr - do 60 l=1,loz - O3TMP(j,l)=o3clim(j,l,monC) + - 1 (o3clim(j,l,monR)-o3clim(j,l,monC)) * delday/difR - 60 continue - else if (ida.lt.midC) then - do 65 j=1,jmr - do 65 l=1,loz - O3TMP(j,l)=o3clim(j,l,monC) + - 1 (o3clim(j,l,monL)-o3clim(j,l,monC)) * delday/difL - 65 continue - else if (ida.eq.midC) then - do 70 j=1,jmr - do 70 l=1,loz - O3TMP(j,l)=o3clim(j,l,monC) - 70 continue - end if -!cselaprint 200,imo,ida -c... linearly interpolate to 5 deg zonal means - jmr1=jmr-1 - do 80 j=1,jmr1 - j1=j*2 - j2=j1+1 - do 80 l=1,loz - o3out(j1,l)=O3TMP(j,l) - o3out(j2,l)=0.5*(O3TMP(j,l)+O3TMP(j+1,l)) - 80 continue - do 85 l=1,loz - o3out(1,l)=O3TMP(1,l) - o3out(jmout-1,l)=O3TMP(jmr,l) - o3out(jmout,l)=O3TMP(jmr,l) - 85 continue - 200 format(1h1,'from o3intpnasa ozone climatology for mont,day=',2i4) - return - END diff --git a/src/fim/FIMsrc/fim/column/calpreciptype.f b/src/fim/FIMsrc/fim/column/calpreciptype.f deleted file mode 100644 index c8dd4e1..0000000 --- a/src/fim/FIMsrc/fim/column/calpreciptype.f +++ /dev/null @@ -1,1683 +0,0 @@ - SUBROUTINE CALPRECIPTYPE(kdt,nrcm,im,ix,lm,lp1,randomno, - & xlat,xlon, - & gt0,gq0,prsl,prsi,PREC, !input - & phii,num_p3d,TSKIN,SR,phy_f3d, !input - & DOMR,DOMZR,DOMIP,DOMS) !output -! SUBROUTINE CALPRECIPTYPE(nrcm,randomno,im,lm,lp1,T,Q,PMID,PINT,PREC, & !input -! ZINT,num_p3d,TSKIN,SR,F_RimeF, & !input -! DOMR,DOMZR,DOMIP,DOMS) !output -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: CALPRECIPTYPE COMPUTE DOMINANT PRECIP TYPE -! PRGRMMR: CHUANG ORG: W/NP2 DATE: 2008-05-28 -! -! -! ABSTRACT: -! THIS ROUTINE COMPUTES PRECIPITATION TYPE. -! . It is adopted from post but was made into a column to used by GFS model -! -! -! use vrbls3d -! use vrbls2d -! use soil -! use masks -! use params_mod -! use ctlblk_mod -! use rqstfld_mod - USE FUNCPHYS, ONLY : fpvs,FTDP,fpkap,ftlcl,stma,fthe - USE PHYSCONS -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none -! -! INCLUDE "mpif.h" -! -! IN NGM SUBROUTINE OUTPUT WE FIND THE FOLLOWING COMMENT. -! "IF THE FOLLOWING THRESHOLD VALUES ARE CHANGED, CONTACT -! TDL/SYNOPTIC-SCALE TECHNIQUES BRANCH (PAUL DALLAVALLE -! AND JOHN JENSENIUS). THEY MAY BE USING IT IN ONE OF -! THEIR PACKING CODES." THE THRESHOLD VALUE IS 0.01 INCH -! OR 2.54E-4 METER. PRECIPITATION VALUES LESS THAN THIS -! THRESHOLD ARE SET TO MINUS ONE TIMES THIS THRESHOLD. - real,PARAMETER :: PTHRESH = 0.0 -! -! SET CELCIUS TO KELVIN AND SECOND TO HOUR CONVERSION. - integer,PARAMETER :: NALG = 5 -! -! DECLARE VARIABLES. -! - integer,intent(in) :: kdt,nrcm,im,ix,lm,lp1,num_p3d - real,intent(in) :: xlat(im),xlon(im) - real(kind=kind_phys),dimension(im),intent(in) :: PREC,SR,TSKIN - real,intent(in) :: randomno(ix,nrcm) - real(kind=kind_phys),dimension(ix,LM),intent(in) :: - & gt0,gq0,prsl,phy_f3d - real(kind=kind_phys),dimension(ix,lp1),intent(in) :: prsi,phii - -! real(kind=kind_phys),dimension(im,LM),intent(in) :: T,Q,PMID,F_RimeF -! real(kind=kind_phys),dimension(im,lp1),intent(in) :: pint,zint - real(kind=kind_phys),dimension(im),intent(out) :: DOMR,DOMZR,DOMIP - & ,DOMS - - INTEGER IWX1,IWX4,IWX5 - REAL IWX2,IWX3 - REAL(kind=kind_phys) ES,QC,PV - REAL SLEET(NALG),RAIN(NALG),FREEZR(NALG),SNOW(NALG) - real(kind=kind_phys),dimension(LM) :: T,Q,PMID,F_RimeF - real(kind=kind_phys),dimension(lp1) :: pint,zint - REAL(kind=kind_phys), ALLOCATABLE :: TWET(:),RH(:),TD(:) -! REAL DOMS(IM,JM),DOMR(IM,JM),DOMIP(IM,JM),DOMZR(IM,JM) -! - integer I,J,L,IWX,ISNO,IIP,IZR,IRAIN,k,k1 - real(kind=kind_phys) tdpd,pr,tr,pk,tlcl,thelcl,qwet, - & time_vert,time_ncep,time_ramer,time_bourg,time_revised, - & time_dominant,btim,timef -! real RDTPHS,TLOW,TSFCK,QSAT,DTOP,DBOT,SNEQV,RRNUM,SFCPRS,SFCQ, & -! RC,SFCTMP,SNCOVR,FACTRS,SOLAR -! -! computes wet bulb here since two algorithms use it -! lp1=lm+1 -! convert geopotential to height -! do l=1,lp1 -! zint(l)=zint(l)/con_g -! end do -! DON'T FORGET TO FLIP 3D ARRAYS AROUND BECAUSE GFS COUNTS FROM BOTTOM UP - - ALLOCATE ( TWET(LM),RH(LM),TD(LM) ) -! print*,'debug calpreciptype: ', & -! im,lm,lp1,nrcm - - time_vert = 0. - time_ncep = 0. - time_ramer = 0. - time_bourg = 0. - time_revised = 0. - - do i=1,im -! if(kdt>15. and. kdt<20) btim = timef() - do k=1,lm - k1 = lm-k+1 - t(k1) = gt0(i,k) - q(k1) = gq0(i,k) - pmid(k1) = prsl(i,k) * 1000.0 - f_rimef(k1) = phy_f3d(i,k) -! -! Compute wet bulb -! do l=1,lm - pv = pmid(k1)*q(k1)/(con_eps-con_epsm1*q(k1)) - td(k1) = ftdp(pv) - tdpd = t(k1)-td(k1) - if(pmid(k1)>=50000.)then ! only compute twet below 500mb to save time - if(tdpd.gt.0.) then - pr = pmid(k1) - tr = t(k1) - pk = fpkap(pr) - tlcl = ftlcl(tr,tdpd) - thelcl = fthe(tlcl,pk*tlcl/tr) - call stma(thelcl,pk,twet(k1),qwet) - else - twet(k1)=t(k1) - endif - endif - ES = FPVS(T(k1)) - ES = MIN(ES,PMID(k1)) - QC = CON_EPS*ES/(PMID(k1)+CON_EPSM1*ES) - RH(k1) = MAX(con_epsq,Q(k1))/QC - - k1 = lp1-k+1 - pint(k1) = prsi(i,k) * 1000.0 - zint(k1) = phii(i,k)/con_g - - enddo - pint(1) = prsi(i,lp1) * 1000.0 - zint(1) = phii(i,lp1)/con_g - -! if(kdt>15.and.kdt<20) time_vert = time_vert + (timef() - btim) -! debug print statement -! if (abs(xlon(i)*57.29578-114.0) .lt. 0.2 .and. & -! abs(xlat(i)*57.29578-40.0) .lt. 0.2)then -! print*,'debug in calpreciptype: i,im,lm,lp1,xlon,xlat,prec,tskin,sr,nrcm,randomno,num_p3d ', & -! i,im,lm,lp1,xlon(i)*57.29578,xlat(i)*57.29578,prec(i),tskin(i),sr(i), & -! nrcm,randomno(i,1:nrcm),num_p3d -! do l=1,lm -! print*,'debug in calpreciptype: l,t,q,p,pint,z,twet', & -! l,t(l),q(l), & -! pmid(l),pint(l),zint(l),twet(l) -! end do -! print*,'debug in calpreciptype: lp1,pint,z ', lp1,pint(lp1),zint(lp1) -! end if -! end debug print statement -! CALL WETBULB(lm,con_rocp,con_epsq,T,Q,PMID,TWET) -! INSTANTANEOUS PRECIPITATION TYPE. -! if(kdt>10.and.kdt<20)btim = timef() - - CALL CALWXT(lm,lp1,T(1),Q(1),PMID(1),PINT(1),PREC(i), - & PTHRESH,con_fvirt,con_rog,con_epsq, - & ZINT(1),IWX1,TWET(1)) -! if(kdt>10.and.kdt<20)time_ncep=time_ncep+(timef() - btim) - IWX = IWX1 - ISNO = MOD(IWX,2) - IIP = MOD(IWX,4)/2 - IZR = MOD(IWX,8)/4 - IRAIN = IWX/8 - SNOW(1) = ISNO*1.0 - SLEET(1) = IIP*1.0 - FREEZR(1) = IZR*1.0 - RAIN(1) = IRAIN*1.0 - - -! DOMINANT PRECIPITATION TYPE -!GSM IF DOMINANT PRECIP TYPE IS REQUESTED, 4 MORE ALGORITHMS -!GSM WILL BE CALLED. THE TALLIES ARE THEN SUMMED IN -!GSM CALWXT_DOMINANT - -! RAMER ALGORITHM -! ALLOCATE ( RH(LM),TD(LM) ) -! DO L=1,LM -!HC: use RH and TD consistent with GFS ice physics -! ES=FPVS(T(L)) -! ES=MIN(ES,PMID(L)) -! QC=CON_EPS*ES/(PMID(L)+CON_EPSM1*ES) -! RH(L)=MAX(con_epsq,Q(L))/QC -! PV = PMID(L)*Q(L)/(CON_EPS-CON_EPSM1*Q(L)) -! TD(L)=FTDP(PV) -! END DO -! if(kdt>10.and.kdt<20)btim = timef() - - CALL CALWXT_RAMER(lm,lp1,T(1),Q(1),PMID(1),RH(1),TD(1), - & PINT(1),PREC(i),PTHRESH,IWX2) - -! if(kdt>10.and.kdt<20)time_ramer=time_ramer+(timef() - btim) -! deallocate(RH,TD) -! -! DECOMPOSE IWX2 ARRAY -! - IWX = NINT(IWX2) - ISNO = MOD(IWX,2) - IIP = MOD(IWX,4)/2 - IZR = MOD(IWX,8)/4 - IRAIN = IWX/8 - SNOW(2) = ISNO*1.0 - SLEET(2) = IIP*1.0 - FREEZR(2) = IZR*1.0 - RAIN(2) = IRAIN*1.0 - -! BOURGOUIN ALGORITHM -! ISEED=44641*(INT(SDAT(1)-1)*24*31+INT(SDAT(2))*24+IHRST)+ -! & MOD(IFHR*60+IFMIN,44641)+4357 -! if(kdt>10.and.kdt<20)btim = timef() - CALL CALWXT_BOURG(LM,LP1,randomno(i,1),con_g,PTHRESH, - & T(1),Q(1),PMID(1),PINT(1),PREC(i),ZINT(1),IWX3) -! print *,'in SURFCE,me=',me,'IWX3=',IWX3(1:30,JSTA),'PTHRESH=',PTHRESH -! if(kdt>10.and.kdt<20)time_bourg=time_bourg+(timef() - btim) -! -! DECOMPOSE IWX3 ARRAY -! - IWX = NINT(IWX3) - ISNO = MOD(IWX,2) - IIP = MOD(IWX,4)/2 - IZR = MOD(IWX,8)/4 - IRAIN = IWX/8 - SNOW(3) = ISNO*1.0 - SLEET(3) = IIP*1.0 - FREEZR(3) = IZR*1.0 - RAIN(3) = IRAIN*1.0 - -! -! REVISED NCEP ALGORITHM -! -! if(kdt>10.and.kdt<20)btim = timef() - - CALL CALWXT_REVISED(LM,LP1,T(1),Q(1),PMID(1),PINT(1), - & PREC(i),PTHRESH,con_fvirt,con_rog,con_epsq, - & ZINT(1),TWET(1),IWX4) - -! if(kdt>10.and.kdt<20)time_revised=time_revised+(timef() - btim) -! print *,'in SURFCE,me=',me,'IWX4=',IWX4(1:30,JSTA) -! -! DECOMPOSE IWX2 ARRAY -! - IWX = IWX4 - ISNO = MOD(IWX,2) - IIP = MOD(IWX,4)/2 - IZR = MOD(IWX,8)/4 - IRAIN = IWX/8 - SNOW(4) = ISNO*1.0 - SLEET(4) = IIP*1.0 - FREEZR(4) = IZR*1.0 - RAIN(4) = IRAIN*1.0 - -! EXPLICIT ALGORITHM (UNDER 18 NOT ADMITTED WITHOUT PARENT -! OR GUARDIAN) - - IF(num_p3d == 3) then ! Ferrier's scheme - CALL CALWXT_EXPLICIT(LM,PTHRESH, - & TSKIN(i),PREC(i),SR(i),F_RimeF(1),IWX5) - else - IWX5 = 0 - endif -! DECOMPOSE IWX2 ARRAY -! - IWX = IWX5 - ISNO = MOD(IWX,2) - IIP = MOD(IWX,4)/2 - IZR = MOD(IWX,8)/4 - IRAIN = IWX/8 - SNOW(5) = ISNO*1.0 - SLEET(5) = IIP*1.0 - FREEZR(5) = IZR*1.0 - RAIN(5) = IRAIN*1.0 -! -! if(kdt>10.and.kdt<20)btim = timef() - - CALL CALWXT_DOMINANT(NALG,PREC(i),PTHRESH,RAIN(1),FREEZR(1), - & SLEET(1),SNOW(1),DOMR(i),DOMZR(i),DOMIP(i),DOMS(i)) - -! if(kdt>10.and.kdt<20)time_dominant=time_dominant+(timef() - btim) -!debug print statement -! if (abs(xlon(i)*57.29578-114.0) .lt. 0.2 .and. & -! abs(xlat(i)*57.29578-40.0) .lt. 0.2) & -! print*,'debug in calpreciptype: DOMR,DOMZR,DOMIP,DOMS ', & -! DOMR(i),DOMZR(i),DOMIP(i),DOMS(i) -! end of debug print statement - - enddo ! end loop for i - -! if(kdt>10.and.kdt<20)print*, & -! 'time_vert,time_ncep,time_ramer,time_bourg,time_revised,time_dominant='& -! ,time_vert,time_ncep,time_ramer,time_bourg,time_revised,time_dominant - - DEALLOCATE (TWET,RH,TD) - RETURN - END -! -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -! - SUBROUTINE CALWXT(lm,lp1,T,Q,PMID,PINT,PREC, - & PTHRESH,D608,ROG,EPSQ, - & ZINT,IWX,TWET) -! -! FILE: CALWXT.f -! WRITTEN: 11 NOVEMBER 1993, MICHAEL BALDWIN -! REVISIONS: -! 30 SEPT 1994-SETUP NEW DECISION TREE (M BALDWIN) -! 12 JUNE 1998-CONVERSION TO 2-D (T BLACK) -! 01-10-25 H CHUANG - MODIFIED TO PROCESS HYBRID MODEL OUTPUT -! 02-01-15 MIKE BALDWIN - WRF VERSION -! -! -! ROUTINE TO COMPUTE PRECIPITATION TYPE USING A DECISION TREE -! APPROACH THAT USES VARIABLES SUCH AS INTEGRATED WET BULB TEMP -! BELOW FREEZING AND LOWEST LAYER TEMPERATURE -! -! SEE BALDWIN AND CONTORNO PREPRINT FROM 13TH WEATHER ANALYSIS -! AND FORECASTING CONFERENCE FOR MORE DETAILS -! (OR BALDWIN ET AL, 10TH NWP CONFERENCE PREPRINT) -! -! use params_mod -! use ctlblk_mod -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none -! -! INPUT: -! T,Q,PMID,HTM,LMH,PREC,ZINT -! - integer,intent(in):: lm,lp1 -! real,intent(in):: pthresh - real,dimension(LM),intent(in) :: T,Q,PMID,TWET - real,dimension(LP1),intent(in) :: ZINT,PINT - integer,intent(out) :: IWX - real,intent(in) :: PREC,PTHRESH,D608,ROG,EPSQ -! real,intent(out) :: ZWET - - -! OUTPUT: -! IWX - INSTANTANEOUS WEATHER TYPE. -! ACTS LIKE A 4 BIT BINARY -! 1111 = RAIN/FREEZING RAIN/ICE PELLETS/SNOW -! WHERE THE ONE'S DIGIT IS FOR SNOW -! THE TWO'S DIGIT IS FOR ICE PELLETS -! THE FOUR'S DIGIT IS FOR FREEZING RAIN -! AND THE EIGHT'S DIGIT IS FOR RAIN -! -! INTERNAL: -! -! REAL, ALLOCATABLE :: TWET(:) - real, parameter :: D00=0.0 - integer KARR,LICEE - real TCOLD,TWARM - -! SUBROUTINES CALLED: -! WETBULB -! -! -! INITIALIZE WEATHER TYPE ARRAY TO ZERO (IE, OFF). -! WE DO THIS SINCE WE WANT IWX TO REPRESENT THE -! INSTANTANEOUS WEATHER TYPE ON RETURN. -! -! -! ALLOCATE LOCAL STORAGE -! - - integer I,J,L,LMHK,LICE,IFREL,IWRML,IFRZL - real PSFCK,TDCHK,A,TDKL,TDPRE,TLMHK,TWRMK,AREAS8,AREAP4, - & SURFW,SURFC,DZKL,AREA1,PINTK1,PINTK2,PM150,PKL,TKL,QKL - -! ALLOCATE ( TWET(LM) ) -! -!!$omp parallel do - IWX = 0 -! ZWET=SPVAL -! -!!$omp parallel do -!!$omp& private(a,lmhk,pkl,psfck,qkl,tdchk,tdkl,tdpre,tkl) - -! -! SKIP THIS POINT IF NO PRECIP THIS TIME STEP -! - IF (PREC.LE.PTHRESH) GOTO 800 -! -! FIND COLDEST AND WARMEST TEMPS IN SATURATED LAYER BETWEEN -! 70 MB ABOVE GROUND AND 500 MB -! ALSO FIND HIGHEST SATURATED LAYER IN THAT RANGE -! -!meb - PSFCK=PINT(LM+1) -!meb - TDCHK=2.0 - 760 TCOLD=T(LM) - TWARM=T(LM) - LICEE=LM -! - DO 775 L=1,LM - QKL=Q(L) - QKL=AMAX1(EPSQ,QKL) - TKL=T(L) - PKL=PMID(L) -! -! SKIP PAST THIS IF THE LAYER IS NOT BETWEEN 70 MB ABOVE GROUND -! AND 500 MB -! - IF (PKL.LT.50000.0.OR.PKL.GT.PSFCK-7000.0) GOTO 775 - A=ALOG(QKL*PKL/(6.1078*(0.378*QKL+0.622))) - TDKL=(237.3*A)/(17.269-A)+273.15 - TDPRE=TKL-TDKL - IF (TDPRE.LT.TDCHK.AND.TKL.LT.TCOLD) TCOLD=TKL - IF (TDPRE.LT.TDCHK.AND.TKL.GT.TWARM) TWARM=TKL - IF (TDPRE.LT.TDCHK.AND.L.LT.LICEE) LICEE=L - 775 CONTINUE -! -! IF NO SAT LAYER AT DEW POINT DEP=TDCHK, INCREASE TDCHK -! AND START AGAIN (BUT DON'T MAKE TDCHK > 6) -! - IF (TCOLD==T(LM).AND.TDCHK<6.0) THEN - TDCHK=TDCHK+2.0 - GOTO 760 - ENDIF - 800 CONTINUE -! -! LOWEST LAYER T -! - KARR=0 - IF (PREC.LE.PTHRESH) GOTO 850 - TLMHK=T(LM) -! -! DECISION TREE TIME -! - IF (TCOLD>269.15) THEN - IF (TLMHK.LE.273.15) THEN -! TURN ON THE FLAG FOR -! FREEZING RAIN = 4 -! IF ITS NOT ON ALREADY -! IZR=MOD(IWX(I,J),8)/4 -! IF (IZR.LT.1) IWX(I,J)=IWX(I,J)+4 - IWX=IWX+4 - GOTO 850 - ELSE -! TURN ON THE FLAG FOR -! RAIN = 8 -! IF ITS NOT ON ALREADY -! IRAIN=IWX(I,J)/8 -! IF (IRAIN.LT.1) IWX(I,J)=IWX(I,J)+8 - IWX=IWX+8 - GOTO 850 - ENDIF - ENDIF - KARR=1 - 850 CONTINUE -! -! COMPUTE WET BULB ONLY AT POINTS THAT NEED IT -! -! CALL WETBULB(lm,T,Q,PMID,KARR,TWET) -! CALL WETFRZLVL(TWET,ZWET) -! -!!$omp parallel do -!!$omp& private(area1,areap4,areas8,dzkl,ifrzl,iwrml,lice, -!!$omp& lmhk,pintk1,pintk2,pm150,psfck,surfc,surfw, -!!$omp& tlmhk,twrmk) - - IF(KARR.GT.0)THEN - LICE=LICEE -!meb - PSFCK=PINT(LM+1) -!meb - TLMHK=T(LM) - TWRMK=TWARM -! -! TWET AREA VARIABLES -! CALCULATE ONLY WHAT IS NEEDED -! FROM GROUND TO 150 MB ABOVE SURFACE -! FROM GROUND TO TCOLD LAYER -! AND FROM GROUND TO 1ST LAYER WHERE WET BULB T < 0.0 -! -! PINTK1 IS THE PRESSURE AT THE BOTTOM OF THE LAYER -! PINTK2 IS THE PRESSURE AT THE TOP OF THE LAYER -! -! AREAP4 IS THE AREA OF TWET ABOVE -4 C BELOW HIGHEST SAT LYR -! - AREAS8=D00 - AREAP4=D00 - SURFW =D00 - SURFC =D00 -! - DO 1945 L=LM,LICE,-1 - DZKL=ZINT(L)-ZINT(L+1) - AREA1=(TWET(L)-269.15)*DZKL - IF (TWET(L).GE.269.15) AREAP4=AREAP4+AREA1 - 1945 CONTINUE -! - IF (AREAP4.LT.3000.0) THEN -! TURN ON THE FLAG FOR -! SNOW = 1 -! IF ITS NOT ON ALREADY -! ISNO=MOD(IWX(I,J),2) -! IF (ISNO.LT.1) IWX(I,J)=IWX(I,J)+1 - IWX=IWX+1 - GO TO 1900 - ENDIF -! -! AREAS8 IS THE NET AREA OF TWET W.R.T. FREEZING IN LOWEST 150MB -! - PINTK1=PSFCK - PM150=PSFCK-15000. -! - DO 1955 L=LM,1,-1 - PINTK2=PINT(L) - IF(PINTK1.LT.PM150)GO TO 1950 - DZKL=ZINT(L)-ZINT(L+1) -! -! SUM PARTIAL LAYER IF IN 150 MB AGL LAYER -! - IF(PINTK2.LT.PM150) - & DZKL=T(L)*(Q(L)*D608+1.0)*ROG*ALOG(PINTK1/PM150) - AREA1=(TWET(L)-273.15)*DZKL - AREAS8=AREAS8+AREA1 - 1950 PINTK1=PINTK2 - 1955 CONTINUE -! -! SURFW IS THE AREA OF TWET ABOVE FREEZING BETWEEN THE GROUND -! AND THE FIRST LAYER ABOVE GROUND BELOW FREEZING -! SURFC IS THE AREA OF TWET BELOW FREEZING BETWEEN THE GROUND -! AND THE WARMEST SAT LAYER -! - IFRZL=0 - IWRML=0 -! - DO 2050 L=LM,1,-1 - IF (IFRZL.EQ.0.AND.T(L).LT.273.15) IFRZL=1 - IF (IWRML.EQ.0.AND.T(L).GE.TWRMK) IWRML=1 -! - IF (IWRML.EQ.0.OR.IFRZL.EQ.0) THEN -! if(pmid(l) < 50000.)print*,'need twet above 500mb' - DZKL=ZINT(L)-ZINT(L+1) - AREA1=(TWET(L)-273.15)*DZKL - IF(IFRZL.EQ.0.AND.TWET(L).GE.273.15)SURFW=SURFW+AREA1 - IF(IWRML.EQ.0.AND.TWET(L).LE.273.15)SURFC=SURFC+AREA1 - ENDIF - 2050 CONTINUE - IF(SURFC.LT.-3000.0.OR. - & (AREAS8.LT.-3000.0.AND.SURFW.LT.50.0)) THEN -! TURN ON THE FLAG FOR -! ICE PELLETS = 2 -! IF ITS NOT ON ALREADY -! IIP=MOD(IWX(I,J),4)/2 -! IF (IIP.LT.1) IWX(I,J)=IWX(I,J)+2 - IWX=IWX+2 - GOTO 1900 - ENDIF -! - IF(TLMHK.LT.273.15) THEN -! TURN ON THE FLAG FOR -! FREEZING RAIN = 4 -! IF ITS NOT ON ALREADY -! IZR=MOD(IWX(K),8)/4 -! IF (IZR.LT.1) IWX(K)=IWX(K)+4 - IWX=IWX+4 - ELSE -! TURN ON THE FLAG FOR -! RAIN = 8 -! IF ITS NOT ON ALREADY -! IRAIN=IWX(K)/8 -! IF (IRAIN.LT.1) IWX(K)=IWX(K)+8 - IWX=IWX+8 - ENDIF - ENDIF - 1900 CONTINUE -!--------------------------------------------------------- -! DEALLOCATE (TWET) - - RETURN - END -! -! -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -! -! DoPhase is a subroutine written and provided by Jim Ramer at NOAA/FSL -! -! Ramer, J, 1993: An empirical technique for diagnosing precipitation -! type from model output. Preprints, 5th Conf. on Aviation -! Weather Systems, Vienna, VA, Amer. Meteor. Soc., 227-230. -! -! CODE ADAPTED FOR WRF POST 24 AUGUST 2005 G MANIKIN -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -! - SUBROUTINE CALWXT_RAMER(lm,lp1, - & T,Q,PMID,RH,TD,PINT,PREC,PTHRESH,PTYP) - -! SUBROUTINE dophase(pq, ! input pressure sounding mb -! + t, ! input temperature sounding K -! + pmid, ! input pressure -! + pint, ! input interface pressure -! + q, ! input spec humidityfraction -! + lmh, ! input number of levels in sounding -! + prec, ! input amount of precipitation -! + ptyp) ! output(2) phase 2=Rain, 3=Frzg, 4=Solid, -! 6=IP JC 9/16/99 -! use params_mod -! use CTLBLK_mod -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none -! - real,PARAMETER :: LECP=1572.5 - real,PARAMETER :: twice=266.55,rhprcp=0.80,deltag=1.02, - & prcpmin=0.3,emelt=0.045,rlim=0.04,slim=0.85 - real,PARAMETER :: twmelt=273.15,tz=273.15,efac=1.0 ! specify in params now -! - INTEGER*4 i, k1, lll, k2, toodry -! - REAL xxx ,mye, icefrac,flg - integer,intent(in) :: lm,lp1 - real,DIMENSION(LM),intent(in) :: T,Q,PMID,RH,TD - real,DIMENSION(LP1),intent(in) :: PINT - real,intent(in) :: PREC,PTHRESH - real,intent(out) :: PTYP -! - real,DIMENSION(LM) :: P,TQ,QQ,PQ,RHQ - real,DIMENSION(LM) :: tqtmp,pqtmp,rhqtmp - real,DIMENSION(LM) :: TWQ -! - integer J,L,LEV,LNQ,ii - real RHMAX,TWMAX,PTOP,dpdrh,twtop,rhtop,wgt1,wgt2, - & rhavg,dtavg,dpk,ptw,rate,pbot,qc, b,qtmp - real,external :: xmytw -! -! Initialize. - icefrac = -9999. -! - - PTYP = 0 - DO 88 L = 1,LM - LEV=LM-L+1 -! P(L)=PMID(L) -! QC=PQ0/P(L) * EXP(A2*(T(L)-A3)/(T(L)-A4)) -!GSM forcing Q (QTMP) to be positive to deal with negative Q values -! causing problems later in this subroutine -! QTMP=AMAX1(H1M12,Q(L)) -! RHQTMP(LEV)=QTMP/QC - RHQ(LEV)=RH(L) - PQ(LEV)=PMID(L)/100. - TQ(LEV)=T(L) - 88 CONTINUE - -! do 92 L=1,LM -! TQ(L)=TQTMP(L) -! PQ(L)=PQTMP(L) -! RHQ(L)=RHQTMP(L) -! 92 continue - -! BIG LOOP -! DO 800 J=JSTA,JEND -! DO 800 I=1,IM -! -! SKIP THIS POINT IF NO PRECIP THIS TIME STEP -! - IF (PREC.LE.PTHRESH) GOTO 800 - -! -! -!CC RATE RESTRICTION REMOVED BY JOHN CORTINAS 3/16/99 -! -! Construct wet-bulb sounding, locate generating level. - twmax = -999.0 - rhmax = 0.0 - k1 = 0 ! top of precip generating layer - k2 = 0 ! layer of maximum rh -! - IF (rhq(1).lt.rhprcp) THEN - toodry = 1 - ELSE - toodry = 0 - END IF -! - pbot = pq(1) -! NQ=LM - DO 10 L = 1, lm -! xxx = tdofesat(esat(tq(L))*rhq(L)) - xxx = td(l) !HC: use TD consistent with GFS ice physics - if (xxx .lt. -500.) goto 800 - twq(L) = xmytw(tq(L),xxx,pq(L)) - twmax = amax1(twq(L),twmax) - IF (pq(L).ge.400.0) THEN - IF (rhq(L).gt.rhmax) THEN - rhmax = rhq(L) - k2 = i - END IF -! - IF (L.ne.1) THEN - IF (rhq(L).ge.rhprcp.or.toodry.eq.0) THEN - IF (toodry.ne.0) THEN - dpdrh = alog(pq(L)/pq(L-1)) / - & (rhq(L)-RHQ(L-1)) - pbot = exp(alog(pq(L))+(rhprcp-rhq(L))*dpdrh) -! - ptw = pq(L) - toodry = 0 - ELSE IF (rhq(L).ge.rhprcp) THEN - ptw = pq(L) - ELSE - toodry = 1 - dpdrh = alog(pq(L)/pq(L-1)) / - & (rhq(L)-rhq(L-1)) - ptw = exp(alog(pq(L))+(rhprcp-rhq(L))*dpdrh) -!lin dpdrh=(Pq(i)-Pq(i-1))/(Rhq(i)-Rhq(i-1)) -!lin ptw=Pq(i)+(rhprcp-Rhq(i))*dpdrh -! - END IF -! - IF (pbot/ptw.ge.deltag) THEN -!lin If (pbot-ptw.lt.deltag) Goto 2003 - k1 = L - ptop = ptw - END IF - END IF - END IF - END IF -! - 10 CONTINUE - -! -! Gross checks for liquid and solid precip which dont require generating level. -! - IF (twq(1).ge.273.15+2.0) THEN - ptyp = 8 ! liquid - icefrac = 0.0 - goto 800 - END IF -! - IF (twmax.le.twice) THEN - icefrac = 1.0 - ptyp = 1 ! solid - goto 800 - END IF -! -! Check to see if we had no success with locating a generating level. -! - IF (k1.eq.0) goto 800 -! - IF (ptop.eq.pq(k1)) THEN - twtop = twq(k1) - rhtop = rhq(k1) - k2 = k1 - k1 = k1 - 1 - ELSE - k2 = k1 - k1 = k1 - 1 - wgt1 = alog(ptop/pq(k2)) / alog(pq(k1)/pq(k2)) - wgt2 = 1.0 - wgt1 - twtop = twq(k1) * wgt1 + twq(k2) * wgt2 - rhtop = rhq(k1) * wgt1 + rhq(k2) * wgt2 - END IF -! - -! Calculate temp and wet-bulb ranges below precip generating level. - DO 20 L = 1, k1 - twmax = amax1(twq(l),twmax) - 20 CONTINUE -! -! Gross check for solid precip, initialize ice fraction. -! IF (i.eq.1.and.j.eq.1) WRITE (*,*) 'twmax=',twmax,twice,'twtop=',twtop - IF (twtop.le.twice) THEN - icefrac = 1.0 - IF (twmax.le.twmelt) THEN ! gross check for solid precip. - ptyp = 1 ! solid precip - goto 800 - END IF - lll = 0 - ELSE - icefrac = 0.0 - lll = 1 - END IF -! -! Loop downward through sounding from highest precip generating level. - 30 CONTINUE -! - IF (icefrac.ge.1.0) THEN ! starting as all ice - IF (twq(k1).lt.twmelt) GO TO 40 ! cannot commence melting - IF (twq(k1).eq.twtop) GO TO 40 ! both equal twmelt, nothing h - wgt1 = (twmelt-twq(k1)) / (twtop-twq(k1)) - rhavg = rhq(k1) + wgt1 * (rhtop-rhq(k1)) / 2 - dtavg = (twmelt-twq(k1)) / 2 - dpk = wgt1 * alog(pq(k1)/ptop) !lin dpk=wgt1*(Pq(k1)-Ptop) -! mye=emelt*(1.0-(1.0-Rhavg)*efac) - mye = emelt * rhavg ** efac - icefrac = icefrac + dpk * dtavg / mye - ELSE IF (icefrac.le.0.0) THEN ! starting as all liquid - lll = 1 -! Goto 1020 - IF (twq(k1).gt.twice) GO TO 40 ! cannot commence freezing - IF (twq(k1).eq.twtop) THEN - wgt1 = 0.5 - ELSE - wgt1 = (twice-twq(k1)) / (twtop-twq(k1)) - END IF - rhavg = rhq(k1) + wgt1 * (rhtop-rhq(k1)) / 2 - dtavg = twmelt - (twq(k1)+twice) / 2 - dpk = wgt1 * alog(pq(k1)/ptop) !lin dpk=wgt1*(Pq(k1)-Ptop) -! mye=emelt*(1.0-(1.0-Rhavg)*efac) - mye = emelt * rhavg ** efac - icefrac = icefrac + dpk * dtavg / mye - ELSE IF ((twq(k1).le.twmelt).and.(twq(k1).lt.twmelt)) THEN ! mix - rhavg = (rhq(k1)+rhtop) / 2 - dtavg = twmelt - (twq(k1)+twtop) / 2 - dpk = alog(pq(k1)/ptop) !lin dpk=Pq(k1)-Ptop -! mye=emelt*(1.0-(1.0-Rhavg)*efac) - mye = emelt * rhavg ** efac - icefrac = icefrac + dpk * dtavg / mye - ELSE ! mix where Tw curve crosses twmelt in layer - IF (twq(k1).eq.twtop) GO TO 40 ! both equal twmelt, nothing h - wgt1 = (twmelt-twq(k1)) / (twtop-twq(k1)) - wgt2 = 1.0 - wgt1 - rhavg = rhtop + wgt2 * (rhq(k1)-rhtop) / 2 - dtavg = (twmelt-twtop) / 2 - dpk = wgt2 * alog(pq(k1)/ptop) !lin dpk=wgt2*(Pq(k1)-Ptop) -! mye=emelt*(1.0-(1.0-Rhavg)*efac) - mye = emelt * rhavg ** efac - icefrac = icefrac + dpk * dtavg / mye - icefrac = amin1(1.0,amax1(icefrac,0.0)) - IF (icefrac.le.0.0) THEN -! Goto 1020 - IF (twq(k1).gt.twice) GO TO 40 ! cannot commence freezin - wgt1 = (twice-twq(k1)) / (twtop-twq(k1)) - dtavg = twmelt - (twq(k1)+twice) / 2 - ELSE - dtavg = (twmelt-twq(k1)) / 2 - END IF - rhavg = rhq(k1) + wgt1 * (rhtop-rhq(k1)) / 2 - dpk = wgt1 * alog(pq(k1)/ptop) !lin dpk=wgt1*(Pq(k1)-Ptop) -! mye=emelt*(1.0-(1.0-Rhavg)*efac) - mye = emelt * rhavg ** efac - icefrac = icefrac + dpk * dtavg / mye - END IF -! - icefrac = amin1(1.0,amax1(icefrac,0.0)) -! IF (i.eq.1.and.j.eq.1) WRITE (*,*) 'NEW ICEFRAC:', icefrac, icefrac -! -! Get next level down if there is one, loop back. - 40 IF (k1.gt.1) THEN - twtop = twq(k1) - ptop = pq(k1) - rhtop = rhq(k1) - k1 = k1 - 1 - GO TO 30 - END IF -! -! -! Determine precip type based on snow fraction and surface wet-bulb. -! -! - IF (icefrac.ge.slim) THEN - IF (lll.ne.0) THEN - ptyp = 2 ! Ice Pellets JC 9/16/99 - ELSE - ptyp = 1 ! Snow - END IF - ELSE IF (icefrac.le.rlim) THEN - IF (twq(1).lt.tz) THEN - ptyp = 4 ! Freezing Precip - ELSE - ptyp = 8 ! Rain - END IF - ELSE - IF (twq(1).lt.tz) THEN -!GSM not sure what to do when 'mix' is predicted; In previous -!GSM versions of this code for which I had to have an answer, -!GSM I chose sleet. Here, though, since we have 4 other -!GSM algorithms to provide an answer, I will not declare a -!GSM type from the Ramer in this situation and allow the -!GSM other algorithms to make the call. - - ptyp = 0 ! don't know -! ptyp = 5 ! Mix - ELSE -! ptyp = 5 ! Mix - ptyp = 0 ! don't know - END IF - END IF - 800 CONTINUE - - RETURN -! - END -! -! -!-------------------------------------------------------------------------- -! REAL*4 FUNCTION mytw(t,td,p) - FUNCTION xmytw(t,td,p) -! - IMPLICIT NONE -! - INTEGER*4 cflag, l -! REAL*4 f, c0, c1, c2, k, kd, kw, ew, t, td, p, ed, fp, s, & - REAL f, c0, c1, c2, k, kd, kw, ew, t, td, p, ed, fp, s, - & de, xmytw - DATA f, c0, c1, c2 /0.0006355, 26.66082, 0.0091379024, 6106.3960/ -! -! - xmytw = (t+td) / 2 - IF (td.ge.t) RETURN -! - IF (t.lt.100.0) THEN - k = t + 273.15 - kd = td + 273.15 - IF (kd.ge.k) RETURN - cflag = 1 - ELSE - k = t - kd = td - cflag = 0 - END IF -! - ed = c0 - c1 * kd - c2 / kd - IF (ed.lt.-14.0.or.ed.gt.7.0) RETURN - ed = exp(ed) - ew = c0 - c1 * k - c2 / k - IF (ew.lt.-14.0.or.ew.gt.7.0) RETURN - ew = exp(ew) - fp = p * f - s = (ew-ed) / (k-kd) - kw = (k*fp+kd*s) / (fp+s) -! - DO 10 l = 1, 5 - ew = c0 - c1 * kw - c2 / kw - IF (ew.lt.-14.0.or.ew.gt.7.0) RETURN - ew = exp(ew) - de = fp * (k-kw) + ed - ew - IF (abs(de/ew).lt.1E-5) GO TO 20 - s = ew * (c1-c2/(kw*kw)) - fp - kw = kw - de / s - 10 CONTINUE - 20 CONTINUE -! -! print *, 'kw ', kw - IF (cflag.ne.0) THEN - xmytw = kw - 273.15 - ELSE - xmytw = kw - END IF -! - RETURN - END -! -! -!$$$ Subprogram documentation block -! -! Subprogram: calwxt_bourg Calculate precipitation type (Bourgouin) -! Prgmmr: Baldwin Org: np22 Date: 1999-07-06 -! -! Abstract: This routine computes precipitation type -! using a decision tree approach that uses the so-called -! "energy method" of Bourgouin of AES (Canada) 1992 -! -! Program history log: -! 1999-07-06 M Baldwin -! 1999-09-20 M Baldwin make more consistent with bourgouin (1992) -! 2005-08-24 G Manikin added to wrf post -! 2007-06-19 M Iredell mersenne twister, best practices -! 2008-03-03 G Manikin added checks to prevent stratospheric warming -! episodes from being seen as "warm" layers -! impacting precip type -! -! Usage: call calwxt_bourg(im,jm,jsta_2l,jend_2u,jsta,jend,lm,lp1, & -! & iseed,g,pthresh, & -! & t,q,pmid,pint,lmh,prec,zint,ptype) -! Input argument list: -! im integer i dimension -! jm integer j dimension -! jsta_2l integer j dimension start point (including haloes) -! jend_2u integer j dimension end point (including haloes) -! jsta integer j dimension start point (excluding haloes) -! jend integer j dimension end point (excluding haloes) -! lm integer k dimension -! lp1 integer k dimension plus 1 -! iseed integer random number seed -! g real gravity (m/s**2) -! pthresh real precipitation threshold (m) -! t real(im,jsta_2l:jend_2u,lm) mid layer temp (K) -! q real(im,jsta_2l:jend_2u,lm) specific humidity (kg/kg) -! pmid real(im,jsta_2l:jend_2u,lm) mid layer pressure (Pa) -! pint real(im,jsta_2l:jend_2u,lp1) interface pressure (Pa) -! lmh real(im,jsta_2l:jend_2u) max number of layers -! prec real(im,jsta_2l:jend_2u) precipitation (m) -! zint real(im,jsta_2l:jend_2u,lp1) interface height (m) -! Output argument list: -! ptype real(im,jm) instantaneous weather type () -! acts like a 4 bit binary -! 1111 = rain/freezing rain/ice pellets/snow -! where the one's digit is for snow -! the two's digit is for ice pellets -! the four's digit is for freezing rain -! and the eight's digit is for rain -! in other words... -! ptype=1 snow -! ptype=2 ice pellets/mix with ice pellets -! ptype=4 freezing rain/mix with freezing rain -! ptype=8 rain -! -! Modules used: -! mersenne_twister pseudo-random number generator -! -! Subprograms called: -! random_number pseudo-random number generator -! -! Attributes: -! Language: Fortran 90 -! -! Remarks: vertical order of arrays must be layer 1 = top -! and layer lmh = bottom -! -!$$$ - subroutine calwxt_bourg(lm,lp1,rn,g,pthresh, - & t,q,pmid,pint,prec,zint,ptype) -! use mersenne_twister - implicit none -! -! input: - integer,intent(in):: lm,lp1 -! integer,intent(in):: iseed - real,intent(in):: g,pthresh,rn(2) - real,intent(in):: t(lm) - real,intent(in):: q(lm) - real,intent(in):: pmid(lm) - real,intent(in):: pint(lp1) - real,intent(in):: prec - real,intent(in):: zint(lp1) -! -! output: - real,intent(out):: ptype -! - integer ifrzl,iwrml,l,lhiwrm,lmhk - real pintk1,areane,tlmhk,areape,pintk2,surfw,area1,dzkl,psfck - real r1,r2 -! -! initialize weather type array to zero (ie, off). -! we do this since we want ptype to represent the -! instantaneous weather type on return. -! -!!$omp parallel do - - ptype = 0 - -! -! call random_number(rn,iseed) -! -!!$omp parallel do -!!$omp& private(a,lmhk,tlmhk,iwrml,psfck,lhiwrm,pintk1,pintk2,area1, -!!$omp& areape,dzkl,surfw,r1,r2) - - psfck=pint(lm+1) -! -! skip this point if no precip this time step -! - if (prec.le.pthresh) return -! find the depth of the warm layer based at the surface -! this will be the cut off point between computing -! the surface based warm air and the warm air aloft -! -! -! lowest layer t -! - tlmhk = t(lm) - iwrml = lm + 1 - if (tlmhk.ge.273.15) then - do l = lm, 2, -1 - if (t(l).ge.273.15.and.t(l-1).lt.273.15.and. - & iwrml.eq.lm+1) iwrml = l - end do - end if -! -! now find the highest above freezing level -! - lhiwrm = lm + 1 - do l = lm, 1, -1 -! gsm added 250 mb check to prevent stratospheric warming situations -! from counting as warm layers aloft - if (t(l).ge.273.15 .and. pmid(l).gt.25000.) lhiwrm = l - end do - -! energy variables -! surfw is the positive energy between the ground -! and the first sub-freezing layer above ground -! areane is the negative energy between the ground -! and the highest layer above ground -! that is above freezing -! areape is the positive energy "aloft" -! which is the warm energy not based at the ground -! (the total warm energy = surfw + areape) -! -! pintk1 is the pressure at the bottom of the layer -! pintk2 is the pressure at the top of the layer -! dzkl is the thickness of the layer -! ifrzl is a flag that tells us if we have hit -! a below freezing layer -! - pintk1 = psfck - ifrzl = 0 - areane = 0.0 - areape = 0.0 - surfw = 0.0 - - do l = lm, 1, -1 - if (ifrzl.eq.0.and.t(l).le.273.15) ifrzl = 1 - pintk2=pint(l) - dzkl=zint(l)-zint(l+1) - area1 = alog(t(l)/273.15) * g * dzkl - if (t(l).ge.273.15.and. pmid(l).gt.25000.) then - if (l.lt.iwrml) areape = areape + area1 - if (l.ge.iwrml) surfw = surfw + area1 - else - if (l.gt.lhiwrm) areane = areane + abs(area1) - end if - pintk1 = pintk2 - end do - -! -! decision tree time -! - if (areape.lt.2.0) then -! very little or no positive energy aloft, check for -! positive energy just above the surface to determine rain vs. snow - if (surfw.lt.5.6) then -! not enough positive energy just above the surface -! snow = 1 - ptype = 1 - else if (surfw.gt.13.2) then -! enough positive energy just above the surface -! rain = 8 - ptype = 8 - else -! transition zone, assume equally likely rain/snow -! picking a random number, if <=0.5 snow - r1 = rn(1) - if (r1.le.0.5) then -! snow = 1 - ptype = 1 - else -! rain = 8 - ptype = 8 - end if - end if -! - else -! some positive energy aloft, check for enough negative energy -! to freeze and make ice pellets to determine ip vs. zr - if (areane.gt.66.0+0.66*areape) then -! enough negative area to make ip, -! now need to check if there is enough positive energy -! just above the surface to melt ip to make rain - if (surfw.lt.5.6) then -! not enough energy at the surface to melt ip -! ice pellets = 2 - ptype = 2 - else if (surfw.gt.13.2) then -! enough energy at the surface to melt ip -! rain = 8 - ptype = 8 - else -! transition zone, assume equally likely ip/rain -! picking a random number, if <=0.5 ip - r1 = rn(1) - if (r1.le.0.5) then -! ice pellets = 2 - ptype = 2 - else -! rain = 8 - ptype = 8 - end if - end if - else if (areane.lt.46.0+0.66*areape) then -! not enough negative energy to refreeze, check surface temp -! to determine rain vs. zr - if (tlmhk.lt.273.15) then -! freezing rain = 4 - ptype = 4 - else -! rain = 8 - ptype = 8 - end if - else -! transition zone, assume equally likely ip/zr -! picking a random number, if <=0.5 ip - r1 = rn(1) - if (r1.le.0.5) then -! still need to check positive energy -! just above the surface to melt ip vs. rain - if (surfw.lt.5.6) then -! ice pellets = 2 - ptype = 2 - else if (surfw.gt.13.2) then -! rain = 8 - ptype = 8 - else -! transition zone, assume equally likely ip/rain -! picking a random number, if <=0.5 ip - r2 = rn(2) - if (r2.le.0.5) then -! ice pellets = 2 - ptype = 2 - else -! rain = 8 - ptype = 8 - end if - end if - else -! not enough negative energy to refreeze, check surface temp -! to determine rain vs. zr - if (tlmhk.lt.273.15) then -! freezing rain = 4 - ptype = 4 - else -! rain = 8 - ptype = 8 - end if - end if - end if - end if -! end do -! end do - return - end -! -! - SUBROUTINE CALWXT_REVISED(LM,LP1,T,Q,PMID,PINT,PREC, - & PTHRESH,D608,ROG,EPSQ, - & ZINT,TWET,IWX) -! -! FILE: CALWXT.f -! WRITTEN: 11 NOVEMBER 1993, MICHAEL BALDWIN -! REVISIONS: -! 30 SEPT 1994-SETUP NEW DECISION TREE (M BALDWIN) -! 12 JUNE 1998-CONVERSION TO 2-D (T BLACK) -! 01-10-25 H CHUANG - MODIFIED TO PROCESS HYBRID MODEL OUTPUT -! 02-01-15 MIKE BALDWIN - WRF VERSION -! 05-07-07 BINBIN ZHOU - ADD PREC FOR RSM -! 05-08-24 GEOFF MANIKIN - MODIFIED THE AREA REQUIREMENTS -! TO MAKE AN ALTERNATE ALGORITHM -! -! -! ROUTINE TO COMPUTE PRECIPITATION TYPE USING A DECISION TREE -! APPROACH THAT USES VARIABLES SUCH AS INTEGRATED WET BULB TEMP -! BELOW FREEZING AND LOWEST LAYER TEMPERATURE -! -! SEE BALDWIN AND CONTORNO PREPRINT FROM 13TH WEATHER ANALYSIS -! AND FORECASTING CONFERENCE FOR MORE DETAILS -! (OR BALDWIN ET AL, 10TH NWP CONFERENCE PREPRINT) -! -! SINCE THE ORIGINAL VERSION OF THE ALGORITHM HAS A HIGH BIAS -! FOR FREEZING RAIN AND SLEET, THE GOAL IS TO BALANCE THAT BIAS -! WITH A VERSION MORE LIKELY TO PREDICT SNOW -! -! use params_mod -! use ctlblk_mod -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none -! -! LIST OF VARIABLES NEEDED -! PARAMETERS: -! D608,ROG,H1,D00 -!HC PARAMETER(D608=0.608,ROG=287.04/9.8,H1=1.0,D00=0.0) -! -! INPUT: -! T,Q,PMID,HTM,LMH,PREC,ZINT - integer,intent(in):: lm,lp1 - REAL,dimension(LM),intent(in) :: T,Q,PMID,TWET - REAL,dimension(LP1),intent(in) :: PINT,ZINT - REAL,intent(in) :: PREC,PTHRESH,D608,ROG,EPSQ -! OUTPUT: -! IWX - INSTANTANEOUS WEATHER TYPE. -! ACTS LIKE A 4 BIT BINARY -! 1111 = RAIN/FREEZING RAIN/ICE PELLETS/SNOW -! WHERE THE ONE'S DIGIT IS FOR SNOW -! THE TWO'S DIGIT IS FOR ICE PELLETS -! THE FOUR'S DIGIT IS FOR FREEZING RAIN -! AND THE EIGHT'S DIGIT IS FOR RAIN - integer, intent(out) :: IWX -! INTERNAL: -! - real, parameter :: D00=0.0 - integer KARR,LICEE - real TCOLD,TWARM -! - integer I,J,L,LMHK,LICE,IFREL,IWRML,IFRZL - real PSFCK,TDCHK,A,TDKL,TDPRE,TLMHK,TWRMK,AREAS8,AREAP4,AREA1, - & SURFW,SURFC,DZKL,PINTK1,PINTK2,PM150,QKL,TKL,PKL,AREA0, - & AREAP0 - -! SUBROUTINES CALLED: -! WETBULB -! -! -! INITIALIZE WEATHER TYPE ARRAY TO ZERO (IE, OFF). -! WE DO THIS SINCE WE WANT IWX TO REPRESENT THE -! INSTANTANEOUS WEATHER TYPE ON RETURN. -! -! -! ALLOCATE LOCAL STORAGE -! -! -!!$omp parallel do - IWX = 0 - -!!$omp parallel do -!!$omp& private(a,lmhk,pkl,psfck,qkl,tdchk,tdkl,tdpre,tkl) - - LMHK=LM -! -! SKIP THIS POINT IF NO PRECIP THIS TIME STEP -! - IF (PREC.LE.PTHRESH) GOTO 800 -! -! FIND COLDEST AND WARMEST TEMPS IN SATURATED LAYER BETWEEN -! 70 MB ABOVE GROUND AND 500 MB -! ALSO FIND HIGHEST SATURATED LAYER IN THAT RANGE -! -!meb - PSFCK=PINT(LP1) -!meb - TDCHK=2.0 - 760 TCOLD=T(LMHK) - TWARM=T(LMHK) - LICEE=LMHK -! - DO 775 L=1,LMHK - QKL=Q(L) - QKL=AMAX1(EPSQ,QKL) - TKL=T(L) - PKL=PMID(L) -! -! SKIP PAST THIS IF THE LAYER IS NOT BETWEEN 70 MB ABOVE GROUND -! AND 500 MB -! - IF (PKL.LT.50000.0.OR.PKL.GT.PSFCK-7000.0) GOTO 775 - A=ALOG(QKL*PKL/(6.1078*(0.378*QKL+0.622))) - TDKL=(237.3*A)/(17.269-A)+273.15 - TDPRE=TKL-TDKL - IF (TDPRE.LT.TDCHK.AND.TKL.LT.TCOLD) TCOLD=TKL - IF (TDPRE.LT.TDCHK.AND.TKL.GT.TWARM) TWARM=TKL - IF (TDPRE.LT.TDCHK.AND.L.LT.LICEE) LICEE=L - 775 CONTINUE -! -! IF NO SAT LAYER AT DEW POINT DEP=TDCHK, INCREASE TDCHK -! AND START AGAIN (BUT DON'T MAKE TDCHK > 6) -! - IF (TCOLD.EQ.T(LMHK).AND.TDCHK.LT.6.0) THEN - TDCHK=TDCHK+2.0 - GOTO 760 - ENDIF - 800 CONTINUE -! -! LOWEST LAYER T -! - KARR=0 - IF (PREC.LE.PTHRESH) GOTO 850 - LMHK=LM - TLMHK=T(LMHK) -! -! DECISION TREE TIME -! - IF (TCOLD.GT.269.15) THEN - IF (TLMHK.LE.273.15) THEN -! TURN ON THE FLAG FOR -! FREEZING RAIN = 4 -! IF ITS NOT ON ALREADY -! IZR=MOD(IWX,8)/4 -! IF (IZR.LT.1) IWX=IWX+4 - IWX=IWX+4 - GOTO 850 - ELSE -! TURN ON THE FLAG FOR -! RAIN = 8 -! IF ITS NOT ON ALREADY -! IRAIN=IWX/8 -! IF (IRAIN.LT.1) IWX=IWX+8 - IWX=IWX+8 - GOTO 850 - ENDIF - ENDIF - KARR=1 - 850 CONTINUE -! -!!$omp parallel do -!!$omp& private(area1,areap4,areap0,areas8,dzkl,ifrzl,iwrml,lice, -!!$omp& lmhk,pintk1,pintk2,pm150,psfck,surfc,surfw, -!!$omp& tlmhk,twrmk) - - IF(KARR.GT.0)THEN - LMHK=LM - LICE=LICEE -!meb - PSFCK=PINT(LP1) -!meb - TLMHK=T(LMHK) - TWRMK=TWARM -! -! TWET AREA VARIABLES -! CALCULATE ONLY WHAT IS NEEDED -! FROM GROUND TO 150 MB ABOVE SURFACE -! FROM GROUND TO TCOLD LAYER -! AND FROM GROUND TO 1ST LAYER WHERE WET BULB T < 0.0 -! -! PINTK1 IS THE PRESSURE AT THE BOTTOM OF THE LAYER -! PINTK2 IS THE PRESSURE AT THE TOP OF THE LAYER -! -! AREAP4 IS THE AREA OF TWET ABOVE -4 C BELOW HIGHEST SAT LYR -! AREAP0 IS THE AREA OF TWET ABOVE 0 C BELOW HIGHEST SAT LYR -! - AREAS8=D00 - AREAP4=D00 - AREAP0=D00 - SURFW =D00 - SURFC =D00 - -! - DO 1945 L=LMHK,LICE,-1 - DZKL=ZINT(L)-ZINT(L+1) - AREA1=(TWET(L)-269.15)*DZKL - AREA0=(TWET(L)-273.15)*DZKL - IF (TWET(L).GE.269.15) AREAP4=AREAP4+AREA1 - IF (TWET(L).GE.273.15) AREAP0=AREAP0+AREA0 - 1945 CONTINUE -! -! IF (AREAP4.LT.3000.0) THEN -! TURN ON THE FLAG FOR -! SNOW = 1 -! IF ITS NOT ON ALREADY -! ISNO=MOD(IWX,2) -! IF (ISNO.LT.1) IWX=IWX+1 -! IWX=IWX+1 -! GO TO 1900 -! ENDIF - IF (AREAP0.LT.350.0) THEN -! TURN ON THE FLAG FOR -! SNOW = 1 - IWX=IWX+1 - GOTO 1900 - ENDIF -! -! AREAS8 IS THE NET AREA OF TWET W.R.T. FREEZING IN LOWEST 150MB -! - PINTK1=PSFCK - PM150=PSFCK-15000. -! - DO 1955 L=LMHK,1,-1 - PINTK2=PINT(L) - IF(PINTK1.LT.PM150)GO TO 1950 - DZKL=ZINT(L)-ZINT(L+1) -! -! SUM PARTIAL LAYER IF IN 150 MB AGL LAYER -! - IF(PINTK2.LT.PM150) - & DZKL=T(L)*(Q(L)*D608+1.0)*ROG* - & ALOG(PINTK1/PM150) - AREA1=(TWET(L)-273.15)*DZKL - AREAS8=AREAS8+AREA1 - 1950 PINTK1=PINTK2 - 1955 CONTINUE -! -! SURFW IS THE AREA OF TWET ABOVE FREEZING BETWEEN THE GROUND -! AND THE FIRST LAYER ABOVE GROUND BELOW FREEZING -! SURFC IS THE AREA OF TWET BELOW FREEZING BETWEEN THE GROUND -! AND THE WARMEST SAT LAYER -! - IFRZL=0 - IWRML=0 -! - DO 2050 L=LMHK,1,-1 - IF (IFRZL.EQ.0.AND.T(L).LT.273.15) IFRZL=1 - IF (IWRML.EQ.0.AND.T(L).GE.TWRMK) IWRML=1 -! - IF (IWRML.EQ.0.OR.IFRZL.EQ.0) THEN -! if(pmid(l) .lt. 50000.)print*,'twet needed above 500mb' - DZKL=ZINT(L)-ZINT(L+1) - AREA1=(TWET(L)-273.15)*DZKL - IF(IFRZL.EQ.0.AND.TWET(L).GE.273.15)SURFW=SURFW+AREA1 - IF(IWRML.EQ.0.AND.TWET(L).LE.273.15)SURFC=SURFC+AREA1 - ENDIF - 2050 CONTINUE - IF(SURFC.LT.-3000.0.OR. - & (AREAS8.LT.-3000.0.AND.SURFW.LT.50.0)) THEN -! TURN ON THE FLAG FOR -! ICE PELLETS = 2 -! IF ITS NOT ON ALREADY -! IIP=MOD(IWX,4)/2 -! IF (IIP.LT.1) IWX=IWX+2 - IWX=IWX+2 - GOTO 1900 - ENDIF -! - IF(TLMHK.LT.273.15) THEN -! TURN ON THE FLAG FOR -! FREEZING RAIN = 4 -! IF ITS NOT ON ALREADY -! IZR=MOD(IWX(K),8)/4 -! IF (IZR.LT.1) IWX(K)=IWX(K)+4 - IWX=IWX+4 - ELSE -! TURN ON THE FLAG FOR -! RAIN = 8 -! IF ITS NOT ON ALREADY -! IRAIN=IWX(K)/8 -! IF (IRAIN.LT.1) IWX(K)=IWX(K)+8 - IWX=IWX+8 - ENDIF - ENDIF - 1900 CONTINUE -! print *, 'revised check ', IWX(500,800) - - RETURN - END -! -! - SUBROUTINE CALWXT_EXPLICIT(LM,PTHRESH,TSKIN,PREC,SR,F_RIMEF,IWX) -! -! FILE: CALWXT.f -! WRITTEN: 24 AUGUST 2005, G MANIKIN and B FERRIER -! -! ROUTINE TO COMPUTE PRECIPITATION TYPE USING EXPLICIT FIELDS -! FROM THE MODEL MICROPHYSICS - -! use params_mod -! use ctlblk_mod -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none -! -! LIST OF VARIABLES NEEDED -! PARAMETERS: -! -! INPUT: - integer, intent(in):: lm - real,intent(in):: TSKIN, PREC, SR,PTHRESH - REAL,intent(in):: F_RimeF(LM) - integer,intent(out) :: IWX - integer I,J,LMHK - real PSFC,SNOW -! -! ALLOCATE LOCAL STORAGE -! -!!$omp parallel do - IWX = 0 - -!GSM THE RSM IS CURRENTLY INCOMPATIBLE WITH THIS ROUTINE -!GSM ACCORDING TO B FERRIER, THERE MAY BE A WAY TO WRITE -!GSM A VERSION OF THIS ALGORITHM TO WORK WITH THE RSM -!GSM MICROPHYSICS, BUT IT DOESN'T EXIST AT THIS TIME -!!$omp parallel do -!!$omp& private(lmhk,psfc,tskin) - -! SKIP THIS POINT IF NO PRECIP THIS TIME STEP -! - IF (PREC.LE.PTHRESH) GOTO 800 -! -! A SNOW RATIO LESS THAN 0.5 ELIMINATES SNOW AND SLEET -! USE THE SKIN TEMPERATURE TO DISTINGUISH RAIN FROM FREEZING RAIN -! NOTE THAT 2-M TEMPERATURE MAY BE A BETTER CHOICE IF THE MODEL -! HAS A COLD BIAS FOR SKIN TEMPERATURE -! - IF (SR.LT.0.5) THEN -! SURFACE (SKIN) POTENTIAL TEMPERATURE AND TEMPERATURE. -! PSFC=PMID(LM) -! TSKIN=THS*(PSFC/P1000)**CAPA - - IF (TSKIN.LT.273.15) THEN -! FREEZING RAIN = 4 - IWX=IWX+4 - ELSE -! RAIN = 8 - IWX=IWX+8 - ENDIF - ELSE -! -! DISTINGUISH SNOW FROM SLEET WITH THE RIME FACTOR -! - IF(F_RimeF(LM).GE.10) THEN -! SLEET = 2 - IWX=IWX+2 - ELSE - SNOW = 1 - IWX=IWX+1 - ENDIF - ENDIF - 800 CONTINUE - 810 RETURN - END -! -! - SUBROUTINE CALWXT_DOMINANT(NALG,PREC,PTHRESH,RAIN,FREEZR, - & SLEET,SNOW,DOMR,DOMZR,DOMIP,DOMS) -! -! WRITTEN: 24 AUGUST 2005, G MANIKIN -! -! THIS ROUTINE TAKES THE PRECIP TYPE SOLUTIONS FROM DIFFERENT -! ALGORITHMS AND SUMS THEM UP TO GIVE A DOMINANT TYPE -! -! use params_mod -! use ctlblk_mod -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none -! -! INPUT: - integer,intent(in) :: NALG - REAL, intent(in) :: PREC,PTHRESH - real,intent(out) :: DOMS,DOMR,DOMZR,DOMIP - real,DIMENSION(NALG),intent(in) :: RAIN,SNOW,SLEET,FREEZR - integer I,J,L - real TOTSN,TOTIP,TOTR,TOTZR -!-------------------------------------------------------------------------- -! print* , 'into dominant' -!!$omp parallel do - DOMR = 0. - DOMS = 0. - DOMZR = 0. - DOMIP = 0. -! -!!$omp parallel do -!!$omp& private(totsn,totip,totr,totzr) -! SKIP THIS POINT IF NO PRECIP THIS TIME STEP - IF (PREC.LE.PTHRESH) GOTO 800 - TOTSN = 0 - TOTIP = 0 - TOTR = 0 - TOTZR = 0 -! LOOP OVER THE NUMBER OF DIFFERENT ALGORITHMS THAT ARE USED - DO 820 L = 1, NALG - IF (RAIN(L).GT. 0) THEN - TOTR = TOTR + 1 - GOTO 830 - ENDIF - - IF (SNOW(L).GT. 0) THEN - TOTSN = TOTSN + 1 - GOTO 830 - ENDIF - - IF (SLEET(L).GT. 0) THEN - TOTIP = TOTIP + 1 - GOTO 830 - ENDIF - - IF (FREEZR(L).GT. 0) THEN - TOTZR = TOTZR + 1 - GOTO 830 - ENDIF - 830 CONTINUE - 820 CONTINUE - -! TIES ARE BROKEN TO FAVOR THE MOST DANGEROUS FORM OF PRECIP -! FREEZING RAIN > SNOW > SLEET > RAIN - IF (TOTSN .GT. TOTIP) THEN - IF (TOTSN .GT. TOTZR) THEN - IF (TOTSN .GE. TOTR) THEN - DOMS = 1 - GOTO 800 - ELSE - DOMR = 1 - GOTO 800 - ENDIF - ELSE IF (TOTZR .GE. TOTR) THEN - DOMZR = 1 - GOTO 800 - ELSE - DOMR = 1 - GOTO 800 - ENDIF - ELSE IF (TOTIP .GT. TOTZR) THEN - IF (TOTIP .GE. TOTR) THEN - DOMIP = 1 - GOTO 800 - ELSE - DOMR = 1 - GOTO 800 - ENDIF - ELSE IF (TOTZR .GE. TOTR) THEN - DOMZR = 1 - GOTO 800 - ELSE - DOMR = 1 - GOTO 800 - ENDIF - 800 CONTINUE - RETURN - END - - - - - diff --git a/src/fim/FIMsrc/fim/column/cnvcld_v.f b/src/fim/FIMsrc/fim/column/cnvcld_v.f deleted file mode 100644 index 82e7555..0000000 --- a/src/fim/FIMsrc/fim/column/cnvcld_v.f +++ /dev/null @@ -1,90 +0,0 @@ - SUBROUTINE CNVC90(CLSTP,IM,IX,RN,KBOT,KTOP,KM,PRSI, - 1 ACV,ACVB,ACVT,CV,CVB,CVT) -cc - USE MACHINE, ONLY :kind_phys - implicit none - integer i,ibot,im,itop,km,lc,lz,n,ncc,ix - real(kind=kind_phys) ah,cc1,cc2,clstp,cvb0,p1,p2,rkbot,rktop,val -cc - integer KBOT(IM),KTOP(IM) - real(kind=kind_phys) RN(IM), ACV(IM), ACVB(IM), ACVT(IM), - & CV(IM), CVB(IM), CVT(IM) - real(kind=kind_phys) prsi(ix,km+1) - integer NMD(IM) - real(kind=kind_phys) PMD(IM) -! - real (kind=kind_phys), parameter :: cons_100=100.0 - real(kind=kind_phys) R_KBOT_I, R_KTOP_I -! - PARAMETER(NCC=9) - real(kind=kind_phys) CC(NCC),P(NCC) - DATA CC/0.,0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8/ - DATA P/.14,.31,.70,1.6,3.4,7.7,17.,38.,85./ - DATA CVB0/100./ -! - LZ=0 - LC=0 - IF(CLSTP.GE.1000.) LZ=1 - IF(CLSTP.GE.1100..OR.(CLSTP.LT.1000..AND.CLSTP.GE.100.)) LC=1 - AH=MOD(CLSTP,cons_100) - IF(LZ.NE.0) THEN - DO I=1,IM - ACV(I) = 0. - ACVB(I) = CVB0 - ACVT(I) = 0. - ENDDO - ENDIF - IF(LC.NE.0) THEN - DO I=1,IM - IF(RN(I).GT.0.) THEN - ACV(I) = ACV(I)+RN(I) - R_KBOT_I= KBOT(I) - ACVB(I) = MIN(ACVB(I),R_KBOT_I) - R_KTOP_I= KTOP(I) - ACVT(I) = MAX(ACVT(I),R_KTOP_I) - ENDIF - ENDDO - ENDIF - IF(AH.GT.0.01.AND.AH.LT.99.99) THEN - DO I=1,IM - IF(ACV(I).GT.0.) THEN -! CVB(I) = ACVB(I) -! CVT(I) = ACVT(I) -c.... convert cvt and cvb to pressures - ITOP = NINT(ACVT(I)) - CVT(I) = PRSI(i,ITOP+1) - IBOT = NINT(ACVB(I)) - CVB(I) = PRSI(i,IBOT) - ELSE -! CVB(I) = CVB0 - CVB(I) = 0. - CVT(I) = 0. - ENDIF - PMD(I) = ACV(I)*(24.E+3/AH) - NMD(I) = 0 - ENDDO - DO N=1,NCC - DO I=1,IM - IF(PMD(I).GT.P(N)) NMD(I) = N - ENDDO - ENDDO - DO I=1,IM - IF(NMD(I).EQ.0) THEN - CV(I) = 0. -! CVB(I) = CVB0 - CVB(I) = 0. - CVT(I) = 0. - ELSEIF(NMD(I).EQ.NCC) THEN - CV(I) = CC(NCC) - ELSE - CC1 = CC(NMD(I)) - CC2 = CC(NMD(I)+1) - P1 = P(NMD(I)) - P2 = P(NMD(I)+1) - CV(I) = CC1 + (CC2-CC1)*(PMD(I)-P1)/(P2-P1) - ENDIF - ENDDO - ENDIF - RETURN - END - diff --git a/src/fim/FIMsrc/fim/column/co2tab_sw.h b/src/fim/FIMsrc/fim/column/co2tab_sw.h deleted file mode 100755 index 843aa65..0000000 --- a/src/fim/FIMsrc/fim/column/co2tab_sw.h +++ /dev/null @@ -1,1303 +0,0 @@ - integer nu, nw, nx, ny - PARAMETER (NU=43, NW=37, NX=62, NY=101) - real (kind=kind_phys) CAH(NU,NW), COA(NX,NY) -C ... CO2 LOOK-UP TABLE FOR 1.220-2.270 MICRON BAND ............. - DATA (CAH(I,1),I=1,43) / 3*1.0E-7, 2*2.0E-7, 3.0E-7, 5.0E-7, - 1 7.0E-7, 9.0E-7, 1.3E-6, 1.9E-6, 2.6E-6, 3.7E-6, 5.3E-6, 7.4E-6, - 2 .0000104,.0000147,.0000206,.0000288,.0000402,.0000559,.0000772, - 3 .0001059,.0001439,.0001936,.0002575,.0003384,.0004400,.0005662, - 4 .0007219,.0009131,.0011470,.0014327,.0017806,.0022021,.0027093, - 5 .0033141,.0040280,.0048609,.0058217,.0069177,.0081559,.0095430 / - DATA (CAH(I,2),I=1,43) / 3*1.0E-7, 2*2.0E-7, 3.0E-7, 5.0E-7, - 1 7.0E-7, 9.0E-7, 1.3E-6, 1.9E-6, 2.6E-6, 3.7E-6, 5.3E-6, 7.4E-6, - 2 .0000104,.0000147,.0000206,.0000288,.0000402,.0000559,.0000772, - 3 .0001059,.0001439,.0001936,.0002575,.0003384,.0004400,.0005662, - 4 .0007219,.0009130,.0011470,.0014326,.0017805,.0022020,.0027091, - 5 .0033139,.0040276,.0048605,.0058211,.0069170,.0081551,.0095420 / - DATA (CAH(I,3),I=1,43) / 3*1.0E-7, 2*2.0E-7, 3.0E-7, 5.0E-7, - 1 7.0E-7, 9.0E-7, 1.3E-6, 1.9E-6, 2.6E-6, 3.7E-6, 5.3E-6, 7.4E-6, - 2 .0000104,.0000147,.0000206,.0000288,.0000402,.0000559,.0000772, - 3 .0001059,.0001439,.0001936,.0002574,.0003384,.0004399,.0005661, - 4 .0007218,.0009129,.0011468,.0014325,.0017803,.0022017,.0027088, - 5 .0033135,.0040271,.0048599,.0058204,.0069161,.0081539,.0095406 / - DATA (CAH(I,4),I=1,43) / 3*1.0E-7, 2*2.0E-7, 3.0E-7, 5.0E-7, - 1 7.0E-7, 9.0E-7, 1.3E-6, 1.9E-6, 2.6E-6, 3.7E-6, 5.3E-6, 7.4E-6, - 2 .0000104,.0000147,.0000206,.0000288,.0000402,.0000559,.0000772, - 3 .0001059,.0001439,.0001936,.0002574,.0003384,.0004399,.0005661, - 4 .0007217,.0009128,.0011467,.0014323,.0017800,.0022014,.0027084, - 5 .0033130,.0040265,.0048591,.0058194,.0069148,.0081524,.0095387 / - DATA (CAH(I,5),I=1,43) / 3*1.0E-7, 2*2.0E-7, 3.0E-7, 5.0E-7, - 1 7.0E-7, 9.0E-7, 1.3E-6, 1.9E-6, 2.6E-6, 3.7E-6, 5.3E-6, 7.4E-6, - 2 .0000104,.0000147,.0000206,.0000288,.0000402,.0000559,.0000772, - 3 .0001059,.0001439,.0001935,.0002574,.0003383,.0004398,.0005660, - 4 .0007216,.0009127,.0011465,.0014320,.0017797,.0022010,.0027078, - 5 .0033123,.0040256,.0048580,.0058180,.0069132,.0081503,.0095361 / - DATA (CAH(I,6),I=1,43) / 3*1.0E-7, 2*2.0E-7, 3.0E-7, 5.0E-7, - 1 7.0E-7, 9.0E-7, 1.3E-6, 1.9E-6, 2.6E-6, 3.7E-6, 5.3E-6, 7.4E-6, - 2 .0000104,.0000147,.0000206,.0000288,.0000402,.0000559,.0000772, - 3 .0001059,.0001439,.0001935,.0002573,.0003383,.0004398,.0005659, - 4 .0007215,.0009125,.0011462,.0014317,.0017792,.0022004,.0027071, - 5 .0033113,.0040244,.0048565,.0058162,.0069109,.0081476,.0095328 / - DATA (CAH(I,7),I=1,43) / 3*1.0E-7, 2*2.0E-7, 3.0E-7, 5.0E-7, - 1 7.0E-7, 9.0E-7, 1.3E-6, 1.9E-6, 2.6E-6, 3.7E-6, 5.3E-6, 7.4E-6, - 2 .0000104,.0000147,.0000206,.0000288,.0000402,.0000559,.0000772, - 3 .0001058,.0001438,.0001935,.0002573,.0003382,.0004396,.0005657, - 4 .0007213,.0009122,.0011459,.0014312,.0017786,.0021996,.0027061, - 5 .0033100,.0040228,.0048545,.0058137,.0069079,.0081439,.0095283 / - DATA (CAH(I,8),I=1,43) / 3*1.0E-7, 2*2.0E-7, 3.0E-7, 5.0E-7, - 1 7.0E-7, 9.0E-7, 1.3E-6, 1.9E-6, 2.6E-6, 3.7E-6, 5.2E-6, 7.4E-6, - 2 .0000104,.0000146,.0000206,.0000288,.0000402,.0000558,.0000772, - 3 .0001058,.0001438,.0001934,.0002572,.0003381,.0004395,.0005655, - 4 .0007210,.0009119,.0011454,.0014306,.0017778,.0021985,.0027047, - 5 .0033084,.0040207,.0048519,.0058105,.0069040,.0081391,.0095225 / - DATA (CAH(I,9),I=1,43) / 3*1.0E-7, 2*2.0E-7, 3.0E-7, 5.0E-7, - 1 7.0E-7, 9.0E-7, 1.3E-6, 1.9E-6, 2.6E-6, 3.7E-6, 5.2E-6, 7.4E-6, - 2 .0000104,.0000146,.0000206,.0000288,.0000402,.0000558,.0000771, - 3 .0001058,.0001437,.0001933,.0002571,.0003379,.0004393,.0005652, - 4 .0007206,.0009114,.0011447,.0014297,.0017767,.0021971,.0027030, - 5 .0033061,.0040180,.0048485,.0058064,.0068989,.0081329,.0095149 / - DATA (CAH(I,10),I=1,43) / 3*1.0E-7, 2*2.0E-7, 3.0E-7, 5.0E-7, - 1 7.0E-7, 9.0E-7, 1.3E-6, 1.9E-6, 2.6E-6, 3.7E-6, 5.2E-6, 7.4E-6, - 2 .0000104,.0000146,.0000205,.0000288,.0000402,.0000558,.0000771, - 3 .0001057,.0001437,.0001932,.0002569,.0003377,.0004390,.0005649, - 4 .0007201,.0009107,.0011439,.0014286,.0017753,.0021953,.0027006, - 5 .0033032,.0040144,.0048441,.0058009,.0068922,.0081248,.0095051 / - DATA (CAH(I,11),I=1,43) / 3*1.0E-7, 2*2.0E-7, 3.0E-7, 5.0E-7, - 1 7.0E-7, 9.0E-7, 1.3E-6, 1.9E-6, 2.6E-6, 3.7E-6, 5.2E-6, 7.4E-6, - 2 .0000104,.0000146,.0000205,.0000287,.0000401,.0000558,.0000770, - 3 .0001056,.0001436,.0001931,.0002567,.0003375,.0004387,.0005644, - 4 .0007195,.0009098,.0011428,.0014271,.0017734,.0021929,.0026976, - 5 .0032995,.0040097,.0048384,.0057939,.0068837,.0081145,.0094926 / - DATA (CAH(I,12),I=1,43) / 3*1.0E-7, 2*2.0E-7, 3.0E-7, 5.0E-7, - 1 7.0E-7, 9.0E-7, 1.3E-6, 1.9E-6, 2.6E-6, 3.7E-6, 5.2E-6, 7.4E-6, - 2 .0000104,.0000146,.0000205,.0000287,.0000401,.0000557,.0000770, - 3 .0001055,.0001434,.0001929,.0002565,.0003371,.0004382,.0005637, - 4 .0007186,.0009087,.0011413,.0014252,.0017709,.0021898,.0026937, - 5 .0032946,.0040038,.0048311,.0057850,.0068729,.0081013,.0094768 / - DATA (CAH(I,13),I=1,43) / 3*1.0E-7, 2*2.0E-7, 3.0E-7, 5.0E-7, - 1 7.0E-7, 9.0E-7, 1.3E-6, 1.9E-6, 2.6E-6, 3.7E-6, 5.2E-6, 7.4E-6, - 2 .0000104,.0000146,.0000205,.0000287,.0000400,.0000556,.0000769, - 3 .0001054,.0001432,.0001926,.0002561,.0003366,.0004376,.0005629, - 4 .0007175,.0009073,.0011394,.0014228,.0017678,.0021859,.0026888, - 5 .0032885,.0039963,.0048218,.0057738,.0068592,.0080849,.0094570 / - DATA (CAH(I,14),I=1,43) / 3*1.0E-7, 2*2.0E-7, 3.0E-7, 5.0E-7, - 1 7.0E-7, 9.0E-7, 1.3E-6, 1.9E-6, 2.6E-6, 3.7E-6, 5.2E-6, 7.4E-6, - 2 .0000104,.0000146,.0000205,.0000286,.0000400,.0000556,.0000767, - 3 .0001052,.0001430,.0001923,.0002557,.0003361,.0004368,.0005619, - 4 .0007161,.0009054,.0011370,.0014197,.0017639,.0021809,.0026826, - 5 .0032809,.0039869,.0048103,.0057597,.0068422,.0080643,.0094323 / - DATA (CAH(I,15),I=1,43) / 3*1.0E-7, 2*2.0E-7, 3.0E-7, 5.0E-7, - 1 7.0E-7, 9.0E-7, 1.3E-6, 1.9E-6, 2.6E-6, 3.7E-6, 5.2E-6, 7.3E-6, - 2 .0000103,.0000145,.0000204,.0000286,.0000399,.0000554,.0000766, - 3 .0001050,.0001427,.0001919,.0002552,.0003353,.0004358,.0005605, - 4 .0007144,.0009032,.0011340,.0014159,.0017590,.0021748,.0026750, - 5 .0032715,.0039752,.0047961,.0057424,.0068212,.0080389,.0094019 / - DATA (CAH(I,16),I=1,43) / 3*1.0E-7, 2*2.0E-7, 3.0E-7, 5.0E-7, - 1 7.0E-7, 9.0E-7, 1.3E-6, 1.9E-6, 2.6E-6, 3.7E-6, 5.2E-6, 7.3E-6, - 2 .0000103,.0000145,.0000204,.0000285,.0000398,.0000553,.0000764, - 3 .0001047,.0001423,.0001914,.0002545,.0003344,.0004345,.0005589, - 4 .0007122,.0009003,.0011304,.0014112,.0017531,.0021673,.0026656, - 5 .0032598,.0039609,.0047786,.0057211,.0067954,.0080078,.0093646 / - DATA (CAH(I,17),I=1,43) / 3*1.0E-7, 2*2.0E-7, 3.0E-7, 5.0E-7, - 1 7.0E-7, 9.0E-7, 1.3E-6, 1.8E-6, 2.6E-6, 3.7E-6, 5.2E-6, 7.3E-6, - 2 .0000103,.0000145,.0000203,.0000284,.0000397,.0000551,.0000761, - 3 .0001044,.0001419,.0001908,.0002536,.0003332,.0004330,.0005568, - 4 .0007095,.0008968,.0011259,.0014054,.0017458,.0021123,.0026542, - 5 .0032457,.0039435,.0047573,.0056951,.0067640,.0079700,.0093194 / - DATA (CAH(I,18),I=1,43) / 3*1.0E-7, 2*2.0E-7, 3.0E-7, 5.0E-7, - 1 7.0E-7, 9.0E-7, 1.3E-6, 1.8E-6, 2.6E-6, 3.7E-6, 5.2E-6, 7.3E-6, - 2 .0000102,.0000144,.0000202,.0000283,.0000395,.0000549,.0000758, - 3 .0001040,.0001413,.0001900,.0002525,.0003318,.0004311,.0005543, - 4 .0007063,.0008926,.0011204,.0013985,.0017370,.0021470,.0026404, - 5 .0032285,.0039224,.0047315,.0056637,.0067260,.0079245,.0092651 / - DATA (CAH(I,19),I=1,43) / 3*1.0E-7, 2*2.0E-7, 3.0E-7, 5.0E-7, - 1 6.0E-7, 9.0E-7, 1.3E-6, 1.8E-6, 2.6E-6, 3.6E-6, 5.1E-6, 7.2E-6, - 2 .0000102,.0000143,.0000201,.0000282,.0000393,.0000546,.0000754, - 3 .0001034,.0001406,.0001890,.0002512,.0003300,.0004287,.0005513, - 4 .0007023,.0008875,.0011139,.0013901,.0017264,.0021337,.0026238, - 5 .0032080,.0038971,.0047005,.0056261,.0066806,.0078701,.0092003 / - DATA (CAH(I,20),I=1,43) / 3*1.0E-7, 2*2.0E-7, 3.0E-7, 5.0E-7, - 1 6.0E-7, 9.0E-7, 1.3E-6, 1.8E-6, 2.6E-6, 3.6E-6, 5.1E-6, 7.2E-6, - 2 .0000101,.0000142,.0000200,.0000280,.0000391,.0000543,.0000750, - 3 .0001028,.0001397,.0001878,.0002496,.0003279,.0004259,.0005476, - 4 .0006975,.0008813,.0011060,.0013802,.0017138,.0021179,.0026040, - 5 .0031835,.0038670,.0046637,.0055814,.0066267,.0078055,.0091235 / - DATA (CAH(I,21),I=1,43) / 3*1.0E-7, 2*2.0E-7, 3.0E-7, 5.0E-7, - 1 6.0E-7, 9.0E-7, 1.3E-6, 1.8E-6, 2.5E-6, 3.6E-6, 5.1E-6, 7.1E-6, - 2 .0000100,.0000141,.0000198,.0000278,.0000388,.0000539,.0000744, - 3 .0001020,.0001386,.0001863,.0002477,.0003253,.0004226,.0005432, - 4 .0006918,.0008740,.0010966,.0013683,.0016988,.0020991,.0025806, - 5 .0031545,.0038313,.0046201,.0055285,.0065630,.0077294,.0090332 / - DATA (CAH(I,22),I=1,43) / 3*1.0E-7, 2*2.0E-7, 3.0E-7, 4.0E-7, - 1 6.0E-7, 9.0E-7, 1.3E-6, 1.8E-6, 2.5E-6, 3.6E-6, 5.0E-6, 7.1E-6, - 2 .0000100,.0000140,.0000197,.0000275,.0000384,.0000534,.0000737, - 3 .0001011,.0001373,.0001846,.0002453,.0003222,.0004185,.0005265, - 4 .0006850,.0008652,.0010855,.0013541,.0016809,.0020768,.0025528, - 5 .0031202,.0037892,.0045688,.0054664,.0064883,.0076402,.0089277 / - DATA (CAH(I,23),I=1,43) / 3*1.0E-7, 2*2.0E-7, 3.0E-7, 4.0E-7, - 1 6.0E-7, 9.0E-7, 1.3E-6, 1.8E-6, 2.5E-6, 3.5E-6, 5.0E-6, 7.0E-6, - 2 .0000098,.0000138,.0000194,.0000272,.0000380,.0000528,.0000729, - 3 .0000999,.0001357,.0001825,.0002425,.0003185,.0004137,.0005316, - 4 .0006769,.0008548,.0010722,.0013373,.0016599,.0020504,.0025201, - 5 .0030799,.0037398,.0045087,.0053938,.0064013,.0075366,.0088053 / - DATA (CAH(I,24),I=1,43) / 3*1.0E-7, 2*2.0E-7, 3.0E-7, 4.0E-7, - 1 6.0E-7, 9.0E-7, 1.2E-6, 1.7E-6, 2.5E-6, 3.5E-6, 4.9E-6, 6.9E-6, - 2 .0000097,.0000137,.0000192,.0000268,.0000375,.0000520,.0000719, - 3 .0000986,.0001339,.0001800,.0002392,.0003142,.0004079,.0005242, - 4 .0006673,.0008426,.0010567,.0013177,.0016352,.0020196,.0024820, - 5 .0030330,.0036825,.0044391,.0053098,.0063007,.0074172,.0084815 / - DATA (CAH(I,25),I=1,43) / 3*1.0E-7, 2*2.0E-7, 3.0E-7, 4.0E-7, - 1 6.0E-7, 9.0E-7, 1.2E-6, 1.7E-6, 2.4E-6, 3.4E-6, 4.8E-6, 6.8E-6, - 2 .0000096,.0000134,.0000189,.0000264,.0000369,.0000512,.0000708, - 3 .0000970,.0001318,.0001772,.0002354,.0003091,.0004013,.0005156, - 4 .0006562,.0008284,.0010386,.0012949,.0016066,.0019840,.0024379, - 5 .0029788,.0036164,.0043590,.0052135,.0061857,.0072808,.0085042 / - DATA (CAH(I,26),I=1,43) / 3*1.0E-7, 2*2.0E-7, 3.0E-7, 4.0E-7, - 1 6.0E-7, 8.0E-7, 1.2E-6, 1.7E-6, 2.4E-6, 3.4E-6, 4.7E-6, 6.7E-6, - 2 .0000094,.0000132,.0000185,.0000259,.0000362,.0000503,.0000695, - 3 .0000952,.0001294,.0001739,.0002310,.0003033,.0003937,.0005057, - 4 .0006435,.0008121,.0010180,.0012688,.0015739,.0019434,.0023877, - 5 .0029172,.0035413,.0042681,.0051043,.0060554,.0071267,.0083234 / - DATA (CAH(I,27),I=1,43) / 4*1.0E-7, 2.0E-7, 3.0E-7, 4.0E-7, - 1 6.0E-7, 8.0E-7, 1.2E-6, 1.6E-6, 2.3E-6, 3.3E-6, 4.6E-6, 6.5E-6, - 2 .0000092,.0000129,.0000181,.0000254,.0000355,.0000493,.0000680, - 3 .0000933,.0001267,.0001702,.0002261,.0002968,.0003852,.0004946, - 4 .0006291,.0007937,.0009946,.0012394,.0015370,.0018975,.0023310, - 5 .0028478,.0034568,.0041660,.0049818,.0059096,.0069544,.0081215 / - DATA (CAH(I,28),I=1,43) / 4*1.0E-7, 2.0E-7, 3.0E-7, 4.0E-7, - 1 6.0E-7, 8.0E-7, 1.1E-6, 1.6E-6, 2.3E-6, 3.2E-6, 4.5E-6, 6.4E-6, - 2 .0000090,.0000126,.0000177,.0000248,.0000346,.0000481,.0000664, - 3 .0000910,.0001236,.0001661,.0002206,.0002895,.0003755,.0004821, - 4 .0006130,.0007731,.0009685,.0012065,.0014959,.0018463,.0022680, - 5 .0027705,.0033629,.0040526,.0048459,.0057480,.0067639,.0078987 / - DATA (CAH(I,29),I=1,43) / 0.E0,3*1.0E-7,2.0E-7, 3.0E-7, 4.0E-7, - 1 6.0E-7, 8.0E-7, 1.1E-6, 1.6E-6, 2.2E-6, 3.1E-6, 4.4E-6, 6.2E-6, - 2 .0000087,.0000123,.0000173,.0000242,.0000330,.0000468,.0000646, - 3 .0000886,.0001203,.0001616,.0002145,.0002814,.0003649,.0004682, - 4 .0005951,.0007503,.0009396,.0011701,.0014505,.0017900,.0021986, - 5 .0026857,.0032598,.0039283,.0046971,.0055713,.0065558,.0076557 / - DATA (CAH(I,30),I=1,43) / 0.E0,3*1.0E-7,2.0E-7, 3.0E-7, 4.0E-7, - 1 5.0E-7, 8.0E-7, 1.1E-6, 1.5E-6, 2.1E-6, 3.0E-6, 4.3E-6, 6.0E-6, - 2 .0000085,.0000119,.0000167,.0000234,.0000327,.0000454,.0000627, - 3 .0000859,.0001166,.0001566,.0002078,.0002724,.0003531,.0004529, - 4 .0005755,.0007253,.0009079,.0011304,.0014010,.0017287,.0021232, - 5 .0025935,.0031480,.0037936,.0045361,.0053805,.0063314,.0073941 / - DATA (CAH(I,31),I=1,43) / 0.E0,3*1.0E-7,2.0E-7, 3.0E-7, 4.0E-7, - 1 5.0E-7, 7.0E-7, 1.0E-6, 1.5E-6, 2.1E-6, 2.9E-6, 4.1E-6, 5.8E-6, - 2 .0000082,.0000115,.0000162,.0000226,.0000316,.0000438,.0000605, - 3 .0000829,.0001125,.0001510,.0002004,.0002626,.0003402,.0004362, - 4 .0005540,.0006980,.0008736,.0010874,.0013476,.0016627,.0020421, - 5 .0024947,.0030283,.0036497,.0043644,.0051772,.0060928,.0071164 / - DATA (CAH(I,32),I=1,43) / 0.E0,3*1.0E-7,2.0E-7, 3.0E-7, 4.0E-7, - 1 5.0E-7, 7.0E-7, 1.0E-6, 1.4E-6, 2.0E-6, 2.8E-6, 4.0E-6, 5.6E-6, - 2 .0000079,.0000111,.0000155,.0000218,.0000303,.0000421,.0000582, - 3 .0000797,.0001081,.0001450,.0001923,.0002519,.0003262,.0004180, - 4 .0005308,.0006686,.0008367,.0010414,.0012905,.0015925,.0019561, - 5 .0023900,.0029017,.0034978,.0041836,.0049638,.0058430,.0068264 / - DATA (CAH(I,33),I=1,43) / 0.E0,3*1.0E-7,2.0E-7, 2.0E-7, 3.0E-7, - 1 5.0E-7, 7.0E-7, 1.0E-6, 1.4E-6, 1.9E-6, 2.7E-6, 3.8E-6, 5.3E-6, - 2 .0000075,.0000106,.0000149,.0000208,.0000290,.0000403,.0000556, - 3 .0000761,.0001032,.0001384,.0001834,.0002402,.0003110,.0003985, - 4 .0005059,.0006372,.0007974,.0009926,.0012302,.0015185,.0018657, - 5 .0022803,.0027696,.0033398,.0039960,.0047430,.0055851,.0065278 / - DATA (CAH(I,34),I=1,43) / 0.E0,3*1.0E-7,2.0E-7, 2.0E-7, 3.0E-7, - 1 5.0E-7, 6.0E-7, 9.0E-7, 1.3E-6, 1.8E-6, 2.6E-6, 3.6E-6, 5.1E-6, - 2 .0000071,.0000100,.0000141,.0000197,.0000275,.0000382,.0000527, - 3 .0000722,.0000979,.0001312,.0001739,.0002277,.0002947,.0003775, - 4 .0004793,.0006038,.0007558,.0009412,.0011671,.0014412,.0017717, - 5 .0021208,.0026329,.0031768,.0038033,.0045168,.0053220,.0062240 / - DATA (CAH(I,35),I=1,43) / 0.E0,3*1.0E-7,2.0E-7, 2.0E-7, 3.0E-7, - 1 4.0E-7, 6.0E-7, 9.0E-7, 1.2E-6, 1.7E-6, 2.4E-6, 3.4E-6, 4.8E-6, - 2 .0000067,.0000095,.0000133,.0000186,.0000259,.0000360,.0000496, - 3 .0000679,.0000921,.0001235,.0001637,.0002143,.0002773,.0003554, - 4 .0004513,.0005688,.0007124,.0008876,.0011014,.0013610,.0016745, - 5 .0020493,.0024925,.0030099,.0036066,.0042868,.0050553,.0059171 / - DATA (CAH(I,36),I=1,43) / 0.0E0, 4*1.0E-7, 2.0E-7, 3.0E-7, - 1 4.0E-7, 6.0E-7, 8.0E-7, 1.1E-6, 1.6E-6, 2.2E-6, 3.2E-6, 4.5E-6, - 2 .0000063,.0000088,.0000124,.0000173,.0000242,.0000336,.0000463, - 3 .0000634,.0000860,.0001153,.0001528,.0002001,.0002591,.0003322, - 4 .0004221,.0005323,.0006672,.0008322,.0010335,.0012785,.0015746, - 5 .0019293,.0023491,.0028399,.0034067,.0040539,.0047860,.0056083 / - DATA (CAH(I,37),I=1,43) / 2*0.0E0, 3*1.0E-7, 2.0E-7, 3.0E-7, - 1 4.0E-7, 5.0E-7, 7.0E-7, 1.0E-6, 1.5E-6, 2.1E-6, 2.9E-6, 4.1E-6, - 2 .0000058,.0000082,.0000114,.0000160,.0000223,.0000310,.0000428, - 3 .0000586,.0000795,.0001067,.0001414,.0001853,.0002401,.0003081, - 4 .0003918,.0004947,.0006208,.0007751,.0009639,.0011940,.0014726, - 5 .0018069,.0022032,.0026674,.0032043,.0038186,.0045147,.0052979 / -C ... CO2 LOOK-UP TABLE FOR 2.270-10.00 MICRON BAND ............. - DATA (COA(I,1),I=1,62) / - 1 0.80E-5,0.89E-5,0.98E-5,1.06E-5,1.14E-5,1.21E-5,1.28E-5,1.34E-5, - 2 1.40E-5,1.46E-5,1.52E-5,1.58E-5,1.63E-5,1.68E-5,1.73E-5,1.78E-5, - 3 1.82E-5,1.86E-5,1.91E-5,1.95E-5,1.99E-5,2.02E-5,2.06E-5,2.10E-5, - 4 2.13E-5,2.17E-5,2.20E-5,2.23E-5,2.26E-5,2.29E-5,2.32E-5,2.35E-5, - 5 2.38E-5,2.41E-5,2.44E-5,2.46E-5,2.49E-5,2.52E-5,2.54E-5,2.57E-5, - 6 2.59E-5,2.61E-5,2.64E-5,2.66E-5,2.68E-5,2.71E-5,2.73E-5,2.75E-5, - 7 2.77E-5,2.79E-5,2.81E-5,2.83E-5,2.85E-5,2.87E-5,2.89E-5,2.91E-5, - 8 2.93E-5,2.95E-5,2.97E-5,2.98E-5,3.00E-5,3.02E-5/ - DATA (COA(I,2),I=1,62) / - 1 0.85E-5,0.95E-5,1.04E-5,1.13E-5,1.21E-5,1.28E-5,1.36E-5,1.43E-5, - 2 1.49E-5,1.55E-5,1.61E-5,1.67E-5,1.72E-5,1.78E-5,1.83E-5,1.87E-5, - 3 1.92E-5,1.96E-5,2.01E-5,2.05E-5,2.09E-5,2.13E-5,2.17E-5,2.20E-5, - 4 2.24E-5,2.27E-5,2.31E-5,2.34E-5,2.37E-5,2.40E-5,2.43E-5,2.46E-5, - 5 2.49E-5,2.52E-5,2.55E-5,2.58E-5,2.60E-5,2.63E-5,2.66E-5,2.68E-5, - 6 2.71E-5,2.73E-5,2.75E-5,2.78E-5,2.80E-5,2.82E-5,2.85E-5,2.87E-5, - 7 2.89E-5,2.91E-5,2.93E-5,2.95E-5,2.97E-5,2.99E-5,3.01E-5,3.03E-5, - 8 3.05E-5,3.07E-5,3.09E-5,3.11E-5,3.13E-5,3.14E-5 / - DATA (COA(I,3),I=1,62) / - 1 0.95E-5,1.06E-5,1.16E-5,1.25E-5,1.34E-5,1.43E-5,1.50E-5,1.58E-5, - 2 1.65E-5,1.71E-5,1.78E-5,1.84E-5,1.89E-5,1.95E-5,2.00E-5,2.05E-5, - 3 2.10E-5,2.15E-5,2.19E-5,2.23E-5,2.28E-5,2.32E-5,2.35E-5,2.39E-5, - 4 2.43E-5,2.47E-5,2.50E-5,2.53E-5,2.57E-5,2.60E-5,2.63E-5,2.66E-5, - 5 2.69E-5,2.72E-5,2.75E-5,2.78E-5,2.81E-5,2.83E-5,2.86E-5,2.89E-5, - 6 2.91E-5,2.94E-5,2.96E-5,2.99E-5,3.01E-5,3.03E-5,3.06E-5,3.08E-5, - 7 3.10E-5,3.12E-5,3.15E-5,3.17E-5,3.19E-5,3.21E-5,3.23E-5,3.25E-5, - 8 3.27E-5,3.29E-5,3.31E-5,3.33E-5,3.35E-5,3.29E-5 / - DATA (COA(I,4),I=1,62) / - 1 1.00E-5,1.11E-5,1.22E-5,1.31E-5,1.41E-5,1.49E-5,1.57E-5,1.65E-5, - 2 1.72E-5,1.79E-5,1.85E-5,1.91E-5,1.97E-5,2.03E-5,2.08E-5,2.13E-5, - 3 2.18E-5,2.23E-5,2.27E-5,2.32E-5,2.36E-5,2.40E-5,2.44E-5,2.48E-5, - 4 2.52E-5,2.55E-5,2.59E-5,2.62E-5,2.66E-5,2.69E-5,2.72E-5,2.75E-5, - 5 2.78E-5,2.81E-5,2.84E-5,2.87E-5,2.90E-5,2.93E-5,2.95E-5,2.98E-5, - 6 3.00E-5,3.03E-5,3.06E-5,3.08E-5,3.10E-5,3.13E-5,3.15E-5,3.17E-5, - 7 3.20E-5,3.22E-5,3.24E-5,3.26E-5,3.28E-5,3.31E-5,3.33E-5,3.35E-5, - 8 3.30E-5,3.39E-5,3.41E-5,3.43E-5,3.45E-5,3.46E-5 / - DATA (COA(I,5),I=1,62) / - 1 1.09E-5,1.21E-5,1.32E-5,1.43E-5,1.52E-5,1.61E-5,1.70E-5,1.78E-5, - 2 1.85E-5,1.92E-5,1.99E-5,2.05E-5,2.11E-5,2.17E-5,2.22E-5,2.28E-5, - 3 2.33E-5,2.38E-5,2.42E-5,2.47E-5,2.51E-5,2.55E-5,2.59E-5,2.63E-5, - 4 2.67E-5,2.71E-5,2.75E-5,2.78E-5,2.82E-5,2.85E-5,2.88E-5,2.91E-5, - 5 2.95E-5,2.98E-5,3.01E-5,3.04E-5,3.07E-5,3.09E-5,3.12E-5,3.15E-5, - 6 3.18E-5,3.20E-5,3.23E-5,3.25E-5,3.28E-5,3.30E-5,3.33E-5,3.35E-5, - 7 3.30E-5,3.40E-5,3.42E-5,3.44E-5,3.46E-5,3.48E-5,3.51E-5,3.53E-5, - 8 3.55E-5,3.57E-5,3.59E-5,3.61E-5,3.63E-5,3.65E-5 / - DATA (COA(I,6),I=1,62) / - 1 1.17E-5,1.30E-5,1.42E-5,1.53E-5,1.63E-5,1.73E-5,1.81E-5,1.90E-5, - 2 1.97E-5,2.04E-5,2.11E-5,2.18E-5,2.24E-5,2.30E-5,2.35E-5,2.41E-5, - 3 2.46E-5,2.51E-5,2.56E-5,2.60E-5,2.65E-5,2.69E-5,2.73E-5,2.77E-5, - 4 2.81E-5,2.85E-5,2.89E-5,2.93E-5,2.96E-5,2.99E-5,3.03E-5,3.06E-5, - 5 3.09E-5,3.13E-5,3.16E-5,3.19E-5,3.22E-5,3.24E-5,3.27E-5,3.30E-5, - 6 3.33E-5,3.36E-5,3.31E-5,3.41E-5,3.43E-5,3.46E-5,3.48E-5,3.51E-5, - 7 3.53E-5,3.55E-5,3.58E-5,3.60E-5,3.62E-5,3.65E-5,3.67E-5,3.69E-5, - 8 3.71E-5,3.73E-5,3.75E-5,3.77E-5,3.79E-5,3.81E-5 / - DATA (COA(I,7),I=1,62) / - 1 1.25E-5,1.39E-5,1.51E-5,1.63E-5,1.73E-5,1.83E-5,1.92E-5,2.00E-5, - 2 2.08E-5,2.16E-5,2.23E-5,2.29E-5,2.36E-5,2.42E-5,2.47E-5,2.53E-5, - 3 2.58E-5,2.63E-5,2.68E-5,2.73E-5,2.77E-5,2.82E-5,2.86E-5,2.90E-5, - 4 2.94E-5,2.98E-5,3.02E-5,3.06E-5,3.09E-5,3.13E-5,3.16E-5,3.20E-5, - 5 3.23E-5,3.26E-5,3.29E-5,3.32E-5,3.35E-5,3.31E-5,3.41E-5,3.44E-5, - 6 3.47E-5,3.50E-5,3.52E-5,3.55E-5,3.58E-5,3.60E-5,3.63E-5,3.65E-5, - 7 3.68E-5,3.70E-5,3.72E-5,3.75E-5,3.77E-5,3.79E-5,3.82E-5,3.84E-5, - 8 3.86E-5,3.88E-5,3.90E-5,3.92E-5,3.94E-5,3.96E-5 / - DATA (COA(I,8),I=1,62) / - 1 1.32E-5,1.47E-5,1.60E-5,1.72E-5,1.83E-5,1.93E-5,2.02E-5,2.10E-5, - 2 2.18E-5,2.26E-5,2.33E-5,2.40E-5,2.46E-5,2.52E-5,2.58E-5,2.64E-5, - 3 2.69E-5,2.74E-5,2.79E-5,2.84E-5,2.89E-5,2.93E-5,2.98E-5,3.02E-5, - 4 3.06E-5,3.10E-5,3.14E-5,3.18E-5,3.21E-5,3.25E-5,3.28E-5,3.32E-5, - 5 3.35E-5,3.31E-5,3.42E-5,3.45E-5,3.48E-5,3.51E-5,3.54E-5,3.57E-5, - 6 3.60E-5,3.63E-5,3.65E-5,3.68E-5,3.71E-5,3.73E-5,3.76E-5,3.78E-5, - 7 3.81E-5,3.83E-5,3.86E-5,3.88E-5,3.91E-5,3.93E-5,3.95E-5,3.97E-5, - 8 4.00E-5,4.02E-5,4.04E-5,4.06E-5,4.08E-5,4.11E-5 / - DATA (COA(I,9),I=1,62) / - 1 1.43E-5,1.58E-5,1.72E-5,1.84E-5,1.95E-5,2.06E-5,2.15E-5,2.24E-5, - 2 2.32E-5,2.40E-5,2.47E-5,2.54E-5,2.61E-5,2.67E-5,2.73E-5,2.79E-5, - 3 2.84E-5,2.90E-5,2.95E-5,3.00E-5,3.05E-5,3.09E-5,3.14E-5,3.18E-5, - 4 3.22E-5,3.26E-5,3.30E-5,3.34E-5,3.31E-5,3.42E-5,3.45E-5,3.49E-5, - 5 3.52E-5,3.56E-5,3.59E-5,3.62E-5,3.65E-5,3.68E-5,3.71E-5,3.74E-5, - 6 3.77E-5,3.80E-5,3.83E-5,3.86E-5,3.89E-5,3.91E-5,3.94E-5,3.97E-5, - 7 3.99E-5,4.02E-5,4.04E-5,4.07E-5,4.09E-5,4.12E-5,4.14E-5,4.16E-5, - 8 4.19E-5,4.21E-5,4.23E-5,4.26E-5,4.28E-5,4.30E-5 / - DATA (COA(I,10),I=1,62) / - 1 1.53E-5,1.69E-5,1.83E-5,1.96E-5,2.07E-5,2.18E-5,2.27E-5,2.36E-5, - 2 2.45E-5,2.53E-5,2.60E-5,2.67E-5,2.74E-5,2.81E-5,2.87E-5,2.93E-5, - 3 2.98E-5,3.04E-5,3.09E-5,3.14E-5,3.19E-5,3.24E-5,3.28E-5,3.33E-5, - 4 3.30E-5,3.41E-5,3.45E-5,3.49E-5,3.53E-5,3.57E-5,3.61E-5,3.64E-5, - 5 3.68E-5,3.71E-5,3.75E-5,3.78E-5,3.81E-5,3.84E-5,3.87E-5,3.91E-5, - 6 3.94E-5,3.97E-5,3.99E-5,4.02E-5,4.05E-5,4.08E-5,4.11E-5,4.13E-5, - 7 4.16E-5,4.19E-5,4.21E-5,4.24E-5,4.26E-5,4.29E-5,4.31E-5,4.34E-5, - 8 4.36E-5,4.39E-5,4.41E-5,4.43E-5,4.46E-5,4.48E-5 / - DATA (COA(I,11),I=1,62) / - 1 1.65E-5,1.82E-5,1.96E-5,2.09E-5,2.21E-5,2.32E-5,2.42E-5,2.51E-5, - 2 2.60E-5,2.68E-5,2.76E-5,2.83E-5,2.90E-5,2.97E-5,3.03E-5,3.09E-5, - 3 3.15E-5,3.21E-5,3.26E-5,3.31E-5,3.36E-5,3.41E-5,3.46E-5,3.50E-5, - 4 3.55E-5,3.59E-5,3.63E-5,3.67E-5,3.71E-5,3.75E-5,3.79E-5,3.83E-5, - 5 3.86E-5,3.90E-5,3.94E-5,3.97E-5,4.00E-5,4.04E-5,4.07E-5,4.10E-5, - 6 4.13E-5,4.16E-5,4.19E-5,4.22E-5,4.25E-5,4.28E-5,4.31E-5,4.34E-5, - 7 4.37E-5,4.39E-5,4.42E-5,4.45E-5,4.47E-5,4.50E-5,4.53E-5,4.55E-5, - 8 4.58E-5,4.60E-5,4.63E-5,4.65E-5,4.68E-5,4.70E-5 / - DATA (COA(I,12),I=1,62) / - 1 1.73E-5,1.90E-5,2.05E-5,2.19E-5,2.31E-5,2.42E-5,2.52E-5,2.62E-5, - 2 2.71E-5,2.79E-5,2.87E-5,2.94E-5,3.01E-5,3.08E-5,3.14E-5,3.20E-5, - 3 3.26E-5,3.32E-5,3.30E-5,3.43E-5,3.48E-5,3.53E-5,3.58E-5,3.62E-5, - 4 3.67E-5,3.71E-5,3.76E-5,3.80E-5,3.84E-5,3.88E-5,3.92E-5,3.96E-5, - 5 3.99E-5,4.03E-5,4.07E-5,4.10E-5,4.14E-5,4.17E-5,4.20E-5,4.24E-5, - 6 4.27E-5,4.30E-5,4.33E-5,4.36E-5,4.39E-5,4.42E-5,4.45E-5,4.48E-5, - 7 4.51E-5,4.54E-5,4.57E-5,4.59E-5,4.62E-5,4.65E-5,4.68E-5,4.70E-5, - 8 4.73E-5,4.75E-5,4.78E-5,4.81E-5,4.83E-5,4.86E-5 / - DATA (COA(I,13),I=1,62) / - 1 1.86E-5,2.04E-5,2.19E-5,2.33E-5,2.46E-5,2.57E-5,2.68E-5,2.77E-5, - 2 2.86E-5,2.95E-5,3.03E-5,3.11E-5,3.18E-5,3.25E-5,3.31E-5,3.31E-5, - 3 3.44E-5,3.50E-5,3.55E-5,3.61E-5,3.66E-5,3.71E-5,3.76E-5,3.81E-5, - 4 3.86E-5,3.90E-5,3.95E-5,3.99E-5,4.03E-5,4.07E-5,4.12E-5,4.16E-5, - 5 4.19E-5,4.23E-5,4.27E-5,4.31E-5,4.34E-5,4.38E-5,4.41E-5,4.45E-5, - 6 4.48E-5,4.51E-5,4.55E-5,4.58E-5,4.61E-5,4.64E-5,4.67E-5,4.70E-5, - 7 4.73E-5,4.76E-5,4.79E-5,4.82E-5,4.85E-5,4.88E-5,4.91E-5,4.94E-5, - 8 4.97E-5,4.99E-5,5.02E-5,5.05E-5,5.07E-5,5.10E-5 / - DATA (COA(I,14),I=1,62) / - 1 1.98E-5,2.16E-5,2.32E-5,2.46E-5,2.59E-5,2.71E-5,2.81E-5,2.91E-5, - 2 3.01E-5,3.10E-5,3.18E-5,3.26E-5,3.33E-5,3.40E-5,3.47E-5,3.54E-5, - 3 3.60E-5,3.66E-5,3.72E-5,3.77E-5,3.83E-5,3.88E-5,3.93E-5,3.98E-5, - 4 4.03E-5,4.08E-5,4.12E-5,4.17E-5,4.21E-5,4.25E-5,4.30E-5,4.34E-5, - 5 4.38E-5,4.42E-5,4.46E-5,4.49E-5,4.53E-5,4.57E-5,4.61E-5,4.64E-5, - 6 4.68E-5,4.71E-5,4.75E-5,4.78E-5,4.81E-5,4.85E-5,4.88E-5,4.91E-5, - 7 4.94E-5,4.98E-5,5.01E-5,5.04E-5,5.07E-5,5.10E-5,5.13E-5,5.16E-5, - 8 5.19E-5,5.22E-5,5.24E-5,5.27E-5,5.30E-5,5.33E-5 / - DATA (COA(I,15),I=1,62) / - 1 2.09E-5,2.28E-5,2.44E-5,2.58E-5,2.71E-5,2.83E-5,2.94E-5,3.05E-5, - 2 3.14E-5,3.23E-5,3.32E-5,3.40E-5,3.47E-5,3.54E-5,3.61E-5,3.68E-5, - 3 3.75E-5,3.81E-5,3.87E-5,3.92E-5,3.98E-5,4.04E-5,4.09E-5,4.14E-5, - 4 4.19E-5,4.24E-5,4.29E-5,4.33E-5,4.38E-5,4.42E-5,4.47E-5,4.51E-5, - 5 4.55E-5,4.59E-5,4.63E-5,4.67E-5,4.71E-5,4.75E-5,4.79E-5,4.83E-5, - 6 4.86E-5,4.90E-5,4.93E-5,4.97E-5,5.01E-5,5.04E-5,5.07E-5,5.11E-5, - 7 5.14E-5,5.18E-5,5.21E-5,5.24E-5,5.27E-5,5.30E-5,5.34E-5,5.37E-5, - 8 5.40E-5,5.43E-5,5.46E-5,5.49E-5,5.52E-5,5.55E-5 / - DATA (COA(I,16),I=1,62) / - 1 2.21E-5,2.40E-5,2.57E-5,2.72E-5,2.85E-5,2.97E-5,3.08E-5,3.19E-5, - 2 3.29E-5,3.31E-5,3.47E-5,3.55E-5,3.63E-5,3.70E-5,3.77E-5,3.84E-5, - 3 3.91E-5,3.97E-5,4.04E-5,4.09E-5,4.15E-5,4.21E-5,4.26E-5,4.32E-5, - 4 4.37E-5,4.42E-5,4.47E-5,4.52E-5,4.56E-5,4.61E-5,4.66E-5,4.70E-5, - 5 4.75E-5,4.79E-5,4.83E-5,4.87E-5,4.91E-5,4.96E-5,5.00E-5,5.03E-5, - 6 5.07E-5,5.11E-5,5.15E-5,5.19E-5,5.23E-5,5.26E-5,5.30E-5,5.33E-5, - 7 5.37E-5,5.40E-5,5.44E-5,5.47E-5,5.51E-5,5.54E-5,5.58E-5,5.61E-5, - 8 5.64E-5,5.67E-5,5.71E-5,5.74E-5,5.77E-5,5.80E-5 / - DATA (COA(I,17),I=1,62) / - 1 2.34E-5,2.54E-5,2.71E-5,2.86E-5,3.00E-5,3.12E-5,3.24E-5,3.35E-5, - 2 3.45E-5,3.54E-5,3.63E-5,3.72E-5,3.80E-5,3.87E-5,3.95E-5,4.02E-5, - 3 4.09E-5,4.15E-5,4.22E-5,4.28E-5,4.34E-5,4.40E-5,4.46E-5,4.51E-5, - 4 4.57E-5,4.62E-5,4.67E-5,4.72E-5,4.77E-5,4.82E-5,4.87E-5,4.92E-5, - 5 4.96E-5,5.01E-5,5.05E-5,5.10E-5,5.14E-5,5.18E-5,5.23E-5,5.27E-5, - 6 5.31E-5,5.35E-5,5.39E-5,5.43E-5,5.47E-5,5.51E-5,5.55E-5,5.59E-5, - 7 5.62E-5,5.66E-5,5.70E-5,5.73E-5,5.77E-5,5.81E-5,5.84E-5,5.88E-5, - 8 5.91E-5,5.95E-5,5.98E-5,6.02E-5,6.05E-5,6.08E-5 / - DATA (COA(I,18),I=1,62) / - 1 2.48E-5,2.68E-5,2.85E-5,3.01E-5,3.15E-5,3.28E-5,3.40E-5,3.51E-5, - 2 3.62E-5,3.71E-5,3.81E-5,3.89E-5,3.98E-5,4.06E-5,4.13E-5,4.21E-5, - 3 4.28E-5,4.35E-5,4.42E-5,4.48E-5,4.54E-5,4.60E-5,4.66E-5,4.72E-5, - 4 4.78E-5,4.84E-5,4.89E-5,4.94E-5,5.00E-5,5.05E-5,5.10E-5,5.15E-5, - 5 5.20E-5,5.25E-5,5.30E-5,5.34E-5,5.39E-5,5.44E-5,5.48E-5,5.53E-5, - 6 5.57E-5,5.61E-5,5.66E-5,5.70E-5,5.74E-5,5.78E-5,5.82E-5,5.86E-5, - 7 5.90E-5,5.94E-5,5.98E-5,6.02E-5,6.06E-5,6.10E-5,6.14E-5,6.18E-5, - 8 6.21E-5,6.25E-5,6.29E-5,6.33E-5,6.36E-5,6.40E-5 / - DATA (COA(I,19),I=1,62) / - 1 2.60E-5,2.81E-5,2.99E-5,3.15E-5,3.30E-5,3.43E-5,3.55E-5,3.67E-5, - 2 3.77E-5,3.88E-5,3.97E-5,4.06E-5,4.15E-5,4.23E-5,4.31E-5,4.39E-5, - 3 4.46E-5,4.53E-5,4.60E-5,4.67E-5,4.74E-5,4.80E-5,4.87E-5,4.93E-5, - 4 4.99E-5,5.05E-5,5.10E-5,5.16E-5,5.22E-5,5.27E-5,5.33E-5,5.38E-5, - 5 5.43E-5,5.48E-5,5.53E-5,5.58E-5,5.63E-5,5.68E-5,5.73E-5,5.78E-5, - 6 5.82E-5,5.87E-5,5.91E-5,5.96E-5,6.01E-5,6.05E-5,6.09E-5,6.14E-5, - 7 6.18E-5,6.22E-5,6.26E-5,6.31E-5,6.35E-5,6.39E-5,6.43E-5,6.47E-5, - 8 6.51E-5,6.55E-5,6.59E-5,6.63E-5,6.67E-5,6.70E-5 / - DATA (COA(I,20),I=1,62) / - 1 2.75E-5,2.96E-5,3.15E-5,3.32E-5,3.47E-5,3.60E-5,3.73E-5,3.85E-5, - 2 3.96E-5,4.07E-5,4.17E-5,4.26E-5,4.35E-5,4.44E-5,4.52E-5,4.60E-5, - 3 4.68E-5,4.76E-5,4.83E-5,4.90E-5,4.97E-5,5.04E-5,5.11E-5,5.17E-5, - 4 5.24E-5,5.30E-5,5.36E-5,5.42E-5,5.48E-5,5.54E-5,5.60E-5,5.66E-5, - 5 5.71E-5,5.77E-5,5.82E-5,5.87E-5,5.93E-5,5.98E-5,6.03E-5,6.08E-5, - 6 6.13E-5,6.18E-5,6.23E-5,6.28E-5,6.33E-5,6.38E-5,6.42E-5,6.47E-5, - 7 6.52E-5,6.56E-5,6.61E-5,6.65E-5,6.70E-5,6.74E-5,6.78E-5,6.83E-5, - 8 6.87E-5,6.91E-5,6.95E-5,7.00E-5,7.04E-5,7.08E-5 / - DATA (COA(I,21),I=1,62) / - 1 2.90E-5,3.12E-5,3.31E-5,3.49E-5,3.64E-5,3.79E-5,3.92E-5,4.04E-5, - 2 4.16E-5,4.27E-5,4.37E-5,4.47E-5,4.57E-5,4.66E-5,4.75E-5,4.83E-5, - 3 4.92E-5,5.00E-5,5.07E-5,5.15E-5,5.23E-5,5.30E-5,5.37E-5,5.44E-5, - 4 5.51E-5,5.58E-5,5.64E-5,5.71E-5,5.77E-5,5.83E-5,5.89E-5,5.96E-5, - 5 6.02E-5,6.07E-5,6.13E-5,6.19E-5,6.25E-5,6.30E-5,6.36E-5,6.41E-5, - 6 6.47E-5,6.52E-5,6.57E-5,6.63E-5,6.68E-5,6.73E-5,6.78E-5,6.83E-5, - 7 6.88E-5,6.93E-5,6.98E-5,7.02E-5,7.07E-5,7.12E-5,7.16E-5,7.21E-5, - 8 7.26E-5,7.30E-5,7.35E-5,7.39E-5,7.44E-5,7.48E-5 / - DATA (COA(I,22),I=1,62) / - 1 3.06E-5,3.29E-5,3.49E-5,3.66E-5,3.83E-5,3.98E-5,4.11E-5,4.24E-5, - 2 4.36E-5,4.48E-5,4.59E-5,4.69E-5,4.79E-5,4.89E-5,4.99E-5,5.08E-5, - 3 5.16E-5,5.25E-5,5.33E-5,5.42E-5,5.49E-5,5.57E-5,5.65E-5,5.72E-5, - 4 5.80E-5,5.87E-5,5.94E-5,6.01E-5,6.08E-5,6.15E-5,6.21E-5,6.28E-5, - 5 6.34E-5,6.40E-5,6.47E-5,6.53E-5,6.59E-5,6.65E-5,6.71E-5,6.77E-5, - 6 6.83E-5,6.88E-5,6.94E-5,7.00E-5,7.05E-5,7.11E-5,7.16E-5,7.21E-5, - 7 7.27E-5,7.32E-5,7.37E-5,7.42E-5,7.47E-5,7.52E-5,7.57E-5,7.62E-5, - 8 7.67E-5,7.72E-5,7.77E-5,7.82E-5,7.86E-5,7.91E-5 / - DATA (COA(I,23),I=1,62) / - 1 3.23E-5,3.47E-5,3.68E-5,3.86E-5,4.03E-5,4.19E-5,4.33E-5,4.47E-5, - 2 4.59E-5,4.72E-5,4.83E-5,4.94E-5,5.05E-5,5.16E-5,5.26E-5,5.35E-5, - 3 5.45E-5,5.54E-5,5.63E-5,5.72E-5,5.80E-5,5.89E-5,5.97E-5,6.05E-5, - 4 6.13E-5,6.21E-5,6.28E-5,6.36E-5,6.43E-5,6.50E-5,6.57E-5,6.64E-5, - 5 6.71E-5,6.78E-5,6.85E-5,6.92E-5,6.98E-5,7.05E-5,7.11E-5,7.17E-5, - 6 7.24E-5,7.30E-5,7.36E-5,7.42E-5,7.48E-5,7.54E-5,7.60E-5,7.65E-5, - 7 7.71E-5,7.77E-5,7.82E-5,7.88E-5,7.93E-5,7.99E-5,8.04E-5,8.09E-5, - 8 8.15E-5,8.20E-5,8.25E-5,8.30E-5,8.35E-5,8.40E-5 / - DATA (COA(I,24),I=1,62) / - 1 3.41E-5,3.65E-5,3.87E-5,4.06E-5,4.24E-5,4.40E-5,4.56E-5,4.70E-5, - 2 4.83E-5,4.96E-5,5.09E-5,5.21E-5,5.32E-5,5.43E-5,5.54E-5,5.64E-5, - 3 5.74E-5,5.84E-5,5.94E-5,6.03E-5,6.13E-5,6.22E-5,6.30E-5,6.39E-5, - 4 6.48E-5,6.56E-5,6.64E-5,6.72E-5,6.80E-5,6.88E-5,6.96E-5,7.03E-5, - 5 7.11E-5,7.18E-5,7.25E-5,7.32E-5,7.39E-5,7.46E-5,7.53E-5,7.60E-5, - 6 7.67E-5,7.73E-5,7.80E-5,7.86E-5,7.93E-5,7.99E-5,8.05E-5,8.11E-5, - 7 8.17E-5,8.23E-5,8.29E-5,8.35E-5,8.41E-5,8.47E-5,8.53E-5,8.58E-5, - 8 8.64E-5,8.70E-5,8.75E-5,8.81E-5,8.86E-5,8.92E-5 / - DATA (COA(I,25),I=1,62) / - 1 3.59E-5,3.85E-5,4.08E-5,4.28E-5,4.47E-5,4.64E-5,4.80E-5,4.95E-5, - 2 5.10E-5,5.24E-5,5.37E-5,5.50E-5,5.62E-5,5.74E-5,5.85E-5,5.97E-5, - 3 6.08E-5,6.18E-5,6.29E-5,6.39E-5,6.49E-5,6.58E-5,6.68E-5,6.77E-5, - 4 6.86E-5,6.95E-5,7.04E-5,7.13E-5,7.21E-5,7.30E-5,7.38E-5,7.46E-5, - 5 7.54E-5,7.62E-5,7.70E-5,7.77E-5,7.85E-5,7.92E-5,8.00E-5,8.07E-5, - 6 8.14E-5,8.21E-5,8.28E-5,8.35E-5,8.42E-5,8.49E-5,8.56E-5,8.62E-5, - 7 8.69E-5,8.75E-5,8.82E-5,8.88E-5,8.94E-5,9.00E-5,9.07E-5,9.13E-5, - 8 9.19E-5,9.25E-5,9.31E-5,9.36E-5,9.42E-5,9.48E-5 / - DATA (COA(I,26),I=1,62) / - 1 0.380E-4,0.407E-4,0.431E-4,0.453E-4,0.473E-4,0.491E-4,0.508E-4, - 2 0.525E-4,0.540E-4,0.555E-4,0.569E-4,0.583E-4,0.596E-4,0.609E-4, - 3 0.622E-4,0.634E-4,0.646E-4,0.657E-4,0.668E-4,0.679E-4,0.690E-4, - 4 0.700E-4,0.711E-4,0.721E-4,0.731E-4,0.740E-4,0.750E-4,0.759E-4, - 5 0.769E-4,0.778E-4,0.786E-4,0.795E-4,0.804E-4,0.812E-4,0.821E-4, - 6 0.829E-4,0.837E-4,0.845E-4,0.853E-4,0.861E-4,0.869E-4,0.876E-4, - 7 0.884E-4,0.891E-4,0.899E-4,0.906E-4,0.913E-4,0.920E-4,0.927E-4, - 8 0.934E-4,0.941E-4,0.948E-4,0.955E-4,0.961E-4,0.968E-4,0.974E-4, - 9 0.981E-4,0.987E-4,0.994E-4,1.000E-4,1.006E-4,1.012E-4 / - DATA (COA(I,27),I=1,62) / - 1 0.403E-4,0.431E-4,0.456E-4,0.479E-4,0.500E-4,0.520E-4,0.538E-4, - 2 0.556E-4,0.573E-4,0.589E-4,0.604E-4,0.619E-4,0.633E-4,0.647E-4, - 3 0.661E-4,0.674E-4,0.686E-4,0.699E-4,0.711E-4,0.723E-4,0.734E-4, - 4 0.746E-4,0.757E-4,0.768E-4,0.778E-4,0.789E-4,0.799E-4,0.809E-4, - 5 0.819E-4,0.829E-4,0.838E-4,0.848E-4,0.857E-4,0.866E-4,0.875E-4, - 6 0.884E-4,0.893E-4,0.902E-4,0.910E-4,0.919E-4,0.927E-4,0.935E-4, - 7 0.943E-4,0.951E-4,0.959E-4,0.967E-4,0.974E-4,0.982E-4,0.990E-4, - 8 0.997E-4,1.004E-4,1.012E-4,1.019E-4,1.026E-4,1.033E-4,1.040E-4, - 9 1.047E-4,1.054E-4,1.061E-4,1.067E-4,1.074E-4,1.080E-4 / - DATA (COA(I,28),I=1,62) / - 1 0.426E-4,0.456E-4,0.482E-4,0.507E-4,0.529E-4,0.550E-4,0.570E-4, - 2 0.589E-4,0.607E-4,0.624E-4,0.641E-4,0.657E-4,0.672E-4,0.687E-4, - 3 0.702E-4,0.716E-4,0.730E-4,0.743E-4,0.756E-4,0.769E-4,0.781E-4, - 4 0.794E-4,0.806E-4,0.817E-4,0.829E-4,0.840E-4,0.851E-4,0.862E-4, - 5 0.873E-4,0.883E-4,0.893E-4,0.904E-4,0.913E-4,0.923E-4,0.933E-4, - 6 0.943E-4,0.952E-4,0.961E-4,0.970E-4,0.979E-4,0.988E-4,0.997E-4, - 7 1.006E-4,1.014E-4,1.023E-4,1.031E-4,1.039E-4,1.047E-4,1.055E-4, - 8 1.063E-4,1.071E-4,1.079E-4,1.087E-4,1.094E-4,1.102E-4,1.109E-4, - 9 1.116E-4,1.124E-4,1.131E-4,1.138E-4,1.145E-4,1.152E-4 / - DATA (COA(I,29),I=1,62) / - 1 0.451E-4,0.482E-4,0.511E-4,0.537E-4,0.561E-4,0.584E-4,0.605E-4, - 2 0.626E-4,0.645E-4,0.664E-4,0.682E-4,0.699E-4,0.715E-4,0.732E-4, - 3 0.747E-4,0.763E-4,0.777E-4,0.792E-4,0.806E-4,0.820E-4,0.833E-4, - 4 0.846E-4,0.859E-4,0.872E-4,0.884E-4,0.896E-4,0.908E-4,0.920E-4, - 5 0.931E-4,0.942E-4,0.953E-4,0.964E-4,0.975E-4,0.986E-4,0.996E-4, - 6 1.006E-4,1.016E-4,1.026E-4,1.036E-4,1.046E-4,1.055E-4,1.064E-4, - 7 1.074E-4,1.083E-4,1.092E-4,1.101E-4,1.110E-4,1.118E-4,1.127E-4, - 8 1.135E-4,1.144E-4,1.152E-4,1.160E-4,1.168E-4,1.176E-4,1.184E-4, - 9 1.192E-4,1.200E-4,1.207E-4,1.215E-4,1.222E-4,1.230E-4 / - DATA (COA(I,30),I=1,62) / - 1 0.478E-4,0.512E-4,0.543E-4,0.571E-4,0.597E-4,0.621E-4,0.644E-4, - 2 0.666E-4,0.687E-4,0.708E-4,0.727E-4,0.746E-4,0.764E-4,0.781E-4, - 3 0.798E-4,0.814E-4,0.830E-4,0.846E-4,0.861E-4,0.876E-4,0.891E-4, - 4 0.905E-4,0.919E-4,0.932E-4,0.945E-4,0.958E-4,0.971E-4,0.984E-4, - 5 0.996E-4,1.008E-4,1.020E-4,1.032E-4,1.043E-4,1.055E-4,1.066E-4, - 6 1.077E-4,1.088E-4,1.098E-4,1.109E-4,1.119E-4,1.129E-4,1.139E-4, - 7 1.149E-4,1.159E-4,1.168E-4,1.178E-4,1.187E-4,1.197E-4,1.206E-4, - 8 1.215E-4,1.224E-4,1.233E-4,1.241E-4,1.250E-4,1.258E-4,1.267E-4, - 9 1.275E-4,1.283E-4,1.292E-4,1.300E-4,1.308E-4,1.316E-4 / - DATA (COA(I,31),I=1,62) / - 1 0.508E-4,0.544E-4,0.577E-4,0.607E-4,0.635E-4,0.661E-4,0.686E-4, - 2 0.710E-4,0.733E-4,0.754E-4,0.775E-4,0.795E-4,0.815E-4,0.834E-4, - 3 0.852E-4,0.870E-4,0.887E-4,0.904E-4,0.920E-4,0.936E-4,0.952E-4, - 4 0.967E-4,0.982E-4,0.996E-4,1.011E-4,1.025E-4,1.038E-4,1.052E-4, - 5 1.065E-4,1.078E-4,1.091E-4,1.103E-4,1.116E-4,1.128E-4,1.140E-4, - 6 1.151E-4,1.163E-4,1.174E-4,1.186E-4,1.197E-4,1.207E-4,1.218E-4, - 7 1.229E-4,1.239E-4,1.249E-4,1.260E-4,1.270E-4,1.279E-4,1.289E-4, - 8 1.299E-4,1.308E-4,1.318E-4,1.327E-4,1.336E-4,1.317E-4,1.325E-4, - 9 1.363E-4,1.372E-4,1.380E-4,1.389E-4,1.397E-4,1.406E-4 / - DATA (COA(I,32),I=1,62) / - 1 0.540E-4,0.579E-4,0.615E-4,0.647E-4,0.677E-4,0.706E-4,0.733E-4, - 2 0.758E-4,0.783E-4,0.806E-4,0.829E-4,0.851E-4,0.872E-4,0.892E-4, - 3 0.912E-4,0.931E-4,0.950E-4,0.968E-4,0.985E-4,1.003E-4,1.020E-4, - 4 1.036E-4,1.052E-4,1.068E-4,1.083E-4,1.098E-4,1.113E-4,1.127E-4, - 5 1.142E-4,1.156E-4,1.169E-4,1.183E-4,1.196E-4,1.209E-4,1.222E-4, - 6 1.234E-4,1.246E-4,1.259E-4,1.270E-4,1.282E-4,1.294E-4,1.305E-4, - 7 1.317E-4,1.328E-4,1.339E-4,1.321E-4,1.360E-4,1.371E-4,1.381E-4, - 8 1.391E-4,1.401E-4,1.411E-4,1.421E-4,1.431E-4,1.440E-4,1.450E-4, - 9 1.459E-4,1.469E-4,1.478E-4,1.487E-4,1.496E-4,1.505E-4 / - DATA (COA(I,33),I=1,62) / - 1 0.575E-4,0.617E-4,0.655E-4,0.690E-4,0.723E-4,0.754E-4,0.783E-4, - 2 0.810E-4,0.837E-4,0.862E-4,0.887E-4,0.910E-4,0.933E-4,0.955E-4, - 3 0.976E-4,0.997E-4,1.017E-4,1.036E-4,1.055E-4,1.074E-4,1.092E-4, - 4 1.110E-4,1.127E-4,1.144E-4,1.160E-4,1.176E-4,1.192E-4,1.208E-4, - 5 1.223E-4,1.238E-4,1.252E-4,1.267E-4,1.281E-4,1.295E-4,1.308E-4, - 6 1.322E-4,1.335E-4,1.319E-4,1.360E-4,1.373E-4,1.385E-4,1.397E-4, - 7 1.409E-4,1.421E-4,1.433E-4,1.444E-4,1.456E-4,1.467E-4,1.478E-4, - 8 1.489E-4,1.499E-4,1.510E-4,1.520E-4,1.531E-4,1.541E-4,1.551E-4, - 9 1.561E-4,1.571E-4,1.581E-4,1.590E-4,1.600E-4,1.609E-4/ - DATA (COA(I,34),I=1,62) / - 1 0.613E-4,0.659E-4,0.700E-4,0.738E-4,0.773E-4,0.806E-4,0.838E-4, - 2 0.868E-4,0.896E-4,0.924E-4,0.950E-4,0.976E-4,1.000E-4,1.024E-4, - 3 1.047E-4,1.069E-4,1.091E-4,1.112E-4,1.132E-4,1.152E-4,1.172E-4, - 4 1.191E-4,1.209E-4,1.227E-4,1.245E-4,1.262E-4,1.279E-4,1.296E-4, - 5 1.312E-4,1.328E-4,1.344E-4,1.359E-4,1.374E-4,1.389E-4,1.403E-4, - 6 1.417E-4,1.432E-4,1.445E-4,1.459E-4,1.472E-4,1.485E-4,1.498E-4, - 7 1.511E-4,1.524E-4,1.536E-4,1.548E-4,1.560E-4,1.572E-4,1.584E-4, - 8 1.595E-4,1.607E-4,1.618E-4,1.629E-4,1.640E-4,1.651E-4,1.661E-4, - 9 1.672E-4,1.682E-4,1.693E-4,1.703E-4,1.713E-4,1.723E-4 / - DATA (COA(I,35),I=1,62) / - 1 0.654E-4,0.703E-4,0.747E-4,0.789E-4,0.827E-4,0.863E-4,0.897E-4, - 2 0.929E-4,0.960E-4,0.990E-4,1.018E-4,1.046E-4,1.072E-4,1.098E-4, - 3 1.123E-4,1.147E-4,1.170E-4,1.193E-4,1.214E-4,1.236E-4,1.257E-4, - 4 1.277E-4,1.297E-4,1.316E-4,1.335E-4,1.325E-4,1.372E-4,1.389E-4, - 5 1.407E-4,1.424E-4,1.440E-4,1.457E-4,1.473E-4,1.488E-4,1.504E-4, - 6 1.519E-4,1.534E-4,1.548E-4,1.563E-4,1.577E-4,1.591E-4,1.605E-4, - 7 1.618E-4,1.631E-4,1.645E-4,1.658E-4,1.670E-4,1.683E-4,1.695E-4, - 8 1.707E-4,1.720E-4,1.732E-4,1.743E-4,1.755E-4,1.767E-4,1.778E-4, - 9 1.789E-4,1.800E-4,1.811E-4,1.822E-4,1.833E-4,1.844E-4 / - DATA (COA(I,36),I=1,62) / - 1 0.699E-4,0.752E-4,0.800E-4,0.844E-4,0.886E-4,0.925E-4,0.962E-4, - 2 0.997E-4,1.030E-4,1.062E-4,1.093E-4,1.123E-4,1.151E-4,1.179E-4, - 3 1.205E-4,1.231E-4,1.256E-4,1.280E-4,1.304E-4,1.327E-4,1.321E-4, - 4 1.371E-4,1.392E-4,1.413E-4,1.433E-4,1.453E-4,1.472E-4,1.491E-4, - 5 1.509E-4,1.527E-4,1.545E-4,1.562E-4,1.579E-4,1.596E-4,1.612E-4, - 6 1.629E-4,1.644E-4,1.660E-4,1.675E-4,1.690E-4,1.705E-4,1.720E-4, - 7 1.734E-4,1.749E-4,1.762E-4,1.776E-4,1.790E-4,1.803E-4,1.817E-4, - 8 1.830E-4,1.842E-4,1.855E-4,1.868E-4,1.880E-4,1.892E-4,1.905E-4, - 9 1.917E-4,1.928E-4,1.940E-4,1.952E-4,1.963E-4,1.975E-4 / - DATA (COA(I,37),I=1,62) / - 1 0.748E-4,0.805E-4,0.858E-4,0.906E-4,0.951E-4,0.993E-4,1.033E-4, - 2 1.071E-4,1.107E-4,1.142E-4,1.175E-4,1.207E-4,1.238E-4,1.267E-4, - 3 1.296E-4,1.323E-4,1.322E-4,1.376E-4,1.401E-4,1.426E-4,1.450E-4, - 4 1.473E-4,1.496E-4,1.518E-4,1.539E-4,1.560E-4,1.581E-4,1.601E-4, - 5 1.620E-4,1.640E-4,1.659E-4,1.677E-4,1.695E-4,1.713E-4,1.731E-4, - 6 1.748E-4,1.765E-4,1.781E-4,1.798E-4,1.814E-4,1.830E-4,1.845E-4, - 7 1.861E-4,1.876E-4,1.891E-4,1.905E-4,1.920E-4,1.934E-4,1.948E-4, - 8 1.962E-4,1.976E-4,1.990E-4,2.003E-4,2.017E-4,2.030E-4,2.043E-4, - 9 2.056E-4,2.068E-4,2.081E-4,2.093E-4,2.106E-4,2.118E-4 / - DATA (COA(I,38),I=1,62) / - 1 0.802E-4,0.863E-4,0.920E-4,0.972E-4,1.021E-4,1.067E-4,1.110E-4, - 2 1.151E-4,1.190E-4,1.227E-4,1.263E-4,1.297E-4,1.330E-4,1.362E-4, - 3 1.393E-4,1.422E-4,1.451E-4,1.479E-4,1.506E-4,1.532E-4,1.557E-4, - 4 1.582E-4,1.606E-4,1.630E-4,1.653E-4,1.675E-4,1.697E-4,1.719E-4, - 5 1.740E-4,1.760E-4,1.780E-4,1.800E-4,1.819E-4,1.839E-4,1.857E-4, - 6 1.876E-4,1.894E-4,1.911E-4,1.929E-4,1.946E-4,1.963E-4,1.980E-4, - 7 1.996E-4,2.012E-4,2.028E-4,2.044E-4,2.060E-4,2.075E-4,2.090E-4, - 8 2.105E-4,2.120E-4,2.135E-4,2.149E-4,2.164E-4,2.178E-4,2.192E-4, - 9 2.205E-4,2.219E-4,2.233E-4,2.246E-4,2.259E-4,2.273E-4 / - DATA (COA(I,39),I=1,62) / - 1 0.859E-4,0.926E-4,0.987E-4,1.044E-4,1.097E-4,1.146E-4,1.193E-4, - 2 1.237E-4,1.279E-4,1.319E-4,1.358E-4,1.395E-4,1.430E-4,1.464E-4, - 3 1.497E-4,1.528E-4,1.559E-4,1.589E-4,1.617E-4,1.645E-4,1.673E-4, - 4 1.699E-4,1.725E-4,1.750E-4,1.774E-4,1.798E-4,1.822E-4,1.845E-4, - 5 1.867E-4,1.889E-4,1.911E-4,1.932E-4,1.953E-4,1.973E-4,1.993E-4, - 6 2.013E-4,2.032E-4,2.051E-4,2.070E-4,2.088E-4,2.107E-4,2.124E-4, - 7 2.142E-4,2.160E-4,2.177E-4,2.194E-4,2.211E-4,2.227E-4,2.243E-4, - 8 2.260E-4,2.276E-4,2.291E-4,2.307E-4,2.322E-4,2.338E-4,2.353E-4, - 9 2.368E-4,2.382E-4,2.397E-4,2.412E-4,2.426E-4,2.440E-4 / - DATA (COA(I,40),I=1,62) / - 1 0.922E-4,0.995E-4,1.061E-4,1.122E-4,1.179E-4,1.233E-4,1.283E-4, - 2 1.331E-4,1.376E-4,1.419E-4,1.460E-4,1.500E-4,1.538E-4,1.574E-4, - 3 1.609E-4,1.643E-4,1.676E-4,1.707E-4,1.738E-4,1.768E-4,1.797E-4, - 4 1.825E-4,1.853E-4,1.880E-4,1.906E-4,1.932E-4,1.957E-4,1.981E-4, - 5 2.006E-4,2.029E-4,2.052E-4,2.075E-4,2.097E-4,2.119E-4,2.141E-4, - 6 2.162E-4,2.183E-4,2.203E-4,2.223E-4,2.243E-4,2.263E-4,2.282E-4, - 7 2.301E-4,2.320E-4,2.339E-4,2.357E-4,2.375E-4,2.393E-4,2.411E-4, - 8 2.428E-4,2.446E-4,2.463E-4,2.480E-4,2.496E-4,2.513E-4,2.529E-4, - 9 2.546E-4,2.562E-4,2.578E-4,2.593E-4,2.609E-4,2.625E-4 / - DATA (COA(I,41),I=1,62) / - 1 0.990E-4,1.069E-4,1.141E-4,1.207E-4,1.268E-4,1.326E-4,1.380E-4, - 2 1.431E-4,1.480E-4,1.526E-4,1.570E-4,1.612E-4,1.653E-4,1.692E-4, - 3 1.729E-4,1.766E-4,1.801E-4,1.835E-4,1.868E-4,1.900E-4,1.931E-4, - 4 1.961E-4,1.991E-4,2.019E-4,2.048E-4,2.075E-4,2.102E-4,2.129E-4, - 5 2.154E-4,2.180E-4,2.205E-4,2.229E-4,2.253E-4,2.277E-4,2.300E-4, - 6 2.323E-4,2.346E-4,2.368E-4,2.390E-4,2.411E-4,2.432E-4,2.453E-4, - 7 2.474E-4,2.494E-4,2.515E-4,2.535E-4,2.554E-4,2.574E-4,2.593E-4, - 8 2.612E-4,2.631E-4,2.649E-4,2.668E-4,2.686E-4,2.704E-4,2.722E-4, - 9 2.740E-4,2.757E-4,2.775E-4,2.792E-4,2.809E-4,2.826E-4 / - DATA (COA(I,42),I=1,62) / - 1 1.063E-4,1.148E-4,1.226E-4,1.297E-4,1.363E-4,1.425E-4,1.483E-4, - 2 1.538E-4,1.590E-4,1.639E-4,1.687E-4,1.732E-4,1.775E-4,1.817E-4, - 3 1.857E-4,1.896E-4,1.933E-4,1.970E-4,2.005E-4,2.039E-4,2.073E-4, - 4 2.105E-4,2.137E-4,2.168E-4,2.198E-4,2.228E-4,2.257E-4,2.286E-4, - 5 2.314E-4,2.341E-4,2.368E-4,2.394E-4,2.420E-4,2.446E-4,2.471E-4, - 6 2.496E-4,2.520E-4,2.544E-4,2.568E-4,2.591E-4,2.615E-4,2.637E-4, - 7 2.660E-4,2.682E-4,2.704E-4,2.726E-4,2.747E-4,2.768E-4,2.789E-4, - 8 2.810E-4,2.831E-4,2.851E-4,2.871E-4,2.891E-4,2.911E-4,2.930E-4, - 9 2.950E-4,2.969E-4,2.988E-4,3.007E-4,3.025E-4,3.044E-4 / - DATA (COA(I,43),I=1,62) / - 1 1.141E-4,1.233E-4,1.316E-4,1.393E-4,1.464E-4,1.531E-4,1.593E-4, - 2 1.652E-4,1.707E-4,1.760E-4,1.811E-4,1.859E-4,1.905E-4,1.950E-4, - 3 1.993E-4,2.035E-4,2.075E-4,2.114E-4,2.152E-4,2.189E-4,2.225E-4, - 4 2.260E-4,2.294E-4,2.328E-4,2.360E-4,2.393E-4,2.424E-4,2.455E-4, - 5 2.485E-4,2.515E-4,2.544E-4,2.573E-4,2.601E-4,2.629E-4,2.656E-4, - 6 2.683E-4,2.709E-4,2.736E-4,2.762E-4,2.787E-4,2.812E-4,2.837E-4, - 7 2.862E-4,2.886E-4,2.910E-4,2.934E-4,2.957E-4,2.980E-4,3.003E-4, - 8 3.026E-4,3.048E-4,3.071E-4,3.093E-4,3.114E-4,3.136E-4,3.157E-4, - 9 3.179E-4,3.200E-4,3.221E-4,3.241E-4,3.262E-4,3.282E-4 / - DATA (COA(I,44),I=1,62) / - 1 1.224E-4,1.323E-4,1.413E-4,1.496E-4,1.572E-4,1.643E-4,1.709E-4, - 2 1.772E-4,1.832E-4,1.888E-4,1.943E-4,1.994E-4,2.044E-4,2.092E-4, - 3 2.138E-4,2.183E-4,2.226E-4,2.269E-4,2.309E-4,2.349E-4,2.388E-4, - 4 2.426E-4,2.463E-4,2.499E-4,2.535E-4,2.570E-4,2.604E-4,2.637E-4, - 5 2.670E-4,2.702E-4,2.734E-4,2.765E-4,2.796E-4,2.826E-4,2.856E-4, - 6 2.886E-4,2.915E-4,2.943E-4,2.972E-4,2.999E-4,3.027E-4,3.054E-4, - 7 3.081E-4,3.108E-4,3.134E-4,3.160E-4,3.185E-4,3.211E-4,3.236E-4, - 8 3.261E-4,3.286E-4,3.310E-4,3.334E-4,3.358E-4,3.382E-4,3.405E-4, - 9 3.428E-4,3.451E-4,3.474E-4,3.497E-4,3.519E-4,3.542E-4 / - DATA (COA(I,45),I=1,62) / - 1 1.312E-4,1.419E-4,1.515E-4,1.603E-4,1.685E-4,1.761E-4,1.832E-4, - 2 1.899E-4,1.963E-4,2.024E-4,2.082E-4,2.138E-4,2.191E-4,2.243E-4, - 3 2.292E-4,2.341E-4,2.387E-4,2.433E-4,2.477E-4,2.520E-4,2.562E-4, - 4 2.603E-4,2.644E-4,2.683E-4,2.722E-4,2.759E-4,2.796E-4,2.833E-4, - 5 2.869E-4,2.904E-4,2.939E-4,2.973E-4,3.006E-4,3.039E-4,3.072E-4, - 6 3.104E-4,3.136E-4,3.167E-4,3.198E-4,3.228E-4,3.259E-4,3.288E-4, - 7 3.318E-4,3.347E-4,3.376E-4,3.404E-4,3.432E-4,3.460E-4,3.487E-4, - 8 3.515E-4,3.542E-4,3.568E-4,3.595E-4,3.621E-4,3.647E-4,3.673E-4, - 9 3.698E-4,3.724E-4,3.749E-4,3.773E-4,3.798E-4,3.822E-4 / - DATA (COA(I,46),I=1,62) / - 1 1.406E-4,1.520E-4,1.623E-4,1.718E-4,1.805E-4,1.886E-4,1.963E-4, - 2 2.035E-4,2.103E-4,2.168E-4,2.231E-4,2.291E-4,2.348E-4,2.404E-4, - 3 2.458E-4,2.510E-4,2.561E-4,2.610E-4,2.658E-4,2.705E-4,2.750E-4, - 4 2.795E-4,2.839E-4,2.882E-4,2.924E-4,2.965E-4,3.005E-4,3.045E-4, - 5 3.084E-4,3.123E-4,3.161E-4,3.198E-4,3.235E-4,3.271E-4,3.307E-4, - 6 3.342E-4,3.376E-4,3.411E-4,3.445E-4,3.478E-4,3.511E-4,3.544E-4, - 7 3.576E-4,3.608E-4,3.639E-4,3.670E-4,3.701E-4,3.731E-4,3.762E-4, - 8 3.791E-4,3.821E-4,3.850E-4,3.879E-4,3.908E-4,3.936E-4,3.965E-4, - 9 3.992E-4,4.020E-4,4.047E-4,4.075E-4,4.102E-4,4.128E-4 / - DATA (COA(I,47),I=1,62) / - 1 1.506E-4,1.628E-4,1.739E-4,1.840E-4,1.934E-4,2.021E-4,2.103E-4, - 2 2.180E-4,2.254E-4,2.324E-4,2.391E-4,2.456E-4,2.518E-4,2.579E-4, - 3 2.637E-4,2.694E-4,2.749E-4,2.802E-4,2.854E-4,2.905E-4,2.955E-4, - 4 3.004E-4,3.052E-4,3.099E-4,3.145E-4,3.190E-4,3.234E-4,3.278E-4, - 5 3.320E-4,3.362E-4,3.404E-4,3.445E-4,3.485E-4,3.524E-4,3.564E-4, - 6 3.602E-4,3.640E-4,3.678E-4,3.715E-4,3.751E-4,3.787E-4,3.823E-4, - 7 3.858E-4,3.893E-4,3.928E-4,3.962E-4,3.995E-4,4.029E-4,4.062E-4, - 8 4.094E-4,4.127E-4,4.159E-4,4.190E-4,4.222E-4,4.253E-4,4.283E-4, - 9 4.314E-4,4.344E-4,4.374E-4,4.404E-4,4.433E-4,4.462E-4 / - DATA (COA(I,48),I=1,62) / - 1 1.613E-4,1.744E-4,1.863E-4,1.971E-4,2.072E-4,2.165E-4,2.254E-4, - 2 2.337E-4,2.417E-4,2.493E-4,2.565E-4,2.636E-4,2.703E-4,2.769E-4, - 3 2.832E-4,2.894E-4,2.954E-4,3.013E-4,3.070E-4,3.125E-4,3.180E-4, - 4 3.233E-4,3.286E-4,3.337E-4,3.387E-4,3.436E-4,3.485E-4,3.533E-4, - 5 3.579E-4,3.625E-4,3.671E-4,3.716E-4,3.760E-4,3.803E-4,3.846E-4, - 6 3.888E-4,3.929E-4,3.971E-4,4.011E-4,4.051E-4,4.091E-4,4.130E-4, - 7 4.168E-4,4.206E-4,4.244E-4,4.281E-4,4.318E-4,4.354E-4,4.390E-4, - 8 4.426E-4,4.461E-4,4.496E-4,4.530E-4,4.565E-4,4.598E-4,4.632E-4, - 9 4.665E-4,4.698E-4,4.730E-4,4.763E-4,4.795E-4,4.826E-4 / - DATA (COA(I,49),I=1,62) / - 1 1.728E-4,1.868E-4,1.996E-4,2.112E-4,2.220E-4,2.321E-4,2.417E-4, - 2 2.507E-4,2.593E-4,2.676E-4,2.755E-4,2.831E-4,2.905E-4,2.977E-4, - 3 3.046E-4,3.113E-4,3.179E-4,3.243E-4,3.305E-4,3.366E-4,3.426E-4, - 4 3.484E-4,3.542E-4,3.598E-4,3.653E-4,3.707E-4,3.760E-4,3.812E-4, - 5 3.863E-4,3.914E-4,3.963E-4,4.012E-4,4.060E-4,4.108E-4,4.154E-4, - 6 4.201E-4,4.246E-4,4.291E-4,4.335E-4,4.379E-4,4.422E-4,4.464E-4, - 7 4.506E-4,4.548E-4,4.589E-4,4.629E-4,4.669E-4,4.709E-4,4.748E-4, - 8 4.787E-4,4.825E-4,4.863E-4,4.900E-4,4.937E-4,4.974E-4,5.010E-4, - 9 5.046E-4,5.082E-4,5.117E-4,5.152E-4,5.187E-4,5.221E-4 / - DATA (COA(I,50),I=1,62) / - 1 1.851E-4,2.003E-4,2.139E-4,2.265E-4,2.382E-4,2.491E-4,2.595E-4, - 2 2.693E-4,2.787E-4,2.877E-4,2.963E-4,3.047E-4,3.127E-4,3.205E-4, - 3 3.281E-4,3.355E-4,3.427E-4,3.497E-4,3.565E-4,3.632E-4,3.697E-4, - 4 3.761E-4,3.824E-4,3.885E-4,3.945E-4,4.004E-4,4.062E-4,4.119E-4, - 5 4.175E-4,4.230E-4,4.285E-4,4.338E-4,4.390E-4,4.442E-4,4.493E-4, - 6 4.543E-4,4.593E-4,4.641E-4,4.689E-4,4.737E-4,4.784E-4,4.830E-4, - 7 4.875E-4,4.920E-4,4.965E-4,5.009E-4,5.052E-4,5.095E-4,5.138E-4, - 8 5.179E-4,5.221E-4,5.262E-4,5.302E-4,5.342E-4,5.268E-4,5.421E-4, - 9 5.460E-4,5.499E-4,5.537E-4,5.574E-4,5.612E-4,5.649E-4 / - DATA (COA(I,51),I=1,62) / - 1 1.985E-4,2.149E-4,2.297E-4,2.433E-4,2.559E-4,2.679E-4,2.791E-4, - 2 2.898E-4,3.001E-4,3.099E-4,3.193E-4,3.285E-4,3.373E-4,3.459E-4, - 3 3.542E-4,3.622E-4,3.701E-4,3.778E-4,3.853E-4,3.926E-4,3.997E-4, - 4 4.067E-4,4.135E-4,4.202E-4,4.268E-4,4.333E-4,4.396E-4,4.458E-4, - 5 4.519E-4,4.579E-4,4.638E-4,4.696E-4,4.753E-4,4.809E-4,4.864E-4, - 6 4.919E-4,4.972E-4,5.025E-4,5.077E-4,5.129E-4,5.179E-4,5.229E-4, - 7 5.279E-4,5.327E-4,5.375E-4,5.423E-4,5.470E-4,5.516E-4,5.562E-4, - 8 5.607E-4,5.652E-4,5.696E-4,5.739E-4,5.782E-4,5.825E-4,5.867E-4, - 9 5.909E-4,5.951E-4,5.991E-4,6.032E-4,6.072E-4,6.112E-4 / - DATA (COA(I,52),I=1,62) / - 1 2.132E-4,2.309E-4,2.469E-4,2.617E-4,2.755E-4,2.885E-4,3.008E-4, - 2 3.125E-4,3.237E-4,3.345E-4,3.449E-4,3.549E-4,3.645E-4,3.739E-4, - 3 3.830E-4,3.918E-4,4.004E-4,4.088E-4,4.170E-4,4.250E-4,4.328E-4, - 4 4.404E-4,4.478E-4,4.551E-4,4.623E-4,4.693E-4,4.762E-4,4.829E-4, - 5 4.895E-4,4.960E-4,5.024E-4,5.087E-4,5.149E-4,5.210E-4,5.269E-4, - 6 5.328E-4,5.272E-4,5.443E-4,5.500E-4,5.555E-4,5.609E-4,5.663E-4, - 7 5.717E-4,5.769E-4,5.821E-4,5.872E-4,5.922E-4,5.972E-4,6.021E-4, - 8 6.070E-4,6.118E-4,6.165E-4,6.212E-4,6.258E-4,6.304E-4,6.349E-4, - 9 6.394E-4,6.438E-4,6.482E-4,6.525E-4,6.568E-4,6.611E-4 / - DATA (COA(I,53),I=1,62) / - 1 2.293E-4,2.485E-4,2.660E-4,2.821E-4,2.972E-4,3.114E-4,3.249E-4, - 2 3.377E-4,3.500E-4,3.618E-4,3.732E-4,3.841E-4,3.947E-4,4.049E-4, - 3 4.149E-4,4.245E-4,4.339E-4,4.430E-4,4.520E-4,4.606E-4,4.691E-4, - 4 4.774E-4,4.855E-4,4.934E-4,5.012E-4,5.087E-4,5.162E-4,5.235E-4, - 5 5.306E-4,5.377E-4,5.446E-4,5.513E-4,5.580E-4,5.646E-4,5.710E-4, - 6 5.773E-4,5.836E-4,5.897E-4,5.957E-4,6.017E-4,6.076E-4,6.134E-4, - 7 6.191E-4,6.247E-4,6.302E-4,6.357E-4,6.411E-4,6.464E-4,6.517E-4, - 8 6.569E-4,6.620E-4,6.671E-4,6.721E-4,6.771E-4,6.820E-4,6.868E-4, - 9 6.916E-4,6.963E-4,7.010E-4,7.056E-4,7.102E-4,7.147E-4 / - DATA (COA(I,54),I=1,62) / - 1 2.471E-4,2.680E-4,2.871E-4,3.048E-4,3.214E-4,3.369E-4,3.517E-4, - 2 3.658E-4,3.792E-4,3.921E-4,4.045E-4,4.165E-4,4.281E-4,4.392E-4, - 3 4.501E-4,4.606E-4,4.708E-4,4.807E-4,4.903E-4,4.998E-4,5.089E-4, - 4 5.179E-4,5.267E-4,5.352E-4,5.436E-4,5.518E-4,5.598E-4,5.677E-4, - 5 5.754E-4,5.829E-4,5.903E-4,5.976E-4,6.048E-4,6.118E-4,6.187E-4, - 6 6.255E-4,6.322E-4,6.388E-4,6.453E-4,6.516E-4,6.579E-4,6.641E-4, - 7 6.702E-4,6.762E-4,6.822E-4,6.880E-4,6.938E-4,6.995E-4,7.051E-4, - 8 7.106E-4,7.161E-4,7.215E-4,7.269E-4,7.321E-4,7.374E-4,7.425E-4, - 9 7.476E-4,7.527E-4,7.576E-4,7.626E-4,7.674E-4,7.723E-4 / - DATA (COA(I,55),I=1,62) / - 1 2.669E-4,2.898E-4,3.107E-4,3.300E-4,3.482E-4,3.653E-4,3.815E-4, - 2 3.969E-4,4.116E-4,4.257E-4,4.392E-4,4.522E-4,4.648E-4,4.769E-4, - 3 4.887E-4,5.001E-4,5.111E-4,5.218E-4,5.323E-4,5.425E-4,5.524E-4, - 4 5.620E-4,5.714E-4,5.807E-4,5.897E-4,5.985E-4,6.071E-4,6.155E-4, - 5 6.238E-4,6.319E-4,6.398E-4,6.476E-4,6.553E-4,6.628E-4,6.702E-4, - 6 6.775E-4,6.846E-4,6.917E-4,6.986E-4,7.054E-4,7.121E-4,7.187E-4, - 7 7.252E-4,7.316E-4,7.379E-4,7.442E-4,7.503E-4,7.564E-4,7.624E-4, - 8 7.683E-4,7.741E-4,7.798E-4,7.855E-4,7.911E-4,7.967E-4,8.022E-4, - 9 8.076E-4,8.129E-4,8.182E-4,8.235E-4,8.286E-4,8.337E-4/ - DATA (COA(I,56),I=1,62) / - 1 2.889E-4,3.140E-4,3.369E-4,3.582E-4,3.780E-4,3.967E-4,4.144E-4, - 2 4.312E-4,4.473E-4,4.626E-4,4.773E-4,4.914E-4,5.050E-4,5.182E-4, - 3 5.309E-4,5.432E-4,5.551E-4,5.666E-4,5.779E-4,5.888E-4,5.995E-4, - 4 6.098E-4,6.200E-4,6.298E-4,6.395E-4,6.489E-4,6.581E-4,6.672E-4, - 5 6.760E-4,6.847E-4,6.932E-4,7.015E-4,7.097E-4,7.177E-4,7.256E-4, - 6 7.333E-4,7.409E-4,7.484E-4,7.558E-4,7.630E-4,7.702E-4,7.772E-4, - 7 7.841E-4,7.909E-4,7.976E-4,8.043E-4,8.108E-4,8.172E-4,8.236E-4, - 8 8.298E-4,8.360E-4,8.421E-4,8.481E-4,8.541E-4,8.600E-4,8.658E-4, - 9 8.715E-4,8.772E-4,8.828E-4,8.883E-4,8.938E-4,8.992E-4/ - DATA (COA(I,57),I=1,62) / - 1 3.135E-4,3.410E-4,3.662E-4,3.895E-4,4.112E-4,4.316E-4,4.509E-4, - 2 4.692E-4,4.866E-4,5.032E-4,5.191E-4,5.344E-4,5.491E-4,5.632E-4, - 3 5.769E-4,5.901E-4,6.029E-4,6.153E-4,6.274E-4,6.391E-4,6.505E-4, - 4 6.616E-4,6.725E-4,6.830E-4,6.933E-4,7.034E-4,7.132E-4,7.229E-4, - 5 7.323E-4,7.415E-4,7.506E-4,7.595E-4,7.682E-4,7.767E-4,7.851E-4, - 6 7.933E-4,8.014E-4,8.093E-4,8.172E-4,8.249E-4,8.324E-4,8.399E-4, - 7 8.472E-4,8.544E-4,8.615E-4,8.685E-4,8.755E-4,8.823E-4,8.890E-4, - 8 8.956E-4,9.021E-4,9.086E-4,9.149E-4,9.212E-4,9.274E-4,9.335E-4, - 9 9.396E-4,9.455E-4,9.514E-4,9.573E-4,9.630E-4,9.687E-4 / - DATA (COA(I,58),I=1,62) / - 1 3.409E-4,3.711E-4,3.987E-4,4.241E-4,4.478E-4,4.700E-4,4.909E-4, - 2 5.107E-4,5.295E-4,5.474E-4,5.645E-4,5.810E-4,5.968E-4,6.120E-4, - 3 6.267E-4,6.408E-4,6.545E-4,6.678E-4,6.807E-4,6.932E-4,7.054E-4, - 4 7.173E-4,7.288E-4,7.401E-4,7.510E-4,7.618E-4,7.722E-4,7.825E-4, - 5 7.925E-4,8.023E-4,8.119E-4,8.213E-4,8.306E-4,8.396E-4,8.485E-4, - 6 8.572E-4,8.658E-4,8.742E-4,8.824E-4,8.906E-4,8.986E-4,9.064E-4, - 7 9.142E-4,9.218E-4,9.293E-4,9.367E-4,9.439E-4,9.511E-4,9.582E-4, - 8 9.652E-4,9.720E-4,9.788E-4,9.855E-4,9.921E-4,9.986E-4,1.0050E-3, - 9 1.0113E-3,1.0176E-3,1.0238E-3,1.0299E-3,1.0359E-3,1.0419E-3 / - DATA (COA(I,59),I=1,62) / - 1 0.3715E-3,0.4046E-3,0.4346E-3,0.4623E-3,0.4880E-3,0.5120E-3, - 2 0.5346E-3,0.5560E-3,0.5762E-3,0.5955E-3,0.6139E-3,0.6315E-3, - 3 0.6485E-3,0.6648E-3,0.6804E-3,0.6956E-3,0.7102E-3,0.7244E-3, - 4 0.7382E-3,0.7515E-3,0.7645E-3,0.7771E-3,0.7893E-3,0.8012E-3, - 5 0.8129E-3,0.8243E-3,0.8354E-3,0.8463E-3,0.8569E-3,0.8673E-3, - 6 0.8774E-3,0.8874E-3,0.8971E-3,0.9067E-3,0.9160E-3,0.9252E-3, - 7 0.9342E-3,0.9431E-3,0.9518E-3,0.9604E-3,0.9688E-3,0.9770E-3, - 8 0.9851E-3,0.9931E-3,1.0010E-3,1.0088E-3,1.0164E-3,1.0239E-3, - 9 1.0313E-3,1.0386E-3,1.0458E-3,1.0529E-3,1.0598E-3,1.0667E-3, - A 1.0735E-3,1.0802E-3,1.0869E-3,1.0934E-3,1.0998E-3,1.1062E-3, - B 1.1125E-3,1.1187E-3 / - DATA (COA(I,60),I=1,62) / - 1 0.4055E-3,0.4415E-3,0.4742E-3,0.5042E-3,0.5320E-3,0.5579E-3, - 2 0.5822E-3,0.6052E-3,0.6269E-3,0.6476E-3,0.6673E-3,0.6862E-3, - 3 0.7042E-3,0.7216E-3,0.7383E-3,0.7545E-3,0.7701E-3,0.7851E-3, - 4 0.7997E-3,0.8139E-3,0.8276E-3,0.8410E-3,0.8540E-3,0.8666E-3, - 5 0.8789E-3,0.8910E-3,0.9027E-3,0.9141E-3,0.9253E-3,0.9362E-3, - 6 0.9469E-3,0.9574E-3,0.9676E-3,0.9777E-3,0.9875E-3,0.9972E-3, - 7 1.0066E-3,1.0159E-3,1.0250E-3,1.0339E-3,1.0427E-3,1.0514E-3, - 8 1.0599E-3,1.0682E-3,1.0764E-3,1.0845E-3,1.0925E-3,1.1003E-3, - 9 1.1080E-3,1.1156E-3,1.1231E-3,1.1304E-3,1.1377E-3,1.1449E-3, - A 1.1519E-3,1.1589E-3,1.1658E-3,1.1726E-3,1.1793E-3,1.1859E-3, - 6 1.1924E-3,1.1989E-3 / - DATA (COA(I,61),I=1,62) / - 1 0.4429E-3,0.4821E-3,0.5175E-3,0.5499E-3,0.5798E-3,0.6076E-3, - 2 0.6337E-3,0.6583E-3,0.6816E-3,0.7037E-3,0.7247E-3,0.7448E-3, - 3 0.7640E-3,0.7825E-3,0.8003E-3,0.8174E-3,0.8339E-3,0.8499E-3, - 4 0.8653E-3,0.8803E-3,0.8948E-3,0.9089E-3,0.9226E-3,0.9359E-3, - 5 0.9488E-3,0.9615E-3,0.9738E-3,0.9858E-3,0.9975E-3,1.0089E-3, - 6 1.0201E-3,1.0311E-3,1.0418E-3,1.0523E-3,1.0625E-3,1.0726E-3, - 7 1.0825E-3,1.0921E-3,1.1016E-3,1.1109E-3,1.1201E-3,1.1291E-3, - 8 1.1379E-3,1.1466E-3,1.1551E-3,1.1635E-3,1.1718E-3,1.1799E-3, - 9 1.1879E-3,1.1958E-3,1.2035E-3,1.2112E-3,1.2187E-3,1.2261E-3, - A 1.2335E-3,1.2407E-3,1.2478E-3,1.2548E-3,1.2618E-3,1.2686E-3, - B 1.2754E-3,1.2821E-3 / - DATA (COA(I,62),I=1,62) / - 1 0.4840E-3,0.5264E-3,0.5646E-3,0.5994E-3,0.6316E-3,0.6614E-3, - 2 0.6893E-3,0.7155E-3,0.7403E-3,0.7638E-3,0.7862E-3,0.8075E-3, - 3 0.8279E-3,0.8475E-3,0.8663E-3,0.8844E-3,0.9018E-3,0.9186E-3, - 4 0.9349E-3,0.9506E-3,0.9658E-3,0.9806E-3,0.9950E-3,1.0089E-3, - 5 1.0225E-3,1.0356E-3,1.0485E-3,1.0610E-3,1.0733E-3,1.0852E-3, - 6 1.0968E-3,1.1082E-3,1.1194E-3,1.1303E-3,1.1409E-3,1.1514E-3, - 7 1.1616E-3,1.1717E-3,1.1815E-3,1.1912E-3,1.2007E-3,1.2100E-3, - 8 1.2191E-3,1.2281E-3,1.2370E-3,1.2457E-3,1.2542E-3,1.2627E-3, - 9 1.2709E-3,1.2791E-3,1.2871E-3,1.2951E-3,1.3029E-3,1.3106E-3, - A 1.3181E-3,1.3256E-3,1.3330E-3,1.3403E-3,1.3475E-3,1.3546E-3, - B 1.3616E-3,1.3685E-3 / - DATA (COA(I,63),I=1,62) / - 1 0.5290E-3,0.5747E-3,0.6157E-3,0.6530E-3,0.6874E-3,0.7192E-3, - 2 0.7490E-3,0.7769E-3,0.8032E-3,0.8281E-3,0.8518E-3,0.8743E-3, - 3 0.8959E-3,0.9165E-3,0.9362E-3,0.9552E-3,0.9735E-3,0.9911E-3, - 4 1.0082E-3,1.0246E-3,1.0405E-3,1.0559E-3,1.0709E-3,1.0854E-3, - 5 1.0995E-3,1.1132E-3,1.1266E-3,1.1396E-3,1.1523E-3,1.1647E-3, - 6 1.1768E-3,1.1886E-3,1.2002E-3,1.2115E-3,1.2225E-3,1.2334E-3, - 7 1.2440E-3,1.2544E-3,1.2646E-3,1.2746E-3,1.2844E-3,1.2941E-3, - 8 1.3036E-3,1.3129E-3,1.3220E-3,1.3310E-3,1.3399E-3,1.3486E-3, - 9 1.3572E-3,1.3657E-3,1.3740E-3,1.3823E-3,1.3904E-3,1.3983E-3, - A 1.4062E-3,1.4140E-3,1.4217E-3,1.4292E-3,1.4367E-3,1.4441E-3, - B 1.4514E-3,1.4586E-3 / - DATA (COA(I,64),I=1,62) / - 1 0.5778E-3,0.6269E-3,0.6708E-3,0.7107E-3,0.7473E-3,0.7812E-3, - 2 0.8127E-3,0.8423E-3,0.8701E-3,0.8964E-3,0.9213E-3,0.9450E-3, - 3 0.9676E-3,0.9892E-3,1.0099E-3,1.0297E-3,1.0488E-3,1.0671E-3, - 4 1.0848E-3,1.1020E-3,1.1185E-3,1.1345E-3,1.1500E-3,1.1651E-3, - 5 1.1798E-3,1.1940E-3,1.2078E-3,1.2213E-3,1.2345E-3,1.2473E-3, - 6 1.2599E-3,1.2721E-3,1.2841E-3,1.2958E-3,1.3073E-3,1.3185E-3, - 7 1.3295E-3,1.3403E-3,1.3509E-3,1.3612E-3,1.3714E-3,1.3815E-3, - 8 1.3913E-3,1.4010E-3,1.4105E-3,1.4199E-3,1.4291E-3,1.4382E-3, - 9 1.4471E-3,1.4559E-3,1.4646E-3,1.4732E-3,1.4816E-3,1.4900E-3, - A 1.4982E-3,1.5063E-3,1.5143E-3,1.5222E-3,1.5300E-3,1.5377E-3, - B 1.5453E-3,1.5528E-3 / - DATA (COA(I,65),I=1,62) / - 1 0.6307E-3,0.6832E-3,0.7301E-3,0.7725E-3,0.8114E-3,0.8472E-3, - 2 0.8805E-3,0.9116E-3,0.9409E-3,0.9684E-3,0.9945E-3,1.0193E-3, - 3 1.0428E-3,1.0653E-3,1.0868E-3,1.1075E-3,1.1273E-3,1.1464E-3, - 4 1.1647E-3,1.1825E-3,1.1996E-3,1.2162E-3,1.2323E-3,1.2480E-3, - 5 1.2631E-3,1.2779E-3,1.2922E-3,1.3062E-3,1.3199E-3,1.3332E-3, - 6 1.3462E-3,1.3589E-3,1.3713E-3,1.3835E-3,1.3954E-3,1.4071E-3, - 7 1.4186E-3,1.4298E-3,1.4408E-3,1.4516E-3,1.4623E-3,1.4727E-3, - 8 1.4830E-3,1.4931E-3,1.5030E-3,1.5128E-3,1.5225E-3,1.5319E-3, - 9 1.5413E-3,1.5505E-3,1.5596E-3,1.5686E-3,1.5774E-3,1.5862E-3, - A 1.5948E-3,1.6033E-3,1.6117E-3,1.6200E-3,1.6282E-3,1.6363E-3, - B 1.6443E-3,1.6522E-3 / - DATA (COA(I,66),I=1,62) / - 1 0.6876E-3,0.7436E-3,0.7934E-3,0.8383E-3,0.8793E-3,0.9170E-3, - 2 0.9520E-3,0.9846E-3,1.0150E-3,1.0439E-3,1.0710E-3,1.0968E-3, - 3 1.1213E-3,1.1446E-3,1.1669E-3,1.1883E-3,1.2089E-3,1.2287E-3, - 4 1.2477E-3,1.2661E-3,1.2839E-3,1.3011E-3,1.3178E-3,1.3340E-3, - 5 1.3498E-3,1.3651E-3,1.3800E-3,1.3946E-3,1.4088E-3,1.4227E-3, - 6 1.4362E-3,1.4495E-3,1.4624E-3,1.4751E-3,1.4876E-3,1.4998E-3, - 7 1.5117E-3,1.5235E-3,1.5350E-3,1.5464E-3,1.5575E-3,1.5685E-3, - 8 1.5792E-3,1.5899E-3,1.6003E-3,1.6106E-3,1.6207E-3,1.6307E-3, - 9 1.6405E-3,1.6502E-3,1.6598E-3,1.6693E-3,1.6786E-3,1.6878E-3, - A 1.6969E-3,1.7059E-3,1.7147E-3,1.7235E-3,1.7322E-3,1.7407E-3, - B 1.7492E-3,1.7575E-3 / - DATA (COA(I,67),I=1,62) / - 1 0.7485E-3,0.8080E-3,0.8606E-3,0.9079E-3,0.9509E-3,0.9904E-3, - 2 1.0269E-3,1.0608E-3,1.0926E-3,1.1225E-3,1.1507E-3,1.1774E-3, - 3 1.2028E-3,1.2270E-3,1.2501E-3,1.2723E-3,1.2936E-3,1.3142E-3, - 4 1.3339E-3,1.3531E-3,1.3716E-3,1.3895E-3,1.4069E-3,1.4238E-3, - 5 1.4402E-3,1.4562E-3,1.4718E-3,1.4870E-3,1.5019E-3,1.5164E-3, - 6 1.5306E-3,1.5445E-3,1.5581E-3,1.5714E-3,1.5845E-3,1.5973E-3, - 7 1.6099E-3,1.6223E-3,1.6344E-3,1.6464E-3,1.6581E-3,1.6697E-3, - 8 1.6811E-3,1.6922E-3,1.7033E-3,1.7141E-3,1.7249E-3,1.7354E-3, - 9 1.7458E-3,1.7561E-3,1.7662E-3,1.7762E-3,1.7861E-3,1.7959E-3, - A 1.8055E-3,1.8150E-3,1.8244E-3,1.8337E-3,1.8429E-3,1.8520E-3, - B 1.8610E-3,1.8698E-3 / - DATA (COA(I,68),I=1,62) / - 1 0.8135E-3,0.8762E-3,0.9315E-3,0.9811E-3,1.0259E-3,1.0670E-3, - 2 1.1050E-3,1.1402E-3,1.1732E-3,1.2042E-3,1.2334E-3,1.2611E-3, - 3 1.2874E-3,1.3126E-3,1.3366E-3,1.3597E-3,1.3819E-3,1.4033E-3, - 4 1.4239E-3,1.4439E-3,1.4632E-3,1.4820E-3,1.5002E-3,1.5179E-3, - 5 1.5351E-3,1.5519E-3,1.5683E-3,1.5843E-3,1.6000E-3,1.6153E-3, - 6 1.6302E-3,1.6449E-3,1.6592E-3,1.6733E-3,1.6871E-3,1.7007E-3, - 7 1.7140E-3,1.7271E-3,1.7400E-3,1.7526E-3,1.7651E-3,1.7773E-3, - 8 1.7894E-3,1.8012E-3,1.8129E-3,1.8245E-3,1.8358E-3,1.8471E-3, - 9 1.8581E-3,1.8690E-3,1.8798E-3,1.8904E-3,1.9009E-3,1.9113E-3, - A 1.9215E-3,1.9316E-3,1.9416E-3,1.9515E-3,1.9613E-3,1.9709E-3, - B 1.9805E-3,1.9899E-3 / - DATA (COA(I,69),I=1,62) / - 1 0.8823E-3,0.9481E-3,1.0059E-3,1.0575E-3,1.1042E-3,1.1468E-3, - 2 1.1862E-3,1.2227E-3,1.2569E-3,1.2891E-3,1.3195E-3,1.3483E-3, - 3 1.3757E-3,1.4020E-3,1.4271E-3,1.4512E-3,1.4744E-3,1.4968E-3, - 4 1.5185E-3,1.5395E-3,1.5598E-3,1.5795E-3,1.5987E-3,1.6174E-3, - 5 1.6356E-3,1.6533E-3,1.6707E-3,1.6876E-3,1.7041E-3,1.7203E-3, - 6 1.7362E-3,1.7517E-3,1.7669E-3,1.7819E-3,1.7965E-3,1.8109E-3, - 7 1.8251E-3,1.8390E-3,1.8527E-3,1.8661E-3,1.8793E-3,1.8924E-3, - 8 1.9052E-3,1.9178E-3,1.9303E-3,1.9425E-3,1.9546E-3,1.9665E-3, - 9 1.9783E-3,1.9899E-3,2.0014E-3,2.0127E-3,2.0238E-3,2.0348E-3, - A 2.0457E-3,2.0565E-3,2.0671E-3,2.0776E-3,2.0880E-3,2.0983E-3, - B 2.1084E-3,2.1185E-3 / - DATA (COA(I,70),I=1,62) / - 1 0.9546E-3,1.0233E-3,1.0834E-3,1.1370E-3,1.1854E-3,1.2297E-3, - 2 1.2705E-3,1.3085E-3,1.3441E-3,1.3776E-3,1.4093E-3,1.4395E-3, - 3 1.4682E-3,1.4957E-3,1.5221E-3,1.5475E-3,1.5720E-3,1.5956E-3, - 4 1.6185E-3,1.6406E-3,1.6621E-3,1.6830E-3,1.7033E-3,1.7231E-3, - 5 1.7424E-3,1.7613E-3,1.7797E-3,1.7976E-3,1.8152E-3,1.8324E-3, - 6 1.8493E-3,1.8658E-3,1.8820E-3,1.8979E-3,1.9135E-3,1.9288E-3, - 7 1.9439E-3,1.9587E-3,1.9732E-3,1.9875E-3,2.0016E-3,2.0155E-3, - 8 2.0291E-3,2.0425E-3,2.0558E-3,2.0688E-3,2.0817E-3,2.0944E-3, - 9 2.1069E-3,2.1192E-3,2.1314E-3,2.1434E-3,2.1095E-3,2.1670E-3, - A 2.1786E-3,2.1900E-3,2.2013E-3,2.2125E-3,2.2235E-3,2.2344E-3, - B 2.2452E-3,2.2558E-3 / - DATA (COA(I,71),I=1,62) / - 1 1.0302E-3,1.1016E-3,1.1640E-3,1.2195E-3,1.2698E-3,1.3159E-3, - 2 1.3584E-3,1.3981E-3,1.4354E-3,1.4705E-3,1.5038E-3,1.5355E-3, - 3 1.5658E-3,1.5948E-3,1.6227E-3,1.6496E-3,1.6755E-3,1.7005E-3, - 4 1.7248E-3,1.7483E-3,1.7712E-3,1.7934E-3,1.8150E-3,1.8360E-3, - 5 1.8566E-3,1.8766E-3,1.8962E-3,1.9153E-3,1.9340E-3,1.9524E-3, - 6 1.9703E-3,1.9879E-3,2.0052E-3,2.0221E-3,2.0387E-3,2.0550E-3, - 7 2.0710E-3,2.0867E-3,2.1022E-3,2.1174E-3,2.1324E-3,2.1471E-3, - 8 2.1159E-3,2.1759E-3,2.1900E-3,2.2039E-3,2.2175E-3,2.2310E-3, - 9 2.2443E-3,2.2574E-3,2.2703E-3,2.2830E-3,2.2956E-3,2.3080E-3, - A 2.3203E-3,2.3324E-3,2.3443E-3,2.3562E-3,2.3678E-3,2.3794E-3, - B 2.3908E-3,2.4020E-3 / - DATA (COA(I,72),I=1,62) / - 1 1.1087E-3,1.1828E-3,1.2476E-3,1.3054E-3,1.3579E-3,1.4060E-3, - 2 1.4506E-3,1.4923E-3,1.5315E-3,1.5685E-3,1.6038E-3,1.6373E-3, - 3 1.6694E-3,1.7002E-3,1.7298E-3,1.7583E-3,1.7859E-3,1.8125E-3, - 4 1.8384E-3,1.8634E-3,1.8877E-3,1.9114E-3,1.9344E-3,1.9568E-3, - 5 1.9787E-3,2.0000E-3,2.0209E-3,2.0412E-3,2.0612E-3,2.0807E-3, - 6 2.0998E-3,2.1185E-3,2.1368E-3,2.1090E-3,2.1725E-3,2.1898E-3, - 7 2.2068E-3,2.2235E-3,2.2399E-3,2.2561E-3,2.2720E-3,2.2876E-3, - 8 2.3029E-3,2.3181E-3,2.3330E-3,2.3477E-3,2.3621E-3,2.3764E-3, - 9 2.3904E-3,2.4042E-3,2.4179E-3,2.4314E-3,2.4446E-3,2.4577E-3, - A 2.4707E-3,2.4834E-3,2.4960E-3,2.5085E-3,2.5208E-3,2.5329E-3, - B 2.5449E-3,2.5568E-3 / - DATA (COA(I,73),I=1,62) / - 1 1.1902E-3,1.2672E-3,1.3347E-3,1.3952E-3,1.4502E-3,1.5008E-3, - 2 1.5478E-3,1.5919E-3,1.6334E-3,1.6727E-3,1.7101E-3,1.7457E-3, - 3 1.7799E-3,1.8126E-3,1.8442E-3,1.8746E-3,1.9039E-3,1.9323E-3, - 4 1.9598E-3,1.9865E-3,2.0124E-3,2.0376E-3,2.0621E-3,2.0859E-3, - 5 2.1092E-3,2.1319E-3,2.1083E-3,2.1757E-3,2.1969E-3,2.2176E-3, - 6 2.2379E-3,2.2577E-3,2.2772E-3,2.2962E-3,2.3149E-3,2.3333E-3, - 7 2.3513E-3,2.3690E-3,2.3863E-3,2.4034E-3,2.4202E-3,2.4366E-3, - 8 2.4529E-3,2.4688E-3,2.4845E-3,2.5000E-3,2.5152E-3,2.5302E-3, - 9 2.5450E-3,2.5595E-3,2.5739E-3,2.5880E-3,2.6019E-3,2.6157E-3, - A 2.6293E-3,2.6426E-3,2.6557E-3,2.6689E-3,2.6817E-3,2.6944E-3, - B 2.7070E-3,2.7194E-3 / - DATA (COA(I,74),I=1,62) / - 1 1.2749E-3,1.3552E-3,1.4259E-3,1.4895E-3,1.5475E-3,1.6010E-3, - 2 1.6509E-3,1.6977E-3,1.7418E-3,1.7836E-3,1.8234E-3,1.8614E-3, - 3 1.8978E-3,1.9328E-3,1.9664E-3,1.9987E-3,2.0300E-3,2.0602E-3, - 4 2.0895E-3,2.1179E-3,2.1454E-3,2.1722E-3,2.1982E-3,2.2235E-3, - 5 2.2482E-3,2.2723E-3,2.2958E-3,2.3187E-3,2.3411E-3,2.3630E-3, - 6 2.3844E-3,2.4054E-3,2.4259E-3,2.4460E-3,2.4658E-3,2.4851E-3, - 7 2.5040E-3,2.5226E-3,2.5409E-3,2.5588E-3,2.5764E-3,2.5937E-3, - 8 2.6107E-3,2.6275E-3,2.6439E-3,2.6601E-3,2.6760E-3,2.6917E-3, - 9 2.7071E-3,2.7223E-3,2.7373E-3,2.7520E-3,2.7665E-3,2.7808E-3, - A 2.7950E-3,2.8089E-3,2.8226E-3,2.8361E-3,2.8495E-3,2.8627E-3, - B 2.8757E-3,2.8885E-3 / - DATA (COA(I,75),I=1,62) / - 1 1.3631E-3,1.4474E-3,1.5220E-3,1.5892E-3,1.6507E-3,1.7076E-3, - 2 1.7607E-3,1.8105E-3,1.8575E-3,1.9021E-3,1.9445E-3,1.9850E-3, - 3 2.0238E-3,2.0610E-3,2.0967E-3,2.1312E-3,2.1186E-3,2.1965E-3, - 4 2.2276E-3,2.2577E-3,2.2868E-3,2.3152E-3,2.3427E-3,2.3695E-3, - 5 2.3956E-3,2.4210E-3,2.4457E-3,2.4699E-3,2.4935E-3,2.5165E-3, - 6 2.5390E-3,2.5610E-3,2.5826E-3,2.6037E-3,2.6243E-3,2.6445E-3, - 7 2.6643E-3,2.6838E-3,2.7028E-3,2.7215E-3,2.7399E-3,2.7579E-3, - 8 2.7756E-3,2.7930E-3,2.8101E-3,2.8269E-3,2.8434E-3,2.8596E-3, - 9 2.8756E-3,2.8913E-3,2.9068E-3,2.9220E-3,2.9370E-3,2.9518E-3, - A 2.9664E-3,2.9807E-3,2.9949E-3,3.0088E-3,3.0225E-3,3.0361E-3, - B 3.0494E-3,3.0626E-3 / - DATA (COA(I,76),I=1,62) / - 1 1.4557E-3,1.5446E-3,1.6236E-3,1.6950E-3,1.7605E-3,1.8211E-3, - 2 1.8777E-3,1.9308E-3,1.9809E-3,2.0284E-3,2.0736E-3,2.1167E-3, - 3 2.1121E-3,2.1973E-3,2.2353E-3,2.2718E-3,2.3069E-3,2.3409E-3, - 4 2.3737E-3,2.4055E-3,2.4362E-3,2.4661E-3,2.4950E-3,2.5232E-3, - 5 2.5506E-3,2.5772E-3,2.6031E-3,2.6284E-3,2.6531E-3,2.6771E-3, - 6 2.7006E-3,2.7235E-3,2.7460E-3,2.7679E-3,2.7893E-3,2.8103E-3, - 7 2.8309E-3,2.8510E-3,2.8707E-3,2.8900E-3,2.9090E-3,2.9276E-3, - 8 2.9458E-3,2.9637E-3,2.9813E-3,2.9986E-3,3.0156E-3,3.0322E-3, - 9 3.0486E-3,3.0647E-3,3.0806E-3,3.0962E-3,3.1115E-3,3.1266E-3, - A 3.1414E-3,3.1560E-3,3.1704E-3,3.1846E-3,3.1986E-3,3.2123E-3, - B 3.2259E-3,3.2392E-3 / - DATA (COA(I,77),I=1,62) / - 1 1.5532E-3,1.6476E-3,1.7317E-3,1.8078E-3,1.8775E-3,1.9422E-3, - 2 2.0024E-3,2.0590E-3,2.1123E-3,2.1169E-3,2.2106E-3,2.2563E-3, - 3 2.2999E-3,2.3416E-3,2.3817E-3,2.4202E-3,2.4572E-3,2.4929E-3, - 4 2.5273E-3,2.5607E-3,2.5929E-3,2.6241E-3,2.6543E-3,2.6837E-3, - 5 2.7122E-3,2.7399E-3,2.7668E-3,2.7931E-3,2.8186E-3,2.8435E-3, - 6 2.8678E-3,2.8915E-3,2.9146E-3,2.9372E-3,2.9592E-3,2.9808E-3, - 7 3.0019E-3,3.0225E-3,3.0427E-3,3.0625E-3,3.0819E-3,3.1009E-3, - 8 3.1195E-3,3.1377E-3,3.1556E-3,3.1732E-3,3.1904E-3,3.2073E-3, - 9 3.2239E-3,3.2402E-3,3.2563E-3,3.2720E-3,3.2875E-3,3.3027E-3, - A 3.3177E-3,3.3324E-3,3.3468E-3,3.3611E-3,3.3751E-3,3.3889E-3, - B 3.4025E-3,3.4159E-3 / - DATA (COA(I,78),I=1,62) / - 1 1.6566E-3,1.7571E-3,1.8467E-3,1.9278E-3,2.0021E-3,2.0708E-3, - 2 2.1349E-3,2.1949E-3,2.2514E-3,2.3047E-3,2.3554E-3,2.4035E-3, - 3 2.4494E-3,2.4932E-3,2.5352E-3,2.5755E-3,2.6142E-3,2.6515E-3, - 4 2.6874E-3,2.7220E-3,2.7555E-3,2.7878E-3,2.8191E-3,2.8495E-3, - 5 2.8789E-3,2.9075E-3,2.9352E-3,2.9621E-3,2.9883E-3,3.0138E-3, - 6 3.0387E-3,3.0629E-3,3.0864E-3,3.1094E-3,3.1319E-3,3.1538E-3, - 7 3.1752E-3,3.1961E-3,3.2166E-3,3.2365E-3,3.2561E-3,3.2752E-3, - 8 3.2940E-3,3.3123E-3,3.3303E-3,3.3479E-3,3.3652E-3,3.3821E-3, - 9 3.3988E-3,3.4151E-3,3.4310E-3,3.4467E-3,3.4622E-3,3.4773E-3, - A 3.4922E-3,3.5068E-3,3.5211E-3,3.5353E-3,3.5491E-3,3.5628E-3, - B 3.5762E-3,3.5894E-3 / - DATA (COA(I,79),I=1,62) / - 1 1.7664E-3,1.8736E-3,1.9689E-3,2.0552E-3,2.1342E-3,2.2071E-3, - 2 2.2749E-3,2.3383E-3,2.3978E-3,2.4539E-3,2.5070E-3,2.5574E-3, - 3 2.6054E-3,2.6511E-3,2.6948E-3,2.7366E-3,2.7767E-3,2.8153E-3, - 4 2.8523E-3,2.8880E-3,2.9224E-3,2.9556E-3,2.9877E-3,3.0187E-3, - 5 3.0487E-3,3.0778E-3,3.1060E-3,3.1334E-3,3.1599E-3,3.1857E-3, - 6 3.2108E-3,3.2352E-3,3.2590E-3,3.2821E-3,3.3047E-3,3.3267E-3, - 7 3.3481E-3,3.3690E-3,3.3894E-3,3.4094E-3,3.4289E-3,3.4479E-3, - 8 3.4665E-3,3.4847E-3,3.5025E-3,3.5200E-3,3.5371E-3,3.5538E-3, - 9 3.5702E-3,3.5862E-3,3.6020E-3,3.6174E-3,3.6325E-3,3.6474E-3, - A 3.6620E-3,3.6763E-3,3.6903E-3,3.7041E-3,3.7177E-3,3.7310E-3, - B 3.7441E-3,3.7569E-3 / - DATA (COA(I,80),I=1,62) / - 1 1.8832E-3,1.9973E-3,2.0987E-3,2.1902E-3,2.2737E-3,2.3505E-3, - 2 2.4220E-3,2.4885E-3,2.5508E-3,2.6093E-3,2.6646E-3,2.7169E-3, - 3 2.7666E-3,2.8138E-3,2.8589E-3,2.9018E-3,2.9430E-3,2.9824E-3, - 4 3.0202E-3,3.0565E-3,3.0915E-3,3.1252E-3,3.1576E-3,3.1890E-3, - 5 3.2192E-3,3.2485E-3,3.2768E-3,3.3042E-3,3.3308E-3,3.3566E-3, - 6 3.3816E-3,3.4059E-3,3.4295E-3,3.4525E-3,3.4748E-3,3.4966E-3, - 7 3.5177E-3,3.5384E-3,3.5585E-3,3.5781E-3,3.5972E-3,3.6159E-3, - 8 3.6341E-3,3.6520E-3,3.6694E-3,3.6864E-3,3.7031E-3,3.7193E-3, - 9 3.7353E-3,3.7509E-3,3.7662E-3,3.7811E-3,3.7958E-3,3.8102E-3, - A 3.8243E-3,3.8381E-3,3.8517E-3,3.8650E-3,3.8780E-3,3.8908E-3, - B 3.9034E-3,3.9158E-3 / - DATA (COA(I,81),I=1,62) / - 1 2.0072E-3,2.1282E-3,2.2356E-3,2.3321E-3,2.4200E-3,2.5006E-3, - 2 2.5751E-3,2.6443E-3,2.7089E-3,2.7695E-3,2.8265E-3,2.8803E-3, - 3 2.9311E-3,2.9794E-3,3.0252E-3,3.0689E-3,3.1106E-3,3.1504E-3, - 4 3.1886E-3,3.2251E-3,3.2602E-3,3.2939E-3,3.3263E-3,3.3575E-3, - 5 3.3876E-3,3.4166E-3,3.4447E-3,3.4718E-3,3.4980E-3,3.5234E-3, - 6 3.5480E-3,3.5719E-3,3.5950E-3,3.6175E-3,3.6393E-3,3.6605E-3, - 7 3.6811E-3,3.7012E-3,3.7207E-3,3.7398E-3,3.7583E-3,3.7764E-3, - 8 3.7940E-3,3.8112E-3,3.8280E-3,3.8444E-3,3.8604E-3,3.8761E-3, - 9 3.8914E-3,3.9063E-3,3.9210E-3,3.9353E-3,3.9494E-3,3.9631E-3, - A 3.9766E-3,3.9898E-3,4.0027E-3,4.0154E-3,4.0278E-3,4.0400E-3, - B 4.0520E-3,4.0638E-3 / - DATA (COA(I,82),I=1,62) / - 1 2.1381E-3,2.2661E-3,2.3791E-3,2.4803E-3,2.5719E-3,2.6557E-3, - 2 2.7328E-3,2.8041E-3,2.8705E-3,2.9325E-3,2.9905E-3,3.0451E-3, - 3 3.0966E-3,3.1453E-3,3.1914E-3,3.2353E-3,3.2769E-3,3.3166E-3, - 4 3.3545E-3,3.3908E-3,3.4255E-3,3.4588E-3,3.4907E-3,3.5214E-3, - 5 3.5509E-3,3.5793E-3,3.6067E-3,3.6331E-3,3.6586E-3,3.6833E-3, - 6 3.7071E-3,3.7302E-3,3.7526E-3,3.7743E-3,3.7953E-3,3.8157E-3, - 7 3.8356E-3,3.8548E-3,3.8736E-3,3.8916E-3,3.9095E-3,3.9268E-3, - 8 3.9436E-3,3.9600E-3,3.9761E-3,3.9917E-3,4.0069E-3,4.0218E-3, - 9 4.0364E-3,4.0506E-3,4.0645E-3,4.0781E-3,4.0914E-3,4.1044E-3, - A 4.1172E-3,4.1296E-3,4.1419E-3,4.1539E-3,4.1656E-3,4.1772E-3, - B 4.1885E-3,4.1996E-3 / - DATA (COA(I,83),I=1,62) / - 1 2.2756E-3,2.4100E-3,2.5280E-3,2.6332E-3,2.7280E-3,2.8142E-3, - 2 2.8931E-3,2.9658E-3,3.0331E-3,3.0957E-3,3.1541E-3,3.2089E-3, - 3 3.2603E-3,3.3088E-3,3.3545E-3,3.3978E-3,3.4389E-3,3.4780E-3, - 4 3.5151E-3,3.5506E-3,3.5844E-3,3.6168E-3,3.6478E-3,3.6775E-3, - 5 3.7061E-3,3.7335E-3,3.7599E-3,3.7853E-3,3.8098E-3,3.8335E-3, - 6 3.8563E-3,3.8784E-3,3.8998E-3,3.9205E-3,3.9405E-3,3.9599E-3, - 7 3.9788E-3,3.9971E-3,4.0149E-3,4.0322E-3,4.0490E-3,4.0653E-3, - 8 4.0813E-3,4.0968E-3,4.1119E-3,4.1267E-3,4.1411E-3,4.1552E-3, - 9 4.1689E-3,4.1823E-3,4.1954E-3,4.2082E-3,4.2208E-3,4.2331E-3, - A 4.2451E-3,4.2569E-3,4.2684E-3,4.2797E-3,4.2908E-3,4.3017E-3, - B 4.3123E-3,4.3228E-3 / - DATA (COA(I,84),I=1,62) / - 1 2.4185E-3,2.5586E-3,2.6808E-3,2.7890E-3,2.8859E-3,2.9735E-3, - 2 3.0533E-3,3.1264E-3,3.1938E-3,3.2562E-3,3.3142E-3,3.3683E-3, - 3 3.4190E-3,3.4665E-3,3.5113E-3,3.5535E-3,3.5934E-3,3.6313E-3, - 4 3.6672E-3,3.7014E-3,3.7340E-3,3.7651E-3,3.7948E-3,3.8232E-3, - 5 3.8505E-3,3.8767E-3,3.9018E-3,3.9260E-3,3.9493E-3,3.9717E-3, - 6 3.9934E-3,4.0143E-3,4.0345E-3,4.0540E-3,4.0730E-3,4.0913E-3, - 7 4.1091E-3,4.1264E-3,4.1432E-3,4.1595E-3,4.1753E-3,4.1907E-3, - 8 4.2057E-3,4.2204E-3,4.2346E-3,4.2485E-3,4.2621E-3,4.2754E-3, - 9 4.2883E-3,4.3009E-3,4.3133E-3,4.3254E-3,4.3372E-3,4.3488E-3, - A 4.3601E-3,4.3712E-3,4.3821E-3,4.3928E-3,4.4032E-3,4.4135E-3, - B 4.4236E-3,4.4335E-3 / - DATA (COA(I,85),I=1,62) / - 1 2.5653E-3,2.7099E-3,2.8350E-3,2.9450E-3,3.0428E-3,3.1307E-3, - 2 3.2102E-3,3.2828E-3,3.3493E-3,3.4106E-3,3.4673E-3,3.5200E-3, - 3 3.5692E-3,3.6152E-3,3.6583E-3,3.6990E-3,3.7373E-3,3.7735E-3, - 4 3.8078E-3,3.8404E-3,3.8714E-3,3.9009E-3,3.9291E-3,3.9560E-3, - 5 3.9818E-3,4.0065E-3,4.0303E-3,4.0531E-3,4.0751E-3,4.0962E-3, - 6 4.1166E-3,4.1363E-3,4.1553E-3,4.1738E-3,4.1916E-3,4.2089E-3, - 7 4.2256E-3,4.2419E-3,4.2577E-3,4.2730E-3,4.2879E-3,4.3025E-3, - 8 4.3166E-3,4.3304E-3,4.3439E-3,4.3570E-3,4.3698E-3,4.3823E-3, - 9 4.3945E-3,4.4064E-3,4.4181E-3,4.4296E-3,4.4407E-3,4.4517E-3, - A 4.4624E-3,4.4730E-3,4.4833E-3,4.4934E-3,4.5033E-3,4.5130E-3, - B 4.5226E-3,4.5320E-3 / - DATA (COA(I,86),I=1,62) / - 1 2.7124E-3,2.8597E-3,2.9861E-3,3.0963E-3,3.1936E-3,3.2805E-3, - 2 3.3586E-3,3.4295E-3,3.4941E-3,3.5534E-3,3.6081E-3,3.6587E-3, - 3 3.7058E-3,3.7497E-3,3.7908E-3,3.8294E-3,3.8657E-3,3.9000E-3, - 4 3.9324E-3,3.9631E-3,3.9923E-3,4.0201E-3,4.0467E-3,4.0720E-3, - 5 4.0963E-3,4.1195E-3,4.1418E-3,4.1633E-3,4.1839E-3,4.2038E-3, - 6 4.2230E-3,4.2415E-3,4.2594E-3,4.2768E-3,4.2935E-3,4.3098E-3, - 7 4.3256E-3,4.3409E-3,4.3558E-3,4.3703E-3,4.3844E-3,4.3982E-3, - 8 4.4115E-3,4.4246E-3,4.4373E-3,4.4497E-3,4.4619E-3,4.4737E-3, - 9 4.4853E-3,4.4966E-3,4.5077E-3,4.5186E-3,4.5292E-3,4.5397E-3, - A 4.5499E-3,4.5599E-3,4.5697E-3,4.5793E-3,4.5888E-3,4.5981E-3, - B 4.6072E-3,4.6162E-3 / - DATA (COA(I,87),I=1,62) / - 1 2.8481E-3,2.9956E-3,3.1209E-3,3.2292E-3,3.3241E-3,3.4083E-3, - 2 3.4836E-3,3.5515E-3,3.6132E-3,3.6696E-3,3.7214E-3,3.7692E-3, - 3 3.8136E-3,3.8548E-3,3.8934E-3,3.9296E-3,3.9636E-3,3.9956E-3, - 4 4.0260E-3,4.0547E-3,4.0820E-3,4.1080E-3,4.1328E-3,4.1565E-3, - 5 4.1792E-3,4.2010E-3,4.2219E-3,4.2419E-3,4.2613E-3,4.2800E-3, - 6 4.2980E-3,4.3154E-3,4.3322E-3,4.3485E-3,4.3643E-3,4.3796E-3, - 7 4.3945E-3,4.4090E-3,4.4231E-3,4.4367E-3,4.4501E-3,4.4631E-3, - 8 4.4757E-3,4.4881E-3,4.5001E-3,4.5119E-3,4.5234E-3,4.5347E-3, - 9 4.5457E-3,4.5564E-3,4.5670E-3,4.5773E-3,4.5874E-3,4.5973E-3, - A 4.6070E-3,4.6166E-3,4.6259E-3,4.6351E-3,4.6441E-3,4.6530E-3, - B 4.6616E-3,4.6702E-3 / - DATA (COA(I,88),I=1,62) / - 1 2.9341E-3,3.0768E-3,3.1968E-3,3.2997E-3,3.3892E-3,3.4681E-3, - 2 3.5383E-3,3.6014E-3,3.6584E-3,3.7104E-3,3.7581E-3,3.8020E-3, - 3 3.8427E-3,3.8805E-3,3.9159E-3,3.9490E-3,3.9801E-3,4.0095E-3, - 4 4.0373E-3,4.0637E-3,4.0888E-3,4.1127E-3,4.1355E-3,4.1573E-3, - 5 4.1782E-3,4.1983E-3,4.2175E-3,4.2361E-3,4.2540E-3,4.2713E-3, - 6 4.2880E-3,4.3041E-3,4.3197E-3,4.3349E-3,4.3495E-3,4.3638E-3, - 7 4.3777E-3,4.3911E-3,4.4042E-3,4.4170E-3,4.4294E-3,4.4416E-3, - 8 4.4534E-3,4.4649E-3,4.4762E-3,4.4872E-3,4.4980E-3,4.5085E-3, - 9 4.5188E-3,4.5289E-3,4.5387E-3,4.5484E-3,4.5579E-3,4.5672E-3, - A 4.5763E-3,4.5852E-3,4.5940E-3,4.6026E-3,4.6110E-3,4.6193E-3, - B 4.6275E-3,4.6355E-3 / - DATA (COA(I,89),I=1,62) / - 1 2.9122E-3,3.0427E-3,3.1513E-3,3.2438E-3,3.3237E-3,3.3938E-3, - 2 3.4559E-3,3.5116E-3,3.5619E-3,3.6076E-3,3.6495E-3,3.6882E-3, - 3 3.7238E-3,3.7573E-3,3.7884E-3,3.8176E-3,3.8451E-3,3.8711E-3, - 4 3.8957E-3,3.9191E-3,3.9413E-3,3.9626E-3,3.9829E-3,4.0023E-3, - 5 4.0209E-3,4.0389E-3,4.0561E-3,4.0727E-3,4.0887E-3,4.1042E-3, - 6 4.1192E-3,4.1337E-3,4.1477E-3,4.1613E-3,4.1745E-3,4.1874E-3, - 7 4.1998E-3,4.2120E-3,4.2238E-3,4.2353E-3,4.2465E-3,4.2574E-3, - 8 4.2681E-3,4.2785E-3,4.2887E-3,4.2986E-3,4.3084E-3,4.3179E-3, - 9 4.3272E-3,4.3363E-3,4.3452E-3,4.3539E-3,4.3625E-3,4.3709E-3, - A 4.3791E-3,4.3872E-3,4.3951E-3,4.4029E-3,4.4105E-3,4.4180E-3, - B 4.4254E-3,4.4326E-3 / - DATA (COA(I,90),I=1,62) / - 1 2.7405E-3,2.8512E-3,2.9426E-3,3.0199E-3,3.0864E-3,3.1447E-3, - 2 3.1962E-3,3.2424E-3,3.2841E-3,3.3221E-3,3.3569E-3,3.3891E-3, - 3 3.4190E-3,3.4468E-3,3.4729E-3,3.4974E-3,3.5206E-3,3.5424E-3, - 4 3.5632E-3,3.5830E-3,3.6018E-3,3.6198E-3,3.6370E-3,3.6535E-3, - 5 3.6694E-3,3.6847E-3,3.6993E-3,3.7135E-3,3.7272E-3,3.7404E-3, - 6 3.7532E-3,3.7656E-3,3.7776E-3,3.7892E-3,3.8005E-3,3.8115E-3, - 7 3.8222E-3,3.8326E-3,3.8427E-3,3.8526E-3,3.8622E-3,3.8716E-3, - 8 3.8808E-3,3.8897E-3,3.8984E-3,3.9070E-3,3.9153E-3,3.9235E-3, - 9 3.9314E-3,3.9393E-3,3.9469E-3,3.9544E-3,3.9618E-3,3.9690E-3, - A 3.9761E-3,3.9830E-3,3.9898E-3,3.9965E-3,4.0030E-3,4.0095E-3, - B 4.0158E-3,4.0220E-3 / - DATA (COA(I,91),I=1,62) / - 1 2.4633E-3,2.5514E-3,2.6239E-3,2.6851E-3,2.7377E-3,2.7838E-3, - 2 2.8247E-3,2.8613E-3,2.8946E-3,2.9249E-3,2.9529E-3,2.9787E-3, - 3 3.0028E-3,3.0253E-3,3.0464E-3,3.0663E-3,3.0851E-3,3.1029E-3, - 4 3.1199E-3,3.1360E-3,3.1514E-3,3.1661E-3,3.1803E-3,3.1938E-3, - 5 3.2068E-3,3.2194E-3,3.2314E-3,3.2431E-3,3.2544E-3,3.2652E-3, - 6 3.2758E-3,3.2860E-3,3.2959E-3,3.3055E-3,3.3148E-3,3.3239E-3, - 7 3.3327E-3,3.3413E-3,3.3497E-3,3.3578E-3,3.3658E-3,3.3735E-3, - 8 3.3811E-3,3.3885E-3,3.3957E-3,3.4028E-3,3.4097E-3,3.4164E-3, - 9 3.4230E-3,3.4295E-3,3.4359E-3,3.4421E-3,3.4482E-3,3.4541E-3, - A 3.4600E-3,3.4657E-3,3.4714E-3,3.4769E-3,3.4823E-3,3.4877E-3, - B 3.4929E-3,3.4981E-3 / - DATA (COA(I,92),I=1,62) / - 1 2.1142E-3,2.2278E-3,2.2837E-3,2.3309E-3,2.3717E-3,2.4075E-3, - 2 2.4394E-3,2.4681E-3,2.4943E-3,2.5182E-3,2.5404E-3,2.5609E-3, - 3 2.5801E-3,2.5980E-3,2.6149E-3,2.6308E-3,2.6459E-3,2.6602E-3, - 4 2.6738E-3,2.6868E-3,2.6992E-3,2.7111E-3,2.7225E-3,2.7334E-3, - 5 2.7439E-3,2.7541E-3,2.7638E-3,2.7733E-3,2.7824E-3,2.7912E-3, - 6 2.7997E-3,2.8080E-3,2.8160E-3,2.8238E-3,2.8314E-3,2.8387E-3, - 7 2.8459E-3,2.8529E-3,2.8597E-3,2.8663E-3,2.8727E-3,2.8791E-3, - 8 2.8852E-3,2.8912E-3,2.8971E-3,2.9028E-3,2.9084E-3,2.9139E-3, - 9 2.9193E-3,2.9246E-3,2.9297E-3,2.9348E-3,2.9398E-3,2.9446E-3, - A 2.9494E-3,2.9541E-3,2.9587E-3,2.9632E-3,2.9676E-3,2.9720E-3, - B 2.9761E-3,2.9805E-3 / - DATA (COA(I,93),I=1,62) / - 1 1.8726E-3,1.9238E-3,1.9660E-3,2.0019E-3,2.0331E-3,2.0606E-3, - 2 2.0852E-3,2.1074E-3,2.1278E-3,2.1464E-3,2.1179E-3,2.1798E-3, - 3 2.1948E-3,2.2089E-3,2.2221E-3,2.2347E-3,2.2466E-3,2.2578E-3, - 4 2.2686E-3,2.2789E-3,2.2887E-3,2.2981E-3,2.3071E-3,2.3158E-3, - 5 2.3241E-3,2.3321E-3,2.3399E-3,2.3474E-3,2.3546E-3,2.3616E-3, - 6 2.3684E-3,2.3750E-3,2.3814E-3,2.3876E-3,2.3936E-3,2.3995E-3, - 7 2.4052E-3,2.4108E-3,2.4162E-3,2.4215E-3,2.4266E-3,2.4317E-3, - 8 2.4366E-3,2.4414E-3,2.4461E-3,2.4507E-3,2.4552E-3,2.4596E-3, - 9 2.4639E-3,2.4681E-3,2.4722E-3,2.4763E-3,2.4802E-3,2.4841E-3, - A 2.4880E-3,2.4917E-3,2.4954E-3,2.4990E-3,2.5026E-3,2.5060E-3, - B 2.5095E-3,2.5129E-3 / - DATA (COA(I,94),I=1,62) / - 1 1.6337E-3,1.6718E-3,1.7033E-3,1.7303E-3,1.7537E-3,1.7745E-3, - 2 1.7931E-3,1.8100E-3,1.8254E-3,1.8397E-3,1.8529E-3,1.8651E-3, - 3 1.8766E-3,1.8874E-3,1.8976E-3,1.9073E-3,1.9164E-3,1.9251E-3, - 4 1.9334E-3,1.9413E-3,1.9489E-3,1.9562E-3,1.9631E-3,1.9698E-3, - 5 1.9763E-3,1.9825E-3,1.9885E-3,1.9944E-3,2.0000E-3,2.0054E-3, - 6 2.0107E-3,2.0158E-3,2.0208E-3,2.0256E-3,2.0303E-3,2.0349E-3, - 7 2.0394E-3,2.0437E-3,2.0479E-3,2.0521E-3,2.0561E-3,2.0600E-3, - 8 2.0639E-3,2.0676E-3,2.0713E-3,2.0749E-3,2.0784E-3,2.0819E-3, - 9 2.0852E-3,2.0886E-3,2.0918E-3,2.0950E-3,2.0981E-3,2.1011E-3, - A 2.1041E-3,2.1071E-3,2.1100E-3,2.1128E-3,2.1156E-3,2.1183E-3, - B 2.1210E-3,2.1236E-3 / - DATA (COA(I,95),I=1,62) / - 1 1.4740E-3,1.5024E-3,1.5259E-3,1.5460E-3,1.5636E-3,1.5791E-3, - 2 1.5931E-3,1.6058E-3,1.6174E-3,1.6282E-3,1.6381E-3,1.6474E-3, - 3 1.6561E-3,1.6643E-3,1.6720E-3,1.6793E-3,1.6863E-3,1.6929E-3, - 4 1.6992E-3,1.7052E-3,1.7110E-3,1.7165E-3,1.7219E-3,1.7270E-3, - 5 1.7319E-3,1.7367E-3,1.7413E-3,1.7458E-3,1.7501E-3,1.7543E-3, - 6 1.7584E-3,1.7623E-3,1.7661E-3,1.7699E-3,1.7735E-3,1.7770E-3, - 7 1.7804E-3,1.7838E-3,1.7870E-3,1.7902E-3,1.7933E-3,1.7964E-3, - 8 1.7993E-3,1.8023E-3,1.8051E-3,1.8079E-3,1.8106E-3,1.8132E-3, - 9 1.8158E-3,1.8184E-3,1.8209E-3,1.8233E-3,1.8258E-3,1.8281E-3, - A 1.8304E-3,1.8327E-3,1.8349E-3,1.8371E-3,1.8393E-3,1.8414E-3, - B 1.8434E-3,1.8455E-3 / - DATA (COA(I,96),I=1,62) / - 1 1.3895E-3,1.4110E-3,1.4289E-3,1.4441E-3,1.4574E-3,1.4692E-3, - 2 1.4798E-3,1.4894E-3,1.4982E-3,1.5064E-3,1.5139E-3,1.5210E-3, - 3 1.5277E-3,1.5338E-3,1.5398E-3,1.5454E-3,1.5508E-3,1.5558E-3, - 4 1.5607E-3,1.5653E-3,1.5698E-3,1.5740E-3,1.5782E-3,1.5821E-3, - 5 1.5859E-3,1.5896E-3,1.5932E-3,1.5966E-3,1.6000E-3,1.6032E-3, - 6 1.6064E-3,1.6094E-3,1.6124E-3,1.6153E-3,1.6181E-3,1.6208E-3, - 7 1.6235E-3,1.6261E-3,1.6286E-3,1.6311E-3,1.6335E-3,1.6358E-3, - 8 1.6381E-3,1.6404E-3,1.6426E-3,1.6447E-3,1.6468E-3,1.6489E-3, - 9 1.6509E-3,1.6529E-3,1.6548E-3,1.6567E-3,1.6586E-3,1.6604E-3, - A 1.6622E-3,1.6639E-3,1.6657E-3,1.6673E-3,1.6690E-3,1.6706E-3, - B 1.6722E-3,1.6738E-3 / - DATA (COA(I,97),I=1,62) / - 1 1.3502E-3,1.3669E-3,1.3807E-3,1.3924E-3,1.4027E-3,1.4118E-3, - 2 1.4200E-3,1.4274E-3,1.4343E-3,1.4406E-3,1.4465E-3,1.4520E-3, - 3 1.4571E-3,1.4620E-3,1.4666E-3,1.4710E-3,1.4751E-3,1.4791E-3, - 4 1.4829E-3,1.4865E-3,1.4900E-3,1.4933E-3,1.4966E-3,1.4997E-3, - 5 1.5027E-3,1.5055E-3,1.5083E-3,1.5109E-3,1.5136E-3,1.5162E-3, - 6 1.5186E-3,1.5210E-3,1.5234E-3,1.5256E-3,1.5278E-3,1.5299E-3, - 7 1.5320E-3,1.5340E-3,1.5360E-3,1.5380E-3,1.5398E-3,1.5417E-3, - 8 1.5435E-3,1.5452E-3,1.5469E-3,1.5486E-3,1.5503E-3,1.5519E-3, - 9 1.5534E-3,1.5550E-3,1.5565E-3,1.5580E-3,1.5594E-3,1.5608E-3, - A 1.5622E-3,1.5636E-3,1.5649E-3,1.5663E-3,1.5676E-3,1.5688E-3, - B 1.5701E-3,1.5713E-3 / - DATA (COA(I,98),I=1,62) / - 1 1.3341E-3,1.3476E-3,1.3588E-3,1.3683E-3,1.3766E-3,1.3840E-3, - 2 1.3907E-3,1.3967E-3,1.4023E-3,1.4074E-3,1.4122E-3,1.4167E-3, - 3 1.4209E-3,1.4248E-3,1.4286E-3,1.4321E-3,1.4355E-3,1.4387E-3, - 4 1.4418E-3,1.4447E-3,1.4476E-3,1.4503E-3,1.4529E-3,1.4554E-3, - 5 1.4578E-3,1.4602E-3,1.4624E-3,1.4646E-3,1.4667E-3,1.4688E-3, - 6 1.4708E-3,1.4727E-3,1.4746E-3,1.4764E-3,1.4782E-3,1.4799E-3, - 7 1.4816E-3,1.4833E-3,1.4849E-3,1.4864E-3,1.4879E-3,1.4894E-3, - 8 1.4909E-3,1.4923E-3,1.4937E-3,1.4950E-3,1.4964E-3,1.4977E-3, - 9 1.4989E-3,1.5002E-3,1.5014E-3,1.5026E-3,1.5038E-3,1.5049E-3, - A 1.5060E-3,1.5071E-3,1.5082E-3,1.5093E-3,1.5103E-3,1.5114E-3, - B 1.5124E-3,1.5134E-3 / - DATA (COA(I,99),I=1,62) / - 1 1.3255E-3,1.3373E-3,1.3470E-3,1.3554E-3,1.3626E-3,1.3691E-3, - 2 1.3749E-3,1.3803E-3,1.3851E-3,1.3896E-3,1.3938E-3,1.3977E-3, - 3 1.4014E-3,1.4049E-3,1.4082E-3,1.4113E-3,1.4142E-3,1.4171E-3, - 4 1.4197E-3,1.4223E-3,1.4248E-3,1.4272E-3,1.4294E-3,1.4316E-3, - 5 1.4337E-3,1.4358E-3,1.4378E-3,1.4397E-3,1.4415E-3,1.4433E-3, - 6 1.4450E-3,1.4467E-3,1.4483E-3,1.4499E-3,1.4515E-3,1.4530E-3, - 7 1.4544E-3,1.4559E-3,1.4573E-3,1.4586E-3,1.4599E-3,1.4612E-3, - 8 1.4625E-3,1.4637E-3,1.4649E-3,1.4661E-3,1.4672E-3,1.4684E-3, - 9 1.4695E-3,1.4705E-3,1.4716E-3,1.4726E-3,1.4736E-3,1.4746E-3, - A 1.4756E-3,1.4766E-3,1.4775E-3,1.4784E-3,1.4793E-3,1.4802E-3, - B 1.4811E-3,1.4820E-3 / - DATA (COA(I,100),I=1,62) / - 1 1.3126E-3,1.3234E-3,1.3324E-3,1.3401E-3,1.3469E-3,1.3529E-3, - 2 1.3583E-3,1.3632E-3,1.3677E-3,1.3719E-3,1.3758E-3,1.3795E-3, - 3 1.3829E-3,1.3861E-3,1.3891E-3,1.3920E-3,1.3947E-3,1.3974E-3, - 4 1.3998E-3,1.4022E-3,1.4045E-3,1.4067E-3,1.4088E-3,1.4108E-3, - 5 1.4127E-3,1.4146E-3,1.4164E-3,1.4181E-3,1.4198E-3,1.4215E-3, - 6 1.4230E-3,1.4246E-3,1.4261E-3,1.4275E-3,1.4289E-3,1.4303E-3, - 7 1.4316E-3,1.4329E-3,1.4341E-3,1.4354E-3,1.4366E-3,1.4377E-3, - 8 1.4389E-3,1.4400E-3,1.4411E-3,1.4421E-3,1.4432E-3,1.4442E-3, - 9 1.4452E-3,1.4462E-3,1.4471E-3,1.4480E-3,1.4490E-3,1.4499E-3, - A 1.4507E-3,1.4516E-3,1.4525E-3,1.4533E-3,1.4541E-3,1.4549E-3, - B 1.4557E-3,1.4565E-3 / - DATA (COA(I,101),I=1,62) / - 1 1.2882E-3,1.2983E-3,1.3066E-3,1.3138E-3,1.3202E-3,1.3258E-3, - 2 1.3309E-3,1.3355E-3,1.3398E-3,1.3437E-3,1.3473E-3,1.3507E-3, - 3 1.3539E-3,1.3569E-3,1.3598E-3,1.3625E-3,1.3650E-3,1.3674E-3, - 4 1.3697E-3,1.3719E-3,1.3740E-3,1.3760E-3,1.3780E-3,1.3798E-3, - 5 1.3816E-3,1.3833E-3,1.3850E-3,1.3865E-3,1.3881E-3,1.3896E-3, - 6 1.3910E-3,1.3924E-3,1.3938E-3,1.3951E-3,1.3963E-3,1.3976E-3, - 7 1.3988E-3,1.3999E-3,1.4011E-3,1.4022E-3,1.4033E-3,1.4043E-3, - 8 1.4054E-3,1.4064E-3,1.4073E-3,1.4083E-3,1.4092E-3,1.4101E-3, - 9 1.4110E-3,1.4119E-3,1.4128E-3,1.4136E-3,1.4145E-3,1.4153E-3, - A 1.4161E-3,1.4168E-3,1.4176E-3,1.4183E-3,1.4191E-3,1.4198E-3, - B 1.4205E-3,1.4212E-3 / -! - SAVE CAH, COA -C -C --- END OF CO2 LOOK UP TABLE -C diff --git a/src/fim/FIMsrc/fim/column/conrad.f b/src/fim/FIMsrc/fim/column/conrad.f deleted file mode 100644 index 8a31905..0000000 --- a/src/fim/FIMsrc/fim/column/conrad.f +++ /dev/null @@ -1,89 +0,0 @@ - SUBROUTINE CONRAD(NFILE,RCO2, L,LP1,LP1V,NBLY, NBLW - &, SGTMP, CO21D, CO22D, CO21D3, CO21D7 - &, SOURCE, DSRCE) -CFPP$ NOCONCUR R -! ******************************************************************* -! * C O N R A D * -! * READ CO2 TRANSMISSION DATA FROM UNIT(NFILE)FOR NEW VERTICAL * -! * COORDINATE TESTS ... * -! * THESE ARRAYS USED TO BE IN BLOCK DATA ...K.CAMPANA-MAR 90 * -! ******************************************************************* -! - use machine - implicit none -! - integer nfile, L, LP1, LP1V, NBLY, NBLW - real (kind=kind_rad) SGTMP(LP1,2), CO21D(L,6), CO22D(LP1,LP1,6) - &, CO21D3(LP1,6), CO21D7(LP1,6) - &, SOURCE(28,NBLY),DSRCE(28,NBLY), RCO2 -! - real (kind=kind_io4) sgtmp4(lp1,2),co21d4(l,6),co22d4(lp1,lp1,6) - &, co21d34(lp1,6), co21d74(lp1,6), rco24 -! - integer i, j, kk -! -! CO2 DATA TABLES FOR USERS VERTICAL COORDINATE -! -! THE FOLLOWING MODULE BLOCKS CONTAIN PRETABULATED CO2 TRANSMISSION -! FUNCTIONS, EVALUATED USING THE METHODS OF FELS AND -! SCHWARZKOPF (1981) AND SCHWARZKOPF AND FELS (1985), -!----- THE 2-DIMENSIONAL ARRAYS ARE -! CO2 TRANSMISSION FUNCTIONS AND THEIR DERIVATIVES -! FROM 109-LEVEL LINE-BY-LINE CALCULATIONS MADE USING THE 1982 -! MCCLATCHY TAPE (12511 LINES),CONSOLIDATED,INTERPOLATED -! TO THE NMC MRF VERTICAL COORDINATTE,AND RE-CONSOLIDATED TO A -! 200 CM-1 BANDWIDTH. THE INTERPOLATION METHOD IS DESCRIBED IN -! SCHWARZKOPF AND FELS (J.G.R.,1985). -!----- THE 1-DIM ARRAYS ARE -! CO2 TRANSMISSION FUNCTIONS AND THEIR DERIVATIVES -! FOR TAU(I,I+1),I=1,L, -! WHERE THE VALUES ARE NOT OBTAINED BY QUADRATURE,BUT ARE THE -! ACTUAL TRANSMISSIVITIES,ETC,BETWEEN A PAIR OF PRESSURES. -! THESE USED ONLY FOR NEARBY LAYER CALCULATIONS INCLUDING QH2O. -!----- THE WEIGHTING FUNCTION GTEMP=P(K)**0.2*(1.+P(K)/30000.)**0.8/ -! 1013250.,WHERE P(K)=PRESSURE,NMC MRF(NEW) L18 DATA LEVELS FOR -! PSTAR=1013250. -!----- STEMP IS US STANDARD ATMOSPHERES,1976,AT DATA PRESSURE LEVELS -! USING NMC MRF SIGMAS,WHERE PSTAR=1013.25 MB (PTZ PROGRAM) -!====> BEGIN HERE TO GET CONSTANTS FOR RADIATION PACKAGE -! - REWIND NFILE -! READ IN PRE-COMPUTED CO2 TRANSMISSION DATA.... -! - READ(NFILE) (SGTMP4(I,1),I=1,LP1) - READ(NFILE) (SGTMP4(I,2),I=1,LP1) - DO KK=1,6 - READ(NFILE) (CO21D4(I,KK),I=1,L) - ENDDO - DO KK=1,6 - READ(NFILE) ((CO22D4(I,J,KK),I=1,LP1),J=1,LP1) - ENDDO - DO KK=1,6 - READ(NFILE) (CO21D34(I,KK),I=1,LP1) - ENDDO - DO KK=1,6 - READ(NFILE) (CO21D74(I,KK),I=1,LP1) - ENDDO -! -! READ CO2 CONCENTRATION IN PPM (DEFAULTED IN GRADFS IF MISSING) - READ(NFILE,END=31) RCO24 - 31 CONTINUE -! - SGTMP = SGTMP4 - CO21D = CO21D4 - CO22D = CO22D4 - CO21D3 = CO21D34 - CO21D7 = CO21D74 - RCO2 = RCO24 -! - REWIND NFILE -! -! PRINT 66,NFILE -! 66 FORMAT(1H ,'----READ CO2 TRANSMISSION FUNCTIONS FROM UNIT ',I2) -! -!...... DEFINE TABLES FOR LW RADIATION -! - CALL LWTABLE(LP1,LP1V, SOURCE,DSRCE) -! - RETURN - END diff --git a/src/fim/FIMsrc/fim/column/coordinate_def.f b/src/fim/FIMsrc/fim/column/coordinate_def.f deleted file mode 100755 index f56d8f6..0000000 --- a/src/fim/FIMsrc/fim/column/coordinate_def.f +++ /dev/null @@ -1,15 +0,0 @@ - module coordinate_def -! use resol_def - use machine - implicit none - save - real(kind=kind_evod) , allocatable :: - . AK5(:),BK5(:),CK5(:),CK(:),DBK(:),bkl(:), ! hmhj - . AMHYB(:,:),BMHYB(:,:),SVHYB(:),tor_hyb(:), - . D_HYB_m(:,:,:),THREF(:),dm205_hyb(:,:,:) ! hmhj - real(kind=kind_evod) vertcoord_id,eps_si ! hmhj - -! - real(kind=kind_evod) , allocatable :: vcoord(:,:) - integer nvcoord, idsl, idvc, idvm - end module coordinate_def diff --git a/src/fim/FIMsrc/fim/column/copy.ksh b/src/fim/FIMsrc/fim/column/copy.ksh deleted file mode 100755 index 178bcb0..0000000 --- a/src/fim/FIMsrc/fim/column/copy.ksh +++ /dev/null @@ -1,15 +0,0 @@ -#!/bin/ksh - -# copy script for column -#JR These files were built and stored in library libw3_4.a but can't be -#JR used here because they need to be built with 8-byte reals - -#TBH Hack since IBM does not include rsync in default path -#TBH function update { rsync -ut $1 .; } -function update { cp -f $1 .; } - -# linking the .mod files works for ifort but not for the Lahey compiler. -update ../../w3/iw3jdn.f -update ../../w3/w3fs26.f -update ../../w3/w3movdat.f -update ../../w3/w3reddat.f diff --git a/src/fim/FIMsrc/fim/column/coundummy.f b/src/fim/FIMsrc/fim/column/coundummy.f deleted file mode 100644 index d71cb4e..0000000 --- a/src/fim/FIMsrc/fim/column/coundummy.f +++ /dev/null @@ -1,28 +0,0 @@ - subroutine init_countperf(lat) - integer lat - return - end - subroutine countperf(flag,ic,nop) - integer flag,ic - real nop - return - end - subroutine end_countperf() - return - end - subroutine write_countperf(npes,me,hours) - integer npes,me - real hours - return - end - subroutine synchro - return - end - FUNCTION timer() - integer timer - timer=0. - return - end - subroutine synctime() - return - end diff --git a/src/fim/FIMsrc/fim/column/crhtab.f b/src/fim/FIMsrc/fim/column/crhtab.f deleted file mode 100644 index facc022..0000000 --- a/src/fim/FIMsrc/fim/column/crhtab.f +++ /dev/null @@ -1,282 +0,0 @@ - SUBROUTINE CRHTAB(RHCL,IER) -C--------------------------------------------------------------------- -C.. CLD-RH RELATIONS OBTAINED FROM MITCHELL-HAHN PROCEDURE, HERE READ -C CLD/RH TUNING TABLES FOR DAY 0,1,...,5 AND MERGE INTO 1 FILE.. -C .............K.A.C. MAR 93 -C USE ONLY ONE TABLE (DAY 1) FOR ALL FCST HRS....K.A.C. FEB 94 -c... 4 cld types .... KAC FEB96 -c... smooth out last bunch of bins of the tables...KAC AUG97 -C OUTPUT: -C RHCL - TUNING TABLES FOR ALL FORECAST DAYS -C IER - =1 IF TABLES AVAILABLE.. =-1 IF NO TABLES -C-------------------------------------------------------------------- - use machine - implicit none -!! - integer mcld,nseal,ida,nbin,nlon,nlat,lon,jl,nc,lat,kcl,nsl - integer ken,icrit,isat,ibs,nb,kt,it,l,m,j,k,itim,ier,icfq,i - integer iy,im,n,kd,nbdayi,id,ld -CRH1T PARAMETER (MCLD=3,NSEAL=2,IDA=6, -cmcl3 PARAMETER (MCLD=3,NSEAL=2,IDA=1, - PARAMETER (MCLD=4,NSEAL=2,IDA=1, - 2 NBIN=100,NLON=2,NLAT=4) - real (kind=kind_io8) cstem,cfrac,clsat,rhsat,binscl - real (kind=kind_io8) RHFD(NBIN,NLON,NLAT,MCLD,NSEAL) - real (kind=kind_io8) RRHFD(NBIN,NLON,NLAT,MCLD,NSEAL) - real (kind=kind_io8) RTNFFD(NBIN,NLON,NLAT,MCLD,NSEAL) - real (kind=kind_io8) RRNFFD(NBIN,NLON,NLAT,MCLD,NSEAL) - real (kind=kind_io8) RHCF(NBIN,NLON,NLAT,MCLD,NSEAL) - real (kind=kind_io8) RTNFCF(NBIN,NLON,NLAT,MCLD,NSEAL) - INTEGER KPTS(NLON,NLAT,MCLD,NSEAL) - INTEGER KKPTS(NLON,NLAT,MCLD,NSEAL) - real (kind=kind_io8) RHC(NLON,NLAT,MCLD,NSEAL) - real (kind=kind_io8) RHCL (NBIN,NLON,NLAT,MCLD,NSEAL,IDA) - real (kind=kind_io8) RHCLA(NBIN,NLON,NLAT,MCLD,NSEAL) - INTEGER ICDAYS(15),IDATE(4) - real(kind=kind_io4) fhour - real(kind=kind_io4) RHFD4(NBIN,NLON,NLAT,MCLD,NSEAL) - real(kind=kind_io4) RTNFFD4(NBIN,NLON,NLAT,MCLD,NSEAL) -C........................... BEGIN HERE .............. - IER = 1 - DO 8000 ITIM=1,IDA - ICFQ = 43 + ITIM-1 - REWIND ICFQ -Cmcl3 NCLDS=1,2,3 (L,M,H)..JSL=1,2 (LAND,SEA) -cmcl4 MCLD=1,2,3,4 (BL,L,M,H) - BINSCL = 1./NBIN - DO 1000 M=1,NSEAL - DO 1000 L=1,MCLD - DO 1000 K=1,NLAT - DO 1000 J=1,NLON - DO 1000 I=1,NBIN - RRHFD(I,J,K,L,M) = 0. - RRNFFD(I,J,K,L,M) = 0. - 1000 CONTINUE - DO 1001 M=1,NSEAL - DO 1001 L=1,MCLD - DO 1001 K=1,NLAT - DO 1001 J=1,NLON - KKPTS(J,K,L,M) = 0 - 1001 CONTINUE -C.... READ THE DATA OFF THE ROTATING FILE - READ (ICFQ,ERR=998,END=999) NBDAYI,ICDAYS - DO 53 LD=1,NBDAYI - ID = ICDAYS(LD) / 10000 - IM = (ICDAYS(LD)-ID*10000) / 100 - IY = ICDAYS(LD)-ID*10000-IM*100 - 53 CONTINUE - READ (ICFQ,ERR=998,END=999) FHOUR,IDATE -csela PRINT 3003,IDATE,FHOUR,ITIM - DO 1300 KD=1,NBDAYI - READ (ICFQ) RHFD4 - RHFD=RHFD4 - READ (ICFQ) RTNFFD4 - RTNFFD=RTNFFD4 - READ (ICFQ) KPTS - - DO 1002 M=1,NSEAL - DO 1002 L=1,MCLD - DO 1002 K=1,NLAT - DO 1002 J=1,NLON - DO 1002 I=1,NBIN - RRHFD(I,J,K,L,M) = RRHFD(I,J,K,L,M) + RHFD(I,J,K,L,M) - RRNFFD(I,J,K,L,M) = RRNFFD(I,J,K,L,M)+RTNFFD(I,J,K,L,M) - 1002 CONTINUE - DO 1003 M=1,NSEAL - DO 1003 L=1,MCLD - DO 1003 K=1,NLAT - DO 1003 J=1,NLON - KKPTS(J,K,L,M) = KKPTS(J,K,L,M) + KPTS(J,K,L,M) - 1003 CONTINUE - 1300 CONTINUE -C - DO 1004 M=1,NSEAL - DO 1004 L=1,MCLD - DO 1004 K=1,NLAT - DO 1004 J=1,NLON - DO 1004 I=1,NBIN - RHCF(I,J,K,L,M) = RRHFD(I,J,K,L,M) - RTNFCF(I,J,K,L,M) = RRNFFD(I,J,K,L,M) - 1004 CONTINUE - DO 1005 M=1,NSEAL - DO 1005 L=1,MCLD - DO 1005 K=1,NLAT - DO 1005 J=1,NLON - KPTS(J,K,L,M) = KKPTS(J,K,L,M) - 1005 CONTINUE -C..... COMPUTE THE CUMULATIVE FREQUENCY DISTRIBUTION.. - DO 200 N=1,NSEAL - DO 200 K=1,MCLD - DO 200 L=1,NLAT - DO 200 J=1,NLON - DO 190 I=2,NBIN - RHCF(I,J,L,K,N) = RHCF(I-1,J,L,K,N) + RHCF(I,J,L,K,N) - RTNFCF(I,J,L,K,N)=RTNFCF(I-1,J,L,K,N) + RTNFCF(I,J,L,K,N) - 190 CONTINUE - 200 CONTINUE - DO 300 N=1,NSEAL - DO 300 L=1,NLAT - DO 300 J=1,NLON - DO 300 K=1,MCLD - DO 300 I=1,NBIN - IF (KPTS(J,L,K,N).GT.0) THEN - RHCF(I,J,L,K,N) = RHCF(I,J,L,K,N) / KPTS(J,L,K,N) - RTNFCF(I,J,L,K,N) = RTNFCF(I,J,L,K,N) / KPTS(J,L,K,N) -c... cause we mix calculations of rh retune with cray and ibm words -c the last value of rhcf is close to but ne 1.0, -c so we reset it in order that the 360 loop gives compleat tabl -c... rtnfcf caused couple of problems, seems to be ever so slightly -c gt 1.0 - IF (I.EQ.NBIN) THEN - RHCF(I,J,L,K,N) = 1.0 - END IF - IF (RTNFCF(I,J,L,K,N).GE.1.0) THEN - RTNFCF(I,J,L,K,N) = 1.0 - END IF - ELSE - RHCF(I,J,L,K,N) = -0.1 - RTNFCF(I,J,L,K,N) = -0.1 - END IF - 300 CONTINUE - DO 255 NSL=1,NSEAL - DO 255 KCL=1,MCLD -csela PRINT 264,KCL,NSL -csela PRINT 265,((KPTS(I,L,KCL,NSL),I=1,NLON),L=1,NLAT) - 255 CONTINUE - DO 360 NSL=1,NSEAL - DO 360 K=1,MCLD - DO 360 L=1,NLAT - DO 360 J=1,NLON - IF (KPTS(J,L,K,NSL).LE.0) GO TO 317 - DO 320 I=1,NBIN - ICRIT = I - IF (RHCF(I,J,L,K,NSL).GE.RTNFCF(1,J,L,K,NSL)) GO TO 350 - 320 CONTINUE -C... NO CRITICAL RH - 317 ICRIT=-1 - 350 RHC(J,L,K,NSL) = ICRIT * BINSCL - 360 CONTINUE -csela DO 1210 NSL=1,NSEAL -csela DO 1210 K=1,MCLD -csela PRINT 1221,K,NSL -csela DO 1210 L=1,NLAT -csela PRINT 211,(RHC(J,L,K,NSL),J=1,NLON) -csela 1210 CONTINUE - DO 450 NSL=1,NSEAL - DO 450 KEN=1,MCLD - DO 450 L=1,NLAT - DO 450 JL=1,NLON - DO 400 I=1,NBIN - RHCL(I,JL,L,KEN,NSL,ITIM) = -0.1 - 400 CONTINUE - 450 CONTINUE - DO 751 NSL=1,NSEAL - DO 751 KEN=1,MCLD - DO 751 L=1,NLAT - DO 751 JL=1,NLON - IF (KPTS(JL,L,KEN,NSL).LE.0) GO TO 751 - DO 753 I=1,NBIN - DO 755 J=1,NBIN - IF (RHCF(J,JL,L,KEN,NSL).GE.RTNFCF(I,JL,L,KEN,NSL)) THEN - RHCL(I,JL,L,KEN,NSL,ITIM) = J*BINSCL - GO TO 753 - END IF - 755 CONTINUE - 753 CONTINUE - 751 CONTINUE - DO 3000 LON=1,NLON - DO 3000 LAT=1,NLAT - DO 3000 NC=1,MCLD - DO 3000 NSL=1,NSEAL - ISAT = 0 - DO 67 IT=1,NBIN - CFRAC = BINSCL * (IT-1) - IF (RHCL(IT,LON,LAT,NC,NSL,ITIM).LT.0.) THEN - PRINT 1941,IT,NSL,NC,LAT,LON - STOP - END IF - IF (IT.LT.NBIN.AND.RTNFCF(IT,LON,LAT,NC,NSL).GE.1.) THEN - IF (ISAT.LE.0) THEN - ISAT = IT - RHSAT = RHCL(IT,LON,LAT,NC,NSL,ITIM) - CLSAT = CFRAC - END IF - RHCL(IT,LON,LAT,NC,NSL,ITIM) = - 1 RHSAT + (1.-RHSAT)*(CFRAC-CLSAT)/(1.-CLSAT) - END IF - IF (IT.EQ.NBIN) RHCL(IT,LON,LAT,NC,NSL,ITIM) = 1. - 67 CONTINUE - 3000 CONTINUE -c... smooth out the table as it reaches rh=1.0, via linear interpolation -c between location of rh ge .98 and the NBIN bin (where rh=1.0) -c... previously rh=1.0 occurred for many of the latter bins in the -c table, thereby giving a cloud value of less then 1.0 for rh=1.0 - nb=nbin-2 - DO 4000 LON=1,NLON - DO 4000 LAT=1,NLAT - DO 4000 NC=1,MCLD - DO 4000 NSL=1,NSEAL - do 4167 it=1,nbin - RHCLA(IT,LON,LAT,NC,NSL)=RHCL(IT,LON,LAT,NC,NSL,ITIM) - 4167 continue - DO 4067 IT=1,nb - ibs=it - cfrac=binscl*ibs - IF (RHCL(IT,LON,LAT,NC,NSL,ITIM).ge..98) THEN -CC Print 4011,nsl,nc,lat,lon,ibs,nbin -CC 4011 format (1h ,'nsl,nc,lat,lon,ibs,nbin=',6i4) - do 4068 kt=ibs,nbin - cstem=binscl*kt - RHCLA(kt,LON,LAT,NC,NSL) = - 1 rhcl(ibs,LON,LAT,NC,NSL,ITIM)+ - 2 (rhcl(nbin,LON,LAT,NC,NSL,ITIM) - 3 -rhcl(ibs,LON,LAT,NC,NSL,ITIM))* - 3 (cstem-cfrac)/(1.-cfrac) -c if (nc.eq.2.and.lat.eq.2.and.lo.eq.1.and.nsl.eq.2) then -c print 4012,kt,cstem,cfrac,rhcl(ibs,LON,LAT,NC,NSL,ITIM), -c 1 RHCLA(kt,LON,LAT,NC,NSL) -c 4012 format(1h ,'kt,cs,cf,rhibs,rhcla=',i5,4f12.8) -c end if - 4068 continue - go to 4000 - end if - 4067 CONTINUE - 4000 CONTINUE -c... restore table data to preferred location.. - DO 4200 LON=1,NLON - DO 4200 LAT=1,NLAT - DO 4200 NC=1,MCLD - DO 4200 NSL=1,NSEAL - DO 4200 IT=1,NBIN - RHCL(IT,LON,LAT,NC,NSL,ITIM)= RHCLA(IT,LON,LAT,NC,NSL) - 4200 CONTINUE - 8000 CONTINUE - DO 8001 KEN=1,IDA - ICFQ = 42 + KEN - REWIND ICFQ - 8001 CONTINUE - RETURN - 998 PRINT 988,ITIM - IER = -1 - RETURN - 999 PRINT 989,ITIM - IER = -1 - RETURN - 11 FORMAT(1H ,' from crhtab DAYS ON FILE =',I5) - 51 FORMAT(1H ,' from crhtab ARCHV DATA FROM DA,MO,YR=',3I4) - 202 FORMAT(1H0,' MODEL RH ',' OBS RTCLD') - 203 FORMAT(2F10.2) - 210 FORMAT(1H ,' NO CRIT RH FOR LAT=',I3,' AND LON BAND=',I3, - 1 ' LAND(=1) SEA=',I3) - 211 FORMAT(1H ,15F6.2) - 264 FORMAT(1H ,' NUMBER OF GG POINTS USED IN EACH AREA..BY LATITUDE', - 1 '..FOR CLOUD TYPE=',I4,'SEALAND=',I2) - 265 FORMAT(1H ,15I8) - 988 FORMAT(1H ,'from crhtab ERROR READING TABLES FOR TIME=',I4) - 989 FORMAT(1H ,'from crhtab E.O.F READING TABLES FOR TIME=',I4) - 1221 FORMAT(1H0,' CRITICAL RH FOR LON,LAT ARRAYS FOR CLD TYPE=',I3, - 1 ' LAND(=1) SEA=',I3) - 1941 FORMAT(1H ,' NEG RHCL FOR IT,NSL,NC,LAT,LON=',5I4,'...STOPPP..') - 3003 FORMAT(5X,'...LAST DATE/TIME AND CURRENT ITIM',/,10X, - 1 4I15,F7.1,I6) - END diff --git a/src/fim/FIMsrc/fim/column/date_def.f b/src/fim/FIMsrc/fim/column/date_def.f deleted file mode 100644 index 5d7186c..0000000 --- a/src/fim/FIMsrc/fim/column/date_def.f +++ /dev/null @@ -1,10 +0,0 @@ - module date_def -! use resol_def - use machine - implicit none - save - integer idate(4) - real(kind=kind_evod) fhour,shour,thour,z00 - REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: spdmax(:) - - end module date_def diff --git a/src/fim/FIMsrc/fim/column/dcyc2_v.f b/src/fim/FIMsrc/fim/column/dcyc2_v.f deleted file mode 100644 index 54a365e..0000000 --- a/src/fim/FIMsrc/fim/column/dcyc2_v.f +++ /dev/null @@ -1,74 +0,0 @@ -CFPP$ NOCONCUR R - SUBROUTINE DCYC2T3(IX,IM,LEVS,SOLHR,SLAG, - & SINLAB,COSLAB,SDEC,CDEC, - & XLON,CZMN,SFCDLW,SFCNSW,TF, - & SFCDSW,DSWSFC, ! FOR SEA-ICE - XW Nov04 - & TSEA,TSFLW,SWH,HLW, - & DLWSFC,ULWSFC,SLRAD,TAU,XMU,xcosz) -! - USE MACHINE , ONLY : kind_phys - USE PHYSCONS, PI => con_PI, SBC => con_SBC - implicit none -! -! include 'constant.h' -! - integer levs,IM,IX - real(kind=kind_phys) cdec,cnwatt,hsigma,sdec,slag,solhr - real(kind=kind_phys) SINLAB(IM) , COSLAB(IM), XLON(IM), - & CZMN(IM), SFCDLW(IM), SFCNSW(IM), - & TF(IM), TSEA(IM), TSFLW(IM), - & DLWSFC(IM), ULWSFC(IM), SLRAD(IM), -!yth add cosine of zenith angle as output for sunshine time calc. 3/08 -! & XMU(IM) - & XMU(IM), xcosz(IM) - real(kind=kind_phys) SWH(IX,LEVS), HLW(IX,LEVS), TAU(IM,LEVS) -!c-- XW: FOR SEA-ICE Nov04 -C ADD SFCDSW (INPUT) & DSWSFC (OUTPUT) - real(kind=kind_phys) SFCDSW(IM), DSWSFC(IM) -!c-- XW: END SEA-ICE -! PARAMETER (HSIGMA=SBC,CNWATT=-con_JCAL*1.E4/60.) - integer I, K - real(kind=kind_phys) cns,ss,cc,ch,sdlw, tem -C----------------------------------------------------------------------- -C COMPUTE COSINE OF SOLAR ZENITH ANGLE FOR BOTH HEMISPHERES. - CNS = PI*(SOLHR-12.)/12.+SLAG - DO I=1,IM - SS = SINLAB(I) * SDEC - CC = COSLAB(I) * CDEC - CH = CC * COS(XLON(I)+CNS) - XMU(I) = CH + SS - ENDDO -C XMU=(SINLAB*SDEC) -C 1 +(COSLAB*CDEC)*COS(XLON+CNS) -CC DO I=1,LON2 -C NORMALIZE BY AVERAGE VALUE OVER RADIATION PERIOD FOR DAYTIME. - DO I=1,IM - xcosz(i) = xmu(i) - IF(XMU(I).GT.0.0001.AND.CZMN(I).GT.0.0001) THEN - XMU(I) = XMU(I) / CZMN(I) - ELSE - XMU(I) = 0. - ENDIF -C ADJUST LONGWAVE FLUX AT SURFACE TO ACCOUNT FOR T CHANGES IN LAYER 1. -! SDLW = SFCDLW(I)*(TF(I)/TSFLW(I))**4 - TEM = TF(I) / TSFLW(I) - TEM = TEM * TEM - DLWSFC(I) = SFCDLW(I) * TEM * TEM -C RETURN NET SURFACE RADIATIVE FLUX. -! SLRAD(I) = SFCNSW(I)*XMU(I) + SDLW - SLRAD(I) = SFCNSW(I)*XMU(I) - DLWSFC(I) - DSWSFC(I) = SFCDSW(I)*XMU(I) ! FOR SEA-ICE - XW Nov04 -C RETURN DOWNWARD AND UPWARD LONGWAVE FLUX AT GROUND, RESPECTIVELY. -! DLWSFC(I) = SDLW*CNWATT -! ULWSFC(I) = HSIGMA*TSEA(I)**4 - TEM = TSEA(I) * TSEA(I) - ULWSFC(I) = SBC * TEM * TEM - ENDDO -C ADD RADIATIVE HEATING TO TEMPERATURE TENDENCY - DO K=1,LEVS - DO I=1,IM - TAU(I,K) = TAU(I,K) + SWH(I,K)*XMU(I) + HLW(I,K) - ENDDO - ENDDO - RETURN - END diff --git a/src/fim/FIMsrc/fim/column/dcyc2_v.pre.rad.f b/src/fim/FIMsrc/fim/column/dcyc2_v.pre.rad.f deleted file mode 100644 index bfe50fa..0000000 --- a/src/fim/FIMsrc/fim/column/dcyc2_v.pre.rad.f +++ /dev/null @@ -1,73 +0,0 @@ - subroutine dcyc2t3_pre_rad(ix,im,levs,solhr,slag, - & sinlab,coslab,sdec,cdec, - & xlon,czmn,sfcdlw,sfcnsw,tf, - & sfcdsw,dswsfc, ! FOR SEA-ICE - XW Nov04 - & tsea,tsflw,swh,hlw, -!yth add xcosz as output for sunshine time calc. mar/08 -! & dlwsfc,ulwsfc,slrad,tau,xmu) - & dlwsfc,ulwsfc,slrad,tau,xmu,xcosz) - use machine , only : kind_phys - use physcons, pi => con_pi, sbc => con_sbc,jcal=>con_JCAL - implicit none - integer levs,im,ix - real(kind=kind_phys) cdec,cnwatt,hsigma,sdec,slag,solhr - real(kind=kind_phys) sinlab(im) , coslab(im), xlon(im), - & czmn(im), sfcdlw(im), sfcnsw(im), - & tf(im), tsea(im), tsflw(im), - & dlwsfc(im), ulwsfc(im), slrad(im), -!yth add xcosz as output var -! & xmu(im) - & xmu(im), xcosz(im) - real(kind=kind_phys) swh(ix,levs), hlw(ix,levs), tau(im,levs) -!c-- XW: FOR SEA-ICE Nov04 -C ADD SFCDSW (INPUT) & DSWSFC (OUTPUT) - real(kind=kind_phys) sfcdsw(im), dswsfc(im) -!c-- XW: END SEA-ICE - integer i, k - real(kind=kind_phys) cns,ss,cc,ch,sdlw, tem - PARAMETER (CNWATT=-jcal*1.E4/60.) - - - slag=0. - hlw=0. - swh=0. - sfcnsw=0. - sfcdlw=350./cnwatt -!sela - - cns = pi*(solhr-12.)/12.+slag - do i=1,im -!sela ss = sinlab(i) * sdec -!sela cc = coslab(i) * cdec -!sela ch = cc * cos(xlon(i)+cns) -!sela xmu(i) = ch + ss - SS=0.5 - CC=0.5 - CH=0.5 -!yth mar/08 - XMU(i)=CH+SS - CZMN(i)=0.1 - - enddo - do i=1,im - xcosz(i) = xmu(i) - if(xmu(i).gt.0.01.and.czmn(i).gt.0.01) then - xmu(i) = xmu(i) / czmn(i) - else - xmu(i) = 0. - endif - tem = tf(i) / tsflw(i) - tem = tem * tem - dlwsfc(i) = sfcdlw(i) * tem * tem - slrad(i) = sfcnsw(i)*xmu(i) - dlwsfc(i) - dswsfc(i) = sfcdsw(i)*xmu(i) ! FOR SEA-ICE - XW Nov04 - tem = tsea(i) * tsea(i) - ulwsfc(i) = sbc * tem * tem - enddo - do k=1,levs - do i=1,im - tau(i,k) = tau(i,k) + swh(i,k)*xmu(i) + hlw(i,k) - enddo - enddo - return - end diff --git a/src/fim/FIMsrc/fim/column/delnpe.f b/src/fim/FIMsrc/fim/column/delnpe.f deleted file mode 100644 index 9245c92..0000000 --- a/src/fim/FIMsrc/fim/column/delnpe.f +++ /dev/null @@ -1,169 +0,0 @@ - subroutine delnpe(qe,odphi,edlam,epse,epso, - x ls_node) -cc - -cc - use resol_def - use layout1 - use physcons, rerth => con_rerth - implicit none -cc -cc input q is in ibm triang. order -cc output is in ibm triang. order -cc - real(kind=kind_evod) qe(len_trie_ls,2) - real(kind=kind_evod) odphi(len_trio_ls,2) - real(kind=kind_evod) edlam(len_trie_ls,2) -cc - real(kind=kind_evod) epse(len_trie_ls) - real(kind=kind_evod) epso(len_trio_ls) -cc - integer ls_node(ls_dim,3) -cc -!cmr ls_node(1,1) ... ls_node(ls_max_node,1) : values of L -!cmr ls_node(1,2) ... ls_node(ls_max_node,2) : values of jbasev -!cmr ls_node(1,3) ... ls_node(ls_max_node,3) : values of jbasod -cc - integer l,locl,n -cc - integer indev,indev1,indev2 - integer indod,indod1,indod2 - integer inddif -cc - real(kind=kind_evod) aa,r1mn,rl,rnp2 -cc - real(kind=kind_evod) cons1 !constant - real(kind=kind_evod) cons2 !constant -cc - integer indlsev,jbasev - integer indlsod,jbasod -cc - include 'function2' -cc -cc -cc...................................................................... -cc -cc - CALL countperf(0,13,0.) -!! - cons1 = 1.d0 !constant - cons2 = 2.d0 !constant -cc -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - indev1 = indlsev(L,L) - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap+1,L) - else - indev2 = indlsev(jcap ,L) - endif - rl=l - do indev = indev1 , indev2 -cc dlam(l,n)= i*l*q(l,n) -cc - edlam(indev,1) = -rl * qe(indev,2) - edlam(indev,2) = rl * qe(indev,1) -cc - enddo -cc - enddo -cc -cc...................................................................... -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - jbasod=ls_node(locl,3) - indev1 = indlsev(L,L) - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap-1,L) - else - indev2 = indlsev(jcap ,L) - endif - indod1 = indlsod(l+1,l) - inddif = indev1 - indod1 -cc - r1mn = -l - do indev = indev1 , indev2 -cc - odphi(indev-inddif,1) = - 1 r1mn * epso(indev-inddif) * qe(indev,1) -cc - odphi(indev-inddif,2) = - 1 r1mn * epso(indev-inddif) * qe(indev,2) -cc - r1mn = r1mn - cons2 !constant - enddo -cc - enddo -cc -cc...................................................................... -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - jbasod=ls_node(locl,3) - indev1 = indlsev(L,L) + 1 - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap-1,L) - else - indev2 = indlsev(jcap ,L) - endif - indod1 = indlsod(l+1,l) - inddif = indev1 - indod1 -cc - rnp2 = l+3 - do indev = indev1 , indev2 -cc - odphi(indev-inddif,1) = odphi(indev-inddif,1) + - 1 rnp2 * epse(indev) * qe(indev ,1) -cc - odphi(indev-inddif,2) = odphi(indev-inddif,2) + - 1 rnp2 * epse(indev) * qe(indev ,2) -cc - rnp2 = rnp2 + cons2 !constant - enddo -cc - enddo -cc -cc...................................................................... -cc - aa=cons1/rerth !constant -cc -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - jbasod=ls_node(locl,3) - indev1 = indlsev(L,L) - indod1 = indlsod(L+1,L) - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap+1,L) - indod2 = indlsod(jcap ,L) - else - indev2 = indlsev(jcap ,L) - indod2 = indlsod(jcap+1,L) - endif - DO indev = indev1 , indev2 -cc - edlam(indev,1) = edlam(indev,1) * aa - edlam(indev,2) = edlam(indev,2) * aa -cc - enddo -cc - do indod = indod1 , indod2 -cc - odphi(indod,1) = odphi(indod,1) * aa - odphi(indod,2) = odphi(indod,2) * aa -cc - enddo -cc -cc - enddo -cc - CALL countperf(1,13,0.) -!! - return - end diff --git a/src/fim/FIMsrc/fim/column/delnpo.f b/src/fim/FIMsrc/fim/column/delnpo.f deleted file mode 100644 index 00cf5df..0000000 --- a/src/fim/FIMsrc/fim/column/delnpo.f +++ /dev/null @@ -1,183 +0,0 @@ - subroutine delnpo(qo,edphi,odlam,epse,epso, - x ls_node) -cc - -cc - use resol_def - use layout1 - use physcons, rerth => con_rerth - implicit none -cc -cc input q is in ibm triang. order -cc output is in ibm triang. order -cc - real(kind=kind_evod) qo(len_trio_ls,2) - real(kind=kind_evod) edphi(len_trie_ls,2) - real(kind=kind_evod) odlam(len_trio_ls,2) -cc - real(kind=kind_evod) epse(len_trie_ls) - real(kind=kind_evod) epso(len_trio_ls) -cc - integer ls_node(ls_dim,3) -cc -!cmr ls_node(1,1) ... ls_node(ls_max_node,1) : values of L -!cmr ls_node(1,2) ... ls_node(ls_max_node,2) : values of jbasev -!cmr ls_node(1,3) ... ls_node(ls_max_node,3) : values of jbasod -cc - integer l,locl,n -cc - integer indev,indev1,indev2 - integer indod,indod1,indod2 - integer inddif -cc - real(kind=kind_evod) aa,r1mn,rl,rnp2 -cc - real(kind=kind_evod) cons0 !constant - real(kind=kind_evod) cons1 !constant - real(kind=kind_evod) cons2 !constant -cc - integer indlsev,jbasev - integer indlsod,jbasod -cc - include 'function2' -cc -cc -cc...................................................................... -cc -cc - CALL countperf(0,13,0.) -!! - cons0 = 0.d0 !constant - cons1 = 1.d0 !constant - cons2 = 2.d0 !constant -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasod=ls_node(locl,3) - indod1 = indlsod(L+1,L) - if (mod(L,2).eq.mod(jcap+1,2)) then - indod2 = indlsod(jcap ,L) - else - indod2 = indlsod(jcap+1,L) - endif -cc - rl = l - do indod = indod1 , indod2 -cc dlam(l,n)= i*l*q(l,n) -cc - odlam(indod,1) = -rl * qo(indod,2) - odlam(indod,2) = rl * qo(indod,1) -cc - enddo -cc - enddo -cc -cc...................................................................... -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - jbasod=ls_node(locl,3) - indev1 = indlsev(L,L) + 1 - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap+1,L) - else - indev2 = indlsev(jcap ,L) - endif - indod1 = indlsod(l+1,l) - inddif = indev1 - indod1 -cc - r1mn = -l - 1 - do indev = indev1 , indev2 -cc - edphi(indev,1) = - 1 r1mn * epse(indev) * qo(indev-inddif,1) -cc - edphi(indev,2) = - 1 r1mn * epse(indev) * qo(indev-inddif,2) -cc - r1mn = r1mn - cons2 !constant - enddo -cc - enddo -cc -cc...................................................................... -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) -cc - edphi(indlsev(l,l),1) = cons0 !constant - edphi(indlsev(l,l),2) = cons0 !constant -cc -cc - enddo -cc -cc...................................................................... -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - jbasod=ls_node(locl,3) - indev1 = indlsev(L,L) - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap+1,L) - 1 - else - indev2 = indlsev(jcap ,L) - 1 - endif - indod1 = indlsod(l+1,l) - inddif = indev1 - indod1 -cc - rnp2 = l+2 - do indev = indev1 , indev2 -cc - edphi(indev,1) = edphi(indev ,1) + - 1 rnp2 * epso(indev-inddif) * qo(indev-inddif,1) -cc - edphi(indev,2) = edphi(indev ,2) + - 1 rnp2 * epso(indev-inddif) * qo(indev-inddif,2) -cc - rnp2 = rnp2 + cons2 !constant - enddo -cc - enddo -cc -cc...................................................................... -cc - aa=cons1/rerth !constant -cc -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - jbasod=ls_node(locl,3) - indev1 = indlsev(L,L) - indod1 = indlsod(L+1,L) - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap+1,L) - indod2 = indlsod(jcap ,L) - else - indev2 = indlsev(jcap ,L) - indod2 = indlsod(jcap+1,L) - endif - do indod = indod1 , indod2 -cc - odlam(indod,1) = odlam(indod,1) * aa - odlam(indod,2) = odlam(indod,2) * aa -cc - enddo -cc - do indev = indev1 , indev2 -cc - edphi(indev,1) = edphi(indev,1) * aa - edphi(indev,2) = edphi(indev,2) * aa -cc - enddo -cc -cc - enddo -cc - CALL countperf(1,13,0.) -!! - return - end diff --git a/src/fim/FIMsrc/fim/column/dezouv.f b/src/fim/FIMsrc/fim/column/dezouv.f deleted file mode 100644 index a2a1995..0000000 --- a/src/fim/FIMsrc/fim/column/dezouv.f +++ /dev/null @@ -1,259 +0,0 @@ - subroutine dezouv(dev,zod,uev,vod,epsedn,epsodn, - x snnp1ev,snnp1od,ls_node) -cc - -cc - use resol_def - use layout1 - use physcons, rerth => con_rerth - implicit none -cc - real(kind=kind_evod) dev(len_trie_ls,2) - real(kind=kind_evod) zod(len_trio_ls,2) - real(kind=kind_evod) uev(len_trie_ls,2) - real(kind=kind_evod) vod(len_trio_ls,2) -cc - real(kind=kind_evod) epsedn(len_trie_ls) - real(kind=kind_evod) epsodn(len_trio_ls) -cc - real(kind=kind_evod) snnp1ev(len_trie_ls) - real(kind=kind_evod) snnp1od(len_trio_ls) -cc - integer ls_node(ls_dim,3) -cc -!cmr ls_node(1,1) ... ls_node(ls_max_node,1) : values of L -!cmr ls_node(1,2) ... ls_node(ls_max_node,2) : values of jbasev -!cmr ls_node(1,3) ... ls_node(ls_max_node,3) : values of jbasod -cc - integer l,locl,n -cc - integer indev,indev1,indev2 - integer indod,indod1,indod2 - integer inddif -cc - real(kind=kind_evod) rl -cc - real(kind=kind_evod) cons0 !constant -cc - integer indlsev,jbasev - integer indlsod,jbasod -cc - include 'function2' -cc -cc -cc...................................................................... -cc -cc - cons0 = 0.d0 !constant -cc -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) -cc - uev(indlsev(l,l),1) = cons0 !constant - uev(indlsev(l,l),2) = cons0 !constant -cc -cc - enddo -cc -cc...................................................................... -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - jbasod=ls_node(locl,3) - indev1 = indlsev(L,L) + 1 - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap+1,L) - else - indev2 = indlsev(jcap ,L) - endif - indod1 = indlsod(l+1,l) - inddif = indev1 - indod1 -cc - do indev = indev1 , indev2 -cc - uev(indev,1) = -epsedn(indev) - x * zod(indev-inddif,1) -cc - uev(indev,2) = -epsedn(indev) - x * zod(indev-inddif,2) -cc - enddo -cc - enddo -cc -cc...................................................................... -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - jbasod=ls_node(locl,3) - indev1 = indlsev(L,L) - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap-1,L) - else - indev2 = indlsev(jcap ,L) - endif - indod1 = indlsod(l+1,l) - inddif = indev1 - indod1 -cc - do indev = indev1 , indev2 -cc - vod(indev-inddif,1) = epsodn(indev-inddif) - x * dev(indev,1) -cc - vod(indev-inddif,2) = epsodn(indev-inddif) - x * dev(indev,2) -cc - enddo -cc - enddo -cc -cc...................................................................... -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - indev1 = indlsev(L,L) - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap-1,L) - else - indev2 = indlsev(jcap ,L) - endif - if ( l .ge. 1 ) then - rl = l - do indev = indev1 , indev2 -cc u(l,n)=-i*l*d(l,n)/(n*(n+1)) -cc - uev(indev,1) = uev(indev,1) - 1 + rl * dev(indev,2) - 2 / snnp1ev(indev) -cc - uev(indev,2) = uev(indev,2) - 1 - rl * dev(indev,1) - 2 / snnp1ev(indev) -cc - enddo - endif -cc - enddo -cc -cc...................................................................... -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasod=ls_node(locl,3) - indod1 = indlsod(L+1,L) - if (mod(L,2).eq.mod(jcap+1,2)) then - indod2 = indlsod(jcap ,L) - else - indod2 = indlsod(jcap+1,L) - 1 - endif - if ( l .ge. 1 ) then - rl = l - do indod = indod1 , indod2 -cc u(l,n)=-i*l*d(l,n)/(n*(n+1)) -cc - vod(indod,1) = vod(indod,1) - 1 + rl * zod(indod,2) - 2 / snnp1od(indod) -cc - vod(indod,2) = vod(indod,2) - 1 - rl * zod(indod,1) - 2 / snnp1od(indod) -cc - enddo - endif -cc - enddo -cc -cc...................................................................... -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - jbasod=ls_node(locl,3) - indev1 = indlsev(L,L) - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap+1,L) - 1 - else - indev2 = indlsev(jcap ,L) - 1 - endif - indod1 = indlsod(l+1,l) - inddif = indev1 - indod1 -cc - do indev = indev1 , indev2 -cc - uev(indev,1) = uev(indev ,1) - 1 + epsodn(indev-inddif) * zod(indev-inddif,1) -cc - uev(indev,2) = uev(indev ,2) - 1 + epsodn(indev-inddif) * zod(indev-inddif,2) -cc - enddo -cc - enddo -cc -cc...................................................................... -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - jbasod=ls_node(locl,3) - indev1 = indlsev(L,L) + 1 - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap-1,L) - else - indev2 = indlsev(jcap ,L) - endif - indod1 = indlsod(l+1,l) - inddif = indev1 - indod1 -cc - do indev = indev1 , indev2 -cc - vod(indev-inddif,1) = vod(indev-inddif,1) - 1 - epsedn(indev) * dev(indev ,1) -cc - vod(indev-inddif,2) = vod(indev-inddif,2) - 1 - epsedn(indev) * dev(indev ,2) -cc - enddo -cc - enddo -cc -cc...................................................................... -cc -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - jbasod=ls_node(locl,3) - indev1 = indlsev(L,L) - indod1 = indlsod(L+1,L) - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap+1,L) - indod2 = indlsod(jcap ,L) - else - indev2 = indlsev(jcap ,L) - indod2 = indlsod(jcap+1,L) - endif - do indev = indev1 , indev2 -cc - uev(indev,1) = uev(indev,1) * rerth - uev(indev,2) = uev(indev,2) * rerth -cc - enddo -cc - do indod = indod1 , indod2 -cc - vod(indod,1) = vod(indod,1) * rerth - vod(indod,2) = vod(indod,2) * rerth -cc - enddo -cc - enddo -cc - return - end diff --git a/src/fim/FIMsrc/fim/column/dozeuv.f b/src/fim/FIMsrc/fim/column/dozeuv.f deleted file mode 100644 index 3d96cba..0000000 --- a/src/fim/FIMsrc/fim/column/dozeuv.f +++ /dev/null @@ -1,257 +0,0 @@ - subroutine dozeuv(dod,zev,uod,vev,epsedn,epsodn, - x snnp1ev,snnp1od,ls_node) -cc - use resol_def - use layout1 - use physcons, rerth => con_rerth - implicit none -cc - real(kind=kind_evod) dod(len_trio_ls,2) - real(kind=kind_evod) zev(len_trie_ls,2) - real(kind=kind_evod) uod(len_trio_ls,2) - real(kind=kind_evod) vev(len_trie_ls,2) -cc - real(kind=kind_evod) epsedn(len_trie_ls) - real(kind=kind_evod) epsodn(len_trio_ls) -cc - real(kind=kind_evod) snnp1ev(len_trie_ls) - real(kind=kind_evod) snnp1od(len_trio_ls) -cc - integer ls_node(ls_dim,3) -cc -!cmr ls_node(1,1) ... ls_node(ls_max_node,1) : values of L -!cmr ls_node(1,2) ... ls_node(ls_max_node,2) : values of jbasev -!cmr ls_node(1,3) ... ls_node(ls_max_node,3) : values of jbasod -cc - integer l,locl,n -cc - integer indev,indev1,indev2 - integer indod,indod1,indod2 - integer inddif -cc - real(kind=kind_evod) rl -cc - real(kind=kind_evod) cons0 !constant -cc - integer indlsev,jbasev - integer indlsod,jbasod -cc - include 'function2' -cc -cc -cc...................................................................... -cc -cc - cons0 = 0.d0 !constant -cc -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) -cc - vev(indlsev(l,l),1) = cons0 !constant - vev(indlsev(l,l),2) = cons0 !constant -cc -cc - enddo -cc -cc...................................................................... -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - jbasod=ls_node(locl,3) - indev1 = indlsev(L,L) - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap-1,L) - else - indev2 = indlsev(jcap ,L) - endif - indod1 = indlsod(l+1,l) - inddif = indev1 - indod1 -cc - do indev = indev1 , indev2 -cc - uod(indev-inddif,1) = -epsodn(indev-inddif) - x * zev(indev,1) -cc - uod(indev-inddif,2) = -epsodn(indev-inddif) - x * zev(indev,2) -cc - enddo -cc - enddo -cc -cc...................................................................... -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - jbasod=ls_node(locl,3) - indev1 = indlsev(L,L) + 1 - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap+1,L) - else - indev2 = indlsev(jcap ,L) - endif - indod1 = indlsod(l+1,l) - inddif = indev1 - indod1 -cc - do indev = indev1 , indev2 -cc - vev(indev,1) = epsedn(indev) - x * dod(indev-inddif,1) -cc - vev(indev,2) = epsedn(indev) - x * dod(indev-inddif,2) -cc - enddo -cc - enddo -cc -cc...................................................................... -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasod=ls_node(locl,3) - indod1 = indlsod(L+1,L) - if (mod(L,2).eq.mod(jcap+1,2)) then - indod2 = indlsod(jcap ,L) - else - indod2 = indlsod(jcap+1,L) - 1 - endif - if ( l .ge. 1 ) then - rl = l - do indod = indod1 , indod2 -cc u(l,n)=-i*l*d(l,n)/(n*(n+1)) -cc - uod(indod,1) = uod(indod,1) - 1 + rl * dod(indod,2) - 2 / snnp1od(indod) -cc - uod(indod,2) = uod(indod,2) - 1 - rl * dod(indod,1) - 2 / snnp1od(indod) -cc - enddo - endif -cc - enddo -cc -cc...................................................................... -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - indev1 = indlsev(L,L) - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap-1,L) - else - indev2 = indlsev(jcap ,L) - endif - if ( l .ge. 1 ) then - rl = l - do indev = indev1 , indev2 -cc u(l,n)=-i*l*d(l,n)/(n*(n+1)) -cc - vev(indev,1) = vev(indev,1) - 1 + rl * zev(indev,2) - 2 / snnp1ev(indev) -cc - vev(indev,2) = vev(indev,2) - 1 - rl * zev(indev,1) - 2 / snnp1ev(indev) -cc - enddo - endif -cc - enddo -cc -cc...................................................................... -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - jbasod=ls_node(locl,3) - indev1 = indlsev(L,L) + 1 - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap-1,L) - else - indev2 = indlsev(jcap ,L) - endif - indod1 = indlsod(l+1,l) - inddif = indev1 - indod1 -cc - do indev = indev1 , indev2 -cc - uod(indev-inddif,1) = uod(indev-inddif,1) - 1 + epsedn(indev) * zev(indev ,1) -cc - uod(indev-inddif,2) = uod(indev-inddif,2) - 1 + epsedn(indev) * zev(indev ,2) -cc - enddo -cc - enddo -cc -cc...................................................................... -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - jbasod=ls_node(locl,3) - indev1 = indlsev(L,L) - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap+1,L) - 1 - else - indev2 = indlsev(jcap ,L) - 1 - endif - indod1 = indlsod(l+1,l) - inddif = indev1 - indod1 -cc - do indev = indev1 , indev2 -cc - vev(indev,1) = vev(indev ,1) - 1 - epsodn(indev-inddif) * dod(indev-inddif,1) -cc - vev(indev,2) = vev(indev ,2) - 1 - epsodn(indev-inddif) * dod(indev-inddif,2) -cc - enddo -cc - enddo -cc -cc...................................................................... -cc -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - jbasod=ls_node(locl,3) - indev1 = indlsev(L,L) - indod1 = indlsod(L+1,L) - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap+1,L) - indod2 = indlsod(jcap ,L) - else - indev2 = indlsev(jcap ,L) - indod2 = indlsod(jcap+1,L) - endif - do indod = indod1 , indod2 -cc - uod(indod,1) = uod(indod,1) * rerth - uod(indod,2) = uod(indod,2) * rerth -cc - enddo -cc - do indev = indev1 , indev2 -cc - vev(indev,1) = vev(indev,1) * rerth - vev(indev,2) = vev(indev,2) * rerth -cc - enddo -cc - enddo -cc - return - end diff --git a/src/fim/FIMsrc/fim/column/funcphys_v.F90 b/src/fim/FIMsrc/fim/column/funcphys_v.F90 deleted file mode 100644 index e8014f0..0000000 --- a/src/fim/FIMsrc/fim/column/funcphys_v.F90 +++ /dev/null @@ -1,2899 +0,0 @@ -!------------------------------------------------------------------------------- -module funcphys -!$$$ Module Documentation Block -! -! Module: funcphys API for basic thermodynamic physics -! Author: Iredell Org: W/NX23 Date: 1999-03-01 -! -! Abstract: This module provides an Application Program Interface -! for computing basic thermodynamic physics functions, in particular -! (1) saturation vapor pressure as a function of temperature, -! (2) dewpoint temperature as a function of vapor pressure, -! (3) equivalent potential temperature as a function of temperature -! and scaled pressure to the kappa power, -! (4) temperature and specific humidity along a moist adiabat -! as functions of equivalent potential temperature and -! scaled pressure to the kappa power, -! (5) scaled pressure to the kappa power as a function of pressure, and -! (6) temperature at the lifting condensation level as a function -! of temperature and dewpoint depression. -! The entry points required to set up lookup tables start with a "g". -! All the other entry points are functions starting with an "f" or -! are subroutines starting with an "s". These other functions and -! subroutines are elemental; that is, they return a scalar if they -! are passed only scalars, but they return an array if they are passed -! an array. These other functions and subroutines can be inlined, too. -! -! Program History Log: -! 1999-03-01 Mark Iredell -! 1999-10-15 Mark Iredell SI unit for pressure (Pascals) -! 2001-02-26 Mark Iredell Ice phase changes of Hong and Moorthi -! -! Public Variables: -! krealfp Integer parameter kind or length of reals (=kind_phys) -! -! Public Subprograms: -! gpvsl Compute saturation vapor pressure over liquid table -! -! fpvsl Elementally compute saturation vapor pressure over liquid -! function result Real(krealfp) saturation vapor pressure in Pascals -! t Real(krealfp) temperature in Kelvin -! -! fpvslq Elementally compute saturation vapor pressure over liquid -! function result Real(krealfp) saturation vapor pressure in Pascals -! t Real(krealfp) temperature in Kelvin -! -! fpvslx Elementally compute saturation vapor pressure over liquid -! function result Real(krealfp) saturation vapor pressure in Pascals -! t Real(krealfp) temperature in Kelvin -! -! gpvsi Compute saturation vapor pressure over ice table -! -! fpvsi Elementally compute saturation vapor pressure over ice -! function result Real(krealfp) saturation vapor pressure in Pascals -! t Real(krealfp) temperature in Kelvin -! -! fpvsiq Elementally compute saturation vapor pressure over ice -! function result Real(krealfp) saturation vapor pressure in Pascals -! t Real(krealfp) temperature in Kelvin -! -! fpvsix Elementally compute saturation vapor pressure over ice -! function result Real(krealfp) saturation vapor pressure in Pascals -! t Real(krealfp) temperature in Kelvin -! -! gpvs Compute saturation vapor pressure table -! -! fpvs Elementally compute saturation vapor pressure -! function result Real(krealfp) saturation vapor pressure in Pascals -! t Real(krealfp) temperature in Kelvin -! -! fpvsq Elementally compute saturation vapor pressure -! function result Real(krealfp) saturation vapor pressure in Pascals -! t Real(krealfp) temperature in Kelvin -! -! fpvsx Elementally compute saturation vapor pressure -! function result Real(krealfp) saturation vapor pressure in Pascals -! t Real(krealfp) temperature in Kelvin -! -! gtdpl Compute dewpoint temperature over liquid table -! -! ftdpl Elementally compute dewpoint temperature over liquid -! function result Real(krealfp) dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! ftdplq Elementally compute dewpoint temperature over liquid -! function result Real(krealfp) dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! ftdplx Elementally compute dewpoint temperature over liquid -! function result Real(krealfp) dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! ftdplxg Elementally compute dewpoint temperature over liquid -! function result Real(krealfp) dewpoint temperature in Kelvin -! t Real(krealfp) guess dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! gtdpi Compute dewpoint temperature table over ice -! -! ftdpi Elementally compute dewpoint temperature over ice -! function result Real(krealfp) dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! ftdpiq Elementally compute dewpoint temperature over ice -! function result Real(krealfp) dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! ftdpix Elementally compute dewpoint temperature over ice -! function result Real(krealfp) dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! ftdpixg Elementally compute dewpoint temperature over ice -! function result Real(krealfp) dewpoint temperature in Kelvin -! t Real(krealfp) guess dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! gtdp Compute dewpoint temperature table -! -! ftdp Elementally compute dewpoint temperature -! function result Real(krealfp) dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! ftdpq Elementally compute dewpoint temperature -! function result Real(krealfp) dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! ftdpx Elementally compute dewpoint temperature -! function result Real(krealfp) dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! ftdpxg Elementally compute dewpoint temperature -! function result Real(krealfp) dewpoint temperature in Kelvin -! t Real(krealfp) guess dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! gthe Compute equivalent potential temperature table -! -! fthe Elementally compute equivalent potential temperature -! function result Real(krealfp) equivalent potential temperature in Kelvin -! t Real(krealfp) LCL temperature in Kelvin -! pk Real(krealfp) LCL pressure over 1e5 Pa to the kappa power -! -! ftheq Elementally compute equivalent potential temperature -! function result Real(krealfp) equivalent potential temperature in Kelvin -! t Real(krealfp) LCL temperature in Kelvin -! pk Real(krealfp) LCL pressure over 1e5 Pa to the kappa power -! -! fthex Elementally compute equivalent potential temperature -! function result Real(krealfp) equivalent potential temperature in Kelvin -! t Real(krealfp) LCL temperature in Kelvin -! pk Real(krealfp) LCL pressure over 1e5 Pa to the kappa power -! -! gtma Compute moist adiabat tables -! -! stma Elementally compute moist adiabat temperature and moisture -! the Real(krealfp) equivalent potential temperature in Kelvin -! pk Real(krealfp) pressure over 1e5 Pa to the kappa power -! tma Real(krealfp) parcel temperature in Kelvin -! qma Real(krealfp) parcel specific humidity in kg/kg -! -! stmaq Elementally compute moist adiabat temperature and moisture -! the Real(krealfp) equivalent potential temperature in Kelvin -! pk Real(krealfp) pressure over 1e5 Pa to the kappa power -! tma Real(krealfp) parcel temperature in Kelvin -! qma Real(krealfp) parcel specific humidity in kg/kg -! -! stmax Elementally compute moist adiabat temperature and moisture -! the Real(krealfp) equivalent potential temperature in Kelvin -! pk Real(krealfp) pressure over 1e5 Pa to the kappa power -! tma Real(krealfp) parcel temperature in Kelvin -! qma Real(krealfp) parcel specific humidity in kg/kg -! -! stmaxg Elementally compute moist adiabat temperature and moisture -! tg Real(krealfp) guess parcel temperature in Kelvin -! the Real(krealfp) equivalent potential temperature in Kelvin -! pk Real(krealfp) pressure over 1e5 Pa to the kappa power -! tma Real(krealfp) parcel temperature in Kelvin -! qma Real(krealfp) parcel specific humidity in kg/kg -! -! gpkap Compute pressure to the kappa table -! -! fpkap Elementally raise pressure to the kappa power. -! function result Real(krealfp) p over 1e5 Pa to the kappa power -! p Real(krealfp) pressure in Pascals -! -! fpkapq Elementally raise pressure to the kappa power. -! function result Real(krealfp) p over 1e5 Pa to the kappa power -! p Real(krealfp) pressure in Pascals -! -! fpkapo Elementally raise pressure to the kappa power. -! function result Real(krealfp) p over 1e5 Pa to the kappa power -! p Real(krealfp) surface pressure in Pascals -! -! fpkapx Elementally raise pressure to the kappa power. -! function result Real(krealfp) p over 1e5 Pa to the kappa power -! p Real(krealfp) pressure in Pascals -! -! grkap Compute pressure to the 1/kappa table -! -! frkap Elementally raise pressure to the 1/kappa power. -! function result Real(krealfp) pressure in Pascals -! pkap Real(krealfp) p over 1e5 Pa to the 1/kappa power -! -! frkapq Elementally raise pressure to the kappa power. -! function result Real(krealfp) pressure in Pascals -! pkap Real(krealfp) p over 1e5 Pa to the kappa power -! -! frkapx Elementally raise pressure to the kappa power. -! function result Real(krealfp) pressure in Pascals -! pkap Real(krealfp) p over 1e5 Pa to the kappa power -! -! gtlcl Compute LCL temperature table -! -! ftlcl Elementally compute LCL temperature. -! function result Real(krealfp) temperature at the LCL in Kelvin -! t Real(krealfp) temperature in Kelvin -! tdpd Real(krealfp) dewpoint depression in Kelvin -! -! ftlclq Elementally compute LCL temperature. -! function result Real(krealfp) temperature at the LCL in Kelvin -! t Real(krealfp) temperature in Kelvin -! tdpd Real(krealfp) dewpoint depression in Kelvin -! -! ftlclo Elementally compute LCL temperature. -! function result Real(krealfp) temperature at the LCL in Kelvin -! t Real(krealfp) temperature in Kelvin -! tdpd Real(krealfp) dewpoint depression in Kelvin -! -! ftlclx Elementally compute LCL temperature. -! function result Real(krealfp) temperature at the LCL in Kelvin -! t Real(krealfp) temperature in Kelvin -! tdpd Real(krealfp) dewpoint depression in Kelvin -! -! gfuncphys Compute all physics function tables -! -! Attributes: -! Language: Fortran 90 -! -!$$$ - use machine,only:kind_phys - use physcons - implicit none - private -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Public Variables -! integer,public,parameter:: krealfp=selected_real_kind(15,45) - integer,public,parameter:: krealfp=kind_phys -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Private Variables - real(krealfp),parameter:: psatb=con_psat*1.e-5 - integer,parameter:: nxpvsl=7501 - real(krealfp) c1xpvsl,c2xpvsl,tbpvsl(nxpvsl) - integer,parameter:: nxpvsi=7501 - real(krealfp) c1xpvsi,c2xpvsi,tbpvsi(nxpvsi) - integer,parameter:: nxpvs=7501 - real(krealfp) c1xpvs,c2xpvs,tbpvs(nxpvs) - integer,parameter:: nxtdpl=5001 - real(krealfp) c1xtdpl,c2xtdpl,tbtdpl(nxtdpl) - integer,parameter:: nxtdpi=5001 - real(krealfp) c1xtdpi,c2xtdpi,tbtdpi(nxtdpi) - integer,parameter:: nxtdp=5001 - real(krealfp) c1xtdp,c2xtdp,tbtdp(nxtdp) - integer,parameter:: nxthe=241,nythe=151 - real(krealfp) c1xthe,c2xthe,c1ythe,c2ythe,tbthe(nxthe,nythe) - integer,parameter:: nxma=151,nyma=121 - real(krealfp) c1xma,c2xma,c1yma,c2yma,tbtma(nxma,nyma),tbqma(nxma,nyma) -! integer,parameter:: nxpkap=5501 - integer,parameter:: nxpkap=11001 - real(krealfp) c1xpkap,c2xpkap,tbpkap(nxpkap) - integer,parameter:: nxrkap=5501 - real(krealfp) c1xrkap,c2xrkap,tbrkap(nxrkap) - integer,parameter:: nxtlcl=151,nytlcl=61 - real(krealfp) c1xtlcl,c2xtlcl,c1ytlcl,c2ytlcl,tbtlcl(nxtlcl,nytlcl) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Public Subprograms - public gpvsl,fpvsl,fpvslq,fpvslx - public gpvsi,fpvsi,fpvsiq,fpvsix - public gpvs,fpvs,fpvsq,fpvsx - public gtdpl,ftdpl,ftdplq,ftdplx,ftdplxg - public gtdpi,ftdpi,ftdpiq,ftdpix,ftdpixg - public gtdp,ftdp,ftdpq,ftdpx,ftdpxg - public gthe,fthe,ftheq,fthex - public gtma,stma,stmaq,stmax,stmaxg - public gpkap,fpkap,fpkapq,fpkapo,fpkapx - public grkap,frkap,frkapq,frkapx - public gtlcl,ftlcl,ftlclq,ftlclo,ftlclx - public gfuncphys -contains -!------------------------------------------------------------------------------- - subroutine gpvsl -!$$$ Subprogram Documentation Block -! -! Subprogram: gpvsl Compute saturation vapor pressure table over liquid -! Author: N Phillips W/NMC2X2 Date: 30 dec 82 -! -! Abstract: Computes saturation vapor pressure table as a function of -! temperature for the table lookup function fpvsl. -! Exact saturation vapor pressures are calculated in subprogram fpvslx. -! The current implementation computes a table with a length -! of 7501 for temperatures ranging from 180. to 330. Kelvin. -! -! Program History Log: -! 91-05-07 Iredell -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! -! Usage: call gpvsl -! -! Subprograms called: -! (fpvslx) inlinable function to compute saturation vapor pressure -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx - real(krealfp) xmin,xmax,xinc,x,t -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=180.0_krealfp - xmax=330.0_krealfp - xinc=(xmax-xmin)/(nxpvsl-1) -! c1xpvsl=1.-xmin/xinc - c2xpvsl=1./xinc - c1xpvsl=1.-xmin*c2xpvsl - do jx=1,nxpvsl - x=xmin+(jx-1)*xinc - t=x - tbpvsl(jx)=fpvslx(t) - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental function fpvsl(t) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpvsl Compute saturation vapor pressure over liquid -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute saturation vapor pressure from the temperature. -! A linear interpolation is done between values in a lookup table -! computed in gpvsl. See documentation for fpvslx for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is almost 6 decimal places. -! On the Cray, fpvsl is about 4 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! -! Usage: pvsl=fpvsl(t) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! -! Output argument list: -! fpvsl Real(krealfp) saturation vapor pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpvsl - real(krealfp),intent(in):: t - integer jx - real(krealfp) xj -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xpvsl+c2xpvsl*t,1._krealfp),real(nxpvsl,krealfp)) - jx=min(xj,nxpvsl-1._krealfp) - fpvsl=tbpvsl(jx)+(xj-jx)*(tbpvsl(jx+1)-tbpvsl(jx)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function fpvslq(t) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpvslq Compute saturation vapor pressure over liquid -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute saturation vapor pressure from the temperature. -! A quadratic interpolation is done between values in a lookup table -! computed in gpvsl. See documentation for fpvslx for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is almost 9 decimal places. -! On the Cray, fpvslq is about 3 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell quadratic interpolation -! 1999-03-01 Iredell f90 module -! -! Usage: pvsl=fpvslq(t) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! -! Output argument list: -! fpvslq Real(krealfp) saturation vapor pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpvslq - real(krealfp),intent(in):: t - integer jx - real(krealfp) xj,dxj,fj1,fj2,fj3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xpvsl+c2xpvsl*t,1._krealfp),real(nxpvsl,krealfp)) - jx=min(max(nint(xj),2),nxpvsl-1) - dxj=xj-jx - fj1=tbpvsl(jx-1) - fj2=tbpvsl(jx) - fj3=tbpvsl(jx+1) - fpvslq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function fpvslx(t) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpvslx Compute saturation vapor pressure over liquid -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Exactly compute saturation vapor pressure from temperature. -! The water model assumes a perfect gas, constant specific heats -! for gas and liquid, and neglects the volume of the liquid. -! The model does account for the variation of the latent heat -! of condensation with temperature. The ice option is not included. -! The Clausius-Clapeyron equation is integrated from the triple point -! to get the formula -! pvsl=con_psat*(tr**xa)*exp(xb*(1.-tr)) -! where tr is ttp/t and other values are physical constants. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! -! Usage: pvsl=fpvslx(t) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! -! Output argument list: -! fpvslx Real(krealfp) saturation vapor pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpvslx - real(krealfp),intent(in):: t - real(krealfp),parameter:: dldt=con_cvap-con_cliq - real(krealfp),parameter:: heat=con_hvap - real(krealfp),parameter:: xpona=-dldt/con_rv - real(krealfp),parameter:: xponb=-dldt/con_rv+heat/(con_rv*con_ttp) - real(krealfp) tr -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - tr=con_ttp/t - fpvslx=con_psat*(tr**xpona)*exp(xponb*(1.-tr)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - subroutine gpvsi -!$$$ Subprogram Documentation Block -! -! Subprogram: gpvsi Compute saturation vapor pressure table over ice -! Author: N Phillips W/NMC2X2 Date: 30 dec 82 -! -! Abstract: Computes saturation vapor pressure table as a function of -! temperature for the table lookup function fpvsi. -! Exact saturation vapor pressures are calculated in subprogram fpvsix. -! The current implementation computes a table with a length -! of 7501 for temperatures ranging from 180. to 330. Kelvin. -! -! Program History Log: -! 91-05-07 Iredell -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: call gpvsi -! -! Subprograms called: -! (fpvsix) inlinable function to compute saturation vapor pressure -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx - real(krealfp) xmin,xmax,xinc,x,t -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=180.0_krealfp - xmax=330.0_krealfp - xinc=(xmax-xmin)/(nxpvsi-1) -! c1xpvsi=1.-xmin/xinc - c2xpvsi=1./xinc - c1xpvsi=1.-xmin*c2xpvsi - do jx=1,nxpvsi - x=xmin+(jx-1)*xinc - t=x - tbpvsi(jx)=fpvsix(t) - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental function fpvsi(t) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpvsi Compute saturation vapor pressure over ice -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute saturation vapor pressure from the temperature. -! A linear interpolation is done between values in a lookup table -! computed in gpvsi. See documentation for fpvsix for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is almost 6 decimal places. -! On the Cray, fpvsi is about 4 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: pvsi=fpvsi(t) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! -! Output argument list: -! fpvsi Real(krealfp) saturation vapor pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpvsi - real(krealfp),intent(in):: t - integer jx - real(krealfp) xj -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xpvsi+c2xpvsi*t,1._krealfp),real(nxpvsi,krealfp)) - jx=min(xj,nxpvsi-1._krealfp) - fpvsi=tbpvsi(jx)+(xj-jx)*(tbpvsi(jx+1)-tbpvsi(jx)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function fpvsiq(t) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpvsiq Compute saturation vapor pressure over ice -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute saturation vapor pressure from the temperature. -! A quadratic interpolation is done between values in a lookup table -! computed in gpvsi. See documentation for fpvsix for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is almost 9 decimal places. -! On the Cray, fpvsiq is about 3 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell quadratic interpolation -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: pvsi=fpvsiq(t) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! -! Output argument list: -! fpvsiq Real(krealfp) saturation vapor pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpvsiq - real(krealfp),intent(in):: t - integer jx - real(krealfp) xj,dxj,fj1,fj2,fj3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xpvsi+c2xpvsi*t,1._krealfp),real(nxpvsi,krealfp)) - jx=min(max(nint(xj),2),nxpvsi-1) - dxj=xj-jx - fj1=tbpvsi(jx-1) - fj2=tbpvsi(jx) - fj3=tbpvsi(jx+1) - fpvsiq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function fpvsix(t) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpvsix Compute saturation vapor pressure over ice -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Exactly compute saturation vapor pressure from temperature. -! The water model assumes a perfect gas, constant specific heats -! for gas and ice, and neglects the volume of the ice. -! The model does account for the variation of the latent heat -! of condensation with temperature. The liquid option is not included. -! The Clausius-Clapeyron equation is integrated from the triple point -! to get the formula -! pvsi=con_psat*(tr**xa)*exp(xb*(1.-tr)) -! where tr is ttp/t and other values are physical constants. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: pvsi=fpvsix(t) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! -! Output argument list: -! fpvsix Real(krealfp) saturation vapor pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpvsix - real(krealfp),intent(in):: t - real(krealfp),parameter:: dldt=con_cvap-con_csol - real(krealfp),parameter:: heat=con_hvap+con_hfus - real(krealfp),parameter:: xpona=-dldt/con_rv - real(krealfp),parameter:: xponb=-dldt/con_rv+heat/(con_rv*con_ttp) - real(krealfp) tr -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - tr=con_ttp/t - fpvsix=con_psat*(tr**xpona)*exp(xponb*(1.-tr)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - subroutine gpvs -!$$$ Subprogram Documentation Block -! -! Subprogram: gpvs Compute saturation vapor pressure table -! Author: N Phillips W/NMC2X2 Date: 30 dec 82 -! -! Abstract: Computes saturation vapor pressure table as a function of -! temperature for the table lookup function fpvs. -! Exact saturation vapor pressures are calculated in subprogram fpvsx. -! The current implementation computes a table with a length -! of 7501 for temperatures ranging from 180. to 330. Kelvin. -! -! Program History Log: -! 91-05-07 Iredell -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: call gpvs -! -! Subprograms called: -! (fpvsx) inlinable function to compute saturation vapor pressure -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx - real(krealfp) xmin,xmax,xinc,x,t -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=180.0_krealfp - xmax=330.0_krealfp - xinc=(xmax-xmin)/(nxpvs-1) -! c1xpvs=1.-xmin/xinc - c2xpvs=1./xinc - c1xpvs=1.-xmin*c2xpvs - do jx=1,nxpvs - x=xmin+(jx-1)*xinc - t=x - tbpvs(jx)=fpvsx(t) - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental function fpvs(t) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpvs Compute saturation vapor pressure -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute saturation vapor pressure from the temperature. -! A linear interpolation is done between values in a lookup table -! computed in gpvs. See documentation for fpvsx for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is almost 6 decimal places. -! On the Cray, fpvs is about 4 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: pvs=fpvs(t) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! -! Output argument list: -! fpvs Real(krealfp) saturation vapor pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpvs - real(krealfp),intent(in):: t - integer jx - real(krealfp) xj -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xpvs+c2xpvs*t,1._krealfp),real(nxpvs,krealfp)) - jx=min(xj,nxpvs-1._krealfp) - fpvs=tbpvs(jx)+(xj-jx)*(tbpvs(jx+1)-tbpvs(jx)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function fpvsq(t) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpvsq Compute saturation vapor pressure -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute saturation vapor pressure from the temperature. -! A quadratic interpolation is done between values in a lookup table -! computed in gpvs. See documentation for fpvsx for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is almost 9 decimal places. -! On the Cray, fpvsq is about 3 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell quadratic interpolation -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: pvs=fpvsq(t) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! -! Output argument list: -! fpvsq Real(krealfp) saturation vapor pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpvsq - real(krealfp),intent(in):: t - integer jx - real(krealfp) xj,dxj,fj1,fj2,fj3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xpvs+c2xpvs*t,1._krealfp),real(nxpvs,krealfp)) - jx=min(max(nint(xj),2),nxpvs-1) - dxj=xj-jx - fj1=tbpvs(jx-1) - fj2=tbpvs(jx) - fj3=tbpvs(jx+1) - fpvsq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function fpvsx(t) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpvsx Compute saturation vapor pressure -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Exactly compute saturation vapor pressure from temperature. -! The saturation vapor pressure over either liquid and ice is computed -! over liquid for temperatures above the triple point, -! over ice for temperatures 20 degress below the triple point, -! and a linear combination of the two for temperatures in between. -! The water model assumes a perfect gas, constant specific heats -! for gas, liquid and ice, and neglects the volume of the condensate. -! The model does account for the variation of the latent heat -! of condensation and sublimation with temperature. -! The Clausius-Clapeyron equation is integrated from the triple point -! to get the formula -! pvsl=con_psat*(tr**xa)*exp(xb*(1.-tr)) -! where tr is ttp/t and other values are physical constants. -! The reference for this computation is Emanuel(1994), pages 116-117. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: pvs=fpvsx(t) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! -! Output argument list: -! fpvsx Real(krealfp) saturation vapor pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpvsx - real(krealfp),intent(in):: t - real(krealfp),parameter:: tliq=con_ttp - real(krealfp),parameter:: tice=con_ttp-20.0 - real(krealfp),parameter:: dldtl=con_cvap-con_cliq - real(krealfp),parameter:: heatl=con_hvap - real(krealfp),parameter:: xponal=-dldtl/con_rv - real(krealfp),parameter:: xponbl=-dldtl/con_rv+heatl/(con_rv*con_ttp) - real(krealfp),parameter:: dldti=con_cvap-con_csol - real(krealfp),parameter:: heati=con_hvap+con_hfus - real(krealfp),parameter:: xponai=-dldti/con_rv - real(krealfp),parameter:: xponbi=-dldti/con_rv+heati/(con_rv*con_ttp) - real(krealfp) tr,w,pvl,pvi -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - tr=con_ttp/t - if(t.ge.tliq) then - fpvsx=con_psat*(tr**xponal)*exp(xponbl*(1.-tr)) - elseif(t.lt.tice) then - fpvsx=con_psat*(tr**xponai)*exp(xponbi*(1.-tr)) - else - w=(t-tice)/(tliq-tice) - pvl=con_psat*(tr**xponal)*exp(xponbl*(1.-tr)) - pvi=con_psat*(tr**xponai)*exp(xponbi*(1.-tr)) - fpvsx=w*pvl+(1.-w)*pvi - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - subroutine gtdpl -!$$$ Subprogram Documentation Block -! -! Subprogram: gtdpl Compute dewpoint temperature over liquid table -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute dewpoint temperature table as a function of -! vapor pressure for inlinable function ftdpl. -! Exact dewpoint temperatures are calculated in subprogram ftdplxg. -! The current implementation computes a table with a length -! of 5001 for vapor pressures ranging from 1 to 10001 Pascals -! giving a dewpoint temperature range of 208 to 319 Kelvin. -! -! Program History Log: -! 91-05-07 Iredell -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! -! Usage: call gtdpl -! -! Subprograms called: -! (ftdplxg) inlinable function to compute dewpoint temperature over liquid -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx - real(krealfp) xmin,xmax,xinc,t,x,pv -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=1 - xmax=10001 - xinc=(xmax-xmin)/(nxtdpl-1) - c1xtdpl=1.-xmin/xinc - c2xtdpl=1./xinc - t=208.0 - do jx=1,nxtdpl - x=xmin+(jx-1)*xinc - pv=x - t=ftdplxg(t,pv) - tbtdpl(jx)=t - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental function ftdpl(pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdpl Compute dewpoint temperature over liquid -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute dewpoint temperature from vapor pressure. -! A linear interpolation is done between values in a lookup table -! computed in gtdpl. See documentation for ftdplxg for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is better than 0.0005 Kelvin -! for dewpoint temperatures greater than 250 Kelvin, -! but decreases to 0.02 Kelvin for a dewpoint around 230 Kelvin. -! On the Cray, ftdpl is about 75 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! -! Usage: tdpl=ftdpl(pv) -! -! Input argument list: -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdpl Real(krealfp) dewpoint temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdpl - real(krealfp),intent(in):: pv - integer jx - real(krealfp) xj -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xtdpl+c2xtdpl*pv,1._krealfp),real(nxtdpl,krealfp)) - jx=min(xj,nxtdpl-1._krealfp) - ftdpl=tbtdpl(jx)+(xj-jx)*(tbtdpl(jx+1)-tbtdpl(jx)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftdplq(pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdplq Compute dewpoint temperature over liquid -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute dewpoint temperature from vapor pressure. -! A quadratic interpolation is done between values in a lookup table -! computed in gtdpl. see documentation for ftdplxg for details. -! Input values outside table range are reset to table extrema. -! the interpolation accuracy is better than 0.00001 Kelvin -! for dewpoint temperatures greater than 250 Kelvin, -! but decreases to 0.002 Kelvin for a dewpoint around 230 Kelvin. -! On the Cray, ftdplq is about 60 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell quadratic interpolation -! 1999-03-01 Iredell f90 module -! -! Usage: tdpl=ftdplq(pv) -! -! Input argument list: -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdplq Real(krealfp) dewpoint temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdplq - real(krealfp),intent(in):: pv - integer jx - real(krealfp) xj,dxj,fj1,fj2,fj3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xtdpl+c2xtdpl*pv,1._krealfp),real(nxtdpl,krealfp)) - jx=min(max(nint(xj),2),nxtdpl-1) - dxj=xj-jx - fj1=tbtdpl(jx-1) - fj2=tbtdpl(jx) - fj3=tbtdpl(jx+1) - ftdplq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftdplx(pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdplx Compute dewpoint temperature over liquid -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: exactly compute dewpoint temperature from vapor pressure. -! An approximate dewpoint temperature for function ftdplxg -! is obtained using ftdpl so gtdpl must be already called. -! See documentation for ftdplxg for details. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! -! Usage: tdpl=ftdplx(pv) -! -! Input argument list: -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdplx Real(krealfp) dewpoint temperature in Kelvin -! -! Subprograms called: -! (ftdpl) inlinable function to compute dewpoint temperature over liquid -! (ftdplxg) inlinable function to compute dewpoint temperature over liquid -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdplx - real(krealfp),intent(in):: pv - real(krealfp) tg -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - tg=ftdpl(pv) - ftdplx=ftdplxg(tg,pv) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftdplxg(tg,pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdplxg Compute dewpoint temperature over liquid -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Exactly compute dewpoint temperature from vapor pressure. -! A guess dewpoint temperature must be provided. -! The water model assumes a perfect gas, constant specific heats -! for gas and liquid, and neglects the volume of the liquid. -! The model does account for the variation of the latent heat -! of condensation with temperature. The ice option is not included. -! The Clausius-Clapeyron equation is integrated from the triple point -! to get the formula -! pvs=con_psat*(tr**xa)*exp(xb*(1.-tr)) -! where tr is ttp/t and other values are physical constants. -! The formula is inverted by iterating Newtonian approximations -! for each pvs until t is found to within 1.e-6 Kelvin. -! This function can be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! -! Usage: tdpl=ftdplxg(tg,pv) -! -! Input argument list: -! tg Real(krealfp) guess dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdplxg Real(krealfp) dewpoint temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdplxg - real(krealfp),intent(in):: tg,pv - real(krealfp),parameter:: terrm=1.e-6 - real(krealfp),parameter:: dldt=con_cvap-con_cliq - real(krealfp),parameter:: heat=con_hvap - real(krealfp),parameter:: xpona=-dldt/con_rv - real(krealfp),parameter:: xponb=-dldt/con_rv+heat/(con_rv*con_ttp) - real(krealfp) t,tr,pvt,el,dpvt,terr - integer i -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - t=tg - do i=1,100 - tr=con_ttp/t - pvt=con_psat*(tr**xpona)*exp(xponb*(1.-tr)) - el=heat+dldt*(t-con_ttp) - dpvt=el*pvt/(con_rv*t**2) - terr=(pvt-pv)/dpvt - t=t-terr - if(abs(terr).le.terrm) exit - enddo - ftdplxg=t -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - subroutine gtdpi -!$$$ Subprogram Documentation Block -! -! Subprogram: gtdpi Compute dewpoint temperature over ice table -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute dewpoint temperature table as a function of -! vapor pressure for inlinable function ftdpi. -! Exact dewpoint temperatures are calculated in subprogram ftdpixg. -! The current implementation computes a table with a length -! of 5001 for vapor pressures ranging from 0.1 to 1000.1 Pascals -! giving a dewpoint temperature range of 197 to 279 Kelvin. -! -! Program History Log: -! 91-05-07 Iredell -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: call gtdpi -! -! Subprograms called: -! (ftdpixg) inlinable function to compute dewpoint temperature over ice -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx - real(krealfp) xmin,xmax,xinc,t,x,pv -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=0.1 - xmax=1000.1 - xinc=(xmax-xmin)/(nxtdpi-1) - c1xtdpi=1.-xmin/xinc - c2xtdpi=1./xinc - t=197.0 - do jx=1,nxtdpi - x=xmin+(jx-1)*xinc - pv=x - t=ftdpixg(t,pv) - tbtdpi(jx)=t - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental function ftdpi(pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdpi Compute dewpoint temperature over ice -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute dewpoint temperature from vapor pressure. -! A linear interpolation is done between values in a lookup table -! computed in gtdpi. See documentation for ftdpixg for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is better than 0.0005 Kelvin -! for dewpoint temperatures greater than 250 Kelvin, -! but decreases to 0.02 Kelvin for a dewpoint around 230 Kelvin. -! On the Cray, ftdpi is about 75 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: tdpi=ftdpi(pv) -! -! Input argument list: -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdpi Real(krealfp) dewpoint temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdpi - real(krealfp),intent(in):: pv - integer jx - real(krealfp) xj -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xtdpi+c2xtdpi*pv,1._krealfp),real(nxtdpi,krealfp)) - jx=min(xj,nxtdpi-1._krealfp) - ftdpi=tbtdpi(jx)+(xj-jx)*(tbtdpi(jx+1)-tbtdpi(jx)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftdpiq(pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdpiq Compute dewpoint temperature over ice -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute dewpoint temperature from vapor pressure. -! A quadratic interpolation is done between values in a lookup table -! computed in gtdpi. see documentation for ftdpixg for details. -! Input values outside table range are reset to table extrema. -! the interpolation accuracy is better than 0.00001 Kelvin -! for dewpoint temperatures greater than 250 Kelvin, -! but decreases to 0.002 Kelvin for a dewpoint around 230 Kelvin. -! On the Cray, ftdpiq is about 60 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell quadratic interpolation -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: tdpi=ftdpiq(pv) -! -! Input argument list: -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdpiq Real(krealfp) dewpoint temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdpiq - real(krealfp),intent(in):: pv - integer jx - real(krealfp) xj,dxj,fj1,fj2,fj3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xtdpi+c2xtdpi*pv,1._krealfp),real(nxtdpi,krealfp)) - jx=min(max(nint(xj),2),nxtdpi-1) - dxj=xj-jx - fj1=tbtdpi(jx-1) - fj2=tbtdpi(jx) - fj3=tbtdpi(jx+1) - ftdpiq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftdpix(pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdpix Compute dewpoint temperature over ice -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: exactly compute dewpoint temperature from vapor pressure. -! An approximate dewpoint temperature for function ftdpixg -! is obtained using ftdpi so gtdpi must be already called. -! See documentation for ftdpixg for details. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: tdpi=ftdpix(pv) -! -! Input argument list: -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdpix Real(krealfp) dewpoint temperature in Kelvin -! -! Subprograms called: -! (ftdpi) inlinable function to compute dewpoint temperature over ice -! (ftdpixg) inlinable function to compute dewpoint temperature over ice -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdpix - real(krealfp),intent(in):: pv - real(krealfp) tg -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - tg=ftdpi(pv) - ftdpix=ftdpixg(tg,pv) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftdpixg(tg,pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdpixg Compute dewpoint temperature over ice -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Exactly compute dewpoint temperature from vapor pressure. -! A guess dewpoint temperature must be provided. -! The water model assumes a perfect gas, constant specific heats -! for gas and ice, and neglects the volume of the ice. -! The model does account for the variation of the latent heat -! of sublimation with temperature. The liquid option is not included. -! The Clausius-Clapeyron equation is integrated from the triple point -! to get the formula -! pvs=con_psat*(tr**xa)*exp(xb*(1.-tr)) -! where tr is ttp/t and other values are physical constants. -! The formula is inverted by iterating Newtonian approximations -! for each pvs until t is found to within 1.e-6 Kelvin. -! This function can be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: tdpi=ftdpixg(tg,pv) -! -! Input argument list: -! tg Real(krealfp) guess dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdpixg Real(krealfp) dewpoint temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdpixg - real(krealfp),intent(in):: tg,pv - real(krealfp),parameter:: terrm=1.e-6 - real(krealfp),parameter:: dldt=con_cvap-con_csol - real(krealfp),parameter:: heat=con_hvap+con_hfus - real(krealfp),parameter:: xpona=-dldt/con_rv - real(krealfp),parameter:: xponb=-dldt/con_rv+heat/(con_rv*con_ttp) - real(krealfp) t,tr,pvt,el,dpvt,terr - integer i -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - t=tg - do i=1,100 - tr=con_ttp/t - pvt=con_psat*(tr**xpona)*exp(xponb*(1.-tr)) - el=heat+dldt*(t-con_ttp) - dpvt=el*pvt/(con_rv*t**2) - terr=(pvt-pv)/dpvt - t=t-terr - if(abs(terr).le.terrm) exit - enddo - ftdpixg=t -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - subroutine gtdp -!$$$ Subprogram Documentation Block -! -! Subprogram: gtdp Compute dewpoint temperature table -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute dewpoint temperature table as a function of -! vapor pressure for inlinable function ftdp. -! Exact dewpoint temperatures are calculated in subprogram ftdpxg. -! The current implementation computes a table with a length -! of 5001 for vapor pressures ranging from 0.5 to 1000.5 Pascals -! giving a dewpoint temperature range of 208 to 319 Kelvin. -! -! Program History Log: -! 91-05-07 Iredell -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: call gtdp -! -! Subprograms called: -! (ftdpxg) inlinable function to compute dewpoint temperature -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx - real(krealfp) xmin,xmax,xinc,t,x,pv -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=0.5 - xmax=10000.5 - xinc=(xmax-xmin)/(nxtdp-1) - c1xtdp=1.-xmin/xinc - c2xtdp=1./xinc - t=208.0 - do jx=1,nxtdp - x=xmin+(jx-1)*xinc - pv=x - t=ftdpxg(t,pv) - tbtdp(jx)=t - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental function ftdp(pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdp Compute dewpoint temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute dewpoint temperature from vapor pressure. -! A linear interpolation is done between values in a lookup table -! computed in gtdp. See documentation for ftdpxg for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is better than 0.0005 Kelvin -! for dewpoint temperatures greater than 250 Kelvin, -! but decreases to 0.02 Kelvin for a dewpoint around 230 Kelvin. -! On the Cray, ftdp is about 75 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: tdp=ftdp(pv) -! -! Input argument list: -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdp Real(krealfp) dewpoint temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdp - real(krealfp),intent(in):: pv - integer jx - real(krealfp) xj -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xtdp+c2xtdp*pv,1._krealfp),real(nxtdp,krealfp)) - jx=min(xj,nxtdp-1._krealfp) - ftdp=tbtdp(jx)+(xj-jx)*(tbtdp(jx+1)-tbtdp(jx)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftdpq(pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdpq Compute dewpoint temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute dewpoint temperature from vapor pressure. -! A quadratic interpolation is done between values in a lookup table -! computed in gtdp. see documentation for ftdpxg for details. -! Input values outside table range are reset to table extrema. -! the interpolation accuracy is better than 0.00001 Kelvin -! for dewpoint temperatures greater than 250 Kelvin, -! but decreases to 0.002 Kelvin for a dewpoint around 230 Kelvin. -! On the Cray, ftdpq is about 60 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell quadratic interpolation -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: tdp=ftdpq(pv) -! -! Input argument list: -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdpq Real(krealfp) dewpoint temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdpq - real(krealfp),intent(in):: pv - integer jx - real(krealfp) xj,dxj,fj1,fj2,fj3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xtdp+c2xtdp*pv,1._krealfp),real(nxtdp,krealfp)) - jx=min(max(nint(xj),2),nxtdp-1) - dxj=xj-jx - fj1=tbtdp(jx-1) - fj2=tbtdp(jx) - fj3=tbtdp(jx+1) - ftdpq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftdpx(pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdpx Compute dewpoint temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: exactly compute dewpoint temperature from vapor pressure. -! An approximate dewpoint temperature for function ftdpxg -! is obtained using ftdp so gtdp must be already called. -! See documentation for ftdpxg for details. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: tdp=ftdpx(pv) -! -! Input argument list: -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdpx Real(krealfp) dewpoint temperature in Kelvin -! -! Subprograms called: -! (ftdp) inlinable function to compute dewpoint temperature -! (ftdpxg) inlinable function to compute dewpoint temperature -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdpx - real(krealfp),intent(in):: pv - real(krealfp) tg -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - tg=ftdp(pv) - ftdpx=ftdpxg(tg,pv) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftdpxg(tg,pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdpxg Compute dewpoint temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Exactly compute dewpoint temperature from vapor pressure. -! A guess dewpoint temperature must be provided. -! The saturation vapor pressure over either liquid and ice is computed -! over liquid for temperatures above the triple point, -! over ice for temperatures 20 degress below the triple point, -! and a linear combination of the two for temperatures in between. -! The water model assumes a perfect gas, constant specific heats -! for gas, liquid and ice, and neglects the volume of the condensate. -! The model does account for the variation of the latent heat -! of condensation and sublimation with temperature. -! The Clausius-Clapeyron equation is integrated from the triple point -! to get the formula -! pvsl=con_psat*(tr**xa)*exp(xb*(1.-tr)) -! where tr is ttp/t and other values are physical constants. -! The reference for this decision is Emanuel(1994), pages 116-117. -! The formula is inverted by iterating Newtonian approximations -! for each pvs until t is found to within 1.e-6 Kelvin. -! This function can be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: tdp=ftdpxg(tg,pv) -! -! Input argument list: -! tg Real(krealfp) guess dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdpxg Real(krealfp) dewpoint temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdpxg - real(krealfp),intent(in):: tg,pv - real(krealfp),parameter:: terrm=1.e-6 - real(krealfp),parameter:: tliq=con_ttp - real(krealfp),parameter:: tice=con_ttp-20.0 - real(krealfp),parameter:: dldtl=con_cvap-con_cliq - real(krealfp),parameter:: heatl=con_hvap - real(krealfp),parameter:: xponal=-dldtl/con_rv - real(krealfp),parameter:: xponbl=-dldtl/con_rv+heatl/(con_rv*con_ttp) - real(krealfp),parameter:: dldti=con_cvap-con_csol - real(krealfp),parameter:: heati=con_hvap+con_hfus - real(krealfp),parameter:: xponai=-dldti/con_rv - real(krealfp),parameter:: xponbi=-dldti/con_rv+heati/(con_rv*con_ttp) - real(krealfp) t,tr,w,pvtl,pvti,pvt,ell,eli,el,dpvt,terr - integer i -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - t=tg - do i=1,100 - tr=con_ttp/t - if(t.ge.tliq) then - pvt=con_psat*(tr**xponal)*exp(xponbl*(1.-tr)) - el=heatl+dldtl*(t-con_ttp) - dpvt=el*pvt/(con_rv*t**2) - elseif(t.lt.tice) then - pvt=con_psat*(tr**xponai)*exp(xponbi*(1.-tr)) - el=heati+dldti*(t-con_ttp) - dpvt=el*pvt/(con_rv*t**2) - else - w=(t-tice)/(tliq-tice) - pvtl=con_psat*(tr**xponal)*exp(xponbl*(1.-tr)) - pvti=con_psat*(tr**xponai)*exp(xponbi*(1.-tr)) - pvt=w*pvtl+(1.-w)*pvti - ell=heatl+dldtl*(t-con_ttp) - eli=heati+dldti*(t-con_ttp) - dpvt=(w*ell*pvtl+(1.-w)*eli*pvti)/(con_rv*t**2) - endif - terr=(pvt-pv)/dpvt - t=t-terr - if(abs(terr).le.terrm) exit - enddo - ftdpxg=t -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - subroutine gthe -!$$$ Subprogram Documentation Block -! -! Subprogram: gthe Compute equivalent potential temperature table -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute equivalent potential temperature table -! as a function of LCL temperature and pressure over 1e5 Pa -! to the kappa power for function fthe. -! Equivalent potential temperatures are calculated in subprogram fthex -! the current implementation computes a table with a first dimension -! of 241 for temperatures ranging from 183.16 to 303.16 Kelvin -! and a second dimension of 151 for pressure over 1e5 Pa -! to the kappa power ranging from 0.04**rocp to 1.10**rocp. -! -! Program History Log: -! 91-05-07 Iredell -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! -! Usage: call gthe -! -! Subprograms called: -! (fthex) inlinable function to compute equiv. pot. temperature -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx,jy - real(krealfp) xmin,xmax,ymin,ymax,xinc,yinc,x,y,pk,t -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=con_ttp-90._krealfp - xmax=con_ttp+30._krealfp - ymin=0.04_krealfp**con_rocp - ymax=1.10_krealfp**con_rocp - xinc=(xmax-xmin)/(nxthe-1) - c1xthe=1.-xmin/xinc - c2xthe=1./xinc - yinc=(ymax-ymin)/(nythe-1) - c1ythe=1.-ymin/yinc - c2ythe=1./yinc - do jy=1,nythe - y=ymin+(jy-1)*yinc - pk=y - do jx=1,nxthe - x=xmin+(jx-1)*xinc - t=x - tbthe(jx,jy)=fthex(t,pk) - enddo - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental function fthe(t,pk) -!$$$ Subprogram Documentation Block -! -! Subprogram: fthe Compute equivalent potential temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute equivalent potential temperature at the LCL -! from temperature and pressure over 1e5 Pa to the kappa power. -! A bilinear interpolation is done between values in a lookup table -! computed in gthe. see documentation for fthex for details. -! Input values outside table range are reset to table extrema, -! except zero is returned for too cold or high LCLs. -! The interpolation accuracy is better than 0.01 Kelvin. -! On the Cray, fthe is almost 6 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! -! Usage: the=fthe(t,pk) -! -! Input argument list: -! t Real(krealfp) LCL temperature in Kelvin -! pk Real(krealfp) LCL pressure over 1e5 Pa to the kappa power -! -! Output argument list: -! fthe Real(krealfp) equivalent potential temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fthe - real(krealfp),intent(in):: t,pk - integer jx,jy - real(krealfp) xj,yj,ftx1,ftx2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(c1xthe+c2xthe*t,real(nxthe,krealfp)) - yj=min(c1ythe+c2ythe*pk,real(nythe,krealfp)) - if(xj.ge.1..and.yj.ge.1.) then - jx=min(xj,nxthe-1._krealfp) - jy=min(yj,nythe-1._krealfp) - ftx1=tbthe(jx,jy)+(xj-jx)*(tbthe(jx+1,jy)-tbthe(jx,jy)) - ftx2=tbthe(jx,jy+1)+(xj-jx)*(tbthe(jx+1,jy+1)-tbthe(jx,jy+1)) - fthe=ftx1+(yj-jy)*(ftx2-ftx1) - else - fthe=0. - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftheq(t,pk) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftheq Compute equivalent potential temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute equivalent potential temperature at the LCL -! from temperature and pressure over 1e5 Pa to the kappa power. -! A biquadratic interpolation is done between values in a lookup table -! computed in gthe. see documentation for fthex for details. -! Input values outside table range are reset to table extrema, -! except zero is returned for too cold or high LCLs. -! The interpolation accuracy is better than 0.0002 Kelvin. -! On the Cray, ftheq is almost 3 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell quadratic interpolation -! 1999-03-01 Iredell f90 module -! -! Usage: the=ftheq(t,pk) -! -! Input argument list: -! t Real(krealfp) LCL temperature in Kelvin -! pk Real(krealfp) LCL pressure over 1e5 Pa to the kappa power -! -! Output argument list: -! ftheq Real(krealfp) equivalent potential temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftheq - real(krealfp),intent(in):: t,pk - integer jx,jy - real(krealfp) xj,yj,dxj,dyj - real(krealfp) ft11,ft12,ft13,ft21,ft22,ft23,ft31,ft32,ft33 - real(krealfp) ftx1,ftx2,ftx3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(c1xthe+c2xthe*t,real(nxthe,krealfp)) - yj=min(c1ythe+c2ythe*pk,real(nythe,krealfp)) - if(xj.ge.1..and.yj.ge.1.) then - jx=min(max(nint(xj),2),nxthe-1) - jy=min(max(nint(yj),2),nythe-1) - dxj=xj-jx - dyj=yj-jy - ft11=tbthe(jx-1,jy-1) - ft12=tbthe(jx-1,jy) - ft13=tbthe(jx-1,jy+1) - ft21=tbthe(jx,jy-1) - ft22=tbthe(jx,jy) - ft23=tbthe(jx,jy+1) - ft31=tbthe(jx+1,jy-1) - ft32=tbthe(jx+1,jy) - ft33=tbthe(jx+1,jy+1) - ftx1=(((ft31+ft11)/2-ft21)*dxj+(ft31-ft11)/2)*dxj+ft21 - ftx2=(((ft32+ft12)/2-ft22)*dxj+(ft32-ft12)/2)*dxj+ft22 - ftx3=(((ft33+ft13)/2-ft23)*dxj+(ft33-ft13)/2)*dxj+ft23 - ftheq=(((ftx3+ftx1)/2-ftx2)*dyj+(ftx3-ftx1)/2)*dyj+ftx2 - else - ftheq=0. - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- -! elemental function fthex(t,pk) - function fthex(t,pk) -!$$$ Subprogram Documentation Block -! -! Subprogram: fthex Compute equivalent potential temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Exactly compute equivalent potential temperature at the LCL -! from temperature and pressure over 1e5 Pa to the kappa power. -! Equivalent potential temperature is constant for a saturated parcel -! rising adiabatically up a moist adiabat when the heat and mass -! of the condensed water are neglected. Ice is also neglected. -! The formula for equivalent potential temperature (Holton) is -! the=t*(pd**(-rocp))*exp(el*eps*pv/(cp*t*pd)) -! where t is the temperature, pv is the saturated vapor pressure, -! pd is the dry pressure p-pv, el is the temperature dependent -! latent heat of condensation hvap+dldt*(t-ttp), and other values -! are physical constants defined in parameter statements in the code. -! Zero is returned if the input values make saturation impossible. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! -! Usage: the=fthex(t,pk) -! -! Input argument list: -! t Real(krealfp) LCL temperature in Kelvin -! pk Real(krealfp) LCL pressure over 1e5 Pa to the kappa power -! -! Output argument list: -! fthex Real(krealfp) equivalent potential temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fthex - real(krealfp),intent(in):: t,pk - real(krealfp) p,tr,pv,pd,el,expo,expmax -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - p=pk**con_cpor - tr=con_ttp/t - pv=psatb*(tr**con_xpona)*exp(con_xponb*(1.-tr)) - pd=p-pv - if(pd.gt.pv) then - el=con_hvap+con_dldt*(t-con_ttp) - expo=el*con_eps*pv/(con_cp*t*pd) - fthex=t*pd**(-con_rocp)*exp(expo) - else - fthex=0. - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - subroutine gtma -!$$$ Subprogram Documentation Block -! -! Subprogram: gtma Compute moist adiabat tables -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute temperature and specific humidity tables -! as a function of equivalent potential temperature and -! pressure over 1e5 Pa to the kappa power for subprogram stma. -! Exact parcel temperatures are calculated in subprogram stmaxg. -! The current implementation computes a table with a first dimension -! of 151 for equivalent potential temperatures ranging from 200 to 500 -! Kelvin and a second dimension of 121 for pressure over 1e5 Pa -! to the kappa power ranging from 0.01**rocp to 1.10**rocp. -! -! Program History Log: -! 91-05-07 Iredell -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! -! Usage: call gtma -! -! Subprograms called: -! (stmaxg) inlinable subprogram to compute parcel temperature -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx,jy - real(krealfp) xmin,xmax,ymin,ymax,xinc,yinc,x,y,pk,the,t,q,tg -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=200._krealfp - xmax=500._krealfp - ymin=0.01_krealfp**con_rocp - ymax=1.10_krealfp**con_rocp - xinc=(xmax-xmin)/(nxma-1) - c1xma=1.-xmin/xinc - c2xma=1./xinc - yinc=(ymax-ymin)/(nyma-1) - c1yma=1.-ymin/yinc - c2yma=1./yinc - do jy=1,nyma - y=ymin+(jy-1)*yinc - pk=y - tg=xmin*y - do jx=1,nxma - x=xmin+(jx-1)*xinc - the=x - call stmaxg(tg,the,pk,t,q) - tbtma(jx,jy)=t - tbqma(jx,jy)=q - tg=t - enddo - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental subroutine stma(the,pk,tma,qma) -!$$$ Subprogram Documentation Block -! -! Subprogram: stma Compute moist adiabat temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute temperature and specific humidity of a parcel -! lifted up a moist adiabat from equivalent potential temperature -! at the LCL and pressure over 1e5 Pa to the kappa power. -! Bilinear interpolations are done between values in a lookup table -! computed in gtma. See documentation for stmaxg for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is better than 0.01 Kelvin -! and 5.e-6 kg/kg for temperature and humidity, respectively. -! On the Cray, stma is about 35 times faster than exact calculation. -! This subprogram should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! -! Usage: call stma(the,pk,tma,qma) -! -! Input argument list: -! the Real(krealfp) equivalent potential temperature in Kelvin -! pk Real(krealfp) pressure over 1e5 Pa to the kappa power -! -! Output argument list: -! tma Real(krealfp) parcel temperature in Kelvin -! qma Real(krealfp) parcel specific humidity in kg/kg -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp),intent(in):: the,pk - real(krealfp),intent(out):: tma,qma - integer jx,jy - real(krealfp) xj,yj,ftx1,ftx2,qx1,qx2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xma+c2xma*the,1._krealfp),real(nxma,krealfp)) - yj=min(max(c1yma+c2yma*pk,1._krealfp),real(nyma,krealfp)) - jx=min(xj,nxma-1._krealfp) - jy=min(yj,nyma-1._krealfp) - ftx1=tbtma(jx,jy)+(xj-jx)*(tbtma(jx+1,jy)-tbtma(jx,jy)) - ftx2=tbtma(jx,jy+1)+(xj-jx)*(tbtma(jx+1,jy+1)-tbtma(jx,jy+1)) - tma=ftx1+(yj-jy)*(ftx2-ftx1) - qx1=tbqma(jx,jy)+(xj-jx)*(tbqma(jx+1,jy)-tbqma(jx,jy)) - qx2=tbqma(jx,jy+1)+(xj-jx)*(tbqma(jx+1,jy+1)-tbqma(jx,jy+1)) - qma=qx1+(yj-jy)*(qx2-qx1) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental subroutine stmaq(the,pk,tma,qma) -!$$$ Subprogram Documentation Block -! -! Subprogram: stmaq Compute moist adiabat temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute temperature and specific humidity of a parcel -! lifted up a moist adiabat from equivalent potential temperature -! at the LCL and pressure over 1e5 Pa to the kappa power. -! Biquadratic interpolations are done between values in a lookup table -! computed in gtma. See documentation for stmaxg for details. -! Input values outside table range are reset to table extrema. -! the interpolation accuracy is better than 0.0005 Kelvin -! and 1.e-7 kg/kg for temperature and humidity, respectively. -! On the Cray, stmaq is about 25 times faster than exact calculation. -! This subprogram should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell quadratic interpolation -! 1999-03-01 Iredell f90 module -! -! Usage: call stmaq(the,pk,tma,qma) -! -! Input argument list: -! the Real(krealfp) equivalent potential temperature in Kelvin -! pk Real(krealfp) pressure over 1e5 Pa to the kappa power -! -! Output argument list: -! tmaq Real(krealfp) parcel temperature in Kelvin -! qma Real(krealfp) parcel specific humidity in kg/kg -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp),intent(in):: the,pk - real(krealfp),intent(out):: tma,qma - integer jx,jy - real(krealfp) xj,yj,dxj,dyj - real(krealfp) ft11,ft12,ft13,ft21,ft22,ft23,ft31,ft32,ft33 - real(krealfp) ftx1,ftx2,ftx3 - real(krealfp) q11,q12,q13,q21,q22,q23,q31,q32,q33,qx1,qx2,qx3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xma+c2xma*the,1._krealfp),real(nxma,krealfp)) - yj=min(max(c1yma+c2yma*pk,1._krealfp),real(nyma,krealfp)) - jx=min(max(nint(xj),2),nxma-1) - jy=min(max(nint(yj),2),nyma-1) - dxj=xj-jx - dyj=yj-jy - ft11=tbtma(jx-1,jy-1) - ft12=tbtma(jx-1,jy) - ft13=tbtma(jx-1,jy+1) - ft21=tbtma(jx,jy-1) - ft22=tbtma(jx,jy) - ft23=tbtma(jx,jy+1) - ft31=tbtma(jx+1,jy-1) - ft32=tbtma(jx+1,jy) - ft33=tbtma(jx+1,jy+1) - ftx1=(((ft31+ft11)/2-ft21)*dxj+(ft31-ft11)/2)*dxj+ft21 - ftx2=(((ft32+ft12)/2-ft22)*dxj+(ft32-ft12)/2)*dxj+ft22 - ftx3=(((ft33+ft13)/2-ft23)*dxj+(ft33-ft13)/2)*dxj+ft23 - tma=(((ftx3+ftx1)/2-ftx2)*dyj+(ftx3-ftx1)/2)*dyj+ftx2 - q11=tbqma(jx-1,jy-1) - q12=tbqma(jx-1,jy) - q13=tbqma(jx-1,jy+1) - q21=tbqma(jx,jy-1) - q22=tbqma(jx,jy) - q23=tbqma(jx,jy+1) - q31=tbqma(jx+1,jy-1) - q32=tbqma(jx+1,jy) - q33=tbqma(jx+1,jy+1) - qx1=(((q31+q11)/2-q21)*dxj+(q31-q11)/2)*dxj+q21 - qx2=(((q32+q12)/2-q22)*dxj+(q32-q12)/2)*dxj+q22 - qx3=(((q33+q13)/2-q23)*dxj+(q33-q13)/2)*dxj+q23 - qma=(((qx3+qx1)/2-qx2)*dyj+(qx3-qx1)/2)*dyj+qx2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental subroutine stmax(the,pk,tma,qma) -!$$$ Subprogram Documentation Block -! -! Subprogram: stmax Compute moist adiabat temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Exactly compute temperature and humidity of a parcel -! lifted up a moist adiabat from equivalent potential temperature -! at the LCL and pressure over 1e5 Pa to the kappa power. -! An approximate parcel temperature for subprogram stmaxg -! is obtained using stma so gtma must be already called. -! See documentation for stmaxg for details. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! -! Usage: call stmax(the,pk,tma,qma) -! -! Input argument list: -! the Real(krealfp) equivalent potential temperature in Kelvin -! pk Real(krealfp) pressure over 1e5 Pa to the kappa power -! -! Output argument list: -! tma Real(krealfp) parcel temperature in Kelvin -! qma Real(krealfp) parcel specific humidity in kg/kg -! -! Subprograms called: -! (stma) inlinable subprogram to compute parcel temperature -! (stmaxg) inlinable subprogram to compute parcel temperature -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp),intent(in):: the,pk - real(krealfp),intent(out):: tma,qma - real(krealfp) tg,qg -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call stma(the,pk,tg,qg) - call stmaxg(tg,the,pk,tma,qma) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental subroutine stmaxg(tg,the,pk,tma,qma) -!$$$ Subprogram Documentation Block -! -! Subprogram: stmaxg Compute moist adiabat temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: exactly compute temperature and humidity of a parcel -! lifted up a moist adiabat from equivalent potential temperature -! at the LCL and pressure over 1e5 Pa to the kappa power. -! A guess parcel temperature must be provided. -! Equivalent potential temperature is constant for a saturated parcel -! rising adiabatically up a moist adiabat when the heat and mass -! of the condensed water are neglected. Ice is also neglected. -! The formula for equivalent potential temperature (Holton) is -! the=t*(pd**(-rocp))*exp(el*eps*pv/(cp*t*pd)) -! where t is the temperature, pv is the saturated vapor pressure, -! pd is the dry pressure p-pv, el is the temperature dependent -! latent heat of condensation hvap+dldt*(t-ttp), and other values -! are physical constants defined in parameter statements in the code. -! The formula is inverted by iterating Newtonian approximations -! for each the and p until t is found to within 1.e-4 Kelvin. -! The specific humidity is then computed from pv and pd. -! This subprogram can be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! -! Usage: call stmaxg(tg,the,pk,tma,qma) -! -! Input argument list: -! tg Real(krealfp) guess parcel temperature in Kelvin -! the Real(krealfp) equivalent potential temperature in Kelvin -! pk Real(krealfp) pressure over 1e5 Pa to the kappa power -! -! Output argument list: -! tma Real(krealfp) parcel temperature in Kelvin -! qma Real(krealfp) parcel specific humidity in kg/kg -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp),intent(in):: tg,the,pk - real(krealfp),intent(out):: tma,qma - real(krealfp),parameter:: terrm=1.e-4 - real(krealfp) t,p,tr,pv,pd,el,expo,thet,dthet,terr - integer i -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - t=tg - p=pk**con_cpor - do i=1,100 - tr=con_ttp/t - pv=psatb*(tr**con_xpona)*exp(con_xponb*(1.-tr)) - pd=p-pv - el=con_hvap+con_dldt*(t-con_ttp) - expo=el*con_eps*pv/(con_cp*t*pd) - thet=t*pd**(-con_rocp)*exp(expo) - dthet=thet/t*(1.+expo*(con_dldt*t/el+el*p/(con_rv*t*pd))) - terr=(thet-the)/dthet - t=t-terr - if(abs(terr).le.terrm) exit - enddo - tma=t - tr=con_ttp/t - pv=psatb*(tr**con_xpona)*exp(con_xponb*(1.-tr)) - pd=p-pv - qma=con_eps*pv/(pd+con_eps*pv) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine gpkap -!$$$ Subprogram documentation block -! -! Subprogram: gpkap Compute coefficients for p**kappa -! Author: Phillips org: w/NMC2X2 Date: 29 dec 82 -! -! Abstract: Computes pressure to the kappa table as a function of pressure -! for the table lookup function fpkap. -! Exact pressure to the kappa values are calculated in subprogram fpkapx. -! The current implementation computes a table with a length -! of 5501 for pressures ranging up to 110000 Pascals. -! -! Program History Log: -! 94-12-30 Iredell -! 1999-03-01 Iredell f90 module -! 1999-03-24 Iredell table lookup -! -! Usage: call gpkap -! -! Subprograms called: -! fpkapx function to compute exact pressure to the kappa -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx - real(krealfp) xmin,xmax,xinc,x,p -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=0._krealfp - xmax=110000._krealfp - xinc=(xmax-xmin)/(nxpkap-1) - c1xpkap=1.-xmin/xinc - c2xpkap=1./xinc - do jx=1,nxpkap - x=xmin+(jx-1)*xinc - p=x - tbpkap(jx)=fpkapx(p) - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental function fpkap(p) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpkap raise pressure to the kappa power. -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Raise pressure over 1e5 Pa to the kappa power. -! A linear interpolation is done between values in a lookup table -! computed in gpkap. See documentation for fpkapx for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy ranges from 9 decimal places -! at 100000 Pascals to 5 decimal places at 1000 Pascals. -! On the Cray, fpkap is over 5 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell standardized kappa, -! increased range and accuracy -! 1999-03-01 Iredell f90 module -! 1999-03-24 Iredell table lookup -! -! Usage: pkap=fpkap(p) -! -! Input argument list: -! p Real(krealfp) pressure in Pascals -! -! Output argument list: -! fpkap Real(krealfp) p over 1e5 Pa to the kappa power -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpkap - real(krealfp),intent(in):: p - integer jx - real(krealfp) xj -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xpkap+c2xpkap*p,1._krealfp),real(nxpkap,krealfp)) - jx=min(xj,nxpkap-1._krealfp) - fpkap=tbpkap(jx)+(xj-jx)*(tbpkap(jx+1)-tbpkap(jx)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function fpkapq(p) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpkapq raise pressure to the kappa power. -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Raise pressure over 1e5 Pa to the kappa power. -! A quadratic interpolation is done between values in a lookup table -! computed in gpkap. see documentation for fpkapx for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy ranges from 12 decimal places -! at 100000 Pascals to 7 decimal places at 1000 Pascals. -! On the Cray, fpkap is over 4 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell standardized kappa, -! increased range and accuracy -! 1999-03-01 Iredell f90 module -! 1999-03-24 Iredell table lookup -! -! Usage: pkap=fpkapq(p) -! -! Input argument list: -! p Real(krealfp) pressure in Pascals -! -! Output argument list: -! fpkapq Real(krealfp) p over 1e5 Pa to the kappa power -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpkapq - real(krealfp),intent(in):: p - integer jx - real(krealfp) xj,dxj,fj1,fj2,fj3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xpkap+c2xpkap*p,1._krealfp),real(nxpkap,krealfp)) - jx=min(max(nint(xj),2),nxpkap-1) - dxj=xj-jx - fj1=tbpkap(jx-1) - fj2=tbpkap(jx) - fj3=tbpkap(jx+1) - fpkapq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - function fpkapo(p) -!$$$ Subprogram documentation block -! -! Subprogram: fpkapo raise surface pressure to the kappa power. -! Author: Phillips org: w/NMC2X2 Date: 29 dec 82 -! -! Abstract: Raise surface pressure over 1e5 Pa to the kappa power -! using a rational weighted chebyshev approximation. -! The numerator is of order 2 and the denominator is of order 4. -! The pressure range is 40000-110000 Pa and kappa is defined in fpkapx. -! The accuracy of this approximation is almost 8 decimal places. -! On the Cray, fpkap is over 10 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell standardized kappa, -! increased range and accuracy -! 1999-03-01 Iredell f90 module -! -! Usage: pkap=fpkapo(p) -! -! Input argument list: -! p Real(krealfp) surface pressure in Pascals -! p should be in the range 40000 to 110000 -! -! Output argument list: -! fpkapo Real(krealfp) p over 1e5 Pa to the kappa power -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpkapo - real(krealfp),intent(in):: p - integer,parameter:: nnpk=2,ndpk=4 - real(krealfp):: cnpk(0:nnpk)=(/3.13198449e-1,5.78544829e-2,& - 8.35491871e-4/) - real(krealfp):: cdpk(0:ndpk)=(/1.,8.15968401e-2,5.72839518e-4,& - -4.86959812e-7,5.24459889e-10/) - integer n - real(krealfp) pkpa,fnpk,fdpk -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - pkpa=p*1.e-3_krealfp - fnpk=cnpk(nnpk) - do n=nnpk-1,0,-1 - fnpk=pkpa*fnpk+cnpk(n) - enddo - fdpk=cdpk(ndpk) - do n=ndpk-1,0,-1 - fdpk=pkpa*fdpk+cdpk(n) - enddo - fpkapo=fnpk/fdpk -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function fpkapx(p) -!$$$ Subprogram documentation block -! -! Subprogram: fpkapx raise pressure to the kappa power. -! Author: Phillips org: w/NMC2X2 Date: 29 dec 82 -! -! Abstract: raise pressure over 1e5 Pa to the kappa power. -! Kappa is equal to rd/cp where rd and cp are physical constants. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 94-12-30 Iredell made into inlinable function -! 1999-03-01 Iredell f90 module -! -! Usage: pkap=fpkapx(p) -! -! Input argument list: -! p Real(krealfp) pressure in Pascals -! -! Output argument list: -! fpkapx Real(krealfp) p over 1e5 Pa to the kappa power -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpkapx - real(krealfp),intent(in):: p -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - fpkapx=(p/1.e5_krealfp)**con_rocp -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - subroutine grkap -!$$$ Subprogram documentation block -! -! Subprogram: grkap Compute coefficients for p**(1/kappa) -! Author: Phillips org: w/NMC2X2 Date: 29 dec 82 -! -! Abstract: Computes pressure to the 1/kappa table as a function of pressure -! for the table lookup function frkap. -! Exact pressure to the 1/kappa values are calculated in subprogram frkapx. -! The current implementation computes a table with a length -! of 5501 for pressures ranging up to 110000 Pascals. -! -! Program History Log: -! 94-12-30 Iredell -! 1999-03-01 Iredell f90 module -! 1999-03-24 Iredell table lookup -! -! Usage: call grkap -! -! Subprograms called: -! frkapx function to compute exact pressure to the 1/kappa -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx - real(krealfp) xmin,xmax,xinc,x,p -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=0._krealfp - xmax=fpkapx(110000._krealfp) - xinc=(xmax-xmin)/(nxrkap-1) - c1xrkap=1.-xmin/xinc - c2xrkap=1./xinc - do jx=1,nxrkap - x=xmin+(jx-1)*xinc - p=x - tbrkap(jx)=frkapx(p) - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental function frkap(pkap) -!$$$ Subprogram Documentation Block -! -! Subprogram: frkap raise pressure to the 1/kappa power. -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Raise pressure over 1e5 Pa to the 1/kappa power. -! A linear interpolation is done between values in a lookup table -! computed in grkap. See documentation for frkapx for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is better than 7 decimal places. -! On the IBM, fpkap is about 4 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell standardized kappa, -! increased range and accuracy -! 1999-03-01 Iredell f90 module -! 1999-03-24 Iredell table lookup -! -! Usage: p=frkap(pkap) -! -! Input argument list: -! pkap Real(krealfp) p over 1e5 Pa to the kappa power -! -! Output argument list: -! frkap Real(krealfp) pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) frkap - real(krealfp),intent(in):: pkap - integer jx - real(krealfp) xj -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xrkap+c2xrkap*pkap,1._krealfp),real(nxrkap,krealfp)) - jx=min(xj,nxrkap-1._krealfp) - frkap=tbrkap(jx)+(xj-jx)*(tbrkap(jx+1)-tbrkap(jx)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function frkapq(pkap) -!$$$ Subprogram Documentation Block -! -! Subprogram: frkapq raise pressure to the 1/kappa power. -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Raise pressure over 1e5 Pa to the 1/kappa power. -! A quadratic interpolation is done between values in a lookup table -! computed in grkap. see documentation for frkapx for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is better than 11 decimal places. -! On the IBM, fpkap is almost 4 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell standardized kappa, -! increased range and accuracy -! 1999-03-01 Iredell f90 module -! 1999-03-24 Iredell table lookup -! -! Usage: p=frkapq(pkap) -! -! Input argument list: -! pkap Real(krealfp) p over 1e5 Pa to the kappa power -! -! Output argument list: -! frkapq Real(krealfp) pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) frkapq - real(krealfp),intent(in):: pkap - integer jx - real(krealfp) xj,dxj,fj1,fj2,fj3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xrkap+c2xrkap*pkap,1._krealfp),real(nxrkap,krealfp)) - jx=min(max(nint(xj),2),nxrkap-1) - dxj=xj-jx - fj1=tbrkap(jx-1) - fj2=tbrkap(jx) - fj3=tbrkap(jx+1) - frkapq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function frkapx(pkap) -!$$$ Subprogram documentation block -! -! Subprogram: frkapx raise pressure to the 1/kappa power. -! Author: Phillips org: w/NMC2X2 Date: 29 dec 82 -! -! Abstract: raise pressure over 1e5 Pa to the 1/kappa power. -! Kappa is equal to rd/cp where rd and cp are physical constants. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 94-12-30 Iredell made into inlinable function -! 1999-03-01 Iredell f90 module -! -! Usage: p=frkapx(pkap) -! -! Input argument list: -! pkap Real(krealfp) p over 1e5 Pa to the kappa power -! -! Output argument list: -! frkapx Real(krealfp) pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) frkapx - real(krealfp),intent(in):: pkap -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - frkapx=pkap**(1/con_rocp)*1.e5_krealfp -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - subroutine gtlcl -!$$$ Subprogram Documentation Block -! -! Subprogram: gtlcl Compute equivalent potential temperature table -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute lifting condensation level temperature table -! as a function of temperature and dewpoint depression for function ftlcl. -! Lifting condensation level temperature is calculated in subprogram ftlclx -! The current implementation computes a table with a first dimension -! of 151 for temperatures ranging from 180.0 to 330.0 Kelvin -! and a second dimension of 61 for dewpoint depression ranging from -! 0 to 60 Kelvin. -! -! Program History Log: -! 1999-03-01 Iredell f90 module -! -! Usage: call gtlcl -! -! Subprograms called: -! (ftlclx) inlinable function to compute LCL temperature -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx,jy - real(krealfp) xmin,xmax,ymin,ymax,xinc,yinc,x,y,tdpd,t -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=180._krealfp - xmax=330._krealfp - ymin=0._krealfp - ymax=60._krealfp - xinc=(xmax-xmin)/(nxtlcl-1) - c1xtlcl=1.-xmin/xinc - c2xtlcl=1./xinc - yinc=(ymax-ymin)/(nytlcl-1) - c1ytlcl=1.-ymin/yinc - c2ytlcl=1./yinc - do jy=1,nytlcl - y=ymin+(jy-1)*yinc - tdpd=y - do jx=1,nxtlcl - x=xmin+(jx-1)*xinc - t=x - tbtlcl(jx,jy)=ftlclx(t,tdpd) - enddo - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental function ftlcl(t,tdpd) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftlcl Compute LCL temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute temperature at the lifting condensation level -! from temperature and dewpoint depression. -! A bilinear interpolation is done between values in a lookup table -! computed in gtlcl. See documentation for ftlclx for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is better than 0.0005 Kelvin. -! On the Cray, ftlcl is ? times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 1999-03-01 Iredell f90 module -! -! Usage: tlcl=ftlcl(t,tdpd) -! -! Input argument list: -! t Real(krealfp) LCL temperature in Kelvin -! tdpd Real(krealfp) dewpoint depression in Kelvin -! -! Output argument list: -! ftlcl Real(krealfp) temperature at the LCL in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftlcl - real(krealfp),intent(in):: t,tdpd - integer jx,jy - real(krealfp) xj,yj,ftx1,ftx2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xtlcl+c2xtlcl*t,1._krealfp),real(nxtlcl,krealfp)) - yj=min(max(c1ytlcl+c2ytlcl*tdpd,1._krealfp),real(nytlcl,krealfp)) - jx=min(xj,nxtlcl-1._krealfp) - jy=min(yj,nytlcl-1._krealfp) - ftx1=tbtlcl(jx,jy)+(xj-jx)*(tbtlcl(jx+1,jy)-tbtlcl(jx,jy)) - ftx2=tbtlcl(jx,jy+1)+(xj-jx)*(tbtlcl(jx+1,jy+1)-tbtlcl(jx,jy+1)) - ftlcl=ftx1+(yj-jy)*(ftx2-ftx1) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftlclq(t,tdpd) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftlclq Compute LCL temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute temperature at the lifting condensation level -! from temperature and dewpoint depression. -! A biquadratic interpolation is done between values in a lookup table -! computed in gtlcl. see documentation for ftlclx for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is better than 0.000003 Kelvin. -! On the Cray, ftlclq is ? times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 1999-03-01 Iredell f90 module -! -! Usage: tlcl=ftlclq(t,tdpd) -! -! Input argument list: -! t Real(krealfp) LCL temperature in Kelvin -! tdpd Real(krealfp) dewpoint depression in Kelvin -! -! Output argument list: -! ftlcl Real(krealfp) temperature at the LCL in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftlclq - real(krealfp),intent(in):: t,tdpd - integer jx,jy - real(krealfp) xj,yj,dxj,dyj - real(krealfp) ft11,ft12,ft13,ft21,ft22,ft23,ft31,ft32,ft33 - real(krealfp) ftx1,ftx2,ftx3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xtlcl+c2xtlcl*t,1._krealfp),real(nxtlcl,krealfp)) - yj=min(max(c1ytlcl+c2ytlcl*tdpd,1._krealfp),real(nytlcl,krealfp)) - jx=min(max(nint(xj),2),nxtlcl-1) - jy=min(max(nint(yj),2),nytlcl-1) - dxj=xj-jx - dyj=yj-jy - ft11=tbtlcl(jx-1,jy-1) - ft12=tbtlcl(jx-1,jy) - ft13=tbtlcl(jx-1,jy+1) - ft21=tbtlcl(jx,jy-1) - ft22=tbtlcl(jx,jy) - ft23=tbtlcl(jx,jy+1) - ft31=tbtlcl(jx+1,jy-1) - ft32=tbtlcl(jx+1,jy) - ft33=tbtlcl(jx+1,jy+1) - ftx1=(((ft31+ft11)/2-ft21)*dxj+(ft31-ft11)/2)*dxj+ft21 - ftx2=(((ft32+ft12)/2-ft22)*dxj+(ft32-ft12)/2)*dxj+ft22 - ftx3=(((ft33+ft13)/2-ft23)*dxj+(ft33-ft13)/2)*dxj+ft23 - ftlclq=(((ftx3+ftx1)/2-ftx2)*dyj+(ftx3-ftx1)/2)*dyj+ftx2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - function ftlclo(t,tdpd) -!$$$ Subprogram documentation block -! -! Subprogram: ftlclo Compute LCL temperature. -! Author: Phillips org: w/NMC2X2 Date: 29 dec 82 -! -! Abstract: Compute temperature at the lifting condensation level -! from temperature and dewpoint depression. the formula used is -! a polynomial taken from Phillips mstadb routine which empirically -! approximates the original exact implicit relationship. -! (This kind of approximation is customary (inman, 1969), but -! the original source for this particular one is not yet known. -MI) -! Its accuracy is about 0.03 Kelvin for a dewpoint depression of 30. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 1999-03-01 Iredell f90 module -! -! Usage: tlcl=ftlclo(t,tdpd) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! tdpd Real(krealfp) dewpoint depression in Kelvin -! -! Output argument list: -! ftlclo Real(krealfp) temperature at the LCL in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftlclo - real(krealfp),intent(in):: t,tdpd - real(krealfp),parameter:: clcl1= 0.954442e+0,clcl2= 0.967772e-3,& - clcl3=-0.710321e-3,clcl4=-0.270742e-5 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ftlclo=t-tdpd*(clcl1+clcl2*t+tdpd*(clcl3+clcl4*t)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftlclx(t,tdpd) -!$$$ Subprogram documentation block -! -! Subprogram: ftlclx Compute LCL temperature. -! Author: Iredell org: w/NMC2X2 Date: 25 March 1999 -! -! Abstract: Compute temperature at the lifting condensation level -! from temperature and dewpoint depression. A parcel lifted -! adiabatically becomes saturated at the lifting condensation level. -! The water model assumes a perfect gas, constant specific heats -! for gas and liquid, and neglects the volume of the liquid. -! The model does account for the variation of the latent heat -! of condensation with temperature. The ice option is not included. -! The Clausius-Clapeyron equation is integrated from the triple point -! to get the formulas -! pvlcl=con_psat*(trlcl**xa)*exp(xb*(1.-trlcl)) -! pvdew=con_psat*(trdew**xa)*exp(xb*(1.-trdew)) -! where pvlcl is the saturated parcel vapor pressure at the LCL, -! pvdew is the unsaturated parcel vapor pressure initially, -! trlcl is ttp/tlcl and trdew is ttp/tdew. The adiabatic lifting -! of the parcel is represented by the following formula -! pvdew=pvlcl*(t/tlcl)**(1/kappa) -! This formula is inverted by iterating Newtonian approximations -! until tlcl is found to within 1.e-6 Kelvin. Note that the minimum -! returned temperature is 180 Kelvin. -! -! Program History Log: -! 1999-03-25 Iredell -! -! Usage: tlcl=ftlclx(t,tdpd) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! tdpd Real(krealfp) dewpoint depression in Kelvin -! -! Output argument list: -! ftlclx Real(krealfp) temperature at the LCL in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftlclx - real(krealfp),intent(in):: t,tdpd - real(krealfp),parameter:: terrm=1.e-4,tlmin=180.,tlminx=tlmin-5. - real(krealfp) tr,pvdew,tlcl,ta,pvlcl,el,dpvlcl,terr,terrp - integer i -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - tr=con_ttp/(t-tdpd) - pvdew=con_psat*(tr**con_xpona)*exp(con_xponb*(1.-tr)) - tlcl=t-tdpd - do i=1,100 - tr=con_ttp/tlcl - ta=t/tlcl - pvlcl=con_psat*(tr**con_xpona)*exp(con_xponb*(1.-tr))*ta**(1/con_rocp) - el=con_hvap+con_dldt*(tlcl-con_ttp) - dpvlcl=(el/(con_rv*t**2)+1/(con_rocp*tlcl))*pvlcl - terr=(pvlcl-pvdew)/dpvlcl - tlcl=tlcl-terr - if(abs(terr).le.terrm.or.tlcl.lt.tlminx) exit - enddo - ftlclx=max(tlcl,tlmin) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - subroutine gfuncphys -!$$$ Subprogram Documentation Block -! -! Subprogram: gfuncphys Compute all physics function tables -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute all physics function tables. Lookup tables are -! set up for computing saturation vapor pressure, dewpoint temperature, -! equivalent potential temperature, moist adiabatic temperature and humidity, -! pressure to the kappa, and lifting condensation level temperature. -! -! Program History Log: -! 1999-03-01 Iredell f90 module -! -! Usage: call gfuncphys -! -! Subprograms called: -! gpvsl compute saturation vapor pressure over liquid table -! gpvsi compute saturation vapor pressure over ice table -! gpvs compute saturation vapor pressure table -! gtdpl compute dewpoint temperature over liquid table -! gtdpi compute dewpoint temperature over ice table -! gtdp compute dewpoint temperature table -! gthe compute equivalent potential temperature table -! gtma compute moist adiabat tables -! gpkap compute pressure to the kappa table -! grkap compute pressure to the 1/kappa table -! gtlcl compute LCL temperature table -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call gpvsl - call gpvsi - call gpvs - call gtdpl - call gtdpi - call gtdp - call gthe - call gtma - call gpkap - call grkap - call gtlcl -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- -end module diff --git a/src/fim/FIMsrc/fim/column/function2 b/src/fim/FIMsrc/fim/column/function2 deleted file mode 100644 index f332823..0000000 --- a/src/fim/FIMsrc/fim/column/function2 +++ /dev/null @@ -1,5 +0,0 @@ -!cc - indlsev(n,l) = jbasev + (n-l)/2 + 1 -!cc - indlsod(n,l) = jbasod + (n-l)/2 + 1 -!cc diff --git a/src/fim/FIMsrc/fim/column/gbphys_v.f b/src/fim/FIMsrc/fim/column/gbphys_v.f deleted file mode 100644 index 62fd62d..0000000 --- a/src/fim/FIMsrc/fim/column/gbphys_v.f +++ /dev/null @@ -1,2431 +0,0 @@ - SUBROUTINE GBPHYS(IM,IX,levs,lsoil,lsm,ntrac,ncld, - & ntoz,ntcw,nmtvr,lonf,latg,jcap,ras,nlons,xkt2,nrcm,pre_rad, - & UGRS,VGRS,PGR,TGRS,QGRS,vvel, - & GT0,GQ0,GU0,GV0,sinlat,coslat,rcs2,sdiaga,sdiagb, - & prsi,prsl,prslk,prsik,phii,phil,dpshc,fhour,lssav,solhr, -! & prsi,prsl,prslk,prsik,phii,phil,prsshc,fhour,lssav,solhr, - & lsfwd,clstp,dtp,dtf,poz,prdout,ko3,pl_coeff, -! The beginning for oceanic sub-layer and diurnal models. XL, Dec, 2007 -! & nr_ocn,nf_ocn,nsst_active,ifd,time_old,time_ins,I_Sw,I_Q,I_Qrain, - & nsst_active,ifd,time_old,time_ins,I_Sw,I_Q,I_Qrain, - & I_M,I_Tau,I_Sw_Zw,I_Q_Ts,I_M_Ts, - & Tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d, -! The end for oceanic sub-layer and diurnal models. XL, Dec, 2007 - & HICE,FICE,TISFC,SFCDSW, ! FOR SEA-ICE - XW Nov04 -Clu [+2L]: add (tprcp,srflag),(slc,snwdph,slope,shdmin,shdmax,snoalb),sfalb - & TPRCP, SRFLAG, - & SLC ,SNWDPH,SLOPE ,SHDMIN,SHDMAX,SNOALB,SFALB , -Cwei added 10/24/2006 - & CHH,CMM,EPI,DLWSFCI,ULWSFCI,USWSFCI,DSWSFCI,DTSFCI, - & DQSFCI,GFLUXI,SRUNOFF,T1,Q1,U1,V1,ZLVL,EVBSA,EVCWA, - & TRANSA,SBSNOA,SNOWCA,SOILM,SNOHFA,SMCWLT2,SMCREF2, - -!hchuang code change - & gsoil,gtmp2m,gustar,gpblh,gu10m,gv10m,gzorl,goro, - - & TSEA ,SHELEG,SNCOVR, TG3 ,ZORL ,CV ,CVB ,CVT , - & SLMSK ,VFRAC ,CANOPY,F10M ,VTYPE ,STYPE ,UUSTAR,FFMM ,FFHH , - & TMPMIN,TMPMAX, -!jwang add spfhmax/spfhmin - & SPFHMIN,SPFHMAX, - & GESHEM,DUSFC ,DVSFC ,DTSFC ,DQSFC ,DLWSFC,ULWSFC, - & suntim, - & GFLUX ,RUNOFF,EP ,CLDWRK,DUGWD ,DVGWD ,PSMEAN,BENGSH,XLON , - & COSZEN,SFCNSW,XLAT , - & SFCDLW,TSFLW ,PSURF ,U10M ,V10M ,T2M ,Q2M , -! & COSZEN,SFCNSW,SFCDLW,TSFLW ,PSURF ,U10M ,V10M ,T2M ,Q2M , - & HPBL ,PWAT ,SWH,HLW,SMC,STC,HPRIME,slag,sdec,cdec, - & acv,acvb,acvt, - & phy_f3d, phy_f2d, num_p3d, num_p2d, flgmin, - & DT3DT, DQ3DT, DU3DT, DV3DT, upd_mf, dwn_mf, det_mf, - & dkt, dkh, rnp, LDIAG3D, lggfs3d, -! & DT3DT, DQ3DT, DU3DT, DV3DT, LDIAG3D, -! -! Coupling deletion-> -! & flipv, me,kdt,lat,oro, crtrh, ncw, old_monin) -!<-Coupling deletion -! Coupling insertion-> - & flipv, me,kdt,lat,oro, crtrh, ncw, old_monin,cnvgwd,ccwf,ctei_rm, - & sashal,newsas,mom4ice,mstrat,trans_trac,cal_pre,HFLX,EVAP, - > lssav_cc_dummy,DLWSFC_cc_dummy,ULWSFC_cc_dummy,SWSFC_cc_dummy, - > XMU_cc_dummy, - > DLW_cc_dummy,DSW_cc_dummy,SNW_cc_dummy,LPREC_cc_dummy, !cpl insertion - > DUSFC_cc_dummy,DVSFC_cc_dummy,DTSFC_cc_dummy,DQSFC_cc_dummy, - > PRECR_cc_dummy,skip_cu_physics,skip_mp_physics, cubot, cutop) - -!! USE SURFACE_cc, ONLY: JCAL_cc -!<-Coupling insertion -! - USE MACHINE , ONLY : kind_phys - USE PHYSCONS, ROCP => con_rocp, CP => con_cp, FV => con_fvirt - &, grav => con_g, RD => con_RD - &, RV => con_RV, HVAP => con_HVAP - &, HFUS => con_HFUS - &, rerth => con_rerth, pi => con_pi - implicit none -! - integer levs,lsoil,lsm,ix,im,ntrac,ncld,ntoz,ntcw,nmtvr,lonf, - & latg,jcap,nlons(im),num_p3d,num_p2d,nrcm,lat - &, pl_coeff -! - real, parameter :: hocp=hvap/cp - LOGICAL lssav,lsfwd, old_monin, cnvgwd - LOGICAL skip_cu_physics,skip_mp_physics - integer levshc(im), levshcm ! Needed for pry version - integer ncw(2) -! real(kind=kind_phys) dtp,dtf,FHOUR,solhr, prsshc - real(kind=kind_phys) dtp,dtf,FHOUR,solhr, dpshc(im), crtrh(3) - real(kind=kind_phys) flgmin(2), ccwf, ctei_rm - real, parameter :: fhourpr=0.0 - -! Coupling insertion-> - logical lssav_cc_dummy - real(kind=kind_phys),dimension(IM):: - > DLWSFC_cc_dummy,ULWSFC_cc_dummy,SWSFC_cc_dummy,XMU_cc_dummy, - > DLW_cc_dummy,DSW_cc_dummy,SNW_cc_dummy,LPREC_cc_dummy, - > DUSFC_cc_dummy,DVSFC_cc_dummy,DTSFC_cc_dummy,DQSFC_cc_dummy, - > PRECR_cc_dummy - -!! real(kind=kind_phys),parameter:: CONVRAD_cc=JCAL_cc*1.E4/60. -!<-Coupling insertion - - real(kind=kind_phys) UGRS(IX,LEVS), VGRS(IX,LEVS), - & TGRS(IX,LEVS), qgrs(IX,levs,ntrac), - & VVEL(IX,LEVS), -! - & GT0(IX,LEVS), GU0(IX,LEVS), - & GV0(IX,LEVS), gq0(IX,levs,ntrac), -! - & DEL(IX,LEVS), PRSI(IX,LEVS+1), - & PRSL(IX,LEVS), PRSLK(IX,LEVS), - & PRSIK(IX,LEVS+1), PHII(IX,LEVS+1), - & PHIL(IX,LEVS), - & PGR(IM), XKT2(IX,nrcm) - &, ccwfac(im) - &, xcosz(im), suntim(im) ! yth mar/08 cosz for compute suntim - real(kind=kind_phys) sdiaga(IM,LEVS), sdiagb(IM,LEVS) - - real(kind=kind_phys) RCS2(IM), SINLAT(IM), COSLAT(IM),clstp - - real(kind=kind_phys) SMC(IX,LSOIL), STC(IX,LSOIL), SWH(IX,LEVS) - &, HICE(IM), FICE(IM), SFCDSW(IM) ! SEA-ICE - &, TISFC(IM) - &, HLW(IX,LEVS), HPRIME(IX,NMTVR), TSEA(IM) - &, SHELEG(IM), TG3(IM), ZORL(IM) - &, SNCOVR(IM) - &, CV(IM), CVB(IM), CVT(IM) - &, COSZEN(IM), PWAT(IM), SLMSK(IM) - &, VFRAC(IM), CANOPY(IM), F10M(IM) - &, VTYPE(IM), STYPE(IM), UUSTAR(IM) - &, FFMM(IM), FFHH(IM), TMPMIN(IM) - &, TMPMAX(IM), GESHEM(IM), DUSFC(IM) - &, DVSFC(IM), DTSFC(IM), DQSFC(IM) - &, DLWSFC(IM), ULWSFC(IM), GFLUX(IM) - &, RUNOFF(IM), EP(IM), CLDWRK(IM) - &, DUGWD(IM), DVGWD(IM), PSMEAN(IM) - &, BENGSH(IM), XLON(IM), SFCNSW(IM) - &, SFCDLW(IM), TSFLW(IM), PSURF(IM) - &, U10M(IM), V10M(IM), T2M(IM) - &, Q2M(IM), HPBL(IM), xlat(IM) -!jwang add spfhmax/spfhmin - &, SPFHMIN(IM), SPFHMAX(IM) -Clu [+5L]: add (tprcp,srflag),(slc,snwdph,shdmin,shdmax,snoalb,slope),sfalb,(fm10,fh2) - &, TPRCP(IM), SRFLAG(IM) - &, SLC(IX,LSOIL) - &, SNWDPH(IM), SHDMIN(IM), SHDMAX(IM) - &, SNOALB(IM), SLOPE(IM), SFALB(IM) -Cwei added 10/24/2006 - &, CHH(IM),CMM(IM),EPI(IM),DLWSFCI(IM),ULWSFCI(IM),USWSFCI(IM) - &, DSWSFCI(IM),DTSFCI(IM),DQSFCI(IM),GFLUXI(IM),SRUNOFF(IM),T1(IM) - &, Q1(IM),U1(IM),V1(IM),ZLVL(IM) - &, EVBSA(IM),EVCWA(IM),TRANSA(IM),SBSNOA(IM),SNOWCA(IM),SOILM(IM) -!hchuang code change 11/12/2007 [+2L] - &, gsoil(im), gtmp2m(im), gustar(im), gpblh(im), gu10m(im) - &, gv10m(im), gzorl(im), goro(im) - &, SNOHFA(IM),tseal(im) -! - &, phy_f3d(IX,LEVS,num_p3d), phy_f2d(IX,num_p2d) - &, acv(IM), acvb(IM), acvt(IM) - &, oro(im) - -! li added for oceanic components -! integer nr_ocn,nf_ocn -! real(kind=kind_phys) ocnr(im,nr_ocn) -! real(kind=kind_phys) ocnf(im,nf_ocn) - real(kind=kind_phys) ifd(im),time_old(im),time_ins(im),I_Sw(im), - & I_Q(im),I_Qrain(im),I_M(im),I_Tau(im), - & I_Sw_Zw(im),I_Q_Ts(im),I_M_Ts(im),Tref(im), - & dt_cool(im),z_c(im),dt_warm(im),z_w(im), - & c_0(im),c_d(im),w_0(im),w_d(im) - real(kind=kind_phys) cubot,cutop - logical nsst_active - - real(kind=kind_phys) slag,sdec,cdec -! - real(kind=kind_phys) dt3dt(IX,levs,6), dq3dt(IX,levs,5+pl_coeff), - & du3dt(IX,levs,4), dv3dt(IX,levs,4) -! &, cumflx(ix,levs) -!hchuang code change [+3L] - &, dkh(IX,LEVS), rnp(ix,levs) - &, upd_mf(ix,levs), dwn_mf(ix,levs) - &, det_mf(ix,levs) -! - integer me, kdt - logical RAS,LDIAG3D,pre_rad,sashal,newsas,mom4ice,mstrat - &, trans_trac,lggfs3d,cal_pre -! -! In CLW, the first two varaibles are cloud water and ice. -! From third to ntrac are convective transportable tracers, -! third being the ozone, when ntrac=3 (valid only with RAS) -! - real(kind=kind_phys), allocatable :: CLW(:,:,:) - real(kind=kind_phys) garea(im), dlength(im) -! real(kind=kind_phys) CLW(IX,LEVS,ntrac) -! &, garea(im), dlength(im) -! - integer KO3 - real(kind=kind_phys) poz(KO3), prdout(IX,ko3,pl_coeff) -! - real(kind=kind_phys) RHC(IM,LEVS), SR(IM,levs) - &, xncw(IM), rhbbot, rhbtop, rhpbl - &, dxmax, dxmin, dxinv - &, dkt(IM,LEVS-1), rainp(im,levs) - &, ud_mf(im,levs), dd_mf(im,levs) - &, dt_mf(im,levs) - logical flipv -! - real, PARAMETER:: RLAPSE=0.65E-2 - real(kind=kind_phys), parameter :: rhc_max=0.9999 ! 20060512 -! real(kind=kind_phys), parameter :: rhc_max=0.999 ! for pry -! - real (kind=kind_phys), parameter :: qmin=1.0e-10, p850=85.0 - -! -! -! parameter (dxmax=log(1.0/7200.0), dxmin=log(1.0/192.0) -! parameter (dxmax=-8.8818363, dxmin=-5.2574954 -! &, dxinv=1.0/(dxmax-dxmin)) -! parameter (dxmax=ln(1.0/14000.0), dxmin=ln(1.0/192.0) -! parameter (dxmax=-9.5468126, dxmin=-5.2574954 -! &, dxinv=1.0/(dxmax-dxmin)) -! -! parameter (dxmax=ln(1.0/(14000.0*7000.0)), dxmin=ln(1.0/(192.0*94.0)) -! -! parameter (dxmax=-18.40047804, dxmin=-9.800790154 -! &, dxinv=1.0/(dxmax-dxmin)) -! -! -! parameter (dxmax=ln(1.0/(4000.0*2000.0)), dxmin=ln(1.0/(192.0*94.0)) -! -! parameter (dxmax=-15.8949521, dxmin=-9.800790154 -! &, dxinv=1.0/(dxmax-dxmin)) -! -! parameter (dxmax=ln(1.0/(3000.0*1500.0)), dxmin=ln(1.0/(192.0*94.0)) -! -! parameter (dxmax=-15.31958795, dxmin=-9.800790154 -! &, dxinv=1.0/(dxmax-dxmin)) -! -! parameter (dxmax=ln(1.0/(2500.0*1250.0)), dxmin=ln(1.0/(192.0*94.0)) -! -! parameter (dxmax=-14.95494484, dxmin=-9.800790154 -! &, dxinv=1.0/(dxmax-dxmin)) -! -! parameter (dxmax=ln(1.0/(2000.0*1000.0)), dxmin=ln(1.0/(192.0*94.0)) -! parameter (dxmax=-14.50865774, dxmin=-9.800790154 -! &, dxinv=1.0/(dxmax-dxmin)) -! -! parameter (dxmax=ln(1.0/(5000.0*2500.0)), dxmin=ln(1.0/(192.0*94.0)) - parameter (dxmax=-16.118095651, dxmin=-9.800790154 - &, dxinv=1.0/(dxmax-dxmin)) -! - real (kind=kind_phys), parameter :: cb2mb=10.0 -c -c Local variables -c --------------- - real(kind=kind_phys) DTDT(IM,LEVS), DQDT(IM,LEVS,ntrac), - & DUDT(IM,LEVS), DVDT(IM,LEVS), - & GWDCU(IM,LEVS), GWDCV(IM,LEVS), - & DIAGN1(IM,LEVS), DIAGN2(IM,LEVS) - &, cuhr(im,levs) - real(kind=kind_phys) cumchr(IM,levs),cumabs(IM) - real(kind=kind_phys) qmax(IM) -! -Clu [-3L/+1L]: add slsoil; comment out ai, bi, cci, rhsmc, zsoil -Cwei [+1L]: uncomment and add slsoil because of adding OSU LSM - real(kind=kind_phys) SMSOIL(IM,LSOIL), STSOIL(IM,LSOIL), - & AI(IM,LSOIL), BI(IM,LSOIL), - & CCI(IM,LSOIL), RHSMC(IM,LSOIL), - & ZSOIL(IM,LSOIL), - + SLSOIL(IM,LSOIL) -!c-- XW: FOR SEA-ICE Nov04 - real(kind=kind_phys) CICE(IM), DSWSFC(IM), ZICE(IM) - &, TICE(IM) -!c-- XW: END SEA-ICE -! - real(kind=kind_phys) GFLX(IM), RAIN(IM), RAINC(IM), - & RAINL(IM), RAIN1(IM), EVAPC(IM), - & SNOWMT(IM), CD(IM), CDQ(IM), - & QSS(IM), radsl(IM), DUSFCG(IM), - & DVSFCG(IM), DUSFC1(IM), DVSFC1(IM), - & DTSFC1(IM), DQSFC1(IM), DLWSF1(IM), - & ULWSF1(IM), RB(IM), RHSCNPY(IM), - & DRAIN(IM), CLD1D(IM), RAINCS(IM), - & EVAP(IM), HFLX(IM), STRESS(IM), -! & EVAP(IM), HFLX(IM), RNET(IM), - & T850(IM), - & EP1D(IM), GAMT(IM), GAMQ(IM), - & sigmaf(IM), - & rcl(IM), rcs(IM), - & oc(IM), oa4(IM,4), clx(IM,4), - & theta(IM),gamma(IM),sigma(IM),elvmax(IM), - & wind(IM), work1(IM), work2(IM), - & runof(IM), xmu(IM) - &, qr_col(im,levs), fc_ice(im,levs) - &, oro_land(im) -Cwei added 10/24/2006 - &, EVBS(im),EVCW(im),TRANS(im),SBSNO(im),SNOWC(im),SNOHF(im) - &, SMCWLT2(IM),SMCREF2(IM) -! -Clu [+1L]: add (fm10,fh2) - &, FM10(IM), FH2(IM) -Clu_q2m_iter [+1L]: add tsurf - &, tsurf(im) -Clu_q2m_iter [+1L]: add flag_iter and flag_guess - logical flag_iter(im), flag_guess(im) -Clu_q2m [+1L]: add wrk1, wrk2 - real(kind=kind_phys) wrk1, wrk2 -! -! - REAL(kind=kind_phys), PARAMETER :: EPSQ=1.E-20, HSUB=HVAP+HFUS - integer KBOT(IM), KTOP(IM), kcnv(im), - & soiltyp(IM), vegtype(IM), kpbl(IM) -Clu [+1L]: add slopetyp - &, SLOPETYP(IM) - integer i, nvdiff, kk, ic, k, n, kinver(im), ipr, lv, k1 - &, lmh(im), tracers, trc_shft, tottracer -Clu_q2m_iter [+1L]: add iter - +, iter -! - logical lprnt, invrsn(im) - real(kind=kind_phys) frain, tem, tem1, qi, qw, qr, wc - &, f_rain, f_ice, tem0d, tx1(im), tx2(im) - &, tem2, ctei_r(im), flgmin_l(im) -! &, sumq, sumr, tem2 -! &, pwato(im), raino(im), evapo(im), sume -! -! HCHUANG add temporary arrays - real(kind=kind_phys), dimension(im) :: DOMR,DOMZR,DOMIP,DOMS - integer ipnGlobal,its,mype - logical DiagPrint - call PhysicsGetIpnItsMype(ipnGlobal,its,mype,DiagPrint) -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ - EVAPC = 0.0 - GFLX = 0.0 - QSS = 0.0 - del = 0.0 -! -! lprnt = .true. - lprnt = .false. -! ipr = 1 -! lprnt = kdt .gt. 0 .and. ilon .eq. 1 -! do i=1,im -! work1(1) = xlon(i) * 57.29578 -! if (work1(1) .ge. 180.0) work1(1) = work1(1) - 360.0 -! work2(1) = xlat(i) * 57.29578 -! print *,' me=',me,' work1=',work1(1),' work2=',work2(1),' i=',i -! lprnt = kdt .gt. 4320 -! lprnt = kdt .gt. 0 -! & .and. abs(work1(1)-110.3) .lt. 0.5 -! & .and. abs(work2(1)-2.0) .lt. 0.5 -! lprnt = kdt .ge. 14 .and. lat .eq. 43 -! lprnt = kdt .ge. 0 -! & .and. abs(xlon(i)*57.29578-180.0) .lt. 0.201 -! & .and. abs(xlat(i)*57.29578-4.76) .lt. 0.201 -! & .and. abs(xlon(i)*57.29578-110.3) .lt. 0.201 -! & .and. abs(xlat(i)*57.29578-2.0) .lt. 0.201 -! print *,' i=',i,' xlon=',xlon(i)*57.29578 -! &, ' xlat=',xlat(i)*57.29578 -! &,' i=',i,' me=',me -! if (lprnt) then -! ipr = i -! exit -! endif -! enddo - -! lprnt = .false. -! if(lprnt) then -! print *,' IM=',IM,' IX=',IX,' levs=',levs,' lsoil=',lsoil -! *,' ntrac=',ntrac,' ntoz=',ntoz,' ntcw=',ntcw,' me=',me -! *,' xlat=',xlat(ipr),' kdt=',kdt,' slmsk=',slmsk(ipr) -! &,' tsea=',tsea(ipr),' tref=',tref(ipr),' dt_cool=' -! &,dt_cool(ipr),' dt_warm=',dt_warm(ipr) -! *,' nrcm=',nrcm -! &,' xlon=',xlon(ipr),' sfalb=',sfalb(ipr),' kdt=',kdt -! print *,' pgr=',pgr(ipr),' kdt=',kdt,' ipr=',ipr -! print *,' ipr=',ipr,' phy_f2d=',phy_f2d(ipr,1:num_p2d) -! print *,' ugrs=',ugrs(ipr,:) -! print *,' vgrs=',vgrs(ipr,:) -! print *,' tgrs=',tgrs(ipr,:),' kdt=',kdt,' ipr=',ipr -! &,' xlon=',xlon(ipr),' xlat=',xlat(ipr) -! print *,' qgrs=',qgrs(ipr,:,1) -! print *,' ozg=',qgrs(ipr,:,2) -! print *,' clw=',qgrs(ipr,:,3) -! &,' xlon=',xlon(ipr),' xlat=',xlat(ipr) -! endif -! -! - lmh(:) = levs - NVDIFF = ntrac ! vertical diffusion of all tracers! -! -! Figure out how many extra tracers are there -! - tottracer = 0 ! no convective transport of tracers - if (trans_trac) then - if (ntcw > 0) then - if (ntoz < ntcw) then - trc_shft = ntcw + ncld - 1 - else - trc_shft = ntoz - endif - elseif (ntoz > 0) then - trc_shft = ntoz - else - trc_shft = 1 - endif - - tracers = ntrac - trc_shft - tottracer = tracers - if (ntoz > 0) tottracer = tottracer + 1 ! ozone is added separately - endif - allocate (clw(ix,levs,tottracer+2)) - -! if (lprnt) print *,' trans_trac=',trans_trac,' tottracer=', -! & tottracer,' trc_shft=',trc_shft,' kdt=',kdt -! - if (ras) then - if (ccwf >= 0.0) then - ccwfac = ccwf - else - ccwfac = -999.0 - endif - endif -! -! - CALL GET_PRS(im,ix,levs,ntrac,TGRS,QGRS - &, prsi,prsik,prsl,prslk,phii,phil,del) -!.......................................................................... -! - rhbbot = crtrh(1) - rhpbl = crtrh(2) - rhbtop = crtrh(3) - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! do i=1,im -! PWATo(i) = 0. -! evapo(i) = dqsfc(i) -! raino(i) = geshem(i) -! enddo -! DO K=1,LEVS -! do i=1,im -! work1(i) = 0.0 -! enddo -! if (ncld .gt. 0) then -! do ic=ntcw, ntcw+ncld-1 -! do i=1,im -! work1(i) = work1(i) + qgrs(i,k,ic) -! enddo -! enddo -! endif -! do i=1,im -! PWATo(i) = PWATo(i) + DEL(i,K)*(qgrs(i,K,1)+work1(i)) -! enddo -! ENDDO -! do i=1,im -! PWATo(i) = PWATo(i)*(1.E3/grav) -! enddo -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! -! print *,' prsi=',prsi(ipr,:) -! print *,' prsl=',prsl(ipr,:) -! print *,' del=',del(ipr,:) -! print *,' phii=',phii(ipr,:) -! print *,' phil=',phil(ipr,:) -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! For pry version - do i=1,im - cld1d(i) = 0. - levshc(i) = 0 - enddo - ud_mf = 0.0 - dd_mf = 0.0 - dt_mf = 0.0 - do k=2,levs - do i=1,im - if (prsi(i,1)-prsi(i,k) .le. dpshc(i)) levshc(i) = k - enddo - enddo - levshcm = 1 - do i=1,im - levshcm = max(levshcm, levshc(i)) - enddo - if (mstrat) then - levshcm = max(levshcm, levs/2) - else - levshcm = min(levshcm, levs/2) - endif -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! FRAIN=FACTOR FOR CENTERED DIFFERENCE SCHEME CORRECTION OF RAIN AMOUNT. -! - FRAIN = DTF/DTP - if(skip_cu_physics)then - ktop(1) = cutop - kbot(1) = cubot - rain1(1)= dtp*bengsh(1) - endif -! if(bengsh(1).gt.0.)write(6,*)'cubot,cutop,raincv = ', -! 1 cubot(1),cutop(1),bengsh(1) -! if(bengsh(1).gt.0.)write(6,*)'kbot,ktop,rain1,dtf,dtp= ', -! 1 kbot(1),ktop(1),rain1(1),dtf,dtp - - do i=1,im - SOILTYP(i) = INT(STYPE(i)+.5) - SIGMAF(i) = MAX(VFRAC(i),0.01) -! SIGMAF(i) = MAX(VFRAC(i),.3) - if (lsm == 0) SIGMAF(i) = 0.5 + VFRAC(i) * 0.5 - VEGTYPE(i) = INT(VTYPE(i)+.5) - SLOPETYP(i) = INT(SLOPE(i)+.5) !! Clu [+1L]: slope -> slopetyp -! fm1(i) = ffmm(i) -! fh1(i) = ffhh(i) -! ustar1(i) = uustar(i) - IF(SLMSK(i).EQ.2.) THEN - SOILTYP(i) = 9 - VEGTYPE(i) = 13 - SLOPETYP(i) = 9 !! Clu [+1L]: QA(slopetyp) - ENDIF - enddo -!sela if(vegtype.eq.0 )print*,' vegtyp ilon ilat =',vegtype, ilon,ilat -! -! TRANSFER SOIL MOISTURE AND TEMPERATURE FROM GLOBAL TO LOCAL VARIABLES -! - DO K = 1, LSOIL - do i=1,im - SMSOIL(i,K) = SMC(i,k) - STSOIL(i,K) = STC(i,k) - SLSOIL(i,K) = SLC(i,k) !! Clu [+1L]: slc -> slsoil - enddo - ENDDO -! -!c-- XW: FOR SEA-ICE Nov04 -! -! TRANSFER ICE THICKNESS & CONCENTRATION FROM GLOBAL TO LOCAL VARIABLES -! - do i=1,im - ZICE(i) = HICE(i) - CICE(i) = FICE(i) - TICE(i) = TISFC(i) - enddo -!c-- XW: END SEA-ICE -! - do k=1,levs - do i=1,im - dudt(i,k) = 0. - dvdt(i,k) = 0. - dtdt(i,k) = 0. - enddo - enddo - do n=1,ntrac - do k=1,levs - do i=1,im - dqdt(i,k,n) = 0. ! dqdt may be dimensioned (levs,ntrac) - enddo - enddo - enddo - do i=1,im - RCL(i) = RCS2(i) - RCS(i) = SQRT(RCL(i)) - psurf(i) = pgr(i) - work1(i) = prsik(i,1) / prslk(i,1) -! garea(i) = rerth * rerth * (pi+pi)*pi*coslat(i)/(nlons(i)*latg) - tem1 = rerth * (pi+pi)*coslat(i)/nlons(i) - tem2 = rerth * pi/latg - garea(i) = tem1 * tem2 - dlength(i) = sqrt(tem1*tem1+tem2*tem2) - enddo - if(lssav) then - do i=1,im - PSMEAN(i) = PSMEAN(i) + PGR(i)*DTF - enddo - endif -! -! INITIALIZE DTDT WITH HEATING RATE FROM DCYC2 -! -! if(lprnt) then -! do ipr=1,im -! print *,' before DCYC2: IM=',IM,' LSOIL=',LSOIL,' levs=',levs -! &,' sde=',sdec,' cdec=',cdec,' tsea=',tsea(ipr),' ipr=',ipr -! &,' lat=',lat,' me=',me,' kdt=',kdt -! &,' sfcdlw=',sfcdlw(ipr),' sfcnsw=',sfcnsw(ipr) -! print *,' hlw=',hlw(ipr,:),' me=',me,' lat=',lat,xlon(ipr) -! print *,' swh=',swh(ipr,:),' me=',me,' lat=',lat,xlon(ipr) -! enddo -! endif -! -! - if(pre_rad)then - CALL DCYC2t3_pre_rad(IX,IM,LEVS,SOLHR,SLAG, - & SINLAT,COSLAT,SDEC,CDEC, - & XLON,COSZEN,SFCDLW,SFCNSW,TGRS(1,1), - & SFCDSW,DSWSFC, ! FOR SEA-ICE - XW Nov04 - & TSEA,TGRS(1,1),SWH,HLW, -!yth mar/08 add output xcosz -! & DLWSF1,ULWSF1,radsl,DTDT,xmu) - & DLWSF1,ULWSF1,radsl,DTDT,xmu,xcosz) - else - CALL DCYC2t3(IX,IM,LEVS,SOLHR,SLAG, - & SINLAT,COSLAT,SDEC,CDEC, - & XLON,COSZEN,SFCDLW,SFCNSW,TGRS(1,1), - & SFCDSW,DSWSFC, ! FOR SEA-ICE - XW Nov04 - & TSEA,TSFLW,SWH,HLW, -!yth mar/08 add output xcosz -! & DLWSF1,ULWSF1,radsl,DTDT,xmu) - & DLWSF1,ULWSF1,radsl,DTDT,xmu,xcosz) - endif -! print *,'SFCDSW,DSWSFC,radsl',SFCDSW,DSWSFC,radsl - -!-> Coupling insertion - if(lssav_cc_dummy) then - do i=1,im - XMU_cc_dummy(I) = MAX(0.,MIN(1.0,XMU(I)*COSZEN(I))) - DSW_cc_dummy(I) = DSWSFC(I) - DLW_cc_dummy(I) = DLWSF1(I) - DLWSFC_cc_dummy(I) = DLWSFC_cc_dummy(I) + DLWSF1(I) !*DTF (?) - ULWSFC_cc_dummy(I) = ULWSFC_cc_dummy(I) + ULWSF1(I) !*DTF (?) - SWSFC_cc_dummy(I) = SWSFC_cc_dummy(I) + radsl(I) + DLWSF1(I) !*DTF (?) - enddo -! -!********************************************************************* -!! > SWSFC_cc_dummy(1:IM)+radsl(1:IM)*CONVRAD_cc+DLWSF1(1:IM) -! <- see progtmr.f, subr. progtm (called below), and -! SUBROUTINE DCYC2T3 just called -! ** check signs here, esp. for SWR. -! - there are many pecularities here, the whole rad. -! stuff must be kept an eye on -! Signs for SWSFC_cc: sign for SWSFC_cc is intended positive -! upward, as for other fluxes. Downward LWR needs to be subtracted -! from radsl*const, where the downward LWR is considered positive -! upward. Since DLWSF1 is downward LWR positive downward, -! DLWSF1 must be added rather than subtracted. Similarly (see -! progtmr.f), radsl must be taken with +. -! > SWSFC_cc_dummy(1:IM)+radsl(1:IM)+DLWSF1(1:IM) -!********************************************************************* - end if -!<- Coupling insertion - - - if(lssav)then - -!yth mar/08 compute sundhine duration time that is defined as the length -! of time (in mdl output interval) that solar radiation falling -! on a plane perpendicular to the direction of the sun >= 120 w/m2 - - do i = 1, im - if ( xcosz(i) >= 0.0001 ) then ! zenth angle > 89.994 deg - tem1 = dswsfc(i) / xcosz(i) - if ( tem1 >= 120.0 ) then - suntim(i) = suntim(i) + dtf - endif - endif - enddo -!yth end suntim - - do i=1,im - DLWSFC(i) = DLWSFC(i) + DLWSF1(i)*DTF - ULWSFC(i) = ULWSFC(i) + ULWSF1(i)*DTF - enddo - IF (LDIAG3D) THEN - DO K=1,LEVS - do i=1,im - DT3DT(i,k,1) = DT3DT(i,k,1) + HLW(i,K)*DTF - DT3DT(i,k,2) = DT3DT(i,k,2) + SWH(i,K)*DTF*xmu(i) - enddo - ENDDO - ENDIF - endif -! -! - do i=1,im - kcnv(i) = 0 - kinver(i) = levs - invrsn(i) = .false. - tx1(i) = 0.0 - tx2(i) = 10.0 - ctei_r(i) = 10.0 - enddo -! ctei_rm = 0.20 -! ctei_rm = 0.25 -! ctei_rm = 0.50 -! ctei_rm = 0.70 - do k=1,levs/2 - do i=1,im - if (prsi(i,1)-prsi(i,k+1) .lt. 0.35*prsi(i,1) - & .and. (.not. invrsn(i))) then - tem = (TGRS(i,K+1) - TGRS(i,K)) / (prsl(i,k) - prsl(i,k+1)) -! if (tem .gt. 0.02 .and. tx1(i) .lt. 0.0) then -! if (tem .gt. 0.20 .and. tx1(i) .lt. 0.0) then -!!!! if (tem > 0.10 .and. (tx1(i) < 0.0 .or. tx2(i) < 0.0)) then -! if (tem .gt. 0.05 .and. tx1(i) .lt. 0.0) then - if (tem .gt. 0.025 .and. tx1(i) .lt. 0.0) then - invrsn(i) = .true. -! - if (qgrs(i,k,1) .ne. qgrs(i,k+1,1) .and. - & .not. sashal) then - tem1 = (1.0 + hocp*max(qgrs(i,k+1,1),qmin)/tgrs(i,k+1)) - tem2 = (1.0 + hocp*max(qgrs(i,k,1),qmin)/tgrs(i,k)) - tem1 = tem1 * tgrs(i,k+1) / prslk(i,k+1) - & - tem2 * tgrs(i,k) / prslk(i,k) -! (Cp/L)(delthetae)/(deltotwater) < 0.7 - ctei_r(i) = (1.0/hocp)*tem1/(qgrs(i,k+1,1)-qgrs(i,k,1) - & + qgrs(i,k+1,ntcw)-qgrs(i,k,ntcw)) - else - ctei_r(i) = 10 - endif - kinver(i) = k -!!!! kinver(i) = k + 1 - endif - tx2(i) = tx1(i) - tx1(i) = tem - endif - enddo - enddo - -! ipr = 1 -! if(lprnt) then -! print *,' before PROGTM: IM=',IM,' LSOIL=',LSOIL -! &,' nvdiff=',nvdiff,' radsl=',radsl(ipr),' dlwsf1=',dlwsf1(ipr) -! &,' dlwsf1=',dlwsf1(ipr),' tsea2=',tsea(ipr) -! &,' ipr=',ipr,' me=',me,' lat=',lat,' xlon=',xlon(ipr) -! &,' kdt=',kdt -! print *,' dtdth=',dtdt(ipr,:),' kdt=',kdt -! endif -! phy_f2d(:,num_p2d) = 0.0 ! disable downdraft effect on evap -! -Clu [-11L/+34L]: Revision starts here ................................... -Clu CALL PROGTM(IM,LSOIL,PGR,UGRS,VGRS,TGRS,QGRS, -Clu & SHELEG,TSEA,QSS, -Clu & SMSOIL,STSOIL,EVAPC,SOILTYP,SIGMAF, -Clu & vegtype,CANOPY, -Clu & dlwsf1, -Clu & radsl,SNOWMT,dtf ,ZORL,TG3, -Clu & GFLX,F10M,U10M,V10M,T2M,Q2M,ZSOIL, -Clu & CD,CDQ,RB,RHSCNPY,RHSMC,AI,BI,CCI, -Clu & RCL,PRSL(1,1),work1,SLMSK, -Clu & DRAIN,EVAP,HFLX,STRESS,EP1D,ffmm,ffhh, -Clu & uustar,WIND,phy_f2d(1,num_p2d)) - -Clu_q2m [+22L]: print selected variables -! do i=1,im -! wrk1 = xlon(i) * 57.29578 -! if (wrk1 .ge. 180.0) wrk1 = wrk1 - 360.0 -! wrk2 = xlat(i) * 57.29578 -! lprnt = abs(wrk1+96.5) .lt. 0.5 -! & .and. abs(wrk2-39.1) .lt. 0.5 -! & .and. me .eq. 12 -! if(lprnt) then -! write(221) LSOIL,PGR(i),UGRS(i,1),VGRS(i,1), -! & TGRS(i,1),QGRS(i,1,1), -! & SHELEG(i),TSEA(i),QSS(i), -! & (SMSOIL(i,k),k=1,LSOIL),(STSOIL(i,k),k=1,LSOIL), -! & (SLSOIL(i,k),k=1,LSOIL),EVAPC(i),SOILTYP(i),SIGMAF(I), -! & vegtype(i),CANOPY(i),dlwsf1(i), -! & radsl(i),dtf ,ZORL(i), -! & TG3(i),GFLX(i),U10M(i), -! & V10M(i),T2M(i),Q2M(i),CD(i),CDQ(i), -! & RCL(i),PRSL(1,1),work1(i),SLMSK(i), -! + DRAIN(i),EVAP(i),HFLX(i),EP1D(i),ffmm(i),ffhh(i), -! & uustar(i),WIND(i) -! endif -! enddo - -Clu_q2m_iter [+5L]: initialize flag_guess, flag_iter, tsurf - do i=1, im - tsurf(i) = tsea(i) - flag_guess(i) = .False. - flag_iter(i) = .True. - drain(i) = 0.0 - ep1d(i) = 0.0 - runof(i) = 0.0 - hflx(i) = 0.0 - evap(i) = 0.0 -! - evbs(i) = 0.0 - evcw(i) = 0.0 - trans(i) = 0.0 - sbsno(i) = 0.0 - snowc(i) = 0.0 - snohf(i) = 0.0 - enddo - -Clu_q2m_iter [+2L]: add iter-loop over (sfc_diff,sfc_drv,sfc_ocean,sfc_sice) - do iter = 1, 2 !!!!! <---- Clu_q2m_iter -! -!** surface exchange coefficients -! - CALL SFC_DIFF(IM,PGR,UGRS,VGRS,TGRS,QGRS, - & TSEA,ZORL,CD,CDQ,RB, - & RCL,PRSL(1,1),work1,SLMSK, - & STRESS,ffmm,ffhh, -Clu_q2m_iter [-1L/+2L]: add tsurf, flag_iter -!* & uustar,WIND,phy_f2d(1,num_p2d),fm10,fh2) - + uustar,WIND,phy_f2d(1,num_p2d),fm10,fh2, - + tsurf, flag_iter) - -! if (lprnt) print *,' cdq=',cdq(ipr),' iter=',iter -! &,' wind=',wind(ipr),'phy_f2d=',phy_f2d(ipr,num_p2d),' ugrs=' -! &,ugrs(ipr,1),' vgrs=',vgrs(ipr,1) - -Clu_q2m_iter [+4L]: update flag_guess - do i=1, im - if((iter.eq.1) .and. (wind(i).lt.2.)) - + flag_guess(i) = .True. - enddo - -! -!** surface energy balance over ocean -! - - if ( nsst_active ) then - - do i=1, im - if ( SLMSK(i) .eq. 0. ) then - tseal(i) = tsea(i) + oro(i) * rlapse - Tref(i) = TSEAL(i) - dt_warm(i) + dt_cool(i) - endif - enddo - -! if (lprnt) print *,' tseaz1=',tsea(ipr),' tref=',tref(ipr), -! &' dt_cool=',dt_cool(ipr),' dt_warm=',dt_warm(ipr) -! &,' tgrs=',tgrs(ipr,1),' prsl=',prsl(ipr,1) -! &,' work1=',work1(ipr),' kdt=',kdt - - CALL SFC_NSSTAC(IM,LSOIL,PGR,UGRS,VGRS,TGRS,QGRS, - & TSEAL,QSS,EVAPC,GFLX,CD,CDQ, - & RCL,PRSL(1,1),work1,SLMSK, - & xlon,sinlat,stress,dlwsf1,radsl,tprcp,dtf,kdt, - ! input - & ifd,time_old,time_ins,I_Sw,I_Q,I_Qrain, - & I_M,I_Tau,I_Sw_Zw,I_Q_Ts,I_M_Ts, - ! inout - & Tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d, - ! inout - & CMM,CHH, - & EVAP,HFLX,EP1D,phy_f2d(1,num_p2d),flag_iter, - & lprnt, ipr) - -! if (lprnt) print *,' tseaz2=',tseal(ipr),' tref=',tref(ipr), -! &' dt_cool=',dt_cool(ipr),' dt_warm=',dt_warm(ipr),' kdt=',kdt - - do i=1, im - if ( SLMSK(i) .eq. 0. ) then -! TSEA(i) = Tref(i) + dt_warm(i) - dt_cool(i) -! & - oro(i) * rlapse - TSEA(i) = TSEAL(i) - oro(i) * rlapse - endif - enddo -! if (lprnt) print *,' tseaz2=',tsea(ipr),' tref=',tref(ipr), -! &' dt_cool=',dt_cool(ipr),' dt_warm=',dt_warm(ipr),' kdt=',kdt - - else - - CALL SFC_OCEAN(IM,LSOIL,PGR,UGRS,VGRS,TGRS,QGRS, - & TSEA,QSS,EVAPC,GFLX,CD,CDQ, - & RCL,PRSL(1,1),work1,SLMSK, - & CMM,CHH, - & EVAP,HFLX,EP1D,phy_f2d(1,num_p2d),flag_iter) - endif - -! if (lprnt) print *,' sfalb=',sfalb(ipr),' ipr=',ipr -! &,' sheleg=',sheleg(ipr),' snwdph=',snwdph(ipr) -! &,' tprcp=',tprcp(ipr),' kdt=',kdt,' iter=',iter - -! -!** surface energy balance over land -! - if (lsm == 1) then ! NOAH LSM CALL - CALL SFC_DRV(IM,LSOIL,PGR,UGRS,VGRS,TGRS,QGRS, - & SHELEG,SNCOVR,SNWDPH,TSEA,QSS,TPRCP,SRFLAG, - & SMSOIL,STSOIL,SLSOIL,EVAPC,SOILTYP,SIGMAF, - & vegtype,CANOPY,dlwsf1,DSWSFC, - & radsl,dtf,TG3,GFLX,CD,CDQ, - & RCL,PRSL(1,1),work1,SLMSK, - & DRAIN,EVAP,HFLX,EP1D,phy_f2d(1,num_p2d), -Clu_q2m_iter [-1L/+2L]: add tsurf, flag_iter, flag_guess -!* + RUNOF,SLOPETYP,SHDMIN,SHDMAX,SNOALB,SFALB) - + RUNOF,SLOPETYP,SHDMIN,SHDMAX,SNOALB,SFALB, -Cwei added 10/24/2006 - + CMM,CHH,ZLVL,EVBS,EVCW,TRANS,SBSNO, - + SNOWC,SOILM,SNOHF,SMCWLT2,SMCREF2, - + tsurf, flag_iter, flag_guess) - else ! OSU LSM CALL - CALL SFC_LAND(IM,LSOIL,PGR,UGRS,VGRS,TGRS,QGRS, - & SHELEG,TSEA,QSS,TPRCP,SRFLAG, - & SMSOIL,STSOIL,EVAPC,SOILTYP,SIGMAF, - & vegtype,CANOPY,dlwsf1, - & radsl,SNOWMT,dtf,ZORL,TG3, - & GFLX,ZSOIL, - & CD,CDQ,RHSCNPY,RHSMC,AI,BI,CCI, - & RCL,PRSL(1,1),work1,SLMSK, - & DRAIN,EVAP,HFLX,EP1D,phy_f2d(1,num_p2d), -Cwei added 10/24/2006 - + CMM,CHH,ZLVL,EVBS,EVCW,TRANS,SBSNO, - + SNOWC,SOILM,SNOHF,SMCWLT2,SMCREF2, - & tsurf,flag_iter, flag_guess) - endif -! -! if (lprnt) print *,' tseabeficemodel =',tsea(ipr),' me=',me -! &,' kdt=',kdt -! -!** surface energy balance over seaice -! -!<-- cpl insertion - CALL SFC_SICE(IM,LSOIL,PGR,UGRS,VGRS,TGRS,QGRS, - & ZICE,CICE,TICE,DSWSFC, ! FOR SEA-ICE - XW Nov04 - & SHELEG,SNWDPH,TSEA,QSS,TPRCP,SRFLAG,STSOIL,EVAPC, - & dlwsf1,radsl,SNOWMT,dtf,GFLX,CD,CDQ, - & RCL,PRSL(1,1),work1,SLMSK, -Cwei added 10/24/2006 - + CMM,CHH,ZLVL, -Clu_q2m_iter [-1L/+1L]: add flag_iter -!* & EVAP,HFLX,EP1D,phy_f2d(1,num_p2d)) - + EVAP,HFLX,EP1D,phy_f2d(1,num_p2d),flag_iter, - & mom4ice,lsm) - -Clu_q2m_iter [+7L]: update flag_iter and flag_guess - do i=1, im - flag_iter(i) = .False. - flag_guess(i) = .False. - if((slmsk(i) .eq. 1.) .and. (iter .eq. 1)) then -!!!! if((slmsk(i) < 1.1) .and. (iter .eq. 1)) then - if(wind(i).lt.2.) flag_iter(i) = .True. -! elseif (slmsk(i) == 0. .and. iter == 1 .and. nsst_active) then -! flag_iter(i) = .True. - endif - enddo - enddo !!!!! <---- Clu_q2m_iter -Cwei added 10/24/2006 - do i=1,im - epi(i) = ep1d(i) - dlwsfci(i) = dlwsf1(i) - ulwsfci(i) = ulwsf1(i) - uswsfci(i) = sfcnsw(i)*xmu(i) + dswsfc(i) - dswsfci(i) = dswsfc(i) - gfluxi(i) = gflx(i) - t1(i) = tgrs(i,1) - q1(i) = qgrs(i,1,1) - u1(i) = ugrs(i,1) - v1(i) = vgrs(i,1) - enddo - - if (lsm == 0) then ! OSU LSM CALL - do i=1,im - SNCOVR(i) = 0.0 - if (SHELEG(i) > 0.0) SNCOVR(i) = 1.0 - enddo - endif - -! -!** update near surface fields -! - CALL SFC_DIAG(IM,LSOIL,PGR,UGRS,VGRS,TGRS,QGRS, - & TSEA,QSS,F10M,U10M,V10M,T2M,Q2M,RCL,work1,SLMSK, - & EVAP,ffmm,ffhh,fm10,fh2) -! -Clu_q2m [+22L]: print selected variables -! do i=1,im -! wrk1 = xlon(i) * 57.29578 -! if (wrk1 .ge. 180.0) wrk1 = wrk1 - 360.0 -! wrk2 = xlat(i) * 57.29578 -! lprnt = abs(wrk1+96.5) .lt. 0.5 -! & .and. abs(wrk2-39.1) .lt. 0.5 -! & .and. me .eq. 12 -! if(lprnt) then -! write(222) LSOIL,PGR(i),UGRS(i,1),VGRS(i,1), -! & TGRS(i,1),QGRS(i,1,1), -! & SHELEG(i),TSEA(i),QSS(i), -! & (SMSOIL(i,k),k=1,LSOIL),(STSOIL(i,k),k=1,LSOIL), -! & (SLSOIL(i,k),k=1,LSOIL),EVAPC(i),SOILTYP(i),SIGMAF(I), -! & vegtype(i),CANOPY(i),dlwsf1(i), -! & radsl(i),dtf ,ZORL(i), -! & TG3(i),GFLX(i),U10M(i), -! & V10M(i),T2M(i),Q2M(i),CD(i),CDQ(i), -! & RCL(i),PRSL(1,1),work1(i),SLMSK(i), -! + DRAIN(i),EVAP(i),HFLX(i),EP1D(i),ffmm(i),ffhh(i), -! & uustar(i),WIND(i) -! endif -! enddo -Clu [-11L/+34L]: Revision ends here ..................................... -! -! if(lprnt) then -! print *,' hflx=',hflx(ipr) -! print *,' evap=',evap(ipr) -! print *,' stress=',stress(ipr) -! endif -! - do i=1,im - phy_f2d(i,num_p2d) = 0.0 - enddo - -! if (lprnt) print *,' tseaim=',tsea(ipr),' me=',me,' kdt=',kdt -! - if(lssav)then - do i=1,im - GFLUX(i) = GFLUX(i) + GFLX(i)*DTF -Cwei added 10/24/2006 - EVBSA(I) = EVBSA(I) + EVBS(i)*DTF - EVCWA(I) = EVCWA(I) + EVCW(i)*DTF - TRANSA(I) = TRANSA(I) + TRANS(i)*DTF - SBSNOA(I) = SBSNOA(I) + SBSNO(i)*DTF - SNOWCA(I) = SNOWCA(I) + SNOWC(i)*DTF - SNOHFA(I) = SNOHFA(I) + SNOHF(i)*DTF - - TMPMAX(i) = MAX(TMPMAX(i),T2M(i)) - TMPMIN(i) = MIN(TMPMIN(i),T2M(i)) -!jwang [+2L] add SPFHMIN & SPFHMAX - SPFHMAX(i) = MAX(SPFHMAX(i),Q2M(i)) - SPFHMIN(i) = MIN(SPFHMIN(i),Q2M(i)) -! - EP(i) = EP(i) + EP1D(i) * DTF -! -!hchuang code change 11/12/2007 [+6] -!hchuang oro is passin variable not derived in this routine - gtmp2m(i) = gtmp2m(i) + t2m(i) * DTF - gu10m(i) = gu10m(i) + u10m(i) * DTF - gv10m(i) = gv10m(i) + v10m(i) * DTF - gustar(i) = gustar(i) + uustar(i) * DTF - gzorl(i) = gzorl(i) + zorl(i) * DTF - goro(i) = goro(i) + slmsk(i) * DTF - -CWei move to the place after calling progt2 -Clu [+3L]: compute total runoff -! TOTAL RUNOFF IS COMPOSED OF DRAINAGE INTO WATER TABLE AND -! RUNOFF AT THE SURFACE AND IS ACCUMULATED IN UNIT OF METERS -! RUNOFF(i) = RUNOFF(i) + (DRAIN(i)+RUNOF(i)) * DTF / 1000.0 - -! uustar(i) = ustar1(i) ! should be under lsfwd -! ffmm(i) = fm1(i) ! should be under lsfwd -! ffhh(i) = fh1(i) ! should be under lsfwd - enddo - endif -csela the following is the correct code, the above duplicates oper. code. -csela if(lsfwd)then -csela uustar(ilon,ilat)=ustar1 -csela ffmm(ilon,ilat)=fm1 -csela ffhh(ilon,ilat)=fh1 -csela endif -! -Clu [+11L]: update smc, stc, slc -! -! RETURN UPDATED SMSOIL AND STSOIL TO GLOBAL ARRAYS -! -!Wei move to the place after calling progt2 -! DO K = 1, LSOIL -! do i=1,im -! SMC(i,k) = SMSOIL(i,K) -! STC(i,k) = STSOIL(i,K) -! SLC(i,k) = SLSOIL(i,K) -! enddo -! ENDDO -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Commented by Moorthi on 20050505 -! - do i=1,im -! -! COMPUTE COEFFICIENT OF EVAPORATION IN EVAPC -! - IF (EVAPC(i) .GT. 1.0E0) EVAPC(i) = 1.0E0 -! -! OVER SNOW COVER OR ICE OR SEA, COEF OF EVAP =1.0E0 -! - IF((SHELEG(i).GT.0.) .OR. (SLMSK(i).NE.1.0)) EVAPC(i) = 1.0E0 - enddo -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! VERTICAL DIFFUSION -! -! if (lprnt) print *,' tsea3=',tsea(ipr),' slmsk=',slmsk(ipr) -! &,' kdt=',kdt,' evap=',evap(ipr) -! if (lprnt) print *,' dtdtb=',dtdt(ipr,:) -! - do i=1,im - if (slmsk(i) .eq. 0) then - oro_land(i) = 0.0 - else - oro_land(i) = oro(i) - endif - enddo - if (OLD_MONIN) then - if (mstrat) then - CALL MONINP1(IX,IM,LEVS,nvdiff,DVDT,DUDT,DTDT,DQDT, - & UGRS,VGRS,TGRS,QGRS, - & prsik(1,1),RB,ffmm,ffhh,TSEA,QSS,HFLX,EVAP,STRESS,WIND,KPBL, - & PRSI,DEL,PRSL,PRSLK,PHII,PHIL,RCL,dtp, - & DUSFC1,DVSFC1,DTSFC1,DQSFC1,HPBL,GAMT,GAMQ,DKT, - & kinver, oro_land) - else - CALL MONINP(IX,IM,LEVS,nvdiff,DVDT,DUDT,DTDT,DQDT, - & UGRS,VGRS,TGRS,QGRS, - & prsik(1,1),RB,ffmm,ffhh,TSEA,QSS,HFLX,EVAP,STRESS,WIND,KPBL, - & PRSI,DEL,PRSL,PRSLK,PHII,PHIL,RCL,dtp, - & DUSFC1,DVSFC1,DTSFC1,DQSFC1,HPBL,GAMT,GAMQ,DKT) - endif - ELSE -! if (mstrat) then -! CALL MONINQ1(IX,IM,LEVS,nvdiff,DVDT,DUDT,DTDT,DQDT, -! & UGRS,VGRS,TGRS,QGRS,swh,hlw,xmu, -! & prsik(1,1),RB,ffmm,ffhh,TSEA,QSS,HFLX,EVAP,STRESS,WIND,KPBL, -! & PRSI,DEL,PRSL,PRSLK,PHII,PHIL,RCS,dtp, -! & DUSFC1,DVSFC1,DTSFC1,DQSFC1,HPBL,GAMT,GAMQ,DKT, -! & kinver) -! else - CALL MONINQ(IX,IM,LEVS,nvdiff,DVDT,DUDT,DTDT,DQDT, - & UGRS,VGRS,TGRS,QGRS,swh,hlw,xmu, - & prsik(1,1),RB,ffmm,ffhh,TSEA,QSS,HFLX,EVAP,STRESS,WIND,KPBL, - & PRSI,DEL,PRSL,PRSLK,PHII,PHIL,RCS,dtp, - & DUSFC1,DVSFC1,DTSFC1,DQSFC1,HPBL,GAMT,GAMQ,DKT) -! endif - ENDIF -! -! if (ntoz .gt. 0) dqdt(:,:,ntoz) = 0.0 -! -! if (lprnt) then -! print *,' dusfc1=',dusfc1(ipr) -! print *,' dtsfc1=',dtsfc1(ipr) -! print *,' dqsfc1=',dqsfc1(ipr) -! print *,' dtdt=',dtdt(ipr,:) -! print *,' dudtm=',dudt(ipr,:) -! endif - -!-> Coupling insertion - if(lssav_cc_dummy) then - DUSFC_cc_dummy(1:IM)=DUSFC_cc_dummy(1:IM)+DUSFC1 !*DTF <-na h.(?) - DVSFC_cc_dummy(1:IM)=DVSFC_cc_dummy(1:IM)+DVSFC1 !*DTF <-na h.(?) - DTSFC_cc_dummy(1:IM)=DTSFC_cc_dummy(1:IM)+DTSFC1 !*DTF <-na h.(?) - DQSFC_cc_dummy(1:IM)=DQSFC_cc_dummy(1:IM)+DQSFC1 !*DTF <-na h.(?) - end if -!<- Coupling insertion - - if(lssav) then - do i=1,im - DUSFC(i) = DUSFC(i) + DUSFC1(i)*DTF - DVSFC(i) = DVSFC(i) + DVSFC1(i)*DTF - DTSFC(i) = DTSFC(i) + DTSFC1(i)*DTF - DQSFC(i) = DQSFC(i) + DQSFC1(i)*DTF - dtsfci(i) = dtsfc1(i) - dqsfci(i) = dqsfc1(i) -!hchuang code change 11/12/2007 [+1L] - gpblh(i) = gpblh(i) + hpbl(i) * DTF - enddo - IF (LDIAG3D) THEN - DO K=1,LEVS - do i=1,im - tem1 = rcs(i) * dtf - tem = dtdt(i,k) - (hlw(i,k)+swh(i,k)*xmu(i)) - DT3DT(i,k,3) = DT3DT(i,k,3) + tem*DTF - ! DQ3DT(i,k,1) = DQ3DT(i,k,1) + DQDT(i,K,1)*DTF - DU3DT(i,k,1) = DU3DT(i,k,1) + DUDT(i,K)*tem1 - DU3DT(i,k,2) = DU3DT(i,k,2) - DUDT(i,K)*tem1 - DV3DT(i,k,1) = DV3DT(i,k,1) + DVDT(i,K)*tem1 - DV3DT(i,k,2) = DV3DT(i,k,2) - DVDT(i,K)*tem1 - enddo - ENDDO - ENDIF - IF ( LDIAG3D .OR. LGGFS3D ) THEN - DO K=1,LEVS - do i=1,im - DQ3DT(i,k,1) = DQ3DT(i,k,1) + DQDT(i,K,1)*DTF - enddo - ENDDO - if (ntoz .gt. 0) then - DO K=1,LEVS - do i=1,im - DQ3DT(i,k,5) = DQ3DT(i,k,5) + DQDT(i,K,ntoz)*DTF - enddo - enddo - endif - ENDIF - IF ( LGGFS3D ) THEN - DO K=1,LEVS-1 - do i=1,im - dkh(I,K) = dkh(I,K) + dkt(I,K)*dtf - enddo - ENDDO - ENDIF - endif -! - if (NMTVR .eq. 6) then - do i=1,im - oc(i) = hprime(i,2) - enddo - do k = 1, 4 - do i=1,im - oa4(i,k) = hprime(i,k+2) - clx(i,k) = 0.0 - enddo - enddo - elseif(NMTVR .eq. 10) then - do i=1,im - oc(i) = hprime(i,2) - enddo - do k = 1, 4 - do i=1,im - oa4(i,k) = hprime(i,k+2) - clx(i,k) = hprime(i,k+6) - enddo - enddo -! --- lm mb (*j*) - elseif(NMTVR .eq. 14) then -! --- get the kim fields (until this is changed) - do i=1,im - oc(i) = hprime(i,2) - enddo - do k = 1, 4 - do i=1,im - oa4(i,k) = hprime(i,k+2) - clx(i,k) = hprime(i,k+6) - enddo - enddo - do i=1,im - theta(i) = hprime(i,11) - gamma(i) = hprime(i,12) - sigma(i) = hprime(i,13) - elvmax(i) = hprime(i,14) - enddo - else - oc = 0 - oa4 = 0 - clx = 0 - theta = 0 - gamma = 0 - sigma = 0 - elvmax = 0 - endif -!sela also replace lonf2 with cleff in this routine and compute -!sela cleff for all columns once before the loops on lat and lon -!sela do this in gloopb once and for all, better yet, in step1 -! -! -! Call (old) operational gravity-wave drag -! -! CALL GWDPS(lonf2,LEVS,DVDT,DUDT,UGRS,VGRS,TGRS,QGRS, -! & PGR,SI,DEL,CL,SL,slk,RCL,dtp,LAT,HPRIME(ilon,ilat,1), -! & oc,oa4,DUSFCG,DVSFCG) -! -! if(lssav) then -! DUGWD(ilon,ilat)=DUGWD(ilon,ilat)+DUSFCG*DTF -! DVGWD(ilon,ilat)=DVGWD(ilon,ilat)+DVSFCG*DTF -! IF (LDIAG3D) THEN -! work1 = rcs * dtf -! DO K=1,LEVS -! DU3DT(k,2,ilon,ilat) = DU3DT(k,2,ilon,ilat) + DUDT(K)*work1 -! DV3DT(k,2,ilon,ilat) = DV3DT(k,2,ilon,ilat) + DVDT(K)*work1 -! ENDDO -! ENDIF -! endif -!#ifdef NEWGWD -! -! Call New operational gravity-wave drag -! -! if(lprnt) then -! print *,' kdt=',kdt,' rcl=',rcl(ipr),' dtp=',dtp, -! &' pgr=',pgr(ipr),' kpbl=',kpbl,grav, CP, RD, RV, LONF -! print *,' ugrs=',ugrs -! print *,' vgrs=',vgrs -! print *,' tgrs=',tgrs(ipr,:) -! print *,' qgrs=',qgrs -! print *,' hprime=',hprime(ipr,:) -! print *,' oa4=',oa4,' oc=',oc,' clx=',clx -! print *,' si=',si -! print *,' prsl=',prsl(1,:),' me=',me -! print *,' del=',del(1,:),' me=',me -! print *,' prslk=',prslk(1,:),' me=',me -! print *,' prsik=',prsik(1,:),' me=',me -! endif -! - CALL GWDPS(IM, IX, IM, LEVS, DVDT, DUDT, - & UGRS, VGRS, TGRS, QGRS, - & KPBL, PRSI, DEL, PRSL, PRSLK, - & PHII, PHIL, RCL, DTP, -!! & PGR, KPBL, PRSI, DEL, PRSL, PRSLK, RCL, DTP, - & KDT, hprime(1,1), oc, oa4, clx, - & theta,sigma,gamma,elvmax,DUSFCG, DVSFCG, - & grav, CP, RD, RV, LONF, nmtvr, me, lprnt,ipr) -! -! if (lprnt) print *,' dudtg=',dudt(ipr,:) - if(lssav) then - do i=1,im - DUGWD(i) = DUGWD(i) + DUSFCG(i)*DTF - DVGWD(i) = DVGWD(i) + DVSFCG(i)*DTF - enddo -! if (lprnt) print *,' dugwd=',dugwd(ipr),' dusfcg=',dusfcg(ipr) -! if (lprnt) print *,' dvgwd=',dvgwd(ipr),' dvsfcg=',dvsfcg(ipr) - IF (LDIAG3D) THEN - DO K=1,LEVS - do i=1,im - tem = rcs(i) * dtf - DU3DT(i,k,2) = DU3DT(i,k,2) + DUDT(i,K)*tem - DV3DT(i,k,2) = DV3DT(i,k,2) + DVDT(i,K)*tem - enddo - ENDDO -! if(lprnt) then -! print *,' gwdu=',du3dt(:,:,2) -! endif - ENDIF - endif -!#endif -! - DO K=1,LEVS - do i=1,im - GT0(i,K) = TGRS(i,K) + DTDT(i,K) * DTp - GU0(i,K) = UGRS(i,K) + DUDT(i,K) * DTp - GV0(i,K) = VGRS(i,K) + DVDT(i,K) * DTp - enddo - enddo -! - DO N=1,ntrac - DO K=1,LEVS - do i=1,im - GQ0(i,K,N) = QGRS(i,K,N) + dqdt(i,k,n) * dtp - enddo - enddo - enddo -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! if (me .eq. 0) then -! sumq = 0.0 -! DO K=1,LEVS -! do i=1,im -! sumq = sumq + (dqdt(i,k,1)+dqdt(i,k,ntcw)) * del(i,k) -! enddo -! enddo -! sume = 0.0 -! do i=1,im -! sume = sume + dqsfc1(i) -! enddo -! sumq = sumq * 1000.0 / grav -! sume = sume / hvap -! print *,' after MON: sumq=',sumq,' sume=',sume, ' kdt=',kdt -! endif -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! -! OZONE PHYSICS -! - if(ntoz .gt. 0 .and. ntrac .ge. ntoz)then -!jbao CALL OZPHYS(IX, IM, LEVS, KO3, DTP, GQ0(1,1,ntoz), GQ0(1,1,ntoz) -!jbao &, GT0, poz, prsl, prdout, pl_coeff, DEL, LDIAG3D -!jbao &, LGGFS3D, dq3dt(1,1,6), me) -!hchuang code change [r1L] -! &, dq3dt(1,1,6), me) - endif -!jbao stop 22222 -! -! to side-step the ozone physics -! if(NTRAC .GE. 2) then -! do k = 1, LEVS -! GQ0(k,ntoz) = qgrs(k,ntoz) -! enddo -! endif -! -! if (lprnt) then -! print *,' levs=',levs,' jcap=',jcap,' dtp',dtp -! *,' slmsk=',slmsk(ilon,ilat),' rcs=',rcs,' kdt=',kdt -! print *,' xkt2=',xkt2,' ncld=',ncld,' iq=',iq,' lat=',lat -! print *,' pgr=',pgr -! print *,' del=',del(1,:) -! print *,' prsl=',prsl(1,:) -! print *,' prslk=',prslk(1,:) -! print *,' xkt2=',xkt2(ipr,1) -! print *,' GT0=',GT0(ipr,:) -! &,' kdt=',kdt,' xlon=',xlon(ipr),' xlat=',xlat(ipr) -! print *,' dtdt=',dtdt(ipr,:) -! print *,' gu0=',gu0(ipr,:) -! print *,' gv0=',gv0(ipr,:) -! print *,' gq0=',(gq0(ipr,k,1),k=1,levs) -! print *,' gq1=',(gq0(ipr,k,ntcw),k=1,levs) -! print *,' vvel=',vvel -! endif -! - IF (LDIAG3D) THEN - do k=1,levs - do i=1,im - dtdt(i,k) = GT0(i,k) -! dqdt(i,k,1) = gq0(i,k,1) - dudt(i,k) = GU0(i,k) - dvdt(i,k) = GV0(i,k) - enddo - enddo - elseif (cnvgwd) then - do k=1,levs - do i=1,im - dtdt(i,k) = GT0(i,k) - enddo - enddo - ENDIF - IF ( LDIAG3D .OR. LGGFS3D ) THEN - do k=1,levs - do i=1,im - dqdt(i,k,1) = gq0(i,k,1) - enddo - enddo - ENDIF -! - call GET_PHI(im,ix,levs,ntrac,gt0,gq0, - & prsi,prsik,prsl,prslk,phii,phil) -! -! -! if (lprnt) then -! print *,' phii2=',phii(ipr,:) -! print *,' phil2=',phil(ipr,:) -! endif -! - do k=1,levs - do i=1,im - CLW(i,k,1) = 0.0 - CLW(i,k,2) = -999.9 - enddo - enddo -! For convective tracer transport (while using RAS) - if (ras) then - if (tottracer > 0) then - if (ntoz > 0) then - CLW(:,:,3) = GQ0(:,:,ntoz) - if (tracers > 0) then - do n=1,tracers - CLW(:,:,3+n) = GQ0(:,:,n+trc_shft) - enddo - endif - else - do n=1,tracers - CLW(:,:,2+n) = GQ0(:,:,n+trc_shft) - enddo - endif - endif - endif -! - if(.not. skip_cu_physics)then - do i=1,im - ktop(i) = 1 - kbot(i) = levs - enddo - endif -! -! Calling precipitation processes -! - do i=1,im -!pry work1(i) = (log(1.0 / (rcs(i)*nlons(i))) - dxmin) * dxinv - work1(i) = (log(1.0 / (rcs(i)*nlons(i)*latg)) - dxmin) * dxinv -!jbao work1(i) = (log(coslat(i) / (nlons(i)*latg)) - dxmin) * dxinv - work1(i) = max(0.0, min(1.0,work1(i))) - work2(i) = 1.0 - work1(i) - enddo -! -! Calling convective parameterization -! - if (ntcw .gt. 0) then -! - do k=1,levs - do i=1,im - rhc(i,k) = rhbbot - (rhbbot-rhbtop) * (1.0-prslk(i,k)) - rhc(i,k) = rhc_max * work1(i) + rhc(i,k) * work2(i) - rhc(i,k) = max(0.0, min(1.0,rhc(i,k))) - enddo - enddo - if (num_p3d .eq. 3) then ! Call Brad Ferrier's Microphysics - do i=1,im - flgmin_l(i) = flgmin(1)*work1(i) + flgmin(2)*work2(i) - enddo -! -!*** ALGORITHM TO SEPARATE DIFFERENT HYDROMETEOR SPECIES -! - DO K=1,LEVS - do i=1,im - WC = GQ0(i,K,ntcw) - QI = 0. - QR = 0. - QW = 0. - F_ice = max(0.0, min(1.0, phy_f3d(I,K,1))) - F_rain = max(0.0, min(1.0, phy_f3d(I,K,2))) -! - QI = F_ice*WC - QW = WC-QI - IF (QW .GT. 0.0) THEN - QR = F_rain*QW - QW = QW-QR - ENDIF -! -! IF (F_ice .GE. 1.) THEN -! QI = WC -! ELSE IF (F_ice .LE. 0.) THEN -! QW = WC -! ELSE -! QI = F_ice*WC -! QW = WC-QI -! ENDIF -! -! IF (QW.GT.0. .AND. F_rain.GT.0.) THEN -! IF (F_rain .GE. 1.) THEN -! QR = QW -! QW = 0. -! ELSE -! QR = F_rain*QW -! QW = QW-QR -! ENDIF -! ENDIF -! - QR_col(I,K) = QR -! CLW(I,K) = QI + QW - CLW(I,K,1) = QI - CLW(I,K,2) = QW -! -! -!*** ARRAY TO TRACK FRACTION OF "CLOUD" IN THE FORM OF ICE -! -! IF (QI+QW .GT. EPSQ) THEN -! FC_ice(I,K) = QI / (QI+QW) -! ELSE -! FC_ice(I,K) = 0. -! ENDIF - - enddo - ENDDO - else - DO K=1,LEVS - do i=1,im - clw(i,K,1) = GQ0(i,K,ntcw) - enddo - ENDDO - endif - else - rhc(:,:) = 1.0 - endif -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! if (me .eq. 0) then -! sumq = 0.0 -! DO K=1,LEVS -! do i=1,im -! sumq = sumq - (gq0(i,k,1)+clw(i,k,1)+clw(i,k,2)) * del(i,k) -! enddo -! enddo -! endif -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! - IF (.NOT. skip_cu_physics) THEN - IF (.NOT. RAS ) THEN - if (.not. newsas) then - CALL SASCNV(IM,IX,LEVS,JCAP,dtp,DEL,PRSL,PGR,PHIL, - & CLW,GQ0,GT0,gu0,gv0,rcs,CLD1D, - & RAIN1,KBOT,KTOP,kcnv,SLMSK, - & VVEL,xkt2,ncld,ud_mf,dd_mf,dt_mf) -!hchuang code change 03/03/08 [r1L] add SAS modification of mass flux -! & VVEL,xkt2,ncld) - else - CALL SASCNVN(IM,IX,LEVS,JCAP,dtp,DEL,PRSL,PGR,PHIL, - & CLW,GQ0,GT0,gu0,gv0,rcs,CLD1D, - & RAIN1,KBOT,KTOP,kcnv,SLMSK, - & VVEL,ncld,ud_mf,dd_mf,dt_mf,sdiaga,sdiagb) -!hchuang code change 03/03/08 [r1L] add SAS modification of mass flux -! & VVEL,xkt2,ncld) - endif - -! if(lprnt) print *,' rain1=',rain1(ipr),' xkt2=',xkt2(ipr,1) - - ELSE - -! if(lprnt) print *,' calling RAS for kdt=',kdt,' me=',me -! &,' lprnt=',lprnt - - CALL RASCNV(IM, IX, LEVS, DTP, DTF, xkt2 -! &, GT0, GQ0, GU0, GV0, clw - &, GT0, GQ0, GU0, GV0, clw, tottracer - &, prsi, prsl, prsik, prslk, phil, phii - &, KPBL, CD, RAIN1, KBOT, KTOP, kcnv - &, phy_f2d(1,num_p2d), flipv, cb2mb - &, me, garea, lmh, ccwfac, nrcm, rhc - &, ud_mf, dd_mf, dt_mf, lprnt, ipr) -! &, me, 1, 1, garea, lprnt, ipr) -! -! do i=1,im -! if (tsea(i) .gt. 380.0 .or. tsea(i) .lt. 10) then -! print *,' tsea=', tsea(i),' i=',i,' lat=',lat, -! &' kdt=',kdt,' xlon=',xlon(i),' xlat=',xlat(i),' slmsk=', -! &slmsk(i),' me=',me -! stop -! endif -! enddo -! do k=1,levs -! do i=1,im -! if (gt0(i,k) .gt. 330.0 .or. gt0(i,k) .lt. 80) then -! print *,' gt0=', gt0(i,k),' i=',i,' k=',k,' lat=',lat, -! &' kdt=',kdt,' xlon=',xlon(i),' xlat=',xlat(i) -! stop -! endif -! if (gq0(i,k,1) .gt. 1.0 ) then -! print *,' gq0=', gq0(i,k,1),' i=',i,' k=',k,' lat=',lat, -! &' kdt=',kdt -! stop -! endif -! enddo -! enddo -! if(lprnt) print *,' returning from RAS for kdt=', kdt,' me=',me -! &,' lat=',lat -! - CLD1D = 0 -! -! Update the tracers due to convective transport -! - if (tottracer > 0) then - if (ntoz > 0) then ! For ozone - GQ0(:,:,ntoz) = clw(:,:,3) - if (tracers > 0) then ! For other tracers - do n=1,tracers - GQ0(:,:,n+trc_shft) = CLW(:,:,3+n) - enddo - endif - else - do n=1,tracers - GQ0(:,:,n+trc_shft) = CLW(:,:,2+n) - enddo - endif - endif - ENDIF - ENDIF !skip_cu_phys -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! if (me .eq. 0) then -! DO K=1,LEVS -! do i=1,im -! sumq = sumq + (gq0(i,k,1)+clw(i,k,1)+clw(i,k,2)) * del(i,k) -! enddo -! enddo -! sumr = 0.0 -! do i=1,im -! sumr = sumr + rain1(i) -! enddo -! sumq = sumq * 1000.0 / grav -! sumr = sumr *1000 -! print *,' after RAS: sumq=',sumq,' sumr=',sumr, ' kdt=',kdt -! endif -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! - if(lssav) then - do i=1,im - CLDWRK(i) = CLDWRK(i) + CLD1D(i) * DTF - enddo - IF (LDIAG3D) THEN - DO K=1,LEVS - do i=1,im - tem = rcs(i) * FRAIN - DT3DT(i,k,4) = DT3DT(i,k,4) + (GT0(i,k)-dtdt(i,k)) * FRAIN -! DQ3DT(i,k,2) = DQ3DT(i,k,2) + (gq0(i,k,1)-dqdt(i,k,1)) -! & * FRAIN - DU3DT(i,k,3) = DU3DT(i,k,3) + (GU0(i,k)-dudt(i,k)) * tem - DV3DT(i,k,3) = DV3DT(i,k,3) + (GV0(i,k)-dvdt(i,k)) * tem - enddo - ENDDO - ENDIF - IF ( LDIAG3D .OR. LGGFS3D ) THEN - DO K=1,LEVS - do i=1,im - DQ3DT(i,k,2) = DQ3DT(i,k,2) + (gq0(i,k,1)-dqdt(i,k,1)) - & * FRAIN - upd_mf(i,k) = upd_mf(i,k) + ud_mf(i,k) * FRAIN - dwn_mf(i,k) = dwn_mf(i,k) + dd_mf(i,k) * FRAIN - det_mf(i,k) = det_mf(i,k) + dt_mf(i,k) * FRAIN - enddo - ENDDO - ENDIF - endif -! - do i=1,im - RAINC(i) = FRAIN * RAIN1(i) - enddo - if(lssav) then - do i=1,im - BENGSH(i) = BENGSH(i) + RAINC(i) - enddo - endif -! -!************************************************************************ - if (cnvgwd) then ! call CONVECTIVE GRAVITY WAVE DRAG -! -!----------------------------------------------------------------------- -! Calculate Maximum Convective Heating Rate qmax [K/s] -! cuhr = Temperature change due to deep convection -!----------------------------------------------------------------------- - - do i=1,IM - qmax(i) = 0. - cumabs(i) = 0. - enddo - do k=1,LEVS - do i=1,IM -! cuhr(i,k) = (GT0(i,k)-DTDT(i,k)) / DTF - cuhr(i,k) = (GT0(i,k)-DTDT(i,k)) / DTP ! Moorthi - - cumchr(i,k) = 0. - GWDCU(i,k) = 0. - GWDCV(i,k) = 0. - DIAGN1(i,k) = 0. - DIAGN2(i,k) = 0. -! - if (k >= kbot(i) .and. k <= ktop(i)) then - qmax(i) = max(qmax(i),cuhr(i,k)) - cumabs(i) = cuhr(i,k) + cumabs(i) - endif - enddo - enddo - - do i=1,IM - do k=KBOT(i),KTOP(i) - do k1=KBOT(i),k - cumchr(i,k) = cuhr(i,k1) + cumchr(i,k) - enddo - cumchr(i,k) = cumchr(i,k) / cumabs(i) - enddo - enddo -! - if (lprnt) then - if (KBOT(ipr).le.KTOP(ipr)) then - write(*,*) 'KBOT <= KTOP for (lat,lon) = ', - & xlon(ipr)*57.29578,xlat(ipr)*57.29578 - write(*,*) 'kcnv KBOT KTOP QMAX DLENGTH ', - + kcnv(ipr),kbot(ipr),ktop(ipr),(86400.*qmax(ipr)),dlength(ipr) - write(*,9000) kdt - do k=KTOP(ipr),KBOT(ipr),-1 - write(*,9010) k,(86400.*cuhr(ipr,k)),(100.*cumchr(ipr,k)) - enddo - endif - - 9000 format(/,3x,'K',5x,'CUHR(K)',4x,'CUMCHR(K)',5x,'at KDT = ',i4,/) - 9010 format(2x,i2,2x,f8.2,5x,f6.0) -! -! print *,' Before GWDC in GBPHYS fhour ',fhour - if (fhour >= fhourpr) then - print *,' Before GWDC in GBPHYS start print' - write(*,*) 'FHOUR IX IM LEVS = ',fhour,ix,im,levs - print *,'dtp dtf RCS = ',dtp,dtf,RCS(ipr) - - write(*,9100) - k=LEVS+1 - write(*,9110) k,(10.*prsi(ipr,k)) - do k=LEVS,1,-1 - write(*,9120) k,(10.*prsl(ipr,k)),(10.*del(ipr,k)) - write(*,9110) k,(10.*prsi(ipr,k)) - enddo - - 9100 format(//,14x,'PRESSURE LEVELS',//, - +' ILEV',7x,'PRSI',8x,'PRSL',8x,'DELP',/) - 9110 format(i4,2x,f10.3) - 9120 format(i4,12x,2(2x,f10.3)) - write(*,9130) - do k=LEVS,1,-1 - write(*,9140) k,UGRS(ipr,k),GU0(ipr,k), - + VGRS(ipr,k),GV0(ipr,k), - + TGRS(ipr,k),GT0(ipr,k),DTDT(ipr,k), - + dudt(ipr,k),dvdt(ipr,k) - enddo - - 9130 format(//,10x,'Before GWDC in GBPHYS',//,' ILEV',6x, - +'UGRS',9x,'GU0',8x,'VGRS',9x,'GV0',8x, - +'TGRS',9x,'GT0',8x,'GT0B',8x,'DUDT',8x,'DVDT',/) - 9140 format(i4,9(2x,f10.3)) - - print *,' Before GWDC in GBPHYS end print' - - endif - endif - CALL GWDC(IM, IX, IM, LEVS, LAT, UGRS, VGRS, TGRS, QGRS, - & RCS, PRSL, PRSI, DEL, QMAX, CUMCHR, KTOP, KBOT, kcnv, - & GWDCU, GWDCV, grav, CP, RD, fv, dlength, - & lprnt, ipr, fhour, - & DUSFCG,DVSFCG,DIAGN1,DIAGN2) -! - if (lprnt) then - if (fhour.ge.fhourpr) then - print *,' After GWDC in GBPHYS start print' - write(*,9131) - do k=LEVS,1,-1 - write(*,9141) k,UGRS(ipr,k),GU0(ipr,k), - + VGRS(ipr,k),GV0(ipr,k), - + TGRS(ipr,k),GT0(ipr,k),DTDT(ipr,k), - + GWDCU(ipr,k),GWDCV(ipr,k) - enddo - - 9131 format(//,10x,'After GWDC in GBPHYS',//,' ILEV',6x, - +'UGRS',9x,'GU0',8x,'VGRS',9x,'GV0',8x, - +'TGRS',9x,'GT0',8x,'GT0B',7x,'GWDCU',7x,'GWDCV',/) - 9141 format(i4,9(2x,f10.3)) - print *,' After GWDC in GBPHYS end print' - endif - endif -! -!----------------------------------------------------------------------- -! Write out cloud top stress and wind tendencies -!----------------------------------------------------------------------- - - if(lssav) then - do i=1,im - DUGWD(i) = DUGWD(i) + DUSFCG(i)*DTF - DVGWD(i) = DVGWD(i) + DVSFCG(i)*DTF - enddo - IF (LDIAG3D) THEN - DO K=1,LEVS - do i=1,im - tem = rcs(i) * dtf - DU3DT(i,k,4) = DU3DT(i,k,4) + GWDCU(i,K)*tem - DV3DT(i,k,4) = DV3DT(i,k,4) + GWDCV(i,K)*tem -! DU3DT(i,k,2) = DU3DT(i,k,2) + DIAGN1(i,K)*tem -! DV3DT(i,k,2) = DV3DT(i,k,2) + DIAGN2(i,K)*tem - enddo - ENDDO - ENDIF - endif - -!----------------------------------------------------------------------- -! Update the wind components with GWDC tendencies -!----------------------------------------------------------------------- - - DO K=1,LEVS - do i=1,im - GU0(i,K) = GU0(i,K) + GWDCU(i,K) * DTP - GV0(i,K) = GV0(i,K) + GWDCV(i,K) * DTP - enddo - enddo -! - if (lprnt) then - if (fhour.ge.fhourpr) then - print *,' After Tendency GWDC in GBPHYS start print' - write(*,9132) - do k=LEVS,1,-1 - write(*,9142) k,UGRS(ipr,k),GU0(ipr,k),VGRS(ipr,k), - & GV0(ipr,k),TGRS(ipr,k),GT0(ipr,k),DTDT(ipr,k), - + GWDCU(ipr,k),GWDCV(ipr,k) - enddo - 9132 format(//,10x,'After Tendency GWDC in GBPHYS',//,' ILEV',6x, - +'UGRS',9x,'GU0',8x,'VGRS',9x,'GV0',8x, - +'TGRS',9x,'GT0',8x,'GT0B',7x,'GWDCU',7x,'GWDCV',/) - 9142 format(i4,9(2x,f10.3)) - print *,' After Tendency GWDC in GBPHYS end print' - endif - endif -! - endif ! END CONVECTIVE GRAVITY WAVE DRAG -!************************************************************************ -! -! - IF (LDIAG3D) THEN - do k=1,levs - do i=1,im - dtdt(i,k) = GT0(i,k) -! dqdt(i,k,1) = gq0(i,k,1) - enddo - enddo - ENDIF - IF ( LDIAG3D .OR. LGGFS3D ) THEN - do k=1,levs - do i=1,im - dqdt(i,k,1) = gq0(i,k,1) - enddo - enddo - ENDIF -! - if (.not. sashal) then - ud_mf = 0.0 - dt_mf = 0.0 -! if (lprnt) print *,' levshcm=',levshcm,' gt0sh=',gt0(ipr,:) - if (.not. mstrat) then - CALL SHALCVt3(IM,IX,LEVSHCM,dtp,DEL,PRSI,PRSL,PRSLK, - & kcnv,GQ0,GT0) ! for pry - else - CALL SHALCV(IM,IX,LEVSHCM,dtp,DEL,PRSI,PRSL,PRSLK,kcnv,GQ0,GT0 - &, levshc,phil,kinver,ctei_r,ctei_rm) -! &, DPSHC,phil,kinver) -! &, DPSHC,kinver) -! if (lprnt) print *,' levshcm=',levshcm,' gt0sha=',gt0(ipr,:) - endif -! - else - CALL SHALCNV(IM,IX,LEVS,JCAP,dtp,DEL,PRSL,PGR,PHIL, - & CLW,GQ0,GT0,gu0,gv0,rcs, - & RAIN1,KBOT,KTOP,kcnv,SLMSK, - & VVEL,ncld,HPBL,HFLX,EVAP,ud_mf,dt_mf) -! - do i=1,im - RAINCS(i) = FRAIN * RAIN1(i) - enddo - if(lssav) then - do i=1,im - BENGSH(i) = BENGSH(i) + RAINCS(i) - enddo - endif - do i=1,im - RAINC(i) = RAINC(i) + RAINCS(i) - enddo - if(lssav) then - do i=1,im - CLDWRK(i) = CLDWRK(i) + CLD1D(i) * DTF - enddo - endif - endif -! -! - if(lssav) then - IF (LDIAG3D) THEN - DO K=1,LEVS - do i=1,im - DT3DT(i,k,5) = DT3DT(i,k,5) + (GT0(i,k)-dtdt(i,k)) * FRAIN -! DQ3DT(i,k,3) = DQ3DT(i,k,3) + (gq0(i,k,1)-dqdt(i,k,1)) -! & * FRAIN - enddo - ENDDO - do k=1,levs - do i=1,im - dtdt(i,k) = GT0(i,k) -! dqdt(i,k,1) = gq0(i,k,1) - enddo - enddo - ENDIF - IF ( LDIAG3D .OR. LGGFS3D ) THEN - DO K=1,LEVS - do i=1,im - DQ3DT(i,k,3) = DQ3DT(i,k,3) + (gq0(i,k,1)-dqdt(i,k,1)) - & * FRAIN - upd_mf(i,k) = upd_mf(i,k) + ud_mf(i,k) * FRAIN - det_mf(i,k) = det_mf(i,k) + dt_mf(i,k) * FRAIN - enddo - ENDDO -! - do k=1,levs - do i=1,im - dqdt(i,k,1) = gq0(i,k,1) - enddo - enddo - ENDIF - endif -! -! - DO K=1,LEVS - do i=1,im - if (CLW(I,K,2) .le. -999.0) CLW(I,K,2) = 0.0 - enddo - ENDDO - if (ntcw .gt. 0) then - if (num_p3d .eq. 3) then ! Call Brad Ferrier's Microphysics -! -!*** EXTRACT CLOUD WATER & ICE FROM FC_ice -! - DO K=1,LEVS - do i=1,im -! QI = CLW(I,K)*FC_ice(I,K) -! QW = CLW(I,K) - QI -! - QI = CLW(I,K,1) - QW = CLW(I,K,2) -! -!*** ALGORITHM TO COMBINE DIFFERENT HYDROMETEOR SPECIES -! -! GQ0(i,K,ntcw) = MAX(EPSQ, QI+QW+QR_col(i,K)) - GQ0(i,K,ntcw) = QI + QW + QR_col(i,K) - IF (QI .LE. EPSQ) THEN - phy_f3d(I,K,1) = 0. - ELSE - phy_f3d(I,K,1) = QI/GQ0(i,K,ntcw) - ENDIF - IF (QR_col(I,K) .LE. EPSQ) THEN - phy_f3d(I,K,2) = 0. - ELSE - phy_f3d(I,K,2) = QR_col(I,K) / (QW+QR_col(I,K)) - ENDIF - enddo - ENDDO - else - DO K=1,LEVS - do i=1,im -! GQ0(i,K,ntcw) = CLW(i,K) + GQ0(i,K,ntcw) - GQ0(i,K,ntcw) = CLW(i,K,1) + clw(i,K,2) -! GQ0(i,K,ntcw) = CLW(i,K,1) ! for pry - enddo - ENDDO - endif - else - DO K=1,LEVS - do i=1,im - clw(i,K,1) = CLW(i,K,1) + clw(i,K,2) - enddo - ENDDO - - endif - -! - CALL CNVC90(CLSTP, IM, IX, RAINC, KBOT, KTOP, LEVS, PRSI, - & aCV, aCVB, aCVT, CV, CVB, CVT) -! -! - IF (NCLD .EQ. 0) THEN - CALL LRGSCL(IX,IM,LEVS,dtp,GT0,GQ0,PRSL,DEL,PRSLK,RAIN1,CLW) - ELSEIF (NCLD .EQ. 1) THEN -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! if (me .eq. 0) then -! sumq = 0.0 -! DO K=1,LEVS -! do i=1,im -! sumq = sumq - (gq0(i,k,1)+gq0(i,k,ntcw)) * del(i,k) -! enddo -! enddo -! endif -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! To call moist convective adjustment -! -! CALL MSTCNV(IM,IX,LEVS,DTP,GT0,GQ0,PRSL,DEL,PRSLK,RAIN1 -! &, lprnt,ipr) -! do i=1,im -! RAINC(i) = RAINC(i) + FRAIN * RAIN1(i) -! enddo -! if(lssav) then -! do i=1,im -! BENGSH(i) = BENGSH(i) + RAIN1(i) * FRAIN -! enddo -! IF (LDIAG3D) THEN -! DO K=1,LEVS -! do i=1,im -! DT3DT(i,k,4) = DT3DT(i,k,4) + (GT0(i,k)-dtdt(i,k)) -! & * FRAIN -! DQ3DT(i,k,2) = DQ3DT(i,k,2) + (gq0(i,k,1)-dqdt(i,k,1)) -! & * FRAIN -! enddo -! ENDDO -! ENDIF -! endif -! -! IF (LDIAG3D) THEN -! do k=1,levs -! do i=1,im -! dtdt(i,k) = GT0(i,k) -! dqdt(i,k,1) = gq0(i,k,1) -! enddo -! enddo -! ENDIF -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! if (me .eq. 0) then -! DO K=1,LEVS -! do i=1,im -! sumq = sumq + (gq0(i,k,1)+gq0(i,k,ntcw)) * del(i,k) -! enddo -! enddo -! sumr = 0.0 -! do i=1,im -! sumr = sumr + rain1(i) -! enddo -! sumq = sumq * 1000.0 / grav -! sumr = sumr *1000 -! print *,' after MCN: sumq=',sumq,' sumr=',sumr, ' kdt=',kdt -! endif -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! moist convective adjustment over -! -! - if (num_p3d .eq. 3) then ! Call Brad Ferrier's Microphysics -! - do i=1,im - xncw(i) = ncw(2) * work1(i) + ncw(1) * work2(i) - enddo - if (kdt .eq. 1 .and. abs(xlon(1)) .lt. 0.0001) - & print *,' xncw=',xncw(1),' rhc=',rhc(1,1) - &, ' work1=',work1(1),' work2=',work2(1),' flgmin=',flgmin_l(1) - &, ' lon=',xlon(1) * 57.29578,' lat=',lat,' me=',me -! &, ' lon=',xlon(1) * 57.29578,' lat=',xlat(1) * 57.29578 -! &,' kinver=',kinver(1) -! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! if (me .eq. 0) then -! sumq = 0.0 -! DO K=1,LEVS -! do i=1,im -! sumq = sumq - (gq0(i,k,1)+gq0(i,k,ntcw)) * del(i,k) -! enddo -! enddo -! endif -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! if (lprnt) print *,' ipr=',ipr,' gt0_gsmb=',gt0(ipr,:) -! &,' xlon=',xlon(ipr),' xlat=',xlat(ipr) - call GSMDRIVE(IM, IX, LEVS, DTP, PRSL, DEL - &, GT0, GQ0(1,1,1), GQ0(1,1,ntcw), slmsk - &, phy_f3d(1,1,1), phy_f3d(1,1,2) - &, phy_f3d(1,1,3), RAIN1, SR, grav - &, hvap, hsub, cp, rhc, xncw, flgmin_l - &, me, lprnt, ipr) -! &, hvap, hsub, cp, rhc, xncw, me, lprnt, ipr) -! -! if (lprnt) print *,' ipr=',ipr,' gt0_gsma=',gt0(ipr,:) -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! if (me .eq. 0) then -! DO K=1,LEVS -! do i=1,im -! sumq = sumq + (gq0(i,k,1)+gq0(i,k,ntcw)) * del(i,k) -! enddo -! enddo -! sumr = 0.0 -! do i=1,im -! sumr = sumr + rain1(i) -! enddo -! sumq = sumq * 1000.0 / grav -! sumr = sumr *1000 -! print *,' after GSM: sumq=',sumq,' sumr=',sumr, ' kdt=',kdt -! endif -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! - elseif (num_p3d .eq. 4) then ! Call Zhao/Carr/Sundqvist Microphysics -! -! The following commented by Moorthi on 11/01/2002 -! do k=1,levs/2 -! do i=1,im -!! if (k .le. kinver(i) .and. slmsk(i) .eq. 0.0) then -! if (k .le. kinver(i)) then -! rhc(i,k) = 0.85 -! endif -! enddo -! enddo -! if (me .eq. 0 .and. kdt .eq. 1 .and. ilon .eq. 1) -! & print *,' rhc=',rhc -! if (me .eq. 0 .and. kdt .eq. 1) -! & print *,' rhc=',rhc(1,1) -! &, ' lon=',xlon(1) * 57.29578,' lat=',xlat(1) * 57.29578 -! &,' kinver=',kinver(1) -! if (kdt .eq. 1 .and. abs(xlon(1)) .lt. 0.0001) -! & print *,' rhc=',rhc(1,1) -! &, ' work1=',work1(1),' work2=',work2(1) -! &, ' lon=',xlon(1) * 57.29578,' lat=',lat,' me=',me -! -! if (lprnt) print *,' ipr=',ipr,' gt0_gsc=',gt0(ipr,:) -! &,' xlon=',xlon(ipr),' xlat=',xlat(ipr) -! if (lprnt) print *,' ipr=',ipr,' gq0_gsc=',gq0(ipr,:,1) -! &,' xlon=',xlon(ipr),' xlat=',xlat(ipr) -! if (lprnt) print *,' ipr=',ipr,' gc0_gsc=',gq0(ipr,:,ntcw) -! &,' xlon=',xlon(ipr),' xlat=',xlat(ipr) -! if (lprnt) print *,' ipr=',ipr,' phy_f3d1=',phy_f3d(ipr,:,1) -! if (lprnt) print *,' ipr=',ipr,' phy_f3d2=',phy_f3d(ipr,:,2) -! if (lprnt) print *,' ipr=',ipr,' phy_f3d3=',phy_f3d(ipr,:,3) -! if (lprnt) print *,' ipr=',ipr,' phy_f2d=', -! &phy_f2d(ipr,1:num_p2d),' num_p2d=',num_p2d -! &, phy_f2d(ipr,2) - CALL GSCOND(IM, IX, LEVS, DTP, PRSL, PGR, - & GQ0(1,1,1), GQ0(1,1,ntcw), GT0, - & phy_f3d(1,1,1), phy_f3d(1,1,2), phy_f2d(1,1), - & phy_f3d(1,1,3), phy_f3d(1,1,4), phy_f2d(1,2), -! & rhc,lprnt) - & rhc,lprnt, ipr) - CALL PRECPD(IM, IX, LEVS, DTP, DEL, PRSL, PGR, - & GQ0(1,1,1), GQ0(1,1,ntcw), GT0, RAIN1, -!hchuang code change [+1L] : for rain production rate - & rainp, - & rhc, lprnt, ipr) -! & GQ0(1,1,1), GQ0(1,1,ntcw), GT0, RAIN1, rhc, lprnt) -! if (lprnt) print *,' rain1=',rain1(ipr) - endif -! -! ELSEIF (NCLD .EQ. 2) THEN -! CALL CLOUD3(1, 1, LEVS,DTP,PSEXP, -! 1 GT0(1,1),GQ0(1,1,1),GQ0(1,1,ntcw),NCLD,SL,DEL,SLK, -! 2 RAIN1,LAT,VVEL,KDT,FHOUR) -! ELSEIF (NCLD .EQ. 4) THEN -! CALL CLOUD5(1, 1, LEVS,DTP,PSEXP, -! 1 GT0,GQ0(1,1),GQ0(1,ntcw),NCLD,SL,DEL,SLK, -! 2 RAIN1,LAT,VVEL,KDT,FHOUR) -! ELSEIF (NCLD .EQ. 5) THEN -! CALL CLOUD6(1, 1, LEVS,DTP,PSEXP, -! 1 GT0,GQ0(1,1),GQ0(1,ntcw),NCLD,SL,DEL,SLK, -! 2 RAIN1,LAT,VVEL,KDT,FHOUR) - ENDIF -! -! if (lprnt) print *,' rain1=',rain1(ipr),' rainc=',rainc(ipr) - do i=1,im - RAINL(i) = FRAIN * RAIN1(i) - RAIN(i) = RAINC(i) + RAINL(i) - enddo - -!!-> Coupling insertion - if(lssav_cc_dummy) then - PRECR_cc_dummy(1:IM)=PRECR_cc_dummy(1:IM)+RAIN(1:IM) - end if -!!<- Coupling insertion - - if (cal_pre) then -! HCHUANG: add dominant precipitation type algorithm - - call calpreciptype(kdt,nrcm,im,ix,LEVS,LEVS+1,xkt2, - & xlat,xlon,gt0,gq0,prsl,prsi,RAIN, - & phii,num_p3d,tsea,sr,phy_f3d(1,1,3), ! input - & DOMR,DOMZR,DOMIP,DOMS) ! output - -! -! if (lprnt) print*,'debug calpreciptype: DOMR,DOMZR,DOMIP,DOMS ' -! &,DOMR(ipr),DOMZR(ipr),DOMIP(ipr),DOMS(ipr) -! do i=1,im -! if (abs(xlon(i)*57.29578-114.0) .lt. 0.2 .and. -! & abs(xlat(i)*57.29578-40.0) .lt. 0.2) -! & print*,'debug calpreciptype: DOMR,DOMZR,DOMIP,DOMS ', -! & DOMR(i),DOMZR(i),DOMIP(i),DOMS(i) -! end do -! HCHUANG: use new precipitation type to decide snow flag for LSM snow accumulation - do i=1,im - if(DOMS(i) >0.0 .or. DOMIP(i)>0.0)then - SRFLAG(i) = 1. - else - SRFLAG(i) = 0. - end if - enddo - endif - - - if(lssav) then - do i=1,im - GESHEM(i) = GESHEM(i) + RAIN(i) - enddo - IF (LDIAG3D) THEN - DO K=1,LEVS - do i=1,im - DT3DT(i,k,6) = DT3DT(i,k,6) + (GT0(i,k)-dtdt(i,k)) * FRAIN -! DQ3DT(i,k,4) = DQ3DT(i,k,4) + (gq0(i,k,1)-dqdt(i,k,1)) -! & * FRAIN - enddo - ENDDO - ENDIF - IF ( LDIAG3D .OR. LGGFS3D ) THEN - DO K=1,LEVS - do i=1,im - DQ3DT(i,k,4) = DQ3DT(i,k,4) + (gq0(i,k,1)-dqdt(i,k,1)) - & * FRAIN - enddo - ENDDO - ENDIF -!hchuang code change [+8L] 10/08/2008 rnp is 1.E+3 m/dtp, with mutiply by frain dtf/dtp -! rnp becomes rain (km) amount when output it will become -! rnp/(total time) that is km/s -! - IF (LGGFS3D) THEN - DO K=1,LEVS - do i=1,im - rnp(i,k) = rainp(i,k) * frain ! 3D large scale liqid rain amount - ! of one DTF time period in mm - enddo - ENDDO - ENDIF -! - endif -! -! ESTIMATE T850 FOR RAIN-SNOW DECISION -! - do i=1,im - T850(i) = GT0(I,1) - enddo - DO K = 1, LEVS - 1 - do i=1,im - IF(PRSL(I,K) .GT. P850 .AND. PRSL(I,K+1) .LE. P850) THEN - T850(i) = GT0(i,K) - (PRSL(i,k)-P850) - & / (PRSL(I,K)-PRSL(I,K+1)) * (GT0(I,K)-GT0(I,K+1)) - ENDIF - enddo - ENDDO - -!lu [-4L/+3L]: snow-rain detection is performed in land/sice module -! - if (cal_pre) then ! HCHUANG: new precip type algorithm defines srflag - do i = 1, im - tprcp(i) = rain(i) ! clu: rain -> tprcp - if (t850(i) <= 273.16) then -! --- ... wei: when call osu lsm, neutral impact, for code consistency - if (lsm == 0 .and. slmsk(i) /= 0.0) then - sheleg(i) = sheleg(i) + 1.e3*rain(i) - tprcp(i) = 0. - endif - endif - enddo - else - do i = 1, im - tprcp(i) = rain(i) ! clu: rain -> tprcp - srflag(i) = 0. ! clu: default srflag as 'rain' (i.e. 0) - if (t850(i) <= 273.16) then - srflag(i) = 1. ! clu: set srflag to 'snow' (i.e. 1) -! --- ... wei: when call osu lsm, neutral impact, for code consistency - if (lsm == 0 .and. slmsk(i) /= 0.0) then - sheleg(i) = sheleg(i) + 1.e3*rain(i) - tprcp(i) = 0. - endif - endif - enddo - endif - -! if (lprnt) print *,' TPRCP=',tprcp(ipr),' rain=',rain(ipr) - -!-->cpl insertion -! SNW_cc_dummy=0. - do i=1,im -! if(T850(i).LE.273.16.AND.SLMSK(i).NE.0.) THEN - if(T850(i).LE.273.16) THEN - LPREC_cc_dummy(i)=0.0 - SNW_cc_dummy(i)=RAIN(i) - else - LPREC_cc_dummy(i)=RAIN(i) - SNW_cc_dummy(i)=0.0 - endif - enddo -!<-- cpl insertion - -CWei [+2] when call OSU LSM -! -! UPDATE SOIL MOISTURE AND CANOPY WATER AFTER PRECIPITATION computaion -! - if (lsm == 0) then - CALL PROGT2(IM,LSOIL,RHSCNPY,RHSMC,AI,BI,CCI,SMSOIL, - & SLMSK,CANOPY,TPRCP,RUNOF,SNOWMT, - & ZSOIL,SOILTYP,SIGMAF,dtf,me) - -CWei [+5]: let soil liquid water equal to soil total water - DO K = 1, LSOIL - do i=1,im - IF(SLMSK(i).EQ.1.) THEN - SLSOIL(i,K) = SMSOIL(i,k) - ENDIF - enddo - ENDDO - endif - -! -! TOTAL RUNOFF IS COMPOSED OF DRAINAGE INTO WATER TABLE AND -! RUNOFF AT THE SURFACE AND IS ACCUMULATED IN UNIT OF METERS -! - if(lssav) then - do i=1,im - RUNOFF(i) = RUNOFF(i) + (DRAIN(i)+RUNOF(i)) * DTF / 1000.0 -Cwei added 10/24/2006 - SRUNOFF(i) = SRUNOFF(i) + RUNOF(i) * DTF / 1000.0 -!hchaung 11/19/2007 [+1L] ; top soil moisture unit is in mm - gsoil(i) = gsoil(i) + smsoil(i,1) * DTF - enddo - endif - -!c-- XW: FOR SEA-ICE Nov04 -! -! RETURN UPDATED ICE THICKNESS & CONCENTRATION TO GLOBAL ARRAYS -! - do i=1,im - IF(SLMSK(i).EQ.2.) THEN - HICE(i) = ZICE(i) - FICE(i) = CICE(i) - TISFC(i) = TICE(i) - else - HICE(i) = 0.0 - FICE(i) = 0.0 - TISFC(i) = TSEA(i) - endif - enddo -!c-- XW: END SEA-ICE - -Clu [-10L]: comment out smc/stc update -! -! RETURN UPDATED SMSOIL AND STSOIL TO GLOBAL ARRAYS -! - DO K = 1, LSOIL - do i=1,im - SMC(i,k) = SMSOIL(i,K) - STC(i,k) = STSOIL(i,K) - SLC(i,k) = SLSOIL(i,K) - enddo - ENDDO -! -! calc. integral of moistue in pwat -! - do i=1,im - PWAT(i) = 0. - enddo - DO K=1,LEVS - do i=1,im - work1(i) = 0.0 - enddo - if (ncld .gt. 0) then - do ic=ntcw, ntcw+ncld-1 - do i=1,im -! work1(i) = work1(i) + max(gq0(i,k,ic), qmin) - work1(i) = work1(i) + gq0(i,k,ic) - enddo - enddo - endif - do i=1,im -! inside this routine, let t as dry temperature only ! hmhj -! work2(i) = 1.0 + fv * max(gq0(i,k,1),qmin) ! hmhj -! GT0(i,K) = GT0(i,K) * work2(i) ! hmhj - PWAT(i) = PWAT(i) + DEL(i,K)*(GQ0(i,K,1)+work1(i)) - enddo - ENDDO - 490 CONTINUE - do i=1,im - PWAT(i) = PWAT(i)*(1.E3/grav) - enddo -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! if (me .eq. 0) then -! do i=1,im -! tem1 = dqsfc(i) - evapo(i) -! tem2 = geshem(i) - raino(i) -! print *,' pwatdif=',pwat(i)-pwato(i),' Edif=',tem1 -! &,' Pdif=',tem2,' E-P=',(tem1/hvap-tem2*1000)/frain -! &,' pwato=',pwato(i),' pwat=',pwat(i) -! enddo -! endif -! if (lprnt) then -! do i=1,im -! print *,' i=',i,' gt0=',gt0(i,:),' kdt=',kdt -! &,' xlon=',xlon(i)*57.296,' xlat(i)=',xlat(i)*57.296 -! print *,' ipr=',ipr,' gt0=',gt0(ipr,:),' kdt=',kdt,' ipr=' -! print *,' gt0E=',gt0(ipr,:) -! &,' xlon=',xlon(ipr),' xlat=',xlat(ipr) -! print *,' gu0=',gu0(ipr,:) -! print *,' gv0=',gv0(ipr,:) -! print *,' gq0=',gq0(ipr,:,3) -! print *,' gq0=',gq0(ipr,14,3) -! &,' xlon=',xlon(ipr),' xlat=',xlat(ipr) -! &,ipr -! enddo -! endif -! do i=1,im -! print *,' i=',i,' me=',me,' lat=',lat,' gt0=',gt0(i,:) -! enddo -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! -! CALL dscal(LEVS*IX,rcl,GU0,1) ! Commented by Moorthi -- Moved to gbphys_call.f -! CALL dscal(LEVS*IX,rcl,GV0,1) -! -csela write(66,103)gq0(1,2),gq0(levs,2) -103 format(1h ,' at end ozphys gq0(1,2) gq0(levs,2)',2(2x,e12.3)) -! - deallocate (clw) - -! if(lprnt) call mpi_quit(7) -! if (kdt .gt. 1) call mpi_quit(7) -! - RETURN - END - diff --git a/src/fim/FIMsrc/fim/column/get_prs_v.f b/src/fim/FIMsrc/fim/column/get_prs_v.f deleted file mode 100644 index 1d14916..0000000 --- a/src/fim/FIMsrc/fim/column/get_prs_v.f +++ /dev/null @@ -1,366 +0,0 @@ - subroutine GET_PRS(im,ix,levs,ntrac,t,q, - & prsi,prki,prsl,prkl,phii,phil,del) -! - USE MACHINE , ONLY : kind_phys - use resol_def , only : thermodyn_id, sfcpress_id - use namelist_def , only : gen_coord_hybrid - use physcons , only : cp => con_cp, nu => con_fvirt - &, rd => con_rd, rkap => con_rocp - USE tracer_const - implicit none -! - integer im, ix, levs, ntrac - real(kind=kind_phys) prsi(ix,levs+1), prki(ix,levs+1) - &, phii(ix,levs+1), phil(ix,levs) - &, prsl(ix,levs), prkl(ix,levs) - &, del(ix,levs), T(ix,levs) - &, q(ix,levs,ntrac) - real(kind=kind_phys) xcp(ix,levs), xr(ix,levs), kappa(ix,levs) - real(kind=kind_phys) tem, dphib, dphit, dphi - real (kind=kind_phys), parameter :: zero=0.0 - &, rkapi=1.0/rkap, rkapp1=1.0+rkap - integer i, k, n -! - do k=1,levs - do i=1,im - del(i,k) = PRSI(i,k) - PRSI(i,k+1) - enddo - enddo -! - if( gen_coord_hybrid ) then ! hmhj - if( thermodyn_id.eq.3 ) then ! Enthalpy case -! -! hmhj : This is for generalized hybrid (Henry) with finite difference -! in the vertical and enthalpy as the prognostic (thermodynamic) -! variable. However, the input "t" here is the temperature, -! not enthalpy (because this subroutine is called by gbphys where -! only temperature is available). -! - if (prki(1,1) <= zero .or. prkl(1,1) <= zero) then - call GET_CPR(im,ix,levs,ntrac,q,xcp,xr) -! - do k=1,levs - do i=1,im - kappa(i,k) = xr(i,k)/xcp(i,k) - prsl(i,k) = (PRSI(i,k) + PRSI(i,k+1))*0.5 - prkl(i,k) = (prsl(i,k)*0.01) ** kappa(i,k) - enddo - enddo - do k=2,levs - do i=1,im - tem = 0.5 * (kappa(i,k) + kappa(i,k-1)) - prki(i,k-1) = (prsi(i,k)*0.01) ** tem - enddo - enddo - do i=1,im - prki(i,1) = (prsi(i,1)*0.01) ** kappa(i,1) - enddo - k = levs + 1 - if (prsi(1,k) .gt. 0.0) then - do i=1,im - prki(i,k) = (prsi(i,k)*0.01) ** kappa(i,levs) - enddo - endif -! - do i=1,im - phii(i,1) = 0.0 ! Ignoring topography height here - enddo - DO k=1,levs - do i=1,im - TEM = xr(i,k) * T(i,k) - DPHI = (PRSI(i,k) - PRSI(i,k+1)) * TEM - & / (PRSI(i,k) + PRSI(i,k+1)) - phil(i,k) = phii(i,k) + DPHI - phii(i,k+1) = phil(i,k) + DPHI -! if(k == 1 .and. i == 1) print *,' xr=',xr(1,1),' T=',t(1,1) -! &,' prsi=',prsi(1,1),prsi(1,2),' tem=',tem,' dphi=',dphi - ENDDO - ENDDO - endif - if (prsl(1,1) <= 0.0) then - do k=1,levs - do i=1,im - prsl(i,k) = (PRSI(i,k) + PRSI(i,k+1))*0.5 - enddo - enddo - endif - if (phil(1,levs) <= 0.0) then ! If geopotential is not given, calculate - do i=1,im - phii(i,1) = 0.0 ! Ignoring topography height here - enddo - call GET_R(im,ix,levs,ntrac,q,xr) - DO k=1,levs - do i=1,im - TEM = xr(i,k) * T(i,k) - DPHI = (PRSI(i,k) - PRSI(i,k+1)) * TEM - & / (PRSI(i,k) + PRSI(i,k+1)) - phil(i,k) = phii(i,k) + DPHI - phii(i,k+1) = phil(i,k) + DPHI -! if(k == 1 .and. i == 1) print *,' xr=',xr(1,1),' T=',t(1,1) -! &,' prsi=',prsi(1,1),prsi(1,2),' tem=',tem,' dphi=',dphi - ENDDO - ENDDO - endif - else ! gc Virtual Temp case - if (prki(1,1) <= zero .or. prkl(1,1) <= zero) then - do k=1,levs - do i=1,im - prsl(i,k) = (PRSI(i,k) + PRSI(i,k+1))*0.5 - prkl(i,k) = (prsl(i,k)*0.01) ** rkap - enddo - enddo - do k=1,levs+1 - do i=1,im - prki(i,k) = (prsi(i,k)*0.01) ** rkap - enddo - enddo - do i=1,im - phii(i,1) = 0.0 ! Ignoring topography height here - enddo - DO k=1,levs - do i=1,im - TEM = rd * T(i,k)*(1.0+NU*max(Q(i,k,1),zero)) - DPHI = (PRSI(i,k) - PRSI(i,k+1)) * TEM - & / (PRSI(i,k) + PRSI(i,k+1)) - phil(i,k) = phii(i,k) + DPHI - phii(i,k+1) = phil(i,k) + DPHI - ENDDO - ENDDO - endif - if (prsl(1,1) <= 0.0) then - do k=1,levs - do i=1,im - prsl(i,k) = (PRSI(i,k) + PRSI(i,k+1))*0.5 - enddo - enddo - endif - if (phil(1,levs) <= 0.0) then ! If geopotential is not given, calculate - do i=1,im - phii(i,1) = 0.0 ! Ignoring topography height here - enddo - DO k=1,levs - do i=1,im - TEM = rd * T(i,k)*(1.0+NU*max(Q(i,k,1),zero)) - DPHI = (PRSI(i,k) - PRSI(i,k+1)) * TEM - & / (PRSI(i,k) + PRSI(i,k+1)) - phil(i,k) = phii(i,k) + DPHI - phii(i,k+1) = phil(i,k) + DPHI - ENDDO - ENDDO - endif - endif - else ! Not gc Virtual Temp (Orig Joe) - if (prki(1,1) <= zero) then -! Pressure is in centibars!!!! - do i=1,im - prki(i,1) = (prsi(i,1)*0.01) ** rkap - enddo - do k=1,levs - do i=1,im - prki(i,k+1) = (prsi(i,k+1)*0.01) ** rkap - tem = rkapp1 * del(i,k) - prkl(i,k) = (prki(i,k)*PRSI(i,k)-prki(i,k+1)*PRSI(i,k+1)) - & / tem - enddo - enddo - - elseif (prkl(1,1) <= zero) then - do k=1,levs - do i=1,im - tem = rkapp1 * del(i,k) - prkl(i,k) = (prki(i,k)*PRSI(i,k)-prki(i,k+1)*PRSI(i,k+1)) - & / tem - enddo - enddo - endif - if (prsl(1,1) <= 0.0) then - do k=1,levs - do i=1,im - PRSL(i,k) = 100.0 * PRKL(i,k) ** rkapi - enddo - enddo - endif - if (phil(1,levs) <= 0.0) then ! If geopotential is not given, calculate - do i=1,im - phii(i,1) = 0.0 ! Ignoring topography height here - enddo - DO k=1,levs - do i=1,im - TEM = CP * T(i,k) * (1.0 + NU*max(Q(i,k,1),zero)) - & / PRKL(i,k) - DPHIB = (PRKI(i,k) - PRKL(i,k)) * TEM - DPHIT = (PRKL(i,k ) - PRKI(i,k+1)) * TEM - phil(i,k) = phii(i,k) + DPHIB - phii(i,k+1) = phil(i,k) + DPHIT - ENDDO - ENDDO - endif - endif -! - return - end - subroutine GET_PHI(im,ix,levs,ntrac,t,q, - & prsi,prki,prsl,prkl,phii,phil) -! - USE MACHINE , ONLY : kind_phys - USE MACHINE , ONLY : kind_phys - use resol_def , only : thermodyn_id, sfcpress_id - use namelist_def , only : gen_coord_hybrid - use physcons , only : cp => con_cp, nu => con_fvirt - &, rd => con_rd, rkap => con_rocp - USE tracer_const - implicit none -! - integer im, ix, levs, ntrac - real(kind=kind_phys) prsi(ix,levs+1), prsl(ix,levs) - &, prki(ix,levs+1), prkl(ix,levs) - &, phii(ix,levs+1), phil(ix,levs) - &, T(ix,levs), q(ix,levs,ntrac) - real(kind=kind_phys) xr(ix,levs) - real(kind=kind_phys) tem, dphib, dphit, dphi - real (kind=kind_phys), parameter :: zero=0.0 - integer i, k, n -! - do i=1,im - phii(i,1) = zero ! Ignoring topography height here - enddo - if( gen_coord_hybrid ) then ! hmhj - if( thermodyn_id.eq.3 ) then ! Enthalpy case - call GET_R(im,ix,levs,ntrac,q,xr) - DO k=1,levs - do i=1,im - TEM = xr(i,k) * T(i,k) - DPHI = (PRSI(i,k) - PRSI(i,k+1)) * TEM - & /(PRSI(i,k) + PRSI(i,k+1)) - phil(i,k) = phii(i,k) + DPHI - phii(i,k+1) = phil(i,k) + DPHI -! if(k <= 4 .and. i == 1) print *,' xr=',xr(1,k),' T=',t(1,k) -! &,' prsi=',prsi(1,k),prsi(1,k+1),' tem=',tem,' dphi=',dphi,' k=',k - ENDDO - ENDDO -! - else ! gc Virtual Temp - DO k=1,levs - do i=1,im - TEM = RD * T(i,k) * (1.0 + NU*max(Q(i,k,1),zero)) - DPHI = (PRSI(i,k) - PRSI(i,k+1)) * TEM - & /(PRSI(i,k) + PRSI(i,k+1)) - phil(i,k) = phii(i,k) + DPHI - phii(i,k+1) = phil(i,k) + DPHI - ENDDO - ENDDO - endif - else ! Not gc Virt Temp (Orig Joe) - DO k=1,levs - do i=1,im - TEM = CP * T(i,k) * (1.0 + NU*max(Q(i,k,1),zero)) - & / PRKL(i,k) - DPHIB = (PRKI(i,k) - PRKL(i,k)) * TEM - DPHIT = (PRKL(i,k ) - PRKI(i,k+1)) * TEM - phil(i,k) = phii(i,k) + DPHIB - phii(i,k+1) = phil(i,k) + DPHIT - ENDDO - ENDDO - endif -! - return - end - subroutine GET_CPR(im,ix,levs,ntrac,q,xcp,xr) -! - USE MACHINE , ONLY : kind_phys - USE tracer_const - implicit none -! - real (kind=kind_phys), parameter :: zero=0.0 - integer im, ix, levs, ntrac - real(kind=kind_phys) q(ix,levs,ntrac) - real(kind=kind_phys) xcp(ix,levs),xr(ix,levs),sumq(ix,levs) - integer i, k, n -! - sumq = zero - xr = zero - xcp = zero - do n=1,ntrac - if( ri(n) > 0.0 ) then - do k=1,levs - do i=1,im - xr(i,k) = xr(i,k) + q(i,k,n) * ri(n) - xcp(i,k) = xcp(i,k) + q(i,k,n) * cpi(n) - sumq(i,k) = sumq(i,k) + q(i,k,n) - enddo - enddo - endif - enddo - do k=1,levs - do i=1,im - xr(i,k) = (1.-sumq(i,k))*ri(0) + xr(i,k) - xcp(i,k) = (1.-sumq(i,k))*cpi(0) + xcp(i,k) - enddo - enddo -! - return - end - subroutine GET_R(im,ix,levs,ntrac,q,xr) -! - USE MACHINE , ONLY : kind_phys - USE tracer_const - implicit none -! - real (kind=kind_phys), parameter :: zero=0.0 - integer im, ix, levs, ntrac - real(kind=kind_phys) q(ix,levs,ntrac) - real(kind=kind_phys) xr(ix,levs),sumq(ix,levs) - integer i, k, n -! - sumq = zero - xr = zero - do n=1,ntrac - if( ri(n) > 0.0 ) then - do k=1,levs - do i=1,im - xr(i,k) = xr(i,k) + q(i,k,n) * ri(n) - sumq(i,k) = sumq(i,k) + q(i,k,n) - enddo - enddo - endif - enddo - do k=1,levs - do i=1,im - xr(i,k) = (1.-sumq(i,k))*ri(0) + xr(i,k) - enddo - enddo -! - return - end - subroutine GET_CP(im,ix,levs,ntrac,q,xcp) -! - USE MACHINE , ONLY : kind_phys - USE tracer_const - implicit none -! - real (kind=kind_phys), parameter :: zero=0.0 - integer im, ix, levs, ntrac - real(kind=kind_phys) q(ix,levs,ntrac) - real(kind=kind_phys) xcp(ix,levs),sumq(ix,levs) - integer i, k, n -! - sumq = zero - xcp = zero - do n=1,ntrac - if( cpi(n) > 0.0 ) then - do k=1,levs - do i=1,im - xcp(i,k) = xcp(i,k) + q(i,k,n) * cpi(n) - sumq(i,k) = sumq(i,k) + q(i,k,n) - enddo - enddo - endif - enddo - do k=1,levs - do i=1,im - xcp(i,k) = (1.-sumq(i,k))*cpi(0) + xcp(i,k) - enddo - enddo -! - return - end diff --git a/src/fim/FIMsrc/fim/column/getaer.f b/src/fim/FIMsrc/fim/column/getaer.f deleted file mode 100644 index 5d70437..0000000 --- a/src/fim/FIMsrc/fim/column/getaer.f +++ /dev/null @@ -1,63 +0,0 @@ - subroutine getaer(nf,kprfg,idxcg,cmixg,denng - &, nxc, ndn, imxae, jmxae, IMON) -!**************************************************************** -! read in opac global aerosol data set (1998) for sw radiation -! -! input variables: -! nf - input file unit nuber -! -! output variables: -! kprfg - aerosol profile type index -! idxcg - aerosol components types indices -! cmixg - aerosol components mixing ratioes -! denng - first two layers aerosol number densities -! -!**************************************************************** - use machine - implicit none -! - input variable: - integer nf, nxc, ndn, imxae, jmxae, imon -! - output variables: - integer idxcg(nxc,imxae,jmxae), kprfg(imxae,jmxae) - real (kind=kind_io8) cmixg(nxc,imxae,jmxae),denng(ndn,imxae,jmxae) -! - local variables: - integer idxc(nxc), kprf, i, j, k, nc - real (kind=kind_io8) cmix(nxc), denn - real (kind=kind_io8) temp - character cline*80, ctyp*3, aerosol_file*40 -! - write(aerosol_file,101) imon - 101 format('aeropac3a.m',i2.2) -! - open (unit=nf, file=aerosol_file, status='OLD', form='FORMATTED') -! - read(nf,10) cline - 10 format(a80) -! - do j=1,jmxae - do i=1,imxae - read(nf,20) (idxc(k),cmix(k),k=1,nxc),kprf,denn,nc,ctyp - 20 format(5(i2,e11.4),i2,f8.2,i3,1x,a3) -! - kprfg(i,j) = kprf - denng(1,i,j) = denn ! num density of 1st layer - if (kprf .ge. 6) then - denng(2,i,j) = cmix(nxc) ! num density of 2dn layer - else - denng(2,i,j) = 0.0 - end if -! - temp = 1.0 - do k=1,nxc-1 - idxcg(k,i,j) = idxc(k) ! component index - cmixg(k,i,j) = cmix(k) ! component mixing ratio - temp = temp - cmix(k) - end do - idxcg(nxc,i,j) = idxc(nxc) - cmixg(nxc,i,j) = temp ! to make sure all add to 1. - end do - end do - close(nf) -! - return - end diff --git a/src/fim/FIMsrc/fim/column/getozn.f b/src/fim/FIMsrc/fim/column/getozn.f deleted file mode 100644 index 297a5af..0000000 --- a/src/fim/FIMsrc/fim/column/getozn.f +++ /dev/null @@ -1,138 +0,0 @@ - SUBROUTINE GETOZN(LENT, LM, O3B, K1, K2, FAC, PRSLK, iflip - &, XLAT,ko3) -! -! This code is written By Shrinivas Moorthi -! - USE MACHINE , ONLY : kind_phys,kind_rad,kind_io4 - USE FUNCPHYS , ONLY : fpkap - USE PHYSCONS, ROCP => con_ROCP, PI => con_PI - implicit none -! include 'constant.h' -! - integer jmr, blte, dlte, loz -! 4X5 ozone data -! parameter (jmr=45, BLTE=-86.0, DLTE=4.0) -! GEOS ozone data - parameter (jmr=18, BLTE=-85.0, DLTE=10.0, LOZ=17) -! - real (kind=kind_rad) p00, daylen - PARAMETER (p00=1000.0) - logical geosoz - parameter (geosoz=.true., daylen=86400.0) -! - integer lent, lm, k1, k2, iflip, ko3 -! -! LOCALS -! - real (kind=kind_rad) O3r(JMr,LOZ,12), O3B(lent,LM) - &, PRSLK(LENT,LM), O3I(lent,LOZ), PKSTR(LOZ) - &, PSTR(LOZ), xlat(lent) - &, wk1(lent) -! - integer imond(12), ilat(jmr,12) - real (kind=kind_io4) pstr4(loz), o3clim4(jmr,loz,12) -! - LOGICAL FIRST - DATA FIRST/.TRUE./ - DATA PKSTR/LOZ*0.0/, PSTR/LOZ*0.0/ -! DATA O3Z/JMLZ13*0.0/ -! - real (kind=kind_rad) tem, tem1, tem2, tem3, tem4 - &, temp, rdg, fac, deglat, elte -! - SAVE first, pkstr, pstr, o3r, elte -! - integer i, j, k, l, nm, j1, j2, ll -! -! if(me .eq. 0) WRITE (6,989) jdat(1),jdat(2),jdat(3),jdat(5) -! 989 FORMAT(' UPDATING OZONE FOR ', I4,I3,I3,I3) -! - IF (FIRST) THEN - REWIND KO3 - elte = blte + (jmr-1) * dlte - do l=1,loz - READ (KO3,15) pstr4(l) - enddo - pstr = pstr4 - DO nm=1,12 - do j=1,jmr - READ (KO3,19) imond(nm),ilat(j,nm), - & (o3clim4(j,l,nm), l=1,10) - READ (KO3,20) (o3clim4(j,l,nm), l=11,loz) - ENDDO - ENDDO - O3R = o3clim4 - do nm=1,12 - do l=1,loz - do j=1,jmr - o3r(j,l,nm) = o3r(j,l,nm) * 1.655e-6 - enddo - enddo - enddo -! - 15 format(f10.3) - 19 format(i2,i4,10f6.2) - 20 format(6x,10f6.2) -! - PRINT *,' FOUND OZONE DATA FOR LEVELS PSTR=',(PSTR(L),L=1,LOZ) -! print *,' O3=',(o3r(15,l,1),l=1,loz) -! - DO L=1,LOZ - PKSTR(L) = fpkap(PSTR(L)*100.0) -! PKSTR(L) = (PSTR(L)/P00) ** ROCP - ENDDO -! - FIRST = .FALSE. - ENDIF -! - RDG = 180.0 / PI - DO I=1,LENT - deglat = xlat(i)*rdg - if (deglat .gt. blte .and. deglat .lt. elte) then - tem1 = (deglat - BLTE)/DLTE + 1 - J1 = tem1 - J2 = J1 + 1 - tem1 = tem1 - J1 - elseif (deglat .le. blte) then - j1 = 1 - j2 = 1 - tem1 = 1.0 - elseif (deglat .ge. elte) then - j1 = jmr - j2 = jmr - tem1 = 1.0 - endif - tem2 = 1.0 - tem1 - DO J=1,LOZ - tem3 = tem2*o3r(j1,J,k1) + tem1*o3r(j2,J,k1) - tem4 = tem2*o3r(j1,J,k2) + tem1*o3r(j2,J,k2) - O3I(I,J) = tem4*fac + tem3*(1.0-fac) - ENDDO - ENDDO -! DO I=1,LENT -! PIK(I) = (PS(I)*10.0/P00) ** ROCP -! ENDDO -! - DO L=1,LM - LL = L - if (iflip .eq. 1) LL = LM + 1 -L - DO I=1,LENT - WK1(I) = PRSLK(I,LL) - ENDDO - DO K=1,LOZ-1 - temp = 1.0 / (PKSTR(K+1) - PKSTR(K)) - DO I=1,LENT - IF (WK1(I).GT.PKSTR(K) .AND. WK1(I).LE.PKSTR(K+1)) THEN - TEM = (PKSTR(K+1) - WK1(I)) * TEMP - O3B(I,L) = TEM * O3I(I,K) + (1.0 - TEM) * O3I(I,K+1) - ENDIF - ENDDO - ENDDO - DO I=1,LENT - IF (WK1(I) .GT. PKSTR(LOZ)) O3B(I,L) = O3I(I,LOZ) - IF (WK1(I) .LT. PKSTR(1)) O3B(I,L) = O3I(I,1) - ENDDO - ENDDO -! - RETURN - END diff --git a/src/fim/FIMsrc/fim/column/gg_def.f b/src/fim/FIMsrc/fim/column/gg_def.f deleted file mode 100644 index bfa0e9d..0000000 --- a/src/fim/FIMsrc/fim/column/gg_def.f +++ /dev/null @@ -1,10 +0,0 @@ - module gg_def -! use resol_def - use machine - - implicit none - save - REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: colrad_a(:),wgt_a(:), - . wgtcs_a(:),rcs2_a(:),sinlat_a(:),colrad_r(:),wgt_r(:), - . wgtcs_r(:),rcs2_r(:),sinlat_r(:),coslat_r(:) - end module gg_def diff --git a/src/fim/FIMsrc/fim/column/gloopr.f b/src/fim/FIMsrc/fim/column/gloopr.f deleted file mode 100644 index e6886f8..0000000 --- a/src/fim/FIMsrc/fim/column/gloopr.f +++ /dev/null @@ -1,1098 +0,0 @@ - subroutine gloopr - x (ncld, - x lats_nodes_r,global_lats_r, - x lonsperlar, -!jbao not needed by fim x epse,epso,epsedn,epsodn, -!jbao not needed by fim x snnp1ev,snnp1od, plnev_r,plnod_r, -!jbao not needed by fim x pddev_r,pddod_r, -! x snnp1ev,snnp1od,ndexev,ndexod, -! x plnev_r,plnod_r,pddev_r,pddod_r,plnew_r,plnow_r, - x phour, - & xlon,xlat,coszdg,COSZEN, - & SLMSK,SHELEG,SNCOVR,SNOALB,ZORL,TSEA,HPRIME, -Clu [+1L]: extract snow-free albedo (SFALB) - + SFALB, - & ALVSF,ALNSF ,ALVWF ,ALNWF,FACSF ,FACWF,CV,CVT , - & CVB ,SWH,HLW,SFCNSW,SFCDLW, - & FICE ,TISFC, SFCDSW, ! FOR SEA-ICE - XW Nov04 - & TSFLW,FLUXR , phy_f3d,slag,sdec,cdec,NBLCK,KDT, - & global_times_r,prsl,prsi,prslk,gt,gr,gr1, - & sscal,asymp,ext_cof,extlw_cof,yyyymmddhhmm) -cc -!jbao new gfs#include "f_hpm.h" -! - USE MACHINE , ONLY : kind_phys - USE FUNCPHYS , ONLY : fpkap - USE PHYSCONS, FV => con_fvirt, rerth => con_rerth ! hmhj - - use module_radiation_driver, only : radinit, grrad - use module_radiation_astronomy,only : astronomy -! -!! --- for optional spectral band heating outputs -!! use module_radsw_parameters, only : NBDSW -!! use module_radlw_parameters, only : NBDLW -! - use resol_def - use layout1 - use gg_def - use vert_def - use date_def - use namelist_def - use coordinate_def ! hmhj - use tracer_const ! hmhj -! jbao old gloopr cldcov passed in, we don't have d3d_def in fim?? -! use d3d_def , only : cldcov -! - implicit none -! jbao does fim need this??? - include 'mpif.h' -! -! jbao new gfs add ncld , grrad needs it - integer, intent(in) :: ncld -! jbao newgfs add ncld , grrad needs it - - real (kind=kind_phys), parameter :: QMIN =1.0e-10 - real (kind=kind_evod), parameter :: Typical_pgr = 95.0 - real (kind=kind_evod), parameter :: cons0 = 0.0, cons2 = 2.0 -! -! --- ... inputs: - integer ls_node, ls_nodes, max_ls_nodes - integer, intent(in) :: lats_nodes_r, & - & global_lats_r(LATR), lonsperlar(LATR) - - integer, intent(in) :: NBLCK - -!jbao not needed by fim real(kind=kind_evod), dimension(LEN_TRIE_LS), intent(in) :: & -!jbao not needed by fim & epse, epsedn, snnp1ev - -!jbao not needed by fim real(kind=kind_evod), dimension(LEN_TRIO_LS), intent(in) :: & -!jbao not needed by fim & epso, epsodn, snnp1od - -!jbao not needed by fim real(kind=kind_evod), intent(in) :: plnev_r(LEN_TRIE_LS, LATR2) -!jbao not needed by fim real(kind=kind_evod), intent(in) :: plnod_r(LEN_TRIO_LS, LATR2) - - real (kind=kind_phys), dimension(LONR,LATS_NODE_R), intent(in) :: & - & xlon, xlat, slmsk, sheleg, zorl, tsea, & - & alvsf, alnsf, alvwf, alnwf, facsf, facwf, & - & cv, cvt, cvb, FICE, tisfc, sncovr, snoalb - - real (kind=kind_phys), intent(in) :: & -! jbao orig, in old fim newgfs hprime is defined as 1,lonr.. & hprime(NMTVR,LONR,LATS_NODE_R), phour, & - & HPRIME( 1,lonr,lats_node_r), phour, & - & phy_f3d(NGPTC,LEVS,NBLCK,LATS_NODE_R,NUM_P3D) -! -! --- ... input and output: -!jbao real(kind=kind_evod), intent(inout) :: & -!jbao & trie_ls(LEN_TRIE_LS,2,11*LEVS+3*LEVH+6), & -!jbao & trio_ls(LEN_TRIO_LS,2,11*LEVS+3*LEVH+6) - integer ipt_ls ! hmhj - real(kind=kind_evod) reall ! hmhj - real(kind=kind_evod) rlcs2(jcap1) ! hmhj - - - real (kind=kind_phys), intent(inout) :: & - & fluxr (33,LONR,LATS_NODE_R) -! jbao orig ,nfxr isn't defined til later but=27 and added cldcov not 27, but levs & fluxr (NFXR,LONR,LATS_NODE_R) - real (kind=kind_phys) CLDCOV(LEVS,lonr,lats_node_r) !, intent(out) :: & -! & cldcov (27,LONR,LATS_NODE_R) -! jbao end new gfs define cldcov - -! --- ... inputs but not used anymore: -!jbao not needed by fim real(kind=kind_evod), intent(in) :: pddev_r(LEN_TRIE_LS,LATR2), & -!jbao not needed by fim & pddod_r(LEN_TRIO_LS,LATR2) & -! & plnew_r(LEN_TRIE_LS,LATR2), & -! & plnow_r(LEN_TRIO_LS,LATR2) -! & syn_ls_r(4*LS_DIM,LOTS,LATR2) - -! integer, intent(in) :: ndexev(LEN_TRIE_LS), ndexod(LEN_TRIO_LS) - integer, intent(in) :: KDT -! --- ... outputs: -! jbao old gloopr had global_times_r defined as the following: - real(kind=kind_evod) global_times_r -! jbao orig real(kind=kind_evod), intent(out) :: & -! jbao orig in old glooper get rid of dimesnions & global_times_r(LATG,NODES) - real(kind=kind_evod) :: & - & for_gr_r_1(LONRX*LOTS,LATS_DIM_R), & - & dyn_gr_r_1(lonrx*lotd,lats_dim_r), ! hmhj - & for_gr_r_2(LONRX*LOTS,LATS_DIM_R), - & dyn_gr_r_2(lonrx*lotd,lats_dim_r) ! hmhj - - real (kind=kind_phys), intent(out) :: & - & swh(NGPTC,LEVS,NBLCK,LATS_NODE_R), & - & hlw(NGPTC,LEVS,NBLCK,LATS_NODE_R) - - real (kind=kind_phys),dimension(LONR,LATS_NODE_R), intent(out) :: & - & coszdg, coszen, sfcnsw, sfcdlw, tsflw, & - & sfcdsw, SFALB - - real (kind=kind_phys), intent(out) :: slag, sdec, cdec - -!! --- ... optional spectral band heating rates -!! real (kind=kind_phys), optional, intent(out) :: & -!! & htrswb(NGPTC,LEVS,NBDSW,NBLCK,LATS_NODE_R), & -!! & htrlwb(NGPTC,LEVS,NBDLW,NBLCK,LATS_NODE_R) - -! --- ... locals: -! real(kind=kind_phys) :: prsl(NGPTC,LEVS), prdel(NGPTC,LEVS), & - real(kind=kind_phys) :: prsl(NGPTC,LEVS), prslk(NGPTC,LEVS), & - & prsi(NGPTC,LEVP1), prsik(NGPTC,LEVP1) - -! jbao newgfs change levr to levs - real (kind=kind_phys) :: si_loc(levs+1) -! real (kind=kind_phys) :: si_loc(levs+1), prslk(NGPTC,levs) - - real (kind=kind_phys) :: gu(NGPTC,LEVS), gv1(NGPTC,LEVS), & - & gt(NGPTC,levs), gd (NGPTC,LEVS), & -! jbao orig old has ngptc,levs,2 ntrac -1 & gr(NGPTC,levs), gr1(NGPTC,levs,NTRAC-1), & - & gr(NGPTC,levs), gr1(NGPTC,levs,2), & - & gphi(NGPTC), glam(NGPTC), gq(NGPTC), & - & sumq(NGPTC,levs), xcp(NGPTC,levs), &! hmhj - & gtv(NGPTC,levs), gtvx(NGPTC,levs), &! hmhj - & gtvy(NGPTC,levs) ! hmhj - - real (kind=kind_phys) :: f_ice(NGPTC,LEVS), f_rain(NGPTC,LEVS), & - & r_rime(NGPTC,LEVS) - - real (kind=kind_phys) :: cldcov_v(NGPTC,LEVS), hprime_v(NGPTC), & - & fluxr_v(NGPTC,33), vvel(NGPTC,LEVS) -! jbao old glooper nfxr not defined yet is 27 & fluxr_v(NGPTC,NFXR), vvel(NGPTC,LEVS) - real (kind=kind_phys) :: flgmin_l(ngptc), work1, work2 - - real (kind=kind_phys) :: rinc(5), dtsw, dtlw, solcon - - real (kind=kind_phys), save :: facoz -!-----aerosols Bao----------------------------------------- - real (kind=kind_phys) sscal(LEVS,14) - real (kind=kind_phys) asymp(LEVS,14) - real (kind=kind_phys) ext_cof(LEVS,14) - real (kind=kind_phys) extlw_cof(LEVS,16) -!-----end aerosols Bao----------------------------------------- - - integer :: njeff, lon, lan, lat, iblk, lon_dim, lons_lat, istrt - integer :: idat(8), jdat(8), DAYS(13), iday, imon, midmon, id - integer :: lmax - CHARACTER(len=12) :: yyyymmddhhmm - INTEGER year, month, day, hour, minute - - integer, save :: icwp, k1oz, k2oz, midm, midp - -! --- number of days in a month - data DAYS / 31,28,31,30,31,30,31,31,30,31,30,31,30 / - -! --- ... control parameters: -! (some of the them may be moved into model namelist) - -! --- ICTM=yyyy#, controls time sensitive external data (e.g. CO2, solcon, aerosols, etc) -! integer, parameter :: ICTM = 0 ! use data at initial cond time, if not -! ! available, use latest, no extrapolation. -!! integer, parameter :: ICTM = 1 ! use data at the forecast time, if not -! ! available, use latest and extrapolation. -! integer, parameter :: ICTM =yyyy0 ! use yyyy data for the forecast time, -! ! no further data extrapolation. -! integer, parameter :: ICTM =yyyy1 ! use yyyy data for the fcst. if needed, do -! ! extrapolation to match the fcst time. - -! --- ISOL controls solar constant data source -!! integer, parameter :: ISOL = 0 ! use prescribed solar constant -! integer, parameter :: ISOL = 1 ! use varying solar const with 11-yr cycle - -! --- ICO2 controls co2 data source for radiation -! integer, parameter :: ICO2 = 0 ! prescribed global mean value (old opernl) -!! integer, parameter :: ICO2 = 1 ! use obs co2 annual mean value only -! integer, parameter :: ICO2 = 2 ! use obs co2 monthly data with 2-d variation - -! --- IALB controls surface albedo for sw radiation -!! integer, parameter :: IALB = 0 ! use climatology alb, based on sfc type -! integer, parameter :: IALB = 1 ! use modis derived alb (to be developed) - -! --- IEMS controls surface emissivity for lw radiation -!! integer, parameter :: IEMS = 0 ! use fixed value of 1.0 -! integer, parameter :: IEMS = 1 ! use varying sfc emiss, based on sfc type -! --- IAER controls aerosols scheme selections -! Old definition -! integer, parameter :: IAER = 1 ! opac climatology, without volc forcing -! integer, parameter :: IAER =11 ! opac climatology, with volcanic forcing -! integer, parameter :: IAER = 2 ! gocart prognostic, without volc forcing -! integer, parameter :: IAER =12 ! gocart prognostic, with volcanic forcing -! New definition in this code -! IAER = 0 --> no aerosol effect at all (volc, sw, lw) -! = 1 --> only tropospheric sw aerosols, no trop-lw and volc -! = 10 --> only tropospheric lw aerosols, no trop-sw and volc -! = 11 --> both trop-sw and trop-lw aerosols, no volc -! = 100 --> only strato-volc aeros, no trop-sw and trop-lw -! = 101 --> only sw aeros (trop + volc), no lw aeros -! = 110 --> only lw aeros (trop + volc), no sw aeros -! = 111 --> both sw and lw aeros (trop + volc) -! - -! --- IOVR controls cloud overlapping method in radiation: -! integer, parameter :: IOVR_SW = 0 ! sw: random overlap clouds -!! integer, parameter :: IOVR_SW = 1 ! sw: max-random overlap clouds - -! integer, parameter :: IOVR_LW = 0 ! lw: random overlap clouds -!! integer, parameter :: IOVR_LW = 1 ! lw: max-random overlap clouds - -! --- iflip indicates model vertical index direction: -! integer, parameter :: IFLIP = 0 ! virtical profile index from top to bottom - integer, parameter :: IFLIP = 1 ! virtical profile index from bottom to top -! -! The following parameters are from gbphys -! - real (kind=kind_phys), parameter :: dxmax=-16.118095651, & - & dxmin=-9.800790154, dxinv=1.0/(dxmax-dxmin) - - integer :: kr, kt, kd, kq, ku, kv, ierr, dimg, kx, ky - integer :: i, j, k, n - integer :: kdtphi,kdtlam,ks ! hmhj - - logical :: lslag, change, lprnt - data lslag / .false. /, lprnt / .false. / - logical, save :: first, sas_shal - data first / .true. / - -! --- timers: - real*8 :: rtc, timer1, timer2 -! jbao new variable for the update as of Feb 2010 - integer nfxr - -! -!===> *** ... begin here -! -!! -cc -!cmr ls_node(1,1) ... ls_node(ls_max_node,1) : values of L -!cmr ls_node(1,2) ... ls_node(ls_max_node,2) : values of jbasev -!cmr ls_node(1,3) ... ls_node(ls_max_node,3) : values of jbasod -cc -cc -c$$$ integer lots,lotd,lota -c$$$cc -c$$$ parameter ( lots = 5*levs+1*levh+3 ) -c$$$ parameter ( lotd = 6*levs+2*levh+0 ) -c$$$ parameter ( lota = 3*levs+1*levh+1 ) -cc -cc - integer kap,kar,kat,kau,kav,kdrlam - integer ksd,ksplam,kspphi,ksq,ksr,kst - integer ksu,ksv,ksz,node -cc -! real(kind=kind_evod) spdlat(levs,lats_dim_r) -!Moor real(kind=kind_phys) slk(levs) -! real(kind=kind_evod) spdmax_node (levs) -! real(kind=kind_evod) spdmax_nodes(levs,nodes) -cc -cc -ccxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx -cc -cc -cc................................................................ -cc syn(1, 0*levs+0*levh+1, lan) ze -cc syn(1, 1*levs+0*levh+1, lan) di -cc syn(1, 2*levs+0*levh+1, lan) te -cc syn(1, 3*levs+0*levh+1, lan) rq -cc syn(1, 3*levs+1*levh+1, lan) q -cc syn(1, 3*levs+1*levh+2, lan) dpdlam -cc syn(1, 3*levs+1*levh+3, lan) dpdphi -cc syn(1, 3*levs+1*levh+4, lan) uln -cc syn(1, 4*levs+1*levh+4, lan) vln -cc................................................................ -cc dyn(1, 0*levs+0*levh+1, lan) d(t)/d(phi) -cc dyn(1, 1*levs+0*levh+1, lan) d(rq)/d(phi) -cc dyn(1, 1*levs+1*levh+1, lan) d(t)/d(lam) -cc dyn(1, 2*levs+1*levh+1, lan) d(rq)/d(lam) -cc dyn(1, 2*levs+2*levh+1, lan) d(u)/d(lam) -cc dyn(1, 3*levs+2*levh+1, lan) d(v)/d(lam) -cc dyn(1, 4*levs+2*levh+1, lan) d(u)/d(phi) -cc dyn(1, 5*levs+2*levh+1, lan) d(v)/d(phi) -cc................................................................ -cc anl(1, 0*levs+0*levh+1, lan) w dudt -cc anl(1, 1*levs+0*levh+1, lan) x dvdt -cc anl(1, 2*levs+0*levh+1, lan) y dtdt -cc anl(1, 3*levs+0*levh+1, lan) rt drdt -cc anl(1, 3*levs+1*levh+1, lan) z dqdt -cc................................................................ -cc -cc -c$$$ parameter(ksz =0*levs+0*levh+1, -c$$$ x ksd =1*levs+0*levh+1, -c$$$ x kst =2*levs+0*levh+1, -c$$$ x ksr =3*levs+0*levh+1, -c$$$ x ksq =3*levs+1*levh+1, -c$$$ x ksplam =3*levs+1*levh+2, -c$$$ x kspphi =3*levs+1*levh+3, -c$$$ x ksu =3*levs+1*levh+4, -c$$$ x ksv =4*levs+1*levh+4) -cc -c$$$ parameter(kdtphi =0*levs+0*levh+1, -c$$$ x kdrphi =1*levs+0*levh+1, -c$$$ x kdtlam =1*levs+1*levh+1, -c$$$ x kdrlam =2*levs+1*levh+1, -c$$$ x kdulam =2*levs+2*levh+1, -c$$$ x kdvlam =3*levs+2*levh+1, -c$$$ x kduphi =4*levs+2*levh+1, -c$$$ x kdvphi =5*levs+2*levh+1) -cc -c$$$ parameter(kau =0*levs+0*levh+1, -c$$$ x kav =1*levs+0*levh+1, -c$$$ x kat =2*levs+0*levh+1, -c$$$ x kar =3*levs+0*levh+1, -c$$$ x kap =3*levs+1*levh+1) -cc -cc -c$$$ integer P_gz,P_zem,P_dim,P_tem,P_rm,P_qm -c$$$ integer P_ze,P_di,P_te,P_rq,P_q,P_dlam,P_dphi,P_uln,P_vln -c$$$ integer P_w,P_x,P_y,P_rt,P_zq -c$$$cc -c$$$cc old common /comfspec/ -c$$$ parameter(P_gz = 0*levs+0*levh+1, ! gze/o(lnte/od,2), -c$$$ x P_zem = 0*levs+0*levh+2, ! zeme/o(lnte/od,2,levs), -c$$$ x P_dim = 1*levs+0*levh+2, ! dime/o(lnte/od,2,levs), -c$$$ x P_tem = 2*levs+0*levh+2, ! teme/o(lnte/od,2,levs), -c$$$ x P_rm = 3*levs+0*levh+2, ! rme/o(lnte/od,2,levh), -c$$$ x P_qm = 3*levs+1*levh+2, ! qme/o(lnte/od,2), -c$$$ x P_ze = 3*levs+1*levh+3, ! zee/o(lnte/od,2,levs), -c$$$ x P_di = 4*levs+1*levh+3, ! die/o(lnte/od,2,levs), -c$$$ x P_te = 5*levs+1*levh+3, ! tee/o(lnte/od,2,levs), -c$$$ x P_rq = 6*levs+1*levh+3, ! rqe/o(lnte/od,2,levh), -c$$$ x P_q = 6*levs+2*levh+3, ! qe/o(lnte/od,2), -c$$$ x P_dlam= 6*levs+2*levh+4, ! dpdlame/o(lnte/od,2), -c$$$ x P_dphi= 6*levs+2*levh+5, ! dpdphie/o(lnte/od,2), -c$$$ x P_uln = 6*levs+2*levh+6, ! ulne/o(lnte/od,2,levs), -c$$$ x P_vln = 7*levs+2*levh+6, ! vlne/o(lnte/od,2,levs), -c$$$ x P_w = 8*levs+2*levh+6, ! we/o(lnte/od,2,levs), -c$$$ x P_x = 9*levs+2*levh+6, ! xe/o(lnte/od,2,levs), -c$$$ x P_y =10*levs+2*levh+6, ! ye/o(lnte/od,2,levs), -c$$$ x P_rt =11*levs+2*levh+6, ! rte/o(lnte/od,2,levh), -c$$$ x P_zq =11*levs+3*levh+6) ! zqe/o(lnte/od,2) -cc -cc -! print *,' in gloopr vertcoord_id =',vertcoord_id -!================================================================================= -!!! ********* temporary return - Stan B - 14 Aug 2010 - -! return -!!! -!================================================================================= - - -! jbao new variable for the update as of Feb 2010 - ls_node = 1 - ls_nodes = 1 - max_ls_nodes = 1 - f_ice = 0.0 - f_rain = 0.0 - r_rime =0.0 - cldcov =0.0 - -! some of these are declared--jbao do we need to declare them? - num_p3d=4 - nfxr=33 - sashal=.true. ! jbao true from gfs namelist - norad_precip=.false. ! jbao false from gfs namelist - crick_proof=.false. ! jbao false from gfs namelist - ccnorm=.false. ! jbao false from gfs namelist - lggfs3d=.false. - lprnt=.false. - ras = .false. ! jbao needed by new gfs from do onestep - - ntrac = 3 ! new gfs physics 3 !JFM and Bao originally in new gloopr was 2 - ntcw = 3 !JFM and Bao - ntoz = 2 !JFM and Bao - vvel = 0.0 !JFM and Bao - LDIAG3D = .false. !JFM - lssav = .true. !JFM false means FLUXR is not calculated in grrad, ok because fluxr not used in physics.F90 - fluxr = 0.0 - fluxr_v = 0.0 -! jbao end new gfs - -! -! jbao not needed by fim ksz =0*levs+0*levh+1 -! jbao not needed by fim ksd =1*levs+0*levh+1 -! jbao not needed by fim kst =2*levs+0*levh+1 -! jbao not needed by fim ksr =3*levs+0*levh+1 -! jbao not needed by fim ksq =3*levs+1*levh+1 -! jbao not needed by fim ksplam =3*levs+1*levh+2 -! jbao not needed by fim kspphi =3*levs+1*levh+3 -! jbao not needed by fim ksu =3*levs+1*levh+4 -! jbao not needed by fim ksv =4*levs+1*levh+4 - -! jbao not needed by fim kdtphi =0*levs+0*levh+1 ! hmhj -! jbao not needed by fim kdtlam =1*levs+1*levh+1 ! hmhj -cc -! jbao not needed by fim lslag=.false. -cc - idat = 0 -! get date info from the date string - READ(UNIT=yyyymmddhhmm(1:4), FMT='(I4)') year - READ(UNIT=yyyymmddhhmm(5:6), FMT='(I2)') month - READ(UNIT=yyyymmddhhmm(7:8), FMT='(I2)') day - READ(UNIT=yyyymmddhhmm(9:10), FMT='(I2)') hour - READ(UNIT=yyyymmddhhmm(11:12), FMT='(I2)') minute - idat(1) = year - idat(2) = month - idat(3) = day - idat(5) = hour - - rinc = 0. - rinc(2) = phour - call w3movdat(rinc, idat, jdat) -! - if (ntoz .le. 0) then ! Climatological Ozone! -! -! if(me .eq. 0) WRITE (6,989) jdat(1),jdat(2),jdat(3),jdat(5) -! 989 FORMAT(' UPDATING OZONE FOR ', I4,I3,I3,I3) -! - IDAY = jdat(3) - IMON = jdat(2) - MIDMON = DAYS(IMON)/2 + 1 - CHANGE = FIRST .OR. - & ( (IDAY .EQ. MIDMON) .AND. (jdat(5).EQ.0) ) -! - IF (CHANGE) THEN - IF (IDAY .LT. MIDMON) THEN - K1OZ = MOD(IMON+10,12) + 1 - MIDM = DAYS(K1OZ)/2 + 1 - K2OZ = IMON - MIDP = DAYS(K1OZ) + MIDMON - ELSE - K1OZ = IMON - MIDM = MIDMON - K2OZ = MOD(IMON,12) + 1 - MIDP = DAYS(K2OZ)/2 + 1 + DAYS(K1OZ) - ENDIF - ENDIF -! - IF (IDAY .LT. MIDMON) THEN - ID = IDAY + DAYS(K1OZ) - ELSE - ID = IDAY - ENDIF - FACOZ = real (ID-MIDM) / real (MIDP-MIDM) - endif -! jbao do we need to do this or as in old gloopr goto 11111?? -! jbao need ras in here -! - if (first) then - sas_shal = sashal .and. (.not. ras) - goto 1111 ! jbao skip find levels -! -! jbao do we need to bring in these variables? they are defined elsewhere? hybrid not defined - if( hybrid.or.gen_coord_hybrid ) then ! hmhj - - if( gen_coord_hybrid ) then ! hmhj - si_loc(levs+1) = si(levp1) ! hmhj - do k=1,levs ! hmhj - si_loc(k) = si(k) ! hmhj - enddo ! hmhj - else ! hmhj -! --- get some sigma distribution for radiation-cloud initialization -!sela si(k)=(ak5(k)+bk5(k)*Typical_pgr)/Typical_pgr !ak(k) bk(k) go top to botto - si_loc(levs+1)= ak5(1)/typical_pgr+bk5(1) - do k=1,levs - si_loc(levs+1-k)= ak5(levp1-levs+k)/typical_pgr - & + bk5(levp1-levs+k) - enddo - endif -! jbao it will do this comment out?? - else - do k = 1, levs - si_loc(k) = si(k) - enddo - si_loc(levs+1) = si(levp1) - endif ! end_if_hybrid - -! --- determin prognostic/diagnostic cloud scheme -! jbao new gfs continue- here?? -1111 continue - icwp = 0 - if (NTCW > 0) icwp = 1 - -! jbao new gfs: old gloopr first=false isn't done 111 continue is after this but icwp =0 is done - first = .false. - - endif ! end_if_first -! jbao end do we need to do this -! jbao new gfs needs sinlat_r, coslat_r, in previous gloopr in fim, did that here - allocate (sinlat_r(1),coslat_r(1)) - sinlat_r(1) = sin(xlat(1,1)) ! jbao - coslat_r(1) = cos(xlat(1,1)) ! jbao - lsswr = .true. ! jbao - lslwr = .true. ! jbao - fhswr = 1.0 ! jbao test 0 cause floating point - fhlwr = 1.0 ! jbao test 0 cause floating point - isol = 0 ! jbao - ico2 = 1 ! jbao -! 0 - use default value -! 1 - read in CO2 file - ialb = 0 ! jbao - iaer = 1 ! 0 ! jbao test to turn off aerosols - iovr_lw=1 - iovr_sw=1 - iems = 0 ! jbao - ictm = 1 ! jbao - do k=1,levp1 - SI_loc(k)= prsi(1,k)/prsi(1,1) - enddo - - -! end jbao new gfs needs sinlat_r, coslat_r, other variables above in previous gloopr in fim, did that here - -! -!===> *** ... radiation initialization -! - dtsw = 3600.0 * fhswr - dtlw = 3600.0 * fhlwr - -! jbao is si_loc correct? what about ico2?, isol?,ialb,iaer (before, passed in numbers),ictm not defined - call radinit & -! --- input: - & ( si_loc, levs, IFLIP, NUM_P3D, ICTM, & - & ISOL, ICO2, ICWP, IALB, IEMS, IAER, idat, jdat, me ) -! --- output: ( none ) - -! -!===> *** ... astronomy for sw radiation calculation. -! - call astronomy & -! --- inputs: - & ( lonsperlar, global_lats_r, sinlat_r, coslat_r, xlon, & -! & fhswr, jdat, deltim, & - & fhswr, jdat, & - & LONR, LATS_NODE_R, LATR, IPT_LATS_NODE_R, lsswr, me, & -! --- outputs: - & solcon, slag, sdec, cdec, coszen, coszdg & - & ) - -! print *,' returned from astro' -! -!===> *** ... spectrum to grid transformation for radiation calculation. -! ----------------------------------- -cc -! jbao new gfs not needed by fim call f_hpmstart(61,"gr delnpe") -! jbao new gfs not needed by fim call delnpe(trie_ls(1,1,P_q ), -! jbao new gfs not needed by fim x trio_ls(1,1,P_dphi), -! jbao new gfs not needed by fim x trie_ls(1,1,P_dlam), -! jbao new gfs not needed by fim x epse,epso,ls_node) -! jbao new gfs not needed by fim call f_hpmstop(61) -cc -! jbao new gfs not needed by fim call f_hpmstart(62,"gr delnpo") -! jbao new gfs not needed by fim call delnpo(trio_ls(1,1,P_q ), -! jbao new gfs not needed by fim x trie_ls(1,1,P_dphi), -! jbao new gfs not needed by fim x trio_ls(1,1,P_dlam), -! jbao new gfs not needed by fim x epse,epso,ls_node) -! jbao new gfs not needed by fim call f_hpmstop(62) -cc -cc -! jbao new gfs not needed by fim call f_hpmstart(63,"gr dezouv dozeuv") -! -! jbao new gfs not needed by fim!$omp parallel do shared(trie_ls,trio_ls) -! jbao new gfs not needed by fim!$omp+shared(epsedn,epsodn,snnp1ev,snnp1od,ls_node) -! jbao new gfs not needed by fim!$omp+private(k) -! jbao new gfs not needed by fim do k=1,levs -! jbao new gfs not needed by fim call dezouv(trie_ls(1,1,P_di +k-1), trio_ls(1,1,P_ze +k-1), -! jbao new gfs not needed by fim x trie_ls(1,1,P_uln+k-1), trio_ls(1,1,P_vln+k-1), -! jbao new gfs not needed by fim x epsedn,epsodn,snnp1ev,snnp1od,ls_node) -cc -! jbao new gfs not needed by fim call dozeuv(trio_ls(1,1,P_di +k-1), trie_ls(1,1,P_ze +k-1), -! jbao new gfs not needed by fim x trio_ls(1,1,P_uln+k-1), trie_ls(1,1,P_vln+k-1), -! jbao new gfs not needed by fim x epsedn,epsodn,snnp1ev,snnp1od,ls_node) -! jbao new gfs not needed by fim enddo -! jbao new gfs not needed by fim call f_hpmstop(63) -cc -! jbao new gfs not needed by fim!sela print*,'completed call to dztouv' -cc -! jbao?? is next line needed -!cmr call mpi_barrier (mpi_comm_world,ierr) -cc - CALL countperf(0,5,0.) - CALL synctime() - CALL countperf(1,5,0.) -!! -! jbao new gfs dimg is not needed comment out?? -! jbao new gfs physics dimg=0 - CALL countperf(0,1,0.) -cc -!jbao new gfs not needed by fim call f_hpmstart(67,"gr sumfln") -cc -!jbao new gfs not needed by fim!sela print*,'begining call to sumfln' -!jbao new gfs not needed by fim call sumflna_r(trie_ls(1,1,P_ze), -!jbao new gfs not needed by fim x trio_ls(1,1,P_ze), -!jbao new gfs not needed by fim x lat1s_r, -!jbao new gfs not needed by fim x plnev_r,plnod_r, -!jbao new gfs not needed by fim x lots,ls_node,latr2, -!jbao new gfs not needed by fim x lslag,lats_dim_a,lots,for_gr_r_1, -!jbao new gfs not needed by fim x ls_nodes,max_ls_nodes, -!jbao new gfs not needed by fim x lats_nodes_r,global_lats_r, -!jbao new gfs not needed by fim x lats_node_r,ipt_lats_node_r,lon_dims_r,dimg, -!jbao new gfs not needed by fim x lonsperlar,lonrx,latr) -cc -!jbao new gfs not needed by fim!sela print*,'completed call to sumfln' -!jbao new gfs not needed by fim call f_hpmstop(67) -cc - CALL countperf(1,1,0.) -cc -! ----------------------------------- -!jbao new gfs not needed by fim if( vertcoord_id.eq.3. ) then -! ----------------------------------- -!jbao new gfs not needed by fim CALL countperf(0,1,0.) ! hmhj -! -!jbao new gfs not needed by fim call f_hpmstart(68,"gr sumder2") ! hmhj -! -!jbao new gfs not needed by fim call sumdera_r(trie_ls(1,1,P_te), ! hmhj -!jbao new gfs not needed by fim x trio_ls(1,1,P_te), ! hmhj -!jbao new gfs not needed by fim x lat1s_r, ! hmhj -!jbao new gfs not needed by fim x pddev_r,pddod_r, ! hmhj -!jbao new gfs not needed by fim x levs,ls_node,latr2, ! hmhj -!jbao new gfs not needed by fim x lslag,lats_dim_r,lotd, ! hmhj -!jbao new gfs not needed by fim x dyn_gr_r_1, ! hmhj -!jbao new gfs not needed by fim x ls_nodes,max_ls_nodes, ! hmhj -!jbao new gfs not needed by fim x lats_nodes_r,global_lats_r, ! hmhj -!jbao new gfs not needed by fim x lats_node_r,ipt_lats_node_r,lon_dims_r,dimg, ! hmhj -!jbao new gfs not needed by fim x lonsperlar,lonrx,latr) ! hmhj -! -!jbao new gfs not needed by fim call f_hpmstop(68) ! hmhj -! -!jbao new gfs not needed by fim CALL countperf(1,1,0.) ! hmhj -! -------------------------------- -!jbao new gfs not needed by fim endif ! vertcoord_id=3 -! -------------------------------- -! - -!cmr call mpi_barrier (mpi_comm_world,ierr) - -! jbao not needed by fim do lan=1,lats_node_r -! jbao new gfs for fim not needed timer1=rtc() -! jbao not needed by fimcc -! jbao not needed by fim lat = global_lats_r(ipt_lats_node_r-1+lan) -! jbao not needed by fimcc -! jbao ?? do we need lon_dims_r if so how do we get it in? -! jbao not needed by fim lon_dim = lon_dims_r(lan) -cc -! jbao not needed by fim lons_lat = lonsperlar(lat) - -! ------------------------------------------------------- -! jbao not needed by fim if( gen_coord_hybrid .and. vertcoord_id.eq.3. ) then -! ------------------------------------------------------- -! -! jbao not needed by fim lmax = min(jcap,lons_lat/2) ! hmhj -! jbao not needed by fim! -! jbao not needed by fim ipt_ls=min(lat,latr-lat+1) ! hmhj -! jbao not needed by fim -! jbao not needed by fim do i=1,lmax+1 ! hmhj -! jbao not needed by fim if ( ipt_ls .ge. lat1s_r(i-1) ) then ! hmhj -! jbao not needed by fim reall=i-1 ! hmhj -! jbao not needed by fim rlcs2(i)=reall*rcs2_r(ipt_ls)/rerth ! hmhj -! jbao not needed by fim else ! hmhj -! jbao not needed by fim rlcs2(i)=cons0 !constant ! hmhj -! jbao not needed by fim endif ! hmhj -! jbao not needed by fim enddo ! hmhj -! -! jbao not needed by fim!$omp parallel do private(k,i) -! jbao not needed by fim do k=1,levs ! hmhj -! jbao not needed by fim do i=1,lmax+1 ! hmhj -! jbao not needed by fim! -! jbao not needed by fim! d(t)/d(lam) ! hmhj -! jbao not needed by fim dyn_gr_r_1(2*i-1+(kdtlam-2+k)*lon_dim,lan)= ! hmhj -! jbao not needed by fim x -for_gr_r_1(2*i +(kst -2+k)*lon_dim,lan)*rlcs2(i) ! hmhj -! jbao not needed by fim dyn_gr_r_1(2*i +(kdtlam-2+k)*lon_dim,lan)= ! hmhj -! jbao not needed by fim x for_gr_r_1(2*i-1+(kst -2+k)*lon_dim,lan)*rlcs2(i) ! hmhj -! jbao not needed by fim enddo ! hmhj -! jbao not needed by fim enddo ! hmhj -! jbao not needed by fim! -------------------- -! jbao not needed by fim endif ! gc and vertcoord_id=3 -! --------------------- -! -cc -! jbao not needed by fim CALL countperf(0,6,0.) -!jbao newgfs not needed in fim!sela print*,' beginning call four2grid',lan -!jbao newgfs not needed in fim CALL FOUR2GRID_thread(for_gr_r_1(1,lan),for_gr_r_2(1,lan), & -!jbao newgfs not needed in fim & lon_dim,lons_lat,lonrx,5*levs+levh+3,lan,me) - -! ------------------------------------------------------- -! jbao not needed by fim if( gen_coord_hybrid.and.vertcoord_id.eq.3. ) then ! hmhj -! ------------------------------------------------------- -! jbao not needed by fim CALL FOUR2GRID_thread(dyn_gr_r_1(1,lan),dyn_gr_r_2(1,lan), ! hmhj -! jbao not needed by fim & lon_dim,lons_lat,lonrx,levs,lan,me) ! hmhj -! jbao not needed by fim CALL FOUR2GRID_thread(dyn_gr_r_1((kdtlam-1)*lon_dim+1,lan), ! hmhj -! jbao not needed by fim & dyn_gr_r_2((kdtlam-1)*lon_dim+1,lan), ! hmhj -! jbao not needed by fim & lon_dim,lons_lat,lonrx,levs,lan,me) ! hmhj -! ------------------------- -! jbao not needed by fim endif ! gc and vertcoord_id=3 -! ------------------------- - -! jbao not needed by fim!sela print*,' completed call four2grid lan=',lan -! jbao ?? new gfs do we need the following? -! jbao not needed by fim CALL countperf(1,6,0.) -!! -! jbao do we need to this?? gen_coord_hyrbrid is false does it do this? -! jbao not needed by fim if( .not. gen_coord_hybrid ) then ! hmhj -! jbao not needed by fim -! jbao not needed by fim do k = 1, LEVS -! jbao not needed by fim kr = (KSR + k - 2) * lon_dim -! jbao not needed by fim kt = (KST + k - 2) * lon_dim -! jbao not needed by fim do j = 1, lons_lat -! jbao not needed by fim if (for_gr_r_2(j+kr,lan) <= 0.0) then -! jbao not needed by fim for_gr_r_2(j+kr,lan) = QMIN -! jbao not needed by fim endif -! jbao not needed by fim for_gr_r_2(j+kt,lan) = for_gr_r_2(j+kt,lan) & -! jbao not needed by fim & / (1.0 + FV*for_gr_r_2(j+kr,lan)) -! jbao not needed by fim enddo -! jbao not needed by fim enddo -! jbao not needed by fim kq = (KSQ - 1)*lon_dim -! jbao not needed by fim do j = 1, lons_lat -! jbao not needed by fim for_gr_r_2(j+kq,lan) = exp( for_gr_r_2(j+kq,lan) ) -! jbao not needed by fim enddo -! jbao not needed by fim -! jbao not needed by fim endif ! hmhj -c -! jbao don't think next 2 are needed for fim -! timer2=rtc() -! global_times_r(lat,me+1)=timer2-timer1 -c$$$ print*,'timeloopr',me,timer1,timer2,global_times_r(lat,me+1) - -!! -! jbao not needed by fim enddo !lan -! -! jbao newgfs not needed in fim call f_hpmstart(69,"gr lat_loop2") -! -!===> *** ... starting latitude loop -! - do lan=1,lats_node_r -cc - lat = global_lats_r(ipt_lats_node_r-1+lan) -cc - lons_lat = lonsperlar(lat) - -!! -!$omp parallel do schedule(dynamic,1) private(lon,j,k,lon_dim) -!$omp+private(istrt,njeff,iblk,ku,kv,kd,kq,kt,kr,kx,ky,ks,n) -!$omp+private(vvel,gu,gv1,gd,gt,gr,gr1,gq,gphi,glam) -!$omp+private(gtv,gtvx,gtvy,sumq,xcp) -!$omp+private(cldcov_v,hprime_v,fluxr_v,f_ice,f_rain,r_rime) -!$omp+private(prslk,prsl,prsik,prsi) - - DO lon=1,lons_lat,NGPTC -!! -!jbao newgfs do we need to define lon_dimsr in do physics? -! jbao no need to use lon_dim = lon_dims_r(lan) -! jbao newgfs as previous gloopr for fim set njeff and istrt=1 -! NJEFF = MIN(NGPTC,lons_lat-lon+1) -! ISTRT = lon - njeff=1 - ISTRT = 1 - IBLK = 1 -! jbao newgfs iblk is set to 1 before, here it will be 1 but should we just set to 1 ?? -! jbao if (NGPTC.ne.1) then -! jbao IBLK = lon/NGPTC+1 -! jbao else -! jbao IBLK = lon -! jbao endif -! jbao not needed by fim do k = 1, LEVS -! jbao not needed by fim ku = lon - 1 + (KSU + k - 2)*lon_dim -! jbao not needed by fim kv = lon - 1 + (KSV + k - 2)*lon_dim -! jbao not needed by fim kd = lon - 1 + (KSD + k - 2)*lon_dim -! jbao not needed by fim do j = 1, njeff -! jbao not needed by fim gu(j,k) = for_gr_r_2(j+ku,lan) -! jbao not needed by fim gv1(j,k) = for_gr_r_2(j+kv,lan) -! jbao not needed by fim gd(j,k) = for_gr_r_2(j+kd,lan) -! jbao not needed by fim enddo -! jbao not needed by fim enddo - -! jbao not needed by fim if( gen_coord_hybrid ) then ! hmhj - -! jbao not needed by fim do k=1,levs ! hmhj -! jbao not needed by fim kt = lon - 1 + (KST + k - 2)*lon_dim -! jbao not needed by fim kr = lon - 1 + (KSR + k - 2)*lon_dim -! jbao not needed by fim do j=1,njeff ! hmhj -! jbao not needed by fim gtv(j,k) = for_gr_r_2(j+kt,lan) -! jbao not needed by fim gr(j,k) = max(qmin, for_gr_r_2(j+kr,lan)) -! jbao not needed by fim enddo ! hmhj -! jbao not needed by fim enddo ! hmhj -! -------------------------------------- -! jbao not needed by fim if( vertcoord_id.eq.3. ) then -! -------------------------------------- -! jbao not needed by fim do k=1,levs ! hmhj -! jbao not needed by fim kx = lon - 1 + (kdtlam + k - 2)*lon_dim -! jbao not needed by fim ky = lon - 1 + (kdtphi + k - 2)*lon_dim -! jbao not needed by fim do j=1,njeff ! hmhj -! jbao not needed by fim gtvx(j,k) = dyn_gr_r_2(j+kx,lan) -! jbao not needed by fim gtvy(j,k) = dyn_gr_r_2(j+ky,lan) -! jbao not needed by fim enddo ! hmhj -! jbao not needed by fim enddo ! hmhj -! ----------------------------- -! jbao not needed by fim endif -! ----------------------------- -! jbao thermodyn_id not defined? -! jbao not needed by fim if( thermodyn_id.eq.3 ) then -! get dry temperature from enthalpy ! hmhj -! jbao not needed by fim sumq=0.0 ! hmhj -! jbao not needed by fim xcp=0.0 ! hmhj -! jbao not needed by fim do i=1,ntrac ! hmhj -! jbao not needed by fim if( cpi(i).ne.0.0 ) then ! hmhj -! jbao not needed by fim ks=ksr+(i-1)*levs ! hmhj -! jbao not needed by fim do k=1,levs ! hmhj -! jbao not needed by fim kr = lon - 1 + (ks + k - 2)*lon_dim ! hmhj -! jbao not needed by fim do j=1,njeff ! hmhj -! jbao not needed by fim sumq(j,k)=sumq(j,k)+for_gr_r_2(j+kr,lan) ! hmhj -! jbao not needed by fim xcp(j,k)=xcp(j,k)+cpi(i)*for_gr_r_2(j+kr,lan) ! hmhj -! jbao not needed by fim enddo ! hmhj -! jbao not needed by fim enddo ! hmhj -! jbao not needed by fim endif ! hmhj -! jbao not needed by fim enddo ! hmhj -! jbao not needed by fim do k=1,levs ! hmhj -! jbao not needed by fim do j=1,njeff ! hmhj -! jbao not needed by fim xcp(j,k)=(1.-sumq(j,k))*cpi(0)+xcp(j,k) ! hmhj -! jbao not needed by fim gt(j,k)=gtv(j,k)/xcp(j,k) ! hmhj -! jbao not needed by fim enddo ! hmhj -! jbao not needed by fim enddo ! hmhj -! jbao not needed by fim else if( thermodyn_id.le.1 ) then ! hmhj -! jbao not needed by fim! get dry temperature from virtual temperature ! hmhj -! jbao not needed by fim do k=1,levs ! hmhj -! jbao not needed by fim do j=1,njeff ! hmhj -! jbao not needed by fim gt(j,k) = gtv(j,k) / (1.+fv*gr(j,k)) ! hmhj -! jbao not needed by fim enddo ! hmhj -! jbao not needed by fim enddo ! hmhj -! jbao not needed by fim else -! jbao not needed by fim! get dry temperature from dry temperature ! hmhj -! jbao not needed by fim do k=1,levs ! hmhj -! jbao not needed by fim do j=1,njeff ! hmhj -! jbao not needed by fim gt(j,k) = gtv(j,k) ! hmhj -! jbao not needed by fim enddo ! hmhj -! jbao not needed by fim enddo -! jbao not needed by fim endif -! jbao not needed by fim -! jbao not needed by fim else ! hmhj -! -! jbao not needed by fim do k = 1, levs -! jbao not needed by fim kt = lon - 1 + (KST + k - 2)*lon_dim -! jbao not needed by fim kr = lon - 1 + (KSR + k - 2)*lon_dim -! jbao not needed by fim do j = 1, njeff -! jbao not needed by fim gt(j,k) = for_gr_r_2(j+kt,lan) -! jbao not needed by fim gr(j,k) = for_gr_r_2(j+kr,lan) -! jbao not needed by fim enddo -! jbao not needed by fim enddo - -! jbao not needed by fim endif -! -! Remaining tracers -! -! jbao not needed by fim do n = 1, NTRAC-1 -! jbao not needed by fim do k = 1, levs -! jbao not needed by fim kr = lon - 1 + (KSR + n*LEVS + k - 2)*lon_dim -! jbao not needed by fim do j = 1, njeff -! jbao not needed by fim gr1(j,k,n) = for_gr_r_2(j+kr,lan) -! jbao not needed by fim enddo -! jbao not needed by fim enddo -! jbao not needed by fim enddo -! jbao not needed by fim kq = lon - 1 + (KSQ - 1)*lon_dim -! jbao not needed by fim kt = lon - 1 + (KSPPHI - 1)*lon_dim -! jbao not needed by fim kr = lon - 1 + (KSPLAM - 1)*lon_dim -! jbao not needed by fim do j = 1, njeff -! jbao not needed by fim gq (j) = for_gr_r_2(j+kq,lan) -! jbao not needed by fim gphi(j) = for_gr_r_2(j+kt,lan) -! jbao not needed by fim glam(j) = for_gr_r_2(j+kr,lan) -! jbao not needed by fim enddo -!! -! --- vertical structure variables: del,si,sl,prslk,prdel -! -! jbao not needed by fim if( gen_coord_hybrid ) then ! hmhj -! jbao not needed by fim!Moor call hyb2press_gc(njeff,ngptc,gq,gtv,prsi,prsl,prdel) ! hmhj -! jbao not needed by fim call hyb2press_gc(njeff,ngptc,gq,gtv,prsi,prsl,prsik,prslk) ! hmhj -! jbao not needed by fim call omegtes_gc(njeff,ngptc,rcs2_r(min(lat,latr-lat+1)), ! hmhj -! jbao not needed by fim & gq,gphi,glam,gtv,gtvx,gtvy,gd,gu,gv1,vvel) ! hmhj -! jbao not needed by fim elseif (hybrid) then -! jbao not needed by fim !Moor call hyb2press(njeff,ngptc,gq, prsi, prsl,prdel) -! jbao not needed by fim call hyb2press(njeff,ngptc,gq, prsi, prsl,prsik, prslk) -! jbao not needed by fim call omegtes(njeff,ngptc,rcs2_r(min(lat,latr-lat+1)), -! jbao not needed by fim & gq,gphi,glam,gd,gu,gv1,vvel) -! jbao not needed by fim else -! jbao newgfs for fim comment these out?? -! jbao not needed by fim !Moor call sig2press(njeff,ngptc,gq,sl,del,si, prsi, prsl,prdel) -! jbao not needed by fim call sig2press(njeff,ngptc,gq,sl,si,slk,sik, -! jbao not needed by fim & prsi,prsl,prsik,prslk) -! jbao not needed by fim CALL countperf(0,12,0.) -! jbao not needed by fim call omegast3(njeff,ngptc,levs, -! jbao not needed by fim & gphi,glam,gu,gv1,gd,del, -! jbao not needed by fim & rcs2_r(min(lat,latr-lat+1)),vvel,gq,sl) -! jbao not needed by fim endif -! end jbao newgfs for fim comment these out?? -!..... -! jbao this was one of them levr do we need to comment this out - do k=1,levs - do j=1,njeff - prslk(j,k) = fpkap(prsl(j,k)*1000.0) - cldcov_v(j,k) = cldcov(k,istrt+j-1,lan) - enddo - enddo - -!jbao if (levs .lt. levs) then -!jbao do j=1,njeff -!jbao prsi(j,levs+1) = prsi(j,levp1) -!jbao prsl(j,levs) = (prsi(j,levp1)+prsi(j,levs)) * 0.5 -!jbao prsik(j,levs+1) = prslk(j,levp1) -!jbao prslk(j,levs) = fpkap(prsl(j,levs)*1000.0) -!jbao enddo -!jbao endif -! jbao both false doesn't do - if (ldiag3d .or. lggfs3d) then - do k=1,levs - do j=1,njeff -!Moor prslk(j,k) = fpkap(prsl(j,k)*1000.0) -! jbao ?? cldcov_v goes in grrad, but ldiag3d and lggfs3d are false so not defined - cldcov_v(j,k) = cldcov(k,istrt+j-1,lan) - enddo - enddo - endif -! - do j=1,njeff - hprime_v(j) = hprime(1,istrt+j-1,lan) - enddo -! - do k=1, nfxr - do j=1,njeff -!jbao?? new gfs commented out in previous fim version of gfs but fluxr_v needed in grrad -! fluxr_v(j,k) = fluxr(k,istrt+j-1,lan) - enddo - enddo - if (NUM_P3D == 3) then - do k = 1, levs - do j = 1, njeff - f_ice (j,k) = phy_f3d(j,k,iblk,lan,1) - f_rain(j,k) = phy_f3d(j,k,iblk,lan,2) - r_rime(j,k) = phy_f3d(j,k,iblk,lan,3) - enddo - enddo - endif -! jbao before this is done in gbphys???? -! jbao work1 = (log(coslat_r(lat) / (lons_lat*latg)) - dxmin) * dxinv -! jbao work1 = max(0.0, min(1.0,work1)) -! jbao work2 = flgmin(1)*work1 + flgmin(2)*(1.0-work1) -! jbao do j=1,njeff -! jbao flgmin_l(j) = work2 -! jbao enddo - -! *** ... calling radiation driver - -! -! lprnt = me .eq. 0 .and. kdt .ge. 120 -! if (lprnt) then -! if (kdt .gt. 85) then -! print *,' calling grrad for me=',me,' lan=',lan,' lat=',lat -! &,' num_p3d=',num_p3d,' snoalb=',snoalb(lon,lan),' lon=',lon -! &,' tsea=',tsea(lon,lan),' sncovr=',sncovr(lon,lan), -! &' sheleg=',sheleg(lon,lan) -! -!jbao old gloopr call grrad & -!jbao old gloopr! --- inputs: -!jbao old gloopr & ( prsi,prsl,prslk,gt,gr,gr1,vvel,slmsk(lon,lan), & -!jbao old gloopr & xlon(lon,lan),xlat(lon,lan),tsea(lon,lan), & -!jbao old gloopr & sheleg(lon,lan),sncovr(lon,lan),snoalb(lon,lan), & -!jbao old gloopr & zorl(lon,lan),hprime_v, & -!jbao old gloopr & alvsf(lon,lan),alnsf(lon,lan),alvwf(lon,lan), & -!jbao old gloopr & alnwf(lon,lan),facsf(lon,lan),facwf(lon,lan), & -!jbao old gloopr ! fice FOR SEA-ICE XW Nov04 -!jbao old gloopr & fice(lon,lan),tisfc(lon,lan), & -!jbao old gloopr & solcon,coszen(lon,lan),coszdg(lon,lan),k1oz,k2oz,facoz, & -!jbao old gloopr & cv(lon,lan),cvt(lon,lan),cvb(lon,lan), & -!jbao old gloopr & IOVR_SW,IOVR_LW,f_ice,f_rain,r_rime,flgmin_l, & -!jbao old gloopr & NUM_P3D,NTCW-1,NCLD,NTOZ-1,NTRAC-1,NFXR, & -!jbao old gloopr & dtlw,dtsw, lsswr,lslwr,lssav,ldiag3d,sas_shal,norad_precip,& -!jbao old gloopr & crick_proof, ccnorm,lggfs3d, & -!jbao old gloopr! & dtlw,dtsw, lsswr,lslwr,lssav,ldiag3d,lggfs3d, & -!jbao old gloopr & NGPTC,njeff,levs,IFLIP, me, lprnt, & -!jbao old gloopr! --- outputs: -!jbao old gloopr & swh(1,1,iblk,lan),sfcnsw(lon,lan),sfcdsw(lon,lan), & ! sfcdsw FOR SEA-ICE XW Nov04 -!jbao old gloopr & sfalb(lon,lan), & ! lu [+1L]: add sfalb -!jbao old gloopr & hlw(1,1,iblk,lan),sfcdlw(lon,lan),tsflw(lon,lan), & -!jbao old gloopr! --- input/output: -!jbao old gloopr & fluxr_v,cldcov_v & -!jbao old gloopr!! --- optional outputs: -!jbao old gloopr!! &, HTRSWB=htrswb(1,1,1,iblk,lan), & -!jbao old gloopr!! &, HTRLWB=htrlwb(1,1,1,iblk,lan) & -!jbao old gloopr & ) -! -! jbao new gloopr call to grrad - call grrad & -! --- inputs: - & ( prsi,prsl,prslk,gt,gr,gr1,vvel,slmsk(lon,lan), & - & xlon(lon,lan),xlat(lon,lan),tsea(lon,lan), & - & sheleg(lon,lan),sncovr(lon,lan),snoalb(lon,lan), & - & zorl(lon,lan),hprime_v, & - & alvsf(lon,lan),alnsf(lon,lan),alvwf(lon,lan), & - & alnwf(lon,lan),facsf(lon,lan),facwf(lon,lan), & - ! fice FOR SEA-ICE XW Nov04 - & fice(lon,lan),tisfc(lon,lan), & - & solcon,coszen(lon,lan),coszdg(lon,lan),k1oz,k2oz,facoz, & - & cv(lon,lan),cvt(lon,lan),cvb(lon,lan), & - & IOVR_SW,IOVR_LW,f_ice,f_rain,r_rime,flgmin_l, & - & NUM_P3D,NTCW-1,NCLD,NTOZ-1,NTRAC-1,NFXR, & - & dtlw,dtsw, lsswr,lslwr,lssav,ldiag3d,sas_shal,norad_precip,& - & crick_proof, ccnorm,lggfs3d, & - & sscal,asymp,ext_cof,extlw_cof, & -! & dtlw,dtsw, lsswr,lslwr,lssav,ldiag3d,lggfs3d, & - & NGPTC,njeff,levs,IFLIP, me, lprnt, & -! --- outputs: - & swh(1,1,iblk,lan),sfcnsw(lon,lan),sfcdsw(lon,lan), & ! sfcdsw FOR SEA-ICE XW Nov04 - & sfalb(lon,lan), & ! l - & hlw(1,1,iblk,lan),sfcdlw(lon,lan),tsflw(lon,lan), & -! --- input/output: - & fluxr_v,cldcov_v & -!! --- optional outputs: -!! &, HTRSWB=htrswb(1,1,1,iblk,lan), & -!! &, HTRLWB=htrlwb(1,1,1,iblk,lan) & - & ) - - -! if (lprnt) print *,' returned from grrad for me=',me,' lan=', -! &lan,' lat=',lat,' kdt=',kdt -! -! -! jbao not needed in fim if (ldiag3d .or. lggfs3d) then -! jbao not needed in fim do k=1,levs -! jbao not needed in fim do j=1,njeff -! jbao not needed in fim cldcov(k,istrt+j-1,lan) = cldcov_v(j,k) -! jbao not needed in fim enddo -! jbao not needed in fim enddo -! jbao not needed in fim endif - do k=1,nfxr - do j=1,njeff - fluxr(k,istrt+j-1,lan) = fluxr_v(j,k) - enddo - enddo -! jbao original newgfs had levr .lt levs?? keep like this??? -! jbao not needed in fim if (levs .lt. levs) then -! jbao original newgfs had levr+1,levs keep like this??? -! jbao not needed in fim do k=levs+1,levs -! jbao not needed in fim do j=1,njeff -! jbao not needed in fim hlw(j,k,iblk,lan) = hlw(j,levs,iblk,lan) -! jbao not needed in fim swh(j,k,iblk,lan) = swh(j,levs,iblk,lan) -! jbao not needed in fim enddo -! jbao not needed in fim enddo -! jbao not needed in fim endif - -c$$$ write(2900+lat,*) ' ilon = ',istrt -c$$$ write(2900+lat,'("swh",T16,"hlw")') -c$$$ do k=1,levs -c$$$ write(2900+lat, -c$$$ . '(e10.3,T16,e10.3,T31,e10.3)') -c$$$ . swh(1,k,iblk,lan),hlw(1,k,iblk,lan) -c$$$ enddo - -!! - CALL countperf(1,12,0.) - ENDDO -! - enddo -cc -! jbao newgfs not in fim call f_hpmstop(69) -!! - CALL countperf(0,5,0.) - CALL synctime() - CALL countperf(1,5,0.) -!sela print*,'completed gloopr_v kdt=',kdt -!! -! jbao new gfs for fim ??? this is what it was in previous fim gfs??do we -! need to allocate / deallocatek - deallocate(sinlat_r,coslat_r) - return - end subroutine gloopr diff --git a/src/fim/FIMsrc/fim/column/grrad.f b/src/fim/FIMsrc/fim/column/grrad.f deleted file mode 100644 index 0f1605f..0000000 --- a/src/fim/FIMsrc/fim/column/grrad.f +++ /dev/null @@ -1,1148 +0,0 @@ -!!!!! ========================================================== !!!!! -!!!!! 'module_radiation_driver' descriptions !!!!! -!!!!! ========================================================== !!!!! -! ! -! this is the radiation driver module. it prepares atmospheric ! -! profiles and invokes main radiation calculations. ! -! ! -! in module 'module_radiation_driver' there are twe externally ! -! callable subroutine: ! -! ! -! 'radinit' -- initialization routine ! -! input: ! -! ( si, NLAY, iflip, NP3D, ! -! ISOL, ICO2, ICWP, IALB, IEMS, IAER, idate, jdate, me ) ! -! output: ! -! ( none ) ! -! ! -! 'grrad' -- setup and invoke main radiation calls ! -! input: ! -! ( prsi,prsl,prslk,tgrs,qgrs,oz,vvl,slmsk, ! -! xlon,xlat,tsfc,snowd,sncovr,snoalb,zorl,hprim, ! -! alvsf,alnsf,alvwf,alnwf,facsf,facwf,fice,tisfc, ! -! solcon,coszen,coszdg,k1oz,k2oz,facoz, ! -! cv,cvt,cvb,iovrsw,iovrlw,fcice,frain,rrime, ! -! np3d,ntcw,ncld,ntoz, NTRAC,NFXR, ! -! dtlw,dtsw, lsswr,lslwr,lssav,ldiag3d,sashal,norad_precip, ! -! crick_proof, ccnorm, lggfs3d, ! -! IX, IM, LM, iflip, me, lprnt, ! -! output: ! -! htrsw,sfcnsw,sfcdsw,sfalb, ! -! htrlw,sfcdlw,tsflw, ! -! input/output: ! -! fluxr,cldcov, ! -! optional output: ! -! HTRSWB,HTRLWB) ! -! ! -! ! -! external modules referenced: ! -! 'module machine' in 'machine.f' ! -! 'module funcphys' in 'funcphys.f' ! -! 'module physcons' in 'physcons.f ! -! ! -! 'module module_radiation_gases' in 'radiation_gases.f' ! -! 'module module_radiation_aerosols' in 'radiation_aerosols.f' ! -! 'module module_radiation_surface' in 'radiation_surface.f' ! -! 'module module_radiation_clouds' in 'radiation_clouds.f' ! -! ! -! 'module module_radsw_cntr_para' in 'radsw_xxxx_param.f' ! -! 'module module_radsw_parameters' in 'radsw_xxxx_param.f' ! -! 'module module_radsw_main' in 'radsw_xxxx_main.f' ! -! ! -! 'module module_radlw_cntr_para' in 'radlw_xxxx_param.f' ! -! 'module module_radlw_parameters' in 'radlw_xxxx_param.f' ! -! 'module module_radlw_main' in 'radlw_xxxx_main.f' ! -! ! -! where xxxx may vary according to different scheme selection ! -! ! -! ! -! program history log: ! -! mm-dd-yy ncep - created program grrad ! -! 08-12-03 yu-tai hou - re-written for modulized radiations ! -! 11-06-03 yu-tai hou - modified ! -! 01-18-05 s. moorthi - NOAH/ICE model changes added ! -! 05-10-05 yu-tai hou - modified module structure ! -! 12-xx-05 s. moorthi - sfc lw flux adj by mean temperature ! -! 02-20-06 yu-tai hou - add time variation for co2 data, and ! -! solar const. add sfc emiss change ! -! 03-21-06 s. Moorthi - added surface temp over ice ! -! 07-28-06 yu-tai hou - add stratospheric vocanic aerosols ! -! 03-14-07 yu-tai hou - add generalized spectral band interp ! -! for aerosol optical prop. (sw and lw) ! -! 04-10-07 yu-tai hou - spectral band sw/lw heating rates ! -! 05-04-07 yu-tai hou - make options for clim based and modis ! -! based (h. wei and c. marshall) albedo ! -! 09-05-08 yu-tai hou - add the initial date and time 'idate' ! -! and control param 'ICTM' to the passing param list! -! to handel different time/date requirements for ! -! external data (co2, aeros, solcon, ...) ! -! ! -!!!!! ========================================================== !!!!! -!!!!! end descriptions !!!!! -!!!!! ========================================================== !!!!! - - - -!========================================! - module module_radiation_driver ! -!........................................! -! - use machine , only : kind_phys - use physcons, only : con_eps, con_epsm1 - use funcphys, only : fpvs -! use resol_def, only : psthk - - use module_radiation_astronomy,only : solinit - use module_radiation_gases, only : NF_VGAS, getgases, getozn, & - & gasinit - use module_radiation_aerosols,only : NF_AESW, aerinit, setaer, & - & NF_AELW - use module_radiation_surface, only : NF_ALBD, sfcinit, setalb, & - & setemis - use module_radiation_clouds, only : NF_CLDS, cldinit, & - & progcld1, progcld2, diagcld1 - - use module_radsw_cntr_para, only : iaersw - use module_radsw_parameters, only : topfsw_type, sfcfsw_type, & - & profsw_type,cmpfsw_type,NBDSW - use module_radsw_main, only : rswinit, swrad - - use module_radlw_cntr_para, only : iaerlw - use module_radlw_parameters, only : topflw_type, sfcflw_type, & - & proflw_type, NBDLW - use module_radlw_main, only : rlwinit, lwrad -! - implicit none -! - private - -! --- constant values - real (kind=kind_phys) :: QMIN, QME5, QME6, EPSQ -! parameter ( QMIN=1.0e-10, QME5=1.0e-5, QME6=1.0e-6, EPSQ=1.0e-12 ) - parameter (QMIN=1.0e-10,QME5=1.0e-20,QME6=1.0e-20,EPSQ=1.0e-12 ) - -! real (kind=kind_phys), parameter :: psthk = 10.0 ! sfc air press thkness -! ! (mb) for tsflw calc. - -! --- control variables - integer :: irad1st=1, month0=0, iyear0=0 - - public radinit, grrad - - -! ================= - contains -! ================= - - -!----------------------------------- - subroutine radinit & -!................................... - -! --- inputs: - & ( si, NLAY, iflip, NP3D, ICTM, & - & ISOL, ICO2, ICWP, IALB, IEMS, IAER, idate, jdate, me ) -! --- outputs: -! ( none ) - -! ================= subprogram documentation block ================ ! -! ! -! subprogram: radinit initialization of radiation calculations ! -! ! -! ! -! program history log: ! -! 08-14-2003 yu-tai hou created ! -! ! -! usage: call radinit ! -! ! -! attributes: ! -! language: fortran 90 ! -! machine: ibm sp ! -! ! -! ==================== defination of variables ==================== ! -! ! -! input parameters: ! -! si : model vertical sigma interface ! -! NLAY : number of model vertical layers ! -! iflip : control flag for direction of vertical index ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! NP3D :=3: ferrier's microphysics cloud scheme ! -! =4: zhao/carr/sundqvist microphysics cloud ! -! ICTM :=yyyy#, external data time/date control flag ! -! = 0: use data at initial cond time, if not ! -! available, use latest, no extrapolation. ! -! = 1: use data at the forecast time, if not ! -! available, use latest and extrapolation. ! -! =yyyy0: use yyyy data for the forecast time, ! -! no further data extrapolation. ! -! =yyyy1: use yyyy data for the fcst. if needed, do ! -! extrapolation to match the fcst time. ! -! ISOL :=0: use a fixed solar constant value ! -! =1: use 11-year cycle solar constant table ! -! ICO2 :=0: use prescribed global mean co2 (old oper) ! -! =1: use observed co2 annual mean value only ! -! =2: use obs co2 monthly data with 2-d variation ! -! ICWP : control flag for cloud generation schemes ! -! =0: use diagnostic cloud scheme ! -! =1: use prognostic cloud scheme (default) ! -! IALB : control flag for surface albedo schemes ! -! =0: climatology, based on surface veg types ! -! =1: modis retrieval based surface albedo scheme ! -! IEMS : control flag for surface emissivity schemes ! -! =0: fixed value of 1.0 ! -! =1: varying value based on surface veg types ! -! IAER : flag for aerosols scheme selection ! -! = 1: opac climatology, without volc forcing ! -! =11: opac climatology, with volcanic forcing ! -! = 2: gocart prognostic, without volc forcing ! -! =12: gocart prognostic, with volcanic forcing ! -! idate(8) : ncep absolute date and time of initial condition ! -! (yr, mon, day, t-zone, hr, min, sec, mil-sec) ! -! jdate(8) : ncep absolute date and time at fcst time ! -! (yr, mon, day, t-zone, hr, min, sec, mil-sec) ! -! me : print control flag ! -! ! -! outputs: (none) ! -! ! -! usage: call radinit ! -! ! -! subroutines called: cldinit, aerinit, rlwinit, rswinit, gasinit ! -! ! -! =================================================================== ! -! - implicit none - -! --- inputs: - integer, intent(in) :: NLAY, iflip, NP3D, ICTM, ISOL, ICO2, ICWP, & - & IALB, IEMS, IAER, me - integer, intent(in) :: idate(:), jdate(:) - - real (kind=kind_phys), intent(in) :: si(:) - -! --- outputs: (none) - -! --- locals: - integer :: iyear, month, iday, ihour - -! -!===> ... begin here -! - - if ( irad1st == 1 ) then - if (me == 0) then -! print *,' NEW RADIATION PROGRAM STRUCTURES -- SEP 01 2004' - print *,' NEW RADIATION PROGRAM STRUCTURES BECAME OPER. ', & - & ' May 01 2007' - endif - endif - - if ( ICTM == 0 ) then ! get external data at initial condition time - iyear = idate(1) - month = idate(2) -! iday = idate(3) -! ihour = idate(5) - else ! get external data at fcst or specified time - iyear = jdate(1) - month = jdate(2) -! iday = jdate(3) -! ihour = jdate(5) - endif ! end if_ICTM_block - -! --- ... call aerosols and co2 initialization routines - - if ( month0 /= month ) then - month0 = month - if ( iaersw==1 .or. iaerlw==1 ) then - - call aerinit ( iyear, month, IAER, me ) - - endif - - call gasinit ( iyear, month, ICTM, ICO2, me ) - endif - -! --- ... call astronomy initialization routine - - if ( ISOL == 0 ) then - - if ( irad1st == 1) then - call solinit ( ISOL, iyear, me ) - endif - - else - - if ( iyear0 /= iyear ) then - iyear0 = iyear - call solinit ( ISOL, iyear, me ) - endif - - endif - -! --- ... followings only need to be called once - - if ( irad1st == 1 ) then - - irad1st = 0 - -! --- ... call surface initialization routine - - call sfcinit ( NLAY, iflip, IALB, IEMS, me ) - -! --- ... call cloud initialization routine - - call cldinit ( si, NLAY, iflip, NP3D, ICWP, me ) - -! --- ... call lw radiation initialization routine - - call rlwinit ( ICWP, me, NLAY ) - -! --- ... call sw radiation initialization routine - - call rswinit ( ICWP, me, NLAY ) - - endif ! end of if_irad1st_block -! - return -!................................... - end subroutine radinit -!----------------------------------- - - -!----------------------------------- - subroutine grrad & -!................................... - -! --- inputs: - & ( prsi,prsl,prslk,tgrs,qgrs,oz,vvl,slmsk, & - & xlon,xlat,tsfc,snowd,sncovr,snoalb,zorl,hprim, & - & alvsf,alnsf,alvwf,alnwf,facsf,facwf,fice,tisfc, & - & solcon,coszen,coszdg,k1oz,k2oz,facoz, & - & cv,cvt,cvb,iovrsw,iovrlw,fcice,frain,rrime,flgmin, & - & np3d,ntcw,ncld,ntoz, NTRAC,NFXR, & - & dtlw,dtsw, lsswr,lslwr,lssav,ldiag3d,sashal,norad_precip, & - & crick_proof, ccnorm, lggfs3d, & -! & dtlw,dtsw, lsswr,lslwr,lssav,ldiag3d, & - & sscal,asymp,ext_cof,extlw_cof, & - & IX, IM, LM, iflip, me, lprnt, & -! --- outputs: - & htrsw,sfcnsw,sfcdsw,sfalb, & - & htrlw,sfcdlw,tsflw, & -! --- input/output: - & fluxr,cldcov & -!! --- optional outputs: - &, HTRSWB,HTRLWB & - & ) - -! ================= subprogram documentation block ================ ! -! ! -! this program is the driver of radiation calculation subroutines. * ! -! It sets up profile variables for radiation input, including * ! -! clouds, surface albedos, atmospheric aerosols, ozone, etc. * ! -! * ! -! usage: call grrad * ! -! * ! -! subprograms called: * ! -! setalb, setemis, setaer, getozn, getgases, * ! -! progcld1, progcld2, diagcds, * ! -! swrad, lwrad, fpvs * ! -! * ! -! attributes: * ! -! language: fortran 90 * ! -! machine: ibm-sp, sgi * ! -! * ! -! * ! -! ==================== defination of variables ==================== ! -! ! -! input variables: ! -! prsi (IX,LM+1) : model level pressure in cb (kPa) ! -! prsl (IX,LM) : model layer mean pressure in cb (kPa) ! -! prslk (IX,LM) : pressure in cb (kPa) ! -! tgrs (IX,LM) : model layer mean temperature in k ! -! qgrs (IX,LM) : layer specific humidity in gm/gm ! -! oz (IX,LM,NTRAC):layer ozone mass mixing ratio ! -! vvl (IX,LM) : layer mean vertical velocity in cb/sec ! -! slmsk (IM) : sea/land mask array (sea:0,land:1,sea-ice:2) ! -! xlon,xlat (IM) : grid longitude/latitude in radians ! -! tsfc (IM) : surface temperature in k ! -! snowd (IM) : snow depth water equivalent in mm ! -! sncovr(IM) : snow cover in fraction ! -! snoalb(IM) : maximum snow albedo in fraction ! -! zorl (IM) : surface roughness in cm ! -! hprim (IM) : topographic standard deviation in m ! -! alvsf (IM) : mean vis albedo with strong cosz dependency ! -! alnsf (IM) : mean nir albedo with strong cosz dependency ! -! alvwf (IM) : mean vis albedo with weak cosz dependency ! -! alnwf (IM) : mean nir albedo with weak cosz dependency ! -! facsf (IM) : fractional coverage with strong cosz dependen ! -! facwf (IM) : fractional coverage with weak cosz dependency ! -! fice (IM) : ice fraction over open water grid ! -! tisfc (IM) : surface temperature over ice fraction ! -! solcon : solar constant (sun-earth distant adjusted) ! -! coszen(IM) : mean cos of zenith angle over rad call period ! -! coszdg(IM) : daytime mean cosz over rad call period ! -! k1oz,k2oz,facoz : parameters for climatological ozone ! -! cv (IM) : fraction of convective cloud ! -! cvt, cvb (IM) : convective cloud top/bottom pressure in cb ! -! iovrsw/iovrlw : control flag for cloud overlap (sw/lw rad) ! -! =0 random overlapping clouds ! -! =1 max/ran overlapping clouds ! -! fcice : fraction of cloud ice (in ferrier scheme) ! -! frain : fraction of rain water (in ferrier scheme) ! -! rrime : mass ratio of total to unrimed ice ( >= 1 ) ! -! flgmin : minimim large ice fraction ! -! np3d : =3 brad ferrier microphysics scheme ! -! =4 zhao/carr/sundqvist microphysics scheme ! -! ntcw : =0 no cloud condensate calculated ! -! >0 array index location for cloud condensate ! -! ncld : only used when ntcw .gt. 0 ! -! ntoz : =0 climatological ozone profile ! -! >0 interactive ozone profile ! -! NTRAC : dimension veriable for array oz ! -! NFXR : second dimension of input/output array fluxr ! -! dtlw, dtsw : time duration for lw/sw radiation call in sec ! -! lsswr, lslwr : logical flags for sw/lw radiation calls ! -! lssav : logical flag for store 3-d cloud field ! -! ldiag3d : logical flag for store 3-d diagnostic fields ! -! sashal : logical flag for Jongil's shallow convection ! -! norad_precip : logical flag for not using precip in radiation ! -! crick_proof : logical flag for eliminating CRICK ! -! ccnorm : logical flag for incloud condensate mixing ratio! -! lggfs3d : logical flag for storing 3d fields for GOCART ! -! IX,IM : horizontal dimention and num of used points ! -! LM : vertical layer dimension ! -! iflip : control flag for in/out vertical indexing ! -! =0 index from toa to surface ! -! =1 index from surface to toa ! -! me : control flag for parallel process ! -! lprnt : control flag for diagnostic print out ! -! ! -! output variables: ! -! htrsw (IX,LM) : total sky sw heating rate in k/sec ! -! sfcnsw(IM) : total sky surface net sw flux in w/m**2 ! -! sfcdsw(IM) : total sky surface downward sw flux in w/m**2 ! -! sfalb (IM) : mean surface diffused albedo ! -! htrlw (IX,LM) : total sky lw heating rate in k/sec ! -! sfcdlw(IM) : total sky surface downward lw flux in w/m**2 ! -! tsflw (IM) : surface air temp during lw calculation in k ! -! ! -! input and output variables: ! -! fluxr (IX,NFXR) : to save 2-d fields ! -! cldcov(IX,LM) : to save 3-d cloud fraction ! -! ! -! optional output variables: ! -! htrswb(IX,LM,NBDSW) : spectral band total sky sw heating rate ! -! htrlwb(IX,LM,NBDLW) : spectral band total sky lw heating rate ! -! ! -! ! -! definitions of internal variable arrays: ! -! ! -! 1. fixed gases: (defined in 'module_radiation_gases') ! -! gasvmr(:,:,1) - co2 volume mixing ratio ! -! gasvmr(:,:,2) - n2o volume mixing ratio ! -! gasvmr(:,:,3) - ch4 volume mixing ratio ! -! gasvmr(:,:,4) - o2 volume mixing ratio ! -! gasvmr(:,:,5) - co volume mixing ratio ! -! gasvmr(:,:,6) - cf11 volume mixing ratio ! -! gasvmr(:,:,7) - cf12 volume mixing ratio ! -! gasvmr(:,:,8) - cf22 volume mixing ratio ! -! gasvmr(:,:,9) - ccl4 volume mixing ratio ! -! ! -! 2. cloud profiles: (defined in 'module_radiation_clouds') ! -! --- for prognostic cloud --- ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud liq water path ! -! clouds(:,:,3) - mean effective radius for liquid cloud ! -! clouds(:,:,4) - layer cloud ice water path ! -! clouds(:,:,5) - mean effective radius for ice cloud ! -! clouds(:,:,6) - layer rain drop water path ! -! clouds(:,:,7) - mean effective radius for rain drop ! -! clouds(:,:,8) - layer snow flake water path ! -! clouds(:,:,9) - mean effective radius for snow flake ! -! --- for diagnostic cloud --- ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud optical depth ! -! clouds(:,:,3) - layer cloud single scattering albedo ! -! clouds(:,:,4) - layer cloud asymmetry factor ! -! ! -! 3. surface albedo: (defined in 'module_radiation_surface') ! -! sfcalb( :,1 ) - near ir direct beam albedo ! -! sfcalb( :,2 ) - near ir diffused albedo ! -! sfcalb( :,3 ) - uv+vis direct beam albedo ! -! sfcalb( :,4 ) - uv+vis diffused albedo ! -! ! -! 4. sw aerosol profiles: (defined in 'module_radiation_aerosols') ! -! faersw(:,:,:,1)- sw aerosols optical depth ! -! faersw(:,:,:,2)- sw aerosols single scattering albedo ! -! faersw(:,:,:,3)- sw aerosols asymmetry parameter ! -! ! -! 5. lw aerosol profiles: (defined in 'module_radiation_aerosols') ! -! faerlw(:,:,:,1)- lw aerosols optical depth ! -! faerlw(:,:,:,2)- lw aerosols single scattering albedo ! -! faerlw(:,:,:,3)- lw aerosols asymmetry parameter ! -! ! -! 6. sw fluxes at toa: (defined in 'module_radsw_main') ! -! (topfsw_type -- derived data type for toa rad fluxes) ! -! topfsw(:)%upfxc - total sky upward flux at toa ! -! topfsw(:)%dnfxc - total sky downward flux at toa ! -! topfsw(:)%upfx0 - clear sky upward flux at toa ! -! ! -! 7. lw fluxes at toa: (defined in 'module_radlw_main') ! -! (topflw_type -- derived data type for toa rad fluxes) ! -! topflw(:)%upfxc - total sky upward flux at toa ! -! topflw(:)%upfx0 - clear sky upward flux at toa ! -! ! -! 8. sw fluxes at sfc: (defined in 'module_radsw_main') ! -! (sfcfsw_type -- derived data type for sfc rad fluxes) ! -! sfcfsw(:)%upfxc - total sky upward flux at sfc ! -! sfcfsw(:)%dnfxc - total sky downward flux at sfc ! -! sfcfsw(:)%upfx0 - clear sky upward flux at sfc ! -! sfcfsw(:)%dnfx0 - clear sky downward flux at sfc ! -! ! -! 9. lw fluxes at sfc: (defined in 'module_radlw_main') ! -! (sfcflw_type -- derived data type for sfc rad fluxes) ! -! sfcflw(:)%upfxc - total sky upward flux at sfc ! -! sfcflw(:)%dnfxc - total sky downward flux at sfc ! -! sfcflw(:)%dnfx0 - clear sky downward flux at sfc ! -! ! -!! optional radiation outputs: ! -!! 10. sw flux profiles: (defined in 'module_radsw_main') ! -!! (profsw_type -- derived data type for rad vertical profiles) ! -!! fswprf(:,:)%upfxc - total sky upward flux ! -!! fswprf(:,:)%dnfxc - total sky downward flux ! -!! fswprf(:,:)%upfx0 - clear sky upward flux ! -!! fswprf(:,:)%dnfx0 - clear sky downward flux ! -!! ! -!! 11. lw flux profiles: (defined in 'module_radlw_main') ! -!! (proflw_type -- derived data type for rad vertical profiles) ! -!! flwprf(:,:)%upfxc - total sky upward flux ! -!! flwprf(:,:)%dnfxc - total sky downward flux ! -!! flwprf(:,:)%upfx0 - clear sky upward flux ! -!! flwprf(:,:)%dnfx0 - clear sky downward flux ! -!! ! -!! 12. sw sfc components: (defined in 'module_radsw_main') ! -!! (cmpfsw_type -- derived data type for component sfc fluxes) ! -!! scmpsw(:)%uvbfc - total sky downward uv-b flux at sfc ! -!! scmpsw(:)%uvbf0 - clear sky downward uv-b flux at sfc ! -!! scmpsw(:)%nirbm - total sky sfc downward nir direct flux ! -!! scmpsw(:)%nirdf - total sky sfc downward nir diffused flux ! -!! scmpsw(:)%visbm - total sky sfc downward uv+vis direct flx ! -!! scmpsw(:)%visdf - total sky sfc downward uv+vis diff flux ! -! ! -! ====================== end of definations ======================= ! -! - implicit none - -! --- constant parameter - -! --- inputs: (horizontal dimensioned by IX) - integer, intent(in) :: IX,IM, LM, NTRAC,NFXR, iflip, me, & - & k1oz, k2oz, iovrsw, iovrlw, np3d, ntoz, ntcw, ncld - - logical, intent(in) :: lsswr, lslwr, lssav, ldiag3d, lprnt, & - & sashal, norad_precip, crick_proof, ccnorm,& - & lggfs3d - - real (kind=kind_phys), dimension(IX,LM+1), intent(in) :: prsi - - real (kind=kind_phys), dimension(IX,LM), intent(in) :: prsl, & - & prslk, tgrs, qgrs, vvl, fcice, frain, rrime - real (kind=kind_phys), dimension(IM), intent(in) :: flgmin - real (kind=kind_phys) sscal(LM,14) - real (kind=kind_phys) asymp(LM,14) - real (kind=kind_phys) ext_cof(LM,14) - real (kind=kind_phys) extlw_cof(LM,16) - - - real (kind=kind_phys), dimension(IM), intent(in) :: slmsk, & - & xlon, xlat, tsfc, snowd, zorl, hprim, alvsf, alnsf, alvwf, & - & alnwf, facsf, facwf, coszen, coszdg, cv, cvt, cvb, fice, & - & tisfc, sncovr, snoalb - - real (kind=kind_phys), intent(in) :: solcon, facoz, dtlw, dtsw, & - & oz(IX,LM,NTRAC) - -! --- outputs: (horizontal dimensioned by IX) - real (kind=kind_phys), dimension(IX,LM),intent(out):: htrsw,htrlw - - real (kind=kind_phys), dimension(IM), intent(out):: sfcnsw, & - & sfcdlw, tsflw, sfcdsw, sfalb - -! --- variables are for both input and output: - real (kind=kind_phys), intent(inout) :: & - & fluxr(IX,NFXR), cldcov(IX,LM) - -!! --- optional outputs: - real (kind=kind_phys), dimension(IX,LM,NBDSW), optional, & - & intent(out) :: htrswb - real (kind=kind_phys), dimension(IX,LM,NBDLW), optional, & - & intent(out) :: htrlwb - -! --- local variables: (horizontal dimensioned by IM) - real (kind=kind_phys), dimension(IM,LM+1) :: plvl, tlvl - - real (kind=kind_phys), dimension(IM,LM) :: plyr, tlyr, qlyr, & - & olyr, rhly, qstl, vvel, clw, tem2da, tem2db - - real (kind=kind_phys), dimension(IM) :: tsfa, cvt1, cvb1, tem1d, & - & sfcemis - - real (kind=kind_phys), dimension(IM,LM,NF_CLDS) :: clouds - real (kind=kind_phys), dimension(IM,LM,NF_VGAS) :: gasvmr - real (kind=kind_phys), dimension(IM, NF_ALBD) :: sfcalb - - real (kind=kind_phys), dimension(IM,LM,NBDSW,NF_AESW) :: faersw - real (kind=kind_phys), dimension(IM,LM,NBDLW,NF_AELW) :: faerlw - - real (kind=kind_phys), dimension(IM,LM) :: htswc - real (kind=kind_phys), dimension(IM,LM) :: htlwc - - type (topfsw_type), dimension(IM) :: topfsw - type (topflw_type), dimension(IM) :: topflw - - type (sfcfsw_type), dimension(IM) :: sfcfsw - type (sfcflw_type), dimension(IM) :: sfcflw - -!! --- may be used for optional sw/lw outputs: -!! take out "!!" as needed -!! real (kind=kind_phys), dimension(IM,LM) :: htsw0 -!! type (profsw_type), dimension(IM,LM+1) :: fswprf - type (cmpfsw_type), dimension(IM) :: scmpsw - real (kind=kind_phys), dimension(IM,LM,NBDSW) :: htswb - -!! real (kind=kind_phys), dimension(IM,LM) :: htlw0 -!! type (proflw_type), dimension(IM,LM+1) :: flwprf - real (kind=kind_phys), dimension(IM,LM,NBDLW) :: htlwb - - real (kind=kind_phys) :: raddt, es, qs, delt, tem0d, cldsa(IM,5) - - integer :: i, j, k, k1, lv, icec, itop, ibtc, nday, idxday(IM), & - & mbota(IM,3), mtopa(IM,3), LP1 - -! --- for debug test use -! real (kind=kind_phys) :: temlon, temlat, alon, alat -! integer :: ipt -! logical :: lprnt1 - -! -!===> ... begin here -! - LP1 = LM + 1 - - raddt = min(dtsw, dtlw) - -! --- ... for debug test -! alon = 120.0 -! alat = 29.5 -! ipt = 0 -! do i = 1, IM -! temlon = xlon(i) * 57.29578 -! if (temlon < 0.0) temlon = temlon + 360.0 -! temlat = xlat(i) * 57.29578 -! lprnt1 = abs(temlon-alon) < 1.1 .and. abs(temlat-alat) < 1.1 -! if ( lprnt1 ) then -! ipt = i -! exit -! endif -! enddo - -! print *,' in grrad : raddt=',raddt -! --- ... compute relative humidity - - do k = 1, LM - do i = 1, IM - es = min( prsl(i,k), 0.001 * fpvs( tgrs(i,k) ) ) ! fpvs in pa - qs = max( QMIN, con_eps * es / (prsl(i,k) + con_epsm1*es) ) - rhly(i,k) = max( 0.0, min( 1.0, max(QMIN, qgrs(i,k))/qs ) ) - qstl(i,k) = qs - enddo - enddo - -! --- ... get layer ozone mass mixing ratio - - if (ntoz > 0) then ! interactive ozone generation - - do k = 1, LM - do i = 1, IM - olyr(i,k) = oz(i,k,ntoz) - enddo - enddo - - else ! climatological ozone - - do k = 1, LM - do i = 1, IM - tem2da(i,k) = prslk(i,k) - enddo - enddo - -! print *,' in grrad : calling getozn' - call getozn & -! --- inputs: - & ( tem2da,xlat,k1oz,k2oz,facoz, & - & IM, LM, iflip, & -! --- outputs: - & olyr & - & ) - - endif ! end_if_ntoz - -! --- ... prepare atmospheric profiles for radiation input -! convert pressure unit from cb to mb - - do k = 1, LM - do i = 1, IM - plvl(i,k) = 10.0 * prsi(i,k) - plyr(i,k) = 10.0 * prsl(i,k) - vvel(i,k) = 10.0 * vvl (i,k) - tlyr(i,k) = tgrs(i,k) - olyr(i,k) = max( QMIN, olyr(i,k) ) - enddo - enddo - - do i = 1, IM - plvl(i,LP1) = 10.0 * prsi(i,LP1) - enddo - -! --- ... set up non-prognostic gas volume mixing ratioes - - call getgases & -! --- inputs: - & ( plvl, xlon, xlat, & - & IM, LM, iflip, & -! --- outputs: - & gasvmr & - & ) - -! --- ... get temperature at layer interface, and layer moisture - - do k = 2, LM - do i = 1, IM - tem2da(i,k) = log( plyr(i,k) ) - tem2db(i,k) = log( plvl(i,k) ) - enddo - enddo - - if (iflip == 0) then ! input data from toa to sfc - - do i = 1, IM - tem1d (i) = QME6 - tem2da(i,1) = log( plyr(i,1) ) - tem2db(i,1) = 1.0 - tsfa (i) = tlyr(i,LM) ! sfc layer air temp - tlvl(i,1) = tlyr(i,1) - tlvl(i,LP1) = tsfc(i) - enddo - - do k = 1, LM - do i = 1, IM - qlyr(i,k) = max( tem1d(i), qgrs(i,k) ) - tem1d(i) = min( QME5, qlyr(i,k) ) - enddo - enddo - - do k = 2, LM - do i = 1, IM - tlvl(i,k) = tlyr(i,k) + (tlyr(i,k-1) - tlyr(i,k)) & - & * (tem2db(i,k) - tem2da(i,k)) & - & / (tem2da(i,k-1) - tem2da(i,k)) - enddo - enddo - - else ! input data from sfc to toa - - do i = 1, IM - tem1d (i) = QME6 - tem2da(i,1) = log( plyr(i,1) ) - tem2db(i,1) = log( plvl(i,1) ) - tsfa (i) = tlyr(i,1) ! sfc layer air temp - tlvl(i,1) = tsfc(i) - tlvl(i,LP1) = tlyr(i,LM) - enddo - - do k = LM, 1, -1 - do i = 1, IM - qlyr(i,k) = max( tem1d(i), qgrs(i,k) ) - tem1d(i) = min( QME5, qlyr(i,k) ) - enddo - enddo - - do k = 1, LM-1 - do i = 1, IM - tlvl(i,k+1) = tlyr(i,k) + (tlyr(i,k+1) - tlyr(i,k)) & - & * (tem2db(i,k+1) - tem2da(i,k)) & - & / (tem2da(i,k+1) - tem2da(i,k)) - enddo - enddo - - endif ! end_if_iflip - -! --- check for daytime points - - nday = 0 - do i = 1, IM - if (coszen(i) >= 0.0001) then - nday = nday + 1 - idxday(nday) = i - endif - enddo - -! --- ... setup aerosols property profile for radiation - - faersw(:,:,:,:) = 0.0 - faerlw(:,:,:,:) = 0.0 - - if (iaersw==1 .or. iaerlw==1) then - -!check print *,' in grrad : calling setaer ' - - call setaer & -! --- inputs: - & ( xlon,xlat,plvl,plyr,tlyr,qlyr,rhly, & - & IM,LM,LP1, iflip, lsswr,lslwr, & -! --- outputs: - & faersw,faerlw & - & ) -! this number ("currently set to 2") needs to be defined. -! if(iaersw == 2)then - if(sscal(1,1).lt.100)then -! write(6,*)'overwriting aerosol optical props',im,ix - do k = 1, LM - do i = 1, IM - faerlw(i,k,:,1)=extlw_cof(k,:) - faersw(i,k,:,1)=ext_cof(k,:) - faersw(i,k,:,2)=sscal(k,:) - faersw(i,k,:,3)=asymp(k,:) - enddo - enddo - endif - - endif ! end_if_iaersw_iaerlw - -! --- ... obtain cloud information for radiation calculations - - if (ntcw > 0) then ! prognostic cloud scheme - - do k = 1, LM - do i = 1, IM - clw(i,k) = 0.0 - enddo - - do j = 1, ncld - lv = ntcw + j - 1 - do i = 1, IM - clw(i,k) = clw(i,k) + oz(i,k,lv) ! cloud condensate amount - enddo - enddo - enddo - - where (clw < EPSQ) - clw = 0.0 - endwhere - - if (np3d == 4) then ! zhao/moorthi's prognostic cloud scheme - - call progcld1 & -! --- inputs: - & ( plyr,plvl,tlyr,qlyr,qstl,rhly,clw, & - & xlat,xlon,slmsk, & - & IM, LM, LP1, iflip, iovrsw, sashal, crick_proof, ccnorm, & -! & IM, LM, LP1, iflip, iovrsw, & -! --- outputs: - & clouds,cldsa,mtopa,mbota & - & ) - - elseif (np3d == 3) then ! ferrier's microphysics - -! print *,' in grrad : calling progcld2' - call progcld2 & -! --- inputs: - & ( plyr,plvl,tlyr,qlyr,qstl,rhly,clw, & - & xlat,xlon,slmsk, fcice,frain,rrime,flgmin, & - & IM, LM, LP1, iflip, iovrsw, sashal, norad_precip, & - & crick_proof, ccnorm, & -! & IM, LM, LP1, iflip, iovrsw, & -! --- outputs: - & clouds,cldsa,mtopa,mbota & - & ) - - endif ! end if_np3d - - else ! diagnostic cloud scheme - - do i = 1, IM - cvt1(i) = 10.0 * cvt(i) - cvb1(i) = 10.0 * cvb(i) - enddo - -! --- compute diagnostic cloud related quantities - - call diagcld1 & -! --- inputs: - & ( plyr,plvl,tlyr,rhly,vvel,cv,cvt1,cvb1, & - & xlat,xlon,slmsk, & - & IM, LM, LP1, iflip, iovrsw, & -! --- outputs: - & clouds,cldsa,mtopa,mbota & - & ) - - endif ! end_if_ntcw - -! --- ... start radiation calculations -! remember to set heating rate unit to k/sec! - - if (lsswr) then - -! --- setup surface albedo for sw radiation, incl xw (nov04) sea-ice - - call setalb & -! --- inputs: - & ( slmsk,snowd,sncovr,snoalb,zorl,coszen,tsfc,tsfa,hprim, & - & alvsf,alnsf,alvwf,alnwf,facsf,facwf,fice,tisfc, & - & IM, & -! --- outputs: - & sfcalb & - & ) - -! jbao / sgb -! sfcalb = 0.10 ! jbao/sgb - -! --- lu [+4L]: derive SFALB from vis- and nir- diffuse surface albedo - do i = 1, IM - sfalb(i) = max(0.01, 0.5 * (sfcalb(i,2) + sfcalb(i,4))) - enddo - - - if (nday > 0) then - -! print *,' in grrad : calling swrad' - - if ( present(htrswb) ) then - - call swrad & -! --- inputs: - & ( plyr,plvl,tlyr,tlvl,qlyr,olyr,gasvmr, & - & clouds,iovrsw,faersw,sfcalb, & - & coszen,solcon, nday,idxday, & - & IM, LM, LP1, iflip, lprnt, & -! --- outputs: - & htswc,topfsw,sfcfsw & -!! --- optional: -!! &, HSW0=htsw0,FLXPRF=fswprf & - &, HSWB=htswb,FDNCMP=scmpsw & - & ) - - do j = 1, NBDSW - do k = 1, LM - do i = 1, IM - htrswb(i,k,j) = htswb(i,k,j) - enddo - enddo - enddo - - else - - call swrad & -! --- inputs: - & ( plyr,plvl,tlyr,tlvl,qlyr,olyr,gasvmr, & - & clouds,iovrsw,faersw,sfcalb, & - & coszen,solcon, nday,idxday, & - & IM, LM, LP1, iflip, lprnt, & -! --- outputs: - & htswc,topfsw,sfcfsw & -!! --- optional: -!! &, HSW0=htsw0,FLXPRF=fswprf,HSWB=htswb & - &, FDNCMP=scmpsw & - & ) - - endif - - do i = 1, IM - sfcnsw(i) = sfcfsw(i)%upfxc - sfcfsw(i)%dnfxc - sfcdsw(i) = sfcfsw(i)%dnfxc - enddo - - do k = 1, LM - do i = 1, IM - htrsw(i,k) = htswc(i,k) - enddo - enddo - - else ! if_nday_block - - htrsw(:,:) = 0.0 - sfcnsw (:) = 0.0 - sfcdsw (:) = 0.0 - - sfcfsw= sfcfsw_type( 0.0, 0.0, 0.0, 0.0 ) - topfsw= topfsw_type( 0.0, 0.0, 0.0 ) - scmpsw= cmpfsw_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ) - -!! --- optional: -!! fswprf= profsw_type( 0.0, 0.0, 0.0, 0.0 ) - - if ( present(htrswb) ) htrswb(:,:,:) = 0.0 - - endif ! end_if_nday - - endif ! end_if_lsswr - - if (lslwr) then - -! --- save surface air temp for diurnal adjustment at model t-steps - - tsflw(1:IM) = tsfa(1:IM) - -! --- setup surface emissivity for lw radiation - - call setemis & -! --- inputs: - & ( xlon,xlat,slmsk,snowd,sncovr,zorl,tsfc,tsfa,hprim, & - & IM, & -! --- outputs: - & sfcemis & - & ) - -! print *,' in grrad : calling lwrad' - - if ( present(htrlwb) ) then - - call lwrad & -! --- inputs: - & ( plyr,plvl,tlyr,tlvl,qlyr,olyr,gasvmr, & - & clouds,iovrlw,faerlw,sfcemis, & - & IM, LM, LP1, iflip, lprnt, & -! --- outputs: - & htlwc,topflw,sfcflw & -!! --- optional: -!! &, HLW0=htlw0,FLXPRF=flwprf & - &, HLWB=htlwb & - & ) - - do j = 1, NBDLW - do k = 1, LM - do i = 1, IM - htrlwb(i,k,j) = htlwb(i,k,j) - enddo - enddo - enddo - - else - - call lwrad & -! --- inputs: - & ( plyr,plvl,tlyr,tlvl,qlyr,olyr,gasvmr, & - & clouds,iovrlw,faerlw,sfcemis, & - & IM, LM, LP1, iflip, lprnt, & -! --- outputs: - & htlwc,topflw,sfcflw & -!! --- optional: -!! &, HLW0=htlw0,FLXPRF=flwprf,HLWB=htlwb & - & ) - - endif - - do i = 1, IM - sfcdlw(i) = sfcflw(i)%dnfxc -! --- save surface air temp for diurnal adjustment at model t-steps - tsflw (i) = tsfa(i) - enddo - - do k = 1, LM - do i = 1, IM - htrlw(i,k) = htlwc(i,k) - enddo - enddo - - endif ! end_if_lslwr - -! --- ... collect the fluxr data for wrtsfc - -! --- in previous codes, fluxr(17) contained various attempts at -! calculating surface albedo...it has proven unsatisfactory!! -! so now, sfc albedo will be calculated in wrtsfc as the -! ratio of the time-mean of the sfcsw fluxes .. kac+mi dec98 - - if (lssav) then - - if (lslwr) then - do i = 1, IM - fluxr(i,1 ) = topflw(i)%upfxc ! jwb fluxr(i,1 ) + dtlw * topflw(i)%upfxc ! total sky top lw up - fluxr(i,19) = fluxr(i,19) + dtlw * sfcflw(i)%dnfxc ! total sky sfc lw dn - fluxr(i,20) = fluxr(i,20) + dtlw * sfcflw(i)%upfxc ! total sky sfc lw up -!*RADFLX* - fluxr(i,28) = fluxr(i,28) + dtlw * topflw(i)%upfx0 ! clear sky top lw up - fluxr(i,30) = fluxr(i,30) + dtlw * sfcflw(i)%dnfx0 ! clear sky sfc lw dn - fluxr(i,33) = fluxr(i,33) + dtlw * sfcflw(i)%upfx0 ! clear sky sfc lw up -!*RADFLX* - enddo - endif - -! --- proper diurnal sw wgt..coszro=mean cosz over daylight, while -! coszdg= mean cosz over entire interval - - if (lsswr) then - do i = 1, IM - if (coszen(i) > 0.) then - tem0d = dtsw * coszdg(i) / coszen(i) - fluxr(i,2 ) = fluxr(i,2) + topfsw(i)%upfxc * tem0d ! total sky top sw up - fluxr(i,3 ) = fluxr(i,3) + sfcfsw(i)%upfxc * tem0d ! total sky sfc sw up - fluxr(i,4 ) = fluxr(i,4) + sfcfsw(i)%dnfxc * tem0d ! total sky sfc sw dn - fluxr(i,18) = fluxr(i,18) + topfsw(i)%dnfxc * tem0d ! total sky top sw dn -! --- sw uv-b fluxes - fluxr(i,21) = fluxr(i,21) + scmpsw(i)%uvbfc * tem0d ! total sky uv-b sw dn - fluxr(i,22) = fluxr(i,22) + scmpsw(i)%uvbf0 * tem0d ! clear sky uv-b sw dn -!*RADFLX* - fluxr(i,29) = fluxr(i,29) + topfsw(i)%upfx0 * tem0d ! clear sky top sw up - fluxr(i,31) = fluxr(i,31) + sfcfsw(i)%upfx0 * tem0d ! clear sky sfc sw up - fluxr(i,32) = fluxr(i,32) + sfcfsw(i)%dnfx0 * tem0d ! clear sky sfc sw dn -!*RADFLX* - endif - enddo - endif - -! --- save total cloud and bl cloud - - if (lsswr .or. lslwr) then - do i = 1, IM - fluxr(i,26) = fluxr(i,26) + raddt * cldsa(i,4) - fluxr(i,27) = fluxr(i,27) + raddt * cldsa(i,5) - enddo - -! --- save cld frac,toplyr,botlyr and top temp, note that the order -! of h,m,l cloud is reversed for the fluxr output. -! --- save interface pressure (cb) of top/bot - - do k = 1, 3 - do i = 1, IM - tem0d = raddt * cldsa(i,k) - itop = mtopa(i,k) - ibtc = mbota(i,k) - fluxr(i, 8-k) = fluxr(i, 8-k) + tem0d - fluxr(i,11-k) = fluxr(i,11-k) + prsi(i,itop+1) * tem0d - fluxr(i,14-k) = fluxr(i,14-k) + prsi(i,ibtc) * tem0d - fluxr(i,17-k) = fluxr(i,17-k) + tgrs(i,itop) * tem0d - enddo - enddo - endif - - if (ldiag3d .or. lggfs3d) then - do k = 1, LM - do i = 1, IM - cldcov(i,k) = cldcov(i,k) + clouds(i,k,1) * raddt - enddo - enddo - endif - - endif ! end_if_lssav -! - return -!................................... - end subroutine grrad -!----------------------------------- - - -! -!........................................! - end module module_radiation_driver ! -!========================================! diff --git a/src/fim/FIMsrc/fim/column/gscond_v.f b/src/fim/FIMsrc/fim/column/gscond_v.f deleted file mode 100644 index c12ca59..0000000 --- a/src/fim/FIMsrc/fim/column/gscond_v.f +++ /dev/null @@ -1,296 +0,0 @@ - SUBROUTINE GSCOND (IM,IX,KM,DT,PRSL,PS,Q,cwm,T - &, tp, qp, psp, tp1, qp1, psp1, u, lprnt, ipr) -! -! ****************************************************************** -! * * -! * SUBROUTINE FOR GRID-SCALE CONDENSATION & EVAPORATION * -! * FOR THE MRF MODEL AT NCEP. * -! * * -! ****************************************************************** -! * * -! * CREATED BY: Q. ZHAO JAN. 1995 * -! * MODIFIED BY: H.-L. PAN SEP. 1998 * -! * MODIFIED BY: S. MOORTHI AUG. 1999, 2000 * -! * * -! * REFERENCES: * -! * * -! ****************************************************************** -!---------------------------------------------------------------------- -!---------------------------------------------------------------------- -! - USE MACHINE , ONLY : kind_phys - USE FUNCPHYS , ONLY : fpvs - USE PHYSCONS, PSAT => con_PSAT, HVAP => con_HVAP, grav => con_g - &, HFUS => con_HFUS, TTP => con_TTP, RD => con_RD - &, CP => con_CP, EPS => con_eps, EPSM1 => con_epsm1 - &, RV => con_RV - implicit none -! - real (kind=kind_phys) G, H1, H2, H1000 - &, D00, D125, D5, ELWV, ELIV - &, EPSQ, TM10, ELIW, ARCP - &, A1, R, CPR, RCPR, RCP - PARAMETER (H1=1.E0, H2=2.E0, H1000=1000.0 - &, D00=0.E0, D125=.125E0, D5=0.5E0 - &, A1=PSAT - &, ELWV=HVAP, ELIV=HVAP+HFUS, G=grav - &, EPSQ=2.E-12, TM10=TTP-10., R=RD - &, CPR=CP*R, RCPR=H1/CPR, RCP=H1/CP) -! - real(kind=kind_phys), parameter :: cons_0=0.0, cons_m15=-15.0 -! - integer IM, IX, KM, ipr - real (kind=kind_phys) Q(IX,KM), T(IX,KM), CWM(IX,KM) - &, PRSL(IX,KM), PS(IM), DT - &, TP(IX,KM), QP(IX,KM), PSP(IM) - &, TP1(IX,KM), QP1(IX,KM), PSP1(IM) -! - real (kind=kind_phys) QI(IM), QINT(IM), U(IM,KM), CCRIK, E0 - &, COND, rdt, us, cclimit, climit - &, u00b, u00t, tmt0, tmt15, qik, cwmik - &, ai, bi, qw, u00ik, tik, pres, pp0, fi - &, at, aq, ap, fiw, elv, qc, rqik - &, rqikk, tx1, tx2, tx3, es, qs - &, tsq, delq, condi, cone0, us00, ccrik1 - &, aa, ab, ac, ad, ae, af, ag - &, el2orc, albycp, vprs(im) - INTEGER IW(IM,KM), i, k, iwik - logical lprnt -! -!-----------------PREPARE CONSTANTS FOR LATER USES----------------- -! - EL2ORC = HVAP*HVAP / (RV*CP) - ALBYCP = HVAP / CP -! - RDT = H1/DT - US = H1 - CCLIMIT = 1.0E-3 - CLIMIT = 1.0E-20 -! - DO I = 1, IM - IW(I,KM) = D00 - enddo -! -! check for first time step -! - if (tp(1,1) .lt. 1.) then - do k = 1, km - do i = 1, im - tp(i,k) = t(i,k) - qp(i,k) = max(q(i,k),epsq) - tp1(i,k) = t(i,k) - qp1(i,k) = max(q(i,k),epsq) - enddo - enddo - do i = 1, im - psp(i) = ps(i) - psp1(i) = ps(i) - enddo - endif -c -C************************************************************* -C*******BEGINING OF GRID-SCALE CONDENSATION/EVAP. LOOP******* -C************************************************************* -C -! DO K = KM-1,2,-1 - DO K = KM,1,-1 -! vprs(:) = 0.001 * fpvs(T(:,k)) ! fpvs in Pa -C----------------------------------------------------------------------- -C------------------QW, QI AND QINT-------------------------------------- - DO I = 1, IM - TMT0 = T(I,K)-273.16 - TMT15 = MIN(TMT0,cons_m15) - QIK = MAX(Q(I,K),EPSQ) - CWMIK = MAX(CWM(I,K),CLIMIT) -! -! AI = 0.008855 -! BI = 1.0 -! IF (TMT0 .LT. -20.0) THEN -! AI = 0.007225 -! BI = 0.9674 -! END IF -! -! the global qsat computation is done in cb - pres = prsl(i,k) -! -! QW = vprs(i) - QW = min(pres, 0.001 * fpvs(T(i,k))) -! - QW = EPS * QW / (PRES + EPSM1 * QW) - QW = MAX(QW,EPSQ) -! QI(I) = QW *(BI+AI*MIN(TMT0,cons_0)) -! QINT(I) = QW *(1.-0.00032*TMT15*(TMT15+15.)) - qi(i) = qw - qint(i) = qw -! IF (TMT0 .LE. -40.) QINT(I) = QI(I) -C-------------------ICE-WATER ID NUMBER IW------------------------------ - IF(TMT0.LT.-15.0) THEN - U00IK = U(I,K) - FI = QIK - U00IK*QI(I) - IF(FI.GT.D00.OR.CWMIK.GT.CLIMIT) THEN - IW(I,K) = 1 - ELSE - IW(I,K) = 0 - END IF - END IF -C - IF(TMT0.GE.0.0) THEN - IW(I,K) = 0 - END IF -C - IF (TMT0 .LT. 0.0 .AND. TMT0 .GE. -15.0) THEN - IW(I,K) = 0 - if (k .lt. km) then - IF (IW(I,K+1) .EQ. 1 .AND. CWMIK .GT. CLIMIT) IW(I,K) = 1 - endif - END IF - enddo -C--------------CONDENSATION AND EVAPORATION OF CLOUD-------------------- - DO I = 1, IM -C------------------------AT, AQ AND DP/DT------------------------------- - QIK = MAX(Q(I,K),EPSQ) - CWMIK = MAX(CWM(I,K),CLIMIT) - IWIK = IW(I,K) - U00IK = U(I,K) - TIK = T(I,K) - PRES = PRSL(I,K) * H1000 - PP0 = (PRES / PS(I)) * PSP(I) - AT = (TIK-TP(I,K)) * RDT - AQ = (QIK-QP(I,K)) * RDT - AP = (PRES-PP0) * RDT -C----------------THE SATUATION SPECIFIC HUMIDITY------------------------ - FIW = FLOAT(IWIK) - ELV = (H1-FIW)*ELWV + FIW*ELIV - QC = (H1-FIW)*QINT(I) + FIW*QI(I) -! if (lprnt) print *,' qc=',qc,' qint=',qint(i),' qi=',qi(i) -C----------------THE RELATIVE HUMIDITY---------------------------------- - IF(QC.LE.1.0E-10) THEN - RQIK=D00 - ELSE - RQIK = QIK/QC - ENDIF -C----------------CLOUD COVER RATIO CCRIK-------------------------------- - IF (RQIK .LT. U00IK) THEN - CCRIK = D00 - ELSEIF(RQIK.GE.US) THEN - CCRIK = US - ELSE - RQIKK = MIN(US,RQIK) - CCRIK = H1-SQRT((US-RQIKK)/(US-U00IK)) - ENDIF -C-----------CORRECT CCR IF IT IS TOO SMALL IN LARGE CWM REGIONS-------- -c IF(CCRIK.GE.0.01.AND.CCRIK.LE.0.2.AND -c & .CWMIK.GE.0.2E-3) THEN -c CCRIK=MIN(1.0,CWMIK*1.0E3) -c END IF -C---------------------------------------------------------------------- -! If no cloud exists then evaporate any existing cloud condensate -C----------------EVAPORATION OF CLOUD WATER----------------------------- - E0 = D00 - IF (CCRIK.LE.CCLIMIT.AND.CWMIK.GT.CLIMIT) THEN -! -! First iteration - increment halved -! - tx1 = tik - tx3 = qik -! - es = min(pres, fpvs(tx1)) - qs = u00ik * eps * ES / (pres + epsm1*es) - tsq = tx1 * tx1 - delq = 0.5 * (qs - tx3) * tsq / (tsq + EL2ORC * QS) -! - tx2 = delq - tx1 = tx1 - delq * ALBYCP - tx3 = tx3 + delq -! -! Second iteration -! - es = min(pres, fpvs(tx1)) - qs = u00ik * eps * ES / (pres + epsm1*es) - tsq = tx1 * tx1 - delq = (qs - tx3) * tsq / (tsq + EL2ORC * QS) -! - tx2 = tx2 + delq - tx1 = tx1 - delq * ALBYCP - tx3 = tx3 + delq -! -! Third iteration -! - es = min(pres, fpvs(tx1)) - qs = u00ik * eps * ES / (pres + epsm1*es) - tsq = tx1 * tx1 - delq = (qs - tx3) * tsq / (tsq + EL2ORC * QS) - tx2 = tx2 + delq -! - E0 = Max(tx2*RDT, cons_0) -! if (lprnt .and. i .eq. ipr .and. k .eq. 34) -! & print *,' tx2=',tx2,' qc=',qc,' u00ik=',u00ik,' rqik=',rqik -! &,' cwmik=',cwmik,' e0',e0 - -! E0 = MAX(QC*(U00IK-RQIK)*RDT, cons_0) - E0 = MIN(CWMIK*RDT, E0) - E0 = MAX(cons_0,E0) - END IF -! If cloud cover > 0.2 condense water vapor in to cloud condensate -C-----------THE EQS. FOR COND. HAS BEEN REORGANIZED TO REDUCE CPU------ - COND = D00 -! IF (CCRIK .GT. 0.20 .AND. QC .GT. EPSQ) THEN - IF (CCRIK .GT. CCLIMIT .AND. QC .GT. EPSQ) THEN - US00 = US - U00IK - CCRIK1 = 1.0 - CCRIK - AA = EPS*ELV*PRES*QIK - AB = CCRIK*CCRIK1*QC*US00 - AC = AB + 0.5*CWMIK - AD = AB * CCRIK1 - AE = CPR*TIK*TIK - AF = AE * PRES - AG = AA * ELV - AI = CP * AA - COND = (AC-AD)*(AF*AQ-AI*AT+AE*QIK*AP)/(AC*(AF+AG)) -C-----------CHECK & CORRECT IF OVER CONDENSATION OCCURS----------------- - CONDI = (QIK -U00IK *QC*1.0)*RDT - COND = MIN(COND, CONDI) -C----------CHECK & CORRECT IF SUPERSATUATION IS TOO HIGH---------------- -c QTEMP=QIK-MAX(0.,(COND-E0))*DT -c IF(QC.LE.1.0E-10) THEN -c RQTMP=0.0 -c ELSE -c RQTMP=QTEMP/QC -c END IF -c IF(RQTMP.GE.1.10) THEN -c COND=(QIK-1.10*QC)*RDT -c END IF -C----------------------------------------------------------------------- - COND = MAX(COND, D00) -C-------------------UPDATE OF T, Q AND CWM------------------------------ - END IF - CONE0 = (COND-E0) * DT - CWM(I,K) = CWM(I,K) + CONE0 -! if (lprnt .and. i .eq. ipr) print *,' t=',t(i,k),' cone0',cone0 -! &,' cond=',cond,' e0=',e0,' elv=',elv,' rcp=',rcp,' k=',k -! &,' cwm=',cwm(i,k) - T(I,K) = T(I,K) + ELV*RCP*CONE0 - Q(I,K) = Q(I,K) - CONE0 - enddo ! End of I-Loop! - enddo ! End of K-Loop! -C -C********************************************************************* -C****************END OF THE CONDENSATION/EVAPORATION LOOP************* -C********************************************************************* -C----------------store t, q, ps for next time step - do k = 1, km - do i = 1, im - tp(i,k) = tp1(i,k) - qp(i,k) = qp1(i,k) -! - tp1(i,k) = t(i,k) - qp1(i,k) = max(q(i,k),epsq) - enddo - enddo - do i = 1, im - psp(i) = psp1(i) - psp1(i) = ps(i) - enddo -C----------------------------------------------------------------------- - RETURN - END diff --git a/src/fim/FIMsrc/fim/column/gsmcolumn_v.f b/src/fim/FIMsrc/fim/column/gsmcolumn_v.f deleted file mode 100644 index ffd6f5e..0000000 --- a/src/fim/FIMsrc/fim/column/gsmcolumn_v.f +++ /dev/null @@ -1,1568 +0,0 @@ -! -!############################################################################### -! ***** VERSION OF MICROPHYSICS DESIGNED FOR HIGHER RESOLUTION MESO ETA MODEL -! (1) Represents sedimentation by preserving a portion of the precipitation -! through top-down integration from cloud-top. Modified procedure to -! Zhao and Carr (1997). -! (2) Microphysical equations are modified to be less sensitive to time -! steps by use of Clausius-Clapeyron equation to account for changes in -! saturation mixing ratios in response to latent heating/cooling. -! (3) Prevent spurious temperature oscillations across 0C due to -! microphysics. -! (4) Uses lookup tables for: calculating two different ventilation -! coefficients in condensation and deposition processes; accretion of -! cloud water by precipitation; precipitation mass; precipitation rate -! (and mass-weighted precipitation fall speeds). -! (5) Assumes temperature-dependent variation in mean diameter of large ice -! (Houze et al., 1979; Ryan et al., 1996). -! -> 8/22/01: This relationship has been extended to colder temperatures -! to parameterize smaller large-ice particles down to mean sizes of MDImin, -! which is 50 microns reached at -55.9C. -! (6) Attempts to differentiate growth of large and small ice, mainly for -! improved transition from thin cirrus to thick, precipitating ice -! anvils. -! -> 8/22/01: This feature has been diminished by effectively adjusting to -! ice saturation during depositional growth at temperatures colder than -! -10C. Ice sublimation is calculated more explicitly. The logic is -! that sources of are either poorly understood (e.g., nucleation for NWP) -! or are not represented in the Eta model (e.g., detrainment of ice from -! convection). Otherwise the model is too wet compared to the radiosonde -! observations based on 1 Feb - 18 March 2001 retrospective runs. -! (7) Top-down integration also attempts to treat mixed-phase processes, -! allowing a mixture of ice and water. Based on numerous observational -! studies, ice growth is based on nucleation at cloud top & -! subsequent growth by vapor deposition and riming as the ice particles -! fall through the cloud. Effective nucleation rates are a function -! of ice supersaturation following Meyers et al. (JAM, 1992). -! -> 8/22/01: The simulated relative humidities were far too moist compared -! to the rawinsonde observations. This feature has been substantially -! diminished, limited to a much narrower temperature range of 0 to -10C. -! (8) Depositional growth of newly nucleated ice is calculated for large time -! steps using Fig. 8 of Miller and Young (JAS, 1979), at 1 deg intervals -! using their ice crystal masses calculated after 600 s of growth in water -! saturated conditions. The growth rates are normalized by time step -! assuming 3D growth with time**1.5 following eq. (6.3) in Young (1993). -! -> 8/22/01: This feature has been effectively limited to 0 to -10C. -! (9) Ice precipitation rates can increase due to increase in response to -! cloud water riming due to (a) increased density & mass of the rimed -! ice, and (b) increased fall speeds of rimed ice. -! -> 8/22/01: This feature has been effectively limited to 0 to -10C. -!############################################################################### -!############################################################################### -! - SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, - & LSFC, P_col, QI_col, QR_col, QV_col, QW_col, RimeF_col, T_col, - & THICK_col, WC_col, LM, RHC_col, XNCW, PRINT_diag) -! -!############################################################################### -!############################################################################### -! -!------------------------------------------------------------------------------- -!----- NOTE: Code is currently set up w/o threading! -!------------------------------------------------------------------------------- -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: Grid-scale microphysical processes - condensation & precipitation -! PRGRMMR: Ferrier ORG: W/NP22 DATE: 08-2001 -!------------------------------------------------------------------------------- -! ABSTRACT: -! * Merges original GSCOND & PRECPD subroutines. -! * Code has been substantially streamlined and restructured. -! * Exchange between water vapor & small cloud condensate is calculated using -! the original Asai (1965, J. Japan) algorithm. See also references to -! Yau and Austin (1979, JAS), Rutledge and Hobbs (1983, JAS), and Tao et al. -! (1989, MWR). This algorithm replaces the Sundqvist et al. (1989, MWR) -! parameterization. -!------------------------------------------------------------------------------- -! -! USAGE: -! * CALL GSMCOLUMN FROM SUBROUTINE GSMDRIVE -! * SUBROUTINE GSMDRIVE CALLED FROM MAIN PROGRAM EBU -! -! INPUT ARGUMENT LIST: -! DTPH - physics time step (s) -! I_index - I index -! J_index - J index -! LSFC - Eta level of level above surface, ground -! P_col - vertical column of model pressure (Pa) -! QI_col - vertical column of model ice mixing ratio (kg/kg) -! QR_col - vertical column of model rain ratio (kg/kg) -! QV_col - vertical column of model water vapor specific humidity (kg/kg) -! QW_col - vertical column of model cloud water mixing ratio (kg/kg) -! RimeF_col - vertical column of rime factor for ice in model (ratio, defined below) -! T_col - vertical column of model temperature (deg K) -! THICK_col - vertical column of model mass thickness (density*height increment) -! WC_col - vertical column of model mixing ratio of total condensate (kg/kg) -! -! -! OUTPUT ARGUMENT LIST: -! ARAIN - accumulated rainfall at the surface (kg) -! ASNOW - accumulated snowfall at the surface (kg) -! QV_col - vertical column of model water vapor specific humidity (kg/kg) -! WC_col - vertical column of model mixing ratio of total condensate (kg/kg) -! QW_col - vertical column of model cloud water mixing ratio (kg/kg) -! QI_col - vertical column of model ice mixing ratio (kg/kg) -! QR_col - vertical column of model rain ratio (kg/kg) -! RimeF_col - vertical column of rime factor for ice in model (ratio, defined below) -! T_col - vertical column of model temperature (deg K) -! -! OUTPUT FILES: -! NONE -! -! Subprograms & Functions called: -! * Real Function CONDENSE - cloud water condensation -! * Real Function DEPOSIT - ice deposition (not sublimation) -! -! UNIQUE: NONE -! -! LIBRARY: NONE -! -! COMMON BLOCKS: -! CMICRO_CONS - key constants initialized in GSMCONST -! CMICRO_STATS - accumulated and maximum statistics -! CMY_GROWTH - lookup table for growth of ice crystals in -! water saturated conditions (Miller & Young, 1979) -! IVENT_TABLES - lookup tables for ventilation effects of ice -! IACCR_TABLES - lookup tables for accretion rates of ice -! IMASS_TABLES - lookup tables for mass content of ice -! IRATE_TABLES - lookup tables for precipitation rates of ice -! IRIME_TABLES - lookup tables for increase in fall speed of rimed ice -! RVENT_TABLES - lookup tables for ventilation effects of rain -! RACCR_TABLES - lookup tables for accretion rates of rain -! RMASS_TABLES - lookup tables for mass content of rain -! RVELR_TABLES - lookup tables for fall speeds of rain -! RRATE_TABLES - lookup tables for precipitation rates of rain -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE : IBM SP -! - USE MACHINE , ONLY : kind_phys - USE FUNCPHYS - USE PHYSCONS, CP => con_CP, RD => con_RD, RV => con_RV - &, T0C => con_T0C, HVAP => con_HVAP, HFUS => con_HFUS - &, EPS => con_EPS, EPSM1 => con_EPSM1 - &, EPS1 => con_FVirt -! -!------------------------------------------------------------------------- -!--------------- Arrays & constants in argument list --------------------- -!------------------------------------------------------------------------- -! -! INCLUDE "parmeta" -! INCLUDE "mpp.h" - REAL ARAING, ASNOWG, P_col(LM), QI_col(LM), QR_col(LM), QV_col(LM) - &, QW_col(LM), RimeF_col(LM), T_col(LM), THICK_col(LM), - & WC_col(LM), RHC_col(LM), XNCW(LM), ARAIN, ASNOW -! - INTEGER I_index, J_index, LSFC -! -!------------------------------------------------------------------------- -!-------------- Common blocks for microphysical statistics --------------- -!------------------------------------------------------------------------- -! -!------------------------------------------------------------------------- -!--------- Common blocks for constants initialized in GSMCONST ---------- -! - COMMON /CMICRO_CONS/ ABFR, CBFR, CIACW, CIACR, C_N0r0, - & CN0r0, CN0r_DMRmin, CN0r_DMRmax, CRACW, CRAUT, ESW0, -! & QAUT0, RFmax, RHgrd, RQR_DR1, RQR_DR2, RQR_DR3, RQR_DRmin, - & QAUTx, RFmax, RQR_DR1, RQR_DR2, RQR_DR3, RQR_DRmin, - & RQR_DRmax, RR_DRmin, RR_DR1, RR_DR2, RR_DR3, RR_DRmax -! - COMMON /CMICRO_CON2/ mic_step -! -!--- The following variables are for microphysical statistics -! - INTEGER, PARAMETER :: ITLO=-60, ITHI=40 - COMMON /CMICRO_STATS/ NSTATS(ITLO:ITHI,4), QMAX(ITLO:ITHI,5), - & QTOT(ITLO:ITHI,22) - INTEGER :: NSTATS - REAL :: QMAX, QTOT -! -!------------------------------------------------------------------------- -!--------------- Common blocks for various lookup tables ----------------- -! -!--- Discretized growth rates of small ice crystals after their nucleation -! at 1 C intervals from -1 C to -35 C, based on calculations by Miller -! and Young (1979, JAS) after 600 s of growth. Resultant growth rates -! are multiplied by physics time step in GSMCONST. -! - INTEGER, PARAMETER :: MY_T1=1, MY_T2=35 - COMMON /CMY600/ MY_GROWTH(MY_T1:MY_T2) - REAL MY_GROWTH -! -!------------------------------------------------------------------------- -! -!--- Mean ice-particle diameters varying from 50 microns to 1000 microns -! (1 mm), assuming an exponential size distribution. -! -!---- Meaning of the following arrays: -! - mdiam - mean diameter (m) -! - VENTI1 - integrated quantity associated w/ ventilation effects -! (capacitance only) for calculating vapor deposition onto ice -! - VENTI2 - integrated quantity associated w/ ventilation effects -! (with fall speed) for calculating vapor deposition onto ice -! - ACCRI - integrated quantity associated w/ cloud water collection by ice -! - MASSI - integrated quantity associated w/ ice mass -! - VSNOWI - mass-weighted fall speed of snow (large ice), used to calculate -! precipitation rates -! - REAL, PARAMETER :: DMImin=.05e-3, DMImax=1.e-3, DelDMI=1.e-6, - & XMImin=1.e6*DMImin, XMImax=1.e6*DMImax - INTEGER, PARAMETER :: MDImin=XMImin, MDImax=XMImax -! - COMMON /IACCR_TABLES/ ACCRI(MDImin:MDImax) - COMMON /IMASS_TABLES/ MASSI(MDImin:MDImax) - REAL MASSI - COMMON /IRATE_TABLES/ VSNOWI(MDImin:MDImax) - COMMON /IVENT_TABLES/ VENTI1(MDImin:MDImax), VENTI2(MDImin:MDImax) -! -!------------------------------------------------------------------------- -! -!--- VEL_RF - velocity increase of rimed particles as functions of crude -! particle size categories (at 0.1 mm intervals of mean ice particle -! sizes) and rime factor (different values of Rime Factor of 1.1**N, -! where N=0 to Nrime). -! - INTEGER, PARAMETER :: Nrime=40 - COMMON /IRIME_TABLES/ VEL_RF(2:9,0:Nrime) -! -!------------------------------------------------------------------------- -! -!--- Mean rain drop diameters varying from 50 microns (0.05 mm) to 450 microns -! (0.45 mm), assuming an exponential size distribution. -! - REAL, PARAMETER :: DMRmin=.05e-3, DMRmax=.45e-3, DelDMR=1.e-6, - & XMRmin=1.e6*DMRmin, XMRmax=1.e6*DMRmax - INTEGER, PARAMETER :: MDRmin=XMRmin, MDRmax=XMRmax -! - COMMON /RACCR_TABLES/ ACCRR(MDRmin:MDRmax) - COMMON /RMASS_TABLES/ MASSR(MDRmin:MDRmax) - REAL MASSR - COMMON /RRATE_TABLES/ RRATE(MDRmin:MDRmax) - COMMON /RVELR_TABLES/ VRAIN(MDRmin:MDRmax) - COMMON /RVENT_TABLES/ VENTR1(MDRmin:MDRmax), VENTR2(MDRmin:MDRmax) -! -!------------------------------------------------------------------------- -!------- Key parameters, local variables, & important comments --------- -!----------------------------------------------------------------------- -! -!--- KEY Parameters: -! -!---- Comments on 14 March 2002 -! * Set EPSQ to the universal value of 1.e-12 throughout the code -! condensate. The value of EPSQ will need to be changed in the other -! subroutines in order to make it consistent throughout the Eta code. -! * Set CLIMIT=10.*EPSQ as the lower limit for the total mass of -! condensate in the current layer and the input flux of condensate -! from above (TOT_ICE, TOT_ICEnew, TOT_RAIN, and TOT_RAINnew). -! -!- NLImax - maximum number concentration of large ice crystals (20,000 /m**3, 20 per liter) -!- NLImin - minimum number concentration of large ice crystals (100 /m**3, 0.1 per liter) -! -! REAL, PARAMETER :: CP=1004.6, EPSQ=1.E-12, RD=287.04, -! & RHOL=1000., RV=461.5, T0C=273.15, XLS=2.834E6, EPS=RD/RV, - REAL, PARAMETER :: EPSQ=1.E-12, RHOL=1000., XLS=HVAP+HFUS, - & NLImax=20.E3, NLImin=100., T_ICE=-10., T_ICE_init=-5., - & TOLER=5.E-7, -! & CLIMIT=10.*EPSQ, EPS1=RV/RD-1., RCP=1./CP, - & CLIMIT=10.*EPSQ, RCP=1./CP, - & RCPRV=RCP/RV, RRHOL=1./RHOL, XLS1=XLS*RCP, XLS2=XLS*XLS*RCPRV, - & XLS3=XLS*XLS/RV, - & C1=1./3., C2=1./6., C3=3.31/6., - & DMR1=.1E-3, DMR2=.2E-3, DMR3=.32E-3, N0r0=8.E6, N0rmin=1.e4, - & N0s0=4.E6, RHO0=1.194, XMR1=1.e6*DMR1, XMR2=1.e6*DMR2, - & XMR3=1.e6*DMR3, Xratio=.025 - INTEGER, PARAMETER :: MDR1=XMR1, MDR2=XMR2, MDR3=XMR3 -! -!--- If BLEND=1: -! precipitation (large) ice amounts are estimated at each level as a -! blend of ice falling from the grid point above and the precip ice -! present at the start of the time step (see TOT_ICE below). -!--- If BLEND=0: -! precipitation (large) ice amounts are estimated to be the precip -! ice present at the start of the time step. -! -!--- Extended to include sedimentation of rain on 2/5/01 -! - REAL, PARAMETER :: BLEND=1. -! -!--- This variable is for debugging purposes (if .true.) -! -! LOGICAL, PARAMETER :: PRINT_diag=.TRUE. - LOGICAL PRINT_diag -! -!--- Local variables -! - REAL EMAIRI, N0r, NLICE, NSmICE - LOGICAL CLEAR, ICE_logical, DBG_logical, RAIN_logical - real (kind=kind_phys) r_val,r_fpvs,r_pp -! -!####################################################################### -!########################## Begin Execution ############################ -!####################################################################### -! - DTPH = DTPG / mic_step - ARAING=0. ! Total Accumulated rainfall into grid box from above (kg/m**2) - ASNOWG=0. ! Total Accumulated snowfall into grid box from above (kg/m**2) -! - do ntimes =1,mic_step -! - ARAIN=0. ! Accumulated rainfall into grid box from above (kg/m**2) - ASNOW=0. ! Accumulated snowfall into grid box from above (kg/m**2) -! -!----------------------------------------------------------------------- -!------------ Loop from top (L=1) to surface (L=LSFC) ------------------ -!----------------------------------------------------------------------- -! - DO 10 L=1,LSFC - -!--- Skip this level and go to the next lower level if no condensate -! and very low specific humidities -! - IF (QV_col(L).LE.EPSQ .AND. WC_col(L).LE.EPSQ) GO TO 10 -! -!----------------------------------------------------------------------- -!------------ Proceed with cloud microphysics calculations ------------- -!----------------------------------------------------------------------- -! - TK=T_col(L) ! Temperature (deg K) - TC=TK-T0C ! Temperature (deg C) - PP=P_col(L) ! Pressure (Pa) - QV=QV_col(L) ! Specific humidity of water vapor (kg/kg) -! WV=QV/(1.-QV) ! Water vapor mixing ratio (kg/kg) - WV=QV ! Water vapor mixing ratio (kg/kg) - WC=WC_col(L) ! Grid-scale mixing ratio of total condensate (water or ice; kg/kg) -! WC=WC/(1.-WC) - RHgrd = RHC_col(L) -! -!----------------------------------------------------------------------- -!--- Moisture variables below are mixing ratios & not specifc humidities -!----------------------------------------------------------------------- -! - CLEAR=.TRUE. -! -!--- This check is to determine grid-scale saturation when no condensate is present -! - r_val=TK - r_fpvs=FPVSL(r_val) - r_pp=PP - ESW=min(r_pp,r_fpvs) ! Saturation vapor pressure w/r/t water -! QSW=EPS*ESW/(PP-ESW) ! Saturation mixing ratio w/r/t water - QSW=EPS*ESW/(PP+epsm1*ESW) ! Saturation specific humidity w/r/t water - WS=QSW ! General saturation mixing ratio (water/ice) - IF (TC .LT. 0.) THEN - r_val=TK - r_fpvs=FPVSI(r_val) - r_pp=PP - ESI=min(r_pp,r_fpvs) ! Saturation vapor pressure w/r/t ice -! QSI=EPS*ESI/(PP-ESI) ! Saturation mixing ratio w/r/t water - QSI=EPS*ESI/(PP+epsm1*ESI) ! Saturation specific humidity w/r/t water - WS=QSI ! General saturation mixing ratio (water/ice) - if (pp .le. esi) ws = wv /rhgrd - ENDIF -! -!--- Effective grid-scale Saturation mixing ratios -! - QSWgrd=RHgrd*QSW - QSIgrd=RHgrd*QSI - WSgrd=RHgrd*WS -! -!--- Check if air is subsaturated and w/o condensate -! - IF (WV.GT.WSgrd .OR. WC.GT.EPSQ) CLEAR=.FALSE. -! -!--- Check if any rain is falling into layer from above -! - IF (ARAIN .GT. CLIMIT) THEN - CLEAR=.FALSE. - ELSE - ARAIN=0. - ENDIF -! -!--- Check if any ice is falling into layer from above -! -!--- NOTE that "SNOW" in variable names is synonomous with -! large, precipitation ice particles -! - IF (ASNOW .GT. CLIMIT) THEN - CLEAR=.FALSE. - ELSE - ASNOW=0. - ENDIF -! -!----------------------------------------------------------------------- -!-- Loop to the end if in clear, subsaturated air free of condensate --- -!----------------------------------------------------------------------- -! - IF (CLEAR) GO TO 10 -! -!----------------------------------------------------------------------- -!--------- Initialize RHO, THICK & microphysical processes ------------- -!----------------------------------------------------------------------- -! -! -!--- Virtual temperature, TV=T*(1./EPS-1)*Q, Q is specific humidity; -! (see pp. 63-65 in Fleagle & Businger, 1963) -! - RHO=PP/(RD*TK*(1.+EPS1*QV)) ! Air density (kg/m**3) - RRHO=1./RHO ! Reciprocal of air density - DTRHO=DTPH*RHO ! Time step * air density - BLDTRH=BLEND*DTRHO ! Blend parameter * time step * air density - THICK=THICK_col(L) ! Layer thickness = RHO*DZ = -DP/G = (Psfc-Ptop)*D_ETA/(G*ETA_s -! - ARAINnew=0. ! Updated accumulated rainfall - ASNOWnew=0. ! Updated accumulated snowfall - QI=QI_col(L) ! Ice mixing ratio - QInew=0. ! Updated ice mixing ratio - QR=QR_col(L) ! Rain mixing ratio - QRnew=0. ! Updated rain ratio - QW=QW_col(L) ! Cloud water mixing ratio - QWnew=0. ! Updated cloud water ratio -! - PCOND=0. ! Condensation (>0) or evaporation (<0) of cloud water (kg/kg) - PIDEP=0. ! Deposition (>0) or sublimation (<0) of ice crystals (kg/kg) - PIACW=0. ! Cloud water collection (riming) by precipitation ice (kg/kg; - PIACWI=0. ! Growth of precip ice by riming (kg/kg; >0) - PIACWR=0. ! Shedding of accreted cloud water to form rain (kg/kg; >0) - PIACR=0. ! Freezing of rain onto large ice at supercooled temps (kg/kg; - PICND=0. ! Condensation (>0) onto wet, melting ice (kg/kg) - PIEVP=0. ! Evaporation (<0) from wet, melting ice (kg/kg) - PIMLT=0. ! Melting ice (kg/kg; >0) - PRAUT=0. ! Cloud water autoconversion to rain (kg/kg; >0) - PRACW=0. ! Cloud water collection (accretion) by rain (kg/kg; >0) - PREVP=0. ! Rain evaporation (kg/kg; <0) -! -!--- Double check input hydrometeor mixing ratios -! -! DUM=WC-(QI+QW+QR) -! DUM1=ABS(DUM) -! DUM2=TOLER*MIN(WC, QI+QW+QR) -! IF (DUM1 .GT. DUM2) THEN -! WRITE(6,"(/2(a,i4),a,i2)") '{@ i=',I_index,' j=',J_index, -! & ' L=',L -! WRITE(6,"(4(a12,g11.4,1x))") -! & '{@ TCold=',TC,'P=',.01*PP,'DIFF=',DUM,'WCold=',WC, -! & '{@ QIold=',QI,'QWold=',QW,'QRold=',QR -! ENDIF -! -!*********************************************************************** -!*********** MAIN MICROPHYSICS CALCULATIONS NOW FOLLOW! **************** -!*********************************************************************** -! -!--- Calculate a few variables, which are used more than once below -! -!--- Latent heat of vaporization as a function of temperature from -! Bolton (1980, JAS) -! - XLV=3.148E6-2370*TK ! Latent heat of vaporization (Lv) - XLF=XLS-XLV ! Latent heat of fusion (Lf) - XLV1=XLV*RCP ! Lv/Cp - XLF1=XLF*RCP ! Lf/Cp - TK2=1./(TK*TK) ! 1./TK**2 - XLV2=XLV*XLV*QSW*TK2/RV ! Lv**2*Qsw/(Rv*TK**2) - DENOMW=1.+XLV2*RCP ! Denominator term, Clausius-Clapeyron correction -! -!--- Basic thermodynamic quantities -! * DYNVIS - dynamic viscosity [ kg/(m*s) ] -! * THERM_COND - thermal conductivity [ J/(m*s*K) ] -! * DIFFUS - diffusivity of water vapor [ m**2/s ] -! - TFACTOR=TK**1.5/(TK+120.) - DYNVIS=1.496E-6*TFACTOR - THERM_COND=2.116E-3*TFACTOR - DIFFUS=8.794E-5*TK**1.81/PP -! -!--- Air resistance term for the fall speed of ice following the -! basic research by Heymsfield, Kajikawa, others -! - GAMMAS=(1.E5/PP)**C1 -! -!--- Air resistance for rain fall speed (Beard, 1985, JAOT, p.470) -! -!Moorthi GAMMAR=(RHO0/RHO)**.4 - GAMMAR=sqrt(RHO0/RHO) -! -!---------------------------------------------------------------------- -!------------- IMPORTANT MICROPHYSICS DECISION TREE ----------------- -!---------------------------------------------------------------------- -! -!--- Determine if conditions supporting ice are present -! - IF (TC.LT.0. .OR. QI.GT.EPSQ .OR. ASNOW.GT.CLIMIT) THEN - ICE_logical=.TRUE. - ELSE - ICE_logical=.FALSE. - QLICE=0. - QTICE=0. - ENDIF -! -!--- Determine if rain is present -! - RAIN_logical=.FALSE. - IF (ARAIN.GT.CLIMIT .OR. QR.GT.EPSQ) RAIN_logical=.TRUE. -! - IF (ICE_logical) THEN -! -!--- IMPORTANT: Estimate time-averaged properties. -! -!--- -! * FLARGE - ratio of number of large ice to total (large & small) ice -! * FSMALL - ratio of number of small ice crystals to large ice particles -! -> Small ice particles are assumed to have a mean diameter of 50 microns. -! * XSIMASS - used for calculating small ice mixing ratio -!--- -! * TOT_ICE - total mass (small & large) ice before microphysics, -! which is the sum of the total mass of large ice in the -! current layer and the input flux of ice from above -! * PILOSS - greatest loss (<0) of total (small & large) ice by -! sublimation, removing all of the ice falling from above -! and the ice within the layer -! * RimeF1 - Rime Factor, which is the mass ratio of total (unrimed & rimed) -! ice mass to the unrimed ice mass (>=1) -! * VrimeF - the velocity increase due to rime factor or melting (ratio, >=1) -! * VSNOW - Fall speed of rimed snow w/ air resistance correction -! * EMAIRI - equivalent mass of air associated layer and with fall of snow into layer -! * XLIMASS - used for calculating large ice mixing ratio -! * FLIMASS - mass fraction of large ice -! * QTICE - time-averaged mixing ratio of total ice -! * QLICE - time-averaged mixing ratio of large ice -! * NLICE - time-averaged number concentration of large ice -! * NSmICE - number concentration of small ice crystals at current level -!--- -!--- Assumed number fraction of large ice particles to total (large & small) -! ice particles, which is based on a general impression of the literature. -! - WVQW=WV+QW ! Water vapor & cloud water -! - IF (TC.GE.0. .OR. WVQW.LT.QSIgrd) THEN - ! - !--- Eliminate small ice particle contributions for melting & sublimation - ! - FLARGE=1. - ELSE - ! - !--- Enhanced number of small ice particles during depositional growth - ! (effective only when 0C > T >= T_ice [-10C] ) - ! - ! FLARGE=.2 - FLARGE=.15 - ! FLARGE=.1 - ! - !--- Larger number of small ice particles due to rime splintering - ! - IF (TC.GE.-8. .AND. TC.LE.-3.) FLARGE=.5*FLARGE -! - ENDIF ! End IF (TC.GE.0. .OR. WVQW.LT.QSIgrd) - FSMALL=(1.-FLARGE)/FLARGE - XSIMASS=RRHO*MASSI(MDImin)*FSMALL - IF (QI.LE.EPSQ .AND. ASNOW.LE.CLIMIT) THEN - INDEXS=MDImin - TOT_ICE=0. - PILOSS=0. - RimeF1=1. - VrimeF=1. - VEL_INC=GAMMAS - VSNOW=0. - EMAIRI=THICK - XLIMASS=RRHO*RimeF1*MASSI(INDEXS) - FLIMASS=XLIMASS/(XLIMASS+XSIMASS) - QLICE=0. - QTICE=0. - NLICE=0. - NSmICE=0. - ELSE - ! - !--- For T<0C mean particle size follows Houze et al. (JAS, 1979, p. 160), - ! converted from Fig. 5 plot of LAMDAs. Similar set of relationships - ! also shown in Fig. 8 of Ryan (BAMS, 1996, p. 66). - ! -!Moorthi DUM=XMImax*EXP(.0536*TC) - DUM=XMImax*EXP(.0550*TC) -! DUM=XMImax*EXP(.0540*TC) - INDEXS=MIN(MDImax, MAX(MDImin, INT(DUM) ) ) - TOT_ICE=THICK*QI+BLEND*ASNOW - PILOSS=-TOT_ICE/THICK - LBEF=MAX(1,L-1) - DUM1=RimeF_col(LBEF) - DUM2=RimeF_col(L) - RimeF1=(DUM2*THICK*QI+DUM1*BLEND*ASNOW)/TOT_ICE - RimeF1=MIN(RimeF1, RFmax) - DO IPASS=0,1 - IF (RimeF1 .LE. 1.) THEN - RimeF1=1. - VrimeF=1. - ELSE - IXS=MAX(2, MIN(INDEXS/100, 9)) - XRF=10.492*ALOG(RimeF1) - IXRF=MAX(0, MIN(INT(XRF), Nrime)) - IF (IXRF .GE. Nrime) THEN - VrimeF=VEL_RF(IXS,Nrime) - ELSE - VrimeF=VEL_RF(IXS,IXRF)+(XRF-FLOAT(IXRF))* - & (VEL_RF(IXS,IXRF+1)-VEL_RF(IXS,IXRF)) - ENDIF - ENDIF ! End IF (RimeF1 .LE. 1.) - VEL_INC=GAMMAS*VrimeF - VSNOW=VEL_INC*VSNOWI(INDEXS) - EMAIRI=THICK+BLDTRH*VSNOW - XLIMASS=RRHO*RimeF1*MASSI(INDEXS) - FLIMASS=XLIMASS/(XLIMASS+XSIMASS) - QTICE=TOT_ICE/EMAIRI - QLICE=FLIMASS*QTICE - NLICE=QLICE/XLIMASS - NSmICE=Fsmall*NLICE - ! - IF ( (NLICE.GE.NLImin .AND. NLICE.LE.NLImax) - & .OR. IPASS.EQ.1) THEN - EXIT - ELSE - ! - !--- Reduce excessive accumulation of ice at upper levels - ! associated with strong grid-resolved ascent - ! - !--- Force NLICE to be between NLImin and NLImax - ! - DUM=MAX(NLImin, MIN(NLImax, NLICE) ) - XLI=RHO*(QTICE/DUM-XSIMASS)/RimeF1 - IF (XLI .LE. MASSI(MDImin) ) THEN - INDEXS=MDImin - ELSE IF (XLI .LE. MASSI(450) ) THEN - DLI=9.5885E5*XLI**.42066 ! DLI in microns - INDEXS=MIN(MDImax, MAX(MDImin, INT(DLI) ) ) - ELSE IF (XLI .LE. MASSI(MDImax) ) THEN - DLI=3.9751E6*XLI**.49870 ! DLI in microns - INDEXS=MIN(MDImax, MAX(MDImin, INT(DLI) ) ) - ELSE - INDEXS=MDImax - ! - !--- 8/22/01: Increase density of large ice if maximum limits - ! are reached for number concentration (NLImax) and mean size - ! (MDImax). Done to increase fall out of ice. - ! - IF (DUM .GE. NLImax) - & RimeF1=RHO*(QTICE/NLImax-XSIMASS)/MASSI(INDEXS) - ENDIF ! End IF (XLI .LE. MASSI(MDImin) ) -! WRITE(6,"(4(a12,g11.4,1x))") -! & '{$ TC=',TC,'P=',.01*PP,'NLICE=',NLICE,'DUM=',DUM, -! & '{$ XLI=',XLI,'INDEXS=',FLOAT(INDEXS),'RHO=',RHO,'QTICE=',QTICE, -! & '{$ XSIMASS=',XSIMASS,'RimeF1=',RimeF1 - ENDIF ! End IF ( (NLICE.GE.NLImin .AND. NLICE.LE.NLImax) ... - ENDDO ! End DO IPASS=0,1 - ENDIF ! End IF (QI.LE.EPSQ .AND. ASNOW.LE.CLIMIT) - ENDIF ! End IF (ICE_logical) -! -!---------------------------------------------------------------------- -!--------------- Calculate individual processes ----------------------- -!---------------------------------------------------------------------- -! -!--- Cloud water autoconversion to rain and collection by rain -! - IF (QW.GT.EPSQ .AND. TC.GE.T_ICE) THEN - ! - !--- QW0 could be modified based on land/sea properties, - ! presence of convection, etc. This is why QAUT0 and CRAUT - ! are passed into the subroutine as externally determined - ! parameters. Can be changed in the future if desired. - ! -! QW0=QAUT0*RRHO - QW0=QAUTx*RRHO*XNCW(L) - PRAUT=MAX(0., QW-QW0)*CRAUT - IF (QLICE .GT. EPSQ) THEN - ! - !--- Collection of cloud water by large ice particles ("snow") - ! PIACWI=PIACW for riming, PIACWI=0 for shedding - ! - FWS=MIN(1., CIACW*VEL_INC*NLICE*ACCRI(INDEXS)/PP**C1) - PIACW=FWS*QW - IF (TC .LT. 0.) PIACWI=PIACW ! Large ice riming - ENDIF ! End IF (QLICE .GT. EPSQ) - ENDIF ! End IF (QW.GT.EPSQ .AND. TC.GE.T_ICE) -! -!---------------------------------------------------------------------- -!--- Loop around some of the ice-phase processes if no ice should be present -!---------------------------------------------------------------------- -! - IF (ICE_logical .EQV. .FALSE.) GO TO 20 -! -!--- Now the pretzel logic of calculating ice deposition -! - IF (TC.LT.T_ICE .AND. (WV.GT.QSIgrd .OR. QW.GT.EPSQ)) THEN - ! - !--- Adjust to ice saturation at T0) and evaporation - ! - DUM=PIEVP-PIMLT - IF (DUM .LT. PILOSS) THEN - DUM1=PILOSS/DUM - PIMLT=PIMLT*DUM1 - PIEVP=PIEVP*DUM1 - ENDIF ! End IF (DUM .GT. QTICE) - ENDIF ! End IF (TC.GT.0. .AND. TCC.GT.0. .AND. ICE_logical) -! -!--- IMPORTANT: Estimate time-averaged properties. -! -! * TOT_RAIN - total mass of rain before microphysics, which is the sum of -! the total mass of rain in the current layer and the input -! flux of rain from above -! * VRAIN1 - fall speed of rain into grid from above (with air resistance correction) -! * QTRAIN - time-averaged mixing ratio of rain (kg/kg) -! * PRLOSS - greatest loss (<0) of rain, removing all rain falling from -! above and the rain within the layer -! * RQR - rain content (kg/m**3) -! * INDEXR - mean size of rain drops to the nearest 1 micron in size -! * N0r - intercept of rain size distribution (typically 10**6 m**-4) -! - TOT_RAIN=0. - VRAIN1=0. - QTRAIN=0. - PRLOSS=0. - RQR=0. - N0r=0. - INDEXR1=INDEXR ! For debugging only - INDEXR=MDRmin - IF (RAIN_logical) THEN - IF (ARAIN .LE. 0.) THEN - INDEXR=MDRmin - VRAIN1=0. - ELSE - ! - !--- INDEXR (related to mean diameter) & N0r could be modified - ! by land/sea properties, presence of convection, etc. - ! - !--- Rain rate normalized to a density of 1.194 kg/m**3 - ! - RR=ARAIN/(DTPH*GAMMAR) - ! - IF (RR .LE. RR_DRmin) THEN - ! - !--- Assume fixed mean diameter of rain (0.2 mm) for low rain rates, - ! instead vary N0r with rain rate - ! - INDEXR=MDRmin - ELSE IF (RR .LE. RR_DR1) THEN - ! - !--- Best fit to mass-weighted fall speeds (V) from rain lookup tables - ! for mean diameters (Dr) between 0.05 and 0.10 mm: - ! V(Dr)=5.6023e4*Dr**1.136, V in m/s and Dr in m - ! RR = PI*1000.*N0r0*5.6023e4*Dr**(4+1.136) = 1.408e15*Dr**5.136, - ! RR in kg/(m**2*s) - ! Dr (m) = 1.123e-3*RR**.1947 -> Dr (microns) = 1.123e3*RR**.1947 - ! - INDEXR=INT( 1.123E3*RR**.1947 + .5 ) - INDEXR=MAX( MDRmin, MIN(INDEXR, MDR1) ) - ELSE IF (RR .LE. RR_DR2) THEN - ! - !--- Best fit to mass-weighted fall speeds (V) from rain lookup tables - ! for mean diameters (Dr) between 0.10 and 0.20 mm: - ! V(Dr)=1.0867e4*Dr**.958, V in m/s and Dr in m - ! RR = PI*1000.*N0r0*1.0867e4*Dr**(4+.958) = 2.731e14*Dr**4.958, - ! RR in kg/(m**2*s) - ! Dr (m) = 1.225e-3*RR**.2017 -> Dr (microns) = 1.225e3*RR**.2017 - ! - INDEXR=INT( 1.225E3*RR**.2017 + .5 ) - INDEXR=MAX( MDR1, MIN(INDEXR, MDR2) ) - ELSE IF (RR .LE. RR_DR3) THEN - ! - !--- Best fit to mass-weighted fall speeds (V) from rain lookup tables - ! for mean diameters (Dr) between 0.20 and 0.32 mm: - ! V(Dr)=2831.*Dr**.80, V in m/s and Dr in m - ! RR = PI*1000.*N0r0*2831.*Dr**(4+.80) = 7.115e13*Dr**4.80, - ! RR in kg/(m**2*s) - ! Dr (m) = 1.3006e-3*RR**.2083 -> Dr (microns) = 1.3006e3*RR**.2083 - ! - INDEXR=INT( 1.3006E3*RR**.2083 + .5 ) - INDEXR=MAX( MDR2, MIN(INDEXR, MDR3) ) - ELSE IF (RR .LE. RR_DRmax) THEN - ! - !--- Best fit to mass-weighted fall speeds (V) from rain lookup tables - ! for mean diameters (Dr) between 0.32 and 0.45 mm: - ! V(Dr)=944.8*Dr**.6636, V in m/s and Dr in m - ! RR = PI*1000.*N0r0*944.8*Dr**(4+.6636) = 2.3745e13*Dr**4.6636, - ! RR in kg/(m**2*s) - ! Dr (m) = 1.355e-3*RR**.2144 -> Dr (microns) = 1.355e3*RR**.2144 - ! - INDEXR=INT( 1.355E3*RR**.2144 + .5 ) - INDEXR=MAX( MDR3, MIN(INDEXR, MDRmax) ) - ELSE - ! - !--- Assume fixed mean diameter of rain (0.45 mm) for high rain rates, - ! instead vary N0r with rain rate - ! - INDEXR=MDRmax - ENDIF ! End IF (RR .LE. RR_DRmin) etc. - VRAIN1=GAMMAR*VRAIN(INDEXR) - ENDIF ! End IF (ARAIN .LE. 0.) - INDEXR1=INDEXR ! For debugging only - TOT_RAIN=THICK*QR+BLEND*ARAIN - QTRAIN=TOT_RAIN/(THICK+BLDTRH*VRAIN1) - PRLOSS=-TOT_RAIN/THICK - RQR=RHO*QTRAIN - ! - !--- RQR - time-averaged rain content (kg/m**3) - ! - IF (RQR .LE. RQR_DRmin) THEN - N0r=MAX(N0rmin, CN0r_DMRmin*RQR) - INDEXR=MDRmin - ELSE IF (RQR .GE. RQR_DRmax) THEN - N0r=CN0r_DMRmax*RQR - INDEXR=MDRmax - ELSE - N0r=N0r0 - INDEXR=MAX( XMRmin, MIN(CN0r0*RQR**.25, XMRmax) ) - ENDIF - ! - IF (TC .LT. T_ICE) THEN - PIACR=-PRLOSS - ELSE - DWVr=WV-PCOND-QSW - DUM=QW+PCOND - IF (DWVr.LT.0. .AND. DUM.LE.EPSQ) THEN - ! - !--- Rain evaporation - ! - ! * RFACTOR - [GAMMAR**.5]*[Schmidt**(1./3.)]*[(RHO/DYNVIS)**.5], - ! where Schmidt (Schmidt Number) =DYNVIS/(RHO*DIFFUS) - ! - ! * Units: RFACTOR - s**.5/m ; ABW - m**2/s ; VENTR - m**-2 ; - ! N0r - m**-4 ; VENTR1 - m**2 ; VENTR2 - m**3/s**.5 ; - ! CREVP - unitless - ! -! RFACTOR=GAMMAR**.5*(RHO/(DIFFUS*DIFFUS*DYNVIS))**C2 - RFACTOR=sqrt(GAMMAR)*(RHO/(DIFFUS*DIFFUS*DYNVIS))**C2 - ABW=1./(RHO*XLV2/THERM_COND+1./DIFFUS) - ! - !--- Note that VENTR1, VENTR2 lookup tables do not include the - ! 1/Davg multiplier as in the ice tables - ! - VENTR=N0r*(VENTR1(INDEXR)+RFACTOR*VENTR2(INDEXR)) - CREVP=ABW*VENTR*DTPH - IF (CREVP .LT. Xratio) THEN - DUM=DWVr*CREVP - ELSE - DUM=DWVr*(1.-EXP(-CREVP*DENOMW))/DENOMW - ENDIF - PREVP=MAX(DUM, PRLOSS) - ELSE IF (QW .GT. EPSQ) THEN - FWR=CRACW*GAMMAR*N0r*ACCRR(INDEXR) - PRACW=MIN(1.,FWR)*QW - ENDIF ! End IF (DWVr.LT.0. .AND. DUM.LE.EPSQ) - ! - IF (TC.LT.0. .AND. TCC.LT.0.) THEN - ! - !--- Biggs (1953) heteorogeneous freezing (e.g., Lin et al., 1983) - ! - DUM=(EXP(ABFR*TC)-1.)*(.001*FLOAT(INDEXR))**7 - PIACR=MIN(CBFR*N0r*RRHO*DUM, QTRAIN) - IF (QLICE .GT. EPSQ) THEN - ! - !--- Freezing of rain by collisions w/ large ice - ! - DUM=GAMMAR*VRAIN(INDEXR) - DUM1=DUM-VSNOW - ! - !--- DUM2 - Difference in spectral fall speeds of rain and - ! large ice, parameterized following eq. (48) on p. 112 of - ! Murakami (J. Meteor. Soc. Japan, 1990) - ! - DUM2=(DUM1*DUM1+.04*DUM*VSNOW)**.5 - DUM1=5.E-12*INDEXR*INDEXR+2.E-12*INDEXR*INDEXS - & +.5E-12*INDEXS*INDEXS - FIR=MIN(1., CIACR*NLICE*DUM1*DUM2) - ! - !--- Future? Should COLLECTION BY SMALL ICE SHOULD BE INCLUDED??? - ! - PIACR=MIN(PIACR+FIR*QTRAIN, QTRAIN) - ENDIF ! End IF (QLICE .GT. EPSQ) - DUM=PREVP-PIACR - If (DUM .LT. PRLOSS) THEN - DUM1=PRLOSS/DUM - PREVP=DUM1*PREVP - PIACR=DUM1*PIACR - ENDIF ! End If (DUM .LT. PRLOSS) - ENDIF ! End IF (TC.LT.0. .AND. TCC.LT.0.) - ENDIF ! End IF (TC .LT. T_ICE) - ENDIF ! End IF (RAIN_logical) -! -!---------------------------------------------------------------------- -!---------------------- Main Budget Equations ------------------------- -!---------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------- -!--- Update fields, determine characteristics for next lower layer ---- -!----------------------------------------------------------------------- -! -!--- Carefully limit sinks of cloud water -! - DUM1=PIACW+PRAUT+PRACW-MIN(0.,PCOND) - IF (DUM1 .GT. QW) THEN - DUM=QW/DUM1 - PIACW=DUM*PIACW - PIACWI=DUM*PIACWI - PRAUT=DUM*PRAUT - PRACW=DUM*PRACW - IF (PCOND .LT. 0.) PCOND=DUM*PCOND - ENDIF - PIACWR=PIACW-PIACWI ! TC >= 0C -! -!--- QWnew - updated cloud water mixing ratio -! - DELW=PCOND-PIACW-PRAUT-PRACW - QWnew=QW+DELW - IF (QWnew .LE. EPSQ) QWnew=0. - IF (QW.GT.0. .AND. QWnew.NE.0.) THEN - DUM=QWnew/QW - IF (DUM .LT. TOLER) QWnew=0. - ENDIF -! -!--- Update temperature and water vapor mixing ratios -! - DELT= XLV1*(PCOND+PIEVP+PICND+PREVP) - & +XLS1*PIDEP+XLF1*(PIACWI+PIACR-PIMLT) - Tnew=TK+DELT -! - DELV=-PCOND-PIDEP-PIEVP-PICND-PREVP - WVnew=WV+DELV -! -!--- Update ice mixing ratios -! -!--- -! * TOT_ICEnew - total mass (small & large) ice after microphysics, -! which is the sum of the total mass of large ice in the -! current layer and the flux of ice out of the grid box below -! * RimeF - Rime Factor, which is the mass ratio of total (unrimed & -! rimed) ice mass to the unrimed ice mass (>=1) -! * QInew - updated mixing ratio of total (large & small) ice in layer -! -> TOT_ICEnew=QInew*THICK+BLDTRH*QLICEnew*VSNOW -! -> But QLICEnew=QInew*FLIMASS, so -! -> TOT_ICEnew=QInew*(THICK+BLDTRH*FLIMASS*VSNOW) -! * ASNOWnew - updated accumulation of snow at bottom of grid cell -!--- -! - DELI=0. - RimeF=1. - IF (ICE_logical) THEN - DELI=PIDEP+PIEVP+PIACWI+PIACR-PIMLT - TOT_ICEnew=TOT_ICE+THICK*DELI - IF (TOT_ICE.GT.0. .AND. TOT_ICEnew.NE.0.) THEN - DUM=TOT_ICEnew/TOT_ICE - IF (DUM .LT. TOLER) TOT_ICEnew=0. - ENDIF - IF (TOT_ICEnew .LE. CLIMIT) THEN - TOT_ICEnew=0. - RimeF=1. - QInew=0. - ASNOWnew=0. - ELSE - ! - !--- Update rime factor if appropriate - ! - DUM=PIACWI+PIACR - IF (DUM.LE.EPSQ .AND. PIDEP.LE.EPSQ) THEN - RimeF=RimeF1 - ELSE - ! - !--- Rime Factor, RimeF = (Total ice mass)/(Total unrimed ice mass) - ! DUM1 - Total ice mass, rimed & unrimed - ! DUM2 - Estimated mass of *unrimed* ice - ! - DUM1=TOT_ICE+THICK*(PIDEP+DUM) - DUM2=TOT_ICE/RimeF1+THICK*PIDEP - IF (DUM2 .LE. 0.) THEN - RimeF=RFmax - ELSE - RimeF=MIN(RFmax, MAX(1., DUM1/DUM2) ) - ENDIF - ENDIF ! End IF (DUM.LE.EPSQ .AND. PIDEP.LE.EPSQ) - QInew=TOT_ICEnew/(THICK+BLDTRH*FLIMASS*VSNOW) - IF (QInew .LE. EPSQ) QInew=0. - IF (QI.GT.0. .AND. QInew.NE.0.) THEN - DUM=QInew/QI - IF (DUM .LT. TOLER) QInew=0. - ENDIF - ASNOWnew=BLDTRH*FLIMASS*VSNOW*QInew - IF (ASNOW.GT.0. .AND. ASNOWnew.NE.0.) THEN - DUM=ASNOWnew/ASNOW - IF (DUM .LT. TOLER) ASNOWnew=0. - ENDIF - ENDIF ! End IF (TOT_ICEnew .LE. CLIMIT) - ENDIF ! End IF (ICE_logical) -! -!--- Update rain mixing ratios -! -!--- -! * TOT_RAINnew - total mass of rain after microphysics -! current layer and the input flux of ice from above -! * VRAIN2 - time-averaged fall speed of rain in grid and below -! (with air resistance correction) -! * QRnew - updated rain mixing ratio in layer -! -> TOT_RAINnew=QRnew*(THICK+BLDTRH*VRAIN2) -! * ARAINnew - updated accumulation of rain at bottom of grid cell -!--- -! - DELR=PRAUT+PRACW+PIACWR-PIACR+PIMLT+PREVP+PICND - TOT_RAINnew=TOT_RAIN+THICK*DELR - IF (TOT_RAIN.GT.0. .AND. TOT_RAINnew.NE.0.) THEN - DUM=TOT_RAINnew/TOT_RAIN - IF (DUM .LT. TOLER) TOT_RAINnew=0. - ENDIF - IF (TOT_RAINnew .LE. CLIMIT) THEN - TOT_RAINnew=0. - VRAIN2=0. - QRnew=0. - ARAINnew=0. - ELSE - ! - !--- 1st guess time-averaged rain rate at bottom of grid box - ! - RR=TOT_RAINnew/(DTPH*GAMMAR) - ! - !--- Use same algorithm as above for calculating mean drop diameter - ! (IDR, in microns), which is used to estimate the time-averaged - ! fall speed of rain drops at the bottom of the grid layer. This - ! isn't perfect, but the alternative is solving a transcendental - ! equation that is numerically inefficient and nasty to program - ! (coded in earlier versions of GSMCOLUMN prior to 8-22-01). - ! - IF (RR .LE. RR_DRmin) THEN - IDR=MDRmin - ELSE IF (RR .LE. RR_DR1) THEN - IDR=INT( 1.123E3*RR**.1947 + .5 ) - IDR=MAX( MDRmin, MIN(IDR, MDR1) ) - ELSE IF (RR .LE. RR_DR2) THEN - IDR=INT( 1.225E3*RR**.2017 + .5 ) - IDR=MAX( MDR1, MIN(IDR, MDR2) ) - ELSE IF (RR .LE. RR_DR3) THEN - IDR=INT( 1.3006E3*RR**.2083 + .5 ) - IDR=MAX( MDR2, MIN(IDR, MDR3) ) - ELSE IF (RR .LE. RR_DRmax) THEN - IDR=INT( 1.355E3*RR**.2144 + .5 ) - IDR=MAX( MDR3, MIN(IDR, MDRmax) ) - ELSE - IDR=MDRmax - ENDIF ! End IF (RR .LE. RR_DRmin) - VRAIN2=GAMMAR*VRAIN(IDR) - QRnew=TOT_RAINnew/(THICK+BLDTRH*VRAIN2) - IF (QRnew .LE. EPSQ) QRnew=0. - IF (QR.GT.0. .AND. QRnew.NE.0.) THEN - DUM=QRnew/QR - IF (DUM .LT. TOLER) QRnew=0. - ENDIF - ARAINnew=BLDTRH*VRAIN2*QRnew - IF (ARAIN.GT.0. .AND. ARAINnew.NE.0.) THEN - DUM=ARAINnew/ARAIN - IF (DUM .LT. TOLER) ARAINnew=0. - ENDIF - ENDIF ! End IF (TOT_RAINnew .LE. CLIMIT) -! - WCnew=QWnew+QRnew+QInew -! -!---------------------------------------------------------------------- -!-------------- Begin debugging & verification ------------------------ -!---------------------------------------------------------------------- -! -!--- QT, QTnew - total water (vapor & condensate) before & after microphysics, resp. -! -! QT=THICK*(QV+WC_col(l))+ARAIN+ASNOW -! QTnew=THICK*(WVnew/(1.+WVnew)+WCnew/(1.+wcnew)) -! & +ARAINnew+ASNOWnew - QT=THICK*(WV+WC)+ARAIN+ASNOW - QTnew=THICK*(WVnew+WCnew)+ARAINnew+ASNOWnew - BUDGET=QT-QTnew -! -!--- Additional check on budget preservation, accounting for truncation effects -! - DBG_logical=.FALSE. - DUM=ABS(BUDGET) - IF (DUM .GT. TOLER) THEN - DUM=DUM/MIN(QT, QTnew) - IF (DUM .GT. TOLER) DBG_logical=.TRUE. - ENDIF -! -! DUM=(RHgrd+.001)*QSInew -! IF ( (QWnew.GT.EPSQ .OR. QRnew.GT.EPSQ .OR. WVnew.GT.DUM) -! & .AND. TC.LT.T_ICE ) DBG_logical=.TRUE. -! -! IF (TC.GT.5. .AND. QInew.GT.EPSQ) DBG_logical=.TRUE. -! - IF ((WVnew.LT.EPSQ .OR. DBG_logical) .AND. PRINT_diag) THEN - ! - WRITE(6,"(/2(a,i4),2(a,i2))") '{} i=',I_index,' j=',J_index, - & ' L=',L,' LSFC=',LSFC - ! - r_val=Tnew - r_fpvs=FPVSL(r_val) - r_pp=PP - ESW=min(r_pp,r_fpvs) -! QSWnew=EPS*ESW/(PP-ESW) - QSWnew=EPS*ESW/(PP+epsm1*ESW) - IF (TC.LT.0. .OR. Tnew .LT. 0.) THEN - r_val=Tnew - r_fpvs=FPVSI(r_val) - r_pp=PP - ESI=min(r_pp,r_fpvs) -! QSInew=EPS*ESI/(PP-ESI) - QSInew=EPS*ESI/(PP+epsm1*ESI) - ELSE - QSI=QSW - QSInew=QSWnew - ENDIF - WSnew=QSInew - WRITE(6,"(4(a12,g11.4,1x))") - & '{} TCold=',TC,'TCnew=',Tnew-T0C,'P=',.01*PP,'RHO=',RHO, - & '{} THICK=',THICK,'RHold=',WV/WS,'RHnew=',WVnew/WSnew, - & 'RHgrd=',RHgrd, - & '{} RHWold=',WV/QSW,'RHWnew=',WVnew/QSWnew,'RHIold=',WV/QSI, - & 'RHInew=',WVnew/QSInew, - & '{} QSWold=',QSW,'QSWnew=',QSWnew,'QSIold=',QSI,'QSInew=',QSInew, - & '{} WSold=',WS,'WSnew=',WSnew,'WVold=',WV,'WVnew=',WVnew, - & '{} WCold=',WC,'WCnew=',WCnew,'QWold=',QW,'QWnew=',QWnew, - & '{} QIold=',QI,'QInew=',QInew,'QRold=',QR,'QRnew=',QRnew, - & '{} ARAINold=',ARAIN,'ARAINnew=',ARAINnew,'ASNOWold=',ASNOW, - & 'ASNOWnew=',ASNOWnew, - & '{} TOT_RAIN=',TOT_RAIN,'TOT_RAINnew=',TOT_RAINnew, - & 'TOT_ICE=',TOT_ICE,'TOT_ICEnew=',TOT_ICEnew, - & '{} BUDGET=',BUDGET,'QTold=',QT,'QTnew=',QTnew - ! - WRITE(6,"(4(a12,g11.4,1x))") - & '{} DELT=',DELT,'DELV=',DELV,'DELW=',DELW,'DELI=',DELI, - & '{} DELR=',DELR,'PCOND=',PCOND,'PIDEP=',PIDEP,'PIEVP=',PIEVP, - & '{} PICND=',PICND,'PREVP=',PREVP,'PRAUT=',PRAUT,'PRACW=',PRACW, - & '{} PIACW=',PIACW,'PIACWI=',PIACWI,'PIACWR=',PIACWR,'PIMLT=', - & PIMLT, - & '{} PIACR=',PIACR - ! - IF (ICE_logical) WRITE(6,"(4(a12,g11.4,1x))") - & '{} RimeF1=',RimeF1,'GAMMAS=',GAMMAS,'VrimeF=',VrimeF, - & 'VSNOW=',VSNOW, - & '{} INDEXS=',FLOAT(INDEXS),'FLARGE=',FLARGE,'FSMALL=',FSMALL, - & 'FLIMASS=',FLIMASS, - & '{} XSIMASS=',XSIMASS,'XLIMASS=',XLIMASS,'QLICE=',QLICE, - & 'QTICE=',QTICE, - & '{} NLICE=',NLICE,'NSmICE=',NSmICE,'PILOSS=',PILOSS, - & 'EMAIRI=',EMAIRI, - & '{} RimeF=',RimeF - ! - IF (TOT_RAIN.GT.0. .OR. TOT_RAINnew.GT.0.) - & WRITE(6,"(4(a12,g11.4,1x))") - & '{} INDEXR1=',FLOAT(INDEXR1),'INDEXR=',FLOAT(INDEXR), - & 'GAMMAR=',GAMMAR,'N0r=',N0r, - & '{} VRAIN1=',VRAIN1,'VRAIN2=',VRAIN2,'QTRAIN=',QTRAIN,'RQR=',RQR, - & '{} PRLOSS=',PRLOSS,'VOLR1=',THICK+BLDTRH*VRAIN1, - & 'VOLR2=',THICK+BLDTRH*VRAIN2 - ! - IF (PRAUT .GT. 0.) WRITE(6,"(a12,g11.4,1x)") '{} QW0=',QW0 - ! - IF (PRACW .GT. 0.) WRITE(6,"(a12,g11.4,1x)") '{} FWR=',FWR - ! - IF (PIACR .GT. 0.) WRITE(6,"(a12,g11.4,1x)") '{} FIR=',FIR - ! - DUM=PIMLT+PICND-PREVP-PIEVP - IF (DUM.GT.0. .or. DWVi.NE.0.) - & WRITE(6,"(4(a12,g11.4,1x))") - & '{} TFACTOR=',TFACTOR,'DYNVIS=',DYNVIS, - & 'THERM_CON=',THERM_COND,'DIFFUS=',DIFFUS - ! - IF (PREVP .LT. 0.) WRITE(6,"(4(a12,g11.4,1x))") - & '{} RFACTOR=',RFACTOR,'ABW=',ABW,'VENTR=',VENTR,'CREVP=',CREVP, - & '{} DWVr=',DWVr,'DENOMW=',DENOMW - ! - IF (PIDEP.NE.0. .AND. DWVi.NE.0.) - & WRITE(6,"(4(a12,g11.4,1x))") - & '{} DWVi=',DWVi,'DENOMI=',DENOMI,'PIDEP_max=',PIDEP_max, - & 'SFACTOR=',SFACTOR, - & '{} ABI=',ABI,'VENTIL=',VENTIL,'VENTIL1=',VENTI1(INDEXS), - & 'VENTIL2=',SFACTOR*VENTI2(INDEXS), - & '{} VENTIS=',VENTIS,'DIDEP=',DIDEP - ! - IF (PIDEP.GT.0. .AND. PCOND.NE.0.) - & WRITE(6,"(4(a12,g11.4,1x))") - & '{} DENOMW=',DENOMW,'DENOMWI=',DENOMWI,'DENOMF=',DENOMF, - & 'DUM2=',PCOND-PIACW - ! - IF (FWS .GT. 0.) WRITE(6,"(4(a12,g11.4,1x))") - & '{} FWS=',FWS - ! - DUM=PIMLT+PICND-PIEVP - IF (DUM.GT. 0.) WRITE(6,"(4(a12,g11.4,1x))") - & '{} SFACTOR=',SFACTOR,'VENTIL=',VENTIL,'VENTIL1=',VENTI1(INDEXS), - & 'VENTIL2=',SFACTOR*VENTI2(INDEXS), - & '{} AIEVP=',AIEVP,'DIEVP=',DIEVP,'QSW0=',QSW0,'DWV0=',DWV0 - ! - if(lsfc .gt. 0) stop - ENDIF -! -!---------------------------------------------------------------------- -!-------------- Water budget statistics & maximum values -------------- -!---------------------------------------------------------------------- -! - IF (PRINT_diag) THEN - ITdx=MAX( ITLO, MIN( INT(Tnew-T0C), ITHI ) ) - IF (QInew .GT. EPSQ) NSTATS(ITdx,1)=NSTATS(ITdx,1)+1 - IF (QInew.GT.EPSQ .AND. QRnew+QWnew.GT.EPSQ) - & NSTATS(ITdx,2)=NSTATS(ITdx,2)+1 - IF (QWnew .GT. EPSQ) NSTATS(ITdx,3)=NSTATS(ITdx,3)+1 - IF (QRnew .GT. EPSQ) NSTATS(ITdx,4)=NSTATS(ITdx,4)+1 - ! - QMAX(ITdx,1)=MAX(QMAX(ITdx,1), QInew) - QMAX(ITdx,2)=MAX(QMAX(ITdx,2), QWnew) - QMAX(ITdx,3)=MAX(QMAX(ITdx,3), QRnew) - QMAX(ITdx,4)=MAX(QMAX(ITdx,4), ASNOWnew) - QMAX(ITdx,5)=MAX(QMAX(ITdx,5), ARAINnew) - QTOT(ITdx,1)=QTOT(ITdx,1)+QInew*THICK - QTOT(ITdx,2)=QTOT(ITdx,2)+QWnew*THICK - QTOT(ITdx,3)=QTOT(ITdx,3)+QRnew*THICK - ! - QTOT(ITdx,4)=QTOT(ITdx,4)+PCOND*THICK - QTOT(ITdx,5)=QTOT(ITdx,5)+PICND*THICK - QTOT(ITdx,6)=QTOT(ITdx,6)+PIEVP*THICK - QTOT(ITdx,7)=QTOT(ITdx,7)+PIDEP*THICK - QTOT(ITdx,8)=QTOT(ITdx,8)+PREVP*THICK - QTOT(ITdx,9)=QTOT(ITdx,9)+PRAUT*THICK - QTOT(ITdx,10)=QTOT(ITdx,10)+PRACW*THICK - QTOT(ITdx,11)=QTOT(ITdx,11)+PIMLT*THICK - QTOT(ITdx,12)=QTOT(ITdx,12)+PIACW*THICK - QTOT(ITdx,13)=QTOT(ITdx,13)+PIACWI*THICK - QTOT(ITdx,14)=QTOT(ITdx,14)+PIACWR*THICK - QTOT(ITdx,15)=QTOT(ITdx,15)+PIACR*THICK - ! - QTOT(ITdx,16)=QTOT(ITdx,16)+(WVnew-WV)*THICK - QTOT(ITdx,17)=QTOT(ITdx,17)+(QWnew-QW)*THICK - QTOT(ITdx,18)=QTOT(ITdx,18)+(QInew-QI)*THICK - QTOT(ITdx,19)=QTOT(ITdx,19)+(QRnew-QR)*THICK - QTOT(ITdx,20)=QTOT(ITdx,20)+(ARAINnew-ARAIN) - QTOT(ITdx,21)=QTOT(ITdx,21)+(ASNOWnew-ASNOW) - IF (QInew .GT. 0.) - & QTOT(ITdx,22)=QTOT(ITdx,22)+QInew*THICK/RimeF - ! - ENDIF -! -!---------------------------------------------------------------------- -!------------------------- Update arrays ------------------------------ -!---------------------------------------------------------------------- -! - T_col(L)=Tnew ! Updated temperature -! -! QV_col(L)=max(EPSQ, WVnew/(1.+WVnew)) ! Updated specific humidity - QV_col(L)=max(EPSQ, WVnew ) ! Updated specific humidity - WC_col(L)=max(EPSQ, WCnew) ! Updated total condensate mixing ratio - QI_col(L)=max(EPSQ, QInew) ! Updated ice mixing ratio - QR_col(L)=max(EPSQ, QRnew) ! Updated rain mixing ratio - QW_col(L)=max(EPSQ, QWnew) ! Updated cloud water mixing ratio - RimeF_col(L)=RimeF ! Updated rime factor - ASNOW=ASNOWnew ! Updated accumulated snow - ARAIN=ARAINnew ! Updated accumulated rain -! -!####################################################################### -! -10 CONTINUE ! ##### End "L" loop through model levels ##### -! - ARAING = ARAING + ARAIN - ASNOWG = ASNOWG + ASNOW - enddo ! do for ntimes=1,mic_step -! -!####################################################################### -! -!----------------------------------------------------------------------- -!--------------------------- Return to GSMDRIVE ----------------------- -!----------------------------------------------------------------------- -! - RETURN - END -! -!####################################################################### -!--------- Produces accurate calculation of cloud condensation --------- -!####################################################################### -! - REAL FUNCTION CONDENSE (PP, QW, RHgrd, TK, WV) -! -!--------------------------------------------------------------------------------- -!------ The Asai (1965) algorithm takes into consideration the release of ------ -!------ latent heat in increasing the temperature & in increasing the ------ -!------ saturation mixing ratio (following the Clausius-Clapeyron eqn.). ------ -!--------------------------------------------------------------------------------- - USE MACHINE , ONLY : kind_phys - USE FUNCPHYS , ONLY : FPVSL - USE PHYSCONS, CP => con_CP, RD => con_RD, RV => con_RV - &, EPS => con_EPS, EPSM1 => con_epsm1 -! - INTEGER, PARAMETER :: HIGH_PRES=kind_phys -! INTEGER, PARAMETER :: HIGH_PRES=Selected_Real_Kind(15) - REAL (KIND=HIGH_PRES), PARAMETER :: EPSQ=1.E-12, - & RHLIMIT=.001, RHLIMIT1=-RHLIMIT -! REAL, PARAMETER :: CP=1004.6, RD=287.04, RV=461.5, EPS=RD/RV, -! & RCP=1./CP, RCPRV=RCP/RV, EPSM1=RD/RV-1. - REAL, PARAMETER :: RCP=1./CP, RCPRV=RCP/RV - REAL (KIND=HIGH_PRES) :: COND, SSAT, WCdum, tsq - real (kind=kind_phys) r_val,r_fpvs,r_pp -! -!----------------------------------------------------------------------- -! -!--- LV (T) is from Bolton (JAS, 1980) -! -! XLV=3.148E6-2370.*TK -! XLV1=XLV*RCP -! XLV2=XLV*XLV*RCPRV -! - Tdum=TK - WVdum=WV - WCdum=QW - r_val=Tdum - r_fpvs=FPVSL(r_val) - r_pp=pp - ESW=min(r_pp,r_fpvs) ! Saturation vapor press w/r/t water -! WS=RHgrd*EPS*ESW/(PP-ESW) ! Saturation mixing ratio w/r/t water - WS=RHgrd*EPS*ESW/(PP+epsm1*ESW) ! Saturation mixing ratio w/r/t water - DWV=WVdum-WS ! Deficit grid-scale water vapor mixing ratio - SSAT=DWV/WS ! Supersaturation ratio - CONDENSE=0. - DO WHILE ((SSAT.LT.RHLIMIT1 .AND. WCdum.GT.EPSQ) - & .OR. SSAT.GT.RHLIMIT) -! - XLV=3.148E6-2370.*Tdum - XLV1=XLV*RCP - XLV2=XLV*XLV*RCPRV -! -! COND=DWV/(1.+XLV2*WS/(Tdum*Tdum)) ! Asai (1965, J. Japan) - tsq =Tdum*Tdum - COND=DWV*tsq/(tsq+XLV2*WS) ! Asai (1965, J. Japan) - COND=MAX(COND, -WCdum) ! Limit cloud water evaporation - Tdum=Tdum+XLV1*COND ! Updated temperature - WVdum=WVdum-COND ! Updated water vapor mixing ratio - WCdum=WCdum+COND ! Updated cloud water mixing ratio - CONDENSE=CONDENSE+COND ! Total cloud water condensation - r_val=Tdum - r_fpvs=FPVSL(r_val) - r_pp=pp - ESW=min(r_pp,r_fpvs) ! Updated saturation vapor press w/r/t water -! WS=RHgrd*EPS*ESW/(PP-ESW) ! Updated saturation mixing ratio w/r/t water - WS=RHgrd*EPS*ESW/(PP+epsm1*ESW) ! Updated saturation mixing ratio w/r/t water - DWV=WVdum-WS ! Deficit grid-scale water vapor mixing ratio - SSAT=DWV/WS ! Grid-scale supersaturation ratio - ENDDO - - RETURN - END -! -!####################################################################### -!---------------- Calculate ice deposition at T con_CP, RD => con_RD, RV => con_RV - &, HVAP => con_HVAP, HFUS => con_HFUS - &, EPS => con_EPS, EPSM1 => con_epsm1 -! -!--- Also uses the Asai (1965) algorithm, but uses a different target -! vapor pressure for the adjustment -! - INTEGER, PARAMETER :: HIGH_PRES=kind_phys -! INTEGER, PARAMETER :: HIGH_PRES=Selected_Real_Kind(15) - REAL (KIND=HIGH_PRES), PARAMETER :: RHLIMIT=.001, - & RHLIMIT1=-RHLIMIT -! REAL, PARAMETER :: CP=1004.6, RD=287.04, RV=461.5, XLS=2.834E6, -! & EPS=RD/RV, RCP=1./CP, RCPRV=RCP/RV, XLS1=XLS*RCP, -! & XLS2=XLS*XLS*RCPRV, EPSM1=RD/RV-1. - REAL, PARAMETER :: RCP=1./CP, RCPRV=RCP/RV, XLS=HVAP+HFUS - &, XLS1=XLS*RCP, XLS2=XLS*XLS*RCPRV - REAL (KIND=HIGH_PRES) :: DEP, SSAT - real (kind=kind_phys) r_val,r_fpvs,r_pp -! -!----------------------------------------------------------------------- -! - r_val=Tdum - r_fpvs=FPVSI(r_val) - r_pp=pp - ESI=min(r_pp,r_fpvs) ! Saturation vapor press w/r/t ice -! WS=RHgrd*EPS*ESI/(PP-ESI) ! Saturation mixing ratio - WS=RHgrd*EPS*ESI/(PP+epsm1*ESI) ! Saturation mixing ratio - DWV=WVdum-WS ! Deficit grid-scale water vapor mixing ratio - SSAT=DWV/WS ! Supersaturation ratio - DEPOSIT=0. - DO WHILE (SSAT.GT.RHLIMIT .OR. SSAT.LT.RHLIMIT1) - ! - !--- Note that XLVS2=LS*LV/(CP*RV)=LV*WS/(RV*T*T)*(LS/CP*DEP1), - ! where WS is the saturation mixing ratio following Clausius- - ! Clapeyron (see Asai,1965; Young,1993,p.405) - ! - DEP=DWV/(1.+XLS2*WS/(Tdum*Tdum)) ! Asai (1965, J. Japan) - Tdum=Tdum+XLS1*DEP ! Updated temperature - WVdum=WVdum-DEP ! Updated ice mixing ratio - DEPOSIT=DEPOSIT+DEP ! Total ice deposition - r_val=Tdum - r_fpvs=FPVSI(r_val) - r_pp=pp - ESI=min(r_pp,r_fpvs) ! Updated saturation vapor press w/r/t ice -! WS=RHgrd*EPS*ESI/(PP-ESI) ! Updated saturation mixing ratio w/r/t ice - WS=RHgrd*EPS*ESI/(PP+epsm1*ESI) ! Updated saturation mixing ratio w/r/t ice - DWV=WVdum-WS ! Deficit grid-scale water vapor mixing ratio - SSAT=DWV/WS ! Grid-scale supersaturation ratio - ENDDO - RETURN - END diff --git a/src/fim/FIMsrc/fim/column/gsmddrive_v.f b/src/fim/FIMsrc/fim/column/gsmddrive_v.f deleted file mode 100644 index f01c840..0000000 --- a/src/fim/FIMsrc/fim/column/gsmddrive_v.f +++ /dev/null @@ -1,567 +0,0 @@ -!@PROCESS NOEXTCHK -! -!--- The 1st line is an inlined compiler directive that turns off -qextchk -! during compilation, even if it's specified as a compiler option in the -! makefile (Tuccillo, personal communication; Ferrier, Feb '02). -! -!############################################################################### -!---------------------- Driver of the new microphysics ------------------------- -!############################################################################### -! - SUBROUTINE GSMDRIVE(IM, IX, LM,DT,PRSL,DEL,TIN,QIN,CCIN,slmsk, & - & F_ice, F_rain, F_RimeF, APREC, SR, GRAV, & - & HVAP, HSUB, CP, RHC, XNCW, flgmin, & - & me, lprnt, ipr) -! & HVAP, CP, RHC, XNCW, me, PRINT_diag) -! -!------------------------------------------------------------------------------- -!----- NOTE: Code is currently set up w/o threading! -!------------------------------------------------------------------------------- -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: Grid-scale microphysical processes - condensation & precipitation -! PRGRMMR: Ferrier ORG: W/NP22 DATE: February 2001 -! 2001-04-xx Ferrier - Beta-tested version -! 2001-05-21 Ferrier - Added gradual latent heating to remove external waves -! 2001-05-30 Ferrier - Changed default to uniform maritime conditions for testing -! 2001-11-09 Moorthi - Modified for Global Spectral Model -!------------------------------------------------------------------------------- -! ABSTRACT: -! * Merges original GSCOND & PRECPD subroutines. -! * Code has been substantially streamlined and restructured. -! * Exchange between water vapor & small cloud condensate is calculated using -! the original Asai (1965, J. Japan) algorithm. See also references to -! Yau and Austin (1979, JAS), Rutledge and Hobbs (1983, JAS), and Tao et al. -! (1989, MWR). This algorithm replaces the Sundqvist et al. (1989, MWR) -! parameterization. -!------------------------------------------------------------------------------- -! Prior PROGRAM HISTORY LOG: -! -! *** Heritage as Subroutine GSCOND: -! 94-~?? ZHAO - ORIGINATOR -! 95-03-25 BLACK - CONVERSION FROM 1-D TO 2-D IN HORIZONTAL -! 95-03-28 BLACK - ADDED EXTERNAL EDGE -! 98-11-02 BLACK - MODIFIED FOR DISTRIBUTED MEMORY -! -! *** Heritage as Subroutine PRECPD: -! 94-~?? ZHAO - ORIGINATOR -! 95-03-25 BLACK - CONVERSION FROM 1-D TO 2-D IN HORIZONTAL -! 95-11-20 ABELES - PARALLEL OPTIMIZATION -! 96-03-29 BLACK - REMOVED SCRCH COMMON -! 96-07-18 ZHAO - NEW WMIN CALCULATION -! 96-09-25 BALDWIN - NEW SR CALCULATION -! 98-11-02 BLACK - MODIFICATION FOR DISTRIBUTED MEMORY -!------------------------------------------------------------------------------- -! -! USAGE: CALL GSMDRIVE FROM gbphys -! -! INPUT ARGUMENT LIST: -! LM,DT,SL,DEL,PS,TIN,QIN,CCIN,slmsk, -! F_ice, F_rain, F_RimeF, APREC, SR, GRAV, -! ilon, ilat, HVAP, CP, RHC, XNCW,me -! -! OUTPUT ARGUMENT LIST: -! TIN, QIN, CCIN, F_ice, F_rain, F_RimeF, APREC -! -! OUTPUT FILES: -! NONE -! -! Subprograms & Functions called: -! GSMCONST - initialize rain & ice lookup tables, read from external file; -! initialize constants -! GSMCOLUMN - cloud microphysics calculations over vertical columns -! -! UNIQUE: NONE -! -! LIBRARY: NONE -! -!?--- COMMON BLOCKS (input for microphysics): -!? CTLBLK, LOOPS, MASKS, PHYS, VRBLS, CLDWTR, PVRBLS, ACMCLH, PPTASM, C_FRACN -! -!--- COMMON BLOCKS ("triggers" for microphysics & statistics): -! CMICRO_START, CMICRO_STATS -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE : IBM SP -! -!------------------------------------------------------------------------ - USE MACHINE , ONLY : kind_phys - use module_microphysics , only : gsmcolumn - implicit none -! - integer im, ix, lm, ilon, ilat, me, ipr - real (kind=kind_phys) DT, GRAV, HVAP, HSUB, CP - real (kind=kind_phys) TIN(IX,LM), QIN(IX,LM), CCIN(IX,LM) & - &, DEL(IX,LM), PRSL(IX,LM), RHC(IM,LM) & - &, slmsk(IM), APREC(IM), SR(IM), XNCW(IM) & - &, RHC_col(LM), FLGMIN(im) - logical lprnt -! -!---------------------------------------------------------------------- -!----- Key parameters passed to column microphysics (COLUMN_MICRO) ------ -!------------------------------------------------------------------------- -! -!--- Flag from INIT.F at start of model run, used in initiating statistics -! -! COMMON /CMICRO_START/ MICRO_START -! LOGICAL :: MICRO_START -! -!--- This variable is for debugging purposes (if .true.) -! -! LOGICAL, PARAMETER :: PRINT_diag=.TRUE. - LOGICAL PRINT_diag -! -!--- The following variables are for microphysical statistics (non-essential) -! -! INTEGER, PARAMETER :: ITLO=-60, ITHI=40, ITHILO=ITHI-ITLO+1, -! & ITHILO_N=ITHILO*4, ITHILO_QM=ITHILO*5, ITHILO_QT=ITHILO*22 -! COMMON /CMICRO_STATS/ NSTATS(ITLO:ITHI,4), QMAX(ITLO:ITHI,5), -! & QTOT(ITLO:ITHI,22) -! INTEGER :: NSTATS, NSTATS_0(ITLO:ITHI,4) -! REAL :: QMAX, QTOT, QMAX_0(ITLO:ITHI,5),QTOT_0(ITLO:ITHI,22) -! REAL, SAVE :: Thour_print, -! & PRECmax(2),PRECtot(2),PRECmax_0(2),PRECtot_0(2) -! REAL, PARAMETER :: DThour_print=3. ! Print statistics every 3 h -! REAL, PARAMETER :: DThour_print=0. ! Print statistics every time step -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~~~~ BEGIN section on hydrometeor fractions -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~~~~ Saved values use REAL (REAL*4) arrays rather than INTEGER*2 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -! - real (kind=kind_phys) F_ice(IX,LM), F_rain(IX,LM), F_RimeF(IX,LM),& - & Fice, Frain, DUM -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~~~~ END section on hydrometeor fractions -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!----------------------------------------------------------------------- -!-------------- Local arrays & parameters in GSMDRIVE ----------------- -!----------------------------------------------------------------------- -! -!---- Comments on 14 March 2002 -! * EPSQ=1.E-12 is the universal lower limit for specific humidity and -! total condensate, and is consistent throughout the Eta code. -! -! REAL, PARAMETER :: EPSQ=1.E-12, RHOL=1000., T0C=273.15, - REAL, PARAMETER :: EPSQ=1.0E-20, RHOL=1000., T0C=273.15, & - & T_ICE=-40., T_ICEK=T0C+T_ICE, RRHOL=1./RHOL, EPSQ1=1.001*EPSQ -! & T_ICE=-10., T_ICEK=T0C+T_ICE, RRHOL=1./RHOL, EPSQ1=1.001*EPSQ -! - REAL ARAIN, ASNOW, P_col(LM), QI_col(LM), QR_col(LM), & - & QV_col(LM), QW_col(LM), RimeF_col(LM), T_col(LM), THICK_col(LM), & - & WC_col(LM), NCW(LM) -! -! - real Ps_Pa, QAUT0, tc, wc, qi, qr, qw, psfc - integer L, LL, i -! -!------------------------------------------------------------------------ -! -!####################################################################### -!########################## Begin Execution ############################ -!####################################################################### -! -!------------------------------------------------------------------------ -!---------------------- Microphysical constants ------------------------- -!------------------------------------------------------------------------ -! -! -! move water from vapor to liquid should the liquid amount be negative -! - do L = 1, LM - do i=1,im - if (CCIN(i,L) .lt. 0.0) then - qin(i,L) = qin(i,L) + CCIN(i,L) - if (tin(i,l) .gt. t_icek) then - tin(i,L) = tin(i,L) - CCIN(i,L) * (HVAP/CP) - else - tin(i,L) = tin(i,L) - CCIN(i,L) * (HSUB/CP) - endif - CCIN(i,L) = 0. - endif - enddo - enddo -! -!------------------------------------------------------------------------ -!--------------- Initialize constants for statistics -------------------- -!------------------------------------------------------------------------ -! -! Thour_print=-DTPH/3600.+FLOAT(NTSD-1)*DT/3600. -! IF (PRINT_diag) THEN -! -!-------- Total and maximum quantities -! -! DO I=ITLO,ITHI -!--- Microphysical statistics dealing w/ grid-point counts -! DO J=1,4 -! NSTATS(I,J)=0 -! ENDDO -!--- Microphysical statistics dealing w/ maxima of hydrometeor mass -! DO J=1,5 -! QMAX(I,J)=0. -! ENDDO -!--- Microphysical statistics dealing w/ total hydrometeor mass -! DO J=1,22 -! QTOT(I,J)=0. -! ENDDO -! ENDDO -! DO I=1,2 -! PRECmax(I)=0. ! Maximum precip rates (rain, snow) at surface (mm/h) -! PRECtot(I)=0. ! Total precipitation (rain, snow) accumulation at surface -! ENDDO -! ENDIF -! ENDIF -! - do i=1,im ! Begining of the I loop! -! -! if (lprnt .and. i .eq. ipr) then -! PRINT_diag = .true. -! else - PRINT_diag = .false. -! endif -! IF (PRINT_diag) THEN -! print *,' printing for i=',i,' me=',me -! print *,' ccin=',ccin(ipr,:) -! print *,' qin=',qin(ipr,:) -! print *,' F_rain=',F_rain(ipr,:) -! endif -! -!--- Initialize column data (1D arrays) -! - psfc = 0.0 - DO L=1,LM - LL = LM + 1 - L - P_col(L) = PRSL(I,LL) * 1000.0 ! Level Pressure in Pa - THICK_col(L) = DEL(I,LL) * (1000.0/GRAV) !--- Layer thickness = RHO*DZ - T_col(L) = TIN(I,LL) - QV_col(L) = max(EPSQ, QIN(I,LL)) - RHC_col(L) = RHC(I,LL) - WC_col(L) = CCIN(I,LL) -! NCW(L) = XNCW(I) * (P_col(L)*0.001) - NCW(L) = XNCW(I) - psfc = psfc + del(I,LL) * 1000.0 - ENDDO -! if (print_diag) print *,' wc_col=',wc_col - DO L=1,LM - LL = LM + 1 - L - TC = T_col(L)-T0C - IF (WC_col(L) .LE. EPSQ1) THEN - WC_col(L) = 0. - IF (TC .LT. T_ICE) THEN - F_ice(I,LL) = 1. - ELSE - F_ice(I,LL) = 0. - ENDIF - F_rain(I,LL) = 0. - F_RimeF(I,LL) = 1. - ENDIF -! -!--- Determine composition of condensate in terms of -! cloud water, ice, & rain -! - WC = WC_col(L) - QI = 0. - QR = 0. - QW = 0. - Fice = F_ice(I,LL) - Frain = F_rain(I,LL) -! -!--- REAL*4 array storage -! -! if (print_diag) print *,' L=',L,' fice=',fice,' frain=',frain -! &,' wc=',wc - IF (Fice .GE. 1.) THEN - QI = WC - ELSE IF (Fice .LE. 0.) THEN - QW = WC - ELSE - QI = Fice*WC - QW = WC-QI - ENDIF - IF (QW.GT.0. .AND. Frain.GT.0.) THEN - IF (Frain .GE. 1.) THEN - QR = QW - QW = 0. - ELSE - QR = Frain*QW - QW = QW-QR - ENDIF - ENDIF - RimeF_col(L) = F_RimeF(I,LL) ! (real) -! -! if (print_diag) print *,' qi=',qi,' qr=',qr,' qw=',qw,' wc=',wc - QI_col(L) = QI - QR_col(L) = QR - QW_col(L) = QW - ENDDO -! if (PRINT_diag) then -! print *,' QI_col=',qi_col -! print *,' QR_col=',qr_col -! print *,' QW_col=',qw_col -! endif -! -!####################################################################### -! -!--- Perform the microphysical calculations in this column -! - ilon = i - ilat = 0 - CALL GSMCOLUMN ( ARAIN, ASNOW, DT, ilon, ilat, LM, & - & P_col, QI_col, QR_col, QV_col, QW_col, RimeF_col, T_col, & -! & THICK_col, WC_col, lm, RHC_col, NCW, .false., psfc) - & THICK_col, WC_col, lm, RHC_col, NCW, flgmin(i), PRINT_diag, psfc) -! -!####################################################################### -! -! -!####################################################################### -! -! if (PRINT_diag) then -! print *,' arain=',arain,' asnow=',asnow -! print *,' aQI_col=',qi_col -! print *,' aQR_col=',qr_col -! print *,' aQW_col=',qw_col -! endif -! -!--- Update storage arrays -! - DO L=1,LM - LL = LM + 1 - L - TIN(I,LL) = T_col(L) - IF (QIN(I,LL) .LT. EPSQ) THEN - QIN(I,LL) = QIN(I,LL) + QV_col(L) - else - QIN(I,LL) = QV_col(L) - endif -! if (print_diag) print *,' ccin=',ccin(ipr,ll), wc_col(l) - IF (CCIN(I,LL) .LT. EPSQ) THEN - CCIN(I,LL) = CCIN(I,LL) + WC_col(L) - else - CCIN(I,LL) = WC_col(L) - endif -! if (print_diag) print *,' accin=',ccin(ipr,ll), wc_col(l) -! -!--- REAL*4 array storage -! - F_RimeF(I,LL)=MAX(1., RimeF_col(L)) - IF (QI_col(L) .LE. EPSQ) THEN - F_ice(I,LL)=0. - IF (T_col(L) .LT. T_ICEK) F_ice(I,LL)=1. - ELSE - F_ice(I,LL)=MAX( 0., MIN(1., QI_col(L)/WC_col(L)) ) - ENDIF - IF (QR_col(L) .LE. EPSQ) THEN - DUM=0 - ELSE - DUM=QR_col(L)/(QR_col(L)+QW_col(L)) - ENDIF - F_rain(I,LL)=DUM -! -! - ENDDO -! -! IF (PRINT_diag) THEN -! print *,' accin=',ccin(ipr,:) -! print *,' aqin=',qin(ipr,:) -! print *,' aF_rain=',F_rain(ipr,:) -! endif -! -!--- Update accumulated precipitation statistics -! -!--- Surface precipitation statistics; SR is fraction of surface -! precipitation (if >0) associated with snow -! - APREC(I) = (ARAIN+ASNOW)*RRHOL ! Accumulated surface precip (depth in m) - IF(APREC(i) .LT. 1.E-8) THEN - SR(I) = 0. - ELSE - SR(I) = RRHOL*ASNOW / APREC(I) - ENDIF -! -! IF (PRINT_diag) THEN -! print *,' ccio=',ccin -! print *,' qio=',qin -! print *,' F_rain=',F_rain -! print *,' aprec=',aprec,' arain=',arain,' asnow=',asnow -! endif -! -!--- Debug statistics -! -! IF (PRINT_diag) THEN -! PRECtot(1)=PRECtot(1)+ARAIN -! PRECtot(2)=PRECtot(2)+ASNOW -! PRECmax(1)=MAX(PRECmax(1), ARAIN) -! PRECmax(2)=MAX(PRECmax(2), ASNOW) -! ENDIF -!####################################################################### -!####################################################################### -! -!----------------------------------------------------------------------- -!--------------------- END of main microphysics loop ------------------- -!----------------------------------------------------------------------- -! - ENDDO ! End of the I loop -! -! time_model=float(NTSD-1)*DT/3600. -! IF (PRINT_diag .AND. time_model.GE.Thour_print) THEN -! CALL MPI_REDUCE(NSTATS,NSTATS_0,ITHILO_N,MPI_INTEGER,MPI_SUM,0, -! & MPI_COMM_COMP,IRTN) -! CALL MPI_REDUCE(QMAX,QMAX_0,ITHILO_QM,MPI_REAL,MPI_MAX,0, -! & MPI_COMM_COMP,IRTN) -! CALL MPI_REDUCE(PRECmax,PRECmax_0,2,MPI_REAL,MPI_MAX,0, -! & MPI_COMM_COMP,IRTN) -! CALL MPI_REDUCE(QTOT,QTOT_0,ITHILO_QT,MPI_REAL,MPI_SUM,0, -! & MPI_COMM_COMP,IRTN) -! CALL MPI_REDUCE(PRECtot,PRECtot_0,2,MPI_REAL,MPI_SUM,0, -! & MPI_COMM_COMP,IRTN) -! IF (MYPE .EQ. 0) THEN -! HDTPH=3600./DTPH ! Convert precip rates to mm/h -! DO K=ITLO,ITHI -! QMAX_0(K,1)=1000.*QMAX_0(K,1) -! QMAX_0(K,2)=1000.*QMAX_0(K,2) -! QMAX_0(K,3)=1000.*QMAX_0(K,3) -! QMAX_0(K,4)=HDTPH*QMAX_0(K,4) -! QMAX_0(K,5)=HDTPH*QMAX_0(K,5) -! ENDDO -! PRECmax_0(1)=HDTPH*PRECmax_0(1) -! PRECmax_0(2)=HDTPH*PRECmax_0(2) -! -! WRITE(6,"(A,F5.2,4(A,G11.4))") '{ Time(h)=',time_model, -! & ' TRAIN_sfc=',PRECtot_0(1),' TSNOW_sfc=',PRECtot_0(2), -! & ' RRmax_sfc(mm/h)=',PRECmax_0(1), -! & ' SRmax_sfc(mm/h)=',PRECmax_0(2) -! -! WRITE(6,"(3A)") '{ (C) <--------- Counts ----------> ', -! & '<----------- g/kg ----------> <----- mm/h ------>', -! & ' <---- kg/m**2 * # grids ---->' -! WRITE(6,"(3A)") '{ T NCICE NCMIX NCWAT NCRAIN ', -! & 'QIMAX QWMAX QRMAX SRMAX RRMAX QITOT ', -! & 'QWTOT QRTOT' -! DO K=ITLO,ITHI -! WRITE(6,"(A,I3,I9,3I7,8G10.4)") -! & '{ ',K,(NSTATS_0(K,II), II=1,4), -! & (QMAX_0(K,JJ), JJ=1,5),(QTOT_0(K,KK), KK=1,3) -! ENDDO -! -! WRITE(6,"(3A)") -! & '{ T TCOND TICND TIEVP TIDEP TREVP ', -! & 'TRAUT TRACW TIMLT TIACW TIACWI TIACWR ', -! & 'TIACR' -! DO K=ITLO,ITHI -! WRITE(6,"(A,I3,12G10.4)") '{ ',K,(QTOT_0(K,II), II=4,15) -! ENDDO -! -! WRITE(6,"(2A)") -! & '{ T DEL_QT TVDIF DEL_HYD TWDIF TIDIF ', -! & 'TRDIF DARAIN DASNOW RimeF' -! DO K=ITLO,ITHI -! DEL_HYD=0. -! DO II=17,19 -! DEL_HYD=DEL_HYD+QTOT_0(K,II) -! ENDDO -! DEL_QT=0. -! DO II=16,21 -! DEL_QT=DEL_QT+QTOT_0(K,II) -! ENDDO -! IF (QTOT_0(K,22) .GT. 0.) THEN -! RimeF_bulk=QTOT_0(K,1)/QTOT_0(K,22) -! ELSE -! RimeF_bulk=1. -! ENDIF -! WRITE(6,"(A,I3,9G10.4)") '{ ',K,DEL_QT,QTOT_0(K,16), -! & DEL_HYD,(QTOT_0(K,II), II=17,21),RimeF_bulk -! ENDDO -! -! ENDIF -! -!-------- Reset arrays storing total and maximum quantities -! -! DO I=ITLO,ITHI -!--- Microphysical statistics dealing w/ grid-point counts -! DO J=1,4 -! NSTATS(I,J)=0 -! ENDDO -!--- Microphysical statistics dealing w/ maxima of hydrometeor mass -! DO J=1,5 -! QMAX(I,J)=0. -! ENDDO -!--- Microphysical statistics dealing w/ total hydrometeor mass -! DO J=1,22 -! QTOT(I,J)=0. -! ENDDO -! ENDDO -! DO I=1,2 -! PRECmax(I)=0. ! Maximum precip rates (rain, snow) at surface (mm/h) -! PRECtot(I)=0. ! Total precipitation (rain, snow) accumulation at surface -! ENDDO -! Thour_print=Thour_print+DThour_print -! ENDIF -! -!----------------------------------------------------------------------- -!------------------------ Return to main program ----------------------- -!----------------------------------------------------------------------- -! - RETURN -!----------------------------------------------------------------------- -200 format(a2,i5,f6.2,4(1x,a10,g11.4)) -210 format(a2,i5,f6.2,4(1x,a10,i7)) -!----------------------------------------------------------------------- - END - SUBROUTINE MICRO_INIT(LM,LEN,F_ice,F_rain,F_RimeF,DT,FHOUR,me & - &, first) -! -! This subroutine initializes the necessary constants and -! tables for Brad Ferrier's cloud microphysics package -! - USE MACHINE , ONLY : kind_phys - use module_microphysics , only : gsmconst - implicit none -! - logical first - integer LM, LEN, me - real (kind=kind_phys) F_ice(LEN,LM), F_rain(LEN,LM), & - & F_RimeF(LEN,LM), DT, FHOUR -! - if (fhour .lt. 0.1) then - F_ice = 0. ! Initialize ice fraction array (real) - F_rain = 0. ! Initialize rain fraction array (real) - F_RimeF = 1. ! Initialize rime factor array (real) - endif - CALL GSMCONST (DT,me,first) ! Initialize lookup tables & constants -! - RETURN - END - SUBROUTINE INIT_MICRO(DT,levs,len,num_p3d,phy_f3d,fhour,me) -! - USE MACHINE , ONLY : kind_phys - implicit none -! - integer levs, len, num_p3d, me, nsphys - real (kind=kind_phys) dt, fhour, phy_f3d(len,levs,num_p3d) & - &, dtlast, dtp, dtphys - logical first - data first/.true./, dtlast/0.0/ - save first, dtlast -! - dtphys=3600. - NSPHYS=MAX(INT(2*dt/DTPHYS+0.9999),1) - DTP=(dt+dt) / NSPHYS -! - if (num_p3d .eq. 3 .and. dtp .ne. dtlast) then -! Initialization and/or constant evaluation for Ferrier's microphysics - call MICRO_INIT(LEVS, len, phy_f3d(1,1,1), phy_f3d(1,1,2) & - &, phy_f3d(1,1,3), DTP, FHOUR, me, first) - dtlast = dtp - first = .false. - endif - - - RETURN - END diff --git a/src/fim/FIMsrc/fim/column/gwdc.f b/src/fim/FIMsrc/fim/column/gwdc.f deleted file mode 100755 index 25279a8..0000000 --- a/src/fim/FIMsrc/fim/column/gwdc.f +++ /dev/null @@ -1,1089 +0,0 @@ - subroutine gwdc(im,ix,iy,km,lat,u1,v1,t1,q1, - & rcs,pmid1,pint1,dpmid1,qmax,cumchr1,ktop,kbot,kuo, - & fu1,fv1,g,cp,rd,fv,dlength,lprnt,ipr,fhour, - & tauctx,taucty,brunm1,rhom1) -! & gwdcloc,critic,brunm1,rhom1) - -!*********************************************************************** -! ORIGINAL CODE FOR PARAMETERIZATION OF CONVECTIVELY FORCED -! GRAVITY WAVE DRAG FROM YONSEI UNIVERSITY, KOREA -! BASED ON THE THEORY GIVEN BY CHUN AND BAIK (JAS, 1998) -! MODIFIED FOR IMPLEMENTATION INTO THE GFS/CFS BY -! AKE JOHANSSON --- AUG 2005 -!*********************************************************************** - - USE MACHINE , ONLY : kind_phys - implicit none - -!---------------------------- Arguments -------------------------------- -! -! Input variables -! -! u : midpoint zonal wind -! v : midpoint meridional wind -! t : midpoint temperatures -! pmid : midpoint pressures -! pint : interface pressures -! dpmid : midpoint delta p ( pi(k)-pi(k-1) ) -! rcs : reciprocal of cosine latitude rcs=1/cos(lat) -! rcsi : cosine latitude rcsi=cos(lat) -! lat : latitude index -! qmax : deep convective heating -! kcldtop : Vertical level index for cloud top ( mid level ) -! kcldbot : Vertical level index for cloud bottom ( mid level ) -! kuo : (0,1) dependent on whether convection occur or not -! -! Output variables -! -! fu1 : zonal wind tendency -! fv1 : meridional wind tendency -! -!----------------------------------------------------------------------- - - integer im, ix, iy, km, lat, ipr, ilev - integer ktop(im),kbot(im),kuo(im) - integer kcldtop(im),kcldbot(im) - - real(kind=kind_phys) g,cp,rd,fv,dlength(im),rcs(im),rcsi(im) - real(kind=kind_phys) qmax(ix),cumchr1(ix,km),cumchr(ix,km) - real(kind=kind_phys) fhour,fhourpr - real(kind=kind_phys) u1(ix,km),v1(ix,km),t1(ix,km),q1(ix,km), - & pmid1(ix,km),dpmid1(ix,km),pint1(ix,km+1), - & fu1(iy,km),fv1(iy,km) - real(kind=kind_phys) u(im,km),v(im,km),t(im,km),spfh(im,km), - & pmid(im,km),dpmid(im,km),pint(im,km+1) - - logical lprnt - -!------------------------- Local workspace ----------------------------- -! -! i, k : Loop index -! ii,kk : Loop index -! cldbar : Deep convective cloud coverage at the cloud top. -! ugwdc : Zonal wind after GWDC paramterization -! vgwdc : Meridional wind after GWDC parameterization -! plnmid : Log(pmid) ( mid level ) -! plnint : Log(pint) ( interface level ) -! dpint : Delta pmid ( interface level ) -! tauct : Wave stress at the cloud top calculated using basic-wind -! parallel to the wind vector at the cloud top ( mid level ) -! tauctx : Wave stress at the cloud top projected in the east -! taucty : Wave stress at the cloud top projected in the north -! qmax : Maximum deep convective heating rate ( K s-1 ) in a -! horizontal grid point calculated from cumulus para- -! meterization. ( mid level ) -! wtgwc : Wind tendency in direction to the wind vector at the cloud top level -! due to convectively generated gravity waves ( mid level ) -! utgwc : Zonal wind tendency due to convectively generated -! gravity waves ( mid level ) -! vtgwc : Meridional wind tendency due to convectively generated -! gravity waves ( mid level ) -! taugwci : Profile of wave stress calculated using basic-wind -! parallel to the wind vector at the cloud top -! taugwcxi : Profile of zonal component of gravity wave stress -! taugwcyi : Profile of meridional component of gravity wave stress -! -! taugwci, taugwcxi, and taugwcyi are defined at the interface level -! -! bruni : Brunt-Vaisala frequency ( interface level ) -! brunm : Brunt-Vaisala frequency ( mid level ) -! rhoi : Air density ( interface level ) -! rhom : Air density ( mid level ) -! ti : Temperature ( interface level ) -! basicum : Basic-wind profile. Basic-wind is parallel to the wind -! vector at the cloud top level. (mid level) -! basicui : Basic-wind profile. Basic-wind is parallel to the wind -! vector at the cloud top level. ( interface level ) -! riloc : Local Richardson number ( interface level ) -! rimin : Minimum Richardson number including both the basic-state -! and gravity wave effects ( interface level ) -! gwdcloc : Horizontal location where the GWDC scheme is activated. -! break : Horizontal location where wave breaking is occurred. -! critic : Horizontal location where critical level filtering is -! occurred. -! dogwdc : Logical flag whether the GWDC parameterization is -! calculated at a grid point or not. -! -! dogwdc is used in order to lessen CPU time for GWDC calculation. -! -!----------------------------------------------------------------------- - - integer i,ii,k,k1,k2,kk,kb - - real(kind=kind_phys) cldbar(im), - & ugwdc(im,km),vgwdc(im,km), - & plnmid(im,km),plnint(im,km+1),dpint(im,km+1), - & tauct(im),tauctx(im),taucty(im), - & wtgwc(im,km),utgwc(im,km),vtgwc(im,km), - & taugwci(im,km+1),taugwcxi(im,km+1),taugwcyi(im,km+1), - & bruni(im,km+1),rhoi(im,km+1),ti(im,km+1), - & brunm(im,km),rhom(im,km),brunm1(im,km),rhom1(im,km), - & basicum(im,km),basicui(im,km+1), - & riloc(km+1),rimin(km+1) - - real(kind=kind_phys) gwdcloc(im),break(im),critic(im) - real(kind=kind_phys) tem1, tem2, qtem - - logical dogwdc(im) - -!----------------------------------------------------------------------- -! -! ucltop : Zonal wind at the cloud top ( mid level ) -! vcltop : Meridional wind at the cloud top ( mid level ) -! windcltop : Wind speed at the cloud top ( mid level ) -! shear : Vertical shear of basic wind -! cosphi : Cosine of angle of wind vector at the cloud top -! sinphi : Sine of angle of wind vector at the cloud top -! c1 : Tunable parameter -! c2 : Tunable parameter -! dlength : Grid spacing in the direction of basic wind at the cloud top -! nonlinct : Nonlinear parameter at the cloud top -! nonlin : Nonlinear parameter above the cloud top -! nonlins : Saturation nonlinear parameter -! taus : Saturation gravity wave drag -! n2 : Square of Brunt-Vaisala frequency -! dtdp : dT/dp -! xstress : Vertically integrated zonal momentum change due to GWDC -! ystress : Vertically integrated meridional momentum change due to GWDC -! crit1 : Variable 1 for checking critical level -! crit2 : Variable 2 for checking critical level -! sum1 : Temporary variable -! -!----------------------------------------------------------------------- - - real(kind=kind_phys) ucltop, vcltop, windcltop, shear, kcldtopi - real(kind=kind_phys) cosphi, sinphi, angle - real(kind=kind_phys) nonlinct, nonlin, nonlins, taus - -!----------------------------------------------------------------------- - real(kind=kind_phys), parameter :: - & c1=1.41, c2=-0.38, ricrit=0.25 - &, n2min=1.e-32, zero=0.0, one=1.0 - &, taumin=1.0e-20, tauctmax=-20. - &, qmin=1.0e-10, shmin=1.0e-20 - &, rimax=1.0e+20, rimaxm=0.99e+20 - &, rimaxp=1.01e+20, rilarge=0.9e+20 - &, riminx=-1.0e+20, riminm=-1.01e+20 - &, riminp=-0.99e+20, rismall=-0.9e+20 - - real(kind=kind_phys) n2, dtdp, sum1, xstress, ystress - real(kind=kind_phys) crit1, crit2 - real(kind=kind_phys) pi,p1,p2 - -!----------------------------------------------------------------------- -! Write out incoming variables -!----------------------------------------------------------------------- - - fhourpr = zero - if (lprnt) then - if (fhour.ge.fhourpr) then - print *,' ' - write(*,*) 'Inside GWDC raw input start print at fhour = ', - & fhour - write(*,*) 'IX IM KM ',ix,im,km - write(*,*) 'KBOT KTOP QMAX DLENGTH KUO ', - + kbot(ipr),ktop(ipr),qmax(ipr),dlength(ipr),kuo(ipr) - write(*,*) 'g cp rd RCS ',g,cp,rd,RCS(ipr) - -!-------- Pressure levels ---------- - write(*,9100) - ilev=km+1 - write(*,9110) ilev,(10.*pint1(ipr,ilev)) - do ilev=km,1,-1 - write(*,9120) ilev,(10.*pmid1(ipr,ilev)), - & (10.*dpmid1(ipr,ilev)) - write(*,9110) ilev,(10.*pint1(ipr,ilev)) - enddo - -!-------- U1 V1 T1 ---------- - write(*,9130) - do ilev=km,1,-1 - write(*,9140) ilev,U1(ipr,ilev),V1(ipr,ilev),T1(ipr,ilev) - enddo - - print *,' ' - print *,' Inside GWDC raw input end print' - endif - endif - - 9100 format(//,14x,'PRESSURE LEVELS',//, - +' ILEV',6x,'PINT1',7x,'PMID1',6x,'DPMID1',/) - 9110 format(i4,2x,f10.3) - 9120 format(i4,12x,2(2x,f10.3)) - 9130 format(//,' ILEV',7x,'U1',10x,'V1',10x,'T1',/) - 9140 format(i4,3(2x,f10.3)) - -!----------------------------------------------------------------------- -! Create local arrays with reversed vertical indices -! Make regular (U,V) by using array RCS=1/cos(lat) -! Incoming (U1,V1)=cos(lat)*(U,V) -! Make pressure have unit of Pa [Multiply by 1000] -! Incoming pressures in kPa -!----------------------------------------------------------------------- - - do k=1,km - k1 = km - k + 1 - do i=1,im - u(i,k) = u1(i,k1)*rcs(i) - v(i,k) = v1(i,k1)*rcs(i) - t(i,k) = t1(i,k1) - spfh(i,k) = max(q1(i,k1),qmin) - pmid(i,k) = pmid1(i,k1)*1000. - dpmid(i,k) = dpmid1(i,k1)*1000. - cumchr(i,k) = cumchr1(i,k1) - enddo - enddo - - do k=1,km+1 - k1 = km - k + 2 - do i=1,im - pint(i,k) = pint1(i,k1)*1000. - enddo - enddo - - do i = 1, im - kcldtop(i) = km - ktop(i) + 1 - kcldbot(i) = km - kbot(i) + 1 - enddo - - if (lprnt) then - if (fhour.ge.fhourpr) then - write(*,9200) - do i=1,im - write(*,9201) kuo(i),kcldbot(i),kcldtop(i) - enddo - endif - endif - - 9200 format(//,' Inside GWDC local variables start print',//, - +2x,'KUO',2x,'KCLDBOT',2x,'KCLDTOP',//) - 9201 format(i4,2x,i5,4x,i5) - -!*********************************************************************** -! -! Begin GWDC -! -!*********************************************************************** - - pi = 2.*asin(1.) - -!----------------------------------------------------------------------- -! -! Initialize local variables -! -!----------------------------------------------------------------------- -! PRESSURE VARIABLES -! -! Interface 1 ======== pint(1) ********* -! Mid-Level 1 -------- pmid(1) dpmid(1) -! 2 ======== pint(2) dpint(2) -! 2 -------- pmid(2) dpmid(2) -! 3 ======== pint(3) dpint(3) -! 3 -------- pmid(3) dpmid(3) -! 4 ======== pint(4) dpint(4) -! 4 -------- pmid(4) dpmid(4) -! ........ -! 17 ======== pint(17) dpint(17) -! 17 -------- pmid(17) dpmid(17) -! 18 ======== pint(18) dpint(18) -! 18 -------- pmid(18) dpmid(18) -! 19 ======== pint(19) ********* -! -!----------------------------------------------------------------------- - - do k = 1, km+1 - do i = 1, im - plnint(i,k) = log(pint(i,k)) - taugwci(i,k) = zero - taugwcxi(i,k) = zero - taugwcyi(i,k) = zero - bruni(i,k) = zero - rhoi(i,k) = zero - ti(i,k) = zero - basicui(i,k) = zero - riloc(k) = zero - rimin(k) = zero - enddo - enddo - - do k = 1, km - do i = 1, im - plnmid(i,k) = log(pmid(i,k)) - wtgwc(i,k) = zero - utgwc(i,k) = zero - vtgwc(i,k) = zero - ugwdc(i,k) = zero - vgwdc(i,k) = zero - brunm(i,k) = zero - rhom(i,k) = zero - basicum(i,k) = zero - enddo - enddo - - do k = 2, km - do i = 1, im - dpint(i,k) = pmid(i,k) - pmid(i,k-1) - enddo - enddo - - do i = 1, im - dpint(i,1) = zero - dpint(i,km+1) = zero - tauct(i) = zero - tauctx(i) = zero - taucty(i) = zero - gwdcloc(i) = zero - break(i) = zero - critic(i) = zero - enddo - -!----------------------------------------------------------------------- -! THERMAL VARIABLES -! -! Interface 1 ======== TI(1) RHOI(1) BRUNI(1) -! 1 -------- T(1) RHOM(1) BRUNM(1) -! 2 ======== TI(2) RHOI(2) BRUNI(2) -! 2 -------- T(2) RHOM(2) BRUNM(2) -! 3 ======== TI(3) RHOI(3) BRUNI(3) -! 3 -------- T(3) RHOM(3) BRUNM(3) -! 4 ======== TI(4) RHOI(4) BRUNI(4) -! 4 -------- T(4) RHOM(4) BRUNM(4) -! ........ -! 17 ======== -! 17 -------- T(17) RHOM(17) BRUNM(17) -! 18 ======== TI(18) RHOI(18) BRUNI(18) -! 18 -------- T(18) RHOM(18) BRUNM(18) -! 19 ======== TI(19) RHOI(19) BRUNI(19) -! -!----------------------------------------------------------------------- - - do k = 1, km - do i = 1, im - rhom(i,k) = pmid(i,k) / (rd*t(i,k)*(1.0+fv*spfh(i,k))) - enddo - enddo - -!----------------------------------------------------------------------- -! -! Top interface temperature is calculated assuming an isothermal -! atmosphere above the top mid level. -! -!----------------------------------------------------------------------- - - do i = 1, im - ti(i,1) = t(i,1) - rhoi(i,1) = pint(i,1)/(rd*ti(i,1)) - bruni(i,1) = sqrt ( g*g / (cp*ti(i,1)) ) - enddo - -!----------------------------------------------------------------------- -! -! Calculate interface level temperature, density, and Brunt-Vaisala -! frequencies based on linear interpolation of Temp in ln(Pressure) -! -!----------------------------------------------------------------------- - - do k = 2, km - do i = 1, im - tem1 = (plnmid(i,k)-plnint(i,k)) / (plnmid(i,k)-plnmid(i,k-1)) - tem2 = one - tem1 - ti(i,k) = t(i,k-1) * tem1 + t(i,k) * tem2 - qtem = spfh(i,k-1) * tem1 + spfh(i,k) * tem2 - rhoi(i,k) = pint(i,k) / ( rd * ti(i,k)*(1.0+fv*qtem) ) - dtdp = (t(i,k)-t(i,k-1)) / (pmid(i,k)-pmid(i,k-1)) - n2 = g*g/ti(i,k)*( 1./cp - rhoi(i,k)*dtdp ) - bruni(i,k) = sqrt (max (n2min, n2)) - enddo - enddo - -!----------------------------------------------------------------------- -! -! Bottom interface temperature is calculated assuming an isothermal -! atmosphere below the bottom mid level -! -!----------------------------------------------------------------------- - - do i = 1, im - ti(i,km+1) = t(i,km) - rhoi(i,km+1) = pint(i,km+1)/(rd*ti(i,km+1)*(1.0+fv*spfh(i,km))) - bruni(i,km+1) = sqrt ( g*g / (cp*ti(i,km+1)) ) - enddo - -!----------------------------------------------------------------------- -! -! Determine the mid-level Brunt-Vaisala frequencies. -! based on interpolated interface Temperatures [ ti ] -! -!----------------------------------------------------------------------- - - do k = 1, km - do i = 1, im - dtdp = (ti(i,k+1)-ti(i,k)) / (pint(i,k+1)-pint(i,k)) - n2 = g*g/t(i,k)*( 1./cp - rhom(i,k)*dtdp ) - brunm(i,k) = sqrt (max (n2min, n2)) - enddo - enddo - -!----------------------------------------------------------------------- -! PRINTOUT -!----------------------------------------------------------------------- - - if (lprnt) then - if (fhour.ge.fhourpr) then - -!-------- Pressure levels ---------- - write(*,9101) - do ilev=1,km - write(*,9111) ilev,(0.01*pint(ipr,ilev)), - & (0.01*dpint(ipr,ilev)),plnint(ipr,ilev) - write(*,9121) ilev,(0.01*pmid(ipr,ilev)), - & (0.01*dpmid(ipr,ilev)),plnmid(ipr,ilev) - enddo - ilev=km+1 - write(*,9111) ilev,(0.01*pint(ipr,ilev)), - & (0.01*dpint(ipr,ilev)),plnint(ipr,ilev) - -! 2 -!-------- U V T N ---------- - write(*,9102) - do ilev=1,km - write(*,9112) ilev,ti(ipr,ilev),(100.*bruni(ipr,ilev)) - write(*,9122) ilev,u(ipr,ilev),v(ipr,ilev), - + t(ipr,ilev),(100.*brunm(ipr,ilev)) - enddo - ilev=km+1 - write(*,9112) ilev,ti(ipr,ilev),(100.*bruni(ipr,ilev)) - - endif - endif - - 9101 format(//,14x,'PRESSURE LEVELS',//, - +' ILEV',4x,'PINT',4x,'PMID',4x,'DPINT',3x,'DPMID',5x,'LNP',/) - 9111 format(i4,1x,f8.2,9x,f8.2,9x,f8.2) - 9121 format(i4,9x,f8.2,9x,f8.2,1x,f8.2) - 9102 format(//' ILEV',5x,'U',7x,'V',5x,'TI',7x,'T', - +5x,'BRUNI',3x,'BRUNM',//) - 9112 format(i4,16x,f8.2,8x,f8.3) - 9122 format(i4,2f8.2,8x,f8.2,8x,f8.3) - -!----------------------------------------------------------------------- -! -! Set switch for no convection present -! -!----------------------------------------------------------------------- - - do i = 1, im - dogwdc(i) =.true. - if (kuo(i) == 0 .or. qmax(i) <= zero) dogwdc(i) =.false. - enddo - -!*********************************************************************** -! -! Big loop over grid points ONLY done if KUO=1 -! -!*********************************************************************** - - do i = 1, im - - if ( dogwdc(i) ) then ! For fast GWDC calculation - - kk = kcldtop(i) - kb = kcldbot(i) - cldbar(i) = 0.1 - -!----------------------------------------------------------------------- -! -! Determine cloud top wind component, direction, and speed. -! Here, ucltop, vcltop, and windcltop are wind components and -! wind speed at mid-level cloud top index -! -!----------------------------------------------------------------------- - - ucltop = u(i,kcldtop(i)) - vcltop = v(i,kcldtop(i)) - windcltop = sqrt( ucltop*ucltop + vcltop*vcltop ) - cosphi = ucltop/windcltop - sinphi = vcltop/windcltop - angle = acos(cosphi)*180./pi - -!----------------------------------------------------------------------- -! -! Calculate basic state wind projected in the direction of the cloud -! top wind. -! Input u(i,k) and v(i,k) is defined at mid level -! -!----------------------------------------------------------------------- - - do k=1,km - basicum(i,k) = u(i,k)*cosphi + v(i,k)*sinphi - enddo - -!----------------------------------------------------------------------- -! -! Basic state wind at interface level is also calculated -! based on linear interpolation in ln(Pressure) -! -! In the top and bottom boundaries, basic-state wind at interface level -! is assumed to be vertically uniform. -! -!----------------------------------------------------------------------- - - basicui(i,1) = basicum(i,1) - do k=2,km - tem1 = (plnmid(i,k)-plnint(i,k)) / (plnmid(i,k)-plnmid(i,k-1)) - tem2 = one - tem1 - basicui(i,k) = basicum(i,k)*tem2 + basicum(i,k-1)*tem2 - enddo - basicui(i,km+1) = basicum(i,km) - -!----------------------------------------------------------------------- -! -! Calculate local richardson number -! -! basicum : U at mid level -! basicui : UI at interface level -! -! Interface 1 ======== UI(1) rhoi(1) bruni(1) riloc(1) -! Mid-level 1 -------- U(1) -! 2 ======== UI(2) dpint(2) rhoi(2) bruni(2) riloc(2) -! 2 -------- U(2) -! 3 ======== UI(3) dpint(3) rhoi(3) bruni(3) riloc(3) -! 3 -------- U(3) -! 4 ======== UI(4) dpint(4) rhoi(4) bruni(4) riloc(4) -! 4 -------- U(4) -! ........ -! 17 ======== UI(17) dpint(17) rhoi(17) bruni(17) riloc(17) -! 17 -------- U(17) -! 18 ======== UI(18) dpint(18) rhoi(18) bruni(18) riloc(18) -! 18 -------- U(18) -! 19 ======== UI(19) rhoi(19) bruni(19) riloc(19) -! -!----------------------------------------------------------------------- - - do k=2,km - shear = (basicum(i,k) - basicum(i,k-1))/dpint(i,k) * - & ( rhoi(i,k)*g ) - if ( abs(shear) .lt. shmin ) then - riloc(k) = rimax - else - riloc(k) = (bruni(i,k)/shear) ** 2 - if (riloc(k) .ge. rimax ) riloc(k) = rilarge - end if - enddo - - riloc(1) = riloc(2) - riloc(km+1) = riloc(km) - - if (lprnt.and.(i.eq.ipr)) then - if (fhour.ge.fhourpr) then - write(*,9104) ucltop,vcltop,windcltop,angle,kk - do ilev=1,km - write(*,9114) ilev,basicui(ipr,ilev),dpint(ipr,ilev), - + rhoi(ipr,ilev),(100.*bruni(ipr,ilev)),riloc(ilev) - write(*,9124) ilev,(basicum(ipr,ilev)) - enddo - ilev=km+1 - write(*,9114) ilev,basicui(ipr,ilev),dpint(ipr,ilev), - + rhoi(ipr,ilev),(100.*bruni(ipr,ilev)),riloc(ilev) - endif - endif - - 9104 format(//,'WIND VECTOR AT CLOUDTOP = (',f6.2,' , ',f6.2,' ) = ', - +f6.2,' IN DIRECTION ',f6.2,4x,'KK = ',i2,//, - +' ILEV',2x,'BASICUM',2x,'BASICUI',4x,'DPINT',6x,'RHOI',5x, - +'BRUNI',6x,'RI',/) - 9114 format(i4,10x,f8.2,4(2x,f8.2)) - 9124 format(i4,1x,f8.2) - -!----------------------------------------------------------------------- -! -! Calculate gravity wave stress at the interface level cloud top -! -! kcldtopi : The interface level cloud top index -! kcldtop : The midlevel cloud top index -! kcldbot : The midlevel cloud bottom index -! -! A : Find deep convective heating rate maximum -! -! If kcldtop(i) is less than kcldbot(i) in a horizontal grid point, -! it can be thought that there is deep convective cloud. However, -! deep convective heating between kcldbot and kcldtop is sometimes -! zero in spite of kcldtop less than kcldbot. In this case, -! maximum deep convective heating is assumed to be 1.e-30. -! -! B : kk is the vertical index for interface level cloud top -! -! C : Total convective fractional cover (cldbar) is used as the -! convective cloud cover for GWDC calculation instead of -! convective cloud cover in each layer (concld). -! a1 = cldbar*dlength -! You can see the difference between cldbar(i) and concld(i) -! in (4.a.2) in Description of the NCAR Community Climate -! Model (CCM3). -! In NCAR CCM3, cloud fractional cover in each layer in a deep -! cumulus convection is determined assuming total convective -! cloud cover is randomly overlapped in each layer in the -! cumulus convection. -! -! D : Wave stress at cloud top is calculated when the atmosphere -! is dynamically stable at the cloud top -! -! E : Cloud top wave stress and nonlinear parameter are calculated -! using density, temperature, and wind that are defined at mid -! level just below the interface level in which cloud top wave -! stress is defined. -! Nonlinct is defined at the interface level. -! -! F : If the atmosphere is dynamically unstable at the cloud top, -! GWDC calculation in current horizontal grid is skipped. -! -! G : If mean wind at the cloud top is less than zero, GWDC -! calculation in current horizontal grid is skipped. -! -! H : Maximum cloud top stress, tauctmax = -20 N m^(-2), -! in order to prevent numerical instability. -! -!----------------------------------------------------------------------- -!D - if ( basicui(i,kcldtop(i)) > zero ) then -!E - if ( riloc(kcldtop(i)) > ricrit ) then - nonlinct = ( g*qmax(i)*cldbar(i)*dlength(i) )/ - & (bruni(i,kcldtop(i))*t(i,kcldtop(i))*(basicum(i,kcldtop(i))**2)) - tauct(i) = - (rhom(i,kcldtop(i))*(basicum(i,kcldtop(i))**2)) - & / (bruni(i,kcldtop(i))*dlength(i)) - & * basicum(i,kcldtop(i))*c1*c2*c2*nonlinct*nonlinct - tauctx(i) = tauct(i)*cosphi - taucty(i) = tauct(i)*sinphi - else -!F - tauct(i) = zero - tauctx(i) = zero - taucty(i) = zero - go to 1000 - end if - else -!G - tauct(i) = zero - tauctx(i) = zero - taucty(i) = zero - go to 1000 - - end if -!H - if ( tauct(i) .lt. tauctmax ) then - tauct(i) = tauctmax - tauctx(i) = tauctmax*cosphi - taucty(i) = tauctmax*sinphi - end if - - if (lprnt.and.(i.eq.ipr)) then - if (fhour.ge.fhourpr) then - write(*,9210) tauctx(ipr),taucty(ipr),tauct(ipr),angle,kk - endif - endif - - 9210 format(/,5x,'STRESS VECTOR = ( ',f8.3,' , ',f8.3,' ) = ',f8.3, - +' IN DIRECTION ',f6.2,4x,'KK = ',i2,/) - -!----------------------------------------------------------------------- -! -! At this point, mean wind at the cloud top is larger than zero and -! local RI at the cloud top is larger than ricrit (=0.25) -! -! Calculate minimum of Richardson number including both basic-state -! condition and wave effects. -! -! g*Q_0*alpha*dx RI_loc*(1 - mu*|c2|) -! mu = ---------------- RI_min = ----------------------------- -! c_p*N*T*U^2 (1 + mu*RI_loc^(0.5)*|c2|)^2 -! -! Minimum RI is calculated for the following two cases -! -! (1) RIloc < 1.e+20 -! (2) Riloc = 1.e+20 ----> Vertically uniform basic-state wind -! -! RIloc cannot be smaller than zero because N^2 becomes 1.E-32 in the -! case of N^2 < 0.. Thus the sign of RINUM is determined by -! 1 - nonlin*|c2|. -! -!----------------------------------------------------------------------- - - do k=kcldtop(i),1,-1 - - if ( k .ne. 1 ) then - crit1 = ucltop*(u(i,k)+u(i,k-1))*0.5 - crit2 = vcltop*(v(i,k)+v(i,k-1))*0.5 - else - crit1 = ucltop*u(i,1) - crit2 = vcltop*v(i,1) - end if - - if((basicui(i,k) > zero).and.(crit1 > zero).and. - & (crit2 > zero)) then - nonlin = ( g*qmax(i)*cldbar(i)*dlength(i) )/ - & ( bruni(i,k)*ti(i,k)*(basicui(i,k)**2) ) - if ( riloc(k) < rimaxm ) then - rimin(k) = riloc(k)*( 1 - nonlin*abs(c2) ) / - & ( 1 + nonlin*sqrt(riloc(k))*abs(c2) )**2 - else if((riloc(k) > rimaxm).and. - & (riloc(k) < rimaxp))then - rimin(k) = ( 1 - nonlin*abs(c2) ) / - & ( (nonlin**2)*(c2**2) ) - end if - if ( rimin(k) <= riminx ) then - rimin(k) = rismall - end if - else - rimin(k) = riminx - end if - end do - -!----------------------------------------------------------------------- -! -! If minimum RI at interface cloud top is less than or equal to 1/4, -! GWDC calculation for current horizontal grid is skipped -! -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -! -! Calculate gravity wave stress profile using the wave saturation -! hypothesis of Lindzen (1981). -! -! Assuming kcldtop(i)=10 and kcldbot=16, -! -! TAUGWCI RIloc RImin UTGWC -! -! Interface 1 ======== - 0.001 -1.e20 -! 1 -------- 0.000 -! 2 ======== - 0.001 -1.e20 -! 2 -------- 0.000 -! 3 ======== - 0.001 -1.e20 -! 3 -------- -.xxx -! 4 ======== - 0.001 2.600 2.000 -! 4 -------- 0.000 -! 5 ======== - 0.001 2.500 2.000 -! 5 -------- 0.000 -! 6 ======== - 0.001 1.500 0.110 -! 6 -------- +.xxx -! 7 ======== - 0.005 2.000 3.000 -! 7 -------- 0.000 -! 8 ======== - 0.005 1.000 0.222 -! 8 -------- +.xxx -! 9 ======== - 0.010 1.000 2.000 -! 9 -------- 0.000 -! kcldtopi 10 ======== $$$ - 0.010 -! kcldtop 10 -------- $$$ yyyyy -! 11 ======== $$$ 0 -! 11 -------- $$$ -! 12 ======== $$$ 0 -! 12 -------- $$$ -! 13 ======== $$$ 0 -! 13 -------- $$$ -! 14 ======== $$$ 0 -! 14 -------- $$$ -! 15 ======== $$$ 0 -! 15 -------- $$$ -! 16 ======== $$$ 0 -! kcldbot 16 -------- $$$ -! 17 ======== 0 -! 17 -------- -! 18 ======== 0 -! 18 -------- -! 19 ======== 0 -! -!----------------------------------------------------------------------- -! -! Even though the cloud top level obtained in deep convective para- -! meterization is defined in mid-level, the cloud top level for -! the GWDC calculation is assumed to be the interface level just -! above the mid-level cloud top vertical level index. -! -!----------------------------------------------------------------------- - - taugwci(i,kcldtop(i)) = tauct(i) ! *1 - - do k=kcldtop(i)-1,2,-1 - if ( abs(taugwci(i,k+1)) > taumin ) then ! TAUGWCI - if ( riloc(k) > ricrit ) then ! RIloc - if ( rimin(k) > ricrit ) then ! RImin - taugwci(i,k) = taugwci(i,k+1) - else if ((rimin(k) > riminp) .and. - & (rimin(k) <= ricrit)) then - nonlins = (1.0/abs(c2))*( 2.*sqrt(2. + 1./sqrt(riloc(k)) ) - & - ( 2. + 1./sqrt(riloc(k)) ) ) - taus = - ( rhoi(i,k)*( basicui(i,k)**2 ) )/ - & ( bruni(i,k)*dlength(i) ) * - & basicui(i,k)*c1*c2*c2*nonlins*nonlins - taugwci(i,k) = taus - else if((rimin(k) > riminm) .and. - & (rimin(k) < riminp)) then - taugwci(i,k) = zero - end if ! RImin - else - -!!!!!!!!!! In the dynamically unstable environment, there is no gravity -!!!!!!!!!! wave stress - - taugwci(i,k) = zero - end if ! RIloc - else - taugwci(i,k) = zero - end if ! TAUGWCI - - if ( (basicum(i,k+1)*basicum(i,k) ) .lt. 0. ) then - taugwci(i,k+1) = zero - taugwci(i,k) = zero - endif - - if (abs(taugwci(i,k)) .gt. abs(taugwci(i,k+1))) then - taugwci(i,k) = taugwci(i,k+1) - end if - - end do - -!!!!!! Upper boundary condition to permit upward propagation of gravity -!!!!!! wave energy at the upper boundary - - taugwci(i,1) = taugwci(i,2) - -!----------------------------------------------------------------------- -! -! Calculate zonal and meridional wind tendency -! -!----------------------------------------------------------------------- - - do k=1,km+1 - taugwcxi(i,k) = taugwci(i,k)*cosphi - taugwcyi(i,k) = taugwci(i,k)*sinphi - end do - -!!!!!! Vertical differentiation -!!!!!! - do k=1,kcldtop(i)-1 - tem1 = g / dpmid(i,k) - wtgwc(i,k) = tem1 * (taugwci(i,k+1) - taugwci(i,k)) - utgwc(i,k) = tem1 * (taugwcxi(i,k+1) - taugwcxi(i,k)) - vtgwc(i,k) = tem1 * (taugwcyi(i,k+1) - taugwcyi(i,k)) - end do - - do k=kcldtop(i),km - wtgwc(i,k) = zero - utgwc(i,k) = zero - vtgwc(i,k) = zero - end do - -!----------------------------------------------------------------------- -! -! Calculate momentum flux = stress deposited above cloup top -! Apply equal amount with opposite sign within cloud -! -!----------------------------------------------------------------------- - - xstress = zero - ystress = zero - do k=1,kcldtop(i)-1 - xstress = xstress + utgwc(i,k)*dpmid(i,k)/g - ystress = ystress + vtgwc(i,k)*dpmid(i,k)/g - end do - -!----------------------------------------------------------------------- -! ALT 1 ONLY UPPERMOST LAYER -!----------------------------------------------------------------------- - -C kk = kcldtop(i) -C tem1 = g / dpmid(i,kk) -C utgwc(i,kk) = - tem1 * xstress -C vtgwc(i,kk) = - tem1 * ystress - -!----------------------------------------------------------------------- -! ALT 2 SIN(KT-KB) -!----------------------------------------------------------------------- - - kk = kcldtop(i) - kb = kcldbot(i) - do k=kk,kb - p1=pi/2.*(pint(i,k)-pint(i,kk))/ - + (pint(i,kb+1)-pint(i,kk)) - p2=pi/2.*(pint(i,k+1)-pint(i,kk))/ - + (pint(i,kb+1)-pint(i,kk)) - utgwc(i,k) = - g*xstress*(sin(p2)-sin(p1))/dpmid(i,k) - vtgwc(i,k) = - g*ystress*(sin(p2)-sin(p1))/dpmid(i,k) - enddo - -!----------------------------------------------------------------------- -! ALT 3 FROM KT to KB PROPORTIONAL TO CONV HEATING -!----------------------------------------------------------------------- - -! do k=kcldtop(i),kcldbot(i) -! p1=cumchr(i,k) -! p2=cumchr(i,k+1) -! utgwc(i,k) = - g*xstress*(p1-p2)/dpmid(i,k) -! enddo - -!----------------------------------------------------------------------- -! -! The GWDC should accelerate the zonal and meridional wind in the -! opposite direction of the previous zonal and meridional wind, -! respectively -! -!----------------------------------------------------------------------- - -! do k=1,kcldtop(i)-1 - -! if (utgwc(i,k)*u(i,k) .gt. 0.0) then - -!-------------------- x-component------------------- - -! write(6,'(a)') -! + '(GWDC) WARNING: The GWDC should accelerate the zonal wind ' -! write(6,'(a,a,i3,a,i3)') -! + 'in the opposite direction of the previous zonal wind', -! + ' at I = ',i,' and J = ',lat -! write(6,'(4(1x,e17.10))') u(i,kk),v(i,kk),u(i,k),v(i,k) -! write(6,'(a,1x,e17.10))') 'Vcld . V =', -! + u(i,kk)*u(i,k)+v(i,kk)*v(i,k) - -! if(u(i,kcldtop(i))*u(i,k)+v(i,kcldtop(i))*v(i,k).gt.0.0)then -! do k1=1,km -! write(6,'(i2,36x,2(1x,e17.10))') -! + k1,taugwcxi(i,k1),taugwci(i,k1) -! write(6,'(i2,2(1x,e17.10))') k1,utgwc(i,k1),u(i,k1) -! end do -! write(6,'(i2,36x,1x,e17.10)') (km+1),taugwcxi(i,km+1) -! end if - -!-------------------- Along wind at cloud top ----- - -! do k1=1,km -! write(6,'(i2,36x,2(1x,e17.10))') -! + k1,taugwci(i,k1) -! write(6,'(i2,2(1x,e17.10))') k1,wtgwc(i,k1),basicum(i,k1) -! end do -! write(6,'(i2,36x,1x,e17.10)') (km+1),taugwci(i,km+1) - -! end if - -! if (vtgwc(i,k)*v(i,k) .gt. 0.0) then -! write(6,'(a)') -! + '(GWDC) WARNING: The GWDC should accelerate the meridional wind' -! write(6,'(a,a,i3,a,i3)') -! + 'in the opposite direction of the previous meridional wind', -! + ' at I = ',i,' and J = ',lat -! write(6,'(4(1x,e17.10))') u(i,kcldtop(i)),v(i,kcldtop(i)), -! + u(i,k),v(i,k) -! write(6,'(a,1x,e17.10))') 'Vcld . V =', -! + u(i,kcldtop(i))*u(i,k)+v(i,kcldtop(i))*v(i,k) -! if(u(i,kcldtop(i))*u(i,k)+v(i,kcldtop(i))*v(i,k).gt.0.0)then -! do k1=1,km -! write(6,'(i2,36x,2(1x,e17.10))') -! + k1,taugwcyi(i,k1),taugwci(i,k1) -! write(6,'(i2,2(1x,e17.10))') k1,vtgwc(i,k1),v(i,k1) -! end do -! write(6,'(i2,36x,1x,e17.10)') (km+1),taugwcyi(i,km+1) -! end if -! end if - -! enddo - - 1000 continue - - end if ! DO GWDC CALCULATION - - end do ! I-LOOP - -!*********************************************************************** - - if (lprnt) then - if (fhour.ge.fhourpr) then -!-------- UTGWC VTGWC ---------- - write(*,9220) - do ilev=1,km - write(*,9221) ilev,(86400.*utgwc(ipr,ilev)), - + (86400.*vtgwc(ipr,ilev)) - enddo - endif - endif - - 9220 format(//,14x,'TENDENCY DUE TO GWDC',//, - +' ILEV',6x,'UTGWC',7x,'VTGWC',/) - 9221 format(i4,2(2x,f10.3)) - -!----------------------------------------------------------------------- -! -! For GWDC performance analysis -! -!----------------------------------------------------------------------- - - do i = 1, im - kk=kcldtop(i) - - if ( dogwdc(i) .and. (abs(taugwci(i,kk)).gt.taumin) ) then - - gwdcloc(i) = one - - do k = 1, kk-1 - if ( abs(taugwci(i,k)-taugwci(i,kk)).gt.taumin ) then - break(i) = 1.0 - go to 2000 - endif - enddo - 2000 continue - - do k = 1, kk-1 - - if ( ( abs(taugwci(i,k)).lt.taumin ) .and. - & ( abs(taugwci(i,k+1)).gt.taumin ) .and. - & ( basicum(i,k+1)*basicum(i,k) .lt. 0. ) ) then - critic(i) = 1.0 -! print *,i,k,' inside GWDC taugwci(k) = ',taugwci(i,k) -! print *,i,k+1,' inside GWDC taugwci(k+1) = ',taugwci(i,k+1) -! print *,i,k,' inside GWDC basicum(k) = ',basicum(i,k) -! print *,i,k+1,' inside GWDC basicum(k+1) = ',basicum(i,k+1) -! print *,i,' inside GWDC critic = ',critic(i) - goto 2010 - endif - enddo - 2010 continue - - endif - - enddo - -!----------------------------------------------------------------------- -! Convert back local GWDC Tendency arrays to GFS model vertical indices -! Make output Tendencies cos-weighted by using array RCS=1/cos(lat) -! Outgoing (FU1,FV1)=cos(lat)*(utgwc,vtgwc) -!----------------------------------------------------------------------- - - do i=1,im - rcsi(i) = one / rcs(i) - enddo - do k=1,km - k1=km-k+1 - do i=1,im - fu1(i,k1) = utgwc(i,k)*rcsi(i) - fv1(i,k1) = vtgwc(i,k)*rcsi(i) - brunm1(i,k1) = brunm(i,k) - rhom1(i,k1) = rhom(i,k) - enddo - enddo - - if (lprnt) then - if (fhour.ge.fhourpr) then -!-------- UTGWC VTGWC ---------- - write(*,9225) - do ilev=km,1,-1 - write(*,9226) ilev,(86400.*fu1(ipr,ilev)), - + (86400.*fv1(ipr,ilev)) - enddo - endif - endif - - 9225 format(//,14x,'TENDENCY DUE TO GWDC - TO GBPHYS',//, - +' ILEV',6x,'UTGWC',7x,'VTGWC',/) - 9226 format(i4,2(2x,f10.3)) - - return - end diff --git a/src/fim/FIMsrc/fim/column/gwdps_v.F90 b/src/fim/FIMsrc/fim/column/gwdps_v.F90 deleted file mode 100644 index 59a4e2d..0000000 --- a/src/fim/FIMsrc/fim/column/gwdps_v.F90 +++ /dev/null @@ -1,863 +0,0 @@ -!FPP$ NOCONCUR R -! SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,U1,V1,T1,Q1,PSTAR,KPBL, - SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,U1,V1,T1,Q1,KPBL, & - PRSI,DEL,PRSL,PRSLK,PHII, PHIL,RCL,DELTIM,KDT, & - HPRIME,OC,OA4,CLX4,THETA,SIGMA,GAMMA,ELVMAX, & - DUSFC,DVSFC,G, CP, RD, RV, IMX, & - nmtvr, me, lprnt, ipr) -! -! ******************************************************************** -! -----> I M P L E M E N T A T I O N V E R S I O N <---------- -! -! --- Not in this code -- History of GWDP at NCEP---- -! ---------------- ----------------------- -! VERSION 3 MODIFIED FOR GRAVITY WAVES, LOCATION: .FR30(V3GWD) *J* -!--- 3.1 INCLUDES VARIABLE SATURATION FLUX PROFILE CF ISIGST -!--- 3.G INCLUDES PS COMBINED W/ PH (GLAS AND GFDL) -!----- ALSO INCLUDED IS RI SMOOTH OVER A THICK LOWER LAYER -!----- ALSO INCLUDED IS DECREASE IN DE-ACC AT TOP BY 1/2 -!----- THE NMC GWD INCORPORATING BOTH GLAS(P&S) AND GFDL(MIGWD) -!----- MOUNTAIN INDUCED GRAVITY WAVE DRAG -!----- CODE FROM .FR30(V3MONNX) FOR MONIN3 -!----- THIS VERSION (06 MAR 1987) -!----- THIS VERSION (26 APR 1987) 3.G -!----- THIS VERSION (01 MAY 1987) 3.9 -!----- CHANGE TO FORTRAN 77 (FEB 1989) --- HANN-MING HENRY JUANG -!----- -! -! VERSION 4 -! ----- This code ----- -! -!----- MODIFIED TO IMPLEMENT THE ENHANCED LOW TROPOSPHERIC GRAVITY -!----- WAVE DRAG DEVELOPED BY KIM AND ARAKAWA(JAS, 1995). -! Orographic Std Dev (hprime), Convexity (OC), Asymmetry (OA4) -! and Lx (CLX4) are input topographic statistics needed. -! -!----- PROGRAMMED AND DEBUGGED BY HONG, ALPERT AND KIM --- JAN 1996. -!----- debugged again - moorthi and iredell --- may 1998. -!----- -! Further Cleanup, optimization and modification -! - S. Moorthi May 98, March 99. -!----- modified for usgs orography data (ncep office note 424) -! and with several bugs fixed - moorthi and hong --- july 1999. -! -!----- Modified & implemented into NRL NOGAPS -! - Young-Joon Kim, July 2000 -!----- -! VERSION lm MB (6): oz fix 8/2003 -! ----- This code ----- -! -!------ Changed to include the Lott and Miller Mtn Blocking -! with some modifications by (*j*) 4/02 -! From a Principal Coordinate calculation using the -! Hi Res 8 minute orography, the Angle of the -! mtn with that to the East (x) axis is THETA, the slope -! parameter SIGMA. The anisotropy is in GAMMA - all are input -! topographic statistics needed. These are calculated off-line -! as a function of model resolution in the fortran code ml01rg2.f, -! with script mlb2.sh. (*j*) -!----- gwdps_mb.f version (following lmi) elvmax < hncrit (*j*) -! MB3a expt to enhance elvmax mtn hgt see sigfac & hncrit -!----- -!----------------------------------------------------------------------C -! USE -! ROUTINE IS CALLED FROM GBPHYS (AFTER CALL TO MONNIN) -! -! PURPOSE -! USING THE GWD PARAMETERIZATIONS OF PS-GLAS AND PH- -! GFDL TECHNIQUE. THE TIME TENDENCIES OF U V -! ARE ALTERED TO INCLUDE THE EFFECT OF MOUNTAIN INDUCED -! GRAVITY WAVE DRAG FROM SUB-GRID SCALE OROGRAPHY INCLUDING -! CONVECTIVE BREAKING, SHEAR BREAKING AND THE PRESENCE OF -! CRITICAL LEVELS -! -! INPUT -! A(IY,KM) NON-LIN TENDENCY FOR V WIND COMPONENT -! B(IY,KM) NON-LIN TENDENCY FOR U WIND COMPONENT -! U1(IX,KM) ZONAL WIND / SQRT(RCL) M/SEC AT T0-DT -! V1(IX,KM) MERIDIONAL WIND / SQRT(RCL) M/SEC AT T0-DT -! T1(IX,KM) TEMPERATURE DEG K AT T0-DT -! Q1(IX,KM) SPECIFIC HUMIDITY AT T0-DT -! -! RCL A scaling factor = RECIPROCAL OF SQUARE OF COS(LAT) -! FOR MRF GFS. -! DELTIM TIME STEP SECS -! SI(N) P/PSFC AT BASE OF LAYER N -! SL(N) P/PSFC AT MIDDLE OF LAYER N -! DEL(N) POSITIVE INCREMENT OF P/PSFC ACROSS LAYER N -! KPBL(IM) is the index of the top layer of the PBL -! ipr & lprnt for diagnostics -! -! OUTPUT -! A, B AS AUGMENTED BY TENDENCY DUE TO GWDPS -! OTHER INPUT VARIABLES UNMODIFIED. -! ******************************************************************** - USE MACHINE , ONLY : kind_phys - implicit none - integer im, iy, ix, km, imx, lat, kdt, ipr, me - integer KPBL(IM) ! Index for the PBL top layer! - real(kind=kind_phys) deltim, G, CP, RD, RV -! real(kind=kind_phys) A(IY,KM), B(IY,KM), PSTAR(IM) - real(kind=kind_phys) A(IY,KM), B(IY,KM), & - U1(IX,KM), V1(IX,KM), T1(IX,KM), & - Q1(IX,KM), PRSI(IX,KM+1), DEL(IX,KM), & - PRSL(IX,KM), PRSLK(IX,KM), PHIL(IX,KM), & - PHII(IX,KM+1) - real(kind=kind_phys) OC(IM), OA4(IY,4), CLX4(IY,4), & - HPRIME(IM), rcl(im) -! for lm mtn blocking - real(kind=kind_phys) ELVMAX(IM),THETA(IM),SIGMA(IM),GAMMA(IM) - real(kind=kind_phys) wk(IM) - real(kind=kind_phys) bnv2lm(IM,KM),PE(IM),EK(IM),ZBK(IM),UP(IM) - real(kind=kind_phys) DB(IM,KM),ANG(IM,KM),UDS(IM,KM) - real(kind=kind_phys) ZLEN, DBTMP, R, PHIANG, CDmb, DBIM -! -! Some constants -! - real(kind=kind_phys) pi, dw2min, rimin, ric, bnv2min, efmin, & - efmax,hpmax - PARAMETER (PI=3.1415926535897931) - PARAMETER (DW2MIN=1., RIMIN=-100., RIC=0.25, BNV2MIN=1.0E-5) - PARAMETER (EFMIN=0.0, EFMAX=10.0, hpmax=200.0) -! PARAMETER (EFMIN=0.0, EFMAX=10.0, hpmax=2500.0) -! - real(kind=kind_phys) FRC, CE, CEOFRC, frmax, CG, GMAX, & - CRITAC, VELEPS, FACTOP, RLOLEV, RDI - parameter (FRC=1.0, CE=0.8, CEOFRC=CE/FRC, frmax=100., CG=0.5) - parameter (GMAX=1.0, CRITAC=5.0E-4, VELEPS=1.0, FACTOP=0.5) - parameter (RLOLEV=500.0) -! parameter (RLOLEV=0.5) -! - real(kind=kind_phys) dpmin,hminmt,hncrit,minwnd,sigfac -! --- for lm mtn blocking - parameter (cdmb = 1.0) ! non-dim sub grid mtn drag Amp (*j*) - parameter (hncrit=8000.) ! Max value in meters for ELVMAX (*j*) -! hncrit set to 8000m and sigfac added to enhance elvmax mtn hgt - parameter (sigfac=0.1) ! MB3a expt test for ELVMAX factor (*j*) - parameter (hminmt=50.) ! min mtn height (*j*) - parameter (minwnd=0.1) ! min wind component (*j*) - -! parameter (dpmin=00.0) ! Minimum thickness of the reference layer - parameter (dpmin=05.0) ! Minimum thickness of the reference layer -! parameter (dpmin=20.0) ! Minimum thickness of the reference layer - ! in centibars -! - real(kind=kind_phys) FDIR - integer mdir - parameter(mdir=8, FDIR=mdir/(PI+PI)) - integer nwdir(mdir) - data nwdir/6,7,5,8,2,3,1,4/ - save nwdir -! - LOGICAL ICRILV(IM) -! -!---- MOUNTAIN INDUCED GRAVITY WAVE DRAG -! - real(kind=kind_phys) TAUB(IM), XN(IM), YN(IM), UBAR(IM), & - VBAR(IM), ULOW(IM), OA(IM), CLX(IM), & - ROLL(IM), ULOI(IM), DUSFC(IM), DVSFC(IM), & - DTFAC(IM), XLINV(IM), DELKS(IM), DELKS1(IM) -! - real(kind=kind_phys) BNV2(IM,KM), TAUP(IM,KM+1), ri_n(IM,KM), & - TAUD(IM,KM), RO(IM,KM), VTK(IM,KM), & - VTJ(IM,KM), SCOR(IM), VELCO(IM,KM-1), & - bnv2bar(im), rcs(im) -! - real(kind=kind_phys) VELKO(KM-1) - Integer kref(IM), kint(im), iwk(im), iwk2(im), ipt(im) -! for lm mtn blocking - Integer kreflm(IM), iwklm(im), iptlm(im) - Integer idxzb(im), idxm1, ktrial, klevm1, nmtvr -! - real(kind=kind_phys) gor, gocp, fv, xl, gr2, bnv, fr, & - brvf, cleff, tem, tem1, tem2, temc, temv, & - wdir, ti, rdz, dw2, shr2, bvf2, & - rdelks, wtkbj, efact, coefm, gfobnv, & - scork, rscor, hd, fro, rim, sira, & - dtaux, dtauy, rcsks, pkp1log, pklog - integer ncnt, kmm1, kmm2, lcap, lcapp1, kbps, kbpsp1,kbpsm1, & - kmps, kmpsp1, idir, nwd, i, j, k, klcap, kp1, kmpbl, npt, & - kmll,kmds -! kmll,kmds,ihit,jhit - logical lprnt -#if ( defined NEED_SINDCOSD ) -!JR Define statement functions for sind, cosd, and atan2d in situations where -!JR compiler doesn't support them (e.g. gfortran) - real(kind=kind_phys) :: x, y, sind, cosd, atan2d - sind(x) = sin (x*pi/180._kind_phys) - cosd(x) = cos (x*pi/180._kind_phys) - atan2d(x,y) = atan2 (x*pi/180._kind_phys, y*pi/180._kind_phys) -#endif -! - DO I = 1, IM - DUSFC(I) = 0. - DVSFC(I) = 0. - ENDDO -! - DO K = 1, KM - DO I = 1, IM - DB(I,K) = 0. - ANG(I,K) = 0. - UDS(I,K) = 0. - ENDDO - ENDDO -! - RDI = 1.0 / RD - GOR = G/RD - GR2 = G*GOR - GOCP = G/CP - FV = RV/RD - 1 -! -! NCNT = 0 - KMM1 = KM - 1 - KMM2 = KM - 2 - LCAP = KM - LCAPP1 = LCAP + 1 -! -! - IF ( NMTVR .eq. 14) then -! ---- for lm and gwd calculation points - npt = 0 - DO I = 1,IM - IF ( (elvmax(i) .GT. HMINMT) .and. (hprime(i) .GT. 0.0001) ) then - npt = npt + 1 - ipt(npt) = i - ENDIF - ENDDO - IF (npt .eq. 0) RETURN ! No gwd/mb calculation done! -! -! --- iwklm is the level above the height of the of the mountain. -! --- idxzb is the level of the dividing streamline. -! INITIALIZE DIVIDING STREAMLINE (DS) CONTROL VECTOR -! - do i=1,npt - rcs(i) = sqrt(rcl(ipt(i))) - iwklm(i) = 2 - IDXZB(i) = 0 - kreflm(i) = 0 - enddo -! if (lprnt) -! &print *,' in gwdps_lm.f npt,IM,IX,IY,km,me=',npt,IM,IX,IY,km,me -! -! -! start lm mtn blocking (mb) section -! -!.............................. -!.............................. -! -! (*j*) 11/03: test upper limit on KMLL=km - 1 -! then do not need hncrit -- test with large hncrit first. -! KMLL = km / 2 ! maximum mtnlm height : # of vertical levels / 2 - KMLL = kmm1 -! --- No mtn should be as high as KMLL (so we do not have to start at -! --- the top of the model but could do calc for all levels). -! -! - DO K = 1,KMLL - DO I = 1, npt - j = ipt(i) -! --- interpolate to max mtn height for index, iwklm(I) wk[gz] -! --- ELVMAX is limited to hncrit because to hi res topo30 orog. - pkp1log = phil(j,k+1) / G - pklog = phil(j,k) / G - ELVMAX(J) = min (ELVMAX(J) + sigfac * hprime(j), hncrit) - if ( ( ELVMAX(j) .le. pkp1log ) .and. ( ELVMAX(j) .ge. pklog ) ) THEN -! print *,' in gwdps_lm.f 1 =',k,ELVMAX(j),pklog,pkp1log,me -! --- wk for diags but can be saved and reused. - wk(i) = G * ELVMAX(j) / ( phil(j,k+1) - phil(j,k) ) - iwklm(I) = MAX(iwklm(I), k+1 ) -! print *,' in gwdps_lm.f 2 npt=',npt,i,j,wk(i),iwklm(i),me - endif -! -! --- find at prsl levels large scale environment variables -! --- these cover all possible mtn max heights - VTJ(I,K) = T1(J,K) * (1.+FV*Q1(J,K)) - VTK(I,K) = VTJ(I,K) / PRSLK(J,K) - RO(I,K) = RDI * PRSL(J,K) / VTJ(I,K) ! DENSITY TONS/M**3 - ENDDO - ENDDO -! -! testing for highest model level of mountain top -! -! ihit = 2 -! jhit = 0 -! do i = 1, npt -! j=ipt(i) -! if ( iwklm(i) .gt. ihit ) then -! ihit = iwklm(i) -! jhit = j -! endif -! enddo -! print *, ' mb: kdt,max(iwklm),jhit,phil,me=',kdt,ihit,jhit,phil(jhit,ihit),me - - klevm1 = KMLL - 1 - DO K = 1, klevm1 - DO I = 1, npt - j = ipt(i) - RDZ = g / ( phil(j,k+1) - phil(j,k) ) -! --- Brunt-Vaisala Frequency - BNV2LM(I,K) = (G+G) * RDZ * ( VTK(I,K+1)-VTK(I,K) ) / ( VTK(I,K+1)+VTK(I,K) ) - bnv2lm(i,k) = max( bnv2lm(i,k), bnv2min ) - ENDDO - ENDDO -! print *,' in gwdps_lm.f 3 npt=',npt,j,RDZ,me -! - DO I = 1, npt - J = ipt(i) - DELKS(I) = 1.0 / (PRSI(J,1) - PRSI(J,iwklm(i))) - DELKS1(I) = 1.0 / (PRSL(J,1) - PRSL(J,iwklm(i))) - UBAR (I) = 0.0 - VBAR (I) = 0.0 - ROLL (I) = 0.0 - PE (I) = 0.0 - EK (I) = 0.0 -! --- - BNV2bar(I) = (PRSL(J,1)-PRSL(J,2)) * DELKS1(I) * BNV2LM(I,1) - ENDDO - -! --- find the dividing stream line height -! --- starting from the level above the max mtn downward -! --- iwklm(i) is the k-index of mtn elvmax elevation - DO Ktrial = KMLL, 1, -1 - DO I = 1, npt - IF ( Ktrial .LT. iwklm(I) .and. kreflm(I) .eq. 0 ) then - kreflm(I) = Ktrial - ENDIF - ENDDO - ENDDO -! print *,' in gwdps_lm.f 4 npt=',npt,kreflm(npt),me -! -! --- in the layer kreflm(I) to 1 find PE (which needs N, ELVMAX) -! --- make averages, guess dividing stream (DS) line layer. -! --- This is not used in the first cut except for testing and -! --- is the vert ave of quantities from the surface to mtn top. -! - DO I = 1, npt - DO K = 1, Kreflm(I) - J = ipt(i) - RDELKS = DEL(J,K) * DELKS(I) - RCSKS = RCS(I) * RDELKS - UBAR(I) = UBAR(I) + RCSKS * U1(J,K) ! trial Mean U below - VBAR(I) = VBAR(I) + RCSKS * V1(J,K) ! trial Mean V below - - ROLL(I) = ROLL(I) + RDELKS * RO(I,K) ! trial Mean RO below - RDELKS = (PRSL(J,K)-PRSL(J,K+1)) * DELKS1(I) - BNV2bar(I) = BNV2bar(I) + BNV2lm(I,K) * RDELKS -! --- these vert ave are for diags, testing and GWD to follow (*j*). - ENDDO - ENDDO -! print *,' in gwdps_lm.f 5 =',i,kreflm(npt),BNV2bar(npt),me -! -! --- integrate to get PE in the trial layer. -! --- Need the first layer where PE>EK - as soon as -! --- IDXZB is not 0 we have a hit and Zb is found. -! - DO I = 1, npt - DO K = iwklm(I), 1, -1 - J = ipt(i) - PHIANG = atan2D(V1(J,K),U1(J,K)) - ANG(I,K) = ( THETA(J) - PHIANG ) - if ( ANG(I,K) .gt. 90. ) ANG(I,K) = ANG(I,K) - 180. - if ( ANG(I,K) .lt. -90. ) ANG(I,K) = ANG(I,K) + 180. - UDS(I,K) = RCS(I) * MAX(SQRT(U1(J,K)*U1(J,K) + V1(J,K)*V1(J,K)), minwnd) -! --- Test to see if we found Zb previously - IF (IDXZB(I) .eq. 0 ) then - PE(I) = PE(I) + BNV2lm(I,K)*(G*ELVMAX(J) - phil(J,K))*(PHII(J,K+1) - PHII(J,K))/(G*G) -! --- KE -! --- Wind projected on the line perpendicular to mtn range, U(Zb(K)). -! --- kenetic energy is at the layer Zb -! --- THETA ranges from -+90deg |_ to the mtn "largest topo variations" - UP(I) = UDS(I,K) * cosD(ANG(I,K)) - EK(I) = 0.5 * UP(I) * UP(I) - -! --- Dividing Stream lime is found when PE =exceeds EK. - IF ( PE(I) .ge. EK(I) ) IDXZB(I) = K -! --- Then mtn blocked flow is between Zb=k(IDXZB(I)) and surface -! - ENDIF - ENDDO - ENDDO -! -! print *,' in gwdps_lm.f 6 =',phiang,THETA(ipt(npt)),me -! print *,' in gwdps_lm.f 7 =',IDXZB(npt),PE(npt) -! -! if(lprnt) print *,' BNV2bar,BNV2lm=',bnv2bar(ipr),BNV2lm(ipr,:) -! if(lprnt) print *,' ipr,IDXZB,UDS=',ipr,IDXZB(ipr),UDS(ipr,:) -! if(lprnt) print *,' PE,UP,EK=',PE(ipr),UP(ipr),EK(ipr) - DO I = 1, npt - J = ipt(i) -! --- Calc if N constant in layers (Zb guess) - a diagnostic only. - ZBK(I) = ELVMAX(J) - SQRT(UBAR(I)**2 + VBAR(I)**2)/BNV2bar(I) - ENDDO -! if(lprnt) print *,' iwklm,ZBK=',iwklm(ipr),ZBK(ipr),IDXZB(ipr) -! if(lprnt) print *,' Zb=',PHIL(ipt(ipr),IDXZB(ipr))/G -! print *,' in gwdps_lm.f 8 npt =',npt,ZBK(npt),UP(npt),me -! -! --- The drag for mtn blocked flow -! - DO I = 1, npt - J = ipt(i) - ZLEN = 0. -! print *,' in gwdps_lm.f 9 =',i,j,IDXZB(i),me - IF ( IDXZB(I) .gt. 0 ) then - DO K = IDXZB(I), 1, -1 - IF ( PHIL(J,IDXZB(I)) .gt. PHIL(J,K) ) then - ZLEN = SQRT( ( PHIL(J,IDXZB(I)) - PHIL(J,K) ) / ( PHIL(J,K ) + G * hprime(J) ) ) -! --- lm eq 14: - R = ( cosD(ANG(I,K))**2 + GAMMA(J) * sinD(ANG(I,K))**2 ) / & - ( gamma(J) * cosD(ANG(I,K))**2 + sinD(ANG(I,K))**2 ) -! --- (negitive of DB -- see sign at tendency) - DBTMP = 0.25 * CDmb * & - MAX( 2. - 1. / R, 0. ) * sigma(J) * & - MAX( cosD(ANG(I,K)), gamma(J) * sinD(ANG(I,K)) ) * & - ZLEN / hprime(J) - DB(I,K) = DBTMP * UDS(I,K) -! if(lprnt) then -! print *,' in gwdps_lmi.f 10 npt=',npt,i,j,idxzb(i),DBTMP,R,me -! print *,' in gwdps_lmi.f 11 K=',k,ZLEN,cosD(ANG(I,K)),me -! print *,' in gwdps_lmi.f 12 DB=',DB(i,k),sinD(ANG(I,K)) -! endif - endif - ENDDO -! if(lprnt) print *,' @K=1,ZLEN,DBTMP=',K,ZLEN,DBTMP - endif - ENDDO -! -!............................. -!............................. -! end mtn blocking section -! - ELSEIF ( NMTVR .ne. 14) then -! ---- for mb not present and gwd (nmtvr .ne .14) - npt = 0 - DO I = 1,IM - IF ( hprime(i) .GT. 0.0001 ) then - npt = npt + 1 - ipt(npt) = i - ENDIF - ENDDO - IF (npt .eq. 0) RETURN ! No gwd/mb calculation done! -! - do i=1,npt - rcs(i) = sqrt(rcl(ipt(i))) - IDXZB(i) = 0 - enddo - ENDIF -! -!............................. -!............................. -! - KMPBL = km / 2 ! maximum pbl height : # of vertical levels / 2 -! -! Scale cleff between IM=384*2 and 192*2 for T126/T170 and T62 -! - if (imx .gt. 0) then -! cleff = 1.0E-5 * SQRT(FLOAT(IMX)/384.0) ! this is inverse of CLEFF! -! cleff = 1.0E-5 * SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! - cleff = 0.5E-5 * SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! -! cleff = 2.0E-5 * SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! -! cleff = 2.5E-5 * SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! - endif -! - DO K = 1,KM - DO I =1,npt - J = ipt(i) - VTJ(I,K) = T1(J,K) * (1.+FV*Q1(J,K)) - VTK(I,K) = VTJ(I,K) / PRSLK(J,K) - RO(I,K) = RDI * PRSL(J,K) / VTJ(I,K) ! DENSITY TONS/M**3 - TAUP(I,K) = 0.0 - ENDDO - ENDDO - DO K = 1,KMM1 - DO I =1,npt - J = ipt(i) - TI = 2.0 / (T1(J,K)+T1(J,K+1)) - TEM = TI / (PRSL(J,K)-PRSL(J,K+1)) -! RDZ = GOR * PRSI(J,K+1) * TEM - RDZ = g / (phil(j,k+1) - phil(j,k)) - TEM1 = U1(J,K) - U1(J,K+1) - TEM2 = V1(J,K) - V1(J,K+1) - DW2 = RCL(J)*(TEM1*TEM1 + TEM2*TEM2) - SHR2 = MAX(DW2,DW2MIN) * RDZ * RDZ - BVF2 = G*(GOCP+RDZ*(VTJ(I,K+1)-VTJ(I,K))) * TI - ri_n(I,K) = MAX(BVF2/SHR2,RIMIN) ! Richardson number -! Brunt-Vaisala Frequency -! TEM = GR2 * (PRSL(J,K)+PRSL(J,K+1)) * TEM -! BNV2(I,K) = TEM * (VTK(I,K+1)-VTK(I,K))/(VTK(I,K+1)+VTK(I,K)) - BNV2(I,K) = (G+G) * RDZ * (VTK(I,K+1)-VTK(I,K)) & - / (VTK(I,K+1)+VTK(I,K)) - bnv2(i,k) = max( bnv2(i,k), bnv2min ) - ENDDO - ENDDO -! print *,' in gwdps_lm.f GWD:14 =',npt,kmm1,bnv2(npt,kmm1) -! -! Apply 3 point smoothing on BNV2 -! -! do k=1,km -! do i=1,im -! vtk(i,k) = bnv2(i,k) -! enddo -! enddo -! do k=2,kmm1 -! do i=1,im -! bnv2(i,k) = 0.25*(vtk(i,k-1)+vtk(i,k+1)) + 0.5*vtk(i,k) -! enddo -! enddo -! -! Finding the first interface index above 50 hPa level -! - do i=1,npt - iwk(i) = 2 - enddo - DO K=3,KMPBL - DO I=1,npt - j = ipt(i) - tem = (prsi(j,1) - prsi(j,k)) - if (tem .lt. dpmin) iwk(i) = k - enddo - enddo -! - KBPS = 1 - KMPS = KM - DO I=1,npt - J = ipt(i) - kref(I) = MAX(IWK(I), KPBL(J)+1 ) ! reference level - DELKS(I) = 1.0 / (PRSI(J,1) - PRSI(J,kref(I))) - DELKS1(I) = 1.0 / (PRSL(J,1) - PRSL(J,kref(I))) - UBAR (I) = 0.0 - VBAR (I) = 0.0 - ROLL (I) = 0.0 - KBPS = MAX(KBPS, kref(I)) - KMPS = MIN(KMPS, kref(I)) -! - BNV2bar(I) = (PRSL(J,1)-PRSL(J,2)) * DELKS1(I) * BNV2(I,1) - ENDDO -! print *,' in gwdps_lm.f GWD:15 =',KBPS,KMPS - KBPSP1 = KBPS + 1 - KBPSM1 = KBPS - 1 - DO K = 1,KBPS - DO I = 1,npt - IF (K .LT. kref(I)) THEN - J = ipt(i) - RDELKS = DEL(J,K) * DELKS(I) - RCSKS = RCS(I) * RDELKS - UBAR(I) = UBAR(I) + RCSKS * U1(J,K) ! Mean U below kref - VBAR(I) = VBAR(I) + RCSKS * V1(J,K) ! Mean V below kref -! - ROLL(I) = ROLL(I) + RDELKS * RO(I,K) ! Mean RO below kref - RDELKS = (PRSL(J,K)-PRSL(J,K+1)) * DELKS1(I) - BNV2bar(I) = BNV2bar(I) + BNV2(I,K) * RDELKS - ENDIF - ENDDO - ENDDO -! print *,' in gwdps_lm.f GWD:15B =',bnv2bar(npt) -! -! FIGURE OUT LOW-LEVEL HORIZONTAL WIND DIRECTION AND FIND 'OA' -! -! NWD 1 2 3 4 5 6 7 8 -! WD W S SW NW E N NE SE -! - DO I = 1,npt - J = ipt(i) - wdir = atan2(UBAR(I),VBAR(I)) + pi - idir = mod(nint(fdir*wdir),mdir) + 1 - nwd = nwdir(idir) - OA(I) = (1-2*INT( (NWD-1)/4 )) * OA4(J,MOD(NWD-1,4)+1) - CLX(I) = CLX4(J,MOD(NWD-1,4)+1) - ENDDO -! -!-----XN,YN "LOW-LEVEL" WIND PROJECTIONS IN ZONAL -! & MERIDIONAL DIRECTIONS -!-----ULOW "LOW-LEVEL" WIND MAGNITUDE - (= U) -!-----BNV2 BNV2 = N**2 -!-----TAUB BASE MOMENTUM FLUX -!-----= -(RO * U**3/(N*XL)*GF(FR) FOR N**2 > 0 -!-----= 0. FOR N**2 < 0 -!-----FR FROUDE = N*HPRIME / U -!-----G GMAX*FR**2/(FR**2+CG/OC) -! -!-----INITIALIZE SOME ARRAYS -! - DO I = 1,npt - XN(I) = 0.0 - YN(I) = 0.0 - TAUB (I) = 0.0 - ULOW (I) = 0.0 - DTFAC(I) = 1.0 - ICRILV(I) = .FALSE. ! INITIALIZE CRITICAL LEVEL CONTROL VECTOR - -! -!----COMPUTE THE "LOW LEVEL" WIND MAGNITUDE (M/S) -! - ULOW(I) = MAX(SQRT(UBAR(I)*UBAR(I) + VBAR(I)*VBAR(I)), 1.0) - ULOI(I) = 1.0 / ULOW(I) - ENDDO -! - DO K = 1,KMM1 - DO I = 1,npt - J = ipt(i) - VELCO(I,K) = (0.5*RCS(I)) * ((U1(J,K)+U1(J,K+1))*UBAR(I) & - + (V1(J,K)+V1(J,K+1))*VBAR(I)) - VELCO(I,K) = VELCO(I,K) * ULOI(I) -! IF ((VELCO(I,K).LT.VELEPS) .AND. (VELCO(I,K).GT.0.)) THEN -! VELCO(I,K) = VELEPS -! ENDIF - ENDDO - ENDDO -! -! -! find the interface level of the projected wind where -! low levels & upper levels meet above pbl -! - do i=1,npt - kint(i) = km - enddo - do k = 1,kmm1 - do i = 1,npt - IF (K .GT. kref(I)) THEN - if(velco(i,k) .lt. veleps .and. kint(i) .eq. km) then - kint(i) = k+1 - endif - endif - enddo - enddo -! WARNING KINT = KREF !!!!!!!!! - do i=1,npt - kint(i) = kref(i) - enddo -! -! if(lprnt) print *,' ubar=',ubar,' vbar=',vbar,' ulow=',ulow,' veleps=',veleps -! - DO I = 1,npt - J = ipt(i) - BNV = SQRT( BNV2bar(I) ) - FR = BNV * ULOI(I) * min(HPRIME(J),hpmax) - FR = MIN(FR, FRMAX) - XN(I) = UBAR(I) * ULOI(I) - YN(I) = VBAR(I) * ULOI(I) -! -! Compute the base level stress and store it in TAUB -! CALCULATE ENHANCEMENT FACTOR, NUMBER OF MOUNTAINS & ASPECT -! RATIO CONST. USE SIMPLIFIED RELATIONSHIP BETWEEN STANDARD -! DEVIATION & CRITICAL HGT -! - EFACT = (OA(I) + 2.) ** (CEOFRC*FR) - EFACT = MIN( MAX(EFACT,EFMIN), EFMAX ) -! - COEFM = (1. + CLX(I)) ** (OA(I)+1.) -! - XLINV(I) = COEFM * CLEFF -! - TEM = FR * FR * OC(J) - GFOBNV = GMAX * TEM / ((TEM + CG)*BNV) ! G/N0 -! - TAUB(I) = XLINV(I) * ROLL(I) * ULOW(I) * ULOW(I) & - * ULOW(I) * GFOBNV * EFACT ! BASE FLUX Tau0 -! -! tem = min(HPRIME(I),hpmax) -! TAUB(I) = XLINV(I) * ROLL(I) * ULOW(I) * BNV * tem * tem -! - K = MAX(1, kref(I)-1) - TEM = MAX(VELCO(I,K)*VELCO(I,K), 0.0001) - SCOR(I) = BNV2(I,K) / TEM ! Scorer parameter below ref level - ENDDO -! if(lprnt) print *,' taub=',taub -! -!----SET UP BOTTOM VALUES OF STRESS -! - DO K = 1, KBPS - DO I = 1,npt - IF (K .LE. kref(I)) TAUP(I,K) = TAUB(I) - ENDDO - ENDDO -! -! Now compute vertical structure of the stress. -! - DO K = KMPS, KMM1 ! Vertical Level K Loop! - KP1 = K + 1 - DO I = 1, npt -! -!-----UNSTABLE LAYER IF RI < RIC -!-----UNSTABLE LAYER IF UPPER AIR VEL COMP ALONG SURF VEL <=0 (CRIT LAY) -!---- AT (U-C)=0. CRIT LAYER EXISTS AND BIT VECTOR SHOULD BE SET (.LE.) -! - IF (K .GE. kref(I)) THEN - ICRILV(I) = ICRILV(I) .OR. ( ri_n(I,K) .LT. RIC) & - .OR. (VELCO(I,K) .LE. 0.0) - ENDIF - ENDDO -! - DO I = 1,npt - IF (K .GE. kref(I)) THEN - IF (.NOT.ICRILV(I) .AND. TAUP(I,K) .GT. 0.0 ) THEN - TEMV = 1.0 / max(VELCO(I,K), 0.01) -! IF (OA(I) .GT. 0. .AND. PRSI(ipt(i),KP1).GT.RLOLEV) THEN - IF (OA(I).GT.0. .AND. kp1 .lt. kint(i)) THEN - SCORK = BNV2(I,K) * TEMV * TEMV - RSCOR = MIN(1.0, SCORK / SCOR(I)) - SCOR(I) = SCORK - ELSE - RSCOR = 1. - ENDIF -! - BRVF = SQRT(BNV2(I,K)) ! Brunt-Vaisala Frequency -! TEM1 = XLINV(I)*(RO(I,KP1)+RO(I,K))*BRVF*VELCO(I,K)*0.5 - TEM1 = XLINV(I)*(RO(I,KP1)+RO(I,K))*BRVF*0.5 * max(VELCO(I,K),0.01) - HD = SQRT(TAUP(I,K) / TEM1) - FRO = BRVF * HD * TEMV -! -! RIM is the MINIMUM-RICHARDSON NUMBER BY SHUTTS (1985) -! - TEM2 = SQRT(ri_n(I,K)) - TEM = 1. + TEM2 * FRO - RIM = ri_n(I,K) * (1.-FRO) / (TEM * TEM) -! -! CHECK STABILITY TO EMPLOY THE 'SATURATION HYPOTHESIS' -! OF LINDZEN (1981) EXCEPT AT TROPOSPHERIC DOWNSTREAM REGIONS -! -! ---------------------- - IF (RIM .LE. RIC .AND. & -! (OA(I) .LE. 0. .OR. PRSI(ipt(I),KP1).LE.RLOLEV )) THEN - (OA(I) .LE. 0. .OR. kp1 .ge. kint(i) )) THEN - TEMC = 2.0 + 1.0 / TEM2 - HD = VELCO(I,K) * (2.*SQRT(TEMC)-TEMC) / BRVF - TAUP(I,KP1) = TEM1 * HD * HD - ELSE - TAUP(I,KP1) = TAUP(I,K) * RSCOR - ENDIF - taup(i,kp1) = min(taup(i,kp1), taup(i,k)) - ENDIF - ENDIF - ENDDO - ENDDO -! -! DO I=1,IM -! taup(i,km+1) = taup(i,km) -! ENDDO -! - IF(LCAP .LE. KM) THEN - DO KLCAP = LCAPP1, KM+1 - DO I = 1,npt - SIRA = PRSI(ipt(I),KLCAP) / PRSI(ipt(I),LCAP) - TAUP(I,KLCAP) = SIRA * TAUP(I,LCAP) - ENDDO - ENDDO - ENDIF -! -! Calculate - (g/p*)*d(tau)/d(sigma) and Decel terms DTAUX, DTAUY -! - DO I=1,npt -! SCOR(I) = 1.0 / (RCS(I) * PSTAR(I)) - SCOR(I) = 1.0 / RCS(I) - ENDDO - DO K = 1,KM - DO I = 1,npt - TAUD(I,K) = G * (TAUP(I,K+1) - TAUP(I,K)) * SCOR(I) / DEL(ipt(I),K) - ENDDO - ENDDO -! -!------LIMIT DE-ACCELERATION (MOMENTUM DEPOSITION ) AT TOP TO 1/2 VALUE -!------THE IDEA IS SOME STUFF MUST GO OUT THE 'TOP' -! - DO KLCAP = LCAP, KM - DO I = 1,npt - TAUD(I,KLCAP) = TAUD(I,KLCAP) * FACTOP - ENDDO - ENDDO -! -!------IF THE GRAVITY WAVE DRAG WOULD FORCE A CRITICAL LINE IN THE -!------LAYERS BELOW SIGMA=RLOLEV DURING THE NEXT DELTIM TIMESTEP, -!------THEN ONLY APPLY DRAG UNTIL THAT CRITICAL LINE IS REACHED. -! - DO K = 1,KMM1 - DO I = 1,npt - IF (K .GT. kref(I) .and. PRSI(ipt(i),K) .GE. RLOLEV) THEN - IF(TAUD(I,K).NE.0.) THEN - TEM = DELTIM * RCS(I) * TAUD(I,K) - DTFAC(I) = MIN(DTFAC(I),ABS(VELCO(I,K)/TEM)) - ENDIF - ENDIF - ENDDO - ENDDO -! -! if(lprnt) print *,' before A=',A(ipt(ipr),:) -! if(lprnt) print *,' before B=',B(ipt(ipr),:) - - DO K = 1,KM - DO I = 1,npt - J = ipt(i) - TAUD(I,K) = TAUD(I,K) * DTFAC(I) - DTAUX = TAUD(I,K) * XN(I) - DTAUY = TAUD(I,K) * YN(I) -! --- lm mb (*j*) changes overwrite GWD - if ( K .lt. IDXZB(I) .AND. IDXZB(I) .ne. 0 ) then - DBIM = DB(I,K) / (1.+DB(I,K)*DELTIM) - A(J,K) = - DBIM * V1(J,K) + A(J,K) - B(J,K) = - DBIM * U1(J,K) + B(J,K) -! if ( ABS(DBIM * U1(J,K)) .gt. .01 ) print *,' in gwdps_lmi.f KDT=',KDT,I,K,DB(I,K), & -! dbim,idxzb(I),U1(J,K),V1(J,K),me - DUSFC(J) = DUSFC(J) - DBIM * V1(J,K) * DEL(J,K) - DVSFC(J) = DVSFC(J) - DBIM * U1(J,K) * DEL(J,K) - else -! - A(J,K) = DTAUY + A(J,K) - B(J,K) = DTAUX + B(J,K) - DUSFC(J) = DUSFC(J) + DTAUX * DEL(J,K) - DVSFC(J) = DVSFC(J) + DTAUY * DEL(J,K) - endif - ENDDO - ENDDO -! if(lprnt) print *,' in gwdps_lm.f after A=',A(ipt(ipr),:) -! if(lprnt) print *,' in gwdps_lm.f after B=',B(ipt(ipr),:) -! if(lprnt) print *,' DB=',DB(ipr,:) - DO I = 1,npt - J = ipt(i) -! TEM = (-1.E3/G) * RCS(I) * PSTAR(I) - TEM = (-1.E3/G) * RCS(I) - DUSFC(J) = TEM * DUSFC(J) - DVSFC(J) = TEM * DVSFC(J) - ENDDO -! -! MONITOR FOR EXCESSIVE GRAVITY WAVE DRAG TENDENCIES IF NCNT>0 -! -! IF(NCNT.GT.0) THEN -! IF(LAT.GE.38.AND.LAT.LE.42) THEN -!CMIC$ GUARD 37 -! DO 92 I = 1,IM -! IF(IKOUNT.GT.NCNT) GO TO 92 -! IF(I.LT.319.OR.I.GT.320) GO TO 92 -! DO 91 K = 1,KM -! IF(ABS(RCS*TAUD(I,K)) .GT. CRITAC) THEN -! IF(I.LE.IM) THEN -! IKOUNT = IKOUNT+1 -! PRINT 123,I,LAT,KDT -! PRINT 124,TAUB(I),BNV(I),ULOW(I), -! 1 GF(I),FR(I),ROLL(I),HPRIME(I),XN(I),YN(I) -! PRINT 124,(TAUD(I,KK),KK = 1,KM) -! PRINT 124,(TAUP(I,KK),KK = 1,KM+1) -! PRINT 124,(ri_n(I,KK),KK = 1,KM) -! DO 93 KK = 1,KMM1 -! VELKO(KK) = -! 1 0.5*RCS*((U1(I,KK)+U1(I,KK+1))*UBAR(I)+ -! 2 (V1(I,KK)+V1(I,KK+1))*VBAR(I))*ULOI(I) -!93 CONTINUE -! PRINT 124,(VELKO(KK),KK = 1,KMM1) -! PRINT 124,(A (I,KK),KK = 1,KM) -! PRINT 124,(DTAUY(I,KK),KK = 1,KM) -! PRINT 124,(B (I,KK),KK = 1,KM) -! PRINT 124,(DTAUX(I,KK),KK = 1,KM) -! GO TO 92 -! ENDIF -! ENDIF -!91 CONTINUE -!92 CONTINUE -!CMIC$ END GUARD 37 -!123 FORMAT(' *** MIGWD PRINT *** I=',I3,' LAT=',I3,' KDT=',I3) -!124 FORMAT(2X, 10E13.6) -! ENDIF -! ENDIF -! -! print *,' in gwdps_lm.f 18 =',A(ipt(1),idxzb(1)) -! &, B(ipt(1),idxzb(1)),me - RETURN - END diff --git a/src/fim/FIMsrc/fim/column/hpmdummy.f b/src/fim/FIMsrc/fim/column/hpmdummy.f deleted file mode 100644 index 8aea8c8..0000000 --- a/src/fim/FIMsrc/fim/column/hpmdummy.f +++ /dev/null @@ -1,14 +0,0 @@ - subroutine f_hpminit(me,desc) - character*20 desc - return - end - subroutine f_hpmterminate(me) - return - end - subroutine f_hpmstart(n,desc) - character*20 desc - return - end - subroutine f_hpmstop(n) - return - end diff --git a/src/fim/FIMsrc/fim/column/hyb2press.f b/src/fim/FIMsrc/fim/column/hyb2press.f deleted file mode 100644 index 6175548..0000000 --- a/src/fim/FIMsrc/fim/column/hyb2press.f +++ /dev/null @@ -1,73 +0,0 @@ - subroutine hyb2press(njeff,nsize_ar, pgr,prsi,prsl,prsik,prslk) - - use machine , only : kind_phys - - - use resol_def - use coordinate_def - use physcons, rk => con_rocp - implicit none - - - real (kind=kind_phys), parameter :: rk1 = rk + 1.0, rkr = 1.0/rk - &, R100=100.0, PT01=0.01 - integer njeff,nsize_ar - real(kind=kind_phys) prsl(nsize_ar,levs), prslk(nsize_ar,levs) - real(kind=kind_phys) prsi(nsize_ar,levs+1), prsik(nsize_ar,levs+1) - real(kind=kind_phys) pgr(nsize_ar) - real(kind=kind_phys) tem - - integer iq,ilat,me - integer i,k - - do k=1,levp1 - do i=1,njeff - prsi(i,levs+2-k) = ak5(k) + bk5(k)*pgr(i) ! prsi are now pressures - enddo - enddo - - do i=1,njeff - prsik(i,1) = (prsi(i,1)*PT01) ** rk - enddo - do k=1,levs - do i=1,njeff - prsik(i,k+1) = (prsi(i,k+1)*PT01) ** rk - tem = rk1 * (PRSI(i,k) - PRSI(i,k+1)) - prslk(i,k) = (prsik(i,k)*PRSI(i,k)-prsik(i,k+1)*PRSI(i,k+1)) - & / tem - prsl(i,k) = R100 * prslk(i,k) ** rkr - enddo - enddo - - - i=1 - me=0 - if(me.eq.0) return - -250 format('ilat iq=',i4,2x,i5,'sumdel(i)=',e12.3) - -251 format('ilat=',i4,2x,'iq=',i5,2x, - & 'sl1(i)=',e12.3,2x,'levshc(i)=',i5,' me=',i3) - -! if(ilat.lt.3)then - -! write(200,250)ilat,iq,sumdel(i) -! write(200,251)ilat,iq,sl1(i),levshc(i),me - -! do k=1,levp1 -! write(200,150) ak5(k),bk5(k),si(i,k),pgr(i) -150 format('ak5(k)=',e12.3,2x,'bk5(k)=',e12.3,2x,'si(i,k)=',e12.3, - & 'p=',e12.3) -! enddo - -! do k=1,levs -! if(me.eq.0)then -! write(200,300)k,sl(i,k),del(i,k) -! endif -300 format('k sl del=',i2,2x,e12.3,2x,e12.3) -! enddo - -! endif - - return - end diff --git a/src/fim/FIMsrc/fim/column/iounitdef.f b/src/fim/FIMsrc/fim/column/iounitdef.f deleted file mode 100644 index 007964d..0000000 --- a/src/fim/FIMsrc/fim/column/iounitdef.f +++ /dev/null @@ -1,92 +0,0 @@ -!!!!! ========================================================== !!!!! -!!!!! module "module_iounitdef description !!!!! -!!!!! ========================================================== !!!!! -! ! -! this module defines fortran unit numbers for input/output data ! -! files for the ncep gfs model. ! -! ! -! name type description unit no. ! -! --------------------------------------------------------------- ! -! NISIGI - input, sigma file 1 11 ! -! NISIGI2 - input, sigma file 2 12 ! -! NISFCI - input, surface initial data 14 ! -! ! -! NIMTNVR - input, montain variance file 24 ! -! NIDTBTH - input, equivalent potential temperature file 27 ! -! NICO2TR - input, co2 transm table for gfdl-lw only 15 ! -! NICO2CN - input, monthly/yearly 2-d co2 data (shared) 102 ! -! NIO3PRD - input, ozone production climatology 28 ! -! NIO3LOS - input, ozone destruction climatology 29 ! -! NIO3CLM - input, ozone climatology distribution 48 ! -! NINAMSF - input, namelist for surface file 35 ! -! NISFCYC - input, surface cycle files 101 ! -! NIRADSF - input, radiation surface data files (shared) 102 ! -! NICLTUN - input, cloud tuning table 43 ! -! NIMICPH - input, micro physics data file 1 ! -! NIAERCM - input, aerosols climatology (shared) 102 ! -! ! -! NOSIGR1 - output, first time level sigma restart file 51 ! -! NOSIGR2 - output, second time level sigma restart file 52 ! -! NOSFCR - output, surface restart file 53 ! -! NOSIGF - output, sigma file for post process 61 ! -! NOSFCF - output, surface file for post process 62 ! -! NOFLXF - output, flux file for post process 63 ! -! NOD3DF - output, 3-d file for post process 64 ! -!hchuang code change [+1L] -! NOG3DF - output, 3-d file for GFS-GOCART specific 69 ! -! NOLOGF - output, log file 99 ! -! ! -! NIOFRAD - in/out, temperary radiation data file (shared) 16 ! -! ! -!!!!! ========================================================== !!!!! -!!!!! end descriptions !!!!! -!!!!! ========================================================== !!!!! - -!========================================! - module module_iounitdef ! -!........................................! -! - implicit none -! - public - -! --- ... input units - - integer, parameter :: NISIGI = 11 - integer, parameter :: NISIGI2 = 12 - integer, parameter :: NISFCI = 14 - integer, parameter :: NICO2TR = 15 - integer, parameter :: NICO2CN = 102 - integer, parameter :: NIMTNVR = 24 - integer, parameter :: NIDTBTH = 27 - integer, parameter :: NIO3PRD = 28 - integer, parameter :: NIO3LOS = 29 - integer, parameter :: NINAMSF = 35 - integer, parameter :: NICLTUN = 43 - integer, parameter :: NIO3CLM = 48 - integer, parameter :: NIMICPH = 1 - integer, parameter :: NISFCYC = 101 - integer, parameter :: NIAERCM = 102 - integer, parameter :: NIRADSF = 102 - -! --- ... output units - - integer, parameter :: NOSIGR1 = 51 - integer, parameter :: NOSIGR2 = 52 - integer, parameter :: NOSFCR = 53 - integer, parameter :: NOSIGF = 61 - integer, parameter :: NOSFCF = 62 - integer, parameter :: NOFLXF = 63 - integer, parameter :: NOD3DF = 64 -!hchuang code change [+1L] - integer, parameter :: NOG3DF = 69 - integer, parameter :: NOLOGF = 99 - -! --- ... in/out units - - integer, parameter :: NIOFRAD = 16 - -! -!........................................! - end module module_iounitdef ! -!========================================! diff --git a/src/fim/FIMsrc/fim/column/layout1.f b/src/fim/FIMsrc/fim/column/layout1.f deleted file mode 100644 index d0a5faf..0000000 --- a/src/fim/FIMsrc/fim/column/layout1.f +++ /dev/null @@ -1,32 +0,0 @@ - module layout1 -! use resol_def - implicit none - save -cc - integer nodes, nodes_comp,nodes_io, - x me, - x ls_dim, - x ls_max_node, - x lats_dim_a, - x lats_dim_r, - x lats_dim_ext, - x lats_node_a, - x lats_node_a_max, - x lats_node_ext, - x lats_node_r, - x lats_node_r_max, - x ipt_lats_node_a, - x ipt_lats_node_ext, - x ipt_lats_node_r, - x len_trie_ls, - x len_trio_ls, - x len_trie_ls_max, - x len_trio_ls_max, - x me_l_0 -cc - INTEGER ,ALLOCATABLE :: lat1s_a(:),lat1s_r(:), - . lon_dims_a(:),lon_dims_ext(:),lon_dims_r(:) -c! jbao new gfs physics - parameter (lats_node_r = 1, ipt_lats_node_r = 1) -c! end jbao new gfs physics - end module layout1 diff --git a/src/fim/FIMsrc/fim/column/lrgsclr_v.f b/src/fim/FIMsrc/fim/column/lrgsclr_v.f deleted file mode 100644 index b0e20e1..0000000 --- a/src/fim/FIMsrc/fim/column/lrgsclr_v.f +++ /dev/null @@ -1,289 +0,0 @@ - SUBROUTINE LRGSCL(IX,IM,KM,DT,T1,Q1,PRSL,DEL,PRSLK,RAIN,CLW) -! - USE MACHINE , ONLY : kind_phys - USE FUNCPHYS , ONLY : fpvs, ftdp, fthe, stma, ftlcl - USE PHYSCONS, HVAP => con_HVAP, CP => con_CP, RV => con_RV - &, EPS => con_eps, EPSM1 => con_epsm1, ROCP => con_ROCP - &, grav => con_g - implicit none -! -! include 'constant.h' -! - integer IX , IM, KM - real(kind=kind_phys) T1(IX,KM), Q1(IX,KM), PRSL(IX,KM), - & DEL(IX,KM), PRSLK(IX,KM), RAIN(IM), - & CLW(IM,KM), DT -! -! LOCAL VARIABLES -! - integer k, kmax, I - real(kind=kind_phys) dpovg, EI, el2orc, - & elocp, - & pk, qcond, qevap, - & rnevap, SLKLCL,TDPD, - & THELCL, TLCL, val0, val1 -! -! -! PHYSICAL PARAMETERS - PARAMETER(ELOCP=HVAP/CP, EL2ORC=HVAP*HVAP/(RV*CP)) -! -! - real(kind=kind_phys) TO(IM,KM), QO(IM,KM), QS(IM,KM), - & THE(IM,KM), DQ(IM,KM), RAINLVL(IM,KM), - & ES(IM,KM), DQINT(IM), PINT(IM), - & DELQBAR(IM), DELTBAR(IM), THEBAR(IM), - & THEINT(IM) - integer KMLEV(IM,KM), KE(IM), KK(IM), KS(IM) - LOGICAL FLG(IM), TOPFLG(IM), TOTFLG -cc -cc-------------------------------------------------------------------- -cc - real(kind=kind_phys) cons_0 !constant - real(kind=kind_phys) cons_1pdm8 !constant -cc - cons_0 = 0.d0 !constant - cons_1pdm8 = 1.d-8 !constant -cc -cc-------------------------------------------------------------------- -cc - KMAX = KM - DO K = 1, KM - do i=1,im - IF (PRSL(I,K) .GT. 60.0) KMAX = K + 1 - enddo - ENDDO -C -C SURFACE PRESSURE UNIT IS CB -C - DO I=1,IM -! PSK(I) = FPKAP(PS(I)) - RAIN(I) = 0. - DELTBAR(I) = 0. - DELQBAR(I) = 0. - FLG(I) = .FALSE. - TOPFLG(I) = .FALSE. - KE(I) = kmax + 1 - KS(I) = 0 - ENDDO - TOTFLG = .FALSE. -C -C COLUMN VARIABLES -C PRSL IS PRESSURE OF THE LAYER (CB) -C TO IS TEMPERATURE AT T+DT (K)... THIS IS AFTER ADVECTION AND TURBULAN -C QO IS MIXING RATIO AT T+DT (KG/KG)..Q1 -C - DO K = 1, KMAX - DO I=1,IM -! PFLD(I,k) = PS(I) * SL(K) - TO(I,k) = T1(I,k) - QO(I,k) = Q1(I,k) - ENDDO - ENDDO -C -C MODEL CONSISTENT SATURATION MIXING RATIO -C -! es(:,:) = 0.001 * fpvs(t1(1:IM,:)) ! fpvs in Pa - DO K = 1, KMAX - DO I=1,IM - es(I,k) = min(PRSL(I,k), 0.001 * fpvs(t1(I,k))) ! fpvs in Pa - QS(I,k) = EPS * ES(I,k) / (PRSL(I,k) + EPSM1*ES(I,k)) - QS(I,k) = MAX(QS(I,k),cons_1pdm8) !constant - ENDDO - ENDDO - DO K = 1, KMAX - DO I=1,IM - IF(QO(I,k).GT.QS(I,k)) FLG(I) = .TRUE. - ENDDO - ENDDO -!! - DO I=1,IM - IF(FLG(I)) TOTFLG = .TRUE. - ENDDO - IF(.NOT.TOTFLG) RETURN -!! - DO K = 1, KMAX - DO I = 1, IM - DQ(I,k) = 0. - THE(I,k) = TO(I,k) - ENDDO - ENDDO -C -C COMPUTE THETA-E -C - DO K = 1, KMAX - DO I = 1, IM - IF(FLG(I)) THEN -! PK = PSK(I) * SLK(K) - PK = PRSLK(I,K) - THE(I,k) = FTHE(TO(I,k),PK) - IF(THE(I,k).EQ.0.) THEN - THE(I,k) = TO(I,k) / PK - ENDIF -C THE(I,k) = TO(I,k) * ((PRSL(I,k)-ES(I,k))*.01) ** (-ROCP) -C & * EXP(ELOCP * QS(I,k) / TO(I,k)) - DQ(I,k) = QO(I,k)- QS(I,k) -C -C MODIFICATION OF THETA-E FOR SUPER-SATURATION -C - THE(I,k)= THE(I,k) * (1. + HVAP*MAX(DQ(I,k),cons_0) !constant - & /(CP*TO(I,k))) - ENDIF - ENDDO - ENDDO - DO K = 1, KMAX - DO I = 1, IM - KMLEV(I,k) = 0 - RAINLVL(I,k) = 0. - ENDDO - ENDDO -C -C STARTING POINT OF ADJUSTMENT -C - K = 1 - DO I = 1, IM - KK(I) = 0 - DQINT(I) = 0. - THEINT(I) = 0. - THEBAR(I) = 0. - PINT(I) = 0. -C -C FOR CONDITIONALLY UNSTABLE AND SUPERSATURATED LAYERS, -C OBTAIN INTEGRATED THETA AND Q-QS -C -C KMLEV KEEPS TRACK OF THE NUMBER OF LAYERS THAT SATISFIES -C THE CONDITION FOR ADJUSTMENT -C - IF(DQ(I,k).GT.0..AND.THE(I,k).GE.THE(I,K+1).AND.FLG(I)) THEN - DQINT(I) = DQINT(I) + DQ(I,k) * DEL(I,K) - THEINT(I) = THEINT(I) + THE(I,k) * DEL(I,K) - PINT(I) = PINT(I) + DEL(I,K) - KK(I) = KK(I) + 1 - KMLEV(I,k) = KK(I) - ENDIF - ENDDO - DO K = 2, KMAX - 1 - DO I = 1, IM - IF(DQ(I,k).GT.0..AND.THE(I,k).GE.THE(I,K+1).AND.FLG(I)) THEN - DQINT(I) = DQINT(I) + DQ(I,k) * DEL(I,K) - THEINT(I) = THEINT(I) + THE(I,k) * DEL(I,K) - PINT(I) = PINT(I) + DEL(I,K) - KK(I) = KK(I) + 1 - KMLEV(I,k) = KK(I) - ENDIF - ENDDO - DO I = 1, IM - IF(PINT(I).GT.0.)THEBAR(I) = THEINT(I) / PINT(I) -C -C IF THE LAYER BELOW SATISFIES THE CONDITION AND THE PRESENT -C LAYER IS COLDER THAN THE ADJSUTED THETA-E, -C THE LAYER IS INCLUDED IF THE INTEGRATED MOISTURE EXCESS -C CAN BE MAINTAINED -C - IF(KMLEV(I,k).EQ.0.AND.KMLEV(I,K-1).GT.0.AND. - & THEBAR(I).GE.THE(I,k).AND..NOT.TOPFLG(I)) THEN - DQINT(I) = DQINT(I) + DQ(I,k) * DEL(I,K) - ENDIF - IF(KMLEV(I,k).EQ.0.AND.KMLEV(I,K-1).GT.0.AND. - & THEBAR(I).GE.THE(I,k).AND.DQINT(I).GT.0. - & .AND..NOT.TOPFLG(I)) THEN - KK(I) = KK(I) + 1 - KMLEV(I,k) = KK(I) - TOPFLG(I) = .TRUE. -! PK = PSK(I) * SLK(K) - EI = 1000.0 * PRSL(I,k) * QO(I,k) - & / (EPS - EPSM1*QO(I,k)) - EI = MIN(MAX(EI,cons_1pdm8),ES(I,k)) !constant - TDPD = MAX(TO(I,k)-FTDP(EI),cons_0) !constant - TLCL = FTLCL(TO(I,k), TDPD) - SLKLCL = PRSLK(I,K) * TLCL / TO(I,k) - THELCL = FTHE(TLCL,SLKLCL) - IF(THELCL.NE.0.) THEN - THE(I,k) = THELCL -C THE(I,k) = TO(I,k) * ((PRSL(I,k) - EI)*.01) ** (-ROCP) -C & * EXP(ELOCP * MAX(QO(I,k),1.E-8) / TO(I,k)) - ENDIF - THEINT(I) = THEINT(I) + THE(I,k) * DEL(I,K) - PINT(I) = PINT(I) + DEL(I,K) - ENDIF - ENDDO -C -C RESET THE INTEGRAL IF THE LAYER IS NOT IN THE CLOUD -C - DO I = 1, IM - IF(KMLEV(I,k).EQ.0.AND.KMLEV(I,K-1).GT.0) THEN - THEBAR(I) = THEINT(I) / PINT(I) - DQINT(I) = 0. - THEINT(I) = 0. - PINT(I) = 0. - KK(I) = 0 - KS(I) = k - 1 - KE(I) = KS(I) - KMLEV(I,k-1) + 1 - FLG(I) = .false. - ENDIF - ENDDO - enddo -C -C When within A CLOUD LAYER, COMPUTE THE MOIST-ADIABATIC -C (TO AND QO) USING THE AVERAGED THETA-E AND THE RESULTANT RAIN -C - do k = 1, kmax - DO I = 1, IM - if(k.ge.KE(I).and.k.le.KS(I)) then -! PK = PSK(I) * SLK(K) - PK = PRSLK(I,K) -! TO(I,k) = FTMA(THEBAR(I),PK,QO(I,k)) - CALL STMA(THEBAR(i),PK,TO(I,k),QO(I,k)) - THE(I,k) = THEBAR(I) - QS(I,k) = QO(I,k) - DPOVG = DEL(I,K) * (1.0/grav) - RAINLVL(I,k) = (Q1(I,k) - QO(I,k)) * dpovg - DELTBAR(I) = DELTBAR(I) + (TO(I,k) - T1(I,k)) * dpovg / PK - DELQBAR(I) = DELQBAR(I) + (QO(I,k) - Q1(I,k)) * dpovg - ENDIF -C -C THIS STEP TAKES CARE OF STABLE HEATING -C - IF(KMLEV(I,k).EQ.0.AND.DQ(I,k).GT.0.) THEN - QCOND = (QO(I,k)-QS(I,k)) / - & (1.+EL2ORC*QS(I,k)/(TO(I,K)*TO(I,K))) - QO(I,k) = QO(I,k) - QCOND - TO(I,k) = TO(I,k) + QCOND * ELOCP -! PK = PSK(I) * SLK(K) - PK = PRSLK(I,K) -C TO(I,k) = FTMA(THE(I,k),PK,QO(I,k)) - DPOVG = DEL(I,K) * (1.0/grav) - RAINLVL(I,k) = (Q1(I,k) - QO(I,k)) * dpovg - DELTBAR(I) = DELTBAR(I) + (TO(I,k) - T1(I,k)) * dpovg / PK - DELQBAR(I) = DELQBAR(I) + (QO(I,k) - Q1(I,k)) * dpovg - QS(I,k) = QO(I,k) - ENDIF - ENDDO - ENDDO -C -C EVAPORATION OF FALLING RAIN -C - DO K = KMAX, 1, -1 - DO I = 1, IM - T1(I,k) = TO(I,k) - Q1(I,k) = QO(I,k) - DPOVG = DEL(I,K) * (1.0/grav) - RAIN(I) = RAIN(I) + RAINLVL(I,k) + CLW(I,k) * DPOVG - DQ(I,k) = (QO(I,k) - QS(I,k)) / - & (1. + EL2ORC*QS(I,k)/(TO(I,K)*TO(I,K))) - IF(RAIN(I).GT.0..AND.RAINLVL(I,k).LE.0.) THEN - QEVAP = -DQ(I,k)*(1.-EXP(-0.32*SQRT(DT*RAIN(I)))) - RNEVAP = MIN(QEVAP*DPOVG,RAIN(I)) - Q1(I,k) = Q1(I,k)+RNEVAP/DPOVG - T1(I,k) = T1(I,k)-RNEVAP/DPOVG*ELOCP - RAIN(I) = RAIN(I)-RNEVAP - DELTBAR(I) = DELTBAR(I) - RNEVAP * ELOCP - DELQBAR(I) = DELQBAR(I) + RNEVAP - ENDIF - ENDDO - ENDDO - DO I = 1, IM - RAIN(I) = MAX(RAIN(I),cons_0) !constant - ENDDO -!! - RETURN - END diff --git a/src/fim/FIMsrc/fim/column/lwave.f b/src/fim/FIMsrc/fim/column/lwave.f deleted file mode 100644 index 76e511e..0000000 --- a/src/fim/FIMsrc/fim/column/lwave.f +++ /dev/null @@ -1,3095 +0,0 @@ - SUBROUTINE CLO89(CLDFAC,CAMT,NCLDS,KBTM,KTOP - &, L, LP1, IMAX, NVECT) -! -! -! SUBROUTINE CLO88 COMPUTES CLOUD TRANSMISSION FUNCTIONS FOR THE -! LONGWAVE CODE,USING CODE WRITTEN BY BERT KATZ (301-763-8161). -! AND MODIFIED BY DAN SCHWARZKOPF IN DECEMBER,1988. -! INPUTS: (MODULE BLOCK) -! CAMT,KTOP,KBTM,NCLDS RADISW -! OUTPUT: -! CLDFAC CLDCOM -! -! CALLED BY: RADMN OR MODEL ROUTINE -! CALLS : -! -! - USE MACHINE , ONLY : kind_rad - implicit none -! - integer IMAX,KP,K,LP1,L,NVECT - integer NCLDS(IMAX),KTOP(IMAX,LP1),KBTM(IMAX,LP1) - real (kind=kind_rad) CAMT(IMAX,LP1),CLDFAC(IMAX,LP1,LP1) - &, CLDROW(LP1) -! - real (kind=kind_rad) CLDIPT(LP1,LP1,NVECT) -! - real (kind=kind_rad) xcld - integer iq, itop, jtop, ip, ir, i, j, k1, k2, kt, nc, kb -! - DO IQ=1,IMAX,NVECT -! - ITOP = IQ + (NVECT-1) - IF (ITOP .GT. IMAX) ITOP = IMAX - JTOP = ITOP - IQ + 1 -! - DO IP=1,JTOP - IR = IQ + IP - 1 - IF (NCLDS(IR).EQ.0) THEN - DO J=1,LP1 - DO I=1,LP1 - CLDIPT(I,J,IP) = 1. - ENDDO - ENDDO - ENDIF - IF (NCLDS(IR).GE.1) THEN - XCLD = 1.-CAMT(IR,2) - K1 = KTOP(IR,2) + 1 - K2 = KBTM(IR,2) - DO J=1,LP1 - CLDROW(J) = 1. - ENDDO - DO J=1,K2 - CLDROW(J) = XCLD - ENDDO - KB = MAX(K1,K2+1) - DO K=KB,LP1 - DO KP=1,LP1 - CLDIPT(KP,K,IP) = CLDROW(KP) - ENDDO - ENDDO - DO J=1,LP1 - CLDROW(J) = 1. - ENDDO - DO J=K1,LP1 - CLDROW(J) = XCLD - ENDDO - KT = MIN(K1-1,K2) - DO K=1,KT - DO KP=1,LP1 - CLDIPT(KP,K,IP) = CLDROW(KP) - ENDDO - ENDDO - IF (K2+1 .LE. K1-1) THEN - DO J=K2+1,K1-1 - DO I=1,LP1 - CLDIPT(I,J,IP) = 1. - ENDDO - ENDDO - ELSE IF(K1.LE.K2) THEN - DO J=K1,K2 - DO I=1,LP1 - CLDIPT(I,J,IP) = XCLD - ENDDO - ENDDO - ENDIF - ENDIF - IF (NCLDS(IR).GE.2) THEN - DO NC=2,NCLDS(IR) - XCLD = 1. - CAMT(IR,NC+1) - K1 = KTOP(IR,NC+1)+1 - K2 = KBTM(IR,NC+1) - DO J=1,LP1 - CLDROW(J) = 1. - ENDDO - DO J=1,K2 - CLDROW(J) = XCLD - ENDDO - KB = MAX(K1,K2+1) - DO K=KB,LP1 - DO KP=1,LP1 - CLDIPT(KP,K,IP) = CLDIPT(KP,K,IP)*CLDROW(KP) -! CLDFIP(KP,K) = CLDROW(KP) - ENDDO - ENDDO - DO J=1,LP1 - CLDROW(J) = 1. - ENDDO - DO J=K1,LP1 - CLDROW(J) = XCLD - ENDDO - KT = MIN(K1-1,K2) - DO K=1,KT - DO KP=1,LP1 - CLDIPT(KP,K,IP) = CLDIPT(KP,K,IP)*CLDROW(KP) -! CLDFIP(KP,K) = CLDROW(KP) - ENDDO - ENDDO -! IF(K2+1.LE.K1-1) THEN -! DO J=K2+1,K1-1 -! DO I=1,LP1 -! CLDIPT(I,J,IP) = 1. -! ENDDO -! ENDDO - IF (K1 .LE. K2) THEN - DO J=K1,K2 - DO I=1,LP1 - CLDIPT(I,J,IP) = CLDIPT(I,J,IP)*XCLD - ENDDO - ENDDO - ENDIF -! DO J=1,LP1 -! DO I=1,LP1 -! CLDIPT(I,J,IP) = CLDIPT(I,J,IP)*CLDFIP(I,J) -! ENDDO -! ENDDO - ENDDO - ENDIF -! - ENDDO -! - DO J=1,LP1 - DO I=1,LP1 - DO IP=1,JTOP - IR = IQ + IP - 1 - CLDFAC(IR,I,J) = CLDIPT(I,J,IP) - ENDDO - ENDDO - ENDDO -! - ENDDO -! - RETURN - END -! - SUBROUTINE E1E290(G1,G2,G3,G4,G5,EMISS,FXOE1,DTE1,FXOE2,DTE2, - & AVEPHI, L, LP1, IMAX, EM1V, EM1VW, T1, T2, T4) -CFPP$ NOCONCUR R -! -! SUBROUTINE E1E290 COMPUTES THE EXCHANGE TERMS IN THE FLUX EQUATION -! FOR LONGWAVE RADIATION FOR ALL TERMS EXCEPT THE EXCHANGE WITH THE -! TOP OF THE ATMOSPHERE. THE METHOD IS A TABLE LOOKUP ON A PRE- -! COMPUTED E2 FUNCTION (DEFINED IN REF. (4)). -! THE E1 FUNCTION CALCULATIONS (FORMERLY DONE IN SUBROUTINE -! E1V88 COMPUTE THE FLUX RESULTING FROM THE EXCHANGE OF PHOTONS -! BETWEEN A LAYER AND THE TOP OF THE ATMOSPHERE. THE METHOD IS A -! TABLE LOOKUP ON A PRE-COMPUTED E1 FUNCTION. -! CALCULATIONS ARE DONE IN TWO FREQUENCY RANGES: -! 1) 0-560,1200-2200 CM-1 FOR Q(APPROX) -! 2) 160-560 CM-1 FOR Q(APPROX,CTS). -! MOTIVATION FOR THESE CALCULATIONS IS IN REFERENCES (1) AND (4). -! INPUTS: (MODULE BLOCKS) -! EM1V,EM1VW,T1,T2,T4 TABCOM -! AVEPHI TFCOM -! TEMP RADISW -! T KDACOM -! FXOE1,DTE1 ARGUMENT LIST -! FXOE2,DTE2 ARGUMENT LIST -! OUTPUTS: -! EMISS TFCOM -! G1,G2,G3 ARGUMENT LIST,FOR 1ST FREQ. RANGE -! G4,G5 ARGUMENT LIST,FOR 2ND FREQ. RANGE -! -! CALLED BY : FST88 -! CALLS : -! -! -c$$$ USE MACHINE , ONLY : kind_rad - USE HCON - implicit none -! - integer L, LP1, IMAX - real (kind=kind_rad) AVEPHI(IMAX,LP1), EMISS(IMAX,LP1) -! - integer IT1(IMAX,3*L+2) - real (kind=kind_rad) FYO(IMAX,LP1), DU(IMAX,LP1), - & WW1(IMAX,LP1), WW2(IMAX,LP1) -!---VARIABLES IN THE ARGUMENT LIST - real (kind=kind_rad) T1(5040), T2(5040), T4(5040) - &, EM1V(5040), EM1VW(5040) - &, FXOE1(IMAX,LP1), DTE1(IMAX,LP1) - &, FXOE2(IMAX,LP1), DTE2(IMAX,LP1), - & G1(IMAX,LP1), G2(IMAX,L) - &, G3(IMAX,LP1), G4(IMAX,LP1), G5(IMAX,L) -! - real (kind=kind_rad) TMP3, tem1, tem2, tem3, tem4 - integer LL, LLP1, KP, I, IVAL, K1, K2, item -! -!---FIRST WE OBTAIN THE EMISSIVITIES AS A FUNCTION OF TEMPERATURE -! (INDEX FXO) AND WATER AMOUNT (INDEX FYO). THIS PART OF THE CODE -! THUS GENERATES THE E2 FUNCTION. THE FXO INDICES HAVE BEEN -! OBTAINED IN FST88, FOR CONVENIENCE. -! -!---THIS SUBROUTINE EVALUATES THE K=1 CASE ONLY-- -! -!---THIS LOOP REPLACES LOOPS GOING FROMI=1,IMAX AND KP=2,LP1 PLUS -! THE SPECIAL CASE FOR THE LP1TH LAYER. -! LP2 = L + 2 - LL = L + L - LLP1 = LL + 1 -! - DO KP=1,LP1 - DO I=1,IMAX - TMP3 = LOG10(AVEPHI(I,KP)) + H16E1 - FYO(I,KP) = AINT(TMP3*TEN) - DU(I,KP) = TMP3 - HP1*FYO(I,KP) - FYO(I,KP) = H28E1 * FYO(I,KP) - IVAL = FYO(I,KP) + FXOE2(I,KP) - EMISS(I,KP) = T1(IVAL ) + DU(I,KP) * T2(IVAL) - & + DTE2(I,KP) * T4(IVAL) - ENDDO - ENDDO -! -!---THE SPECIAL CASE EMISS(I,L) (LAYER KP) IS OBTAINED NOW -! BY AVERAGING THE VALUES FOR L AND LP1: - DO I=1,IMAX - EMISS(I,L) = HAF*(EMISS(I,L) + EMISS(I,LP1)) - ENDDO -! -! CALCULATIONS FOR THE KP=1 LAYER ARE NOT PERFORMED, AS -! THE RADIATION CODE ASSUMES THAT THE TOP FLUX LAYER (ABOVE THE -! TOP DATA LEVEL) IS ISOTHERMAL, AND HENCE CONTRIBUTES NOTHING -! TO THE FLUXES AT OTHER LEVELS. -! -!***THE FOLLOWING IS THE CALCULATION FOR THE E1 FUNCTION, FORMERLY -! DONE IN SUBROUTINE E1V88. THE MOVE TO E1E288 IS DUE TO THE -! SAVINGS IN OBTAINING INDEX VALUES (THE TEMP. INDICES HAVE -! BEEN OBTAINED IN FST88, WHILE THE U-INDICES ARE OBTAINED -! IN THE E2 CALCS.,WITH K=1). -! -! FOR TERMS INVOLVING TOP LAYER, DU IS NOT KNOWN; IN FACT, WE -! USE INDEX 2 TO REPERSENT INDEX 1 IN PREV. CODE. THIS MEANS THAT -! THE IT1 INDEX 1 AND LLP1 HAS TO BE CALCULATED SEPARATELY. THE -! INDEX LLP2 GIVES THE SAME VALUE AS 1; IT CAN BE OMITTED. -! - DO I=1,IMAX - IT1(I,1) = FXOE1(I,1) - WW1(I,1) = TEN - DTE1(I,1) - WW2(I,1) = HP1 - ENDDO -CDIR$ IVDEP - DO KP=1,L - K1 = KP + 1 - K2 = KP + LP1 - DO I=1,IMAX - IT1(I,K1) = FYO(I,KP) + FXOE1(I,K1) - IT1(I,K2) = FYO(I,KP) + FXOE1(I,KP) - WW1(I,K1) = TEN - DTE1(I,K1) - WW2(I,K1) = HP1 - DU(I,KP) - ENDDO - ENDDO - DO KP=1,L - DO I=1,IMAX - IT1(I,KP+LLP1) = FYO(I,KP) + FXOE1(I,1) - ENDDO - ENDDO -! -! G3(I,1) HAS THE SAME VALUES AS G1 (AND DID ALL ALONG) - DO I=1,IMAX - TEM1 = WW1(I,1) * WW2(I,1) - TEM2 = WW2(I,1) * DTE1(I,1) - ITEM = IT1(I,1) - G1(I,1) = TEM1 * EM1V(ITEM) + TEM2 * EM1V(ITEM+1) - G4(I,1) = TEM1 * EM1VW(ITEM) + TEM2 * EM1VW(ITEM+1) - G3(I,1) = G1(I,1) - ENDDO - DO KP=1,L - K1 = KP + 1 - DO I=1,IMAX - TEM1 = WW1(I,K1) * WW2(I,K1) - TEM2 = WW2(I,K1) * DTE1(I,K1) - TEM3 = WW1(I,K1) * DU(I,KP) - TEM4 = DTE1(I,K1) * DU(I,KP) - ITEM = IT1(I,K1) -! - G1(I,K1) = TEM1 * EM1V(ITEM) + TEM2 * EM1V(ITEM+1)+ - & TEM3 * EM1V(ITEM+28) + TEM4 * EM1V(ITEM+29) - G4(I,K1) = TEM1 * EM1VW(ITEM) + TEM2 * EM1VW(ITEM+1)+ - & TEM3 * EM1VW(ITEM+28) + TEM4 * EM1VW(ITEM+29) -! - TEM1 = WW1(I,KP) * WW2(I,K1) - TEM2 = WW2(I,K1) * DTE1(I,KP) - TEM3 = WW1(I,KP) * DU(I,KP) - TEM4 = DTE1(I,KP) * DU(I,KP) - ITEM = IT1(I,LP1+KP) -! - G2(I,KP) = TEM1 * EM1V(ITEM) + TEM2 * EM1V(ITEM+1)+ - & TEM3 * EM1V(ITEM+28) + TEM4 * EM1V(ITEM+29) - G5(I,KP) = TEM1 * EM1VW(ITEM) + TEM2 * EM1VW(ITEM+1)+ - & TEM3 * EM1VW(ITEM+28) + TEM4 * EM1VW(ITEM+29) - ENDDO - ENDDO - DO KP=2,LP1 - DO I=1,IMAX - ITEM = IT1(I,LL+KP) - G3(I,KP) = WW1(I,1) * WW2(I,KP) * EM1V(ITEM)+ - & WW2(I,KP) * DTE1(I,1) * EM1V(ITEM+1)+ - & WW1(I,1) * DU(I,KP-1) * EM1V(ITEM+28)+ - & DTE1(I,1) * DU(I,KP-1) * EM1V(ITEM+29) - ENDDO - ENDDO -! - RETURN - END - SUBROUTINE E290(EMISSB,EMISS,AVEPHI,KLEN,FXOE2,DTE2 - &, L, LP1, IMAX, T1, T2, T4) -CFPP$ NOCONCUR R -! -! SUBROUTINE E290 COMPUTES THE EXCHANGE TERMS IN THE FLUX EQUATION -! FOR LONGWAVE RADIATION FOR ALL TERMS EXCEPT THE EXCHANGE WITH THE -! TOP OF THE ATMOSPHERE. THE METHOD IS A TABLE LOOKUP ON A PRE- -! COMPUTED E2 FUNCTION (DEFINED IN REF. (4)). -! CALCULATIONS ARE DONE IN THE FREQUENCY RANGE: -! 1) 0-560,1200-2200 CM-1 FOR Q(APPROX) -! MOTIVATION FOR THESE CALCULATIONS IS IN REFERENCES (1) AND (4). -! INPUTS: (MODULE BLOCKS) -! T1,T2,T4, TABCOM -! AVEPHI TFCOM -! FXOE2,DTE2,KLEN ARGUMENT LIST -! OUTPUTS: -! EMISS,EMISSB TFCOM -! -! CALLED BY : FST88 -! CALLS : -! -! -c$$$ USE MACHINE , ONLY : kind_rad - USE HCON - implicit none -! - integer L, LP1, IMAX, KLEN - real (kind=kind_rad) EMISSB(IMAX,LP1), EMISS(IMAX,LP1) - &, AVEPHI(IMAX,LP1) - &, DT(IMAX,LP1), FYO(IMAX,LP1) - &, DU(IMAX,LP1) - integer IVAL(IMAX,LP1) -!---VARIABLES IN THE ARGUMENT LIST - real (kind=kind_rad) T1(5040), T2(5040), T4(5040) - &, FXOE2(IMAX,LP1), DTE2(IMAX,LP1) -! - real (kind=kind_rad) tmp3 - integer lp2,i, k, k1, item -! -!---FIRST WE OBTAIN THE EMISSIVITIES AS A FUNCTION OF TEMPERATURE -! (INDEX FXO) AND WATER AMOUNT (INDEX FYO). THIS PART OF THE CODE -! THUS GENERATES THE E2 FUNCTION. -! -!---CALCULATIONS FOR VARYING KP (FROM KP=K+1 TO LP1, INCLUDING SPECIAL -! CASE: RESULTS ARE IN EMISS - - LP2 = L + 2 - DO K=1,LP2-KLEN - K1 = K + KLEN - 1 - DO I=1,IMAX - TMP3 = LOG10(AVEPHI(I,K1)) + H16E1 - FYO(I,K) = AINT(TMP3*TEN) - DU(I,K) = TMP3 - HP1*FYO(I,K) - FYO(I,K) = H28E1 * FYO(I,K) - ITEM = FYO(I,K) + FXOE2(I,K1) - EMISS(I,K1) = T1(ITEM) + DU(I,K) * T2(ITEM) - & + DTE2(I,K1) * T4(ITEM) - ENDDO - ENDDO - -!---THE SPECIAL CASE EMISS(I,L) (LAYER KP) IS OBTAINED NOW -! BY AVERAGING THE VALUES FOR L AND LP1: - - DO I=1,IMAX - EMISS(I,L) = HAF*(EMISS(I,L) + EMISS(I,LP1)) - ENDDO - -!---NOTE THAT EMISS(I,LP1) IS NOT USEFUL AFTER THIS POINT. -! -!---CALCULATIONS FOR KP=KLEN AND VARYING K; RESULTS ARE IN EMISSB. -! IN THIS CASE, THE TEMPERATURE INDEX IS UNCHANGED, ALWAYS BEING -! FXO(I,KLEN-1); THE WATER INDEX CHANGES, BUT IS SYMMETRICAL WITH -! THAT FOR THE VARYING KP CASE.NOTE THAT THE SPECIAL CASE IS NOT -! INVOLVED HERE. -! (FIXED LEVEL) K VARIES FROM (KLEN+1) TO LP1; RESULTS ARE IN -! EMISSB(I,(KLEN) TO L) -! - DO K=1,LP1-KLEN - DO I=1,IMAX - DT(I,K) = DTE2(I,KLEN-1) - IVAL(I,K) = FYO(I,K) + FXOE2(I,KLEN-1) - ENDDO - ENDDO -! - DO K=1,LP1-KLEN - K1 = K + KLEN - 1 - DO I=1,IMAX - ITEM = IVAL(I,K) - EMISSB(I,K1) = T1(ITEM) + DU(I,K) * T2(ITEM) - & + DT(I,K) * T4(ITEM) - ENDDO - ENDDO -! - RETURN - END - SUBROUTINE E2SPEC(EMISS,AVEPHI,FXOSP,DTSP - &, LP1, IMAX, T1, T2, T4) -CFPP$ NOCONCUR R -! -! SUBROUTINE E2SPEC COMPUTES THE EXCHANGE TERMS IN THE FLUX EQUATION -! FOR LONGWAVE RADIATION FOR 2 TERMS USED FOR NEARBY LAYER COMPU- -! TATIONS. THE METHOD IS A TABLE LOOKUP ON A PRE- -! COMPUTED E2 FUNCTION (DEFINED IN REF. (4)). -! CALCULATIONS ARE DONE IN THE FREQUENCY RANGE: -! 0-560,1200-2200 CM-1 -! MOTIVATION FOR THESE CALCULATIONS IS IN REFERENCES (1) AND (4). -! INPUTS: (MODULE BLOCKS) -! T1,T2,T4, TABCOM -! AVEPHI TFCOM -! FXOSP,DTSP ARGUMENT LIST -! OUTPUTS: -! EMISS TFCOM -! -! CALLED BY : FST88 -! CALLS : -! -! -c$$$ USE MACHINE , ONLY : kind_rad - USE HCON - implicit none -! - integer LP1, IMAX - real (kind=kind_rad) AVEPHI(IMAX,LP1), EMISS(IMAX,LP1) -!---VARIABLES IN THE ARGUMENT LIST - real (kind=kind_rad) T1(5040), T2(5040), T4(5040) - &, FXOSP(IMAX,2), DTSP(IMAX,2) - real (kind=kind_rad) TMP3, FYO, DU - integer k, i, ival -! -!---FIRST WE OBTAIN THE EMISSIVITIES AS A FUNCTION OF TEMPERATURE -! (INDEX FXO) AND WATER AMOUNT (INDEX FYO). THIS PART OF THE CODE -! THUS GENERATES THE E2 FUNCTION. -! - DO K=1,2 - DO I=1,IMAX - TMP3 = LOG10(AVEPHI(I,K)) + H16E1 - FYO = AINT(TMP3*TEN) - DU = TMP3 - HP1*FYO - IVAL = H28E1*FYO + FXOSP(I,K) - EMISS(I,K) = T1(IVAL) + DU*T2(IVAL) + DTSP(I,K)*T4(IVAL) - ENDDO - ENDDO -! - RETURN - END -! SUBROUTINE E3V88 COMPUTES NEARBY LAYER TRANSMISSIVITIES FOR -! H2O USING A TABLE LOOKUP OF THE PRE-COMPUTED E3 FUNCTION -! ( DESCRIBED IN REF. (4)). -! INPUTS: (MODULE BLOCKS,ARGS.) -! TV,AV ARGUMENT LIST -! EM3 TABCOM -! OUTPUTS: -! EMV ARGUMENT LIST -! -! CALLED BY : FST88 -! CALLS : ALOG10H,ALOG10V -! - SUBROUTINE E3V88(EMV,TV,AV, LLP1, IMAX, EM3V) -CFPP$ NOCONCUR R -! -c$$$ USE MACHINE , ONLY : kind_rad - USE HCON - implicit none -! - integer LLP1,IMAX -! -! DIMENSIONS OF ARRAYS IN ARGUMENT LIST - real (kind=kind_rad) EMV(IMAX,LLP1), TV(IMAX,LLP1) - &, AV(IMAX,LLP1),EM3V(5040) -! - real (kind=kind_rad) FXO, TMP3, DT, FYO, DU, WW1, WW2 - integer k, i, it -! -!---THE FOLLOWING LOOP REPLACES A DOUBLE LOOP OVER I (1-IMAX) AND -! K (1-LLP1) -! - DO K=1,LLP1 - DO I=1,IMAX - FXO = AINT(TV(I,K)*HP1) - TMP3 = LOG10(AV(I,K)) + H16E1 - DT = TV(I,K) - TEN*FXO - FYO = AINT(TMP3*TEN) - DU = TMP3 - HP1*FYO -!---OBTAIN INDEX FOR TABLE LOOKUP; THIS VALUE WILL HAVE TO BE -! DECREMENTED BY 9 TO ACCOUNT FOR TABLE TEMPS STARTING AT 100K. - IT = FXO + FYO*H28E1 - WW1 = TEN - DT - WW2 = HP1 - DU - EMV(I,K) = WW2 * (WW1*EM3V(IT-9) + DT*EM3V(IT-8)) - & + DU * (WW1*EM3V(IT+19) + DT*EM3V(IT+20)) - ENDDO - ENDDO -! - RETURN - END -! ***************************************************************** -! SUBROUTINE FST88 IS THE MAIN COMPUTATION MODULE OF THE -! LONG-WAVE RADIATION CODE. IN IT ALL "EMISSIVITY" CALCULATIONS, -! INCLUDING CALLS TO TABLE LOOKUP SUBROUTINES. ALSO,AFTER CALLING -! SUBROUTINE "SPA88", FINAL COMBINED HEATING RATES AND GROUND -! FLUX ARE OBTAINED. -! ***************************************************************** -! INPUTS: -! BETINW,BETAWD,AB15WD BDWIDE -! BETAD,BO3RND,AO3RND BANDTA -! CLDFAC CLDCOM -! QH2O,P,DELP2,DELP,T,VAR1,VAR2, KDACOM -! VAR3,VAR4,CNTVAL KDACOM -! TOTVO2,TOTO3,TOTPHI,EMPL,EMX1 KDACOM -! TPHIO3,EMX2 KDACOM -! TEMP,PRESS RADISW -! NCLDS,KTOP,KBTM,CAMT RADISW -! IND,INDX2,KMAXV,SOURCE,DSRCE TABCOM -! SKC1R,SKC3R,KMAXVM,NREP1,NREP2 TABCOM -! NST1,NST2,NRP1,NRP2 TABCOM -! CO2NBL,CO21 TFCOM -! CO2SP1,CO2SP2 TFCOM -! OUTPUTS: -! HEATRA,GRNFLX,TOPFLX LWOUT -! -! CALLED BY : RADMN OR MAIN PGM -! CALLS : CLO88,E1E288,E3V88,SPA88,NLTE -! -! PASSED VARIABLES: -! IN E3V88: -! EMD = E3 FUNCTION FOR H2O LINES (0-560,1200-2200 CM-1) -! COMPUTED IN E3V88 -! TPL = TEMPERATURE INPUT FOR E3 CALCULATION IN E3V88 -! EMPL = H2O AMOUNT,INPUT FOR E3 CALCULATION IN E3V88 -! (COMPUTED IN LWR88; STORED IN KDACOM.H) -! IN E1E288: -! E1CTS1 = E1 FUNCTION FOR THE (I+1)TH LEVEL USING THE -! TEMPERATURE OF THE ITH DATA LEVEL,COMPUTED OVER -! THE FREQUENCY RANGE 0-560,1200-2200 CM-1. (E1CTS1- -! E1CTW1) IS USED IN OBTAINING THE FLUX AT THE TOP -! IN THE 0-160,1200-2200 CM-1 RANGE (FLX1E1). -! E1CTS2 = E1 FUNCTION FOR THE ITH LEVEL, USING THE TEMP. OF -! THE ITH DATA LEVEL,COMPUTED OVER THE FREQUENCY RANGE -! 0-560,1200-2200 CM-1. (E1CTS2-E1CTW2) IS ALSO USED -! IN OBTAINING THE FLUX AT THE TOP IN THE 0-160,. -! 1200-2200 CM-1 RANGE. -! E1FLX = E1 FCTN. FOR THE ITH LEVEL,USING THE TEMPERATURE AT -! THE TOP OF THE ATMOSPHERE. COMPUTED OVER THE FREQ. -! RANGE 0-560,1200-2200 CM-1. USED FOR Q(APPROX) TERM. -! (IN MODULE BLOCK TFCOM) -! E1CTW1 = LIKE E1CTS1,BUT COMPUTED OVER THE 160-560 CM-1 RANGE -! AND USED FOR Q(APPROX,CTS) CALCULATION -! E1CTW2 = LIKE E1CTS2,BUT COMPUTED OVER THE 160-560 CM-1 RANGE -! AND USED FOR Q(APPROX,CTS) CALCULATION -! FXO = TEMPERATURE INDEX USED FOR E1 FUNCTION AND ALSO -! USED FOR SOURCE FUNCTION CALC. IN FST88. -! DT = TEMP. DIFF.BETWEEN MODEL TEMPS. AND TEMPS. AT -! TABULAR VALUES OF E1 AND SOURCE FCTNS. USED IN -! FST88 AND IN E1 FUNCTION CALC. -! FXOE2 = TEMPERATURE INDEX USED FOR E2 FUNCTION -! DTE2 = TEMP. DIFF. BETWEEN MODEL TEMP. AND TEMPS. AT -! TABULAR VALUES OF E2 FUNCTION. - SUBROUTINE FST88(HEATRA,GRNFLX,TOPFLX, - & QH2O,PRESS,P,DELP,DELP2,TEMP,T, - & CLDFAC, -! & CLDFAC,NCLDS,KTOP,KBTM,CAMT, - & CO21,CO2NBL,CO2SP1,CO2SP2, - & VAR1,VAR2,VAR3,VAR4,CNTVAL, - & TOTO3,TPHIO3,TOTPHI,TOTVO2, - & EMX1,EMX2,EMPL - &, L, LP1, LP1V, LLP1, IMAX - &, SOURCE,DSRCE) -! -CFPP$ NOCONCUR R -! -c$$$ USE MACHINE , ONLY : kind_rad - USE HCON - USE RNDDTA - implicit none -! - integer L, LP1, LP1V, LLP1, IMAX -! - real (kind=kind_rad) SOURCE(28,NBLY), DSRCE(28,NBLY) -! - real (kind=kind_rad) QH2O(IMAX,LP1), PRESS(IMAX,LP1) - &, P(IMAX,LP1), DELP(IMAX,L), DELP2(IMAX,L) - &, TEMP(IMAX,LP1), T(IMAX,LP1) - &, CLDFAC(IMAX,LP1,LP1) - &, CO21(IMAX,LP1,LP1), CO2NBL(IMAX,L) - &, CO2SP1(IMAX,LP1), CO2SP2(IMAX,LP1) - &, VAR1(IMAX,L), VAR2(IMAX,L) - &, VAR3(IMAX,L), VAR4(IMAX,L) - &, CNTVAL(IMAX,LP1), TOPFLX(IMAX) - &, HEATRA(IMAX,L), GRNFLX(IMAX) -! - real (kind=kind_rad) GXCTS(IMAX), FLX1E1(IMAX) - &, AVEPHI(IMAX,LP1), EMISS(IMAX,LP1) - &, EMISSB(IMAX,LP1) - &, TOTO3(IMAX,LP1), TPHIO3(IMAX,LP1) - &, TOTPHI(IMAX,LP1), TOTVO2(IMAX,LP1) - &, EMX1(IMAX), EMX2(IMAX) - &, EMPL(IMAX,LLP1) -! - real (kind=kind_rad) EXCTS(IMAX,L), CTSO3(IMAX,L), CTS(IMAX,L) - &, E1FLX(IMAX,LP1), CO2SP(IMAX,LP1) - &, TO3SPC(IMAX,L), TO3SP(IMAX,LP1) - real (kind=kind_rad) OSS(IMAX,LP1), CSS(IMAX,LP1) - &, SS1(IMAX,LP1), SS2(IMAX,LP1) - &, TC(IMAX,LP1), DTC(IMAX,LP1) - &, SORC(IMAX,LP1,NBLY), CSOUR(IMAX,LP1) -!CC - real (kind=kind_rad) AVVO2(IMAX,LP1), OVER1D(IMAX,LP1) - &, TO31D(IMAX,LP1), CONT1D(IMAX,LP1) - &, AVMO3(IMAX,LP1), AVPHO3(IMAX,LP1) - &, C(IMAX,LLP1), C2(IMAX,LLP1) - &, EMSPEC(IMAX,2) -! -!---DIMENSION OF VARIABLES EQUIVALENCED TO THOSE IN VTEMP--- - real (kind=kind_rad) VTMP3(IMAX,LP1) - &, ALP(IMAX,LLP1) ! TPL used in place of CSUB - &, DELPR1(IMAX,LP1), DELPR2(IMAX,LP1) - &, EMISDG(IMAX,LP1), CONTDG(IMAX,LP1) - &, TO3DG(IMAX,LP1), FLXNET(IMAX,LP1) - &, VSUM1(IMAX,LP1) -! -!---DIMENSION OF VARIABLES PASSED TO OTHER SUBROUTINES--- -! (AND NOT FOUND IN MODULE BLOCKS) - real (kind=kind_rad) E1CTS1(IMAX,LP1), E1CTS2(IMAX,L) - &, E1CTW1(IMAX,LP1), E1CTW2(IMAX,L) - &, TPL(IMAX,LLP1) ! TPL used as EMD as well -! IT IS POSSIBLE TO EQUIVALENCE EMD,TPL TO THE ABOVE VARIABLES, -! AS THEY GET CALLED AT DIFFERENT TIMES - real (kind=kind_rad) FXO(IMAX,LP1), DT(IMAX,LP1) - &, FXOE2(IMAX,LP1), DTE2(IMAX,LP1) - &, FXOSP(IMAX,2), DTSP(IMAX,2) -! -! DIMENSION OF LOCAL VARIABLES - real (kind=kind_rad) RLOG(IMAX,L), FLX(IMAX,LP1) - &, TOTEVV(IMAX,LP1), CNTTAU(IMAX,LP1) -! - real (kind=kind_rad) vtmp, fac1, tem, tmp3, du, fyo, dt3 - &, ww1, ww2, fxo3, csub2 - integer lm1, ll, llm1, llm2, i, k, item, k1, kk, klen - &, kk1, kkk, kp, ival, it -cc -cc-------------------------------------------------------------------- -cc - real(kind=kind_rad) cons_1pdm25 !constant -cc - cons_1pdm25 = 1.d-25 !constant -cc -cc-------------------------------------------------------------------- -cc -! -! FIRST SECTION IS TABLE LOOKUP FOR SOURCE FUNCTION AND -! DERIVATIVE (B AND DB/DT).ALSO,THE NLTE CO2 SOURCE FUNCTION -! IS OBTAINED -! -!---IN CALCS. BELOW, DECREMENTING THE INDEX BY 9 -! ACCOUNTS FOR THE TABLES BEGINNING AT T=100K. -! AT T=100K. -! - LM1 = L - 1 - LL = LLP1 - 1 - LLM1 = LL - 1 - LLM2 = LL - 2 -! -! ******* E1 SOURCE ******* - DO K=1,LP1 - DO I=1,IMAX - VTMP = AINT(TEMP(I,K)*HP1) - FXO(I,K) = VTMP - 9.0 - DT(I,K) = TEMP(I,K) - TEN*VTMP -! - ITEM = FXO(I,K) -! -! SOURCE FUNCTION FOR 14 COMBINED BANDS -! BAND 9 - (560-670 CM-1) BAND 10 - (670-800 CM-1) -! BAND 11 - (800-900 CM-1) BAND 12 - (900-990 CM-1) -! BAND 13 - (990-1070 CM-1) BAND 14 - (1070-1200 CM-1) -! - SORC(I,K,1) = SOURCE(ITEM,1) + DT(I,K)*DSRCE(ITEM,1) ! Band 1 - SORC(I,K,2) = SOURCE(ITEM,2) + DT(I,K)*DSRCE(ITEM,2) ! Band 2 - SORC(I,K,3) = SOURCE(ITEM,3) + DT(I,K)*DSRCE(ITEM,3) ! Band 3 - SORC(I,K,4) = SOURCE(ITEM,4) + DT(I,K)*DSRCE(ITEM,4) ! Band 4 - SORC(I,K,5) = SOURCE(ITEM,5) + DT(I,K)*DSRCE(ITEM,5) ! Band 5 - SORC(I,K,6) = SOURCE(ITEM,6) + DT(I,K)*DSRCE(ITEM,6) ! Band 6 - SORC(I,K,7) = SOURCE(ITEM,7) + DT(I,K)*DSRCE(ITEM,7) ! Band 7 - SORC(I,K,8) = SOURCE(ITEM,8) + DT(I,K)*DSRCE(ITEM,8) ! Band 8 - SORC(I,K,9) = SOURCE(ITEM,9) + DT(I,K)*DSRCE(ITEM,9) ! Band 9 - SORC(I,K,10) = SOURCE(ITEM,10) + DT(I,K)*DSRCE(ITEM,10) ! Band 10 - SORC(I,K,11) = SOURCE(ITEM,11) + DT(I,K)*DSRCE(ITEM,11) ! Band 11 - SORC(I,K,12) = SOURCE(ITEM,12) + DT(I,K)*DSRCE(ITEM,12) ! Band 12 - SORC(I,K,13) = SOURCE(ITEM,13) + DT(I,K)*DSRCE(ITEM,13) ! Band 13 - SORC(I,K,14) = SOURCE(ITEM,14) + DT(I,K)*DSRCE(ITEM,14) ! Band 14 - ENDDO - ENDDO -! -!---TEMP. INDICES FOR E2 (KP=1 LAYER NOT USED IN FLUX CALCULATIONS) - DO K=1,L - DO I=1,IMAX - VTMP = AINT(T(I,K+1)*HP1) - FXOE2(I,K) = VTMP - 9.0 - DTE2(I,K) = T(I,K+1) - TEN*VTMP - ENDDO - ENDDO -!---SPECIAL CASE TO HANDLE KP=LP1 LAYER AND SPECIAL E2 CALCS. - DO I=1,IMAX - FXOE2(I,LP1) = FXO(I,L) - DTE2(I,LP1) = DT(I,L) - FXOSP(I,1) = FXOE2(I,LM1) - FXOSP(I,2) = FXO(I,LM1) - DTSP(I,1) = DTE2(I,LM1) - DTSP(I,2) = DT(I,LM1) - ENDDO -! -! THE FOLLOWING SUBROUTINE OBTAINS NLTE SOURCE FUNCTION FOR CO2 -! -! CALL NLTE -! -!---OBTAIN SPECIAL SOURCE FUNCTIONS FOR THE 15 UM BAND (CSOUR) -! AND THE WINDOW REGION (SS1). ALSO -!---COMPUTE TEMP**4 (TC) AND VERTICAL TEMPERATURE DIFFERENCES -! (OSS,CSS,SS2,DTC). ALL THESE WILL BE USED LATER IN FLUX COMPUTATIONS. -! - DO K=1,LP1 - DO I=1,IMAX - SS1(I,K) = SORC(I,K,11) + SORC(I,K,12) + SORC(I,K,14) - CSOUR(I,K) = SORC(I,K,9) + SORC(I,K,10) - VTMP = TEMP(I,K) * TEMP(I,K) - TC(I,K) = VTMP * VTMP - ENDDO - ENDDO - DO K=1,L - K1 = K + 1 - DO I=1,IMAX - OSS(I,K1) = SORC(I,K1,13) - SORC(I,K,13) - CSS(I,K1) = CSOUR(I,K1) - CSOUR(I,K) - DTC(I,K1) = TC(I,K1) - TC(I,K) - SS2(I,K1) = SS1(I,K1) - SS1(I,K) - ENDDO - ENDDO -! -! -!---THE FOLLOWIMG IS A DRASTIC REWRITE OF THE RADIATION CODE TO -! (LARGELY) ELIMINATE THREE-DIMENSIONAL ARRAYS. THE CODE WORKS -! ON THE FOLLOWING PRINCIPLES: -! -! LET K = FIXED FLUX LEVEL, KP = VARYING FLUX LEVEL -! THEN FLUX(K)=SUM OVER KP : (DELTAB(KP)*TAU(KP,K)) -! OVER ALL KP'S, FROM 1 TO LP1. -! -! WE CAN BREAK DOWN THE CALCULATIONS FOR ALL K'S AS FOLLOWS: -! -! FOR ALL K'S K=1 TO LP1: -! FLUX(K)=SUM OVER KP : (DELTAB(KP)*TAU(KP,K)) (1) -! OVER ALL KP'S, FROM K+1 TO LP1 -! AND -! FOR KP FROM K+1 TO LP1: -! FLUX(KP) = DELTAB(K)*TAU(K,KP) (2) -! -! NOW IF TAU(K,KP)=TAU(KP,K) (SYMMETRICAL ARRAYS) -! WE CAN COMPUTE A 1-DIMENSIONAL ARRAY TAU1D(KP) FROM -! K+1 TO LP1, EACH TIME K IS INCREMENTED. -! EQUATIONS (1) AND (2) THEN BECOME: -! -! TAU1D(KP) = (VALUES FOR TAU(KP,K) AT THE PARTICULAR K) -! FLUX(K) = SUM OVER KP : (DELTAB(KP)*TAU1D(KP)) (3) -! FLUX(KP) = DELTAB(K)*TAU1D(KP) (4) -! -! THE TERMS FOR TAU (K,K) AND OTHER SPECIAL TERMS (FOR -! NEARBY LAYERS) MUST, OF COURSE, BE HANDLED SEPARATELY, AND -! WITH CARE. -! -! COMPUTE "UPPER TRIANGLE" TRANSMISSION FUNCTIONS FOR -! THE 9.6 UM BAND (TO3SP) AND THE 15 UM BAND (OVER1D). ALSO, -! THE -! STAGE 1...COMPUTE O3 ,OVER TRANSMISSION FCTNS AND AVEPHI -!---DO K=1 CALCULATION (FROM FLUX LAYER KK TO THE TOP) SEPARATELY -! AS VECTORIZATION IS IMPROVED,AND OZONE CTS TRANSMISSIVITY -! MAY BE EXTRACTED HERE. -! - DO K=1,L - DO I=1,IMAX - AVEPHI(I,K) = TOTPHI(I,K+1) - ENDDO - ENDDO -! -!---IN ORDER TO PROPERLY EVALUATE EMISS INTEGRATED OVER THE (LP1) -! LAYER, A SPECIAL EVALUATION OF EMISS IS DONE. THIS REQUIRES -! A SPECIAL COMPUTATION OF AVEPHI, AND IT IS STORED IN THE -! (OTHERWISE VACANT) LP1'TH POSITION -! - DO I=1,IMAX - AVEPHI(I,LP1) = AVEPHI(I,LM1) + EMX1(I) - ENDDO -! -! COMPUTE FLUXES FOR K=1 -! - CALL E1E290(E1CTS1,E1CTS2,E1FLX,E1CTW1,E1CTW2,EMISS, - & FXO,DT,FXOE2,DTE2,AVEPHI - &, L, LP1, IMAX, EM1V, EM1VW, T1, T2, T4) -! - DO K=1,L - K1 = K + 1 - DO I=1,IMAX - FAC1 = BO3RND(2)*TPHIO3(I,K1)/TOTO3(I,K1) - TO3SPC(I,K) = HAF*(FAC1* - & (SQRT(ONE+(FOUR*AO3RND(2)*TOTO3(I,K1))/FAC1)-ONE)) -! -! FOR K=1, TO3SP IS USED INSTEAD OF TO31D (THEY ARE EQUAL IN THIS -! CASE); TO3SP IS PASSED TO SPA90, WHILE TO31D IS A WORK-ARRAY. -! - TO3SP(I,K) = EXP(HM1EZ*(TO3SPC(I,K)+SKO3R*TOTVO2(I,K1))) - OVER1D(I,K) = EXP(HM1EZ*(SQRT(AB15WD*TOTPHI(I,K1))+ - & SKC1R*TOTVO2(I,K1))) -! -!---BECAUSE ALL CONTINUUM TRANSMISSIVITIES ARE OBTAINED FROM THE -! 2-D QUANTITY CNTTAU (AND ITS RECIPROCAL TOTEVV) WE STORE BOTH -! OF THESE HERE. FOR K=1, CONT1D EQUALS CNTTAU -! - CNTTAU(I,K) = EXP(HM1EZ*TOTVO2(I,K1)) - TOTEVV(I,K) = 1. / max(CNTTAU(I,K),cons_1pdm25) !constant -! TOTEVV(I,K) = 1. / CNTTAU(I,K) ! commenteed by Moorthi 03/08/2000 - ENDDO - ENDDO - DO K=1,L - DO I=1,IMAX - CO2SP(I,K+1) = OVER1D(I,K)*CO21(I,1,K+1) - ENDDO - ENDDO - DO K=1,L - K1 = K + 1 - DO I=1,IMAX - CO21(I,K1,1) = CO21(I,K1,1)*OVER1D(I,K) - ENDDO - ENDDO -!---RLOG IS THE NBL AMOUNT FOR THE 15 UM BAND CALCULATION - DO I=1,IMAX - RLOG(I,1) = OVER1D(I,1)*CO2NBL(I,1) - ENDDO -!---THE TERMS WHEN KP=1 FOR ALL K ARE THE PHOTON EXCHANGE WITH -! THE TOP OF THE ATMOSPHERE, AND ARE OBTAINED DIFFERENTLY THAN -! THE OTHER CALCULATIONS - DO K=2,LP1 - DO I=1,IMAX - TEM = TC(I,1)*E1FLX(I,K) + SS1(I,1)*CNTTAU(I,K-1) - & + SORC(I,1,13)*TO3SP(I,K-1) + CSOUR(I,1)*CO2SP(I,K) - FLX(I,K) = TEM * CLDFAC(I,1,K) - ENDDO - ENDDO - - DO I=1,IMAX - FLX(I,1) = TC(I,1)*E1FLX(I,1) + SS1(I,1) + SORC(I,1,13) - & + CSOUR(I,1) - ENDDO -!---THE KP TERMS FOR K=1... - DO KP=2,LP1 - DO I=1,IMAX - TEM = OSS(I,KP)*TO3SP(I,KP-1) + SS2(I,KP)*CNTTAU(I,KP-1) - & + CSS(I,KP)*CO21(I,KP,1) + DTC(I,KP)*EMISS(I,KP-1) - FLX(I,1) = FLX(I,1) + TEM * CLDFAC(I,KP,1) - ENDDO - ENDDO -! -! SUBROUTINE SPA88 IS CALLED TO OBTAIN EXACT CTS FOR WATER -! CO2 AND O3, AND APPROXIMATE CTS CO2 AND O3 CALCULATIONS. -! - CALL SPA88(EXCTS,CTSO3,GXCTS,SORC,CSOUR, - & CLDFAC,TEMP,PRESS,VAR1,VAR2, - & P,DELP,DELP2,TOTVO2,TO3SP,TO3SPC, - & CO2SP1,CO2SP2,CO2SP - &, L, LP1, IMAX) -! -! THIS SECTION COMPUTES THE EMISSIVITY CTS HEATING RATES FOR 2 -! EMISSIVITY BANDS: THE 0-160,1200-2200 CM-1 BAND AND THE 800- -! 990,1070-1200 CM-1 BAND. THE REMAINING CTS COMTRIBUTIONS ARE -! CONTAINED IN CTSO3, COMPUTED IN SPA88. -! - DO I=1,IMAX - VTMP3(I,1) = 1. - ENDDO - DO K=1,L - DO I=1,IMAX - VTMP3(I,K+1) = CNTTAU(I,K)*CLDFAC(I,K+1,1) - ENDDO - ENDDO - DO K=1,L - DO I=1,IMAX - CTS(I,K) = TC(I,K) * (E1CTW2(I,K)*CLDFAC(I,K+1,1) - & - E1CTW1(I,K)*CLDFAC(I,K,1)) + - & SS1(I,K)*(VTMP3(I,K+1)-VTMP3(I,K)) -! - ENDDO - ENDDO -! - DO K=1,L - DO I=1,IMAX - VTMP3(I,K)=TC(I,K)*(CLDFAC(I,K,1)*(E1CTS1(I,K)-E1CTW1(I,K)) - - & CLDFAC(I,K+1,1)*(E1CTS2(I,K)-E1CTW2(I,K))) -! - ENDDO - ENDDO - DO I=1,IMAX - TEM = TC(I,LP1) * (E1CTS1(I,LP1)-E1CTW1(I,LP1)) - FLX1E1(I) = TEM * CLDFAC(I,LP1,1) - ENDDO - DO K=1,L - DO I=1,IMAX - FLX1E1(I) = FLX1E1(I) + VTMP3(I,K) - ENDDO - ENDDO -! -!---NOW REPEAT FLUX CALCULATIONS FOR THE K=2..LM1 CASES. -! CALCULATIONS FOR FLUX LEVEL L AND LP1 ARE DONE SEPARATELY, AS ALL -! EMISSIVITY AND CO2 CALCULATIONS ARE SPECIAL CASES OR NEARBY LAYERS. -! - DO K=2,LM1 - KLEN = K - DO KK=1,LP1-K - DO I=1,IMAX - AVEPHI(I,KK+K-1) = TOTPHI(I,KK+K) - TOTPHI(I,K) - ENDDO - ENDDO - DO I=1,IMAX - AVEPHI(I,LP1) = AVEPHI(I,LM1) + EMX1(I) - ENDDO -! -!---COMPUTE EMISSIVITY FLUXES (E2) FOR THIS CASE. NOTE THAT -! WE HAVE OMITTED THE NEARBY LATER CASE (EMISS(I,K,K)) AS WELL -! AS ALL CASES WITH K=L OR LP1. BUT THESE CASES HAVE ALWAYS -! BEEN HANDLED AS SPECIAL CASES, SO WE MAY AS WELL COMPUTE -! THEIR FLUXES SEPARASTELY. -! - CALL E290(EMISSB,EMISS,AVEPHI,KLEN,FXOE2,DTE2 - &, L, LP1, IMAX, T1, T2, T4) -! - DO KK=1,LP1-K - KKK = KK + K - KK1 = KKK - 1 - DO I=1,IMAX - AVMO3(I,KK1) = TOTO3(I,KKK) - TOTO3(I,K) - AVPHO3(I,KK1) = TPHIO3(I,KKK) - TPHIO3(I,K) - AVVO2(I,KK1) = TOTVO2(I,KKK) - TOTVO2(I,K) - CONT1D(I,KK1) = CNTTAU(I,KK1) * TOTEVV(I,K-1) - ENDDO - ENDDO -! -CDIR$ IVDEP - DO KK=1,LP1-K - KKK = KK + K - KK1 = KKK - 1 - DO I=1,IMAX - FAC1 = BO3RND(2)*AVPHO3(I,KK1)/AVMO3(I,KK1) - VTMP = HAF*(FAC1*(SQRT(ONE+(FOUR*AO3RND(2)*AVMO3(I,KK1)) - & /FAC1)-ONE)) - TO31D(I,KK1) = EXP(HM1EZ*(VTMP+SKO3R*AVVO2(I,KK1))) - OVER1D(I,KK1) = EXP(HM1EZ*(SQRT(AB15WD*AVEPHI(I,KK1))+ - & SKC1R*AVVO2(I,KK1))) - CO21(I,KKK,K) = OVER1D(I,KK1)*CO21(I,KKK,K) - ENDDO - ENDDO - DO KP=K+1,LP1 - DO I=1,IMAX - CO21(I,K,KP) = OVER1D(I,KP-1)*CO21(I,K,KP) - ENDDO - ENDDO -!---RLOG IS THE NBL AMOUNT FOR THE 15 UM BAND CALCULATION - DO I=1,IMAX - RLOG(I,K) = OVER1D(I,K)*CO2NBL(I,K) - ENDDO -!---THE KP TERMS FOR ARBIRRARY K.. - DO KP=K+1,LP1 - DO I=1,IMAX - TEM = OSS(I,KP)*TO31D(I,KP-1)+SS2(I,KP)*CONT1D(I,KP-1) - & + CSS(I,KP)*CO21(I,KP,K) +DTC(I,KP)*EMISS(I,KP-1) - FLX(I,K) = FLX(I,K) + TEM * CLDFAC(I,KP,K) - ENDDO - ENDDO - DO KP=K+1,LP1 - DO I=1,IMAX - TEM = OSS(I,K)*TO31D(I,KP-1)+SS2(I,K)*CONT1D(I,KP-1) - & + CSS(I,K)*CO21(I,K,KP) +DTC(I,K)*EMISSB(I,KP-1) - FLX(I,KP) = FLX(I,KP) + TEM * CLDFAC(I,K,KP) - ENDDO - ENDDO - ENDDO -! -! NOW DO K=L CASE. SINCE THE KP LOOP IS LENGTH 1, MANY SIMPLIFI- -! CATIONS OCCUR. ALSO, THE CO2 QUANTITIES (AS WELL AS THE EMISS -! QUANTITIES) ARE COMPUTED IN THE NBL SEDCTION; THEREFORE, WE WANT -! ONLY OVER,TO3 AND CONT1D (OVER(I,L),TO31D(I,L) AND CONT1D(I,L) -! ACCORDING TO THE NOTATION. THUS NO CALL IS MADE TO THE E290 -! SUBROUTINE. -! THE THIRD SECTION CALCULATES BOUNDARY LAYER AND NEARBY LAYER -! CORRECTIONS TO THE TRANSMISSION FUNCTIONS OBTAINED ABOVE. METHODS -! ARE GIVEN IN REF. (4). -! THE FOLLOWING RATIOS ARE USED IN VARIOUS NBL CALCULATIONS: -! -! THE REMAINING CALCULATIONS ARE FOR : -! 1) THE (K,K) TERMS, K=2,LM1; -! 2) THE (L,L) TERM -! 3) THE (L,LP1) TERM -! 4) THE (LP1,L) TERM -! 5) THE (LP1,LP1) TERM. -! EACH IS UNIQUELY HANDLED; DIFFERENT FLUX TERMS ARE COMPUTED -! DIFFERENTLY -! -! -! FOURTH SECTION OBTAINS WATER TRANSMISSION FUNCTIONS -! USED IN Q(APPROX) CALCULATIONS AND ALSO MAKES NBL CORRECTIONS: -! 1) EMISS (I,J) IS THE TRANSMISSION FUNCTION MATRIX OBTAINED -! BY CALLING SUBROUTINE E1E288; -! 2) "NEARBY LAYER" CORRECTIONS (EMISS(I,I)) ARE OBTAINED -! USING SUBROUTINE E3V88; -! 3) SPECIAL VALUES AT THE SURFACE (EMISS(L,LP1),EMISS(LP1,L), -! EMISS(LP1,LP1)) ARE CALCULATED. -! -! -! OBTAIN ARGUMENTS FOR E1E288 AND E3V88: -! - DO I=1,IMAX - TPL(I,1) = TEMP(I,L) - TPL(I,LP1) = HAF*(T(I,LP1) + TEMP(I,L)) - TPL(I,LLP1) = HAF*(T(I,L) + TEMP(I,L)) -! -!---E2 FUNCTIONS ARE REQUIRED IN THE NBL CALCULATIONS FOR 2 CASES, -! DENOTED (IN OLD CODE) AS (L,LP1) AND (LP1,LP1) - AVEPHI(I,1) = VAR2(I,L) - AVEPHI(I,2) = VAR2(I,L) + EMPL(I,L) - ENDDO - DO K=2,L - DO I=1,IMAX - TPL(I,K) = T(I,K) - TPL(I,K+L) = T(I,K) - ENDDO - ENDDO -! -! Inlining of E2SPEC -! -! SUBROUTINE E2SPEC COMPUTES THE EXCHANGE TERMS IN THE FLUX EQUATION -! FOR LONGWAVE RADIATION FOR 2 TERMS USED FOR NEARBY LAYER COMPU- -! TATIONS. THE METHOD IS A TABLE LOOKUP ON A PRE- -! COMPUTED E2 FUNCTION (DEFINED IN REF. (4)). -! - DO K=1,2 - DO I=1,IMAX - TMP3 = LOG10(AVEPHI(I,K)) + H16E1 - FYO = AINT(TMP3*TEN) - DU = TMP3 - HP1*FYO - IVAL = H28E1*FYO + FXOSP(I,K) - EMISS(I,K) = T1(IVAL) + DU*T2(IVAL) + DTSP(I,K)*T4(IVAL) - ENDDO - ENDDO -! -! CALL E3V88 FOR NBL H2O TRANSMISSIVITIES -! SUBROUTINE E3V88 COMPUTES NEARBY LAYER TRANSMISSIVITIES FOR -! H2O USING A TABLE LOOKUP OF THE PRE-COMPUTED E3 FUNCTION -! ( DESCRIBED IN REF. (4)). -! -! Inlining of E3V88 -! - DO K=1,LLP1 - DO I=1,IMAX - FXO3 = AINT(TPL(I,K)*HP1) - TMP3 = LOG10(EMPL(I,K)) + H16E1 - DT3 = TPL(I,K) - TEN*FXO3 - FYO = AINT(TMP3*TEN) - DU = TMP3 - HP1*FYO -!---OBTAIN INDEX FOR TABLE LOOKUP; THIS VALUE WILL HAVE TO BE -! DECREMENTED BY 9 TO ACCOUNT FOR TABLE TEMPS STARTING AT 100K. - IT = FXO3 + FYO*H28E1 - WW1 = TEN - DT3 - WW2 = HP1 - DU - TPL(I,K) = WW2 * (WW1*EM3V(IT-9) + DT3*EM3V(IT-8))+ - & DU * (WW1*EM3V(IT+19) + DT3*EM3V(IT+20)) - ENDDO - ENDDO -! -! COMPUTE NEARBY LAYER AND SPECIAL-CASE TRANSMISSIVITIES FOR EMISS -! USING METHODS FOR H2O GIVEN IN REF. (4) -CDIR$ IVDEP - DO K=2,L - DO I=1,IMAX - EMISDG(I,K) = TPL(I,K+L) + TPL(I,K) - ENDDO - ENDDO -! -! NOTE THAT EMX1/2 (PRESSURE SCALED PATHS) ARE NOW COMPUTED IN -! LWR88 - DO I=1,IMAX - EMSPEC(I,1) = (TPL(I,1)*EMPL(I,1)-TPL(I,LP1)*EMPL(I,LP1))/ - & EMX1(I) + QUARTR*(EMISS(I,1)+EMISS(I,2)) - EMISDG(I,LP1)=TWO*TPL(I,LP1) - EMSPEC(I,2) = TWO*(TPL(I,1)*EMPL(I,1)-TPL(I,LLP1)*EMPL(I,LLP1))/ - & EMX2(I) - ENDDO - DO I=1,IMAX - FAC1 = BO3RND(2)*VAR4(I,L)/VAR3(I,L) - VTMP = HAF*(FAC1*(SQRT(ONE+(FOUR*AO3RND(2)*VAR3(I,L))/FAC1) - & -ONE)) - TO31D(I,L) = EXP(HM1EZ*(VTMP+SKO3R*CNTVAL(I,L))) - OVER1D(I,L) = EXP(HM1EZ*(SQRT(AB15WD*VAR2(I,L))+ - & SKC1R*CNTVAL(I,L))) - CONT1D(I,L) = CNTTAU(I,L)*TOTEVV(I,LM1) - RLOG(I,L) = OVER1D(I,L)*CO2NBL(I,L) - ENDDO - DO K=1,L - K1 = K + 1 - DO I=1,IMAX - RLOG(I,K) = LOG(RLOG(I,K)) - DELPR2(I,K1) = DELP(I,K)*(P(I,K1)-PRESS(I,K)) - TPL(I,K) = -SQRT(DELPR2(I,K1))*RLOG(I,K) - ENDDO - ENDDO - DO K=1,LM1 - K1 = K + 1 - DO I=1,IMAX - DELPR1(I,K1) = DELP(I,K1)*(PRESS(I,K1)-P(I,K1)) - TPL(I,K+L) = -SQRT(DELPR1(I,K1))*RLOG(I,K1) - ENDDO - ENDDO - DO I=1,IMAX - TPL(I,LL) = -RLOG(I,L) - TPL(I,LLP1) = -RLOG(I,L)*SQRT(DELP(I,L)*(P(I,LP1)-PRESS(I,LM1))) - ENDDO -! THE FIRST COMPUTATION IS FOR THE 15 UM BAND,WITH THE -! FOR THE COMBINED H2O AND CO2 TRANSMISSION FUNCTION. -! -! PERFORM NBL COMPUTATIONS FOR THE 15 UM BAND -!***THE STATEMENT FUNCTION SF IN PREV. VERSIONS IS NOW EXPLICITLY -! EVALUATED. - DO K=1,LLP1 - DO I=1,IMAX - C(I,K)=TPL(I,K)*(HMP66667+TPL(I,K)*(QUARTR+TPL(I,K)*HM6666M2)) - ENDDO - ENDDO - DO I=1,IMAX - CO21(I,LP1,LP1) = ONE+C(I,L) - CO21(I,LP1,L) = ONE+(DELP2(I,L)*C(I,LL)-(PRESS(I,L)-P(I,L))* - & C(I,LLM1))/(P(I,LP1)-PRESS(I,L)) - CO21(I,L,LP1) = ONE+((P(I,LP1)-PRESS(I,LM1))*C(I,LLP1)- - & (P(I,LP1)-PRESS(I,L))*C(I,L))/(PRESS(I,L)-PRESS(I,LM1)) - ENDDO - DO K=2,L - DO I=1,IMAX - CO21(I,K,K) = ONE + HAF*(C(I,LM1+K)+C(I,K-1)) - ENDDO - ENDDO -! -! COMPUTE NEARBY-LAYER TRANSMISSIVITIES FOR THE O3 BAND AND FOR THE -! ONE-BAND CONTINUUM BAND (TO3 AND EMISS2). THE SF2 FUNCTION IS -! USED. THE METHOD IS THE SAME AS DESCRIBED FOR CO2 IN REF (4). -CDIR$ IVDEP - DO K=1,LM1 - K1 = K + 1 - DO I=1,IMAX - TPL(I,K1) = CNTVAL(I,K1) * DELPR1(I,K1) - TPL(I,K+L) = CNTVAL(I,K) * DELPR2(I,K1) - ENDDO - ENDDO -!---THE SF2 FUNCTION IN PREV. VERSIONS IS NOW EXPLICITLY EVALUATED - DO K=1,LLM2 - DO I=1,IMAX - TEM = TPL(I,K+1) - CSUB2 = SKO3R*TEM - C(I,K+1) = TEM *(HMP5+TEM *(HP166666-TEM*H41666M2)) - C2(I,K+1) = CSUB2*(HMP5+CSUB2*(HP166666-CSUB2*H41666M2)) - ENDDO - ENDDO - DO I=1,IMAX - CONTDG(I,LP1) = 1. + C(I,LLM1) - TO3DG(I,LP1) = 1. + C2(I,LLM1) - ENDDO - DO K=2,L - DO I=1,IMAX - CONTDG(I,K) = ONE + HAF * (C(I,K) + C(I,LM1+K)) - TO3DG(I,K) = ONE + HAF * (C2(I,K) + C2(I,LM1+K)) - ENDDO - ENDDO -! -!---NOW OBTAIN FLUXES -! -! FOR THE DIAGONAL TERMS... - DO K=2,LP1 - DO I=1,IMAX - TEM = DTC(I,K)*EMISDG(I,K) + SS2(I,K)*CONTDG(I,K) - & + OSS(I,K)*TO3DG(I,K) + CSS(I,K)*CO21(I,K,K) - FLX(I,K) = FLX(I,K) + TEM * CLDFAC(I,K,K) - ENDDO - ENDDO -! FOR THE TWO OFF-DIAGONAL TERMS... - DO I=1,IMAX - TEM = CSS(I,LP1)*CO21(I,LP1,L) + DTC(I,LP1)*EMSPEC(I,2) - & + OSS(I,LP1)*TO31D(I,L) + SS2(I,LP1)*CONT1D(I,L) - FLX(I,L) = FLX(I,L) + TEM * CLDFAC(I,LP1,L) -! - TEM = CSS(I,L)*CO21(I,L,LP1) + OSS(I,L)*TO31D(I,L) - & + SS2(I,L)*CONT1D(I,L) + DTC(I,L)*EMSPEC(I,1) - FLX(I,LP1) = FLX(I,LP1) + TEM * CLDFAC(I,L,LP1) - ENDDO -! -! FINAL SECTION OBTAINS EMISSIVITY HEATING RATES, -! TOTAL HEATING RATES AND THE FLUX AT THE GROUND -! - DO K=1,L - DO I=1,IMAX -! .....CALCULATE THE TOTAL HEATING RATES - TEM = RADCON * DELP(I,K) - VSUM1(I,K) = FLX(I,K+1) - FLX(I,K) - CTS(I,K) - & - CTSO3(I,K) + EXCTS(I,K) - HEATRA(I,K) = TEM * VSUM1(I,K) -! -! print *,' heatra=',heatra(i,k),' flx=', flx(i,K+1),flx(i,k) -! &,' cts=',cts(i,K),' ctso3=',ctso3(i,k) -! &,' excts=',excts(i,k),' k=',k,' tem=',radcon*delp(i,k) -! -! - ENDDO - ENDDO -! -! .....CALCULATE THE FLUX AT EACH FLUX LEVEL USING THE FLUX AT THE -! TOP (FLX1E1+GXCTS) AND THE INTEGRAL OF THE HEATING RATES (VSUM1) - DO I=1,IMAX - TOPFLX(I) = FLX1E1(I) + GXCTS(I) - FLXNET(I,1) = TOPFLX(I) - ENDDO -!---ONLY THE SURFACE VALUE OF FLUX (GRNFLX) IS NEEDED UNLESS -! THE THICK CLOUD SECTION IS INVOKED. -! - DO K=1,L - DO I=1,IMAX - FLXNET(I,K+1) = FLXNET(I,K) + VSUM1(I,K) - ENDDO - ENDDO - DO I=1,IMAX - GRNFLX(I) = FLXNET(I,LP1) - ENDDO -! -! *************************************************************** -! * THICK CLOUD SECTION NO LONGER USED ....K.A.C. SEP96 * -! *************************************************************** -! THIS IS THE THICK CLOUD SECTION.OPTIONALLY,IF THICK CLOUD -! FLUXES ARE TO BE "CONVECTIVELY ADJUSTED",IE,DF/DP IS CONSTANT, -! FOR CLOUDY PART OF GRID POINT, THE FOLLOWING CODE IS EXECUTED. -!***FIRST,COUNT THE NUMBER OF CLOUDS ALONG THE LAT. ROW. SKIP THE -! ENTIRE THICK CLOUD COMPUTATION IF THERE ARE NO CLOUDS. -!KC ICNT=0 -!KC DO 1301 I=1,IMAX -!KC ICNT=ICNT+NCLDS(I) -!KC1301 CONTINUE -!KC IF (ICNT.EQ.0) GO TO 6999 -!---FIND THE MAXIMUM NUMBER OF CLOUDS IN THE LATITUDE ROW -!KC KCLDS=NCLDS(1) -!KC DO 2106 I=2,IMAX -!KC KCLDS=MAX(NCLDS(I),KCLDS) -!KC2106 CONTINUE -! -!***OBTAIN THE PRESSURES AND FLUXES OF THE TOP AND BOTTOM OF -! THE NC'TH CLOUD (IT IS ASSUMED THAT ALL KTOP AND KBTM'S HAVE -! BEEN DEFINED!). -!KC DO 1361 KK=1,KCLDS -!KC KMIN=LP1 -!KC KMAX=0 -!KC DO 1362 I=1,IMAX -!KC J1=KTOP(I,KK+1) -! IF (J1.EQ.1) GO TO 1362 -!KC J3=KBTM(I,KK+1) -!KC IF (J3.GT.J1) THEN -!KC PTOP(I)=P(I,J1) -!KC PBOT(I)=P(I,J3+1) -!KC FTOP(I)=FLXNET(I,J1) -!KC FBOT(I)=FLXNET(I,J3+1) -!***OBTAIN THE "FLUX DERIVATIVE" DF/DP (DELPTC) -!KC DELPTC(I)=(FTOP(I)-FBOT(I))/(PTOP(I)-PBOT(I)) -!KC KMIN=MIN(KMIN,J1) -!KC KMAX=MAX(KMAX,J3) -!KC ENDIF -!KC1362 CONTINUE -!KC KMIN=KMIN+1 -!***CALCULATE THE TOT. FLUX CHG. FROM THE TOP OF THE CLOUD, FOR -! ALL LEVELS. -!KC DO 1365 K=KMIN,KMAX -!KC DO 1363 I=1,IMAX -! IF (KTOP(I,KK+1).EQ.1) GO TO 1363 -!KC IF(KTOP(I,KK+1).LT.K .AND. K.LE.KBTM(I,KK+1)) THEN -!KC Z1(I,K)=(P(I,K)-PTOP(I))*DELPTC(I)+FTOP(I) -!ORIGINAL FLXNET(I,K)=FLXNET(I,K)*(ONE-CAMT(I,KK+1)) + -!ORIGINAL1 Z1(I,K)*CAMT(I,KK+1) -!KC FLXNET(I,K)=Z1(I,K) -!KC ENDIF -!KC1363 CONTINUE -!KC1365 CONTINUE -!KC1361 CONTINUE -!***USING THIS FLUX CHG. IN THE CLOUDY PART OF THE GRID BOX, OBTAIN -! THE NEW FLUXES, WEIGHTING THE CLEAR AND CLOUDY FLUXES:AGAIN, ONLY -! THE FLUXES IN THICK-CLOUD LEVELS WILL EVENTUALLY BE USED. -! DO 6051 K=1,LP1 -! DO 6051 I=1,IMAX -! FLXNET(I,K)=FLXNET(I,K)*(ONE-CAMT(I,NC)) + -! 1 Z1(I,K)*CAMT(I,NC) -!051 CONTINUE -!***MERGE FLXTHK INTO FLXNET FOR APPROPRIATE LEVELS. -! DO 1401 K=1,LP1 -! DO 1401 I=1,IMAX -! IF (K.GT.ITOP(I) .AND. K.LE.IBOT(I) -! 1 .AND. (NC-1).LE.NCLDS(I)) THEN -! FLXNET(I,K)=FLXTHK(I,K) -! ENDIF -!401 CONTINUE -! -!******END OF CLOUD LOOP***** -!KC6001 CONTINUE -!KC6999 CONTINUE -!***THE FINAL STEP IS TO RECOMPUTE THE HEATING RATES BASED ON THE -! REVISED FLUXES: -!KC DO 6101 K=1,L -!KC DO 6101 I=1,IMAX -!KC HEATRA(I,K)=RADCON*(FLXNET(I,K+1)-FLXNET(I,K))*DELP(I,K) -!KC6101 CONTINUE -! THE THICK CLOUD SECTION ENDS HERE. -! *************************************************************** -! * THICK CLOUD SECTION NO LONGER USED ....K.A.C. SEP96 * -! *************************************************************** - RETURN - END - SUBROUTINE HCONST -CFPP$ NOCONCUR R -! - USE HCON - implicit none -! SUBROUTINE HCONST DEFINES VARIABLES TO REPRESENT FLOATING- -! POINT CONSTANTS. -! -! COMDECK HCON CONTAINS THE MODULE BLOCK FOR THESE FLOATING- -! POINT CONSTANTS. -! -! THE NAMING CONVENTIONS FOR THE FLOATING-POINT VARIABLES ARE -! AS FOLLOWS: -! -! 1) PHYSICAL AND MATHEMATICAL CONSTANTS WILL BE GIVEN NAMES -! RELEVANT TO THEIR MEANING -! 2) OTHER CONSTANTS WILL BE GIVEN NAMES RELEVANT TO THEIR VALUE -! AND ADHERING TO THE FOLLOWING CONVENTIONS: -! A) THE FIRST LETTER WILL BE REPRESENTED WITH AN 'H' EXCEPT -! FOR I) AND J) BELOW -! B) A DECIMAL POINT WILL BE REPRESENTED WITH A 'P' -! C) THERE WILL BE NO EMBEDDED '0'(ZERO); ALL 0'S WILL -! BE REPRESENTED WITH A 'Z' -! D) A MINUS SIGN WILL BE REPRESENTED WITH AN 'M' -! E) THE DECIMAL POINT IS ASSUMED AFTER THE FIRST DIGIT FOR -! NUMBERS WITH EXPONENTS -! F) POSITIVE EXPONENTS ARE INDICATED WITH 'E';NEGATIVE -! EXPONENTS WITH 'M' -! G) DIGITS ARE TRUNCATED IN ORDER TO HAVE NO MORE THAN 8 -! CHARACTERS PER NAME -! H) NUMBERS LESS THAN 0.1 AND GREATER THAN 10. WILL BE -! REPRESENTED IN EXPONENT FORMAT (EXCEPT A FEW SPECIAL CASES) -! I) THE WHOLE NUMBERS FROM 0.0 THROUGH 10.,AND 20.,30.,40.,50., -! 60.,70.,80.,90.,100.,WILL BE SPELLED OUT -! J) GOOD JUDGMENT WILL PREVAIL OVER ALL CONVENTIONS -! -! EXAMPLES -! CONSTANT VARIABLE NAME CONVENTION -! 600. LHEATC 1) -! 680. LHEATS 1) -! 1.4142 SQROOT2 1) -! 2.0 TWO 2)-(I) -! -3.0 HM3PZ 2)-(A,B,D) -! 310. C31E2 2)-(A,E,F,H) -! -0.7239E-9 HM723M1Z 2)-(A,C,D,E,F,G,H) -! 0.0 ZERO 2)-(I) -! 0.1 HP1 2)-(A,B,H) -! 0.01 H1M2 2)-(A,E,F,H) -! 30. THIRTY 2)-(H,I) -! 0.5 HAF 2)-(J) -! 9.0 HNINE 2)-(J) -! -! -!******THE FOLLOWING ARE PHYSICAL CONSTANTS***** -! ARRANGED IN ALPHABETICAL ORDER -! - AMOLWT = 28.9644 - CSUBP = 1.00484E7 - DIFFCTR = 1.66 - G = 980.665 - GINV = 1./G - GRAVDR = 980.0 - O3DIFCTR = 1.90 - P0 = 1013250. - P0INV = 1./P0 - GP0INV = GINV*P0INV - P0XZP2 = 202649.902 - P0XZP8 = 810600.098 - P0X2 = 2.*1013250. - RADCON = 8.427 - RADCON1 = 1./8.427 - RATCO2MW = 1.519449738 - RATH2OMW = .622 - RGASK = 8.3142E7 - RGASSP = 8.31432E7 - SECPDA = 8.64E4 -! -!******THE FOLLOWING ARE MATHEMATICAL CONSTANTS******* -! ARRANGED IN DECREASING ORDER - HUNDRED = 100. - HNINETY = 90. - SIXTY = 60. - FIFTY = 50. - TEN = 10. - EIGHT = 8. - FIVE = 5. - FOUR = 4. - THREE = 3. - TWO = 2. - ONE = 1. - HAF = 0.5 - QUARTR = 0.25 - ZERO = 0. -! -!******FOLLOWING ARE POSITIVE FLOATING POINT CONSTANTS(H'S) -! ARRANGED IN DECREASING ORDER - H83E26 = 8.3E26 - H71E26 = 7.1E26 - H1E15 = 1.E15 - H1E13 = 1.E13 - H1E11 = 1.E11 - H1E8 = 1.E8 - H2E6 = 2.0E6 - H1E6 = 1.0E6 - H69766E5 = 6.97667E5 - H4E5 = 4.E5 - H165E5 = 1.65E5 - H5725E4 = 57250. - H488E4 = 48800. - H1E4 = 1.E4 - H24E3 = 2400. - H20788E3 = 2078.8 - H2075E3 = 2075. - H18E3 = 1800. - H1224E3 = 1224. - H67390E2 = 673.9057 - H5E2 = 500. - H3082E2 = 308.2 - H3E2 = 300. - H2945E2 = 294.5 - H29316E2 = 293.16 - H26E2 = 260.0 - H25E2 = 250. - H23E2 = 230. - H2E2 = 200.0 - H15E2 = 150. - H1386E2 = 138.6 - H1036E2 = 103.6 - H8121E1 = 81.21 - H35E1 = 35. - H3116E1 = 31.16 - H28E1 = 28. - H181E1 = 18.1 - H18E1 = 18. - H161E1 = 16.1 - H16E1 = 16. - H1226E1 = 12.26 - H9P94 = 9.94 - H6P08108 = 6.081081081 - H3P6 = 3.6 - H3P5 = 3.5 - H2P9 = 2.9 - H2P8 = 2.8 - H2P5 = 2.5 - H1P8 = 1.8 - H1P4387 = 1.4387 - H1P41819 = 1.418191 - H1P4 = 1.4 - H1P25892 = 1.258925411 - H1P082 = 1.082 - HP816 = 0.816 - HP805 = 0.805 - HP8 = 0.8 - HP60241 = 0.60241 - HP602409 = 0.60240964 - HP6 = 0.6 - HP526315 = 0.52631579 - HP518 = 0.518 - HP5048 = 0.5048 - HP3795 = 0.3795 - HP369 = 0.369 - HP26 = 0.26 - HP228 = 0.228 - HP219 = 0.219 - HP166666 = .166666 - HP144 = 0.144 - HP118666 = 0.118666192 - HP1=0.1 -! (NEGATIVE EXPONENTIALS BEGIN HERE) - H658M2 = 0.0658 - H625M2 = 0.0625 - H44871M2 = 4.4871E-2 - H44194M2 = .044194 - H42M2 = 0.042 - H41666M2 = 0.0416666 - H28571M2 = .02857142857 - H2118M2 = 0.02118 - H129M2 = 0.0129 - H1M2 = .01 - H559M3 = 5.59E-3 - H3M3 = 0.003 - H235M3 = 2.35E-3 - H1M3 = 1.0E-3 - H987M4 = 9.87E-4 - H323M4 = 0.000323 - H3M4 = 0.0003 - H285M4 = 2.85E-4 - H1M4 = 0.0001 - H75826M4 = 7.58265E-4 - H6938M5 = 6.938E-5 - H394M5 = 3.94E-5 - H37412M5 = 3.7412E-5 - H15M5 = 1.5E-5 - H1439M5 = 1.439E-5 - H128M5 = 1.28E-5 - H102M5 = 1.02E-5 - H1M5 = 1.0E-5 - H7M6 = 7.E-6 - H4999M6 = 4.999E-6 - H451M6 = 4.51E-6 - H25452M6 = 2.5452E-6 - H1M6 = 1.E-6 - H391M7 = 3.91E-7 - H1174M7 = 1.174E-7 - H8725M8 = 8.725E-8 - H327M8 = 3.27E-8 - H257M8 = 2.57E-8 - H1M8 = 1.0E-8 - H23M10 = 2.3E-10 - H14M10 = 1.4E-10 - H11M10 = 1.1E-10 - H1M10 = 1.E-10 - H83M11 = 8.3E-11 - H82M11 = 8.2E-11 - H8M11 = 8.E-11 - H77M11 = 7.7E-11 - H72M11 = 7.2E-11 - H53M11 = 5.3E-11 - H48M11 = 4.8E-11 - H44M11 = 4.4E-11 - H42M11 = 4.2E-11 - H37M11 = 3.7E-11 - H35M11 = 3.5E-11 - H32M11 = 3.2E-11 - H3M11 = 3.0E-11 - H28M11 = 2.8E-11 - H24M11 = 2.4E-11 - H23M11 = 2.3E-11 - H2M11 = 2.E-11 - H18M11 = 1.8E-11 - H15M11 = 1.5E-11 - H14M11 = 1.4E-11 - H114M11 = 1.14E-11 - H11M11 = 1.1E-11 - H1M11 = 1.E-11 - H96M12 = 9.6E-12 - H93M12 = 9.3E-12 - H77M12 = 7.7E-12 - H74M12 = 7.4E-12 - H65M12 = 6.5E-12 - H62M12 = 6.2E-12 - H6M12 = 6.E-12 - H45M12 = 4.5E-12 - H44M12 = 4.4E-12 - H4M12 = 4.E-12 - H38M12 = 3.8E-12 - H37M12 = 3.7E-12 - H3M12 = 3.E-12 - H29M12 = 2.9E-12 - H28M12 = 2.8E-12 - H24M12 = 2.4E-12 - H21M12 = 2.1E-12 - H16M12 = 1.6E-12 - H14M12 = 1.4E-12 - H12M12 = 1.2E-12 - H8M13 = 8.E-13 - H46M13 = 4.6E-13 - H36M13 = 3.6E-13 - H135M13 = 1.35E-13 - H12M13 = 1.2E-13 - H1M13 = 1.E-13 - H3M14 = 3.E-14 - H15M14 = 1.5E-14 - H14M14 = 1.4E-14 - H101M16 = 1.01E-16 - H1M16 = 1.0E-16 - H1M17 = 1.E-17 - H1M18 = 1.E-18 - H1M19 = 1.E-19 - H1M20 = 1.E-20 - H1M21 = 1.E-21 - H1M22 = 1.E-22 - H1M23 = 1.E-23 - H1M24 = 1.E-24 - H26M30 = 2.6E-30 - H14M30 = 1.4E-30 - H25M31 = 2.5E-31 - H21M31 = 2.1E-31 - H12M31 = 1.2E-31 - H9M32 = 9.E-32 - H55M32 = 5.5E-32 - H45M32 = 4.5E-32 - H4M33 = 4.E-33 - H62M34 = 6.2E-34 -! -!******FOLLOWING ARE NEGATIVE FLOATING POINT CONSTANTS (HM'S) -! ARRANGED IN DESCENDING ORDER - HM2M2 = -.02 - HM6666M2 = -.066667 - HMP5 = -0.5 - HMP575 = -0.575 - HMP66667 = -.66667 - HMP805 = -0.805 - HM1EZ = -1. - HM13EZ = -1.3 - HM19EZ = -1.9 - HM1E1 = -10. - HM1597E1 = -15.97469413 - HM161E1 = -16.1 - HM1797E1 = -17.97469413 - HM181E1 = -18.1 - HM8E1 = -80. - HM1E2 = -100. -! - RETURN - END - SUBROUTINE LWR88(HEATRA,GRNFLX,TOPFLX, - & PRESS,TEMP,RH2O,QO3,CLDFAC, - & CAMT,NCLDS,KTOP,KBTM -! - &, L, LP1, LP1V, LLP1, IMAX -! - &, STEMP, GTEMP - &, CDTM51, CO2M51, C2DM51, CDTM58, CO2M58, C2DM58 - &, CDT51, CO251, C2D51, CDT58, CO258, C2D58 - &, CDT31, CO231, C2D31, CDT38, CO238, C2D38 - &, CDT71, CO271, C2D71, CDT78, CO278, C2D78 -! -! &, CO211,CO218 ! Not used!!! -! - &, SOURCE,DSRCE) -! -CFPP$ NOCONCUR R -! SUBROUTINE LWR88 COMPUTES TEMPERATURE-CORRECTED CO2 TRANSMISSION -! FUNCTIONS AND ALSO COMPUTES THE PRESSURE GRID AND LAYER OPTICAL -! PATHS. -! INPUTS: (MODULE BLOCKS) -! CLDFAC CLDCOM -! PRESS,TEMP,RH2O,QO3 RADISW -! CAMT,NCLDS,KTOP,KBTM RADISW -! CO251,CO258,CDT51,CDT58 CO2BD3 -! C2D51,C2D58,CO2M51,CO2M58 CO2BD3 -! CDTM51,CDTM58,C2DM51,C2DM58 CO2BD3 -! STEMP,GTEMP CO2BD3 -! CO231,CO238,CDT31,CDT38 CO2BD2 -! C2D31,C2D38 CO2BD2 -! CO271,CO278,CDT71,CDT78 CO2BD4 -! C2D71,C2D78 CO2BD4 -! BETINW BDWIDE -! OUTPUTS: -! HEATRA,GRNFLX,TOPFLX LWOUT -! CALLED BY: -! RADMN OR INPUT ROUTINE OF MODEL -! CALLS: -! FST88 -! -c$$$ USE MACHINE , ONLY : kind_rad - USE HCON - USE RNDDTA - implicit none -! -! B0,B1,B2,B3 ARE COEFFICIENTS USED TO CORRECT FOR THE USE OF 250K IN -! THE PLANCK FUNCTION USED IN EVALUATING PLANCK-WEIGHTED CO2 -! TRANSMISSION FUNCTIONS. (SEE REF. 4) -! - real (kind=kind_rad) B0, B1, B2, B3 - PARAMETER (B0=-.51926410E-4, B1=-.18113332E-3, - & B2=-.10680132E-5, B3=-.67303519E-7) -! - integer L, LP1, LP1V, LLP1, IMAX - integer NCLDS(IMAX), KTOP(IMAX,LP1), KBTM(IMAX,LP1) -! - real (kind=kind_rad) CO251(LP1,LP1), CO258(LP1,LP1) - &, CDT51(LP1,LP1), CDT58(LP1,LP1) - &, C2D51(LP1,LP1), C2D58(LP1,LP1) - &, CO2M51(L), CO2M58(L) - &, CDTM51(L), CDTM58(L) - &, C2DM51(L), C2DM58(L) - &, STEMP(LP1), GTEMP(LP1) -! - real (kind=kind_rad) CO231(LP1), CO238(LP1), CDT31(LP1) - &, CDT38(LP1), C2D31(LP1), C2D38(LP1) -! - real (kind=kind_rad) CO271(LP1), CO278(LP1), CDT71(LP1) - &, CDT78(LP1), C2D71(LP1), C2D78(LP1) -! - real (kind=kind_rad) SOURCE(28,NBLY), DSRCE(28,NBLY) -! - real (kind=kind_rad) PRESS(IMAX,LP1), TEMP(IMAX,LP1) - &, RH2O(IMAX,L), QO3(IMAX,L) - &, CLDFAC(IMAX,LP1,LP1), CAMT(IMAX,LP1) - &, HEATRA(IMAX,L), GRNFLX(IMAX) - &, TOPFLX(IMAX), DELP2(IMAX,L) -! - real (kind=kind_rad) QH2O(IMAX,L), T(IMAX,LP1) - &, P(IMAX,LP1), DELP(IMAX,L) - &, CO21(IMAX,LP1,LP1), CO2NBL(IMAX,L) - &, CO2SP1(IMAX,LP1), CO2SP2(IMAX,LP1) - &, VAR1(IMAX,L), VAR2(IMAX,L) - &, VAR3(IMAX,L), VAR4(IMAX,L) - &, TOTO3(IMAX,LP1), TPHIO3(IMAX,LP1) - &, TOTPHI(IMAX,LP1), TOTVO2(IMAX,LP1) - &, EMX1(IMAX), EMX2(IMAX) - &, EMPL(IMAX,LLP1), CNTVAL(IMAX,LP1) -! - real (kind=kind_rad) CO2R1(IMAX,LP1), DCO2D1(IMAX,LP1) - &, D2CD21(IMAX,LP1), D2CD22(IMAX,LP1) - &, CO2R2(IMAX,LP1), DCO2D2(IMAX,LP1) - &, CO2MR(IMAX,L), CO2MD(IMAX,L) - &, CO2M2D(IMAX,L), TDAV(IMAX,LP1) - &, TSTDAV(IMAX,LP1) , VV(IMAX,L) - &, VSUM3(IMAX,LP1), DIFT(IMAX,LP1) - &, A1(IMAX), A2(IMAX) - &, TLSQU(IMAX,LP1) -! -! - real (kind=kind_rad) texpsl, tem, vsum2, CO2R, DCO2DT, D2CDT2 - integer LL, LM1, LP2, K, I, KP, K1, KK -! - LL = LLP1 - 1 - LM1 = L - 1 - LP2 = L + 2 -! -!****COMPUTE FLUX PRESSURES (P) AND DIFFERENCES (DELP2,DELP) -!****COMPUTE FLUX LEVEL TEMPERATURES (T) AND CONTINUUM TEMPERATURE -! CORRECTIONS (TEXPSL) -! - DO K=2,L - DO I=1,IMAX - P(I,K) = HAF*(PRESS(I,K-1)+PRESS(I,K)) - T(I,K) = HAF*(TEMP(I,K-1)+TEMP(I,K)) - ENDDO - ENDDO - DO I=1,IMAX - P(I,1) = ZERO - P(I,LP1) = PRESS(I,LP1) - T(I,1) = TEMP(I,1) - T(I,LP1) = TEMP(I,LP1) - ENDDO - DO K=1,L - DO I=1,IMAX - DELP2(I,K) = P(I,K+1) - P(I,K) - DELP(I,K) = ONE / DELP2(I,K) - ENDDO - ENDDO -!****COMPUTE ARGUMENT FOR CONT.TEMP.COEFF. -! (THIS IS 1800.(1./TEMP-1./296.))..THEN TAKE EXPONENTIAL -! DO I=1,IMAX*LP1 -! TEXPSL(I,1) = EXP(H18E3/TEMP(I,1)-H6P08108) -! ENDDO -!***COMPUTE OPTICAL PATHS FOR H2O AND O3, USING THE DIFFUSIVITY -! APPROXIMATION FOR THE ANGULAR INTEGRATION (1.66). OBTAIN THE -! UNWEIGHTED VALUES(VAR1,VAR3) AND THE WEIGHTED VALUES(VAR2,VAR4). -! THE QUANTITIES H3M4(.0003) AND H3M3(.003) APPEARING IN THE VAR2 AND -! VAR4 EXPRESSIONS ARE THE APPROXIMATE VOIGT CORRECTIONS FOR H2O AND -! O3,RESPECTIVELY. -! - DO K=1,L - DO I=1,IMAX - QH2O(I,K) = RH2O(I,K)*DIFFCTR -! -!---VV IS THE LAYER-MEAN PRESSURE (IN ATM),WHICH IS NOT THE SAME AS -! THE LEVEL PRESSURE (PRESS) -! - VV(I,K) = HAF*(P(I,K+1)+P(I,K))*P0INV - VAR1(I,K) = DELP2(I,K) * QH2O(I,K)*GINV - VAR3(I,K) = DELP2(I,K) * QO3(I,K)*DIFFCTR*GINV - VAR2(I,K) = VAR1(I,K) * (VV(I,K)+H3M4) - VAR4(I,K) = VAR3(I,K) * (VV(I,K)+H3M3) -! -! COMPUTE OPTICAL PATH FOR THE H2O CONTINUUM, USING ROBERTS COEFFS. -! (BETINW),AND TEMP. CORRECTION (TEXPSL). THE DIFFUSIVITY FACTOR -! (WHICH CANCELS OUT IN THIS EXPRESSION) IS ASSUMED TO BE 1.66. THE -! USE OF THE DIFFUSIVITY FACTOR HAS BEEN SHOWN TO BE A SIGNIFICANT -! SOURCE OF ERROR IN THE CONTINUUM CALCS.,BUT THE TIME PENALTY OF -! AN ANGULAR INTEGRATION IS SEVERE. -! - TEXPSL = EXP(H18E3/TEMP(I,K)-H6P08108) - CNTVAL(I,K) = TEXPSL*RH2O(I,K)*VAR2(I,K)*BETINW/ - & (RH2O(I,K)+RATH2OMW) - ENDDO - ENDDO -! COMPUTE SUMMED OPTICAL PATHS FOR H2O,O3 AND CONTINUUM - DO I=1,IMAX - TOTPHI(I,1) = ZERO - TOTO3(I,1) = ZERO - TPHIO3(I,1) = ZERO - TOTVO2(I,1) = ZERO - ENDDO - DO K=2,LP1 - DO I=1,IMAX - TOTPHI(I,K) = TOTPHI(I,K-1) + VAR2(I,K-1) - TOTO3(I,K) = TOTO3(I,K-1) + VAR3(I,K-1) - TPHIO3(I,K) = TPHIO3(I,K-1) + VAR4(I,K-1) - TOTVO2(I,K) = TOTVO2(I,K-1) + CNTVAL(I,K-1) - ENDDO - ENDDO -! -!---EMX1 IS THE ADDITIONAL PRESSURE-SCALED MASS FROM PRESS(L) TO -! P(L). IT IS USED IN NEARBY LAYER AND EMISS CALCULATIONS. -!---EMX2 IS THE ADDITIONAL PRESSURE-SCALED MASS FROM PRESS(L) TO -! P(LP1). IT IS USED IN CALCULATIONS BETWEEN FLUX LEVELS L AND LP1. -! - DO I=1,IMAX - TEM = QH2O(I,L)*PRESS(I,L)*GP0INV - EMX1(I) = TEM * (PRESS(I,L)-P(I,L)) - EMX2(I) = TEM * (P(I,LP1)-PRESS(I,L)) - ENDDO -!---EMPL IS THE PRESSURE SCALED MASS FROM P(K) TO PRESS(K) (INDEX 2-LP1) -! OR TO PRESS(K+1) (INDEX LP2-LL) - DO K=1,L - DO I=1,IMAX - EMPL(I,K+1)=QH2O(I,K)*P(I,K+1)*(P(I,K+1)-PRESS(I,K))*GP0INV - ENDDO - ENDDO - DO K=1,LM1 - KK = K + LP1 - K1 = K + 1 - DO I=1,IMAX - EMPL(I,KK)=QH2O(I,K1)*P(I,K1)*(PRESS(I,K1)-P(I,K1))*GP0INV - ENDDO - ENDDO - DO I=1,IMAX - EMPL(I,1) = VAR2(I,L) - EMPL(I,LLP1) = EMPL(I,LL) - ENDDO -!***COMPUTE WEIGHTED TEMPERATURE (TDAV) AND PRESSURE (TSTDAV) INTEGRALS -! FOR USE IN OBTAINING TEMP. DIFFERENCE BET. SOUNDING AND STD. -! TEMP. SOUNDING (DIFT) - DO I=1,IMAX - TSTDAV(I,1) = ZERO - TDAV(I,1) = ZERO - ENDDO - DO K=1,LP1 - DO I=1,IMAX - VSUM3(I,K) = TEMP(I,K) - STEMP(K) - ENDDO - ENDDO - DO K=1,L - DO I=1,IMAX - VSUM2 = GTEMP(K) * DELP2(I,K) - TSTDAV(I,K+1) = TSTDAV(I,K) + VSUM2 - TDAV(I,K+1) = TDAV(I,K) + VSUM2 * VSUM3(I,K) - ENDDO - ENDDO -! -!****EVALUATE COEFFICIENTS FOR CO2 PRESSURE INTERPOLATION (A1,A2) - TEM = 1.0 / P0XZP2 - DO I=1,IMAX - A1(I) = (PRESS(I,LP1)-P0XZP8)*TEM - A2(I) = (P0-PRESS(I,LP1))*TEM - ENDDO -! -!***PERFORM CO2 PRESSURE INTERPOLATION ON ALL INPUTTED TRANSMISSION -! FUNCTIONS AND TEMP. DERIVATIVES -!---SUCCESSIVELY COMPUTING CO2R,DCO2DT AND D2CDT2 IS DONE TO SAVE -! STORAGE (AT A SLIGHT LOSS IN COMPUTATION TIME) - DO K=1,LP1 - DO I=1,IMAX - CO2R1(I,K) = A1(I)*CO231(K)+A2(I)*CO238(K) - D2CD21(I,K) = H1M3*(A1(I)*C2D31(K)+A2(I)*C2D38(K)) - DCO2D1(I,K) = H1M2*(A1(I)*CDT31(K)+A2(I)*CDT38(K)) - CO2R2(I,K) = A1(I)*CO271(K)+A2(I)*CO278(K) - D2CD22(I,K) = H1M3*(A1(I)*C2D71(K)+A2(I)*C2D78(K)) - DCO2D2(I,K) = H1M2*(A1(I)*CDT71(K)+A2(I)*CDT78(K)) - ENDDO - ENDDO - DO K=1,L - DO I=1,IMAX - CO2MR(I,K) = A1(I)*CO2M51(K)+A2(I)*CO2M58(K) - CO2MD(I,K) = H1M2*(A1(I)*CDTM51(K)+A2(I)*CDTM58(K)) - CO2M2D(I,K) = H1M3*(A1(I)*C2DM51(K)+A2(I)*C2DM58(K)) - ENDDO - ENDDO -! -!***COMPUTE CO2 TEMPERATURE INTERPOLATIONS FOR ALL BANDS,USING DIFT -! -! THE CASE WHERE K=1 IS HANDLED FIRST. WE ARE NOW REPLACING -! 3-DIMENSIONAL ARRAYS BY 2-D ARRAYS, TO SAVE SPACE. THUS THIS -! CALCULATION IS FOR (I,KP,1) -! - DO KP=2,LP1 - DO I=1,IMAX - DIFT(I,KP) = TDAV(I,KP) / TSTDAV(I,KP) - ENDDO - ENDDO - DO I=1,IMAX - CO21(I,1,1) = 1.0 - CO2SP1(I,1) = 1.0 - CO2SP2(I,1) = 1.0 - ENDDO - DO KP=2,LP1 - DO I=1,IMAX -!---CALCULATIONS FOR KP>1 FOR K=1 - CO2R = A1(I)*CO251(KP,1)+A2(I)*CO258(KP,1) - DCO2DT = H1M2*(A1(I)*CDT51(KP,1)+A2(I)*CDT58(KP,1)) - D2CDT2 = H1M3*(A1(I)*C2D51(KP,1)+A2(I)*C2D58(KP,1)) - CO21(I,KP,1) = CO2R+DIFT(I,KP)*(DCO2DT+HAF*DIFT(I,KP)*D2CDT2) -!---CALCULATIONS FOR (EFFECTIVELY) KP=1,K>KP. THESE USE THE -! SAME VALUE OF DIFT DUE TO SYMMETRY - CO2R = A1(I)*CO251(1,KP)+A2(I)*CO258(1,KP) - DCO2DT = H1M2*(A1(I)*CDT51(1,KP)+A2(I)*CDT58(1,KP)) - D2CDT2 = H1M3*(A1(I)*C2D51(1,KP)+A2(I)*C2D58(1,KP)) - CO21(I,1,KP) = CO2R+DIFT(I,KP)*(DCO2DT+HAF*DIFT(I,KP)*D2CDT2) - ENDDO - ENDDO -! -! THE TRANSMISSION FUNCTIONS USED IN SPA88 MAY BE COMPUTED NOW. -!---(IN THE 250 LOOP,DIFT REALLY SHOULD BE (I,1,K), BUT DIFT IS -! INVARIANT WITH RESPECT TO K,KP,AND SO (I,1,K)=(I,K,1)) - DO K=2,LP1 - DO I=1,IMAX - CO2SP1(I,K) = CO2R1(I,K)+DIFT(I,K)*(DCO2D1(I,K)+HAF*DIFT(I,K)* - & D2CD21(I,K)) - CO2SP2(I,K) = CO2R2(I,K)+DIFT(I,K)*(DCO2D2(I,K)+HAF*DIFT(I,K)* - & D2CD22(I,K)) - ENDDO - ENDDO -! -! NEXT THE CASE WHEN K=2...L - DO K=2,L - DO KP=K+1,LP1 - DO I=1,IMAX - DIFT(I,KP) = (TDAV(I,KP)-TDAV(I,K))/ - & (TSTDAV(I,KP)-TSTDAV(I,K)) -! - CO2R = A1(I)*CO251(KP,K)+A2(I)*CO258(KP,K) - DCO2DT = H1M2*(A1(I)*CDT51(KP,K)+A2(I)*CDT58(KP,K)) - D2CDT2 = H1M3*(A1(I)*C2D51(KP,K)+A2(I)*C2D58(KP,K)) - CO21(I,KP,K) = CO2R+DIFT(I,KP)*(DCO2DT+HAF*DIFT(I,KP)*D2CDT2) -! - CO2R = A1(I)*CO251(K,KP)+A2(I)*CO258(K,KP) - DCO2DT = H1M2*(A1(I)*CDT51(K,KP)+A2(I)*CDT58(K,KP)) - D2CDT2 = H1M3*(A1(I)*C2D51(K,KP)+A2(I)*C2D58(K,KP)) - CO21(I,K,KP) = CO2R+DIFT(I,KP)*(DCO2DT+HAF*DIFT(I,KP)*D2CDT2) - ENDDO - ENDDO - ENDDO -! FINALLY THE CASE WHEN K=KP,K=2..LP1 - DO K=2,LP1 - DO I=1,IMAX - DIFT(I,K) = HAF*(VSUM3(I,K)+VSUM3(I,K-1)) - CO2R = A1(I)*CO251(K,K)+A2(I)*CO258(K,K) - DCO2DT = H1M2*(A1(I)*CDT51(K,K)+A2(I)*CDT58(K,K)) - D2CDT2 = H1M3*(A1(I)*C2D51(K,K)+A2(I)*C2D58(K,K)) - CO21(I,K,K) = CO2R+DIFT(I,K)*(DCO2DT+HAF*DIFT(I,K)*D2CDT2) - ENDDO - ENDDO -!--- WE AREN'T DOING NBL TFS ON THE 100 CM-1 BANDS . - DO K=1,L - DO I=1,IMAX - CO2NBL(I,K) = CO2MR(I,K) + VSUM3(I,K) * - & (CO2MD(I,K)+HAF*VSUM3(I,K)*CO2M2D(I,K)) - ENDDO - ENDDO -!***COMPUTE TEMP. COEFFICIENT BASED ON T(K) (SEE REF.2) - DO K=1,LP1 - DO I=1,IMAX - IF (T(I,K).LE.H25E2) THEN - TEM = T(I,K) - H25E2 - TLSQU(I,K) = B0 + TEM * (B1 + TEM * (B2 + B3*TEM)) - ELSE - TLSQU(I,K) = B0 - ENDIF - ENDDO - ENDDO -!***APPLY TO ALL CO2 TFS - DO K=1,LP1 - DO KP=1,LP1 - DO I=1,IMAX - CO21(I,KP,K) = CO21(I,KP,K)*(ONE-TLSQU(I,KP)) + TLSQU(I,KP) - ENDDO - ENDDO - DO I=1,IMAX - CO2SP1(I,K) = CO2SP1(I,K)*(ONE-TLSQU(I,1)) + TLSQU(I,1) - CO2SP2(I,K) = CO2SP2(I,K)*(ONE-TLSQU(I,1)) + TLSQU(I,1) - ENDDO - ENDDO - DO K=1,L - DO I=1,IMAX - CO2NBL(I,K) = CO2NBL(I,K)*(ONE-TLSQU(I,K))+TLSQU(I,K) - ENDDO - ENDDO - CALL FST88(HEATRA,GRNFLX,TOPFLX, - & QH2O,PRESS,P,DELP,DELP2,TEMP,T, - & CLDFAC, -! & CLDFAC,NCLDS,KTOP,KBTM,CAMT, - & CO21,CO2NBL,CO2SP1,CO2SP2, - & VAR1,VAR2,VAR3,VAR4,CNTVAL, - & TOTO3,TPHIO3,TOTPHI,TOTVO2, - & EMX1,EMX2,EMPL - &, L, LP1, LP1V, LLP1, IMAX - &, SOURCE,DSRCE) - RETURN - END -! SUBROUTINE SPA88 COMPUTES EXACT CTS HEATING RATES AND FLUXES AND -! CORRESPONDING CTS EMISSIVITY QUANTITIES FOR H2O,CO2 AND O3. -! INPUTS: (MODULE BLOCKS) -! ACOMB,BCOMB,APCM,BPCM BDCOMB -! ATPCM,BTPCM,BETACM BDCOMB -! BETINW BDWIDE -! TEMP,PRESS RADISW -! VAR1,VAR2,P,DELP,DELP2 KDACOM -! TOTVO2,TO3SP,TO3SPC TFCOM -! CO2SP1,CO2SP2,CO2SP TFCOM -! CLDFAC CLDCOM -! SKO2D TABCOM -! SORC,CSOUR SRCCOM -! OUTPUTS: -! EXCTS,CTSO3 TFCOM -! GXCTS RDFLUX -! CALLED BY: -! FST88 -! CALLS: -! - SUBROUTINE SPA88(EXCTS,CTSO3,GXCTS,SORC,CSOUR, - & CLDFAC,TEMP,PRESS,VAR1,VAR2, - & P,DELP,DELP2,TOTVO2,TO3SP,TO3SPC, - & CO2SP1,CO2SP2,CO2SP - &, L, LP1, IMAX) -CFPP$ NOCONCUR R -! -c$$$ USE MACHINE , ONLY : kind_rad - USE HCON - USE RNDDTA - implicit none -! - integer L, LP1, IMAX -! - real (kind=kind_rad) SORC(IMAX,LP1,NBLY), CSOUR(IMAX,LP1) - &, CLDFAC(IMAX,LP1,LP1) - &, TEMP(IMAX,LP1), PRESS(IMAX,LP1) - &, VAR1(IMAX,L), VAR2(IMAX,L) - &, P(IMAX,LP1), DELP(IMAX,L) - &, DELP2(IMAX,L), TOTVO2(IMAX,LP1) - &, TO3SPC(IMAX,L), TO3SP(IMAX,LP1) - &, CO2SP1(IMAX,LP1), CO2SP2(IMAX,LP1) - &, CO2SP(IMAX,LP1), EXCTS(IMAX,L) - &, CTSO3(IMAX,L), GXCTS(IMAX) -! - real (kind=kind_rad) PHITMP(IMAX,L), PSITMP(IMAX,L) - &, TT(IMAX,L), CTMP(IMAX,LP1) - &, X(IMAX,L), Y(IMAX,L) - &, TOPM(IMAX,L), TOPPHI(IMAX,L) - &, CTMP3(IMAX,LP1), CTMP2(IMAX,LP1) -! - real (kind=kind_rad) F, FF, AG, AGG, FAC1, FAC2, TEM - integer lm1, k, i, ib -! - LM1 = L - 1 -! -!---COMPUTE TEMPERATURE QUANTITIES FOR USE IN PROGRAM - DO K=1,L - DO I=1,IMAX - X(I,K) = TEMP(I,K) - H25E2 - Y(I,K) = X(I,K) * X(I,K) -! -! Initialize some arrays -! - EXCTS(I,K) = 0.0 - ENDDO - ENDDO -!---INITIALIZE CTMP(I,1),CTMP2(I,1),CTMP3(I,1) TO UNITY; THESE ARE -! TRANSMISSION FCTNS AT THE TOP. - DO I=1,IMAX - CTMP(I,1) = ONE - CTMP2(I,1) = 1. - CTMP3(I,1) = 1. - GXCTS(I) = 0.0 - -! For Clear Sky - ENDDO -! -!***BEGIN LOOP ON FREQUENCY BANDS *** -! -!-----CALCULATION FOR BAND 1 (COMBINED BAND 1) -!-----CALCULATION FOR BAND 2 (COMBINED BAND 2) -!-----CALCULATION FOR BAND 3 (COMBINED BAND 3) -!-----CALCULATION FOR BAND 4 (COMBINED BAND 4) -!-----CALCULATION FOR BAND 5 (COMBINED BAND 5) -!-----CALCULATION FOR BAND 6 (COMBINED BAND 6) -!-----CALCULATION FOR BAND 7 (COMBINED BAND 7) -!-----CALCULATION FOR BAND 8 (COMBINED BAND 8) -!-----CALCULATION FOR BAND 9 ( 560-670 CM-1; INCLUDES CO2) -!-----CALCULATION FOR BAND 10 (670-800 CM-1; INCLUDES CO2) -!-----CALCULATION FOR BAND 11 (800-900 CM-1) -!-----CALCULATION FOR BAND 12 (900-990 CM-1) -!-----CALCULATION FOR BAND 13 (990-1070 CM-1; INCLUDES O3)) -!-----CALCULATION FOR BAND 14 (1070-1200 CM-1) -! - DO IB=1,14 -! -! -!--- CALCULATION FOR SINGLE BAND (COMBINED BAND) -! -!--- OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY -! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED -! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) -! - DO K=1,L - DO I=1,IMAX - F = H44194M2*(APCM(IB)*X(I,K)+BPCM(IB)*Y(I,K)) - FF = H44194M2*(ATPCM(IB)*X(I,K)+BTPCM(IB)*Y(I,K)) - AG = (H1P41819+F)*F + ONE - AGG = (H1P41819+FF)*FF + ONE -! - AG = AG * AG ! AG ** 2 - AG = AG * AG ! AG ** 4 - AG = AG * AG ! AG ** 8 - AGG = AGG * AGG - AGG = AGG * AGG - AGG = AGG * AGG -! - PHITMP(I,K) = VAR1(I,K) * (AG*AG) ! AG ** 16 - PSITMP(I,K) = VAR2(I,K) * (AGG*AGG) - ENDDO - ENDDO -!--- OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE -! P(K) (TOPM,TOPPHI) - DO I=1,IMAX - TOPM(I,1) = PHITMP(I,1) - TOPPHI(I,1) = PSITMP(I,1) - ENDDO - DO K=2,L - DO I=1,IMAX - TOPM(I,K) = TOPM(I,K-1) + PHITMP(I,K) - TOPPHI(I,K) = TOPPHI(I,K-1) + PSITMP(I,K) - ENDDO - ENDDO -!--- TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION - IF (IB .LT. 5) THEN - DO K=1,L - DO I=1,IMAX - FAC1 = ACOMB(IB)*TOPM(I,K) - FAC2 = FAC1*TOPM(I,K)/(BCOMB(IB)*TOPPHI(I,K)) - TT(I,K) = EXP(HM1EZ*FAC1/SQRT(1.+FAC2)) - ENDDO - ENDDO - ELSEIF (IB .LT. 9 .OR. (IB .GT. 10 .AND. IB .NE. 13)) THEN - DO K=1,L - DO I=1,IMAX - FAC1 = ACOMB(IB)*TOPM(I,K) - FAC2 = FAC1*TOPM(I,K)/(BCOMB(IB)*TOPPHI(I,K)) - TT(I,K) = EXP(HM1EZ*(FAC1/SQRT(1.+FAC2)+ - & BETACM(IB)*TOTVO2(I,K+1)*SKO2D)) - ENDDO - ENDDO - ELSEIF (IB .EQ. 9) THEN - DO K=1,L - DO I=1,IMAX - FAC1 = ACOMB(IB)*TOPM(I,K) - FAC2 = FAC1*TOPM(I,K)/(BCOMB(IB)*TOPPHI(I,K)) - TT(I,K) = EXP(HM1EZ*(FAC1/SQRT(1.+FAC2)+ - & BETACM(IB)*TOTVO2(I,K+1)*SKO2D))*CO2SP1(I,K+1) - ENDDO - ENDDO - ELSEIF (IB .EQ. 10) THEN - DO K=1,L - DO I=1,IMAX - FAC1 = ACOMB(IB)*TOPM(I,K) - FAC2 = FAC1*TOPM(I,K)/(BCOMB(IB)*TOPPHI(I,K)) - TT(I,K) = EXP(HM1EZ*(FAC1/SQRT(1.+FAC2)+ - & BETACM(IB)*TOTVO2(I,K+1)*SKO2D))*CO2SP2(I,K+1) - ENDDO - ENDDO - ELSEIF (IB .EQ. 13) THEN - DO K=1,L - DO I=1,IMAX - FAC1 = ACOMB(IB)*TOPM(I,K) - FAC2 = FAC1*TOPM(I,K)/(BCOMB(IB)*TOPPHI(I,K)) - TT(I,K) = EXP(HM1EZ*(FAC1/SQRT(1.+FAC2)+ - & BETACM(IB)*TOTVO2(I,K+1)*SKO2D +TO3SPC(I,K))) - ENDDO - ENDDO - ENDIF - DO K=1,L - DO I=1,IMAX - CTMP(I,K+1) = TT(I,K)*CLDFAC(I,K+1,1) - ENDDO - ENDDO -! -!--- EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS - DO K=1,L - DO I=1,IMAX - EXCTS(I,K) = EXCTS(I,K) - & + SORC(I,K,IB) * (CTMP(I,K+1)-CTMP(I,K)) - ENDDO - ENDDO -!--- GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS - DO I=1,IMAX - TEM = TT(I,L)*SORC(I,L,IB)+ - & (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + - & TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * - & (SORC(I,LP1,IB)-SORC(I,L,IB)) - GXCTS(I) = GXCTS(I) + TEM * CLDFAC(I,LP1,1) - ENDDO -! - ENDDO ! Band Loop Ends here! -! -! -! OBTAIN CTS FLUX AT THE TOP BY INTEGRATION OF HEATING RATES AND -! USING CTS FLUX AT THE BOTTOM (CURRENT VALUE OF GXCTS). NOTE -! THAT THE PRESSURE QUANTITIES AND CONVERSION FACTORS HAVE NOT -! BEEN INCLUDED EITHER IN EXCTS OR IN GXCTS. THESE CANCEL OUT, THUS -! REDUCING COMPUTATIONS! -! - DO K=1,L - DO I=1,IMAX - GXCTS(I) = GXCTS(I) - EXCTS(I,K) - ENDDO - ENDDO -! -! NOW SCALE THE COOLING RATE (EXCTS) BY INCLUDING THE PRESSURE -! FACTOR (DELP) AND THE CONVERSION FACTOR (RADCON) -! -! DO I=1,IMAX*L -! EXCTS(I,1) = EXCTS(I,1) *RADCON*DELP(I,1) -! ENDDO -!---THIS IS THE END OF THE EXACT CTS COMPUTATIONS; AT THIS POINT -! EXCTS HAS ITS APPROPRIATE VALUE. -! -!*** COMPUTE APPROXIMATE CTS HEATING RATES FOR 15UM AND 9.6 UM BANDS -! (CTSO3) - DO K=1,L - DO I=1,IMAX - CTMP2(I,K+1) = CO2SP(I,K+1) * CLDFAC(I,K+1,1) - CTMP3(I,K+1) = TO3SP(I,K) * CLDFAC(I,K+1,1) - ENDDO - ENDDO - DO K=1,L - DO I=1,IMAX -! CTSO3(I,K) = RADCON*DELP(I,K)* - CTSO3(I,K) = CSOUR(I,K)*(CTMP2(I,K+1)-CTMP2(I,K)) + - & SORC(I,K,13)*(CTMP3(I,K+1)-CTMP3(I,K)) -! - ENDDO - ENDDO -! - RETURN - END - SUBROUTINE LWTABLE(LP1,LP1V, SOURCE,DSRCE) -CFPP$ NOCONCUR R -! SUBROUTINE TABLE COMPUTES TABLE ENTRIES USED IN THE LONGWAVE RADIA -! PROGRAM. ALSO CALCULATED ARE INDICES USED IN STRIP-MINING AND FOR -! SOME PRE-COMPUTABLE FUNCTIONS. -! INPUTS: -! OUTPUTS: -! EM1V,EM1VW,T1,T2,T4 TABCOM -! EM3,SOURCE,DSRCE,IND,INDX2,KMAXV TABCOM -! KMAXVM, TABCOM -! AO3RND,BO3RND,AB15 BANDTA -! AB15WD,SKC1R,SKO3R,SKO2D BDWIDE -! -c$$$ USE MACHINE , ONLY : kind_rad - USE HCON - USE RNDDTA - implicit none -! - integer lp1, lp1v,i1 -! - real (kind=kind_rad) SOURCE(28,NBLY), DSRCE(28,NBLY) -! - real (kind=kind_rad) SUM(28,180), PERTSM(28,180) - &, SUM3(28,180), SUMWDE(28,180) - &, SRCWD(28,NBLX), SRC1NB(28,NBLW) - &, DBDTNB(28,NBLW), ZMASS(181) - &, ZROOT(181), SC(28), DSC(28) - &, XTEMV(28), TFOUR(28), FORTCU(28) - &, X(28), X1(28), X2(180) - &, SRCS(28), SUM4(28), SUM6(28) - &, SUM7(28), SUM8(28), SUM4WD(28) - &, R1(28), R2(28), S2(28) - &, T3(28), R1WD(28) - &, EXPO(180), FAC(180) - &, CNUSB(30), DNUSB(30) - &, ALFANB(NBLW), AROTNB(NBLW) - &, ANB(NBLW), BNB(NBLW), CENTNB(NBLW) - &, DELNB(NBLW), BETANB(NBLW) -! - real (kind=kind_rad) CENT, DEL, BDHI, BDLO, ANU, C1 - integer L, LP2, N, J, JP, I, IA, NSUBDS, NSB - real (kind=kind_rad) ARNDM1(64), ARNDM2(64), ARNDM3(35) - &, BRNDM1(64), BRNDM2(64), BRNDM3(35) - &, AP1(64), AP2(64), AP3(35) - &, BP1(64), BP2(64), BP3(35) - &, ATP1(64), ATP2(64), ATP3(35) - &, BTP1(64), BTP2(64), BTP3(35) - &, BETAD1(64), BETAD2(64), BETAD3(35) - &, BANDL1(64), BANDL2(64), BANDL3(35) - &, BANDH1(64), BANDH2(64), BANDH3(35) -! -!***THE FOLLOWING DATA STATEMENTS ARE BAND PARAMETERS OBTAINED USING -! THE 1982 AFGL CATALOG ON THE SPECIFIED BANDS -! - DATA ARNDM1 / - & 0.354693E+00, 0.269857E+03, 0.167062E+03, 0.201314E+04, - & 0.964533E+03, 0.547971E+04, 0.152933E+04, 0.599429E+04, - & 0.699329E+04, 0.856721E+04, 0.962489E+04, 0.233348E+04, - & 0.127091E+05, 0.104383E+05, 0.504249E+04, 0.181227E+05, - & 0.856480E+03, 0.136354E+05, 0.288635E+04, 0.170200E+04, - & 0.209761E+05, 0.126797E+04, 0.110096E+05, 0.336436E+03, - & 0.491663E+04, 0.863701E+04, 0.540389E+03, 0.439786E+04, - & 0.347836E+04, 0.130557E+03, 0.465332E+04, 0.253086E+03, - & 0.257387E+04, 0.488041E+03, 0.892991E+03, 0.117148E+04, - & 0.125880E+03, 0.458852E+03, 0.142975E+03, 0.446355E+03, - & 0.302887E+02, 0.394451E+03, 0.438112E+02, 0.348811E+02, - & 0.615503E+02, 0.143165E+03, 0.103958E+02, 0.725108E+02, - & 0.316628E+02, 0.946456E+01, 0.542675E+02, 0.351557E+02, - & 0.301797E+02, 0.381010E+01, 0.126319E+02, 0.548010E+01, - & 0.600199E+01, 0.640803E+00, 0.501549E-01, 0.167961E-01, - & 0.178110E-01, 0.170166E+00, 0.273514E-01, 0.983767E+00/ - DATA ARNDM2 / - & 0.753946E+00, 0.941763E-01, 0.970547E+00, 0.268862E+00, - & 0.564373E+01, 0.389794E+01, 0.310955E+01, 0.128235E+01, - & 0.196414E+01, 0.247113E+02, 0.593435E+01, 0.377552E+02, - & 0.305173E+02, 0.852479E+01, 0.116780E+03, 0.101490E+03, - & 0.138939E+03, 0.324228E+03, 0.683729E+02, 0.471304E+03, - & 0.159684E+03, 0.427101E+03, 0.114716E+03, 0.106190E+04, - & 0.294607E+03, 0.762948E+03, 0.333199E+03, 0.830645E+03, - & 0.162512E+04, 0.525676E+03, 0.137739E+04, 0.136252E+04, - & 0.147164E+04, 0.187196E+04, 0.131118E+04, 0.103975E+04, - & 0.621637E+01, 0.399459E+02, 0.950648E+02, 0.943161E+03, - & 0.526821E+03, 0.104150E+04, 0.905610E+03, 0.228142E+04, - & 0.806270E+03, 0.691845E+03, 0.155237E+04, 0.192241E+04, - & 0.991871E+03, 0.123907E+04, 0.457289E+02, 0.146146E+04, - & 0.319382E+03, 0.436074E+03, 0.374214E+03, 0.778217E+03, - & 0.140227E+03, 0.562540E+03, 0.682685E+02, 0.820292E+02, - & 0.178779E+03, 0.186150E+03, 0.383864E+03, 0.567416E+01/ - DATA ARNDM3 / - & 0.225129E+03, 0.473099E+01, 0.753149E+02, 0.233689E+02, - & 0.339802E+02, 0.108855E+03, 0.380016E+02, 0.151039E+01, - & 0.660346E+02, 0.370165E+01, 0.234169E+02, 0.440206E+00, - & 0.615283E+01, 0.304077E+02, 0.117769E+01, 0.125248E+02, - & 0.142652E+01, 0.241831E+00, 0.483721E+01, 0.226357E-01, - & 0.549835E+01, 0.597067E+00, 0.404553E+00, 0.143584E+01, - & 0.294291E+00, 0.466273E+00, 0.156048E+00, 0.656185E+00, - & 0.172727E+00, 0.118349E+00, 0.141598E+00, 0.588581E-01, - & 0.919409E-01, 0.155521E-01, 0.537083E-02/ - DATA BRNDM1 / - & 0.789571E-01, 0.920256E-01, 0.696960E-01, 0.245544E+00, - & 0.188503E+00, 0.266127E+00, 0.271371E+00, 0.330917E+00, - & 0.190424E+00, 0.224498E+00, 0.282517E+00, 0.130675E+00, - & 0.212579E+00, 0.227298E+00, 0.138585E+00, 0.187106E+00, - & 0.194527E+00, 0.177034E+00, 0.115902E+00, 0.118499E+00, - & 0.142848E+00, 0.216869E+00, 0.149848E+00, 0.971585E-01, - & 0.151532E+00, 0.865628E-01, 0.764246E-01, 0.100035E+00, - & 0.171133E+00, 0.134737E+00, 0.105173E+00, 0.860832E-01, - & 0.148921E+00, 0.869234E-01, 0.106018E+00, 0.184865E+00, - & 0.767454E-01, 0.108981E+00, 0.123094E+00, 0.177287E+00, - & 0.848146E-01, 0.119356E+00, 0.133829E+00, 0.954505E-01, - & 0.155405E+00, 0.164167E+00, 0.161390E+00, 0.113287E+00, - & 0.714720E-01, 0.741598E-01, 0.719590E-01, 0.140616E+00, - & 0.355356E-01, 0.832779E-01, 0.128680E+00, 0.983013E-01, - & 0.629660E-01, 0.643346E-01, 0.717082E-01, 0.629730E-01, - & 0.875182E-01, 0.857907E-01, 0.358808E+00, 0.178840E+00/ - DATA BRNDM2 / - & 0.254265E+00, 0.297901E+00, 0.153916E+00, 0.537774E+00, - & 0.267906E+00, 0.104254E+00, 0.400723E+00, 0.389670E+00, - & 0.263701E+00, 0.338116E+00, 0.351528E+00, 0.267764E+00, - & 0.186419E+00, 0.238237E+00, 0.210408E+00, 0.176869E+00, - & 0.114715E+00, 0.173299E+00, 0.967770E-01, 0.172565E+00, - & 0.162085E+00, 0.157782E+00, 0.886832E-01, 0.242999E+00, - & 0.760298E-01, 0.164248E+00, 0.221428E+00, 0.166799E+00, - & 0.312514E+00, 0.380600E+00, 0.353828E+00, 0.269500E+00, - & 0.254759E+00, 0.285408E+00, 0.159764E+00, 0.721058E-01, - & 0.170528E+00, 0.231595E+00, 0.307184E+00, 0.564136E-01, - & 0.159884E+00, 0.147907E+00, 0.185666E+00, 0.183567E+00, - & 0.182482E+00, 0.230650E+00, 0.175348E+00, 0.195978E+00, - & 0.255323E+00, 0.198517E+00, 0.195500E+00, 0.208356E+00, - & 0.309603E+00, 0.112011E+00, 0.102570E+00, 0.128276E+00, - & 0.168100E+00, 0.177836E+00, 0.105533E+00, 0.903330E-01, - & 0.126036E+00, 0.101430E+00, 0.124546E+00, 0.221406E+00/ - DATA BRNDM3 / - & 0.137509E+00, 0.911365E-01, 0.724508E-01, 0.795788E-01, - & 0.137411E+00, 0.549175E-01, 0.787714E-01, 0.165544E+00, - & 0.136484E+00, 0.146729E+00, 0.820496E-01, 0.846211E-01, - & 0.785821E-01, 0.122527E+00, 0.125359E+00, 0.101589E+00, - & 0.155756E+00, 0.189239E+00, 0.999086E-01, 0.480993E+00, - & 0.100233E+00, 0.153754E+00, 0.130780E+00, 0.136136E+00, - & 0.159353E+00, 0.156634E+00, 0.272265E+00, 0.186874E+00, - & 0.192090E+00, 0.135397E+00, 0.131497E+00, 0.127463E+00, - & 0.227233E+00, 0.190562E+00, 0.214005E+00/ - DATA AP1 / - & -0.675950E-02, -0.909459E-02, -0.800214E-02, -0.658673E-02, - & -0.245580E-02, -0.710464E-02, -0.205565E-02, -0.446529E-02, - & -0.440265E-02, -0.593625E-02, -0.201913E-02, -0.349169E-02, - & -0.209324E-02, -0.127980E-02, -0.388007E-02, -0.140542E-02, - & 0.518346E-02, -0.159375E-02, 0.250508E-02, 0.132182E-01, - & -0.903779E-03, 0.110959E-01, 0.924528E-03, 0.207428E-01, - & 0.364166E-02, 0.365229E-02, 0.884367E-02, 0.617260E-02, - & 0.701340E-02, 0.184265E-01, 0.992822E-02, 0.908582E-02, - & 0.106581E-01, 0.276268E-02, 0.158414E-01, 0.145747E-01, - & 0.453080E-02, 0.214767E-01, 0.553895E-02, 0.195031E-01, - & 0.237016E-01, 0.112371E-01, 0.275977E-01, 0.188833E-01, - & 0.131079E-01, 0.130019E-01, 0.385122E-01, 0.111768E-01, - & 0.622620E-02, 0.194397E-01, 0.134360E-01, 0.207829E-01, - & 0.147960E-01, 0.744479E-02, 0.107564E-01, 0.181562E-01, - & 0.170062E-01, 0.233303E-01, 0.256735E-01, 0.274745E-01, - & 0.279259E-01, 0.197002E-01, 0.140268E-01, 0.185933E-01/ - DATA AP2 / - & 0.169525E-01, 0.214410E-01, 0.136577E-01, 0.169510E-01, - & 0.173025E-01, 0.958346E-02, 0.255024E-01, 0.308943E-01, - & 0.196031E-01, 0.183608E-01, 0.149419E-01, 0.206358E-01, - & 0.140654E-01, 0.172797E-01, 0.145470E-01, 0.982987E-02, - & 0.116695E-01, 0.811333E-02, 0.965823E-02, 0.649977E-02, - & 0.462192E-02, 0.545929E-02, 0.680407E-02, 0.291235E-02, - & -0.974773E-03, 0.341591E-02, 0.376198E-02, 0.770610E-03, - & -0.940864E-04, 0.514532E-02, 0.232371E-02, -0.177741E-02, - & -0.374892E-03, -0.370485E-03, -0.221435E-02, -0.490000E-02, - & 0.588664E-02, 0.931411E-03, -0.456043E-03, -0.545576E-02, - & -0.421136E-02, -0.353742E-02, -0.174276E-02, -0.361246E-02, - & -0.337822E-02, -0.867030E-03, -0.118001E-02, -0.222405E-02, - & -0.725144E-03, 0.118483E-02, 0.995087E-02, 0.273812E-03, - & 0.417298E-02, 0.764294E-02, 0.631568E-02, -0.213528E-02, - & 0.746130E-02, 0.110337E-02, 0.153157E-01, 0.504532E-02, - & 0.406047E-02, 0.192895E-02, 0.202058E-02, 0.126420E-01/ - DATA AP3 / - & 0.310028E-02, 0.214779E-01, 0.560165E-02, 0.661070E-02, - & 0.694966E-02, 0.539194E-02, 0.103745E-01, 0.180150E-01, - & 0.747133E-02, 0.114927E-01, 0.115213E-01, 0.160709E-02, - & 0.154278E-01, 0.112067E-01, 0.148690E-01, 0.154442E-01, - & 0.123977E-01, 0.237539E-01, 0.162820E-01, 0.269484E-01, - & 0.178081E-01, 0.143221E-01, 0.262468E-01, 0.217065E-01, - & 0.107083E-01, 0.281220E-01, 0.115565E-01, 0.231244E-01, - & 0.225197E-01, 0.178624E-01, 0.327708E-01, 0.116657E-01, - & 0.277452E-01, 0.301647E-01, 0.349782E-01/ - DATA BP1 / - & 0.717848E-05, 0.169280E-04, 0.126710E-04, 0.758397E-05, - & -0.533900E-05, 0.143490E-04, -0.595854E-05, 0.296465E-05, - & 0.323446E-05, 0.115359E-04, -0.692861E-05, 0.131477E-04, - & -0.624945E-05, -0.756955E-06, 0.107458E-05, -0.159796E-05, - & -0.290529E-04, -0.170918E-05, -0.193934E-04, -0.707209E-04, - & -0.148154E-04, -0.383162E-04, -0.186050E-04, -0.951796E-04, - & -0.210944E-04, -0.330590E-04, -0.373087E-04, -0.408972E-04, - & -0.396759E-04, -0.827756E-04, -0.573773E-04, -0.325384E-04, - & -0.449411E-04, -0.271450E-04, -0.752791E-04, -0.549699E-04, - & -0.225655E-04, -0.102034E-03, -0.740322E-05, -0.668846E-04, - & -0.106063E-03, -0.304840E-04, -0.796023E-04, 0.504880E-04, - & 0.486384E-04, -0.531946E-04, -0.147771E-03, -0.406785E-04, - & 0.615750E-05, -0.486264E-04, -0.419335E-04, -0.819467E-04, - & -0.709498E-04, 0.326984E-05, -0.369743E-04, -0.526848E-04, - & -0.550050E-04, -0.684057E-04, -0.447093E-04, -0.778390E-04, - & -0.982953E-04, -0.772497E-04, -0.119430E-05, -0.655187E-04/ - DATA BP2 / - & -0.339078E-04, 0.716657E-04, -0.335893E-04, 0.220239E-04, - & -0.491012E-04, -0.393325E-04, -0.626461E-04, -0.795479E-04, - & -0.599181E-04, -0.578153E-04, -0.597559E-05, -0.866750E-04, - & -0.486783E-04, -0.580912E-04, -0.647368E-04, -0.350643E-04, - & -0.566635E-04, -0.385738E-04, -0.463782E-04, -0.321485E-04, - & -0.177300E-04, -0.250201E-04, -0.365492E-04, -0.165218E-04, - & -0.649177E-05, -0.218458E-04, -0.984604E-05, -0.120034E-04, - & -0.110119E-06, -0.164405E-04, -0.141396E-04, 0.315347E-05, - & -0.141544E-05, -0.297320E-05, -0.216248E-05, 0.839264E-05, - & -0.178197E-04, -0.106225E-04, -0.468195E-05, 0.997043E-05, - & 0.679709E-05, 0.324610E-05, -0.367325E-05, 0.671058E-05, - & 0.509293E-05, -0.437392E-05, -0.787922E-06, -0.271503E-06, - & -0.437940E-05, -0.128205E-04, -0.417830E-04, -0.561134E-05, - & -0.209940E-04, -0.414366E-04, -0.289765E-04, 0.680406E-06, - & -0.558644E-05, -0.530395E-05, -0.622242E-04, -0.159979E-05, - & -0.140286E-04, -0.128463E-04, -0.929499E-05, -0.327886E-04/ - DATA BP3 / - & -0.189353E-04, -0.737589E-04, -0.323471E-04, -0.272502E-04, - & -0.321731E-04, -0.326958E-04, -0.509157E-04, -0.681890E-04, - & -0.362182E-04, -0.354405E-04, -0.578392E-04, 0.238627E-05, - & -0.709028E-04, -0.518717E-04, -0.491859E-04, -0.718017E-04, - & -0.418978E-05, -0.940819E-04, -0.630375E-04, -0.478469E-04, - & -0.751896E-04, -0.267113E-04, -0.109019E-03, -0.890983E-04, - & -0.177301E-04, -0.120216E-03, 0.220464E-04, -0.734277E-04, - & -0.868068E-04, -0.652319E-04, -0.136982E-03, -0.279933E-06, - & -0.791824E-04, -0.111781E-03, -0.748263E-04/ - DATA ATP1 / - & -0.722782E-02, -0.901531E-02, -0.821263E-02, -0.808024E-02, - & -0.320169E-02, -0.661305E-02, -0.287272E-02, -0.486143E-02, - & -0.242857E-02, -0.530288E-02, -0.146813E-02, -0.566474E-03, - & -0.102192E-02, 0.300643E-03, -0.331655E-02, 0.648220E-03, - & 0.552446E-02, -0.933046E-03, 0.205703E-02, 0.130638E-01, - & -0.229828E-02, 0.715648E-02, 0.444446E-03, 0.193500E-01, - & 0.364119E-02, 0.252713E-02, 0.102420E-01, 0.494224E-02, - & 0.584934E-02, 0.146255E-01, 0.921986E-02, 0.768012E-02, - & 0.916105E-02, 0.276223E-02, 0.125245E-01, 0.131146E-01, - & 0.793016E-02, 0.201536E-01, 0.658631E-02, 0.171711E-01, - & 0.228470E-01, 0.131306E-01, 0.226658E-01, 0.176086E-01, - & 0.149987E-01, 0.143060E-01, 0.313189E-01, 0.117070E-01, - & 0.133522E-01, 0.244259E-01, 0.148393E-01, 0.223982E-01, - & 0.151792E-01, 0.180474E-01, 0.106299E-01, 0.191016E-01, - & 0.171776E-01, 0.229724E-01, 0.275530E-01, 0.302731E-01, - & 0.281662E-01, 0.199525E-01, 0.192588E-01, 0.173220E-01/ - DATA ATP2 / - & 0.195220E-01, 0.169371E-01, 0.193212E-01, 0.145558E-01, - & 0.189654E-01, 0.122030E-01, 0.186206E-01, 0.228842E-01, - & 0.139343E-01, 0.164006E-01, 0.137276E-01, 0.154005E-01, - & 0.114575E-01, 0.129956E-01, 0.115305E-01, 0.929260E-02, - & 0.106359E-01, 0.771623E-02, 0.106075E-01, 0.597630E-02, - & 0.493960E-02, 0.532554E-02, 0.646175E-02, 0.302693E-02, - & 0.150899E-02, 0.310333E-02, 0.533734E-02, 0.239094E-03, - & 0.356782E-02, 0.707574E-02, 0.215758E-02, -0.527589E-03, - & 0.643893E-03, -0.101916E-02, -0.383336E-02, -0.445966E-02, - & 0.880190E-02, 0.245662E-02, -0.560923E-03, -0.582201E-02, - & -0.323233E-02, -0.454197E-02, -0.240905E-02, -0.343160E-02, - & -0.335156E-02, -0.623846E-03, 0.393633E-03, -0.271593E-02, - & -0.675874E-03, 0.920642E-03, 0.102168E-01, -0.250663E-03, - & 0.437126E-02, 0.767434E-02, 0.569931E-02, -0.929326E-03, - & 0.659414E-02, 0.280687E-02, 0.127614E-01, 0.780789E-02, - & 0.374807E-02, 0.274288E-02, 0.534940E-02, 0.104349E-01/ - DATA ATP3 / - & 0.294379E-02, 0.177846E-01, 0.523249E-02, 0.125339E-01, - & 0.548538E-02, 0.577403E-02, 0.101532E-01, 0.170375E-01, - & 0.758396E-02, 0.113402E-01, 0.106960E-01, 0.107782E-01, - & 0.136148E-01, 0.992064E-02, 0.167276E-01, 0.149603E-01, - & 0.136259E-01, 0.234521E-01, 0.166806E-01, 0.298505E-01, - & 0.167592E-01, 0.186679E-01, 0.233062E-01, 0.228467E-01, - & 0.128947E-01, 0.293979E-01, 0.219815E-01, 0.220663E-01, - & 0.272710E-01, 0.237139E-01, 0.331743E-01, 0.208799E-01, - & 0.281472E-01, 0.318440E-01, 0.370962E-01/ - DATA BTP1 / - & 0.149748E-04, 0.188007E-04, 0.196530E-04, 0.124747E-04, - & -0.215751E-07, 0.128357E-04, -0.265798E-05, 0.606262E-05, - & 0.287668E-05, 0.974612E-05, -0.833451E-05, 0.584410E-05, - & -0.452879E-05, -0.782537E-05, 0.786165E-05, -0.768351E-05, - & -0.196168E-04, 0.177297E-06, -0.129258E-04, -0.642798E-04, - & -0.986297E-05, -0.257145E-04, -0.141996E-04, -0.865089E-04, - & -0.141691E-04, -0.272578E-04, -0.295198E-04, -0.308878E-04, - & -0.313193E-04, -0.669272E-04, -0.475777E-04, -0.221332E-04, - & -0.419930E-04, -0.102519E-04, -0.590184E-04, -0.574771E-04, - & -0.240809E-04, -0.913994E-04, -0.908886E-05, -0.721074E-04, - & -0.902837E-04, -0.447582E-04, -0.664544E-04, -0.143150E-04, - & -0.511866E-05, -0.559352E-04, -0.104734E-03, -0.305206E-04, - & 0.103303E-04, -0.613019E-04, -0.320040E-04, -0.738909E-04, - & -0.388263E-04, 0.306515E-04, -0.352214E-04, -0.253940E-04, - & -0.521369E-04, -0.746260E-04, -0.744124E-04, -0.881905E-04, - & -0.933645E-04, -0.664045E-04, -0.570712E-05, -0.566312E-04/ - DATA BTP2 / - & -0.364967E-04, 0.393501E-06, -0.234050E-04, -0.141317E-04, - & -0.525480E-04, -0.172241E-04, -0.410843E-04, -0.358348E-04, - & -0.256168E-04, -0.509482E-04, -0.180570E-04, -0.555356E-04, - & -0.271464E-04, -0.274040E-04, -0.480889E-04, -0.275751E-04, - & -0.415681E-04, -0.383770E-04, -0.280139E-04, -0.287919E-04, - & -0.125865E-04, -0.265467E-04, -0.172765E-04, -0.164611E-04, - & 0.189183E-04, -0.171219E-04, -0.132766E-04, -0.344611E-05, - & -0.442832E-05, -0.185779E-04, -0.139755E-04, 0.168083E-05, - & -0.395287E-05, -0.297871E-05, 0.434383E-05, 0.131741E-04, - & -0.192637E-04, -0.549551E-05, 0.122553E-05, 0.204627E-04, - & 0.154027E-04, 0.953462E-05, 0.131125E-05, 0.732839E-05, - & 0.755405E-05, -0.305552E-05, -0.434858E-05, 0.308409E-05, - & -0.164787E-05, -0.818533E-05, -0.355041E-04, -0.504696E-05, - & -0.229022E-04, -0.356891E-04, -0.230346E-04, 0.518835E-05, - & -0.160187E-04, -0.104617E-04, -0.464754E-04, -0.115807E-04, - & -0.130230E-04, -0.603491E-05, -0.125324E-04, -0.165516E-04/ - DATA BTP3 / - & -0.991679E-05, -0.529432E-04, -0.200199E-04, -0.181977E-04, - & -0.220940E-04, -0.204483E-04, -0.432584E-04, -0.449109E-04, - & -0.247305E-04, -0.174253E-04, -0.484446E-04, 0.354150E-04, - & -0.425581E-04, -0.406562E-04, -0.505495E-04, -0.651856E-04, - & -0.153953E-04, -0.894294E-04, -0.616551E-04, -0.846504E-04, - & -0.699414E-04, -0.376203E-04, -0.940985E-04, -0.753050E-04, - & -0.183710E-04, -0.123907E-03, -0.279347E-04, -0.736381E-04, - & -0.103588E-03, -0.754117E-04, -0.140991E-03, -0.366687E-04, - & -0.927785E-04, -0.125321E-03, -0.115290E-03/ - DATA BETAD1 / - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.234879E+03, 0.217419E+03, 0.201281E+03, 0.186364E+03, - & 0.172576E+03, 0.159831E+03, 0.148051E+03, 0.137163E+03, - & 0.127099E+03, 0.117796E+03, 0.109197E+03, 0.101249E+03, - & 0.939031E+02, 0.871127E+02, 0.808363E+02, 0.750349E+02, - & 0.497489E+02, 0.221212E+02, 0.113124E+02, 0.754174E+01, - & 0.589554E+01, 0.495227E+01, 0.000000E+00, 0.000000E+00/ - DATA BETAD2 / - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00/ - DATA BETAD3 / - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.000000E+00, 0.000000E+00, 0.000000E+00/ - DATA BANDL1 / - & 0.000000E+00, 0.100000E+02, 0.200000E+02, 0.300000E+02, - & 0.400000E+02, 0.500000E+02, 0.600000E+02, 0.700000E+02, - & 0.800000E+02, 0.900000E+02, 0.100000E+03, 0.110000E+03, - & 0.120000E+03, 0.130000E+03, 0.140000E+03, 0.150000E+03, - & 0.160000E+03, 0.170000E+03, 0.180000E+03, 0.190000E+03, - & 0.200000E+03, 0.210000E+03, 0.220000E+03, 0.230000E+03, - & 0.240000E+03, 0.250000E+03, 0.260000E+03, 0.270000E+03, - & 0.280000E+03, 0.290000E+03, 0.300000E+03, 0.310000E+03, - & 0.320000E+03, 0.330000E+03, 0.340000E+03, 0.350000E+03, - & 0.360000E+03, 0.370000E+03, 0.380000E+03, 0.390000E+03, - & 0.400000E+03, 0.410000E+03, 0.420000E+03, 0.430000E+03, - & 0.440000E+03, 0.450000E+03, 0.460000E+03, 0.470000E+03, - & 0.480000E+03, 0.490000E+03, 0.500000E+03, 0.510000E+03, - & 0.520000E+03, 0.530000E+03, 0.540000E+03, 0.550000E+03, - & 0.560000E+03, 0.670000E+03, 0.800000E+03, 0.900000E+03, - & 0.990000E+03, 0.107000E+04, 0.120000E+04, 0.121000E+04/ - DATA BANDL2 / - & 0.122000E+04, 0.123000E+04, 0.124000E+04, 0.125000E+04, - & 0.126000E+04, 0.127000E+04, 0.128000E+04, 0.129000E+04, - & 0.130000E+04, 0.131000E+04, 0.132000E+04, 0.133000E+04, - & 0.134000E+04, 0.135000E+04, 0.136000E+04, 0.137000E+04, - & 0.138000E+04, 0.139000E+04, 0.140000E+04, 0.141000E+04, - & 0.142000E+04, 0.143000E+04, 0.144000E+04, 0.145000E+04, - & 0.146000E+04, 0.147000E+04, 0.148000E+04, 0.149000E+04, - & 0.150000E+04, 0.151000E+04, 0.152000E+04, 0.153000E+04, - & 0.154000E+04, 0.155000E+04, 0.156000E+04, 0.157000E+04, - & 0.158000E+04, 0.159000E+04, 0.160000E+04, 0.161000E+04, - & 0.162000E+04, 0.163000E+04, 0.164000E+04, 0.165000E+04, - & 0.166000E+04, 0.167000E+04, 0.168000E+04, 0.169000E+04, - & 0.170000E+04, 0.171000E+04, 0.172000E+04, 0.173000E+04, - & 0.174000E+04, 0.175000E+04, 0.176000E+04, 0.177000E+04, - & 0.178000E+04, 0.179000E+04, 0.180000E+04, 0.181000E+04, - & 0.182000E+04, 0.183000E+04, 0.184000E+04, 0.185000E+04/ - DATA BANDL3 / - & 0.186000E+04, 0.187000E+04, 0.188000E+04, 0.189000E+04, - & 0.190000E+04, 0.191000E+04, 0.192000E+04, 0.193000E+04, - & 0.194000E+04, 0.195000E+04, 0.196000E+04, 0.197000E+04, - & 0.198000E+04, 0.199000E+04, 0.200000E+04, 0.201000E+04, - & 0.202000E+04, 0.203000E+04, 0.204000E+04, 0.205000E+04, - & 0.206000E+04, 0.207000E+04, 0.208000E+04, 0.209000E+04, - & 0.210000E+04, 0.211000E+04, 0.212000E+04, 0.213000E+04, - & 0.214000E+04, 0.215000E+04, 0.216000E+04, 0.217000E+04, - & 0.218000E+04, 0.219000E+04, 0.227000E+04/ - DATA BANDH1 / - & 0.100000E+02, 0.200000E+02, 0.300000E+02, 0.400000E+02, - & 0.500000E+02, 0.600000E+02, 0.700000E+02, 0.800000E+02, - & 0.900000E+02, 0.100000E+03, 0.110000E+03, 0.120000E+03, - & 0.130000E+03, 0.140000E+03, 0.150000E+03, 0.160000E+03, - & 0.170000E+03, 0.180000E+03, 0.190000E+03, 0.200000E+03, - & 0.210000E+03, 0.220000E+03, 0.230000E+03, 0.240000E+03, - & 0.250000E+03, 0.260000E+03, 0.270000E+03, 0.280000E+03, - & 0.290000E+03, 0.300000E+03, 0.310000E+03, 0.320000E+03, - & 0.330000E+03, 0.340000E+03, 0.350000E+03, 0.360000E+03, - & 0.370000E+03, 0.380000E+03, 0.390000E+03, 0.400000E+03, - & 0.410000E+03, 0.420000E+03, 0.430000E+03, 0.440000E+03, - & 0.450000E+03, 0.460000E+03, 0.470000E+03, 0.480000E+03, - & 0.490000E+03, 0.500000E+03, 0.510000E+03, 0.520000E+03, - & 0.530000E+03, 0.540000E+03, 0.550000E+03, 0.560000E+03, - & 0.670000E+03, 0.800000E+03, 0.900000E+03, 0.990000E+03, - & 0.107000E+04, 0.120000E+04, 0.121000E+04, 0.122000E+04/ - DATA BANDH2 / - & 0.123000E+04, 0.124000E+04, 0.125000E+04, 0.126000E+04, - & 0.127000E+04, 0.128000E+04, 0.129000E+04, 0.130000E+04, - & 0.131000E+04, 0.132000E+04, 0.133000E+04, 0.134000E+04, - & 0.135000E+04, 0.136000E+04, 0.137000E+04, 0.138000E+04, - & 0.139000E+04, 0.140000E+04, 0.141000E+04, 0.142000E+04, - & 0.143000E+04, 0.144000E+04, 0.145000E+04, 0.146000E+04, - & 0.147000E+04, 0.148000E+04, 0.149000E+04, 0.150000E+04, - & 0.151000E+04, 0.152000E+04, 0.153000E+04, 0.154000E+04, - & 0.155000E+04, 0.156000E+04, 0.157000E+04, 0.158000E+04, - & 0.159000E+04, 0.160000E+04, 0.161000E+04, 0.162000E+04, - & 0.163000E+04, 0.164000E+04, 0.165000E+04, 0.166000E+04, - & 0.167000E+04, 0.168000E+04, 0.169000E+04, 0.170000E+04, - & 0.171000E+04, 0.172000E+04, 0.173000E+04, 0.174000E+04, - & 0.175000E+04, 0.176000E+04, 0.177000E+04, 0.178000E+04, - & 0.179000E+04, 0.180000E+04, 0.181000E+04, 0.182000E+04, - & 0.183000E+04, 0.184000E+04, 0.185000E+04, 0.186000E+04/ - DATA BANDH3 / - & 0.187000E+04, 0.188000E+04, 0.189000E+04, 0.190000E+04, - & 0.191000E+04, 0.192000E+04, 0.193000E+04, 0.194000E+04, - & 0.195000E+04, 0.196000E+04, 0.197000E+04, 0.198000E+04, - & 0.199000E+04, 0.200000E+04, 0.201000E+04, 0.202000E+04, - & 0.203000E+04, 0.204000E+04, 0.205000E+04, 0.206000E+04, - & 0.207000E+04, 0.208000E+04, 0.209000E+04, 0.210000E+04, - & 0.211000E+04, 0.212000E+04, 0.213000E+04, 0.214000E+04, - & 0.215000E+04, 0.216000E+04, 0.217000E+04, 0.218000E+04, - & 0.219000E+04, 0.220000E+04, 0.238000E+04/ - real (kind=kind_rad) ALB1(21,7),ALB2(21,7),ALB3(21,6) -! - DATA ALB1/ .061,.062,.072,.087,.115,.163,.235,.318,.395,.472,.542, - & .604,.655,.693,.719,.732,.730,.681,.581,.453,.425,.061,.062,.070, - & .083,.108,.145,.198,.263,.336,.415,.487,.547,.595,.631,.656,.670, - & .652,.602,.494,.398,.370,.061,.061,.068,.079,.098,.130,.174,.228, - & .290,.357,.424,.498,.556,.588,.603,.592,.556,.488,.393,.342,.325, - & .061,.061,.065,.073,.086,.110,.150,.192,.248,.306,.360,.407,.444, - & .469,.480,.474,.444,.386,.333,.301,.290,.061,.061,.065,.070,.082, - & .101,.131,.168,.208,.252,.295,.331,.358,.375,.385,.377,.356,.320, - & .288,.266,.255,.061,.061,.063,.068,.077,.092,.114,.143,.176,.210, - & .242,.272,.288,.296,.300,.291,.273,.252,.237,.266,.220,.061,.061, - & .062,.066,.072,.084,.103,.127,.151,.176,.198,.219,.236,.245,.250, - & .246,.235,.222,.211,.205,.200/ - DATA ALB2/ .061,.061,.061,.065,.071,.079,.094,.113,.134,.154,.173, - & .185,.190,.193,.193,.190,.188,.185,.182,.180,.178,.061,.061,.061, - & .064,.067,.072,.083,.099,.117,.135,.150,.160,.164,.165,.164,.162, - & .160,.159,.158,.157,.157,.061,.061,.061,.062,.065,.068,.074,.084, - & .097,.111,.121,.127,.130,.131,.131,.130,.129,.127,.126,.125,.122, - & .061,.061,.061,.061,.062,.064,.070,.076,.085,.094,.101,.105,.107, - & .106,.103,.100,.097,.096,.095,.095,.095,.061,.061,.061,.060,.061, - & .062,.065,.070,.075,.081,.086,.089,.090,.088,.084,.080,.077,.075, - & .074,.074,.074,.061,.061,.060,.060,.060,.061,.063,.065,.068,.072, - & .076,.077,.076,.074,.071,.067,.064,.062,.061,.061,.061,.061,.061, - & .060,.060,.060,.060,.061,.062,.065,.068,.069,.069,.068,.065,.061, - & .058,.055,.054,.053,.052,.052/ - DATA ALB3/ .061,.061,.060,.060,.060,.060,.060,.060,.062,.065,.065, - & .063,.060,.057,.054,.050,.047,.046,.045,.044,.044,.061,.061,.060, - & .060,.060,.059,.059,.059,.059,.059,.058,.055,.051,.047,.043,.039, - & .035,.033,.032,.031,.031,.061,.061,.060,.060,.060,.059,.059,.058, - & .057,.056,.054,.051,.047,.043,.039,.036,.033,.030,.028,.027,.026, - & .061,.061,.060,.060,.060,.059,.059,.058,.057,.055,.052,.049,.045, - & .040,.036,.032,.029,.027,.026,.025,.025,.061,.061,.060,.060,.060, - & .059,.059,.058,.056,.053,.050,.046,.042,.038,.034,.031,.028,.026, - & .025,.025,.025,.061,.061,.060,.060,.059,.058,.058,.057,.055,.053, - & .050,.046,.042,.038,.034,.030,.028,.029,.025,.025,.025/ -! -! INITIALISATION - ARNDM(1:64)=ARNDM1(1:64) - ARNDM(65:128)=ARNDM2(1:64) - ARNDM(129:163)=ARNDM3(1:35) - BRNDM(1:64)=BRNDM1(1:64) - BRNDM(65:128)=BRNDM2(1:64) - BRNDM(129:163)=BRNDM3(1:35) - AP(1:64)=AP1(1:64) - AP(65:128)=AP2(1:64) - AP(129:163)=AP3(1:35) - BP(1:64)=BP1(1:64) - BP(65:128)=BP2(1:64) - BP(129:163)=BP3(1:35) - ATP(1:64)=ATP1(1:64) - ATP(65:128)=ATP2(1:64) - ATP(129:163)=ATP3(1:35) - BTP(1:64)=BTP1(1:64) - BTP(65:128)=BTP2(1:64) - BTP(129:163)=BTP3(1:35) - BETAD(1:64)=BETAD1(1:64) - BETAD(65:128)=BETAD2(1:64) - BETAD(129:163)=BETAD3(1:35) - BANDLO(1:64)=BANDL1(1:64) - BANDLO(65:128)=BANDL2(1:64) - BANDLO(129:163)=BANDL3(1:35) - BANDHI(1:64)=BANDH1(1:64) - BANDHI(65:128)=BANDH2(1:64) - BANDHI(129:163)=BANDH3(1:35) - ALBD(1:21,1:7)=ALB1(1:21,1:7) - ALBD(1:21,8:14)=ALB2(1:21,1:7) - ALBD(1:21,15:20)=ALB3(1:21,1:6) -!**************************************** -!***COMPUTE LOCAL QUANTITIES AND AO3,BO3,AB15 -!....FOR NARROW-BANDS... -! - L = LP1 - 1 - LP2 = LP1 + 1 -! - DO N=1,NBLW - ANB(N) = ARNDM(N) - BNB(N) = BRNDM(N) - CENTNB(N) = HAF * (BANDLO(N) + BANDHI(N)) - DELNB(N) = BANDHI(N) - BANDLO(N) - BETANB(N) = BETAD(N) - ENDDO - AB15(1) = ANB(57)*BNB(57) - AB15(2) = ANB(58)*BNB(58) -!....FOR WIDE BANDS... - AB15WD = AWIDE*BWIDE -! -!***COMPUTE RATIOS OF CONT. COEFFS - SKC1R = BETAWD / BETINW - SKO3R = BETAD(61) / BETINW - SKO2D = ONE / BETINW -! -!****BEGIN TABLE COMPUTATIONS HERE*** -!***COMPUTE TEMPS, MASSES FOR TABLE ENTRIES -!---NOTE: THE DIMENSIONING AND INITIALIZATION OF XTEMV AND OTHER ARRAYS -! WITH DIMENSION OF 28 IMPLY A RESTRICTION OF MODEL TEMPERATURES FROM -! 100K TO 370K. -!---THE DIMENSIONING OF ZMASS,ZROOT AND OTHER ARRAYS WITH DIMENSION OF -! 180 IMPLY A RESTRICTION OF MODEL H2O AMOUNTS SUCH THAT OPTICAL PATHS -! ARE BETWEEN 10**-16 AND 10**2, IN CGS UNITS. - ZMASS(1) = H1M16 - DO J=1,180 - JP = J + 1 - ZROOT(J) = SQRT(ZMASS(J)) - ZMASS(JP) = ZMASS(J)*H1P25892 - ENDDO - DO I=1,28 - XTEMV(I) = HNINETY + TEN*I - TFOUR(I) = 1.0 / (XTEMV(I)*XTEMV(I)*XTEMV(I)*XTEMV(I)) - FORTCU(I) = 1.0 / (FOUR*XTEMV(I)*XTEMV(I)*XTEMV(I)) - ENDDO -!******THE COMPUTATION OF SOURCE,DSRCE IS NEEDED ONLY -! FOR THE COMBINED WIDE-BAND CASE.TO OBTAIN THEM,THE SOURCE -! MUST BE COMPUTED FOR EACH OF THE (NBLX) WIDE BANDS(=SRCWD) -! THEN COMBINED (USING IBAND) INTO SOURCE. - DO N=1,NBLY - DO I=1,28 - SOURCE(I,N) = ZERO - ENDDO - ENDDO - DO N=1,NBLX - DO I=1,28 - SRCWD(I,N)=ZERO - ENDDO - ENDDO -!---BEGIN FREQ. LOOP (ON N) - DO N=1,NBLX - IF (N.LE.46) THEN -!***THE 160-1200 BAND CASES - CENT = CENTNB(N+16) - DEL = DELNB(N+16) - BDLO = BANDLO(N+16) - BDHI = BANDHI(N+16) - ENDIF - IF (N.EQ.NBLX) THEN -!***THE 2270-2380 BAND CASE - CENT = CENTNB(NBLW) - DEL = DELNB(NBLW) - BDLO = BANDLO(NBLW) - BDHI = BANDHI(NBLW) - ENDIF -!***FOR PURPOSES OF ACCURACY, ALL EVALUATIONS OF PLANCK FCTNS ARE MADE -! ON 10 CM-1 INTERVALS, THEN SUMMED INTO THE (NBLX) WIDE BANDS. - NSUBDS = (DEL-H1M3)/10+1 - DO NSB=1,NSUBDS - IF (NSB.NE.NSUBDS) THEN - CNUSB(NSB) = TEN*(NSB-1) + BDLO + FIVE - DNUSB(NSB) = TEN - ELSE - CNUSB(NSB) = HAF * (TEN*(NSB-1)+BDLO+BDHI) - DNUSB(NSB) = BDHI - (TEN*(NSB-1)+BDLO) - ENDIF - C1 = (H37412M5)*CNUSB(NSB)**3 -!---BEGIN TEMP. LOOP (ON I) - DO I=1,28 - X(I) = H1P4387*CNUSB(NSB) / XTEMV(I) - X1(I) = EXP(X(I)) - SRCS(I) = C1 / (X1(I)-ONE) - SRCWD(I,N) = SRCWD(I,N)+SRCS(I)*DNUSB(NSB) - ENDDO - ENDDO - ENDDO ! End of N Loop! -!***THE FOLLOWING LOOPS CREATE THE COMBINED WIDE BAND QUANTITIES SOURCE -! AND DSRCE - DO N=1,40 - DO I=1,28 - SOURCE(I,IBAND(N)) = SOURCE(I,IBAND(N)) + SRCWD(I,N) - ENDDO - ENDDO - DO N=9,NBLY - DO I=1,28 - SOURCE(I,N) = SRCWD(I,N+32) - ENDDO - ENDDO - DO N=1,NBLY - DO I=1,27 - DSRCE(I,N) = (SOURCE(I+1,N)-SOURCE(I,N))*HP1 - ENDDO - ENDDO - DO N=1,NBLW - ALFANB(N) = BNB(N)*ANB(N) - AROTNB(N) = SQRT(ALFANB(N)) - ENDDO -!***FIRST COMPUTE PLANCK FCTNS (SRC1NB) AND DERIVATIVES (DBDTNB) FOR -! USE IN TABLE EVALUATIONS. THESE ARE DIFFERENT FROM SOURCE,DSRCE -! BECAUSE DIFFERENT FREQUENCY PTS ARE USED IN EVALUATION, THE FREQ. -! RANGES ARE DIFFERENT, AND THE DERIVATIVE ALGORITHM IS DIFFERENT. -! - DO N=1,NBLW - CENT = CENTNB(N) - DEL = DELNB(N) -!---NOTE: AT PRESENT, THE IA LOOP IS ONLY USED FOR IA=2. THE LOOP STRUCT -! IS KEPT SO THAT IN THE FUTURE, WE MAY USE A QUADRATURE SCHEME FOR -! THE PLANCK FCTN EVALUATION, RATHER THAN USE THE MID-BAND FREQUENCY. - DO IA=1,3 - ANU = CENT + HAF*(IA-2)*DEL - C1 = (H37412M5)*ANU*ANU*ANU + H1M20 -!---TEMPERATURE LOOP--- - DO I=1,28 - X(I) = H1P4387 * ANU / XTEMV(I) - X1(I) = EXP(X(I)) - SC(I) = C1 / ((X1(I)-ONE)+H1M20) - DSC(I) = SC(I)*SC(I)*X(I)*X1(I) / (XTEMV(I)*C1) - ENDDO - IF (IA.EQ.2) THEN - DO I=1,28 - SRC1NB(I,N ) =DEL * SC(I) - DBDTNB(I,N) = DEL * DSC(I) - ENDDO - ENDIF - ENDDO - ENDDO -!***NEXT COMPUTE R1,R2,S2,AND T3- COEFFICIENTS USED FOR E3 FUNCTION -! WHEN THE OPTICAL PATH IS LESS THAN 10-4. IN THIS CASE, WE ASSUME A -! DIFFERENT DEPENDENCE ON (ZMASS). -!---ALSO OBTAIN R1WD, WHICH IS R1 SUMMED OVER THE 160-560 CM-1 RANGE - DO I=1,28 - SUM4(I) = ZERO - SUM6(I) = ZERO - SUM7(I) = ZERO - SUM8(I) = ZERO - SUM4WD(I) = ZERO - ENDDO - DO N=1,NBLW - CENT=CENTNB(N) -!***PERFORM SUMMATIONS FOR FREQ. RANGES OF 0-560,1200-2200 CM-1 FOR SUM4 -! SUM6,SUM7,SUM8 - IF (CENT.LT.560. .OR. CENT.GT.1200..AND.CENT.LE.2200.) THEN - DO I=1,28 - SUM4(I) = SUM4(I) + SRC1NB(I,N) - SUM6(I) = SUM6(I) + DBDTNB(I,N) - SUM7(I) = SUM7(I) + DBDTNB(I,N) * AROTNB(N) - SUM8(I) = SUM8(I) + DBDTNB(I,N) * ALFANB(N) - ENDDO - ENDIF -!***PERFORM SUMMATIONS OVER 160-560 CM-1 FREQ RANGE FOR E1 CALCS (SUM4WD - IF (CENT.GT.160. .AND. CENT.LT.560.) THEN - DO I=1,28 - SUM4WD(I) = SUM4WD(I) + SRC1NB(I,N) - ENDDO - ENDIF - ENDDO - DO I=1,28 - R1(I) = SUM4(I) * TFOUR(I) - R2(I) = SUM6(I) * FORTCU(I) - S2(I) = SUM7(I) * FORTCU(I) - T3(I) = SUM8(I) * FORTCU(I) - R1WD(I) = SUM4WD(I) * TFOUR(I) - ENDDO - DO J=1,180 - DO I=1,28 - SUM(I,J) = ZERO - PERTSM(I,J) = ZERO - SUM3(I,J) = ZERO - SUMWDE(I,J) = ZERO - ENDDO - ENDDO -!---FREQUENCY LOOP BEGINS--- - DO N=1,NBLW - CENT = CENTNB(N) -!***PERFORM CALCULATIONS FOR FREQ. RANGES OF 0-560,1200-2200 CM-1 - IF (CENT.LT.560. .OR. CENT.GT.1200..AND.CENT.LE.2200.) THEN - DO J=1,180 - X2(J) = AROTNB(N) * ZROOT(J) - EXPO(J) = EXP(-X2(J)) - ENDDO - DO J=1,180 - IF (X2(J).GE.HUNDRED) THEN - EXPO(J) = ZERO - ENDIF - ENDDO - DO J=121,180 - FAC(J) = ZMASS(J)*(ONE-(ONE+X2(J))*EXPO(J))/(X2(J)*X2(J)) - ENDDO - DO J=1,180 - DO I=1,28 - SUM(I,J) = SUM(I,J) + SRC1NB(I,N)*EXPO(J) - PERTSM(I,J) = PERTSM(I,J) + DBDTNB(I,N)*EXPO(J) - ENDDO - ENDDO - DO J=121,180 - DO I=1,28 - SUM3(I,J) = SUM3(I,J) + DBDTNB(I,N)*FAC(J) - ENDDO - ENDDO - ENDIF -!---COMPUTE SUM OVER 160-560 CM-1 RANGE FOR USE IN E1 CALCS (SUMWDE) - IF (CENT.GT.160. .AND. CENT.LT.560.) THEN - DO J=1,180 - DO I=1,28 - SUMWDE(I,J) = SUMWDE(I,J) + SRC1NB(I,N)*EXPO(J) - ENDDO - ENDDO - ENDIF - ENDDO - I1=0 - DO J=1,180 - DO I=1,28 - I1=I1+1 - EM1V(I1) = SUM(I,J) * TFOUR(I) - T1(I1) = PERTSM(I,J) * FORTCU(I) - ENDDO - ENDDO - I1=120*28 - DO J=121,180 - DO I=1,28 - I1=I1+1 - EM3V(I1) = SUM3(I,J) * FORTCU(I) - ENDDO - ENDDO - I1=0 - DO J=1,179 - DO I=1,28 - I1=I1+1 - T2(I1)=(T1(I1+28)-T1(I1))*TEN - ENDDO - ENDDO - I1=0 - DO J=1,180 - DO I=1,27 - T4(I1+I)=(T1(I1+I+1)-T1(I1+I))*HP1 - ENDDO - I1 = I1 + 28 - T4(I1)=ZERO - ENDDO - I1=179*28 - DO I=1,28 - I1=I1+1 - T2(I1)=ZERO - ENDDO - I1=0 - DO J=1,2 - DO I=1,28 - I1=I1+1 - EM1V(I1)=R1(I) - ENDDO - ENDDO - I1=0 - DO J=1,120 - DO I=1,28 - I1=I1+1 - EM3V(I1)=R2(I)/TWO-S2(I)*SQRT(ZMASS(J))/THREE - & + T3(I)*ZMASS(J)/EIGHT - ENDDO - ENDDO - I1=120*28 - DO J=121,180 - DO I=1,28 - I1=I1+1 - EM3V(I1)=EM3V(I1)/ZMASS(J) - ENDDO - ENDDO -!***NOW COMPUTE E1 TABLES FOR 160-560 CM-1 BANDS ONLY. -! WE USE R1WD AND SUMWDE OBTAINED ABOVE. - I1=0 - DO J=1,180 - DO I=1,28 - I1=I1+1 - EM1VW(I1)=SUMWDE(I,J)*TFOUR(I) - ENDDO - ENDDO - I1=0 - DO J=1,2 - DO I=1,28 - I1=I1+1 - EM1VW(I1)=R1WD(I) - ENDDO - ENDDO -! - RETURN - END diff --git a/src/fim/FIMsrc/fim/column/machine.f b/src/fim/FIMsrc/fim/column/machine.f deleted file mode 100644 index 03c18b0..0000000 --- a/src/fim/FIMsrc/fim/column/machine.f +++ /dev/null @@ -1,15 +0,0 @@ - MODULE MACHINE - - IMPLICIT NONE - SAVE -! Machine dependant constants - integer, parameter :: kind_io4 = 4, kind_io8 = 8 , kind_ior = 8 - &, kind_evod = 8, kind_dbl_prec = 8 - &, kind_rad = selected_real_kind(13,60) ! the '60' maps to 64-bit real - &, kind_phys = selected_real_kind(13,60) ! the '60' maps to 64-bit real - &, kind_REAL = 8 ! used in cmp_comm - &, kind_INTEGER = 4 ! -,,- -! - real(kind=kind_evod), parameter :: mprec = 1.e-12 ! machine precision to restrict dep - - END MODULE MACHINE diff --git a/src/fim/FIMsrc/fim/column/module.f b/src/fim/FIMsrc/fim/column/module.f deleted file mode 100644 index 6cf1f07..0000000 --- a/src/fim/FIMsrc/fim/column/module.f +++ /dev/null @@ -1,328 +0,0 @@ - MODULE HCON - - USE MACHINE - IMPLICIT NONE - SAVE - - - real (kind=kind_rad) AMOLWT, CSUBP, DIFFCTR, G, GINV - &, GRAVDR, O3DIFCTR, P0, P0INV - &, GP0INV, P0XZP2, P0XZP8, P0X2 - &, RADCON, RADCON1, RATCO2MW, RATH2OMW - &, RGASK, RGASSP, SECPDA -! -!***THE FOLLOWING DATA ARE LEVEL-INDEPENDENT - DATA G/980.665/ -! - real (kind=kind_rad) HUNDRED, HNINETY, SIXTY, FIFTY, TEN, EIGHT - &, FIVE, FOUR, THREE, TWO, ONE, HAF - &, QUARTR, ZERO -! - real (kind=kind_rad) H83E26, H71E26, H1E15 , H1E13, H1E11 - &, H1E8, H2E6, H1E6, H69766E5,H4E5 - &, H165E5, H5725E4, H488E4, H1E4, H24E3 - &, H20788E3, H2075E3, H18E3, H1224E3 - &, H67390E2, H5E2, H3082E2, H3E2, H2945E2 - &, H29316E2, H26E2, H25E2, H23E2, H2E2 - &, H15E2, H1386E2, H1036E2, H8121E1, H35E1 - &, H3116E1, H28E1, H181E1, H18E1, H161E1 - &, H16E1, H1226E1, H9P94, H6P08108,H3P6 - &, H3P5, H2P9, H2P8, H2P5, H1P8 - &, H1P4387, H1P41819,H1P4, H1P25892,H1P082 - &, HP816, HP805, HP8, HP60241 - &, HP602409, HP6, HP526315,HP518, HP5048 - &, HP3795, HP369, HP26, HP228, HP219 - &, HP166666, HP144, HP118666,HP1 - real (kind=kind_rad) H658M2, H625M2, H44871M2, H44194M2 - &, H42M2, H41666M2, H28571M2, H2118M2 - &, H129M2, H1M2, H559M3, H3M3 - &, H235M3, H1M3, H987M4, H323M4 - &, H3M4, H285M4, H1M4, H75826M4 - &, H6938M5, H394M5, H37412M5, H15M5 - &, H1439M5, H128M5, H102M5, H1M5 - &, H7M6, H4999M6, H451M6, H25452M6 - &, H1M6, H391M7, H1174M7, H8725M8 - &, H327M8, H257M8, H1M8, H23M10 - &, H14M10, H11M10, H1M10, H83M11 - &, H82M11, H8M11, H77M11, H72M11 - &, H53M11 , H48M11, H44M11, H42M11 - &, H37M11, H35M11, H32M11, H3M11 - &, H28M11, H24M11, H23M11, H2M11 - &, H18M11, H15M11, H14M11, H114M11 - &, H11M11, H1M11, H96M12, H93M12 - &, H77M12, H74M12, H65M12, H62M12 - &, H6M12, H45M12, H44M12, H4M12 - &, H38M12, H37M12, H3M12, H29M12 - &, H28M12, H24M12, H21M12, H16M12 - &, H14M12, H12M12, H8M13, H46M13 - &, H36M13, H135M13, H12M13, H1M13 - &, H3M14, H15M14, H14M14, H101M16 - &, H1M16, H1M17, H1M18, H1M19 - &, H1M20, H1M21, H1M22, H1M23 - &, H1M24, H26M30, H14M30, H25M31 - &, H21M31, H12M31, H9M32, H55M32 - &, H45M32, H4M33, H62M34 -! - real (kind=kind_rad) HM2M2, HM6666M2, HMP5, HMP575 - &, HMP66667, HMP805, HM1EZ, HM13EZ - &, HM19EZ, HM1E1, HM1597E1, HM161E1 - &, HM1797E1, HM181E1, HM8E1, HM1E2 -! - END MODULE HCON - - MODULE RNDDTA - - USE MACHINE - IMPLICIT NONE - - SAVE -! - integer nblw, nblx, nbly, nblm -! - PARAMETER (NBLW=163,NBLX=47,NBLY=15) - PARAMETER (NBLM=NBLY-1) -! -! COMMON BLOCK BANDTA CONTAINS RANDOM BAND PARAMETERS FOR THE LW -! CALCULATIONS USING 10 CM-1 WIDE BANDS.THE 15 UM CO2 COMPLEX -! IS 2 BANDS,560-670 AND 670-800 CM-1. OZONE COEFFICIENTS ARE -! IN 3 BANDS,670-800 (14.1 UM),990-1070 AND 1070-1200 (9.6 UM). -! THE (NBLW) BANDS NOW INCLUDE: -! 56 BANDS, 10 CM-1 WIDE 0 - 560 CM-1 -! 2 BANDS, 15 UM COMPLEX 560 - 670 CM-1 -! 670 - 800 CM-1 -! 3 "CONTINUUM" BANDS 800 - 900 CM-1 -! 900 - 990 CM-1 -! 1070 - 1200 CM-1 -! 1 BAND FOR 9.6 UM BAND 990 - 1070 CM-1 -! 100 BANDS, 10 CM-1 WIDE 1200 - 2200 CM-1 -! 1 BAND FOR 4.3 UM SRC 2270 - 2380 CM-1 -! THUS NBLW PRESENTLY EQUALS 163 -! ALL BANDS ARE ARRANGED IN ORDER OF INCREASING WAVENUMBER -! -! ARNDM = RANDOM "A" PARAMETER FOR (NBLW) BANDS -! BRNDM = RANDOM "B" PARAMETER FOR (NBLW) BANDS -! BETAD = CONTINUUM COEFFICIENTS FOR (NBLW) BANDS -! AP,BP = CAPPHI COEFFICIENTS FOR (NBLW) BANDS -! ATP,BTP = CAPPSI COEFFICIENTS FOR (NBLW) BANDS -! BANDLO = LOWEST FREQUENCY IN EACH OF (NBLW) FREQ. BANDS -! BANDHI = HIGHEST FREQUENCY IN EACH OF (NBLW) FREQ. BANDS -! AO3RND = RANDOM "A" PARAMETER FOR OZONE IN (3) OZONE -! BANDS -! BO3RND = RANDOM "B" PARAMETER FOR OZONE IN (3) OZONE -! BANDS -! AB15 = THE PRODUCT ARNDM*BRNDM FOR THE TWO BANDS -! REPRESENTING THE 15 UM BAND COMPLEX OF CO2 -! DATA FOR ARNDM,BRNDM,AP,BP,ATP,BTP,AO3RND,BO3RND ARE OBTAINED BY -! USING THE AFGL 1982 CATALOG. CONTINUUM COEFFICIENTS ARE FROM -! ROBERTS (1976). - real (kind=kind_rad) ARNDM(NBLW),BRNDM(NBLW),BETAD(NBLW),AP(NBLW) - &, BP(NBLW),ATP(NBLW),BTP(NBLW),BANDLO(NBLW) - &, BANDHI(NBLW),AO3RND(3),BO3RND(3),AB15(2) - DATA AO3RND / - & 0.543368E+02, 0.234676E+04, 0.384881E+02/ - DATA BO3RND / - & 0.526064E+01, 0.922424E+01, 0.496515E+01/ -! -! COMMON BLOCK BDWIDE CONTAINS RANDOM BAND PARAMETERS FOR SPECIFIC -! WIDE BANDS. AT PRESENT,THE INFORMATION CONSISTS OF 1) RANDOM -! MODEL PARAMETERS FOR THE 15 UM BAND,560-800 CM-1; 2) THE -! CONTINUUM COEFFICIENT FOR THE 800-990,1070-1200 CM-1 BAND -! SPECIFICALLY: -! AWIDE = RANDOM "A" PARAMETER FOR BAND -! BWIDE = RANDOM "B" PARAMETER FOR BAND -! BETAWD = CONTINUUM COEFFICIENTS FOR BAND -! APWD,BPWD = CAPPHI COEFFICIENTS FOR BAND -! ATPWD,BTPWD = CAPPSI COEFFICIENTS FOR BAND -! BDLOWD = LOWEST FREQUENCY IN EACH FREQ BAND -! BDHIWD = HIGHEST FREQUENCY IN EACH FREQ BAND -! AB15WD = THE PRODUCT ARNDM*BRNDM FOR THE ONE BAND -! REPRESENTING THE 15 UM BAND COMPLEX OF CO2 -! BETINW = CONT.COEFFICIENT FOR A SPECIFIED WIDE -! FREQ.BAND (800-990 AND 1070-1200 CM-1). -! SKO2D = 1./BETINW, USED IN SPA88 FOR CONT. COEFFS -! SKC1R = BETAWD/BETINW, USED FOR CONT. COEFF. FOR -! 15 UM BAND IN FST88 -! SKO3R = RATIO OF CONT. COEFF. FOR 9.9 UM BAND TO -! BETINW, USED FOR 9.6 UM CONT COEFF IN FST88 -! DATA FOR AWIDE,BWIDE,APWD,BPWD,ATPWD,BTPWD,AO3WD,BO3WD ARE -! OBTAINED BY USING THE AFGL 1982 CATALOG. CONTINUUM COEFFICIENTS -! ARE FROM ROBERTS (1976). - real (kind=kind_rad) AWIDE,BWIDE,BETAWD,APWD,BPWD,ATPWD,BTPWD, - & BDLOWD,BDHIWD,BETINW,AB15WD,SKO2D,SKC1R,SKO3R - DATA AWIDE / - & 0.309801E+01/ - DATA BWIDE / - & 0.495357E-01/ - DATA APWD / - & 0.177115E-01/ - DATA BPWD / - & -0.545226E-04/ - DATA ATPWD / - & 0.187967E-01/ - DATA BTPWD / - & -0.567449E-04/ - DATA BETAWD / - & 0.347839E+02/ - DATA BETINW / - & 0.766811E+01/ - DATA BDLOWD / - & 0.560000E+03/ - DATA BDHIWD / - & 0.800000E+03/ -! -! COMMON BLOCK BDCOMB CONTAINS RANDOM BAND PARAMETERS FOR THE LW -! CALCULATIONS USING COMBINED WIDE FREQUENCY BANDS BETWEEN 160 AND -! 1200 CM-1,AS WELL AS THE 2270-2380 BAND FOR SOURCE CALC. -! BANDS 1-8: COMBINED WIDE FREQUENCY BANDS FOR 160-560 CM-1 -! BANDS 9-14: FREQUENCY BANDS,AS IN BANDTA (NARROW BANDS) -! FOR 560-1200 CM-1 -! BAND 15: FREQUENCY BAND 2270-2380 CM-1,USED FOR SOURCE -! CALCULATION ONLY -! THUS NBLY PRESENTLY EQUALS 15 -! -! BANDS ARE ARRANGED IN ORDER OF INCREASING WAVENUMBER -! ACOMB = RANDOM "A" PARAMETER FOR (NBLY) BANDS -! BCOMB = RANDOM "B" PARAMETER FOR (NBLY) BANDS -! BETACM = CONTINUUM COEFFICIENTS FOR (NBLY) BANDS -! APCM,BPCM = CAPPHI COEFFICIENTS FOR (NBLY) BANDS -! ATPCM,BTPCM = CAPPSI COEFFICIENTS FOR (NBLY) BANDS -! BDLOCM = LOWEST FREQUENCY IN EACH OF (NBLY) FREQ. BANDS -! BDHICM = HIGHEST FREQUENCY IN EACH OF (NBLY) FREQ. BANDS -! AO3CM = RANDOM "A" PARAMETER FOR OZONE IN (3) OZONE -! BANDS -! BO3CM = RANDOM "B" PARAMETER FOR OZONE IN (3) OZONE -! BANDS -! AB15CM = THE PRODUCT ARNDM*BRNDM FOR THE TWO BANDS -! REPRESENTING THE 15 UM BAND COMPLEX OF CO2 -! BETINC = CONT.COEFFICIENT FOR A SPECIFIED WIDE -! FREQ.BAND (800-990 AND 1070-1200 CM-1). -! IBAND = INDEX NO OF THE 40 WIDE BANDS USED IN -! COMBINED WIDE BAND CALCULATIONS. IN OTHER -! WORDS,INDEX TELLING WHICH OF THE 40 WIDE -! BANDS BETWEEN 160-560 CM-1 ARE INCLUDED IN -! EACH OF THE FIRST 8 COMBINED WIDE BANDS -! DATA FOR ACOMB,BCOMB,APCM,BPCM,ATPCM,BTPCM,AO3CM,BO3CM ARE -! OBTAINED BY USING THE AFGL 1982 CATALOG. CONTINUUM COEFFICIENTS -! ARE FROM ROBERTS (1976). IBAND INDEX VALUES ARE OBTAINED BY -! EXPERIMENTATION. - integer IBAND(40) - real (kind=kind_rad) ACOMB(NBLY),BCOMB(NBLY), - & BETACM(NBLY),APCM(NBLY),BPCM(NBLY),ATPCM(NBLY), - & BTPCM(NBLY),BDLOCM(NBLY),BDHICM(NBLY),BETINC, - & AO3CM(3),BO3CM(3),AB15CM(2) - DATA ACOMB / - & 0.152070E+05, 0.332194E+04, 0.527177E+03, 0.163124E+03, - & 0.268808E+03, 0.534591E+02, 0.268071E+02, 0.123133E+02, - & 0.600199E+01, 0.640803E+00, 0.501549E-01, 0.167961E-01, - & 0.178110E-01, 0.170166E+00, 0.537083E-02/ - DATA BCOMB / - & 0.152538E+00, 0.118677E+00, 0.103660E+00, 0.100119E+00, - & 0.127518E+00, 0.118409E+00, 0.904061E-01, 0.642011E-01, - & 0.629660E-01, 0.643346E-01, 0.717082E-01, 0.629730E-01, - & 0.875182E-01, 0.857907E-01, 0.214005E+00/ - DATA APCM / - & -0.671879E-03, 0.654345E-02, 0.143657E-01, 0.923593E-02, - & 0.117022E-01, 0.159596E-01, 0.181600E-01, 0.145013E-01, - & 0.170062E-01, 0.233303E-01, 0.256735E-01, 0.274745E-01, - & 0.279259E-01, 0.197002E-01, 0.349782E-01/ - DATA BPCM / - & -0.113520E-04, -0.323965E-04, -0.448417E-04, -0.230779E-04, - & -0.361981E-04, -0.145117E-04, 0.198349E-04, -0.486529E-04, - & -0.550050E-04, -0.684057E-04, -0.447093E-04, -0.778390E-04, - & -0.982953E-04, -0.772497E-04, -0.748263E-04/ - DATA ATPCM / - & -0.106346E-02, 0.641531E-02, 0.137362E-01, 0.922513E-02, - & 0.136162E-01, 0.169791E-01, 0.206959E-01, 0.166223E-01, - & 0.171776E-01, 0.229724E-01, 0.275530E-01, 0.302731E-01, - & 0.281662E-01, 0.199525E-01, 0.370962E-01/ - DATA BTPCM / - & -0.735731E-05, -0.294149E-04, -0.505592E-04, -0.280894E-04, - & -0.492972E-04, -0.341508E-04, -0.362947E-04, -0.250487E-04, - & -0.521369E-04, -0.746260E-04, -0.744124E-04, -0.881905E-04, - & -0.933645E-04, -0.664045E-04, -0.115290E-03/ - DATA BETACM / - & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, - & 0.188625E+03, 0.144293E+03, 0.174098E+03, 0.909366E+02, - & 0.497489E+02, 0.221212E+02, 0.113124E+02, 0.754174E+01, - & 0.589554E+01, 0.495227E+01, 0.000000E+00/ - DATA IBAND / - & 2, 1, 2, 2, 1, 2, 1, 3, 2, 2, - & 3, 2, 2, 4, 2, 4, 2, 3, 3, 2, - & 4, 3, 4, 3, 7, 5, 6, 7, 6, 5, - & 7, 6, 7, 8, 6, 6, 8, 8, 8, 8/ -! -!***THE FOLLOWING DATA ARE LEVEL-INDEPENDENT -!CCCC DATA RCO2/3.3E-4/ -! DATA G/980.665/ -!CCCC DATA CTAUDA/.5/ -!CCCC DATA CSOLAR/1.96/ -!CCCC DATA CCOSZ/.5/ -! B0,B1,B2,B3 ARE COEFFICIENTS USED TO CORRECT FOR THE USE OF 250K IN -! THE PLANCK FUNCTION USED IN EVALUATING PLANCK-WEIGHTED CO2 -! TRANSMISSION FUNCTIONS. (SEE REF. 4) -! DATA B0,B1,B2,B3/-.51926410E-4,-.18113332E-3, -! 1 -.10680132E-5,-.67303519E-7/ -! ******************************************************************* -! * * -! * B L C K F S FROM G F D L * -! * UNUSED DATA CLEANED OUT - NOV 86 AND MAR 89 ..K.A.CAMPANA.... * -! & * -! ******************************************************************* -! -! FOR SEASONAL VARIATION -! SEASON=1,2,3,4 FOR WINTER,SPRING,SUMMER,FALL ONLY (NOT ACTIVE) -! SEASON=5 - SEASONAL VARIATION(I.E.INTERPOLATE TO DAY OF FCST) -! -! INTEGER SEASON -! COMMON/DIUCON/SEASON,FCSTDA,JTIME(5),DAZ(12),JDNMC, -! & FJDNMC,TSLAG,RLAG,TIMIN,TPI,HPI,YEAR,DAY,DHR,IXXXX -! DATA SEASON/5/ -! DATA TSLAG/45.25/, RLAG/14.8125/ -! DATA DAY/86400./, YEAR/365.25/ -! DATA TPI/6.283185308/, HPI/1.570796327/ -! DATA DAY/86400./, YEAR/365.25/ -! DATA TPI/6.283185308/, HPI/1.570796327/ -! DATA JTIME/0,1,0,0,0/ -! DATA DHR/2./ -! DATA DAZ/0.,31.,59.,90.,120.,151.,181.,212.,243.,273.,304.,334./ -! -! SEA SURFACE ALBEDO DATA -! - real (kind=kind_rad) ALBD(21,20),ZA(20),TRN(21),DZA(19) - DATA ZA/90.,88.,86.,84.,82.,80.,78.,76.,74.,70.,66.,62.,58.,54., - & 50.,40.,30.,20.,10.,0.0/ - DATA TRN/.00,.05,.10,.15,.20,.25,.30,.35,.40,.45,.50,.55,.60,.65, - & .70,.75,.80,.85,.90,.95,1.00/ - DATA DZA/8*2.0,6*4.0,5*10.0/ -! - real (kind=kind_rad) - & EM1V(5040),EM1VW(5040),T1(5041), - & T2(5040),T4(5040),EM3V(5040) -cjfe & EM1(28,180),EM1WDE(28,180),TABLE1(28,180), -cjfe & TABLE2(28,180),TABLE3(28,180),EM3(28,180) -! - real (kind=kind_rad) DELCM(NBLY) - DATA DELCM / - & 0.300000E+02, 0.110000E+03, 0.600000E+02, 0.400000E+02, - & 0.200000E+02, 0.500000E+02, 0.400000E+02, 0.500000E+02, - & 0.110000E+03, 0.130000E+03, 0.100000E+03, 0.900000E+02, - & 0.800000E+02, 0.130000E+03, 0.110000E+03/ -! -! real (kind=kind_rad) SC -! DATA SC/2.0/ -! - END MODULE RNDDTA -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - MODULE COMCD1 - - USE MACHINE - IMPLICIT NONE - - SAVE - -cmy delete rocp alread in module physcons - REAL (KIND=kind_rad) PTOPC(4,2),CVTOP,VVCLD(2),CLAPSE - REAL (KIND=kind_rad) CRHRH,PSTRT,CLAPKC,DCLPS,CLPSE - INTEGER KLOWT,KLOWB,LLYR - - END MODULE COMCD1 diff --git a/src/fim/FIMsrc/fim/column/module_bfmicrophysics.f b/src/fim/FIMsrc/fim/column/module_bfmicrophysics.f deleted file mode 100644 index ef59a55..0000000 --- a/src/fim/FIMsrc/fim/column/module_bfmicrophysics.f +++ /dev/null @@ -1,3221 +0,0 @@ - MODULE module_microphysics -! - USE MACHINE , ONLY : kind_phys - USE FUNCPHYS - USE PHYSCONS, CP => con_CP, RD => con_RD, RV => con_RV & - &, T0C => con_T0C, HVAP => con_HVAP, HFUS => con_HFUS & - &, EPS => con_EPS, EPSM1 => con_EPSM1 & - &, EPS1 => con_FVirt, pi => con_pi, grav => con_g - implicit none -! -!--- Common block of constants used in column microphysics -! - real,private :: ABFR, CBFR, CIACW, CIACR, C_N0r0, & - &CN0r0, CN0r_DMRmin, CN0r_DMRmax, CRACW, CRAUT, ESW0, & -! &QAUT0, RFmax, RHgrd, RQR_DR1, RQR_DR2, RQR_DR3, RQR_DRmin, & - &QAUTx, RFmax, RQR_DR1, RQR_DR2, RQR_DR3, RQR_DRmin, & - &RQR_DRmax, RR_DRmin, RR_DR1, RR_DR2, RR_DR3, RR_DRmax -! - real,private :: mic_step -! -!--- Common block for lookup table used in calculating growth rates of -! nucleated ice crystals growing in water saturated conditions -!--- Discretized growth rates of small ice crystals after their nucleation -! at 1 C intervals from -1 C to -35 C, based on calculations by Miller -! and Young (1979, JAS) after 600 s of growth. Resultant growth rates -! are multiplied by physics time step in GSMCONST. -! - INTEGER, PRIVATE,PARAMETER :: MY_T1=1, MY_T2=35 - REAL,PRIVATE,DIMENSION(MY_T1:MY_T2) :: MY_GROWTH -! -!--- Parameters for ice lookup tables, which establish the range of mean ice particle -! diameters; from a minimum mean diameter of 0.05 mm (DMImin) to a -! maximum mean diameter of 1.00 mm (DMImax). The tables store solutions -! at 1 micron intervals (DelDMI) of mean ice particle diameter. -! - REAL, PRIVATE,PARAMETER :: DMImin=.05e-3, DMImax=1.e-3, & - & DelDMI=1.e-6,XMImin=1.e6*DMImin, XMImax=1.e6*DMImax - INTEGER, PRIVATE,PARAMETER :: MDImin=XMImin, MDImax=XMImax -! -!--- Various ice lookup tables -! - REAL, PRIVATE,DIMENSION(MDImin:MDImax) :: & - & ACCRI,MASSI,SDENS,VSNOWI,VENTI1,VENTI2 -! -!--- Mean rain drop diameters varying from 50 microns (0.05 mm) to 450 microns -! (0.45 mm), assuming an exponential size distribution. -! - REAL, PRIVATE,PARAMETER :: DMRmin=.05e-3, DMRmax=.45e-3, & - & DelDMR=1.e-6,XMRmin=1.e6*DMRmin, XMRmax=1.e6*DMRmax & - &, NLImin=100. -! &, NLImin=100., NLImax=20.E3 - INTEGER, PRIVATE,PARAMETER :: MDRmin=XMRmin, MDRmax=XMRmax -! - !--- Factor of 1.5 for RECImin, RESNOWmin, & RERAINmin accounts for - ! integrating exponential distributions for effective radius - ! (i.e., the r**3/r**2 moments). - ! -! INTEGER, PRIVATE, PARAMETER :: INDEXSmin=300 -!! INTEGER, PRIVATE, PARAMETER :: INDEXSmin=200 - INTEGER, PRIVATE, PARAMETER :: INDEXSmin=100 - REAL, PRIVATE, PARAMETER :: RERAINmin=1.5*XMRmin & -! &, RECImin=1.5*XMImin, RESNOWmin=1.5*INDEXSmin, RECWmin=8.0 -! &, RECImin=1.5*XMImin, RESNOWmin=1.5*INDEXSmin, RECWmin=7.5 - &, RECImin=1.5*XMImin, RESNOWmin=1.5*INDEXSmin, RECWmin=10. -! &, RECImin=1.5*XMImin, RESNOWmin=1.5*INDEXSmin, RECWmin=15. -! &, RECImin=1.5*XMImin, RESNOWmin=1.5*INDEXSmin, RECWmin=5. - -! -!--- Various rain lookup tables -!--- Rain lookup tables for mean rain drop diameters from DMRmin to DMRmax, -! assuming exponential size distributions for the rain drops -! - REAL, PRIVATE,DIMENSION(MDRmin:MDRmax):: & - & ACCRR,MASSR,RRATE,VRAIN,VENTR1,VENTR2 -! -!--- Common block for riming tables -!--- VEL_RF - velocity increase of rimed particles as functions of crude -! particle size categories (at 0.1 mm intervals of mean ice particle -! sizes) and rime factor (different values of Rime Factor of 1.1**N, -! where N=0 to Nrime). -! - INTEGER, PRIVATE,PARAMETER :: Nrime=40 - REAL, DIMENSION(2:9,0:Nrime),PRIVATE :: VEL_RF -! -!--- The following variables are for microphysical statistics -! - INTEGER, PARAMETER :: ITLO=-60, ITHI=40 - INTEGER NSTATS(ITLO:ITHI,4) - REAL QMAX(ITLO:ITHI,5), QTOT(ITLO:ITHI,22) -! - REAL, PRIVATE, PARAMETER :: & -! & T_ICE=-10., T_ICE_init=-5. !- Ver1 -!!! &, T_ICE=-20. !- Ver2 - & T_ICE=-40., T_ICE_init=-15. !- Ver2 -! & T_ICE=-30., T_ICE_init=-5. !- Ver2 -! -! Some other miscellaneous parameters -! - REAL, PRIVATE, PARAMETER :: Thom=T_ICE, TNW=50., TOLER=1.0E-20 & -! REAL, PRIVATE, PARAMETER :: Thom=T_ICE, TNW=50., TOLER=5.E-7 -! REAL, PRIVATE, PARAMETER :: Thom=-35., TNW=50., TOLER=5.E-7 -! &, emisCU=.75/1.66 ! Used for convective cloud l/w emissivity -! Assume fixed cloud ice effective radius - &, RECICE=RECImin & - &, EPSQ=1.0E-20 & -! &, EPSQ=1.E-12 & -! &, FLG0P1=0.1, FLG0P2=0.2, FLG1P0=1.0, FLGmin=0.16 & - &, FLG0P1=0.1, FLG0P2=0.2, FLG1P0=1.0 -! &, FLG0P1=0.1, FLG0P2=0.2, FLG1P0=1.0, FLGmin=0.15 -! &, FLG0P1=0.1, FLG0P2=0.2, FLG1P0=1.0, FLGmin=0.170 & -! &, FLG0P1=0.1, FLG0P2=0.2, FLG1P0=1.0, FLGmin=0.175 & -! &, FLG0P1=0.1, FLG0P2=0.2, FLG1P0=1.0, FLGmin=0.18 -! &, FLG0P1=0.1, FLG0P2=0.2, FLG1P0=1.0, FLGmin=0.2 ! 20060512 & -! &, FLG0P1=0.1, FLG0P2=0.2, FLG1P0=1.0, FLGmin=0.25 & -! &, FLG0P1=0.1, FLG0P2=0.2, FLG1P0=1.0, FLGmin=0.3 & -! -! - CONTAINS -! -!####################################################################### -!------- Initialize constants & lookup tables for microphysics --------- -!####################################################################### -! - SUBROUTINE GSMCONST (DTPG,mype,first) -! - implicit none -!------------------------------------------------------------------------------- -!--- SUBPROGRAM DOCUMENTATION BLOCK -! PRGRMMR: Ferrier ORG: W/NP22 DATE: February 2001 -!------------------------------------------------------------------------------- -! ABSTRACT: -! * Reads various microphysical lookup tables used in COLUMN_MICRO -! * Lookup tables were created "offline" and are read in during execution -! * Creates lookup tables for saturation vapor pressure w/r/t water & ice -!------------------------------------------------------------------------------- -! -! USAGE: CALL GSMCONST FROM SUBROUTINE GSMDRIVE AT MODEL START TIME -! -! INPUT ARGUMENT LIST: -! DTPH - physics time step (s) -! -! OUTPUT ARGUMENT LIST: -! NONE -! -! OUTPUT FILES: -! NONE -! -! -! SUBROUTINES: -! MY_GROWTH_RATES - lookup table for growth of nucleated ice -! -! UNIQUE: NONE -! -! LIBRARY: NONE -! -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE : IBM SP -! - integer mype - real dtpg - logical first -! -!--- Parameters & data statement for local calculations -! - REAL, PARAMETER :: C1=1./3., DMR1=.1E-3, DMR2=.2E-3, DMR3=.32E-3, & - & N0r0=8.E6, N0s0=4.E6, RHOL=1000., RHOS=100., & - & XMR1=1.e6*DMR1, XMR2=1.e6*DMR2, XMR3=1.e6*DMR3 - INTEGER, PARAMETER :: MDR1=XMR1, MDR2=XMR2, MDR3=XMR3 -! - real dtph, etime1, etime2, timef, bbfr -!JR timef used as a function: some compilers give unsatisfied external so -!JR make it a statement function - timef() = 0. - - integer i -! -!--- Added on 5/16/01 for Moorthi -! - logical, parameter :: read_lookup=.false., write_lookup=.false. -! -!------------------------------------------------------------------------ -! ************* Parameters used in ETA model -- Not used in Global Model ***** -! -!--- DPHD, DLMD are delta latitude and longitude at the model (NOT geodetic) equator -! => "DX" is the hypotenuse of the model zonal & meridional grid increments. -! -! DX=111.*(DPHD**2+DLMD**2)**.5 ! Resolution at MODEL equator (km) -! DX=MIN(100., MAX(5., DX) ) -! -!--- Assume the following functional relationship for key constants that -! depend on grid resolution from DXmin (5 km) to DXmax (100 km) resolution: -! -! DXmin=5. -! DXmax=100. -! DX=MIN(DXmax, MAX(DXmin, DX) ) -! -!--- EXtune determines the degree to which the coefficients change with resolution. -! The larger EXtune is, the more sensitive the parameter. -! -! EXtune=1. - -! -!--- FXtune ==> F(DX) is the grid-resolution tuning parameter (from 0 to 1) -! -! FXtune=((DXmax-DX)/(DXmax-DXmin))**EXtune -! FXtune=MAX(0., MIN(1., FXtune)) -! -!--- Calculate grid-averaged RH for the onset of condensation (RHgrd) based on -! simple ***ASSUMED*** (user-specified) values at DXmax and at DXmin. -! -! RH_DXmax=.90 !-- 90% RH at DXmax=100 km -! RH_DXmin=.98 !-- 98% RH at DXmin=5 km -! -!--- Note that RHgrd is right now fixed throughout the domain!! -! -! RHgrd=RH_DXmax+(RH_DXmin-RH_DXmax)*FXtune -! ******************************************************************************** -! -! - if (first) then -! -!--- Read in various lookup tables -! - if ( read_lookup ) then - OPEN (UNIT=1,FILE="eta_micro_lookup.dat",FORM="UNFORMATTED") - READ(1) VENTR1 - READ(1) VENTR2 - READ(1) ACCRR - READ(1) MASSR - READ(1) VRAIN - READ(1) RRATE - READ(1) VENTI1 - READ(1) VENTI2 - READ(1) ACCRI - READ(1) MASSI - READ(1) VSNOWI - READ(1) VEL_RF -! read(1) my_growth ! Applicable only for DTPH=180 s for offline testing - CLOSE (1) - else - etime1=timef() - CALL ICE_LOOKUP ! Lookup tables for ice - etime2=timef() - if (mype .eq. 0) & - & print *,'CPU time (sec) in ICE_LOOKUP = ',(etime2-etime1)*0.001 - CALL RAIN_LOOKUP ! Lookup tables for rain - etime1=timef() - if (mype .eq. 0) & - & print *,'CPU time (sec) in RAIN_LOOKUP = ',(etime1-etime2)*0.001 - if (write_lookup) then - open(unit=1,file='micro_lookup.dat',form='unformatted') - write(1) ventr1 - write(1) ventr2 - write(1) accrr - write(1) massr - write(1) vrain - write(1) rrate - write(1) venti1 - write(1) venti2 - write(1) accri - write(1) massi - write(1) vsnowi - write(1) vel_rf -! write(1) my_growth ! Applicable only for DTPH=180 s ???? - CLOSE (1) - endif - endif -!! -!--- Constants associated with Biggs (1953) freezing of rain, as parameterized -! following Lin et al. (JCAM, 1983) & Reisner et al. (1998, QJRMS). -! - ABFR=-0.66 - BBFR=100. - CBFR=20.*PI*PI*BBFR*RHOL*1.E-21 -! -!--- QAUT0 is the threshold cloud content for autoconversion to rain -! needed for droplets to reach a diameter of 20 microns (following -! Manton and Cotton, 1977; Banta and Hanson, 1987, JCAM). It is -! **STRONGLY** affected by the assumed droplet number concentrations -! XNCW! For example, QAUT0=1.2567, 0.8378, or 0.4189 g/m**3 for -! droplet number concentrations of 300, 200, and 100 cm**-3, respectively. -! -!--- Calculate grid-averaged XNCW based on simple ***ASSUMED*** (user-specified) -! values at DXmax and at DXmin. -! -! XNCW_DXmax=50.E6 !-- 50 /cm**3 at DXmax=100 km -! XNCW_DXmin=200.E6 !-- 200 /cm**3 at DXmin=5 km -! -!--- Note that XNCW is right now fixed throughout the domain!! -! -! XNCW=XNCW_DXmax+(XNCW_DXmin-XNCW_DXmax)*FXtune -! -! QAUT0=PI*RHOL*XNCW*(20.E-6)**3/6. - QAUTx=PI*RHOL*1.0E6*(20.E-6)**3/6. -! -!--- Based on rain lookup tables for mean diameters from 0.05 to 0.45 mm -! * Four different functional relationships of mean drop diameter as -! a function of rain rate (RR), derived based on simple fits to -! mass-weighted fall speeds of rain as functions of mean diameter -! from the lookup tables. -! - RR_DRmin=N0r0*RRATE(MDRmin) ! RR for mean drop diameter of .05 mm - RR_DR1=N0r0*RRATE(MDR1) ! RR for mean drop diameter of .10 mm - RR_DR2=N0r0*RRATE(MDR2) ! RR for mean drop diameter of .20 mm - RR_DR3=N0r0*RRATE(MDR3) ! RR for mean drop diameter of .32 mm - RR_DRmax=N0r0*RRATE(MDRmax) ! RR for mean drop diameter of .45 mm -! - RQR_DRmin=N0r0*MASSR(MDRmin) ! Rain content for mean drop diameter of .05 mm - RQR_DR1=N0r0*MASSR(MDR1) ! Rain content for mean drop diameter of .10 mm - RQR_DR2=N0r0*MASSR(MDR2) ! Rain content for mean drop diameter of .20 mm - RQR_DR3=N0r0*MASSR(MDR3) ! Rain content for mean drop diameter of .32 mm - RQR_DRmax=N0r0*MASSR(MDRmax) ! Rain content for mean drop diameter of .45 mm - C_N0r0=PI*RHOL*N0r0 - CN0r0=1.E6/C_N0r0**.25 - CN0r_DMRmin=1./(PI*RHOL*DMRmin**4) - CN0r_DMRmax=1./(PI*RHOL*DMRmax**4) -! - endif ! If (first) then loop ends here -! -! Find out what microphysics time step should be -! - mic_step = max(1, int(dtpg/600.0+0.5)) -! mic_step = max(1, int(dtpg/300.0+0.5)) - dtph = dtpg / mic_step - if (mype .eq. 0) print *,' DTPG=',DTPG,' mic_step=',mic_step & - &, ' dtph=',dtph -! -!--- Calculates coefficients for growth rates of ice nucleated in water -! saturated conditions, scaled by physics time step (lookup table) -! - CALL MY_GROWTH_RATES (DTPH) -! -!--- CIACW is used in calculating riming rates -! The assumed effective collection efficiency of cloud water rimed onto -! ice is =0.5 below: -! -!Moor CIACW=DTPH*0.25*PI*0.5*(1.E5)**C1 ! commented on 20050422 -! ice is =0.1 below: - CIACW=DTPH*0.25*PI*0.1*(1.E5)**C1 -! CIACW = 0.0 ! Brad's suggestion 20040614 -! -!--- CIACR is used in calculating freezing of rain colliding with large ice -! The assumed collection efficiency is 1.0 -! - CIACR=PI*DTPH -! -!--- CRACW is used in calculating collection of cloud water by rain (an -! assumed collection efficiency of 1.0) -! -!Moor CRACW=DTPH*0.25*PI*1.0 ! commented on 20050422 -! -! assumed collection efficiency of 0.1) - CRACW=DTPH*0.25*PI*0.1 -! CRACW = 0.0 ! Brad's suggestion 20040614 -! - ESW0=FPVSL(T0C) ! Saturation vapor pressure at 0C - RFmax=1.1**Nrime ! Maximum rime factor allowed -! -!------------------------------------------------------------------------ -!--------------- Constants passed through argument list ----------------- -!------------------------------------------------------------------------ -! -!--- Important parameters for self collection (autoconversion) of -! cloud water to rain. -! -!--- CRAUT is proportional to the rate that cloud water is converted by -! self collection to rain (autoconversion rate) -! - CRAUT=1.-EXP(-1.E-3*DTPH) -! -! IF (MYPE .EQ. 0) -! & WRITE(6,"(A, A,F6.2,A, A,F5.4, A,F7.3,A, A,F6.2,A, A,F5.3,A)") -! & 'KEY MICROPHYSICAL PARAMETERS FOR ' -! & ,'DX=',DX,' KM:' -! & ,' FXtune=',FXtune -! & ,' RHgrd=',100.*RHgrd,' %' -! & ,' NCW=',1.E-6*XNCW,' /cm**3' -! & ,' QAUT0=',1.E3*QAUT0,' g/kg' -! -!--- For calculating snow optical depths by considering bulk density of -! snow based on emails from Q. Fu (6/27-28/01), where optical -! depth (T) = 1.5*SWP/(Reff*DENS), SWP is snow water path, Reff -! is effective radius, and DENS is the bulk density of snow. -! -! SWP (kg/m**2)=(1.E-3 kg/g)*SWPrad, SWPrad in g/m**2 used in radiation -! T = 1.5*1.E3*SWPrad/(Reff*DENS) -! -! See derivation for MASSI(INDEXS), note equal to RHO*QSNOW/NSNOW -! -! SDENS=1.5e3/DENS, DENS=MASSI(INDEXS)/[PI*(1.E-6*INDEXS)**3] -! - DO I=MDImin,MDImax -!MoorthiSDENS(I)=PI*1.5E-15*FLOAT(I*I*I)/MASSI(I) - SDENS(I)=PI*1.0E-15*FLOAT(I*I*I)/MASSI(I) - ENDDO -! -!----------------------------------------------------------------------- -! - END subroutine gsmconst - -! -!####################################################################### -!--- Sets up lookup table for calculating initial ice crystal growth --- -!####################################################################### -! - SUBROUTINE MY_GROWTH_RATES (DTPH) -! - implicit none -! -!--- Below are tabulated values for the predicted mass of ice crystals -! after 600 s of growth in water saturated conditions, based on -! calculations from Miller and Young (JAS, 1979). These values are -! crudely estimated from tabulated curves at 600 s from Fig. 6.9 of -! Young (1993). Values at temperatures colder than -27C were -! assumed to be invariant with temperature. -! -!--- Used to normalize Miller & Young (1979) calculations of ice growth -! over large time steps using their tabulated values at 600 s. -! Assumes 3D growth with time**1.5 following eq. (6.3) in Young (1993). -! - real dtph, dt_ice - REAL MY_600(MY_T1:MY_T2) -! -!-- 20090714: These values are in g and need to be converted to kg below - DATA MY_600 / & - & 5.5e-8, 1.4E-7, 2.8E-7, 6.E-7, 3.3E-6, & ! -1 to -5 deg C - & 2.E-6, 9.E-7, 8.8E-7, 8.2E-7, 9.4e-7, & ! -6 to -10 deg C - & 1.2E-6, 1.85E-6, 5.5E-6, 1.5E-5, 1.7E-5, & ! -11 to -15 deg C - & 1.5E-5, 1.E-5, 3.4E-6, 1.85E-6, 1.35E-6, & ! -16 to -20 deg C - & 1.05E-6, 1.E-6, 9.5E-7, 9.0E-7 , 9.5E-7, & ! -21 to -25 deg C - & 9.5E-7, 9.E-7, 9.E-7, 9.E-7, 9.E-7, & ! -26 to -30 deg C - & 9.E-7, 9.E-7, 9.E-7, 9.E-7, 9.E-7 / ! -31 to -35 deg C -! -!----------------------------------------------------------------------- -! - DT_ICE=(DTPH/600.)**1.5 -! MY_GROWTH=DT_ICE*MY_600 ! original version - MY_GROWTH=DT_ICE*MY_600*1.E-3 !-- 20090714: Convert from g to kg -! -!----------------------------------------------------------------------- -! - END subroutine MY_GROWTH_RATES -! -!####################################################################### -!--------------- Creates lookup tables for ice processes --------------- -!####################################################################### -! - subroutine ice_lookup -! - implicit none -!----------------------------------------------------------------------------------- -! -!---- Key diameter values in mm -! -!----------------------------------------------------------------------------------- -! -!---- Key concepts: -! - Actual physical diameter of particles (D) -! - Ratio of actual particle diameters to mean diameter (x=D/MD) -! - Mean diameter of exponentially distributed particles, which is the -! same as 1./LAMDA of the distribution (MD) -! - All quantitative relationships relating ice particle characteristics as -! functions of their diameter (e.g., ventilation coefficients, normalized -! accretion rates, ice content, and mass-weighted fall speeds) are a result -! of using composite relationships for ice crystals smaller than 1.5 mm -! diameter merged with analogous relationships for larger sized aggregates. -! Relationships are derived as functions of mean ice particle sizes assuming -! exponential size spectra and assuming the properties of ice crystals at -! sizes smaller than 1.5 mm and aggregates at larger sizes. -! -!----------------------------------------------------------------------------------- -! -!---- Actual ice particle diameters for which integrated distributions are derived -! - DminI - minimum diameter for integration (.02 mm, 20 microns) -! - DmaxI - maximum diameter for integration (2 cm) -! - DdelI - interval for integration (1 micron) -! - real, parameter :: DminI=.02e-3, DmaxI=20.e-3, DdelI=1.e-6, & - & XImin=1.e6*DminI, XImax=1.e6*DmaxI - integer, parameter :: IDImin=XImin, IDImax=XImax -! -!---- Meaning of the following arrays: -! - diam - ice particle diameter (m) -! - mass - ice particle mass (kg) -! - vel - ice particle fall speeds (m/s) -! - vent1 - 1st term in ice particle ventilation factor -! - vent2 - 2nd term in ice particle ventilation factor -! - real diam(IDImin:IDImax),mass(IDImin:IDImax),vel(IDImin:IDImax), & - & vent1(IDImin:IDImax),vent2(IDImin:IDImax) -! -!----------------------------------------------------------------------------------- -! -!---- Found from trial & error that the m(D) & V(D) mass & velocity relationships -! between the ice crystals and aggregates overlapped & merged near a particle -! diameter sizes of 1.5 mm. Thus, ice crystal relationships are used for -! sizes smaller than 1.5 mm and aggregate relationships for larger sizes. -! - real, parameter :: d_crystal_max=1.5 -! -!---- The quantity xmax represents the maximum value of "x" in which the -! integrated values are calculated. For xmax=20., this means that -! integrated ventilation, accretion, mass, and precipitation rates are -! calculated for ice particle sizes less than 20.*mdiam, the mean particle diameter. -! - real, parameter :: xmax=20. -! -!----------------------------------------------------------------------------------- -! -!---- Meaning of the following arrays: -! - mdiam - mean diameter (m) -! - VENTI1 - integrated quantity associated w/ ventilation effects -! (capacitance only) for calculating vapor deposition onto ice -! - VENTI2 - integrated quantity associated w/ ventilation effects -! (with fall speed) for calculating vapor deposition onto ice -! - ACCRI - integrated quantity associated w/ cloud water collection by ice -! - MASSI - integrated quantity associated w/ ice mass -! - VSNOWI - mass-weighted fall speed of snow, used to calculate precip rates -! -!--- Mean ice-particle diameters varying from 50 microns to 1000 microns (1 mm), -! assuming an exponential size distribution. -! - real mdiam -! -!----------------------------------------------------------------------------------- -!------------- Constants & parameters for ventilation factors of ice --------------- -!----------------------------------------------------------------------------------- -! -!---- These parameters are used for calculating the ventilation factors for ice -! crystals between 0.2 and 1.5 mm diameter (Hall and Pruppacher, JAS, 1976). -! From trial & error calculations, it was determined that the ventilation -! factors of smaller ice crystals could be approximated by a simple linear -! increase in the ventilation coefficient from 1.0 at 50 microns (.05 mm) to -! 1.1 at 200 microns (0.2 mm), rather than using the more complex function of -! 1.0 + .14*(Sc**.33*Re**.5)**2 recommended by Hall & Pruppacher. -! - real, parameter :: cvent1i=.86, cvent2i=.28 -! -!---- These parameters are used for calculating the ventilation factors for larger -! aggregates, where D>=1.5 mm (see Rutledge and Hobbs, JAS, 1983; -! Thorpe and Mason, 1966). -! - real, parameter :: cvent1a=.65, cvent2a=.44 -! - real m_agg,m_bullet,m_column,m_ice,m_plate -! -!---- Various constants -! - real, parameter :: c1=2./3., cexp=1./3. -! - logical :: iprint - logical, parameter :: print_diag=.false. -! -!----------------------------------------------------------------------------------- -!- Constants & parameters for calculating the increase in fall speed of rimed ice -- -!----------------------------------------------------------------------------------- -! -!---- Constants & arrays for estimating increasing fall speeds of rimed ice. -! Based largely on theory and results from Bohm (JAS, 1989, 2419-2427). -! -!-------------------- Standard atmosphere conditions at 1000 mb -------------------- -! - real, parameter :: t_std=288., dens_std=1000.e2/(287.04*288.) -! -!---- These "bulk densities" are the actual ice densities in the ice portion of the -! lattice. They are based on text associated w/ (12) on p. 2425 of Bohm (JAS, -! 1989). Columns, plates, & bullets are assumed to have an average bulk density -! of 850 kg/m**3. Aggregates were assumed to have a slightly larger bulk density -! of 600 kg/m**3 compared with dendrites (i.e., the least dense, most "lacy" & -! tenous ice crystal, which was assumed to be ~500 kg/m**3 in Bohm). -! - real, parameter :: dens_crystal=850., dens_agg=600. -! -!--- A value of Nrime=40 for a logarithmic ratio of 1.1 yields a maximum rime factor -! of 1.1**40 = 45.26 that is resolved in these tables. This allows the largest -! ice particles with a mean diameter of MDImax=1000 microns to achieve bulk -! densities of 900 kg/m**3 for rimed ice. -! -! integer, parameter :: Nrime=40 - real m_rime, & - & rime_factor(0:Nrime), rime_vel(0:Nrime), & - & vel_rime(IDImin:IDImax,Nrime), ivel_rime(MDImin:MDImax,Nrime) -! - integer i, j, jj, k, icount - real c2, cbulk, cbulk_ice, px, dynvis_std, crime1 & - &, crime2, crime3, crime4, crime5, d, c_avg, c_agg & - &, c_bullet, c_column, c_plate, cl_agg, cl_bullet & - &, cl_column, cl_plate, v_agg, v_bullet, v_column & - &, v_plate, wd, ecc_column & - &, cvent1, cvent2, crime_best, rime_m1, rime_m2 & - &, x_rime, re_rime, smom3, pratei, expf & - &, bulk_dens, xmass, xmdiam, ecc_plate, dx -! -!----------------------------------------------------------------------------------- -!----------------------------- BEGIN EXECUTION ------------------------------------- -!----------------------------------------------------------------------------------- -! -! - c2=1./sqrt(3.) -! pi=acos(-1.) - cbulk=6./pi - cbulk_ice=900.*pi/6. ! Maximum bulk ice density allowed of 900 kg/m**3 - px=.4**cexp ! Convert fall speeds from 400 mb (Starr & Cox) to 1000 mb -! -!--------------------- Dynamic viscosity (1000 mb, 288 K) -------------------------- -! - dynvis_std=1.496e-6*t_std**1.5/(t_std+120.) - crime1=pi/24. - crime2=8.*9.81*dens_std/(pi*dynvis_std**2) - crime3=crime1*dens_crystal - crime4=crime1*dens_agg - crime5=dynvis_std/dens_std - do i=0,Nrime - rime_factor(i)=1.1**i - enddo -! -!####################################################################### -! Characteristics as functions of actual ice particle diameter -!####################################################################### -! -!---- M(D) & V(D) for 3 categories of ice crystals described by Starr -!---- & Cox (1985). -! -!---- Capacitance & characteristic lengths for Reynolds Number calculations -!---- are based on Young (1993; p. 144 & p. 150). c-axis & a-axis -!---- relationships are from Heymsfield (JAS, 1972; Table 1, p. 1351). -! - icount=60 -! - if (print_diag) & - & write(7,"(2a)") '---- Increase in fall speeds of rimed ice', & - & ' particles as function of ice particle diameter ----' - do i=IDImin,IDImax - if (icount.eq.60 .and. print_diag) then - write(6,"(/2a/3a)") 'Particle masses (mg), fall speeds ', & - & '(m/s), and ventilation factors', & - & ' D(mm) CR_mass Mass_bull Mass_col Mass_plat ', & - & ' Mass_agg CR_vel V_bul CR_col CR_pla Aggreg', & - & ' Vent1 Vent2 ' - write(7,"(3a)") ' <----------------------------------',& - & '--------------- Rime Factor --------------------------', & - & '--------------------------->' - write(7,"(a,23f5.2)") ' D(mm)',(rime_factor(k), k=1,5), & - & (rime_factor(k), k=6,40,2) - icount=0 - endif - d=(float(i)+.5)*1.e-3 ! in mm - c_avg=0. - c_agg=0. - c_bullet=0. - c_column=0. - c_plate=0. - cl_agg=0. - cl_bullet=0. - cl_column=0. - cl_plate=0. - m_agg=0. - m_bullet=0. - m_column=0. - m_plate=0. - v_agg=0. - v_bullet=0. - v_column=0. - v_plate=0. - if (d .lt. d_crystal_max) then -! -!---- This block of code calculates bulk characteristics based on average -! characteristics of bullets, plates, & column ice crystals <1.5 mm size -! -!---- Mass-diameter relationships from Heymsfield (1972) & used -! in Starr & Cox (1985), units in mg -!---- "d" is maximum dimension size of crystal in mm, -! -! Mass of pure ice for spherical particles, used as an upper limit for the -! mass of small columns (<~ 80 microns) & plates (<~ 35 microns) -! - m_ice=.48*d**3 ! Mass of pure ice for spherical particle -! - m_bullet=min(.044*d**3, m_ice) - m_column=min(.017*d**1.7, m_ice) - m_plate=min(.026*d**2.5, m_ice) -! - mass(i)=m_bullet+m_column+m_plate -! -!---- These relationships are from Starr & Cox (1985), applicable at 400 mb -!---- "d" is maximum dimension size of crystal in mm, dx in microns -! - dx=1000.*d ! Convert from mm to microns - if (dx .le. 200.) then - v_column=8.114e-5*dx**1.585 - v_bullet=5.666e-5*dx**1.663 - v_plate=1.e-3*dx - else if (dx .le. 400.) then - v_column=4.995e-3*dx**.807 - v_bullet=3.197e-3*dx**.902 - v_plate=1.48e-3*dx**.926 - else if (dx .le. 600.) then - v_column=2.223e-2*dx**.558 - v_bullet=2.977e-2*dx**.529 - v_plate=9.5e-4*dx - else if (dx .le. 800.) then - v_column=4.352e-2*dx**.453 - v_bullet=2.144e-2*dx**.581 - v_plate=3.161e-3*dx**.812 - else - v_column=3.833e-2*dx**.472 - v_bullet=3.948e-2*dx**.489 - v_plate=7.109e-3*dx**.691 - endif -! -!---- Reduce fall speeds from 400 mb to 1000 mb -! - v_column=px*v_column - v_bullet=px*v_bullet - v_plate=px*v_plate -! -!---- DIFFERENT VERSION! CALCULATES MASS-WEIGHTED CRYSTAL FALL SPEEDS -! - vel(i)=(m_bullet*v_bullet+m_column*v_column+m_plate*v_plate)/ & - & mass(i) - mass(i)=mass(i)/3. -! -!---- Shape factor and characteristic length of various ice habits, -! capacitance is equal to 4*PI*(Shape factor) -! See Young (1993, pp. 143-152 for guidance) -! -!---- Bullets: -! -!---- Shape factor for bullets (Heymsfield, 1975) - c_bullet=.5*d -!---- Length-width functions for bullets from Heymsfield (JAS, 1972) - if (d .gt. 0.3) then - wd=.25*d**.7856 ! Width (mm); a-axis - else - wd=.185*d**.552 - endif -!---- Characteristic length for bullets (see first multiplicative term on right -! side of eq. 7 multiplied by crystal width on p. 821 of Heymsfield, 1975) - cl_bullet=.5*pi*wd*(.25*wd+d)/(d+wd) -! -!---- Plates: -! -!---- Length-width function for plates from Heymsfield (JAS, 1972) - wd=.0449*d**.449 ! Width or thickness (mm); c-axis -!---- Eccentricity & shape factor for thick plates following Young (1993, p. 144) - ecc_plate=sqrt(1.-wd*wd/(d*d)) ! Eccentricity - c_plate=d*ecc_plate/asin(ecc_plate) ! Shape factor -!---- Characteristic length for plates following Young (1993, p. 150, eq. 6.6) - cl_plate=d+2.*wd ! Characteristic lengths for plates -! -!---- Columns: -! -!---- Length-width function for columns from Heymsfield (JAS, 1972) - if (d .gt. 0.2) then - wd=.1973*d**.414 ! Width (mm); a-axis - else - wd=.5*d ! Width (mm); a-axis - endif -!---- Eccentricity & shape factor for columns following Young (1993, p. 144) - ecc_column=sqrt(1.-wd*wd/(d*d)) ! Eccentricity - c_column=ecc_column*d/alog((1.+ecc_column)*d/wd) ! Shape factor -!---- Characteristic length for columns following Young (1993, p. 150, eq. 6.7) - cl_column=(wd+2.*d)/(c1+c2*d/wd) ! Characteristic lengths for columns -! -!---- Convert shape factor & characteristic lengths from mm to m for -! ventilation calculations -! - c_bullet=.001*c_bullet - c_plate=.001*c_plate - c_column=.001*c_column - cl_bullet=.001*cl_bullet - cl_plate=.001*cl_plate - cl_column=.001*cl_column -! -!---- Make a smooth transition between a ventilation coefficient of 1.0 at 50 microns -! to 1.1 at 200 microns -! - if (d .gt. 0.2) then - cvent1=cvent1i - cvent2=cvent2i/3. - else - cvent1=1.0+.1*max(0., d-.05)/.15 - cvent2=0. - endif -! -!---- Ventilation factors for ice crystals: -! - vent1(i)=cvent1*(c_bullet+c_plate+c_column)/3. - vent2(i)=cvent2*(c_bullet*sqrt(v_bullet*cl_bullet) & - & +c_plate*sqrt(v_plate*cl_plate) & - & +c_column*sqrt(v_column*cl_column) ) - crime_best=crime3 ! For calculating Best No. of rimed ice crystals - else -! -!---- This block of code calculates bulk characteristics based on average -! characteristics of unrimed aggregates >= 1.5 mm using Locatelli & -! Hobbs (JGR, 1974, 2185-2197) data. -! -!----- This category is a composite of aggregates of unrimed radiating -!----- assemblages of dendrites or dendrites; aggregates of unrimed -!----- radiating assemblages of plates, side planes, bullets, & columns; -!----- aggregates of unrimed side planes (mass in mg, velocity in m/s) -! - m_agg=(.073*d**1.4+.037*d**1.9+.04*d**1.4)/3. - v_agg=(.8*d**.16+.69*d**.41+.82*d**.12)/3. - mass(i)=m_agg - vel(i)=v_agg -! -!---- Assume spherical aggregates -! -!---- Shape factor is the same as for bullets, = D/2 - c_agg=.001*.5*d ! Units of m -!---- Characteristic length is surface area divided by perimeter -! (.25*PI*D**2)/(PI*D**2) = D/4 - cl_agg=.5*c_agg ! Units of m -! -!---- Ventilation factors for aggregates: -! - vent1(i)=cvent1a*c_agg - vent2(i)=cvent2a*c_agg*sqrt(v_agg*cl_agg) - crime_best=crime4 ! For calculating Best No. of rimed aggregates - endif -! -!---- Convert from shape factor to capacitance for ventilation factors -! - vent1(i)=4.*pi*vent1(i) - vent2(i)=4.*pi*vent2(i) - diam(i)=1.e-3*d ! Convert from mm to m - mass(i)=1.e-6*mass(i) ! Convert from mg to kg -! -!---- Calculate increase in fall speeds of individual rimed ice particles -! - do k=0,Nrime -!---- Mass of rimed ice particle associated with rime_factor(k) - rime_m1=rime_factor(k)*mass(i) - rime_m2=cbulk_ice*diam(i)**3 - m_rime=min(rime_m1, rime_m2) -!---- Best Number (X) of rimed ice particle combining eqs. (8) & (12) in Bohm - x_rime=crime2*m_rime*(crime_best/m_rime)**.25 -!---- Reynolds Number for rimed ice particle using eq. (11) in Bohm - re_rime=8.5*(sqrt(1.+.1519*sqrt(x_rime))-1.)**2 - rime_vel(k)=crime5*re_rime/diam(i) - enddo - do k=1,Nrime - vel_rime(i,k)=rime_vel(k)/rime_vel(0) - enddo - if (print_diag) then - ! - !---- Determine if statistics should be printed out. - ! - iprint=.false. - if (d .le. 1.) then - if (mod(i,10) .eq. 0) iprint=.true. - else - if (mod(i,100) .eq. 0) iprint=.true. - endif - if (iprint) then - write(6,"(f7.4,5e11.4,1x,5f7.4,1x,2e11.4)") & - & d,1.e6*mass(i),m_bullet,m_column,m_plate,m_agg, & - & vel(i),v_bullet,v_column,v_plate,v_agg, & - & vent1(i),vent2(i) - write(7,"(f7.4,23f5.2)") d,(vel_rime(i,k), k=1,5), & - & (vel_rime(i,k), k=6,40,2) - icount=icount+1 - endif - endif - enddo -! -!####################################################################### -! Characteristics as functions of mean particle diameter -!####################################################################### -! - VENTI1=0. - VENTI2=0. - ACCRI=0. - MASSI=0. - VSNOWI=0. - VEL_RF=0. - ivel_rime=0. - icount=0 - if (print_diag) then - icount=60 - write(6,"(/2a)") '------------- Statistics as functions of ', & - & 'mean particle diameter -------------' - write(7,"(/2a)") '------ Increase in fall speeds of rimed ice', & - & ' particles as functions of mean particle diameter -----' - endif - do j=MDImin,MDImax - if (icount.eq.60 .AND. print_diag) then - write(6,"(/2a)") 'D(mm) Vent1 Vent2 ', & - & 'Accrete Mass Vel Dens ' - write(7,"(3a)") ' <----------------------------------', & - & '--------------- Rime Factor --------------------------', & - & '--------------------------->' - write(7,"(a,23f5.2)") 'D(mm)',(rime_factor(k), k=1,5), & - & (rime_factor(k), k=6,40,2) - icount=0 - endif - mdiam=DelDMI*float(j) ! in m - smom3=0. - pratei=0. - rime_vel=0. ! Note that this array is being reused! - do i=IDImin,IDImax - dx=diam(i)/mdiam - if (dx .le. xmax) then ! To prevent arithmetic underflows - expf=exp(-dx)*DdelI - VENTI1(J)=VENTI1(J)+vent1(i)*expf - VENTI2(J)=VENTI2(J)+vent2(i)*expf - ACCRI(J)=ACCRI(J)+diam(i)*diam(i)*vel(i)*expf - xmass=mass(i)*expf - do k=1,Nrime - rime_vel(k)=rime_vel(k)+xmass*vel_rime(i,k) - enddo - MASSI(J)=MASSI(J)+xmass - pratei=pratei+xmass*vel(i) - smom3=smom3+diam(i)**3*expf - else - exit - endif - enddo - ! - !--- Increased fall velocities functions of mean diameter (j), - ! normalized by ice content, and rime factor (k) - ! - do k=1,Nrime - ivel_rime(j,k)=rime_vel(k)/MASSI(J) - enddo - ! - !--- Increased fall velocities functions of ice content at 0.1 mm - ! intervals (j_100) and rime factor (k); accumulations here - ! - jj=j/100 - if (jj.ge.2 .AND. jj.le.9) then - do k=1,Nrime - VEL_RF(jj,k)=VEL_RF(jj,k)+ivel_rime(j,k) - enddo - endif - bulk_dens=cbulk*MASSI(J)/smom3 - VENTI1(J)=VENTI1(J)/mdiam - VENTI2(J)=VENTI2(J)/mdiam - ACCRI(J)=ACCRI(J)/mdiam - VSNOWI(J)=pratei/MASSI(J) - MASSI(J)=MASSI(J)/mdiam - if (mod(j,10).eq.0 .AND. print_diag) then - xmdiam=1.e3*mdiam - write(6,"(f5.3,4e11.4,f6.3,f8.3)") xmdiam,VENTI1(j),VENTI2(j),& - & ACCRI(j),MASSI(j),VSNOWI(j),bulk_dens - write(7,"(f5.3,23f5.2)") xmdiam,(ivel_rime(j,k), k=1,5), & - & (ivel_rime(j,k), k=6,40,2) - icount=icount+1 - endif - enddo -! -!--- Average increase in fall velocities rimed ice as functions of mean -! particle diameter (j, only need 0.1 mm intervals) and rime factor (k) -! - if (print_diag) then - write(7,"(/2a)") ' ------- Increase in fall speeds of rimed ', & - & 'ice particles at reduced, 0.1-mm intervals --------' - write(7,"(3a)") ' <----------------------------------', & - & '--------------- Rime Factor --------------------------', & - & '--------------------------->' - write(7,"(a,23f5.2)") 'D(mm)',(rime_factor(k), k=1,5), & - & (rime_factor(k), k=6,40,2) - endif - do j=2,9 - VEL_RF(j,0)=1. - do k=1,Nrime - VEL_RF(j,k)=.01*VEL_RF(j,k) - enddo - if (print_diag) write(7,"(f3.1,2x,23f5.2)") 0.1*j, & - & (VEL_RF(j,k), k=1,5),(VEL_RF(j,k), k=6,40,2) - enddo -! -!----------------------------------------------------------------------------------- -! - end subroutine ice_lookup -! -!####################################################################### -!-------------- Creates lookup tables for rain processes --------------- -!####################################################################### -! - subroutine rain_lookup - implicit none -! -!--- Parameters & arrays for fall speeds of rain as a function of rain drop -! diameter. These quantities are integrated over exponential size -! distributions of rain drops at 1 micron intervals (DdelR) from minimum -! drop sizes of .05 mm (50 microns, DminR) to maximum drop sizes of 10 mm -! (DmaxR). -! - real, parameter :: DminR=.05e-3, DmaxR=10.e-3, DdelR=1.e-6, & - & XRmin=1.e6*DminR, XRmax=1.e6*DmaxR - integer, parameter :: IDRmin=XRmin, IDRmax=XRmax - real diam(IDRmin:IDRmax), vel(IDRmin:IDRmax) -! -!--- Parameters rain lookup tables, which establish the range of mean drop -! diameters; from a minimum mean diameter of 0.05 mm (DMRmin) to a -! maximum mean diameter of 0.45 mm (DMRmax). The tables store solutions -! at 1 micron intervals (DelDMR) of mean drop diameter. -! - real mdiam, mass -! - logical, parameter :: print_diag=.false. -! - real d, cmass, pi2, expf - integer i, j, i1, i2 -! -!----------------------------------------------------------------------- -!------- Fall speeds of rain as function of rain drop diameter --------- -!----------------------------------------------------------------------- -! - do i=IDRmin,IDRmax - diam(i)=float(i)*DdelR - d=100.*diam(i) ! Diameter in cm - if (d .le. .42) then - ! - !--- Rutledge & Hobbs (1983); vel (m/s), d (cm) - ! - vel(i)=max(0., -.267+51.5*d-102.25*d*d+75.7*d**3) - else if (d.gt.0.42 .and. d.le..58) then - ! - !--- Linear interpolation of Gunn & Kinzer (1949) data - ! - vel(i)=8.92+.25/(.58-.42)*(d-.42) - else - vel(i)=9.17 - endif - enddo - do i=1,100 - i1=(i-1)*100+IDRmin - i2=i1+90 - ! - !--- Print out rain fall speeds only for D<=5.8 mm (.58 cm) - ! - if (diam(i1) .gt. .58e-2) exit - if (print_diag) then - write(6,"(1x)") - write(6,"('D(mm)-> ',10f7.3)") (1000.*diam(j), j=i1,i2,10) - write(6,"('V(m/s)-> ',10f7.3)") (vel(j), j=i1,i2,10) - endif - enddo -! -!----------------------------------------------------------------------- -!------------------- Lookup tables for rain processes ------------------ -!----------------------------------------------------------------------- -! -! pi=acos(-1.) - pi2=2.*pi - cmass=1000.*pi/6. - if (print_diag) then - write(6,"(/'Diam - Mean diameter (mm)' & - & /'VENTR1 - 1st ventilation coefficient (m**2)' & - & /'VENTR2 - 2nd ventilation coefficient (m**3/s**.5)' & - & /'ACCRR - accretion moment (m**4/s)' & - & /'RHO*QR - mass content (kg/m**3) for N0r=8e6' & - & /'RRATE - rain rate moment (m**5/s)' & - & /'VR - mass-weighted rain fall speed (m/s)' & - & /' Diam VENTR1 VENTR2 ACCRR ', & - & 'RHO*QR RRATE VR')") - endif - do j=MDRmin,MDRmax - mdiam=float(j)*DelDMR - VENTR2(J)=0. - ACCRR(J)=0. - MASSR(J)=0. - RRATE(J)=0. - do i=IDRmin,IDRmax - expf=exp(-diam(i)/mdiam)*DdelR - VENTR2(J)=VENTR2(J)+diam(i)**1.5*vel(i)**.5*expf - ACCRR(J)=ACCRR(J)+diam(i)*diam(i)*vel(i)*expf - MASSR(J)=MASSR(J)+diam(i)**3*expf - RRATE(J)=RRATE(J)+diam(i)**3*vel(i)*expf - enddo - ! - !--- Derived based on ventilation, F(D)=0.78+.31*Schmidt**(1/3)*Reynold**.5, - ! where Reynold=(V*D*rho/dyn_vis), V is velocity, D is particle diameter, - ! rho is air density, & dyn_vis is dynamic viscosity. Only terms - ! containing velocity & diameter are retained in these tables. - ! - VENTR1(J)=.78*pi2*mdiam**2 - VENTR2(J)=.31*pi2*VENTR2(J) - ! - MASSR(J)=cmass*MASSR(J) - RRATE(J)=cmass*RRATE(J) - VRAIN(J)=RRATE(J)/MASSR(J) - if (print_diag) write(6,"(f5.3,5g12.5,f6.3)") 1000.*mdiam, - & ventr1(j),ventr2(j),accrr(j),8.e6*massr(j),rrate(j),vrain(j) - enddo -! -!----------------------------------------------------------------------- -! - end subroutine rain_lookup -! -!############################################################################### -! ***** VERSION OF MICROPHYSICS DESIGNED FOR HIGHER RESOLUTION MESO ETA MODEL -! (1) Represents sedimentation by preserving a portion of the precipitation -! through top-down integration from cloud-top. Modified procedure to -! Zhao and Carr (1997). -! (2) Microphysical equations are modified to be less sensitive to time -! steps by use of Clausius-Clapeyron equation to account for changes in -! saturation mixing ratios in response to latent heating/cooling. -! (3) Prevent spurious temperature oscillations across 0C due to -! microphysics. -! (4) Uses lookup tables for: calculating two different ventilation -! coefficients in condensation and deposition processes; accretion of -! cloud water by precipitation; precipitation mass; precipitation rate -! (and mass-weighted precipitation fall speeds). -! (5) Assumes temperature-dependent variation in mean diameter of large ice -! (Houze et al., 1979; Ryan et al., 1996). -! -> 8/22/01: This relationship has been extended to colder temperatures -! to parameterize smaller large-ice particles down to mean sizes of MDImin, -! which is 50 microns reached at -55.9C. -! (6) Attempts to differentiate growth of large and small ice, mainly for -! improved transition from thin cirrus to thick, precipitating ice -! anvils. -! -> 8/22/01: This feature has been diminished by effectively adjusting to -! ice saturation during depositional growth at temperatures colder than -! -10C. Ice sublimation is calculated more explicitly. The logic is -! that sources of are either poorly understood (e.g., nucleation for NWP) -! or are not represented in the Eta model (e.g., detrainment of ice from -! convection). Otherwise the model is too wet compared to the radiosonde -! observations based on 1 Feb - 18 March 2001 retrospective runs. -! (7) Top-down integration also attempts to treat mixed-phase processes, -! allowing a mixture of ice and water. Based on numerous observational -! studies, ice growth is based on nucleation at cloud top & -! subsequent growth by vapor deposition and riming as the ice particles -! fall through the cloud. Effective nucleation rates are a function -! of ice supersaturation following Meyers et al. (JAM, 1992). -! -> 8/22/01: The simulated relative humidities were far too moist compared -! to the rawinsonde observations. This feature has been substantially -! diminished, limited to a much narrower temperature range of 0 to -10C. -! (8) Depositional growth of newly nucleated ice is calculated for large time -! steps using Fig. 8 of Miller and Young (JAS, 1979), at 1 deg intervals -! using their ice crystal masses calculated after 600 s of growth in water -! saturated conditions. The growth rates are normalized by time step -! assuming 3D growth with time**1.5 following eq. (6.3) in Young (1993). -! -> 8/22/01: This feature has been effectively limited to 0 to -10C. -! (9) Ice precipitation rates can increase due to increase in response to -! cloud water riming due to (a) increased density & mass of the rimed -! ice, and (b) increased fall speeds of rimed ice. -! -> 8/22/01: This feature has been effectively limited to 0 to -10C. -!############################################################################### -!############################################################################### -! - SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & - & LSFC, P_col, QI_col, QR_col, QV_col, QW_col, RimeF_col, T_col, & - & THICK_col, WC_col, LM, RHC_col, XNCW, FLGmin, PRINT_diag, psfc) -! - implicit none -! -!############################################################################### -!############################################################################### -! -!------------------------------------------------------------------------------- -!----- NOTE: Code is currently set up w/o threading! -!------------------------------------------------------------------------------- -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: Grid-scale microphysical processes - condensation & precipitation -! PRGRMMR: Ferrier ORG: W/NP22 DATE: 08-2001 -!------------------------------------------------------------------------------- -! ABSTRACT: -! * Merges original GSCOND & PRECPD subroutines. -! * Code has been substantially streamlined and restructured. -! * Exchange between water vapor & small cloud condensate is calculated using -! the original Asai (1965, J. Japan) algorithm. See also references to -! Yau and Austin (1979, JAS), Rutledge and Hobbs (1983, JAS), and Tao et al. -! (1989, MWR). This algorithm replaces the Sundqvist et al. (1989, MWR) -! parameterization. -!------------------------------------------------------------------------------- -! -! USAGE: -! * CALL GSMCOLUMN FROM SUBROUTINE GSMDRIVE -! * SUBROUTINE GSMDRIVE CALLED FROM MAIN PROGRAM EBU -! -! INPUT ARGUMENT LIST: -! DTPH - physics time step (s) -! I_index - I index -! J_index - J index -! LSFC - Eta level of level above surface, ground -! P_col - vertical column of model pressure (Pa) -! QI_col - vertical column of model ice mixing ratio (kg/kg) -! QR_col - vertical column of model rain ratio (kg/kg) -! QV_col - vertical column of model water vapor specific humidity (kg/kg) -! QW_col - vertical column of model cloud water mixing ratio (kg/kg) -! RimeF_col - vertical column of rime factor for ice in model (ratio, defined below) -! T_col - vertical column of model temperature (deg K) -! THICK_col - vertical column of model mass thickness (density*height increment) -! WC_col - vertical column of model mixing ratio of total condensate (kg/kg) -! -! -! OUTPUT ARGUMENT LIST: -! ARAIN - accumulated rainfall at the surface (kg) -! ASNOW - accumulated snowfall at the surface (kg) -! QV_col - vertical column of model water vapor specific humidity (kg/kg) -! WC_col - vertical column of model mixing ratio of total condensate (kg/kg) -! QW_col - vertical column of model cloud water mixing ratio (kg/kg) -! QI_col - vertical column of model ice mixing ratio (kg/kg) -! QR_col - vertical column of model rain ratio (kg/kg) -! RimeF_col - vertical column of rime factor for ice in model (ratio, defined below) -! T_col - vertical column of model temperature (deg K) -! -! OUTPUT FILES: -! NONE -! -! Subprograms & Functions called: -! * Real Function CONDENSE - cloud water condensation -! * Real Function DEPOSIT - ice deposition (not sublimation) -! -! UNIQUE: NONE -! -! LIBRARY: NONE -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE : IBM SP -! -!------------------------------------------------------------------------- -!--------------- Arrays & constants in argument list --------------------- -!------------------------------------------------------------------------- -! -! INCLUDE "parmeta" -! INCLUDE "mpp.h" - integer lm - REAL ARAING, ASNOWG, P_col(LM), QI_col(LM), QR_col(LM), QV_col(LM)& - &, QW_col(LM), RimeF_col(LM), T_col(LM), THICK_col(LM), & - & WC_col(LM), RHC_col(LM), XNCW(LM), ARAIN, ASNOW, dtpg, psfc - real flgmin -! - INTEGER I_index, J_index, LSFC -! -! -!------------------------------------------------------------------------- -! -!--- Mean ice-particle diameters varying from 50 microns to 1000 microns -! (1 mm), assuming an exponential size distribution. -! -!---- Meaning of the following arrays: -! - mdiam - mean diameter (m) -! - VENTI1 - integrated quantity associated w/ ventilation effects -! (capacitance only) for calculating vapor deposition onto ice -! - VENTI2 - integrated quantity associated w/ ventilation effects -! (with fall speed) for calculating vapor deposition onto ice -! - ACCRI - integrated quantity associated w/ cloud water collection by ice -! - MASSI - integrated quantity associated w/ ice mass -! - VSNOWI - mass-weighted fall speed of snow (large ice), used to calculate -! precipitation rates -! - REAL, PARAMETER :: DMImin=.05e-3, DMImax=1.e-3, DelDMI=1.e-6, & - & XMImin=1.e6*DMImin, XMImax=1.e6*DMImax - INTEGER, PARAMETER :: MDImin=XMImin, MDImax=XMImax -! -!------------------------------------------------------------------------- -!------- Key parameters, local variables, & important comments --------- -!----------------------------------------------------------------------- -! -!--- KEY Parameters: -! -!---- Comments on 14 March 2002 -! * Set EPSQ to the universal value of 1.e-12 throughout the code -! condensate. The value of EPSQ will need to be changed in the other -! subroutines in order to make it consistent throughout the Eta code. -! * Set CLIMIT=10.*EPSQ as the lower limit for the total mass of -! condensate in the current layer and the input flux of condensate -! from above (TOT_ICE, TOT_ICEnew, TOT_RAIN, and TOT_RAINnew). -! -!-- NLImax - maximum number concentration of large ice crystals (20,000 /m**3, 20 per liter) -!-- NLImin - minimum number concentration of large ice crystals (100 /m**3, 0.1 per liter) -! - REAL, PARAMETER :: RHOL=1000., XLS=HVAP+HFUS & -! &, T_ICE=-10. !- Ver1 -! &, T_ICE_init=-5. !- Ver1 -!!! &, T_ICE=-20. !- Ver2 -! &, T_ICE=-40. !- Ver2 -! &, T_ICE_init=-15., !- Ver2 -! -! & CLIMIT=10.*EPSQ, EPS1=RV/RD-1., RCP=1./CP, - &,CLIMIT=10.*EPSQ, RCP=1./CP, & - & RCPRV=RCP/RV, RRHOL=1./RHOL, XLS1=XLS*RCP, XLS2=XLS*XLS*RCPRV, & - & XLS3=XLS*XLS/RV, & - & C1=1./3., C2=1./6., C3=3.31/6., & - & DMR1=.1E-3, DMR2=.2E-3, DMR3=.32E-3, N0r0=8.E6, N0rmin=1.e4, & - & N0s0=4.E6, RHO0=1.194, XMR1=1.e6*DMR1, XMR2=1.e6*DMR2, & - & XMR3=1.e6*DMR3, Xratio=.025 - INTEGER, PARAMETER :: MDR1=XMR1, MDR2=XMR2, MDR3=XMR3 -! -!--- If BLEND=1: -! precipitation (large) ice amounts are estimated at each level as a -! blend of ice falling from the grid point above and the precip ice -! present at the start of the time step (see TOT_ICE below). -!--- If BLEND=0: -! precipitation (large) ice amounts are estimated to be the precip -! ice present at the start of the time step. -! -!--- Extended to include sedimentation of rain on 2/5/01 -! - REAL, PARAMETER :: BLEND=1. -! -!--- This variable is for debugging purposes (if .true.) -! -! LOGICAL, PARAMETER :: PRINT_diag=.TRUE. - LOGICAL PRINT_diag -! -!--- Local variables -! - REAL EMAIRI, N0r, NLICE, NSmICE, NLImax, pfac - LOGICAL CLEAR, ICE_logical, DBG_logical, RAIN_logical - - integer lbef, ipass, ixrf, ixs, itdx, idr & - &, index_my, indexr, indexr1, indexs & - &, i, j, k, l, ntimes, item -! &, i, j, k, my_600, i1, i2, l, ntimes - real flimass, xlimass, vsnow, qi_min, dum, piloss & - &, tot_ice, xsimass, vel_inc, vrimef, rimef1, dum1 & - &, dum2, fws, denomi, dwv & - &, xrf, qw0, dli, xli, fsmall & - &, prevp, tk2, dtph & - &, pievp, picnd, piacr, pracw & - &, praut, pimlt, qtice, qlice & - &, gammar, flarge, wvqw, dynvis & - &, tfactor, denom, gammas, diffus, therm_cond & - &, wvnew, delv, tnew, tot_icenew, rimef & - &, deli, fwr, crevp, ventr, delt & - &, delw, fir, delr, qsinew, qswnew & - &, budget, wsnew, vrain2, tot_rainnew & - &, qtnew, qt, wcnew, abw & - &, aievp, tcc, denomf, abi & - &, sfactor, pidep_max, didep, ventis, ventil & - &, dievp, rqr, rfactor, dwvr, rr, tot_rain & - &, dwv0, qsw0, prloss, qtrain, vrain1 & - &, qsw, ws, esi, esw, wv, wc, rhgrd, rho & - &, rrho, dtrho, wsgrd, qsi, qswgrd, qsigrd & - &, tk, tc, pp, bldtrh & - &, xlv, xlv1, xlf, xlf1, xlv2, denomw, denomwi & - &, qwnew, pcond, pidep, qrnew, qi, qr, qw & - &, piacw, piacwi, piacwr, qv, dwvi & - &, arainnew, thick, asnownew & - &, qinew, qi_min_0c, QSW_l, QSI_l, QSW0_l - -! -! -!####################################################################### -!########################## Begin Execution ############################ -!####################################################################### -! - DTPH = DTPG / mic_step - ARAING=0. ! Total Accumulated rainfall into grid box from above (kg/m**2) - ASNOWG=0. ! Total Accumulated snowfall into grid box from above (kg/m**2) -! - do ntimes =1,mic_step -! - QI_min_0C=10.E3*MASSI(MDImin) !- Ver5 - ARAIN=0. ! Accumulated rainfall into grid box from above (kg/m**2) - ASNOW=0. ! Accumulated snowfall into grid box from above (kg/m**2) -! -!----------------------------------------------------------------------- -!------------ Loop from top (L=1) to surface (L=LSFC) ------------------ -!----------------------------------------------------------------------- -! - DO 10 L=1,LSFC - -!--- Skip this level and go to the next lower level if no condensate -! and very low specific humidities -! - IF (QV_col(L).LE.EPSQ .AND. WC_col(L).LE.EPSQ) GO TO 10 -! -!----------------------------------------------------------------------- -!------------ Proceed with cloud microphysics calculations ------------- -!----------------------------------------------------------------------- -! - TK=T_col(L) ! Temperature (deg K) - TC=TK-T0C ! Temperature (deg C) - PP=P_col(L) ! Pressure (Pa) - QV=QV_col(L) ! Specific humidity of water vapor (kg/kg) -! WV=QV/(1.-QV) ! Water vapor mixing ratio (kg/kg) - WV=QV ! Water vapor mixing ratio (kg/kg) - WC=WC_col(L) ! Grid-scale mixing ratio of total condensate (water or ice; kg/kg) -! WC=WC/(1.-WC) - RHgrd = RHC_col(L) -!go pfac = max(0.5, (sqrt(min(1.0, pp*0.00004)))) -! pfac = max(0.5, sqrt(sqrt(min(1.0, pp*0.00004)))) -! pfac = max(0.5, sqrt(sqrt(min(1.0, pp*0.000025)))) -! pfac = max(0.5, sqrt(sqrt(min(1.0, pp*0.000033)))) -! pfac = max(0.25, sqrt(sqrt(min(1.0, pp*0.00002)))) -! pfac = max(0.25, sqrt(sqrt(min(1.0, pp*0.00001)))) -! pfac = max(0.25, sqrt(sqrt(min(1.0, pp/psfc)))) -! pfac = max(0.1, sqrt(min(1.0, pp*0.00001))) -!Aug6 pfac = max(0.5, sqrt(sqrt(min(1.0, pp*0.00002)))) - pfac = max(0.5, sqrt(min(1.0, pp*0.000025))) -!! pfac = max(0.25, sqrt(sqrt(min(1.0, pp*0.000025)))) -! pfac = 1.0 -! -!----------------------------------------------------------------------- -!--- Moisture variables below are mixing ratios & not specifc humidities -!----------------------------------------------------------------------- -! - CLEAR=.TRUE. -! -!--- This check is to determine grid-scale saturation when no condensate is present -! - ESW=min(PP, FPVSL(TK)) ! Saturation vapor pressure w/r/t water -! QSW=EPS*ESW/(PP-ESW) ! Saturation mixing ratio w/r/t water - QSW=EPS*ESW/(PP+epsm1*ESW) ! Saturation specific humidity w/r/t water - WS=QSW ! General saturation mixing ratio (water/ice) - QSI = QSW - IF (TC .LT. 0.) THEN - ESI=min(PP,FPVSI(TK)) ! Saturation vapor pressure w/r/t ice -! QSI=EPS*ESI/(PP-ESI) ! Saturation mixing ratio w/r/t water - QSI=EPS*ESI/(PP+epsm1*ESI) ! Saturation specific humidity w/r/t water - WS=QSI ! General saturation mixing ratio (water/ice) - if (pp .le. esi) ws = wv /rhgrd - ENDIF -! - dum = min(PP, ESW0) - QSW0=EPS*dum/(PP+epsm1*dum) -! -!--- Effective grid-scale Saturation mixing ratios -! - QSWgrd=RHgrd*QSW - QSIgrd=RHgrd*QSI - WSgrd=RHgrd*WS - QSW_l = QSWgrd - QSI_l = QSIgrd - QSW0_l = QSW0*RHgrd -! -!--- Check if air is subsaturated and w/o condensate -! - IF (WV.GT.WSgrd .OR. WC.GT.EPSQ) CLEAR=.FALSE. -! -!--- Check if any rain is falling into layer from above -! - IF (ARAIN .GT. CLIMIT) THEN - CLEAR=.FALSE. - ELSE - ARAIN=0. - ENDIF -! -!--- Check if any ice is falling into layer from above -! -!--- NOTE that "SNOW" in variable names is synonomous with -! large, precipitation ice particles -! - IF (ASNOW .GT. CLIMIT) THEN - CLEAR=.FALSE. - ELSE - ASNOW=0. - ENDIF -! -!----------------------------------------------------------------------- -!-- Loop to the end if in clear, subsaturated air free of condensate --- -!----------------------------------------------------------------------- -! - IF (CLEAR) GO TO 10 -! -!----------------------------------------------------------------------- -!--------- Initialize RHO, THICK & microphysical processes ------------- -!----------------------------------------------------------------------- -! -! -!--- Virtual temperature, TV=T*(1./EPS-1)*Q, Q is specific humidity; -! (see pp. 63-65 in Fleagle & Businger, 1963) -! - RHO=PP/(RD*TK*(1.+EPS1*QV)) ! Air density (kg/m**3) - RRHO=1./RHO ! Reciprocal of air density - DTRHO=DTPH*RHO ! Time step * air density - BLDTRH=BLEND*DTRHO ! Blend parameter * time step * air density - THICK=THICK_col(L) ! Layer thickness = RHO*DZ = -DP/G = (Psfc-Ptop)*D_ETA/(G*ETA_sfc) -! - ARAINnew=0. ! Updated accumulated rainfall - ASNOWnew=0. ! Updated accumulated snowfall - QI=QI_col(L) ! Ice mixing ratio - QInew=0. ! Updated ice mixing ratio - QR=QR_col(L) ! Rain mixing ratio - QRnew=0. ! Updated rain ratio - QW=QW_col(L) ! Cloud water mixing ratio - QWnew=0. ! Updated cloud water ratio -! - PCOND=0. ! Condensation (>0) or evaporation (<0) of cloud water (kg/kg) - PIDEP=0. ! Deposition (>0) or sublimation (<0) of ice crystals (kg/kg) - PIACW=0. ! Cloud water collection (riming) by precipitation ice (kg/kg; >0) - PIACWI=0. ! Growth of precip ice by riming (kg/kg; >0) - PIACWR=0. ! Shedding of accreted cloud water to form rain (kg/kg; >0) - PIACR=0. ! Freezing of rain onto large ice at supercooled temps (kg/kg; >0) - PICND=0. ! Condensation (>0) onto wet, melting ice (kg/kg) - PIEVP=0. ! Evaporation (<0) from wet, melting ice (kg/kg) - PIMLT=0. ! Melting ice (kg/kg; >0) - PRAUT=0. ! Cloud water autoconversion to rain (kg/kg; >0) - PRACW=0. ! Cloud water collection (accretion) by rain (kg/kg; >0) - PREVP=0. ! Rain evaporation (kg/kg; <0) -! -!--- Double check input hydrometeor mixing ratios -! -! DUM=WC-(QI+QW+QR) -! DUM1=ABS(DUM) -! DUM2=TOLER*MIN(WC, QI+QW+QR) -! IF (DUM1 .GT. DUM2) THEN -! WRITE(6,"(/2(a,i4),a,i2)") '{@ i=',I_index,' j=',J_index, -! & ' L=',L -! WRITE(6,"(4(a12,g11.4,1x))") -! & '{@ TCold=',TC,'P=',.01*PP,'DIFF=',DUM,'WCold=',WC, -! & '{@ QIold=',QI,'QWold=',QW,'QRold=',QR -! ENDIF -! -!*********************************************************************** -!*********** MAIN MICROPHYSICS CALCULATIONS NOW FOLLOW! **************** -!*********************************************************************** -! -!--- Calculate a few variables, which are used more than once below -! -!--- Latent heat of vaporization as a function of temperature from -! Bolton (1980, JAS) -! - XLV=3.148E6-2370*TK ! Latent heat of vaporization (Lv) - XLF=XLS-XLV ! Latent heat of fusion (Lf) - XLV1=XLV*RCP ! Lv/Cp - XLF1=XLF*RCP ! Lf/Cp - TK2=1./(TK*TK) ! 1./TK**2 - XLV2=XLV*XLV*QSW_l*TK2/RV ! Lv**2*Qsw_l/(Rv*TK**2) - DENOMW=1.+XLV2*RCP ! Denominator term, Clausius-Clapeyron correction -! -!--- Basic thermodynamic quantities -! * DYNVIS - dynamic viscosity [ kg/(m*s) ] -! * THERM_COND - thermal conductivity [ J/(m*s*K) ] -! * DIFFUS - diffusivity of water vapor [ m**2/s ] -! - TFACTOR=TK**1.5/(TK+120.) - DYNVIS=1.496E-6*TFACTOR - THERM_COND=2.116E-3*TFACTOR - DIFFUS=8.794E-5*TK**1.81/PP -! -!--- Air resistance term for the fall speed of ice following the -! basic research by Heymsfield, Kajikawa, others -! - GAMMAS=(1.E5/PP)**C1 -! -!--- Air resistance for rain fall speed (Beard, 1985, JAOT, p.470) -! -!Moorthi GAMMAR=(RHO0/RHO)**.4 - GAMMAR=(RHO0/RHO)**0.4 -! GAMMAR=sqrt(RHO0/RHO) -! -!---------------------------------------------------------------------- -!------------- IMPORTANT MICROPHYSICS DECISION TREE ----------------- -!---------------------------------------------------------------------- -! -!--- Determine if conditions supporting ice are present -! - IF (TC.LT.0. .OR. QI.GT.EPSQ .OR. ASNOW.GT.CLIMIT) THEN - ICE_logical=.TRUE. - ELSE - ICE_logical=.FALSE. - QLICE=0. - QTICE=0. - ENDIF -! -!--- Determine if rain is present -! - RAIN_logical=.FALSE. - IF (ARAIN.GT.CLIMIT .OR. QR.GT.EPSQ) RAIN_logical=.TRUE. -! - IF (ICE_logical) THEN -! -!--- IMPORTANT: Estimate time-averaged properties. -! -!--- -! * FLARGE - ratio of number of large ice to total (large & small) ice -! * FSMALL - ratio of number of small ice crystals to large ice particles -! -> Small ice particles are assumed to have a mean diameter of 50 microns. -! * XSIMASS - used for calculating small ice mixing ratio -!--- -! * TOT_ICE - total mass (small & large) ice before microphysics, -! which is the sum of the total mass of large ice in the -! current layer and the input flux of ice from above -! * PILOSS - greatest loss (<0) of total (small & large) ice by -! sublimation, removing all of the ice falling from above -! and the ice within the layer -! * RimeF1 - Rime Factor, which is the mass ratio of total (unrimed & rimed) -! ice mass to the unrimed ice mass (>=1) -! * VrimeF - the velocity increase due to rime factor or melting (ratio, >=1) -! * VSNOW - Fall speed of rimed snow w/ air resistance correction -! * EMAIRI - equivalent mass of air associated layer and with fall of snow into layer -! * XLIMASS - used for calculating large ice mixing ratio -! * FLIMASS - mass fraction of large ice -! * QTICE - time-averaged mixing ratio of total ice -! * QLICE - time-averaged mixing ratio of large ice -! * NLICE - time-averaged number concentration of large ice -! * NSmICE - number concentration of small ice crystals at current level -!--- -!--- Assumed number fraction of large ice particles to total (large & small) -! ice particles, which is based on a general impression of the literature. -! - WVQW=WV+QW ! Water vapor & cloud water -! -!--- 6/19/03 - Deleted some code here .... -! -! ********************************************************* - -! IF (TC.GE.0. .OR. WVQW.LT.QSIgrd) THEN -! ! -! !--- Eliminate small ice particle contributions for melting & sublimation -! ! -! FLARGE=FLARGE1 -! ELSE -! ! -! !--- Enhanced number of small ice particles during depositional growth -! ! (effective only when 0C > T >= T_ice [-10C] ) -! ! -! FLARGE=FLARGE2 -! ! -! !--- Larger number of small ice particles due to rime splintering -! ! -! IF (TC.GE.-8. .AND. TC.LE.-3.) FLARGE=.5*FLARGE -! -! ENDIF ! End IF (TC.GE.0. .OR. WVQW.LT.QSIgrd) -! FSMALL=(1.-FLARGE)/FLARGE -! XSIMASS=RRHO*MASSI(MDImin)*FSMALL -! ********************************************************* -! - IF (QI.LE.EPSQ .AND. ASNOW.LE.CLIMIT) THEN - INDEXS=MDImin - FLARGE=0. !--- Begin 6/19/03 changes - FSMALL=1. - XSIMASS=RRHO*MASSI(MDImin) !--- End 6/19/03 changes - TOT_ICE=0. - PILOSS=0. - RimeF1=1. - VrimeF=1. - VEL_INC=GAMMAS - VSNOW=0. - EMAIRI=THICK - XLIMASS=RRHO*RimeF1*MASSI(INDEXS) - FLIMASS=XLIMASS/(XLIMASS+XSIMASS) - QLICE=0. - QTICE=0. - NLICE=0. - NSmICE=0. - ELSE - ! - !--- For T<0C mean particle size follows Houze et al. (JAS, 1979, p. 160), - ! converted from Fig. 5 plot of LAMDAs. Similar set of relationships - ! also shown in Fig. 8 of Ryan (BAMS, 1996, p. 66). - ! - !--- Begin 6/19/03 changes => allow NLImax to increase & FLARGE to - ! decrease at COLDER temperatures; set FLARGE to zero (i.e., only small - ! ice) if the ice mixing ratio is below QI_min -! DUM=MAX(0.05, MIN(1., EXP(.0536*TC)) ) - DUM=MAX(0.05, MIN(1., EXP(.0564*TC)) ) - INDEXS=MIN(MDImax, MAX(MDImin, INT(XMImax*DUM) ) ) -! NLImax=5.E3/sqrt(DUM) !- Ver3 -! - DUM=MAX(FLGmin*pfac, DUM) -! DUM=MAX(FLGmin, DUM) - QI_min=QI_min_0C * dum !- Ver5 -!! QI_min=QI_min_0C !- Ver5 -!!! QI_min=QI_min_0C/DUM !- Ver5 -! NLImax=20.E3 !- Ver3 => comment this line out -! NLImax=50.E3 !- Ver3 => comment this line out - NLImax=10.E3/sqrt(DUM) !- Ver3 -! NLImax=5.E3/sqrt(DUM) !- Ver3 -! NLImax=6.E3/sqrt(DUM) !- Ver3 -! NLImax=7.5E3/sqrt(DUM) !- Ver3 -! NLImax=20.E3/max(0.2,DUM) !- Ver3 -! NLImax=2.0E3/max(0.1,DUM) !- Ver3 -! NLImax=2.5E3/max(0.1,DUM) !- Ver3 -! NLImax=10.E3/max(0.2,DUM) !- Ver3 -! NLImax=4.E3/max(0.2,DUM) !- Ver3 - IF (TC .LT. 0.) THEN -! FLARGE=0.2 !- Ver4 => comment this line out - FLARGE=DUM !- Ver4 - ELSE - FLARGE=1. - ENDIF - FSMALL=(1.-FLARGE)/FLARGE - XSIMASS=RRHO*MASSI(MDImin)*FSMALL - TOT_ICE=THICK*QI+BLEND*ASNOW - PILOSS=-TOT_ICE/THICK - LBEF=MAX(1,L-1) - RimeF1=(RimeF_col(L)*THICK*QI & - & +RimeF_col(LBEF)*BLEND*ASNOW)/TOT_ICE - RimeF1=MIN(RimeF1, RFmax) - VSNOW=0.0 - DO IPASS=0,1 - IF (RimeF1 .LE. 1.) THEN - RimeF1=1. - VrimeF=1. - ELSE - IXS=MAX(2, MIN(INDEXS/100, 9)) - XRF=10.492*ALOG(RimeF1) - IXRF=MAX(0, MIN(INT(XRF), Nrime)) - IF (IXRF .GE. Nrime) THEN - VrimeF=VEL_RF(IXS,Nrime) - ELSE - VrimeF=VEL_RF(IXS,IXRF)+(XRF-FLOAT(IXRF))* & - & (VEL_RF(IXS,IXRF+1)-VEL_RF(IXS,IXRF)) - ENDIF - ENDIF ! End IF (RimeF1 .LE. 1.) - VEL_INC=GAMMAS*VrimeF - VSNOW=VEL_INC*VSNOWI(INDEXS) -! IF (QI.LT.QI_min .AND. TC.LE.T_ICE_init) then !- Ver5 -! dum = qi / max(qi_min, epsq) -! vsnow = vsnow * dum -! endif -!! IF (QI.LT.QI_min .AND. TC.LE.T_ICE_init) !- Ver5 -!! & VSNOW=VSNOW * 0.1 -!!! & VSNOW=VEL_INC*VSNOWI(INDEXS) !- Ver5 - EMAIRI=THICK+BLDTRH*VSNOW - XLIMASS=RRHO*RimeF1*MASSI(INDEXS) - FLIMASS=XLIMASS/(XLIMASS+XSIMASS) - QTICE=TOT_ICE/EMAIRI - QLICE=FLIMASS*QTICE - NLICE=QLICE/XLIMASS - NSmICE=Fsmall*NLICE - ! - IF ( (NLICE.GE.NLImin .AND. NLICE.LE.NLImax) & - & .OR. IPASS.EQ.1) THEN - EXIT - ELSE - IF(TC < 0) THEN - XLI=RHO*(QTICE/DUM-XSIMASS)/RimeF1 - IF (XLI .LE. MASSI(MDImin) ) THEN - INDEXS=MDImin - ELSE IF (XLI .LE. MASSI(450) ) THEN - DLI=9.5885E5*XLI**.42066 ! DLI in microns - INDEXS=MIN(MDImax, MAX(MDImin, INT(DLI) ) ) - ELSE IF (XLI .LE. MASSI(MDImax) ) THEN - DLI=3.9751E6*XLI**.49870 ! DLI in microns - INDEXS=MIN(MDImax, MAX(MDImin, INT(DLI) ) ) - ELSE - INDEXS=MDImax - ENDIF ! End IF (XLI .LE. MASSI(MDImin) ) - ENDIF ! End IF (TC < 0) - ! - !--- Reduce excessive accumulation of ice at upper levels - ! associated with strong grid-resolved ascent - ! - !--- Force NLICE to be between NLImin and NLImax - ! - !--- 8/22/01: Increase density of large ice if maximum limits - ! are reached for number concentration (NLImax) and mean size - ! (MDImax). Done to increase fall out of ice. - ! - ! - - DUM=MAX(NLImin, MIN(NLImax, NLICE) ) - IF (DUM .GE. NLImax .AND. INDEXS .GE. MDImax) & - & RimeF1=RHO*(QTICE/NLImax-XSIMASS)/MASSI(INDEXS) -! -! WRITE(6,"(4(a12,g11.4,1x))") -! & '{$ TC=',TC,'P=',.01*PP,'NLICE=',NLICE,'DUM=',DUM, -! & '{$ XLI=',XLI,'INDEXS=',FLOAT(INDEXS),'RHO=',RHO,'QTICE=',QTICE, -! & '{$ XSIMASS=',XSIMASS,'RimeF1=',RimeF1 - ENDIF ! End IF ( (NLICE.GE.NLImin .AND. NLICE.LE.NLImax) ... - ENDDO ! End DO IPASS=0,1 - ENDIF ! End IF (QI.LE.EPSQ .AND. ASNOW.LE.CLIMIT) - ENDIF ! End IF (ICE_logical) -! -!---------------------------------------------------------------------- -!--------------- Calculate individual processes ----------------------- -!---------------------------------------------------------------------- -! -!--- Cloud water autoconversion to rain and collection by rain -! - IF (QW.GT.EPSQ .AND. TC.GE.T_ICE) THEN - ! - !--- QW0 could be modified based on land/sea properties, - ! presence of convection, etc. This is why QAUT0 and CRAUT - ! are passed into the subroutine as externally determined - ! parameters. Can be changed in the future if desired. - ! -! QW0=QAUT0*RRHO - QW0=QAUTx*RRHO*XNCW(L) - PRAUT=MAX(0., QW-QW0)*CRAUT - IF (QLICE .GT. EPSQ) THEN - ! - !--- Collection of cloud water by large ice particles ("snow") - ! PIACWI=PIACW for riming, PIACWI=0 for shedding - ! -!Moor FWS=MIN(1., CIACW*VEL_INC*NLICE*ACCRI(INDEXS)/PP**C1) ! 20050422 - FWS=MIN(0.1, CIACW*VEL_INC*NLICE*ACCRI(INDEXS)/PP**C1) - PIACW=FWS*QW - IF (TC .LT. 0.) PIACWI=PIACW ! Large ice riming - ENDIF ! End IF (QLICE .GT. EPSQ) - ENDIF ! End IF (QW.GT.EPSQ .AND. TC.GE.T_ICE) -! -!---------------------------------------------------------------------- -!--- Loop around some of the ice-phase processes if no ice should be present -!---------------------------------------------------------------------- -! - IF (ICE_logical .EQV. .FALSE.) GO TO 20 -! -!--- Now the pretzel logic of calculating ice deposition -! - IF (TC.LT.T_ICE .AND. (WV.GT.QSIgrd .OR. QW.GT.EPSQ)) THEN - ! - !--- Adjust to ice saturation at T0) and evaporation - ! - DUM=PIEVP-PIMLT - IF (DUM .LT. PILOSS) THEN - DUM1=PILOSS/DUM - PIMLT=PIMLT*DUM1 - PIEVP=PIEVP*DUM1 - ENDIF ! End IF (DUM .GT. QTICE) - ENDIF ! End IF (TC.GT.0. .AND. TCC.GT.0. .AND. ICE_logical) -! -!--- IMPORTANT: Estimate time-averaged properties. -! -! * TOT_RAIN - total mass of rain before microphysics, which is the sum of -! the total mass of rain in the current layer and the input -! flux of rain from above -! * VRAIN1 - fall speed of rain into grid from above (with air resistance correction) -! * QTRAIN - time-averaged mixing ratio of rain (kg/kg) -! * PRLOSS - greatest loss (<0) of rain, removing all rain falling from -! above and the rain within the layer -! * RQR - rain content (kg/m**3) -! * INDEXR - mean size of rain drops to the nearest 1 micron in size -! * N0r - intercept of rain size distribution (typically 10**6 m**-4) -! - TOT_RAIN=0. - VRAIN1=0. - QTRAIN=0. - PRLOSS=0. - RQR=0. - N0r=0. - INDEXR1=INDEXR ! For debugging only - INDEXR=MDRmin - IF (RAIN_logical) THEN - IF (ARAIN .LE. 0.) THEN - INDEXR=MDRmin - VRAIN1=0. - ELSE - ! - !--- INDEXR (related to mean diameter) & N0r could be modified - ! by land/sea properties, presence of convection, etc. - ! - !--- Rain rate normalized to a density of 1.194 kg/m**3 - ! - RR=ARAIN/(DTPH*GAMMAR) - ! - IF (RR .LE. RR_DRmin) THEN - ! - !--- Assume fixed mean diameter of rain (0.2 mm) for low rain rates, - ! instead vary N0r with rain rate - ! - INDEXR=MDRmin - ELSE IF (RR .LE. RR_DR1) THEN - ! - !--- Best fit to mass-weighted fall speeds (V) from rain lookup tables - ! for mean diameters (Dr) between 0.05 and 0.10 mm: - ! V(Dr)=5.6023e4*Dr**1.136, V in m/s and Dr in m - ! RR = PI*1000.*N0r0*5.6023e4*Dr**(4+1.136) = 1.408e15*Dr**5.136, - ! RR in kg/(m**2*s) - ! Dr (m) = 1.123e-3*RR**.1947 -> Dr (microns) = 1.123e3*RR**.1947 - ! - INDEXR=INT( 1.123E3*RR**.1947 + .5 ) - INDEXR=MAX( MDRmin, MIN(INDEXR, MDR1) ) - ELSE IF (RR .LE. RR_DR2) THEN - ! - !--- Best fit to mass-weighted fall speeds (V) from rain lookup tables - ! for mean diameters (Dr) between 0.10 and 0.20 mm: - ! V(Dr)=1.0867e4*Dr**.958, V in m/s and Dr in m - ! RR = PI*1000.*N0r0*1.0867e4*Dr**(4+.958) = 2.731e14*Dr**4.958, - ! RR in kg/(m**2*s) - ! Dr (m) = 1.225e-3*RR**.2017 -> Dr (microns) = 1.225e3*RR**.2017 - ! - INDEXR=INT( 1.225E3*RR**.2017 + .5 ) - INDEXR=MAX( MDR1, MIN(INDEXR, MDR2) ) - ELSE IF (RR .LE. RR_DR3) THEN - ! - !--- Best fit to mass-weighted fall speeds (V) from rain lookup tables - ! for mean diameters (Dr) between 0.20 and 0.32 mm: - ! V(Dr)=2831.*Dr**.80, V in m/s and Dr in m - ! RR = PI*1000.*N0r0*2831.*Dr**(4+.80) = 7.115e13*Dr**4.80, - ! RR in kg/(m**2*s) - ! Dr (m) = 1.3006e-3*RR**.2083 -> Dr (microns) = 1.3006e3*RR**.2083 - ! - INDEXR=INT( 1.3006E3*RR**.2083 + .5 ) - INDEXR=MAX( MDR2, MIN(INDEXR, MDR3) ) - ELSE IF (RR .LE. RR_DRmax) THEN - ! - !--- Best fit to mass-weighted fall speeds (V) from rain lookup tables - ! for mean diameters (Dr) between 0.32 and 0.45 mm: - ! V(Dr)=944.8*Dr**.6636, V in m/s and Dr in m - ! RR = PI*1000.*N0r0*944.8*Dr**(4+.6636) = 2.3745e13*Dr**4.6636, - ! RR in kg/(m**2*s) - ! Dr (m) = 1.355e-3*RR**.2144 -> Dr (microns) = 1.355e3*RR**.2144 - ! - INDEXR=INT( 1.355E3*RR**.2144 + .5 ) - INDEXR=MAX( MDR3, MIN(INDEXR, MDRmax) ) - ELSE - ! - !--- Assume fixed mean diameter of rain (0.45 mm) for high rain rates, - ! instead vary N0r with rain rate - ! - INDEXR=MDRmax - ENDIF ! End IF (RR .LE. RR_DRmin) etc. - VRAIN1=GAMMAR*VRAIN(INDEXR) - ENDIF ! End IF (ARAIN .LE. 0.) - INDEXR1=INDEXR ! For debugging only - TOT_RAIN=THICK*QR+BLEND*ARAIN - QTRAIN=TOT_RAIN/(THICK+BLDTRH*VRAIN1) - PRLOSS=-TOT_RAIN/THICK - RQR=RHO*QTRAIN - ! - !--- RQR - time-averaged rain content (kg/m**3) - ! - IF (RQR .LE. RQR_DRmin) THEN - N0r=MAX(N0rmin, CN0r_DMRmin*RQR) - INDEXR=MDRmin - ELSE IF (RQR .GE. RQR_DRmax) THEN - N0r=CN0r_DMRmax*RQR - INDEXR=MDRmax - ELSE - N0r=N0r0 -! INDEXR=MAX( XMRmin, MIN(CN0r0*RQR**.25, XMRmax) ) - item = CN0r0*sqrt(sqrt(RQR)) ! Moorthi 07/31/08 - INDEXR = MAX( MDRmin, MIN(item, MDRmax) ) ! Moorthi 07/31/08 - ENDIF - ! - IF (TC .LT. T_ICE) THEN - PIACR=-PRLOSS - ELSE - DWVr=WV-PCOND-QSW_l - DUM=QW+PCOND - IF (DWVr.LT.0. .AND. DUM.LE.EPSQ) THEN - ! - !--- Rain evaporation - ! - ! * RFACTOR - [GAMMAR**.5]*[Schmidt**(1./3.)]*[(RHO/DYNVIS)**.5], - ! where Schmidt (Schmidt Number) =DYNVIS/(RHO*DIFFUS) - ! - ! * Units: RFACTOR - s**.5/m ; ABW - m**2/s ; VENTR - m**-2 ; - ! N0r - m**-4 ; VENTR1 - m**2 ; VENTR2 - m**3/s**.5 ; - ! CREVP - unitless - ! -! RFACTOR=GAMMAR**.5*(RHO/(DIFFUS*DIFFUS*DYNVIS))**C2 - RFACTOR=sqrt(GAMMAR)*(RHO/(DIFFUS*DIFFUS*DYNVIS))**C2 - ABW=1./(RHO*XLV2/THERM_COND+1./DIFFUS) - ! - !--- Note that VENTR1, VENTR2 lookup tables do not include the - ! 1/Davg multiplier as in the ice tables - ! - VENTR=N0r*(VENTR1(INDEXR)+RFACTOR*VENTR2(INDEXR)) - CREVP=ABW*VENTR*DTPH - IF (CREVP .LT. Xratio) THEN - DUM=DWVr*CREVP - ELSE - DUM=DWVr*(1.-EXP(-CREVP*DENOMW))/DENOMW - ENDIF - PREVP=MAX(DUM, PRLOSS) - ELSE IF (QW .GT. EPSQ) THEN - FWR=CRACW*GAMMAR*N0r*ACCRR(INDEXR) -!Moor PRACW=MIN(1.,FWR)*QW ! 20050422 - PRACW=MIN(0.1,FWR)*QW - ENDIF ! End IF (DWVr.LT.0. .AND. DUM.LE.EPSQ) - ! - IF (TC.LT.0. .AND. TCC.LT.0.) THEN - ! - !--- Biggs (1953) heteorogeneous freezing (e.g., Lin et al., 1983) - ! - Rescaled mean drop diameter from microns (INDEXR) to mm (DUM) to prevent underflow - ! - DUM=.001*FLOAT(INDEXR) - dum1 = dum * dum - DUM=(EXP(ABFR*TC)-1.)*DUM1*DUM1*DUM1*DUM - PIACR=MIN(CBFR*N0r*RRHO*DUM, QTRAIN) - IF (QLICE .GT. EPSQ) THEN - ! - !--- Freezing of rain by collisions w/ large ice - ! - DUM=GAMMAR*VRAIN(INDEXR) - DUM1=DUM-VSNOW - ! - !--- DUM2 - Difference in spectral fall speeds of rain and - ! large ice, parameterized following eq. (48) on p. 112 of - ! Murakami (J. Meteor. Soc. Japan, 1990) - ! - DUM2=(DUM1*DUM1+.04*DUM*VSNOW)**.5 - DUM1=5.E-12*INDEXR*INDEXR+2.E-12*INDEXR*INDEXS & - & +.5E-12*INDEXS*INDEXS - FIR=MIN(1., CIACR*NLICE*DUM1*DUM2) - ! - !--- Future? Should COLLECTION BY SMALL ICE SHOULD BE INCLUDED??? - ! - PIACR=MIN(PIACR+FIR*QTRAIN, QTRAIN) - ENDIF ! End IF (QLICE .GT. EPSQ) - DUM=PREVP-PIACR - If (DUM .LT. PRLOSS) THEN - DUM1=PRLOSS/DUM - PREVP=DUM1*PREVP - PIACR=DUM1*PIACR - ENDIF ! End If (DUM .LT. PRLOSS) - ENDIF ! End IF (TC.LT.0. .AND. TCC.LT.0.) - ENDIF ! End IF (TC .LT. T_ICE) - ENDIF ! End IF (RAIN_logical) -! -!---------------------------------------------------------------------- -!---------------------- Main Budget Equations ------------------------- -!---------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------- -!--- Update fields, determine characteristics for next lower layer ---- -!----------------------------------------------------------------------- -! -!--- Carefully limit sinks of cloud water -! - DUM1=PIACW+PRAUT+PRACW-MIN(0.,PCOND) - IF (DUM1 .GT. QW) THEN - DUM=QW/DUM1 - PIACW=DUM*PIACW - PIACWI=DUM*PIACWI - PRAUT=DUM*PRAUT - PRACW=DUM*PRACW - IF (PCOND .LT. 0.) PCOND=DUM*PCOND - ENDIF - PIACWR=PIACW-PIACWI ! TC >= 0C -! -!--- QWnew - updated cloud water mixing ratio -! - DELW=PCOND-PIACW-PRAUT-PRACW - QWnew=QW+DELW - IF (QWnew .LE. EPSQ) QWnew=0. - IF (QW.GT.0. .AND. QWnew.NE.0.) THEN - DUM=QWnew/QW - IF (DUM .LT. TOLER) QWnew=0. - ENDIF -! -!--- Update temperature and water vapor mixing ratios -! - DELT= XLV1*(PCOND+PIEVP+PICND+PREVP) & - & +XLS1*PIDEP+XLF1*(PIACWI+PIACR-PIMLT) - Tnew=TK+DELT -! - DELV=-PCOND-PIDEP-PIEVP-PICND-PREVP - WVnew=WV+DELV -! -!--- Update ice mixing ratios -! -!--- -! * TOT_ICEnew - total mass (small & large) ice after microphysics, -! which is the sum of the total mass of large ice in the -! current layer and the flux of ice out of the grid box below -! * RimeF - Rime Factor, which is the mass ratio of total (unrimed & -! rimed) ice mass to the unrimed ice mass (>=1) -! * QInew - updated mixing ratio of total (large & small) ice in layer -! -> TOT_ICEnew=QInew*THICK+BLDTRH*QLICEnew*VSNOW -! -> But QLICEnew=QInew*FLIMASS, so -! -> TOT_ICEnew=QInew*(THICK+BLDTRH*FLIMASS*VSNOW) -! * ASNOWnew - updated accumulation of snow at bottom of grid cell -!--- -! - DELI=0. - RimeF=1. - IF (ICE_logical) THEN - DELI=PIDEP+PIEVP+PIACWI+PIACR-PIMLT - TOT_ICEnew=TOT_ICE+THICK*DELI - IF (TOT_ICE.GT.0. .AND. TOT_ICEnew.NE.0.) THEN - DUM=TOT_ICEnew/TOT_ICE - IF (DUM .LT. TOLER) TOT_ICEnew=0. - ENDIF - IF (TOT_ICEnew .LE. CLIMIT) THEN - TOT_ICEnew=0. - RimeF=1. - QInew=0. - ASNOWnew=0. - ELSE - ! - !--- Update rime factor if appropriate - ! - DUM=PIACWI+PIACR - IF (DUM.LE.EPSQ .AND. PIDEP.LE.EPSQ) THEN - RimeF=RimeF1 - ELSE - ! - !--- Rime Factor, RimeF = (Total ice mass)/(Total unrimed ice mass) - ! DUM1 - Total ice mass, rimed & unrimed - ! DUM2 - Estimated mass of *unrimed* ice - ! - DUM1=TOT_ICE+THICK*(PIDEP+DUM) - DUM2=TOT_ICE/RimeF1+THICK*PIDEP - IF (DUM2 .LE. 0.) THEN - RimeF=RFmax - ELSE - RimeF=MIN(RFmax, MAX(1., DUM1/DUM2) ) - ENDIF - ENDIF ! End IF (DUM.LE.EPSQ .AND. PIDEP.LE.EPSQ) - QInew=TOT_ICEnew/(THICK+BLDTRH*FLIMASS*VSNOW) - IF (QInew .LE. EPSQ) QInew=0. - IF (QI.GT.0. .AND. QInew.NE.0.) THEN - DUM=QInew/QI - IF (DUM .LT. TOLER) QInew=0. - ENDIF - ASNOWnew=BLDTRH*FLIMASS*VSNOW*QInew - IF (ASNOW.GT.0. .AND. ASNOWnew.NE.0.) THEN - DUM=ASNOWnew/ASNOW - IF (DUM .LT. TOLER) ASNOWnew=0. - ENDIF - ENDIF ! End IF (TOT_ICEnew .LE. CLIMIT) - ENDIF ! End IF (ICE_logical) -! -!--- Update rain mixing ratios -! -!--- -! * TOT_RAINnew - total mass of rain after microphysics -! current layer and the input flux of ice from above -! * VRAIN2 - time-averaged fall speed of rain in grid and below -! (with air resistance correction) -! * QRnew - updated rain mixing ratio in layer -! -> TOT_RAINnew=QRnew*(THICK+BLDTRH*VRAIN2) -! * ARAINnew - updated accumulation of rain at bottom of grid cell -!--- -! - DELR=PRAUT+PRACW+PIACWR-PIACR+PIMLT+PREVP+PICND - TOT_RAINnew=TOT_RAIN+THICK*DELR - IF (TOT_RAIN.GT.0. .AND. TOT_RAINnew.NE.0.) THEN - DUM=TOT_RAINnew/TOT_RAIN - IF (DUM .LT. TOLER) TOT_RAINnew=0. - ENDIF - IF (TOT_RAINnew .LE. CLIMIT) THEN - TOT_RAINnew=0. - VRAIN2=0. - QRnew=0. - ARAINnew=0. - ELSE - ! - !--- 1st guess time-averaged rain rate at bottom of grid box - ! - RR=TOT_RAINnew/(DTPH*GAMMAR) - ! - !--- Use same algorithm as above for calculating mean drop diameter - ! (IDR, in microns), which is used to estimate the time-averaged - ! fall speed of rain drops at the bottom of the grid layer. This - ! isn't perfect, but the alternative is solving a transcendental - ! equation that is numerically inefficient and nasty to program - ! (coded in earlier versions of GSMCOLUMN prior to 8-22-01). - ! - IF (RR .LE. RR_DRmin) THEN - IDR=MDRmin - ELSE IF (RR .LE. RR_DR1) THEN - IDR=INT( 1.123E3*RR**.1947 + .5 ) - IDR=MAX( MDRmin, MIN(IDR, MDR1) ) - ELSE IF (RR .LE. RR_DR2) THEN - IDR=INT( 1.225E3*RR**.2017 + .5 ) - IDR=MAX( MDR1, MIN(IDR, MDR2) ) - ELSE IF (RR .LE. RR_DR3) THEN - IDR=INT( 1.3006E3*RR**.2083 + .5 ) - IDR=MAX( MDR2, MIN(IDR, MDR3) ) - ELSE IF (RR .LE. RR_DRmax) THEN - IDR=INT( 1.355E3*RR**.2144 + .5 ) - IDR=MAX( MDR3, MIN(IDR, MDRmax) ) - ELSE - IDR=MDRmax - ENDIF ! End IF (RR .LE. RR_DRmin) - VRAIN2=GAMMAR*VRAIN(IDR) - QRnew=TOT_RAINnew/(THICK+BLDTRH*VRAIN2) - IF (QRnew .LE. EPSQ) QRnew=0. - IF (QR.GT.0. .AND. QRnew.NE.0.) THEN - DUM=QRnew/QR - IF (DUM .LT. TOLER) QRnew=0. - ENDIF - ARAINnew=BLDTRH*VRAIN2*QRnew - IF (ARAIN.GT.0. .AND. ARAINnew.NE.0.) THEN - DUM=ARAINnew/ARAIN - IF (DUM .LT. TOLER) ARAINnew=0. - ENDIF - ENDIF ! End IF (TOT_RAINnew .LE. CLIMIT) -! - WCnew=QWnew+QRnew+QInew -! -!---------------------------------------------------------------------- -!-------------- Begin debugging & verification ------------------------ -!---------------------------------------------------------------------- -! -!--- QT, QTnew - total water (vapor & condensate) before & after microphysics, resp. -! -! QT=THICK*(QV+WC_col(l))+ARAIN+ASNOW -! QTnew=THICK*(WVnew/(1.+WVnew)+WCnew/(1.+wcnew)) -! & +ARAINnew+ASNOWnew - QT=THICK*(WV+WC)+ARAIN+ASNOW - QTnew=THICK*(WVnew+WCnew)+ARAINnew+ASNOWnew - BUDGET=QT-QTnew -! -!--- Additional check on budget preservation, accounting for truncation effects -! - DBG_logical=.FALSE. -! DUM=ABS(BUDGET) -! IF (DUM .GT. TOLER) THEN -! DUM=DUM/MIN(QT, QTnew) -! IF (DUM .GT. TOLER) DBG_logical=.TRUE. -! ENDIF -! -! DUM=(RHgrd+.001)*QSInew -! IF ( (QWnew.GT.EPSQ .OR. QRnew.GT.EPSQ .OR. WVnew.GT.DUM) -! & .AND. TC.LT.T_ICE ) DBG_logical=.TRUE. -! -! IF (TC.GT.5. .AND. QInew.GT.EPSQ) DBG_logical=.TRUE. -! - IF ((WVnew.LT.EPSQ .OR. DBG_logical) .AND. PRINT_diag) THEN - ! - WRITE(6,"(/2(a,i4),2(a,i2))") '{} i=',I_index,' j=',J_index,& - & ' L=',L,' LSFC=',LSFC - ! - ESW=min(PP, FPVSL(Tnew)) -! QSWnew=EPS*ESW/(PP-ESW) - QSWnew=EPS*ESW/(PP+epsm1*ESW) - IF (TC.LT.0. .OR. Tnew .LT. 0.) THEN - ESI=min(PP, FPVSI(Tnew)) -! QSInew=EPS*ESI/(PP-ESI) - QSInew=EPS*ESI/(PP+epsm1*ESI) - ELSE - QSI=QSW - QSInew=QSWnew - ENDIF - WSnew=QSInew - WRITE(6,"(4(a12,g11.4,1x))") & - & '{} TCold=',TC,'TCnew=',Tnew-T0C,'P=',.01*PP,'RHO=',RHO, & - & '{} THICK=',THICK,'RHold=',WV/WS,'RHnew=',WVnew/WSnew, & - & 'RHgrd=',RHgrd, & - & '{} RHWold=',WV/QSW,'RHWnew=',WVnew/QSWnew,'RHIold=',WV/QSI, & - & 'RHInew=',WVnew/QSInew, & - & '{} QSWold=',QSW,'QSWnew=',QSWnew,'QSIold=',QSI,'QSInew=',QSInew,& - & '{} WSold=',WS,'WSnew=',WSnew,'WVold=',WV,'WVnew=',WVnew, & - & '{} WCold=',WC,'WCnew=',WCnew,'QWold=',QW,'QWnew=',QWnew, & - & '{} QIold=',QI,'QInew=',QInew,'QRold=',QR,'QRnew=',QRnew, & - & '{} ARAINold=',ARAIN,'ARAINnew=',ARAINnew,'ASNOWold=',ASNOW, & - & 'ASNOWnew=',ASNOWnew, & - & '{} TOT_RAIN=',TOT_RAIN,'TOT_RAINnew=',TOT_RAINnew, & - & 'TOT_ICE=',TOT_ICE,'TOT_ICEnew=',TOT_ICEnew, & - & '{} BUDGET=',BUDGET,'QTold=',QT,'QTnew=',QTnew - ! - WRITE(6,"(4(a12,g11.4,1x))") & - & '{} DELT=',DELT,'DELV=',DELV,'DELW=',DELW,'DELI=',DELI, & - & '{} DELR=',DELR,'PCOND=',PCOND,'PIDEP=',PIDEP,'PIEVP=',PIEVP, & - & '{} PICND=',PICND,'PREVP=',PREVP,'PRAUT=',PRAUT,'PRACW=',PRACW, & - & '{} PIACW=',PIACW,'PIACWI=',PIACWI,'PIACWR=',PIACWR,'PIMLT=', & - & PIMLT, & - & '{} PIACR=',PIACR - ! - IF (ICE_logical) WRITE(6,"(4(a12,g11.4,1x))") & - & '{} RimeF1=',RimeF1,'GAMMAS=',GAMMAS,'VrimeF=',VrimeF, & - & 'VSNOW=',VSNOW, & - & '{} INDEXS=',FLOAT(INDEXS),'FLARGE=',FLARGE,'FSMALL=',FSMALL, & - & 'FLIMASS=',FLIMASS, & - & '{} XSIMASS=',XSIMASS,'XLIMASS=',XLIMASS,'QLICE=',QLICE, & - & 'QTICE=',QTICE, & - & '{} NLICE=',NLICE,'NSmICE=',NSmICE,'PILOSS=',PILOSS, & - & 'EMAIRI=',EMAIRI, & - & '{} RimeF=',RimeF - ! - IF (TOT_RAIN.GT.0. .OR. TOT_RAINnew.GT.0.) & - & WRITE(6,"(4(a12,g11.4,1x))") & - & '{} INDEXR1=',FLOAT(INDEXR1),'INDEXR=',FLOAT(INDEXR), & - & 'GAMMAR=',GAMMAR,'N0r=',N0r, & - & '{} VRAIN1=',VRAIN1,'VRAIN2=',VRAIN2,'QTRAIN=',QTRAIN,'RQR=',RQR,& - & '{} PRLOSS=',PRLOSS,'VOLR1=',THICK+BLDTRH*VRAIN1, & - & 'VOLR2=',THICK+BLDTRH*VRAIN2 - ! - IF (PRAUT .GT. 0.) WRITE(6,"(a12,g11.4,1x)") '{} QW0=',QW0 - ! - IF (PRACW .GT. 0.) WRITE(6,"(a12,g11.4,1x)") '{} FWR=',FWR - ! - IF (PIACR .GT. 0.) WRITE(6,"(a12,g11.4,1x)") '{} FIR=',FIR - ! - DUM=PIMLT+PICND-PREVP-PIEVP - IF (DUM.GT.0. .or. DWVi.NE.0.) & - & WRITE(6,"(4(a12,g11.4,1x))") & - & '{} TFACTOR=',TFACTOR,'DYNVIS=',DYNVIS, & - & 'THERM_CON=',THERM_COND,'DIFFUS=',DIFFUS - ! - IF (PREVP .LT. 0.) WRITE(6,"(4(a12,g11.4,1x))") & - & '{} RFACTOR=',RFACTOR,'ABW=',ABW,'VENTR=',VENTR,'CREVP=',CREVP, & - & '{} DWVr=',DWVr,'DENOMW=',DENOMW - ! - IF (PIDEP.NE.0. .AND. DWVi.NE.0.) & - & WRITE(6,"(4(a12,g11.4,1x))") & - & '{} DWVi=',DWVi,'DENOMI=',DENOMI,'PIDEP_max=',PIDEP_max, & - & 'SFACTOR=',SFACTOR, & - & '{} ABI=',ABI,'VENTIL=',VENTIL,'VENTIL1=',VENTI1(INDEXS), & - & 'VENTIL2=',SFACTOR*VENTI2(INDEXS), & - & '{} VENTIS=',VENTIS,'DIDEP=',DIDEP - ! - IF (PIDEP.GT.0. .AND. PCOND.NE.0.) & - & WRITE(6,"(4(a12,g11.4,1x))") & - & '{} DENOMW=',DENOMW,'DENOMWI=',DENOMWI,'DENOMF=',DENOMF, & - & 'DUM2=',PCOND-PIACW - ! - IF (FWS .GT. 0.) WRITE(6,"(4(a12,g11.4,1x))") & - & '{} FWS=',FWS - ! - DUM=PIMLT+PICND-PIEVP - IF (DUM.GT. 0.) WRITE(6,"(4(a12,g11.4,1x))") & - & '{} SFACTOR=',SFACTOR,'VENTIL=',VENTIL,'VENTIL1=',VENTI1(INDEXS),& - & 'VENTIL2=',SFACTOR*VENTI2(INDEXS), & - & '{} AIEVP=',AIEVP,'DIEVP=',DIEVP,'QSW0=',QSW0,'DWV0=',DWV0 - ! -! if(lsfc .gt. 0) stop - ENDIF -! -!---------------------------------------------------------------------- -!-------------- Water budget statistics & maximum values -------------- -!---------------------------------------------------------------------- -! - IF (PRINT_diag) THEN - ITdx=MAX( ITLO, MIN( INT(Tnew-T0C), ITHI ) ) - IF (QInew .GT. EPSQ) NSTATS(ITdx,1)=NSTATS(ITdx,1)+1 - IF (QInew.GT.EPSQ .AND. QRnew+QWnew.GT.EPSQ) & - & NSTATS(ITdx,2)=NSTATS(ITdx,2)+1 - IF (QWnew .GT. EPSQ) NSTATS(ITdx,3)=NSTATS(ITdx,3)+1 - IF (QRnew .GT. EPSQ) NSTATS(ITdx,4)=NSTATS(ITdx,4)+1 - ! - QMAX(ITdx,1)=MAX(QMAX(ITdx,1), QInew) - QMAX(ITdx,2)=MAX(QMAX(ITdx,2), QWnew) - QMAX(ITdx,3)=MAX(QMAX(ITdx,3), QRnew) - QMAX(ITdx,4)=MAX(QMAX(ITdx,4), ASNOWnew) - QMAX(ITdx,5)=MAX(QMAX(ITdx,5), ARAINnew) - QTOT(ITdx,1)=QTOT(ITdx,1)+QInew*THICK - QTOT(ITdx,2)=QTOT(ITdx,2)+QWnew*THICK - QTOT(ITdx,3)=QTOT(ITdx,3)+QRnew*THICK - ! - QTOT(ITdx,4)=QTOT(ITdx,4)+PCOND*THICK - QTOT(ITdx,5)=QTOT(ITdx,5)+PICND*THICK - QTOT(ITdx,6)=QTOT(ITdx,6)+PIEVP*THICK - QTOT(ITdx,7)=QTOT(ITdx,7)+PIDEP*THICK - QTOT(ITdx,8)=QTOT(ITdx,8)+PREVP*THICK - QTOT(ITdx,9)=QTOT(ITdx,9)+PRAUT*THICK - QTOT(ITdx,10)=QTOT(ITdx,10)+PRACW*THICK - QTOT(ITdx,11)=QTOT(ITdx,11)+PIMLT*THICK - QTOT(ITdx,12)=QTOT(ITdx,12)+PIACW*THICK - QTOT(ITdx,13)=QTOT(ITdx,13)+PIACWI*THICK - QTOT(ITdx,14)=QTOT(ITdx,14)+PIACWR*THICK - QTOT(ITdx,15)=QTOT(ITdx,15)+PIACR*THICK - ! - QTOT(ITdx,16)=QTOT(ITdx,16)+(WVnew-WV)*THICK - QTOT(ITdx,17)=QTOT(ITdx,17)+(QWnew-QW)*THICK - QTOT(ITdx,18)=QTOT(ITdx,18)+(QInew-QI)*THICK - QTOT(ITdx,19)=QTOT(ITdx,19)+(QRnew-QR)*THICK - QTOT(ITdx,20)=QTOT(ITdx,20)+(ARAINnew-ARAIN) - QTOT(ITdx,21)=QTOT(ITdx,21)+(ASNOWnew-ASNOW) - IF (QInew .GT. 0.) & - & QTOT(ITdx,22)=QTOT(ITdx,22)+QInew*THICK/RimeF - ! - ENDIF -! -!---------------------------------------------------------------------- -!------------------------- Update arrays ------------------------------ -!---------------------------------------------------------------------- -! - T_col(L)=Tnew ! Updated temperature -! -! QV_col(L)=max(EPSQ, WVnew/(1.+WVnew)) ! Updated specific humidity - QV_col(L)=max(0.0, WVnew ) ! Updated specific humidity - WC_col(L)=max(0.0, WCnew) ! Updated total condensate mixing ratio - QI_col(L)=max(0.0, QInew) ! Updated ice mixing ratio - QR_col(L)=max(0.0, QRnew) ! Updated rain mixing ratio - QW_col(L)=max(0.0, QWnew) ! Updated cloud water mixing ratio - RimeF_col(L)=RimeF ! Updated rime factor - ASNOW=ASNOWnew ! Updated accumulated snow - ARAIN=ARAINnew ! Updated accumulated rain -! -!####################################################################### -! -10 CONTINUE ! ##### End "L" loop through model levels ##### -! - ARAING = ARAING + ARAIN - ASNOWG = ASNOWG + ASNOW - enddo ! do for ntimes=1,mic_step -! -!####################################################################### -! -!----------------------------------------------------------------------- -!--------------------------- Return to GSMDRIVE ----------------------- -!----------------------------------------------------------------------- -! - CONTAINS -! END SUBROUTINE GSMCOLUMN -! -!####################################################################### -!--------- Produces accurate calculation of cloud condensation --------- -!####################################################################### -! - REAL FUNCTION CONDENSE (PP, QW, RHgrd, TK, WV) -! - implicit none -! -!--------------------------------------------------------------------------------- -!------ The Asai (1965) algorithm takes into consideration the release of ------ -!------ latent heat in increasing the temperature & in increasing the ------ -!------ saturation mixing ratio (following the Clausius-Clapeyron eqn.). ------ -!--------------------------------------------------------------------------------- -! - real pp, qw, rhgrd, tk, wv - INTEGER, PARAMETER :: HIGH_PRES=kind_phys -! INTEGER, PARAMETER :: HIGH_PRES=Selected_Real_Kind(15) - REAL (KIND=HIGH_PRES), PARAMETER :: & - & RHLIMIT=.001, RHLIMIT1=-RHLIMIT - REAL, PARAMETER :: RCP=1./CP, RCPRV=RCP/RV - REAL (KIND=HIGH_PRES) :: COND, SSAT, WCdum, tsq - real wvdum, tdum, xlv, xlv1, xlv2, ws, dwv, esw -! -!----------------------------------------------------------------------- -! -!--- LV (T) is from Bolton (JAS, 1980) -! -! XLV=3.148E6-2370.*TK -! XLV1=XLV*RCP -! XLV2=XLV*XLV*RCPRV -! - Tdum=TK - WVdum=WV - WCdum=QW - ESW=min(PP, FPVSL(Tdum)) ! Saturation vapor press w/r/t water -! WS=RHgrd*EPS*ESW/(PP-ESW) ! Saturation mixing ratio w/r/t water - WS=RHgrd*EPS*ESW/(PP+epsm1*ESW) ! Saturation mixing ratio w/r/t water - DWV=WVdum-WS ! Deficit grid-scale water vapor mixing ratio - SSAT=DWV/WS ! Supersaturation ratio - CONDENSE=0. - DO WHILE ((SSAT.LT.RHLIMIT1 .AND. WCdum.GT.EPSQ) & - & .OR. SSAT.GT.RHLIMIT) -! - XLV=3.148E6-2370.*Tdum - XLV1=XLV*RCP - XLV2=XLV*XLV*RCPRV -! -! COND=DWV/(1.+XLV2*WS/(Tdum*Tdum)) ! Asai (1965, J. Japan) - tsq =Tdum*Tdum - COND=DWV*tsq/(tsq+XLV2*WS) ! Asai (1965, J. Japan) - COND=MAX(COND, -WCdum) ! Limit cloud water evaporation - Tdum=Tdum+XLV1*COND ! Updated temperature - WVdum=WVdum-COND ! Updated water vapor mixing ratio - WCdum=WCdum+COND ! Updated cloud water mixing ratio - CONDENSE=CONDENSE+COND ! Total cloud water condensation - ESW=min(PP, FPVSL(Tdum)) ! Updated saturation vapor press w/r/t water -! WS=RHgrd*EPS*ESW/(PP-ESW) ! Updated saturation mixing ratio w/r/t water - WS=RHgrd*EPS*ESW/(PP+epsm1*ESW) ! Updated saturation mixing ratio w/r/t water - DWV=WVdum-WS ! Deficit grid-scale water vapor mixing ratio - SSAT=DWV/WS ! Grid-scale supersaturation ratio - ENDDO - - END FUNCTION CONDENSE -! -!####################################################################### -!---------------- Calculate ice deposition at T=-10C, - ! all ice for T<=-30C, - ! and a linear mixture at -10C > T > -30C - ! - ! * Determine hydrometeor composition of total condensate (QTOT) - ! -! pp = prsl(i,l) * 1000.0 - pp = prsl(i,l) / prsi(i,levs+1) -! pfac = max(0.25, sqrt(sqrt(min(1.0, pp*0.000025)))) -! pfac = max(0.5, sqrt(sqrt(min(1.0, pp*0.000025)))) -! pfac = max(0.5, sqrt(sqrt(min(1.0, pp*0.00002)))) -! pfac = max(0.25, sqrt(sqrt(min(1.0, pp*0.00001)))) -! pfac = max(0.25, sqrt(sqrt(min(1.0, pp)))) -! pfac = max(0.1, sqrt(min(1.0, pp*0.00001))) -! pfac = max(0.5, sqrt(sqrt(min(1.0, pp*0.000033)))) -! pfac = max(0.5, sqrt(sqrt(min(1.0, pp*0.00004)))) -!go pfac = max(0.5, (sqrt(min(1.0, pp*0.000025)))) - pfac = 1.0 - TC = T(I,L) - t0c - QTOT = clw(I,L) - IF (QTOT .GT. EPSQ) THEN - QCWAT=0. - QCICE=0. - QRAIN=0. - QSNOW=0. - FRice = max(0.0, min(1.0, F_ice(I,L))) - FRrain = max(0.0, min(1.0, F_rain(I,L))) - IF(TC.LE.Thom) then - QCICE = QTOT - ELSE - QCICE = FRice * QTOT - QCWAT = QTOT - QCICE - QRAIN = FRrain * QCWAT - QCWAT = QCWAT - QRAIN - ENDIF - ! - !--- Air density (RHO), model mass thickness (CPATH) - ! - RHO = PRSL(I,L)/(RD*T(I,L)*(1.+EPS1*Q(I,L))) - CPATH = (PRSI(I,L+1)-PRSI(I,L))*(1000000.0/grav) - - !! CLOUD WATER - ! - !--- Effective radius (RECWAT) & total water path (CWATP) - ! Assume monodisperse distribution of droplets (no factor of 1.5) - ! - IF(QCWAT .GT. 0.) THEN - RECWAT(I,L) = MAX(RECWmin, RECW1*(RHO*QCWAT)**CEXP) - CWATP(I,L) = CPATH*QCWAT ! cloud water path -! tem = 5.0*(1+max(0.0,min(1.0,-0.05*tc))) -! RECWAT(I,L) = max(RECWAT(I,L), tem) - ENDIF - - !! RAIN - ! - !--- Effective radius (RERAIN) & total water path (RAINP) - !--- Factor of 1.5 accounts for r**3/r**2 moments for exponentially - ! distributed drops in effective radius calculations - ! (from M.D. Chou's code provided to Y.-T. Hou) - ! - IF(QRAIN .GT. 0.) THEN - DRAIN = CN0r0*sqrt(sqrt((RHO*QRAIN))) - RERAIN(I,L) = 1.5*MAX(XMRmin, MIN(DRAIN, XMRmax)) - RAINP(I,L) = CPATH*QRAIN ! rain water path - ENDIF - - !! SNOW (large ice) & CLOUD ICE - ! - !--- Effective radius (RESNOW) & total ice path (SNOWP) - !--- Total ice path (CICEP) for cloud ice - !--- Factor of 1.5 accounts for r**3/r**2 moments for exponentially - ! distributed ice particles in effective radius calculations - ! - !--- Separation of cloud ice & "snow" uses algorithm from - ! subroutine GSMCOLUMN - ! - IF(QCICE .GT. 0.) THEN - ! - !--- Mean particle size following Houze et al. (JAS, 1979, p. 160), - ! converted from Fig. 5 plot of LAMDAs. An analogous set of - ! relationships also shown by Fig. 8 of Ryan (BAMS, 1996, p. 66), - ! but with a variety of different relationships that parallel the - ! Houze curves. - ! -! DUM=MAX(0.05, MIN(1., EXP(.0536*TC)) ) - DUM=MAX(0.05, MIN(1., EXP(.0564*TC)) ) - INDEXS=MIN(MDImax, MAX(MDImin, INT(XMImax*DUM) ) ) -! indexs=max(INDEXSmin, indexs) -! NLImax=5.E3/sqrt(DUM) !- Ver3 - DUM=MAX(FLGmin*pfac, DUM) -! DUM=MAX(FLGmin, DUM) -! NLImax=20.E3 !- Ver3 -! NLImax=50.E3 !- Ver3 => comment this line out - NLImax=10.E3/sqrt(DUM) !- Ver3 -! NLImax=5.E3/sqrt(DUM) !- Ver3 -! NLImax=6.E3/sqrt(DUM) !- Ver3 -! NLImax=7.5E3/sqrt(DUM) !- Ver3 -! NLImax=20.E3/DUM !- Ver3 -! NLImax=20.E3/max(0.2,DUM) !- Ver3 -! NLImax=2.0E3/max(0.1,DUM) !- Ver3 -! NLImax=2.5E3/max(0.1,DUM) !- Ver3 -! NLImax=10.E3/max(0.2,DUM) !- Ver3 -! NLImax=4.E3/max(0.2,DUM) !- Ver3 -!Moorthi DSNOW = XMImax*EXP(.0536*TC) -!Moorthi INDEXS = MAX(INDEXSmin, MIN(MDImax, INT(DSNOW))) - ! - !--- Assumed number fraction of large ice to total (large & small) - ! ice particles, which is based on a general impression of the - ! literature. - ! - ! Small ice are assumed to have a mean diameter of 50 microns. - ! - IF(TC .GE. 0.) THEN - FLARGE=FLG1P0 - ELSE - FLARGE = dum - ENDIF -!------------------------Commented by Moorthi ----------------------------- -! ELSEIF (TC .GE. -25.) THEN -! -!--- Note that absence of cloud water (QCWAT) is used as a quick -! substitute for calculating water subsaturation as in GSMCOLUMN -! -! IF(QCWAT.LE.0. .OR. TC.LT.-8. -! & .OR. TC.GT.-3.)THEN -! FLARGE=FLG0P2 -! ELSE - -!--- Parameterize effects of rime splintering by increasing -! number of small ice particles -! -! FLARGE=FLG0P1 -! ENDIF -! ELSEIF (TC .LE. -50.) THEN -! FLARGE=.01 -! ELSE -! FLARGE=.2*EXP(.1198*(TC+25)) -! ENDIF -!____________________________________________________________________________ - - RimeF=MAX(1., F_RIME(I,L)) - XSIMASS=MASSI(MDImin)*(1.-FLARGE)/FLARGE -! if (lprnt) print *,' rimef=',rimef,' xsimass=',xsimass -! &,' indexs=',indexs,' massi=',massi(indexs),' flarge=',flarge - NLICE=RHO*QCICE/(XSIMASS+RimeF*MASSI(INDEXS)) - ! - !--- From subroutine GSMCOLUMN: - !--- Minimum number concentration for large ice of NLImin=10/m**3 - ! at T>=0C. Done in order to prevent unrealistically small - ! melting rates and tiny amounts of snow from falling to - ! unrealistically warm temperatures. - ! - IF(TC .GE. 0.) THEN - NLICE=MAX(NLImin, NLICE) - ELSEIF (NLICE .GT. NLImax) THEN - ! - !--- Ferrier 6/13/01: Prevent excess accumulation of ice - ! - XLI=(RHO*QCICE/NLImax-XSIMASS)/RimeF - - IF(XLI .LE. MASSI(450) ) THEN - DSNOW=9.5885E5*XLI**.42066 - ELSE - DSNOW=3.9751E6*XLI**.49870 - ENDIF - - INDEXS=MIN(MDImax, MAX(INDEXS, INT(DSNOW))) - NLICE=RHO*QCICE/(XSIMASS+RimeF*MASSI(INDEXS)) - ENDIF - -! if (tc .gt. -20.0 .and. indexs .ge. indexsmin) then -! snofac = max(0.0, min(1.0, exp(1.0*(tc+20.0)))) -! if (indexs .ge. indexsmin) then -! if (tc .gt. -20.0 .or. indexs .ge. indexsmin) then -! if (tc .gt. -40.0) then -! if (tc .ge. -40.0 .or. prsl(i,l) .gt. 50.0) then -!! if (tc .ge. -20.0) then -! if (tc .ge. -20.0 .or. prsl(i,l) .gt. 50.0) then -! if ((tc .ge. -20.0 .or. -! & prsi(i,levs+1)-prsi(i,l) .lt. 30.0) - if (prsi(i,levs+1)-prsi(i,l) .lt. 40.0 & -! if (prsi(i,levs+1)-prsi(i,l) .lt. 70.0 - & .and. indexs .ge. indexsmin) then -! & prsi(i,levs)-prsl(i,l) .lt. 20.0) then -! & prsi(i,levs)-prsl(i,l) .lt. 30.0) then -! & prsi(i,levs)-prsl(i,l) .lt. 40.0) then -! snofac = max(0.0, min(1.0, 0.05*(tc+40.0))) -! snofac = max(0.0, min(1.0, 0.1*(tc+25.0))) -! snofac = max(0.0, min(1.0, 0.0667*(tc+25.0))) -! if (indexs .gt. indexsmin) then - QSNOW = MIN(QCICE, NLICE*RimeF*MASSI(INDEXS)/RHO) -! & * snofac - endif -! qsnow = qcice - QCICE = MAX(0., QCICE-QSNOW) -! qsnow = 0.0 - CICEP (I,L) = CPATH*QCICE ! cloud ice path - RESNOW(I,L) = 1.5*FLOAT(INDEXS) - SDEN = SDENS(INDEXS)/RimeF ! 1/snow density - SNOWP (I,L) = CPATH*QSNOW*SDEN ! snow path / snow density -! SNOWP (I,L) = CPATH*QSNOW ! snow path / snow density -! if (lprnt .and. i .eq. ipr) then -! print *,' L=',L,' snowp=',snowp(i,l),' cpath=',cpath -! &,' qsnow=',qsnow,' sden=',sden,' rimef=',rimef,' indexs=',indexs -! &,' sdens=',sdens(indexs),' resnow=',resnow(i,l) -! &,' qcice=',qcice,' cicep=',cicep(i,l) -! endif - - - ENDIF ! END QCICE BLOCK - ENDIF ! QTOT IF BLOCK - - ENDDO - ENDDO -! - END SUBROUTINE rsipath - - - -!----------------------------------- - subroutine rsipath2 & -!................................... - -! --- inputs: - & ( plyr, plvl, tlyr, qlyr, qcwat, qcice, qrain, rrime, & - & IM, LEVS, iflip, flgmin, & -! --- outputs: - & cwatp, cicep, rainp, snowp, recwat, rerain, resnow, snden & - & ) - -! ================= subprogram documentation block ================ ! -! ! -! abstract: this program is a modified version of ferrier's original ! -! "rsipath" subprogram. it computes layer's cloud liquid, ice, rain, ! -! and snow water condensate path and the partical effective radius ! -! for liquid droplet, rain drop, and snow flake. ! -! ! -! ==================== defination of variables ==================== ! -! ! -! input variables: ! -! plyr (IM,LEVS) : model layer mean pressure in mb (100Pa) ! -! plvl (IM,LEVS+1):model level pressure in mb (100Pa) ! -! tlyr (IM,LEVS) : model layer mean temperature in k ! -! qlyr (IM,LEVS) : layer specific humidity in gm/gm ! -! qcwat (IM,LEVS) : layer cloud liquid water condensate amount ! -! qcice (IM,LEVS) : layer cloud ice water condensate amount ! -! qrain (IM,LEVS) : layer rain drop water amount ! -! rrime (IM,LEVS) : mass ratio of total to unrimed ice ( >= 1 ) ! -! IM : horizontal dimention ! -! LEVS : vertical layer dimensions ! -! iflip : control flag for in/out vertical indexing ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! flgmin : Minimum large ice fraction ! -! lprnt : logical check print control flag ! -! ! -! output variables: ! -! cwatp (IM,LEVS) : layer cloud liquid water path ! -! cicep (IM,LEVS) : layer cloud ice water path ! -! rainp (IM,LEVS) : layer rain water path ! -! snowp (IM,LEVS) : layer snow water path ! -! recwat(IM,LEVS) : layer cloud eff radius for liqid water (micron) ! -! rerain(IM,LEVS) : layer rain water effective radius (micron) ! -! resnow(IM,LEVS) : layer snow flake effective radius (micron) ! -! snden (IM,LEVS) : 1/snow density ! -! ! -! ! -! usage: call rsipath2 ! -! ! -! subroutines called: none ! -! ! -! program history log: ! -! xx-xx-2001 b. ferrier - original program ! -! xx-xx-2004 s. moorthi - modified for use in gfs model ! -! 05-20-2004 y. hou - modified, added vertical index flag! -! to reduce data flipping, and rearrange code to ! -! be comformable with radiation part programs. ! -! ! -! ==================== end of description ===================== ! -! - - implicit none - -! --- constant parameter: - real, parameter :: CEXP= 1.0/3.0 - -! --- inputs: - real, dimension(:,:), intent(in) :: & - & plyr, plvl, tlyr, qlyr, qcwat, qcice, qrain, rrime - - integer, intent(in) :: IM, LEVS, iflip - real, dimension(:), intent(in) :: flgmin -! logical, intent(in) :: lprnt - -! --- output: - real, dimension(:,:), intent(out) :: & - & cwatp, cicep, rainp, snowp, recwat, rerain, resnow, snden - -! --- locals: -! real, dimension(IM,LEVS) :: delp, pp1, pp2 - - real :: recw1, dsnow, qsnow, qqcice, flarge, xsimass, pfac, & - & nlice, xli, nlimax, dum, tem, & - & rho, cpath, rc, totcnd, tc - - integer :: i, k, indexs, ksfc, k1 -! -!===> ... begin here -! - recw1 = 620.3505 / TNW**CEXP ! cloud droplet effective radius - - do k = 1, LEVS - do i = 1, IM - !--- hydrometeor's optical path - cwatp(i,k) = 0.0 - cicep(i,k) = 0.0 - rainp(i,k) = 0.0 - snowp(i,k) = 0.0 - snden(i,k) = 0.0 - !--- hydrometeor's effective radius - recwat(i,k) = RECWmin - rerain(i,k) = RERAINmin - resnow(i,k) = RESNOWmin - enddo - enddo - -! --- set up pressure related arrays, convert unit from mb to cb (10Pa) -! cause the rest part uses cb in computation - - if (iflip == 0) then ! data from toa to sfc - ksfc = levs + 1 - k1 = 0 - else ! data from sfc to top - ksfc = 1 - k1 = 1 - endif ! end_if_iflip -! - do k = 1, LEVS - do i = 1, IM - totcnd = qcwat(i,k) + qcice(i,k) + qrain(i,k) - qsnow = 0.0 - if(totcnd > EPSQ) then - -! --- air density (rho), model mass thickness (cpath), temperature in c (tc) - - rho = 0.1 * plyr(i,k) & - & / (RD* tlyr(i,k) * (1.0 + EPS1*qlyr(i,k))) - cpath = abs(plvl(i,k+1) - plvl(i,k)) * (100000.0 / GRAV) - tc = tlyr(i,k) - T0C - -!! cloud water -! -! --- effective radius (recwat) & total water path (cwatp): -! assume monodisperse distribution of droplets (no factor of 1.5) - - if (qcwat(i,k) > 0.0) then - recwat(i,k) = max(RECWmin,recw1*(rho*qcwat(i,k))**CEXP) - cwatp (i,k) = cpath * qcwat(i,k) ! cloud water path -! tem = 5.0*(1.0 + max(0.0, min(1.0,-0.05*tc))) -! recwat(i,k) = max(recwat(i,k), tem) - endif - -!! rain -! -! --- effective radius (rerain) & total water path (rainp): -! factor of 1.5 accounts for r**3/r**2 moments for exponentially -! distributed drops in effective radius calculations -! (from m.d. chou's code provided to y.-t. hou) - - if (qrain(i,k) > 0.0) then - tem = CN0r0 * sqrt(sqrt(rho*qrain(i,k))) - rerain(i,k) = 1.5 * max(XMRmin, min(XMRmax, tem)) - rainp (i,k) = cpath * qrain(i,k) ! rain water path - endif - -!! snow (large ice) & cloud ice -! -! --- effective radius (resnow) & total ice path (snowp) for snow, and -! total ice path (cicep) for cloud ice: -! factor of 1.5 accounts for r**3/r**2 moments for exponentially -! distributed ice particles in effective radius calculations -! separation of cloud ice & "snow" uses algorithm from subroutine gsmcolumn - -! pfac = max(0.5, sqrt(sqrt(min(1.0, pp1(i,k)*0.00004)))) -!go pfac = max(0.5, (sqrt(min(1.0, pp1(i,k)*0.000025)))) - pfac = 1.0 - - if (qcice(i,k) > 0.0) then - -! --- mean particle size following houze et al. (jas, 1979, p. 160), -! converted from fig. 5 plot of lamdas. an analogous set of -! relationships also shown by fig. 8 of ryan (bams, 1996, p. 66), -! but with a variety of different relationships that parallel -! the houze curves. - -! dum = max(0.05, min(1.0, exp(0.0536*tc) )) - dum = max(0.05, min(1.0, exp(0.0564*tc) )) - indexs = min(MDImax, max(MDImin, int(XMImax*dum) )) - DUM=MAX(FLGmin(i)*pfac, DUM) - -! --- assumed number fraction of large ice to total (large & small) ice -! particles, which is based on a general impression of the literature. -! small ice are assumed to have a mean diameter of 50 microns. - - if (tc >= 0.0) then - flarge = FLG1P0 - else - flarge = dum -! flarge = max(FLGmin*pfac, dum) - endif -!------------------------commented by moorthi ----------------------------- -! elseif (tc >= -25.0) then -! -! --- note that absence of cloud water (qcwat) is used as a quick -! substitute for calculating water subsaturation as in gsmcolumn -! -! if (qcwat(i,k) <= 0.0 .or. tc < -8.0 & -! & .or. tc > -3.0) then -! flarge = FLG0P2 -! else -! -! --- parameterize effects of rime splintering by increasing -! number of small ice particles -! -! flarge = FLG0P1 -! endif -! elseif (tc <= -50.0) then -! flarge = 0.01 -! else -! flarge = 0.2 * exp(0.1198*(tc+25.0)) -! endif -!____________________________________________________________________________ - - xsimass = MASSI(MDImin) * (1.0 - flarge) / flarge -! nlimax = 20.0e3 !- ver3 -! NLImax=50.E3 !- Ver3 => comment this line out - NLImax=10.E3/sqrt(DUM) !- Ver3 -! NLImax=5.E3/sqrt(DUM) !- Ver3 -! NLImax=6.E3/sqrt(DUM) !- Ver3 -! NLImax=7.5E3/sqrt(DUM) !- Ver3 - -! indexs = min(MDImax, max(MDImin, int(XMImax*dum) )) -!moorthi dsnow = XMImax * exp(0.0536*tc) -!moorthi indexs = max(INDEXSmin, min(MDImax, int(dsnow))) - -! if (lprnt) print *,' rrime=',rrime,' xsimass=',xsimass, & -! & ' indexs=',indexs,' massi=',massi(indexs),' flarge=',flarge - - tem = rho * qcice(i,k) - nlice = tem / (xsimass +rrime(i,k)*MASSI(indexs)) - -! --- from subroutine gsmcolumn: -! minimum number concentration for large ice of NLImin=10/m**3 -! at t>=0c. done in order to prevent unrealistically small -! melting rates and tiny amounts of snow from falling to -! unrealistically warm temperatures. - - if (tc >= 0.0) then - - nlice = max(NLImin, nlice) - - elseif (nlice > nlimax) then - -! --- ferrier 6/13/01: prevent excess accumulation of ice - - xli = (tem/nlimax - xsimass) / rrime(i,k) - - if (xli <= MASSI(450) ) then - dsnow = 9.5885e5 * xli**0.42066 - else - dsnow = 3.9751e6 * xli** 0.49870 - endif - - indexs = min(MDImax, max(indexs, int(dsnow))) - nlice = tem / (xsimass + rrime(i,k)*MASSI(indexs)) - - endif ! end if_tc block - -! if (abs(plvl(i,ksfc)-plvl(i,k+k1)) < 300.0 & -! if (abs(plvl(i,ksfc)-plvl(i,k+k1)) < 400.0 & -! if (plvl(i,k+k1) > 600.0 & -! & .and. indexs >= INDEXSmin) then -! if (tc > -20.0 .and. indexs >= indexsmin) then - if (plvl(i,ksfc) > 850.0 .and. & -! & plvl(i,k+k1) > 600.0 .and. indexs >= indexsmin) then - & plvl(i,k+k1) > 700.0 .and. indexs >= indexsmin) then ! 20060516 -!! if (plvl(i,ksfc) > 800.0 .and. & -!! & plvl(i,k+k1) > 700.0 .and. indexs >= indexsmin) then -! if (plvl(i,ksfc) > 700.0 .and. & -! & plvl(i,k+k1) > 600.0 .and. indexs >= indexsmin) then - qsnow = min( qcice(i,k), & - & nlice*rrime(i,k)*MASSI(indexs)/rho ) - endif - - qqcice = max(0.0, qcice(i,k)-qsnow) - cicep (i,k) = cpath * qqcice ! cloud ice path - resnow(i,k) = 1.5 * float(indexs) - snden (i,k) = SDENS(indexs) / rrime(i,k) ! 1/snow density - snowp (i,k) = cpath*qsnow ! snow path -! snowp (i,k) = cpath*qsnow*snden(i,k) ! snow path / snow density - -! if (lprnt .and. i .eq. ipr) then -! if (i .eq. 2) then -! print *,' L=',k,' snowp=',snowp(i,k),' cpath=',cpath, & -! & ' qsnow=',qsnow,' sden=',snden(i,k),' rrime=',rrime(i,k),& -! & ' indexs=',indexs,' sdens=',sdens(indexs),' resnow=', & -! & resnow(i,k),' qcice=',qqcice,' cicep=',cicep(i,k) -! endif - - endif ! end if_qcice block - endif ! end if_totcnd block - - enddo - enddo -! -!................................... - end subroutine rsipath2 -!----------------------------------- - - end MODULE module_microphysics - diff --git a/src/fim/FIMsrc/fim/column/module_nsst_model.f b/src/fim/FIMsrc/fim/column/module_nsst_model.f deleted file mode 100644 index 9f8e139..0000000 --- a/src/fim/FIMsrc/fim/column/module_nsst_model.f +++ /dev/null @@ -1,517 +0,0 @@ - module ocean_model -!$$$ module documentation block -! . . . . -! module: ocean_model oceanic model to forward the oceanic state and the coefficients to calculate the sensitivities. -! at present, diurnal warming model, sub-layer cooling model -! prgmmr: Xu Li org: np22 date: 2007-05-21 -! -! abstract: diurnal warming model, sub-layer cooling model, coefficients to calculate sensitivities of Tz to T_ref, support subroutines - - USE MACHINE , ONLY : kind_phys - USE FUNCPHYS, ONLY : fpvs - USE physcons, only: cp_a => con_cp,rd => con_rd - USE resol_def, only: nr_nsst,nf_nsst - use layout1 - USE module_nsst_parameters, ONLY :cp_w,nu=>vis_w, kw =>tc_w,visw - & ,smallnumber, Von,hvap,sigma_r,gray,t0K,rho0_w,radian - & ,omg_m,omg_r,omg_rot - & ,omega ! ang vel of earth (1/s) - - USE module_nsst_water_prop, ONLY: sw_rad,sw_rad_Aw,sw_rad_upper - & ,sw_rad_upper_Aw,sw_rad_skin,grv - PRIVATE - PUBLIC :: cool_skin, warm_layer, Jacobi_Temp - - - CONTAINS -! - subroutine cool_skin(ustar_a,alpha,beta,rho_w,rho_a,Ts,F_nsol, - & F_sol_0,sss,evap,sinlat,deltaT_c,z_c) -! -! Upper ocean cool-skin parameterizaion, Fairall et al, 1996. -! -! INPUT: -! ustar_a : atmosphreic friction velocity at the air-sea interface (m/s) -! F_nsol : the "nonsolar" part of the surface heat flux (W/m^s) -! sss : ocean upper mixed layer salinity (ppu) -! evap : latent heat flux (W/M^2) -! F_sol_0 : solar radiation at the ocean surface (W/m^2) -! rho_a : atmospheric density -! rho_w : oceanic density -! Ts : oceanic surface temperature -! alpha : thermal expansion coefficient -! beta : saline contraction coefficient -! sinlat : sine of latitude -! -! OUTPUT: -! z_c: molecular sublayer (cool-skin) thickness (m) -! deltaT_c: cool-skin temperature correction (degrees K) -! - implicit none - real(kind=kind_phys), parameter :: z_c_max=0.01,z_c_ini=0.001 - & ,ustar_a_min = 0.056 - real(kind=kind_phys), intent(in) :: ustar_a,F_nsol,evap,sss, - & F_sol_0,rho_a,rho_w,alpha,beta,sinlat - real(kind=kind_phys), intent(out):: z_c,deltaT_c -! declare local variables - real(kind=kind_phys) :: xi,Hb,ustar1_a,bigc,grav,deltaF,Le,Ts,fxp - - grav = grv(sinlat) - Le = (2.501-.00237*Ts)*1e6 - - z_c=z_c_ini ! initial quess - - ustar1_a=max(ustar_a,ustar_a_min) - - CALL sw_rad_skin(z_c,fxp) - deltaF=F_sol_0*fxp - - Hb=alpha*(F_nsol-DeltaF) +beta*sss*cp_w*evap/Le - bigc=16*grav*cp_w*(rho_w*nu)**3/(rho_a*rho_a*kw*kw) - if ( Hb > 0 ) then - xi=6./(1+(bigc*Hb/ustar1_a**4)**0.75)**0.3333333 - else - xi=6.0 - endif - z_c=min(z_c_max,xi*nu/(SQRT(rho_a/rho_w)*ustar1_a )) - - CALL sw_rad_skin(z_c,fxp) - deltaF=F_sol_0*fxp - deltaF=F_nsol - deltaF - if ( deltaF > 0 ) then - deltaT_c= deltaF * z_c / kw - else - deltaT_c=0. - z_c=0. - endif - - end subroutine cool_skin - ! - !====================== - ! - - subroutine warm_layer(alpha,beta,sss,rho_w,F_sol_0,F_nsol,tau, - & lflx,rain,Qrain,Ts,dtime,sinlat,solar_time, - & ifd,time_old,time_ins,I_Sw,I_Q,I_Qrain, - & I_M,I_Tau,dt_warm,z_w, -! ocnr1,ocnf1, - & kdt,lprint) -! -! Upper ocean daily warm layer parameterizaion, Fairall et al, 1996. -! -! INPUT: -! alpha : thermal expansion coefficient (K^-1) -! beta : saline contraction coefficient (ppt^-1) -! sss : sea water salinity (ppt) -! rho_w : sea water density (kg m^-3) -! F_sol_0 : solar radiation at the ocean surface (W/m^2) -! F_nsol : the "nonsolar" part of the surface heat flux (W/m^2) -! tau : wind stress (N/M^2) -! lflx : latent heat flux (w/m^2) -! rain : rainfall (kg/m^2/s) -! Qrain : sensible heat flux by rainfall (W/M^2) -! Ts : sea surface temperature (K) -! dtime : timestep -! sinlat : sine of latitude -! solar_time : local time -! kdt : counts for time steps -! -! InOut: -! z_w : diurnal warming layer depth : z_w -! dt_warm : diurnal warming amount : dt_warm -! -! ocnr1(1:11) : the variables for restart -! ocnr1( 1) : index of time integral started mode : ifd -! ocnr1( 2) : solar time at previous time : time_old -! ocnr1( 3) : the period of time integral : time_ins -! ocnr1( 4) : time integral of solar radiation flux : I_Sw -! ocnr1( 5) : time integral of non-solar heat flux : I_Q -! ocnr1( 6) : time integral of rain caused sensibal heat flux : I_Qrain -! ocnr1( 7) : time integral of mass flux S(E-P) : I_M -! ocnr1( 8) : time integral of momentum flux : I_Tau -! ocnr1( 9) : time integral of d(I_Sw)/d(z_w) : I_Sw_Zw -! ocnr1(10) : time integral of d(I_Q)/d(Ts) : I_Q_Ts -! ocnr1(11) : time integral of d(I_M)/d(Ts) : I_M_Ts - -! ocnf1(1) : Reference temperature : T_ref -! ocnf1(2) : Sub-layer cooling amount : dt_cool -! ocnf1(3) : Sub-layer cooling thickness : z_c -! ocnf1(4) : diurnal warming amount : dt_warm -! ocnf1(5) : diurnal warming layer depth : z_w -! ocnf1(6) : W_0 (time integral) -! ocnf1(7) : W_d (time integral) -! ocnf1(8) : C_0 (current time step) -! ocnf1(9) : C_d (current time step) - - implicit none - integer, parameter :: niter_max=5 - real(kind=kind_phys), parameter :: - & Ri_c=0.65 ! critical bulk Richardson number (Fairall et al, 1996, p.1300) - & ,eps_z=0.01 ! criteria to finish iterations for z_w - & ,z_w_max=20.0 ! max warm layer thickness - & ,z_w_min=0.2 ! max warm layer thickness - & ,solar_time_6am=21600.0 ! solar time at 6am local - & ,Q_warm_min=25.0 ! minimal warming to start generate the warm layer ( = 50 in Fairall et al 1996) - & ,tau_min=0.0031 ! minimal wind stress (~ 1.6 m/s of 10m-wind), no need in Fairall, due to ug accounted for - -! Input/Output variables - - real(kind=kind_phys), intent(in) :: alpha,beta,sss,rho_w,F_sol_0 - & ,F_nsol,tau, - & lflx,rain,Qrain,Ts,solar_time - & ,sinlat,dtime - integer, intent(in) :: kdt - logical, intent(in) :: lprint - -! real(kind=kind_phys), intent(inout) :: ocnr1(nr_ocn) -! real(kind=kind_phys), intent(inout) :: ocnf1(nf_ocn) - -! Local variables - integer :: niter,i - real(kind=kind_phys) ::ifd,time_old,time_ins,I_Sw,I_Q,I_Qrain,I_M - & ,I_Tau - real(kind=kind_phys) ::dt_warm,z_w,z_w_prev,dt_warm0,z_w0 - real(kind=kind_phys) ::I_heat,fxp,coeff,coeff1,coeff2,z_w_tmp, - & F_sol,Q_warm, - & RF_warm,Q_joule,TAU_warm,M_warm,timestep, - & coriolis,Le - - z_w_prev = z_w - dt_warm0 = dt_warm - z_w0 = z_w - - coeff = SQRT(2.*Ri_c) - -! alpha : thermal expansion coefficient (K^-1) -! beta : saline contraction coefficient (ppt^-1) -! sss : sea water salinity (ppt) -! rho_w : sea water density (kg m^-3) -! F_sol_0 : solar radiation at the ocean surface (W/m^2) -! F_nsol : the "nonsolar" part of the surface heat flux (W/m^2) -! tau : wind stress (N/M^2) -! lflx : latent heat flux (w/m^2) -! rain : rainfall (kg/m^2/s) -! Qrain : sensible heat flux by rainfall (W/M^2) -! Ts : sea surface temperature (K) -! dtime : timestep -! sinlat : sine of latitude -! solar_time : local time - -! if (lprint) print *,' dt_warm0=',dt_warm0,' solar_time=',solar_time,& -! ' rain=',rain,' qrain=',qrain,' lflx=',lflx,' F_sol_0=',F_sol_0,& -! 'F_nsol=',F_nsol,' Ts=',Ts,' alpha=',alpha,' beta=',beta,' sss=',sss,& -! ' rho_w=',rho_w,' tau=',tau,' ifd=',ifd,' time_old=',time_old - - - if (solar_time > solar_time_6am .and. ifd == 0.0 ) then - dt_warm = 0.0 ! initialize diurnal warming amount to be zero: - ! 6 am too late to start the first day - z_w = z_w_max ! assign warming depth as z_w_max meters - else - ifd = 1.0 - -! if (solar_time < time_old) then ! solar_time and time_old : 0 ~ 24 - if (abs(solar_time -21600.) < dtime) then ! solar_time and time_old : 0 ~ 24 - ! just pass the midnight (start of a new day) - ifd = 1.0 ! count of the start of a new day - time_ins = 0.0 ! initialize the integral time to be zero - I_Sw = 0.0 - I_Q = 0.0 - I_Qrain = 0.0 - I_heat = 0.0 ! initialize net heat to be zero - I_Tau = 0.0 ! initialize wind stress to be zero - I_M = 0.0 ! initialize mass exchange (E-P) to be zero - dt_warm = 0.0 ! initialize diurnal warming amount to be zero - z_w = z_w_max ! assign warming depth as z_w_max - - else -! Get the first guess (or initial value) of the absorbed solar radiation -! in warm layer. Depends on if the time integral has started or not -! - if( time_ins == 0.0 ) THEN - F_sol = 0.5*F_sol_0 ! implies a shallow heating layer to start the integration - else - call sw_rad(z_w_prev,fxp) - F_sol = F_sol_0*fxp - endif - - timestep = solar_time - time_old ! in seconds - - if ( ifd == 1.0 ) timestep = dtime - - Le = (2.501-.00237*Ts)*1e6 - Q_warm = (F_sol-F_nsol)*timestep - RF_warm = Qrain*timestep - TAU_warm = max(tau_min,tau)*timestep - M_warm = sss*(lflx/Le-rain)*timestep/rho0_w -! -! skip: the heat is not strong enough to set up the onset of a diurnal warming -! - IF (Q_warm/timestep < Q_warm_min .and. time_ins == 0.0) THEN ! this should cover the period from midnight to the onset time of diurnal warming - dt_warm = 0.0 ! initialize diurnal warming amount to be zero - z_w = z_w_max ! assign warming depth as 19 meters (z_w_max) - else ! there exists a warm layer -! -! calculate warm layer depth -! - time_ins = time_ins + timestep - I_Tau = I_Tau + TAU_warm - I_M = I_M + M_warm - I_heat = I_Sw - I_Q - omg_r*I_Qrain - - if ( I_heat+Q_warm > 0.0 ) then - coeff1 = rho_w*alpha*grv(sinlat)/cp_w - coeff2 = beta*grv(sinlat)*rho_w**2 - - z_w_tmp = z_w_prev - - iters: do niter=1,niter_max - CALL sw_rad(z_w_tmp,fxp) - F_sol = F_sol_0*fxp - - Q_joule = (F_sol-F_nsol)*timestep - RF_warm - - if ( I_heat+Q_joule > 0.0 ) THEN -! z_w = MIN(z_w_max,coeff*I_Tau/SQRT(coeff1*(I_heat+Q_joule)+coeff2*omg_m*I_M) ) - z_w = MIN(z_w_max,coeff*I_Tau/SQRT(coeff1*(I_heat+Q_joule)) ) - z_w = max(z_w,z_w_min) - endif - - if (ABS(z_w - z_w_tmp) < eps_z .and. z_w/=z_w_max .and. niter<5) - & exit iters - z_w_tmp = z_w - end do iters - - if (niter == niter_max) then - WRITE(*,*) 'ERROR in warm_layer: iterations do not converge' - STOP - endif - else - F_sol = 0.75*F_sol_0 - z_w = z_w_max -! Q_joule = (F_sol-F_nsol)*timestep-RF_warm - Q_joule = (F_sol-F_nsol)*timestep - endif ! IF ( I_heat+Q_warm > 0.0 ) THEN - - I_heat = I_heat + Q_joule - I_Sw = I_Sw + F_sol*timestep - I_Q = I_Q + F_nsol*timestep - I_Qrain = I_Qrain + RF_warm - - if (I_heat <= 0.0 ) then - dt_warm = 0. - z_w = z_w_max - else - -! if ( (solar_time >= 21.*3600. .and. solar_time < 24.*3600.) ) then -! I_heat = I_heat*(24.*3600. - solar_time)/10800. -! endif - -! z_w = MIN(z_w_max,coeff*I_Tau/SQRT(coeff1*I_heat+coeff2*omg_m*I_M) ) - z_w = MIN(z_w_max,coeff*I_Tau/SQRT(coeff1*I_heat) ) - z_w = max(z_w,z_w_min) - dt_warm = 2.*I_heat/(rho_w*cp_w*z_w) - -! if (lprint) print *,' dt_warm=',dt_warm,' i_heat=',i_heat,' rho_w=',& -! rho_w,' cp_w=',cp_w,' z_w=',z_w - endif - - endif ! IF (Q_warm/timestep < Q_warm_min .and. time_ins == 0.0) THEN : start to accumulate the heat - endif ! IF (solar_time < time_old) THEN: midnight reset - endif ! IF (solar_time > solar_time_6am .and. ifd == 0.0 ) THEN: too late to start the first day - -! if ( mod(kdt,60) == 1 .and. dt_warm >= 2.50 ) then -! write(*,'(a,I5,F3.0,3F8.0,2F11.0,F8.2,2F8.1,F7.4,4F7.2)') & -! 'warming : ',kdt,ifd,time_old,solar_time,time_ins,I_Sw,I_Q,I_Tau,F_sol_0,F_nsol,tau,dt_warm0,z_w0,dt_warm,z_w -! endif - - end subroutine warm_layer - - - subroutine Jacobi_Temp(alpha,beta,sss,Ta,Ps,Qa,ustar_a,rho_w, - & rho_a,rain,lflx,sflx,dlwrf,ulwrf,Rns,Ts, - & timestep,sinlat,loc_time,Hs_Ts,Hl_Ts,RF_Ts, - & I_Sw,I_Q,I_M,I_Sw_Zw,I_Q_Ts,I_M_Ts, - & dt_cool,z_c,dt_warm,z_w, - & c_0,c_d,w_0,w_d, -! & ocnr1,ocnf1, & - & kdt) -! -! Upper ocean deily warm layer parameterizaion (Fairall et al, 1996) and Jacobi (Xu Li, 2007) -! -! INPUT: -! alpha : thermal expansion coefficient -! beta : saline contraction coefficient -! Ta : surface atmospheric temperature (K) -! Ps : surface atmospheric pressure (Pa) -! Qa : surface atmospheric specific humidity (kg/kg) -! ustar_a : friction velocity in the atmosphere (m/s) -! rho_w : sea water density (kg/m^3) -! rho_a : atmoshpere density (kg/m^3) -! rain : rainfall (kg/m^2/s) -! lflx : time mean value: latent heat flux (w/m^2) -! sflx : time mean value: sensible heat flux (w/m^2) -! dlwrf : time mean value: downward longwave radiation flux (w/m^2) -! ulwrf : time mean value: upward longwave radiation flux (w/m^2) -! Rns : time mean value: net solar radiation at the ocean surface (W/m^2) -! Ts : sea surface temperature (K) -! timestep : time step -! sinlat : sine(latitude) -! loc_time : solar time in hour -! Hs_Ts : d(Hs)/d(Ts) = exchange coefficient for air-sea flux calculation -! Hl_Ts : d(Hl)/d(Ts) -! RF_Ts : d(Qrain)/d(Ts) -! kdt : counts for time steps -! me : cpu number -! ocnf1(2) : Sub-layer cooling amount : dt_cool -! ocnf1(3) : Sub-layer cooling thickness : z_c -! ocnf1(4) : diurnal warming amount : dt_warm -! ocnf1(5) : diurnal warming layer depth : z_w - -! -! InOut: -! ocnr1( 4) : time integral of solar radiation flux : I_Sw -! ocnr1( 5) : time integral of non-solar heat flux : I_Q -! ocnr1( 6) : time integral of mass flux S(E-P) : I_M -! ocnr1( 9) : time integral of d(I_Sw)/d(z_w) : I_Sw_Zw -! ocnr1(10) : time integral of d(I_Q)/d(Ts) : I_Q_Ts -! ocnr1(11) : time integral of d(I_M)/d(Ts) : I_M_Ts -! Output: -! ocnf1(6) : W_0 (time integral) -! ocnf1(7) : W_d (time integral) -! ocnf1(8) : C_0 (current time step) -! ocnf1(9) : C_d (current time step) - - - IMPLICIT NONE - real(kind=kind_phys), parameter :: Rich=0.65,ustar_a_min = 0.07 - real(kind=kind_phys), intent(in) :: alpha,beta,sss,Ta,Ps,Qa,rho_w, - & rho_a,ustar_a,rain,lflx,sflx, - & dlwrf,ulwrf,Rns, - & Ts,timestep,sinlat,loc_time, - & Hs_Ts,Hl_Ts,RF_Ts -! real(kind=kind_phys), intent(inout) :: ocnf1(nf_ocn) -! real(kind=kind_phys), intent(inout) :: ocnr1(nr_ocn) -! -! -! Local variables declaring -! - integer :: niter,i,j,kdt,me - real(kind=kind_phys) :: dt_cool ! cooling amount - real(kind=kind_phys) :: z_c ! thickness of sub-layer - real(kind=kind_phys) :: z_w ! thickness of diurnal warming layer - real(kind=kind_phys) :: dt_warm ! diurnal warming at the sea surface -! real(kind=kind_phys) :: time_ins ! time of integration done (Moorthi) - real(kind=kind_phys) :: coeff,coeff1,F_sol,Q_warm - real(kind=kind_phys) :: wj,es,es_liq,es_sol,a_liq,a_sol,b_liq, - & b_sol,Rnl_Ts,es_Ts,es_liq_Ts,es_sol_Ts, - & Q_Ts,H_Ts - real(kind=kind_phys) :: a1,a2,a3,a4,A_c,B_c,H,Rnl,qout,dels,fxp,Qs - real(kind=kind_phys) :: tcw,cc1,cc2,cc3,Hb,qcol,bigc,Le,dtemp, - & corioli,A_w,dwat,dtmp,alfac,wetc - real(kind=kind_phys) :: Sw_Zw,M_Ts,Zw_Ts,I_H - real(kind=kind_phys) :: I_Sw,I_Q,I_Qrain,I_M,I_Sw_Zw,I_Q_ts, - & I_M_Ts,C_0,C_d,W_0,W_d - real(kind=kind_phys) :: Hs_Ts_tmp,Hl_Ts_tmp -!====================================================================================== - - tcw = 0.6 - a1 = 0.065; a2 = 11.0; a3 = 6.6e-5; a4 = 8.0e-4 -!*************** constants for heat flux sensitivity to Ts ****** - a_liq = 5.286; b_liq = 25.12; a_sol = 0.5634; b_sol = 23.04 - Le = (2.501-.00237*Ts)*1e6 -! -! -! Calculate the sensitivities of heat flux componets to Ts -! - -! ======================================================================================================== -! - Rnl = ulwrf - dlwrf ! positive = upward - qout=Rnl+sflx+lflx - - Le = (2.501-.00237*Ts)*1e6 - Rnl_Ts = 4.0*gray*sigma_r*Ts**3 ! d(Rnl)/d(Ts) - -! if ( me > 70 .and. me < 100) then -! write(*,'(a,4F12.6)') 'H_Ts: ',Hs_Ts, Hs_Ts_tmp,Hl_Ts,Hl_Ts_tmp -! endif - - - Q_Ts = Rnl_Ts+Hs_Ts+Hl_Ts+omg_r*RF_Ts - - Rnl = ulwrf - dlwrf ! positive = upward - qout=Rnl+sflx+lflx - if ( z_c == 0.0 ) then - C_0 = 0.0 - C_d = 0.0 - else - - dels=Rns*(.065+11*z_c-6.6e-5/z_c*(1-exp(-z_c/8.0e-4))) ! Eq.16 Shortwave - - qcol=qout-dels - - bigc=16.0*grv(sinlat)*cp_w*(rho_w*visw)**3/ - & (tcw*tcw*rho_a*rho_a) - cc1 = 6.0*visw/(tcw*max(ustar_a,ustar_a_min)*(rho_a/rho_w)**0.5) - cc2 = bigc*alpha/max(ustar_a,ustar_a_min)**4 - cc3 = beta*sss*cp_w/(alpha*Le) - A_c = (a2+a3/z_c**2-(a3/(a4*z_c)+a3/z_c**2)*exp(-z_c/a4)) - - Hb = qcol+beta*sss*lflx*cp_w/(alpha*Le) - - if ( Hb > 0.0 ) then - B_c = (Q_Ts+cc3*Hl_Ts)/(Rns*A_c-4.0*(cc1*tcw)**3*Hb**0.25/ - & (cc2**0.75*z_c**4)) - C_0 = (z_c*Q_Ts+(qout-dels-Rns*A_c*z_c)*B_c)/tcw ! C_0 - C_d = (Rns*A_c*z_c*B_c-Q_Ts)/tcw ! C_d - else - C_0 = z_c*Q_Ts/tcw ! C_0 - C_d = -Q_Ts/tcw ! C_d - endif - - endif ! if ( z_c == 0.0 ) then - - IF ( dT_warm > 0.0 ) THEN ! diurnal warming layer exists - - CALL sw_rad_Aw(z_w,A_w) - - Sw_Zw = Rns*A_w/z_w - M_Ts = sss*Hl_Ts/(Le*rho0_w) - - I_H = I_Sw - I_Q - omg_r*I_Qrain - I_Sw_Zw = I_Sw_Zw + Sw_Zw*timestep - I_Q_Ts = I_Q_Ts + Q_Ts*timestep - I_M_Ts = I_M_Ts + M_Ts*timestep - - coeff = rho_w*cp_w*beta/alpha - Zw_Ts = z_w*(I_Q_Ts-coeff*omg_m*I_M_Ts)/ - & (2.0*I_H+z_w*I_Sw_Zw+2.0*coeff*omg_m*I_M_Ts) - - W_0 = (2.0/(rho0_w*cp_w*z_w))*((I_Sw_Zw-I_H/z_w)*Zw_Ts-I_Q_Ts) ! W_0 - W_d = (2.0/(rho0_w*cp_w*z_w**2))*((2.0*I_H/z_w-I_Sw_Zw) - & *Zw_Ts+I_Q_Ts) ! W_d - - ELSE ! diurnal warming layer doesn't exist - - W_0 = 0.0 - W_d = 0.0 - - I_Sw_Zw = 0.0 - I_Q_Ts = 0.0 - I_M_Ts = 0.0 - - ENDIF ! if ( dT_warm > 0.0 ) - - end subroutine Jacobi_Temp -!============================================================================================== - - function qsee(ts,Pa) - real :: ts,Pa,x,p,es - x=ts - p=Pa - es=6.112*exp(17.502*x/(x+240.97))*.98*(1.0007+3.46e-6*p) - qsee=es*621.97/(p-.378*es) - end function - - end module ocean_model diff --git a/src/fim/FIMsrc/fim/column/module_nsst_parameters.f b/src/fim/FIMsrc/fim/column/module_nsst_parameters.f deleted file mode 100644 index 9e18adc..0000000 --- a/src/fim/FIMsrc/fim/column/module_nsst_parameters.f +++ /dev/null @@ -1,118 +0,0 @@ - MODULE module_nsst_parameters - USE machine, ONLY : kind_phys - &,kind_rad ! for astronomy (date) calculations - ! - ! air constants and coefficients from the atmospehric model - USE physcons, ONLY: - & eps => con_eps - & , cp_a => con_cp ! spec heat air @p (J/kg/K) - & , epsm1 => con_epsm1 - & , hvap => con_hvap ! lat heat H2O cond (J/kg) - & , sigma_r => con_sbc ! stefan-boltzmann (W/m2/K4) - & , grav => con_g ! acceleration due to gravity (kg/m/s^2) - & , omega => con_omega ! ang vel of earth (1/s) - & , rvrdm1 => con_FVirt - & , rd => con_RD - & , rocp => con_rocp ! R/cp - & , pi => con_pi -! -! NOTE: take timestep from here later - PUBLIC - REAL (kind=kind_phys), PARAMETER :: -! -! general constants - & sec_in_day=86400. - & ,sec_in_hour=3600. - & ,Von=0.4 ! von Karman's "constant" ! - & ,t0K=273.16 ! Celsius to Kelvin - & ,gray=0.97 - & ,omg_r =0.0 - & ,omg_rot = 0.0 - & ,omg_m = 0.0 -!dbgz - & ,visw=1.e-6 !m2/s kinematic viscosity water - & ,novalue=0 -! & ,novalue=-1.0e+10 - & ,smallnumber=1.e-6 -! &,timestep_oc=sec_in_day/24. ! time step in the ocean model (1 hours) - & ,timestep_oc=sec_in_day/8. ! time step in the ocean model (3 hours) - & ,radian=2.*pi/180. -! sea constants and coefficients -! - & ,cp_w=4000. ! specific heat water (J/kg/K ) - & ,rho0_w=1022.0 ! density water (kg/m3 ) (or 1024.438) - & ,vis_w=1.e-6 ! kinematic viscosity water (m2/s ) - & ,tc_w=0.6 ! Thermal conductivity water (W/m/K ) - & ,capa_w =3950.0 ! heat capacity of sea water ! -! -! air constants and coefficients -! - & ,thref =1.0e-3 ! reference value of specific volume (m**3/kg) - -!!$!============================================ -!!$ -!!$ ,lvapor=2.453e6 ! latent heat of vaporization NOTE: make it function of T ????? NOTE the same as hvap -!!$ ,alpha=1 ! thermal expansion coefficient -!!$ ,beta ! saline contraction coefficient -!!$ ,cp=1 !=1 specific heat of sea water -!!$ ,g=1 ! acceleration due to gravity -!!$ ,kw=1 ! thermal conductivity of water -!!$ ,nu=1 !kinematic wiscosity -!!$ ,rho_w=1 !water density -!!$ ,rho_a=1 !air density -!!$ ,l_vapr=2.453e6 -!!$ ,novalue=--1.0e+10 -!!$ -!!$c Factors -!!$ Beta=1.2 !Given as 1.25 in Fairall et al.(1996) -!!$ Von=0.4 ! von Karman's "constant" -!!$c fdg=1.00 ! Fairall's LKB rr to von karman adjustment -!!$ fdg=1.00 !based on results from Flux workshop August 1995 -!!$ toK=273.16 ! Celsius to Kelvin -!!$ twopi=3.14159*2. -!!$ -!!$c Air constants and coefficients -!!$ Rgas=287.1 !J/kg/K gas const. dry air -!!$ xlv=(2.501-0.00237*TS)*1e+6 !J/kg latent heat of vaporization at TS -!!$ Cpa=1004.67 !J/kg/K specific heat of dry air (Businger 1982) -!!$ Cpv=Cpa*(1+0.84*Q) !Moist air - currently not used (Businger 1982) -!!$ rhoa=P*100./(Rgas*(T+toK)*(1.+.61*Q)) !kg/m3 Moist air density ( " ) -!!$ visa=1.326e-5*(1+6.542e-3*T+8.301e-6*T*T-4.84e-9*T*T*T) !m2/s -!!$ !Kinematic viscosity of dry air - Andreas (1989) CRREL Rep. 89-11 -!!$c -!!$c Cool skin constants -!!$ al=2.1e-5*(ts+3.2)**0.79 !water thermal expansion coefft. -!!$ be=0.026 !salinity expansion coefft. -!!$ cpw=4000. !J/kg/K specific heat water -!!$ rhow=1022. !kg/m3 density water -!!$ visw=1.e-6 !m2/s kinematic viscosity water -!!$ tcw=0.6 !W/m/K Thermal conductivity water -!!$ bigc=16.*grav*cpw*(rhow*visw)**3/(tcw*tcw*rhoa*rhoa) -!!$ wetc=0.622*xlv*QS/(rgas*(TS+toK)**2) !correction for dq;slope of sat. vap. -!!$ -!!$! -!!$! Functions -!!$ -!!$ -!!$ real, parameter :: timestep=86400. !integration time step, second -!!$ -!!$ real, parameter :: grav =9.81 !gravity, kg/m/s^2 -!!$ real, parameter :: capa =3950.0 !heat capacity of sea water -!!$ real, parameter :: rhoref = 1024.438 !sea water reference density, kg/m^3 -!!$ real , parameter :: hslab=50.0 !slab ocean depth -!!$ real , parameter :: bad=-1.0e+10 -!!$ real , parameter :: tmin=2.68E+02 -!!$ real , parameter :: tmax=3.11E+02 -!!$ -!!$ real, parameter :: grav =9.81 !gravity, kg/m/s^2 -!!$ real, parameter :: capa =3950.0 !heat capacity of sea water -!!$ real, parameter :: rhoref = 1024.438 !sea water reference density, kg/m^3 -!!$ real, parameter :: tmin=2.68E+02 !normal minimal temp -!!$ real, parameter :: tmax=3.11E+02 !normal max temp -!!$ real, parameter :: smin=1.0 !normal minimal salt -!!$ real, parameter :: smax=50. !normal maximum salt -!!$ real, parameter :: visct=1.e-5 !viscocity for temperature diffusion -!!$ real, parameter :: viscs=1.e-5 !viscocity for salt diffusion -!!$ -!!$ - END MODULE module_nsst_parameters diff --git a/src/fim/FIMsrc/fim/column/module_nsst_water_prop.f b/src/fim/FIMsrc/fim/column/module_nsst_water_prop.f deleted file mode 100644 index 2e8bb4f..0000000 --- a/src/fim/FIMsrc/fim/column/module_nsst_water_prop.f +++ /dev/null @@ -1,435 +0,0 @@ - MODULE module_nsst_water_prop - USE machine, ONLY : kind_phys - USE module_nsst_parameters, ONLY : t0K - ! - PRIVATE - PUBLIC :: rhocoef,density,sw_rad,sw_rad_Aw,sw_rad_upper, - & sw_rad_upper_Aw,sw_rad_skin,grv, - & solar_time_from_Julian,compjd - - ! - INTERFACE sw_rad - MODULE PROCEDURE sw_fairall_6exp_v1 ! sw_wick_v1 - END INTERFACE - INTERFACE sw_rad_Aw - MODULE PROCEDURE sw_fairall_6exp_v1_Aw - END INTERFACE - INTERFACE sw_rad_upper - MODULE PROCEDURE sw_soloviev_3exp_v2 - END INTERFACE - INTERFACE sw_rad_upper_Aw - MODULE PROCEDURE sw_soloviev_3exp_v2_Aw - END INTERFACE - INTERFACE sw_rad_skin - MODULE PROCEDURE sw_ohlmann_v1 - END INTERFACE - CONTAINS - ! ------------------------------------------------------ - SUBROUTINE rhocoef(t, s, rhoref, alpha, beta) - ! ------------------------------------------------------ - - ! compute thermal expansion coefficient (alpha) - ! and saline contraction coefficient (beta) using - ! the international equation of state of sea water - ! (1980). Ref: pond and pickard, introduction to - ! dynamical oceanography, pp310. - ! note: compression effects are not included - - IMPLICIT NONE - REAL(kind=kind_phys), INTENT(in) :: t, s, rhoref - REAL(kind=kind_phys), INTENT(out) :: alpha, beta - REAL(kind=kind_phys) :: tc, sqrts, rhoinv -! - real (kind=kind_phys), parameter :: - & ac1=6.793952e-2, ac2=-2.0*9.095290e-3,ac3=3.0*1.001685e-4, - & ac4=-4.0*1.120083e-6,ac5=5.0*6.536332e-9, ac6=-4.0899e-3, - & ac7=2.0*7.6438e-5, ac8=-3.0*8.2467e-7, ac9=4.0*5.3875e-9, - & ac10=1.0227e-4, ac11=-2.0*1.6546e-6 - - real (kind=kind_phys), parameter :: - & bc1=8.24493e-1, bc2=-4.0899e-3, bc3=7.6438e-5, - & bc4=-8.2467e-7, bc5=5.3875e-9, bc6=-1.5*5.72466e-3, - & bc7=1.5*1.0227e-4, bc8=-1.5*1.6546e-6, bc9=2.0*4.8314e-4 -! - tc = t - t0K - sqrts = sqrt(s) - rhoinv = 1.0 / rhoref - - alpha = ac1 + tc*(ac2 + tc*(ac3 + tc*(ac4 + tc*ac5))) - & + s * (ac6 + tc*(ac7 + tc*(ac8 + tc*ac9)) - & + sqrts*(ac10 + tc*ac11)) - - ! NOTE: rhoref - specify - ! - alpha = -alpha * rhoinv - - beta = bc1 + tc*(bc2 + tc*(bc3 + tc*(bc4 + tc*bc5))) - & + sqrts * (bc6 + tc*(bc7 + tc*bc8)) + bc9*s - - beta = beta * rhoinv - - END SUBROUTINE rhocoef - ! ---------------------------------------- - SUBROUTINE density(t, s, rho) - ! ---------------------------------------- - IMPLICIT NONE - - ! input - REAL(kind=kind_phys), INTENT(in) :: t !unit, K - REAL(kind=kind_phys), INTENT(in) :: s !unit, 1/1000 - ! output - REAL(kind=kind_phys), INTENT(out) :: rho !unit, kg/m^3 - ! local - REAL(kind=kind_phys) :: tc, sqrts - real (kind=kind_phys), save :: rc(15) - data rc /999.842594,6.793952e-2, - 9.095290e-3, 1.001685e-4, - & - 1.120083e-6, 6.536332e-9, 8.24493e-1, -4.0899e-3, - & 7.6438e-5, - 8.2467e-7, 5.3875e-9, -5.72466e-3, - & 1.0227e-4, - 1.6546e-6, 4.8314e-4/ - - ! compute density using the international equation - ! of state of sea water 1980, (pond and pickard, - ! introduction to dynamical oceanography, pp310). - ! compression effects are not included - - rho = 0.0 - tc = t - t0K - sqrts = sqrt(s) - - ! effect of temperature on density (line 1) - ! effect of temperature and salinity on density (lines 2-3) - - rho = rc(1) + tc*(rc(2) + tc*(rc(3) + tc*(rc(4) + tc*(rc(5) - & + tc*rc(6))))) - & + s * (rc(7) + tc*(rc(8) + tc*(rc(9) + tc*(rc(10) - & + tc*rc(11)))) - & + sqrts * (rc(12) + tc*(rc(13) + tc*rc(14))) + s*rc(15)) - - END SUBROUTINE density - ! - !====================== - ! - elemental SUBROUTINE sw_fairall_6exp_v1(z,fxp) - ! - ! Fraction of the Solar radiation absorbed by the ocean at the depth z (Fairall et all, 1996, p. 1298) - ! following Paulson and Simpson, 1981 - ! - ! INPUT: - ! z: depth (m) - ! - ! OUTPUT: - ! fxp: Fraction of the solar radiation absorbed by the ocean at depth z (W/m^2) - ! - IMPLICIT NONE - REAL(kind=kind_phys),INTENT(in):: z - REAL(kind=kind_phys),INTENT(out):: fxp - REAL(kind=kind_phys), DIMENSION(9), PARAMETER :: - & F=(/0.237,0.36,0.179,0.087,0.08,0.0246,0.025,0.007,0.0004/) - & ,gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4, - & 3.13e-4,7.82e-5,1.44e-5/) - REAL(kind=kind_phys),DIMENSION(9) :: zgamma - REAL(kind=kind_phys),DIMENSION(9) :: f_c - ! - IF(z>0) THEN - zgamma=z/gamma - f_c=F*(1.-1./zgamma*(1-EXP(-zgamma))) - fxp=SUM(f_c) - ELSE - fxp=0. - ENDIF - ! - END SUBROUTINE sw_fairall_6exp_v1 - ! - !====================== - ! - ! - elemental SUBROUTINE sw_fairall_6exp_v1_Aw(z,Aw) - ! - ! Fraction of the Solar radiation absorbed by the ocean at the depth z (Fairall et all, 1996, p. 1298) - ! following Paulson and Simpson, 1981 - ! - ! INPUT: - ! z: depth (m) - ! - ! OUTPUT: - ! Aw: d(fxp)/d(z) - ! - ! fxp: Fraction of the solar radiation absorbed by the ocean at depth z (W/m^2) - ! - IMPLICIT NONE - REAL(kind=kind_phys),INTENT(in):: z - REAL(kind=kind_phys),INTENT(out):: Aw - REAL(kind=kind_phys) :: fxp - REAL(kind=kind_phys), DIMENSION(9), PARAMETER :: - & F=(/0.237,0.36,0.179,0.087,0.08,0.0246,0.025,0.007,0.0004/) - & ,gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4, - & 3.13e-4,7.82e-5,1.44e-5/) - REAL(kind=kind_phys),DIMENSION(9) :: zgamma - REAL(kind=kind_phys),DIMENSION(9) :: f_Aw - ! - IF(z>0) THEN - zgamma=z/gamma - f_Aw=(F/z)*((gamma/z)*(1-EXP(-zgamma))-EXP(-zgamma)) - Aw=SUM(f_Aw) - -! write(*,'(a,F6.2,F12.6,9F10.4)') 'z,Aw in sw_rad_Aw : ',z,Aw,f_Aw - - ELSE - Aw=0. - ENDIF - ! - END SUBROUTINE sw_fairall_6exp_v1_Aw - ! - !====================== - - elemental SUBROUTINE sw_fairall_simple_v1(F_sol_0,z,dF_sol_z) - ! - ! Solar radiation absorbed by the ocean at the depth z (Fairall et all, 1996, p. 1298) - ! - ! INPUT: - ! F_sol_0: solar radiation at the ocean surface (W/m^2) - ! z: depth (m) - ! - ! OUTPUT: - ! dF_sol_z: solar radiation absorbed by the ocean at depth z (W/m^2) - ! - IMPLICIT NONE - REAL(kind=kind_phys),INTENT(in):: z,F_sol_0 - REAL(kind=kind_phys),INTENT(out):: dF_sol_z - ! - IF(z>0) THEN - dF_sol_z=F_sol_0*(0.137+11.0*z-6.6e-6/z*(1.-EXP(-z/8.e-4))) - ELSE - dF_sol_z=0. - ENDIF - ! - END SUBROUTINE sw_fairall_simple_v1 - ! - !====================== - ! - elemental SUBROUTINE sw_wick_v1(F_sol_0,z,dF_sol_z) - ! - ! Solar radiation absorbed by the ocean at the depth z (Zeng and Beljaars, 2005, p.5) - ! - ! INPUT: - ! F_sol_0: solar radiation at the ocean surface (W/m^2) - ! z: depth (m) - ! - ! OUTPUT: - ! dF_sol_z: solar radiation absorbed by the ocean at depth z (W/m^2) - ! - IMPLICIT NONE - REAL(kind=kind_phys),INTENT(in):: z,F_sol_0 - REAL(kind=kind_phys),INTENT(out):: dF_sol_z - ! - IF(z>0) THEN - dF_sol_z=F_sol_0*(0.065+11.0*z-6.6e-5/z*(1.-EXP(-z/8.e-4))) - ELSE - dF_sol_z=0. - ENDIF - ! - END SUBROUTINE sw_wick_v1 - ! - !====================== - ! - elemental SUBROUTINE sw_soloviev_3exp_v1(F_sol_0,z,dF_sol_z) - ! - ! Solar radiation absorbed by the ocean at the depth z (Fairall et all, 1996, p. 1301) - ! following Soloviev, 1982 - ! - ! INPUT: - ! F_sol_0: solar radiation at the ocean surface (W/m^2) - ! z: depth (m) - ! - ! OUTPUT: - ! dF_sol_z: solar radiation absorbed by the ocean at depth z (W/m^2) - ! - IMPLICIT NONE - REAL(kind=kind_phys),INTENT(in):: z,F_sol_0 - REAL(kind=kind_phys),INTENT(out):: dF_sol_z - REAL(kind=kind_phys),DIMENSION(3) :: f_c - REAL(kind=kind_phys), DIMENSION(3), PARAMETER :: - & f=(/0.45,0.27,0.28/) - & ,gamma=(/12.8,0.357,0.014/) - ! - IF(z>0) THEN - f_c=f*gamma(1-EXP(-z/gamma)) - dF_sol_z=F_sol_0*(1.0-SUM(f_c)/z) - ELSE - dF_sol_z=0. - ENDIF - ! - END SUBROUTINE sw_soloviev_3exp_v1 - ! - !====================== - ! - elemental SUBROUTINE sw_soloviev_3exp_v2(F_sol_0,z,dF_sol_z) - ! - ! Solar radiation absorbed by the ocean at the depth z (Fairall et all, 1996, p. 1301) - ! following Soloviev, 1982 - ! - ! INPUT: - ! F_sol_0: solar radiation at the ocean surface (W/m^2) - ! z: depth (m) - ! - ! OUTPUT: - ! dF_sol_z: solar radiation absorbed by the ocean at depth z (W/m^2) - ! - IMPLICIT NONE - REAL(kind=kind_phys),INTENT(in):: z,F_sol_0 - REAL(kind=kind_phys),INTENT(out):: dF_sol_z - ! - IF(z>0) THEN - dF_sol_z=F_sol_0*(1.0 - & -(0.28*0.014*(1.-exp(-z/0.014)) - & +0.27*0.357*(1.-exp(-z/0.357)) - & +.45*12.82*(1.-exp(-z/12.82)))/z - & ) - ELSE - dF_sol_z=0. - ENDIF - ! - END SUBROUTINE sw_soloviev_3exp_v2 - - elemental SUBROUTINE sw_soloviev_3exp_v2_Aw(z,Aw) - ! - ! Aw = d(fxp)/d(z) - ! following Soloviev, 1982 - ! - ! INPUT: - ! z: depth (m) - ! - ! OUTPUT: - ! Aw: d(fxp)/d(z) - ! - IMPLICIT NONE - REAL(kind=kind_phys),INTENT(in):: z - REAL(kind=kind_phys),INTENT(out):: Aw - REAL(kind=kind_phys):: fxp - ! - IF(z>0) THEN - fxp=(1.0 - & -(0.28*0.014*(1.-exp(-z/0.014)) - & + 0.27*0.357*(1.-exp(-z/0.357)) - & + 0.45*12.82*(1.-exp(-z/12.82)))/z - & ) - Aw=1.0-fxp-(0.28*exp(-z/0.014)+0.27*exp(-z/0.357) - & +0.45*exp(-z/12.82)) - ELSE - Aw=0. - ENDIF - END SUBROUTINE sw_soloviev_3exp_v2_Aw - ! - ! - !====================== - ! - elemental SUBROUTINE sw_ohlmann_v1(z,fxp) - ! - ! Fraction of the Solar radiation absorbed by the ocean at the depth z - ! - ! INPUT: - ! z: depth (m) - ! - ! OUTPUT: - ! fxp: Fraction of the solar radiation absorbed by the ocean at depth z (W/m^2) - ! - IMPLICIT NONE - REAL(kind=kind_phys),INTENT(in):: z - REAL(kind=kind_phys),INTENT(out):: fxp - ! - IF(z>0) THEN - fxp=.065+11.*z-6.6e-5/z*(1.-EXP(-z/8.0e-4)) - ELSE - fxp=0. - ENDIF - ! - END SUBROUTINE sw_ohlmann_v1 - ! - - function grv(lat) - real(kind=kind_phys) :: lat - real(kind=kind_phys) :: gamma,c1,c2,c3,c4,pi,phi,x - gamma=9.7803267715 - c1=0.0052790414 - c2=0.0000232718 - c3=0.0000001262 - c4=0.0000000007 - pi=3.141593 - - phi=lat*pi/180 - x=sin(phi) - grv=gamma*(1+(c1*x**2)+(c2*x**4)+(c3*x**6)+(c4*x**8)) - !print *,'grav=',grv,lat - end function grv - - SUBROUTINE solar_time_from_Julian(jday,xlon,soltim) - ! - ! Calculate solar time from the Julian date - ! - IMPLICIT NONE - REAL(kind=kind_phys), INTENT(in) :: jday - REAL(kind=kind_phys), INTENT(in) :: xlon - REAL(kind=kind_phys), INTENT(out) :: soltim - REAL(kind=kind_phys) :: fjd,xhr,xmin,xsec,intime - INTEGER :: nn - ! - fjd=jday-FLOOR(jday) - fjd=jday - xhr=FLOOR(fjd*24.0)-SIGN(12.0,fjd-0.5) - xmin=NINT(fjd*1440.0)-(xhr+SIGN(12.0,fjd-0.5))*60 - xsec=0 - intime=xhr+xmin/60.0+xsec/3600.0+24.0 - soltim=mod(xlon/15.0+intime,24.0)*3600.0 - END SUBROUTINE solar_time_from_Julian - -! -!*********************************************************************** -! - subroutine compjd(jyr,jmnth,jday,jhr,jmn,jd,fjd) -!fpp$ noconcur r -!$$$ subprogram documentation block -! . . . . -! subprogram: compjd computes julian day and fraction -! prgmmr: kenneth campana org: w/nmc23 date: 89-07-07 -! -! abstract: computes julian day and fraction -! from year, month, day and time utc. -! -! program history log: -! 77-05-06 ray orzol,gfdl -! 98-05-15 iredell y2k compliance -! -! usage: call compjd(jyr,jmnth,jday,jhr,jmn,jd,fjd) -! input argument list: -! jyr - year (4 digits) -! jmnth - month -! jday - day -! jhr - hour -! jmn - minutes -! output argument list: -! jd - julian day. -! fjd - fraction of the julian day. -! -! subprograms called: -! iw3jdn compute julian day number -! -! attributes: -! language: fortran. -! -!$$$ - use machine , only :kind_phys - implicit none -! - integer jyr,jmnth,jday,jhr,jmn,jd - integer iw3jdn - real (kind=kind_phys) fjd - jd=iw3jdn(jyr,jmnth,jday) - if(jhr.lt.12) then - jd=jd-1 - fjd=0.5+jhr/24.+jmn/1440. - else - fjd=(jhr-12)/24.+jmn/1440. - endif - end subroutine compjd - - END MODULE module_nsst_water_prop diff --git a/src/fim/FIMsrc/fim/column/moninp1_v.f b/src/fim/FIMsrc/fim/column/moninp1_v.f deleted file mode 100644 index 2d41160..0000000 --- a/src/fim/FIMsrc/fim/column/moninp1_v.f +++ /dev/null @@ -1,615 +0,0 @@ -CFPP$ NOCONCUR R - SUBROUTINE MONINP1(IX,IM,KM,ntrac,DV,DU,TAU,RTG, - & U1,V1,T1,Q1, - & PSK,RBSOIL,FM,FH,TSEA,QSS,HEAT,EVAP,STRESS,SPD1,KPBL, -! & PSK,RBSOIL,CD,CH,FM,FH,TSEA,QSS,DPHI,SPD1,KPBL, - & PRSI,DEL,PRSL,PRSLK,PHII,PHIL,RCL,DELTIM, - & DUSFC,DVSFC,DTSFC,DQSFC,HPBL,HGAMT,HGAMQ,DKT - &, kinver, oro) -! - USE MACHINE , ONLY : kind_phys - USE PHYSCONS, grav => con_g, RD => con_RD, CP => con_CP - &, HVAP => con_HVAP, ROG => con_ROG, FV => con_FVirt - implicit none -! -! This code assumes that terrain height is not included in PHII and PHIL -! -! Arguments -! - integer IX, IM, KM, ntrac, KPBL(IM) - integer kinver(im) -! - real(kind=kind_phys) DELTIM - real(kind=kind_phys) DV(IM,KM), DU(IM,KM), - & TAU(IM,KM), RTG(IM,KM,ntrac), - & U1(IX,KM), V1(IX,KM), - & T1(IX,KM), Q1(IX,KM,ntrac), - & PSK(IM), RBSOIL(IM), -! & CD(IM), CH(IM), - & FM(IM), FH(IM), - & TSEA(IM), QSS(IM), - & SPD1(IM), -! & DPHI(IM), SPD1(IM), - & PRSI(IX,KM+1), DEL(IX,KM), - & PRSL(IX,KM), PRSLK(IX,KM), - & PHII(IX,KM+1), PHIL(IX,KM), - & RCL(IM), DUSFC(IM), - & dvsfc(IM), dtsfc(IM), - & DQSFC(IM), HPBL(IM), - & HGAMT(IM), hgamq(IM), oro(im) -! -! Locals -! - integer i,iprt,is,iun,k,kk,kmpbl,lond -! real(kind=kind_phys) betaq(IM), betat(IM), betaw(IM), - real(kind=kind_phys) evap(IM), heat(IM), phih(IM), - & phim(IM), rbdn(IM), rbup(IM), - & the1(IM), stress(im), beta(im), - & the1v(IM), thekv(IM), thermal(IM), - & thesv(IM), ustar(IM), wscale(IM) -! & thesv(IM), ustar(IM), wscale(IM), zl1(IM) -! - real(kind=kind_phys) RDZT(IM,KM-1), - & ZI(IM,KM+1), ZL(IM,KM), - & DKU(IM,KM-1), DKT(IM,KM-1), - & AL(IM,KM-1), AD(IM,KM), - & AU(IM,KM-1), A1(IM,KM), - & A2(IM,KM*ntrac), THETA(IM,KM) - logical pblflg(IM), sfcflg(IM), stable(IM) -! - real(kind=kind_phys) aphi16, aphi5, bet1, bvf2, - & cfac, conq, cont, conw, - & conwrc, dk, dkmax, dkmin, - & dq1, dsdz2, dsdzq, dsdzt, - & dsig, dt, dthe1, dtodsd, - & dtodsu, dw2, dw2min, g, - & gamcrq, gamcrt, gocp, gor, gravi, - & hol, pfac, prmax, prmin, prinv, - & prnum, qmin, qtend, rbcr, - & rbint, rdt, rdz, -! & rbint, rdt, rdz, rdzt1, - & ri, rimin, rl2, rlam, rlamun, - & rone, rzero, sfcfrac, - & sflux, shr2, spdk2, sri, - & tem, ti, ttend, tvd, - & tvu, utend, vk, vk2, - & vpert, vtend, xkzo(im,km), zfac, - & zfmin, zk, tem1, xkzm - &, xkzm_loc(im) -cc -! real (kind=kind_phys), parameter :: xkzm_min=3.0 -! real (kind=kind_phys), parameter :: xkzm_min=2.0 - real (kind=kind_phys), parameter :: xkzm_min=1.0 -! real (kind=kind_phys), parameter :: xkzm_min=0.5 -! real (kind=kind_phys), parameter :: xkzm_min=0.75 -! real (kind=kind_phys), parameter :: xkzm_min=0.25 -! real (kind=kind_phys), parameter :: xkzm_min=0.10 - parameter (gravi=1.0/grav) - PARAMETER(g=grav) - PARAMETER(GOR=G/RD,GOCP=G/CP) - PARAMETER(CONT=1000.*CP/G,CONQ=1000.*HVAP/G,CONW=1000./G) -! PARAMETER(RLAM=150.0,VK=0.4,VK2=VK*VK,PRMIN=1.0,PRMAX=4.) - PARAMETER(RLAM=30.0,VK=0.4,VK2=VK*VK,PRMIN=1.0,PRMAX=4.) -! PARAMETER(RLAM=50.0,VK=0.4,VK2=VK*VK,PRMIN=1.0,PRMAX=4.) - PARAMETER(DW2MIN=0.0001,DKMIN=0.0,DKMAX=1000.,RIMIN=-100.) - PARAMETER(RBCR=0.25,CFAC=7.8,PFAC=2.0,SFCFRAC=0.1) -! PARAMETER(RBCR=0.5,CFAC=7.8,PFAC=2.0,SFCFRAC=0.1) -! PARAMETER(QMIN=1.E-8,XKZM=3.0,ZFMIN=1.E-8,APHI5=5.,APHI16=16.) -! PARAMETER(QMIN=1.E-8,XKZM=2.0,ZFMIN=1.E-8,APHI5=5.,APHI16=16.) -! PARAMETER(QMIN=1.E-8,XKZM=1.5,ZFMIN=1.E-8,APHI5=5.,APHI16=16.) - PARAMETER(QMIN=1.E-8,XKZM=1.0,ZFMIN=1.E-8,APHI5=5.,APHI16=16.) -! PARAMETER(QMIN=1.E-8,XKZM=0.5,ZFMIN=1.E-8,APHI5=5.,APHI16=16.) -! PARAMETER(QMIN=1.E-8,XKZM=0.25,ZFMIN=1.E-8,APHI5=5.,APHI16=16.) -! PARAMETER(QMIN=1.E-8,XKZM=0.10,ZFMIN=1.E-8,APHI5=5.,APHI16=16.) -! PARAMETER(QMIN=1.E-8,XKZM=0.0,ZFMIN=1.E-8,APHI5=5.,APHI16=16.) -! PARAMETER(GAMCRT=3.,GAMCRQ=2.E-3) - PARAMETER(GAMCRT=3.,GAMCRQ=0., RLAMUN=150.0) -! PARAMETER(GAMCRT=3.,GAMCRQ=0., RLAMUN=30.0) - PARAMETER(IUN=84) -! -C -C----------------------------------------------------------------------- -C - 601 FORMAT(1X,' MONINP LAT LON STEP HOUR ',3I6,F6.1) - 602 FORMAT(1X,' K',' Z',' T',' TH', - 1 ' TVH',' Q',' U',' V', - 2 ' SP') - 603 FORMAT(1X,I5,8F9.1) - 604 FORMAT(1X,' SFC',9X,F9.1,18X,F9.1) - 605 FORMAT(1X,' K ZL SPD2 THEKV THE1V' - 1 ,' THERMAL RBUP') - 606 FORMAT(1X,I5,6F8.2) - 607 FORMAT(1X,' KPBL HPBL FM FH HGAMT', - 1 ' HGAMQ WS USTAR CD CH') - 608 FORMAT(1X,I5,9F8.2) - 609 FORMAT(1X,' K PR DKT DKU ',I5,3F8.2) - 610 FORMAT(1X,' K PR DKT DKU ',I5,3F8.2,' L2 RI T2', - 1 ' SR2 ',2F8.2,2E10.2) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COMPUTE PRELIMINARY VARIABLES -C - if (IX .lt. im) stop -! -! IPRT = 0 -! IF(IPRT.EQ.1) THEN -CCC LATD = 0 -! LOND = 0 -! ELSE -CCC LATD = 0 -! LOND = 0 -! ENDIF -C - DT = 2. * DELTIM - RDT = 1. / DT - KMPBL = KM / 2 -! - do k=1,km - do i=1,im - zi(i,k) = phii(i,k) * gravi - zl(i,k) = phil(i,k) * gravi - enddo - enddo -! - do k=1,kmpbl - do i=1,im - theta(i,k) = t1(i,k) * psk(i) / prslk(i,k) - enddo - enddo -C - DO K = 1,KM-1 - DO I=1,IM - RDZT(I,K) = 1.0 / (ZL(I,K+1) - ZL(I,K)) -! RDZT(I,K) = GOR * PRSI(I,K+1) / (PRSL(I,K) - PRSL(I,K+1)) -! if (prsi(i,1) .gt. 60.0) then -! tem1 = max((prsi(i,k+1)-30.0)/(prsi(i,1)-30.0), 0.0) -! else -! tem1 = 0.0 -! endif -! xkzo(i,k) = xkzm * tem1 * tem1 -!! tem1 = (zi(i,k+1) - zi(i,1)) * 0.002 -!! xkzo(i,k) = xkzm * exp(-tem1) - ENDDO - ENDDO -C - DO I = 1,IM - DUSFC(I) = 0. - DVSFC(I) = 0. - DTSFC(I) = 0. - DQSFC(I) = 0. - HGAMT(I) = 0. - HGAMQ(I) = 0. - WSCALE(I) = 0. - KPBL(I) = 1 - HPBL(I) = ZI(I,2) - PBLFLG(I) = .TRUE. - SFCFLG(I) = .TRUE. - IF(RBSOIL(I).GT.0.0) SFCFLG(I) = .FALSE. - ENDDO -!! - DO I=1,IM -! RDZT1 = GOR * prSL(i,1) / DEL(i,1) -! BET1 = DT*RDZT1*SPD1(I)/T1(I,1) -! BETA(I) = DT*RDZT1/T1(I,1) - BETA(I) = DT / (zi(i,2)-zi(i,1)) -! BETAW(I) = BET1*CD(I) -! BETAT(I) = BET1*CH(I) -! BETAQ(I) = DPHI(I)*BETAT(I) - ENDDO -C - DO I=1,IM -! ZL1(i) = 0.-(T1(I,1)+TSEA(I))/2.*LOG(PRSL(I,1)/PRSI(I,1))*ROG -! USTAR(I) = SQRT(CD(I)*SPD1(I)**2) - USTAR(I) = SQRT(STRESS(I)) - ENDDO -C - DO I=1,IM - THESV(I) = TSEA(I)*(1.+FV*MAX(QSS(I),QMIN)) - THE1(I) = THETA(I,1) - THE1V(I) = THE1(I)*(1.+FV*MAX(Q1(I,1,1),QMIN)) - THERMAL(I) = THE1V(I) -! DTHE1 = (THE1(I)-TSEA(I)) -! DQ1 = (MAX(Q1(I,1,1),QMIN) - MAX(QSS(I),QMIN)) -! HEAT(I) = -CH(I)*SPD1(I)*DTHE1 -! EVAP(I) = -CH(I)*SPD1(I)*DQ1 - ENDDO -C -C -C COMPUTE THE FIRST GUESS OF PBL HEIGHT -C - DO I=1,IM - STABLE(I) = .FALSE. -! ZL(i,1) = ZL1(i) - RBUP(I) = RBSOIL(I) - ENDDO - DO K = 2, KMPBL - DO I = 1, IM - IF(.NOT.STABLE(I)) THEN - RBDN(I) = RBUP(I) -! ZL(I,k) = ZL(I,K-1) - (T1(i,k)+T1(i,K-1))/2 * -! & LOG(PRSL(I,K)/PRSL(I,K-1)) * ROG - THEKV(I) = THETA(i,k)*(1.+FV*MAX(Q1(i,k,1),QMIN)) - SPDK2 = MAX(RCL(i)*(U1(i,k)**2+V1(i,k)**2),1.) - RBUP(I) = (THEKV(I)-THE1V(I))*(G*ZL(I,k)/THE1V(I))/SPDK2 - KPBL(I) = K - STABLE(I) = RBUP(I).GT.RBCR - ENDIF - ENDDO - ENDDO -C - DO I = 1,IM - K = KPBL(I) - IF(RBDN(I).GE.RBCR) THEN - RBINT = 0. - ELSEIF(RBUP(I).LE.RBCR) THEN - RBINT = 1. - ELSE - RBINT = (RBCR-RBDN(I))/(RBUP(I)-RBDN(I)) - ENDIF - HPBL(I) = ZL(I,K-1) + RBINT*(ZL(I,K)-ZL(I,K-1)) - IF(HPBL(I).LT.ZI(I,KPBL(I))) KPBL(I) = KPBL(I) - 1 - ENDDO -!! - DO I=1,IM - HOL = MAX(RBSOIL(I)*FM(I)*FM(I)/FH(I),RIMIN) - IF(SFCFLG(I)) THEN - HOL = MIN(HOL,-ZFMIN) - ELSE - HOL = MAX(HOL,ZFMIN) - ENDIF -C -! HOL = HOL*HPBL(I)/ZL1(I)*SFCFRAC - HOL = HOL*HPBL(I)/ZL(I,1)*SFCFRAC - IF(SFCFLG(I)) THEN -! PHIM = (1.-APHI16*HOL)**(-1./4.) -! PHIH = (1.-APHI16*HOL)**(-1./2.) - TEM = 1.0 / (1. - APHI16*HOL) - PHIH(I) = SQRT(TEM) - PHIM(I) = SQRT(PHIH(I)) - ELSE - PHIM(I) = (1.+APHI5*HOL) - PHIH(I) = PHIM(I) - ENDIF - WSCALE(I) = USTAR(I)/PHIM(I) - WSCALE(I) = MIN(WSCALE(I),USTAR(I)*APHI16) - WSCALE(I) = MAX(WSCALE(I),USTAR(I)/APHI5) - ENDDO -C -C COMPUTE THE SURFACE VARIABLES FOR PBL HEIGHT ESTIMATION -C UNDER UNSTABLE CONDITIONS -C - DO I = 1,IM - SFLUX = HEAT(I) + EVAP(I)*FV*THE1(I) - IF(SFCFLG(I).AND.SFLUX.GT.0.0) THEN - HGAMT(I) = MIN(CFAC*HEAT(I)/WSCALE(I),GAMCRT) - HGAMQ(I) = MIN(CFAC*EVAP(I)/WSCALE(I),GAMCRQ) - VPERT = HGAMT(I) + FV*THE1(I)*HGAMQ(I) - VPERT = MIN(VPERT,GAMCRT) - THERMAL(I) = THERMAL(I) + MAX(VPERT,0.) - HGAMT(I) = MAX(HGAMT(I),0.0) - HGAMQ(I) = MAX(HGAMQ(I),0.0) - ELSE - PBLFLG(I) = .FALSE. - ENDIF - ENDDO -C - DO I = 1,IM - IF(PBLFLG(I)) THEN - KPBL(I) = 1 - HPBL(I) = ZI(I,2) - ENDIF - ENDDO -C -C ENHANCE THE PBL HEIGHT BY CONSIDERING THE THERMAL -C - DO I = 1, IM - IF(PBLFLG(I)) THEN - STABLE(I) = .FALSE. - RBUP(I) = RBSOIL(I) - ENDIF - ENDDO - DO K = 2, KMPBL - DO I = 1, IM - IF(.NOT.STABLE(I).AND.PBLFLG(I)) THEN - RBDN(I) = RBUP(I) -! ZL(I,k) = ZL(I,K-1) - (T1(i,k)+T1(i,K-1))/2 * -! & LOG(PRSL(I,K)/PRSL(I,K-1)) * ROG - THEKV(I) = THETA(i,k)*(1.+FV*MAX(Q1(i,k,1),QMIN)) - SPDK2 = MAX(RCL(i)*(U1(i,k)**2+V1(i,k)**2),1.) - RBUP(I) = (THEKV(I)-THERMAL(I))*(G*ZL(I,k)/THE1V(I))/SPDK2 - KPBL(I) = K - STABLE(I) = RBUP(I).GT.RBCR - ENDIF - ENDDO - ENDDO -C - DO I = 1,IM - IF(PBLFLG(I)) THEN - K = KPBL(I) - IF(RBDN(I).GE.RBCR) THEN - RBINT = 0. - ELSEIF(RBUP(I).LE.RBCR) THEN - RBINT = 1. - ELSE - RBINT = (RBCR-RBDN(I))/(RBUP(I)-RBDN(I)) - ENDIF - HPBL(I) = ZL(I,K-1) + RBINT*(ZL(I,k)-ZL(I,K-1)) - IF(HPBL(I).LT.ZI(I,KPBL(I))) KPBL(I) = KPBL(I) - 1 - IF(KPBL(I).LE.1) PBLFLG(I) = .FALSE. - ENDIF - ENDDO -!! -! DO K = 1,KM-1 -! DO I=1,IM -! if (rbsoil(i) .gt. 0.0 .or. (.not. pblflg(i))) then -! tem1 = max((prsi(i,k+1)-30.0)/(prsi(i,1)-30.0), 0.0) -! xkzo(i,k) = xkzm * tem1 * tem1 -!! tem1 = (zi(i,k+1) - zi(i,1)) * 0.002 -!! xkzo(i,k) = xkzm * exp(-tem1) -! else -! xkzo(i,k) = 0.0 -! -! if (pblflg(i)) then -! if (sfcflg(i)) then -! xkzo(i,k) = 0.0 -! else -! tem1 = (zi(i,k+1) - zi(i,1)) * 0.0005 -! tem1 = (100.0 - prsi(i,k+1)) * 0.075 -! tem1 = 100.0 - prsi(i,k+1) -! tem1 = max(0.0, 100.0 - prsi(i,k+1)) -! tem1 = tem1 * tem1 * 0.00075 -! tem1 = tem1 * tem1 * 0.001 -! tem1 = tem1 * tem1 * 0.0011 -! tem1 = tem1 * tem1 * 0.0012 -! -! tem1 = 1.0 - prsi(i,k+1) / prsi(i,1) -! tem1 = tem1 * tem1 * 5.0 -! tem1 = tem1 * tem1 * 7.5 -! tem1 = tem1 * tem1 * 10.0 -! tem1 = tem1 * tem1 * 12.0 -! -! xkzo(i,k) = xkzm * min(1.0, exp(-tem1)) -! if (xkzo(i,k) .lt. 0.01) xkzo(i,k) = 0.0 -! endif -! ENDDO -! ENDDO -! - DO I=1,IM -! xkzm_loc(i) = max(xkzm_min, min(xkzm, oro(i)*0.001)) - xkzm_loc(i) = min(xkzm, xkzm_min + oro(i)*0.002) - ENDDO - DO K = 1,KM-1 - DO I=1,IM - if (k .lt. kinver(i)) then -! if (k .le. kinver(i)) then - tem1 = 1.0 - prsi(i,k+1) / prsi(i,1) -!Nogod tem1 = max(0.0, 1.0 - prsi(i,k+1) * 0.01) -! tem1 = tem1 * tem1 * 5.0 - tem1 = tem1 * tem1 * 10.0 -! tem1 = tem1 * tem1 * 20.0 -! xkzo(i,k) = xkzm * min(1.0, exp(-tem1)) - xkzo(i,k) = xkzm_loc(i) * min(1.0, exp(-tem1)) - else - xkzo(i,k) = 0.0 - endif - ENDDO - ENDDO -!! -C -C COMPUTE DIFFUSION COEFFICIENTS BELOW PBL -C - DO K = 1, KMPBL - DO I=1,IM - IF(KPBL(I).GT.K) THEN - PRINV = 1.0 / (PHIH(I)/PHIM(I)+CFAC*VK*.1) - PRINV = MIN(PRINV,PRMAX) - PRINV = MAX(PRINV,PRMIN) -! ZFAC = MAX((1.-(ZI(I,K+1)-ZL1(I))/ -! 1 (HPBL(I)-ZL1(I))), ZFMIN) - ZFAC = MAX((1.-(ZI(I,K+1)-ZL(I,1))/ - 1 (HPBL(I)-ZL(I,1))), ZFMIN) - DKU(i,k) = XKZO(i,k) + WSCALE(I)*VK*ZI(I,K+1) - 1 * ZFAC**PFAC - DKT(i,k) = DKU(i,k)*PRINV - DKU(i,k) = MIN(DKU(i,k),DKMAX) - DKU(i,k) = MAX(DKU(i,k),DKMIN) - DKT(i,k) = MIN(DKT(i,k),DKMAX) - DKT(i,k) = MAX(DKT(i,k),DKMIN) - ENDIF - ENDDO - ENDDO -C -C COMPUTE DIFFUSION COEFFICIENTS OVER PBL (FREE ATMOSPHERE) -C - DO K = 1, KM-1 - DO I=1,IM - IF(K.GE.KPBL(I)) THEN -! TI = 0.5*(T1(i,k)+T1(i,K+1)) - TI = 2.0 / (T1(i,k)+T1(i,K+1)) -! RDZ = RDZT(I,K)/TI -! RDZ = RDZT(I,K) * TI - RDZ = RDZT(I,K) - - DW2 = RCL(i)*((U1(i,k)-U1(i,K+1))**2 - & + (V1(i,k)-V1(i,K+1))**2) - SHR2 = MAX(DW2,DW2MIN)*RDZ*RDZ - TVD = T1(i,k)*(1.+FV*MAX(Q1(i,k,1),QMIN)) - TVU = T1(i,K+1)*(1.+FV*MAX(Q1(i,K+1,1),QMIN)) -! BVF2 = G*(GOCP+RDZ*(TVU-TVD))/TI - BVF2 = G*(GOCP+RDZ*(TVU-TVD)) * TI - RI = MAX(BVF2/SHR2,RIMIN) - ZK = VK*ZI(I,K+1) -! RL2 = (ZK*RLAM/(RLAM+ZK))**2 -! DK = RL2*SQRT(SHR2) -! RL2 = ZK*RLAM/(RLAM+ZK) -! DK = RL2*RL2*SQRT(SHR2) - IF(RI.LT.0.) THEN ! UNSTABLE REGIME - RL2 = ZK*RLAMUN/(RLAMUN+ZK) - DK = RL2*RL2*SQRT(SHR2) - SRI = SQRT(-RI) - DKU(i,k) = XKZO(i,k) + DK*(1+8.*(-RI)/(1+1.746*SRI)) - DKT(i,k) = XKZO(i,k) + DK*(1+8.*(-RI)/(1+1.286*SRI)) - ELSE ! STABLE REGIME - RL2 = ZK*RLAM/(RLAM+ZK) -! tem = rlam * sqrt(0.01*prsi(i,k)) -! RL2 = ZK*tem/(tem+ZK) - DK = RL2*RL2*SQRT(SHR2) - DKT(i,k) = XKZO(i,k) + DK/(1+5.*RI)**2 - PRNUM = 1.0 + 2.1*RI - PRNUM = MIN(PRNUM,PRMAX) - DKU(i,k) = (DKT(i,k)-XKZO(i,k))*PRNUM + XKZO(i,k) - ENDIF -C - DKU(i,k) = MIN(DKU(i,k),DKMAX) - DKU(i,k) = MAX(DKU(i,k),DKMIN) - DKT(i,k) = MIN(DKT(i,k),DKMAX) - DKT(i,k) = MAX(DKT(i,k),DKMIN) -C -CCC IF(I.EQ.LOND.AND.LAT.EQ.LATD) THEN -CCC PRNUM = DKU(k)/DKT(k) -CCC WRITE(IUN,610) K,PRNUM,DKT(k),DKU(k),RL2,RI, -CCC 1 BVF2,SHR2 -CCC ENDIF -C - ENDIF - ENDDO - ENDDO -C -C COMPUTE TRIDIAGONAL MATRIX ELEMENTS FOR HEAT AND MOISTURE -C - DO I=1,IM - AD(I,1) = 1. - A1(I,1) = T1(i,1) + BETA(i) * HEAT(I) - A2(I,1) = Q1(i,1,1) + BETA(i) * EVAP(I) -! A1(I,1) = T1(i,1)-BETAT(I)*(THETA(i,1)-TSEA(I)) -! A2(I,1) = Q1(i,1,1)-BETAQ(I)* -! & (MAX(Q1(i,1,1),QMIN)-MAX(QSS(I),QMIN)) - ENDDO - if(ntrac.ge.2) then - do k = 2, ntrac - is = (k-1) * km - do i = 1, im - A2(I,1+is) = Q1(i,1,k) - enddo - enddo - endif -C - DO K = 1,KM-1 - DO I = 1,IM - DTODSD = DT/DEL(I,K) - DTODSU = DT/DEL(I,K+1) - DSIG = PRSL(I,K)-PRSL(I,K+1) -! RDZ = RDZT(I,K)*2./(T1(i,k)+T1(i,K+1)) - RDZ = RDZT(I,K) - tem1 = DSIG * DKT(i,k) * RDZ - IF(PBLFLG(I).AND.K.LT.KPBL(I)) THEN -! DSDZT = DSIG*DKT(i,k)*RDZ*(GOCP-HGAMT(I)/HPBL(I)) -! DSDZQ = DSIG*DKT(i,k)*RDZ*(-HGAMQ(I)/HPBL(I)) - tem = 1.0 / HPBL(I) - DSDZT = tem1 * (GOCP-HGAMT(I)*tem) - DSDZQ = tem1 * (-HGAMQ(I)*tem) - A2(I,k) = A2(I,k)+DTODSD*DSDZQ - A2(I,k+1) = Q1(i,k+1,1)-DTODSU*DSDZQ - ELSE -! DSDZT = DSIG*DKT(i,k)*RDZ*(GOCP) - DSDZT = tem1 * GOCP - A2(I,k+1) = Q1(i,k+1,1) - ENDIF -! DSDZ2 = DSIG*DKT(i,k)*RDZ*RDZ - DSDZ2 = tem1 * RDZ - AU(I,k) = -DTODSD*DSDZ2 - AL(I,k) = -DTODSU*DSDZ2 - AD(I,k) = AD(I,k)-AU(I,k) - AD(I,k+1) = 1.-AL(I,k) - A1(I,k) = A1(I,k)+DTODSD*DSDZT - A1(I,k+1) = T1(i,k+1)-DTODSU*DSDZT - ENDDO - ENDDO - if(ntrac.ge.2) then - do kk = 2, ntrac - is = (kk-1) * km - do k = 1, km - 1 - do i = 1, im - A2(I,k+1+is) = Q1(i,k+1,kk) - enddo - enddo - enddo - endif -C -C SOLVE TRIDIAGONAL PROBLEM FOR HEAT AND MOISTURE -C - CALL TRIDIN(IM,KM,ntrac,AL,AD,AU,A1,A2,AU,A1,A2) -C -C RECOVER TENDENCIES OF HEAT AND MOISTURE -C - DO K = 1,KM - DO I = 1,IM - TTEND = (A1(I,k)-T1(i,k))*RDT - QTEND = (A2(I,k)-Q1(i,k,1))*RDT - TAU(i,k) = TAU(i,k)+TTEND - RTG(I,k,1) = RTG(i,k,1)+QTEND - DTSFC(I) = DTSFC(I)+CONT*DEL(I,K)*TTEND - DQSFC(I) = DQSFC(I)+CONQ*DEL(I,K)*QTEND - ENDDO - ENDDO - if(ntrac.ge.2) then - do kk = 2, ntrac - is = (kk-1) * km - do k = 1, km - do i = 1, im - QTEND = (A2(I,K+is)-Q1(i,K,kk))*RDT - RTG(i,K,kk) = RTG(i,K,kk)+QTEND - enddo - enddo - enddo - endif -C -C COMPUTE TRIDIAGONAL MATRIX ELEMENTS FOR MOMENTUM -C - DO I=1,IM -! AD(I,1) = 1.+BETAW(I) - AD(I,1) = 1.0 + BETA(i) * STRESS(I) / SPD1(I) - A1(I,1) = U1(i,1) - A2(I,1) = V1(i,1) -! AD(I,1) = 1.0 -! tem = 1.0 + BETA(I) * STRESS(I) / SPD1(I) -! A1(I,1) = U1(i,1) * tem -! A2(I,1) = V1(i,1) * tem - ENDDO -C - DO K = 1,KM-1 - DO I=1,IM - DTODSD = DT/DEL(I,K) - DTODSU = DT/DEL(I,K+1) - DSIG = PRSL(I,K)-PRSL(I,K+1) -! RDZ = RDZT(I,K)*2./(T1(i,k)+T1(i,k+1)) - RDZ = RDZT(I,K) - DSDZ2 = DSIG*DKU(i,k)*RDZ*RDZ - AU(I,k) = -DTODSD*DSDZ2 - AL(I,k) = -DTODSU*DSDZ2 - AD(I,k) = AD(I,k)-AU(I,k) - AD(I,k+1) = 1.-AL(I,k) - A1(I,k+1) = U1(i,k+1) - A2(I,k+1) = V1(i,k+1) - ENDDO - ENDDO -C -C SOLVE TRIDIAGONAL PROBLEM FOR MOMENTUM -C - CALL TRIDI2(IM,KM,AL,AD,AU,A1,A2,AU,A1,A2) -C -C RECOVER TENDENCIES OF MOMENTUM -C - DO K = 1,KM - DO I = 1,IM - CONWRC = CONW*SQRT(RCL(i)) - UTEND = (A1(I,k)-U1(i,k))*RDT - VTEND = (A2(I,k)-V1(i,k))*RDT - DU(i,k) = DU(i,k)+UTEND - DV(i,k) = DV(i,k)+VTEND - DUSFC(I) = DUSFC(I)+CONWRC*DEL(I,K)*UTEND - DVSFC(I) = DVSFC(I)+CONWRC*DEL(I,K)*VTEND - ENDDO - ENDDO -!! - RETURN - END diff --git a/src/fim/FIMsrc/fim/column/moninp_v.f b/src/fim/FIMsrc/fim/column/moninp_v.f deleted file mode 100644 index a28474d..0000000 --- a/src/fim/FIMsrc/fim/column/moninp_v.f +++ /dev/null @@ -1,700 +0,0 @@ -CFPP$ NOCONCUR R - SUBROUTINE MONINP(IX,IM,KM,ntrac,DV,DU,TAU,RTG, - & U1,V1,T1,Q1, - & PSK,RBSOIL,FM,FH,TSEA,QSS,HEAT,EVAP,STRESS,SPD1,KPBL, -! & PSK,RBSOIL,CD,CH,FM,FH,TSEA,QSS,DPHI,SPD1,KPBL, - & PRSI,DEL,PRSL,PRSLK,PHII,PHIL,RCL,DELTIM, -!hchuang code change [c1L] : add DKT output - & DUSFC,DVSFC,DTSFC,DQSFC,HPBL,HGAMT,HGAMQ, DKT) -! - USE MACHINE , ONLY : kind_phys - USE PHYSCONS, grav => con_g, RD => con_RD, CP => con_CP - &, HVAP => con_HVAP, ROG => con_ROG, FV => con_FVirt - implicit none -! -! include 'constant.h' -! -! -! Arguments -! - integer IX, IM, KM, ntrac, KPBL(IM) -! - real(kind=kind_phys) DELTIM - real(kind=kind_phys) DV(IM,KM), DU(IM,KM), - & TAU(IM,KM), RTG(IM,KM,ntrac), - & U1(IX,KM), V1(IX,KM), - & T1(IX,KM), Q1(IX,KM,ntrac), - & PSK(IM), RBSOIL(IM), -! & CD(IM), CH(IM), - & FM(IM), FH(IM), - & TSEA(IM), QSS(IM), - & SPD1(IM), -! & DPHI(IM), SPD1(IM), - & PRSI(IX,KM+1), DEL(IX,KM), - & PRSL(IX,KM), PRSLK(IX,KM), - & PHII(IX,KM+1), PHIL(IX,KM), - & RCL(IM), DUSFC(IM), - & dvsfc(IM), dtsfc(IM), - & DQSFC(IM), HPBL(IM), - & HGAMT(IM), hgamq(IM) -! -! Locals -! - integer i,iprt,is,iun,k,kk,kmpbl,lond -! real(kind=kind_phys) betaq(IM), betat(IM), betaw(IM), - real(kind=kind_phys) evap(IM), heat(IM), phih(IM), - & phim(IM), rbdn(IM), rbup(IM), - & the1(IM), stress(im), beta(im), - & the1v(IM), thekv(IM), thermal(IM), - & thesv(IM), ustar(IM), wscale(IM) -! & thesv(IM), ustar(IM), wscale(IM), zl1(IM) -! - real(kind=kind_phys) RDZT(IM,KM-1), - & ZI(IM,KM+1), ZL(IM,KM), - & DKU(IM,KM-1), DKT(IM,KM-1), - & AL(IM,KM-1), AD(IM,KM), - & AU(IM,KM-1), A1(IM,KM), - & A2(IM,KM*ntrac), THETA(IM,KM) - logical pblflg(IM), sfcflg(IM), stable(IM) -! - real(kind=kind_phys) aphi16, aphi5, bet1, bvf2, - & cfac, conq, cont, conw, - & conwrc, dk, dkmax, dkmin, - & dq1, dsdz2, dsdzq, dsdzt, - & dsig, dt, dthe1, dtodsd, - & dtodsu, dw2, dw2min, g, - & gamcrq, gamcrt, gocp, gor, gravi, - & hol, pfac, prmax, prmin, prinv, - & prnum, qmin, qtend, rbcr, - & rbint, rdt, rdz, -! & rbint, rdt, rdz, rdzt1, - & ri, rimin, rl2, rlam, rlamun, - & rone, rzero, sfcfrac, - & sflux, shr2, spdk2, sri, - & tem, ti, ttend, tvd, - & tvu, utend, vk, vk2, - & vpert, vtend, xkzo(im,km), zfac, - & zfmin, zk, tem1, xkzm -cc - parameter (gravi=1.0/grav) - PARAMETER(g=grav) - PARAMETER(GOR=G/RD,GOCP=G/CP) - PARAMETER(CONT=1000.*CP/G,CONQ=1000.*HVAP/G,CONW=1000./G) -! PARAMETER(RLAM=150.0,VK=0.4,VK2=VK*VK,PRMIN=1.0,PRMAX=4.) - PARAMETER(RLAM=30.0,VK=0.4,VK2=VK*VK,PRMIN=1.0,PRMAX=4.) -! PARAMETER(RLAM=50.0,VK=0.4,VK2=VK*VK,PRMIN=1.0,PRMAX=4.) - PARAMETER(DW2MIN=0.0001,DKMIN=0.0,DKMAX=1000.,RIMIN=-100.) - PARAMETER(RBCR=0.25,CFAC=7.8,PFAC=2.0,SFCFRAC=0.1) -! PARAMETER(RBCR=0.5,CFAC=7.8,PFAC=2.0,SFCFRAC=0.1) -! PARAMETER(QMIN=1.E-8,XKZM=3.0,ZFMIN=1.E-8,APHI5=5.,APHI16=16.) -! PARAMETER(QMIN=1.E-8,XKZM=2.0,ZFMIN=1.E-8,APHI5=5.,APHI16=16.) - PARAMETER(QMIN=1.E-8,XKZM=1.0,ZFMIN=1.E-8,APHI5=5.,APHI16=16.) -! PARAMETER(QMIN=1.E-8,XKZM=0.5,ZFMIN=1.E-8,APHI5=5.,APHI16=16.) -! PARAMETER(QMIN=1.E-8,XKZM=0.25,ZFMIN=1.E-8,APHI5=5.,APHI16=16.) -! PARAMETER(QMIN=1.E-8,XKZM=0.10,ZFMIN=1.E-8,APHI5=5.,APHI16=16.) -! PARAMETER(QMIN=1.E-8,XKZM=0.0,ZFMIN=1.E-8,APHI5=5.,APHI16=16.) -! PARAMETER(GAMCRT=3.,GAMCRQ=2.E-3) - PARAMETER(GAMCRT=3.,GAMCRQ=0., RLAMUN=150.0) -! PARAMETER(GAMCRT=3.,GAMCRQ=0., RLAMUN=30.0) - PARAMETER(IUN=84) -! -C -C----------------------------------------------------------------------- -C - 601 FORMAT(1X,' MONINP LAT LON STEP HOUR ',3I6,F6.1) - 602 FORMAT(1X,' K',' Z',' T',' TH', - 1 ' TVH',' Q',' U',' V', - 2 ' SP') - 603 FORMAT(1X,I5,8F9.1) - 604 FORMAT(1X,' SFC',9X,F9.1,18X,F9.1) - 605 FORMAT(1X,' K ZL SPD2 THEKV THE1V' - 1 ,' THERMAL RBUP') - 606 FORMAT(1X,I5,6F8.2) - 607 FORMAT(1X,' KPBL HPBL FM FH HGAMT', - 1 ' HGAMQ WS USTAR CD CH') - 608 FORMAT(1X,I5,9F8.2) - 609 FORMAT(1X,' K PR DKT DKU ',I5,3F8.2) - 610 FORMAT(1X,' K PR DKT DKU ',I5,3F8.2,' L2 RI T2', - 1 ' SR2 ',2F8.2,2E10.2) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COMPUTE PRELIMINARY VARIABLES -C - if (IX .lt. im) stop -! -! IPRT = 0 -! IF(IPRT.EQ.1) THEN -CCC LATD = 0 -! LOND = 0 -! ELSE -CCC LATD = 0 -! LOND = 0 -! ENDIF -C - DT = 2. * DELTIM - RDT = 1. / DT - KMPBL = KM / 2 -! - do k=1,km - do i=1,im - zi(i,k) = phii(i,k) * gravi - zl(i,k) = phil(i,k) * gravi - enddo - enddo -! - do k=1,kmpbl - do i=1,im - theta(i,k) = t1(i,k) * psk(i) / prslk(i,k) - enddo - enddo -C - DO K = 1,KM-1 - DO I=1,IM - RDZT(I,K) = 1.0 / (ZL(I,K+1) - ZL(I,K)) -! RDZT(I,K) = GOR * PRSI(I,K+1) / (PRSL(I,K) - PRSL(I,K+1)) -! if (prsi(i,1) .gt. 60.0) then -! tem1 = max((prsi(i,k+1)-30.0)/(prsi(i,1)-30.0), 0.0) -! else -! tem1 = 0.0 -! endif -! xkzo(i,k) = xkzm * tem1 * tem1 -!! tem1 = (zi(i,k+1) - zi(i,1)) * 0.002 -!! xkzo(i,k) = xkzm * exp(-tem1) - ENDDO - ENDDO -C - DO I = 1,IM - DUSFC(I) = 0. - DVSFC(I) = 0. - DTSFC(I) = 0. - DQSFC(I) = 0. - HGAMT(I) = 0. - HGAMQ(I) = 0. - WSCALE(I) = 0. - KPBL(I) = 1 - HPBL(I) = ZI(I,2) - PBLFLG(I) = .TRUE. - SFCFLG(I) = .TRUE. - IF(RBSOIL(I).GT.0.0) SFCFLG(I) = .FALSE. - ENDDO -!! - DO I=1,IM -! RDZT1 = GOR * prSL(i,1) / DEL(i,1) -! BET1 = DT*RDZT1*SPD1(I)/T1(I,1) -! BETA(I) = DT*RDZT1/T1(I,1) - BETA(I) = DT / (zi(i,2)-zi(i,1)) -! BETAW(I) = BET1*CD(I) -! BETAT(I) = BET1*CH(I) -! BETAQ(I) = DPHI(I)*BETAT(I) - ENDDO -C - DO I=1,IM -! ZL1(i) = 0.-(T1(I,1)+TSEA(I))/2.*LOG(PRSL(I,1)/PRSI(I,1))*ROG -! USTAR(I) = SQRT(CD(I)*SPD1(I)**2) - USTAR(I) = SQRT(STRESS(I)) - ENDDO -C - DO I=1,IM - THESV(I) = TSEA(I)*(1.+FV*MAX(QSS(I),QMIN)) - THE1(I) = THETA(I,1) - THE1V(I) = THE1(I)*(1.+FV*MAX(Q1(I,1,1),QMIN)) - THERMAL(I) = THE1V(I) -! DTHE1 = (THE1(I)-TSEA(I)) -! DQ1 = (MAX(Q1(I,1,1),QMIN) - MAX(QSS(I),QMIN)) -! HEAT(I) = -CH(I)*SPD1(I)*DTHE1 -! EVAP(I) = -CH(I)*SPD1(I)*DQ1 - ENDDO -C -C -C COMPUTE THE FIRST GUESS OF PBL HEIGHT -C - DO I=1,IM - STABLE(I) = .FALSE. -! ZL(i,1) = ZL1(i) - RBUP(I) = RBSOIL(I) - ENDDO - DO K = 2, KMPBL - DO I = 1, IM - IF(.NOT.STABLE(I)) THEN - RBDN(I) = RBUP(I) -! ZL(I,k) = ZL(I,K-1) - (T1(i,k)+T1(i,K-1))/2 * -! & LOG(PRSL(I,K)/PRSL(I,K-1)) * ROG - THEKV(I) = THETA(i,k)*(1.+FV*MAX(Q1(i,k,1),QMIN)) - SPDK2 = MAX(RCL(i)*(U1(i,k)**2+V1(i,k)**2),1.) - RBUP(I) = (THEKV(I)-THE1V(I))*(G*ZL(I,k)/THE1V(I))/SPDK2 - KPBL(I) = K - STABLE(I) = RBUP(I).GT.RBCR - ENDIF - ENDDO - ENDDO -C - DO I = 1,IM - K = KPBL(I) - IF(RBDN(I).GE.RBCR) THEN - RBINT = 0. - ELSEIF(RBUP(I).LE.RBCR) THEN - RBINT = 1. - ELSE - RBINT = (RBCR-RBDN(I))/(RBUP(I)-RBDN(I)) - ENDIF - HPBL(I) = ZL(I,K-1) + RBINT*(ZL(I,K)-ZL(I,K-1)) - IF(HPBL(I).LT.ZI(I,KPBL(I))) KPBL(I) = KPBL(I) - 1 - ENDDO -!! - DO I=1,IM - HOL = MAX(RBSOIL(I)*FM(I)*FM(I)/FH(I),RIMIN) - IF(SFCFLG(I)) THEN - HOL = MIN(HOL,-ZFMIN) - ELSE - HOL = MAX(HOL,ZFMIN) - ENDIF -C -! HOL = HOL*HPBL(I)/ZL1(I)*SFCFRAC - HOL = HOL*HPBL(I)/ZL(I,1)*SFCFRAC - IF(SFCFLG(I)) THEN -! PHIM = (1.-APHI16*HOL)**(-1./4.) -! PHIH = (1.-APHI16*HOL)**(-1./2.) - TEM = 1.0 / (1. - APHI16*HOL) - PHIH(I) = SQRT(TEM) - PHIM(I) = SQRT(PHIH(I)) - ELSE - PHIM(I) = (1.+APHI5*HOL) - PHIH(I) = PHIM(I) - ENDIF - WSCALE(I) = USTAR(I)/PHIM(I) - WSCALE(I) = MIN(WSCALE(I),USTAR(I)*APHI16) - WSCALE(I) = MAX(WSCALE(I),USTAR(I)/APHI5) - ENDDO -C -C COMPUTE THE SURFACE VARIABLES FOR PBL HEIGHT ESTIMATION -C UNDER UNSTABLE CONDITIONS -C - DO I = 1,IM - SFLUX = HEAT(I) + EVAP(I)*FV*THE1(I) - IF(SFCFLG(I).AND.SFLUX.GT.0.0) THEN - HGAMT(I) = MIN(CFAC*HEAT(I)/WSCALE(I),GAMCRT) - HGAMQ(I) = MIN(CFAC*EVAP(I)/WSCALE(I),GAMCRQ) - VPERT = HGAMT(I) + FV*THE1(I)*HGAMQ(I) - VPERT = MIN(VPERT,GAMCRT) - THERMAL(I) = THERMAL(I) + MAX(VPERT,0.) - HGAMT(I) = MAX(HGAMT(I),0.0) - HGAMQ(I) = MAX(HGAMQ(I),0.0) - ELSE - PBLFLG(I) = .FALSE. - ENDIF - ENDDO -C - DO I = 1,IM - IF(PBLFLG(I)) THEN - KPBL(I) = 1 - HPBL(I) = ZI(I,2) - ENDIF - ENDDO -C -C ENHANCE THE PBL HEIGHT BY CONSIDERING THE THERMAL -C - DO I = 1, IM - IF(PBLFLG(I)) THEN - STABLE(I) = .FALSE. - RBUP(I) = RBSOIL(I) - ENDIF - ENDDO - DO K = 2, KMPBL - DO I = 1, IM - IF(.NOT.STABLE(I).AND.PBLFLG(I)) THEN - RBDN(I) = RBUP(I) -! ZL(I,k) = ZL(I,K-1) - (T1(i,k)+T1(i,K-1))/2 * -! & LOG(PRSL(I,K)/PRSL(I,K-1)) * ROG - THEKV(I) = THETA(i,k)*(1.+FV*MAX(Q1(i,k,1),QMIN)) - SPDK2 = MAX(RCL(i)*(U1(i,k)**2+V1(i,k)**2),1.) - RBUP(I) = (THEKV(I)-THERMAL(I))*(G*ZL(I,k)/THE1V(I))/SPDK2 - KPBL(I) = K - STABLE(I) = RBUP(I).GT.RBCR - ENDIF - ENDDO - ENDDO -C - DO I = 1,IM - IF(PBLFLG(I)) THEN - K = KPBL(I) - IF(RBDN(I).GE.RBCR) THEN - RBINT = 0. - ELSEIF(RBUP(I).LE.RBCR) THEN - RBINT = 1. - ELSE - RBINT = (RBCR-RBDN(I))/(RBUP(I)-RBDN(I)) - ENDIF - HPBL(I) = ZL(I,K-1) + RBINT*(ZL(I,k)-ZL(I,K-1)) - IF(HPBL(I).LT.ZI(I,KPBL(I))) KPBL(I) = KPBL(I) - 1 - IF(KPBL(I).LE.1) PBLFLG(I) = .FALSE. - ENDIF - ENDDO -!! -! DO K = 1,KM-1 -! DO I=1,IM -! if (rbsoil(i) .gt. 0.0 .or. (.not. pblflg(i))) then -! tem1 = max((prsi(i,k+1)-30.0)/(prsi(i,1)-30.0), 0.0) -! xkzo(i,k) = xkzm * tem1 * tem1 -!! tem1 = (zi(i,k+1) - zi(i,1)) * 0.002 -!! xkzo(i,k) = xkzm * exp(-tem1) -! else -! xkzo(i,k) = 0.0 -! -! if (pblflg(i)) then -! if (sfcflg(i)) then -! xkzo(i,k) = 0.0 -! else -! tem1 = (zi(i,k+1) - zi(i,1)) * 0.0005 -! tem1 = (100.0 - prsi(i,k+1)) * 0.075 -! tem1 = 100.0 - prsi(i,k+1) -! tem1 = max(0.0, 100.0 - prsi(i,k+1)) -! tem1 = tem1 * tem1 * 0.00075 -! tem1 = tem1 * tem1 * 0.001 -! tem1 = tem1 * tem1 * 0.0011 -! tem1 = tem1 * tem1 * 0.0012 -! -! tem1 = 1.0 - prsi(i,k+1) / prsi(i,1) -! tem1 = tem1 * tem1 * 5.0 -! tem1 = tem1 * tem1 * 7.5 -! tem1 = tem1 * tem1 * 10.0 -! tem1 = tem1 * tem1 * 12.0 -! -! xkzo(i,k) = xkzm * min(1.0, exp(-tem1)) -! if (xkzo(i,k) .lt. 0.01) xkzo(i,k) = 0.0 -! endif -! ENDDO -! ENDDO -! - DO K = 1,KM-1 - DO I=1,IM - tem1 = 1.0 - prsi(i,k+1) / prsi(i,1) - tem1 = tem1 * tem1 * 10.0 - xkzo(i,k) = xkzm * min(1.0, exp(-tem1)) - ENDDO - ENDDO -!! -C -C COMPUTE DIFFUSION COEFFICIENTS BELOW PBL -C - DO K = 1, KMPBL - DO I=1,IM - IF(KPBL(I).GT.K) THEN - PRINV = 1.0 / (PHIH(I)/PHIM(I)+CFAC*VK*.1) - PRINV = MIN(PRINV,PRMAX) - PRINV = MAX(PRINV,PRMIN) -! ZFAC = MAX((1.-(ZI(I,K+1)-ZL1(I))/ -! 1 (HPBL(I)-ZL1(I))), ZFMIN) - ZFAC = MAX((1.-(ZI(I,K+1)-ZL(I,1))/ - 1 (HPBL(I)-ZL(I,1))), ZFMIN) - DKU(i,k) = XKZO(i,k) + WSCALE(I)*VK*ZI(I,K+1) - 1 * ZFAC**PFAC - DKT(i,k) = DKU(i,k)*PRINV - DKU(i,k) = MIN(DKU(i,k),DKMAX) - DKU(i,k) = MAX(DKU(i,k),DKMIN) - DKT(i,k) = MIN(DKT(i,k),DKMAX) - DKT(i,k) = MAX(DKT(i,k),DKMIN) - ENDIF - ENDDO - ENDDO -C -C COMPUTE DIFFUSION COEFFICIENTS OVER PBL (FREE ATMOSPHERE) -C - DO K = 1, KM-1 - DO I=1,IM - IF(K.GE.KPBL(I)) THEN -! TI = 0.5*(T1(i,k)+T1(i,K+1)) - TI = 2.0 / (T1(i,k)+T1(i,K+1)) -! RDZ = RDZT(I,K)/TI -! RDZ = RDZT(I,K) * TI - RDZ = RDZT(I,K) - - DW2 = RCL(i)*((U1(i,k)-U1(i,K+1))**2 - & + (V1(i,k)-V1(i,K+1))**2) - SHR2 = MAX(DW2,DW2MIN)*RDZ*RDZ - TVD = T1(i,k)*(1.+FV*MAX(Q1(i,k,1),QMIN)) - TVU = T1(i,K+1)*(1.+FV*MAX(Q1(i,K+1,1),QMIN)) -! BVF2 = G*(GOCP+RDZ*(TVU-TVD))/TI - BVF2 = G*(GOCP+RDZ*(TVU-TVD)) * TI - RI = MAX(BVF2/SHR2,RIMIN) - ZK = VK*ZI(I,K+1) -! RL2 = (ZK*RLAM/(RLAM+ZK))**2 -! DK = RL2*SQRT(SHR2) -! RL2 = ZK*RLAM/(RLAM+ZK) -! DK = RL2*RL2*SQRT(SHR2) - IF(RI.LT.0.) THEN ! UNSTABLE REGIME - RL2 = ZK*RLAMUN/(RLAMUN+ZK) - DK = RL2*RL2*SQRT(SHR2) - SRI = SQRT(-RI) - DKU(i,k) = XKZO(i,k) + DK*(1+8.*(-RI)/(1+1.746*SRI)) - DKT(i,k) = XKZO(i,k) + DK*(1+8.*(-RI)/(1+1.286*SRI)) - ELSE ! STABLE REGIME - RL2 = ZK*RLAM/(RLAM+ZK) -! tem = rlam * sqrt(0.01*prsi(i,k)) -! RL2 = ZK*tem/(tem+ZK) - DK = RL2*RL2*SQRT(SHR2) - DKT(i,k) = XKZO(i,k) + DK/(1+5.*RI)**2 - PRNUM = 1.0 + 2.1*RI - PRNUM = MIN(PRNUM,PRMAX) - DKU(i,k) = (DKT(i,k)-XKZO(i,k))*PRNUM + XKZO(i,k) - ENDIF -C - DKU(i,k) = MIN(DKU(i,k),DKMAX) - DKU(i,k) = MAX(DKU(i,k),DKMIN) - DKT(i,k) = MIN(DKT(i,k),DKMAX) - DKT(i,k) = MAX(DKT(i,k),DKMIN) -C -! IF (I.EQ.IM) THEN -! PRNUM = DKU(i,k)/DKT(i,k) -! WRITE(*,610) K,PRNUM,DKT(i,k),DKU(i,k),RL2,RI,BVF2,SHR2 -! ENDIF -C - ENDIF - ENDDO - ENDDO -C -C COMPUTE TRIDIAGONAL MATRIX ELEMENTS FOR HEAT AND MOISTURE -C - DO I=1,IM - AD(I,1) = 1. - A1(I,1) = T1(i,1) + BETA(i) * HEAT(I) - A2(I,1) = Q1(i,1,1) + BETA(i) * EVAP(I) -! A1(I,1) = T1(i,1)-BETAT(I)*(THETA(i,1)-TSEA(I)) -! A2(I,1) = Q1(i,1,1)-BETAQ(I)* -! & (MAX(Q1(i,1,1),QMIN)-MAX(QSS(I),QMIN)) - ENDDO - if(ntrac.ge.2) then - do k = 2, ntrac - is = (k-1) * km - do i = 1, im - A2(I,1+is) = Q1(i,1,k) - enddo - enddo - endif -C - DO K = 1,KM-1 - DO I = 1,IM - DTODSD = DT/DEL(I,K) - DTODSU = DT/DEL(I,K+1) - DSIG = PRSL(I,K)-PRSL(I,K+1) -! RDZ = RDZT(I,K)*2./(T1(i,k)+T1(i,K+1)) - RDZ = RDZT(I,K) - tem1 = DSIG * DKT(i,k) * RDZ - IF(PBLFLG(I).AND.K.LT.KPBL(I)) THEN -! DSDZT = DSIG*DKT(i,k)*RDZ*(GOCP-HGAMT(I)/HPBL(I)) -! DSDZQ = DSIG*DKT(i,k)*RDZ*(-HGAMQ(I)/HPBL(I)) - tem = 1.0 / HPBL(I) - DSDZT = tem1 * (GOCP-HGAMT(I)*tem) - DSDZQ = tem1 * (-HGAMQ(I)*tem) - A2(I,k) = A2(I,k)+DTODSD*DSDZQ - A2(I,k+1) = Q1(i,k+1,1)-DTODSU*DSDZQ - ELSE -! DSDZT = DSIG*DKT(i,k)*RDZ*(GOCP) - DSDZT = tem1 * GOCP - A2(I,k+1) = Q1(i,k+1,1) - ENDIF -! DSDZ2 = DSIG*DKT(i,k)*RDZ*RDZ - DSDZ2 = tem1 * RDZ - AU(I,k) = -DTODSD*DSDZ2 - AL(I,k) = -DTODSU*DSDZ2 - AD(I,k) = AD(I,k)-AU(I,k) - AD(I,k+1) = 1.-AL(I,k) - A1(I,k) = A1(I,k)+DTODSD*DSDZT - A1(I,k+1) = T1(i,k+1)-DTODSU*DSDZT - ENDDO - ENDDO - if(ntrac.ge.2) then - do kk = 2, ntrac - is = (kk-1) * km - do k = 1, km - 1 - do i = 1, im - A2(I,k+1+is) = Q1(i,k+1,kk) - enddo - enddo - enddo - endif -C -C SOLVE TRIDIAGONAL PROBLEM FOR HEAT AND MOISTURE -C - CALL TRIDIN(IM,KM,ntrac,AL,AD,AU,A1,A2,AU,A1,A2) -C -C RECOVER TENDENCIES OF HEAT AND MOISTURE -C - DO K = 1,KM - DO I = 1,IM - TTEND = (A1(I,k)-T1(i,k))*RDT - QTEND = (A2(I,k)-Q1(i,k,1))*RDT - TAU(i,k) = TAU(i,k)+TTEND - RTG(I,k,1) = RTG(i,k,1)+QTEND - DTSFC(I) = DTSFC(I)+CONT*DEL(I,K)*TTEND - DQSFC(I) = DQSFC(I)+CONQ*DEL(I,K)*QTEND - ENDDO - ENDDO - if(ntrac.ge.2) then - do kk = 2, ntrac - is = (kk-1) * km - do k = 1, km - do i = 1, im - QTEND = (A2(I,K+is)-Q1(i,K,kk))*RDT - RTG(i,K,kk) = RTG(i,K,kk)+QTEND - enddo - enddo - enddo - endif -C -C COMPUTE TRIDIAGONAL MATRIX ELEMENTS FOR MOMENTUM -C - DO I=1,IM -! AD(I,1) = 1.+BETAW(I) - AD(I,1) = 1.0 + BETA(i) * STRESS(I) / SPD1(I) - A1(I,1) = U1(i,1) - A2(I,1) = V1(i,1) -! AD(I,1) = 1.0 -! tem = 1.0 + BETA(I) * STRESS(I) / SPD1(I) -! A1(I,1) = U1(i,1) * tem -! A2(I,1) = V1(i,1) * tem - ENDDO -C - DO K = 1,KM-1 - DO I=1,IM - DTODSD = DT/DEL(I,K) - DTODSU = DT/DEL(I,K+1) - DSIG = PRSL(I,K)-PRSL(I,K+1) -! RDZ = RDZT(I,K)*2./(T1(i,k)+T1(i,k+1)) - RDZ = RDZT(I,K) - DSDZ2 = DSIG*DKU(i,k)*RDZ*RDZ - AU(I,k) = -DTODSD*DSDZ2 - AL(I,k) = -DTODSU*DSDZ2 - AD(I,k) = AD(I,k)-AU(I,k) - AD(I,k+1) = 1.-AL(I,k) - A1(I,k+1) = U1(i,k+1) - A2(I,k+1) = V1(i,k+1) - ENDDO - ENDDO -C -C SOLVE TRIDIAGONAL PROBLEM FOR MOMENTUM -C - CALL TRIDI2(IM,KM,AL,AD,AU,A1,A2,AU,A1,A2) -C -C RECOVER TENDENCIES OF MOMENTUM -C - DO K = 1,KM - DO I = 1,IM - CONWRC = CONW*SQRT(RCL(i)) - UTEND = (A1(I,k)-U1(i,k))*RDT - VTEND = (A2(I,k)-V1(i,k))*RDT - DU(i,k) = DU(i,k)+UTEND - DV(i,k) = DV(i,k)+VTEND - DUSFC(I) = DUSFC(I)+CONWRC*DEL(I,K)*UTEND - DVSFC(I) = DVSFC(I)+CONWRC*DEL(I,K)*VTEND - ENDDO - ENDDO -!! - RETURN - END -CFPP$ NOCONCUR R -C----------------------------------------------------------------------- - SUBROUTINE TRIDI2(L,N,CL,CM,CU,R1,R2,AU,A1,A2) -csela %INCLUDE DBTRIDI2; -cc - USE MACHINE , ONLY : kind_phys - implicit none - integer k,n,l,i - real(kind=kind_phys) fk -cc - real(kind=kind_phys) CL(L,2:N),CM(L,N),CU(L,N-1),R1(L,N),R2(L,N), - & AU(L,N-1),A1(L,N),A2(L,N) -C----------------------------------------------------------------------- - DO I=1,L - FK = 1./CM(I,1) - AU(I,1) = FK*CU(I,1) - A1(I,1) = FK*R1(I,1) - A2(I,1) = FK*R2(I,1) - ENDDO - DO K=2,N-1 - DO I=1,L - FK = 1./(CM(I,K)-CL(I,K)*AU(I,K-1)) - AU(I,K) = FK*CU(I,K) - A1(I,K) = FK*(R1(I,K)-CL(I,K)*A1(I,K-1)) - A2(I,K) = FK*(R2(I,K)-CL(I,K)*A2(I,K-1)) - ENDDO - ENDDO - DO I=1,L - FK = 1./(CM(I,N)-CL(I,N)*AU(I,N-1)) - A1(I,N) = FK*(R1(I,N)-CL(I,N)*A1(I,N-1)) - A2(I,N) = FK*(R2(I,N)-CL(I,N)*A2(I,N-1)) - ENDDO - DO K=N-1,1,-1 - DO I=1,L - A1(I,K) = A1(I,K)-AU(I,K)*A1(I,K+1) - A2(I,K) = A2(I,K)-AU(I,K)*A2(I,K+1) - ENDDO - ENDDO -C----------------------------------------------------------------------- - RETURN - END -CFPP$ NOCONCUR R -C----------------------------------------------------------------------- - SUBROUTINE TRIDIN(L,N,nt,CL,CM,CU,R1,R2,AU,A1,A2) -csela %INCLUDE DBTRIDI2; -cc - USE MACHINE , ONLY : kind_phys - implicit none - integer is,k,kk,n,nt,l,i - real(kind=kind_phys) fk(L) -cc - real(kind=kind_phys) CL(L,2:N), CM(L,N), CU(L,N-1), - & R1(L,N), R2(L,N*nt), - & AU(L,N-1), A1(L,N), A2(L,N*nt), - & FKK(L,2:N-1) -C----------------------------------------------------------------------- - DO I=1,L - FK(I) = 1./CM(I,1) - AU(I,1) = FK(I)*CU(I,1) - A1(I,1) = FK(I)*R1(I,1) - ENDDO - do k = 1, nt - is = (k-1) * n - do i = 1, l - a2(i,1+is) = fk(I) * r2(i,1+is) - enddo - enddo - DO K=2,N-1 - DO I=1,L - FKK(I,K) = 1./(CM(I,K)-CL(I,K)*AU(I,K-1)) - AU(I,K) = FKK(I,K)*CU(I,K) - A1(I,K) = FKK(I,K)*(R1(I,K)-CL(I,K)*A1(I,K-1)) - ENDDO - ENDDO - do kk = 1, nt - is = (kk-1) * n - DO K=2,N-1 - DO I=1,L - A2(I,K+is) = FKK(I,K)*(R2(I,K+is)-CL(I,K)*A2(I,K+is-1)) - ENDDO - ENDDO - ENDDO - DO I=1,L - FK(I) = 1./(CM(I,N)-CL(I,N)*AU(I,N-1)) - A1(I,N) = FK(I)*(R1(I,N)-CL(I,N)*A1(I,N-1)) - ENDDO - do k = 1, nt - is = (k-1) * n - do i = 1, l - A2(I,N+is) = FK(I)*(R2(I,N+is)-CL(I,N)*A2(I,N+is-1)) - enddo - enddo - DO K=N-1,1,-1 - DO I=1,L - A1(I,K) = A1(I,K) - AU(I,K)*A1(I,K+1) - ENDDO - ENDDO - do kk = 1, nt - is = (kk-1) * n - DO K=n-1,1,-1 - DO I=1,L - A2(I,K+is) = A2(I,K+is) - AU(I,K)*A2(I,K+is+1) - ENDDO - ENDDO - ENDDO -C----------------------------------------------------------------------- - RETURN - END diff --git a/src/fim/FIMsrc/fim/column/moninq_v.f b/src/fim/FIMsrc/fim/column/moninq_v.f deleted file mode 100755 index ae7ae0e..0000000 --- a/src/fim/FIMsrc/fim/column/moninq_v.f +++ /dev/null @@ -1,864 +0,0 @@ -cfpp$ noconcur r - subroutine moninq(ix,im,km,ntrac,dv,du,tau,rtg, - & uo,vo,t1,q1,swh,hlw,xmu, - & psk,rbsoil,fm,fh,tsea,qss,heat,evap,stress,spd1,kpbl, - & prsi,del,prsl,prslk,phii,phil,rcs,deltim, - & dusfc,dvsfc,dtsfc,dqsfc,hpbl,hgamt,hgamq,dkt) -! - use machine , only : kind_phys - use funcphys , only : fpvs - use physcons, grav => con_g, rd => con_rd, cp => con_cp - &, hvap => con_hvap, fv => con_fvirt - implicit none -! -! include 'constant.h' -! -! -! arguments -! - integer ix, im, km, ntrac, kpbl(im), kpblx(im) -! - real(kind=kind_phys) deltim - real(kind=kind_phys) dv(im,km), du(im,km), - & tau(im,km), rtg(im,km,ntrac), - & uo(ix,km), vo(ix,km), - & t1(ix,km), q1(ix,km,ntrac), - & swh(ix,km), hlw(ix,km), - & xmu(im), - & psk(im), rbsoil(im), -! & cd(im), ch(im), - & fm(im), fh(im), - & tsea(im), qss(im), - & spd1(im), -! & dphi(im), spd1(im), - & prsi(ix,km+1), del(ix,km), - & prsl(ix,km), prslk(ix,km), - & phii(ix,km+1), phil(ix,km), - & rcs(im), dusfc(im), - & dvsfc(im), dtsfc(im), - & dqsfc(im), hpbl(im), hpblx(im), - & hgamt(im), hgamq(im) -! &, hgamu(im), hgamv(im), hgams(im) -! -! locals -! - integer i,iprt,is,iun,k,kk,km1,kmpbl,latd,lond - integer lcld(im),icld(im),kcld(im),krad(im) - integer kemx(im) -! -! real(kind=kind_phys) betaq(im), betat(im), betaw(im), - real(kind=kind_phys) evap(im), heat(im), phih(im), - & phim(im), rbdn(im), rbup(im), - & stress(im),beta(im), - & ustar(im), wscale(im), thermal(im), - & wstar3(im) -! - real(kind=kind_phys) thvx(im,km), thlvx(im,km), - & qlx(im,km), thetae(im,km), - & qtx(im,km), bf(im,km-1), - & u1(im,km), v1(im,km), radx(im,km-1), - & govrth(im), hrad(im), cteit(im), -! & hradm(im), radmin(im), vrad(im), - & radmin(im), vrad(im), - & zd(im), zdd(im), thlvx1(im) -! - real(kind=kind_phys) rdzt(im,km-1),dktx(im,km-1),dkux(im,km-1), - & zi(im,km+1), zl(im,km), xkzo(im,km), - & dku(im,km-1), dkt(im,km-1), - & cku(im,km-1), ckt(im,km-1), - & al(im,km-1), ad(im,km), - & au(im,km-1), a1(im,km), - & a2(im,km*ntrac), theta(im,km) -! -! real(kind=kind_phys) prinv(im), hpbl01(im), rent(im) - real(kind=kind_phys) prinv(im), rent(im) -! - logical pblflg(im), sfcflg(im), scuflg(im), flg(im) -! - real(kind=kind_phys) aphi16, aphi5, bvf2, wfac, - & cfac, conq, cont, conw, - & dk, dkmax, dkmin, - & dq1, dsdz2, dsdzq, dsdzt, - & dsdzu, dsdzv, sfac, - & dsig, dt, dthe1, dtodsd, - & dtodsu, dw2, dw2min, g, - & gamcrq, gamcrt, gocp, gor, gravi, - & hol, hol1, pfac, prmax, prmin, - & prnum, qmin, tdzmin, qtend, rbcr, - & rbint, rdt, rdz, qlmin, -! & rbint, rdt, rdz, rdzt1, - & ri, rimin, rl2, rlam, rlamun, - & rone, rzero, sfcfrac,sflux, - & shr2, spdk2, sri, - & tem, ti, ttend, tvd, - & tvu, utend, vk, vk2, - & vtend, zfac, vpert, cpert, - & rentf1, rentf2, radfac, - & zfmin, zk, tem1, tem2, - & xkzm, xkzmu, xkzminv, - & ptem, ptem1, ptem2 -! - real(kind=kind_phys) zstblmax,h1, h2, qlcr, actei, - & cldtime, u01, v01, delu, delv -cc - parameter(gravi=1.0/grav) - parameter(g=grav) - parameter(gor=g/rd,gocp=g/cp) - parameter(cont=1000.*cp/g,conq=1000.*hvap/g,conw=1000./g) - parameter(rlam=30.0,vk=0.4,vk2=vk*vk) - parameter(prmin=0.25,prmax=4.) - parameter(dw2min=0.0001,dkmin=0.0,dkmax=1000.,rimin=-100.) - parameter(rbcr=0.25,wfac=7.0,cfac=6.5,pfac=2.0,sfcfrac=0.1) - parameter(qmin=1.e-8,xkzm=1.0,zfmin=1.e-8,aphi5=5.,aphi16=16.) - parameter(tdzmin=1.e-3,qlmin=1.e-12,cpert=0.25,sfac=5.4) - parameter(h1=0.33333333,h2=0.66666667) - parameter(cldtime=500.,xkzmu=3.0,xkzminv=0.3) -! parameter(gamcrt=3.,gamcrq=2.e-3,rlamun=150.0) - parameter(gamcrt=3.,gamcrq=0.,rlamun=150.0) - parameter(rentf1=0.2,rentf2=1.0,radfac=0.85) - parameter(iun=84) -! -! parameter (zstblmax = 2500., qlcr=1.0e-5) -! parameter (zstblmax = 2500., qlcr=3.0e-5) -! parameter (zstblmax = 2500., qlcr=3.5e-5) -! parameter (zstblmax = 2500., qlcr=1.0e-4) - parameter (zstblmax = 2500., qlcr=3.5e-5) -! parameter (actei = 0.23) - parameter (actei = 0.7) -c -c----------------------------------------------------------------------- -c - 601 format(1x,' moninp lat lon step hour ',3i6,f6.1) - 602 format(1x,' k',' z',' t',' th', - 1 ' tvh',' q',' u',' v', - 2 ' sp') - 603 format(1x,i5,8f9.1) - 604 format(1x,' sfc',9x,f9.1,18x,f9.1) - 605 format(1x,' k zl spd2 thekv the1v' - 1 ,' thermal rbup') - 606 format(1x,i5,6f8.2) - 607 format(1x,' kpbl hpbl fm fh hgamt', - 1 ' hgamq ws ustar cd ch') - 608 format(1x,i5,9f8.2) - 609 format(1x,' k pr dkt dku ',i5,3f8.2) - 610 format(1x,' k pr dkt dku ',i5,3f8.2,' l2 ri t2', - 1 ' sr2 ',2f8.2,2e10.2) -c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -c compute preliminary variables -c - if (ix .lt. im) stop -! -! iprt = 0 -! if(iprt.eq.1) then -ccc latd = 0 -! lond = 0 -! else -ccc latd = 0 -! lond = 0 -! endif -c - dt = 2. * deltim - rdt = 1. / dt - km1 = km - 1 - kmpbl = km / 2 -! - do k=1,km - do i=1,im - zi(i,k) = phii(i,k) * gravi - zl(i,k) = phil(i,k) * gravi - u1(i,k) = uo(i,k) * rcs(i) - v1(i,k) = vo(i,k) * rcs(i) - enddo - enddo - do i=1,im - zi(i,km+1) = phii(i,km+1) * gravi - enddo -c - do k = 1,km1 - do i=1,im - rdzt(i,k) = 1.0 / (zl(i,k+1) - zl(i,k)) - enddo - enddo -c -c vertical background diffusivity -c - do k = 1,km1 - do i=1,im - tem1 = 1.0 - prsi(i,k+1) / prsi(i,1) - tem1 = tem1 * tem1 * 10.0 - xkzo(i,k) = xkzm * min(1.0, exp(-tem1)) - enddo - enddo -c -c diffusivity in the inversion layer is set to be xkzminv (m^2/s) -c - do k = 1,kmpbl - do i=1,im -! if(zi(i,k+1).gt.200..and.zi(i,k+1).lt.zstblmax) then - if(zi(i,k+1).gt.250.) then - tem1 = (t1(i,k+1)-t1(i,k)) * rdzt(i,k) - if(tem1 .gt. 1.e-5) then - xkzo(i,k) = min(xkzo(i,k),xkzminv) - endif - endif - enddo - enddo -c - do i = 1,im - dusfc(i) = 0. - dvsfc(i) = 0. - dtsfc(i) = 0. - dqsfc(i) = 0. - hgamt(i) = 0. - hgamq(i) = 0. -! hgamu(i) = 0. -! hgamv(i) = 0. -! hgams(i) = 0. - wscale(i)= 0. - kpbl(i) = 1 - kpblx(i) = 1 - hpbl(i) = zi(i,1) - hpblx(i) = zi(i,1) - pblflg(i)= .true. - sfcflg(i)= .true. - if(rbsoil(i).gt.0.0) sfcflg(i) = .false. - scuflg(i)= .true. - if(scuflg(i)) then - radmin(i)= 0. - cteit(i) = 0. - rent(i) = rentf1 - hrad(i) = zi(i,1) -! hradm(i) = zi(i,1) - krad(i) = 1 - icld(i) = 0 - lcld(i) = km1 - kcld(i) = km1 - zd(i) = 0. - endif - enddo -! - do k = 1,km - do i = 1,im - theta(i,k) = t1(i,k) * psk(i) / prslk(i,k) - qlx(i,k) = max(q1(i,k,ntrac),qlmin) - qtx(i,k) = max(q1(i,k,1),qmin)+qlx(i,k) - ptem = qlx(i,k) - ptem1 = hvap*max(q1(i,k,1),qmin)/(cp*t1(i,k)) - thetae(i,k)= theta(i,k)*(1.+ptem1) - thvx(i,k) = theta(i,k)*(1.+fv*max(q1(i,k,1),qmin)-ptem) - ptem2 = theta(i,k)-(hvap/cp)*ptem - thlvx(i,k) = ptem2*(1.+fv*qtx(i,k)) - enddo - enddo - do k = 1,km1 - do i = 1,im - dku(i,k) = 0. - dkt(i,k) = 0. - dktx(i,k) = 0. - dkux(i,k) = 0. - cku(i,k) = 0. - ckt(i,k) = 0. - tem = zi(i,k+1)-zi(i,k) - radx(i,k) = tem*(swh(i,k)*xmu(i)+hlw(i,k)) - enddo - enddo -c - do i=1,im - flg(i) = scuflg(i) - enddo - do k = 1, km1 - do i=1,im - if(flg(i).and.zl(i,k).ge.zstblmax) then - lcld(i)=k - flg(i)=.false. - endif - enddo - enddo -c -c compute buoyancy flux -c - do k = 1, km1 - do i = 1, im - bf(i,k) = (thvx(i,k+1)-thvx(i,k))*rdzt(i,k) - enddo - enddo -c - do i = 1,im - govrth(i) = g/theta(i,1) - enddo -c - do i=1,im - beta(i) = dt / (zi(i,2)-zi(i,1)) - enddo -c - do i=1,im - ustar(i) = sqrt(stress(i)) - thermal(i) = thvx(i,1) - enddo -c -c compute the first guess pbl height -c - do i=1,im - flg(i) = .false. - rbup(i) = rbsoil(i) - enddo - do k = 2, kmpbl - do i = 1, im - if(.not.flg(i)) then - rbdn(i) = rbup(i) - spdk2 = max((u1(i,k)**2+v1(i,k)**2),1.) - rbup(i) = (thvx(i,k)-thermal(i))* - & (g*zl(i,k)/thvx(i,1))/spdk2 - kpbl(i) = k - flg(i) = rbup(i).gt.rbcr - endif - enddo - enddo - do i = 1,im - k = kpbl(i) - if(rbdn(i).ge.rbcr) then - rbint = 0. - elseif(rbup(i).le.rbcr) then - rbint = 1. - else - rbint = (rbcr-rbdn(i))/(rbup(i)-rbdn(i)) - endif - hpbl(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1)) - if(hpbl(i).lt.zi(i,kpbl(i))) kpbl(i) = kpbl(i) - 1 - hpblx(i) = hpbl(i) - kpblx(i) = kpbl(i) - enddo -c -c compute similarity parameters -c - do i=1,im - sflux = heat(i) + evap(i)*fv*theta(i,1) - if(sfcflg(i).and.sflux.gt.0.) then - hol = max(rbsoil(i)*fm(i)*fm(i)/fh(i),rimin) - hol = min(hol,-zfmin) -c - hol1 = hol*hpbl(i)/zl(i,1)*sfcfrac -! phim(i) = (1.-aphi16*hol1)**(-1./4.) -! phih(i) = (1.-aphi16*hol1)**(-1./2.) - tem = 1.0 / (1. - aphi16*hol1) - phih(i) = sqrt(tem) - phim(i) = sqrt(phih(i)) - wstar3(i) = govrth(i)*sflux*hpbl(i) - tem1 = ustar(i)**3. - wscale(i) = (tem1+wfac*vk*wstar3(i)*sfcfrac)**h1 -! wscale(i) = ustar(i)/phim(i) - wscale(i) = min(wscale(i),ustar(i)*aphi16) - wscale(i) = max(wscale(i),ustar(i)/aphi5) - else - pblflg(i)=.false. - endif - enddo -c -c compute counter-gradient mixing term for heat and moisture -c - do i = 1,im - if(pblflg(i)) then - hgamt(i) = min(cfac*heat(i)/wscale(i),gamcrt) - hgamq(i) = min(cfac*evap(i)/wscale(i),gamcrq) - vpert = hgamt(i) + hgamq(i)*fv*theta(i,1) - vpert = min(vpert,gamcrt) - thermal(i)= thermal(i)+max(vpert,0.) - hgamt(i) = max(hgamt(i),0.0) - hgamq(i) = max(hgamq(i),0.0) - endif - enddo -c -c compute large-scale mixing term for momentum -c -! do i = 1,im -! flg(i) = pblflg(i) -! kemx(i)= 1 -! hpbl01(i)= sfcfrac*hpbl(i) -! enddo -! do k = 1, kmpbl -! do i = 1, im -! if(flg(i).and.zl(i,k).gt.hpbl01(i)) then -! kemx(i) = k -! flg(i) = .false. -! endif -! enddo -! enddo -! do i = 1, im -! if(pblflg(i)) then -! kk = kpbl(i) -! if(kemx(i).le.1) then -! ptem = u1(i,1)/zl(i,1) -! ptem1 = v1(i,1)/zl(i,1) -! u01 = ptem*hpbl01(i) -! v01 = ptem1*hpbl01(i) -! else -! tem = zl(i,kemx(i))-zl(i,kemx(i)-1) -! ptem = (u1(i,kemx(i))-u1(i,kemx(i)-1))/tem -! ptem1 = (v1(i,kemx(i))-v1(i,kemx(i)-1))/tem -! tem1 = hpbl01(i)-zl(i,kemx(i)-1) -! u01 = u1(i,kemx(i)-1)+ptem*tem1 -! v01 = v1(i,kemx(i)-1)+ptem1*tem1 -! endif -! if(kk.gt.kemx(i)) then -! delu = u1(i,kk)-u01 -! delv = v1(i,kk)-v01 -! tem2 = sqrt(delu**2+delv**2) -! tem2 = max(tem2,0.1) -! ptem2 = -sfac*ustar(i)*ustar(i)*wstar3(i) -! 1 /(wscale(i)**4.) -! hgamu(i) = ptem2*delu/tem2 -! hgamv(i) = ptem2*delv/tem2 -! tem = sqrt(u1(i,kk)**2+v1(i,kk)**2) -! tem1 = sqrt(u01**2+v01**2) -! ptem = tem - tem1 -! if(ptem.gt.0.) then -! hgams(i)=-sfac*vk*sfcfrac*wstar3(i)/(wscale(i)**3.) -! else -! hgams(i)=sfac*vk*sfcfrac*wstar3(i)/(wscale(i)**3.) -! endif -! else -! hgams(i) = 0. -! endif -! endif -! enddo -c -c enhance the pbl height by considering the thermal excess -c - do i=1,im - flg(i) = .true. - if(pblflg(i)) then - flg(i) = .false. - rbup(i) = rbsoil(i) - endif - enddo - do k = 2, kmpbl - do i = 1, im - if(.not.flg(i)) then - rbdn(i) = rbup(i) - spdk2 = max((u1(i,k)**2+v1(i,k)**2),1.) - rbup(i) = (thvx(i,k)-thermal(i))* - & (g*zl(i,k)/thvx(i,1))/spdk2 - kpbl(i) = k - flg(i) = rbup(i).gt.rbcr - endif - enddo - enddo - do i = 1,im - if(pblflg(i)) then - k = kpbl(i) - if(rbdn(i).ge.rbcr) then - rbint = 0. - elseif(rbup(i).le.rbcr) then - rbint = 1. - else - rbint = (rbcr-rbdn(i))/(rbup(i)-rbdn(i)) - endif - hpbl(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1)) - if(hpbl(i).lt.zi(i,kpbl(i))) kpbl(i) = kpbl(i) - 1 - if(kpbl(i).le.1) pblflg(i) = .false. - endif - enddo -c -c look for stratocumulus -c - do i = 1, im - flg(i)=scuflg(i) - enddo - do k = kmpbl,1,-1 - do i = 1, im - if(flg(i).and.k.le.lcld(i)) then - if(qlx(i,k).ge.qlcr) then - kcld(i)=k - flg(i)=.false. - endif - endif - enddo - enddo - do i = 1, im - if(scuflg(i).and.kcld(i).eq.km1) scuflg(i)=.false. - enddo -c - do i = 1, im - flg(i)=scuflg(i) - enddo - do k = kmpbl,1,-1 - do i = 1, im - if(flg(i).and.k.le.kcld(i)) then - if(qlx(i,k).ge.qlcr) then - if(radx(i,k).lt.radmin(i)) then - radmin(i)=radx(i,k) - krad(i)=k - endif - else - flg(i)=.false. - endif - endif - enddo - enddo - do i = 1, im - if(scuflg(i).and.krad(i).le.1) scuflg(i)=.false. - if(scuflg(i).and.radmin(i).ge.0.) scuflg(i)=.false. - enddo -c - do i = 1, im - flg(i)=scuflg(i) - enddo - do k = kmpbl,2,-1 - do i = 1, im - if(flg(i).and.k.le.krad(i)) then - if(qlx(i,k).ge.qlcr) then - icld(i)=icld(i)+1 - else - flg(i)=.false. - endif - endif - enddo - enddo - do i = 1, im - if(scuflg(i).and.icld(i).lt.1) scuflg(i)=.false. - enddo -c - do i = 1, im - if(scuflg(i)) then - hrad(i) = zi(i,krad(i)+1) -! hradm(i)= zl(i,krad(i)) - endif - enddo -c - do i = 1, im - if(scuflg(i).and.hrad(i).lt.zi(i,2)) scuflg(i)=.false. - enddo -c - do i = 1, im - if(scuflg(i)) then - k = krad(i) - tem = zi(i,k+1)-zi(i,k) - tem1 = cldtime*radmin(i)/tem - thlvx1(i) = thlvx(i,k)+tem1 -! if(thlvx1(i).gt.thlvx(i,k-1)) scuflg(i)=.false. - endif - enddo -c - do i = 1, im - flg(i)=scuflg(i) - enddo - do k = kmpbl,1,-1 - do i = 1, im - if(flg(i).and.k.le.krad(i))then - if(thlvx1(i).le.thlvx(i,k))then - tem=zi(i,k+1)-zi(i,k) - zd(i)=zd(i)+tem - else - flg(i)=.false. - endif - endif - enddo - enddo - do i = 1, im - if(scuflg(i))then - kk = max(1, krad(i)+1-icld(i)) - zdd(i) = hrad(i)-zi(i,kk) - endif - enddo - do i = 1, im - if(scuflg(i))then - zd(i) = max(zd(i),zdd(i)) - zd(i) = min(zd(i),hrad(i)) - tem = govrth(i)*zd(i)*(-radmin(i)) - vrad(i)= tem**h1 - endif - enddo -c -c compute inverse Prandtl number -c - do i = 1, im - if(pblflg(i)) then - tem = phih(i)/phim(i)+cfac*vk*sfcfrac -! prinv(i) = (1.0-hgams(i))/tem - prinv(i) = 1.0 / tem - prinv(i) = min(prinv(i),prmax) - prinv(i) = max(prinv(i),prmin) - endif - enddo -c -c compute diffusion coefficients below pbl -c - do k = 1, kmpbl - do i=1,im - if(pblflg(i).and.k.lt.kpbl(i)) then -! zfac = max((1.-(zi(i,k+1)-zl(i,1))/ -! 1 (hpbl(i)-zl(i,1))), zfmin) - zfac = max((1.-zi(i,k+1)/hpbl(i)), zfmin) - tem = wscale(i)*vk*zi(i,k+1)*zfac**pfac -! dku(i,k) = xkzo(i,k)+wscale(i)*vk*zi(i,k+1) -! 1 *zfac**pfac - dku(i,k) = xkzmu + tem - dkt(i,k) = xkzo(i,k) + tem * prinv(i) - dku(i,k) = min(dku(i,k),dkmax) -! dku(i,k) = max(dku(i,k),xkzmu) - dkt(i,k) = min(dkt(i,k),dkmax) -! dkt(i,k) = max(dkt(i,k),xkzo(i,k)) - dktx(i,k)= dkt(i,k) - dkux(i,k)= dku(i,k) - endif - enddo - enddo -c -c compute diffusion coefficients based on local scheme -c - do i = 1, im - if(.not.pblflg(i)) then - kpbl(i) = 1 - endif - enddo - do k = 1, km1 - do i=1,im - if(k.ge.kpbl(i)) then - rdz = rdzt(i,k) - ti = 2./(t1(i,k)+t1(i,k+1)) - dw2 = (u1(i,k)-u1(i,k+1))**2 - & +(v1(i,k)-v1(i,k+1))**2 - shr2 = max(dw2,dw2min)*rdz*rdz - bvf2 = g*bf(i,k)*ti - ri = max(bvf2/shr2,rimin) - zk = vk*zi(i,k+1) - if(ri.lt.0.) then ! unstable regime - rl2 = zk*rlamun/(rlamun+zk) - dk = rl2*rl2*sqrt(shr2) - sri = sqrt(-ri) - dku(i,k) = xkzmu + dk*(1+8.*(-ri)/(1+1.746*sri)) - dkt(i,k) = xkzo(i,k) + dk*(1+8.*(-ri)/(1+1.286*sri)) - else ! stable regime - rl2 = zk*rlam/(rlam+zk) -!! tem = rlam * sqrt(0.01*prsi(i,k)) -!! rl2 = zk*tem/(tem+zk) - dk = rl2*rl2*sqrt(shr2) - tem1 = dk/(1+5.*ri)**2 - if(k.ge.kpblx(i)) then - prnum = 1.0 + 2.1*ri - prnum = min(prnum,prmax) - else - prnum = 1.0 - endif - dkt(i,k) = xkzo(i,k) + tem1 - dku(i,k) = xkzmu + tem1 * prnum - endif -c - dku(i,k) = min(dku(i,k),dkmax) -! dku(i,k) = max(dku(i,k),xkzmu) - dkt(i,k) = min(dkt(i,k),dkmax) -! dkt(i,k) = max(dkt(i,k),xkzo(i,k)) -c - endif -c - enddo - enddo -c -c compute diffusion coefficients for cloud-top driven diffusion -c if the condition for cloud-top instability is met, -c increase entrainment flux at cloud top -c - do i = 1, im - if(scuflg(i)) then - k = krad(i) - tem = thetae(i,k) - thetae(i,k+1) - tem1 = qtx(i,k) - qtx(i,k+1) - if (tem.gt.0..and.tem1.gt.0.) then - cteit(i)= cp*tem/(hvap*tem1) - if(cteit(i).gt.actei) rent(i) = rentf2 - endif - endif - enddo - do i = 1, im - if(scuflg(i)) then - k = krad(i) - tem1 = max(bf(i,k),tdzmin) - ckt(i,k) = -rent(i)*radmin(i)/tem1 - cku(i,k) = ckt(i,k) - endif - enddo -c - do k = 1, kmpbl - do i=1,im - if(scuflg(i).and.k.lt.krad(i)) then - tem1=hrad(i)-zd(i) - tem2=zi(i,k+1)-tem1 - if(tem2.gt.0.) then - ptem= tem2/zd(i) - if(ptem.ge.1.) ptem= 1. - ptem= tem2*ptem*sqrt(1.-ptem) - ckt(i,k) = radfac*vk*vrad(i)*ptem - cku(i,k) = 0.75*ckt(i,k) - ckt(i,k) = max(ckt(i,k),dkmin) - ckt(i,k) = min(ckt(i,k),dkmax) - cku(i,k) = max(cku(i,k),dkmin) - cku(i,k) = min(cku(i,k),dkmax) - endif - endif - enddo - enddo -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! - do k = 1, kmpbl - do i=1,im - if(scuflg(i)) then - dkt(i,k) = dkt(i,k)+ckt(i,k) - dku(i,k) = dku(i,k)+cku(i,k) - dkt(i,k) = min(dkt(i,k),dkmax) - dku(i,k) = min(dku(i,k),dkmax) - endif - enddo - enddo -c -c compute tridiagonal matrix elements for heat and moisture -c - do i=1,im - ad(i,1) = 1. - a1(i,1) = t1(i,1) + beta(i) * heat(i) - a2(i,1) = q1(i,1,1) + beta(i) * evap(i) - enddo - if(ntrac.ge.2) then - do k = 2, ntrac - is = (k-1) * km - do i = 1, im - a2(i,1+is) = q1(i,1,k) - enddo - enddo - endif -c - do k = 1,km1 - do i = 1,im - dtodsd = dt/del(i,k) - dtodsu = dt/del(i,k+1) - dsig = prsl(i,k)-prsl(i,k+1) -! rdz = rdzt(i,k)*2./(t1(i,k)+t1(i,k+1)) - rdz = rdzt(i,k) - tem1 = dsig * dkt(i,k) * rdz - if(pblflg(i).and.k.lt.kpbl(i)) then -! dsdzt = dsig*dkt(i,k)*rdz*(gocp-hgamt(i)/hpbl(i)) -! dsdzq = dsig*dkt(i,k)*rdz*(-hgamq(i)/hpbl(i)) - ptem1 = dsig * dktx(i,k) * rdz - tem = 1.0 / hpbl(i) - dsdzt = tem1 * gocp - ptem1*hgamt(i)*tem - dsdzq = ptem1 * (-hgamq(i)*tem) - a2(i,k) = a2(i,k)+dtodsd*dsdzq - a2(i,k+1) = q1(i,k+1,1)-dtodsu*dsdzq - else -! dsdzt = dsig*dkt(i,k)*rdz*(gocp) - dsdzt = tem1 * gocp - a2(i,k+1) = q1(i,k+1,1) - endif -! dsdz2 = dsig*dkt(i,k)*rdz*rdz - dsdz2 = tem1 * rdz - au(i,k) = -dtodsd*dsdz2 - al(i,k) = -dtodsu*dsdz2 - ad(i,k) = ad(i,k)-au(i,k) - ad(i,k+1) = 1.-al(i,k) - a1(i,k) = a1(i,k)+dtodsd*dsdzt - a1(i,k+1) = t1(i,k+1)-dtodsu*dsdzt - enddo - enddo - if(ntrac.ge.2) then - do kk = 2, ntrac - is = (kk-1) * km - do k = 1, km1 - do i = 1, im - a2(i,k+1+is) = q1(i,k+1,kk) - enddo - enddo - enddo - endif -c -c solve tridiagonal problem for heat and moisture -c - call tridin(im,km,ntrac,al,ad,au,a1,a2,au,a1,a2) -c -c recover tendencies of heat and moisture -c - do k = 1,km - do i = 1,im - ttend = (a1(i,k)-t1(i,k))*rdt - qtend = (a2(i,k)-q1(i,k,1))*rdt - tau(i,k) = tau(i,k)+ttend - rtg(i,k,1) = rtg(i,k,1)+qtend - dtsfc(i) = dtsfc(i)+cont*del(i,k)*ttend - dqsfc(i) = dqsfc(i)+conq*del(i,k)*qtend - enddo - enddo - if(ntrac.ge.2) then - do kk = 2, ntrac - is = (kk-1) * km - do k = 1, km - do i = 1, im - qtend = (a2(i,k+is)-q1(i,k,kk))*rdt - rtg(i,k,kk) = rtg(i,k,kk)+qtend - enddo - enddo - enddo - endif -c -c compute tridiagonal matrix elements for momentum -c - do i=1,im - ad(i,1) = 1.0 + beta(i) * stress(i) / spd1(i) - a1(i,1) = u1(i,1) - a2(i,1) = v1(i,1) - enddo -c - do k = 1,km1 - do i=1,im - dtodsd = dt/del(i,k) - dtodsu = dt/del(i,k+1) - dsig = prsl(i,k)-prsl(i,k+1) - rdz = rdzt(i,k) - tem1 = dsig*dku(i,k)*rdz -! if(pblflg(i).and.k.lt.kpbl(i))then -! ptem1 = dsig*dkux(i,k)*rdz -! dsdzu = ptem1*(-hgamu(i)/hpbl(i)) -! dsdzv = ptem1*(-hgamv(i)/hpbl(i)) -! a1(i,k) = a1(i,k)+dtodsd*dsdzu -! a1(i,k+1) = u1(i,k+1)-dtodsu*dsdzu -! a2(i,k) = a2(i,k)+dtodsd*dsdzv -! a2(i,k+1) = v1(i,k+1)-dtodsu*dsdzv -! else - a1(i,k+1) = u1(i,k+1) - a2(i,k+1) = v1(i,k+1) -! endif -! dsdz2 = dsig*dku(i,k)*rdz*rdz - dsdz2 = tem1*rdz - au(i,k) = -dtodsd*dsdz2 - al(i,k) = -dtodsu*dsdz2 - ad(i,k) = ad(i,k)-au(i,k) - ad(i,k+1) = 1.-al(i,k) - enddo - enddo -c -c solve tridiagonal problem for momentum -c - call tridi2(im,km,al,ad,au,a1,a2,au,a1,a2) -c -c recover tendencies of momentum -c - do k = 1,km - do i = 1,im - ptem = 1./rcs(i) - utend = (a1(i,k)-u1(i,k))*rdt - vtend = (a2(i,k)-v1(i,k))*rdt - du(i,k) = du(i,k)+utend*ptem - dv(i,k) = dv(i,k)+vtend*ptem - dusfc(i) = dusfc(i)+conw*del(i,k)*utend - dvsfc(i) = dvsfc(i)+conw*del(i,k)*vtend - enddo - enddo -c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -c pbl height for diagnostic purpose -c - do i = 1, im - hpbl(i) = hpblx(i) - kpbl(i) = kpblx(i) - enddo -c -c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - return - end diff --git a/src/fim/FIMsrc/fim/column/mstadb_v.f b/src/fim/FIMsrc/fim/column/mstadb_v.f deleted file mode 100644 index 5e2896f..0000000 --- a/src/fim/FIMsrc/fim/column/mstadb_v.f +++ /dev/null @@ -1,81 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE MSTADBT3(IM,KM,K1,K2,PRSL,PRSLK,TENV,QENV, - & KLCL,KBOT,KTOP,TCLD,QCLD) -cyt INCLUDE DBMSTADB; -cc - USE MACHINE , ONLY : kind_phys - USE FUNCPHYS , ONLY : FTDP, FTHE, FTLCL, STMA - USE PHYSCONS, EPS => con_eps, EPSM1 => con_epsm1, FV => con_FVirt - implicit none -cc -! include 'constant.h' -cc - integer k,k1,k2,km,i,im - real(kind=kind_phys) pv,qma,slklcl,tdpd,thelcl,tlcl - real(kind=kind_phys) tma,tvcld,tvenv -cc - real(kind=kind_phys) PRSL(IM,KM), PRSLK(IM,KM), TENV(IM,KM), - & QENV(IM,KM), TCLD(IM,KM), QCLD(IM,KM) - INTEGER KLCL(IM), KBOT(IM), KTOP(IM) -C LOCAL ARRAYS - real(kind=kind_phys) SLKMA(IM), THEMA(IM) -C----------------------------------------------------------------------- -C DETERMINE WARMEST POTENTIAL WET-BULB TEMPERATURE BETWEEN K1 AND K2. -C COMPUTE ITS LIFTING CONDENSATION LEVEL. -! - DO I=1,IM - SLKMA(I) = 0. - THEMA(I) = 0. - ENDDO - DO K=K1,K2 - DO I=1,IM - PV = 1000.0 * PRSL(I,K)*QENV(I,K)/(EPS-EPSM1*QENV(I,K)) - TDPD = TENV(I,K)-FTDP(PV) - IF(TDPD.GT.0.) THEN - TLCL = FTLCL(TENV(I,K),TDPD) - SLKLCL = PRSLK(I,K)*TLCL/TENV(I,K) - ELSE - TLCL = TENV(I,K) - SLKLCL = PRSLK(I,K) - ENDIF - THELCL=FTHE(TLCL,SLKLCL) - IF(THELCL.GT.THEMA(I)) THEN - SLKMA(I) = SLKLCL - THEMA(I) = THELCL - ENDIF - ENDDO - ENDDO -C----------------------------------------------------------------------- -C SET CLOUD TEMPERATURES AND HUMIDITIES WHEREVER THE PARCEL LIFTED UP -C THE MOIST ADIABAT IS BUOYANT WITH RESPECT TO THE ENVIRONMENT. - DO I=1,IM - KLCL(I)=KM+1 - KBOT(I)=KM+1 - KTOP(I)=0 - ENDDO - DO K=1,KM - DO I=1,IM - TCLD(I,K)=0. - QCLD(I,K)=0. - ENDDO - ENDDO - DO K=K1,KM - DO I=1,IM - IF(PRSLK(I,K).LE.SLKMA(I)) THEN - KLCL(I)=MIN(KLCL(I),K) - CALL STMA(THEMA(I),PRSLK(I,K),TMA,QMA) -! TMA=FTMA(THEMA(I),PRSLK(I,K),QMA) - TVCLD=TMA*(1.+FV*QMA) - TVENV=TENV(I,K)*(1.+FV*QENV(I,K)) - IF(TVCLD.GT.TVENV) THEN - KBOT(I)=MIN(KBOT(I),K) - KTOP(I)=MAX(KTOP(I),K) - TCLD(I,K)=TMA-TENV(I,K) - QCLD(I,K)=QMA-QENV(I,K) - ENDIF - ENDIF - ENDDO - ENDDO -C----------------------------------------------------------------------- - RETURN - END diff --git a/src/fim/FIMsrc/fim/column/namelist_def.f b/src/fim/FIMsrc/fim/column/namelist_def.f deleted file mode 100644 index fe7455f..0000000 --- a/src/fim/FIMsrc/fim/column/namelist_def.f +++ /dev/null @@ -1,31 +0,0 @@ - module namelist_def - use machine - implicit none - save - integer nszer,nsres,nslwr,nsout,nsswr,nsdfi,nscyc,igen,jo3,ngptc - &, lsm,ens_mem,ncw(2),num_reduce,lsea,nsout_hf - real(kind=kind_evod) fhswr,fhlwr,fhrot,fhseg,fhmax,fhout,fhres, - & fhzer,fhini,fhdfi,fhcyc,filta,crtrh(3),flgmin(2),ref_temp,ccwf, - & ctei_rm,fhgoc3d,fhout_hf,fhmax_hf - logical ldiag3d,ras,zhao_mic,sashal,newsas,crick_proof,ccnorm - logical mom4ice,mstrat,trans_trac,lggfs3d,cal_pre - logical lsfwd,lssav,lscca,lsswr,lslwr - logical shuff_lats_a,shuff_lats_r,reshuff_lats_a,reshuff_lats_r - logical hybrid,gen_coord_hybrid,zflxtvd ! hmhj - logical run_enthalpy, out_virttemp ! hmhj - logical adiab,explicit,pre_rad,random_xkt2,old_monin,cnvgwd ! hmhj - logical restart, gfsio_in, gfsio_out - - logical nsst_active - logical nsst_restart - logical tr_analysis - - character*20 ens_nam -! -! Radiation control parameters -! - logical norad_precip - integer isol, ico2, ialb, iems, iaer, iovr_sw, iovr_lw, ictm -c jbao - parameter (ngptc = 1, gen_coord_hybrid=.false.) - end module namelist_def diff --git a/src/fim/FIMsrc/fim/column/namelist_soilveg.f b/src/fim/FIMsrc/fim/column/namelist_soilveg.f deleted file mode 100644 index 5766a44..0000000 --- a/src/fim/FIMsrc/fim/column/namelist_soilveg.f +++ /dev/null @@ -1,178 +0,0 @@ - module namelist_soilveg - implicit none - save - - INTEGER MAX_SLOPETYP - INTEGER MAX_SOILTYP - INTEGER MAX_VEGTYP - - PARAMETER(MAX_SLOPETYP = 30) - PARAMETER(MAX_SOILTYP = 30) - PARAMETER(MAX_VEGTYP = 30) - - REAL SLOPE_DATA(MAX_SLOPETYP) - REAL RSMTBL(MAX_VEGTYP) - REAL RGLTBL(MAX_VEGTYP) - REAL HSTBL(MAX_VEGTYP) - REAL SNUPX(MAX_VEGTYP) - REAL BB(MAX_SOILTYP) - REAL DRYSMC(MAX_SOILTYP) - REAL F11(MAX_SOILTYP) - REAL MAXSMC(MAX_SOILTYP) - REAL REFSMC(MAX_SOILTYP) - REAL SATPSI(MAX_SOILTYP) - REAL SATDK(MAX_SOILTYP) - REAL SATDW(MAX_SOILTYP) - REAL WLTSMC(MAX_SOILTYP) - REAL QTZ(MAX_SOILTYP) - LOGICAL LPARAM - REAL ZBOT_DATA - REAL SALP_DATA - REAL CFACTR_DATA - REAL CMCMAX_DATA - REAL SBETA_DATA - REAL RSMAX_DATA - REAL TOPT_DATA - REAL REFDK_DATA - REAL FRZK_DATA - INTEGER BARE - INTEGER DEFINED_VEG - INTEGER DEFINED_SOIL - INTEGER DEFINED_SLOPE - REAL FXEXP_DATA - INTEGER NROOT_DATA(MAX_VEGTYP) - REAL REFKDT_DATA - REAL Z0_DATA(MAX_VEGTYP) - REAL CZIL_DATA - REAL LAI_DATA(MAX_VEGTYP) - REAL CSOIL_DATA -! - parameter (DEFINED_VEG = 13, DEFINED_SOIL = 9,DEFINED_SLOPE = 9) - parameter (SBETA_DATA = -2.0, - >FXEXP_DATA = 2.0, - >CSOIL_DATA = 2.00E+6, - >SALP_DATA = 4.0, - >REFDK_DATA = 2.0E-6, - >REFKDT_DATA = 3.0, - >FRZK_DATA = 0.15, - >ZBOT_DATA = -8.0, - >CZIL_DATA = 0.075) - DATA SLOPE_DATA /0.1, 0.6, 1.0, 0.35, 0.55, 0.8, - & 0.63, 0.0, 0.0, 0.0, 0.0, 0.0, - & 0.0 , 0.0, 0.0, 0.0, 0.0, 0.0, - & 0.0 , 0.0, 0.0, 0.0, 0.0, 0.0, - & 0.0 , 0.0, 0.0, 0.0, 0.0, 0.0/ -! data ALBTBL /0.1500000,0.1900000,0.1500000,0.1700000, -! > 0.1900000,0.1900000,0.1900000,0.2500000, -! > 0.2300000,0.2000000,0.1200000,0.1100000, -! > 0.1100000,0.1000000,0.1200000,0.1900000, -! > 0.1200000,0.1200000,0.1200000,0.1600000, -! > 0.1600000,0.1600000,0.1700000,0.7000000, -! > 0.3000000,0.1600000,0.6000000,0.000000, -! > 0.000000, 0.000000/ - DATA Z0_DATA /2.653, 0.826, 0.563, 1.089, 0.854, 0.856, - & 0.035, 0.238, 0.065, 0.076, 0.011, 0.035, - & 0.011, 0.000, 0.000, 0.000, 0.000, 0.000, - & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, - & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/ -! data SHDFAC /0.1000000,0.8000000,0.8000000,0.8000000, -! > 0.8000000,0.8000000,0.8000000,0.7000000, -! > 0.7000000,0.5000000,0.8000000,0.7000000, -! > 0.9500000,0.7000000,0.8000000, 0.000000, -! > 0.6000000,0.6000000,9.9999998E-03, 0.6000000, -! > 0.6000000,0.6000000,0.3000000, 0.000000, -! > 0.5000000, 0.000000 ,0.000000 ,0.000000, -! > 0.000000, 0.000000/ - data NROOT_DATA /4,4,4,4,4,4,3,3,3,2,3,3,2,0,0, - & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/ - data RSMTBL /300.0, 175.0, 175.0, 300.0, 300.0, 70.0, - & 45.0, 225.0, 225.0, 225.0, 400.0, 45.0, - & 150.0, 0.0, 0.0, 0.0, 0.0, 0.0, - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/ - data RGLTBL /30.0, 30.0, 30.0, 30.0, 30.0, 65.0, - & 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, - & 100.0, 0.0, 0.0, 0.0, 0.0, 0.0, - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/ - data HSTBL /41.69, 54.53, 51.93, 47.35, 47.35, 54.53, - & 36.35, 42.00, 42.00, 42.00, 42.00, 36.35, - & 42.00, 0.00, 0.00, 0.00, 0.00, 0.00, - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00/ - data SNUPX /0.040, 0.040, 0.040, 0.040, 0.040, 0.040, - * 0.020, 0.020, 0.020, 0.020, 0.013, 0.020, - * 0.013, 0.000, 0.000, 0.000, 0.000, 0.000, - & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, - & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/ - data LAI_DATA /3.0, 3.0, 3.0, 3.0, 3.0, 3.0, - & 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, - & 3.0, 0.0, 0.0, 0.0, 0.0, 0.0, - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/ -! data MAXALB /40.00000, 64.00000, 64.00000, 64.00000, -! > 64.00000, 60.00000, 64.00000, 69.00000, -! > 67.00000, 45.00000, 58.00000, 54.00000, -! > 32.00000, 52.00000, 53.00000, 70.00000, -! > 35.00000, 30.00000, 69.00000, 58.00000, -! > 55.00000, 55.00000, 65.00000, 75.00000, -! > 69.00000, 69.00000, 69.00000, 0.000000, -! > 0.000000, 0.000000/ - parameter (TOPT_DATA = 298.0, CMCMAX_DATA = 0.5E-3, - > CFACTR_DATA = 0.5, RSMAX_DATA = 5000.0, - > BARE = 11) - data bb /4.26, 8.72, 11.55, 4.74, 10.73, 8.17, - & 6.77, 5.25, 4.26, 0.00, 0.00, 0.00, - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00/ - data drysmc /0.029, 0.119, 0.139, 0.047, 0.100, 0.103, - & 0.069, 0.066, 0.029, 0.000, 0.000, 0.000, - & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, - & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, - & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/ - data f11 /-0.999, -1.116, -2.137, -0.572, -3.201, -1.302, - & -1.519, -0.329, -0.999, 0.000, 0.000, 0.000, - & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, - & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, - & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/ - data MAXSMC /0.421, 0.464, 0.468, 0.434, 0.406, 0.465, - & 0.404, 0.439, 0.421, 0.000, 0.000, 0.000, - & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, - & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, - & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/ - data REFSMC /0.248, 0.368, 0.398, 0.281, 0.321, 0.361, - & 0.293, 0.301, 0.248, 0.000, 0.000, 0.000, - & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, - & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, - & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/ - data SATPSI /0.04, 0.62, 0.47, 0.14, 0.10, 0.26, - & 0.14, 0.36, 0.04, 0.00, 0.00, 0.00, - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00/ - data SATDK /1.41E-5, 0.20E-5, 0.10E-5, 0.52E-5, 0.72E-5, - & 0.25E-5, 0.45E-5, 0.34E-5, 1.41E-5, 0.00, - & 0.00 , 0.00 , 0.00 , 0.00 , 0.00, - & 0.00 , 0.00 , 0.00 , 0.00 , 0.00, - & 0.00 , 0.00 , 0.00 , 0.00 , 0.00, - & 0.00 , 0.00 , 0.00 , 0.00 , 0.00/ - data SATDW /5.71E-6, 2.33E-5, 1.16E-5, 7.95E-6, 1.90E-5, - & 1.14E-5, 1.06E-5, 1.46E-5, 5.71E-6, 0.00, - & 0.00 , 0.00 , 0.00 , 0.00 , 0.00, - & 0.00 , 0.00 , 0.00 , 0.00 , 0.00, - & 0.00 , 0.00 , 0.00 , 0.00 , 0.00, - & 0.00 , 0.00 , 0.00 , 0.00 , 0.00/ - data WLTSMC /0.029, 0.119, 0.139, 0.047, 0.100, 0.103, - & 0.069, 0.066, 0.029, 0.000, 0.000, 0.000, - & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, - & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, - & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/ - data QTZ /0.82, 0.10, 0.25, 0.60, 0.52, 0.35, - & 0.60, 0.40, 0.82, 0.00, 0.00, 0.00, - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00/ - -! - end module namelist_soilveg diff --git a/src/fim/FIMsrc/fim/column/noblas.f b/src/fim/FIMsrc/fim/column/noblas.f deleted file mode 100644 index 0f6adcd..0000000 --- a/src/fim/FIMsrc/fim/column/noblas.f +++ /dev/null @@ -1,3489 +0,0 @@ - SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 TRANSA, TRANSB - INTEGER M, N, K, LDA, LDB, LDC - REAL ALPHA, BETA -* .. Array Arguments .. - REAL A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* DGEMM performs one of the matrix-matrix operations -* -* C := alpha*op( A )*op( B ) + beta*C, -* -* where op( X ) is one of -* -* op( X ) = X or op( X ) = X', -* -* alpha and beta are scalars, and A, B and C are matrices, with op( A ) -* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. -* -* Parameters -* ========== -* -* TRANSA - CHARACTER*1. -* On entry, TRANSA specifies the form of op( A ) to be used in -* the matrix multiplication as follows: -* -* TRANSA = 'N' or 'n', op( A ) = A. -* -* TRANSA = 'T' or 't', op( A ) = A'. -* -* TRANSA = 'C' or 'c', op( A ) = A'. -* -* Unchanged on exit. -* -* TRANSB - CHARACTER*1. -* On entry, TRANSB specifies the form of op( B ) to be used in -* the matrix multiplication as follows: -* -* TRANSB = 'N' or 'n', op( B ) = B. -* -* TRANSB = 'T' or 't', op( B ) = B'. -* -* TRANSB = 'C' or 'c', op( B ) = B'. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix -* op( A ) and of the matrix C. M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix -* op( B ) and the number of columns of the matrix C. N must be -* at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry, K specifies the number of columns of the matrix -* op( A ) and the number of rows of the matrix op( B ). K must -* be at least zero. -* Unchanged on exit. -* -* ALPHA - REAL . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - REAL array of DIMENSION ( LDA, ka ), where ka is -* k when TRANSA = 'N' or 'n', and is m otherwise. -* Before entry with TRANSA = 'N' or 'n', the leading m by k -* part of the array A must contain the matrix A, otherwise -* the leading k by m part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANSA = 'N' or 'n' then -* LDA must be at least max( 1, m ), otherwise LDA must be at -* least max( 1, k ). -* Unchanged on exit. -* -* B - REAL array of DIMENSION ( LDB, kb ), where kb is -* n when TRANSB = 'N' or 'n', and is k otherwise. -* Before entry with TRANSB = 'N' or 'n', the leading k by n -* part of the array B must contain the matrix B, otherwise -* the leading n by k part of the array B must contain the -* matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. When TRANSB = 'N' or 'n' then -* LDB must be at least max( 1, k ), otherwise LDB must be at -* least max( 1, n ). -* Unchanged on exit. -* -* BETA - REAL . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then C need not be set on input. -* Unchanged on exit. -* -* C - REAL array of DIMENSION ( LDC, n ). -* Before entry, the leading m by n part of the array C must -* contain the matrix C, except when beta is zero, in which -* case C need not be set on entry. -* On exit, the array C is overwritten by the m by n matrix -* ( alpha*op( A )*op( B ) + beta*C ). -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL NOTA, NOTB - INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB - REAL TEMP -* .. Parameters .. - REAL ONE , ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -* .. -* .. Executable Statements .. -* -* Set NOTA and NOTB as true if A and B respectively are not -* transposed and set NROWA, NCOLA and NROWB as the number of rows -* and columns of A and the number of rows of B respectively. -* - NOTA = LSAME( TRANSA, 'N' ) - NOTB = LSAME( TRANSB, 'N' ) - IF( NOTA )THEN - NROWA = M - NCOLA = K - ELSE - NROWA = K - NCOLA = M - END IF - IF( NOTB )THEN - NROWB = K - ELSE - NROWB = N - END IF -* -* Test the input parameters. -* - INFO = 0 - IF( ( .NOT.NOTA ).AND. - $ ( .NOT.LSAME( TRANSA, 'C' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.NOTB ).AND. - $ ( .NOT.LSAME( TRANSB, 'C' ) ).AND. - $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN - INFO = 2 - ELSE IF( M .LT.0 )THEN - INFO = 3 - ELSE IF( N .LT.0 )THEN - INFO = 4 - ELSE IF( K .LT.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 8 - ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN - INFO = 10 - ELSE IF( LDC.LT.MAX( 1, M ) )THEN - INFO = 13 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DGEMM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And if alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, M - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - RETURN - END IF -* -* Start the operations. -* - IF( NOTB )THEN - IF( NOTA )THEN -* -* Form C := alpha*A*B + beta*C. -* - DO 90, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 50, I = 1, M - C( I, J ) = ZERO - 50 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 60, I = 1, M - C( I, J ) = BETA*C( I, J ) - 60 CONTINUE - END IF - DO 80, L = 1, K - IF( B( L, J ).NE.ZERO )THEN - TEMP = ALPHA*B( L, J ) - DO 70, I = 1, M - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 70 CONTINUE - END IF - 80 CONTINUE - 90 CONTINUE - ELSE -* -* Form C := alpha*A'*B + beta*C -* - DO 120, J = 1, N - DO 110, I = 1, M - TEMP = ZERO - DO 100, L = 1, K - TEMP = TEMP + A( L, I )*B( L, J ) - 100 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 110 CONTINUE - 120 CONTINUE - END IF - ELSE - IF( NOTA )THEN -* -* Form C := alpha*A*B' + beta*C -* - DO 170, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 130, I = 1, M - C( I, J ) = ZERO - 130 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 140, I = 1, M - C( I, J ) = BETA*C( I, J ) - 140 CONTINUE - END IF - DO 160, L = 1, K - IF( B( J, L ).NE.ZERO )THEN - TEMP = ALPHA*B( J, L ) - DO 150, I = 1, M - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 150 CONTINUE - END IF - 160 CONTINUE - 170 CONTINUE - ELSE -* -* Form C := alpha*A'*B' + beta*C -* - DO 200, J = 1, N - DO 190, I = 1, M - TEMP = ZERO - DO 180, L = 1, K - TEMP = TEMP + A( L, I )*B( J, L ) - 180 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 190 CONTINUE - 200 CONTINUE - END IF - END IF -* - RETURN -* -* End of DGEMM . -* - END - SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - REAL A( LDA, * ), WORK( LWORK ) -* .. -* -* Purpose -* ======= -* -* DGETRI computes the inverse of a matrix using the LU factorization -* computed by DGETRF. -* -* This method inverts U and then computes inv(A) by solving the system -* inv(A)*L = inv(U) for inv(A). -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) REAL array, dimension (LDA,N) -* On entry, the factors L and U from the factorization -* A = P*L*U as computed by DGETRF. -* On exit, if INFO = 0, the inverse of the original matrix A. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* IPIV (input) INTEGER array, dimension (N) -* The pivot indices from DGETRF; for 1<=i<=N, row i of the -* matrix was interchanged with row IPIV(i). -* -* WORK (workspace/output) REAL array, dimension (LWORK) -* On exit, if INFO=0, then WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,N). -* For optimal performance LWORK >= N*NB, where NB is -* the optimal blocksize returned by ILAENV. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) is exactly zero; the matrix is -* singular and its inverse could not be computed. -* -* ===================================================================== -* -* .. Parameters .. - REAL ZERO, ONE - PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) -* .. -* .. Local Scalars .. - INTEGER I, IWS, J, JB, JJ, JP, LDWORK, NB, NBMIN, NN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DGEMV, DSWAP, DTRSM, DTRTRI, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - WORK( 1 ) = MAX( N, 1 ) - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -3 - ELSE IF( LWORK.LT.MAX( 1, N ) ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETRI', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Form inv(U). If INFO > 0 from DTRTRI, then U is singular, -* and the inverse is not computed. -* - CALL DTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO ) - IF( INFO.GT.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'DGETRI', ' ', N, -1, -1, -1 ) - NBMIN = 2 - LDWORK = N - IF( NB.GT.1 .AND. NB.LT.N ) THEN - IWS = MAX( LDWORK*NB, 1 ) - IF( LWORK.LT.IWS ) THEN - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DGETRI', ' ', N, -1, -1, -1 ) ) - END IF - ELSE - IWS = N - END IF -* -* Solve the equation inv(A)*L = inv(U) for inv(A). -* - IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN -* -* Use unblocked code. -* - DO 20 J = N, 1, -1 -* -* Copy current column of L to WORK and replace with zeros. -* - DO 10 I = J + 1, N - WORK( I ) = A( I, J ) - A( I, J ) = ZERO - 10 CONTINUE -* -* Compute current column of inv(A). -* - IF( J.LT.N ) - $ CALL DGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ), - $ LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 ) - 20 CONTINUE - ELSE -* -* Use blocked code. -* - NN = ( ( N-1 ) / NB )*NB + 1 - DO 50 J = NN, 1, -NB - JB = MIN( NB, N-J+1 ) -* -* Copy current block column of L to WORK and replace with -* zeros. -* - DO 40 JJ = J, J + JB - 1 - DO 30 I = JJ + 1, N - WORK( I+( JJ-J )*LDWORK ) = A( I, JJ ) - A( I, JJ ) = ZERO - 30 CONTINUE - 40 CONTINUE -* -* Compute current block column of inv(A). -* - IF( J+JB.LE.N ) - $ CALL DGEMM( 'No transpose', 'No transpose', N, JB, - $ N-J-JB+1, -ONE, A( 1, J+JB ), LDA, - $ WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA ) - CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB, - $ ONE, WORK( J ), LDWORK, A( 1, J ), LDA ) - 50 CONTINUE - END IF -* -* Apply column interchanges. -* - DO 60 J = N - 1, 1, -1 - JP = IPIV( J ) - IF( JP.NE.J ) - $ CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 ) - 60 CONTINUE -* - WORK( 1 ) = IWS - RETURN -* -* End of DGETRI -* - END - SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - REAL A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DGETRF computes an LU factorization of a general M-by-N matrix A -* using partial pivoting with row interchanges. -* -* The factorization has the form -* A = P * L * U -* where P is a permutation matrix, L is lower triangular with unit -* diagonal elements (lower trapezoidal if m > n), and U is upper -* triangular (upper trapezoidal if m < n). -* -* This is the right-looking Level 3 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) REAL array, dimension (LDA,N) -* On entry, the M-by-N matrix to be factored. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* ===================================================================== -* -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. -* .. Local Scalars .. - INTEGER I, IINFO, J, JB, NB -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DGETF2, DLASWP, DTRSM, XERBLA -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 ) - IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN -* -* Use unblocked code. -* - CALL DGETF2( M, N, A, LDA, IPIV, INFO ) - ELSE -* -* Use blocked code. -* - DO 20 J = 1, MIN( M, N ), NB - JB = MIN( MIN( M, N )-J+1, NB ) -* -* Factor diagonal and subdiagonal blocks and test for exact -* singularity. -* - CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) -* -* Adjust INFO and the pivot indices. -* - IF( INFO.EQ.0 .AND. IINFO.GT.0 ) - $ INFO = IINFO + J - 1 - DO 10 I = J, MIN( M, J+JB-1 ) - IPIV( I ) = J - 1 + IPIV( I ) - 10 CONTINUE -* -* Apply interchanges to columns 1:J-1. -* - CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) -* - IF( J+JB.LE.N ) THEN -* -* Apply interchanges to columns J+JB:N. -* - CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, - $ IPIV, 1 ) -* -* Compute block row of U. -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, - $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), - $ LDA ) - IF( J+JB.LE.M ) THEN -* -* Update trailing submatrix. -* - CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1, - $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, - $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), - $ LDA ) - END IF - END IF - 20 CONTINUE - END IF - RETURN -* -* End of DGETRF -* - END - SUBROUTINE XERBLA( SRNAME, INFO ) -* -* -- LAPACK auxiliary routine (preliminary version) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER*6 SRNAME - INTEGER INFO -* .. -* -* Purpose -* ======= -* -* XERBLA is an error handler for the LAPACK routines. -* It is called by an LAPACK routine if an input parameter has an -* invalid value. A message is printed and execution stops. -* -* Installers may consider modifying the STOP statement in order to -* call system-specific exception-handling facilities. -* -* Arguments -* ========= -* -* SRNAME (input) CHARACTER*6 -* The name of the routine which called XERBLA. -* -* INFO (input) INTEGER -* The position of the invalid parameter in the parameter list -* of the calling routine. -* -* - WRITE( *, FMT = 9999 )SRNAME, INFO -* - STOP -* - 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', - $ 'an illegal value' ) -* -* End of XERBLA -* - END - SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - CHARACTER DIAG, UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - REAL A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DTRTRI computes the inverse of a real upper or lower triangular -* matrix A. -* -* This is the Level 3 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': A is upper triangular; -* = 'L': A is lower triangular. -* -* DIAG (input) CHARACTER*1 -* = 'N': A is non-unit triangular; -* = 'U': A is unit triangular. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) REAL array, dimension (LDA,N) -* On entry, the triangular matrix A. If UPLO = 'U', the -* leading N-by-N upper triangular part of the array A contains -* the upper triangular matrix, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading N-by-N lower triangular part of the array A contains -* the lower triangular matrix, and the strictly upper -* triangular part of A is not referenced. If DIAG = 'U', the -* diagonal elements of A are also not referenced and are -* assumed to be 1. -* On exit, the (triangular) inverse of the original matrix, in -* the same storage format. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, A(i,i) is exactly zero. The triangular -* matrix is singular and its inverse can not be computed. -* -* ===================================================================== -* -* .. Parameters .. - REAL ONE, ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOUNIT, UPPER - INTEGER J, JB, NB, NN -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DTRMM, DTRSM, DTRTI2, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - NOUNIT = LSAME( DIAG, 'N' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DTRTRI', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Check for singularity if non-unit. -* - IF( NOUNIT ) THEN - DO 10 INFO = 1, N - IF( A( INFO, INFO ).EQ.ZERO ) - $ RETURN - 10 CONTINUE - INFO = 0 - END IF -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'DTRTRI', UPLO // DIAG, N, -1, -1, -1 ) - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code -* - CALL DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) - ELSE -* -* Use blocked code -* - IF( UPPER ) THEN -* -* Compute inverse of upper triangular matrix -* - DO 20 J = 1, N, NB - JB = MIN( NB, N-J+1 ) -* -* Compute rows 1:j-1 of current block column -* - CALL DTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1, - $ JB, ONE, A, LDA, A( 1, J ), LDA ) - CALL DTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1, - $ JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA ) -* -* Compute inverse of current diagonal block -* - CALL DTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO ) - 20 CONTINUE - ELSE -* -* Compute inverse of lower triangular matrix -* - NN = ( ( N-1 ) / NB )*NB + 1 - DO 30 J = NN, 1, -NB - JB = MIN( NB, N-J+1 ) - IF( J+JB.LE.N ) THEN -* -* Compute rows j+jb:n of current block column -* - CALL DTRMM( 'Left', 'Lower', 'No transpose', DIAG, - $ N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA, - $ A( J+JB, J ), LDA ) - CALL DTRSM( 'Right', 'Lower', 'No transpose', DIAG, - $ N-J-JB+1, JB, -ONE, A( J, J ), LDA, - $ A( J+JB, J ), LDA ) - END IF -* -* Compute inverse of current diagonal block -* - CALL DTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO ) - 30 CONTINUE - END IF - END IF -* - RETURN -* -* End of DTRTRI -* - END - SUBROUTINE DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - REAL ALPHA, BETA - INTEGER INCX, INCY, LDA, M, N - CHARACTER*1 TRANS -* .. Array Arguments .. - REAL A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DGEMV performs one of the matrix-vector operations -* -* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, -* -* where alpha and beta are scalars, x and y are vectors and A is an -* m by n matrix. -* -* Parameters -* ========== -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. -* -* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. -* -* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - REAL . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - REAL array of DIMENSION ( LDA, n ). -* Before entry, the leading m by n part of the array A must -* contain the matrix of coefficients. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, m ). -* Unchanged on exit. -* -* X - REAL array of DIMENSION at least -* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. -* Before entry, the incremented array X must contain the -* vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - REAL . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - REAL array of DIMENSION at least -* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. -* Before entry with BETA non-zero, the incremented array Y -* must contain the vector y. On exit, Y is overwritten by the -* updated vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - REAL ONE , ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -* .. Local Scalars .. - REAL TEMP - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 1 - ELSE IF( M.LT.0 )THEN - INFO = 2 - ELSE IF( N.LT.0 )THEN - INFO = 3 - ELSE IF( LDA.LT.MAX( 1, M ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - ELSE IF( INCY.EQ.0 )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DGEMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set LENX and LENY, the lengths of the vectors x and y, and set -* up the start points in X and Y. -* - IF( LSAME( TRANS, 'N' ) )THEN - LENX = N - LENY = M - ELSE - LENX = M - LENY = N - END IF - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( LENX - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( LENY - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, LENY - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, LENY - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, LENY - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, LENY - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form y := alpha*A*x + y. -* - JX = KX - IF( INCY.EQ.1 )THEN - DO 60, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - DO 50, I = 1, M - Y( I ) = Y( I ) + TEMP*A( I, J ) - 50 CONTINUE - END IF - JX = JX + INCX - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IY = KY - DO 70, I = 1, M - Y( IY ) = Y( IY ) + TEMP*A( I, J ) - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - ELSE -* -* Form y := alpha*A'*x + y. -* - JY = KY - IF( INCX.EQ.1 )THEN - DO 100, J = 1, N - TEMP = ZERO - DO 90, I = 1, M - TEMP = TEMP + A( I, J )*X( I ) - 90 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 100 CONTINUE - ELSE - DO 120, J = 1, N - TEMP = ZERO - IX = KX - DO 110, I = 1, M - TEMP = TEMP + A( I, J )*X( IX ) - IX = IX + INCX - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of DGEMV . -* - END - SUBROUTINE DTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, - $ B, LDB ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO, TRANSA, DIAG - INTEGER M, N, LDA, LDB - REAL ALPHA -* .. Array Arguments .. - REAL A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DTRSM solves one of the matrix equations -* -* op( A )*X = alpha*B, or X*op( A ) = alpha*B, -* -* where alpha is a scalar, X and B are m by n matrices, A is a unit, or -* non-unit, upper or lower triangular matrix and op( A ) is one of -* -* op( A ) = A or op( A ) = A'. -* -* The matrix X is overwritten on B. -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether op( A ) appears on the left -* or right of X as follows: -* -* SIDE = 'L' or 'l' op( A )*X = alpha*B. -* -* SIDE = 'R' or 'r' X*op( A ) = alpha*B. -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix A is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANSA - CHARACTER*1. -* On entry, TRANSA specifies the form of op( A ) to be used in -* the matrix multiplication as follows: -* -* TRANSA = 'N' or 'n' op( A ) = A. -* -* TRANSA = 'T' or 't' op( A ) = A'. -* -* TRANSA = 'C' or 'c' op( A ) = A'. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit triangular -* as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of B. M must be at -* least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of B. N must be -* at least zero. -* Unchanged on exit. -* -* ALPHA - REAL . -* On entry, ALPHA specifies the scalar alpha. When alpha is -* zero then A is not referenced and B need not be set before -* entry. -* Unchanged on exit. -* -* A - REAL array of DIMENSION ( LDA, k ), where k is m -* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. -* Before entry with UPLO = 'U' or 'u', the leading k by k -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading k by k -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -* then LDA must be at least max( 1, n ). -* Unchanged on exit. -* -* B - REAL array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the right-hand side matrix B, and on exit is -* overwritten by the solution matrix X. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL LSIDE, NOUNIT, UPPER - INTEGER I, INFO, J, K, NROWA - REAL TEMP -* .. Parameters .. - REAL ONE , ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - LSIDE = LSAME( SIDE , 'L' ) - IF( LSIDE )THEN - NROWA = M - ELSE - NROWA = N - END IF - NOUNIT = LSAME( DIAG , 'N' ) - UPPER = LSAME( UPLO , 'U' ) -* - INFO = 0 - IF( ( .NOT.LSIDE ).AND. - $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 2 - ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN - INFO = 3 - ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. - $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN - INFO = 4 - ELSE IF( M .LT.0 )THEN - INFO = 5 - ELSE IF( N .LT.0 )THEN - INFO = 6 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTRSM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - B( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF( LSIDE )THEN - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*inv( A )*B. -* - IF( UPPER )THEN - DO 60, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 30, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 30 CONTINUE - END IF - DO 50, K = M, 1, -1 - IF( B( K, J ).NE.ZERO )THEN - IF( NOUNIT ) - $ B( K, J ) = B( K, J )/A( K, K ) - DO 40, I = 1, K - 1 - B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) - 40 CONTINUE - END IF - 50 CONTINUE - 60 CONTINUE - ELSE - DO 100, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 70, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 70 CONTINUE - END IF - DO 90 K = 1, M - IF( B( K, J ).NE.ZERO )THEN - IF( NOUNIT ) - $ B( K, J ) = B( K, J )/A( K, K ) - DO 80, I = K + 1, M - B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) - 80 CONTINUE - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form B := alpha*inv( A' )*B. -* - IF( UPPER )THEN - DO 130, J = 1, N - DO 120, I = 1, M - TEMP = ALPHA*B( I, J ) - DO 110, K = 1, I - 1 - TEMP = TEMP - A( K, I )*B( K, J ) - 110 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( I, I ) - B( I, J ) = TEMP - 120 CONTINUE - 130 CONTINUE - ELSE - DO 160, J = 1, N - DO 150, I = M, 1, -1 - TEMP = ALPHA*B( I, J ) - DO 140, K = I + 1, M - TEMP = TEMP - A( K, I )*B( K, J ) - 140 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( I, I ) - B( I, J ) = TEMP - 150 CONTINUE - 160 CONTINUE - END IF - END IF - ELSE - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*B*inv( A ). -* - IF( UPPER )THEN - DO 210, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 170, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 170 CONTINUE - END IF - DO 190, K = 1, J - 1 - IF( A( K, J ).NE.ZERO )THEN - DO 180, I = 1, M - B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) - 180 CONTINUE - END IF - 190 CONTINUE - IF( NOUNIT )THEN - TEMP = ONE/A( J, J ) - DO 200, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 200 CONTINUE - END IF - 210 CONTINUE - ELSE - DO 260, J = N, 1, -1 - IF( ALPHA.NE.ONE )THEN - DO 220, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 220 CONTINUE - END IF - DO 240, K = J + 1, N - IF( A( K, J ).NE.ZERO )THEN - DO 230, I = 1, M - B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) - 230 CONTINUE - END IF - 240 CONTINUE - IF( NOUNIT )THEN - TEMP = ONE/A( J, J ) - DO 250, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 250 CONTINUE - END IF - 260 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*inv( A' ). -* - IF( UPPER )THEN - DO 310, K = N, 1, -1 - IF( NOUNIT )THEN - TEMP = ONE/A( K, K ) - DO 270, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 270 CONTINUE - END IF - DO 290, J = 1, K - 1 - IF( A( J, K ).NE.ZERO )THEN - TEMP = A( J, K ) - DO 280, I = 1, M - B( I, J ) = B( I, J ) - TEMP*B( I, K ) - 280 CONTINUE - END IF - 290 CONTINUE - IF( ALPHA.NE.ONE )THEN - DO 300, I = 1, M - B( I, K ) = ALPHA*B( I, K ) - 300 CONTINUE - END IF - 310 CONTINUE - ELSE - DO 360, K = 1, N - IF( NOUNIT )THEN - TEMP = ONE/A( K, K ) - DO 320, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 320 CONTINUE - END IF - DO 340, J = K + 1, N - IF( A( J, K ).NE.ZERO )THEN - TEMP = A( J, K ) - DO 330, I = 1, M - B( I, J ) = B( I, J ) - TEMP*B( I, K ) - 330 CONTINUE - END IF - 340 CONTINUE - IF( ALPHA.NE.ONE )THEN - DO 350, I = 1, M - B( I, K ) = ALPHA*B( I, K ) - 350 CONTINUE - END IF - 360 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRSM . -* - END - - SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1992 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - REAL A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DGETF2 computes an LU factorization of a general m-by-n matrix A -* using partial pivoting with row interchanges. -* -* The factorization has the form -* A = P * L * U -* where P is a permutation matrix, L is lower triangular with unit -* diagonal elements (lower trapezoidal if m > n), and U is upper -* triangular (upper trapezoidal if m < n). -* -* This is the right-looking Level 2 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) REAL array, dimension (LDA,N) -* On entry, the m by n matrix to be factored. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* > 0: if INFO = k, U(k,k) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* ===================================================================== -* -* .. Parameters .. - REAL ONE, ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -* .. -* .. Local Scalars .. - INTEGER J, JP -* .. -* .. External Functions .. - INTEGER ISAMAX - EXTERNAL ISAMAX -* .. -* .. External Subroutines .. - EXTERNAL DGER, DSCAL, DSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* - DO 10 J = 1, MIN( M, N ) -* -* Find pivot and test for singularity. -* - JP = J - 1 + ISAMAX( M-J+1, A( J, J ), 1 ) - IPIV( J ) = JP - IF( A( JP, J ).NE.ZERO ) THEN -* -* Apply the interchange to columns 1:N. -* - IF( JP.NE.J ) - $ CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) -* -* Compute elements J+1:M of J-th column. -* - IF( J.LT.M ) - $ CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) -* - ELSE IF( INFO.EQ.0 ) THEN -* - INFO = J - END IF -* - IF( J.LT.MIN( M, N ) ) THEN -* -* Update trailing submatrix. -* - CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA, - $ A( J+1, J+1 ), LDA ) - END IF - 10 CONTINUE - RETURN -* -* End of DGETF2 -* - END - SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) -* -* -- LAPACK auxiliary routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - INTEGER INCX, K1, K2, LDA, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - REAL A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DLASWP performs a series of row interchanges on the matrix A. -* One row interchange is initiated for each of rows K1 through K2 of A. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of columns of the matrix A. -* -* A (input/output) REAL array, dimension (LDA,N) -* On entry, the matrix of column dimension N to which the row -* interchanges will be applied. -* On exit, the permuted matrix. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* -* K1 (input) INTEGER -* The first element of IPIV for which a row interchange will -* be done. -* -* K2 (input) INTEGER -* The last element of IPIV for which a row interchange will -* be done. -* -* IPIV (input) INTEGER array, dimension (M*abs(INCX)) -* The vector of pivot indices. Only the elements in positions -* K1 through K2 of IPIV are accessed. -* IPIV(K) = L implies rows K and L are to be interchanged. -* -* INCX (input) INTEGER -* The increment between successive values of IPIV. If IPIV -* is negative, the pivots are applied in reverse order. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, IP, IX -* .. -* .. External Subroutines .. - EXTERNAL DSWAP -* .. -* .. Executable Statements .. -* -* Interchange row I with row IPIV(I) for each of rows K1 through K2. -* - IF( INCX.EQ.0 ) - $ RETURN - IF( INCX.GT.0 ) THEN - IX = K1 - ELSE - IX = 1 + ( 1-K2 )*INCX - END IF - IF( INCX.EQ.1 ) THEN - DO 10 I = K1, K2 - IP = IPIV( I ) - IF( IP.NE.I ) - $ CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) - 10 CONTINUE - ELSE IF( INCX.GT.1 ) THEN - DO 20 I = K1, K2 - IP = IPIV( IX ) - IF( IP.NE.I ) - $ CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) - IX = IX + INCX - 20 CONTINUE - ELSE IF( INCX.LT.0 ) THEN - DO 30 I = K2, K1, -1 - IP = IPIV( IX ) - IF( IP.NE.I ) - $ CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) - IX = IX + INCX - 30 CONTINUE - END IF -* - RETURN -* -* End of DLASWP -* - END - subroutine dswap (n,sx,incx,sy,incy) -c -c interchanges two vectors. -c uses unrolled loops for increments equal to 1. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - real sx(*),sy(*),stemp - integer i,incx,incy,ix,iy,m,mp1,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments not equal -c to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - stemp = sx(ix) - sx(ix) = sy(iy) - sy(iy) = stemp - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,3) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - stemp = sx(i) - sx(i) = sy(i) - sy(i) = stemp - 30 continue - if( n .lt. 3 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,3 - stemp = sx(i) - sx(i) = sy(i) - sy(i) = stemp - stemp = sx(i + 1) - sx(i + 1) = sy(i + 1) - sy(i + 1) = stemp - stemp = sx(i + 2) - sx(i + 2) = sy(i + 2) - sy(i + 2) = stemp - 50 continue - return - end - subroutine dscal(n,sa,sx,incx) -c -c scales a vector by a constant. -c uses unrolled loops for increment equal to 1. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - real sa,sx(*) - integer i,incx,m,mp1,n,nincx -c - if( n.le.0 .or. incx.le.0 )return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - nincx = n*incx - do 10 i = 1,nincx,incx - sx(i) = sa*sx(i) - 10 continue - return -c -c code for increment equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,5) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - sx(i) = sa*sx(i) - 30 continue - if( n .lt. 5 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,5 - sx(i) = sa*sx(i) - sx(i + 1) = sa*sx(i + 1) - sx(i + 2) = sa*sx(i + 2) - sx(i + 3) = sa*sx(i + 3) - sx(i + 4) = sa*sx(i + 4) - 50 continue - return - end - SUBROUTINE DGER ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) -* .. Scalar Arguments .. - REAL ALPHA - INTEGER INCX, INCY, LDA, M, N -* .. Array Arguments .. - REAL A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DGER performs the rank 1 operation -* -* A := alpha*x*y' + A, -* -* where alpha is a scalar, x is an m element vector, y is an n element -* vector and A is an m by n matrix. -* -* Parameters -* ========== -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - REAL . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - REAL array of dimension at least -* ( 1 + ( m - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the m -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - REAL array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* A - REAL array of DIMENSION ( LDA, n ). -* Before entry, the leading m by n part of the array A must -* contain the matrix of coefficients. On exit, A is -* overwritten by the updated matrix. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0E+0 ) -* .. Local Scalars .. - REAL TEMP - INTEGER I, INFO, IX, J, JY, KX -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( M.LT.0 )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - ELSE IF( LDA.LT.MAX( 1, M ) )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DGER ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( INCY.GT.0 )THEN - JY = 1 - ELSE - JY = 1 - ( N - 1 )*INCY - END IF - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( Y( JY ).NE.ZERO )THEN - TEMP = ALPHA*Y( JY ) - DO 10, I = 1, M - A( I, J ) = A( I, J ) + X( I )*TEMP - 10 CONTINUE - END IF - JY = JY + INCY - 20 CONTINUE - ELSE - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( M - 1 )*INCX - END IF - DO 40, J = 1, N - IF( Y( JY ).NE.ZERO )THEN - TEMP = ALPHA*Y( JY ) - IX = KX - DO 30, I = 1, M - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JY = JY + INCY - 40 CONTINUE - END IF -* - RETURN -* -* End of DGER . -* - END - SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER DIAG, UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - REAL A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DTRTI2 computes the inverse of a real upper or lower triangular -* matrix. -* -* This is the Level 2 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the matrix A is upper or lower triangular. -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* DIAG (input) CHARACTER*1 -* Specifies whether or not the matrix A is unit triangular. -* = 'N': Non-unit triangular -* = 'U': Unit triangular -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) REAL array, dimension (LDA,N) -* On entry, the triangular matrix A. If UPLO = 'U', the -* leading n by n upper triangular part of the array A contains -* the upper triangular matrix, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading n by n lower triangular part of the array A contains -* the lower triangular matrix, and the strictly upper -* triangular part of A is not referenced. If DIAG = 'U', the -* diagonal elements of A are also not referenced and are -* assumed to be 1. -* -* On exit, the (triangular) inverse of the original matrix, in -* the same storage format. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOUNIT, UPPER - INTEGER J - REAL AJJ -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DSCAL, DTRMV, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - NOUNIT = LSAME( DIAG, 'N' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DTRTI2', -INFO ) - RETURN - END IF -* - IF( UPPER ) THEN -* -* Compute inverse of upper triangular matrix. -* - DO 10 J = 1, N - IF( NOUNIT ) THEN - A( J, J ) = ONE / A( J, J ) - AJJ = -A( J, J ) - ELSE - AJJ = -ONE - END IF -* -* Compute elements 1:j-1 of j-th column. -* - CALL DTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA, - $ A( 1, J ), 1 ) - CALL DSCAL( J-1, AJJ, A( 1, J ), 1 ) - 10 CONTINUE - ELSE -* -* Compute inverse of lower triangular matrix. -* - DO 20 J = N, 1, -1 - IF( NOUNIT ) THEN - A( J, J ) = ONE / A( J, J ) - AJJ = -A( J, J ) - ELSE - AJJ = -ONE - END IF - IF( J.LT.N ) THEN -* -* Compute elements j+1:n of j-th column. -* - CALL DTRMV( 'Lower', 'No transpose', DIAG, N-J, - $ A( J+1, J+1 ), LDA, A( J+1, J ), 1 ) - CALL DSCAL( N-J, AJJ, A( J+1, J ), 1 ) - END IF - 20 CONTINUE - END IF -* - RETURN -* -* End of DTRTI2 -* - END - SUBROUTINE DTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, - $ B, LDB ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO, TRANSA, DIAG - INTEGER M, N, LDA, LDB - REAL ALPHA -* .. Array Arguments .. - REAL A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DTRMM performs one of the matrix-matrix operations -* -* B := alpha*op( A )*B, or B := alpha*B*op( A ), -* -* where alpha is a scalar, B is an m by n matrix, A is a unit, or -* non-unit, upper or lower triangular matrix and op( A ) is one of -* -* op( A ) = A or op( A ) = A'. -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether op( A ) multiplies B from -* the left or right as follows: -* -* SIDE = 'L' or 'l' B := alpha*op( A )*B. -* -* SIDE = 'R' or 'r' B := alpha*B*op( A ). -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix A is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANSA - CHARACTER*1. -* On entry, TRANSA specifies the form of op( A ) to be used in -* the matrix multiplication as follows: -* -* TRANSA = 'N' or 'n' op( A ) = A. -* -* TRANSA = 'T' or 't' op( A ) = A'. -* -* TRANSA = 'C' or 'c' op( A ) = A'. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit triangular -* as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of B. M must be at -* least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of B. N must be -* at least zero. -* Unchanged on exit. -* -* ALPHA - REAL . -* On entry, ALPHA specifies the scalar alpha. When alpha is -* zero then A is not referenced and B need not be set before -* entry. -* Unchanged on exit. -* -* A - REAL array of DIMENSION ( LDA, k ), where k is m -* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. -* Before entry with UPLO = 'U' or 'u', the leading k by k -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading k by k -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -* then LDA must be at least max( 1, n ). -* Unchanged on exit. -* -* B - REAL array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the matrix B, and on exit is overwritten by the -* transformed matrix. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL LSIDE, NOUNIT, UPPER - INTEGER I, INFO, J, K, NROWA - REAL TEMP -* .. Parameters .. - REAL ONE , ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - LSIDE = LSAME( SIDE , 'L' ) - IF( LSIDE )THEN - NROWA = M - ELSE - NROWA = N - END IF - NOUNIT = LSAME( DIAG , 'N' ) - UPPER = LSAME( UPLO , 'U' ) -* - INFO = 0 - IF( ( .NOT.LSIDE ).AND. - $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 2 - ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN - INFO = 3 - ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. - $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN - INFO = 4 - ELSE IF( M .LT.0 )THEN - INFO = 5 - ELSE IF( N .LT.0 )THEN - INFO = 6 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTRMM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - B( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF( LSIDE )THEN - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*A*B. -* - IF( UPPER )THEN - DO 50, J = 1, N - DO 40, K = 1, M - IF( B( K, J ).NE.ZERO )THEN - TEMP = ALPHA*B( K, J ) - DO 30, I = 1, K - 1 - B( I, J ) = B( I, J ) + TEMP*A( I, K ) - 30 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP*A( K, K ) - B( K, J ) = TEMP - END IF - 40 CONTINUE - 50 CONTINUE - ELSE - DO 80, J = 1, N - DO 70 K = M, 1, -1 - IF( B( K, J ).NE.ZERO )THEN - TEMP = ALPHA*B( K, J ) - B( K, J ) = TEMP - IF( NOUNIT ) - $ B( K, J ) = B( K, J )*A( K, K ) - DO 60, I = K + 1, M - B( I, J ) = B( I, J ) + TEMP*A( I, K ) - 60 CONTINUE - END IF - 70 CONTINUE - 80 CONTINUE - END IF - ELSE -* -* Form B := alpha*A'*B. -* - IF( UPPER )THEN - DO 110, J = 1, N - DO 100, I = M, 1, -1 - TEMP = B( I, J ) - IF( NOUNIT ) - $ TEMP = TEMP*A( I, I ) - DO 90, K = 1, I - 1 - TEMP = TEMP + A( K, I )*B( K, J ) - 90 CONTINUE - B( I, J ) = ALPHA*TEMP - 100 CONTINUE - 110 CONTINUE - ELSE - DO 140, J = 1, N - DO 130, I = 1, M - TEMP = B( I, J ) - IF( NOUNIT ) - $ TEMP = TEMP*A( I, I ) - DO 120, K = I + 1, M - TEMP = TEMP + A( K, I )*B( K, J ) - 120 CONTINUE - B( I, J ) = ALPHA*TEMP - 130 CONTINUE - 140 CONTINUE - END IF - END IF - ELSE - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*B*A. -* - IF( UPPER )THEN - DO 180, J = N, 1, -1 - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 150, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 150 CONTINUE - DO 170, K = 1, J - 1 - IF( A( K, J ).NE.ZERO )THEN - TEMP = ALPHA*A( K, J ) - DO 160, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - ELSE - DO 220, J = 1, N - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 190, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 190 CONTINUE - DO 210, K = J + 1, N - IF( A( K, J ).NE.ZERO )THEN - TEMP = ALPHA*A( K, J ) - DO 200, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 200 CONTINUE - END IF - 210 CONTINUE - 220 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*A'. -* - IF( UPPER )THEN - DO 260, K = 1, N - DO 240, J = 1, K - 1 - IF( A( J, K ).NE.ZERO )THEN - TEMP = ALPHA*A( J, K ) - DO 230, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 230 CONTINUE - END IF - 240 CONTINUE - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( K, K ) - IF( TEMP.NE.ONE )THEN - DO 250, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 250 CONTINUE - END IF - 260 CONTINUE - ELSE - DO 300, K = N, 1, -1 - DO 280, J = K + 1, N - IF( A( J, K ).NE.ZERO )THEN - TEMP = ALPHA*A( J, K ) - DO 270, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 270 CONTINUE - END IF - 280 CONTINUE - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( K, K ) - IF( TEMP.NE.ONE )THEN - DO 290, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 290 CONTINUE - END IF - 300 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRMM . -* - END - SUBROUTINE DTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - REAL A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* DTRMV performs one of the matrix-vector operations -* -* x := A*x, or x := A'*x, -* -* where x is an n element vector and A is an n by n unit, or non-unit, -* upper or lower triangular matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' x := A*x. -* -* TRANS = 'T' or 't' x := A'*x. -* -* TRANS = 'C' or 'c' x := A'*x. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* A - REAL array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* X - REAL array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. On exit, X is overwritten with the -* tranformed vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0E+0 ) -* .. Local Scalars .. - REAL TEMP - INTEGER I, INFO, IX, J, JX, KX - LOGICAL NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTRMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOUNIT = LSAME( DIAG, 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x := A*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - DO 10, I = 1, J - 1 - X( I ) = X( I ) + TEMP*A( I, J ) - 10 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*A( J, J ) - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 30, I = 1, J - 1 - X( IX ) = X( IX ) + TEMP*A( I, J ) - IX = IX + INCX - 30 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( J, J ) - END IF - JX = JX + INCX - 40 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 60, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - DO 50, I = N, J + 1, -1 - X( I ) = X( I ) + TEMP*A( I, J ) - 50 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*A( J, J ) - END IF - 60 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 80, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 70, I = N, J + 1, -1 - X( IX ) = X( IX ) + TEMP*A( I, J ) - IX = IX - INCX - 70 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( J, J ) - END IF - JX = JX - INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A'*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 100, J = N, 1, -1 - TEMP = X( J ) - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 90, I = J - 1, 1, -1 - TEMP = TEMP + A( I, J )*X( I ) - 90 CONTINUE - X( J ) = TEMP - 100 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 120, J = N, 1, -1 - TEMP = X( JX ) - IX = JX - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 110, I = J - 1, 1, -1 - IX = IX - INCX - TEMP = TEMP + A( I, J )*X( IX ) - 110 CONTINUE - X( JX ) = TEMP - JX = JX - INCX - 120 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 140, J = 1, N - TEMP = X( J ) - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 130, I = J + 1, N - TEMP = TEMP + A( I, J )*X( I ) - 130 CONTINUE - X( J ) = TEMP - 140 CONTINUE - ELSE - JX = KX - DO 160, J = 1, N - TEMP = X( JX ) - IX = JX - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 150, I = J + 1, N - IX = IX + INCX - TEMP = TEMP + A( I, J )*X( IX ) - 150 CONTINUE - X( JX ) = TEMP - JX = JX + INCX - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRMV . -* - END - - - - INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, - $ N4 ) -* -* -- LAPACK auxiliary routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER*( * ) NAME, OPTS - INTEGER ISPEC, N1, N2, N3, N4 -* .. -* -* Purpose -* ======= -* -* ILAENV is called from the LAPACK routines to choose problem-dependent -* parameters for the local environment. See ISPEC for a description of -* the parameters. -* -* This version provides a set of parameters which should give good, -* but not optimal, performance on many of the currently available -* computers. Users are encouraged to modify this subroutine to set -* the tuning parameters for their particular machine using the option -* and problem size information in the arguments. -* -* This routine will not function correctly if it is converted to all -* lower case. Converting it to all upper case is allowed. -* -* Arguments -* ========= -* -* ISPEC (input) INTEGER -* Specifies the parameter to be returned as the value of -* ILAENV. -* = 1: the optimal blocksize; if this value is 1, an unblocked -* algorithm will give the best performance. -* = 2: the minimum block size for which the block routine -* should be used; if the usable block size is less than -* this value, an unblocked routine should be used. -* = 3: the crossover point (in a block routine, for N less -* than this value, an unblocked routine should be used) -* = 4: the number of shifts, used in the nonsymmetric -* eigenvalue routines -* = 5: the minimum column dimension for blocking to be used; -* rectangular blocks must have dimension at least k by m, -* where k is given by ILAENV(2,...) and m by ILAENV(5,...) -* = 6: the crossover point for the SVD (when reducing an m by n -* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds -* this value, a QR factorization is used first to reduce -* the matrix to a triangular form.) -* = 7: the number of processors -* = 8: the crossover point for the multishift QR and QZ methods -* for nonsymmetric eigenvalue problems. -* -* NAME (input) CHARACTER*(*) -* The name of the calling subroutine, in either upper case or -* lower case. -* -* OPTS (input) CHARACTER*(*) -* The character options to the subroutine NAME, concatenated -* into a single character string. For example, UPLO = 'U', -* TRANS = 'T', and DIAG = 'N' for a triangular routine would -* be specified as OPTS = 'UTN'. -* -* N1 (input) INTEGER -* N2 (input) INTEGER -* N3 (input) INTEGER -* N4 (input) INTEGER -* Problem dimensions for the subroutine NAME; these may not all -* be required. -* -* (ILAENV) (output) INTEGER -* >= 0: the value of the parameter specified by ISPEC -* < 0: if ILAENV = -k, the k-th argument had an illegal value. -* -* Further Details -* =============== -* -* The following conventions have been used when calling ILAENV from the -* LAPACK routines: -* 1) OPTS is a concatenation of all of the character options to -* subroutine NAME, in the same order that they appear in the -* argument list for NAME, even if they are not used in determining -* the value of the parameter specified by ISPEC. -* 2) The problem dimensions N1, N2, N3, N4 are specified in the order -* that they appear in the argument list for NAME. N1 is used -* first, N2 second, and so on, and unused problem dimensions are -* passed a value of -1. -* 3) The parameter value returned by ILAENV is checked for validity in -* the calling subroutine. For example, ILAENV is used to retrieve -* the optimal blocksize for DTRTRI as follows: -* -* NB = ILAENV( 1, 'DTRTRI', UPLO // DIAG, N, -1, -1, -1 ) -* IF( NB.LE.1 ) NB = MAX( 1, N ) -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL CNAME, SNAME - CHARACTER*1 C1 - CHARACTER*2 C2, C4 - CHARACTER*3 C3 - CHARACTER*6 SUBNAM - INTEGER I, IC, IZ, NB, NBMIN, NX -* .. -* .. Intrinsic Functions .. - INTRINSIC CHAR, ICHAR, INT, MIN, REAL -* .. -* .. Executable Statements .. -* - GO TO ( 100, 100, 100, 400, 500, 600, 700, 800 ) ISPEC -* -* Invalid value for ISPEC -* - ILAENV = -1 - RETURN -* - 100 CONTINUE -* -* Convert NAME to upper case if the first character is lower case. -* - ILAENV = 1 - SUBNAM = NAME - IC = MOVA2I( SUBNAM( 1:1 ) ) - IZ = MOVA2I( 'Z' ) - IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN -* -* ASCII character set -* - IF( IC.GE.97 .AND. IC.LE.122 ) THEN - SUBNAM( 1:1 ) = CHAR( IC-32 ) - DO 10 I = 2, 6 - IC = MOVA2I( SUBNAM( I:I ) ) - IF( IC.GE.97 .AND. IC.LE.122 ) - $ SUBNAM( I:I ) = CHAR( IC-32 ) - 10 CONTINUE - END IF -* - ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN -* -* EBCDIC character set -* - IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. - $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. - $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN - SUBNAM( 1:1 ) = CHAR( IC+64 ) - DO 20 I = 2, 6 - IC = MOVA2I( SUBNAM( I:I ) ) - IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. - $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. - $ ( IC.GE.162 .AND. IC.LE.169 ) ) - $ SUBNAM( I:I ) = CHAR( IC+64 ) - 20 CONTINUE - END IF -* - ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN -* -* Prime machines: ASCII+128 -* - IF( IC.GE.225 .AND. IC.LE.250 ) THEN - SUBNAM( 1:1 ) = CHAR( IC-32 ) - DO 30 I = 2, 6 - IC = MOVA2I( SUBNAM( I:I ) ) - IF( IC.GE.225 .AND. IC.LE.250 ) - $ SUBNAM( I:I ) = CHAR( IC-32 ) - 30 CONTINUE - END IF - END IF -* - C1 = SUBNAM( 1:1 ) - SNAME = C1.EQ.'S' .OR. C1.EQ.'D' - CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' - IF( .NOT.( CNAME .OR. SNAME ) ) - $ RETURN - C2 = SUBNAM( 2:3 ) - C3 = SUBNAM( 4:6 ) - C4 = C3( 2:3 ) -* - GO TO ( 110, 200, 300 ) ISPEC -* - 110 CONTINUE -* -* ISPEC = 1: block size -* -* In these examples, separate code is provided for setting NB for -* real and complex. We assume that NB will take the same value in -* single or double precision. -* - NB = 1 -* - IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. - $ C3.EQ.'QLF' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C3.EQ.'HRD' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( C2.EQ.'PO' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NB = 1 - ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN - NB = 64 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRF' ) THEN - NB = 64 - ELSE IF( C3.EQ.'TRD' ) THEN - NB = 1 - ELSE IF( C3.EQ.'GST' ) THEN - NB = 64 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NB = 32 - END IF - ELSE IF( C3( 1:1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NB = 32 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NB = 32 - END IF - ELSE IF( C3( 1:1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NB = 32 - END IF - END IF - ELSE IF( C2.EQ.'GB' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - IF( N4.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - ELSE - IF( N4.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - END IF - END IF - ELSE IF( C2.EQ.'PB' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - IF( N2.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - ELSE - IF( N2.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - END IF - END IF - ELSE IF( C2.EQ.'TR' ) THEN - IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( C2.EQ.'LA' ) THEN - IF( C3.EQ.'UUM' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN - IF( C3.EQ.'EBZ' ) THEN - NB = 1 - END IF - END IF - ILAENV = NB - RETURN -* - 200 CONTINUE -* -* ISPEC = 2: minimum block size -* - NBMIN = 2 - IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. - $ C3.EQ.'QLF' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'HRD' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NBMIN = 8 - ELSE - NBMIN = 8 - END IF - ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NBMIN = 2 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRD' ) THEN - NBMIN = 2 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NBMIN = 2 - END IF - ELSE IF( C3( 1:1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NBMIN = 2 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NBMIN = 2 - END IF - ELSE IF( C3( 1:1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NBMIN = 2 - END IF - END IF - END IF - ILAENV = NBMIN - RETURN -* - 300 CONTINUE -* -* ISPEC = 3: crossover point -* - NX = 0 - IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. - $ C3.EQ.'QLF' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - ELSE IF( C3.EQ.'HRD' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NX = 1 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRD' ) THEN - NX = 1 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NX = 128 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NX = 128 - END IF - END IF - END IF - ILAENV = NX - RETURN -* - 400 CONTINUE -* -* ISPEC = 4: number of shifts (used by xHSEQR) -* - ILAENV = 6 - RETURN -* - 500 CONTINUE -* -* ISPEC = 5: minimum column dimension (not used) -* - ILAENV = 2 - RETURN -* - 600 CONTINUE -* -* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) -* - ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) - RETURN -* - 700 CONTINUE -* -* ISPEC = 7: number of processors (not used) -* - ILAENV = 1 - RETURN -* - 800 CONTINUE -* -* ISPEC = 8: crossover point for multishift (used by xHSEQR) -* - ILAENV = 50 - RETURN -* -* End of ILAENV -* - END - - - - - - LOGICAL FUNCTION LSAME( CA, CB ) -* -* -- LAPACK auxiliary routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER CA, CB -* .. -* -* Purpose -* ======= -* -* LSAME returns .TRUE. if CA is the same letter as CB regardless of -* case. -* -* Arguments -* ========= -* -* CA (input) CHARACTER*1 -* CB (input) CHARACTER*1 -* CA and CB specify the single characters to be compared. -* -* ===================================================================== -* -* .. Intrinsic Functions .. - INTRINSIC ICHAR -* .. -* .. Local Scalars .. - INTEGER INTA, INTB, ZCODE -* .. -* .. Executable Statements .. -* -* Test if the characters are equal -* - LSAME = CA.EQ.CB - IF( LSAME ) - $ RETURN -* -* Now test for equivalence if both characters are alphabetic. -* - ZCODE = MOVA2I( 'Z' ) -* -* Use 'Z' rather than 'A' so that ASCII can be detected on Prime -* machines, on which ICHAR returns a value with bit 8 set. -* MOVA2I('A') on Prime machines returns 193 which is the same as -* MOVA2I('A') on an EBCDIC machine. -* - INTA = MOVA2I( CA ) - INTB = MOVA2I( CB ) -* - IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN -* -* ASCII is assumed - ZCODE is the ASCII code of either lower or -* upper case 'Z'. -* - IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 - IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 -* - ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN -* -* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or -* upper case 'Z'. -* - IF( INTA.GE.129 .AND. INTA.LE.137 .OR. - $ INTA.GE.145 .AND. INTA.LE.153 .OR. - $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 - IF( INTB.GE.129 .AND. INTB.LE.137 .OR. - $ INTB.GE.145 .AND. INTB.LE.153 .OR. - $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 -* - ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN -* -* ASCII is assumed, on Prime machines - ZCODE is the ASCII code -* plus 128 of either lower or upper case 'Z'. -* - IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 - IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 - END IF - LSAME = INTA.EQ.INTB -* -* RETURN -* -* End of LSAME -* - END - - - - integer function isamax(n,sx,incx) -c -c finds the index of element having max. absolute value. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - real sx(*),smax - integer i,incx,ix,n -c - isamax = 0 - if( n.lt.1 .or. incx.le.0 ) return - isamax = 1 - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - smax = abs(sx(1)) - ix = ix + incx - do 10 i = 2,n - if(abs(sx(ix)).le.smax) go to 5 - isamax = i - smax = abs(sx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 smax = abs(sx(1)) - do 30 i = 2,n - if(abs(sx(i)).le.smax) go to 30 - isamax = i - smax = abs(sx(i)) - 30 continue - return - end - - - subroutine dcopy(n,sx,incx,sy,incy) -c -c copies a vector, x, to a vector, y. -c uses unrolled loops for increments equal to 1. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - real sx(*),sy(*) - integer i,incx,incy,ix,iy,m,mp1,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - sy(iy) = sx(ix) - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,7) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - sy(i) = sx(i) - 30 continue - if( n .lt. 7 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,7 - sy(i) = sx(i) - sy(i + 1) = sx(i + 1) - sy(i + 2) = sx(i + 2) - sy(i + 3) = sx(i + 3) - sy(i + 4) = sx(i + 4) - sy(i + 5) = sx(i + 5) - sy(i + 6) = sx(i + 6) - 50 continue - return - end diff --git a/src/fim/FIMsrc/fim/column/omegas.f b/src/fim/FIMsrc/fim/column/omegas.f deleted file mode 100644 index fe6cdd9..0000000 --- a/src/fim/FIMsrc/fim/column/omegas.f +++ /dev/null @@ -1,80 +0,0 @@ - SUBROUTINE OMEGAST3(NJEFF,NSIZE_AR,NZ, - 1 DPHI,DLAM,UG,VG,DG,DEL,RCL,VVEL,PS,SL) -CFPP$ NOCONCUR R -C.... CODE LIFTED FROM POST (MCP1840) JUN 88--COMPUTES VVEL (CB/SEC) -C.... INPUT PS IN CB,OUTPUT VVEL IN CB/SEC -C.... DO LOOPS ALTERED FOR BETTER VECTORIZATION POSSIBILITIES..K.A.C. -cc - USE MACHINE , ONLY : kind_phys - use resol_def - implicit none - -!! - integer i,k,le,nz,NSIZE_AR,NJEFF - real(kind=kind_phys) rcl -cc - real(kind=kind_phys) DPHI(NSIZE_AR),DLAM(NSIZE_AR),PS(NSIZE_AR) - real(kind=kind_phys) - 1 CG(NJEFF,NZ),UG(NSIZE_AR,NZ),VG(NSIZE_AR,NZ), - 2 DG(NSIZE_AR,NZ),DEL(NZ),SL(NZ) -C... VVEL CONTAINS OMEGA IN LAYERS ON RETURN FROM SUBROUTINE... - real(kind=kind_phys) VVEL(NSIZE_AR,NZ) - real(kind=kind_phys) DB(NJEFF,NZ),CB(NJEFF,NZ), - & DOT(NJEFF,NZ+1) -!! - DO 1 K=1,NZ+1 -CC DO 1 LO=1,NX - DO 49 i=1,NJEFF - DOT(i,K) = 0.E0 - 49 CONTINUE - 1 CONTINUE -C... COMPUTE C=V(TRUE)*DEL(LN(PS)).DIVIDE BY COS FOR DEL COS FOR V -CC DO 3 LO=1,NX - DO 48 i=1,NJEFF - DPHI(i)=DPHI(i)*RCL - DLAM(i)=DLAM(i)*RCL - 48 CONTINUE -CC 3 CONTINUE - DO 5 LE=1,NZ - DO 50 i=1,NJEFF -CC DO 4 LO=1,NX - CG(i,LE)=UG(i,LE)*DLAM(i)+VG(i,LE)*DPHI(i) -CC 4 CONTINUE - 50 CONTINUE - 5 CONTINUE -CC DO 10 LO=1,NX - DO 51 i=1,NJEFF - DB(i,1)=DEL(1)*DG(i,1) - CB(i,1)=DEL(1)*CG(i,1) - 51 CONTINUE -CC 10 CONTINUE -!! - DO 6 LE=1,NZ-1 - DO 52 i=1,NJEFF -CC DO 6 LO=1,NX - DB(i,LE+1)=DB(i,LE)+DEL(LE+1)*DG(i,LE+1) - CB(i,LE+1)=CB(i,LE)+DEL(LE+1)*CG(i,LE+1) - 52 CONTINUE - 6 CONTINUE -!! -C... SIGMA DOT COMPUTED ONLY AT INTERIOR INTERFACES - DO 7 K=1,NZ-1 - DO 53 i=1,NJEFF -CC DO 7 LO=1,NX - DOT(i,K+1)=DOT(i,K)+DEL(K) - 1 *(DB(i,NZ)+CB(i,NZ)-DG(i,K)-CG(i,K)) - 53 CONTINUE - 7 CONTINUE -!! - DO 8 K=1,NZ -CC DO 8 LO=1,NX - DO 54 i=1,NJEFF - VVEL(i,K)= SL(K)*(CG(i,K)-CB(i,NZ)-DB(i,NZ))- - 1 0.5*(DOT(i,K+1)+DOT(i,K)) - VVEL(i,K)=VVEL(i,K)*PS(i) -CCC VVEL(i,K)=VVEL(i,K)*PS(i)*10. - 54 CONTINUE - 8 CONTINUE -!! - RETURN - END diff --git a/src/fim/FIMsrc/fim/column/omegtes.f b/src/fim/FIMsrc/fim/column/omegtes.f deleted file mode 100644 index 3fbdfb8..0000000 --- a/src/fim/FIMsrc/fim/column/omegtes.f +++ /dev/null @@ -1,123 +0,0 @@ - subroutine omegtes(njeff,nsize_ar,rcl, - & expq,dphi,dlam,dg,ug,vg,vvel) - - use machine , only : kind_phys - - use resol_def - use coordinate_def ! hmhj - implicit none - - integer njeff,nsize_ar - integer i,k,n,ifirst,il,ilat - - real(kind=kind_phys) rcl - real(kind=kind_phys) dg(nsize_ar,levs), ug(nsize_ar,levs), - & vg(nsize_ar,levs), - & dphi(nsize_ar), dlam(nsize_ar), qg - - - real(kind=kind_phys) - & pk5(njeff,levp1), dot(levp1), dotinv(levp1), - & dpk(njeff,levs), cg(njeff,levs), - & cb(njeff,levs), db(njeff,levs), - & workb(njeff,levs), workc(njeff,levs), prs(njeff,levs), - & alfa(njeff,levs), rlnp(njeff,levs), rdel(njeff,levs), - & vvel(nsize_ar,levs), - & expq(nsize_ar),dqdt - - real(kind=kind_phys) cons0,cons0p5,cons1,cons2,clog2 !constant - real(kind=kind_phys) rmin,rmax - -! print *,' enter omegtes_fd ' ! hmhj - - cons0 = 0.d0 !constant - cons0p5 = 0.5d0 !constant - cons1 = 1.d0 !constant - cons2 = 2.d0 !constant - clog2=log(cons2) ! constant - - do k=1,levp1 - do i=1,njeff - pk5(i,k)=ak5(k) + bk5(k)*expq(i) - enddo - enddo - - do k=1,levs - do i=1,njeff - prs(i,k)= (pk5(i,k+1) + pk5(i,k) )*cons0p5 - dpk(i,k)= pk5(i,k+1) - pk5(i,k) - rdel(i,k)= cons1/dpk(i,k) ! constant - enddo - enddo - - k=1 - do i=1,njeff - alfa(i,1)=clog2 ! constant - rlnp(i,1)= 99999.99 - enddo - - do k=2,levs - do i=1,njeff - rlnp(i,k)= log( pk5(i,k+1)/pk5(i,k) ) - alfa(i,k)= cons1-( pk5(i,k)/dpk(i,k) )*rlnp(i,k) - enddo - enddo - - do k=1,levs - do i=1,njeff - cg(i,k)=(ug(i,levs+1-k)*dlam(i)+vg(i,levs+1-k)*dphi(i))*rcl - enddo - enddo - - k=1 - do i=1,njeff - db(i,1)=dg(i,levs)*dpk(i,1) - cb(i,1)=cg(i,1)*dbk(1) - enddo - - do k=1,levm1 - do i=1,njeff - db(i,k+1)=db(i,k)+dg(i,levs-k)*dpk(i,k+1) - cb(i,k+1)=cb(i,k)+cg(i,k+1)*dbk(k+1) - enddo - enddo - - -998 format('ilat=',i3) -999 format('k vv(k)=',i3,e13.3,' il=',i3,' slat=',f5.2,' p=',f8.3) - - - k=1 - do i=1,njeff - workb(i,1)=alfa(i,1)* - & ( dg(i,levs)*dpk(i,1)+expq(i)*cb(i,1)*dbk(1) ) - enddo - - do k=2,levs - do i=1,njeff - workb(i,k)=rlnp(i,k)*( db(i,k-1)+expq(i)*cb(i,k-1) ) - & +alfa(i,k)*( dg(i,levs+1-k)*dpk(i,k)+expq(i)*cg(i,k)*dbk(k) ) - enddo - enddo - - k=1 - do i=1,njeff - workc(i,1)=expq(i)*cg(i,1)*dbk(1) - enddo - - do k=2,levs - do i=1,njeff - workc(i,k)=expq(i)*cg(i,k)*( dbk(k)+ck(k)*rlnp(i,k)*rdel(i,k) ) - enddo - enddo - - do k=1,levs - do i=1,njeff - vvel(i,levs+1-k)=rdel(i,k)*( -workb(i,k) + workc(i,k))*prs(i,k) - enddo - enddo - -! print *,' leave omegtes_fd ' ! hmhj - - return - end diff --git a/src/fim/FIMsrc/fim/column/ozphys_v.f b/src/fim/FIMsrc/fim/column/ozphys_v.f deleted file mode 100644 index ee82397..0000000 --- a/src/fim/FIMsrc/fim/column/ozphys_v.f +++ /dev/null @@ -1,115 +0,0 @@ - SUBROUTINE OZPHYS (IX, IM, LEVS, KO3, DT, OZI, OZO, TIN, PO3, - & PRSL, PRDOUT, pl_coeff, DELP, LDIAG3D, - & LGGFS3D, OZP,me) -! -! This code assumes that both PRSL and PO3 are from bottom to top -! as are all other variables -! - USE MACHINE , ONLY : kind_phys - use physcons, only : grav => con_g - implicit none -! - real, parameter :: gravi=1.0/grav - integer IM, IX, LEVS, KO3, pl_coeff,me - real(kind=kind_phys) OZI(IX,LEVS), OZO(IX,LEVS), PO3(KO3), - & PRSL(IX,LEVS), TIN(IX,LEVS), DELP(IX,LEVS), - & PRDOUT(IX,KO3,pl_coeff), - & OZP(IX,LEVS,pl_coeff), DT -! - integer k,kmax,kmin,l,I,j - logical LDIAG3D, LGGFS3D, flg(im) - real(kind=kind_phys) pmax, pmin, tem, temp - real(kind=kind_phys) WK1(IM), WK2(IM), WK3(IM), PROD(IM,pl_coeff), - & OZIB(IM), COLO3(IM,LEVS+1) -! - if (pl_coeff .gt. 2) then - colo3(:,levs+1) = 0.0 - do l=levs,1,-1 - do i=1,im - colo3(i,l) = colo3(i,l+1) + ozi(i,l) * delp(i,l) * gravi - enddo - enddo - endif -! - DO L=1,levs - PMIN = 1.0E10 - PMAX = -1.0E10 -! - DO I=1,IM - WK1(I) = log(prsl(I,l)) - PMIN = MIN(WK1(I), PMIN) - PMAX = MAX(WK1(I), PMAX) - prod(i,:) = 0.0 - ENDDO - kmax = 1 - kmin = 1 - do K=1,KO3-1 - if (pmin .lt. po3(k)) kmax = k - if (pmax .lt. po3(k)) kmin = k - enddo -! - do K=kmin,kmax - temp = 1.0 / (po3(k) - po3(k+1)) - do i=1,IM - flg(i) = .false. - if (wk1(i) .lt. po3(k) .and. wk1(i) .ge. po3(k+1)) then - flg(i) = .true. - wk2(i) = (wk1(i) - po3(k+1)) * temp - wk3(i) = 1.0 - wk2(i) - endif - enddo - do j=1,pl_coeff - do i=1,IM - if (flg(i)) then - prod(i,j) = wk2(i) * prdout(i,k,j) - & + wk3(i) * prdout(i,k+1,j) - endif - enddo - enddo - enddo -! - do j=1,pl_coeff - do i=1,IM - if (wk1(i) .lt. po3(ko3)) then - prod(i,j) = prdout(i,ko3,j) - endif - if (wk1(i) .ge. po3(1)) then - prod(i,j) = prdout(i,1,j) - endif - enddo - enddo - if (pl_coeff .eq. 2) then - do i=1,IM - OZIB(I) = OZI(I,L) ! NO FILLING - ozo(i,l) = (OZIB(I) + prod(i,1)*dt) / (1.0 + prod(i,2)*dt) - enddo -! - IF (LDIAG3D .or. LGGFS3D) then ! Ozone change diagnostics - DO I=1,IM - OZP(I,L,1) = OZP(I,L,1) + PROD(I,1)*DT - OZP(I,L,2) = OZP(I,L,2) + (OZO(I,L) - OZIB(I)) - ENDDO - ENDIF - endif - if (pl_coeff .eq. 4) then - do i=1,IM - OZIB(I) = OZI(I,L) ! NO FILLING - tem = prod(i,1) + prod(i,3)*tin(i,l) - & + prod(i,4)*colo3(i,l+1) -! if (me .eq. 0) print *,'ozphys tem=',tem,' prod=',prod(i,:) -! &,' ozib=',ozib(i),' l=',l,' tin=',tin(i,l),'colo3=',colo3(i,l+1) - ozo(i,l) = (OZIB(I) + tem*dt) / (1.0 + prod(i,2)*dt) - enddo - IF (LDIAG3D .or. LGGFS3D) then ! Ozone change diagnostics - DO I=1,IM - OZP(I,L,1) = OZP(I,L,1) + PROD(I,1)*DT - OZP(I,L,2) = OZP(I,L,2) + (OZO(I,L) - OZIB(I)) - OZP(I,L,3) = OZP(I,L,3) + PROD(I,3)*tin(i,l)*DT - OZP(I,L,4) = OZP(I,L,4) + PROD(I,4)*colo3(i,l+1)*DT - ENDDO - ENDIF - endif - enddo ! Vertical Loop -! - RETURN - END diff --git a/src/fim/FIMsrc/fim/column/physcons_v.F90 b/src/fim/FIMsrc/fim/column/physcons_v.F90 deleted file mode 100644 index 776a677..0000000 --- a/src/fim/FIMsrc/fim/column/physcons_v.F90 +++ /dev/null @@ -1,55 +0,0 @@ - MODULE physcons - use machine,only:kind_phys -! Physical constants as set in NMC handbook from Smithsonian tables. -! Physical constants are given to 5 places. -! 1990/04/30: g and rd are made consistent with NWS usage. -! 2001/10/22: g made consistent with SI usage. -! Math constants - real(kind=kind_phys),parameter:: con_pi =3.1415926535897931 ! pi - real(kind=kind_phys),parameter:: con_sqrt2 =1.414214e+0 ! square root of 2 - real(kind=kind_phys),parameter:: con_sqrt3 =1.732051e+0 ! square root of 3 -! Primary constants - real(kind=kind_phys),parameter:: con_rerth =6.3712e+6 ! radius of earth (m) - real(kind=kind_phys),parameter:: con_g =9.80665e+0! gravity (m/s2) - real(kind=kind_phys),parameter:: con_omega =7.2921e-5 ! ang vel of earth (1/s) - real(kind=kind_phys),parameter:: con_rd =2.8705e+2 ! gas constant air (J/kg/K) - real(kind=kind_phys),parameter:: con_rv =4.6150e+2 ! gas constant H2O (J/kg/K) - real(kind=kind_phys),parameter:: con_cp =1.0046e+3 ! spec heat air @p (J/kg/K) - real(kind=kind_phys),parameter:: con_cv =7.1760e+2 ! spec heat air @v (J/kg/K) - real(kind=kind_phys),parameter:: con_cvap =1.8460e+3 ! spec heat H2O gas (J/kg/K) - real(kind=kind_phys),parameter:: con_cliq =4.1855e+3 ! spec heat H2O liq (J/kg/K) - real(kind=kind_phys),parameter:: con_csol =2.1060e+3 ! spec heat H2O ice (J/kg/K) - real(kind=kind_phys),parameter:: con_hvap =2.5000e+6 ! lat heat H2O cond (J/kg) - real(kind=kind_phys),parameter:: con_hfus =3.3358e+5 ! lat heat H2O fusion (J/kg) - real(kind=kind_phys),parameter:: con_psat =6.1078e+2 ! pres at H2O 3pt (Pa) -! jbao new gfs phys - real(kind=kind_phys),parameter:: con_c =2.99792458e+8 ! speed of light (m/s) - real(kind=kind_phys),parameter:: con_plnk =6.6260693e-34 ! planck constatn (J/s) - real(kind=kind_phys),parameter:: con_boltz =1.3806505e-23 ! boltzmann constant (J/K) - real(kind=kind_phys),parameter:: con_avgd =6.0221415e23 ! avogadro constant (1/mol) - real(kind=kind_phys),parameter:: con_amd =28.9644 ! molecular wght of dry air (g/mol) - real(kind=kind_phys),parameter:: con_amw =18.0154 ! molecular wght of water vapor (g/mol) - real(kind=kind_phys),parameter:: con_amo3 =47.9982 ! molecular wght of o3 (g/mol) -! end jbao new gfs phys - real(kind=kind_phys),parameter:: con_sbc =5.6730e-8 ! stefan-boltzmann (W/m2/K4) - real(kind=kind_phys),parameter:: con_solr =1.3533e+3 ! solar constant (W/m2) - real(kind=kind_phys),parameter:: con_t0c =2.7315e+2 ! temp at 0C (K) -! jbao new gfs physics - real(kind=kind_phys),parameter:: con_tice =2.7120e+2 ! temp freezing sea (K) - real(kind=kind_phys),parameter:: con_ttp =2.7316e+2 ! temp at H2O 3pt (K) - real(kind=kind_phys),parameter:: con_jcal =4.1855E+0 ! JOULES PER CALORIE () -! jbao new gfs physics - real(kind=kind_phys),parameter:: con_rhw0 =1022.0 ! sea water reference density (kg/m^3) - real(kind=kind_phys),parameter:: con_epsq =1.0E-12 ! min q for computing precip type -! end jbao new gfs phys -! Secondary constants - real(kind=kind_phys),parameter:: con_rocp =con_rd/con_cp - real(kind=kind_phys),parameter:: con_cpor =con_cp/con_rd - real(kind=kind_phys),parameter:: con_rog =con_rd/con_g - real(kind=kind_phys),parameter:: con_fvirt =con_rv/con_rd-1. - real(kind=kind_phys),parameter:: con_eps =con_rd/con_rv - real(kind=kind_phys),parameter:: con_epsm1 =con_rd/con_rv-1. - real(kind=kind_phys),parameter:: con_dldt =con_cvap-con_cliq - real(kind=kind_phys),parameter:: con_xpona =-con_dldt/con_rv - real(kind=kind_phys),parameter:: con_xponb =-con_dldt/con_rv+con_hvap/(con_rv*con_ttp) -end module diff --git a/src/fim/FIMsrc/fim/column/precpd_v.f b/src/fim/FIMsrc/fim/column/precpd_v.f deleted file mode 100644 index 2b19445..0000000 --- a/src/fim/FIMsrc/fim/column/precpd_v.f +++ /dev/null @@ -1,499 +0,0 @@ - SUBROUTINE PRECPD (IM,IX,KM,DT,DEL,PRSL,PS,Q,CWM,T,RN - &, RAINP,u00k,lprnt,jpr) -! -! -! ****************************************************************** -! * * -! * SUBROUTINE FOR PRECIPITATION PROCESSES * -! * FROM SUSPENDED CLOUD WATER/ICE * -! * * -! ****************************************************************** -! * * -! * Originally CREATED BY Q. ZHAO JAN. 1995 * -! * ------- * -! * Modified and rewritten by Shrinivas Moorthi Oct. 1998 * -! * ----------------- * -! * and Hua-Lu Pan * -! * ---------- * -! * * -! * References: * -! * * -! * Zhao and Carr (1997), Monthly Weather Review (August) * -! * Sundqvist et al., (1989) Monthly Weather review. (August) * -! * * -! ****************************************************************** -! -! In this code vertical indexing runs from surface to top of the -! model -! -! Argument List: -! -------------- -! IM : Inner dimension over which calculation is made -! IX : Maximum inner dimension -! KM : Number of vertical levels -! DT : Time step in seconds -! DEL(KM) : Pressure layer thickness (Bottom to top) -! PRSL(KM) : Pressure values for model layers (bottom to top) -! PS(IM) : Surface pressure (centibars) -! Q(IX,KM) : Specific Humidity (Updated in the code) -! CWM(IX,KM) : Condensate mixing ratio (Updated in the code) -! T(IX,KM) : Temperature (Updated in the code) -! RN(IM) : Precipitation over one time-step DT (m/DT) -! SR(IM) : Index (=-1 Snow, =0 Rain/Snow, =1 Rain) -! TCW(IM) : Vertically integrated liquid water (Kg/m**2) -! CLL(IX,KM) : Cloud cover -!hchuang RN(IM) unit in m per time step -! precipitation rate conversion 1 mm/s = 1 kg/m2/s -! - USE MACHINE , ONLY : kind_phys - USE FUNCPHYS , ONLY : fpvs - USE PHYSCONS, grav => con_g, HVAP => con_HVAP, HFUS => con_HFUS - &, TTP => con_TTP, CP => con_CP - &, EPS => con_eps, EPSM1 => con_epsm1 - implicit none -! include 'constant.h' -! - real (kind=kind_phys) G, H1, H2, H1000 - &, H1000G, D00, D125, D5 - &, ELWV, ELIV, ROW - &, EPSQ, DLDT, TM10, ELIW - &, RCP, RROW - PARAMETER (G=grav, H1=1.E0, H2=2.E0, H1000=1000.0 - &, H1000G=H1000/G, D00=0.E0, D125=.125E0, D5=0.5E0 - &, ELWV=HVAP, ELIV=HVAP+HFUS, ROW=1.E3 - &, EPSQ=2.E-12, DLDT=2274.E0,TM10=TTP-10.0 - &, ELIW=ELIV-ELWV, RCP=H1/CP, RROW=H1/ROW) -! - real(kind=kind_phys), parameter :: cons_0=0.0, cons_p01=0.01 - &, cons_20=20.0 - &, cons_m30=-30.0, cons_50=50.0 -! - integer IM, IX, KM, LAT, jpr - real (kind=kind_phys) Q(IX,KM), T(IX,KM), CWM(IX,KM) - &, DEL(IX,KM), PRSL(IX,KM) -! &, CLL(IM,KM), DEL(IX,KM), PRSL(IX,KM) - &, PS(IM), RN(IM), SR(IM) - &, TCW(IM), DT -!hchuang code change [+1L] : add record to record information in vertical in -! addition to total column PRECRL - &, RAINP(IM,KM), RNP(IM) -! -! - real (kind=kind_phys) ERR(IM), ERS(IM), PRECRL(IM) - &, PRECSL(IM), PRECRL1(IM), PRECSL1(IM) - &, RQ(IM), CONDT(IM) - &, CONDE(IM), RCONDE(IM), TMT0(IM) - &, WMIN(IM,KM), WMINK(IM), PRES(IM) - &, WMINI(IM,KM), CCR(IM), CCLIM(KM) - &, TT(IM), QQ(IM), WW(IM) - &, WFIX(KM), U00K(IM,KM), ES(IM) - &, Zaodt -! - integer IW(IM,KM), IPR(IM), IWL(IM), IWL1(IM) -! - LOGICAL COMPUT(IM) - logical lprnt -! - real (kind=kind_phys) ke, rdt, us, cclimit, climit, cws, csm1 - &, crs1, crs2, cr, aa2, dtcp, c00, cmr - &, tem, c1, c2, wwn -! &, tem, c1, c2, u00b, u00t, wwn - &, precrk, precsk, pres1, qk, qw, qi - &, ai, bi, qint, fiw, wws, cwmk, expf - &, psaut, psaci, amaxcm, tem1, tem2 - &, tmt0k, tmt15, psm1, psm2, ppr - &, rprs, erk, pps, sid, rid, amaxps - &, praut, pracw, fi, qc, amaxrq, rqkll - integer i, k, ihpr, n -! -!-----------------------Preliminaries --------------------------------- -! -! DO K=1,KM -! DO I=1,IM -! CLL(I,K) = 0.0 -! ENDDO -! ENDDO -! - RDT = H1 / DT - KE = 2.0E-5 ! commented on 09/10/99 -! KE = 2.0E-6 -! KE = 1.0E-5 -! KE = 5.0E-5 - US = H1 - CCLIMIT = 1.0E-3 - CLIMIT = 1.0E-20 - CWS = 0.025 -! - zaodt = 800.0 * RDT -! - CSM1 = 5.0000E-8 * zaodt - CRS1 = 5.00000E-6 * zaodt - CRS2 = 6.66600E-10 * zaodt - CR = 5.0E-4 * zaodt - AA2 = 1.25E-3 * zaodt -! - ke = ke * sqrt(rdt) -! ke = ke * sqrt(zaodt) -! - DTCP = DT * RCP -! -! C00 = 1.5E-1 * DT -! C00 = 10.0E-1 * DT -! C00 = 3.0E-1 * DT !05/09/2000 - C00 = 1.0E-4 * DT !05/09/2000 - CMR = 1.0 / 3.0E-4 -! CMR = 1.0 / 5.0E-4 -! C1 = 100.0 - C1 = 300.0 - C2 = 0.5 -! -! -!--------CALCULATE C0 AND CMR USING LC AT PREVIOUS STEP----------------- -! - DO K=1,KM - DO I=1,IM - tem = (prsl(i,k)*0.01) -! tem = sqrt(tem) - IW(I,K) = 0.0 - wmin(i,k) = 1.0e-5 * tem - wmini(i,k) = 1.0e-5 * tem ! Testing for RAS -! wmin(i,k) = 5.0e-6 * tem ! Testing -! wmini(i,k) = 5.0e-6 * tem ! Testing -! wmin(i,k) = 3.0e-6 * tem ! Testing -! wmini(i,k) = 3.0e-6 * tem ! Testing -! wmini(i,k) = 1.0e-6 * tem ! for SAS - - rainp(i,k) = 0.0 - - ENDDO - ENDDO - DO I=1,IM -! C0(I) = 1.5E-1 -! CMR(I) = 3.0E-4 -! - IWL1(I) = 0 - PRECRL1(I) = D00 - PRECSL1(I) = D00 - COMPUT(I) = .FALSE. - RN(I) = D00 - SR(I) = D00 - ccr(i) = D00 -! - RNP(I) = D00 - ENDDO -!------------SELECT COLUMNS WHERE RAIN CAN BE PRODUCED-------------- - DO K=1, KM-1 - DO I=1,IM - tem = min(wmin(i,k), wmini(i,k)) - IF (CWM(I,K) .GT. tem) COMPUT(I) = .TRUE. - ENDDO - ENDDO - IHPR = 0 - DO I=1,IM - IF (COMPUT(I)) THEN - IHPR = IHPR + 1 - IPR(IHPR) = I - ENDIF - ENDDO -!*********************************************************************** -!-----------------BEGINING OF PRECIPITATION CALCULATION----------------- -!*********************************************************************** -! DO K=KM-1,2,-1 - DO K=KM,1,-1 - DO N=1,IHPR - PRECRL(N) = PRECRL1(N) - PRECSL(N) = PRECSL1(N) - ERR (N) = D00 - ERS (N) = D00 - IWL (N) = 0 -! - I = IPR(N) - TT(N) = T(I,K) - QQ(N) = Q(I,K) - WW(N) = CWM(I,K) - WMINK(N) = WMIN(I,K) - PRES(N) = H1000 * prSL(I,K) -! - PRECRK = MAX(cons_0, PRECRL1(N)) - PRECSK = MAX(cons_0, PRECSL1(N)) - WWN = MAX(WW(N), CLIMIT) -! IF (WWN .GT. WMINK(N) .OR. (PRECRK+PRECSK) .GT. D00) THEN - IF (WWN .GT. CLIMIT .OR. (PRECRK+PRECSK) .GT. D00) THEN - COMPUT(N) = .TRUE. - ELSE - COMPUT(N) = .FALSE. - ENDIF - ENDDO -! -! es(1:IHPR) = fpvs(TT(1:IHPR)) - DO N=1,IHPR - IF (COMPUT(N)) THEN - I = IPR(N) - CONDE(N) = (H1000*DT/G) * DEL(I,K) - CONDT(N) = CONDE(N) * RDT - RCONDE(N) = H1 / CONDE(N) - QK = MAX(EPSQ, QQ(N)) - TMT0(N) = TT(N) - 273.16 - WWN = MAX(WW(N), CLIMIT) -! -! PL = PRES(N) * 0.01 -! CALL QSATD(TT(N), PL, QC) -! RQ(N) = MAX(QQ(N), EPSQ) / MAX(QC, 1.0E-10) -! RQ(N) = MAX(1.0E-10, RQ(N)) ! -- RELATIVE HUMIDITY--- -! -! the global qsat computation is done in Pa - pres1 = pres(n) -! QW = es(N) - QW = min(pres1, fpvs(TT(N))) - QW = EPS * QW / (PRES1 + EPSM1 * QW) - QW = MAX(QW,EPSQ) -! -! TMT15 = MIN(TMT0(N), cons_m15) -! AI = 0.008855 -! BI = 1.0 -! IF (TMT0(N) .LT. -20.0) THEN -! AI = 0.007225 -! BI = 0.9674 -! ENDIF -! QI = QW * (BI + AI*MIN(TMT0(N),cons_0)) -! QINT = QW * (1.-0.00032*TMT15*(TMT15+15.)) -! - qi = qw - qint = qw -! IF (TMT0(N).LE.-40.) QINT = QI -! -!-------------------ICE-WATER ID NUMBER IW------------------------------ - IF(TMT0(N).LT.-15.) THEN - FI = QK - U00K(I,K)*QI - IF(FI.GT.D00.OR.WWN.GT.CLIMIT) THEN - IWL(N) = 1 - ELSE - IWL(N) = 0 - ENDIF -! ENDIF - ELSEIF (TMT0(N).GE.0.) THEN - IWL(N) = 0 -! -! IF(TMT0(N).LT.0.0.AND.TMT0(N).GE.-15.0) THEN - ELSE - IWL(N) = 0 - IF(IWL1(N).EQ.1.AND.WWN.GT.CLIMIT) IWL(N)=1 - ENDIF -! -! IF(TMT0(N).GE.0.) THEN -! IWL(N) = 0 -! ENDIF -!----------------THE SATUATION SPECIFIC HUMIDITY------------------------ - FIW = FLOAT(IWL(N)) - QC = (H1-FIW)*QINT + FIW*QI -!----------------THE RELATIVE HUMIDITY---------------------------------- - IF(QC .LE. 1.0E-10) THEN - RQ(N) = D00 - ELSE - RQ(N) = QK / QC - ENDIF -!----------------CLOUD COVER RATIO CCR---------------------------------- - IF(RQ(N).LT.U00K(I,K)) THEN - CCR(N)=D00 - ELSEIF(RQ(N).GE.US) THEN - CCR(N)=US - ELSE - RQKLL=MIN(US,RQ(N)) - CCR(N)= H1-SQRT((US-RQKLL)/(US-U00K(I,K))) - ENDIF -! - ENDIF - ENDDO -!-------------------ICE-WATER ID NUMBER IWL------------------------------ -! DO N=1,IHPR -! IF (COMPUT(N) .AND. (WW(N) .GT. CLIMIT)) THEN -! IF (TMT0(N) .LT. -15.0 -! * .OR. (TMT0(N) .LT. 0.0 .AND. IWL1(N) .EQ. 1)) -! * IWL(N) = 1 -! CLL(IPR(N),K) = 1.0 ! Cloud Cover! -! CLL(IPR(N),K) = MIN(1.0, WW(N)*CCLIM(K)) ! Cloud Cover! -! ENDIF -! ENDDO -! -!--- PRECIPITATION PRODUCTION -- Auto Conversion and Accretion -! - DO N=1,IHPR - IF (COMPUT(N) .AND. CCR(N) .GT. 0.0) THEN - WWS = WW(N) - CWMK = MAX(cons_0, WWS) -! AMAXCM = MAX(cons_0, CWMK - WMINK(N)) - IF (IWL(N) .EQ. 1) THEN ! Ice Phase - AMAXCM = MAX(cons_0, CWMK - WMINI(IPR(N),K)) - EXPF = DT * EXP(0.025*TMT0(N)) -! PSAUT = MIN(CWMK, 2.0E-3*EXPF*AMAXCM) -! PSAUT = MIN(CWMK, 1.0E-3*EXPF*AMAXCM) -! PSAUT = MIN(CWMK, 5.0E-4*EXPF*AMAXCM) - PSAUT = MIN(CWMK, 4.0E-4*EXPF*AMAXCM) - WW(N) = WW(N) - PSAUT - CWMK = MAX(cons_0, WW(N)) -! CWMK = MAX(cons_0, WW(N)-wmini(ipr(n),k)) - PSACI = MIN(CWMK, AA2*EXPF*PRECSL1(N)*CWMK) - - WW(N) = WW(N) - PSACI - - PRECSL(N) = PRECSL(N) + (WWS - WW(N)) * CONDT(N) - ELSE ! Liquid Water -! -! For using Sundqvist precip formulation of rain -! -! AMAXCM = MAX(cons_0, CWMK - WMINK(N)) - AMAXCM = CWMK - TEM1 = PRECSL1(N) + PRECRL1(N) - TEM2 = MIN(MAX(cons_0, 268.0-TT(N)), cons_20) - TEM = (1.0+C1*SQRT(TEM1*RDT)) * (1+C2*SQRT(TEM2)) -! - TEM2 = AMAXCM * CMR * TEM / max(CCR(N),cons_p01) - TEM2 = MIN(cons_50, TEM2*TEM2) - PRAUT = C00 * TEM * AMAXCM * (1.0-EXP(-TEM2)) - PRAUT = MIN(PRAUT, CWMK) - WW(N) = WW(N) - PRAUT -! -! Below is for Zhao's precip formulation (water) -! -! AMAXCM = MAX(cons_0, CWMK - WMINK(N)) -! PRAUT = MIN(CWMK, C00*AMAXCM*AMAXCM) -! WW(N) = WW(N) - PRAUT -! -! CWMK = MAX(cons_0, WW(N)) -! TEM1 = PRECSL1(N) + PRECRL1(N) -! PRACW = MIN(CWMK, CR*DT*TEM1*CWMK) -! WW(N) = WW(N) - PRACW -! - PRECRL(N) = PRECRL(N) + (WWS - WW(N)) * CONDT(N) -! -!hchuang code change [+1L] : add record to record information in vertical -! TURN RNP in unit of WW (CWM and Q, kg/kg ???) - RNP(N) = RNP(N) + (WWS - WW(N)) - ENDIF - ENDIF - ENDDO -! -!-----EVAPORATION OF PRECIPITATION------------------------- -!**** ERR & ERS POSITIVE--->EVAPORATION-- NEGTIVE--->CONDENSATION -! - DO N=1,IHPR - IF (COMPUT(N)) THEN - I = IPR(N) - QK = MAX(EPSQ, QQ(N)) - TMT0K = MAX(cons_m30, TMT0(N)) - PRECRK = MAX(cons_0, PRECRL(N)) - PRECSK = MAX(cons_0, PRECSL(N)) - AMAXRQ = MAX(cons_0, U00K(I,K)-RQ(N)) * CONDE(N) -!---------------------------------------------------------------------- -! INCREASE THE EVAPORATION FOR STRONG/LIGHT PREC -!---------------------------------------------------------------------- - PPR = KE * AMAXRQ * SQRT(PRECRK) -! PPR = KE * AMAXRQ * SQRT(PRECRK*RDT) - IF (TMT0(N) .GE. 0.) THEN - PPS = 0. - ELSE - PPS = (CRS1+CRS2*TMT0K) * AMAXRQ * PRECSK / U00K(I,K) - END IF -!---------------CORRECT IF OVER-EVAPO./COND. OCCURS-------------------- - ERK=PRECRK+PRECSK - IF(RQ(N).GE.1.0E-10) ERK = AMAXRQ * QK * RDT / RQ(N) - IF (PPR+PPS .GT. ABS(ERK)) THEN - RPRS = ERK / (PRECRK+PRECSK) - PPR = PRECRK * RPRS - PPS = PRECSK * RPRS - ENDIF - PPR = MIN(PPR, PRECRK) - PPS = MIN(PPS, PRECSK) - ERR(N) = PPR * RCONDE(N) - ERS(N) = PPS * RCONDE(N) - PRECRL(N) = PRECRL(N) - PPR -!hchuang code change [+1L] : add record to record information in vertical -! Use ERR for kg/kg/DT not the PPR (mm/DT=kg/m2/DT) -! - RNP(N) = RNP(N) - ERR(N) -! - PRECSL(N) = PRECSL(N) - PPS - ENDIF - ENDDO -!--------------------MELTING OF THE SNOW-------------------------------- - DO N=1,IHPR - IF (COMPUT(N)) THEN - IF (TMT0(N) .GT. 0.) THEN - AMAXPS = MAX(cons_0, PRECSL(N)) - PSM1 = CSM1 * TMT0(N) * TMT0(N) * AMAXPS - PSM2 = CWS * CR * MAX(cons_0, WW(N)) * AMAXPS - PPR = (PSM1 + PSM2) * CONDE(N) - IF (PPR .GT. AMAXPS) THEN - PPR = AMAXPS - PSM1 = AMAXPS * RCONDE(N) - ENDIF - PRECRL(N) = PRECRL(N) + PPR -! -!hchuang code change [+1L] : add record to record information in vertical -! TURN PPR (mm/DT=kg/m2/DT) to kg/kg/DT -> PPR/air density (kg/m3) - RNP(N) = RNP(N) + PPR * RCONDE(N) -! - PRECSL(N) = PRECSL(N) - PPR - ELSE - PSM1 = D00 - ENDIF -! -!---------------UPDATE T AND Q------------------------------------------ - TT(N) = TT(N) - DTCP * (ELWV*ERR(N)+ELIV*ERS(N)+ELIW*PSM1) - QQ(N) = QQ(N) + DT * (ERR(N)+ERS(N)) - ENDIF - ENDDO -! - DO N=1,IHPR - IWL1(N) = IWL(N) - PRECRL1(N) = MAX(cons_0, PRECRL(N)) - PRECSL1(N) = MAX(cons_0, PRECSL(N)) - I = IPR(N) - T(I,K) = TT(N) - Q(I,K) = QQ(N) - CWM(I,K) = WW(N) - IW(I,K) = IWL(N) -!hchuang code change [+1L] : add record to record information in vertical -! RNP = PRECRL1*RCONDE(N) unit in kg/kg/DT -! - RAINP(I,K) = RNP(N) - ENDDO -! -! move water from vapor to liquid should the liquid amount be negative -! - do i = 1, im - if (cwm(i,k) < 0.) then - tem = q(i,k) + cwm(i,k) - if (tem >= 0.0) then - q(i,k) = tem - t(i,k) = t(i,k) - elwv * rcp * cwm(i,k) - cwm(i,k) = 0. - elseif (q(i,k) > 0.0) then - cwm(i,k) = tem - t(i,k) = t(i,k) + elwv * rcp * q(i,k) - q(i,k) = 0.0 - endif - endif - enddo -! - ENDDO ! K loop ends here! -!********************************************************************** -!-----------------------END OF PRECIPITATION PROCESSES----------------- -!********************************************************************** -! - DO N=1,IHPR - I = IPR(N) - RN(I) = (PRECRL1(N) + PRECSL1(N)) * RROW ! Precip at surface -! -!----SR=1 IF SFC PREC IS RAIN ; ----SR=-1 IF SFC PREC IS SNOW -!----SR=0 FOR BOTH OF THEM OR NO SFC PREC -! - RID = 0. - SID = 0. - IF (PRECRL1(N) .GE. 1.E-13) RID = 1. - IF (PRECSL1(N) .GE. 1.E-13) SID = -1. - SR(I) = RID + SID ! SR=1 --> Rain, SR=-1 -->Snow, SR=0 -->Both - ENDDO -! - RETURN - END diff --git a/src/fim/FIMsrc/fim/column/progt2_v.f b/src/fim/FIMsrc/fim/column/progt2_v.f deleted file mode 100755 index e337209..0000000 --- a/src/fim/FIMsrc/fim/column/progt2_v.f +++ /dev/null @@ -1,246 +0,0 @@ - SUBROUTINE PROGT2(IM,KM,RHSCNPY, - & RHSMC,AI,BI,CI,SMC,SLIMSK, - & CANOPY,PRECIP,RUNOFF,SNOWMT, - & ZSOIL,SOILTYP,SIGMAF,DELT,me) -cc - USE MACHINE , ONLY : kind_phys -! USE MACHINE_RAD , ONLY : kind_phys - implicit none - integer km, IM, me - real(kind=kind_phys) delt - real(kind=kind_phys) RHSCNPY(IM), RHSMC(IM,KM), AI(IM,KM), - & BI(IM,KM), CI(IM,KM), SMC(IM,KM), - & SLIMSK(IM), CANOPY(IM), PRECIP(IM), - & RUNOFF(IM), SNOWMT(IM), ZSOIL(IM,KM), - & SIGMAF(IM) - INTEGER SOILTYP(IM) -! - integer k, lond, i - real(kind=kind_phys) CNPY(IM), PRCP(IM), TSAT(IM), - & INF(IM), INFMAX(IM), SMSOIL(IM,KM) -! - real(kind=kind_phys) cc, ctfil1, ctfil2, delt2, - & drip, rffact, rhoh2o, - & rzero, scanop, tdif, thsat, KSAT -! - LOGICAL FLAG(IM) -cc - PARAMETER (SCANOP=.5, RHOH2O=1000.) - PARAMETER (CTFIL1=.5, CTFIL2=1.-CTFIL1) -c PARAMETER (CTFIL1=1., CTFIL2=1.-CTFIL1) - PARAMETER (RFFACT=.15) -C -C##DG LATD = 44 - LOND = 353 - DELT2 = DELT * 2. - - DO I=1,IM - FLAG(I) = SLIMSK(I).EQ.1. - ENDDO - -C -C PRECIPITATION RATE IS NEEDED IN UNIT OF KG M-2 S-1 -C - DO I=1,IM - IF(FLAG(I)) THEN - PRCP(I) = RHOH2O * (PRECIP(I)+SNOWMT(I)) / DELT - RUNOFF(I) = 0. - CNPY(I) = CANOPY(I) - ENDIF - ENDDO -C##DG IF(LAT.EQ.LATD) THEN -C##DG PRINT *, ' BEFORE RUNOFF CAL, RHSMC =', RHSMC(1) -C##DG ENDIF -C -C UPDATE CANOPY WATER CONTENT -C - DO I=1,IM - IF(FLAG(I)) THEN - RHSCNPY(I) = RHSCNPY(I) + SIGMAF(I) * PRCP(I) - CANOPY(I) = CANOPY(I) + DELT * RHSCNPY(I) - CANOPY(I) = MAX(CANOPY(I),0.) - PRCP(I) = PRCP(I) * (1. - SIGMAF(I)) - IF(CANOPY(I).GT.SCANOP) THEN - DRIP = CANOPY(I) - SCANOP - CANOPY(I) = SCANOP - PRCP(I) = PRCP(I) + DRIP / DELT - ENDIF -C -C CALCULATE INFILTRATION RATE -C - INF(I) = PRCP(I) - TSAT(I) = THSAT(SOILTYP(I)) -C DSAT = FUNCDF(TSAT(I),SOILTYP(I)) -C KSAT = FUNCKT(TSAT(I),SOILTYP(I)) -C INFMAX(I) = -DSAT * (TSAT(I) - SMC(I,1)) -C & / (.5 * ZSOIL(I,1)) -C & + KSAT - INFMAX(I) = (-ZSOIL(I,1)) * - & ((TSAT(I) - SMC(I,1)) / DELT - RHSMC(I,1)) - & * RHOH2O - INFMAX(I) = MAX(RFFACT*INFMAX(I),0.) -C IF(SMC(I,1).GE.TSAT(I)) INFMAX(I) = KSAT -C IF(SMC(I,1).GE.TSAT(I)) INFMAX(I) = ZSOIL(I,1) * RHSMC(I,1) - IF(INF(I).GT.INFMAX(I)) THEN - RUNOFF(I) = INF(I) - INFMAX(I) - INF(I) = INFMAX(I) - ENDIF - INF(I) = INF(I) / RHOH2O - RHSMC(I,1) = RHSMC(I,1) - INF(I) / ZSOIL(I,1) - ENDIF - ENDDO -!! -C##DG IF(LAT.EQ.LATD) THEN -C##DG PRINT *, ' PRCP(I), INFMAX(I), RUNOFF =', PRCP(I),INFMAX(I),RUNOFF -C##DG PRINT *, ' SMSOIL =', SMC(1), SMC(2) -C##DG PRINT *, ' RHSMC =', RHSMC(1) -C##DG ENDIF -C -C WE CURRENTLY IGNORE THE EFFECT OF RAIN ON SEA ICE -C -!! -C -C SOLVE THE TRI-DIAGONAL MATRIX -C - DO K = 1, KM - DO I=1,IM - IF(FLAG(I)) THEN - RHSMC(I,K) = RHSMC(I,K) * DELT2 - AI(I,K) = AI(I,K) * DELT2 - BI(I,K) = 1. + BI(I,K) * DELT2 - CI(I,K) = CI(I,K) * DELT2 - ENDIF - ENDDO - ENDDO -C FORWARD ELIMINATION - DO I=1,IM - IF(FLAG(I)) THEN - CI(I,1) = -CI(I,1) / BI(I,1) - RHSMC(I,1) = RHSMC(I,1) / BI(I,1) - ENDIF - ENDDO - DO K = 2, KM - DO I=1,IM - IF(FLAG(I)) THEN - CC = 1. / (BI(I,K) + AI(I,K) * CI(I,K-1)) - CI(I,K) = -CI(I,K) * CC - RHSMC(I,K)=(RHSMC(I,K)-AI(I,K)*RHSMC(I,K-1))*CC - ENDIF - ENDDO - ENDDO -C BACKWARD SUBSTITUTTION - DO I=1,IM - IF(FLAG(I)) THEN - CI(I,KM) = RHSMC(I,KM) - ENDIF - ENDDO -!! - DO K = KM-1, 1 - DO I=1,IM - IF(FLAG(I)) THEN - CI(I,K) = CI(I,K) * CI(I,K+1) + RHSMC(I,K) - ENDIF - ENDDO - ENDDO - 100 CONTINUE -C -C UPDATE SOIL MOISTURE -C - DO K = 1, KM - DO I=1,IM - IF(FLAG(I)) THEN - SMSOIL(I,K) = SMC(I,K) + CI(I,K) - SMSOIL(I,K) = MAX(SMSOIL(I,K),0.) - TDIF = MAX(SMSOIL(I,K) - TSAT(I),0.) - RUNOFF(I) = RUNOFF(I) - - & RHOH2O * TDIF * ZSOIL(I,K) / DELT - SMSOIL(I,K) = SMSOIL(I,K) - TDIF - ENDIF - ENDDO - ENDDO - DO K = 1, KM - DO I=1,IM - IF(FLAG(I)) THEN - SMC(I,K) = CTFIL1 * SMSOIL(I,K) + CTFIL2 * SMC(I,K) - ENDIF - ENDDO - ENDDO -c IF(FLAG(I)) THEN -c CANOPY(I) = CTFIL1 * CANOPY(I) + CTFIL2 * CNPY(I) -c ENDIF -C I = 1 -C PRINT *, ' SMC' -C PRINT 6000, SMC(1), SMC(2) -c6000 FORMAT(2(F8.5,',')) - RETURN - END - FUNCTION KTSOIL(THETA,KTYPE) -! - USE MACHINE , ONLY : kind_phys - USE module_progtm , ONLY : TSAT, DFKT - implicit none - integer ktype,kw - real(kind=kind_phys) ktsoil, theta, w -! - W = (THETA / TSAT(KTYPE)) * 20. + 1. - KW = W - KW = MIN(KW,21) - KW = MAX(KW,1) - KTSOIL = DFKT(KW,KTYPE) - & + (W - KW) * (DFKT(KW+1,KTYPE) - DFKT(KW,KTYPE)) - RETURN - END - FUNCTION FUNCDF(THETA,KTYPE) -! - USE MACHINE , ONLY : kind_phys - USE module_progtm , ONLY : TSAT, DFK - implicit none - integer ktype,kw - real(kind=kind_phys) funcdf,theta,w -! - W = (THETA / TSAT(KTYPE)) * 20. + 1. - KW = W - KW = MIN(KW,21) - KW = MAX(KW,1) - FUNCDF = DFK(KW,KTYPE) - & + (W - KW) * (DFK(KW+1,KTYPE) - DFK(KW,KTYPE)) - RETURN - END - FUNCTION FUNCKT(THETA,KTYPE) -! - USE MACHINE , ONLY : kind_phys - USE module_progtm , ONLY : TSAT, KTK - implicit none - integer ktype,kw - real(kind=kind_phys) funckt,theta,w -! - W = (THETA / TSAT(KTYPE)) * 20. + 1. - KW = W - KW = MIN(KW,21) - KW = MAX(KW,1) - FUNCKT = KTK(KW,KTYPE) - & + (W - KW) * (KTK(KW+1,KTYPE) - KTK(KW,KTYPE)) - RETURN - END - FUNCTION THSAT(KTYPE) -! - USE MACHINE , ONLY : kind_phys - USE module_progtm , ONLY : TSAT - implicit none - integer ktype - real(kind=kind_phys) thsat -! - THSAT = TSAT(KTYPE) - RETURN - END - FUNCTION TWLT(KTYPE) - - USE MACHINE , ONLY : kind_phys -! USE module_progtm - implicit none - integer ktype - real(kind=kind_phys) twlt -! - TWLT = .1 - RETURN - END diff --git a/src/fim/FIMsrc/fim/column/progtm_module.f b/src/fim/FIMsrc/fim/column/progtm_module.f deleted file mode 100755 index 6f5b3fc..0000000 --- a/src/fim/FIMsrc/fim/column/progtm_module.f +++ /dev/null @@ -1,93 +0,0 @@ - module module_progtm - USE MACHINE , ONLY : kind_phys - implicit none - SAVE -! - integer,parameter:: NTYPE=9 - integer,parameter:: NGRID=22 - real(kind=kind_phys) B(NTYPE), SATPSI(NTYPE), SATKT(NTYPE), - & TSAT(NTYPE), - & DFK(NGRID,NTYPE), - & KTK(NGRID,NTYPE), - & DFKT(NGRID,NTYPE) -! -! the nine soil types are: -! 1 ... loamy sand (coarse) -! 2 ... silty clay loam (medium) -! 3 ... light clay (fine) -! 4 ... sandy loam (coarse-medium) -! 5 ... sandy clay (coarse-fine) -! 6 ... clay loam (medium-fine) -! 7 ... sandy clay loam (coarse-med-fine) -! 8 ... loam (organic) -! 9 ... ice (use loamy sand property) -! -! DATA B/4.05,4.38,4.9,5.3,5.39,7.12,7.75,8.52, -! & 10.4,10.4,11.4/ -! DATA SATPSI/.121,.09,.218,.786,.478,.299,.356,.63, -! & .153,.49,.405/ -! DATA SATKT/1.76E-4,1.5633E-4,3.467E-5,7.2E-6,6.95E-6, -! & 6.3E-6,1.7E-6,2.45E-6,2.167E-6,1.033E-6, -! & 1.283E-6/ -! DATA TSAT/.395,.41,.435,.485,.451,.42,.477,.476, -! & .426,.492,.482/ - data b/4.26,8.72,11.55,4.74,10.73,8.17,6.77,5.25,4.26/ - data satpsi/.04,.62,.47,.14,.10,.26,.14,.36,.04/ - data satkt/1.41e-5,.20e-5,.10e-5,.52e-5,.72e-5, - & .25e-5,.45e-5,.34e-5,1.41e-5/ - data tsat/.421,.464,.468,.434,.406,.465,.404,.439,.421/ -! - contains - subroutine GRDDF - USE MACHINE , ONLY : kind_phys - implicit none - integer i, k - real(kind=kind_phys) dynw, f1, f2, theta -! -! GRDDF SETS UP MOISTURE DIFFUSIVITY AND HYDROLIC CONDUCTIVITY -! FOR ALL SOIL TYPES -! GRDDFS SETS UP THERMAL DIFFUSIVITY FOR ALL SOIL TYPES -! - DO K = 1, NTYPE - DYNW = TSAT(K) * .05 - F1 = B(K) * SATKT(K) * SATPSI(K) / TSAT(K) ** (B(K) + 3.) - F2 = SATKT(K) / TSAT(K) ** (B(K) * 2. + 3.) -! -! CONVERT FROM M/S TO KG M-2 S-1 UNIT -! - F1 = F1 * 1000. - F2 = F2 * 1000. - DO I = 1, NGRID - THETA = FLOAT(I-1) * DYNW - THETA = MIN(TSAT(K),THETA) - DFK(I,K) = F1 * THETA ** (B(K) + 2.) - KTK(I,K) = F2 * THETA ** (B(K) * 2. + 3.) - ENDDO - ENDDO - END SUBROUTINE - subroutine GRDKT - USE MACHINE , ONLY : kind_phys - implicit none - integer i, k - real(kind=kind_phys) dynw, f1, theta, pf - DO K = 1, NTYPE - DYNW = TSAT(K) * .05 - F1 = LOG10(SATPSI(K)) + B(K) * LOG10(TSAT(K)) + 2. - DO I = 1, NGRID - THETA = FLOAT(I-1) * DYNW - THETA = MIN(TSAT(K),THETA) - IF(THETA.GT.0.) THEN - PF = F1 - B(K) * LOG10(THETA) - ELSE - PF = 5.2 - ENDIF - IF(PF.LE.5.1) THEN - DFKT(I,K) = EXP(-(2.7+PF)) * 420. - ELSE - DFKT(I,K) = .1744 - ENDIF - ENDDO - ENDDO - END SUBROUTINE -! - end module module_progtm diff --git a/src/fim/FIMsrc/fim/column/radiation_aerosols.f b/src/fim/FIMsrc/fim/column/radiation_aerosols.f deleted file mode 100644 index 6f3b313..0000000 --- a/src/fim/FIMsrc/fim/column/radiation_aerosols.f +++ /dev/null @@ -1,2332 +0,0 @@ -!!!!! ========================================================== !!!!! -!!!!! 'module_radiation_aerosols' description !!!!! -!!!!! ========================================================== !!!!! -! ! -! this module contains different atmospheric aerosols schemes for ! -! radiation computations. ! -! ! -! in the module, the externally callable subroutines are : ! -! ! -! 'aerinit' -- initialization, input aerosol data, etc. ! -! inputs: ! -! (iyear, imon, IAER, me) ! -! outputs: ! -! (none) ! -! ! -! 'setaer' -- mapping aeros profile, compute aeros opticals ! -! inputs: ! -! (xlon,xlat,prsi,prsl,tlay,qlay,rhlay, ! -! IMAX,NLAY,NLP1,iflip,lsswr,lslwr) ! -! outputs: ! -! (aerosw,aerolw) ! -! ! -! ! -! internal subroutine called: ! -! clim_aerinit, setclimaer - for opac climatological aerosols ! -! ! -! gocart_init, setgocart - for gocart aerosols ! -! ! -! ! -! external modules referenced: ! -! ! -! 'module machine' in 'machine.f' ! -! 'module physcons' in 'physcons.f' ! -! 'module module_radsw_parameters' in 'radsw_xxxx#_param.f' ! -! 'module module_radlw_parameters' in 'radlw_xxxx#_param.f' ! -! 'module module_radlw_cntr_para' in 'radsw_xxxx#_param.f' ! -! ! -! output variable definitions: ! -! aerosw(IMAX,NLAY,NBDSW,1) - aerosols optical depth for sw ! -! aerosw(IMAX,NLAY,NBDSW,2) - aerosols single scat albedo for sw ! -! aerosw(IMAX,NLAY,NBDSW,3) - aerosols asymmetry parameter for sw! -! ! -! aerolw(IMAX,NLAY,NBDLW,1) - aerosols optical depth for lw ! -! aerolw(IMAX,NLAY,NBDLW,2) - aerosols single scattering albedo ! -! aerolw(IMAX,NLAY,NBDLW,3) - aerosols asymetry parameter ! -! ! -! ! -! program history: ! -! apr 2003 --- y.-t. hou created ! -! nov 04, 2003 --- y.-t. hou modified version ! -! apr 15, 2005 --- y.-t. hou modified module structure ! -! jul 2006 --- y.-t. hou add volcanic forcing ! -! feb 2007 --- y.-t. hou add generalized spectral band ! -! interpolation for sw aerosol optical properties ! -! mar 2007 --- y.-t. hou add generalized spectral band ! -! interpolation for lw aerosol optical properties ! -! ! -! ! -! references for opac climatological aerosols: ! -! hou et al. 2002 (ncep office note 441) ! -! hess et al. 1998 - bams v79 831-844 ! -! ! -! references for glcart interactive aerosols: ! -! ! -! ! -! references for stratosperic volcanical aerosols: ! -! sato et al. 1993 - jgr, v98, d12, 22987-22994 ! -! ! -! ! -!!!!! ========================================================== !!!!! -!!!!! end descriptions !!!!! -!!!!! ========================================================== !!!!! - - - -!========================================! - module module_radiation_aerosols ! -!........................................! -! - use machine, only : kind_io8, kind_phys - use physcons, only : con_pi, con_rd, con_fvirt, con_g, & - & con_t0c, con_c, con_boltz, con_plnk - - use module_iounitdef, only : NIAERCM - use module_radsw_parameters, only : NBDSW, NSWSTR, wvnum1, wvnum2 - use module_radlw_parameters, only : NBDLW, wvnlw1, wvnlw2 - use module_radlw_cntr_para, only : iaerlw - use module_control ,only: curve,NumCacheBLocksPerPE,alt_topo - & ,mtnvar_file,gfsltln_file,aerosol_file - & ,co2_2008_file,co2_glb_file -! - implicit none -! - private - -! --- general use parameter constants: - integer, parameter, public :: NF_AESW = 3 ! num of output fields for sw rad - integer, parameter, public :: NF_AELW = 3 ! num of output fields for lw rad - - real (kind=kind_phys), parameter :: f_zero = 0.0 - real (kind=kind_phys), parameter :: f_one = 1.0 - -! --- module control parameters set in subroutine "aerinit" - integer, save :: iaerflg = 1 ! choice of tropospheric aerosol schemes - ! =0 no aer; =1 opac; =2 gocart - logical, save :: lalwflg = .false. ! lw aerosols effect - ! =t compute lw aerosol optical prop - logical, save :: laswflg = .false. ! sw aerosols effect - ! =t compute sw aerosol optical prop - integer, save :: NBDIR = NBDLW ! num of actual bands for lw aerosols - ! calculated according to iaerlw setting - integer, save :: NBDSWLW = NBDSW+NBDLW - ! total num of bands for sw+lw aerosols - logical, save :: lvolflg = .false. ! volcanic forcing - ! =t include stratos volcanic forcing - -! --------------------------------------------------------------------- ! -! section-1 : module variables for spectral band interpolation ! -! similar to gfdl-sw treatment (2000 version) ! -! --------------------------------------------------------------------- ! - -! --- parameter constants: - integer, parameter, public :: NWVSOL = 151 ! num of wvnum regions where solar - ! flux is constant - integer, parameter, public :: NWVTOT = 57600 ! total num of wvnum included - integer, parameter, public :: NWVTIR = 4000 ! total num of wvnum in ir range - -! --- number of wavenumbers in each region where the solar flux is constant - integer, dimension(NWVSOL) :: nwvns0 - - data nwvns0 / 100, 11, 14, 18, 24, 33, 50, 83, 12, 12, & - & 13, 15, 15, 17, 18, 20, 21, 24, 26, 30, 32, 37, 42, & - & 47, 55, 64, 76, 91, 111, 139, 179, 238, 333, 41, 42, 45, & - & 46, 48, 51, 53, 55, 58, 61, 64, 68, 71, 75, 79, 84, & - & 89, 95, 101, 107, 115, 123, 133, 142, 154, 167, 181, 197, 217, & - & 238, 263, 293, 326, 368, 417, 476, 549, 641, 758, 909, 101, 103, & - & 105, 108, 109, 112, 115, 117, 119, 122, 125, 128, 130, 134, 137, & - & 140, 143, 147, 151, 154, 158, 163, 166, 171, 175, 181, 185, 190, & - & 196, 201, 207, 213, 219, 227, 233, 240, 248, 256, 264, 274, 282, & - & 292, 303, 313, 325, 337, 349, 363, 377, 392, 408, 425, 444, 462, & - & 483, 505, 529, 554, 580, 610, 641, 675, 711, 751, 793, 841, 891, & - & 947,1008,1075,1150,1231,1323,1425,1538,1667,1633,14300 / - -! --- solar flux (w/m**2) in each wvnumb region where it is constant - real (kind=kind_phys), dimension(NWVSOL) :: s0intv - - data s0intv( 1: 50) / & - & 1.60000E-6, 2.88000E-5, 3.60000E-5, 4.59200E-5, 6.13200E-5, & - & 8.55000E-5, 1.28600E-4, 2.16000E-4, 2.90580E-4, 3.10184E-4, & - & 3.34152E-4, 3.58722E-4, 3.88050E-4, 4.20000E-4, 4.57056E-4, & - & 4.96892E-4, 5.45160E-4, 6.00600E-4, 6.53600E-4, 7.25040E-4, & - & 7.98660E-4, 9.11200E-4, 1.03680E-3, 1.18440E-3, 1.36682E-3, & - & 1.57560E-3, 1.87440E-3, 2.25500E-3, 2.74500E-3, 3.39840E-3, & - & 4.34000E-3, 5.75400E-3, 7.74000E-3, 9.53050E-3, 9.90192E-3, & - & 1.02874E-2, 1.06803E-2, 1.11366E-2, 1.15830E-2, 1.21088E-2, & - & 1.26420E-2, 1.32250E-2, 1.38088E-2, 1.44612E-2, 1.51164E-2, & - & 1.58878E-2, 1.66500E-2, 1.75140E-2, 1.84450E-2, 1.94106E-2 / - data s0intv( 51:100) / & - & 2.04864E-2, 2.17248E-2, 2.30640E-2, 2.44470E-2, 2.59840E-2, & - & 2.75940E-2, 2.94138E-2, 3.13950E-2, 3.34800E-2, 3.57696E-2, & - & 3.84054E-2, 4.13490E-2, 4.46880E-2, 4.82220E-2, 5.22918E-2, & - & 5.70078E-2, 6.19888E-2, 6.54720E-2, 6.69060E-2, 6.81226E-2, & - & 6.97788E-2, 7.12668E-2, 7.27100E-2, 7.31610E-2, 7.33471E-2, & - & 7.34814E-2, 7.34717E-2, 7.35072E-2, 7.34939E-2, 7.35202E-2, & - & 7.33249E-2, 7.31713E-2, 7.35462E-2, 7.36920E-2, 7.23677E-2, & - & 7.25023E-2, 7.24258E-2, 7.20766E-2, 7.18284E-2, 7.32757E-2, & - & 7.31645E-2, 7.33277E-2, 7.36128E-2, 7.33752E-2, 7.28965E-2, & - & 7.24924E-2, 7.23307E-2, 7.21050E-2, 7.12620E-2, 7.10903E-2 / - data s0intv(101:151) / 7.12714E-2, & - & 7.08012E-2, 7.03752E-2, 7.00350E-2, 6.98639E-2, 6.90690E-2, & - & 6.87621E-2, 6.52080E-2, 6.65184E-2, 6.60038E-2, 6.47615E-2, & - & 6.44831E-2, 6.37206E-2, 6.24102E-2, 6.18698E-2, 6.06320E-2, & - & 5.83498E-2, 5.67028E-2, 5.51232E-2, 5.48645E-2, 5.12340E-2, & - & 4.85581E-2, 4.85010E-2, 4.79220E-2, 4.44058E-2, 4.48718E-2, & - & 4.29373E-2, 4.15242E-2, 3.81744E-2, 3.16342E-2, 2.99615E-2, & - & 2.92740E-2, 2.67484E-2, 1.76904E-2, 1.40049E-2, 1.46224E-2, & - & 1.39993E-2, 1.19574E-2, 1.06386E-2, 1.00980E-2, 8.63808E-3, & - & 6.52736E-3, 4.99410E-3, 4.39350E-3, 2.21676E-3, 1.33812E-3, & - & 1.12320E-3, 5.59000E-4, 3.60000E-4, 2.98080E-4, 7.46294E-5 / - -! --------------------------------------------------------------------- ! -! section-2 : module variables for stratospheric volcanic aerosols ! -! from historical data (sato et al. 1993) ! -! --------------------------------------------------------------------- ! - -! --- parameter constants: - integer, parameter :: MINVYR = 1850 ! lower lim (year) data available - integer, parameter :: MAXVYR = 1999 ! upper lim (year) data available - -! --- monthly, 45-deg lat-zone aerosols data set in subroutine 'aerinit' - integer, allocatable :: ivolae(:,:,:) - -! --- static control variables: - integer, save :: kyrstr = 0 - integer, save :: kyrend = 0 - integer, save :: kyrsav = 0 - integer, save :: kmonsav = 0 - -! --------------------------------------------------------------------- ! -! section-3 : module variables for opac climatological aerosols ! -! optical properties (hess et al. 1989) ! -! --------------------------------------------------------------------- ! - -! --- parameters and constants: - integer, parameter :: NXC = 5 ! num of max componets in a profile - integer, parameter :: NAE = 7 ! num of aerosols profile structures - integer, parameter :: NDM = 5 ! num of atmos aerosols domains - integer, parameter :: IMXAE = 72 ! num of lon-points in glb aeros data set - integer, parameter :: JMXAE = 37 ! num of lat-points in glb aeros data set - integer, parameter :: NAERBND=61 ! num of bands for clim aer data (opac) - integer, parameter :: NRHLEV =8 ! num of rh levels for rh-dep components - integer, parameter :: NCM1 = 6 ! num of rh independent aeros species - integer, parameter :: NCM2 = 4 ! num of rh dependent aeros species - integer, parameter :: NCM = NCM1+NCM2 - - real (kind=kind_phys), dimension(NRHLEV) :: rhlev - data rhlev (:) / 0.0, 0.5, 0.7, 0.8, 0.9, 0.95, 0.98, 0.99 / - -! --- the following arrays are for climatological data that are -! allocated and read in subroutine 'clim_aerinit'. -! - spectral band structure: -! iendwv(NAERBND) - ending wavenumber (cm**-1) for each band -! - relativ humidity independent aerosol optical properties: -! species : insoluble (inso); soot (soot); -! mineral nuc mode (minm); mineral acc mode (miam); -! mineral coa mode (micm); mineral transport(mitr). -! rhidext0(NAERBND,NCM1) - extinction coefficient -! rhidsca0(NAERBND,NCM1) - scattering coefficient -! rhidssa0(NAERBND,NCM1) - single scattering albedo -! rhidasy0(NAERBND,NCM1) - asymmetry parameter -! - relative humidity dependent aerosol optical properties: -! species : water soluble (waso); sea salt acc mode(ssam); -! sea salt coa mode(sscm); sulfate droplets (suso). -! rh level: 00%, 50%, 70%, 80%, 90%, 95%, 98%, 99% -! rhdpext0(NAERBND,NRHLEV,NCM2) - extinction coefficient -! rhdpsca0(NAERBND,NRHLEV,NCM2) - scattering coefficient -! rhdpssa0(NAERBND,NRHLEV,NCM2) - single scattering albedo -! rhdpasy0(NAERBND,NRHLEV,NCM2) - asymmetry parameter -! - stratospheric background aerosol optical properties: -! straext0(NAERBND) - extingction coefficients -! - global aerosol distribution: -! haer(NDM,NAE) - scale height of aerosols (km) -! prsref(NDM,NAE) - ref pressure lev (sfc to toa) in mb (100Pa) - - integer, allocatable, dimension(:) :: iendwv - real (kind=kind_phys), allocatable, dimension(:,:) :: rhidext0, & - & rhidsca0, rhidssa0, rhidasy0 - real (kind=kind_phys), allocatable, dimension(:,:,:):: rhdpext0, & - & rhdpsca0, rhdpssa0, rhdpasy0 - real (kind=kind_phys), allocatable, dimension(:) :: straext0 - real (kind=kind_phys), allocatable, save, dimension(:,:) :: haer - real (kind=kind_phys), allocatable, save, dimension(:,:) :: prsref - -! --- the following arrays are allocate and setup in subr 'clim_aerinit' -! - for relative humidity independent aerosol optical properties: -! species : insoluble (inso); soot (soot); -! mineral nuc mode (minm); mineral acc mode (miam); -! mineral coa mode (micm); mineral transport(mitr). -! extrhi(NCM1,NBDSWLW) - extinction coefficient for sw+lw spectral band -! scarhi(NCM1,NBDSWLW) - scattering coefficient for sw+lw spectral band -! ssarhi(NCM1,NBDSWLW) - single scattering albedo for sw+lw spectral band -! asyrhi(NCM1,NBDSWLW) - asymmetry parameter for sw+lw spectral band -! - for relative humidity dependent aerosol optical properties: -! species : water soluble (waso); sea salt acc mode(ssam); -! sea salt coa mode(sscm); sulfate droplets (suso). -! rh level: 00%, 50%, 70%, 80%, 90%, 95%, 98%, 99% -! extrhd(NRHLEV,NCM2,NBDSWLW) - extinction coefficient for sw+lw band -! scarhd(NRHLEV,NCM2,NBDSWLW) - scattering coefficient for sw+lw band -! ssarhd(NRHLEV,NCM2,NBDSWLW) - single scattering albedo for sw+lw band -! asyrhd(NRHLEV,NCM2,NBDSWLW) - asymmetry parameter for sw+lw band -! - for stratospheric aerosols optical properties: -! extstra(NBDSWLW) - extinction coefficient for sw+lw band -! - for topospheric aerosol profile distibution: -! kprfg ( IMXAE*JMXAE) - aeros profile index -! idxcg (NXC*IMXAE*JMXAE) - aeros component index -! cmixg (NXC*IMXAE*JMXAE) - aeros component mixing ratio -! denng (NXC*IMXAE*JMXAE) - aerosols number density - - real (kind=kind_phys), allocatable, save, dimension(:,:) :: & - & extrhi, scarhi, ssarhi, asyrhi - real (kind=kind_phys), allocatable, save, dimension(:,:,:) :: & - & extrhd, scarhd, ssarhd, asyrhd - real (kind=kind_phys), allocatable, save, dimension(:) :: & - & extstra - - real (kind=kind_phys),allocatable,save:: cmixg(:,:,:),denng(:,:,:) - integer, allocatable,save:: kprfg(:,:), idxcg(:,:,:) - -! --- logical parameter for clim opac optic prop input control - logical, save :: lclmin = .true. - - - -! --- public interfaces - - public aerinit, setaer - - -! ================= - contains -! ================= - -!----------------------------------- - subroutine aerinit & -!................................... - -! --- inputs: - & ( iyear, imon, IAER, me ) -! --- outputs: ( none ) - -! ================================================================== ! -! ! -! aerinit does invoke aerosol initialization programs based on the ! -! selection of schemes. ! -! ! -! inputs: ! -! iyear - 4-digit calender year 1 ! -! imon - month of the year 1 ! -! IAER - 3-digit aerosol flag (volc,lw,sw) 1 ! -! = 0: turn all aeros effects off (sw,lw,volc) ! -! = 1: use clim tropspheric aerosol for sw only ! -! = 10: use clim tropspheric aerosol for lw only ! -! = 11: use clim tropspheric aerosol for both sw and lw ! -! =100: volc aerosol only for both sw and lw ! -! =101: volc and clim trops aerosol for sw only ! -! =110: volc and clim trops aerosol for lw only ! -! =111: volc and clim trops aerosol for both sw and lw ! -!not-yet = 2: gocart tropspheric aerosol for sw only ! -! '' = 20: gocart tropspheric aerosol for lw only ! -! '' = 22: gocart tropspheric aerosol for both sw and lw ! -! '' =102: volc and gocart trops aerosol for sw only ! -! '' =120: volc and gocart trops aerosol for lw only ! -!not-yet =122: volc and gocart trops aerosol for both sw and lw ! -! me - print message control flag 1 ! -! ! -! outputs: (to the module variables) ! -! ( none ) ! -! ! -! module variables: ! -! kprfg - aerosols profile index IMXAE*JMXAE ! -! idxcg - aerosols component index NXC*IMXAE*JMXAE ! -! cmixg - aerosols component mixing ratio NXC*IMXAE*JMXAE ! -! denng - aerosols number density NXC*IMXAE*JMXAE ! -! ! -! ivolae - stratosphere volcanic aerosol optical depth (fac 1.e4) ! -! 12*4*10 ! -! ! -! usage: call aerinit ! -! ! -! subprograms called: clim_aerinit ! -! ! -! ================================================================== ! -! - implicit none - -! --- inputs: - integer, intent(in) :: iyear, imon, IAER, me - -! --- output: ( none ) - -! --- locals: - real (kind=kind_phys), dimension(NWVTOT) :: solfwv ! one wvn sol flux - real (kind=kind_phys), dimension(NWVTIR) :: eirfwv ! one wvn ir flux - real (kind=kind_phys) :: soltot, tmp1, tmp2, tmp3 - - integer :: nb, ni, nw, nw1, nw2, nmax, nmin - - character :: cline*80, ctyp*3, volcano_file*32 - - integer :: i, j, k, nc, iy, id, ilw, isw - logical :: file_exist - - data volcano_file / 'volcanic_aerosols_1850-1859.txt ' / - -!===> ... begin here - - isw = mod(IAER,10) ! trop-aer scheme for sw - iy = IAER / 10 - ilw = mod(iy , 10) ! trop-aer scheme for lw - - iaerflg = max( isw, ilw ) ! flag for trop-aer scheme selection - lalwflg = ilw > 0 ! flag for lw trop-aer properties - laswflg = isw > 0 ! flag for sw trop-aer properties - lvolflg = IAER >= 100 ! flag for stratospheric volcanic aer - -! --- ... in sw, aerosols optical properties are computed for each radiation -! spectral band; while in lw, optical properties can be calculated -! for either only one broad band or for each of the lw radiation bands - - if ( iaerlw == 1 ) then - NBDIR = NBDLW - else - NBDIR = 1 - endif - NBDSWLW = NBDSW + NBDIR - -! --- ... define the one wavenumber solar fluxes based on toa solar -! spectral distribution - - nmax = min( NWVTOT, nint( maxval(wvnum2) )) - nmin = max( 1, nint( minval(wvnum1) )) - -! print *,' MINWVN, MAXWVN = ',nmin, nmax - -! soltot1 = f_zero - soltot = f_zero - do nb = 1, NWVSOL - if ( nb == 1 ) then - nw1 = 1 - else - nw1 = nw1 + nwvns0(nb-1) - endif - - nw2 = nw1 + nwvns0(nb) - 1 - - do nw = nw1, nw2 - solfwv(nw) = s0intv(nb) -! soltot1 = soltot1 + s0intv(nb) - if ( nw >= nmin .and. nw <= nmax ) then - soltot = soltot + s0intv(nb) - endif - enddo - enddo - -! --- ... define the one wavenumber ir fluxes based on black-body -! emission distribution at a predefined temperature - - tmp1 = 2.0 * con_pi * con_plnk * (con_c**2) - tmp2 = con_plnk * con_c / (con_boltz * con_t0c) - - do ni = 1, NWVTIR - tmp3 = 100.0 * ni - eirfwv(ni) = (tmp1 * tmp3**3) / (exp(tmp2*tmp3) - 1.0) - enddo - -! --- ... write aerosol parameter configuration to output logs - - if ( me == 0 ) then - - print *,' IAER=',IAER,' iaerflg=',iaerflg,' LW-trop-aer=' & - & ,lalwflg,' SW-trop-aer=',laswflg,' Volc-aer=',lvolflg - - if ( IAER <= 0 ) then ! turn off all aerosol effects - - print *,' - No tropospheric/volcanic aerosol effect included' - print *,' Input values of aerosol optical properties to' & - & ,' both SW and LW radiations are set to zeros' - - elseif ( IAER == 100 ) then ! only stratospheric volcanic aerosols - - print *,' - Include onle volcanic aerosols in both SW and LW' & - & ,' for year, month =', iyear, imon - - else - - if ( IAER < 100 ) then ! no stratospheric volcanic aerosols - print *,' - No stratospheric volcanic aerosol effect' - else ! include stratospheric volcanic aerosols - print *,' - Include stratospheric volcanic aerosol effect' & - & ,' for year, month =', iyear, imon - endif - - if ( iaerflg == 1 ) then ! opac tropospheric climatological - - print *,' - Using OPAC climatology for tropospheric aerosol' - -!gocart! elseif ( iaerflg == 2 ) then ! opac tropospheric climatological - -!gocart! print *,' - Using GOCART scheme for tropospheric aerosol' - - endif ! end if_iaerflg_block - - if ( laswflg ) then ! shcek for sw effect - print *,' Compute aerosol optical properties for SW' & - & ,' input parameters' - else - print *,' No SW radiation aerosol effect, values of' & - & ,' aerosol properties to SW input are set to zeros' - endif ! end if_laswflg_block - - if ( lalwflg ) then ! check for lw effect - print *,' Compute aerosol optical properties for LW' & - & ,' input parameters' - else - print *,' No LW radiation aerosol effect, values of' & - & ,' aerosol properties to LW input are set to zeros' - endif ! end if_lalwflg_block - - endif ! end if_IAER_block - - endif ! end if_me_block - -! --- ... tropospheric aerosol initialization - - if ( IAER == 0 ) then - - return - - elseif ( IAER /= 100 ) then - - if ( iaerflg == 1 ) then ! opac tropospheric climatology - - if ( imon < 1 .or. imon > 12 ) then - print *,' ***** ERROR in specifying requested month!!! ', & - & 'imon=', imon - print *,' ***** STOPPED in subroutinte AERINIT!!!' - stop - endif - - call clim_aerinit & -! --- inputs: - & ( NWVTOT,solfwv,soltot,NWVTIR,eirfwv, & - & NBDSW,NBDIR,NBDSWLW, imon, me & -! --- outputs: (none) - & ) - -!!! elseif ( iaerflg == 2 ) then ! gocart prognostic aerosols - -!!! call gocart aerosol initialization routine here !!! -!!! -!!! call gocart_aerinit - - else - print *,' ERROR in aerosols specification! IAER =',iaer - print *,' iaerflg, lvolflg =',iaerflg,lvolflg - print *,' *** Stopped in subroutine AERINIT !!' - stop - endif ! end if_iaerflg_block - - endif ! end if_IAER_block - -! --- ... stratosperic volcanic aerosol initialization - - if ( lvolflg ) then - -! --- allocate data space - - if ( .not. allocated(ivolae) ) then - allocate ( ivolae(12,4,10) ) ! for 12-mon,4-lat_zone,10-year - endif - - kmonsav = imon - - if ( kyrstr<=iyear .and. iyear<=kyrend ) then ! use previously input data - kyrsav = iyear - return - else ! need to input new data - kyrsav = iyear - kyrstr = iyear - mod(iyear,10) - kyrend = kyrstr + 9 -!check print *,' kyrstr, kyrend, kyrsav, kmonsav =', & -! & kyrstr,kyrend,kyrsav,kmonsav - - if ( iyear < MINVYR .or. iyear > MAXVYR ) then - ivolae(:,:,:) = 1 ! set as lowest value - if ( me == 0 ) then - print *,' Request volcanic date out of range,', & - & ' optical depth set to lowest value' - endif - else - write(volcano_file(19:27),60) kyrstr,kyrend - 60 format(i4.4,'-',i4.4) - - inquire (file=volcano_file, exist=file_exist) - if ( file_exist ) then - open (unit=NIAERCM,file=volcano_file,status='OLD', & - & form='FORMATTED') - - read(NIAERCM,62) cline - 62 format(a80) - -! --- check print - if ( me == 0 ) then - print *,' Opened volcanic data file: ',volcano_file - print *, cline - endif - - do k = 1, 10 - do j = 1, 4 - read(NIAERCM,64) ivolae(:,j,k) -! read(NIAERCM,64) (ivolae(i,j,k),i=1,12) - 64 format(12i5) - enddo - enddo - - close (NIAERCM) - else - print *,' Requested volcanic data file "', & - & volcano_file,'" not found!' - print *,' *** Stopped in subroutine AERINIT !!' - stop - endif ! end if_file_exist_block - endif ! end if_iyear_block - - endif ! end if_kyrstr_block - - if ( me == 0 ) then - iy = mod(kyrsav,10) + 1 - print *,' CHECK: Sample Volcanic data used for month, year:', & - & imon, iyear - print *, ivolae(kmonsav,:,iy) - endif - endif ! end if_lvolflg_block -! - return -!................................... - end subroutine aerinit -!----------------------------------- - - - -!----------------------------------- - subroutine setaer & -!................................... - -! --- inputs: - & ( xlon,xlat,prsi,prsl,tlay,qlay,rhlay, & - & IMAX,NLAY,NLP1, iflip, lsswr,lslwr, & -! --- outputs: - & aerosw,aerolw & - & ) - -! ================================================================== ! -! ! -! setaer computes aerosols optical properties from different global ! -! aerosols data sets based on scheme selection. ! -! ! -! inputs: ! -! xlon, xlat IMAX ! -! - longitude and latitude of given points in radiance ! -! prsi - pressure at interface mb IMAX*NLP1 ! -! prsl - layer mean pressure mb IMAX*NLAY ! -! tlay - layer mean temperature k IMAX*NLAY ! -! qlay - layer mean specific humidity g/g IMAX*NLAY ! -! rhlay - layer mean relative humidity IMAX*NLAY ! -! IMAX - horizontal dimension of arrays 1 ! -! NLAY,NLP1-vertical dimensions of arrays 1 ! -! iflip - control flag for direction of vertical index 1 ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! lsswr,lslwr ! -! - logical flags for sw/lw radiation calls 1 ! -! ! -! outputs: ! -! aerosw - aeros opt properties for sw IMAX*NLAY*NBDSW*NF_AESW! -! (:,:,:,1): optical depth ! -! (:,:,:,2): single scattering albedo ! -! (:,:,:,3): asymmetry parameter ! -! aerolw - aeros opt properties for lw IMAX*NLAY*NBDLW*NF_AELW! -! (:,:,:,1): optical depth ! -! (:,:,:,2): single scattering albedo ! -! (:,:,:,3): asymmetry parameter ! -! ! -! ! -! ! -! module variable: (set by subroutine aerinit) ! -! iaerflg - control flag for tropospheric aerosols selection ! -! =0: do not calc tropospheric aerosol optical properties! -! =1: use opac tropospheric aerosol climatology ! -! =2: use gocart tropospheric interactive aerosol ! -! lalwflg - control flag for lw radiation aerosols effect ! -! =f: do not calc lw aerosol optical properties ! -! =t: calculate lw aerosol optical properties ! -! laswflg - control flag for sw radiation aerosols effect ! -! =f: do not calc sw aerosol optical properties ! -! =t: calculate sw aerosol optical properties ! -! lvolflg - control flag for stratospheric vocanic aerosols ! -! =t: add volcanic aerosols to the background aerosols ! -! =f: do not add volcanic aerosols ! -! ! -! ivolae - stratosphere volcanic aerosol optical depth (fac 1.e4) ! -! 12*4*10 ! -! ! -! usage: call setaer ! -! ! -! subprograms called: setclimaer ! -! ! -! ================================================================== ! -! - implicit none - -! --- inputs: - integer, intent(in) :: IMAX,NLAY,NLP1, iflip - - real (kind=kind_phys), dimension(:,:), intent(in) :: prsi, prsl, & - & tlay, qlay, rhlay - real (kind=kind_phys), dimension(:), intent(in) :: xlon, xlat - logical, intent(in) :: lsswr, lslwr - -! --- outputs: - real (kind=kind_phys), dimension(:,:,:,:), intent(out) :: & - & aerosw, aerolw - -! --- locals: - real (kind=kind_phys), dimension(IMAX) :: alon, alat, volcae, delp - real (kind=kind_phys) :: prsln(NLP1),hz(IMAX,NLP1),dz(IMAX,NLAY) - real (kind=kind_phys) :: tmp1, tmp2, psrfh, psrfl - - integer :: kcutl(IMAX), kcuth(IMAX) - integer :: i, i1, k, m, mb, kp, kh, kl - - logical :: laddsw = .false. - logical :: laddlw = .false. - -! --- conversion constants - real (kind=kind_phys), parameter :: rdg = 180.0 / con_pi - real (kind=kind_phys), parameter :: rovg = 0.001 * con_rd / con_g - - -!===> ... begin here - if ( .not. (lsswr .or. lslwr) ) then - return - endif - - if ( .not. laswflg ) then - aerosw = f_zero - endif - - if ( .not. lalwflg ) then - aerolw = f_zero - endif - - if ( (.not.lvolflg) .and. (iaerflg==0) ) then - return - endif - -! --- ... convert lat/lon from radiance to degree - - do i = 1, IMAX - alon(i) = xlon(i) * rdg - if (alon(i) < f_zero) alon(i) = alon(i) + 360.0 - alat(i) = xlat(i) * rdg - enddo - -! --- ... compute level height and layer thickness - - lab_do_IMAX : do i = 1, IMAX - - lab_if_flip : if (iflip == 1) then ! input from sfc to toa - - do k = 1, NLAY - prsln(k) = log(prsi(i,k)) - enddo - prsln(NLP1)= log(prsl(i,NLAY)) - - do k = NLAY, 1, -1 - dz(i,k) = rovg * (prsln(k) - prsln(k+1)) & - & * tlay(i,k) * (f_one + con_fvirt*qlay(i,k)) - enddo - dz(i,NLAY) = 2.0 * dz(i,NLAY) - - hz(i,1) = f_zero - do k = 1, NLAY - hz(i,k+1) = hz(i,k) + dz(i,k) - enddo - - else lab_if_flip ! input from toa to sfc - - prsln(1) = log(prsl(i,1)) - do k = 2, NLP1 - prsln(k) = log(prsi(i,k)) - enddo - - do k = 1, NLAY - dz(i,k) = rovg * (prsln(k+1) - prsln(k)) & - & * tlay(i,k) * (f_one + con_fvirt*qlay(i,k)) - enddo - dz(i,1) = 2.0 * dz(i,1) - - hz(i,NLP1) = f_zero - do k = NLAY, 1, -1 - hz(i,k) = hz(i,k+1) + dz(i,k) - enddo - - endif lab_if_flip - - enddo lab_do_IMAX - -! --- ... calculate sw aerosol optical properties for the corresponding -! frequency bands based on scheme selection - - if ( iaerflg == 1 ) then ! use opac aerosol climatology - - call setclimaer & -! --- inputs: - & ( alon,alat,prsi,rhlay,dz,hz,NBDSWLW, & - & IMAX,NLAY,NLP1, iflip, lsswr,lslwr, & -! --- outputs: - & aerosw,aerolw & - & ) - -!!! elseif ( iaerflg == 2 ) ! use gocart aerosol scheme - - - endif ! end if_iaerflg_block - -! --- check print -! do m = 1, NBDSW -! print *,' *** CHECK AEROSOLS PROPERTIES FOR SW BAND =',m, & -! & ' ***' -! do k = 1, 10 -! print *,' LEVEL :',k -! print *,' TAUAER:',aerosw(:,k,m,1) -! print *,' SSAAER:',aerosw(:,k,m,2) -! print *,' ASYAER:',aerosw(:,k,m,3) -! enddo -! enddo -! do m = 1, NBDIR -! print *,' *** CHECK AEROSOLS PROPERTIES FOR LW BAND =',m, & -! & ' ***' -! do k = 1, 10 -! print *,' LEVEL :',k -! print *,' TAUAER:',aerolw(:,k,m,1) -! print *,' SSAAER:',aerolw(:,k,m,2) -! print *,' ASYAER:',aerolw(:,k,m,3) -! enddo -! enddo - - -! --- ... stratosphere volcanic forcing - - - if ( lvolflg ) then - - laddsw = lsswr .and. (laswflg .or. iaerflg==0) - laddlw = lslwr .and. (lalwflg .or. iaerflg==0) - - i1 = mod(kyrsav, 10) + 1 - -! --- select data in 4 lat bands, interpolation at the boundaires - - do i = 1, IMAX - if ( alat(i) > 46.0 ) then - volcae(i) = 1.0e-4 * ivolae(kmonsav,1,i1) - else if ( alat(i) > 44.0 ) then - volcae(i) = 5.0e-5 & - & * (ivolae(kmonsav,1,i1) + ivolae(kmonsav,2,i1)) - else if ( alat(i) > 1.0 ) then - volcae(i) = 1.0e-4 * ivolae(kmonsav,2,i1) - else if ( alat(i) > -1.0 ) then - volcae(i) = 5.0e-5 & - & * (ivolae(kmonsav,2,i1) + ivolae(kmonsav,3,i1)) - else if ( alat(i) >-44.0 ) then - volcae(i) = 1.0e-4 * ivolae(kmonsav,3,i1) - else if ( alat(i) >-46.0 ) then - volcae(i) = 5.0e-5 & - & * (ivolae(kmonsav,3,i1) + ivolae(kmonsav,4,i1)) - else - volcae(i) = 1.0e-4 * ivolae(kmonsav,4,i1) - endif - enddo - - if ( iflip == 0 ) then ! input data from toa to sfc - - psrfh = 5.0 ! ref press for upper bound - -! --- find lower boundary of stratosphere - - do i = 1, IMAX - - tmp1 = abs( alat(i) ) - if ( tmp1 > 70.0 ) then ! polar, fixed at 250mb - psrfl = 250.0 - elseif ( tmp1 < 20.0 ) then ! tropic, fixed at 150mb - psrfl = 150.0 - else ! mid-lat, interp - psrfl = 110.0 + 2.0*tmp1 - endif - - kcuth(i) = NLAY - 1 - kcutl(i) = 2 - delp(i) = prsi(i,2) - - lab_do_kcuth0 : do k = 2, NLAY-2 - if ( prsi(i,k) >= psrfh ) then - kcuth(i) = k - 1 - exit lab_do_kcuth0 - endif - enddo lab_do_kcuth0 - - lab_do_kcutl0 : do k = 2, NLAY-2 - if ( prsi(i,k) >= psrfl ) then - kcutl(i) = k - 1 - delp(i) = prsi(i,k) - prsi(i,kcuth(i)) - exit lab_do_kcutl0 - endif - enddo lab_do_kcutl0 - enddo - -! --- sw: add volcanic aerosol optical depth to the background value - - if ( laddsw ) then - do m = 1, NBDSW - mb = NSWSTR + m - 1 - - if ( wvnum1(mb) > 20000 ) then ! range of wvlth < 0.5mu - tmp2 = 0.74 - elseif ( wvnum2(mb) < 20000 ) then ! range of wvlth > 0.5mu - tmp2 = 1.14 - else ! range of wvlth in btwn - tmp2 = 0.94 - endif - tmp1 = (0.275e-4 * (wvnum2(mb)+wvnum1(mb))) ** tmp2 - - do i = 1, IMAX - kh = kcuth(i) - kl = kcutl(i) - do k = kh, kl - tmp2 = tmp1 * ((prsi(i,k+1) - prsi(i,k)) / delp(i)) - aerosw(i,k,m,1) = aerosw(i,k,m,1) + tmp2*volcae(i) - enddo - -! --- smoothing profile at boundary if needed - - if ( aerosw(i,kl,m,1) > 10.*aerosw(i,kl+1,m,1) ) then - tmp2 = aerosw(i,kl,m,1) + aerosw(i,kl+1,m,1) - aerosw(i,kl ,m,1) = 0.8 * tmp2 - aerosw(i,kl+1,m,1) = 0.2 * tmp2 - endif - enddo ! end do_i_block - enddo ! end do_m_block - -! --- check print - -! do i = 1, IMAX -! print *,' LEV PRESS TAUSAV NEWTAU FOR PROFILE:',& -! & i,' KCUTH, KCUTL =',kcuth(i),kcutl(i) -! kh = kcuth(i) - 1 -! kl = kcutl(i) + 10 -! do k = kh, kl -! write(6,71) k, prsl(i,k), aersav(i,k), aerosw(i,k,1,1) -! 71 format(i3,f9.3,2e11.4) -! enddo -! enddo - endif ! end if_laddsw_block - -! --- lw: add volcanic aerosol optical depth to the background value - - if ( laddlw ) then - if ( NBDIR == 1 ) then - - tmp1 = (0.55 / 11.0) ** 1.2 - do i = 1, IMAX - kh = kcuth(i) - kl = kcutl(i) - do k = kh, kl - tmp2 = tmp1 * ((prsi(i,k+1) - prsi(i,k)) / delp(i)) - aerolw(i,k,1,1) = aerolw(i,k,1,1) + tmp2*volcae(i) - enddo - enddo ! end do_i_block - - else - - do m = 1, NBDIR - tmp1 = (0.275e-4 * (wvnlw2(m) + wvnlw1(m))) ** 1.2 - - do i = 1, IMAX - kh = kcuth(i) - kl = kcutl(i) - do k = kh, kl - tmp2 = tmp1 * ((prsi(i,k+1)-prsi(i,k)) / delp(i)) - aerolw(i,k,m,1) = aerolw(i,k,m,1) + tmp2*volcae(i) - enddo - enddo ! end do_i_block - enddo ! end do_m_block - - endif ! end if_NBDIR_block - endif ! end if_laddlw_block - - else ! input data from sfc to toa - - psrfh = 5.0 ! ref press for upper bound - -! --- find lower boundary of stratosphere - - - do i = 1, IMAX - - tmp1 = abs( alat(i) ) - if ( tmp1 > 70.0 ) then ! polar, fixed at 250mb - psrfl = 250.0 - elseif ( tmp1 < 20.0 ) then ! tropic, fixed at 150mb - psrfl = 150.0 - else ! mid-lat, interp - psrfl = 110.0 + 2.0*tmp1 - endif - - kcuth(i) = 2 - kcutl(i) = NLAY - 1 - delp(i) = prsi(i,NLAY-1) - - lab_do_kcuth1 : do k = NLAY-1, 2, -1 - if ( prsi(i,k) >= psrfh ) then - kcuth(i) = k - exit lab_do_kcuth1 - endif - enddo lab_do_kcuth1 - - lab_do_kcutl1 : do k = NLAY, 2, -1 - if ( prsi(i,k) >= psrfl ) then - kcutl(i) = k - delp(i) = prsi(i,k) - prsi(i,kcuth(i)+1) - exit lab_do_kcutl1 - endif - enddo lab_do_kcutl1 - enddo - -! --- sw: add volcanic aerosol optical depth to the background value - - if ( laddsw ) then - do m = 1, NBDSW - mb = NSWSTR + m - 1 - - if ( wvnum1(mb) > 20000 ) then ! range of wvlth < 0.5mu - tmp2 = 0.74 - elseif ( wvnum2(mb) < 20000 ) then ! range of wvlth > 0.5mu - tmp2 = 1.14 - else ! range of wvlth in btwn - tmp2 = 0.94 - endif - tmp1 = (0.275e-4 * (wvnum2(mb)+wvnum1(mb))) ** tmp2 - - do i = 1, IMAX - kh = kcuth(i) - kl = kcutl(i) - do k = kl, kh - tmp2 = tmp1 * ((prsi(i,k) - prsi(i,k+1)) / delp(i)) - aerosw(i,k,m,1) = aerosw(i,k,m,1) + tmp2*volcae(i) - enddo - -! --- smoothing profile at boundary if needed - - if ( aerosw(i,kl,m,1) > 10.*aerosw(i,kl-1,m,1) ) then - tmp2 = aerosw(i,kl,m,1) + aerosw(i,kl-1,m,1) - aerosw(i,kl ,m,1) = 0.8 * tmp2 - aerosw(i,kl-1,m,1) = 0.2 * tmp2 - endif - enddo ! end do_i_block - enddo ! end do_m_block - -! --- check print - -! do i = 1, IMAX -! print *,' LEV PRESS TAUSAV NEWTAU FOR PROFILE:',& -! & i,' KCUTH, KCUTL =',kcuth(i),kcutl(i) -! kh = kcuth(i) + 1 -! kl = kcutl(i) - 10 -! do k = kh, kl, -1 -! write(6,71) NLP1-k,prsl(i,k),aersav(i,k),aerosw(i,k,1,1) -! enddo -! enddo - endif ! end if_laddsw_block - -! --- lw: add volcanic aerosol optical depth to the background value - - if ( laddlw ) then - if ( NBDIR == 1 ) then - - tmp1 = (0.55 / 11.0) ** 1.2 - do i = 1, IMAX - kh = kcuth(i) - kl = kcutl(i) - do k = kl, kh - tmp2 = tmp1 * ((prsi(i,k) - prsi(i,k+1)) / delp(i)) - aerolw(i,k,1,1) = aerolw(i,k,1,1) + tmp2*volcae(i) - enddo - enddo ! end do_i_block - - else - - do m = 1, NBDIR - tmp1 = (0.275e-4 * (wvnlw2(m) + wvnlw1(m))) ** 1.2 - - do i = 1, IMAX - kh = kcuth(i) - kl = kcutl(i) - do k = kl, kh - tmp2 = tmp1 * ((prsi(i,k)-prsi(i,k+1)) / delp(i)) - aerolw(i,k,m,1) = aerolw(i,k,m,1) + tmp2*volcae(i) - enddo - enddo ! end do_i_block - enddo ! end do_m_block - - endif ! end if_NBDIR_block - endif ! end if_laddlw_block - - endif ! end if_iflip_block - -! --- adding volcanic optical depth to stratospheric layers - - - endif ! end if_lvolflg_block -! write(6,*)'take sw parms from chem routines' -! do i = 1, IMAX -! do k = 1,im -! do m=1,nbands -! aerosw(i,k,m,1) = -! enddo -! enddo -! enddo - -! - return -!................................... - end subroutine setaer -!----------------------------------- - - - -!----------------------------------- - subroutine clim_aerinit & -!................................... -! --- inputs: - & ( NWVTOT,solfwv,soltot,NWVTIR,eirfwv, & - & NBDSW,NBDIR,NBDSWLW, imon, me & -! --- outputs: ( none ) - & ) - -! ================================================================== ! -! ! -! subprogram : clim_aerinit ! -! ! -! this is the initialization progrmam for climatological aerosols ! -! ! -! it reads in monthly global distribution of aerosol profiles in ! -! five degree horizontal resolution. Then, it reads and maps the ! -! tabulated aerosol optical spectral data onto corresponding sw ! -! radiation spectral bands. ! -! ! -! ==================== defination of variables =================== ! -! ! -! inputs: ! -! NWVTOT - total num of wave numbers used in sw spectrum ! -! solfwv(NWVTOT) - solar flux for each individual wavenumber (w/m2)! -! soltot - total solar flux for the spectrual range (w/m2)! -! NWVTIR - total num of wave numbers used in the ir region ! -! eirfwv(NWVTIR) - ir flux(273k) for each individual wavenum (w/m2)! -! NBDSW - num of bands calculated for sw aeros opt prop ! -! NBDIR - num of bands calculated for lw aeros opt prop ! -! NBDSWLW - total num of bands calc for sw+lw aeros opt prop! -! imon - month of the year ! -! me - print message control flag ! -! ! -! outputs: (to the module variables) ! -! ! -! module variables: ! -! NBDSW - total number of sw spectral bands ! -! wvnum1,wvnum2 (NSWSTR:NSWEND) ! -! - start/end wavenumbers for each of sw bands ! -! NBDLW - total number of lw spectral bands ! -! wvnlw1,wvnlw2 (NBDLW) ! -! - start/end wavenumbers for each of lw bands ! -! NBDSWLW - total number of sw+lw bands used in this version ! -! extrhi - extinction coef for rh-indep aeros NCM1*NBDSWLW! -! scarhi - scattering coef for rh-indep aeros NCM1*NBDSWLW! -! ssarhi - single-scat-alb for rh-indep aeros NCM1*NBDSWLW! -! asyrhi - asymmetry factor for rh-indep aeros NCM1*NBDSWLW! -! extrhd - extinction coef for rh-dep aeros NRHLEV*NCM2*NBDSWLW! -! scarhd - scattering coef for rh-dep aeros NRHLEV*NCM2*NBDSWLW! -! ssarhd - single-scat-alb for rh-dep aeros NRHLEV*NCM2*NBDSWLW! -! asyrhd - asymmetry factor for rh-dep aeros NRHLEV*NCM2*NBDSWLW! -! ! -! kprfg - aerosols profile index IMXAE*JMXAE ! -! idxcg - aerosols component index NXC*IMXAE*JMXAE ! -! cmixg - aerosols component mixing ratio NXC*IMXAE*JMXAE ! -! denng - aerosols number density NXC*IMXAE*JMXAE ! -! ! -! usage: call aerinit ! -! ! -! subprograms called: optavg ! -! ! -! ================================================================== ! -! - implicit none - -! --- inputs: - integer, intent(in) :: NWVTOT,NWVTIR,NBDSW,NBDIR,NBDSWLW,imon,me - - real (kind=kind_phys), intent(in) :: solfwv(:),soltot, eirfwv(:) - -! --- output: ( none ) - -! --- locals: - real (kind=kind_io8) :: cmix(NXC), denn, tem - integer :: idxc(NXC), kprf - - real (kind=kind_phys), dimension(NBDSW,NAERBND) :: solwaer - real (kind=kind_phys), dimension(NBDSW) :: solbnd - real (kind=kind_phys), dimension(NBDIR,NAERBND) :: eirwaer - real (kind=kind_phys), dimension(NBDIR) :: eirbnd - real (kind=kind_phys) :: sumsol, sumir - - integer, dimension(NBDSW) :: nv1, nv2 - integer, dimension(NBDIR) :: nr1, nr2 - - integer :: i, j, k, m, mb, nc, iy, ib, ii, id, iw, iw1, iw2 - logical :: file_exist - - character :: cline*80, ctyp*3 - -! data aerosol_file / 'climaeropac_global.txt ' / -! data aerosol_file / 'aerosol.dat ' / - -!===> ... begin here - - if ( .not. allocated(kprfg) ) then - allocate ( kprfg ( IMXAE,JMXAE) ) - allocate ( cmixg (NXC,IMXAE,JMXAE) ) - allocate ( denng (NXC,IMXAE,JMXAE) ) - allocate ( idxcg (NXC,IMXAE,JMXAE) ) - endif - -! --- ... reading climatological aerosols data - - inquire (file=aerosol_file, exist=file_exist) - - if ( file_exist ) then - open (unit=NIAERCM,file=aerosol_file,status='OLD', & - & form='FORMATTED') - rewind (NIAERCM) - - if ( me == 0 ) then - print *,' Opened aerosol data file: ',trim(aerosol_file) - endif - else - print *,' Requested aerosol data file "',aerosol_file, & - & '" not found!' - return -!jbao newgfs print *,' *** Stopped in subroutine AERINIT !!' -!jbao newgfs stop - endif ! end if_file_exist_block - - cmixg = f_zero - denng = f_zero - idxcg = 0 - -! --- ... loop over 12 month global distribution - - Lab_do_12mon : do m = 1, 12 - - read(NIAERCM,12) cline - 12 format(a80/) - - if ( m /= imon ) then -! if ( me == 0 ) print *,' *** Skipped ',cline - - do j = 1, JMXAE - do i = 1, IMXAE - read(NIAERCM,*) id - enddo - enddo - else - if ( me == 0 ) print *,' --- Reading ',cline - - do j = 1, JMXAE - do i = 1, IMXAE - read(NIAERCM,14) (idxc(k),cmix(k),k=1,NXC),kprf,denn,nc,ctyp - 14 format(5(i2,e11.4),i2,f8.2,i3,1x,a3) - - kprfg(i,j) = kprf - denng(1,i,j) = denn ! num density of 1st layer - if ( kprf >= 6 ) then - denng(2,i,j) = cmix(NXC) ! num density of 2dn layer - else - denng(2,i,j) = f_zero - endif - - tem = f_one - do k = 1, NXC-1 - idxcg(k,i,j) = idxc(k) ! component index - cmixg(k,i,j) = cmix(k) ! component mixing ratio - tem = tem - cmix(k) - enddo - idxcg(NXC,i,j) = idxc(NXC) - cmixg(NXC,i,j) = tem ! to make sure all add to 1. - enddo - enddo - - if ( .not. lclmin ) then - close (NIAERCM) - exit Lab_do_12mon - endif - endif ! end if_m_block - - enddo Lab_do_12mon - -! -- check print - -! print *,' IDXCG :' -! print 16,idxcg -! 16 format(40i3) -! print *,' CMIXG :' -! print 17,cmixg -! print *,' DENNG :' -! print 17,denng -! print *,' KPRFG :' -! print 17,kprfg -! 17 format(8e16.9) - - if ( .not. lclmin ) then - -! --- ... already done optical property interpolation, exit - - return - - else - -! --- ... aloocate and input aerosol optical data - - if ( .not. allocated( rhidext0 ) ) then - allocate ( rhidext0(NAERBND,NCM1) ) - allocate ( rhidsca0(NAERBND,NCM1) ) - allocate ( rhidssa0(NAERBND,NCM1) ) - allocate ( rhidasy0(NAERBND,NCM1) ) - allocate ( rhdpext0(NAERBND,NRHLEV,NCM2) ) - allocate ( rhdpsca0(NAERBND,NRHLEV,NCM2) ) - allocate ( rhdpssa0(NAERBND,NRHLEV,NCM2) ) - allocate ( rhdpasy0(NAERBND,NRHLEV,NCM2) ) - allocate ( straext0(NAERBND) ) - endif - - if ( .not. allocated( iendwv ) ) then - allocate ( iendwv (NAERBND) ) - allocate ( haer (NDM,NAE) ) - allocate ( prsref (NDM,NAE) ) - endif - - if ( .not. allocated( extrhi ) ) then - allocate ( extrhi ( NCM1,NBDSWLW) ) - allocate ( scarhi ( NCM1,NBDSWLW) ) - allocate ( ssarhi ( NCM1,NBDSWLW) ) - allocate ( asyrhi ( NCM1,NBDSWLW) ) - allocate ( extrhd (NRHLEV,NCM2,NBDSWLW) ) - allocate ( scarhd (NRHLEV,NCM2,NBDSWLW) ) - allocate ( ssarhd (NRHLEV,NCM2,NBDSWLW) ) - allocate ( asyrhd (NRHLEV,NCM2,NBDSWLW) ) - allocate ( extstra( NBDSWLW) ) - endif - - read(NIAERCM,21) cline ! ending wave num for 61 aeros spectral bands - 21 format(a80) - read(NIAERCM,22) iendwv(:) - 22 format(13i6) - - read(NIAERCM,21) cline ! atmos scale height for 5 domains, 7 profs - read(NIAERCM,24) haer(:,:) - 24 format(20f4.1) - - read(NIAERCM,21) cline ! reference pressure for 5 domains, 7 profs - read(NIAERCM,26) prsref(:,:) - 26 format(10f7.2) - - read(NIAERCM,21) cline ! rh indep ext coef for 61 bands, 6 species - read(NIAERCM,28) rhidext0(:,:) - 28 format(8e10.3) - - read(NIAERCM,21) cline ! rh indep sca coef for 61 bands, 6 species - read(NIAERCM,28) rhidsca0(:,:) - - read(NIAERCM,21) cline ! rh indep ssa coef for 61 bands, 6 species - read(NIAERCM,28) rhidssa0(:,:) - - read(NIAERCM,21) cline ! rh indep asy coef for 61 bands, 6 species - read(NIAERCM,28) rhidasy0(:,:) - - read(NIAERCM,21) cline ! rh dep ext coef for 61 bands, 8 rh lev, 4 species - read(NIAERCM,28) rhdpext0(:,:,:) - - read(NIAERCM,21) cline ! rh dep sca coef for 61 bands, 8 rh lev, 4 species - read(NIAERCM,28) rhdpsca0(:,:,:) - - read(NIAERCM,21) cline ! rh dep ssa coef for 61 bands, 8 rh lev, 4 species - read(NIAERCM,28) rhdpssa0(:,:,:) - - read(NIAERCM,21) cline ! rh dep asy coef for 61 bands, 8 rh lev, 4 species - read(NIAERCM,28) rhdpasy0(:,:,:) - - read(NIAERCM,21) cline ! stratospheric background aeros for 61 bands - read(NIAERCM,28) straext0(:) - - lclmin = .false. - -! --- ... compute solar flux weights and interval indices for mapping -! spectral bands between sw radiation and aerosol data - - solbnd (:) = f_zero - solwaer(:,:) = f_zero - - do ib = 1, NBDSW - mb = ib + NSWSTR - 1 - ii = 1 - iw1 = nint(wvnum1(mb)) - iw2 = nint(wvnum2(mb)) - - Lab_swdowhile : do while ( iw1 > iendwv(ii) ) - if ( ii == NAERBND ) exit Lab_swdowhile - ii = ii + 1 - enddo Lab_swdowhile - - sumsol = f_zero - nv1(ib) = ii - - do iw = iw1, iw2 - solbnd(ib) = solbnd(ib) + solfwv(iw) - sumsol = sumsol + solfwv(iw) - - if ( iw == iendwv(ii) ) then - solwaer(ib,ii) = sumsol - - if ( ii < NAERBND ) then - sumsol = f_zero - ii = ii + 1 - endif - endif - enddo - - if ( iw2 /= iendwv(ii) ) then - solwaer(ib,ii) = sumsol - endif - - nv2(ib) = ii -! frcbnd(ib) = solbnd(ib) / soltot - enddo ! end do_ib_block for sw - -! --- ... compute ir flux weights and interval indices for mapping -! spectral bands between lw radiation and aerosol data - - eirbnd (:) = f_zero - eirwaer(:,:) = f_zero - - do ib = 1, NBDIR - ii = 1 - if ( NBDIR == 1 ) then -! iw1 = 250 ! corresponding 40 mu - iw1 = 400 ! corresponding 25 mu - iw2 = 2500 ! corresponding 4 mu - else - iw1 = nint(wvnlw1(ib)) - iw2 = nint(wvnlw2(ib)) - endif - - Lab_lwdowhile : do while ( iw1 > iendwv(ii) ) - if ( ii == NAERBND ) exit Lab_lwdowhile - ii = ii + 1 - enddo Lab_lwdowhile - - sumir = f_zero - nr1(ib) = ii - - do iw = iw1, iw2 - eirbnd(ib) = eirbnd(ib) + eirfwv(iw) - sumir = sumir + eirfwv(iw) - - if ( iw == iendwv(ii) ) then - eirwaer(ib,ii) = sumir - - if ( ii < NAERBND ) then - sumir = f_zero - ii = ii + 1 - endif - endif - enddo - - if ( iw2 /= iendwv(ii) ) then - eirwaer(ib,ii) = sumir - endif - - nr2(ib) = ii - enddo ! end do_ib_block for lw - -! --- compute spectral band mean properties for each species - - call optavg -! --- inputs: (in scope variables) -! --- outputs: (in scope variables) - -! --- check print - -! do ib = 1, NBDSW -! print *,' After optavg, for sw band:',ib -! print *,' extrhi:', extrhi(:,ib) -! print *,' scarhi:', scarhi(:,ib) -! print *,' ssarhi:', ssarhi(:,ib) -! print *,' asyrhi:', asyrhi(:,ib) -! mb = ib + NSWSTR - 1 -! print *,' wvnum1,wvnum2 :',wvnum1(mb),wvnum2(mb) -! do i = 1, NRHLEV -! print *,' extrhd for rhlev:',i -! print *,extrhd(i,:,ib) -! print *,' scarhd for rhlev:',i -! print *,scarhd(i,:,ib) -! print *,' ssarhd for rhlev:',i -! print *,ssarhd(i,:,ib) -! print *,' asyrhd for rhlev:',i -! print *,asyrhd(i,:,ib) -! enddo -! print *,' extstra:', extstra(ib) -! enddo -! print *,' wvnlw1 :',wvnlw1 -! print *,' wvnlw2 :',wvnlw2 -! do ib = 1, NBDIR -! ii = NBDSW + ib -! print *,' After optavg, for lw band:',ib -! print *,' extrhi:', extrhi(:,ii) -! print *,' scarhi:', scarhi(:,ii) -! print *,' ssarhi:', ssarhi(:,ii) -! print *,' asyrhi:', asyrhi(:,ii) -! do i = 1, NRHLEV -! print *,' extrhd for rhlev:',i -! print *,extrhd(i,:,ii) -! print *,' scarhd for rhlev:',i -! print *,scarhd(i,:,ii) -! print *,' ssarhd for rhlev:',i -! print *,ssarhd(i,:,ii) -! print *,' asyrhd for rhlev:',i -! print *,asyrhd(i,:,ii) -! enddo -! print *,' extstra:', extstra(ii) -! enddo - -! --- ... dealoocate input data arrays no longer needed - - deallocate ( rhidext0 ) - deallocate ( rhidsca0 ) - deallocate ( rhidssa0 ) - deallocate ( rhidasy0 ) - deallocate ( rhdpext0 ) - deallocate ( rhdpsca0 ) - deallocate ( rhdpssa0 ) - deallocate ( rhdpasy0 ) - deallocate ( straext0 ) - deallocate ( iendwv ) - - endif ! end if_lclmin_block - -! ================= - contains -! ================= - -!----------------------------- - subroutine optavg -!............................. -! --- inputs: (in scope variables) -! --- outputs: (in scope variables) - -! ==================================================================== ! -! ! -! subprogram: optavg ! -! ! -! compute mean aerosols optical properties over each sw radiation ! -! spectral band for each of the species components. This program ! -! follows gfdl's approach for thick cloud opertical property in ! -! sw radiation scheme (2000). ! -! ! -! ==================== defination of variables =================== ! -! ! -! input arguments: ! -! nv1,nv2 (NBDSW) - start/end spectral band indices of aerosol data ! -! for each sw radiation spectral band ! -! nr1,nr2 (NBDIR) - start/end spectral band indices of aerosol data ! -! for each ir radiation spectral band ! -! solwaer (NBDSW,NAERBND) ! -! - solar flux weight over each sw radiation band ! -! vs each aerosol data spectral band ! -! eirwaer (NBDIR,NAERBND) ! -! - ir flux weight over each lw radiation band ! -! vs each aerosol data spectral band ! -! solbnd (NBDSW) - solar flux weight over each sw radiation band ! -! eirbnd (NBDIR) - ir flux weight over each lw radiation band ! -! NBDSW - total number of sw spectral bands ! -! NBDIR - total number of lw spectral bands ! -! NBDSWLW - total number of sw+lw spectral bands ! -! ! -! output arguments: (to module variables) ! -! ! -! ================================================================== ! -! - implicit none - -! --- inputs: -! --- output: - -! --- locals: - real (kind=kind_phys) :: sumk, sums, sumok, sumokg, sumreft, & - & sp, refb, reft, rsolbd, rirbd - - integer :: ib, nb, ni, nh, nc -! -!===> ... begin here -! -! --- ... loop for each sw radiation spectral band - - do nb = 1, NBDSW - rsolbd = f_one / solbnd(nb) - -! --- for rh independent aerosol species - - do nc = 1, NCM1 - sumk = f_zero - sums = f_zero - sumok = f_zero - sumokg = f_zero - sumreft = f_zero - - do ni = nv1(nb), nv2(nb) - sp = sqrt( (f_one - rhidssa0(ni,nc)) & - & / (f_one - rhidssa0(ni,nc)*rhidasy0(ni,nc)) ) - reft = (f_one - sp) / (f_one + sp) - sumreft = sumreft + reft*solwaer(nb,ni) - - sumk = sumk + rhidext0(ni,nc)*solwaer(nb,ni) - sums = sums + rhidsca0(ni,nc)*solwaer(nb,ni) - sumok = sumok + rhidssa0(ni,nc)*solwaer(nb,ni) & - & * rhidext0(ni,nc) - sumokg = sumokg + rhidssa0(ni,nc)*solwaer(nb,ni) & - & * rhidext0(ni,nc)*rhidasy0(ni,nc) - enddo - - refb = sumreft * rsolbd - - extrhi(nc,nb) = sumk * rsolbd - scarhi(nc,nb) = sums * rsolbd - asyrhi(nc,nb) = sumokg / (sumok + 1.0e-10) - ssarhi(nc,nb) = 4.0*refb & - & / ( (f_one+refb)**2 - asyrhi(nc,nb)*(f_one-refb)**2 ) - enddo ! end do_nc_block for rh-ind aeros - -! --- for rh dependent aerosols species - - do nc = 1, NCM2 - do nh = 1, NRHLEV - sumk = f_zero - sums = f_zero - sumok = f_zero - sumokg = f_zero - sumreft = f_zero - - do ni = nv1(nb), nv2(nb) - sp = sqrt( (f_one - rhdpssa0(ni,nh,nc)) & - & / (f_one - rhdpssa0(ni,nh,nc)*rhdpasy0(ni,nh,nc)) ) - reft = (f_one - sp) / (f_one + sp) - sumreft = sumreft + reft*solwaer(nb,ni) - - sumk = sumk + rhdpext0(ni,nh,nc)*solwaer(nb,ni) - sums = sums + rhdpsca0(ni,nh,nc)*solwaer(nb,ni) - sumok = sumok + rhdpssa0(ni,nh,nc)*solwaer(nb,ni) & - & * rhdpext0(ni,nh,nc) - sumokg = sumokg + rhdpssa0(ni,nh,nc)*solwaer(nb,ni) & - & * rhdpext0(ni,nh,nc)*rhdpasy0(ni,nh,nc) - enddo - - refb = sumreft * rsolbd - - extrhd(nh,nc,nb) = sumk * rsolbd - scarhd(nh,nc,nb) = sums * rsolbd - asyrhd(nh,nc,nb) = sumokg / (sumok + 1.0e-10) - ssarhd(nh,nc,nb) = 4.0*refb & - & / ( (f_one+refb)**2 - asyrhd(nh,nc,nb)*(f_one-refb)**2 ) - enddo ! end do_nh_block - enddo ! end do_nc_block for rh-dep aeros - -! --- for stratospheric background aerosols - - sumk = f_zero - do ni = nv1(nb), nv2(nb) - sumk = sumk + straext0(ni)*solwaer(nb,ni) - enddo - - extstra(nb) = sumk * rsolbd - -! --- check print -! if ( nb > 6 .and. nb < 10) then -! print *,' in optavg for sw band',nb -! print *,' nv1, nv2:',nv1(nb),nv2(nb) -! print *,' solwaer:',solwaer(nb,nv1(nb):nv2(nb)) -! print *,' extrhi:', extrhi(:,nb) -! do i = 1, NRHLEV -! print *,' extrhd for rhlev:',i -! print *,extrhd(i,:,nb) -! enddo -! print *,' sumk, rsolbd, extstra:',sumk,rsolbd,extstra(nb) -! endif - - enddo ! end do_nb_block for sw - -! --- ... loop for each lw radiation spectral band - - do nb = 1, NBDIR - - ib = NBDSW + nb - rirbd = f_one / eirbnd(nb) - -! --- for rh independent aerosol species - - do nc = 1, NCM1 - sumk = f_zero - sums = f_zero - sumok = f_zero - sumokg = f_zero - sumreft = f_zero - - do ni = nr1(nb), nr2(nb) - sp = sqrt( (f_one - rhidssa0(ni,nc)) & - & / (f_one - rhidssa0(ni,nc)*rhidasy0(ni,nc)) ) - reft = (f_one - sp) / (f_one + sp) - sumreft = sumreft + reft*eirwaer(nb,ni) - - sumk = sumk + rhidext0(ni,nc)*eirwaer(nb,ni) - sums = sums + rhidsca0(ni,nc)*eirwaer(nb,ni) - sumok = sumok + rhidssa0(ni,nc)*eirwaer(nb,ni) & - & * rhidext0(ni,nc) - sumokg = sumokg + rhidssa0(ni,nc)*eirwaer(nb,ni) & - & * rhidext0(ni,nc)*rhidasy0(ni,nc) - enddo - - refb = sumreft * rirbd - - extrhi(nc,ib) = sumk * rirbd - scarhi(nc,ib) = sums * rirbd - asyrhi(nc,ib) = sumokg / (sumok + 1.0e-10) - ssarhi(nc,ib) = 4.0*refb & - & / ( (f_one+refb)**2 - asyrhi(nc,ib)*(f_one-refb)**2 ) - enddo ! end do_nc_block for rh-ind aeros - -! --- for rh dependent aerosols species - - do nc = 1, NCM2 - do nh = 1, NRHLEV - sumk = f_zero - sums = f_zero - sumok = f_zero - sumokg = f_zero - sumreft = f_zero - - do ni = nr1(nb), nr2(nb) - sp = sqrt( (f_one - rhdpssa0(ni,nh,nc)) & - & / (f_one - rhdpssa0(ni,nh,nc)*rhdpasy0(ni,nh,nc)) ) - reft = (f_one - sp) / (f_one + sp) - sumreft = sumreft + reft*eirwaer(nb,ni) - - sumk = sumk + rhdpext0(ni,nh,nc)*eirwaer(nb,ni) - sums = sums + rhdpsca0(ni,nh,nc)*eirwaer(nb,ni) - sumok = sumok + rhdpssa0(ni,nh,nc)*eirwaer(nb,ni) & - & * rhdpext0(ni,nh,nc) - sumokg = sumokg + rhdpssa0(ni,nh,nc)*eirwaer(nb,ni) & - & * rhdpext0(ni,nh,nc)*rhdpasy0(ni,nh,nc) - enddo - - refb = sumreft * rirbd - - extrhd(nh,nc,ib) = sumk * rirbd - scarhd(nh,nc,ib) = sums * rirbd - asyrhd(nh,nc,ib) = sumokg / (sumok + 1.0e-10) - ssarhd(nh,nc,ib) = 4.0*refb & - & / ( (f_one+refb)**2 - asyrhd(nh,nc,ib)*(f_one-refb)**2 ) - enddo ! end do_nh_block - enddo ! end do_nc_block for rh-dep aeros - -! --- for stratospheric background aerosols - - sumk = f_zero - do ni = nr1(nb), nr2(nb) - sumk = sumk + straext0(ni)*eirwaer(nb,ni) - enddo - - extstra(ib) = sumk * rirbd - -! --- check print -! if ( nb >= 1 .and. nb < 5) then -! print *,' in optavg for ir band:',nb -! print *,' nr1, nr2:',nr1(nb),nr2(nb) -! print *,' eirwaer:',eirwaer(nb,nr1(nb):nr2(nb)) -! print *,' extrhi:', extrhi(:,ib) -! do i = 1, NRHLEV -! print *,' extrhd for rhlev:',i -! print *,extrhd(i,:,ib) -! enddo -! print *,' sumk, rirbd, extstra:',sumk,rirbd,extstra(ib) -! endif - - enddo ! end do_nb_block for lw - -! - return -!................................ - end subroutine optavg -!-------------------------------- -! -!................................... - end subroutine clim_aerinit -!----------------------------------- - - -!----------------------------------- - subroutine setclimaer & -!................................... - -! --- inputs: - & ( alon,alat,prsi,rhlay,dz,hz,NBDSWLW, & - & IMAX,NLAY,NLP1, iflip, lsswr,lslwr, & -! --- outputs: - & aerosw,aerolw & - & ) - -! ================================================================== ! -! ! -! setaer maps the 5 degree global climatological aerosol data set ! -! onto model grids ! -! ! -! inputs: ! -! NBDSW - total number of sw spectral bands 1 ! -! alon, alat IMAX ! -! - longitude and latitude of given points in degree ! -! prsi - pressure at interface mb IMAX*NLP1 ! -! rhlay - layer mean relative humidity IMAX*NLAY ! -! dz - layer thickness m IMAX*NLAY ! -! hz - level high m IMAX*NLP1 ! -! NBDSWLW - total number of sw+ir bands for aeros opt prop 1 ! -! IMAX - horizontal dimension of arrays 1 ! -! NLAY,NLP1-vertical dimensions of arrays 1 ! -! iflip - control flag for direction of vertical index 1 ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! lsswr,lslwr ! -! - logical flag for sw/lw radiation calls 1 ! -! ! -! outputs: ! -! aerosw - aeros opt properties for sw IMAX*NLAY*NBDSW*NF_AESW! -! (:,:,:,1): optical depth ! -! (:,:,:,2): single scattering albedo ! -! (:,:,:,3): asymmetry parameter ! -! aerolw - aeros opt properties for lw IMAX*NLAY*NBDLW*NF_AELW! -! (:,:,:,1): optical depth ! -! (:,:,:,2): single scattering albedo ! -! (:,:,:,3): asymmetry parameter ! -! ! -! module parameters and constants: ! -! NBDSW - total number of sw bands for aeros opt prop 1 ! -! NBDIR - total number of ir bands for aeros opt prop 1 ! -! ! -! module variable: (set by subroutine clim_aerinit) ! -! kprfg - aerosols profile index IMXAE*JMXAE ! -! idxcg - aerosols component index NXC*IMXAE*JMXAE ! -! cmixg - aerosols component mixing ratio NXC*IMXAE*JMXAE ! -! denng - aerosols number density NXC*IMXAE*JMXAE ! -! ! -! usage: call setclimaer ! -! ! -! subprograms called: radclimaer ! -! ! -! ================================================================== ! -! - implicit none - -! --- inputs: - integer, intent(in) :: IMAX,NLAY,NLP1,iflip,NBDSWLW - logical, intent(in) :: lsswr, lslwr - - real (kind=kind_phys), dimension(:,:), intent(in) :: prsi, & - & rhlay, dz, hz - real (kind=kind_phys), dimension(:), intent(in) :: alon, alat - -! --- outputs: - real (kind=kind_phys), dimension(:,:,:,:), intent(out) :: & - & aerosw, aerolw - -! --- locals: - real (kind=kind_phys), dimension(NXC) :: cmix, denn - integer, dimension(NXC) :: idxc - - real (kind=kind_phys), dimension(NLAY) :: delz, rh1, dz1 - integer, dimension(NLAY) :: idmaer - - real (kind=kind_phys), dimension(NLAY,NBDSWLW):: tauae,ssaae,asyae -!test real (kind=kind_phys), dimension(IMAX,NLAY) :: aersav - - real (kind=kind_phys) :: tmp1, tmp2 - - integer :: i, i1, i2, j1, j2, k, m, m1, kp - -! --- conversion constants -! jbao new gfs phys real (kind=kind_phys), parameter :: dltg = 360.0 / float(IMXAE) ! imxae=72 -! jbao new gfs phys real (kind=kind_phys), parameter :: hdlt = 0.5 * dltg - real (kind=kind_phys), parameter :: dltg = 360.0 / 72.0 - real (kind=kind_phys), parameter :: hdlt = 180.0/ 72.0 - -! -!===> ... begin here -! -! --- map grid in longitude direction - - lab_do_IMAX : do i = 1, IMAX - i2 = 1 - j2 = 1 - - lab_do_IMXAE : do i1 = 1, IMXAE - tmp1 = dltg * (i1 - 1) + hdlt - - if (abs(alon(i)-tmp1) <= hdlt) then - i2 = i1 - exit lab_do_IMXAE - endif - enddo lab_do_IMXAE - -! --- map grid in latitude direction - - lab_do_JMXAE : do j1 = 1, JMXAE - tmp2 = 90.0 - dltg * (j1 - 1) - if (abs(alat(i)-tmp2) <= hdlt) then - j2 = j1 - exit lab_do_JMXAE - endif - enddo lab_do_JMXAE - - do m = 1, NXC - idxc(m) = idxcg(m,i2,j2) - cmix(m) = cmixg(m,i2,j2) - denn(m) = denng(m,i2,j2) - enddo - kp = kprfg(i2,j2) - - do k = 1, NLAY - rh1(k) = rhlay(i,k) - dz1(k) = dz (i,k) - enddo - -! --- compute vertical domain indices - - lab_if_flip : if (iflip == 1) then ! input from sfc to toa - -! --- setup domain index array and effective layer thickness - - i1 = 1 - do k = 1, NLAY - if (prsi(i,k+1) < prsref(i1,kp)) then - i1 = i1 + 1 - if (i1 == 2 .and. prsref(2,kp) == prsref(3,kp)) then - i1 = 3 - endif - endif - idmaer(k) = i1 - - tmp1 = haer(i1,kp) - if (tmp1 > f_zero) then - tmp2 = f_one / tmp1 - delz(k) = tmp1 * (exp(-hz(i,k)*tmp2)-exp(-hz(i,k+1)*tmp2)) - else - delz(k) = dz1(k) - endif - enddo - - else lab_if_flip ! input from toa to sfc -! --- setup domain index array and modified layer thickness - - i1 = 1 - do k = NLAY, 1, -1 - if (prsi(i,k) < prsref(i1,kp)) then - i1 = i1 + 1 - if (i1 == 2 .and. prsref(2,kp) == prsref(3,kp)) then - i1 = 3 - endif - endif - idmaer(k) = i1 - - tmp1 = haer(i1,kp) - if (tmp1 > f_zero) then - tmp2 = f_one / tmp1 - delz(k) = tmp1 * (exp(-hz(i,k+1)*tmp2)-exp(-hz(i,k)*tmp2)) - else - delz(k) = dz1(k) - endif - enddo - endif lab_if_flip - -! --- check print - -! print *,' in setclimaer, profile:',i -! print *,' rh :',rh1 -! print *,' dz :',dz1 -! print *,' delz :',delz -! print *,' idmaer:',idmaer - -! --- calculate sw/lw aerosol optical properties for the -! corresponding frequency bands - - call radclimaer -! --- inputs: (in scope variables) -! --- outputs: (in scope variables) - - if ( lsswr ) then - - if ( laswflg ) then - - do m = 1, NBDSW - do k = 1, NLAY - aerosw(i,k,m,1) = tauae(k,m) - aerosw(i,k,m,2) = ssaae(k,m) - aerosw(i,k,m,3) = asyae(k,m) - enddo - enddo - - else - - aerosw(:,:,:,:) = f_zero - - endif - -! --- testing use -! do k = 1, NLAY -! aersav(i,k) = tauae(k,1) -!test enddo - endif ! end if_lsswr_block - - if ( lslwr ) then - - if ( lalwflg ) then - - if ( NBDIR == 1 ) then - m1 = NBDSW + 1 - do m = 1, NBDLW - do k = 1, NLAY - aerolw(i,k,m,1) = tauae(k,m1) - aerolw(i,k,m,2) = ssaae(k,m1) - aerolw(i,k,m,3) = asyae(k,m1) - enddo - enddo - else - do m = 1, NBDLW - m1 = NBDSW + m - do k = 1, NLAY - aerolw(i,k,m,1) = tauae(k,m1) - aerolw(i,k,m,2) = ssaae(k,m1) - aerolw(i,k,m,3) = asyae(k,m1) - enddo - enddo - endif - - else - - aerolw(:,:,:,:) = f_zero - - endif - endif ! end if_lslwr_block - - enddo lab_do_IMAX - -! ================= - contains -! ================= - -!-------------------------------- - subroutine radclimaer -!................................ - -! --- inputs: (in scope variables) -! --- outputs: (in scope variables) - -! ================================================================== ! -! ! -! compute aerosols optical properties in NBDSW sw bands. there are ! -! seven different vertical profile structures. in the troposphere, ! -! aerosol distribution at each grid point is composed from up to ! -! six components out of a total of ten different substances. ! -! ! -! ref: wmo report wcp-112 (1986) ! -! ! -! input variables: ! -! idxc - indices of aerosol components - NXC ! -! cmix - mixing ratioes of aerosol components - NXC ! -! denn - aerosol number densities - NXC ! -! rh1 - relative humidity - NLAY ! -! delz - effective layer thickness km NLAY ! -! idmaer - aerosol domain index - NLAY ! -! NXC - number of different aerosol components- 1 ! -! NLAY - vertical dimensions - 1 ! -! iflip - control flag for direction of vertical index ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! ! -! output variables: ! -! tauae - optical depth - NLAY*NBDSW ! -! ssaae - single scattering albedo - NLAY*NBDSW ! -! asyae - asymmetry parameter - NLAY*NBDSW ! -! ! -! ================================================================== ! -! - implicit none - -! - real (kind=kind_phys) :: crt1, crt2 - parameter (crt1=30.0, crt2=0.03333) - -! --- inputs: -! --- outputs: - -! --- locals: - real (kind=kind_phys) :: cm, hd, hdi, sig0u, sig0l, ratio, tt0, & - & ex00, sc00, ss00, as00, ex01, sc01, ss01, as01, tt1, & - & ex02, sc02, ss02, as02, ex03, sc03, ss03, as03, tt2, & - & ext1, sca1, ssa1, asy1, drh0, drh1, rdrh - - integer :: ih1, ih2, kk, idom, icmp, ib, ii, ic, ic1 - -! -!===> ... loop over vertical layers from top to surface -! - lab_do_layer : do kk = 1, NLAY - -! --- linear interp coeffs for rh-dep species - - ih2 = 1 - do while ( rh1(kk) > rhlev(ih2) ) - ih2 = ih2 + 1 - if ( ih2 > NRHLEV ) exit - enddo - ih1 = max( 1, ih2-1 ) - ih2 = min( NRHLEV, ih2 ) - - drh0 = rhlev(ih2) - rhlev(ih1) - drh1 = rh1(kk) - rhlev(ih1) - if ( ih1 == ih2 ) then - rdrh = f_zero - else - rdrh = drh1 / drh0 - endif - -! --- assign optical properties in each domain - - idom = idmaer(kk) - - lab_if_idom : if (idom == 5) then -! --- 5th domain - upper stratosphere assume no aerosol - - do ib = 1, NBDSWLW - tauae(kk,ib) = f_zero - if ( ib <= NBDSW ) then - ssaae(kk,ib) = 0.99 - asyae(kk,ib) = 0.696 - else - ssaae(kk,ib) = 0.5 - asyae(kk,ib) = 0.3 - endif - enddo - - elseif (idom == 4) then lab_if_idom -! --- 4th domain - stratospheric layers - - do ib = 1, NBDSWLW - tauae(kk,ib) = extstra(ib) * delz(kk) - if ( ib <= NBDSW ) then - ssaae(kk,ib) = 0.99 - asyae(kk,ib) = 0.696 - else - ssaae(kk,ib) = 0.5 - asyae(kk,ib) = 0.3 - endif - enddo - - elseif (idom == 3) then lab_if_idom -! --- 3rd domain - free tropospheric layers -! 1:inso 0.17e-3; 2:soot 0.4; 7:waso 0.59983; n:730 - - do ib = 1, NBDSWLW - ex01 = extrhi(1,ib) - sc01 = scarhi(1,ib) - ss01 = ssarhi(1,ib) - as01 = asyrhi(1,ib) - - ex02 = extrhi(2,ib) - sc02 = scarhi(2,ib) - ss02 = ssarhi(2,ib) - as02 = asyrhi(2,ib) - - ex03 = extrhd(ih1,1,ib) & - & + rdrh * (extrhd(ih2,1,ib) - extrhd(ih1,1,ib)) - sc03 = scarhd(ih1,1,ib) & - & + rdrh * (scarhd(ih2,1,ib) - scarhd(ih1,1,ib)) - ss03 = ssarhd(ih1,1,ib) & - & + rdrh * (ssarhd(ih2,1,ib) - ssarhd(ih1,1,ib)) - as03 = asyrhd(ih1,1,ib) & - & + rdrh * (asyrhd(ih2,1,ib) - asyrhd(ih1,1,ib)) - - ext1 = 0.17e-3*ex01 + 0.4*ex02 + 0.59983*ex03 - sca1 = 0.17e-3*sc01 + 0.4*sc02 + 0.59983*sc03 - ssa1 = 0.17e-3*ss01*ex01 + 0.4*ss02*ex02 + 0.59983*ss03*ex03 - asy1 = 0.17e-3*as01*sc01 + 0.4*as02*sc02 + 0.59983*as03*sc03 - - tauae(kk,ib) = ext1 * 730.0 * delz(kk) - ssaae(kk,ib) = min(f_one, ssa1/ext1) - asyae(kk,ib) = min(f_one, asy1/sca1) - enddo - - elseif (idom == 1) then lab_if_idom -! --- 1st domain - mixing layer - - lab_do_ib : do ib = 1, NBDSWLW - ext1 = f_zero - sca1 = f_zero - ssa1 = f_zero - asy1 = f_zero - - lab_do_icmp : do icmp = 1, NXC - ic = idxc(icmp) - cm = cmix(icmp) - - lab_if_ic : if (ic > NCM1) then - ic1 = ic - NCM1 - - ex00 = extrhd(ih1,ic1,ib) & - & + rdrh * (extrhd(ih2,ic1,ib) - extrhd(ih1,ic1,ib)) - sc00 = scarhd(ih1,ic1,ib) & - & + rdrh * (scarhd(ih2,ic1,ib) - scarhd(ih1,ic1,ib)) - ss00 = ssarhd(ih1,ic1,ib) & - & + rdrh * (ssarhd(ih2,ic1,ib) - ssarhd(ih1,ic1,ib)) - as00 = asyrhd(ih1,ic1,ib) & - & + rdrh * (asyrhd(ih2,ic1,ib) - asyrhd(ih1,ic1,ib)) - - ext1 = ext1 + cm * ex00 - sca1 = sca1 + cm * sc00 - ssa1 = ssa1 + cm * ss00 * ex00 - asy1 = asy1 + cm * as00 * sc00 - else if (ic > 0) then lab_if_ic - ext1 = ext1 + cm * extrhi(ic,ib) - sca1 = sca1 + cm * scarhi(ic,ib) - ssa1 = ssa1 + cm * ssarhi(ic,ib) * extrhi(ic,ib) - asy1 = asy1 + cm * asyrhi(ic,ib) * scarhi(ic,ib) - endif lab_if_ic - - enddo lab_do_icmp - - tauae(kk,ib) = ext1 * denn(1) * delz(kk) - ssaae(kk,ib) = min(f_one, ssa1/ext1) - asyae(kk,ib) = min(f_one, asy1/sca1) - enddo lab_do_ib - - elseif (idom == 2) then lab_if_idom -! --- 2nd domain - mineral transport layers - - do ib = 1, NBDSWLW - tauae(kk,ib) = extrhi(6,ib) * denn(2) * delz(kk) - ssaae(kk,ib) = ssarhi(6,ib) - asyae(kk,ib) = asyrhi(6,ib) - enddo - - else lab_if_idom -! --- domain index out off range, assume no aerosol - - do ib = 1, NBDSWLW - tauae(kk,ib) = f_zero - ssaae(kk,ib) = f_one - asyae(kk,ib) = f_zero - enddo - -! write(6,19) kk,idom -! 19 format(/' *** ERROR in sub AEROS: domain index out' & -! &, ' of range! K, IDOM =',3i5,' ***') -! stop 19 - - endif lab_if_idom - - enddo lab_do_layer -! -!===> ... smooth profile at domain boundaries -! - if ( iflip == 0 ) then ! input from toa to sfc - - do ib = 1, NBDSWLW - do kk = 2, NLAY - if ( tauae(kk,ib) > f_zero ) then - ratio = tauae(kk-1,ib) / tauae(kk,ib) - else - ratio = f_one - endif - - tt0 = tauae(kk,ib) + tauae(kk-1,ib) - tt1 = 0.2 * tt0 - tt2 = tt0 - tt1 - - if ( ratio > crt1 ) then - tauae(kk,ib) = tt1 - tauae(kk-1,ib) = tt2 - endif - - if ( ratio < crt2 ) then - tauae(kk,ib) = tt2 - tauae(kk-1,ib) = tt1 - endif - enddo ! do_kk_loop - enddo ! do_ib_loop - - else ! input from sfc to toa - - do ib = 1, NBDSWLW - do kk = NLAY-1, 1, -1 - if ( tauae(kk,ib) > f_zero ) then - ratio = tauae(kk+1,ib) / tauae(kk,ib) - else - ratio = f_one - endif - - tt0 = tauae(kk,ib) + tauae(kk+1,ib) - tt1 = 0.2 * tt0 - tt2 = tt0 - tt1 - - if ( ratio > crt1 ) then - tauae(kk,ib) = tt1 - tauae(kk+1,ib) = tt2 - endif - - if ( ratio < crt2 ) then - tauae(kk,ib) = tt2 - tauae(kk+1,ib) = tt1 - endif - enddo ! do_kk_loop - enddo ! do_ib_loop - - endif - -! - return -!................................ - end subroutine radclimaer -!-------------------------------- -! -!................................... - end subroutine setclimaer -!----------------------------------- - - -!..........................................! - end module module_radiation_aerosols ! -!==========================================! diff --git a/src/fim/FIMsrc/fim/column/radiation_astronomy.f b/src/fim/FIMsrc/fim/column/radiation_astronomy.f deleted file mode 100644 index 445dbd5..0000000 --- a/src/fim/FIMsrc/fim/column/radiation_astronomy.f +++ /dev/null @@ -1,760 +0,0 @@ -!!!!! ========================================================== !!!!! -!!!!! 'module_radiation_astronomy' description !!!!! -!!!!! ========================================================== !!!!! -! ! -! set up astronomy quantities for solar radiation calculations. ! -! ! -! in module 'module_radiation_astronomy', externally accessable ! -! subroutines are listed below: ! -! ! -! 'solinit' -- read in solar constant ! -! input: ! -! ( ISOL, iyear, me ) ! -! output: ! -! ( none ) ! -! ! -! 'astronomy' -- get astronomy related quantities ! -! input: ! -! ( lons_lar,glb_lats_r,sinlat,coslat,xlon, ! -!! fhswr,jdate,deltim, ! -! fhswr,jdate, ! -! LON2,LATD,LATR,IPT_LATR, lsswr, me) ! -! output: ! -! ( solcon,slag,sdec,cdec,coszen,coszdg) ! -! ! -! ! -! external modules referenced: ! -! 'module machine' in 'machine.f' ! -! 'module physcons' in 'physcons.f ! -! ! -! program history log: ! -! may-06-1977 --- ray orzol, created at gfdl ! -! jul-07-1989 --- kenneth campana ! -! may-15-1998 --- mark iredell y2k compliance ! -! dec-15-2003 --- yu-tai hou combined compjd and fcstim and ! -! rewrite in fortran 90 compatable form ! -! feb-15-2006 --- yu-tai hou add 11-yr solar constant cycle ! -! ! -!!!!! ========================================================== !!!!! -!!!!! end descriptions !!!!! -!!!!! ========================================================== !!!!! - - - -!========================================! - module module_radiation_astronomy ! -!........................................! -! - use machine, only : kind_phys - use physcons, only : con_solr, con_pi - use module_iounitdef, only : NIRADSF -! - implicit none -! - private - -! --- parameter constants - real (kind=kind_phys), parameter :: degrad = 180.0/con_pi - real (kind=kind_phys), parameter :: tpi = 2.0 * con_pi - real (kind=kind_phys), parameter :: hpi = 0.5 * con_pi - -! --- module variables: - real (kind=kind_phys), public :: solc0 - - public solinit, astronomy - - -! ================= - contains -! ================= - -!----------------------------------- - subroutine solinit & -!................................... - -! --- inputs: - & ( ISOL, iyear, me ) -! --- outputs: ( none ) - -! =================================================================== ! -! ! -! read in solar constant value for a given year ! -! ! -! inputs: ! -! ISOL - =0: use fixed solar constant in "physcon" ! -! =1: use 11-year cycle solar constant from table ! -! iyear - year of the recorded data 1 ! -! me - print message control flag 1 ! -! ! -! outputs: (to module variable) ! -! ( none ) ! -! ! -! module variable: ! -! solc0 - solar constant (w/m**2) 1 ! -! ! -! usage: call solinit ! -! ! -! subprograms called: none ! -! ! -! =================================================================== ! -! - implicit none - -! --- input: - integer, intent(in) :: ISOL, iyear, me - -! --- output: ( none ) - -! --- local: - real (kind=kind_phys):: smean, solc1 - integer :: i, iyr, iyr1, iyr2, jyr - logical :: file_exist - character :: cline*60, cfile0*26 - - data cfile0 / 'solarconstantdata.txt' / - -!===> ... begin here - - if ( ISOL == 0 ) then - solc0 = con_solr - - if ( me == 0 ) then -! print *,' - Using fixed solar constant =', solc0 - endif - - return - endif - -! --- ... check to see if solar constant data file existed - - inquire (file=cfile0, exist=file_exist) - if ( .not. file_exist ) then - solc0 = con_solr - - if ( me == 0 ) then -! print *,' - Using varying solar constant with 11-year cycle' -! print *,' Requested solar data file "',cfile0, & -!! & '" not found!' -! print *,' Using the default solar constant value =',solc0, & -! & ' instead!!' - endif - else - iyr = iyear - - open (NIRADSF,file=cfile0,form='formatted',status='old') - rewind NIRADSF - - read (NIRADSF, 24) iyr1, iyr2, smean, cline - 24 format(i4,2x,i4,f8.2,a60) - - if ( me == 0 ) then -! print *,' - Using varying solar constant with 11-year cycle' -! print *,' Opened solar constant data file: ',cfile0 -!check print *, iyr1, iyr2, smean, cline - endif - - if ( iyr < iyr1 ) then - Lab_dowhile1 : do while ( iyr < iyr1 ) - iyr = iyr + 11 - enddo Lab_dowhile1 - - if ( me == 0 ) then -! print *,' *** Year',iyear,' out of table range!' -! print *,' Using the 11-cycle year (',iyr,' ) value.' - endif - elseif ( iyr > iyr2 ) then - Lab_dowhile2 : do while ( iyr > iyr2 ) - iyr = iyr - 11 - enddo Lab_dowhile2 - - if ( me == 0 ) then -! print *,' *** Year',iyear,' out of table range!' -! print *,' Using the 11-cycle year (',iyr,' ) value.' - endif - endif - - i = iyr2 - Lab_dowhile3 : do while ( i >= iyr1 ) -! read (NIRADSF,26) jyr, solc1 -! 26 format(i4,f8.2) - read (NIRADSF,*) jyr, solc1 - - if ( i == iyr .and. iyr == jyr ) then - solc0 = smean + solc1 - if (me == 0) then -! print *,' CHECK: Solar constant data for year',iyr, & -! & solc1, solc0 - endif - exit Lab_dowhile3 - else -!check if (me == 0) print *,' Skip solar const data for year',i - i = i - 1 - endif - enddo Lab_dowhile3 - - close ( NIRADSF ) - endif ! end if_file_exist_block - -! - return -!................................... - end subroutine solinit -!----------------------------------- - - -!----------------------------------- - subroutine astronomy & -!................................... - -! --- inputs: - & ( lons_lar,glb_lats_r,sinlat,coslat,xlon, & -! & fhswr,jdate,deltim, & - & fhswr,jdate, & - & LON2,LATD,LATR,IPT_LATR, lsswr, me, & -! --- outputs: - & solcon,slag,sdec,cdec,coszen,coszdg & - & ) - -! =================================================================== ! -! ! -! astronomy computes solar parameters at forecast time ! -! ! -! inputs: dimension ! -! lons_lar - num of grid pts on a given lat circle (LATR)! -! glb_lats_r - index for global latitudes (LATR)! -! sinlat,coslat - sin and cos of latitude (LATR)! -! xlon - longitude in radians (LON2*LATD)! -! fhswr - sw radiation calling interval in hour ! -! jdate - current forecast date and time (8) ! -! (yr, mon, day, t-zone, hr, min, sec, mil-sec) ! -!! deltim - duration of model integration time step in seconds ! -! LON2,LATD,LATR- dimensions for longitude/latitude directions ! -! IPT_LATR - latitude index location indecator ! -! lsswr - logical control flag for sw radiation call ! -! me - integer control flag for diagnostic print out ! -! ! -! outputs: ! -! solcon - sun-earth distance adjusted solar constant (w/m2) ! -! slag - equation of time in radians ! -! sdec, cdec - sin and cos of the solar declination angle ! -! coszen - avg of cosz for daytime only (LON2,LATD)! -! coszdg - avg of cosz over entire sw call interval(LON2,LATD)! -! ! -! ! -! external functions called: iw3jdn ! -! ! -! =================================================================== ! -! - implicit none - -! --- input: - integer, intent(in) :: LON2, LATD, LATR, IPT_LATR, me - integer, intent(in) :: lons_lar(:), glb_lats_r(:), jdate(:) - - logical, intent(in) :: lsswr - - real (kind=kind_phys), intent(in) :: sinlat(:), coslat(:), & - & xlon(:,:), fhswr -! & xlon(:,:), fhswr, deltim - -! --- output: - real (kind=kind_phys), intent(out) :: solcon, slag, sdec, cdec, & - & coszen(:,:), coszdg(:,:) - -! --- locals: - real (kind=kind_phys), parameter :: f24 = 24.0 ! hours/day - real (kind=kind_phys), parameter :: f1440 = 1440.0 ! minutes/day - - real (kind=kind_phys) :: solhr, fjd, fjd1, dlt, r1, alp, solc - - integer :: jd, jd1, iyear, imon, iday, ihr, imin - integer :: iw3jdn - -!===> ... begin here - - iyear = jdate(1) - imon = jdate(2) - iday = jdate(3) - ihr = jdate(5) - imin = jdate(6) - -! --- ... calculate forecast julian day and fraction of julian day - - jd1 = iw3jdn(iyear,imon,iday) - -! --- ... unlike in normal applications, where day starts from 0 hr, -! in astronomy applications, day stats from noon. - - if (ihr < 12) then - jd1 = jd1 - 1 -! fjd1= 0.5 + float(ihr)/f24 ! use next line if imin > 0 - fjd1= 0.5 + float(ihr)/f24 + float(imin)/f1440 - else -! fjd1= float(ihr - 12)/f24 ! use next line if imin > 0 - fjd1= float(ihr - 12)/f24 + float(imin)/f1440 - endif - - fjd1 = fjd1 + jd1 - - jd = int(fjd1) - fjd = fjd1 - jd - - if (lsswr) then - -! --- ... hour of forecast time - - solhr = mod( float(ihr), f24 ) - - call solar & -! --- inputs: - & ( jd,fjd, & -! --- outputs: - & r1,dlt,alp,slag,sdec,cdec & - & ) - -! if (me == 0) print*,'in astronomy completed sr solar' - - call coszmn & -! --- inputs: - & ( lons_lar,glb_lats_r,xlon,sinlat,coslat, & -! & fhswr,deltim,solhr,sdec,cdec,slag, & - & fhswr,solhr,sdec,cdec,slag, & - & LON2,LATD,IPT_LATR, & -! --- outputs: - & coszen,coszdg & - & ) - -! if (me == 0) print*,'in astronomy completed sr coszmn' - -! --- ... calculate sun-earth distance adjustment factor appropriate for date - - solcon = solc0 / (r1*r1) - - endif - -! --- ... diagnostic print out - - if (me == 0) then - - call prtime & -! --- inputs: - & ( jd, fjd, dlt, alp, r1, slag, solcon & -! --- outputs: ( none ) - & ) - - endif - -! - return -!................................... - end subroutine astronomy -!----------------------------------- - - -!----------------------------------- - subroutine solar & -!................................... - -! --- inputs: - & ( jd,fjd, & -! --- outputs: - & r1,dlt,alp,slag,sdec,cdec & - & ) - -! =================================================================== ! -! ! -! solar computes radius vector, declination and right ascension of ! -! sun, and equation of time. ! -! ! -! inputs: ! -! jd - julian day ! -! fjd - fraction of the julian day ! -! ! -! outputs: ! -! r1 - earth-sun radius vector ! -! dlt - declination of sun in radians ! -! alp - right ascension of sun in radians ! -! slag - equation of time in radians ! -! sdec - sine of declination angle ! -! cdec - cosine of declination angle ! -! ! -! usage: call solar ! -! ! -! external subroutines called: none ! -! ! -! program history log: ! -! mar-xx-1989 --- kenneth campana, patterner after original gfdl ! -! code but no calculation of latitude mean cos ! -! solar zenith angle. ! -! fall -1988 --- hualu pan, updated to limit iterations in newton! -! method and also ccr reduced to avoid non- ! -! convergence. ! -! dec-15-2003 --- yu-tai hou, updated to make fortran 90 compatable! -! ! -! =================================================================== ! -! - implicit none - -! --- inputs: - real (kind=kind_phys), intent(in) :: fjd - integer, intent(in) :: jd - -! --- outputs: - real (kind=kind_phys), intent(out) :: r1, dlt,alp,slag,sdec,cdec - -! --- locals: - real (kind=kind_phys), parameter :: cyear = 365.25 ! days of year - real (kind=kind_phys), parameter :: ccr = 1.3e-6 ! iteration limit - real (kind=kind_phys), parameter :: tpp = 1.55 ! days between epoch and - ! perihelion passage of 1900 - real (kind=kind_phys), parameter :: svt6 = 78.035 ! days between perihelion passage - ! and march equinox of 1900 - integer, parameter :: jdor = 2415020 ! jd of epoch which is january - ! 0, 1900 at 12 hours ut - - real (kind=kind_phys) :: dat, t1, year, tyear, ec, angin, ador, & - & deleqn, sni, tini, er, qq, e1, ep, cd, eq, date, em, & - & cr, w1, tst, sun - - integer :: jdoe, iter - -!===> ... begin here - -! --- ... computes time in julian centuries after epoch - - t1 = float(jd - jdor) / 36525.0 - -! --- ... computes length of anomalistic and tropical years (minus 365 days) - - year = 0.25964134e0 + 0.304e-5 * t1 - tyear= 0.24219879E0 - 0.614e-5 * t1 - -! --- ... computes orbit eccentricity and angle of earth's inclination from t - - ec = 0.01675104e0 - (0.418e-4 + 0.126e-6 * t1) * t1 - angin= 23.452294e0 - (0.0130125e0 + 0.164e-5 * t1) * t1 - - ador = jdor - jdoe = ador + (svt6 * cyear) / (year - tyear) - -! --- ... deleqn is updated svt6 for current date - - deleqn= float(jdoe - jd) * (year - tyear) / cyear - year = year + 365.0 - sni = sin( angin / degrad ) - tini = 1.0 / tan( angin / degrad ) - er = sqrt( (1.0 + ec) / (1.0 - ec) ) - qq = deleqn * tpi / year - -! --- ... determine true anomaly at equinox - - e1 = 1.0 - cd = 1.0 - iter = 0 - - lab_do_1 : do while ( cd > ccr ) - - ep = e1 - (e1 - ec*sin(e1) - qq) / (1.0 - ec*cos(e1)) - cd = abs(e1 - ep) - e1 = ep - iter = iter + 1 - - if (iter > 10) then - write(6,*) ' ITERATION COUNT FOR LOOP 32 =', iter - write(6,*) ' E, EP, CD =', e1, ep, cd - exit lab_do_1 - endif - - enddo lab_do_1 - - eq = 2.0 * atan( er * tan( 0.5*e1 ) ) - -! --- ... date is days since last perihelion passage - - dat = float(jd - jdor) - tpp + fjd - date = mod(dat, year) - -! --- ... solve orbit equations by newton's method - - em = tpi * date / year - e1 = 1.0 - cr = 1.0 - iter = 0 - - lab_do_2 : do while ( cr > ccr ) - - ep = e1 - (e1 - ec*sin(e1) - em) / (1.0 - ec*cos(e1)) - cr = abs(e1 - ep) - e1 = ep - iter = iter + 1 - - if (iter > 10) then - write(6,*) ' ITERATION COUNT FOR LOOP 31 =', iter - exit lab_do_2 - endif - - enddo lab_do_2 - - w1 = 2.0 * atan( er * tan( 0.5*e1 ) ) - - r1 = 1.0 - ec*cos(e1) - - sdec = sni * sin(w1 - eq) - cdec = sqrt( 1.0 - sdec*sdec ) - - dlt = asin( sdec ) - alp = asin( tan(dlt)*tini ) - - tst = cos( w1 - eq ) - if (tst < 0.0) alp = con_pi - alp - if (alp < 0.0) alp = alp + tpi - - sun = tpi * (date - deleqn) / year - if (sun < 0.0) sun = sun + tpi - slag = sun - alp - 0.03255e0 - -! - return -!................................... - end subroutine solar -!----------------------------------- - - -!----------------------------------- - subroutine coszmn & -!................................... - -! --- inputs: - & ( lons_lar,glb_lats_r,xlon,sinlat,coslat, & -! & dtswav,deltim,solhr,sdec,cdec,slag, & - & dtswav,solhr,sdec,cdec,slag, & - & NLON2,LATD,IPT_LATR, & -! --- outputs: - & coszen,coszdg & - & ) - -! =================================================================== ! -! ! -! coszmn computes mean cos solar zenith angle over 'dtswav' hours. ! -! ! -! inputs: ! -! lons_lar - num of grid pts on a given lat circle ! -! glb_lats_r - index for global latitude ! -! xlon - longitude in radians ! -! sinlat,coslat - sin and cos of latitude ! -! dtswav - sw radiation calling interval in hour ! -!! deltim - duration of model integration time step in second ! -! solhr - time after 00z in hours ! -! sdec, cdec - sin and cos of the solar declination angle ! -! slag - equation of time ! -! NLON2,LATD - dimensions for longitude/latitude directions ! -! IPT_LATR - latitude index location indecator ! -! ! -! outputs: ! -! coszen - average of cosz for daytime only in sw call interval -! coszdg - average of cosz over entire sw call interval ! -! ! -! usage: call comzmn ! -! ! -! external subroutines called: none ! -! ! -! program history log: ! -! 05-28-2004 yu-tai hou - modified for gfs hybrid model ! -! ! -! =================================================================== ! -! - implicit none - -! --- inputs: - integer, intent(in) :: NLON2, LATD, IPT_LATR - integer, intent(in) :: lons_lar(:), glb_lats_r(:) - - real (kind=kind_phys), intent(in) :: sinlat(:), coslat(:), & - & xlon(:,:), dtswav, solhr, sdec, cdec, slag -! & xlon(:,:), dtswav, deltim, solhr, sdec, cdec, slag - -! --- outputs: - real (kind=kind_phys), intent(out) :: coszen(:,:), coszdg(:,:) - -! --- locals: - real (kind=kind_phys) :: coszn(NLON2), pid12, cns, ss, cc - - integer :: istsun(NLON2), nstp, istp, nlon, nlnsp, i, it, j, lat - -!===> ... begin here - - nlon = NLON2 / 2 - - nstp = 6 ! number of cosz calc per fcst hour -! nstp = max(6, min(10, nint(3600.0/deltim) )) ! for better time step sync - istp = nint( dtswav*nstp ) ! total num of calc in dtswav interval - -! pid12 = con_pi / 12.0 ! angle per hour - pid12 = (2.0 * asin(1.0)) / 12.0 - - do j = 1, LATD - lat = glb_lats_r(IPT_LATR-1+j) - nlnsp = lons_lar(lat) - - do i = 1, NLON2 - coszen(i,j) = 0.0 - istsun(i) = 0 - enddo - - do it = 1, istp - cns = pid12 * (solhr - 12.0 + float(it-1)/float(nstp)) + slag - ss = sinlat(lat) * sdec - cc = coslat(lat) * cdec - - do i = 1, nlnsp - coszn(i) = ss + cc * cos(cns + xlon(i,j)) - coszen(i,j) = coszen(i,j) + max(0.0, coszn(i)) - if (coszn(i) > 0.0001) istsun(i) = istsun(i) + 1 - enddo - enddo - -! --- ... compute time averages - - do i = 1, NLON2 - coszdg(i,j) = coszen(i,j) / float(istp) - if (istsun(i) > 0) coszen(i,j) = coszen(i,j) / istsun(i) - enddo - enddo - -! - return -!................................... - end subroutine coszmn -!----------------------------------- - - -!----------------------------------- - subroutine prtime & -!................................... - -! --- inputs: - & ( jd, fjd, dlt, alp, r1, slag, solc & -! --- outputs: ( none ) - & ) - -! =================================================================== ! -! ! -! prtime prints out forecast date, time, and astronomy quantities. ! -! ! -! inputs: ! -! jd - forecast julian day ! -! fjd - forecast fraction of julian day ! -! dlt - declination angle of sun in radians ! -! alp - right ascension of sun in radians ! -! r1 - earth-sun radius vector in meter ! -! slag - equation of time in radians ! -! solc - solar constant in w/m^2 ! -! ! -! outputs: ( none ) ! -! ! -! usage: call prtime ! -! ! -! external subroutines called: w3fs26 ! -! ! -! program history log: ! -! jun-07-1977 --- robert white (gfdl) ! -! jul-07-1989 --- kenneth campana ! -! may-15-1998 --- mark iredell y2k compliance ! -! dec-18-2003 --- yu-tai hou combine cdate and prtime and ! -! rewrite in fortran 90 compatable form ! -! ! -! =================================================================== ! -! - implicit none - -! --- inputs: - integer, intent(in) :: jd - - real (kind=kind_phys), intent(in) :: fjd, dlt, alp, r1, slag, solc - -! --- outputs: ( none ) - -! --- locals: - real (kind=kind_phys), parameter :: sixty = 60.0 - - character(LEN=1), parameter :: sign = '-' - character(LEN=1), parameter :: sigb = ' ' - - character(LEN=1) :: dsig - character(LEN=4) :: month(12) - - data month / 'JAN.','FEB.','MAR.','APR.','MAY ','JUNE', & - & 'JULY','AUG.','SEP.','OCT.','NOV ','DEC.' / - - integer :: iday, imon, iyear, ihr, ltd, ltm, & - & ihalp, iyy, jda, mfjd, idaywk, idayyr - real (kind=kind_phys) :: xmin, dltd, dltm, dlts, halp, ymin, & - & asec, eqt, eqsec - -!===> ... begin here - -! --- ... get forecast hour and minute from fraction of julian day - - if (fjd >= 0.5) then - jda = jd + 1 - mfjd= nint( fjd*1440.0 ) - ihr = mfjd / 60 - 12 - xmin= float(mfjd) - (ihr + 12)*sixty - else - jda = jd - mfjd= nint( fjd*1440.0 ) - ihr = mfjd / 60 + 12 - xmin= float(mfjd) - (ihr - 12)*sixty - endif - -! --- ... get forecast year, month, and day from julian day - - call w3fs26(jda, iyear,imon,iday, idaywk,idayyr) - -! -- ... compute solar parameters - - dltd = degrad * dlt - ltd = dltd - dltm = sixty * (abs(dltd) - abs(float(ltd))) - ltm = dltm - dlts = sixty * (dltm - float(ltm)) - - if ((dltd < 0.0) .and. (ltd == 0.0)) then - dsig = sign - else - dsig = sigb - endif - - halp = 6.0 * alp / hpi - ihalp= halp - ymin = abs(halp - float(ihalp)) * sixty - iyy = ymin - asec = (ymin - float(iyy)) * sixty - - eqt = 228.55735 * slag - eqsec= sixty * eqt - -! print 101, iday, month(imon), iyear, ihr, xmin, jd, fjd -! 101 format('0 FORECAST DATE',9x,i3,a5,i6,' AT',i3,' HRS',f6.2,' MINS'/& -! & ' JULIAN DAY',12x,i8,2x,'PLUS',f11.6) -! -! print 102, r1, halp, ihalp, iyy, asec -! 102 format(' RADIUS VECTOR',9x,f10.7/' RIGHT ASCENSION OF SUN', & -! & f12.7,' HRS, OR',i4,' HRS',i4,' MINS',f6.1,' SECS') -! -! print 103, dltd, dsig, ltd, ltm, dlts, eqt, eqsec, slag, solc -! 103 format(' DECLINATION OF THE SUN',f12.7,' DEGS, OR ',a1,i3, & -! & ' DEGS',i4,' MINS',f6.1,' SECS'/' EQUATION OF TIME',6x, & -! & f12.7,' MINS, OR',f10.2,' SECS, OR',f9.6,' RADIANS'/ & -! & ' SOLAR CONSTANT',8X,F12.7,' (DISTANCE AJUSTED)'//) - -! - return -!................................... - end subroutine prtime -!----------------------------------- - -! -!...........................................! - end module module_radiation_astronomy ! -!===========================================! diff --git a/src/fim/FIMsrc/fim/column/radiation_clouds.f b/src/fim/FIMsrc/fim/column/radiation_clouds.f deleted file mode 100644 index 923aa60..0000000 --- a/src/fim/FIMsrc/fim/column/radiation_clouds.f +++ /dev/null @@ -1,2456 +0,0 @@ -!!!!! module_radiation_clouds description !!!!! -!!!!! ========================================================== !!!!! -! ! -! the 'radiation_clouds.f' contains: ! -! ! -! 'module_radiation_clouds' --- compute cloud related quantities! -! for radiation computations ! -! ! -! the following are the externally accessable subroutines: ! -! ! -! 'cldinit' --- initialization routine ! -! inputs: ! -! (si, NLAY, iflip, np3d, icld, me) ! -! outputs: ! -! ( none ) ! -! ! -! 'progcld1' --- zhao/moorthi prognostic cloud scheme ! -! inputs: ! -! (plyr,plvl,tlyr,qlyr,qstl,rhly,clw, ! -! xlat,xlon,slmsk, ! -! IX, NLAY, NLP1, iflip, iovr, ! -! outputs: ! -! clouds,clds,mtop,mbot) ! -! ! -! 'progcld2' --- ferrier prognostic cloud microphysics ! -! inputs: ! -! (plyr,plvl,tlyr,qlyr,qstl,rhly,clw, ! -! xlat,xlon,slmsk, f_ice,f_rain,r_rime, ! -! IX, NLAY, NLP1, iflip, iovr, ! -! outputs: ! -! clouds,clds,mtop,mbot) ! -! ! -! 'diagcld1' --- diagnostic cloud calc routine ! -! inputs: ! -! (plyr,plvl,tlyr,rhly,vvel,cv,cvt,cvb, ! -! xlat,xlon,slmsk, ! -! IX, NLAY, NLP1, iflip, iovr, ! -! outputs: ! -! clouds,clds,mtop,mbot) ! -! ! -! internal accessable only subroutines: ! -! 'gethml' --- get diagnostic hi, mid, low clouds ! -! ! -! 'rhtable' --- rh lookup table for diag cloud scheme ! -! ! -! ! -! cloud array description: ! -! --- for prognostic cloud: icld=1 --- ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud liq water path ! -! clouds(:,:,3) - mean effective radius for liquid cloud ! -! clouds(:,:,4) - layer cloud ice water path ! -! clouds(:,:,5) - mean effective radius for ice cloud ! -! clouds(:,:,6) - layer rain drop water path ! -! clouds(:,:,7) - mean effective radius for rain drop ! -! ** clouds(:,:,8) - layer snow flake water path ! -! clouds(:,:,9) - mean effective radius for snow flake ! -! ** fu's scheme need to be normalized by snow density (g/m**3/1.0e6)! -! --- for diagnostic cloud: icld=0 --- ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud optical depth ! -! clouds(:,:,3) - layer cloud single scattering albedo ! -! clouds(:,:,4) - layer cloud asymmetry factor ! -! ! -! external modules referenced: ! -! ! -! 'module machine' in 'machine.f' ! -! 'module physcons' in 'physcons.f' ! -! 'module module_microphysics' in 'module_bfmicrophysics.f' ! -! ! -! ! -! modification history log: ! -! ! -! apr 2003, yu-tai hou ! -! created 'module_rad_clouds' from combining the ! -! original subroutine 'cldjms', 'cldprp', and 'gcljms'! -! may 2004, yu-tai hou ! -! incorporate ferrier's cloud microphysics scheme. ! -! apr 2005, yu-tai hou ! -! modified cloud array and module structures. ! -! dec 2008, yu-tai hou ! -! changed low-cld calc, now cantains clds from sfc ! -! layer and upward to the low/mid boundary (include ! -! bl-cld). h,m,l clds domain boundaries are adjusted ! -! for better agreement with observations. ! -! ! -!!!!! ========================================================== !!!!! -!!!!! end descriptions !!!!! -!!!!! ========================================================== !!!!! - - -!========================================! - module module_radiation_clouds ! -!........................................! -! - use machine, only : kind_phys, kind_io8, kind_io4 - use physcons, only : con_pi, con_g, con_rd, & - & con_fvirt, con_ttp, con_rocp, & - & con_t0c - use module_microphysics, only : rsipath2 - use module_iounitdef, only : NICLTUN -! - implicit none -! - private - -! --- set constant parameters - - integer, parameter, public :: NF_CLDS = 9 ! number of fields in cloud array - -! --- pressure limits of cloud domain interfaces (low,mid,high) in mb (0.1kPa) - real (kind=kind_phys) :: ptopc(4,2) - -!org data ptopc / 1050., 642., 350., 0.0, 1050., 750., 500., 0.0 / - data ptopc / 1050., 650., 400., 0.0, 1050., 750., 500., 0.0 / - -! real (kind=kind_phys), parameter :: climit = 0.01 - real (kind=kind_phys), parameter :: climit = 0.001, climit2=0.05 - real (kind=kind_phys), parameter :: ovcst = 1.0 - 1.0e-8 - -! --- set default quantities as parameters (for prognostic cloud) - - real (kind=kind_phys), parameter :: reliq_def = 10.0 ! default liq radius to 10 micron - real (kind=kind_phys), parameter :: reice_def = 50.0 ! default ice radius to 50 micron - real (kind=kind_phys), parameter :: rrain_def = 1000.0 ! default rain radius to 1000 micron - real (kind=kind_phys), parameter :: rsnow_def = 250.0 ! default snow radius to 250 micron - -! --- set look-up table dimensions and other parameters (for diagnostic cloud) - - integer, parameter :: NBIN=100 ! rh in one percent interval - integer, parameter :: NLON=2 ! =1,2 for eastern and western hemispheres - integer, parameter :: NLAT=4 ! =1,4 for 60n-30n,30n-equ,equ-30s,30s-60s - integer, parameter :: MCLD=4 ! =1,4 for bl,low,mid,hi cld type - integer, parameter :: NSEAL=2 ! =1,2 for land,sea - - real (kind=kind_phys), parameter :: cldssa_def = 0.99 ! default cld single scat albedo - real (kind=kind_phys), parameter :: cldasy_def = 0.84 ! default cld asymmetry factor - -! --- xlabdy: lat bndry between tuning regions, +/- xlim for transition -! xlobdy: lon bndry between tuning regions - real (kind=kind_phys), parameter :: xlim=5.0 - real (kind=kind_phys) :: xlabdy(3), xlobdy(3) - - data xlabdy / 30.0, 0.0, -30.0 /, xlobdy / 0.0, 180., 360. / - -! --- low cloud vertical velocity adjustment boundaries in mb/sec - real (kind=kind_phys), parameter :: vvcld1= 0.0003e0 - real (kind=kind_phys), parameter :: vvcld2=-0.0005e0 - -! --- those data will be set up by "cldinit" -! rhcl : tuned rh relation table for diagnostic cloud scheme -! llyr : upper limit of boundary layer clouds - - real (kind=kind_phys) :: rhcl(NBIN,NLON,NLAT,MCLD,NSEAL) - integer :: llyr - - public progcld1, progcld2, diagcld1, cldinit - - -! ================= - contains -! ================= - - -!----------------------------------- - subroutine cldinit & -!................................... - -! --- inputs: - & ( si, NLAY, iflip, np3d, icld, me ) -! --- outputs: -! ( none ) - -! =================================================================== ! -! ! -! abstract: cldinit is an initialization program for cloud-radiation ! -! calculations. it sets up boundary layer cloud top. ! -! ! -! ! -! inputs: ! -! si (L+1) : model vertical sigma layer interface ! -! NLAY : vertical layer number ! -! iflip : control flag for direction of vertical index ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! np3d : =3: ferrier microphysics cloud scheme ! -! =4: zhao/carr/sundqvist microphysics cloud ! -! icld : cloud computation method flag ! -! =0: model use diagnostic cloud method ! -! =1: model use prognostic cloud method ! -! me : print control flag ! -! ! -! outputs: (none) ! -! ! -! usage: call cldinit ! -! ! -! subroutines called: rhtable ! -! ! -! =================================================================== ! -! - implicit none - -! --- inputs: - integer, intent(in) :: NLAY, iflip, np3d, icld, me - - real (kind=kind_phys), intent(in) :: si(:) - -! --- outputs: (none) - -! --- locals: - integer :: k, kl, ier - -! -!===> ... begin here -! - if (icld == 0) then - if (me == 0) print *,' - Using Diagnostic Cloud Method' - -! --- set up tuned rh table - - call rhtable( me, ier ) - - if (ier < 0) then - write(6,99) ier - 99 format(3x,' *** Error in finding tuned RH table ***' & - &, /3x,' STOP at calling subroutine RHTABLE !!'/) - stop 99 - endif - else - if (me == 0) then - print *,' - Using Prognostic Cloud Method' - if (np3d == 3) print *,' --- Ferrier cloud microphysics' - if (np3d == 4) print *, & - & ' --- Zhao/Carr/Sundqvist microphysics' - endif - endif - -! --- compute llyr - the top of bl cld and is topmost non cld(low) layer -! for stratiform (at or above lowest 0.1 of the atmosphere) - - if (iflip == 0) then ! data from toa to sfc - - kl = NLAY - lab_do_k0 : do k = NLAY+1, 2, -1 - kl = k - if (si(k) < 0.9e0) exit lab_do_k0 - enddo lab_do_k0 - - llyr = kl + 1 - - else ! data from sfc to top - - kl = 2 - lab_do_k1 : do k = 1, NLAY - kl = k - if (si(k) < 0.9e0) exit lab_do_k1 - enddo lab_do_k1 - - llyr = kl - 1 - - endif ! end_if_iflip - -! - return -!................................... - end subroutine cldinit -!----------------------------------- - - -!----------------------------------- - subroutine progcld1 & -!................................... - -! --- inputs: - & ( plyr,plvl,tlyr,qlyr,qstl,rhly,clw, & - & xlat,xlon,slmsk, & - & IX, NLAY, NLP1, iflip, iovr, sashal, crick_proof, ccnorm, & -! --- outputs: - & clouds,clds,mtop,mbot & - & ) - -! ================= subprogram documentation block ================ ! -! ! -! subprogram: progcld1 computes cloud related quantities using ! -! zhao/moorthi's prognostic cloud microphysics scheme. ! -! ! -! abstract: this program computes cloud fractions from cloud ! -! condensates, calculates liquid/ice cloud droplet effective radius, ! -! and computes the low, mid, high, total and boundary layer cloud ! -! fractions and the vertical indices of low, mid, and high cloud ! -! top and base. the three vertical cloud domains are set up in the ! -! initial subroutine "cldinit". ! -! ! -! program history log: ! -! 11-xx-1992 y.h., k.a.c, a.k. - cloud parameterization ! -! 'cldjms' patterned after slingo and slingo's work (jgr, ! -! 1992), stratiform clouds are allowed in any layer except ! -! the surface and upper stratosphere. the relative humidity ! -! criterion may cery in different model layers. ! -! 10-25-1995 kenneth campana - tuned cloud rh curves ! -! rh-cld relation from tables created using mitchell-hahn ! -! tuning technique on airforce rtneph observations. ! -! 11-02-1995 kenneth campana - the bl relationships used ! -! below llyr, except in marine stratus regions. ! -! 04-11-1996 kenneth campana - save bl cld amt in cld(,5) ! -! 12-29-1998 s. moorthi - prognostic cloud method ! -! 04-15-2003 yu-tai hou - rewritten in frotran 90 ! -! modulized form, seperate prognostic and diagnostic methods ! -! into two packages. ! -! ! -! usage: call progcld1 ! -! ! -! subprograms called: gethml ! -! ! -! attributes: ! -! language: fortran 90 ! -! machine: ibm-sp, sgi ! -! ! -! ! -! ==================== defination of variables ==================== ! -! ! -! input variables: ! -! plyr (IX,NLAY) : model layer mean pressure in mb (100Pa) ! -! plvl (IX,NLP1) : model level pressure in mb (100Pa) ! -! tlyr (IX,NLAY) : model layer mean temperature in k ! -! qlyr (IX,NLAY) : layer specific humidity in gm/gm ! -! qstl (IX,NLAY) : layer saturate humidity in gm/gm ! -! rhly (IX,NLAY) : layer relative humidity (=qlyr/qstl) ! -! clw (IX,NLAY) : layer cloud condensate amount ! -! xlat (IX) : grid latitude in radians ! -! xlon (IX) : grid longitude in radians (not used) ! -! slmsk (IX) : sea/land mask array (sea:0,land:1,sea-ice:2) ! -! IX : horizontal dimention ! -! NLAY,NLP1 : vertical layer/level dimensions ! -! iflip : control flag for in/out vertical indexing ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! iovr : control flag for cloud overlap ! -! =0 random overlapping clouds ! -! =1 max/ran overlapping clouds ! -! ! -! output variables: ! -! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! -! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! -! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! -! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! -! clouds(:,:,6) - layer rain drop water path not assigned ! -! clouds(:,:,7) - mean eff radius for rain drop (micron) ! -! *** clouds(:,:,8) - layer snow flake water path not assigned ! -! clouds(:,:,9) - mean eff radius for snow flake (micron) ! -! *** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) ! -! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! -! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! -! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! -! ! -! ==================== end of description ===================== ! -! - implicit none - -! --- inputs - integer, intent(in) :: IX, NLAY, NLP1, iflip, iovr - - real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & - & tlyr, qlyr, qstl, rhly, clw - - real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & - & slmsk - logical, intent(in) :: sashal, crick_proof, ccnorm - -! --- outputs - real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds - - real (kind=kind_phys), dimension(:,:), intent(out) :: clds - - integer, dimension(:,:), intent(out) :: mtop,mbot - -! --- local variables: - real (kind=kind_phys), dimension(IX,NLAY) :: cldtot, cldcnv, & - & cwp, cip, crp, csp, rew, rei, res, rer, delp, tem2d, clwf - - real (kind=kind_phys) :: ptop1(IX,4) - - real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & - & tem1, tem2, tem3 - - integer, dimension(IX) :: kinver - - integer :: i, k, id, id1 - - logical :: inversn(IX) - -! -!===> ... begin here -! - clouds(:,:,:) = 0.0 - - do k = 1, NLAY - do i = 1, IX - cldtot(i,k) = 0.0 - cldcnv(i,k) = 0.0 - cwp (i,k) = 0.0 - cip (i,k) = 0.0 - crp (i,k) = 0.0 - csp (i,k) = 0.0 - rew (i,k) = reliq_def ! default liq radius to 10 micron - rei (i,k) = reice_def ! default ice radius to 50 micron - rer (i,k) = rrain_def ! default rain radius to 1000 micron - res (i,k) = rsnow_def ! default snow radius to 250 micron - tem2d (i,k) = min( 1.0, max( 0.0, (con_ttp-tlyr(i,k))*0.05 ) ) - clwf(i,k) = 0.0 - enddo - enddo -! - if (crick_proof) then - do i = 1, IX - clwf(i,1) = 0.75*clw(i,1) + 0.25*clw(i,2) - clwf(i,nlay) = 0.75*clw(i,nlay) + 0.25*clw(i,nlay) - enddo - do k = 2, NLAY-1 - do i = 1, IX - clwf(i,K) = 0.25*clw(i,k-1) + 0.5*clw(i,k) + 0.25*clw(i,k+1) - enddo - enddo - else - do k = 1, NLAY - do i = 1, IX - clwf(i,k) = clw(i,k) - enddo - enddo - endif - -! --- find top pressure for each cloud domain for given latitude -! ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,L,m,h; -! --- i=1,2 are low-lat (<45 degree) and pole regions) - - do id = 1, 4 - tem1 = ptopc(id,2) - ptopc(id,1) - - do i =1, IX - tem2 = max( 0.0, 4.0*abs(xlat(i))/con_pi-1.0 ) - ptop1(i,id) = ptopc(id,1) + tem1*tem2 - enddo - enddo - -! --- compute liquid/ice condensate path in g/m**2 - - tem1 = 1.0e+5 / con_g - - if (iflip == 0) then ! input data from toa to sfc - do k = 1, NLAY - do i = 1, IX - delp(i,k) = plvl(i,k+1) - plvl(i,k) - clwt = max(0.0, clwf(i,k)) * tem1 * delp(i,k) - cip(i,k) = clwt * tem2d(i,k) - cwp(i,k) = clwt - cip(i,k) - enddo - enddo - else ! input data from sfc to toa - do k = 1, NLAY - do i = 1, IX - delp(i,k) = plvl(i,k) - plvl(i,k+1) - clwt = max(0.0, clwf(i,k)) * tem1 * delp(i,k) - cip(i,k) = clwt * tem2d(i,k) - cwp(i,k) = clwt - cip(i,k) - enddo - enddo - endif ! end_if_iflip - -! --- effective liquid cloud droplet radius over land - - do i = 1, IX - if (nint(slmsk(i)) == 1) then - do k = 1, NLAY - rew(i,k) = 5.0 + 5.0 * tem2d(i,k) - enddo - endif - enddo - -! --- layer cloud fraction - - if (iflip == 0) then ! input data from toa to sfc - - do i = 1, IX - inversn(i) = .false. - kinver (i) = 1 - enddo - - do k = NLAY-1, 1, -1 - do i = 1, IX - if (plyr(i,k) > 600.0 .and. (.not.inversn(i))) then - tem1 = tlyr(i,k-1) - tlyr(i,k) - - if (tem1 > 0.1 .and. tlyr(i,k) > 278.0) then - inversn(i) = .true. - kinver(i) = k - endif - endif - enddo - enddo - - clwmin = 0.0 - if (.not. sashal) then - do k = NLAY, 1, -1 - do i = 1, IX - clwt = 1.0e-6 * (plyr(i,k)*0.001) -! clwt = 2.0e-6 * (plyr(i,k)*0.001) - - if (clwf(i,k) > clwt .or. & - & (inversn(i) .and. k >= kinver(i)) ) then - - onemrh= max( 1.e-10, 1.0-rhly(i,k) ) - clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) - - tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) - tem1 = 2000.0 / tem1 -! tem1 = 1000.0 / tem1 -! if (inversn(i) .and. k >= kinver(i)) tem1 = tem1 * 5.0 - - value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(rhly(i,k)) ) - - cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) - endif - enddo - enddo - else - do k = NLAY, 1, -1 - do i = 1, IX - clwt = 1.0e-6 * (plyr(i,k)*0.001) -! clwt = 2.0e-6 * (plyr(i,k)*0.001) - - if (clwf(i,k) > clwt .or. & - & (inversn(i) .and. k >= kinver(i)) ) then - - onemrh= max( 1.e-10, 1.0-rhly(i,k) ) - clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) - -! tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) -! tem1 = 2000.0 / tem1 - - tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) !jhan - tem1 = 100.0 / tem1 -! -! tem1 = 2000.0 / tem1 -! tem1 = 1000.0 / tem1 -! if (inversn(i) .and. k >= kinver(i)) tem1 = tem1 * 5.0 -! - - value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(rhly(i,k)) ) - cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) - endif - enddo - enddo - endif - - else ! input data from sfc to toa - - do i = 1, IX - inversn(i) = .false. - kinver (i) = NLAY - enddo - - do k = 2, NLAY - do i = 1, IX - if (plyr(i,k) > 600.0 .and. (.not.inversn(i))) then - tem1 = tlyr(i,k+1) - tlyr(i,k) - - if (tem1 > 0.1 .and. tlyr(i,k) > 278.0) then - inversn(i) = .true. - kinver(i) = k - endif - endif - enddo - enddo - - clwmin = 0.0 - if (.not. sashal) then - do k = 1, NLAY - do i = 1, IX - clwt = 1.0e-6 * (plyr(i,k)*0.001) -! clwt = 2.0e-6 * (plyr(i,k)*0.001) - - if (clwf(i,k) > clwt .or. & - & (inversn(i) .and. k <= kinver(i)) ) then - - onemrh= max( 1.e-10, 1.0-rhly(i,k) ) - clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) - - tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) - tem1 = 2000.0 / tem1 - -! tem1 = 1000.0 / tem1 -! if (inversn(i) .and. k <= kinver(i)) tem1 = tem1 * 5.0 - - value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(rhly(i,k)) ) - - cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) - endif - enddo - enddo - else - do k = 1, NLAY - do i = 1, IX - clwt = 1.0e-6 * (plyr(i,k)*0.001) -! clwt = 2.0e-6 * (plyr(i,k)*0.001) - - if (clwf(i,k) > clwt .or. & - & (inversn(i) .and. k <= kinver(i)) ) then - - onemrh= max( 1.e-10, 1.0-rhly(i,k) ) - clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) - -! tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) -! tem1 = 2000.0 / tem1 - - tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) !jhan - tem1 = 100.0 / tem1 -! -! tem1 = 2000.0 / tem1 -! tem1 = 1000.0 / tem1 -! if (inversn(i) .and. k <= kinver(i)) tem1 = tem1 * 5.0 -! - - value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(rhly(i,k)) ) - - cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) - endif - enddo - enddo - endif - - endif ! end_if_flip - - where (cldtot < climit) - cldtot = 0.0 - cwp = 0.0 - cip = 0.0 - crp = 0.0 - csp = 0.0 - endwhere -! - if (ccnorm) then - do k = 1, NLAY - do i = 1, IX - if (cldtot(i,k) >= climit) then - tem1 = 1.0 / max(climit2, cldtot(i,k)) - cwp(i,k) = cwp(i,k) * tem1 - cip(i,k) = cip(i,k) * tem1 - crp(i,k) = crp(i,k) * tem1 - csp(i,k) = csp(i,k) * tem1 - endif - enddo - enddo - endif - -! --- effective ice cloud droplet radius - - tem1 = con_g / con_rd - do k = 1, NLAY - do i = 1, IX - tem2 = tlyr(i,k) - con_ttp - - if (cip(i,k) > 0.0) then - tem3 = tem1 * cip(i,k) * ( plyr(i,k) / delp(i,k) ) & - & / (tlyr(i,k) * (1.0 + con_fvirt * qlyr(i,k))) - - if (tem2 < -50.0) then - rei(i,k) = (1250.0/9.917) * tem3 ** 0.109 - elseif (tem2 < -40.0) then - rei(i,k) = (1250.0/9.337) * tem3 ** 0.08 - elseif (tem2 < -30.0) then - rei(i,k) = (1250.0/9.208) * tem3 ** 0.055 - else - rei(i,k) = (1250.0/9.387) * tem3 ** 0.031 - endif - endif - enddo - enddo - -! - do k = 1, NLAY - do i = 1, IX - clouds(i,k,1) = cldtot(i,k) - clouds(i,k,2) = cwp(i,k) - clouds(i,k,3) = rew(i,k) - clouds(i,k,4) = cip(i,k) - clouds(i,k,5) = rei(i,k) -! clouds(i,k,6) = 0.0 - clouds(i,k,7) = rer(i,k) -! clouds(i,k,8) = 0.0 - clouds(i,k,9) = rei(i,k) - enddo - enddo - - -! --- compute low, mid, high, total, and boundary layer cloud fractions -! and clouds top/bottom layer indices for low, mid, and high clouds. -! The three cloud domain boundaries are defined by ptopc. The cloud -! overlapping method is defined by control flag 'iovr', which is -! --- also used by the lw and sw radiation programs. - - call gethml & -! --- inputs: - & ( plyr, ptop1, cldtot, cldcnv, & - & IX,NLAY, iflip, iovr, & -! --- outputs: - & clds, mtop, mbot & - & ) - - -! - return -!................................... - end subroutine progcld1 -!----------------------------------- - - -!----------------------------------- - subroutine progcld2 & -!................................... - -! --- inputs: - & ( plyr,plvl,tlyr,qlyr,qstl,rhly,clw, & - & xlat,xlon,slmsk, f_ice,f_rain,r_rime,flgmin, & - & IX, NLAY, NLP1, iflip, iovr, sashal, norad_precip, & - & crick_proof, ccnorm, & -! --- outputs: - & clouds,clds,mtop,mbot & - & ) - -! ================= subprogram documentation block ================ ! -! ! -! subprogram: progcld2 computes cloud related quantities using ! -! ferrier's prognostic cloud microphysics scheme. ! -! ! -! abstract: this program computes cloud fractions from cloud ! -! condensates, calculates liquid/ice cloud droplet effective radius, ! -! and computes the low, mid, high, total and boundary layer cloud ! -! fractions and the vertical indices of low, mid, and high cloud ! -! top and base. the three vertical cloud domains are set up in the ! -! initial subroutine "cldinit". ! -! ! -! program history log: ! -! - - brad ferrier - original development ! -! - -2003 s. moorthi - adapted to ncep gfs model ! -! 05-05-2004 yu-tai hou - rewritten as a separated ! -! program in the cloud module. ! -! ! -! usage: call progcld2 ! -! ! -! subprograms called: gethml ! -! ! -! attributes: ! -! language: fortran 90 ! -! machine: ibm-sp, sgi ! -! ! -! ! -! ==================== defination of variables ==================== ! -! ! -! input variables: ! -! plyr (IX,NLAY) : model layer mean pressure in mb (100Pa) ! -! plvl (IX,NLP1) : model level pressure in mb (100Pa) ! -! tlyr (IX,NLAY) : model layer mean temperature in k ! -! qlyr (IX,NLAY) : layer specific humidity in gm/gm ! -! qstl (IX,NLAY) : layer saturate humidity in gm/gm ! -! rhly (IX,NLAY) : layer relative humidity (=qlyr/qstl) ! -! clw (IX,NLAY) : layer cloud condensate amount ! -! f_ice (IX,NLAY) : fraction of layer cloud ice (ferrier micro-phys) ! -! f_rain(IX,NLAY) : fraction of layer rain water (ferrier micro-phys) ! -! r_rime(IX,NLAY) : mass ratio of total ice to unrimed ice (>=1) ! -! xlat (IX) : grid latitude in radians ! -! xlon (IX) : grid longitude in radians (not used) ! -! slmsk (IX) : sea/land mask array (sea:0,land:1,sea-ice:2) ! -! IX : horizontal dimention ! -! NLAY,NLP1 : vertical layer/level dimensions ! -! iflip : control flag for in/out vertical indexing ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! iovr : control flag for cloud overlap ! -! =0 random overlapping clouds ! -! =1 max/ran overlapping clouds ! -! ! -! output variables: ! -! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! -! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! -! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! -! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! -! clouds(:,:,6) - layer rain drop water path (g/m**2) ! -! clouds(:,:,7) - mean eff radius for rain drop (micron) ! -! *** clouds(:,:,8) - layer snow flake water path (g/m**2) ! -! clouds(:,:,9) - mean eff radius for snow flake (micron) ! -! *** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) ! -! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! -! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! -! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! -! ! -! ==================== end of description ===================== ! -! - implicit none - -! --- constants - real (kind=kind_phys), parameter :: EPSQ = 1.0e-12 - -! --- inputs - integer, intent(in) :: IX, NLAY, NLP1, iflip, iovr - - real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & - & tlyr, qlyr, qstl, rhly, clw, f_ice, f_rain, r_rime - - real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & - & slmsk - logical, intent(in) :: sashal, norad_precip, crick_proof, ccnorm - real (kind=kind_phys), dimension(:), intent(in) :: flgmin - -! --- outputs - real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds - - real (kind=kind_phys), dimension(:,:), intent(out) :: clds - - integer, dimension(:,:), intent(out) :: mtop,mbot - -! --- local variables: - real (kind=kind_phys), dimension(IX,NLAY) :: cldtot, cldcnv, & - & cwp, cip, crp, csp, rew, rei, res, rer, tem2d, clw2, & - & qcwat, qcice, qrain, fcice, frain, rrime, rsden, clwf - - real (kind=kind_phys) :: ptop1(IX,4), tx1(IX) - - real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & - & tem1, tem2, tem3 - - integer, dimension(IX) :: kinver - - integer :: i, k, id, id1 - - logical :: inversn(IX) - -! -!===> ... begin here -! -! clouds(:,:,:) = 0.0 - - do k = 1, NLAY - do i = 1, IX - cldtot(i,k) = 0.0 - cldcnv(i,k) = 0.0 - cwp (i,k) = 0.0 - cip (i,k) = 0.0 - crp (i,k) = 0.0 - csp (i,k) = 0.0 - rew (i,k) = reliq_def ! default liq radius to 10 micron - rei (i,k) = reice_def ! default ice radius to 50 micron - rer (i,k) = rrain_def ! default rain radius to 1000 micron - res (i,k) = rsnow_def ! default snow radius to 250 micron - fcice (i,k) = max(0.0, min(1.0, f_ice(i,k))) - frain (i,k) = max(0.0, min(1.0, f_rain(i,k))) - rrime (i,k) = max(1.0, r_rime(i,k)) - tem2d (i,k) = tlyr(i,k) - con_t0c - enddo - enddo -! - if (crick_proof) then - do i = 1, IX - clwf(i,1) = 0.75*clw(i,1) + 0.25*clw(i,2) - clwf(i,nlay) = 0.75*clw(i,nlay) + 0.25*clw(i,nlay) - enddo - do k = 2, NLAY-1 - do i = 1, IX - clwf(i,K) = 0.25*clw(i,k-1) + 0.5*clw(i,k) + 0.25*clw(i,k+1) - enddo - enddo - else - do k = 1, NLAY - do i = 1, IX - clwf(i,k) = clw(i,k) - enddo - enddo - endif - -! --- find top pressure for each cloud domain for given latitude -! ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,L,m,h; -! --- i=1,2 are low-lat (<45 degree) and pole regions) - - do id = 1, 4 - tem1 = ptopc(id,2) - ptopc(id,1) - - do i =1, IX - tem2 = max( 0.0, 4.0*abs(xlat(i))/con_pi-1.0 ) - ptop1(i,id) = ptopc(id,1) + tem1*tem2 - enddo - enddo - -! --- separate cloud condensate into liquid, ice, and rain types, and -! save the liquid+ice condensate in array clw2 for later -! calculation of cloud fraction - - do k = 1, NLAY - do i = 1, IX - if (tem2d(i,k) > -40.0) then - qcice(i,k) = clwf(i,k) * fcice(i,k) - tem1 = clwf(i,k) - qcice(i,k) - qrain(i,k) = tem1 * frain(i,k) - qcwat(i,k) = tem1 - qrain(i,k) - clw2 (i,k) = qcwat(i,k) + qcice(i,k) - else - qcice(i,k) = clwf(i,k) - qrain(i,k) = 0.0 - qcwat(i,k) = 0.0 - clw2 (i,k) = clwf(i,k) - endif - enddo - enddo - - call rsipath2 & -! --- inputs: - & ( plyr, plvl, tlyr, qlyr, qcwat, qcice, qrain, rrime, & - & IX, NLAY, iflip, flgmin, & -! --- outputs: - & cwp, cip, crp, csp, rew, rer, res, rsden & - & ) - - - if (iflip == 0) then ! input data from toa to sfc - do k = 1, NLAY - do i = 1, IX - tem2d(i,k) = (con_g * plyr(i,k)) & - & / (con_rd* (plvl(i,k+1) - plvl(i,k))) - enddo - enddo - else ! input data from sfc to toa - do k = 1, NLAY - do i = 1, IX - tem2d(i,k) = (con_g * plyr(i,k)) & - & / (con_rd* (plvl(i,k) - plvl(i,k+1))) - enddo - enddo - endif ! end_if_iflip - -! --- layer cloud fraction - - if (iflip == 0) then ! input data from toa to sfc - - do i = 1, IX - inversn(i) = .false. - kinver (i) = 1 - tx1(i) = 0.0 - enddo - -! do k = NLAY-1, 1, -1 - do k = NLAY, 1, -1 - do i = 1, IX -! if (plyr(i,k) > 600.0 .and. (.not.inversn(i))) then -! tem1 = tlyr(i,k-1) - tlyr(i,k) - -!! if (tem1 > 0.1 .and. tlyr(i,k) > 278.0) then -! if (tem1 > 0.1 ) then - - if (plvl(i,NLP1)-plvl(i,k) .lt. 0.35*plvl(i,NLP1) & - & .and. (.not. inversn(i))) then - tem1 = (tlyr(i,K-1)-tlyr(i,K)) / (plyr(i,k)-plyr(i,k-1)) -! if (tem1 .gt. 0.005 .and. tx1(i) .lt. 0.0) then - if (tem1 .gt. 0.002 .and. tx1(i) .lt. 0.0) then - inversn(i) = .true. - kinver(i) = k - 1 - endif - tx1(i) = tem1 - endif - enddo - enddo - - clwmin = 0.0 - if (.not. sashal) then - do k = NLAY, 1, -1 - do i = 1, IX -! clwt = 1.0e-7 * (plyr(i,k)*0.001) -! clwt = 1.0e-6 * (plyr(i,k)*0.001) - clwt = 2.0e-6 * (plyr(i,k)*0.001) -! clwt = 5.0e-6 * (plyr(i,k)*0.001) -! clwt = 5.0e-6 - - if (clw2(i,k) > clwt .or. & - & (inversn(i) .and. k >= kinver(i)) ) then - - onemrh= max( 1.e-10, 1.0-rhly(i,k) ) - clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) - -! tem1 = min(max(sqrt(onemrh*qstl(i,k)),0.0001),1.0) -! tem1 = 100.0 / tem1 - - tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) - tem1 = 2000.0 / tem1 -! tem1 = 2400.0 / tem1 -!cnt tem1 = 2500.0 / tem1 -! tem1 = min(max(sqrt(onemrh*qstl(i,k)),0.0001),1.0) -! tem1 = 2000.0 / tem1 -! tem1 = 1000.0 / tem1 -! tem1 = 100.0 / tem1 -! if (inversn(i) .and. k >= kinver(i)) tem1 = tem1 * 5.0 - - value = max( min( tem1*(clw2(i,k)-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(rhly(i,k)) ) - - cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) - endif - enddo - enddo - else - do k = NLAY, 1, -1 - do i = 1, IX -! clwt = 1.0e-6 * (plyr(i,k)*0.001) - clwt = 2.0e-6 * (plyr(i,k)*0.001) - - if (clw2(i,k) > clwt .or. & - & (inversn(i) .and. k >= kinver(i)) ) then - - onemrh= max( 1.e-10, 1.0-rhly(i,k) ) - clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) - - tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) !jhan - tem1 = 100.0 / tem1 - -! tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) -! tem1 = 2000.0 / tem1 -! -! tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) -! tem1 = 2200.0 / tem1 -! tem1 = 2400.0 / tem1 -! tem1 = 2500.0 / tem1 -! tem1 = min(max(sqrt(onemrh*qstl(i,k)),0.0001),1.0) -! tem1 = 2000.0 / tem1 -! tem1 = 1000.0 / tem1 -! tem1 = 100.0 / tem1 -! if (inversn(i) .and. k >= kinver(i)) tem1 = tem1 * 5.0 -! - - value = max( min( tem1*(clw2(i,k)-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(rhly(i,k)) ) - - cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) - endif - enddo - enddo - endif - - else ! input data from sfc to toa - - do i = 1, IX - inversn(i) = .false. - kinver (i) = NLAY - tx1(i) = 0.0 - enddo - -! do k = 2, NLAY - do k = 1, NLAY - do i = 1, IX -! if (plyr(i,k) > 600.0 .and. (.not.inversn(i))) then -! tem1 = tlyr(i,k+1) - tlyr(i,k) - -!! if (tem1 > 0.1 .and. tlyr(i,k) > 278.0) then -! if (tem1 > 0.1 ) then - - if (plvl(i,1)-plvl(i,k+1) .lt. 0.35*plvl(i,1) & - & .and. (.not. inversn(i))) then - tem1 = (tlyr(i,K+1)-tlyr(i,K)) / (plyr(i,k)-plyr(i,k+1)) -! if (tem1 .gt. 0.005 .and. tx1(i) .lt. 0.0) then - if (tem1 .gt. 0.002 .and. tx1(i) .lt. 0.0) then - inversn(i) = .true. - kinver(i) = k + 1 - endif - tx1(i) = tem1 - endif - enddo - enddo - - clwmin = 0.0e-6 - if (.not. sashal) then - do k = 1, NLAY - do i = 1, IX -! clwt = 1.0e-7 * (plyr(i,k)*0.001) -! clwt = 1.0e-6 * (plyr(i,k)*0.001) - clwt = 2.0e-6 * (plyr(i,k)*0.001) -! clwt = 5.0e-6 * (plyr(i,k)*0.001) -! clwt = 5.0e-6 - - if (clw2(i,k) > clwt .or. & - & (inversn(i) .and. k <= kinver(i)) ) then - - onemrh= max( 1.e-10, 1.0-rhly(i,k) ) - clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) - -! tem1 = min(max(sqrt(onemrh*qstl(i,k)),0.0001),1.0) -! tem1 = 100.0 / tem1 - - tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) - tem1 = 2000.0 / tem1 -! tem1 = 2400.0 / tem1 -!cnt tem1 = 2500.0 / tem1 -! tem1 = min(max(sqrt(onemrh*qstl(i,k)),0.0001),1.0) -! tem1 = 2000.0 / tem1 -! tem1 = 1000.0 / tem1 -! tem1 = 100.0 / tem1 -! if (inversn(i) .and. k <= kinver(i)) tem1 = tem1 * 5.0 - - value = max( min( tem1*(clw2(i,k)-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(rhly(i,k)) ) - - cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) - endif - enddo - enddo - else - do k = 1, NLAY - do i = 1, IX -! clwt = 1.0e-6 * (plyr(i,k)*0.001) - clwt = 2.0e-6 * (plyr(i,k)*0.001) - - if (clw2(i,k) > clwt .or. & - & (inversn(i) .and. k <= kinver(i)) ) then - - onemrh= max( 1.e-10, 1.0-rhly(i,k) ) - clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) - - tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) !jhan - tem1 = 100.0 / tem1 - -! tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) -! tem1 = 2000.0 / tem1 -! -! tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) -! tem1 = 2200.0 / tem1 -! tem1 = 2400.0 / tem1 -! tem1 = 2500.0 / tem1 -! tem1 = min(max(sqrt(onemrh*qstl(i,k)),0.0001),1.0) -! tem1 = 2000.0 / tem1 -! tem1 = 1000.0 / tem1 -! tem1 = 100.0 / tem1 -! if (inversn(i) .and. k <= kinver(i)) tem1 = tem1 * 5.0 - - value = max( min( tem1*(clw2(i,k)-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(rhly(i,k)) ) - - cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) - endif - enddo - enddo - endif - - endif ! end_if_flip - - where (cldtot < climit) - cldtot = 0.0 - cwp = 0.0 - cip = 0.0 - crp = 0.0 - csp = 0.0 - endwhere -! When norad_precip = .true. snow/rain has no impact on radiation - if (norad_precip) then - crp = 0.0 - csp = 0.0 - endif - -! - if (ccnorm) then - do k = 1, NLAY - do i = 1, IX - if (cldtot(i,k) >= climit) then - tem1 = 1.0 / max(climit2, cldtot(i,k)) - cwp(i,k) = cwp(i,k) * tem1 - cip(i,k) = cip(i,k) * tem1 - crp(i,k) = crp(i,k) * tem1 - csp(i,k) = csp(i,k) * tem1 - endif - enddo - enddo - endif - -! --- effective ice cloud droplet radius - - do k = 1, NLAY - do i = 1, IX - tem1 = tlyr(i,k) - con_ttp - tem2 = cip(i,k) - - if (tem2 > 0.0) then - tem3 = tem2d(i,k) * tem2 & - & / (tlyr(i,k) * (1.0 + con_fvirt * qlyr(i,k))) - - if (tem1 < -50.0) then - rei(i,k) = (1250.0/9.917) * tem3 ** 0.109 - elseif (tem1 < -40.0) then - rei(i,k) = (1250.0/9.337) * tem3 ** 0.08 - elseif (tem1 < -30.0) then - rei(i,k) = (1250.0/9.208) * tem3 ** 0.055 - else - rei(i,k) = (1250.0/9.387) * tem3 ** 0.031 - endif - -! if (lprnt .and. k == l) print *,' reiL=',rei(i,k),' icec=', & -! & icec,' cip=',cip(i,k),' tem=',tem,' delt=',delt - - rei(i,k) = max(10.0, min(rei(i,k), 300.0)) -! rei(i,k) = max(20.0, min(rei(i,k), 300.0)) -!!!! rei(i,k) = max(30.0, min(rei(i,k), 300.0)) -! rei(i,k) = max(50.0, min(rei(i,k), 300.0)) -! rei(i,k) = max(100.0, min(rei(i,k), 300.0)) - endif - enddo - enddo -! - do k = 1, NLAY - do i = 1, IX - clouds(i,k,1) = cldtot(i,k) - clouds(i,k,2) = cwp(i,k) - clouds(i,k,3) = rew(i,k) - clouds(i,k,4) = cip(i,k) - clouds(i,k,5) = rei(i,k) - clouds(i,k,6) = crp(i,k) - clouds(i,k,7) = rer(i,k) -! clouds(i,k,8) = csp(i,k) !ncar scheme - clouds(i,k,8) = csp(i,k) * rsden(i,k) !fu's scheme - clouds(i,k,9) = rei(i,k) - enddo - enddo - - -! --- compute low, mid, high, total, and boundary layer cloud fractions -! and clouds top/bottom layer indices for low, mid, and high clouds. -! The three cloud domain boundaries are defined by ptopc. The cloud -! overlapping method is defined by control flag 'iovr', which is -! --- also used by the lw and sw radiation programs. - - call gethml & -! --- inputs: - & ( plyr, ptop1, cldtot, cldcnv, & - & IX,NLAY, iflip, iovr, & -! --- outputs: - & clds, mtop, mbot & - & ) - - -! - return -!................................... - end subroutine progcld2 -!----------------------------------- - - -!----------------------------------- - subroutine diagcld1 & -!................................... - -! --- inputs: - & ( plyr,plvl,tlyr,rhly,vvel,cv,cvt,cvb, & - & xlat,xlon,slmsk, & - & IX, NLAY, NLP1, iflip, iovr, & -! --- outputs: - & clouds,clds,mtop,mbot & - & ) - -! ================= subprogram documentation block ================ ! -! ! -! subprogram: diagcld1 computes cloud fractions for radiation ! -! calculations. ! -! ! -! abstract: clouds are diagnosed from layer relative humidity, and ! -! estimate cloud optical depth from temperature and layer thickness. ! -! then computes the low, mid, high, total and boundary layer cloud ! -! fractions and the vertical indices of low, mid, and high cloud top ! -! and base. the three vertical cloud domains are set up in the ! -! initial subroutine "cldinit". ! -! ! -! program history log: ! -! 11-xx-1992 y.h., k.a.c, a.k. - cloud parameterization ! -! 'cldjms' patterned after slingo and slingo's work (jgr, ! -! 1992), stratiform clouds are allowed in any layer except ! -! the surface and upper stratosphere. the relative humidity ! -! criterion may cery in different model layers. ! -! 10-25-1995 kenneth campana - tuned cloud rh curves ! -! rh-cld relation from tables created using mitchell-hahn ! -! tuning technique on airforce rtneph observations. ! -! 11-02-1995 kenneth campana - the bl relationships used ! -! below llyr, except in marine stratus regions. ! -! 04-11-1996 kenneth campana - save bl cld amt in cld(,5) ! -! 12-29-1998 s. moorthi - prognostic cloud method ! -! 04-15-2003 yu-tai hou - rewritten in frotran 90 ! -! modulized form, seperate prognostic and diagnostic methods ! -! into two packages. ! -! ! -! usage: call diagcld1 ! -! ! -! subprograms called: gethml ! -! ! -! attributes: ! -! language: fortran 90 ! -! machine: ibm-sp, sgi ! -! ! -! ! -! ==================== defination of variables ==================== ! -! ! -! input variables: ! -! plyr (IX,NLAY) : model layer mean pressure in mb (100Pa) ! -! plvl (IX,NLP1) : model level pressure in mb (100Pa) ! -! tlyr (IX,NLAY) : model layer mean temperature in k ! -! rhly (IX,NLAY) : layer relative humidity ! -! vvel (IX,NLAY) : layer mean vertical velocity in mb/sec ! -! clw (IX,NLAY) : layer cloud condensate amount (not used) ! -! xlat (IX) : grid latitude in radians ! -! xlon (IX) : grid longitude in radians ! -! slmsk (IX) : sea/land mask array (sea:0,land:1,sea-ice:2) ! -! cv (IX) : fraction of convective cloud ! -! cvt, cvb (IX) : conv cloud top/bottom pressure in mb ! -! IX : horizontal dimention ! -! NLAY,NLP1 : vertical layer/level dimensions ! -! iflip : control flag for in/out vertical indexing ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! iovr : control flag for cloud overlap ! -! =0 random overlapping clouds ! -! =1 max/ran overlapping clouds ! -! ! -! output variables: ! -! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud optical depth ! -! clouds(:,:,3) - layer cloud single scattering albedo ! -! clouds(:,:,4) - layer cloud asymmetry factor ! -! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! -! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! -! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! -! ! -! ==================== end of description ===================== ! -! - implicit none - -! --- inputs - integer, intent(in) :: IX, NLAY, NLP1, iflip, iovr - - real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & - & tlyr, rhly, vvel - - real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & - & slmsk, cv, cvt, cvb - -! --- outputs - real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds - - real (kind=kind_phys), dimension(:,:), intent(out) :: clds - - integer, dimension(:,:), intent(out) :: mtop,mbot - -! --- local variables: - real (kind=kind_phys), dimension(IX,NLAY) :: cldtot, cldcnv, & - & cldtau, taufac, dthdp, tem2d - - real (kind=kind_phys) :: ptop1(IX,4) - - real (kind=kind_phys) :: cr1, cr2, crk, pval, cval, omeg, value, & - & tem1, tem2 - - integer, dimension(IX):: idom, kcut - -! --- for rh-cl calculation - real (kind=kind_phys) :: xlatdg, xlondg, xlnn, xlss, xrgt, xlft, & - & rhcla(NBIN,NLON,MCLD,NSEAL), rhcld(IX,NBIN,MCLD) - - integer :: ireg, ib, ic, id, id1, il, is, nhalf - - integer :: i, j, k, klowt, klowb - - logical :: notstop - -! -!===> ... begin here -! - clouds(:,:,:) = 0.0 - - tem1 = 180.0 / con_pi - - lab_do_i_IX : do i = 1, IX - - xlatdg = xlat(i) * tem1 - xlondg = xlon(i) * tem1 - ireg = 4 - -! --- get rh-cld relation for this lat - - lab_do_j : do j = 1, 3 - if (xlatdg > xlabdy(j)) then - ireg = j - exit lab_do_j - endif - enddo lab_do_j - - do is = 1, NSEAL - do ic = 1, MCLD - do il = 1, NLON - do ib = 1, NBIN - rhcla(ib,il,ic,is) = rhcl(ib,il,ireg,ic,is) - enddo - enddo - enddo - enddo - -! --- linear transition between latitudinal regions... - do j = 1, 3 - xlnn = xlabdy(j) + xlim - xlss = xlabdy(j) - xlim - - if (xlatdg < xlnn .and. xlatdg > xlss) then - do is = 1, NSEAL - do ic = 1, MCLD - do il = 1, NLON - do ib = 1, NBIN - rhcla(ib,il,ic,is) = rhcl(ib,il,j+1,ic,is) & - & + (rhcl(ib,il,j,ic,is)-rhcl(ib,il,j+1,ic,is)) & - & * (xlatdg-xlss) / (xlnn-xlss) - enddo - enddo - enddo - enddo - endif - - enddo ! end_j_loop - -! --- get rh-cld relationship for each grid point, interpolating -! longitudinally between regions if necessary.. - - if (slmsk(i) < 1.0) then - is = 2 - else - is = 1 - endif - -! --- which hemisphere (e,w) - - if (xlondg > 180.e0) then - il = 2 - else - il = 1 - endif - - do ic = 1, MCLD - do ib = 1, NBIN - rhcld(i,ib,ic) = rhcla(ib,il,ic,is) - enddo - - lab_do_k : do k = 1, 3 - tem2 = abs(xlondg - xlobdy(k)) - - if (tem2 < xlim) then - id = il - id1= id + 1 - if (id1 > NLON) id1 = 1 - - xlft = xlobdy(k) - xlim - xrgt = xlobdy(k) + xlim - - do ib = 1, NBIN - rhcld(i,ib,ic) = rhcla(ib,id1,ic,is) & - & + (rhcla(ib,id,ic,is) - rhcla(ib,id1,ic,is)) & - & * (xlondg-xrgt)/(xlft-xrgt) - enddo - exit lab_do_k - endif - - enddo lab_do_k - - enddo ! end_do_ic_loop - enddo lab_do_i_IX - -! --- find top pressure for each cloud domain - - do j = 1, 4 - tem1 = ptopc(j,2) - ptopc(j,1) - - do i = 1, IX - tem2 = max( 0.0, 4.0*abs(xlat(i))/con_pi-1.0 ) - ptop1(i,j) = ptopc(j,1) + tem1*tem2 - enddo - enddo - -! --- stratiform cloud optical depth - - do k = 1, NLAY - do i = 1, IX - tem1 = tlyr(i,k) - con_ttp - if (tem1 <= -10.0) then - cldtau(i,k) = max( 0.1e-3, 2.0e-6*(tem1+82.5)**2 ) - else - cldtau(i,k) = min( 0.08, 6.949e-3*tem1+0.08 ) - endif - enddo - enddo - -! --- potential temperature and its lapse rate - - do k = 1, NLAY - do i = 1, IX - cldtot(i,k) = 0.0 - cldcnv(i,k) = 0.0 - tem1 = (plyr(i,k)*0.001) ** (-con_rocp) - tem2d(i,k) = tem1 * tlyr(i,k) - enddo - enddo - - do k = 1, NLAY-1 - do i = 1, IX - dthdp(i,k) = (tem2d(i,k+1)-tem2d(i,k))/(plyr(i,k+1)-plyr(i,k)) - enddo - enddo -! -!===> ... diagnostic method to find cloud amount cldtot, cldcnv -! - - if (iflip == 0) then ! input data from toa to sfc - -! --- find the lowest low cloud top sigma level, computed for each lat cause -! domain definition changes with latitude... - -! klowb = 1 - klowt = 1 - do k = 1, NLAY - do i = 1, IX -! if (plvl(i,k) < ptop1(i,2)) klowb = k - if (plvl(i,k) < ptop1(i,2)) klowt = max(klowt,k) - taufac(i,k) = plvl(i,k+1) - plvl(i,k) - enddo - enddo - - do i = 1, IX - -! --- find the stratosphere cut off layer for high cloud (about 250mb). -! it is assumed to be above the layer with dthdp less than -0.25 in -! the high cloud domain - - kcut(i) = 2 - lab_do_kcut0 : do k = klowt-1, 2, -1 - if (plyr(i,k) <= ptop1(i,3) .and. & - & dthdp(i,k) < -0.25e0) then - kcut(i) = k - exit lab_do_kcut0 - endif - enddo lab_do_kcut0 - -! --- put convective cloud into 'cldcnv', no merge at this point.. - - if (cv(i) >= climit .and. cvt(i) < cvb(i)) then - id = NLAY - id1 = NLAY - - lab_do_k_cvt0 : do k = 2, NLAY - if (cvt(i) <= plyr(i,k)) then - id = k - 1 - exit lab_do_k_cvt0 - endif - enddo lab_do_k_cvt0 - - lab_do_k_cvb0 : do k = NLAY-1, 1, -1 - if (cvb(i) >= plyr(i,k)) then - id1 = k + 1 - exit lab_do_k_cvb0 - endif - enddo lab_do_k_cvb0 - - tem1 = plyr(i,id1) - plyr(i,id) - do k = id, id1 - cldcnv(i,k) = cv(i) - taufac(i,k) = taufac(i,k) * max( 0.25, 1.0-0.125*tem1 ) - cldtau(i,k) = 0.06 - enddo - endif - - enddo ! end_do_i_loop - -! --- calculate stratiform cloud and put into array 'cldtot' using -! the cloud-rel.humidity relationship from table look-up..where -! tables obtained using k.mitchell frequency distribution tuning -!bl (observations are daily means from us af rtneph).....k.a.c. -!bl tables created without lowest 10 percent of atmos.....k.a.c. -! (observations are synoptic using -6,+3 window from rtneph) -! tables are created with lowest 10-percent-of-atmos, and are -! --- now used.. 25 october 1995 ... kac. - - do k = NLAY-1, 2, -1 - - if (k < llyr) then - do i = 1, IX - idom(i) = 0 - enddo - - do i = 1, IX - lab_do_ic0 : do ic = 2, 4 - if(plyr(i,k) >= ptop1(i,ic)) then - idom(i) = ic - exit lab_do_ic0 - endif - enddo lab_do_ic0 - enddo - else - do i = 1, IX - idom(i) = 1 - enddo - endif - - do i = 1, IX - id = idom(i) - nhalf = (NBIN + 1) / 2 - - if (id <= 0 .or. k < kcut(i)) then - cldtot(i,k) = 0.0 - elseif (rhly(i,k) <= rhcld(i,1,id)) then - cldtot(i,k) = 0.0 - elseif (rhly(i,k) >= rhcld(i,NBIN,id)) then - cldtot(i,k) = 1.0 - else - ib = nhalf - crk = rhly(i,k) - - notstop = .true. - do while ( notstop ) - nhalf = (nhalf + 1) / 2 - cr1 = rhcld(i,ib, id) - cr2 = rhcld(i,ib+1,id) - - if (crk <= cr1) then - ib = max( ib-nhalf, 1 ) - elseif (crk > cr2) then - ib = min( ib+nhalf, NBIN-1 ) - else - cldtot(i,k) = 0.01 * (ib + (crk - cr1)/(cr2 - cr1)) - notstop = .false. - endif - enddo ! end_do_while - endif - enddo ! end_do_i_loop - - enddo ! end_do_k_loop - -! --- vertical velocity adjustment on low clouds - - value = vvcld1 - vvcld2 - do k = klowt, llyr+1 - do i = 1, IX - - omeg = vvel(i,k) - cval = cldtot(i,k) - pval = plyr(i,k) - -! --- vertical velocity adjustment on low clouds - - if (cval >= climit .and. pval >= ptop1(i,2)) then - if (omeg >= vvcld1) then - cldtot(i,k) = 0.0 - elseif (omeg > vvcld2) then - tem1 = (vvcld1 - omeg) / value - cldtot(i,k) = cldtot(i,k) * sqrt(tem1) - endif - endif - - enddo ! end_do_i_loop - enddo ! end_do_k_loop - - else ! input data from sfc to toa - -! --- find the lowest low cloud top sigma level, computed for each lat cause -! domain definition changes with latitude... - -! klowb = NLAY - klowt = NLAY - do k = NLAY, 1, -1 - do i = 1, IX -! if (plvl(i,k) < ptop1(i,2)) klowb = k - if (plvl(i,k) < ptop1(i,2)) klowt = min(klowt,k) - taufac(i,k) = plvl(i,k) - plvl(i,k+1) ! dp for later cal cldtau use - enddo - enddo - - do i = 1, IX - -! --- find the stratosphere cut off layer for high cloud (about 250mb). -! it is assumed to be above the layer with dthdp less than -0.25 in -! the high cloud domain - - kcut(i) = NLAY - 1 - lab_do_kcut1 : do k = klowt+1, NLAY-1 - if (plyr(i,k) <= ptop1(i,3) .and. & - & dthdp(i,k) < -0.25e0) then - kcut(i) = k - exit lab_do_kcut1 - endif - enddo lab_do_kcut1 - -! --- put convective cloud into 'cldcnv', no merge at this point.. - - if (cv(i) >= climit .and. cvt(i) < cvb(i)) then - id = 1 - id1 = 1 - - lab_do_k_cvt : do k = NLAY-1, 1, -1 - if (cvt(i) <= plyr(i,k)) then - id = k + 1 - exit lab_do_k_cvt - endif - enddo lab_do_k_cvt - - lab_do_k_cvb : do k = 2, NLAY - if (cvb(i) >= plyr(i,k)) then - id1 = k - 1 - exit lab_do_k_cvb - endif - enddo lab_do_k_cvb - - tem1 = plyr(i,id1) - plyr(i,id) - do k = id1, id - cldcnv(i,k) = cv(i) - taufac(i,k) = taufac(i,k) * max( 0.25, 1.0-0.125*tem1 ) - cldtau(i,k) = 0.06 - enddo - endif - - enddo ! end_do_i_loop - -! --- calculate stratiform cloud and put into array 'cldtot' using -! the cloud-rel.humidity relationship from table look-up..where -! tables obtained using k.mitchell frequency distribution tuning -!bl (observations are daily means from us af rtneph).....k.a.c. -!bl tables created without lowest 10 percent of atmos.....k.a.c. -! (observations are synoptic using -6,+3 window from rtneph) -! tables are created with lowest 10-percent-of-atmos, and are -! --- now used.. 25 october 1995 ... kac. - - do k = 2, NLAY-1 - - if (k > llyr) then - do i = 1, IX - idom(i) = 0 - enddo - - do i = 1, IX - lab_do_ic1 : do ic = 2, 4 - if(plyr(i,k) >= ptop1(i,ic)) then - idom(i) = ic - exit lab_do_ic1 - endif - enddo lab_do_ic1 - enddo - else - do i = 1, IX - idom(i) = 1 - enddo - endif - - do i = 1, IX - id = idom(i) - nhalf = (NBIN + 1) / 2 - - if (id <= 0 .or. k > kcut(i)) then - cldtot(i,k) = 0.0 - elseif (rhly(i,k) <= rhcld(i,1,id)) then - cldtot(i,k) = 0.0 - elseif (rhly(i,k) >= rhcld(i,NBIN,id)) then - cldtot(i,k) = 1.0 - else - ib = nhalf - crk = rhly(i,k) - - notstop = .true. - do while ( notstop ) - nhalf = (nhalf + 1) / 2 - cr1 = rhcld(i,ib, id) - cr2 = rhcld(i,ib+1,id) - - if (crk <= cr1) then - ib = max( ib-nhalf, 1 ) - elseif (crk > cr2) then - ib = min( ib+nhalf, NBIN-1 ) - else - cldtot(i,k) = 0.01 * (ib + (crk - cr1)/(cr2 - cr1)) - notstop = .false. - endif - enddo ! end_do_while - endif - enddo ! end_do_i_loop - - enddo ! end_do_k_loop - -! --- vertical velocity adjustment on low clouds - - value = vvcld1 - vvcld2 - do k = llyr-1, klowt - do i = 1, IX - - omeg = vvel(i,k) - cval = cldtot(i,k) - pval = plyr(i,k) - -! --- vertical velocity adjustment on low clouds - - if (cval >= climit .and. pval >= ptop1(i,2)) then - if (omeg >= vvcld1) then - cldtot(i,k) = 0.0 - elseif (omeg > vvcld2) then - tem1 = (vvcld1 - omeg) / value - cldtot(i,k) = cldtot(i,k) * sqrt(tem1) - endif - endif - - enddo ! end_do_i_loop - enddo ! end_do_k_loop - - endif ! end_if_iflip - -! --- diagnostic cloud optical depth -! cldtau = cldtau * taufac - - where (cldtot < climit) - cldtot = 0.0 - endwhere - where (cldcnv < climit) - cldcnv = 0.0 - endwhere - - where (cldtot < climit .and. cldcnv < climit) - cldtau = 0.0 - endwhere - - do k = 1, NLAY - do i = 1, IX - clouds(i,k,1) = max(cldtot(i,k), cldcnv(i,k)) - clouds(i,k,2) = cldtau(i,k) * taufac(i,k) - clouds(i,k,3) = cldssa_def - clouds(i,k,4) = cldasy_def - enddo - enddo - -! -!===> ... compute low, mid, high, total, and boundary layer cloud fractions -! and clouds top/bottom layer indices for low, mid, and high clouds. -! the three cloud domain boundaries are defined by ptopc. the cloud -! overlapping method is defined by control flag 'iovr', which is -! also used by the lw and sw radiation programs. - - call gethml & -! --- inputs: - & ( plyr, ptop1, cldtot, cldcnv, & - & IX,NLAY, iflip, iovr, & -! --- outputs: - & clds, mtop, mbot & - & ) - -! - return -!................................... - end subroutine diagcld1 -!----------------------------------- - - -!----------------------------------- ! - subroutine gethml & -!................................... ! - -! --- inputs: - & ( plyr, ptop1, cldtot, cldcnv, & - & IX,NLAY, iflip, iovr, & -! --- outputs: - & clds, mtop, mbot & - & ) - -! =================================================================== ! -! ! -! abstract: compute high, mid, low, total, and boundary cloud fractions ! -! and cloud top/bottom layer indices for model diagnostic output. ! -! the three cloud domain boundaries are defined by ptopc. the cloud ! -! overlapping method is defined by control flag 'iovr', which is also ! -! used by lw and sw radiation programs. ! -! ! -! program history log: ! -! 04-29-2004 yu-tai hou - separated to become individule ! -! subprogram to calculate averaged h,m,l,bl cloud amounts. ! -! ! -! usage: call gethml ! -! ! -! subprograms called: none ! -! ! -! attributes: ! -! language: fortran 90 ! -! machine: ibm-sp, sgi ! -! ! -! ! -! ==================== defination of variables ==================== ! -! ! -! input variables: ! -! plyr (IX,NLAY) : model layer mean pressure in mb (100Pa) ! -! ptop1 (IX,4) : pressure limits of cloud domain interfaces ! -! (sfc,low,mid,high) in mb (100Pa) ! -! cldtot(IX,NLAY) : total or straiform cloud profile in fraction ! -! cldcnv(IX,NLAY) : convective cloud (for diagnostic scheme only) ! -! IX : horizontal dimention ! -! NLAY : vertical layer dimensions ! -! iflip : control flag for in/out vertical indexing ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! iovr : control flag for cloud overlap ! -! =0 random overlapping clouds ! -! =1 max/ran overlapping clouds ! -! ! -! output variables: ! -! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! -! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! -! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! -! ! -! ==================== end of description ===================== ! -! - implicit none! - -! --- inputs: - integer, intent(in) :: IX, NLAY, iflip, iovr - - real (kind=kind_phys), dimension(:,:), intent(in) :: plyr, ptop1, & - & cldtot, cldcnv - -! --- outputs - real (kind=kind_phys), dimension(:,:), intent(out) :: clds - - integer, dimension(:,:), intent(out) :: mtop, mbot - -! --- local variables: - real (kind=kind_phys) :: cl1(IX), cl2(IX) - - real (kind=kind_phys) :: pcur, pnxt, ccur, cnxt - - integer, dimension(IX):: idom, kbt1, kth1, kbt2, kth2 - - integer :: i, k, id, id1, kstr, kend, kinc - -! -!===> ... begin here -! - do i = 1, IX - clds(i,1) = 0.0 - clds(i,2) = 0.0 - clds(i,3) = 0.0 - clds(i,4) = 0.0 - clds(i,5) = 0.0 - mtop(i,1) = 1 - mtop(i,2) = 1 - mtop(i,3) = 1 - mbot(i,1) = 1 - mbot(i,2) = 1 - mbot(i,3) = 1 - cl1 (i) = 1.0 - cl2 (i) = 1.0 - enddo - -! --- total and bl clouds, where cl1, cl2 are fractions of clear-sky view -! layer processed from surface and up - - if (iflip == 0) then ! input data from toa to sfc - kstr = NLAY - kend = 1 - kinc = -1 - else ! input data from sfc to toa - kstr = 1 - kend = NLAY - kinc = 1 - endif ! end_if_iflip - - if (iovr == 0) then ! random overlap - - do k = kstr, kend, kinc - do i = 1, IX - ccur = min( ovcst, max( cldtot(i,k), cldcnv(i,k) )) - if (ccur >= climit) cl1(i) = cl1(i) * (1.0 - ccur) - enddo - - if (k == llyr) then - do i = 1, IX - clds(i,5) = 1.0 - cl1(i) ! save bl cloud - enddo - endif - enddo - - do i = 1, IX - clds(i,4) = 1.0 - cl1(i) ! save total cloud - enddo - - else ! max/ran overlap - - do k = kstr, kend, kinc - do i = 1, IX - ccur = min( ovcst, max( cldtot(i,k), cldcnv(i,k) )) - if (ccur >= climit) then ! cloudy layer - cl2(i) = min( cl2(i), (1.0 - ccur) ) - else ! clear layer - cl1(i) = cl1(i) * cl2(i) - cl2(i) = 1.0 - endif - enddo - - if (k == llyr) then - do i = 1, IX - clds(i,5) = 1.0 - cl1(i) * cl2(i) ! save bl cloud - enddo - endif - enddo - - do i = 1, IX - clds(i,4) = 1.0 - cl1(i) * cl2(i) ! save total cloud - enddo - - endif ! end_if_iovr - -! --- high, mid, low clouds, where cl1, cl2 are cloud fractions -! layer processed from one layer below llyr and up -! --- change! layer processed from surface to top, so low clouds will -! contains both bl and low clouds. - - if (iflip == 0) then ! input data from toa to sfc - - do i = 1, IX - cl1 (i) = 0.0 - cl2 (i) = 0.0 - kbt1(i) = NLAY - kbt2(i) = NLAY - kth1(i) = 0 - kth2(i) = 0 - idom(i) = 1 - enddo - -!org do k = llyr-1, 1, -1 - do k = NLAY, 1, -1 - do i = 1, IX - id = idom(i) - id1= id + 1 - - pcur = plyr(i,k) - ccur = min( ovcst, max( cldtot(i,k), cldcnv(i,k) )) - - if (k > 1) then - pnxt = plyr(i,k-1) - cnxt = min( ovcst, max( cldtot(i,k-1), cldcnv(i,k-1) )) - else - pnxt = -1.0 - cnxt = 0.0 - endif - - if (pcur < ptop1(i,id1)) then - id = id + 1 - id1= id1 + 1 - idom(i) = id - endif - - if (ccur >= climit) then - if (kth2(i) == 0) kbt2(i) = k - kth2(i) = kth2(i) + 1 - - if (iovr == 0) then - cl2(i) = cl2(i) + ccur - cl2(i)*ccur - else - cl2(i) = max( cl2(i), ccur ) - endif - - if (cnxt < climit .or. pnxt < ptop1(i,id1)) then - kbt1(i) = nint( (cl1(i)*kbt1(i) + cl2(i)*kbt2(i) ) & - & / (cl1(i) + cl2(i)) ) - kth1(i) = nint( (cl1(i)*kth1(i) + cl2(i)*kth2(i) ) & - & / (cl1(i) + cl2(i)) ) - cl1 (i) = cl1(i) + cl2(i) - cl1(i)*cl2(i) - - kbt2(i) = 1 - kth2(i) = 0 - cl2 (i) = 0.0 - endif ! end_if_cnxt_or_pnxt - endif ! end_if_ccur - - if (pnxt < ptop1(i,id1)) then - clds(i,id) = cl1(i) - mtop(i,id) = min( kbt1(i), kbt1(i)-kth1(i)+1 ) - mbot(i,id) = kbt1(i) - - cl1 (i) = 0.0 - kbt1(i) = 1 - kth1(i) = 0 - endif ! end_if_pnxt - - enddo ! end_do_i_loop - enddo ! end_do_k_loop - - else ! input data from sfc to toa - - do i = 1, IX - cl1 (i) = 0.0 - cl2 (i) = 0.0 - kbt1(i) = 1 - kbt2(i) = 1 - kth1(i) = 0 - kth2(i) = 0 - idom(i) = 1 - enddo - -!org do k = llyr+1, NLAY - do k = 1, NLAY - do i = 1, IX - id = idom(i) - id1= id + 1 - - pcur = plyr(i,k) - ccur = min( ovcst, max( cldtot(i,k), cldcnv(i,k) )) - - if (k < NLAY) then - pnxt = plyr(i,k+1) - cnxt = min( ovcst, max( cldtot(i,k+1), cldcnv(i,k+1) )) - else - pnxt = -1.0 - cnxt = 0.0 - endif - - if (pcur < ptop1(i,id1)) then - id = id + 1 - id1= id1 + 1 - idom(i) = id - endif - - if (ccur >= climit) then - if (kth2(i) == 0) kbt2(i) = k - kth2(i) = kth2(i) + 1 - - if (iovr == 0) then - cl2(i) = cl2(i) + ccur - cl2(i)*ccur - else - cl2(i) = max( cl2(i), ccur ) - endif - - if (cnxt < climit .or. pnxt < ptop1(i,id1)) then - kbt1(i) = nint( (cl1(i)*kbt1(i) + cl2(i)*kbt2(i)) & - & / (cl1(i) + cl2(i)) ) - kth1(i) = nint( (cl1(i)*kth1(i) + cl2(i)*kth2(i)) & - & / (cl1(i) + cl2(i)) ) - cl1 (i) = cl1(i) + cl2(i) - cl1(i)*cl2(i) - - kbt2(i) = 1 - kth2(i) = 0 - cl2 (i) = 0.0 - endif ! end_if_cnxt_or_pnxt - endif ! end_if_ccur - - if (pnxt < ptop1(i,id1)) then - clds(i,id) = cl1(i) - mtop(i,id) = max( kbt1(i), kbt1(i)+kth1(i)-1 ) - mbot(i,id) = kbt1(i) - - cl1 (i) = 0.0 - kbt1(i) = 1 - kth1(i) = 0 - endif ! end_if_pnxt - - enddo ! end_do_i_loop - enddo ! end_do_k_loop - - endif ! end_if_iflip - -! - return -!................................... - end subroutine gethml -!----------------------------------- - - -!----------------------------------- ! - subroutine rhtable & -!................................... ! - -! --- inputs: - & ( me & -! --- outputs: - &, ier ) - -! =================================================================== ! -! ! -! abstract: cld-rh relations obtained from mitchell-hahn procedure, ! -! here read cld/rh tuning tables for day 0,1,...,5 and merge into 1 ! -! file. ! -! ! -! program history log: ! -! 03-xx-1993 kenneth campana - created original crhtab ! -! 02-xx-1994 kenneth campana - use only one table for all ! -! forecast hours ! -! 08-xx-1997 kenneth campana - smooth out last bunch of ! -! bins of the tables ! -! 04-21-2003 yu-tai hou - seperate prognostic and ! -! diagnostic cloud schemes, re-write into f90 ! -! modulized form. ! -! ! -! ! -! inputs: ! -! me : check print control flag ! -! ! -! outputs: ! -! ier : error flag ! -! ! -! =================================================================== ! -! - implicit none! - -! --- inputs: - integer, intent(in) :: me - -! --- output: - integer, intent(out) :: ier - -! --- locals: - real (kind=kind_io8), dimension(NBIN,NLON,NLAT,MCLD,NSEAL) :: & - & rhfd, rtnfd, rhcf, rtncf, rhcla - - real (kind=kind_io4), dimension(NBIN,NLON,NLAT,MCLD,NSEAL) :: & - & rhfd4, rtnfd4 - - real(kind=kind_io4) :: fhour - - real(kind=kind_phys) :: binscl, cfrac, clsat, rhsat, cstem - - integer, dimension(NLON,NLAT,MCLD,NSEAL) :: kpts, kkpts - - integer :: icdays(15), idate(4), nbdayi, isat - - integer :: i, i1, j, k, l, m, id, im, iy - -! -!===> ... begin here -! - - ier = 1 - - rewind NICLTUN - - binscl = 1.0 / NBIN - -! --- array initializations - - do m=1,NSEAL - do l=1,MCLD - do k=1,NLAT - do j=1,NLON - do i=1,NBIN - rhcf (i,j,k,l,m) = 0.0 - rtncf(i,j,k,l,m) = 0.0 - rhcla(i,j,k,l,m) = -0.1 - enddo - enddo - enddo - enddo - enddo - - kkpts = 0 - -! --- read the data off the rotating file - - read (NICLTUN,ERR=998,END=999) nbdayi, icdays - - if (me == 0) print 11, nbdayi - 11 format(' from rhtable DAYS ON FILE =',i5) - - do i = 1, nbdayi - id = icdays(i) / 10000 - im = (icdays(i)-id*10000) / 100 - iy = icdays(i)-id*10000-im*100 - if (me == 0) print 51, id,im,iy - 51 format(' from rhtable ARCHV DATA FROM DA,MO,YR=',3i4) - enddo - - read (NICLTUN,ERR=998,END=999) fhour,idate - - do i1 = 1, nbdayi - read (NICLTUN) rhfd4 - rhfd = rhfd4 - - read (NICLTUN) rtnfd4 - rtnfd = rtnfd4 - - read (NICLTUN) kpts - - do m=1,NSEAL - do l=1,MCLD - do k=1,NLAT - do j=1,NLON - do i=1,NBIN - rhcf (i,j,k,l,m) = rhcf (i,j,k,l,m) + rhfd (i,j,k,l,m) - rtncf(i,j,k,l,m) = rtncf(i,j,k,l,m) + rtnfd(i,j,k,l,m) - enddo - enddo - enddo - enddo - enddo - - kkpts = kkpts + kpts - - enddo ! end_do_i1_loop - - do m = 1, NSEAL - do l = 1, MCLD - do k = 1, NLAT - do j = 1, NLON - -! --- compute the cumulative frequency distribution - - do i = 2, NBIN - rhcf (i,j,k,l,m) = rhcf (i-1,j,k,l,m) + rhcf (i,j,k,l,m) - rtncf(i,j,k,l,m) = rtncf(i-1,j,k,l,m) + rtncf(i,j,k,l,m) - enddo ! end_do_i_loop - - if (kkpts(j,k,l,m) > 0) then - do i = 1, NBIN - rhcf (i,j,k,l,m)= rhcf (i,j,k,l,m)/kkpts(j,k,l,m) - rtncf(i,j,k,l,m)=min(1., rtncf(i,j,k,l,m)/kkpts(j,k,l,m)) - enddo - -! --- cause we mix calculations of rh retune with cray and ibm words -! the last value of rhcf is close to but ne 1.0, -! --- so we reset it in order that the 360 loop gives complete tabl - - rhcf(NBIN,j,k,l,m) = 1.0 - - do i = 1, NBIN - lab_do_i1 : do i1 = 1, NBIN - if (rhcf(i1,j,k,l,m) >= rtncf(i,j,k,l,m)) then - rhcla(i,j,k,l,m) = i1 * binscl - exit lab_do_i1 - endif - enddo lab_do_i1 - enddo - - else ! if_kkpts -! --- no critical rh - - do i = 1, NBIN - rhcf (i,j,k,l,m) = -0.1 - rtncf(i,j,k,l,m) = -0.1 - enddo - - if (me == 0) then - print 210, k,j,m - 210 format(' NO CRIT RH FOR LAT=',I3,' AND LON BAND=',I3, & - & ' LAND(=1) SEA=',I3//' MODEL RH ',' OBS RTCLD') - do i = 1, NBIN - print 203, rhcf(i,j,k,l,m), rtncf(i,j,k,l,m) - 203 format(2f10.2) - enddo - endif - - endif ! if_kkpts - - enddo ! end_do_j_loop - enddo ! end_do_k_loop - enddo ! end_do_l_loop - enddo ! end_do_m_loop - - do m = 1, NSEAL - do l = 1, MCLD - do k = 1, NLAT - do j = 1, NLON - - isat = 0 - do i = 1, NBIN-1 - cfrac = binscl * (i - 1) - - if (rhcla(i,j,k,l,m) < 0.0) then - print 1941, i,m,l,k,j - 1941 format(' NEG RHCLA FOR IT,NSL,NC,LAT,LON=',5I4 & - &, '...STOPPP..') - stop - endif - - if (rtncf(i,j,k,l,m) >= 1.0) then - if (isat <= 0) then - isat = i - rhsat = rhcla(i,j,k,l,m) - clsat = cfrac - endif - - rhcla(i,j,k,l,m) = rhsat + (1.0 - rhsat) & - & * (cfrac - clsat) / (1.0 - clsat) - endif - enddo - - rhcla(NBIN,j,k,l,m) = 1.0 - - enddo ! end_do_j_loop - enddo ! end_do_k_loop - enddo ! end_do_l_loop - enddo ! end_do_m_loop - -! --- smooth out the table as it reaches rh=1.0, via linear interpolation -! between location of rh ge .98 and the NBIN bin (where rh=1.0) -! previously rh=1.0 occurred for many of the latter bins in the -! --- table, thereby giving a cloud value of less then 1.0 for rh=1.0 - - rhcl = rhcla - - do m = 1, NSEAL - do l = 1, MCLD - do k = 1, NLAT - do j = 1, NLON - - lab_do_i : do i = 1, NBIN - 2 - cfrac = binscl * i - - if (rhcla(i,j,k,l,m) >= 0.98) then - do i1 = i, NBIN - cstem = binscl * i1 - - rhcl(i1,j,k,l,m) = rhcla(i,j,k,l,m) & - & + (rhcla(NBIN,j,k,l,m) - rhcla(i,j,k,l,m)) & - & * (cstem - cfrac) / (1.0 - cfrac) - enddo - exit lab_do_i - endif - enddo lab_do_i - - enddo ! end_do_j_loop - enddo ! end_do_k_loop - enddo ! end_do_l_loop - enddo ! end_do_m_loop - - if (me == 0) then - print *,'completed rhtable for cloud tuninig tables' - endif - return - - 998 print 988 - 988 format(' from rhtable ERROR READING TABLES') - ier = -1 - return - - 999 print 989 - 989 format(' from rhtable E.O.F READING TABLES') - ier = -1 - return - -!................................... - end subroutine rhtable -!----------------------------------- - - -! -!........................................! - end module module_radiation_clouds ! -!========================================! - diff --git a/src/fim/FIMsrc/fim/column/radiation_gases.f b/src/fim/FIMsrc/fim/column/radiation_gases.f deleted file mode 100644 index 3743e9a..0000000 --- a/src/fim/FIMsrc/fim/column/radiation_gases.f +++ /dev/null @@ -1,730 +0,0 @@ -!!!!! ========================================================== !!!!! -!!!!! 'module_radiation_gases' description !!!!! -!!!!! ========================================================== !!!!! -! ! -! set up ozone climatological profiles and other constant gas ! -! profiles, such as co2, ch4, n2o, o2, and those of cfc gases. All ! -! data are entered as mixing ratio by volume, except ozone which is ! -! mass mixing ratio (g/g). ! -! ! -! in the module, the externally callabe subroutines are : ! -! ! -! 'gasinit' -- initialization ! -! input: ! -! ( iyear, month, ICTM, ICO2, me ) ! -! output: ! -! ( none ) ! -! ! -! 'getozn' -- setup climatological ozone profile ! -! input: ! -! ( prslk,xlat,k1oz,k2oz,facoz, ! -! IMAX, LM, iflip ) ! -! output: ! -! ( o3mmr ) ! -! ! -! 'getgases' -- setup constant gas profiles for LW and SW ! -! input: ! -! ( plvl, xlon, xlat, ! -! IMAX, LMAX, iflip ) ! -! output: ! -! ( gasdat ) ! -! ! -! external modules referenced: ! -! 'module machine' in 'machine.f' ! -! 'module funcphys' in 'funcphys.f' ! -! 'module physcons' in 'physcons.f ! -! 'module module_iounitdef' in 'iounitdef.f' ! -! ! -! unit used for radiative active gases: ! -! ozone : mass mixing ratio (g/g) ! -! co2 : volume mixing ratio (p/p) ! -! n2o : volume mixing ratio (p/p) ! -! ch4 : volume mixing ratio (p/p) ! -! o2 : volume mixing ratio (p/p) ! -! co : volume mixing ratio (p/p) ! -! cfc11 : volume mixing ratio (p/p) ! -! cfc12 : volume mixing ratio (p/p) ! -! cfc22 : volume mixing ratio (p/p) ! -! ccl4 : volume mixing ratio (p/p) ! -! cfc113: volume mixing ratio (p/p) ! -! ! -!!!!! ========================================================== !!!!! -!!!!! end descriptions !!!!! -!!!!! ========================================================== !!!!! - - - -!========================================! - module module_radiation_gases ! -!........................................! -! - use machine , only : kind_phys, kind_io4 - use funcphys, only : fpkap - use physcons, only : con_pi - use ozne_def, only : jmr => latsozc, loz => levozc & - &, blte => blatc, dlte=> dphiozc & - &, timeozc => timeozc - use module_iounitdef, only : NIO3CLM, NICO2CN - use module_control, only : curve,NumCacheBlocksPerPE - & ,alt_topo,gfsltln_file,mtnvar_file,aerosol_file,co2_2008_file - & ,co2_glb_file -! - implicit none -! - private - -! --- parameter constants - - integer, parameter, public :: NF_VGAS = 10 ! number of gas species - integer, parameter :: IMXCO2 = 24 ! input co2 data lon points - integer, parameter :: JMXCO2 = 12 ! input co2 data lat points - integer, parameter :: MINYEAR = 1957 ! earlist year 2-d co2 data - ! available - - real (kind=kind_phys), parameter :: resco2=15.0 ! horiz res in degree - real (kind=kind_phys), parameter :: raddeg=180.0/con_pi ! rad->deg conversion - real (kind=kind_phys), parameter :: prsco2=788.0 ! pres lim for 2-d co2 (mb) - -! --- parameter constants for gas volume mixing ratioes - - real (kind=kind_phys), parameter :: co2vmr_def = 390.0e-6 - real (kind=kind_phys), parameter :: n2ovmr_def = 0.31e-6 - real (kind=kind_phys), parameter :: ch4vmr_def = 1.50e-6 - real (kind=kind_phys), parameter :: o2vmr_def = 0.209 - real (kind=kind_phys), parameter :: covmr_def = 1.50e-8 - real (kind=kind_phys), parameter :: f11vmr_def = 3.520e-10 ! aer 2003 value - real (kind=kind_phys), parameter :: f12vmr_def = 6.358e-10 ! aer 2003 value - real (kind=kind_phys), parameter :: f22vmr_def = 1.500e-10 ! aer 2003 value - real (kind=kind_phys), parameter :: cl4vmr_def = 1.397e-10 ! aer 2003 value - real (kind=kind_phys), parameter :: f113vmr_def= 8.2000e-11 ! gfdl 1999 value - -! --- co2 2-d monthly data and global mean from observed data - - real (kind=kind_phys), allocatable :: co2vmr_sav(:,:,:) - real (kind=kind_phys) :: co2_glb - -! --- ico2flg - control flag for co2 data sources set by 'gasinit' -! =0: use prescribed global mean value -! =1: use observed co2 global annual mean value -! =2: use obs co2 monthly data with 2-d variation - - integer :: ico2flg = 0 - integer :: kyrsav = 0 - integer :: kmonsav = 0 - -! --- public interfaces - - public gasinit, getgases, getozn - - -! ================= - contains -! ================= - -!----------------------------------- - subroutine gasinit & -!................................... - -! --- inputs: - & ( iyear, month, ICTM, ICO2, me ) -! --- outputs: ( none ) - -! =================================================================== ! -! ! -! gasinit reads in recorded global 2-d monthly co2 data stored in ! -! 15 degree lat/lon horizontal resolution. ! -! ! -! inputs: dimemsion ! -! iyear - year of the requested data for fcst 1 ! -! month - month of the year 1 ! -! ICTM - =yyyy#, external data time/date control flag ! -! = 0: use data at initial cond time, if not available,! -! then use latest, without extrapolation. ! -! = 1: use data at the forecast time, if not available,! -! then use latest and extrapolate to fcst time. ! -! =yyyy0: use yyyy data for the forecast time, no further ! -! data extrapolation. ! -! =yyyy1: use yyyy data for the fcst. if needed, do ! -! extrapolation to match the fcst time. ! -! ICO2 - input data control flag 1 ! -! =0: use prescribed global mean co2 (old opernl) ! -! =1: use observed co2 global annual mean value ! -! =2: use obs co2 monthly data with 2-d variation ! -! me - print message control flag 1 ! -! ! -! outputs: (to the module variables) ! -! ( none ) ! -! ! -! module variables: ! -! ico2flg - control flag as ICO2 1 ! -! co2vmr_sav - monthly co2 volume mixing ratio IMXCO2*JMXCO2*12 ! -! co2_glb - global annual mean co2 mixing ratio 1 ! -! ! -! usage: call gasinit ! -! ! -! subprograms called: none ! -! ! -! =================================================================== ! -! - implicit none - -! --- inputs: - integer, intent(in) :: iyear, month, ICTM, ICO2, me - -! --- output: ( none ) - -! --- locals: - real (kind=kind_phys), dimension(IMXCO2,JMXCO2) :: co2dat - real (kind=kind_phys):: co2g1, co2g2, rate - integer :: i, iyr, imo, iyr1, iyr2, jyr, idyr - logical :: file_exist, lextpl - character :: cline*94, cform*8, cfile0*26, cfile1*26 - -! data cfile0 / 'co2historicaldata_glob.txt' / -! data cfile1 / 'co2historicaldata_2004.txt' / - data cform / '(24f7.2)' / !! data format in IMXCO2*f7.2 - - cfile0=trim(co2_glb_file) - cfile1=trim(co2_2008_file) -!===> ... begin here - - ico2flg = ICO2 - -! ---- Default value for co2_glb: co2vmr_def - - co2_glb = co2vmr_def - - if ( ICO2 == 0 ) then -! --- ... use prescribed global mean co2 data - co2_glb = co2vmr_def - - if ( me == 0 ) then - print *,' - Using prescribed co2 global mean value=', & - & co2vmr_def - endif - - return - endif - - lextpl = ( mod(ICTM,10) == 1 ) ! flag for data extrapolation - idyr = ICTM / 10 ! year of data source used - if ( idyr == 0 ) idyr = iyear ! not specified, use model year - - if ( ICO2 == 1 .or. ICO2 == 2 ) then -! --- ... auto select co2 2-d data table for required year - - kmonsav = month - if ( kyrsav == iyear ) return - kyrsav = iyear - iyr = iyear - -! --- ... allocate data space - if ( ICO2==2 .and. .not. allocated(co2vmr_sav) ) then - allocate ( co2vmr_sav(IMXCO2,JMXCO2,12) ) - endif - -! --- ... set up input data format -! write(cform,22) IMXCO2 -! 22 format('(',i2,'f7.2)') - -! --- ... for data earlier than MINYEAR (1957), the data are in -! the form of semi-yearly global mean values. otherwise, -! data are monthly mean in horizontal 2-d map. - - Lab_if_idyr : if ( idyr < MINYEAR ) then - - if ( me == 0 ) then - print *,' - Using Historical Co2 Data Table' - print *,' Requested CO2 data year',iyear,' earlier than', & - & MINYEAR - print *,' Which is the earliest monthly observation', & - & ' data available.' - print *,' Thus, historical global mean data is used' - endif - -! --- ... check to see if requested co2 data file existed - - inquire (file=cfile0, exist=file_exist) - if ( .not. file_exist ) then - - if ( me == 0 ) then - print *,' Requested co2 data file "',cfile0, & - & '" not found!' - print *,' *** Stopped in subroutine GASINIT !!' - endif - stop - else - open (NICO2CN,file=cfile0,form='formatted',status='old') - rewind NICO2CN - - read (NICO2CN, 24) iyr1, iyr2, cline - 24 format(i4,4x,i4,a48) - - if ( me == 0 ) then - print *,' Opened co2 data file: ',cfile0 -!check print *, iyr1, iyr2, cline(1:48) - endif - - if ( idyr < iyr1 ) then - iyr = iyr1 -!check if ( me == 0 ) then -! print *,' Using earlist available co2 data, year=', & -! & iyr1 -!check endif - endif - - i = iyr2 - Lab_dowhile1 : do while ( i >= iyr1 ) -! read (NICO2CN,26) jyr, co2g1, co2g2 -! 26 format(i4,4x,2f7.2) - read (NICO2CN, *) jyr, co2g1, co2g2 - - if ( i == iyr .and. iyr == jyr ) then - co2_glb = (co2g1+co2g2) * 0.5e-6 - if ( ICO2 == 2 ) then - co2vmr_sav(:,:,1:6) = co2g1 * 1.0e-6 - co2vmr_sav(:,:,7:12) = co2g2 * 1.0e-6 - endif - - if ( me == 0 ) print *,' Co2 data for year',iyear, & - & co2_glb - exit Lab_dowhile1 - else -!check if ( me == 0 ) print *,' Skip co2 data for year',i - i = i - 1 - endif - enddo Lab_dowhile1 - - close ( NICO2CN ) - endif ! end if_file_exist_block - - else Lab_if_idyr - -! --- ... set up input data file name - write(cfile1(19:22),34) idyr - 34 format(i4.4) - - if ( me == 0 ) then - print *,' - Using Historical Co2 Data Table' - endif - -! --- ... check to see if requested co2 data file existed - - inquire (file=cfile1, exist=file_exist) - if ( .not. file_exist ) then - Lab_if_ICTM : if ( ICTM > 10 ) then ! specified year of data not found - - if ( me == 0 ) then - print *,' Specified co2 data for year',idyr, & - & ' not found !! Need to change namelist ICTM !!' - print *,' *** Stopped in subroutine GASINIT !!' - endif - stop - - else Lab_if_ICTM ! looking for latest available data - - if ( me == 0 ) then - print *,' Requested co2 data for year',idyr, & - & ' not found, check for other available data set' - endif - - Lab_dowhile2 : do while ( iyr >= MINYEAR ) - iyr = iyr - 1 - write(cfile1(19:22),34) iyr - - inquire (file=cfile1, exist=file_exist) - if ( me == 0 ) then - print *,' Looking for CO2 file ',cfile1 - endif - - if ( file_exist ) then - exit Lab_dowhile2 - endif - enddo Lab_dowhile2 - - if ( .not. file_exist ) then -! jbao new gfs don't have file yet - if ( me == 0) print *,' Can not find co2 data source file, - . use default = ',co2_glb - return -! end jbao - if ( me == 0 ) then - print *,' Can not find co2 data source file' - print *,' *** Stopped in subroutine GASINIT !!' - endif - stop - endif - - endif Lab_if_ICTM - endif ! end if_file_exist_block - -! --- ... read in co2 2-d data for the requested month - open (NICO2CN,file=cfile1,form='formatted',status='old') - rewind NICO2CN - read (NICO2CN, 36) iyr, cline, co2g1, co2g2 - 36 format(i4,a94,f7.2,16x,f5.2) - - if ( me == 0 ) then - print *,' Opened co2 data file: ',cfile1 - print *, iyr, cline, co2g1, ' GROWTH RATE =', co2g2 - endif - -! --- ... add growth rate if needed - if ( lextpl ) then -! rate = co2g2 * (iyear - iyr) ! rate from early year -! rate = 1.60 * (iyear - iyr) ! avg rate over long period - rate = 2.00 * (iyear - iyr) ! avg rate for recent period - else - rate = 0.0 - endif - - co2_glb = (co2g1 + rate) * 1.0e-6 -!check if ( me == 0 ) print *,' co2 data for year',iyear,co2_glb - - if ( ICO2 == 2 ) then - do imo = 1, 12 - read (NICO2CN,cform) co2dat -!check print cform, co2dat - - co2vmr_sav(:,:,imo) = (co2dat(:,:) + rate) * 1.0e-6 - enddo - - if ( me == 0 ) then - print *,' CHECK: Sample CO2 data used for year:',iyear - do imo = 1, 12, 3 - print *,' Month =',imo - print *, co2vmr_sav(1,:,imo) - enddo - endif - endif - - close ( NICO2CN ) - endif Lab_if_idyr - - return - else - print *,' !! ERROR in CO2 Scheme Setting, ICO2=',ICO2 - stop - endif ! end if_ICO2_block - -! -!................................... - end subroutine gasinit -!----------------------------------- - - -!----------------------------------- - subroutine getgases & -!................................... - -! --- inputs: - & ( plvl, xlon, xlat, & - & IMAX, LMAX, iflip, & -! --- outputs: - & gasdat & - & ) - -! =================================================================== ! -! ! -! getgases set up global distribution of radiation absorbing gases ! -! in volume mixing ratio. currently only co2 has the options from ! -! observed values, all other gases are asigned to the climatological ! -! values. ! -! ! -! inputs: ! -! plvl(IMAX,LMAX+1)- pressure at model layer interfaces (mb) ! -! xlon,xlat(IMAX) - grid longitude/latitude in radians ! -! IMAX, LMAX - horiz, vert dimensions for output data ! -! iflip - control flag for direction of vertical index ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! ! -! outputs: ! -! gasdat(IMAX,LMAX,NF_VGAS) - gases volume mixing ratioes ! -! (:,:,1) - co2 ! -! (:,:,2) - n2o ! -! (:,:,3) - ch4 ! -! (:,:,4) - o2 ! -! (:,:,5) - co ! -! (:,:,6) - cfc11 ! -! (:,:,7) - cfc12 ! -! (:,:,8) - cfc22 ! -! (:,:,9) - ccl4 ! -! (:,:,10) - cfc113 ! -! ! -! module variables used: ! -! ico2flg - =0: use prescribed co2 global mean value ! -! =1: use input global mean co2 value (co2_glb) ! -! =2: use input 2-d monthly co2 value (co2vmr_sav) ! -! co2vmr_sav - saved monthly co2 concentration from sub gasinit ! -! co2_glb - saved global annual mean co2 value from gasinit ! -! ! -! usage: call getgases ! -! ! -! subprograms called: none ! -! ! -! =================================================================== ! -! - implicit none - -! --- input: - integer, intent(in) :: IMAX, LMAX, iflip - real (kind=kind_phys), intent(in) :: plvl(:,:), xlon(:), xlat(:) - -! --- output: - real (kind=kind_phys), intent(out) :: gasdat(:,:,:) - -! --- local: - integer :: i, k, ilat, ilon - -!===> ... begin here - -! --- ... assign default values - - do k = 1, LMAX - do i = 1, IMAX - gasdat(i,k,1) = co2vmr_def - gasdat(i,k,2) = n2ovmr_def - gasdat(i,k,3) = ch4vmr_def - gasdat(i,k,4) = o2vmr_def - gasdat(i,k,5) = covmr_def - gasdat(i,k,6) = f11vmr_def - gasdat(i,k,7) = f12vmr_def - gasdat(i,k,8) = f22vmr_def - gasdat(i,k,9) = cl4vmr_def - gasdat(i,k,10)= f113vmr_def - enddo - enddo - -! --- ... co2 section - - if ( ico2flg == 1 ) then -! --- use obs co2 global annual mean value only - - do k = 1, LMAX - do i = 1, IMAX - gasdat(i,k,1) = co2_glb - enddo - enddo - - elseif ( ico2flg == 2 ) then -! --- use obs co2 monthly data with 2-d variation at lower atmos -! otherwise use global mean value - - do i = 1, IMAX - ilon = min( IMXCO2, int( xlon(i)*raddeg /resco2) + 1 ) - ilat = min( JMXCO2, int((90.0-xlat(i)*raddeg)/resco2) + 1 ) - - do k = 1, LMAX - if ( plvl(i,k+1) >= prsco2 ) then - gasdat(i,k,1) = co2vmr_sav(ilon,ilat,kmonsav) - else - gasdat(i,k,1) = co2_glb - endif - enddo - enddo - endif - -! - return -!................................... - end subroutine getgases -!----------------------------------- - - -!----------------------------------- - subroutine getozn & -!................................... - -! --- inputs: - & ( prslk,xlat,k1oz,k2oz,facoz, & - & IMAX, LM, iflip, & -! --- outputs: - & o3mmr & - & ) - -! =================================================================== ! -! ! -! getozn sets up climatological ozone profile for radiation calculation! -! ! -! this code is originally written By Shrinivas Moorthi ! -! ! -! modified to make output o3mmr has same vertical index order as given ! -! by input flag 'iflip' --- Apr. 03, y-t hou ! -! ! -! inputs: ! -! prslk (IMAX,LM) - pressure in cb (kPa) ! -! xlat (IMAX) - latitude in radians ! -! k1oz, k2oz - ozone data interpolation indices ! -! facoz - ozone data interpolation factor ! -! IMAX, LM - horizontal and vertical dimensions ! -! iflip - control flag for direction of vertical index ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! ! -! outputs: ! -! o3mmr (IMAX,LM) - output ozone profile in mass mixing ratio (g/g)! -! ! -! usage: call getozn ! -! ! -! external function called : fpkap ! -! ! -! =================================================================== ! -! - implicit none - -! --- inputs: - integer, intent(in) :: IMAX, LM, k1oz, k2oz, iflip - - real (kind=kind_phys), intent(in) :: prslk(:,:), xlat(:), facoz - -! --- outputs: - real (kind=kind_phys), intent(out) :: o3mmr(:,:) - -! --- locals: -! integer :: JMR, blte, dlte, LOZ -! 4X5 ozone data -! parameter (JMR=45, blte=-86.0, dlte=4.0) -! GEOS ozone data -! parameter (JMR=18, blte=-85.0, dlte=10.0, LOZ=17) -! - real (kind=kind_io4) :: o3clim4(JMR,LOZ,12), pstr4(LOZ) - - real (kind=kind_phys), allocatable :: pstr(:), pkstr(:), & - & o3r(:,:,:) - real (kind=kind_phys) :: o3i(IMAX,LOZ), wk1(IMAX), deglat, elte, & - & rdg, tem, tem1, tem2, tem3, tem4, temp - - integer :: imond(12), ilat(JMR,12) - integer :: i, j, k, l, nm, j1, j2, ll - - logical :: first -! - data first / .true. / - - save first, pkstr, pstr, o3r, elte -! - - if (first) then - - if (timeozc .ne. 12) then - print *,' timeozc=',timeozc, ' is not monthly mean' & - &,' - job aborting' -! jbao new gfs physics - stop -! call mpi_quit(999) - endif -! - allocate (pstr(LOZ), pkstr(LOZ), o3r(JMR,LOZ,timeozc)) - rewind NIO3CLM - elte = blte + (JMR-1) * dlte - - if (LOZ == 17) then ! For the operational ozone climatology - do l = 1, LOZ - read(NIO3CLM,15) pstr4(l) - 15 format(f10.3) - enddo - - do nm = 1, 12 - do j = 1, JMR - read(NIO3CLM,19) imond(nm),ilat(j,nm), & - & (o3clim4(j,l,nm),l=1,10) - 19 format(i2,i4,10f6.2) - read(NIO3CLM,20) (o3clim4(j,l,nm), l=11,LOZ) - 20 format(6x,10f6.2) - enddo - enddo - else ! For newer ozone climatology - read (NIO3CLM) - do l=1,loz - READ (NIO3CLM) pstr4(l) - enddo - - do nm = 1, 12 - do l=1,loz - read(NIO3CLM) (o3clim4(j,l,nm),j=1,jmr) - enddo - enddo - endif -! - pstr = pstr4 - o3r = o3clim4 - - do nm = 1, 12 - do l = 1, LOZ - do j = 1, JMR - o3r(j,l,nm) = o3r(j,l,nm) * 1.655e-6 - enddo - enddo - enddo - - print *,' FOUND OZONE DATA FOR LEVELS PSTR=',(pstr(l),l=1,LOZ) -! print *,' O3=',(o3r(15,l,1),l=1,LOZ) - - do l = 1, LOZ - pkstr(l) = fpkap(pstr(l)*100.0) - enddo - - first = .false. - endif -! - do i = 1, IMAX - deglat = xlat(i) * raddeg - - if (deglat > blte .and. deglat < elte) then - tem1 = (deglat - blte) / dlte + 1 - j1 = tem1 - j2 = j1 + 1 - tem1 = tem1 - j1 - elseif (deglat <= blte) then - j1 = 1 - j2 = 1 - tem1 = 1.0 - elseif (deglat >= elte) then - j1 = JMR - j2 = JMR - tem1 = 1.0 - endif - - tem2 = 1.0 - tem1 - do j = 1, LOZ - tem3 = tem2*o3r(j1,j,k1oz) + tem1*o3r(j2,j,k1oz) - tem4 = tem2*o3r(j1,j,k2oz) + tem1*o3r(j2,j,k2oz) - o3i(i,j) = tem4*facoz + tem3*(1.0 - facoz) - enddo - enddo - - do l = 1, LM - ll = l - if (iflip == 1) ll = LM -l + 1 - - do i = 1, IMAX - wk1(i) = prslk(i,ll) - enddo - - do k = 1, LOZ-1 - temp = 1.0 / (pkstr(k+1) - pkstr(k)) - - do i = 1, IMAX - if (wk1(i) > pkstr(k) .and. wk1(i) <= pkstr(k+1)) then - tem = (pkstr(k+1) - wk1(i)) * temp - o3mmr(I,ll) = tem * o3i(i,k) + (1.0 - tem) * o3i(i,k+1) - endif - enddo - enddo - - do i = 1, IMAX - if (wk1(i) > pkstr(LOZ)) o3mmr(i,ll) = o3i(i,LOZ) - if (wk1(i) < pkstr(1)) o3mmr(i,ll) = o3i(i,1) - enddo - enddo -! - return -!................................... - end subroutine getozn -!----------------------------------- - -! -!........................................! - end module module_radiation_gases ! -!========================================! diff --git a/src/fim/FIMsrc/fim/column/radiation_surface.f b/src/fim/FIMsrc/fim/column/radiation_surface.f deleted file mode 100644 index a54196b..0000000 --- a/src/fim/FIMsrc/fim/column/radiation_surface.f +++ /dev/null @@ -1,731 +0,0 @@ -!!! use Yang et al. (2008, JAMC) albedo dependence on surface albedo over land - - -!!!!! ========================================================== !!!!! -!!!!! 'module_radiation_surface' description !!!!! -!!!!! ========================================================== !!!!! -! ! -! this module sets up surface albedo for sw radiation and surface ! -! emissivity for lw radiation. ! -! ! -! ! -! in the module, the externally callabe subroutines are : ! -! ! -! 'sfcinit' -- initialization radiation surface data ! -! inputs: ! -! ( LMAX, iflip, IALB, IEMS, me ) ! -! outputs: ! -! (none) ! -! ! -! 'setalb' -- set up four-component surface albedoes ! -! inputs: ! -! (slmsk,snowf,sncovr,snoalb,zorlf,coszf,tsknf,tairf,hprif, ! -! alvsf,alnsf,alvwf,alnwf,facsf,facwf,fice,tisfc ! -! IMAX) ! -! outputs: ! -! (sfcalb) ! -! ! -! 'setemis' -- set up surface emissivity for lw radiation ! -! inputs: ! -! (xlon,xlat,slmsk,snowf,sncovr,zorlf,tsknf,tairf,hprif, ! -! IMAX) ! -! outputs: ! -! (sfcemis) ! -! ! -! external modules referenced: ! -! ! -! 'module machine' in 'machine.f' ! -! 'module physcons' in 'physcons.f' ! -! 'module module_iounitdef' in 'iounitdef.f' ! -! ! -! ! -! program history log: ! -! 1995 y.t. hou - created albaer.f (include albedo ! -! and aerosols calculations) ! -! nov 1997 y.t. hou - modified snow albedo ! -! jan 1998 y.t. hou - included grumbine's sea-ice scheme ! -! feb 1998 h.l. pan - seasonal interpolation in cycle ! -! mar 2000 y.t. hou - modified to use opac aerosol data ! -! apr 2003 y.t. hou - seperate albedo and aerosols into ! -! two subroutines, rewritten in f90 modulized form ! -! jan 2005 s. moorthi - xingren's sea-ice fraction added ! -! apr 2005 y.t. hou - revised module structure ! -! feb 2006 y.t. hou - add varying surface emissivity, ! -! modified sfc albedo structure for modis shceme ! -! Mar 2006 s. moorthi - added surface temp over ice fraction ! -! mar 2007 c. marshall & h. wei ! -! - added modis based sfc albedo scheme ! -! may 2007 y. hou & s. moorthi ! -! - fix bug in modis albedo over ocean ! -! aug 2007 h. wei & s. moorthi ! -! - fix bug in modis albedo over sea-ice ! -! aug 2007 y. hou - fix bug in emissivity over ocean in ! -! the modis scheme option ! -! ! -!!!!! ========================================================== !!!!! -!!!!! end descriptions !!!!! -!!!!! ========================================================== !!!!! - - -!========================================! - module module_radiation_surface ! -!........................................! -! - use machine, only : kind_phys - use physcons, only : con_t0c, con_ttp, con_pi & - &, con_tice - use module_iounitdef, only : NIRADSF -! - implicit none -! - private - -! --- constant parameters - - integer, parameter, public :: NF_ALBD = 4 ! num of sfc albedo components - - integer, parameter, public :: IMXEMS = 360 ! num of lon-pts in glb emis-type map - integer, parameter, public :: JMXEMS = 180 ! num of lat-pts in glb emis-type map - - real (kind=kind_phys), parameter :: my_zero = 0.0 - real (kind=kind_phys), parameter :: rad2dg= 180.0 / con_pi - -! --- global surface emissivity index array set up in 'sfcinit' - - integer, allocatable :: idxems(:,:) - - integer :: ialbflg = 0 - integer :: iemsflg = 0 -! - public sfcinit, setalb, setemis - -! ================= - contains -! ================= - - -!----------------------------------- - subroutine sfcinit & -!................................... - -! --- inputs: - & ( LMAX, iflip, IALB, IEMS, me ) -! --- outputs: ( none ) - -! =================================================================== ! -! ! -! this program is the initialization program for surface radiation ! -! related quantities (albedo, emissivity, etc.) ! -! ! -! program history log: ! -! feb. 2006 yu-tai hou - created ! -! ! -! usage: call sfcinit ! -! ! -! subprograms called: none ! -! ! -! ==================== defination of variables ==================== ! -! ! -! inputs: ! -! LMAX - model vertical layer dimension ! -! iflip - control flag for direction of vertical index ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! IALB - control flag for surface albedo schemes ! -! =0: climatology, based on surface veg types ! -! =1: ! -! IEMS - control flag for surface emissivity schemes ! -! =0: fixed value of 1.0 ! -! =1: varying value based on surface veg types ! -! me - print control flag ! -! ! -! outputs: (none) to module variables only ! -! ! -! ==================== end of description ===================== ! -! - implicit none - -! --- inputs: - integer, intent(in) :: LMAX, iflip, IALB, IEMS, me - -! --- outputs: ( none ) - -! --- locals: - integer :: i, k, ia, ja - logical :: file_exist - character :: cline*80, cfems*24 - - data cfems / 'sfc_emissivity_idx.txt ' / - -! -!===> ... begin here -! - -! --- ... initialization of surface albedo section - - ialbflg = IALB - - if ( IALB == 0 ) then - - if ( me == 0 ) then - print *,' - Using climatology surface albedo scheme for sw' - endif - - else if ( IALB == 1 ) then - - if ( me == 0 ) then - print *,' - Using MODIS based land surface albedo for sw' - endif - - else - print *,' !! ERROR in Albedo Scheme Setting, IALB=',IALB - stop - endif ! end if_IALB_block - -! --- ... initialization of surface emissivity section - - iemsflg = IEMS - - if ( IEMS == 0 ) then ! fixed sfc emis at 1.0 - - if ( me == 0 ) then - print *,' - Using Fixed Surface Emissivity = 1.0 for lw' - endif - - elseif ( IEMS == 1 ) then ! input sfc emiss type map - -! --- allocate data space - if ( .not. allocated(idxems) ) then - allocate ( idxems(IMXEMS,JMXEMS) ) - endif - -! --- check to see if requested emissivity data file existed - - inquire (file=cfems, exist=file_exist) - - if ( .not. file_exist ) then - if ( me == 0 ) then - print *,' - Using Varying Surface Emissivity for lw' - print *,' Requested data file "',cfems,'" not found!' - print *,' Change to fixed surface emissivity = 1.0 !' - endif - - iemsflg = 0 - else - open (NIRADSF,file=cfems,form='formatted',status='old') - rewind NIRADSF - - read (NIRADSF,12) cline - 12 format(a80) - - read (NIRADSF,14) idxems - 14 format(80i1) - - if ( me == 0 ) then - print *,' - Using Varying Surface Emissivity for lw' - print *,' Opened data file: ',cfems - print *, cline -!check print *,' CHECK: Sample emissivity index data' -! ia = IMXEMS / 5 -! ja = JMXEMS / 5 -! print *, idxems(1:IMXEMS:ia,1:JMXEMS:ja) - endif - endif ! end if_file_exist_block - - else - print *,' !! ERROR in Emissivity Scheme Setting, IEMS=',IEMS - stop - endif ! end if_IEMS_block - -! - return -!................................... - end subroutine sfcinit -!----------------------------------- - - -!----------------------------------- - subroutine setalb & -!................................... - -! --- inputs: - & ( slmsk,snowf,sncovr,snoalb,zorlf,coszf,tsknf,tairf,hprif, & - & alvsf,alnsf,alvwf,alnwf,facsf,facwf,fice,tisfc, & - & IMAX, & -! --- outputs: - & sfcalb & - & ) - -! =================================================================== ! -! ! -! this program computes four components of surface albedos (i.e. ! -! vis-nir, direct-diffused) according to controflag ialbflg. ! -! 1) climatological surface albedo scheme (briegleb 1992) ! -! 2) modis retrieval based scheme from boston univ. ! -! ! -! ! -! usage: call setalb ! -! ! -! subprograms called: none ! -! ! -! ==================== defination of variables ==================== ! -! ! -! inputs: ! -! slmsk (IMAX) - sea(0),land(1),ice(2) mask on fcst model grid ! -! snowf (IMAX) - snow depth water equivalent in mm ! -! sncovr(IMAX) - ialgflg=0: not used ! -! ialgflg=1: snow cover over land in fraction ! -! snoalb(IMAX) - ialbflg=0: not used ! -! ialgflg=1: max snow albedo over land in fraction ! -! zorlf (IMAX) - surface roughness in cm ! -! coszf (IMAX) - cosin of solar zenith angle ! -! tsknf (IMAX) - ground surface temperature in k ! -! tairf (IMAX) - lowest model layer air temperature in k ! -! hprif (IMAX) - topographic sdv in m ! -! --- for ialbflg=0 climtological albedo scheme --- ! -! alvsf (IMAX) - 60 degree vis albedo with strong cosz dependency ! -! alnsf (IMAX) - 60 degree nir albedo with strong cosz dependency ! -! alvwf (IMAX) - 60 degree vis albedo with weak cosz dependency ! -! alnwf (IMAX) - 60 degree nir albedo with weak cosz dependency ! -! --- for ialbflg=1 modis based land albedo scheme --- ! -! alvsf (IMAX) - visible black sky albedo at zenith 60 degree ! -! alnsf (IMAX) - near-ir black sky albedo at zenith 60 degree ! -! alvwf (IMAX) - visible white sky albedo ! -! alnwf (IMAX) - near-ir white sky albedo ! -! ! -! facsf (IMAX) - fractional coverage with strong cosz dependency ! -! facwf (IMAX) - fractional coverage with weak cosz dependency ! -! fice (IMAX) - sea-ice fraction ! -! tisfc (IMAX) - sea-ice surface temperature ! -! IMAX - array horizontal dimension ! -! ! -! outputs: ! -! sfcalb(IMAX,NF_ALBD) ! -! ( :, 1) - near ir direct beam albedo ! -! ( :, 2) - near ir diffused albedo ! -! ( :, 3) - uv+vis direct beam albedo ! -! ( :, 4) - uv+vis diffused albedo ! -! ! -! module internal control variables: ! -! ialbflg - =0 use the default climatology surface albedo ! -! =1 use modis retrieved albedo and input snow cover! -! for land areas ! -! ! -! ==================== end of description ===================== ! -! - implicit none - -! --- inputs - integer, intent(in) :: IMAX - - real (kind=kind_phys), dimension(:), intent(in) :: & - & slmsk, snowf, zorlf, coszf, tsknf, tairf, hprif, & - & alvsf, alnsf, alvwf, alnwf, facsf, facwf, fice, tisfc, & - & sncovr, snoalb - -! --- outputs - real (kind=kind_phys), dimension(:,:), intent(out) :: sfcalb - -! --- locals: - real (kind=kind_phys) :: asnvb, asnnb, asnvd, asnnd, asevb & - &, asenb, asevd, asend, fsno, fsea, rfcs, rfcw, flnd & - &, asnow, argh, hrgh, fsno0, fsno1, flnd0, fsea0, csnow & - &, a1, a2, b1, b2, b3 - - real (kind=kind_phys) ffw, dtgd - - integer :: i, k - -! -!===> ... begin here -! - - if ( ialbflg == 0 ) then ! use climatological albedo scheme - - do i = 1, IMAX - -! --- modified snow albedo scheme - units convert to m -! (originally snowf in mm; zorlf in cm) - - asnow = 0.02*snowf(i) - argh = min(0.50, max(.025, 0.01*zorlf(i))) - hrgh = min(1.0, max(0.20, 1.0577-1.1538e-3*hprif(i) ) ) - fsno0 = asnow / (argh + asnow) * hrgh - if (nint(slmsk(i)) == 0 .and. tsknf(i) > con_tice) fsno0 = 0.0 - fsno1 = 1.0 - fsno0 - flnd0 = min(1.0, facsf(i)+facwf(i)) - fsea0 = max(0.0, 1.0 - flnd0) - fsno = fsno0 - fsea = fsea0 * fsno1 - flnd = flnd0 * fsno1 - -! --- diffused sea surface albedo - - if (tsknf(i) >= 271.5) then - asevd = 0.06 - asend = 0.06 - elseif (tsknf(i) < 271.1) then - asevd = 0.70 - asend = 0.65 - else - a1 = (tsknf(i) - 271.1)**2 - asevd = 0.7 - 4.0*a1 - asend = 0.65 - 3.6875*a1 - endif - -! --- diffused snow albedo - - if (nint(slmsk(i)) == 2) then - ffw = 1.0 - fice(i) - if (ffw < 1.0) then - dtgd = max(0.0, min(5.0, (con_ttp-tisfc(i)) )) - b1 = 0.03 * dtgd - else - b1 = 0.0 - endif - - b3 = 0.06 * ffw - asnvd = (0.70 + b1) * fice(i) + b3 - asnnd = (0.60 + b1) * fice(i) + b3 - asevd = 0.70 * fice(i) + b3 - asend = 0.60 * fice(i) + b3 - else - asnvd = 0.90 - asnnd = 0.75 - endif - -! --- direct snow albedo - - if (coszf(i) < 0.5) then - csnow = 0.5 * (3.0 / (1.0+4.0*coszf(i)) - 1.0) - asnvb = min( 0.98, asnvd+(1.0-asnvd)*csnow ) - asnnb = min( 0.98, asnnd+(1.0-asnnd)*csnow ) - else - asnvb = asnvd - asnnb = asnnd - endif - -! --- direct sea surface albedo - - if (coszf(i) > 0.0001) then -! rfcs = 1.4 / (1.0 + 0.8*coszf(i)) -! rfcw = 1.3 / (1.0 + 0.6*coszf(i)) -! fanglin yang - rfcs = 2.14 / (1.0 + 1.48*coszf(i)) - rfcw = 2.14 / (1.0 + 1.48*coszf(i)) - - if (tsknf(i) >= con_t0c) then - asevb = max(asevd, 0.026/(coszf(i)**1.7+0.065) & - & + 0.15 * (coszf(i)-0.1) * (coszf(i)-0.5) & - & * (coszf(i)-1.0)) - asenb = asevb - else - asevb = asevd - asenb = asend - endif - else - rfcs = 1.0 - rfcw = 1.0 - asevb = asevd - asenb = asend - endif - - a1 = alvsf(i) * facsf(i) - b1 = alvwf(i) * facwf(i) - a2 = alnsf(i) * facsf(i) - b2 = alnwf(i) * facwf(i) - sfcalb(i,1) = (a2*rfcs+b2*rfcw)*flnd + asenb*fsea + asnnb*fsno - sfcalb(i,2) = (a2 + b2) * 0.96 *flnd + asend*fsea + asnnd*fsno - sfcalb(i,3) = (a1*rfcs+b1*rfcw)*flnd + asevb*fsea + asnvb*fsno - sfcalb(i,4) = (a1 + b1) * 0.96 *flnd + asevd*fsea + asnvd*fsno - - enddo ! end_do_i_loop - - else ! use modis based albedo for land area - - do i = 1, IMAX - -! --- snow cover input directly from land model, no conversion needed - - fsno0 = sncovr(i) - - if (nint(slmsk(i)) == 0 .and. tsknf(i) > con_tice) fsno0 = 0.0 - - if (nint(slmsk(i)) == 2) then - asnow = 0.02*snowf(i) - argh = min(0.50, max(.025, 0.01*zorlf(i))) - hrgh = min(1.0, max(0.20, 1.0577-1.1538e-3*hprif(i) ) ) - fsno0 = asnow / (argh + asnow) * hrgh - endif - - fsno1 = 1.0 - fsno0 - flnd0 = min(1.0, facsf(i)+facwf(i)) - fsea0 = max(0.0, 1.0 - flnd0) - fsno = fsno0 - fsea = fsea0 * fsno1 - flnd = flnd0 * fsno1 - -! --- diffused sea surface albedo - - if (tsknf(i) >= 271.5) then - asevd = 0.06 - asend = 0.06 - elseif (tsknf(i) < 271.1) then - asevd = 0.70 - asend = 0.65 - else - a1 = (tsknf(i) - 271.1)**2 - asevd = 0.7 - 4.0*a1 - asend = 0.65 - 3.6875*a1 - endif - -! --- diffused snow albedo, land area use input max snow albedo - - if (nint(slmsk(i)) == 2) then - ffw = 1.0 - fice(i) - if (ffw < 1.0) then - dtgd = max(0.0, min(5.0, (con_ttp-tisfc(i)) )) - b1 = 0.03 * dtgd - else - b1 = 0.0 - endif - - b3 = 0.06 * ffw - asnvd = (0.70 + b1) * fice(i) + b3 - asnnd = (0.60 + b1) * fice(i) + b3 - asevd = 0.70 * fice(i) + b3 - asend = 0.60 * fice(i) + b3 - else - asnvd = snoalb(i) - asnnd = snoalb(i) - endif - -! --- direct snow albedo - - if (nint(slmsk(i)) == 2) then - if (coszf(i) < 0.5) then - csnow = 0.5 * (3.0 / (1.0+4.0*coszf(i)) - 1.0) - asnvb = min( 0.98, asnvd+(1.0-asnvd)*csnow ) - asnnb = min( 0.98, asnnd+(1.0-asnnd)*csnow ) - else - asnvb = asnvd - asnnb = asnnd - endif - else - asnvb = snoalb(i) - asnnb = snoalb(i) - endif - -! --- direct sea surface albedo, use fanglin's zenith angle treatment - - if (coszf(i) > 0.0001) then - -! rfcs = 1.89 - 3.34*coszf(i) + 4.13*coszf(i)*coszf(i) & -! & - 2.02*coszf(i)*coszf(i)*coszf(i) - rfcs = 1.775/(1.0+1.55*coszf(i)) - - if (tsknf(i) >= con_t0c) then - asevb = max(asevd, 0.026/(coszf(i)**1.7+0.065) & - & + 0.15 * (coszf(i)-0.1) * (coszf(i)-0.5) & - & * (coszf(i)-1.0)) - asenb = asevb - else - asevb = asevd - asenb = asend - endif - else - rfcs = 1.0 - asevb = asevd - asenb = asend - endif - - sfcalb(i,1) = alnsf(i)*rfcs*flnd + asenb*fsea + asnnb*fsno - sfcalb(i,2) = alnwf(i) *flnd + asend*fsea + asnnd*fsno - sfcalb(i,3) = alvsf(i)*rfcs*flnd + asevb*fsea + asnvb*fsno - sfcalb(i,4) = alvwf(i) *flnd + asevd*fsea + asnvd*fsno - - enddo ! end_do_i_loop - - endif ! end if_ialbflg -! - return -!................................... - end subroutine setalb -!----------------------------------- - - -!----------------------------------- - subroutine setemis & -!................................... - -! --- inputs: - & ( xlon,xlat,slmsk,snowf,sncovr,zorlf,tsknf,tairf,hprif, & - & IMAX, & -! --- outputs: - & sfcemis & - & ) - -! =================================================================== ! -! ! -! this program computes surface emissivity for lw radiation. ! -! ! -! usage: call setemis ! -! ! -! subprograms called: none ! -! ! -! ==================== defination of variables ==================== ! -! ! -! inputs: ! -! xlon (IMAX) - longitude in radiance ! -! xlat (IMAX) - latitude in radiance ! -! slmsk (IMAX) - sea(0),land(1),ice(2) mask on fcst model grid ! -! snowf (IMAX) - snow depth water equivalent in mm ! -! sncovr(IMAX) - ialbflg=1: snow cover over land in fraction ! -! zorlf (IMAX) - surface roughness in cm ! -! tsknf (IMAX) - ground surface temperature in k ! -! tairf (IMAX) - lowest model layer air temperature in k ! -! hprif (IMAX) - topographic sdv in m ! -! IMAX - array horizontal dimension ! -! ! -! outputs: ! -! sfcemis(IMAX) - surface emissivity ! -! ! -! ------------------------------------------------------------------- ! -! ! -! surface type definations: ! -! 1. open water 2. grass/wood/shrub land ! -! 3. tundra/bare soil 4. sandy desert ! -! 5. rocky desert 6. forest ! -! 7. ice 8. snow ! -! ! -! input index data lon from 0 towards east, lat from n to s ! -! ! -! ==================== end of description ===================== ! -! - implicit none - -! --- inputs - integer, intent(in) :: IMAX - - real (kind=kind_phys), dimension(:), intent(in) :: & - & xlon,xlat, slmsk, snowf,sncovr, zorlf, tsknf, tairf, hprif - -! --- outputs - real (kind=kind_phys), dimension(:), intent(out) :: sfcemis - -! --- locals: - integer :: i, i1, i2, j1, j2, idx - - real (kind=kind_phys) :: dltg, hdlt, tmp1, tmp2, & - & asnow, argh, hrgh, fsno, fsno0, fsno1 - -! --- reference emiss value for diff surface emiss index -! 1-open water, 2-grass/shrub land, 3-bare soil, tundra, -! 4-sandy desert, 5-rocky desert, 6-forest, 7-ice, 8-snow - - real (kind=kind_phys) :: emsref(8) - data emsref / 0.97, 0.95, 0.94, 0.90, 0.93, 0.96, 0.96, 0.99 / - -! -!===> ... begin here -! - - if ( iemsflg == 0 ) then ! sfc emiss default to 1.0 - - sfcemis(:) = 1.0 - return - - else ! emiss set by sfc type and condition - - dltg = 360.0 / float(IMXEMS) - hdlt = 0.5 * dltg - -! --- ... mapping input data onto model grid -! note: this is a simple mapping method, an upgrade is needed if -! the model grid is much corcer than the 1-deg data resolution - - lab_do_IMAX : do i = 1, IMAX - - if ( nint(slmsk(i)) == 0 ) then ! sea point - - sfcemis(i) = emsref(1) - - else if ( nint(slmsk(i)) == 2 ) then ! sea-ice - - sfcemis(i) = emsref(7) - - else ! land - -! --- map grid in longitude direction - i2 = 1 - j2 = 1 - - tmp1 = xlon(i) * rad2dg - if (tmp1 < my_zero) tmp1 = tmp1 + 360.0 - - lab_do_IMXEMS : do i1 = 1, IMXEMS - tmp2 = dltg * (i1 - 1) + hdlt - - if (abs(tmp1-tmp2) <= hdlt) then - i2 = i1 - exit lab_do_IMXEMS - endif - enddo lab_do_IMXEMS - -! --- map grid in latitude direction - tmp1 = xlat(i) * rad2dg - - lab_do_JMXEMS : do j1 = 1, JMXEMS - tmp2 = 90.0 - dltg * (j1 - 1) - - if (abs(tmp1-tmp2) <= hdlt) then - j2 = j1 - exit lab_do_JMXEMS - endif - enddo lab_do_JMXEMS - - - idx = max( 2, idxems(i2,j2) ) - if ( idx >= 7 ) idx = 2 - sfcemis(i) = emsref(idx) - - endif ! end if_slmsk_block - -! --- check for snow covered area - - if ( ialbflg==1 .and. nint(slmsk(i))==1 ) then ! input land area snow cover - - fsno0 = sncovr(i) - fsno1 = 1.0 - fsno0 - sfcemis(i) = sfcemis(i)*fsno1 + emsref(8)*fsno0 - - else ! compute snow cover from snow depth - if ( snowf(i) > my_zero ) then - asnow = 0.02*snowf(i) - argh = min(0.50, max(.025, 0.01*zorlf(i))) - hrgh = min(1.0, max(0.20, 1.0577-1.1538e-3*hprif(i) ) ) - fsno0 = asnow / (argh + asnow) * hrgh - if (nint(slmsk(i)) == 0 .and. tsknf(i) > 271.2) & - & fsno0=my_zero - fsno1 = 1.0 - fsno0 - sfcemis(i) = sfcemis(i)*fsno1 + emsref(8)*fsno0 - endif - - endif ! end if_ialbflg - - enddo lab_do_IMAX - - endif ! end if_iemsflg_block - -!chk print *,' In setemis, iemsflg, sfcemis =',iemsflg,sfcemis - -! - return -!................................... - end subroutine setemis -!----------------------------------- - -! -!.........................................! - end module module_radiation_surface ! -!=========================================! diff --git a/src/fim/FIMsrc/fim/column/radlw_datatb.f b/src/fim/FIMsrc/fim/column/radlw_datatb.f deleted file mode 100644 index be8ef2c..0000000 --- a/src/fim/FIMsrc/fim/column/radlw_datatb.f +++ /dev/null @@ -1,29531 +0,0 @@ -!!!!! ========================================================== !!!!! -!!!!! rrtm1 radiation package description !!!!! -!!!!! ========================================================== !!!!! -! ! -! the rrtm1 package includes these parts: ! -! ! -! 'radlw_rrtm1_param.f' ! -! 'radlw_rrtm1_datatb.f' ! -! 'radlw_rrtm1_main.f' ! -! ! -! the 'radlw_rrtm1_param.f' contains: ! -! ! -! 'module_radlw_cntr_para' -- control parameters set up ! -! 'module_radlw_parameters' -- band parameters set up ! -! ! -! the 'radlw_rrtm1_datatb.f' contains: ! -! ! -! 'module_radlw_avplank' -- plank flux data ! -! 'module_radlw_cldprlw' -- cloud property coefficients ! -! 'module_radlw_kgbnn' -- absorption coeffients for 16 ! -! bands, where nn = 01-16 ! -! ! -! the 'radlw_rrtm1_main.f' contains: ! -! ! -! 'module_radlw_main' -- main lw radiation transfer ! -! ! -! in the main module 'module_radlw_main' there are only two ! -! externally callable subroutines: ! -! ! -! ! -! 'lwrad -- main rrtm1 lw radiation routine ! -! 'rlwinit' -- to initialize rrtm1 lw radiation ! -! ! -! all the lw radiation subprograms become contained subprograms ! -! in module 'module_radlw_main' and many of them are not directly ! -! accessable from places outside the module. ! -! ! -! compilation sequence is: ! -! ! -! 'radlw_rrtm1_param,f' ! -! 'radlw_rrtm1_datatb,f' ! -! 'radlw_rrtm1_main.f' ! -! ! -! and all should be put in front of routines that use lw modules ! -! ! -! ! -! ! -! the original program declarations: ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Copyright 2002, 2003, Atmospheric & Environmental Research, Inc.(AER)! -! This software may be used, copied, or redistributed as long as it is ! -! not sold and this copyright notice is reproduced on each copy made. ! -! This model is provided as is without any express or implied warranties -! (http://www.rtweb.aer.com/) ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! rrtm ! -! ! -! rapid radiative transfer model ! -! ! -! atmospheric and environmental research, inc. ! -! 840 memorial drive ! -! cambridge, ma 02139 ! -! ! -! eli j. mlawer ! -! steven j. taubman~ ! -! shepard a. clough ! -! ! -! ~currently at gfdl ! -! ! -! email: mlawer@aer.com ! -! ! -! the authors wish to acknowledge the contributions of the ! -! following people: patrick d. brown, michael j. iacono, ! -! ronald e. farren, luke chen, robert bergstrom. ! -! ! -! ! -!!!!! ========================================================== !!!!! -!!!!! end descriptions !!!!! -!!!!! ========================================================== !!!!! - - - -!========================================! - module module_radlw_avplank ! -!........................................! -! - use machine, only : kind_phys - use module_radlw_parameters, only : NPLNK, NBANDS -! - implicit none -! - private - - real (kind=kind_phys), public :: totplnk(NPLNK,NBANDS) - - data totplnk( 1: 50, 1) / & - &1.13735E-06,1.15150E-06,1.16569E-06,1.17992E-06,1.19419E-06, & - &1.20850E-06,1.22285E-06,1.23723E-06,1.25164E-06,1.26610E-06, & - &1.28059E-06,1.29511E-06,1.30967E-06,1.32426E-06,1.33889E-06, & - &1.35355E-06,1.36824E-06,1.38296E-06,1.39772E-06,1.41250E-06, & - &1.42732E-06,1.44217E-06,1.45704E-06,1.47195E-06,1.48689E-06, & - &1.50185E-06,1.51684E-06,1.53186E-06,1.54691E-06,1.56198E-06, & - &1.57709E-06,1.59222E-06,1.60737E-06,1.62255E-06,1.63776E-06, & - &1.65299E-06,1.66825E-06,1.68352E-06,1.69883E-06,1.71416E-06, & - &1.72951E-06,1.74488E-06,1.76028E-06,1.77570E-06,1.79114E-06, & - &1.80661E-06,1.82210E-06,1.83760E-06,1.85313E-06,1.86868E-06/ - data totplnk( 51:100, 1) / & - &1.88425E-06,1.89985E-06,1.91546E-06,1.93109E-06,1.94674E-06, & - &1.96241E-06,1.97811E-06,1.99381E-06,2.00954E-06,2.02529E-06, & - &2.04105E-06,2.05684E-06,2.07264E-06,2.08846E-06,2.10429E-06, & - &2.12015E-06,2.13602E-06,2.15190E-06,2.16781E-06,2.18373E-06, & - &2.19966E-06,2.21562E-06,2.23159E-06,2.24758E-06,2.26358E-06, & - &2.27959E-06,2.29562E-06,2.31167E-06,2.32773E-06,2.34381E-06, & - &2.35990E-06,2.37601E-06,2.39212E-06,2.40825E-06,2.42440E-06, & - &2.44056E-06,2.45673E-06,2.47292E-06,2.48912E-06,2.50533E-06, & - &2.52157E-06,2.53781E-06,2.55406E-06,2.57032E-06,2.58660E-06, & - &2.60289E-06,2.61919E-06,2.63550E-06,2.65183E-06,2.66817E-06/ - data totplnk(101:150, 1) / & - &2.68452E-06,2.70088E-06,2.71726E-06,2.73364E-06,2.75003E-06, & - &2.76644E-06,2.78286E-06,2.79929E-06,2.81572E-06,2.83218E-06, & - &2.84864E-06,2.86510E-06,2.88159E-06,2.89807E-06,2.91458E-06, & - &2.93109E-06,2.94762E-06,2.96415E-06,2.98068E-06,2.99724E-06, & - &3.01379E-06,3.03036E-06,3.04693E-06,3.06353E-06,3.08013E-06, & - &3.09674E-06,3.11335E-06,3.12998E-06,3.14661E-06,3.16324E-06, & - &3.17989E-06,3.19656E-06,3.21323E-06,3.22991E-06,3.24658E-06, & - &3.26328E-06,3.27998E-06,3.29669E-06,3.31341E-06,3.33013E-06, & - &3.34686E-06,3.36360E-06,3.38034E-06,3.39709E-06,3.41387E-06, & - &3.43063E-06,3.44742E-06,3.46420E-06,3.48099E-06,3.49779E-06/ - data totplnk(151:181, 1) / & - &3.51461E-06,3.53141E-06,3.54824E-06,3.56506E-06,3.58191E-06, & - &3.59875E-06,3.61559E-06,3.63244E-06,3.64931E-06,3.66617E-06, & - &3.68305E-06,3.69992E-06,3.71682E-06,3.73372E-06,3.75061E-06, & - &3.76753E-06,3.78443E-06,3.80136E-06,3.81829E-06,3.83522E-06, & - &3.85215E-06,3.86910E-06,3.88605E-06,3.90301E-06,3.91997E-06, & - &3.93694E-06,3.95390E-06,3.97087E-06,3.98788E-06,4.00485E-06, & - &4.02187E-06/ - data totplnk( 1: 50, 2) / & - &2.13441E-06,2.18076E-06,2.22758E-06,2.27489E-06,2.32268E-06, & - &2.37093E-06,2.41966E-06,2.46886E-06,2.51852E-06,2.56864E-06, & - &2.61922E-06,2.67026E-06,2.72175E-06,2.77370E-06,2.82609E-06, & - &2.87893E-06,2.93221E-06,2.98593E-06,3.04008E-06,3.09468E-06, & - &3.14970E-06,3.20515E-06,3.26103E-06,3.31732E-06,3.37404E-06, & - &3.43118E-06,3.48873E-06,3.54669E-06,3.60506E-06,3.66383E-06, & - &3.72301E-06,3.78259E-06,3.84256E-06,3.90293E-06,3.96368E-06, & - &4.02483E-06,4.08636E-06,4.14828E-06,4.21057E-06,4.27324E-06, & - &4.33629E-06,4.39971E-06,4.46350E-06,4.52765E-06,4.59217E-06, & - &4.65705E-06,4.72228E-06,4.78787E-06,4.85382E-06,4.92011E-06/ - data totplnk( 51:100, 2) / & - &4.98675E-06,5.05374E-06,5.12106E-06,5.18873E-06,5.25674E-06, & - &5.32507E-06,5.39374E-06,5.46274E-06,5.53207E-06,5.60172E-06, & - &5.67169E-06,5.74198E-06,5.81259E-06,5.88352E-06,5.95475E-06, & - &6.02629E-06,6.09815E-06,6.17030E-06,6.24276E-06,6.31552E-06, & - &6.38858E-06,6.46192E-06,6.53557E-06,6.60950E-06,6.68373E-06, & - &6.75824E-06,6.83303E-06,6.90810E-06,6.98346E-06,7.05909E-06, & - &7.13500E-06,7.21117E-06,7.28763E-06,7.36435E-06,7.44134E-06, & - &7.51859E-06,7.59611E-06,7.67388E-06,7.75192E-06,7.83021E-06, & - &7.90875E-06,7.98755E-06,8.06660E-06,8.14589E-06,8.22544E-06, & - &8.30522E-06,8.38526E-06,8.46553E-06,8.54604E-06,8.62679E-06/ - data totplnk(101:150, 2) / & - &8.70777E-06,8.78899E-06,8.87043E-06,8.95211E-06,9.03402E-06, & - &9.11616E-06,9.19852E-06,9.28109E-06,9.36390E-06,9.44692E-06, & - &9.53015E-06,9.61361E-06,9.69729E-06,9.78117E-06,9.86526E-06, & - &9.94957E-06,1.00341E-05,1.01188E-05,1.02037E-05,1.02888E-05, & - &1.03742E-05,1.04597E-05,1.05454E-05,1.06313E-05,1.07175E-05, & - &1.08038E-05,1.08903E-05,1.09770E-05,1.10639E-05,1.11509E-05, & - &1.12382E-05,1.13257E-05,1.14133E-05,1.15011E-05,1.15891E-05, & - &1.16773E-05,1.17656E-05,1.18542E-05,1.19429E-05,1.20317E-05, & - &1.21208E-05,1.22100E-05,1.22994E-05,1.23890E-05,1.24787E-05, & - &1.25686E-05,1.26587E-05,1.27489E-05,1.28393E-05,1.29299E-05/ - data totplnk(151:181, 2) / & - &1.30206E-05,1.31115E-05,1.32025E-05,1.32937E-05,1.33850E-05, & - &1.34765E-05,1.35682E-05,1.36600E-05,1.37520E-05,1.38441E-05, & - &1.39364E-05,1.40288E-05,1.41213E-05,1.42140E-05,1.43069E-05, & - &1.43999E-05,1.44930E-05,1.45863E-05,1.46797E-05,1.47733E-05, & - &1.48670E-05,1.49608E-05,1.50548E-05,1.51489E-05,1.52431E-05, & - &1.53375E-05,1.54320E-05,1.55267E-05,1.56214E-05,1.57164E-05, & - &1.58114E-05/ - data totplnk( 1: 50, 3) / & - &1.34822E-06,1.39134E-06,1.43530E-06,1.48010E-06,1.52574E-06, & - &1.57222E-06,1.61956E-06,1.66774E-06,1.71678E-06,1.76666E-06, & - &1.81741E-06,1.86901E-06,1.92147E-06,1.97479E-06,2.02898E-06, & - &2.08402E-06,2.13993E-06,2.19671E-06,2.25435E-06,2.31285E-06, & - &2.37222E-06,2.43246E-06,2.49356E-06,2.55553E-06,2.61837E-06, & - &2.68207E-06,2.74664E-06,2.81207E-06,2.87837E-06,2.94554E-06, & - &3.01356E-06,3.08245E-06,3.15221E-06,3.22282E-06,3.29429E-06, & - &3.36662E-06,3.43982E-06,3.51386E-06,3.58876E-06,3.66451E-06, & - &3.74112E-06,3.81857E-06,3.89688E-06,3.97602E-06,4.05601E-06, & - &4.13685E-06,4.21852E-06,4.30104E-06,4.38438E-06,4.46857E-06/ - data totplnk( 51:100, 3) / & - &4.55358E-06,4.63943E-06,4.72610E-06,4.81359E-06,4.90191E-06, & - &4.99105E-06,5.08100E-06,5.17176E-06,5.26335E-06,5.35573E-06, & - &5.44892E-06,5.54292E-06,5.63772E-06,5.73331E-06,5.82970E-06, & - &5.92688E-06,6.02485E-06,6.12360E-06,6.22314E-06,6.32346E-06, & - &6.42455E-06,6.52641E-06,6.62906E-06,6.73247E-06,6.83664E-06, & - &6.94156E-06,7.04725E-06,7.15370E-06,7.26089E-06,7.36883E-06, & - &7.47752E-06,7.58695E-06,7.69712E-06,7.80801E-06,7.91965E-06, & - &8.03201E-06,8.14510E-06,8.25891E-06,8.37343E-06,8.48867E-06, & - &8.60463E-06,8.72128E-06,8.83865E-06,8.95672E-06,9.07548E-06, & - &9.19495E-06,9.31510E-06,9.43594E-06,9.55745E-06,9.67966E-06/ - data totplnk(101:150, 3) / & - &9.80254E-06,9.92609E-06,1.00503E-05,1.01752E-05,1.03008E-05, & - &1.04270E-05,1.05539E-05,1.06814E-05,1.08096E-05,1.09384E-05, & - &1.10679E-05,1.11980E-05,1.13288E-05,1.14601E-05,1.15922E-05, & - &1.17248E-05,1.18581E-05,1.19920E-05,1.21265E-05,1.22616E-05, & - &1.23973E-05,1.25337E-05,1.26706E-05,1.28081E-05,1.29463E-05, & - &1.30850E-05,1.32243E-05,1.33642E-05,1.35047E-05,1.36458E-05, & - &1.37875E-05,1.39297E-05,1.40725E-05,1.42159E-05,1.43598E-05, & - &1.45044E-05,1.46494E-05,1.47950E-05,1.49412E-05,1.50879E-05, & - &1.52352E-05,1.53830E-05,1.55314E-05,1.56803E-05,1.58297E-05, & - &1.59797E-05,1.61302E-05,1.62812E-05,1.64327E-05,1.65848E-05/ - data totplnk(151:181, 3) / & - &1.67374E-05,1.68904E-05,1.70441E-05,1.71982E-05,1.73528E-05, & - &1.75079E-05,1.76635E-05,1.78197E-05,1.79763E-05,1.81334E-05, & - &1.82910E-05,1.84491E-05,1.86076E-05,1.87667E-05,1.89262E-05, & - &1.90862E-05,1.92467E-05,1.94076E-05,1.95690E-05,1.97309E-05, & - &1.98932E-05,2.00560E-05,2.02193E-05,2.03830E-05,2.05472E-05, & - &2.07118E-05,2.08768E-05,2.10423E-05,2.12083E-05,2.13747E-05, & - &2.15414E-05/ - data totplnk( 1: 50, 4) / & - &8.90528E-07,9.24222E-07,9.58757E-07,9.94141E-07,1.03038E-06, & - &1.06748E-06,1.10545E-06,1.14430E-06,1.18403E-06,1.22465E-06, & - &1.26618E-06,1.30860E-06,1.35193E-06,1.39619E-06,1.44136E-06, & - &1.48746E-06,1.53449E-06,1.58246E-06,1.63138E-06,1.68124E-06, & - &1.73206E-06,1.78383E-06,1.83657E-06,1.89028E-06,1.94495E-06, & - &2.00060E-06,2.05724E-06,2.11485E-06,2.17344E-06,2.23303E-06, & - &2.29361E-06,2.35519E-06,2.41777E-06,2.48134E-06,2.54592E-06, & - &2.61151E-06,2.67810E-06,2.74571E-06,2.81433E-06,2.88396E-06, & - &2.95461E-06,3.02628E-06,3.09896E-06,3.17267E-06,3.24741E-06, & - &3.32316E-06,3.39994E-06,3.47774E-06,3.55657E-06,3.63642E-06/ - data totplnk( 51:100, 4) / & - &3.71731E-06,3.79922E-06,3.88216E-06,3.96612E-06,4.05112E-06, & - &4.13714E-06,4.22419E-06,4.31227E-06,4.40137E-06,4.49151E-06, & - &4.58266E-06,4.67485E-06,4.76806E-06,4.86229E-06,4.95754E-06, & - &5.05383E-06,5.15113E-06,5.24946E-06,5.34879E-06,5.44916E-06, & - &5.55053E-06,5.65292E-06,5.75632E-06,5.86073E-06,5.96616E-06, & - &6.07260E-06,6.18003E-06,6.28848E-06,6.39794E-06,6.50838E-06, & - &6.61983E-06,6.73229E-06,6.84573E-06,6.96016E-06,7.07559E-06, & - &7.19200E-06,7.30940E-06,7.42779E-06,7.54715E-06,7.66749E-06, & - &7.78882E-06,7.91110E-06,8.03436E-06,8.15859E-06,8.28379E-06, & - &8.40994E-06,8.53706E-06,8.66515E-06,8.79418E-06,8.92416E-06/ - data totplnk(101:150, 4) / & - &9.05510E-06,9.18697E-06,9.31979E-06,9.45356E-06,9.58826E-06, & - &9.72389E-06,9.86046E-06,9.99793E-06,1.01364E-05,1.02757E-05, & - &1.04159E-05,1.05571E-05,1.06992E-05,1.08422E-05,1.09861E-05, & - &1.11309E-05,1.12766E-05,1.14232E-05,1.15707E-05,1.17190E-05, & - &1.18683E-05,1.20184E-05,1.21695E-05,1.23214E-05,1.24741E-05, & - &1.26277E-05,1.27822E-05,1.29376E-05,1.30939E-05,1.32509E-05, & - &1.34088E-05,1.35676E-05,1.37273E-05,1.38877E-05,1.40490E-05, & - &1.42112E-05,1.43742E-05,1.45380E-05,1.47026E-05,1.48680E-05, & - &1.50343E-05,1.52014E-05,1.53692E-05,1.55379E-05,1.57074E-05, & - &1.58778E-05,1.60488E-05,1.62207E-05,1.63934E-05,1.65669E-05/ - data totplnk(151:181, 4) / & - &1.67411E-05,1.69162E-05,1.70920E-05,1.72685E-05,1.74459E-05, & - &1.76240E-05,1.78029E-05,1.79825E-05,1.81629E-05,1.83440E-05, & - &1.85259E-05,1.87086E-05,1.88919E-05,1.90760E-05,1.92609E-05, & - &1.94465E-05,1.96327E-05,1.98199E-05,2.00076E-05,2.01961E-05, & - &2.03853E-05,2.05752E-05,2.07658E-05,2.09571E-05,2.11491E-05, & - &2.13418E-05,2.15352E-05,2.17294E-05,2.19241E-05,2.21196E-05, & - &2.23158E-05/ - data totplnk( 1:50, 5) / & - &5.70230E-07,5.94788E-07,6.20085E-07,6.46130E-07,6.72936E-07, & - &7.00512E-07,7.28869E-07,7.58019E-07,7.87971E-07,8.18734E-07, & - &8.50320E-07,8.82738E-07,9.15999E-07,9.50110E-07,9.85084E-07, & - &1.02093E-06,1.05765E-06,1.09527E-06,1.13378E-06,1.17320E-06, & - &1.21353E-06,1.25479E-06,1.29698E-06,1.34011E-06,1.38419E-06, & - &1.42923E-06,1.47523E-06,1.52221E-06,1.57016E-06,1.61910E-06, & - &1.66904E-06,1.71997E-06,1.77192E-06,1.82488E-06,1.87886E-06, & - &1.93387E-06,1.98991E-06,2.04699E-06,2.10512E-06,2.16430E-06, & - &2.22454E-06,2.28584E-06,2.34821E-06,2.41166E-06,2.47618E-06, & - &2.54178E-06,2.60847E-06,2.67626E-06,2.74514E-06,2.81512E-06/ - data totplnk( 51:100, 5) / & - &2.88621E-06,2.95841E-06,3.03172E-06,3.10615E-06,3.18170E-06, & - &3.25838E-06,3.33618E-06,3.41511E-06,3.49518E-06,3.57639E-06, & - &3.65873E-06,3.74221E-06,3.82684E-06,3.91262E-06,3.99955E-06, & - &4.08763E-06,4.17686E-06,4.26725E-06,4.35880E-06,4.45150E-06, & - &4.54537E-06,4.64039E-06,4.73659E-06,4.83394E-06,4.93246E-06, & - &5.03215E-06,5.13301E-06,5.23504E-06,5.33823E-06,5.44260E-06, & - &5.54814E-06,5.65484E-06,5.76272E-06,5.87177E-06,5.98199E-06, & - &6.09339E-06,6.20596E-06,6.31969E-06,6.43460E-06,6.55068E-06, & - &6.66793E-06,6.78636E-06,6.90595E-06,7.02670E-06,7.14863E-06, & - &7.27173E-06,7.39599E-06,7.52142E-06,7.64802E-06,7.77577E-06/ - data totplnk(101:150, 5) / & - &7.90469E-06,8.03477E-06,8.16601E-06,8.29841E-06,8.43198E-06, & - &8.56669E-06,8.70256E-06,8.83957E-06,8.97775E-06,9.11706E-06, & - &9.25753E-06,9.39915E-06,9.54190E-06,9.68580E-06,9.83085E-06, & - &9.97704E-06,1.01243E-05,1.02728E-05,1.04224E-05,1.05731E-05, & - &1.07249E-05,1.08779E-05,1.10320E-05,1.11872E-05,1.13435E-05, & - &1.15009E-05,1.16595E-05,1.18191E-05,1.19799E-05,1.21418E-05, & - &1.23048E-05,1.24688E-05,1.26340E-05,1.28003E-05,1.29676E-05, & - &1.31361E-05,1.33056E-05,1.34762E-05,1.36479E-05,1.38207E-05, & - &1.39945E-05,1.41694E-05,1.43454E-05,1.45225E-05,1.47006E-05, & - &1.48797E-05,1.50600E-05,1.52413E-05,1.54236E-05,1.56070E-05/ - data totplnk(151:181, 5) / & - &1.57914E-05,1.59768E-05,1.61633E-05,1.63509E-05,1.65394E-05, & - &1.67290E-05,1.69197E-05,1.71113E-05,1.73040E-05,1.74976E-05, & - &1.76923E-05,1.78880E-05,1.80847E-05,1.82824E-05,1.84811E-05, & - &1.86808E-05,1.88814E-05,1.90831E-05,1.92857E-05,1.94894E-05, & - &1.96940E-05,1.98996E-05,2.01061E-05,2.03136E-05,2.05221E-05, & - &2.07316E-05,2.09420E-05,2.11533E-05,2.13657E-05,2.15789E-05, & - &2.17931E-05/ - data totplnk( 1: 50, 6) / & - &2.73493E-07,2.87408E-07,3.01848E-07,3.16825E-07,3.32352E-07, & - &3.48439E-07,3.65100E-07,3.82346E-07,4.00189E-07,4.18641E-07, & - &4.37715E-07,4.57422E-07,4.77774E-07,4.98784E-07,5.20464E-07, & - &5.42824E-07,5.65879E-07,5.89638E-07,6.14115E-07,6.39320E-07, & - &6.65266E-07,6.91965E-07,7.19427E-07,7.47666E-07,7.76691E-07, & - &8.06516E-07,8.37151E-07,8.68607E-07,9.00896E-07,9.34029E-07, & - &9.68018E-07,1.00287E-06,1.03860E-06,1.07522E-06,1.11274E-06, & - &1.15117E-06,1.19052E-06,1.23079E-06,1.27201E-06,1.31418E-06, & - &1.35731E-06,1.40141E-06,1.44650E-06,1.49257E-06,1.53965E-06, & - &1.58773E-06,1.63684E-06,1.68697E-06,1.73815E-06,1.79037E-06/ - data totplnk( 51:100, 6) / & - &1.84365E-06,1.89799E-06,1.95341E-06,2.00991E-06,2.06750E-06, & - &2.12619E-06,2.18599E-06,2.24691E-06,2.30895E-06,2.37212E-06, & - &2.43643E-06,2.50189E-06,2.56851E-06,2.63628E-06,2.70523E-06, & - &2.77536E-06,2.84666E-06,2.91916E-06,2.99286E-06,3.06776E-06, & - &3.14387E-06,3.22120E-06,3.29975E-06,3.37953E-06,3.46054E-06, & - &3.54280E-06,3.62630E-06,3.71105E-06,3.79707E-06,3.88434E-06, & - &3.97288E-06,4.06270E-06,4.15380E-06,4.24617E-06,4.33984E-06, & - &4.43479E-06,4.53104E-06,4.62860E-06,4.72746E-06,4.82763E-06, & - &4.92911E-06,5.03191E-06,5.13603E-06,5.24147E-06,5.34824E-06, & - &5.45634E-06,5.56578E-06,5.67656E-06,5.78867E-06,5.90213E-06/ - data totplnk(101:150, 6) / & - &6.01694E-06,6.13309E-06,6.25060E-06,6.36947E-06,6.48968E-06, & - &6.61126E-06,6.73420E-06,6.85850E-06,6.98417E-06,7.11120E-06, & - &7.23961E-06,7.36938E-06,7.50053E-06,7.63305E-06,7.76694E-06, & - &7.90221E-06,8.03887E-06,8.17690E-06,8.31632E-06,8.45710E-06, & - &8.59928E-06,8.74282E-06,8.88776E-06,9.03409E-06,9.18179E-06, & - &9.33088E-06,9.48136E-06,9.63323E-06,9.78648E-06,9.94111E-06, & - &1.00971E-05,1.02545E-05,1.04133E-05,1.05735E-05,1.07351E-05, & - &1.08980E-05,1.10624E-05,1.12281E-05,1.13952E-05,1.15637E-05, & - &1.17335E-05,1.19048E-05,1.20774E-05,1.22514E-05,1.24268E-05, & - &1.26036E-05,1.27817E-05,1.29612E-05,1.31421E-05,1.33244E-05/ - data totplnk(151:181, 6) / & - &1.35080E-05,1.36930E-05,1.38794E-05,1.40672E-05,1.42563E-05, & - &1.44468E-05,1.46386E-05,1.48318E-05,1.50264E-05,1.52223E-05, & - &1.54196E-05,1.56182E-05,1.58182E-05,1.60196E-05,1.62223E-05, & - &1.64263E-05,1.66317E-05,1.68384E-05,1.70465E-05,1.72559E-05, & - &1.74666E-05,1.76787E-05,1.78921E-05,1.81069E-05,1.83230E-05, & - &1.85404E-05,1.87591E-05,1.89791E-05,1.92005E-05,1.94232E-05, & - &1.96471E-05/ - data totplnk( 1: 50, 7) / & - &1.25349E-07,1.32735E-07,1.40458E-07,1.48527E-07,1.56954E-07, & - &1.65748E-07,1.74920E-07,1.84481E-07,1.94443E-07,2.04814E-07, & - &2.15608E-07,2.26835E-07,2.38507E-07,2.50634E-07,2.63229E-07, & - &2.76301E-07,2.89864E-07,3.03930E-07,3.18508E-07,3.33612E-07, & - &3.49253E-07,3.65443E-07,3.82195E-07,3.99519E-07,4.17428E-07, & - &4.35934E-07,4.55050E-07,4.74785E-07,4.95155E-07,5.16170E-07, & - &5.37844E-07,5.60186E-07,5.83211E-07,6.06929E-07,6.31355E-07, & - &6.56498E-07,6.82373E-07,7.08990E-07,7.36362E-07,7.64501E-07, & - &7.93420E-07,8.23130E-07,8.53643E-07,8.84971E-07,9.17128E-07, & - &9.50123E-07,9.83969E-07,1.01868E-06,1.05426E-06,1.09073E-06/ - data totplnk( 51:100, 7) / & - &1.12810E-06,1.16638E-06,1.20558E-06,1.24572E-06,1.28680E-06, & - &1.32883E-06,1.37183E-06,1.41581E-06,1.46078E-06,1.50675E-06, & - &1.55374E-06,1.60174E-06,1.65078E-06,1.70087E-06,1.75200E-06, & - &1.80421E-06,1.85749E-06,1.91186E-06,1.96732E-06,2.02389E-06, & - &2.08159E-06,2.14040E-06,2.20035E-06,2.26146E-06,2.32372E-06, & - &2.38714E-06,2.45174E-06,2.51753E-06,2.58451E-06,2.65270E-06, & - &2.72210E-06,2.79272E-06,2.86457E-06,2.93767E-06,3.01201E-06, & - &3.08761E-06,3.16448E-06,3.24261E-06,3.32204E-06,3.40275E-06, & - &3.48476E-06,3.56808E-06,3.65271E-06,3.73866E-06,3.82595E-06, & - &3.91456E-06,4.00453E-06,4.09584E-06,4.18851E-06,4.28254E-06/ - data totplnk(101:150, 7) / & - &4.37796E-06,4.47475E-06,4.57293E-06,4.67249E-06,4.77346E-06, & - &4.87583E-06,4.97961E-06,5.08481E-06,5.19143E-06,5.29948E-06, & - &5.40896E-06,5.51989E-06,5.63226E-06,5.74608E-06,5.86136E-06, & - &5.97810E-06,6.09631E-06,6.21597E-06,6.33713E-06,6.45976E-06, & - &6.58388E-06,6.70950E-06,6.83661E-06,6.96521E-06,7.09531E-06, & - &7.22692E-06,7.36005E-06,7.49468E-06,7.63084E-06,7.76851E-06, & - &7.90773E-06,8.04846E-06,8.19072E-06,8.33452E-06,8.47985E-06, & - &8.62674E-06,8.77517E-06,8.92514E-06,9.07666E-06,9.22975E-06, & - &9.38437E-06,9.54057E-06,9.69832E-06,9.85762E-06,1.00185E-05, & - &1.01810E-05,1.03450E-05,1.05106E-05,1.06777E-05,1.08465E-05/ - data totplnk(151:181, 7) / & - &1.10168E-05,1.11887E-05,1.13621E-05,1.15372E-05,1.17138E-05, & - &1.18920E-05,1.20718E-05,1.22532E-05,1.24362E-05,1.26207E-05, & - &1.28069E-05,1.29946E-05,1.31839E-05,1.33749E-05,1.35674E-05, & - &1.37615E-05,1.39572E-05,1.41544E-05,1.43533E-05,1.45538E-05, & - &1.47558E-05,1.49595E-05,1.51647E-05,1.53716E-05,1.55800E-05, & - &1.57900E-05,1.60017E-05,1.62149E-05,1.64296E-05,1.66460E-05, & - &1.68640E-05/ - data totplnk( 1: 50, 8) / & - &6.74445E-08,7.18176E-08,7.64153E-08,8.12456E-08,8.63170E-08, & - &9.16378E-08,9.72168E-08,1.03063E-07,1.09184E-07,1.15591E-07, & - &1.22292E-07,1.29296E-07,1.36613E-07,1.44253E-07,1.52226E-07, & - &1.60540E-07,1.69207E-07,1.78236E-07,1.87637E-07,1.97421E-07, & - &2.07599E-07,2.18181E-07,2.29177E-07,2.40598E-07,2.52456E-07, & - &2.64761E-07,2.77523E-07,2.90755E-07,3.04468E-07,3.18673E-07, & - &3.33381E-07,3.48603E-07,3.64352E-07,3.80638E-07,3.97474E-07, & - &4.14871E-07,4.32841E-07,4.51395E-07,4.70547E-07,4.90306E-07, & - &5.10687E-07,5.31699E-07,5.53357E-07,5.75670E-07,5.98652E-07, & - &6.22315E-07,6.46672E-07,6.71731E-07,6.97511E-07,7.24018E-07/ - data totplnk( 51:100, 8) / & - &7.51266E-07,7.79269E-07,8.08038E-07,8.37584E-07,8.67922E-07, & - &8.99061E-07,9.31016E-07,9.63797E-07,9.97417E-07,1.03189E-06, & - &1.06722E-06,1.10343E-06,1.14053E-06,1.17853E-06,1.21743E-06, & - &1.25726E-06,1.29803E-06,1.33974E-06,1.38241E-06,1.42606E-06, & - &1.47068E-06,1.51630E-06,1.56293E-06,1.61056E-06,1.65924E-06, & - &1.70894E-06,1.75971E-06,1.81153E-06,1.86443E-06,1.91841E-06, & - &1.97350E-06,2.02968E-06,2.08699E-06,2.14543E-06,2.20500E-06, & - &2.26573E-06,2.32762E-06,2.39068E-06,2.45492E-06,2.52036E-06, & - &2.58700E-06,2.65485E-06,2.72393E-06,2.79424E-06,2.86580E-06, & - &2.93861E-06,3.01269E-06,3.08803E-06,3.16467E-06,3.24259E-06/ - data totplnk(101:150, 8) / & - &3.32181E-06,3.40235E-06,3.48420E-06,3.56739E-06,3.65192E-06, & - &3.73779E-06,3.82502E-06,3.91362E-06,4.00359E-06,4.09494E-06, & - &4.18768E-06,4.28182E-06,4.37737E-06,4.47434E-06,4.57273E-06, & - &4.67254E-06,4.77380E-06,4.87651E-06,4.98067E-06,5.08630E-06, & - &5.19339E-06,5.30196E-06,5.41201E-06,5.52356E-06,5.63660E-06, & - &5.75116E-06,5.86722E-06,5.98479E-06,6.10390E-06,6.22453E-06, & - &6.34669E-06,6.47042E-06,6.59569E-06,6.72252E-06,6.85090E-06, & - &6.98085E-06,7.11238E-06,7.24549E-06,7.38019E-06,7.51646E-06, & - &7.65434E-06,7.79382E-06,7.93490E-06,8.07760E-06,8.22192E-06, & - &8.36784E-06,8.51540E-06,8.66459E-06,8.81542E-06,8.96786E-06/ - data totplnk(151:181, 8) / & - &9.12197E-06,9.27772E-06,9.43513E-06,9.59419E-06,9.75490E-06, & - &9.91728E-06,1.00813E-05,1.02471E-05,1.04144E-05,1.05835E-05, & - &1.07543E-05,1.09267E-05,1.11008E-05,1.12766E-05,1.14541E-05, & - &1.16333E-05,1.18142E-05,1.19969E-05,1.21812E-05,1.23672E-05, & - &1.25549E-05,1.27443E-05,1.29355E-05,1.31284E-05,1.33229E-05, & - &1.35193E-05,1.37173E-05,1.39170E-05,1.41185E-05,1.43217E-05, & - &1.45267E-05/ - data totplnk( 1: 50, 9) / & - &2.61522E-08,2.80613E-08,3.00838E-08,3.22250E-08,3.44899E-08, & - &3.68841E-08,3.94129E-08,4.20820E-08,4.48973E-08,4.78646E-08, & - &5.09901E-08,5.42799E-08,5.77405E-08,6.13784E-08,6.52001E-08, & - &6.92126E-08,7.34227E-08,7.78375E-08,8.24643E-08,8.73103E-08, & - &9.23832E-08,9.76905E-08,1.03240E-07,1.09039E-07,1.15097E-07, & - &1.21421E-07,1.28020E-07,1.34902E-07,1.42075E-07,1.49548E-07, & - &1.57331E-07,1.65432E-07,1.73860E-07,1.82624E-07,1.91734E-07, & - &2.01198E-07,2.11028E-07,2.21231E-07,2.31818E-07,2.42799E-07, & - &2.54184E-07,2.65983E-07,2.78205E-07,2.90862E-07,3.03963E-07, & - &3.17519E-07,3.31541E-07,3.46039E-07,3.61024E-07,3.76507E-07/ - data totplnk( 51:100, 9) / & - &3.92498E-07,4.09008E-07,4.26050E-07,4.43633E-07,4.61769E-07, & - &4.80469E-07,4.99744E-07,5.19606E-07,5.40067E-07,5.61136E-07, & - &5.82828E-07,6.05152E-07,6.28120E-07,6.51745E-07,6.76038E-07, & - &7.01010E-07,7.26674E-07,7.53041E-07,7.80124E-07,8.07933E-07, & - &8.36482E-07,8.65781E-07,8.95845E-07,9.26683E-07,9.58308E-07, & - &9.90732E-07,1.02397E-06,1.05803E-06,1.09292E-06,1.12866E-06, & - &1.16526E-06,1.20274E-06,1.24109E-06,1.28034E-06,1.32050E-06, & - &1.36158E-06,1.40359E-06,1.44655E-06,1.49046E-06,1.53534E-06, & - &1.58120E-06,1.62805E-06,1.67591E-06,1.72478E-06,1.77468E-06, & - &1.82561E-06,1.87760E-06,1.93066E-06,1.98479E-06,2.04000E-06/ - data totplnk(101:150, 9) / & - &2.09631E-06,2.15373E-06,2.21228E-06,2.27196E-06,2.33278E-06, & - &2.39475E-06,2.45790E-06,2.52222E-06,2.58773E-06,2.65445E-06, & - &2.72238E-06,2.79152E-06,2.86191E-06,2.93354E-06,3.00643E-06, & - &3.08058E-06,3.15601E-06,3.23273E-06,3.31075E-06,3.39009E-06, & - &3.47074E-06,3.55272E-06,3.63605E-06,3.72072E-06,3.80676E-06, & - &3.89417E-06,3.98297E-06,4.07315E-06,4.16474E-06,4.25774E-06, & - &4.35217E-06,4.44802E-06,4.54532E-06,4.64406E-06,4.74428E-06, & - &4.84595E-06,4.94911E-06,5.05376E-06,5.15990E-06,5.26755E-06, & - &5.37671E-06,5.48741E-06,5.59963E-06,5.71340E-06,5.82871E-06, & - &5.94559E-06,6.06403E-06,6.18404E-06,6.30565E-06,6.42885E-06/ - data totplnk(151:181, 9) / & - &6.55364E-06,6.68004E-06,6.80806E-06,6.93771E-06,7.06898E-06, & - &7.20190E-06,7.33646E-06,7.47267E-06,7.61056E-06,7.75010E-06, & - &7.89133E-06,8.03423E-06,8.17884E-06,8.32514E-06,8.47314E-06, & - &8.62284E-06,8.77427E-06,8.92743E-06,9.08231E-06,9.23893E-06, & - &9.39729E-06,9.55741E-06,9.71927E-06,9.88291E-06,1.00483E-05, & - &1.02155E-05,1.03844E-05,1.05552E-05,1.07277E-05,1.09020E-05, & - &1.10781E-05/ - data totplnk( 1: 50,10) / & - &8.89300E-09,9.63263E-09,1.04235E-08,1.12685E-08,1.21703E-08, & - &1.31321E-08,1.41570E-08,1.52482E-08,1.64090E-08,1.76428E-08, & - &1.89533E-08,2.03441E-08,2.18190E-08,2.33820E-08,2.50370E-08, & - &2.67884E-08,2.86402E-08,3.05969E-08,3.26632E-08,3.48436E-08, & - &3.71429E-08,3.95660E-08,4.21179E-08,4.48040E-08,4.76294E-08, & - &5.05996E-08,5.37201E-08,5.69966E-08,6.04349E-08,6.40411E-08, & - &6.78211E-08,7.17812E-08,7.59276E-08,8.02670E-08,8.48059E-08, & - &8.95508E-08,9.45090E-08,9.96873E-08,1.05093E-07,1.10733E-07, & - &1.16614E-07,1.22745E-07,1.29133E-07,1.35786E-07,1.42711E-07, & - &1.49916E-07,1.57410E-07,1.65202E-07,1.73298E-07,1.81709E-07/ - data totplnk( 51:100,10) / & - &1.90441E-07,1.99505E-07,2.08908E-07,2.18660E-07,2.28770E-07, & - &2.39247E-07,2.50101E-07,2.61340E-07,2.72974E-07,2.85013E-07, & - &2.97467E-07,3.10345E-07,3.23657E-07,3.37413E-07,3.51623E-07, & - &3.66298E-07,3.81448E-07,3.97082E-07,4.13212E-07,4.29848E-07, & - &4.47000E-07,4.64680E-07,4.82898E-07,5.01664E-07,5.20991E-07, & - &5.40888E-07,5.61369E-07,5.82440E-07,6.04118E-07,6.26410E-07, & - &6.49329E-07,6.72887E-07,6.97095E-07,7.21964E-07,7.47506E-07, & - &7.73732E-07,8.00655E-07,8.28287E-07,8.56635E-07,8.85717E-07, & - &9.15542E-07,9.46122E-07,9.77469E-07,1.00960E-06,1.04251E-06, & - &1.07623E-06,1.11077E-06,1.14613E-06,1.18233E-06,1.21939E-06/ - data totplnk(101:150,10) / & - &1.25730E-06,1.29610E-06,1.33578E-06,1.37636E-06,1.41785E-06, & - &1.46027E-06,1.50362E-06,1.54792E-06,1.59319E-06,1.63942E-06, & - &1.68665E-06,1.73487E-06,1.78410E-06,1.83435E-06,1.88564E-06, & - &1.93797E-06,1.99136E-06,2.04582E-06,2.10137E-06,2.15801E-06, & - &2.21576E-06,2.27463E-06,2.33462E-06,2.39577E-06,2.45806E-06, & - &2.52153E-06,2.58617E-06,2.65201E-06,2.71905E-06,2.78730E-06, & - &2.85678E-06,2.92749E-06,2.99946E-06,3.07269E-06,3.14720E-06, & - &3.22299E-06,3.30007E-06,3.37847E-06,3.45818E-06,3.53923E-06, & - &3.62161E-06,3.70535E-06,3.79046E-06,3.87695E-06,3.96481E-06, & - &4.05409E-06,4.14477E-06,4.23687E-06,4.33040E-06,4.42538E-06/ - data totplnk(151:181,10) / & - &4.52180E-06,4.61969E-06,4.71905E-06,4.81991E-06,4.92226E-06, & - &5.02611E-06,5.13148E-06,5.23839E-06,5.34681E-06,5.45681E-06, & - &5.56835E-06,5.68146E-06,5.79614E-06,5.91242E-06,6.03030E-06, & - &6.14978E-06,6.27088E-06,6.39360E-06,6.51798E-06,6.64398E-06, & - &6.77165E-06,6.90099E-06,7.03198E-06,7.16468E-06,7.29906E-06, & - &7.43514E-06,7.57294E-06,7.71244E-06,7.85369E-06,7.99666E-06, & - &8.14138E-06/ - data totplnk( 1: 50,11) / & - &2.53767E-09,2.77242E-09,3.02564E-09,3.29851E-09,3.59228E-09, & - &3.90825E-09,4.24777E-09,4.61227E-09,5.00322E-09,5.42219E-09, & - &5.87080E-09,6.35072E-09,6.86370E-09,7.41159E-09,7.99628E-09, & - &8.61974E-09,9.28404E-09,9.99130E-09,1.07437E-08,1.15436E-08, & - &1.23933E-08,1.32953E-08,1.42522E-08,1.52665E-08,1.63410E-08, & - &1.74786E-08,1.86820E-08,1.99542E-08,2.12985E-08,2.27179E-08, & - &2.42158E-08,2.57954E-08,2.74604E-08,2.92141E-08,3.10604E-08, & - &3.30029E-08,3.50457E-08,3.71925E-08,3.94476E-08,4.18149E-08, & - &4.42991E-08,4.69043E-08,4.96352E-08,5.24961E-08,5.54921E-08, & - &5.86277E-08,6.19081E-08,6.53381E-08,6.89231E-08,7.26681E-08/ - data totplnk( 51:100,11) / & - &7.65788E-08,8.06604E-08,8.49187E-08,8.93591E-08,9.39879E-08, & - &9.88106E-08,1.03834E-07,1.09063E-07,1.14504E-07,1.20165E-07, & - &1.26051E-07,1.32169E-07,1.38525E-07,1.45128E-07,1.51982E-07, & - &1.59096E-07,1.66477E-07,1.74132E-07,1.82068E-07,1.90292E-07, & - &1.98813E-07,2.07638E-07,2.16775E-07,2.26231E-07,2.36015E-07, & - &2.46135E-07,2.56599E-07,2.67415E-07,2.78592E-07,2.90137E-07, & - &3.02061E-07,3.14371E-07,3.27077E-07,3.40186E-07,3.53710E-07, & - &3.67655E-07,3.82031E-07,3.96848E-07,4.12116E-07,4.27842E-07, & - &4.44039E-07,4.60713E-07,4.77876E-07,4.95537E-07,5.13706E-07, & - &5.32392E-07,5.51608E-07,5.71360E-07,5.91662E-07,6.12521E-07/ - data totplnk(101:150,11) / & - &6.33950E-07,6.55958E-07,6.78556E-07,7.01753E-07,7.25562E-07, & - &7.49992E-07,7.75055E-07,8.00760E-07,8.27120E-07,8.54145E-07, & - &8.81845E-07,9.10233E-07,9.39318E-07,9.69113E-07,9.99627E-07, & - &1.03087E-06,1.06286E-06,1.09561E-06,1.12912E-06,1.16340E-06, & - &1.19848E-06,1.23435E-06,1.27104E-06,1.30855E-06,1.34690E-06, & - &1.38609E-06,1.42614E-06,1.46706E-06,1.50886E-06,1.55155E-06, & - &1.59515E-06,1.63967E-06,1.68512E-06,1.73150E-06,1.77884E-06, & - &1.82715E-06,1.87643E-06,1.92670E-06,1.97797E-06,2.03026E-06, & - &2.08356E-06,2.13791E-06,2.19330E-06,2.24975E-06,2.30728E-06, & - &2.36589E-06,2.42560E-06,2.48641E-06,2.54835E-06,2.61142E-06/ - data totplnk(151:181,11) / & - &2.67563E-06,2.74100E-06,2.80754E-06,2.87526E-06,2.94417E-06, & - &3.01429E-06,3.08562E-06,3.15819E-06,3.23199E-06,3.30704E-06, & - &3.38336E-06,3.46096E-06,3.53984E-06,3.62002E-06,3.70151E-06, & - &3.78433E-06,3.86848E-06,3.95399E-06,4.04084E-06,4.12907E-06, & - &4.21868E-06,4.30968E-06,4.40209E-06,4.49592E-06,4.59117E-06, & - &4.68786E-06,4.78600E-06,4.88561E-06,4.98669E-06,5.08926E-06, & - &5.19332E-06/ - data totplnk( 1: 50,12) / & - &2.73921E-10,3.04500E-10,3.38056E-10,3.74835E-10,4.15099E-10, & - &4.59126E-10,5.07214E-10,5.59679E-10,6.16857E-10,6.79103E-10, & - &7.46796E-10,8.20335E-10,9.00144E-10,9.86671E-10,1.08039E-09, & - &1.18180E-09,1.29142E-09,1.40982E-09,1.53757E-09,1.67529E-09, & - &1.82363E-09,1.98327E-09,2.15492E-09,2.33932E-09,2.53726E-09, & - &2.74957E-09,2.97710E-09,3.22075E-09,3.48145E-09,3.76020E-09, & - &4.05801E-09,4.37595E-09,4.71513E-09,5.07672E-09,5.46193E-09, & - &5.87201E-09,6.30827E-09,6.77205E-09,7.26480E-09,7.78794E-09, & - &8.34304E-09,8.93163E-09,9.55537E-09,1.02159E-08,1.09151E-08, & - &1.16547E-08,1.24365E-08,1.32625E-08,1.41348E-08,1.50554E-08/ - data totplnk( 51:100,12) / & - &1.60264E-08,1.70500E-08,1.81285E-08,1.92642E-08,2.04596E-08, & - &2.17171E-08,2.30394E-08,2.44289E-08,2.58885E-08,2.74209E-08, & - &2.90290E-08,3.07157E-08,3.24841E-08,3.43371E-08,3.62782E-08, & - &3.83103E-08,4.04371E-08,4.26617E-08,4.49878E-08,4.74190E-08, & - &4.99589E-08,5.26113E-08,5.53801E-08,5.82692E-08,6.12826E-08, & - &6.44245E-08,6.76991E-08,7.11105E-08,7.46634E-08,7.83621E-08, & - &8.22112E-08,8.62154E-08,9.03795E-08,9.47081E-08,9.92066E-08, & - &1.03879E-07,1.08732E-07,1.13770E-07,1.18998E-07,1.24422E-07, & - &1.30048E-07,1.35880E-07,1.41924E-07,1.48187E-07,1.54675E-07, & - &1.61392E-07,1.68346E-07,1.75543E-07,1.82988E-07,1.90688E-07/ - data totplnk(101:150,12) / & - &1.98650E-07,2.06880E-07,2.15385E-07,2.24172E-07,2.33247E-07, & - &2.42617E-07,2.52289E-07,2.62272E-07,2.72571E-07,2.83193E-07, & - &2.94147E-07,3.05440E-07,3.17080E-07,3.29074E-07,3.41430E-07, & - &3.54155E-07,3.67259E-07,3.80747E-07,3.94631E-07,4.08916E-07, & - &4.23611E-07,4.38725E-07,4.54267E-07,4.70245E-07,4.86666E-07, & - &5.03541E-07,5.20879E-07,5.38687E-07,5.56975E-07,5.75751E-07, & - &5.95026E-07,6.14808E-07,6.35107E-07,6.55932E-07,6.77293E-07, & - &6.99197E-07,7.21656E-07,7.44681E-07,7.68278E-07,7.92460E-07, & - &8.17235E-07,8.42614E-07,8.68606E-07,8.95223E-07,9.22473E-07, & - &9.50366E-07,9.78915E-07,1.00813E-06,1.03802E-06,1.06859E-06/ - data totplnk(151:181,12) / & - &1.09986E-06,1.13184E-06,1.16453E-06,1.19796E-06,1.23212E-06, & - &1.26703E-06,1.30270E-06,1.33915E-06,1.37637E-06,1.41440E-06, & - &1.45322E-06,1.49286E-06,1.53333E-06,1.57464E-06,1.61679E-06, & - &1.65981E-06,1.70370E-06,1.74847E-06,1.79414E-06,1.84071E-06, & - &1.88821E-06,1.93663E-06,1.98599E-06,2.03631E-06,2.08759E-06, & - &2.13985E-06,2.19310E-06,2.24734E-06,2.30260E-06,2.35888E-06, & - &2.41619E-06/ - data totplnk( 1: 50,13) / & - &4.53634E-11,5.11435E-11,5.75754E-11,6.47222E-11,7.26531E-11, & - &8.14420E-11,9.11690E-11,1.01921E-10,1.13790E-10,1.26877E-10, & - &1.41288E-10,1.57140E-10,1.74555E-10,1.93665E-10,2.14613E-10, & - &2.37548E-10,2.62633E-10,2.90039E-10,3.19948E-10,3.52558E-10, & - &3.88073E-10,4.26716E-10,4.68719E-10,5.14331E-10,5.63815E-10, & - &6.17448E-10,6.75526E-10,7.38358E-10,8.06277E-10,8.79625E-10, & - &9.58770E-10,1.04410E-09,1.13602E-09,1.23495E-09,1.34135E-09, & - &1.45568E-09,1.57845E-09,1.71017E-09,1.85139E-09,2.00268E-09, & - &2.16464E-09,2.33789E-09,2.52309E-09,2.72093E-09,2.93212E-09, & - &3.15740E-09,3.39757E-09,3.65341E-09,3.92579E-09,4.21559E-09/ - data totplnk( 51:100,13) / & - &4.52372E-09,4.85115E-09,5.19886E-09,5.56788E-09,5.95928E-09, & - &6.37419E-09,6.81375E-09,7.27917E-09,7.77168E-09,8.29256E-09, & - &8.84317E-09,9.42487E-09,1.00391E-08,1.06873E-08,1.13710E-08, & - &1.20919E-08,1.28515E-08,1.36514E-08,1.44935E-08,1.53796E-08, & - &1.63114E-08,1.72909E-08,1.83201E-08,1.94008E-08,2.05354E-08, & - &2.17258E-08,2.29742E-08,2.42830E-08,2.56545E-08,2.70910E-08, & - &2.85950E-08,3.01689E-08,3.18155E-08,3.35373E-08,3.53372E-08, & - &3.72177E-08,3.91818E-08,4.12325E-08,4.33727E-08,4.56056E-08, & - &4.79342E-08,5.03617E-08,5.28915E-08,5.55270E-08,5.82715E-08, & - &6.11286E-08,6.41019E-08,6.71951E-08,7.04119E-08,7.37560E-08/ - data totplnk(101:150,13) / & - &7.72315E-08,8.08424E-08,8.45927E-08,8.84866E-08,9.25281E-08, & - &9.67218E-08,1.01072E-07,1.05583E-07,1.10260E-07,1.15107E-07, & - &1.20128E-07,1.25330E-07,1.30716E-07,1.36291E-07,1.42061E-07, & - &1.48031E-07,1.54206E-07,1.60592E-07,1.67192E-07,1.74015E-07, & - &1.81064E-07,1.88345E-07,1.95865E-07,2.03628E-07,2.11643E-07, & - &2.19912E-07,2.28443E-07,2.37244E-07,2.46318E-07,2.55673E-07, & - &2.65316E-07,2.75252E-07,2.85489E-07,2.96033E-07,3.06891E-07, & - &3.18070E-07,3.29576E-07,3.41417E-07,3.53600E-07,3.66133E-07, & - &3.79021E-07,3.92274E-07,4.05897E-07,4.19899E-07,4.34288E-07, & - &4.49071E-07,4.64255E-07,4.79850E-07,4.95863E-07,5.12300E-07/ - data totplnk(151:181,13) / & - &5.29172E-07,5.46486E-07,5.64250E-07,5.82473E-07,6.01164E-07, & - &6.20329E-07,6.39979E-07,6.60122E-07,6.80767E-07,7.01922E-07, & - &7.23596E-07,7.45800E-07,7.68539E-07,7.91826E-07,8.15669E-07, & - &8.40076E-07,8.65058E-07,8.90623E-07,9.16783E-07,9.43544E-07, & - &9.70917E-07,9.98912E-07,1.02754E-06,1.05681E-06,1.08673E-06, & - &1.11731E-06,1.14856E-06,1.18050E-06,1.21312E-06,1.24645E-06, & - &1.28049E-06/ - data totplnk( 1: 50,14) / & - &1.40113E-11,1.59358E-11,1.80960E-11,2.05171E-11,2.32266E-11, & - &2.62546E-11,2.96335E-11,3.33990E-11,3.75896E-11,4.22469E-11, & - &4.74164E-11,5.31466E-11,5.94905E-11,6.65054E-11,7.42522E-11, & - &8.27975E-11,9.22122E-11,1.02573E-10,1.13961E-10,1.26466E-10, & - &1.40181E-10,1.55206E-10,1.71651E-10,1.89630E-10,2.09265E-10, & - &2.30689E-10,2.54040E-10,2.79467E-10,3.07128E-10,3.37190E-10, & - &3.69833E-10,4.05243E-10,4.43623E-10,4.85183E-10,5.30149E-10, & - &5.78755E-10,6.31255E-10,6.87910E-10,7.49002E-10,8.14824E-10, & - &8.85687E-10,9.61914E-10,1.04385E-09,1.13186E-09,1.22631E-09, & - &1.32761E-09,1.43617E-09,1.55243E-09,1.67686E-09,1.80992E-09/ - data totplnk( 51:100,14) / & - &1.95212E-09,2.10399E-09,2.26607E-09,2.43895E-09,2.62321E-09, & - &2.81949E-09,3.02844E-09,3.25073E-09,3.48707E-09,3.73820E-09, & - &4.00490E-09,4.28794E-09,4.58819E-09,4.90647E-09,5.24371E-09, & - &5.60081E-09,5.97875E-09,6.37854E-09,6.80120E-09,7.24782E-09, & - &7.71950E-09,8.21740E-09,8.74271E-09,9.29666E-09,9.88054E-09, & - &1.04956E-08,1.11434E-08,1.18251E-08,1.25422E-08,1.32964E-08, & - &1.40890E-08,1.49217E-08,1.57961E-08,1.67140E-08,1.76771E-08, & - &1.86870E-08,1.97458E-08,2.08553E-08,2.20175E-08,2.32342E-08, & - &2.45077E-08,2.58401E-08,2.72334E-08,2.86900E-08,3.02122E-08, & - &3.18021E-08,3.34624E-08,3.51954E-08,3.70037E-08,3.88899E-08/ - data totplnk(101:150,14) / & - &4.08568E-08,4.29068E-08,4.50429E-08,4.72678E-08,4.95847E-08, & - &5.19963E-08,5.45058E-08,5.71161E-08,5.98309E-08,6.26529E-08, & - &6.55857E-08,6.86327E-08,7.17971E-08,7.50829E-08,7.84933E-08, & - &8.20323E-08,8.57035E-08,8.95105E-08,9.34579E-08,9.75488E-08, & - &1.01788E-07,1.06179E-07,1.10727E-07,1.15434E-07,1.20307E-07, & - &1.25350E-07,1.30566E-07,1.35961E-07,1.41539E-07,1.47304E-07, & - &1.53263E-07,1.59419E-07,1.65778E-07,1.72345E-07,1.79124E-07, & - &1.86122E-07,1.93343E-07,2.00792E-07,2.08476E-07,2.16400E-07, & - &2.24568E-07,2.32988E-07,2.41666E-07,2.50605E-07,2.59813E-07, & - &2.69297E-07,2.79060E-07,2.89111E-07,2.99455E-07,3.10099E-07/ - data totplnk(151:181,14) / & - &3.21049E-07,3.32311E-07,3.43893E-07,3.55801E-07,3.68041E-07, & - &3.80621E-07,3.93547E-07,4.06826E-07,4.20465E-07,4.34473E-07, & - &4.48856E-07,4.63620E-07,4.78774E-07,4.94325E-07,5.10280E-07, & - &5.26648E-07,5.43436E-07,5.60652E-07,5.78302E-07,5.96397E-07, & - &6.14943E-07,6.33949E-07,6.53421E-07,6.73370E-07,6.93803E-07, & - &7.14731E-07,7.36157E-07,7.58095E-07,7.80549E-07,8.03533E-07, & - &8.27050E-07/ - data totplnk( 1: 50,15) / & - &3.90483E-12,4.47999E-12,5.13122E-12,5.86739E-12,6.69829E-12, & - &7.63467E-12,8.68833E-12,9.87221E-12,1.12005E-11,1.26885E-11, & - &1.43534E-11,1.62134E-11,1.82888E-11,2.06012E-11,2.31745E-11, & - &2.60343E-11,2.92087E-11,3.27277E-11,3.66242E-11,4.09334E-11, & - &4.56935E-11,5.09455E-11,5.67338E-11,6.31057E-11,7.01127E-11, & - &7.78096E-11,8.62554E-11,9.55130E-11,1.05651E-10,1.16740E-10, & - &1.28858E-10,1.42089E-10,1.56519E-10,1.72243E-10,1.89361E-10, & - &2.07978E-10,2.28209E-10,2.50173E-10,2.73999E-10,2.99820E-10, & - &3.27782E-10,3.58034E-10,3.90739E-10,4.26067E-10,4.64196E-10, & - &5.05317E-10,5.49631E-10,5.97347E-10,6.48689E-10,7.03891E-10/ - data totplnk( 51:100,15) / & - &7.63201E-10,8.26876E-10,8.95192E-10,9.68430E-10,1.04690E-09, & - &1.13091E-09,1.22079E-09,1.31689E-09,1.41957E-09,1.52922E-09, & - &1.64623E-09,1.77101E-09,1.90401E-09,2.04567E-09,2.19647E-09, & - &2.35690E-09,2.52749E-09,2.70875E-09,2.90127E-09,3.10560E-09, & - &3.32238E-09,3.55222E-09,3.79578E-09,4.05375E-09,4.32682E-09, & - &4.61574E-09,4.92128E-09,5.24420E-09,5.58536E-09,5.94558E-09, & - &6.32575E-09,6.72678E-09,7.14964E-09,7.59526E-09,8.06470E-09, & - &8.55897E-09,9.07916E-09,9.62638E-09,1.02018E-08,1.08066E-08, & - &1.14420E-08,1.21092E-08,1.28097E-08,1.35446E-08,1.43155E-08, & - &1.51237E-08,1.59708E-08,1.68581E-08,1.77873E-08,1.87599E-08/ - data totplnk(101:150,15) / & - &1.97777E-08,2.08423E-08,2.19555E-08,2.31190E-08,2.43348E-08, & - &2.56045E-08,2.69302E-08,2.83140E-08,2.97578E-08,3.12636E-08, & - &3.28337E-08,3.44702E-08,3.61755E-08,3.79516E-08,3.98012E-08, & - &4.17265E-08,4.37300E-08,4.58143E-08,4.79819E-08,5.02355E-08, & - &5.25777E-08,5.50114E-08,5.75393E-08,6.01644E-08,6.28896E-08, & - &6.57177E-08,6.86521E-08,7.16959E-08,7.48520E-08,7.81239E-08, & - &8.15148E-08,8.50282E-08,8.86675E-08,9.24362E-08,9.63380E-08, & - &1.00376E-07,1.04555E-07,1.08878E-07,1.13349E-07,1.17972E-07, & - &1.22751E-07,1.27690E-07,1.32793E-07,1.38064E-07,1.43508E-07, & - &1.49129E-07,1.54931E-07,1.60920E-07,1.67099E-07,1.73473E-07/ - data totplnk(151:181,15) / & - &1.80046E-07,1.86825E-07,1.93812E-07,2.01014E-07,2.08436E-07, & - &2.16082E-07,2.23957E-07,2.32067E-07,2.40418E-07,2.49013E-07, & - &2.57860E-07,2.66963E-07,2.76328E-07,2.85961E-07,2.95868E-07, & - &3.06053E-07,3.16524E-07,3.27286E-07,3.38345E-07,3.49707E-07, & - &3.61379E-07,3.73367E-07,3.85676E-07,3.98315E-07,4.11287E-07, & - &4.24602E-07,4.38265E-07,4.52283E-07,4.66662E-07,4.81410E-07, & - &4.96535E-07/ - data totplnk( 1: 50,16) / & - &4.65378E-13,5.41927E-13,6.29913E-13,7.30869E-13,8.46510E-13, & - &9.78750E-13,1.12972E-12,1.30181E-12,1.49764E-12,1.72016E-12, & - &1.97260E-12,2.25858E-12,2.58206E-12,2.94744E-12,3.35955E-12, & - &3.82372E-12,4.34581E-12,4.93225E-12,5.59010E-12,6.32711E-12, & - &7.15171E-12,8.07317E-12,9.10159E-12,1.02480E-11,1.15244E-11, & - &1.29438E-11,1.45204E-11,1.62697E-11,1.82084E-11,2.03545E-11, & - &2.27278E-11,2.53494E-11,2.82424E-11,3.14313E-11,3.49431E-11, & - &3.88064E-11,4.30522E-11,4.77139E-11,5.28273E-11,5.84308E-11, & - &6.45658E-11,7.12764E-11,7.86103E-11,8.66176E-11,9.53534E-11, & - &1.04875E-10,1.15245E-10,1.26528E-10,1.38796E-10,1.52123E-10/ - data totplnk( 51:100,16) / & - &1.66590E-10,1.82281E-10,1.99287E-10,2.17704E-10,2.37632E-10, & - &2.59182E-10,2.82468E-10,3.07610E-10,3.34738E-10,3.63988E-10, & - &3.95504E-10,4.29438E-10,4.65951E-10,5.05212E-10,5.47402E-10, & - &5.92707E-10,6.41329E-10,6.93477E-10,7.49371E-10,8.09242E-10, & - &8.73338E-10,9.41911E-10,1.01524E-09,1.09359E-09,1.17728E-09, & - &1.26660E-09,1.36190E-09,1.46350E-09,1.57177E-09,1.68709E-09, & - &1.80984E-09,1.94044E-09,2.07932E-09,2.22693E-09,2.38373E-09, & - &2.55021E-09,2.72689E-09,2.91429E-09,3.11298E-09,3.32353E-09, & - &3.54655E-09,3.78265E-09,4.03251E-09,4.29679E-09,4.57620E-09, & - &4.87148E-09,5.18341E-09,5.51276E-09,5.86037E-09,6.22708E-09/ - data totplnk(101:150,16) / & - &6.61381E-09,7.02145E-09,7.45097E-09,7.90336E-09,8.37967E-09, & - &8.88092E-09,9.40827E-09,9.96280E-09,1.05457E-08,1.11583E-08, & - &1.18017E-08,1.24773E-08,1.31865E-08,1.39306E-08,1.47111E-08, & - &1.55295E-08,1.63872E-08,1.72860E-08,1.82274E-08,1.92132E-08, & - &2.02450E-08,2.13247E-08,2.24541E-08,2.36352E-08,2.48699E-08, & - &2.61602E-08,2.75082E-08,2.89161E-08,3.03860E-08,3.19203E-08, & - &3.35213E-08,3.51913E-08,3.69330E-08,3.87486E-08,4.06411E-08, & - &4.26129E-08,4.46668E-08,4.68058E-08,4.90325E-08,5.13502E-08, & - &5.37617E-08,5.62703E-08,5.88791E-08,6.15915E-08,6.44107E-08, & - &6.73404E-08,7.03841E-08,7.35453E-08,7.68278E-08,8.02355E-08/ - data totplnk(151:181,16) / & - &8.37721E-08,8.74419E-08,9.12486E-08,9.51968E-08,9.92905E-08, & - &1.03534E-07,1.07932E-07,1.12490E-07,1.17211E-07,1.22100E-07, & - &1.27163E-07,1.32404E-07,1.37829E-07,1.43443E-07,1.49250E-07, & - &1.55257E-07,1.61470E-07,1.67893E-07,1.74532E-07,1.81394E-07, & - &1.88485E-07,1.95810E-07,2.03375E-07,2.11189E-07,2.19256E-07, & - &2.27583E-07,2.36177E-07,2.45046E-07,2.54196E-07,2.63634E-07, & - &2.73367E-07/ - -!........................................! - end module module_radlw_avplank ! -!========================================! - - - -!========================================! - module module_radlw_cldprlw ! -!........................................! -! - use machine, only : kind_phys - use module_radlw_parameters, only : NBANDS -! - implicit none -! - private - - real (kind=kind_phys), public :: & - & absice0(2), absice1(2,5), absice2(40,16), abscoice(NBANDS),& - & absliq1, absliq2, absliq3(58,16), abscoliq(NBANDS), & - & absrain, abssnow0, abssnow1 - - integer, public :: ipat(NBANDS) - -! --- ipat is bands index for ebert & curry ice cloud (for iflagice=1) - data ipat / 1, 2, 3,3,3, 4,4,4, 5,5,5,5,5,5,5,5 / - -! --- absrain is the rain drop absorption coefficient (m2/g) -! data absrain / 3.07e-3 / ! chou coeff - data absrain / 0.33e-3 / ! ncar coeff - -! --- abssnow is the snow flake absorption coefficient (micron) - data abssnow0 / 1.5 / ! fu coeff -! --- abssnow is the snow flake absorption coefficient (m2/g) - data abssnow1 / 2.34e-3 / ! ncar coeff - -! absliqn is the liquid water absorption coefficient (m2/g). -! === for iflagliq = 1, - data absliq1 / 0.0602410 / - -! === everything below is for iflagliq >= 2. - -! absice#(j,ib) are the parameters needed to compute the ice water -! absorption coefficient in spectral region ib for iceflag=#. the -! units of absice#(1,ib) are m2/g and absicen(2,ib) has units -! (microns (m2/g)). -! --- for iflagice = 0. - data absice0 / 0.005, 1.0 / -!! data absice0 / 0.0029, 1.0 / ! moorthi's coeff - -! --- for iflagice = 1. - data absice1 / 0.0036, 1.136, 0.0068, 0.600, 0.0003, 1.338, & - & 0.0016, 1.166, 0.0020, 1.118 / - -! --- for iflagice = 2. -! each band, the absorption coef's are listed for a range of effective -! radii from 13.0 to 130.0 microns in increments of 3.0 microns. - data absice2(:,1) / & - & 5.308137e-02,4.610615e-02,4.128355e-02,3.767141e-02,3.481773e-02,& - & 3.247569e-02,3.049760e-02,2.878894e-02,2.728603e-02,2.594420e-02,& - & 2.473109e-02,2.362260e-02,2.260035e-02,2.165006e-02,2.076046e-02,& - & 1.992250e-02,1.912880e-02,1.837331e-02,1.765101e-02,1.695766e-02,& - & 1.628969e-02,1.564405e-02,1.501811e-02,1.440959e-02,1.381653e-02,& - & 1.323720e-02,1.267006e-02,1.211378e-02,1.156715e-02,1.102911e-02,& - & 1.049869e-02,9.975041e-03,9.457376e-03,8.944992e-03,8.437249e-03,& - & 7.933561e-03,7.433394e-03,6.936257e-03,6.441701e-03,5.949308e-03/ - data absice2(:,2) / & - & 3.808872e-02,3.502664e-02,3.231765e-02,2.998940e-02,2.798500e-02,& - & 2.624287e-02,2.471175e-02,2.335146e-02,2.213092e-02,2.102607e-02,& - & 2.001804e-02,1.909193e-02,1.823581e-02,1.744003e-02,1.669669e-02,& - & 1.599927e-02,1.534234e-02,1.472132e-02,1.413234e-02,1.357209e-02,& - & 1.303774e-02,1.252681e-02,1.203718e-02,1.156698e-02,1.111455e-02,& - & 1.067846e-02,1.025741e-02,9.850260e-03,9.455976e-03,9.073645e-03,& - & 8.702438e-03,8.341606e-03,7.990473e-03,7.648424e-03,7.314896e-03,& - & 6.989379e-03,6.671402e-03,6.360537e-03,6.056387e-03,5.758587e-03/ - data absice2(:,3) / & - & 7.402665e-02,6.209102e-02,5.216790e-02,4.453142e-02,3.864415e-02,& - & 3.402727e-02,3.033647e-02,2.733239e-02,2.484767e-02,2.276330e-02,& - & 2.099304e-02,1.947312e-02,1.815559e-02,1.700375e-02,1.598911e-02,& - & 1.508925e-02,1.428628e-02,1.356580e-02,1.291609e-02,1.232749e-02,& - & 1.179201e-02,1.130298e-02,1.085478e-02,1.044263e-02,1.006249e-02,& - & 9.710860e-03,9.384746e-03,9.081546e-03,8.798995e-03,8.535113e-03,& - & 8.288163e-03,8.056611e-03,7.839102e-03,7.634433e-03,7.441532e-03,& - & 7.259442e-03,7.087304e-03,6.924348e-03,6.769881e-03,6.623274e-03/ - data absice2(:,4) / & - & 8.094820e-02,6.403291e-02,5.250755e-02,4.428943e-02,3.818391e-02,& - & 3.349259e-02,2.978790e-02,2.679591e-02,2.433399e-02,2.227614e-02,& - & 2.053280e-02,1.903874e-02,1.774534e-02,1.661571e-02,1.562134e-02,& - & 1.473990e-02,1.395366e-02,1.324836e-02,1.261241e-02,1.203630e-02,& - & 1.151218e-02,1.103347e-02,1.059465e-02,1.019105e-02,9.818699e-03,& - & 9.474168e-03,9.154525e-03,8.857223e-03,8.580047e-03,8.321061e-03,& - & 8.078565e-03,7.851061e-03,7.637226e-03,7.435882e-03,7.245985e-03,& - & 7.066598e-03,6.896884e-03,6.736091e-03,6.583542e-03,6.438624e-03/ - data absice2(:,5) / & - & 8.107771e-02,6.356966e-02,5.202664e-02,4.388361e-02,3.785256e-02,& - & 3.321862e-02,2.955444e-02,2.658946e-02,2.414439e-02,2.209589e-02,& - & 2.035644e-02,1.886226e-02,1.756586e-02,1.643112e-02,1.543016e-02,& - & 1.454108e-02,1.374647e-02,1.303233e-02,1.238726e-02,1.180189e-02,& - & 1.126846e-02,1.078049e-02,1.033252e-02,9.919924e-03,9.538748e-03,& - & 9.185608e-03,8.857581e-03,8.552134e-03,8.267059e-03,8.000423e-03,& - & 7.750529e-03,7.515880e-03,7.295149e-03,7.087158e-03,6.890857e-03,& - & 6.705306e-03,6.529664e-03,6.363173e-03,6.205150e-03,6.054977e-03/ - data absice2(:,6) / & - & 6.617399e-02,5.382356e-02,4.548024e-02,3.943650e-02,3.483962e-02,& - & 3.121482e-02,2.827613e-02,2.584066e-02,2.378586e-02,2.202637e-02,& - & 2.050087e-02,1.916411e-02,1.798196e-02,1.692814e-02,1.598211e-02,& - & 1.512754e-02,1.435129e-02,1.364266e-02,1.299284e-02,1.239453e-02,& - & 1.184158e-02,1.132883e-02,1.085186e-02,1.040690e-02,9.990698e-03,& - & 9.600436e-03,9.233660e-03,8.888220e-03,8.562226e-03,8.254011e-03,& - & 7.962094e-03,7.685159e-03,7.422029e-03,7.171651e-03,6.933078e-03,& - & 6.705456e-03,6.488015e-03,6.280053e-03,6.080937e-03,5.890087e-03/ - data absice2(:,7) / & - & 5.525622e-02,4.882834e-02,4.307237e-02,3.828016e-02,3.432924e-02,& - & 3.105137e-02,2.830273e-02,2.597146e-02,2.397252e-02,2.224126e-02,& - & 2.072819e-02,1.939498e-02,1.821160e-02,1.715425e-02,1.620385e-02,& - & 1.534496e-02,1.456495e-02,1.385341e-02,1.320165e-02,1.260242e-02,& - & 1.204956e-02,1.153786e-02,1.106285e-02,1.062069e-02,1.020806e-02,& - & 9.822069e-03,9.460187e-03,9.120204e-03,8.800168e-03,8.498356e-03,& - & 8.213235e-03,7.943442e-03,7.687759e-03,7.445092e-03,7.214460e-03,& - & 6.994979e-03,6.785846e-03,6.586339e-03,6.395797e-03,6.213622e-03/ - data absice2(:,8) / & - & 6.204709e-02,5.447577e-02,4.693652e-02,4.068410e-02,3.566129e-02,& - & 3.162111e-02,2.833719e-02,2.563384e-02,2.338009e-02,2.147883e-02,& - & 1.985755e-02,1.846151e-02,1.724884e-02,1.618712e-02,1.525092e-02,& - & 1.442006e-02,1.367838e-02,1.301277e-02,1.241252e-02,1.186877e-02,& - & 1.137421e-02,1.092266e-02,1.050894e-02,1.012866e-02,9.778052e-03,& - & 9.453889e-03,9.153392e-03,8.874146e-03,8.614049e-03,8.371264e-03,& - & 8.144174e-03,7.931357e-03,7.731552e-03,7.543641e-03,7.366629e-03,& - & 7.199625e-03,7.041832e-03,6.892534e-03,6.751085e-03,6.616904e-03/ - data absice2(:,9) / & - & 6.886530e-02,5.796039e-02,4.871664e-02,4.157422e-02,3.606747e-02,& - & 3.175486e-02,2.831396e-02,2.551931e-02,2.321294e-02,2.128248e-02,& - & 1.964647e-02,1.824476e-02,1.703216e-02,1.597411e-02,1.504384e-02,& - & 1.422028e-02,1.348667e-02,1.282952e-02,1.223786e-02,1.170268e-02,& - & 1.121653e-02,1.077318e-02,1.036740e-02,9.994772e-03,9.651518e-03,& - & 9.334412e-03,9.040674e-03,8.767897e-03,8.513989e-03,8.277122e-03,& - & 8.055693e-03,7.848290e-03,7.653665e-03,7.470712e-03,7.298447e-03,& - & 7.135991e-03,6.982557e-03,6.837440e-03,6.700003e-03,6.569673e-03/ - data absice2(:,10) / & - & 7.124487e-02,5.846725e-02,4.869304e-02,4.140966e-02,3.588534e-02,& - & 3.159352e-02,2.818254e-02,2.541683e-02,2.313524e-02,2.122481e-02,& - & 1.960443e-02,1.821456e-02,1.701063e-02,1.595869e-02,1.503244e-02,& - & 1.421124e-02,1.347864e-02,1.282143e-02,1.222886e-02,1.169209e-02,& - & 1.120381e-02,1.075791e-02,1.034925e-02,9.973491e-03,9.626911e-03,& - & 9.306335e-03,9.009024e-03,8.732604e-03,8.475009e-03,8.234434e-03,& - & 8.009292e-03,7.798186e-03,7.599882e-03,7.413280e-03,7.237405e-03,& - & 7.071384e-03,6.914434e-03,6.765853e-03,6.625009e-03,6.491330e-03/ - data absice2(:,11) / & - & 6.946157e-02,5.694109e-02,4.754750e-02,4.056198e-02,3.525241e-02,& - & 3.111421e-02,2.781424e-02,2.512985e-02,2.290863e-02,2.104354e-02,& - & 1.945751e-02,1.809386e-02,1.691003e-02,1.587352e-02,1.495910e-02,& - & 1.414692e-02,1.342116e-02,1.276904e-02,1.218016e-02,1.164598e-02,& - & 1.115939e-02,1.071445e-02,1.030618e-02,9.930324e-03,9.583261e-03,& - & 9.261888e-03,8.963524e-03,8.685843e-03,8.426821e-03,8.184683e-03,& - & 7.957872e-03,7.745014e-03,7.544891e-03,7.356422e-03,7.178643e-03,& - & 7.010693e-03,6.851799e-03,6.701265e-03,6.558467e-03,6.422836e-03/ - data absice2(:,12) / & - & 4.162544e-02,3.774206e-02,3.387559e-02,3.048216e-02,2.759398e-02,& - & 2.514770e-02,2.306767e-02,2.128679e-02,1.975015e-02,1.841389e-02,& - & 1.724326e-02,1.621062e-02,1.529388e-02,1.447525e-02,1.374029e-02,& - & 1.307717e-02,1.247616e-02,1.192916e-02,1.142938e-02,1.097111e-02,& - & 1.054952e-02,1.016048e-02,9.800441e-03,9.466351e-03,9.155566e-03,& - & 8.865782e-03,8.594987e-03,8.341414e-03,8.103506e-03,7.879884e-03,& - & 7.669326e-03,7.470744e-03,7.283166e-03,7.105719e-03,6.937623e-03,& - & 6.778171e-03,6.626727e-03,6.482715e-03,6.345612e-03,6.214942e-03/ - data absice2(:,13) / & - & 5.989806e-02,5.056817e-02,4.311112e-02,3.735098e-02,3.285293e-02,& - & 2.927343e-02,2.637042e-02,2.397535e-02,2.196938e-02,2.026708e-02,& - & 1.880583e-02,1.753882e-02,1.643044e-02,1.545319e-02,1.458549e-02,& - & 1.381020e-02,1.311354e-02,1.248431e-02,1.191334e-02,1.139300e-02,& - & 1.091697e-02,1.047989e-02,1.007724e-02,9.705182e-03,9.360395e-03,& - & 9.040037e-03,8.741639e-03,8.463052e-03,8.202396e-03,7.958020e-03,& - & 7.728467e-03,7.512449e-03,7.308820e-03,7.116561e-03,6.934759e-03,& - & 6.762596e-03,6.599337e-03,6.444320e-03,6.296944e-03,6.156667e-03/ - data absice2(:,14) / & - & 5.427438e-02,4.682405e-02,4.056412e-02,3.555101e-02,3.153408e-02,& - & 2.827650e-02,2.559668e-02,2.336126e-02,2.147261e-02,1.985856e-02,& - & 1.846503e-02,1.725091e-02,1.618448e-02,1.524093e-02,1.440064e-02,& - & 1.364787e-02,1.296990e-02,1.235630e-02,1.179850e-02,1.128934e-02,& - & 1.082285e-02,1.039396e-02,9.998390e-03,9.632453e-03,9.292999e-03,& - & 8.977300e-03,8.682986e-03,8.407991e-03,8.150503e-03,7.908927e-03,& - & 7.681856e-03,7.468042e-03,7.266375e-03,7.075864e-03,6.895622e-03,& - & 6.724854e-03,6.562843e-03,6.408943e-03,6.262568e-03,6.123188e-03/ - data absice2(:,15) / & - & 3.734649e-02,3.412194e-02,3.079772e-02,2.783212e-02,2.528118e-02,& - & 2.310335e-02,2.123972e-02,1.963551e-02,1.824481e-02,1.703044e-02,& - & 1.596258e-02,1.501737e-02,1.417560e-02,1.342171e-02,1.274301e-02,& - & 1.212909e-02,1.157132e-02,1.106249e-02,1.059658e-02,1.016849e-02,& - & 9.773873e-03,9.409024e-03,9.070757e-03,8.756320e-03,8.463322e-03,& - & 8.189678e-03,7.933561e-03,7.693367e-03,7.467678e-03,7.255238e-03,& - & 7.054931e-03,6.865762e-03,6.686840e-03,6.517366e-03,6.356622e-03,& - & 6.203960e-03,6.058793e-03,5.920590e-03,5.788869e-03,5.663191e-03/ - data absice2(:,16) / & - & 4.226924e-02,3.719702e-02,3.276247e-02,2.909934e-02,2.609178e-02,& - & 2.360471e-02,2.152589e-02,1.976868e-02,1.826735e-02,1.697197e-02,& - & 1.584428e-02,1.485463e-02,1.397979e-02,1.320136e-02,1.250459e-02,& - & 1.187752e-02,1.131042e-02,1.079523e-02,1.032526e-02,9.894930e-03,& - & 9.499496e-03,9.134956e-03,8.797885e-03,8.485341e-03,8.194783e-03,& - & 7.924007e-03,7.671090e-03,7.434349e-03,7.212302e-03,7.003645e-03,& - & 6.807219e-03,6.621995e-03,6.447055e-03,6.281580e-03,6.124830e-03,& - & 5.976146e-03,5.834927e-03,5.700635e-03,5.572778e-03,5.450912e-03/ - -! === for iflagliq = 2. - data absliq2 /0.0903614/ - -! === for iflagliq = 3. -! each band, the absorption coeff's are listed for a range of effective -! radii from 2.5 to 59.5 microns in increments of 1.0 micron. - data absliq3(:,1) / & - & 2.317311e-02,6.109513e-02,6.850127e-02,7.025095e-02,7.045720e-02,& - & 7.014763e-02,6.964456e-02,6.906029e-02,6.843251e-02,6.776883e-02,& - & 6.740428e-02,6.471351e-02,6.215508e-02,5.977013e-02,5.755809e-02,& - & 5.550328e-02,5.358573e-02,5.178553e-02,5.008436e-02,4.846591e-02,& - & 4.691585e-02,4.542158e-02,4.397195e-02,4.255702e-02,4.116779e-02,& - & 3.979603e-02,3.843408e-02,3.707472e-02,3.593146e-02,3.477353e-02,& - & 3.368067e-02,3.264653e-02,3.166568e-02,3.073339e-02,2.984557e-02,& - & 2.899858e-02,2.818924e-02,2.741469e-02,2.667239e-02,2.596005e-02,& - & 2.527561e-02,2.461722e-02,2.398318e-02,2.337194e-02,2.278211e-02,& - & 2.221240e-02,2.166162e-02,2.112870e-02,2.061262e-02,2.011246e-02,& - & 1.962737e-02,1.915655e-02,1.869927e-02,1.825485e-02,1.782263e-02,& - & 1.740204e-02,1.699251e-02,1.659352e-02/ - data absliq3(:,2) / & - & 9.103496e-02,1.480995e-01,1.402309e-01,1.300658e-01,1.214233e-01,& - & 1.140277e-01,1.073661e-01,1.010236e-01,9.466848e-02,8.801306e-02,& - & 8.222715e-02,7.610165e-02,7.087689e-02,6.633009e-02,6.231412e-02,& - & 5.872623e-02,5.549144e-02,5.255308e-02,4.986711e-02,4.739856e-02,& - & 4.511911e-02,4.300551e-02,4.103841e-02,3.920156e-02,3.748114e-02,& - & 3.586532e-02,3.434392e-02,3.290809e-02,3.176277e-02,3.060455e-02,& - & 2.951870e-02,2.849868e-02,2.753870e-02,2.663363e-02,2.577891e-02,& - & 2.497048e-02,2.420469e-02,2.347828e-02,2.278828e-02,2.213206e-02,& - & 2.150719e-02,2.091151e-02,2.034301e-02,1.979989e-02,1.928050e-02,& - & 1.878332e-02,1.830698e-02,1.785018e-02,1.741177e-02,1.699066e-02,& - & 1.658586e-02,1.619643e-02,1.582154e-02,1.546038e-02,1.511222e-02,& - & 1.477637e-02,1.445221e-02,1.413913e-02/ - data absliq3(:,3) / & - & 2.951735e-01,2.347648e-01,1.980376e-01,1.721142e-01,1.520826e-01,& - & 1.356541e-01,1.216134e-01,1.092517e-01,9.812634e-02,8.794481e-02,& - & 8.125663e-02,7.445630e-02,6.863743e-02,6.360421e-02,5.920939e-02,& - & 5.534017e-02,5.190868e-02,4.884551e-02,4.609508e-02,4.361243e-02,& - & 4.136074e-02,3.930963e-02,3.743377e-02,3.571191e-02,3.412609e-02,& - & 3.266100e-02,3.130355e-02,3.004245e-02,2.884966e-02,2.780765e-02,& - & 2.683173e-02,2.591580e-02,2.505449e-02,2.424303e-02,2.347722e-02,& - & 2.275331e-02,2.206794e-02,2.141810e-02,2.080110e-02,2.021450e-02,& - & 1.965609e-02,1.912390e-02,1.861611e-02,1.813107e-02,1.766729e-02,& - & 1.722339e-02,1.679811e-02,1.639031e-02,1.599892e-02,1.562296e-02,& - & 1.526155e-02,1.491384e-02,1.457907e-02,1.425652e-02,1.394554e-02,& - & 1.364551e-02,1.335586e-02,1.307606e-02/ - data absliq3(:,4) / & - & 3.009248e-01,2.369488e-01,1.969469e-01,1.686924e-01,1.471901e-01,& - & 1.299859e-01,1.157190e-01,1.035677e-01,9.300276e-02,8.366584e-02,& - & 7.710747e-02,7.070016e-02,6.522841e-02,6.050237e-02,5.638011e-02,& - & 5.275342e-02,4.953838e-02,4.666896e-02,4.409246e-02,4.176635e-02,& - & 3.965594e-02,3.773263e-02,3.597266e-02,3.435610e-02,3.286616e-02,& - & 3.148853e-02,3.021100e-02,2.902305e-02,2.789483e-02,2.691087e-02,& - & 2.598836e-02,2.512166e-02,2.430581e-02,2.353642e-02,2.280958e-02,& - & 2.212182e-02,2.147004e-02,2.085146e-02,2.026356e-02,1.970411e-02,& - & 1.917105e-02,1.866254e-02,1.817690e-02,1.771260e-02,1.726825e-02,& - & 1.684257e-02,1.643440e-02,1.604265e-02,1.566636e-02,1.530459e-02,& - & 1.495653e-02,1.462140e-02,1.429847e-02,1.398708e-02,1.368662e-02,& - & 1.339651e-02,1.311622e-02,1.284525e-02/ - data absliq3(:,5) / & - & 2.646912e-01,2.120182e-01,1.780086e-01,1.535393e-01,1.347209e-01,& - & 1.195802e-01,1.069960e-01,9.627716e-02,8.697099e-02,7.876703e-02,& - & 7.292724e-02,6.709201e-02,6.209771e-02,5.777322e-02,5.399095e-02,& - & 5.065378e-02,4.768655e-02,4.503014e-02,4.263744e-02,4.047042e-02,& - & 3.849806e-02,3.669482e-02,3.503944e-02,3.351411e-02,3.210378e-02,& - & 3.079567e-02,2.957880e-02,2.844375e-02,2.737899e-02,2.643902e-02,& - & 2.555652e-02,2.472627e-02,2.394368e-02,2.320467e-02,2.250563e-02,& - & 2.184333e-02,2.121488e-02,2.061771e-02,2.004948e-02,1.950810e-02,& - & 1.899165e-02,1.849842e-02,1.802685e-02,1.757549e-02,1.714305e-02,& - & 1.672834e-02,1.633026e-02,1.594781e-02,1.558006e-02,1.522615e-02,& - & 1.488531e-02,1.455681e-02,1.423996e-02,1.393415e-02,1.363879e-02,& - & 1.335334e-02,1.307730e-02,1.281020e-02/ - data absliq3(:,6) / & - & 8.811824e-02,1.067453e-01,9.797529e-02,8.996253e-02,8.352002e-02,& - & 7.818990e-02,7.359390e-02,6.946955e-02,6.562659e-02,6.191484e-02,& - & 5.833548e-02,5.493056e-02,5.196417e-02,4.933254e-02,4.696588e-02,& - & 4.481484e-02,4.284310e-02,4.102307e-02,3.933320e-02,3.775632e-02,& - & 3.627847e-02,3.488817e-02,3.357580e-02,3.233326e-02,3.115363e-02,& - & 3.003095e-02,2.896007e-02,2.793646e-02,2.705024e-02,2.626182e-02,& - & 2.550246e-02,2.477275e-02,2.407256e-02,2.340134e-02,2.275825e-02,& - & 2.214224e-02,2.155220e-02,2.098694e-02,2.044526e-02,1.992599e-02,& - & 1.942798e-02,1.895011e-02,1.849132e-02,1.805060e-02,1.762699e-02,& - & 1.721959e-02,1.682755e-02,1.645004e-02,1.608633e-02,1.573569e-02,& - & 1.539746e-02,1.507101e-02,1.475575e-02,1.445112e-02,1.415662e-02,& - & 1.387173e-02,1.359601e-02,1.332903e-02/ - data absliq3(:,7) / & - & 4.321742e-02,7.360776e-02,6.983400e-02,6.652314e-02,6.419483e-02,& - & 6.235512e-02,6.066381e-02,5.886798e-02,5.671241e-02,5.386294e-02,& - & 4.995791e-02,4.862892e-02,4.701198e-02,4.528539e-02,4.354655e-02,& - & 4.184799e-02,4.021685e-02,3.866581e-02,3.719923e-02,3.581678e-02,& - & 3.451553e-02,3.329122e-02,3.213899e-02,3.105381e-02,3.003074e-02,& - & 2.906507e-02,2.815236e-02,2.728853e-02,2.628212e-02,2.557439e-02,& - & 2.487989e-02,2.420288e-02,2.354602e-02,2.291084e-02,2.229808e-02,& - & 2.170793e-02,2.114022e-02,2.059448e-02,2.007010e-02,1.956633e-02,& - & 1.908238e-02,1.861742e-02,1.817060e-02,1.774108e-02,1.732806e-02,& - & 1.693073e-02,1.654832e-02,1.618011e-02,1.582540e-02,1.548352e-02,& - & 1.515384e-02,1.483577e-02,1.452875e-02,1.423223e-02,1.394571e-02,& - & 1.366873e-02,1.340083e-02,1.314159e-02/ - data absliq3(:,8) / & - & 1.418807e-01,7.154191e-02,6.303346e-02,6.111324e-02,6.019305e-02,& - & 5.924194e-02,5.789680e-02,5.588757e-02,5.289232e-02,4.844620e-02,& - & 4.608385e-02,4.560133e-02,4.454102e-02,4.318657e-02,4.170261e-02,& - & 4.018504e-02,3.868917e-02,3.724607e-02,3.587214e-02,3.457487e-02,& - & 3.335635e-02,3.221551e-02,3.114941e-02,3.015414e-02,2.922530e-02,& - & 2.835836e-02,2.754884e-02,2.679246e-02,2.576920e-02,2.507042e-02,& - & 2.439184e-02,2.373495e-02,2.310052e-02,2.248877e-02,2.189956e-02,& - & 2.133248e-02,2.078695e-02,2.026227e-02,1.975769e-02,1.927241e-02,& - & 1.880560e-02,1.835644e-02,1.792414e-02,1.750791e-02,1.710699e-02,& - & 1.672066e-02,1.634822e-02,1.598900e-02,1.564237e-02,1.530773e-02,& - & 1.498452e-02,1.467219e-02,1.437023e-02,1.407816e-02,1.379552e-02,& - & 1.352189e-02,1.325685e-02,1.300002e-02/ - data absliq3(:,9) / & - & 6.727262e-02,6.610126e-02,6.478659e-02,6.337803e-02,6.189851e-02,& - & 6.033352e-02,5.861357e-02,5.658760e-02,5.398387e-02,5.035361e-02,& - & 4.716084e-02,4.636301e-02,4.503130e-02,4.345260e-02,4.178762e-02,& - & 4.012609e-02,3.851708e-02,3.698595e-02,3.554424e-02,3.419543e-02,& - & 3.293837e-02,3.176932e-02,3.068324e-02,2.967450e-02,2.873737e-02,& - & 2.786621e-02,2.705567e-02,2.630077e-02,2.524495e-02,2.454240e-02,& - & 2.386557e-02,2.321441e-02,2.258852e-02,2.198727e-02,2.140986e-02,& - & 2.085540e-02,2.032297e-02,1.981160e-02,1.932034e-02,1.884823e-02,& - & 1.839436e-02,1.795783e-02,1.753780e-02,1.713345e-02,1.674400e-02,& - & 1.636871e-02,1.600688e-02,1.565786e-02,1.532101e-02,1.499576e-02,& - & 1.468153e-02,1.437781e-02,1.408409e-02,1.379992e-02,1.352485e-02,& - & 1.325846e-02,1.300036e-02,1.275018e-02/ - data absliq3(:,10) / & - & 7.970399e-02,7.638436e-02,7.364989e-02,7.135247e-02,6.930427e-02,& - & 6.728066e-02,6.502274e-02,6.223945e-02,5.860926e-02,5.378152e-02,& - & 5.146821e-02,4.972139e-02,4.773920e-02,4.569609e-02,4.368575e-02,& - & 4.175686e-02,3.993275e-02,3.822235e-02,3.662650e-02,3.514157e-02,& - & 3.376166e-02,3.247981e-02,3.128873e-02,3.018124e-02,2.915047e-02,& - & 2.819001e-02,2.729394e-02,2.645681e-02,2.541650e-02,2.468318e-02,& - & 2.397828e-02,2.330174e-02,2.265305e-02,2.203141e-02,2.143587e-02,& - & 2.086533e-02,2.031867e-02,1.979474e-02,1.929243e-02,1.881062e-02,& - & 1.834825e-02,1.790431e-02,1.747781e-02,1.706784e-02,1.667353e-02,& - & 1.629405e-02,1.592863e-02,1.557655e-02,1.523712e-02,1.490969e-02,& - & 1.459367e-02,1.428848e-02,1.399359e-02,1.370850e-02,1.343274e-02,& - & 1.316586e-02,1.290746e-02,1.265714e-02/ - data absliq3(:,11) / & - & 1.494379e-01,1.335347e-01,1.215419e-01,1.117433e-01,1.032629e-01,& - & 9.557744e-02,8.833824e-02,8.129427e-02,7.425327e-02,6.706086e-02,& - & 6.387608e-02,5.977878e-02,5.598406e-02,5.253178e-02,4.941317e-02,& - & 4.660136e-02,4.406436e-02,4.177059e-02,3.969101e-02,3.779976e-02,& - & 3.607421e-02,3.449469e-02,3.304416e-02,3.170785e-02,3.047295e-02,& - & 2.932829e-02,2.826416e-02,2.727201e-02,2.617887e-02,2.532765e-02,& - & 2.452371e-02,2.376351e-02,2.304378e-02,2.236152e-02,2.171398e-02,& - & 2.109866e-02,2.051327e-02,1.995571e-02,1.942406e-02,1.891659e-02,& - & 1.843168e-02,1.796787e-02,1.752382e-02,1.709828e-02,1.669013e-02,& - & 1.629830e-02,1.592185e-02,1.555986e-02,1.521153e-02,1.487608e-02,& - & 1.455281e-02,1.424106e-02,1.394021e-02,1.364970e-02,1.336900e-02,& - & 1.309761e-02,1.283507e-02,1.258095e-02/ - data absliq3(:,12) / & - & 3.719852e-02,3.885858e-02,3.990704e-02,4.043514e-02,4.046101e-02,& - & 3.998338e-02,3.899533e-02,3.748863e-02,3.545507e-02,3.288698e-02,& - & 3.325759e-02,3.224436e-02,3.123840e-02,3.025843e-02,2.931462e-02,& - & 2.841198e-02,2.755245e-02,2.673607e-02,2.596181e-02,2.522801e-02,& - & 2.453266e-02,2.387362e-02,2.324871e-02,2.265581e-02,2.209286e-02,& - & 2.155791e-02,2.104914e-02,2.056482e-02,1.997489e-02,1.957035e-02,& - & 1.917308e-02,1.878385e-02,1.840320e-02,1.803148e-02,1.766887e-02,& - & 1.731546e-02,1.697124e-02,1.663615e-02,1.631005e-02,1.599278e-02,& - & 1.568416e-02,1.538398e-02,1.509202e-02,1.480804e-02,1.453181e-02,& - & 1.426309e-02,1.400164e-02,1.374723e-02,1.349962e-02,1.325858e-02,& - & 1.302390e-02,1.279536e-02,1.257275e-02,1.235586e-02,1.214450e-02,& - & 1.193848e-02,1.173761e-02,1.154172e-02/ - data absliq3(:,13) / & - & 3.118678e-02,4.483573e-02,4.902244e-02,4.964059e-02,4.868059e-02,& - & 4.696101e-02,4.486300e-02,4.257948e-02,4.021383e-02,3.782356e-02,& - & 3.742657e-02,3.603843e-02,3.470737e-02,3.344343e-02,3.224992e-02,& - & 3.112640e-02,3.007038e-02,2.907835e-02,2.814632e-02,2.727021e-02,& - & 2.644598e-02,2.566981e-02,2.493808e-02,2.424745e-02,2.359483e-02,& - & 2.297739e-02,2.239252e-02,2.183785e-02,2.117925e-02,2.070756e-02,& - & 2.024699e-02,1.979812e-02,1.936131e-02,1.893669e-02,1.852428e-02,& - & 1.812396e-02,1.773555e-02,1.735881e-02,1.699345e-02,1.663916e-02,& - & 1.629560e-02,1.596244e-02,1.563933e-02,1.532591e-02,1.502185e-02,& - & 1.472680e-02,1.444043e-02,1.416242e-02,1.389246e-02,1.363023e-02,& - & 1.337545e-02,1.312783e-02,1.288711e-02,1.265302e-02,1.242532e-02,& - & 1.220376e-02,1.198811e-02,1.177816e-02/ - data absliq3(:,14) / & - & 1.589879e-02,3.506523e-02,4.008515e-02,4.072696e-02,3.981012e-02,& - & 3.833056e-02,3.668287e-02,3.503265e-02,3.344965e-02,3.196089e-02,& - & 3.137121e-02,3.033481e-02,2.934152e-02,2.839725e-02,2.750374e-02,& - & 2.666039e-02,2.586536e-02,2.511614e-02,2.440996e-02,2.374397e-02,& - & 2.311538e-02,2.252152e-02,2.195989e-02,2.142815e-02,2.092415e-02,& - & 2.044588e-02,1.999154e-02,1.955943e-02,1.902540e-02,1.865979e-02,& - & 1.829955e-02,1.794554e-02,1.759834e-02,1.725841e-02,1.692600e-02,& - & 1.660128e-02,1.628433e-02,1.597515e-02,1.567370e-02,1.537987e-02,& - & 1.509356e-02,1.481461e-02,1.454286e-02,1.427815e-02,1.402027e-02,& - & 1.376906e-02,1.352431e-02,1.328583e-02,1.305344e-02,1.282695e-02,& - & 1.260616e-02,1.239091e-02,1.218100e-02,1.197627e-02,1.177655e-02,& - & 1.158167e-02,1.139148e-02,1.120583e-02/ - data absliq3(:,15) / & - & 5.020792e-03,2.176149e-02,2.554494e-02,2.594839e-02,2.536500e-02,& - & 2.452808e-02,2.368427e-02,2.291585e-02,2.224506e-02,2.167161e-02,& - & 2.114512e-02,2.058169e-02,2.004540e-02,1.953718e-02,1.905667e-02,& - & 1.860280e-02,1.817419e-02,1.776930e-02,1.738656e-02,1.702444e-02,& - & 1.668148e-02,1.635633e-02,1.604770e-02,1.575444e-02,1.547545e-02,& - & 1.520974e-02,1.495642e-02,1.471463e-02,1.436841e-02,1.417275e-02,& - & 1.397622e-02,1.377965e-02,1.358376e-02,1.338908e-02,1.319607e-02,& - & 1.300508e-02,1.281637e-02,1.263017e-02,1.244664e-02,1.226591e-02,& - & 1.208805e-02,1.191314e-02,1.174120e-02,1.157227e-02,1.140633e-02,& - & 1.124338e-02,1.108341e-02,1.092637e-02,1.077224e-02,1.062098e-02,& - & 1.047253e-02,1.032685e-02,1.018389e-02,1.004360e-02,9.905925e-03,& - & 9.770801e-03,9.638176e-03,9.507998e-03/ - data absliq3(:,16) / & - & 1.398301e-02,3.704987e-02,3.928249e-02,3.759325e-02,3.534122e-02,& - & 3.328979e-02,3.158282e-02,3.020512e-02,2.910579e-02,2.823262e-02,& - & 2.653908e-02,2.559978e-02,2.471139e-02,2.387688e-02,2.309574e-02,& - & 2.236567e-02,2.168353e-02,2.104590e-02,2.044933e-02,1.989053e-02,& - & 1.936639e-02,1.887404e-02,1.841087e-02,1.797450e-02,1.756277e-02,& - & 1.717372e-02,1.680557e-02,1.645673e-02,1.600733e-02,1.571652e-02,& - & 1.543078e-02,1.515061e-02,1.487636e-02,1.460824e-02,1.434636e-02,& - & 1.409077e-02,1.384144e-02,1.359831e-02,1.336129e-02,1.313026e-02,& - & 1.290509e-02,1.268563e-02,1.247173e-02,1.226323e-02,1.205997e-02,& - & 1.186180e-02,1.166854e-02,1.148005e-02,1.129616e-02,1.111674e-02,& - & 1.094163e-02,1.077068e-02,1.060377e-02,1.044075e-02,1.028151e-02,& - & 1.012590e-02,9.973826e-03,9.825151e-03/ - -!........................................! - end module module_radlw_cldprlw ! -!========================================! - - - -!========================================! - module module_radlw_kgb01 ! -!........................................! -! -! ********* the original program descriptions ********* ! -! ! -! rrtm longwave radiative transfer model ! -! atmospheric and environmental research, inc., cambridge, ma ! -! ! -! original version: e. j. mlawer, et al. ! -! revision for ncar ccm: michael j. iacono; september, 1998 ! -! ! -! this module contains 16 block data statements that include the ! -! absorption coefficients and other data for each of the 16 longwave ! -! spectral bands used in rrtm. here, the data are defined for 16 ! -! g-points, or sub-intervals, per band. these data are combined and ! -! weighted using a mapping procedure in routine rrtminit to reduce ! -! the total number of g-points from 256 to 140 for use in the ccm. ! -! ! -! ********* ********* end description ********* ********* ! -! - use machine, only : kind_phys - use module_radlw_parameters, only : NG01 -! - implicit none -! - private -! - integer, public :: MSA01, MSB01, MSF01 - parameter (MSA01=65, MSB01=235, MSF01=10) - - real (kind=kind_phys), public :: & - & absa(MSA01,NG01), absb(MSB01,NG01), selfref(MSF01,NG01), & - & forref(NG01), fracrefa(NG01), fracrefb(NG01) - -! the array absa(65,NG01) = ka(5,13,NG01) contains absorption coefs -! at the NG01=8 chosen g-values for a range of pressure levels>~100mb -! and temperatures. the first index in the array, jt, which runs from -! 1 to 5, corresponds to different temperatures. more specifically, -! jt = 1-5 means that the data are for the corresponding temperature of -! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the -! second index, jp, runs from 1 to 13 and refers to the corresponding -! pressure level in pref (e.g. jp = 1 is for a pressure of 1053.63 mb). -! the third index, ig, goes from 1 to NG01=8, and tells us which -! g-interval the absorption coefficients are for. - - data absa(:,1) / & - & 6.873586e-01,6.401567e-01,5.980173e-01,5.601714e-01,5.264165e-01,& - & 5.794078e-01,5.389091e-01,5.031812e-01,4.709597e-01,4.422472e-01,& - & 4.955921e-01,4.600878e-01,4.287860e-01,4.008121e-01,3.756918e-01,& - & 4.276590e-01,3.963226e-01,3.685490e-01,3.439527e-01,3.219174e-01,& - & 3.698981e-01,3.421539e-01,3.176002e-01,2.958416e-01,2.764741e-01,& - & 3.210326e-01,2.963644e-01,2.745485e-01,2.552552e-01,2.381442e-01,& - & 2.788130e-01,2.568133e-01,2.374974e-01,2.203761e-01,2.052149e-01,& - & 2.420256e-01,2.226887e-01,2.055443e-01,1.904433e-01,1.771123e-01,& - & 2.106855e-01,1.937484e-01,1.788137e-01,1.656663e-01,1.541195e-01,& - & 1.884727e-01,1.737195e-01,1.608784e-01,1.495804e-01,1.396524e-01,& - & 1.632693e-01,1.511410e-01,1.406816e-01,1.315247e-01,1.234346e-01,& - & 1.396468e-01,1.298071e-01,1.213466e-01,1.139821e-01,1.074976e-01,& - & 1.188569e-01,1.107280e-01,1.037045e-01,9.766051e-02,9.237845e-02/ - data absa(:,2) / & - & 2.534396e+00,2.420995e+00,2.316199e+00,2.217834e+00,2.125741e+00,& - & 2.111483e+00,2.016120e+00,1.926807e+00,1.844104e+00,1.767793e+00,& - & 1.770676e+00,1.689079e+00,1.612676e+00,1.542267e+00,1.477886e+00,& - & 1.497715e+00,1.427517e+00,1.362479e+00,1.302366e+00,1.247278e+00,& - & 1.270588e+00,1.210779e+00,1.155154e+00,1.103667e+00,1.056748e+00,& - & 1.080571e+00,1.029491e+00,9.818693e-01,9.381396e-01,8.979784e-01,& - & 9.194461e-01,8.756366e-01,8.350725e-01,7.973601e-01,7.630087e-01,& - & 7.832860e-01,7.455835e-01,7.105813e-01,6.784916e-01,6.490078e-01,& - & 6.720241e-01,6.395442e-01,6.091599e-01,5.815412e-01,5.560232e-01,& - & 5.856827e-01,5.578492e-01,5.317601e-01,5.081156e-01,4.864335e-01,& - & 5.017570e-01,4.784925e-01,4.573379e-01,4.380174e-01,4.204626e-01,& - & 4.279394e-01,4.085994e-01,3.912864e-01,3.757387e-01,3.615201e-01,& - & 3.605024e-01,3.446525e-01,3.307569e-01,3.181926e-01,3.068010e-01/ - data absa(:,3) / & - & 7.257267e+00,7.015020e+00,6.776414e+00,6.549252e+00,6.338234e+00,& - & 6.198131e+00,5.981201e+00,5.775218e+00,5.581760e+00,5.402037e+00,& - & 5.273253e+00,5.086056e+00,4.910910e+00,4.747458e+00,4.596699e+00,& - & 4.509401e+00,4.348021e+00,4.197742e+00,4.058893e+00,3.928698e+00,& - & 3.856719e+00,3.716576e+00,3.588240e+00,3.468781e+00,3.357496e+00,& - & 3.296517e+00,3.176113e+00,3.064881e+00,2.963395e+00,2.865736e+00,& - & 2.813844e+00,2.709672e+00,2.614155e+00,2.525940e+00,2.440753e+00,& - & 2.398993e+00,2.309538e+00,2.227655e+00,2.150681e+00,2.076591e+00,& - & 2.065007e+00,1.987271e+00,1.915863e+00,1.847999e+00,1.783026e+00,& - & 1.805832e+00,1.738620e+00,1.675822e+00,1.615692e+00,1.558027e+00,& - & 1.540431e+00,1.484556e+00,1.432123e+00,1.380812e+00,1.331620e+00,& - & 1.314274e+00,1.268615e+00,1.223956e+00,1.181097e+00,1.140353e+00,& - & 1.117756e+00,1.080141e+00,1.043286e+00,1.007542e+00,9.741095e-01/ - data absa(:,4) / & - & 2.982228e+01,2.893748e+01,2.807294e+01,2.725772e+01,2.646121e+01,& - & 2.747046e+01,2.667256e+01,2.589011e+01,2.511276e+01,2.437019e+01,& - & 2.513356e+01,2.438309e+01,2.364621e+01,2.292277e+01,2.222352e+01,& - & 2.283748e+01,2.214159e+01,2.146459e+01,2.079804e+01,2.014479e+01,& - & 2.058768e+01,1.995365e+01,1.934213e+01,1.872688e+01,1.812404e+01,& - & 1.839697e+01,1.783936e+01,1.728998e+01,1.673880e+01,1.619743e+01,& - & 1.624751e+01,1.577008e+01,1.528565e+01,1.480817e+01,1.432883e+01,& - & 1.420090e+01,1.380227e+01,1.339335e+01,1.297853e+01,1.255252e+01,& - & 1.234566e+01,1.201055e+01,1.166492e+01,1.130291e+01,1.092780e+01,& - & 1.094146e+01,1.064262e+01,1.033313e+01,1.000401e+01,9.665918e+00,& - & 9.472126e+00,9.210186e+00,8.932034e+00,8.638601e+00,8.342547e+00,& - & 8.094214e+00,7.864939e+00,7.620881e+00,7.366361e+00,7.116755e+00,& - & 6.834321e+00,6.638517e+00,6.429566e+00,6.217516e+00,6.008021e+00/ - data absa(:,5) / & - & 1.312221e+02,1.278083e+02,1.243354e+02,1.211648e+02,1.181091e+02,& - & 1.350714e+02,1.313366e+02,1.279551e+02,1.246081e+02,1.215434e+02,& - & 1.381675e+02,1.343636e+02,1.307987e+02,1.273763e+02,1.241864e+02,& - & 1.402241e+02,1.363618e+02,1.325349e+02,1.288720e+02,1.254054e+02,& - & 1.403162e+02,1.364805e+02,1.325499e+02,1.288244e+02,1.251884e+02,& - & 1.383684e+02,1.344907e+02,1.305668e+02,1.268925e+02,1.233479e+02,& - & 1.346453e+02,1.307925e+02,1.269947e+02,1.234014e+02,1.199129e+02,& - & 1.290807e+02,1.254006e+02,1.218308e+02,1.183842e+02,1.151219e+02,& - & 1.219639e+02,1.186237e+02,1.153176e+02,1.121279e+02,1.091048e+02,& - & 1.136653e+02,1.107059e+02,1.076520e+02,1.047395e+02,1.019546e+02,& - & 1.041992e+02,1.013854e+02,9.864704e+01,9.597822e+01,9.335551e+01,& - & 9.484422e+01,9.230293e+01,8.975732e+01,8.721164e+01,8.468875e+01,& - & 8.513441e+01,8.282690e+01,8.046509e+01,7.807935e+01,7.574896e+01/ - data absa(:,6) / & - & 3.611321e+02,3.556058e+02,3.498716e+02,3.440949e+02,3.383258e+02,& - & 4.036973e+02,3.951307e+02,3.863165e+02,3.776259e+02,3.683357e+02,& - & 4.423904e+02,4.329120e+02,4.220833e+02,4.110757e+02,4.002402e+02,& - & 4.728720e+02,4.629555e+02,4.521835e+02,4.409662e+02,4.298692e+02,& - & 4.995770e+02,4.894672e+02,4.784123e+02,4.673280e+02,4.565170e+02,& - & 5.268584e+02,5.163435e+02,5.042932e+02,4.921029e+02,4.797731e+02,& - & 5.537910e+02,5.417844e+02,5.284191e+02,5.152966e+02,5.013795e+02,& - & 5.804063e+02,5.666516e+02,5.515188e+02,5.356923e+02,5.196859e+02,& - & 6.022189e+02,5.883998e+02,5.719105e+02,5.545273e+02,5.375103e+02,& - & 6.154617e+02,6.006043e+02,5.839323e+02,5.669452e+02,5.493094e+02,& - & 6.127319e+02,5.972150e+02,5.792353e+02,5.616503e+02,5.441388e+02,& - & 5.989746e+02,5.823901e+02,5.649701e+02,5.478488e+02,5.312379e+02,& - & 5.752825e+02,5.586685e+02,5.421561e+02,5.260994e+02,5.109337e+02/ - data absa(:,7) / & - & 5.885042e+02,5.769384e+02,5.707579e+02,5.626011e+02,5.535640e+02,& - & 6.655113e+02,6.567831e+02,6.504269e+02,6.422605e+02,6.363201e+02,& - & 7.567693e+02,7.511298e+02,7.424994e+02,7.344772e+02,7.289640e+02,& - & 8.680281e+02,8.562017e+02,8.465945e+02,8.334892e+02,8.264376e+02,& - & 9.882567e+02,9.730189e+02,9.596136e+02,9.438705e+02,9.315972e+02,& - & 1.115747e+03,1.098869e+03,1.077767e+03,1.062948e+03,1.047237e+03,& - & 1.250526e+03,1.229082e+03,1.207014e+03,1.188007e+03,1.168853e+03,& - & 1.392960e+03,1.364986e+03,1.342222e+03,1.320097e+03,1.295147e+03,& - & 1.538669e+03,1.506223e+03,1.478062e+03,1.449829e+03,1.423487e+03,& - & 1.680943e+03,1.647770e+03,1.617210e+03,1.581259e+03,1.549281e+03,& - & 1.802059e+03,1.766738e+03,1.734451e+03,1.696284e+03,1.658330e+03,& - & 1.911848e+03,1.875069e+03,1.838838e+03,1.798507e+03,1.757837e+03,& - & 2.009601e+03,1.972060e+03,1.930678e+03,1.889381e+03,1.842748e+03/ - data absa(:,8) / & - & 1.034629e+03,1.012707e+03,1.001210e+03,9.870197e+02,9.647308e+02,& - & 1.235543e+03,1.207923e+03,1.193199e+03,1.165659e+03,1.151179e+03,& - & 1.474944e+03,1.452464e+03,1.427360e+03,1.385910e+03,1.367873e+03,& - & 1.743649e+03,1.720775e+03,1.695371e+03,1.648131e+03,1.643273e+03,& - & 2.052356e+03,2.019895e+03,1.999409e+03,1.962155e+03,1.929635e+03,& - & 2.411012e+03,2.375323e+03,2.334918e+03,2.314008e+03,2.300733e+03,& - & 2.806959e+03,2.795763e+03,2.730702e+03,2.706215e+03,2.682043e+03,& - & 3.250125e+03,3.240390e+03,3.188175e+03,3.142353e+03,3.124931e+03,& - & 3.739170e+03,3.706126e+03,3.670094e+03,3.636326e+03,3.610234e+03,& - & 4.281714e+03,4.262730e+03,4.230813e+03,4.174891e+03,4.155855e+03,& - & 4.928066e+03,4.893458e+03,4.853595e+03,4.794102e+03,4.767411e+03,& - & 5.694021e+03,5.633797e+03,5.565809e+03,5.500612e+03,5.456980e+03,& - & 6.556204e+03,6.483163e+03,6.394545e+03,6.324864e+03,6.236535e+03/ - -! the array absb(235,NG01) = kb(5,13:59,NG01) contains absorption coefs -! at the NG01=8 chosen g-values for a range of pressure levels < ~100mb -! and temperatures. the first index in the array, jt, which runs from -! 1 to 5, corresponds to different temperatures. more specifically, -! jt = 1-5 means that the data are for the corresponding temperature of -! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the -! second index, jp, runs from 13 to 59 and refers to the jpth reference -! pressure level (see taumol.f for the value of these pressure levels -! in mb). the third index, ig, goes from 1 to NG01=8, and tells us -! which g-interval the absorption coefficients are for. - - data absb(:,1) / & - & 1.188584e-01,1.107305e-01,1.037105e-01,9.766051e-02,9.238188e-02,& - & 1.036070e-01,9.688587e-02,9.120730e-02,8.634354e-02,8.216419e-02,& - & 9.010155e-02,8.472244e-02,8.017501e-02,7.631794e-02,7.305743e-02,& - & 7.648179e-02,7.215746e-02,6.852433e-02,6.545512e-02,6.284106e-02,& - & 6.447221e-02,6.099641e-02,5.810039e-02,5.565650e-02,5.352912e-02,& - & 5.400080e-02,5.121300e-02,4.890102e-02,4.693351e-02,4.521545e-02,& - & 4.542776e-02,4.319926e-02,4.134876e-02,3.976658e-02,3.839206e-02,& - & 3.781988e-02,3.604408e-02,3.456457e-02,3.330315e-02,3.220864e-02,& - & 3.135820e-02,2.994580e-02,2.876145e-02,2.775883e-02,2.687872e-02,& - & 2.581924e-02,2.470498e-02,2.376822e-02,2.297958e-02,2.226667e-02,& - & 2.123406e-02,2.035402e-02,1.961335e-02,1.898695e-02,1.840735e-02,& - & 1.748810e-02,1.679086e-02,1.620285e-02,1.570215e-02,1.523807e-02,& - & 1.436060e-02,1.380883e-02,1.334747e-02,1.294098e-02,1.257088e-02,& - & 1.175465e-02,1.132074e-02,1.095502e-02,1.062921e-02,1.033264e-02,& - & 9.563612e-03,9.223051e-03,8.934014e-03,8.669021e-03,8.430844e-03,& - & 7.749971e-03,7.481732e-03,7.250077e-03,7.035521e-03,6.844088e-03,& - & 6.214530e-03,6.001678e-03,5.814696e-03,5.643096e-03,5.488414e-03,& - & 4.960398e-03,4.790792e-03,4.639392e-03,4.501353e-03,4.376270e-03,& - & 3.920287e-03,3.785376e-03,3.662577e-03,3.551204e-03,3.449820e-03,& - & 3.092492e-03,2.984976e-03,2.885389e-03,2.795821e-03,2.713936e-03,& - & 2.433119e-03,2.346259e-03,2.266677e-03,2.194460e-03,2.127861e-03,& - & 1.927424e-03,1.857059e-03,1.793121e-03,1.735061e-03,1.680785e-03,& - & 1.532498e-03,1.475127e-03,1.423296e-03,1.376226e-03,1.332009e-03,& - & 1.225313e-03,1.178321e-03,1.135859e-03,1.097381e-03,1.061099e-03,& - & 9.908422e-04,9.521286e-04,9.168505e-04,8.849446e-04,8.550764e-04,& - & 8.003018e-04,7.682560e-04,7.389205e-04,7.124494e-04,6.879327e-04,& - & 6.446306e-04,6.181921e-04,5.937916e-04,5.718350e-04,5.516887e-04,& - & 5.272378e-04,5.052942e-04,4.847778e-04,4.668093e-04,4.502631e-04,& - & 4.323103e-04,4.136385e-04,3.966537e-04,3.820798e-04,3.682234e-04,& - & 3.539504e-04,3.385929e-04,3.245215e-04,3.114446e-04,3.008142e-04,& - & 2.913011e-04,2.781936e-04,2.664020e-04,2.553088e-04,2.464106e-04,& - & 2.401432e-04,2.288166e-04,2.188161e-04,2.094179e-04,2.010604e-04,& - & 1.978038e-04,1.879940e-04,1.793354e-04,1.714942e-04,1.643685e-04,& - & 1.632372e-04,1.547008e-04,1.471876e-04,1.405816e-04,1.345046e-04,& - & 1.354597e-04,1.279606e-04,1.214294e-04,1.157400e-04,1.106055e-04,& - & 1.123297e-04,1.055342e-04,1.000624e-04,9.510752e-05,9.076246e-05,& - & 9.304149e-05,8.710412e-05,8.230814e-05,7.799569e-05,7.428400e-05,& - & 7.744272e-05,7.228909e-05,6.795731e-05,6.437853e-05,6.115927e-05,& - & 6.463576e-05,6.018045e-05,5.642352e-05,5.331694e-05,5.053712e-05,& - & 5.386399e-05,5.007815e-05,4.682627e-05,4.412007e-05,4.172388e-05,& - & 4.492046e-05,4.163750e-05,3.882739e-05,3.647523e-05,3.439931e-05,& - & 3.778490e-05,3.494245e-05,3.251780e-05,3.048926e-05,2.870313e-05,& - & 3.195692e-05,2.948929e-05,2.740031e-05,2.559504e-05,2.412029e-05,& - & 2.705405e-05,2.490101e-05,2.310197e-05,2.155015e-05,2.028047e-05,& - & 2.292727e-05,2.104342e-05,1.949108e-05,1.815590e-05,1.703116e-05,& - & 1.945640e-05,1.781082e-05,1.646905e-05,1.532495e-05,1.436078e-05,& - & 1.651526e-05,1.512788e-05,1.400328e-05,1.304437e-05,1.224340e-05/ - data absb(:,2) / & - & 3.605168e-01,3.446729e-01,3.307613e-01,3.181930e-01,3.068206e-01,& - & 3.106979e-01,2.980315e-01,2.868973e-01,2.769289e-01,2.679642e-01,& - & 2.692210e-01,2.592085e-01,2.503679e-01,2.425067e-01,2.354710e-01,& - & 2.290957e-01,2.212295e-01,2.143123e-01,2.082163e-01,2.028275e-01,& - & 1.943168e-01,1.881820e-01,1.828186e-01,1.781326e-01,1.740759e-01,& - & 1.638339e-01,1.590996e-01,1.549740e-01,1.514337e-01,1.483488e-01,& - & 1.390994e-01,1.354779e-01,1.323701e-01,1.297430e-01,1.274470e-01,& - & 1.169263e-01,1.141864e-01,1.118341e-01,1.098810e-01,1.081735e-01,& - & 9.788549e-02,9.579619e-02,9.404559e-02,9.258549e-02,9.134133e-02,& - & 8.144505e-02,7.986496e-02,7.856666e-02,7.750292e-02,7.658602e-02,& - & 6.770016e-02,6.651535e-02,6.556165e-02,6.478476e-02,6.409879e-02,& - & 5.645282e-02,5.558899e-02,5.489336e-02,5.433090e-02,5.380187e-02,& - & 4.696176e-02,4.633534e-02,4.583018e-02,4.539146e-02,4.496490e-02,& - & 3.894916e-02,3.848467e-02,3.809532e-02,3.774612e-02,3.740000e-02,& - & 3.201342e-02,3.165418e-02,3.134882e-02,3.105146e-02,3.076431e-02,& - & 2.613763e-02,2.584822e-02,2.559462e-02,2.534416e-02,2.510416e-02,& - & 2.098921e-02,2.074392e-02,2.052438e-02,2.031312e-02,2.010239e-02,& - & 1.673832e-02,1.652799e-02,1.633709e-02,1.614961e-02,1.596643e-02,& - & 1.317026e-02,1.298803e-02,1.281625e-02,1.265058e-02,1.249225e-02,& - & 1.035633e-02,1.019808e-02,1.004780e-02,9.903418e-03,9.766774e-03,& - & 8.128671e-03,7.992982e-03,7.864123e-03,7.739102e-03,7.621329e-03,& - & 6.438532e-03,6.323892e-03,6.215053e-03,6.109816e-03,6.009887e-03,& - & 5.116032e-03,5.019410e-03,4.927611e-03,4.838737e-03,4.754145e-03,& - & 4.085361e-03,4.003710e-03,3.926693e-03,3.851905e-03,3.780686e-03,& - & 3.294793e-03,3.225983e-03,3.161350e-03,3.098795e-03,3.038790e-03,& - & 2.654824e-03,2.596751e-03,2.542422e-03,2.490165e-03,2.439570e-03,& - & 2.135421e-03,2.086011e-03,2.039997e-03,1.996502e-03,1.954154e-03,& - & 1.741515e-03,1.699372e-03,1.660606e-03,1.625229e-03,1.590232e-03,& - & 1.422944e-03,1.386764e-03,1.354250e-03,1.325714e-03,1.296758e-03,& - & 1.161311e-03,1.131528e-03,1.104103e-03,1.078366e-03,1.056575e-03,& - & 9.510751e-04,9.259328e-04,9.025109e-04,8.807753e-04,8.627728e-04,& - & 7.796901e-04,7.582461e-04,7.382069e-04,7.197135e-04,7.026640e-04,& - & 6.386579e-04,6.202528e-04,6.031701e-04,5.873169e-04,5.729906e-04,& - & 5.238403e-04,5.079577e-04,4.933548e-04,4.797553e-04,4.675951e-04,& - & 4.313947e-04,4.176277e-04,4.050594e-04,3.934249e-04,3.829754e-04,& - & 3.549467e-04,3.424789e-04,3.322156e-04,3.222176e-04,3.132544e-04,& - & 2.917001e-04,2.809828e-04,2.720832e-04,2.634467e-04,2.557729e-04,& - & 2.408104e-04,2.316017e-04,2.234803e-04,2.165479e-04,2.099627e-04,& - & 1.992853e-04,1.913645e-04,1.844206e-04,1.784771e-04,1.728420e-04,& - & 1.646597e-04,1.580460e-04,1.520893e-04,1.469987e-04,1.421772e-04,& - & 1.361048e-04,1.304423e-04,1.253118e-04,1.209676e-04,1.168289e-04,& - & 1.132954e-04,1.084974e-04,1.041173e-04,1.004307e-04,9.691007e-05,& - & 9.471162e-05,9.067809e-05,8.696270e-05,8.362699e-05,8.084690e-05,& - & 7.922920e-05,7.582534e-05,7.267746e-05,6.985226e-05,6.749704e-05,& - & 6.632919e-05,6.344568e-05,6.078590e-05,5.839160e-05,5.627600e-05,& - & 5.562205e-05,5.317000e-05,5.093525e-05,4.890964e-05,4.712934e-05,& - & 4.696079e-05,4.493571e-05,4.309428e-05,4.143710e-05,3.998691e-05/ - data absb(:,3) / & - & 1.117735e+00,1.080184e+00,1.043270e+00,1.007591e+00,9.742075e-01,& - & 9.789529e-01,9.478280e-01,9.173596e-01,8.880541e-01,8.606540e-01,& - & 8.665203e-01,8.405564e-01,8.150066e-01,7.907292e-01,7.680385e-01,& - & 7.528144e-01,7.310444e-01,7.099363e-01,6.899365e-01,6.711492e-01,& - & 6.497549e-01,6.319656e-01,6.148742e-01,5.984917e-01,5.832503e-01,& - & 5.562434e-01,5.419053e-01,5.281320e-01,5.150724e-01,5.031397e-01,& - & 4.799351e-01,4.685626e-01,4.576734e-01,4.475964e-01,4.384044e-01,& - & 4.092397e-01,4.002831e-01,3.919350e-01,3.843158e-01,3.773650e-01,& - & 3.469867e-01,3.401335e-01,3.338834e-01,3.281490e-01,3.229115e-01,& - & 2.920308e-01,2.869414e-01,2.822447e-01,2.779669e-01,2.741207e-01,& - & 2.455328e-01,2.417119e-01,2.382267e-01,2.350559e-01,2.323134e-01,& - & 2.072847e-01,2.044343e-01,2.018713e-01,1.996664e-01,1.978283e-01,& - & 1.744516e-01,1.723576e-01,1.705750e-01,1.690697e-01,1.678974e-01,& - & 1.462535e-01,1.447794e-01,1.435404e-01,1.425768e-01,1.417883e-01,& - & 1.212998e-01,1.202610e-01,1.194272e-01,1.187237e-01,1.180982e-01,& - & 9.980898e-02,9.905759e-02,9.842935e-02,9.785915e-02,9.729150e-02,& - & 8.048081e-02,7.987364e-02,7.932137e-02,7.879581e-02,7.824715e-02,& - & 6.432927e-02,6.378559e-02,6.327049e-02,6.276873e-02,6.224728e-02,& - & 5.053836e-02,5.003417e-02,4.954504e-02,4.906871e-02,4.858913e-02,& - & 3.965301e-02,3.919128e-02,3.874116e-02,3.830937e-02,3.788280e-02,& - & 3.102984e-02,3.061751e-02,3.021681e-02,2.983636e-02,2.946761e-02,& - & 2.453367e-02,2.417416e-02,2.382999e-02,2.350620e-02,2.319466e-02,& - & 1.944696e-02,1.913844e-02,1.884555e-02,1.857251e-02,1.831163e-02,& - & 1.548875e-02,1.522716e-02,1.497895e-02,1.474909e-02,1.453075e-02,& - & 1.246599e-02,1.224514e-02,1.203566e-02,1.184048e-02,1.165849e-02,& - & 1.001892e-02,9.831572e-03,9.656160e-03,9.490883e-03,9.339558e-03,& - & 8.031171e-03,7.873503e-03,7.723956e-03,7.587383e-03,7.460943e-03,& - & 6.536561e-03,6.404470e-03,6.279203e-03,6.170236e-03,6.065862e-03,& - & 5.329766e-03,5.218385e-03,5.114746e-03,5.030483e-03,4.942761e-03,& - & 4.335118e-03,4.250624e-03,4.165045e-03,4.080638e-03,4.023345e-03,& - & 3.539198e-03,3.471119e-03,3.400120e-03,3.328524e-03,3.281959e-03,& - & 2.890614e-03,2.835406e-03,2.776260e-03,2.715755e-03,2.661208e-03,& - & 2.357360e-03,2.312203e-03,2.262839e-03,2.212077e-03,2.165843e-03,& - & 1.923542e-03,1.886625e-03,1.845448e-03,1.802975e-03,1.763796e-03,& - & 1.574914e-03,1.544842e-03,1.510381e-03,1.475005e-03,1.442030e-03,& - & 1.287106e-03,1.256459e-03,1.233732e-03,1.204323e-03,1.176708e-03,& - & 1.049409e-03,1.023785e-03,1.005219e-03,9.806497e-04,9.576227e-04,& - & 8.602653e-04,8.390343e-04,8.196353e-04,8.033423e-04,7.842166e-04,& - & 7.069383e-04,6.895249e-04,6.734499e-04,6.600623e-04,6.441337e-04,& - & 5.778267e-04,5.658893e-04,5.525933e-04,5.415255e-04,5.282749e-04,& - & 4.733282e-04,4.635497e-04,4.526321e-04,4.433938e-04,4.323965e-04,& - & 3.916769e-04,3.837609e-04,3.748737e-04,3.672298e-04,3.581675e-04,& - & 3.260897e-04,3.197170e-04,3.125560e-04,3.047231e-04,2.988326e-04,& - & 2.715190e-04,2.664575e-04,2.607270e-04,2.543079e-04,2.494784e-04,& - & 2.261227e-04,2.222121e-04,2.176140e-04,2.123909e-04,2.073056e-04,& - & 1.887195e-04,1.857905e-04,1.821065e-04,1.778970e-04,1.737202e-04,& - & 1.603824e-04,1.582205e-04,1.553478e-04,1.519685e-04,1.486144e-04/ - data absb(:,4) / & - & 6.834865e+00,6.638031e+00,6.429193e+00,6.217201e+00,6.008780e+00,& - & 5.800502e+00,5.633283e+00,5.458002e+00,5.280728e+00,5.109059e+00,& - & 5.003790e+00,4.863288e+00,4.717391e+00,4.571090e+00,4.426601e+00,& - & 4.337969e+00,4.221774e+00,4.101226e+00,3.978502e+00,3.857516e+00,& - & 3.805014e+00,3.707134e+00,3.606205e+00,3.503096e+00,3.401713e+00,& - & 3.336208e+00,3.253296e+00,3.167364e+00,3.080482e+00,2.995784e+00,& - & 2.947355e+00,2.877153e+00,2.804773e+00,2.732389e+00,2.662218e+00,& - & 2.571854e+00,2.512429e+00,2.452243e+00,2.392527e+00,2.335367e+00,& - & 2.225939e+00,2.176822e+00,2.127372e+00,2.078907e+00,2.033172e+00,& - & 1.906920e+00,1.866715e+00,1.826913e+00,1.788754e+00,1.752546e+00,& - & 1.627512e+00,1.595168e+00,1.564148e+00,1.534235e+00,1.506170e+00,& - & 1.391770e+00,1.366858e+00,1.342869e+00,1.320421e+00,1.299387e+00,& - & 1.185175e+00,1.166395e+00,1.148586e+00,1.131988e+00,1.116912e+00,& - & 1.004264e+00,9.905181e-01,9.776359e-01,9.662641e-01,9.559160e-01,& - & 8.417388e-01,8.319919e-01,8.232006e-01,8.151468e-01,8.080107e-01,& - & 7.001649e-01,6.931987e-01,6.869845e-01,6.813820e-01,6.766031e-01,& - & 5.704507e-01,5.653525e-01,5.607917e-01,5.568628e-01,5.534749e-01,& - & 4.605337e-01,4.566398e-01,4.532191e-01,4.502833e-01,4.478645e-01,& - & 3.651890e-01,3.620804e-01,3.593766e-01,3.570508e-01,3.550960e-01,& - & 2.891126e-01,2.866236e-01,2.844338e-01,2.825432e-01,2.808490e-01,& - & 2.281853e-01,2.261499e-01,2.243537e-01,2.227480e-01,2.212713e-01,& - & 1.820698e-01,1.804306e-01,1.789695e-01,1.776194e-01,1.763338e-01,& - & 1.455436e-01,1.442125e-01,1.429981e-01,1.418451e-01,1.406898e-01,& - & 1.167984e-01,1.156968e-01,1.146835e-01,1.136931e-01,1.126722e-01,& - & 9.462337e-02,9.372146e-02,9.287631e-02,9.203406e-02,9.115519e-02,& - & 7.645253e-02,7.569449e-02,7.499489e-02,7.427844e-02,7.352450e-02,& - & 6.153430e-02,6.089410e-02,6.028741e-02,5.969877e-02,5.906061e-02,& - & 5.030346e-02,4.977709e-02,4.927878e-02,4.883124e-02,4.830974e-02,& - & 4.117412e-02,4.072611e-02,4.032875e-02,4.003948e-02,3.960791e-02,& - & 3.358777e-02,3.330233e-02,3.298160e-02,3.261824e-02,3.243189e-02,& - & 2.749334e-02,2.728740e-02,2.702385e-02,2.671281e-02,2.659752e-02,& - & 2.250304e-02,2.235071e-02,2.213204e-02,2.186803e-02,2.162107e-02,& - & 1.837816e-02,1.825979e-02,1.807732e-02,1.785590e-02,1.765257e-02,& - & 1.500714e-02,1.491533e-02,1.476275e-02,1.457716e-02,1.441015e-02,& - & 1.229251e-02,1.221784e-02,1.209262e-02,1.193957e-02,1.180315e-02,& - & 1.004099e-02,9.893852e-03,9.874218e-03,9.748040e-03,9.638648e-03,& - & 8.171397e-03,8.047651e-03,8.030863e-03,7.926210e-03,7.838407e-03,& - & 6.692593e-03,6.591492e-03,6.517800e-03,6.491883e-03,6.421433e-03,& - & 5.497945e-03,5.414627e-03,5.354571e-03,5.334608e-03,5.278523e-03,& - & 4.469719e-03,4.438056e-03,4.388776e-03,4.373082e-03,4.328045e-03,& - & 3.653522e-03,3.627345e-03,3.586526e-03,3.573242e-03,3.536993e-03,& - & 3.024925e-03,3.005623e-03,2.973408e-03,2.965011e-03,2.936709e-03,& - & 2.523262e-03,2.511022e-03,2.486512e-03,2.459230e-03,2.461818e-03,& - & 2.104940e-03,2.098455e-03,2.080108e-03,2.059082e-03,2.064523e-03,& - & 1.756698e-03,1.754548e-03,1.741129e-03,1.724954e-03,1.712547e-03,& - & 1.470473e-03,1.471788e-03,1.462606e-03,1.450532e-03,1.441609e-03,& - & 1.261271e-03,1.266930e-03,1.262911e-03,1.255459e-03,1.249582e-03/ - data absb(:,5) / & - & 8.512491e+01,8.281789e+01,8.045453e+01,7.807747e+01,7.575748e+01,& - & 7.527586e+01,7.319452e+01,7.104618e+01,6.894920e+01,6.687898e+01,& - & 6.574123e+01,6.384006e+01,6.194865e+01,6.009889e+01,5.830196e+01,& - & 5.676452e+01,5.513466e+01,5.351162e+01,5.196349e+01,5.045125e+01,& - & 4.868854e+01,4.730744e+01,4.596922e+01,4.465121e+01,4.331755e+01,& - & 4.164537e+01,4.052060e+01,3.938392e+01,3.821696e+01,3.704723e+01,& - & 3.581955e+01,3.485774e+01,3.385868e+01,3.285578e+01,3.185656e+01,& - & 3.087423e+01,3.003561e+01,2.918254e+01,2.833009e+01,2.748358e+01,& - & 2.674838e+01,2.603623e+01,2.531031e+01,2.458874e+01,2.387883e+01,& - & 2.325291e+01,2.264394e+01,2.202625e+01,2.141668e+01,2.081767e+01,& - & 2.037032e+01,1.984862e+01,1.932860e+01,1.881130e+01,1.830020e+01,& - & 1.799206e+01,1.755058e+01,1.710670e+01,1.666381e+01,1.623132e+01,& - & 1.584843e+01,1.547436e+01,1.509239e+01,1.471539e+01,1.435165e+01,& - & 1.388650e+01,1.356357e+01,1.323969e+01,1.292521e+01,1.262307e+01,& - & 1.199693e+01,1.172589e+01,1.145851e+01,1.119949e+01,1.095746e+01,& - & 1.023584e+01,1.001291e+01,9.794489e+00,9.589520e+00,9.400820e+00,& - & 8.532244e+00,8.351509e+00,8.179837e+00,8.022518e+00,7.876143e+00,& - & 7.029361e+00,6.887036e+00,6.754492e+00,6.634188e+00,6.521676e+00,& - & 5.685501e+00,5.576110e+00,5.474649e+00,5.383094e+00,5.298611e+00,& - & 4.587155e+00,4.503349e+00,4.426229e+00,4.357221e+00,4.295379e+00,& - & 3.687765e+00,3.624432e+00,3.566819e+00,3.515520e+00,3.469867e+00,& - & 2.991966e+00,2.944257e+00,2.902101e+00,2.864655e+00,2.831590e+00,& - & 2.431976e+00,2.397002e+00,2.365777e+00,2.337979e+00,2.314688e+00,& - & 1.984670e+00,1.958656e+00,1.935385e+00,1.915332e+00,1.898912e+00,& - & 1.633896e+00,1.614415e+00,1.597441e+00,1.583157e+00,1.571785e+00,& - & 1.341002e+00,1.326168e+00,1.314542e+00,1.304562e+00,1.296937e+00,& - & 1.095988e+00,1.084830e+00,1.076138e+00,1.070043e+00,1.065093e+00,& - & 9.081362e-01,9.002150e-01,8.943365e-01,8.912659e-01,8.887799e-01,& - & 7.528582e-01,7.471623e-01,7.435455e-01,7.433726e-01,7.425094e-01,& - & 6.216230e-01,6.193471e-01,6.173088e-01,6.160044e-01,6.191547e-01,& - & 5.147423e-01,5.140072e-01,5.129511e-01,5.124184e-01,5.164068e-01,& - & 4.259526e-01,4.261768e-01,4.257458e-01,4.256694e-01,4.270394e-01,& - & 3.515497e-01,3.522294e-01,3.521867e-01,3.524054e-01,3.539326e-01,& - & 2.898826e-01,2.908672e-01,2.910261e-01,2.913808e-01,2.929261e-01,& - & 2.395717e-01,2.406798e-01,2.409791e-01,2.414377e-01,2.429683e-01,& - & 1.972602e-01,1.967066e-01,1.987234e-01,1.992277e-01,2.006390e-01,& - & 1.616156e-01,1.611992e-01,1.630014e-01,1.634608e-01,1.646967e-01,& - & 1.333012e-01,1.330779e-01,1.336616e-01,1.352413e-01,1.364007e-01,& - & 1.102540e-01,1.101901e-01,1.108204e-01,1.122956e-01,1.134089e-01,& - & 9.013788e-02,9.093119e-02,9.156268e-02,9.290376e-02,9.393475e-02,& - & 7.398692e-02,7.470780e-02,7.530101e-02,7.647781e-02,7.740043e-02,& - & 6.168555e-02,6.242483e-02,6.305700e-02,6.421687e-02,6.513125e-02,& - & 5.194243e-02,5.273049e-02,5.342356e-02,5.408332e-02,5.557184e-02,& - & 4.376803e-02,4.457709e-02,4.529952e-02,4.600050e-02,4.748291e-02,& - & 3.690363e-02,3.771451e-02,3.845073e-02,3.916861e-02,4.014536e-02,& - & 3.125863e-02,3.207418e-02,3.281862e-02,3.355084e-02,3.454136e-02,& - & 2.752628e-02,2.846420e-02,2.932109e-02,3.019102e-02,3.138385e-02/ - data absb(:,6) / & - & 5.752820e+02,5.585467e+02,5.422423e+02,5.261497e+02,5.109261e+02,& - & 5.432524e+02,5.276696e+02,5.128634e+02,4.984170e+02,4.840356e+02,& - & 5.064568e+02,4.928218e+02,4.790230e+02,4.657940e+02,4.527250e+02,& - & 4.680705e+02,4.554667e+02,4.431096e+02,4.301650e+02,4.173226e+02,& - & 4.286588e+02,4.168360e+02,4.044579e+02,3.921067e+02,3.801392e+02,& - & 3.874100e+02,3.761657e+02,3.645517e+02,3.533527e+02,3.428555e+02,& - & 3.452293e+02,3.347962e+02,3.247882e+02,3.150153e+02,3.057524e+02,& - & 3.034647e+02,2.943677e+02,2.855370e+02,2.771994e+02,2.692792e+02,& - & 2.636385e+02,2.559841e+02,2.486938e+02,2.417738e+02,2.347303e+02,& - & 2.267534e+02,2.205230e+02,2.144790e+02,2.082461e+02,2.018953e+02,& - & 1.940593e+02,1.887912e+02,1.833422e+02,1.778004e+02,1.723591e+02,& - & 1.658857e+02,1.612162e+02,1.564392e+02,1.517948e+02,1.471830e+02,& - & 1.423116e+02,1.383053e+02,1.343560e+02,1.304361e+02,1.266022e+02,& - & 1.232626e+02,1.199309e+02,1.166241e+02,1.133724e+02,1.101838e+02,& - & 1.076445e+02,1.048397e+02,1.020490e+02,9.927101e+01,9.652357e+01,& - & 9.449147e+01,9.207990e+01,8.968916e+01,8.729149e+01,8.492214e+01,& - & 8.161966e+01,7.960194e+01,7.754677e+01,7.551328e+01,7.356425e+01,& - & 6.981713e+01,6.807863e+01,6.634332e+01,6.467345e+01,6.308249e+01,& - & 5.858538e+01,5.713023e+01,5.571190e+01,5.436420e+01,5.313156e+01,& - & 4.887215e+01,4.768349e+01,4.654055e+01,4.550173e+01,4.455772e+01,& - & 4.049019e+01,3.954064e+01,3.866334e+01,3.787635e+01,3.716129e+01,& - & 3.376083e+01,3.302460e+01,3.236770e+01,3.177297e+01,3.124051e+01,& - & 2.815010e+01,2.759829e+01,2.711080e+01,2.667061e+01,2.627433e+01,& - & 2.353315e+01,2.312224e+01,2.275807e+01,2.243072e+01,2.215094e+01,& - & 1.982604e+01,1.951965e+01,1.924550e+01,1.901307e+01,1.882081e+01,& - & 1.663153e+01,1.640988e+01,1.621653e+01,1.605897e+01,1.593329e+01,& - & 1.388824e+01,1.373057e+01,1.359700e+01,1.350142e+01,1.342639e+01,& - & 1.173533e+01,1.162921e+01,1.154792e+01,1.149659e+01,1.146322e+01,& - & 9.910382e+00,9.840882e+00,9.800180e+00,9.791236e+00,9.792204e+00,& - & 8.338884e+00,8.310818e+00,8.300467e+00,8.305890e+00,8.350007e+00,& - & 7.024660e+00,7.026067e+00,7.036098e+00,7.056825e+00,7.122995e+00,& - & 5.910802e+00,5.932872e+00,5.957102e+00,5.989125e+00,6.044279e+00,& - & 4.957048e+00,4.992718e+00,5.026054e+00,5.066524e+00,5.128477e+00,& - & 4.149113e+00,4.193687e+00,4.232631e+00,4.278156e+00,4.343098e+00,& - & 3.475117e+00,3.524479e+00,3.566903e+00,3.616189e+00,3.681214e+00,& - & 2.898047e+00,2.920758e+00,2.991100e+00,3.041221e+00,3.104844e+00,& - & 2.403824e+00,2.426443e+00,2.492814e+00,2.541150e+00,2.601269e+00,& - & 2.005563e+00,2.028669e+00,2.070384e+00,2.138256e+00,2.195571e+00,& - & 1.677313e+00,1.699833e+00,1.739744e+00,1.803638e+00,1.858281e+00,& - & 1.380964e+00,1.419212e+00,1.456544e+00,1.515550e+00,1.566027e+00,& - & 1.144811e+00,1.179689e+00,1.213717e+00,1.266730e+00,1.312698e+00,& - & 9.633002e-01,9.966121e-01,1.029009e+00,1.079266e+00,1.123765e+00,& - & 8.179431e-01,8.505309e-01,8.821859e-01,9.175041e-01,9.752531e-01,& - & 6.947530e-01,7.264339e-01,7.569261e-01,7.909790e-01,8.474302e-01,& - & 5.905893e-01,6.212258e-01,6.503137e-01,6.828478e-01,7.251909e-01,& - & 5.048534e-01,5.345532e-01,5.625916e-01,5.940099e-01,6.352787e-01,& - & 4.534170e-01,4.845147e-01,5.148627e-01,5.491796e-01,5.942442e-01/ - data absb(:,7) / & - & 2.009850e+03,1.972721e+03,1.931973e+03,1.888786e+03,1.842337e+03,& - & 2.089658e+03,2.047897e+03,1.999985e+03,1.952047e+03,1.905455e+03,& - & 2.148088e+03,2.097314e+03,2.048909e+03,1.997604e+03,1.947339e+03,& - & 2.178053e+03,2.126502e+03,2.075408e+03,2.021413e+03,1.967883e+03,& - & 2.184361e+03,2.133521e+03,2.078562e+03,2.023480e+03,1.967446e+03,& - & 2.171974e+03,2.117225e+03,2.061841e+03,2.003477e+03,1.946557e+03,& - & 2.135019e+03,2.080328e+03,2.022958e+03,1.965176e+03,1.908644e+03,& - & 2.072149e+03,2.016896e+03,1.961269e+03,1.904727e+03,1.847614e+03,& - & 1.986068e+03,1.931850e+03,1.875804e+03,1.820674e+03,1.766343e+03,& - & 1.873668e+03,1.820913e+03,1.766946e+03,1.715598e+03,1.666217e+03,& - & 1.742213e+03,1.692948e+03,1.644634e+03,1.598475e+03,1.553929e+03,& - & 1.600555e+03,1.556418e+03,1.513790e+03,1.472252e+03,1.432352e+03,& - & 1.453515e+03,1.414712e+03,1.377497e+03,1.340076e+03,1.304437e+03,& - & 1.309077e+03,1.274411e+03,1.240345e+03,1.207182e+03,1.175063e+03,& - & 1.168232e+03,1.137241e+03,1.107248e+03,1.077854e+03,1.050763e+03,& - & 1.033976e+03,1.006921e+03,9.808276e+02,9.562390e+02,9.335413e+02,& - & 9.078413e+02,8.850084e+02,8.634978e+02,8.436024e+02,8.245219e+02,& - & 7.908981e+02,7.721570e+02,7.554744e+02,7.396845e+02,7.244805e+02,& - & 6.844369e+02,6.705252e+02,6.574840e+02,6.449036e+02,6.326284e+02,& - & 5.907426e+02,5.800388e+02,5.697898e+02,5.597642e+02,5.502255e+02,& - & 5.080865e+02,4.999726e+02,4.918342e+02,4.840416e+02,4.770977e+02,& - & 4.372921e+02,4.307798e+02,4.246055e+02,4.192538e+02,4.143678e+02,& - & 3.762074e+02,3.714803e+02,3.674506e+02,3.640296e+02,3.607530e+02,& - & 3.242892e+02,3.212032e+02,3.188615e+02,3.168326e+02,3.148941e+02,& - & 2.804244e+02,2.787489e+02,2.776849e+02,2.766591e+02,2.758353e+02,& - & 2.423718e+02,2.418043e+02,2.418276e+02,2.416205e+02,2.416267e+02,& - & 2.093882e+02,2.096561e+02,2.102318e+02,2.108345e+02,2.116110e+02,& - & 1.818268e+02,1.827248e+02,1.837024e+02,1.848664e+02,1.862412e+02,& - & 1.581482e+02,1.594821e+02,1.608207e+02,1.623492e+02,1.641757e+02,& - & 1.375556e+02,1.392762e+02,1.408899e+02,1.426376e+02,1.449162e+02,& - & 1.196668e+02,1.216621e+02,1.235565e+02,1.255629e+02,1.280685e+02,& - & 1.040396e+02,1.062051e+02,1.083071e+02,1.105537e+02,1.131854e+02,& - & 9.031610e+01,9.257200e+01,9.482417e+01,9.720372e+01,9.998387e+01,& - & 7.833343e+01,8.062012e+01,8.294762e+01,8.539137e+01,8.825188e+01,& - & 6.795313e+01,7.021011e+01,7.255161e+01,7.503931e+01,7.793264e+01,& - & 5.875565e+01,6.086892e+01,6.333797e+01,6.578509e+01,6.867079e+01,& - & 5.056430e+01,5.261937e+01,5.506362e+01,5.748823e+01,6.033465e+01,& - & 4.376241e+01,4.576299e+01,4.805226e+01,5.057137e+01,5.334385e+01,& - & 3.799456e+01,3.990847e+01,4.213092e+01,4.463730e+01,4.733752e+01,& - & 3.280882e+01,3.470782e+01,3.685211e+01,3.930196e+01,4.194882e+01,& - & 2.824924e+01,3.007021e+01,3.210226e+01,3.449769e+01,3.706214e+01,& - & 2.477498e+01,2.656128e+01,2.851645e+01,3.082565e+01,3.331701e+01,& - & 2.203423e+01,2.381118e+01,2.573445e+01,2.786912e+01,3.039691e+01,& - & 1.965611e+01,2.143227e+01,2.332817e+01,2.543610e+01,2.789405e+01,& - & 1.756676e+01,1.937588e+01,2.123435e+01,2.334023e+01,2.566745e+01,& - & 1.583740e+01,1.771984e+01,1.958441e+01,2.169535e+01,2.406093e+01,& - & 1.537303e+01,1.754936e+01,1.968587e+01,2.202946e+01,2.466408e+01/ - data absb(:,8) / & - & 6.542090e+03,6.440177e+03,6.392552e+03,6.293362e+03,6.245077e+03,& - & 7.468852e+03,7.410027e+03,7.301736e+03,7.193966e+03,7.088459e+03,& - & 8.541426e+03,8.423472e+03,8.307703e+03,8.168462e+03,8.050069e+03,& - & 9.633780e+03,9.506928e+03,9.364065e+03,9.222383e+03,9.080635e+03,& - & 1.076247e+04,1.061623e+04,1.046919e+04,1.031817e+04,1.013586e+04,& - & 1.198302e+04,1.177749e+04,1.162609e+04,1.143318e+04,1.123989e+04,& - & 1.320427e+04,1.301731e+04,1.281292e+04,1.260604e+04,1.236448e+04,& - & 1.452981e+04,1.429495e+04,1.402913e+04,1.380807e+04,1.355120e+04,& - & 1.584224e+04,1.556770e+04,1.532103e+04,1.504238e+04,1.474457e+04,& - & 1.718721e+04,1.689819e+04,1.655896e+04,1.627729e+04,1.594517e+04,& - & 1.852949e+04,1.820030e+04,1.784171e+04,1.748214e+04,1.710514e+04,& - & 1.986401e+04,1.946302e+04,1.904791e+04,1.862863e+04,1.821645e+04,& - & 2.111005e+04,2.065980e+04,2.019218e+04,1.973758e+04,1.928954e+04,& - & 2.221966e+04,2.174246e+04,2.125483e+04,2.077691e+04,2.029629e+04,& - & 2.325571e+04,2.274679e+04,2.222159e+04,2.171657e+04,2.120127e+04,& - & 2.420950e+04,2.366581e+04,2.309433e+04,2.255776e+04,2.201281e+04,& - & 2.504584e+04,2.446775e+04,2.386068e+04,2.328822e+04,2.271622e+04,& - & 2.579779e+04,2.517121e+04,2.455160e+04,2.393193e+04,2.333593e+04,& - & 2.642329e+04,2.576206e+04,2.511855e+04,2.447767e+04,2.385147e+04,& - & 2.693667e+04,2.625372e+04,2.559207e+04,2.493458e+04,2.429219e+04,& - & 2.735499e+04,2.666845e+04,2.597857e+04,2.530995e+04,2.465237e+04,& - & 2.771205e+04,2.701309e+04,2.631130e+04,2.563293e+04,2.496250e+04,& - & 2.806467e+04,2.735257e+04,2.663557e+04,2.594727e+04,2.529821e+04,& - & 2.842849e+04,2.770413e+04,2.697665e+04,2.627738e+04,2.561983e+04,& - & 2.884921e+04,2.811312e+04,2.737321e+04,2.666315e+04,2.599622e+04,& - & 2.923150e+04,2.846169e+04,2.773543e+04,2.701629e+04,2.633911e+04,& - & 2.957196e+04,2.879413e+04,2.805493e+04,2.733466e+04,2.665006e+04,& - & 2.995818e+04,2.917114e+04,2.842589e+04,2.769624e+04,2.700298e+04,& - & 3.032373e+04,2.953293e+04,2.877954e+04,2.804263e+04,2.734178e+04,& - & 3.063296e+04,2.987218e+04,2.911303e+04,2.836782e+04,2.765941e+04,& - & 3.100125e+04,3.023628e+04,2.947446e+04,2.872034e+04,2.800490e+04,& - & 3.137182e+04,3.060751e+04,2.983624e+04,2.907825e+04,2.834668e+04,& - & 3.172667e+04,3.096232e+04,3.019102e+04,2.942557e+04,2.868740e+04,& - & 3.208750e+04,3.132314e+04,3.055100e+04,2.978127e+04,2.903625e+04,& - & 3.246549e+04,3.171009e+04,3.093546e+04,3.016302e+04,2.941115e+04,& - & 3.283491e+04,3.211129e+04,3.131158e+04,3.053744e+04,2.977971e+04,& - & 3.319409e+04,3.247780e+04,3.168400e+04,3.090703e+04,3.014686e+04,& - & 3.352492e+04,3.282000e+04,3.203236e+04,3.125340e+04,3.048929e+04,& - & 3.383799e+04,3.314552e+04,3.236284e+04,3.158513e+04,3.082218e+04,& - & 3.415991e+04,3.346496e+04,3.268875e+04,3.191527e+04,3.115218e+04,& - & 3.446079e+04,3.378139e+04,3.301314e+04,3.224437e+04,3.148195e+04,& - & 3.473362e+04,3.406627e+04,3.331190e+04,3.254800e+04,3.178705e+04,& - & 3.499148e+04,3.434121e+04,3.359344e+04,3.283934e+04,3.208253e+04,& - & 3.524898e+04,3.461754e+04,3.388306e+04,3.313195e+04,3.237755e+04,& - & 3.550487e+04,3.489245e+04,3.417037e+04,3.342630e+04,3.265778e+04,& - & 3.575597e+04,3.515803e+04,3.444871e+04,3.371371e+04,3.294819e+04,& - & 3.589743e+04,3.530421e+04,3.459686e+04,3.385961e+04,3.309168e+04/ - -! the array selfref contains the coefficient of the water vapor -! self-continuum (including the energy term). the first index -! refers to temperature in 7.2 degree increments. for instance, -! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, -! etc. the second index runs over the g-channel (1 to NG01=8). - - data selfref(:, 1) / & - & 3.85782e+00,3.48866e+00,3.15499e+00,2.85339e+00,2.58075e+00, & - & 2.33428e+00,2.11145e+00,1.91000e+00,1.72785e+00,1.56315e+00/ - data selfref(:, 2) / & - & 6.31101e+00,5.72251e+00,5.18891e+00,4.70509e+00,4.26639e+00, & - & 3.86862e+00,3.50795e+00,3.18091e+00,2.88437e+00,2.61549e+00/ - data selfref(:, 3) / & - & 6.22671e+00,5.64924e+00,5.12532e+00,4.64999e+00,4.21875e+00, & - & 3.82750e+00,3.47254e+00,3.15049e+00,2.85832e+00,2.59323e+00/ - data selfref(:, 4) / & - & 6.18196e+00,5.62148e+00,5.11189e+00,4.64856e+00,4.22728e+00, & - & 3.84424e+00,3.49594e+00,3.17925e+00,2.89129e+00,2.62944e+00/ - data selfref(:, 5) / & - & 6.26761e+00,5.75212e+00,5.27904e+00,4.84487e+00,4.44640e+00, & - & 4.08072e+00,3.74510e+00,3.43710e+00,3.15443e+00,2.89501e+00/ - data selfref(:, 6) / & - & 7.14853e+00,6.48281e+00,5.87910e+00,5.33162e+00,4.83513e+00, & - & 4.38489e+00,3.97659e+00,3.60630e+00,3.27051e+00,2.96598e+00/ - data selfref(:, 7) / & - & 6.99620e+00,6.42504e+00,5.90065e+00,5.41920e+00,4.97716e+00, & - & 4.57128e+00,4.19861e+00,3.85641e+00,3.54219e+00,3.25365e+00/ - data selfref(:, 8) / & - & 7.45019e+00,6.77368e+00,6.15864e+00,5.59946e+00,5.09108e+00, & - & 4.62888e+00,4.20866e+00,3.82661e+00,3.47925e+00,3.16345e+00/ - - data forref / & - & -8.15395564e-02,-5.11118397e-02,-2.34778970e-02,-1.43142389e-02, & - & -1.17182080e-02, 4.67175525e-03, 1.97165832e-02, 8.48740190e-02 / - - data fracrefa / & - & 0.2640497088, 0.2981655002, 0.2306305170, 0.1473007500, & - & 0.0469404794, 0.0075516403, 0.0044305800, 0.0009305400 / - data fracrefb / & - & 0.3287672997, 0.2784040570, 0.1999233812, 0.1357454211, & - & 0.0455209911, 0.0068867803, 0.0040154802, 0.0007363300 / - -!........................................! - end module module_radlw_kgb01 ! -!========================================! - - - -!========================================! - module module_radlw_kgb02 ! -!........................................! -! - use machine, only : kind_phys - use module_radlw_parameters, only : NG02 -! - implicit none -! - private -! - integer, public :: MSA02, MSB02, MSF02, MAF02 - parameter (MSA02=65, MSB02=235, MSF02=10, MAF02=13) - - real (kind=kind_phys), public :: & - & absa(MSA02,NG02), absb(MSB02,NG02), selfref(MSF02,NG02), & - & forref(NG02), fracrefa(NG02,MAF02), fracrefb(NG02), & - & refparam(MAF02) - -! the array absa(65,NG02) = ka(5,13,NG02) contains absorption coefs -! at the NG02=14 chosen g-values for a range of pressure levels>~100mb -! and temperatures. the first index in the array, jt, which runs from -! 1 to 5, corresponds to different temperatures. more specifically, -! jt = 1-5 means that the data are for the corresponding temperature of -! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the -! second index, jp, runs from 1 to 13 and refers to the corresponding -! pressure level in pref (e.g. jp = 1 is for a pressure of 1053.63 mb). -! the third index, ig, goes from 1 to NG02=14, and tells us which -! g-interval the absorption coefficients are for. - - data absa(:, 1) / & - & 1.440000e-02,1.555400e-02,1.673900e-02,1.796100e-02,1.937900e-02,& - & 1.145200e-02,1.228800e-02,1.323200e-02,1.419000e-02,1.527700e-02,& - & 8.998900e-03,9.596000e-03,1.032700e-02,1.106800e-02,1.188900e-02,& - & 7.107800e-03,7.542400e-03,8.071000e-03,8.663900e-03,9.292000e-03,& - & 5.663200e-03,5.961600e-03,6.342100e-03,6.807600e-03,7.294900e-03,& - & 4.534800e-03,4.726700e-03,5.001500e-03,5.339100e-03,5.731700e-03,& - & 3.648400e-03,3.773700e-03,3.958300e-03,4.205000e-03,4.506900e-03,& - & 2.948500e-03,3.030500e-03,3.150900e-03,3.327000e-03,3.547000e-03,& - & 2.402800e-03,2.447600e-03,2.527200e-03,2.645600e-03,2.808900e-03,& - & 1.989900e-03,2.004700e-03,2.058300e-03,2.140300e-03,2.264300e-03,& - & 1.647800e-03,1.659300e-03,1.703600e-03,1.773700e-03,1.882300e-03,& - & 1.359900e-03,1.369400e-03,1.406700e-03,1.467200e-03,1.561700e-03,& - & 1.115700e-03,1.124100e-03,1.155500e-03,1.207300e-03,1.286400e-03/ - data absa(:, 2) / & - & 3.890500e-02,4.242900e-02,4.651300e-02,5.058800e-02,5.502100e-02,& - & 3.080300e-02,3.346100e-02,3.654600e-02,3.992200e-02,4.344000e-02,& - & 2.414400e-02,2.601900e-02,2.828700e-02,3.095300e-02,3.373900e-02,& - & 1.908200e-02,2.037100e-02,2.203400e-02,2.401400e-02,2.625000e-02,& - & 1.520300e-02,1.609200e-02,1.727100e-02,1.872100e-02,2.047100e-02,& - & 1.216400e-02,1.276900e-02,1.357800e-02,1.464300e-02,1.592800e-02,& - & 9.781500e-03,1.018600e-02,1.074000e-02,1.148700e-02,1.243500e-02,& - & 7.924500e-03,8.168700e-03,8.549700e-03,9.064400e-03,9.761800e-03,& - & 6.472700e-03,6.583600e-03,6.839100e-03,7.194700e-03,7.682600e-03,& - & 5.324000e-03,5.357500e-03,5.519300e-03,5.770600e-03,6.116600e-03,& - & 4.378300e-03,4.406500e-03,4.539100e-03,4.745300e-03,5.031300e-03,& - & 3.596800e-03,3.620300e-03,3.729800e-03,3.899800e-03,4.137800e-03,& - & 2.950700e-03,2.970400e-03,3.061100e-03,3.201500e-03,3.401200e-03/ - data absa(:, 3) / & - & 1.063600e-01,1.168000e-01,1.282400e-01,1.401700e-01,1.526600e-01,& - & 8.444300e-02,9.248000e-02,1.014800e-01,1.109200e-01,1.210000e-01,& - & 6.595900e-02,7.186900e-02,7.877000e-02,8.625000e-02,9.405800e-02,& - & 5.168100e-02,5.602900e-02,6.120700e-02,6.708800e-02,7.319500e-02,& - & 4.073400e-02,4.393800e-02,4.777700e-02,5.228800e-02,5.724300e-02,& - & 3.224800e-02,3.453400e-02,3.734400e-02,4.073800e-02,4.467300e-02,& - & 2.573100e-02,2.724400e-02,2.933300e-02,3.184900e-02,3.486100e-02,& - & 2.069300e-02,2.165700e-02,2.315400e-02,2.501200e-02,2.726800e-02,& - & 1.673000e-02,1.734600e-02,1.832700e-02,1.971600e-02,2.138100e-02,& - & 1.358800e-02,1.401500e-02,1.465800e-02,1.568000e-02,1.693600e-02,& - & 1.118000e-02,1.152800e-02,1.206300e-02,1.291700e-02,1.395900e-02,& - & 9.192000e-03,9.476600e-03,9.924400e-03,1.063600e-02,1.150200e-02,& - & 7.551700e-03,7.786100e-03,8.160200e-03,8.750400e-03,9.468200e-03/ - data absa(:, 4) / & - & 2.655900e-01,2.777800e-01,2.898300e-01,3.011200e-01,3.115100e-01,& - & 2.141500e-01,2.237600e-01,2.337200e-01,2.429100e-01,2.514800e-01,& - & 1.711300e-01,1.786400e-01,1.867900e-01,1.941800e-01,2.015800e-01,& - & 1.368900e-01,1.430500e-01,1.493300e-01,1.557700e-01,1.621200e-01,& - & 1.095100e-01,1.148400e-01,1.199300e-01,1.252700e-01,1.304800e-01,& - & 8.767800e-02,9.201300e-02,9.629200e-02,1.005200e-01,1.049200e-01,& - & 7.027100e-02,7.364600e-02,7.725200e-02,8.067900e-02,8.429500e-02,& - & 5.629200e-02,5.902700e-02,6.191500e-02,6.478400e-02,6.766200e-02,& - & 4.504500e-02,4.730800e-02,4.959300e-02,5.199200e-02,5.435000e-02,& - & 3.608300e-02,3.803700e-02,3.992800e-02,4.186800e-02,4.382700e-02,& - & 2.968400e-02,3.130500e-02,3.286900e-02,3.445800e-02,3.606900e-02,& - & 2.442800e-02,2.576000e-02,2.703900e-02,2.834500e-02,2.967100e-02,& - & 2.009400e-02,2.117900e-02,2.222400e-02,2.330400e-02,2.439400e-02/ - data absa(:, 5) / & - & 4.729000e-01,4.892800e-01,5.088700e-01,5.332800e-01,5.621600e-01,& - & 3.847500e-01,3.976200e-01,4.128000e-01,4.321900e-01,4.547300e-01,& - & 3.097900e-01,3.199600e-01,3.310500e-01,3.453000e-01,3.621600e-01,& - & 2.500200e-01,2.580000e-01,2.667400e-01,2.770900e-01,2.894600e-01,& - & 2.021800e-01,2.084700e-01,2.154600e-01,2.231100e-01,2.323900e-01,& - & 1.628600e-01,1.684000e-01,1.739700e-01,1.799600e-01,1.868300e-01,& - & 1.305500e-01,1.360200e-01,1.405000e-01,1.452400e-01,1.504700e-01,& - & 1.044200e-01,1.095400e-01,1.135300e-01,1.173700e-01,1.214300e-01,& - & 8.338800e-02,8.784100e-02,9.168200e-02,9.481600e-02,9.805000e-02,& - & 6.701000e-02,7.059800e-02,7.401500e-02,7.676900e-02,7.937200e-02,& - & 5.511800e-02,5.805100e-02,6.086900e-02,6.311400e-02,6.529400e-02,& - & 4.530000e-02,4.772100e-02,5.004900e-02,5.189000e-02,5.368200e-02,& - & 3.722500e-02,3.923600e-02,4.113300e-02,4.263100e-02,4.412600e-02/ - data absa(:, 6) / & - & 8.422400e-01,9.226400e-01,1.007300e+00,1.093000e+00,1.179300e+00,& - & 6.759500e-01,7.423200e-01,8.124800e-01,8.830200e-01,9.561600e-01,& - & 5.290400e-01,5.804800e-01,6.375100e-01,6.964200e-01,7.572100e-01,& - & 4.131500e-01,4.540700e-01,4.997100e-01,5.488600e-01,5.996400e-01,& - & 3.246700e-01,3.553100e-01,3.915900e-01,4.316100e-01,4.742300e-01,& - & 2.557400e-01,2.778400e-01,3.057900e-01,3.381700e-01,3.727800e-01,& - & 2.031300e-01,2.179200e-01,2.387600e-01,2.638600e-01,2.920500e-01,& - & 1.628500e-01,1.720100e-01,1.867500e-01,2.059800e-01,2.284300e-01,& - & 1.317800e-01,1.368700e-01,1.467000e-01,1.608700e-01,1.782700e-01,& - & 1.076000e-01,1.102200e-01,1.166100e-01,1.269000e-01,1.403300e-01,& - & 8.847100e-02,9.074200e-02,9.608800e-02,1.047700e-01,1.160100e-01,& - & 7.272400e-02,7.464500e-02,7.916500e-02,8.646400e-02,9.584400e-02,& - & 5.971900e-02,6.135000e-02,6.517700e-02,7.130100e-02,7.908800e-02/ - data absa(:, 7) / & - & 1.841600e+00,2.037700e+00,2.235100e+00,2.435100e+00,2.635700e+00,& - & 1.505700e+00,1.669100e+00,1.834200e+00,2.003100e+00,2.170500e+00,& - & 1.198000e+00,1.332900e+00,1.470400e+00,1.609900e+00,1.748800e+00,& - & 9.440800e-01,1.056600e+00,1.170800e+00,1.287400e+00,1.401400e+00,& - & 7.405200e-01,8.333200e-01,9.300700e-01,1.026300e+00,1.122100e+00,& - & 5.750200e-01,6.514500e-01,7.310200e-01,8.122800e-01,8.928300e-01,& - & 4.441300e-01,5.056500e-01,5.711300e-01,6.383200e-01,7.063600e-01,& - & 3.421500e-01,3.912500e-01,4.441400e-01,4.996300e-01,5.560000e-01,& - & 2.627800e-01,3.015500e-01,3.440900e-01,3.894000e-01,4.363400e-01,& - & 2.039900e-01,2.345000e-01,2.686300e-01,3.055900e-01,3.441000e-01,& - & 1.689900e-01,1.945200e-01,2.230600e-01,2.536700e-01,2.860000e-01,& - & 1.400000e-01,1.613200e-01,1.850400e-01,2.104900e-01,2.373600e-01,& - & 1.158700e-01,1.336400e-01,1.533200e-01,1.744800e-01,1.969500e-01/ - data absa(:, 8) / & - & 4.775100e+00,5.279100e+00,5.793300e+00,6.308300e+00,6.832600e+00,& - & 4.004800e+00,4.444300e+00,4.894000e+00,5.358000e+00,5.826700e+00,& - & 3.240000e+00,3.625300e+00,4.020700e+00,4.423000e+00,4.821000e+00,& - & 2.588300e+00,2.921000e+00,3.265600e+00,3.615400e+00,3.964100e+00,& - & 2.055000e+00,2.339000e+00,2.635100e+00,2.933600e+00,3.237000e+00,& - & 1.613000e+00,1.853800e+00,2.102700e+00,2.358200e+00,2.618400e+00,& - & 1.254800e+00,1.456700e+00,1.666400e+00,1.882000e+00,2.103600e+00,& - & 9.668700e-01,1.134800e+00,1.311000e+00,1.493000e+00,1.680500e+00,& - & 7.384700e-01,8.759300e-01,1.022100e+00,1.174100e+00,1.331900e+00,& - & 5.677600e-01,6.801700e-01,8.005900e-01,9.275000e-01,1.059300e+00,& - & 4.751100e-01,5.697200e-01,6.711800e-01,7.784000e-01,8.894900e-01,& - & 3.965800e-01,4.759300e-01,5.612800e-01,6.512400e-01,7.441700e-01,& - & 3.300500e-01,3.965000e-01,4.680700e-01,5.435700e-01,6.215500e-01/ - data absa(:, 9) / & - & 1.783100e+01,1.982300e+01,2.188400e+01,2.393700e+01,2.590400e+01,& - & 1.598300e+01,1.790800e+01,1.984400e+01,2.175000e+01,2.363900e+01,& - & 1.383800e+01,1.565200e+01,1.742800e+01,1.919500e+01,2.094600e+01,& - & 1.170700e+01,1.337200e+01,1.501800e+01,1.667500e+01,1.833000e+01,& - & 9.761900e+00,1.124400e+01,1.275200e+01,1.427900e+01,1.583700e+01,& - & 7.981700e+00,9.298800e+00,1.065000e+01,1.202900e+01,1.344900e+01,& - & 6.447800e+00,7.586400e+00,8.771700e+00,1.000800e+01,1.128900e+01,& - & 5.155000e+00,6.138100e+00,7.166700e+00,8.256700e+00,9.375900e+00,& - & 4.046200e+00,4.892400e+00,5.794400e+00,6.746600e+00,7.710000e+00,& - & 3.192000e+00,3.913300e+00,4.691200e+00,5.509100e+00,6.343200e+00,& - & 2.771700e+00,3.403900e+00,4.080000e+00,4.781800e+00,5.508100e+00,& - & 2.397800e+00,2.943600e+00,3.523500e+00,4.129300e+00,4.760000e+00,& - & 2.057500e+00,2.526300e+00,3.024400e+00,3.547700e+00,4.089600e+00/ - data absa(:, 10) / & - & 4.974800e+01,5.511200e+01,5.993800e+01,6.502300e+01,7.045800e+01,& - & 4.658800e+01,5.166100e+01,5.690100e+01,6.246300e+01,6.848700e+01,& - & 4.162800e+01,4.669900e+01,5.231400e+01,5.835300e+01,6.445800e+01,& - & 3.745600e+01,4.246900e+01,4.786700e+01,5.338400e+01,5.911100e+01,& - & 3.343600e+01,3.879300e+01,4.399200e+01,4.907700e+01,5.404600e+01,& - & 2.894800e+01,3.406600e+01,3.909300e+01,4.394300e+01,4.857700e+01,& - & 2.441100e+01,2.916900e+01,3.377200e+01,3.832800e+01,4.267400e+01,& - & 2.021300e+01,2.437900e+01,2.854700e+01,3.263200e+01,3.671700e+01,& - & 1.677000e+01,2.027500e+01,2.372600e+01,2.728900e+01,3.114900e+01,& - & 1.374000e+01,1.681400e+01,1.987400e+01,2.303900e+01,2.652900e+01,& - & 1.216100e+01,1.482000e+01,1.766700e+01,2.076700e+01,2.394800e+01,& - & 1.066600e+01,1.309300e+01,1.572700e+01,1.847300e+01,2.119500e+01,& - & 9.391500e+00,1.155700e+01,1.384700e+01,1.617200e+01,1.855800e+01/ - data absa(:, 11) / & - & 7.284200e+01,8.212700e+01,9.175100e+01,1.008100e+02,1.086800e+02,& - & 7.091200e+01,8.021100e+01,8.913300e+01,9.776700e+01,1.053700e+02,& - & 6.716900e+01,7.589500e+01,8.395700e+01,9.146700e+01,9.874000e+01,& - & 6.104600e+01,6.908600e+01,7.707100e+01,8.462500e+01,9.232500e+01,& - & 5.429100e+01,6.162400e+01,6.914600e+01,7.691600e+01,8.505000e+01,& - & 4.794000e+01,5.475400e+01,6.194300e+01,6.973900e+01,7.776500e+01,& - & 4.142400e+01,4.832300e+01,5.588400e+01,6.343400e+01,7.106400e+01,& - & 3.480800e+01,4.171800e+01,4.924000e+01,5.672800e+01,6.403200e+01,& - & 2.872400e+01,3.533300e+01,4.239500e+01,4.937200e+01,5.618600e+01,& - & 2.406000e+01,2.988600e+01,3.617100e+01,4.251100e+01,4.885500e+01,& - & 2.246600e+01,2.784200e+01,3.327600e+01,3.870700e+01,4.441100e+01,& - & 2.063500e+01,2.540200e+01,3.013000e+01,3.506500e+01,4.045600e+01,& - & 1.837500e+01,2.252800e+01,2.694400e+01,3.172100e+01,3.664200e+01/ - data absa(:, 12) / & - & 1.281400e+02,1.393800e+02,1.499400e+02,1.615000e+02,1.727300e+02,& - & 1.202800e+02,1.317100e+02,1.438100e+02,1.562800e+02,1.693600e+02,& - & 1.090800e+02,1.222100e+02,1.366200e+02,1.510800e+02,1.659100e+02,& - & 9.968900e+01,1.139300e+02,1.289900e+02,1.444600e+02,1.593200e+02,& - & 9.157400e+01,1.064700e+02,1.217900e+02,1.368100e+02,1.509000e+02,& - & 8.315900e+01,9.837200e+01,1.137000e+02,1.278700e+02,1.418400e+02,& - & 7.513000e+01,8.927900e+01,1.033500e+02,1.169600e+02,1.308800e+02,& - & 6.694200e+01,7.971900e+01,9.254700e+01,1.053000e+02,1.188700e+02,& - & 5.772200e+01,6.983700e+01,8.208200e+01,9.459300e+01,1.077000e+02,& - & 4.904000e+01,6.062000e+01,7.257700e+01,8.518700e+01,9.784400e+01,& - & 4.543300e+01,5.635200e+01,6.822300e+01,8.049900e+01,9.251200e+01,& - & 4.197100e+01,5.246700e+01,6.353300e+01,7.454300e+01,8.508400e+01,& - & 3.901300e+01,4.856800e+01,5.827200e+01,6.774100e+01,7.719400e+01/ - data absa(:, 13) / & - & 3.000418e+02,3.295884e+02,3.559647e+02,3.815349e+02,4.050856e+02,& - & 3.019791e+02,3.360053e+02,3.647513e+02,3.919344e+02,4.139147e+02,& - & 2.952656e+02,3.290951e+02,3.602482e+02,3.879871e+02,4.183900e+02,& - & 2.800250e+02,3.161535e+02,3.488284e+02,3.786839e+02,4.121769e+02,& - & 2.613678e+02,2.973359e+02,3.330985e+02,3.680068e+02,4.009861e+02,& - & 2.395188e+02,2.761093e+02,3.137507e+02,3.510789e+02,3.880699e+02,& - & 2.170940e+02,2.549912e+02,2.938101e+02,3.321606e+02,3.713830e+02,& - & 1.954783e+02,2.347621e+02,2.753640e+02,3.151168e+02,3.562516e+02,& - & 1.758713e+02,2.149611e+02,2.562928e+02,2.974233e+02,3.385016e+02,& - & 1.601232e+02,1.987001e+02,2.384238e+02,2.798183e+02,3.207363e+02,& - & 1.612582e+02,1.997352e+02,2.390504e+02,2.799799e+02,3.208008e+02,& - & 1.608018e+02,1.982578e+02,2.377596e+02,2.780894e+02,3.192241e+02,& - & 1.588756e+02,1.956866e+02,2.345322e+02,2.743441e+02,3.149050e+02/ - data absa(:, 14) / & - & 8.980436e+02,9.642712e+02,1.013968e+03,1.073470e+03,1.124377e+03,& - & 1.007697e+03,1.091230e+03,1.153224e+03,1.225741e+03,1.266873e+03,& - & 1.096855e+03,1.165183e+03,1.247149e+03,1.316440e+03,1.394898e+03,& - & 1.133012e+03,1.235148e+03,1.361004e+03,1.423211e+03,1.545942e+03,& - & 1.175383e+03,1.297036e+03,1.447036e+03,1.552931e+03,1.641856e+03,& - & 1.213479e+03,1.338415e+03,1.489119e+03,1.637367e+03,1.739211e+03,& - & 1.216874e+03,1.365263e+03,1.531539e+03,1.687845e+03,1.812837e+03,& - & 1.175938e+03,1.366162e+03,1.567938e+03,1.730082e+03,1.885912e+03,& - & 1.137682e+03,1.344249e+03,1.568606e+03,1.760931e+03,1.951304e+03,& - & 1.107107e+03,1.325739e+03,1.557866e+03,1.791714e+03,2.015841e+03,& - & 1.180441e+03,1.426279e+03,1.670059e+03,1.943857e+03,2.175329e+03,& - & 1.252501e+03,1.544450e+03,1.804912e+03,2.095031e+03,2.347725e+03,& - & 1.343284e+03,1.634048e+03,1.934659e+03,2.239545e+03,2.526366e+03/ - -! the array absb(235,NG02) = kb(5,13:59,NG02) contains absorption coefs -! at the NG02=14 chosen g-values for a range of pressure levels< ~100mb -! and temperatures. the first index in the array, jt, which runs from -! 1 to 5, corresponds to different temperatures. more specifically, -! jt = 1-5 means that the data are for the corresponding temperature of -! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the -! second index, jp, runs from 13 to 59 and refers to the jpth reference -! pressure level (see taumol.f for the value of these pressure levels -! in mb). the third index, ig, goes from 1 to NG02=14, and tells us -! which g-interval the absorption coefficients are for. - - data absb(:,1) / & - & 1.116500e-03,1.124700e-03,1.156000e-03,1.207600e-03,1.286900e-03,& - & 9.149900e-04,9.241700e-04,9.521400e-04,9.979300e-04,1.064700e-03,& - & 7.489500e-04,7.588500e-04,7.839800e-04,8.236400e-04,8.793400e-04,& - & 6.128500e-04,6.230100e-04,6.452800e-04,6.791900e-04,7.256100e-04,& - & 5.016100e-04,5.116200e-04,5.308800e-04,5.595600e-04,5.982700e-04,& - & 4.105900e-04,4.200700e-04,4.363500e-04,4.606900e-04,4.928500e-04,& - & 3.364100e-04,3.450000e-04,3.587900e-04,3.792900e-04,4.061600e-04,& - & 2.760300e-04,2.836300e-04,2.953700e-04,3.127600e-04,3.353100e-04,& - & 2.265900e-04,2.331700e-04,2.432400e-04,2.579600e-04,2.769500e-04,& - & 1.863100e-04,1.921700e-04,2.010300e-04,2.137400e-04,2.299400e-04,& - & 1.532700e-04,1.584600e-04,1.663100e-04,1.772300e-04,1.909600e-04,& - & 1.262000e-04,1.308000e-04,1.377800e-04,1.471400e-04,1.586700e-04,& - & 1.040000e-04,1.081000e-04,1.142600e-04,1.223100e-04,1.319200e-04,& - & 8.581200e-05,8.950700e-05,9.492700e-05,1.019000e-04,1.098200e-04,& - & 7.085900e-05,7.420500e-05,7.893900e-05,8.495700e-05,9.144900e-05,& - & 5.856900e-05,6.159400e-05,6.570000e-05,7.082000e-05,7.619100e-05,& - & 4.846500e-05,5.117700e-05,5.474500e-05,5.904000e-05,6.353200e-05,& - & 4.014700e-05,4.255300e-05,4.565300e-05,4.920700e-05,5.298100e-05,& - & 3.330000e-05,3.541400e-05,3.810200e-05,4.101400e-05,4.419500e-05,& - & 2.766200e-05,2.950400e-05,3.179800e-05,3.420800e-05,3.689200e-05,& - & 2.300000e-05,2.460500e-05,2.653100e-05,2.854900e-05,3.081400e-05,& - & 1.910100e-05,2.048800e-05,2.208100e-05,2.377300e-05,2.568300e-05,& - & 1.577200e-05,1.694500e-05,1.824800e-05,1.965400e-05,2.124800e-05,& - & 1.293200e-05,1.389700e-05,1.496400e-05,1.611800e-05,1.742700e-05,& - & 1.050000e-05,1.126600e-05,1.214000e-05,1.307000e-05,1.412200e-05,& - & 8.523200e-06,9.129300e-06,9.842400e-06,1.059300e-05,1.143800e-05,& - & 6.919900e-06,7.400100e-06,7.979300e-06,8.585100e-06,9.265100e-06,& - & 5.586900e-06,5.957900e-06,6.420800e-06,6.906700e-06,7.449000e-06,& - & 4.510200e-06,4.795900e-06,5.159800e-06,5.553500e-06,5.984500e-06,& - & 3.645500e-06,3.863400e-06,4.144500e-06,4.466600e-06,4.809300e-06,& - & 2.943400e-06,3.104500e-06,3.318100e-06,3.577900e-06,3.850000e-06,& - & 2.378400e-06,2.494000e-06,2.655400e-06,2.859600e-06,3.077300e-06,& - & 1.925400e-06,2.007300e-06,2.128000e-06,2.284000e-06,2.461500e-06,& - & 1.559900e-06,1.617600e-06,1.705500e-06,1.822600e-06,1.965600e-06,& - & 1.264700e-06,1.304500e-06,1.365700e-06,1.452700e-06,1.563600e-06,& - & 1.028000e-06,1.054600e-06,1.096700e-06,1.160200e-06,1.243000e-06,& - & 8.389900e-07,8.543500e-07,8.834800e-07,9.284100e-07,9.898999e-07,& - & 6.875800e-07,6.941700e-07,7.142400e-07,7.455100e-07,7.912500e-07,& - & 5.652500e-07,5.656400e-07,5.787900e-07,6.006700e-07,6.340600e-07,& - & 4.661400e-07,4.626200e-07,4.699100e-07,4.852100e-07,5.089500e-07,& - & 3.858300e-07,3.797100e-07,3.823700e-07,3.928500e-07,4.094000e-07,& - & 3.199800e-07,3.124900e-07,3.121400e-07,3.189600e-07,3.306900e-07,& - & 2.658500e-07,2.578400e-07,2.556800e-07,2.595300e-07,2.678500e-07,& - & 2.213700e-07,2.134100e-07,2.100500e-07,2.115900e-07,2.173900e-07,& - & 1.847700e-07,1.771200e-07,1.730400e-07,1.729200e-07,1.767600e-07,& - & 1.544800e-07,1.472800e-07,1.429100e-07,1.418100e-07,1.440600e-07,& - & 1.279500e-07,1.216900e-07,1.177700e-07,1.165100e-07,1.180200e-07/ - data absb(:,2) / & - & 2.951600e-03,2.971300e-03,3.061600e-03,3.201900e-03,3.401700e-03,& - & 2.419700e-03,2.441400e-03,2.520700e-03,2.640700e-03,2.816700e-03,& - & 1.983100e-03,2.006300e-03,2.075500e-03,2.180000e-03,2.334200e-03,& - & 1.625200e-03,1.649200e-03,1.709700e-03,1.801400e-03,1.934100e-03,& - & 1.332100e-03,1.355600e-03,1.408600e-03,1.488200e-03,1.601700e-03,& - & 1.092000e-03,1.114800e-03,1.161000e-03,1.229200e-03,1.324800e-03,& - & 8.953400e-04,9.169000e-04,9.570900e-04,1.014800e-03,1.095100e-03,& - & 7.344500e-04,7.550300e-04,7.895800e-04,8.386300e-04,9.060000e-04,& - & 6.029000e-04,6.218000e-04,6.514800e-04,6.930800e-04,7.496600e-04,& - & 4.959500e-04,5.135300e-04,5.393700e-04,5.756100e-04,6.234800e-04,& - & 4.085500e-04,4.243400e-04,4.467700e-04,4.784600e-04,5.189700e-04,& - & 3.370400e-04,3.508700e-04,3.704100e-04,3.982500e-04,4.325400e-04,& - & 2.782300e-04,2.903400e-04,3.075600e-04,3.317600e-04,3.610800e-04,& - & 2.298800e-04,2.406500e-04,2.559900e-04,2.768900e-04,3.021800e-04,& - & 1.900800e-04,1.996600e-04,2.133500e-04,2.311800e-04,2.528700e-04,& - & 1.572900e-04,1.658200e-04,1.780400e-04,1.932100e-04,2.115800e-04,& - & 1.303000e-04,1.379400e-04,1.487000e-04,1.617200e-04,1.771200e-04,& - & 1.080700e-04,1.149100e-04,1.242300e-04,1.355200e-04,1.483000e-04,& - & 8.973700e-05,9.587300e-05,1.038500e-04,1.135700e-04,1.242200e-04,& - & 7.460700e-05,8.011400e-05,8.692500e-05,9.516000e-05,1.040900e-04,& - & 6.211500e-05,6.697600e-05,7.284200e-05,7.974900e-05,8.726100e-05,& - & 5.166700e-05,5.585400e-05,6.091100e-05,6.664100e-05,7.294500e-05,& - & 4.271400e-05,4.622400e-05,5.047600e-05,5.520700e-05,6.044600e-05,& - & 3.503300e-05,3.791600e-05,4.141300e-05,4.529000e-05,4.959000e-05,& - & 2.841700e-05,3.072400e-05,3.351100e-05,3.665600e-05,4.012300e-05,& - & 2.304400e-05,2.487900e-05,2.709100e-05,2.964600e-05,3.244000e-05,& - & 1.869600e-05,2.015000e-05,2.190500e-05,2.397700e-05,2.623100e-05,& - & 1.507900e-05,1.619000e-05,1.756100e-05,1.921900e-05,2.101900e-05,& - & 1.216600e-05,1.299800e-05,1.407600e-05,1.538700e-05,1.682600e-05,& - & 9.824500e-06,1.044700e-05,1.129200e-05,1.231400e-05,1.347000e-05,& - & 7.920700e-06,8.376600e-06,9.021200e-06,9.801500e-06,1.073000e-05,& - & 6.389100e-06,6.720400e-06,7.195000e-06,7.796800e-06,8.529500e-06,& - & 5.161400e-06,5.401800e-06,5.746300e-06,6.212600e-06,6.777900e-06,& - & 4.173500e-06,4.345100e-06,4.593100e-06,4.945000e-06,5.372400e-06,& - & 3.375000e-06,3.495900e-06,3.672200e-06,3.924700e-06,4.251300e-06,& - & 2.741800e-06,2.819200e-06,2.943400e-06,3.122500e-06,3.371100e-06,& - & 2.237100e-06,2.277500e-06,2.365600e-06,2.492500e-06,2.675000e-06,& - & 1.831700e-06,1.846500e-06,1.907300e-06,1.998400e-06,2.129000e-06,& - & 1.503600e-06,1.503900e-06,1.541600e-06,1.606500e-06,1.700200e-06,& - & 1.236500e-06,1.228900e-06,1.247600e-06,1.294400e-06,1.361700e-06,& - & 1.018000e-06,1.007000e-06,1.013000e-06,1.044700e-06,1.093100e-06,& - & 8.388100e-07,8.269400e-07,8.260700e-07,8.457400e-07,8.805900e-07,& - & 6.919500e-07,6.798700e-07,6.754800e-07,6.856200e-07,7.111400e-07,& - & 5.717300e-07,5.594800e-07,5.535600e-07,5.573300e-07,5.750800e-07,& - & 4.731600e-07,4.609600e-07,4.545200e-07,4.544800e-07,4.658100e-07,& - & 3.918900e-07,3.801300e-07,3.736600e-07,3.716000e-07,3.778500e-07,& - & 3.226200e-07,3.124100e-07,3.066300e-07,3.043800e-07,3.085000e-07/ - data absb(:,3) / & - & 7.552700e-03,7.787500e-03,8.161300e-03,8.750000e-03,9.469300e-03,& - & 6.216200e-03,6.417900e-03,6.744300e-03,7.243600e-03,7.848800e-03,& - & 5.115400e-03,5.289900e-03,5.575800e-03,5.997700e-03,6.509700e-03,& - & 4.209100e-03,4.359800e-03,4.610800e-03,4.966200e-03,5.404100e-03,& - & 3.462400e-03,3.593100e-03,3.812500e-03,4.111800e-03,4.486700e-03,& - & 2.847800e-03,2.961100e-03,3.151300e-03,3.405600e-03,3.722700e-03,& - & 2.342400e-03,2.440300e-03,2.605000e-03,2.820500e-03,3.087500e-03,& - & 1.927900e-03,2.013600e-03,2.156800e-03,2.339400e-03,2.563300e-03,& - & 1.586800e-03,1.662500e-03,1.786600e-03,1.940300e-03,2.127900e-03,& - & 1.309500e-03,1.379800e-03,1.487300e-03,1.618500e-03,1.776200e-03,& - & 1.082000e-03,1.147000e-03,1.238800e-03,1.350600e-03,1.482800e-03,& - & 8.953300e-04,9.548000e-04,1.032500e-03,1.127300e-03,1.239100e-03,& - & 7.422900e-04,7.953400e-04,8.615100e-04,9.418600e-04,1.036100e-03,& - & 6.170500e-04,6.634900e-04,7.201800e-04,7.887000e-04,8.674100e-04,& - & 5.137300e-04,5.537700e-04,6.025900e-04,6.608500e-04,7.264000e-04,& - & 4.282600e-04,4.624500e-04,5.043400e-04,5.540500e-04,6.085000e-04,& - & 3.573000e-04,3.866700e-04,4.225500e-04,4.647500e-04,5.100800e-04,& - & 2.982300e-04,3.235600e-04,3.542700e-04,3.896300e-04,4.276200e-04,& - & 2.491500e-04,2.711100e-04,2.973000e-04,3.267600e-04,3.585300e-04,& - & 2.083500e-04,2.272600e-04,2.496900e-04,2.741500e-04,3.005200e-04,& - & 1.744000e-04,1.906300e-04,2.096600e-04,2.300400e-04,2.518000e-04,& - & 1.456600e-04,1.594900e-04,1.753700e-04,1.924200e-04,2.102800e-04,& - & 1.206900e-04,1.322700e-04,1.453800e-04,1.594900e-04,1.741200e-04,& - & 9.904300e-05,1.085600e-04,1.193100e-04,1.308800e-04,1.428500e-04,& - & 8.019200e-05,8.782800e-05,9.655200e-05,1.059200e-04,1.157100e-04,& - & 6.489500e-05,7.100600e-05,7.807800e-05,8.564100e-05,9.364900e-05,& - & 5.252900e-05,5.741700e-05,6.313700e-05,6.924800e-05,7.578600e-05,& - & 4.217200e-05,4.601100e-05,5.055000e-05,5.546900e-05,6.078200e-05,& - & 3.384500e-05,3.684300e-05,4.040500e-05,4.437800e-05,4.866900e-05,& - & 2.717800e-05,2.949900e-05,3.230500e-05,3.550700e-05,3.894800e-05,& - & 2.174800e-05,2.352600e-05,2.570700e-05,2.826200e-05,3.099900e-05,& - & 1.738600e-05,1.874500e-05,2.043000e-05,2.242000e-05,2.461500e-05,& - & 1.391900e-05,1.495500e-05,1.623900e-05,1.778600e-05,1.954800e-05,& - & 1.116400e-05,1.192500e-05,1.289800e-05,1.409200e-05,1.549300e-05,& - & 8.972400e-06,9.490600e-06,1.022500e-05,1.113600e-05,1.221400e-05,& - & 7.229400e-06,7.573700e-06,8.119900e-06,8.803300e-06,9.633500e-06,& - & 5.838100e-06,6.072600e-06,6.458200e-06,6.971800e-06,7.607600e-06,& - & 4.729600e-06,4.893000e-06,5.153200e-06,5.542800e-06,6.026100e-06,& - & 3.839900e-06,3.951400e-06,4.128400e-06,4.416800e-06,4.782200e-06,& - & 3.124500e-06,3.197300e-06,3.321100e-06,3.523900e-06,3.801200e-06,& - & 2.547100e-06,2.592500e-06,2.678500e-06,2.815800e-06,3.025800e-06,& - & 2.081400e-06,2.107300e-06,2.166400e-06,2.261700e-06,2.417300e-06,& - & 1.702800e-06,1.716500e-06,1.755800e-06,1.823900e-06,1.935000e-06,& - & 1.393600e-06,1.400100e-06,1.425500e-06,1.473700e-06,1.550800e-06,& - & 1.140900e-06,1.144200e-06,1.158900e-06,1.192400e-06,1.246100e-06,& - & 9.353200e-07,9.361700e-07,9.441500e-07,9.667700e-07,1.005300e-06,& - & 7.671600e-07,7.665500e-07,7.719300e-07,7.890000e-07,8.189900e-07/ - data absb(:,4) / & - & 2.009500e-02,2.118200e-02,2.222500e-02,2.330400e-02,2.439400e-02,& - & 1.660100e-02,1.748000e-02,1.833800e-02,1.923100e-02,2.012800e-02,& - & 1.371100e-02,1.442500e-02,1.513400e-02,1.586800e-02,1.661100e-02,& - & 1.131900e-02,1.190300e-02,1.249000e-02,1.309400e-02,1.370000e-02,& - & 9.337700e-03,9.816600e-03,1.030100e-02,1.079700e-02,1.129600e-02,& - & 7.699400e-03,8.093100e-03,8.495100e-03,8.898600e-03,9.314000e-03,& - & 6.345400e-03,6.669000e-03,7.001900e-03,7.331300e-03,7.682900e-03,& - & 5.232800e-03,5.500100e-03,5.772400e-03,6.046900e-03,6.341300e-03,& - & 4.315000e-03,4.534400e-03,4.759300e-03,4.988100e-03,5.233600e-03,& - & 3.570300e-03,3.749900e-03,3.936600e-03,4.126800e-03,4.331800e-03,& - & 2.954700e-03,3.102400e-03,3.257600e-03,3.414000e-03,3.584900e-03,& - & 2.445200e-03,2.569700e-03,2.696100e-03,2.825900e-03,2.964200e-03,& - & 2.024500e-03,2.128800e-03,2.232000e-03,2.339700e-03,2.451100e-03,& - & 1.678500e-03,1.764300e-03,1.848800e-03,1.938700e-03,2.028300e-03,& - & 1.392000e-03,1.461900e-03,1.531300e-03,1.606700e-03,1.678900e-03,& - & 1.154800e-03,1.211200e-03,1.268600e-03,1.330500e-03,1.389900e-03,& - & 9.577900e-04,1.003600e-03,1.051500e-03,1.101600e-03,1.150100e-03,& - & 7.939800e-04,8.315900e-04,8.717600e-04,9.122200e-04,9.511900e-04,& - & 6.581300e-04,6.891300e-04,7.230500e-04,7.555900e-04,7.868000e-04,& - & 5.455700e-04,5.713300e-04,5.992000e-04,6.259100e-04,6.509400e-04,& - & 4.522500e-04,4.738400e-04,4.963500e-04,5.181000e-04,5.385000e-04,& - & 3.742900e-04,3.924000e-04,4.105700e-04,4.281100e-04,4.448300e-04,& - & 3.084100e-04,3.235000e-04,3.382100e-04,3.524000e-04,3.660800e-04,& - & 2.528500e-04,2.652500e-04,2.772900e-04,2.888500e-04,3.000600e-04,& - & 2.058600e-04,2.158500e-04,2.258200e-04,2.354000e-04,2.445700e-04,& - & 1.675300e-04,1.755900e-04,1.838400e-04,1.917700e-04,1.992700e-04,& - & 1.363500e-04,1.428600e-04,1.496800e-04,1.562200e-04,1.623500e-04,& - & 1.104500e-04,1.156700e-04,1.213200e-04,1.267200e-04,1.317600e-04,& - & 8.941000e-05,9.361000e-05,9.824100e-05,1.026600e-04,1.068600e-04,& - & 7.237800e-05,7.578100e-05,7.946500e-05,8.314500e-05,8.667200e-05,& - & 5.842400e-05,6.118800e-05,6.410700e-05,6.718800e-05,7.014000e-05,& - & 4.705800e-05,4.934600e-05,5.167100e-05,5.423000e-05,5.665700e-05,& - & 3.789900e-05,3.979800e-05,4.166900e-05,4.370600e-05,4.572400e-05,& - & 3.049700e-05,3.205500e-05,3.357200e-05,3.517600e-05,3.687300e-05,& - & 2.447900e-05,2.573200e-05,2.699500e-05,2.826700e-05,2.967100e-05,& - & 1.963500e-05,2.065900e-05,2.170600e-05,2.272900e-05,2.383000e-05,& - & 1.575000e-05,1.658800e-05,1.743800e-05,1.827600e-05,1.914400e-05,& - & 1.263800e-05,1.332700e-05,1.401400e-05,1.471300e-05,1.540800e-05,& - & 1.013400e-05,1.071000e-05,1.127300e-05,1.184900e-05,1.241000e-05,& - & 8.135000e-06,8.607000e-06,9.066600e-06,9.531400e-06,9.996100e-06,& - & 6.526800e-06,6.907700e-06,7.287400e-06,7.664700e-06,8.051400e-06,& - & 5.240000e-06,5.550400e-06,5.866200e-06,6.175400e-06,6.492200e-06,& - & 4.224400e-06,4.466500e-06,4.725000e-06,4.977500e-06,5.233100e-06,& - & 3.416300e-06,3.593000e-06,3.802300e-06,4.010400e-06,4.217500e-06,& - & 2.769300e-06,2.886700e-06,3.057500e-06,3.230700e-06,3.400300e-06,& - & 2.250000e-06,2.327900e-06,2.462700e-06,2.604800e-06,2.743300e-06,& - & 1.838600e-06,1.896600e-06,2.004000e-06,2.119900e-06,2.233200e-06/ - data absb(:,5) / & - & 3.722700e-02,3.923600e-02,4.113600e-02,4.263500e-02,4.412500e-02,& - & 3.073100e-02,3.238600e-02,3.390800e-02,3.512600e-02,3.638300e-02,& - & 2.537800e-02,2.672700e-02,2.794100e-02,2.894700e-02,3.000200e-02,& - & 2.095900e-02,2.204600e-02,2.301400e-02,2.385100e-02,2.473400e-02,& - & 1.729400e-02,1.817600e-02,1.895200e-02,1.964300e-02,2.038000e-02,& - & 1.426100e-02,1.498300e-02,1.559700e-02,1.617400e-02,1.678400e-02,& - & 1.175400e-02,1.234200e-02,1.283700e-02,1.331200e-02,1.382000e-02,& - & 9.694000e-03,1.017200e-02,1.056900e-02,1.096200e-02,1.138900e-02,& - & 7.993500e-03,8.380400e-03,8.701900e-03,9.025600e-03,9.391700e-03,& - & 6.609800e-03,6.921300e-03,7.180200e-03,7.455200e-03,7.762600e-03,& - & 5.467500e-03,5.712200e-03,5.927600e-03,6.159000e-03,6.417700e-03,& - & 4.524800e-03,4.714500e-03,4.895600e-03,5.090500e-03,5.310300e-03,& - & 3.743600e-03,3.893800e-03,4.045100e-03,4.208300e-03,4.397700e-03,& - & 3.098000e-03,3.219300e-03,3.344600e-03,3.482000e-03,3.646100e-03,& - & 2.562900e-03,2.662100e-03,2.766000e-03,2.881000e-03,3.024200e-03,& - & 2.118500e-03,2.201200e-03,2.288100e-03,2.385400e-03,2.510000e-03,& - & 1.752000e-03,1.820100e-03,1.893300e-03,1.977400e-03,2.086100e-03,& - & 1.449000e-03,1.505300e-03,1.566800e-03,1.640500e-03,1.735300e-03,& - & 1.198700e-03,1.245400e-03,1.297000e-03,1.362000e-03,1.444600e-03,& - & 9.916200e-04,1.030700e-03,1.074900e-03,1.131700e-03,1.203600e-03,& - & 8.202400e-04,8.533600e-04,8.917600e-04,9.413700e-04,1.003400e-03,& - & 6.777300e-04,7.055400e-04,7.389800e-04,7.820100e-04,8.349000e-04,& - & 5.579700e-04,5.810300e-04,6.095000e-04,6.459500e-04,6.902400e-04,& - & 4.574100e-04,4.763600e-04,4.998700e-04,5.299400e-04,5.663400e-04,& - & 3.727500e-04,3.881200e-04,4.067100e-04,4.306300e-04,4.598300e-04,& - & 3.036800e-04,3.161200e-04,3.307900e-04,3.497700e-04,3.731600e-04,& - & 2.474300e-04,2.574600e-04,2.690900e-04,2.841400e-04,3.028700e-04,& - & 2.008300e-04,2.088100e-04,2.178600e-04,2.295000e-04,2.442200e-04,& - & 1.629000e-04,1.693000e-04,1.764000e-04,1.853900e-04,1.968100e-04,& - & 1.321200e-04,1.372900e-04,1.429700e-04,1.498300e-04,1.586500e-04,& - & 1.069200e-04,1.111100e-04,1.156100e-04,1.208100e-04,1.275200e-04,& - & 8.648400e-05,8.985100e-05,9.340100e-05,9.738400e-05,1.024600e-04,& - & 6.990200e-05,7.264100e-05,7.549100e-05,7.863200e-05,8.243800e-05,& - & 5.635700e-05,5.867800e-05,6.098700e-05,6.345600e-05,6.630900e-05,& - & 4.524600e-05,4.735100e-05,4.918800e-05,5.113200e-05,5.330200e-05,& - & 3.633100e-05,3.814900e-05,3.966700e-05,4.122600e-05,4.293200e-05,& - & 2.915000e-05,3.066200e-05,3.199700e-05,3.325400e-05,3.458300e-05,& - & 2.339300e-05,2.464500e-05,2.583500e-05,2.684200e-05,2.790300e-05,& - & 1.885000e-05,1.982200e-05,2.083000e-05,2.167500e-05,2.253300e-05,& - & 1.525900e-05,1.593200e-05,1.676000e-05,1.751400e-05,1.819900e-05,& - & 1.241800e-05,1.279600e-05,1.348200e-05,1.414100e-05,1.469600e-05,& - & 1.015300e-05,1.033400e-05,1.085900e-05,1.141400e-05,1.188200e-05,& - & 8.313400e-06,8.380500e-06,8.747600e-06,9.201600e-06,9.616800e-06,& - & 6.812800e-06,6.825000e-06,7.042200e-06,7.418400e-06,7.778600e-06,& - & 5.587100e-06,5.579400e-06,5.687900e-06,5.980500e-06,6.283600e-06,& - & 4.583300e-06,4.567700e-06,4.612300e-06,4.822800e-06,5.071500e-06,& - & 3.755400e-06,3.741300e-06,3.766400e-06,3.925000e-06,4.128600e-06/ - data absb(:,6) / & - & 5.972100e-02,6.135400e-02,6.518400e-02,7.129600e-02,7.907600e-02,& - & 4.909000e-02,5.065700e-02,5.405500e-02,5.926800e-02,6.578400e-02,& - & 4.037300e-02,4.185700e-02,4.483900e-02,4.926500e-02,5.474900e-02,& - & 3.320500e-02,3.458900e-02,3.720000e-02,4.096300e-02,4.558800e-02,& - & 2.732100e-02,2.857200e-02,3.084400e-02,3.404400e-02,3.794300e-02,& - & 2.247900e-02,2.359500e-02,2.557000e-02,2.829300e-02,3.154500e-02,& - & 1.850000e-02,1.949100e-02,2.119600e-02,2.349600e-02,2.620300e-02,& - & 1.523800e-02,1.612500e-02,1.759800e-02,1.954300e-02,2.179200e-02,& - & 1.255700e-02,1.334300e-02,1.461400e-02,1.625200e-02,1.812400e-02,& - & 1.038400e-02,1.110700e-02,1.221700e-02,1.361200e-02,1.518700e-02,& - & 8.601400e-03,9.260200e-03,1.022300e-02,1.141000e-02,1.273700e-02,& - & 7.134400e-03,7.734900e-03,8.567000e-03,9.577300e-03,1.068800e-02,& - & 5.931800e-03,6.472000e-03,7.195600e-03,8.046300e-03,8.974400e-03,& - & 4.948400e-03,5.432100e-03,6.059500e-03,6.773200e-03,7.546500e-03,& - & 4.135900e-03,4.566000e-03,5.104600e-03,5.701100e-03,6.344700e-03,& - & 3.465100e-03,3.842700e-03,4.298600e-03,4.797600e-03,5.332400e-03,& - & 2.910200e-03,3.238600e-03,3.621800e-03,4.039300e-03,4.483000e-03,& - & 2.447000e-03,2.730700e-03,3.052000e-03,3.400700e-03,3.768200e-03,& - & 2.060600e-03,2.303700e-03,2.572800e-03,2.863600e-03,3.168400e-03,& - & 1.737200e-03,1.943400e-03,2.169000e-03,2.411200e-03,2.664300e-03,& - & 1.466000e-03,1.639500e-03,1.828700e-03,2.030100e-03,2.240000e-03,& - & 1.232800e-03,1.378000e-03,1.535900e-03,1.702700e-03,1.876100e-03,& - & 1.025500e-03,1.145900e-03,1.276600e-03,1.414200e-03,1.556800e-03,& - & 8.424600e-04,9.414400e-04,1.048900e-03,1.161800e-03,1.278800e-03,& - & 6.803200e-04,7.605900e-04,8.480000e-04,9.401100e-04,1.035800e-03,& - & 5.487700e-04,6.138000e-04,6.848100e-04,7.599600e-04,8.382000e-04,& - & 4.427000e-04,4.953900e-04,5.530200e-04,6.142900e-04,6.781800e-04,& - & 3.530800e-04,3.952800e-04,4.415900e-04,4.912700e-04,5.432200e-04,& - & 2.813600e-04,3.148900e-04,3.520100e-04,3.921900e-04,4.343400e-04,& - & 2.243500e-04,2.507400e-04,2.804900e-04,3.129200e-04,3.471000e-04,& - & 1.780200e-04,1.983100e-04,2.220400e-04,2.480000e-04,2.756800e-04,& - & 1.411100e-04,1.565000e-04,1.752600e-04,1.959200e-04,2.182400e-04,& - & 1.121900e-04,1.236500e-04,1.382800e-04,1.547100e-04,1.726300e-04,& - & 8.935300e-05,9.762600e-05,1.087600e-04,1.218200e-04,1.361100e-04,& - & 7.133100e-05,7.692300e-05,8.522300e-05,9.544300e-05,1.067500e-04,& - & 5.721900e-05,6.088500e-05,6.689700e-05,7.472600e-05,8.366400e-05,& - & 4.615700e-05,4.845000e-05,5.263400e-05,5.849900e-05,6.555200e-05,& - & 3.749700e-05,3.882200e-05,4.164300e-05,4.599700e-05,5.149000e-05,& - & 3.054800e-05,3.125800e-05,3.311600e-05,3.627200e-05,4.046800e-05,& - & 2.490400e-05,2.529000e-05,2.646700e-05,2.866200e-05,3.182400e-05,& - & 2.031800e-05,2.057300e-05,2.123900e-05,2.272100e-05,2.505900e-05,& - & 1.659700e-05,1.677100e-05,1.713900e-05,1.812700e-05,1.983000e-05,& - & 1.356100e-05,1.368100e-05,1.389200e-05,1.453600e-05,1.573900e-05,& - & 1.108600e-05,1.116700e-05,1.131000e-05,1.169300e-05,1.252600e-05,& - & 9.062800e-06,9.122500e-06,9.220300e-06,9.436700e-06,9.999300e-06,& - & 7.430300e-06,7.454800e-06,7.522300e-06,7.648100e-06,8.021500e-06,& - & 6.093500e-06,6.100900e-06,6.152500e-06,6.244800e-06,6.522600e-06/ - data absb(:,7) / & - & 1.158800e-01,1.336500e-01,1.533200e-01,1.745100e-01,1.969000e-01,& - & 9.705500e-02,1.119600e-01,1.283900e-01,1.461200e-01,1.648800e-01,& - & 8.129400e-02,9.377200e-02,1.075600e-01,1.224000e-01,1.380900e-01,& - & 6.806100e-02,7.854500e-02,9.010100e-02,1.025000e-01,1.155000e-01,& - & 5.695200e-02,6.573900e-02,7.539300e-02,8.566500e-02,9.643600e-02,& - & 4.761700e-02,5.496600e-02,6.297900e-02,7.148000e-02,8.040900e-02,& - & 3.977300e-02,4.589400e-02,5.254400e-02,5.958500e-02,6.700300e-02,& - & 3.326600e-02,3.838100e-02,4.389100e-02,4.974200e-02,5.589900e-02,& - & 2.782100e-02,3.207700e-02,3.664700e-02,4.150500e-02,4.660800e-02,& - & 2.347800e-02,2.703900e-02,3.083900e-02,3.487900e-02,3.910300e-02,& - & 1.982200e-02,2.279000e-02,2.596000e-02,2.930500e-02,3.280400e-02,& - & 1.674500e-02,1.922500e-02,2.185600e-02,2.463600e-02,2.754500e-02,& - & 1.416100e-02,1.622500e-02,1.841500e-02,2.073200e-02,2.315700e-02,& - & 1.200300e-02,1.371900e-02,1.554700e-02,1.748900e-02,1.949800e-02,& - & 1.017100e-02,1.160200e-02,1.313300e-02,1.475300e-02,1.641300e-02,& - & 8.615100e-03,9.813800e-03,1.109700e-02,1.244000e-02,1.380800e-02,& - & 7.303100e-03,8.310000e-03,9.380600e-03,1.048900e-02,1.161400e-02,& - & 6.192400e-03,7.035000e-03,7.924300e-03,8.837900e-03,9.761500e-03,& - & 5.253300e-03,5.956200e-03,6.692900e-03,7.444200e-03,8.204000e-03,& - & 4.457100e-03,5.042200e-03,5.650400e-03,6.268800e-03,6.894600e-03,& - & 3.780000e-03,4.266000e-03,4.767800e-03,5.277200e-03,5.793100e-03,& - & 3.189900e-03,3.592300e-03,4.005800e-03,4.425900e-03,4.852000e-03,& - & 2.658800e-03,2.991100e-03,3.331100e-03,3.677300e-03,4.028900e-03,& - & 2.186700e-03,2.459800e-03,2.739200e-03,3.023900e-03,3.313500e-03,& - & 1.765400e-03,1.988400e-03,2.217500e-03,2.451200e-03,2.688600e-03,& - & 1.423500e-03,1.605500e-03,1.793200e-03,1.984900e-03,2.179600e-03,& - & 1.147700e-03,1.296100e-03,1.449900e-03,1.607100e-03,1.766800e-03,& - & 9.130200e-04,1.033500e-03,1.159100e-03,1.287700e-03,1.418500e-03,& - & 7.246700e-04,8.222100e-04,9.246400e-04,1.029800e-03,1.137000e-03,& - & 5.747400e-04,6.536900e-04,7.370100e-04,8.229300e-04,9.107000e-04,& - & 4.520400e-04,5.157100e-04,5.831200e-04,6.532200e-04,7.249200e-04,& - & 3.539700e-04,4.050900e-04,4.594400e-04,5.165100e-04,5.750200e-04,& - & 2.767700e-04,3.178300e-04,3.616200e-04,4.079300e-04,4.556200e-04,& - & 2.154000e-04,2.483500e-04,2.835800e-04,3.209300e-04,3.597900e-04,& - & 1.663300e-04,1.926600e-04,2.208100e-04,2.508000e-04,2.823600e-04,& - & 1.283000e-04,1.491400e-04,1.716700e-04,1.957300e-04,2.212100e-04,& - & 9.890000e-05,1.152400e-04,1.332500e-04,1.525200e-04,1.730000e-04,& - & 7.652300e-05,8.926400e-05,1.036300e-04,1.190600e-04,1.355000e-04,& - & 5.935000e-05,6.920400e-05,8.057100e-05,9.295200e-05,1.061700e-04,& - & 4.611000e-05,5.363800e-05,6.256500e-05,7.248000e-05,8.308100e-05,& - & 3.590700e-05,4.157200e-05,4.852300e-05,5.642100e-05,6.491900e-05,& - & 2.816900e-05,3.239400e-05,3.778600e-05,4.404700e-05,5.087400e-05,& - & 2.224400e-05,2.533200e-05,2.948000e-05,3.442000e-05,3.990300e-05,& - & 1.766100e-05,1.984800e-05,2.300400e-05,2.687500e-05,3.126100e-05,& - & 1.411600e-05,1.559000e-05,1.796200e-05,2.097200e-05,2.445700e-05,& - & 1.134200e-05,1.232300e-05,1.407600e-05,1.640300e-05,1.916100e-05,& - & 9.228200e-06,9.966900e-06,1.133800e-05,1.319900e-05,1.542700e-05/ - data absb(:,8) / & - & 3.300700e-01,3.965100e-01,4.680900e-01,5.435700e-01,6.215700e-01,& - & 2.789900e-01,3.350700e-01,3.953400e-01,4.585100e-01,5.238300e-01,& - & 2.360300e-01,2.832000e-01,3.337700e-01,3.866900e-01,4.413700e-01,& - & 1.995900e-01,2.392600e-01,2.815500e-01,3.256700e-01,3.716100e-01,& - & 1.685400e-01,2.017100e-01,2.369600e-01,2.739100e-01,3.123600e-01,& - & 1.420900e-01,1.697700e-01,1.991800e-01,2.300900e-01,2.622900e-01,& - & 1.195400e-01,1.426200e-01,1.671900e-01,1.930100e-01,2.198400e-01,& - & 1.007700e-01,1.200500e-01,1.405400e-01,1.620800e-01,1.842900e-01,& - & 8.491400e-02,1.010000e-01,1.180600e-01,1.358800e-01,1.543700e-01,& - & 7.235500e-02,8.579100e-02,9.998200e-02,1.148100e-01,1.302000e-01,& - & 6.163700e-02,7.283300e-02,8.465800e-02,9.698400e-02,1.098100e-01,& - & 5.251400e-02,6.186000e-02,7.170100e-02,8.196700e-02,9.259600e-02,& - & 4.476900e-02,5.256800e-02,6.076300e-02,6.929600e-02,7.812000e-02,& - & 3.825300e-02,4.475600e-02,5.157800e-02,5.867000e-02,6.601300e-02,& - & 3.266700e-02,3.808800e-02,4.375700e-02,4.965600e-02,5.579300e-02,& - & 2.787700e-02,3.239300e-02,3.710900e-02,4.203000e-02,4.717900e-02,& - & 2.379700e-02,2.755500e-02,3.149100e-02,3.561700e-02,3.992300e-02,& - & 2.029800e-02,2.343200e-02,2.672700e-02,3.018900e-02,3.377300e-02,& - & 1.731400e-02,1.993600e-02,2.270100e-02,2.558700e-02,2.857100e-02,& - & 1.477000e-02,1.697200e-02,1.928100e-02,2.168800e-02,2.416200e-02,& - & 1.260000e-02,1.444600e-02,1.637300e-02,1.837400e-02,2.042400e-02,& - & 1.069600e-02,1.223600e-02,1.383900e-02,1.549700e-02,1.719400e-02,& - & 8.955500e-03,1.023200e-02,1.155900e-02,1.293100e-02,1.433500e-02,& - & 7.384600e-03,8.437300e-03,9.532500e-03,1.066200e-02,1.182200e-02,& - & 5.960600e-03,6.823300e-03,7.720900e-03,8.648700e-03,9.604100e-03,& - & 4.803700e-03,5.510500e-03,6.245900e-03,7.007900e-03,7.794300e-03,& - & 3.870600e-03,4.449100e-03,5.051900e-03,5.677900e-03,6.325100e-03,& - & 3.070500e-03,3.541700e-03,4.033600e-03,4.546100e-03,5.077300e-03,& - & 2.428500e-03,2.811800e-03,3.212900e-03,3.631800e-03,4.067300e-03,& - & 1.918400e-03,2.230000e-03,2.557000e-03,2.899100e-03,3.256100e-03,& - & 1.499900e-03,1.752200e-03,2.018000e-03,2.296600e-03,2.588100e-03,& - & 1.165500e-03,1.369400e-03,1.584900e-03,1.811300e-03,2.048800e-03,& - & 9.037600e-04,1.068200e-03,1.242700e-03,1.426600e-03,1.619900e-03,& - & 6.965000e-04,8.285800e-04,9.695000e-04,1.118600e-03,1.275500e-03,& - & 5.310800e-04,6.364300e-04,7.498400e-04,8.701800e-04,9.972100e-04,& - & 4.036100e-04,4.874200e-04,5.783300e-04,6.753400e-04,7.780700e-04,& - & 3.056600e-04,3.721500e-04,4.447500e-04,5.227900e-04,6.057900e-04,& - & 2.319300e-04,2.845900e-04,3.425100e-04,4.052600e-04,4.723000e-04,& - & 1.759000e-04,2.174800e-04,2.636100e-04,3.139500e-04,3.680400e-04,& - & 1.330400e-04,1.657300e-04,2.024000e-04,2.426500e-04,2.862100e-04,& - & 1.003300e-04,1.259000e-04,1.549600e-04,1.870400e-04,2.220100e-04,& - & 7.604300e-05,9.603300e-05,1.190300e-04,1.446400e-04,1.727100e-04,& - & 5.772500e-05,7.330900e-05,9.148200e-05,1.119000e-04,1.343900e-04,& - & 4.377300e-05,5.584500e-05,7.015500e-05,8.640100e-05,1.043900e-04,& - & 3.317800e-05,4.246600e-05,5.367700e-05,6.656200e-05,8.093200e-05,& - & 2.527600e-05,3.236500e-05,4.113300e-05,5.134300e-05,6.281500e-05,& - & 2.013800e-05,2.577900e-05,3.283600e-05,4.110500e-05,5.043300e-05/ - data absb(:,9) / & - & 2.057500e+00,2.525900e+00,3.023400e+00,3.547100e+00,4.089200e+00,& - & 1.789600e+00,2.193600e+00,2.624300e+00,3.075400e+00,3.535700e+00,& - & 1.553200e+00,1.900500e+00,2.269800e+00,2.653400e+00,3.046000e+00,& - & 1.343100e+00,1.639900e+00,1.954200e+00,2.280100e+00,2.615400e+00,& - & 1.156400e+00,1.409100e+00,1.675000e+00,1.951700e+00,2.235300e+00,& - & 9.926100e-01,1.205900e+00,1.430300e+00,1.663500e+00,1.902900e+00,& - & 8.482900e-01,1.028300e+00,1.217100e+00,1.413100e+00,1.614200e+00,& - & 7.255100e-01,8.768900e-01,1.036000e+00,1.201200e+00,1.370300e+00,& - & 6.193200e-01,7.464500e-01,8.801900e-01,1.018900e+00,1.161600e+00,& - & 5.343600e-01,6.417100e-01,7.544100e-01,8.710400e-01,9.910700e-01,& - & 4.606400e-01,5.511200e-01,6.457000e-01,7.436500e-01,8.443600e-01,& - & 3.969600e-01,4.729200e-01,5.522000e-01,6.345200e-01,7.190500e-01,& - & 3.420600e-01,4.057600e-01,4.724000e-01,5.414400e-01,6.125300e-01,& - & 2.950900e-01,3.486600e-01,4.046200e-01,4.625500e-01,5.221200e-01,& - & 2.543200e-01,2.993800e-01,3.463600e-01,3.948700e-01,4.447300e-01,& - & 2.189700e-01,2.568600e-01,2.962100e-01,3.369000e-01,3.787100e-01,& - & 1.886300e-01,2.203500e-01,2.533800e-01,2.874600e-01,3.227600e-01,& - & 1.622700e-01,1.889100e-01,2.165900e-01,2.453200e-01,2.750800e-01,& - & 1.396100e-01,1.619700e-01,1.852200e-01,2.094600e-01,2.345100e-01,& - & 1.200900e-01,1.388600e-01,1.584800e-01,1.788800e-01,2.000100e-01,& - & 1.032400e-01,1.190400e-01,1.355900e-01,1.528100e-01,1.707100e-01,& - & 8.824500e-02,1.015600e-01,1.155000e-01,1.300600e-01,1.452800e-01,& - & 7.437300e-02,8.555100e-02,9.729700e-02,1.095700e-01,1.225100e-01,& - & 6.170400e-02,7.104900e-02,8.090000e-02,9.125100e-02,1.022100e-01,& - & 5.006000e-02,5.782000e-02,6.602400e-02,7.470100e-02,8.392300e-02,& - & 4.055000e-02,4.699100e-02,5.382600e-02,6.110500e-02,6.886400e-02,& - & 3.284500e-02,3.818500e-02,4.388300e-02,4.999000e-02,5.651200e-02,& - & 2.615900e-02,3.055900e-02,3.527900e-02,4.036400e-02,4.580300e-02,& - & 2.076200e-02,2.438000e-02,2.828500e-02,3.251400e-02,3.704100e-02,& - & 1.645400e-02,1.942600e-02,2.265200e-02,2.616300e-02,2.992900e-02,& - & 1.288900e-02,1.531600e-02,1.796900e-02,2.086500e-02,2.398600e-02,& - & 1.002500e-02,1.200000e-02,1.417200e-02,1.655300e-02,1.913100e-02,& - & 7.774600e-03,9.378400e-03,1.115300e-02,1.310700e-02,1.523200e-02,& - & 5.983900e-03,7.280300e-03,8.723600e-03,1.032000e-02,1.206600e-02,& - & 4.546900e-03,5.587200e-03,6.752700e-03,8.049000e-03,9.473700e-03,& - & 3.438700e-03,4.270700e-03,5.208100e-03,6.257800e-03,7.417000e-03,& - & 2.587200e-03,3.250200e-03,4.001400e-03,4.848700e-03,5.789600e-03,& - & 1.948400e-03,2.476300e-03,3.078200e-03,3.761900e-03,4.525500e-03,& - & 1.464100e-03,1.883300e-03,2.364200e-03,2.915600e-03,3.534300e-03,& - & 1.094700e-03,1.426000e-03,1.809200e-03,2.252500e-03,2.752300e-03,& - & 8.138500e-04,1.074400e-03,1.378800e-03,1.733500e-03,2.136300e-03,& - & 6.072700e-04,8.122700e-04,1.054300e-03,1.338300e-03,1.663400e-03,& - & 4.527200e-04,6.137400e-04,8.058900e-04,1.033100e-03,1.295200e-03,& - & 3.358300e-04,4.618100e-04,6.137700e-04,7.950800e-04,1.005700e-03,& - & 2.477600e-04,3.459000e-04,4.655900e-04,6.097800e-04,7.786100e-04,& - & 1.828300e-04,2.592400e-04,3.533800e-04,4.680800e-04,6.034000e-04,& - & 1.439400e-04,2.056500e-04,2.823100e-04,3.764100e-04,4.876600e-04/ - data absb(:,10) / & - & 9.390400e+00,1.155800e+01,1.384500e+01,1.616300e+01,1.855500e+01,& - & 8.397300e+00,1.027000e+01,1.220900e+01,1.423100e+01,1.640300e+01,& - & 7.422700e+00,9.032800e+00,1.072500e+01,1.253900e+01,1.442400e+01,& - & 6.520500e+00,7.925700e+00,9.431000e+00,1.101200e+01,1.260200e+01,& - & 5.696800e+00,6.923600e+00,8.231300e+00,9.579200e+00,1.095600e+01,& - & 4.947100e+00,6.016100e+00,7.133900e+00,8.294800e+00,9.485700e+00,& - & 4.289500e+00,5.202900e+00,6.164200e+00,7.152700e+00,8.173000e+00,& - & 3.714700e+00,4.492900e+00,5.306800e+00,6.147400e+00,7.007800e+00,& - & 3.202400e+00,3.863100e+00,4.549900e+00,5.259600e+00,5.986700e+00,& - & 2.788100e+00,3.346200e+00,3.929100e+00,4.533200e+00,5.151600e+00,& - & 2.422100e+00,2.893400e+00,3.388800e+00,3.900700e+00,4.429600e+00,& - & 2.101200e+00,2.504200e+00,2.925700e+00,3.360500e+00,3.809900e+00,& - & 1.823400e+00,2.168300e+00,2.523400e+00,2.894000e+00,3.274000e+00,& - & 1.588000e+00,1.877300e+00,2.178100e+00,2.492100e+00,2.818200e+00,& - & 1.379500e+00,1.623300e+00,1.879000e+00,2.146300e+00,2.424600e+00,& - & 1.195200e+00,1.402000e+00,1.620400e+00,1.847300e+00,2.081800e+00,& - & 1.035300e+00,1.212600e+00,1.397400e+00,1.589500e+00,1.785400e+00,& - & 8.971000e-01,1.047900e+00,1.204600e+00,1.366500e+00,1.532100e+00,& - & 7.781700e-01,9.051900e-01,1.038600e+00,1.175400e+00,1.318200e+00,& - & 6.739900e-01,7.825100e-01,8.951500e-01,1.012700e+00,1.136900e+00,& - & 5.840500e-01,6.762200e-01,7.723600e-01,8.740300e-01,9.795600e-01,& - & 5.035700e-01,5.818200e-01,6.645200e-01,7.515100e-01,8.403500e-01,& - & 4.277900e-01,4.944000e-01,5.649100e-01,6.389200e-01,7.133300e-01,& - & 3.577700e-01,4.142100e-01,4.738700e-01,5.361700e-01,5.990000e-01,& - & 2.923400e-01,3.396300e-01,3.897300e-01,4.419400e-01,4.950800e-01,& - & 2.384500e-01,2.780400e-01,3.201400e-01,3.639300e-01,4.088700e-01,& - & 1.944900e-01,2.276200e-01,2.630300e-01,2.998700e-01,3.380800e-01,& - & 1.558100e-01,1.833800e-01,2.129800e-01,2.438800e-01,2.764000e-01,& - & 1.243700e-01,1.472800e-01,1.719800e-01,1.979000e-01,2.256100e-01,& - & 9.911400e-02,1.181400e-01,1.387100e-01,1.604900e-01,1.840900e-01,& - & 7.801400e-02,9.369900e-02,1.107200e-01,1.289700e-01,1.489300e-01,& - & 6.093000e-02,7.381300e-02,8.782900e-02,1.030600e-01,1.199000e-01,& - & 4.743900e-02,5.796300e-02,6.952400e-02,8.217900e-02,9.637700e-02,& - & 3.662800e-02,4.518900e-02,5.466300e-02,6.513900e-02,7.703100e-02,& - & 2.789000e-02,3.478700e-02,4.249300e-02,5.109600e-02,6.096500e-02,& - & 2.111900e-02,2.664500e-02,3.289600e-02,3.992100e-02,4.808900e-02,& - & 1.590000e-02,2.030700e-02,2.535100e-02,3.106400e-02,3.779200e-02,& - & 1.198200e-02,1.548600e-02,1.955300e-02,2.419600e-02,2.972700e-02,& - & 9.005600e-03,1.178800e-02,1.505100e-02,1.881500e-02,2.334800e-02,& - & 6.728700e-03,8.932300e-03,1.154300e-02,1.458100e-02,1.827700e-02,& - & 4.991700e-03,6.731800e-03,8.809500e-03,1.125500e-02,1.425000e-02,& - & 3.716600e-03,5.089700e-03,6.743800e-03,8.715500e-03,1.114700e-02,& - & 2.763100e-03,3.845600e-03,5.159300e-03,6.747600e-03,8.719500e-03,& - & 2.041100e-03,2.890500e-03,3.930800e-03,5.203100e-03,6.794900e-03,& - & 1.497800e-03,2.159800e-03,2.980700e-03,3.994800e-03,5.275200e-03,& - & 1.098500e-03,1.614200e-03,2.261300e-03,3.068700e-03,4.098600e-03,& - & 8.650000e-04,1.283300e-03,1.812700e-03,2.481700e-03,3.344300e-03/ - data absb(:,11) / & - & 1.837200e+01,2.253100e+01,2.694200e+01,3.172100e+01,3.666600e+01,& - & 1.647600e+01,2.026600e+01,2.437500e+01,2.867300e+01,3.296000e+01,& - & 1.483800e+01,1.825800e+01,2.187400e+01,2.554000e+01,2.929900e+01,& - & 1.332200e+01,1.628200e+01,1.936100e+01,2.255300e+01,2.593800e+01,& - & 1.179700e+01,1.434000e+01,1.702200e+01,1.986500e+01,2.280500e+01,& - & 1.035400e+01,1.257600e+01,1.494500e+01,1.740900e+01,1.988000e+01,& - & 9.036500e+00,1.098000e+01,1.303900e+01,1.515200e+01,1.725800e+01,& - & 7.883400e+00,9.569500e+00,1.132700e+01,1.313200e+01,1.493200e+01,& - & 6.855000e+00,8.297000e+00,9.811900e+00,1.133500e+01,1.285600e+01,& - & 6.019900e+00,7.256200e+00,8.532600e+00,9.810400e+00,1.108600e+01,& - & 5.265500e+00,6.315500e+00,7.381300e+00,8.454600e+00,9.520500e+00,& - & 4.596800e+00,5.476500e+00,6.371700e+00,7.277200e+00,8.175200e+00,& - & 4.004600e+00,4.743700e+00,5.501200e+00,6.258200e+00,7.024300e+00,& - & 3.489900e+00,4.115600e+00,4.754400e+00,5.397800e+00,6.047800e+00,& - & 3.037000e+00,3.570400e+00,4.108300e+00,4.655900e+00,5.202600e+00,& - & 2.644100e+00,3.090800e+00,3.545200e+00,4.009200e+00,4.477400e+00,& - & 2.299100e+00,2.674400e+00,3.060900e+00,3.454500e+00,3.857100e+00,& - & 1.995200e+00,2.313000e+00,2.643600e+00,2.978500e+00,3.322400e+00,& - & 1.730300e+00,2.003500e+00,2.282800e+00,2.569800e+00,2.859700e+00,& - & 1.502100e+00,1.734900e+00,1.972300e+00,2.216200e+00,2.460700e+00,& - & 1.304800e+00,1.502200e+00,1.705400e+00,1.911200e+00,2.125500e+00,& - & 1.126700e+00,1.295200e+00,1.468200e+00,1.645700e+00,1.835200e+00,& - & 9.595800e-01,1.103300e+00,1.251400e+00,1.406300e+00,1.573000e+00,& - & 8.054300e-01,9.272800e-01,1.054600e+00,1.189500e+00,1.334600e+00,& - & 6.611700e-01,7.642900e-01,8.731100e-01,9.895600e-01,1.113800e+00,& - & 5.421900e-01,6.291500e-01,7.222000e-01,8.218900e-01,9.283200e-01,& - & 4.447400e-01,5.185100e-01,5.975800e-01,6.826900e-01,7.737900e-01,& - & 3.587400e-01,4.207700e-01,4.873800e-01,5.593000e-01,6.366600e-01,& - & 2.880900e-01,3.401800e-01,3.962300e-01,4.570200e-01,5.226500e-01,& - & 2.309300e-01,2.745300e-01,3.217500e-01,3.730400e-01,4.286600e-01,& - & 1.828600e-01,2.190800e-01,2.586000e-01,3.016900e-01,3.486600e-01,& - & 1.437100e-01,1.736400e-01,2.065500e-01,2.425800e-01,2.821800e-01,& - & 1.125400e-01,1.372400e-01,1.645800e-01,1.946600e-01,2.280000e-01,& - & 8.741900e-02,1.076900e-01,1.302900e-01,1.553400e-01,1.832500e-01,& - & 6.694600e-02,8.345500e-02,1.019800e-01,1.226600e-01,1.458800e-01,& - & 5.094100e-02,6.433800e-02,7.948500e-02,9.652300e-02,1.157300e-01,& - & 3.850600e-02,4.932600e-02,6.166200e-02,7.568200e-02,9.153600e-02,& - & 2.910300e-02,3.784000e-02,4.786800e-02,5.937600e-02,7.248200e-02,& - & 2.191600e-02,2.895100e-02,3.706700e-02,4.649900e-02,5.731700e-02,& - & 1.639200e-02,2.202000e-02,2.857500e-02,3.626800e-02,4.516900e-02,& - & 1.217200e-02,1.664200e-02,2.190800e-02,2.815500e-02,3.545700e-02,& - & 9.065800e-03,1.261300e-02,1.684700e-02,2.191500e-02,2.790600e-02,& - & 6.744400e-03,9.548300e-03,1.294700e-02,1.704100e-02,2.195400e-02,& - & 4.983700e-03,7.189300e-03,9.903100e-03,1.320100e-02,1.721500e-02,& - & 3.655500e-03,5.379700e-03,7.534500e-03,1.018500e-02,1.344800e-02,& - & 2.679800e-03,4.023400e-03,5.732200e-03,7.859100e-03,1.050900e-02,& - & 2.117400e-03,3.212600e-03,4.617800e-03,6.389000e-03,8.630700e-03/ - data absb(:,12) / & - & 3.903700e+01,4.859500e+01,5.829000e+01,6.774300e+01,7.717500e+01,& - & 3.673100e+01,4.514300e+01,5.336700e+01,6.173500e+01,7.026600e+01,& - & 3.378200e+01,4.105300e+01,4.846500e+01,5.610100e+01,6.404600e+01,& - & 3.036100e+01,3.683700e+01,4.369200e+01,5.074900e+01,5.777000e+01,& - & 2.718100e+01,3.303700e+01,3.912200e+01,4.523600e+01,5.130200e+01,& - & 2.428900e+01,2.937300e+01,3.457300e+01,3.982000e+01,4.525400e+01,& - & 2.148900e+01,2.583200e+01,3.028600e+01,3.489500e+01,3.972800e+01,& - & 1.888900e+01,2.262600e+01,2.651600e+01,3.057300e+01,3.472900e+01,& - & 1.649900e+01,1.977200e+01,2.316900e+01,2.666800e+01,3.024700e+01,& - & 1.456400e+01,1.739700e+01,2.033200e+01,2.337500e+01,2.648200e+01,& - & 1.281100e+01,1.525400e+01,1.780300e+01,2.043600e+01,2.311000e+01,& - & 1.125000e+01,1.335400e+01,1.554900e+01,1.779700e+01,2.009400e+01,& - & 9.859700e+00,1.167000e+01,1.353700e+01,1.546600e+01,1.742300e+01,& - & 8.644700e+00,1.018100e+01,1.177900e+01,1.341700e+01,1.508100e+01,& - & 7.559400e+00,8.864200e+00,1.022600e+01,1.163000e+01,1.305800e+01,& - & 6.592500e+00,7.716100e+00,8.889700e+00,1.008700e+01,1.132700e+01,& - & 5.756500e+00,6.724000e+00,7.726800e+00,8.763200e+00,9.840900e+00,& - & 5.029000e+00,5.863600e+00,6.724700e+00,7.629000e+00,8.559900e+00,& - & 4.403500e+00,5.118200e+00,5.868000e+00,6.655500e+00,7.466500e+00,& - & 3.857800e+00,4.475200e+00,5.130800e+00,5.815100e+00,6.527800e+00,& - & 3.379400e+00,3.916700e+00,4.490400e+00,5.088000e+00,5.714800e+00,& - & 2.948600e+00,3.419300e+00,3.916700e+00,4.441000e+00,4.989800e+00,& - & 2.538400e+00,2.948500e+00,3.380600e+00,3.838200e+00,4.313800e+00,& - & 2.152400e+00,2.506200e+00,2.880200e+00,3.277600e+00,3.693300e+00,& - & 1.783300e+00,2.084700e+00,2.407200e+00,2.750500e+00,3.112400e+00,& - & 1.474900e+00,1.732600e+00,2.010800e+00,2.306700e+00,2.624400e+00,& - & 1.219400e+00,1.440300e+00,1.680700e+00,1.937300e+00,2.216400e+00,& - & 9.901000e-01,1.177600e+00,1.383800e+00,1.605500e+00,1.848900e+00,& - & 8.015000e-01,9.600200e-01,1.136000e+00,1.328100e+00,1.539600e+00,& - & 6.477800e-01,7.819400e-01,9.322300e-01,1.098000e+00,1.282400e+00,& - & 5.167600e-01,6.295500e-01,7.571000e-01,8.990800e-01,1.058300e+00,& - & 4.090100e-01,5.032000e-01,6.107100e-01,7.318100e-01,8.684800e-01,& - & 3.226500e-01,4.013100e-01,4.914700e-01,5.941200e-01,7.112400e-01,& - & 2.521000e-01,3.174700e-01,3.928400e-01,4.793700e-01,5.788600e-01,& - & 1.938700e-01,2.475000e-01,3.101400e-01,3.826200e-01,4.663400e-01,& - & 1.482800e-01,1.919200e-01,2.435100e-01,3.040300e-01,3.744200e-01,& - & 1.126800e-01,1.479600e-01,1.902100e-01,2.402600e-01,2.993400e-01,& - & 8.569200e-02,1.141900e-01,1.487600e-01,1.900700e-01,2.394800e-01,& - & 6.496800e-02,8.789800e-02,1.160400e-01,1.501600e-01,1.913700e-01,& - & 4.891300e-02,6.728000e-02,9.011700e-02,1.181400e-01,1.523800e-01,& - & 3.653700e-02,5.112500e-02,6.960900e-02,9.247200e-02,1.207600e-01,& - & 2.738900e-02,3.899900e-02,5.393200e-02,7.267600e-02,9.604900e-02,& - & 2.048700e-02,2.970100e-02,4.172500e-02,5.707500e-02,7.639000e-02,& - & 1.521100e-02,2.247300e-02,3.209600e-02,4.455200e-02,6.053400e-02,& - & 1.120600e-02,1.689200e-02,2.454300e-02,3.459600e-02,4.768900e-02,& - & 8.252000e-03,1.268600e-02,1.875800e-02,2.687300e-02,3.758800e-02,& - & 6.570000e-03,1.022100e-02,1.529700e-02,2.216100e-02,3.134300e-02/ - data absb(:,13) / & - & 1.587560e+02,1.956894e+02,2.344366e+02,2.741451e+02,3.146894e+02,& - & 1.584699e+02,1.945459e+02,2.325356e+02,2.718256e+02,3.119739e+02,& - & 1.568853e+02,1.922278e+02,2.294186e+02,2.679401e+02,3.070967e+02,& - & 1.546355e+02,1.888959e+02,2.252044e+02,2.621186e+02,2.996274e+02,& - & 1.511648e+02,1.840900e+02,2.184906e+02,2.529899e+02,2.877136e+02,& - & 1.460501e+02,1.767647e+02,2.085047e+02,2.407362e+02,2.731294e+02,& - & 1.387901e+02,1.672346e+02,1.967639e+02,2.268136e+02,2.570526e+02,& - & 1.302884e+02,1.569042e+02,1.844685e+02,2.126037e+02,2.409272e+02,& - & 1.212129e+02,1.457147e+02,1.713138e+02,1.972801e+02,2.233675e+02,& - & 1.134700e+02,1.359567e+02,1.591590e+02,1.826278e+02,2.062439e+02,& - & 1.054524e+02,1.257394e+02,1.464561e+02,1.677636e+02,1.893723e+02,& - & 9.746170e+01,1.154812e+02,1.340355e+02,1.532282e+02,1.729868e+02,& - & 8.955136e+01,1.055880e+02,1.223036e+02,1.397430e+02,1.577728e+02,& - & 8.192205e+01,9.641877e+01,1.115719e+02,1.273384e+02,1.434050e+02,& - & 7.463981e+01,8.775568e+01,1.014753e+02,1.155671e+02,1.301648e+02,& - & 6.786403e+01,7.966084e+01,9.200494e+01,1.049184e+02,1.183407e+02,& - & 6.175622e+01,7.234334e+01,8.355562e+01,9.547509e+01,1.078980e+02,& - & 5.614631e+01,6.574425e+01,7.610429e+01,8.704662e+01,9.866976e+01,& - & 5.108380e+01,5.991574e+01,6.951126e+01,7.969583e+01,9.054421e+01,& - & 4.665028e+01,5.482854e+01,6.373904e+01,7.324370e+01,8.342273e+01,& - & 4.281424e+01,5.042607e+01,5.868592e+01,6.761449e+01,7.729850e+01,& - & 3.926323e+01,4.631783e+01,5.406316e+01,6.247689e+01,7.178176e+01,& - & 3.556804e+01,4.212207e+01,4.935979e+01,5.734601e+01,6.627663e+01,& - & 3.174377e+01,3.781481e+01,4.455603e+01,5.210807e+01,6.058125e+01,& - & 2.764215e+01,3.319909e+01,3.941208e+01,4.644625e+01,5.439787e+01,& - & 2.408289e+01,2.917569e+01,3.492513e+01,4.150417e+01,4.895561e+01,& - & 2.102390e+01,2.570737e+01,3.105033e+01,3.722067e+01,4.424658e+01,& - & 1.800085e+01,2.224292e+01,2.716201e+01,3.287592e+01,3.943936e+01,& - & 1.537058e+01,1.921305e+01,2.372433e+01,2.901448e+01,3.515550e+01,& - & 1.312131e+01,1.661223e+01,2.074626e+01,2.564821e+01,3.138797e+01,& - & 1.103085e+01,1.416746e+01,1.792229e+01,2.242997e+01,2.776056e+01,& - & 9.185308e+00,1.198959e+01,1.538826e+01,1.950457e+01,2.443733e+01,& - & 7.630261e+00,1.012576e+01,1.319379e+01,1.694300e+01,2.150403e+01,& - & 6.273570e+00,8.472290e+00,1.122515e+01,1.462858e+01,1.880637e+01,& - & 5.058706e+00,6.970900e+00,9.404226e+00,1.245690e+01,1.625529e+01,& - & 4.049263e+00,5.703601e+00,7.844185e+00,1.057218e+01,1.399979e+01,& - & 3.218148e+00,4.636550e+00,6.510106e+00,8.935145e+00,1.200905e+01,& - & 2.562171e+00,3.776063e+00,5.413494e+00,7.573512e+00,1.034613e+01,& - & 2.037835e+00,3.070493e+00,4.500036e+00,6.417964e+00,8.918818e+00,& - & 1.607017e+00,2.480545e+00,3.718399e+00,5.410818e+00,7.665372e+00,& - & 1.255503e+00,1.991711e+00,3.053522e+00,4.540524e+00,6.558228e+00,& - & 9.866362e-01,1.608368e+00,2.525617e+00,3.836711e+00,5.647538e+00,& - & 7.751155e-01,1.297594e+00,2.091827e+00,3.244951e+00,4.870890e+00,& - & 6.041880e-01,1.039632e+00,1.724195e+00,2.733113e+00,4.182720e+00,& - & 4.678159e-01,8.277239e-01,1.410400e+00,2.291425e+00,3.579805e+00,& - & 3.623452e-01,6.600511e-01,1.155504e+00,1.925607e+00,3.070923e+00,& - & 3.132836e-01,5.836613e-01,1.041533e+00,1.765627e+00,2.852406e+00/ - data absb(:,14) / & - & 1.338855e+03,1.646507e+03,1.930478e+03,2.241308e+03,2.519244e+03,& - & 1.457082e+03,1.788126e+03,2.100791e+03,2.412002e+03,2.715987e+03,& - & 1.603113e+03,1.938967e+03,2.279399e+03,2.604526e+03,2.941018e+03,& - & 1.733218e+03,2.100743e+03,2.462136e+03,2.802548e+03,3.176417e+03,& - & 1.871846e+03,2.261044e+03,2.634156e+03,3.012718e+03,3.402035e+03,& - & 2.014241e+03,2.429442e+03,2.829721e+03,3.245403e+03,3.645161e+03,& - & 2.156679e+03,2.605740e+03,3.046750e+03,3.466961e+03,3.898417e+03,& - & 2.320469e+03,2.785729e+03,3.254240e+03,3.702219e+03,4.144417e+03,& - & 2.488573e+03,2.972482e+03,3.445563e+03,3.929447e+03,4.393128e+03,& - & 2.683356e+03,3.188935e+03,3.682325e+03,4.176066e+03,4.671022e+03,& - & 2.887790e+03,3.408745e+03,3.921849e+03,4.432684e+03,4.945644e+03,& - & 3.090730e+03,3.626160e+03,4.161363e+03,4.705675e+03,5.215653e+03,& - & 3.299207e+03,3.850656e+03,4.409190e+03,4.959009e+03,5.480826e+03,& - & 3.513449e+03,4.081664e+03,4.653172e+03,5.212444e+03,5.747674e+03,& - & 3.730094e+03,4.310521e+03,4.891567e+03,5.461811e+03,6.005514e+03,& - & 3.944772e+03,4.535149e+03,5.122501e+03,5.702649e+03,6.240449e+03,& - & 4.159961e+03,4.758796e+03,5.353102e+03,5.938319e+03,6.478959e+03,& - & 4.371963e+03,4.976804e+03,5.575981e+03,6.149735e+03,6.707861e+03,& - & 4.583632e+03,5.193309e+03,5.795106e+03,6.370711e+03,6.930116e+03,& - & 4.792820e+03,5.405149e+03,6.009564e+03,6.585958e+03,7.145733e+03,& - & 4.998936e+03,5.613278e+03,6.218784e+03,6.795056e+03,7.353708e+03,& - & 5.178912e+03,5.794807e+03,6.401222e+03,6.976731e+03,7.534370e+03,& - & 5.290979e+03,5.912911e+03,6.520002e+03,7.096690e+03,7.654713e+03,& - & 5.332396e+03,5.958027e+03,6.564108e+03,7.147621e+03,7.709240e+03,& - & 5.273303e+03,5.904244e+03,6.515789e+03,7.105888e+03,7.673302e+03,& - & 5.204465e+03,5.839766e+03,6.457092e+03,7.053011e+03,7.627379e+03,& - & 5.131957e+03,5.771825e+03,6.393442e+03,6.994649e+03,7.574458e+03,& - & 4.989625e+03,5.634336e+03,6.262756e+03,6.871303e+03,7.474878e+03,& - & 4.835391e+03,5.484615e+03,6.118467e+03,6.734657e+03,7.345818e+03,& - & 4.676446e+03,5.330176e+03,5.970193e+03,6.592234e+03,7.210701e+03,& - & 4.479468e+03,5.136208e+03,5.781734e+03,6.410970e+03,7.037455e+03,& - & 4.263350e+03,4.922498e+03,5.573239e+03,6.209388e+03,6.843825e+03,& - & 4.045447e+03,4.706158e+03,5.360919e+03,6.013004e+03,6.645618e+03,& - & 3.812084e+03,4.473259e+03,5.131285e+03,5.789078e+03,6.429350e+03,& - & 3.551828e+03,4.210880e+03,4.871495e+03,5.534020e+03,6.181513e+03,& - & 3.297320e+03,3.947402e+03,4.609080e+03,5.275434e+03,5.929748e+03,& - & 3.040482e+03,3.689879e+03,4.345161e+03,5.013934e+03,5.674054e+03,& - & 2.803042e+03,3.444522e+03,4.097473e+03,4.767169e+03,5.431631e+03,& - & 2.576829e+03,3.208526e+03,3.859946e+03,4.526477e+03,5.194223e+03,& - & 2.355595e+03,2.975749e+03,3.620905e+03,4.285483e+03,4.954889e+03,& - & 2.139916e+03,2.745636e+03,3.382804e+03,4.044234e+03,4.713869e+03,& - & 1.948216e+03,2.538810e+03,3.166659e+03,3.823324e+03,4.492112e+03,& - & 1.770317e+03,2.344669e+03,2.961445e+03,3.612572e+03,4.279743e+03,& - & 1.599268e+03,2.155410e+03,2.760089e+03,3.403371e+03,4.064961e+03,& - & 1.435394e+03,1.971253e+03,2.561684e+03,3.196040e+03,3.853260e+03,& - & 1.287123e+03,1.802069e+03,2.377375e+03,3.001500e+03,3.652940e+03,& - & 1.229712e+03,1.735993e+03,2.304938e+03,2.924730e+03,3.573704e+03/ - -! the array selfref contains the coefficient of the water vapor -! self-continuum (including the energy term). the first index -! refers to temperature in 7.2 degree increments. for instance, -! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, -! etc. the second index runs over the g-channel (1 to NG02=14). - - data selfref(:, 1) / & - & 7.542320e-01,6.872310e-01,6.261810e-01,5.705550e-01,5.198700e-01,& - & 4.736880e-01,4.316080e-01,3.932660e-01,3.583310e-01,3.264990e-01/ - data selfref(:, 2) / & - & 1.013770e+00,9.302660e-01,8.536370e-01,7.833200e-01,7.187960e-01,& - & 6.595870e-01,6.052540e-01,5.553980e-01,5.096480e-01,4.676670e-01/ - data selfref(:, 3) / & - & 1.319540e+00,1.225230e+00,1.137660e+00,1.056350e+00,9.808530e-01,& - & 9.107490e-01,8.456560e-01,7.852150e-01,7.290950e-01,6.769850e-01/ - data selfref(:, 4) / & - & 2.187260e+00,2.059600e+00,1.939400e+00,1.826210e+00,1.719620e+00,& - & 1.619260e+00,1.524760e+00,1.435770e+00,1.351970e+00,1.273060e+00/ - data selfref(:, 5) / & - & 3.174400e+00,2.927940e+00,2.700610e+00,2.490940e+00,2.297540e+00,& - & 2.119160e+00,1.954630e+00,1.802870e+00,1.662900e+00,1.533790e+00/ - data selfref(:, 6) / & - & 2.697050e+00,2.486840e+00,2.293020e+00,2.114310e+00,1.949520e+00,& - & 1.797580e+00,1.657480e+00,1.528300e+00,1.409190e+00,1.299360e+00/ - data selfref(:, 7) / & - & 2.918930e+00,2.683710e+00,2.467450e+00,2.268620e+00,2.085810e+00,& - & 1.917730e+00,1.763190e+00,1.621110e+00,1.490480e+00,1.370370e+00/ - data selfref(:, 8) / & - & 2.918470e+00,2.691380e+00,2.481950e+00,2.288830e+00,2.110730e+00,& - & 1.946480e+00,1.795020e+00,1.655350e+00,1.526540e+00,1.407760e+00/ - data selfref(:, 9) / & - & 2.739940e+00,2.548340e+00,2.370140e+00,2.204400e+00,2.050260e+00,& - & 1.906890e+00,1.773540e+00,1.649520e+00,1.534180e+00,1.426900e+00/ - data selfref(:,10) / & - & 2.819020e+00,2.660100e+00,2.510140e+00,2.368630e+00,2.235100e+00,& - & 2.109090e+00,1.990200e+00,1.878000e+00,1.772130e+00,1.672220e+00/ - data selfref(:,11) / & - & 3.194300e+00,2.976710e+00,2.773950e+00,2.585000e+00,2.408910e+00,& - & 2.244830e+00,2.091920e+00,1.949420e+00,1.816630e+00,1.692890e+00/ - data selfref(:,12) / & - & 3.247780e+00,3.045350e+00,2.855530e+00,2.677550e+00,2.510660e+00,& - & 2.354170e+00,2.207440e+00,2.069850e+00,1.940840e+00,1.819870e+00/ - data selfref(:,13) / & - & 3.696856e+00,3.434696e+00,3.191196e+00,2.965013e+00,2.754920e+00,& - & 2.559764e+00,2.378481e+00,2.210088e+00,2.053649e+00,1.908322e+00/ - data selfref(:,14) / & - & 4.344872e+00,4.037020e+00,3.750993e+00,3.485247e+00,3.238350e+00,& - & 3.008960e+00,2.795829e+00,2.597805e+00,2.413821e+00,2.242877e+00/ - - data forref / & - & -2.345500e-03,-8.426980e-03,-2.018160e-02,-5.667010e-02, & - & -8.931890e-02,-6.374870e-02,-4.564550e-02,-4.414170e-02, & - & -4.486050e-02,-4.746960e-02,-5.166480e-02,-5.630990e-02, & - & -4.397315e-02,-2.165847e-02 / - - data fracrefa(:,:) / & - & 0.1806806028,0.1680317521,0.1514015794,0.1222148016,0.1024084985,& - & 0.0933029726,0.0751895979,0.0561129414,0.0378148705,0.0038719201,& - & 0.0032128501,0.0024444000,0.0028725001,0.0004385800,0.1792762130,& - & 0.1673116833,0.1512953788,0.1232808530,0.1024348363,0.0935479626,& - & 0.0753841773,0.0563307106,0.0381083190,0.0039834701,0.0032026200,& - & 0.0025002901,0.0028979301,0.0004460700,0.1776288599,0.1663855463,& - & 0.1511544585,0.1247062311,0.1025321335,0.0938345864,0.0756023973,& - & 0.0564656816,0.0384407714,0.0040914202,0.0032252099,0.0025491801,& - & 0.0029294798,0.0004542800,0.1756604314,0.1653977334,0.1509219855,& - & 0.1257197112,0.1034060866,0.0942618921,0.0755905136,0.0567818806,& - & 0.0388149917,0.0041410201,0.0032855100,0.0025879501,0.0029679299,& - & 0.0004632600,0.1733582467,0.1644254774,0.1507070065,0.1266746372,& - & 0.1045230329,0.0945083275,0.0759940967,0.0570639297,0.0391037017,& - & 0.0041788002,0.0033525601,0.0026170800,0.0030211802,0.0004722300,& - & 0.1708254367,0.1632151604,0.1504424661,0.1279761195,0.1057464629,& - & 0.0947005674,0.0764742270,0.0573875606,0.0393562093,0.0042378898,& - & 0.0034265099,0.0026454900,0.0030846901,0.0004817500,0.1680927724,& - & 0.1619333625,0.1501318365,0.1293740869,0.1072078422,0.0948536769,& - & 0.0769263580,0.0577177405,0.0396698788,0.0042775399,0.0034969600,& - & 0.0026894601,0.0031375801,0.0004917400,0.1651799679,0.1605924815,& - & 0.1498485208,0.1307926923,0.1086502969,0.0949294716,0.0775973573,& - & 0.0581220090,0.0399716906,0.0043235598,0.0035530799,0.0027403100,& - & 0.0031964399,0.0005020800,0.1620917916,0.1591202319,0.1493822336,& - & 0.1319824457,0.1107723266,0.0948794782,0.0783163607,0.0586344004,& - & 0.0402823910,0.0043680398,0.0036040701,0.0027988499,0.0032522499,& - & 0.0005151700,0.1596242487,0.1578934342,0.1489810348,0.1327522993,& - & 0.1125394031,0.0950350165,0.0788438171,0.0590800904,0.0405352414,& - & 0.0043997099,0.0036426899,0.0028496501,0.0032983399,0.0005252200,& - & 0.1592620015,0.1577093154,0.1489172876,0.1328388155,0.1127600968,& - & 0.0950731114,0.0789222196,0.0591922998,0.0405482389,0.0044083302,& - & 0.0036557501,0.0028645899,0.0033219100,0.0005265000,0.1592635065,& - & 0.1577048302,0.1489117742,0.1327996552,0.1126817092,0.0951521620,& - & 0.0789034069,0.0592480712,0.0405285098,0.0044086999,0.0036542499,& - & 0.0028687799,0.0033466299,0.0005281000,0.1593776494,0.1577578038,& - & 0.1489260346,0.1327324808,0.1125273108,0.0952165723,0.0788585767,& - & 0.0592767894,0.0405018404,0.0044028498,0.0036574800,0.0028679101,& - & 0.0033670000,0.0005298700 / - data fracrefb / & - & 0.1744428873,0.1646726876,0.1502148956,0.1246090233,0.1040064320,& - & 0.0948192775,0.0759070367,0.0575285591,0.0393171497,0.0042857202,& - & 0.0034935200,0.0027893800,0.0033348501,0.0005781500 / - -! these are the mixing ratios for h2o for a mls atmosphere at the -! 13 rrtm reference pressure levels: 1.8759999e-02, 1.2223309e-02, -! 5.8908667e-03, 2.7675382e-03, 1.4065107e-03, 7.5969833e-04, -! 3.8875898e-04, 1.6542293e-04, 3.7189537e-05, 7.4764857e-06, -! 4.3081886e-06, 3.3319423e-06, 3.2039343e-06/ -! -! the following are parameters related to the reference water vapor -! mixing ratios by refparam(i) = refh2o(i) / (.002+refh2o(i)). -! these parameters are used for the planck function interpolation. - - data refparam / & - & 0.903661, 0.859386, 0.746542, 0.580496, 0.412889, 0.275283, & - & 0.162745, 7.63929e-02, 1.82553e-02, 3.72432e-03, & - & 2.14946e-03, 1.66320e-03, 1.59940e-03 / - -!........................................! - end module module_radlw_kgb02 ! -!========================================! - - - -!========================================! - module module_radlw_kgb03 ! -!........................................! -! - use machine, only : kind_phys - use module_radlw_parameters, only : NG03 -! - implicit none -! - private -! - integer, public :: MSA03, MSB03, MSF03, MAF03, MBF03, MEF03, MOF03 - parameter (MSA03=650, MSB03=1175, MSF03=10) - parameter (MAF03=10, MBF03=5, MEF03=10, MOF03=59) - - real (kind=kind_phys), public :: & - & absa(MSA03,NG03), absb(MSB03,NG03), selfref(MSF03,NG03), & - & forref(NG03), fracrefa(NG03,MAF03), fracrefb(NG03,MBF03), & - & absn2oa(NG03), absn2ob(NG03), h2oref(MOF03), n2oref(MOF03),& - & co2ref(MOF03), etaref(MEF03) - -! the array absa(650,NG03) = ka(10,5,13,NG03) contains absorption coefs -! at the NG03=16 g-intervals for a range of pressure levels > ~100mb, -! temperatures, and ratios of water vapor to co2. the first index in -! the array, js, runs from 1 to 10, and corresponds to different water -! vapor to co2 ratios, as expressed through the binary species -! parameter eta, defined as eta = h2o/(h20+(rat)*co2), where rat is -! the ratio of the integrated line strength in the band of co2 to that -! of h2o. for instance, js=1 refers to dry air (eta = 0), js = 10 -! corresponds to eta = 1.0. the 2nd index in the array, jt, which runs -! from 1 to 5, corresponds to different temperatures. more specifically, -! jt = 1-5 means that the data are for the corresponding temperature of -! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the -! third index, jp, runs from 1 to 13 and refers to the reference -! pressure level (e.g. jp = 1 is for a pressure of 1053.63 mb). the -! fourth index, ig, goes from 1 to NG03=16, and tells us which -! g-interval the absorption coefficients are for. - - data absa(1:300,1) / & - & 1.390500e-05,5.549100e-04,9.406900e-04,1.268300e-03,1.575800e-03,& - & 1.865700e-03,2.127100e-03,2.331000e-03,2.223800e-03,1.209800e-03,& - & 1.871800e-05,6.225400e-04,1.041900e-03,1.394400e-03,1.709600e-03,& - & 2.007000e-03,2.278300e-03,2.492100e-03,2.489300e-03,1.332900e-03,& - & 2.527700e-05,7.079100e-04,1.167900e-03,1.554000e-03,1.882600e-03,& - & 2.185500e-03,2.463700e-03,2.683600e-03,2.487000e-03,1.468300e-03,& - & 3.397400e-05,8.147900e-04,1.327700e-03,1.749500e-03,2.101900e-03,& - & 2.411500e-03,2.695500e-03,2.914400e-03,2.678600e-03,1.583500e-03,& - & 4.501800e-05,9.462100e-04,1.522500e-03,1.988800e-03,2.373500e-03,& - & 2.692400e-03,2.976700e-03,3.190400e-03,2.919900e-03,1.719600e-03,& - & 1.059200e-05,4.449900e-04,7.648000e-04,1.036100e-03,1.285100e-03,& - & 1.518300e-03,1.726000e-03,1.886100e-03,1.786900e-03,9.518900e-04,& - & 1.423300e-05,4.975400e-04,8.438600e-04,1.136400e-03,1.393000e-03,& - & 1.630800e-03,1.845000e-03,2.008800e-03,1.984300e-03,1.040600e-03,& - & 1.930600e-05,5.643600e-04,9.428500e-04,1.261100e-03,1.531800e-03,& - & 1.775300e-03,1.993100e-03,2.158800e-03,2.012800e-03,1.149800e-03,& - & 2.611900e-05,6.484200e-04,1.068000e-03,1.414700e-03,1.707100e-03,& - & 1.956700e-03,2.178900e-03,2.340100e-03,2.153800e-03,1.235800e-03,& - & 3.487100e-05,7.525600e-04,1.222100e-03,1.604500e-03,1.920400e-03,& - & 2.182400e-03,2.404700e-03,2.559900e-03,2.355800e-03,1.345800e-03,& - & 7.665000e-06,3.494700e-04,6.086700e-04,8.311900e-04,1.032300e-03,& - & 1.218500e-03,1.383000e-03,1.508700e-03,1.418700e-03,7.532500e-04,& - & 1.020800e-05,3.879900e-04,6.672700e-04,9.056900e-04,1.114000e-03,& - & 1.303900e-03,1.472800e-03,1.599400e-03,1.554100e-03,8.182600e-04,& - & 1.385200e-05,4.374500e-04,7.413200e-04,9.980100e-04,1.219200e-03,& - & 1.413700e-03,1.584900e-03,1.712300e-03,1.659300e-03,8.952800e-04,& - & 1.887300e-05,5.008400e-04,8.348800e-04,1.113600e-03,1.350500e-03,& - & 1.552900e-03,1.724900e-03,1.848700e-03,1.714100e-03,9.647200e-04,& - & 2.541200e-05,5.798900e-04,9.508300e-04,1.257700e-03,1.511000e-03,& - & 1.726500e-03,1.900100e-03,2.015400e-03,1.859200e-03,1.051400e-03,& - & 5.532700e-06,2.737000e-04,4.820200e-04,6.629300e-04,8.270500e-04,& - & 9.762100e-04,1.107100e-03,1.214900e-03,1.136500e-03,6.223500e-04,& - & 7.238100e-06,3.013800e-04,5.241600e-04,7.169700e-04,8.862000e-04,& - & 1.039100e-03,1.173000e-03,1.272600e-03,1.211300e-03,6.732000e-04,& - & 9.769800e-06,3.372100e-04,5.785600e-04,7.851200e-04,9.645900e-04,& - & 1.121000e-03,1.256500e-03,1.354900e-03,1.345200e-03,7.241600e-04,& - & 1.334400e-05,3.838100e-04,6.473900e-04,8.703800e-04,1.061500e-03,& - & 1.225200e-03,1.361200e-03,1.457600e-03,1.365500e-03,7.832500e-04,& - & 1.809000e-05,4.425800e-04,7.328800e-04,9.775400e-04,1.181300e-03,& - & 1.354900e-03,1.492600e-03,1.582200e-03,1.460700e-03,8.522100e-04,& - & 4.081000e-06,2.155100e-04,3.828300e-04,5.294000e-04,6.636800e-04,& - & 7.850300e-04,8.889700e-04,9.787000e-04,9.288500e-04,5.311200e-04,& - & 5.191600e-06,2.350700e-04,4.127100e-04,5.682600e-04,7.056800e-04,& - & 8.297100e-04,9.369500e-04,1.016800e-03,9.522000e-04,5.684000e-04,& - & 6.915900e-06,2.608800e-04,4.520800e-04,6.179700e-04,7.630100e-04,& - & 8.897900e-04,9.985300e-04,1.075900e-03,1.038900e-03,6.077700e-04,& - & 9.419600e-06,2.948000e-04,5.027400e-04,6.808800e-04,8.355000e-04,& - & 9.674600e-04,1.076400e-03,1.152200e-03,1.131300e-03,6.557700e-04,& - & 1.282300e-05,3.383400e-04,5.655500e-04,7.600000e-04,9.245900e-04,& - & 1.064000e-03,1.174500e-03,1.245600e-03,1.159900e-03,7.120500e-04,& - & 3.074500e-06,1.702800e-04,3.046700e-04,4.235100e-04,5.332400e-04,& - & 6.316600e-04,7.136200e-04,7.759500e-04,7.255500e-04,4.676600e-04,& - & 3.746700e-06,1.836400e-04,3.253300e-04,4.499200e-04,5.617400e-04,& - & 6.628900e-04,7.491800e-04,8.199200e-04,7.721700e-04,4.954000e-04,& - & 4.884400e-06,2.018900e-04,3.531800e-04,4.861100e-04,6.024800e-04,& - & 7.054800e-04,7.934300e-04,8.555600e-04,8.171900e-04,5.287100e-04,& - & 6.587500e-06,2.262300e-04,3.898700e-04,5.317400e-04,6.561500e-04,& - & 7.625500e-04,8.510500e-04,9.116400e-04,9.077600e-04,5.673800e-04,& - & 8.978200e-06,2.579700e-04,4.357400e-04,5.894500e-04,7.218000e-04,& - & 8.340100e-04,9.228800e-04,9.805900e-04,9.271500e-04,6.134000e-04/ - data absa(301:650,1) / & - & 2.385200e-06,1.353700e-04,2.437600e-04,3.404600e-04,4.295300e-04,& - & 5.087700e-04,5.735300e-04,6.119200e-04,5.727000e-04,4.331900e-04,& - & 2.762000e-06,1.442900e-04,2.576100e-04,3.575200e-04,4.486100e-04,& - & 5.310200e-04,5.996600e-04,6.581700e-04,6.254100e-04,4.575000e-04,& - & 3.488000e-06,1.570100e-04,2.770100e-04,3.834400e-04,4.769100e-04,& - & 5.609200e-04,6.322000e-04,6.839100e-04,6.433300e-04,4.866400e-04,& - & 4.619200e-06,1.742800e-04,3.033000e-04,4.164000e-04,5.160800e-04,& - & 6.019200e-04,6.738700e-04,7.230200e-04,7.002900e-04,5.211500e-04,& - & 6.265900e-06,1.972300e-04,3.366800e-04,4.582800e-04,5.644200e-04,& - & 6.546500e-04,7.269900e-04,7.740500e-04,7.741300e-04,5.600200e-04,& - & 1.901500e-06,1.082000e-04,1.959200e-04,2.748400e-04,3.468800e-04,& - & 4.098800e-04,4.603700e-04,4.874700e-04,4.572300e-04,4.307400e-04,& - & 2.089700e-06,1.141000e-04,2.048900e-04,2.854300e-04,3.595400e-04,& - & 4.259900e-04,4.807500e-04,5.210200e-04,4.894000e-04,4.609100e-04,& - & 2.532000e-06,1.227700e-04,2.183400e-04,3.032100e-04,3.787400e-04,& - & 4.471700e-04,5.048900e-04,5.518000e-04,5.233800e-04,4.908000e-04,& - & 3.272700e-06,1.349800e-04,2.369000e-04,3.272000e-04,4.067200e-04,& - & 4.763600e-04,5.349100e-04,5.756100e-04,5.505100e-04,5.197800e-04,& - & 4.385600e-06,1.514700e-04,2.611100e-04,3.576500e-04,4.426400e-04,& - & 5.150200e-04,5.738200e-04,6.130200e-04,6.143800e-04,5.497600e-04,& - & 1.548200e-06,8.705200e-05,1.583900e-04,2.230000e-04,2.810500e-04,& - & 3.309000e-04,3.693600e-04,3.899200e-04,3.656100e-04,5.030700e-04,& - & 1.623300e-06,9.080000e-05,1.638600e-04,2.291600e-04,2.893300e-04,& - & 3.427000e-04,3.860300e-04,4.113700e-04,3.867900e-04,5.303400e-04,& - & 1.872700e-06,9.660500e-05,1.729900e-04,2.406800e-04,3.021600e-04,& - & 3.576800e-04,4.038600e-04,4.430600e-04,4.252300e-04,5.582300e-04,& - & 2.346000e-06,1.051400e-04,1.859400e-04,2.579800e-04,3.215800e-04,& - & 3.783000e-04,4.260400e-04,4.606100e-04,4.383000e-04,5.890400e-04,& - & 3.083500e-06,1.169100e-04,2.033600e-04,2.801500e-04,3.481400e-04,& - & 4.063800e-04,4.542100e-04,4.865800e-04,4.761500e-04,6.243500e-04,& - & 1.279900e-06,7.064600e-05,1.289800e-04,1.818000e-04,2.287000e-04,& - & 2.672800e-04,2.967800e-04,3.156500e-04,2.987700e-04,5.651900e-04,& - & 1.298700e-06,7.290600e-05,1.321500e-04,1.853500e-04,2.342100e-04,& - & 2.769500e-04,3.113000e-04,3.288600e-04,3.102100e-04,5.870600e-04,& - & 1.435300e-06,7.691500e-05,1.383500e-04,1.929000e-04,2.429500e-04,& - & 2.880300e-04,3.251400e-04,3.535400e-04,3.357800e-04,6.141200e-04,& - & 1.738700e-06,8.289400e-05,1.475900e-04,2.052800e-04,2.566300e-04,& - & 3.029300e-04,3.417500e-04,3.721600e-04,3.575100e-04,6.498500e-04,& - & 2.234300e-06,9.146900e-05,1.602200e-04,2.216800e-04,2.763000e-04,& - & 3.234600e-04,3.626800e-04,3.893800e-04,3.749200e-04,6.958300e-04,& - & 1.054300e-06,5.798300e-05,1.058200e-04,1.491900e-04,1.879100e-04,& - & 2.200000e-04,2.443300e-04,2.599500e-04,2.459200e-04,5.030700e-04,& - & 1.072600e-06,5.990700e-05,1.085800e-04,1.522300e-04,1.924400e-04,& - & 2.277500e-04,2.561000e-04,2.704600e-04,2.561500e-04,5.158800e-04,& - & 1.189400e-06,6.321200e-05,1.138300e-04,1.587000e-04,1.997900e-04,& - & 2.369300e-04,2.674700e-04,2.915400e-04,2.791900e-04,5.385500e-04,& - & 1.439000e-06,6.825800e-05,1.214500e-04,1.690600e-04,2.113800e-04,& - & 2.494800e-04,2.813600e-04,3.058100e-04,2.955300e-04,5.729600e-04,& - & 1.847000e-06,7.548900e-05,1.320200e-04,1.825700e-04,2.278200e-04,& - & 2.668100e-04,2.989200e-04,3.205800e-04,3.105200e-04,6.181800e-04,& - & 8.679800e-07,4.755300e-05,8.673000e-05,1.222600e-04,1.541300e-04,& - & 1.808500e-04,2.008800e-04,2.136800e-04,2.025200e-04,4.192500e-04,& - & 8.849500e-07,4.918300e-05,8.911800e-05,1.249000e-04,1.579000e-04,& - & 1.869900e-04,2.104900e-04,2.223100e-04,2.117000e-04,4.291100e-04,& - & 9.832499e-07,5.192500e-05,9.354700e-05,1.304400e-04,1.641300e-04,& - & 1.947100e-04,2.198600e-04,2.400100e-04,2.320900e-04,4.487100e-04,& - & 1.188900e-06,5.618300e-05,9.986300e-05,1.390500e-04,1.739100e-04,& - & 2.052200e-04,2.314200e-04,2.513500e-04,2.426700e-04,4.781800e-04,& - & 1.523500e-06,6.228100e-05,1.087400e-04,1.502300e-04,1.875500e-04,& - & 2.198000e-04,2.461700e-04,2.637900e-04,2.578400e-04,5.170800e-04,& - & 7.141800e-07,3.892100e-05,7.089100e-05,9.988900e-05,1.259700e-04,& - & 1.479900e-04,1.645300e-04,1.751300e-04,1.666700e-04,3.430900e-04,& - & 7.289500e-07,4.028400e-05,7.294500e-05,1.022100e-04,1.292300e-04,& - & 1.530900e-04,1.725800e-04,1.822900e-04,1.738600e-04,3.510900e-04,& - & 8.107900e-07,4.257600e-05,7.665900e-05,1.069200e-04,1.344900e-04,& - & 1.596100e-04,1.802600e-04,1.970400e-04,1.924000e-04,3.670000e-04,& - & 9.800100e-07,4.614900e-05,8.193200e-05,1.140600e-04,1.427100e-04,& - & 1.684100e-04,1.899200e-04,2.061700e-04,1.992800e-04,3.909200e-04,& - & 1.252800e-06,5.128000e-05,8.935900e-05,1.233800e-04,1.540100e-04,& - & 1.805600e-04,2.022500e-04,2.167200e-04,2.136000e-04,4.225200e-04/ - data absa(1:300,2) / & - & 6.120700e-05,1.097800e-03,1.761100e-03,2.363800e-03,2.905700e-03,& - & 3.365100e-03,3.713700e-03,3.838300e-03,3.229700e-03,2.426400e-03,& - & 8.505800e-05,1.329200e-03,2.075000e-03,2.733800e-03,3.340300e-03,& - & 3.862900e-03,4.257900e-03,4.333700e-03,3.410100e-03,2.673600e-03,& - & 1.168200e-04,1.616200e-03,2.468900e-03,3.194600e-03,3.871900e-03,& - & 4.455200e-03,4.907600e-03,4.933500e-03,3.902200e-03,2.924700e-03,& - & 1.578900e-04,1.966800e-03,2.948000e-03,3.766900e-03,4.517100e-03,& - & 5.168200e-03,5.665300e-03,5.649900e-03,4.065200e-03,3.151500e-03,& - & 2.099000e-04,2.388700e-03,3.529900e-03,4.456500e-03,5.284400e-03,& - & 6.007600e-03,6.555100e-03,6.476400e-03,4.438500e-03,3.453800e-03,& - & 4.654100e-05,8.867400e-04,1.409900e-03,1.886400e-03,2.318000e-03,& - & 2.679800e-03,2.961300e-03,3.061500e-03,2.659700e-03,1.887200e-03,& - & 6.533900e-05,1.074700e-03,1.667000e-03,2.185500e-03,2.662200e-03,& - & 3.071000e-03,3.386200e-03,3.458400e-03,2.785200e-03,2.078200e-03,& - & 9.058900e-05,1.308200e-03,1.994700e-03,2.563400e-03,3.086000e-03,& - & 3.537900e-03,3.897500e-03,3.936600e-03,3.166800e-03,2.259000e-03,& - & 1.238500e-04,1.596800e-03,2.394100e-03,3.035000e-03,3.606700e-03,& - & 4.105700e-03,4.494200e-03,4.510700e-03,3.278200e-03,2.450400e-03,& - & 1.666700e-04,1.948000e-03,2.878600e-03,3.606400e-03,4.237000e-03,& - & 4.780500e-03,5.202400e-03,5.167700e-03,3.542500e-03,2.697500e-03,& - & 3.292200e-05,6.865400e-04,1.097000e-03,1.465400e-03,1.805100e-03,& - & 2.084700e-03,2.308800e-03,2.383700e-03,2.126500e-03,1.454000e-03,& - & 4.658300e-05,8.301500e-04,1.294800e-03,1.695800e-03,2.066300e-03,& - & 2.379200e-03,2.622900e-03,2.695100e-03,2.251800e-03,1.596900e-03,& - & 6.541000e-05,1.011400e-03,1.551800e-03,1.991900e-03,2.394400e-03,& - & 2.736600e-03,3.009800e-03,3.059500e-03,2.453000e-03,1.729900e-03,& - & 9.073400e-05,1.236600e-03,1.868800e-03,2.365200e-03,2.800500e-03,& - & 3.172500e-03,3.470600e-03,3.500000e-03,2.664100e-03,1.891200e-03,& - & 1.240700e-04,1.512600e-03,2.251000e-03,2.821100e-03,3.298900e-03,& - & 3.700100e-03,4.016100e-03,4.007500e-03,2.779800e-03,2.079600e-03,& - & 2.277800e-05,5.251000e-04,8.488800e-04,1.135200e-03,1.397900e-03,& - & 1.616800e-03,1.796400e-03,1.833100e-03,1.783700e-03,1.172300e-03,& - & 3.236300e-05,6.308600e-04,9.970900e-04,1.307300e-03,1.594300e-03,& - & 1.836600e-03,2.024400e-03,2.087500e-03,1.812400e-03,1.273200e-03,& - & 4.596200e-05,7.678800e-04,1.191200e-03,1.534700e-03,1.843300e-03,& - & 2.107700e-03,2.313500e-03,2.358600e-03,1.896600e-03,1.380600e-03,& - & 6.473900e-05,9.399200e-04,1.435200e-03,1.824800e-03,2.158000e-03,& - & 2.440300e-03,2.663900e-03,2.689300e-03,2.141300e-03,1.499900e-03,& - & 9.000900e-05,1.153500e-03,1.733000e-03,2.181100e-03,2.548700e-03,& - & 2.846400e-03,3.081300e-03,3.081100e-03,2.201300e-03,1.637000e-03,& - & 1.579200e-05,4.014800e-04,6.583100e-04,8.843400e-04,1.086900e-03,& - & 1.256800e-03,1.403000e-03,1.415700e-03,1.379000e-03,9.947100e-04,& - & 2.239700e-05,4.788700e-04,7.670500e-04,1.011300e-03,1.232900e-03,& - & 1.420200e-03,1.568700e-03,1.618400e-03,1.458200e-03,1.069800e-03,& - & 3.209600e-05,5.807800e-04,9.118300e-04,1.182300e-03,1.422100e-03,& - & 1.626000e-03,1.782300e-03,1.820800e-03,1.549300e-03,1.148600e-03,& - & 4.584000e-05,7.116000e-04,1.096900e-03,1.403400e-03,1.662800e-03,& - & 1.880400e-03,2.047000e-03,2.068600e-03,1.654000e-03,1.236500e-03,& - & 6.482200e-05,8.749600e-04,1.326900e-03,1.679300e-03,1.965800e-03,& - & 2.194600e-03,2.367100e-03,2.367700e-03,1.781200e-03,1.337600e-03,& - & 1.090200e-05,3.060500e-04,5.102800e-04,6.885300e-04,8.448800e-04,& - & 9.784000e-04,1.097400e-03,1.110100e-03,1.064500e-03,8.664800e-04,& - & 1.530100e-05,3.613000e-04,5.871900e-04,7.807900e-04,9.525200e-04,& - & 1.095900e-03,1.215200e-03,1.239700e-03,1.204600e-03,9.188500e-04,& - & 2.201600e-05,4.354800e-04,6.926700e-04,9.051100e-04,1.092400e-03,& - & 1.249800e-03,1.372000e-03,1.405300e-03,1.231900e-03,9.739600e-04,& - & 3.183000e-05,5.331700e-04,8.306300e-04,1.069800e-03,1.273400e-03,& - & 1.441800e-03,1.568700e-03,1.588100e-03,1.277500e-03,1.039900e-03,& - & 4.573800e-05,6.569600e-04,1.003900e-03,1.279000e-03,1.502100e-03,& - & 1.681200e-03,1.811900e-03,1.811700e-03,1.427400e-03,1.115600e-03/ - data absa(301:650,2) / & - & 7.636900e-06,2.340900e-04,3.966200e-04,5.373600e-04,6.595400e-04,& - & 7.662800e-04,8.632400e-04,8.811900e-04,8.619400e-04,7.907900e-04,& - & 1.049400e-05,2.729300e-04,4.503300e-04,6.041900e-04,7.377100e-04,& - & 8.484600e-04,9.451200e-04,9.549700e-04,9.299900e-04,8.238700e-04,& - & 1.505900e-05,3.261200e-04,5.257000e-04,6.928500e-04,8.405600e-04,& - & 9.621400e-04,1.057900e-03,1.086800e-03,9.860001e-04,8.642100e-04,& - & 2.197300e-05,3.976600e-04,6.271600e-04,8.130700e-04,9.731400e-04,& - & 1.106200e-03,1.205200e-03,1.222400e-03,1.047300e-03,9.138600e-04,& - & 3.202400e-05,4.902300e-04,7.569300e-04,9.694200e-04,1.144100e-03,& - & 1.286100e-03,1.387300e-03,1.390400e-03,1.099500e-03,9.740900e-04,& - & 5.481900e-06,1.802200e-04,3.095100e-04,4.210900e-04,5.176500e-04,& - & 6.043400e-04,6.796600e-04,7.041400e-04,7.072900e-04,7.654300e-04,& - & 7.294600e-06,2.068900e-04,3.467300e-04,4.684100e-04,5.726300e-04,& - & 6.604600e-04,7.394900e-04,7.488700e-04,7.213700e-04,7.851200e-04,& - & 1.035100e-05,2.445700e-04,3.998800e-04,5.318800e-04,6.479100e-04,& - & 7.424700e-04,8.194100e-04,8.349500e-04,8.154500e-04,8.210700e-04,& - & 1.515600e-05,2.962900e-04,4.736500e-04,6.187300e-04,7.445400e-04,& - & 8.495800e-04,9.285400e-04,9.439300e-04,8.394000e-04,8.728100e-04,& - & 2.236100e-05,3.648200e-04,5.698300e-04,7.340700e-04,8.704500e-04,& - & 9.836600e-04,1.065100e-03,1.069800e-03,8.669800e-04,9.361300e-04,& - & 4.045200e-06,1.401700e-04,2.432900e-04,3.321800e-04,4.092500e-04,& - & 4.810300e-04,5.391800e-04,5.610000e-04,5.650100e-04,8.097000e-04,& - & 5.156700e-06,1.579500e-04,2.686300e-04,3.650000e-04,4.468800e-04,& - & 5.175600e-04,5.830600e-04,5.942300e-04,5.889400e-04,8.664600e-04,& - & 7.165700e-06,1.842700e-04,3.056300e-04,4.102600e-04,5.007600e-04,& - & 5.751000e-04,6.379600e-04,6.441600e-04,6.281400e-04,9.458900e-04,& - & 1.045400e-05,2.211700e-04,3.585500e-04,4.722200e-04,5.713700e-04,& - & 6.535000e-04,7.167600e-04,7.318200e-04,6.718000e-04,1.044500e-03,& - & 1.555400e-05,2.712900e-04,4.290200e-04,5.562200e-04,6.629600e-04,& - & 7.522000e-04,8.192600e-04,8.253400e-04,7.131700e-04,1.156700e-03,& - & 3.105700e-06,1.108300e-04,1.937900e-04,2.651100e-04,3.279300e-04,& - & 3.862200e-04,4.307100e-04,4.444100e-04,4.595200e-04,8.817400e-04,& - & 3.799100e-06,1.228300e-04,2.111300e-04,2.882100e-04,3.534800e-04,& - & 4.111200e-04,4.617400e-04,4.771700e-04,4.865700e-04,9.868500e-04,& - & 5.149900e-06,1.414300e-04,2.373400e-04,3.210000e-04,3.923600e-04,& - & 4.514500e-04,5.031500e-04,5.079200e-04,4.940600e-04,1.124200e-03,& - & 7.452800e-06,1.682700e-04,2.757400e-04,3.661300e-04,4.444200e-04,& - & 5.091200e-04,5.602600e-04,5.714000e-04,5.568100e-04,1.293500e-03,& - & 1.113400e-05,2.053200e-04,3.283200e-04,4.282500e-04,5.127500e-04,& - & 5.833100e-04,6.370900e-04,6.444700e-04,5.755400e-04,1.489200e-03,& - & 2.579300e-06,9.138600e-05,1.599100e-04,2.191400e-04,2.707600e-04,& - & 3.182100e-04,3.550000e-04,3.687100e-04,3.789900e-04,8.333900e-04,& - & 3.193200e-06,1.015200e-04,1.743900e-04,2.384000e-04,2.925300e-04,& - & 3.397500e-04,3.812200e-04,3.938400e-04,4.056700e-04,9.507400e-04,& - & 4.370900e-06,1.172800e-04,1.965600e-04,2.659500e-04,3.249500e-04,& - & 3.736600e-04,4.157000e-04,4.196500e-04,4.112200e-04,1.099200e-03,& - & 6.395400e-06,1.400000e-04,2.292200e-04,3.041900e-04,3.687900e-04,& - & 4.216800e-04,4.634500e-04,4.731900e-04,4.595400e-04,1.280400e-03,& - & 9.617400e-06,1.712000e-04,2.735700e-04,3.571100e-04,4.265400e-04,& - & 4.841500e-04,5.277500e-04,5.332100e-04,4.753700e-04,1.494600e-03,& - & 2.144900e-06,7.518500e-05,1.315900e-04,1.806800e-04,2.233500e-04,& - & 2.619800e-04,2.923500e-04,3.035000e-04,3.125600e-04,7.298600e-04,& - & 2.684900e-06,8.373900e-05,1.437000e-04,1.966600e-04,2.415300e-04,& - & 2.804600e-04,3.144500e-04,3.244000e-04,3.381400e-04,8.389600e-04,& - & 3.712000e-06,9.707200e-05,1.624200e-04,2.197400e-04,2.686600e-04,& - & 3.088000e-04,3.429600e-04,3.465500e-04,3.418300e-04,9.791401e-04,& - & 5.475000e-06,1.162100e-04,1.901200e-04,2.521000e-04,3.054700e-04,& - & 3.490100e-04,3.829900e-04,3.909800e-04,3.804500e-04,1.149900e-03,& - & 8.270300e-06,1.424100e-04,2.273100e-04,2.970100e-04,3.544200e-04,& - & 4.014700e-04,4.367900e-04,4.403900e-04,3.915400e-04,1.349600e-03,& - & 1.783000e-06,6.154500e-05,1.077600e-04,1.481600e-04,1.834600e-04,& - & 2.151800e-04,2.400300e-04,2.492000e-04,2.585500e-04,6.048300e-04,& - & 2.252300e-06,6.870800e-05,1.178700e-04,1.613900e-04,1.984600e-04,& - & 2.306500e-04,2.583100e-04,2.666300e-04,2.811500e-04,6.953300e-04,& - & 3.139400e-06,7.989400e-05,1.335700e-04,1.807100e-04,2.210600e-04,& - & 2.542300e-04,2.821100e-04,2.854100e-04,2.843700e-04,8.118100e-04,& - & 4.643100e-06,9.587200e-05,1.567700e-04,2.079100e-04,2.519000e-04,& - & 2.878500e-04,3.156700e-04,3.221400e-04,3.107700e-04,9.537400e-04,& - & 7.029300e-06,1.178200e-04,1.878200e-04,2.455600e-04,2.931000e-04,& - & 3.317200e-04,3.606900e-04,3.627600e-04,3.232100e-04,1.119000e-03/ - data absa(1:300,3) / & - & 3.139500e-04,2.335800e-03,3.669500e-03,4.758300e-03,5.630000e-03,& - & 6.308400e-03,6.445900e-03,5.647600e-03,4.311400e-03,3.535900e-03,& - & 4.404100e-04,2.855000e-03,4.428800e-03,5.733700e-03,6.770300e-03,& - & 7.487400e-03,7.585200e-03,6.604800e-03,4.460900e-03,3.730700e-03,& - & 6.088900e-04,3.499000e-03,5.331800e-03,6.878300e-03,8.089900e-03,& - & 8.856200e-03,8.865900e-03,7.699800e-03,5.083400e-03,4.160600e-03,& - & 8.294500e-04,4.296700e-03,6.410600e-03,8.201300e-03,9.603800e-03,& - & 1.038200e-02,1.029800e-02,8.941900e-03,6.150600e-03,4.803000e-03,& - & 1.111100e-03,5.264000e-03,7.678500e-03,9.724300e-03,1.131300e-02,& - & 1.207300e-02,1.191800e-02,1.034000e-02,7.223100e-03,5.555900e-03,& - & 2.578600e-04,1.868900e-03,2.917100e-03,3.765500e-03,4.455700e-03,& - & 4.985100e-03,5.087700e-03,4.498700e-03,3.562400e-03,2.782300e-03,& - & 3.651800e-04,2.298200e-03,3.522900e-03,4.534800e-03,5.362700e-03,& - & 5.941300e-03,6.013100e-03,5.279600e-03,3.652800e-03,2.986200e-03,& - & 5.096300e-04,2.832600e-03,4.249000e-03,5.447800e-03,6.429100e-03,& - & 7.052200e-03,7.063700e-03,6.179400e-03,4.083200e-03,3.332600e-03,& - & 7.004100e-04,3.494600e-03,5.131500e-03,6.518100e-03,7.657400e-03,& - & 8.303900e-03,8.250100e-03,7.201300e-03,4.957900e-03,3.818200e-03,& - & 9.450900e-04,4.304200e-03,6.178000e-03,7.764500e-03,9.055200e-03,& - & 9.697000e-03,9.593700e-03,8.364400e-03,5.847500e-03,4.374400e-03,& - & 1.937900e-04,1.431600e-03,2.232400e-03,2.873500e-03,3.397000e-03,& - & 3.804100e-03,3.880200e-03,3.466900e-03,2.911900e-03,2.174400e-03,& - & 2.777000e-04,1.767400e-03,2.700100e-03,3.457700e-03,4.088200e-03,& - & 4.545100e-03,4.613000e-03,4.069200e-03,2.937900e-03,2.358800e-03,& - & 3.925100e-04,2.193800e-03,3.264500e-03,4.160400e-03,4.909900e-03,& - & 5.412500e-03,5.449200e-03,4.784600e-03,3.200300e-03,2.634600e-03,& - & 5.460500e-04,2.727800e-03,3.960900e-03,4.997700e-03,5.874000e-03,& - & 6.406700e-03,6.400300e-03,5.605400e-03,3.773200e-03,2.986000e-03,& - & 7.446600e-04,3.384800e-03,4.804500e-03,5.982300e-03,6.978700e-03,& - & 7.520900e-03,7.470800e-03,6.543300e-03,4.562000e-03,3.396600e-03,& - & 1.401500e-04,1.081300e-03,1.685400e-03,2.172900e-03,2.570900e-03,& - & 2.877200e-03,2.931700e-03,2.645100e-03,2.265700e-03,1.738300e-03,& - & 2.031100e-04,1.340700e-03,2.041700e-03,2.616200e-03,3.090000e-03,& - & 3.437100e-03,3.497000e-03,3.103000e-03,2.433100e-03,1.880700e-03,& - & 2.908600e-04,1.674000e-03,2.481000e-03,3.147800e-03,3.709100e-03,& - & 4.101200e-03,4.150300e-03,3.666900e-03,2.519300e-03,2.085300e-03,& - & 4.101900e-04,2.097500e-03,3.027600e-03,3.793200e-03,4.450300e-03,& - & 4.873600e-03,4.894800e-03,4.312900e-03,2.842200e-03,2.348100e-03,& - & 5.665800e-04,2.621300e-03,3.697200e-03,4.566300e-03,5.312400e-03,& - & 5.756400e-03,5.744900e-03,5.060200e-03,3.483100e-03,2.660700e-03,& - & 1.000500e-04,8.175100e-04,1.272800e-03,1.640900e-03,1.949200e-03,& - & 2.182800e-03,2.221000e-03,2.023600e-03,1.772800e-03,1.447700e-03,& - & 1.462800e-04,1.015400e-03,1.543900e-03,1.977800e-03,2.340400e-03,& - & 2.606500e-03,2.649900e-03,2.364800e-03,1.985300e-03,1.559800e-03,& - & 2.121300e-04,1.273700e-03,1.883000e-03,2.387800e-03,2.808900e-03,& - & 3.111600e-03,3.158400e-03,2.805500e-03,1.997900e-03,1.716500e-03,& - & 3.031600e-04,1.603700e-03,2.310200e-03,2.889000e-03,3.373200e-03,& - & 3.705200e-03,3.738600e-03,3.312800e-03,2.188900e-03,1.913500e-03,& - & 4.243700e-04,2.017000e-03,2.841500e-03,3.497000e-03,4.044800e-03,& - & 4.394600e-03,4.405400e-03,3.895600e-03,2.608900e-03,2.145600e-03,& - & 6.984800e-05,6.134400e-04,9.542700e-04,1.233300e-03,1.469600e-03,& - & 1.645900e-03,1.677800e-03,1.549100e-03,1.434000e-03,1.215500e-03,& - & 1.028700e-04,7.623100e-04,1.159600e-03,1.487500e-03,1.760200e-03,& - & 1.964400e-03,1.998700e-03,1.801500e-03,1.547500e-03,1.310600e-03,& - & 1.506400e-04,9.589700e-04,1.418400e-03,1.799700e-03,2.117400e-03,& - & 2.348100e-03,2.385500e-03,2.123900e-03,1.666400e-03,1.439700e-03,& - & 2.181200e-04,1.210200e-03,1.748500e-03,2.187500e-03,2.548600e-03,& - & 2.802800e-03,2.835600e-03,2.520600e-03,1.719500e-03,1.593400e-03,& - & 3.096900e-04,1.527300e-03,2.163400e-03,2.662000e-03,3.069500e-03,& - & 3.338000e-03,3.351500e-03,2.974600e-03,1.951500e-03,1.777800e-03/ - data absa(301:650,3) / & - & 4.822100e-05,4.601000e-04,7.148100e-04,9.285900e-04,1.110000e-03,& - & 1.240800e-03,1.268300e-03,1.194100e-03,1.165400e-03,1.061800e-03,& - & 7.131600e-05,5.699300e-04,8.699400e-04,1.116500e-03,1.322000e-03,& - & 1.478100e-03,1.505000e-03,1.375700e-03,1.214000e-03,1.142700e-03,& - & 1.054000e-04,7.174000e-04,1.067100e-03,1.354600e-03,1.592100e-03,& - & 1.767500e-03,1.799300e-03,1.608500e-03,1.340900e-03,1.246000e-03,& - & 1.542100e-04,9.067500e-04,1.319400e-03,1.653100e-03,1.923900e-03,& - & 2.116300e-03,2.144600e-03,1.911800e-03,1.354900e-03,1.370200e-03,& - & 2.220700e-04,1.148500e-03,1.637900e-03,2.023600e-03,2.329200e-03,& - & 2.531900e-03,2.545200e-03,2.261800e-03,1.488400e-03,1.520200e-03,& - & 3.302400e-05,3.453000e-04,5.368800e-04,7.011500e-04,8.422900e-04,& - & 9.388900e-04,9.672500e-04,9.169400e-04,9.167000e-04,1.013500e-03,& - & 4.886700e-05,4.256000e-04,6.514500e-04,8.377800e-04,9.954399e-04,& - & 1.113400e-03,1.134500e-03,1.053800e-03,9.711300e-04,1.085700e-03,& - & 7.282500e-05,5.347100e-04,8.002200e-04,1.018100e-03,1.196700e-03,& - & 1.330200e-03,1.354700e-03,1.226600e-03,1.044600e-03,1.177400e-03,& - & 1.077400e-04,6.765200e-04,9.908100e-04,1.245800e-03,1.450800e-03,& - & 1.597600e-03,1.619900e-03,1.451000e-03,1.138900e-03,1.291300e-03,& - & 1.571200e-04,8.589300e-04,1.233000e-03,1.531800e-03,1.764800e-03,& - & 1.918800e-03,1.929800e-03,1.719700e-03,1.158500e-03,1.430100e-03,& - & 2.269400e-05,2.596400e-04,4.058700e-04,5.324400e-04,6.430700e-04,& - & 7.148600e-04,7.424000e-04,7.116400e-04,7.227300e-04,1.249300e-03,& - & 3.340300e-05,3.185100e-04,4.882600e-04,6.298200e-04,7.528200e-04,& - & 8.406700e-04,8.577700e-04,8.105500e-04,7.804800e-04,1.381200e-03,& - & 5.002800e-05,3.982600e-04,5.993100e-04,7.642400e-04,9.003100e-04,& - & 1.001800e-03,1.020100e-03,9.377100e-04,8.289700e-04,1.524800e-03,& - & 7.476700e-05,5.039200e-04,7.414100e-04,9.367600e-04,1.093000e-03,& - & 1.205000e-03,1.222800e-03,1.098300e-03,9.013400e-04,1.687100e-03,& - & 1.103500e-04,6.409700e-04,9.243400e-04,1.153200e-03,1.333400e-03,& - & 1.452600e-03,1.461400e-03,1.305400e-03,9.181000e-04,1.872700e-03,& - & 1.613100e-05,1.988900e-04,3.127500e-04,4.122800e-04,4.983900e-04,& - & 5.562300e-04,5.825300e-04,5.634300e-04,5.605000e-04,1.588900e-03,& - & 2.354800e-05,2.427900e-04,3.728900e-04,4.822200e-04,5.791200e-04,& - & 6.448600e-04,6.626500e-04,6.339100e-04,6.228700e-04,1.897000e-03,& - & 3.534500e-05,3.021300e-04,4.566200e-04,5.830200e-04,6.887200e-04,& - & 7.665200e-04,7.803700e-04,7.253100e-04,6.602000e-04,2.261100e-03,& - & 5.320700e-05,3.818100e-04,5.640300e-04,7.142800e-04,8.359600e-04,& - & 9.216500e-04,9.356200e-04,8.450200e-04,7.124900e-04,2.667600e-03,& - & 7.934900e-05,4.866800e-04,7.036500e-04,8.795400e-04,1.020400e-03,& - & 1.114500e-03,1.123200e-03,1.004500e-03,7.747600e-04,3.111000e-03,& - & 1.360100e-05,1.664400e-04,2.605900e-04,3.419000e-04,4.132300e-04,& - & 4.609800e-04,4.823600e-04,4.660200e-04,4.640800e-04,1.706000e-03,& - & 2.001500e-05,2.039000e-04,3.127400e-04,4.024800e-04,4.815700e-04,& - & 5.355300e-04,5.500000e-04,5.259200e-04,5.132700e-04,2.093000e-03,& - & 3.022900e-05,2.549300e-04,3.832500e-04,4.883800e-04,5.759000e-04,& - & 6.386800e-04,6.495200e-04,6.032900e-04,5.435400e-04,2.534100e-03,& - & 4.572800e-05,3.235700e-04,4.751300e-04,5.990000e-04,7.003200e-04,& - & 7.705200e-04,7.816000e-04,7.036400e-04,5.886700e-04,3.011000e-03,& - & 6.847100e-05,4.145300e-04,5.951800e-04,7.394300e-04,8.558600e-04,& - & 9.324300e-04,9.398500e-04,8.388800e-04,6.400400e-04,3.514400e-03,& - & 1.139000e-05,1.385500e-04,2.170500e-04,2.835600e-04,3.419800e-04,& - & 3.812500e-04,3.989700e-04,3.870100e-04,3.842800e-04,1.620200e-03,& - & 1.689500e-05,1.703300e-04,2.613200e-04,3.357400e-04,4.003300e-04,& - & 4.444000e-04,4.554700e-04,4.345300e-04,4.179500e-04,2.005600e-03,& - & 2.569700e-05,2.139900e-04,3.207900e-04,4.079400e-04,4.808000e-04,& - & 5.317200e-04,5.401500e-04,5.013100e-04,4.506200e-04,2.435600e-03,& - & 3.909800e-05,2.730100e-04,3.992300e-04,5.013700e-04,5.848700e-04,& - & 6.418500e-04,6.519000e-04,5.859800e-04,4.910000e-04,2.899200e-03,& - & 5.888000e-05,3.513500e-04,5.023300e-04,6.205400e-04,7.159600e-04,& - & 7.774200e-04,7.840600e-04,7.008900e-04,5.297500e-04,3.385300e-03,& - & 9.358900e-06,1.140400e-04,1.792900e-04,2.342400e-04,2.817700e-04,& - & 3.138200e-04,3.288700e-04,3.193900e-04,3.178200e-04,1.371200e-03,& - & 1.399700e-05,1.407000e-04,2.163800e-04,2.782200e-04,3.313100e-04,& - & 3.674000e-04,3.761800e-04,3.587500e-04,3.425700e-04,1.694800e-03,& - & 2.146700e-05,1.776000e-04,2.665700e-04,3.386000e-04,3.986300e-04,& - & 4.402000e-04,4.477400e-04,4.150300e-04,3.738700e-04,2.055500e-03,& - & 3.293900e-05,2.279100e-04,3.332000e-04,4.172800e-04,4.857600e-04,& - & 5.316900e-04,5.407200e-04,4.871800e-04,4.135800e-04,2.441800e-03,& - & 5.003800e-05,2.944300e-04,4.208000e-04,5.180700e-04,5.961900e-04,& - & 6.453200e-04,6.503500e-04,5.836000e-04,4.322800e-04,2.842600e-03/ - data absa(1:300,4) / & - & 1.395900e-03,5.992200e-03,8.231600e-03,9.805900e-03,1.061300e-02,& - & 1.062000e-02,1.000700e-02,8.725400e-03,5.946500e-03,5.343800e-03,& - & 1.849700e-03,7.546000e-03,1.020300e-02,1.195500e-02,1.278600e-02,& - & 1.271200e-02,1.185600e-02,1.029100e-02,7.144700e-03,6.171300e-03,& - & 2.445500e-03,9.397700e-03,1.254800e-02,1.443400e-02,1.525200e-02,& - & 1.509500e-02,1.398900e-02,1.206600e-02,8.351000e-03,7.116700e-03,& - & 3.209300e-03,1.152300e-02,1.523200e-02,1.723500e-02,1.805100e-02,& - & 1.781800e-02,1.640700e-02,1.400800e-02,9.705900e-03,8.263700e-03,& - & 4.164000e-03,1.394700e-02,1.813800e-02,2.035300e-02,2.113300e-02,& - & 2.084700e-02,1.906400e-02,1.618200e-02,1.121800e-02,9.521900e-03,& - & 1.178400e-03,4.825900e-03,6.582400e-03,7.807600e-03,8.399700e-03,& - & 8.401300e-03,7.958900e-03,6.903500e-03,4.797200e-03,4.153600e-03,& - & 1.566000e-03,6.086700e-03,8.214600e-03,9.589200e-03,1.019700e-02,& - & 1.011800e-02,9.481600e-03,8.171000e-03,5.731100e-03,4.785600e-03,& - & 2.077100e-03,7.615600e-03,1.015100e-02,1.165500e-02,1.224400e-02,& - & 1.210300e-02,1.124900e-02,9.621700e-03,6.705300e-03,5.526800e-03,& - & 2.737100e-03,9.398600e-03,1.236200e-02,1.399600e-02,1.457300e-02,& - & 1.439400e-02,1.327300e-02,1.124900e-02,7.808200e-03,6.414500e-03,& - & 3.570700e-03,1.144100e-02,1.478200e-02,1.656900e-02,1.718500e-02,& - & 1.695300e-02,1.551700e-02,1.307800e-02,9.055500e-03,7.409400e-03,& - & 9.361200e-04,3.718100e-03,5.039000e-03,5.950200e-03,6.367900e-03,& - & 6.378600e-03,6.069800e-03,5.272700e-03,3.712000e-03,3.220100e-03,& - & 1.249000e-03,4.695700e-03,6.317600e-03,7.374500e-03,7.796600e-03,& - & 7.736100e-03,7.275100e-03,6.274600e-03,4.449000e-03,3.684400e-03,& - & 1.667200e-03,5.901700e-03,7.848700e-03,9.022300e-03,9.457300e-03,& - & 9.328300e-03,8.699500e-03,7.430100e-03,5.189500e-03,4.240500e-03,& - & 2.213400e-03,7.337100e-03,9.628100e-03,1.091100e-02,1.134600e-02,& - & 1.118700e-02,1.034300e-02,8.752000e-03,6.106100e-03,4.888300e-03,& - & 2.908000e-03,9.007800e-03,1.159600e-02,1.299000e-02,1.347400e-02,& - & 1.330600e-02,1.220000e-02,1.025000e-02,7.074600e-03,5.639400e-03,& - & 7.289900e-04,2.835800e-03,3.816600e-03,4.464900e-03,4.760500e-03,& - & 4.777600e-03,4.564500e-03,3.990500e-03,2.817200e-03,2.525900e-03,& - & 9.756200e-04,3.585800e-03,4.800000e-03,5.564300e-03,5.872900e-03,& - & 5.834500e-03,5.510600e-03,4.766000e-03,3.336900e-03,2.874700e-03,& - & 1.311000e-03,4.525200e-03,5.986100e-03,6.865400e-03,7.191200e-03,& - & 7.089800e-03,6.625700e-03,5.678800e-03,3.946700e-03,3.301700e-03,& - & 1.753500e-03,5.659200e-03,7.389500e-03,8.360000e-03,8.702800e-03,& - & 8.572600e-03,7.954400e-03,6.741300e-03,4.702300e-03,3.792000e-03,& - & 2.323400e-03,7.000100e-03,8.979500e-03,1.003300e-02,1.040700e-02,& - & 1.026900e-02,9.469000e-03,7.945500e-03,5.445000e-03,4.372900e-03,& - & 5.665000e-04,2.154900e-03,2.896400e-03,3.361900e-03,3.566400e-03,& - & 3.584100e-03,3.432300e-03,3.020100e-03,2.257500e-03,2.054700e-03,& - & 7.592300e-04,2.744900e-03,3.649400e-03,4.201000e-03,4.418000e-03,& - & 4.395300e-03,4.167500e-03,3.621900e-03,2.547300e-03,2.304600e-03,& - & 1.025300e-03,3.483400e-03,4.568600e-03,5.206900e-03,5.448100e-03,& - & 5.375800e-03,5.040800e-03,4.335900e-03,3.016200e-03,2.619500e-03,& - & 1.380100e-03,4.380400e-03,5.672500e-03,6.384100e-03,6.648500e-03,& - & 6.545700e-03,6.091400e-03,5.182800e-03,3.563600e-03,2.997100e-03,& - & 1.843400e-03,5.439100e-03,6.943400e-03,7.730700e-03,8.014300e-03,& - & 7.890100e-03,7.307200e-03,6.154800e-03,4.178400e-03,3.450800e-03,& - & 4.347900e-04,1.610500e-03,2.162400e-03,2.504800e-03,2.662900e-03,& - & 2.683300e-03,2.573800e-03,2.273700e-03,1.860600e-03,1.723400e-03,& - & 5.823300e-04,2.065000e-03,2.744400e-03,3.146400e-03,3.311200e-03,& - & 3.296700e-03,3.129200e-03,2.733000e-03,1.914200e-03,1.918300e-03,& - & 7.884300e-04,2.645700e-03,3.464600e-03,3.922100e-03,4.095400e-03,& - & 4.044300e-03,3.806500e-03,3.287200e-03,2.247200e-03,2.160300e-03,& - & 1.067600e-03,3.359900e-03,4.329400e-03,4.840600e-03,5.030600e-03,& - & 4.952500e-03,4.623500e-03,3.953000e-03,2.677800e-03,2.463600e-03,& - & 1.436000e-03,4.202800e-03,5.335500e-03,5.907500e-03,6.114800e-03,& - & 6.007000e-03,5.577900e-03,4.730500e-03,3.193800e-03,2.820100e-03/ - data absa(301:650,4) / & - & 3.306600e-04,1.192100e-03,1.599700e-03,1.850800e-03,1.975000e-03,& - & 2.006500e-03,1.936200e-03,1.712100e-03,1.510200e-03,1.475500e-03,& - & 4.425100e-04,1.539900e-03,2.043100e-03,2.338600e-03,2.469300e-03,& - & 2.473100e-03,2.355900e-03,2.061900e-03,1.516700e-03,1.627800e-03,& - & 5.995400e-04,1.989500e-03,2.599600e-03,2.938900e-03,3.076900e-03,& - & 3.044900e-03,2.869600e-03,2.485400e-03,1.710000e-03,1.826100e-03,& - & 8.153900e-04,2.554800e-03,3.283100e-03,3.660400e-03,3.800400e-03,& - & 3.740600e-03,3.500400e-03,3.000900e-03,2.018500e-03,2.072300e-03,& - & 1.103500e-03,3.229900e-03,4.085100e-03,4.505400e-03,4.650600e-03,& - & 4.563600e-03,4.245800e-03,3.617000e-03,2.415000e-03,2.368900e-03,& - & 2.482400e-04,8.757600e-04,1.175000e-03,1.362000e-03,1.459100e-03,& - & 1.494400e-03,1.453000e-03,1.301600e-03,1.236200e-03,1.381500e-03,& - & 3.323000e-04,1.139000e-03,1.510300e-03,1.730600e-03,1.832300e-03,& - & 1.845400e-03,1.771500e-03,1.558800e-03,1.256700e-03,1.524100e-03,& - & 4.503600e-04,1.483300e-03,1.939700e-03,2.191100e-03,2.298400e-03,& - & 2.284300e-03,2.164400e-03,1.878600e-03,1.301000e-03,1.704700e-03,& - & 6.142500e-04,1.925800e-03,2.473600e-03,2.752600e-03,2.861800e-03,& - & 2.820800e-03,2.647400e-03,2.273800e-03,1.497700e-03,1.923100e-03,& - & 8.357900e-04,2.467700e-03,3.110000e-03,3.420900e-03,3.532100e-03,& - & 3.466400e-03,3.230200e-03,2.752900e-03,1.821100e-03,2.180200e-03,& - & 1.864800e-04,6.421300e-04,8.624800e-04,1.001800e-03,1.075900e-03,& - & 1.111400e-03,1.089300e-03,9.906400e-04,9.875300e-04,1.877500e-03,& - & 2.493100e-04,8.384300e-04,1.113500e-03,1.277700e-03,1.354900e-03,& - & 1.373500e-03,1.326700e-03,1.178400e-03,1.022500e-03,2.072500e-03,& - & 3.373900e-04,1.099700e-03,1.438800e-03,1.627500e-03,1.709500e-03,& - & 1.706400e-03,1.627600e-03,1.424400e-03,1.019600e-03,2.319600e-03,& - & 4.600000e-04,1.441400e-03,1.853100e-03,2.063400e-03,2.145300e-03,& - & 2.116200e-03,1.997000e-03,1.724800e-03,1.167700e-03,2.607800e-03,& - & 6.281900e-04,1.870200e-03,2.357400e-03,2.590300e-03,2.670400e-03,& - & 2.621400e-03,2.447700e-03,2.091400e-03,1.360800e-03,2.929400e-03,& - & 1.430700e-04,4.798900e-04,6.452700e-04,7.515400e-04,8.096000e-04,& - & 8.409000e-04,8.308600e-04,7.687400e-04,8.286300e-04,3.634700e-03,& - & 1.910500e-04,6.285800e-04,8.350000e-04,9.599100e-04,1.018500e-03,& - & 1.039300e-03,1.009500e-03,9.011800e-04,8.311400e-04,4.229400e-03,& - & 2.581900e-04,8.297500e-04,1.084800e-03,1.229000e-03,1.290800e-03,& - & 1.294300e-03,1.240700e-03,1.094700e-03,8.450700e-04,4.794200e-03,& - & 3.517500e-04,1.096600e-03,1.409000e-03,1.569500e-03,1.630100e-03,& - & 1.612500e-03,1.527100e-03,1.324400e-03,8.957400e-04,5.332600e-03,& - & 4.814000e-04,1.435500e-03,1.809600e-03,1.989400e-03,2.047500e-03,& - & 2.008000e-03,1.876800e-03,1.611800e-03,1.032300e-03,5.871200e-03,& - & 1.248000e-04,4.065100e-04,5.431700e-04,6.305700e-04,6.771100e-04,& - & 7.012400e-04,6.923000e-04,6.363700e-04,6.748000e-04,4.474800e-03,& - & 1.678900e-04,5.365700e-04,7.067500e-04,8.079800e-04,8.557500e-04,& - & 8.711600e-04,8.442200e-04,7.530600e-04,6.821900e-04,5.248400e-03,& - & 2.274800e-04,7.132400e-04,9.243000e-04,1.039100e-03,1.088000e-03,& - & 1.088500e-03,1.041400e-03,9.176100e-04,6.931000e-04,5.999700e-03,& - & 3.110000e-04,9.466200e-04,1.206200e-03,1.334500e-03,1.380600e-03,& - & 1.361600e-03,1.284200e-03,1.113200e-03,7.518300e-04,6.727500e-03,& - & 4.263200e-04,1.237500e-03,1.550700e-03,1.699600e-03,1.742800e-03,& - & 1.704600e-03,1.583500e-03,1.358000e-03,8.685200e-04,7.457200e-03,& - & 1.073800e-04,3.437000e-04,4.556100e-04,5.271200e-04,5.651200e-04,& - & 5.841800e-04,5.760800e-04,5.282400e-04,5.558400e-04,4.522900e-03,& - & 1.450900e-04,4.571900e-04,5.962800e-04,6.780900e-04,7.169700e-04,& - & 7.284800e-04,7.056500e-04,6.299700e-04,5.643600e-04,5.315600e-03,& - & 1.978300e-04,6.116700e-04,7.848100e-04,8.776400e-04,9.147600e-04,& - & 9.129800e-04,8.725200e-04,7.665200e-04,5.701100e-04,6.075700e-03,& - & 2.719200e-04,8.117300e-04,1.026500e-03,1.133300e-03,1.168000e-03,& - & 1.149000e-03,1.078400e-03,9.336100e-04,6.271800e-04,6.811300e-03,& - & 3.739700e-04,1.059800e-03,1.319700e-03,1.444900e-03,1.479900e-03,& - & 1.446500e-03,1.336200e-03,1.140700e-03,7.241500e-04,7.542500e-03,& - & 8.929200e-05,2.871900e-04,3.786400e-04,4.369400e-04,4.687800e-04,& - & 4.846100e-04,4.778800e-04,4.384200e-04,4.571900e-04,3.841600e-03,& - & 1.214900e-04,3.853700e-04,4.991800e-04,5.655700e-04,5.969800e-04,& - & 6.054900e-04,5.870800e-04,5.247200e-04,4.678700e-04,4.493100e-03,& - & 1.671900e-04,5.175600e-04,6.604400e-04,7.366600e-04,7.659100e-04,& - & 7.626000e-04,7.275300e-04,6.386700e-04,4.695400e-04,5.096100e-03,& - & 2.316100e-04,6.875900e-04,8.643500e-04,9.538800e-04,9.829500e-04,& - & 9.656800e-04,9.030000e-04,7.797900e-04,5.222700e-04,5.685500e-03,& - & 3.205700e-04,8.992300e-04,1.113000e-03,1.217100e-03,1.246500e-03,& - & 1.219300e-03,1.124500e-03,9.552100e-04,6.064600e-04,6.287500e-03/ - data absa(1:300,5) / & - & 7.858100e-03,1.635900e-02,1.874700e-02,1.910400e-02,1.849300e-02,& - & 1.745300e-02,1.612400e-02,1.443600e-02,9.963400e-03,9.026600e-03,& - & 1.024800e-02,1.993000e-02,2.254300e-02,2.290100e-02,2.218700e-02,& - & 2.095400e-02,1.937900e-02,1.719400e-02,1.196100e-02,1.070600e-02,& - & 1.309600e-02,2.388800e-02,2.673900e-02,2.719500e-02,2.643300e-02,& - & 2.493600e-02,2.304600e-02,2.029500e-02,1.410600e-02,1.254400e-02,& - & 1.633800e-02,2.832900e-02,3.150000e-02,3.204700e-02,3.115100e-02,& - & 2.939500e-02,2.725800e-02,2.390900e-02,1.647900e-02,1.454100e-02,& - & 1.990500e-02,3.326700e-02,3.692500e-02,3.752300e-02,3.646000e-02,& - & 3.448000e-02,3.193900e-02,2.792400e-02,1.909600e-02,1.682000e-02,& - & 6.500000e-03,1.321000e-02,1.501700e-02,1.533800e-02,1.489400e-02,& - & 1.404600e-02,1.288600e-02,1.148500e-02,7.839600e-03,6.983500e-03,& - & 8.506000e-03,1.624600e-02,1.819600e-02,1.854600e-02,1.799900e-02,& - & 1.696200e-02,1.557000e-02,1.375900e-02,9.500400e-03,8.252400e-03,& - & 1.089500e-02,1.962900e-02,2.180100e-02,2.220200e-02,2.157100e-02,& - & 2.028700e-02,1.861900e-02,1.633600e-02,1.131100e-02,9.676300e-03,& - & 1.363400e-02,2.346700e-02,2.593800e-02,2.638500e-02,2.562600e-02,& - & 2.403900e-02,2.210800e-02,1.932000e-02,1.327700e-02,1.125400e-02,& - & 1.664300e-02,2.778900e-02,3.066600e-02,3.114900e-02,3.017800e-02,& - & 2.831700e-02,2.602300e-02,2.264400e-02,1.543800e-02,1.305800e-02,& - & 5.106800e-03,1.015500e-02,1.148500e-02,1.177000e-02,1.148400e-02,& - & 1.082300e-02,9.862300e-03,8.759400e-03,5.995800e-03,5.261100e-03,& - & 6.683500e-03,1.264000e-02,1.408400e-02,1.438200e-02,1.402300e-02,& - & 1.319200e-02,1.201200e-02,1.056000e-02,7.291700e-03,6.186400e-03,& - & 8.603300e-03,1.544400e-02,1.706900e-02,1.743700e-02,1.694000e-02,& - & 1.590000e-02,1.446400e-02,1.261900e-02,8.811600e-03,7.253100e-03,& - & 1.083200e-02,1.866500e-02,2.052100e-02,2.093900e-02,2.031400e-02,& - & 1.900000e-02,1.728900e-02,1.501500e-02,1.035500e-02,8.472500e-03,& - & 1.332800e-02,2.230700e-02,2.450800e-02,2.496700e-02,2.413500e-02,& - & 2.249400e-02,2.048200e-02,1.771400e-02,1.216100e-02,9.854300e-03,& - & 3.969500e-03,7.681800e-03,8.633100e-03,8.872800e-03,8.684700e-03,& - & 8.174300e-03,7.417100e-03,6.573300e-03,4.675600e-03,4.039500e-03,& - & 5.187100e-03,9.666900e-03,1.073000e-02,1.098400e-02,1.072700e-02,& - & 1.007900e-02,9.113000e-03,7.964000e-03,5.523000e-03,4.745700e-03,& - & 6.687200e-03,1.193600e-02,1.315000e-02,1.344700e-02,1.309000e-02,& - & 1.226600e-02,1.108200e-02,9.581900e-03,6.723900e-03,5.558200e-03,& - & 8.468600e-03,1.455800e-02,1.598200e-02,1.634600e-02,1.584100e-02,& - & 1.478300e-02,1.333100e-02,1.147300e-02,7.945500e-03,6.500900e-03,& - & 1.053000e-02,1.753200e-02,1.924500e-02,1.969700e-02,1.902100e-02,& - & 1.766300e-02,1.591000e-02,1.364200e-02,9.417300e-03,7.563800e-03,& - & 3.118000e-03,5.820900e-03,6.485400e-03,6.664400e-03,6.538000e-03,& - & 6.141000e-03,5.560900e-03,4.918200e-03,3.596900e-03,3.158200e-03,& - & 4.054900e-03,7.375700e-03,8.152000e-03,8.349700e-03,8.155000e-03,& - & 7.643400e-03,6.893400e-03,5.984000e-03,4.129000e-03,3.694000e-03,& - & 5.218000e-03,9.178700e-03,1.011600e-02,1.033500e-02,1.004800e-02,& - & 9.405800e-03,8.459200e-03,7.244700e-03,5.047800e-03,4.330800e-03,& - & 6.634700e-03,1.128500e-02,1.239200e-02,1.268000e-02,1.227400e-02,& - & 1.144700e-02,1.027100e-02,8.731000e-03,6.084900e-03,5.069100e-03,& - & 8.313100e-03,1.370600e-02,1.502300e-02,1.539400e-02,1.488000e-02,& - & 1.381000e-02,1.235900e-02,1.045900e-02,7.253800e-03,5.908300e-03,& - & 2.411300e-03,4.403500e-03,4.858400e-03,4.970200e-03,4.865200e-03,& - & 4.563100e-03,4.128200e-03,3.647500e-03,2.649500e-03,2.638000e-03,& - & 3.141700e-03,5.604100e-03,6.155200e-03,6.278800e-03,6.120900e-03,& - & 5.727900e-03,5.162100e-03,4.464700e-03,3.133300e-03,3.049000e-03,& - & 4.052300e-03,7.010700e-03,7.697400e-03,7.855600e-03,7.624900e-03,& - & 7.122800e-03,6.398200e-03,5.441200e-03,3.735400e-03,3.535100e-03,& - & 5.173500e-03,8.671400e-03,9.504600e-03,9.706200e-03,9.393700e-03,& - & 8.751400e-03,7.842700e-03,6.599800e-03,4.623100e-03,4.093100e-03,& - & 6.526600e-03,1.061500e-02,1.160300e-02,1.186200e-02,1.147000e-02,& - & 1.066500e-02,9.530700e-03,7.958900e-03,5.490800e-03,4.735400e-03/ - data absa(301:650,5) / & - & 1.831300e-03,3.298100e-03,3.633400e-03,3.706700e-03,3.620100e-03,& - & 3.391200e-03,3.067900e-03,2.706600e-03,2.024100e-03,2.255400e-03,& - & 2.397600e-03,4.244400e-03,4.644200e-03,4.721700e-03,4.591500e-03,& - & 4.284700e-03,3.854600e-03,3.332800e-03,2.408100e-03,2.595400e-03,& - & 3.118400e-03,5.355900e-03,5.846000e-03,5.945100e-03,5.758300e-03,& - & 5.371700e-03,4.818000e-03,4.088800e-03,2.787900e-03,3.003200e-03,& - & 4.021600e-03,6.660500e-03,7.270000e-03,7.400700e-03,7.154900e-03,& - & 6.656100e-03,5.959900e-03,4.992900e-03,3.438400e-03,3.486000e-03,& - & 5.120600e-03,8.212700e-03,8.936400e-03,9.094400e-03,8.796000e-03,& - & 8.171700e-03,7.305900e-03,6.065100e-03,4.136200e-03,4.038300e-03,& - & 1.367800e-03,2.434400e-03,2.677100e-03,2.731400e-03,2.676400e-03,& - & 2.519900e-03,2.289200e-03,2.014600e-03,1.515800e-03,2.071700e-03,& - & 1.798600e-03,3.172100e-03,3.469800e-03,3.532500e-03,3.438300e-03,& - & 3.212500e-03,2.885300e-03,2.494000e-03,1.779000e-03,2.365300e-03,& - & 2.364400e-03,4.058700e-03,4.419400e-03,4.491200e-03,4.350500e-03,& - & 4.057400e-03,3.629400e-03,3.075300e-03,2.090800e-03,2.707500e-03,& - & 3.088500e-03,5.105200e-03,5.551100e-03,5.635900e-03,5.446000e-03,& - & 5.061700e-03,4.520200e-03,3.783400e-03,2.529300e-03,3.117800e-03,& - & 3.984300e-03,6.352100e-03,6.878000e-03,6.972900e-03,6.737400e-03,& - & 6.248400e-03,5.574600e-03,4.630400e-03,3.121600e-03,3.594400e-03,& - & 1.018000e-03,1.780800e-03,1.951300e-03,1.991700e-03,1.957100e-03,& - & 1.856800e-03,1.703400e-03,1.514300e-03,1.232400e-03,2.956600e-03,& - & 1.340900e-03,2.349100e-03,2.564400e-03,2.610300e-03,2.551500e-03,& - & 2.396900e-03,2.159600e-03,1.867900e-03,1.363200e-03,3.331700e-03,& - & 1.777000e-03,3.045000e-03,3.309400e-03,3.364100e-03,3.269300e-03,& - & 3.059000e-03,2.735800e-03,2.308300e-03,1.620400e-03,3.746400e-03,& - & 2.352000e-03,3.880500e-03,4.209000e-03,4.272200e-03,4.136200e-03,& - & 3.852100e-03,3.425600e-03,2.856800e-03,1.873200e-03,4.206100e-03,& - & 3.072900e-03,4.885500e-03,5.277000e-03,5.337900e-03,5.158900e-03,& - & 4.779000e-03,4.247800e-03,3.524100e-03,2.340000e-03,4.737400e-03,& - & 7.725300e-04,1.321900e-03,1.442100e-03,1.474000e-03,1.453900e-03,& - & 1.387600e-03,1.285300e-03,1.156700e-03,1.002200e-03,6.884700e-03,& - & 1.017300e-03,1.762500e-03,1.920000e-03,1.955900e-03,1.917500e-03,& - & 1.808700e-03,1.636700e-03,1.424200e-03,1.039400e-03,7.532800e-03,& - & 1.356400e-03,2.312200e-03,2.509300e-03,2.549700e-03,2.484800e-03,& - & 2.331200e-03,2.090200e-03,1.766800e-03,1.223000e-03,8.312600e-03,& - & 1.813400e-03,2.983200e-03,3.226400e-03,3.275500e-03,3.178800e-03,& - & 2.967200e-03,2.637300e-03,2.195600e-03,1.420600e-03,9.194900e-03,& - & 2.398200e-03,3.802400e-03,4.092100e-03,4.137000e-03,4.002500e-03,& - & 3.713200e-03,3.291300e-03,2.718700e-03,1.743700e-03,1.017400e-02,& - & 6.631100e-04,1.123300e-03,1.221900e-03,1.248500e-03,1.229800e-03,& - & 1.173100e-03,1.081800e-03,9.681200e-04,8.227700e-04,9.115100e-03,& - & 8.796100e-04,1.504400e-03,1.632900e-03,1.663100e-03,1.627900e-03,& - & 1.534600e-03,1.387800e-03,1.199000e-03,8.684400e-04,9.963600e-03,& - & 1.183600e-03,1.981100e-03,2.144400e-03,2.178300e-03,2.121100e-03,& - & 1.985900e-03,1.778000e-03,1.495200e-03,1.019000e-03,1.094100e-02,& - & 1.590500e-03,2.571300e-03,2.769400e-03,2.808700e-03,2.723500e-03,& - & 2.535700e-03,2.251200e-03,1.867600e-03,1.171800e-03,1.206000e-02,& - & 2.111800e-03,3.300900e-03,3.529800e-03,3.554800e-03,3.436900e-03,& - & 3.182100e-03,2.819400e-03,2.314100e-03,1.444200e-03,1.328500e-02,& - & 5.647700e-04,9.505400e-04,1.032700e-03,1.054600e-03,1.037400e-03,& - & 9.887000e-04,9.099200e-04,8.070100e-04,6.707600e-04,9.460700e-03,& - & 7.572800e-04,1.278500e-03,1.387500e-03,1.411300e-03,1.378200e-03,& - & 1.298600e-03,1.173100e-03,1.007400e-03,7.258900e-04,1.033100e-02,& - & 1.026100e-03,1.692100e-03,1.829500e-03,1.857000e-03,1.805100e-03,& - & 1.688800e-03,1.508600e-03,1.262600e-03,8.433900e-04,1.136800e-02,& - & 1.386900e-03,2.209500e-03,2.373600e-03,2.400800e-03,2.324700e-03,& - & 2.161500e-03,1.916700e-03,1.582100e-03,9.680900e-04,1.254500e-02,& - & 1.843400e-03,2.858800e-03,3.042400e-03,3.052400e-03,2.944200e-03,& - & 2.719400e-03,2.406800e-03,1.965600e-03,1.205700e-03,1.384600e-02,& - & 4.727800e-04,7.955200e-04,8.650200e-04,8.833700e-04,8.688100e-04,& - & 8.280200e-04,7.616400e-04,6.714600e-04,5.470600e-04,7.891200e-03,& - & 6.417800e-04,1.075900e-03,1.168600e-03,1.188300e-03,1.160100e-03,& - & 1.093500e-03,9.872500e-04,8.429400e-04,6.029400e-04,8.680500e-03,& - & 8.775700e-04,1.432500e-03,1.548600e-03,1.569800e-03,1.526700e-03,& - & 1.428300e-03,1.274400e-03,1.060400e-03,6.949700e-04,9.633700e-03,& - & 1.191200e-03,1.885700e-03,2.022500e-03,2.038800e-03,1.972500e-03,& - & 1.833400e-03,1.624700e-03,1.332600e-03,8.002600e-04,1.069400e-02,& - & 1.584600e-03,2.454500e-03,2.607000e-03,2.609300e-03,2.511100e-03,& - & 2.315100e-03,2.044100e-03,1.660600e-03,1.009100e-03,1.182800e-02/ - data absa(1:300,6) / & - & 2.777800e-02,3.340500e-02,3.526700e-02,3.600600e-02,3.589800e-02,& - & 3.455300e-02,3.110000e-02,2.501400e-02,1.809400e-02,1.679400e-02,& - & 3.336600e-02,4.023500e-02,4.260800e-02,4.337000e-02,4.291400e-02,& - & 4.124700e-02,3.706400e-02,2.994600e-02,2.194000e-02,2.009100e-02,& - & 3.947600e-02,4.791900e-02,5.067000e-02,5.132100e-02,5.066400e-02,& - & 4.861000e-02,4.379300e-02,3.548600e-02,2.622800e-02,2.381600e-02,& - & 4.616500e-02,5.640600e-02,5.935300e-02,6.011700e-02,5.946800e-02,& - & 5.691800e-02,5.132900e-02,4.164300e-02,3.115500e-02,2.822400e-02,& - & 5.359000e-02,6.567600e-02,6.895600e-02,6.988200e-02,6.929900e-02,& - & 6.613900e-02,5.973300e-02,4.863800e-02,3.670100e-02,3.321900e-02,& - & 2.255900e-02,2.765400e-02,2.901500e-02,2.933700e-02,2.907800e-02,& - & 2.793700e-02,2.518900e-02,2.040400e-02,1.414400e-02,1.290900e-02,& - & 2.736100e-02,3.352300e-02,3.534000e-02,3.554000e-02,3.503700e-02,& - & 3.357500e-02,3.023400e-02,2.455800e-02,1.735800e-02,1.545800e-02,& - & 3.270200e-02,4.022200e-02,4.226600e-02,4.237000e-02,4.169000e-02,& - & 3.988700e-02,3.594500e-02,2.924200e-02,2.087200e-02,1.838900e-02,& - & 3.869800e-02,4.770300e-02,4.987400e-02,5.003700e-02,4.923400e-02,& - & 4.700000e-02,4.235500e-02,3.446200e-02,2.493600e-02,2.187400e-02,& - & 4.540600e-02,5.586400e-02,5.825000e-02,5.861100e-02,5.770100e-02,& - & 5.494000e-02,4.954100e-02,4.042500e-02,2.949800e-02,2.582400e-02,& - & 1.749200e-02,2.178700e-02,2.265200e-02,2.275000e-02,2.245300e-02,& - & 2.153400e-02,1.949500e-02,1.581900e-02,1.060200e-02,9.536500e-03,& - & 2.151900e-02,2.673100e-02,2.790200e-02,2.786400e-02,2.735500e-02,& - & 2.615100e-02,2.362400e-02,1.918400e-02,1.314400e-02,1.142700e-02,& - & 2.610400e-02,3.239100e-02,3.373600e-02,3.354500e-02,3.284600e-02,& - & 3.137400e-02,2.829700e-02,2.299600e-02,1.596400e-02,1.363200e-02,& - & 3.132700e-02,3.876700e-02,4.022700e-02,3.999300e-02,3.911400e-02,& - & 3.726300e-02,3.356200e-02,2.729300e-02,1.923400e-02,1.628300e-02,& - & 3.718200e-02,4.579100e-02,4.745200e-02,4.727000e-02,4.621100e-02,& - & 4.390000e-02,3.950200e-02,3.218800e-02,2.290000e-02,1.932600e-02,& - & 1.329100e-02,1.667800e-02,1.727500e-02,1.727800e-02,1.699300e-02,& - & 1.628600e-02,1.482200e-02,1.199000e-02,7.757900e-03,7.148800e-03,& - & 1.663000e-02,2.081500e-02,2.156800e-02,2.144000e-02,2.097300e-02,& - & 2.000600e-02,1.812600e-02,1.465400e-02,9.832900e-03,8.520500e-03,& - & 2.044400e-02,2.555300e-02,2.639700e-02,2.613200e-02,2.547100e-02,& - & 2.422300e-02,2.191000e-02,1.772200e-02,1.215500e-02,1.014800e-02,& - & 2.488700e-02,3.095900e-02,3.184700e-02,3.146900e-02,3.064100e-02,& - & 2.905100e-02,2.619000e-02,2.121200e-02,1.476700e-02,1.211000e-02,& - & 2.991200e-02,3.701000e-02,3.803100e-02,3.754600e-02,3.650900e-02,& - & 3.452300e-02,3.100900e-02,2.516400e-02,1.770500e-02,1.442700e-02,& - & 1.006600e-02,1.266800e-02,1.307100e-02,1.302900e-02,1.276500e-02,& - & 1.221700e-02,1.114800e-02,9.002100e-03,5.758700e-03,5.420900e-03,& - & 1.275700e-02,1.601500e-02,1.654400e-02,1.639700e-02,1.599000e-02,& - & 1.523400e-02,1.378900e-02,1.110500e-02,7.396700e-03,6.504600e-03,& - & 1.590100e-02,1.996300e-02,2.050800e-02,2.025400e-02,1.968200e-02,& - & 1.864400e-02,1.682100e-02,1.355200e-02,9.235600e-03,7.781100e-03,& - & 1.959600e-02,2.449900e-02,2.508200e-02,2.469600e-02,2.393600e-02,& - & 2.258000e-02,2.026900e-02,1.634400e-02,1.132100e-02,9.316300e-03,& - & 2.383000e-02,2.965000e-02,3.033400e-02,2.981100e-02,2.879200e-02,& - & 2.707000e-02,2.416600e-02,1.953600e-02,1.366500e-02,1.111100e-02,& - & 7.608700e-03,9.495100e-03,9.764900e-03,9.694300e-03,9.469100e-03,& - & 9.031100e-03,8.224900e-03,6.652800e-03,4.337800e-03,4.262700e-03,& - & 9.702900e-03,1.214600e-02,1.249500e-02,1.239400e-02,1.204700e-02,& - & 1.143800e-02,1.032900e-02,8.294600e-03,5.426700e-03,5.054900e-03,& - & 1.224100e-02,1.535300e-02,1.572900e-02,1.553400e-02,1.503900e-02,& - & 1.418800e-02,1.272700e-02,1.021800e-02,6.880300e-03,6.022300e-03,& - & 1.522200e-02,1.908800e-02,1.950400e-02,1.921300e-02,1.855000e-02,& - & 1.737900e-02,1.548300e-02,1.243400e-02,8.517000e-03,7.208400e-03,& - & 1.867700e-02,2.338400e-02,2.389200e-02,2.351000e-02,2.258100e-02,& - & 2.103400e-02,1.863000e-02,1.498000e-02,1.041500e-02,8.605900e-03/ - data absa(301:650,6) / & - & 5.782700e-03,7.131300e-03,7.280200e-03,7.204500e-03,6.995400e-03,& - & 6.626900e-03,6.009700e-03,4.873100e-03,3.126400e-03,3.713700e-03,& - & 7.408400e-03,9.188700e-03,9.400000e-03,9.309600e-03,9.030400e-03,& - & 8.519000e-03,7.673300e-03,6.152500e-03,3.926300e-03,4.394400e-03,& - & 9.404000e-03,1.171700e-02,1.197600e-02,1.183500e-02,1.143400e-02,& - & 1.072600e-02,9.580400e-03,7.662700e-03,5.065600e-03,5.196100e-03,& - & 1.177200e-02,1.473000e-02,1.504800e-02,1.485400e-02,1.430200e-02,& - & 1.332000e-02,1.177900e-02,9.407400e-03,6.372500e-03,6.124900e-03,& - & 1.453300e-02,1.823400e-02,1.865200e-02,1.841700e-02,1.765400e-02,& - & 1.631900e-02,1.431700e-02,1.142200e-02,7.888100e-03,7.193100e-03,& - & 4.347300e-03,5.353000e-03,5.445300e-03,5.377200e-03,5.186600e-03,& - & 4.864700e-03,4.380800e-03,3.555900e-03,2.417300e-03,3.510800e-03,& - & 5.653400e-03,6.960800e-03,7.094200e-03,6.993300e-03,6.748900e-03,& - & 6.333000e-03,5.674500e-03,4.552000e-03,2.908100e-03,4.118000e-03,& - & 7.223100e-03,8.949200e-03,9.115500e-03,8.977200e-03,8.651900e-03,& - & 8.086500e-03,7.184200e-03,5.729800e-03,3.712600e-03,4.851000e-03,& - & 9.098000e-03,1.132500e-02,1.155400e-02,1.140200e-02,1.096000e-02,& - & 1.018200e-02,8.952100e-03,7.110300e-03,4.739900e-03,5.688000e-03,& - & 1.130200e-02,1.412100e-02,1.445700e-02,1.430200e-02,1.370900e-02,& - & 1.264400e-02,1.100700e-02,8.699300e-03,5.928100e-03,6.643600e-03,& - & 3.216600e-03,3.963500e-03,4.042100e-03,3.993600e-03,3.844100e-03,& - & 3.592300e-03,3.209700e-03,2.588600e-03,1.769300e-03,5.061500e-03,& - & 4.255100e-03,5.249600e-03,5.343100e-03,5.263300e-03,5.054300e-03,& - & 4.709000e-03,4.197900e-03,3.355600e-03,2.081100e-03,5.751700e-03,& - & 5.517800e-03,6.831000e-03,6.948100e-03,6.818100e-03,6.534000e-03,& - & 6.073300e-03,5.377500e-03,4.277900e-03,2.674400e-03,6.543600e-03,& - & 7.023300e-03,8.712000e-03,8.869300e-03,8.720900e-03,8.351400e-03,& - & 7.737600e-03,6.799200e-03,5.365300e-03,3.483600e-03,7.445800e-03,& - & 8.790800e-03,1.093500e-02,1.115600e-02,1.101100e-02,1.055100e-02,& - & 9.737700e-03,8.464300e-03,6.615700e-03,4.410500e-03,8.413100e-03,& - & 2.403600e-03,2.962600e-03,3.027000e-03,2.989100e-03,2.878300e-03,& - & 2.696600e-03,2.416700e-03,1.938400e-03,1.295000e-03,1.258000e-02,& - & 3.230400e-03,3.993600e-03,4.069600e-03,4.006300e-03,3.844100e-03,& - & 3.581700e-03,3.184100e-03,2.525800e-03,1.631800e-03,1.386700e-02,& - & 4.245000e-03,5.271300e-03,5.371700e-03,5.268300e-03,5.033900e-03,& - & 4.662500e-03,4.109100e-03,3.250900e-03,2.006500e-03,1.520400e-02,& - & 5.474400e-03,6.806400e-03,6.923800e-03,6.791200e-03,6.490500e-03,& - & 5.983800e-03,5.243900e-03,4.118800e-03,2.600200e-03,1.665200e-02,& - & 6.935300e-03,8.607900e-03,8.763500e-03,8.618100e-03,8.234900e-03,& - & 7.588600e-03,6.599400e-03,5.119200e-03,3.323900e-03,1.825100e-02,& - & 2.064800e-03,2.548100e-03,2.600000e-03,2.560700e-03,2.463000e-03,& - & 2.306900e-03,2.069200e-03,1.656200e-03,1.086000e-03,1.704900e-02,& - & 2.785900e-03,3.454700e-03,3.523700e-03,3.459400e-03,3.314200e-03,& - & 3.084100e-03,2.734500e-03,2.158400e-03,1.334100e-03,1.874700e-02,& - & 3.677300e-03,4.576400e-03,4.663300e-03,4.575100e-03,4.372100e-03,& - & 4.040500e-03,3.541900e-03,2.777100e-03,1.673000e-03,2.046000e-02,& - & 4.764500e-03,5.926200e-03,6.030100e-03,5.910400e-03,5.646200e-03,& - & 5.201700e-03,4.530600e-03,3.516300e-03,2.177500e-03,2.222500e-02,& - & 6.067300e-03,7.519400e-03,7.659200e-03,7.514600e-03,7.160800e-03,& - & 6.575000e-03,5.695400e-03,4.387700e-03,2.787800e-03,2.411200e-02,& - & 1.764900e-03,2.184000e-03,2.227300e-03,2.189400e-03,2.102900e-03,& - & 1.964700e-03,1.757000e-03,1.409200e-03,9.061200e-04,1.811600e-02,& - & 2.391100e-03,2.972100e-03,3.030600e-03,2.977600e-03,2.851400e-03,& - & 2.645000e-03,2.335100e-03,1.842400e-03,1.096800e-03,1.992900e-02,& - & 3.173200e-03,3.950300e-03,4.021500e-03,3.944000e-03,3.772100e-03,& - & 3.486300e-03,3.046500e-03,2.373800e-03,1.393100e-03,2.170700e-02,& - & 4.132900e-03,5.137400e-03,5.222600e-03,5.116100e-03,4.882700e-03,& - & 4.495000e-03,3.901900e-03,3.010600e-03,1.819900e-03,2.354200e-02,& - & 5.297200e-03,6.540600e-03,6.663600e-03,6.531900e-03,6.206000e-03,& - & 5.677900e-03,4.900600e-03,3.765300e-03,2.334000e-03,2.547800e-02,& - & 1.491700e-03,1.853100e-03,1.892000e-03,1.862000e-03,1.786100e-03,& - & 1.661700e-03,1.478800e-03,1.187300e-03,7.555000e-04,1.544400e-02,& - & 2.033300e-03,2.534800e-03,2.583800e-03,2.540800e-03,2.432800e-03,& - & 2.251400e-03,1.978300e-03,1.561100e-03,9.018700e-04,1.701500e-02,& - & 2.715300e-03,3.387300e-03,3.443900e-03,3.376300e-03,3.226400e-03,& - & 2.975000e-03,2.593200e-03,2.023900e-03,1.159700e-03,1.856400e-02,& - & 3.562500e-03,4.424400e-03,4.497100e-03,4.402500e-03,4.190900e-03,& - & 3.843600e-03,3.327700e-03,2.571900e-03,1.515900e-03,2.017600e-02,& - & 4.591500e-03,5.659900e-03,5.762900e-03,5.640600e-03,5.342300e-03,& - & 4.870000e-03,4.190700e-03,3.217100e-03,1.949700e-03,2.191300e-02/ - data absa(1:300,7) / & - & 6.401300e-02,7.355900e-02,7.801600e-02,7.811000e-02,7.496300e-02,& - & 6.893300e-02,6.075000e-02,4.887500e-02,3.930800e-02,3.656000e-02,& - & 7.636300e-02,8.796000e-02,9.355900e-02,9.397900e-02,9.073400e-02,& - & 8.334900e-02,7.319200e-02,5.877400e-02,4.744100e-02,4.403600e-02,& - & 8.975800e-02,1.033100e-01,1.105100e-01,1.116900e-01,1.076900e-01,& - & 9.867900e-02,8.672600e-02,6.981900e-02,5.665500e-02,5.267500e-02,& - & 1.043300e-01,1.200800e-01,1.292800e-01,1.310500e-01,1.257600e-01,& - & 1.154400e-01,1.016600e-01,8.224100e-02,6.714200e-02,6.252000e-02,& - & 1.200100e-01,1.382400e-01,1.493200e-01,1.515800e-01,1.452600e-01,& - & 1.337400e-01,1.180400e-01,9.595100e-02,7.901600e-02,7.373400e-02,& - & 5.296800e-02,6.211600e-02,6.583500e-02,6.604400e-02,6.329400e-02,& - & 5.816100e-02,5.117600e-02,4.139300e-02,3.113300e-02,2.825500e-02,& - & 6.372800e-02,7.489900e-02,7.953600e-02,8.005700e-02,7.710100e-02,& - & 7.083900e-02,6.217500e-02,5.010800e-02,3.779800e-02,3.418200e-02,& - & 7.553200e-02,8.857200e-02,9.464800e-02,9.570000e-02,9.197300e-02,& - & 8.444300e-02,7.408500e-02,5.991800e-02,4.542900e-02,4.106900e-02,& - & 8.840400e-02,1.035600e-01,1.112400e-01,1.125900e-01,1.079800e-01,& - & 9.924600e-02,8.737300e-02,7.099300e-02,5.411000e-02,4.892600e-02,& - & 1.023500e-01,1.201000e-01,1.292600e-01,1.306400e-01,1.253700e-01,& - & 1.155600e-01,1.020800e-01,8.320600e-02,6.403000e-02,5.794700e-02,& - & 4.173500e-02,4.980300e-02,5.274100e-02,5.265700e-02,5.024900e-02,& - & 4.611300e-02,4.058800e-02,3.298600e-02,2.352200e-02,2.088600e-02,& - & 5.084100e-02,6.075700e-02,6.438900e-02,6.456400e-02,6.184400e-02,& - & 5.679500e-02,4.985400e-02,4.040700e-02,2.885500e-02,2.544200e-02,& - & 6.088900e-02,7.260300e-02,7.733400e-02,7.787600e-02,7.457400e-02,& - & 6.838800e-02,6.003700e-02,4.882700e-02,3.500400e-02,3.075100e-02,& - & 7.199200e-02,8.567500e-02,9.163400e-02,9.223300e-02,8.835600e-02,& - & 8.106300e-02,7.139700e-02,5.837100e-02,4.197200e-02,3.682100e-02,& - & 8.414400e-02,1.001900e-01,1.071300e-01,1.077400e-01,1.034500e-01,& - & 9.514000e-02,8.407600e-02,6.889600e-02,4.994400e-02,4.383200e-02,& - & 3.215400e-02,3.897000e-02,4.115000e-02,4.080200e-02,3.873400e-02,& - & 3.546300e-02,3.118900e-02,2.544100e-02,1.742600e-02,1.534800e-02,& - & 3.973900e-02,4.811500e-02,5.084600e-02,5.056700e-02,4.818800e-02,& - & 4.414600e-02,3.876500e-02,3.162900e-02,2.172200e-02,1.882400e-02,& - & 4.823200e-02,5.820200e-02,6.178600e-02,6.169100e-02,5.876900e-02,& - & 5.380000e-02,4.723700e-02,3.862700e-02,2.659600e-02,2.290600e-02,& - & 5.769300e-02,6.940300e-02,7.391200e-02,7.380100e-02,7.037000e-02,& - & 6.448700e-02,5.673300e-02,4.660400e-02,3.215700e-02,2.758200e-02,& - & 6.816200e-02,8.191000e-02,8.694300e-02,8.694700e-02,8.311600e-02,& - & 7.635500e-02,6.738900e-02,5.547400e-02,3.850600e-02,3.298400e-02,& - & 2.454300e-02,3.011400e-02,3.156400e-02,3.111400e-02,2.945300e-02,& - & 2.688700e-02,2.357500e-02,1.932300e-02,1.279500e-02,1.169100e-02,& - & 3.084300e-02,3.771900e-02,3.954000e-02,3.906500e-02,3.707900e-02,& - & 3.384500e-02,2.967900e-02,2.436700e-02,1.628200e-02,1.428300e-02,& - & 3.798900e-02,4.614100e-02,4.860100e-02,4.816400e-02,4.569100e-02,& - & 4.169700e-02,3.659900e-02,3.011000e-02,2.023000e-02,1.731600e-02,& - & 4.599700e-02,5.563900e-02,5.873800e-02,5.821700e-02,5.529300e-02,& - & 5.055100e-02,4.447400e-02,3.667500e-02,2.467900e-02,2.082400e-02,& - & 5.498000e-02,6.633500e-02,6.968900e-02,6.922000e-02,6.593400e-02,& - & 6.047700e-02,5.335600e-02,4.402300e-02,2.973500e-02,2.492500e-02,& - & 1.842600e-02,2.276100e-02,2.364100e-02,2.322600e-02,2.192900e-02,& - & 1.996800e-02,1.746700e-02,1.434700e-02,9.180700e-03,8.844100e-03,& - & 2.357800e-02,2.903200e-02,3.013300e-02,2.960600e-02,2.799600e-02,& - & 2.549500e-02,2.229800e-02,1.836300e-02,1.212900e-02,1.095000e-02,& - & 2.950700e-02,3.604700e-02,3.750800e-02,3.691300e-02,3.488600e-02,& - & 3.178600e-02,2.784400e-02,2.296500e-02,1.529200e-02,1.340900e-02,& - & 3.626600e-02,4.401500e-02,4.586500e-02,4.510300e-02,4.267500e-02,& - & 3.898200e-02,3.426100e-02,2.827900e-02,1.885300e-02,1.621400e-02,& - & 4.398400e-02,5.304100e-02,5.501700e-02,5.412900e-02,5.142900e-02,& - & 4.716100e-02,4.156400e-02,3.427000e-02,2.288200e-02,1.944600e-02/ - data absa(301:650,7) / & - & 1.376400e-02,1.698000e-02,1.748800e-02,1.710800e-02,1.610600e-02,& - & 1.466000e-02,1.281100e-02,1.050800e-02,6.585800e-03,7.397900e-03,& - & 1.790500e-02,2.204900e-02,2.270800e-02,2.221300e-02,2.091200e-02,& - & 1.901500e-02,1.659400e-02,1.361600e-02,8.992500e-03,8.912700e-03,& - & 2.278100e-02,2.783400e-02,2.870700e-02,2.808900e-02,2.643600e-02,& - & 2.403600e-02,2.100100e-02,1.724300e-02,1.155000e-02,1.072700e-02,& - & 2.846600e-02,3.447300e-02,3.549900e-02,3.468100e-02,3.269500e-02,& - & 2.980300e-02,2.613800e-02,2.150400e-02,1.443200e-02,1.288800e-02,& - & 3.508700e-02,4.209100e-02,4.309600e-02,4.205700e-02,3.978100e-02,& - & 3.645600e-02,3.208900e-02,2.635600e-02,1.766500e-02,1.541900e-02,& - & 1.035300e-02,1.261400e-02,1.288200e-02,1.250700e-02,1.173700e-02,& - & 1.067500e-02,9.309300e-03,7.625700e-03,4.611600e-03,7.361500e-03,& - & 1.358700e-02,1.662500e-02,1.698800e-02,1.653900e-02,1.552100e-02,& - & 1.407500e-02,1.225200e-02,1.000800e-02,6.574200e-03,8.818300e-03,& - & 1.755100e-02,2.131000e-02,2.182100e-02,2.126200e-02,1.993700e-02,& - & 1.806600e-02,1.572100e-02,1.283900e-02,8.665300e-03,1.045800e-02,& - & 2.226500e-02,2.681400e-02,2.735700e-02,2.660000e-02,2.497600e-02,& - & 2.267000e-02,1.979600e-02,1.619300e-02,1.097900e-02,1.233200e-02,& - & 2.786200e-02,3.321800e-02,3.366200e-02,3.263400e-02,3.070300e-02,& - & 2.802100e-02,2.458100e-02,2.010200e-02,1.358900e-02,1.441300e-02,& - & 7.878100e-03,9.435700e-03,9.508200e-03,9.156700e-03,8.545500e-03,& - & 7.711500e-03,6.698700e-03,5.466800e-03,3.237500e-03,1.069000e-02,& - & 1.037800e-02,1.253200e-02,1.269200e-02,1.226000e-02,1.145000e-02,& - & 1.034200e-02,8.958200e-03,7.295600e-03,4.723600e-03,1.233000e-02,& - & 1.349500e-02,1.627000e-02,1.651600e-02,1.600000e-02,1.495500e-02,& - & 1.348500e-02,1.167500e-02,9.474400e-03,6.392900e-03,1.416000e-02,& - & 1.731500e-02,2.076100e-02,2.102600e-02,2.032600e-02,1.900900e-02,& - & 1.716400e-02,1.488400e-02,1.209100e-02,8.253200e-03,1.622900e-02,& - & 2.195000e-02,2.607900e-02,2.624200e-02,2.530100e-02,2.364500e-02,& - & 2.144300e-02,1.868400e-02,1.520300e-02,1.036100e-02,1.862300e-02,& - & 6.091200e-03,7.261800e-03,7.249700e-03,6.936800e-03,6.425100e-03,& - & 5.738100e-03,4.922400e-03,3.987000e-03,2.327900e-03,2.440600e-02,& - & 8.123700e-03,9.706100e-03,9.737500e-03,9.338800e-03,8.659100e-03,& - & 7.750500e-03,6.664200e-03,5.399700e-03,3.351300e-03,2.655900e-02,& - & 1.064300e-02,1.268000e-02,1.276700e-02,1.229200e-02,1.141600e-02,& - & 1.023500e-02,8.804200e-03,7.107700e-03,4.742300e-03,2.916600e-02,& - & 1.374500e-02,1.632700e-02,1.643200e-02,1.580300e-02,1.468000e-02,& - & 1.319600e-02,1.136800e-02,9.159100e-03,6.257600e-03,3.214000e-02,& - & 1.751500e-02,2.072600e-02,2.077800e-02,1.993600e-02,1.850300e-02,& - & 1.667900e-02,1.441900e-02,1.164200e-02,7.965600e-03,3.544500e-02,& - & 5.354900e-03,6.381600e-03,6.366000e-03,6.084000e-03,5.615600e-03,& - & 4.982500e-03,4.230300e-03,3.379500e-03,1.974900e-03,3.236700e-02,& - & 7.201300e-03,8.560400e-03,8.553200e-03,8.176300e-03,7.542100e-03,& - & 6.699700e-03,5.706500e-03,4.572900e-03,2.863200e-03,3.519600e-02,& - & 9.502200e-03,1.120200e-02,1.120400e-02,1.071600e-02,9.900000e-03,& - & 8.823000e-03,7.539400e-03,6.033100e-03,4.023600e-03,3.863800e-02,& - & 1.228800e-02,1.443200e-02,1.442400e-02,1.379100e-02,1.273500e-02,& - & 1.138700e-02,9.760800e-03,7.810300e-03,5.323400e-03,4.250700e-02,& - & 1.556700e-02,1.829500e-02,1.826100e-02,1.746000e-02,1.614500e-02,& - & 1.446900e-02,1.244800e-02,9.947700e-03,6.780000e-03,4.670300e-02,& - & 4.661000e-03,5.545400e-03,5.531500e-03,5.283800e-03,4.875900e-03,& - & 4.325400e-03,3.658300e-03,2.882100e-03,1.668100e-03,3.434700e-02,& - & 6.328500e-03,7.486400e-03,7.468200e-03,7.126600e-03,6.559000e-03,& - & 5.811100e-03,4.923200e-03,3.890100e-03,2.426300e-03,3.772300e-02,& - & 8.411400e-03,9.872500e-03,9.830300e-03,9.356200e-03,8.604400e-03,& - & 7.637000e-03,6.494600e-03,5.144700e-03,3.414400e-03,4.164500e-02,& - & 1.087700e-02,1.273000e-02,1.266200e-02,1.205600e-02,1.109300e-02,& - & 9.874100e-03,8.435200e-03,6.686500e-03,4.514600e-03,4.583600e-02,& - & 1.374700e-02,1.607400e-02,1.598300e-02,1.525700e-02,1.409800e-02,& - & 1.261200e-02,1.079900e-02,8.534700e-03,5.746100e-03,5.029500e-02,& - & 4.007900e-03,4.756000e-03,4.741700e-03,4.525100e-03,4.176300e-03,& - & 3.716200e-03,3.148800e-03,2.461000e-03,1.398300e-03,2.979700e-02,& - & 5.497500e-03,6.479100e-03,6.446700e-03,6.139900e-03,5.650200e-03,& - & 5.014000e-03,4.245100e-03,3.317500e-03,2.046500e-03,3.307400e-02,& - & 7.317300e-03,8.591300e-03,8.537700e-03,8.119200e-03,7.453900e-03,& - & 6.607500e-03,5.606300e-03,4.394000e-03,2.877200e-03,3.670900e-02,& - & 9.474300e-03,1.109000e-02,1.100200e-02,1.046800e-02,9.635600e-03,& - & 8.579200e-03,7.299300e-03,5.731400e-03,3.802500e-03,4.054700e-02,& - & 1.201300e-02,1.399400e-02,1.387900e-02,1.322800e-02,1.223400e-02,& - & 1.096400e-02,9.366200e-03,7.336300e-03,4.841200e-03,4.459300e-02/ - data absa(1:300,8) / & - & 1.604300e-01,1.595500e-01,1.574400e-01,1.520300e-01,1.439100e-01,& - & 1.326600e-01,1.182600e-01,1.064700e-01,1.037100e-01,1.014400e-01,& - & 1.921900e-01,1.920000e-01,1.894400e-01,1.830900e-01,1.732400e-01,& - & 1.605400e-01,1.444300e-01,1.309500e-01,1.267200e-01,1.241000e-01,& - & 2.262900e-01,2.270000e-01,2.242400e-01,2.171900e-01,2.062500e-01,& - & 1.928000e-01,1.741000e-01,1.585100e-01,1.523800e-01,1.492400e-01,& - & 2.630200e-01,2.648700e-01,2.621400e-01,2.547000e-01,2.437100e-01,& - & 2.288200e-01,2.069200e-01,1.891400e-01,1.809800e-01,1.774800e-01,& - & 3.019500e-01,3.053800e-01,3.029900e-01,2.958400e-01,2.847100e-01,& - & 2.679300e-01,2.428500e-01,2.230100e-01,2.133600e-01,2.095200e-01,& - & 1.384600e-01,1.402200e-01,1.400300e-01,1.358200e-01,1.290000e-01,& - & 1.196500e-01,1.066800e-01,9.105900e-02,8.558500e-02,8.163600e-02,& - & 1.671500e-01,1.698500e-01,1.697100e-01,1.648400e-01,1.566800e-01,& - & 1.456400e-01,1.309300e-01,1.128500e-01,1.055500e-01,1.007900e-01,& - & 1.980300e-01,2.024400e-01,2.021100e-01,1.969000e-01,1.880100e-01,& - & 1.755800e-01,1.585100e-01,1.371900e-01,1.276100e-01,1.219300e-01,& - & 2.313300e-01,2.377700e-01,2.378200e-01,2.325400e-01,2.235100e-01,& - & 2.094600e-01,1.889000e-01,1.639700e-01,1.519600e-01,1.455700e-01,& - & 2.671100e-01,2.754200e-01,2.766800e-01,2.718500e-01,2.623200e-01,& - & 2.462100e-01,2.219700e-01,1.937100e-01,1.795300e-01,1.723100e-01,& - & 1.127200e-01,1.164800e-01,1.174200e-01,1.145200e-01,1.092900e-01,& - & 1.015800e-01,9.037600e-02,7.463700e-02,6.642900e-02,6.150600e-02,& - & 1.374900e-01,1.427300e-01,1.438600e-01,1.405200e-01,1.341700e-01,& - & 1.251000e-01,1.119300e-01,9.336100e-02,8.289300e-02,7.681900e-02,& - & 1.646900e-01,1.717900e-01,1.731400e-01,1.694400e-01,1.626100e-01,& - & 1.521600e-01,1.367400e-01,1.143100e-01,1.011000e-01,9.370200e-02,& - & 1.942200e-01,2.035600e-01,2.055500e-01,2.020300e-01,1.949100e-01,& - & 1.828500e-01,1.641400e-01,1.375400e-01,1.215100e-01,1.128600e-01,& - & 2.262300e-01,2.378100e-01,2.411600e-01,2.382900e-01,2.304900e-01,& - & 2.161000e-01,1.939700e-01,1.634700e-01,1.444200e-01,1.344900e-01,& - & 8.905100e-02,9.414800e-02,9.537600e-02,9.349000e-02,8.956400e-02,& - & 8.312300e-02,7.382500e-02,6.044000e-02,5.001800e-02,4.524100e-02,& - & 1.098400e-01,1.166700e-01,1.183700e-01,1.162400e-01,1.114200e-01,& - & 1.038300e-01,9.268600e-02,7.638400e-02,6.330700e-02,5.715800e-02,& - & 1.332100e-01,1.418800e-01,1.440300e-01,1.417300e-01,1.364100e-01,& - & 1.277900e-01,1.143900e-01,9.437500e-02,7.806600e-02,7.049700e-02,& - & 1.589100e-01,1.698400e-01,1.726500e-01,1.706900e-01,1.649700e-01,& - & 1.550500e-01,1.386200e-01,1.143900e-01,9.469000e-02,8.563500e-02,& - & 1.869000e-01,2.003100e-01,2.045900e-01,2.030600e-01,1.967300e-01,& - & 1.846300e-01,1.652400e-01,1.366900e-01,1.133000e-01,1.028900e-01,& - & 6.920300e-02,7.477900e-02,7.598300e-02,7.484000e-02,7.156700e-02,& - & 6.639800e-02,5.886500e-02,4.819300e-02,3.718800e-02,3.316900e-02,& - & 8.643000e-02,9.381700e-02,9.558700e-02,9.432200e-02,9.045600e-02,& - & 8.412400e-02,7.501600e-02,6.161500e-02,4.774400e-02,4.231700e-02,& - & 1.060800e-01,1.154200e-01,1.177200e-01,1.163600e-01,1.121800e-01,& - & 1.047900e-01,9.378400e-02,7.699600e-02,5.954500e-02,5.265600e-02,& - & 1.280800e-01,1.397400e-01,1.426200e-01,1.414800e-01,1.370300e-01,& - & 1.284500e-01,1.148500e-01,9.418400e-02,7.283800e-02,6.451600e-02,& - & 1.522400e-01,1.664800e-01,1.708100e-01,1.699000e-01,1.647100e-01,& - & 1.544200e-01,1.382100e-01,1.134700e-01,8.795600e-02,7.819500e-02,& - & 5.271100e-02,5.799400e-02,5.909600e-02,5.809000e-02,5.543000e-02,& - & 5.135400e-02,4.551500e-02,3.727100e-02,2.703000e-02,2.504000e-02,& - & 6.671900e-02,7.370000e-02,7.536700e-02,7.431100e-02,7.115600e-02,& - & 6.606800e-02,5.885300e-02,4.836900e-02,3.530100e-02,3.174400e-02,& - & 8.286300e-02,9.175800e-02,9.394700e-02,9.297900e-02,8.950000e-02,& - & 8.346800e-02,7.460900e-02,6.132800e-02,4.468300e-02,3.944000e-02,& - & 1.013200e-01,1.123400e-01,1.152000e-01,1.144300e-01,1.105900e-01,& - & 1.035300e-01,9.248900e-02,7.583300e-02,5.531800e-02,4.840600e-02,& - & 1.218500e-01,1.353800e-01,1.394500e-01,1.389500e-01,1.343300e-01,& - & 1.257200e-01,1.124300e-01,9.211200e-02,6.749200e-02,5.887000e-02/ - data absa(301:650,8) / & - & 3.956200e-02,4.427600e-02,4.510900e-02,4.418700e-02,4.208200e-02,& - & 3.885900e-02,3.445400e-02,2.822400e-02,1.938400e-02,1.932100e-02,& - & 5.087900e-02,5.705500e-02,5.839900e-02,5.736700e-02,5.480200e-02,& - & 5.078900e-02,4.523200e-02,3.727300e-02,2.580600e-02,2.486900e-02,& - & 6.400300e-02,7.199600e-02,7.376400e-02,7.277400e-02,6.984700e-02,& - & 6.507800e-02,5.812500e-02,4.794700e-02,3.320500e-02,3.117300e-02,& - & 7.917300e-02,8.923900e-02,9.161700e-02,9.075000e-02,8.739600e-02,& - & 8.172000e-02,7.303100e-02,6.001300e-02,4.167400e-02,3.829700e-02,& - & 9.635000e-02,1.087700e-01,1.121400e-01,1.114800e-01,1.074000e-01,& - & 1.003000e-01,8.964500e-02,7.370300e-02,5.141300e-02,4.621700e-02,& - & 2.937400e-02,3.335800e-02,3.391000e-02,3.317600e-02,3.148800e-02,& - & 2.900200e-02,2.565100e-02,2.099800e-02,1.379000e-02,1.793100e-02,& - & 3.845300e-02,4.373200e-02,4.461900e-02,4.367600e-02,4.158600e-02,& - & 3.849100e-02,3.423400e-02,2.823600e-02,1.882600e-02,2.188200e-02,& - & 4.907500e-02,5.593600e-02,5.713900e-02,5.613800e-02,5.370800e-02,& - & 4.995300e-02,4.464600e-02,3.688700e-02,2.466200e-02,2.659100e-02,& - & 6.143700e-02,7.014000e-02,7.190200e-02,7.091900e-02,6.802700e-02,& - & 6.350800e-02,5.679300e-02,4.682200e-02,3.140500e-02,3.212000e-02,& - & 7.564800e-02,8.645500e-02,8.905900e-02,8.813800e-02,8.461200e-02,& - & 7.882600e-02,7.047400e-02,5.812100e-02,3.920300e-02,3.869300e-02,& - & 2.163100e-02,2.476200e-02,2.509100e-02,2.451900e-02,2.324500e-02,& - & 2.134300e-02,1.881000e-02,1.537300e-02,9.764100e-03,2.927300e-02,& - & 2.881300e-02,3.308400e-02,3.362100e-02,3.284200e-02,3.120100e-02,& - & 2.876900e-02,2.551600e-02,2.101800e-02,1.370700e-02,3.381300e-02,& - & 3.740800e-02,4.298400e-02,4.369600e-02,4.273700e-02,4.078700e-02,& - & 3.784700e-02,3.377700e-02,2.790500e-02,1.831100e-02,3.901000e-02,& - & 4.750200e-02,5.459800e-02,5.565000e-02,5.465400e-02,5.229200e-02,& - & 4.870100e-02,4.352800e-02,3.595600e-02,2.366000e-02,4.468400e-02,& - & 5.918400e-02,6.807500e-02,6.973700e-02,6.871600e-02,6.578800e-02,& - & 6.114800e-02,5.466400e-02,4.521600e-02,2.987800e-02,5.082900e-02,& - & 1.642000e-02,1.869300e-02,1.885600e-02,1.833400e-02,1.734100e-02,& - & 1.593000e-02,1.401300e-02,1.140300e-02,7.064000e-03,7.053200e-02,& - & 2.204000e-02,2.531700e-02,2.563200e-02,2.500900e-02,2.370200e-02,& - & 2.179700e-02,1.927300e-02,1.581000e-02,1.020400e-02,7.682700e-02,& - & 2.896800e-02,3.341800e-02,3.380500e-02,3.296300e-02,3.135800e-02,& - & 2.900700e-02,2.581000e-02,2.126600e-02,1.388600e-02,8.369100e-02,& - & 3.728500e-02,4.300000e-02,4.352900e-02,4.256200e-02,4.063500e-02,& - & 3.770400e-02,3.361700e-02,2.778100e-02,1.817700e-02,9.145700e-02,& - & 4.708500e-02,5.424800e-02,5.508900e-02,5.402700e-02,5.157300e-02,& - & 4.782800e-02,4.267100e-02,3.532600e-02,2.319800e-02,9.989800e-02,& - & 1.456300e-02,1.648000e-02,1.652000e-02,1.597200e-02,1.505400e-02,& - & 1.380000e-02,1.215100e-02,9.849800e-03,6.152900e-03,9.302500e-02,& - & 1.942200e-02,2.223000e-02,2.236500e-02,2.174200e-02,2.057500e-02,& - & 1.892000e-02,1.670200e-02,1.364900e-02,8.859300e-03,9.975300e-02,& - & 2.547100e-02,2.935100e-02,2.954500e-02,2.876600e-02,2.727600e-02,& - & 2.515000e-02,2.231900e-02,1.833000e-02,1.204400e-02,1.070800e-01,& - & 3.287700e-02,3.791300e-02,3.817200e-02,3.720000e-02,3.534500e-02,& - & 3.264000e-02,2.901000e-02,2.391200e-02,1.575000e-02,1.155100e-01,& - & 4.178300e-02,4.807000e-02,4.847800e-02,4.721100e-02,4.484200e-02,& - & 4.143100e-02,3.682200e-02,3.042600e-02,2.011700e-02,1.249300e-01,& - & 1.296800e-02,1.461300e-02,1.451800e-02,1.396500e-02,1.310800e-02,& - & 1.196500e-02,1.048000e-02,8.466100e-03,5.328100e-03,9.622400e-02,& - & 1.722600e-02,1.960700e-02,1.958900e-02,1.895500e-02,1.787700e-02,& - & 1.639000e-02,1.440100e-02,1.171400e-02,7.642300e-03,1.028100e-01,& - & 2.256100e-02,2.583200e-02,2.588700e-02,2.513000e-02,2.374600e-02,& - & 2.176000e-02,1.918400e-02,1.570100e-02,1.035900e-02,1.104200e-01,& - & 2.920800e-02,3.351700e-02,3.359200e-02,3.256100e-02,3.075100e-02,& - & 2.822100e-02,2.490600e-02,2.046500e-02,1.356400e-02,1.194300e-01,& - & 3.731500e-02,4.278200e-02,4.286300e-02,4.141400e-02,3.908300e-02,& - & 3.586300e-02,3.166100e-02,2.608700e-02,1.734800e-02,1.294100e-01,& - & 1.143100e-02,1.289600e-02,1.273600e-02,1.219900e-02,1.140200e-02,& - & 1.034500e-02,9.000300e-03,7.228700e-03,4.582400e-03,8.051900e-02,& - & 1.520600e-02,1.725800e-02,1.715800e-02,1.653900e-02,1.553100e-02,& - & 1.414000e-02,1.233800e-02,9.983000e-03,6.546400e-03,8.686300e-02,& - & 1.997200e-02,2.277700e-02,2.271300e-02,2.194000e-02,2.063100e-02,& - & 1.877000e-02,1.641500e-02,1.336400e-02,8.869300e-03,9.442000e-02,& - & 2.594700e-02,2.969800e-02,2.963400e-02,2.854200e-02,2.676200e-02,& - & 2.436100e-02,2.133800e-02,1.742400e-02,1.163300e-02,1.032900e-01,& - & 3.334200e-02,3.808200e-02,3.794200e-02,3.648200e-02,3.416800e-02,& - & 3.108000e-02,2.722400e-02,2.226600e-02,1.489600e-02,1.129900e-01/ - data absa(1:300,9) / & - & 3.539900e-01,3.312100e-01,3.248600e-01,3.188000e-01,3.182200e-01,& - & 3.244200e-01,3.358600e-01,3.426900e-01,3.350100e-01,3.368500e-01,& - & 4.265100e-01,4.005500e-01,3.946100e-01,3.889000e-01,3.892000e-01,& - & 3.961300e-01,4.080200e-01,4.144500e-01,4.064000e-01,4.086700e-01,& - & 5.053900e-01,4.763900e-01,4.709000e-01,4.653800e-01,4.672400e-01,& - & 4.747200e-01,4.883000e-01,4.947900e-01,4.877000e-01,4.908300e-01,& - & 5.905800e-01,5.585000e-01,5.537300e-01,5.489900e-01,5.526400e-01,& - & 5.623300e-01,5.791100e-01,5.848600e-01,5.802000e-01,5.841700e-01,& - & 6.814400e-01,6.461800e-01,6.428000e-01,6.402800e-01,6.469300e-01,& - & 6.602600e-01,6.799300e-01,6.860800e-01,6.851900e-01,6.903700e-01,& - & 3.419000e-01,3.232700e-01,3.181900e-01,3.093600e-01,3.038400e-01,& - & 3.026300e-01,3.047200e-01,3.075400e-01,2.990100e-01,2.984400e-01,& - & 4.149300e-01,3.938900e-01,3.889500e-01,3.791300e-01,3.729200e-01,& - & 3.713200e-01,3.729200e-01,3.743600e-01,3.646200e-01,3.637400e-01,& - & 4.952400e-01,4.714400e-01,4.668100e-01,4.555600e-01,4.490100e-01,& - & 4.473000e-01,4.494100e-01,4.498000e-01,4.397500e-01,4.388800e-01,& - & 5.825800e-01,5.562000e-01,5.513000e-01,5.397400e-01,5.328600e-01,& - & 5.322100e-01,5.356100e-01,5.353000e-01,5.264100e-01,5.253200e-01,& - & 6.754900e-01,6.470000e-01,6.419100e-01,6.313400e-01,6.256200e-01,& - & 6.264400e-01,6.314100e-01,6.314800e-01,6.252000e-01,6.242300e-01,& - & 3.132200e-01,2.990500e-01,2.947500e-01,2.871400e-01,2.777700e-01,& - & 2.705600e-01,2.647100e-01,2.616900e-01,2.525100e-01,2.487400e-01,& - & 3.843300e-01,3.685200e-01,3.647800e-01,3.551700e-01,3.441000e-01,& - & 3.355200e-01,3.276300e-01,3.219800e-01,3.106500e-01,3.061900e-01,& - & 4.627900e-01,4.453800e-01,4.424300e-01,4.303600e-01,4.173100e-01,& - & 4.079500e-01,3.981300e-01,3.900800e-01,3.772100e-01,3.726000e-01,& - & 5.492600e-01,5.299600e-01,5.272400e-01,5.132000e-01,4.984000e-01,& - & 4.889400e-01,4.783700e-01,4.678000e-01,4.540100e-01,4.483500e-01,& - & 6.419400e-01,6.215200e-01,6.186200e-01,6.032700e-01,5.876700e-01,& - & 5.786400e-01,5.681800e-01,5.548700e-01,5.417600e-01,5.353300e-01,& - & 2.776800e-01,2.676000e-01,2.657200e-01,2.598000e-01,2.489600e-01,& - & 2.379500e-01,2.258400e-01,2.155300e-01,2.056700e-01,1.999400e-01,& - & 3.462800e-01,3.351800e-01,3.331200e-01,3.257300e-01,3.123800e-01,& - & 2.984800e-01,2.833200e-01,2.693400e-01,2.564100e-01,2.496900e-01,& - & 4.216600e-01,4.101800e-01,4.084600e-01,3.989600e-01,3.828800e-01,& - & 3.661700e-01,3.480400e-01,3.304900e-01,3.148500e-01,3.068800e-01,& - & 5.048000e-01,4.929400e-01,4.918400e-01,4.799500e-01,4.612600e-01,& - & 4.420700e-01,4.216500e-01,4.000000e-01,3.820800e-01,3.726400e-01,& - & 5.951600e-01,5.832600e-01,5.824400e-01,5.685200e-01,5.477400e-01,& - & 5.276000e-01,5.041000e-01,4.779200e-01,4.586000e-01,4.478200e-01,& - & 2.413100e-01,2.350100e-01,2.352000e-01,2.308900e-01,2.218300e-01,& - & 2.072100e-01,1.908700e-01,1.754400e-01,1.640900e-01,1.581700e-01,& - & 3.055300e-01,2.993600e-01,2.995600e-01,2.936800e-01,2.814800e-01,& - & 2.637400e-01,2.431800e-01,2.228100e-01,2.074300e-01,2.001400e-01,& - & 3.770300e-01,3.715700e-01,3.716700e-01,3.641900e-01,3.485900e-01,& - & 3.273900e-01,3.026400e-01,2.768800e-01,2.575500e-01,2.482800e-01,& - & 4.561000e-01,4.513100e-01,4.521300e-01,4.424700e-01,4.238700e-01,& - & 3.988200e-01,3.700800e-01,3.384900e-01,3.153600e-01,3.042600e-01,& - & 5.424700e-01,5.388600e-01,5.402100e-01,5.284000e-01,5.075300e-01,& - & 4.790100e-01,4.456700e-01,4.080900e-01,3.816300e-01,3.688100e-01,& - & 2.029800e-01,2.002500e-01,2.021300e-01,1.998200e-01,1.921200e-01,& - & 1.769100e-01,1.588600e-01,1.406900e-01,1.276300e-01,1.214700e-01,& - & 2.615700e-01,2.597600e-01,2.620900e-01,2.583200e-01,2.479800e-01,& - & 2.287100e-01,2.057700e-01,1.819700e-01,1.641600e-01,1.563400e-01,& - & 3.280100e-01,3.276100e-01,3.302300e-01,3.248400e-01,3.111400e-01,& - & 2.880300e-01,2.596600e-01,2.288500e-01,2.058700e-01,1.964400e-01,& - & 4.020700e-01,4.035100e-01,4.062200e-01,3.990300e-01,3.823400e-01,& - & 3.546500e-01,3.206200e-01,2.828900e-01,2.544000e-01,2.431200e-01,& - & 4.833600e-01,4.869700e-01,4.900300e-01,4.811400e-01,4.618500e-01,& - & 4.292800e-01,3.896600e-01,3.446300e-01,3.104300e-01,2.970600e-01/ - data absa(301:650,9) / & - & 1.668800e-01,1.670200e-01,1.703100e-01,1.692100e-01,1.619900e-01,& - & 1.489700e-01,1.309200e-01,1.113300e-01,9.676000e-02,9.371800e-02,& - & 2.188200e-01,2.208700e-01,2.248600e-01,2.228600e-01,2.133500e-01,& - & 1.961500e-01,1.728500e-01,1.469500e-01,1.269000e-01,1.209600e-01,& - & 2.788800e-01,2.830600e-01,2.877700e-01,2.846900e-01,2.720400e-01,& - & 2.503300e-01,2.212200e-01,1.878600e-01,1.616100e-01,1.529600e-01,& - & 3.468000e-01,3.538500e-01,3.588100e-01,3.542000e-01,3.385400e-01,& - & 3.118800e-01,2.761200e-01,2.352800e-01,2.021500e-01,1.909500e-01,& - & 4.220500e-01,4.321500e-01,4.375900e-01,4.312700e-01,4.127300e-01,& - & 3.811600e-01,3.387900e-01,2.894800e-01,2.488600e-01,2.356000e-01,& - & 1.345900e-01,1.369200e-01,1.408000e-01,1.397100e-01,1.334700e-01,& - & 1.226200e-01,1.066600e-01,8.730500e-02,7.191500e-02,8.003800e-02,& - & 1.796300e-01,1.844200e-01,1.895400e-01,1.880600e-01,1.795100e-01,& - & 1.649700e-01,1.437700e-01,1.175800e-01,9.620600e-02,1.009400e-01,& - & 2.326600e-01,2.403300e-01,2.467200e-01,2.445400e-01,2.329000e-01,& - & 2.142400e-01,1.869500e-01,1.530300e-01,1.245600e-01,1.256800e-01,& - & 2.935500e-01,3.049500e-01,3.121300e-01,3.085200e-01,2.940700e-01,& - & 2.702000e-01,2.365400e-01,1.945100e-01,1.579600e-01,1.551600e-01,& - & 3.618600e-01,3.772500e-01,3.852200e-01,3.799600e-01,3.624200e-01,& - & 3.335500e-01,2.931800e-01,2.422900e-01,1.967700e-01,1.899200e-01,& - & 1.063100e-01,1.099300e-01,1.135500e-01,1.123700e-01,1.070100e-01,& - & 9.820700e-02,8.518200e-02,6.775500e-02,5.233100e-02,1.049200e-01,& - & 1.445400e-01,1.509000e-01,1.559000e-01,1.544400e-01,1.472700e-01,& - & 1.352600e-01,1.175000e-01,9.325900e-02,7.162200e-02,1.246700e-01,& - & 1.901900e-01,2.001100e-01,2.065300e-01,2.046600e-01,1.948600e-01,& - & 1.790400e-01,1.556300e-01,1.236400e-01,9.441500e-02,1.474000e-01,& - & 2.434700e-01,2.577500e-01,2.654900e-01,2.624100e-01,2.498700e-01,& - & 2.294900e-01,1.996900e-01,1.593900e-01,1.213600e-01,1.736900e-01,& - & 3.042200e-01,3.231700e-01,3.320300e-01,3.277700e-01,3.119700e-01,& - & 2.866400e-01,2.505100e-01,2.008400e-01,1.529600e-01,2.039800e-01,& - & 8.435000e-02,8.881500e-02,9.200700e-02,9.071200e-02,8.623500e-02,& - & 7.883400e-02,6.825100e-02,5.349400e-02,3.856900e-02,2.844800e-01,& - & 1.165500e-01,1.239600e-01,1.286400e-01,1.270000e-01,1.209100e-01,& - & 1.107600e-01,9.617500e-02,7.520600e-02,5.374100e-02,3.118300e-01,& - & 1.557500e-01,1.668800e-01,1.730200e-01,1.709600e-01,1.628000e-01,& - & 1.492700e-01,1.296400e-01,1.012800e-01,7.199800e-02,3.403500e-01,& - & 2.019900e-01,2.177100e-01,2.253900e-01,2.223900e-01,2.118200e-01,& - & 1.942600e-01,1.687000e-01,1.322000e-01,9.382000e-02,3.702200e-01,& - & 2.554300e-01,2.760200e-01,2.851200e-01,2.812500e-01,2.677600e-01,& - & 2.455800e-01,2.137900e-01,1.684300e-01,1.196700e-01,4.013300e-01,& - & 7.730500e-02,8.351200e-02,8.655800e-02,8.511500e-02,8.075900e-02,& - & 7.366800e-02,6.372900e-02,4.979800e-02,3.327900e-02,4.233100e-01,& - & 1.067400e-01,1.163100e-01,1.207400e-01,1.189700e-01,1.130600e-01,& - & 1.033800e-01,8.969300e-02,6.994700e-02,4.639200e-02,4.575900e-01,& - & 1.425200e-01,1.563000e-01,1.623000e-01,1.598900e-01,1.521500e-01,& - & 1.393100e-01,1.208200e-01,9.422900e-02,6.220700e-02,4.930100e-01,& - & 1.849500e-01,2.034400e-01,2.111300e-01,2.080100e-01,1.980700e-01,& - & 1.812500e-01,1.573400e-01,1.230300e-01,8.130700e-02,5.301200e-01,& - & 2.341100e-01,2.578300e-01,2.669000e-01,2.630300e-01,2.503500e-01,& - & 2.294400e-01,1.994300e-01,1.565800e-01,1.039700e-01,5.678900e-01,& - & 7.010800e-02,7.742700e-02,8.006300e-02,7.869500e-02,7.441200e-02,& - & 6.779800e-02,5.871000e-02,4.582600e-02,2.870100e-02,4.879300e-01,& - & 9.657200e-02,1.076500e-01,1.115400e-01,1.097600e-01,1.040300e-01,& - & 9.505300e-02,8.241400e-02,6.435500e-02,4.008500e-02,5.248000e-01,& - & 1.289000e-01,1.443600e-01,1.496000e-01,1.473900e-01,1.399200e-01,& - & 1.280100e-01,1.109600e-01,8.664400e-02,5.397500e-02,5.625100e-01,& - & 1.673700e-01,1.877800e-01,1.943000e-01,1.916500e-01,1.820800e-01,& - & 1.665900e-01,1.445000e-01,1.130700e-01,7.069600e-02,6.018300e-01,& - & 2.118600e-01,2.379200e-01,2.458700e-01,2.423300e-01,2.302100e-01,& - & 2.108600e-01,1.832700e-01,1.438600e-01,9.029200e-02,6.416300e-01,& - & 6.275000e-02,7.067800e-02,7.285000e-02,7.135800e-02,6.744100e-02,& - & 6.143300e-02,5.318500e-02,4.150500e-02,2.480600e-02,4.470000e-01,& - & 8.631600e-02,9.814300e-02,1.013400e-01,9.944700e-02,9.421000e-02,& - & 8.601400e-02,7.452600e-02,5.827300e-02,3.474300e-02,4.810300e-01,& - & 1.152900e-01,1.315600e-01,1.357900e-01,1.334600e-01,1.266600e-01,& - & 1.157300e-01,1.003100e-01,7.851100e-02,4.692800e-02,5.160600e-01,& - & 1.497600e-01,1.710400e-01,1.764300e-01,1.735800e-01,1.647300e-01,& - & 1.505800e-01,1.306700e-01,1.024900e-01,6.155100e-02,5.522400e-01,& - & 1.896400e-01,2.165600e-01,2.233900e-01,2.197000e-01,2.085600e-01,& - & 1.907400e-01,1.657500e-01,1.303100e-01,7.838200e-02,5.891300e-01/ - data absa(1:300,10) / & - & 6.186700e-01,5.763000e-01,6.030500e-01,6.945600e-01,7.726100e-01,& - & 8.100500e-01,8.242400e-01,7.848700e-01,7.971600e-01,8.109700e-01,& - & 7.553800e-01,7.070600e-01,7.482500e-01,8.657300e-01,9.513300e-01,& - & 9.949600e-01,1.014400e+00,9.434900e-01,9.751000e-01,9.855700e-01,& - & 9.075300e-01,8.543100e-01,9.095400e-01,1.050400e+00,1.143900e+00,& - & 1.196100e+00,1.213800e+00,1.103800e+00,1.163500e+00,1.172900e+00,& - & 1.071700e+00,1.013400e+00,1.087600e+00,1.247100e+00,1.350500e+00,& - & 1.404900e+00,1.421900e+00,1.291500e+00,1.387800e+00,1.399100e+00,& - & 1.242700e+00,1.182700e+00,1.283300e+00,1.450400e+00,1.563500e+00,& - & 1.629800e+00,1.659700e+00,1.485700e+00,1.641400e+00,1.646000e+00,& - & 6.432100e-01,5.869600e-01,5.823000e-01,6.561900e-01,7.155600e-01,& - & 7.417000e-01,7.607100e-01,7.391200e-01,7.453200e-01,7.585000e-01,& - & 7.898400e-01,7.245300e-01,7.331600e-01,8.257400e-01,8.933900e-01,& - & 9.257800e-01,9.366600e-01,8.917200e-01,9.062700e-01,9.241200e-01,& - & 9.486900e-01,8.731200e-01,8.999200e-01,1.010800e+00,1.090600e+00,& - & 1.122800e+00,1.118400e+00,1.053200e+00,1.081600e+00,1.105000e+00,& - & 1.118200e+00,1.033300e+00,1.081600e+00,1.209900e+00,1.299100e+00,& - & 1.329500e+00,1.318300e+00,1.230500e+00,1.286500e+00,1.310900e+00,& - & 1.295300e+00,1.204600e+00,1.274300e+00,1.419700e+00,1.517900e+00,& - & 1.556500e+00,1.546300e+00,1.406100e+00,1.505000e+00,1.528200e+00,& - & 6.275700e-01,5.747300e-01,5.591400e-01,5.817200e-01,6.288700e-01,& - & 6.501400e-01,6.780200e-01,6.590400e-01,6.593400e-01,6.729500e-01,& - & 7.841800e-01,7.158800e-01,7.060700e-01,7.423800e-01,8.001400e-01,& - & 8.182200e-01,8.401600e-01,8.093600e-01,8.148400e-01,8.280500e-01,& - & 9.601400e-01,8.761200e-01,8.684500e-01,9.223200e-01,9.921400e-01,& - & 9.981000e-01,1.010400e+00,9.730600e-01,9.886900e-01,1.003000e+00,& - & 1.143600e+00,1.050000e+00,1.047300e+00,1.121600e+00,1.199200e+00,& - & 1.190900e+00,1.197900e+00,1.149300e+00,1.184300e+00,1.202800e+00,& - & 1.336300e+00,1.228800e+00,1.240000e+00,1.332800e+00,1.418900e+00,& - & 1.408500e+00,1.405400e+00,1.332600e+00,1.395200e+00,1.419000e+00,& - & 6.090200e-01,5.586500e-01,5.287500e-01,5.179200e-01,5.451800e-01,& - & 5.632500e-01,5.887700e-01,5.838700e-01,5.820600e-01,5.930800e-01,& - & 7.614000e-01,6.991200e-01,6.775700e-01,6.669000e-01,7.032700e-01,& - & 7.230500e-01,7.417200e-01,7.203000e-01,7.206800e-01,7.316100e-01,& - & 9.400200e-01,8.636500e-01,8.436600e-01,8.379500e-01,8.810900e-01,& - & 8.927900e-01,9.065200e-01,8.701800e-01,8.759500e-01,8.877300e-01,& - & 1.136100e+00,1.047100e+00,1.023900e+00,1.029100e+00,1.072900e+00,& - & 1.076900e+00,1.089800e+00,1.037000e+00,1.055400e+00,1.068000e+00,& - & 1.345900e+00,1.241500e+00,1.220000e+00,1.234300e+00,1.281100e+00,& - & 1.281200e+00,1.294100e+00,1.222500e+00,1.259800e+00,1.270200e+00,& - & 5.751500e-01,5.323200e-01,5.039100e-01,4.797800e-01,4.698400e-01,& - & 4.883900e-01,5.158700e-01,5.059000e-01,5.004900e-01,4.951800e-01,& - & 7.312800e-01,6.740600e-01,6.481100e-01,6.204900e-01,6.186800e-01,& - & 6.340100e-01,6.543900e-01,6.348800e-01,6.301500e-01,6.241000e-01,& - & 9.092000e-01,8.375900e-01,8.183500e-01,7.843500e-01,7.848700e-01,& - & 7.969500e-01,8.051600e-01,7.772700e-01,7.750400e-01,7.763600e-01,& - & 1.109900e+00,1.024500e+00,1.007000e+00,9.705200e-01,9.634800e-01,& - & 9.778000e-01,9.764900e-01,9.366000e-01,9.397300e-01,9.445100e-01,& - & 1.330500e+00,1.227200e+00,1.211200e+00,1.173200e+00,1.159400e+00,& - & 1.178400e+00,1.170400e+00,1.111200e+00,1.126300e+00,1.127200e+00,& - & 5.362400e-01,4.996600e-01,4.712400e-01,4.439600e-01,4.130900e-01,& - & 4.179900e-01,4.320400e-01,4.168900e-01,4.079600e-01,4.029600e-01,& - & 6.908600e-01,6.421400e-01,6.147100e-01,5.816800e-01,5.457600e-01,& - & 5.533100e-01,5.610600e-01,5.320700e-01,5.198300e-01,5.138100e-01,& - & 8.678500e-01,8.070000e-01,7.815600e-01,7.416900e-01,7.028100e-01,& - & 7.009000e-01,7.031700e-01,6.688000e-01,6.568500e-01,6.488400e-01,& - & 1.062500e+00,9.915000e-01,9.728400e-01,9.258300e-01,8.759200e-01,& - & 8.686400e-01,8.673300e-01,8.223800e-01,8.124500e-01,8.001100e-01,& - & 1.282300e+00,1.197500e+00,1.185600e+00,1.125500e+00,1.065900e+00,& - & 1.061200e+00,1.049800e+00,9.854600e-01,9.837100e-01,9.675100e-01/ - data absa(301:650,10) / & - & 4.882200e-01,4.543100e-01,4.234600e-01,3.968000e-01,3.741500e-01,& - & 3.507100e-01,3.511800e-01,3.415200e-01,3.311900e-01,3.255800e-01,& - & 6.434100e-01,5.983600e-01,5.656500e-01,5.316700e-01,5.002700e-01,& - & 4.711600e-01,4.635000e-01,4.435300e-01,4.288400e-01,4.249300e-01,& - & 8.215800e-01,7.660600e-01,7.309800e-01,6.863200e-01,6.473200e-01,& - & 6.116700e-01,5.953500e-01,5.654800e-01,5.473900e-01,5.428800e-01,& - & 1.017900e+00,9.515600e-01,9.178500e-01,8.656700e-01,8.140400e-01,& - & 7.726100e-01,7.533200e-01,7.027700e-01,6.816400e-01,6.683400e-01,& - & 1.233200e+00,1.156800e+00,1.127000e+00,1.064300e+00,1.001900e+00,& - & 9.549000e-01,9.276000e-01,8.529300e-01,8.323400e-01,8.126900e-01,& - & 4.269800e-01,3.959100e-01,3.690500e-01,3.524700e-01,3.324700e-01,& - & 3.023300e-01,2.853900e-01,2.761300e-01,2.638000e-01,2.556600e-01,& - & 5.779200e-01,5.359900e-01,5.050400e-01,4.796500e-01,4.545400e-01,& - & 4.104700e-01,3.840100e-01,3.679500e-01,3.502200e-01,3.408500e-01,& - & 7.531200e-01,7.020800e-01,6.643300e-01,6.280700e-01,5.980000e-01,& - & 5.375000e-01,5.023700e-01,4.791600e-01,4.562900e-01,4.435500e-01,& - & 9.492700e-01,8.866900e-01,8.454700e-01,8.019400e-01,7.572500e-01,& - & 6.920500e-01,6.451100e-01,6.002600e-01,5.712700e-01,5.553000e-01,& - & 1.163900e+00,1.091100e+00,1.045400e+00,9.955200e-01,9.408300e-01,& - & 8.680000e-01,8.025800e-01,7.330900e-01,6.998700e-01,6.825100e-01,& - & 3.590000e-01,3.344500e-01,3.173000e-01,3.060900e-01,2.891600e-01,& - & 2.612000e-01,2.336100e-01,2.157600e-01,2.024000e-01,3.162500e-01,& - & 4.987500e-01,4.653000e-01,4.440100e-01,4.278600e-01,4.033600e-01,& - & 3.632600e-01,3.206300e-01,2.958300e-01,2.754900e-01,3.959600e-01,& - & 6.648900e-01,6.219900e-01,5.955800e-01,5.702100e-01,5.387500e-01,& - & 4.835500e-01,4.269200e-01,3.941500e-01,3.663700e-01,4.855300e-01,& - & 8.534000e-01,8.005900e-01,7.683000e-01,7.371000e-01,6.930600e-01,& - & 6.245400e-01,5.569700e-01,5.041900e-01,4.674200e-01,5.773200e-01,& - & 1.064600e+00,1.002800e+00,9.621800e-01,9.218000e-01,8.701200e-01,& - & 7.920200e-01,6.979600e-01,6.271000e-01,5.817400e-01,6.558200e-01,& - & 3.030400e-01,2.839700e-01,2.744000e-01,2.681400e-01,2.511900e-01,& - & 2.286400e-01,1.971200e-01,1.706700e-01,1.543900e-01,6.761600e-01,& - & 4.303900e-01,4.046300e-01,3.913500e-01,3.811600e-01,3.587300e-01,& - & 3.250900e-01,2.775800e-01,2.388100e-01,2.170800e-01,7.404000e-01,& - & 5.830800e-01,5.508900e-01,5.339200e-01,5.188100e-01,4.858800e-01,& - & 4.396900e-01,3.765900e-01,3.247100e-01,2.935700e-01,8.110300e-01,& - & 7.607200e-01,7.209800e-01,6.999000e-01,6.804700e-01,6.330900e-01,& - & 5.738300e-01,4.958900e-01,4.233600e-01,3.800100e-01,8.932800e-01,& - & 9.602700e-01,9.177500e-01,8.892400e-01,8.589300e-01,8.037200e-01,& - & 7.291100e-01,6.305800e-01,5.361000e-01,4.785800e-01,1.002400e+00,& - & 2.995300e-01,2.833100e-01,2.792600e-01,2.732100e-01,2.569800e-01,& - & 2.331800e-01,1.987200e-01,1.586800e-01,1.377900e-01,1.110700e+00,& - & 4.247400e-01,4.040400e-01,3.978100e-01,3.878000e-01,3.643800e-01,& - & 3.308700e-01,2.810300e-01,2.238600e-01,1.943400e-01,1.202900e+00,& - & 5.744200e-01,5.492400e-01,5.396100e-01,5.266700e-01,4.925900e-01,& - & 4.465300e-01,3.824500e-01,3.034100e-01,2.614200e-01,1.291500e+00,& - & 7.481300e-01,7.215900e-01,7.060200e-01,6.875900e-01,6.402900e-01,& - & 5.846200e-01,4.998300e-01,3.964200e-01,3.379500e-01,1.370400e+00,& - & 9.425600e-01,9.158100e-01,8.968400e-01,8.691500e-01,8.127800e-01,& - & 7.380500e-01,6.335300e-01,5.031000e-01,4.264400e-01,1.463800e+00,& - & 2.900200e-01,2.789000e-01,2.804500e-01,2.724400e-01,2.576900e-01,& - & 2.330300e-01,1.972900e-01,1.511900e-01,1.225100e-01,1.412900e+00,& - & 4.102600e-01,3.967900e-01,3.983000e-01,3.865200e-01,3.642000e-01,& - & 3.284700e-01,2.803600e-01,2.137600e-01,1.705800e-01,1.519700e+00,& - & 5.545500e-01,5.403800e-01,5.401100e-01,5.220800e-01,4.910700e-01,& - & 4.444700e-01,3.809000e-01,2.886800e-01,2.275100e-01,1.622500e+00,& - & 7.201400e-01,7.069500e-01,7.063300e-01,6.790300e-01,6.397300e-01,& - & 5.800700e-01,4.957600e-01,3.765600e-01,2.946000e-01,1.713400e+00,& - & 9.094400e-01,8.942300e-01,8.907500e-01,8.594100e-01,8.094600e-01,& - & 7.316100e-01,6.265200e-01,4.788000e-01,3.753200e-01,1.822400e+00,& - & 2.734000e-01,2.707600e-01,2.752600e-01,2.677000e-01,2.517900e-01,& - & 2.267500e-01,1.924500e-01,1.468200e-01,1.061900e-01,1.421000e+00,& - & 3.864100e-01,3.842500e-01,3.893000e-01,3.781600e-01,3.550100e-01,& - & 3.199400e-01,2.735000e-01,2.067100e-01,1.476100e-01,1.525100e+00,& - & 5.208900e-01,5.211300e-01,5.273800e-01,5.097300e-01,4.782700e-01,& - & 4.334600e-01,3.699100e-01,2.784900e-01,1.960800e-01,1.623800e+00,& - & 6.778600e-01,6.793800e-01,6.860800e-01,6.623300e-01,6.242100e-01,& - & 5.641000e-01,4.814000e-01,3.625900e-01,2.547300e-01,1.723000e+00,& - & 8.571100e-01,8.606800e-01,8.647200e-01,8.361700e-01,7.860200e-01,& - & 7.121700e-01,6.076000e-01,4.596600e-01,3.290500e-01,1.834500e+00/ - data absa(1:300,11) / & - & 9.415900e-01,8.691000e-01,9.493900e-01,1.030900e+00,1.097100e+00,& - & 1.159700e+00,1.157300e+00,1.019800e+00,1.125900e+00,1.144400e+00,& - & 1.181600e+00,1.090300e+00,1.168100e+00,1.249100e+00,1.352400e+00,& - & 1.425200e+00,1.401700e+00,1.254800e+00,1.388500e+00,1.416100e+00,& - & 1.445700e+00,1.333800e+00,1.409800e+00,1.494300e+00,1.625700e+00,& - & 1.696600e+00,1.661500e+00,1.514500e+00,1.682300e+00,1.716000e+00,& - & 1.726100e+00,1.593600e+00,1.667600e+00,1.764000e+00,1.903400e+00,& - & 1.981600e+00,1.937500e+00,1.790400e+00,1.991500e+00,2.029000e+00,& - & 2.022200e+00,1.866400e+00,1.940200e+00,2.058800e+00,2.188600e+00,& - & 2.271900e+00,2.217100e+00,2.113000e+00,2.332000e+00,2.386100e+00,& - & 8.841400e-01,8.347000e-01,9.012200e-01,9.819800e-01,1.045000e+00,& - & 1.090200e+00,1.077000e+00,9.485500e-01,1.038600e+00,1.058100e+00,& - & 1.114300e+00,1.055000e+00,1.115100e+00,1.217600e+00,1.303000e+00,& - & 1.343700e+00,1.320700e+00,1.174600e+00,1.302200e+00,1.322900e+00,& - & 1.370500e+00,1.300100e+00,1.355700e+00,1.479700e+00,1.577400e+00,& - & 1.613300e+00,1.589200e+00,1.416700e+00,1.591200e+00,1.609600e+00,& - & 1.652900e+00,1.566700e+00,1.625200e+00,1.760200e+00,1.863800e+00,& - & 1.899500e+00,1.868700e+00,1.678200e+00,1.896700e+00,1.918900e+00,& - & 1.954300e+00,1.849200e+00,1.919800e+00,2.057400e+00,2.158300e+00,& - & 2.194400e+00,2.159400e+00,1.993900e+00,2.247200e+00,2.279100e+00,& - & 8.186900e-01,7.702300e-01,8.210900e-01,8.833600e-01,9.280500e-01,& - & 9.612800e-01,9.485600e-01,8.584300e-01,9.198300e-01,9.474300e-01,& - & 1.038900e+00,9.861500e-01,1.034500e+00,1.125600e+00,1.175200e+00,& - & 1.202000e+00,1.185700e+00,1.060800e+00,1.159900e+00,1.185400e+00,& - & 1.282600e+00,1.225000e+00,1.274700e+00,1.396800e+00,1.438300e+00,& - & 1.467100e+00,1.448700e+00,1.272100e+00,1.417500e+00,1.435000e+00,& - & 1.556400e+00,1.486500e+00,1.544700e+00,1.688100e+00,1.720100e+00,& - & 1.755700e+00,1.722500e+00,1.503500e+00,1.692900e+00,1.710000e+00,& - & 1.853900e+00,1.770400e+00,1.837000e+00,1.988900e+00,2.018300e+00,& - & 2.051100e+00,2.007500e+00,1.781600e+00,2.012600e+00,2.033100e+00,& - & 7.649700e-01,7.107600e-01,7.329500e-01,7.700600e-01,7.964200e-01,& - & 8.248100e-01,8.260800e-01,7.599300e-01,8.077700e-01,8.284800e-01,& - & 9.835200e-01,9.185700e-01,9.461100e-01,1.007300e+00,1.028200e+00,& - & 1.049700e+00,1.046700e+00,9.538900e-01,1.031600e+00,1.051700e+00,& - & 1.229200e+00,1.151200e+00,1.184600e+00,1.270900e+00,1.282400e+00,& - & 1.306500e+00,1.289900e+00,1.157400e+00,1.265000e+00,1.290400e+00,& - & 1.501200e+00,1.409300e+00,1.451000e+00,1.556500e+00,1.563700e+00,& - & 1.587000e+00,1.539900e+00,1.377400e+00,1.518300e+00,1.551800e+00,& - & 1.793400e+00,1.688600e+00,1.743400e+00,1.862000e+00,1.866700e+00,& - & 1.877900e+00,1.805800e+00,1.624300e+00,1.806100e+00,1.847600e+00,& - & 7.454800e-01,6.781400e-01,6.547600e-01,6.594800e-01,6.793400e-01,& - & 7.078800e-01,7.174500e-01,6.735300e-01,7.046100e-01,7.309900e-01,& - & 9.596900e-01,8.782500e-01,8.601700e-01,8.815500e-01,8.923900e-01,& - & 9.167000e-01,9.270800e-01,8.500000e-01,9.072800e-01,9.303200e-01,& - & 1.205800e+00,1.109900e+00,1.096000e+00,1.133000e+00,1.137700e+00,& - & 1.155800e+00,1.156500e+00,1.041600e+00,1.127800e+00,1.147600e+00,& - & 1.481000e+00,1.367100e+00,1.363900e+00,1.409500e+00,1.416200e+00,& - & 1.415900e+00,1.396000e+00,1.253100e+00,1.372600e+00,1.394000e+00,& - & 1.779800e+00,1.647100e+00,1.658400e+00,1.710000e+00,1.717300e+00,& - & 1.689000e+00,1.652500e+00,1.487900e+00,1.647100e+00,1.674800e+00,& - & 7.056500e-01,6.419100e-01,5.917400e-01,5.634400e-01,5.741300e-01,& - & 6.021600e-01,6.173500e-01,5.888200e-01,6.139100e-01,6.253200e-01,& - & 9.237600e-01,8.406400e-01,7.835300e-01,7.620300e-01,7.699500e-01,& - & 7.947000e-01,8.077400e-01,7.571000e-01,7.983600e-01,8.121100e-01,& - & 1.173500e+00,1.069300e+00,1.016300e+00,9.946000e-01,1.000500e+00,& - & 1.022200e+00,1.022100e+00,9.324700e-01,9.963300e-01,1.009600e+00,& - & 1.461100e+00,1.329400e+00,1.278000e+00,1.255800e+00,1.263200e+00,& - & 1.267400e+00,1.252800e+00,1.124400e+00,1.217500e+00,1.233900e+00,& - & 1.776200e+00,1.617100e+00,1.564500e+00,1.546200e+00,1.548300e+00,& - & 1.529900e+00,1.504500e+00,1.338900e+00,1.470200e+00,1.486000e+00/ - data absa(301:650,11) / & - & 6.439700e-01,5.884800e-01,5.416400e-01,5.043800e-01,4.890400e-01,& - & 5.120500e-01,5.288800e-01,4.954700e-01,5.121900e-01,5.135700e-01,& - & 8.601400e-01,7.854100e-01,7.273800e-01,6.810900e-01,6.644700e-01,& - & 6.873500e-01,7.061000e-01,6.488000e-01,6.804400e-01,6.745700e-01,& - & 1.105200e+00,1.008900e+00,9.505300e-01,8.943300e-01,8.783400e-01,& - & 8.963700e-01,9.030700e-01,8.151900e-01,8.648900e-01,8.549500e-01,& - & 1.389400e+00,1.266100e+00,1.211700e+00,1.143600e+00,1.123900e+00,& - & 1.130200e+00,1.115900e+00,1.000900e+00,1.070500e+00,1.068600e+00,& - & 1.711200e+00,1.559800e+00,1.499900e+00,1.425100e+00,1.391500e+00,& - & 1.387400e+00,1.351700e+00,1.205800e+00,1.304900e+00,1.305900e+00,& - & 5.787900e-01,5.327400e-01,4.897300e-01,4.563000e-01,4.326900e-01,& - & 4.328400e-01,4.393000e-01,4.094600e-01,4.186000e-01,4.165500e-01,& - & 7.891300e-01,7.261400e-01,6.715500e-01,6.292700e-01,5.891900e-01,& - & 5.937700e-01,5.984900e-01,5.462900e-01,5.611600e-01,5.552400e-01,& - & 1.031500e+00,9.484800e-01,8.892300e-01,8.318400e-01,7.831200e-01,& - & 7.892200e-01,7.821700e-01,6.952800e-01,7.202700e-01,7.112600e-01,& - & 1.308900e+00,1.203000e+00,1.142100e+00,1.071000e+00,1.018400e+00,& - & 1.007800e+00,9.849400e-01,8.698100e-01,9.105500e-01,9.011700e-01,& - & 1.623300e+00,1.493000e+00,1.433400e+00,1.345900e+00,1.279700e+00,& - & 1.251200e+00,1.215500e+00,1.064700e+00,1.130300e+00,1.114300e+00,& - & 5.087200e-01,4.700000e-01,4.318900e-01,4.070300e-01,3.834700e-01,& - & 3.663700e-01,3.572200e-01,3.332200e-01,3.351900e-01,4.962900e-01,& - & 7.103200e-01,6.567000e-01,6.079600e-01,5.726400e-01,5.366100e-01,& - & 5.068900e-01,4.959900e-01,4.558100e-01,4.590100e-01,6.150400e-01,& - & 9.472500e-01,8.749200e-01,8.205200e-01,7.721900e-01,7.222000e-01,& - & 6.837900e-01,6.583900e-01,5.935200e-01,5.985300e-01,7.136300e-01,& - & 1.221200e+00,1.128500e+00,1.068000e+00,1.002900e+00,9.420800e-01,& - & 8.907200e-01,8.457700e-01,7.555700e-01,7.652700e-01,8.052200e-01,& - & 1.526300e+00,1.412600e+00,1.349900e+00,1.271800e+00,1.192100e+00,& - & 1.122000e+00,1.068500e+00,9.321300e-01,9.577500e-01,9.430300e-01,& - & 4.483400e-01,4.159600e-01,3.851900e-01,3.673800e-01,3.470700e-01,& - & 3.166700e-01,2.993500e-01,2.730800e-01,2.699300e-01,8.620200e-01,& - & 6.401800e-01,5.947600e-01,5.545200e-01,5.274200e-01,4.944400e-01,& - & 4.503900e-01,4.188500e-01,3.823500e-01,3.760600e-01,1.005000e+00,& - & 8.694100e-01,8.071900e-01,7.612800e-01,7.208300e-01,6.777800e-01,& - & 6.113200e-01,5.648500e-01,5.097700e-01,5.005200e-01,1.187900e+00,& - & 1.137400e+00,1.057800e+00,1.004800e+00,9.466900e-01,8.948500e-01,& - & 8.026200e-01,7.373000e-01,6.623100e-01,6.521000e-01,1.392600e+00,& - & 1.437900e+00,1.339800e+00,1.280000e+00,1.209900e+00,1.136900e+00,& - & 1.029000e+00,9.423900e-01,8.262100e-01,8.203300e-01,1.598700e+00,& - & 4.643700e-01,4.319500e-01,4.064000e-01,3.908300e-01,3.675900e-01,& - & 3.309500e-01,2.962100e-01,2.605900e-01,2.489800e-01,1.442400e+00,& - & 6.599500e-01,6.150400e-01,5.835400e-01,5.610900e-01,5.244800e-01,& - & 4.707600e-01,4.151000e-01,3.634500e-01,3.457100e-01,1.567900e+00,& - & 8.962700e-01,8.372600e-01,7.981000e-01,7.631300e-01,7.156100e-01,& - & 6.392600e-01,5.580400e-01,4.895900e-01,4.656500e-01,1.709300e+00,& - & 1.169500e+00,1.094900e+00,1.049400e+00,9.997900e-01,9.379200e-01,& - & 8.338400e-01,7.330400e-01,6.361100e-01,6.064800e-01,1.868700e+00,& - & 1.475600e+00,1.386500e+00,1.330600e+00,1.270000e+00,1.186000e+00,& - & 1.064800e+00,9.331000e-01,7.979600e-01,7.611400e-01,2.043300e+00,& - & 4.688300e-01,4.399200e-01,4.236300e-01,4.099100e-01,3.826700e-01,& - & 3.454800e-01,2.954900e-01,2.460600e-01,2.240600e-01,1.916100e+00,& - & 6.661900e-01,6.264300e-01,6.039400e-01,5.841600e-01,5.462100e-01,& - & 4.902000e-01,4.156800e-01,3.441600e-01,3.149900e-01,2.054100e+00,& - & 9.024700e-01,8.518200e-01,8.232800e-01,7.936200e-01,7.405700e-01,& - & 6.624900e-01,5.616700e-01,4.662100e-01,4.257600e-01,2.200500e+00,& - & 1.175400e+00,1.114100e+00,1.076300e+00,1.039300e+00,9.631400e-01,& - & 8.634900e-01,7.373300e-01,6.055500e-01,5.510800e-01,2.350600e+00,& - & 1.481600e+00,1.411800e+00,1.363000e+00,1.310900e+00,1.217400e+00,& - & 1.094500e+00,9.347000e-01,7.632700e-01,6.945800e-01,2.481700e+00,& - & 4.658100e-01,4.390700e-01,4.312500e-01,4.201200e-01,3.914200e-01,& - & 3.528800e-01,2.976400e-01,2.316500e-01,2.002200e-01,2.003800e+00,& - & 6.601400e-01,6.252500e-01,6.136300e-01,5.955600e-01,5.556500e-01,& - & 4.995800e-01,4.198900e-01,3.260300e-01,2.820400e-01,2.150600e+00,& - & 8.916200e-01,8.486600e-01,8.323100e-01,8.074700e-01,7.501000e-01,& - & 6.728700e-01,5.695200e-01,4.403200e-01,3.794400e-01,2.296300e+00,& - & 1.158200e+00,1.110500e+00,1.086500e+00,1.052600e+00,9.732000e-01,& - & 8.768800e-01,7.416900e-01,5.725400e-01,4.909000e-01,2.426400e+00,& - & 1.455700e+00,1.405400e+00,1.375600e+00,1.324100e+00,1.228300e+00,& - & 1.103700e+00,9.358000e-01,7.234200e-01,6.192400e-01,2.552600e+00/ - data absa(1:300,12) / & - & 1.989900e+00,1.741600e+00,1.655700e+00,1.662600e+00,1.629200e+00,& - & 1.618600e+00,1.551600e+00,1.511100e+00,1.651500e+00,1.699900e+00,& - & 2.416700e+00,2.115000e+00,2.028500e+00,2.015400e+00,1.944600e+00,& - & 1.937800e+00,1.891200e+00,1.872700e+00,2.057200e+00,2.113700e+00,& - & 2.867800e+00,2.509800e+00,2.425100e+00,2.384000e+00,2.289800e+00,& - & 2.292500e+00,2.226200e+00,2.252800e+00,2.474800e+00,2.540200e+00,& - & 3.333400e+00,2.917200e+00,2.834000e+00,2.763300e+00,2.674700e+00,& - & 2.679900e+00,2.551100e+00,2.657500e+00,2.917100e+00,2.995100e+00,& - & 3.807000e+00,3.331700e+00,3.243100e+00,3.143400e+00,3.084400e+00,& - & 3.076700e+00,2.887100e+00,3.085100e+00,3.376800e+00,3.470000e+00,& - & 1.802000e+00,1.577100e+00,1.565800e+00,1.552900e+00,1.567800e+00,& - & 1.560900e+00,1.506800e+00,1.432200e+00,1.579400e+00,1.626500e+00,& - & 2.224400e+00,1.946700e+00,1.937600e+00,1.887800e+00,1.890700e+00,& - & 1.915600e+00,1.845100e+00,1.780600e+00,1.977500e+00,2.024800e+00,& - & 2.677700e+00,2.343300e+00,2.327900e+00,2.246600e+00,2.243400e+00,& - & 2.306100e+00,2.173100e+00,2.160100e+00,2.397100e+00,2.454400e+00,& - & 3.154400e+00,2.760500e+00,2.732600e+00,2.632000e+00,2.634200e+00,& - & 2.705900e+00,2.508200e+00,2.577000e+00,2.849800e+00,2.923300e+00,& - & 3.640800e+00,3.186400e+00,3.139200e+00,3.032100e+00,3.054000e+00,& - & 3.095000e+00,2.850900e+00,3.020200e+00,3.335000e+00,3.427300e+00,& - & 1.564900e+00,1.373200e+00,1.382600e+00,1.402000e+00,1.431800e+00,& - & 1.426600e+00,1.367600e+00,1.262100e+00,1.411300e+00,1.441100e+00,& - & 1.975000e+00,1.732300e+00,1.734800e+00,1.721200e+00,1.770400e+00,& - & 1.792500e+00,1.694900e+00,1.596000e+00,1.783200e+00,1.820900e+00,& - & 2.422200e+00,2.125600e+00,2.115700e+00,2.068800e+00,2.146400e+00,& - & 2.185200e+00,2.023900e+00,1.972600e+00,2.195800e+00,2.249800e+00,& - & 2.900000e+00,2.548100e+00,2.520600e+00,2.450000e+00,2.554800e+00,& - & 2.585300e+00,2.367500e+00,2.389100e+00,2.653600e+00,2.723800e+00,& - & 3.393100e+00,2.986500e+00,2.939600e+00,2.862400e+00,2.974100e+00,& - & 2.994900e+00,2.716600e+00,2.825200e+00,3.147700e+00,3.222500e+00,& - & 1.328000e+00,1.178600e+00,1.200300e+00,1.238400e+00,1.262100e+00,& - & 1.262300e+00,1.207400e+00,1.095400e+00,1.217800e+00,1.251900e+00,& - & 1.721400e+00,1.530300e+00,1.529600e+00,1.558100e+00,1.604500e+00,& - & 1.616000e+00,1.519100e+00,1.400400e+00,1.559900e+00,1.599500e+00,& - & 2.153100e+00,1.918400e+00,1.896000e+00,1.907300e+00,1.990900e+00,& - & 1.995600e+00,1.846600e+00,1.752900e+00,1.959700e+00,2.002000e+00,& - & 2.625900e+00,2.342100e+00,2.300600e+00,2.291100e+00,2.409800e+00,& - & 2.386200e+00,2.205900e+00,2.147700e+00,2.408300e+00,2.453300e+00,& - & 3.131200e+00,2.795100e+00,2.728900e+00,2.709800e+00,2.844000e+00,& - & 2.795500e+00,2.567400e+00,2.571800e+00,2.886200e+00,2.937500e+00,& - & 1.116100e+00,1.007300e+00,1.047500e+00,1.070400e+00,1.092400e+00,& - & 1.096500e+00,1.051600e+00,9.488100e-01,1.056800e+00,1.085100e+00,& - & 1.485200e+00,1.343900e+00,1.360700e+00,1.389200e+00,1.428800e+00,& - & 1.430800e+00,1.342100e+00,1.229700e+00,1.369600e+00,1.406100e+00,& - & 1.907200e+00,1.726600e+00,1.713600e+00,1.749500e+00,1.811300e+00,& - & 1.790300e+00,1.662500e+00,1.556100e+00,1.735400e+00,1.778600e+00,& - & 2.375400e+00,2.154300e+00,2.102400e+00,2.151200e+00,2.223700e+00,& - & 2.173500e+00,2.017500e+00,1.917600e+00,2.150400e+00,2.191300e+00,& - & 2.876600e+00,2.615400e+00,2.526400e+00,2.589600e+00,2.649300e+00,& - & 2.588600e+00,2.377600e+00,2.303700e+00,2.596900e+00,2.631600e+00,& - & 9.498500e-01,8.593300e-01,8.889800e-01,9.023200e-01,9.235400e-01,& - & 9.306600e-01,9.048600e-01,8.173900e-01,9.070600e-01,9.353200e-01,& - & 1.283400e+00,1.169000e+00,1.190800e+00,1.208600e+00,1.241500e+00,& - & 1.236800e+00,1.175600e+00,1.074200e+00,1.192800e+00,1.228800e+00,& - & 1.679900e+00,1.537800e+00,1.535800e+00,1.567300e+00,1.603500e+00,& - & 1.572600e+00,1.479500e+00,1.379800e+00,1.531500e+00,1.577600e+00,& - & 2.123800e+00,1.952900e+00,1.923500e+00,1.975800e+00,1.997000e+00,& - & 1.949600e+00,1.819000e+00,1.709200e+00,1.913700e+00,1.953600e+00,& - & 2.609500e+00,2.408400e+00,2.350900e+00,2.422800e+00,2.418000e+00,& - & 2.361800e+00,2.159700e+00,2.067500e+00,2.321400e+00,2.361800e+00/ - data absa(301:650,12) / & - & 8.481200e-01,7.684100e-01,7.532600e-01,7.503500e-01,7.711800e-01,& - & 7.887200e-01,7.718300e-01,7.058500e-01,7.794600e-01,8.079500e-01,& - & 1.146500e+00,1.044500e+00,1.029000e+00,1.037000e+00,1.059800e+00,& - & 1.068300e+00,1.024200e+00,9.396300e-01,1.038600e+00,1.075400e+00,& - & 1.519300e+00,1.389400e+00,1.364900e+00,1.385300e+00,1.398200e+00,& - & 1.381300e+00,1.317800e+00,1.217300e+00,1.350900e+00,1.391400e+00,& - & 1.951800e+00,1.788400e+00,1.751300e+00,1.786500e+00,1.777100e+00,& - & 1.737000e+00,1.644600e+00,1.522200e+00,1.706300e+00,1.739100e+00,& - & 2.425900e+00,2.227900e+00,2.179400e+00,2.229000e+00,2.196200e+00,& - & 2.129900e+00,1.978800e+00,1.858500e+00,2.085700e+00,2.122500e+00,& - & 7.784100e-01,7.071100e-01,6.652200e-01,6.360600e-01,6.476000e-01,& - & 6.671300e-01,6.614800e-01,6.039000e-01,6.697300e-01,6.884300e-01,& - & 1.065800e+00,9.663600e-01,9.158300e-01,8.869900e-01,9.084800e-01,& - & 9.196500e-01,8.937200e-01,8.195500e-01,9.114100e-01,9.349700e-01,& - & 1.413700e+00,1.283600e+00,1.230700e+00,1.211500e+00,1.223200e+00,& - & 1.211600e+00,1.165900e+00,1.073200e+00,1.196900e+00,1.225900e+00,& - & 1.833000e+00,1.667000e+00,1.604700e+00,1.595600e+00,1.581100e+00,& - & 1.551500e+00,1.475200e+00,1.350700e+00,1.518600e+00,1.542500e+00,& - & 2.304900e+00,2.103600e+00,2.027800e+00,2.022000e+00,1.985500e+00,& - & 1.930800e+00,1.801900e+00,1.660500e+00,1.870500e+00,1.896300e+00,& - & 7.091200e-01,6.446900e-01,5.936300e-01,5.562700e-01,5.538400e-01,& - & 5.618600e-01,5.592700e-01,5.035400e-01,5.612500e-01,7.496900e-01,& - & 9.952700e-01,9.055000e-01,8.344200e-01,7.826400e-01,7.775200e-01,& - & 7.896900e-01,7.769200e-01,6.935400e-01,7.779300e-01,8.704300e-01,& - & 1.341200e+00,1.219000e+00,1.126800e+00,1.074300e+00,1.060600e+00,& - & 1.061400e+00,1.035000e+00,9.223700e-01,1.040900e+00,1.057300e+00,& - & 1.749300e+00,1.587400e+00,1.486300e+00,1.431000e+00,1.398600e+00,& - & 1.384300e+00,1.325400e+00,1.177100e+00,1.337400e+00,1.337100e+00,& - & 2.217600e+00,2.012700e+00,1.912600e+00,1.837100e+00,1.790300e+00,& - & 1.750400e+00,1.635800e+00,1.463000e+00,1.660000e+00,1.667900e+00,& - & 6.537600e-01,5.964900e-01,5.438200e-01,5.039200e-01,4.922200e-01,& - & 4.909400e-01,4.767200e-01,4.196600e-01,4.692100e-01,1.376900e+00,& - & 9.380000e-01,8.567000e-01,7.836700e-01,7.259500e-01,6.980500e-01,& - & 6.953300e-01,6.761900e-01,5.913200e-01,6.616000e-01,1.670600e+00,& - & 1.285400e+00,1.174100e+00,1.077400e+00,1.000800e+00,9.566800e-01,& - & 9.516500e-01,9.165600e-01,7.922400e-01,8.951000e-01,1.978500e+00,& - & 1.692100e+00,1.544800e+00,1.430100e+00,1.336100e+00,1.273500e+00,& - & 1.258700e+00,1.195700e+00,1.018100e+00,1.160900e+00,2.289400e+00,& - & 2.157600e+00,1.966400e+00,1.849400e+00,1.730000e+00,1.650900e+00,& - & 1.607000e+00,1.497300e+00,1.281600e+00,1.464800e+00,2.606700e+00,& - & 7.095200e-01,6.505300e-01,5.931600e-01,5.514600e-01,5.218000e-01,& - & 5.065200e-01,4.771800e-01,4.124600e-01,4.578300e-01,2.024100e+00,& - & 1.016700e+00,9.326200e-01,8.533300e-01,7.923200e-01,7.449900e-01,& - & 7.114000e-01,6.746500e-01,5.785900e-01,6.461300e-01,2.291200e+00,& - & 1.388600e+00,1.273200e+00,1.173600e+00,1.090600e+00,1.013900e+00,& - & 9.703400e-01,9.124000e-01,7.704900e-01,8.637600e-01,2.646300e+00,& - & 1.818100e+00,1.668000e+00,1.554900e+00,1.441700e+00,1.342500e+00,& - & 1.283000e+00,1.183600e+00,9.885700e-01,1.112900e+00,3.026300e+00,& - & 2.305700e+00,2.114600e+00,1.995000e+00,1.850800e+00,1.728900e+00,& - & 1.630700e+00,1.491900e+00,1.245500e+00,1.408500e+00,3.418600e+00,& - & 7.588600e-01,6.979600e-01,6.385200e-01,5.992900e-01,5.599000e-01,& - & 5.192400e-01,4.784000e-01,4.034100e-01,4.415400e-01,2.608700e+00,& - & 1.085100e+00,9.977000e-01,9.167300e-01,8.589900e-01,7.980900e-01,& - & 7.328700e-01,6.714800e-01,5.635000e-01,6.161200e-01,2.831000e+00,& - & 1.475500e+00,1.357300e+00,1.257900e+00,1.177400e+00,1.088600e+00,& - & 9.948400e-01,9.035400e-01,7.500700e-01,8.221400e-01,3.138800e+00,& - & 1.925300e+00,1.771100e+00,1.660400e+00,1.547100e+00,1.433600e+00,& - & 1.305100e+00,1.169800e+00,9.714000e-01,1.065100e+00,3.485000e+00,& - & 2.430800e+00,2.239600e+00,2.116700e+00,1.972900e+00,1.827200e+00,& - & 1.658500e+00,1.480900e+00,1.217700e+00,1.344800e+00,3.882500e+00,& - & 7.922900e-01,7.322100e-01,6.773700e-01,6.413000e-01,5.984700e-01,& - & 5.358000e-01,4.772800e-01,3.900300e-01,4.140000e-01,2.763800e+00,& - & 1.129700e+00,1.045000e+00,9.714000e-01,9.161800e-01,8.513800e-01,& - & 7.600600e-01,6.661900e-01,5.438300e-01,5.763800e-01,2.970300e+00,& - & 1.531000e+00,1.416900e+00,1.328000e+00,1.247000e+00,1.158400e+00,& - & 1.027200e+00,8.929500e-01,7.300700e-01,7.720800e-01,3.218000e+00,& - & 1.993900e+00,1.845700e+00,1.741600e+00,1.631500e+00,1.516900e+00,& - & 1.336000e+00,1.163400e+00,9.490000e-01,1.005800e+00,3.528800e+00,& - & 2.507900e+00,2.328700e+00,2.204300e+00,2.069100e+00,1.916200e+00,& - & 1.696700e+00,1.473200e+00,1.190300e+00,1.264100e+00,3.860300e+00/ - data absa(1:300,13) / & - & 3.964900e+00,3.469600e+00,2.974200e+00,2.689300e+00,2.581400e+00,& - & 2.253900e+00,1.959100e+00,2.195300e+00,2.358500e+00,2.443500e+00,& - & 4.693400e+00,4.107000e+00,3.520600e+00,3.242500e+00,3.076200e+00,& - & 2.667000e+00,2.321300e+00,2.657700e+00,2.828100e+00,2.939100e+00,& - & 5.430900e+00,4.752400e+00,4.073800e+00,3.821100e+00,3.569900e+00,& - & 3.101300e+00,2.744600e+00,3.184800e+00,3.384100e+00,3.520500e+00,& - & 6.170800e+00,5.399700e+00,4.633100e+00,4.411000e+00,4.065000e+00,& - & 3.550600e+00,3.265300e+00,3.793900e+00,4.034900e+00,4.194600e+00,& - & 6.887900e+00,6.027300e+00,5.187300e+00,4.982100e+00,4.555900e+00,& - & 4.007800e+00,3.843300e+00,4.468800e+00,4.772400e+00,4.954400e+00,& - & 3.669800e+00,3.211300e+00,2.763400e+00,2.622000e+00,2.449800e+00,& - & 2.217700e+00,1.931700e+00,2.175900e+00,2.356600e+00,2.453900e+00,& - & 4.392200e+00,3.843300e+00,3.317400e+00,3.196200e+00,2.940200e+00,& - & 2.630300e+00,2.349600e+00,2.706400e+00,2.899500e+00,3.042100e+00,& - & 5.131500e+00,4.490300e+00,3.896000e+00,3.780400e+00,3.447500e+00,& - & 3.057500e+00,2.847800e+00,3.307500e+00,3.515400e+00,3.710100e+00,& - & 5.880000e+00,5.145300e+00,4.492400e+00,4.364600e+00,3.964200e+00,& - & 3.520800e+00,3.389100e+00,3.939900e+00,4.195400e+00,4.421400e+00,& - & 6.610100e+00,5.784100e+00,5.087200e+00,4.934800e+00,4.477700e+00,& - & 4.045800e+00,3.971300e+00,4.616000e+00,4.939300e+00,5.187000e+00,& - & 3.241100e+00,2.836100e+00,2.483100e+00,2.407000e+00,2.248000e+00,& - & 2.087000e+00,1.805100e+00,2.020200e+00,2.199400e+00,2.300200e+00,& - & 3.947000e+00,3.453800e+00,3.048300e+00,2.966700e+00,2.718100e+00,& - & 2.514800e+00,2.250100e+00,2.576500e+00,2.783700e+00,2.931300e+00,& - & 4.680400e+00,4.095500e+00,3.645900e+00,3.539900e+00,3.216300e+00,& - & 2.963900e+00,2.771500e+00,3.208800e+00,3.455700e+00,3.650700e+00,& - & 5.431200e+00,4.752500e+00,4.267500e+00,4.120600e+00,3.736400e+00,& - & 3.456200e+00,3.339900e+00,3.884400e+00,4.192000e+00,4.420200e+00,& - & 6.179600e+00,5.407400e+00,4.899000e+00,4.701300e+00,4.291500e+00,& - & 3.975700e+00,3.940700e+00,4.582800e+00,4.941000e+00,5.212300e+00,& - & 2.792900e+00,2.443900e+00,2.193900e+00,2.145400e+00,2.051500e+00,& - & 1.887700e+00,1.638300e+00,1.804500e+00,1.974000e+00,2.062800e+00,& - & 3.479300e+00,3.044500e+00,2.759800e+00,2.670500e+00,2.512100e+00,& - & 2.326600e+00,2.090100e+00,2.362000e+00,2.568900e+00,2.699800e+00,& - & 4.201000e+00,3.676100e+00,3.366000e+00,3.227800e+00,3.002700e+00,& - & 2.808600e+00,2.602800e+00,2.985500e+00,3.257400e+00,3.412400e+00,& - & 4.951900e+00,4.333100e+00,4.006600e+00,3.813700e+00,3.526900e+00,& - & 3.345300e+00,3.163500e+00,3.667000e+00,4.007000e+00,4.190300e+00,& - & 5.712800e+00,4.998900e+00,4.667200e+00,4.409200e+00,4.081700e+00,& - & 3.879100e+00,3.769800e+00,4.388200e+00,4.806500e+00,5.015000e+00,& - & 2.383200e+00,2.085400e+00,1.920600e+00,1.910200e+00,1.837700e+00,& - & 1.680400e+00,1.458100e+00,1.582000e+00,1.738500e+00,1.810400e+00,& - & 3.040800e+00,2.660800e+00,2.478500e+00,2.405400e+00,2.302500e+00,& - & 2.123400e+00,1.894700e+00,2.114200e+00,2.321300e+00,2.419200e+00,& - & 3.747200e+00,3.278900e+00,3.088800e+00,2.939500e+00,2.803600e+00,& - & 2.628200e+00,2.390600e+00,2.715300e+00,2.992600e+00,3.105900e+00,& - & 4.491500e+00,3.930200e+00,3.739300e+00,3.509000e+00,3.337500e+00,& - & 3.175900e+00,2.935400e+00,3.382700e+00,3.735200e+00,3.869000e+00,& - & 5.266300e+00,4.608100e+00,4.407700e+00,4.100600e+00,3.918000e+00,& - & 3.709000e+00,3.530700e+00,4.107600e+00,4.533800e+00,4.698600e+00,& - & 1.993200e+00,1.745000e+00,1.666300e+00,1.674700e+00,1.587500e+00,& - & 1.457700e+00,1.265300e+00,1.349900e+00,1.481700e+00,1.546500e+00,& - & 2.612600e+00,2.287700e+00,2.190600e+00,2.146500e+00,2.044000e+00,& - & 1.894800e+00,1.675100e+00,1.829500e+00,2.025300e+00,2.093900e+00,& - & 3.303500e+00,2.892200e+00,2.779600e+00,2.667100e+00,2.556400e+00,& - & 2.398200e+00,2.143300e+00,2.387600e+00,2.656300e+00,2.731100e+00,& - & 4.048000e+00,3.544100e+00,3.409400e+00,3.225300e+00,3.119600e+00,& - & 2.934600e+00,2.653600e+00,3.026600e+00,3.371000e+00,3.461600e+00,& - & 4.834200e+00,4.233800e+00,4.069600e+00,3.823000e+00,3.739600e+00,& - & 3.459400e+00,3.230900e+00,3.733900e+00,4.160000e+00,4.269600e+00/ - data absa(301:650,13) / & - & 1.646800e+00,1.446900e+00,1.437500e+00,1.432100e+00,1.347400e+00,& - & 1.242400e+00,1.089200e+00,1.151000e+00,1.262600e+00,1.318300e+00,& - & 2.229100e+00,1.958200e+00,1.927000e+00,1.894600e+00,1.789900e+00,& - & 1.661300e+00,1.463800e+00,1.584400e+00,1.748600e+00,1.814300e+00,& - & 2.893700e+00,2.545200e+00,2.476000e+00,2.409500e+00,2.297700e+00,& - & 2.147500e+00,1.892100e+00,2.092000e+00,2.324000e+00,2.394100e+00,& - & 3.631900e+00,3.201800e+00,3.080700e+00,2.973600e+00,2.872100e+00,& - & 2.669900e+00,2.368900e+00,2.676700e+00,2.981800e+00,3.062100e+00,& - & 4.429400e+00,3.912400e+00,3.736300e+00,3.582600e+00,3.503100e+00,& - & 3.193600e+00,2.916200e+00,3.334600e+00,3.729500e+00,3.813900e+00,& - & 1.364500e+00,1.203000e+00,1.225100e+00,1.198000e+00,1.126700e+00,& - & 1.049600e+00,9.400700e-01,9.873800e-01,1.079500e+00,1.132100e+00,& - & 1.887500e+00,1.671600e+00,1.678700e+00,1.635700e+00,1.549100e+00,& - & 1.442000e+00,1.284400e+00,1.370900e+00,1.511200e+00,1.570800e+00,& - & 2.523500e+00,2.240500e+00,2.201800e+00,2.138300e+00,2.041800e+00,& - & 1.903400e+00,1.679700e+00,1.830900e+00,2.036900e+00,2.095600e+00,& - & 3.246000e+00,2.889000e+00,2.798900e+00,2.708900e+00,2.611300e+00,& - & 2.407000e+00,2.124300e+00,2.372700e+00,2.644300e+00,2.714100e+00,& - & 4.041500e+00,3.601500e+00,3.454900e+00,3.342700e+00,3.230000e+00,& - & 2.932100e+00,2.635400e+00,2.988800e+00,3.339000e+00,3.418600e+00,& - & 1.154300e+00,1.025100e+00,1.034900e+00,9.879400e-01,9.320500e-01,& - & 8.844000e-01,8.032000e-01,8.451900e-01,9.271100e-01,1.020600e+00,& - & 1.610800e+00,1.431000e+00,1.447600e+00,1.388500e+00,1.323500e+00,& - & 1.249200e+00,1.116900e+00,1.195800e+00,1.314100e+00,1.370500e+00,& - & 2.188500e+00,1.953200e+00,1.955000e+00,1.874100e+00,1.793200e+00,& - & 1.681900e+00,1.484300e+00,1.610600e+00,1.780100e+00,1.844700e+00,& - & 2.881100e+00,2.583000e+00,2.535700e+00,2.443600e+00,2.344700e+00,& - & 2.161300e+00,1.904300e+00,2.100500e+00,2.333900e+00,2.405700e+00,& - & 3.676400e+00,3.307900e+00,3.179600e+00,3.091100e+00,2.953900e+00,& - & 2.675700e+00,2.387400e+00,2.674100e+00,2.982000e+00,3.061100e+00,& - & 1.030200e+00,9.217600e-01,9.057400e-01,8.461500e-01,7.997000e-01,& - & 7.697600e-01,7.027400e-01,7.428300e-01,8.156500e-01,2.701700e+00,& - & 1.445800e+00,1.291800e+00,1.272600e+00,1.204100e+00,1.154600e+00,& - & 1.105200e+00,9.953500e-01,1.058400e+00,1.169100e+00,2.933600e+00,& - & 1.985600e+00,1.778700e+00,1.742700e+00,1.669100e+00,1.601600e+00,& - & 1.513700e+00,1.340700e+00,1.447100e+00,1.606000e+00,3.215400e+00,& - & 2.649300e+00,2.382000e+00,2.310300e+00,2.228400e+00,2.131600e+00,& - & 1.976900e+00,1.743500e+00,1.914300e+00,2.124800e+00,3.463300e+00,& - & 3.428100e+00,3.094600e+00,2.964500e+00,2.874800e+00,2.724500e+00,& - & 2.487900e+00,2.210300e+00,2.455100e+00,2.730700e+00,3.600000e+00,& - & 1.098700e+00,9.888300e-01,9.445700e-01,8.759900e-01,8.357000e-01,& - & 8.017400e-01,7.290800e-01,7.640000e-01,8.504000e-01,4.164400e+00,& - & 1.551900e+00,1.396000e+00,1.327200e+00,1.241900e+00,1.193600e+00,& - & 1.147500e+00,1.032300e+00,1.090400e+00,1.211800e+00,4.437700e+00,& - & 2.116800e+00,1.906200e+00,1.815600e+00,1.715100e+00,1.655400e+00,& - & 1.561200e+00,1.390000e+00,1.482300e+00,1.650400e+00,4.764800e+00,& - & 2.810900e+00,2.537200e+00,2.406500e+00,2.297700e+00,2.198400e+00,& - & 2.033800e+00,1.805700e+00,1.949100e+00,2.179200e+00,5.136700e+00,& - & 3.620000e+00,3.275700e+00,3.097300e+00,2.972500e+00,2.804900e+00,& - & 2.572600e+00,2.273100e+00,2.475900e+00,2.785700e+00,5.393100e+00,& - & 1.183400e+00,1.071800e+00,9.983200e-01,9.195100e-01,8.806600e-01,& - & 8.398400e-01,7.551600e-01,7.762900e-01,8.692400e-01,5.019600e+00,& - & 1.681700e+00,1.521000e+00,1.412500e+00,1.304100e+00,1.246800e+00,& - & 1.191000e+00,1.064400e+00,1.099100e+00,1.238400e+00,5.325300e+00,& - & 2.288400e+00,2.069700e+00,1.923700e+00,1.792600e+00,1.710500e+00,& - & 1.614100e+00,1.435600e+00,1.490300e+00,1.682700e+00,5.693400e+00,& - & 3.015300e+00,2.727500e+00,2.544900e+00,2.391100e+00,2.257800e+00,& - & 2.105800e+00,1.868600e+00,1.945300e+00,2.202600e+00,6.112300e+00,& - & 3.852100e+00,3.485200e+00,3.264600e+00,3.081400e+00,2.880000e+00,& - & 2.661300e+00,2.337700e+00,2.457600e+00,2.786600e+00,6.428200e+00,& - & 1.285200e+00,1.164600e+00,1.064200e+00,9.755600e-01,9.242000e-01,& - & 8.762000e-01,7.719600e-01,7.714600e-01,8.763000e-01,4.855600e+00,& - & 1.830100e+00,1.658900e+00,1.515200e+00,1.389300e+00,1.305500e+00,& - & 1.232300e+00,1.089500e+00,1.087500e+00,1.237200e+00,5.176200e+00,& - & 2.488900e+00,2.255800e+00,2.061300e+00,1.903400e+00,1.777400e+00,& - & 1.669200e+00,1.471700e+00,1.465700e+00,1.674300e+00,5.598400e+00,& - & 3.257000e+00,2.949300e+00,2.712700e+00,2.517500e+00,2.337100e+00,& - & 2.180000e+00,1.909900e+00,1.904100e+00,2.179500e+00,5.998900e+00,& - & 4.132600e+00,3.738200e+00,3.472600e+00,3.217200e+00,2.981100e+00,& - & 2.743300e+00,2.397700e+00,2.406000e+00,2.751900e+00,6.321800e+00/ - data absa(1:300,14) / & - & 6.346700e+00,5.553600e+00,4.760500e+00,3.967300e+00,3.438600e+00,& - & 3.008900e+00,3.229500e+00,3.756700e+00,4.053100e+00,4.192300e+00,& - & 7.396400e+00,6.472100e+00,5.547800e+00,4.623400e+00,4.080800e+00,& - & 3.613700e+00,3.978200e+00,4.629800e+00,5.026800e+00,5.184500e+00,& - & 8.425000e+00,7.372100e+00,6.319200e+00,5.266300e+00,4.683600e+00,& - & 4.237600e+00,4.803500e+00,5.591900e+00,6.074000e+00,6.264800e+00,& - & 9.449900e+00,8.268900e+00,7.087900e+00,5.923900e+00,5.278600e+00,& - & 4.899900e+00,5.676000e+00,6.605200e+00,7.180200e+00,7.402200e+00,& - & 1.042300e+01,9.120000e+00,7.817400e+00,6.588200e+00,5.855800e+00,& - & 5.601400e+00,6.588400e+00,7.667500e+00,8.325500e+00,8.580300e+00,& - & 6.096000e+00,5.334100e+00,4.572300e+00,3.812600e+00,3.406900e+00,& - & 2.939600e+00,3.219700e+00,3.745500e+00,4.028600e+00,4.215500e+00,& - & 7.167600e+00,6.271900e+00,5.376100e+00,4.496600e+00,4.041200e+00,& - & 3.549300e+00,3.947200e+00,4.592000e+00,4.969900e+00,5.177500e+00,& - & 8.227500e+00,7.199300e+00,6.171000e+00,5.208900e+00,4.656800e+00,& - & 4.198500e+00,4.744000e+00,5.521100e+00,6.014900e+00,6.237000e+00,& - & 9.279900e+00,8.120200e+00,6.960400e+00,5.958600e+00,5.271600e+00,& - & 4.896000e+00,5.659900e+00,6.587200e+00,7.173500e+00,7.441400e+00,& - & 1.029000e+01,9.004400e+00,7.718100e+00,6.721100e+00,5.875700e+00,& - & 5.624500e+00,6.655800e+00,7.745200e+00,8.406900e+00,8.737300e+00,& - & 5.603900e+00,4.903600e+00,4.203200e+00,3.544500e+00,3.190200e+00,& - & 2.753700e+00,3.081300e+00,3.584000e+00,3.857600e+00,4.076400e+00,& - & 6.686300e+00,5.850600e+00,5.015000e+00,4.281500e+00,3.827000e+00,& - & 3.335200e+00,3.785700e+00,4.404800e+00,4.763700e+00,5.013100e+00,& - & 7.773700e+00,6.802100e+00,5.830500e+00,5.066500e+00,4.459400e+00,& - & 3.982700e+00,4.565900e+00,5.312400e+00,5.765900e+00,6.047700e+00,& - & 8.850800e+00,7.744600e+00,6.638400e+00,5.881300e+00,5.085900e+00,& - & 4.684000e+00,5.459100e+00,6.352700e+00,6.891400e+00,7.229100e+00,& - & 9.907900e+00,8.669600e+00,7.431400e+00,6.653900e+00,5.710700e+00,& - & 5.461800e+00,6.493300e+00,7.555600e+00,8.191600e+00,8.596700e+00,& - & 5.042900e+00,4.412700e+00,3.782400e+00,3.256500e+00,2.911700e+00,& - & 2.589800e+00,2.895800e+00,3.370200e+00,3.640800e+00,3.852600e+00,& - & 6.116500e+00,5.352000e+00,4.587600e+00,4.030000e+00,3.541600e+00,& - & 3.153200e+00,3.578000e+00,4.163300e+00,4.515500e+00,4.759500e+00,& - & 7.220200e+00,6.317800e+00,5.415300e+00,4.849200e+00,4.182900e+00,& - & 3.779000e+00,4.363100e+00,5.076600e+00,5.492800e+00,5.802900e+00,& - & 8.327600e+00,7.286800e+00,6.246000e+00,5.653400e+00,4.822500e+00,& - & 4.464000e+00,5.262500e+00,6.122100e+00,6.615600e+00,6.998400e+00,& - & 9.414800e+00,8.238100e+00,7.061800e+00,6.422100e+00,5.476000e+00,& - & 5.266800e+00,6.301200e+00,7.327900e+00,7.896200e+00,8.377400e+00,& - & 4.480200e+00,3.920200e+00,3.360300e+00,2.966200e+00,2.661100e+00,& - & 2.428800e+00,2.702600e+00,3.145500e+00,3.411400e+00,3.602400e+00,& - & 5.540100e+00,4.847700e+00,4.155200e+00,3.738400e+00,3.263300e+00,& - & 2.992800e+00,3.390000e+00,3.944300e+00,4.263600e+00,4.518800e+00,& - & 6.643800e+00,5.813400e+00,4.983100e+00,4.544600e+00,3.888400e+00,& - & 3.605300e+00,4.183500e+00,4.865800e+00,5.243500e+00,5.575400e+00,& - & 7.770900e+00,6.799600e+00,5.833800e+00,5.346000e+00,4.546100e+00,& - & 4.305500e+00,5.105100e+00,5.935900e+00,6.376300e+00,6.803100e+00,& - & 8.889800e+00,7.778700e+00,6.698300e+00,6.126000e+00,5.226700e+00,& - & 5.151700e+00,6.171200e+00,7.174800e+00,7.688800e+00,8.224200e+00,& - & 3.895600e+00,3.408700e+00,2.922100e+00,2.628100e+00,2.405000e+00,& - & 2.191600e+00,2.417400e+00,2.816100e+00,3.092700e+00,3.224400e+00,& - & 4.930300e+00,4.314100e+00,3.704600e+00,3.384400e+00,3.010500e+00,& - & 2.777000e+00,3.141200e+00,3.657500e+00,3.981400e+00,4.191000e+00,& - & 6.021800e+00,5.269100e+00,4.538700e+00,4.165700e+00,3.635000e+00,& - & 3.417200e+00,3.972600e+00,4.621400e+00,4.989700e+00,5.299100e+00,& - & 7.156800e+00,6.262300e+00,5.434500e+00,4.965800e+00,4.296600e+00,& - & 4.156300e+00,4.935100e+00,5.738300e+00,6.143400e+00,6.585700e+00,& - & 8.300300e+00,7.262800e+00,6.367100e+00,5.759000e+00,4.964400e+00,& - & 5.029800e+00,6.022900e+00,7.004600e+00,7.495700e+00,8.037500e+00/ - data absa(301:650,14) / & - & 3.338800e+00,2.921500e+00,2.518700e+00,2.325300e+00,2.111900e+00,& - & 1.916400e+00,2.085900e+00,2.431500e+00,2.698200e+00,2.783600e+00,& - & 4.335900e+00,3.794000e+00,3.286900e+00,3.029300e+00,2.710200e+00,& - & 2.502600e+00,2.803200e+00,3.266100e+00,3.595300e+00,3.740000e+00,& - & 5.412000e+00,4.735600e+00,4.139500e+00,3.777800e+00,3.351300e+00,& - & 3.168800e+00,3.657200e+00,4.257400e+00,4.645900e+00,4.880500e+00,& - & 6.542800e+00,5.725000e+00,5.063900e+00,4.562000e+00,4.036200e+00,& - & 3.952100e+00,4.670100e+00,5.435000e+00,5.881400e+00,6.234400e+00,& - & 7.701100e+00,6.738500e+00,6.035900e+00,5.368900e+00,4.739800e+00,& - & 4.867100e+00,5.810400e+00,6.760900e+00,7.285500e+00,7.756400e+00,& - & 2.833200e+00,2.479000e+00,2.158800e+00,2.051700e+00,1.821200e+00,& - & 1.642700e+00,1.755500e+00,2.046300e+00,2.280800e+00,2.341700e+00,& - & 3.784500e+00,3.311500e+00,2.906200e+00,2.730700e+00,2.400200e+00,& - & 2.207600e+00,2.439400e+00,2.842400e+00,3.148900e+00,3.255000e+00,& - & 4.834100e+00,4.229900e+00,3.758400e+00,3.458200e+00,3.043700e+00,& - & 2.874800e+00,3.283400e+00,3.824200e+00,4.198300e+00,4.382300e+00,& - & 5.961100e+00,5.216000e+00,4.684100e+00,4.225700e+00,3.738100e+00,& - & 3.669500e+00,4.300800e+00,5.008000e+00,5.465300e+00,5.741300e+00,& - & 7.138800e+00,6.246500e+00,5.651600e+00,5.031700e+00,4.485100e+00,& - & 4.596600e+00,5.460600e+00,6.357100e+00,6.930300e+00,7.290100e+00,& - & 2.371200e+00,2.074800e+00,1.851400e+00,1.761000e+00,1.541000e+00,& - & 1.377600e+00,1.460200e+00,1.701900e+00,1.891700e+00,1.949100e+00,& - & 3.270600e+00,2.861800e+00,2.553500e+00,2.412100e+00,2.095300e+00,& - & 1.909100e+00,2.086700e+00,2.431500e+00,2.696100e+00,2.785500e+00,& - & 4.292800e+00,3.756200e+00,3.370700e+00,3.132500e+00,2.732300e+00,& - & 2.556800e+00,2.889700e+00,3.365800e+00,3.711200e+00,3.856600e+00,& - & 5.408400e+00,4.732400e+00,4.287200e+00,3.907400e+00,3.433300e+00,& - & 3.340300e+00,3.875900e+00,4.514800e+00,4.965700e+00,5.173000e+00,& - & 6.594500e+00,5.770200e+00,5.261200e+00,4.734100e+00,4.202700e+00,& - & 4.261900e+00,5.020300e+00,5.847500e+00,6.424700e+00,6.700700e+00,& - & 2.023800e+00,1.770900e+00,1.627100e+00,1.521300e+00,1.321100e+00,& - & 1.170800e+00,1.247000e+00,1.452900e+00,1.610000e+00,4.367500e+00,& - & 2.873900e+00,2.514700e+00,2.302000e+00,2.139300e+00,1.857500e+00,& - & 1.673500e+00,1.830500e+00,2.132400e+00,2.356500e+00,4.322700e+00,& - & 3.865000e+00,3.381900e+00,3.100900e+00,2.843800e+00,2.483200e+00,& - & 2.302100e+00,2.592400e+00,3.019400e+00,3.320200e+00,4.393800e+00,& - & 4.977700e+00,4.355500e+00,3.996400e+00,3.630900e+00,3.187100e+00,& - & 3.070000e+00,3.525800e+00,4.107300e+00,4.524900e+00,4.961200e+00,& - & 6.182500e+00,5.411400e+00,4.952800e+00,4.482500e+00,3.986900e+00,& - & 3.980600e+00,4.638200e+00,5.402700e+00,5.952100e+00,6.194000e+00,& - & 2.080400e+00,1.820400e+00,1.700500e+00,1.553600e+00,1.350000e+00,& - & 1.204400e+00,1.305300e+00,1.520100e+00,1.668300e+00,7.099500e+00,& - & 2.937200e+00,2.571000e+00,2.412300e+00,2.187600e+00,1.910300e+00,& - & 1.735600e+00,1.913100e+00,2.228400e+00,2.449300e+00,7.095000e+00,& - & 3.962800e+00,3.473100e+00,3.241100e+00,2.926500e+00,2.561400e+00,& - & 2.394700e+00,2.697600e+00,3.143400e+00,3.470000e+00,6.963700e+00,& - & 5.124800e+00,4.493700e+00,4.160300e+00,3.759700e+00,3.317700e+00,& - & 3.201500e+00,3.668700e+00,4.274600e+00,4.722000e+00,6.906900e+00,& - & 6.404800e+00,5.623800e+00,5.159600e+00,4.665300e+00,4.186900e+00,& - & 4.150300e+00,4.829100e+00,5.627800e+00,6.213100e+00,7.373500e+00,& - & 2.160600e+00,1.891900e+00,1.777600e+00,1.598800e+00,1.393100e+00,& - & 1.260700e+00,1.376500e+00,1.603000e+00,1.758400e+00,8.853900e+00,& - & 3.024100e+00,2.653800e+00,2.510800e+00,2.255800e+00,1.976000e+00,& - & 1.813500e+00,2.004800e+00,2.335400e+00,2.568200e+00,8.829900e+00,& - & 4.085400e+00,3.591700e+00,3.375800e+00,3.034700e+00,2.673200e+00,& - & 2.511700e+00,2.810600e+00,3.274300e+00,3.609500e+00,8.667000e+00,& - & 5.304400e+00,4.678600e+00,4.344300e+00,3.921300e+00,3.496900e+00,& - & 3.358500e+00,3.804000e+00,4.433000e+00,4.907500e+00,8.570000e+00,& - & 6.644000e+00,5.881200e+00,5.412000e+00,4.912500e+00,4.428200e+00,& - & 4.342900e+00,4.985500e+00,5.810200e+00,6.449200e+00,8.683000e+00,& - & 2.252500e+00,1.986400e+00,1.864300e+00,1.660200e+00,1.461400e+00,& - & 1.335000e+00,1.456900e+00,1.696000e+00,1.853900e+00,8.760100e+00,& - & 3.133200e+00,2.763200e+00,2.601800e+00,2.336700e+00,2.076500e+00,& - & 1.917100e+00,2.110500e+00,2.457800e+00,2.694500e+00,8.683700e+00,& - & 4.214600e+00,3.726900e+00,3.496300e+00,3.160900e+00,2.832600e+00,& - & 2.652200e+00,2.939000e+00,3.423400e+00,3.771500e+00,8.595200e+00,& - & 5.471800e+00,4.864500e+00,4.531300e+00,4.122100e+00,3.716300e+00,& - & 3.538700e+00,3.944200e+00,4.594500e+00,5.079600e+00,8.549400e+00,& - & 6.876100e+00,6.137200e+00,5.671800e+00,5.222900e+00,4.715500e+00,& - & 4.563700e+00,5.116300e+00,5.964500e+00,6.638800e+00,8.727500e+00/ - data absa(1:300,15) / & - & 7.403800e+00,6.478500e+00,5.553200e+00,4.628000e+00,3.738900e+00,& - & 4.385300e+00,5.251400e+00,6.090200e+00,6.234600e+00,6.598100e+00,& - & 8.577000e+00,7.505100e+00,6.433200e+00,5.361300e+00,4.492200e+00,& - & 5.533200e+00,6.624800e+00,7.685600e+00,7.878800e+00,8.335800e+00,& - & 9.719600e+00,8.492400e+00,7.290100e+00,6.075400e+00,5.428700e+00,& - & 6.775800e+00,8.117400e+00,9.429500e+00,9.645400e+00,1.023100e+01,& - & 1.082300e+01,9.470100e+00,8.117500e+00,6.765000e+00,6.484500e+00,& - & 8.096800e+00,9.697100e+00,1.124700e+01,1.153500e+01,1.223200e+01,& - & 1.186200e+01,1.038000e+01,8.897500e+00,7.414900e+00,7.598700e+00,& - & 9.485400e+00,1.136700e+01,1.318300e+01,1.353500e+01,1.432200e+01,& - & 7.248700e+00,6.342800e+00,5.436900e+00,4.530900e+00,3.830500e+00,& - & 4.686600e+00,5.612200e+00,6.510900e+00,6.694400e+00,7.223700e+00,& - & 8.463200e+00,7.405400e+00,6.347700e+00,5.290000e+00,4.797200e+00,& - & 5.977400e+00,7.161200e+00,8.309100e+00,8.544800e+00,9.220300e+00,& - & 9.637600e+00,8.433100e+00,7.228600e+00,6.024100e+00,5.927700e+00,& - & 7.403200e+00,8.867000e+00,1.028800e+01,1.059100e+01,1.142000e+01,& - & 1.078700e+01,9.438600e+00,8.090500e+00,6.742300e+00,7.136500e+00,& - & 8.912000e+00,1.067500e+01,1.238700e+01,1.276600e+01,1.375100e+01,& - & 1.187600e+01,1.039200e+01,8.907600e+00,7.426300e+00,8.409300e+00,& - & 1.050200e+01,1.257700e+01,1.460000e+01,1.506100e+01,1.621600e+01,& - & 6.806000e+00,5.955400e+00,5.104800e+00,4.254100e+00,3.794500e+00,& - & 4.679300e+00,5.606600e+00,6.506900e+00,6.726200e+00,7.370500e+00,& - & 8.051200e+00,7.044900e+00,6.038700e+00,5.032400e+00,4.872300e+00,& - & 6.080700e+00,7.284500e+00,8.453400e+00,8.747100e+00,9.578500e+00,& - & 9.277100e+00,8.117600e+00,6.958100e+00,5.798600e+00,6.122700e+00,& - & 7.649000e+00,9.162000e+00,1.063400e+01,1.101300e+01,1.204900e+01,& - & 1.046100e+01,9.153500e+00,7.846000e+00,6.554800e+00,7.481000e+00,& - & 9.344500e+00,1.119300e+01,1.299500e+01,1.347400e+01,1.472600e+01,& - & 1.161200e+01,1.016100e+01,8.709400e+00,7.396300e+00,8.901400e+00,& - & 1.111900e+01,1.332300e+01,1.546200e+01,1.605500e+01,1.752500e+01,& - & 6.272700e+00,5.488700e+00,4.704700e+00,3.920700e+00,3.652500e+00,& - & 4.500000e+00,5.389800e+00,6.258800e+00,6.514900e+00,7.156700e+00,& - & 7.516900e+00,6.577400e+00,5.637900e+00,4.698500e+00,4.791100e+00,& - & 5.975100e+00,7.159600e+00,8.314100e+00,8.662000e+00,9.504400e+00,& - & 8.786100e+00,7.688000e+00,6.589800e+00,5.530500e+00,6.124700e+00,& - & 7.648800e+00,9.166900e+00,1.064500e+01,1.110600e+01,1.217300e+01,& - & 1.002600e+01,8.772800e+00,7.519700e+00,6.447300e+00,7.608100e+00,& - & 9.502200e+00,1.138600e+01,1.322500e+01,1.381900e+01,1.512100e+01,& - & 1.121500e+01,9.813200e+00,8.411700e+00,7.463400e+00,9.176300e+00,& - & 1.146500e+01,1.373400e+01,1.595600e+01,1.669700e+01,1.824300e+01,& - & 5.709400e+00,4.995800e+00,4.282200e+00,3.575100e+00,3.445600e+00,& - & 4.240800e+00,5.080800e+00,5.900100e+00,6.164000e+00,6.772400e+00,& - & 6.961000e+00,6.090900e+00,5.220900e+00,4.395000e+00,4.616000e+00,& - & 5.737800e+00,6.874600e+00,7.987700e+00,8.393300e+00,9.164100e+00,& - & 8.245200e+00,7.214600e+00,6.184000e+00,5.297800e+00,5.997300e+00,& - & 7.490000e+00,8.975700e+00,1.042900e+01,1.097400e+01,1.196700e+01,& - & 9.531700e+00,8.340300e+00,7.148900e+00,6.359400e+00,7.569000e+00,& - & 9.457000e+00,1.133000e+01,1.316600e+01,1.387900e+01,1.510200e+01,& - & 1.077400e+01,9.427100e+00,8.080800e+00,7.516500e+00,9.260000e+00,& - & 1.157000e+01,1.386400e+01,1.611600e+01,1.702100e+01,1.848100e+01,& - & 5.089200e+00,4.453100e+00,3.817000e+00,3.219900e+00,3.211300e+00,& - & 4.011300e+00,4.805200e+00,5.578400e+00,5.794600e+00,6.416800e+00,& - & 6.341500e+00,5.548900e+00,4.756300e+00,4.048200e+00,4.340700e+00,& - & 5.421200e+00,6.494300e+00,7.543400e+00,7.903100e+00,8.673400e+00,& - & 7.623000e+00,6.670100e+00,5.717300e+00,5.037200e+00,5.704900e+00,& - & 7.126800e+00,8.542700e+00,9.927700e+00,1.050300e+01,1.140100e+01,& - & 8.942700e+00,7.825000e+00,6.707200e+00,6.186400e+00,7.305400e+00,& - & 9.126200e+00,1.093600e+01,1.271700e+01,1.353000e+01,1.459600e+01,& - & 1.023400e+01,8.955200e+00,7.675700e+00,7.440800e+00,9.097500e+00,& - & 1.136400e+01,1.361900e+01,1.583700e+01,1.685700e+01,1.818200e+01/ - data absa(301:650,15) / & - & 4.470100e+00,3.911400e+00,3.352700e+00,2.849100e+00,3.052500e+00,& - & 3.812000e+00,4.567100e+00,5.302900e+00,5.517000e+00,6.105400e+00,& - & 5.702500e+00,4.989700e+00,4.276900e+00,3.707600e+00,4.144100e+00,& - & 5.176800e+00,6.202200e+00,7.204500e+00,7.535300e+00,8.288800e+00,& - & 6.990300e+00,6.116600e+00,5.242900e+00,4.742100e+00,5.471100e+00,& - & 6.834500e+00,8.190800e+00,9.515800e+00,1.002100e+01,1.094400e+01,& - & 8.311600e+00,7.272700e+00,6.233900e+00,5.934700e+00,7.027700e+00,& - & 8.778800e+00,1.052300e+01,1.222900e+01,1.297000e+01,1.405600e+01,& - & 9.643300e+00,8.437900e+00,7.240400e+00,7.253900e+00,8.819100e+00,& - & 1.101500e+01,1.320200e+01,1.535100e+01,1.638100e+01,1.763600e+01,& - & 3.881500e+00,3.396300e+00,2.911200e+00,2.514400e+00,2.890100e+00,& - & 3.610700e+00,4.326700e+00,5.023700e+00,5.256200e+00,5.784300e+00,& - & 5.080300e+00,4.445300e+00,3.810300e+00,3.358800e+00,3.958100e+00,& - & 4.943300e+00,5.924500e+00,6.883100e+00,7.224600e+00,7.920500e+00,& - & 6.364200e+00,5.568700e+00,4.773200e+00,4.406100e+00,5.263500e+00,& - & 6.574600e+00,7.879300e+00,9.159100e+00,9.661200e+00,1.053300e+01,& - & 7.696200e+00,6.734200e+00,5.801600e+00,5.621800e+00,6.807300e+00,& - & 8.503500e+00,1.019100e+01,1.184200e+01,1.256400e+01,1.361800e+01,& - & 9.060000e+00,7.927600e+00,6.888700e+00,6.978200e+00,8.596500e+00,& - & 1.073800e+01,1.287200e+01,1.495900e+01,1.591600e+01,1.720100e+01,& - & 3.324800e+00,2.909300e+00,2.493700e+00,2.272400e+00,2.696100e+00,& - & 3.368400e+00,4.035900e+00,4.690000e+00,4.949900e+00,5.397300e+00,& - & 4.480800e+00,3.920700e+00,3.361500e+00,3.092000e+00,3.739500e+00,& - & 4.670600e+00,5.597100e+00,6.504400e+00,6.872700e+00,7.483600e+00,& - & 5.750500e+00,5.031700e+00,4.343500e+00,4.101600e+00,5.020500e+00,& - & 6.271400e+00,7.516000e+00,8.739700e+00,9.270900e+00,1.004700e+01,& - & 7.090800e+00,6.204400e+00,5.378200e+00,5.288200e+00,6.559700e+00,& - & 8.194400e+00,9.821700e+00,1.141600e+01,1.214200e+01,1.313000e+01,& - & 8.473200e+00,7.414100e+00,6.491300e+00,6.628700e+00,8.356500e+00,& - & 1.043800e+01,1.251200e+01,1.455100e+01,1.551400e+01,1.672300e+01,& - & 2.892000e+00,2.530600e+00,2.169300e+00,2.098600e+00,2.512400e+00,& - & 3.138800e+00,3.762500e+00,4.375200e+00,4.667200e+00,5.615700e+00,& - & 4.004000e+00,3.503500e+00,3.023800e+00,2.937600e+00,3.566700e+00,& - & 4.455900e+00,5.341600e+00,6.211500e+00,6.621000e+00,7.169100e+00,& - & 5.252900e+00,4.596300e+00,3.980400e+00,3.943600e+00,4.839700e+00,& - & 6.046500e+00,7.247400e+00,8.428200e+00,9.002300e+00,9.688500e+00,& - & 6.600900e+00,5.775800e+00,5.045100e+00,5.123600e+00,6.390100e+00,& - & 7.983100e+00,9.569000e+00,1.112800e+01,1.189800e+01,1.279000e+01,& - & 8.035800e+00,7.031400e+00,6.214600e+00,6.465000e+00,8.196400e+00,& - & 1.024000e+01,1.227400e+01,1.428300e+01,1.531700e+01,1.640500e+01,& - & 2.959700e+00,2.589700e+00,2.265500e+00,2.276900e+00,2.735900e+00,& - & 3.413100e+00,4.092400e+00,4.762200e+00,5.136900e+00,8.766400e+00,& - & 4.109000e+00,3.595400e+00,3.127400e+00,3.208600e+00,3.889100e+00,& - & 4.858900e+00,5.825500e+00,6.776100e+00,7.297400e+00,9.142900e+00,& - & 5.425700e+00,4.747500e+00,4.143200e+00,4.307100e+00,5.296000e+00,& - & 6.617800e+00,7.932700e+00,9.230000e+00,9.913900e+00,1.087700e+01,& - & 6.863500e+00,6.005600e+00,5.303100e+00,5.572600e+00,6.972800e+00,& - & 8.711700e+00,1.044400e+01,1.215200e+01,1.306800e+01,1.395600e+01,& - & 8.400700e+00,7.350600e+00,6.601000e+00,7.037600e+00,8.924900e+00,& - & 1.115000e+01,1.336700e+01,1.554700e+01,1.673600e+01,1.786100e+01,& - & 3.070600e+00,2.686800e+00,2.378600e+00,2.465000e+00,2.937600e+00,& - & 3.660600e+00,4.390000e+00,5.109700e+00,5.552300e+00,1.112200e+01,& - & 4.289400e+00,3.753200e+00,3.313500e+00,3.494200e+00,4.213900e+00,& - & 5.264600e+00,6.312100e+00,7.346600e+00,7.937600e+00,1.113600e+01,& - & 5.688400e+00,4.977300e+00,4.426000e+00,4.703900e+00,5.751900e+00,& - & 7.186600e+00,8.616500e+00,1.002900e+01,1.082700e+01,1.249900e+01,& - & 7.250500e+00,6.344800e+00,5.706600e+00,6.094100e+00,7.559200e+00,& - & 9.444300e+00,1.132300e+01,1.317200e+01,1.423000e+01,1.515700e+01,& - & 8.972900e+00,7.851300e+00,7.167700e+00,7.701800e+00,9.694500e+00,& - & 1.211200e+01,1.451900e+01,1.689600e+01,1.823500e+01,1.940200e+01,& - & 3.224600e+00,2.821600e+00,2.541000e+00,2.667200e+00,3.133500e+00,& - & 3.895300e+00,4.671800e+00,5.439800e+00,5.939800e+00,1.104800e+01,& - & 4.539600e+00,3.972200e+00,3.605700e+00,3.812400e+00,4.523500e+00,& - & 5.633400e+00,6.755100e+00,7.865400e+00,8.565500e+00,1.152300e+01,& - & 6.082200e+00,5.321900e+00,4.871600e+00,5.151400e+00,6.186100e+00,& - & 7.721400e+00,9.258100e+00,1.077600e+01,1.169900e+01,1.315000e+01,& - & 7.860000e+00,6.877700e+00,6.319300e+00,6.690300e+00,8.136700e+00,& - & 1.016400e+01,1.218700e+01,1.418800e+01,1.539200e+01,1.628900e+01,& - & 9.848300e+00,8.618200e+00,7.961900e+00,8.455500e+00,1.046700e+01,& - & 1.307700e+01,1.568000e+01,1.824600e+01,1.974900e+01,2.094600e+01/ - data absa(1:300,16) / & - & 7.512700e+00,6.573700e+00,5.634900e+00,4.695800e+00,3.877900e+00,& - & 4.841600e+00,5.798100e+00,6.718900e+00,6.800200e+00,7.240800e+00,& - & 8.697900e+00,7.610900e+00,6.523900e+00,5.436800e+00,4.790300e+00,& - & 5.980700e+00,7.160900e+00,8.299400e+00,8.310900e+00,8.945500e+00,& - & 9.731700e+00,8.604200e+00,7.299300e+00,6.083000e+00,5.852600e+00,& - & 7.307600e+00,8.749000e+00,1.003400e+01,1.026300e+01,1.081600e+01,& - & 1.096100e+01,9.591300e+00,8.221400e+00,6.851400e+00,7.153200e+00,& - & 8.933600e+00,1.069600e+01,1.239500e+01,1.254100e+01,1.321800e+01,& - & 1.200700e+01,1.050600e+01,9.006300e+00,7.505500e+00,8.553300e+00,& - & 1.068200e+01,1.278900e+01,1.482300e+01,1.500300e+01,1.597500e+01,& - & 7.373100e+00,6.451600e+00,5.530100e+00,4.608600e+00,4.293700e+00,& - & 5.360900e+00,6.419800e+00,7.440800e+00,7.532900e+00,8.212400e+00,& - & 8.602100e+00,7.527100e+00,6.452000e+00,5.376800e+00,5.367500e+00,& - & 6.701800e+00,8.023700e+00,9.299700e+00,9.414000e+00,1.026400e+01,& - & 9.788800e+00,8.565400e+00,7.342000e+00,6.118600e+00,6.549600e+00,& - & 8.178200e+00,9.790400e+00,1.134400e+01,1.147400e+01,1.251900e+01,& - & 1.094500e+01,9.576900e+00,8.209000e+00,6.841200e+00,8.047400e+00,& - & 1.004800e+01,1.203000e+01,1.394400e+01,1.411400e+01,1.538800e+01,& - & 1.204200e+01,1.053700e+01,9.033300e+00,7.528000e+00,9.706200e+00,& - & 1.211700e+01,1.451100e+01,1.681900e+01,1.702400e+01,1.855800e+01,& - & 6.943700e+00,6.075900e+00,5.208000e+00,4.340200e+00,4.502300e+00,& - & 5.621400e+00,6.729700e+00,7.802600e+00,7.901200e+00,8.815500e+00,& - & 8.207000e+00,7.181300e+00,6.155400e+00,5.129800e+00,5.732900e+00,& - & 7.157800e+00,8.569900e+00,9.933600e+00,1.006000e+01,1.122800e+01,& - & 9.449100e+00,8.268100e+00,7.087200e+00,5.906200e+00,7.070700e+00,& - & 8.829700e+00,1.058100e+01,1.226200e+01,1.242200e+01,1.386000e+01,& - & 1.064200e+01,9.311500e+00,7.981500e+00,6.651500e+00,8.665400e+00,& - & 1.081900e+01,1.295400e+01,1.501300e+01,1.519400e+01,1.696600e+01,& - & 1.180700e+01,1.033100e+01,8.855400e+00,7.941600e+00,1.058200e+01,& - & 1.321200e+01,1.582000e+01,1.832200e+01,1.857100e+01,2.072100e+01,& - & 6.425800e+00,5.622600e+00,4.819600e+00,4.016400e+00,4.598300e+00,& - & 5.733900e+00,6.874000e+00,7.966100e+00,8.072800e+00,9.113200e+00,& - & 7.691700e+00,6.730300e+00,5.769000e+00,4.807600e+00,5.986600e+00,& - & 7.474900e+00,8.951800e+00,1.037700e+01,1.051500e+01,1.185700e+01,& - & 8.981300e+00,7.858600e+00,6.736100e+00,5.667800e+00,7.531600e+00,& - & 9.403800e+00,1.124700e+01,1.304900e+01,1.322800e+01,1.492500e+01,& - & 1.023900e+01,8.959300e+00,7.679600e+00,6.950900e+00,9.261500e+00,& - & 1.156400e+01,1.384500e+01,1.602800e+01,1.622000e+01,1.833300e+01,& - & 1.144000e+01,1.001000e+01,8.583800e+00,8.509800e+00,1.133900e+01,& - & 1.415900e+01,1.695300e+01,1.965600e+01,1.990600e+01,2.247600e+01,& - & 5.877000e+00,5.142400e+00,4.407900e+00,3.673300e+00,4.629700e+00,& - & 5.786600e+00,6.927700e+00,8.030800e+00,8.136900e+00,9.227200e+00,& - & 7.152300e+00,6.258200e+00,5.364400e+00,4.641300e+00,6.184100e+00,& - & 7.721300e+00,9.246100e+00,1.071800e+01,1.087300e+01,1.232500e+01,& - & 8.461300e+00,7.403800e+00,6.346200e+00,5.957200e+00,7.933700e+00,& - & 9.905700e+00,1.187200e+01,1.375800e+01,1.396500e+01,1.580000e+01,& - & 9.767600e+00,8.546800e+00,7.325900e+00,7.423800e+00,9.891600e+00,& - & 1.235200e+01,1.479100e+01,1.714700e+01,1.738400e+01,1.971900e+01,& - & 1.102500e+01,9.647200e+00,8.271600e+00,9.140600e+00,1.217900e+01,& - & 1.520800e+01,1.821100e+01,2.109700e+01,2.136400e+01,2.426700e+01,& - & 5.265000e+00,4.606900e+00,3.948800e+00,3.418400e+00,4.553800e+00,& - & 5.683400e+00,6.805900e+00,7.891400e+00,8.014500e+00,9.094000e+00,& - & 6.547000e+00,5.728700e+00,4.910400e+00,4.691200e+00,6.250500e+00,& - & 7.804300e+00,9.346300e+00,1.082500e+01,1.101000e+01,1.247900e+01,& - & 7.853400e+00,6.871800e+00,5.890200e+00,6.164000e+00,8.213900e+00,& - & 1.025700e+01,1.227400e+01,1.424500e+01,1.446800e+01,1.640600e+01,& - & 9.200700e+00,8.050700e+00,6.900700e+00,7.821600e+00,1.042100e+01,& - & 1.301400e+01,1.558100e+01,1.805500e+01,1.834400e+01,2.080900e+01,& - & 1.051200e+01,9.198400e+00,7.884200e+00,9.742900e+00,1.298200e+01,& - & 1.620600e+01,1.940700e+01,2.250200e+01,2.278900e+01,2.592800e+01/ - data absa(301:650,16) / & - & 4.656500e+00,4.074500e+00,3.492500e+00,3.295600e+00,4.391100e+00,& - & 5.486400e+00,6.569500e+00,7.611500e+00,7.743900e+00,8.783700e+00,& - & 5.929200e+00,5.188100e+00,4.447000e+00,4.669700e+00,6.221900e+00,& - & 7.768600e+00,9.304300e+00,1.079000e+01,1.098200e+01,1.245100e+01,& - & 7.257600e+00,6.350500e+00,5.443300e+00,6.292200e+00,8.382300e+00,& - & 1.046800e+01,1.254300e+01,1.453600e+01,1.480500e+01,1.676500e+01,& - & 8.617900e+00,7.540600e+00,6.463300e+00,8.155000e+00,1.086600e+01,& - & 1.356700e+01,1.624400e+01,1.884200e+01,1.918600e+01,2.174200e+01,& - & 9.985100e+00,8.737000e+00,7.489800e+00,1.032100e+01,1.375200e+01,& - & 1.717100e+01,2.056100e+01,2.382500e+01,2.417700e+01,2.750800e+01,& - & 4.075400e+00,3.566000e+00,3.056600e+00,3.133300e+00,4.174900e+00,& - & 5.210900e+00,6.237900e+00,7.239100e+00,7.382200e+00,8.358300e+00,& - & 5.327300e+00,4.661400e+00,3.995600e+00,4.588000e+00,6.113200e+00,& - & 7.632900e+00,9.137200e+00,1.060000e+01,1.081900e+01,1.223800e+01,& - & 6.660700e+00,5.828100e+00,4.995600e+00,6.348900e+00,8.469200e+00,& - & 1.057500e+01,1.265800e+01,1.467800e+01,1.499100e+01,1.695100e+01,& - & 8.039400e+00,7.034400e+00,6.029600e+00,8.423700e+00,1.122400e+01,& - & 1.401400e+01,1.678900e+01,1.946000e+01,1.985400e+01,2.247000e+01,& - & 9.443700e+00,8.263300e+00,7.289500e+00,1.086800e+01,1.448000e+01,& - & 1.808100e+01,2.165300e+01,2.511100e+01,2.551400e+01,2.899000e+01,& - & 3.512100e+00,3.073100e+00,2.634100e+00,2.927900e+00,3.901300e+00,& - & 4.875400e+00,5.836800e+00,6.764400e+00,6.892000e+00,7.815000e+00,& - & 4.722300e+00,4.132100e+00,3.541600e+00,4.424000e+00,5.894700e+00,& - & 7.360200e+00,8.823700e+00,1.023400e+01,1.047300e+01,1.181800e+01,& - & 6.047800e+00,5.291800e+00,4.535900e+00,6.311800e+00,8.410500e+00,& - & 1.050400e+01,1.258500e+01,1.459400e+01,1.494800e+01,1.683700e+01,& - & 7.440400e+00,6.510400e+00,5.828200e+00,8.590800e+00,1.144700e+01,& - & 1.429400e+01,1.711900e+01,1.985600e+01,2.029900e+01,2.293500e+01,& - & 8.873200e+00,7.764100e+00,7.553900e+00,1.132700e+01,1.509300e+01,& - & 1.884900e+01,2.257300e+01,2.616500e+01,2.665200e+01,3.023000e+01,& - & 3.061800e+00,2.679100e+00,2.296400e+00,2.936400e+00,3.912600e+00,& - & 4.884700e+00,5.847500e+00,6.780800e+00,6.875600e+00,7.835800e+00,& - & 4.231600e+00,3.702700e+00,3.174300e+00,4.335000e+00,5.776200e+00,& - & 7.213800e+00,8.636700e+00,1.001900e+01,1.028400e+01,1.157000e+01,& - & 5.545700e+00,4.852500e+00,4.361500e+00,6.337300e+00,8.449200e+00,& - & 1.055000e+01,1.263800e+01,1.465600e+01,1.508200e+01,1.692300e+01,& - & 6.959300e+00,6.089400e+00,5.913400e+00,8.866100e+00,1.181400e+01,& - & 1.475100e+01,1.766900e+01,2.049100e+01,2.097800e+01,2.366400e+01,& - & 8.439600e+00,7.384700e+00,7.965100e+00,1.194200e+01,1.591500e+01,& - & 1.987200e+01,2.379300e+01,2.759300e+01,2.816100e+01,3.187200e+01,& - & 3.157900e+00,2.763200e+00,2.389600e+00,3.554500e+00,4.736200e+00,& - & 5.913600e+00,7.082300e+00,8.206900e+00,8.332300e+00,9.487300e+00,& - & 4.374400e+00,3.827600e+00,3.510000e+00,5.153800e+00,6.867100e+00,& - & 8.574300e+00,1.027400e+01,1.191400e+01,1.220900e+01,1.375700e+01,& - & 5.747100e+00,5.028800e+00,5.003400e+00,7.497000e+00,9.988800e+00,& - & 1.247200e+01,1.494200e+01,1.733300e+01,1.782100e+01,2.000700e+01,& - & 7.262900e+00,6.355000e+00,7.047400e+00,1.056600e+01,1.407900e+01,& - & 1.758400e+01,2.105700e+01,2.441900e+01,2.501900e+01,2.821100e+01,& - & 8.906900e+00,7.793600e+00,9.528400e+00,1.428600e+01,1.903700e+01,& - & 2.377100e+01,2.846800e+01,3.301000e+01,3.375100e+01,3.813000e+01,& - & 3.300600e+00,2.888100e+00,2.866600e+00,4.298500e+00,5.727400e+00,& - & 7.150600e+00,8.560700e+00,9.929900e+00,1.009700e+01,1.157000e+01,& - & 4.595200e+00,4.020800e+00,4.102400e+00,6.151100e+00,8.195900e+00,& - & 1.023500e+01,1.225400e+01,1.421500e+01,1.455800e+01,1.641500e+01,& - & 6.117200e+00,5.352600e+00,5.920500e+00,8.878300e+00,1.183500e+01,& - & 1.478100e+01,1.770600e+01,2.053100e+01,2.111400e+01,2.370500e+01,& - & 7.906300e+00,6.918000e+00,8.381200e+00,1.256600e+01,1.674700e+01,& - & 2.091500e+01,2.504900e+01,2.906400e+01,2.982000e+01,3.355200e+01,& - & 9.940500e+00,8.698000e+00,1.136100e+01,1.703400e+01,2.269700e+01,& - & 2.834700e+01,3.393600e+01,3.935700e+01,4.037700e+01,4.547100e+01,& - & 3.524000e+00,3.083500e+00,3.450200e+00,5.173400e+00,6.894700e+00,& - & 8.609100e+00,1.031000e+01,1.195400e+01,1.218700e+01,1.380600e+01,& - & 5.019100e+00,4.391700e+00,4.887300e+00,7.327600e+00,9.765400e+00,& - & 1.219400e+01,1.460800e+01,1.694300e+01,1.736600e+01,1.955900e+01,& - & 6.861200e+00,6.003500e+00,6.994100e+00,1.048600e+01,1.397100e+01,& - & 1.744600e+01,2.089600e+01,2.425600e+01,2.499300e+01,2.797900e+01,& - & 8.993700e+00,7.871300e+00,9.917200e+00,1.487400e+01,1.981800e+01,& - & 2.475400e+01,2.964200e+01,3.437400e+01,3.540700e+01,3.968900e+01,& - & 1.138600e+01,9.963200e+00,1.344100e+01,2.015700e+01,2.686100e+01,& - & 3.354500e+01,4.016500e+01,4.661600e+01,4.798100e+01,5.379300e+01/ - -! the array absb(1175,NG03) = kb(5,5,13:59,NG03) contains absorption -! coefs at the NG03=16 g-intervals for a range of pressure levels < -! ~100mb, temperatures, and ratios of h2o to co2. the first index in -! the array, js, runs from 1 to 5, and corresponds to different h2o -! to co2 ratios, as expressed through the binary species parameter -! eta, defined as eta = h2o/(h2o+rat*co2), where rat is the ratio -! of the integrated line strength in the band of co2 to that of h2o. -! for instance, js=1 refers to no h2o, js = 2 corresponds to eta = -! 0.25, etc. the second index, jt, which runs from 1 to 5, -! corresponds to different temperatures. more specifically, jt = 1-5 -! means that the data are for the corresponding temperature of -! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the -! third index, jp, runs from 13 to 59 and refers to the corresponding -! pressure level in pref (e.g. jp = 13 is for a pressure of 95.5835 mb). -! the fourth index, ig, goes from 1 to NG03=16, and tells us which -! g-interval the absorption coefficients are for. - - data absb(1:300,1) / & - & 7.141800e-07,7.768300e-05,1.653000e-04,3.322100e-04,3.437500e-04,& - & 7.289500e-07,7.789100e-05,1.581300e-04,2.961100e-04,3.515600e-04,& - & 8.110400e-07,8.031300e-05,1.557300e-04,2.720500e-04,3.674400e-04,& - & 9.803000e-07,8.464500e-05,1.582900e-04,2.578800e-04,3.912400e-04,& - & 1.253200e-06,9.136700e-05,1.655600e-04,2.524300e-04,4.227800e-04,& - & 5.866200e-07,6.321700e-05,1.339400e-04,2.681500e-04,2.802400e-04,& - & 6.032200e-07,6.364400e-05,1.287100e-04,2.398900e-04,2.869700e-04,& - & 6.770700e-07,6.585700e-05,1.272600e-04,2.211300e-04,3.001400e-04,& - & 8.225100e-07,6.966300e-05,1.298400e-04,2.103800e-04,3.197600e-04,& - & 1.053700e-06,7.547700e-05,1.362500e-04,2.066900e-04,3.455300e-04,& - & 4.815900e-07,5.132700e-05,1.082800e-04,2.158000e-04,2.271600e-04,& - & 4.995300e-07,5.189800e-05,1.045600e-04,1.938400e-04,2.328200e-04,& - & 5.659200e-07,5.393700e-05,1.038300e-04,1.793800e-04,2.434200e-04,& - & 6.906000e-07,5.727600e-05,1.063700e-04,1.713600e-04,2.592500e-04,& - & 8.876400e-07,6.230000e-05,1.120600e-04,1.690100e-04,2.797800e-04,& - & 3.953400e-07,4.165800e-05,8.750900e-05,1.734900e-04,1.832700e-04,& - & 4.139500e-07,4.230500e-05,8.493400e-05,1.565300e-04,1.879400e-04,& - & 4.729800e-07,4.417600e-05,8.471400e-05,1.454600e-04,1.962700e-04,& - & 5.801700e-07,4.709400e-05,8.716200e-05,1.395300e-04,2.086200e-04,& - & 7.484700e-07,5.141000e-05,9.216400e-05,1.382200e-04,2.249200e-04,& - & 3.246100e-07,3.390000e-05,7.092800e-05,1.398200e-04,1.479000e-04,& - & 3.431000e-07,3.457000e-05,6.914200e-05,1.266600e-04,1.517500e-04,& - & 3.950200e-07,3.624300e-05,6.925800e-05,1.181700e-04,1.584000e-04,& - & 4.870600e-07,3.877000e-05,7.155800e-05,1.138000e-04,1.681100e-04,& - & 6.305200e-07,4.246200e-05,7.592400e-05,1.132200e-04,1.809700e-04,& - & 2.666500e-07,2.769000e-05,5.771400e-05,1.130600e-04,1.197400e-04,& - & 2.843300e-07,2.835200e-05,5.646700e-05,1.027800e-04,1.229500e-04,& - & 3.299100e-07,2.982000e-05,5.678200e-05,9.622300e-05,1.283300e-04,& - & 4.088500e-07,3.199000e-05,5.891600e-05,9.303300e-05,1.360100e-04,& - & 5.311300e-07,3.514700e-05,6.266700e-05,9.295500e-05,1.460400e-04,& - & 2.191500e-07,2.265000e-05,4.703200e-05,9.154500e-05,9.717400e-05,& - & 2.356300e-07,2.328200e-05,4.617200e-05,8.348600e-05,9.986900e-05,& - & 2.754800e-07,2.455300e-05,4.660300e-05,7.844100e-05,1.042200e-04,& - & 3.431000e-07,2.641400e-05,4.854700e-05,7.613400e-05,1.103600e-04,& - & 4.472400e-07,2.909600e-05,5.173700e-05,7.638100e-05,1.183900e-04,& - & 1.803000e-07,1.855800e-05,3.835600e-05,7.407100e-05,7.916900e-05,& - & 1.957900e-07,1.915500e-05,3.779100e-05,6.778800e-05,8.144600e-05,& - & 2.308500e-07,2.025400e-05,3.830900e-05,6.395600e-05,8.504700e-05,& - & 2.892400e-07,2.185900e-05,4.006200e-05,6.234600e-05,9.008200e-05,& - & 3.784600e-07,2.413700e-05,4.278800e-05,6.282000e-05,9.665000e-05,& - & 1.484700e-07,1.521500e-05,3.129000e-05,5.994900e-05,6.455200e-05,& - & 1.628700e-07,1.576600e-05,3.094300e-05,5.505400e-05,6.647800e-05,& - & 1.936600e-07,1.671300e-05,3.150300e-05,5.216100e-05,6.947500e-05,& - & 2.440800e-07,1.809200e-05,3.305900e-05,5.106400e-05,7.363200e-05,& - & 3.204800e-07,2.002200e-05,3.538300e-05,5.167500e-05,7.902500e-05,& - & 1.228900e-07,1.248400e-05,2.547200e-05,4.819200e-05,5.260300e-05,& - & 1.369700e-07,1.300900e-05,2.533400e-05,4.450400e-05,5.426700e-05,& - & 1.648800e-07,1.384300e-05,2.595000e-05,4.243200e-05,5.680300e-05,& - & 2.096800e-07,1.505200e-05,2.736300e-05,4.180300e-05,6.027400e-05,& - & 2.766900e-07,1.671500e-05,2.938400e-05,4.257500e-05,6.471500e-05,& - & 1.020600e-07,1.025200e-05,2.074700e-05,3.873400e-05,4.284000e-05,& - & 1.155900e-07,1.074200e-05,2.075500e-05,3.599000e-05,4.427400e-05,& - & 1.408200e-07,1.147300e-05,2.139100e-05,3.453500e-05,4.640900e-05,& - & 1.806400e-07,1.252800e-05,2.265000e-05,3.424500e-05,4.928900e-05,& - & 2.394400e-07,1.396100e-05,2.440800e-05,3.509400e-05,5.290800e-05,& - & 8.510300e-08,8.414700e-06,1.689100e-05,3.109900e-05,3.478000e-05,& - & 9.800600e-08,8.865500e-06,1.699900e-05,2.909100e-05,3.599600e-05,& - & 1.207300e-07,9.508600e-06,1.763100e-05,2.810500e-05,3.777300e-05,& - & 1.561600e-07,1.042700e-05,1.874200e-05,2.805600e-05,4.011400e-05,& - & 2.078400e-07,1.166300e-05,2.027400e-05,2.892700e-05,4.302800e-05/ - data absb(301:600,1) / & - & 7.131000e-08,6.918500e-06,1.376700e-05,2.497600e-05,2.824100e-05,& - & 8.349900e-08,7.324600e-06,1.394300e-05,2.353300e-05,2.927300e-05,& - & 1.040100e-07,7.893500e-06,1.455500e-05,2.289600e-05,3.073500e-05,& - & 1.355500e-07,8.694100e-06,1.552900e-05,2.301500e-05,3.263900e-05,& - & 1.810800e-07,9.760900e-06,1.686700e-05,2.387300e-05,3.499300e-05,& - & 6.014200e-08,5.704700e-06,1.124300e-05,2.006900e-05,2.297800e-05,& - & 7.160300e-08,6.068100e-06,1.146500e-05,1.905700e-05,2.385400e-05,& - & 9.025100e-08,6.573800e-06,1.204500e-05,1.868100e-05,2.507600e-05,& - & 1.184700e-07,7.274500e-06,1.290300e-05,1.892100e-05,2.662600e-05,& - & 1.587500e-07,8.199600e-06,1.407700e-05,1.975100e-05,2.855500e-05,& - & 5.098300e-08,4.708800e-06,9.191200e-06,1.614700e-05,1.866800e-05,& - & 6.163000e-08,5.031500e-06,9.440200e-06,1.545200e-05,1.940500e-05,& - & 7.856300e-08,5.480600e-06,9.974200e-06,1.526200e-05,2.040300e-05,& - & 1.037700e-07,6.093100e-06,1.073100e-05,1.557500e-05,2.167200e-05,& - & 1.393400e-07,6.894200e-06,1.176000e-05,1.636100e-05,2.319600e-05,& - & 4.342300e-08,3.890600e-06,7.522600e-06,1.300900e-05,1.512700e-05,& - & 5.322800e-08,4.175500e-06,7.781800e-06,1.254600e-05,1.573600e-05,& - & 6.856400e-08,4.573100e-06,8.263900e-06,1.248700e-05,1.653600e-05,& - & 9.103900e-08,5.107400e-06,8.932600e-06,1.283700e-05,1.750500e-05,& - & 1.223900e-07,5.801600e-06,9.831800e-06,1.356500e-05,1.867000e-05,& - & 3.720400e-08,3.223800e-06,6.173600e-06,1.050200e-05,1.227900e-05,& - & 4.620600e-08,3.475900e-06,6.433000e-06,1.020900e-05,1.276400e-05,& - & 6.007600e-08,3.827300e-06,6.863500e-06,1.024100e-05,1.336800e-05,& - & 8.014400e-08,4.293600e-06,7.453800e-06,1.060600e-05,1.412100e-05,& - & 1.077700e-07,4.896600e-06,8.241200e-06,1.127500e-05,1.504600e-05,& - & 3.199600e-08,2.673700e-06,5.075400e-06,8.494800e-06,9.882200e-06,& - & 4.024500e-08,2.898400e-06,5.326400e-06,8.322300e-06,1.025600e-05,& - & 5.274700e-08,3.207900e-06,5.708000e-06,8.416000e-06,1.072700e-05,& - & 7.060900e-08,3.613800e-06,6.228300e-06,8.777700e-06,1.132000e-05,& - & 9.498400e-08,4.139800e-06,6.919300e-06,9.387200e-06,1.206200e-05,& - & 2.764100e-08,2.222100e-06,4.182000e-06,6.885400e-06,7.885700e-06,& - & 3.520100e-08,2.422500e-06,4.418200e-06,6.798600e-06,8.187500e-06,& - & 4.645100e-08,2.694300e-06,4.756600e-06,6.933000e-06,8.570400e-06,& - & 6.233600e-08,3.048100e-06,5.215000e-06,7.281000e-06,9.047300e-06,& - & 8.377400e-08,3.504800e-06,5.818800e-06,7.829000e-06,9.636500e-06,& - & 2.398100e-08,1.850000e-06,3.453800e-06,5.592500e-06,6.270800e-06,& - & 3.088800e-08,2.028800e-06,3.670100e-06,5.566800e-06,6.514800e-06,& - & 4.100400e-08,2.267200e-06,3.970900e-06,5.724100e-06,6.823200e-06,& - & 5.509200e-08,2.575400e-06,4.374300e-06,6.051400e-06,7.215300e-06,& - & 7.392800e-08,2.972200e-06,4.901300e-06,6.540600e-06,7.688400e-06,& - & 2.089100e-08,1.543200e-06,2.858700e-06,4.551800e-06,4.964800e-06,& - & 2.717000e-08,1.701800e-06,3.053500e-06,4.568900e-06,5.162800e-06,& - & 3.624200e-08,1.910500e-06,3.320200e-06,4.734600e-06,5.422600e-06,& - & 4.874100e-08,2.180000e-06,3.676000e-06,5.038800e-06,5.737900e-06,& - & 6.522700e-08,2.523400e-06,4.134100e-06,5.473000e-06,6.118900e-06,& - & 1.809500e-08,1.286600e-06,2.367500e-06,3.715400e-06,3.966900e-06,& - & 2.370900e-08,1.425300e-06,2.539400e-06,3.756900e-06,4.135900e-06,& - & 3.172100e-08,1.606000e-06,2.772900e-06,3.918500e-06,4.349800e-06,& - & 4.265400e-08,1.839400e-06,3.082200e-06,4.191800e-06,4.608300e-06,& - & 5.694500e-08,2.134800e-06,3.477300e-06,4.573300e-06,4.922900e-06,& - & 1.531800e-08,1.063700e-06,1.950300e-06,3.036900e-06,3.142500e-06,& - & 2.014200e-08,1.181400e-06,2.096900e-06,3.084000e-06,3.280400e-06,& - & 2.698500e-08,1.333900e-06,2.295400e-06,3.228100e-06,3.450600e-06,& - & 3.627100e-08,1.531200e-06,2.557200e-06,3.463200e-06,3.660000e-06,& - & 4.834800e-08,1.779600e-06,2.890000e-06,3.787700e-06,3.911900e-06,& - & 1.260900e-08,8.701900e-07,1.595200e-06,2.482900e-06,2.454900e-06,& - & 1.658700e-08,9.671101e-07,1.716000e-06,2.522900e-06,2.565600e-06,& - & 2.222400e-08,1.092400e-06,1.879500e-06,2.642400e-06,2.698600e-06,& - & 2.986900e-08,1.254400e-06,2.094800e-06,2.836100e-06,2.862000e-06,& - & 3.980200e-08,1.458400e-06,2.368200e-06,3.103400e-06,3.059300e-06/ - data absb(601:900,1) / & - & 9.982500e-09,7.029800e-07,1.294200e-06,2.032800e-06,1.958000e-06,& - & 1.308200e-08,7.794900e-07,1.389200e-06,2.056700e-06,2.045500e-06,& - & 1.750400e-08,8.787300e-07,1.518100e-06,2.146400e-06,2.150500e-06,& - & 2.353000e-08,1.006900e-06,1.688400e-06,2.297400e-06,2.278300e-06,& - & 3.140800e-08,1.169100e-06,1.905800e-06,2.507600e-06,2.432500e-06,& - & 7.891400e-09,5.677000e-07,1.050000e-06,1.665300e-06,1.559100e-06,& - & 1.029800e-08,6.278500e-07,1.124300e-06,1.677300e-06,1.628400e-06,& - & 1.375200e-08,7.063000e-07,1.225600e-06,1.743500e-06,1.711300e-06,& - & 1.849100e-08,8.074800e-07,1.360000e-06,1.860400e-06,1.811900e-06,& - & 2.471300e-08,9.362300e-07,1.532300e-06,2.025200e-06,1.932500e-06,& - & 6.244900e-09,4.586200e-07,8.522700e-07,1.365000e-06,1.236200e-06,& - & 8.110700e-09,5.058800e-07,9.102400e-07,1.368700e-06,1.291300e-06,& - & 1.080700e-08,5.679000e-07,9.897900e-07,1.417100e-06,1.356700e-06,& - & 1.452800e-08,6.478000e-07,1.095800e-06,1.507200e-06,1.436100e-06,& - & 1.944600e-08,7.498800e-07,1.232300e-06,1.636300e-06,1.530600e-06,& - & 4.830200e-09,3.676400e-07,6.889000e-07,1.121800e-06,9.869600e-07,& - & 6.215700e-09,4.035400e-07,7.320700e-07,1.116400e-06,1.030400e-06,& - & 8.244100e-09,4.513100e-07,7.926100e-07,1.147400e-06,1.081700e-06,& - & 1.107400e-08,5.128200e-07,8.738600e-07,1.213200e-06,1.143400e-06,& - & 1.485100e-08,5.918000e-07,9.792100e-07,1.311000e-06,1.217100e-06,& - & 3.736800e-09,2.947600e-07,5.575500e-07,9.237600e-07,7.872000e-07,& - & 4.754500e-09,3.218200e-07,5.888600e-07,9.123800e-07,8.219100e-07,& - & 6.269000e-09,3.584200e-07,6.346200e-07,9.300300e-07,8.623700e-07,& - & 8.408600e-09,4.056700e-07,6.966300e-07,9.768800e-07,9.102600e-07,& - & 1.129100e-08,4.664000e-07,7.774800e-07,1.050300e-06,9.675200e-07,& - & 2.900700e-09,2.365000e-07,4.521300e-07,7.620900e-07,6.257500e-07,& - & 3.644500e-09,2.569800e-07,4.740800e-07,7.471400e-07,6.539700e-07,& - & 4.771400e-09,2.848800e-07,5.086700e-07,7.552700e-07,6.860100e-07,& - & 6.383800e-09,3.212000e-07,5.558400e-07,7.877800e-07,7.235000e-07,& - & 8.577300e-09,3.677700e-07,6.178200e-07,8.424900e-07,7.679400e-07,& - & 2.235100e-09,1.891100e-07,3.668700e-07,6.316200e-07,4.980500e-07,& - & 2.763400e-09,2.045100e-07,3.811500e-07,6.136000e-07,5.210700e-07,& - & 3.580700e-09,2.253400e-07,4.065800e-07,6.140900e-07,5.463500e-07,& - & 4.767200e-09,2.528400e-07,4.417700e-07,6.347300e-07,5.755300e-07,& - & 6.405200e-09,2.880500e-07,4.884600e-07,6.739700e-07,6.097700e-07,& - & 1.724800e-09,1.512100e-07,2.982600e-07,5.258000e-07,3.962400e-07,& - & 2.093900e-09,1.627700e-07,3.069800e-07,5.056300e-07,4.151500e-07,& - & 2.675900e-09,1.780800e-07,3.250200e-07,5.008500e-07,4.350700e-07,& - & 3.537500e-09,1.987500e-07,3.509800e-07,5.122700e-07,4.577900e-07,& - & 4.745700e-09,2.252300e-07,3.858200e-07,5.393300e-07,4.842100e-07,& - & 1.342600e-09,1.213100e-07,2.431500e-07,4.391900e-07,3.142900e-07,& - & 1.596300e-09,1.297800e-07,2.481100e-07,4.179900e-07,3.298200e-07,& - & 2.006800e-09,1.410700e-07,2.602700e-07,4.099900e-07,3.458500e-07,& - & 2.629100e-09,1.564900e-07,2.793900e-07,4.147300e-07,3.636000e-07,& - & 3.516500e-09,1.764300e-07,3.053100e-07,4.326800e-07,3.840700e-07,& - & 1.052500e-09,9.760700e-08,1.987100e-07,3.686400e-07,2.495400e-07,& - & 1.219000e-09,1.034200e-07,2.010800e-07,3.471300e-07,2.615000e-07,& - & 1.504400e-09,1.118100e-07,2.087100e-07,3.369100e-07,2.747400e-07,& - & 1.947400e-09,1.231500e-07,2.225400e-07,3.369000e-07,2.886900e-07,& - & 2.590000e-09,1.380900e-07,2.416000e-07,3.478400e-07,3.044600e-07,& - & 8.318400e-10,7.873000e-08,1.628800e-07,3.114200e-07,1.992600e-07,& - & 9.318900e-10,8.240000e-08,1.633800e-07,2.901400e-07,2.078100e-07,& - & 1.124600e-09,8.856600e-08,1.677300e-07,2.782000e-07,2.185000e-07,& - & 1.431000e-09,9.672600e-08,1.771800e-07,2.748200e-07,2.296000e-07,& - & 1.886600e-09,1.077700e-07,1.909600e-07,2.801600e-07,2.417400e-07,& - & 6.666700e-10,6.374300e-08,1.338300e-07,2.644400e-07,1.591900e-07,& - & 7.215200e-10,6.598000e-08,1.332600e-07,2.437000e-07,1.650000e-07,& - & 8.480300e-10,7.030500e-08,1.354600e-07,2.307900e-07,1.732500e-07,& - & 1.057600e-09,7.623900e-08,1.414500e-07,2.253300e-07,1.822900e-07,& - & 1.378100e-09,8.429200e-08,1.513600e-07,2.267200e-07,1.917900e-07/ - data absb(901:1175,1) / & - & 5.414400e-10,5.180100e-08,1.101300e-07,2.261800e-07,1.271100e-07,& - & 5.662900e-10,5.310700e-08,1.090700e-07,2.055300e-07,1.308900e-07,& - & 6.448600e-10,5.591800e-08,1.098600e-07,1.924400e-07,1.367600e-07,& - & 7.873500e-10,6.029100e-08,1.133900e-07,1.856500e-07,1.442200e-07,& - & 1.010600e-09,6.611000e-08,1.203400e-07,1.844600e-07,1.518500e-07,& - & 4.443700e-10,4.223200e-08,9.086200e-08,1.944400e-07,1.022000e-07,& - & 4.514200e-10,4.295400e-08,8.949500e-08,1.736700e-07,1.047800e-07,& - & 4.979200e-10,4.472400e-08,8.947000e-08,1.610000e-07,1.088600e-07,& - & 5.943600e-10,4.791900e-08,9.144200e-08,1.535200e-07,1.146400e-07,& - & 7.494000e-10,5.214500e-08,9.609200e-08,1.508600e-07,1.208800e-07,& - & 3.671300e-10,3.447400e-08,7.530800e-08,1.680300e-07,8.241500e-08,& - & 3.643000e-10,3.486200e-08,7.357100e-08,1.473200e-07,8.428300e-08,& - & 3.893800e-10,3.595800e-08,7.309500e-08,1.351500e-07,8.712900e-08,& - & 4.528700e-10,3.816900e-08,7.406800e-08,1.274600e-07,9.135900e-08,& - & 5.604200e-10,4.129700e-08,7.700500e-08,1.239000e-07,9.646700e-08,& - & 3.050700e-10,2.813500e-08,6.290300e-08,1.459600e-07,6.632600e-08,& - & 2.970900e-10,2.838500e-08,6.055400e-08,1.258000e-07,6.771700e-08,& - & 3.080500e-10,2.902900e-08,5.988600e-08,1.138000e-07,6.970900e-08,& - & 3.477600e-10,3.047000e-08,6.019000e-08,1.062500e-07,7.272500e-08,& - & 4.219500e-10,3.280000e-08,6.194400e-08,1.021600e-07,7.674500e-08,& - & 2.547100e-10,2.299800e-08,5.295900e-08,1.273800e-07,5.313100e-08,& - & 2.443200e-10,2.315200e-08,5.000700e-08,1.081900e-07,5.417900e-08,& - & 2.465400e-10,2.350800e-08,4.916500e-08,9.619500e-08,5.565800e-08,& - & 2.697700e-10,2.441700e-08,4.907100e-08,8.893900e-08,5.779000e-08,& - & 3.199200e-10,2.610400e-08,5.003100e-08,8.455000e-08,6.080300e-08,& - & 2.131400e-10,1.885200e-08,4.474800e-08,1.111500e-07,4.330200e-08,& - & 2.019300e-10,1.890400e-08,4.144900e-08,9.313500e-08,4.406700e-08,& - & 1.996500e-10,1.910500e-08,4.040900e-08,8.142000e-08,4.517700e-08,& - & 2.122400e-10,1.967800e-08,4.011400e-08,7.454100e-08,4.670400e-08,& - & 2.455700e-10,2.084700e-08,4.058600e-08,7.015400e-08,4.893200e-08,& - & 1.786700e-10,1.555500e-08,3.797200e-08,9.710800e-08,3.572800e-08,& - & 1.676000e-10,1.543300e-08,3.455500e-08,8.030600e-08,3.627100e-08,& - & 1.630600e-10,1.557000e-08,3.323700e-08,6.917900e-08,3.707500e-08,& - & 1.688100e-10,1.591800e-08,3.286500e-08,6.254300e-08,3.818100e-08,& - & 1.902200e-10,1.669700e-08,3.301800e-08,5.835700e-08,3.982900e-08,& - & 1.501400e-10,1.291500e-08,3.238000e-08,8.505500e-08,2.952600e-08,& - & 1.395800e-10,1.261600e-08,2.897800e-08,6.947300e-08,2.990400e-08,& - & 1.340200e-10,1.270400e-08,2.741100e-08,5.908800e-08,3.048500e-08,& - & 1.354800e-10,1.290800e-08,2.696600e-08,5.263100e-08,3.128100e-08,& - & 1.485400e-10,1.341600e-08,2.692800e-08,4.869400e-08,3.248700e-08,& - & 1.264800e-10,1.077800e-08,2.770800e-08,7.494200e-08,2.444300e-08,& - & 1.166600e-10,1.033400e-08,2.443000e-08,6.040400e-08,2.470700e-08,& - & 1.106700e-10,1.037400e-08,2.269100e-08,5.071400e-08,2.511100e-08,& - & 1.096700e-10,1.049000e-08,2.215500e-08,4.444600e-08,2.568600e-08,& - & 1.169700e-10,1.081500e-08,2.200700e-08,4.075200e-08,2.656000e-08,& - & 1.065900e-10,9.029300e-09,2.375900e-08,6.608900e-08,2.034700e-08,& - & 9.763600e-11,8.513500e-09,2.066800e-08,5.254300e-08,2.052500e-08,& - & 9.173200e-11,8.468900e-09,1.887600e-08,4.357000e-08,2.078500e-08,& - & 8.948700e-11,8.548300e-09,1.821300e-08,3.764500e-08,2.119500e-08,& - & 9.305900e-11,8.750500e-09,1.802200e-08,3.413100e-08,2.182700e-08,& - & 8.833100e-11,7.463000e-09,1.979300e-08,5.559300e-08,1.748200e-08,& - & 8.069400e-11,6.993200e-09,1.713300e-08,4.395700e-08,1.748600e-08,& - & 7.554900e-11,6.923300e-09,1.555300e-08,3.628800e-08,1.762000e-08,& - & 7.329300e-11,6.986300e-09,1.492500e-08,3.120600e-08,1.787000e-08,& - & 7.549200e-11,7.132800e-09,1.475000e-08,2.815900e-08,1.836900e-08/ - data absb(1:300,2) / & - & 1.783100e-06,1.148500e-04,2.249200e-04,4.168800e-04,6.054700e-04,& - & 2.252300e-06,1.230600e-04,2.285500e-04,3.887300e-04,6.958000e-04,& - & 3.140100e-06,1.373800e-04,2.431500e-04,3.787300e-04,8.121800e-04,& - & 4.644400e-06,1.595600e-04,2.682200e-04,3.862900e-04,9.539900e-04,& - & 7.031300e-06,1.898700e-04,3.050700e-04,4.126100e-04,1.119200e-03,& - & 1.507800e-06,9.395500e-05,1.837600e-04,3.384500e-04,5.037200e-04,& - & 1.933400e-06,1.012100e-04,1.874300e-04,3.171300e-04,5.791000e-04,& - & 2.716000e-06,1.136800e-04,2.004800e-04,3.103200e-04,6.765800e-04,& - & 4.031400e-06,1.326600e-04,2.223300e-04,3.184500e-04,7.942300e-04,& - & 6.114400e-06,1.584800e-04,2.540800e-04,3.419700e-04,9.292200e-04,& - & 1.277400e-06,7.665900e-05,1.496600e-04,2.742800e-04,4.080600e-04,& - & 1.653900e-06,8.307500e-05,1.534100e-04,2.581800e-04,4.682400e-04,& - & 2.332700e-06,9.382300e-05,1.650400e-04,2.540000e-04,5.455400e-04,& - & 3.469400e-06,1.100700e-04,1.839800e-04,2.623100e-04,6.378000e-04,& - & 5.270500e-06,1.320700e-04,2.111900e-04,2.832300e-04,7.450900e-04,& - & 1.080700e-06,6.253000e-05,1.218000e-04,2.221500e-04,3.280800e-04,& - & 1.408400e-06,6.819600e-05,1.255800e-04,2.101400e-04,3.744500e-04,& - & 1.992100e-06,7.740900e-05,1.358900e-04,2.079200e-04,4.332200e-04,& - & 2.970900e-06,9.131700e-05,1.522300e-04,2.161000e-04,5.032900e-04,& - & 4.517500e-06,1.101300e-04,1.755200e-04,2.345600e-04,5.839400e-04,& - & 9.118000e-07,5.117900e-05,9.938600e-05,1.802500e-04,2.643700e-04,& - & 1.194600e-06,5.614300e-05,1.031000e-04,1.713400e-04,2.999600e-04,& - & 1.697200e-06,6.407700e-05,1.121600e-04,1.704900e-04,3.449400e-04,& - & 2.540200e-06,7.603400e-05,1.262000e-04,1.783400e-04,3.985000e-04,& - & 3.860200e-06,9.213700e-05,1.462000e-04,1.944600e-04,4.605300e-04,& - & 7.684700e-07,4.212800e-05,8.142700e-05,1.466300e-04,2.142800e-04,& - & 1.014000e-06,4.646700e-05,8.501800e-05,1.400500e-04,2.422100e-04,& - & 1.449200e-06,5.335800e-05,9.293900e-05,1.401900e-04,2.773900e-04,& - & 2.175600e-06,6.367100e-05,1.050400e-04,1.475300e-04,3.193700e-04,& - & 3.297300e-06,7.746900e-05,1.223300e-04,1.615900e-04,3.680500e-04,& - & 6.466500e-07,3.475600e-05,6.683000e-05,1.194000e-04,1.745500e-04,& - & 8.602600e-07,3.852800e-05,7.021200e-05,1.146000e-04,1.969400e-04,& - & 1.236800e-06,4.452800e-05,7.712000e-05,1.154000e-04,2.249800e-04,& - & 1.858000e-06,5.340400e-05,8.755700e-05,1.221500e-04,2.585000e-04,& - & 2.810300e-06,6.516200e-05,1.024900e-04,1.343800e-04,2.967900e-04,& - & 5.465600e-07,2.877000e-05,5.497500e-05,9.719600e-05,1.432600e-04,& - & 7.343600e-07,3.208500e-05,5.815700e-05,9.386500e-05,1.615500e-04,& - & 1.062200e-06,3.735800e-05,6.422100e-05,9.515900e-05,1.843600e-04,& - & 1.596500e-06,4.497400e-05,7.328700e-05,1.013900e-04,2.114900e-04,& - & 2.411900e-06,5.503300e-05,8.624400e-05,1.120700e-04,2.417200e-04,& - & 4.623300e-07,2.383400e-05,4.526400e-05,7.914900e-05,1.177400e-04,& - & 6.270700e-07,2.675100e-05,4.820200e-05,7.692800e-05,1.327300e-04,& - & 9.112300e-07,3.135800e-05,5.351500e-05,7.855000e-05,1.513300e-04,& - & 1.371100e-06,3.785600e-05,6.140500e-05,8.420600e-05,1.732100e-04,& - & 2.069800e-06,4.646600e-05,7.255500e-05,9.352400e-05,1.969800e-04,& - & 3.980900e-07,1.986100e-05,3.736200e-05,6.425500e-05,9.713000e-05,& - & 5.466600e-07,2.248700e-05,4.015900e-05,6.305800e-05,1.094600e-04,& - & 8.005700e-07,2.657700e-05,4.493500e-05,6.507000e-05,1.245600e-04,& - & 1.207100e-06,3.221100e-05,5.192400e-05,7.034400e-05,1.418200e-04,& - & 1.819500e-06,3.967400e-05,6.164500e-05,7.862300e-05,1.604000e-04,& - & 3.436700e-07,1.656800e-05,3.088000e-05,5.223800e-05,8.002100e-05,& - & 4.775800e-07,1.892800e-05,3.350400e-05,5.176200e-05,9.005400e-05,& - & 7.044700e-07,2.252900e-05,3.777400e-05,5.399000e-05,1.021100e-04,& - & 1.063800e-06,2.741400e-05,4.392800e-05,5.884500e-05,1.154200e-04,& - & 1.600700e-06,3.384900e-05,5.235300e-05,6.613400e-05,1.300200e-04,& - & 2.973100e-07,1.381700e-05,2.553100e-05,4.247700e-05,6.548300e-05,& - & 4.180000e-07,1.592500e-05,2.796300e-05,4.252500e-05,7.345000e-05,& - & 6.203900e-07,1.908300e-05,3.174800e-05,4.484100e-05,8.260300e-05,& - & 9.379900e-07,2.330300e-05,3.715500e-05,4.923600e-05,9.277100e-05,& - & 1.408400e-06,2.882400e-05,4.440400e-05,5.562100e-05,1.040100e-04/ - data absb(301:600,2) / & - & 2.584600e-07,1.155700e-05,2.116800e-05,3.459100e-05,5.340200e-05,& - & 3.677900e-07,1.344600e-05,2.339700e-05,3.501900e-05,5.950400e-05,& - & 5.491400e-07,1.620300e-05,2.674700e-05,3.731600e-05,6.645300e-05,& - & 8.308100e-07,1.984800e-05,3.148900e-05,4.127100e-05,7.420400e-05,& - & 1.243400e-06,2.458600e-05,3.770600e-05,4.684300e-05,8.296400e-05,& - & 2.268800e-07,9.718200e-06,1.762600e-05,2.823800e-05,4.345800e-05,& - & 3.269800e-07,1.142100e-05,1.966000e-05,2.894600e-05,4.810400e-05,& - & 4.909500e-07,1.382700e-05,2.264200e-05,3.116200e-05,5.345800e-05,& - & 7.425400e-07,1.699100e-05,2.680400e-05,3.471000e-05,5.961600e-05,& - & 1.106400e-06,2.107300e-05,3.213100e-05,3.958100e-05,6.656400e-05,& - & 1.999300e-07,8.189000e-06,1.470600e-05,2.310400e-05,3.488500e-05,& - & 2.914700e-07,9.712000e-06,1.654400e-05,2.398400e-05,3.844400e-05,& - & 4.395500e-07,1.180300e-05,1.919200e-05,2.606300e-05,4.265800e-05,& - & 6.636500e-07,1.454900e-05,2.281700e-05,2.921400e-05,4.754800e-05,& - & 9.839900e-07,1.806000e-05,2.738100e-05,3.345400e-05,5.303400e-05,& - & 1.766600e-07,6.910600e-06,1.229100e-05,1.895000e-05,2.761400e-05,& - & 2.602700e-07,8.261300e-06,1.393900e-05,1.991200e-05,3.034700e-05,& - & 3.936000e-07,1.007600e-05,1.627700e-05,2.182200e-05,3.366500e-05,& - & 5.925500e-07,1.245500e-05,1.941900e-05,2.459900e-05,3.752100e-05,& - & 8.739700e-07,1.547400e-05,2.333200e-05,2.828100e-05,4.180900e-05,& - & 1.573100e-07,5.860600e-06,1.031600e-05,1.560000e-05,2.190200e-05,& - & 2.340000e-07,7.054300e-06,1.179000e-05,1.659000e-05,2.408900e-05,& - & 3.541800e-07,8.634300e-06,1.385300e-05,1.832400e-05,2.673700e-05,& - & 5.311900e-07,1.070000e-05,1.657600e-05,2.076600e-05,2.975800e-05,& - & 7.791600e-07,1.329900e-05,1.993900e-05,2.397100e-05,3.311700e-05,& - & 1.406300e-07,4.982400e-06,8.676400e-06,1.288000e-05,1.731000e-05,& - & 2.106700e-07,6.030300e-06,9.987500e-06,1.384800e-05,1.904700e-05,& - & 3.187300e-07,7.409300e-06,1.180400e-05,1.540800e-05,2.111200e-05,& - & 4.760200e-07,9.199000e-06,1.415600e-05,1.755000e-05,2.346700e-05,& - & 6.943100e-07,1.144200e-05,1.705300e-05,2.034000e-05,2.609100e-05,& - & 1.264400e-07,4.251600e-06,7.319500e-06,1.067300e-05,1.368200e-05,& - & 1.903100e-07,5.169300e-06,8.485700e-06,1.159300e-05,1.503400e-05,& - & 2.875100e-07,6.374500e-06,1.008400e-05,1.298500e-05,1.663500e-05,& - & 4.272400e-07,7.926000e-06,1.210900e-05,1.486000e-05,1.844600e-05,& - & 6.191600e-07,9.857000e-06,1.460200e-05,1.728000e-05,2.048100e-05,& - & 1.140900e-07,3.637900e-06,6.191500e-06,8.874700e-06,1.078300e-05,& - & 1.722800e-07,4.441200e-06,7.228700e-06,9.727300e-06,1.184200e-05,& - & 2.596200e-07,5.494900e-06,8.626800e-06,1.096300e-05,1.307800e-05,& - & 3.836500e-07,6.837700e-06,1.037100e-05,1.260500e-05,1.447700e-05,& - & 5.523300e-07,8.503200e-06,1.251500e-05,1.469800e-05,1.606800e-05,& - & 1.031900e-07,3.118000e-06,5.248100e-06,7.400400e-06,8.450000e-06,& - & 1.561200e-07,3.821500e-06,6.168600e-06,8.177100e-06,9.283300e-06,& - & 2.344100e-07,4.741800e-06,7.386100e-06,9.270000e-06,1.023500e-05,& - & 3.444600e-07,5.906000e-06,8.892500e-06,1.071000e-05,1.133500e-05,& - & 4.924100e-07,7.337100e-06,1.073100e-05,1.250700e-05,1.257600e-05,& - & 9.230700e-08,2.661900e-06,4.438500e-06,6.171000e-06,6.708600e-06,& - & 1.397000e-07,3.273100e-06,5.244800e-06,6.865200e-06,7.366600e-06,& - & 2.089500e-07,4.069000e-06,6.293000e-06,7.818600e-06,8.127400e-06,& - & 3.053200e-07,5.068100e-06,7.583600e-06,9.063400e-06,9.007100e-06,& - & 4.339200e-07,6.291200e-06,9.151600e-06,1.059800e-05,1.000100e-05,& - & 7.933400e-08,2.229400e-06,3.699800e-06,5.104900e-06,5.246600e-06,& - & 1.200200e-07,2.746700e-06,4.384600e-06,5.699300e-06,5.755400e-06,& - & 1.791200e-07,3.417600e-06,5.265400e-06,6.507300e-06,6.353800e-06,& - & 2.609600e-07,4.257200e-06,6.349900e-06,7.556600e-06,7.048400e-06,& - & 3.697100e-07,5.282000e-06,7.661600e-06,8.841500e-06,7.840300e-06,& - & 6.513300e-08,1.825800e-06,3.030500e-06,4.178100e-06,4.039100e-06,& - & 9.852100e-08,2.250400e-06,3.592700e-06,4.667000e-06,4.425700e-06,& - & 1.470400e-07,2.801400e-06,4.315900e-06,5.330700e-06,4.885100e-06,& - & 2.142300e-07,3.490500e-06,5.205600e-06,6.191900e-06,5.422100e-06,& - & 3.034700e-07,4.331100e-06,6.281000e-06,7.246400e-06,6.040000e-06/ - data absb(601:900,2) / & - & 5.040900e-08,1.454600e-06,2.429700e-06,3.377700e-06,3.188800e-06,& - & 7.627800e-08,1.789700e-06,2.872200e-06,3.759500e-06,3.488300e-06,& - & 1.141600e-07,2.226500e-06,3.448000e-06,4.283400e-06,3.845400e-06,& - & 1.669500e-07,2.775200e-06,4.156600e-06,4.967000e-06,4.265300e-06,& - & 2.374100e-07,3.446400e-06,5.017500e-06,5.809800e-06,4.750900e-06,& - & 3.889000e-08,1.157200e-06,1.946200e-06,2.730300e-06,2.517300e-06,& - & 5.883900e-08,1.421100e-06,2.293500e-06,3.026500e-06,2.749000e-06,& - & 8.830600e-08,1.766400e-06,2.750300e-06,3.438800e-06,3.025900e-06,& - & 1.296300e-07,2.202300e-06,3.313800e-06,3.979800e-06,3.353300e-06,& - & 1.850900e-07,2.737200e-06,4.000700e-06,4.652000e-06,3.734200e-06,& - & 3.001500e-08,9.208400e-07,1.559600e-06,2.208300e-06,1.982800e-06,& - & 4.538500e-08,1.128800e-06,1.831900e-06,2.437600e-06,2.160800e-06,& - & 6.827800e-08,1.401400e-06,2.193700e-06,2.761600e-06,2.375100e-06,& - & 1.006100e-07,1.747700e-06,2.642200e-06,3.189100e-06,2.629000e-06,& - & 1.442300e-07,2.173400e-06,3.190100e-06,3.724800e-06,2.925600e-06,& - & 2.225600e-08,7.191200e-07,1.232900e-06,1.774500e-06,1.569700e-06,& - & 3.356900e-08,8.785100e-07,1.439600e-06,1.943600e-06,1.705500e-06,& - & 5.066400e-08,1.087900e-06,1.718200e-06,2.190000e-06,1.870500e-06,& - & 7.511800e-08,1.356400e-06,2.068000e-06,2.519200e-06,2.066800e-06,& - & 1.084300e-07,1.688600e-06,2.496000e-06,2.936900e-06,2.297300e-06,& - & 1.644700e-08,5.608000e-07,9.744400e-07,1.428600e-06,1.243500e-06,& - & 2.469500e-08,6.824200e-07,1.130200e-06,1.550000e-06,1.346900e-06,& - & 3.734900e-08,8.422900e-07,1.342800e-06,1.736000e-06,1.473200e-06,& - & 5.570500e-08,1.049700e-06,1.614800e-06,1.987500e-06,1.624600e-06,& - & 8.098800e-08,1.307500e-06,1.947900e-06,2.310900e-06,1.803000e-06,& - & 1.218600e-08,4.381900e-07,7.712400e-07,1.153800e-06,9.846000e-07,& - & 1.816700e-08,5.304000e-07,8.886700e-07,1.238600e-06,1.063100e-06,& - & 2.749600e-08,6.524000e-07,1.050100e-06,1.377600e-06,1.159200e-06,& - & 4.122600e-08,8.120500e-07,1.261100e-06,1.569500e-06,1.275500e-06,& - & 6.035800e-08,1.012200e-06,1.519800e-06,1.818900e-06,1.412900e-06,& - & 8.882500e-09,3.402500e-07,6.077000e-07,9.333100e-07,7.808500e-07,& - & 1.307700e-08,4.082100e-07,6.942500e-07,9.875901e-07,8.397700e-07,& - & 1.976300e-08,4.999600e-07,8.143700e-07,1.088100e-06,9.125200e-07,& - & 2.978500e-08,6.206200e-07,9.749500e-07,1.231600e-06,1.001000e-06,& - & 4.396800e-08,7.737100e-07,1.173700e-06,1.420600e-06,1.105900e-06,& - & 6.465200e-09,2.643200e-07,4.793000e-07,7.585400e-07,6.201800e-07,& - & 9.343100e-09,3.132100e-07,5.418900e-07,7.891700e-07,6.634200e-07,& - & 1.405400e-08,3.817000e-07,6.302100e-07,8.594800e-07,7.186600e-07,& - & 2.125700e-08,4.719200e-07,7.505300e-07,9.653201e-07,7.854200e-07,& - & 3.163600e-08,5.881400e-07,9.025500e-07,1.106900e-06,8.650800e-07,& - & 4.749300e-09,2.061800e-07,3.795500e-07,6.201000e-07,4.932000e-07,& - & 6.704600e-09,2.410300e-07,4.242100e-07,6.340900e-07,5.237200e-07,& - & 9.997900e-09,2.918300e-07,4.890300e-07,6.812100e-07,5.653400e-07,& - & 1.514200e-08,3.591500e-07,5.783300e-07,7.582500e-07,6.157500e-07,& - & 2.269200e-08,4.469500e-07,6.943500e-07,8.639400e-07,6.758400e-07,& - & 3.502600e-09,1.609500e-07,3.016400e-07,5.098800e-07,3.926600e-07,& - & 4.805600e-09,1.857100e-07,3.323800e-07,5.121100e-07,4.141100e-07,& - & 7.061100e-09,2.225600e-07,3.793600e-07,5.410800e-07,4.442200e-07,& - & 1.067400e-08,2.725400e-07,4.448400e-07,5.957300e-07,4.821300e-07,& - & 1.609100e-08,3.380700e-07,5.322000e-07,6.736800e-07,5.273900e-07,& - & 2.586000e-09,1.255800e-07,2.407900e-07,4.223700e-07,3.132600e-07,& - & 3.429000e-09,1.430000e-07,2.605600e-07,4.162300e-07,3.285700e-07,& - & 4.922000e-09,1.687800e-07,2.936500e-07,4.309200e-07,3.496000e-07,& - & 7.390800e-09,2.054100e-07,3.407400e-07,4.677100e-07,3.779000e-07,& - & 1.118200e-08,2.535400e-07,4.049800e-07,5.239400e-07,4.118700e-07,& - & 1.936200e-09,9.854800e-08,1.941100e-07,3.527200e-07,2.493700e-07,& - & 2.479800e-09,1.107200e-07,2.055000e-07,3.410500e-07,2.609000e-07,& - & 3.455500e-09,1.286500e-07,2.282800e-07,3.459400e-07,2.756000e-07,& - & 5.123400e-09,1.551500e-07,2.620700e-07,3.690900e-07,2.959500e-07,& - & 7.753800e-09,1.904500e-07,3.087200e-07,4.087800e-07,3.212800e-07/ - data absb(901:1175,2) / & - & 1.469300e-09,7.779000e-08,1.579600e-07,2.963800e-07,1.977000e-07,& - & 1.818900e-09,8.613400e-08,1.633400e-07,2.813900e-07,2.067400e-07,& - & 2.451400e-09,9.873700e-08,1.784200e-07,2.800100e-07,2.174000e-07,& - & 3.562500e-09,1.174900e-07,2.024000e-07,2.929200e-07,2.315000e-07,& - & 5.368200e-09,1.433900e-07,2.360600e-07,3.202400e-07,2.500000e-07,& - & 1.133900e-09,6.194500e-08,1.293300e-07,2.504100e-07,1.574800e-07,& - & 1.360500e-09,6.760300e-08,1.311800e-07,2.338300e-07,1.648000e-07,& - & 1.775100e-09,7.652700e-08,1.406300e-07,2.285300e-07,1.728800e-07,& - & 2.515700e-09,8.969700e-08,1.575300e-07,2.345100e-07,1.829500e-07,& - & 3.757900e-09,1.087500e-07,1.819000e-07,2.526600e-07,1.963300e-07,& - & 8.871400e-10,4.974500e-08,1.065900e-07,2.126000e-07,1.256100e-07,& - & 1.032300e-09,5.336900e-08,1.063000e-07,1.954200e-07,1.317100e-07,& - & 1.305400e-09,5.966800e-08,1.116100e-07,1.877700e-07,1.380100e-07,& - & 1.797800e-09,6.899900e-08,1.232800e-07,1.891900e-07,1.454800e-07,& - & 2.647800e-09,8.283700e-08,1.409300e-07,2.005100e-07,1.551000e-07,& - & 7.018400e-10,4.019000e-08,8.821800e-08,1.813600e-07,9.973100e-08,& - & 7.919700e-10,4.234900e-08,8.675500e-08,1.641700e-07,1.049600e-07,& - & 9.713200e-10,4.671700e-08,8.917900e-08,1.551500e-07,1.100000e-07,& - & 1.297200e-09,5.338000e-08,9.695400e-08,1.536600e-07,1.156300e-07,& - & 1.872100e-09,6.324800e-08,1.095900e-07,1.599000e-07,1.225400e-07,& - & 5.609200e-10,3.264800e-08,7.311700e-08,1.551900e-07,7.897900e-08,& - & 6.142300e-10,3.382100e-08,7.113800e-08,1.388000e-07,8.327500e-08,& - & 7.309500e-10,3.676300e-08,7.182400e-08,1.290900e-07,8.740800e-08,& - & 9.459100e-10,4.149200e-08,7.660900e-08,1.256500e-07,9.172500e-08,& - & 1.330500e-09,4.845200e-08,8.551900e-08,1.283300e-07,9.678000e-08,& - & 4.534000e-10,2.671500e-08,6.084400e-08,1.327300e-07,6.376800e-08,& - & 4.835700e-10,2.724100e-08,5.866400e-08,1.175800e-07,6.702800e-08,& - & 5.595500e-10,2.913700e-08,5.834100e-08,1.077900e-07,7.046100e-08,& - & 7.036400e-10,3.250800e-08,6.104100e-08,1.033000e-07,7.390500e-08,& - & 9.634800e-10,3.751000e-08,6.723600e-08,1.037800e-07,7.779300e-08,& - & 3.701800e-10,2.187700e-08,5.074800e-08,1.138300e-07,5.214300e-08,& - & 3.846100e-10,2.205900e-08,4.849100e-08,9.981000e-08,5.453100e-08,& - & 4.331900e-10,2.321900e-08,4.765600e-08,9.029100e-08,5.735700e-08,& - & 5.303300e-10,2.560300e-08,4.894500e-08,8.528200e-08,6.011400e-08,& - & 7.066800e-10,2.923600e-08,5.316200e-08,8.441300e-08,6.315100e-08,& - & 3.044500e-10,1.793100e-08,4.237800e-08,9.853300e-08,4.276800e-08,& - & 3.083100e-10,1.793400e-08,4.011600e-08,8.490800e-08,4.444500e-08,& - & 3.382400e-10,1.860000e-08,3.906300e-08,7.599800e-08,4.673800e-08,& - & 4.033000e-10,2.024600e-08,3.949200e-08,7.078300e-08,4.895700e-08,& - & 5.228000e-10,2.287200e-08,4.219000e-08,6.900800e-08,5.133100e-08,& - & 2.518800e-10,1.475400e-08,3.543800e-08,8.575600e-08,3.519300e-08,& - & 2.491200e-10,1.467000e-08,3.333700e-08,7.243000e-08,3.627600e-08,& - & 2.665300e-10,1.498300e-08,3.218400e-08,6.424100e-08,3.812800e-08,& - & 3.093900e-10,1.606200e-08,3.206400e-08,5.902500e-08,3.992000e-08,& - & 3.902100e-10,1.794800e-08,3.363500e-08,5.668000e-08,4.178700e-08,& - & 2.092500e-10,1.217000e-08,2.971500e-08,7.467100e-08,2.910900e-08,& - & 2.031800e-10,1.201500e-08,2.776300e-08,6.186900e-08,2.978900e-08,& - & 2.120700e-10,1.213500e-08,2.658100e-08,5.438800e-08,3.125400e-08,& - & 2.399800e-10,1.281000e-08,2.617600e-08,4.933000e-08,3.270300e-08,& - & 2.950800e-10,1.415600e-08,2.697500e-08,4.672400e-08,3.416900e-08,& - & 1.725300e-10,9.990600e-09,2.454600e-08,6.252600e-08,2.455900e-08,& - & 1.664400e-10,9.831300e-09,2.286800e-08,5.148400e-08,2.530000e-08,& - & 1.720200e-10,9.896600e-09,2.182300e-08,4.506700e-08,2.645300e-08,& - & 1.927000e-10,1.038800e-08,2.141400e-08,4.070200e-08,2.751800e-08,& - & 2.345400e-10,1.143100e-08,2.192800e-08,3.836400e-08,2.865700e-08/ - data absb(1:300,3) / & - & 9.359200e-06,1.863500e-04,3.236000e-04,5.101300e-04,1.371900e-03,& - & 1.399700e-05,2.215000e-04,3.618600e-04,5.076600e-04,1.695200e-03,& - & 2.147200e-05,2.702900e-04,4.208600e-04,5.416000e-04,2.055900e-03,& - & 3.294900e-05,3.359500e-04,5.019000e-04,6.090900e-04,2.442200e-03,& - & 5.005500e-05,4.228300e-04,6.079400e-04,7.005700e-04,2.843100e-03,& - & 7.781100e-06,1.544300e-04,2.673100e-04,4.173700e-04,1.193700e-03,& - & 1.179000e-05,1.845400e-04,3.010400e-04,4.186100e-04,1.466100e-03,& - & 1.828100e-05,2.265100e-04,3.517700e-04,4.504900e-04,1.765900e-03,& - & 2.836100e-05,2.831900e-04,4.213600e-04,5.081400e-04,2.075900e-03,& - & 4.349600e-05,3.580600e-04,5.124000e-04,5.862600e-04,2.395500e-03,& - & 6.408500e-06,1.273200e-04,2.202100e-04,3.409300e-04,1.010400e-03,& - & 9.862000e-06,1.530300e-04,2.498200e-04,3.448700e-04,1.232700e-03,& - & 1.548300e-05,1.891300e-04,2.933100e-04,3.738500e-04,1.466000e-03,& - & 2.432900e-05,2.377200e-04,3.531300e-04,4.233000e-04,1.702100e-03,& - & 3.762000e-05,3.018100e-04,4.308100e-04,4.903700e-04,1.930900e-03,& - & 5.294400e-06,1.048900e-04,1.813900e-04,2.783600e-04,8.155300e-04,& - & 8.263900e-06,1.268500e-04,2.070800e-04,2.840900e-04,9.807800e-04,& - & 1.317100e-05,1.577500e-04,2.444300e-04,3.098800e-04,1.150300e-03,& - & 2.091200e-05,1.992900e-04,2.955400e-04,3.525200e-04,1.313100e-03,& - & 3.249600e-05,2.540900e-04,3.617900e-04,4.096300e-04,1.476000e-03,& - & 4.449300e-06,8.677000e-05,1.499100e-04,2.277100e-04,6.524500e-04,& - & 7.039500e-06,1.055900e-04,1.720300e-04,2.343000e-04,7.726200e-04,& - & 1.133500e-05,1.320800e-04,2.040700e-04,2.572200e-04,8.902800e-04,& - & 1.806900e-05,1.676500e-04,2.477900e-04,2.936800e-04,1.006300e-03,& - & 2.809000e-05,2.145500e-04,3.041200e-04,3.424900e-04,1.124800e-03,& - & 3.831600e-06,7.234700e-05,1.245800e-04,1.867300e-04,5.212200e-04,& - & 6.118400e-06,8.858000e-05,1.436100e-04,1.937700e-04,6.076700e-04,& - & 9.894700e-06,1.113500e-04,1.712000e-04,2.141000e-04,6.919400e-04,& - & 1.575600e-05,1.419000e-04,2.085500e-04,2.453100e-04,7.786800e-04,& - & 2.447200e-05,1.822700e-04,2.566700e-04,2.870800e-04,8.697500e-04,& - & 3.316700e-06,6.047200e-05,1.036100e-04,1.534400e-04,4.191200e-04,& - & 5.327500e-06,7.448500e-05,1.200200e-04,1.604900e-04,4.816700e-04,& - & 8.618200e-06,9.404800e-05,1.437500e-04,1.783900e-04,5.449800e-04,& - & 1.369700e-05,1.203400e-04,1.757000e-04,2.050800e-04,6.124400e-04,& - & 2.126100e-05,1.551600e-04,2.168000e-04,2.408900e-04,6.850900e-04,& - & 2.904900e-06,5.086300e-05,8.649700e-05,1.263100e-04,3.389800e-04,& - & 4.678200e-06,6.303700e-05,1.007700e-04,1.332800e-04,3.865800e-04,& - & 7.555100e-06,7.994900e-05,1.212700e-04,1.491200e-04,4.360800e-04,& - & 1.198500e-05,1.027200e-04,1.488000e-04,1.720900e-04,4.896800e-04,& - & 1.856400e-05,1.328900e-04,1.839500e-04,2.029000e-04,5.486200e-04,& - & 2.534800e-06,4.282700e-05,7.223900e-05,1.040500e-04,2.734700e-04,& - & 4.089600e-06,5.339200e-05,8.468200e-05,1.107800e-04,3.103300e-04,& - & 6.591100e-06,6.800200e-05,1.024000e-04,1.246800e-04,3.494500e-04,& - & 1.044300e-05,8.777700e-05,1.260400e-04,1.444800e-04,3.927000e-04,& - & 1.612600e-05,1.138400e-04,1.561900e-04,1.710000e-04,4.403200e-04,& - & 2.253500e-06,3.648400e-05,6.084400e-05,8.591500e-05,2.186100e-04,& - & 3.642100e-06,4.583800e-05,7.193000e-05,9.268800e-05,2.469500e-04,& - & 5.864900e-06,5.871600e-05,8.751600e-05,1.051200e-04,2.780500e-04,& - & 9.272400e-06,7.615800e-05,1.080900e-04,1.225600e-04,3.128300e-04,& - & 1.423700e-05,9.883400e-05,1.343200e-04,1.457100e-04,3.509500e-04,& - & 1.994000e-06,3.113300e-05,5.132800e-05,7.109000e-05,1.732700e-04,& - & 3.231200e-06,3.939900e-05,6.117900e-05,7.770800e-05,1.953100e-04,& - & 5.201100e-06,5.076800e-05,7.484700e-05,8.876000e-05,2.201700e-04,& - & 8.191900e-06,6.602300e-05,9.281500e-05,1.041300e-04,2.480900e-04,& - & 1.249800e-05,8.567600e-05,1.155000e-04,1.243000e-04,2.786100e-04,& - & 1.745900e-06,2.655800e-05,4.330200e-05,5.893100e-05,1.345600e-04,& - & 2.837800e-06,3.384000e-05,5.203400e-05,6.522100e-05,1.518400e-04,& - & 4.566800e-06,4.381200e-05,6.402700e-05,7.501500e-05,1.715600e-04,& - & 7.165500e-06,5.705600e-05,7.959700e-05,8.854500e-05,1.936800e-04,& - & 1.089100e-05,7.404100e-05,9.915600e-05,1.060200e-04,2.175900e-04/ - data absb(301:600,3) / & - & 1.535100e-06,2.273900e-05,3.666100e-05,4.903300e-05,1.046400e-04,& - & 2.501300e-06,2.915600e-05,4.440300e-05,5.490600e-05,1.183900e-04,& - & 4.019300e-06,3.786700e-05,5.490000e-05,6.359600e-05,1.340500e-04,& - & 6.281600e-06,4.936900e-05,6.836200e-05,7.547800e-05,1.514200e-04,& - & 9.514700e-06,6.400600e-05,8.521200e-05,9.053200e-05,1.699800e-04,& - & 1.368300e-06,1.960900e-05,3.123900e-05,4.102500e-05,8.252900e-05,& - & 2.231300e-06,2.526900e-05,3.812600e-05,4.643600e-05,9.360000e-05,& - & 3.575400e-06,3.291300e-05,4.729500e-05,5.419000e-05,1.061100e-04,& - & 5.566400e-06,4.291500e-05,5.895200e-05,6.458100e-05,1.196600e-04,& - & 8.392800e-06,5.554000e-05,7.347800e-05,7.757800e-05,1.340700e-04,& - & 1.217100e-06,1.692300e-05,2.666600e-05,3.442800e-05,6.483600e-05,& - & 1.986200e-06,2.189600e-05,3.275200e-05,3.933200e-05,7.365000e-05,& - & 3.175000e-06,2.859300e-05,4.072700e-05,4.621000e-05,8.336600e-05,& - & 4.925700e-06,3.724500e-05,5.078800e-05,5.524200e-05,9.374400e-05,& - & 7.393400e-06,4.809000e-05,6.324900e-05,6.641400e-05,1.049000e-04,& - & 1.079200e-06,1.460000e-05,2.278400e-05,2.895200e-05,5.048500e-05,& - & 1.762900e-06,1.897200e-05,2.812300e-05,3.334600e-05,5.727700e-05,& - & 2.813100e-06,2.480500e-05,3.504200e-05,3.940900e-05,6.462200e-05,& - & 4.351200e-06,3.225100e-05,4.369400e-05,4.721100e-05,7.260200e-05,& - & 6.498900e-06,4.155900e-05,5.433700e-05,5.676300e-05,8.133300e-05,& - & 9.685700e-07,1.266600e-05,1.955600e-05,2.444700e-05,3.952900e-05,& - & 1.581800e-06,1.651500e-05,2.423600e-05,2.836200e-05,4.469700e-05,& - & 2.516800e-06,2.158600e-05,3.022700e-05,3.368800e-05,5.041300e-05,& - & 3.872300e-06,2.801000e-05,3.766600e-05,4.041100e-05,5.668800e-05,& - & 5.746200e-06,3.601600e-05,4.676800e-05,4.856500e-05,6.355300e-05,& - & 8.705600e-07,1.100100e-05,1.680600e-05,2.067900e-05,3.064200e-05,& - & 1.420400e-06,1.437300e-05,2.089100e-05,2.415800e-05,3.464400e-05,& - & 2.251100e-06,1.876900e-05,2.605800e-05,2.879600e-05,3.911400e-05,& - & 3.445600e-06,2.431200e-05,3.244900e-05,3.457000e-05,4.402500e-05,& - & 5.079600e-06,3.120300e-05,4.024700e-05,4.152800e-05,4.943000e-05,& - & 7.880000e-07,9.584100e-06,1.448000e-05,1.753700e-05,2.370300e-05,& - & 1.282700e-06,1.253200e-05,1.803500e-05,2.061900e-05,2.682900e-05,& - & 2.022400e-06,1.634300e-05,2.248800e-05,2.463900e-05,3.030000e-05,& - & 3.073500e-06,2.113700e-05,2.798800e-05,2.959000e-05,3.417400e-05,& - & 4.501000e-06,2.705100e-05,3.464900e-05,3.551900e-05,3.844900e-05,& - & 7.164500e-07,8.362100e-06,1.249900e-05,1.490800e-05,1.844300e-05,& - & 1.161900e-06,1.094200e-05,1.558400e-05,1.762600e-05,2.088600e-05,& - & 1.820200e-06,1.424600e-05,1.942200e-05,2.109900e-05,2.364800e-05,& - & 2.746800e-06,1.838900e-05,2.415400e-05,2.534400e-05,2.672200e-05,& - & 3.993900e-06,2.345900e-05,2.984500e-05,3.039100e-05,3.012800e-05,& - & 6.527900e-07,7.302100e-06,1.079700e-05,1.269500e-05,1.440200e-05,& - & 1.053300e-06,9.555000e-06,1.346600e-05,1.507800e-05,1.632200e-05,& - & 1.638600e-06,1.242000e-05,1.677700e-05,1.807100e-05,1.850900e-05,& - & 2.455500e-06,1.600200e-05,2.085000e-05,2.171300e-05,2.096700e-05,& - & 3.543800e-06,2.033100e-05,2.569500e-05,2.600100e-05,2.364400e-05,& - & 5.886300e-07,6.333900e-06,9.273400e-06,1.077800e-05,1.146900e-05,& - & 9.444500e-07,8.284500e-06,1.156700e-05,1.283900e-05,1.301700e-05,& - & 1.459600e-06,1.075000e-05,1.440600e-05,1.539900e-05,1.477400e-05,& - & 2.172400e-06,1.381800e-05,1.787900e-05,1.849300e-05,1.672900e-05,& - & 3.114800e-06,1.749800e-05,2.198700e-05,2.213100e-05,1.882400e-05,& - & 5.053700e-07,5.349300e-06,7.791900e-06,9.003900e-06,8.978100e-06,& - & 8.091800e-07,6.993700e-06,9.719200e-06,1.073900e-05,1.021300e-05,& - & 1.247000e-06,9.068000e-06,1.210200e-05,1.288600e-05,1.159600e-05,& - & 1.850100e-06,1.164100e-05,1.500600e-05,1.547000e-05,1.311800e-05,& - & 2.644900e-06,1.471300e-05,1.843300e-05,1.850500e-05,1.474000e-05,& - & 4.105700e-07,4.381400e-06,6.385100e-06,7.378700e-06,6.870400e-06,& - & 6.588200e-07,5.729500e-06,7.964900e-06,8.801400e-06,7.831000e-06,& - & 1.016800e-06,7.430500e-06,9.917900e-06,1.056200e-05,8.907900e-06,& - & 1.510800e-06,9.539000e-06,1.229800e-05,1.267900e-05,1.008300e-05,& - & 2.161600e-06,1.205600e-05,1.510400e-05,1.516900e-05,1.134500e-05/ - data absb(601:900,3) / & - & 3.131500e-07,3.461000e-06,5.078000e-06,5.909900e-06,5.369200e-06,& - & 5.055300e-07,4.530000e-06,6.335600e-06,7.038100e-06,6.116000e-06,& - & 7.850200e-07,5.882200e-06,7.891000e-06,8.442000e-06,6.958700e-06,& - & 1.173100e-06,7.565400e-06,9.793600e-06,1.013700e-05,7.886000e-06,& - & 1.687400e-06,9.581000e-06,1.204500e-05,1.213200e-05,8.881000e-06,& - & 2.377100e-07,2.727400e-06,4.031100e-06,4.728100e-06,4.187700e-06,& - & 3.861200e-07,3.572700e-06,5.029600e-06,5.620000e-06,4.763000e-06,& - & 6.034800e-07,4.645700e-06,6.266100e-06,6.737000e-06,5.419600e-06,& - & 9.073500e-07,5.985600e-06,7.784000e-06,8.091300e-06,6.148400e-06,& - & 1.312700e-06,7.597500e-06,9.585900e-06,9.688000e-06,6.928800e-06,& - & 1.802300e-07,2.149100e-06,3.200000e-06,3.783700e-06,3.250200e-06,& - & 2.945600e-07,2.816400e-06,3.992100e-06,4.487700e-06,3.691400e-06,& - & 4.634400e-07,3.667600e-06,4.975100e-06,5.376000e-06,4.198300e-06,& - & 7.011900e-07,4.733500e-06,6.185200e-06,6.457900e-06,4.764800e-06,& - & 1.020200e-06,6.022000e-06,7.626700e-06,7.735500e-06,5.371200e-06,& - & 1.298800e-07,1.649000e-06,2.486200e-06,2.983700e-06,2.533100e-06,& - & 2.142100e-07,2.161500e-06,3.100300e-06,3.522900e-06,2.872300e-06,& - & 3.404600e-07,2.821300e-06,3.865500e-06,4.214400e-06,3.264600e-06,& - & 5.203100e-07,3.650600e-06,4.811200e-06,5.062600e-06,3.707500e-06,& - & 7.645000e-07,4.662100e-06,5.944800e-06,6.068500e-06,4.183900e-06,& - & 9.278800e-08,1.261100e-06,1.927100e-06,2.351400e-06,1.974800e-06,& - & 1.543800e-07,1.652700e-06,2.400400e-06,2.761400e-06,2.233700e-06,& - & 2.480200e-07,2.161700e-06,2.994500e-06,3.296700e-06,2.536400e-06,& - & 3.830600e-07,2.804000e-06,3.729800e-06,3.958400e-06,2.881300e-06,& - & 5.686600e-07,3.594300e-06,4.618300e-06,4.748400e-06,3.255500e-06,& - & 6.612300e-08,9.644200e-07,1.494300e-06,1.855700e-06,1.537900e-06,& - & 1.109000e-07,1.262900e-06,1.858100e-06,2.166400e-06,1.733600e-06,& - & 1.800600e-07,1.654600e-06,2.318600e-06,2.579000e-06,1.966000e-06,& - & 2.811200e-07,2.151300e-06,2.889700e-06,3.094300e-06,2.233100e-06,& - & 4.217600e-07,2.767600e-06,3.585400e-06,3.713900e-06,2.524700e-06,& - & 4.572300e-08,7.272100e-07,1.146800e-06,1.456100e-06,1.197000e-06,& - & 7.727900e-08,9.508600e-07,1.421400e-06,1.686900e-06,1.343600e-06,& - & 1.269800e-07,1.246900e-06,1.773400e-06,1.998800e-06,1.520100e-06,& - & 2.008700e-07,1.626100e-06,2.211700e-06,2.394800e-06,1.725700e-06,& - & 3.051700e-07,2.099700e-06,2.749200e-06,2.875600e-06,1.952600e-06,& - & 3.119500e-08,5.452900e-07,8.774000e-07,1.142800e-06,9.321200e-07,& - & 5.300200e-08,7.113200e-07,1.082100e-06,1.311700e-06,1.041100e-06,& - & 8.811600e-08,9.328100e-07,1.348800e-06,1.543900e-06,1.173300e-06,& - & 1.413500e-07,1.220100e-06,1.683300e-06,1.845700e-06,1.330500e-06,& - & 2.177200e-07,1.580900e-06,2.095600e-06,2.215900e-06,1.506300e-06,& - & 2.131000e-08,4.094400e-07,6.732700e-07,9.015300e-07,7.249700e-07,& - & 3.623100e-08,5.323500e-07,8.246200e-07,1.022700e-06,8.060600e-07,& - & 6.086000e-08,6.975200e-07,1.025700e-06,1.194600e-06,9.042100e-07,& - & 9.896600e-08,9.144200e-07,1.280800e-06,1.423200e-06,1.022800e-06,& - & 1.545800e-07,1.188500e-06,1.595700e-06,1.707100e-06,1.158100e-06,& - & 1.445500e-08,3.064700e-07,5.165700e-07,7.151700e-07,5.630900e-07,& - & 2.443800e-08,3.964400e-07,6.266800e-07,7.974000e-07,6.235700e-07,& - & 4.140000e-08,5.185000e-07,7.766700e-07,9.231200e-07,6.961900e-07,& - & 6.824100e-08,6.804500e-07,9.695100e-07,1.093900e-06,7.845500e-07,& - & 1.082100e-07,8.873900e-07,1.208900e-06,1.310100e-06,8.879400e-07,& - & 9.692900e-09,2.279700e-07,3.954200e-07,5.718200e-07,4.384700e-07,& - & 1.612300e-08,2.924200e-07,4.735900e-07,6.214100e-07,4.827100e-07,& - & 2.744700e-08,3.812900e-07,5.832800e-07,7.112000e-07,5.369200e-07,& - & 4.585500e-08,5.003000e-07,7.271000e-07,8.359200e-07,6.020600e-07,& - & 7.392300e-08,6.546700e-07,9.073300e-07,9.982900e-07,6.803100e-07,& - & 6.605800e-09,1.706300e-07,3.044700e-07,4.622400e-07,3.421700e-07,& - & 1.067000e-08,2.161800e-07,3.595800e-07,4.882400e-07,3.732500e-07,& - & 1.812800e-08,2.806000e-07,4.388100e-07,5.500700e-07,4.134800e-07,& - & 3.062400e-08,3.676600e-07,5.453500e-07,6.403600e-07,4.613700e-07,& - & 5.015100e-08,4.821700e-07,6.807100e-07,7.612300e-07,5.195500e-07/ - data absb(901:1175,3) / & - & 4.601400e-09,1.287200e-07,2.363300e-07,3.781400e-07,2.674800e-07,& - & 7.112700e-09,1.604000e-07,2.744500e-07,3.880400e-07,2.884100e-07,& - & 1.195100e-08,2.067500e-07,3.309800e-07,4.273800e-07,3.173400e-07,& - & 2.034100e-08,2.701900e-07,4.092900e-07,4.923000e-07,3.528400e-07,& - & 3.378900e-08,3.545700e-07,5.105100e-07,5.810400e-07,3.954300e-07,& - & 3.312300e-09,9.838900e-08,1.858300e-07,3.120000e-07,2.115100e-07,& - & 4.863500e-09,1.203400e-07,2.115600e-07,3.122300e-07,2.260600e-07,& - & 8.001700e-09,1.536600e-07,2.519000e-07,3.352100e-07,2.467600e-07,& - & 1.363800e-08,2.001200e-07,3.092800e-07,3.814100e-07,2.733600e-07,& - & 2.292200e-08,2.624100e-07,3.850200e-07,4.464800e-07,3.052800e-07,& - & 2.441800e-09,7.593300e-08,1.474200e-07,2.596800e-07,1.689100e-07,& - & 3.398900e-09,9.109500e-08,1.642800e-07,2.538500e-07,1.788900e-07,& - & 5.413900e-09,1.148200e-07,1.929900e-07,2.654200e-07,1.934400e-07,& - & 9.180300e-09,1.488100e-07,2.347700e-07,2.970900e-07,2.131800e-07,& - & 1.556700e-08,1.948100e-07,2.913100e-07,3.446400e-07,2.373400e-07,& - & 1.835600e-09,5.913800e-08,1.178800e-07,2.179200e-07,1.355100e-07,& - & 2.422600e-09,6.942700e-08,1.285300e-07,2.082700e-07,1.416700e-07,& - & 3.692100e-09,8.611700e-08,1.485500e-07,2.123000e-07,1.519500e-07,& - & 6.179300e-09,1.108000e-07,1.786500e-07,2.323800e-07,1.662300e-07,& - & 1.053300e-08,1.446800e-07,2.205500e-07,2.668900e-07,1.844000e-07,& - & 1.405700e-09,4.646000e-08,9.533500e-08,1.847600e-07,1.085900e-07,& - & 1.760700e-09,5.328500e-08,1.013900e-07,1.721500e-07,1.124200e-07,& - & 2.548800e-09,6.487100e-08,1.148800e-07,1.713200e-07,1.195100e-07,& - & 4.165700e-09,8.262900e-08,1.364100e-07,1.828300e-07,1.296500e-07,& - & 7.099700e-09,1.075000e-07,1.671500e-07,2.073200e-07,1.429600e-07,& - & 1.099900e-09,3.684600e-08,7.769700e-08,1.575400e-07,8.820600e-08,& - & 1.315600e-09,4.139900e-08,8.074900e-08,1.433100e-07,9.085400e-08,& - & 1.812400e-09,4.949300e-08,8.971000e-08,1.396200e-07,9.571200e-08,& - & 2.867700e-09,6.226400e-08,1.051800e-07,1.454200e-07,1.031200e-07,& - & 4.857100e-09,8.060200e-08,1.277400e-07,1.622900e-07,1.131500e-07,& - & 8.725400e-10,2.951100e-08,6.377300e-08,1.347200e-07,7.222400e-08,& - & 1.001900e-09,3.247000e-08,6.479500e-08,1.199600e-07,7.413100e-08,& - & 1.317100e-09,3.808100e-08,7.064200e-08,1.145800e-07,7.743800e-08,& - & 2.002100e-09,4.722100e-08,8.161400e-08,1.167400e-07,8.299800e-08,& - & 3.348200e-09,6.072700e-08,9.811300e-08,1.277400e-07,9.067200e-08,& - & 6.995000e-10,2.383800e-08,5.268000e-08,1.156200e-07,5.923400e-08,& - & 7.741300e-10,2.564400e-08,5.247200e-08,1.011700e-07,6.057200e-08,& - & 9.720800e-10,2.946500e-08,5.597200e-08,9.454800e-08,6.283400e-08,& - & 1.412100e-09,3.594000e-08,6.356200e-08,9.435300e-08,6.697000e-08,& - & 2.312800e-09,4.582200e-08,7.556800e-08,1.009800e-07,7.280800e-08,& - & 5.658100e-10,1.934600e-08,4.379000e-08,9.956500e-08,4.860200e-08,& - & 6.063800e-10,2.035200e-08,4.273700e-08,8.602000e-08,4.959800e-08,& - & 7.283500e-10,2.292800e-08,4.458800e-08,7.855400e-08,5.115600e-08,& - & 1.008900e-09,2.748700e-08,4.970400e-08,7.681200e-08,5.418800e-08,& - & 1.603400e-09,3.464100e-08,5.839200e-08,8.033100e-08,5.857400e-08,& - & 4.610300e-10,1.579300e-08,3.662700e-08,8.572600e-08,3.997800e-08,& - & 4.813000e-10,1.628600e-08,3.501500e-08,7.330700e-08,4.078900e-08,& - & 5.558500e-10,1.800400e-08,3.576400e-08,6.561000e-08,4.188400e-08,& - & 7.363000e-10,2.119800e-08,3.917100e-08,6.295900e-08,4.410000e-08,& - & 1.127600e-09,2.636600e-08,4.540300e-08,6.445800e-08,4.743100e-08,& - & 3.775500e-10,1.293200e-08,3.023200e-08,7.148000e-08,3.364700e-08,& - & 3.902800e-10,1.325200e-08,2.871600e-08,6.091900e-08,3.420900e-08,& - & 4.441500e-10,1.453100e-08,2.909900e-08,5.412900e-08,3.519700e-08,& - & 5.780400e-10,1.697900e-08,3.164500e-08,5.158800e-08,3.720300e-08,& - & 8.707300e-10,2.099700e-08,3.646900e-08,5.242800e-08,4.011500e-08/ - data absb(1:300,4) / & - & 8.929100e-05,3.852400e-04,5.083800e-04,6.586500e-04,3.842200e-03,& - & 1.215000e-04,5.039500e-04,6.250200e-04,7.159100e-04,4.493400e-03,& - & 1.672200e-04,6.639100e-04,7.860500e-04,8.200100e-04,5.096700e-03,& - & 2.316700e-04,8.669000e-04,9.973800e-04,9.696000e-04,5.686200e-03,& - & 3.206600e-04,1.114900e-03,1.257200e-03,1.172300e-03,6.288600e-03,& - & 7.306900e-05,3.244300e-04,4.257200e-04,5.456500e-04,3.232400e-03,& - & 1.007800e-04,4.278800e-04,5.277300e-04,5.981200e-04,3.708300e-03,& - & 1.406600e-04,5.656400e-04,6.684600e-04,6.898200e-04,4.160100e-03,& - & 1.970800e-04,7.397400e-04,8.502100e-04,8.216500e-04,4.625600e-03,& - & 2.752300e-04,9.528100e-04,1.071300e-03,9.974500e-04,5.117700e-03,& - & 5.826800e-05,2.720300e-04,3.560400e-04,4.520600e-04,2.535500e-03,& - & 8.180500e-05,3.609800e-04,4.446700e-04,4.995600e-04,2.858100e-03,& - & 1.162000e-04,4.791000e-04,5.664100e-04,5.804400e-04,3.190300e-03,& - & 1.650100e-04,6.281000e-04,7.214800e-04,6.957700e-04,3.550100e-03,& - & 2.330100e-04,8.114400e-04,9.102700e-04,8.472600e-04,3.946300e-03,& - & 4.611500e-05,2.274200e-04,2.976000e-04,3.744100e-04,1.863500e-03,& - & 6.604400e-05,3.038800e-04,3.743200e-04,4.170900e-04,2.089600e-03,& - & 9.551300e-05,4.049400e-04,4.788100e-04,4.883300e-04,2.337300e-03,& - & 1.376800e-04,5.322900e-04,6.107300e-04,5.883600e-04,2.620100e-03,& - & 1.967600e-04,6.891600e-04,7.722300e-04,7.181100e-04,2.912800e-03,& - & 3.723600e-05,1.911700e-04,2.492800e-04,3.103600e-04,1.378100e-03,& - & 5.429100e-05,2.569300e-04,3.156500e-04,3.486700e-04,1.550500e-03,& - & 7.974900e-05,3.433200e-04,4.049800e-04,4.112700e-04,1.750200e-03,& - & 1.165300e-04,4.521000e-04,5.174400e-04,4.971500e-04,1.965400e-03,& - & 1.684800e-04,5.856700e-04,6.548700e-04,6.082800e-04,2.186700e-03,& - & 3.121400e-05,1.626500e-04,2.100100e-04,2.578900e-04,1.050800e-03,& - & 4.611500e-05,2.192800e-04,2.676400e-04,2.923500e-04,1.192500e-03,& - & 6.852600e-05,2.931100e-04,3.439500e-04,3.466200e-04,1.352200e-03,& - & 1.010800e-04,3.859500e-04,4.397200e-04,4.205000e-04,1.520000e-03,& - & 1.472400e-04,4.997900e-04,5.562000e-04,5.150800e-04,1.688400e-03,& - & 2.649400e-05,1.387700e-04,1.775200e-04,2.145600e-04,8.326700e-04,& - & 3.964500e-05,1.873500e-04,2.271700e-04,2.453100e-04,9.516800e-04,& - & 5.944100e-05,2.503100e-04,2.922300e-04,2.920300e-04,1.081400e-03,& - & 8.834100e-05,3.295400e-04,3.734600e-04,3.551600e-04,1.214300e-03,& - & 1.295200e-04,4.267400e-04,4.723200e-04,4.356500e-04,1.345300e-03,& - & 2.295300e-05,1.192300e-04,1.510600e-04,1.790600e-04,6.753100e-04,& - & 3.468400e-05,1.609600e-04,1.938700e-04,2.064500e-04,7.736000e-04,& - & 5.238700e-05,2.149300e-04,2.493900e-04,2.467400e-04,8.792700e-04,& - & 7.833900e-05,2.828700e-04,3.186700e-04,3.009400e-04,9.845700e-04,& - & 1.153200e-04,3.665500e-04,4.033200e-04,3.695500e-04,1.089000e-03,& - & 1.993900e-05,1.023000e-04,1.285800e-04,1.496800e-04,5.486900e-04,& - & 3.042700e-05,1.381600e-04,1.653100e-04,1.737500e-04,6.293200e-04,& - & 4.630100e-05,1.845300e-04,2.126900e-04,2.084800e-04,7.142400e-04,& - & 6.961200e-05,2.428800e-04,2.718900e-04,2.549700e-04,7.979900e-04,& - & 1.025500e-04,3.149600e-04,3.445200e-04,3.135600e-04,8.817800e-04,& - & 1.765000e-05,8.909900e-05,1.108600e-04,1.261700e-04,4.413600e-04,& - & 2.725600e-05,1.204000e-04,1.428800e-04,1.477000e-04,5.062500e-04,& - & 4.178400e-05,1.608200e-04,1.839100e-04,1.782500e-04,5.725900e-04,& - & 6.296300e-05,2.116800e-04,2.352800e-04,2.186900e-04,6.383100e-04,& - & 9.247900e-05,2.747300e-04,2.983400e-04,2.693600e-04,7.051100e-04,& - & 1.566100e-05,7.757000e-05,9.560600e-05,1.064900e-04,3.528200e-04,& - & 2.441900e-05,1.049200e-04,1.235000e-04,1.256900e-04,4.038900e-04,& - & 3.761700e-05,1.402100e-04,1.591400e-04,1.525300e-04,4.553500e-04,& - & 5.662300e-05,1.845900e-04,2.037800e-04,1.877200e-04,5.073400e-04,& - & 8.285000e-05,2.395500e-04,2.586800e-04,2.316800e-04,5.607300e-04,& - & 1.376100e-05,6.731300e-05,8.238700e-05,8.998500e-05,2.765700e-04,& - & 2.166000e-05,9.121400e-05,1.066300e-04,1.070300e-04,3.156400e-04,& - & 3.347100e-05,1.219800e-04,1.376700e-04,1.306200e-04,3.553600e-04,& - & 5.031300e-05,1.606600e-04,1.764600e-04,1.612700e-04,3.963300e-04,& - & 7.336000e-05,2.082900e-04,2.241400e-04,1.993900e-04,4.396400e-04/ - data absb(301:600,4) / & - & 1.216300e-05,5.863200e-05,7.121000e-05,7.628900e-05,2.155700e-04,& - & 1.926200e-05,7.956300e-05,9.238400e-05,9.143100e-05,2.454800e-04,& - & 2.976800e-05,1.064500e-04,1.194200e-04,1.122200e-04,2.763600e-04,& - & 4.463500e-05,1.400600e-04,1.531600e-04,1.389200e-04,3.091300e-04,& - & 6.472300e-05,1.812200e-04,1.944600e-04,1.720300e-04,3.445900e-04,& - & 1.090500e-05,5.150900e-05,6.198200e-05,6.504800e-05,1.691200e-04,& - & 1.730100e-05,6.993800e-05,8.056400e-05,7.859400e-05,1.923500e-04,& - & 2.667400e-05,9.347800e-05,1.042000e-04,9.693300e-05,2.169200e-04,& - & 3.981000e-05,1.226000e-04,1.335800e-04,1.203100e-04,2.437200e-04,& - & 5.726900e-05,1.581900e-04,1.692900e-04,1.490400e-04,2.728300e-04,& - & 9.744300e-06,4.525600e-05,5.397700e-05,5.556400e-05,1.307900e-04,& - & 1.546800e-05,6.143400e-05,7.024000e-05,6.766100e-05,1.488500e-04,& - & 2.378500e-05,8.187600e-05,9.086800e-05,8.380100e-05,1.685700e-04,& - & 3.528900e-05,1.070500e-04,1.162800e-04,1.041800e-04,1.903800e-04,& - & 5.035200e-05,1.376300e-04,1.470500e-04,1.289100e-04,2.139900e-04,& - & 8.666200e-06,3.971000e-05,4.697300e-05,4.754500e-05,9.957300e-05,& - & 1.376200e-05,5.380800e-05,6.119100e-05,5.831200e-05,1.137800e-04,& - & 2.108700e-05,7.145800e-05,7.907100e-05,7.242800e-05,1.296900e-04,& - & 3.107300e-05,9.312700e-05,1.009700e-04,9.007900e-05,1.471300e-04,& - & 4.403200e-05,1.191900e-04,1.272600e-04,1.112800e-04,1.660300e-04,& - & 7.799800e-06,3.499600e-05,4.103600e-05,4.086500e-05,7.646200e-05,& - & 1.235100e-05,4.725300e-05,5.343600e-05,5.040900e-05,8.783600e-05,& - & 1.879900e-05,6.249800e-05,6.890900e-05,6.272700e-05,1.004700e-04,& - & 2.748500e-05,8.109500e-05,8.773100e-05,7.797300e-05,1.143400e-04,& - & 3.868100e-05,1.032400e-04,1.100900e-04,9.609200e-05,1.293700e-04,& - & 7.018400e-06,3.079300e-05,3.583500e-05,3.518100e-05,5.853900e-05,& - & 1.105900e-05,4.141900e-05,4.660500e-05,4.358500e-05,6.750400e-05,& - & 1.670700e-05,5.455000e-05,5.993700e-05,5.429500e-05,7.747100e-05,& - & 2.426100e-05,7.041600e-05,7.604300e-05,6.739400e-05,8.846800e-05,& - & 3.392000e-05,8.925900e-05,9.502000e-05,8.283400e-05,1.002600e-04,& - & 6.344600e-06,2.713000e-05,3.132600e-05,3.036400e-05,4.477800e-05,& - & 9.924000e-06,3.633000e-05,4.066700e-05,3.773200e-05,5.177600e-05,& - & 1.488300e-05,4.759300e-05,5.213400e-05,4.701500e-05,5.960300e-05,& - & 2.145400e-05,6.112000e-05,6.584700e-05,5.820700e-05,6.810400e-05,& - & 2.977000e-05,7.711400e-05,8.193500e-05,7.130900e-05,7.716300e-05,& - & 5.744700e-06,2.390900e-05,2.740200e-05,2.625600e-05,3.447500e-05,& - & 8.914600e-06,3.184900e-05,3.548700e-05,3.269500e-05,3.993400e-05,& - & 1.327100e-05,4.148100e-05,4.530500e-05,4.070300e-05,4.600200e-05,& - & 1.898200e-05,5.301500e-05,5.696900e-05,5.023000e-05,5.254600e-05,& - & 2.612900e-05,6.663400e-05,7.062500e-05,6.135900e-05,5.950700e-05,& - & 5.198100e-06,2.104800e-05,2.395900e-05,2.272700e-05,2.659100e-05,& - & 8.004500e-06,2.786300e-05,3.092800e-05,2.832900e-05,3.079500e-05,& - & 1.182600e-05,3.610700e-05,3.931100e-05,3.520000e-05,3.543700e-05,& - & 1.678000e-05,4.595500e-05,4.924900e-05,4.332100e-05,4.042200e-05,& - & 2.290300e-05,5.751900e-05,6.083500e-05,5.276500e-05,4.573900e-05,& - & 4.658000e-06,1.836500e-05,2.079200e-05,1.956200e-05,2.097300e-05,& - & 7.119500e-06,2.417800e-05,2.674100e-05,2.438500e-05,2.425300e-05,& - & 1.044200e-05,3.119600e-05,3.386300e-05,3.022700e-05,2.782700e-05,& - & 1.470300e-05,3.955600e-05,4.228100e-05,3.710500e-05,3.169400e-05,& - & 1.992200e-05,4.935100e-05,5.208200e-05,4.510200e-05,3.582400e-05,& - & 3.987100e-06,1.555100e-05,1.757100e-05,1.647500e-05,1.623600e-05,& - & 6.075700e-06,2.041400e-05,2.254200e-05,2.052700e-05,1.874100e-05,& - & 8.879400e-06,2.628100e-05,2.849000e-05,2.540500e-05,2.147300e-05,& - & 1.245500e-05,3.325300e-05,3.551100e-05,3.114700e-05,2.445800e-05,& - & 1.681700e-05,4.141700e-05,4.368000e-05,3.781200e-05,2.766800e-05,& - & 3.242100e-06,1.274100e-05,1.441500e-05,1.353200e-05,1.230500e-05,& - & 4.948900e-06,1.672100e-05,1.848200e-05,1.685600e-05,1.419700e-05,& - & 7.242000e-06,2.152500e-05,2.335400e-05,2.085700e-05,1.627900e-05,& - & 1.016500e-05,2.723500e-05,2.910600e-05,2.556400e-05,1.856800e-05,& - & 1.373100e-05,3.392400e-05,3.579800e-05,3.103500e-05,2.102800e-05/ - data absb(601:900,4) / & - & 2.496000e-06,1.006000e-05,1.142400e-05,1.078200e-05,9.508600e-06,& - & 3.836300e-06,1.323600e-05,1.467300e-05,1.343100e-05,1.097700e-05,& - & 5.648800e-06,1.707600e-05,1.857200e-05,1.663500e-05,1.259400e-05,& - & 7.974700e-06,2.165200e-05,2.318800e-05,2.041500e-05,1.437400e-05,& - & 1.082500e-05,2.702100e-05,2.856600e-05,2.481100e-05,1.629100e-05,& - & 1.912400e-06,7.918300e-06,9.031600e-06,8.574300e-06,7.323600e-06,& - & 2.961000e-06,1.045000e-05,1.162100e-05,1.068000e-05,8.461400e-06,& - & 4.388400e-06,1.351500e-05,1.473500e-05,1.324100e-05,9.713600e-06,& - & 6.234400e-06,1.717700e-05,1.843500e-05,1.627200e-05,1.109400e-05,& - & 8.507400e-06,2.148000e-05,2.274900e-05,1.980100e-05,1.258700e-05,& - & 1.462700e-06,6.228000e-06,7.135800e-06,6.816400e-06,5.609100e-06,& - & 2.281900e-06,8.243700e-06,9.199100e-06,8.490000e-06,6.483700e-06,& - & 3.404000e-06,1.068900e-05,1.168700e-05,1.053500e-05,7.450700e-06,& - & 4.866700e-06,1.361900e-05,1.464900e-05,1.296500e-05,8.514400e-06,& - & 6.678900e-06,1.706500e-05,1.810900e-05,1.579600e-05,9.672400e-06,& - & 1.067500e-06,4.758000e-06,5.494800e-06,5.305900e-06,4.323500e-06,& - & 1.685400e-06,6.331600e-06,7.106500e-06,6.605900e-06,5.003700e-06,& - & 2.541600e-06,8.247500e-06,9.058400e-06,8.207800e-06,5.759800e-06,& - & 3.673200e-06,1.055200e-05,1.139200e-05,1.012500e-05,6.592100e-06,& - & 5.089500e-06,1.327000e-05,1.412500e-05,1.236200e-05,7.498300e-06,& - & 7.716100e-07,3.615300e-06,4.213500e-06,4.120800e-06,3.329100e-06,& - & 1.234100e-06,4.839800e-06,5.466700e-06,5.124500e-06,3.857200e-06,& - & 1.883000e-06,6.335800e-06,6.993700e-06,6.374200e-06,4.447500e-06,& - & 2.752400e-06,8.142200e-06,8.825300e-06,7.880600e-06,5.100100e-06,& - & 3.853300e-06,1.028000e-05,1.098000e-05,9.644500e-06,5.808800e-06,& - & 5.552500e-07,2.741600e-06,3.227300e-06,3.201900e-06,2.556100e-06,& - & 8.999300e-07,3.692400e-06,4.199800e-06,3.974000e-06,2.963800e-06,& - & 1.390000e-06,4.859700e-06,5.393300e-06,4.946500e-06,3.423000e-06,& - & 2.055200e-06,6.273500e-06,6.829500e-06,6.128400e-06,3.932600e-06,& - & 2.908400e-06,7.954100e-06,8.526400e-06,7.519000e-06,4.487100e-06,& - & 3.870000e-07,2.040300e-06,2.434300e-06,2.462900e-06,1.955900e-06,& - & 6.376800e-07,2.768300e-06,3.178000e-06,3.045500e-06,2.267700e-06,& - & 9.999200e-07,3.668800e-06,4.099600e-06,3.791500e-06,2.624100e-06,& - & 1.498700e-06,4.763700e-06,5.214000e-06,4.707600e-06,3.020700e-06,& - & 2.150100e-06,6.071400e-06,6.536100e-06,5.793400e-06,3.454100e-06,& - & 2.647300e-07,1.502600e-06,1.822100e-06,1.889700e-06,1.493000e-06,& - & 4.443100e-07,2.056100e-06,2.386600e-06,2.322900e-06,1.730000e-06,& - & 7.083600e-07,2.745700e-06,3.092700e-06,2.889400e-06,2.004600e-06,& - & 1.077800e-06,3.588800e-06,3.952900e-06,3.594100e-06,2.312200e-06,& - & 1.569600e-06,4.601500e-06,4.978600e-06,4.437300e-06,2.649900e-06,& - & 1.798800e-07,1.103800e-06,1.362500e-06,1.454000e-06,1.137100e-06,& - & 3.076100e-07,1.522500e-06,1.789800e-06,1.773800e-06,1.316000e-06,& - & 4.989300e-07,2.049400e-06,2.328700e-06,2.201700e-06,1.525800e-06,& - & 7.711700e-07,2.697400e-06,2.991300e-06,2.741600e-06,1.763200e-06,& - & 1.139900e-06,3.479700e-06,3.785100e-06,3.394300e-06,2.025200e-06,& - & 1.199500e-07,8.029200e-07,1.012100e-06,1.118400e-06,8.648800e-07,& - & 2.092300e-07,1.116600e-06,1.333100e-06,1.351100e-06,9.984900e-07,& - & 3.458200e-07,1.516100e-06,1.740900e-06,1.670000e-06,1.157900e-06,& - & 5.438400e-07,2.011400e-06,2.248100e-06,2.080300e-06,1.340100e-06,& - & 8.166900e-07,2.612300e-06,2.859600e-06,2.582200e-06,1.542400e-06,& - & 7.755200e-08,5.743000e-07,7.435200e-07,8.591300e-07,6.583400e-07,& - & 1.381500e-07,8.054700e-07,9.805500e-07,1.024100e-06,7.578500e-07,& - & 2.333800e-07,1.104600e-06,1.285500e-06,1.256700e-06,8.775300e-07,& - & 3.743900e-07,1.479300e-06,1.669000e-06,1.563600e-06,1.016800e-06,& - & 5.723800e-07,1.936400e-06,2.135700e-06,1.945100e-06,1.172600e-06,& - & 4.975900e-08,4.098200e-07,5.473400e-07,6.659700e-07,5.005500e-07,& - & 9.039900e-08,5.789900e-07,7.204100e-07,7.795200e-07,5.740700e-07,& - & 1.561300e-07,8.015500e-07,9.475400e-07,9.474200e-07,6.628800e-07,& - & 2.556300e-07,1.083700e-06,1.235900e-06,1.175000e-06,7.686000e-07,& - & 3.982400e-07,1.431000e-06,1.591300e-06,1.463400e-06,8.875600e-07/ - data absb(901:1175,4) / & - & 3.174700e-08,2.920200e-07,4.045800e-07,5.218500e-07,3.807400e-07,& - & 5.862000e-08,4.147600e-07,5.288900e-07,5.964300e-07,4.332200e-07,& - & 1.034900e-07,5.792500e-07,6.973100e-07,7.164700e-07,4.988900e-07,& - & 1.731100e-07,7.908300e-07,9.131200e-07,8.833500e-07,5.776000e-07,& - & 2.750200e-07,1.053900e-06,1.182600e-06,1.100000e-06,6.679900e-07,& - & 2.058400e-08,2.100800e-07,3.030100e-07,4.149500e-07,2.949700e-07,& - & 3.834800e-08,2.990500e-07,3.914900e-07,4.617100e-07,3.320000e-07,& - & 6.900100e-08,4.207300e-07,5.162600e-07,5.467700e-07,3.806300e-07,& - & 1.178300e-07,5.796500e-07,6.782900e-07,6.688700e-07,4.399100e-07,& - & 1.907600e-07,7.794700e-07,8.826900e-07,8.315400e-07,5.091300e-07,& - & 1.349300e-08,1.521100e-07,2.292900e-07,3.338500e-07,2.307700e-07,& - & 2.512200e-08,2.161100e-07,2.914500e-07,3.610600e-07,2.567600e-07,& - & 4.597800e-08,3.059600e-07,3.831600e-07,4.198400e-07,2.925700e-07,& - & 8.011000e-08,4.251100e-07,5.048300e-07,5.087700e-07,3.373700e-07,& - & 1.321500e-07,5.766800e-07,6.596500e-07,6.302900e-07,3.904300e-07,& - & 8.923000e-09,1.107100e-07,1.752300e-07,2.719000e-07,1.811800e-07,& - & 1.641100e-08,1.560600e-07,2.178500e-07,2.850500e-07,1.992300e-07,& - & 3.043900e-08,2.219500e-07,2.843800e-07,3.239400e-07,2.248500e-07,& - & 5.407300e-08,3.108000e-07,3.753500e-07,3.881300e-07,2.582700e-07,& - & 9.096100e-08,4.253400e-07,4.921500e-07,4.780000e-07,2.986400e-07,& - & 5.987600e-09,8.120100e-08,1.353600e-07,2.243400e-07,1.430600e-07,& - & 1.071700e-08,1.127200e-07,1.638300e-07,2.274800e-07,1.549500e-07,& - & 2.001500e-08,1.606000e-07,2.112500e-07,2.516200e-07,1.728400e-07,& - & 3.620900e-08,2.264300e-07,2.786900e-07,2.970600e-07,1.972300e-07,& - & 6.216100e-08,3.126300e-07,3.665500e-07,3.629200e-07,2.277000e-07,& - & 4.165500e-09,6.069900e-08,1.063100e-07,1.869500e-07,1.150400e-07,& - & 7.166200e-09,8.250600e-08,1.249800e-07,1.836000e-07,1.231100e-07,& - & 1.335300e-08,1.173200e-07,1.586300e-07,1.978100e-07,1.360900e-07,& - & 2.452700e-08,1.663200e-07,2.086000e-07,2.295400e-07,1.543100e-07,& - & 4.288300e-08,2.313900e-07,2.750700e-07,2.778900e-07,1.776600e-07,& - & 2.981500e-09,4.599400e-08,8.452500e-08,1.573500e-07,9.346200e-08,& - & 4.872300e-09,6.094000e-08,9.639100e-08,1.497400e-07,9.900600e-08,& - & 8.968300e-09,8.606100e-08,1.199600e-07,1.569800e-07,1.086900e-07,& - & 1.666100e-08,1.224900e-07,1.567700e-07,1.785200e-07,1.225000e-07,& - & 2.962900e-08,1.716100e-07,2.070500e-07,2.139400e-07,1.406000e-07,& - & 2.186100e-09,3.524300e-08,6.784200e-08,1.333800e-07,7.607100e-08,& - & 3.351800e-09,4.529200e-08,7.496200e-08,1.233500e-07,7.996500e-08,& - & 6.027200e-09,6.316500e-08,9.116800e-08,1.256200e-07,8.702100e-08,& - & 1.126900e-08,9.006800e-08,1.179200e-07,1.395600e-07,9.747900e-08,& - & 2.036200e-08,1.269800e-07,1.557100e-07,1.651500e-07,1.114800e-07,& - & 1.640900e-09,2.738600e-08,5.484800e-08,1.138800e-07,6.203300e-08,& - & 2.342800e-09,3.393000e-08,5.887500e-08,1.025100e-07,6.487000e-08,& - & 4.062500e-09,4.642300e-08,6.967400e-08,1.013300e-07,6.986600e-08,& - & 7.588000e-09,6.613800e-08,8.886200e-08,1.097700e-07,7.774600e-08,& - & 1.391500e-08,9.373800e-08,1.170200e-07,1.278600e-07,8.858600e-08,& - & 1.263500e-09,2.160400e-08,4.473100e-08,9.755200e-08,5.082800e-08,& - & 1.681400e-09,2.576200e-08,4.678600e-08,8.597600e-08,5.291100e-08,& - & 2.783500e-09,3.442700e-08,5.381500e-08,8.246900e-08,5.651500e-08,& - & 5.149700e-09,4.880600e-08,6.742500e-08,8.708500e-08,6.250400e-08,& - & 9.553300e-09,6.944600e-08,8.833600e-08,9.962500e-08,7.098800e-08,& - & 1.015800e-09,1.749000e-08,3.665100e-08,8.133000e-08,4.275000e-08,& - & 1.316100e-09,2.054300e-08,3.794200e-08,7.109800e-08,4.450600e-08,& - & 2.132500e-09,2.719100e-08,4.318000e-08,6.750600e-08,4.766400e-08,& - & 3.920600e-09,3.843500e-08,5.371100e-08,7.058700e-08,5.296100e-08,& - & 7.299100e-09,5.476000e-08,7.019900e-08,8.015800e-08,6.035600e-08/ - data absb(1:300,5) / & - & 4.727900e-04,8.709800e-04,9.054300e-04,9.382300e-04,7.891900e-03,& - & 6.417700e-04,1.172800e-03,1.186500e-03,1.110800e-03,8.680900e-03,& - & 8.777100e-04,1.552000e-03,1.545700e-03,1.362400e-03,9.635800e-03,& - & 1.191300e-03,2.024700e-03,1.986400e-03,1.688300e-03,1.069700e-02,& - & 1.584900e-03,2.608700e-03,2.521400e-03,2.090200e-03,1.183200e-02,& - & 3.979700e-04,7.426400e-04,7.713100e-04,7.891700e-04,6.387500e-03,& - & 5.488300e-04,1.004100e-03,1.016400e-03,9.446200e-04,7.122800e-03,& - & 7.576400e-04,1.336000e-03,1.328100e-03,1.166000e-03,7.945100e-03,& - & 1.031800e-03,1.752500e-03,1.714500e-03,1.450600e-03,8.833700e-03,& - & 1.376400e-03,2.265800e-03,2.186000e-03,1.801400e-03,9.739100e-03,& - & 3.316400e-04,6.308500e-04,6.575300e-04,6.637700e-04,4.873600e-03,& - & 4.643100e-04,8.579100e-04,8.704100e-04,8.024600e-04,5.486400e-03,& - & 6.463500e-04,1.147700e-03,1.141300e-03,9.966400e-04,6.151900e-03,& - & 8.854200e-04,1.511800e-03,1.479700e-03,1.245000e-03,6.838400e-03,& - & 1.186000e-03,1.960700e-03,1.891700e-03,1.551400e-03,7.533000e-03,& - & 2.754700e-04,5.354000e-04,5.598600e-04,5.585000e-04,3.557100e-03,& - & 3.907600e-04,7.321000e-04,7.444900e-04,6.818200e-04,4.037600e-03,& - & 5.491400e-04,9.838800e-04,9.797500e-04,8.514800e-04,4.540000e-03,& - & 7.564700e-04,1.301300e-03,1.275000e-03,1.067300e-03,5.049100e-03,& - & 1.016800e-03,1.689400e-03,1.632700e-03,1.334700e-03,5.586400e-03,& - & 2.315200e-04,4.564000e-04,4.775300e-04,4.715200e-04,2.647900e-03,& - & 3.321500e-04,6.260000e-04,6.369000e-04,5.806900e-04,3.016300e-03,& - & 4.696000e-04,8.446600e-04,8.411300e-04,7.279500e-04,3.392400e-03,& - & 6.489000e-04,1.119000e-03,1.098100e-03,9.156000e-04,3.787600e-03,& - & 8.735700e-04,1.454200e-03,1.406700e-03,1.149000e-03,4.201500e-03,& - & 1.993200e-04,3.915300e-04,4.089400e-04,3.998300e-04,2.039200e-03,& - & 2.874000e-04,5.380200e-04,5.467000e-04,4.954800e-04,2.321800e-03,& - & 4.068800e-04,7.276900e-04,7.247300e-04,6.236700e-04,2.617100e-03,& - & 5.621200e-04,9.644200e-04,9.462200e-04,7.876700e-04,2.928600e-03,& - & 7.565700e-04,1.252300e-03,1.212600e-03,9.898701e-04,3.258400e-03,& - & 1.730000e-04,3.361500e-04,3.501000e-04,3.392000e-04,1.624900e-03,& - & 2.499000e-04,4.631400e-04,4.693000e-04,4.225300e-04,1.850900e-03,& - & 3.537400e-04,6.268100e-04,6.235400e-04,5.346200e-04,2.090300e-03,& - & 4.880800e-04,8.300000e-04,8.136800e-04,6.769300e-04,2.344200e-03,& - & 6.562200e-04,1.076300e-03,1.041500e-03,8.510000e-04,2.614900e-03,& - & 1.520200e-04,2.908900e-04,3.011800e-04,2.884700e-04,1.319500e-03,& - & 2.194700e-04,4.013700e-04,4.048800e-04,3.616000e-04,1.505100e-03,& - & 3.100500e-04,5.422900e-04,5.377300e-04,4.593400e-04,1.701100e-03,& - & 4.268700e-04,7.164100e-04,7.006200e-04,5.821300e-04,1.912600e-03,& - & 5.724300e-04,9.282500e-04,8.956500e-04,7.313500e-04,2.135200e-03,& - & 1.334200e-04,2.520700e-04,2.592700e-04,2.452900e-04,1.074100e-03,& - & 1.923300e-04,3.475300e-04,3.490600e-04,3.093400e-04,1.226200e-03,& - & 2.710800e-04,4.683600e-04,4.629500e-04,3.938700e-04,1.388500e-03,& - & 3.722800e-04,6.177700e-04,6.020000e-04,4.988700e-04,1.562600e-03,& - & 4.991100e-04,7.995100e-04,7.686400e-04,6.263700e-04,1.744300e-03,& - & 1.187600e-04,2.223200e-04,2.272300e-04,2.114400e-04,8.647500e-04,& - & 1.709800e-04,3.054700e-04,3.055600e-04,2.682700e-04,9.881700e-04,& - & 2.402400e-04,4.104300e-04,4.041200e-04,3.417100e-04,1.121300e-03,& - & 3.295400e-04,5.402800e-04,5.241400e-04,4.323800e-04,1.261900e-03,& - & 4.418700e-04,6.976100e-04,6.680900e-04,5.424900e-04,1.408000e-03,& - & 1.053300e-04,1.957300e-04,1.991000e-04,1.826900e-04,6.925700e-04,& - & 1.515500e-04,2.681600e-04,2.672000e-04,2.326200e-04,7.930800e-04,& - & 2.127400e-04,3.592100e-04,3.524400e-04,2.961600e-04,9.006800e-04,& - & 2.919000e-04,4.719100e-04,4.559300e-04,3.744500e-04,1.013600e-03,& - & 3.913800e-04,6.087800e-04,5.805900e-04,4.696800e-04,1.130600e-03,& - & 9.258200e-05,1.716700e-04,1.739800e-04,1.578100e-04,5.467700e-04,& - & 1.334400e-04,2.345600e-04,2.331500e-04,2.013900e-04,6.278200e-04,& - & 1.876900e-04,3.136500e-04,3.067000e-04,2.563700e-04,7.142000e-04,& - & 2.577300e-04,4.117400e-04,3.963000e-04,3.240200e-04,8.043100e-04,& - & 3.454900e-04,5.312400e-04,5.044900e-04,4.065300e-04,8.975900e-04/ - data absb(301:600,5) / & - & 8.172000e-05,1.508000e-04,1.523500e-04,1.366200e-04,4.324000e-04,& - & 1.180500e-04,2.055800e-04,2.036700e-04,1.746000e-04,4.974800e-04,& - & 1.663200e-04,2.745900e-04,2.674600e-04,2.222700e-04,5.666200e-04,& - & 2.282000e-04,3.603200e-04,3.453900e-04,2.810700e-04,6.385300e-04,& - & 3.050900e-04,4.649700e-04,4.399300e-04,3.528900e-04,7.132800e-04,& - & 7.302300e-05,1.333700e-04,1.341300e-04,1.189200e-04,3.458400e-04,& - & 1.056000e-04,1.814100e-04,1.789400e-04,1.521300e-04,3.983900e-04,& - & 1.486100e-04,2.420800e-04,2.346200e-04,1.937100e-04,4.538400e-04,& - & 2.031300e-04,3.174100e-04,3.029100e-04,2.451600e-04,5.115000e-04,& - & 2.702500e-04,4.089100e-04,3.858500e-04,3.081000e-04,5.715800e-04,& - & 6.524400e-05,1.177900e-04,1.179600e-04,1.034700e-04,2.727400e-04,& - & 9.431700e-05,1.600300e-04,1.571100e-04,1.325100e-04,3.146200e-04,& - & 1.323500e-04,2.133800e-04,2.057800e-04,1.688800e-04,3.587400e-04,& - & 1.799400e-04,2.792300e-04,2.656700e-04,2.139700e-04,4.042300e-04,& - & 2.381500e-04,3.587800e-04,3.380800e-04,2.690800e-04,4.519400e-04,& - & 5.813500e-05,1.039300e-04,1.035800e-04,8.997400e-05,2.118600e-04,& - & 8.392200e-05,1.410600e-04,1.378300e-04,1.153900e-04,2.448600e-04,& - & 1.171900e-04,1.877100e-04,1.804200e-04,1.472500e-04,2.792100e-04,& - & 1.584600e-04,2.449800e-04,2.326900e-04,1.868200e-04,3.149300e-04,& - & 2.083400e-04,3.138300e-04,2.956800e-04,2.348800e-04,3.523500e-04,& - & 5.215600e-05,9.211000e-05,9.128800e-05,7.848700e-05,1.637900e-04,& - & 7.490700e-05,1.247400e-04,1.213400e-04,1.008100e-04,1.892400e-04,& - & 1.038900e-04,1.654300e-04,1.586200e-04,1.288400e-04,2.156400e-04,& - & 1.394900e-04,2.150700e-04,2.041600e-04,1.634900e-04,2.433600e-04,& - & 1.819300e-04,2.745700e-04,2.588000e-04,2.052900e-04,2.723000e-04,& - & 4.666500e-05,8.157800e-05,8.047500e-05,6.854500e-05,1.252300e-04,& - & 6.659000e-05,1.101100e-04,1.067700e-04,8.817500e-05,1.444800e-04,& - & 9.166600e-05,1.454400e-04,1.393200e-04,1.128000e-04,1.646700e-04,& - & 1.221400e-04,1.883000e-04,1.788200e-04,1.430100e-04,1.858400e-04,& - & 1.580800e-04,2.393700e-04,2.260100e-04,1.792700e-04,2.080400e-04,& - & 4.177400e-05,7.229300e-05,7.104400e-05,6.001400e-05,9.440400e-05,& - & 5.915300e-05,9.714200e-05,9.403400e-05,7.730300e-05,1.087600e-04,& - & 8.074900e-05,1.277300e-04,1.223100e-04,9.886100e-05,1.238300e-04,& - & 1.066500e-04,1.645900e-04,1.564600e-04,1.251100e-04,1.396900e-04,& - & 1.370800e-04,2.081500e-04,1.968700e-04,1.563400e-04,1.567000e-04,& - & 3.736000e-05,6.404200e-05,6.276300e-05,5.267400e-05,7.129500e-05,& - & 5.245800e-05,8.562700e-05,8.278600e-05,6.784600e-05,8.199000e-05,& - & 7.094800e-05,1.120500e-04,1.073200e-04,8.665900e-05,9.332900e-05,& - & 9.291200e-05,1.436100e-04,1.366700e-04,1.093700e-04,1.055000e-04,& - & 1.187200e-04,1.805800e-04,1.710800e-04,1.360700e-04,1.186100e-04,& - & 3.333000e-05,5.665100e-05,5.540400e-05,4.625700e-05,5.360300e-05,& - & 4.636600e-05,7.536500e-05,7.281500e-05,5.954100e-05,6.170900e-05,& - & 6.211700e-05,9.806400e-05,9.400200e-05,7.588000e-05,7.040400e-05,& - & 8.078500e-05,1.250300e-04,1.191100e-04,9.544000e-05,7.984200e-05,& - & 1.026600e-04,1.564200e-04,1.483100e-04,1.181300e-04,8.995600e-05,& - & 2.945300e-05,4.967400e-05,4.849400e-05,4.033000e-05,4.144900e-05,& - & 4.058700e-05,6.576300e-05,6.351900e-05,5.185200e-05,4.777200e-05,& - & 5.394100e-05,8.510900e-05,8.161300e-05,6.590800e-05,5.464500e-05,& - & 6.974200e-05,1.080000e-04,1.029200e-04,8.254000e-05,6.211000e-05,& - & 8.824800e-05,1.346100e-04,1.276400e-04,1.017300e-04,7.011500e-05,& - & 2.508700e-05,4.225900e-05,4.125500e-05,3.427500e-05,3.153300e-05,& - & 3.437700e-05,5.577900e-05,5.392800e-05,4.403700e-05,3.646700e-05,& - & 4.550900e-05,7.196200e-05,6.907300e-05,5.585500e-05,4.185800e-05,& - & 5.867200e-05,9.108500e-05,8.686700e-05,6.973600e-05,4.771800e-05,& - & 7.408600e-05,1.133100e-04,1.075000e-04,8.575300e-05,5.396400e-05,& - & 2.052500e-05,3.476700e-05,3.400100e-05,2.829700e-05,2.354800e-05,& - & 2.810400e-05,4.587200e-05,4.444100e-05,3.635700e-05,2.735500e-05,& - & 3.719900e-05,5.914200e-05,5.686400e-05,4.607400e-05,3.151600e-05,& - & 4.797300e-05,7.484200e-05,7.148000e-05,5.747300e-05,3.605600e-05,& - & 6.058900e-05,9.307800e-05,8.841600e-05,7.064500e-05,4.090500e-05/ - data absb(601:900,5) / & - & 1.611800e-05,2.752300e-05,2.697900e-05,2.254300e-05,1.801000e-05,& - & 2.216500e-05,3.640700e-05,3.534800e-05,2.900800e-05,2.098300e-05,& - & 2.944400e-05,4.705500e-05,4.532600e-05,3.680800e-05,2.424900e-05,& - & 3.808100e-05,5.968100e-05,5.708100e-05,4.598200e-05,2.781300e-05,& - & 4.821200e-05,7.437400e-05,7.074000e-05,5.660200e-05,3.163500e-05,& - & 1.261000e-05,2.171800e-05,2.134300e-05,1.790800e-05,1.372000e-05,& - & 1.742400e-05,2.881200e-05,2.803400e-05,2.307900e-05,1.603400e-05,& - & 2.324000e-05,3.733900e-05,3.603300e-05,2.933100e-05,1.858900e-05,& - & 3.014900e-05,4.747600e-05,4.547900e-05,3.670000e-05,2.138200e-05,& - & 3.827600e-05,5.929400e-05,5.647600e-05,4.525600e-05,2.438700e-05,& - & 9.849400e-06,1.711900e-05,1.686500e-05,1.421500e-05,1.037400e-05,& - & 1.368000e-05,2.278100e-05,2.221500e-05,1.835000e-05,1.216700e-05,& - & 1.832400e-05,2.960300e-05,2.862300e-05,2.335600e-05,1.415300e-05,& - & 2.384900e-05,3.773900e-05,3.620800e-05,2.927800e-05,1.633600e-05,& - & 3.036200e-05,4.724000e-05,4.505700e-05,3.616400e-05,1.869000e-05,& - & 7.433900e-06,1.309600e-05,1.294900e-05,1.099400e-05,7.922200e-06,& - & 1.042300e-05,1.752900e-05,1.714300e-05,1.423000e-05,9.321500e-06,& - & 1.406400e-05,2.289700e-05,2.219400e-05,1.816900e-05,1.087800e-05,& - & 1.842100e-05,2.931900e-05,2.819100e-05,2.285000e-05,1.259500e-05,& - & 2.356000e-05,3.684900e-05,3.520900e-05,2.831100e-05,1.445600e-05,& - & 5.570400e-06,9.961900e-06,9.889100e-06,8.465400e-06,6.039400e-06,& - & 7.889900e-06,1.342400e-05,1.316600e-05,1.099000e-05,7.131700e-06,& - & 1.073900e-05,1.763200e-05,1.713300e-05,1.407700e-05,8.348700e-06,& - & 1.416200e-05,2.268300e-05,2.186000e-05,1.776700e-05,9.698600e-06,& - & 1.820600e-05,2.863500e-05,2.741400e-05,2.209100e-05,1.117000e-05,& - & 4.158100e-06,7.559100e-06,7.536100e-06,6.510800e-06,4.585200e-06,& - & 5.953800e-06,1.025900e-05,1.009400e-05,8.478400e-06,5.432400e-06,& - & 8.180100e-06,1.355200e-05,1.320200e-05,1.089200e-05,6.381600e-06,& - & 1.086500e-05,1.752000e-05,1.692500e-05,1.379600e-05,7.438200e-06,& - & 1.404400e-05,2.222200e-05,2.131200e-05,1.721500e-05,8.597400e-06,& - & 3.029500e-06,5.622700e-06,5.637000e-06,4.929100e-06,3.464400e-06,& - & 4.399200e-06,7.700600e-06,7.607100e-06,6.440600e-06,4.117700e-06,& - & 6.116800e-06,1.024800e-05,1.001400e-05,8.306500e-06,4.854100e-06,& - & 8.202200e-06,1.333200e-05,1.291600e-05,1.056700e-05,5.678300e-06,& - & 1.067900e-05,1.700600e-05,1.634800e-05,1.324200e-05,6.587100e-06,& - & 2.175200e-06,4.135400e-06,4.174500e-06,3.702800e-06,2.607200e-06,& - & 3.210500e-06,5.721900e-06,5.677800e-06,4.854600e-06,3.106600e-06,& - & 4.524200e-06,7.679700e-06,7.530700e-06,6.287400e-06,3.674200e-06,& - & 6.134200e-06,1.006500e-05,9.779500e-06,8.035300e-06,4.314600e-06,& - & 8.057200e-06,1.291900e-05,1.245000e-05,1.011800e-05,5.024600e-06,& - & 1.552000e-06,3.030400e-06,3.082100e-06,2.779700e-06,1.953900e-06,& - & 2.330400e-06,4.236400e-06,4.225000e-06,3.653100e-06,2.332600e-06,& - & 3.330300e-06,5.739400e-06,5.650200e-06,4.752300e-06,2.766400e-06,& - & 4.571100e-06,7.578900e-06,7.386200e-06,6.099100e-06,3.260600e-06,& - & 6.061200e-06,9.791400e-06,9.463500e-06,7.717400e-06,3.812900e-06,& - & 1.089600e-06,2.195700e-06,2.253100e-06,2.074900e-06,1.459500e-06,& - & 1.668200e-06,3.103500e-06,3.114400e-06,2.729600e-06,1.744100e-06,& - & 2.422700e-06,4.250000e-06,4.202000e-06,3.567100e-06,2.072900e-06,& - & 3.371800e-06,5.659800e-06,5.535300e-06,4.597700e-06,2.451800e-06,& - & 4.521500e-06,7.366200e-06,7.141700e-06,5.847000e-06,2.878200e-06,& - & 7.446900e-07,1.560500e-06,1.620000e-06,1.533500e-06,1.089300e-06,& - & 1.167200e-06,2.232700e-06,2.258500e-06,2.014300e-06,1.301900e-06,& - & 1.728400e-06,3.096600e-06,3.078200e-06,2.644200e-06,1.550600e-06,& - & 2.444700e-06,4.167100e-06,4.091600e-06,3.425300e-06,1.838900e-06,& - & 3.323400e-06,5.471000e-06,5.322700e-06,4.379300e-06,2.166600e-06,& - & 5.035600e-07,1.103100e-06,1.161200e-06,1.136600e-06,8.111100e-07,& - & 8.096700e-07,1.598200e-06,1.631600e-06,1.485500e-06,9.680300e-07,& - & 1.224000e-06,2.244900e-06,2.245800e-06,1.955400e-06,1.154500e-06,& - & 1.760900e-06,3.056100e-06,3.014400e-06,2.547100e-06,1.371600e-06,& - & 2.430200e-06,4.050000e-06,3.953700e-06,3.272900e-06,1.621400e-06/ - data absb(901:1175,5) / & - & 3.366900e-07,7.756200e-07,8.301300e-07,8.466100e-07,6.023900e-07,& - & 5.561800e-07,1.137800e-06,1.173700e-06,1.096000e-06,7.170100e-07,& - & 8.596600e-07,1.618900e-06,1.631500e-06,1.443200e-06,8.548900e-07,& - & 1.260000e-06,2.231000e-06,2.212200e-06,1.890400e-06,1.016900e-06,& - & 1.766800e-06,2.986400e-06,2.926500e-06,2.440300e-06,1.205300e-06,& - & 2.259700e-07,5.486500e-07,5.983400e-07,6.397200e-07,4.557800e-07,& - & 3.833600e-07,8.142100e-07,8.496500e-07,8.159200e-07,5.400000e-07,& - & 6.062000e-07,1.172500e-06,1.190900e-06,1.072000e-06,6.434800e-07,& - & 9.049400e-07,1.635400e-06,1.630400e-06,1.410000e-06,7.659700e-07,& - & 1.288600e-06,2.211900e-06,2.176300e-06,1.829200e-06,9.091200e-07,& - & 1.510200e-07,3.883900e-07,4.331500e-07,4.896900e-07,3.486600e-07,& - & 2.634100e-07,5.827700e-07,6.161400e-07,6.111200e-07,4.101800e-07,& - & 4.266600e-07,8.491400e-07,8.697800e-07,7.986800e-07,4.880700e-07,& - & 6.490800e-07,1.198400e-06,1.201900e-06,1.053000e-06,5.812300e-07,& - & 9.390400e-07,1.638500e-06,1.619000e-06,1.373400e-06,6.902800e-07,& - & 9.987500e-08,2.739200e-07,3.141100e-07,3.799200e-07,2.673200e-07,& - & 1.793600e-07,4.153700e-07,4.460100e-07,4.600200e-07,3.116000e-07,& - & 2.980000e-07,6.123000e-07,6.332300e-07,5.955800e-07,3.693700e-07,& - & 4.626200e-07,8.745700e-07,8.831600e-07,7.854400e-07,4.398700e-07,& - & 6.807200e-07,1.209400e-06,1.200600e-06,1.029600e-06,5.226400e-07,& - & 6.534300e-08,1.925100e-07,2.285100e-07,2.994700e-07,2.055600e-07,& - & 1.209100e-07,2.946900e-07,3.224800e-07,3.487700e-07,2.368600e-07,& - & 2.062700e-07,4.394600e-07,4.596300e-07,4.447100e-07,2.788900e-07,& - & 3.274300e-07,6.352200e-07,6.465300e-07,5.850800e-07,3.316800e-07,& - & 4.906000e-07,8.888100e-07,8.870800e-07,7.700300e-07,3.940900e-07,& - & 4.330600e-08,1.369900e-07,1.689700e-07,2.403500e-07,1.617100e-07,& - & 8.218200e-08,2.110900e-07,2.358900e-07,2.688700e-07,1.846500e-07,& - & 1.439200e-07,3.180300e-07,3.366400e-07,3.357300e-07,2.160500e-07,& - & 2.335600e-07,4.648900e-07,4.768800e-07,4.396100e-07,2.564900e-07,& - & 3.560100e-07,6.575600e-07,6.599000e-07,5.798100e-07,3.049500e-07,& - & 2.885400e-08,9.807200e-08,1.265100e-07,1.957700e-07,1.289300e-07,& - & 5.587300e-08,1.516800e-07,1.736400e-07,2.100100e-07,1.460000e-07,& - & 1.004100e-07,2.306800e-07,2.475000e-07,2.554200e-07,1.699200e-07,& - & 1.666500e-07,3.408700e-07,3.525000e-07,3.317800e-07,2.012900e-07,& - & 2.585900e-07,4.871800e-07,4.918300e-07,4.378300e-07,2.395100e-07,& - & 1.918300e-08,7.029600e-08,9.595800e-08,1.616600e-07,1.032400e-07,& - & 3.769000e-08,1.087300e-07,1.281600e-07,1.660600e-07,1.157300e-07,& - & 6.956400e-08,1.668100e-07,1.818400e-07,1.953800e-07,1.339500e-07,& - & 1.181700e-07,2.491200e-07,2.599800e-07,2.506800e-07,1.582000e-07,& - & 1.868500e-07,3.597900e-07,3.656600e-07,3.304400e-07,1.882800e-07,& - & 1.274900e-08,5.051400e-08,7.414700e-08,1.351100e-07,8.304500e-08,& - & 2.523700e-08,7.778500e-08,9.501200e-08,1.330000e-07,9.199200e-08,& - & 4.779000e-08,1.202400e-07,1.335800e-07,1.506000e-07,1.058600e-07,& - & 8.323300e-08,1.813900e-07,1.913600e-07,1.897300e-07,1.245600e-07,& - & 1.343000e-07,2.648000e-07,2.711300e-07,2.492600e-07,1.481700e-07,& - & 8.607100e-09,3.674800e-08,5.834800e-08,1.138900e-07,6.728000e-08,& - & 1.700300e-08,5.601200e-08,7.127000e-08,1.079700e-07,7.380100e-08,& - & 3.288400e-08,8.701700e-08,9.879700e-08,1.175200e-07,8.432900e-08,& - & 5.872200e-08,1.325000e-07,1.414700e-07,1.446800e-07,9.892300e-08,& - & 9.671800e-08,1.954900e-07,2.016700e-07,1.888900e-07,1.176100e-07,& - & 6.576200e-09,2.883900e-08,4.724000e-08,9.428100e-08,5.634700e-08,& - & 1.296900e-08,4.374700e-08,5.662000e-08,8.836100e-08,6.207100e-08,& - & 2.527500e-08,6.811200e-08,7.801400e-08,9.481400e-08,7.129300e-08,& - & 4.556500e-08,1.041500e-07,1.117200e-07,1.156600e-07,8.415200e-08,& - & 7.565500e-08,1.543500e-07,1.596500e-07,1.506500e-07,1.004200e-07/ - data absb(1:300,6) / & - & 1.491700e-03,1.897500e-03,1.821700e-03,1.646200e-03,1.544500e-02,& - & 2.033200e-03,2.587800e-03,2.458100e-03,2.097500e-03,1.701600e-02,& - & 2.715700e-03,3.447900e-03,3.244200e-03,2.678700e-03,1.856600e-02,& - & 3.563000e-03,4.499200e-03,4.203700e-03,3.389700e-03,2.018300e-02,& - & 4.592500e-03,5.765100e-03,5.354300e-03,4.235900e-03,2.191900e-02,& - & 1.282900e-03,1.645000e-03,1.579100e-03,1.404900e-03,1.266900e-02,& - & 1.759400e-03,2.251900e-03,2.133700e-03,1.802800e-03,1.398300e-02,& - & 2.366000e-03,3.012500e-03,2.824800e-03,2.308800e-03,1.534000e-02,& - & 3.120600e-03,3.949200e-03,3.668500e-03,2.929200e-03,1.675800e-02,& - & 4.042400e-03,5.071400e-03,4.679700e-03,3.671100e-03,1.831800e-02,& - & 1.101000e-03,1.425500e-03,1.365000e-03,1.201700e-03,9.718400e-03,& - & 1.521900e-03,1.959300e-03,1.849500e-03,1.548700e-03,1.078200e-02,& - & 2.058600e-03,2.632400e-03,2.457400e-03,1.989200e-03,1.188500e-02,& - & 2.727900e-03,3.458700e-03,3.199000e-03,2.531700e-03,1.307600e-02,& - & 3.547600e-03,4.451100e-03,4.087300e-03,3.182500e-03,1.438100e-02,& - & 9.443900e-04,1.234200e-03,1.179100e-03,1.029000e-03,7.097400e-03,& - & 1.315200e-03,1.703800e-03,1.603800e-03,1.332000e-03,7.921900e-03,& - & 1.787300e-03,2.295700e-03,2.136000e-03,1.716500e-03,8.813000e-03,& - & 2.377600e-03,3.022700e-03,2.785600e-03,2.191700e-03,9.777300e-03,& - & 3.104200e-03,3.900700e-03,3.564500e-03,2.760900e-03,1.082300e-02,& - & 8.141800e-04,1.072700e-03,1.021500e-03,8.828200e-04,5.283600e-03,& - & 1.138900e-03,1.485100e-03,1.393600e-03,1.146700e-03,5.945900e-03,& - & 1.553000e-03,2.004700e-03,1.858600e-03,1.483000e-03,6.672200e-03,& - & 2.075000e-03,2.642500e-03,2.424700e-03,1.898600e-03,7.458900e-03,& - & 2.714400e-03,3.419100e-03,3.109300e-03,2.394700e-03,8.305500e-03,& - & 7.074300e-04,9.375300e-04,8.900000e-04,7.595900e-04,4.071800e-03,& - & 9.918200e-04,1.300500e-03,1.215400e-03,9.906200e-04,4.624500e-03,& - & 1.356400e-03,1.755100e-03,1.620700e-03,1.285600e-03,5.228700e-03,& - & 1.815900e-03,2.317400e-03,2.115100e-03,1.646900e-03,5.879700e-03,& - & 2.377300e-03,3.005200e-03,2.718900e-03,2.080000e-03,6.574600e-03,& - & 6.152500e-04,8.197000e-04,7.755300e-04,6.542300e-04,3.267600e-03,& - & 8.639100e-04,1.136800e-03,1.059200e-03,8.568300e-04,3.740200e-03,& - & 1.184200e-03,1.534900e-03,1.411300e-03,1.113300e-03,4.253100e-03,& - & 1.585000e-03,2.031400e-03,1.845300e-03,1.427100e-03,4.802200e-03,& - & 2.073800e-03,2.634700e-03,2.375600e-03,1.807300e-03,5.389400e-03,& - & 5.381300e-04,7.185200e-04,6.774200e-04,5.661000e-04,2.683700e-03,& - & 7.560900e-04,9.953900e-04,9.239600e-04,7.431900e-04,3.086400e-03,& - & 1.036000e-03,1.346000e-03,1.231700e-03,9.660000e-04,3.522000e-03,& - & 1.384100e-03,1.781100e-03,1.612400e-03,1.241100e-03,3.988200e-03,& - & 1.808300e-03,2.304700e-03,2.075300e-03,1.574900e-03,4.486300e-03,& - & 4.704700e-04,6.277400e-04,5.894500e-04,4.888800e-04,2.209400e-03,& - & 6.610200e-04,8.692400e-04,8.037700e-04,6.424400e-04,2.549400e-03,& - & 9.036300e-04,1.175700e-03,1.072500e-03,8.368100e-04,2.916600e-03,& - & 1.204800e-03,1.552600e-03,1.403100e-03,1.077500e-03,3.310300e-03,& - & 1.571800e-03,2.002800e-03,1.802400e-03,1.367700e-03,3.730800e-03,& - & 4.190700e-04,5.577100e-04,5.211900e-04,4.279200e-04,1.800300e-03,& - & 5.867100e-04,7.713300e-04,7.099800e-04,5.632500e-04,2.082800e-03,& - & 7.991600e-04,1.039600e-03,9.456000e-04,7.349700e-04,2.387500e-03,& - & 1.062400e-03,1.366300e-03,1.233800e-03,9.459100e-04,2.714700e-03,& - & 1.382800e-03,1.756900e-03,1.579100e-03,1.198600e-03,3.062500e-03,& - & 3.726800e-04,4.954000e-04,4.604900e-04,3.744100e-04,1.459900e-03,& - & 5.196300e-04,6.829500e-04,6.261600e-04,4.937800e-04,1.692800e-03,& - & 7.055200e-04,9.162700e-04,8.311800e-04,6.443400e-04,1.943900e-03,& - & 9.356600e-04,1.198700e-03,1.080800e-03,8.274700e-04,2.212900e-03,& - & 1.216500e-03,1.538600e-03,1.379300e-03,1.046000e-03,2.495800e-03,& - & 3.296600e-04,4.387600e-04,4.064100e-04,3.276700e-04,1.168200e-03,& - & 4.583300e-04,6.022600e-04,5.505900e-04,4.324800e-04,1.358100e-03,& - & 6.209900e-04,8.046100e-04,7.285100e-04,5.635100e-04,1.562100e-03,& - & 8.219300e-04,1.049700e-03,9.442800e-04,7.219900e-04,1.779300e-03,& - & 1.068500e-03,1.344900e-03,1.202800e-03,9.104600e-04,2.005200e-03/ - data absb(301:600,6) / & - & 2.921500e-04,3.888500e-04,3.590600e-04,2.875200e-04,9.349800e-04,& - & 4.049800e-04,5.312100e-04,4.843600e-04,3.792500e-04,1.088800e-03,& - & 5.472400e-04,7.070700e-04,6.387000e-04,4.928100e-04,1.253900e-03,& - & 7.240300e-04,9.206100e-04,8.259400e-04,6.299100e-04,1.427500e-03,& - & 9.420700e-04,1.177900e-03,1.050300e-03,7.927700e-04,1.605800e-03,& - & 2.606000e-04,3.462500e-04,3.186500e-04,2.536000e-04,7.559500e-04,& - & 3.599000e-04,4.709600e-04,4.279200e-04,3.338000e-04,8.808300e-04,& - & 4.854000e-04,6.245700e-04,5.625700e-04,4.326000e-04,1.013700e-03,& - & 6.423600e-04,8.117700e-04,7.259600e-04,5.515300e-04,1.151900e-03,& - & 8.367300e-04,1.037800e-03,9.217700e-04,6.931100e-04,1.293800e-03,& - & 2.316700e-04,3.075000e-04,2.820600e-04,2.233500e-04,6.015700e-04,& - & 3.190800e-04,4.165000e-04,3.775000e-04,2.932700e-04,7.008300e-04,& - & 4.302100e-04,5.509700e-04,4.948800e-04,3.791800e-04,8.053200e-04,& - & 5.699900e-04,7.155100e-04,6.377000e-04,4.825500e-04,9.142400e-04,& - & 7.425100e-04,9.148100e-04,8.091300e-04,6.058500e-04,1.026400e-03,& - & 2.052400e-04,2.722100e-04,2.490600e-04,1.963400e-04,4.706300e-04,& - & 2.825500e-04,3.675500e-04,3.324400e-04,2.573300e-04,5.478400e-04,& - & 3.811900e-04,4.854600e-04,4.350700e-04,3.319200e-04,6.292900e-04,& - & 5.053100e-04,6.305200e-04,5.601500e-04,4.220800e-04,7.142600e-04,& - & 6.576800e-04,8.058900e-04,7.109200e-04,5.300700e-04,8.018200e-04,& - & 1.826800e-04,2.415500e-04,2.204400e-04,1.729000e-04,3.647300e-04,& - & 2.514700e-04,3.253100e-04,2.934700e-04,2.261800e-04,4.243100e-04,& - & 3.393000e-04,4.294000e-04,3.835100e-04,2.913600e-04,4.872900e-04,& - & 4.490900e-04,5.575400e-04,4.936200e-04,3.703100e-04,5.527700e-04,& - & 5.828800e-04,7.116500e-04,6.262500e-04,4.653900e-04,6.209400e-04,& - & 1.627500e-04,2.142700e-04,1.949200e-04,1.522100e-04,2.788200e-04,& - & 2.239700e-04,2.880700e-04,2.590500e-04,1.988400e-04,3.246400e-04,& - & 3.017300e-04,3.802000e-04,3.383800e-04,2.559100e-04,3.727900e-04,& - & 3.983500e-04,4.929000e-04,4.352300e-04,3.253900e-04,4.231800e-04,& - & 5.151200e-04,6.281400e-04,5.523600e-04,4.092800e-04,4.764400e-04,& - & 1.454100e-04,1.905000e-04,1.726900e-04,1.341500e-04,2.098800e-04,& - & 1.996800e-04,2.557900e-04,2.291700e-04,1.750400e-04,2.445400e-04,& - & 2.683100e-04,3.371300e-04,2.992400e-04,2.253400e-04,2.811600e-04,& - & 3.529600e-04,4.360300e-04,3.846000e-04,2.865700e-04,3.197100e-04,& - & 4.538500e-04,5.542200e-04,4.874700e-04,3.605100e-04,3.603300e-04,& - & 1.301200e-04,1.697900e-04,1.533200e-04,1.184600e-04,1.585800e-04,& - & 1.781100e-04,2.275800e-04,2.032800e-04,1.544700e-04,1.850000e-04,& - & 2.384600e-04,2.992000e-04,2.650800e-04,1.989000e-04,2.128900e-04,& - & 3.119500e-04,3.857900e-04,3.402900e-04,2.530500e-04,2.422600e-04,& - & 3.983100e-04,4.884600e-04,4.304000e-04,3.181500e-04,2.735100e-04,& - & 1.163400e-04,1.514700e-04,1.363600e-04,1.047500e-04,1.197800e-04,& - & 1.586300e-04,2.024800e-04,1.805000e-04,1.366500e-04,1.397300e-04,& - & 2.113700e-04,2.653000e-04,2.349600e-04,1.759200e-04,1.608700e-04,& - & 2.746700e-04,3.407900e-04,3.010900e-04,2.237200e-04,1.834400e-04,& - & 3.478200e-04,4.291900e-04,3.795000e-04,2.808000e-04,2.075700e-04,& - & 1.031200e-04,1.340800e-04,1.204100e-04,9.211000e-05,9.290300e-05,& - & 1.400800e-04,1.787100e-04,1.591400e-04,1.201600e-04,1.083100e-04,& - & 1.855600e-04,2.332900e-04,2.067800e-04,1.546400e-04,1.247600e-04,& - & 2.393900e-04,2.983300e-04,2.642900e-04,1.964900e-04,1.424800e-04,& - & 3.011700e-04,3.737300e-04,3.316200e-04,2.460500e-04,1.615200e-04,& - & 8.844300e-05,1.151200e-04,1.033600e-04,7.895000e-05,7.068400e-05,& - & 1.198500e-04,1.532700e-04,1.365800e-04,1.031100e-04,8.250400e-05,& - & 1.581300e-04,1.996200e-04,1.773400e-04,1.327600e-04,9.524400e-05,& - & 2.030300e-04,2.544500e-04,2.261700e-04,1.685900e-04,1.090700e-04,& - & 2.545700e-04,3.176400e-04,2.827500e-04,2.106700e-04,1.240100e-04,& - & 7.310500e-05,9.555300e-05,8.589400e-05,6.566500e-05,5.258600e-05,& - & 9.908800e-05,1.273100e-04,1.136600e-04,8.595000e-05,6.160300e-05,& - & 1.305200e-04,1.657500e-04,1.476600e-04,1.108500e-04,7.139500e-05,& - & 1.673700e-04,2.110000e-04,1.881700e-04,1.408200e-04,8.206000e-05,& - & 2.097100e-04,2.632800e-04,2.348200e-04,1.758300e-04,9.361600e-05/ - data absb(601:900,6) / & - & 5.796400e-05,7.616000e-05,6.857600e-05,5.254100e-05,4.007300e-05,& - & 7.883400e-05,1.018300e-04,9.106300e-05,6.904500e-05,4.711100e-05,& - & 1.041200e-04,1.329400e-04,1.186400e-04,8.932200e-05,5.477000e-05,& - & 1.338200e-04,1.695200e-04,1.514300e-04,1.137400e-04,6.313400e-05,& - & 1.680800e-04,2.119600e-04,1.892800e-04,1.422000e-04,7.222500e-05,& - & 4.577500e-05,6.047900e-05,5.455500e-05,4.190200e-05,3.039700e-05,& - & 6.249600e-05,8.116400e-05,7.270800e-05,5.527400e-05,3.587800e-05,& - & 8.278200e-05,1.062600e-04,9.500200e-05,7.174000e-05,4.184100e-05,& - & 1.067000e-04,1.358300e-04,1.214900e-04,9.155800e-05,4.837700e-05,& - & 1.343800e-04,1.702100e-04,1.521300e-04,1.146300e-04,5.551200e-05,& - & 3.609500e-05,4.796000e-05,4.334000e-05,3.337900e-05,2.288200e-05,& - & 4.946800e-05,6.461400e-05,5.797900e-05,4.419900e-05,2.711000e-05,& - & 6.572800e-05,8.483000e-05,7.596600e-05,5.754100e-05,3.172900e-05,& - & 8.498900e-05,1.087100e-04,9.733800e-05,7.359500e-05,3.681600e-05,& - & 1.073300e-04,1.365500e-04,1.221600e-04,9.228900e-05,4.238000e-05,& - & 2.754800e-05,3.686600e-05,3.339800e-05,2.581600e-05,1.740600e-05,& - & 3.801700e-05,4.997800e-05,4.493900e-05,3.436300e-05,2.071700e-05,& - & 5.084300e-05,6.599800e-05,5.917300e-05,4.496000e-05,2.434000e-05,& - & 6.610300e-05,8.498200e-05,7.616500e-05,5.773400e-05,2.833400e-05,& - & 8.388900e-05,1.071800e-04,9.597100e-05,7.265100e-05,3.271600e-05,& - & 2.089100e-05,2.816000e-05,2.558100e-05,1.985300e-05,1.321900e-05,& - & 2.905600e-05,3.844800e-05,3.464300e-05,2.657800e-05,1.580300e-05,& - & 3.911900e-05,5.108600e-05,4.587000e-05,3.494900e-05,1.864300e-05,& - & 5.116700e-05,6.614400e-05,5.932100e-05,4.507800e-05,2.178100e-05,& - & 6.531300e-05,8.380700e-05,7.510000e-05,5.696500e-05,2.522800e-05,& - & 1.579700e-05,2.145200e-05,1.954100e-05,1.523400e-05,9.986400e-06,& - & 2.214800e-05,2.950600e-05,2.664400e-05,2.050700e-05,1.199500e-05,& - & 3.002800e-05,3.945600e-05,3.547800e-05,2.711300e-05,1.421500e-05,& - & 3.952600e-05,5.138000e-05,4.612200e-05,3.513900e-05,1.667000e-05,& - & 5.074700e-05,6.540900e-05,5.866100e-05,4.458800e-05,1.936900e-05,& - & 1.168500e-05,1.600100e-05,1.462800e-05,1.147100e-05,7.493600e-06,& - & 1.654800e-05,2.221300e-05,2.011300e-05,1.553700e-05,9.053600e-06,& - & 2.263800e-05,2.995400e-05,2.697900e-05,2.068500e-05,1.077900e-05,& - & 3.004800e-05,3.929300e-05,3.531100e-05,2.696800e-05,1.269700e-05,& - & 3.886000e-05,5.033800e-05,4.518300e-05,3.441000e-05,1.480600e-05,& - & 8.534800e-06,1.179200e-05,1.082500e-05,8.551500e-06,5.587100e-06,& - & 1.222400e-05,1.654200e-05,1.502300e-05,1.165900e-05,6.794700e-06,& - & 1.689900e-05,2.252100e-05,2.032100e-05,1.563300e-05,8.132000e-06,& - & 2.263700e-05,2.978300e-05,2.680100e-05,2.052500e-05,9.622700e-06,& - & 2.951100e-05,3.843700e-05,3.453100e-05,2.635600e-05,1.126500e-05,& - & 6.205300e-06,8.649800e-06,7.982800e-06,6.358700e-06,4.135500e-06,& - & 8.992400e-06,1.227400e-05,1.118400e-05,8.722800e-06,5.064600e-06,& - & 1.257700e-05,1.687800e-05,1.526300e-05,1.178100e-05,6.098000e-06,& - & 1.700400e-05,2.251000e-05,2.028700e-05,1.557900e-05,7.249500e-06,& - & 2.234500e-05,2.927300e-05,2.632700e-05,2.013900e-05,8.524100e-06,& - & 4.453500e-06,6.266300e-06,5.821500e-06,4.684700e-06,3.040300e-06,& - & 6.538600e-06,9.008700e-06,8.238300e-06,6.465000e-06,3.749500e-06,& - & 9.262600e-06,1.252300e-05,1.135300e-05,8.795800e-06,4.545500e-06,& - & 1.265200e-05,1.686600e-05,1.522400e-05,1.172600e-05,5.432400e-06,& - & 1.678200e-05,2.211500e-05,1.991000e-05,1.527100e-05,6.415400e-06,& - & 3.125500e-06,4.444500e-06,4.162500e-06,3.397300e-06,2.224800e-06,& - & 4.660700e-06,6.487100e-06,5.960900e-06,4.714900e-06,2.763300e-06,& - & 6.699600e-06,9.134900e-06,8.307200e-06,6.465100e-06,3.375100e-06,& - & 9.270500e-06,1.244900e-05,1.125600e-05,8.699900e-06,4.058200e-06,& - & 1.242900e-05,1.648000e-05,1.485400e-05,1.142800e-05,4.816600e-06,& - & 2.177600e-06,3.128700e-06,2.959300e-06,2.458800e-06,1.616200e-06,& - & 3.300400e-06,4.642400e-06,4.291500e-06,3.427900e-06,2.021600e-06,& - & 4.817800e-06,6.631700e-06,6.051200e-06,4.734700e-06,2.486900e-06,& - & 6.763200e-06,9.150700e-06,8.291400e-06,6.428400e-06,3.009900e-06,& - & 9.169700e-06,1.223400e-05,1.104200e-05,8.522400e-06,3.591900e-06/ - data absb(901:1175,6) / & - & 1.505300e-06,2.185800e-06,2.090900e-06,1.777400e-06,1.163800e-06,& - & 2.320800e-06,3.300100e-06,3.074100e-06,2.484900e-06,1.465500e-06,& - & 3.442600e-06,4.787400e-06,4.385800e-06,3.454200e-06,1.814500e-06,& - & 4.907300e-06,6.693700e-06,6.079800e-06,4.729900e-06,2.211600e-06,& - & 6.734900e-06,9.045300e-06,8.176900e-06,6.330900e-06,2.654500e-06,& - & 1.046200e-06,1.534000e-06,1.484800e-06,1.296400e-06,8.527300e-07,& - & 1.640200e-06,2.355700e-06,2.212400e-06,1.813700e-06,1.079900e-06,& - & 2.470900e-06,3.471200e-06,3.194100e-06,2.534200e-06,1.344800e-06,& - & 3.575800e-06,4.916800e-06,4.477600e-06,3.496400e-06,1.649600e-06,& - & 4.970200e-06,6.720200e-06,6.083500e-06,4.722200e-06,1.991200e-06,& - & 7.266300e-07,1.075000e-06,1.054200e-06,9.505900e-07,6.298700e-07,& - & 1.158200e-06,1.678900e-06,1.591000e-06,1.327600e-06,8.010600e-07,& - & 1.771900e-06,2.514400e-06,2.326700e-06,1.862200e-06,1.003300e-06,& - & 2.604600e-06,3.611500e-06,3.298300e-06,2.587200e-06,1.238100e-06,& - & 3.669700e-06,4.994500e-06,4.528800e-06,3.523600e-06,1.503100e-06,& - & 5.012800e-07,7.482900e-07,7.450300e-07,6.990200e-07,4.641700e-07,& - & 8.129000e-07,1.188900e-06,1.138300e-06,9.707500e-07,5.912400e-07,& - & 1.263700e-06,1.811100e-06,1.687400e-06,1.365400e-06,7.448500e-07,& - & 1.887000e-06,2.641400e-06,2.420800e-06,1.908800e-06,9.239800e-07,& - & 2.698200e-06,3.698100e-06,3.360500e-06,2.620900e-06,1.128400e-06,& - & 3.431600e-07,5.173000e-07,5.242800e-07,5.165000e-07,3.416300e-07,& - & 5.663600e-07,8.360000e-07,8.098800e-07,7.095900e-07,4.340200e-07,& - & 8.953900e-07,1.295700e-06,1.217000e-06,9.988100e-07,5.491700e-07,& - & 1.358500e-06,1.921300e-06,1.768100e-06,1.403900e-06,6.848700e-07,& - & 1.972800e-06,2.726700e-06,2.484000e-06,1.943100e-06,8.412700e-07,& - & 2.372900e-07,3.614100e-07,3.734600e-07,3.881400e-07,2.596500e-07,& - & 3.984700e-07,5.928100e-07,5.814500e-07,5.249700e-07,3.286500e-07,& - & 6.401200e-07,9.341800e-07,8.845100e-07,7.376000e-07,4.172600e-07,& - & 9.854800e-07,1.407200e-06,1.300900e-06,1.041400e-06,5.230400e-07,& - & 1.452400e-06,2.024300e-06,1.849000e-06,1.451400e-06,6.458200e-07,& - & 1.642200e-07,2.531300e-07,2.674100e-07,2.955500e-07,2.008300e-07,& - & 2.808500e-07,4.208900e-07,4.184700e-07,3.911200e-07,2.533100e-07,& - & 4.584000e-07,6.740500e-07,6.438000e-07,5.469600e-07,3.224500e-07,& - & 7.159100e-07,1.031400e-06,9.587900e-07,7.746200e-07,4.063600e-07,& - & 1.070700e-06,1.505000e-06,1.378500e-06,1.086800e-06,5.040700e-07,& - & 1.129700e-07,1.765400e-07,1.916000e-07,2.278500e-07,1.560000e-07,& - & 1.968700e-07,2.973600e-07,3.002400e-07,2.925000e-07,1.955700e-07,& - & 3.265500e-07,4.837900e-07,4.667300e-07,4.054500e-07,2.492600e-07,& - & 5.177600e-07,7.523900e-07,7.039700e-07,5.751500e-07,3.157000e-07,& - & 7.858300e-07,1.114600e-06,1.024200e-06,8.118000e-07,3.935500e-07,& - & 7.720000e-08,1.226400e-07,1.376600e-07,1.785600e-07,1.218700e-07,& - & 1.371500e-07,2.090500e-07,2.148800e-07,2.199800e-07,1.512700e-07,& - & 2.313600e-07,3.452600e-07,3.368700e-07,3.006700e-07,1.927600e-07,& - & 3.726500e-07,5.459800e-07,5.145300e-07,4.263200e-07,2.452900e-07,& - & 5.739600e-07,8.217200e-07,7.579400e-07,6.047700e-07,3.074700e-07,& - & 5.295500e-08,8.576400e-08,1.001700e-07,1.431000e-07,9.643300e-08,& - & 9.583100e-08,1.475700e-07,1.547900e-07,1.674500e-07,1.181900e-07,& - & 1.644400e-07,2.470700e-07,2.439700e-07,2.246300e-07,1.505900e-07,& - & 2.689600e-07,3.969800e-07,3.770600e-07,3.174400e-07,1.923600e-07,& - & 4.202700e-07,6.068600e-07,5.621700e-07,4.521600e-07,2.424300e-07,& - & 4.061300e-08,6.633000e-08,7.875600e-08,1.168200e-07,8.076300e-08,& - & 7.411000e-08,1.146400e-07,1.211900e-07,1.339400e-07,1.002400e-07,& - & 1.282500e-07,1.932700e-07,1.916100e-07,1.784700e-07,1.288700e-07,& - & 2.112500e-07,3.127900e-07,2.977900e-07,2.521700e-07,1.653900e-07,& - & 3.322100e-07,4.812800e-07,4.464800e-07,3.601400e-07,2.091600e-07/ - data absb(1:300,7) / & - & 4.008200e-03,4.747100e-03,4.210600e-03,3.309700e-03,2.979700e-02,& - & 5.495600e-03,6.450300e-03,5.674100e-03,4.360600e-03,3.307600e-02,& - & 7.320100e-03,8.543400e-03,7.472400e-03,5.689900e-03,3.671800e-02,& - & 9.476800e-03,1.100600e-02,9.649000e-03,7.360700e-03,4.056200e-02,& - & 1.201600e-02,1.388300e-02,1.224800e-02,9.412600e-03,4.460700e-02,& - & 3.518200e-03,4.144000e-03,3.671200e-03,2.886500e-03,2.510600e-02,& - & 4.836800e-03,5.658500e-03,4.976300e-03,3.824100e-03,2.817800e-02,& - & 6.439100e-03,7.492600e-03,6.579700e-03,5.012700e-03,3.149900e-02,& - & 8.355600e-03,9.659000e-03,8.495900e-03,6.495600e-03,3.498300e-02,& - & 1.063600e-02,1.219700e-02,1.077800e-02,8.292700e-03,3.867700e-02,& - & 3.080800e-03,3.618000e-03,3.202400e-03,2.507700e-03,2.013300e-02,& - & 4.234200e-03,4.940800e-03,4.357300e-03,3.344700e-03,2.281100e-02,& - & 5.648400e-03,6.542500e-03,5.759800e-03,4.405000e-03,2.564800e-02,& - & 7.356900e-03,8.445900e-03,7.447800e-03,5.699700e-03,2.863300e-02,& - & 9.407900e-03,1.069500e-02,9.452500e-03,7.267100e-03,3.175000e-02,& - & 2.693700e-03,3.158100e-03,2.798000e-03,2.177500e-03,1.539400e-02,& - & 3.708500e-03,4.310900e-03,3.804800e-03,2.921900e-03,1.750700e-02,& - & 4.960900e-03,5.716400e-03,5.035500e-03,3.848300e-03,1.973000e-02,& - & 6.489500e-03,7.400200e-03,6.521900e-03,4.980600e-03,2.208400e-02,& - & 8.316300e-03,9.405100e-03,8.291400e-03,6.352500e-03,2.455100e-02,& - & 2.364200e-03,2.766800e-03,2.448900e-03,1.898800e-03,1.186800e-02,& - & 3.259800e-03,3.781100e-03,3.329000e-03,2.551000e-03,1.355900e-02,& - & 4.374700e-03,5.020200e-03,4.415500e-03,3.361300e-03,1.534000e-02,& - & 5.734000e-03,6.518900e-03,5.728600e-03,4.353800e-03,1.722000e-02,& - & 7.360000e-03,8.299000e-03,7.299200e-03,5.554800e-03,1.920500e-02,& - & 2.089800e-03,2.440500e-03,2.154200e-03,1.662600e-03,9.441700e-03,& - & 2.886300e-03,3.335300e-03,2.931800e-03,2.235200e-03,1.081300e-02,& - & 3.877100e-03,4.435800e-03,3.893500e-03,2.947200e-03,1.226000e-02,& - & 5.083900e-03,5.766300e-03,5.061000e-03,3.822900e-03,1.379700e-02,& - & 6.536200e-03,7.347200e-03,6.454900e-03,4.878100e-03,1.542700e-02,& - & 1.851700e-03,2.154800e-03,1.896500e-03,1.458000e-03,7.777300e-03,& - & 2.557600e-03,2.947100e-03,2.584600e-03,1.961200e-03,8.917600e-03,& - & 3.434500e-03,3.924400e-03,3.436200e-03,2.590600e-03,1.013200e-02,& - & 4.506400e-03,5.099400e-03,4.470000e-03,3.364200e-03,1.143100e-02,& - & 5.809700e-03,6.508300e-03,5.704600e-03,4.290500e-03,1.280800e-02,& - & 1.645800e-03,1.910300e-03,1.678100e-03,1.283100e-03,6.514100e-03,& - & 2.269800e-03,2.613000e-03,2.287700e-03,1.727800e-03,7.484900e-03,& - & 3.046400e-03,3.477200e-03,3.042700e-03,2.284500e-03,8.519800e-03,& - & 4.005300e-03,4.520500e-03,3.956300e-03,2.967100e-03,9.623000e-03,& - & 5.170400e-03,5.787500e-03,5.054200e-03,3.780600e-03,1.080000e-02,& - & 1.454800e-03,1.690300e-03,1.483000e-03,1.127600e-03,5.446100e-03,& - & 2.003100e-03,2.310200e-03,2.021400e-03,1.520200e-03,6.276300e-03,& - & 2.691900e-03,3.072300e-03,2.685400e-03,2.011400e-03,7.163600e-03,& - & 3.543600e-03,4.004000e-03,3.493500e-03,2.608800e-03,8.109800e-03,& - & 4.574200e-03,5.141600e-03,4.472300e-03,3.326100e-03,9.111200e-03,& - & 1.302500e-03,1.517600e-03,1.331900e-03,1.007800e-03,4.497000e-03,& - & 1.791100e-03,2.067600e-03,1.810400e-03,1.358300e-03,5.195300e-03,& - & 2.407000e-03,2.751100e-03,2.402100e-03,1.793300e-03,5.945500e-03,& - & 3.163500e-03,3.591600e-03,3.128500e-03,2.322800e-03,6.743500e-03,& - & 4.074500e-03,4.610700e-03,4.004800e-03,2.965000e-03,7.590400e-03,& - & 1.162800e-03,1.356400e-03,1.191100e-03,9.003500e-04,3.686500e-03,& - & 1.598100e-03,1.845800e-03,1.615700e-03,1.211100e-03,4.271800e-03,& - & 2.143400e-03,2.457800e-03,2.145100e-03,1.596100e-03,4.900400e-03,& - & 2.807000e-03,3.208900e-03,2.793100e-03,2.069300e-03,5.569000e-03,& - & 3.606000e-03,4.111400e-03,3.571800e-03,2.640800e-03,6.276700e-03,& - & 1.034900e-03,1.207900e-03,1.060800e-03,8.014500e-04,2.977200e-03,& - & 1.420000e-03,1.644200e-03,1.438400e-03,1.076200e-03,3.461900e-03,& - & 1.897400e-03,2.188100e-03,1.908900e-03,1.419200e-03,3.981500e-03,& - & 2.477900e-03,2.849900e-03,2.481800e-03,1.840000e-03,4.532200e-03,& - & 3.175400e-03,3.638500e-03,3.166600e-03,2.345700e-03,5.115100e-03/ - data absb(301:600,7) / & - & 9.223200e-04,1.077200e-03,9.452400e-04,7.125300e-04,2.403200e-03,& - & 1.260500e-03,1.464800e-03,1.281000e-03,9.567300e-04,2.802300e-03,& - & 1.678200e-03,1.943400e-03,1.696100e-03,1.261100e-03,3.228300e-03,& - & 2.185800e-03,2.522000e-03,2.197800e-03,1.632900e-03,3.680300e-03,& - & 2.795300e-03,3.212500e-03,2.797300e-03,2.077600e-03,4.158600e-03,& - & 8.257700e-04,9.660200e-04,8.469800e-04,6.365100e-04,1.958900e-03,& - & 1.123100e-03,1.308200e-03,1.144200e-03,8.538000e-04,2.287400e-03,& - & 1.489400e-03,1.728300e-03,1.508600e-03,1.123100e-03,2.638100e-03,& - & 1.934700e-03,2.235800e-03,1.948600e-03,1.450200e-03,3.010000e-03,& - & 2.471800e-03,2.843100e-03,2.475300e-03,1.839900e-03,3.401800e-03,& - & 7.364300e-04,8.631900e-04,7.564400e-04,5.675700e-04,1.569800e-03,& - & 9.972100e-04,1.163400e-03,1.017500e-03,7.594900e-04,1.834800e-03,& - & 1.318900e-03,1.531400e-03,1.336400e-03,9.961900e-04,2.118300e-03,& - & 1.710900e-03,1.977100e-03,1.722200e-03,1.282700e-03,2.418700e-03,& - & 2.186100e-03,2.513100e-03,2.185100e-03,1.624300e-03,2.733900e-03,& - & 6.543400e-04,7.683700e-04,6.729100e-04,5.048000e-04,1.234900e-03,& - & 8.833500e-04,1.031200e-03,9.013600e-04,6.734800e-04,1.445400e-03,& - & 1.165400e-03,1.354400e-03,1.180600e-03,8.806500e-04,1.670100e-03,& - & 1.513000e-03,1.746800e-03,1.519700e-03,1.131700e-03,1.908400e-03,& - & 1.934600e-03,2.221400e-03,1.927500e-03,1.431100e-03,2.159000e-03,& - & 5.825000e-04,6.841500e-04,5.990000e-04,4.492300e-04,9.613800e-04,& - & 7.837900e-04,9.155900e-04,7.993500e-04,5.972400e-04,1.126400e-03,& - & 1.033700e-03,1.200600e-03,1.045200e-03,7.791800e-04,1.302700e-03,& - & 1.343000e-03,1.548500e-03,1.344500e-03,9.994300e-04,1.490300e-03,& - & 1.720700e-03,1.971200e-03,1.705800e-03,1.262800e-03,1.687400e-03,& - & 5.178800e-04,6.085100e-04,5.324400e-04,3.992200e-04,7.380700e-04,& - & 6.956000e-04,8.128000e-04,7.089600e-04,5.292600e-04,8.655500e-04,& - & 9.185400e-04,1.065300e-03,9.260800e-04,6.894400e-04,1.002900e-03,& - & 1.194800e-03,1.375200e-03,1.191700e-03,8.834100e-04,1.149100e-03,& - & 1.533500e-03,1.754700e-03,1.512500e-03,1.116200e-03,1.302400e-03,& - & 4.609200e-04,5.421100e-04,4.740800e-04,3.550900e-04,5.568200e-04,& - & 6.191800e-04,7.232100e-04,6.300500e-04,4.699700e-04,6.545400e-04,& - & 8.188100e-04,9.482200e-04,8.229000e-04,6.114100e-04,7.599700e-04,& - & 1.066800e-03,1.226700e-03,1.059300e-03,7.829200e-04,8.719500e-04,& - & 1.370400e-03,1.568100e-03,1.346500e-03,9.892000e-04,9.897300e-04,& - & 4.115200e-04,4.840900e-04,4.230800e-04,3.164500e-04,4.216800e-04,& - & 5.533400e-04,6.457500e-04,5.616700e-04,4.183300e-04,4.967700e-04,& - & 7.329900e-04,8.476600e-04,7.338300e-04,5.437000e-04,5.777400e-04,& - & 9.558800e-04,1.098700e-03,9.458600e-04,6.961300e-04,6.638400e-04,& - & 1.228800e-03,1.406500e-03,1.204000e-03,8.801300e-04,7.548600e-04,& - & 3.685400e-04,4.331600e-04,3.781700e-04,2.826000e-04,3.189900e-04,& - & 4.964600e-04,5.781600e-04,5.022100e-04,3.731500e-04,3.765600e-04,& - & 6.580800e-04,7.606300e-04,6.566700e-04,4.848000e-04,4.387600e-04,& - & 8.586700e-04,9.878200e-04,8.474800e-04,6.213300e-04,5.051700e-04,& - & 1.103700e-03,1.265800e-03,1.080100e-03,7.861100e-04,5.753200e-04,& - & 3.286700e-04,3.857200e-04,3.362200e-04,2.507100e-04,2.485500e-04,& - & 4.434300e-04,5.156900e-04,4.468600e-04,3.310100e-04,2.938100e-04,& - & 5.881000e-04,6.799000e-04,5.852800e-04,4.303100e-04,3.425500e-04,& - & 7.673700e-04,8.842800e-04,7.564000e-04,5.521700e-04,3.947800e-04,& - & 9.851700e-04,1.134200e-03,9.655400e-04,6.995100e-04,4.500200e-04,& - & 2.851300e-04,3.343800e-04,2.910800e-04,2.167200e-04,1.897400e-04,& - & 3.854200e-04,4.485700e-04,3.880200e-04,2.866100e-04,2.249200e-04,& - & 5.120800e-04,5.932900e-04,5.096700e-04,3.735600e-04,2.628400e-04,& - & 6.688200e-04,7.736600e-04,6.605900e-04,4.804600e-04,3.035200e-04,& - & 8.577500e-04,9.935800e-04,8.454800e-04,6.101000e-04,3.469100e-04,& - & 2.390800e-04,2.808600e-04,2.443200e-04,1.817200e-04,1.413100e-04,& - & 3.244700e-04,3.786600e-04,3.272900e-04,2.412300e-04,1.682800e-04,& - & 4.324400e-04,5.030600e-04,4.317900e-04,3.157300e-04,1.975200e-04,& - & 5.658700e-04,6.584300e-04,5.620600e-04,4.077800e-04,2.289900e-04,& - & 7.260000e-04,8.474600e-04,7.217700e-04,5.196700e-04,2.626200e-04/ - data absb(601:900,7) / & - & 1.922300e-04,2.263500e-04,1.968700e-04,1.463000e-04,1.079400e-04,& - & 2.624200e-04,3.072400e-04,2.655300e-04,1.954700e-04,1.291000e-04,& - & 3.515000e-04,4.107100e-04,3.526200e-04,2.574000e-04,1.521300e-04,& - & 4.618500e-04,5.405100e-04,4.616700e-04,3.345000e-04,1.770000e-04,& - & 5.941600e-04,6.986500e-04,5.957300e-04,4.285900e-04,2.036600e-04,& - & 1.539600e-04,1.818600e-04,1.582000e-04,1.174500e-04,8.202600e-05,& - & 2.113900e-04,2.485300e-04,2.148600e-04,1.580200e-04,9.855500e-05,& - & 2.845400e-04,3.343300e-04,2.872100e-04,2.094300e-04,1.166100e-04,& - & 3.753800e-04,4.423300e-04,3.783500e-04,2.738400e-04,1.362200e-04,& - & 4.843200e-04,5.742500e-04,4.905400e-04,3.527600e-04,1.573000e-04,& - & 1.231000e-04,1.459600e-04,1.270300e-04,9.429100e-05,6.178300e-05,& - & 1.699400e-04,2.008500e-04,1.737500e-04,1.277200e-04,7.460700e-05,& - & 2.298800e-04,2.719000e-04,2.338500e-04,1.703900e-04,8.868900e-05,& - & 3.044700e-04,3.615700e-04,3.099600e-04,2.241600e-04,1.040400e-04,& - & 3.938300e-04,4.714300e-04,4.036400e-04,2.902200e-04,1.206200e-04,& - & 9.515500e-05,1.133200e-04,9.873400e-05,7.334400e-05,4.698500e-05,& - & 1.323600e-04,1.572600e-04,1.362100e-04,1.002000e-04,5.705400e-05,& - & 1.803100e-04,2.145400e-04,1.848400e-04,1.347400e-04,6.816200e-05,& - & 2.401700e-04,2.872500e-04,2.468400e-04,1.786100e-04,8.032100e-05,& - & 3.122300e-04,3.770000e-04,3.235800e-04,2.327900e-04,9.349900e-05,& - & 7.304000e-05,8.736500e-05,7.621900e-05,5.669600e-05,3.562800e-05,& - & 1.024200e-04,1.223100e-04,1.060800e-04,7.814900e-05,4.352800e-05,& - & 1.405100e-04,1.681900e-04,1.452100e-04,1.059800e-04,5.227700e-05,& - & 1.883800e-04,2.268800e-04,1.954200e-04,1.415600e-04,6.189400e-05,& - & 2.462200e-04,2.997600e-04,2.579800e-04,1.858600e-04,7.235700e-05,& - & 5.586400e-05,6.711900e-05,5.865200e-05,4.371900e-05,2.685300e-05,& - & 7.900900e-05,9.483100e-05,8.236800e-05,6.079800e-05,3.301700e-05,& - & 1.091900e-04,1.314300e-04,1.137100e-04,8.313300e-05,3.988100e-05,& - & 1.473600e-04,1.786600e-04,1.542400e-04,1.119500e-04,4.744900e-05,& - & 1.937200e-04,2.376600e-04,2.051100e-04,1.480300e-04,5.573000e-05,& - & 4.176100e-05,5.039800e-05,4.413000e-05,3.298500e-05,2.007300e-05,& - & 5.964500e-05,7.191600e-05,6.259900e-05,4.633000e-05,2.486400e-05,& - & 8.319400e-05,1.006400e-04,8.723200e-05,6.394200e-05,3.023500e-05,& - & 1.132000e-04,1.380300e-04,1.194000e-04,8.687000e-05,3.617800e-05,& - & 1.499200e-04,1.851100e-04,1.601100e-04,1.158700e-04,4.270700e-05,& - & 3.080100e-05,3.734900e-05,3.275300e-05,2.457700e-05,1.489100e-05,& - & 4.448700e-05,5.387100e-05,4.699000e-05,3.488800e-05,1.859200e-05,& - & 6.265800e-05,7.615600e-05,6.612900e-05,4.862300e-05,2.277300e-05,& - & 8.606100e-05,1.054700e-04,9.138800e-05,6.667900e-05,2.743100e-05,& - & 1.150100e-04,1.427400e-04,1.236900e-04,8.974700e-05,3.256500e-05,& - & 2.260800e-05,2.754100e-05,2.418500e-05,1.823200e-05,1.095800e-05,& - & 3.302500e-05,4.015900e-05,3.510900e-05,2.615600e-05,1.379900e-05,& - & 4.701100e-05,5.737900e-05,4.991900e-05,3.682000e-05,1.703100e-05,& - & 6.519800e-05,8.026500e-05,6.966900e-05,5.097500e-05,2.066000e-05,& - & 8.791500e-05,1.096500e-04,9.515900e-05,6.923600e-05,2.467500e-05,& - & 1.637300e-05,2.004300e-05,1.762400e-05,1.336000e-05,7.992600e-06,& - & 2.421600e-05,2.956700e-05,2.590300e-05,1.937300e-05,1.016000e-05,& - & 3.486800e-05,4.272200e-05,3.724100e-05,2.756400e-05,1.264300e-05,& - & 4.888200e-05,6.041000e-05,5.252200e-05,3.853900e-05,1.545500e-05,& - & 6.657900e-05,8.339200e-05,7.247200e-05,5.286400e-05,1.858600e-05,& - & 1.159900e-05,1.426800e-05,1.256700e-05,9.584600e-06,5.786500e-06,& - & 1.739400e-05,2.132100e-05,1.871900e-05,1.406300e-05,7.432000e-06,& - & 2.537500e-05,3.118900e-05,2.724400e-05,2.024200e-05,9.334500e-06,& - & 3.602000e-05,4.462400e-05,3.886800e-05,2.861200e-05,1.150600e-05,& - & 4.965000e-05,6.235800e-05,5.424700e-05,3.967400e-05,1.394500e-05,& - & 8.159200e-06,1.008800e-05,8.902900e-06,6.835200e-06,4.148600e-06,& - & 1.241400e-05,1.528100e-05,1.344200e-05,1.014700e-05,5.386500e-06,& - & 1.835500e-05,2.263600e-05,1.981500e-05,1.478400e-05,6.832000e-06,& - & 2.639900e-05,3.278700e-05,2.860600e-05,2.113000e-05,8.497200e-06,& - & 3.683400e-05,4.637400e-05,4.039800e-05,2.962300e-05,1.038300e-05/ - data absb(901:1175,7) / & - & 5.695000e-06,7.085400e-06,6.265800e-06,4.846000e-06,2.941100e-06,& - & 8.804000e-06,1.088000e-05,9.588400e-06,7.277600e-06,3.860700e-06,& - & 1.319400e-05,1.632100e-05,1.432300e-05,1.073100e-05,4.947100e-06,& - & 1.923100e-05,2.394500e-05,2.092700e-05,1.551500e-05,6.211200e-06,& - & 2.718300e-05,3.429100e-05,2.991700e-05,2.199900e-05,7.656600e-06,& - & 3.995800e-06,5.001500e-06,4.436600e-06,3.458500e-06,2.122700e-06,& - & 6.278400e-06,7.790100e-06,6.875900e-06,5.249000e-06,2.812300e-06,& - & 9.536700e-06,1.182800e-05,1.040600e-05,7.827300e-06,3.638400e-06,& - & 1.407600e-05,1.757400e-05,1.538400e-05,1.144500e-05,4.606900e-06,& - & 2.015800e-05,2.547000e-05,2.225100e-05,1.640600e-05,5.724500e-06,& - & 2.798800e-06,3.526600e-06,3.140300e-06,2.472900e-06,1.542800e-06,& - & 4.475800e-06,5.578100e-06,4.931300e-06,3.786800e-06,2.061500e-06,& - & 6.895100e-06,8.572200e-06,7.556000e-06,5.708400e-06,2.691500e-06,& - & 1.030400e-05,1.289400e-05,1.130800e-05,8.439300e-06,3.436300e-06,& - & 1.494500e-05,1.892000e-05,1.654600e-05,1.223200e-05,4.303100e-06,& - & 1.943500e-06,2.468500e-06,2.209800e-06,1.763400e-06,1.114300e-06,& - & 3.169500e-06,3.971300e-06,3.518300e-06,2.719900e-06,1.501100e-06,& - & 4.959200e-06,6.182800e-06,5.458100e-06,4.143400e-06,1.977500e-06,& - & 7.508200e-06,9.411900e-06,8.272200e-06,6.194900e-06,2.546700e-06,& - & 1.102600e-05,1.398400e-05,1.224600e-05,9.078000e-06,3.214500e-06,& - & 1.335900e-06,1.712800e-06,1.543900e-06,1.255100e-06,7.987400e-07,& - & 2.227400e-06,2.808600e-06,2.495100e-06,1.944600e-06,1.084300e-06,& - & 3.544500e-06,4.434200e-06,3.920600e-06,2.991600e-06,1.440700e-06,& - & 5.442300e-06,6.830700e-06,6.017300e-06,4.523100e-06,1.872100e-06,& - & 8.093100e-06,1.028100e-05,9.016800e-06,6.703100e-06,2.382100e-06,& - & 9.265200e-07,1.198800e-06,1.089200e-06,9.047200e-07,5.918500e-07,& - & 1.579100e-06,2.004200e-06,1.786400e-06,1.405300e-06,8.090300e-07,& - & 2.556400e-06,3.210600e-06,2.843300e-06,2.181200e-06,1.082900e-06,& - & 3.981000e-06,5.004200e-06,4.415800e-06,3.331100e-06,1.417900e-06,& - & 5.994000e-06,7.621300e-06,6.694100e-06,4.990800e-06,1.816200e-06,& - & 6.427100e-07,8.398600e-07,7.696900e-07,6.562200e-07,4.468000e-07,& - & 1.120200e-06,1.431500e-06,1.281200e-06,1.019800e-06,6.146900e-07,& - & 1.846300e-06,2.330300e-06,2.067200e-06,1.595000e-06,8.284800e-07,& - & 2.918700e-06,3.675200e-06,3.248400e-06,2.459300e-06,1.092300e-06,& - & 4.449000e-06,5.662300e-06,4.979900e-06,3.723200e-06,1.407900e-06,& - & 4.422200e-07,5.844300e-07,5.413200e-07,4.767500e-07,3.373800e-07,& - & 7.890700e-07,1.015700e-06,9.137700e-07,7.381000e-07,4.667100e-07,& - & 1.324800e-06,1.681900e-06,1.495600e-06,1.162200e-06,6.335400e-07,& - & 2.129600e-06,2.688500e-06,2.379300e-06,1.809100e-06,8.412500e-07,& - & 3.290500e-06,4.190600e-06,3.690500e-06,2.766700e-06,1.091700e-06,& - & 3.016600e-07,4.036600e-07,3.789000e-07,3.475900e-07,2.549500e-07,& - & 5.516100e-07,7.154200e-07,6.479200e-07,5.333400e-07,3.543300e-07,& - & 9.447000e-07,1.206900e-06,1.076100e-06,8.439400e-07,4.844600e-07,& - & 1.544800e-06,1.957100e-06,1.734900e-06,1.325700e-06,6.479100e-07,& - & 2.423100e-06,3.088500e-06,2.724600e-06,2.047600e-06,8.465000e-07,& - & 2.061500e-07,2.796600e-07,2.665900e-07,2.567200e-07,1.949000e-07,& - & 3.863400e-07,5.050600e-07,4.608200e-07,3.879200e-07,2.719300e-07,& - & 6.754500e-07,8.679400e-07,7.767200e-07,6.153400e-07,3.743900e-07,& - & 1.122900e-06,1.428900e-06,1.269000e-06,9.753900e-07,5.041700e-07,& - & 1.788800e-06,2.284100e-06,2.018200e-06,1.520900e-06,6.629900e-07,& - & 1.586400e-07,2.161800e-07,2.073200e-07,2.035000e-07,1.656500e-07,& - & 3.007200e-07,3.945100e-07,3.608600e-07,3.063200e-07,2.329700e-07,& - & 5.310300e-07,6.846300e-07,6.135500e-07,4.879200e-07,3.225800e-07,& - & 8.909600e-07,1.137700e-06,1.011300e-06,7.787400e-07,4.360800e-07,& - & 1.431100e-06,1.834400e-06,1.621400e-06,1.222300e-06,5.745600e-07/ - data absb(1:300,8) / & - & 1.143100e-02,1.274100e-02,1.143600e-02,9.162100e-03,8.051900e-02,& - & 1.520600e-02,1.716000e-02,1.555500e-02,1.245400e-02,8.686400e-02,& - & 1.997600e-02,2.272200e-02,2.065400e-02,1.650200e-02,9.444600e-02,& - & 2.595400e-02,2.964300e-02,2.678100e-02,2.140600e-02,1.033300e-01,& - & 3.335200e-02,3.795300e-02,3.418900e-02,2.727700e-02,1.130400e-01,& - & 1.017900e-02,1.138900e-02,1.017600e-02,8.052200e-03,6.550400e-02,& - & 1.364100e-02,1.535500e-02,1.381700e-02,1.090600e-02,7.223000e-02,& - & 1.802300e-02,2.041800e-02,1.835200e-02,1.443700e-02,8.015000e-02,& - & 2.353200e-02,2.670500e-02,2.387600e-02,1.875800e-02,8.903800e-02,& - & 3.023900e-02,3.428200e-02,3.061400e-02,2.401700e-02,9.857700e-02,& - & 9.009000e-03,1.012000e-02,9.016700e-03,7.076400e-03,5.259100e-02,& - & 1.218600e-02,1.373400e-02,1.225800e-02,9.569600e-03,5.940200e-02,& - & 1.622500e-02,1.833300e-02,1.634000e-02,1.268800e-02,6.712700e-02,& - & 2.118500e-02,2.404200e-02,2.133200e-02,1.657800e-02,7.551200e-02,& - & 2.714100e-02,3.092800e-02,2.748000e-02,2.133300e-02,8.452100e-02,& - & 7.966600e-03,8.986200e-03,7.967100e-03,6.224200e-03,4.129400e-02,& - & 1.088500e-02,1.227000e-02,1.088500e-02,8.430300e-03,4.751900e-02,& - & 1.451100e-02,1.644200e-02,1.454400e-02,1.123400e-02,5.441500e-02,& - & 1.892600e-02,2.155400e-02,1.907600e-02,1.475000e-02,6.180100e-02,& - & 2.423600e-02,2.768700e-02,2.463300e-02,1.902400e-02,6.962400e-02,& - & 7.108000e-03,8.014700e-03,7.075800e-03,5.487300e-03,3.329700e-02,& - & 9.738800e-03,1.099100e-02,9.694000e-03,7.458700e-03,3.875400e-02,& - & 1.297100e-02,1.471200e-02,1.298000e-02,9.980600e-03,4.467300e-02,& - & 1.692000e-02,1.922100e-02,1.703700e-02,1.313100e-02,5.087800e-02,& - & 2.167500e-02,2.468800e-02,2.195800e-02,1.694400e-02,5.739200e-02,& - & 6.404800e-03,7.214900e-03,6.342300e-03,4.870500e-03,2.761000e-02,& - & 8.757900e-03,9.892900e-03,8.696000e-03,6.639900e-03,3.224100e-02,& - & 1.167400e-02,1.317800e-02,1.161400e-02,8.893700e-03,3.715100e-02,& - & 1.522600e-02,1.718300e-02,1.519000e-02,1.167800e-02,4.232100e-02,& - & 1.952100e-02,2.206500e-02,1.953600e-02,1.502200e-02,4.775900e-02,& - & 5.778000e-03,6.509700e-03,5.707300e-03,4.336200e-03,2.351700e-02,& - & 7.898000e-03,8.894300e-03,7.801900e-03,5.918200e-03,2.746400e-02,& - & 1.054700e-02,1.181300e-02,1.037800e-02,7.908200e-03,3.165300e-02,& - & 1.378000e-02,1.539500e-02,1.354400e-02,1.033400e-02,3.606800e-02,& - & 1.766100e-02,1.976900e-02,1.738700e-02,1.326300e-02,4.067200e-02,& - & 5.235800e-03,5.894300e-03,5.160900e-03,3.893000e-03,2.026500e-02,& - & 7.165000e-03,8.033700e-03,7.030300e-03,5.300900e-03,2.364200e-02,& - & 9.576800e-03,1.067300e-02,9.327000e-03,7.046700e-03,2.721000e-02,& - & 1.252000e-02,1.391000e-02,1.214800e-02,9.177200e-03,3.095500e-02,& - & 1.605400e-02,1.783000e-02,1.557100e-02,1.176000e-02,3.485600e-02,& - & 4.730600e-03,5.322800e-03,4.648000e-03,3.493400e-03,1.741500e-02,& - & 6.483700e-03,7.250500e-03,6.321400e-03,4.741000e-03,2.024800e-02,& - & 8.667200e-03,9.647900e-03,8.392000e-03,6.277600e-03,2.324600e-02,& - & 1.134000e-02,1.258100e-02,1.091800e-02,8.162000e-03,2.639700e-02,& - & 1.456000e-02,1.610200e-02,1.396700e-02,1.044000e-02,2.969700e-02,& - & 4.341800e-03,4.876500e-03,4.250500e-03,3.183100e-03,1.472500e-02,& - & 5.944900e-03,6.638000e-03,5.774400e-03,4.303800e-03,1.707300e-02,& - & 7.938900e-03,8.832100e-03,7.661500e-03,5.688300e-03,1.956000e-02,& - & 1.038200e-02,1.150700e-02,9.958300e-03,7.380800e-03,2.218000e-02,& - & 1.334800e-02,1.471800e-02,1.272400e-02,9.415800e-03,2.494200e-02,& - & 3.975500e-03,4.460100e-03,3.879100e-03,2.894000e-03,1.231700e-02,& - & 5.432600e-03,6.067500e-03,5.264900e-03,3.907900e-03,1.426100e-02,& - & 7.247100e-03,8.065200e-03,6.977500e-03,5.160900e-03,1.631900e-02,& - & 9.485300e-03,1.049900e-02,9.066900e-03,6.681700e-03,1.849400e-02,& - & 1.222400e-02,1.343300e-02,1.157500e-02,8.501600e-03,2.080300e-02,& - & 3.623700e-03,4.066400e-03,3.532700e-03,2.624900e-03,1.011100e-02,& - & 4.940500e-03,5.528400e-03,4.786700e-03,3.542200e-03,1.171200e-02,& - & 6.594100e-03,7.336700e-03,6.341200e-03,4.674000e-03,1.340700e-02,& - & 8.650000e-03,9.558200e-03,8.238700e-03,6.041300e-03,1.520300e-02,& - & 1.116000e-02,1.225800e-02,1.051800e-02,7.674500e-03,1.712000e-02/ - data absb(301:600,8) / & - & 3.292300e-03,3.709700e-03,3.217400e-03,2.385200e-03,8.274300e-03,& - & 4.486800e-03,5.033300e-03,4.354700e-03,3.214000e-03,9.586400e-03,& - & 6.002200e-03,6.681700e-03,5.765200e-03,4.234800e-03,1.098200e-02,& - & 7.885500e-03,8.718700e-03,7.491300e-03,5.465500e-03,1.246900e-02,& - & 1.016900e-02,1.119600e-02,9.576800e-03,6.938500e-03,1.405700e-02,& - & 2.996600e-03,3.393600e-03,2.943500e-03,2.177300e-03,6.822600e-03,& - & 4.088700e-03,4.600300e-03,3.976800e-03,2.928100e-03,7.905600e-03,& - & 5.474500e-03,6.114900e-03,5.264000e-03,3.849100e-03,9.060700e-03,& - & 7.188600e-03,7.985600e-03,6.845600e-03,4.964300e-03,1.030000e-02,& - & 9.259600e-03,1.024800e-02,8.748900e-03,6.301400e-03,1.162400e-02,& - & 2.715600e-03,3.087600e-03,2.680500e-03,1.982200e-03,5.515800e-03,& - & 3.710400e-03,4.190000e-03,3.621500e-03,2.659300e-03,6.400100e-03,& - & 4.966700e-03,5.577100e-03,4.800400e-03,3.492800e-03,7.346600e-03,& - & 6.512000e-03,7.281300e-03,6.239600e-03,4.503800e-03,8.362600e-03,& - & 8.374800e-03,9.331200e-03,7.964900e-03,5.710100e-03,9.454000e-03,& - & 2.454000e-03,2.801500e-03,2.433200e-03,1.798600e-03,4.371700e-03,& - & 3.353300e-03,3.806500e-03,3.290700e-03,2.410400e-03,5.084400e-03,& - & 4.481600e-03,5.064800e-03,4.361100e-03,3.164100e-03,5.849100e-03,& - & 5.865600e-03,6.605900e-03,5.664900e-03,4.078300e-03,6.671900e-03,& - & 7.537500e-03,8.452400e-03,7.218100e-03,5.163400e-03,7.553400e-03,& - & 2.219900e-03,2.546800e-03,2.211600e-03,1.632000e-03,3.431300e-03,& - & 3.028400e-03,3.457600e-03,2.990800e-03,2.186800e-03,4.000700e-03,& - & 4.039400e-03,4.595900e-03,3.958400e-03,2.869300e-03,4.614100e-03,& - & 5.280400e-03,5.985100e-03,5.133300e-03,3.690100e-03,5.272300e-03,& - & 6.781500e-03,7.648200e-03,6.527300e-03,4.667000e-03,5.978400e-03,& - & 2.004600e-03,2.313000e-03,2.009000e-03,1.479400e-03,2.654300e-03,& - & 2.729500e-03,3.136900e-03,2.713800e-03,1.981200e-03,3.104300e-03,& - & 3.635600e-03,4.160700e-03,3.584100e-03,2.595100e-03,3.589200e-03,& - & 4.749100e-03,5.410300e-03,4.636300e-03,3.332300e-03,4.108800e-03,& - & 6.103000e-03,6.906300e-03,5.895000e-03,4.207400e-03,4.667300e-03,& - & 1.811600e-03,2.102100e-03,1.826400e-03,1.342600e-03,2.019200e-03,& - & 2.462600e-03,2.844500e-03,2.461500e-03,1.794700e-03,2.368200e-03,& - & 3.277000e-03,3.768000e-03,3.243500e-03,2.345400e-03,2.745400e-03,& - & 4.282500e-03,4.893300e-03,4.190700e-03,3.005700e-03,3.151600e-03,& - & 5.510700e-03,6.249600e-03,5.325700e-03,3.788900e-03,3.587300e-03,& - & 1.640900e-03,1.912800e-03,1.661500e-03,1.220000e-03,1.539900e-03,& - & 2.227600e-03,2.583400e-03,2.233500e-03,1.625700e-03,1.810800e-03,& - & 2.964200e-03,3.416400e-03,2.936600e-03,2.119200e-03,2.104900e-03,& - & 3.878300e-03,4.438200e-03,3.792900e-03,2.712000e-03,2.421600e-03,& - & 5.000800e-03,5.672700e-03,4.821200e-03,3.416800e-03,2.763000e-03,& - & 1.489600e-03,1.742500e-03,1.512100e-03,1.108500e-03,1.170800e-03,& - & 2.021900e-03,2.349900e-03,2.027400e-03,1.471700e-03,1.379800e-03,& - & 2.693300e-03,3.105900e-03,2.664100e-03,1.914500e-03,1.607800e-03,& - & 3.531200e-03,4.036000e-03,3.438300e-03,2.448500e-03,1.854900e-03,& - & 4.557600e-03,5.170200e-03,4.376900e-03,3.087300e-03,2.122100e-03,& - & 1.346100e-03,1.577300e-03,1.365400e-03,9.984800e-04,9.182800e-04,& - & 1.829300e-03,2.126400e-03,1.829400e-03,1.322400e-03,1.085000e-03,& - & 2.442100e-03,2.812900e-03,2.403800e-03,1.718600e-03,1.267000e-03,& - & 3.207700e-03,3.663100e-03,3.107600e-03,2.199700e-03,1.465400e-03,& - & 4.152100e-03,4.702700e-03,3.961400e-03,2.777300e-03,1.680100e-03,& - & 1.183200e-03,1.388200e-03,1.199100e-03,8.740200e-04,7.039300e-04,& - & 1.613600e-03,1.876500e-03,1.608900e-03,1.158500e-03,8.344500e-04,& - & 2.163100e-03,2.489900e-03,2.118600e-03,1.508900e-03,9.777000e-04,& - & 2.853500e-03,3.254200e-03,2.748500e-03,1.936400e-03,1.134300e-03,& - & 3.709200e-03,4.196500e-03,3.516400e-03,2.452200e-03,1.303900e-03,& - & 1.006600e-03,1.183300e-03,1.019500e-03,7.406400e-04,5.236600e-04,& - & 1.381500e-03,1.607100e-03,1.373900e-03,9.857300e-04,6.234400e-04,& - & 1.862600e-03,2.144900e-03,1.819100e-03,1.289800e-03,7.336000e-04,& - & 2.474100e-03,2.818200e-03,2.372900e-03,1.663500e-03,8.543600e-04,& - & 3.233600e-03,3.656800e-03,3.050400e-03,2.118100e-03,9.862500e-04/ - data absb(601:900,8) / & - & 8.208400e-04,9.670900e-04,8.322900e-04,6.037400e-04,4.042000e-04,& - & 1.137200e-03,1.325400e-03,1.130000e-03,8.087200e-04,4.841700e-04,& - & 1.546800e-03,1.782600e-03,1.508300e-03,1.064300e-03,5.728300e-04,& - & 2.072400e-03,2.360300e-03,1.980700e-03,1.382900e-03,6.703100e-04,& - & 2.730100e-03,3.085200e-03,2.565600e-03,1.772500e-03,7.769300e-04,& - & 6.676500e-04,7.885600e-04,6.779600e-04,4.908700e-04,3.103400e-04,& - & 9.339900e-04,1.090800e-03,9.283100e-04,6.621000e-04,3.742000e-04,& - & 1.282900e-03,1.480100e-03,1.248000e-03,8.778800e-04,4.452900e-04,& - & 1.733400e-03,1.976500e-03,1.652100e-03,1.148400e-03,5.238900e-04,& - & 2.304200e-03,2.602800e-03,2.156500e-03,1.482300e-03,6.100800e-04,& - & 5.431500e-04,6.431000e-04,5.521100e-04,3.989000e-04,2.358300e-04,& - & 7.674300e-04,8.979700e-04,7.631400e-04,5.426900e-04,2.863200e-04,& - & 1.064900e-03,1.229900e-03,1.034200e-03,7.246200e-04,3.429300e-04,& - & 1.451900e-03,1.657500e-03,1.379100e-03,9.549600e-04,4.057500e-04,& - & 1.946200e-03,2.198700e-03,1.814900e-03,1.241100e-03,4.748700e-04,& - & 4.266000e-04,5.072200e-04,4.353700e-04,3.143800e-04,1.812800e-04,& - & 6.103900e-04,7.164700e-04,6.081700e-04,4.318900e-04,2.218700e-04,& - & 8.570300e-04,9.924000e-04,8.337400e-04,5.827600e-04,2.676000e-04,& - & 1.182300e-03,1.351000e-03,1.122500e-03,7.745900e-04,3.185700e-04,& - & 1.601800e-03,1.812300e-03,1.491600e-03,1.015800e-03,3.747900e-04,& - & 3.327100e-04,3.973600e-04,3.410800e-04,2.462400e-04,1.388500e-04,& - & 4.822500e-04,5.684600e-04,4.823700e-04,3.421600e-04,1.713700e-04,& - & 6.857600e-04,7.968800e-04,6.683700e-04,4.662200e-04,2.082100e-04,& - & 9.573200e-04,1.097600e-03,9.099600e-04,6.257100e-04,2.495500e-04,& - & 1.312000e-03,1.487000e-03,1.221400e-03,8.282900e-04,2.951600e-04,& - & 2.586700e-04,3.104200e-04,2.664500e-04,1.924400e-04,1.055400e-04,& - & 3.800500e-04,4.498100e-04,3.816000e-04,2.703300e-04,1.313800e-04,& - & 5.475000e-04,6.385200e-04,5.351100e-04,3.726200e-04,1.608900e-04,& - & 7.737000e-04,8.898900e-04,7.367500e-04,5.053000e-04,1.941400e-04,& - & 1.073200e-03,1.219200e-03,9.994400e-04,6.754200e-04,2.310000e-04,& - & 1.960800e-04,2.365400e-04,2.033000e-04,1.469200e-04,7.964000e-05,& - & 2.924400e-04,3.478600e-04,2.953600e-04,2.092900e-04,1.001300e-04,& - & 4.274600e-04,5.010900e-04,4.196800e-04,2.922700e-04,1.237000e-04,& - & 6.125800e-04,7.073700e-04,5.853100e-04,4.007700e-04,1.504700e-04,& - & 8.608900e-04,9.813200e-04,8.032500e-04,5.416500e-04,1.803000e-04,& - & 1.464100e-04,1.775900e-04,1.528900e-04,1.107600e-04,5.962700e-05,& - & 2.218400e-04,2.653400e-04,2.256000e-04,1.600500e-04,7.577700e-05,& - & 3.292400e-04,3.878000e-04,3.252400e-04,2.265700e-04,9.451700e-05,& - & 4.789300e-04,5.557100e-04,4.599300e-04,3.146500e-04,1.159900e-04,& - & 6.824300e-04,7.813000e-04,6.391600e-04,4.304000e-04,1.400600e-04,& - & 1.086500e-04,1.325100e-04,1.143500e-04,8.296000e-05,4.421200e-05,& - & 1.672900e-04,2.012800e-04,1.713400e-04,1.218300e-04,5.683000e-05,& - & 2.522900e-04,2.990800e-04,2.508300e-04,1.748600e-04,7.160400e-05,& - & 3.726200e-04,4.345200e-04,3.598600e-04,2.461900e-04,8.863200e-05,& - & 5.388200e-04,6.200400e-04,5.071700e-04,3.409000e-04,1.079300e-04,& - & 7.935800e-05,9.732700e-05,8.420900e-05,6.125000e-05,3.245900e-05,& - & 1.242900e-04,1.504500e-04,1.283000e-04,9.146600e-05,4.224100e-05,& - & 1.905300e-04,2.273600e-04,1.910000e-04,1.332500e-04,5.378300e-05,& - & 2.861400e-04,3.357000e-04,2.782800e-04,1.905000e-04,6.721800e-05,& - & 4.203900e-04,4.863500e-04,3.977400e-04,2.672400e-04,8.258200e-05,& - & 5.645300e-05,6.962800e-05,6.041000e-05,4.415000e-05,2.363400e-05,& - & 9.003900e-05,1.097100e-04,9.380900e-05,6.708200e-05,3.117400e-05,& - & 1.405300e-04,1.688200e-04,1.420700e-04,9.946200e-05,4.017700e-05,& - & 2.147700e-04,2.537400e-04,2.106800e-04,1.445100e-04,5.074200e-05,& - & 3.208800e-04,3.735700e-04,3.061500e-04,2.058500e-04,6.290100e-05,& - & 3.979800e-05,4.934000e-05,4.293600e-05,3.153300e-05,1.700300e-05,& - & 6.465900e-05,7.927500e-05,6.797400e-05,4.884400e-05,2.275400e-05,& - & 1.027700e-04,1.243300e-04,1.049300e-04,7.371500e-05,2.970600e-05,& - & 1.599200e-04,1.903400e-04,1.583800e-04,1.088600e-04,3.793600e-05,& - & 2.432500e-04,2.851300e-04,2.340800e-04,1.575500e-04,4.749200e-05/ - data absb(901:1175,8) / & - & 2.780200e-05,3.461600e-05,3.021800e-05,2.230800e-05,1.206100e-05,& - & 4.601400e-05,5.676100e-05,4.882000e-05,3.523900e-05,1.638600e-05,& - & 7.449100e-05,9.074100e-05,7.679500e-05,5.414300e-05,2.168700e-05,& - & 1.180200e-04,1.415300e-04,1.180600e-04,8.135600e-05,2.802200e-05,& - & 1.827900e-04,2.158300e-04,1.775400e-04,1.197000e-04,3.545600e-05,& - & 1.954000e-05,2.440000e-05,2.136100e-05,1.583700e-05,8.699700e-06,& - & 3.291800e-05,4.082200e-05,3.520500e-05,2.551200e-05,1.199000e-05,& - & 5.425500e-05,6.652600e-05,5.643800e-05,3.995000e-05,1.607300e-05,& - & 8.752600e-05,1.057100e-04,8.838300e-05,6.106600e-05,2.100600e-05,& - & 1.379900e-04,1.641500e-04,1.352400e-04,9.133400e-05,2.684700e-05,& - & 1.371500e-05,1.717000e-05,1.506100e-05,1.122000e-05,6.306600e-06,& - & 2.352500e-05,2.929000e-05,2.532900e-05,1.843200e-05,8.817600e-06,& - & 3.946000e-05,4.867200e-05,4.137700e-05,2.939700e-05,1.197100e-05,& - & 6.479400e-05,7.883700e-05,6.604000e-05,4.575900e-05,1.583000e-05,& - & 1.040200e-04,1.247000e-04,1.029000e-04,6.964000e-05,2.043300e-05,& - & 9.557800e-06,1.198600e-05,1.052900e-05,7.883100e-06,4.527800e-06,& - & 1.667900e-05,2.085600e-05,1.807600e-05,1.321100e-05,6.424400e-06,& - & 2.847700e-05,3.532000e-05,3.010300e-05,2.146800e-05,8.839100e-06,& - & 4.759400e-05,5.835700e-05,4.898700e-05,3.402600e-05,1.183300e-05,& - & 7.779800e-05,9.398200e-05,7.769200e-05,5.272300e-05,1.543700e-05,& - & 6.607200e-06,8.293000e-06,7.296100e-06,5.489300e-06,3.214500e-06,& - & 1.172600e-05,1.471600e-05,1.278100e-05,9.382200e-06,4.628400e-06,& - & 2.038000e-05,2.540700e-05,2.171500e-05,1.554300e-05,6.458200e-06,& - & 3.465800e-05,4.278100e-05,3.598800e-05,2.511100e-05,8.758600e-06,& - & 5.769400e-05,7.024000e-05,5.820400e-05,3.960600e-05,1.155800e-05,& - & 4.623100e-06,5.809400e-06,5.115900e-06,3.868100e-06,2.361700e-06,& - & 8.348700e-06,1.050700e-05,9.140900e-06,6.732400e-06,3.445700e-06,& - & 1.474900e-05,1.847300e-05,1.581800e-05,1.136600e-05,4.867800e-06,& - & 2.552400e-05,3.169300e-05,2.671200e-05,1.869800e-05,6.675400e-06,& - & 4.324400e-05,5.305800e-05,4.405000e-05,3.004200e-05,8.895700e-06,& - & 3.243500e-06,4.080900e-06,3.596800e-06,2.733300e-06,1.766600e-06,& - & 5.964400e-06,7.517200e-06,6.550600e-06,4.840900e-06,2.611600e-06,& - & 1.070400e-05,1.346200e-05,1.154700e-05,8.323800e-06,3.732800e-06,& - & 1.884600e-05,2.352200e-05,1.985400e-05,1.394300e-05,5.172000e-06,& - & 3.247700e-05,4.011300e-05,3.337000e-05,2.281100e-05,6.956900e-06,& - & 2.257400e-06,2.846000e-06,2.512500e-06,1.922700e-06,1.317900e-06,& - & 4.236900e-06,5.347400e-06,4.664800e-06,3.458700e-06,1.975600e-06,& - & 7.725800e-06,9.749600e-06,8.376600e-06,6.054900e-06,2.857100e-06,& - & 1.382900e-05,1.734700e-05,1.466800e-05,1.033200e-05,4.001400e-06,& - & 2.424200e-05,3.014000e-05,2.511900e-05,1.721900e-05,5.434900e-06,& - & 1.556200e-06,1.966500e-06,1.741300e-06,1.345800e-06,9.809301e-07,& - & 2.989100e-06,3.779500e-06,3.299500e-06,2.457200e-06,1.491300e-06,& - & 5.541500e-06,7.011700e-06,6.035600e-06,4.374100e-06,2.182700e-06,& - & 1.008300e-05,1.270200e-05,1.076300e-05,7.604700e-06,3.091600e-06,& - & 1.798700e-05,2.249700e-05,1.878300e-05,1.291200e-05,4.241300e-06,& - & 1.075000e-06,1.360700e-06,1.209700e-06,9.478800e-07,7.383800e-07,& - & 2.115000e-06,2.681100e-06,2.342700e-06,1.752900e-06,1.136900e-06,& - & 3.992700e-06,5.063600e-06,4.365200e-06,3.173100e-06,1.685300e-06,& - & 7.382000e-06,9.332000e-06,7.921500e-06,5.610400e-06,2.412600e-06,& - & 1.339000e-05,1.684300e-05,1.408100e-05,9.705100e-06,3.341500e-06,& - & 8.414500e-07,1.067900e-06,9.497900e-07,7.470900e-07,6.349900e-07,& - & 1.682800e-06,2.140600e-06,1.868100e-06,1.396700e-06,9.849900e-07,& - & 3.223900e-06,4.095400e-06,3.526400e-06,2.558000e-06,1.469300e-06,& - & 6.039200e-06,7.656900e-06,6.491100e-06,4.582100e-06,2.112100e-06,& - & 1.109700e-05,1.400900e-05,1.169100e-05,8.042000e-06,2.931400e-06/ - data absb(1:300,9) / & - & 6.274900e-02,7.285500e-02,6.747800e-02,5.334500e-02,4.469900e-01,& - & 8.631900e-02,1.013500e-01,9.423000e-02,7.464000e-02,4.810200e-01,& - & 1.153100e-01,1.358300e-01,1.267100e-01,1.004200e-01,5.162100e-01,& - & 1.498100e-01,1.765000e-01,1.648000e-01,1.307800e-01,5.524300e-01,& - & 1.897000e-01,2.234700e-01,2.086500e-01,1.658700e-01,5.893700e-01,& - & 5.718700e-02,6.730100e-02,6.212900e-02,4.911000e-02,3.776900e-01,& - & 7.846600e-02,9.327000e-02,8.644500e-02,6.845900e-02,4.075300e-01,& - & 1.046700e-01,1.247600e-01,1.157400e-01,9.181900e-02,4.386800e-01,& - & 1.358100e-01,1.619200e-01,1.503400e-01,1.193000e-01,4.706400e-01,& - & 1.722400e-01,2.046400e-01,1.902100e-01,1.511000e-01,5.040800e-01,& - & 5.172100e-02,6.156600e-02,5.668000e-02,4.475100e-02,2.956800e-01,& - & 7.093600e-02,8.511500e-02,7.849200e-02,6.218200e-02,3.221300e-01,& - & 9.451500e-02,1.137000e-01,1.048600e-01,8.318200e-02,3.498600e-01,& - & 1.228900e-01,1.472800e-01,1.360700e-01,1.079000e-01,3.785300e-01,& - & 1.563700e-01,1.862700e-01,1.719500e-01,1.362600e-01,4.089400e-01,& - & 4.657800e-02,5.591100e-02,5.127400e-02,4.041600e-02,2.267300e-01,& - & 6.386600e-02,7.715800e-02,7.081000e-02,5.594400e-02,2.507100e-01,& - & 8.529400e-02,1.028500e-01,9.446300e-02,7.473100e-02,2.755900e-01,& - & 1.112600e-01,1.333100e-01,1.223700e-01,9.672500e-02,3.020700e-01,& - & 1.420700e-01,1.688900e-01,1.546700e-01,1.218200e-01,3.301500e-01,& - & 4.190000e-02,5.046400e-02,4.605300e-02,3.617900e-02,1.822600e-01,& - & 5.752200e-02,6.944400e-02,6.347200e-02,4.997300e-02,2.044700e-01,& - & 7.702600e-02,9.253800e-02,8.455100e-02,6.660500e-02,2.281000e-01,& - & 1.007900e-01,1.201700e-01,1.095500e-01,8.598500e-02,2.534200e-01,& - & 1.292700e-01,1.525800e-01,1.384600e-01,1.081600e-01,2.794600e-01,& - & 3.789100e-02,4.545400e-02,4.119700e-02,3.226000e-02,1.540300e-01,& - & 5.205700e-02,6.235800e-02,5.664400e-02,4.444900e-02,1.750200e-01,& - & 6.981500e-02,8.316000e-02,7.548800e-02,5.905100e-02,1.974800e-01,& - & 9.166800e-02,1.081900e-01,9.782400e-02,7.613000e-02,2.210500e-01,& - & 1.179900e-01,1.377000e-01,1.237100e-01,9.578000e-02,2.452500e-01,& - & 3.444100e-02,4.085400e-02,3.678500e-02,2.864800e-02,1.359200e-01,& - & 4.731000e-02,5.601400e-02,5.050500e-02,3.933300e-02,1.559900e-01,& - & 6.355900e-02,7.476300e-02,6.729100e-02,5.214900e-02,1.773800e-01,& - & 8.369900e-02,9.746600e-02,8.722500e-02,6.725000e-02,1.996000e-01,& - & 1.080900e-01,1.243600e-01,1.105100e-01,8.470400e-02,2.224000e-01,& - & 3.166200e-02,3.701100e-02,3.306400e-02,2.553500e-02,1.216600e-01,& - & 4.346200e-02,5.068300e-02,4.531200e-02,3.491800e-02,1.405000e-01,& - & 5.846800e-02,6.769300e-02,6.029100e-02,4.625100e-02,1.604100e-01,& - & 7.708200e-02,8.836800e-02,7.821800e-02,5.963200e-02,1.809200e-01,& - & 9.959000e-02,1.129600e-01,9.928200e-02,7.523600e-02,2.018000e-01,& - & 2.919700e-02,3.364400e-02,2.980000e-02,2.275100e-02,1.084000e-01,& - & 4.006100e-02,4.602200e-02,4.072000e-02,3.102500e-02,1.257500e-01,& - & 5.387900e-02,6.151300e-02,5.414500e-02,4.107100e-02,1.437700e-01,& - & 7.103500e-02,8.036800e-02,7.034400e-02,5.299300e-02,1.622800e-01,& - & 9.171700e-02,1.027500e-01,8.949500e-02,6.697800e-02,1.810900e-01,& - & 2.749900e-02,3.125100e-02,2.744900e-02,2.071700e-02,9.512300e-02,& - & 3.765700e-02,4.271500e-02,3.738100e-02,2.814500e-02,1.104300e-01,& - & 5.056200e-02,5.697700e-02,4.966400e-02,3.718400e-02,1.261500e-01,& - & 6.639700e-02,7.432100e-02,6.448600e-02,4.798600e-02,1.421000e-01,& - & 8.526600e-02,9.495800e-02,8.204500e-02,6.071200e-02,1.582700e-01,& - & 2.595100e-02,2.912500e-02,2.533000e-02,1.893400e-02,8.235300e-02,& - & 3.545500e-02,3.969400e-02,3.444100e-02,2.564100e-02,9.531700e-02,& - & 4.733100e-02,5.283800e-02,4.568800e-02,3.383600e-02,1.085700e-01,& - & 6.176300e-02,6.875800e-02,5.928400e-02,4.365200e-02,1.220900e-01,& - & 7.893300e-02,8.753700e-02,7.536400e-02,5.517300e-02,1.359000e-01,& - & 2.447300e-02,2.716900e-02,2.344400e-02,1.736300e-02,6.943000e-02,& - & 3.325000e-02,3.693600e-02,3.181000e-02,2.346200e-02,8.015700e-02,& - & 4.411700e-02,4.897500e-02,4.212300e-02,3.092100e-02,9.122300e-02,& - & 5.728500e-02,6.343900e-02,5.452400e-02,3.985400e-02,1.026600e-01,& - & 7.299800e-02,8.052400e-02,6.910900e-02,5.033200e-02,1.144100e-01/ - data absb(301:600,9) / & - & 2.308800e-02,2.543800e-02,2.180100e-02,1.600200e-02,5.783700e-02,& - & 3.117400e-02,3.439600e-02,2.949300e-02,2.156900e-02,6.678400e-02,& - & 4.114700e-02,4.536000e-02,3.889100e-02,2.837500e-02,7.610100e-02,& - & 5.324400e-02,5.852100e-02,5.011800e-02,3.647300e-02,8.575800e-02,& - & 6.765900e-02,7.412100e-02,6.331700e-02,4.595300e-02,9.569300e-02,& - & 2.185300e-02,2.392800e-02,2.042600e-02,1.485300e-02,4.839200e-02,& - & 2.936000e-02,3.213800e-02,2.744900e-02,1.995800e-02,5.591600e-02,& - & 3.859000e-02,4.217000e-02,3.599300e-02,2.613800e-02,6.379200e-02,& - & 4.977500e-02,5.424200e-02,4.620600e-02,3.346300e-02,7.197500e-02,& - & 6.307900e-02,6.854900e-02,5.824500e-02,4.204400e-02,8.044800e-02,& - & 2.058900e-02,2.243200e-02,1.909100e-02,1.379800e-02,3.971100e-02,& - & 2.757700e-02,2.999200e-02,2.549900e-02,1.844100e-02,4.594600e-02,& - & 3.616300e-02,3.922200e-02,3.329200e-02,2.402700e-02,5.251400e-02,& - & 4.652500e-02,5.033100e-02,4.263000e-02,3.066900e-02,5.935400e-02,& - & 5.882200e-02,6.350200e-02,5.365000e-02,3.850500e-02,6.646800e-02,& - & 1.932000e-02,2.097500e-02,1.779500e-02,1.279100e-02,3.191200e-02,& - & 2.585500e-02,2.795900e-02,2.367800e-02,1.700000e-02,3.701100e-02,& - & 3.386400e-02,3.650000e-02,3.083900e-02,2.208200e-02,4.238200e-02,& - & 4.347800e-02,4.676400e-02,3.941000e-02,2.814300e-02,4.800900e-02,& - & 5.487400e-02,5.890700e-02,4.953700e-02,3.532000e-02,5.394700e-02,& - & 1.812300e-02,1.962800e-02,1.659700e-02,1.186100e-02,2.542300e-02,& - & 2.422500e-02,2.612100e-02,2.203200e-02,1.569900e-02,2.954200e-02,& - & 3.170000e-02,3.403100e-02,2.863900e-02,2.034500e-02,3.391100e-02,& - & 4.066300e-02,4.352900e-02,3.654400e-02,2.591700e-02,3.854500e-02,& - & 5.126800e-02,5.476900e-02,4.589500e-02,3.252200e-02,4.348800e-02,& - & 1.695800e-02,1.836400e-02,1.547900e-02,1.099800e-02,1.995100e-02,& - & 2.267100e-02,2.440900e-02,2.051800e-02,1.452100e-02,2.324100e-02,& - & 2.964100e-02,3.177200e-02,2.662800e-02,1.879500e-02,2.676600e-02,& - & 3.801200e-02,4.058100e-02,3.394300e-02,2.393500e-02,3.056100e-02,& - & 4.790800e-02,5.103100e-02,4.262700e-02,3.003300e-02,3.465300e-02,& - & 1.587500e-02,1.718100e-02,1.445900e-02,1.021100e-02,1.540000e-02,& - & 2.120100e-02,2.282600e-02,1.913900e-02,1.346300e-02,1.800900e-02,& - & 2.770300e-02,2.969400e-02,2.481600e-02,1.742100e-02,2.083700e-02,& - & 3.553800e-02,3.792600e-02,3.162300e-02,2.217900e-02,2.391400e-02,& - & 4.482400e-02,4.769200e-02,3.973800e-02,2.784400e-02,2.727700e-02,& - & 1.488100e-02,1.611600e-02,1.353200e-02,9.512700e-03,1.192500e-02,& - & 1.986500e-02,2.139500e-02,1.790500e-02,1.252900e-02,1.400400e-02,& - & 2.595900e-02,2.782300e-02,2.320800e-02,1.620600e-02,1.628500e-02,& - & 3.331300e-02,3.556400e-02,2.960000e-02,2.063900e-02,1.880700e-02,& - & 4.206000e-02,4.478200e-02,3.722300e-02,2.592600e-02,2.157800e-02,& - & 1.396700e-02,1.514400e-02,1.269000e-02,8.884400e-03,9.207400e-03,& - & 1.864000e-02,2.009700e-02,1.678500e-02,1.170500e-02,1.087300e-02,& - & 2.438700e-02,2.615300e-02,2.177800e-02,1.513600e-02,1.272600e-02,& - & 3.132700e-02,3.347100e-02,2.781400e-02,1.929200e-02,1.478700e-02,& - & 3.957200e-02,4.222100e-02,3.504400e-02,2.426400e-02,1.708000e-02,& - & 1.303800e-02,1.415400e-02,1.183200e-02,8.249200e-03,7.364700e-03,& - & 1.742000e-02,1.879800e-02,1.565900e-02,1.087600e-02,8.741200e-03,& - & 2.282500e-02,2.450000e-02,2.036000e-02,1.408900e-02,1.028900e-02,& - & 2.936000e-02,3.141800e-02,2.606500e-02,1.797800e-02,1.202700e-02,& - & 3.713700e-02,3.971300e-02,3.291900e-02,2.266100e-02,1.397600e-02,& - & 1.185100e-02,1.289000e-02,1.076100e-02,7.471800e-03,5.755000e-03,& - & 1.590000e-02,1.718200e-02,1.428600e-02,9.883400e-03,6.879100e-03,& - & 2.089700e-02,2.248600e-02,1.864800e-02,1.284800e-02,8.152200e-03,& - & 2.696500e-02,2.894000e-02,2.397100e-02,1.645700e-02,9.592200e-03,& - & 3.423800e-02,3.672200e-02,3.038500e-02,2.081900e-02,1.121600e-02,& - & 1.045500e-02,1.139700e-02,9.503300e-03,6.575500e-03,4.357100e-03,& - & 1.411700e-02,1.529000e-02,1.269900e-02,8.748400e-03,5.250800e-03,& - & 1.865800e-02,2.013800e-02,1.667300e-02,1.143900e-02,6.273400e-03,& - & 2.420400e-02,2.607100e-02,2.155100e-02,1.473800e-02,7.433600e-03,& - & 3.089800e-02,3.326300e-02,2.747100e-02,1.874500e-02,8.750800e-03/ - data absb(601:900,9) / & - & 8.849800e-03,9.665700e-03,8.048200e-03,5.550700e-03,3.439400e-03,& - & 1.205300e-02,1.308800e-02,1.085000e-02,7.446300e-03,4.175600e-03,& - & 1.605300e-02,1.738000e-02,1.437300e-02,9.819700e-03,5.025500e-03,& - & 2.099200e-02,2.269700e-02,1.872300e-02,1.275400e-02,5.997700e-03,& - & 2.699900e-02,2.918200e-02,2.404800e-02,1.634100e-02,7.108100e-03,& - & 7.468000e-03,8.179300e-03,6.800100e-03,4.674100e-03,2.703600e-03,& - & 1.026800e-02,1.118400e-02,9.254600e-03,6.328800e-03,3.309400e-03,& - & 1.379900e-02,1.498700e-02,1.237000e-02,8.420400e-03,4.013600e-03,& - & 1.818900e-02,1.974100e-02,1.626000e-02,1.103100e-02,4.826700e-03,& - & 2.357900e-02,2.560500e-02,2.105200e-02,1.424400e-02,5.762600e-03,& - & 6.294200e-03,6.924900e-03,5.746000e-03,3.936000e-03,2.104400e-03,& - & 8.743200e-03,9.566300e-03,7.900000e-03,5.382300e-03,2.599400e-03,& - & 1.186400e-02,1.293700e-02,1.066000e-02,7.230400e-03,3.179200e-03,& - & 1.578100e-02,1.719700e-02,1.414500e-02,9.555400e-03,3.855600e-03,& - & 2.062400e-02,2.251200e-02,1.847000e-02,1.244300e-02,4.638100e-03,& - & 5.137500e-03,5.680300e-03,4.706900e-03,3.211500e-03,1.657800e-03,& - & 7.229100e-03,7.945900e-03,6.549500e-03,4.444100e-03,2.066600e-03,& - & 9.929600e-03,1.087100e-02,8.938400e-03,6.039200e-03,2.549800e-03,& - & 1.335400e-02,1.460300e-02,1.198900e-02,8.066400e-03,3.117200e-03,& - & 1.763000e-02,1.932000e-02,1.581900e-02,1.061000e-02,3.778300e-03,& - & 4.166900e-03,4.630700e-03,3.831100e-03,2.605500e-03,1.302200e-03,& - & 5.945000e-03,6.565400e-03,5.403100e-03,3.649700e-03,1.638700e-03,& - & 8.270200e-03,9.093900e-03,7.462700e-03,5.020400e-03,2.040600e-03,& - & 1.125400e-02,1.235800e-02,1.012400e-02,6.783600e-03,2.516000e-03,& - & 1.502100e-02,1.652600e-02,1.350500e-02,9.017000e-03,3.074500e-03,& - & 3.367300e-03,3.761800e-03,3.108400e-03,2.109300e-03,1.015900e-03,& - & 4.875800e-03,5.411600e-03,4.446900e-03,2.993000e-03,1.291000e-03,& - & 6.876500e-03,7.595700e-03,6.224000e-03,4.167500e-03,1.623100e-03,& - & 9.470300e-03,1.044900e-02,8.542600e-03,5.698800e-03,2.019500e-03,& - & 1.278900e-02,1.413300e-02,1.152700e-02,7.661000e-03,2.489100e-03,& - & 2.654500e-03,2.981700e-03,2.461100e-03,1.667200e-03,7.891400e-04,& - & 3.907200e-03,4.360100e-03,3.578500e-03,2.402600e-03,1.013000e-03,& - & 5.597000e-03,6.214600e-03,5.083300e-03,3.391400e-03,1.287100e-03,& - & 7.817000e-03,8.668000e-03,7.072800e-03,4.698400e-03,1.617500e-03,& - & 1.069500e-02,1.187600e-02,9.667000e-03,6.396400e-03,2.013600e-03,& - & 2.059900e-03,2.326400e-03,1.918900e-03,1.298200e-03,6.104300e-04,& - & 3.086500e-03,3.463200e-03,2.839800e-03,1.902900e-03,7.916000e-04,& - & 4.494500e-03,5.020000e-03,4.100900e-03,2.728200e-03,1.016600e-03,& - & 6.377100e-03,7.109200e-03,5.791800e-03,3.832400e-03,1.291600e-03,& - & 8.850700e-03,9.881600e-03,8.027100e-03,5.288500e-03,1.625400e-03,& - & 1.588300e-03,1.802900e-03,1.486200e-03,1.004100e-03,4.691500e-04,& - & 2.423700e-03,2.734800e-03,2.240200e-03,1.498300e-03,6.146300e-04,& - & 3.591500e-03,4.035300e-03,3.292000e-03,2.184700e-03,7.981300e-04,& - & 5.178700e-03,5.807400e-03,4.724200e-03,3.115800e-03,1.025500e-03,& - & 7.297700e-03,8.194900e-03,6.645500e-03,4.359700e-03,1.305200e-03,& - & 1.205000e-03,1.375200e-03,1.132700e-03,7.641500e-04,3.582500e-04,& - & 1.874500e-03,2.127100e-03,1.740600e-03,1.162300e-03,4.745500e-04,& - & 2.829200e-03,3.199000e-03,2.605800e-03,1.726100e-03,6.228000e-04,& - & 4.152300e-03,4.686700e-03,3.806800e-03,2.504300e-03,8.099700e-04,& - & 5.948400e-03,6.721100e-03,5.441200e-03,3.556600e-03,1.042500e-03,& - & 8.905900e-04,1.022100e-03,8.407600e-04,5.665200e-04,2.727000e-04,& - & 1.415400e-03,1.614200e-03,1.319100e-03,8.800300e-04,3.657800e-04,& - & 2.179000e-03,2.478500e-03,2.016200e-03,1.333100e-03,4.848700e-04,& - & 3.260300e-03,3.703500e-03,3.003300e-03,1.971100e-03,6.379000e-04,& - & 4.754300e-03,5.406500e-03,4.369800e-03,2.847800e-03,8.307900e-04,& - & 6.513700e-04,7.516000e-04,6.176800e-04,4.155900e-04,2.060500e-04,& - & 1.058400e-03,1.212800e-03,9.899600e-04,6.600900e-04,2.801400e-04,& - & 1.663100e-03,1.902600e-03,1.546100e-03,1.020500e-03,3.758100e-04,& - & 2.538400e-03,2.902500e-03,2.350400e-03,1.539400e-03,4.996700e-04,& - & 3.771600e-03,4.319100e-03,3.485300e-03,2.265900e-03,6.582600e-04/ - data absb(901:1175,9) / & - & 4.707400e-04,5.461400e-04,4.484200e-04,3.014900e-04,1.538700e-04,& - & 7.831200e-04,9.014700e-04,7.352200e-04,4.897100e-04,2.129300e-04,& - & 1.256600e-03,1.445700e-03,1.173800e-03,7.734100e-04,2.894900e-04,& - & 1.957700e-03,2.253200e-03,1.822800e-03,1.191700e-03,3.892900e-04,& - & 2.966500e-03,3.422900e-03,2.758600e-03,1.790200e-03,5.184600e-04,& - & 3.421300e-04,3.993500e-04,3.274600e-04,2.198800e-04,1.167400e-04,& - & 5.834300e-04,6.743700e-04,5.493600e-04,3.651100e-04,1.648000e-04,& - & 9.565000e-04,1.104600e-03,8.953900e-04,5.887300e-04,2.273300e-04,& - & 1.519600e-03,1.758200e-03,1.420700e-03,9.262200e-04,3.091600e-04,& - & 2.347200e-03,2.726100e-03,2.193300e-03,1.420300e-03,4.159200e-04,& - & 2.477500e-04,2.912100e-04,2.387000e-04,1.599600e-04,8.887700e-05,& - & 4.343300e-04,5.039500e-04,4.099600e-04,2.718300e-04,1.282700e-04,& - & 7.280900e-04,8.431400e-04,6.822200e-04,4.475700e-04,1.801700e-04,& - & 1.179700e-03,1.370800e-03,1.105700e-03,7.187100e-04,2.478500e-04,& - & 1.856900e-03,2.169300e-03,1.742000e-03,1.125000e-03,3.367900e-04,& - & 1.772200e-04,2.097700e-04,1.718800e-04,1.151700e-04,6.693400e-05,& - & 3.198800e-04,3.732900e-04,3.031400e-04,2.006100e-04,9.902100e-05,& - & 5.497700e-04,6.385300e-04,5.153900e-04,3.376200e-04,1.420800e-04,& - & 9.090800e-04,1.060200e-03,8.537000e-04,5.534200e-04,1.983400e-04,& - & 1.458400e-03,1.713000e-03,1.374000e-03,8.846900e-04,2.725700e-04,& - & 1.248600e-04,1.487600e-04,1.219200e-04,8.175600e-05,4.981000e-05,& - & 2.323600e-04,2.732600e-04,2.217500e-04,1.464700e-04,7.554900e-05,& - & 4.109200e-04,4.787800e-04,3.856600e-04,2.521900e-04,1.110800e-04,& - & 6.944900e-04,8.123300e-04,6.528800e-04,4.223500e-04,1.581800e-04,& - & 1.136200e-03,1.341500e-03,1.074600e-03,6.901600e-04,2.199300e-04,& - & 8.922500e-05,1.069800e-04,8.765100e-05,5.881300e-05,3.803000e-05,& - & 1.713700e-04,2.029300e-04,1.645600e-04,1.085000e-04,5.900100e-05,& - & 3.118900e-04,3.646000e-04,2.930300e-04,1.910100e-04,8.883300e-05,& - & 5.393200e-04,6.318000e-04,5.059700e-04,3.263100e-04,1.291300e-04,& - & 8.991100e-04,1.063700e-03,8.501700e-04,5.440300e-04,1.820400e-04,& - & 6.390900e-05,7.705800e-05,6.310300e-05,4.236500e-05,2.940800e-05,& - & 1.269400e-04,1.511800e-04,1.224700e-04,8.064000e-05,4.654600e-05,& - & 2.377900e-04,2.792200e-04,2.239200e-04,1.453300e-04,7.175500e-05,& - & 4.215200e-04,4.941700e-04,3.942000e-04,2.531700e-04,1.066400e-04,& - & 7.163300e-04,8.475400e-04,6.752200e-04,4.302500e-04,1.528700e-04,& - & 4.523800e-05,5.487300e-05,4.491900e-05,3.017900e-05,2.262000e-05,& - & 9.304600e-05,1.115200e-04,9.025100e-05,5.937500e-05,3.652300e-05,& - & 1.797300e-04,2.122400e-04,1.699300e-04,1.099800e-04,5.767800e-05,& - & 3.275300e-04,3.844900e-04,3.057100e-04,1.955000e-04,8.777600e-05,& - & 5.686000e-04,6.725200e-04,5.337300e-04,3.386400e-04,1.283300e-04,& - & 3.156500e-05,3.856100e-05,3.157200e-05,2.123600e-05,1.731900e-05,& - & 6.743700e-05,8.136800e-05,6.578500e-05,4.327800e-05,2.851300e-05,& - & 1.345300e-04,1.598300e-04,1.278800e-04,8.263400e-05,4.610500e-05,& - & 2.526500e-04,2.973100e-04,2.357300e-04,1.502000e-04,7.194600e-05,& - & 4.489400e-04,5.311900e-04,4.197900e-04,2.651700e-04,1.076600e-04,& - & 2.207500e-05,2.713400e-05,2.222600e-05,1.497100e-05,1.336400e-05,& - & 4.897800e-05,5.945400e-05,4.805100e-05,3.159300e-05,2.240600e-05,& - & 1.010100e-04,1.208300e-04,9.654300e-05,6.230100e-05,3.707800e-05,& - & 1.955900e-04,2.311000e-04,1.827400e-04,1.160100e-04,5.935700e-05,& - & 3.563900e-04,4.221000e-04,3.321500e-04,2.087900e-04,9.099900e-05,& - & 1.816200e-05,2.236200e-05,1.826000e-05,1.225300e-05,1.170800e-05,& - & 4.132300e-05,5.028500e-05,4.048300e-05,2.649400e-05,1.989700e-05,& - & 8.712300e-05,1.045500e-04,8.321300e-05,5.339000e-05,3.340000e-05,& - & 1.721400e-04,2.039100e-04,1.604700e-04,1.012300e-04,5.426300e-05,& - & 3.189700e-04,3.782500e-04,2.960600e-04,1.848000e-04,8.439300e-05/ - data absb(1:300,10) / & - & 2.734100e-01,2.752600e-01,2.518300e-01,1.926100e-01,1.421000e+00,& - & 3.864100e-01,3.893100e-01,3.550000e-01,2.736300e-01,1.525000e+00,& - & 5.210100e-01,5.275100e-01,4.784100e-01,3.701200e-01,1.624200e+00,& - & 6.780700e-01,6.863100e-01,6.244700e-01,4.816200e-01,1.723600e+00,& - & 8.573200e-01,8.650200e-01,7.863200e-01,6.078800e-01,1.835300e+00,& - & 2.610000e-01,2.721700e-01,2.485700e-01,1.909900e-01,1.309600e+00,& - & 3.666200e-01,3.832100e-01,3.483800e-01,2.681700e-01,1.404800e+00,& - & 4.930200e-01,5.142100e-01,4.696200e-01,3.602100e-01,1.498600e+00,& - & 6.406800e-01,6.650300e-01,6.080600e-01,4.665500e-01,1.600800e+00,& - & 8.059400e-01,8.387000e-01,7.628600e-01,5.873900e-01,1.699600e+00,& - & 2.453800e-01,2.645000e-01,2.406500e-01,1.854400e-01,1.099100e+00,& - & 3.429000e-01,3.688000e-01,3.371400e-01,2.576800e-01,1.180700e+00,& - & 4.600800e-01,4.921200e-01,4.511100e-01,3.435100e-01,1.265500e+00,& - & 5.951000e-01,6.359100e-01,5.804200e-01,4.434700e-01,1.353800e+00,& - & 7.443100e-01,7.981800e-01,7.281000e-01,5.587000e-01,1.441500e+00,& - & 2.281400e-01,2.511200e-01,2.289400e-01,1.760400e-01,8.691800e-01,& - & 3.174000e-01,3.481500e-01,3.181300e-01,2.432100e-01,9.379400e-01,& - & 4.240600e-01,4.641000e-01,4.226000e-01,3.221100e-01,1.012200e+00,& - & 5.452000e-01,5.987000e-01,5.432800e-01,4.142400e-01,1.084900e+00,& - & 6.805300e-01,7.460800e-01,6.807400e-01,5.220500e-01,1.161600e+00,& - & 2.094200e-01,2.342800e-01,2.130000e-01,1.635700e-01,6.885600e-01,& - & 2.902800e-01,3.240200e-01,2.933400e-01,2.245900e-01,7.531600e-01,& - & 3.852100e-01,4.315400e-01,3.884800e-01,2.966000e-01,8.171200e-01,& - & 4.938600e-01,5.528000e-01,4.990800e-01,3.819700e-01,8.833100e-01,& - & 6.148800e-01,6.882100e-01,6.245200e-01,4.787900e-01,9.585700e-01,& - & 1.906300e-01,2.156100e-01,1.950300e-01,1.489700e-01,5.826200e-01,& - & 2.623400e-01,2.981500e-01,2.672700e-01,2.034000e-01,6.443700e-01,& - & 3.466600e-01,3.944800e-01,3.527800e-01,2.694500e-01,7.077300e-01,& - & 4.431000e-01,5.037000e-01,4.519700e-01,3.462400e-01,7.761000e-01,& - & 5.497900e-01,6.264000e-01,5.660700e-01,4.326900e-01,8.449800e-01,& - & 1.716100e-01,1.965900e-01,1.759200e-01,1.340000e-01,5.231500e-01,& - & 2.348900e-01,2.700300e-01,2.406800e-01,1.832000e-01,5.848800e-01,& - & 3.094200e-01,3.557600e-01,3.171200e-01,2.421000e-01,6.478900e-01,& - & 3.938900e-01,4.537400e-01,4.062900e-01,3.099900e-01,7.135100e-01,& - & 4.889100e-01,5.640200e-01,5.067900e-01,3.861300e-01,7.767000e-01,& - & 1.543600e-01,1.784900e-01,1.583500e-01,1.205400e-01,4.812200e-01,& - & 2.103700e-01,2.432900e-01,2.159400e-01,1.647500e-01,5.408300e-01,& - & 2.758800e-01,3.192300e-01,2.847500e-01,2.168300e-01,6.022900e-01,& - & 3.517900e-01,4.067300e-01,3.635600e-01,2.764700e-01,6.638900e-01,& - & 4.394400e-01,5.059100e-01,4.516100e-01,3.430900e-01,7.258800e-01,& - & 1.393100e-01,1.606100e-01,1.421000e-01,1.080000e-01,4.408200e-01,& - & 1.890300e-01,2.179200e-01,1.936100e-01,1.469100e-01,4.968500e-01,& - & 2.483600e-01,2.849400e-01,2.542300e-01,1.923200e-01,5.560400e-01,& - & 3.185500e-01,3.631300e-01,3.232500e-01,2.446300e-01,6.154300e-01,& - & 4.003400e-01,4.534600e-01,4.007100e-01,3.034600e-01,6.756200e-01,& - & 1.285300e-01,1.473000e-01,1.301200e-01,9.841900e-02,3.950600e-01,& - & 1.743200e-01,1.985700e-01,1.762100e-01,1.327400e-01,4.491000e-01,& - & 2.301200e-01,2.598400e-01,2.296000e-01,1.729500e-01,5.050500e-01,& - & 2.971600e-01,3.316300e-01,2.912600e-01,2.189100e-01,5.630400e-01,& - & 3.773300e-01,4.149700e-01,3.613700e-01,2.709300e-01,6.224100e-01,& - & 1.188100e-01,1.354500e-01,1.194400e-01,8.924400e-02,3.522300e-01,& - & 1.617300e-01,1.825000e-01,1.601900e-01,1.196000e-01,4.038000e-01,& - & 2.153100e-01,2.391800e-01,2.082800e-01,1.550800e-01,4.568500e-01,& - & 2.811100e-01,3.063400e-01,2.643300e-01,1.961600e-01,5.105000e-01,& - & 3.586200e-01,3.853800e-01,3.291300e-01,2.433600e-01,5.651200e-01,& - & 1.105100e-01,1.249600e-01,1.095700e-01,8.103200e-02,3.106200e-01,& - & 1.517200e-01,1.688000e-01,1.466000e-01,1.080200e-01,3.560100e-01,& - & 2.037600e-01,2.221200e-01,1.909300e-01,1.396900e-01,4.015100e-01,& - & 2.659500e-01,2.867000e-01,2.429000e-01,1.769300e-01,4.465500e-01,& - & 3.371100e-01,3.615400e-01,3.042100e-01,2.201600e-01,4.930700e-01/ - data absb(301:600,10) / & - & 1.042000e-01,1.161200e-01,1.007100e-01,7.399400e-02,2.676900e-01,& - & 1.437900e-01,1.574000e-01,1.350100e-01,9.835300e-02,3.048600e-01,& - & 1.921700e-01,2.086800e-01,1.765000e-01,1.273500e-01,3.423600e-01,& - & 2.487000e-01,2.691900e-01,2.263400e-01,1.617100e-01,3.814800e-01,& - & 3.137700e-01,3.380300e-01,2.844200e-01,2.014600e-01,4.227200e-01,& - & 9.967500e-02,1.091300e-01,9.338900e-02,6.820400e-02,2.270200e-01,& - & 1.360800e-01,1.486600e-01,1.258700e-01,9.054800e-02,2.583100e-01,& - & 1.798700e-01,1.962900e-01,1.653100e-01,1.176100e-01,2.907700e-01,& - & 2.314100e-01,2.513300e-01,2.118400e-01,1.500200e-01,3.252100e-01,& - & 2.916800e-01,3.149800e-01,2.656800e-01,1.875400e-01,3.616400e-01,& - & 9.496100e-02,1.033400e-01,8.737400e-02,6.312600e-02,1.868300e-01,& - & 1.278300e-01,1.396900e-01,1.179000e-01,8.411200e-02,2.133200e-01,& - & 1.676200e-01,1.827800e-01,1.544200e-01,1.098400e-01,2.414200e-01,& - & 2.151800e-01,2.332900e-01,1.971900e-01,1.399600e-01,2.715900e-01,& - & 2.708800e-01,2.922800e-01,2.466600e-01,1.744200e-01,3.035200e-01,& - & 8.989400e-02,9.746800e-02,8.217700e-02,5.888900e-02,1.506000e-01,& - & 1.198800e-01,1.303500e-01,1.100000e-01,7.873800e-02,1.728700e-01,& - & 1.564900e-01,1.695700e-01,1.432900e-01,1.025600e-01,1.970700e-01,& - & 2.004600e-01,2.164000e-01,1.826600e-01,1.302100e-01,2.230500e-01,& - & 2.520900e-01,2.714700e-01,2.285600e-01,1.618200e-01,2.504800e-01,& - & 8.497500e-02,9.156400e-02,7.711900e-02,5.532000e-02,1.203100e-01,& - & 1.127900e-01,1.215400e-01,1.024800e-01,7.369900e-02,1.392100e-01,& - & 1.467300e-01,1.579200e-01,1.330900e-01,9.544900e-02,1.598400e-01,& - & 1.874100e-01,2.015800e-01,1.695100e-01,1.208200e-01,1.820300e-01,& - & 2.350600e-01,2.533700e-01,2.122400e-01,1.505300e-01,2.054900e-01,& - & 8.054000e-02,8.597900e-02,7.224800e-02,5.183800e-02,9.525700e-02,& - & 1.065900e-01,1.136300e-01,9.554200e-02,6.863000e-02,1.111600e-01,& - & 1.381100e-01,1.476900e-01,1.239800e-01,8.865100e-02,1.285100e-01,& - & 1.757600e-01,1.888500e-01,1.579500e-01,1.123000e-01,1.470400e-01,& - & 2.196800e-01,2.375000e-01,1.977800e-01,1.403400e-01,1.674600e-01,& - & 7.656800e-02,8.101300e-02,6.787700e-02,4.853100e-02,7.456600e-02,& - & 1.010900e-01,1.069900e-01,8.962800e-02,6.397300e-02,8.764200e-02,& - & 1.306200e-01,1.389600e-01,1.161800e-01,8.266500e-02,1.020900e-01,& - & 1.655000e-01,1.777400e-01,1.481400e-01,1.050300e-01,1.180200e-01,& - & 2.067500e-01,2.232700e-01,1.855500e-01,1.315100e-01,1.354400e-01,& - & 7.288800e-02,7.683800e-02,6.412600e-02,4.549500e-02,5.881700e-02,& - & 9.626700e-02,1.014000e-01,8.457900e-02,5.994500e-02,6.977300e-02,& - & 1.239800e-01,1.317000e-01,1.096000e-01,7.755500e-02,8.199700e-02,& - & 1.568200e-01,1.681000e-01,1.396000e-01,9.881200e-02,9.552800e-02,& - & 1.959400e-01,2.110700e-01,1.750500e-01,1.241600e-01,1.109000e-01,& - & 6.963500e-02,7.331700e-02,6.101000e-02,4.286500e-02,4.666000e-02,& - & 9.170100e-02,9.675900e-02,8.032600e-02,5.650100e-02,5.583300e-02,& - & 1.180100e-01,1.254000e-01,1.040600e-01,7.331600e-02,6.613800e-02,& - & 1.495300e-01,1.598500e-01,1.323800e-01,9.360100e-02,7.780800e-02,& - & 1.872700e-01,2.010800e-01,1.662100e-01,1.178900e-01,9.102900e-02,& - & 6.605100e-02,6.960600e-02,5.779300e-02,4.030000e-02,3.839000e-02,& - & 8.685000e-02,9.201000e-02,7.610400e-02,5.312900e-02,4.630000e-02,& - & 1.119000e-01,1.190200e-01,9.837600e-02,6.905900e-02,5.524300e-02,& - & 1.422700e-01,1.519300e-01,1.253400e-01,8.842400e-02,6.550300e-02,& - & 1.789300e-01,1.916400e-01,1.578000e-01,1.115900e-01,7.710800e-02,& - & 6.106100e-02,6.458900e-02,5.347200e-02,3.707600e-02,3.093600e-02,& - & 8.041300e-02,8.551800e-02,7.063100e-02,4.903300e-02,3.763000e-02,& - & 1.041800e-01,1.109800e-01,9.137600e-02,6.389200e-02,4.534800e-02,& - & 1.332600e-01,1.421800e-01,1.168400e-01,8.200400e-02,5.417700e-02,& - & 1.681800e-01,1.801400e-01,1.479100e-01,1.038300e-01,6.435200e-02,& - & 5.485900e-02,5.826900e-02,4.818200e-02,3.325300e-02,2.420400e-02,& - & 7.262600e-02,7.749100e-02,6.394900e-02,4.418600e-02,2.974700e-02,& - & 9.486700e-02,1.012100e-01,8.312600e-02,5.776100e-02,3.618300e-02,& - & 1.221500e-01,1.304500e-01,1.069300e-01,7.444500e-02,4.369300e-02,& - & 1.551400e-01,1.664600e-01,1.361300e-01,9.476000e-02,5.244400e-02/ - data absb(601:900,10) / & - & 4.723000e-02,5.037600e-02,4.160600e-02,2.865000e-02,1.957600e-02,& - & 6.316200e-02,6.755900e-02,5.573700e-02,3.836600e-02,2.430700e-02,& - & 8.338200e-02,8.910000e-02,7.309600e-02,5.040400e-02,2.984500e-02,& - & 1.083100e-01,1.157800e-01,9.474700e-02,6.539900e-02,3.633400e-02,& - & 1.387200e-01,1.491200e-01,1.215300e-01,8.389000e-02,4.397000e-02,& - & 4.059400e-02,4.348200e-02,3.588200e-02,2.465200e-02,1.579600e-02,& - & 5.489300e-02,5.885900e-02,4.853500e-02,3.334200e-02,1.983800e-02,& - & 7.327000e-02,7.844200e-02,6.429900e-02,4.405700e-02,2.458700e-02,& - & 9.613100e-02,1.029700e-01,8.406200e-02,5.754200e-02,3.019400e-02,& - & 1.242500e-01,1.337100e-01,1.087100e-01,7.437600e-02,3.682600e-02,& - & 3.496000e-02,3.758400e-02,3.100100e-02,2.125300e-02,1.265900e-02,& - & 4.779600e-02,5.141200e-02,4.233300e-02,2.900600e-02,1.607300e-02,& - & 6.451000e-02,6.924400e-02,5.669000e-02,3.867100e-02,2.013000e-02,& - & 8.556100e-02,9.190400e-02,7.480000e-02,5.087300e-02,2.494100e-02,& - & 1.116300e-01,1.202200e-01,9.762800e-02,6.623500e-02,3.066800e-02,& - & 2.926800e-02,3.148200e-02,2.593500e-02,1.772100e-02,1.021700e-02,& - & 4.045900e-02,4.358600e-02,3.585200e-02,2.448600e-02,1.311000e-02,& - & 5.522900e-02,5.944900e-02,4.858800e-02,3.303800e-02,1.658600e-02,& - & 7.411700e-02,7.987200e-02,6.488500e-02,4.390700e-02,2.072500e-02,& - & 9.786500e-02,1.055000e-01,8.556800e-02,5.764300e-02,2.566200e-02,& - & 2.439700e-02,2.623100e-02,2.158600e-02,1.468200e-02,8.235300e-03,& - & 3.413900e-02,3.678600e-02,3.023000e-02,2.056800e-02,1.067400e-02,& - & 4.710600e-02,5.085800e-02,4.145900e-02,2.811500e-02,1.363500e-02,& - & 6.400000e-02,6.918000e-02,5.606200e-02,3.779900e-02,1.720400e-02,& - & 8.551700e-02,9.240000e-02,7.478200e-02,5.009900e-02,2.145000e-02,& - & 2.026800e-02,2.184500e-02,1.795600e-02,1.214000e-02,6.599100e-03,& - & 2.878900e-02,3.102100e-02,2.546700e-02,1.724600e-02,8.647700e-03,& - & 4.019400e-02,4.347400e-02,3.536300e-02,2.390200e-02,1.115400e-02,& - & 5.525800e-02,5.991900e-02,4.842900e-02,3.253600e-02,1.421000e-02,& - & 7.469600e-02,8.096200e-02,6.539300e-02,4.361800e-02,1.784900e-02,& - & 1.642600e-02,1.780400e-02,1.461300e-02,9.805000e-03,5.261700e-03,& - & 2.374700e-02,2.563000e-02,2.101100e-02,1.416000e-02,6.984700e-03,& - & 3.365300e-02,3.641200e-02,2.959200e-02,1.992500e-02,9.104000e-03,& - & 4.686800e-02,5.093800e-02,4.110800e-02,2.752600e-02,1.171000e-02,& - & 6.412900e-02,6.976000e-02,5.623800e-02,3.738300e-02,1.482300e-02,& - & 1.310000e-02,1.431600e-02,1.174200e-02,7.818500e-03,4.173100e-03,& - & 1.930600e-02,2.094600e-02,1.713000e-02,1.148800e-02,5.625300e-03,& - & 2.783900e-02,3.015900e-02,2.449700e-02,1.642000e-02,7.417700e-03,& - & 3.935100e-02,4.284500e-02,3.454200e-02,2.303600e-02,9.632300e-03,& - & 5.454500e-02,5.956500e-02,4.791600e-02,3.176600e-02,1.229700e-02,& - & 1.036500e-02,1.143200e-02,9.376700e-03,6.211700e-03,3.283900e-03,& - & 1.558900e-02,1.706300e-02,1.393000e-02,9.285900e-03,4.500500e-03,& - & 2.291000e-02,2.492400e-02,2.022700e-02,1.349400e-02,6.016500e-03,& - & 3.293800e-02,3.593300e-02,2.894400e-02,1.921500e-02,7.890100e-03,& - & 4.628800e-02,5.073900e-02,4.075500e-02,2.693000e-02,1.016300e-02,& - & 8.061100e-03,8.968700e-03,7.361600e-03,4.864900e-03,2.563000e-03,& - & 1.238400e-02,1.370000e-02,1.118700e-02,7.414100e-03,3.573600e-03,& - & 1.858900e-02,2.037600e-02,1.651400e-02,1.094900e-02,4.854600e-03,& - & 2.722800e-02,2.979800e-02,2.398600e-02,1.586700e-02,6.439500e-03,& - & 3.890700e-02,4.277200e-02,3.432800e-02,2.259800e-02,8.379300e-03,& - & 6.094200e-03,6.837300e-03,5.615100e-03,3.710800e-03,1.987400e-03,& - & 9.583000e-03,1.072000e-02,8.768700e-03,5.783000e-03,2.814900e-03,& - & 1.471900e-02,1.628600e-02,1.320600e-02,8.708200e-03,3.898900e-03,& - & 2.203400e-02,2.424800e-02,1.949600e-02,1.283900e-02,5.246400e-03,& - & 3.206800e-02,3.538500e-02,2.836600e-02,1.861100e-02,6.908700e-03,& - & 4.551000e-03,5.151500e-03,4.228600e-03,2.793800e-03,1.532400e-03,& - & 7.329300e-03,8.302200e-03,6.795800e-03,4.470800e-03,2.201800e-03,& - & 1.153200e-02,1.290900e-02,1.048500e-02,6.889600e-03,3.103200e-03,& - & 1.766900e-02,1.961900e-02,1.576800e-02,1.033400e-02,4.252600e-03,& - & 2.626300e-02,2.913400e-02,2.332500e-02,1.524400e-02,5.676800e-03/ - data absb(901:1175,10) / & - & 3.356000e-03,3.832700e-03,3.139100e-03,2.074300e-03,1.180200e-03,& - & 5.534200e-03,6.354200e-03,5.198100e-03,3.421100e-03,1.709600e-03,& - & 8.929400e-03,1.014300e-02,8.246800e-03,5.419600e-03,2.447000e-03,& - & 1.402400e-02,1.576500e-02,1.268400e-02,8.273400e-03,3.412900e-03,& - & 2.135200e-02,2.386600e-02,1.907500e-02,1.241100e-02,4.627900e-03,& - & 2.492900e-03,2.863200e-03,2.337900e-03,1.544000e-03,9.322500e-04,& - & 4.202900e-03,4.875200e-03,3.980500e-03,2.619800e-03,1.357600e-03,& - & 6.932500e-03,7.992500e-03,6.497400e-03,4.267400e-03,1.961300e-03,& - & 1.115800e-02,1.270900e-02,1.022900e-02,6.664400e-03,2.783200e-03,& - & 1.740300e-02,1.964200e-02,1.569100e-02,1.015500e-02,3.833300e-03,& - & 1.853200e-03,2.136400e-03,1.737600e-03,1.145400e-03,7.487800e-04,& - & 3.188800e-03,3.729100e-03,3.035700e-03,1.994500e-03,1.092200e-03,& - & 5.363800e-03,6.278000e-03,5.096800e-03,3.341900e-03,1.585800e-03,& - & 8.850100e-03,1.021900e-02,8.227700e-03,5.363900e-03,2.283200e-03,& - & 1.414900e-02,1.614600e-02,1.291200e-02,8.317100e-03,3.200000e-03,& - & 1.362800e-03,1.578300e-03,1.280800e-03,8.405500e-04,6.001200e-04,& - & 2.401700e-03,2.823600e-03,2.290500e-03,1.501100e-03,8.812600e-04,& - & 4.116900e-03,4.881500e-03,3.960700e-03,2.590600e-03,1.284700e-03,& - & 6.953600e-03,8.155900e-03,6.566400e-03,4.281500e-03,1.863800e-03,& - & 1.140900e-02,1.319400e-02,1.055300e-02,6.787500e-03,2.653400e-03,& - & 9.860600e-04,1.154000e-03,9.338400e-04,6.104000e-04,4.770900e-04,& - & 1.792000e-03,2.114500e-03,1.706300e-03,1.116900e-03,7.131200e-04,& - & 3.129400e-03,3.754600e-03,3.042100e-03,1.986100e-03,1.041900e-03,& - & 5.405900e-03,6.452200e-03,5.192100e-03,3.381600e-03,1.513000e-03,& - & 9.111800e-03,1.069600e-02,8.553400e-03,5.506600e-03,2.184300e-03,& - & 7.251300e-04,8.573200e-04,6.918300e-04,4.503900e-04,3.876900e-04,& - & 1.363900e-03,1.606700e-03,1.290200e-03,8.397200e-04,5.934100e-04,& - & 2.421400e-03,2.917600e-03,2.354500e-03,1.532800e-03,8.721400e-04,& - & 4.249000e-03,5.141400e-03,4.136200e-03,2.685100e-03,1.271000e-03,& - & 7.327700e-03,8.735200e-03,6.986600e-03,4.497400e-03,1.846300e-03,& - & 5.353600e-04,6.381900e-04,5.142900e-04,3.338400e-04,3.178700e-04,& - & 1.043400e-03,1.228600e-03,9.819700e-04,6.346400e-04,5.005100e-04,& - & 1.889600e-03,2.275900e-03,1.825500e-03,1.182000e-03,7.468900e-04,& - & 3.354300e-03,4.100000e-03,3.292200e-03,2.128900e-03,1.091000e-03,& - & 5.895700e-03,7.136000e-03,5.707200e-03,3.672100e-03,1.588300e-03,& - & 3.904100e-04,4.698300e-04,3.782700e-04,2.449500e-04,2.582200e-04,& - & 7.904100e-04,9.355400e-04,7.444400e-04,4.774300e-04,4.209800e-04,& - & 1.471100e-03,1.770600e-03,1.408500e-03,9.046200e-04,6.413500e-04,& - & 2.641000e-03,3.248700e-03,2.599400e-03,1.675300e-03,9.418900e-04,& - & 4.718000e-03,5.794200e-03,4.633900e-03,2.975300e-03,1.374400e-03,& - & 2.811200e-04,3.413400e-04,2.746000e-04,1.773900e-04,2.081000e-04,& - & 5.923300e-04,7.061200e-04,5.603600e-04,3.572400e-04,3.521800e-04,& - & 1.140400e-03,1.369800e-03,1.081800e-03,6.886700e-04,5.509500e-04,& - & 2.075600e-03,2.559800e-03,2.038900e-03,1.307100e-03,8.194700e-04,& - & 3.756500e-03,4.671500e-03,3.737200e-03,2.389700e-03,1.197000e-03,& - & 2.028700e-04,2.484100e-04,1.995000e-04,1.287000e-04,1.687300e-04,& - & 4.447200e-04,5.347000e-04,4.229200e-04,2.689900e-04,2.955600e-04,& - & 8.890900e-04,1.066800e-03,8.366900e-04,5.291700e-04,4.769800e-04,& - & 1.647200e-03,2.031900e-03,1.607900e-03,1.023500e-03,7.222200e-04,& - & 3.014200e-03,3.780800e-03,3.020000e-03,1.923000e-03,1.057800e-03,& - & 1.726400e-04,2.125200e-04,1.697900e-04,1.087700e-04,1.553500e-04,& - & 3.884400e-04,4.689200e-04,3.689200e-04,2.328500e-04,2.777000e-04,& - & 7.931300e-04,9.535800e-04,7.424200e-04,4.649000e-04,4.561100e-04,& - & 1.488800e-03,1.836200e-03,1.443700e-03,9.090700e-04,6.987800e-04,& - & 2.741200e-03,3.444400e-03,2.740300e-03,1.729300e-03,1.028000e-03/ - data absb(1:300,11) / & - & 4.658200e-01,4.312600e-01,3.914800e-01,2.978200e-01,2.003800e+00,& - & 6.601500e-01,6.136200e-01,5.556400e-01,4.199700e-01,2.150600e+00,& - & 8.918600e-01,8.325500e-01,7.503200e-01,5.697500e-01,2.297000e+00,& - & 1.158600e+00,1.086900e+00,9.735900e-01,7.419600e-01,2.427100e+00,& - & 1.456300e+00,1.376100e+00,1.228700e+00,9.362400e-01,2.553700e+00,& - & 4.662200e-01,4.469400e-01,4.062100e-01,3.051700e-01,1.923900e+00,& - & 6.562600e-01,6.309700e-01,5.702900e-01,4.301700e-01,2.065900e+00,& - & 8.815300e-01,8.502900e-01,7.639100e-01,5.801500e-01,2.196800e+00,& - & 1.139600e+00,1.104300e+00,9.883600e-01,7.500600e-01,2.318000e+00,& - & 1.429000e+00,1.387000e+00,1.240700e+00,9.405100e-01,2.454800e+00,& - & 4.581400e-01,4.539800e-01,4.105400e-01,3.083900e-01,1.683500e+00,& - & 6.400500e-01,6.356300e-01,5.720200e-01,4.326500e-01,1.804400e+00,& - & 8.548100e-01,8.518800e-01,7.632500e-01,5.777600e-01,1.921600e+00,& - & 1.101100e+00,1.098400e+00,9.847000e-01,7.424200e-01,2.048000e+00,& - & 1.378900e+00,1.370700e+00,1.226300e+00,9.269200e-01,2.166200e+00,& - & 4.393600e-01,4.505500e-01,4.061000e-01,3.060700e-01,1.389100e+00,& - & 6.098000e-01,6.258000e-01,5.620500e-01,4.241100e-01,1.493700e+00,& - & 8.105100e-01,8.304100e-01,7.476200e-01,5.621900e-01,1.602400e+00,& - & 1.042300e+00,1.062900e+00,9.563600e-01,7.192600e-01,1.707400e+00,& - & 1.301200e+00,1.327000e+00,1.186700e+00,8.966200e-01,1.806500e+00,& - & 4.122600e-01,4.360600e-01,3.920300e-01,2.961400e-01,1.147600e+00,& - & 5.688900e-01,6.007800e-01,5.410000e-01,4.060700e-01,1.237800e+00,& - & 7.547500e-01,7.922300e-01,7.142100e-01,5.342900e-01,1.329400e+00,& - & 9.674700e-01,1.012400e+00,9.080700e-01,6.819400e-01,1.412400e+00,& - & 1.199400e+00,1.259300e+00,1.126100e+00,8.518500e-01,1.495500e+00,& - & 3.806400e-01,4.127900e-01,3.708900e-01,2.798100e-01,9.715000e-01,& - & 5.235800e-01,5.646200e-01,5.082900e-01,3.810500e-01,1.054900e+00,& - & 6.926300e-01,7.431200e-01,6.662100e-01,4.987100e-01,1.133900e+00,& - & 8.822900e-01,9.487200e-01,8.460700e-01,6.357600e-01,1.210900e+00,& - & 1.091800e+00,1.171500e+00,1.048500e+00,7.932100e-01,1.296600e+00,& - & 3.470700e-01,3.825400e-01,3.436200e-01,2.585800e-01,8.652400e-01,& - & 4.762400e-01,5.217700e-01,4.666000e-01,3.504100e-01,9.456700e-01,& - & 6.267100e-01,6.865100e-01,6.096500e-01,4.583100e-01,1.024400e+00,& - & 7.965300e-01,8.709800e-01,7.744200e-01,5.840100e-01,1.107300e+00,& - & 9.842700e-01,1.072600e+00,9.599700e-01,7.254000e-01,1.196600e+00,& - & 3.156700e-01,3.518100e-01,3.144400e-01,2.362200e-01,8.015800e-01,& - & 4.313100e-01,4.792300e-01,4.243600e-01,3.188000e-01,8.808100e-01,& - & 5.651200e-01,6.270000e-01,5.531200e-01,4.174100e-01,9.611300e-01,& - & 7.166100e-01,7.915900e-01,7.017800e-01,5.303200e-01,1.048900e+00,& - & 8.823600e-01,9.746800e-01,8.695200e-01,6.574300e-01,1.137200e+00,& - & 2.859200e-01,3.207400e-01,2.839400e-01,2.133300e-01,7.429000e-01,& - & 3.882600e-01,4.350200e-01,3.822300e-01,2.879700e-01,8.217800e-01,& - & 5.074100e-01,5.657200e-01,4.979200e-01,3.759000e-01,9.051900e-01,& - & 6.405800e-01,7.134000e-01,6.308000e-01,4.766300e-01,9.922500e-01,& - & 7.881100e-01,8.794400e-01,7.795300e-01,5.891700e-01,1.081200e+00,& - & 2.634900e-01,2.966000e-01,2.596400e-01,1.955700e-01,6.757000e-01,& - & 3.552700e-01,3.983500e-01,3.485000e-01,2.630500e-01,7.522400e-01,& - & 4.605000e-01,5.153800e-01,4.531500e-01,3.416100e-01,8.362000e-01,& - & 5.803400e-01,6.497100e-01,5.712400e-01,4.314800e-01,9.219100e-01,& - & 7.159800e-01,7.999200e-01,7.038700e-01,5.309800e-01,1.010800e+00,& - & 2.429400e-01,2.730600e-01,2.373200e-01,1.787200e-01,6.070500e-01,& - & 3.249700e-01,3.637200e-01,3.178800e-01,2.386900e-01,6.842100e-01,& - & 4.206700e-01,4.694100e-01,4.107200e-01,3.087400e-01,7.660000e-01,& - & 5.316400e-01,5.909700e-01,5.161400e-01,3.879200e-01,8.530000e-01,& - & 6.586100e-01,7.284400e-01,6.339200e-01,4.775700e-01,9.424100e-01,& - & 2.248200e-01,2.510800e-01,2.180200e-01,1.628600e-01,5.385400e-01,& - & 2.999700e-01,3.329100e-01,2.898500e-01,2.164000e-01,6.167800e-01,& - & 3.894900e-01,4.294500e-01,3.725900e-01,2.784100e-01,6.994700e-01,& - & 4.947500e-01,5.404000e-01,4.678100e-01,3.487400e-01,7.867800e-01,& - & 6.168800e-01,6.684500e-01,5.752600e-01,4.294600e-01,8.763800e-01/ - data absb(301:600,11) / & - & 2.086700e-01,2.317500e-01,2.008500e-01,1.484900e-01,4.833600e-01,& - & 2.794400e-01,3.072900e-01,2.648700e-01,1.960900e-01,5.582300e-01,& - & 3.650600e-01,3.963200e-01,3.402000e-01,2.511500e-01,6.366100e-01,& - & 4.672700e-01,5.007000e-01,4.273100e-01,3.151200e-01,7.158200e-01,& - & 5.863600e-01,6.220900e-01,5.279600e-01,3.892500e-01,7.983400e-01,& - & 1.958700e-01,2.159400e-01,1.857600e-01,1.360200e-01,4.342600e-01,& - & 2.638200e-01,2.867600e-01,2.445900e-01,1.787300e-01,5.008500e-01,& - & 3.469200e-01,3.712000e-01,3.146500e-01,2.287400e-01,5.693400e-01,& - & 4.452000e-01,4.718100e-01,3.963700e-01,2.876600e-01,6.396900e-01,& - & 5.560500e-01,5.885500e-01,4.919500e-01,3.567500e-01,7.147600e-01,& - & 1.853900e-01,2.023200e-01,1.724200e-01,1.249100e-01,3.746800e-01,& - & 2.509600e-01,2.693600e-01,2.276600e-01,1.637200e-01,4.313400e-01,& - & 3.298500e-01,3.511800e-01,2.938000e-01,2.101800e-01,4.902400e-01,& - & 4.205000e-01,4.477900e-01,3.724500e-01,2.655200e-01,5.537300e-01,& - & 5.235300e-01,5.579900e-01,4.645100e-01,3.297900e-01,6.224400e-01,& - & 1.767000e-01,1.907900e-01,1.608100e-01,1.155000e-01,3.117300e-01,& - & 2.381600e-01,2.554500e-01,2.134900e-01,1.516500e-01,3.601500e-01,& - & 3.104600e-01,3.332900e-01,2.769200e-01,1.953500e-01,4.120300e-01,& - & 3.942100e-01,4.235500e-01,3.522600e-01,2.475300e-01,4.688100e-01,& - & 4.911300e-01,5.275700e-01,4.398800e-01,3.081700e-01,5.298900e-01,& - & 1.684300e-01,1.815400e-01,1.515400e-01,1.076700e-01,2.544100e-01,& - & 2.246600e-01,2.427000e-01,2.019000e-01,1.420100e-01,2.955600e-01,& - & 2.912600e-01,3.153700e-01,2.623200e-01,1.838700e-01,3.411300e-01,& - & 3.698300e-01,4.001100e-01,3.334000e-01,2.333800e-01,3.910000e-01,& - & 4.610100e-01,4.986700e-01,4.166300e-01,2.905300e-01,4.446400e-01,& - & 1.595900e-01,1.726200e-01,1.437400e-01,1.013000e-01,2.047100e-01,& - & 2.111500e-01,2.296300e-01,1.911600e-01,1.342100e-01,2.402000e-01,& - & 2.736000e-01,2.974000e-01,2.479500e-01,1.740300e-01,2.796800e-01,& - & 3.476400e-01,3.775600e-01,3.154900e-01,2.207000e-01,3.228100e-01,& - & 4.344000e-01,4.721900e-01,3.946500e-01,2.746500e-01,3.689600e-01,& - & 1.509100e-01,1.639100e-01,1.364500e-01,9.627800e-02,1.628900e-01,& - & 1.993100e-01,2.172100e-01,1.807900e-01,1.277100e-01,1.930900e-01,& - & 2.582100e-01,2.810900e-01,2.344900e-01,1.650200e-01,2.267600e-01,& - & 3.287500e-01,3.582900e-01,2.989800e-01,2.091900e-01,2.637000e-01,& - & 4.115700e-01,4.500200e-01,3.749900e-01,2.606400e-01,3.036500e-01,& - & 1.435000e-01,1.557700e-01,1.294800e-01,9.191100e-02,1.312600e-01,& - & 1.892700e-01,2.059100e-01,1.713700e-01,1.214800e-01,1.571200e-01,& - & 2.454200e-01,2.674500e-01,2.226500e-01,1.568600e-01,1.860600e-01,& - & 3.129900e-01,3.421100e-01,2.846400e-01,1.987900e-01,2.177600e-01,& - & 3.918900e-01,4.315400e-01,3.578400e-01,2.486900e-01,2.526100e-01,& - & 1.372700e-01,1.483800e-01,1.232500e-01,8.772300e-02,1.065600e-01,& - & 1.811000e-01,1.964700e-01,1.632200e-01,1.156200e-01,1.286700e-01,& - & 2.349300e-01,2.563300e-01,2.126000e-01,1.494500e-01,1.534400e-01,& - & 2.993000e-01,3.291100e-01,2.724100e-01,1.899100e-01,1.811200e-01,& - & 3.749100e-01,4.165800e-01,3.434000e-01,2.386700e-01,2.118800e-01,& - & 1.309200e-01,1.409400e-01,1.166700e-01,8.291100e-02,8.947100e-02,& - & 1.728300e-01,1.872000e-01,1.549800e-01,1.094500e-01,1.087900e-01,& - & 2.242300e-01,2.450800e-01,2.024700e-01,1.417500e-01,1.306700e-01,& - & 2.856800e-01,3.161300e-01,2.602200e-01,1.811900e-01,1.555100e-01,& - & 3.583600e-01,4.015700e-01,3.294200e-01,2.288600e-01,1.833500e-01,& - & 1.222800e-01,1.311800e-01,1.081500e-01,7.648000e-02,7.377000e-02,& - & 1.617200e-01,1.751600e-01,1.441900e-01,1.013800e-01,9.053200e-02,& - & 2.100500e-01,2.302400e-01,1.893600e-01,1.321200e-01,1.097700e-01,& - & 2.682300e-01,2.983700e-01,2.445000e-01,1.701000e-01,1.315200e-01,& - & 3.380300e-01,3.806900e-01,3.115100e-01,2.162300e-01,1.563900e-01,& - & 1.112700e-01,1.190200e-01,9.779000e-02,6.865200e-02,5.929400e-02,& - & 1.477900e-01,1.599100e-01,1.310000e-01,9.167800e-02,7.342800e-02,& - & 1.924800e-01,2.115200e-01,1.731000e-01,1.204400e-01,8.993100e-02,& - & 2.469800e-01,2.754600e-01,2.251300e-01,1.563500e-01,1.086500e-01,& - & 3.131200e-01,3.535700e-01,2.890000e-01,2.002800e-01,1.300700e-01/ - data absb(601:900,11) / & - & 9.717100e-02,1.037000e-01,8.493000e-02,5.913200e-02,4.880000e-02,& - & 1.302200e-01,1.404200e-01,1.146700e-01,7.978800e-02,6.110100e-02,& - & 1.705300e-01,1.873200e-01,1.526700e-01,1.059200e-01,7.554900e-02,& - & 2.202100e-01,2.458400e-01,2.002500e-01,1.388700e-01,9.212300e-02,& - & 2.814200e-01,3.180600e-01,2.595400e-01,1.797000e-01,1.111400e-01,& - & 8.475000e-02,9.044700e-02,7.386200e-02,5.102400e-02,4.012000e-02,& - & 1.147200e-01,1.234700e-01,1.005300e-01,6.943700e-02,5.077600e-02,& - & 1.513600e-01,1.660700e-01,1.349900e-01,9.321900e-02,6.338500e-02,& - & 1.968000e-01,2.197800e-01,1.784700e-01,1.234700e-01,7.800600e-02,& - & 2.534100e-01,2.867500e-01,2.333800e-01,1.614500e-01,9.484000e-02,& - & 7.401100e-02,7.919100e-02,6.447800e-02,4.420700e-02,3.280500e-02,& - & 1.012200e-01,1.090700e-01,8.854100e-02,6.075900e-02,4.197100e-02,& - & 1.347800e-01,1.477900e-01,1.199200e-01,8.232500e-02,5.290100e-02,& - & 1.766000e-01,1.972700e-01,1.598600e-01,1.101700e-01,6.573000e-02,& - & 2.290900e-01,2.598600e-01,2.107400e-01,1.455700e-01,8.050500e-02,& - & 6.247300e-02,6.707300e-02,5.456600e-02,3.718700e-02,2.688500e-02,& - & 8.660600e-02,9.364400e-02,7.580100e-02,5.166100e-02,3.483600e-02,& - & 1.168000e-01,1.279900e-01,1.037200e-01,7.069300e-02,4.436800e-02,& - & 1.547000e-01,1.724700e-01,1.396000e-01,9.567900e-02,5.568700e-02,& - & 2.023700e-01,2.297700e-01,1.857300e-01,1.279300e-01,6.885000e-02,& - & 5.244600e-02,5.650700e-02,4.595900e-02,3.119500e-02,2.194800e-02,& - & 7.370100e-02,8.011100e-02,6.471400e-02,4.381900e-02,2.883400e-02,& - & 1.007600e-01,1.107000e-01,8.951200e-02,6.057600e-02,3.715800e-02,& - & 1.350800e-01,1.505700e-01,1.217500e-01,8.289200e-02,4.710000e-02,& - & 1.785400e-01,2.026900e-01,1.635600e-01,1.121400e-01,5.882300e-02,& - & 4.399300e-02,4.754300e-02,3.862800e-02,2.617500e-02,1.782200e-02,& - & 6.261800e-02,6.846100e-02,5.530100e-02,3.721700e-02,2.372800e-02,& - & 8.681400e-02,9.594800e-02,7.732800e-02,5.200900e-02,3.095300e-02,& - & 1.179300e-01,1.316500e-01,1.063500e-01,7.196700e-02,3.967900e-02,& - & 1.576700e-01,1.790900e-01,1.443000e-01,9.841400e-02,5.003100e-02,& - & 3.605100e-02,3.906800e-02,3.170000e-02,2.150000e-02,1.433600e-02,& - & 5.213100e-02,5.726200e-02,4.624000e-02,3.100300e-02,1.936700e-02,& - & 7.334100e-02,8.159000e-02,6.570600e-02,4.388000e-02,2.560400e-02,& - & 1.011300e-01,1.133600e-01,9.135500e-02,6.139100e-02,3.321000e-02,& - & 1.370400e-01,1.556600e-01,1.253000e-01,8.498400e-02,4.235700e-02,& - & 2.915300e-02,3.168900e-02,2.565100e-02,1.739800e-02,1.145200e-02,& - & 4.289400e-02,4.727100e-02,3.816100e-02,2.555900e-02,1.570200e-02,& - & 6.131600e-02,6.860600e-02,5.524100e-02,3.670600e-02,2.105100e-02,& - & 8.580900e-02,9.681100e-02,7.786700e-02,5.197200e-02,2.764300e-02,& - & 1.180400e-01,1.342700e-01,1.080500e-01,7.283200e-02,3.569800e-02,& - & 2.347400e-02,2.562000e-02,2.068300e-02,1.399200e-02,9.087200e-03,& - & 3.516800e-02,3.888400e-02,3.135700e-02,2.099800e-02,1.265000e-02,& - & 5.112500e-02,5.747900e-02,4.626800e-02,3.068500e-02,1.718800e-02,& - & 7.264200e-02,8.254000e-02,6.638500e-02,4.398200e-02,2.287800e-02,& - & 1.014100e-01,1.159300e-01,9.312900e-02,6.238400e-02,2.991200e-02,& - & 1.862200e-02,2.041900e-02,1.644600e-02,1.108900e-02,7.150800e-03,& - & 2.846500e-02,3.159100e-02,2.542500e-02,1.700300e-02,1.010000e-02,& - & 4.211500e-02,4.755800e-02,3.829600e-02,2.538100e-02,1.392800e-02,& - & 6.088400e-02,6.960600e-02,5.600000e-02,3.688800e-02,1.879800e-02,& - & 8.627100e-02,9.929500e-02,7.964500e-02,5.299400e-02,2.487300e-02,& - & 1.437600e-02,1.584900e-02,1.275600e-02,8.563700e-03,5.584600e-03,& - & 2.252300e-02,2.509100e-02,2.013300e-02,1.343300e-02,8.013500e-03,& - & 3.398700e-02,3.852100e-02,3.097100e-02,2.049800e-02,1.121700e-02,& - & 4.999500e-02,5.747500e-02,4.627100e-02,3.042700e-02,1.535400e-02,& - & 7.209500e-02,8.355300e-02,6.709900e-02,4.424900e-02,2.056700e-02,& - & 1.094800e-02,1.218700e-02,9.819700e-03,6.568600e-03,4.330900e-03,& - & 1.767800e-02,1.977300e-02,1.584700e-02,1.052300e-02,6.319600e-03,& - & 2.727200e-02,3.103500e-02,2.488600e-02,1.642700e-02,8.975300e-03,& - & 4.084700e-02,4.723100e-02,3.798900e-02,2.496800e-02,1.243500e-02,& - & 5.994300e-02,6.992800e-02,5.626100e-02,3.686300e-02,1.688400e-02/ - data absb(901:1175,11) / & - & 8.222700e-03,9.275100e-03,7.491800e-03,4.985700e-03,3.317900e-03,& - & 1.371000e-02,1.546100e-02,1.238200e-02,8.183700e-03,4.941600e-03,& - & 2.175200e-02,2.482400e-02,1.987000e-02,1.306400e-02,7.119900e-03,& - & 3.320200e-02,3.859200e-02,3.099200e-02,2.032600e-02,9.989500e-03,& - & 4.956400e-02,5.820600e-02,4.689800e-02,3.066100e-02,1.373400e-02,& - & 6.191500e-03,7.080800e-03,5.734100e-03,3.793300e-03,2.601400e-03,& - & 1.063400e-02,1.214000e-02,9.718500e-03,6.396500e-03,3.937400e-03,& - & 1.739100e-02,1.994500e-02,1.595500e-02,1.044500e-02,5.767800e-03,& - & 2.712500e-02,3.170100e-02,2.541300e-02,1.659900e-02,8.197500e-03,& - & 4.119300e-02,4.872600e-02,3.923400e-02,2.563600e-02,1.139200e-02,& - & 4.641500e-03,5.377900e-03,4.364500e-03,2.876200e-03,2.067000e-03,& - & 8.198200e-03,9.496400e-03,7.612800e-03,4.989900e-03,3.163800e-03,& - & 1.383900e-02,1.601400e-02,1.280800e-02,8.336200e-03,4.717300e-03,& - & 2.215500e-02,2.601500e-02,2.083300e-02,1.353700e-02,6.807100e-03,& - & 3.426600e-02,4.081900e-02,3.280900e-02,2.139900e-02,9.549400e-03,& - & 3.445000e-03,4.041900e-03,3.282200e-03,2.159300e-03,1.647500e-03,& - & 6.250800e-03,7.353700e-03,5.918100e-03,3.860300e-03,2.537100e-03,& - & 1.090000e-02,1.277300e-02,1.021600e-02,6.612600e-03,3.834800e-03,& - & 1.797500e-02,2.123300e-02,1.700100e-02,1.099400e-02,5.630300e-03,& - & 2.837500e-02,3.403800e-02,2.733200e-02,1.774400e-02,7.984300e-03,& - & 2.533100e-03,3.001700e-03,2.436800e-03,1.599800e-03,1.319300e-03,& - & 4.708800e-03,5.627400e-03,4.548300e-03,2.954900e-03,2.029400e-03,& - & 8.477400e-03,1.009700e-02,8.077500e-03,5.209200e-03,3.095900e-03,& - & 1.444100e-02,1.720900e-02,1.378000e-02,8.874500e-03,4.617200e-03,& - & 2.338500e-02,2.821200e-02,2.265000e-02,1.461500e-02,6.651100e-03,& - & 1.895400e-03,2.260700e-03,1.827800e-03,1.194600e-03,1.098500e-03,& - & 3.586200e-03,4.347100e-03,3.518900e-03,2.282200e-03,1.689500e-03,& - & 6.631200e-03,8.042400e-03,6.452300e-03,4.140600e-03,2.594000e-03,& - & 1.167100e-02,1.408900e-02,1.128100e-02,7.227900e-03,3.912200e-03,& - & 1.943200e-02,2.359800e-02,1.894000e-02,1.215400e-02,5.733700e-03,& - & 1.429000e-03,1.712500e-03,1.377600e-03,8.934700e-04,9.378400e-04,& - & 2.745700e-03,3.362300e-03,2.718200e-03,1.759700e-03,1.445300e-03,& - & 5.187400e-03,6.397900e-03,5.151100e-03,3.293000e-03,2.222100e-03,& - & 9.422600e-03,1.155000e-02,9.255700e-03,5.899000e-03,3.385100e-03,& - & 1.615000e-02,1.977700e-02,1.587700e-02,1.013800e-02,5.039600e-03,& - & 1.068000e-03,1.289000e-03,1.031600e-03,6.644600e-04,8.043000e-04,& - & 2.097800e-03,2.585800e-03,2.082300e-03,1.344200e-03,1.245600e-03,& - & 4.030100e-03,5.043500e-03,4.077000e-03,2.599600e-03,1.914200e-03,& - & 7.540200e-03,9.403500e-03,7.547900e-03,4.789800e-03,2.939300e-03,& - & 1.333000e-02,1.649800e-02,1.324800e-02,8.428100e-03,4.430500e-03,& - & 7.880100e-04,9.628900e-04,7.669100e-04,4.909700e-04,6.885900e-04,& - & 1.596600e-03,1.977700e-03,1.584000e-03,1.016400e-03,1.080300e-03,& - & 3.111800e-03,3.947300e-03,3.193800e-03,2.034300e-03,1.662200e-03,& - & 5.975200e-03,7.590700e-03,6.111900e-03,3.862500e-03,2.558300e-03,& - & 1.090900e-02,1.369400e-02,1.099000e-02,6.963000e-03,3.898700e-03,& - & 5.817300e-04,7.204100e-04,5.727900e-04,3.647400e-04,5.935500e-04,& - & 1.225800e-03,1.524900e-03,1.214500e-03,7.724500e-04,9.545600e-04,& - & 2.424100e-03,3.104400e-03,2.508700e-03,1.593400e-03,1.469700e-03,& - & 4.751200e-03,6.135100e-03,4.958700e-03,3.124500e-03,2.263600e-03,& - & 8.945100e-03,1.140400e-02,9.157000e-03,5.775200e-03,3.484400e-03,& - & 5.052200e-04,6.304100e-04,4.992300e-04,3.152900e-04,5.758100e-04,& - & 1.088500e-03,1.359500e-03,1.077500e-03,6.774200e-04,9.392900e-04,& - & 2.175800e-03,2.792800e-03,2.248700e-03,1.418100e-03,1.451800e-03,& - & 4.293300e-03,5.581300e-03,4.516600e-03,2.832000e-03,2.245600e-03,& - & 8.180200e-03,1.052600e-02,8.459700e-03,5.317000e-03,3.484000e-03/ - data absb(1:300,12) / & - & 7.922800e-01,6.773900e-01,5.985100e-01,4.775300e-01,2.763700e+00,& - & 1.129800e+00,9.714600e-01,8.514800e-01,6.664200e-01,2.970100e+00,& - & 1.531500e+00,1.328300e+00,1.158600e+00,8.931200e-01,3.218800e+00,& - & 1.994400e+00,1.742200e+00,1.517400e+00,1.164100e+00,3.530200e+00,& - & 2.508900e+00,2.205200e+00,1.917000e+00,1.474100e+00,3.862200e+00,& - & 8.394900e-01,7.309300e-01,6.474600e-01,4.921500e-01,2.728900e+00,& - & 1.183800e+00,1.039200e+00,9.153000e-01,6.859300e-01,2.937400e+00,& - & 1.593600e+00,1.408000e+00,1.236200e+00,9.179200e-01,3.166100e+00,& - & 2.061800e+00,1.831800e+00,1.600600e+00,1.195100e+00,3.413300e+00,& - & 2.578200e+00,2.301600e+00,2.006700e+00,1.503200e+00,3.633000e+00,& - & 8.685000e-01,7.781600e-01,6.898800e-01,5.114200e-01,2.483900e+00,& - & 1.215200e+00,1.093800e+00,9.672700e-01,7.114500e-01,2.679400e+00,& - & 1.623100e+00,1.468200e+00,1.291200e+00,9.540500e-01,2.863600e+00,& - & 2.083300e+00,1.893300e+00,1.656200e+00,1.231500e+00,3.020300e+00,& - & 2.590700e+00,2.366000e+00,2.069200e+00,1.540700e+00,3.195500e+00,& - & 8.790300e-01,8.115400e-01,7.201700e-01,5.296600e-01,2.148700e+00,& - & 1.219600e+00,1.129000e+00,9.986700e-01,7.358900e-01,2.297900e+00,& - & 1.615800e+00,1.502000e+00,1.321500e+00,9.802800e-01,2.433200e+00,& - & 2.060800e+00,1.925800e+00,1.688400e+00,1.254700e+00,2.577700e+00,& - & 2.544400e+00,2.392200e+00,2.097900e+00,1.561300e+00,2.707300e+00,& - & 8.679700e-01,8.265700e-01,7.333800e-01,5.382300e-01,1.845000e+00,& - & 1.192900e+00,1.140700e+00,1.007400e+00,7.452500e-01,1.969100e+00,& - & 1.569400e+00,1.505100e+00,1.327000e+00,9.853500e-01,2.090300e+00,& - & 1.988600e+00,1.916500e+00,1.689600e+00,1.253300e+00,2.207100e+00,& - & 2.452500e+00,2.361900e+00,2.084900e+00,1.552400e+00,2.322900e+00,& - & 8.338500e-01,8.216800e-01,7.274900e-01,5.364900e-01,1.623400e+00,& - & 1.138900e+00,1.123100e+00,9.930600e-01,7.363400e-01,1.730700e+00,& - & 1.488700e+00,1.473900e+00,1.303400e+00,9.663500e-01,1.843500e+00,& - & 1.881500e+00,1.863400e+00,1.652200e+00,1.225400e+00,1.948400e+00,& - & 2.310600e+00,2.292000e+00,2.028500e+00,1.516200e+00,2.055100e+00,& - & 7.853000e-01,7.967900e-01,7.052800e-01,5.226500e-01,1.453300e+00,& - & 1.064400e+00,1.083000e+00,9.592000e-01,7.104500e-01,1.565100e+00,& - & 1.385600e+00,1.408700e+00,1.254200e+00,9.267700e-01,1.674800e+00,& - & 1.745200e+00,1.774500e+00,1.578200e+00,1.173700e+00,1.783900e+00,& - & 2.139800e+00,2.179400e+00,1.937300e+00,1.455300e+00,1.902300e+00,& - & 7.277800e-01,7.619400e-01,6.739000e-01,5.007700e-01,1.361700e+00,& - & 9.806800e-01,1.026200e+00,9.124500e-01,6.749100e-01,1.480700e+00,& - & 1.272200e+00,1.329300e+00,1.183100e+00,8.757400e-01,1.596600e+00,& - & 1.599100e+00,1.671400e+00,1.485300e+00,1.109000e+00,1.716300e+00,& - & 1.953500e+00,2.050000e+00,1.823100e+00,1.375400e+00,1.849400e+00,& - & 6.650400e-01,7.137800e-01,6.330500e-01,4.700200e-01,1.294600e+00,& - & 8.927800e-01,9.569300e-01,8.496700e-01,6.296000e-01,1.417000e+00,& - & 1.155300e+00,1.238200e+00,1.096800e+00,8.159900e-01,1.540000e+00,& - & 1.448200e+00,1.555100e+00,1.376100e+00,1.033000e+00,1.673700e+00,& - & 1.763500e+00,1.898400e+00,1.692000e+00,1.278200e+00,1.814800e+00,& - & 6.140900e-01,6.721000e-01,5.951700e-01,4.420500e-01,1.214000e+00,& - & 8.200900e-01,8.969000e-01,7.913400e-01,5.890000e-01,1.338800e+00,& - & 1.057300e+00,1.156200e+00,1.017000e+00,7.623900e-01,1.467400e+00,& - & 1.317300e+00,1.444100e+00,1.277300e+00,9.611100e-01,1.610300e+00,& - & 1.600800e+00,1.759300e+00,1.571400e+00,1.185900e+00,1.755400e+00,& - & 5.648900e-01,6.264300e-01,5.518100e-01,4.105500e-01,1.129600e+00,& - & 7.513600e-01,8.320500e-01,7.288200e-01,5.458700e-01,1.255600e+00,& - & 9.614700e-01,1.067300e+00,9.362200e-01,7.047400e-01,1.393900e+00,& - & 1.194500e+00,1.329200e+00,1.175800e+00,8.854000e-01,1.538000e+00,& - & 1.449800e+00,1.620300e+00,1.444300e+00,1.089700e+00,1.687900e+00,& - & 5.201900e-01,5.810800e-01,5.071400e-01,3.789400e-01,1.033500e+00,& - & 6.867800e-01,7.675300e-01,6.683600e-01,5.026100e-01,1.162300e+00,& - & 8.749000e-01,9.800000e-01,8.588800e-01,6.455900e-01,1.304700e+00,& - & 1.085500e+00,1.219400e+00,1.075700e+00,8.102900e-01,1.451300e+00,& - & 1.319500e+00,1.487500e+00,1.317600e+00,9.961700e-01,1.604200e+00/ - data absb(301:600,12) / & - & 4.812500e-01,5.377600e-01,4.654300e-01,3.492000e-01,9.429600e-01,& - & 6.306200e-01,7.067100e-01,6.137400e-01,4.602500e-01,1.078600e+00,& - & 8.013800e-01,8.996100e-01,7.869000e-01,5.899900e-01,1.221900e+00,& - & 9.950100e-01,1.120000e+00,9.813100e-01,7.397900e-01,1.374600e+00,& - & 1.213300e+00,1.369000e+00,1.200200e+00,9.084800e-01,1.531000e+00,& - & 4.471800e-01,5.004500e-01,4.302600e-01,3.219000e-01,8.740100e-01,& - & 5.837700e-01,6.532900e-01,5.666900e-01,4.222200e-01,1.013200e+00,& - & 7.422500e-01,8.312200e-01,7.214200e-01,5.409300e-01,1.159900e+00,& - & 9.257600e-01,1.036300e+00,8.987500e-01,6.765100e-01,1.315000e+00,& - & 1.135900e+00,1.268900e+00,1.100300e+00,8.312800e-01,1.472500e+00,& - & 4.174200e-01,4.658900e-01,4.001400e-01,2.960700e-01,8.031100e-01,& - & 5.453400e-01,6.069400e-01,5.225400e-01,3.881400e-01,9.374800e-01,& - & 6.970500e-01,7.731700e-01,6.643200e-01,4.956600e-01,1.080800e+00,& - & 8.742100e-01,9.658800e-01,8.281600e-01,6.191500e-01,1.227000e+00,& - & 1.078300e+00,1.190000e+00,1.015100e+00,7.635600e-01,1.378100e+00,& - & 3.923700e-01,4.351500e-01,3.724800e-01,2.730500e-01,7.228000e-01,& - & 5.156300e-01,5.675700e-01,4.840300e-01,3.570000e-01,8.467700e-01,& - & 6.630800e-01,7.251900e-01,6.159000e-01,4.547200e-01,9.771000e-01,& - & 8.364600e-01,9.115200e-01,7.699700e-01,5.698800e-01,1.109600e+00,& - & 1.035900e+00,1.127600e+00,9.496200e-01,7.052600e-01,1.248500e+00,& - & 3.727900e-01,4.101400e-01,3.477400e-01,2.534100e-01,6.326900e-01,& - & 4.928300e-01,5.376900e-01,4.523300e-01,3.302100e-01,7.429400e-01,& - & 6.373100e-01,6.899400e-01,5.778000e-01,4.207000e-01,8.567800e-01,& - & 8.063700e-01,8.702500e-01,7.264400e-01,5.290800e-01,9.759500e-01,& - & 9.994300e-01,1.081300e+00,9.012800e-01,6.586600e-01,1.101900e+00,& - & 3.572200e-01,3.908000e-01,3.271000e-01,2.360100e-01,5.403700e-01,& - & 4.744800e-01,5.142900e-01,4.278300e-01,3.071600e-01,6.350300e-01,& - & 6.143900e-01,6.630800e-01,5.492000e-01,3.934500e-01,7.338100e-01,& - & 7.764400e-01,8.406200e-01,6.935000e-01,4.978200e-01,8.401000e-01,& - & 9.622600e-01,1.047800e+00,8.646800e-01,6.225600e-01,9.539800e-01,& - & 3.449800e-01,3.754500e-01,3.115000e-01,2.212200e-01,4.490500e-01,& - & 4.582000e-01,4.965300e-01,4.098300e-01,2.888800e-01,5.291700e-01,& - & 5.917000e-01,6.437800e-01,5.281000e-01,3.728400e-01,6.159000e-01,& - & 7.478700e-01,8.183500e-01,6.706400e-01,4.744800e-01,7.095300e-01,& - & 9.277600e-01,1.023800e+00,8.402000e-01,5.954000e-01,8.085000e-01,& - & 3.338700e-01,3.639700e-01,2.997900e-01,2.096200e-01,3.730700e-01,& - & 4.416300e-01,4.836300e-01,3.960700e-01,2.759400e-01,4.421600e-01,& - & 5.701500e-01,6.287600e-01,5.136300e-01,3.576500e-01,5.178800e-01,& - & 7.214100e-01,8.015100e-01,6.551700e-01,4.571700e-01,6.001600e-01,& - & 8.992200e-01,1.006200e+00,8.240700e-01,5.745900e-01,6.853600e-01,& - & 3.229300e-01,3.554700e-01,2.909300e-01,2.014900e-01,3.091700e-01,& - & 4.262700e-01,4.735500e-01,3.861900e-01,2.664000e-01,3.692000e-01,& - & 5.505800e-01,6.166500e-01,5.034600e-01,3.467900e-01,4.350500e-01,& - & 6.998000e-01,7.885200e-01,6.447500e-01,4.444200e-01,5.048800e-01,& - & 8.759200e-01,9.939000e-01,8.149600e-01,5.602900e-01,5.774600e-01,& - & 3.094000e-01,3.452800e-01,2.815600e-01,1.936300e-01,2.661100e-01,& - & 4.089400e-01,4.607400e-01,3.756500e-01,2.576300e-01,3.193800e-01,& - & 5.304100e-01,6.025100e-01,4.918500e-01,3.367900e-01,3.776200e-01,& - & 6.778600e-01,7.735000e-01,6.339900e-01,4.327600e-01,4.388000e-01,& - & 8.521600e-01,9.805000e-01,8.044300e-01,5.475800e-01,5.038400e-01,& - & 2.893900e-01,3.270200e-01,2.662200e-01,1.824900e-01,2.242600e-01,& - & 3.843200e-01,4.386000e-01,3.576800e-01,2.446100e-01,2.704400e-01,& - & 5.022700e-01,5.768700e-01,4.713300e-01,3.215600e-01,3.204700e-01,& - & 6.452200e-01,7.463000e-01,6.120200e-01,4.151600e-01,3.735600e-01,& - & 8.162300e-01,9.532500e-01,7.816300e-01,5.282100e-01,4.327200e-01,& - & 2.633000e-01,3.007000e-01,2.444200e-01,1.675700e-01,1.831000e-01,& - & 3.525500e-01,4.066700e-01,3.314400e-01,2.264400e-01,2.220000e-01,& - & 4.646800e-01,5.394800e-01,4.411000e-01,3.001200e-01,2.641200e-01,& - & 6.015500e-01,7.048600e-01,5.778300e-01,3.905800e-01,3.100200e-01,& - & 7.670300e-01,9.087300e-01,7.445700e-01,5.006000e-01,3.639500e-01/ - data absb(601:900,12) / & - & 2.300100e-01,2.644200e-01,2.145900e-01,1.472700e-01,1.553600e-01,& - & 3.109600e-01,3.619700e-01,2.946100e-01,2.012900e-01,1.900400e-01,& - & 4.143100e-01,4.858900e-01,3.970000e-01,2.700000e-01,2.280000e-01,& - & 5.422600e-01,6.426600e-01,5.266500e-01,3.552400e-01,2.691000e-01,& - & 6.984100e-01,8.379700e-01,6.866300e-01,4.596300e-01,3.177400e-01,& - & 2.013400e-01,2.322700e-01,1.881400e-01,1.293500e-01,1.313700e-01,& - & 2.746800e-01,3.220800e-01,2.617400e-01,1.789100e-01,1.621700e-01,& - & 3.695600e-01,4.377600e-01,3.573300e-01,2.428900e-01,1.962300e-01,& - & 4.889600e-01,5.864000e-01,4.800200e-01,3.234900e-01,2.330000e-01,& - & 6.366600e-01,7.734600e-01,6.338000e-01,4.228600e-01,2.766300e-01,& - & 1.769700e-01,2.046700e-01,1.654000e-01,1.138600e-01,1.100700e-01,& - & 2.436800e-01,2.873500e-01,2.331900e-01,1.594700e-01,1.371900e-01,& - & 3.309200e-01,3.958000e-01,3.226800e-01,2.191800e-01,1.672000e-01,& - & 4.424900e-01,5.369900e-01,4.391400e-01,2.955200e-01,1.998700e-01,& - & 5.822600e-01,7.160000e-01,5.870900e-01,3.905800e-01,2.387900e-01,& - & 1.508400e-01,1.744900e-01,1.404500e-01,9.679400e-02,9.339200e-02,& - & 2.101000e-01,2.482200e-01,2.009700e-01,1.376600e-01,1.176700e-01,& - & 2.883500e-01,3.471600e-01,2.824800e-01,1.919700e-01,1.449500e-01,& - & 3.898800e-01,4.778900e-01,3.903700e-01,2.626100e-01,1.746800e-01,& - & 5.194500e-01,6.458600e-01,5.290300e-01,3.516200e-01,2.097500e-01,& - & 1.281700e-01,1.482900e-01,1.188700e-01,8.184000e-02,7.905700e-02,& - & 1.806000e-01,2.136200e-01,1.724700e-01,1.183000e-01,1.008100e-01,& - & 2.508000e-01,3.033400e-01,2.463400e-01,1.675300e-01,1.254800e-01,& - & 3.428000e-01,4.237600e-01,3.458600e-01,2.325100e-01,1.525600e-01,& - & 4.623000e-01,5.807000e-01,4.751800e-01,3.157200e-01,1.843100e-01,& - & 1.089300e-01,1.261300e-01,1.008300e-01,6.915700e-02,6.639400e-02,& - & 1.554700e-01,1.841500e-01,1.480300e-01,1.016100e-01,8.577700e-02,& - & 2.184600e-01,2.650200e-01,2.148600e-01,1.462700e-01,1.079400e-01,& - & 3.019800e-01,3.758700e-01,3.063800e-01,2.058300e-01,1.324700e-01,& - & 4.119900e-01,5.222500e-01,4.270900e-01,2.835100e-01,1.611100e-01,& - & 9.063800e-02,1.050300e-01,8.379500e-02,5.707100e-02,5.535400e-02,& - & 1.313100e-01,1.554800e-01,1.245800e-01,8.536400e-02,7.257600e-02,& - & 1.868100e-01,2.270700e-01,1.834700e-01,1.250100e-01,9.253800e-02,& - & 2.616000e-01,3.267200e-01,2.659500e-01,1.787600e-01,1.150000e-01,& - & 3.612000e-01,4.609700e-01,3.766900e-01,2.499900e-01,1.407500e-01,& - & 7.451800e-02,8.640900e-02,6.895200e-02,4.657700e-02,4.578700e-02,& - & 1.097500e-01,1.299400e-01,1.038500e-01,7.083500e-02,6.097600e-02,& - & 1.582800e-01,1.925000e-01,1.550600e-01,1.055800e-01,7.893600e-02,& - & 2.247100e-01,2.809800e-01,2.282100e-01,1.536500e-01,9.946000e-02,& - & 3.140600e-01,4.026900e-01,3.287100e-01,2.181300e-01,1.227600e-01,& - & 6.092700e-02,7.088800e-02,5.660400e-02,3.800700e-02,3.745100e-02,& - & 9.156200e-02,1.084800e-01,8.656300e-02,5.863800e-02,5.073900e-02,& - & 1.340100e-01,1.630500e-01,1.309300e-01,8.890900e-02,6.664500e-02,& - & 1.927800e-01,2.413200e-01,1.953800e-01,1.317100e-01,8.519500e-02,& - & 2.730100e-01,3.508700e-01,2.859900e-01,1.899400e-01,1.062700e-01,& - & 4.904900e-02,5.739000e-02,4.584100e-02,3.065200e-02,3.024400e-02,& - & 7.539500e-02,8.954400e-02,7.147900e-02,4.801600e-02,4.181200e-02,& - & 1.124300e-01,1.367300e-01,1.094000e-01,7.399200e-02,5.580200e-02,& - & 1.638500e-01,2.051500e-01,1.655400e-01,1.116300e-01,7.238400e-02,& - & 2.353500e-01,3.022800e-01,2.459600e-01,1.635900e-01,9.135000e-02,& - & 3.845500e-02,4.531100e-02,3.619100e-02,2.409900e-02,2.418000e-02,& - & 6.054300e-02,7.221900e-02,5.775200e-02,3.850100e-02,3.415300e-02,& - & 9.246900e-02,1.122900e-01,8.964900e-02,6.032600e-02,4.644800e-02,& - & 1.368900e-01,1.710200e-01,1.375000e-01,9.254700e-02,6.121400e-02,& - & 1.992700e-01,2.553500e-01,2.070400e-01,1.381800e-01,7.842500e-02,& - & 2.990700e-02,3.553800e-02,2.834900e-02,1.878100e-02,1.905400e-02,& - & 4.822800e-02,5.790400e-02,4.634500e-02,3.076400e-02,2.746600e-02,& - & 7.547000e-02,9.180600e-02,7.331700e-02,4.899500e-02,3.815100e-02,& - & 1.140600e-01,1.420400e-01,1.138300e-01,7.634300e-02,5.117200e-02,& - & 1.682200e-01,2.149700e-01,1.737200e-01,1.160700e-01,6.662900e-02/ - data absb(901:1175,12) / & - & 2.308400e-02,2.760200e-02,2.204300e-02,1.451500e-02,1.470000e-02,& - & 3.813400e-02,4.613800e-02,3.693200e-02,2.442200e-02,2.169600e-02,& - & 6.105300e-02,7.469100e-02,5.974300e-02,3.961800e-02,3.078400e-02,& - & 9.462400e-02,1.174700e-01,9.390600e-02,6.271700e-02,4.205700e-02,& - & 1.416200e-01,1.803100e-01,1.452000e-01,9.695100e-02,5.566500e-02,& - & 1.788000e-02,2.152200e-02,1.719300e-02,1.128100e-02,1.156300e-02,& - & 3.030400e-02,3.698800e-02,2.959400e-02,1.948900e-02,1.751100e-02,& - & 4.962000e-02,6.113000e-02,4.899000e-02,3.231300e-02,2.534500e-02,& - & 7.879400e-02,9.781300e-02,7.819800e-02,5.194300e-02,3.529800e-02,& - & 1.201000e-01,1.522700e-01,1.222900e-01,8.143800e-02,4.746200e-02,& - & 1.377800e-02,1.675300e-02,1.336600e-02,8.758700e-03,9.169100e-03,& - & 2.406800e-02,2.959800e-02,2.372000e-02,1.553100e-02,1.424100e-02,& - & 4.031900e-02,5.002300e-02,4.014600e-02,2.637900e-02,2.104100e-02,& - & 6.544400e-02,8.155900e-02,6.527400e-02,4.310700e-02,2.980800e-02,& - & 1.019300e-01,1.287800e-01,1.031600e-01,6.848500e-02,4.076400e-02,& - & 1.050300e-02,1.290800e-02,1.029600e-02,6.739100e-03,7.163200e-03,& - & 1.896300e-02,2.351400e-02,1.886300e-02,1.229200e-02,1.141600e-02,& - & 3.257400e-02,4.076300e-02,3.269200e-02,2.141300e-02,1.723200e-02,& - & 5.401500e-02,6.772500e-02,5.429700e-02,3.564800e-02,2.488000e-02,& - & 8.614200e-02,1.085000e-01,8.678300e-02,5.741200e-02,3.460400e-02,& - & 7.903400e-03,9.823900e-03,7.836900e-03,5.124800e-03,5.484300e-03,& - & 1.479200e-02,1.852600e-02,1.484700e-02,9.658500e-03,8.979800e-03,& - & 2.614500e-02,3.297600e-02,2.645400e-02,1.726000e-02,1.388000e-02,& - & 4.432400e-02,5.590000e-02,4.489400e-02,2.934500e-02,2.045000e-02,& - & 7.225900e-02,9.103100e-02,7.283600e-02,4.796400e-02,2.889900e-02,& - & 6.003000e-03,7.534300e-03,6.020600e-03,3.926900e-03,4.437400e-03,& - & 1.162600e-02,1.474600e-02,1.180100e-02,7.673300e-03,7.464400e-03,& - & 2.120400e-02,2.693200e-02,2.163900e-02,1.405800e-02,1.182000e-02,& - & 3.673400e-02,4.663000e-02,3.747300e-02,2.439900e-02,1.774600e-02,& - & 6.104800e-02,7.717600e-02,6.183900e-02,4.051700e-02,2.547400e-02,& - & 4.563000e-03,5.768100e-03,4.620500e-03,3.000200e-03,3.704500e-03,& - & 9.127300e-03,1.172800e-02,9.395600e-03,6.094500e-03,6.407700e-03,& - & 1.719100e-02,2.203900e-02,1.771100e-02,1.146900e-02,1.039000e-02,& - & 3.051700e-02,3.900900e-02,3.132100e-02,2.035000e-02,1.590900e-02,& - & 5.168000e-02,6.561800e-02,5.264900e-02,3.434500e-02,2.323100e-02,& - & 3.442900e-03,4.369300e-03,3.510200e-03,2.266400e-03,3.097200e-03,& - & 7.106700e-03,9.241200e-03,7.410600e-03,4.801000e-03,5.493800e-03,& - & 1.383800e-02,1.792600e-02,1.439300e-02,9.310200e-03,9.116700e-03,& - & 2.522600e-02,3.247000e-02,2.606700e-02,1.689000e-02,1.425300e-02,& - & 4.355500e-02,5.555900e-02,4.463900e-02,2.900800e-02,2.119400e-02,& - & 2.583500e-03,3.279200e-03,2.634000e-03,1.692800e-03,2.597900e-03,& - & 5.481800e-03,7.201800e-03,5.786000e-03,3.739900e-03,4.693800e-03,& - & 1.104500e-02,1.447700e-02,1.161500e-02,7.507100e-03,7.988000e-03,& - & 2.073400e-02,2.685500e-02,2.158400e-02,1.393900e-02,1.277100e-02,& - & 3.653100e-02,4.683400e-02,3.764100e-02,2.439100e-02,1.932800e-02,& - & 1.955400e-03,2.480500e-03,1.981500e-03,1.267500e-03,2.231100e-03,& - & 4.240600e-03,5.619400e-03,4.525100e-03,2.914200e-03,4.075100e-03,& - & 8.825300e-03,1.171500e-02,9.404900e-03,6.068700e-03,7.108200e-03,& - & 1.708100e-02,2.229400e-02,1.792100e-02,1.154200e-02,1.160100e-02,& - & 3.076800e-02,3.966100e-02,3.185300e-02,2.059900e-02,1.786000e-02,& - & 1.731100e-03,2.195000e-03,1.746400e-03,1.109500e-03,2.281000e-03,& - & 3.786700e-03,5.037500e-03,4.062200e-03,2.605000e-03,4.222900e-03,& - & 7.992700e-03,1.069100e-02,8.587200e-03,5.533000e-03,7.463700e-03,& - & 1.570600e-02,2.060300e-02,1.655900e-02,1.065300e-02,1.233800e-02,& - & 2.861400e-02,3.699500e-02,2.970300e-02,1.919100e-02,1.917800e-02/ - data absb(1:300,13) / & - & 1.285200e+00,1.064300e+00,9.242300e-01,7.721000e-01,4.856000e+00,& - & 1.830000e+00,1.515300e+00,1.305600e+00,1.089600e+00,5.176200e+00,& - & 2.489800e+00,2.061900e+00,1.778100e+00,1.472000e+00,5.599500e+00,& - & 3.258000e+00,2.713600e+00,2.337900e+00,1.910300e+00,6.000600e+00,& - & 4.134400e+00,3.474100e+00,2.982600e+00,2.398600e+00,6.325400e+00,& - & 1.435300e+00,1.181300e+00,1.009700e+00,8.176600e-01,4.436400e+00,& - & 2.032000e+00,1.676600e+00,1.421700e+00,1.147600e+00,4.777700e+00,& - & 2.739700e+00,2.276600e+00,1.916400e+00,1.540400e+00,5.195600e+00,& - & 3.552500e+00,2.977400e+00,2.503800e+00,1.989800e+00,5.557900e+00,& - & 4.458300e+00,3.778400e+00,3.176700e+00,2.509800e+00,5.895400e+00,& - & 1.578500e+00,1.306700e+00,1.109700e+00,8.667400e-01,3.849200e+00,& - & 2.212500e+00,1.843400e+00,1.556300e+00,1.205000e+00,4.196800e+00,& - & 2.959500e+00,2.484400e+00,2.088900e+00,1.606800e+00,4.545300e+00,& - & 3.804500e+00,3.225900e+00,2.708800e+00,2.075700e+00,4.894500e+00,& - & 4.732400e+00,4.053000e+00,3.402400e+00,2.620100e+00,5.130800e+00,& - & 1.699000e+00,1.427000e+00,1.219700e+00,9.154000e-01,3.296700e+00,& - & 2.363200e+00,1.996500e+00,1.699100e+00,1.263500e+00,3.599200e+00,& - & 3.133200e+00,2.673700e+00,2.266200e+00,1.679700e+00,3.882500e+00,& - & 3.995400e+00,3.441300e+00,2.915000e+00,2.173200e+00,4.095500e+00,& - & 4.944100e+00,4.281300e+00,3.629600e+00,2.734700e+00,4.335600e+00,& - & 1.786700e+00,1.529100e+00,1.317200e+00,9.644200e-01,2.894600e+00,& - & 2.463000e+00,2.124000e+00,1.819700e+00,1.327100e+00,3.120900e+00,& - & 3.241200e+00,2.820500e+00,2.412000e+00,1.762100e+00,3.323100e+00,& - & 4.112900e+00,3.602600e+00,3.078500e+00,2.275200e+00,3.546700e+00,& - & 5.051800e+00,4.457500e+00,3.817400e+00,2.844400e+00,3.786900e+00,& - & 1.839500e+00,1.613200e+00,1.396100e+00,1.012100e+00,2.625500e+00,& - & 2.510600e+00,2.221100e+00,1.917900e+00,1.391800e+00,2.807400e+00,& - & 3.284000e+00,2.923000e+00,2.521600e+00,1.845500e+00,2.988600e+00,& - & 4.139800e+00,3.707600e+00,3.199500e+00,2.365500e+00,3.203300e+00,& - & 5.065200e+00,4.568100e+00,3.958600e+00,2.947000e+00,3.443100e+00,& - & 1.842900e+00,1.670000e+00,1.453600e+00,1.056400e+00,2.457700e+00,& - & 2.502200e+00,2.278400e+00,1.983300e+00,1.449200e+00,2.609300e+00,& - & 3.252000e+00,2.980500e+00,2.589400e+00,1.914000e+00,2.786000e+00,& - & 4.080700e+00,3.764800e+00,3.279200e+00,2.435400e+00,2.980400e+00,& - & 4.968000e+00,4.622400e+00,4.039500e+00,3.022400e+00,3.217500e+00,& - & 1.822800e+00,1.702500e+00,1.492800e+00,1.089800e+00,2.365400e+00,& - & 2.453800e+00,2.305100e+00,2.020400e+00,1.489700e+00,2.521700e+00,& - & 3.169900e+00,2.997100e+00,2.632000e+00,1.952400e+00,2.699900e+00,& - & 3.955400e+00,3.771000e+00,3.317500e+00,2.472500e+00,2.891100e+00,& - & 4.806300e+00,4.609400e+00,4.074100e+00,3.059000e+00,3.123200e+00,& - & 1.762300e+00,1.706100e+00,1.500600e+00,1.105100e+00,2.298700e+00,& - & 2.356800e+00,2.293800e+00,2.024100e+00,1.500500e+00,2.481000e+00,& - & 3.026400e+00,2.966300e+00,2.625200e+00,1.954000e+00,2.670900e+00,& - & 3.766100e+00,3.711400e+00,3.301700e+00,2.466000e+00,2.873900e+00,& - & 4.570900e+00,4.529200e+00,4.035300e+00,3.045800e+00,3.112200e+00,& - & 1.705100e+00,1.710500e+00,1.513700e+00,1.122000e+00,2.221500e+00,& - & 2.259400e+00,2.281200e+00,2.026500e+00,1.507800e+00,2.427300e+00,& - & 2.884300e+00,2.929800e+00,2.615900e+00,1.949700e+00,2.634400e+00,& - & 3.578400e+00,3.653000e+00,3.269900e+00,2.453200e+00,2.857100e+00,& - & 4.328200e+00,4.441300e+00,3.981700e+00,3.026300e+00,3.113800e+00,& - & 1.622700e+00,1.686500e+00,1.498700e+00,1.116400e+00,2.151600e+00,& - & 2.133400e+00,2.231100e+00,1.994700e+00,1.486500e+00,2.371400e+00,& - & 2.713000e+00,2.850500e+00,2.560100e+00,1.913100e+00,2.595700e+00,& - & 3.354500e+00,3.541700e+00,3.184500e+00,2.407000e+00,2.842300e+00,& - & 4.051100e+00,4.298000e+00,3.882400e+00,2.966300e+00,3.109700e+00,& - & 1.522100e+00,1.639900e+00,1.463100e+00,1.092200e+00,2.055700e+00,& - & 1.990900e+00,2.155100e+00,1.933300e+00,1.443800e+00,2.289300e+00,& - & 2.522700e+00,2.742400e+00,2.467000e+00,1.856000e+00,2.530800e+00,& - & 3.113200e+00,3.399800e+00,3.069000e+00,2.331500e+00,2.795900e+00,& - & 3.762500e+00,4.127500e+00,3.750200e+00,2.872600e+00,3.071100e+00/ - data absb(301:600,13) / & - & 1.416400e+00,1.576400e+00,1.412000e+00,1.053900e+00,1.971000e+00,& - & 1.845100e+00,2.062300e+00,1.852300e+00,1.388900e+00,2.211700e+00,& - & 2.332300e+00,2.617000e+00,2.356000e+00,1.781300e+00,2.470200e+00,& - & 2.878500e+00,3.242300e+00,2.935300e+00,2.237900e+00,2.741500e+00,& - & 3.474800e+00,3.938600e+00,3.595800e+00,2.756600e+00,3.024600e+00,& - & 1.317400e+00,1.506500e+00,1.350500e+00,1.010800e+00,1.909200e+00,& - & 1.710000e+00,1.965600e+00,1.761400e+00,1.327300e+00,2.156800e+00,& - & 2.159900e+00,2.491800e+00,2.242400e+00,1.702200e+00,2.425100e+00,& - & 2.661900e+00,3.086300e+00,2.800700e+00,2.136800e+00,2.697400e+00,& - & 3.216400e+00,3.756200e+00,3.438200e+00,2.632300e+00,2.989700e+00,& - & 1.222700e+00,1.431800e+00,1.277600e+00,9.623400e-01,1.808400e+00,& - & 1.584500e+00,1.865000e+00,1.666900e+00,1.261600e+00,2.060600e+00,& - & 1.998600e+00,2.363700e+00,2.125500e+00,1.618000e+00,2.323500e+00,& - & 2.467000e+00,2.933500e+00,2.660600e+00,2.030600e+00,2.597900e+00,& - & 2.983600e+00,3.581200e+00,3.279900e+00,2.504700e+00,2.894000e+00,& - & 1.138200e+00,1.356900e+00,1.204700e+00,9.105000e-01,1.675600e+00,& - & 1.473100e+00,1.765800e+00,1.574700e+00,1.195900e+00,1.925900e+00,& - & 1.859500e+00,2.241700e+00,2.013600e+00,1.532300e+00,2.179700e+00,& - & 2.293300e+00,2.793000e+00,2.530400e+00,1.926600e+00,2.458100e+00,& - & 2.779200e+00,3.430300e+00,3.128800e+00,2.384600e+00,2.756900e+00,& - & 1.069000e+00,1.288100e+00,1.139400e+00,8.619600e-01,1.531600e+00,& - & 1.383300e+00,1.676700e+00,1.490900e+00,1.133000e+00,1.763600e+00,& - & 1.741800e+00,2.137300e+00,1.915200e+00,1.452900e+00,2.007900e+00,& - & 2.152000e+00,2.679600e+00,2.415800e+00,1.832700e+00,2.275200e+00,& - & 2.619800e+00,3.304500e+00,3.000000e+00,2.277100e+00,2.561600e+00,& - & 1.012700e+00,1.226600e+00,1.079700e+00,8.186300e-01,1.372400e+00,& - & 1.306900e+00,1.601500e+00,1.418500e+00,1.074500e+00,1.582900e+00,& - & 1.648700e+00,2.052200e+00,1.830200e+00,1.382000e+00,1.815300e+00,& - & 2.047300e+00,2.584300e+00,2.320900e+00,1.751500e+00,2.065900e+00,& - & 2.509200e+00,3.202300e+00,2.896900e+00,2.188800e+00,2.337400e+00,& - & 9.651000e-01,1.179400e+00,1.030800e+00,7.785600e-01,1.191800e+00,& - & 1.247700e+00,1.545700e+00,1.361900e+00,1.025200e+00,1.381700e+00,& - & 1.583700e+00,1.988500e+00,1.765200e+00,1.324800e+00,1.591400e+00,& - & 1.979700e+00,2.515900e+00,2.249600e+00,1.688000e+00,1.816900e+00,& - & 2.439700e+00,3.133300e+00,2.824300e+00,2.125300e+00,2.069100e+00,& - & 9.280900e-01,1.146200e+00,9.962800e-01,7.453600e-01,1.032000e+00,& - & 1.207100e+00,1.506900e+00,1.320500e+00,9.859700e-01,1.203300e+00,& - & 1.543200e+00,1.947600e+00,1.719100e+00,1.283500e+00,1.389700e+00,& - & 1.940600e+00,2.476600e+00,2.203800e+00,1.645800e+00,1.597100e+00,& - & 2.399400e+00,3.098400e+00,2.784400e+00,2.089200e+00,1.836400e+00,& - & 9.045200e-01,1.125800e+00,9.732100e-01,7.200200e-01,8.856200e-01,& - & 1.184600e+00,1.486400e+00,1.294100e+00,9.587600e-01,1.037100e+00,& - & 1.521400e+00,1.931100e+00,1.693700e+00,1.257200e+00,1.204600e+00,& - & 1.919600e+00,2.465700e+00,2.185800e+00,1.623900e+00,1.397700e+00,& - & 2.383600e+00,3.100700e+00,2.776800e+00,2.078100e+00,1.627300e+00,& - & 8.846700e-01,1.106800e+00,9.505400e-01,6.962900e-01,7.849400e-01,& - & 1.164200e+00,1.470600e+00,1.271700e+00,9.347000e-01,9.213800e-01,& - & 1.501500e+00,1.918100e+00,1.675800e+00,1.234500e+00,1.077300e+00,& - & 1.901800e+00,2.463200e+00,2.175900e+00,1.608000e+00,1.261400e+00,& - & 2.374000e+00,3.114500e+00,2.782100e+00,2.071200e+00,1.479200e+00,& - & 8.495500e-01,1.068800e+00,9.123100e-01,6.620200e-01,6.782400e-01,& - & 1.125000e+00,1.431300e+00,1.230300e+00,8.969800e-01,8.019300e-01,& - & 1.459900e+00,1.879100e+00,1.634700e+00,1.194500e+00,9.477100e-01,& - & 1.861700e+00,2.428900e+00,2.138200e+00,1.570300e+00,1.123900e+00,& - & 2.337100e+00,3.088600e+00,2.750300e+00,2.037000e+00,1.325800e+00,& - & 7.955400e-01,1.008600e+00,8.557300e-01,6.148500e-01,5.702700e-01,& - & 1.064200e+00,1.363400e+00,1.165200e+00,8.419700e-01,6.837800e-01,& - & 1.392400e+00,1.804900e+00,1.563400e+00,1.132600e+00,8.221800e-01,& - & 1.790000e+00,2.351200e+00,2.060700e+00,1.502600e+00,9.885900e-01,& - & 2.263000e+00,3.006500e+00,2.668700e+00,1.964000e+00,1.176200e+00/ - data absb(601:900,13) / & - & 7.141700e-01,9.130900e-01,7.708900e-01,5.480300e-01,4.962200e-01,& - & 9.691300e-01,1.251200e+00,1.063000e+00,7.604300e-01,5.979700e-01,& - & 1.284000e+00,1.674600e+00,1.441600e+00,1.035300e+00,7.223300e-01,& - & 1.667800e+00,2.200800e+00,1.918700e+00,1.387500e+00,8.730400e-01,& - & 2.127100e+00,2.838000e+00,2.506200e+00,1.831400e+00,1.044400e+00,& - & 6.409400e-01,8.276800e-01,6.964500e-01,4.897200e-01,4.278200e-01,& - & 8.826800e-01,1.149900e+00,9.725200e-01,6.890100e-01,5.181700e-01,& - & 1.185400e+00,1.556700e+00,1.332600e+00,9.487500e-01,6.291100e-01,& - & 1.554800e+00,2.063300e+00,1.790300e+00,1.284600e+00,7.640400e-01,& - & 2.000500e+00,2.681900e+00,2.357700e+00,1.710800e+00,9.191000e-01,& - & 5.770000e-01,7.534800e-01,6.323400e-01,4.403900e-01,3.631600e-01,& - & 8.061700e-01,1.060700e+00,8.946400e-01,6.278700e-01,4.425600e-01,& - & 1.097100e+00,1.452800e+00,1.237100e+00,8.738100e-01,5.406300e-01,& - & 1.453900e+00,1.940900e+00,1.676800e+00,1.194600e+00,6.603400e-01,& - & 1.888000e+00,2.541900e+00,2.224400e+00,1.603900e+00,7.989000e-01,& - & 5.018600e-01,6.629400e-01,5.550000e-01,3.828900e-01,3.176900e-01,& - & 7.132300e-01,9.479800e-01,7.975200e-01,5.538400e-01,3.887700e-01,& - & 9.858600e-01,1.316400e+00,1.115700e+00,7.813600e-01,4.761800e-01,& - & 1.325800e+00,1.778100e+00,1.526900e+00,1.079500e+00,5.846200e-01,& - & 1.739700e+00,2.349600e+00,2.044700e+00,1.464000e+00,7.118300e-01,& - & 4.338000e-01,5.809700e-01,4.847600e-01,3.318600e-01,2.776200e-01,& - & 6.281900e-01,8.437500e-01,7.079800e-01,4.871800e-01,3.415100e-01,& - & 8.823100e-01,1.188500e+00,1.003000e+00,6.967600e-01,4.194400e-01,& - & 1.204400e+00,1.623900e+00,1.386200e+00,9.729200e-01,5.173700e-01,& - & 1.597600e+00,2.164400e+00,1.873300e+00,1.332400e+00,6.338200e-01,& - & 3.744900e-01,5.089800e-01,4.233700e-01,2.878800e-01,2.407000e-01,& - & 5.527000e-01,7.503800e-01,6.283600e-01,4.289200e-01,2.975300e-01,& - & 7.890600e-01,1.072200e+00,9.020300e-01,6.217200e-01,3.669900e-01,& - & 1.092800e+00,1.482400e+00,1.259100e+00,8.775000e-01,4.548600e-01,& - & 1.467000e+00,1.993100e+00,1.716500e+00,1.213000e+00,5.605100e-01,& - & 3.153500e-01,4.348100e-01,3.605700e-01,2.436700e-01,2.082500e-01,& - & 4.750300e-01,6.526200e-01,5.449400e-01,3.694300e-01,2.584100e-01,& - & 6.911900e-01,9.473300e-01,7.947500e-01,5.432400e-01,3.195200e-01,& - & 9.728300e-01,1.327900e+00,1.122300e+00,7.767400e-01,3.965200e-01,& - & 1.324300e+00,1.805000e+00,1.545000e+00,1.084900e+00,4.908700e-01,& - & 2.617400e-01,3.659000e-01,3.026300e-01,2.034400e-01,1.793800e-01,& - & 4.027700e-01,5.605600e-01,4.666200e-01,3.144200e-01,2.233800e-01,& - & 5.977700e-01,8.270400e-01,6.919000e-01,4.696100e-01,2.769700e-01,& - & 8.558400e-01,1.177000e+00,9.905900e-01,6.804100e-01,3.432300e-01,& - & 1.183900e+00,1.618900e+00,1.377900e+00,9.603700e-01,4.259700e-01,& - & 2.165100e-01,3.062300e-01,2.530300e-01,1.690900e-01,1.528600e-01,& - & 3.399800e-01,4.794400e-01,3.979900e-01,2.666500e-01,1.913800e-01,& - & 5.150500e-01,7.191500e-01,6.004700e-01,4.050100e-01,2.380400e-01,& - & 7.506900e-01,1.039200e+00,8.723300e-01,5.947700e-01,2.947200e-01,& - & 1.054600e+00,1.448200e+00,1.226500e+00,8.485300e-01,3.658900e-01,& - & 1.766300e-01,2.519800e-01,2.082100e-01,1.385200e-01,1.292000e-01,& - & 2.831200e-01,4.039200e-01,3.345400e-01,2.229700e-01,1.631500e-01,& - & 4.378700e-01,6.174600e-01,5.142100e-01,3.450600e-01,2.032900e-01,& - & 6.504000e-01,9.065800e-01,7.588900e-01,5.140800e-01,2.518800e-01,& - & 9.287800e-01,1.282100e+00,1.080800e+00,7.427400e-01,3.124000e-01,& - & 1.404400e-01,2.012800e-01,1.662100e-01,1.105100e-01,1.089700e-01,& - & 2.300400e-01,3.315400e-01,2.741900e-01,1.818000e-01,1.396200e-01,& - & 3.632500e-01,5.182100e-01,4.303400e-01,2.872800e-01,1.743100e-01,& - & 5.511700e-01,7.748300e-01,6.467300e-01,4.355400e-01,2.165400e-01,& - & 8.020000e-01,1.113900e+00,9.356100e-01,6.379900e-01,2.678200e-01,& - & 1.110100e-01,1.592700e-01,1.313900e-01,8.752700e-02,9.020100e-02,& - & 1.856700e-01,2.696800e-01,2.227000e-01,1.471000e-01,1.176400e-01,& - & 2.993300e-01,4.315900e-01,3.575300e-01,2.373000e-01,1.481100e-01,& - & 4.636900e-01,6.579700e-01,5.478900e-01,3.670600e-01,1.840200e-01,& - & 6.880700e-01,9.621400e-01,8.057700e-01,5.457000e-01,2.276100e-01/ - data absb(901:1175,13) / & - & 8.695200e-02,1.248100e-01,1.027000e-01,6.873500e-02,7.291600e-02,& - & 1.488600e-01,2.171800e-01,1.793400e-01,1.182900e-01,9.683000e-02,& - & 2.450700e-01,3.565700e-01,2.949600e-01,1.948100e-01,1.238400e-01,& - & 3.872200e-01,5.551800e-01,4.610900e-01,3.074400e-01,1.541300e-01,& - & 5.863100e-01,8.260200e-01,6.896800e-01,4.644000e-01,1.905800e-01,& - & 6.842300e-02,9.836200e-02,8.081300e-02,5.431800e-02,6.064000e-02,& - & 1.202400e-01,1.756000e-01,1.448700e-01,9.571300e-02,8.209400e-02,& - & 2.018800e-01,2.956100e-01,2.441800e-01,1.607200e-01,1.066200e-01,& - & 3.248500e-01,4.702000e-01,3.894500e-01,2.584300e-01,1.337700e-01,& - & 5.011600e-01,7.118500e-01,5.928400e-01,3.973400e-01,1.654700e-01,& - & 5.372800e-02,7.747500e-02,6.357500e-02,4.281200e-02,5.093300e-02,& - & 9.703500e-02,1.417600e-01,1.167000e-01,7.731300e-02,7.036100e-02,& - & 1.661800e-01,2.444700e-01,2.018000e-01,1.325500e-01,9.283000e-02,& - & 2.724100e-01,3.973300e-01,3.286100e-01,2.170200e-01,1.179900e-01,& - & 4.278400e-01,6.127700e-01,5.090800e-01,3.398400e-01,1.464100e-01,& - & 4.180200e-02,6.050200e-02,4.969700e-02,3.350400e-02,4.202300e-02,& - & 7.772200e-02,1.135400e-01,9.325100e-02,6.206100e-02,5.935100e-02,& - & 1.360800e-01,2.005700e-01,1.655700e-01,1.087300e-01,7.964500e-02,& - & 2.273000e-01,3.335300e-01,2.757100e-01,1.813100e-01,1.028000e-01,& - & 3.629900e-01,5.246200e-01,4.348700e-01,2.890500e-01,1.285900e-01,& - & 3.218300e-02,4.668000e-02,3.848100e-02,2.604200e-02,3.375600e-02,& - & 6.172800e-02,9.013300e-02,7.397300e-02,4.938100e-02,4.899300e-02,& - & 1.107700e-01,1.631900e-01,1.345400e-01,8.855500e-02,6.705600e-02,& - & 1.884400e-01,2.778500e-01,2.293600e-01,1.504200e-01,8.793400e-02,& - & 3.061900e-01,4.460500e-01,3.689700e-01,2.441000e-01,1.112000e-01,& - & 2.504700e-02,3.640000e-02,3.015300e-02,2.050200e-02,2.903800e-02,& - & 4.950900e-02,7.246300e-02,5.942800e-02,3.971300e-02,4.329600e-02,& - & 9.104700e-02,1.340800e-01,1.103200e-01,7.281100e-02,6.035200e-02,& - & 1.577300e-01,2.332200e-01,1.925600e-01,1.261000e-01,8.024700e-02,& - & 2.606400e-01,3.819500e-01,3.156700e-01,2.079800e-01,1.026800e-01,& - & 1.953100e-02,2.840900e-02,2.365400e-02,1.616900e-02,2.601600e-02,& - & 3.973100e-02,5.830000e-02,4.786400e-02,3.204600e-02,3.989100e-02,& - & 7.501100e-02,1.103500e-01,9.060900e-02,6.002500e-02,5.669100e-02,& - & 1.323900e-01,1.959900e-01,1.617800e-01,1.059700e-01,7.643000e-02,& - & 2.223200e-01,3.273700e-01,2.705300e-01,1.775600e-01,9.905200e-02,& - & 1.508500e-02,2.199100e-02,1.838500e-02,1.262900e-02,2.321000e-02,& - & 3.164000e-02,4.651900e-02,3.829300e-02,2.574100e-02,3.655400e-02,& - & 6.140100e-02,9.025200e-02,7.404400e-02,4.917500e-02,5.316800e-02,& - & 1.106900e-01,1.637100e-01,1.350200e-01,8.864700e-02,7.286300e-02,& - & 1.888200e-01,2.790500e-01,2.304200e-01,1.508800e-01,9.553200e-02,& - & 1.149700e-02,1.686100e-02,1.416700e-02,9.743300e-03,2.053500e-02,& - & 2.498200e-02,3.676700e-02,3.040500e-02,2.053900e-02,3.338100e-02,& - & 4.986300e-02,7.340800e-02,6.017200e-02,4.001800e-02,4.985300e-02,& - & 9.197300e-02,1.359200e-01,1.118800e-01,7.364400e-02,6.936800e-02,& - & 1.595600e-01,2.363300e-01,1.952000e-01,1.276500e-01,9.214300e-02,& - & 8.755700e-03,1.298700e-02,1.095700e-02,7.530000e-03,1.843700e-02,& - & 1.982200e-02,2.915300e-02,2.423500e-02,1.646000e-02,3.105200e-02,& - & 4.061500e-02,5.990400e-02,4.913400e-02,3.275200e-02,4.755300e-02,& - & 7.674900e-02,1.132600e-01,9.303300e-02,6.144600e-02,6.732700e-02,& - & 1.353800e-01,2.008100e-01,1.658300e-01,1.084600e-01,9.054000e-02,& - & 7.783400e-03,1.163500e-02,9.823700e-03,6.734600e-03,2.056700e-02,& - & 1.796800e-02,2.645600e-02,2.202800e-02,1.498800e-02,3.530000e-02,& - & 3.727500e-02,5.502600e-02,4.516300e-02,3.013200e-02,5.458700e-02,& - & 7.118700e-02,1.050200e-01,8.620100e-02,5.699800e-02,7.796500e-02,& - & 1.265200e-01,1.876900e-01,1.549600e-01,1.014200e-01,1.051600e-01/ - data absb(1:300,14) / & - & 2.252400e+00,1.864200e+00,1.461300e+00,1.456900e+00,8.760100e+00,& - & 3.133100e+00,2.601700e+00,2.076500e+00,2.110800e+00,8.683700e+00,& - & 4.216100e+00,3.497500e+00,2.833200e+00,2.940000e+00,8.596700e+00,& - & 5.474200e+00,4.532600e+00,3.717600e+00,3.946100e+00,8.550900e+00,& - & 6.879400e+00,5.674200e+00,4.718000e+00,5.120100e+00,8.733200e+00,& - & 2.430000e+00,2.009900e+00,1.603900e+00,1.595100e+00,7.999800e+00,& - & 3.367100e+00,2.780900e+00,2.272200e+00,2.286100e+00,7.939900e+00,& - & 4.509800e+00,3.724900e+00,3.105800e+00,3.147900e+00,7.939600e+00,& - & 5.847900e+00,4.832700e+00,4.084800e+00,4.174800e+00,8.020400e+00,& - & 7.348500e+00,6.086700e+00,5.184500e+00,5.350500e+00,8.476500e+00,& - & 2.656800e+00,2.179600e+00,1.785400e+00,1.735200e+00,6.706000e+00,& - & 3.682200e+00,3.019200e+00,2.511800e+00,2.466000e+00,6.763200e+00,& - & 4.914500e+00,4.041900e+00,3.419700e+00,3.362500e+00,6.934400e+00,& - & 6.353600e+00,5.254000e+00,4.491000e+00,4.410700e+00,7.273400e+00,& - & 7.975100e+00,6.637600e+00,5.712700e+00,5.603600e+00,8.165300e+00,& - & 2.942700e+00,2.401900e+00,1.991800e+00,1.880700e+00,5.489000e+00,& - & 4.075500e+00,3.333400e+00,2.794100e+00,2.649700e+00,5.726700e+00,& - & 5.418300e+00,4.458700e+00,3.784800e+00,3.578600e+00,6.075100e+00,& - & 6.984900e+00,5.789500e+00,4.953300e+00,4.668800e+00,6.871200e+00,& - & 8.745300e+00,7.319200e+00,6.303100e+00,5.918500e+00,8.045100e+00,& - & 3.275000e+00,2.672600e+00,2.237800e+00,2.030100e+00,4.764000e+00,& - & 4.533000e+00,3.708900e+00,3.128300e+00,2.837400e+00,5.128100e+00,& - & 6.012600e+00,4.950700e+00,4.210900e+00,3.804600e+00,5.751300e+00,& - & 7.713500e+00,6.416900e+00,5.492100e+00,4.933700e+00,6.713500e+00,& - & 9.633800e+00,8.104700e+00,6.959900e+00,6.236600e+00,8.005800e+00,& - & 3.647200e+00,2.980700e+00,2.518900e+00,2.179600e+00,4.433400e+00,& - & 5.032300e+00,4.136700e+00,3.497900e+00,3.024700e+00,4.909600e+00,& - & 6.645400e+00,5.514400e+00,4.685800e+00,4.038100e+00,5.660800e+00,& - & 8.489000e+00,7.126400e+00,6.080300e+00,5.219900e+00,6.692500e+00,& - & 1.054200e+01,8.958600e+00,7.660100e+00,6.557500e+00,7.998800e+00,& - & 4.027400e+00,3.323300e+00,2.822700e+00,2.326100e+00,4.297500e+00,& - & 5.520400e+00,4.599200e+00,3.896100e+00,3.208900e+00,4.840800e+00,& - & 7.264100e+00,6.109000e+00,5.184700e+00,4.271000e+00,5.634800e+00,& - & 9.224100e+00,7.854300e+00,6.683700e+00,5.515500e+00,6.691200e+00,& - & 1.140300e+01,9.803400e+00,8.382000e+00,6.904800e+00,7.967000e+00,& - & 4.404200e+00,3.692300e+00,3.156400e+00,2.500900e+00,4.338600e+00,& - & 6.005600e+00,5.081500e+00,4.330500e+00,3.432800e+00,4.892000e+00,& - & 7.855100e+00,6.716400e+00,5.713600e+00,4.551200e+00,5.665800e+00,& - & 9.923900e+00,8.570300e+00,7.321500e+00,5.850400e+00,6.681800e+00,& - & 1.219700e+01,1.063900e+01,9.129900e+00,7.313400e+00,7.925500e+00,& - & 4.747900e+00,4.050800e+00,3.498300e+00,2.695500e+00,4.401000e+00,& - & 6.435500e+00,5.539900e+00,4.767800e+00,3.682000e+00,4.944600e+00,& - & 8.366300e+00,7.275100e+00,6.251800e+00,4.857200e+00,5.675700e+00,& - & 1.051200e+01,9.231400e+00,7.952600e+00,6.214100e+00,6.628800e+00,& - & 1.285600e+01,1.139600e+01,9.865900e+00,7.756100e+00,7.827700e+00,& - & 5.142000e+00,4.482300e+00,3.909600e+00,2.952700e+00,4.401300e+00,& - & 6.900600e+00,6.070500e+00,5.280600e+00,4.002500e+00,4.952800e+00,& - & 8.898300e+00,7.901300e+00,6.867800e+00,5.240200e+00,5.674800e+00,& - & 1.111600e+01,9.947000e+00,8.669800e+00,6.667400e+00,6.599400e+00,& - & 1.350200e+01,1.220200e+01,1.068600e+01,8.285300e+00,7.751700e+00,& - & 5.471300e+00,4.891100e+00,4.307200e+00,3.213900e+00,4.381300e+00,& - & 7.275100e+00,6.563800e+00,5.766400e+00,4.325000e+00,4.955500e+00,& - & 9.323000e+00,8.473500e+00,7.445500e+00,5.621200e+00,5.678300e+00,& - & 1.156400e+01,1.059900e+01,9.342800e+00,7.104900e+00,6.582500e+00,& - & 1.397400e+01,1.291000e+01,1.143900e+01,8.785700e+00,7.686500e+00,& - & 5.735000e+00,5.271200e+00,4.680100e+00,3.477400e+00,4.307800e+00,& - & 7.569500e+00,7.006700e+00,6.218900e+00,4.644400e+00,4.909700e+00,& - & 9.627900e+00,8.984500e+00,7.982200e+00,5.995400e+00,5.651400e+00,& - & 1.187800e+01,1.116000e+01,9.953300e+00,7.536600e+00,6.553200e+00,& - & 1.428500e+01,1.351400e+01,1.212600e+01,9.266500e+00,7.671500e+00/ - data absb(301:600,14) / & - & 5.926700e+00,5.618700e+00,5.028000e+00,3.738700e+00,4.297200e+00,& - & 7.764200e+00,7.407700e+00,6.634700e+00,4.955500e+00,4.930900e+00,& - & 9.818700e+00,9.427700e+00,8.472000e+00,6.364800e+00,5.693400e+00,& - & 1.205900e+01,1.164400e+01,1.051500e+01,7.952500e+00,6.618600e+00,& - & 1.446300e+01,1.404000e+01,1.275200e+01,9.743200e+00,7.771400e+00,& - & 6.067300e+00,5.944900e+00,5.365500e+00,4.005800e+00,4.368400e+00,& - & 7.888400e+00,7.777600e+00,7.035900e+00,5.275100e+00,5.044600e+00,& - & 9.923800e+00,9.829300e+00,8.938100e+00,6.735200e+00,5.834900e+00,& - & 1.215000e+01,1.208600e+01,1.104700e+01,8.379200e+00,6.801100e+00,& - & 1.453500e+01,1.452700e+01,1.335300e+01,1.023600e+01,7.978900e+00,& - & 6.134300e+00,6.230200e+00,5.676300e+00,4.252500e+00,4.379900e+00,& - & 7.933100e+00,8.086900e+00,7.403200e+00,5.568900e+00,5.101200e+00,& - & 9.949200e+00,1.017200e+01,9.362200e+00,7.077900e+00,5.941100e+00,& - & 1.215100e+01,1.246700e+01,1.152900e+01,8.786100e+00,6.949500e+00,& - & 1.452900e+01,1.494400e+01,1.391400e+01,1.072700e+01,8.141700e+00,& - & 6.145300e+00,6.476300e+00,5.963700e+00,4.484100e+00,4.335700e+00,& - & 7.921700e+00,8.359900e+00,7.743000e+00,5.838100e+00,5.095700e+00,& - & 9.908900e+00,1.047400e+01,9.752100e+00,7.403100e+00,5.993900e+00,& - & 1.210300e+01,1.280200e+01,1.198300e+01,9.176500e+00,7.038000e+00,& - & 1.448400e+01,1.531500e+01,1.445000e+01,1.120500e+01,8.256000e+00,& - & 6.134400e+00,6.710300e+00,6.246800e+00,4.709400e+00,4.206000e+00,& - & 7.887300e+00,8.621700e+00,8.078100e+00,6.110800e+00,4.977100e+00,& - & 9.865800e+00,1.077100e+01,1.014600e+01,7.733800e+00,5.885100e+00,& - & 1.205900e+01,1.313300e+01,1.244500e+01,9.578700e+00,6.930800e+00,& - & 1.444000e+01,1.570000e+01,1.500200e+01,1.170200e+01,8.165800e+00,& - & 6.107400e+00,6.934000e+00,6.526600e+00,4.932700e+00,4.009600e+00,& - & 7.850100e+00,8.883100e+00,8.408800e+00,6.389400e+00,4.786800e+00,& - & 9.832100e+00,1.106800e+01,1.054100e+01,8.066300e+00,5.684500e+00,& - & 1.202900e+01,1.347600e+01,1.291700e+01,9.990300e+00,6.731200e+00,& - & 1.441900e+01,1.610900e+01,1.557300e+01,1.220900e+01,7.975400e+00,& - & 6.098600e+00,7.172200e+00,6.820000e+00,5.175500e+00,3.716300e+00,& - & 7.845000e+00,9.161900e+00,8.762000e+00,6.685800e+00,4.461900e+00,& - & 9.834000e+00,1.139300e+01,1.096900e+01,8.427900e+00,5.331600e+00,& - & 1.204300e+01,1.386400e+01,1.342900e+01,1.044000e+01,6.368600e+00,& - & 1.446100e+01,1.657100e+01,1.618500e+01,1.275100e+01,7.631500e+00,& - & 6.126600e+00,7.438400e+00,7.135000e+00,5.438400e+00,3.436400e+00,& - & 7.884300e+00,9.473300e+00,9.148100e+00,7.006500e+00,4.150800e+00,& - & 9.890800e+00,1.176500e+01,1.143600e+01,8.818900e+00,5.005700e+00,& - & 1.213200e+01,1.430600e+01,1.398900e+01,1.092600e+01,6.048000e+00,& - & 1.459100e+01,1.709500e+01,1.684500e+01,1.333200e+01,7.337300e+00,& - & 6.192800e+00,7.731000e+00,7.480400e+00,5.725100e+00,3.157100e+00,& - & 7.974700e+00,9.826900e+00,9.573100e+00,7.356300e+00,3.854700e+00,& - & 1.001600e+01,1.218700e+01,1.194000e+01,9.248100e+00,4.704900e+00,& - & 1.229600e+01,1.480400e+01,1.459000e+01,1.145300e+01,5.773600e+00,& - & 1.481300e+01,1.767000e+01,1.755200e+01,1.395100e+01,7.099500e+00,& - & 6.242400e+00,7.989700e+00,7.791000e+00,5.983600e+00,2.961100e+00,& - & 8.055000e+00,1.014300e+01,9.952800e+00,7.672400e+00,3.656800e+00,& - & 1.012900e+01,1.256900e+01,1.239900e+01,9.637500e+00,4.513700e+00,& - & 1.245500e+01,1.525100e+01,1.513500e+01,1.192800e+01,5.606700e+00,& - & 1.502400e+01,1.819000e+01,1.819300e+01,1.450900e+01,6.972600e+00,& - & 6.178300e+00,8.086800e+00,7.935400e+00,6.109700e+00,2.738600e+00,& - & 8.002100e+00,1.027400e+01,1.014300e+01,7.834200e+00,3.423100e+00,& - & 1.009300e+01,1.274100e+01,1.263800e+01,9.846400e+00,4.281700e+00,& - & 1.244800e+01,1.546600e+01,1.543000e+01,1.219000e+01,5.383800e+00,& - & 1.505000e+01,1.845300e+01,1.855300e+01,1.483000e+01,6.779500e+00,& - & 5.973900e+00,7.987900e+00,7.876200e+00,6.073600e+00,2.496600e+00,& - & 7.783700e+00,1.018000e+01,1.009700e+01,7.807200e+00,3.160600e+00,& - & 9.872300e+00,1.265800e+01,1.260700e+01,9.833000e+00,4.002900e+00,& - & 1.222900e+01,1.539600e+01,1.541800e+01,1.219400e+01,5.091700e+00,& - & 1.483400e+01,1.840300e+01,1.857000e+01,1.485700e+01,6.486300e+00/ - data absb(601:900,14) / & - & 5.561200e+00,7.603700e+00,7.521700e+00,5.804900e+00,2.243300e+00,& - & 7.317900e+00,9.757100e+00,9.706300e+00,7.507400e+00,2.864600e+00,& - & 9.360200e+00,1.220300e+01,1.218800e+01,9.500100e+00,3.660800e+00,& - & 1.168100e+01,1.491600e+01,1.496700e+01,1.182500e+01,4.700500e+00,& - & 1.425900e+01,1.789700e+01,1.808900e+01,1.446100e+01,6.047500e+00,& - & 5.179600e+00,7.227500e+00,7.168100e+00,5.536200e+00,1.998500e+00,& - & 6.882500e+00,9.340100e+00,9.311600e+00,7.205000e+00,2.578600e+00,& - & 8.877000e+00,1.174800e+01,1.175900e+01,9.158300e+00,3.330400e+00,& - & 1.116100e+01,1.443000e+01,1.450800e+01,1.144300e+01,4.322500e+00,& - & 1.370600e+01,1.738200e+01,1.759100e+01,1.404900e+01,5.618300e+00,& - & 4.836300e+00,6.876200e+00,6.834400e+00,5.280100e+00,1.762300e+00,& - & 6.487400e+00,8.947900e+00,8.933900e+00,6.917600e+00,2.303500e+00,& - & 8.436700e+00,1.131500e+01,1.134600e+01,8.833100e+00,3.015700e+00,& - & 1.068000e+01,1.396500e+01,1.406200e+01,1.107700e+01,3.961900e+00,& - & 1.319000e+01,1.688700e+01,1.710500e+01,1.364600e+01,5.210300e+00,& - & 4.379300e+00,6.355700e+00,6.325800e+00,4.886400e+00,1.565800e+00,& - & 5.949800e+00,8.353500e+00,8.346400e+00,6.465800e+00,2.060400e+00,& - & 7.823200e+00,1.064800e+01,1.068900e+01,8.311100e+00,2.719200e+00,& - & 9.994100e+00,1.323600e+01,1.333800e+01,1.047700e+01,3.593600e+00,& - & 1.244100e+01,1.609800e+01,1.630400e+01,1.297600e+01,4.760800e+00,& - & 3.945600e+00,5.842000e+00,5.823100e+00,4.496000e+00,1.388900e+00,& - & 5.432200e+00,7.760100e+00,7.759700e+00,6.012400e+00,1.837700e+00,& - & 7.222900e+00,9.980400e+00,1.002400e+01,7.785100e+00,2.443200e+00,& - & 9.315100e+00,1.249600e+01,1.259800e+01,9.869400e+00,3.250300e+00,& - & 1.169600e+01,1.529400e+01,1.548900e+01,1.229000e+01,4.331500e+00,& - & 3.549600e+00,5.359800e+00,5.349700e+00,4.126300e+00,1.223000e+00,& - & 4.955200e+00,7.195700e+00,7.198100e+00,5.577100e+00,1.630800e+00,& - & 6.662400e+00,9.337400e+00,9.381900e+00,7.283000e+00,2.185000e+00,& - & 8.675500e+00,1.178100e+01,1.188200e+01,9.283300e+00,2.929500e+00,& - & 1.098400e+01,1.451200e+01,1.469400e+01,1.162400e+01,3.928700e+00,& - & 3.123700e+00,4.816400e+00,4.812900e+00,3.705500e+00,1.059700e+00,& - & 4.431000e+00,6.552400e+00,6.555500e+00,5.076900e+00,1.422000e+00,& - & 6.036300e+00,8.599300e+00,8.636900e+00,6.704000e+00,1.919000e+00,& - & 7.951500e+00,1.094900e+01,1.104100e+01,8.608200e+00,2.593700e+00,& - & 1.017000e+01,1.359400e+01,1.376100e+01,1.084600e+01,3.502400e+00,& - & 2.709400e+00,4.273800e+00,4.271500e+00,3.285100e+00,9.064200e-01,& - & 3.914800e+00,5.901900e+00,5.908300e+00,4.570800e+00,1.223800e+00,& - & 5.414600e+00,7.844100e+00,7.876200e+00,6.112400e+00,1.663200e+00,& - & 7.221200e+00,1.009300e+01,1.017200e+01,7.916200e+00,2.268500e+00,& - & 9.338300e+00,1.264000e+01,1.279000e+01,1.003900e+01,3.087700e+00,& - & 2.338100e+00,3.770800e+00,3.768700e+00,2.896800e+00,7.666100e-01,& - & 3.443900e+00,5.295600e+00,5.303900e+00,4.095800e+00,1.040500e+00,& - & 4.837500e+00,7.129600e+00,7.154700e+00,5.551000e+00,1.428900e+00,& - & 6.536600e+00,9.274200e+00,9.340900e+00,7.262000e+00,1.968400e+00,& - & 8.549200e+00,1.172300e+01,1.185500e+01,9.271500e+00,2.707600e+00,& - & 1.986800e+00,3.281200e+00,3.280000e+00,2.519000e+00,6.418000e-01,& - & 2.989600e+00,4.695900e+00,4.702800e+00,3.624400e+00,8.733800e-01,& - & 4.274300e+00,6.414500e+00,6.435100e+00,4.986600e+00,1.211500e+00,& - & 5.859200e+00,8.447500e+00,8.503700e+00,6.605900e+00,1.686900e+00,& - & 7.756500e+00,1.078900e+01,1.090000e+01,8.503900e+00,2.346600e+00,& - & 1.643900e+00,2.787200e+00,2.785300e+00,2.136100e+00,5.360800e-01,& - & 2.533200e+00,4.076100e+00,4.080800e+00,3.141700e+00,7.268900e-01,& - & 3.700400e+00,5.668200e+00,5.687200e+00,4.400200e+00,1.014200e+00,& - & 5.160300e+00,7.576300e+00,7.619400e+00,5.917200e+00,1.423600e+00,& - & 6.929400e+00,9.795100e+00,9.884600e+00,7.695400e+00,2.000600e+00,& - & 1.345400e+00,2.344100e+00,2.343500e+00,1.793400e+00,4.433200e-01,& - & 2.128900e+00,3.509000e+00,3.513000e+00,2.701700e+00,5.990600e-01,& - & 3.181000e+00,4.980800e+00,4.995500e+00,3.856200e+00,8.368100e-01,& - & 4.516800e+00,6.758300e+00,6.789700e+00,5.267900e+00,1.189800e+00,& - & 6.158900e+00,8.851900e+00,8.924000e+00,6.939200e+00,1.689400e+00/ - data absb(901:1175,14) / & - & 1.088000e+00,1.952000e+00,1.949200e+00,1.489200e+00,3.620500e-01,& - & 1.773000e+00,2.996500e+00,2.999300e+00,2.302600e+00,4.869600e-01,& - & 2.710800e+00,4.343100e+00,4.355000e+00,3.355500e+00,6.799300e-01,& - & 3.929700e+00,5.993900e+00,6.020500e+00,4.663800e+00,9.789200e-01,& - & 5.445600e+00,7.962300e+00,8.019700e+00,6.231600e+00,1.409700e+00,& - & 8.811700e-01,1.625000e+00,1.622100e+00,1.238300e+00,3.085100e-01,& - & 1.479200e+00,2.561400e+00,2.564000e+00,1.964900e+00,4.103300e-01,& - & 2.315300e+00,3.791100e+00,3.799800e+00,2.925300e+00,5.691100e-01,& - & 3.425500e+00,5.327000e+00,5.349800e+00,4.136900e+00,8.202800e-01,& - & 4.824900e+00,7.174800e+00,7.218900e+00,5.606800e+00,1.194600e+00,& - & 7.105600e-01,1.344200e+00,1.343300e+00,1.024100e+00,2.696900e-01,& - & 1.228500e+00,2.182500e+00,2.183600e+00,1.670100e+00,3.535200e-01,& - & 1.971900e+00,3.300900e+00,3.307500e+00,2.543100e+00,4.846300e-01,& - & 2.978700e+00,4.725400e+00,4.742900e+00,3.659800e+00,6.943000e-01,& - & 4.268800e+00,6.456000e+00,6.490500e+00,5.034500e+00,1.018600e+00,& - & 5.667300e-01,1.099300e+00,1.100200e+00,8.363900e-01,2.358700e-01,& - & 1.010900e+00,1.843100e+00,1.842000e+00,1.407300e+00,3.043500e-01,& - & 1.667200e+00,2.853200e+00,2.858900e+00,2.194500e+00,4.117200e-01,& - & 2.571800e+00,4.165300e+00,4.178500e+00,3.220100e+00,5.848400e-01,& - & 3.756000e+00,5.781400e+00,5.811100e+00,4.500500e+00,8.610300e-01,& - & 4.469500e-01,8.884600e-01,8.900100e-01,6.729000e-01,2.045600e-01,& - & 8.229300e-01,1.538700e+00,1.537700e+00,1.173700e+00,2.621400e-01,& - & 1.396100e+00,2.446700e+00,2.451200e+00,1.877800e+00,3.483200e-01,& - & 2.204200e+00,3.645900e+00,3.655600e+00,2.814100e+00,4.901400e-01,& - & 3.285000e+00,5.151100e+00,5.174900e+00,4.000600e+00,7.213900e-01,& - & 3.554200e-01,7.224300e-01,7.240200e-01,5.444200e-01,1.882200e-01,& - & 6.747600e-01,1.290600e+00,1.291400e+00,9.842900e-01,2.421100e-01,& - & 1.176700e+00,2.110500e+00,2.112000e+00,1.615900e+00,3.143600e-01,& - & 1.901400e+00,3.207400e+00,3.216000e+00,2.472500e+00,4.338400e-01,& - & 2.887100e+00,4.610900e+00,4.630200e+00,3.572400e+00,6.297800e-01,& - & 2.820600e-01,5.856100e-01,5.863100e-01,4.388100e-01,1.795600e-01,& - & 5.528500e-01,1.080500e+00,1.082400e+00,8.227900e-01,2.317000e-01,& - & 9.908000e-01,1.817100e+00,1.817400e+00,1.388800e+00,2.965100e-01,& - & 1.639700e+00,2.820700e+00,2.826900e+00,2.170000e+00,3.992700e-01,& - & 2.536400e+00,4.124600e+00,4.139000e+00,3.190100e+00,5.667600e-01,& - & 2.214900e-01,4.688800e-01,4.679300e-01,3.493100e-01,1.715300e-01,& - & 4.494100e-01,8.970200e-01,8.991700e-01,6.803000e-01,2.221600e-01,& - & 8.276400e-01,1.552000e+00,1.551700e+00,1.184800e+00,2.840300e-01,& - & 1.404400e+00,2.465600e+00,2.471300e+00,1.893700e+00,3.724900e-01,& - & 2.216800e+00,3.670800e+00,3.682700e+00,2.835600e+00,5.165400e-01,& - & 1.721400e-01,3.707900e-01,3.682400e-01,2.742000e-01,1.633800e-01,& - & 3.617200e-01,7.371300e-01,7.392400e-01,5.563900e-01,2.137300e-01,& - & 6.857000e-01,1.313400e+00,1.314800e+00,1.002500e+00,2.745600e-01,& - & 1.194200e+00,2.142400e+00,2.145400e+00,1.641800e+00,3.531000e-01,& - & 1.926400e+00,3.250500e+00,3.260200e+00,2.507000e+00,4.775200e-01,& - & 1.344500e-01,2.928400e-01,2.890300e-01,2.148200e-01,1.577400e-01,& - & 2.913700e-01,6.056300e-01,6.066800e-01,4.544700e-01,2.092900e-01,& - & 5.690400e-01,1.112100e+00,1.114300e+00,8.476200e-01,2.700400e-01,& - & 1.016400e+00,1.862500e+00,1.863400e+00,1.424200e+00,3.451400e-01,& - & 1.677200e+00,2.881500e+00,2.888500e+00,2.218200e+00,4.556400e-01,& - & 1.213100e-01,2.651800e-01,2.608900e-01,1.939300e-01,1.744100e-01,& - & 2.662600e-01,5.578200e-01,5.585200e-01,4.178700e-01,2.346100e-01,& - & 5.265900e-01,1.037700e+00,1.040300e+00,7.902800e-01,3.063300e-01,& - & 9.506400e-01,1.756600e+00,1.757300e+00,1.342900e+00,3.967400e-01,& - & 1.583000e+00,2.740400e+00,2.747400e+00,2.108700e+00,5.202100e-01/ - data absb(1:300,15) / & - & 3.224400e+00,2.540900e+00,3.132800e+00,4.671200e+00,1.104800e+01,& - & 4.539800e+00,3.605700e+00,4.523700e+00,6.755400e+00,1.152300e+01,& - & 6.083700e+00,4.873200e+00,6.188700e+00,9.262200e+00,1.315400e+01,& - & 7.862800e+00,6.321700e+00,8.142200e+00,1.219600e+01,1.629600e+01,& - & 9.852500e+00,7.965300e+00,1.047200e+01,1.568600e+01,2.095900e+01,& - & 3.575500e+00,2.877900e+00,3.451900e+00,5.102800e+00,1.037300e+01,& - & 5.052400e+00,4.125000e+00,4.988300e+00,7.387800e+00,1.151300e+01,& - & 6.834600e+00,5.598400e+00,6.821200e+00,1.015100e+01,1.385500e+01,& - & 8.900000e+00,7.272300e+00,8.953700e+00,1.337900e+01,1.787100e+01,& - & 1.126500e+01,9.170100e+00,1.149700e+01,1.720600e+01,2.298100e+01,& - & 4.082400e+00,3.343500e+00,3.816400e+00,5.587000e+00,9.563700e+00,& - & 5.757700e+00,4.785000e+00,5.507600e+00,8.084200e+00,1.146100e+01,& - & 7.821300e+00,6.500700e+00,7.536200e+00,1.109700e+01,1.482600e+01,& - & 1.025600e+01,8.459300e+00,9.911400e+00,1.465500e+01,1.957200e+01,& - & 1.303200e+01,1.068700e+01,1.268400e+01,1.879300e+01,2.509900e+01,& - & 4.737200e+00,3.927000e+00,4.246300e+00,6.122100e+00,9.097600e+00,& - & 6.643600e+00,5.578700e+00,6.104500e+00,8.812600e+00,1.184300e+01,& - & 9.051700e+00,7.579700e+00,8.354200e+00,1.209200e+01,1.614700e+01,& - & 1.187900e+01,9.900800e+00,1.102300e+01,1.596000e+01,2.130900e+01,& - & 1.509300e+01,1.251900e+01,1.407800e+01,2.038700e+01,2.722100e+01,& - & 5.519700e+00,4.616000e+00,4.741800e+00,6.677300e+00,9.220500e+00,& - & 7.711900e+00,6.501900e+00,6.777400e+00,9.535800e+00,1.272700e+01,& - & 1.046700e+01,8.838800e+00,9.274200e+00,1.305800e+01,1.743000e+01,& - & 1.372000e+01,1.155300e+01,1.224400e+01,1.722700e+01,2.299800e+01,& - & 1.741300e+01,1.459400e+01,1.567300e+01,2.204700e+01,2.943300e+01,& - & 6.427400e+00,5.411100e+00,5.303400e+00,7.235000e+00,9.762200e+00,& - & 8.957300e+00,7.580700e+00,7.547900e+00,1.027300e+01,1.371000e+01,& - & 1.211100e+01,1.025800e+01,1.032100e+01,1.400600e+01,1.869600e+01,& - & 1.584500e+01,1.338600e+01,1.362200e+01,1.847000e+01,2.465000e+01,& - & 2.008400e+01,1.689000e+01,1.743400e+01,2.367300e+01,3.159900e+01,& - & 7.516400e+00,6.313400e+00,5.939500e+00,7.809300e+00,1.047500e+01,& - & 1.044100e+01,8.801400e+00,8.427800e+00,1.103500e+01,1.472900e+01,& - & 1.404300e+01,1.186100e+01,1.151300e+01,1.498800e+01,2.000400e+01,& - & 1.832200e+01,1.543300e+01,1.517700e+01,1.971500e+01,2.631800e+01,& - & 2.314600e+01,1.946600e+01,1.938400e+01,2.525500e+01,3.370900e+01,& - & 8.845500e+00,7.406600e+00,6.718600e+00,8.455800e+00,1.134300e+01,& - & 1.221900e+01,1.027500e+01,9.487100e+00,1.188200e+01,1.585800e+01,& - & 1.634600e+01,1.376300e+01,1.293100e+01,1.609500e+01,2.147900e+01,& - & 2.120600e+01,1.785500e+01,1.699000e+01,2.112700e+01,2.819800e+01,& - & 2.666100e+01,2.243500e+01,2.164000e+01,2.696900e+01,3.599500e+01,& - & 1.037800e+01,8.673100e+00,7.634000e+00,9.134900e+00,1.228100e+01,& - & 1.424600e+01,1.195900e+01,1.071200e+01,1.278000e+01,1.704000e+01,& - & 1.894000e+01,1.592900e+01,1.452800e+01,1.726500e+01,2.301800e+01,& - & 2.441600e+01,2.056300e+01,1.901900e+01,2.260200e+01,3.012400e+01,& - & 3.052300e+01,2.574700e+01,2.413500e+01,2.871200e+01,3.824800e+01,& - & 1.235500e+01,1.032400e+01,8.910300e+00,1.013200e+01,1.353200e+01,& - & 1.682700e+01,1.411000e+01,1.239700e+01,1.408500e+01,1.863500e+01,& - & 2.218000e+01,1.865300e+01,1.665900e+01,1.892100e+01,2.500300e+01,& - & 2.831100e+01,2.390500e+01,2.164100e+01,2.458400e+01,3.247200e+01,& - & 3.514900e+01,2.973800e+01,2.725000e+01,3.100400e+01,4.098700e+01,& - & 1.460500e+01,1.220500e+01,1.044500e+01,1.129100e+01,1.487100e+01,& - & 1.971600e+01,1.653900e+01,1.437600e+01,1.556600e+01,2.031000e+01,& - & 2.572600e+01,2.168300e+01,1.911500e+01,2.073600e+01,2.699500e+01,& - & 3.257200e+01,2.756600e+01,2.458100e+01,2.671600e+01,3.478600e+01,& - & 4.012300e+01,3.408000e+01,3.068600e+01,3.345700e+01,4.368600e+01,& - & 1.713400e+01,1.433000e+01,1.223700e+01,1.259200e+01,1.624100e+01,& - & 2.288200e+01,1.925200e+01,1.664200e+01,1.719300e+01,2.203500e+01,& - & 2.958400e+01,2.500500e+01,2.186600e+01,2.268200e+01,2.902300e+01,& - & 3.713000e+01,3.155600e+01,2.783600e+01,2.899000e+01,3.715400e+01,& - & 4.538800e+01,3.871300e+01,3.444600e+01,3.610400e+01,4.637700e+01/ - data absb(301:600,15) / & - & 1.992700e+01,1.670700e+01,1.428800e+01,1.405100e+01,1.769900e+01,& - & 2.634300e+01,2.221700e+01,1.918800e+01,1.897300e+01,2.381400e+01,& - & 3.372400e+01,2.862000e+01,2.489700e+01,2.476400e+01,3.110600e+01,& - & 4.195200e+01,3.579400e+01,3.137800e+01,3.144000e+01,3.957200e+01,& - & 5.089100e+01,4.358700e+01,3.847900e+01,3.887800e+01,4.903000e+01,& - & 2.302600e+01,1.936500e+01,1.661600e+01,1.569200e+01,1.932000e+01,& - & 3.012900e+01,2.549100e+01,2.203200e+01,2.094400e+01,2.572600e+01,& - & 3.818800e+01,3.253600e+01,2.826600e+01,2.708900e+01,3.335400e+01,& - & 4.707600e+01,4.031600e+01,3.523800e+01,3.411300e+01,4.210600e+01,& - & 5.669100e+01,4.870200e+01,4.282800e+01,4.189000e+01,5.186500e+01,& - & 2.631900e+01,2.220900e+01,1.910300e+01,1.747500e+01,2.104700e+01,& - & 3.407700e+01,2.896100e+01,2.504700e+01,2.306600e+01,2.774000e+01,& - & 4.276600e+01,3.659900e+01,3.179900e+01,2.954500e+01,3.562400e+01,& - & 5.231100e+01,4.494900e+01,3.925400e+01,3.688100e+01,4.462500e+01,& - & 6.253500e+01,5.390300e+01,4.727600e+01,4.495900e+01,5.474400e+01,& - & 2.973900e+01,2.521200e+01,2.172500e+01,1.937000e+01,2.282300e+01,& - & 3.811100e+01,3.255600e+01,2.817800e+01,2.531200e+01,2.980500e+01,& - & 4.744200e+01,4.075800e+01,3.544700e+01,3.213000e+01,3.795200e+01,& - & 5.758100e+01,4.963700e+01,4.335900e+01,3.978000e+01,4.724100e+01,& - & 6.835000e+01,5.911000e+01,5.179000e+01,4.813500e+01,5.771100e+01,& - & 3.328900e+01,2.837700e+01,2.448500e+01,2.142500e+01,2.462500e+01,& - & 4.227000e+01,3.627700e+01,3.144500e+01,2.769500e+01,3.189800e+01,& - & 5.220000e+01,4.500100e+01,3.916500e+01,3.483300e+01,4.033600e+01,& - & 6.288400e+01,5.437700e+01,4.752600e+01,4.279200e+01,4.997600e+01,& - & 7.415700e+01,6.431200e+01,5.634300e+01,5.143600e+01,6.084200e+01,& - & 3.692200e+01,3.163700e+01,2.733600e+01,2.356600e+01,2.643600e+01,& - & 4.648400e+01,4.004600e+01,3.476400e+01,3.014800e+01,3.400000e+01,& - & 5.694100e+01,4.923500e+01,4.290700e+01,3.760400e+01,4.276700e+01,& - & 6.811900e+01,5.907400e+01,5.166000e+01,4.584000e+01,5.277800e+01,& - & 7.981600e+01,6.939100e+01,6.079700e+01,5.474600e+01,6.407000e+01,& - & 4.064800e+01,3.498900e+01,3.027600e+01,2.579000e+01,2.825300e+01,& - & 5.073900e+01,4.386900e+01,3.813600e+01,3.269300e+01,3.617600e+01,& - & 6.169800e+01,5.349300e+01,4.666900e+01,4.045300e+01,4.532700e+01,& - & 7.330700e+01,6.372500e+01,5.576500e+01,4.894400e+01,5.574500e+01,& - & 8.537900e+01,7.438400e+01,6.518900e+01,5.811600e+01,6.743900e+01,& - & 4.443000e+01,3.838400e+01,3.327900e+01,2.809300e+01,3.019800e+01,& - & 5.501000e+01,4.771300e+01,4.152100e+01,3.530400e+01,3.848600e+01,& - & 6.640600e+01,5.771400e+01,5.040300e+01,4.334000e+01,4.801900e+01,& - & 7.839400e+01,6.829400e+01,5.980200e+01,5.209300e+01,5.886100e+01,& - & 9.078900e+01,7.924800e+01,6.949600e+01,6.152000e+01,7.097100e+01,& - & 4.824200e+01,4.181400e+01,3.631100e+01,3.044500e+01,3.226100e+01,& - & 5.925900e+01,5.153400e+01,4.489800e+01,3.795300e+01,4.093300e+01,& - & 7.104400e+01,6.187700e+01,5.409900e+01,4.624300e+01,5.086100e+01,& - & 8.338500e+01,7.275400e+01,6.373800e+01,5.522500e+01,6.207200e+01,& - & 9.601400e+01,8.396500e+01,7.366500e+01,6.493200e+01,7.466000e+01,& - & 5.167200e+01,4.490700e+01,3.905200e+01,3.255900e+01,3.415000e+01,& - & 6.306600e+01,5.494200e+01,4.793200e+01,4.032000e+01,4.313700e+01,& - & 7.518100e+01,6.558600e+01,5.737600e+01,4.884800e+01,5.341600e+01,& - & 8.778600e+01,7.671800e+01,6.723700e+01,5.802200e+01,6.498600e+01,& - & 1.006200e+02,8.812200e+01,7.732200e+01,6.797200e+01,7.796800e+01,& - & 5.397400e+01,4.701000e+01,4.091400e+01,3.395300e+01,3.528400e+01,& - & 6.563200e+01,5.726100e+01,4.998600e+01,4.188000e+01,4.447700e+01,& - & 7.798300e+01,6.810800e+01,5.960700e+01,5.055400e+01,5.496600e+01,& - & 9.077400e+01,7.942300e+01,6.961500e+01,5.985600e+01,6.674700e+01,& - & 1.037600e+02,9.095800e+01,7.982700e+01,6.995300e+01,7.997500e+01,& - & 5.495200e+01,4.792800e+01,4.172800e+01,3.448200e+01,3.549700e+01,& - & 6.674800e+01,5.830400e+01,5.090000e+01,4.246900e+01,4.474300e+01,& - & 7.923700e+01,6.926800e+01,6.063000e+01,5.120300e+01,5.529900e+01,& - & 9.216000e+01,8.069000e+01,7.074000e+01,6.056000e+01,6.715000e+01,& - & 1.052700e+02,9.234700e+01,8.103300e+01,7.069100e+01,8.044500e+01/ - data absb(601:900,15) / & - & 5.407700e+01,4.720300e+01,4.109000e+01,3.381600e+01,3.440200e+01,& - & 6.587100e+01,5.758100e+01,5.025600e+01,4.173000e+01,4.350400e+01,& - & 7.839400e+01,6.856400e+01,6.000300e+01,5.040600e+01,5.391900e+01,& - & 9.137300e+01,8.002400e+01,7.015500e+01,5.971100e+01,6.563000e+01,& - & 1.045700e+02,9.174300e+01,8.050200e+01,6.976900e+01,7.876400e+01,& - & 5.299800e+01,4.629200e+01,4.028400e+01,3.304700e+01,3.325600e+01,& - & 6.475800e+01,5.664600e+01,4.943000e+01,4.086700e+01,4.219300e+01,& - & 7.728600e+01,6.762800e+01,5.917000e+01,4.948100e+01,5.244700e+01,& - & 9.029500e+01,7.910100e+01,6.933900e+01,5.872700e+01,6.400200e+01,& - & 1.035500e+02,9.087800e+01,7.973300e+01,6.869500e+01,7.696400e+01,& - & 5.183800e+01,4.530900e+01,3.941400e+01,3.225300e+01,3.213300e+01,& - & 6.355000e+01,5.562200e+01,4.852700e+01,3.997200e+01,4.090500e+01,& - & 7.605600e+01,6.659100e+01,5.824300e+01,4.850400e+01,5.098700e+01,& - & 8.907500e+01,7.805500e+01,6.842200e+01,5.768400e+01,6.238600e+01,& - & 1.023900e+02,8.986700e+01,7.883700e+01,6.757600e+01,7.517200e+01,& - & 4.947100e+01,4.324600e+01,3.759100e+01,3.069800e+01,3.021800e+01,& - & 6.103200e+01,5.343100e+01,4.659400e+01,3.822900e+01,3.870200e+01,& - & 7.341700e+01,6.430900e+01,5.622300e+01,4.659100e+01,4.845500e+01,& - & 8.639800e+01,7.572100e+01,6.634000e+01,5.565500e+01,5.956700e+01,& - & 9.972500e+01,8.749300e+01,7.675400e+01,6.536600e+01,7.201000e+01,& - & 4.694000e+01,4.102900e+01,3.564600e+01,2.905400e+01,2.825200e+01,& - & 5.830300e+01,5.106100e+01,4.448800e+01,3.638200e+01,3.642900e+01,& - & 7.054500e+01,6.180900e+01,5.401400e+01,4.456900e+01,4.586600e+01,& - & 8.344600e+01,7.314000e+01,6.405300e+01,5.348900e+01,5.665300e+01,& - & 9.676200e+01,8.489000e+01,7.445300e+01,6.302800e+01,6.876200e+01,& - & 4.440000e+01,3.880800e+01,3.369500e+01,2.743300e+01,2.636700e+01,& - & 5.554800e+01,4.865300e+01,4.237000e+01,3.455800e+01,3.423100e+01,& - & 6.763900e+01,5.926400e+01,5.176500e+01,4.254800e+01,4.334500e+01,& - & 8.042200e+01,7.050500e+01,6.170800e+01,5.130900e+01,5.380200e+01,& - & 9.369000e+01,8.218700e+01,7.207100e+01,6.069200e+01,6.558200e+01,& - & 4.129900e+01,3.608600e+01,3.130300e+01,2.548100e+01,2.416800e+01,& - & 5.214600e+01,4.566800e+01,3.973300e+01,3.234900e+01,3.165700e+01,& - & 6.399700e+01,5.610400e+01,4.894800e+01,4.007800e+01,4.038200e+01,& - & 7.662100e+01,6.718800e+01,5.877300e+01,4.861700e+01,5.040700e+01,& - & 8.981000e+01,7.877100e+01,6.904300e+01,5.782500e+01,6.179800e+01,& - & 3.801300e+01,3.320500e+01,2.879400e+01,2.342500e+01,2.191100e+01,& - & 4.850600e+01,4.246600e+01,3.691600e+01,3.001700e+01,2.899900e+01,& - & 6.007000e+01,5.266400e+01,4.590800e+01,3.746400e+01,3.730900e+01,& - & 7.247900e+01,6.356000e+01,5.556400e+01,4.574900e+01,4.687700e+01,& - & 8.553900e+01,7.502800e+01,6.572600e+01,5.477000e+01,5.783800e+01,& - & 3.480800e+01,3.042900e+01,2.637200e+01,2.143800e+01,1.976400e+01,& - & 4.494900e+01,3.932900e+01,3.416400e+01,2.775900e+01,2.647700e+01,& - & 5.619800e+01,4.927100e+01,4.291600e+01,3.492900e+01,3.436500e+01,& - & 6.837200e+01,5.996600e+01,5.237100e+01,4.294800e+01,4.351500e+01,& - & 8.125800e+01,7.128000e+01,6.240200e+01,5.175200e+01,5.399900e+01,& - & 3.150500e+01,2.757800e+01,2.388700e+01,1.940100e+01,1.761200e+01,& - & 4.125400e+01,3.608000e+01,3.131200e+01,2.544900e+01,2.394100e+01,& - & 5.213700e+01,4.569100e+01,3.976200e+01,3.231500e+01,3.139200e+01,& - & 6.402300e+01,5.616700e+01,4.899600e+01,4.003400e+01,4.008900e+01,& - & 7.670200e+01,6.728400e+01,5.886300e+01,4.856900e+01,5.008300e+01,& - & 2.796100e+01,2.450300e+01,2.124800e+01,1.723300e+01,1.536700e+01,& - & 3.726500e+01,3.258600e+01,2.826300e+01,2.296300e+01,2.126900e+01,& - & 4.770600e+01,4.178300e+01,3.632700e+01,2.949000e+01,2.824600e+01,& - & 5.923200e+01,5.196000e+01,4.528400e+01,3.687300e+01,3.644500e+01,& - & 7.162400e+01,6.283600e+01,5.493000e+01,4.510400e+01,4.590200e+01,& - & 2.458300e+01,2.158900e+01,1.876200e+01,1.519100e+01,1.329200e+01,& - & 3.342600e+01,2.926800e+01,2.535700e+01,2.059000e+01,1.876900e+01,& - & 4.342500e+01,3.801600e+01,3.300900e+01,2.680000e+01,2.530700e+01,& - & 5.454900e+01,4.783800e+01,4.165200e+01,3.384200e+01,3.300100e+01,& - & 6.663600e+01,5.847200e+01,5.104200e+01,4.174000e+01,4.194800e+01/ - data absb(901:1175,15) / & - & 2.142100e+01,1.884300e+01,1.644000e+01,1.326600e+01,1.136600e+01,& - & 2.976500e+01,2.608500e+01,2.260800e+01,1.834000e+01,1.643600e+01,& - & 3.931200e+01,3.439800e+01,2.984800e+01,2.423900e+01,2.255300e+01,& - & 5.000600e+01,4.382800e+01,3.812300e+01,3.094100e+01,2.976400e+01,& - & 6.174100e+01,5.418200e+01,4.724400e+01,3.850200e+01,3.820700e+01,& - & 1.864700e+01,1.645700e+01,1.441800e+01,1.159100e+01,9.726800e+00,& - & 2.649200e+01,2.325400e+01,2.018400e+01,1.635400e+01,1.441100e+01,& - & 3.561500e+01,3.117600e+01,2.703300e+01,2.194000e+01,2.012200e+01,& - & 4.588700e+01,4.019400e+01,3.492500e+01,2.833500e+01,2.690400e+01,& - & 5.726200e+01,5.023500e+01,4.377300e+01,3.557600e+01,3.487900e+01,& - & 1.614300e+01,1.430600e+01,1.258600e+01,1.009300e+01,8.287000e+00,& - & 2.347500e+01,2.064600e+01,1.796500e+01,1.452700e+01,1.258000e+01,& - & 3.217300e+01,2.819100e+01,2.442700e+01,1.981800e+01,1.791200e+01,& - & 4.202900e+01,3.679900e+01,3.194600e+01,2.593100e+01,2.430200e+01,& - & 5.302100e+01,4.650500e+01,4.047700e+01,3.285800e+01,3.182500e+01,& - & 1.384900e+01,1.232300e+01,1.090100e+01,8.725700e+00,7.003000e+00,& - & 2.065600e+01,1.819400e+01,1.589700e+01,1.281000e+01,1.087900e+01,& - & 2.888100e+01,2.532800e+01,2.196500e+01,1.780600e+01,1.584600e+01,& - & 3.832800e+01,3.354600e+01,2.910600e+01,2.362200e+01,2.185000e+01,& - & 4.891800e+01,4.288000e+01,3.728900e+01,3.024600e+01,2.893600e+01,& - & 1.174000e+01,1.050600e+01,9.342000e+00,7.473000e+00,5.852400e+00,& - & 1.800200e+01,1.591400e+01,1.395600e+01,1.121000e+01,9.327800e+00,& - & 2.573100e+01,2.260700e+01,1.963400e+01,1.589700e+01,1.391800e+01,& - & 3.475800e+01,3.044400e+01,2.639300e+01,2.141200e+01,1.953200e+01,& - & 4.494000e+01,3.936700e+01,3.420100e+01,2.774200e+01,2.621300e+01,& - & 9.982300e+00,8.983500e+00,8.043300e+00,6.421700e+00,4.923300e+00,& - & 1.574300e+01,1.396800e+01,1.230000e+01,9.858900e+00,8.042500e+00,& - & 2.299900e+01,2.023100e+01,1.762200e+01,1.423700e+01,1.226500e+01,& - & 3.161900e+01,2.772100e+01,2.402100e+01,1.948100e+01,1.753300e+01,& - & 4.142200e+01,3.626900e+01,3.148600e+01,2.554800e+01,2.386000e+01,& - & 8.460000e+00,7.658700e+00,6.910500e+00,5.506400e+00,4.139300e+00,& - & 1.374100e+01,1.223500e+01,1.082800e+01,8.664100e+00,6.931000e+00,& - & 2.052500e+01,1.808900e+01,1.580900e+01,1.273300e+01,1.078500e+01,& - & 2.873300e+01,2.521100e+01,2.186200e+01,1.771800e+01,1.573300e+01,& - & 3.816700e+01,3.341400e+01,2.899400e+01,2.352300e+01,2.171700e+01,& - & 7.094200e+00,6.470500e+00,5.884300e+00,4.682000e+00,3.460000e+00,& - & 1.188800e+01,1.063800e+01,9.456300e+00,7.563600e+00,5.930600e+00,& - & 1.819500e+01,1.608400e+01,1.410400e+01,1.132800e+01,9.425800e+00,& - & 2.596500e+01,2.281600e+01,1.981300e+01,1.604200e+01,1.404400e+01,& - & 3.503100e+01,3.068600e+01,2.660700e+01,2.158200e+01,1.968200e+01,& - & 5.880900e+00,5.407300e+00,4.952000e+00,3.935800e+00,2.876500e+00,& - & 1.018800e+01,9.164400e+00,8.199700e+00,6.547600e+00,5.035600e+00,& - & 1.601100e+01,1.420400e+01,1.250400e+01,1.002200e+01,8.188700e+00,& - & 2.333100e+01,2.052600e+01,1.787100e+01,1.444300e+01,1.245200e+01,& - & 3.201300e+01,2.806600e+01,2.432100e+01,1.972200e+01,1.776300e+01,& - & 4.859200e+00,4.512000e+00,4.153300e+00,3.305000e+00,2.406900e+00,& - & 8.723500e+00,7.889800e+00,7.109800e+00,5.665900e+00,4.288000e+00,& - & 1.409300e+01,1.254300e+01,1.109100e+01,8.878800e+00,7.131200e+00,& - & 2.096900e+01,1.847300e+01,1.613700e+01,1.300400e+01,1.103700e+01,& - & 2.925600e+01,2.566900e+01,2.225400e+01,1.803900e+01,1.604100e+01,& - & 4.486000e+00,4.183200e+00,3.858900e+00,3.073200e+00,2.258800e+00,& - & 8.176400e+00,7.415700e+00,6.701900e+00,5.337500e+00,4.038100e+00,& - & 1.336300e+01,1.191300e+01,1.055300e+01,8.443700e+00,6.758300e+00,& - & 2.005900e+01,1.769000e+01,1.547400e+01,1.245300e+01,1.051700e+01,& - & 2.818800e+01,2.474000e+01,2.146000e+01,1.738800e+01,1.538200e+01/ - data absb(1:300,16) / & - & 3.524000e+00,3.450800e+00,6.895700e+00,1.031000e+01,1.381000e+01,& - & 5.018800e+00,4.888400e+00,9.766800e+00,1.460600e+01,1.956300e+01,& - & 6.863600e+00,6.996300e+00,1.398300e+01,2.091700e+01,2.799600e+01,& - & 8.998300e+00,9.923100e+00,1.982100e+01,2.965700e+01,3.970200e+01,& - & 1.139100e+01,1.344800e+01,2.687300e+01,4.019700e+01,5.382100e+01,& - & 4.086500e+00,4.262700e+00,8.515700e+00,1.273700e+01,1.706100e+01,& - & 5.915200e+00,5.977000e+00,1.194100e+01,1.786100e+01,2.391900e+01,& - & 8.111600e+00,8.494600e+00,1.697400e+01,2.539300e+01,3.399400e+01,& - & 1.066700e+01,1.198200e+01,2.394100e+01,3.582000e+01,4.794700e+01,& - & 1.357000e+01,1.616600e+01,3.229300e+01,4.832800e+01,6.467900e+01,& - & 4.920500e+00,5.238100e+00,1.046700e+01,1.565700e+01,2.096200e+01,& - & 7.110700e+00,7.325100e+00,1.463600e+01,2.189200e+01,2.931400e+01,& - & 9.765700e+00,1.031900e+01,2.062500e+01,3.085700e+01,4.130700e+01,& - & 1.286300e+01,1.434800e+01,2.866700e+01,4.290200e+01,5.741500e+01,& - & 1.637700e+01,1.924500e+01,3.844000e+01,5.753000e+01,7.701400e+01,& - & 6.001900e+00,6.375500e+00,1.274200e+01,1.906000e+01,2.551100e+01,& - & 8.671900e+00,8.960100e+00,1.790500e+01,2.678200e+01,3.585800e+01,& - & 1.189700e+01,1.249400e+01,2.496500e+01,3.735100e+01,5.000500e+01,& - & 1.566400e+01,1.703300e+01,3.403900e+01,5.094300e+01,6.816000e+01,& - & 1.993100e+01,2.260900e+01,4.514400e+01,6.760400e+01,9.038400e+01,& - & 7.385900e+00,7.700400e+00,1.538900e+01,2.302300e+01,3.081600e+01,& - & 1.064000e+01,1.086300e+01,2.170600e+01,3.247000e+01,4.346700e+01,& - & 1.456300e+01,1.499200e+01,2.995800e+01,4.482400e+01,5.999100e+01,& - & 1.913800e+01,2.015200e+01,4.021900e+01,6.018900e+01,8.051700e+01,& - & 2.428600e+01,2.645900e+01,5.244800e+01,7.850400e+01,1.050100e+02,& - & 9.122600e+00,9.259700e+00,1.849100e+01,2.766800e+01,3.703400e+01,& - & 1.309000e+01,1.303800e+01,2.600800e+01,3.892300e+01,5.208300e+01,& - & 1.787000e+01,1.786200e+01,3.554500e+01,5.319900e+01,7.116700e+01,& - & 2.338400e+01,2.380200e+01,4.710500e+01,7.049400e+01,9.431600e+01,& - & 2.960300e+01,3.095900e+01,6.061700e+01,9.076100e+01,1.213700e+02,& - & 1.126700e+01,1.110300e+01,2.197500e+01,3.289100e+01,4.400000e+01,& - & 1.610800e+01,1.558800e+01,3.073700e+01,4.599800e+01,6.153800e+01,& - & 2.188000e+01,2.122600e+01,4.160300e+01,6.228600e+01,8.328400e+01,& - & 2.854600e+01,2.806300e+01,5.455500e+01,8.165300e+01,1.092000e+02,& - & 3.601500e+01,3.620900e+01,6.941800e+01,1.039800e+02,1.389700e+02,& - & 1.399300e+01,1.337900e+01,2.592000e+01,3.880400e+01,5.189600e+01,& - & 1.985700e+01,1.871100e+01,3.597000e+01,5.385800e+01,7.202000e+01,& - & 2.684900e+01,2.530900e+01,4.823600e+01,7.222100e+01,9.656400e+01,& - & 3.485400e+01,3.320400e+01,6.260500e+01,9.375400e+01,1.253200e+02,& - & 4.382800e+01,4.246400e+01,7.893200e+01,1.182200e+02,1.580100e+02,& - & 1.731500e+01,1.611400e+01,3.012900e+01,4.511500e+01,6.031400e+01,& - & 2.439300e+01,2.239500e+01,4.148300e+01,6.211600e+01,8.304000e+01,& - & 3.277600e+01,3.009100e+01,5.511900e+01,8.255900e+01,1.103300e+02,& - & 4.229400e+01,3.917600e+01,7.092400e+01,1.062200e+02,1.419500e+02,& - & 5.303800e+01,4.969200e+01,8.890800e+01,1.331700e+02,1.779400e+02,& - & 2.182500e+01,1.977900e+01,3.524800e+01,5.279600e+01,7.055000e+01,& - & 3.039600e+01,2.725300e+01,4.803300e+01,7.194800e+01,9.612500e+01,& - & 4.038000e+01,3.623000e+01,6.317300e+01,9.466000e+01,1.264800e+02,& - & 5.179700e+01,4.670700e+01,8.076600e+01,1.209900e+02,1.616500e+02,& - & 6.454000e+01,5.872400e+01,1.007100e+02,1.508400e+02,2.015600e+02,& - & 2.732000e+01,2.418800e+01,4.069300e+01,6.096000e+01,8.145300e+01,& - & 3.755800e+01,3.297600e+01,5.497000e+01,8.233600e+01,1.100300e+02,& - & 4.940800e+01,4.337500e+01,7.181600e+01,1.075900e+02,1.437300e+02,& - & 6.287400e+01,5.535300e+01,9.130900e+01,1.368000e+02,1.827600e+02,& - & 7.769800e+01,6.896100e+01,1.133300e+02,1.697800e+02,2.267900e+02,& - & 3.386900e+01,2.938700e+01,4.664800e+01,6.990400e+01,9.336700e+01,& - & 4.600600e+01,3.962200e+01,6.251500e+01,9.367900e+01,1.251100e+02,& - & 5.994600e+01,5.157100e+01,8.120900e+01,1.216700e+02,1.625000e+02,& - & 7.553900e+01,6.511000e+01,1.026500e+02,1.538000e+02,2.054200e+02,& - & 9.247700e+01,8.044800e+01,1.266000e+02,1.896900e+02,2.533300e+02/ - data absb(301:600,16) / & - & 4.159900e+01,3.545400e+01,5.314600e+01,7.964200e+01,1.063500e+02,& - & 5.578200e+01,4.722800e+01,7.074000e+01,1.059700e+02,1.415500e+02,& - & 7.194300e+01,6.074400e+01,9.133800e+01,1.368800e+02,1.827600e+02,& - & 8.973500e+01,7.604300e+01,1.146000e+02,1.717500e+02,2.293200e+02,& - & 1.088100e+02,9.302200e+01,1.406200e+02,2.107900e+02,2.813300e+02,& - & 5.063300e+01,4.254000e+01,6.052100e+01,9.053300e+01,1.208900e+02,& - & 6.703100e+01,5.588100e+01,7.983700e+01,1.196400e+02,1.597400e+02,& - & 8.544900e+01,7.104600e+01,1.021900e+02,1.531400e+02,2.044800e+02,& - & 1.055000e+02,8.810400e+01,1.274100e+02,1.909200e+02,2.549000e+02,& - & 1.266200e+02,1.066500e+02,1.553500e+02,2.328400e+02,3.108500e+02,& - & 6.076000e+01,5.036200e+01,6.862700e+01,1.021400e+02,1.363500e+02,& - & 7.937200e+01,6.535100e+01,8.949600e+01,1.338100e+02,1.786200e+02,& - & 1.000700e+02,8.217100e+01,1.135000e+02,1.701400e+02,2.270900e+02,& - & 1.221900e+02,1.008600e+02,1.406000e+02,2.107700e+02,2.813500e+02,& - & 1.451700e+02,1.207800e+02,1.703100e+02,2.552700e+02,3.407800e+02,& - & 7.185000e+01,5.886500e+01,7.724900e+01,1.143500e+02,1.526300e+02,& - & 9.265300e+01,7.539300e+01,9.967100e+01,1.485100e+02,1.982200e+02,& - & 1.154100e+02,9.382100e+01,1.251500e+02,1.873800e+02,2.500900e+02,& - & 1.394000e+02,1.140300e+02,1.538100e+02,2.305300e+02,3.077000e+02,& - & 1.640600e+02,1.351700e+02,1.851000e+02,2.774800e+02,3.703000e+02,& - & 8.387600e+01,6.795500e+01,8.653600e+01,1.271600e+02,1.697100e+02,& - & 1.067100e+02,8.605000e+01,1.103500e+02,1.638600e+02,2.186900e+02,& - & 1.312800e+02,1.059600e+02,1.373600e+02,2.052200e+02,2.738700e+02,& - & 1.569100e+02,1.275000e+02,1.673700e+02,2.507100e+02,3.345400e+02,& - & 1.830700e+02,1.496800e+02,1.998600e+02,2.996300e+02,3.998100e+02,& - & 9.640200e+01,7.740300e+01,9.610000e+01,1.404200e+02,1.873300e+02,& - & 1.211100e+02,9.691700e+01,1.212900e+02,1.795300e+02,2.395700e+02,& - & 1.472500e+02,1.183000e+02,1.496700e+02,2.231900e+02,2.977800e+02,& - & 1.743500e+02,1.408900e+02,1.809000e+02,2.707600e+02,3.612600e+02,& - & 2.017400e+02,1.639100e+02,2.144700e+02,3.214000e+02,4.288100e+02,& - & 1.093800e+02,8.712900e+01,1.060500e+02,1.542500e+02,2.057600e+02,& - & 1.357100e+02,1.080000e+02,1.324700e+02,1.955000e+02,2.608600e+02,& - & 1.632400e+02,1.306300e+02,1.621200e+02,2.412200e+02,3.218200e+02,& - & 1.916200e+02,1.541200e+02,1.944700e+02,2.906900e+02,3.878300e+02,& - & 2.198900e+02,1.778100e+02,2.290000e+02,3.430100e+02,4.576100e+02,& - & 1.225600e+02,9.706700e+01,1.161700e+02,1.683600e+02,2.246100e+02,& - & 1.503000e+02,1.191300e+02,1.439300e+02,2.117000e+02,2.824100e+02,& - & 1.790500e+02,1.427900e+02,1.746300e+02,2.593600e+02,3.460100e+02,& - & 2.083500e+02,1.670000e+02,2.079100e+02,3.104700e+02,4.140400e+02,& - & 2.373400e+02,1.911800e+02,2.432700e+02,3.642000e+02,4.858400e+02,& - & 1.357000e+02,1.070500e+02,1.263800e+02,1.827700e+02,2.437900e+02,& - & 1.646900e+02,1.301500e+02,1.553000e+02,2.279700e+02,3.040800e+02,& - & 1.944800e+02,1.546700e+02,1.870700e+02,2.773300e+02,3.699400e+02,& - & 2.243600e+02,1.793600e+02,2.212200e+02,3.297600e+02,4.399100e+02,& - & 2.539300e+02,2.039000e+02,2.572800e+02,3.848700e+02,5.133000e+02,& - & 1.476900e+02,1.161500e+02,1.356100e+02,1.958000e+02,2.611500e+02,& - & 1.776500e+02,1.401300e+02,1.654600e+02,2.425500e+02,3.235200e+02,& - & 2.081900e+02,1.652200e+02,1.980800e+02,2.932700e+02,3.911400e+02,& - & 2.385500e+02,1.902500e+02,2.329300e+02,3.469200e+02,4.627000e+02,& - & 2.685000e+02,2.150300e+02,2.695500e+02,4.029200e+02,5.374200e+02,& - & 1.564300e+02,1.227000e+02,1.419000e+02,2.043600e+02,2.725400e+02,& - & 1.871300e+02,1.473000e+02,1.724300e+02,2.521400e+02,3.362900e+02,& - & 2.181900e+02,1.728200e+02,2.056200e+02,3.037200e+02,4.050600e+02,& - & 2.489500e+02,1.981400e+02,2.408100e+02,3.582500e+02,4.777500e+02,& - & 2.791700e+02,2.231300e+02,2.778000e+02,4.149500e+02,5.533600e+02,& - & 1.612800e+02,1.262300e+02,1.447000e+02,2.076000e+02,2.768200e+02,& - & 1.925000e+02,1.511800e+02,1.755300e+02,2.558700e+02,3.412400e+02,& - & 2.240000e+02,1.770600e+02,2.089400e+02,3.078700e+02,4.105000e+02,& - & 2.551100e+02,2.026500e+02,2.443500e+02,3.628100e+02,4.838300e+02,& - & 2.856600e+02,2.278100e+02,2.814400e+02,4.199400e+02,5.600500e+02/ - data absb(601:900,16) / & - & 1.607400e+02,1.256200e+02,1.427000e+02,2.034200e+02,2.713100e+02,& - & 1.923500e+02,1.506900e+02,1.733700e+02,2.515000e+02,3.354400e+02,& - & 2.242200e+02,1.767600e+02,2.066100e+02,3.033700e+02,4.045600e+02,& - & 2.556800e+02,2.026600e+02,2.419300e+02,3.583000e+02,4.778200e+02,& - & 2.866100e+02,2.280700e+02,2.789400e+02,4.154800e+02,5.541100e+02,& - & 1.593100e+02,1.243400e+02,1.402100e+02,1.985500e+02,2.648000e+02,& - & 1.912000e+02,1.494700e+02,1.706400e+02,2.463400e+02,3.284900e+02,& - & 2.233600e+02,1.756800e+02,2.036800e+02,2.979700e+02,3.973400e+02,& - & 2.552000e+02,2.018400e+02,2.387900e+02,3.528200e+02,4.704500e+02,& - & 2.864600e+02,2.274900e+02,2.757000e+02,4.098800e+02,5.466400e+02,& - & 1.573700e+02,1.227200e+02,1.375200e+02,1.934700e+02,2.580000e+02,& - & 1.894700e+02,1.478500e+02,1.676600e+02,2.408600e+02,3.211800e+02,& - & 2.219000e+02,1.741400e+02,2.004800e+02,2.922700e+02,3.897600e+02,& - & 2.540100e+02,2.005400e+02,2.354000e+02,3.468500e+02,4.625700e+02,& - & 2.855700e+02,2.264000e+02,2.722000e+02,4.038700e+02,5.385300e+02,& - & 1.517300e+02,1.183400e+02,1.317000e+02,1.836900e+02,2.449600e+02,& - & 1.838700e+02,1.432600e+02,1.612600e+02,2.301400e+02,3.069000e+02,& - & 2.165400e+02,1.695100e+02,1.935500e+02,2.809200e+02,3.746000e+02,& - & 2.489600e+02,1.961100e+02,2.280600e+02,3.349000e+02,4.465800e+02,& - & 2.808100e+02,2.222500e+02,2.645900e+02,3.916200e+02,5.222500e+02,& - & 1.453100e+02,1.134400e+02,1.253900e+02,1.734200e+02,2.312600e+02,& - & 1.773900e+02,1.380400e+02,1.543900e+02,2.188000e+02,2.917600e+02,& - & 2.102200e+02,1.641800e+02,1.861200e+02,2.687300e+02,3.583200e+02,& - & 2.429200e+02,1.908600e+02,2.201500e+02,3.219600e+02,4.293400e+02,& - & 2.750700e+02,2.173000e+02,2.563000e+02,3.783900e+02,5.044900e+02,& - & 1.385900e+02,1.083200e+02,1.190200e+02,1.632500e+02,2.176900e+02,& - & 1.705200e+02,1.326600e+02,1.474500e+02,2.074900e+02,2.766500e+02,& - & 2.034200e+02,1.585900e+02,1.786300e+02,2.564400e+02,3.419900e+02,& - & 2.363500e+02,1.852800e+02,2.121500e+02,3.091300e+02,4.121300e+02,& - & 2.688000e+02,2.119700e+02,2.477800e+02,3.648100e+02,4.864400e+02,& - & 1.300100e+02,1.017800e+02,1.112300e+02,1.510000e+02,2.013200e+02,& - & 1.615600e+02,1.257300e+02,1.389400e+02,1.937100e+02,2.582800e+02,& - & 1.944300e+02,1.512800e+02,1.693000e+02,2.413400e+02,3.218200e+02,& - & 2.275000e+02,1.779200e+02,2.021300e+02,2.930800e+02,3.907800e+02,& - & 2.602500e+02,2.048000e+02,2.372400e+02,3.479800e+02,4.640300e+02,& - & 1.206400e+02,9.469600e+01,1.029100e+02,1.382200e+02,1.843200e+02,& - & 1.516400e+02,1.181700e+02,1.298000e+02,1.791300e+02,2.389300e+02,& - & 1.842800e+02,1.432200e+02,1.593000e+02,2.252600e+02,3.003600e+02,& - & 2.175300e+02,1.697200e+02,1.913900e+02,2.758300e+02,3.678200e+02,& - & 2.504900e+02,1.966600e+02,2.257900e+02,3.297500e+02,4.396800e+02,& - & 1.115100e+02,8.761300e+01,9.479000e+01,1.260800e+02,1.681200e+02,& - & 1.416400e+02,1.105700e+02,1.207700e+02,1.650700e+02,2.200600e+02,& - & 1.739600e+02,1.352000e+02,1.494500e+02,2.095800e+02,2.794600e+02,& - & 2.072200e+02,1.613400e+02,1.807700e+02,2.588500e+02,3.450900e+02,& - & 2.404100e+02,1.882300e+02,2.144100e+02,3.117900e+02,4.156900e+02,& - & 1.020200e+02,8.026300e+01,8.645600e+01,1.138500e+02,1.518300e+02,& - & 1.310200e+02,1.025100e+02,1.114300e+02,1.505800e+02,2.007700e+02,& - & 1.628400e+02,1.266400e+02,1.392200e+02,1.932600e+02,2.576900e+02,& - & 1.959300e+02,1.522800e+02,1.696100e+02,2.410100e+02,3.212700e+02,& - & 2.293200e+02,1.791100e+02,2.024900e+02,2.928300e+02,3.903800e+02,& - & 9.183300e+01,7.252100e+01,7.749200e+01,1.010700e+02,1.347800e+02,& - & 1.193500e+02,9.363900e+01,1.012400e+02,1.352200e+02,1.803400e+02,& - & 1.503100e+02,1.171400e+02,1.280000e+02,1.756800e+02,2.343000e+02,& - & 1.831000e+02,1.421600e+02,1.573600e+02,2.214800e+02,2.953500e+02,& - & 2.165500e+02,1.687500e+02,1.893100e+02,2.718700e+02,3.626100e+02,& - & 8.243400e+01,6.527100e+01,6.908200e+01,8.931000e+01,1.190800e+02,& - & 1.081500e+02,8.494000e+01,9.149700e+01,1.208500e+02,1.611700e+02,& - & 1.379600e+02,1.077500e+02,1.171500e+02,1.589300e+02,2.119100e+02,& - & 1.702400e+02,1.322700e+02,1.455000e+02,2.027500e+02,2.703300e+02,& - & 2.036100e+02,1.582900e+02,1.764600e+02,2.514200e+02,3.352600e+02/ - data absb(901:1175,16) / & - & 7.359100e+01,5.855500e+01,6.121700e+01,7.858500e+01,1.047800e+02,& - & 9.746800e+01,7.678700e+01,8.219900e+01,1.075300e+02,1.433700e+02,& - & 1.258900e+02,9.859500e+01,1.066400e+02,1.429900e+02,1.906300e+02,& - & 1.574300e+02,1.225000e+02,1.339700e+02,1.846400e+02,2.461800e+02,& - & 1.905200e+02,1.479400e+02,1.639100e+02,2.314900e+02,3.086800e+02,& - & 6.596100e+01,5.263800e+01,5.439300e+01,6.939900e+01,9.253400e+01,& - & 8.811600e+01,6.961600e+01,7.394800e+01,9.588300e+01,1.278400e+02,& - & 1.149500e+02,9.022200e+01,9.718500e+01,1.289800e+02,1.719700e+02,& - & 1.455600e+02,1.135000e+02,1.235000e+02,1.684600e+02,2.245300e+02,& - & 1.782300e+02,1.383900e+02,1.524500e+02,2.134300e+02,2.845800e+02,& - & 5.911900e+01,4.735400e+01,4.834400e+01,6.120400e+01,8.160400e+01,& - & 7.968000e+01,6.316800e+01,6.645200e+01,8.553000e+01,1.141000e+02,& - & 1.048200e+02,8.235600e+01,8.843000e+01,1.162300e+02,1.549700e+02,& - & 1.342700e+02,1.049400e+02,1.136800e+02,1.533900e+02,2.045400e+02,& - & 1.663900e+02,1.293200e+02,1.417300e+02,1.965200e+02,2.620200e+02,& - & 5.274500e+01,4.246700e+01,4.275400e+01,5.368000e+01,7.157600e+01,& - & 7.174700e+01,5.712900e+01,5.942400e+01,7.607300e+01,1.014200e+02,& - & 9.520000e+01,7.504700e+01,8.007100e+01,1.043400e+02,1.391100e+02,& - & 1.232800e+02,9.660800e+01,1.042000e+02,1.391800e+02,1.855600e+02,& - & 1.546500e+02,1.203900e+02,1.312800e+02,1.802600e+02,2.403700e+02,& - & 4.693100e+01,3.794200e+01,3.771700e+01,4.687300e+01,6.247900e+01,& - & 6.442600e+01,5.143400e+01,5.293400e+01,6.732300e+01,8.976600e+01,& - & 8.624200e+01,6.815400e+01,7.214700e+01,9.326600e+01,1.243600e+02,& - & 1.127000e+02,8.842500e+01,9.507200e+01,1.257500e+02,1.676700e+02,& - & 1.430600e+02,1.116100e+02,1.211600e+02,1.646500e+02,2.195700e+02,& - & 4.207700e+01,3.416900e+01,3.348800e+01,4.126200e+01,5.490200e+01,& - & 5.819000e+01,4.663400e+01,4.744100e+01,5.991500e+01,7.987800e+01,& - & 7.851400e+01,6.228200e+01,6.532800e+01,8.392400e+01,1.119000e+02,& - & 1.034200e+02,8.127600e+01,8.708600e+01,1.142000e+02,1.522700e+02,& - & 1.326900e+02,1.037200e+02,1.121900e+02,1.509700e+02,2.013000e+02,& - & 3.779700e+01,3.083600e+01,2.980500e+01,3.638300e+01,4.827100e+01,& - & 5.258300e+01,4.233700e+01,4.255800e+01,5.336400e+01,7.112900e+01,& - & 7.153800e+01,5.697100e+01,5.916200e+01,7.565300e+01,1.008800e+02,& - & 9.494300e+01,7.484500e+01,7.976500e+01,1.038000e+02,1.384000e+02,& - & 1.230000e+02,9.636700e+01,1.038400e+02,1.385400e+02,1.847200e+02,& - & 3.387300e+01,2.774000e+01,2.648000e+01,3.194200e+01,4.220800e+01,& - & 4.745300e+01,3.834300e+01,3.812500e+01,4.737900e+01,6.314800e+01,& - & 6.509100e+01,5.194000e+01,5.345200e+01,6.796600e+01,9.062700e+01,& - & 8.704600e+01,6.876400e+01,7.278400e+01,9.407200e+01,1.254300e+02,& - & 1.136500e+02,8.917300e+01,9.582300e+01,1.267600e+02,1.690100e+02,& - & 3.026900e+01,2.488700e+01,2.352200e+01,2.796600e+01,3.667200e+01,& - & 4.274200e+01,3.468000e+01,3.402900e+01,4.194000e+01,5.582600e+01,& - & 5.904900e+01,4.729100e+01,4.814600e+01,6.081300e+01,8.107900e+01,& - & 7.958800e+01,6.309200e+01,6.621300e+01,8.506800e+01,1.134100e+02,& - & 1.046700e+02,8.224100e+01,8.812700e+01,1.156100e+02,1.541700e+02,& - & 2.718100e+01,2.240700e+01,2.104300e+01,2.457000e+01,3.190300e+01,& - & 3.860700e+01,3.147300e+01,3.047000e+01,3.725500e+01,4.946200e+01,& - & 5.366100e+01,4.316600e+01,4.345400e+01,5.450700e+01,7.268800e+01,& - & 7.288100e+01,5.799600e+01,6.031000e+01,7.712500e+01,1.028400e+02,& - & 9.658600e+01,7.608900e+01,8.113500e+01,1.056600e+02,1.409100e+02,& - & 2.603100e+01,2.148200e+01,2.012600e+01,2.330300e+01,3.012900e+01,& - & 3.706300e+01,3.025900e+01,2.915000e+01,3.548600e+01,4.706400e+01,& - & 5.163000e+01,4.159600e+01,4.169000e+01,5.214400e+01,6.953900e+01,& - & 7.035000e+01,5.603200e+01,5.804300e+01,7.411500e+01,9.884200e+01,& - & 9.347400e+01,7.371600e+01,7.841600e+01,1.018600e+02,1.358100e+02/ - -! the array selfref contains the coefficient of the water vapor -! self-continuum (including the energy term). the first index -! refers to temperature in 7.2 degree increments. for instance, -! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, -! etc. the second index runs over the g-channel (1 to NG03=16). - - data selfref(:, 1) / & - & 5.102860e-01,4.304240e-01,3.630610e-01,3.062410e-01,2.583130e-01,& - & 2.178860e-01,1.837860e-01,1.550230e-01,1.307610e-01,1.102970e-01/ - data selfref(:, 2) / & - & 4.967770e-01,4.307580e-01,3.735120e-01,3.238740e-01,2.808330e-01,& - & 2.435120e-01,2.111500e-01,1.830890e-01,1.587580e-01,1.376590e-01/ - data selfref(:, 3) / & - & 4.655950e-01,4.047780e-01,3.519050e-01,3.059390e-01,2.659760e-01,& - & 2.312340e-01,2.010300e-01,1.747710e-01,1.519420e-01,1.320950e-01/ - data selfref(:, 4) / & - & 4.346290e-01,3.867090e-01,3.440730e-01,3.061370e-01,2.723840e-01,& - & 2.423530e-01,2.156330e-01,1.918580e-01,1.707050e-01,1.518840e-01/ - data selfref(:, 5) / & - & 4.176250e-01,3.754420e-01,3.375190e-01,3.034270e-01,2.727780e-01,& - & 2.452250e-01,2.204560e-01,1.981880e-01,1.781690e-01,1.601730e-01/ - data selfref(:, 6) / & - & 3.974120e-01,3.612490e-01,3.283760e-01,2.984940e-01,2.713320e-01,& - & 2.466410e-01,2.241980e-01,2.037960e-01,1.852510e-01,1.683940e-01/ - data selfref(:, 7) / & - & 3.897950e-01,3.561780e-01,3.254600e-01,2.973910e-01,2.717430e-01,& - & 2.483070e-01,2.268920e-01,2.073240e-01,1.894440e-01,1.731050e-01/ - data selfref(:, 8) / & - & 3.790950e-01,3.468280e-01,3.173080e-01,2.903010e-01,2.655920e-01,& - & 2.429860e-01,2.223050e-01,2.033840e-01,1.860730e-01,1.702350e-01/ - data selfref(:, 9) / & - & 3.870860e-01,3.539880e-01,3.237200e-01,2.960400e-01,2.707270e-01,& - & 2.475780e-01,2.264090e-01,2.070500e-01,1.893460e-01,1.731560e-01/ - data selfref(:,10) / & - & 4.075290e-01,3.712840e-01,3.382630e-01,3.081790e-01,2.807700e-01,& - & 2.557990e-01,2.330490e-01,2.123220e-01,1.934380e-01,1.762340e-01/ - data selfref(:,11) / & - & 4.093150e-01,3.744200e-01,3.425000e-01,3.133020e-01,2.865920e-01,& - & 2.621600e-01,2.398110e-01,2.193670e-01,2.006650e-01,1.835580e-01/ - data selfref(:,12) / & - & 3.739960e-01,3.514620e-01,3.302860e-01,3.103850e-01,2.916840e-01,& - & 2.741090e-01,2.575930e-01,2.420720e-01,2.274870e-01,2.137800e-01/ - data selfref(:,13) / & - & 4.879650e-01,4.445250e-01,4.049520e-01,3.689020e-01,3.360610e-01,& - & 3.061440e-01,2.788910e-01,2.540630e-01,2.314460e-01,2.108420e-01/ - data selfref(:,14) / & - & 5.679990e-01,5.033360e-01,4.460340e-01,3.952560e-01,3.502590e-01,& - & 3.103840e-01,2.750480e-01,2.437360e-01,2.159880e-01,1.913990e-01/ - data selfref(:,15) / & - & 5.924920e-01,5.270720e-01,4.688740e-01,4.171030e-01,3.710480e-01,& - & 3.300790e-01,2.936330e-01,2.612110e-01,2.323690e-01,2.067120e-01/ - data selfref(:,16) / & - & 5.041760e-01,4.648450e-01,4.285820e-01,3.951480e-01,3.643220e-01,& - & 3.359010e-01,3.096970e-01,2.855380e-01,2.632630e-01,2.427250e-01/ - - data forref / & - & 1.768420e-04, 1.779130e-04, 1.251860e-04, 1.079120e-04, & - & 1.052170e-04, 7.487260e-05, 1.117010e-04, 7.689210e-05, & - & 9.872420e-05, 9.857110e-05, 6.165570e-05,-1.612910e-05, & - & -1.267940e-04,-1.190110e-04,-2.678140e-04, 6.950050e-05 / - - data absn2oa / & - & 1.503870e-01,2.914070e-01,6.288030e-01,9.656190e-01,1.150540e+00,& - & 2.234240e+00,1.833920e+00,1.390330e+00,4.284570e-01,2.735020e-01,& - & 1.843070e-01,1.613250e-01,7.663140e-02,1.338620e-01,6.711960e-07,& - & 1.592930e-06 / - - data absn2ob / & - & 9.370440e-05,1.233180e-03,7.917200e-03,5.330050e-02,1.723430e-01,& - & 4.295710e-01,1.012880e+00,3.838630e+00,1.153120e+01,1.083830e+00,& - & 2.248470e+00,1.512680e+00,3.331770e-01,7.821020e-01,3.446310e-01,& - & 1.610390e-03 / - - data fracrefa(:,:) / & - & 0.1511639953,0.1487569958,0.1423230022,0.1323450059,0.1188160032,& - & 0.1022410020,0.0834558010,0.0626749024,0.0425065011,0.0046265000,& - & 0.0038225900,0.0030260000,0.0022200400,0.0014139700,0.0005337900,& - & 0.0000742100,0.1526599973,0.1488839984,0.1419589967,0.1317950040,& - & 0.1184270009,0.1020900011,0.0833612978,0.0626436993,0.0424765982,& - & 0.0046194601,0.0038153599,0.0030260100,0.0022200400,0.0014139700,& - & 0.0005330200,0.0000749800,0.1528279930,0.1490300000,0.1419239938,& - & 0.1317429990,0.1183530018,0.1020269990,0.0832983032,0.0626482964,& - & 0.0424690992,0.0046024201,0.0038190400,0.0030157301,0.0022200400,& - & 0.0014139700,0.0005337900,0.0000742100,0.1529839933,0.1490280032,& - & 0.1419340074,0.1317349970,0.1183329970,0.1019579992,0.0832472965,& - & 0.0626477003,0.0424649008,0.0046048900,0.0038112300,0.0030189301,& - & 0.0022109300,0.0014139700,0.0005337900,0.0000742100,0.1530759931,& - & 0.1490720063,0.1419889927,0.1316979975,0.1182729974,0.1019229963,& - & 0.0832159966,0.0626349002,0.0424560010,0.0046084598,0.0038083601,& - & 0.0030166300,0.0022140199,0.0014116700,0.0005280700,0.0000737600,& - & 0.1531140059,0.1491540074,0.1420730054,0.1316729933,0.1181930006,& - & 0.1018889993,0.0831876025,0.0626195967,0.0424388982,0.0046158400,& - & 0.0038092900,0.0030081500,0.0022173601,0.0014058800,0.0005277600,& - & 0.0000737600,0.1531600058,0.1492549926,0.1421300024,0.1317099929,& - & 0.1180770025,0.1018140018,0.0831739977,0.0626029968,0.0424272008,& - & 0.0046152002,0.0038138099,0.0030128499,0.0022027500,0.0014037100,& - & 0.0005277600,0.0000737600,0.1532119960,0.1494099945,0.1422249973,& - & 0.1316419989,0.1179820001,0.1017450020,0.0831750035,0.0625364035,& - & 0.0424312986,0.0046172398,0.0038153401,0.0030032001,0.0022009099,& - & 0.0014036400,0.0005285200,0.0000730000,0.1531279981,0.1497309953,& - & 0.1423439980,0.1316889971,0.1179519966,0.1015610024,0.0830299035,& - & 0.0625223964,0.0424098000,0.0046103499,0.0038138099,0.0030017600,& - & 0.0022016000,0.0014028400,0.0005277400,0.0000737600,0.1529249996,& - & 0.1497800052,0.1424240023,0.1317259967,0.1179879978,0.1015639976,& - & 0.0830304995,0.0625166968,0.0424096994,0.0046130200,0.0038145201,& - & 0.0030024999,0.0022012601,0.0014032400,0.0005285000,0.0000730000/ - data fracrefb(:,:) / & - & 0.1634020060,0.1560769975,0.1460140049,0.1318269968,0.1152469963,& - & 0.0966657028,0.0782535970,0.0584978014,0.0394965000,0.0042798002,& - & 0.0035371899,0.0027930301,0.0020478801,0.0013013900,0.0004905500,& - & 0.0000690400,0.1576289982,0.1549469978,0.1465979964,0.1326780021,& - & 0.1156269982,0.0983835980,0.0793042034,0.0596270002,0.0403635986,& - & 0.0043805302,0.0036146301,0.0028572299,0.0020834501,0.0013213500,& - & 0.0005052800,0.0000800300,0.1564150006,0.1539449990,0.1463360041,& - & 0.1318040043,0.1161710024,0.0992416963,0.0800051019,0.0602141991,& - & 0.0408273004,0.0044169398,0.0036536399,0.0028772301,0.0021091399,& - & 0.0013578400,0.0005465100,0.0000800300,0.1548269987,0.1528629959,& - & 0.1439249963,0.1324409992,0.1171199977,0.0999492034,0.0811920017,& - & 0.0610436015,0.0413560010,0.0044668498,0.0036837701,0.0029076701,& - & 0.0021544499,0.0014286500,0.0005614200,0.0000800300,0.1597509980,& - & 0.1565349996,0.1421439946,0.1289220005,0.1150839999,0.0990602002,& - & 0.0808793977,0.0607818998,0.0414053015,0.0045272401,0.0037455801,& - & 0.0029532800,0.0021850900,0.0013864400,0.0005601800,0.0000800300/ - - data etaref / & - & 0.000,0.125,0.250,0.375,0.500,0.625,0.750,0.875,0.9875,1.0 / - - data h2oref / & - & 1.87599e-02,1.22233e-02,5.89086e-03,2.76753e-03,1.40651e-03, & - & 7.59698e-04,3.88758e-04,1.65422e-04,3.71895e-05,7.47648e-06, & - & 4.30818e-06,3.33194e-06,3.20393e-06,3.16186e-06,3.25235e-06, & - & 3.42258e-06,3.62884e-06,3.91482e-06,4.14875e-06,4.30810e-06, & - & 4.44204e-06,4.57783e-06,4.70865e-06,4.79432e-06,4.86971e-06, & - & 4.92603e-06,4.96688e-06,4.99628e-06,5.05266e-06,5.12658e-06, & - & 5.25028e-06,5.35708e-06,5.45085e-06,5.48304e-06,5.50000e-06, & - & 5.50000e-06,5.45359e-06,5.40468e-06,5.35576e-06,5.25327e-06, & - & 5.14362e-06,5.03396e-06,4.87662e-06,4.69787e-06,4.51911e-06, & - & 4.33600e-06,4.14416e-06,3.95232e-06,3.76048e-06,3.57217e-06, & - & 3.38549e-06,3.19881e-06,3.01212e-06,2.82621e-06,2.64068e-06, & - & 2.45515e-06,2.26962e-06,2.08659e-06,1.93029e-06 / - - data n2oref / & - & 3.20000e-07,3.20000e-07,3.20000e-07,3.20000e-07,3.20000e-07, & - & 3.19652e-07,3.15324e-07,3.03830e-07,2.94221e-07,2.84953e-07, & - & 2.76714e-07,2.64709e-07,2.42847e-07,2.09547e-07,1.71945e-07, & - & 1.37491e-07,1.13319e-07,1.00354e-07,9.12812e-08,8.54633e-08, & - & 8.03631e-08,7.33718e-08,6.59754e-08,5.60386e-08,4.70901e-08, & - & 3.99774e-08,3.29786e-08,2.60642e-08,2.10663e-08,1.65918e-08, & - & 1.30167e-08,1.00900e-08,7.62490e-09,6.11592e-09,4.66725e-09, & - & 3.28574e-09,2.84838e-09,2.46198e-09,2.07557e-09,1.85507e-09, & - & 1.65675e-09,1.45843e-09,1.31948e-09,1.20716e-09,1.09485e-09, & - & 9.97803e-10,9.31260e-10,8.64721e-10,7.98181e-10,7.51380e-10, & - & 7.13670e-10,6.75960e-10,6.38250e-10,6.09811e-10,5.85998e-10, & - & 5.62185e-10,5.38371e-10,5.15183e-10,4.98660e-10 / - - data co2ref / & - & 53*3.55e-04, 3.5470873e-04, 3.5427220e-04, 3.5383567e-04, & - & 3.5339911e-04, 3.5282588e-04, 3.5079606e-04 / - -!........................................! - end module module_radlw_kgb03 ! -!========================================! - - - -!========================================! - module module_radlw_kgb04 ! -!........................................! -! - use machine, only : kind_phys - use module_radlw_parameters, only : NG04 -! - implicit none -! - private -! - integer, public :: MSA04, MSB04, MSF04, MAF04, MBF04 - parameter (MSA04=585, MSB04=1410, MSF04=10, MAF04=9, MBF04=6) - - real (kind=kind_phys), public :: & - & absa(MSA04,NG04), absb(MSB04,NG04), selfref(MSF04,NG04), & - & fracrefa(NG04,MAF04), fracrefb(NG04,MBF04) - -! the array absa(585,NG04) = ka(9,5,13,NG04) contains absorption coefs -! at the NG04=14 g-intervals for a range of pressure levels > ~100mb, -! temperatures, and ratios of water vapor to co2. the first index in -! the array, js, runs from 1 to 9 and corresponds to different water -! vapor to co2 ratios, as expressed through the binary species parameter -! eta, defined as eta = h2o/(h20+rat*co2), where rat is the ratio of -! the integrated line strength in the band of co2 to that of h2o. for -! instance, js=1 refers to dry air (eta = 0), js = 9 corresponds to -! eta = 1.0. the 2nd index in the array, jt, which runs from 1 to 5, -! corresponds to different temperatures. more specifically, jt = 1-5 -! means that the data are for the corresponding temperature of -! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the -! third index, jp, runs from 1 to 13 and refers to the reference -! pressure level (e.g. jp = 1 is for a pressure of 1053.63 mb). the -! fourth index, ig, goes from 1 to NG04=14, and tells us which -! g-interval the absorption coefficients are for. - - data absa(1:270,1) / & - &6.652000e-04,9.365100e-04,1.419500e-03,1.725500e-03,1.763600e-03, & - &1.917900e-03,2.220400e-03,6.652100e-04,2.956000e-04,7.262400e-04, & - &1.046600e-03,1.388800e-03,1.709600e-03,1.789700e-03,1.856100e-03, & - &2.130000e-03,7.262400e-04,3.110300e-04,7.838300e-04,1.158400e-03, & - &1.407100e-03,1.642000e-03,1.716000e-03,1.851800e-03,1.880200e-03, & - &7.838200e-04,3.391400e-04,8.382800e-04,1.257000e-03,1.427700e-03, & - &1.540600e-03,1.660100e-03,1.766100e-03,1.913500e-03,8.382800e-04, & - &3.497600e-04,8.904200e-04,1.336300e-03,1.462300e-03,1.494900e-03, & - &1.594800e-03,1.720900e-03,1.880000e-03,8.904200e-04,3.633900e-04, & - &5.606200e-04,7.712700e-04,1.208400e-03,1.430700e-03,1.461000e-03, & - &1.605200e-03,1.846500e-03,5.606400e-04,2.262200e-04,6.137500e-04, & - &8.638000e-04,1.170100e-03,1.433600e-03,1.489500e-03,1.575600e-03, & - &1.778900e-03,6.137500e-04,2.413700e-04,6.644300e-04,9.595300e-04, & - &1.178100e-03,1.415800e-03,1.469300e-03,1.560600e-03,1.569400e-03, & - &6.644300e-04,2.632000e-04,7.131500e-04,1.047800e-03,1.197500e-03, & - &1.312800e-03,1.420700e-03,1.529900e-03,1.620400e-03,7.131500e-04, & - &2.669700e-04,7.611000e-04,1.119600e-03,1.229400e-03,1.263600e-03, & - &1.341600e-03,1.429200e-03,1.610300e-03,7.611000e-04,2.817600e-04, & - &4.561000e-04,6.153200e-04,1.063400e-03,1.182800e-03,1.232100e-03, & - &1.340700e-03,1.558500e-03,4.561000e-04,1.718800e-04,5.023800e-04, & - &6.902100e-04,9.817900e-04,1.212400e-03,1.237500e-03,1.335900e-03, & - &1.539600e-03,5.023800e-04,1.849200e-04,5.473500e-04,7.724900e-04, & - &9.840199e-04,1.206800e-03,1.254600e-03,1.297500e-03,1.428300e-03, & - &5.473500e-04,1.993900e-04,5.911200e-04,8.527500e-04,9.983300e-04, & - &1.143200e-03,1.214300e-03,1.305300e-03,1.331600e-03,5.911100e-04, & - &2.033400e-04,6.342200e-04,9.193300e-04,1.019900e-03,1.085200e-03, & - &1.154000e-03,1.214500e-03,1.376000e-03,6.342200e-04,2.158300e-04, & - &3.642300e-04,4.871400e-04,9.413900e-04,9.650700e-04,9.910400e-04, & - &1.074000e-03,1.279700e-03,3.642300e-04,1.390500e-04,4.044800e-04, & - &5.435300e-04,8.404100e-04,9.990000e-04,1.027000e-03,1.112900e-03, & - &1.259400e-03,4.044800e-04,1.487500e-04,4.440100e-04,6.120100e-04, & - &8.174800e-04,1.020500e-03,1.040600e-03,1.094300e-03,1.224900e-03, & - &4.440100e-04,1.555900e-04,4.829100e-04,6.810700e-04,8.221800e-04, & - &9.957600e-04,1.051500e-03,1.100600e-03,1.125200e-03,4.829100e-04, & - &1.619000e-04,5.212300e-04,7.434300e-04,8.415100e-04,9.301900e-04, & - &1.013000e-03,1.078500e-03,1.143900e-03,5.212300e-04,1.716500e-04, & - &2.876300e-04,3.865400e-04,7.783800e-04,7.846700e-04,8.081700e-04, & - &8.993800e-04,1.067600e-03,2.876300e-04,1.248500e-04,3.226900e-04, & - &4.283000e-04,7.459000e-04,8.188700e-04,8.567400e-04,9.174400e-04, & - &1.059800e-03,3.226900e-04,1.288800e-04,3.571000e-04,4.815000e-04, & - &6.830100e-04,8.401400e-04,8.544700e-04,9.408200e-04,1.059500e-03, & - &3.571000e-04,1.328700e-04,3.911400e-04,5.404400e-04,6.791300e-04, & - &8.559800e-04,8.645100e-04,8.976800e-04,1.016000e-03,3.911400e-04, & - &1.380100e-04,4.249300e-04,5.961600e-04,6.908100e-04,8.143200e-04, & - &8.708600e-04,9.023000e-04,9.275100e-04,4.249300e-04,1.452400e-04, & - &2.239700e-04,3.035200e-04,6.289300e-04,6.263300e-04,6.579300e-04, & - &7.340300e-04,8.435000e-04,2.239700e-04,1.210700e-04,2.542000e-04, & - &3.355700e-04,6.579700e-04,6.689100e-04,6.849100e-04,7.402300e-04, & - &8.568700e-04,2.542000e-04,1.228000e-04,2.839600e-04,3.765500e-04, & - &5.910200e-04,6.903300e-04,7.178300e-04,7.666700e-04,8.637600e-04, & - &2.839600e-04,1.257700e-04,3.135000e-04,4.240400e-04,5.610900e-04, & - &7.163200e-04,7.216900e-04,7.590200e-04,8.506300e-04,3.135000e-04, & - &1.303800e-04,3.428300e-04,4.725900e-04,5.631500e-04,6.966900e-04, & - &7.376700e-04,7.626600e-04,8.117900e-04,3.428300e-04,1.359400e-04/ - data absa(271:585,1) / & - &1.726900e-04,2.397100e-04,5.029700e-04,4.986000e-04,5.247100e-04, & - &5.793200e-04,6.843900e-04,1.726900e-04,1.238600e-04,1.984300e-04, & - &2.625900e-04,5.353200e-04,5.372900e-04,5.560600e-04,6.093900e-04, & - &7.123000e-04,1.984300e-04,1.261500e-04,2.239300e-04,2.936200e-04, & - &5.335000e-04,5.638400e-04,5.875000e-04,6.258000e-04,7.225500e-04, & - &2.239300e-04,1.302100e-04,2.492500e-04,3.315600e-04,4.693400e-04, & - &5.825000e-04,5.935900e-04,6.545300e-04,7.230500e-04,2.492500e-04, & - &1.352300e-04,2.747200e-04,3.718400e-04,4.628300e-04,5.997700e-04, & - &6.030300e-04,6.209400e-04,7.062900e-04,2.747200e-04,1.412600e-04, & - &1.322100e-04,1.919900e-04,3.977000e-04,3.993900e-04,4.180700e-04, & - &4.573100e-04,5.298800e-04,1.322100e-04,1.450900e-04,1.539300e-04, & - &2.055900e-04,4.325000e-04,4.290800e-04,4.496800e-04,4.958100e-04, & - &5.688500e-04,1.539300e-04,1.503800e-04,1.755800e-04,2.291200e-04, & - &4.552500e-04,4.599600e-04,4.714000e-04,5.138500e-04,5.903300e-04, & - &1.755800e-04,1.576400e-04,1.971100e-04,2.582400e-04,4.099000e-04, & - &4.760000e-04,4.938300e-04,5.272700e-04,5.917300e-04,1.971100e-04, & - &1.667400e-04,2.189200e-04,2.915700e-04,3.826800e-04,4.945100e-04, & - &4.988300e-04,5.270000e-04,5.943800e-04,2.189200e-04,1.774600e-04, & - &1.003500e-04,1.595200e-04,3.129300e-04,3.134800e-04,3.266600e-04, & - &3.702800e-04,4.142500e-04,1.003500e-04,2.666900e-04,1.185800e-04, & - &1.634600e-04,3.452900e-04,3.416500e-04,3.565700e-04,3.928900e-04, & - &4.594900e-04,1.185800e-04,2.907600e-04,1.369300e-04,1.786600e-04, & - &3.670000e-04,3.708300e-04,3.833600e-04,4.166800e-04,4.818000e-04, & - &1.369300e-04,3.156700e-04,1.551800e-04,2.011100e-04,3.663500e-04, & - &3.885500e-04,4.047100e-04,4.304300e-04,4.928500e-04,1.551800e-04, & - &3.420900e-04,1.736200e-04,2.275400e-04,3.220100e-04,4.029100e-04, & - &4.125800e-04,4.491300e-04,4.961300e-04,1.736200e-04,3.692100e-04, & - &7.675600e-05,1.396200e-04,2.476700e-04,2.491200e-04,2.596800e-04, & - &2.865300e-04,3.299200e-04,7.675600e-05,9.233200e-04,9.197200e-05, & - &1.317700e-04,2.749800e-04,2.746000e-04,2.876800e-04,3.148600e-04, & - &3.611700e-04,9.197200e-05,1.029000e-03,1.074700e-04,1.412900e-04, & - &2.976200e-04,2.972800e-04,3.108000e-04,3.392700e-04,3.854200e-04, & - &1.074700e-04,1.125800e-03,1.229500e-04,1.584300e-04,3.085000e-04, & - &3.153500e-04,3.252900e-04,3.538700e-04,4.042200e-04,1.229500e-04, & - &1.211900e-03,1.385000e-04,1.791900e-04,2.796900e-04,3.291800e-04, & - &3.414100e-04,3.638300e-04,4.059200e-04,1.385000e-04,1.288500e-03, & - &6.426200e-05,1.148800e-04,2.065200e-04,2.069300e-04,2.151500e-04, & - &2.375900e-04,2.707400e-04,6.426200e-05,1.743600e-03,7.706300e-05, & - &1.091000e-04,2.289300e-04,2.283700e-04,2.388000e-04,2.598700e-04, & - &3.006500e-04,7.706200e-05,1.935200e-03,9.012600e-05,1.175900e-04, & - &2.467700e-04,2.475200e-04,2.593200e-04,2.816800e-04,3.206400e-04, & - &9.012600e-05,2.101500e-03,1.031800e-04,1.320400e-04,2.534900e-04, & - &2.611700e-04,2.704700e-04,2.944500e-04,3.335400e-04,1.031800e-04, & - &2.237500e-03,1.162500e-04,1.497900e-04,2.304700e-04,2.728800e-04, & - &2.831600e-04,3.022200e-04,3.371700e-04,1.162500e-04,2.349900e-03, & - &5.383800e-05,9.447200e-05,1.722100e-04,1.722900e-04,1.791200e-04, & - &1.981100e-04,2.229800e-04,5.383800e-05,2.219000e-03,6.458300e-05, & - &9.041600e-05,1.907000e-04,1.899700e-04,1.985100e-04,2.162100e-04, & - &2.488300e-04,6.458300e-05,2.450800e-03,7.557900e-05,9.814600e-05, & - &2.047900e-04,2.055600e-04,2.150800e-04,2.347500e-04,2.656400e-04, & - &7.557900e-05,2.646000e-03,8.653100e-05,1.100800e-04,2.088700e-04, & - &2.163000e-04,2.243000e-04,2.441600e-04,2.768800e-04,8.653100e-05, & - &2.801300e-03,9.742700e-05,1.249000e-04,1.885900e-04,2.259600e-04, & - &2.333600e-04,2.505700e-04,2.788800e-04,9.742700e-05,2.923600e-03, & - &4.509900e-05,7.751300e-05,1.432500e-04,1.438700e-04,1.490000e-04, & - &1.640400e-04,1.847000e-04,4.510000e-05,2.313600e-03,5.413700e-05, & - &7.516300e-05,1.587000e-04,1.579700e-04,1.650500e-04,1.793400e-04, & - &2.068700e-04,5.413700e-05,2.540300e-03,6.332900e-05,8.172700e-05, & - &1.696500e-04,1.706300e-04,1.787100e-04,1.951200e-04,2.203500e-04, & - &6.332900e-05,2.728200e-03,7.245000e-05,9.177800e-05,1.721900e-04, & - &1.791400e-04,1.863500e-04,2.020300e-04,2.294300e-04,7.245000e-05, & - &2.878800e-03,8.153000e-05,1.039700e-04,1.547600e-04,1.873900e-04, & - &1.932200e-04,2.081900e-04,2.307100e-04,8.153000e-05,2.995000e-03/ - data absa(1:270,2) / & - &1.526000e-03,1.759500e-03,1.648000e-03,2.225800e-03,2.834400e-03, & - &3.146900e-03,3.691800e-03,1.526000e-03,4.991400e-04,1.582600e-03, & - &1.821200e-03,1.756100e-03,1.998000e-03,2.468100e-03,2.968400e-03, & - &3.287200e-03,1.582600e-03,4.641500e-04,1.622700e-03,1.857100e-03, & - &1.835000e-03,1.903200e-03,2.304600e-03,2.722000e-03,3.303000e-03, & - &1.622700e-03,4.623100e-04,1.662700e-03,1.901600e-03,1.945000e-03, & - &1.994500e-03,2.241400e-03,2.532700e-03,2.836300e-03,1.662700e-03, & - &4.951600e-04,1.694200e-03,1.956700e-03,2.028200e-03,2.117800e-03, & - &2.183700e-03,2.328900e-03,2.695100e-03,1.694200e-03,5.560400e-04, & - &1.295700e-03,1.473600e-03,1.369600e-03,1.921900e-03,2.444800e-03, & - &2.718500e-03,3.097300e-03,1.295700e-03,3.577700e-04,1.352000e-03, & - &1.535200e-03,1.459400e-03,1.736300e-03,2.160800e-03,2.593100e-03, & - &2.947700e-03,1.352000e-03,3.533400e-04,1.395500e-03,1.572800e-03, & - &1.538800e-03,1.591000e-03,1.965200e-03,2.396500e-03,2.821400e-03, & - &1.395500e-03,3.520800e-04,1.430600e-03,1.611900e-03,1.628900e-03, & - &1.666800e-03,1.874900e-03,2.151500e-03,2.579800e-03,1.430600e-03, & - &3.890300e-04,1.461800e-03,1.664800e-03,1.711200e-03,1.769600e-03, & - &1.865800e-03,2.039000e-03,2.263000e-03,1.461800e-03,4.350100e-04, & - &1.094100e-03,1.224900e-03,1.111000e-03,1.697800e-03,2.075700e-03, & - &2.397700e-03,2.538500e-03,1.094100e-03,2.543500e-04,1.149600e-03, & - &1.289300e-03,1.209400e-03,1.540000e-03,1.903700e-03,2.228200e-03, & - &2.610800e-03,1.149600e-03,2.584400e-04,1.192600e-03,1.327800e-03, & - &1.271700e-03,1.359000e-03,1.708800e-03,2.181200e-03,2.339200e-03, & - &1.192600e-03,2.680400e-04,1.226700e-03,1.358900e-03,1.347300e-03, & - &1.369000e-03,1.604200e-03,1.929000e-03,2.350700e-03,1.226700e-03, & - &3.006500e-04,1.255400e-03,1.403400e-03,1.426900e-03,1.446200e-03, & - &1.580300e-03,1.789100e-03,1.993400e-03,1.255400e-03,3.352900e-04, & - &9.222800e-04,1.014400e-03,8.915500e-04,1.552300e-03,1.818200e-03, & - &2.079000e-03,2.101900e-03,9.222900e-04,1.973900e-04,9.717300e-04, & - &1.076400e-03,9.909400e-04,1.356300e-03,1.713000e-03,1.918200e-03, & - &2.166600e-03,9.717300e-04,1.990000e-04,1.013800e-03,1.115100e-03, & - &1.044500e-03,1.225100e-03,1.536900e-03,1.852100e-03,2.101300e-03, & - &1.013800e-03,2.127600e-04,1.047300e-03,1.146000e-03,1.116100e-03, & - &1.128400e-03,1.357800e-03,1.675400e-03,2.007700e-03,1.047300e-03, & - &2.359500e-04,1.072600e-03,1.180500e-03,1.181400e-03,1.184800e-03, & - &1.347900e-03,1.561500e-03,1.899400e-03,1.072600e-03,2.616500e-04, & - &7.669000e-04,8.276500e-04,7.806200e-04,1.386700e-03,1.586700e-03, & - &1.693600e-03,1.752100e-03,7.669000e-04,1.628000e-04,8.128500e-04, & - &8.877400e-04,7.834100e-04,1.198800e-03,1.477000e-03,1.671900e-03, & - &1.769300e-03,8.128500e-04,1.676800e-04,8.518300e-04,9.293000e-04, & - &8.609800e-04,1.103500e-03,1.351700e-03,1.587100e-03,1.846800e-03, & - &8.518200e-04,1.791800e-04,8.838100e-04,9.600500e-04,9.154700e-04, & - &9.461000e-04,1.239600e-03,1.575700e-03,1.671900e-03,8.838100e-04, & - &1.952800e-04,9.078000e-04,9.903800e-04,9.786700e-04,9.638500e-04, & - &1.136300e-03,1.375000e-03,1.675900e-03,9.078000e-04,2.143000e-04, & - &6.279500e-04,6.683800e-04,7.356100e-04,1.226300e-03,1.368300e-03, & - &1.404600e-03,1.509400e-03,6.279500e-04,1.521600e-04,6.718300e-04, & - &7.228800e-04,6.180100e-04,1.091900e-03,1.271200e-03,1.475700e-03, & - &1.481400e-03,6.718300e-04,1.589400e-04,7.077300e-04,7.651300e-04, & - &6.891200e-04,9.697400e-04,1.194500e-03,1.367100e-03,1.517000e-03, & - &7.077300e-04,1.689700e-04,7.381600e-04,7.978200e-04,7.447300e-04, & - &8.706500e-04,1.102800e-03,1.331000e-03,1.498200e-03,7.381600e-04, & - &1.808300e-04,7.617300e-04,8.255700e-04,8.069600e-04,7.965300e-04, & - &9.717100e-04,1.200100e-03,1.435000e-03,7.617300e-04,1.954400e-04/ - data absa(271:585,2) / & - &5.089100e-04,5.328000e-04,7.282000e-04,1.060000e-03,1.189700e-03, & - &1.202800e-03,1.264500e-03,5.089100e-04,1.681900e-04,5.501900e-04, & - &5.855900e-04,5.505000e-04,9.818900e-04,1.113300e-03,1.199400e-03, & - &1.217700e-03,5.501900e-04,1.774000e-04,5.843800e-04,6.258800e-04, & - &5.219200e-04,8.687500e-04,1.039900e-03,1.176100e-03,1.221400e-03, & - &5.843800e-04,1.889700e-04,6.123900e-04,6.568200e-04,6.071300e-04, & - &7.780800e-04,9.733100e-04,1.114000e-03,1.301400e-03,6.123900e-04, & - &2.029000e-04,6.346700e-04,6.841900e-04,6.529500e-04,6.755400e-04, & - &8.811900e-04,1.113300e-03,1.205300e-03,6.346700e-04,2.187200e-04, & - &4.093500e-04,4.188500e-04,6.710100e-04,9.125600e-04,1.019400e-03, & - &1.013500e-03,1.081900e-03,4.093500e-04,2.182400e-04,4.469200e-04, & - &4.711800e-04,5.165900e-04,8.591300e-04,9.635700e-04,9.884600e-04, & - &1.042900e-03,4.469200e-04,2.369000e-04,4.790300e-04,5.092100e-04, & - &4.251300e-04,7.786600e-04,8.942300e-04,1.020500e-03,1.021300e-03, & - &4.790300e-04,2.581900e-04,5.051900e-04,5.387300e-04,4.747000e-04, & - &6.824200e-04,8.492500e-04,9.608200e-04,1.056500e-03,5.051900e-04, & - &2.816900e-04,5.264600e-04,5.635500e-04,5.317300e-04,6.213400e-04, & - &7.850300e-04,9.370600e-04,1.032200e-03,5.264700e-04,3.057400e-04, & - &3.263900e-04,3.206200e-04,6.170700e-04,7.954000e-04,8.456400e-04, & - &8.581700e-04,9.072300e-04,3.263900e-04,5.554500e-04,3.601200e-04, & - &3.731900e-04,5.022600e-04,7.425400e-04,8.402300e-04,8.330100e-04, & - &8.572800e-04,3.601200e-04,6.116500e-04,3.898700e-04,4.122500e-04, & - &3.790700e-04,6.853000e-04,7.788100e-04,8.377800e-04,8.481700e-04, & - &3.898700e-04,6.665300e-04,4.142400e-04,4.391000e-04,3.605100e-04, & - &6.100000e-04,7.290200e-04,8.199900e-04,8.439600e-04,4.142400e-04, & - &7.181900e-04,4.343100e-04,4.623900e-04,4.228800e-04,5.488000e-04, & - &6.886700e-04,7.786600e-04,8.909700e-04,4.343100e-04,7.720200e-04, & - &2.606200e-04,2.409700e-04,5.676000e-04,6.783800e-04,7.083900e-04, & - &7.458200e-04,7.558300e-04,2.606200e-04,2.527700e-03,2.902300e-04, & - &2.954500e-04,4.517300e-04,6.299400e-04,7.172700e-04,7.000100e-04, & - &7.342000e-04,2.902200e-04,2.778400e-03,3.170200e-04,3.329400e-04, & - &3.452700e-04,5.979300e-04,6.677400e-04,6.935200e-04,7.131200e-04, & - &3.170200e-04,3.014500e-03,3.391900e-04,3.581500e-04,2.945900e-04, & - &5.360900e-04,6.295200e-04,7.002900e-04,6.997200e-04,3.391900e-04, & - &3.222200e-03,3.576800e-04,3.792300e-04,3.287400e-04,4.754900e-04, & - &5.948300e-04,6.731100e-04,7.361300e-04,3.576800e-04,3.403500e-03, & - &2.190700e-04,2.032800e-04,4.641900e-04,5.629700e-04,5.890700e-04, & - &6.115500e-04,6.101300e-04,2.190700e-04,5.124200e-03,2.441000e-04, & - &2.484300e-04,3.713000e-04,5.228400e-04,5.976200e-04,5.858500e-04, & - &6.013500e-04,2.441100e-04,5.586400e-03,2.662500e-04,2.793000e-04, & - &2.818900e-04,4.940500e-04,5.540200e-04,5.772000e-04,5.857100e-04, & - &2.662500e-04,6.006600e-03,2.848700e-04,3.001800e-04,2.447200e-04, & - &4.420000e-04,5.265200e-04,5.824800e-04,5.796100e-04,2.848700e-04, & - &6.376300e-03,3.001000e-04,3.171900e-04,2.731100e-04,3.920100e-04, & - &4.942700e-04,5.630600e-04,6.163100e-04,3.001000e-04,6.680400e-03, & - &1.839400e-04,1.711800e-04,3.773000e-04,4.679200e-04,4.897500e-04, & - &4.991700e-04,5.039700e-04,1.839400e-04,6.795300e-03,2.048800e-04, & - &2.089100e-04,3.035500e-04,4.353600e-04,4.919500e-04,4.836900e-04, & - &4.961500e-04,2.048800e-04,7.372200e-03,2.233800e-04,2.337000e-04, & - &2.285300e-04,4.084800e-04,4.605700e-04,4.813900e-04,4.829300e-04, & - &2.233800e-04,7.888800e-03,2.390500e-04,2.512600e-04,2.015600e-04, & - &3.655700e-04,4.399200e-04,4.819500e-04,4.852600e-04,2.390500e-04, & - &8.318100e-03,2.512900e-04,2.646700e-04,2.290500e-04,3.227300e-04, & - &4.123000e-04,4.663000e-04,5.124800e-04,2.512900e-04,8.638600e-03, & - &1.543000e-04,1.444200e-04,3.080500e-04,3.895000e-04,4.076700e-04, & - &4.117900e-04,4.133000e-04,1.543000e-04,7.305300e-03,1.717900e-04, & - &1.751000e-04,2.481800e-04,3.619800e-04,4.062500e-04,3.997400e-04, & - &4.116600e-04,1.717900e-04,7.902200e-03,1.874100e-04,1.957500e-04, & - &1.860400e-04,3.367000e-04,3.827200e-04,4.014500e-04,4.006000e-04, & - &1.874100e-04,8.414500e-03,2.003100e-04,2.097500e-04,1.665600e-04, & - &3.037900e-04,3.676900e-04,4.007800e-04,4.018700e-04,2.003200e-04, & - &8.801800e-03,2.101800e-04,2.207600e-04,1.915900e-04,2.644800e-04, & - &3.443200e-04,3.851200e-04,4.242000e-04,2.101800e-04,9.068000e-03/ - data absa(1:270,3) / & - &2.346500e-03,2.403100e-03,2.259700e-03,2.152400e-03,2.827600e-03, & - &3.576100e-03,4.307900e-03,2.346500e-03,5.147100e-04,2.304200e-03, & - &2.448500e-03,2.419900e-03,2.293800e-03,2.984700e-03,3.195200e-03, & - &4.166700e-03,2.304200e-03,6.231900e-04,2.270000e-03,2.496600e-03, & - &2.586200e-03,2.651100e-03,2.873800e-03,2.916400e-03,3.611800e-03, & - &2.270000e-03,7.422900e-04,2.250900e-03,2.557300e-03,2.758100e-03, & - &2.971800e-03,3.065700e-03,3.337600e-03,3.160000e-03,2.250900e-03, & - &8.597700e-04,2.242200e-03,2.635500e-03,2.955200e-03,3.253100e-03, & - &3.429600e-03,3.455800e-03,3.280800e-03,2.242200e-03,9.976600e-04, & - &2.015700e-03,2.051000e-03,1.885100e-03,1.820600e-03,2.434300e-03, & - &2.970400e-03,3.831100e-03,2.015700e-03,4.139600e-04,1.981500e-03, & - &2.088600e-03,2.043900e-03,1.893800e-03,2.520400e-03,2.712800e-03, & - &3.335000e-03,1.981500e-03,4.803900e-04,1.957600e-03,2.132600e-03, & - &2.179000e-03,2.179500e-03,2.488200e-03,2.494100e-03,3.210900e-03, & - &1.957500e-03,5.795500e-04,1.948100e-03,2.182900e-03,2.323500e-03, & - &2.467600e-03,2.609700e-03,2.834900e-03,2.586800e-03,1.948100e-03, & - &6.671400e-04,1.950700e-03,2.252100e-03,2.491200e-03,2.735600e-03, & - &2.898700e-03,2.941800e-03,2.783000e-03,1.950700e-03,7.752300e-04, & - &1.728500e-03,1.737700e-03,1.530500e-03,1.675700e-03,2.168000e-03, & - &2.560900e-03,3.388700e-03,1.728500e-03,3.228000e-04,1.701500e-03, & - &1.765300e-03,1.687800e-03,1.511200e-03,2.171900e-03,2.408300e-03, & - &2.806100e-03,1.701500e-03,3.741200e-04,1.685100e-03,1.810100e-03, & - &1.807300e-03,1.753900e-03,2.239800e-03,2.111200e-03,2.733300e-03, & - &1.685100e-03,4.315700e-04,1.678600e-03,1.856700e-03,1.929100e-03, & - &1.992700e-03,2.134700e-03,2.269300e-03,2.280100e-03,1.678600e-03, & - &5.044800e-04,1.687700e-03,1.915600e-03,2.071000e-03,2.242000e-03, & - &2.362500e-03,2.531000e-03,2.318200e-03,1.687700e-03,5.858300e-04, & - &1.483400e-03,1.471100e-03,1.252200e-03,1.447900e-03,1.985400e-03, & - &2.256900e-03,2.977500e-03,1.483400e-03,2.508100e-04,1.460100e-03, & - &1.487000e-03,1.369000e-03,1.266200e-03,1.806000e-03,2.082600e-03, & - &2.497700e-03,1.460100e-03,2.927700e-04,1.446700e-03,1.527100e-03, & - &1.497900e-03,1.350000e-03,1.849700e-03,1.961000e-03,2.290700e-03, & - &1.446700e-03,3.327100e-04,1.443200e-03,1.571400e-03,1.596900e-03, & - &1.593700e-03,1.790200e-03,1.932000e-03,2.242000e-03,1.443200e-03, & - &3.846700e-04,1.455000e-03,1.623600e-03,1.712700e-03,1.806800e-03, & - &1.848600e-03,2.117600e-03,1.801800e-03,1.455100e-03,4.455100e-04, & - &1.277300e-03,1.249700e-03,1.006400e-03,1.250600e-03,1.735200e-03, & - &2.106400e-03,2.518800e-03,1.277300e-03,2.102500e-04,1.259500e-03, & - &1.263400e-03,1.114700e-03,1.129600e-03,1.582400e-03,1.807500e-03, & - &2.297800e-03,1.259500e-03,2.360100e-04,1.247100e-03,1.290700e-03, & - &1.222600e-03,1.055900e-03,1.555600e-03,1.726400e-03,1.831900e-03, & - &1.247100e-03,2.667400e-04,1.246000e-03,1.327700e-03,1.323200e-03, & - &1.283900e-03,1.526600e-03,1.563900e-03,1.903000e-03,1.246000e-03, & - &3.049100e-04,1.257500e-03,1.372100e-03,1.414300e-03,1.445300e-03, & - &1.500600e-03,1.767400e-03,1.743600e-03,1.257500e-03,3.506000e-04, & - &1.095800e-03,1.059500e-03,7.766400e-04,1.108500e-03,1.539300e-03, & - &1.933800e-03,2.193400e-03,1.095800e-03,1.964500e-04,1.081600e-03, & - &1.072700e-03,9.069500e-04,1.002300e-03,1.443400e-03,1.585600e-03, & - &2.029100e-03,1.081600e-03,2.120800e-04,1.071000e-03,1.088800e-03, & - &9.912900e-04,8.744300e-04,1.317900e-03,1.503300e-03,1.707700e-03, & - &1.071000e-03,2.348100e-04,1.070800e-03,1.118600e-03,1.087400e-03, & - &9.596900e-04,1.267100e-03,1.401000e-03,1.591700e-03,1.070800e-03, & - &2.633900e-04,1.080600e-03,1.157200e-03,1.163100e-03,1.154500e-03, & - &1.248500e-03,1.429400e-03,1.600400e-03,1.080600e-03,2.980300e-04/ - data absa(271:585,3) / & - &9.334800e-04,8.909200e-04,5.716100e-04,1.020800e-03,1.378400e-03, & - &1.703700e-03,1.893500e-03,9.334800e-04,2.114600e-04,9.217100e-04, & - &9.032900e-04,7.147700e-04,8.490300e-04,1.277800e-03,1.494500e-03, & - &1.727000e-03,9.217100e-04,2.300500e-04,9.141900e-04,9.192000e-04, & - &8.116000e-04,7.643500e-04,1.121300e-03,1.330100e-03,1.621400e-03, & - &9.141900e-04,2.523400e-04,9.140200e-04,9.396800e-04,8.812600e-04, & - &7.528700e-04,1.057000e-03,1.247500e-03,1.299800e-03,9.140200e-04, & - &2.781500e-04,9.229000e-04,9.725400e-04,9.564400e-04,8.947900e-04, & - &1.050800e-03,1.126800e-03,1.350100e-03,9.229000e-04,3.080600e-04, & - &7.890000e-04,7.448800e-04,4.621800e-04,9.631800e-04,1.237200e-03, & - &1.523700e-03,1.672200e-03,7.890000e-04,3.076500e-04,7.804300e-04, & - &7.542800e-04,5.436600e-04,7.590900e-04,1.087900e-03,1.355000e-03, & - &1.479400e-03,7.804300e-04,3.386400e-04,7.746600e-04,7.698000e-04, & - &6.496300e-04,7.000900e-04,9.764900e-04,1.168900e-03,1.432600e-03, & - &7.746600e-04,3.728600e-04,7.750600e-04,7.887000e-04,7.157500e-04, & - &6.186400e-04,8.956500e-04,1.070800e-03,1.238700e-03,7.750600e-04, & - &4.107000e-04,7.828700e-04,8.156100e-04,7.783600e-04,6.683800e-04, & - &8.845300e-04,9.515800e-04,1.162000e-03,7.828700e-04,4.522200e-04, & - &6.635300e-04,6.220700e-04,4.149700e-04,8.532500e-04,1.154500e-03, & - &1.320200e-03,1.454300e-03,6.635300e-04,9.225500e-04,6.582400e-04, & - &6.278600e-04,3.933900e-04,7.116400e-04,9.591000e-04,1.224800e-03, & - &1.283400e-03,6.582400e-04,1.004700e-03,6.533100e-04,6.392100e-04, & - &5.101600e-04,5.965400e-04,8.759600e-04,1.085700e-03,1.214500e-03, & - &6.533100e-04,1.090000e-03,6.541300e-04,6.595000e-04,5.824400e-04, & - &5.397400e-04,7.925900e-04,9.302400e-04,1.160000e-03,6.541300e-04, & - &1.180100e-03,6.602200e-04,6.811000e-04,6.363900e-04,5.271600e-04, & - &7.231100e-04,8.501600e-04,9.625600e-04,6.602200e-04,1.268400e-03, & - &5.553700e-04,5.165800e-04,3.596900e-04,7.577800e-04,1.026800e-03, & - &1.118800e-03,1.238500e-03,5.553700e-04,4.664700e-03,5.529900e-04, & - &5.225900e-04,3.172800e-04,6.552600e-04,8.436300e-04,1.073800e-03, & - &1.079000e-03,5.529900e-04,4.996000e-03,5.488100e-04,5.306500e-04, & - &3.937300e-04,5.236100e-04,7.601400e-04,9.469700e-04,1.040900e-03, & - &5.488100e-04,5.303500e-03,5.501000e-04,5.487800e-04,4.703800e-04, & - &4.934200e-04,6.758300e-04,8.068300e-04,1.029900e-03,5.501000e-04, & - &5.605500e-03,5.559800e-04,5.687100e-04,5.224700e-04,4.361500e-04, & - &6.181500e-04,7.443100e-04,8.600800e-04,5.559800e-04,5.886600e-03, & - &4.638300e-04,4.318100e-04,2.931100e-04,6.261300e-04,8.446400e-04, & - &9.433200e-04,1.027600e-03,4.638300e-04,9.782000e-03,4.617100e-04, & - &4.364800e-04,2.656200e-04,5.338200e-04,6.968500e-04,9.017900e-04, & - &9.012800e-04,4.617100e-04,1.039800e-02,4.597100e-04,4.449100e-04, & - &3.350800e-04,4.326700e-04,6.386400e-04,7.794400e-04,8.892200e-04, & - &4.597100e-04,1.094400e-02,4.625900e-04,4.629800e-04,4.017500e-04, & - &4.089400e-04,5.587400e-04,6.657400e-04,8.637800e-04,4.625900e-04, & - &1.145200e-02,4.697400e-04,4.822300e-04,4.481900e-04,3.710400e-04, & - &5.100700e-04,6.109100e-04,6.909500e-04,4.697400e-04,1.191600e-02, & - &3.867700e-04,3.603500e-04,2.418400e-04,5.164700e-04,6.994500e-04, & - &8.046000e-04,8.371700e-04,3.867700e-04,1.327400e-02,3.852100e-04, & - &3.640200e-04,2.224200e-04,4.344700e-04,5.811000e-04,7.404700e-04, & - &7.632100e-04,3.852100e-04,1.406800e-02,3.845800e-04,3.729600e-04, & - &2.869600e-04,3.575100e-04,5.296000e-04,6.436600e-04,7.517900e-04, & - &3.845800e-04,1.475800e-02,3.881000e-04,3.894400e-04,3.437700e-04, & - &3.335500e-04,4.669200e-04,5.574600e-04,7.089500e-04,3.881000e-04, & - &1.537600e-02,3.959500e-04,4.086300e-04,3.812500e-04,3.120200e-04, & - &4.267800e-04,5.113100e-04,5.748900e-04,3.959500e-04,1.594100e-02, & - &3.219400e-04,2.997600e-04,1.985200e-04,4.256700e-04,5.752500e-04, & - &6.706100e-04,6.990700e-04,3.219400e-04,1.456500e-02,3.210300e-04, & - &3.034200e-04,1.851900e-04,3.515700e-04,4.879100e-04,6.193900e-04, & - &6.516000e-04,3.210300e-04,1.539500e-02,3.211300e-04,3.120500e-04, & - &2.441000e-04,2.957100e-04,4.408200e-04,5.295700e-04,6.274100e-04, & - &3.211200e-04,1.610700e-02,3.254200e-04,3.275400e-04,2.910300e-04, & - &2.667800e-04,3.885800e-04,4.666300e-04,5.770000e-04,3.254200e-04, & - &1.676400e-02,3.327100e-04,3.452200e-04,3.231300e-04,2.630600e-04, & - &3.532500e-04,4.278600e-04,4.775800e-04,3.327100e-04,1.732900e-02/ - data absa(1:270,4) / & - &3.253900e-03,3.494000e-03,3.438800e-03,3.065900e-03,3.452200e-03, & - &4.118800e-03,4.147200e-03,3.253900e-03,9.964600e-04,3.236300e-03, & - &3.604500e-03,3.702100e-03,3.590100e-03,3.146300e-03,4.336000e-03, & - &4.083800e-03,3.236300e-03,1.095600e-03,3.233400e-03,3.770000e-03, & - &3.960200e-03,3.962900e-03,3.808100e-03,4.292500e-03,5.121900e-03, & - &3.233400e-03,1.300700e-03,3.249000e-03,3.974800e-03,4.207100e-03, & - &4.293500e-03,4.316400e-03,4.260400e-03,5.603300e-03,3.249000e-03, & - &1.594400e-03,3.269800e-03,4.174000e-03,4.449700e-03,4.615500e-03, & - &4.804700e-03,5.153700e-03,5.555900e-03,3.269800e-03,1.911900e-03, & - &2.822900e-03,2.998400e-03,2.924800e-03,2.571000e-03,2.959100e-03, & - &3.568500e-03,3.347100e-03,2.822900e-03,7.103700e-04,2.818200e-03, & - &3.107900e-03,3.151000e-03,3.022000e-03,2.645600e-03,3.506500e-03, & - &3.509100e-03,2.818200e-03,8.294100e-04,2.827300e-03,3.264100e-03, & - &3.399100e-03,3.388200e-03,3.107600e-03,3.633900e-03,4.145300e-03, & - &2.827300e-03,9.932900e-04,2.847900e-03,3.453700e-03,3.637800e-03, & - &3.692200e-03,3.590200e-03,3.498500e-03,4.807900e-03,2.847900e-03, & - &1.220700e-03,2.876200e-03,3.643500e-03,3.864000e-03,3.982900e-03, & - &4.019600e-03,4.213700e-03,4.605700e-03,2.876200e-03,1.464500e-03, & - &2.448000e-03,2.550300e-03,2.427600e-03,1.929900e-03,2.439400e-03, & - &2.960000e-03,3.081900e-03,2.448000e-03,5.131000e-04,2.448400e-03, & - &2.648900e-03,2.624900e-03,2.461300e-03,2.189100e-03,2.811300e-03, & - &2.908500e-03,2.448400e-03,6.069500e-04,2.463100e-03,2.781700e-03, & - &2.857800e-03,2.802100e-03,2.336100e-03,3.195600e-03,3.291200e-03, & - &2.463100e-03,7.431300e-04,2.484300e-03,2.944000e-03,3.073400e-03, & - &3.094700e-03,2.959600e-03,2.962100e-03,3.825400e-03,2.484300e-03, & - &8.983100e-04,2.515200e-03,3.119000e-03,3.280100e-03,3.352700e-03, & - &3.337400e-03,3.265300e-03,3.726600e-03,2.515200e-03,1.079700e-03, & - &2.125000e-03,2.167000e-03,1.999000e-03,1.519900e-03,1.996200e-03, & - &2.499500e-03,2.902400e-03,2.125000e-03,3.753100e-04,2.120400e-03, & - &2.248900e-03,2.170000e-03,1.939900e-03,1.996300e-03,2.426600e-03, & - &2.600000e-03,2.120400e-03,4.475600e-04,2.141300e-03,2.358700e-03, & - &2.362700e-03,2.254400e-03,1.919500e-03,2.465800e-03,2.517200e-03, & - &2.141300e-03,5.470500e-04,2.165400e-03,2.498000e-03,2.566300e-03, & - &2.537300e-03,2.372800e-03,2.476900e-03,2.831800e-03,2.165400e-03, & - &6.612500e-04,2.191300e-03,2.645600e-03,2.753600e-03,2.781600e-03, & - &2.740500e-03,2.570200e-03,3.260500e-03,2.191300e-03,7.971400e-04, & - &1.826500e-03,1.838100e-03,1.645700e-03,1.248600e-03,1.722900e-03, & - &2.054700e-03,2.684800e-03,1.826500e-03,2.859600e-04,1.827400e-03, & - &1.904800e-03,1.798300e-03,1.475200e-03,1.746900e-03,2.111600e-03, & - &2.113400e-03,1.827400e-03,3.419000e-04,1.850800e-03,2.000300e-03, & - &1.962000e-03,1.818800e-03,1.607700e-03,1.951600e-03,2.107300e-03, & - &1.850800e-03,4.129200e-04,1.879300e-03,2.118200e-03,2.135000e-03, & - &2.051700e-03,1.808700e-03,2.207100e-03,2.271400e-03,1.879300e-03, & - &4.978900e-04,1.906500e-03,2.243500e-03,2.305300e-03,2.292600e-03, & - &2.222400e-03,2.082900e-03,2.556500e-03,1.906500e-03,5.997500e-04, & - &1.573800e-03,1.553600e-03,1.346200e-03,1.090500e-03,1.534500e-03, & - &1.837800e-03,2.369600e-03,1.573800e-03,2.457000e-04,1.578500e-03, & - &1.610200e-03,1.486400e-03,1.087800e-03,1.453300e-03,1.809600e-03, & - &1.920800e-03,1.578500e-03,2.865000e-04,1.593800e-03,1.688600e-03, & - &1.624200e-03,1.432900e-03,1.397100e-03,1.658800e-03,1.797700e-03, & - &1.593800e-03,3.364600e-04,1.620700e-03,1.790300e-03,1.774000e-03, & - &1.660900e-03,1.409000e-03,1.788000e-03,1.826400e-03,1.620700e-03, & - &3.992700e-04,1.651400e-03,1.894500e-03,1.918900e-03,1.870700e-03, & - &1.730900e-03,1.765100e-03,1.895600e-03,1.651400e-03,4.734100e-04/ - data absa(271:585,4) / & - &1.356600e-03,1.317600e-03,1.080000e-03,9.987900e-04,1.364500e-03, & - &1.671600e-03,2.013800e-03,1.356600e-03,2.711700e-04,1.361600e-03, & - &1.361400e-03,1.229400e-03,8.694300e-04,1.244100e-03,1.455700e-03, & - &1.762700e-03,1.361600e-03,3.049700e-04,1.373800e-03,1.425100e-03, & - &1.342400e-03,1.074800e-03,1.323900e-03,1.494800e-03,1.489300e-03, & - &1.373800e-03,3.454700e-04,1.390900e-03,1.506200e-03,1.467500e-03, & - &1.331400e-03,1.129900e-03,1.425600e-03,1.510100e-03,1.390900e-03, & - &3.936300e-04,1.421400e-03,1.593900e-03,1.592900e-03,1.515900e-03, & - &1.304400e-03,1.554600e-03,1.584700e-03,1.421400e-03,4.499900e-04, & - &1.163800e-03,1.113900e-03,8.479600e-04,8.466800e-04,1.239600e-03, & - &1.509400e-03,1.697500e-03,1.163800e-03,4.305200e-04,1.167100e-03, & - &1.149100e-03,9.970200e-04,7.189400e-04,1.115700e-03,1.283500e-03, & - &1.517100e-03,1.167100e-03,4.724400e-04,1.176300e-03,1.197100e-03, & - &1.106100e-03,7.562500e-04,1.094800e-03,1.322700e-03,1.324300e-03, & - &1.176300e-03,5.190800e-04,1.188200e-03,1.258200e-03,1.208100e-03, & - &1.041000e-03,9.493100e-04,1.211200e-03,1.235000e-03,1.188200e-03, & - &5.724200e-04,1.214100e-03,1.332200e-03,1.314200e-03,1.220800e-03, & - &9.867100e-04,1.312800e-03,1.345600e-03,1.214100e-03,6.312000e-04, & - &9.933700e-04,9.374300e-04,6.197000e-04,7.545600e-04,1.108900e-03, & - &1.340700e-03,1.506800e-03,9.933700e-04,1.442200e-03,9.947100e-04, & - &9.660100e-04,8.026300e-04,6.426000e-04,9.903500e-04,1.171000e-03, & - &1.328900e-03,9.947100e-04,1.549800e-03,1.002800e-03,1.003700e-03, & - &9.038800e-04,5.939400e-04,8.748500e-04,1.077900e-03,1.196800e-03, & - &1.002800e-03,1.663200e-03,1.013800e-03,1.050000e-03,9.879400e-04, & - &7.632200e-04,8.531200e-04,1.104700e-03,1.066400e-03,1.013800e-03, & - &1.776400e-03,1.032400e-03,1.107200e-03,1.075100e-03,9.675500e-04, & - &7.982900e-04,1.035400e-03,1.133900e-03,1.032400e-03,1.883600e-03, & - &8.439000e-04,7.888300e-04,4.549600e-04,6.397800e-04,9.706200e-04, & - &1.188800e-03,1.302500e-03,8.439000e-04,7.797800e-03,8.441700e-04, & - &8.104700e-04,6.403900e-04,5.586700e-04,8.677500e-04,1.010000e-03, & - &1.197200e-03,8.441700e-04,8.165100e-03,8.520900e-04,8.421800e-04, & - &7.370100e-04,4.805300e-04,7.550300e-04,9.450700e-04,1.039400e-03, & - &8.520900e-04,8.532000e-03,8.624300e-04,8.787100e-04,8.137800e-04, & - &5.479400e-04,7.569300e-04,9.409300e-04,9.069400e-04,8.624300e-04, & - &8.888600e-03,8.783800e-04,9.250000e-04,8.854400e-04,7.604400e-04, & - &6.423600e-04,8.235400e-04,9.454000e-04,8.783900e-04,9.232500e-03, & - &7.114000e-04,6.668600e-04,3.965900e-04,5.312800e-04,8.239000e-04, & - &9.633400e-04,1.053500e-03,7.114000e-04,1.675200e-02,7.147000e-04, & - &6.892800e-04,5.485700e-04,4.779000e-04,7.001700e-04,8.457800e-04, & - &9.623900e-04,7.147000e-04,1.746700e-02,7.240600e-04,7.182900e-04, & - &6.325200e-04,4.013600e-04,6.047300e-04,8.122900e-04,8.641300e-04, & - &7.240600e-04,1.815400e-02,7.375000e-04,7.508800e-04,6.960300e-04, & - &4.800700e-04,6.283400e-04,7.534500e-04,7.853000e-04,7.375000e-04, & - &1.877900e-02,7.557500e-04,7.936700e-04,7.560600e-04,6.521300e-04, & - &5.471800e-04,7.019300e-04,8.340400e-04,7.557500e-04,1.935200e-02, & - &5.982900e-04,5.615700e-04,3.434700e-04,4.414500e-04,6.800800e-04, & - &7.839700e-04,8.512700e-04,5.983000e-04,2.322300e-02,6.034400e-04, & - &5.838700e-04,4.695700e-04,3.973700e-04,5.769600e-04,7.207800e-04, & - &7.893000e-04,6.034400e-04,2.417100e-02,6.138300e-04,6.105700e-04, & - &5.401400e-04,3.430600e-04,5.045000e-04,6.794100e-04,7.330600e-04, & - &6.138300e-04,2.504200e-02,6.290900e-04,6.418700e-04,5.944300e-04, & - &4.204900e-04,5.124400e-04,6.192100e-04,6.811500e-04,6.290900e-04, & - &2.583000e-02,6.501000e-04,6.812300e-04,6.480500e-04,5.624300e-04, & - &4.555500e-04,5.806900e-04,6.976600e-04,6.501000e-04,2.653700e-02, & - &5.026900e-04,4.730900e-04,2.972200e-04,3.602900e-04,5.532700e-04, & - &6.726700e-04,6.964100e-04,5.026900e-04,2.594900e-02,5.086300e-04, & - &4.932400e-04,4.022700e-04,3.251200e-04,4.743500e-04,5.721800e-04, & - &6.496500e-04,5.086300e-04,2.696600e-02,5.199800e-04,5.175400e-04, & - &4.604200e-04,2.920000e-04,4.191900e-04,5.592000e-04,6.235500e-04, & - &5.199700e-04,2.790500e-02,5.356500e-04,5.472400e-04,5.086500e-04, & - &3.727300e-04,4.179900e-04,5.112500e-04,5.579000e-04,5.356500e-04, & - &2.873500e-02,5.569800e-04,5.837300e-04,5.555700e-04,4.851900e-04, & - &3.808000e-04,4.857500e-04,5.986600e-04,5.569800e-04,2.948100e-02/ - data absa(1:270,5) / & - &5.177300e-03,5.517900e-03,5.479400e-03,5.059000e-03,3.887000e-03, & - &4.629600e-03,5.924100e-03,5.177300e-03,1.527700e-03,5.203400e-03, & - &5.699300e-03,5.719500e-03,5.606500e-03,5.157100e-03,4.638300e-03, & - &6.999800e-03,5.203400e-03,2.032700e-03,5.252300e-03,5.878700e-03, & - &6.008400e-03,6.068400e-03,6.039700e-03,6.107300e-03,5.920800e-03, & - &5.252300e-03,2.512500e-03,5.305400e-03,6.074600e-03,6.301000e-03, & - &6.520500e-03,6.811100e-03,7.326900e-03,7.591500e-03,5.305400e-03, & - &3.025900e-03,5.367900e-03,6.288000e-03,6.589600e-03,6.976900e-03, & - &7.542600e-03,8.261600e-03,9.573400e-03,5.367900e-03,3.598800e-03, & - &4.605000e-03,4.890400e-03,4.782600e-03,4.281200e-03,3.096100e-03, & - &4.006600e-03,5.011500e-03,4.605000e-03,1.183300e-03,4.654600e-03, & - &5.066900e-03,5.015300e-03,4.802800e-03,4.237100e-03,3.857100e-03, & - &5.708200e-03,4.654500e-03,1.525000e-03,4.716300e-03,5.244500e-03, & - &5.281800e-03,5.219300e-03,5.040100e-03,4.815800e-03,4.811100e-03, & - &4.716300e-03,1.885100e-03,4.784000e-03,5.437500e-03,5.542800e-03, & - &5.614500e-03,5.755700e-03,6.097900e-03,6.065000e-03,4.784000e-03, & - &2.287200e-03,4.854100e-03,5.635000e-03,5.802900e-03,5.998300e-03, & - &6.391600e-03,6.922000e-03,7.841700e-03,4.854200e-03,2.741000e-03, & - &4.056600e-03,4.266600e-03,4.113600e-03,3.490200e-03,2.432000e-03, & - &3.744800e-03,4.059600e-03,4.056600e-03,8.553700e-04,4.119200e-03, & - &4.434300e-03,4.337400e-03,4.012600e-03,3.286300e-03,3.171000e-03, & - &4.691300e-03,4.119200e-03,1.091200e-03,4.188300e-03,4.606800e-03, & - &4.571000e-03,4.408000e-03,4.058700e-03,3.397000e-03,4.095000e-03, & - &4.188300e-03,1.356400e-03,4.260700e-03,4.787400e-03,4.830200e-03, & - &4.760000e-03,4.678900e-03,4.680300e-03,4.604600e-03,4.260700e-03, & - &1.658700e-03,4.329100e-03,4.972900e-03,5.082100e-03,5.113200e-03, & - &5.238900e-03,5.550100e-03,6.145300e-03,4.329100e-03,2.012300e-03, & - &3.545900e-03,3.682500e-03,3.493200e-03,2.763700e-03,1.920100e-03, & - &3.046000e-03,3.274900e-03,3.545900e-03,6.156100e-04,3.606100e-03, & - &3.836200e-03,3.718200e-03,3.322300e-03,2.349700e-03,2.662700e-03, & - &3.684500e-03,3.606100e-03,7.801100e-04,3.675100e-03,4.000900e-03, & - &3.935200e-03,3.721200e-03,3.158600e-03,2.659900e-03,3.928400e-03, & - &3.675100e-03,9.754100e-04,3.747200e-03,4.165700e-03,4.154700e-03, & - &4.047100e-03,3.757900e-03,3.498700e-03,3.468400e-03,3.747200e-03, & - &1.206000e-03,3.817300e-03,4.339200e-03,4.392600e-03,4.357500e-03, & - &4.291900e-03,4.273000e-03,4.366200e-03,3.817300e-03,1.474300e-03, & - &3.091100e-03,3.154700e-03,2.951700e-03,2.158500e-03,1.708900e-03, & - &2.506500e-03,2.673600e-03,3.091100e-03,4.525900e-04,3.143200e-03, & - &3.295200e-03,3.153500e-03,2.714400e-03,1.730500e-03,2.374000e-03, & - &2.917100e-03,3.143200e-03,5.694000e-04,3.201100e-03,3.441800e-03, & - &3.352600e-03,3.099800e-03,2.442400e-03,2.172800e-03,3.356300e-03, & - &3.201100e-03,7.131300e-04,3.269100e-03,3.592500e-03,3.547600e-03, & - &3.413000e-03,3.030400e-03,2.454200e-03,2.785300e-03,3.269100e-03, & - &8.864100e-04,3.341300e-03,3.750700e-03,3.751200e-03,3.695400e-03, & - &3.514400e-03,3.303900e-03,3.117400e-03,3.341300e-03,1.091300e-03, & - &2.681400e-03,2.694000e-03,2.470600e-03,1.624100e-03,1.579600e-03, & - &1.998600e-03,2.311100e-03,2.681400e-03,3.567300e-04,2.728600e-03, & - &2.817000e-03,2.656600e-03,2.195300e-03,1.395100e-03,2.018700e-03, & - &2.316700e-03,2.728600e-03,4.392800e-04,2.778400e-03,2.939600e-03, & - &2.832300e-03,2.543100e-03,1.804500e-03,1.858000e-03,2.523000e-03, & - &2.778400e-03,5.422500e-04,2.845700e-03,3.070700e-03,3.004000e-03, & - &2.831300e-03,2.430400e-03,1.875700e-03,2.428000e-03,2.845700e-03, & - &6.688000e-04,2.914900e-03,3.214500e-03,3.179100e-03,3.092700e-03, & - &2.871800e-03,2.502000e-03,2.411400e-03,2.914900e-03,8.209000e-04/ - data absa(271:585,5) / & - &2.316700e-03,2.295200e-03,2.069600e-03,1.177300e-03,1.400100e-03, & - &1.674200e-03,2.111300e-03,2.316700e-03,3.655600e-04,2.361700e-03, & - &2.399500e-03,2.227800e-03,1.756100e-03,1.222100e-03,1.703900e-03, & - &1.925200e-03,2.361700e-03,4.226400e-04,2.412500e-03,2.506600e-03, & - &2.381800e-03,2.080400e-03,1.264200e-03,1.632800e-03,2.016000e-03, & - &2.412400e-03,4.946600e-04,2.472600e-03,2.618900e-03,2.534600e-03, & - &2.333700e-03,1.928500e-03,1.539600e-03,2.285100e-03,2.472600e-03, & - &5.821100e-04,2.534800e-03,2.747300e-03,2.687000e-03,2.569600e-03, & - &2.323500e-03,1.815300e-03,1.952600e-03,2.534800e-03,6.881100e-04, & - &1.995500e-03,1.948800e-03,1.734300e-03,8.557600e-04,1.216900e-03, & - &1.398200e-03,1.880600e-03,1.995500e-03,5.842500e-04,2.036300e-03, & - &2.038500e-03,1.871500e-03,1.367800e-03,1.148800e-03,1.358300e-03, & - &1.663000e-03,2.036300e-03,6.494300e-04,2.084800e-03,2.135500e-03, & - &2.001600e-03,1.709900e-03,1.049000e-03,1.361200e-03,1.530400e-03, & - &2.084800e-03,7.203900e-04,2.140200e-03,2.234700e-03,2.137700e-03, & - &1.928100e-03,1.457600e-03,1.361500e-03,1.749400e-03,2.140200e-03, & - &7.914400e-04,2.191800e-03,2.343900e-03,2.273900e-03,2.132300e-03, & - &1.870100e-03,1.411700e-03,1.669400e-03,2.191800e-03,8.742800e-04, & - &1.708900e-03,1.646100e-03,1.436300e-03,6.601100e-04,1.023500e-03, & - &1.257600e-03,1.602100e-03,1.708900e-03,2.190500e-03,1.744900e-03, & - &1.724000e-03,1.561100e-03,9.593900e-04,1.017100e-03,1.093000e-03, & - &1.498000e-03,1.744900e-03,2.303200e-03,1.789200e-03,1.809500e-03, & - &1.677900e-03,1.370000e-03,8.873300e-04,1.197600e-03,1.236200e-03, & - &1.789200e-03,2.428500e-03,1.836900e-03,1.897500e-03,1.797500e-03, & - &1.588800e-03,1.020200e-03,1.188300e-03,1.343000e-03,1.836900e-03, & - &2.568000e-03,1.881200e-03,1.987400e-03,1.912300e-03,1.761400e-03, & - &1.464900e-03,1.149100e-03,1.571300e-03,1.881200e-03,2.722100e-03, & - &1.457200e-03,1.386800e-03,1.182600e-03,6.234600e-04,8.676200e-04, & - &1.083600e-03,1.334800e-03,1.457200e-03,1.265800e-02,1.488600e-03, & - &1.453100e-03,1.300400e-03,6.923900e-04,8.686800e-04,9.616800e-04, & - &1.256900e-03,1.488600e-03,1.305900e-02,1.526400e-03,1.527400e-03, & - &1.405100e-03,1.074700e-03,7.721800e-04,9.741000e-04,1.085900e-03, & - &1.526400e-03,1.344900e-02,1.566400e-03,1.601800e-03,1.502100e-03, & - &1.301600e-03,7.544200e-04,1.042100e-03,1.098600e-03,1.566400e-03, & - &1.382300e-02,1.603900e-03,1.678200e-03,1.602900e-03,1.455800e-03, & - &1.142800e-03,9.845900e-04,1.231100e-03,1.603900e-03,1.419700e-02, & - &1.251700e-03,1.190900e-03,1.025300e-03,4.890500e-04,7.359700e-04, & - &9.042700e-04,1.258800e-03,1.251700e-03,2.827000e-02,1.281700e-03, & - &1.248900e-03,1.120800e-03,6.028700e-04,7.225400e-04,8.294600e-04, & - &1.020500e-03,1.281700e-03,2.903200e-02,1.312700e-03,1.311200e-03, & - &1.205900e-03,9.418100e-04,6.213100e-04,8.617100e-04,8.910100e-04, & - &1.312700e-03,2.969800e-02,1.345200e-03,1.374100e-03,1.288300e-03, & - &1.121500e-03,6.576600e-04,8.735400e-04,9.302100e-04,1.345200e-03, & - &3.033600e-02,1.375300e-03,1.437100e-03,1.374600e-03,1.254700e-03, & - &9.951700e-04,7.985700e-04,1.095900e-03,1.375300e-03,3.095600e-02, & - &1.073300e-03,1.021500e-03,8.845400e-04,3.900600e-04,6.235900e-04, & - &7.408500e-04,1.039500e-03,1.073300e-03,4.015800e-02,1.098700e-03, & - &1.070300e-03,9.622100e-04,5.352800e-04,5.811500e-04,7.143800e-04, & - &8.320300e-04,1.098700e-03,4.119600e-02,1.125700e-03,1.122200e-03, & - &1.030900e-03,8.129100e-04,4.903300e-04,7.234100e-04,7.553600e-04, & - &1.125700e-03,4.214900e-02,1.152000e-03,1.173700e-03,1.099900e-03, & - &9.665400e-04,5.789000e-04,6.999100e-04,7.925700e-04,1.152000e-03, & - &4.306000e-02,1.177000e-03,1.226600e-03,1.172700e-03,1.074600e-03, & - &8.650600e-04,6.573700e-04,9.185100e-04,1.177000e-03,4.389900e-02, & - &9.172300e-04,8.734000e-04,7.585500e-04,3.316000e-04,5.189800e-04, & - &6.067500e-04,8.366600e-04,9.172300e-04,4.580500e-02,9.389400e-04, & - &9.141600e-04,8.217900e-04,4.836900e-04,4.697700e-04,6.304600e-04, & - &6.991700e-04,9.389400e-04,4.710400e-02,9.617400e-04,9.572900e-04, & - &8.793200e-04,7.045300e-04,4.016200e-04,5.924800e-04,6.337200e-04, & - &9.617400e-04,4.824900e-02,9.843800e-04,1.000400e-03,9.357500e-04, & - &8.253600e-04,5.055700e-04,5.568500e-04,6.808200e-04,9.843800e-04, & - &4.929600e-02,1.008000e-03,1.046400e-03,9.986199e-04,9.176900e-04, & - &7.491100e-04,5.513300e-04,7.214100e-04,1.008000e-03,5.023600e-02/ - data absa(1:270,6) / & - &8.533300e-03,9.079800e-03,9.153900e-03,8.937900e-03,8.008200e-03, & - &5.578300e-03,6.611700e-03,8.533300e-03,2.826100e-03,8.410900e-03, & - &9.345900e-03,9.662400e-03,9.754700e-03,9.579600e-03,8.402700e-03, & - &6.496100e-03,8.410900e-03,3.578000e-03,8.303000e-03,9.632600e-03, & - &1.020600e-02,1.061400e-02,1.085800e-02,1.046200e-02,9.845600e-03, & - &8.303000e-03,4.409000e-03,8.223700e-03,9.895800e-03,1.079600e-02, & - &1.154500e-02,1.209900e-02,1.236900e-02,1.207700e-02,8.223700e-03, & - &5.305000e-03,8.159900e-03,1.018100e-02,1.146900e-02,1.249000e-02, & - &1.337700e-02,1.416500e-02,1.431800e-02,8.159900e-03,6.298700e-03, & - &7.709400e-03,8.149500e-03,8.181700e-03,7.969000e-03,7.057400e-03, & - &4.658300e-03,5.945800e-03,7.709400e-03,2.125300e-03,7.609800e-03, & - &8.385700e-03,8.618800e-03,8.620200e-03,8.366800e-03,7.235400e-03, & - &5.461400e-03,7.609800e-03,2.691100e-03,7.538000e-03,8.632400e-03, & - &9.069600e-03,9.357800e-03,9.532300e-03,9.134400e-03,8.409900e-03, & - &7.538000e-03,3.328300e-03,7.492600e-03,8.875000e-03,9.578100e-03, & - &1.016400e-02,1.060300e-02,1.075500e-02,1.037800e-02,7.492600e-03, & - &4.028800e-03,7.477500e-03,9.162700e-03,1.015600e-02,1.098200e-02, & - &1.169500e-02,1.235200e-02,1.266700e-02,7.477500e-03,4.811600e-03, & - &6.912100e-03,7.218800e-03,7.179600e-03,6.888900e-03,5.850200e-03, & - &3.227800e-03,4.987900e-03,6.912100e-03,1.516000e-03,6.848000e-03, & - &7.427600e-03,7.520300e-03,7.404800e-03,7.001400e-03,5.705500e-03, & - &4.338400e-03,6.848000e-03,1.927900e-03,6.813500e-03,7.649300e-03, & - &7.897600e-03,8.014100e-03,8.017000e-03,7.544100e-03,6.517400e-03, & - &6.813500e-03,2.402800e-03,6.812200e-03,7.895600e-03,8.313100e-03, & - &8.696500e-03,8.995200e-03,8.975200e-03,8.488200e-03,6.812200e-03, & - &2.937500e-03,6.849200e-03,8.165700e-03,8.793600e-03,9.390400e-03, & - &9.916800e-03,1.034500e-02,1.048400e-02,6.849200e-03,3.539000e-03, & - &6.139700e-03,6.332400e-03,6.226900e-03,5.866600e-03,4.660100e-03, & - &2.633500e-03,4.350200e-03,6.139700e-03,1.067600e-03,6.107100e-03, & - &6.528100e-03,6.506100e-03,6.298700e-03,5.731500e-03,4.212200e-03, & - &3.524300e-03,6.107100e-03,1.367400e-03,6.117300e-03,6.742400e-03, & - &6.835100e-03,6.792800e-03,6.635500e-03,6.008400e-03,4.411100e-03, & - &6.117300e-03,1.721600e-03,6.161600e-03,6.985000e-03,7.201800e-03, & - &7.353300e-03,7.463900e-03,7.305400e-03,6.735500e-03,6.161600e-03, & - &2.129500e-03,6.232700e-03,7.249800e-03,7.616600e-03,7.940400e-03, & - &8.279900e-03,8.519600e-03,8.478000e-03,6.232700e-03,2.589300e-03, & - &5.411600e-03,5.505400e-03,5.355100e-03,4.938700e-03,3.403000e-03, & - &2.392500e-03,3.502600e-03,5.411600e-03,7.599100e-04,5.411200e-03, & - &5.701300e-03,5.602400e-03,5.321500e-03,4.573500e-03,2.784300e-03, & - &3.302100e-03,5.411200e-03,9.788900e-04,5.457100e-03,5.912400e-03, & - &5.893900e-03,5.746800e-03,5.424200e-03,4.578400e-03,3.171100e-03, & - &5.457100e-03,1.242000e-03,5.530300e-03,6.153900e-03,6.232200e-03, & - &6.216600e-03,6.139500e-03,5.800200e-03,5.069400e-03,5.530300e-03, & - &1.550800e-03,5.612600e-03,6.423100e-03,6.612000e-03,6.719300e-03, & - &6.830700e-03,6.874700e-03,6.712900e-03,5.612600e-03,1.906900e-03, & - &4.739600e-03,4.746300e-03,4.551800e-03,4.043300e-03,2.263800e-03, & - &2.314100e-03,2.880500e-03,4.739600e-03,5.669800e-04,4.767300e-03, & - &4.935700e-03,4.780100e-03,4.445700e-03,3.530400e-03,1.892000e-03, & - &2.974700e-03,4.767300e-03,7.214600e-04,4.832600e-03,5.146000e-03, & - &5.053800e-03,4.836200e-03,4.345500e-03,3.263800e-03,2.449200e-03, & - &4.832600e-03,9.139300e-04,4.913800e-03,5.389800e-03,5.367000e-03, & - &5.244800e-03,5.013500e-03,4.489000e-03,3.478100e-03,4.913700e-03, & - &1.144100e-03,5.000700e-03,5.660500e-03,5.724600e-03,5.683400e-03, & - &5.615900e-03,5.444900e-03,5.034300e-03,5.000700e-03,1.413900e-03/ - data absa(271:585,6) / & - &4.137800e-03,4.075400e-03,3.838900e-03,3.247500e-03,1.485700e-03, & - &2.102500e-03,2.298400e-03,4.137800e-03,5.248100e-04,4.182200e-03, & - &4.252100e-03,4.057000e-03,3.668800e-03,2.530600e-03,1.483100e-03, & - &2.606700e-03,4.182200e-03,6.311100e-04,4.250900e-03,4.458300e-03, & - &4.308100e-03,4.048600e-03,3.447300e-03,2.109100e-03,1.976800e-03, & - &4.250900e-03,7.639700e-04,4.333400e-03,4.687600e-03,4.603700e-03, & - &4.430800e-03,4.065100e-03,3.364700e-03,2.158700e-03,4.333400e-03, & - &9.287600e-04,4.422500e-03,4.934200e-03,4.941000e-03,4.819100e-03, & - &4.628000e-03,4.287000e-03,3.612000e-03,4.422600e-03,1.125200e-03, & - &3.609400e-03,3.503300e-03,3.240000e-03,2.628700e-03,9.986300e-04, & - &1.750000e-03,1.896000e-03,3.609400e-03,8.260000e-04,3.663700e-03, & - &3.664200e-03,3.443000e-03,3.021100e-03,1.711900e-03,1.355800e-03, & - &2.146200e-03,3.663700e-03,9.081200e-04,3.735400e-03,3.845100e-03, & - &3.674200e-03,3.369100e-03,2.681900e-03,1.391000e-03,1.947400e-03, & - &3.735400e-03,1.010100e-03,3.811900e-03,4.050900e-03,3.930400e-03, & - &3.722800e-03,3.324800e-03,2.376800e-03,1.665000e-03,3.812000e-03, & - &1.135300e-03,3.897400e-03,4.269200e-03,4.218900e-03,4.080900e-03, & - &3.814700e-03,3.318600e-03,2.441900e-03,3.897400e-03,1.274200e-03, & - &3.150900e-03,3.013500e-03,2.741400e-03,2.084800e-03,8.022500e-04, & - &1.386000e-03,1.609500e-03,3.150900e-03,3.287400e-03,3.206900e-03, & - &3.155200e-03,2.930000e-03,2.512000e-03,1.188200e-03,1.224400e-03, & - &1.813400e-03,3.206900e-03,3.442600e-03,3.277900e-03,3.314200e-03, & - &3.129200e-03,2.817700e-03,2.055600e-03,1.003200e-03,1.796400e-03, & - &3.277900e-03,3.600200e-03,3.351200e-03,3.491800e-03,3.347700e-03, & - &3.121400e-03,2.709000e-03,1.562500e-03,1.356500e-03,3.351200e-03, & - &3.758600e-03,3.430100e-03,3.685200e-03,3.595100e-03,3.431400e-03, & - &3.154700e-03,2.550400e-03,1.520700e-03,3.430100e-03,3.931200e-03, & - &2.743400e-03,2.599000e-03,2.341800e-03,1.598800e-03,7.703500e-04, & - &1.215900e-03,1.397800e-03,2.743400e-03,2.004600e-02,2.798700e-03, & - &2.724500e-03,2.502200e-03,2.112600e-03,8.970800e-04,1.076300e-03, & - &1.509300e-03,2.798700e-03,2.051600e-02,2.863900e-03,2.862300e-03, & - &2.682500e-03,2.383700e-03,1.579100e-03,8.761400e-04,1.414900e-03, & - &2.863900e-03,2.093800e-02,2.934100e-03,3.019800e-03,2.877700e-03, & - &2.642500e-03,2.209500e-03,1.119700e-03,1.206200e-03,2.934200e-03, & - &2.134500e-02,3.012900e-03,3.189900e-03,3.082500e-03,2.904500e-03, & - &2.620100e-03,1.965400e-03,1.192600e-03,3.012900e-03,2.174400e-02, & - &2.393000e-03,2.276000e-03,2.047500e-03,1.491700e-03,6.151900e-04, & - &9.573900e-04,1.211700e-03,2.393000e-03,4.601000e-02,2.449500e-03, & - &2.389700e-03,2.196400e-03,1.877400e-03,8.879500e-04,8.578500e-04, & - &1.221200e-03,2.449500e-03,4.711800e-02,2.510800e-03,2.514900e-03, & - &2.360700e-03,2.117900e-03,1.506300e-03,7.248700e-04,1.161700e-03, & - &2.510800e-03,4.804400e-02,2.579700e-03,2.661300e-03,2.539100e-03, & - &2.335300e-03,1.979100e-03,1.104900e-03,9.488300e-04,2.579700e-03, & - &4.880500e-02,2.649900e-03,2.818200e-03,2.722900e-03,2.558000e-03, & - &2.314200e-03,1.807900e-03,1.003500e-03,2.649900e-03,4.939100e-02, & - &2.074600e-03,1.978300e-03,1.780100e-03,1.355600e-03,4.826700e-04, & - &8.146300e-04,1.018500e-03,2.074600e-03,6.754700e-02,2.127300e-03, & - &2.077000e-03,1.910500e-03,1.648100e-03,8.372400e-04,7.168300e-04, & - &1.010300e-03,2.127300e-03,6.926600e-02,2.184400e-03,2.191500e-03, & - &2.059400e-03,1.858700e-03,1.389200e-03,6.475100e-04,9.572800e-04, & - &2.184400e-03,7.061900e-02,2.244100e-03,2.322600e-03,2.220600e-03, & - &2.045300e-03,1.749100e-03,1.040500e-03,7.813800e-04,2.244100e-03, & - &7.160200e-02,2.305000e-03,2.459800e-03,2.382200e-03,2.238100e-03, & - &2.030400e-03,1.632500e-03,9.243800e-04,2.305000e-03,7.230300e-02, & - &1.788300e-03,1.706500e-03,1.537400e-03,1.200700e-03,4.302500e-04, & - &6.759000e-04,8.188500e-04,1.788300e-03,7.986000e-02,1.836300e-03, & - &1.794800e-03,1.652800e-03,1.432400e-03,7.677400e-04,6.224600e-04, & - &8.132900e-04,1.836300e-03,8.180700e-02,1.886900e-03,1.896000e-03, & - &1.781800e-03,1.609500e-03,1.239700e-03,5.695000e-04,8.231800e-04, & - &1.886900e-03,8.329100e-02,1.937800e-03,2.007400e-03,1.920600e-03, & - &1.775500e-03,1.532200e-03,9.584500e-04,6.970800e-04,1.937800e-03, & - &8.441600e-02,1.990000e-03,2.125800e-03,2.064400e-03,1.940500e-03, & - &1.765100e-03,1.441900e-03,8.368800e-04,1.990000e-03,8.529200e-02/ - data absa(1:270,7) / & - &1.647300e-02,1.663900e-02,1.662000e-02,1.604400e-02,1.502400e-02, & - &1.318700e-02,7.621300e-03,1.647300e-02,5.936900e-03,1.628300e-02, & - &1.731900e-02,1.760100e-02,1.737100e-02,1.671400e-02,1.560600e-02, & - &1.267500e-02,1.628300e-02,7.530900e-03,1.604400e-02,1.793900e-02, & - &1.861600e-02,1.873600e-02,1.850900e-02,1.793200e-02,1.631600e-02, & - &1.604400e-02,9.303400e-03,1.578000e-02,1.856600e-02,1.970700e-02, & - &2.021800e-02,2.046800e-02,2.039200e-02,2.022100e-02,1.578000e-02, & - &1.124100e-02,1.551400e-02,1.923900e-02,2.086600e-02,2.184800e-02, & - &2.251800e-02,2.293800e-02,2.433800e-02,1.551400e-02,1.336900e-02, & - &1.553400e-02,1.569800e-02,1.565500e-02,1.506800e-02,1.413500e-02, & - &1.227000e-02,7.418100e-03,1.553400e-02,4.464000e-03,1.534200e-02, & - &1.632400e-02,1.659000e-02,1.635300e-02,1.583100e-02,1.481500e-02, & - &1.254300e-02,1.534200e-02,5.697000e-03,1.509800e-02,1.690400e-02, & - &1.754500e-02,1.769100e-02,1.749700e-02,1.708500e-02,1.577600e-02, & - &1.509800e-02,7.087600e-03,1.483400e-02,1.749100e-02,1.858300e-02, & - &1.913600e-02,1.938100e-02,1.939600e-02,1.891900e-02,1.483400e-02, & - &8.639200e-03,1.458200e-02,1.808700e-02,1.971000e-02,2.069900e-02, & - &2.141500e-02,2.184400e-02,2.210100e-02,1.458200e-02,1.034400e-02, & - &1.437900e-02,1.440000e-02,1.427300e-02,1.371400e-02,1.277400e-02, & - &1.075800e-02,5.922100e-03,1.437900e-02,3.162700e-03,1.418100e-02, & - &1.496200e-02,1.520400e-02,1.490600e-02,1.435700e-02,1.327500e-02, & - &1.075000e-02,1.418100e-02,4.072000e-03,1.395500e-02,1.548500e-02, & - &1.607800e-02,1.612400e-02,1.592800e-02,1.541900e-02,1.414500e-02, & - &1.395500e-02,5.122700e-03,1.371500e-02,1.601900e-02,1.701100e-02, & - &1.744300e-02,1.760100e-02,1.759900e-02,1.715100e-02,1.371500e-02, & - &6.325100e-03,1.348800e-02,1.656600e-02,1.801500e-02,1.888500e-02, & - &1.946600e-02,1.988000e-02,1.989100e-02,1.348800e-02,7.636200e-03, & - &1.310000e-02,1.294800e-02,1.270900e-02,1.215200e-02,1.121100e-02, & - &8.954000e-03,3.923500e-03,1.310000e-02,2.207700e-03,1.292200e-02, & - &1.342100e-02,1.356300e-02,1.327300e-02,1.268700e-02,1.146500e-02, & - &8.593200e-03,1.292200e-02,2.890800e-03,1.271000e-02,1.388600e-02, & - &1.437300e-02,1.437100e-02,1.408000e-02,1.340700e-02,1.198500e-02, & - &1.271000e-02,3.676000e-03,1.251000e-02,1.437300e-02,1.520000e-02, & - &1.550300e-02,1.554200e-02,1.536400e-02,1.483500e-02,1.251000e-02, & - &4.589100e-03,1.232500e-02,1.488500e-02,1.609900e-02,1.675800e-02, & - &1.716900e-02,1.743500e-02,1.747100e-02,1.232500e-02,5.617900e-03, & - &1.178500e-02,1.150700e-02,1.116800e-02,1.060000e-02,9.650700e-03, & - &6.941400e-03,2.934500e-03,1.178500e-02,1.549600e-03,1.161800e-02, & - &1.188600e-02,1.190600e-02,1.160100e-02,1.100800e-02,9.748200e-03, & - &6.371600e-03,1.161800e-02,2.051300e-03,1.144700e-02,1.228800e-02, & - &1.262000e-02,1.254000e-02,1.219600e-02,1.147500e-02,9.844800e-03, & - &1.144700e-02,2.647400e-03,1.129300e-02,1.271900e-02,1.335000e-02, & - &1.350900e-02,1.347200e-02,1.320700e-02,1.251700e-02,1.129300e-02, & - &3.341400e-03,1.118300e-02,1.317800e-02,1.412300e-02,1.458300e-02, & - &1.488300e-02,1.501500e-02,1.492600e-02,1.118300e-02,4.131200e-03, & - &1.048700e-02,1.012400e-02,9.724900e-03,9.145700e-03,8.128500e-03, & - &4.899600e-03,1.967800e-03,1.048700e-02,1.093700e-03,1.034900e-02, & - &1.043700e-02,1.033200e-02,9.975400e-03,9.286600e-03,7.916000e-03, & - &4.387800e-03,1.034900e-02,1.459800e-03,1.022000e-02,1.078400e-02, & - &1.092900e-02,1.075300e-02,1.035300e-02,9.543200e-03,7.823200e-03, & - &1.022000e-02,1.900800e-03,1.013500e-02,1.114300e-02,1.153000e-02, & - &1.157600e-02,1.143900e-02,1.108800e-02,1.027700e-02,1.013500e-02, & - &2.422100e-03,1.010200e-02,1.155400e-02,1.219400e-02,1.248000e-02, & - &1.265200e-02,1.267800e-02,1.249400e-02,1.010200e-02,3.025700e-03/ - data absa(271:585,7) / & - &9.230900e-03,8.831900e-03,8.396800e-03,7.795200e-03,6.747500e-03, & - &3.287000e-03,1.917900e-03,9.230900e-03,8.964500e-04,9.124200e-03, & - &9.093200e-03,8.904600e-03,8.499400e-03,7.773700e-03,6.209500e-03, & - &2.821100e-03,9.124200e-03,1.134600e-03,9.049900e-03,9.388000e-03, & - &9.391200e-03,9.143700e-03,8.664000e-03,7.805900e-03,5.835800e-03, & - &9.049900e-03,1.437900e-03,9.031900e-03,9.728100e-03,9.888800e-03, & - &9.824000e-03,9.604300e-03,9.153500e-03,8.262500e-03,9.031900e-03, & - &1.816200e-03,9.067700e-03,1.011400e-02,1.045300e-02,1.059000e-02, & - &1.061400e-02,1.051500e-02,1.021200e-02,9.067800e-03,2.270000e-03, & - &8.075000e-03,7.662300e-03,7.213800e-03,6.597500e-03,5.425700e-03, & - &2.272300e-03,1.624900e-03,8.075000e-03,1.283100e-03,7.999700e-03, & - &7.879300e-03,7.622700e-03,7.181700e-03,6.421600e-03,4.536600e-03, & - &1.973600e-03,7.999700e-03,1.449700e-03,7.973900e-03,8.149600e-03, & - &8.022000e-03,7.722000e-03,7.187400e-03,6.245500e-03,3.853000e-03, & - &7.973900e-03,1.655200e-03,8.012800e-03,8.469400e-03,8.461400e-03, & - &8.295100e-03,7.966800e-03,7.436800e-03,6.344400e-03,8.012800e-03, & - &1.896500e-03,8.113600e-03,8.834100e-03,8.971000e-03,8.945900e-03, & - &8.820300e-03,8.600600e-03,8.140200e-03,8.113600e-03,2.190900e-03, & - &7.029600e-03,6.630800e-03,6.180400e-03,5.536000e-03,4.143700e-03, & - &1.563200e-03,1.434800e-03,7.029600e-03,5.074600e-03,6.989100e-03, & - &6.815400e-03,6.504700e-03,6.012600e-03,5.166400e-03,3.130900e-03, & - &1.344000e-03,6.989100e-03,5.257500e-03,7.004700e-03,7.068200e-03, & - &6.840100e-03,6.467100e-03,5.888100e-03,4.803200e-03,2.440800e-03, & - &7.004700e-03,5.472500e-03,7.093700e-03,7.364200e-03,7.226600e-03, & - &6.960200e-03,6.550500e-03,5.947200e-03,4.622500e-03,7.093700e-03, & - &5.707500e-03,7.235900e-03,7.718900e-03,7.689800e-03,7.539300e-03, & - &7.279600e-03,6.954000e-03,6.311500e-03,7.235900e-03,5.939500e-03, & - &6.082400e-03,5.720100e-03,5.295000e-03,4.653300e-03,3.124300e-03, & - &1.084900e-03,1.351400e-03,6.082400e-03,3.203600e-02,6.081600e-03, & - &5.899900e-03,5.571100e-03,5.054300e-03,4.167400e-03,2.195100e-03, & - &1.151300e-03,6.081600e-03,3.264600e-02,6.145400e-03,6.149600e-03, & - &5.854600e-03,5.443700e-03,4.818000e-03,3.642400e-03,1.733000e-03, & - &6.145400e-03,3.307900e-02,6.275800e-03,6.438200e-03,6.199100e-03, & - &5.878300e-03,5.435000e-03,4.723700e-03,3.281000e-03,6.275700e-03, & - &3.340100e-02,6.434400e-03,6.777400e-03,6.629500e-03,6.394100e-03, & - &6.067800e-03,5.639700e-03,4.897800e-03,6.434400e-03,3.365200e-02, & - &5.281100e-03,5.005500e-03,4.633500e-03,4.075700e-03,2.872700e-03, & - &1.086500e-03,1.017100e-03,5.281100e-03,7.684000e-02,5.340900e-03, & - &5.214000e-03,4.880600e-03,4.414000e-03,3.662200e-03,2.030200e-03, & - &9.181100e-04,5.340900e-03,7.787000e-02,5.467400e-03,5.475800e-03, & - &5.163800e-03,4.767900e-03,4.220300e-03,3.224700e-03,1.598000e-03, & - &5.467400e-03,7.859400e-02,5.617500e-03,5.767700e-03,5.509200e-03, & - &5.189700e-03,4.772800e-03,4.126700e-03,2.988800e-03,5.617500e-03, & - &7.895900e-02,5.784800e-03,6.088500e-03,5.918900e-03,5.678200e-03, & - &5.343100e-03,4.922300e-03,4.250000e-03,5.784800e-03,7.914800e-02, & - &4.640600e-03,4.426400e-03,4.075000e-03,3.582200e-03,2.651000e-03, & - &1.013200e-03,9.215600e-04,4.640600e-03,1.176800e-01,4.751300e-03, & - &4.650100e-03,4.313300e-03,3.881100e-03,3.250700e-03,1.850100e-03, & - &7.392400e-04,4.751300e-03,1.189200e-01,4.889200e-03,4.896600e-03, & - &4.592000e-03,4.216200e-03,3.735700e-03,2.901500e-03,1.440200e-03, & - &4.889200e-03,1.198800e-01,5.043400e-03,5.164900e-03,4.911700e-03, & - &4.608700e-03,4.234000e-03,3.674300e-03,2.665200e-03,5.043400e-03, & - &1.204000e-01,5.194300e-03,5.460400e-03,5.285900e-03,5.053200e-03, & - &4.746600e-03,4.336700e-03,3.675800e-03,5.194300e-03,1.206600e-01, & - &4.104000e-03,3.932000e-03,3.601600e-03,3.166000e-03,2.419800e-03, & - &9.600600e-04,7.433600e-04,4.104000e-03,1.447800e-01,4.223200e-03, & - &4.142500e-03,3.833100e-03,3.440700e-03,2.904600e-03,1.697900e-03, & - &6.792100e-04,4.223200e-03,1.462300e-01,4.361100e-03,4.369800e-03, & - &4.089900e-03,3.746100e-03,3.327300e-03,2.660300e-03,1.296300e-03, & - &4.361100e-03,1.474800e-01,4.499200e-03,4.614800e-03,4.384100e-03, & - &4.096300e-03,3.757000e-03,3.285900e-03,2.368700e-03,4.499200e-03, & - &1.481700e-01,4.632700e-03,4.872900e-03,4.708600e-03,4.488400e-03, & - &4.210200e-03,3.839100e-03,3.259200e-03,4.632700e-03,1.484800e-01/ - data absa(1:270,8) / & - &3.244600e-02,3.096100e-02,2.994300e-02,2.881400e-02,2.670100e-02, & - &2.382600e-02,2.078600e-02,3.244600e-02,1.567600e-02,3.252700e-02, & - &3.184800e-02,3.199400e-02,3.117500e-02,2.971900e-02,2.853200e-02, & - &2.815700e-02,3.252700e-02,2.006000e-02,3.255500e-02,3.303500e-02, & - &3.400900e-02,3.363200e-02,3.309800e-02,3.403500e-02,3.609300e-02, & - &3.255500e-02,2.531900e-02,3.252000e-02,3.442400e-02,3.589300e-02, & - &3.622100e-02,3.717300e-02,4.003700e-02,4.379000e-02,3.252000e-02, & - &3.144400e-02,3.243600e-02,3.576100e-02,3.782800e-02,3.916700e-02, & - &4.208100e-02,4.677700e-02,5.169900e-02,3.243600e-02,3.833900e-02, & - &3.325900e-02,3.163700e-02,3.050200e-02,2.932200e-02,2.719200e-02, & - &2.404500e-02,1.941800e-02,3.325900e-02,1.240100e-02,3.330900e-02, & - &3.254200e-02,3.257900e-02,3.186900e-02,3.010900e-02,2.790000e-02, & - &2.553000e-02,3.330900e-02,1.597100e-02,3.335200e-02,3.375500e-02, & - &3.471800e-02,3.439200e-02,3.324600e-02,3.225000e-02,3.234900e-02, & - &3.335200e-02,2.027800e-02,3.333000e-02,3.517400e-02,3.673700e-02, & - &3.691600e-02,3.664100e-02,3.727400e-02,3.944100e-02,3.333000e-02, & - &2.523400e-02,3.322600e-02,3.656900e-02,3.877700e-02,3.971300e-02, & - &4.059600e-02,4.297900e-02,4.703200e-02,3.322600e-02,3.075900e-02, & - &3.339100e-02,3.159400e-02,3.017600e-02,2.873900e-02,2.663300e-02, & - &2.333600e-02,1.817700e-02,3.339100e-02,9.143800e-03,3.346300e-02, & - &3.244500e-02,3.215400e-02,3.136200e-02,2.962600e-02,2.696300e-02, & - &2.319800e-02,3.346300e-02,1.196400e-02,3.350700e-02,3.366600e-02, & - &3.434800e-02,3.402000e-02,3.266400e-02,3.072900e-02,2.867500e-02, & - &3.350700e-02,1.531200e-02,3.348400e-02,3.507600e-02,3.646000e-02, & - &3.668500e-02,3.585100e-02,3.476000e-02,3.444600e-02,3.348400e-02, & - &1.914400e-02,3.336500e-02,3.649100e-02,3.854600e-02,3.940000e-02, & - &3.930900e-02,3.934000e-02,4.103900e-02,3.336500e-02,2.342600e-02, & - &3.282300e-02,3.085600e-02,2.921600e-02,2.753600e-02,2.526300e-02, & - &2.200500e-02,1.712600e-02,3.282300e-02,6.484700e-03,3.291600e-02, & - &3.170300e-02,3.108100e-02,3.005900e-02,2.825200e-02,2.556600e-02, & - &2.164300e-02,3.291600e-02,8.641100e-03,3.294200e-02,3.285500e-02, & - &3.317200e-02,3.267900e-02,3.144200e-02,2.928300e-02,2.618000e-02, & - &3.294200e-02,1.125600e-02,3.289500e-02,3.420700e-02,3.526100e-02, & - &3.538600e-02,3.468300e-02,3.299200e-02,3.083000e-02,3.289500e-02, & - &1.426600e-02,3.279100e-02,3.559800e-02,3.734200e-02,3.814400e-02, & - &3.795800e-02,3.691500e-02,3.606000e-02,3.279100e-02,1.762300e-02, & - &3.152700e-02,2.944100e-02,2.766600e-02,2.580000e-02,2.351700e-02, & - &2.029000e-02,1.528400e-02,3.152700e-02,4.548300e-03,3.162700e-02, & - &3.025300e-02,2.941000e-02,2.819100e-02,2.638500e-02,2.375400e-02, & - &1.978200e-02,3.162700e-02,6.166200e-03,3.165300e-02,3.137400e-02, & - &3.139400e-02,3.070400e-02,2.949900e-02,2.741000e-02,2.420700e-02, & - &3.165300e-02,8.144700e-03,3.158700e-02,3.268100e-02,3.337300e-02, & - &3.336400e-02,3.271100e-02,3.106100e-02,2.836600e-02,3.158700e-02, & - &1.046000e-02,3.145900e-02,3.403500e-02,3.539100e-02,3.606300e-02, & - &3.594100e-02,3.474700e-02,3.264300e-02,3.145900e-02,1.309500e-02, & - &2.969000e-02,2.751300e-02,2.563300e-02,2.360500e-02,2.129800e-02, & - &1.814700e-02,1.314600e-02,2.969000e-02,3.136900e-03,2.977000e-02, & - &2.828800e-02,2.718300e-02,2.578900e-02,2.403600e-02,2.156100e-02, & - &1.754300e-02,2.977000e-02,4.318700e-03,2.978300e-02,2.929400e-02, & - &2.904500e-02,2.819200e-02,2.696000e-02,2.503400e-02,2.185800e-02, & - &2.978300e-02,5.786700e-03,2.969200e-02,3.052300e-02,3.094600e-02, & - &3.071500e-02,3.000700e-02,2.849700e-02,2.580000e-02,2.969200e-02, & - &7.550200e-03,2.953400e-02,3.178300e-02,3.286900e-02,3.326200e-02, & - &3.306400e-02,3.199900e-02,2.975500e-02,2.953400e-02,9.580000e-03/ - data absa(271:585,8) / & - &2.739900e-02,2.521900e-02,2.331800e-02,2.125000e-02,1.890500e-02, & - &1.586600e-02,1.021100e-02,2.739900e-02,2.213300e-03,2.746500e-02, & - &2.591800e-02,2.466400e-02,2.319500e-02,2.141500e-02,1.904400e-02, & - &1.528700e-02,2.746500e-02,3.058100e-03,2.746700e-02,2.684700e-02, & - &2.636300e-02,2.538100e-02,2.410300e-02,2.226100e-02,1.929800e-02, & - &2.746700e-02,4.137900e-03,2.737700e-02,2.796700e-02,2.811300e-02, & - &2.772100e-02,2.689700e-02,2.551300e-02,2.301100e-02,2.737700e-02, & - &5.443400e-03,2.720500e-02,2.909500e-02,2.988900e-02,3.006400e-02, & - &2.973500e-02,2.882300e-02,2.678500e-02,2.720500e-02,6.988600e-03, & - &2.483800e-02,2.273000e-02,2.087900e-02,1.884700e-02,1.656200e-02, & - &1.359800e-02,7.926300e-03,2.483800e-02,2.319700e-03,2.489000e-02, & - &2.336000e-02,2.203300e-02,2.052300e-02,1.879700e-02,1.656700e-02, & - &1.279000e-02,2.489000e-02,2.780600e-03,2.486200e-02,2.416000e-02, & - &2.352800e-02,2.249100e-02,2.119900e-02,1.947700e-02,1.680200e-02, & - &2.486200e-02,3.407900e-03,2.477500e-02,2.515400e-02,2.510000e-02, & - &2.457800e-02,2.371100e-02,2.238100e-02,2.021900e-02,2.477500e-02, & - &4.258000e-03,2.462200e-02,2.614800e-02,2.669900e-02,2.667100e-02, & - &2.629400e-02,2.537200e-02,2.358900e-02,2.462200e-02,5.336100e-03, & - &2.222100e-02,2.020900e-02,1.841800e-02,1.649700e-02,1.436200e-02, & - &1.145200e-02,5.846400e-03,2.222100e-02,8.104500e-03,2.222800e-02, & - &2.073800e-02,1.939900e-02,1.792900e-02,1.627400e-02,1.418000e-02, & - &1.025600e-02,2.222800e-02,8.497600e-03,2.218100e-02,2.141900e-02, & - &2.068500e-02,1.963600e-02,1.837000e-02,1.674000e-02,1.422100e-02, & - &2.218100e-02,8.906400e-03,2.207700e-02,2.225900e-02,2.205300e-02, & - &2.145200e-02,2.056100e-02,1.927100e-02,1.733700e-02,2.207700e-02, & - &9.366600e-03,2.195900e-02,2.314000e-02,2.345000e-02,2.328100e-02, & - &2.278900e-02,2.185600e-02,2.032800e-02,2.195900e-02,9.896000e-03, & - &1.966500e-02,1.781300e-02,1.613500e-02,1.437900e-02,1.242300e-02, & - &9.619400e-03,4.366500e-03,1.966500e-02,5.085900e-02,1.965500e-02, & - &1.825400e-02,1.696100e-02,1.558700e-02,1.405300e-02,1.208800e-02, & - &8.138200e-03,1.965500e-02,5.146500e-02,1.957700e-02,1.880500e-02, & - &1.805400e-02,1.705800e-02,1.585000e-02,1.433600e-02,1.195000e-02, & - &1.957700e-02,5.195500e-02,1.947300e-02,1.952300e-02,1.922700e-02, & - &1.859100e-02,1.770000e-02,1.647800e-02,1.469300e-02,1.947300e-02, & - &5.235400e-02,1.940500e-02,2.028800e-02,2.042300e-02,2.013200e-02, & - &1.956400e-02,1.869100e-02,1.734700e-02,1.940500e-02,5.268200e-02, & - &1.719900e-02,1.569200e-02,1.430700e-02,1.286100e-02,1.126200e-02, & - &9.031600e-03,4.421200e-03,1.719900e-02,1.264100e-01,1.713900e-02, & - &1.608900e-02,1.509400e-02,1.399500e-02,1.269900e-02,1.106300e-02, & - &8.129400e-03,1.713900e-02,1.263000e-01,1.706200e-02,1.661600e-02, & - &1.606800e-02,1.525000e-02,1.421300e-02,1.292700e-02,1.096800e-02, & - &1.706200e-02,1.265700e-01,1.702700e-02,1.728400e-02,1.707400e-02, & - &1.650300e-02,1.572700e-02,1.474700e-02,1.330200e-02,1.702700e-02, & - &1.268000e-01,1.705100e-02,1.800300e-02,1.809700e-02,1.779500e-02, & - &1.733800e-02,1.667000e-02,1.565600e-02,1.705100e-02,1.266800e-01, & - &1.489200e-02,1.370700e-02,1.258900e-02,1.142400e-02,1.009600e-02, & - &8.281500e-03,4.423300e-03,1.489200e-02,2.017800e-01,1.483000e-02, & - &1.407600e-02,1.332700e-02,1.241500e-02,1.130600e-02,9.912800e-03, & - &7.651000e-03,1.483000e-02,2.012700e-01,1.481500e-02,1.461600e-02, & - &1.416600e-02,1.343600e-02,1.253100e-02,1.141900e-02,9.814400e-03, & - &1.481500e-02,2.010900e-01,1.487400e-02,1.524900e-02,1.501900e-02, & - &1.448400e-02,1.380200e-02,1.296900e-02,1.180200e-02,1.487400e-02, & - &2.010800e-01,1.502800e-02,1.594700e-02,1.592300e-02,1.563000e-02, & - &1.520500e-02,1.466500e-02,1.388800e-02,1.502800e-02,2.006100e-01, & - &1.285600e-02,1.192600e-02,1.103400e-02,1.005100e-02,8.904800e-03, & - &7.380800e-03,4.356000e-03,1.285600e-02,2.594700e-01,1.284900e-02, & - &1.231700e-02,1.169200e-02,1.088200e-02,9.888400e-03,8.678600e-03, & - &6.847900e-03,1.284900e-02,2.595300e-01,1.291300e-02,1.285000e-02, & - &1.241700e-02,1.172100e-02,1.088200e-02,9.919000e-03,8.602300e-03, & - &1.291300e-02,2.594200e-01,1.308800e-02,1.347100e-02,1.316900e-02, & - &1.263700e-02,1.198900e-02,1.124800e-02,1.030100e-02,1.308800e-02, & - &2.590900e-01,1.337300e-02,1.415900e-02,1.402900e-02,1.367900e-02, & - &1.324100e-02,1.274900e-02,1.212500e-02,1.337300e-02,2.581500e-01/ - data absa(1:270,9) / & - &6.473300e-02,6.052100e-02,5.825200e-02,5.686600e-02,5.652600e-02, & - &5.574200e-02,5.204600e-02,6.473300e-02,5.623300e-02,6.547700e-02, & - &6.304700e-02,6.310600e-02,6.461200e-02,6.679000e-02,6.750700e-02, & - &6.472300e-02,6.547700e-02,7.272000e-02,6.621600e-02,6.610800e-02, & - &6.918100e-02,7.426800e-02,7.904700e-02,8.049700e-02,7.828000e-02, & - &6.621600e-02,9.164800e-02,6.679100e-02,6.957900e-02,7.673700e-02, & - &8.524400e-02,9.184500e-02,9.452700e-02,9.244100e-02,6.679100e-02, & - &1.130700e-01,6.729800e-02,7.383900e-02,8.535600e-02,9.714700e-02, & - &1.055400e-01,1.097800e-01,1.075200e-01,6.729800e-02,1.367800e-01, & - &7.087700e-02,6.525300e-02,6.123200e-02,5.794200e-02,5.566200e-02, & - &5.370300e-02,5.025100e-02,7.087700e-02,4.855000e-02,7.155500e-02, & - &6.749200e-02,6.547300e-02,6.455100e-02,6.505400e-02,6.526400e-02, & - &6.323100e-02,7.155500e-02,6.333400e-02,7.215900e-02,7.021800e-02, & - &7.074200e-02,7.327800e-02,7.645900e-02,7.827400e-02,7.683600e-02, & - &7.215900e-02,8.052800e-02,7.267200e-02,7.332600e-02,7.745600e-02, & - &8.331400e-02,8.906100e-02,9.238200e-02,9.143800e-02,7.267200e-02, & - &1.001700e-01,7.306800e-02,7.709000e-02,8.513200e-02,9.451800e-02, & - &1.030900e-01,1.079600e-01,1.065100e-01,7.306700e-02,1.222900e-01, & - &7.783600e-02,7.055100e-02,6.455900e-02,5.916700e-02,5.441400e-02, & - &5.031400e-02,4.579400e-02,7.783600e-02,3.888200e-02,7.843500e-02, & - &7.253200e-02,6.809200e-02,6.461300e-02,6.235800e-02,6.060800e-02, & - &5.827600e-02,7.843500e-02,5.137000e-02,7.893200e-02,7.482500e-02, & - &7.252700e-02,7.198900e-02,7.247100e-02,7.287300e-02,7.176600e-02, & - &7.893200e-02,6.608600e-02,7.937900e-02,7.750100e-02,7.838800e-02, & - &8.084700e-02,8.409700e-02,8.680100e-02,8.656800e-02,7.937900e-02, & - &8.314100e-02,7.969900e-02,8.069100e-02,8.512100e-02,9.100800e-02, & - &9.744100e-02,1.022600e-01,1.016300e-01,7.969900e-02,1.025400e-01, & - &8.490600e-02,7.624100e-02,6.868400e-02,6.126000e-02,5.432200e-02, & - &4.802700e-02,4.141100e-02,8.490600e-02,3.032500e-02,8.569800e-02, & - &7.824300e-02,7.174800e-02,6.577800e-02,6.093500e-02,5.671900e-02, & - &5.261000e-02,8.569800e-02,4.054900e-02,8.627500e-02,8.032400e-02, & - &7.542900e-02,7.200900e-02,6.953100e-02,6.753900e-02,6.547000e-02, & - &8.627500e-02,5.270000e-02,8.671300e-02,8.257500e-02,8.046200e-02, & - &7.974800e-02,7.973500e-02,8.032600e-02,7.997400e-02,8.671300e-02, & - &6.702900e-02,8.702700e-02,8.527600e-02,8.650900e-02,8.881900e-02, & - &9.176100e-02,9.479800e-02,9.480100e-02,8.702700e-02,8.350800e-02, & - &9.150700e-02,8.162000e-02,7.282800e-02,6.414200e-02,5.556800e-02, & - &4.725100e-02,3.888000e-02,9.150700e-02,2.322900e-02,9.240500e-02, & - &8.367900e-02,7.586300e-02,6.821600e-02,6.104600e-02,5.451300e-02, & - &4.826100e-02,9.240500e-02,3.150800e-02,9.311500e-02,8.570000e-02, & - &7.933500e-02,7.357900e-02,6.842000e-02,6.387200e-02,5.956700e-02, & - &9.311500e-02,4.151100e-02,9.363600e-02,8.796300e-02,8.377600e-02, & - &8.033600e-02,7.728400e-02,7.504600e-02,7.288200e-02,9.363600e-02, & - &5.333300e-02,9.401100e-02,9.050400e-02,8.912800e-02,8.824700e-02, & - &8.782400e-02,8.797900e-02,8.707800e-02,9.401100e-02,6.715500e-02, & - &9.747200e-02,8.653800e-02,7.662400e-02,6.682400e-02,5.705900e-02, & - &4.726800e-02,3.713800e-02,9.747200e-02,1.722100e-02,9.845100e-02, & - &8.851800e-02,7.953600e-02,7.073700e-02,6.195600e-02,5.332800e-02, & - &4.492300e-02,9.845100e-02,2.378000e-02,9.927000e-02,9.059200e-02, & - &8.299200e-02,7.564500e-02,6.833800e-02,6.124600e-02,5.464700e-02, & - &9.927000e-02,3.182100e-02,9.987400e-02,9.282500e-02,8.714500e-02, & - &8.171300e-02,7.602400e-02,7.089500e-02,6.625600e-02,9.987400e-02, & - &4.151400e-02,1.003100e-01,9.536200e-02,9.219600e-02,8.867200e-02, & - &8.523700e-02,8.216400e-02,7.901700e-02,1.003100e-01,5.289200e-02/ - data absa(271:585,9) / & - &1.023200e-01,9.055300e-02,7.962400e-02,6.890600e-02,5.807000e-02, & - &4.725600e-02,3.614700e-02,1.023200e-01,1.255100e-02,1.033700e-01, & - &9.240700e-02,8.243400e-02,7.254800e-02,6.264300e-02,5.275300e-02, & - &4.258100e-02,1.033700e-01,1.757500e-02,1.042800e-01,9.446300e-02, & - &8.575600e-02,7.710300e-02,6.847200e-02,5.971100e-02,5.086100e-02, & - &1.042800e-01,2.386500e-02,1.049900e-01,9.664900e-02,8.971500e-02, & - &8.280400e-02,7.568200e-02,6.809400e-02,6.086200e-02,1.049900e-01, & - &3.154600e-02,1.054700e-01,9.918000e-02,9.451900e-02,8.947900e-02, & - &8.371700e-02,7.781300e-02,7.199300e-02,1.054700e-01,4.072100e-02, & - &1.051800e-01,9.288600e-02,8.119100e-02,6.995700e-02,5.850800e-02, & - &4.696500e-02,3.494700e-02,1.051800e-01,9.167000e-03,1.063600e-01, & - &9.467400e-02,8.403600e-02,7.341300e-02,6.277600e-02,5.200700e-02, & - &4.095100e-02,1.063600e-01,1.299800e-02,1.073300e-01,9.673800e-02, & - &8.725200e-02,7.778300e-02,6.820300e-02,5.837200e-02,4.803400e-02, & - &1.073300e-01,1.787800e-02,1.081200e-01,9.891100e-02,9.115200e-02, & - &8.317300e-02,7.496300e-02,6.611600e-02,5.665500e-02,1.081200e-01, & - &2.386800e-02,1.086300e-01,1.015100e-01,9.571700e-02,8.957800e-02, & - &8.257200e-02,7.466900e-02,6.639700e-02,1.086300e-01,3.108200e-02, & - &1.058900e-01,9.337800e-02,8.132000e-02,6.969900e-02,5.793900e-02, & - &4.596300e-02,3.351000e-02,1.058900e-01,1.500500e-02,1.071000e-01, & - &9.504600e-02,8.399200e-02,7.296800e-02,6.184000e-02,5.067000e-02, & - &3.917200e-02,1.071000e-01,1.668700e-02,1.081100e-01,9.702500e-02, & - &8.706200e-02,7.713500e-02,6.700800e-02,5.669300e-02,4.553900e-02, & - &1.081100e-01,1.906200e-02,1.089300e-01,9.921000e-02,9.089300e-02, & - &8.226800e-02,7.343200e-02,6.387200e-02,5.335400e-02,1.089300e-01, & - &2.251700e-02,1.095100e-01,1.018000e-01,9.532800e-02,8.853300e-02, & - &8.077700e-02,7.193300e-02,6.186000e-02,1.095100e-01,2.719400e-02, & - &1.046300e-01,9.219100e-02,8.013200e-02,6.841300e-02,5.664100e-02, & - &4.461900e-02,3.208000e-02,1.046300e-01,8.399100e-02,1.058200e-01, & - &9.377000e-02,8.262700e-02,7.153900e-02,6.026500e-02,4.898900e-02, & - &3.736600e-02,1.058200e-01,8.500800e-02,1.068300e-01,9.565100e-02, & - &8.558700e-02,7.542900e-02,6.515400e-02,5.471500e-02,4.340800e-02, & - &1.068300e-01,8.663600e-02,1.075900e-01,9.776400e-02,8.922000e-02, & - &8.033600e-02,7.134900e-02,6.157600e-02,5.072000e-02,1.075900e-01, & - &8.813300e-02,1.081400e-01,1.002700e-01,9.347600e-02,8.646100e-02, & - &7.847000e-02,6.923200e-02,5.860400e-02,1.081400e-01,8.959500e-02, & - &1.019200e-01,8.993400e-02,7.844200e-02,6.720600e-02,5.580700e-02, & - &4.427400e-02,3.248500e-02,1.019200e-01,2.134600e-01,1.029400e-01, & - &9.147400e-02,8.100100e-02,7.032400e-02,5.961800e-02,4.889000e-02, & - &3.772400e-02,1.029400e-01,2.131900e-01,1.037600e-01,9.337000e-02, & - &8.396200e-02,7.443500e-02,6.479500e-02,5.479500e-02,4.382700e-02, & - &1.037600e-01,2.128900e-01,1.043700e-01,9.548900e-02,8.768200e-02, & - &7.961400e-02,7.110200e-02,6.161900e-02,5.104600e-02,1.043700e-01, & - &2.128700e-01,1.047500e-01,9.808300e-02,9.212400e-02,8.574300e-02, & - &7.794600e-02,6.904800e-02,5.862700e-02,1.047500e-01,2.131000e-01, & - &9.726100e-02,8.599100e-02,7.532400e-02,6.473700e-02,5.398900e-02, & - &4.318400e-02,3.216900e-02,9.726100e-02,3.538400e-01,9.810100e-02, & - &8.752800e-02,7.783800e-02,6.792100e-02,5.803100e-02,4.801100e-02, & - &3.735600e-02,9.810100e-02,3.511000e-01,9.872100e-02,8.935800e-02, & - &8.084400e-02,7.215600e-02,6.330300e-02,5.381200e-02,4.347800e-02, & - &9.872100e-02,3.490500e-01,9.907300e-02,9.144800e-02,8.455600e-02, & - &7.737300e-02,6.936900e-02,6.048200e-02,5.043400e-02,9.907300e-02, & - &3.471000e-01,9.922900e-02,9.391700e-02,8.902800e-02,8.307000e-02, & - &7.579500e-02,6.746400e-02,5.774500e-02,9.922900e-02,3.452600e-01, & - &9.093800e-02,8.063300e-02,7.095400e-02,6.119800e-02,5.134900e-02, & - &4.151300e-02,3.132100e-02,9.093800e-02,4.763000e-01,9.152400e-02, & - &8.207600e-02,7.333300e-02,6.442700e-02,5.552600e-02,4.630400e-02, & - &3.640800e-02,9.152400e-02,4.714900e-01,9.187000e-02,8.378500e-02, & - &7.635400e-02,6.872600e-02,6.065000e-02,5.187800e-02,4.235000e-02, & - &9.187000e-02,4.678100e-01,9.205700e-02,8.586400e-02,8.005300e-02, & - &7.365000e-02,6.636100e-02,5.817500e-02,4.889000e-02,9.205700e-02, & - &4.647100e-01,9.205100e-02,8.815300e-02,8.423800e-02,7.882900e-02, & - &7.222400e-02,6.466200e-02,5.579000e-02,9.205100e-02,4.617700e-01/ - data absa(1:270,10) / & - &1.897000e-01,1.672200e-01,1.594000e-01,1.465400e-01,1.341200e-01, & - &1.199000e-01,1.015300e-01,1.897000e-01,1.268300e-01,1.931000e-01, & - &1.758400e-01,1.703200e-01,1.628700e-01,1.519800e-01,1.363700e-01, & - &1.133800e-01,1.931000e-01,1.649200e-01,1.964400e-01,1.861600e-01, & - &1.846300e-01,1.785300e-01,1.668600e-01,1.530700e-01,1.300600e-01, & - &1.964400e-01,2.095100e-01,1.990900e-01,1.951000e-01,1.979400e-01, & - &1.945500e-01,1.881400e-01,1.697000e-01,1.404900e-01,1.990900e-01, & - &2.602300e-01,2.014100e-01,2.042300e-01,2.119800e-01,2.135900e-01, & - &2.032000e-01,1.783900e-01,1.616600e-01,2.014100e-01,3.181400e-01, & - &1.851300e-01,1.641700e-01,1.557000e-01,1.429900e-01,1.302800e-01, & - &1.155800e-01,9.757500e-02,1.851300e-01,1.203300e-01,1.895000e-01, & - &1.738100e-01,1.671000e-01,1.596200e-01,1.469700e-01,1.306100e-01, & - &1.096100e-01,1.895000e-01,1.592000e-01,1.936200e-01,1.839500e-01, & - &1.819500e-01,1.741900e-01,1.616700e-01,1.482800e-01,1.256800e-01, & - &1.936200e-01,2.028200e-01,1.972100e-01,1.934800e-01,1.953000e-01, & - &1.911200e-01,1.828400e-01,1.650000e-01,1.370800e-01,1.972100e-01, & - &2.520400e-01,2.002300e-01,2.032000e-01,2.102000e-01,2.081900e-01, & - &1.974100e-01,1.746600e-01,1.534300e-01,2.002300e-01,3.080800e-01, & - &1.800100e-01,1.591800e-01,1.495700e-01,1.363400e-01,1.240000e-01, & - &1.105200e-01,9.351000e-02,1.800100e-01,1.021900e-01,1.852800e-01, & - &1.690100e-01,1.609600e-01,1.532700e-01,1.406100e-01,1.248100e-01, & - &1.068200e-01,1.852800e-01,1.377300e-01,1.902300e-01,1.792900e-01, & - &1.758200e-01,1.670000e-01,1.543000e-01,1.416100e-01,1.225200e-01, & - &1.902300e-01,1.787700e-01,1.946900e-01,1.889300e-01,1.890600e-01, & - &1.831400e-01,1.744900e-01,1.594800e-01,1.340800e-01,1.946900e-01, & - &2.272300e-01,1.982100e-01,1.994600e-01,2.041500e-01,1.992200e-01, & - &1.897200e-01,1.722900e-01,1.517000e-01,1.982100e-01,2.824300e-01, & - &1.791600e-01,1.569300e-01,1.431700e-01,1.297000e-01,1.182000e-01, & - &1.054200e-01,8.881000e-02,1.791600e-01,8.162900e-02,1.839300e-01, & - &1.649600e-01,1.540800e-01,1.465600e-01,1.347000e-01,1.196800e-01, & - &1.010900e-01,1.839300e-01,1.130000e-01,1.882900e-01,1.739500e-01, & - &1.691200e-01,1.609000e-01,1.483600e-01,1.353300e-01,1.168800e-01, & - &1.882900e-01,1.501100e-01,1.923800e-01,1.836400e-01,1.824200e-01, & - &1.761700e-01,1.676100e-01,1.543000e-01,1.305600e-01,1.923000e-01, & - &1.953200e-01,1.957400e-01,1.946300e-01,1.970500e-01,1.926400e-01, & - &1.851100e-01,1.715700e-01,1.514500e-01,1.957400e-01,2.470100e-01, & - &1.879700e-01,1.645300e-01,1.453300e-01,1.268600e-01,1.121900e-01, & - &9.871900e-02,8.193200e-02,1.879700e-01,6.516600e-02,1.916000e-01, & - &1.692500e-01,1.521800e-01,1.401400e-01,1.291700e-01,1.130200e-01, & - &9.448000e-02,1.916000e-01,9.207700e-02,1.944600e-01,1.757800e-01, & - &1.640200e-01,1.550600e-01,1.423500e-01,1.278000e-01,1.106600e-01, & - &1.944600e-01,1.247900e-01,1.973600e-01,1.818300e-01,1.766400e-01, & - &1.699900e-01,1.617900e-01,1.482600e-01,1.281600e-01,1.973600e-01, & - &1.634600e-01,2.001100e-01,1.907400e-01,1.908200e-01,1.882900e-01, & - &1.808000e-01,1.685800e-01,1.500900e-01,2.001100e-01,2.082200e-01, & - &2.022300e-01,1.769900e-01,1.532200e-01,1.312800e-01,1.109200e-01, & - &9.156100e-02,7.366100e-02,2.022300e-01,5.137700e-02,2.051200e-01, & - &1.796700e-01,1.578800e-01,1.393800e-01,1.226800e-01,1.054300e-01, & - &8.738500e-02,2.051200e-01,7.385300e-02,2.079000e-01,1.845000e-01, & - &1.652900e-01,1.511200e-01,1.352900e-01,1.202200e-01,1.039800e-01, & - &2.079000e-01,1.008700e-01,2.100400e-01,1.882300e-01,1.750900e-01, & - &1.628400e-01,1.538600e-01,1.415500e-01,1.242700e-01,2.100400e-01, & - &1.336000e-01,2.118300e-01,1.942800e-01,1.851300e-01,1.817700e-01, & - &1.749800e-01,1.642300e-01,1.470400e-01,2.118300e-01,1.717800e-01/ - data absa(271:585,10) / & - &2.196600e-01,1.922300e-01,1.648700e-01,1.407500e-01,1.174300e-01, & - &9.235200e-02,6.716500e-02,2.196600e-01,3.984400e-02,2.228900e-01, & - &1.950500e-01,1.701200e-01,1.471100e-01,1.248200e-01,1.016600e-01, & - &8.111600e-02,2.228900e-01,5.880300e-02,2.256200e-01,1.991800e-01, & - &1.755800e-01,1.557900e-01,1.336100e-01,1.138100e-01,9.829600e-02, & - &2.256200e-01,8.210500e-02,2.279800e-01,2.028300e-01,1.839300e-01, & - &1.636000e-01,1.467200e-01,1.348200e-01,1.194200e-01,2.279800e-01, & - &1.101300e-01,2.296500e-01,2.071300e-01,1.904500e-01,1.771100e-01, & - &1.689000e-01,1.587500e-01,1.429400e-01,2.296500e-01,1.430100e-01, & - &2.392700e-01,2.094000e-01,1.795300e-01,1.507400e-01,1.250500e-01, & - &9.733800e-02,6.876100e-02,2.392700e-01,3.157200e-02,2.424300e-01, & - &2.121600e-01,1.835900e-01,1.575600e-01,1.306900e-01,1.045600e-01, & - &7.792300e-02,2.424300e-01,4.597800e-02,2.454700e-01,2.153400e-01, & - &1.885300e-01,1.650300e-01,1.389600e-01,1.137700e-01,9.342500e-02, & - &2.454700e-01,6.438100e-02,2.480200e-01,2.196600e-01,1.964800e-01, & - &1.719700e-01,1.487200e-01,1.296700e-01,1.141700e-01,2.480200e-01, & - &8.797000e-02,2.499800e-01,2.230900e-01,2.026100e-01,1.823200e-01, & - &1.651700e-01,1.526400e-01,1.383400e-01,2.499800e-01,1.163900e-01, & - &2.614800e-01,2.288200e-01,1.961800e-01,1.637000e-01,1.344800e-01, & - &1.039500e-01,7.162900e-02,2.614800e-01,2.850300e-02,2.651900e-01, & - &2.321000e-01,1.993700e-01,1.701500e-01,1.396400e-01,1.089200e-01, & - &7.888900e-02,2.651900e-01,3.800800e-02,2.682400e-01,2.347800e-01, & - &2.044900e-01,1.756200e-01,1.465200e-01,1.167400e-01,9.227000e-02, & - &2.682400e-01,5.242200e-02,2.707800e-01,2.387700e-01,2.105400e-01, & - &1.826400e-01,1.541200e-01,1.304100e-01,1.074900e-01,2.707800e-01, & - &7.033800e-02,2.726400e-01,2.416100e-01,2.166200e-01,1.897800e-01, & - &1.686000e-01,1.480400e-01,1.308000e-01,2.726400e-01,9.255400e-02, & - &2.820100e-01,2.467800e-01,2.115600e-01,1.763800e-01,1.435200e-01, & - &1.108400e-01,7.697200e-02,2.820100e-01,1.247100e-01,2.857600e-01, & - &2.500600e-01,2.143800e-01,1.823100e-01,1.496100e-01,1.154900e-01, & - &8.200600e-02,2.857600e-01,1.249600e-01,2.889300e-01,2.528600e-01, & - &2.194900e-01,1.878700e-01,1.555100e-01,1.222800e-01,9.340600e-02, & - &2.889300e-01,1.285700e-01,2.914300e-01,2.565300e-01,2.251800e-01, & - &1.946600e-01,1.619700e-01,1.340900e-01,1.061400e-01,2.914300e-01, & - &1.366400e-01,2.926900e-01,2.587800e-01,2.309700e-01,1.996700e-01, & - &1.742600e-01,1.493300e-01,1.247700e-01,2.926900e-01,1.464800e-01, & - &3.000300e-01,2.625500e-01,2.250600e-01,1.881900e-01,1.537100e-01, & - &1.185100e-01,8.180900e-02,3.000300e-01,3.145400e-01,3.032400e-01, & - &2.653500e-01,2.277500e-01,1.944800e-01,1.590300e-01,1.229200e-01, & - &8.886500e-02,3.032400e-01,3.086100e-01,3.049300e-01,2.668600e-01, & - &2.326600e-01,1.991800e-01,1.649000e-01,1.315300e-01,1.007800e-01, & - &3.049300e-01,3.069900e-01,3.057700e-01,2.694000e-01,2.378900e-01, & - &2.049500e-01,1.733800e-01,1.446700e-01,1.131400e-01,3.057700e-01, & - &3.108200e-01,3.055100e-01,2.704400e-01,2.422700e-01,2.122900e-01, & - &1.880100e-01,1.597900e-01,1.309000e-01,3.055100e-01,3.152700e-01, & - &3.113400e-01,2.724300e-01,2.335400e-01,1.963900e-01,1.609000e-01, & - &1.238700e-01,8.605200e-02,3.113400e-01,5.297800e-01,3.135900e-01, & - &2.744100e-01,2.367700e-01,2.023800e-01,1.655200e-01,1.290100e-01, & - &9.520700e-02,3.135900e-01,5.205200e-01,3.141500e-01,2.753700e-01, & - &2.412200e-01,2.071500e-01,1.719300e-01,1.399700e-01,1.072000e-01, & - &3.141500e-01,5.156000e-01,3.137200e-01,2.767800e-01,2.460900e-01, & - &2.125600e-01,1.833500e-01,1.532200e-01,1.208100e-01,3.137200e-01, & - &5.155700e-01,3.123900e-01,2.782200e-01,2.495600e-01,2.236700e-01, & - &1.983800e-01,1.693700e-01,1.360600e-01,3.123900e-01,5.166700e-01, & - &3.163800e-01,2.768300e-01,2.375000e-01,2.011400e-01,1.645600e-01, & - &1.263200e-01,8.925300e-02,3.163800e-01,7.349700e-01,3.167100e-01, & - &2.771300e-01,2.409700e-01,2.054200e-01,1.686600e-01,1.334700e-01, & - &9.965800e-02,3.167100e-01,7.189100e-01,3.165900e-01,2.782400e-01, & - &2.444800e-01,2.104800e-01,1.771500e-01,1.454900e-01,1.113200e-01, & - &3.165900e-01,7.102000e-01,3.148400e-01,2.784500e-01,2.484900e-01, & - &2.179600e-01,1.894800e-01,1.595500e-01,1.263500e-01,3.148400e-01, & - &7.075600e-01,3.118600e-01,2.805400e-01,2.536200e-01,2.308600e-01, & - &2.049600e-01,1.751200e-01,1.414300e-01,3.118600e-01,7.058400e-01/ - data absa(1:270,11) / & - &3.132700e-01,2.743800e-01,2.386400e-01,2.164800e-01,1.869000e-01, & - &1.567300e-01,1.273400e-01,3.132700e-01,1.498600e-01,3.139200e-01, & - &2.749100e-01,2.520000e-01,2.273400e-01,2.030300e-01,1.754100e-01, & - &1.408900e-01,3.139200e-01,1.970700e-01,3.138300e-01,2.765000e-01, & - &2.610900e-01,2.419500e-01,2.192700e-01,1.865000e-01,1.495500e-01, & - &3.138300e-01,2.515900e-01,3.127200e-01,2.840300e-01,2.722300e-01, & - &2.558500e-01,2.285400e-01,2.009200e-01,1.869100e-01,3.127200e-01, & - &3.130400e-01,3.109000e-01,2.895500e-01,2.819100e-01,2.666400e-01, & - &2.412100e-01,2.130100e-01,2.413700e-01,3.109000e-01,3.811800e-01, & - &3.132400e-01,2.742200e-01,2.392000e-01,2.150000e-01,1.849500e-01, & - &1.552800e-01,1.257700e-01,3.132400e-01,1.504500e-01,3.147000e-01, & - &2.755700e-01,2.522300e-01,2.265700e-01,2.021000e-01,1.742100e-01, & - &1.383700e-01,3.147000e-01,1.986600e-01,3.153600e-01,2.792600e-01, & - &2.614100e-01,2.421400e-01,2.188800e-01,1.847800e-01,1.507400e-01, & - &3.153600e-01,2.567700e-01,3.150400e-01,2.877900e-01,2.737600e-01, & - &2.563300e-01,2.294200e-01,1.999300e-01,1.711200e-01,3.150400e-01, & - &3.230200e-01,3.138100e-01,2.932400e-01,2.851900e-01,2.695100e-01, & - &2.405500e-01,2.079300e-01,2.170000e-01,3.138100e-01,3.962500e-01, & - &3.120400e-01,2.731500e-01,2.370400e-01,2.109400e-01,1.796600e-01, & - &1.489600e-01,1.201300e-01,3.120400e-01,1.375800e-01,3.146600e-01, & - &2.754700e-01,2.502900e-01,2.218300e-01,1.965100e-01,1.691200e-01, & - &1.325800e-01,3.146600e-01,1.858600e-01,3.161700e-01,2.799200e-01, & - &2.594800e-01,2.388400e-01,2.144500e-01,1.803000e-01,1.445000e-01, & - &3.161700e-01,2.426600e-01,3.168100e-01,2.889000e-01,2.722100e-01, & - &2.533400e-01,2.258000e-01,1.947100e-01,1.579900e-01,3.168100e-01, & - &3.076200e-01,3.166000e-01,2.949000e-01,2.847200e-01,2.681700e-01, & - &2.381400e-01,2.050600e-01,1.841800e-01,3.166000e-01,3.816200e-01, & - &3.086600e-01,2.701600e-01,2.334100e-01,2.059200e-01,1.736500e-01, & - &1.415200e-01,1.135000e-01,3.086600e-01,1.172900e-01,3.126100e-01, & - &2.736400e-01,2.467900e-01,2.168700e-01,1.891200e-01,1.622700e-01, & - &1.287700e-01,3.126100e-01,1.626300e-01,3.151700e-01,2.786600e-01, & - &2.563300e-01,2.332200e-01,2.081800e-01,1.752400e-01,1.401100e-01, & - &3.151700e-01,2.174100e-01,3.171800e-01,2.880200e-01,2.694700e-01, & - &2.486600e-01,2.206100e-01,1.894200e-01,1.569500e-01,3.172700e-01, & - &2.801200e-01,3.185800e-01,2.947900e-01,2.819000e-01,2.630900e-01, & - &2.344800e-01,2.006800e-01,1.693000e-01,3.185800e-01,3.497900e-01, & - &3.035900e-01,2.657200e-01,2.287400e-01,1.997400e-01,1.682600e-01, & - &1.365300e-01,1.095900e-01,3.035900e-01,9.556400e-02,3.096100e-01, & - &2.709800e-01,2.419100e-01,2.117200e-01,1.819700e-01,1.568800e-01, & - &1.268200e-01,3.096100e-01,1.354600e-01,3.143100e-01,2.773700e-01, & - &2.523100e-01,2.274300e-01,2.021700e-01,1.726800e-01,1.376800e-01, & - &3.143100e-01,1.848400e-01,3.178700e-01,2.873400e-01,2.657900e-01, & - &2.430800e-01,2.153300e-01,1.867900e-01,1.534700e-01,3.178700e-01, & - &2.431500e-01,3.202700e-01,2.946800e-01,2.787000e-01,2.569500e-01, & - &2.318900e-01,2.001600e-01,1.685000e-01,3.202700e-01,3.115900e-01, & - &2.986500e-01,2.613900e-01,2.241700e-01,1.923700e-01,1.626100e-01, & - &1.330600e-01,1.040200e-01,2.986500e-01,7.472800e-02,3.061900e-01, & - &2.680000e-01,2.365200e-01,2.057900e-01,1.768400e-01,1.516800e-01, & - &1.222300e-01,3.061900e-01,1.082900e-01,3.124100e-01,2.751400e-01, & - &2.481500e-01,2.208100e-01,1.972000e-01,1.691700e-01,1.339600e-01, & - &3.124100e-01,1.515100e-01,3.166100e-01,2.853800e-01,2.610400e-01, & - &2.384100e-01,2.116500e-01,1.824300e-01,1.488700e-01,3.166100e-01, & - &2.034800e-01,3.200000e-01,2.929300e-01,2.747900e-01,2.514600e-01, & - &2.288100e-01,1.989300e-01,1.674500e-01,3.200000e-01,2.652000e-01/ - data absa(271:585,11) / & - &3.008100e-01,2.632400e-01,2.256700e-01,1.894700e-01,1.582400e-01, & - &1.293400e-01,9.913900e-02,3.008100e-01,5.823600e-02,3.078500e-01, & - &2.693800e-01,2.336200e-01,2.022500e-01,1.719700e-01,1.452600e-01, & - &1.160600e-01,3.078500e-01,8.614300e-02,3.135500e-01,2.747100e-01, & - &2.447500e-01,2.155800e-01,1.920300e-01,1.635900e-01,1.288400e-01, & - &3.135500e-01,1.227900e-01,3.177300e-01,2.833900e-01,2.553400e-01, & - &2.339600e-01,2.075500e-01,1.765800e-01,1.445000e-01,3.177300e-01, & - &1.675200e-01,3.207300e-01,2.901800e-01,2.695200e-01,2.469700e-01, & - &2.238100e-01,1.962300e-01,1.658200e-01,3.207300e-01,2.216500e-01, & - &3.162900e-01,2.767600e-01,2.372800e-01,1.977600e-01,1.610900e-01, & - &1.290100e-01,9.469900e-02,3.162900e-01,4.530000e-02,3.222700e-01, & - &2.820300e-01,2.421400e-01,2.063600e-01,1.726200e-01,1.401600e-01, & - &1.087700e-01,3.222700e-01,6.885300e-02,3.268800e-01,2.860700e-01, & - &2.506900e-01,2.155600e-01,1.874800e-01,1.566100e-01,1.229900e-01, & - &3.268800e-01,1.001800e-01,3.298100e-01,2.914000e-01,2.571200e-01, & - &2.307800e-01,2.015800e-01,1.705800e-01,1.400600e-01,3.298100e-01, & - &1.383800e-01,3.318800e-01,2.961800e-01,2.678400e-01,2.420900e-01, & - &2.169600e-01,1.924000e-01,1.648000e-01,3.318800e-01,1.838800e-01, & - &3.405400e-01,2.979800e-01,2.554300e-01,2.128700e-01,1.707900e-01, & - &1.342100e-01,9.571000e-02,3.405400e-01,3.823600e-02,3.463300e-01, & - &3.030500e-01,2.597600e-01,2.189000e-01,1.814700e-01,1.422500e-01, & - &1.035000e-01,3.463300e-01,5.623800e-02,3.503700e-01,3.065700e-01, & - &2.660200e-01,2.267800e-01,1.899400e-01,1.534400e-01,1.166700e-01, & - &3.503700e-01,8.174300e-02,3.522800e-01,3.094400e-01,2.699200e-01, & - &2.366000e-01,2.012300e-01,1.648700e-01,1.360200e-01,3.522800e-01, & - &1.141300e-01,3.522500e-01,3.121100e-01,2.773100e-01,2.449300e-01, & - &2.116000e-01,1.873800e-01,1.627600e-01,3.522500e-01,1.534800e-01, & - &3.685200e-01,3.224700e-01,2.764400e-01,2.303900e-01,1.844800e-01, & - &1.418800e-01,9.975700e-02,3.685200e-01,1.404000e-01,3.731500e-01, & - &3.265200e-01,2.798900e-01,2.336600e-01,1.926100e-01,1.500300e-01, & - &1.058600e-01,3.731500e-01,1.452600e-01,3.757100e-01,3.287800e-01, & - &2.836600e-01,2.410400e-01,1.998700e-01,1.582000e-01,1.157800e-01, & - &3.757100e-01,1.549700e-01,3.770500e-01,3.302400e-01,2.873500e-01, & - &2.493300e-01,2.090700e-01,1.674800e-01,1.341300e-01,3.770500e-01, & - &1.674600e-01,3.762800e-01,3.324700e-01,2.934300e-01,2.566300e-01, & - &2.174800e-01,1.867300e-01,1.605800e-01,3.762800e-01,1.827500e-01, & - &4.003800e-01,3.503500e-01,3.003400e-01,2.503000e-01,2.011600e-01, & - &1.552200e-01,1.082300e-01,4.003800e-01,3.549000e-01,4.039600e-01, & - &3.535000e-01,3.030100e-01,2.542500e-01,2.094600e-01,1.619500e-01, & - &1.137400e-01,4.039600e-01,3.485600e-01,4.056500e-01,3.549600e-01, & - &3.066500e-01,2.611200e-01,2.155100e-01,1.695800e-01,1.257200e-01, & - &4.056500e-01,3.507600e-01,4.055800e-01,3.559500e-01,3.093800e-01, & - &2.684000e-01,2.230100e-01,1.804600e-01,1.440300e-01,4.055800e-01, & - &3.572200e-01,4.044600e-01,3.571200e-01,3.155300e-01,2.732300e-01, & - &2.336600e-01,2.021000e-01,1.687500e-01,4.044600e-01,3.671900e-01, & - &4.315400e-01,3.776400e-01,3.237000e-01,2.698100e-01,2.180400e-01, & - &1.685000e-01,1.166900e-01,4.315400e-01,6.013400e-01,4.337400e-01, & - &3.795600e-01,3.253600e-01,2.746600e-01,2.255500e-01,1.738500e-01, & - &1.229000e-01,4.337400e-01,5.847900e-01,4.333100e-01,3.791600e-01, & - &3.280800e-01,2.800000e-01,2.315600e-01,1.816600e-01,1.363000e-01, & - &4.333100e-01,5.770100e-01,4.321600e-01,3.800900e-01,3.313600e-01, & - &2.869200e-01,2.383500e-01,1.956900e-01,1.540600e-01,4.321600e-01, & - &5.778800e-01,4.292400e-01,3.792900e-01,3.364400e-01,2.916200e-01, & - &2.535800e-01,2.159800e-01,1.780100e-01,4.292400e-01,5.859000e-01, & - &4.550700e-01,3.982000e-01,3.413400e-01,2.848600e-01,2.319900e-01, & - &1.790800e-01,1.237800e-01,4.550700e-01,8.346600e-01,4.556000e-01, & - &3.986500e-01,3.420700e-01,2.907600e-01,2.382400e-01,1.841300e-01, & - &1.323100e-01,4.556000e-01,8.174300e-01,4.540800e-01,3.973800e-01, & - &3.450800e-01,2.949400e-01,2.444700e-01,1.940000e-01,1.465800e-01, & - &4.540800e-01,8.039500e-01,4.506100e-01,3.969300e-01,3.484100e-01, & - &3.008600e-01,2.538600e-01,2.097600e-01,1.640700e-01,4.506100e-01, & - &8.011200e-01,4.463200e-01,3.950900e-01,3.517900e-01,3.091000e-01, & - &2.715300e-01,2.303000e-01,1.864500e-01,4.463200e-01,8.044500e-01/ - data absa(1:270,12) / & - &4.513400e-01,3.950800e-01,3.389000e-01,2.882500e-01,2.477800e-01, & - &1.992400e-01,1.487500e-01,4.513400e-01,1.882400e-01,4.430200e-01, & - &3.878000e-01,3.347700e-01,2.979300e-01,2.516300e-01,2.088000e-01, & - &1.642100e-01,4.430200e-01,2.439300e-01,4.344200e-01,3.802700e-01, & - &3.411000e-01,2.999300e-01,2.602200e-01,2.194900e-01,2.033700e-01, & - &4.344200e-01,3.121100e-01,4.254800e-01,3.724800e-01,3.400100e-01, & - &3.036300e-01,2.687200e-01,2.352900e-01,2.620800e-01,4.254800e-01, & - &4.021800e-01,4.163700e-01,3.718400e-01,3.395600e-01,3.070200e-01, & - &2.766600e-01,3.004800e-01,3.337000e-01,4.163700e-01,5.181000e-01, & - &4.599300e-01,4.025700e-01,3.452200e-01,2.946000e-01,2.512000e-01, & - &2.007500e-01,1.499400e-01,4.599300e-01,1.838000e-01,4.521400e-01, & - &3.956900e-01,3.430600e-01,3.031400e-01,2.554200e-01,2.117000e-01, & - &1.651700e-01,4.521400e-01,2.430200e-01,4.439200e-01,3.885900e-01, & - &3.483600e-01,3.054400e-01,2.649900e-01,2.241800e-01,1.873100e-01, & - &4.439200e-01,3.130000e-01,4.354200e-01,3.819400e-01,3.476900e-01, & - &3.098500e-01,2.729100e-01,2.316000e-01,2.475800e-01,4.354200e-01, & - &3.963600e-01,4.265900e-01,3.810200e-01,3.459700e-01,3.126700e-01, & - &2.810100e-01,2.855900e-01,3.226400e-01,4.265900e-01,5.018700e-01, & - &4.683300e-01,4.098800e-01,3.514600e-01,2.972500e-01,2.525500e-01, & - &2.007100e-01,1.465800e-01,4.683300e-01,1.749300e-01,4.612100e-01, & - &4.036600e-01,3.487800e-01,3.068200e-01,2.566800e-01,2.103000e-01, & - &1.655600e-01,4.612100e-01,2.337300e-01,4.537800e-01,3.971600e-01, & - &3.541500e-01,3.089500e-01,2.667700e-01,2.248300e-01,1.737400e-01, & - &4.537800e-01,3.065600e-01,4.457600e-01,3.913200e-01,3.537500e-01, & - &3.140900e-01,2.747300e-01,2.311400e-01,2.167700e-01,4.457600e-01, & - &3.929600e-01,4.370500e-01,3.904600e-01,3.532600e-01,3.167900e-01, & - &2.850200e-01,2.571200e-01,2.893000e-01,4.370500e-01,4.902600e-01, & - &4.759500e-01,4.165500e-01,3.571400e-01,2.992000e-01,2.521300e-01, & - &1.998200e-01,1.438100e-01,4.759500e-01,1.587200e-01,4.703300e-01, & - &4.116100e-01,3.541400e-01,3.092200e-01,2.584600e-01,2.073100e-01, & - &1.621500e-01,4.703300e-01,2.180000e-01,4.635200e-01,4.056500e-01, & - &3.597100e-01,3.120400e-01,2.667800e-01,2.229200e-01,1.712200e-01, & - &4.635200e-01,2.901800e-01,4.558500e-01,4.002700e-01,3.592000e-01, & - &3.181400e-01,2.757100e-01,2.298800e-01,1.880700e-01,4.558500e-01, & - &3.761500e-01,4.474700e-01,3.999400e-01,3.604500e-01,3.210200e-01, & - &2.848200e-01,2.419400e-01,2.487200e-01,4.474700e-01,4.773300e-01, & - &4.833200e-01,4.229600e-01,3.626000e-01,3.023500e-01,2.504200e-01, & - &1.986400e-01,1.413000e-01,4.833200e-01,1.374500e-01,4.786700e-01, & - &4.189000e-01,3.594700e-01,3.112700e-01,2.592700e-01,2.049300e-01, & - &1.575000e-01,4.786700e-01,1.959600e-01,4.725900e-01,4.135800e-01, & - &3.652000e-01,3.145900e-01,2.672300e-01,2.204800e-01,1.703200e-01, & - &4.725900e-01,2.674200e-01,4.653800e-01,4.085000e-01,3.651800e-01, & - &3.217600e-01,2.768800e-01,2.277700e-01,1.808800e-01,4.653800e-01, & - &3.519600e-01,4.576900e-01,4.089600e-01,3.672600e-01,3.257100e-01, & - &2.832100e-01,2.409800e-01,2.146200e-01,4.576900e-01,4.512300e-01, & - &4.899300e-01,4.287700e-01,3.675600e-01,3.063700e-01,2.486100e-01, & - &1.959200e-01,1.409700e-01,4.899300e-01,1.130900e-01,4.862300e-01, & - &4.255100e-01,3.648000e-01,3.125900e-01,2.593700e-01,2.029300e-01, & - &1.535900e-01,4.862300e-01,1.665400e-01,4.815800e-01,4.214500e-01, & - &3.698100e-01,3.181100e-01,2.657900e-01,2.180500e-01,1.703400e-01, & - &4.815800e-01,2.341600e-01,4.758000e-01,4.167500e-01,3.710800e-01, & - &3.245600e-01,2.780300e-01,2.283300e-01,1.806600e-01,4.758000e-01, & - &3.160700e-01,4.675800e-01,4.165200e-01,3.736700e-01,3.314700e-01, & - &2.838000e-01,2.422300e-01,1.984100e-01,4.675800e-01,4.118100e-01/ - data absa(271:585,12) / & - &4.955600e-01,4.336500e-01,3.717500e-01,3.098500e-01,2.485400e-01, & - &1.927700e-01,1.401300e-01,4.955600e-01,8.947300e-02,4.936300e-01, & - &4.319500e-01,3.702900e-01,3.125600e-01,2.596300e-01,2.032800e-01, & - &1.519400e-01,4.936300e-01,1.361900e-01,4.898800e-01,4.286600e-01, & - &3.726500e-01,3.207300e-01,2.654900e-01,2.178700e-01,1.701000e-01, & - &4.898800e-01,1.964400e-01,4.835600e-01,4.233500e-01,3.764000e-01, & - &3.264800e-01,2.804500e-01,2.319000e-01,1.795500e-01,4.835600e-01, & - &2.716300e-01,4.761300e-01,4.234300e-01,3.794100e-01,3.367700e-01, & - &2.883900e-01,2.441600e-01,1.924000e-01,4.761300e-01,3.614600e-01, & - &4.995200e-01,4.371300e-01,3.746900e-01,3.122800e-01,2.499200e-01, & - &1.899200e-01,1.391000e-01,4.995200e-01,7.006800e-02,4.987600e-01, & - &4.364700e-01,3.741500e-01,3.135900e-01,2.589800e-01,2.036500e-01, & - &1.522500e-01,4.987600e-01,1.091100e-01,4.956100e-01,4.336700e-01, & - &3.747800e-01,3.225300e-01,2.665200e-01,2.180200e-01,1.693100e-01, & - &4.956100e-01,1.606500e-01,4.913200e-01,4.299500e-01,3.805600e-01, & - &3.282500e-01,2.831300e-01,2.356100e-01,1.796300e-01,4.913200e-01, & - &2.265700e-01,4.849300e-01,4.303700e-01,3.839200e-01,3.399900e-01, & - &2.950600e-01,2.459200e-01,1.930500e-01,4.849300e-01,3.079800e-01, & - &5.029700e-01,4.401100e-01,3.772700e-01,3.144500e-01,2.516400e-01, & - &1.892300e-01,1.363000e-01,5.029700e-01,5.592800e-02,5.028000e-01, & - &4.399900e-01,3.771900e-01,3.143900e-01,2.559600e-01,2.038700e-01, & - &1.519400e-01,5.028000e-01,8.725900e-02,5.016500e-01,4.389900e-01, & - &3.773300e-01,3.231600e-01,2.681500e-01,2.176500e-01,1.672900e-01, & - &5.016500e-01,1.303200e-01,4.977500e-01,4.355800e-01,3.832500e-01, & - &3.289800e-01,2.834800e-01,2.369600e-01,1.799200e-01,4.977500e-01, & - &1.869700e-01,4.925600e-01,4.353300e-01,3.860000e-01,3.428500e-01, & - &2.991700e-01,2.475700e-01,1.946900e-01,4.925600e-01,2.577600e-01, & - &5.177300e-01,4.530500e-01,3.883200e-01,3.236100e-01,2.589400e-01, & - &1.944400e-01,1.362600e-01,5.177300e-01,1.714300e-01,5.201400e-01, & - &4.551800e-01,3.901400e-01,3.251100e-01,2.613700e-01,2.055800e-01, & - &1.509100e-01,5.201400e-01,1.787800e-01,5.185900e-01,4.537600e-01, & - &3.889900e-01,3.297700e-01,2.717800e-01,2.180600e-01,1.645000e-01, & - &5.185900e-01,1.877800e-01,5.146400e-01,4.503600e-01,3.927800e-01, & - &3.342900e-01,2.852000e-01,2.359300e-01,1.792300e-01,5.146400e-01, & - &2.068600e-01,5.101800e-01,4.490500e-01,3.944000e-01,3.470300e-01, & - &3.002600e-01,2.481700e-01,1.972700e-01,5.101800e-01,2.434200e-01, & - &5.483200e-01,4.797700e-01,4.112600e-01,3.427400e-01,2.742000e-01, & - &2.070300e-01,1.463600e-01,5.483200e-01,4.222900e-01,5.489000e-01, & - &4.802900e-01,4.116900e-01,3.430800e-01,2.780300e-01,2.190200e-01, & - &1.567500e-01,5.489000e-01,4.130400e-01,5.476000e-01,4.791200e-01, & - &4.114800e-01,3.484500e-01,2.880200e-01,2.286400e-01,1.695700e-01, & - &5.476000e-01,4.186600e-01,5.445100e-01,4.764600e-01,4.146600e-01, & - &3.532400e-01,3.004300e-01,2.425300e-01,1.858800e-01,5.445100e-01, & - &4.296300e-01,5.384400e-01,4.749900e-01,4.151400e-01,3.647200e-01, & - &3.097700e-01,2.565500e-01,2.138700e-01,5.384400e-01,4.451300e-01, & - &5.906500e-01,5.168400e-01,4.430400e-01,3.691400e-01,2.953600e-01, & - &2.245200e-01,1.581200e-01,5.906500e-01,7.008800e-01,5.887200e-01, & - &5.151600e-01,4.415700e-01,3.681800e-01,3.005000e-01,2.347000e-01, & - &1.653300e-01,5.887200e-01,6.872400e-01,5.865700e-01,5.132800e-01, & - &4.418300e-01,3.735700e-01,3.088300e-01,2.436900e-01,1.772000e-01, & - &5.865700e-01,6.769200e-01,5.820200e-01,5.095400e-01,4.428700e-01, & - &3.799600e-01,3.190100e-01,2.535500e-01,1.975400e-01,5.820200e-01, & - &6.806300e-01,5.748800e-01,5.073600e-01,4.444800e-01,3.873400e-01, & - &3.263600e-01,2.753000e-01,2.289600e-01,5.748800e-01,6.886400e-01, & - &6.333000e-01,5.541400e-01,4.750000e-01,3.958500e-01,3.169700e-01, & - &2.432900e-01,1.702400e-01,6.333000e-01,9.619300e-01,6.322300e-01, & - &5.531900e-01,4.742400e-01,3.963800e-01,3.247300e-01,2.515200e-01, & - &1.759900e-01,6.322300e-01,9.444400e-01,6.274400e-01,5.490500e-01, & - &4.737300e-01,4.007600e-01,3.305000e-01,2.602500e-01,1.899300e-01, & - &6.274400e-01,9.285900e-01,6.216100e-01,5.450200e-01,4.727900e-01, & - &4.077400e-01,3.392200e-01,2.716400e-01,2.121600e-01,6.216100e-01, & - &9.198300e-01,6.141600e-01,5.419000e-01,4.754500e-01,4.109400e-01, & - &3.498800e-01,2.976700e-01,2.431500e-01,6.141600e-01,9.207600e-01/ - data absa(1:270,13) / & - &5.680100e-01,4.975300e-01,4.261400e-01,3.556200e-01,2.978400e-01, & - &2.376200e-01,1.706700e-01,5.680100e-01,2.884700e-01,5.450600e-01, & - &4.771300e-01,4.094500e-01,3.561400e-01,2.990600e-01,2.368700e-01, & - &2.180600e-01,5.450600e-01,3.956600e-01,5.220800e-01,4.570400e-01, & - &4.010300e-01,3.509900e-01,2.964000e-01,2.738200e-01,2.961100e-01, & - &5.220800e-01,5.381300e-01,5.000900e-01,4.377700e-01,3.942400e-01, & - &3.474300e-01,3.138000e-01,3.565500e-01,3.884400e-01,5.000900e-01, & - &7.124800e-01,4.784200e-01,4.206700e-01,3.868100e-01,3.443800e-01, & - &3.822400e-01,4.487400e-01,4.967000e-01,4.784200e-01,9.206900e-01, & - &5.892900e-01,5.157600e-01,4.425300e-01,3.689900e-01,3.086600e-01, & - &2.459300e-01,1.741900e-01,5.892900e-01,2.701600e-01,5.649500e-01, & - &4.944600e-01,4.240500e-01,3.695600e-01,3.094100e-01,2.458400e-01, & - &2.090000e-01,5.649500e-01,3.613600e-01,5.406800e-01,4.732800e-01, & - &4.175000e-01,3.638000e-01,3.086900e-01,2.678200e-01,2.884500e-01, & - &5.406800e-01,4.868400e-01,5.170600e-01,4.525900e-01,4.084800e-01, & - &3.607500e-01,3.165800e-01,3.432300e-01,3.802500e-01,5.170600e-01, & - &6.534600e-01,4.940400e-01,4.383100e-01,4.009100e-01,3.560400e-01, & - &3.727400e-01,4.356300e-01,4.865700e-01,4.940400e-01,8.544300e-01, & - &6.146000e-01,5.379200e-01,4.611900e-01,3.844600e-01,3.158000e-01, & - &2.524500e-01,1.806900e-01,6.146000e-01,2.447600e-01,5.890200e-01, & - &5.155000e-01,4.420100e-01,3.820100e-01,3.198100e-01,2.524600e-01, & - &1.929000e-01,5.890200e-01,3.238400e-01,5.635900e-01,4.932500e-01, & - &4.334000e-01,3.771700e-01,3.192400e-01,2.608500e-01,2.606000e-01, & - &5.635900e-01,4.295300e-01,5.385800e-01,4.713900e-01,4.243300e-01, & - &3.739200e-01,3.204300e-01,3.100600e-01,3.486700e-01,5.385800e-01, & - &5.677300e-01,5.149000e-01,4.569600e-01,4.159200e-01,3.699100e-01, & - &3.482200e-01,4.012200e-01,4.511800e-01,5.149000e-01,7.438700e-01, & - &6.414500e-01,5.613400e-01,4.812300e-01,4.011900e-01,3.233200e-01, & - &2.577800e-01,1.849400e-01,6.414500e-01,2.163000e-01,6.141900e-01, & - &5.375000e-01,4.607900e-01,3.924100e-01,3.292200e-01,2.590600e-01, & - &1.889200e-01,6.141900e-01,2.920800e-01,5.881300e-01,5.146800e-01, & - &4.479900e-01,3.900400e-01,3.267100e-01,2.651000e-01,2.268500e-01, & - &5.881300e-01,3.913700e-01,5.627300e-01,4.924800e-01,4.405900e-01, & - &3.855600e-01,3.306000e-01,2.862500e-01,3.076000e-01,5.627300e-01, & - &5.058900e-01,5.380400e-01,4.758800e-01,4.306700e-01,3.836900e-01, & - &3.339500e-01,3.592100e-01,4.049500e-01,5.380400e-01,6.523700e-01, & - &6.675900e-01,5.842000e-01,5.008200e-01,4.174500e-01,3.341700e-01, & - &2.610100e-01,1.876900e-01,6.675900e-01,1.937100e-01,6.399300e-01, & - &5.599800e-01,4.800900e-01,4.034200e-01,3.376200e-01,2.649300e-01, & - &1.897300e-01,6.399300e-01,2.640900e-01,6.133200e-01,5.366700e-01, & - &4.631400e-01,4.026600e-01,3.339700e-01,2.694100e-01,2.081900e-01, & - &6.133200e-01,3.592800e-01,5.874300e-01,5.140600e-01,4.564400e-01, & - &3.963700e-01,3.394700e-01,2.762000e-01,2.643200e-01,5.874300e-01, & - &4.755400e-01,5.621200e-01,4.952600e-01,4.457400e-01,3.961700e-01, & - &3.357200e-01,3.140700e-01,3.582800e-01,5.621200e-01,6.083700e-01, & - &6.947300e-01,6.079300e-01,5.211900e-01,4.344000e-01,3.476400e-01, & - &2.633600e-01,1.889600e-01,6.947300e-01,1.725000e-01,6.672100e-01, & - &5.838200e-01,5.005300e-01,4.171900e-01,3.456100e-01,2.712100e-01, & - &1.917700e-01,6.672100e-01,2.404400e-01,6.400000e-01,5.600400e-01, & - &4.802400e-01,4.155400e-01,3.440200e-01,2.720600e-01,2.020200e-01, & - &6.400000e-01,3.309900e-01,6.139400e-01,5.372700e-01,4.742300e-01, & - &4.081100e-01,3.465600e-01,2.798400e-01,2.294400e-01,6.139400e-01, & - &4.421400e-01,5.908400e-01,5.187900e-01,4.625200e-01,4.075800e-01, & - &3.460200e-01,2.875100e-01,3.043200e-01,5.908400e-01,5.778700e-01/ - data absa(271:585,13) / & - &7.224900e-01,6.322500e-01,5.419200e-01,4.516600e-01,3.614100e-01, & - &2.711500e-01,1.892600e-01,7.224900e-01,1.484000e-01,6.956900e-01, & - &6.087600e-01,5.218300e-01,4.349300e-01,3.525300e-01,2.770000e-01, & - &1.946300e-01,6.956900e-01,2.136600e-01,6.703000e-01,5.865600e-01, & - &5.028200e-01,4.305400e-01,3.547200e-01,2.758200e-01,2.055800e-01, & - &6.703000e-01,3.016900e-01,6.475000e-01,5.665900e-01,4.955500e-01, & - &4.229700e-01,3.538200e-01,2.857100e-01,2.167300e-01,6.475000e-01, & - &4.128100e-01,6.251200e-01,5.476000e-01,4.837400e-01,4.211600e-01, & - &3.561900e-01,2.846800e-01,2.646600e-01,6.251200e-01,5.471400e-01, & - &7.529400e-01,6.588700e-01,5.647400e-01,4.706400e-01,3.765400e-01, & - &2.824800e-01,1.897400e-01,7.529400e-01,1.227400e-01,7.289100e-01, & - &6.378100e-01,5.467100e-01,4.556300e-01,3.649800e-01,2.834200e-01, & - &1.984400e-01,7.289100e-01,1.831000e-01,7.055700e-01,6.174400e-01, & - &5.292800e-01,4.466600e-01,3.671600e-01,2.835100e-01,2.087900e-01, & - &7.055700e-01,2.661400e-01,6.824400e-01,5.971900e-01,5.186700e-01, & - &4.421000e-01,3.638300e-01,2.922300e-01,2.187700e-01,6.824400e-01, & - &3.763500e-01,6.608900e-01,5.783300e-01,5.094400e-01,4.400500e-01, & - &3.685700e-01,2.967600e-01,2.416000e-01,6.608900e-01,5.093000e-01, & - &7.858200e-01,6.876200e-01,5.893400e-01,4.912300e-01,3.929800e-01, & - &2.948700e-01,1.966800e-01,7.858200e-01,9.881600e-02,7.634000e-01, & - &6.679800e-01,5.726000e-01,4.771800e-01,3.818600e-01,2.892200e-01, & - &2.039100e-01,7.634000e-01,1.525700e-01,7.408300e-01,6.482500e-01, & - &5.556100e-01,4.645900e-01,3.818000e-01,2.945600e-01,2.130500e-01, & - &7.408300e-01,2.277100e-01,7.207100e-01,6.306500e-01,5.441400e-01, & - &4.645900e-01,3.795600e-01,3.022600e-01,2.246000e-01,7.207100e-01, & - &3.306000e-01,7.010100e-01,6.134000e-01,5.384800e-01,4.599600e-01, & - &3.851600e-01,3.103000e-01,2.329200e-01,7.010100e-01,4.591600e-01, & - &8.169900e-01,7.149000e-01,6.127900e-01,5.107000e-01,4.086200e-01, & - &3.065100e-01,2.044700e-01,8.169900e-01,2.022300e-01,7.968000e-01, & - &6.972500e-01,5.976800e-01,4.980800e-01,3.985700e-01,2.995400e-01, & - &2.111600e-01,7.968000e-01,2.151200e-01,7.776900e-01,6.805400e-01, & - &5.833200e-01,4.864600e-01,3.973500e-01,3.063800e-01,2.218200e-01, & - &7.776900e-01,2.397300e-01,7.576000e-01,6.629400e-01,5.699300e-01, & - &4.857100e-01,3.961700e-01,3.148200e-01,2.329400e-01,7.576000e-01, & - &3.028500e-01,7.361800e-01,6.441400e-01,5.644200e-01,4.805200e-01, & - &4.037800e-01,3.254500e-01,2.366600e-01,7.361800e-01,4.160100e-01, & - &8.394200e-01,7.345000e-01,6.296300e-01,5.247100e-01,4.198700e-01, & - &3.149900e-01,2.117300e-01,8.394200e-01,5.170400e-01,8.205100e-01, & - &7.179800e-01,6.154400e-01,5.128900e-01,4.104100e-01,3.118000e-01, & - &2.247700e-01,8.205100e-01,5.071500e-01,8.010400e-01,7.009900e-01, & - &6.008900e-01,5.036200e-01,4.122200e-01,3.219800e-01,2.337700e-01, & - &8.010400e-01,5.060200e-01,7.789700e-01,6.816800e-01,5.903000e-01, & - &5.019000e-01,4.131600e-01,3.348400e-01,2.452100e-01,7.789700e-01, & - &5.271900e-01,7.565700e-01,6.629400e-01,5.816800e-01,4.994000e-01, & - &4.239700e-01,3.422900e-01,2.542200e-01,7.565700e-01,5.689300e-01, & - &8.608400e-01,7.533200e-01,6.456900e-01,5.381100e-01,4.305400e-01, & - &3.230200e-01,2.208900e-01,8.608400e-01,8.591500e-01,8.438300e-01, & - &7.384900e-01,6.329600e-01,5.275700e-01,4.227200e-01,3.265200e-01, & - &2.366200e-01,8.438300e-01,8.425800e-01,8.246100e-01,7.216200e-01, & - &6.186100e-01,5.217300e-01,4.260900e-01,3.365100e-01,2.460200e-01, & - &8.246100e-01,8.242400e-01,8.036200e-01,7.033000e-01,6.107600e-01, & - &5.164200e-01,4.319600e-01,3.502400e-01,2.578800e-01,8.036200e-01, & - &8.152600e-01,7.819600e-01,6.868600e-01,5.999300e-01,5.191500e-01, & - &4.421900e-01,3.585700e-01,2.831800e-01,7.819600e-01,8.441700e-01, & - &8.988500e-01,7.865200e-01,6.741700e-01,5.619000e-01,4.495700e-01, & - &3.373600e-01,2.346800e-01,8.988500e-01,1.174700e+00,8.817600e-01, & - &7.715700e-01,6.613800e-01,5.512600e-01,4.433400e-01,3.450300e-01, & - &2.459100e-01,8.817600e-01,1.147400e+00,8.644500e-01,7.564400e-01, & - &6.487100e-01,5.479700e-01,4.479800e-01,3.526000e-01,2.572900e-01, & - &8.644500e-01,1.116700e+00,8.453100e-01,7.396800e-01,6.422800e-01, & - &5.428800e-01,4.570300e-01,3.658800e-01,2.754600e-01,8.453100e-01, & - &1.093700e+00,8.263600e-01,7.279100e-01,6.342700e-01,5.503500e-01, & - &4.645600e-01,3.821000e-01,3.191400e-01,8.263600e-01,1.109100e+00/ - data absa(1:270,14) / & - &6.540048e-01,5.721184e-01,4.909770e-01,4.092275e-01,3.287697e-01, & - &2.834457e-01,2.768631e-01,6.540048e-01,6.917000e-01,6.225228e-01, & - &5.448837e-01,4.670632e-01,3.937976e-01,3.647266e-01,3.700110e-01, & - &3.825037e-01,6.225258e-01,9.617109e-01,5.910416e-01,5.173734e-01, & - &4.441758e-01,4.251202e-01,4.517172e-01,4.929889e-01,5.091599e-01, & - &5.910416e-01,1.288786e+00,5.618904e-01,4.919098e-01,4.543647e-01, & - &4.990555e-01,5.863570e-01,6.385998e-01,6.571716e-01,5.618904e-01, & - &1.673439e+00,5.334442e-01,4.667144e-01,4.947492e-01,6.254746e-01, & - &7.413285e-01,8.077296e-01,8.252665e-01,5.334442e-01,2.113550e+00, & - &6.917379e-01,6.054397e-01,5.189079e-01,4.326927e-01,3.477826e-01, & - &2.930179e-01,2.754446e-01,6.917379e-01,6.771960e-01,6.574324e-01, & - &5.755112e-01,4.935647e-01,4.166931e-01,3.796262e-01,3.719302e-01, & - &3.863220e-01,6.574324e-01,9.567876e-01,6.235204e-01,5.457951e-01, & - &4.696484e-01,4.457737e-01,4.598828e-01,5.029414e-01,5.207404e-01, & - &6.235204e-01,1.298623e+00,5.910956e-01,5.174455e-01,4.796638e-01, & - &5.160319e-01,6.007256e-01,6.609803e-01,6.834523e-01,5.910956e-01, & - &1.704645e+00,5.604536e-01,4.907155e-01,5.201678e-01,6.429336e-01, & - &7.673643e-01,8.448583e-01,8.712294e-01,5.604536e-01,2.175750e+00, & - &7.369944e-01,6.450647e-01,5.531998e-01,4.612413e-01,3.690844e-01, & - &2.949797e-01,2.538666e-01,7.369944e-01,6.058555e-01,6.994851e-01, & - &6.123214e-01,5.250914e-01,4.392117e-01,3.846789e-01,3.564157e-01, & - &3.590764e-01,6.994851e-01,8.739995e-01,6.627792e-01,5.802378e-01, & - &4.979238e-01,4.573672e-01,4.484818e-01,4.773742e-01,4.981358e-01, & - &6.627792e-01,1.212193e+00,6.269838e-01,5.489387e-01,5.005342e-01, & - &5.136520e-01,5.770987e-01,6.398689e-01,6.672202e-01,6.269838e-01, & - &1.624511e+00,5.937681e-01,5.198900e-01,5.328662e-01,6.270860e-01, & - &7.498427e-01,8.318372e-01,8.668075e-01,5.937681e-01,2.117002e+00, & - &7.874876e-01,6.892231e-01,5.910774e-01,4.928415e-01,3.945543e-01, & - &3.014522e-01,2.374915e-01,7.874876e-01,5.316682e-01,7.445545e-01, & - &6.517366e-01,5.588864e-01,4.660417e-01,3.915294e-01,3.428092e-01, & - &3.216914e-01,7.445545e-01,7.712061e-01,7.051035e-01,6.172532e-01, & - &5.293906e-01,4.696830e-01,4.392999e-01,4.379810e-01,4.599617e-01, & - &7.051035e-01,1.084564e+00,6.666800e-01,5.836909e-01,5.220767e-01, & - &5.117595e-01,5.424100e-01,6.000580e-01,6.304639e-01,6.666800e-01, & - &1.491172e+00,6.297727e-01,5.514154e-01,5.440122e-01,6.055712e-01, & - &7.149495e-01,7.955763e-01,8.356975e-01,6.297727e-01,1.985771e+00, & - &8.389008e-01,7.342317e-01,6.295705e-01,5.248657e-01,4.198934e-01, & - &3.152988e-01,2.297655e-01,8.389008e-01,4.649666e-01,7.919492e-01, & - &6.931681e-01,5.944361e-01,4.955885e-01,4.044424e-01,3.366989e-01, & - &2.916224e-01,7.919492e-01,6.819191e-01,7.484108e-01,6.550879e-01, & - &5.618141e-01,4.853591e-01,4.362375e-01,4.080612e-01,4.169923e-01, & - &7.484108e-01,9.680042e-01,7.072390e-01,6.192045e-01,5.453315e-01, & - &5.148074e-01,5.156584e-01,5.573831e-01,5.866924e-01,7.072390e-01, & - &1.343781e+00,6.676896e-01,5.845528e-01,5.584240e-01,5.900508e-01, & - &6.723970e-01,7.540521e-01,7.941555e-01,6.676896e-01,1.822082e+00, & - &8.928025e-01,7.814019e-01,6.699703e-01,5.584803e-01,4.470398e-01, & - &3.354756e-01,2.290996e-01,8.928025e-01,3.986669e-01,8.425891e-01, & - &7.374772e-01,6.323162e-01,5.272323e-01,4.227344e-01,3.360745e-01, & - &2.703222e-01,8.425891e-01,5.911469e-01,7.940807e-01,6.951335e-01, & - &5.961136e-01,5.041561e-01,4.368585e-01,3.866139e-01,3.689249e-01, & - &7.940807e-01,8.509411e-01,7.502852e-01,6.567774e-01,5.703687e-01, & - &5.213209e-01,4.950003e-01,5.044010e-01,5.336954e-01,7.502852e-01, & - &1.196598e+00,7.080648e-01,6.198726e-01,5.753074e-01,5.776855e-01, & - &6.232156e-01,6.966525e-01,7.398339e-01,7.080648e-01,1.639205e+00/ - data absa(271:585,14) / & - &9.476042e-01,8.292823e-01,7.109426e-01,5.926445e-01,4.742929e-01, & - &3.559982e-01,2.371706e-01,9.476042e-01,3.435473e-01,8.938949e-01, & - &7.823405e-01,6.708230e-01,5.592054e-01,4.476774e-01,3.426293e-01, & - &2.579922e-01,8.938949e-01,5.135880e-01,8.423353e-01,7.372488e-01, & - &6.321821e-01,5.285321e-01,4.445795e-01,3.753586e-01,3.263676e-01, & - &8.423353e-01,7.470983e-01,7.939792e-01,6.949704e-01,5.990389e-01, & - &5.329770e-01,4.835371e-01,4.612865e-01,4.772714e-01,7.939792e-01, & - &1.061737e+00,7.503806e-01,6.568944e-01,5.957661e-01,5.720993e-01, & - &5.847729e-01,6.314818e-01,6.780830e-01,7.503806e-01,1.472612e+00, & - &1.002786e+00,8.776228e-01,7.524148e-01,6.271870e-01,5.019116e-01, & - &3.767165e-01,2.513162e-01,1.002786e+00,2.989113e-01,9.460810e-01, & - &8.279787e-01,7.099196e-01,5.917951e-01,4.736525e-01,3.562676e-01, & - &2.540449e-01,9.460810e-01,4.505759e-01,8.933464e-01,7.818918e-01, & - &6.704301e-01,5.589569e-01,4.585582e-01,3.725011e-01,3.008276e-01, & - &8.933464e-01,6.630111e-01,8.438035e-01,7.385452e-01,6.335496e-01, & - &5.505549e-01,4.829211e-01,4.328966e-01,4.234085e-01,8.438035e-01, & - &9.496084e-01,7.987214e-01,6.991503e-01,6.217417e-01,5.751832e-01, & - &5.586804e-01,5.721346e-01,6.124358e-01,7.987214e-01,1.331840e+00, & - &1.063254e+00,9.305180e-01,7.976962e-01,6.649210e-01,5.320401e-01, & - &3.992552e-01,2.663782e-01,1.063254e+00,2.598541e-01,1.005687e+00, & - &8.801488e-01,7.546166e-01,6.290167e-01,5.033855e-01,3.777314e-01, & - &2.573538e-01,1.005687e+00,3.962885e-01,9.515613e-01,8.328559e-01, & - &7.140477e-01,5.952569e-01,4.794976e-01,3.769751e-01,2.880725e-01, & - &9.515613e-01,5.901570e-01,9.013619e-01,7.889990e-01,6.765511e-01, & - &5.756904e-01,4.910213e-01,4.176570e-01,3.810977e-01,9.013619e-01, & - &8.547969e-01,8.563212e-01,7.495386e-01,6.564465e-01,5.902062e-01, & - &5.447891e-01,5.282731e-01,5.515317e-01,8.563212e-01,1.209756e+00, & - &1.127087e+00,9.863424e-01,8.455573e-01,7.047145e-01,5.639471e-01, & - &4.230722e-01,2.822065e-01,1.127087e+00,3.010595e-01,1.067881e+00, & - &9.345231e-01,8.011838e-01,6.677510e-01,5.344274e-01,4.010490e-01, & - &2.682177e-01,1.067881e+00,3.818287e-01,1.015335e+00,8.886499e-01, & - &7.618427e-01,6.350663e-01,5.083914e-01,3.918389e-01,2.880580e-01, & - &1.015335e+00,5.478168e-01,9.689668e-01,8.480575e-01,7.271125e-01, & - &6.123098e-01,5.120024e-01,4.213431e-01,3.616893e-01,9.689668e-01, & - &7.981656e-01,9.288097e-01,8.129776e-01,7.054108e-01,6.215338e-01, & - &5.527309e-01,5.122191e-01,5.139692e-01,9.288097e-01,1.137513e+00, & - &1.173352e+00,1.026727e+00,8.801147e-01,7.335477e-01,5.868955e-01, & - &4.403682e-01,2.938087e-01,1.173352e+00,6.591916e-01,1.121399e+00, & - &9.814805e-01,8.413203e-01,7.012480e-01,5.610973e-01,4.208493e-01, & - &2.847119e-01,1.121399e+00,6.885412e-01,1.075903e+00,9.416041e-01, & - &8.072338e-01,6.728282e-01,5.414481e-01,4.208088e-01,3.168922e-01, & - &1.075903e+00,7.718862e-01,1.038082e+00,9.085345e-01,7.789626e-01, & - &6.614202e-01,5.555907e-01,4.614604e-01,4.052378e-01,1.038082e+00, & - &9.511091e-01,1.006534e+00,8.808681e-01,7.704271e-01,6.813436e-01, & - &6.116924e-01,5.704511e-01,5.657784e-01,1.006534e+00,1.273090e+00, & - &1.242372e+00,1.087158e+00,9.319829e-01,7.767339e-01,6.215223e-01, & - &4.662369e-01,3.108293e-01,1.242372e+00,1.120651e+00,1.199225e+00, & - &1.049449e+00,8.996235e-01,7.497535e-01,6.000026e-01,4.501338e-01, & - &3.106964e-01,1.199225e+00,1.110297e+00,1.163827e+00,1.018477e+00, & - &8.731078e-01,7.277235e-01,5.900510e-01,4.613684e-01,3.545513e-01, & - &1.163827e+00,1.155700e+00,1.134953e+00,9.931890e-01,8.530508e-01, & - &7.289525e-01,6.137648e-01,5.181038e-01,4.552266e-01,1.134953e+00, & - &1.284166e+00,1.112419e+00,9.735395e-01,8.565917e-01,7.595087e-01, & - &6.851682e-01,6.385202e-01,6.227467e-01,1.112419e+00,1.531588e+00, & - &1.338130e+00,1.170962e+00,1.003767e+00,8.365734e-01,6.692854e-01, & - &5.021732e-01,3.349118e-01,1.338130e+00,1.570955e+00,1.305214e+00, & - &1.142175e+00,9.790406e-01,8.160265e-01,6.529050e-01,4.920150e-01, & - &3.474598e-01,1.305214e+00,1.536160e+00,1.279404e+00,1.119497e+00, & - &9.596735e-01,8.019266e-01,6.538864e-01,5.161908e-01,4.005427e-01, & - &1.279404e+00,1.557463e+00,1.259091e+00,1.101810e+00,9.497449e-01, & - &8.136011e-01,6.868908e-01,5.856661e-01,5.113727e-01,1.259091e+00, & - &1.660014e+00,1.241171e+00,1.086423e+00,9.597698e-01,8.537390e-01, & - &7.728492e-01,7.148460e-01,6.856565e-01,1.241171e+00,1.870186e+00/ - -! the array absb(1410,NG04) = kb(6,5,13:59,NG04) contains absorption -! coefs for each of the NG04=14 g-intervals for a range of pressure -! levels < ~100mb, temperatures, and ratios of o3 to co2. the first -! index in the array, js, runs from 1 to 6, and corresponds to -! different o3 to co2 ratios, as expressed through the binary species -! parameter eta, defined as eta = o3/(o3+rat*h2o), where rat is the -! ratio of the integrated line strength in the band of co2 to that of -! o3. for instance, js=1 refers to no o3 (eta = 0) and js = 5 -! corresponds to eta = 1.0. the second index, jt, which runs from 1 -! to 5, corresponds to different temperatures. more specifically, -! jt = 1-5 means that the data are for the corresponding temperature of -! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the -! third index, jp, runs from 13 to 59 and refers to the corresponding -! pressure level in pref (e.g. jp = 13 is for a pressure of 95.5835 mb). -! the fourth index, ig, goes from 1 to NG04=14, and tells us which -! g-interval the absorption coefficients are for. - - data absb(1:360,1) / & - &1.059000e-03,1.170800e-03,6.180400e-03,8.385100e-03,9.840100e-03, & - &1.065000e-02,1.273700e-03,1.392100e-03,6.783700e-03,9.180200e-03, & - &1.072400e-02,1.169400e-02,1.492800e-03,1.616700e-03,7.303700e-03, & - &9.809700e-03,1.141300e-02,1.255900e-02,1.710100e-03,1.838000e-03, & - &7.736100e-03,1.030500e-02,1.193200e-02,1.325200e-02,1.926800e-03, & - &2.057400e-03,8.104000e-03,1.070900e-02,1.232100e-02,1.378700e-02, & - &8.985300e-04,1.005300e-03,5.261200e-03,7.125700e-03,8.317000e-03, & - &8.627700e-03,1.078500e-03,1.191400e-03,5.751300e-03,7.756400e-03, & - &9.011800e-03,9.381900e-03,1.259100e-03,1.378200e-03,6.171500e-03, & - &8.247800e-03,9.548400e-03,9.999600e-03,1.439700e-03,1.562700e-03, & - &6.519300e-03,8.648700e-03,9.962000e-03,1.048500e-02,1.620100e-03, & - &1.745900e-03,6.816500e-03,8.982700e-03,1.027300e-02,1.085500e-02, & - &7.624800e-04,8.627900e-04,4.455700e-03,6.020700e-03,6.989600e-03, & - &7.023600e-03,9.111700e-04,1.018000e-03,4.856100e-03,6.512700e-03, & - &7.536900e-03,7.584600e-03,1.059600e-03,1.172300e-03,5.189800e-03, & - &6.908900e-03,7.964300e-03,8.032500e-03,1.209400e-03,1.326300e-03, & - &5.473400e-03,7.238000e-03,8.295700e-03,8.372300e-03,1.360300e-03, & - &1.480200e-03,5.708500e-03,7.510400e-03,8.549700e-03,8.617800e-03, & - &6.455800e-04,7.380400e-04,3.759600e-03,5.058900e-03,5.848500e-03, & - &5.770500e-03,7.674800e-04,8.661200e-04,4.079600e-03,5.449600e-03, & - &6.285800e-03,6.201000e-03,8.902900e-04,9.946600e-04,4.352300e-03, & - &5.773500e-03,6.628600e-03,6.537500e-03,1.015400e-03,1.124200e-03, & - &4.576700e-03,6.043000e-03,6.898100e-03,6.785500e-03,1.141200e-03, & - &1.253200e-03,4.767300e-03,6.261000e-03,7.108300e-03,6.958500e-03, & - &5.446100e-04,6.279200e-04,3.157500e-03,4.232900e-03,4.877300e-03, & - &4.743300e-03,6.449800e-04,7.339500e-04,3.417800e-03,4.550000e-03, & - &5.229100e-03,5.077800e-03,7.467700e-04,8.413700e-04,3.636800e-03, & - &4.815300e-03,5.508000e-03,5.332800e-03,8.511700e-04,9.501600e-04, & - &3.817600e-03,5.033700e-03,5.727900e-03,5.517300e-03,9.567000e-04, & - &1.059100e-03,3.973600e-03,5.205700e-03,5.900100e-03,5.641100e-03, & - &4.583100e-04,5.320700e-04,2.645300e-03,3.535000e-03,4.059500e-03, & - &3.902500e-03,5.414800e-04,6.204800e-04,2.856400e-03,3.792000e-03, & - &4.343000e-03,4.163800e-03,6.262000e-04,7.104600e-04,3.031600e-03, & - &4.009300e-03,4.570500e-03,4.359400e-03,7.129600e-04,8.014000e-04, & - &3.178500e-03,4.182200e-03,4.750000e-03,4.499300e-03,8.011700e-04, & - &8.928300e-04,3.307300e-03,4.321500e-03,4.888800e-03,4.589100e-03, & - &3.849400e-04,4.495700e-04,2.213000e-03,2.947000e-03,3.373400e-03, & - &3.205200e-03,4.539200e-04,5.232600e-04,2.382200e-03,3.156700e-03, & - &3.603700e-03,3.408700e-03,5.244200e-04,5.986000e-04,2.523100e-03, & - &3.330700e-03,3.789400e-03,3.558400e-03,5.966800e-04,6.746200e-04, & - &2.642300e-03,3.470200e-03,3.934300e-03,3.663800e-03,6.704700e-04, & - &7.513300e-04,2.747900e-03,3.583300e-03,4.043900e-03,3.728600e-03, & - &3.239100e-04,3.800200e-04,1.850500e-03,2.457500e-03,2.804500e-03, & - &2.640000e-03,3.811100e-04,4.415000e-04,1.985500e-03,2.626800e-03, & - &2.991300e-03,2.798000e-03,4.398500e-04,5.043800e-04,2.098000e-03, & - &2.765700e-03,3.141200e-03,2.914000e-03,5.001200e-04,5.679600e-04, & - &2.195200e-03,2.878300e-03,3.255700e-03,2.993700e-03,5.615100e-04, & - &6.316900e-04,2.283400e-03,2.970000e-03,3.342700e-03,3.041000e-03, & - &2.724000e-04,3.207100e-04,1.544200e-03,2.048100e-03,2.331000e-03, & - &2.174800e-03,3.199200e-04,3.720000e-04,1.651900e-03,2.183100e-03, & - &2.482200e-03,2.298400e-03,3.688300e-04,4.243200e-04,1.743000e-03, & - &2.294500e-03,2.600400e-03,2.388000e-03,4.189000e-04,4.773600e-04, & - &1.823000e-03,2.384900e-03,2.691600e-03,2.448300e-03,4.701800e-04, & - &5.302000e-04,1.896300e-03,2.460100e-03,2.762000e-03,2.483400e-03, & - &2.315300e-04,2.730300e-04,1.291500e-03,1.712000e-03,1.945600e-03, & - &1.798900e-03,2.710300e-04,3.157800e-04,1.377300e-03,1.818700e-03, & - &2.064300e-03,1.894000e-03,3.118700e-04,3.594700e-04,1.451200e-03, & - &1.906800e-03,2.156600e-03,1.961500e-03,3.535000e-04,4.034500e-04, & - &1.517200e-03,1.979400e-03,2.228800e-03,2.005900e-03,3.961900e-04, & - &4.471300e-04,1.577100e-03,2.041500e-03,2.284300e-03,2.031000e-03, & - &1.968000e-04,2.322400e-04,1.078500e-03,1.428800e-03,1.622300e-03, & - &1.487100e-03,2.297000e-04,2.679100e-04,1.147400e-03,1.513800e-03, & - &1.715300e-03,1.560000e-03,2.635600e-04,3.041100e-04,1.207500e-03, & - &1.583900e-03,1.787500e-03,1.611100e-03,2.982300e-04,3.404900e-04, & - &1.261500e-03,1.642800e-03,1.844400e-03,1.643600e-03,3.336600e-04, & - &3.765500e-04,1.310600e-03,1.693600e-03,1.888500e-03,1.660600e-03, & - &1.673200e-04,1.974900e-04,9.002400e-04,1.191200e-03,1.351500e-03, & - &1.228400e-03,1.947000e-04,2.271200e-04,9.555800e-04,1.258700e-03, & - &1.423900e-03,1.283800e-03,2.228100e-04,2.570700e-04,1.004800e-03, & - &1.315300e-03,1.480800e-03,1.322100e-03,2.516900e-04,2.870800e-04, & - &1.048400e-03,1.363000e-03,1.526000e-03,1.345300e-03,2.809400e-04, & - &3.167400e-04,1.088600e-03,1.404600e-03,1.561400e-03,1.356100e-03/ - data absb(361:720,1) / & - &1.423600e-04,1.679400e-04,7.512500e-04,9.928900e-04,1.125400e-03, & - &1.014800e-03,1.651200e-04,1.924600e-04,7.959800e-04,1.046500e-03, & - &1.181900e-03,1.056700e-03,1.884500e-04,2.172200e-04,8.359800e-04, & - &1.092500e-03,1.226900e-03,1.085100e-03,2.125500e-04,2.419800e-04, & - &8.713700e-04,1.131200e-03,1.263200e-03,1.101200e-03,2.364200e-04, & - &2.660900e-04,9.037300e-04,1.164100e-03,1.290400e-03,1.107500e-03, & - &1.213500e-04,1.429600e-04,6.270500e-04,8.275200e-04,9.367000e-04, & - &8.388800e-04,1.402500e-04,1.632000e-04,6.633500e-04,8.708600e-04, & - &9.812400e-04,8.702400e-04,1.596800e-04,1.836700e-04,6.955400e-04, & - &9.076200e-04,1.017100e-03,8.908500e-04,1.796800e-04,2.041100e-04, & - &7.242300e-04,9.389900e-04,1.046000e-03,9.017100e-04,1.991100e-04, & - &2.235500e-04,7.504100e-04,9.646000e-04,1.066800e-03,9.048800e-04, & - &1.034100e-04,1.215300e-04,5.231000e-04,6.896000e-04,7.791900e-04, & - &6.937000e-04,1.191000e-04,1.382800e-04,5.524200e-04,7.242000e-04, & - &8.141200e-04,7.171100e-04,1.352900e-04,1.552000e-04,5.782000e-04, & - &7.537300e-04,8.428500e-04,7.317500e-04,1.517300e-04,1.719300e-04, & - &6.015400e-04,7.786700e-04,8.656300e-04,7.389000e-04,1.675300e-04, & - &1.876500e-04,6.228900e-04,7.988300e-04,8.813000e-04,7.399700e-04, & - &8.806100e-05,1.032100e-04,4.362500e-04,5.743700e-04,6.477700e-04, & - &5.734800e-04,1.011000e-04,1.170800e-04,4.598300e-04,6.022700e-04, & - &6.755300e-04,5.909400e-04,1.145500e-04,1.310200e-04,4.804700e-04, & - &6.256700e-04,6.982600e-04,6.012500e-04,1.280100e-04,1.446900e-04, & - &4.995700e-04,6.454400e-04,7.160900e-04,6.058300e-04,1.408600e-04, & - &1.573600e-04,5.169300e-04,6.617000e-04,7.279600e-04,6.057000e-04, & - &7.500300e-05,8.766400e-05,3.637400e-04,4.783400e-04,5.384400e-04, & - &4.748600e-04,8.584700e-05,9.915300e-05,3.826000e-04,5.006600e-04, & - &5.604800e-04,4.878500e-04,9.700400e-05,1.106400e-04,3.992900e-04, & - &5.192600e-04,5.785700e-04,4.950900e-04,1.079800e-04,1.216900e-04, & - &4.147100e-04,5.346900e-04,5.920000e-04,4.979800e-04,1.183900e-04, & - &1.319300e-04,4.288500e-04,5.479000e-04,6.012100e-04,4.971900e-04, & - &6.385600e-05,7.442800e-05,3.030900e-04,3.983100e-04,4.474800e-04, & - &3.933600e-04,7.287000e-05,8.390600e-05,3.181600e-04,4.159700e-04, & - &4.650000e-04,4.029200e-04,8.207900e-05,9.334300e-05,3.316900e-04, & - &4.306600e-04,4.791300e-04,4.080700e-04,9.101500e-05,1.022500e-04, & - &3.443000e-04,4.431400e-04,4.894700e-04,4.097700e-04,9.939500e-05, & - &1.105100e-04,3.557000e-04,4.535700e-04,4.965800e-04,4.087200e-04, & - &5.435700e-05,6.317600e-05,2.524500e-04,3.315700e-04,3.717800e-04, & - &3.264700e-04,6.186100e-05,7.099600e-05,2.644500e-04,3.453800e-04, & - &3.857000e-04,3.335500e-04,6.941600e-05,7.870900e-05,2.755400e-04, & - &3.571200e-04,3.967100e-04,3.372300e-04,7.665600e-05,8.588000e-05, & - &2.857700e-04,3.670900e-04,4.044900e-04,3.382600e-04,8.338800e-05, & - &9.252500e-05,2.950100e-04,3.753000e-04,4.100100e-04,3.372400e-04, & - &4.625900e-05,5.360300e-05,2.101600e-04,2.758400e-04,3.089200e-04, & - &2.710900e-04,5.249800e-05,6.005900e-05,2.198700e-04,2.867600e-04, & - &3.198700e-04,2.763000e-04,5.865600e-05,6.629800e-05,2.289100e-04, & - &2.961100e-04,3.283200e-04,2.789500e-04,6.449800e-05,7.207100e-05, & - &2.371800e-04,3.040400e-04,3.343000e-04,2.795700e-04,6.991600e-05, & - &7.742400e-05,2.447100e-04,3.105800e-04,3.385000e-04,2.785900e-04, & - &3.936100e-05,4.546000e-05,1.749300e-04,2.293200e-04,2.565600e-04, & - &2.252500e-04,4.451200e-05,5.076800e-05,1.828100e-04,2.380000e-04, & - &2.651600e-04,2.291800e-04,4.951400e-05,5.578100e-05,1.901600e-04, & - &2.454900e-04,2.716500e-04,2.311400e-04,5.422200e-05,6.042700e-05, & - &1.968300e-04,2.516800e-04,2.762500e-04,2.315200e-04,5.856800e-05, & - &6.473100e-05,2.029900e-04,2.569700e-04,2.793900e-04,2.305800e-04, & - &3.332300e-05,3.837100e-05,1.453200e-04,1.902600e-04,2.127300e-04, & - &1.868000e-04,3.754200e-05,4.270300e-05,1.517600e-04,1.972500e-04, & - &2.194900e-04,1.898200e-04,4.160300e-05,4.675000e-05,1.577500e-04, & - &2.032200e-04,2.244900e-04,1.912600e-04,4.541000e-05,5.050500e-05, & - &1.632100e-04,2.082200e-04,2.281000e-04,1.914700e-04,4.887200e-05, & - &5.394000e-05,1.682600e-04,2.125400e-04,2.304800e-04,1.906000e-04, & - &2.784800e-05,3.201700e-05,1.201900e-04,1.572300e-04,1.757400e-04, & - &1.546700e-04,3.130500e-05,3.555300e-05,1.254900e-04,1.629400e-04, & - &1.811700e-04,1.571200e-04,3.462100e-05,3.884800e-05,1.303900e-04, & - &1.678000e-04,1.851700e-04,1.583000e-04,3.770400e-05,4.189100e-05, & - &1.349100e-04,1.718800e-04,1.880500e-04,1.584300e-04,4.047600e-05, & - &4.464900e-05,1.390900e-04,1.754900e-04,1.899700e-04,1.577900e-04, & - &2.295600e-05,2.638500e-05,9.892100e-05,1.294000e-04,1.446300e-04, & - &1.277900e-04,2.579300e-05,2.928500e-05,1.033300e-04,1.341500e-04, & - &1.491200e-04,1.298900e-04,2.852000e-05,3.199300e-05,1.074000e-04, & - &1.382100e-04,1.524600e-04,1.309700e-04,3.102800e-05,3.447300e-05, & - &1.111500e-04,1.416000e-04,1.548700e-04,1.311600e-04,3.326800e-05, & - &3.670100e-05,1.146400e-04,1.446600e-04,1.564800e-04,1.307500e-04/ - data absb(721:1080,1) / & - &1.856300e-05,2.137200e-05,8.085700e-05,1.058700e-04,1.183900e-04, & - &1.050900e-04,2.090200e-05,2.377100e-05,8.455000e-05,1.099000e-04, & - &1.222400e-04,1.070400e-04,2.315800e-05,2.601700e-05,8.796800e-05, & - &1.133400e-04,1.251300e-04,1.080600e-04,2.523200e-05,2.806800e-05, & - &9.113900e-05,1.163000e-04,1.272900e-04,1.083900e-04,2.707500e-05, & - &2.989800e-05,9.407100e-05,1.189100e-04,1.287400e-04,1.082200e-04, & - &1.498800e-05,1.728900e-05,6.605500e-05,8.657500e-05,9.685500e-05, & - &8.649300e-05,1.691800e-05,1.927200e-05,6.915000e-05,8.999600e-05, & - &1.001600e-04,8.828000e-05,1.878300e-05,2.113800e-05,7.202600e-05, & - &9.296200e-05,1.027000e-04,8.927500e-05,2.049600e-05,2.283400e-05, & - &7.468900e-05,9.547000e-05,1.045900e-04,8.970100e-05,2.201600e-05, & - &2.433800e-05,7.716200e-05,9.770400e-05,1.059100e-04,8.971800e-05, & - &1.209600e-05,1.398200e-05,5.394900e-05,7.078600e-05,7.923000e-05, & - &7.128700e-05,1.368900e-05,1.562000e-05,5.654600e-05,7.369800e-05, & - &8.206300e-05,7.293600e-05,1.523100e-05,1.716900e-05,5.896600e-05, & - &7.622500e-05,8.427700e-05,7.390700e-05,1.664500e-05,1.857000e-05, & - &6.120400e-05,7.836700e-05,8.594100e-05,7.441800e-05,1.790100e-05, & - &1.981000e-05,6.329000e-05,8.029800e-05,8.713100e-05,7.456100e-05, & - &9.627600e-06,1.116500e-05,4.383100e-05,5.759900e-05,6.450900e-05, & - &5.827300e-05,1.093900e-05,1.251900e-05,4.602400e-05,6.010800e-05, & - &6.699400e-05,5.981000e-05,1.222000e-05,1.381400e-05,4.807300e-05, & - &6.229300e-05,6.898800e-05,6.075900e-05,1.340100e-05,1.498800e-05, & - &4.996800e-05,6.417000e-05,7.049400e-05,6.131300e-05,1.445000e-05, & - &1.602200e-05,5.174200e-05,6.583300e-05,7.159400e-05,6.153900e-05, & - &7.638300e-06,8.890600e-06,3.555500e-05,4.680600e-05,5.245800e-05, & - &4.756800e-05,8.719000e-06,1.001000e-05,3.742200e-05,4.897200e-05, & - &5.463100e-05,4.898100e-05,9.781600e-06,1.109200e-05,3.915000e-05, & - &5.086200e-05,5.641300e-05,4.989900e-05,1.077000e-05,1.207800e-05, & - &4.076500e-05,5.250500e-05,5.778800e-05,5.046100e-05,1.165000e-05, & - &1.294400e-05,4.227100e-05,5.394800e-05,5.880100e-05,5.074800e-05, & - &6.054200e-06,7.072100e-06,2.882000e-05,3.800000e-05,4.262400e-05, & - &3.881900e-05,6.940600e-06,7.995100e-06,3.041200e-05,3.987500e-05, & - &4.452900e-05,4.011800e-05,7.820200e-06,8.896700e-06,3.187000e-05, & - &4.150900e-05,4.610600e-05,4.098600e-05,8.646200e-06,9.723900e-06, & - &3.323600e-05,4.293400e-05,4.733800e-05,4.154900e-05,9.384100e-06, & - &1.045000e-05,3.451100e-05,4.418600e-05,4.827700e-05,4.187600e-05, & - &4.753500e-06,5.576200e-06,2.326700e-05,3.072500e-05,3.450900e-05, & - &3.157100e-05,5.476500e-06,6.335700e-06,2.463100e-05,3.236400e-05, & - &3.618000e-05,3.277600e-05,6.206300e-06,7.087800e-06,2.587000e-05, & - &3.378700e-05,3.758800e-05,3.360300e-05,6.897100e-06,7.784700e-06, & - &2.702500e-05,3.503000e-05,3.871000e-05,3.416600e-05,7.520000e-06, & - &8.399500e-06,2.811100e-05,3.612100e-05,3.958200e-05,3.452300e-05, & - &3.710800e-06,4.373500e-06,1.873500e-05,2.477400e-05,2.785900e-05, & - &2.562400e-05,4.298600e-06,4.997000e-06,1.989600e-05,2.620200e-05, & - &2.932600e-05,2.674000e-05,4.900400e-06,5.620900e-06,2.095300e-05, & - &2.744500e-05,3.058100e-05,2.753300e-05,5.480000e-06,6.209400e-06, & - &2.194200e-05,2.853600e-05,3.160600e-05,2.808100e-05,6.006700e-06, & - &6.732600e-06,2.286100e-05,2.948900e-05,3.240800e-05,2.845200e-05, & - &2.891100e-06,3.422700e-06,1.506400e-05,1.994700e-05,2.245700e-05, & - &2.079100e-05,3.367400e-06,3.933500e-06,1.605700e-05,2.118900e-05, & - &2.374300e-05,2.181300e-05,3.862400e-06,4.449900e-06,1.696200e-05, & - &2.227400e-05,2.485200e-05,2.256600e-05,4.345600e-06,4.944300e-06, & - &1.779400e-05,2.321900e-05,2.577700e-05,2.309800e-05,4.791100e-06, & - &5.389800e-06,1.858100e-05,2.405600e-05,2.650900e-05,2.347000e-05, & - &2.238300e-06,2.663700e-06,1.207300e-05,1.601100e-05,1.804400e-05, & - &1.683100e-05,2.624700e-06,3.081400e-06,1.292100e-05,1.708100e-05, & - &1.917000e-05,1.776000e-05,3.028300e-06,3.506100e-06,1.370100e-05, & - &1.803300e-05,2.015000e-05,1.846900e-05,3.430700e-06,3.921100e-06, & - &1.440800e-05,1.886200e-05,2.098300e-05,1.898500e-05,3.806900e-06, & - &4.300200e-06,1.507600e-05,1.959700e-05,2.165400e-05,1.935300e-05, & - &1.715700e-06,2.053800e-06,9.624600e-06,1.278200e-05,1.441600e-05, & - &1.353900e-05,2.027400e-06,2.393800e-06,1.035500e-05,1.371000e-05, & - &1.541300e-05,1.438800e-05,2.354700e-06,2.742000e-06,1.102700e-05, & - &1.454600e-05,1.627800e-05,1.505100e-05,2.688100e-06,3.088500e-06, & - &1.163200e-05,1.527500e-05,1.702600e-05,1.554700e-05,3.005800e-06, & - &3.410700e-06,1.219700e-05,1.591900e-05,1.764200e-05,1.591200e-05, & - &1.310700e-06,1.578200e-06,7.650800e-06,1.017500e-05,1.148200e-05, & - &1.088300e-05,1.561500e-06,1.854000e-06,8.282500e-06,1.098000e-05, & - &1.236400e-05,1.165300e-05,1.825800e-06,2.138500e-06,8.857900e-06, & - &1.171000e-05,1.312400e-05,1.226900e-05,2.099600e-06,2.425800e-06, & - &9.378400e-06,1.235100e-05,1.379000e-05,1.274300e-05,2.366700e-06, & - &2.698800e-06,9.857400e-06,1.291400e-05,1.435300e-05,1.310100e-05/ - data absb(1081:1410,1) / & - &9.972200e-07,1.208800e-06,6.064000e-06,8.071400e-06,9.114400e-06, & - &8.752900e-06,1.198400e-06,1.431500e-06,6.608900e-06,8.774300e-06, & - &9.891600e-06,9.449200e-06,1.411900e-06,1.663100e-06,7.101100e-06, & - &9.403900e-06,1.056000e-05,1.001600e-05,1.635100e-06,1.899700e-06, & - &7.551300e-06,9.968500e-06,1.114800e-05,1.046500e-05,1.857900e-06, & - &2.129700e-06,7.957700e-06,1.046100e-05,1.165400e-05,1.081700e-05, & - &7.588600e-07,9.272100e-07,4.803800e-06,6.397800e-06,7.223100e-06, & - &7.003300e-06,9.210000e-07,1.106300e-06,5.271400e-06,7.005600e-06, & - &7.904000e-06,7.621600e-06,1.093300e-06,1.294700e-06,5.694500e-06, & - &7.550000e-06,8.492200e-06,8.134600e-06,1.274100e-06,1.488200e-06, & - &6.079700e-06,8.042100e-06,9.006600e-06,8.549000e-06,1.458600e-06, & - &1.680700e-06,6.427400e-06,8.475000e-06,9.457400e-06,8.877900e-06, & - &5.762900e-07,7.102900e-07,3.794300e-06,5.057000e-06,5.710800e-06, & - &5.579100e-06,7.070200e-07,8.539300e-07,4.196600e-06,5.583900e-06, & - &6.305600e-06,6.126200e-06,8.458700e-07,1.007100e-06,4.561000e-06, & - &6.054900e-06,6.818600e-06,6.583200e-06,9.920500e-07,1.165100e-06, & - &4.891400e-06,6.481500e-06,7.268100e-06,6.958200e-06,1.143700e-06, & - &1.324500e-06,5.189900e-06,6.859300e-06,7.667000e-06,7.260400e-06, & - &4.358400e-07,5.422400e-07,2.985500e-06,3.981700e-06,4.497600e-06, & - &4.444200e-06,5.409700e-07,6.576400e-07,3.333400e-06,4.439200e-06, & - &5.015300e-06,4.924600e-06,6.525300e-07,7.812900e-07,3.645600e-06, & - &4.845800e-06,5.462500e-06,5.331400e-06,7.708600e-07,9.100200e-07, & - &3.928700e-06,5.212700e-06,5.854600e-06,5.668800e-06,8.944400e-07, & - &1.041300e-06,4.183700e-06,5.541800e-06,6.203700e-06,5.947500e-06, & - &3.279600e-07,4.121400e-07,2.339400e-06,3.119500e-06,3.526200e-06, & - &3.545500e-06,4.121300e-07,5.049800e-07,2.639900e-06,3.518400e-06, & - &3.974200e-06,3.966200e-06,5.019400e-07,6.044200e-07,2.907300e-06, & - &3.868000e-06,4.364200e-06,4.327300e-06,5.975200e-07,7.091400e-07, & - &3.150500e-06,4.183700e-06,4.705900e-06,4.631300e-06,6.976500e-07, & - &8.165900e-07,3.368400e-06,4.469700e-06,5.010600e-06,4.888200e-06, & - &2.476800e-07,3.141200e-07,1.833300e-06,2.442000e-06,2.764900e-06, & - &2.786200e-06,3.147600e-07,3.887300e-07,2.090200e-06,2.787600e-06, & - &3.150000e-06,3.142600e-06,3.872400e-07,4.687200e-07,2.319200e-06, & - &3.088200e-06,3.487400e-06,3.456400e-06,4.643400e-07,5.538400e-07, & - &2.527600e-06,3.359300e-06,3.783200e-06,3.720600e-06,5.453700e-07, & - &6.415600e-07,2.714100e-06,3.606400e-06,4.046800e-06,3.945300e-06, & - &1.869300e-07,2.392700e-07,1.433600e-06,1.907400e-06,2.163500e-06, & - &2.161900e-06,2.402500e-07,2.991800e-07,1.651900e-06,2.204800e-06, & - &2.492600e-06,2.460400e-06,2.987200e-07,3.636000e-07,1.848800e-06, & - &2.463300e-06,2.783200e-06,2.728200e-06,3.607500e-07,4.325100e-07, & - &2.026500e-06,2.695400e-06,3.039100e-06,2.955100e-06,4.264800e-07, & - &5.040400e-07,2.185500e-06,2.907000e-06,3.266300e-06,3.145800e-06, & - &1.405400e-07,1.817600e-07,1.116100e-06,1.483400e-06,1.685800e-06, & - &1.670600e-06,1.827200e-07,2.296200e-07,1.301400e-06,1.737700e-06, & - &1.965600e-06,1.921500e-06,2.296800e-07,2.814400e-07,1.470200e-06, & - &1.960200e-06,2.214900e-06,2.147800e-06,2.797300e-07,3.370900e-07, & - &1.621900e-06,2.158600e-06,2.435800e-06,2.342800e-06,3.329200e-07, & - &3.953500e-07,1.757800e-06,2.339800e-06,2.632100e-06,2.505800e-06, & - &1.051000e-07,1.375000e-07,8.640500e-07,1.147300e-06,1.307600e-06, & - &1.285000e-06,1.384900e-07,1.756000e-07,1.022200e-06,1.363800e-06, & - &1.544600e-06,1.496100e-06,1.759900e-07,2.172700e-07,1.165900e-06, & - &1.555600e-06,1.758300e-06,1.685900e-06,2.164200e-07,2.621600e-07, & - &1.295400e-06,1.725200e-06,1.948300e-06,1.852800e-06,2.593700e-07, & - &3.095400e-07,1.412000e-06,1.880200e-06,2.117700e-06,1.993100e-06, & - &7.856200e-08,1.041200e-07,6.669700e-07,8.854700e-07,1.012200e-06, & - &9.835900e-07,1.050500e-07,1.343500e-07,8.018600e-07,1.068800e-06, & - &1.212300e-06,1.160200e-06,1.349100e-07,1.678100e-07,9.234300e-07, & - &1.233000e-06,1.394700e-06,1.318900e-06,1.675500e-07,2.039800e-07, & - &1.034100e-06,1.378100e-06,1.557600e-06,1.460000e-06,2.021900e-07, & - &2.424500e-07,1.133700e-06,1.510400e-06,1.702900e-06,1.579700e-06, & - &6.203200e-08,8.266700e-08,5.335800e-07,7.086000e-07,8.106100e-07, & - &7.599200e-07,8.346400e-08,1.071400e-07,6.459600e-07,8.609200e-07, & - &9.771400e-07,9.033000e-07,1.077200e-07,1.344500e-07,7.472700e-07, & - &9.982200e-07,1.129300e-06,1.031000e-06,1.343400e-07,1.639400e-07, & - &8.400000e-07,1.119700e-06,1.265800e-06,1.143100e-06,1.626000e-07, & - &1.954000e-07,9.232800e-07,1.230700e-06,1.388100e-06,1.238800e-06/ - data absb(1:360,2) / & - &3.652300e-03,3.893900e-03,1.927200e-02,2.774000e-02,3.351200e-02, & - &3.362700e-02,4.069800e-03,4.300600e-03,2.014000e-02,2.915900e-02, & - &3.560300e-02,3.637500e-02,4.441200e-03,4.665000e-03,2.090700e-02, & - &3.032900e-02,3.717800e-02,3.873200e-02,4.748300e-03,4.965200e-03, & - &2.159200e-02,3.126600e-02,3.822200e-02,4.051400e-02,4.982900e-03, & - &5.193800e-03,2.216800e-02,3.196900e-02,3.879400e-02,4.174100e-02, & - &3.086500e-03,3.320000e-03,1.653100e-02,2.381700e-02,2.889700e-02, & - &2.814200e-02,3.436200e-03,3.660300e-03,1.725200e-02,2.496600e-02, & - &3.054500e-02,3.021100e-02,3.743100e-03,3.958600e-03,1.789900e-02, & - &2.589100e-02,3.168400e-02,3.182400e-02,3.987200e-03,4.195500e-03, & - &1.845900e-02,2.659400e-02,3.236200e-02,3.290700e-02,4.170300e-03, & - &4.374800e-03,1.891100e-02,2.707400e-02,3.268300e-02,3.359100e-02, & - &2.611500e-03,2.831100e-03,1.408500e-02,2.030400e-02,2.471000e-02, & - &2.351400e-02,2.904100e-03,3.114400e-03,1.468000e-02,2.121000e-02, & - &2.593100e-02,2.499900e-02,3.153000e-03,3.354000e-03,1.521200e-02, & - &2.190400e-02,2.671100e-02,2.606400e-02,3.344600e-03,3.539500e-03, & - &1.564100e-02,2.240900e-02,2.714100e-02,2.675500e-02,3.484900e-03, & - &3.679400e-03,1.599500e-02,2.275000e-02,2.733000e-02,2.715200e-02, & - &2.212900e-03,2.416800e-03,1.192800e-02,1.717900e-02,2.093800e-02, & - &1.961700e-02,2.453600e-03,2.649100e-03,1.240900e-02,1.786600e-02, & - &2.179900e-02,2.068200e-02,2.651400e-03,2.838400e-03,1.282200e-02, & - &1.838000e-02,2.233800e-02,2.142600e-02,2.795100e-03,2.977800e-03, & - &1.315700e-02,1.876900e-02,2.263000e-02,2.190200e-02,2.903600e-03, & - &3.086000e-03,1.343500e-02,1.902700e-02,2.274600e-02,2.214600e-02, & - &1.873500e-03,2.062700e-03,1.003600e-02,1.442400e-02,1.757700e-02, & - &1.626500e-02,2.066200e-03,2.248800e-03,1.041800e-02,1.494400e-02, & - &1.819900e-02,1.705200e-02,2.219400e-03,2.392500e-03,1.073900e-02, & - &1.535000e-02,1.858900e-02,1.759500e-02,2.329100e-03,2.499000e-03, & - &1.100900e-02,1.565600e-02,1.879600e-02,1.792400e-02,2.416800e-03, & - &2.586900e-03,1.122000e-02,1.586700e-02,1.887200e-02,1.807200e-02, & - &1.580300e-03,1.754900e-03,8.398200e-03,1.203800e-02,1.465700e-02, & - &1.344300e-02,1.732500e-03,1.901000e-03,8.700100e-03,1.244500e-02, & - &1.512400e-02,1.403700e-02,1.850600e-03,2.009500e-03,8.959900e-03, & - &1.277300e-02,1.541500e-02,1.444200e-02,1.937200e-03,2.094500e-03, & - &9.168200e-03,1.302300e-02,1.557100e-02,1.467300e-02,2.008600e-03, & - &2.166800e-03,9.336000e-03,1.318900e-02,1.562700e-02,1.476700e-02, & - &1.326300e-03,1.484200e-03,6.996500e-03,1.000500e-02,1.217100e-02, & - &1.107300e-02,1.446300e-03,1.597500e-03,7.242000e-03,1.033500e-02, & - &1.253200e-02,1.152700e-02,1.539100e-03,1.681900e-03,7.447300e-03, & - &1.060500e-02,1.275600e-02,1.182500e-02,1.608700e-03,1.751500e-03, & - &7.613200e-03,1.080600e-02,1.287900e-02,1.198700e-02,1.666700e-03, & - &1.811300e-03,7.748900e-03,1.092700e-02,1.292300e-02,1.204200e-02, & - &1.110600e-03,1.250400e-03,5.817900e-03,8.301600e-03,1.008800e-02, & - &9.125400e-03,1.206000e-03,1.338500e-03,6.016300e-03,8.572600e-03, & - &1.036800e-02,9.472300e-03,1.278900e-03,1.405200e-03,6.176900e-03, & - &8.790700e-03,1.054100e-02,9.694200e-03,1.335100e-03,1.462200e-03, & - &6.311800e-03,8.943300e-03,1.064000e-02,9.807700e-03,1.382500e-03, & - &1.512300e-03,6.421800e-03,9.035000e-03,1.067200e-02,9.836600e-03, & - &9.278900e-04,1.049900e-03,4.830900e-03,6.877600e-03,8.344200e-03, & - &7.515700e-03,1.003900e-03,1.118300e-03,4.987000e-03,7.101600e-03, & - &8.565000e-03,7.781600e-03,1.061700e-03,1.172300e-03,5.116100e-03, & - &7.272300e-03,8.703200e-03,7.946300e-03,1.107000e-03,1.218500e-03, & - &5.223600e-03,7.388600e-03,8.779900e-03,8.025700e-03,1.145500e-03, & - &1.260700e-03,5.314300e-03,7.459000e-03,8.797600e-03,8.038100e-03, & - &7.783800e-04,8.827400e-04,4.014300e-03,5.707000e-03,6.907900e-03, & - &6.201900e-03,8.380300e-04,9.354900e-04,4.136000e-03,5.883800e-03, & - &7.078200e-03,6.400600e-03,8.831400e-04,9.791401e-04,4.237400e-03, & - &6.014500e-03,7.184500e-03,6.516800e-03,9.196800e-04,1.016500e-03, & - &4.324100e-03,6.102600e-03,7.235800e-03,6.568200e-03,9.504700e-04, & - &1.051200e-03,4.401200e-03,6.154700e-03,7.242800e-03,6.567300e-03, & - &6.521500e-04,7.403600e-04,3.330500e-03,4.731900e-03,5.714200e-03, & - &5.113700e-03,6.989400e-04,7.816200e-04,3.426400e-03,4.869300e-03, & - &5.845600e-03,5.260200e-03,7.338800e-04,8.161800e-04,3.507800e-03, & - &4.968200e-03,5.922200e-03,5.341700e-03,7.633300e-04,8.469500e-04, & - &3.579900e-03,5.034900e-03,5.956400e-03,5.373300e-03,7.890400e-04, & - &8.761200e-04,3.645400e-03,5.075500e-03,5.957400e-03,5.364800e-03, & - &5.461000e-04,6.197700e-04,2.759800e-03,3.920300e-03,4.724500e-03, & - &4.211300e-03,5.822200e-04,6.520500e-04,2.836600e-03,4.025800e-03, & - &4.822200e-03,4.318000e-03,6.096900e-04,6.797400e-04,2.903400e-03, & - &4.101000e-03,4.877800e-03,4.373900e-03,6.334700e-04,7.050900e-04, & - &2.964400e-03,4.152300e-03,4.899500e-03,4.391000e-03,6.554500e-04, & - &7.302100e-04,3.019800e-03,4.186100e-03,4.897600e-03,4.378900e-03/ - data absb(361:720,2) / & - &4.569000e-04,5.179300e-04,2.285200e-03,3.245800e-03,3.904300e-03, & - &3.468000e-03,4.845800e-04,5.433400e-04,2.347500e-03,3.326400e-03, & - &3.975200e-03,3.543400e-03,5.065400e-04,5.657300e-04,2.403600e-03, & - &3.384700e-03,4.014700e-03,3.581300e-03,5.256800e-04,5.867600e-04, & - &2.454700e-03,3.425800e-03,4.028400e-03,3.589300e-03,5.446900e-04, & - &6.084100e-04,2.500000e-03,3.453000e-03,4.025200e-03,3.573500e-03, & - &3.820500e-04,4.324200e-04,1.892500e-03,2.685700e-03,3.223700e-03, & - &2.854100e-03,4.033500e-04,4.526300e-04,1.943800e-03,2.748400e-03, & - &3.275700e-03,2.908700e-03,4.209200e-04,4.707500e-04,1.990400e-03, & - &2.794200e-03,3.302600e-03,2.932400e-03,4.365500e-04,4.882100e-04, & - &2.032600e-03,2.827100e-03,3.311900e-03,2.934400e-03,4.531600e-04, & - &5.071200e-04,2.068500e-03,2.849900e-03,3.308400e-03,2.916200e-03, & - &3.189600e-04,3.605200e-04,1.567300e-03,2.221100e-03,2.660100e-03, & - &2.349200e-03,3.354400e-04,3.765400e-04,1.609500e-03,2.269700e-03, & - &2.696900e-03,2.386800e-03,3.496500e-04,3.914300e-04,1.647800e-03, & - &2.306800e-03,2.716300e-03,2.402300e-03,3.626800e-04,4.061200e-04, & - &1.681800e-03,2.333300e-03,2.722700e-03,2.399900e-03,3.770800e-04, & - &4.226300e-04,1.710400e-03,2.351400e-03,2.719100e-03,2.381100e-03, & - &2.658500e-04,3.001400e-04,1.297900e-03,1.836300e-03,2.193500e-03, & - &1.933200e-03,2.788700e-04,3.130000e-04,1.332500e-03,1.875300e-03, & - &2.220700e-03,1.959300e-03,2.904100e-04,3.253000e-04,1.363700e-03, & - &1.904700e-03,2.234800e-03,1.968700e-03,3.013900e-04,3.378600e-04, & - &1.391000e-03,1.926000e-03,2.239500e-03,1.963700e-03,3.138100e-04, & - &3.521800e-04,1.414700e-03,1.939500e-03,2.236300e-03,1.945800e-03, & - &2.214300e-04,2.496800e-04,1.074800e-03,1.518200e-03,1.807800e-03, & - &1.592300e-03,2.318600e-04,2.601600e-04,1.103300e-03,1.549300e-03, & - &1.828100e-03,1.610400e-03,2.412100e-04,2.703600e-04,1.128500e-03, & - &1.572600e-03,1.838800e-03,1.615500e-03,2.506200e-04,2.812800e-04, & - &1.150600e-03,1.588800e-03,1.842000e-03,1.608200e-03,2.613000e-04, & - &2.935800e-04,1.170400e-03,1.599200e-03,1.839100e-03,1.592400e-03, & - &1.843400e-04,2.075400e-04,8.902600e-04,1.255400e-03,1.489900e-03, & - &1.311900e-03,1.927100e-04,2.162000e-04,9.133900e-04,1.280000e-03, & - &1.505500e-03,1.324500e-03,2.003400e-04,2.247700e-04,9.337300e-04, & - &1.298100e-03,1.513300e-03,1.326200e-03,2.083800e-04,2.341600e-04, & - &9.518800e-04,1.310400e-03,1.515900e-03,1.319000e-03,2.176600e-04, & - &2.447500e-04,9.684200e-04,1.319000e-03,1.513000e-03,1.304700e-03, & - &1.534200e-04,1.725400e-04,7.373600e-04,1.037900e-03,1.228000e-03, & - &1.082300e-03,1.601800e-04,1.797200e-04,7.559300e-04,1.057400e-03, & - &1.239700e-03,1.090800e-03,1.664800e-04,1.869700e-04,7.727400e-04, & - &1.071400e-03,1.246000e-03,1.090600e-03,1.734200e-04,1.950600e-04, & - &7.877300e-04,1.081200e-03,1.247600e-03,1.083700e-03,1.814900e-04, & - &2.042000e-04,8.015400e-04,1.088100e-03,1.244500e-03,1.071100e-03, & - &1.276700e-04,1.434700e-04,6.106600e-04,8.582300e-04,1.012100e-03, & - &8.931000e-04,1.331200e-04,1.494100e-04,6.258100e-04,8.734500e-04, & - &1.021400e-03,8.986000e-04,1.384400e-04,1.556200e-04,6.395200e-04, & - &8.843200e-04,1.025900e-03,8.974200e-04,1.444700e-04,1.626000e-04, & - &6.520500e-04,8.922600e-04,1.026600e-03,8.909800e-04,1.514400e-04, & - &1.705400e-04,6.635900e-04,8.979400e-04,1.024000e-03,8.805600e-04, & - &1.061900e-04,1.193100e-04,5.057300e-04,7.096400e-04,8.345500e-04, & - &7.374700e-04,1.106100e-04,1.242400e-04,5.180800e-04,7.213600e-04, & - &8.414800e-04,7.407500e-04,1.151700e-04,1.295900e-04,5.294400e-04, & - &7.300700e-04,8.446900e-04,7.391300e-04,1.204100e-04,1.356300e-04, & - &5.398500e-04,7.364700e-04,8.447900e-04,7.334900e-04,1.264800e-04, & - &1.425600e-04,5.494700e-04,7.412300e-04,8.427100e-04,7.249800e-04, & - &8.815700e-05,9.906200e-05,4.184200e-04,5.863300e-04,6.878900e-04, & - &6.080700e-04,9.181100e-05,1.032100e-04,4.286300e-04,5.955600e-04, & - &6.931200e-04,6.102300e-04,9.572900e-05,1.078200e-04,4.380800e-04, & - &6.025900e-04,6.955600e-04,6.084800e-04,1.002500e-04,1.130200e-04, & - &4.467800e-04,6.079100e-04,6.956200e-04,6.039300e-04,1.055500e-04, & - &1.190700e-04,4.547800e-04,6.118000e-04,6.939500e-04,5.968900e-04, & - &7.288900e-05,8.192500e-05,3.453300e-04,4.835200e-04,5.664300e-04, & - &5.011700e-04,7.593800e-05,8.543800e-05,3.539400e-04,4.912100e-04, & - &5.708100e-04,5.028200e-04,7.926100e-05,8.933700e-05,3.618800e-04, & - &4.969300e-04,5.728400e-04,5.014300e-04,8.311900e-05,9.377900e-05, & - &3.691800e-04,5.015600e-04,5.731400e-04,4.980800e-04,8.766600e-05, & - &9.898200e-05,3.759900e-04,5.048700e-04,5.719400e-04,4.924200e-04, & - &5.999500e-05,6.746800e-05,2.843300e-04,3.980100e-04,4.661000e-04, & - &4.128100e-04,6.253200e-05,7.039900e-05,2.916000e-04,4.044700e-04, & - &4.699200e-04,4.144300e-04,6.530800e-05,7.366100e-05,2.983800e-04, & - &4.095000e-04,4.718700e-04,4.137200e-04,6.856200e-05,7.741200e-05, & - &3.044800e-04,4.135500e-04,4.723400e-04,4.112200e-04,7.236700e-05, & - &8.179500e-05,3.103300e-04,4.164200e-04,4.716100e-04,4.068900e-04/ - data absb(721:1080,2) / & - &4.905900e-05,5.519900e-05,2.331700e-04,3.267100e-04,3.829500e-04, & - &3.393800e-04,5.116500e-05,5.762000e-05,2.394100e-04,3.323900e-04, & - &3.865200e-04,3.412000e-04,5.344300e-05,6.030400e-05,2.451900e-04, & - &3.368700e-04,3.885300e-04,3.411000e-04,5.611400e-05,6.339500e-05, & - &2.504400e-04,3.404900e-04,3.893000e-04,3.395500e-04,5.921400e-05, & - &6.699900e-05,2.554600e-04,3.431800e-04,3.890500e-04,3.363100e-04, & - &4.010400e-05,4.514500e-05,1.911800e-04,2.680800e-04,3.145700e-04, & - &2.791200e-04,4.184800e-05,4.714500e-05,1.964900e-04,2.730500e-04, & - &3.178900e-04,2.811200e-04,4.372100e-05,4.934800e-05,2.014300e-04, & - &2.770900e-04,3.199000e-04,2.815400e-04,4.590800e-05,5.189300e-05, & - &2.059500e-04,2.803300e-04,3.208600e-04,2.806200e-04,4.842800e-05, & - &5.484800e-05,2.103000e-04,2.828700e-04,3.209800e-04,2.783200e-04, & - &3.277900e-05,3.691300e-05,1.567600e-04,2.199600e-04,2.583500e-04, & - &2.298600e-04,3.422600e-05,3.856800e-05,1.612700e-04,2.243100e-04, & - &2.614000e-04,2.319300e-04,3.576400e-05,4.038200e-05,1.655000e-04, & - &2.279000e-04,2.633400e-04,2.327100e-04,3.755800e-05,4.248000e-05, & - &1.693900e-04,2.308200e-04,2.643900e-04,2.323000e-04,3.959600e-05, & - &4.488900e-05,1.731500e-04,2.331300e-04,2.647700e-04,2.307200e-04, & - &2.666900e-05,3.004900e-05,1.281200e-04,1.800300e-04,2.118700e-04, & - &1.883800e-04,2.787100e-05,3.141100e-05,1.319700e-04,1.838900e-04, & - &2.147200e-04,1.905200e-04,2.911500e-05,3.288300e-05,1.356400e-04, & - &1.871700e-04,2.166400e-04,1.914900e-04,3.056900e-05,3.458400e-05, & - &1.389900e-04,1.898000e-04,2.177900e-04,1.914700e-04,3.219200e-05, & - &3.652500e-05,1.422300e-04,1.919200e-04,2.183500e-04,1.904500e-04, & - &2.167100e-05,2.443600e-05,1.046400e-04,1.472100e-04,1.735400e-04, & - &1.542200e-04,2.267300e-05,2.556400e-05,1.079400e-04,1.506700e-04, & - &1.762400e-04,1.563500e-04,2.369200e-05,2.675800e-05,1.110900e-04, & - &1.535900e-04,1.780900e-04,1.574600e-04,2.485900e-05,2.813300e-05, & - &1.139800e-04,1.560000e-04,1.793200e-04,1.577200e-04,2.615700e-05, & - &2.969400e-05,1.167900e-04,1.579700e-04,1.800600e-04,1.571400e-04, & - &1.759900e-05,1.986800e-05,8.542800e-05,1.203300e-04,1.421000e-04, & - &1.262400e-04,1.843700e-05,2.079800e-05,8.824700e-05,1.234000e-04, & - &1.446000e-04,1.283200e-04,1.927600e-05,2.177100e-05,9.094000e-05, & - &1.260000e-04,1.463600e-04,1.295300e-04,2.021400e-05,2.288300e-05, & - &9.344400e-05,1.281900e-04,1.476100e-04,1.299500e-04,2.125600e-05, & - &2.413800e-05,9.587900e-05,1.299900e-04,1.484200e-04,1.297100e-04, & - &1.424100e-05,1.610700e-05,6.957500e-05,9.812200e-05,1.161000e-04, & - &1.031300e-04,1.495300e-05,1.687600e-05,7.198900e-05,1.008800e-04, & - &1.184700e-04,1.051600e-04,1.564300e-05,1.766800e-05,7.432200e-05, & - &1.032100e-04,1.201600e-04,1.064300e-04,1.639200e-05,1.855900e-05, & - &7.646900e-05,1.051900e-04,1.214000e-04,1.070200e-04,1.722500e-05, & - &1.956100e-05,7.856900e-05,1.068600e-04,1.222800e-04,1.070400e-04, & - &1.149800e-05,1.303600e-05,5.657600e-05,7.989500e-05,9.473300e-05, & - &8.413100e-05,1.210600e-05,1.367000e-05,5.863700e-05,8.233300e-05, & - &9.691700e-05,8.609400e-05,1.267600e-05,1.431700e-05,6.063400e-05, & - &8.442900e-05,9.854600e-05,8.740900e-05,1.327700e-05,1.503100e-05, & - &6.249900e-05,8.624000e-05,9.977200e-05,8.813000e-05,1.394300e-05, & - &1.583200e-05,6.431000e-05,8.777000e-05,1.006600e-04,8.834400e-05, & - &9.269300e-06,1.054300e-05,4.596300e-05,6.497800e-05,7.719400e-05, & - &6.858900e-05,9.795700e-06,1.107400e-05,4.773900e-05,6.716500e-05, & - &7.924100e-05,7.048300e-05,1.026700e-05,1.160000e-05,4.944500e-05, & - &6.902700e-05,8.076900e-05,7.181200e-05,1.075400e-05,1.217400e-05, & - &5.105000e-05,7.066100e-05,8.192100e-05,7.260100e-05,1.128700e-05, & - &1.281400e-05,5.260500e-05,7.204800e-05,8.281900e-05,7.297400e-05, & - &7.450300e-06,8.507500e-06,3.728100e-05,5.273500e-05,6.277600e-05, & - &5.579700e-05,7.907100e-06,8.956600e-06,3.880100e-05,5.468200e-05, & - &6.466200e-05,5.762100e-05,8.305400e-06,9.387400e-06,4.025400e-05, & - &5.634700e-05,6.609600e-05,5.893600e-05,8.704700e-06,9.850800e-06, & - &4.164300e-05,5.781500e-05,6.720600e-05,5.979300e-05,9.129300e-06, & - &1.036200e-05,4.297800e-05,5.908600e-05,6.808700e-05,6.027500e-05, & - &5.948200e-06,6.834300e-06,3.015200e-05,4.266500e-05,5.089800e-05, & - &4.516900e-05,6.361000e-06,7.225000e-06,3.145500e-05,4.440600e-05, & - &5.264300e-05,4.694200e-05,6.701800e-06,7.579900e-06,3.269500e-05, & - &4.589700e-05,5.399200e-05,4.822900e-05,7.029600e-06,7.954900e-06, & - &3.389600e-05,4.721000e-05,5.505000e-05,4.911200e-05,7.368400e-06, & - &8.362300e-06,3.504200e-05,4.835900e-05,5.589500e-05,4.966500e-05, & - &4.722600e-06,5.475500e-06,2.436600e-05,3.447000e-05,4.117300e-05, & - &3.652000e-05,5.107500e-06,5.822000e-06,2.546900e-05,3.601000e-05, & - &4.279700e-05,3.822200e-05,5.403000e-06,6.119600e-06,2.653500e-05, & - &3.734200e-05,4.404900e-05,3.947400e-05,5.674000e-06,6.421300e-06, & - &2.756600e-05,3.850700e-05,4.504100e-05,4.036700e-05,5.948500e-06, & - &6.748300e-06,2.854400e-05,3.954200e-05,4.583900e-05,4.096600e-05/ - data absb(1081:1410,2) / & - &3.728500e-06,4.368700e-06,1.966200e-05,2.780000e-05,3.321800e-05, & - &2.950100e-05,4.088400e-06,4.682100e-06,2.060200e-05,2.915100e-05, & - &3.472100e-05,3.111200e-05,4.349900e-06,4.938200e-06,2.151300e-05, & - &3.033100e-05,3.587200e-05,3.232900e-05,4.578200e-06,5.183100e-06, & - &2.238800e-05,3.137000e-05,3.680600e-05,3.322400e-05,4.803800e-06, & - &5.447100e-06,2.322800e-05,3.229500e-05,3.755800e-05,3.386500e-05, & - &2.938500e-06,3.475600e-06,1.586800e-05,2.241300e-05,2.677600e-05, & - &2.374500e-05,3.264700e-06,3.762800e-06,1.666600e-05,2.359400e-05, & - &2.815000e-05,2.521100e-05,3.502400e-06,3.986700e-06,1.743900e-05, & - &2.463000e-05,2.919800e-05,2.636000e-05,3.696900e-06,4.188500e-06, & - &1.818600e-05,2.554700e-05,3.005400e-05,2.721400e-05,3.881500e-06, & - &4.401200e-06,1.891000e-05,2.636900e-05,3.075400e-05,2.785500e-05, & - &2.310000e-06,2.756300e-06,1.280300e-05,1.805400e-05,2.154700e-05, & - &1.904400e-05,2.596100e-06,3.018600e-06,1.347700e-05,1.907600e-05, & - &2.278100e-05,2.036000e-05,2.816700e-06,3.217000e-06,1.413000e-05, & - &1.998300e-05,2.374300e-05,2.143100e-05,2.984700e-06,3.386300e-06, & - &1.476700e-05,2.079000e-05,2.452300e-05,2.222500e-05,3.138000e-06, & - &3.558800e-06,1.538700e-05,2.151600e-05,2.516100e-05,2.284200e-05, & - &1.809200e-06,2.178300e-06,1.032000e-05,1.452000e-05,1.729600e-05, & - &1.525800e-05,2.055200e-06,2.412800e-06,1.088700e-05,1.540400e-05, & - &1.840000e-05,1.643200e-05,2.259300e-06,2.591400e-06,1.144000e-05, & - &1.619100e-05,1.927900e-05,1.741000e-05,2.406900e-06,2.736500e-06, & - &1.198000e-05,1.689900e-05,1.998000e-05,1.815900e-05,2.536000e-06, & - &2.876600e-06,1.250900e-05,1.753500e-05,2.056300e-05,1.874000e-05, & - &1.410500e-06,1.715800e-06,8.308400e-06,1.165900e-05,1.384700e-05, & - &1.221400e-05,1.620200e-06,1.919900e-06,8.786500e-06,1.242000e-05, & - &1.483200e-05,1.326000e-05,1.804800e-06,2.083300e-06,9.254200e-06, & - &1.310300e-05,1.562900e-05,1.414800e-05,1.938800e-06,2.209900e-06, & - &9.709500e-06,1.372000e-05,1.625800e-05,1.485600e-05,2.048400e-06, & - &2.325200e-06,1.015900e-05,1.427500e-05,1.678600e-05,1.540800e-05, & - &1.100100e-06,1.352000e-06,6.691500e-06,9.365100e-06,1.108000e-05, & - &9.691500e-06,1.277600e-06,1.526400e-06,7.098000e-06,1.001900e-05, & - &1.195100e-05,1.059900e-05,1.438900e-06,1.674400e-06,7.489600e-06, & - &1.060500e-05,1.266100e-05,1.137100e-05,1.561800e-06,1.785600e-06, & - &7.873000e-06,1.113900e-05,1.322500e-05,1.200500e-05,1.656300e-06, & - &1.882100e-06,8.253700e-06,1.162100e-05,1.370000e-05,1.249700e-05, & - &8.564500e-07,1.063900e-06,5.388200e-06,7.516000e-06,8.856400e-06, & - &7.641100e-06,1.006000e-06,1.211800e-06,5.733600e-06,8.078000e-06, & - &9.617000e-06,8.415100e-06,1.144200e-06,1.343100e-06,6.060400e-06, & - &8.580100e-06,1.024700e-05,9.070900e-06,1.256800e-06,1.442100e-06, & - &6.382900e-06,9.038000e-06,1.075200e-05,9.623200e-06,1.338900e-06, & - &1.523900e-06,6.704800e-06,9.456000e-06,1.117200e-05,1.004900e-05, & - &6.644200e-07,8.337900e-07,4.332400e-06,6.019800e-06,7.062900e-06, & - &6.004900e-06,7.895000e-07,9.595200e-07,4.627300e-06,6.504700e-06, & - &7.721900e-06,6.668200e-06,9.071700e-07,1.073800e-06,4.900800e-06, & - &6.932900e-06,8.280600e-06,7.228500e-06,1.008400e-06,1.162900e-06, & - &5.171000e-06,7.326600e-06,8.730800e-06,7.699300e-06,1.081300e-06, & - &1.233200e-06,5.441400e-06,7.687600e-06,9.101800e-06,8.075100e-06, & - &5.131700e-07,6.495100e-07,3.479300e-06,4.812100e-06,5.619500e-06, & - &4.703100e-06,6.173500e-07,7.575800e-07,3.730400e-06,5.229300e-06, & - &6.186300e-06,5.274100e-06,7.169800e-07,8.554300e-07,3.960900e-06, & - &5.596900e-06,6.679700e-06,5.751300e-06,8.060800e-07,9.360800e-07, & - &4.186700e-06,5.932600e-06,7.078000e-06,6.153500e-06,8.722000e-07, & - &9.972200e-07,4.412300e-06,6.244200e-06,7.406300e-06,6.483900e-06, & - &3.948000e-07,5.043500e-07,2.793500e-06,3.843200e-06,4.465700e-06, & - &3.676400e-06,4.821900e-07,5.977200e-07,3.007300e-06,4.202500e-06, & - &4.951800e-06,4.162500e-06,5.660600e-07,6.807000e-07,3.201500e-06, & - &4.517400e-06,5.383200e-06,4.568100e-06,6.428200e-07,7.525500e-07, & - &3.389600e-06,4.802400e-06,5.733800e-06,4.908100e-06,7.031100e-07, & - &8.064500e-07,3.578200e-06,5.069800e-06,6.023400e-06,5.189000e-06, & - &3.153900e-07,4.048000e-07,2.273800e-06,3.121100e-06,3.618200e-06, & - &2.920400e-06,3.882200e-07,4.832400e-07,2.452900e-06,3.423200e-06, & - &4.026900e-06,3.311700e-06,4.580300e-07,5.525100e-07,2.614200e-06, & - &3.687300e-06,4.390900e-06,3.639700e-06,5.220900e-07,6.131300e-07, & - &2.770900e-06,3.926700e-06,4.688500e-06,3.910000e-06,5.735600e-07, & - &6.588400e-07,2.928800e-06,4.151600e-06,4.935000e-06,4.128000e-06/ - data absb(1:360,3) / & - &7.640900e-03,7.863000e-03,3.509900e-02,5.148900e-02,6.347800e-02, & - &6.704500e-02,7.619400e-03,7.843900e-03,3.632000e-02,5.359000e-02, & - &6.575500e-02,7.086100e-02,7.622100e-03,7.847800e-03,3.740800e-02, & - &5.538800e-02,6.778900e-02,7.414000e-02,7.724500e-03,7.951600e-03, & - &3.834600e-02,5.682200e-02,6.956600e-02,7.716600e-02,7.897800e-03, & - &8.125500e-03,3.919100e-02,5.791600e-02,7.102900e-02,7.976600e-02, & - &6.345800e-03,6.574300e-03,3.054400e-02,4.493700e-02,5.515000e-02, & - &5.719700e-02,6.329300e-03,6.560500e-03,3.159100e-02,4.670600e-02, & - &5.714200e-02,6.015500e-02,6.358700e-03,6.594500e-03,3.249600e-02, & - &4.818500e-02,5.890900e-02,6.270600e-02,6.468600e-03,6.709200e-03, & - &3.331300e-02,4.936200e-02,6.043100e-02,6.490800e-02,6.625500e-03, & - &6.864000e-03,3.402400e-02,5.021800e-02,6.152800e-02,6.651600e-02, & - &5.260800e-03,5.495500e-03,2.638400e-02,3.886900e-02,4.760200e-02, & - &4.863500e-02,5.254800e-03,5.495600e-03,2.724900e-02,4.034500e-02, & - &4.931000e-02,5.094500e-02,5.299300e-03,5.550000e-03,2.801900e-02, & - &4.155100e-02,5.081400e-02,5.282300e-02,5.406600e-03,5.660800e-03, & - &2.870800e-02,4.245200e-02,5.192600e-02,5.415400e-02,5.552100e-03, & - &5.801700e-03,2.928200e-02,4.300700e-02,5.252600e-02,5.494300e-02, & - &4.354800e-03,4.588000e-03,2.261000e-02,3.337500e-02,4.079000e-02, & - &4.126000e-02,4.361900e-03,4.606800e-03,2.334800e-02,3.457700e-02, & - &4.224100e-02,4.300900e-02,4.413600e-03,4.670500e-03,2.398400e-02, & - &3.550400e-02,4.335300e-02,4.422400e-02,4.517800e-03,4.776600e-03, & - &2.452800e-02,3.607200e-02,4.401000e-02,4.497500e-02,4.650400e-03, & - &4.907100e-03,2.494200e-02,3.636300e-02,4.428200e-02,4.537900e-02, & - &3.604600e-03,3.829100e-03,1.925700e-02,2.845100e-02,3.471100e-02, & - &3.475600e-02,3.621300e-03,3.859200e-03,1.986200e-02,2.937400e-02, & - &3.581900e-02,3.595700e-02,3.677100e-03,3.929100e-03,2.036300e-02, & - &2.999400e-02,3.652600e-02,3.669900e-02,3.771400e-03,4.028300e-03, & - &2.075900e-02,3.032600e-02,3.691000e-02,3.715200e-02,3.889900e-03, & - &4.146600e-03,2.106500e-02,3.050500e-02,3.703500e-02,3.734700e-02, & - &2.988500e-03,3.199800e-03,1.629600e-02,2.406100e-02,2.931000e-02, & - &2.902100e-02,3.009200e-03,3.235700e-03,1.676700e-02,2.471100e-02, & - &3.006900e-02,2.981800e-02,3.060100e-03,3.301900e-03,1.713700e-02, & - &2.510700e-02,3.052700e-02,3.031400e-02,3.143300e-03,3.390400e-03, & - &1.744500e-02,2.534000e-02,3.077200e-02,3.059500e-02,3.249100e-03, & - &3.497500e-03,1.766300e-02,2.546100e-02,3.082200e-02,3.067700e-02, & - &2.479200e-03,2.678600e-03,1.369100e-02,2.018000e-02,2.454400e-02, & - &2.404000e-02,2.498200e-03,2.713400e-03,1.404900e-02,2.062900e-02, & - &2.506900e-02,2.459700e-02,2.545200e-03,2.774600e-03,1.434400e-02, & - &2.092100e-02,2.539000e-02,2.493500e-02,2.619600e-03,2.853000e-03, & - &1.457900e-02,2.109700e-02,2.555500e-02,2.510700e-02,2.716200e-03, & - &2.953000e-03,1.473200e-02,2.118600e-02,2.557200e-02,2.511800e-02, & - &2.052800e-03,2.239500e-03,1.144000e-02,1.682200e-02,2.043700e-02, & - &1.985400e-02,2.071100e-03,2.273600e-03,1.172300e-02,1.715800e-02, & - &2.081700e-02,2.025400e-02,2.115100e-03,2.329300e-03,1.195700e-02, & - &1.738000e-02,2.105000e-02,2.049200e-02,2.183300e-03,2.401500e-03, & - &1.212900e-02,1.752200e-02,2.116800e-02,2.059700e-02,2.272400e-03, & - &2.494900e-03,1.224900e-02,1.757800e-02,2.116600e-02,2.057100e-02, & - &1.696500e-03,1.866600e-03,9.520000e-03,1.396500e-02,1.695200e-02, & - &1.635700e-02,1.715200e-03,1.900200e-03,9.751700e-03,1.422700e-02, & - &1.723600e-02,1.665000e-02,1.756700e-03,1.951000e-03,9.928300e-03, & - &1.440800e-02,1.741900e-02,1.682100e-02,1.818200e-03,2.017900e-03, & - &1.006100e-02,1.451200e-02,1.750200e-02,1.688300e-02,1.900200e-03, & - &2.104900e-03,1.016000e-02,1.454700e-02,1.749300e-02,1.683800e-02, & - &1.401200e-03,1.554300e-03,7.918700e-03,1.158200e-02,1.404400e-02, & - &1.347500e-02,1.421700e-03,1.587800e-03,8.097500e-03,1.178900e-02, & - &1.426000e-02,1.368600e-02,1.462500e-03,1.635600e-03,8.234200e-03, & - &1.192800e-02,1.439900e-02,1.380200e-02,1.518900e-03,1.698200e-03, & - &8.336300e-03,1.199600e-02,1.445500e-02,1.383000e-02,1.592900e-03, & - &1.778500e-03,8.413100e-03,1.201500e-02,1.443000e-02,1.377200e-02, & - &1.157000e-03,1.292900e-03,6.574400e-03,9.592900e-03,1.161500e-02, & - &1.108600e-02,1.179000e-03,1.325700e-03,6.709800e-03,9.754400e-03, & - &1.178200e-02,1.123700e-02,1.217500e-03,1.370400e-03,6.814100e-03, & - &9.851500e-03,1.188900e-02,1.131500e-02,1.268600e-03,1.428200e-03, & - &6.893400e-03,9.900200e-03,1.192000e-02,1.131800e-02,1.334000e-03, & - &1.500100e-03,6.957700e-03,9.910800e-03,1.188600e-02,1.125400e-02, & - &9.557400e-04,1.075300e-03,5.447600e-03,7.937600e-03,9.595900e-03, & - &9.110000e-03,9.783400e-04,1.107000e-03,5.550600e-03,8.055700e-03, & - &9.727600e-03,9.217600e-03,1.014000e-03,1.148500e-03,5.632300e-03, & - &8.128100e-03,9.802800e-03,9.263500e-03,1.059400e-03,1.200500e-03, & - &5.696600e-03,8.161200e-03,9.814500e-03,9.250500e-03,1.117200e-03, & - &1.264400e-03,5.752300e-03,8.164300e-03,9.779400e-03,9.186500e-03/ - data absb(361:720,3) / & - &7.903100e-04,8.949800e-04,4.509300e-03,6.559700e-03,7.922600e-03, & - &7.481400e-03,8.126300e-04,9.245900e-04,4.588000e-03,6.646700e-03, & - &8.024700e-03,7.557200e-03,8.447900e-04,9.625700e-04,4.652700e-03, & - &6.697700e-03,8.072500e-03,7.581300e-03,8.854500e-04,1.009300e-03, & - &4.708800e-03,6.718600e-03,8.072500e-03,7.558200e-03,9.363900e-04, & - &1.065800e-03,4.758000e-03,6.721000e-03,8.036800e-03,7.494000e-03, & - &6.544000e-04,7.455500e-04,3.728700e-03,5.415600e-03,6.539700e-03, & - &6.143500e-03,6.758800e-04,7.729200e-04,3.791700e-03,5.478600e-03, & - &6.611900e-03,6.192700e-03,7.045000e-04,8.070600e-04,3.845200e-03, & - &5.513700e-03,6.641500e-03,6.201800e-03,7.413900e-04,8.491600e-04, & - &3.895900e-03,5.529600e-03,6.634700e-03,6.172900e-03,7.867800e-04, & - &8.996400e-04,3.939800e-03,5.533900e-03,6.600700e-03,6.113000e-03, & - &5.426100e-04,6.213800e-04,3.081200e-03,4.467300e-03,5.393000e-03, & - &5.043200e-03,5.624400e-04,6.462300e-04,3.132600e-03,4.513000e-03, & - &5.444100e-03,5.074600e-03,5.879300e-04,6.766500e-04,3.179900e-03, & - &4.538600e-03,5.459800e-03,5.073500e-03,6.213900e-04,7.145600e-04, & - &3.224600e-03,4.553000e-03,5.448800e-03,5.044000e-03,6.618900e-04, & - &7.592800e-04,3.262200e-03,4.558300e-03,5.419200e-03,4.988700e-03, & - &4.504100e-04,5.180200e-04,2.545900e-03,3.682600e-03,4.443200e-03, & - &4.138600e-03,4.681800e-04,5.402500e-04,2.590100e-03,3.716600e-03, & - &4.477600e-03,4.157600e-03,4.912200e-04,5.673100e-04,2.631700e-03, & - &3.737800e-03,4.484800e-03,4.151100e-03,5.216500e-04,6.015300e-04, & - &2.670100e-03,3.751700e-03,4.473300e-03,4.121400e-03,5.574700e-04, & - &6.405100e-04,2.700700e-03,3.758700e-03,4.449800e-03,4.072200e-03, & - &3.741300e-04,4.319600e-04,2.104400e-03,3.034300e-03,3.658500e-03, & - &3.398100e-03,3.901700e-04,4.516600e-04,2.142400e-03,3.061200e-03, & - &3.681000e-03,3.409500e-03,4.115700e-04,4.762500e-04,2.179200e-03, & - &3.080600e-03,3.683700e-03,3.400200e-03,4.386500e-04,5.066300e-04, & - &2.209000e-03,3.093800e-03,3.674400e-03,3.373500e-03,4.701200e-04, & - &5.403900e-04,2.235400e-03,3.100500e-03,3.655100e-03,3.329700e-03, & - &3.110300e-04,3.602400e-04,1.740600e-03,2.500500e-03,3.011000e-03, & - &2.791100e-03,3.257700e-04,3.778500e-04,1.773700e-03,2.523600e-03, & - &3.025500e-03,2.797200e-03,3.453800e-04,4.001700e-04,1.803600e-03, & - &2.540600e-03,3.026900e-03,2.787000e-03,3.693500e-04,4.267300e-04, & - &1.828600e-03,2.552900e-03,3.018600e-03,2.761500e-03,3.967600e-04, & - &4.560800e-04,1.851300e-03,2.558400e-03,3.004000e-03,2.724200e-03, & - &2.590000e-04,3.006600e-04,1.440600e-03,2.061800e-03,2.477300e-03, & - &2.294800e-03,2.726100e-04,3.165500e-04,1.468400e-03,2.081000e-03, & - &2.487300e-03,2.297800e-03,2.903700e-04,3.366900e-04,1.492800e-03, & - &2.096600e-03,2.488100e-03,2.287800e-03,3.115400e-04,3.597900e-04, & - &1.513800e-03,2.106400e-03,2.482300e-03,2.265400e-03,3.350700e-04, & - &3.850900e-04,1.534200e-03,2.111600e-03,2.470900e-03,2.233800e-03, & - &2.161400e-04,2.512600e-04,1.193000e-03,1.700700e-03,2.038100e-03, & - &1.887800e-03,2.286100e-04,2.657100e-04,1.216200e-03,1.718000e-03, & - &2.046000e-03,1.889000e-03,2.445700e-04,2.836500e-04,1.236300e-03, & - &1.730700e-03,2.047000e-03,1.879000e-03,2.629700e-04,3.036400e-04, & - &1.254300e-03,1.738500e-03,2.043000e-03,1.859400e-03,2.832000e-04, & - &3.252700e-04,1.272600e-03,1.743900e-03,2.033400e-03,1.832800e-03, & - &1.807700e-04,2.103900e-04,9.884000e-04,1.404300e-03,1.677700e-03, & - &1.554300e-03,1.922000e-04,2.235000e-04,1.007400e-03,1.418700e-03, & - &1.683800e-03,1.553800e-03,2.062600e-04,2.391800e-04,1.024400e-03, & - &1.428900e-03,1.685200e-03,1.544300e-03,2.221500e-04,2.563900e-04, & - &1.040300e-03,1.435600e-03,1.681800e-03,1.527700e-03,2.395800e-04, & - &2.749400e-04,1.056500e-03,1.441000e-03,1.674100e-03,1.505400e-03, & - &1.511900e-04,1.760900e-04,8.185500e-04,1.159600e-03,1.381200e-03, & - &1.279100e-03,1.614500e-04,1.878500e-04,8.342500e-04,1.171200e-03, & - &1.386600e-03,1.277300e-03,1.736700e-04,2.013300e-04,8.488300e-04, & - &1.179900e-03,1.388200e-03,1.269100e-03,1.873400e-04,2.160900e-04, & - &8.630700e-04,1.186300e-03,1.385500e-03,1.255000e-03,2.022500e-04, & - &2.320200e-04,8.775200e-04,1.192000e-03,1.379500e-03,1.236300e-03, & - &1.258600e-04,1.467100e-04,6.765800e-04,9.564900e-04,1.137000e-03, & - &1.052300e-03,1.347900e-04,1.569400e-04,6.901600e-04,9.665800e-04, & - &1.142300e-03,1.050900e-03,1.452700e-04,1.684000e-04,7.025100e-04, & - &9.740700e-04,1.143500e-03,1.044100e-03,1.569100e-04,1.809800e-04, & - &7.153300e-04,9.805800e-04,1.141800e-03,1.032600e-03,1.695700e-04, & - &1.945900e-04,7.279900e-04,9.863600e-04,1.137800e-03,1.017100e-03, & - &1.041400e-04,1.215100e-04,5.580100e-04,7.882700e-04,9.359900e-04, & - &8.655900e-04,1.117000e-04,1.301600e-04,5.697600e-04,7.972400e-04, & - &9.408500e-04,8.649800e-04,1.205600e-04,1.398600e-04,5.809100e-04, & - &8.044800e-04,9.427300e-04,8.599700e-04,1.303800e-04,1.504700e-04, & - &5.920300e-04,8.104000e-04,9.417900e-04,8.508400e-04,1.410400e-04, & - &1.619900e-04,6.030800e-04,8.160500e-04,9.393300e-04,8.381800e-04/ - data absb(721:1080,3) / & - &8.532300e-05,9.966400e-05,4.588400e-04,6.485200e-04,7.697400e-04, & - &7.114100e-04,9.152700e-05,1.068200e-04,4.690900e-04,6.566900e-04, & - &7.746700e-04,7.119400e-04,9.887100e-05,1.148700e-04,4.788600e-04, & - &6.634500e-04,7.769500e-04,7.084900e-04,1.070400e-04,1.237400e-04, & - &4.888300e-04,6.693000e-04,7.773700e-04,7.016800e-04,1.159700e-04, & - &1.333900e-04,4.984100e-04,6.748100e-04,7.762400e-04,6.918200e-04, & - &6.986400e-05,8.170200e-05,3.772000e-04,5.335600e-04,6.330900e-04, & - &5.849800e-04,7.494900e-05,8.760500e-05,3.861200e-04,5.408500e-04, & - &6.377400e-04,5.861500e-04,8.103200e-05,9.429000e-05,3.946900e-04, & - &5.471000e-04,6.404600e-04,5.842400e-04,8.783000e-05,1.016900e-04, & - &4.033700e-04,5.526100e-04,6.415500e-04,5.791300e-04,9.529300e-05, & - &1.097800e-04,4.117700e-04,5.578800e-04,6.415400e-04,5.716600e-04, & - &5.719700e-05,6.697300e-05,3.100500e-04,4.387400e-04,5.205600e-04, & - &4.813100e-04,6.137100e-05,7.184200e-05,3.177900e-04,4.453100e-04, & - &5.250200e-04,4.829800e-04,6.640700e-05,7.739400e-05,3.254000e-04, & - &4.511500e-04,5.279900e-04,4.821500e-04,7.206400e-05,8.356000e-05, & - &3.330100e-04,4.563200e-04,5.296100e-04,4.785800e-04,7.830300e-05, & - &9.035500e-05,3.403500e-04,4.613400e-04,5.303100e-04,4.730800e-04, & - &4.652200e-05,5.452200e-05,2.542100e-04,3.602700e-04,4.276700e-04, & - &3.947300e-04,4.986300e-05,5.847100e-05,2.609200e-04,3.661200e-04, & - &4.319700e-04,3.968100e-04,5.396800e-05,6.302700e-05,2.675700e-04, & - &3.715200e-04,4.351300e-04,3.968300e-04,5.862300e-05,6.812600e-05, & - &2.742600e-04,3.763600e-04,4.371100e-04,3.945200e-04,6.378900e-05, & - &7.376600e-05,2.807000e-04,3.810600e-04,4.383100e-04,3.905300e-04, & - &3.780400e-05,4.433300e-05,2.082100e-04,2.954900e-04,3.510300e-04, & - &3.234100e-04,4.049200e-05,4.755000e-05,2.140800e-04,3.008900e-04, & - &3.553200e-04,3.258700e-04,4.379500e-05,5.126500e-05,2.198700e-04, & - &3.057700e-04,3.584300e-04,3.263800e-04,4.761900e-05,5.546200e-05, & - &2.257500e-04,3.102300e-04,3.606600e-04,3.250600e-04,5.189800e-05, & - &6.015400e-05,2.313800e-04,3.146300e-04,3.621900e-04,3.222500e-04, & - &3.072500e-05,3.604300e-05,1.704800e-04,2.422800e-04,2.880200e-04, & - &2.649700e-04,3.288100e-05,3.866300e-05,1.755900e-04,2.471600e-04, & - &2.921000e-04,2.674800e-04,3.552700e-05,4.168100e-05,1.806200e-04, & - &2.515200e-04,2.951100e-04,2.684100e-04,3.866400e-05,4.513400e-05, & - &1.857700e-04,2.556400e-04,2.974700e-04,2.678600e-04,4.219500e-05, & - &4.902100e-05,1.906800e-04,2.597000e-04,2.991900e-04,2.659900e-04, & - &2.489100e-05,2.918700e-05,1.392800e-04,1.983100e-04,2.359200e-04, & - &2.167500e-04,2.659300e-05,3.130100e-05,1.437400e-04,2.027200e-04, & - &2.398300e-04,2.194200e-04,2.869000e-05,3.374700e-05,1.481000e-04, & - &2.066800e-04,2.428500e-04,2.207100e-04,3.123200e-05,3.654700e-05, & - &1.525600e-04,2.103800e-04,2.451500e-04,2.207100e-04,3.412000e-05, & - &3.974300e-05,1.568300e-04,2.140700e-04,2.469600e-04,2.195800e-04, & - &2.014400e-05,2.360500e-05,1.136600e-04,1.621700e-04,1.930400e-04, & - &1.772000e-04,2.146800e-05,2.528800e-05,1.174600e-04,1.660100e-04, & - &1.966400e-04,1.797800e-04,2.311700e-05,2.725500e-05,1.212700e-04, & - &1.696200e-04,1.995500e-04,1.813300e-04,2.516700e-05,2.952500e-05, & - &1.251500e-04,1.729800e-04,2.018800e-04,1.818200e-04,2.750900e-05, & - &3.213300e-05,1.289000e-04,1.763100e-04,2.037300e-04,1.812800e-04, & - &1.631500e-05,1.909900e-05,9.265800e-05,1.324700e-04,1.577700e-04, & - &1.448100e-04,1.734100e-05,2.042700e-05,9.596000e-05,1.359600e-04, & - &1.612200e-04,1.473800e-04,1.864700e-05,2.202200e-05,9.923800e-05, & - &1.391200e-04,1.638800e-04,1.490100e-04,2.026200e-05,2.384000e-05, & - &1.026000e-04,1.421100e-04,1.661000e-04,1.498000e-04,2.216700e-05, & - &2.596900e-05,1.058800e-04,1.451200e-04,1.679600e-04,1.497600e-04, & - &1.321100e-05,1.544600e-05,7.542700e-05,1.080600e-04,1.287600e-04, & - &1.182100e-04,1.399000e-05,1.647000e-05,7.824800e-05,1.111300e-04, & - &1.319300e-04,1.206400e-04,1.501300e-05,1.775300e-05,8.110200e-05, & - &1.139700e-04,1.344400e-04,1.223400e-04,1.627700e-05,1.921000e-05, & - &8.398000e-05,1.166300e-04,1.365200e-04,1.233800e-04,1.781600e-05, & - &2.093200e-05,8.685600e-05,1.193100e-04,1.383300e-04,1.237100e-04, & - &1.069500e-05,1.247600e-05,6.124500e-05,8.792100e-05,1.048100e-04, & - &9.623600e-05,1.126300e-05,1.324300e-05,6.364800e-05,9.065600e-05, & - &1.077200e-04,9.851900e-05,1.204800e-05,1.425900e-05,6.611500e-05, & - &9.316800e-05,1.100900e-04,1.002300e-04,1.303200e-05,1.542700e-05, & - &6.859800e-05,9.556800e-05,1.120600e-04,1.014200e-04,1.425400e-05, & - &1.679500e-05,7.109600e-05,9.793400e-05,1.137900e-04,1.019900e-04, & - &8.684100e-06,1.009600e-05,4.969400e-05,7.145200e-05,8.525900e-05, & - &7.830700e-05,9.079600e-06,1.065900e-05,5.174000e-05,7.390000e-05, & - &8.787500e-05,8.045100e-05,9.676900e-06,1.145000e-05,5.383100e-05, & - &7.609500e-05,9.006700e-05,8.211700e-05,1.044000e-05,1.238500e-05, & - &5.596000e-05,7.822100e-05,9.189100e-05,8.337900e-05,1.139900e-05, & - &1.346800e-05,5.811500e-05,8.030100e-05,9.349400e-05,8.413200e-05/ - data absb(1081:1410,3) / & - &7.069500e-06,8.188300e-06,4.027000e-05,5.798100e-05,6.925900e-05, & - &6.368100e-05,7.332200e-06,8.589700e-06,4.201400e-05,6.015600e-05, & - &7.156900e-05,6.571400e-05,7.777900e-06,9.193200e-06,4.377800e-05, & - &6.207500e-05,7.358100e-05,6.731100e-05,8.366700e-06,9.939100e-06, & - &4.560500e-05,6.394500e-05,7.525400e-05,6.860200e-05,9.110000e-06, & - &1.079700e-05,4.745500e-05,6.578300e-05,7.674100e-05,6.949600e-05, & - &5.766600e-06,6.661700e-06,3.263400e-05,4.702600e-05,5.623100e-05, & - &5.164600e-05,5.941300e-06,6.942300e-06,3.412100e-05,4.895100e-05, & - &5.827500e-05,5.353300e-05,6.268300e-06,7.397200e-06,3.560700e-05, & - &5.064100e-05,6.009000e-05,5.499900e-05,6.719900e-06,7.987900e-06, & - &3.716700e-05,5.227500e-05,6.160800e-05,5.623500e-05,7.303400e-06, & - &8.680800e-06,3.875700e-05,5.388100e-05,6.296800e-05,5.716700e-05, & - &4.708600e-06,5.429900e-06,2.642400e-05,3.811500e-05,4.561000e-05, & - &4.179400e-05,4.828700e-06,5.624000e-06,2.769700e-05,3.979900e-05, & - &4.741200e-05,4.351200e-05,5.060600e-06,5.960400e-06,2.895200e-05, & - &4.129000e-05,4.903100e-05,4.484900e-05,5.406500e-06,6.426300e-06, & - &3.028300e-05,4.271700e-05,5.042400e-05,4.599500e-05,5.861500e-06, & - &6.982000e-06,3.164100e-05,4.412000e-05,5.164700e-05,4.691200e-05, & - &3.843600e-06,4.427400e-06,2.137300e-05,3.085800e-05,3.695300e-05, & - &3.378500e-05,3.932800e-06,4.565100e-06,2.246800e-05,3.232000e-05, & - &3.852700e-05,3.535300e-05,4.091400e-06,4.808500e-06,2.352100e-05, & - &3.363100e-05,3.996300e-05,3.658500e-05,4.353100e-06,5.170100e-06, & - &2.464300e-05,3.486100e-05,4.120800e-05,3.763000e-05,4.705000e-06, & - &5.613100e-06,2.580100e-05,3.608400e-05,4.230800e-05,3.850700e-05, & - &3.130700e-06,3.609000e-06,1.727100e-05,2.494800e-05,2.990500e-05, & - &2.729100e-05,3.206200e-06,3.712600e-06,1.820700e-05,2.621000e-05, & - &3.126300e-05,2.872800e-05,3.314400e-06,3.884400e-06,1.909600e-05, & - &2.736700e-05,3.254800e-05,2.986900e-05,3.507700e-06,4.159500e-06, & - &2.003400e-05,2.842700e-05,3.365200e-05,3.082300e-05,3.777200e-06, & - &4.510100e-06,2.101800e-05,2.948700e-05,3.462900e-05,3.166400e-05, & - &2.545200e-06,2.941700e-06,1.396500e-05,2.017800e-05,2.420900e-05, & - &2.191100e-05,2.617300e-06,3.026500e-06,1.476000e-05,2.126600e-05, & - &2.537700e-05,2.318800e-05,2.694300e-06,3.147500e-06,1.551200e-05, & - &2.226900e-05,2.649700e-05,2.419300e-05,2.834600e-06,3.354900e-06, & - &1.629500e-05,2.318300e-05,2.747400e-05,2.501500e-05,3.040800e-06, & - &3.632400e-06,1.712700e-05,2.410000e-05,2.833900e-05,2.574500e-05, & - &2.063200e-06,2.394000e-06,1.129600e-05,1.631600e-05,1.958600e-05, & - &1.751900e-05,2.137300e-06,2.469100e-06,1.196100e-05,1.724200e-05, & - &2.058300e-05,1.862100e-05,2.194900e-06,2.556100e-06,1.260000e-05, & - &1.811100e-05,2.155900e-05,1.949900e-05,2.295000e-06,2.710900e-06, & - &1.325000e-05,1.889900e-05,2.241400e-05,2.019800e-05,2.453000e-06, & - &2.929100e-06,1.395100e-05,1.968600e-05,2.317700e-05,2.080000e-05, & - &1.664200e-06,1.942600e-06,9.134100e-06,1.318100e-05,1.582900e-05, & - &1.399200e-05,1.742900e-06,2.013900e-06,9.685100e-06,1.396300e-05, & - &1.668100e-05,1.493600e-05,1.789600e-06,2.079500e-06,1.022500e-05, & - &1.471600e-05,1.751700e-05,1.570200e-05,1.860700e-06,2.192300e-06, & - &1.076800e-05,1.539700e-05,1.827400e-05,1.630600e-05,1.979900e-06, & - &2.361700e-06,1.135600e-05,1.607000e-05,1.894800e-05,1.680100e-05, & - &1.335300e-06,1.573000e-06,7.381100e-06,1.064000e-05,1.277700e-05, & - &1.115800e-05,1.417900e-06,1.641600e-06,7.834500e-06,1.129600e-05, & - &1.350600e-05,1.196200e-05,1.459900e-06,1.693900e-06,8.291700e-06, & - &1.194500e-05,1.422000e-05,1.263300e-05,1.511200e-06,1.774700e-06, & - &8.745000e-06,1.253100e-05,1.488500e-05,1.315800e-05,1.599300e-06, & - &1.904700e-06,9.236200e-06,1.310300e-05,1.547100e-05,1.357100e-05, & - &1.068200e-06,1.270700e-06,5.967300e-06,8.591500e-06,1.031300e-05, & - &8.887500e-06,1.151000e-06,1.337200e-06,6.338300e-06,9.137100e-06, & - &1.093200e-05,9.571700e-06,1.191800e-06,1.381300e-06,6.724600e-06, & - &9.693500e-06,1.153900e-05,1.014900e-05,1.230300e-06,1.439900e-06, & - &7.103100e-06,1.019800e-05,1.212000e-05,1.060300e-05,1.294300e-06, & - &1.538700e-06,7.511300e-06,1.068200e-05,1.262900e-05,1.095500e-05, & - &8.684400e-07,1.037100e-06,4.874900e-06,7.011100e-06,8.411500e-06, & - &7.146100e-06,9.408300e-07,1.095400e-06,5.183600e-06,7.469100e-06, & - &8.932800e-06,7.701600e-06,9.774100e-07,1.133100e-06,5.507000e-06, & - &7.939300e-06,9.448800e-06,8.160700e-06,1.009200e-06,1.180600e-06, & - &5.824600e-06,8.365100e-06,9.943200e-06,8.524600e-06,1.060200e-06, & - &1.260800e-06,6.168200e-06,8.777800e-06,1.037600e-05,8.803000e-06/ - data absb(1:360,4) / & - &1.194400e-02,1.216800e-02,5.992200e-02,8.936700e-02,1.107400e-01, & - &1.194400e-01,1.208600e-02,1.230400e-02,6.146000e-02,9.145600e-02, & - &1.134400e-01,1.241200e-01,1.235700e-02,1.257000e-02,6.288700e-02, & - &9.335800e-02,1.157000e-01,1.284500e-01,1.272900e-02,1.293700e-02, & - &6.414700e-02,9.501300e-02,1.176200e-01,1.322600e-01,1.323800e-02, & - &1.344000e-02,6.515300e-02,9.639200e-02,1.191800e-01,1.357000e-01, & - &1.001200e-02,1.024700e-02,5.297500e-02,7.894200e-02,9.734600e-02, & - &1.036800e-01,1.018000e-02,1.041000e-02,5.440900e-02,8.085600e-02, & - &9.974000e-02,1.075100e-01,1.046700e-02,1.068900e-02,5.569300e-02, & - &8.257900e-02,1.018800e-01,1.109300e-01,1.085400e-02,1.106700e-02, & - &5.677500e-02,8.402800e-02,1.036800e-01,1.138900e-01,1.134300e-02, & - &1.154900e-02,5.771400e-02,8.529200e-02,1.051100e-01,1.165200e-01, & - &8.377800e-03,8.630900e-03,4.649800e-02,6.916900e-02,8.492600e-02, & - &8.947900e-02,8.566700e-03,8.810100e-03,4.775700e-02,7.091200e-02, & - &8.713000e-02,9.262200e-02,8.858800e-03,9.089300e-03,4.886400e-02, & - &7.237900e-02,8.905400e-02,9.541100e-02,9.239700e-03,9.459900e-03, & - &4.982900e-02,7.369200e-02,9.068600e-02,9.779400e-02,9.672800e-03, & - &9.884300e-03,5.071100e-02,7.486800e-02,9.200000e-02,9.967300e-02, & - &7.003200e-03,7.280000e-03,4.049300e-02,6.008700e-02,7.365400e-02, & - &7.684700e-02,7.204600e-03,7.465700e-03,4.155900e-02,6.155200e-02, & - &7.559100e-02,7.952200e-02,7.495100e-03,7.740800e-03,4.252500e-02, & - &6.287200e-02,7.730300e-02,8.185000e-02,7.837400e-03,8.073100e-03, & - &4.343100e-02,6.406600e-02,7.869700e-02,8.356400e-02,8.202800e-03, & - &8.426100e-03,4.425600e-02,6.500500e-02,7.959800e-02,8.443000e-02, & - &5.851800e-03,6.153100e-03,3.495900e-02,5.174100e-02,6.346600e-02, & - &6.560500e-02,6.057500e-03,6.341700e-03,3.587400e-02,5.301300e-02, & - &6.515100e-02,6.782300e-02,6.323200e-03,6.595100e-03,3.676100e-02, & - &5.416800e-02,6.656000e-02,6.949600e-02,6.622100e-03,6.878200e-03, & - &3.756700e-02,5.510000e-02,6.747800e-02,7.035800e-02,6.934700e-03, & - &7.177800e-03,3.825600e-02,5.564100e-02,6.781800e-02,7.053700e-02, & - &4.888000e-03,5.205500e-03,2.996000e-02,4.425500e-02,5.434200e-02, & - &5.568400e-02,5.083600e-03,5.388400e-03,3.078000e-02,4.535900e-02, & - &5.570600e-02,5.729700e-02,5.319400e-03,5.612600e-03,3.154300e-02, & - &4.623800e-02,5.663200e-02,5.824200e-02,5.579600e-03,5.855800e-03, & - &3.219000e-02,4.679600e-02,5.706400e-02,5.857900e-02,5.842200e-03, & - &6.108300e-03,3.270100e-02,4.706600e-02,5.710500e-02,5.848300e-02, & - &4.083000e-03,4.400300e-03,2.553600e-02,3.763500e-02,4.618800e-02, & - &4.683000e-02,4.262100e-03,4.573900e-03,2.622500e-02,3.847300e-02, & - &4.711300e-02,4.782100e-02,4.470100e-03,4.772600e-03,2.682700e-02, & - &3.902800e-02,4.762700e-02,4.831000e-02,4.683600e-03,4.974200e-03, & - &2.730600e-02,3.935500e-02,4.780100e-02,4.840800e-02,4.910100e-03, & - &5.190800e-03,2.767100e-02,3.954700e-02,4.773800e-02,4.819600e-02, & - &3.418300e-03,3.728100e-03,2.163500e-02,3.176700e-02,3.891000e-02, & - &3.903500e-02,3.575500e-03,3.884700e-03,2.217200e-02,3.232100e-02, & - &3.946800e-02,3.963000e-02,3.747000e-03,4.048900e-03,2.262100e-02, & - &3.267600e-02,3.975500e-02,3.989100e-02,3.925700e-03,4.220300e-03, & - &2.299700e-02,3.292400e-02,3.982000e-02,3.986800e-02,4.124800e-03, & - &4.410700e-03,2.323900e-02,3.308600e-02,3.973400e-02,3.962200e-02, & - &2.860600e-03,3.159600e-03,1.819100e-02,2.660100e-02,3.251500e-02, & - &3.231700e-02,2.992800e-03,3.293000e-03,1.859800e-02,2.697000e-02, & - &3.286600e-02,3.269900e-02,3.136900e-03,3.430900e-03,1.896800e-02, & - &2.724700e-02,3.303500e-02,3.283400e-02,3.291100e-03,3.580700e-03, & - &1.924200e-02,2.745500e-02,3.306000e-02,3.275400e-02,3.466000e-03, & - &3.748600e-03,1.940200e-02,2.757700e-02,3.298800e-02,3.250500e-02, & - &2.395800e-03,2.678600e-03,1.522100e-02,2.216300e-02,2.703900e-02, & - &2.667500e-02,2.508900e-03,2.792200e-03,1.555500e-02,2.244400e-02, & - &2.726800e-02,2.691500e-02,2.633000e-03,2.912500e-03,1.584200e-02, & - &2.267500e-02,2.737200e-02,2.696800e-02,2.769400e-03,3.046400e-03, & - &1.603000e-02,2.284300e-02,2.739200e-02,2.685600e-02,2.923200e-03, & - &3.195600e-03,1.614500e-02,2.290600e-02,2.733100e-02,2.661000e-02, & - &2.004200e-03,2.264000e-03,1.269000e-02,1.840100e-02,2.240400e-02, & - &2.195900e-02,2.102300e-03,2.361700e-03,1.296500e-02,1.863700e-02, & - &2.256400e-02,2.210900e-02,2.210300e-03,2.468500e-03,1.317300e-02, & - &1.883300e-02,2.264500e-02,2.210800e-02,2.330300e-03,2.587100e-03, & - &1.331200e-02,1.894000e-02,2.266300e-02,2.198500e-02,2.466100e-03, & - &2.721800e-03,1.339900e-02,1.897200e-02,2.260400e-02,2.176000e-02, & - &1.676200e-03,1.909000e-03,1.055900e-02,1.525200e-02,1.852100e-02, & - &1.804200e-02,1.761400e-03,1.993200e-03,1.077000e-02,1.545500e-02, & - &1.864700e-02,1.812800e-02,1.856400e-03,2.089000e-03,1.092700e-02, & - &1.559800e-02,1.871600e-02,1.809700e-02,1.961800e-03,2.195100e-03, & - &1.102900e-02,1.566900e-02,1.872800e-02,1.797100e-02,2.078800e-03, & - &2.313900e-03,1.109400e-02,1.568500e-02,1.865600e-02,1.776500e-02/ - data absb(361:720,4) / & - &1.402500e-03,1.606700e-03,8.767600e-03,1.263200e-02,1.529500e-02, & - &1.480800e-02,1.476700e-03,1.681000e-03,8.928500e-03,1.279200e-02, & - &1.539800e-02,1.484900e-02,1.560000e-03,1.766400e-03,9.045100e-03, & - &1.289300e-02,1.545800e-02,1.480300e-02,1.651800e-03,1.861300e-03, & - &9.121800e-03,1.294500e-02,1.544900e-02,1.468200e-02,1.750300e-03, & - &1.962200e-03,9.178800e-03,1.295400e-02,1.537800e-02,1.449600e-02, & - &1.174300e-03,1.351500e-03,7.268000e-03,1.045300e-02,1.262400e-02, & - &1.214300e-02,1.239700e-03,1.418700e-03,7.388400e-03,1.057200e-02, & - &1.271300e-02,1.215800e-02,1.312100e-03,1.494400e-03,7.476900e-03, & - &1.064700e-02,1.274800e-02,1.210100e-02,1.390400e-03,1.577400e-03, & - &7.540100e-03,1.068400e-02,1.272800e-02,1.198600e-02,1.473600e-03, & - &1.662500e-03,7.592500e-03,1.068300e-02,1.266200e-02,1.182300e-02, & - &9.840199e-04,1.137300e-03,6.016200e-03,8.639400e-03,1.041900e-02, & - &9.956100e-03,1.041100e-03,1.197200e-03,6.108600e-03,8.728700e-03, & - &1.048300e-02,9.951900e-03,1.102900e-03,1.263300e-03,6.178100e-03, & - &8.782700e-03,1.050100e-02,9.891800e-03,1.169500e-03,1.334400e-03, & - &6.234100e-03,8.808300e-03,1.047800e-02,9.785700e-03,1.240900e-03, & - &1.407900e-03,6.282200e-03,8.807900e-03,1.041800e-02,9.645300e-03, & - &8.250200e-04,9.575100e-04,4.975800e-03,7.133800e-03,8.593800e-03, & - &8.159900e-03,8.745000e-04,1.010500e-03,5.048600e-03,7.199600e-03, & - &8.636900e-03,8.144100e-03,9.266400e-04,1.067400e-03,5.107000e-03, & - &7.239000e-03,8.645700e-03,8.084900e-03,9.842600e-04,1.128700e-03, & - &5.158700e-03,7.259300e-03,8.621800e-03,7.990700e-03,1.046000e-03, & - &1.193200e-03,5.206600e-03,7.261200e-03,8.569400e-03,7.870500e-03, & - &6.923600e-04,8.067400e-04,4.113300e-03,5.886300e-03,7.081500e-03, & - &6.690000e-03,7.344100e-04,8.527000e-04,4.173500e-03,5.934900e-03, & - &7.112200e-03,6.668300e-03,7.793000e-04,9.024700e-04,4.225200e-03, & - &5.966200e-03,7.113600e-03,6.614000e-03,8.290500e-04,9.549000e-04, & - &4.274600e-03,5.983500e-03,7.089800e-03,6.532800e-03,8.828800e-04, & - &1.012100e-03,4.316800e-03,5.989800e-03,7.047500e-03,6.430700e-03, & - &5.810900e-04,6.799200e-04,3.400700e-03,4.854600e-03,5.833800e-03, & - &5.485700e-03,6.167200e-04,7.195300e-04,3.453100e-03,4.892100e-03, & - &5.853800e-03,5.462300e-03,6.556400e-04,7.623500e-04,3.500100e-03, & - &4.920000e-03,5.850800e-03,5.413600e-03,6.991600e-04,8.083700e-04, & - &3.544500e-03,4.936100e-03,5.831500e-03,5.344800e-03,7.458800e-04, & - &8.590700e-04,3.581400e-03,4.947000e-03,5.797200e-03,5.257500e-03, & - &4.877300e-04,5.729800e-04,2.814200e-03,4.003400e-03,4.804600e-03, & - &4.501800e-03,5.179000e-04,6.068700e-04,2.859200e-03,4.035200e-03, & - &4.816300e-03,4.478500e-03,5.525900e-04,6.442000e-04,2.902600e-03, & - &4.059600e-03,4.812800e-03,4.437000e-03,5.902700e-04,6.847300e-04, & - &2.939600e-03,4.077900e-03,4.797200e-03,4.378900e-03,6.310900e-04, & - &7.299600e-04,2.973000e-03,4.089200e-03,4.770300e-03,4.306300e-03, & - &4.094300e-04,4.826000e-04,2.330700e-03,3.302600e-03,3.955300e-03, & - &3.695100e-03,4.358500e-04,5.119400e-04,2.370600e-03,3.330700e-03, & - &3.962700e-03,3.675100e-03,4.664400e-04,5.447100e-04,2.407500e-03, & - &3.354400e-03,3.960800e-03,3.638800e-03,4.991800e-04,5.804500e-04, & - &2.439500e-03,3.372500e-03,3.948500e-03,3.590000e-03,5.345800e-04, & - &6.206900e-04,2.471000e-03,3.383900e-03,3.929200e-03,3.529900e-03, & - &3.441000e-04,4.065400e-04,1.931700e-03,2.726900e-03,3.256000e-03, & - &3.035700e-03,3.678000e-04,4.323100e-04,1.966900e-03,2.752400e-03, & - &3.262200e-03,3.017100e-03,3.942200e-04,4.610300e-04,1.997900e-03, & - &2.774900e-03,3.261700e-03,2.986900e-03,4.227400e-04,4.928900e-04, & - &2.026800e-03,2.791000e-03,3.253300e-03,2.946100e-03,4.535600e-04, & - &5.282600e-04,2.055800e-03,2.802600e-03,3.238800e-03,2.897100e-03, & - &2.890700e-04,3.419700e-04,1.601700e-03,2.252700e-03,2.681600e-03, & - &2.493400e-03,3.099900e-04,3.645900e-04,1.631400e-03,2.277000e-03, & - &2.688100e-03,2.477400e-03,3.329200e-04,3.898900e-04,1.658700e-03, & - &2.296500e-03,2.688200e-03,2.451600e-03,3.575800e-04,4.181700e-04, & - &1.685100e-03,2.311800e-03,2.683700e-03,2.418300e-03,3.844300e-04, & - &4.489100e-04,1.711700e-03,2.324100e-03,2.673400e-03,2.378900e-03, & - &2.416300e-04,2.861300e-04,1.326200e-03,1.861000e-03,2.209200e-03, & - &2.049200e-03,2.598000e-04,3.059000e-04,1.351800e-03,1.882900e-03, & - &2.216100e-03,2.036400e-03,2.794800e-04,3.280600e-04,1.376200e-03, & - &1.900000e-03,2.218600e-03,2.014900e-03,3.006600e-04,3.526800e-04, & - &1.400400e-03,1.914900e-03,2.216500e-03,1.988900e-03,3.240100e-04, & - &3.794200e-04,1.425000e-03,1.927800e-03,2.209900e-03,1.957800e-03, & - &2.006600e-04,2.379700e-04,1.096200e-03,1.536300e-03,1.820200e-03, & - &1.685100e-03,2.162300e-04,2.549800e-04,1.118800e-03,1.555700e-03, & - &1.827900e-03,1.674900e-03,2.330300e-04,2.742300e-04,1.140700e-03, & - &1.571800e-03,1.832500e-03,1.659100e-03,2.510200e-04,2.953400e-04, & - &1.162600e-03,1.586300e-03,1.832400e-03,1.638200e-03,2.710700e-04, & - &3.183900e-04,1.185000e-03,1.599000e-03,1.829500e-03,1.613800e-03/ - data absb(721:1080,4) / & - &1.648900e-04,1.959800e-04,9.033800e-04,1.266000e-03,1.499200e-03, & - &1.385800e-03,1.780000e-04,2.103500e-04,9.231900e-04,1.283500e-03, & - &1.507800e-03,1.378900e-03,1.921300e-04,2.267000e-04,9.428600e-04, & - &1.298700e-03,1.513800e-03,1.367300e-03,2.073100e-04,2.446700e-04, & - &9.626000e-04,1.312900e-03,1.515900e-03,1.352000e-03,2.242600e-04, & - &2.643300e-04,9.831700e-04,1.325500e-03,1.516000e-03,1.333000e-03, & - &1.354500e-04,1.613300e-04,7.442300e-04,1.043000e-03,1.234500e-03, & - &1.140000e-03,1.464700e-04,1.734600e-04,7.617600e-04,1.059000e-03, & - &1.244000e-03,1.135700e-03,1.583400e-04,1.873100e-04,7.793300e-04, & - &1.073100e-03,1.250500e-03,1.127500e-03,1.711200e-04,2.025400e-04, & - &7.970900e-04,1.086600e-03,1.254200e-03,1.116300e-03,1.854300e-04, & - &2.193200e-04,8.156700e-04,1.098900e-03,1.256200e-03,1.101400e-03, & - &1.112800e-04,1.327900e-04,6.130800e-04,8.596000e-04,1.017100e-03, & - &9.383100e-04,1.205400e-04,1.430500e-04,6.283800e-04,8.739400e-04, & - &1.026400e-03,9.363500e-04,1.305100e-04,1.548000e-04,6.440800e-04, & - &8.868800e-04,1.033200e-03,9.307800e-04,1.412600e-04,1.677400e-04, & - &6.599400e-04,8.994600e-04,1.037800e-03,9.226800e-04,1.533800e-04, & - &1.820900e-04,6.767800e-04,9.112300e-04,1.041300e-03,9.113700e-04, & - &9.070500e-05,1.085200e-04,5.035500e-04,7.068100e-04,8.368400e-04, & - &7.709100e-04,9.834800e-05,1.170600e-04,5.169700e-04,7.200900e-04, & - &8.460100e-04,7.700400e-04,1.067100e-04,1.268900e-04,5.308600e-04, & - &7.319100e-04,8.529800e-04,7.666600e-04,1.157000e-04,1.378100e-04, & - &5.450700e-04,7.435500e-04,8.583100e-04,7.609300e-04,1.257800e-04, & - &1.499000e-04,5.600200e-04,7.547300e-04,8.628400e-04,7.524500e-04, & - &7.381700e-05,8.854900e-05,4.132500e-04,5.810600e-04,6.883000e-04, & - &6.326900e-04,8.015800e-05,9.568000e-05,4.250100e-04,5.929300e-04, & - &6.970000e-04,6.331000e-04,8.711600e-05,1.038400e-04,4.372200e-04, & - &6.036900e-04,7.040100e-04,6.312200e-04,9.461000e-05,1.130300e-04, & - &4.497600e-04,6.144800e-04,7.097700e-04,6.272600e-04,1.030500e-04, & - &1.232400e-04,4.631100e-04,6.247500e-04,7.147700e-04,6.210100e-04, & - &6.004700e-05,7.221000e-05,3.390000e-04,4.774900e-04,5.659600e-04, & - &5.192600e-04,6.530700e-05,7.818300e-05,3.492700e-04,4.880000e-04, & - &5.740400e-04,5.204900e-04,7.108300e-05,8.494800e-05,3.599100e-04, & - &4.977600e-04,5.809200e-04,5.196800e-04,7.733900e-05,9.266800e-05, & - &3.709800e-04,5.075900e-04,5.867600e-04,5.171700e-04,8.439100e-05, & - &1.012800e-04,3.828400e-04,5.171000e-04,5.920000e-04,5.126500e-04, & - &4.861100e-05,5.860100e-05,2.774900e-04,3.914500e-04,4.646400e-04, & - &4.258400e-04,5.292500e-05,6.356200e-05,2.863700e-04,4.009400e-04, & - &4.722600e-04,4.277300e-04,5.770400e-05,6.914300e-05,2.956500e-04, & - &4.097600e-04,4.788200e-04,4.278400e-04,6.289000e-05,7.555500e-05, & - &3.053100e-04,4.186100e-04,4.845400e-04,4.263200e-04,6.873300e-05, & - &8.275400e-05,3.157400e-04,4.272900e-04,4.898500e-04,4.232400e-04, & - &3.925500e-05,4.742800e-05,2.268200e-04,3.205300e-04,3.811500e-04, & - &3.490400e-04,4.275600e-05,5.151800e-05,2.344600e-04,3.290000e-04, & - &3.881800e-04,3.512600e-04,4.670200e-05,5.611800e-05,2.425400e-04, & - &3.369600e-04,3.944500e-04,3.520400e-04,5.098800e-05,6.141400e-05, & - &2.509300e-04,3.448300e-04,3.998400e-04,3.515000e-04,5.581800e-05, & - &6.741300e-05,2.600400e-04,3.527100e-04,4.050800e-04,3.495500e-04, & - &3.167700e-05,3.836000e-05,1.852300e-04,2.622200e-04,3.123800e-04, & - &2.859200e-04,3.452200e-05,4.173100e-05,1.919200e-04,2.697100e-04, & - &3.188300e-04,2.886000e-04,3.777500e-05,4.552300e-05,1.988200e-04, & - &2.768000e-04,3.246900e-04,2.897900e-04,4.130600e-05,4.987200e-05, & - &2.060800e-04,2.838400e-04,3.298400e-04,2.898400e-04,4.529200e-05, & - &5.486400e-05,2.139500e-04,2.908800e-04,3.347300e-04,2.887600e-04, & - &2.550100e-05,3.094900e-05,1.510600e-04,2.142200e-04,2.557000e-04, & - &2.339600e-04,2.779500e-05,3.369800e-05,1.568100e-04,2.208300e-04, & - &2.615300e-04,2.368300e-04,3.047300e-05,3.683000e-05,1.627100e-04, & - &2.270400e-04,2.669500e-04,2.384200e-04,3.337600e-05,4.038500e-05, & - &1.689900e-04,2.333200e-04,2.717800e-04,2.389400e-04,3.663700e-05, & - &4.450700e-05,1.758500e-04,2.396200e-04,2.763800e-04,2.385500e-04, & - &2.045000e-05,2.487100e-05,1.228500e-04,1.745800e-04,2.088300e-04, & - &1.909700e-04,2.228600e-05,2.708600e-05,1.278400e-04,1.804200e-04, & - &2.140400e-04,1.939500e-04,2.445400e-05,2.964900e-05,1.328600e-04, & - &1.859100e-04,2.191000e-04,1.958100e-04,2.684400e-05,3.254500e-05, & - &1.382500e-04,1.914300e-04,2.235800e-04,1.967300e-04,2.948400e-05, & - &3.591800e-05,1.441100e-04,1.970000e-04,2.278100e-04,1.968400e-04, & - &1.639500e-05,1.998700e-05,9.978700e-05,1.421400e-04,1.703200e-04, & - &1.558200e-04,1.786000e-05,2.175300e-05,1.041300e-04,1.472500e-04, & - &1.749900e-04,1.588400e-04,1.960000e-05,2.383400e-05,1.083900e-04, & - &1.520700e-04,1.795700e-04,1.608300e-04,2.156700e-05,2.620800e-05, & - &1.129900e-04,1.569000e-04,1.837000e-04,1.619900e-04,2.370400e-05, & - &2.894600e-05,1.179700e-04,1.617800e-04,1.875300e-04,1.624600e-04/ - data absb(1081:1410,4) / & - &1.313900e-05,1.606200e-05,8.097600e-05,1.156200e-04,1.387600e-04, & - &1.271400e-04,1.430400e-05,1.745500e-05,8.471000e-05,1.200400e-04, & - &1.428800e-04,1.300300e-04,1.569000e-05,1.913600e-05,8.834800e-05, & - &1.242700e-04,1.470000e-04,1.321300e-04,1.730400e-05,2.108000e-05, & - &9.222200e-05,1.284400e-04,1.507200e-04,1.334900e-04,1.904500e-05, & - &2.329600e-05,9.647300e-05,1.327200e-04,1.542000e-04,1.342400e-04, & - &1.055500e-05,1.293700e-05,6.569500e-05,9.404300e-05,1.130200e-04, & - &1.034500e-04,1.147700e-05,1.403100e-05,6.889300e-05,9.781000e-05, & - &1.165900e-04,1.061800e-04,1.258100e-05,1.538500e-05,7.202200e-05, & - &1.015200e-04,1.202300e-04,1.082500e-04,1.390000e-05,1.697900e-05, & - &7.529800e-05,1.051300e-04,1.236200e-04,1.096500e-04,1.533300e-05, & - &1.878300e-05,7.891800e-05,1.088800e-04,1.267700e-04,1.105700e-04, & - &8.492100e-06,1.042800e-05,5.329200e-05,7.644800e-05,9.198800e-05, & - &8.402500e-05,9.212700e-06,1.128500e-05,5.600500e-05,7.965000e-05, & - &9.506600e-05,8.653900e-05,1.009300e-05,1.237400e-05,5.869500e-05, & - &8.289100e-05,9.827400e-05,8.850900e-05,1.116500e-05,1.367500e-05, & - &6.146100e-05,8.602800e-05,1.013200e-04,8.992600e-05,1.234400e-05, & - &1.514900e-05,6.453300e-05,8.929400e-05,1.041600e-04,9.088700e-05, & - &6.843000e-06,8.409000e-06,4.319300e-05,6.207300e-05,7.481500e-05, & - &6.821600e-05,7.394200e-06,9.079000e-06,4.549200e-05,6.481800e-05, & - &7.747300e-05,7.054000e-05,8.096200e-06,9.945500e-06,4.780100e-05, & - &6.763800e-05,8.024100e-05,7.236600e-05,8.953200e-06,1.099600e-05, & - &5.013600e-05,7.035200e-05,8.298800e-05,7.373800e-05,9.925400e-06, & - &1.220600e-05,5.272200e-05,7.315400e-05,8.550200e-05,7.472300e-05, & - &5.527500e-06,6.782600e-06,3.499200e-05,5.038700e-05,6.079500e-05, & - &5.537900e-05,5.936000e-06,7.307000e-06,3.690400e-05,5.268100e-05, & - &6.307000e-05,5.747500e-05,6.491600e-06,7.987600e-06,3.888500e-05, & - &5.512300e-05,6.544500e-05,5.919400e-05,7.172100e-06,8.831400e-06, & - &4.085600e-05,5.746500e-05,6.787500e-05,6.053000e-05,7.969500e-06, & - &9.822500e-06,4.303100e-05,5.987000e-05,7.011800e-05,6.152000e-05, & - &4.484100e-06,5.485500e-06,2.837000e-05,4.091600e-05,4.940100e-05, & - &4.476400e-05,4.780500e-06,5.896500e-06,2.996200e-05,4.283200e-05, & - &5.135000e-05,4.657500e-05,5.217500e-06,6.430300e-06,3.164600e-05, & - &4.492100e-05,5.337700e-05,4.810100e-05,5.759600e-06,7.107800e-06, & - &3.331300e-05,4.695100e-05,5.551800e-05,4.929900e-05,6.412100e-06, & - &7.921400e-06,3.514500e-05,4.900500e-05,5.749700e-05,5.021600e-05, & - &3.650200e-06,4.445200e-06,2.300400e-05,3.322500e-05,4.013100e-05, & - &3.607600e-05,3.858400e-06,4.763800e-06,2.432200e-05,3.482000e-05, & - &4.179800e-05,3.760800e-05,4.197000e-06,5.182400e-06,2.574600e-05, & - &3.659400e-05,4.352500e-05,3.892100e-05,4.629600e-06,5.723800e-06, & - &2.717000e-05,3.835400e-05,4.538600e-05,3.995400e-05,5.159600e-06, & - &6.389700e-06,2.870300e-05,4.010300e-05,4.713000e-05,4.074800e-05, & - &2.979800e-06,3.609700e-06,1.864500e-05,2.695800e-05,3.256500e-05, & - &2.904900e-05,3.120300e-06,3.850300e-06,1.972800e-05,2.828500e-05, & - &3.399700e-05,3.036200e-05,3.377000e-06,4.176400e-06,2.092900e-05, & - &2.978200e-05,3.546800e-05,3.148000e-05,3.719700e-06,4.607300e-06, & - &2.213700e-05,3.129900e-05,3.706400e-05,3.237300e-05,4.147600e-06, & - &5.148100e-06,2.342000e-05,3.279200e-05,3.859000e-05,3.307000e-05, & - &2.438000e-06,2.937100e-06,1.510100e-05,2.184900e-05,2.638400e-05, & - &2.337800e-05,2.528300e-06,3.113100e-06,1.599000e-05,2.296100e-05, & - &2.762800e-05,2.450100e-05,2.717300e-06,3.365900e-06,1.699500e-05, & - &2.420800e-05,2.887600e-05,2.544300e-05,2.988200e-06,3.707300e-06, & - &1.801800e-05,2.551600e-05,3.023500e-05,2.622000e-05,3.330900e-06, & - &4.142900e-06,1.909400e-05,2.679400e-05,3.157500e-05,2.682500e-05, & - &1.999100e-06,2.396900e-06,1.223500e-05,1.771300e-05,2.138000e-05, & - &1.881900e-05,2.055200e-06,2.521700e-06,1.296900e-05,1.864100e-05, & - &2.245000e-05,1.975400e-05,2.191200e-06,2.718400e-06,1.380300e-05, & - &1.967800e-05,2.350100e-05,2.055500e-05,2.404500e-06,2.986900e-06, & - &1.466800e-05,2.079900e-05,2.465700e-05,2.121600e-05,2.677900e-06, & - &3.336900e-06,1.557000e-05,2.189300e-05,2.582400e-05,2.173000e-05, & - &1.643800e-06,1.970100e-06,1.001000e-05,1.448700e-05,1.747000e-05, & - &1.523400e-05,1.686900e-06,2.068300e-06,1.062700e-05,1.527200e-05, & - &1.838100e-05,1.597900e-05,1.794700e-06,2.229400e-06,1.133200e-05, & - &1.615500e-05,1.928600e-05,1.662200e-05,1.969900e-06,2.451600e-06, & - &1.206300e-05,1.710800e-05,2.026800e-05,1.713400e-05,2.196700e-06, & - &2.743300e-06,1.283100e-05,1.804300e-05,2.127400e-05,1.752400e-05/ - data absb(1:360,5) / & - &2.180700e-02,2.202100e-02,1.004400e-01,1.494000e-01,1.900400e-01, & - &2.108400e-01,2.232500e-02,2.254300e-02,1.022700e-01,1.517000e-01, & - &1.932400e-01,2.168200e-01,2.286600e-02,2.308200e-02,1.040000e-01, & - &1.540600e-01,1.962500e-01,2.220900e-01,2.340700e-02,2.363000e-02, & - &1.054200e-01,1.563400e-01,1.988200e-01,2.269100e-01,2.396900e-02, & - &2.419800e-02,1.067300e-01,1.583200e-01,2.008400e-01,2.312300e-01, & - &1.858400e-02,1.880100e-02,9.049200e-02,1.338300e-01,1.698900e-01, & - &1.869000e-01,1.904300e-02,1.926000e-02,9.236300e-02,1.365000e-01, & - &1.733800e-01,1.921500e-01,1.950900e-02,1.972700e-02,9.403600e-02, & - &1.391100e-01,1.765200e-01,1.965300e-01,2.001200e-02,2.024000e-02, & - &9.554700e-02,1.415200e-01,1.790400e-01,2.004600e-01,2.060100e-02, & - &2.083100e-02,9.682500e-02,1.435400e-01,1.810500e-01,2.038100e-01, & - &1.576400e-02,1.598600e-02,8.080500e-02,1.193000e-01,1.508400e-01, & - &1.644200e-01,1.617600e-02,1.639800e-02,8.263000e-02,1.220500e-01, & - &1.543000e-01,1.688100e-01,1.661400e-02,1.684100e-02,8.426500e-02, & - &1.247000e-01,1.572200e-01,1.725800e-01,1.711900e-02,1.735300e-02, & - &8.571600e-02,1.269500e-01,1.596900e-01,1.758800e-01,1.771300e-02, & - &1.794700e-02,8.688400e-02,1.286700e-01,1.616800e-01,1.786400e-01, & - &1.333000e-02,1.355900e-02,7.152500e-02,1.057000e-01,1.329200e-01, & - &1.436000e-01,1.369300e-02,1.392400e-02,7.329100e-02,1.084000e-01, & - &1.361400e-01,1.474500e-01,1.411600e-02,1.435600e-02,7.480400e-02, & - &1.108400e-01,1.389200e-01,1.507800e-01,1.462700e-02,1.486900e-02, & - &7.606700e-02,1.127500e-01,1.413200e-01,1.537300e-01,1.518200e-02, & - &1.542200e-02,7.713700e-02,1.143200e-01,1.432500e-01,1.561800e-01, & - &1.122600e-02,1.147100e-02,6.286400e-02,9.297000e-02,1.162400e-01, & - &1.243500e-01,1.156700e-02,1.181300e-02,6.442700e-02,9.550500e-02, & - &1.192100e-01,1.277300e-01,1.199000e-02,1.223900e-02,6.577300e-02, & - &9.756600e-02,1.218300e-01,1.307600e-01,1.245900e-02,1.270900e-02, & - &6.690000e-02,9.929100e-02,1.240900e-01,1.333500e-01,1.294200e-02, & - &1.318800e-02,6.790200e-02,1.007700e-01,1.258600e-01,1.351300e-01, & - &9.427400e-03,9.696500e-03,5.480300e-02,8.115600e-02,1.009500e-01, & - &1.068900e-01,9.763600e-03,1.002900e-02,5.618000e-02,8.329200e-02, & - &1.036800e-01,1.099400e-01,1.015900e-02,1.042300e-02,5.735900e-02, & - &8.514200e-02,1.061200e-01,1.125600e-01,1.055700e-02,1.082300e-02, & - &5.840300e-02,8.670900e-02,1.080300e-01,1.143000e-01,1.097900e-02, & - &1.123700e-02,5.937600e-02,8.777400e-02,1.090300e-01,1.148300e-01, & - &7.909800e-03,8.211600e-03,4.741400e-02,7.021600e-02,8.716000e-02, & - &9.132200e-02,8.232600e-03,8.528800e-03,4.861000e-02,7.208700e-02, & - &8.965700e-02,9.391500e-02,8.566200e-03,8.861700e-03,4.966400e-02, & - &7.369100e-02,9.163600e-02,9.564600e-02,8.907400e-03,9.199500e-03, & - &5.059900e-02,7.478400e-02,9.270600e-02,9.628600e-02,9.277700e-03, & - &9.560300e-03,5.140400e-02,7.524800e-02,9.289000e-02,9.601500e-02, & - &6.640600e-03,6.973000e-03,4.076500e-02,6.039500e-02,7.489400e-02, & - &7.761500e-02,6.920700e-03,7.247700e-03,4.180200e-02,6.196500e-02, & - &7.690100e-02,7.938100e-02,7.206500e-03,7.532300e-03,4.268900e-02, & - &6.307100e-02,7.805200e-02,8.017700e-02,7.503300e-03,7.824500e-03, & - &4.340100e-02,6.358600e-02,7.842500e-02,8.020500e-02,7.820700e-03, & - &8.135300e-03,4.398600e-02,6.370400e-02,7.821100e-02,7.964400e-02, & - &5.568400e-03,5.917200e-03,3.485700e-02,5.159400e-02,6.385800e-02, & - &6.533100e-02,5.807900e-03,6.155700e-03,3.570800e-02,5.270500e-02, & - &6.513200e-02,6.628500e-02,6.050300e-03,6.400100e-03,3.635200e-02, & - &5.330000e-02,6.567500e-02,6.656900e-02,6.299800e-03,6.647700e-03, & - &3.685200e-02,5.351900e-02,6.572000e-02,6.635200e-02,6.574400e-03, & - &6.917200e-03,3.727100e-02,5.355400e-02,6.537100e-02,6.570800e-02, & - &4.679200e-03,5.033100e-03,2.965700e-02,4.371600e-02,5.393100e-02, & - &5.447200e-02,4.877800e-03,5.237100e-03,3.026100e-02,4.436600e-02, & - &5.460700e-02,5.493500e-02,5.077000e-03,5.442200e-03,3.071000e-02, & - &4.466500e-02,5.483600e-02,5.495900e-02,5.292700e-03,5.658600e-03, & - &3.109600e-02,4.479800e-02,5.472400e-02,5.462200e-02,5.543400e-03, & - &5.904200e-03,3.137900e-02,4.483800e-02,5.436000e-02,5.396900e-02, & - &3.925000e-03,4.278800e-03,2.501200e-02,3.668500e-02,4.511700e-02, & - &4.508100e-02,4.087300e-03,4.449100e-03,2.544300e-02,3.706500e-02, & - &4.548500e-02,4.529500e-02,4.258100e-03,4.628800e-03,2.580300e-02, & - &3.727100e-02,4.555900e-02,4.519900e-02,4.452200e-03,4.824700e-03, & - &2.608300e-02,3.739800e-02,4.540400e-02,4.481600e-02,4.679700e-03, & - &5.047800e-03,2.627300e-02,3.740900e-02,4.508800e-02,4.419600e-02, & - &3.285800e-03,3.629100e-03,2.094700e-02,3.058500e-02,3.752200e-02, & - &3.714900e-02,3.423600e-03,3.777500e-03,2.129600e-02,3.085500e-02, & - &3.772900e-02,3.722500e-02,3.575600e-03,3.940400e-03,2.157400e-02, & - &3.103400e-02,3.773100e-02,3.705900e-02,3.754700e-03,4.121700e-03, & - &2.177200e-02,3.113200e-02,3.758900e-02,3.667100e-02,3.959200e-03, & - &4.322000e-03,2.191100e-02,3.110500e-02,3.733600e-02,3.610500e-02/ - data absb(361:720,5) / & - &2.748500e-03,3.071500e-03,1.748500e-02,2.541100e-02,3.108800e-02, & - &3.052900e-02,2.869600e-03,3.206200e-03,1.776000e-02,2.563700e-02, & - &3.121200e-02,3.052200e-02,3.009300e-03,3.356200e-03,1.796500e-02, & - &2.579200e-02,3.120000e-02,3.032600e-02,3.171000e-03,3.520900e-03, & - &1.811200e-02,2.583400e-02,3.108400e-02,2.996100e-02,3.354100e-03, & - &3.704900e-03,1.822100e-02,2.578700e-02,3.086500e-02,2.946100e-02, & - &2.301900e-03,2.599100e-03,1.455800e-02,2.108300e-02,2.570500e-02, & - &2.504600e-02,2.409700e-03,2.721800e-03,1.476500e-02,2.127300e-02, & - &2.579100e-02,2.499000e-02,2.537400e-03,2.858200e-03,1.492000e-02, & - &2.137500e-02,2.578500e-02,2.478400e-02,2.683800e-03,3.009500e-03, & - &1.503600e-02,2.139100e-02,2.568100e-02,2.445300e-02,2.841600e-03, & - &3.173500e-03,1.512400e-02,2.134100e-02,2.546800e-02,2.401600e-02, & - &1.928400e-03,2.197900e-03,1.209200e-02,1.747400e-02,2.123300e-02, & - &2.052600e-02,2.027100e-03,2.311000e-03,1.224800e-02,1.761700e-02, & - &2.130500e-02,2.044500e-02,2.141300e-03,2.433900e-03,1.236800e-02, & - &1.768300e-02,2.129700e-02,2.024800e-02,2.270000e-03,2.570800e-03, & - &1.246100e-02,1.768300e-02,2.118700e-02,1.995400e-02,2.405000e-03, & - &2.713700e-03,1.254700e-02,1.764400e-02,2.099600e-02,1.957800e-02, & - &1.617700e-03,1.859800e-03,1.002500e-02,1.446400e-02,1.753300e-02, & - &1.681100e-02,1.707000e-03,1.961600e-03,1.014600e-02,1.456600e-02, & - &1.759500e-02,1.672000e-02,1.808400e-03,2.073100e-03,1.024000e-02, & - &1.461000e-02,1.756700e-02,1.653900e-02,1.919100e-03,2.193000e-03, & - &1.032600e-02,1.461000e-02,1.746200e-02,1.628200e-02,2.036400e-03, & - &2.320300e-03,1.040900e-02,1.458300e-02,1.729600e-02,1.596000e-02, & - &1.359300e-03,1.575600e-03,8.301700e-03,1.195700e-02,1.447900e-02, & - &1.377200e-02,1.440100e-03,1.667400e-03,8.396900e-03,1.203300e-02, & - &1.451500e-02,1.368100e-02,1.528600e-03,1.766700e-03,8.478400e-03, & - &1.206400e-02,1.447700e-02,1.351800e-02,1.623900e-03,1.872500e-03, & - &8.558700e-03,1.206400e-02,1.438100e-02,1.329400e-02,1.727000e-03, & - &1.986800e-03,8.643800e-03,1.205700e-02,1.423900e-02,1.302800e-02, & - &1.144500e-03,1.336100e-03,6.872000e-03,9.879100e-03,1.195000e-02, & - &1.128300e-02,1.215600e-03,1.418800e-03,6.949300e-03,9.934900e-03, & - &1.196400e-02,1.119500e-02,1.292200e-03,1.506100e-03,7.024800e-03, & - &9.958000e-03,1.192400e-02,1.105100e-02,1.374700e-03,1.600400e-03, & - &7.103300e-03,9.969600e-03,1.184000e-02,1.086400e-02,1.467900e-03, & - &1.704800e-03,7.190400e-03,9.972200e-03,1.172400e-02,1.064500e-02, & - &9.657100e-04,1.135500e-03,5.686700e-03,8.159800e-03,9.853900e-03, & - &9.250700e-03,1.026800e-03,1.208100e-03,5.756100e-03,8.201300e-03, & - &9.856000e-03,9.170100e-03,1.093200e-03,1.285700e-03,5.827300e-03, & - &8.224300e-03,9.817800e-03,9.048200e-03,1.166600e-03,1.371200e-03, & - &5.907500e-03,8.242800e-03,9.746500e-03,8.894600e-03,1.250900e-03, & - &1.466200e-03,5.989600e-03,8.255500e-03,9.657800e-03,8.712100e-03, & - &8.154900e-04,9.664700e-04,4.708700e-03,6.739000e-03,8.122200e-03, & - &7.586600e-03,8.680800e-04,1.030300e-03,4.774500e-03,6.773100e-03, & - &8.118800e-03,7.515300e-03,9.263500e-04,1.099700e-03,4.844700e-03, & - &6.799200e-03,8.082800e-03,7.416000e-03,9.929300e-04,1.177900e-03, & - &4.922200e-03,6.822600e-03,8.027900e-03,7.287700e-03,1.068600e-03, & - &1.264100e-03,4.995200e-03,6.844900e-03,7.962800e-03,7.136600e-03, & - &6.886600e-04,8.234700e-04,3.904500e-03,5.566000e-03,6.693400e-03, & - &6.225900e-03,7.345500e-04,8.798600e-04,3.966300e-03,5.598600e-03, & - &6.686600e-03,6.167700e-03,7.869800e-04,9.428200e-04,4.036100e-03, & - &5.628100e-03,6.658400e-03,6.084200e-03,8.470600e-04,1.014000e-03, & - &4.103600e-03,5.656800e-03,6.618500e-03,5.977200e-03,9.157900e-04, & - &1.092600e-03,4.172800e-03,5.681800e-03,6.569700e-03,5.851900e-03, & - &5.805800e-04,7.002300e-04,3.240300e-03,4.600500e-03,5.516600e-03, & - &5.111100e-03,6.212200e-04,7.504800e-04,3.300500e-03,4.633400e-03, & - &5.509900e-03,5.062600e-03,6.686500e-04,8.078800e-04,3.363000e-03, & - &4.665800e-03,5.490600e-03,4.992500e-03,7.227800e-04,8.722700e-04, & - &3.424600e-03,4.697000e-03,5.461900e-03,4.903300e-03,7.842000e-04, & - &9.441100e-04,3.491300e-03,4.722100e-03,5.429000e-03,4.799900e-03, & - &4.868000e-04,5.916800e-04,2.688600e-03,3.803100e-03,4.547200e-03, & - &4.200700e-03,5.228700e-04,6.364700e-04,2.744200e-03,3.836500e-03, & - &4.544200e-03,4.161300e-03,5.649400e-04,6.880100e-04,2.799000e-03, & - &3.871300e-03,4.532600e-03,4.103500e-03,6.134600e-04,7.459100e-04, & - &2.856400e-03,3.901700e-03,4.515000e-03,4.030300e-03,6.671400e-04, & - &8.105300e-04,2.920700e-03,3.929400e-03,4.495500e-03,3.947200e-03, & - &4.055600e-04,4.961800e-04,2.228400e-03,3.144000e-03,3.749200e-03, & - &3.455300e-03,4.371600e-04,5.357200e-04,2.277500e-03,3.177800e-03, & - &3.751400e-03,3.424500e-03,4.740300e-04,5.813200e-04,2.327000e-03, & - &3.212400e-03,3.746800e-03,3.378000e-03,5.165900e-04,6.328300e-04, & - &2.380100e-03,3.241200e-03,3.738000e-03,3.319300e-03,5.632000e-04, & - &6.900100e-04,2.440100e-03,3.271600e-03,3.726800e-03,3.253800e-03/ - data absb(721:1080,5) / & - &3.344500e-04,4.113800e-04,1.841400e-03,2.596000e-03,3.091800e-03, & - &2.844000e-03,3.613900e-04,4.454200e-04,1.885000e-03,2.629300e-03, & - &3.098400e-03,2.821600e-03,3.930200e-04,4.849500e-04,1.929100e-03, & - &2.662400e-03,3.099500e-03,2.786200e-03,4.296200e-04,5.300000e-04, & - &1.977800e-03,2.691300e-03,3.098500e-03,2.740800e-03,4.695700e-04, & - &5.798100e-04,2.032100e-03,2.722400e-03,3.093900e-03,2.689900e-03, & - &2.756500e-04,3.406900e-04,1.521500e-03,2.143900e-03,2.550200e-03, & - &2.341800e-03,2.986300e-04,3.700300e-04,1.559800e-03,2.175600e-03, & - &2.560000e-03,2.326400e-03,3.257700e-04,4.042200e-04,1.599500e-03, & - &2.206800e-03,2.565700e-03,2.299500e-03,3.570900e-04,4.433900e-04, & - &1.642900e-03,2.234900e-03,2.569500e-03,2.265000e-03,3.915000e-04, & - &4.869500e-04,1.692200e-03,2.265800e-03,2.569300e-03,2.225700e-03, & - &2.272400e-04,2.821100e-04,1.257400e-03,1.770900e-03,2.103800e-03, & - &1.929900e-03,2.468100e-04,3.073600e-04,1.291500e-03,1.800800e-03, & - &2.115500e-03,1.919400e-03,2.701400e-04,3.370400e-04,1.326800e-03, & - &1.829300e-03,2.124700e-03,1.899700e-03,2.969600e-04,3.710900e-04, & - &1.365800e-03,1.856400e-03,2.131600e-03,1.873900e-03,3.266100e-04, & - &4.091100e-04,1.409900e-03,1.886600e-03,2.134900e-03,1.844200e-03, & - &1.857900e-04,2.316000e-04,1.036500e-03,1.460300e-03,1.734300e-03, & - &1.586600e-03,2.022100e-04,2.529000e-04,1.066600e-03,1.487700e-03, & - &1.747600e-03,1.581000e-03,2.218700e-04,2.782600e-04,1.097500e-03, & - &1.514100e-03,1.758900e-03,1.566900e-03,2.446400e-04,3.074700e-04, & - &1.132000e-03,1.539900e-03,1.768200e-03,1.547900e-03,2.698200e-04, & - &3.402300e-04,1.171200e-03,1.568100e-03,1.774400e-03,1.525400e-03, & - &1.516600e-04,1.898000e-04,8.537900e-04,1.203500e-03,1.429300e-03, & - &1.303900e-03,1.654600e-04,2.077500e-04,8.802500e-04,1.228400e-03, & - &1.443200e-03,1.301400e-03,1.819400e-04,2.293000e-04,9.074100e-04, & - &1.252800e-03,1.456000e-03,1.291900e-03,2.012000e-04,2.542900e-04, & - &9.378700e-04,1.276600e-03,1.466400e-03,1.278200e-03,2.226300e-04, & - &2.825000e-04,9.723200e-04,1.302900e-03,1.474600e-03,1.261300e-03, & - &1.237400e-04,1.554600e-04,7.030700e-04,9.913699e-04,1.177400e-03, & - &1.071600e-03,1.353300e-04,1.705500e-04,7.262300e-04,1.014000e-03, & - &1.191700e-03,1.071300e-03,1.491400e-04,1.888200e-04,7.499800e-04, & - &1.036300e-03,1.204900e-03,1.065100e-03,1.653900e-04,2.102200e-04, & - &7.769300e-04,1.058400e-03,1.216000e-03,1.055600e-03,1.836100e-04, & - &2.344200e-04,8.071900e-04,1.082400e-03,1.225300e-03,1.043100e-03, & - &1.004500e-04,1.266400e-04,5.773400e-04,8.153600e-04,9.688400e-04, & - &8.797700e-04,1.100500e-04,1.391700e-04,5.977400e-04,8.358200e-04, & - &9.829201e-04,8.814900e-04,1.215300e-04,1.544500e-04,6.185300e-04, & - &8.560600e-04,9.961900e-04,8.782600e-04,1.351000e-04,1.725800e-04, & - &6.418600e-04,8.760100e-04,1.007500e-03,8.718700e-04,1.504300e-04, & - &1.931800e-04,6.682800e-04,8.976300e-04,1.017200e-03,8.629400e-04, & - &8.130500e-05,1.028400e-04,4.733600e-04,6.697600e-04,7.962600e-04, & - &7.218900e-04,8.919300e-05,1.131500e-04,4.911100e-04,6.879000e-04, & - &8.098000e-04,7.250500e-04,9.867600e-05,1.258300e-04,5.091300e-04, & - &7.061700e-04,8.225600e-04,7.241000e-04,1.099600e-04,1.411100e-04, & - &5.293700e-04,7.243600e-04,8.341000e-04,7.201900e-04,1.228200e-04, & - &1.585900e-04,5.523600e-04,7.437600e-04,8.440500e-04,7.141700e-04, & - &6.578600e-05,8.342000e-05,3.877900e-04,5.495700e-04,6.538600e-04, & - &5.920500e-04,7.223600e-05,9.193200e-05,4.033100e-04,5.660100e-04, & - &6.667700e-04,5.962800e-04,8.005000e-05,1.024200e-04,4.188300e-04, & - &5.823800e-04,6.788800e-04,5.968800e-04,8.940500e-05,1.152100e-04, & - &4.361400e-04,5.985300e-04,6.899700e-04,5.949500e-04,1.001800e-04, & - &1.300300e-04,4.561000e-04,6.157600e-04,6.997000e-04,5.910700e-04, & - &5.310400e-05,6.747600e-05,3.171100e-04,4.503000e-04,5.363400e-04, & - &4.852900e-04,5.831000e-05,7.444000e-05,3.305000e-04,4.647100e-04, & - &5.481400e-04,4.899400e-04,6.472100e-05,8.307000e-05,3.438800e-04, & - &4.794500e-04,5.594200e-04,4.917800e-04,7.244600e-05,9.371100e-05, & - &3.587900e-04,4.939700e-04,5.701000e-04,4.913000e-04,8.143500e-05, & - &1.062000e-04,3.760400e-04,5.093600e-04,5.797400e-04,4.892900e-04, & - &4.268600e-05,5.431400e-05,2.585300e-04,3.679900e-04,4.390800e-04, & - &3.968600e-04,4.683400e-05,5.995800e-05,2.701000e-04,3.805300e-04, & - &4.499200e-04,4.019400e-04,5.203100e-05,6.695600e-05,2.817400e-04, & - &3.938200e-04,4.602300e-04,4.046400e-04,5.834400e-05,7.568300e-05, & - &2.943700e-04,4.067400e-04,4.703900e-04,4.052800e-04,6.577400e-05, & - &8.610200e-05,3.090400e-04,4.202200e-04,4.795500e-04,4.044500e-04, & - &3.431300e-05,4.368700e-05,2.107100e-04,3.003500e-04,3.590200e-04, & - &3.243600e-04,3.759300e-05,4.825000e-05,2.205900e-04,3.112100e-04, & - &3.687500e-04,3.295600e-04,4.178500e-05,5.390600e-05,2.306200e-04, & - &3.229800e-04,3.781900e-04,3.328700e-04,4.690500e-05,6.099300e-05, & - &2.412800e-04,3.343800e-04,3.876300e-04,3.342800e-04,5.302000e-05, & - &6.964500e-05,2.536600e-04,3.462000e-04,3.962500e-04,3.344000e-04/ - data absb(1081:1410,5) / & - &2.758300e-05,3.511500e-05,1.715500e-04,2.448100e-04,2.931700e-04, & - &2.649800e-04,3.017000e-05,3.880000e-05,1.798600e-04,2.541800e-04, & - &3.018900e-04,2.702500e-04,3.352100e-05,4.333600e-05,1.885200e-04, & - &2.644700e-04,3.104300e-04,2.738700e-04,3.765700e-05,4.908400e-05, & - &1.975800e-04,2.744900e-04,3.189900e-04,2.758600e-04,4.265300e-05, & - &5.622600e-05,2.079900e-04,2.848400e-04,3.270300e-04,2.767600e-04, & - &2.221700e-05,2.827100e-05,1.396900e-04,1.994800e-04,2.391900e-04, & - &2.159700e-04,2.426600e-05,3.125600e-05,1.466700e-04,2.075400e-04, & - &2.469300e-04,2.209700e-04,2.694100e-05,3.491400e-05,1.541300e-04, & - &2.164000e-04,2.545700e-04,2.246100e-04,3.028500e-05,3.957500e-05, & - &1.618600e-04,2.253000e-04,2.623400e-04,2.269200e-04,3.438200e-05, & - &4.547100e-05,1.706700e-04,2.343500e-04,2.698600e-04,2.282500e-04, & - &1.790300e-05,2.277300e-05,1.136900e-04,1.624100e-04,1.949800e-04, & - &1.757300e-04,1.953600e-05,2.519200e-05,1.195400e-04,1.693700e-04, & - &2.018100e-04,1.803500e-04,2.166000e-05,2.814400e-05,1.260100e-04, & - &1.770000e-04,2.086600e-04,1.838700e-04,2.436400e-05,3.192900e-05, & - &1.326400e-04,1.848600e-04,2.156000e-04,1.863300e-04,2.771300e-05, & - &3.676700e-05,1.400700e-04,1.927300e-04,2.224900e-04,1.878600e-04, & - &1.441900e-05,1.833700e-05,9.247000e-05,1.321400e-04,1.586900e-04, & - &1.429000e-04,1.573200e-05,2.029200e-05,9.735500e-05,1.380800e-04, & - &1.647600e-04,1.471700e-04,1.740200e-05,2.266700e-05,1.029100e-04, & - &1.446000e-04,1.708300e-04,1.505400e-04,1.958100e-05,2.573000e-05, & - &1.085700e-04,1.515200e-04,1.769700e-04,1.530500e-04,2.230100e-05, & - &2.966600e-05,1.148400e-04,1.583200e-04,1.831900e-04,1.546800e-04, & - &1.160300e-05,1.475900e-05,7.515400e-05,1.074000e-04,1.290400e-04, & - &1.161800e-04,1.266700e-05,1.633300e-05,7.923500e-05,1.124800e-04, & - &1.343800e-04,1.200700e-04,1.397500e-05,1.824500e-05,8.393300e-05, & - &1.180000e-04,1.396000e-04,1.232900e-04,1.571800e-05,2.070800e-05, & - &8.880300e-05,1.240200e-04,1.450200e-04,1.257400e-04,1.791600e-05, & - &2.389500e-05,9.406900e-05,1.299500e-04,1.506100e-04,1.274900e-04, & - &9.355200e-06,1.191200e-05,6.110000e-05,8.731600e-05,1.049200e-04, & - &9.408000e-05,1.022300e-05,1.318000e-05,6.451900e-05,9.164800e-05, & - &1.096000e-04,9.747400e-05,1.126000e-05,1.472800e-05,6.848700e-05, & - &9.634600e-05,1.141000e-04,1.003100e-04,1.265300e-05,1.671400e-05, & - &7.268000e-05,1.015600e-04,1.188100e-04,1.025400e-04,1.442900e-05, & - &1.929900e-05,7.713700e-05,1.067000e-04,1.237800e-04,1.041700e-04, & - &7.547800e-06,9.623300e-06,4.965100e-05,7.096100e-05,8.528900e-05, & - &7.600500e-05,8.256000e-06,1.064500e-05,5.253500e-05,7.465100e-05, & - &8.933800e-05,7.887200e-05,9.084300e-06,1.189700e-05,5.587100e-05, & - &7.865400e-05,9.322000e-05,8.132000e-05,1.019300e-05,1.350100e-05, & - &5.944400e-05,8.311900e-05,9.732500e-05,8.326300e-05,1.162800e-05, & - &1.559900e-05,6.325200e-05,8.760600e-05,1.016900e-04,8.468300e-05, & - &6.090300e-06,7.771800e-06,4.031000e-05,5.761200e-05,6.924400e-05, & - &6.139700e-05,6.664100e-06,8.593000e-06,4.273600e-05,6.075500e-05, & - &7.274400e-05,6.379300e-05,7.329100e-06,9.604000e-06,4.552300e-05, & - &6.414600e-05,7.609700e-05,6.589200e-05,8.205900e-06,1.089700e-05, & - &4.858200e-05,6.795800e-05,7.961200e-05,6.757200e-05,9.359300e-06, & - &1.259600e-05,5.182600e-05,7.184900e-05,8.342600e-05,6.881600e-05, & - &4.916900e-06,6.276800e-06,3.269200e-05,4.672600e-05,5.617400e-05, & - &4.956100e-05,5.375800e-06,6.931300e-06,3.473000e-05,4.939900e-05, & - &5.917100e-05,5.156600e-05,5.913100e-06,7.747500e-06,3.705500e-05, & - &5.226100e-05,6.205600e-05,5.336200e-05,6.601600e-06,8.784300e-06, & - &3.966100e-05,5.549800e-05,6.505800e-05,5.481300e-05,7.524500e-06, & - &1.015900e-05,4.242000e-05,5.887000e-05,6.838400e-05,5.590900e-05, & - &3.976900e-06,5.077100e-06,2.652000e-05,3.790500e-05,4.556600e-05, & - &3.998800e-05,4.339500e-06,5.596400e-06,2.822200e-05,4.016100e-05, & - &4.812000e-05,4.168300e-05,4.776500e-06,6.257300e-06,3.016200e-05, & - &4.256700e-05,5.061200e-05,4.317400e-05,5.319100e-06,7.092400e-06, & - &3.237700e-05,4.531900e-05,5.317200e-05,4.442800e-05,6.058400e-06, & - &8.202800e-06,3.472700e-05,4.823200e-05,5.604200e-05,4.538100e-05, & - &3.262500e-06,4.171600e-06,2.174700e-05,3.105200e-05,3.732900e-05, & - &3.240900e-05,3.562200e-06,4.606200e-06,2.319100e-05,3.296600e-05, & - &3.948800e-05,3.377500e-05,3.926500e-06,5.160300e-06,2.485700e-05, & - &3.503900e-05,4.161000e-05,3.493600e-05,4.379600e-06,5.865100e-06, & - &2.675800e-05,3.740700e-05,4.384000e-05,3.591200e-05,5.000400e-06, & - &6.806400e-06,2.877800e-05,3.992000e-05,4.634400e-05,3.664500e-05/ - data absb(1:360,6) / & - &4.253500e-02,4.276200e-02,1.699800e-01,2.594300e-01,3.311800e-01, & - &3.675900e-01,4.368100e-02,4.390700e-02,1.709800e-01,2.616900e-01, & - &3.356700e-01,3.765600e-01,4.488100e-02,4.510600e-02,1.723500e-01, & - &2.633200e-01,3.384300e-01,3.833700e-01,4.609700e-02,4.631000e-02, & - &1.738100e-01,2.643800e-01,3.396900e-01,3.885500e-01,4.733900e-02, & - &4.753800e-02,1.751200e-01,2.649300e-01,3.399900e-01,3.926000e-01, & - &3.665300e-02,3.688300e-02,1.572900e-01,2.394900e-01,3.062200e-01, & - &3.356900e-01,3.764500e-02,3.787300e-02,1.590200e-01,2.421300e-01, & - &3.101800e-01,3.431300e-01,3.867400e-02,3.890200e-02,1.607200e-01, & - &2.439800e-01,3.125600e-01,3.492700e-01,3.971500e-02,3.992400e-02, & - &1.622800e-01,2.453900e-01,3.143100e-01,3.539500e-01,4.081900e-02, & - &4.102200e-02,1.634300e-01,2.465800e-01,3.153700e-01,3.572300e-01, & - &3.148900e-02,3.171700e-02,1.445900e-01,2.188600e-01,2.792900e-01, & - &3.033300e-01,3.232500e-02,3.255100e-02,1.465100e-01,2.215200e-01, & - &2.828300e-01,3.102600e-01,3.320100e-02,3.341900e-02,1.481900e-01, & - &2.237200e-01,2.857000e-01,3.158800e-01,3.410900e-02,3.431700e-02, & - &1.495700e-01,2.257400e-01,2.879200e-01,3.200300e-01,3.519600e-02, & - &3.540300e-02,1.507400e-01,2.275000e-01,2.893700e-01,3.230000e-01, & - &2.693700e-02,2.716400e-02,1.316200e-01,1.977700e-01,2.516400e-01, & - &2.723600e-01,2.765500e-02,2.788100e-02,1.334200e-01,2.006700e-01, & - &2.553700e-01,2.788000e-01,2.840400e-02,2.861500e-02,1.350300e-01, & - &2.032600e-01,2.585600e-01,2.838700e-01,2.927000e-02,2.947600e-02, & - &1.364000e-01,2.057400e-01,2.610500e-01,2.876400e-01,3.041700e-02, & - &3.062400e-02,1.376400e-01,2.079800e-01,2.629300e-01,2.904100e-01, & - &2.295300e-02,2.318000e-02,1.184500e-01,1.772100e-01,2.246000e-01, & - &2.422400e-01,2.355900e-02,2.378400e-02,1.202300e-01,1.803100e-01, & - &2.285200e-01,2.480500e-01,2.425200e-02,2.446200e-02,1.217400e-01, & - &1.832200e-01,2.318800e-01,2.525600e-01,2.516000e-02,2.536900e-02, & - &1.231700e-01,1.859500e-01,2.346100e-01,2.559500e-01,2.632600e-02, & - &2.653600e-02,1.244500e-01,1.881300e-01,2.368400e-01,2.584300e-01, & - &1.948200e-02,1.971600e-02,1.056000e-01,1.576400e-01,1.988500e-01, & - &2.133300e-01,2.002000e-02,2.024700e-02,1.072800e-01,1.608000e-01, & - &2.027800e-01,2.185200e-01,2.071800e-02,2.093300e-02,1.088100e-01, & - &1.638000e-01,2.061900e-01,2.225200e-01,2.165900e-02,2.187200e-02, & - &1.102100e-01,1.663300e-01,2.091200e-01,2.257000e-01,2.272300e-02, & - &2.293600e-02,1.115300e-01,1.684800e-01,2.114900e-01,2.281800e-01, & - &1.647400e-02,1.672600e-02,9.327800e-02,1.391100e-01,1.747000e-01, & - &1.860700e-01,1.698800e-02,1.722400e-02,9.491400e-02,1.422900e-01, & - &1.785500e-01,1.906000e-01,1.771900e-02,1.794300e-02,9.640200e-02, & - &1.450600e-01,1.820100e-01,1.942400e-01,1.860000e-02,1.882100e-02, & - &9.780900e-02,1.474700e-01,1.849500e-01,1.971600e-01,1.951100e-02, & - &1.973100e-02,9.919800e-02,1.495700e-01,1.872600e-01,1.988700e-01, & - &1.389100e-02,1.417300e-02,8.175500e-02,1.219600e-01,1.524900e-01, & - &1.610900e-01,1.443200e-02,1.469200e-02,8.331400e-02,1.248600e-01, & - &1.562200e-01,1.650800e-01,1.513900e-02,1.538500e-02,8.478300e-02, & - &1.274100e-01,1.595200e-01,1.683000e-01,1.591300e-02,1.615200e-02, & - &8.622300e-02,1.296600e-01,1.621400e-01,1.701400e-01,1.668500e-02, & - &1.691700e-02,8.764200e-02,1.313800e-01,1.635600e-01,1.701400e-01, & - &1.170200e-02,1.203200e-02,7.110500e-02,1.061300e-01,1.323500e-01, & - &1.385100e-01,1.224900e-02,1.255300e-02,7.259500e-02,1.087500e-01, & - &1.358100e-01,1.419300e-01,1.287900e-02,1.316800e-02,7.403200e-02, & - &1.110200e-01,1.386100e-01,1.439600e-01,1.353700e-02,1.381000e-02, & - &7.541600e-02,1.127300e-01,1.401200e-01,1.441900e-01,1.419000e-02, & - &1.445100e-02,7.668800e-02,1.135500e-01,1.402500e-01,1.430200e-01, & - &9.900100e-03,1.028500e-02,6.155200e-02,9.190300e-02,1.144600e-01, & - &1.185000e-01,1.040200e-02,1.076400e-02,6.292800e-02,9.412300e-02, & - &1.172900e-01,1.206600e-01,1.094500e-02,1.128700e-02,6.421900e-02, & - &9.574500e-02,1.188400e-01,1.211600e-01,1.150200e-02,1.182400e-02, & - &6.535200e-02,9.654300e-02,1.191200e-01,1.204300e-01,1.205700e-02, & - &1.236500e-02,6.630600e-02,9.669400e-02,1.185000e-01,1.188700e-01, & - &8.371200e-03,8.801400e-03,5.298700e-02,7.903600e-02,9.822900e-02, & - &1.002200e-01,8.808600e-03,9.223900e-03,5.415900e-02,8.056600e-02, & - &9.988900e-02,1.010400e-01,9.269700e-03,9.665900e-03,5.515200e-02, & - &8.137900e-02,1.003900e-01,1.007400e-01,9.732700e-03,1.011000e-02, & - &5.597200e-02,8.163500e-02,1.000900e-01,9.970200e-02,1.021300e-02, & - &1.057500e-02,5.662700e-02,8.163800e-02,9.923800e-02,9.809200e-02, & - &7.072700e-03,7.536100e-03,4.532100e-02,6.726000e-02,8.327900e-02, & - &8.364700e-02,7.442700e-03,7.898600e-03,4.618800e-02,6.809600e-02, & - &8.401900e-02,8.374700e-02,7.826900e-03,8.267400e-03,4.689200e-02, & - &6.845000e-02,8.401300e-02,8.314800e-02,8.218900e-03,8.644500e-03, & - &4.751000e-02,6.858300e-02,8.351200e-02,8.203900e-02,8.650600e-03, & - &9.063900e-03,4.797900e-02,6.858900e-02,8.268600e-02,8.053000e-02/ - data absb(361:720,6) / & - &5.964800e-03,6.450600e-03,3.840700e-02,5.660500e-02,6.984000e-02, & - &6.921800e-02,6.275300e-03,6.756700e-03,3.906100e-02,5.705700e-02, & - &7.009800e-02,6.900500e-02,6.597900e-03,7.069200e-03,3.961800e-02, & - &5.728300e-02,6.989000e-02,6.831200e-02,6.947200e-03,7.408900e-03, & - &4.007200e-02,5.741000e-02,6.937100e-02,6.724100e-02,7.345800e-03, & - &7.796800e-03,4.042400e-02,5.740700e-02,6.869000e-02,6.588300e-02, & - &5.027600e-03,5.519700e-03,3.234100e-02,4.730600e-02,5.815900e-02, & - &5.698700e-02,5.290500e-03,5.780800e-03,3.285600e-02,4.761000e-02, & - &5.818800e-02,5.664000e-02,5.572400e-03,6.059500e-03,3.330600e-02, & - &4.783100e-02,5.792800e-02,5.593900e-02,5.894600e-03,6.377000e-03, & - &3.365300e-02,4.793500e-02,5.750200e-02,5.495600e-02,6.257400e-03, & - &6.735500e-03,3.392800e-02,4.788700e-02,5.697000e-02,5.376200e-02, & - &4.234900e-03,4.717900e-03,2.711600e-02,3.940100e-02,4.822000e-02, & - &4.678200e-02,4.463400e-03,4.947000e-03,2.754300e-02,3.967400e-02, & - &4.816200e-02,4.638500e-02,4.720200e-03,5.207100e-03,2.788600e-02, & - &3.986900e-02,4.794100e-02,4.572200e-02,5.016000e-03,5.503900e-03, & - &2.816700e-02,3.993400e-02,4.761500e-02,4.484600e-02,5.348100e-03, & - &5.838000e-03,2.839400e-02,3.986000e-02,4.718400e-02,4.382400e-02, & - &3.567400e-03,4.028400e-03,2.267300e-02,3.277200e-02,3.987200e-02, & - &3.833200e-02,3.773400e-03,4.239800e-03,2.300800e-02,3.302800e-02, & - &3.981000e-02,3.793000e-02,4.009700e-03,4.484500e-03,2.328600e-02, & - &3.317500e-02,3.965400e-02,3.732400e-02,4.278800e-03,4.762700e-03, & - &2.351400e-02,3.319400e-02,3.939800e-02,3.657100e-02,4.575700e-03, & - &5.067600e-03,2.371900e-02,3.311800e-02,3.902000e-02,3.570800e-02, & - &3.011500e-03,3.441100e-03,1.891100e-02,2.724700e-02,3.294300e-02, & - &3.138200e-02,3.199400e-03,3.640700e-03,1.917900e-02,2.745500e-02, & - &3.291100e-02,3.100000e-02,3.414700e-03,3.868200e-03,1.940900e-02, & - &2.755200e-02,3.279800e-02,3.047200e-02,3.657900e-03,4.127000e-03, & - &1.960500e-02,2.755900e-02,3.257300e-02,2.983500e-02,3.916200e-03, & - &4.398700e-03,1.980900e-02,2.748800e-02,3.224000e-02,2.912000e-02, & - &2.548100e-03,2.944400e-03,1.574500e-02,2.263400e-02,2.722600e-02, & - &2.567700e-02,2.718800e-03,3.130700e-03,1.596600e-02,2.278600e-02, & - &2.722000e-02,2.533500e-02,2.914800e-03,3.343900e-03,1.616000e-02, & - &2.285500e-02,2.711900e-02,2.488200e-02,3.128000e-03,3.577300e-03, & - &1.634800e-02,2.285400e-02,2.691700e-02,2.435400e-02,3.355300e-03, & - &3.820200e-03,1.655800e-02,2.281100e-02,2.663000e-02,2.376800e-02, & - &2.161500e-03,2.525700e-03,1.309800e-02,1.877800e-02,2.251900e-02, & - &2.101800e-02,2.317000e-03,2.698600e-03,1.328400e-02,1.889100e-02, & - &2.251500e-02,2.072200e-02,2.490500e-03,2.895300e-03,1.345900e-02, & - &1.894600e-02,2.241400e-02,2.034500e-02,2.677700e-03,3.102400e-03, & - &1.364900e-02,1.894900e-02,2.223500e-02,1.990800e-02,2.880300e-03, & - &3.324300e-03,1.386000e-02,1.894600e-02,2.199600e-02,1.943700e-02, & - &1.838500e-03,2.171800e-03,1.089600e-02,1.556400e-02,1.862800e-02, & - &1.720900e-02,1.978700e-03,2.333300e-03,1.105800e-02,1.565700e-02, & - &1.861300e-02,1.695600e-02,2.131100e-03,2.509000e-03,1.122500e-02, & - &1.570100e-02,1.852200e-02,1.664200e-02,2.297100e-03,2.696400e-03, & - &1.141600e-02,1.572500e-02,1.836900e-02,1.629100e-02,2.481400e-03, & - &2.902100e-03,1.162900e-02,1.575700e-02,1.817700e-02,1.591300e-02, & - &1.568600e-03,1.873700e-03,9.068100e-03,1.290200e-02,1.540800e-02, & - &1.409600e-02,1.692000e-03,2.021400e-03,9.216800e-03,1.297600e-02, & - &1.538400e-02,1.388300e-02,1.827300e-03,2.179100e-03,9.384300e-03, & - &1.302200e-02,1.530400e-02,1.363200e-02,1.976500e-03,2.351600e-03, & - &9.573000e-03,1.307100e-02,1.517800e-02,1.335000e-02,2.145200e-03, & - &2.543200e-03,9.783000e-03,1.313100e-02,1.503700e-02,1.304500e-02, & - &1.337200e-03,1.617800e-03,7.551900e-03,1.069300e-02,1.274000e-02, & - &1.154900e-02,1.446100e-03,1.750300e-03,7.694500e-03,1.075700e-02, & - &1.271500e-02,1.137700e-02,1.566000e-03,1.893700e-03,7.858300e-03, & - &1.081600e-02,1.264800e-02,1.117600e-02,1.701400e-03,2.053400e-03, & - &8.044800e-03,1.088400e-02,1.255900e-02,1.095000e-02,1.855800e-03, & - &2.231500e-03,8.242300e-03,1.096300e-02,1.246400e-02,1.070500e-02, & - &1.132900e-03,1.389500e-03,6.288000e-03,8.861000e-03,1.053200e-02, & - &9.480900e-03,1.228400e-03,1.507900e-03,6.426200e-03,8.926100e-03, & - &1.051600e-02,9.346200e-03,1.335100e-03,1.638600e-03,6.584500e-03, & - &8.995800e-03,1.046800e-02,9.186500e-03,1.457300e-03,1.784900e-03, & - &6.761400e-03,9.076000e-03,1.041000e-02,9.006400e-03,1.597000e-03, & - &1.948700e-03,6.942000e-03,9.166200e-03,1.035100e-02,8.811700e-03, & - &9.521100e-04,1.184300e-03,5.231200e-03,7.341200e-03,8.708700e-03, & - &7.798100e-03,1.035400e-03,1.290100e-03,5.362500e-03,7.408800e-03, & - &8.700500e-03,7.692800e-03,1.129600e-03,1.407900e-03,5.513800e-03, & - &7.486200e-03,8.673200e-03,7.568900e-03,1.238800e-03,1.540900e-03, & - &5.675000e-03,7.572600e-03,8.642400e-03,7.426200e-03,1.363800e-03, & - &1.690200e-03,5.841600e-03,7.667700e-03,8.612400e-03,7.270800e-03/ - data absb(721:1080,6) / & - &7.906700e-04,9.972800e-04,4.341200e-03,6.078100e-03,7.201000e-03, & - &6.422500e-03,8.620700e-04,1.090300e-03,4.461800e-03,6.147700e-03, & - &7.204000e-03,6.345000e-03,9.436500e-04,1.195100e-03,4.601600e-03, & - &6.225900e-03,7.194900e-03,6.249100e-03,1.039000e-03,1.313700e-03, & - &4.747400e-03,6.313400e-03,7.183500e-03,6.137100e-03,1.149300e-03, & - &1.448200e-03,4.900800e-03,6.409200e-03,7.175900e-03,6.015300e-03, & - &6.557400e-04,8.390200e-04,3.602900e-03,5.033800e-03,5.953500e-03, & - &5.293100e-03,7.172300e-04,9.209200e-04,3.714300e-03,5.103300e-03, & - &5.966400e-03,5.235600e-03,7.881700e-04,1.014000e-03,3.841000e-03, & - &5.178800e-03,5.969400e-03,5.163100e-03,8.714200e-04,1.119900e-03, & - &3.972200e-03,5.268500e-03,5.973800e-03,5.075800e-03,9.681400e-04, & - &1.240600e-03,4.113000e-03,5.359400e-03,5.979600e-03,4.980900e-03, & - &5.439400e-04,7.058700e-04,2.992000e-03,4.171200e-03,4.924100e-03, & - &4.364800e-03,5.967900e-04,7.779400e-04,3.093800e-03,4.238700e-03, & - &4.942900e-03,4.324400e-03,6.586200e-04,8.605700e-04,3.208000e-03, & - &4.314900e-03,4.956000e-03,4.270500e-03,7.313600e-04,9.552100e-04, & - &3.326100e-03,4.399800e-03,4.970400e-03,4.203700e-03,8.164600e-04, & - &1.063700e-03,3.456500e-03,4.486800e-03,4.987500e-03,4.131300e-03, & - &4.467900e-04,5.874500e-04,2.476300e-03,3.450500e-03,4.070800e-03, & - &3.594500e-03,4.916900e-04,6.500500e-04,2.567700e-03,3.515200e-03, & - &4.094300e-03,3.566700e-03,5.445000e-04,7.222200e-04,2.669300e-03, & - &3.587300e-03,4.113500e-03,3.526600e-03,6.071200e-04,8.057800e-04, & - &2.775300e-03,3.669600e-03,4.135300e-03,3.475900e-03,6.806100e-04, & - &9.019800e-04,2.893700e-03,3.751000e-03,4.159500e-03,3.420200e-03, & - &3.665400e-04,4.876300e-04,2.049700e-03,2.854400e-03,3.365200e-03, & - &2.959300e-03,4.043600e-04,5.416800e-04,2.129700e-03,2.914300e-03, & - &3.391300e-03,2.940900e-03,4.494100e-04,6.044200e-04,2.219700e-03, & - &2.982500e-03,3.414500e-03,2.912200e-03,5.028800e-04,6.776600e-04, & - &2.314300e-03,3.059600e-03,3.440700e-03,2.873800e-03,5.662700e-04, & - &7.629600e-04,2.420900e-03,3.135400e-03,3.469300e-03,2.831200e-03, & - &3.005600e-04,4.042300e-04,1.695500e-03,2.360400e-03,2.781500e-03, & - &2.435900e-03,3.324000e-04,4.507800e-04,1.766200e-03,2.416200e-03, & - &2.808700e-03,2.425000e-03,3.706000e-04,5.050100e-04,1.845500e-03, & - &2.479500e-03,2.834200e-03,2.404700e-03,4.163800e-04,5.691200e-04, & - &1.929900e-03,2.550800e-03,2.862600e-03,2.376500e-03,4.708900e-04, & - &6.446300e-04,2.024900e-03,2.620800e-03,2.894300e-03,2.344700e-03, & - &2.450200e-04,3.326100e-04,1.399100e-03,1.948100e-03,2.296100e-03, & - &2.004500e-03,2.715200e-04,3.721200e-04,1.460600e-03,1.998800e-03, & - &2.324100e-03,1.999900e-03,3.034300e-04,4.185100e-04,1.530100e-03, & - &2.058100e-03,2.351500e-03,1.986700e-03,3.421700e-04,4.738400e-04, & - &1.604700e-03,2.122500e-03,2.380400e-03,1.966200e-03,3.886500e-04, & - &5.398000e-04,1.688800e-03,2.187100e-03,2.413400e-03,1.942300e-03, & - &1.991500e-04,2.724900e-04,1.152700e-03,1.606800e-03,1.894900e-03, & - &1.649200e-03,2.210400e-04,3.058600e-04,1.205900e-03,1.652400e-03, & - &1.922000e-03,1.648700e-03,2.476400e-04,3.452900e-04,1.266800e-03, & - &1.705100e-03,1.949000e-03,1.641000e-03,2.800500e-04,3.925300e-04, & - &1.332200e-03,1.763500e-03,1.978600e-03,1.627400e-03,3.193700e-04, & - &4.494800e-04,1.405800e-03,1.822400e-03,2.011400e-03,1.610300e-03, & - &1.616900e-04,2.228700e-04,9.488600e-04,1.324400e-03,1.562400e-03, & - &1.356400e-03,1.798800e-04,2.510700e-04,9.946200e-04,1.365000e-03, & - &1.588500e-03,1.359500e-03,2.018800e-04,2.843000e-04,1.048100e-03, & - &1.412100e-03,1.615100e-03,1.356100e-03,2.290100e-04,3.245800e-04, & - &1.105600e-03,1.464300e-03,1.643400e-03,1.347100e-03,2.621500e-04, & - &3.735900e-04,1.170000e-03,1.517800e-03,1.675000e-03,1.335100e-03, & - &1.308700e-04,1.815300e-04,7.801400e-04,1.090300e-03,1.286200e-03, & - &1.114900e-03,1.458800e-04,2.052300e-04,8.188700e-04,1.126000e-03, & - &1.311300e-03,1.120100e-03,1.640100e-04,2.330900e-04,8.653100e-04, & - &1.167000e-03,1.336200e-03,1.119900e-03,1.865700e-04,2.671600e-04, & - &9.157600e-04,1.214100e-03,1.363600e-03,1.115000e-03,2.143300e-04, & - &3.090100e-04,9.715600e-04,1.262100e-03,1.394000e-03,1.107500e-03, & - &1.053200e-04,1.467800e-04,6.393100e-04,8.956600e-04,1.057000e-03, & - &9.145700e-04,1.176500e-04,1.665800e-04,6.722500e-04,9.270200e-04, & - &1.080800e-03,9.215300e-04,1.324100e-04,1.898000e-04,7.120200e-04, & - &9.625000e-04,1.104100e-03,9.240400e-04,1.509000e-04,2.181400e-04, & - &7.559200e-04,1.003800e-03,1.129600e-03,9.222400e-04,1.738500e-04, & - &2.534400e-04,8.042000e-04,1.047100e-03,1.158000e-03,9.176500e-04, & - &8.461700e-05,1.183800e-04,5.233400e-04,7.354600e-04,8.683500e-04, & - &7.501700e-04,9.478500e-05,1.349500e-04,5.509100e-04,7.625100e-04, & - &8.903100e-04,7.581600e-04,1.067900e-04,1.542600e-04,5.848800e-04, & - &7.933200e-04,9.116800e-04,7.624500e-04,1.218800e-04,1.778400e-04, & - &6.231400e-04,8.292200e-04,9.347900e-04,7.627600e-04,1.408300e-04, & - &2.074100e-04,6.649100e-04,8.677800e-04,9.607300e-04,7.604900e-04/ - data absb(1081:1410,6) / & - &6.786700e-05,9.527000e-05,4.278600e-04,6.031100e-04,7.121700e-04, & - &6.151100e-04,7.624500e-05,1.090800e-04,4.509700e-04,6.266200e-04, & - &7.324300e-04,6.236900e-04,8.602900e-05,1.251500e-04,4.796600e-04, & - &6.528700e-04,7.515800e-04,6.292300e-04,9.830400e-05,1.446600e-04, & - &5.125900e-04,6.838300e-04,7.725400e-04,6.313200e-04,1.138600e-04, & - &1.693400e-04,5.486300e-04,7.179900e-04,7.959600e-04,6.310000e-04, & - &5.447000e-05,7.674600e-05,3.497600e-04,4.942800e-04,5.839700e-04, & - &5.030600e-04,6.141000e-05,8.823700e-05,3.691500e-04,5.145600e-04, & - &6.021700e-04,5.115400e-04,6.943900e-05,1.016600e-04,3.931400e-04, & - &5.372100e-04,6.193900e-04,5.175500e-04,7.945400e-05,1.179200e-04, & - &4.216000e-04,5.641200e-04,6.383500e-04,5.207400e-04,9.227500e-05, & - &1.385500e-04,4.530100e-04,5.944800e-04,6.595000e-04,5.217500e-04, & - &4.372200e-05,6.180600e-05,2.857800e-04,4.046800e-04,4.785500e-04, & - &4.107400e-04,4.945700e-05,7.134200e-05,3.021100e-04,4.223000e-04, & - &4.948800e-04,4.188600e-04,5.606400e-05,8.255400e-05,3.222500e-04, & - &4.420400e-04,5.104900e-04,4.250600e-04,6.423800e-05,9.612000e-05, & - &3.467200e-04,4.652800e-04,5.274300e-04,4.288800e-04,7.479600e-05, & - &1.133400e-04,3.737800e-04,4.919600e-04,5.461800e-04,4.305700e-04, & - &3.507000e-05,4.969100e-05,2.333000e-04,3.309300e-04,3.917200e-04, & - &3.352700e-04,3.976900e-05,5.754100e-05,2.470600e-04,3.463700e-04, & - &4.067000e-04,3.429700e-04,4.522300e-05,6.691600e-05,2.638100e-04, & - &3.632700e-04,4.204500e-04,3.491200e-04,5.187100e-05,7.820000e-05, & - &2.847200e-04,3.831000e-04,4.353300e-04,3.532400e-04,6.052200e-05, & - &9.255400e-05,3.079600e-04,4.064400e-04,4.519000e-04,3.554800e-04, & - &2.811400e-05,3.989500e-05,1.903300e-04,2.703500e-04,3.202700e-04, & - &2.737400e-04,3.191200e-05,4.627200e-05,2.018000e-04,2.836400e-04, & - &3.336800e-04,2.808800e-04,3.641500e-05,5.408800e-05,2.157000e-04, & - &2.981200e-04,3.460900e-04,2.868200e-04,4.182600e-05,6.348600e-05, & - &2.333400e-04,3.149800e-04,3.589800e-04,2.912000e-04,4.888500e-05, & - &7.540800e-05,2.533700e-04,3.353100e-04,3.735200e-04,2.938600e-04, & - &2.261000e-05,3.212000e-05,1.554000e-04,2.209000e-04,2.618900e-04, & - &2.225200e-04,2.567000e-05,3.730400e-05,1.650000e-04,2.323400e-04, & - &2.738300e-04,2.288100e-04,2.939800e-05,4.382800e-05,1.766200e-04, & - &2.447500e-04,2.848800e-04,2.341000e-04,3.383000e-05,5.168900e-05, & - &1.914700e-04,2.591800e-04,2.962100e-04,2.381800e-04,3.962600e-05, & - &6.163700e-05,2.086500e-04,2.767400e-04,3.089100e-04,2.407800e-04, & - &1.820900e-05,2.588000e-05,1.268800e-04,1.804500e-04,2.139800e-04, & - &1.803800e-04,2.065700e-05,3.008600e-05,1.349300e-04,1.902500e-04, & - &2.245000e-04,1.858200e-04,2.373900e-05,3.551400e-05,1.446000e-04, & - &2.008100e-04,2.343000e-04,1.903300e-04,2.739700e-05,4.208800e-05, & - &1.571400e-04,2.130600e-04,2.441600e-04,1.938600e-04,3.215300e-05, & - &5.038700e-05,1.718600e-04,2.282000e-04,2.553300e-04,1.962700e-04, & - &1.465400e-05,2.083600e-05,1.035000e-04,1.472300e-04,1.745800e-04, & - &1.461300e-04,1.660200e-05,2.422400e-05,1.102300e-04,1.556200e-04, & - &1.838000e-04,1.508700e-04,1.914500e-05,2.871300e-05,1.183100e-04, & - &1.645800e-04,1.924300e-04,1.546600e-04,2.216200e-05,3.420500e-05, & - &1.287700e-04,1.750000e-04,2.010700e-04,1.577600e-04,2.604700e-05, & - &4.111400e-05,1.413700e-04,1.879600e-04,2.108300e-04,1.599400e-04, & - &1.179500e-05,1.676000e-05,8.430400e-05,1.199900e-04,1.421800e-04, & - &1.183000e-04,1.333500e-05,1.947600e-05,8.996400e-05,1.271800e-04, & - &1.503500e-04,1.224400e-04,1.541200e-05,2.315000e-05,9.668000e-05, & - &1.347800e-04,1.577900e-04,1.256600e-04,1.789600e-05,2.772800e-05, & - &1.053900e-04,1.435800e-04,1.653600e-04,1.283500e-04,2.107100e-05, & - &3.347400e-05,1.161400e-04,1.545600e-04,1.738200e-04,1.302800e-04, & - &9.514400e-06,1.350400e-05,6.867000e-05,9.775200e-05,1.157200e-04, & - &9.573100e-05,1.072700e-05,1.568200e-05,7.342500e-05,1.039300e-04, & - &1.228800e-04,9.926800e-05,1.241800e-05,1.867600e-05,7.903600e-05, & - &1.104200e-04,1.294100e-04,1.020500e-04,1.447000e-05,2.249200e-05, & - &8.630100e-05,1.178700e-04,1.360100e-04,1.043100e-04,1.706800e-05, & - &2.729000e-05,9.544500e-05,1.271100e-04,1.432600e-04,1.059900e-04, & - &7.820500e-06,1.114400e-05,5.655300e-05,8.051800e-05,9.525300e-05, & - &7.775800e-05,8.841200e-06,1.299400e-05,6.064500e-05,8.580800e-05, & - &1.013700e-04,8.056500e-05,1.027500e-05,1.555600e-05,6.550800e-05, & - &9.140800e-05,1.070300e-04,8.276700e-05,1.202600e-05,1.886100e-05, & - &7.187900e-05,9.791800e-05,1.127700e-04,8.444300e-05,1.425900e-05, & - &2.305100e-05,7.985700e-05,1.061100e-04,1.192100e-04,8.569700e-05/ - data absb(1:360,7) / & - &9.764700e-02,9.785500e-02,3.036300e-01,4.703100e-01,5.990400e-01, & - &6.664000e-01,1.004900e-01,1.006900e-01,3.021800e-01,4.698200e-01, & - &6.003600e-01,6.730800e-01,1.037700e-01,1.039600e-01,3.003300e-01, & - &4.676200e-01,5.998300e-01,6.788300e-01,1.070400e-01,1.072200e-01, & - &2.989200e-01,4.646700e-01,5.975100e-01,6.820400e-01,1.102300e-01, & - &1.104000e-01,2.980200e-01,4.615500e-01,5.938200e-01,6.834200e-01, & - &8.623500e-02,8.645000e-02,2.902800e-01,4.505500e-01,5.762000e-01, & - &6.343500e-01,8.908400e-02,8.929200e-02,2.894500e-01,4.500200e-01, & - &5.781700e-01,6.398000e-01,9.193900e-02,9.213300e-02,2.890200e-01, & - &4.487100e-01,5.781400e-01,6.442700e-01,9.479300e-02,9.497900e-02, & - &2.889700e-01,4.470800e-01,5.762100e-01,6.466700e-01,9.749300e-02, & - &9.766800e-02,2.892400e-01,4.451800e-01,5.731700e-01,6.467100e-01, & - &7.580400e-02,7.602900e-02,2.744600e-01,4.258900e-01,5.472000e-01, & - &5.972600e-01,7.830000e-02,7.851700e-02,2.750200e-01,4.261800e-01, & - &5.494800e-01,6.017100e-01,8.078500e-02,8.098900e-02,2.759900e-01, & - &4.260900e-01,5.496400e-01,6.046900e-01,8.319500e-02,8.338800e-02, & - &2.772000e-01,4.257900e-01,5.482700e-01,6.058700e-01,8.545500e-02, & - &8.563600e-02,2.783200e-01,4.251000e-01,5.456500e-01,6.053400e-01, & - &6.611800e-02,6.635500e-02,2.573200e-01,3.982900e-01,5.126500e-01, & - &5.552700e-01,6.834000e-02,6.856500e-02,2.592200e-01,3.997200e-01, & - &5.148100e-01,5.590100e-01,7.047900e-02,7.069100e-02,2.613100e-01, & - &4.006400e-01,5.151300e-01,5.612900e-01,7.248900e-02,7.268900e-02, & - &2.633500e-01,4.010800e-01,5.140600e-01,5.625300e-01,7.439700e-02, & - &7.458600e-02,2.651800e-01,4.009800e-01,5.122200e-01,5.624300e-01, & - &5.740600e-02,5.765000e-02,2.393000e-01,3.686600e-01,4.735700e-01, & - &5.087800e-01,5.930900e-02,5.953700e-02,2.421400e-01,3.706000e-01, & - &4.757300e-01,5.119200e-01,6.108200e-02,6.130100e-02,2.448100e-01, & - &3.722000e-01,4.760800e-01,5.145700e-01,6.276900e-02,6.297600e-02, & - &2.472600e-01,3.733300e-01,4.757500e-01,5.163900e-01,6.453800e-02, & - &6.473800e-02,2.492100e-01,3.744400e-01,4.749100e-01,5.171800e-01, & - &4.955200e-02,4.980100e-02,2.205600e-01,3.373500e-01,4.316100e-01, & - &4.598800e-01,5.112100e-02,5.135900e-02,2.236100e-01,3.399100e-01, & - &4.334500e-01,4.634600e-01,5.259300e-02,5.282100e-02,2.265400e-01, & - &3.422000e-01,4.344000e-01,4.666700e-01,5.410900e-02,5.432300e-02, & - &2.290500e-01,3.443800e-01,4.351300e-01,4.690500e-01,5.593900e-02, & - &5.614500e-02,2.310700e-01,3.462800e-01,4.358100e-01,4.707500e-01, & - &4.249400e-02,4.274600e-02,2.010600e-01,3.052000e-01,3.881300e-01, & - &4.108700e-01,4.377900e-02,4.402200e-02,2.042500e-01,3.083600e-01, & - &3.903600e-01,4.149400e-01,4.504700e-02,4.527900e-02,2.071400e-01, & - &3.114900e-01,3.922700e-01,4.186600e-01,4.657200e-02,4.679100e-02, & - &2.096000e-01,3.144200e-01,3.944300e-01,4.216200e-01,4.848600e-02, & - &4.869300e-02,2.117800e-01,3.172400e-01,3.964800e-01,4.240600e-01, & - &3.626900e-02,3.652800e-02,1.814500e-01,2.735800e-01,3.455600e-01, & - &3.636200e-01,3.733900e-02,3.758900e-02,1.845400e-01,2.774400e-01, & - &3.484900e-01,3.681500e-01,3.854900e-02,3.878700e-02,1.873200e-01, & - &2.810700e-01,3.517300e-01,3.721400e-01,4.013500e-02,4.036000e-02, & - &1.899100e-01,2.846800e-01,3.549400e-01,3.757800e-01,4.203400e-02, & - &4.224400e-02,1.923100e-01,2.879600e-01,3.582500e-01,3.792000e-01, & - &3.083800e-02,3.111000e-02,1.621700e-01,2.434700e-01,3.051900e-01, & - &3.190900e-01,3.180200e-02,3.206300e-02,1.651500e-01,2.476100e-01, & - &3.091100e-01,3.238500e-01,3.306200e-02,3.330900e-02,1.679600e-01, & - &2.517300e-01,3.132400e-01,3.283600e-01,3.462900e-02,3.486200e-02, & - &1.706600e-01,2.556100e-01,3.176200e-01,3.324300e-01,3.634200e-02, & - &3.655600e-02,1.733100e-01,2.594500e-01,3.216100e-01,3.353600e-01, & - &2.618500e-02,2.648000e-02,1.439000e-01,2.153500e-01,2.682500e-01, & - &2.783100e-01,2.717000e-02,2.744500e-02,1.468100e-01,2.197200e-01, & - &2.729800e-01,2.833200e-01,2.846100e-02,2.872100e-02,1.496700e-01, & - &2.240300e-01,2.780000e-01,2.877100e-01,2.989500e-02,3.013600e-02, & - &1.525200e-01,2.282600e-01,2.824500e-01,2.909400e-01,3.138900e-02, & - &3.160900e-02,1.554600e-01,2.319200e-01,2.857600e-01,2.920400e-01, & - &2.224200e-02,2.258500e-02,1.267800e-01,1.894200e-01,2.349400e-01, & - &2.414300e-01,2.326900e-02,2.358400e-02,1.296600e-01,1.939200e-01, & - &2.401200e-01,2.460100e-01,2.446200e-02,2.475200e-02,1.326200e-01, & - &1.982600e-01,2.447900e-01,2.493200e-01,2.572400e-02,2.598700e-02, & - &1.356200e-01,2.019400e-01,2.482700e-01,2.504400e-01,2.700900e-02, & - &2.724700e-02,1.386600e-01,2.047200e-01,2.498700e-01,2.491100e-01, & - &1.892400e-02,1.934200e-02,1.110500e-01,1.659000e-01,2.049900e-01, & - &2.080200e-01,1.991000e-02,2.029000e-02,1.139700e-01,1.701800e-01, & - &2.097000e-01,2.113500e-01,2.096500e-02,2.130800e-02,1.169000e-01, & - &1.738200e-01,2.131900e-01,2.125500e-01,2.205200e-02,2.236200e-02, & - &1.197600e-01,1.764700e-01,2.147200e-01,2.115500e-01,2.315900e-02, & - &2.343800e-02,1.225400e-01,1.779000e-01,2.143600e-01,2.089900e-01/ - data absb(361:720,7) / & - &1.612600e-02,1.663400e-02,9.691800e-02,1.445000e-01,1.777600e-01, & - &1.775100e-01,1.700500e-02,1.747100e-02,9.965500e-02,1.480400e-01, & - &1.811700e-01,1.788900e-01,1.790800e-02,1.833000e-02,1.023100e-01, & - &1.505600e-01,1.827700e-01,1.783400e-01,1.883400e-02,1.921400e-02, & - &1.048100e-01,1.518800e-01,1.826900e-01,1.764400e-01,1.980300e-02, & - &2.014700e-02,1.070600e-01,1.524100e-01,1.814200e-01,1.736000e-01, & - &1.373300e-02,1.433300e-02,8.416300e-02,1.249100e-01,1.526400e-01, & - &1.495000e-01,1.448500e-02,1.504200e-02,8.657100e-02,1.272900e-01, & - &1.543300e-01,1.493800e-01,1.526300e-02,1.577500e-02,8.879300e-02, & - &1.286100e-01,1.545600e-01,1.480900e-01,1.606000e-02,1.652600e-02, & - &9.076600e-02,1.292200e-01,1.537300e-01,1.459800e-01,1.693600e-02, & - &1.735600e-02,9.241000e-02,1.295700e-01,1.522400e-01,1.432300e-01, & - &1.167300e-02,1.234900e-02,7.266800e-02,1.067800e-01,1.294600e-01, & - &1.244600e-01,1.231300e-02,1.295500e-02,7.461300e-02,1.081300e-01, & - &1.299800e-01,1.237200e-01,1.297400e-02,1.357400e-02,7.636500e-02, & - &1.088500e-01,1.295800e-01,1.222300e-01,1.368800e-02,1.424100e-02, & - &7.787000e-02,1.093400e-01,1.285900e-01,1.201900e-01,1.450000e-02, & - &1.500400e-02,7.915400e-02,1.096800e-01,1.272100e-01,1.176900e-01, & - &9.901700e-03,1.063700e-02,6.226900e-02,9.033600e-02,1.087300e-01, & - &1.028900e-01,1.044700e-02,1.115500e-02,6.383700e-02,9.116100e-02, & - &1.087000e-01,1.019400e-01,1.103100e-02,1.170300e-02,6.523400e-02, & - &9.175700e-02,1.081300e-01,1.004900e-01,1.168700e-02,1.231700e-02, & - &6.643500e-02,9.224400e-02,1.072200e-01,9.862100e-02,1.245200e-02, & - &1.303600e-02,6.745200e-02,9.254100e-02,1.061700e-01,9.643000e-02, & - &8.394300e-03,9.165400e-03,5.304700e-02,7.594100e-02,9.076400e-02, & - &8.473200e-02,8.866900e-03,9.621100e-03,5.435100e-02,7.661500e-02, & - &9.053400e-02,8.376800e-02,9.397600e-03,1.012500e-02,5.550100e-02, & - &7.720100e-02,8.998900e-02,8.242800e-02,1.001700e-02,1.070800e-02, & - &5.648900e-02,7.764300e-02,8.931000e-02,8.078500e-02,1.073600e-02, & - &1.138900e-02,5.730500e-02,7.787700e-02,8.854500e-02,7.891700e-02, & - &7.119500e-03,7.906400e-03,4.504800e-02,6.370100e-02,7.550600e-02, & - &6.960900e-02,7.543000e-03,8.322300e-03,4.614100e-02,6.433600e-02, & - &7.524900e-02,6.869100e-02,8.039200e-03,8.802800e-03,4.709200e-02, & - &6.488700e-02,7.486500e-02,6.751300e-02,8.626000e-03,9.365700e-03, & - &4.790300e-02,6.526300e-02,7.440100e-02,6.610800e-02,9.296700e-03, & - &1.000700e-02,4.861500e-02,6.544700e-02,7.385200e-02,6.454500e-02, & - &6.047500e-03,6.833500e-03,3.815800e-02,5.342100e-02,6.269500e-02, & - &5.711800e-02,6.442300e-03,7.230600e-03,3.908700e-02,5.403800e-02, & - &6.253300e-02,5.630400e-02,6.915700e-03,7.699000e-03,3.988500e-02, & - &5.450700e-02,6.231400e-02,5.529100e-02,7.464300e-03,8.237800e-03, & - &4.058500e-02,5.481800e-02,6.200700e-02,5.412300e-02,8.087000e-03, & - &8.842700e-03,4.123800e-02,5.495600e-02,6.157100e-02,5.284500e-02, & - &5.157200e-03,5.928100e-03,3.228800e-02,4.483400e-02,5.206300e-02, & - &4.683800e-02,5.534300e-03,6.317800e-03,3.306600e-02,4.537900e-02, & - &5.202200e-02,4.613400e-02,5.979300e-03,6.773200e-03,3.375500e-02, & - &4.578200e-02,5.190600e-02,4.528400e-02,6.492300e-03,7.287600e-03, & - &3.438200e-02,4.603100e-02,5.167700e-02,4.433200e-02,7.059600e-03, & - &7.851000e-03,3.502000e-02,4.615700e-02,5.132600e-02,4.332700e-02, & - &4.419300e-03,5.167200e-03,2.728100e-02,3.764300e-02,4.328900e-02, & - &3.841000e-02,4.778000e-03,5.550900e-03,2.795400e-02,3.811200e-02, & - &4.332300e-02,3.782100e-02,5.195400e-03,5.989900e-03,2.855800e-02, & - &3.844200e-02,4.325300e-02,3.713300e-02,5.667500e-03,6.476000e-03, & - &2.916200e-02,3.866100e-02,4.307700e-02,3.638200e-02,6.186700e-03, & - &6.998100e-03,2.981700e-02,3.881700e-02,4.279100e-02,3.559300e-02, & - &3.796700e-03,4.519000e-03,2.303000e-02,3.160100e-02,3.605400e-02, & - &3.150900e-02,4.131700e-03,4.888600e-03,2.361200e-02,3.199300e-02, & - &3.611400e-02,3.102500e-02,4.519700e-03,5.308000e-03,2.417200e-02, & - &3.228400e-02,3.607500e-02,3.047500e-02,4.949000e-03,5.761500e-03, & - &2.476500e-02,3.250000e-02,3.593400e-02,2.988600e-02,5.427700e-03, & - &6.250600e-03,2.545700e-02,3.270300e-02,3.571700e-02,2.926500e-02, & - &3.248500e-03,3.940100e-03,1.939500e-02,2.648700e-02,3.006100e-02, & - &2.589800e-02,3.557400e-03,4.290200e-03,1.991800e-02,2.683900e-02, & - &3.013700e-02,2.550900e-02,3.908400e-03,4.682300e-03,2.045400e-02, & - &2.711200e-02,3.012300e-02,2.508000e-02,4.297500e-03,5.103900e-03, & - &2.105200e-02,2.734800e-02,3.002800e-02,2.462600e-02,4.740000e-03, & - &5.564200e-03,2.174800e-02,2.760000e-02,2.987300e-02,2.413600e-02, & - &2.760700e-03,3.414200e-03,1.629200e-02,2.216800e-02,2.507100e-02, & - &2.132100e-02,3.040800e-03,3.742900e-03,1.677100e-02,2.249200e-02, & - &2.516700e-02,2.102200e-02,3.354100e-03,4.105000e-03,1.728600e-02, & - &2.276200e-02,2.517900e-02,2.069700e-02,3.703800e-03,4.492400e-03, & - &1.788200e-02,2.302500e-02,2.512800e-02,2.034400e-02,4.111500e-03, & - &4.927500e-03,1.856100e-02,2.332100e-02,2.503800e-02,1.996600e-02/ - data absb(721:1080,7) / & - &2.316500e-03,2.924300e-03,1.363200e-02,1.851100e-02,2.091100e-02, & - &1.758200e-02,2.562000e-03,3.224000e-03,1.407800e-02,1.881700e-02, & - &2.102100e-02,1.735900e-02,2.837800e-03,3.553600e-03,1.456600e-02, & - &1.908900e-02,2.106200e-02,1.711200e-02,3.150600e-03,3.910500e-03, & - &1.513400e-02,1.936800e-02,2.105500e-02,1.684300e-02,3.515400e-03, & - &4.311600e-03,1.578000e-02,1.969000e-02,2.102500e-02,1.655400e-02, & - &1.943600e-03,2.504300e-03,1.140900e-02,1.544900e-02,1.743900e-02, & - &1.450900e-02,2.158500e-03,2.777600e-03,1.182200e-02,1.574100e-02, & - &1.756000e-02,1.434900e-02,2.401800e-03,3.076600e-03,1.227800e-02, & - &1.601000e-02,1.762500e-02,1.416300e-02,2.680700e-03,3.407400e-03, & - &1.282100e-02,1.630000e-02,1.765300e-02,1.396100e-02,3.007400e-03, & - &3.776700e-03,1.342700e-02,1.663500e-02,1.767000e-02,1.374500e-02, & - &1.632400e-03,2.147200e-03,9.557600e-03,1.289900e-02,1.454600e-02, & - &1.198900e-02,1.820000e-03,2.394700e-03,9.933700e-03,1.317000e-02, & - &1.467100e-02,1.187500e-02,2.034100e-03,2.667600e-03,1.036800e-02, & - &1.343600e-02,1.475400e-02,1.174100e-02,2.282200e-03,2.970000e-03, & - &1.087300e-02,1.372900e-02,1.481100e-02,1.159200e-02,2.577700e-03, & - &3.316900e-03,1.145100e-02,1.407100e-02,1.486400e-02,1.142900e-02, & - &1.356000e-03,1.820500e-03,7.978600e-03,1.074600e-02,1.211600e-02, & - &9.893700e-03,1.518800e-03,2.043200e-03,8.320900e-03,1.100100e-02, & - &1.224800e-02,9.811600e-03,1.704700e-03,2.289300e-03,8.718300e-03, & - &1.125600e-02,1.234600e-02,9.713900e-03,1.922200e-03,2.566200e-03, & - &9.187700e-03,1.154500e-02,1.242500e-02,9.603400e-03,2.182700e-03, & - &2.882500e-03,9.721600e-03,1.188000e-02,1.250600e-02,9.479000e-03, & - &1.124500e-03,1.541500e-03,6.659100e-03,8.947800e-03,1.008700e-02, & - &8.164200e-03,1.264800e-03,1.740200e-03,6.968800e-03,9.187100e-03, & - &1.022100e-02,8.105600e-03,1.426600e-03,1.962200e-03,7.330600e-03, & - &9.430000e-03,1.032800e-02,8.035600e-03,1.616200e-03,2.213200e-03, & - &7.761400e-03,9.709400e-03,1.042200e-02,7.953800e-03,1.845200e-03, & - &2.502000e-03,8.254000e-03,1.003000e-02,1.052200e-02,7.859200e-03, & - &9.321900e-04,1.304200e-03,5.555800e-03,7.450200e-03,8.393000e-03, & - &6.737300e-03,1.053100e-03,1.481700e-03,5.835900e-03,7.672700e-03, & - &8.526700e-03,6.697900e-03,1.193200e-03,1.682200e-03,6.166200e-03, & - &7.901200e-03,8.637100e-03,6.648600e-03,1.359100e-03,1.910100e-03, & - &6.559400e-03,8.165900e-03,8.740000e-03,6.590000e-03,1.559500e-03, & - &2.171200e-03,7.014300e-03,8.471100e-03,8.852000e-03,6.519700e-03, & - &7.665500e-04,1.094800e-03,4.619900e-03,6.192900e-03,6.973800e-03, & - &5.559000e-03,8.700600e-04,1.251900e-03,4.872500e-03,6.398200e-03, & - &7.105100e-03,5.535400e-03,9.906701e-04,1.431700e-03,5.171400e-03, & - &6.609400e-03,7.216700e-03,5.503400e-03,1.133300e-03,1.636100e-03, & - &5.523800e-03,6.854900e-03,7.322400e-03,5.461500e-03,1.307800e-03, & - &1.872900e-03,5.939200e-03,7.140400e-03,7.439500e-03,5.409800e-03, & - &6.271600e-04,9.144500e-04,3.837900e-03,5.142300e-03,5.788500e-03, & - &4.587900e-03,7.153900e-04,1.052500e-03,4.060800e-03,5.328400e-03, & - &5.913900e-03,4.575000e-03,8.186800e-04,1.212400e-03,4.326100e-03, & - &5.522300e-03,6.023700e-03,4.556400e-03,9.407600e-04,1.395100e-03, & - &4.643900e-03,5.749300e-03,6.130400e-03,4.529100e-03,1.090500e-03, & - &1.607400e-03,5.018400e-03,6.013200e-03,6.249800e-03,4.493000e-03, & - &5.122900e-04,7.619300e-04,3.185300e-03,4.267800e-03,4.800700e-03, & - &3.786700e-03,5.870000e-04,8.830900e-04,3.382200e-03,4.437600e-03, & - &4.920400e-03,3.783700e-03,6.753200e-04,1.025300e-03,3.617200e-03, & - &4.613700e-03,5.026300e-03,3.775000e-03,7.799200e-04,1.188600e-03, & - &3.900100e-03,4.819300e-03,5.130500e-03,3.758200e-03,9.089800e-04, & - &1.380100e-03,4.237500e-03,5.060200e-03,5.246800e-03,3.733900e-03, & - &4.164500e-04,6.311000e-04,2.635000e-03,3.535300e-03,3.976900e-03, & - &3.125600e-03,4.790200e-04,7.363600e-04,2.809100e-03,3.688800e-03, & - &4.088400e-03,3.128400e-03,5.540700e-04,8.623300e-04,3.015100e-03, & - &3.848000e-03,4.189000e-03,3.126600e-03,6.435700e-04,1.008300e-03, & - &3.267700e-03,4.034900e-03,4.289700e-03,3.119500e-03,7.535400e-04, & - &1.178300e-03,3.568500e-03,4.254400e-03,4.401800e-03,3.106300e-03, & - &3.360100e-04,5.177700e-04,2.172300e-03,2.919700e-03,3.286000e-03, & - &2.576000e-03,3.875400e-04,6.079600e-04,2.323900e-03,3.058100e-03, & - &3.391100e-03,2.584400e-03,4.506500e-04,7.179800e-04,2.502200e-03, & - &3.201900e-03,3.487500e-03,2.588900e-03,5.261300e-04,8.468200e-04, & - &2.723800e-03,3.368200e-03,3.581500e-03,2.588400e-03,6.192900e-04, & - &9.978600e-04,2.989700e-03,3.565800e-03,3.686100e-03,2.582700e-03, & - &2.708300e-04,4.234700e-04,1.789900e-03,2.408800e-03,2.713600e-03, & - &2.124400e-03,3.127900e-04,4.999900e-04,1.920600e-03,2.533000e-03, & - &2.811200e-03,2.136700e-03,3.655000e-04,5.953300e-04,2.074000e-03, & - &2.661400e-03,2.900200e-03,2.145100e-03,4.289700e-04,7.091300e-04, & - &2.266200e-03,2.808300e-03,2.987500e-03,2.149700e-03,5.074600e-04, & - &8.431000e-04,2.499500e-03,2.984100e-03,3.083800e-03,2.149400e-03/ - data absb(1081:1410,7) / & - &2.179800e-04,3.452800e-04,1.471000e-03,1.983300e-03,2.237500e-03, & - &1.752800e-03,2.517700e-04,4.095600e-04,1.585000e-03,2.094300e-03, & - &2.327300e-03,1.767800e-03,2.956800e-04,4.914400e-04,1.716100e-03, & - &2.208900e-03,2.409400e-03,1.779100e-03,3.487400e-04,5.910000e-04, & - &1.881800e-03,2.338000e-03,2.489200e-03,1.787400e-03,4.145800e-04, & - &7.095100e-04,2.084900e-03,2.493400e-03,2.577200e-03,1.791900e-03, & - &1.758500e-04,2.818900e-04,1.209300e-03,1.632900e-03,1.844100e-03, & - &1.443000e-03,2.031900e-04,3.357400e-04,1.308000e-03,1.731300e-03, & - &1.925600e-03,1.458400e-03,2.395400e-04,4.057600e-04,1.421000e-03, & - &1.832600e-03,2.001100e-03,1.470800e-03,2.840200e-04,4.927100e-04, & - &1.564200e-03,1.946800e-03,2.074600e-03,1.481300e-03,3.394300e-04, & - &5.979000e-04,1.741700e-03,2.085200e-03,2.155500e-03,1.489000e-03, & - &1.419000e-04,2.299200e-04,9.940400e-04,1.343500e-03,1.518100e-03, & - &1.185700e-03,1.640400e-04,2.749700e-04,1.078900e-03,1.430400e-03, & - &1.592100e-03,1.201000e-03,1.940400e-04,3.346000e-04,1.176800e-03, & - &1.520400e-03,1.661600e-03,1.214400e-03,2.313100e-04,4.101500e-04, & - &1.300000e-03,1.620700e-03,1.729000e-03,1.225700e-03,2.778000e-04, & - &5.029200e-04,1.454600e-03,1.743200e-03,1.802400e-03,1.234700e-03, & - &1.144400e-04,1.870700e-04,8.151000e-04,1.103600e-03,1.248100e-03, & - &9.744200e-04,1.322200e-04,2.244600e-04,8.896600e-04,1.181000e-03, & - &1.315300e-03,9.898701e-04,1.568500e-04,2.747900e-04,9.735000e-04, & - &1.260200e-03,1.378500e-03,1.003100e-03,1.879800e-04,3.399800e-04, & - &1.078700e-03,1.347900e-03,1.439900e-03,1.014700e-03,2.268500e-04, & - &4.210300e-04,1.212900e-03,1.455300e-03,1.505800e-03,1.024600e-03, & - &9.220300e-05,1.517800e-04,6.668400e-04,9.049100e-04,1.024800e-03, & - &8.009500e-04,1.064500e-04,1.827300e-04,7.318000e-04,9.734500e-04, & - &1.084800e-03,8.162700e-04,1.264500e-04,2.248000e-04,8.042100e-04, & - &1.043200e-03,1.142000e-03,8.293500e-04,1.524000e-04,2.804800e-04, & - &8.933200e-04,1.119600e-03,1.197600e-03,8.410800e-04,1.849300e-04, & - &3.512000e-04,1.009200e-03,1.213000e-03,1.256800e-03,8.514400e-04, & - &7.447500e-05,1.234500e-04,5.461800e-04,7.426100e-04,8.418300e-04, & - &6.553000e-04,8.595900e-05,1.492300e-04,6.025100e-04,8.029400e-04, & - &8.949000e-04,6.689100e-04,1.022900e-04,1.845400e-04,6.650700e-04, & - &8.643500e-04,9.462200e-04,6.805200e-04,1.239900e-04,2.320800e-04, & - &7.415600e-04,9.313300e-04,9.962600e-04,6.911300e-04,1.513200e-04, & - &2.937800e-04,8.414700e-04,1.012500e-03,1.049400e-03,7.003900e-04, & - &6.019200e-05,1.004000e-04,4.470000e-04,6.090800e-04,6.911200e-04, & - &5.344400e-04,6.945700e-05,1.219100e-04,4.955400e-04,6.621600e-04, & - &7.378900e-04,5.462000e-04,8.280600e-05,1.514700e-04,5.496800e-04, & - &7.159600e-04,7.835500e-04,5.559500e-04,1.008900e-04,1.918800e-04, & - &6.150600e-04,7.745100e-04,8.284400e-04,5.649400e-04,1.239100e-04, & - &2.454900e-04,7.015200e-04,8.452400e-04,8.758900e-04,5.726400e-04, & - &4.858000e-05,8.144700e-05,3.649900e-04,4.986000e-04,5.667400e-04, & - &4.356700e-04,5.604700e-05,9.932000e-05,4.064900e-04,5.449200e-04, & - &6.076000e-04,4.458600e-04,6.689300e-05,1.239100e-04,4.532000e-04, & - &5.922400e-04,6.481800e-04,4.542200e-04,8.191200e-05,1.581200e-04, & - &5.092100e-04,6.432600e-04,6.881700e-04,4.616600e-04,1.012600e-04, & - &2.044300e-04,5.838000e-04,7.045600e-04,7.304100e-04,4.680800e-04, & - &3.916000e-05,6.584800e-05,2.973400e-04,4.072000e-04,4.640100e-04, & - &3.548700e-04,4.516900e-05,8.066700e-05,3.330300e-04,4.477100e-04, & - &4.996000e-04,3.638500e-04,5.392200e-05,1.010700e-04,3.727100e-04, & - &4.890100e-04,5.355600e-04,3.710000e-04,6.630900e-05,1.298600e-04, & - &4.206600e-04,5.336300e-04,5.711800e-04,3.771500e-04,8.255800e-05, & - &1.695700e-04,4.845800e-04,5.866000e-04,6.085400e-04,3.826100e-04, & - &3.159500e-05,5.325100e-05,2.421400e-04,3.322000e-04,3.797900e-04, & - &2.889300e-04,3.645300e-05,6.553000e-05,2.725600e-04,3.674400e-04, & - &4.106800e-04,2.967000e-04,4.352200e-05,8.252200e-05,3.067000e-04, & - &4.036200e-04,4.423900e-04,3.027600e-04,5.371800e-05,1.067200e-04, & - &3.477400e-04,4.427300e-04,4.740800e-04,3.078000e-04,6.737700e-05, & - &1.407000e-04,4.022500e-04,4.886300e-04,5.071700e-04,3.123400e-04, & - &2.609500e-05,4.455700e-05,2.013500e-04,2.758600e-04,3.150900e-04, & - &2.354200e-04,3.025100e-05,5.529600e-05,2.277000e-04,3.065200e-04, & - &3.421000e-04,2.416000e-04,3.636400e-05,7.031500e-05,2.576200e-04, & - &3.383900e-04,3.700800e-04,2.461500e-04,4.525200e-05,9.195500e-05, & - &2.941000e-04,3.731800e-04,3.981400e-04,2.496800e-04,5.723900e-05, & - &1.227100e-04,3.433600e-04,4.146400e-04,4.279400e-04,2.528000e-04/ - data absb(1:360,8) / & - &3.059300e-01,3.060100e-01,5.893600e-01,8.820500e-01,1.094700e+00, & - &1.194300e+00,3.057600e-01,3.058500e-01,5.841600e-01,8.744500e-01, & - &1.084200e+00,1.194600e+00,3.073000e-01,3.073900e-01,5.783800e-01, & - &8.662200e-01,1.073600e+00,1.194100e+00,3.114300e-01,3.115300e-01, & - &5.723600e-01,8.566400e-01,1.062300e+00,1.192600e+00,3.182100e-01, & - &3.183000e-01,5.667100e-01,8.458900e-01,1.049600e+00,1.188300e+00, & - &2.654100e-01,2.655200e-01,5.804300e-01,8.835200e-01,1.102600e+00, & - &1.193100e+00,2.669500e-01,2.670600e-01,5.753900e-01,8.777800e-01, & - &1.095100e+00,1.193700e+00,2.711200e-01,2.712300e-01,5.700000e-01, & - &8.710800e-01,1.086900e+00,1.191000e+00,2.780700e-01,2.781800e-01, & - &5.651400e-01,8.627100e-01,1.076700e+00,1.186700e+00,2.873900e-01, & - &2.875100e-01,5.612600e-01,8.528000e-01,1.064300e+00,1.180900e+00, & - &2.317800e-01,2.319100e-01,5.718400e-01,8.769300e-01,1.102200e+00, & - &1.181300e+00,2.356000e-01,2.357300e-01,5.672400e-01,8.734900e-01, & - &1.097600e+00,1.180000e+00,2.421900e-01,2.423300e-01,5.627200e-01, & - &8.682600e-01,1.090400e+00,1.176600e+00,2.507400e-01,2.508800e-01, & - &5.591900e-01,8.609700e-01,1.080700e+00,1.172000e+00,2.600000e-01, & - &2.601300e-01,5.569800e-01,8.526100e-01,1.068800e+00,1.165700e+00, & - &2.041400e-01,2.042900e-01,5.596700e-01,8.637000e-01,1.090400e+00, & - &1.156200e+00,2.100900e-01,2.102400e-01,5.562500e-01,8.614100e-01, & - &1.086500e+00,1.155800e+00,2.175300e-01,2.176800e-01,5.535500e-01, & - &8.565700e-01,1.080000e+00,1.153700e+00,2.258100e-01,2.259500e-01, & - &5.521000e-01,8.507100e-01,1.071200e+00,1.149700e+00,2.345100e-01, & - &2.346600e-01,5.516600e-01,8.444500e-01,1.059900e+00,1.144200e+00, & - &1.811100e-01,1.812700e-01,5.437000e-01,8.406600e-01,1.063300e+00, & - &1.117300e+00,1.875100e-01,1.876700e-01,5.422500e-01,8.387000e-01, & - &1.060300e+00,1.118800e+00,1.947800e-01,1.949400e-01,5.418200e-01, & - &8.352800e-01,1.054700e+00,1.117900e+00,2.022600e-01,2.024200e-01, & - &5.424200e-01,8.313500e-01,1.046200e+00,1.115300e+00,2.097700e-01, & - &2.099200e-01,5.440800e-01,8.266500e-01,1.035300e+00,1.110900e+00, & - &1.603700e-01,1.605400e-01,5.235400e-01,8.074300e-01,1.021400e+00, & - &1.066500e+00,1.665200e-01,1.666900e-01,5.246800e-01,8.067600e-01, & - &1.019600e+00,1.069200e+00,1.729000e-01,1.730700e-01,5.265500e-01, & - &8.047700e-01,1.014700e+00,1.069100e+00,1.793400e-01,1.795100e-01, & - &5.294300e-01,8.025100e-01,1.006900e+00,1.067500e+00,1.858000e-01, & - &1.859600e-01,5.321800e-01,7.999600e-01,9.967500e-01,1.064100e+00, & - &1.414700e-01,1.416500e-01,4.993100e-01,7.657900e-01,9.670600e-01, & - &1.003600e+00,1.468000e-01,1.469900e-01,5.023500e-01,7.662400e-01, & - &9.659800e-01,1.006600e+00,1.522500e-01,1.524400e-01,5.065400e-01, & - &7.661800e-01,9.612400e-01,1.007700e+00,1.577200e-01,1.579100e-01, & - &5.107400e-01,7.659800e-01,9.536300e-01,1.007200e+00,1.633000e-01, & - &1.634800e-01,5.143300e-01,7.648200e-01,9.445900e-01,1.004800e+00, & - &1.241500e-01,1.243500e-01,4.715200e-01,7.170000e-01,9.018000e-01, & - &9.319400e-01,1.287300e-01,1.289400e-01,4.768200e-01,7.187400e-01, & - &9.002800e-01,9.359300e-01,1.333200e-01,1.335200e-01,4.822700e-01, & - &7.202000e-01,8.959200e-01,9.381200e-01,1.380600e-01,1.382600e-01, & - &4.868900e-01,7.211000e-01,8.900300e-01,9.386500e-01,1.430400e-01, & - &1.432300e-01,4.909700e-01,7.215700e-01,8.836600e-01,9.377400e-01, & - &1.082400e-01,1.084500e-01,4.408400e-01,6.623700e-01,8.284000e-01, & - &8.541600e-01,1.121500e-01,1.123700e-01,4.474100e-01,6.656000e-01, & - &8.272100e-01,8.588000e-01,1.161000e-01,1.163100e-01,4.532800e-01, & - &6.684400e-01,8.243300e-01,8.621700e-01,1.203100e-01,1.205200e-01, & - &4.583100e-01,6.711200e-01,8.210100e-01,8.647000e-01,1.251300e-01, & - &1.253500e-01,4.622800e-01,6.732100e-01,8.177300e-01,8.668100e-01, & - &9.413600e-02,9.435600e-02,4.081200e-01,6.055700e-01,7.510200e-01, & - &7.733400e-01,9.745300e-02,9.768000e-02,4.147900e-01,6.099400e-01, & - &7.509000e-01,7.790900e-01,1.009700e-01,1.012000e-01,4.207500e-01, & - &6.144600e-01,7.503900e-01,7.845800e-01,1.050500e-01,1.052700e-01, & - &4.258300e-01,6.184500e-01,7.503600e-01,7.897700e-01,1.099300e-01, & - &1.101600e-01,4.299100e-01,6.215600e-01,7.507300e-01,7.951000e-01, & - &8.134900e-02,8.158400e-02,3.735400e-01,5.479600e-01,6.735600e-01, & - &6.929100e-01,8.427600e-02,8.451000e-02,3.802100e-01,5.538600e-01, & - &6.757000e-01,7.006500e-01,8.764000e-02,8.787400e-02,3.859800e-01, & - &5.594800e-01,6.783800e-01,7.084400e-01,9.178000e-02,9.202100e-02, & - &3.910200e-01,5.647300e-01,6.817500e-01,7.165100e-01,9.668600e-02, & - &9.693900e-02,3.953300e-01,5.695000e-01,6.860200e-01,7.245600e-01, & - &6.999000e-02,7.023700e-02,3.385800e-01,4.921700e-01,5.997700e-01, & - &6.160200e-01,7.271300e-02,7.295900e-02,3.448300e-01,4.990100e-01, & - &6.046700e-01,6.257200e-01,7.609200e-02,7.633900e-02,3.505200e-01, & - &5.058600e-01,6.103900e-01,6.359300e-01,8.027200e-02,8.053100e-02, & - &3.558500e-01,5.125000e-01,6.172900e-01,6.460200e-01,8.504300e-02, & - &8.530700e-02,3.609500e-01,5.191400e-01,6.246700e-01,6.547900e-01/ - data absb(361:720,8) / & - &6.005800e-02,6.032500e-02,3.040400e-01,4.393100e-01,5.318000e-01, & - &5.448800e-01,6.280800e-02,6.307000e-02,3.101900e-01,4.472000e-01, & - &5.392700e-01,5.564700e-01,6.625300e-02,6.651700e-02,3.162000e-01, & - &4.551500e-01,5.480400e-01,5.679300e-01,7.028600e-02,7.056400e-02, & - &3.221000e-01,4.631700e-01,5.572900e-01,5.774800e-01,7.463100e-02, & - &7.490400e-02,3.281800e-01,4.708400e-01,5.653500e-01,5.842800e-01, & - &5.165900e-02,5.196800e-02,2.713600e-01,3.904400e-01,4.706100e-01, & - &4.806600e-01,5.445400e-02,5.474900e-02,2.778000e-01,3.992500e-01, & - &4.806000e-01,4.928000e-01,5.786400e-02,5.816000e-02,2.842700e-01, & - &4.081800e-01,4.909200e-01,5.028900e-01,6.155100e-02,6.184900e-02, & - &2.909500e-01,4.168500e-01,4.999800e-01,5.103300e-01,6.543400e-02, & - &6.572400e-02,2.980600e-01,4.245300e-01,5.071600e-01,5.146900e-01, & - &4.457400e-02,4.495900e-02,2.412600e-01,3.460900e-01,4.162900e-01, & - &4.224800e-01,4.737200e-02,4.772700e-02,2.480300e-01,3.554800e-01, & - &4.272100e-01,4.329100e-01,5.050900e-02,5.085500e-02,2.550500e-01, & - &3.646400e-01,4.368700e-01,4.406700e-01,5.385700e-02,5.418700e-02, & - &2.624200e-01,3.728100e-01,4.447800e-01,4.453100e-01,5.727500e-02, & - &5.758900e-02,2.702900e-01,3.799700e-01,4.505500e-01,4.465100e-01, & - &3.859500e-02,3.908300e-02,2.140900e-01,3.062600e-01,3.675800e-01, & - &3.687000e-01,4.125000e-02,4.170100e-02,2.211500e-01,3.155200e-01, & - &3.775600e-01,3.766400e-01,4.409000e-02,4.451000e-02,2.285800e-01, & - &3.239100e-01,3.857900e-01,3.814400e-01,4.700600e-02,4.739100e-02, & - &2.363800e-01,3.313600e-01,3.919300e-01,3.829900e-01,5.005400e-02, & - &5.040200e-02,2.445200e-01,3.379100e-01,3.958000e-01,3.818600e-01, & - &3.347600e-02,3.409800e-02,1.898500e-01,2.704400e-01,3.231000e-01, & - &3.191000e-01,3.590500e-02,3.647300e-02,1.971000e-01,2.788100e-01, & - &3.314700e-01,3.240900e-01,3.842000e-02,3.893300e-02,2.046800e-01, & - &2.862900e-01,3.377500e-01,3.261100e-01,4.104300e-02,4.150200e-02, & - &2.126100e-01,2.928400e-01,3.418700e-01,3.258400e-01,4.376400e-02, & - &4.416300e-02,2.206900e-01,2.987900e-01,3.441400e-01,3.238200e-01, & - &2.905900e-02,2.983300e-02,1.683100e-01,2.378900e-01,2.822800e-01, & - &2.733000e-01,3.123600e-02,3.193400e-02,1.755400e-01,2.452400e-01, & - &2.886100e-01,2.758300e-01,3.347300e-02,3.409500e-02,1.831400e-01, & - &2.516600e-01,2.929700e-01,2.762800e-01,3.582900e-02,3.637000e-02, & - &1.909900e-01,2.574300e-01,2.957300e-01,2.752600e-01,3.834200e-02, & - &3.880600e-02,1.988900e-01,2.629100e-01,2.975300e-01,2.730800e-01, & - &2.521500e-02,2.614400e-02,1.491900e-01,2.084100e-01,2.447900e-01, & - &2.319800e-01,2.714400e-02,2.797900e-02,1.563400e-01,2.146200e-01, & - &2.494000e-01,2.331100e-01,2.916900e-02,2.990700e-02,1.638000e-01, & - &2.202000e-01,2.525000e-01,2.329100e-01,3.133900e-02,3.197500e-02, & - &1.714500e-01,2.256000e-01,2.548400e-01,2.316900e-01,3.371000e-02, & - &3.424800e-02,1.789700e-01,2.312200e-01,2.568100e-01,2.296800e-01, & - &2.190800e-02,2.298800e-02,1.323400e-01,1.817900e-01,2.109800e-01, & - &1.956700e-01,2.364400e-02,2.461700e-02,1.393200e-01,1.871200e-01, & - &2.143800e-01,1.961400e-01,2.549300e-02,2.634500e-02,1.465500e-01, & - &1.923700e-01,2.170500e-01,1.957000e-01,2.751800e-02,2.825200e-02, & - &1.538000e-01,1.979000e-01,2.194800e-01,1.945500e-01,2.977300e-02, & - &3.038700e-02,1.609800e-01,2.038300e-01,2.219000e-01,1.928600e-01, & - &1.904500e-02,2.026100e-02,1.175200e-01,1.581200e-01,1.811000e-01, & - &1.644800e-01,2.062600e-02,2.172400e-02,1.242300e-01,1.630700e-01, & - &1.839700e-01,1.646400e-01,2.233600e-02,2.330200e-02,1.311400e-01, & - &1.683900e-01,1.866400e-01,1.641800e-01,2.426600e-02,2.509300e-02, & - &1.381100e-01,1.742100e-01,1.893800e-01,1.632500e-01,2.646600e-02, & - &2.716400e-02,1.451300e-01,1.804800e-01,1.923800e-01,1.621100e-01, & - &1.655600e-02,1.789200e-02,1.042900e-01,1.373600e-01,1.551600e-01, & - &1.378900e-01,1.799600e-02,1.921000e-02,1.107200e-01,1.423600e-01, & - &1.579400e-01,1.379700e-01,1.960800e-02,2.068100e-02,1.173900e-01, & - &1.478800e-01,1.608100e-01,1.376400e-01,2.146400e-02,2.238700e-02, & - &1.242100e-01,1.539600e-01,1.639500e-01,1.370600e-01,2.359400e-02, & - &2.437900e-02,1.312600e-01,1.604800e-01,1.675600e-01,1.364500e-01, & - &1.431900e-02,1.575800e-02,9.220400e-02,1.192500e-01,1.328600e-01, & - &1.154800e-01,1.565200e-02,1.697800e-02,9.839900e-02,1.243300e-01, & - &1.356700e-01,1.156400e-01,1.716900e-02,1.835000e-02,1.048700e-01, & - &1.300300e-01,1.387900e-01,1.155400e-01,1.894400e-02,1.997500e-02, & - &1.116700e-01,1.362900e-01,1.423600e-01,1.153400e-01,2.093800e-02, & - &2.182400e-02,1.187700e-01,1.429400e-01,1.465100e-01,1.152200e-01, & - &1.230400e-02,1.382900e-02,8.112000e-02,1.033400e-01,1.136600e-01, & - &9.668600e-02,1.351700e-02,1.494200e-02,8.708200e-02,1.085000e-01, & - &1.166000e-01,9.698100e-02,1.493900e-02,1.623200e-02,9.343900e-02, & - &1.143100e-01,1.199500e-01,9.708500e-02,1.660400e-02,1.775400e-02, & - &1.002000e-01,1.206100e-01,1.238400e-01,9.724500e-02,1.845800e-02, & - &1.945800e-02,1.073200e-01,1.274100e-01,1.284000e-01,9.761100e-02/ - data absb(721:1080,8) / & - &1.044100e-02,1.203700e-02,7.073300e-02,8.910400e-02,9.700600e-02, & - &8.085300e-02,1.153800e-02,1.305500e-02,7.644400e-02,9.422700e-02, & - &1.000200e-01,8.126100e-02,1.284000e-02,1.424700e-02,8.265300e-02, & - &9.999200e-02,1.035100e-01,8.158700e-02,1.435500e-02,1.563400e-02, & - &8.931200e-02,1.062900e-01,1.076100e-01,8.202200e-02,1.605900e-02, & - &1.718800e-02,9.639400e-02,1.131600e-01,1.124000e-01,8.273100e-02, & - &8.864500e-03,1.050100e-02,6.169800e-02,7.690800e-02,8.288300e-02, & - &6.764200e-02,9.855400e-03,1.144100e-02,6.721300e-02,8.195400e-02, & - &8.593100e-02,6.815000e-02,1.104100e-02,1.254000e-02,7.325800e-02, & - &8.764200e-02,8.950600e-02,6.866700e-02,1.243000e-02,1.381700e-02, & - &7.980100e-02,9.393600e-02,9.378200e-02,6.933900e-02,1.398300e-02, & - &1.523500e-02,8.681400e-02,1.008300e-01,9.874200e-02,7.031900e-02, & - &7.540400e-03,9.187400e-03,5.390600e-02,6.649500e-02,7.090200e-02, & - &5.665700e-02,8.434000e-03,1.006100e-02,5.924500e-02,7.143500e-02, & - &7.397900e-02,5.726100e-02,9.524200e-03,1.108900e-02,6.513200e-02, & - &7.704800e-02,7.763600e-02,5.794300e-02,1.078100e-02,1.225900e-02, & - &7.154900e-02,8.332600e-02,8.200400e-02,5.882300e-02,1.221300e-02, & - &1.357000e-02,7.848800e-02,9.023400e-02,8.713900e-02,6.004500e-02, & - &6.348000e-03,7.984100e-03,4.670700e-02,5.715400e-02,6.047800e-02, & - &4.730900e-02,7.141600e-03,8.787600e-03,5.179900e-02,6.189200e-02, & - &6.350400e-02,4.796900e-02,8.111300e-03,9.727400e-03,5.748400e-02, & - &6.735000e-02,6.714000e-02,4.871800e-02,9.246500e-03,1.080100e-02, & - &6.370700e-02,7.351100e-02,7.149700e-02,4.967600e-02,1.054400e-02, & - &1.200100e-02,7.050500e-02,8.036800e-02,7.667400e-02,5.098100e-02, & - &5.339100e-03,6.938300e-03,4.042100e-02,4.910400e-02,5.156700e-02, & - &3.949500e-02,6.042000e-03,7.678500e-03,4.526000e-02,5.361700e-02, & - &5.452300e-02,4.017400e-02,6.901700e-03,8.538900e-03,5.072600e-02, & - &5.888600e-02,5.810600e-02,4.095000e-02,7.921500e-03,9.528100e-03, & - &5.675800e-02,6.489400e-02,6.242500e-02,4.195300e-02,9.095800e-03, & - &1.063200e-02,6.338000e-02,7.166500e-02,6.757500e-02,4.329400e-02, & - &4.487400e-03,6.027700e-03,3.497300e-02,4.218100e-02,4.397200e-02, & - &3.297600e-02,5.108400e-03,6.711700e-03,3.956900e-02,4.648100e-02, & - &4.683800e-02,3.365600e-02,5.877400e-03,7.509200e-03,4.479300e-02, & - &5.153400e-02,5.034900e-02,3.444000e-02,6.790600e-03,8.422700e-03, & - &5.063100e-02,5.738400e-02,5.462000e-02,3.546200e-02,7.852500e-03, & - &9.446700e-03,5.708200e-02,6.404400e-02,5.971800e-02,3.682400e-02, & - &3.742200e-03,5.203300e-03,3.002400e-02,3.602200e-02,3.735800e-02, & - &2.748600e-02,4.285500e-03,5.831600e-03,3.434400e-02,4.007000e-02, & - &4.008900e-02,2.815400e-02,4.963800e-03,6.566600e-03,3.929600e-02, & - &4.487000e-02,4.347200e-02,2.892900e-02,5.773600e-03,7.407100e-03, & - &4.488300e-02,5.047800e-02,4.761400e-02,2.992000e-02,6.726900e-03, & - &8.354700e-03,5.112600e-02,5.694600e-02,5.260300e-02,3.125900e-02, & - &3.112300e-03,4.478700e-03,2.562900e-02,3.064500e-02,3.166200e-02, & - &2.289100e-02,3.581900e-03,5.051000e-03,2.966200e-02,3.440400e-02, & - &3.421300e-02,2.352500e-02,4.171700e-03,5.721900e-03,3.433700e-02, & - &3.894100e-02,3.743700e-02,2.427400e-02,4.887400e-03,6.499700e-03, & - &3.965100e-02,4.427800e-02,4.143100e-02,2.522900e-02,5.737700e-03, & - &7.372600e-03,4.564900e-02,5.051100e-02,4.626500e-02,2.652600e-02, & - &2.585300e-03,3.851300e-03,2.182300e-02,2.602600e-02,2.680400e-02, & - &1.905800e-02,2.988800e-03,4.371900e-03,2.556300e-02,2.950200e-02, & - &2.918200e-02,1.966800e-02,3.503700e-03,4.983200e-03,2.995700e-02, & - &3.376300e-02,3.221300e-02,2.037900e-02,4.132200e-03,5.699500e-03, & - &3.500000e-02,3.882400e-02,3.603200e-02,2.128600e-02,4.889200e-03, & - &6.506000e-03,4.074100e-02,4.479300e-02,4.069900e-02,2.253300e-02, & - &2.133100e-03,3.290900e-03,1.846100e-02,2.199600e-02,2.262300e-02, & - &1.585100e-02,2.481500e-03,3.768600e-03,2.189300e-02,2.518100e-02, & - &2.480500e-02,1.641800e-02,2.925500e-03,4.322400e-03,2.599200e-02, & - &2.913500e-02,2.762000e-02,1.708200e-02,3.477300e-03,4.979400e-03, & - &3.075400e-02,3.390500e-02,3.123300e-02,1.794200e-02,4.143900e-03, & - &5.724000e-03,3.620900e-02,3.957900e-02,3.570500e-02,1.912400e-02, & - &1.748900e-03,2.791700e-03,1.543900e-02,1.842200e-02,1.897800e-02, & - &1.313400e-02,2.042800e-03,3.223400e-03,1.854100e-02,2.130200e-02, & - &2.095200e-02,1.366100e-02,2.419200e-03,3.722300e-03,2.231400e-02, & - &2.492700e-02,2.352500e-02,1.427300e-02,2.896900e-03,4.317100e-03, & - &2.676400e-02,2.935600e-02,2.687400e-02,1.505800e-02,3.480700e-03, & - &5.000600e-03,3.190600e-02,3.469300e-02,3.109400e-02,1.614200e-02, & - &1.432700e-03,2.361800e-03,1.285100e-02,1.537200e-02,1.588500e-02, & - &1.088300e-02,1.678500e-03,2.749500e-03,1.562600e-02,1.795000e-02, & - &1.765400e-02,1.136600e-02,1.996700e-03,3.198600e-03,1.906900e-02, & - &2.125200e-02,1.998700e-02,1.192200e-02,2.406700e-03,3.735000e-03, & - &2.320300e-02,2.533900e-02,2.306600e-02,1.264000e-02,2.915600e-03, & - &4.359700e-03,2.803500e-02,3.033500e-02,2.701000e-02,1.363500e-02/ - data absb(1081:1410,8) / & - &1.168900e-03,1.988300e-03,1.064400e-02,1.277400e-02,1.325700e-02, & - &9.010200e-03,1.377800e-03,2.338000e-03,1.310000e-02,1.505400e-02, & - &1.483000e-02,9.452800e-03,1.643700e-03,2.741700e-03,1.621300e-02, & - &1.804200e-02,1.692800e-02,9.961200e-03,1.994000e-03,3.223600e-03, & - &2.002400e-02,2.180000e-02,1.973900e-02,1.062000e-02,2.434600e-03, & - &3.794200e-03,2.454800e-02,2.644000e-02,2.339600e-02,1.153400e-02, & - &9.560700e-04,1.675300e-03,8.816700e-03,1.061200e-02,1.105200e-02, & - &7.437300e-03,1.131600e-03,1.989700e-03,1.098300e-02,1.262100e-02, & - &1.245600e-02,7.836800e-03,1.356500e-03,2.353700e-03,1.379000e-02, & - &1.532000e-02,1.434600e-02,8.291800e-03,1.656300e-03,2.788800e-03, & - &1.729500e-02,1.878000e-02,1.691500e-02,8.883200e-03,2.037900e-03, & - &3.308500e-03,2.152400e-02,2.309200e-02,2.030500e-02,9.714400e-03, & - &7.825000e-04,1.409200e-03,7.289600e-03,8.796500e-03,9.193000e-03, & - &6.125200e-03,9.296300e-04,1.691700e-03,9.185600e-03,1.055600e-02, & - &1.044200e-02,6.481800e-03,1.119900e-03,2.020500e-03,1.170600e-02, & - &1.298100e-02,1.214600e-02,6.889900e-03,1.375400e-03,2.411600e-03, & - &1.491000e-02,1.615700e-02,1.448400e-02,7.415100e-03,1.705700e-03, & - &2.885000e-03,1.884800e-02,2.016200e-02,1.761700e-02,8.157100e-03, & - &6.374000e-04,1.179500e-03,6.005800e-03,7.269400e-03,7.623100e-03, & - &5.041300e-03,7.629200e-04,1.434500e-03,7.647300e-03,8.797600e-03, & - &8.727400e-03,5.362100e-03,9.227600e-04,1.730100e-03,9.888400e-03, & - &1.094900e-02,1.025000e-02,5.726200e-03,1.139000e-03,2.081700e-03, & - &1.279700e-02,1.384200e-02,1.236700e-02,6.191100e-03,1.424000e-03, & - &2.509900e-03,1.643800e-02,1.754900e-02,1.524800e-02,6.852800e-03, & - &5.173200e-04,9.817800e-04,4.929100e-03,5.986100e-03,6.301300e-03, & - &4.147800e-03,6.231900e-04,1.210100e-03,6.334200e-03,7.298200e-03, & - &7.266800e-03,4.435500e-03,7.589600e-04,1.477200e-03,8.307300e-03, & - &9.188400e-03,8.616600e-03,4.761500e-03,9.403200e-04,1.792300e-03, & - &1.092600e-02,1.179500e-02,1.052200e-02,5.176000e-03,1.185500e-03, & - &2.177900e-03,1.426700e-02,1.521100e-02,1.315100e-02,5.767500e-03, & - &4.209900e-04,8.189600e-04,4.058700e-03,4.941400e-03,5.212200e-03, & - &3.395400e-03,5.107200e-04,1.023200e-03,5.265900e-03,6.069200e-03, & - &6.057700e-03,3.646100e-03,6.263000e-04,1.264000e-03,7.001000e-03, & - &7.731600e-03,7.254500e-03,3.926900e-03,7.806500e-04,1.549800e-03, & - &9.360200e-03,1.008000e-02,8.977900e-03,4.279800e-03,9.913300e-04, & - &1.897600e-03,1.242700e-02,1.323100e-02,1.138800e-02,4.788100e-03, & - &3.426400e-04,6.819600e-04,3.341800e-03,4.078600e-03,4.307700e-03, & - &2.769100e-03,4.182700e-04,8.640700e-04,4.377200e-03,5.043800e-03, & - &5.043900e-03,2.983600e-03,5.165100e-04,1.080900e-03,5.897700e-03, & - &6.500300e-03,6.100700e-03,3.220800e-03,6.475500e-04,1.339400e-03, & - &8.014300e-03,8.608400e-03,7.658500e-03,3.514300e-03,8.291300e-04, & - &1.655300e-03,1.082100e-02,1.150400e-02,9.866800e-03,3.938300e-03, & - &2.780300e-04,5.648700e-04,2.742000e-03,3.356800e-03,3.549600e-03, & - &2.254300e-03,3.412100e-04,7.262200e-04,3.622800e-03,4.178100e-03, & - &4.186200e-03,2.438200e-03,4.244900e-04,9.214900e-04,4.946900e-03, & - &5.441300e-03,5.111600e-03,2.638700e-03,5.359100e-04,1.154700e-03, & - &6.831600e-03,7.320600e-03,6.507800e-03,2.883000e-03,6.920600e-04, & - &1.441300e-03,9.386500e-03,9.961300e-03,8.522300e-03,3.234400e-03, & - &2.250400e-04,4.650000e-04,2.240300e-03,2.754300e-03,2.916600e-03, & - &1.832300e-03,2.779800e-04,6.078300e-04,2.985100e-03,3.449100e-03, & - &3.462800e-03,1.989700e-03,3.475300e-04,7.822500e-04,4.131200e-03, & - &4.535200e-03,4.265700e-03,2.159300e-03,4.420200e-04,9.927200e-04, & - &5.797300e-03,6.195100e-03,5.506000e-03,2.362800e-03,5.755800e-04, & - &1.251700e-03,8.105800e-03,8.587200e-03,7.336000e-03,2.652200e-03, & - &1.822800e-04,3.820800e-04,1.830800e-03,2.261300e-03,2.397000e-03, & - &1.488100e-03,2.263500e-04,5.077300e-04,2.462500e-03,2.850100e-03, & - &2.864700e-03,1.621900e-03,2.851600e-04,6.641200e-04,3.451900e-03, & - &3.783000e-03,3.559200e-03,1.764200e-03,3.653800e-04,8.544400e-04, & - &4.923000e-03,5.245100e-03,4.658000e-03,1.933600e-03,4.791100e-04, & - &1.088600e-03,7.007000e-03,7.406900e-03,6.320800e-03,2.171500e-03, & - &1.531600e-04,3.300900e-04,1.569700e-03,1.926700e-03,2.028700e-03, & - &1.220300e-03,1.917400e-04,4.447900e-04,2.148300e-03,2.464600e-03, & - &2.452100e-03,1.330100e-03,2.439200e-04,5.896700e-04,3.069000e-03, & - &3.334100e-03,3.101700e-03,1.448100e-03,3.159400e-04,7.676900e-04, & - &4.454500e-03,4.718000e-03,4.152300e-03,1.588400e-03,4.193400e-04, & - &9.885899e-04,6.443000e-03,6.795100e-03,5.762200e-03,1.786700e-03/ - data absb(1:360,9) / & - &2.164000e+00,2.163000e+00,1.903700e+00,1.991400e+00,2.150700e+00, & - &2.192400e+00,2.178000e+00,2.177000e+00,1.904300e+00,1.969200e+00, & - &2.118300e+00,2.170200e+00,2.186300e+00,2.185300e+00,1.900400e+00, & - &1.944300e+00,2.082200e+00,2.153300e+00,2.190800e+00,2.189800e+00, & - &1.893900e+00,1.918300e+00,2.044000e+00,2.139000e+00,2.190500e+00, & - &2.189500e+00,1.883600e+00,1.890200e+00,2.004200e+00,2.125500e+00, & - &1.984700e+00,1.983800e+00,1.830300e+00,2.035300e+00,2.259000e+00, & - &2.308800e+00,1.993400e+00,1.992500e+00,1.825000e+00,2.009100e+00, & - &2.223100e+00,2.280100e+00,1.997600e+00,1.996700e+00,1.817000e+00, & - &1.980200e+00,2.184000e+00,2.256600e+00,1.997400e+00,1.996500e+00, & - &1.805300e+00,1.949500e+00,2.143100e+00,2.237200e+00,1.993900e+00, & - &1.993000e+00,1.790400e+00,1.917700e+00,2.100400e+00,2.219200e+00, & - &1.788900e+00,1.788200e+00,1.754700e+00,2.077900e+00,2.357300e+00, & - &2.429000e+00,1.792800e+00,1.792000e+00,1.745200e+00,2.048600e+00, & - &2.318900e+00,2.403700e+00,1.792800e+00,1.792000e+00,1.733000e+00, & - &2.017100e+00,2.279000e+00,2.377500e+00,1.791700e+00,1.790900e+00, & - &1.718200e+00,1.983800e+00,2.236600e+00,2.352800e+00,1.790700e+00, & - &1.789900e+00,1.701000e+00,1.949500e+00,2.193400e+00,2.331700e+00, & - &1.586900e+00,1.586300e+00,1.688300e+00,2.119300e+00,2.445500e+00, & - &2.549200e+00,1.587400e+00,1.586800e+00,1.675000e+00,2.088100e+00, & - &2.408700e+00,2.525900e+00,1.587900e+00,1.587300e+00,1.659600e+00, & - &2.055900e+00,2.369400e+00,2.500600e+00,1.589300e+00,1.588600e+00, & - &1.642000e+00,2.022100e+00,2.327500e+00,2.475800e+00,1.591500e+00, & - &1.590800e+00,1.622500e+00,1.986000e+00,2.283700e+00,2.453100e+00, & - &1.391100e+00,1.390600e+00,1.635700e+00,2.155100e+00,2.527000e+00, & - &2.655000e+00,1.392400e+00,1.391900e+00,1.619700e+00,2.125100e+00, & - &2.491400e+00,2.634200e+00,1.394800e+00,1.394300e+00,1.601600e+00, & - &2.092700e+00,2.452900e+00,2.610400e+00,1.400100e+00,1.399500e+00, & - &1.582400e+00,2.057300e+00,2.411800e+00,2.586200e+00,1.408900e+00, & - &1.408300e+00,1.563200e+00,2.020200e+00,2.368500e+00,2.562500e+00, & - &1.210900e+00,1.210400e+00,1.596400e+00,2.181400e+00,2.595200e+00, & - &2.738900e+00,1.214000e+00,1.213600e+00,1.578400e+00,2.152500e+00, & - &2.561600e+00,2.720900e+00,1.220800e+00,1.220400e+00,1.559500e+00, & - &2.120100e+00,2.524700e+00,2.700500e+00,1.232200e+00,1.231800e+00, & - &1.540700e+00,2.084900e+00,2.485000e+00,2.678400e+00,1.247700e+00, & - &1.247200e+00,1.523000e+00,2.047800e+00,2.444000e+00,2.655300e+00, & - &1.048700e+00,1.048400e+00,1.564900e+00,2.196800e+00,2.640900e+00, & - &2.796300e+00,1.056000e+00,1.055700e+00,1.547400e+00,2.168700e+00, & - &2.610800e+00,2.782900e+00,1.068500e+00,1.068200e+00,1.529200e+00, & - &2.136800e+00,2.578200e+00,2.764900e+00,1.085900e+00,1.085500e+00, & - &1.512100e+00,2.101900e+00,2.543800e+00,2.744500e+00,1.106500e+00, & - &1.106200e+00,1.497500e+00,2.066100e+00,2.506200e+00,2.722200e+00, & - &9.082700e-01,9.080500e-01,1.534100e+00,2.195600e+00,2.663200e+00, & - &2.824200e+00,9.206400e-01,9.204000e-01,1.517200e+00,2.168700e+00, & - &2.640000e+00,2.814500e+00,9.384400e-01,9.381900e-01,1.501600e+00, & - &2.138800e+00,2.612900e+00,2.800000e+00,9.601300e-01,9.598600e-01, & - &1.488500e+00,2.107100e+00,2.581400e+00,2.782800e+00,9.843000e-01, & - &9.840000e-01,1.477100e+00,2.074100e+00,2.545400e+00,2.763600e+00, & - &7.899300e-01,7.897800e-01,1.498600e+00,2.173300e+00,2.662300e+00, & - &2.817900e+00,8.066700e-01,8.065000e-01,1.484800e+00,2.149600e+00, & - &2.644600e+00,2.812900e+00,8.280200e-01,8.278400e-01,1.473300e+00, & - &2.123500e+00,2.620800e+00,2.802900e+00,8.523200e-01,8.521100e-01, & - &1.463900e+00,2.096000e+00,2.591300e+00,2.789800e+00,8.789900e-01, & - &8.787600e-01,1.456600e+00,2.068100e+00,2.557600e+00,2.772700e+00, & - &6.921700e-01,6.920700e-01,1.456700e+00,2.129400e+00,2.632000e+00, & - &2.778900e+00,7.122000e-01,7.120900e-01,1.447800e+00,2.110600e+00, & - &2.617300e+00,2.778300e+00,7.356600e-01,7.355300e-01,1.441300e+00, & - &2.089700e+00,2.596300e+00,2.772200e+00,7.612800e-01,7.611300e-01, & - &1.436300e+00,2.068200e+00,2.570300e+00,2.762400e+00,7.857400e-01, & - &7.855500e-01,1.432700e+00,2.047700e+00,2.540100e+00,2.749200e+00, & - &6.100800e-01,6.100300e-01,1.408300e+00,2.068100e+00,2.570500e+00, & - &2.708300e+00,6.319800e-01,6.319200e-01,1.405100e+00,2.054800e+00, & - &2.559300e+00,2.711700e+00,6.554300e-01,6.553500e-01,1.404000e+00, & - &2.040300e+00,2.542700e+00,2.710200e+00,6.783700e-01,6.782600e-01, & - &1.404100e+00,2.026300e+00,2.521300e+00,2.706000e+00,7.003000e-01, & - &7.001600e-01,1.405000e+00,2.012700e+00,2.496100e+00,2.699400e+00, & - &5.403300e-01,5.403300e-01,1.354600e+00,1.989900e+00,2.482200e+00, & - &2.608400e+00,5.613900e-01,5.613800e-01,1.357700e+00,1.983600e+00, & - &2.475900e+00,2.617400e+00,5.824500e-01,5.824200e-01,1.361800e+00, & - &1.977000e+00,2.464900e+00,2.623200e+00,6.024100e-01,6.023300e-01, & - &1.366400e+00,1.970700e+00,2.449800e+00,2.626800e+00,6.216500e-01, & - &6.215500e-01,1.369900e+00,1.964600e+00,2.432100e+00,2.627700e+00/ - data absb(361:720,9) / & - &4.783200e-01,4.783600e-01,1.297400e+00,1.900000e+00,2.373000e+00, & - &2.487500e+00,4.973300e-01,4.973500e-01,1.305700e+00,1.901400e+00, & - &2.373400e+00,2.503800e+00,5.152300e-01,5.152200e-01,1.314600e+00, & - &1.903100e+00,2.369900e+00,2.518300e+00,5.325600e-01,5.325100e-01, & - &1.322800e+00,1.905100e+00,2.363700e+00,2.532000e+00,5.496800e-01, & - &5.496100e-01,1.329200e+00,1.906800e+00,2.356100e+00,2.543800e+00, & - &4.220100e-01,4.220700e-01,1.236400e+00,1.802900e+00,2.250700e+00, & - &2.353300e+00,4.380400e-01,4.380900e-01,1.249800e+00,1.812600e+00, & - &2.259700e+00,2.378800e+00,4.535400e-01,4.535600e-01,1.263200e+00, & - &1.822900e+00,2.265700e+00,2.404700e+00,4.690600e-01,4.690400e-01, & - &1.274600e+00,1.833300e+00,2.270600e+00,2.430400e+00,4.849700e-01, & - &4.849400e-01,1.283900e+00,1.842900e+00,2.274400e+00,2.454400e+00, & - &3.703600e-01,3.704500e-01,1.173400e+00,1.702900e+00,2.123300e+00, & - &2.215200e+00,3.839800e-01,3.840600e-01,1.191800e+00,1.721800e+00, & - &2.142000e+00,2.252700e+00,3.978700e-01,3.979100e-01,1.208500e+00, & - &1.741200e+00,2.159600e+00,2.291700e+00,4.122700e-01,4.122900e-01, & - &1.223500e+00,1.760400e+00,2.176400e+00,2.330700e+00,4.278000e-01, & - &4.277900e-01,1.235800e+00,1.778500e+00,2.192400e+00,2.367800e+00, & - &3.238400e-01,3.239600e-01,1.111100e+00,1.605000e+00,1.996600e+00, & - &2.081400e+00,3.360300e-01,3.361300e-01,1.133200e+00,1.633200e+00, & - &2.027100e+00,2.132400e+00,3.488100e-01,3.488700e-01,1.153600e+00, & - &1.662200e+00,2.057300e+00,2.185000e+00,3.626800e-01,3.627300e-01, & - &1.172000e+00,1.690000e+00,2.087000e+00,2.237300e+00,3.780400e-01, & - &3.780600e-01,1.187700e+00,1.717300e+00,2.116200e+00,2.286900e+00, & - &2.831200e-01,2.832600e-01,1.050800e+00,1.513000e+00,1.878000e+00, & - &1.958900e+00,2.943400e-01,2.944500e-01,1.076600e+00,1.551100e+00, & - &1.921000e+00,2.024300e+00,3.065200e-01,3.066100e-01,1.100900e+00, & - &1.588900e+00,1.964200e+00,2.090700e+00,3.201600e-01,3.202300e-01, & - &1.122600e+00,1.626100e+00,2.007100e+00,2.154800e+00,3.357100e-01, & - &3.357700e-01,1.142100e+00,1.661500e+00,2.048500e+00,2.215100e+00, & - &2.476600e-01,2.478200e-01,9.943300e-01,1.430400e+00,1.771500e+00, & - &1.851400e+00,2.583700e-01,2.585000e-01,1.024100e+00,1.477500e+00, & - &1.827100e+00,1.930200e+00,2.704500e-01,2.705600e-01,1.051700e+00, & - &1.524400e+00,1.883300e+00,2.008400e+00,2.842700e-01,2.843600e-01, & - &1.077300e+00,1.570100e+00,1.938000e+00,2.082900e+00,3.001300e-01, & - &3.002100e-01,1.100500e+00,1.613000e+00,1.989700e+00,2.153000e+00, & - &2.171800e-01,2.173500e-01,9.433600e-01,1.359200e+00,1.680200e+00, & - &1.762300e+00,2.277300e-01,2.278700e-01,9.766700e-01,1.414700e+00, & - &1.748000e+00,1.853000e+00,2.399500e-01,2.400700e-01,1.008000e+00, & - &1.469900e+00,1.815100e+00,1.940900e+00,2.541400e-01,2.542400e-01, & - &1.037100e+00,1.522700e+00,1.879500e+00,2.025100e+00,2.701800e-01, & - &2.702800e-01,1.064400e+00,1.571700e+00,1.939700e+00,2.103800e+00, & - &1.912600e-01,1.914600e-01,8.985300e-01,1.299700e+00,1.604600e+00, & - &1.690100e+00,2.019300e-01,2.020900e-01,9.354000e-01,1.363200e+00, & - &1.682900e+00,1.790100e+00,2.144500e-01,2.145900e-01,9.703600e-01, & - &1.425100e+00,1.759300e+00,1.887600e+00,2.289000e-01,2.290200e-01, & - &1.003200e+00,1.483400e+00,1.831900e+00,1.980100e+00,2.447600e-01, & - &2.448800e-01,1.034100e+00,1.537300e+00,1.899500e+00,2.066200e+00, & - &1.694000e-01,1.696200e-01,8.604000e-01,1.251600e+00,1.544000e+00, & - &1.633600e+00,1.804000e-01,1.805800e-01,9.006900e-01,1.321700e+00, & - &1.631300e+00,1.742700e+00,1.932200e-01,1.933800e-01,9.390500e-01, & - &1.388700e+00,1.715500e+00,1.848300e+00,2.075900e-01,2.077400e-01, & - &9.752500e-01,1.451800e+00,1.795000e+00,1.947700e+00,2.228700e-01, & - &2.230000e-01,1.009500e+00,1.510300e+00,1.868800e+00,2.039800e+00, & - &1.507600e-01,1.510100e-01,8.274900e-01,1.211500e+00,1.494400e+00, & - &1.586200e+00,1.620300e-01,1.622400e-01,8.709700e-01,1.286700e+00, & - &1.589100e+00,1.703400e+00,1.749200e-01,1.751000e-01,9.124400e-01, & - &1.358400e+00,1.680000e+00,1.815200e+00,1.888400e-01,1.890000e-01, & - &9.516400e-01,1.425700e+00,1.765400e+00,1.920700e+00,2.034700e-01, & - &2.036100e-01,9.885800e-01,1.488200e+00,1.844100e+00,2.018200e+00, & - &1.341000e-01,1.344200e-01,7.962100e-01,1.172600e+00,1.447000e+00, & - &1.540200e+00,1.454200e-01,1.456700e-01,8.426200e-01,1.252300e+00, & - &1.548400e+00,1.663600e+00,1.580200e-01,1.582300e-01,8.869800e-01, & - &1.328300e+00,1.645400e+00,1.781800e+00,1.713500e-01,1.715300e-01, & - &9.289400e-01,1.399900e+00,1.736100e+00,1.893200e+00,1.854000e-01, & - &1.855600e-01,9.684100e-01,1.466400e+00,1.819500e+00,1.996700e+00, & - &1.188500e-01,1.192700e-01,7.645900e-01,1.131800e+00,1.397800e+00, & - &1.489900e+00,1.299000e-01,1.302200e-01,8.138200e-01,1.215800e+00, & - &1.505200e+00,1.619500e+00,1.420100e-01,1.422600e-01,8.609400e-01, & - &1.296200e+00,1.607900e+00,1.744100e+00,1.547800e-01,1.549900e-01, & - &9.055100e-01,1.372000e+00,1.703900e+00,1.861400e+00,1.683600e-01, & - &1.685400e-01,9.476500e-01,1.442400e+00,1.792000e+00,1.970100e+00/ - data absb(721:1080,9) / & - &1.042800e-01,1.048500e-01,7.289900e-01,1.083500e+00,1.338800e+00, & - &1.425900e+00,1.148100e-01,1.152500e-01,7.811800e-01,1.171900e+00, & - &1.452200e+00,1.561600e+00,1.262900e-01,1.266200e-01,8.310800e-01, & - &1.256600e+00,1.560700e+00,1.692500e+00,1.385100e-01,1.387600e-01, & - &8.784800e-01,1.337000e+00,1.662400e+00,1.816100e+00,1.515600e-01, & - &1.517700e-01,9.233900e-01,1.411600e+00,1.755800e+00,1.930900e+00, & - &9.160500e-02,9.234300e-02,6.961000e-01,1.038800e+00,1.284500e+00, & - &1.367400e+00,1.015800e-01,1.021500e-01,7.508800e-01,1.131100e+00, & - &1.403200e+00,1.508700e+00,1.124700e-01,1.128900e-01,8.033900e-01, & - &1.220000e+00,1.516900e+00,1.645300e+00,1.241700e-01,1.244800e-01, & - &8.533800e-01,1.304200e+00,1.623600e+00,1.775000e+00,1.367600e-01, & - &1.370000e-01,9.008300e-01,1.382800e+00,1.721700e+00,1.895200e+00, & - &8.065600e-02,8.159400e-02,6.660700e-01,9.981500e-01,1.235100e+00, & - &1.315200e+00,9.006900e-02,9.078600e-02,7.232100e-01,1.094100e+00, & - &1.358400e+00,1.461700e+00,1.003800e-01,1.009200e-01,7.781400e-01, & - &1.186400e+00,1.476700e+00,1.603700e+00,1.116000e-01,1.120000e-01, & - &8.305000e-01,1.274200e+00,1.587900e+00,1.739200e+00,1.238100e-01, & - &1.241000e-01,8.802600e-01,1.356400e+00,1.690300e+00,1.864200e+00, & - &7.034300e-02,7.151700e-02,6.325800e-01,9.507400e-01,1.176800e+00, & - &1.249500e+00,7.910300e-02,8.002000e-02,6.918900e-01,1.050100e+00, & - &1.304500e+00,1.400300e+00,8.879000e-02,8.949200e-02,7.492500e-01, & - &1.146100e+00,1.427400e+00,1.547600e+00,9.946100e-02,9.997700e-02, & - &8.041400e-01,1.237500e+00,1.543400e+00,1.688400e+00,1.111400e-01, & - &1.115100e-01,8.563300e-01,1.323600e+00,1.650700e+00,1.819100e+00, & - &6.126600e-02,6.269600e-02,6.002200e-01,9.045000e-01,1.119800e+00, & - &1.185200e+00,6.944900e-02,7.059300e-02,6.616100e-01,1.007000e+00, & - &1.251300e+00,1.339900e+00,7.851700e-02,7.940900e-02,7.212100e-01, & - &1.106300e+00,1.378500e+00,1.491600e+00,8.861000e-02,8.927600e-02, & - &7.783900e-01,1.201200e+00,1.499000e+00,1.637400e+00,9.977400e-02, & - &1.002600e-01,8.328400e-01,1.290600e+00,1.610800e+00,1.773700e+00, & - &5.336000e-02,5.505900e-02,5.696600e-01,8.603800e-01,1.065500e+00, & - &1.124300e+00,6.099300e-02,6.238200e-02,6.328000e-01,9.656200e-01, & - &1.200100e+00,1.282300e+00,6.950700e-02,7.061000e-02,6.944500e-01, & - &1.067900e+00,1.331100e+00,1.438000e+00,7.903200e-02,7.987100e-02, & - &7.537600e-01,1.165800e+00,1.455500e+00,1.588300e+00,8.968400e-02, & - &9.030300e-02,8.103100e-01,1.258500e+00,1.571700e+00,1.729800e+00, & - &4.613600e-02,4.812500e-02,5.370400e-01,8.122000e-01,1.005800e+00, & - &1.056900e+00,5.316100e-02,5.482300e-02,6.016800e-01,9.198200e-01, & - &1.143100e+00,1.217700e+00,6.112300e-02,6.247000e-02,6.653200e-01, & - &1.024900e+00,1.277500e+00,1.377000e+00,7.004900e-02,7.109800e-02, & - &7.267300e-01,1.125900e+00,1.406000e+00,1.531800e+00,8.011900e-02, & - &8.090800e-02,7.853400e-01,1.221800e+00,1.526600e+00,1.678600e+00, & - &3.968500e-02,4.197200e-02,5.041200e-01,7.629600e-01,9.442800e-01, & - &9.878700e-01,4.615200e-02,4.810300e-02,5.700400e-01,8.724000e-01, & - &1.083800e+00,1.150800e+00,5.352900e-02,5.514300e-02,6.353600e-01, & - &9.800200e-01,1.221300e+00,1.313200e+00,6.190100e-02,6.318300e-02, & - &6.987900e-01,1.084000e+00,1.353600e+00,1.472300e+00,7.135400e-02, & - &7.234700e-02,7.593900e-01,1.182900e+00,1.478400e+00,1.624200e+00, & - &3.407600e-02,3.665100e-02,4.723800e-01,7.151100e-01,8.844000e-01, & - &9.213000e-01,4.002500e-02,4.226000e-02,5.393900e-01,8.258400e-01, & - &1.025700e+00,1.085800e+00,4.684300e-02,4.873200e-02,6.060700e-01, & - &9.357000e-01,1.165600e+00,1.250900e+00,5.466300e-02,5.619800e-02, & - &6.712500e-01,1.042300e+00,1.301300e+00,1.413700e+00,6.356000e-02, & - &6.477600e-02,7.338100e-01,1.144100e+00,1.429900e+00,1.570500e+00, & - &2.907400e-02,3.193600e-02,4.402100e-01,6.661700e-01,8.230600e-01, & - &8.531100e-01,3.451400e-02,3.703400e-02,5.080300e-01,7.777100e-01, & - &9.653700e-01,1.018400e+00,4.081700e-02,4.298700e-02,5.757900e-01, & - &8.893300e-01,1.107300e+00,1.185600e+00,4.806500e-02,4.987200e-02, & - &6.425500e-01,9.982900e-01,1.246000e+00,1.351700e+00,5.642300e-02, & - &5.788200e-02,7.070000e-01,1.102900e+00,1.378400e+00,1.513100e+00, & - &2.453500e-02,2.768400e-02,4.062800e-01,6.138200e-01,7.574100e-01, & - &7.794900e-01,2.944900e-02,3.226000e-02,4.744300e-01,7.256100e-01, & - &8.997900e-01,9.446800e-01,3.523400e-02,3.769400e-02,5.431600e-01, & - &8.384600e-01,1.043300e+00,1.113000e+00,4.191200e-02,4.400600e-02, & - &6.111900e-01,9.496100e-01,1.184600e+00,1.281900e+00,4.967400e-02, & - &5.140500e-02,6.774000e-01,1.057000e+00,1.320700e+00,1.447400e+00, & - &2.061800e-02,2.402600e-02,3.734300e-01,5.629000e-01,6.935200e-01, & - &7.084900e-01,2.501300e-02,2.810300e-02,4.415100e-01,6.743600e-01, & - &8.351300e-01,8.726600e-01,3.030500e-02,3.304900e-02,5.109000e-01, & - &7.878300e-01,9.795800e-01,1.041500e+00,3.646100e-02,3.884200e-02, & - &5.799900e-01,9.007600e-01,1.122900e+00,1.212600e+00,4.363700e-02, & - &4.564500e-02,6.476600e-01,1.010500e+00,1.262100e+00,1.381700e+00/ - data absb(1081:1410,9) / & - &1.726200e-02,2.088900e-02,3.415400e-01,5.135300e-01,6.314700e-01, & - &6.403500e-01,2.113700e-02,2.448900e-02,4.092400e-01,6.239700e-01, & - &7.716400e-01,8.026800e-01,2.594500e-02,2.896300e-02,4.789500e-01, & - &7.376400e-01,9.162200e-01,9.715900e-01,3.160500e-02,3.426900e-02, & - &5.488500e-01,8.517400e-01,1.061000e+00,1.144200e+00,3.824800e-02, & - &4.053400e-02,6.177600e-01,9.635000e-01,1.202800e+00,1.316800e+00, & - &1.446100e-02,1.825600e-02,3.123800e-01,4.684500e-01,5.748800e-01, & - &5.774400e-01,1.787000e-02,2.143900e-02,3.794900e-01,5.773200e-01, & - &7.130200e-01,7.370300e-01,2.222200e-02,2.549000e-02,4.491400e-01, & - &6.907900e-01,8.570200e-01,9.051600e-01,2.743500e-02,3.036100e-02, & - &5.196600e-01,8.055300e-01,1.002700e+00,1.078100e+00,3.359900e-02, & - &3.615000e-02,5.895500e-01,9.189700e-01,1.146500e+00,1.252900e+00, & - &1.209700e-02,1.600300e-02,2.849200e-01,4.260300e-01,5.218200e-01, & - &5.181600e-01,1.508300e-02,1.882900e-02,3.512700e-01,5.330400e-01, & - &6.573500e-01,6.742900e-01,1.899700e-02,2.248800e-02,4.205800e-01, & - &6.458300e-01,8.001900e-01,8.407700e-01,2.377500e-02,2.694800e-02, & - &4.914300e-01,7.608400e-01,9.462800e-01,1.013400e+00,2.949900e-02, & - &3.230400e-02,5.620500e-01,8.754700e-01,1.091500e+00,1.189500e+00, & - &1.009500e-02,1.405000e-02,2.585400e-01,3.852900e-01,4.710900e-01, & - &4.619700e-01,1.268000e-02,1.656200e-02,3.237800e-01,4.900000e-01, & - &6.031500e-01,6.138500e-01,1.616700e-02,1.985100e-02,3.925700e-01, & - &6.015000e-01,7.443400e-01,7.780500e-01,2.052400e-02,2.392300e-02, & - &4.634300e-01,7.164400e-01,8.901100e-01,9.499400e-01,2.582100e-02, & - &2.887200e-02,5.346500e-01,8.318300e-01,1.036300e+00,1.126800e+00, & - &8.396300e-03,1.234300e-02,2.332500e-01,3.462600e-01,4.224400e-01, & - &4.088300e-01,1.062100e-02,1.458100e-02,2.970000e-01,4.481100e-01, & - &5.505100e-01,5.557200e-01,1.369300e-02,1.753700e-02,3.650100e-01, & - &5.577800e-01,6.893300e-01,7.170500e-01,1.763300e-02,2.124200e-02, & - &4.356200e-01,6.722200e-01,8.341200e-01,8.878000e-01,2.250600e-02, & - &2.579100e-02,5.072100e-01,7.880300e-01,9.810200e-01,1.065000e+00, & - &7.017700e-03,1.089400e-02,2.109500e-01,3.119900e-01,3.796900e-01, & - &3.608500e-01,8.930200e-03,1.291800e-02,2.729800e-01,4.106600e-01, & - &5.036300e-01,5.018100e-01,1.163400e-02,1.558900e-02,3.401300e-01, & - &5.183800e-01,6.397000e-01,6.593000e-01,1.519900e-02,1.897900e-02, & - &4.103200e-01,6.320000e-01,7.832700e-01,8.277000e-01,1.968700e-02, & - &2.317700e-02,4.820100e-01,7.478400e-01,9.301500e-01,1.003400e+00, & - &5.873100e-03,9.628600e-03,1.905200e-01,2.806300e-01,3.406900e-01, & - &3.165500e-01,7.516800e-03,1.148000e-02,2.506400e-01,3.758600e-01, & - &4.601900e-01,4.506900e-01,9.885300e-03,1.390000e-02,3.166900e-01, & - &4.814000e-01,5.930700e-01,6.035000e-01,1.309600e-02,1.701800e-02, & - &3.862800e-01,5.937100e-01,7.350000e-01,7.688700e-01,1.722200e-02, & - &2.089900e-02,4.579100e-01,7.093500e-01,8.814400e-01,9.421500e-01, & - &4.906000e-03,8.503900e-03,1.711100e-01,2.510600e-01,3.038500e-01, & - &2.751100e-01,6.312000e-03,1.020100e-02,2.291500e-01,3.424300e-01, & - &4.184700e-01,4.021500e-01,8.367200e-03,1.240100e-02,2.937800e-01, & - &4.453700e-01,5.477400e-01,5.495900e-01,1.124000e-02,1.526800e-02, & - &3.626300e-01,5.559500e-01,6.874600e-01,7.113800e-01,1.501000e-02, & - &1.885100e-02,4.339800e-01,6.711300e-01,8.330000e-01,8.821700e-01, & - &4.087800e-03,7.498200e-03,1.526900e-01,2.232400e-01,2.691100e-01, & - &2.369600e-01,5.289800e-03,9.061000e-03,2.085000e-01,3.103900e-01, & - &3.784200e-01,3.561500e-01,7.060600e-03,1.106900e-02,2.714600e-01, & - &4.102100e-01,5.036600e-01,4.974500e-01,9.607100e-03,1.370000e-02, & - &3.393900e-01,5.188700e-01,6.407200e-01,6.551100e-01,1.303100e-02, & - &1.701300e-02,4.102500e-01,6.331600e-01,7.849800e-01,8.233100e-01, & - &3.411000e-03,6.618700e-03,1.360800e-01,1.984400e-01,2.381200e-01, & - &2.034700e-01,4.443700e-03,8.072300e-03,1.896900e-01,2.812300e-01, & - &3.420800e-01,3.143900e-01,5.972500e-03,9.912300e-03,2.507900e-01, & - &3.777700e-01,4.631100e-01,4.493100e-01,8.219100e-03,1.233300e-02, & - &3.176500e-01,4.843300e-01,5.971500e-01,6.023600e-01,1.132500e-02, & - &1.541900e-02,3.878900e-01,5.974000e-01,7.398200e-01,7.675700e-01, & - &2.977700e-03,6.055900e-03,1.291100e-01,1.883100e-01,2.255700e-01, & - &1.880400e-01,3.924300e-03,7.458600e-03,1.818800e-01,2.694200e-01, & - &3.274200e-01,2.943100e-01,5.341000e-03,9.234100e-03,2.422900e-01, & - &3.646100e-01,4.467000e-01,4.251600e-01,7.448400e-03,1.157400e-02, & - &3.086900e-01,4.703100e-01,5.794800e-01,5.749300e-01,1.041600e-02, & - &1.457300e-02,3.787200e-01,5.828100e-01,7.214600e-01,7.375600e-01/ - data absb(1:360,10) / & - &7.528900e+00,7.524800e+00,5.802000e+00,4.223500e+00,3.478800e+00, & - &3.383000e+00,7.537300e+00,7.533100e+00,5.796500e+00,4.194900e+00, & - &3.410000e+00,3.309100e+00,7.534200e+00,7.530000e+00,5.790700e+00, & - &4.165600e+00,3.340200e+00,3.269000e+00,7.492700e+00,7.488600e+00, & - &5.756500e+00,4.120600e+00,3.264100e+00,3.256700e+00,7.421200e+00, & - &7.417100e+00,5.697800e+00,4.061100e+00,3.185600e+00,3.249000e+00, & - &7.457100e+00,7.452900e+00,5.730000e+00,4.251600e+00,3.697300e+00, & - &3.624900e+00,7.440700e+00,7.436500e+00,5.721100e+00,4.211300e+00, & - &3.624400e+00,3.566700e+00,7.396300e+00,7.392200e+00,5.681200e+00, & - &4.155600e+00,3.552600e+00,3.511500e+00,7.329600e+00,7.325500e+00, & - &5.624900e+00,4.093500e+00,3.476600e+00,3.470700e+00,7.246500e+00, & - &7.242500e+00,5.561900e+00,4.024500e+00,3.402000e+00,3.449300e+00, & - &7.191100e+00,7.187100e+00,5.528000e+00,4.296800e+00,3.962700e+00, & - &3.909000e+00,7.151300e+00,7.147400e+00,5.495600e+00,4.228900e+00, & - &3.887100e+00,3.840000e+00,7.092300e+00,7.088400e+00,5.446400e+00, & - &4.146800e+00,3.806200e+00,3.782800e+00,6.993400e+00,6.989500e+00, & - &5.371300e+00,4.063800e+00,3.732800e+00,3.729000e+00,6.886400e+00, & - &6.882500e+00,5.289900e+00,3.976100e+00,3.648300e+00,3.670400e+00, & - &6.791100e+00,6.787300e+00,5.220500e+00,4.319900e+00,4.250200e+00, & - &4.246600e+00,6.726300e+00,6.722600e+00,5.171100e+00,4.232900e+00, & - &4.159900e+00,4.174100e+00,6.633300e+00,6.629600e+00,5.098800e+00, & - &4.144800e+00,4.070300e+00,4.109400e+00,6.528000e+00,6.524400e+00, & - &5.019800e+00,4.049600e+00,3.980100e+00,4.040300e+00,6.416700e+00, & - &6.413100e+00,4.936100e+00,3.949900e+00,3.892700e+00,3.961400e+00, & - &6.253100e+00,6.249700e+00,4.828600e+00,4.368600e+00,4.517200e+00, & - &4.636400e+00,6.167700e+00,6.164300e+00,4.762600e+00,4.279200e+00, & - &4.429800e+00,4.560100e+00,6.074700e+00,6.071300e+00,4.690800e+00, & - &4.186000e+00,4.342800e+00,4.481200e+00,5.960400e+00,5.957100e+00, & - &4.605300e+00,4.089900e+00,4.257000e+00,4.393500e+00,5.829100e+00, & - &5.825900e+00,4.508900e+00,3.993500e+00,4.173300e+00,4.301100e+00, & - &5.626600e+00,5.623600e+00,4.420700e+00,4.498900e+00,4.805300e+00, & - &5.024700e+00,5.542700e+00,5.539700e+00,4.351200e+00,4.402100e+00, & - &4.722600e+00,4.947000e+00,5.437400e+00,5.434500e+00,4.266900e+00, & - &4.305400e+00,4.642900e+00,4.854800e+00,5.311800e+00,5.309000e+00, & - &4.172700e+00,4.204600e+00,4.556700e+00,4.765200e+00,5.178800e+00, & - &5.176000e+00,4.082600e+00,4.104500e+00,4.458300e+00,4.676600e+00, & - &4.989200e+00,4.986500e+00,4.102200e+00,4.629000e+00,5.155400e+00, & - &5.394600e+00,4.895100e+00,4.892400e+00,4.016500e+00,4.527300e+00, & - &5.070200e+00,5.307300e+00,4.779800e+00,4.777300e+00,3.923800e+00, & - &4.426900e+00,4.975300e+00,5.220800e+00,4.659800e+00,4.657300e+00, & - &3.835200e+00,4.330300e+00,4.870400e+00,5.140000e+00,4.550800e+00, & - &4.548400e+00,3.746200e+00,4.229000e+00,4.759000e+00,5.060300e+00, & - &4.344600e+00,4.342300e+00,3.879500e+00,4.752200e+00,5.506500e+00, & - &5.753500e+00,4.243100e+00,4.240900e+00,3.792700e+00,4.656100e+00, & - &5.400400e+00,5.680000e+00,4.139700e+00,4.137600e+00,3.704700e+00, & - &4.558500e+00,5.287800e+00,5.603300e+00,4.048100e+00,4.046000e+00, & - &3.615000e+00,4.457500e+00,5.172100e+00,5.526100e+00,3.976500e+00, & - &3.974400e+00,3.534300e+00,4.359500e+00,5.055400e+00,5.440600e+00, & - &3.721100e+00,3.719200e+00,3.761300e+00,4.907400e+00,5.782700e+00, & - &6.115400e+00,3.633000e+00,3.631200e+00,3.671700e+00,4.811600e+00, & - &5.671400e+00,6.050600e+00,3.558900e+00,3.557100e+00,3.580700e+00, & - &4.710800e+00,5.563500e+00,5.972400e+00,3.507300e+00,3.505500e+00, & - &3.501600e+00,4.609700e+00,5.460300e+00,5.888600e+00,3.469100e+00, & - &3.467400e+00,3.436400e+00,4.505200e+00,5.354100e+00,5.809000e+00, & - &3.154300e+00,3.152700e+00,3.678200e+00,5.044700e+00,6.016000e+00, & - &6.425300e+00,3.096900e+00,3.095400e+00,3.589800e+00,4.949900e+00, & - &5.920600e+00,6.365900e+00,3.062000e+00,3.060500e+00,3.505800e+00, & - &4.848600e+00,5.826500e+00,6.298900e+00,3.042500e+00,3.041000e+00, & - &3.439500e+00,4.744600e+00,5.728900e+00,6.228300e+00,3.054600e+00, & - &3.053200e+00,3.385400e+00,4.635800e+00,5.625200e+00,6.160300e+00, & - &2.685400e+00,2.684100e+00,3.630800e+00,5.145900e+00,6.239900e+00, & - &6.674000e+00,2.661700e+00,2.660400e+00,3.546800e+00,5.054000e+00, & - &6.165200e+00,6.631500e+00,2.658400e+00,2.657100e+00,3.470300e+00, & - &4.959900e+00,6.078000e+00,6.582400e+00,2.687200e+00,2.685900e+00, & - &3.411100e+00,4.858700e+00,5.985600e+00,6.528700e+00,2.741700e+00, & - &2.740500e+00,3.356000e+00,4.754800e+00,5.888400e+00,6.468600e+00, & - &2.315100e+00,2.314000e+00,3.588600e+00,5.227400e+00,6.431100e+00, & - &6.878900e+00,2.323000e+00,2.321900e+00,3.511300e+00,5.144200e+00, & - &6.370500e+00,6.854900e+00,2.360900e+00,2.359800e+00,3.452400e+00, & - &5.051400e+00,6.298400e+00,6.816300e+00,2.417500e+00,2.416400e+00, & - &3.398900e+00,4.952100e+00,6.218100e+00,6.771000e+00,2.476200e+00, & - &2.475200e+00,3.357700e+00,4.853300e+00,6.127800e+00,6.724400e+00/ - data absb(361:720,10) / & - &2.024400e+00,2.023500e+00,3.526900e+00,5.272400e+00,6.574000e+00, & - &7.031500e+00,2.065100e+00,2.064300e+00,3.475000e+00,5.196500e+00, & - &6.532700e+00,7.028300e+00,2.122900e+00,2.122000e+00,3.431600e+00, & - &5.109800e+00,6.477700e+00,7.001300e+00,2.185800e+00,2.184900e+00, & - &3.393200e+00,5.018900e+00,6.405000e+00,6.969900e+00,2.251900e+00, & - &2.251000e+00,3.368000e+00,4.935400e+00,6.314300e+00,6.941100e+00, & - &1.803800e+00,1.803100e+00,3.475100e+00,5.274100e+00,6.675400e+00, & - &7.136700e+00,1.858400e+00,1.857700e+00,3.442100e+00,5.212800e+00, & - &6.646800e+00,7.152500e+00,1.921700e+00,1.920900e+00,3.408900e+00, & - &5.144500e+00,6.604000e+00,7.145700e+00,1.982400e+00,1.981600e+00, & - &3.391900e+00,5.073600e+00,6.539800e+00,7.130100e+00,2.043100e+00, & - &2.042300e+00,3.369300e+00,5.009800e+00,6.461400e+00,7.111600e+00, & - &1.620500e+00,1.620000e+00,3.431200e+00,5.251200e+00,6.730200e+00, & - &7.191600e+00,1.682100e+00,1.681500e+00,3.409600e+00,5.210700e+00, & - &6.720400e+00,7.234100e+00,1.739300e+00,1.738700e+00,3.398600e+00, & - &5.161100e+00,6.690100e+00,7.246100e+00,1.795200e+00,1.794500e+00, & - &3.384900e+00,5.111800e+00,6.640000e+00,7.252100e+00,1.846700e+00, & - &1.846000e+00,3.367800e+00,5.068800e+00,6.575000e+00,7.252900e+00, & - &1.458100e+00,1.457700e+00,3.379300e+00,5.215100e+00,6.752800e+00, & - &7.209900e+00,1.513000e+00,1.512600e+00,3.378500e+00,5.194700e+00, & - &6.765300e+00,7.274000e+00,1.566900e+00,1.566400e+00,3.381000e+00, & - &5.166400e+00,6.751200e+00,7.319200e+00,1.617200e+00,1.616600e+00, & - &3.373200e+00,5.142500e+00,6.717700e+00,7.359000e+00,1.663100e+00, & - &1.662500e+00,3.369400e+00,5.110900e+00,6.662400e+00,7.378200e+00, & - &1.302200e+00,1.301900e+00,3.327000e+00,5.172800e+00,6.755900e+00, & - &7.209600e+00,1.353300e+00,1.352900e+00,3.347300e+00,5.172300e+00, & - &6.790500e+00,7.306900e+00,1.403100e+00,1.402700e+00,3.357100e+00, & - &5.170300e+00,6.796500e+00,7.392500e+00,1.449100e+00,1.448700e+00, & - &3.364300e+00,5.165200e+00,6.774100e+00,7.463700e+00,1.492600e+00, & - &1.492100e+00,3.369700e+00,5.147300e+00,6.726100e+00,7.494000e+00, & - &1.160000e+00,1.159700e+00,3.281100e+00,5.124200e+00,6.745500e+00, & - &7.205500e+00,1.206400e+00,1.206100e+00,3.312500e+00,5.149700e+00, & - &6.802700e+00,7.345600e+00,1.251100e+00,1.250800e+00,3.336600e+00, & - &5.170700e+00,6.823300e+00,7.471200e+00,1.293900e+00,1.293500e+00, & - &3.355600e+00,5.180100e+00,6.814300e+00,7.561100e+00,1.335000e+00, & - &1.334600e+00,3.366000e+00,5.173500e+00,6.775400e+00,7.603100e+00, & - &1.033500e+00,1.033300e+00,3.241300e+00,5.076800e+00,6.732800e+00, & - &7.224700e+00,1.075100e+00,1.074900e+00,3.281700e+00,5.129400e+00, & - &6.809600e+00,7.411800e+00,1.115400e+00,1.115200e+00,3.317300e+00, & - &5.167800e+00,6.846700e+00,7.564800e+00,1.154900e+00,1.154600e+00, & - &3.345300e+00,5.189900e+00,6.848500e+00,7.662600e+00,1.197600e+00, & - &1.197300e+00,3.359700e+00,5.196800e+00,6.817400e+00,7.717300e+00, & - &9.219600e-01,9.218400e-01,3.206100e+00,5.042000e+00,6.725100e+00, & - &7.271700e+00,9.591600e-01,9.590100e-01,3.258100e+00,5.114300e+00, & - &6.818700e+00,7.492100e+00,9.961300e-01,9.959300e-01,3.303000e+00, & - &5.167800e+00,6.867700e+00,7.651500e+00,1.035900e+00,1.035700e+00, & - &3.335600e+00,5.200200e+00,6.877900e+00,7.759600e+00,1.085500e+00, & - &1.085100e+00,3.351900e+00,5.217200e+00,6.851700e+00,7.824600e+00, & - &8.244400e-01,8.243800e-01,3.178600e+00,5.017300e+00,6.724300e+00, & - &7.344800e+00,8.583800e-01,8.582600e-01,3.241100e+00,5.106100e+00, & - &6.829900e+00,7.578300e+00,8.942500e-01,8.940700e-01,3.290900e+00, & - &5.171500e+00,6.888900e+00,7.745100e+00,9.390200e-01,9.387500e-01, & - &3.325200e+00,5.214600e+00,6.905600e+00,7.868100e+00,9.996300e-01, & - &9.992600e-01,3.342900e+00,5.236400e+00,6.882000e+00,7.938300e+00, & - &7.380800e-01,7.380700e-01,3.155400e+00,5.000500e+00,6.727000e+00, & - &7.419300e+00,7.704100e-01,7.703100e-01,3.224500e+00,5.103700e+00, & - &6.842800e+00,7.656400e+00,8.092700e-01,8.090800e-01,3.278500e+00, & - &5.178600e+00,6.909000e+00,7.842100e+00,8.622600e-01,8.619800e-01, & - &3.316100e+00,5.229000e+00,6.926400e+00,7.965400e+00,9.316100e-01, & - &9.312900e-01,3.333200e+00,5.253500e+00,6.906800e+00,8.035900e+00, & - &6.609100e-01,6.609000e-01,3.129700e+00,4.982600e+00,6.723100e+00, & - &7.473000e+00,6.934300e-01,6.933700e-01,3.205400e+00,5.098500e+00, & - &6.850400e+00,7.728900e+00,7.370700e-01,7.368900e-01,3.264700e+00, & - &5.183300e+00,6.923300e+00,7.924400e+00,7.968900e-01,7.966500e-01, & - &3.304700e+00,5.242100e+00,6.945600e+00,8.050600e+00,8.713500e-01, & - &8.710700e-01,3.324800e+00,5.268800e+00,6.929900e+00,8.117500e+00, & - &5.926100e-01,5.926300e-01,3.099800e+00,4.957200e+00,6.706300e+00, & - &7.500600e+00,6.261600e-01,6.261100e-01,3.183000e+00,5.086700e+00, & - &6.848900e+00,7.781100e+00,6.734300e-01,6.733000e-01,3.247800e+00, & - &5.183200e+00,6.930900e+00,7.982600e+00,7.366000e-01,7.364000e-01, & - &3.292800e+00,5.248400e+00,6.961100e+00,8.118400e+00,8.139500e-01, & - &8.137200e-01,3.316500e+00,5.280700e+00,6.951200e+00,8.192500e+00/ - data absb(721:1080,10) / & - &5.298900e-01,5.299600e-01,3.058000e+00,4.910400e+00,6.663700e+00, & - &7.474000e+00,5.641900e-01,5.641400e-01,3.150600e+00,5.057600e+00, & - &6.826200e+00,7.783600e+00,6.119600e-01,6.118600e-01,3.223200e+00, & - &5.169400e+00,6.925400e+00,8.002100e+00,6.751600e-01,6.750300e-01, & - &3.277300e+00,5.246800e+00,6.969600e+00,8.154600e+00,7.524200e-01, & - &7.522500e-01,3.307700e+00,5.288000e+00,6.971200e+00,8.243600e+00, & - &4.750500e-01,4.751300e-01,3.017600e+00,4.862800e+00,6.617200e+00, & - &7.449400e+00,5.107100e-01,5.107000e-01,3.119700e+00,5.026900e+00, & - &6.797500e+00,7.781000e+00,5.587700e-01,5.587200e-01,3.200200e+00, & - &5.152600e+00,6.914800e+00,8.018000e+00,6.212300e-01,6.211600e-01, & - &3.261900e+00,5.242400e+00,6.972500e+00,8.185300e+00,6.970000e-01, & - &6.968900e-01,3.298600e+00,5.292700e+00,6.985000e+00,8.294500e+00, & - &4.266700e-01,4.267500e-01,2.979200e+00,4.816200e+00,6.567800e+00, & - &7.430100e+00,4.636800e-01,4.637100e-01,3.089800e+00,4.994900e+00, & - &6.765700e+00,7.779100e+00,5.127100e-01,5.127100e-01,3.178900e+00, & - &5.134500e+00,6.899500e+00,8.032700e+00,5.741800e-01,5.741600e-01, & - &3.247400e+00,5.235000e+00,6.970500e+00,8.215400e+00,6.481300e-01, & - &6.480800e-01,3.290600e+00,5.294600e+00,6.995400e+00,8.348100e+00, & - &3.805900e-01,3.806600e-01,2.929400e+00,4.748200e+00,6.490000e+00, & - &7.341300e+00,4.176400e-01,4.176800e-01,3.051700e+00,4.945500e+00, & - &6.713700e+00,7.722000e+00,4.663100e-01,4.663500e-01,3.149800e+00, & - &5.100400e+00,6.868200e+00,8.000300e+00,5.264400e-01,5.264800e-01, & - &3.226500e+00,5.216200e+00,6.960300e+00,8.207200e+00,5.970200e-01, & - &5.970300e-01,3.278700e+00,5.288200e+00,7.000400e+00,8.357100e+00, & - &3.390600e-01,3.391400e-01,2.876400e+00,4.675000e+00,6.403100e+00, & - &7.237400e+00,3.755500e-01,3.756200e-01,3.011600e+00,4.889900e+00, & - &6.652700e+00,7.651000e+00,4.237400e-01,4.238200e-01,3.119200e+00, & - &5.059600e+00,6.829800e+00,7.958400e+00,4.825200e-01,4.826100e-01, & - &3.203200e+00,5.190900e+00,6.942300e+00,8.188300e+00,5.505500e-01, & - &5.505900e-01,3.264700e+00,5.276700e+00,6.999300e+00,8.356400e+00, & - &3.021600e-01,3.022700e-01,2.822800e+00,4.600100e+00,6.310000e+00, & - &7.128300e+00,3.374900e-01,3.375900e-01,2.970000e+00,4.830300e+00, & - &6.586400e+00,7.574900e+00,3.848000e-01,3.849200e-01,3.086500e+00, & - &5.016200e+00,6.784700e+00,7.910000e+00,4.428800e-01,4.430100e-01, & - &3.179000e+00,5.160800e+00,6.918400e+00,8.164700e+00,5.092800e-01, & - &5.093500e-01,3.249000e+00,5.260700e+00,6.991800e+00,8.353300e+00, & - &2.676800e-01,2.678100e-01,2.759500e+00,4.506800e+00,6.192400e+00, & - &6.981600e+00,3.012100e-01,3.013400e-01,2.919500e+00,4.753800e+00, & - &6.498500e+00,7.465800e+00,3.463600e-01,3.465200e-01,3.047500e+00, & - &4.958600e+00,6.725000e+00,7.836300e+00,4.027900e-01,4.029400e-01, & - &3.148700e+00,5.118600e+00,6.881600e+00,8.119300e+00,4.677500e-01, & - &4.678400e-01,3.228100e+00,5.236500e+00,6.976500e+00,8.333500e+00, & - &2.366300e-01,2.367900e-01,2.688900e+00,4.399600e+00,6.055900e+00, & - &6.813500e+00,2.674800e-01,2.676400e-01,2.861800e+00,4.666700e+00, & - &6.394300e+00,7.335500e+00,3.100700e-01,3.102800e-01,3.003300e+00, & - &4.890400e+00,6.651000e+00,7.746900e+00,3.642600e-01,3.644400e-01, & - &3.114300e+00,5.066600e+00,6.834100e+00,8.060900e+00,4.279000e-01, & - &4.280000e-01,3.201700e+00,5.202700e+00,6.951000e+00,8.300500e+00, & - &2.094300e-01,2.096100e-01,2.614900e+00,4.287000e+00,5.908800e+00, & - &6.637600e+00,2.374800e-01,2.376800e-01,2.799600e+00,4.573900e+00, & - &6.280000e+00,7.198100e+00,2.771700e-01,2.774100e-01,2.954500e+00, & - &4.814900e+00,6.567900e+00,7.649800e+00,3.288100e-01,3.290000e-01, & - &3.076900e+00,5.010000e+00,6.776700e+00,7.995600e+00,3.908900e-01, & - &3.909900e-01,3.172900e+00,5.161700e+00,6.918400e+00,8.264700e+00, & - &1.848800e-01,1.850900e-01,2.533700e+00,4.161900e+00,5.740800e+00, & - &6.434300e+00,2.102900e-01,2.105200e-01,2.730800e+00,4.468500e+00, & - &6.147600e+00,7.035100e+00,2.464100e-01,2.466900e-01,2.899100e+00, & - &4.728200e+00,6.468000e+00,7.529900e+00,2.950200e-01,2.952300e-01, & - &3.033600e+00,4.942800e+00,6.706400e+00,7.912200e+00,3.549200e-01, & - &3.550400e-01,3.139500e+00,5.110800e+00,6.874200e+00,8.212200e+00, & - &1.624000e-01,1.626300e-01,2.438800e+00,4.016600e+00,5.539700e+00, & - &6.180400e+00,1.850400e-01,1.853200e-01,2.649600e+00,4.344200e+00, & - &5.986400e+00,6.826500e+00,2.173500e-01,2.176400e-01,2.831600e+00, & - &4.625000e+00,6.344100e+00,7.370400e+00,2.621900e-01,2.624300e-01, & - &2.980700e+00,4.859700e+00,6.616500e+00,7.794800e+00,3.190400e-01, & - &3.191600e-01,3.098700e+00,5.047300e+00,6.813200e+00,8.131800e+00, & - &1.427400e-01,1.430900e-01,2.337800e+00,3.862100e+00,5.322300e+00, & - &5.912900e+00,1.628900e-01,1.631900e-01,2.563100e+00,4.210800e+00, & - &5.810300e+00,6.606200e+00,1.916700e-01,1.919800e-01,2.758400e+00, & - &4.513300e+00,6.205100e+00,7.196700e+00,2.323900e-01,2.326400e-01, & - &2.922600e+00,4.768000e+00,6.513500e+00,7.666500e+00,2.857700e-01, & - &2.859200e-01,3.052500e+00,4.975900e+00,6.740100e+00,8.042300e+00/ - data absb(1081:1410,10) / & - &1.250600e-01,1.256900e-01,2.231500e+00,3.698400e+00,5.091600e+00, & - &5.636300e+00,1.434800e-01,1.438300e-01,2.471700e+00,4.069100e+00, & - &5.617800e+00,6.374500e+00,1.690000e-01,1.693400e-01,2.680200e+00, & - &4.392800e+00,6.051500e+00,7.012700e+00,2.058100e-01,2.060600e-01, & - &2.858600e+00,4.668200e+00,6.396200e+00,7.529200e+00,2.551800e-01, & - &2.553300e-01,3.002500e+00,4.896800e+00,6.655800e+00,7.945700e+00, & - &1.095900e-01,1.107000e-01,2.126700e+00,3.536800e+00,4.861500e+00, & - &5.353800e+00,1.268900e-01,1.274400e-01,2.380900e+00,3.930200e+00, & - &5.423500e+00,6.130600e+00,1.497300e-01,1.500900e-01,2.601900e+00, & - &4.272500e+00,5.894600e+00,6.811200e+00,1.830400e-01,1.833100e-01, & - &2.792700e+00,4.567500e+00,6.273100e+00,7.374500e+00,2.286600e-01, & - &2.288200e-01,2.950800e+00,4.814600e+00,6.565700e+00,7.828200e+00, & - &9.576800e-02,9.766100e-02,2.021600e+00,3.375100e+00,4.626800e+00, & - &5.059700e+00,1.121600e-01,1.130700e-01,2.288100e+00,3.787500e+00, & - &5.221700e+00,5.874400e+00,1.329900e-01,1.334300e-01,2.521900e+00, & - &4.148000e+00,5.728400e+00,6.594300e+00,1.630800e-01,1.633700e-01, & - &2.724800e+00,4.462600e+00,6.141500e+00,7.203300e+00,2.052400e-01, & - &2.054100e-01,2.896100e+00,4.728100e+00,6.466600e+00,7.694500e+00, & - &8.317100e-02,8.622100e-02,1.914400e+00,3.207600e+00,4.381900e+00, & - &4.758000e+00,9.891200e-02,1.003900e-01,2.190600e+00,3.637000e+00, & - &5.008800e+00,5.608900e+00,1.180900e-01,1.187400e-01,2.438100e+00, & - &4.018500e+00,5.550500e+00,6.368400e+00,1.453900e-01,1.457200e-01, & - &2.652600e+00,4.351100e+00,5.998000e+00,7.021400e+00,1.840600e-01, & - &1.842500e-01,2.836200e+00,4.635400e+00,6.356500e+00,7.553200e+00, & - &7.176000e-02,7.622500e-02,1.804900e+00,3.033800e+00,4.128500e+00, & - &4.454300e+00,8.673300e-02,8.913300e-02,2.089000e+00,3.480800e+00, & - &4.783800e+00,5.338400e+00,1.047000e-01,1.057100e-01,2.349600e+00, & - &3.882600e+00,5.359300e+00,6.134000e+00,1.296400e-01,1.300400e-01, & - &2.575800e+00,4.232800e+00,5.843200e+00,6.831000e+00,1.648600e-01, & - &1.650500e-01,2.771800e+00,4.535800e+00,6.234100e+00,7.404200e+00, & - &6.188200e-02,6.794000e-02,1.702700e+00,2.870500e+00,3.889400e+00, & - &4.146000e+00,7.615500e-02,7.968400e-02,1.993000e+00,3.332500e+00, & - &4.567800e+00,5.050900e+00,9.324000e-02,9.482600e-02,2.264100e+00, & - &3.751300e+00,5.173000e+00,5.877100e+00,1.163200e-01,1.169000e-01, & - &2.502000e+00,4.118200e+00,5.689200e+00,6.612700e+00,1.486500e-01, & - &1.488700e-01,2.708500e+00,4.438400e+00,6.111000e+00,7.226800e+00, & - &5.314300e-02,6.092900e-02,1.603400e+00,2.710800e+00,3.651900e+00, & - &3.834600e+00,6.666400e-02,7.154900e-02,1.899300e+00,3.185400e+00, & - &4.352800e+00,4.744900e+00,8.298800e-02,8.543400e-02,2.178100e+00, & - &3.618800e+00,4.985000e+00,5.601600e+00,1.045500e-01,1.054100e-01, & - &2.428300e+00,4.003500e+00,5.531400e+00,6.367000e+00,1.345000e-01, & - &1.347500e-01,2.644700e+00,4.340000e+00,5.983700e+00,7.024600e+00, & - &4.536300e-02,5.476100e-02,1.505700e+00,2.546500e+00,3.410700e+00, & - &3.527000e+00,5.800500e-02,6.443100e-02,1.804000e+00,3.034000e+00, & - &4.132200e+00,4.434300e+00,7.359300e-02,7.714400e-02,2.089800e+00, & - &3.482300e+00,4.788400e+00,5.317300e+00,9.388700e-02,9.523700e-02, & - &2.351000e+00,3.885000e+00,5.364700e+00,6.110800e+00,1.218100e-01, & - &1.221900e-01,2.577600e+00,4.236100e+00,5.848200e+00,6.808100e+00, & - &3.848400e-02,4.933200e-02,1.408700e+00,2.377500e+00,3.167300e+00, & - &3.219700e+00,5.014700e-02,5.822100e-02,1.707300e+00,2.879300e+00, & - &3.904900e+00,4.127300e+00,6.493100e-02,6.981500e-02,1.998700e+00, & - &3.342000e+00,4.583900e+00,5.021800e+00,8.410900e-02,8.618600e-02, & - &2.269800e+00,3.760600e+00,5.187800e+00,5.844900e+00,1.102300e-01, & - &1.108100e-01,2.507500e+00,4.127400e+00,5.702200e+00,6.574700e+00, & - &3.262600e-02,4.463300e-02,1.317400e+00,2.215600e+00,2.936300e+00, & - &2.927800e+00,4.329800e-02,5.292200e-02,1.614400e+00,2.730400e+00, & - &3.683100e+00,3.832500e+00,5.724700e-02,6.359700e-02,1.910700e+00, & - &3.204300e+00,4.382100e+00,4.723600e+00,7.547300e-02,7.852500e-02, & - &2.189400e+00,3.636900e+00,5.012100e+00,5.574800e+00,1.000300e-01, & - &1.009300e-01,2.438900e+00,4.019700e+00,5.554900e+00,6.332500e+00, & - &2.907200e-02,4.170500e-02,1.280200e+00,2.149400e+00,2.842100e+00, & - &2.779800e+00,3.925200e-02,4.983500e-02,1.576500e+00,2.668000e+00, & - &3.591100e+00,3.665900e+00,5.300000e-02,6.027000e-02,1.874400e+00, & - &3.147300e+00,4.299300e+00,4.541100e+00,7.121800e-02,7.485900e-02, & - &2.156100e+00,3.585200e+00,4.938400e+00,5.379000e+00,9.558100e-02, & - &9.667900e-02,2.409800e+00,3.975200e+00,5.493100e+00,6.151300e+00/ - data absb(1:360,11) / & - &1.083000e+01,1.082400e+01,8.296600e+00,5.777500e+00,4.206700e+00, & - &3.841600e+00,1.084200e+01,1.083600e+01,8.304800e+00,5.775600e+00, & - &4.111700e+00,3.762600e+00,1.080600e+01,1.080000e+01,8.277000e+00, & - &5.752400e+00,4.010300e+00,3.700500e+00,1.072400e+01,1.071800e+01, & - &8.211200e+00,5.700200e+00,3.905800e+00,3.687500e+00,1.062100e+01, & - &1.061500e+01,8.133700e+00,5.646500e+00,3.801300e+00,3.702800e+00, & - &1.118100e+01,1.117500e+01,8.556800e+00,5.964900e+00,4.452200e+00, & - &4.207700e+00,1.113300e+01,1.112700e+01,8.516700e+00,5.932300e+00, & - &4.347600e+00,4.124700e+00,1.105300e+01,1.104700e+01,8.457000e+00, & - &5.888900e+00,4.241500e+00,4.041700e+00,1.093300e+01,1.092700e+01, & - &8.368200e+00,5.825200e+00,4.141300e+00,3.969500e+00,1.078000e+01, & - &1.077400e+01,8.248100e+00,5.738200e+00,4.036200e+00,3.948100e+00, & - &1.126500e+01,1.125900e+01,8.614400e+00,6.050400e+00,4.732300e+00, & - &4.597100e+00,1.116200e+01,1.115600e+01,8.537800e+00,5.989500e+00, & - &4.632300e+00,4.498800e+00,1.102200e+01,1.101500e+01,8.433700e+00, & - &5.919900e+00,4.531200e+00,4.414200e+00,1.088000e+01,1.087400e+01, & - &8.323400e+00,5.834800e+00,4.423700e+00,4.332600e+00,1.069800e+01, & - &1.069200e+01,8.181100e+00,5.729400e+00,4.318900e+00,4.256900e+00, & - &1.104700e+01,1.104100e+01,8.456600e+00,6.073300e+00,5.098700e+00, & - &4.981400e+00,1.091200e+01,1.090500e+01,8.355800e+00,5.995600e+00, & - &4.997900e+00,4.888400e+00,1.075800e+01,1.075200e+01,8.238100e+00, & - &5.893500e+00,4.888100e+00,4.798600e+00,1.056900e+01,1.056300e+01, & - &8.089800e+00,5.776000e+00,4.780800e+00,4.720000e+00,1.036300e+01, & - &1.035700e+01,7.932400e+00,5.661400e+00,4.674600e+00,4.627200e+00, & - &1.057700e+01,1.057200e+01,8.109800e+00,6.099100e+00,5.510600e+00, & - &5.416500e+00,1.041100e+01,1.040500e+01,7.983500e+00,5.980500e+00, & - &5.399600e+00,5.320600e+00,1.022400e+01,1.021900e+01,7.840600e+00, & - &5.852000e+00,5.291000e+00,5.228900e+00,1.002800e+01,1.002200e+01, & - &7.689000e+00,5.721500e+00,5.180300e+00,5.137300e+00,9.816000e+00, & - &9.810500e+00,7.524400e+00,5.583900e+00,5.065300e+00,5.043200e+00, & - &9.898600e+00,9.893100e+00,7.604400e+00,6.116400e+00,5.953400e+00, & - &5.947400e+00,9.714000e+00,9.708600e+00,7.465400e+00,5.979500e+00, & - &5.838300e+00,5.841100e+00,9.527300e+00,9.522000e+00,7.321000e+00, & - &5.838300e+00,5.718900e+00,5.739500e+00,9.318200e+00,9.313000e+00, & - &7.159400e+00,5.700600e+00,5.600200e+00,5.638500e+00,9.098400e+00, & - &9.093400e+00,6.990100e+00,5.559600e+00,5.478400e+00,5.536100e+00, & - &9.061700e+00,9.056700e+00,6.988200e+00,6.194400e+00,6.403200e+00, & - &6.550600e+00,8.880700e+00,8.875800e+00,6.850800e+00,6.054100e+00, & - &6.279000e+00,6.442100e+00,8.684000e+00,8.679300e+00,6.699300e+00, & - &5.915500e+00,6.153000e+00,6.330200e+00,8.469000e+00,8.464300e+00, & - &6.534600e+00,5.778200e+00,6.020500e+00,6.196900e+00,8.246100e+00, & - &8.241500e+00,6.368300e+00,5.641800e+00,5.888400e+00,6.073800e+00, & - &8.133800e+00,8.129400e+00,6.378700e+00,6.372400e+00,6.867600e+00, & - &7.151200e+00,7.948900e+00,7.944600e+00,6.232300e+00,6.236700e+00, & - &6.738000e+00,7.023500e+00,7.748400e+00,7.744200e+00,6.074700e+00, & - &6.098400e+00,6.603700e+00,6.888600e+00,7.533600e+00,7.529500e+00, & - &5.915800e+00,5.958500e+00,6.461500e+00,6.748300e+00,7.319200e+00, & - &7.315300e+00,5.754000e+00,5.815400e+00,6.311400e+00,6.628500e+00, & - &7.178300e+00,7.174500e+00,5.879200e+00,6.578900e+00,7.361300e+00, & - &7.702200e+00,6.991900e+00,6.988200e+00,5.729900e+00,6.438900e+00, & - &7.222500e+00,7.564700e+00,6.790900e+00,6.787300e+00,5.576600e+00, & - &6.297300e+00,7.071200e+00,7.440500e+00,6.593900e+00,6.590300e+00, & - &5.421700e+00,6.149000e+00,6.912900e+00,7.312200e+00,6.409300e+00, & - &6.405900e+00,5.266300e+00,5.996300e+00,6.751600e+00,7.197000e+00, & - &6.217700e+00,6.214400e+00,5.547900e+00,6.790000e+00,7.837400e+00, & - &8.237500e+00,6.035600e+00,6.032400e+00,5.399500e+00,6.645100e+00, & - &7.689500e+00,8.116600e+00,5.859600e+00,5.856500e+00,5.249900e+00, & - &6.494300e+00,7.534200e+00,8.001600e+00,5.706900e+00,5.703900e+00, & - &5.102900e+00,6.334200e+00,7.372100e+00,7.877900e+00,5.590700e+00, & - &5.587800e+00,4.967700e+00,6.173100e+00,7.206800e+00,7.759800e+00, & - &5.300100e+00,5.297400e+00,5.339200e+00,7.021200e+00,8.273100e+00, & - &8.776900e+00,5.146500e+00,5.143900e+00,5.195900e+00,6.865800e+00, & - &8.131800e+00,8.675600e+00,5.025900e+00,5.023400e+00,5.056800e+00, & - &6.696400e+00,7.982200e+00,8.563500e+00,4.940800e+00,4.938300e+00, & - &4.925600e+00,6.522900e+00,7.828300e+00,8.433700e+00,4.898200e+00, & - &4.895700e+00,4.817000e+00,6.346700e+00,7.665600e+00,8.311700e+00, & - &4.481000e+00,4.478800e+00,5.211700e+00,7.218700e+00,8.689400e+00, & - &9.283000e+00,4.387500e+00,4.385400e+00,5.072900e+00,7.055200e+00, & - &8.555200e+00,9.195200e+00,4.329800e+00,4.327700e+00,4.939500e+00, & - &6.884100e+00,8.412900e+00,9.085400e+00,4.324000e+00,4.321900e+00, & - &4.830500e+00,6.710600e+00,8.258300e+00,8.953400e+00,4.356800e+00, & - &4.354700e+00,4.745000e+00,6.534100e+00,8.091700e+00,8.829800e+00/ - data absb(361:720,11) / & - &3.815700e+00,3.813900e+00,5.126000e+00,7.375300e+00,9.080900e+00, & - &9.730300e+00,3.782800e+00,3.780900e+00,4.988100e+00,7.225200e+00, & - &8.954600e+00,9.652900e+00,3.796600e+00,3.794800e+00,4.869800e+00, & - &7.069400e+00,8.811400e+00,9.549200e+00,3.844700e+00,3.842900e+00, & - &4.780800e+00,6.905500e+00,8.654800e+00,9.422000e+00,3.932700e+00, & - &3.930900e+00,4.702100e+00,6.729800e+00,8.488900e+00,9.293600e+00, & - &3.303600e+00,3.302100e+00,5.057500e+00,7.519200e+00,9.418900e+00, & - &1.010200e+01,3.328500e+00,3.327000e+00,4.928100e+00,7.384900e+00, & - &9.302700e+00,1.004100e+01,3.388900e+00,3.387400e+00,4.832600e+00, & - &7.237100e+00,9.167300e+00,9.952600e+00,3.483700e+00,3.482200e+00, & - &4.752500e+00,7.075400e+00,9.013000e+00,9.833400e+00,3.586900e+00, & - &3.585300e+00,4.687900e+00,6.908100e+00,8.842900e+00,9.710400e+00, & - &2.916500e+00,2.915200e+00,4.985700e+00,7.656000e+00,9.711000e+00, & - &1.042100e+01,2.983400e+00,2.982200e+00,4.887700e+00,7.529700e+00, & - &9.610600e+00,1.038200e+01,3.075800e+00,3.074500e+00,4.813000e+00, & - &7.387000e+00,9.483800e+00,1.030600e+01,3.179600e+00,3.178100e+00, & - &4.748500e+00,7.232700e+00,9.330300e+00,1.019800e+01,3.295700e+00, & - &3.294100e+00,4.703800e+00,7.068300e+00,9.156400e+00,1.008900e+01, & - &2.615500e+00,2.614500e+00,4.927500e+00,7.763800e+00,9.955100e+00, & - &1.069600e+01,2.704600e+00,2.703500e+00,4.864100e+00,7.647600e+00, & - &9.868200e+00,1.068200e+01,2.807800e+00,2.806600e+00,4.808600e+00, & - &7.513200e+00,9.747900e+00,1.061500e+01,2.922000e+00,2.920700e+00, & - &4.766100e+00,7.360600e+00,9.599900e+00,1.052100e+01,3.041900e+00, & - &3.040400e+00,4.723500e+00,7.204600e+00,9.419500e+00,1.042400e+01, & - &2.373200e+00,2.372300e+00,4.890000e+00,7.837500e+00,1.015000e+01, & - &1.095100e+01,2.471200e+00,2.470200e+00,4.848100e+00,7.731900e+00, & - &1.007800e+01,1.094600e+01,2.578300e+00,2.577100e+00,4.811800e+00, & - &7.603700e+00,9.972100e+00,1.089300e+01,2.690200e+00,2.688900e+00, & - &4.785000e+00,7.458000e+00,9.826800e+00,1.082200e+01,2.804500e+00, & - &2.803200e+00,4.740000e+00,7.315400e+00,9.648300e+00,1.074100e+01, & - &2.165800e+00,2.165000e+00,4.867700e+00,7.886200e+00,1.031700e+01, & - &1.116700e+01,2.266200e+00,2.265200e+00,4.842300e+00,7.791100e+00, & - &1.026200e+01,1.117700e+01,2.369800e+00,2.368700e+00,4.824900e+00, & - &7.671700e+00,1.016200e+01,1.114500e+01,2.477300e+00,2.476100e+00, & - &4.795900e+00,7.538900e+00,1.001200e+01,1.110500e+01,2.587700e+00, & - &2.586500e+00,4.756900e+00,7.411500e+00,9.834000e+00,1.102900e+01, & - &1.979000e+00,1.978200e+00,4.850000e+00,7.914300e+00,1.046400e+01, & - &1.136600e+01,2.077600e+00,2.076700e+00,4.842700e+00,7.831600e+00, & - &1.041700e+01,1.139800e+01,2.179700e+00,2.178700e+00,4.832100e+00, & - &7.724000e+00,1.031600e+01,1.141000e+01,2.284200e+00,2.283200e+00, & - &4.802100e+00,7.607200e+00,1.017100e+01,1.139000e+01,2.390400e+00, & - &2.389300e+00,4.770200e+00,7.487400e+00,9.988500e+00,1.130500e+01, & - &1.806500e+00,1.805700e+00,4.833700e+00,7.932100e+00,1.059400e+01, & - &1.155300e+01,1.905600e+00,1.904800e+00,4.840400e+00,7.860200e+00, & - &1.055000e+01,1.163200e+01,2.007100e+00,2.006200e+00,4.829100e+00, & - &7.766000e+00,1.044700e+01,1.167600e+01,2.109100e+00,2.108200e+00, & - &4.805200e+00,7.665600e+00,1.029600e+01,1.164800e+01,2.214400e+00, & - &2.213400e+00,4.780600e+00,7.552900e+00,1.010500e+01,1.155700e+01, & - &1.651000e+00,1.650300e+00,4.821000e+00,7.948200e+00,1.070600e+01, & - &1.176700e+01,1.749400e+00,1.748700e+00,4.834300e+00,7.886100e+00, & - &1.065800e+01,1.188100e+01,1.850100e+00,1.849300e+00,4.825200e+00, & - &7.807600e+00,1.054800e+01,1.191800e+01,1.952400e+00,1.951600e+00, & - &4.810100e+00,7.716300e+00,1.039100e+01,1.187800e+01,2.059400e+00, & - &2.058600e+00,4.789600e+00,7.604700e+00,1.019300e+01,1.178300e+01, & - &1.509800e+00,1.509300e+00,4.811900e+00,7.965300e+00,1.079800e+01, & - &1.197200e+01,1.606700e+00,1.606100e+00,4.828200e+00,7.916400e+00, & - &1.074500e+01,1.209100e+01,1.706800e+00,1.706200e+00,4.825400e+00, & - &7.847000e+00,1.063200e+01,1.211300e+01,1.811600e+00,1.810900e+00, & - &4.814700e+00,7.762200e+00,1.047000e+01,1.207300e+01,1.923200e+00, & - &1.922500e+00,4.797700e+00,7.652100e+00,1.026400e+01,1.196900e+01, & - &1.377700e+00,1.377300e+00,4.800700e+00,7.986500e+00,1.087800e+01, & - &1.215200e+01,1.472000e+00,1.471500e+00,4.822000e+00,7.950500e+00, & - &1.082400e+01,1.227200e+01,1.571300e+00,1.570800e+00,4.827500e+00, & - &7.890700e+00,1.071000e+01,1.229600e+01,1.679000e+00,1.678400e+00, & - &4.822000e+00,7.808100e+00,1.054700e+01,1.226000e+01,1.798600e+00, & - &1.798000e+00,4.807500e+00,7.700200e+00,1.033600e+01,1.215900e+01, & - &1.251400e+00,1.251100e+00,4.786800e+00,8.010900e+00,1.094600e+01, & - &1.230400e+01,1.343500e+00,1.343100e+00,4.817900e+00,7.987700e+00, & - &1.089700e+01,1.242700e+01,1.443500e+00,1.443000e+00,4.831400e+00, & - &7.935300e+00,1.078800e+01,1.247000e+01,1.553800e+00,1.553300e+00, & - &4.831800e+00,7.858200e+00,1.062700e+01,1.243800e+01,1.681000e+00, & - &1.680400e+00,4.820300e+00,7.752800e+00,1.041600e+01,1.233900e+01/ - data absb(721:1080,11) / & - &1.128200e+00,1.128000e+00,4.769900e+00,8.031500e+00,1.100000e+01, & - &1.239600e+01,1.216700e+00,1.216400e+00,4.812500e+00,8.024300e+00, & - &1.097000e+01,1.254400e+01,1.315800e+00,1.315500e+00,4.835900e+00, & - &7.981400e+00,1.087200e+01,1.261500e+01,1.428400e+00,1.428000e+00, & - &4.841700e+00,7.912000e+00,1.072200e+01,1.259600e+01,1.561200e+00, & - &1.560600e+00,4.834800e+00,7.813100e+00,1.051600e+01,1.250400e+01, & - &1.020400e+00,1.020200e+00,4.752300e+00,8.047000e+00,1.104100e+01, & - &1.247600e+01,1.104400e+00,1.104200e+00,4.806300e+00,8.052600e+00, & - &1.103100e+01,1.265600e+01,1.202600e+00,1.202300e+00,4.838900e+00, & - &8.020700e+00,1.094500e+01,1.275400e+01,1.317100e+00,1.316700e+00, & - &4.850800e+00,7.958300e+00,1.080500e+01,1.274600e+01,1.455100e+00, & - &1.454600e+00,4.848600e+00,7.866100e+00,1.060800e+01,1.265900e+01, & - &9.269700e-01,9.269000e-01,4.734500e+00,8.052900e+00,1.107000e+01, & - &1.255400e+01,1.008300e+00,1.008100e+00,4.800700e+00,8.073500e+00, & - &1.107900e+01,1.277300e+01,1.103700e+00,1.103500e+00,4.840200e+00, & - &8.052000e+00,1.100800e+01,1.289300e+01,1.220400e+00,1.220100e+00, & - &4.859000e+00,7.997100e+00,1.087600e+01,1.289200e+01,1.362800e+00, & - &1.362300e+00,4.860600e+00,7.911300e+00,1.068800e+01,1.281000e+01, & - &8.375800e-01,8.376000e-01,4.706300e+00,8.048700e+00,1.108200e+01, & - &1.255600e+01,9.158100e-01,9.157700e-01,4.786900e+00,8.087900e+00, & - &1.112000e+01,1.281600e+01,1.007900e+00,1.007800e+00,4.837100e+00, & - &8.080500e+00,1.107000e+01,1.297000e+01,1.122500e+00,1.122200e+00, & - &4.863900e+00,8.035700e+00,1.095400e+01,1.298900e+01,1.266500e+00, & - &1.266000e+00,4.871400e+00,7.959100e+00,1.077900e+01,1.292600e+01, & - &7.580400e-01,7.581200e-01,4.674600e+00,8.034700e+00,1.107700e+01, & - &1.253000e+01,8.342400e-01,8.342500e-01,4.769000e+00,8.093600e+00, & - &1.114700e+01,1.283700e+01,9.228400e-01,9.227200e-01,4.829500e+00, & - &8.103100e+00,1.112100e+01,1.302600e+01,1.034500e+00,1.034200e+00, & - &4.866000e+00,8.069000e+00,1.102200e+01,1.306900e+01,1.177900e+00, & - &1.177500e+00,4.879200e+00,8.002500e+00,1.086200e+01,1.302800e+01, & - &6.883600e-01,6.885000e-01,4.639500e+00,8.010800e+00,1.105700e+01, & - &1.249300e+01,7.620200e-01,7.620800e-01,4.747800e+00,8.091500e+00, & - &1.116100e+01,1.284700e+01,8.489700e-01,8.488900e-01,4.819400e+00, & - &8.117700e+00,1.116000e+01,1.307100e+01,9.572100e-01,9.569700e-01, & - &4.864200e+00,8.096400e+00,1.108100e+01,1.314200e+01,1.097900e+00, & - &1.097500e+00,4.883800e+00,8.039900e+00,1.093700e+01,1.312200e+01, & - &6.232700e-01,6.234600e-01,4.592000e+00,7.968200e+00,1.101000e+01, & - &1.241000e+01,6.936300e-01,6.937200e-01,4.717200e+00,8.077900e+00, & - &1.115700e+01,1.282300e+01,7.781200e-01,7.780800e-01,4.802400e+00, & - &8.123700e+00,1.119000e+01,1.309200e+01,8.825700e-01,8.824000e-01, & - &4.856400e+00,8.118500e+00,1.113400e+01,1.319900e+01,1.017500e+00, & - &1.017200e+00,4.885200e+00,8.074800e+00,1.101000e+01,1.320800e+01, & - &5.631900e-01,5.634400e-01,4.536200e+00,7.909800e+00,1.094200e+01, & - &1.229100e+01,6.312800e-01,6.314300e-01,4.677300e+00,8.051300e+00, & - &1.113300e+01,1.277300e+01,7.129000e-01,7.128800e-01,4.778800e+00, & - &8.120000e+00,1.120600e+01,1.309200e+01,8.137000e-01,8.135600e-01, & - &4.843100e+00,8.134900e+00,1.117800e+01,1.324500e+01,9.415500e-01, & - &9.412600e-01,4.882800e+00,8.103900e+00,1.107600e+01,1.328300e+01, & - &5.084800e-01,5.087700e-01,4.475900e+00,7.839600e+00,1.085300e+01, & - &1.215700e+01,5.755800e-01,5.757400e-01,4.632100e+00,8.014800e+00, & - &1.109000e+01,1.271000e+01,6.542800e-01,6.543100e-01,4.749000e+00, & - &8.107500e+00,1.120600e+01,1.308100e+01,7.517100e-01,7.516000e-01, & - &4.827200e+00,8.142800e+00,1.121100e+01,1.328300e+01,8.732000e-01, & - &8.729500e-01,4.875600e+00,8.127100e+00,1.113300e+01,1.335400e+01, & - &4.574900e-01,4.578100e-01,4.405000e+00,7.747700e+00,1.073300e+01, & - &1.198800e+01,5.233500e-01,5.235400e-01,4.577700e+00,7.962400e+00, & - &1.102700e+01,1.262200e+01,5.997200e-01,5.997700e-01,4.711300e+00, & - &8.084900e+00,1.118800e+01,1.305100e+01,6.934000e-01,6.933200e-01, & - &4.804200e+00,8.140200e+00,1.123200e+01,1.330900e+01,8.090000e-01, & - &8.088000e-01,4.862900e+00,8.143800e+00,1.118200e+01,1.341500e+01, & - &4.079900e-01,4.083400e-01,4.319200e+00,7.626200e+00,1.057000e+01, & - &1.174800e+01,4.729100e-01,4.731100e-01,4.511100e+00,7.885800e+00, & - &1.093000e+01,1.247400e+01,5.473700e-01,5.474600e-01,4.662200e+00, & - &8.046200e+00,1.114400e+01,1.297200e+01,6.357900e-01,6.357500e-01, & - &4.772200e+00,8.127500e+00,1.123500e+01,1.330000e+01,7.450000e-01, & - &7.448600e-01,4.844400e+00,8.153400e+00,1.122000e+01,1.345500e+01, & - &3.623400e-01,3.627100e-01,4.222900e+00,7.484700e+00,1.038100e+01, & - &1.149100e+01,4.264900e-01,4.267200e-01,4.436200e+00,7.792800e+00, & - &1.080500e+01,1.230700e+01,4.989900e-01,4.991100e-01,4.604700e+00, & - &7.993000e+00,1.107700e+01,1.288200e+01,5.834400e-01,5.834300e-01, & - &4.732600e+00,8.104200e+00,1.121900e+01,1.328000e+01,6.865500e-01, & - &6.864500e-01,4.820900e+00,8.153200e+00,1.124400e+01,1.349000e+01/ - data absb(1081:1410,11) / & - &3.210500e-01,3.214100e-01,4.121800e+00,7.321500e+00,1.016200e+01, & - &1.122300e+01,3.826300e-01,3.829000e-01,4.353800e+00,7.680400e+00, & - &1.065400e+01,1.213000e+01,4.542300e-01,4.543800e-01,4.541300e+00, & - &7.923000e+00,1.098900e+01,1.279100e+01,5.358300e-01,5.358700e-01, & - &4.686100e+00,8.069700e+00,1.118000e+01,1.326000e+01,6.329300e-01, & - &6.328500e-01,4.790500e+00,8.141800e+00,1.125300e+01,1.352700e+01, & - &2.850800e-01,2.854600e-01,4.021600e+00,7.153300e+00,9.924200e+00, & - &1.090800e+01,3.437800e-01,3.440600e-01,4.268400e+00,7.556000e+00, & - &1.048500e+01,1.189600e+01,4.140700e-01,4.142400e-01,4.474600e+00, & - &7.843000e+00,1.088200e+01,1.264700e+01,4.936300e-01,4.937000e-01, & - &4.636600e+00,8.025300e+00,1.112600e+01,1.318600e+01,5.861900e-01, & - &5.861400e-01,4.756600e+00,8.123100e+00,1.124400e+01,1.351600e+01, & - &2.532600e-01,2.536500e-01,3.919700e+00,6.971300e+00,9.664400e+00, & - &1.056300e+01,3.087400e-01,3.090200e-01,4.177800e+00,7.418800e+00, & - &1.030000e+01,1.161900e+01,3.771100e-01,3.772800e-01,4.403000e+00, & - &7.750500e+00,1.075700e+01,1.246600e+01,4.554900e-01,4.555800e-01, & - &4.581600e+00,7.969900e+00,1.105600e+01,1.307400e+01,5.442200e-01, & - &5.441900e-01,4.717300e+00,8.096300e+00,1.121800e+01,1.347200e+01, & - &2.246100e-01,2.250100e-01,3.811000e+00,6.772700e+00,9.378000e+00, & - &1.020400e+01,2.769600e-01,2.772400e-01,4.084600e+00,7.266100e+00, & - &1.009000e+01,1.132500e+01,3.425100e-01,3.427300e-01,4.325800e+00, & - &7.641300e+00,1.060800e+01,1.226600e+01,4.192400e-01,4.193400e-01, & - &4.521500e+00,7.900400e+00,1.096600e+01,1.294800e+01,5.051600e-01, & - &5.051600e-01,4.672900e+00,8.060700e+00,1.117600e+01,1.341800e+01, & - &1.987600e-01,1.992500e-01,3.695700e+00,6.552600e+00,9.062700e+00, & - &9.821500e+00,2.481200e-01,2.484200e-01,3.986300e+00,7.097000e+00, & - &9.850100e+00,1.101800e+01,3.101900e-01,3.104200e-01,4.240000e+00, & - &7.516700e+00,1.043600e+01,1.205200e+01,3.845300e-01,3.846500e-01, & - &4.454300e+00,7.818100e+00,1.085500e+01,1.281100e+01,4.682400e-01, & - &4.682700e-01,4.622100e+00,8.012700e+00,1.111400e+01,1.335700e+01, & - &1.765800e-01,1.773800e-01,3.583000e+00,6.333100e+00,8.750100e+00, & - &9.383000e+00,2.231100e-01,2.234300e-01,3.892400e+00,6.927200e+00, & - &9.606600e+00,1.063700e+01,2.822500e-01,2.824900e-01,4.156700e+00, & - &7.387500e+00,1.026200e+01,1.174500e+01,3.540700e-01,3.542000e-01, & - &4.386900e+00,7.729300e+00,1.073300e+01,1.258700e+01,4.359900e-01, & - &4.360500e-01,4.570500e+00,7.957800e+00,1.104500e+01,1.321300e+01, & - &1.569300e-01,1.582100e-01,3.468300e+00,6.108900e+00,8.428200e+00, & - &8.909000e+00,2.008500e-01,2.012800e-01,3.796300e+00,6.751500e+00, & - &9.351700e+00,1.021500e+01,2.573400e-01,2.575600e-01,4.073700e+00, & - &7.251100e+00,1.007200e+01,1.136200e+01,3.263000e-01,3.264300e-01, & - &4.318300e+00,7.632100e+00,1.059800e+01,1.230500e+01,4.060500e-01, & - &4.061200e-01,4.516600e+00,7.895000e+00,1.096200e+01,1.299400e+01, & - &1.388700e-01,1.410300e-01,3.345200e+00,5.871200e+00,8.083300e+00, & - &8.428200e+00,1.805500e-01,1.812200e-01,3.695700e+00,6.559100e+00, & - &9.075700e+00,9.780500e+00,2.343600e-01,2.345800e-01,3.987800e+00, & - &7.102700e+00,9.862400e+00,1.096100e+01,2.999600e-01,3.000900e-01, & - &4.243100e+00,7.522100e+00,1.044700e+01,1.198900e+01,3.771200e-01, & - &3.771900e-01,4.457700e+00,7.822700e+00,1.086400e+01,1.275000e+01, & - &1.223100e-01,1.257200e-01,3.214900e+00,5.619500e+00,7.718900e+00, & - &7.940900e+00,1.618800e-01,1.630300e-01,3.589500e+00,6.350900e+00, & - &8.778900e+00,9.323900e+00,2.128100e-01,2.130900e-01,3.898400e+00, & - &6.942600e+00,9.631300e+00,1.055100e+01,2.753300e-01,2.754900e-01, & - &4.163500e+00,7.399700e+00,1.028000e+01,1.162900e+01,3.495300e-01, & - &3.496200e-01,4.393300e+00,7.739000e+00,1.074900e+01,1.248300e+01, & - &1.075300e-01,1.125500e-01,3.084500e+00,5.367500e+00,7.351900e+00, & - &7.471400e+00,1.452700e-01,1.471300e-01,3.482300e+00,6.140700e+00, & - &8.478000e+00,8.878100e+00,1.934600e-01,1.939300e-01,3.808600e+00, & - &6.777900e+00,9.392600e+00,1.013900e+01,2.533100e-01,2.534500e-01, & - &4.085800e+00,7.272500e+00,1.010400e+01,1.123800e+01,3.244100e-01, & - &3.245100e-01,4.329000e+00,7.648400e+00,1.062300e+01,1.218000e+01, & - &9.961400e-02,1.057700e-01,3.028800e+00,5.261000e+00,7.197800e+00, & - &7.239400e+00,1.373600e-01,1.396900e-01,3.436600e+00,6.053200e+00, & - &8.350900e+00,8.617900e+00,1.850600e-01,1.856600e-01,3.770800e+00, & - &6.707600e+00,9.291200e+00,9.842200e+00,2.440800e-01,2.442100e-01, & - &4.053100e+00,7.218000e+00,1.002900e+01,1.090000e+01,3.139500e-01, & - &3.140600e-01,4.301600e+00,7.608500e+00,1.056800e+01,1.180900e+01/ - data absb(1:360,12) / & - &1.507100e+01,1.506200e+01,1.155300e+01,8.042200e+00,5.177500e+00, & - &4.427600e+00,1.504500e+01,1.503700e+01,1.152300e+01,8.006800e+00, & - &5.060300e+00,4.346800e+00,1.493200e+01,1.492400e+01,1.142800e+01, & - &7.930500e+00,4.943400e+00,4.274300e+00,1.479300e+01,1.478500e+01, & - &1.131800e+01,7.850900e+00,4.834500e+00,4.233800e+00,1.461600e+01, & - &1.460700e+01,1.117200e+01,7.737300e+00,4.718100e+00,4.238200e+00, & - &1.610900e+01,1.610000e+01,1.231300e+01,8.515800e+00,5.530700e+00, & - &4.839200e+00,1.602600e+01,1.601700e+01,1.224400e+01,8.463200e+00, & - &5.410800e+00,4.739900e+00,1.587400e+01,1.586500e+01,1.212700e+01, & - &8.378600e+00,5.284300e+00,4.648000e+00,1.569000e+01,1.568100e+01, & - &1.198200e+01,8.268700e+00,5.144200e+00,4.566300e+00,1.546700e+01, & - &1.545800e+01,1.181000e+01,8.147300e+00,5.003100e+00,4.506700e+00, & - &1.695000e+01,1.694000e+01,1.293600e+01,8.924300e+00,5.913900e+00, & - &5.339200e+00,1.679500e+01,1.678600e+01,1.281700e+01,8.840300e+00, & - &5.772800e+00,5.217300e+00,1.661800e+01,1.660800e+01,1.267500e+01, & - &8.733500e+00,5.629400e+00,5.107600e+00,1.636300e+01,1.635400e+01, & - &1.247700e+01,8.592600e+00,5.484400e+00,5.017400e+00,1.607100e+01, & - &1.606100e+01,1.226300e+01,8.451600e+00,5.350500e+00,4.921700e+00, & - &1.748300e+01,1.747300e+01,1.333100e+01,9.193000e+00,6.313500e+00, & - &5.909400e+00,1.726500e+01,1.725500e+01,1.315800e+01,9.064000e+00, & - &6.175200e+00,5.763600e+00,1.700100e+01,1.699200e+01,1.296100e+01, & - &8.927200e+00,6.042100e+00,5.642000e+00,1.671500e+01,1.670600e+01, & - &1.275000e+01,8.787300e+00,5.906700e+00,5.525000e+00,1.640000e+01, & - &1.639100e+01,1.250900e+01,8.623800e+00,5.767000e+00,5.440800e+00, & - &1.761100e+01,1.760100e+01,1.342300e+01,9.286500e+00,6.828600e+00, & - &6.519200e+00,1.735100e+01,1.734100e+01,1.323100e+01,9.150600e+00, & - &6.689300e+00,6.374800e+00,1.705600e+01,1.704700e+01,1.301300e+01, & - &9.010400e+00,6.543700e+00,6.252600e+00,1.674700e+01,1.673800e+01, & - &1.277800e+01,8.849000e+00,6.393600e+00,6.132100e+00,1.642500e+01, & - &1.641600e+01,1.253100e+01,8.680000e+00,6.239400e+00,6.034100e+00, & - &1.737300e+01,1.736300e+01,1.325900e+01,9.298700e+00,7.443400e+00, & - &7.198600e+00,1.707500e+01,1.706500e+01,1.303500e+01,9.149200e+00, & - &7.287100e+00,7.060600e+00,1.675600e+01,1.674700e+01,1.279600e+01, & - &8.986900e+00,7.122900e+00,6.936500e+00,1.644800e+01,1.643800e+01, & - &1.255900e+01,8.810200e+00,6.961400e+00,6.795300e+00,1.612700e+01, & - &1.611800e+01,1.231100e+01,8.628400e+00,6.800900e+00,6.671200e+00, & - &1.674600e+01,1.673600e+01,1.280300e+01,9.316700e+00,8.093400e+00, & - &7.960400e+00,1.643500e+01,1.642600e+01,1.256700e+01,9.142600e+00, & - &7.924300e+00,7.808300e+00,1.612300e+01,1.611400e+01,1.232900e+01, & - &8.951800e+00,7.752700e+00,7.662700e+00,1.581800e+01,1.580900e+01, & - &1.209400e+01,8.755900e+00,7.578200e+00,7.508000e+00,1.549800e+01, & - &1.549000e+01,1.184500e+01,8.556300e+00,7.399700e+00,7.355200e+00, & - &1.580800e+01,1.579900e+01,1.210900e+01,9.356000e+00,8.754000e+00, & - &8.797800e+00,1.550300e+01,1.549400e+01,1.187300e+01,9.147900e+00, & - &8.575200e+00,8.630700e+00,1.519400e+01,1.518500e+01,1.163600e+01, & - &8.939200e+00,8.395500e+00,8.473100e+00,1.489400e+01,1.488600e+01, & - &1.140300e+01,8.729600e+00,8.217000e+00,8.298900e+00,1.457200e+01, & - &1.456300e+01,1.115200e+01,8.511500e+00,8.038200e+00,8.121400e+00, & - &1.461800e+01,1.460900e+01,1.122400e+01,9.474900e+00,9.467400e+00, & - &9.717600e+00,1.432000e+01,1.431200e+01,1.099300e+01,9.261300e+00, & - &9.287100e+00,9.539200e+00,1.403000e+01,1.402200e+01,1.077000e+01, & - &9.045100e+00,9.107600e+00,9.360400e+00,1.373100e+01,1.372400e+01, & - &1.053800e+01,8.819300e+00,8.918900e+00,9.166100e+00,1.341200e+01, & - &1.340500e+01,1.028800e+01,8.597800e+00,8.726900e+00,8.963400e+00, & - &1.325200e+01,1.324500e+01,1.026300e+01,9.688400e+00,1.023700e+01, & - &1.065900e+01,1.297400e+01,1.296700e+01,1.004500e+01,9.463500e+00, & - &1.005100e+01,1.047000e+01,1.268600e+01,1.267900e+01,9.820400e+00, & - &9.233600e+00,9.853200e+00,1.027600e+01,1.239200e+01,1.238500e+01, & - &9.585300e+00,9.007700e+00,9.646000e+00,1.005700e+01,1.208000e+01, & - &1.207300e+01,9.337300e+00,8.776300e+00,9.429000e+00,9.825700e+00, & - &1.180200e+01,1.179600e+01,9.395500e+00,9.979300e+00,1.107100e+01, & - &1.159000e+01,1.153200e+01,1.152600e+01,9.174000e+00,9.751000e+00, & - &1.085300e+01,1.138700e+01,1.125400e+01,1.124800e+01,8.945700e+00, & - &9.527900e+00,1.062100e+01,1.117600e+01,1.097100e+01,1.096500e+01, & - &8.704900e+00,9.294700e+00,1.037300e+01,1.093900e+01,1.069400e+01, & - &1.068800e+01,8.469100e+00,9.052000e+00,1.011800e+01,1.069200e+01, & - &1.033900e+01,1.033400e+01,8.741600e+00,1.031100e+01,1.186900e+01, & - &1.249600e+01,1.007900e+01,1.007400e+01,8.511800e+00,1.008500e+01, & - &1.162300e+01,1.226600e+01,9.823700e+00,9.818300e+00,8.273900e+00, & - &9.850200e+00,1.136200e+01,1.204100e+01,9.583700e+00,9.578500e+00, & - &8.035200e+00,9.606000e+00,1.108700e+01,1.179500e+01,9.402200e+00, & - &9.397100e+00,7.813000e+00,9.348800e+00,1.080200e+01,1.153000e+01/ - data absb(361:720,12) / & - &8.915900e+00,8.911200e+00,8.325300e+00,1.068000e+01,1.262400e+01, & - &1.334900e+01,8.685600e+00,8.681000e+00,8.090100e+00,1.043400e+01, & - &1.235700e+01,1.311700e+01,8.495500e+00,8.490900e+00,7.852000e+00, & - &1.017900e+01,1.207000e+01,1.288900e+01,8.366900e+00,8.362400e+00, & - &7.620600e+00,9.907400e+00,1.176900e+01,1.262700e+01,8.295100e+00, & - &8.290600e+00,7.426300e+00,9.632200e+00,1.145900e+01,1.233900e+01, & - &7.591800e+00,7.587800e+00,8.044800e+00,1.104700e+01,1.330800e+01, & - &1.418100e+01,7.441700e+00,7.437800e+00,7.811800e+00,1.078200e+01, & - &1.303200e+01,1.394600e+01,7.359000e+00,7.355100e+00,7.578000e+00, & - &1.049700e+01,1.272100e+01,1.369600e+01,7.350200e+00,7.346200e+00, & - &7.371400e+00,1.020300e+01,1.239900e+01,1.340900e+01,7.427600e+00, & - &7.423600e+00,7.217300e+00,9.899800e+00,1.206400e+01,1.310500e+01, & - &6.468300e+00,6.464900e+00,7.881200e+00,1.137500e+01,1.392700e+01, & - &1.496600e+01,6.418900e+00,6.415600e+00,7.647200e+00,1.108800e+01, & - &1.363800e+01,1.471600e+01,6.459100e+00,6.455700e+00,7.424500e+00, & - &1.078500e+01,1.332600e+01,1.445100e+01,6.589500e+00,6.586100e+00, & - &7.254000e+00,1.046600e+01,1.298800e+01,1.414100e+01,6.767300e+00, & - &6.763800e+00,7.125300e+00,1.014500e+01,1.263000e+01,1.380500e+01, & - &5.581200e+00,5.578300e+00,7.768900e+00,1.165800e+01,1.450400e+01, & - &1.567600e+01,5.649400e+00,5.646500e+00,7.532400e+00,1.135600e+01, & - &1.420800e+01,1.542000e+01,5.806300e+00,5.803300e+00,7.335000e+00, & - &1.103500e+01,1.388300e+01,1.513600e+01,5.998200e+00,5.995200e+00, & - &7.189500e+00,1.070500e+01,1.352300e+01,1.479600e+01,6.227500e+00, & - &6.224300e+00,7.084700e+00,1.036300e+01,1.314400e+01,1.444000e+01, & - &4.926300e+00,4.923900e+00,7.673800e+00,1.188600e+01,1.503400e+01, & - &1.630300e+01,5.090500e+00,5.088000e+00,7.451100e+00,1.157700e+01, & - &1.472500e+01,1.605600e+01,5.291000e+00,5.288400e+00,7.282400e+00, & - &1.124500e+01,1.437100e+01,1.573700e+01,5.538800e+00,5.536100e+00, & - &7.156600e+00,1.090300e+01,1.399500e+01,1.537300e+01,5.814000e+00, & - &5.811100e+00,7.064200e+00,1.055100e+01,1.359000e+01,1.502300e+01, & - &4.448100e+00,4.446000e+00,7.592700e+00,1.207200e+01,1.550600e+01, & - &1.687200e+01,4.649500e+00,4.647300e+00,7.399100e+00,1.176400e+01, & - &1.517300e+01,1.660900e+01,4.902600e+00,4.900300e+00,7.249900e+00, & - &1.142600e+01,1.479500e+01,1.626100e+01,5.174800e+00,5.172300e+00, & - &7.140200e+00,1.107300e+01,1.439900e+01,1.588600e+01,5.466900e+00, & - &5.464100e+00,7.051300e+00,1.071200e+01,1.396900e+01,1.554600e+01, & - &4.082600e+00,4.080800e+00,7.524800e+00,1.223000e+01,1.590900e+01, & - &1.737200e+01,4.320300e+00,4.318400e+00,7.358300e+00,1.192100e+01, & - &1.554600e+01,1.707300e+01,4.582000e+00,4.579900e+00,7.231100e+00, & - &1.157700e+01,1.515300e+01,1.671300e+01,4.869500e+00,4.867200e+00, & - &7.128600e+00,1.121200e+01,1.472400e+01,1.638100e+01,5.181600e+00, & - &5.179000e+00,7.046900e+00,1.084700e+01,1.427400e+01,1.604800e+01, & - &3.796800e+00,3.795200e+00,7.473900e+00,1.236100e+01,1.623900e+01, & - &1.780000e+01,4.044700e+00,4.043000e+00,7.333800e+00,1.205000e+01, & - &1.585500e+01,1.748400e+01,4.317900e+00,4.315900e+00,7.218300e+00, & - &1.170200e+01,1.544200e+01,1.716100e+01,4.621300e+00,4.619100e+00, & - &7.124000e+00,1.132900e+01,1.499100e+01,1.685800e+01,4.948500e+00, & - &4.946000e+00,7.048300e+00,1.095400e+01,1.451600e+01,1.649100e+01, & - &3.556800e+00,3.555400e+00,7.433700e+00,1.247100e+01,1.650700e+01, & - &1.816700e+01,3.819100e+00,3.817400e+00,7.316200e+00,1.215000e+01, & - &1.610700e+01,1.787800e+01,4.108100e+00,4.106100e+00,7.215400e+00, & - &1.179500e+01,1.567000e+01,1.761700e+01,4.424400e+00,4.422300e+00, & - &7.130500e+00,1.141300e+01,1.519600e+01,1.728200e+01,4.767700e+00, & - &4.765300e+00,7.054200e+00,1.103600e+01,1.469800e+01,1.688800e+01, & - &3.352100e+00,3.350700e+00,7.412800e+00,1.255900e+01,1.673400e+01, & - &1.850600e+01,3.629100e+00,3.627500e+00,7.312800e+00,1.223200e+01, & - &1.631700e+01,1.828000e+01,3.931700e+00,3.929800e+00,7.221200e+00, & - &1.187200e+01,1.585400e+01,1.800500e+01,4.259300e+00,4.257200e+00, & - &7.142300e+00,1.148100e+01,1.536000e+01,1.764300e+01,4.615300e+00, & - &4.613000e+00,7.065000e+00,1.110500e+01,1.484200e+01,1.722600e+01, & - &3.159800e+00,3.158500e+00,7.414200e+00,1.265700e+01,1.694500e+01, & - &1.887200e+01,3.444200e+00,3.442700e+00,7.325700e+00,1.232700e+01, & - &1.651600e+01,1.867300e+01,3.758700e+00,3.756900e+00,7.240900e+00, & - &1.196000e+01,1.603600e+01,1.837300e+01,4.096400e+00,4.094400e+00, & - &7.163300e+00,1.156700e+01,1.552600e+01,1.797900e+01,4.468600e+00, & - &4.466300e+00,7.086000e+00,1.119000e+01,1.499200e+01,1.754400e+01, & - &2.965400e+00,2.964100e+00,7.431300e+00,1.276600e+01,1.716000e+01, & - &1.922700e+01,3.257000e+00,3.255500e+00,7.349500e+00,1.243600e+01, & - &1.672300e+01,1.903300e+01,3.579700e+00,3.578000e+00,7.271100e+00, & - &1.206900e+01,1.623300e+01,1.871500e+01,3.931600e+00,3.929700e+00, & - &7.191900e+00,1.167500e+01,1.571100e+01,1.831400e+01,4.312700e+00, & - &4.310500e+00,7.110100e+00,1.129300e+01,1.516600e+01,1.786500e+01/ - data absb(721:1080,12) / & - &2.753300e+00,2.752200e+00,7.457700e+00,1.290600e+01,1.740500e+01, & - &1.954600e+01,3.048600e+00,3.047200e+00,7.383900e+00,1.258200e+01, & - &1.696700e+01,1.936700e+01,3.377200e+00,3.375600e+00,7.309300e+00, & - &1.221800e+01,1.647600e+01,1.905000e+01,3.738100e+00,3.736200e+00, & - &7.230300e+00,1.182600e+01,1.594600e+01,1.865900e+01,4.124600e+00, & - &4.122500e+00,7.145500e+00,1.144000e+01,1.539500e+01,1.821200e+01, & - &2.562000e+00,2.561000e+00,7.480800e+00,1.303000e+01,1.761900e+01, & - &1.984100e+01,2.860800e+00,2.859500e+00,7.417400e+00,1.271400e+01, & - &1.718800e+01,1.968300e+01,3.195600e+00,3.194200e+00,7.344000e+00, & - &1.235300e+01,1.669600e+01,1.936900e+01,3.564900e+00,3.563100e+00, & - &7.267000e+00,1.196500e+01,1.616300e+01,1.899400e+01,3.958500e+00, & - &3.956500e+00,7.181700e+00,1.157300e+01,1.560400e+01,1.855000e+01, & - &2.389600e+00,2.388700e+00,7.503100e+00,1.314500e+01,1.780600e+01, & - &2.012300e+01,2.694900e+00,2.693700e+00,7.445500e+00,1.283000e+01, & - &1.738000e+01,1.997900e+01,3.036200e+00,3.034800e+00,7.375600e+00, & - &1.247400e+01,1.689000e+01,1.968300e+01,3.411600e+00,3.409900e+00, & - &7.301000e+00,1.208900e+01,1.635700e+01,1.933100e+01,3.812500e+00, & - &3.810500e+00,7.216100e+00,1.169500e+01,1.579300e+01,1.889300e+01, & - &2.208400e+00,2.207600e+00,7.525700e+00,1.327200e+01,1.801100e+01, & - &2.032700e+01,2.514200e+00,2.513200e+00,7.477600e+00,1.296900e+01, & - &1.759900e+01,2.022300e+01,2.857100e+00,2.855800e+00,7.410400e+00, & - &1.262200e+01,1.711500e+01,1.995100e+01,3.235500e+00,3.233900e+00, & - &7.341200e+00,1.224100e+01,1.658600e+01,1.962500e+01,3.640200e+00, & - &3.638300e+00,7.255900e+00,1.184600e+01,1.602300e+01,1.919300e+01, & - &2.039200e+00,2.038400e+00,7.549700e+00,1.338800e+01,1.819600e+01, & - &2.049900e+01,2.345300e+00,2.344400e+00,7.505500e+00,1.310300e+01, & - &1.780000e+01,2.044100e+01,2.688900e+00,2.687600e+00,7.444200e+00, & - &1.276400e+01,1.733000e+01,2.020100e+01,3.067400e+00,3.065900e+00, & - &7.377300e+00,1.238800e+01,1.680600e+01,1.990100e+01,3.473900e+00, & - &3.472200e+00,7.293200e+00,1.199600e+01,1.624800e+01,1.947800e+01, & - &1.884200e+00,1.883500e+00,7.573800e+00,1.349200e+01,1.835600e+01, & - &2.065100e+01,2.191600e+00,2.190700e+00,7.528400e+00,1.322400e+01, & - &1.798200e+01,2.063900e+01,2.534400e+00,2.533200e+00,7.475600e+00, & - &1.289500e+01,1.752800e+01,2.043800e+01,2.911500e+00,2.910100e+00, & - &7.410700e+00,1.252600e+01,1.701400e+01,2.017000e+01,3.317600e+00, & - &3.316000e+00,7.330000e+00,1.213800e+01,1.646000e+01,1.975900e+01, & - &1.726700e+00,1.726000e+00,7.595000e+00,1.359700e+01,1.851300e+01, & - &2.077000e+01,2.031800e+00,2.031000e+00,7.550800e+00,1.335000e+01, & - &1.817200e+01,2.081500e+01,2.371100e+00,2.370000e+00,7.506700e+00, & - &1.303700e+01,1.773900e+01,2.066700e+01,2.743000e+00,2.741700e+00, & - &7.443300e+00,1.267900e+01,1.723600e+01,2.043400e+01,3.147000e+00, & - &3.145400e+00,7.368600e+00,1.229200e+01,1.669100e+01,2.004800e+01, & - &1.576100e+00,1.575600e+00,7.612600e+00,1.369100e+01,1.864800e+01, & - &2.086200e+01,1.875300e+00,1.874600e+00,7.572500e+00,1.346800e+01, & - &1.835100e+01,2.096800e+01,2.209600e+00,2.208600e+00,7.534200e+00, & - &1.317700e+01,1.794500e+01,2.088700e+01,2.575400e+00,2.574200e+00, & - &7.476700e+00,1.283200e+01,1.746000e+01,2.069200e+01,2.973800e+00, & - &2.972300e+00,7.406600e+00,1.245000e+01,1.692500e+01,2.034200e+01, & - &1.439200e+00,1.438700e+00,7.628900e+00,1.376900e+01,1.876000e+01, & - &2.093500e+01,1.728600e+00,1.727900e+00,7.592100e+00,1.357400e+01, & - &1.850900e+01,2.110500e+01,2.058100e+00,2.057200e+00,7.555800e+00, & - &1.330700e+01,1.813100e+01,2.110100e+01,2.418000e+00,2.416900e+00, & - &7.506200e+00,1.297600e+01,1.767200e+01,2.095300e+01,2.808400e+00, & - &2.807000e+00,7.442000e+00,1.260400e+01,1.714900e+01,2.064000e+01, & - &1.309700e+00,1.309300e+00,7.642300e+00,1.382900e+01,1.884900e+01, & - &2.097400e+01,1.585400e+00,1.584800e+00,7.609800e+00,1.367200e+01, & - &1.865100e+01,2.121200e+01,1.907100e+00,1.906300e+00,7.574500e+00, & - &1.343000e+01,1.831400e+01,2.130000e+01,2.259800e+00,2.258800e+00, & - &7.535000e+00,1.311900e+01,1.788000e+01,2.120100e+01,2.641200e+00, & - &2.639900e+00,7.473100e+00,1.276100e+01,1.737400e+01,2.093200e+01, & - &1.183000e+00,1.182600e+00,7.648100e+00,1.386900e+01,1.890800e+01, & - &2.095100e+01,1.440700e+00,1.440200e+00,7.626100e+00,1.376500e+01, & - &1.877500e+01,2.125100e+01,1.749300e+00,1.748500e+00,7.592800e+00, & - &1.355300e+01,1.849200e+01,2.145700e+01,2.094100e+00,2.093100e+00, & - &7.559100e+00,1.326700e+01,1.809100e+01,2.141600e+01,2.466600e+00, & - &2.465400e+00,7.505600e+00,1.292500e+01,1.761000e+01,2.120900e+01, & - &1.069500e+00,1.069200e+00,7.649800e+00,1.388100e+01,1.892700e+01, & - &2.089600e+01,1.308100e+00,1.307600e+00,7.640400e+00,1.383600e+01, & - &1.887300e+01,2.127600e+01,1.600600e+00,1.599900e+00,7.609700e+00, & - &1.365900e+01,1.864700e+01,2.160000e+01,1.935400e+00,1.934500e+00, & - &7.577300e+00,1.340300e+01,1.828600e+01,2.163400e+01,2.298400e+00, & - &2.297300e+00,7.535300e+00,1.308200e+01,1.783600e+01,2.148600e+01/ - data absb(1081:1410,12) / & - &9.648300e-01,9.646400e-01,7.639200e+00,1.386400e+01,1.890100e+01, & - &2.080900e+01,1.188000e+00,1.187600e+00,7.649400e+00,1.388200e+01, & - &1.893900e+01,2.130300e+01,1.461000e+00,1.460400e+00,7.624600e+00, & - &1.375300e+01,1.877300e+01,2.174600e+01,1.782500e+00,1.781700e+00, & - &7.595200e+00,1.352700e+01,1.846400e+01,2.186400e+01,2.136600e+00, & - &2.135700e+00,7.559100e+00,1.322900e+01,1.804600e+01,2.177900e+01, & - &8.733400e-01,8.732100e-01,7.616700e+00,1.381600e+01,1.884000e+01, & - &2.065300e+01,1.084900e+00,1.084600e+00,7.649900e+00,1.390200e+01, & - &1.896600e+01,2.125600e+01,1.339700e+00,1.339300e+00,7.636900e+00, & - &1.382600e+01,1.887000e+01,2.179300e+01,1.645100e+00,1.644400e+00, & - &7.607800e+00,1.362900e+01,1.861200e+01,2.201500e+01,1.990100e+00, & - &1.989300e+00,7.576600e+00,1.335700e+01,1.822700e+01,2.200000e+01, & - &7.910900e-01,7.910100e-01,7.580800e+00,1.373800e+01,1.873800e+01, & - &2.043700e+01,9.915100e-01,9.912500e-01,7.647100e+00,1.389700e+01, & - &1.895900e+01,2.116000e+01,1.229900e+00,1.229500e+00,7.647100e+00, & - &1.387600e+01,1.894000e+01,2.176600e+01,1.518200e+00,1.517600e+00, & - &7.621100e+00,1.371700e+01,1.873600e+01,2.211500e+01,1.851800e+00, & - &1.851000e+00,7.592000e+00,1.347200e+01,1.839300e+01,2.216900e+01, & - &7.158400e-01,7.158100e-01,7.531500e+00,1.362900e+01,1.859200e+01, & - &2.018400e+01,9.043700e-01,9.041900e-01,7.632300e+00,1.386700e+01, & - &1.891800e+01,2.105200e+01,1.129400e+00,1.129000e+00,7.650000e+00, & - &1.390700e+01,1.898200e+01,2.173800e+01,1.399900e+00,1.399400e+00, & - &7.631600e+00,1.379500e+01,1.883800e+01,2.221200e+01,1.718700e+00, & - &1.717900e+00,7.604000e+00,1.357600e+01,1.854200e+01,2.234700e+01, & - &6.451900e-01,6.452500e-01,7.466500e+00,1.349400e+01,1.840100e+01, & - &1.990600e+01,8.229100e-01,8.227600e-01,7.606400e+00,1.380900e+01, & - &1.884100e+01,2.092800e+01,1.036600e+00,1.036300e+00,7.650000e+00, & - &1.391500e+01,1.899300e+01,2.172300e+01,1.289300e+00,1.288800e+00, & - &7.642200e+00,1.385600e+01,1.891800e+01,2.232800e+01,1.591200e+00, & - &1.590500e+00,7.616500e+00,1.366900e+01,1.867400e+01,2.254800e+01, & - &5.843500e-01,5.844400e-01,7.390700e+00,1.332700e+01,1.817800e+01, & - &1.951500e+01,7.536800e-01,7.535600e-01,7.570500e+00,1.372900e+01, & - &1.873400e+01,2.063400e+01,9.560700e-01,9.558000e-01,7.644900e+00, & - &1.390500e+01,1.897700e+01,2.149700e+01,1.193700e+00,1.193300e+00, & - &7.649900e+00,1.389600e+01,1.897300e+01,2.221200e+01,1.479700e+00, & - &1.479100e+00,7.626100e+00,1.374500e+01,1.877900e+01,2.252700e+01, & - &5.285400e-01,5.286700e-01,7.304400e+00,1.313100e+01,1.792400e+01, & - &1.904700e+01,6.911800e-01,6.910900e-01,7.525400e+00,1.362800e+01, & - &1.859700e+01,2.024900e+01,8.829300e-01,8.827200e-01,7.630700e+00, & - &1.387300e+01,1.893300e+01,2.115800e+01,1.109100e+00,1.108700e+00, & - &7.650700e+00,1.391900e+01,1.900200e+01,2.190000e+01,1.379100e+00, & - &1.378600e+00,7.634800e+00,1.381000e+01,1.886300e+01,2.236700e+01, & - &4.756000e-01,4.758300e-01,7.200700e+00,1.290800e+01,1.762400e+01, & - &1.855900e+01,6.320500e-01,6.320600e-01,7.467900e+00,1.350700e+01, & - &1.842600e+01,1.986000e+01,8.136000e-01,8.134400e-01,7.607400e+00, & - &1.382100e+01,1.886300e+01,2.082500e+01,1.030100e+00,1.029800e+00, & - &7.650600e+00,1.392400e+01,1.901100e+01,2.155700e+01,1.284100e+00, & - &1.283600e+00,7.643700e+00,1.386400e+01,1.893300e+01,2.216200e+01, & - &4.260300e-01,4.263700e-01,7.080000e+00,1.265100e+01,1.727900e+01, & - &1.804400e+01,5.762000e-01,5.762300e-01,7.396000e+00,1.334900e+01, & - &1.821500e+01,1.944800e+01,7.495000e-01,7.493700e-01,7.573600e+00, & - &1.374500e+01,1.876100e+01,2.048000e+01,9.547600e-01,9.544800e-01, & - &7.645500e+00,1.391300e+01,1.899300e+01,2.123900e+01,1.194700e+00, & - &1.194300e+00,7.650700e+00,1.390000e+01,1.898200e+01,2.187900e+01, & - &3.822200e-01,3.825800e-01,6.948700e+00,1.237600e+01,1.691100e+01, & - &1.752500e+01,5.252800e-01,5.253800e-01,7.317700e+00,1.316900e+01, & - &1.797700e+01,1.901300e+01,6.918600e-01,6.917600e-01,7.532600e+00, & - &1.365100e+01,1.863300e+01,2.013900e+01,8.866200e-01,8.863900e-01, & - &7.633400e+00,1.388500e+01,1.895300e+01,2.094200e+01,1.115200e+00, & - &1.114900e+00,7.651300e+00,1.392300e+01,1.901200e+01,2.152500e+01, & - &3.640100e-01,3.643700e-01,6.888600e+00,1.225600e+01,1.675100e+01, & - &1.727700e+01,5.041200e-01,5.042300e-01,7.280700e+00,1.308800e+01, & - &1.787100e+01,1.876700e+01,6.684100e-01,6.683300e-01,7.513800e+00, & - &1.361000e+01,1.857500e+01,1.986500e+01,8.592500e-01,8.590500e-01, & - &7.626300e+00,1.387000e+01,1.893200e+01,2.063700e+01,1.084300e+00, & - &1.084000e+00,7.650900e+00,1.392800e+01,1.901900e+01,2.112600e+01/ - data absb(1:360,13) / & - &2.139200e+01,2.138000e+01,1.637700e+01,1.137300e+01,6.638200e+00, & - &5.407200e+00,2.098400e+01,2.097300e+01,1.606500e+01,1.115500e+01, & - &6.480900e+00,5.281600e+00,2.057100e+01,2.056000e+01,1.574200e+01, & - &1.091800e+01,6.314200e+00,5.139900e+00,2.011600e+01,2.010400e+01, & - &1.538500e+01,1.066100e+01,6.135300e+00,5.034200e+00,1.966500e+01, & - &1.965400e+01,1.504100e+01,1.041000e+01,5.965900e+00,5.104600e+00, & - &2.261100e+01,2.259800e+01,1.728600e+01,1.197900e+01,6.984800e+00, & - &5.800300e+00,2.223500e+01,2.222200e+01,1.699900e+01,1.176300e+01, & - &6.830700e+00,5.614300e+00,2.184500e+01,2.183200e+01,1.668400e+01, & - &1.153200e+01,6.672500e+00,5.476800e+00,2.145500e+01,2.144200e+01, & - &1.637700e+01,1.131300e+01,6.520600e+00,5.362400e+00,2.108100e+01, & - &2.106900e+01,1.607800e+01,1.109000e+01,6.382300e+00,5.230700e+00, & - &2.408500e+01,2.407100e+01,1.839400e+01,1.270900e+01,7.496000e+00, & - &6.331700e+00,2.374400e+01,2.373100e+01,1.811800e+01,1.249900e+01, & - &7.342200e+00,6.143100e+00,2.338400e+01,2.337100e+01,1.783600e+01, & - &1.230100e+01,7.189500e+00,5.990500e+00,2.307900e+01,2.306500e+01, & - &1.759800e+01,1.212500e+01,7.048500e+00,5.845500e+00,2.279000e+01, & - &2.277700e+01,1.735400e+01,1.193800e+01,6.899900e+00,5.741000e+00, & - &2.569500e+01,2.568000e+01,1.958100e+01,1.347900e+01,8.134900e+00, & - &7.062500e+00,2.542100e+01,2.540600e+01,1.937400e+01,1.333600e+01, & - &7.976000e+00,6.888600e+00,2.517000e+01,2.515500e+01,1.916900e+01, & - &1.318500e+01,7.820800e+00,6.733100e+00,2.491700e+01,2.490200e+01, & - &1.895800e+01,1.302100e+01,7.661300e+00,6.569500e+00,2.467100e+01, & - &2.465600e+01,1.875500e+01,1.285700e+01,7.503800e+00,6.441400e+00, & - &2.748500e+01,2.746900e+01,2.092000e+01,1.435900e+01,8.840300e+00, & - &7.962500e+00,2.726100e+01,2.724500e+01,2.073400e+01,1.422100e+01, & - &8.675200e+00,7.769600e+00,2.701900e+01,2.700300e+01,2.053800e+01, & - &1.406700e+01,8.509500e+00,7.586900e+00,2.677400e+01,2.675800e+01, & - &2.034000e+01,1.391600e+01,8.343300e+00,7.409300e+00,2.648900e+01, & - &2.647300e+01,2.011300e+01,1.374700e+01,8.175700e+00,7.258000e+00, & - &2.907300e+01,2.905600e+01,2.209000e+01,1.513000e+01,9.610800e+00, & - &8.966700e+00,2.884700e+01,2.883000e+01,2.190600e+01,1.498400e+01, & - &9.441500e+00,8.734100e+00,2.861400e+01,2.859700e+01,2.172100e+01, & - &1.484000e+01,9.272700e+00,8.530800e+00,2.833300e+01,2.831700e+01, & - &2.149800e+01,1.467700e+01,9.095600e+00,8.332200e+00,2.801900e+01, & - &2.800300e+01,2.125400e+01,1.449900e+01,8.914200e+00,8.146800e+00, & - &3.031500e+01,3.029700e+01,2.300600e+01,1.572400e+01,1.051200e+01, & - &1.001900e+01,3.006100e+01,3.004400e+01,2.280800e+01,1.557700e+01, & - &1.034200e+01,9.764400e+00,2.978700e+01,2.976900e+01,2.259500e+01, & - &1.541900e+01,1.016300e+01,9.532700e+00,2.946400e+01,2.944700e+01, & - &2.234300e+01,1.523900e+01,9.979500e+00,9.329000e+00,2.910400e+01, & - &2.908700e+01,2.206500e+01,1.503900e+01,9.788100e+00,9.129200e+00, & - &3.103600e+01,3.101800e+01,2.354800e+01,1.611300e+01,1.157900e+01, & - &1.115400e+01,3.075500e+01,3.073700e+01,2.333400e+01,1.595700e+01, & - &1.139300e+01,1.089300e+01,3.045200e+01,3.043400e+01,2.309500e+01, & - &1.578000e+01,1.119200e+01,1.065100e+01,3.008600e+01,3.006800e+01, & - &2.281100e+01,1.557700e+01,1.097600e+01,1.044100e+01,2.969600e+01, & - &2.967900e+01,2.251000e+01,1.536300e+01,1.074800e+01,1.021300e+01, & - &3.114400e+01,3.112600e+01,2.363500e+01,1.636000e+01,1.278100e+01, & - &1.241500e+01,3.084400e+01,3.082600e+01,2.340300e+01,1.617200e+01, & - &1.254900e+01,1.214700e+01,3.049800e+01,3.048000e+01,2.313300e+01, & - &1.596000e+01,1.230200e+01,1.188500e+01,3.011100e+01,3.009300e+01, & - &2.283600e+01,1.574200e+01,1.204100e+01,1.164200e+01,2.970000e+01, & - &2.968300e+01,2.251700e+01,1.549600e+01,1.176600e+01,1.138100e+01, & - &3.057900e+01,3.056100e+01,2.321900e+01,1.651000e+01,1.401600e+01, & - &1.379100e+01,3.025200e+01,3.023400e+01,2.296800e+01,1.628300e+01, & - &1.374100e+01,1.348800e+01,2.990600e+01,2.988900e+01,2.270000e+01, & - &1.605100e+01,1.344500e+01,1.318700e+01,2.952300e+01,2.950600e+01, & - &2.240500e+01,1.579400e+01,1.313500e+01,1.290500e+01,2.911600e+01, & - &2.910000e+01,2.209000e+01,1.552100e+01,1.281900e+01,1.259700e+01, & - &2.939700e+01,2.938000e+01,2.234500e+01,1.664000e+01,1.524100e+01, & - &1.527100e+01,2.909600e+01,2.907900e+01,2.211300e+01,1.638200e+01, & - &1.492100e+01,1.490800e+01,2.875900e+01,2.874200e+01,2.185000e+01, & - &1.609800e+01,1.459100e+01,1.455300e+01,2.840500e+01,2.838800e+01, & - &2.157600e+01,1.581000e+01,1.424400e+01,1.421300e+01,2.801000e+01, & - &2.799400e+01,2.126800e+01,1.550800e+01,1.388300e+01,1.384200e+01, & - &2.773600e+01,2.772000e+01,2.111400e+01,1.690400e+01,1.649300e+01, & - &1.679500e+01,2.746200e+01,2.744600e+01,2.090000e+01,1.658200e+01, & - &1.613000e+01,1.639400e+01,2.715100e+01,2.713600e+01,2.066000e+01, & - &1.624700e+01,1.574500e+01,1.597400e+01,2.683100e+01,2.681600e+01, & - &2.040900e+01,1.590800e+01,1.534500e+01,1.556900e+01,2.645900e+01, & - &2.644400e+01,2.012200e+01,1.556000e+01,1.493400e+01,1.513200e+01/ - data absb(361:720,13) / & - &2.574100e+01,2.572600e+01,1.969100e+01,1.726300e+01,1.774700e+01, & - &1.835900e+01,2.549700e+01,2.548200e+01,1.948600e+01,1.689500e+01, & - &1.732600e+01,1.788600e+01,2.524100e+01,2.522700e+01,1.927500e+01, & - &1.651700e+01,1.688900e+01,1.739900e+01,2.494100e+01,2.492700e+01, & - &1.903300e+01,1.612500e+01,1.643600e+01,1.692500e+01,2.462500e+01, & - &2.461100e+01,1.878000e+01,1.572300e+01,1.597100e+01,1.642000e+01, & - &2.354300e+01,2.353000e+01,1.828200e+01,1.764000e+01,1.900000e+01, & - &1.987900e+01,2.334400e+01,2.333000e+01,1.808300e+01,1.723200e+01, & - &1.850800e+01,1.933600e+01,2.313100e+01,2.311800e+01,1.788100e+01, & - &1.680900e+01,1.801200e+01,1.878000e+01,2.289100e+01,2.287800e+01, & - &1.766000e+01,1.638100e+01,1.749600e+01,1.823500e+01,2.263500e+01, & - &2.262300e+01,1.742400e+01,1.594100e+01,1.696500e+01,1.764900e+01, & - &2.126300e+01,2.125100e+01,1.699900e+01,1.807300e+01,2.021800e+01, & - &2.132600e+01,2.113000e+01,2.111800e+01,1.680500e+01,1.760300e+01, & - &1.965500e+01,2.071400e+01,2.096400e+01,2.095300e+01,1.659100e+01, & - &1.714100e+01,1.906800e+01,2.008400e+01,2.081100e+01,2.080000e+01, & - &1.638300e+01,1.666500e+01,1.847700e+01,1.946000e+01,2.067100e+01, & - &2.065900e+01,1.616300e+01,1.618200e+01,1.787500e+01,1.880100e+01, & - &1.900600e+01,1.899500e+01,1.593300e+01,1.851100e+01,2.135500e+01, & - &2.268300e+01,1.893400e+01,1.892300e+01,1.571600e+01,1.800900e+01, & - &2.070800e+01,2.199300e+01,1.887500e+01,1.886400e+01,1.550500e+01, & - &1.748700e+01,2.004100e+01,2.129100e+01,1.886700e+01,1.885600e+01, & - &1.529200e+01,1.696900e+01,1.937000e+01,2.057800e+01,1.892600e+01, & - &1.891600e+01,1.511400e+01,1.644400e+01,1.870000e+01,1.983400e+01, & - &1.686600e+01,1.685600e+01,1.509000e+01,1.893200e+01,2.237800e+01, & - &2.390000e+01,1.689500e+01,1.688500e+01,1.484800e+01,1.839400e+01, & - &2.164200e+01,2.313100e+01,1.700500e+01,1.699600e+01,1.461700e+01, & - &1.783600e+01,2.089900e+01,2.236800e+01,1.718600e+01,1.717700e+01, & - &1.441900e+01,1.727400e+01,2.014800e+01,2.155900e+01,1.741900e+01, & - &1.740900e+01,1.429100e+01,1.670800e+01,1.941400e+01,2.073900e+01, & - &1.495300e+01,1.494500e+01,1.444800e+01,1.932100e+01,2.326600e+01, & - &2.496100e+01,1.514700e+01,1.513800e+01,1.417200e+01,1.872800e+01, & - &2.245100e+01,2.413600e+01,1.542300e+01,1.541500e+01,1.393200e+01, & - &1.813800e+01,2.163600e+01,2.329600e+01,1.578300e+01,1.577400e+01, & - &1.375400e+01,1.753200e+01,2.081500e+01,2.240200e+01,1.622100e+01, & - &1.621200e+01,1.368200e+01,1.693200e+01,2.001400e+01,2.153000e+01, & - &1.334300e+01,1.333500e+01,1.397900e+01,1.965100e+01,2.400600e+01, & - &2.586900e+01,1.369800e+01,1.369000e+01,1.367500e+01,1.900900e+01, & - &2.313300e+01,2.500200e+01,1.416300e+01,1.415500e+01,1.342900e+01, & - &1.837500e+01,2.224300e+01,2.406800e+01,1.471200e+01,1.470300e+01, & - &1.329500e+01,1.774800e+01,2.136200e+01,2.310300e+01,1.531100e+01, & - &1.530300e+01,1.325000e+01,1.711400e+01,2.050000e+01,2.226100e+01, & - &1.205200e+01,1.204500e+01,1.362800e+01,1.991100e+01,2.461800e+01, & - &2.664600e+01,1.258700e+01,1.258000e+01,1.332400e+01,1.923300e+01, & - &2.367900e+01,2.568900e+01,1.321800e+01,1.321000e+01,1.309400e+01, & - &1.855700e+01,2.272200e+01,2.467800e+01,1.391400e+01,1.390700e+01, & - &1.297800e+01,1.790600e+01,2.178200e+01,2.374300e+01,1.465500e+01, & - &1.464600e+01,1.295700e+01,1.724900e+01,2.087400e+01,2.292500e+01, & - &1.106900e+01,1.106300e+01,1.336500e+01,2.010600e+01,2.509700e+01, & - &2.726700e+01,1.175600e+01,1.175000e+01,1.307000e+01,1.939600e+01, & - &2.409500e+01,2.624200e+01,1.253200e+01,1.252500e+01,1.286800e+01, & - &1.868700e+01,2.308700e+01,2.524000e+01,1.336000e+01,1.335200e+01, & - &1.276500e+01,1.801000e+01,2.209900e+01,2.440500e+01,1.422100e+01, & - &1.421300e+01,1.277600e+01,1.733700e+01,2.114400e+01,2.357100e+01, & - &1.033000e+01,1.032500e+01,1.317000e+01,2.027500e+01,2.549200e+01, & - &2.779100e+01,1.114400e+01,1.113700e+01,1.289700e+01,1.953200e+01, & - &2.443000e+01,2.674000e+01,1.203900e+01,1.203200e+01,1.272300e+01, & - &1.880000e+01,2.338300e+01,2.584200e+01,1.297800e+01,1.297100e+01, & - &1.263500e+01,1.809900e+01,2.235200e+01,2.498200e+01,1.393400e+01, & - &1.392600e+01,1.266800e+01,1.741300e+01,2.136100e+01,2.409400e+01, & - &9.725400e+00,9.720100e+00,1.305500e+01,2.046700e+01,2.589000e+01, & - &2.831600e+01,1.064200e+01,1.063600e+01,1.279900e+01,1.969100e+01, & - &2.477600e+01,2.732100e+01,1.163000e+01,1.162400e+01,1.263500e+01, & - &1.893900e+01,2.369100e+01,2.646300e+01,1.266000e+01,1.265300e+01, & - &1.256000e+01,1.821600e+01,2.262100e+01,2.555700e+01,1.368600e+01, & - &1.367800e+01,1.260100e+01,1.751400e+01,2.159800e+01,2.464700e+01, & - &9.182400e+00,9.177500e+00,1.301400e+01,2.070200e+01,2.631900e+01, & - &2.889700e+01,1.017800e+01,1.017300e+01,1.275300e+01,1.989700e+01, & - &2.516400e+01,2.797700e+01,1.124000e+01,1.123400e+01,1.258900e+01, & - &1.912100e+01,2.404300e+01,2.709800e+01,1.233200e+01,1.232500e+01, & - &1.252000e+01,1.837700e+01,2.293800e+01,2.616200e+01,1.342300e+01, & - &1.341500e+01,1.256300e+01,1.766200e+01,2.188300e+01,2.522000e+01/ - data absb(721:1080,13) / & - &8.609900e+00,8.605300e+00,1.304300e+01,2.101900e+01,2.685600e+01, & - &2.956800e+01,9.654600e+00,9.649300e+00,1.276200e+01,2.019700e+01, & - &2.566700e+01,2.866500e+01,1.076900e+01,1.076300e+01,1.258300e+01, & - &1.939400e+01,2.450900e+01,2.777500e+01,1.191000e+01,1.190300e+01, & - &1.250200e+01,1.862400e+01,2.337100e+01,2.679600e+01,1.305400e+01, & - &1.304700e+01,1.253100e+01,1.789000e+01,2.227900e+01,2.583000e+01, & - &8.112400e+00,8.108100e+00,1.309000e+01,2.132300e+01,2.735400e+01, & - &3.022100e+01,9.195500e+00,9.190500e+00,1.278900e+01,2.048000e+01, & - &2.613200e+01,2.933800e+01,1.034600e+01,1.034000e+01,1.259400e+01, & - &1.965700e+01,2.494000e+01,2.843000e+01,1.152600e+01,1.152000e+01, & - &1.249900e+01,1.886400e+01,2.377400e+01,2.741700e+01,1.271000e+01, & - &1.270300e+01,1.251300e+01,1.811000e+01,2.265100e+01,2.642800e+01, & - &7.687500e+00,7.683500e+00,1.314600e+01,2.160000e+01,2.780100e+01, & - &3.087200e+01,8.792900e+00,8.788200e+00,1.283000e+01,2.073900e+01, & - &2.655600e+01,3.000700e+01,9.974400e+00,9.968900e+00,1.261700e+01, & - &1.990100e+01,2.533400e+01,2.907100e+01,1.118400e+01,1.117800e+01, & - &1.250300e+01,1.908500e+01,2.414400e+01,2.802500e+01,1.239700e+01, & - &1.239000e+01,1.250100e+01,1.831400e+01,2.299100e+01,2.702200e+01, & - &7.207300e+00,7.203600e+00,1.324400e+01,2.194100e+01,2.833500e+01, & - &3.147700e+01,8.318300e+00,8.313800e+00,1.290500e+01,2.107100e+01, & - &2.707600e+01,3.059800e+01,9.514000e+00,9.508800e+00,1.266300e+01, & - &2.021300e+01,2.582300e+01,2.967100e+01,1.074400e+01,1.073800e+01, & - &1.252000e+01,1.937700e+01,2.460700e+01,2.861000e+01,1.198300e+01, & - &1.197600e+01,1.249300e+01,1.858800e+01,2.342500e+01,2.760000e+01, & - &6.761100e+00,6.757600e+00,1.334900e+01,2.228000e+01,2.885900e+01, & - &3.204900e+01,7.867400e+00,7.863200e+00,1.299300e+01,2.139500e+01, & - &2.758600e+01,3.115500e+01,9.066500e+00,9.061600e+00,1.272500e+01, & - &2.052200e+01,2.631000e+01,3.024600e+01,1.031100e+01,1.030600e+01, & - &1.254900e+01,1.967400e+01,2.506600e+01,2.917600e+01,1.156800e+01, & - &1.156200e+01,1.249400e+01,1.885900e+01,2.385600e+01,2.816100e+01, & - &6.354800e+00,6.351500e+00,1.345600e+01,2.260800e+01,2.936600e+01, & - &3.260600e+01,7.445100e+00,7.441200e+00,1.308500e+01,2.171100e+01, & - &2.807000e+01,3.169200e+01,8.641100e+00,8.636400e+00,1.279300e+01, & - &2.082200e+01,2.677900e+01,3.080600e+01,9.892900e+00,9.887400e+00, & - &1.258900e+01,1.996200e+01,2.551100e+01,2.973000e+01,1.116600e+01, & - &1.116000e+01,1.250100e+01,1.912700e+01,2.427700e+01,2.871800e+01, & - &5.923600e+00,5.920600e+00,1.359700e+01,2.298000e+01,2.992300e+01, & - &3.317900e+01,6.988500e+00,6.984800e+00,1.320600e+01,2.207000e+01, & - &2.860700e+01,3.224900e+01,8.168200e+00,8.163800e+00,1.288000e+01, & - &2.116500e+01,2.730400e+01,3.138800e+01,9.421100e+00,9.415900e+00, & - &1.265000e+01,2.029000e+01,2.601200e+01,3.033000e+01,1.069900e+01, & - &1.069300e+01,1.252000e+01,1.943800e+01,2.475900e+01,2.931700e+01, & - &5.499800e+00,5.497000e+00,1.374800e+01,2.336400e+01,3.049200e+01, & - &3.375600e+01,6.531100e+00,6.527700e+00,1.334000e+01,2.244200e+01, & - &2.916700e+01,3.282000e+01,7.685700e+00,7.681600e+00,1.298500e+01, & - &2.153100e+01,2.784800e+01,3.197900e+01,8.925600e+00,8.920700e+00, & - &1.272400e+01,2.063500e+01,2.654000e+01,3.095500e+01,1.020900e+01, & - &1.020300e+01,1.255600e+01,1.976800e+01,2.526400e+01,2.993700e+01, & - &5.106600e+00,5.104000e+00,1.389400e+01,2.373500e+01,3.104100e+01, & - &3.432400e+01,6.101500e+00,6.098300e+00,1.348400e+01,2.281300e+01, & - &2.971500e+01,3.340100e+01,7.222000e+00,7.218200e+00,1.310500e+01, & - &2.188900e+01,2.838300e+01,3.257400e+01,8.443800e+00,8.439200e+00, & - &1.280700e+01,2.097500e+01,2.706100e+01,3.159400e+01,9.724300e+00, & - &9.718900e+00,1.260200e+01,2.009800e+01,2.576300e+01,3.058400e+01, & - &4.723500e+00,4.721200e+00,1.404600e+01,2.412100e+01,3.158800e+01, & - &3.488500e+01,5.674200e+00,5.671300e+00,1.364000e+01,2.320100e+01, & - &3.027700e+01,3.399300e+01,6.756200e+00,6.752600e+00,1.324300e+01, & - &2.226600e+01,2.893600e+01,3.317100e+01,7.950000e+00,7.945700e+00, & - &1.290600e+01,2.134100e+01,2.760400e+01,3.225500e+01,9.220400e+00, & - &9.215300e+00,1.267100e+01,2.044800e+01,2.628700e+01,3.126500e+01, & - &4.330000e+00,4.328000e+00,1.421800e+01,2.453200e+01,3.216400e+01, & - &3.543700e+01,5.230600e+00,5.227900e+00,1.381200e+01,2.361600e+01, & - &3.088700e+01,3.458200e+01,6.264600e+00,6.261400e+00,1.340200e+01, & - &2.267800e+01,2.954200e+01,3.373900e+01,7.419200e+00,7.415200e+00, & - &1.303700e+01,2.174800e+01,2.819600e+01,3.292000e+01,8.668300e+00, & - &8.663600e+00,1.276000e+01,2.083000e+01,2.686700e+01,3.194900e+01, & - &3.956300e+00,3.954500e+00,1.439000e+01,2.492400e+01,3.271200e+01, & - &3.597500e+01,4.816300e+00,4.813900e+00,1.398200e+01,2.402200e+01, & - &3.147500e+01,3.517600e+01,5.799500e+00,5.796600e+00,1.357100e+01, & - &2.309300e+01,3.014000e+01,3.433300e+01,6.910100e+00,6.906400e+00, & - &1.318300e+01,2.215100e+01,2.878700e+01,3.360900e+01,8.129000e+00, & - &8.124600e+00,1.286200e+01,2.121800e+01,2.744600e+01,3.268500e+01/ - data absb(1081:1410,13) / & - &3.609500e+00,3.607800e+00,1.455800e+01,2.529600e+01,3.323400e+01, & - &3.650400e+01,4.427100e+00,4.424900e+00,1.415000e+01,2.442300e+01, & - &3.203600e+01,3.577200e+01,5.360300e+00,5.357600e+00,1.374200e+01, & - &2.350000e+01,3.073100e+01,3.496600e+01,6.423400e+00,6.420100e+00, & - &1.333500e+01,2.255300e+01,2.937600e+01,3.435800e+01,7.603200e+00, & - &7.599100e+00,1.298400e+01,2.161600e+01,2.802000e+01,3.350200e+01, & - &3.307500e+00,3.306000e+00,1.471300e+01,2.563500e+01,3.369800e+01, & - &3.691600e+01,4.078500e+00,4.076600e+00,1.431000e+01,2.478800e+01, & - &3.254600e+01,3.625100e+01,4.969700e+00,4.967200e+00,1.390400e+01, & - &2.387300e+01,3.127500e+01,3.548100e+01,5.988000e+00,5.984900e+00, & - &1.348800e+01,2.293100e+01,2.992300e+01,3.494600e+01,7.125300e+00, & - &7.121500e+00,1.311200e+01,2.198900e+01,2.856500e+01,3.416600e+01, & - &3.035000e+00,3.033700e+00,1.485100e+01,2.593500e+01,3.410700e+01, & - &3.723700e+01,3.758700e+00,3.756900e+00,1.446500e+01,2.512900e+01, & - &3.301900e+01,3.665000e+01,4.614200e+00,4.611900e+00,1.405300e+01, & - &2.423300e+01,3.178500e+01,3.594500e+01,5.584800e+00,5.582000e+00, & - &1.364400e+01,2.330000e+01,3.045000e+01,3.542800e+01,6.679800e+00, & - &6.676200e+00,1.324500e+01,2.235000e+01,2.908800e+01,3.474700e+01, & - &2.782500e+00,2.781400e+00,1.497500e+01,2.619500e+01,3.449200e+01, & - &3.751000e+01,3.460500e+00,3.458900e+00,1.461600e+01,2.545500e+01, & - &3.346900e+01,3.704200e+01,4.274400e+00,4.272300e+00,1.420700e+01, & - &2.458500e+01,3.227900e+01,3.642900e+01,5.199400e+00,5.196800e+00, & - &1.379700e+01,2.366100e+01,3.097500e+01,3.593300e+01,6.253100e+00, & - &6.249900e+00,1.338600e+01,2.270600e+01,2.960800e+01,3.536000e+01, & - &2.546200e+00,2.545100e+00,1.507600e+01,2.641400e+01,3.484000e+01, & - &3.776900e+01,3.181500e+00,3.180100e+00,1.475900e+01,2.576600e+01, & - &3.389400e+01,3.743700e+01,3.947600e+00,3.945700e+00,1.436100e+01, & - &2.492400e+01,3.275100e+01,3.693600e+01,4.836000e+00,4.833600e+00, & - &1.395000e+01,2.401200e+01,3.148200e+01,3.650500e+01,5.844400e+00, & - &5.841400e+00,1.353500e+01,2.306800e+01,3.012800e+01,3.604600e+01, & - &2.347600e+00,2.346700e+00,1.516300e+01,2.659800e+01,3.511700e+01, & - &3.785200e+01,2.943900e+00,2.942600e+00,1.488400e+01,2.602900e+01, & - &3.425300e+01,3.763700e+01,3.664100e+00,3.662400e+00,1.450300e+01, & - &2.523100e+01,3.317200e+01,3.716100e+01,4.519300e+00,4.517100e+00, & - &1.408800e+01,2.433400e+01,3.193800e+01,3.665600e+01,5.483800e+00, & - &5.481000e+00,1.367700e+01,2.340000e+01,3.060300e+01,3.632900e+01, & - &2.171000e+00,2.170100e+00,1.523400e+01,2.674700e+01,3.533900e+01, & - &3.788500e+01,2.727800e+00,2.726600e+00,1.498900e+01,2.624500e+01, & - &3.457900e+01,3.768900e+01,3.408200e+00,3.406700e+00,1.463300e+01, & - &2.551000e+01,3.355600e+01,3.724200e+01,4.223800e+00,4.221800e+00, & - &1.422300e+01,2.463900e+01,3.236300e+01,3.666600e+01,5.151300e+00, & - &5.148700e+00,1.381200e+01,2.371200e+01,3.105700e+01,3.627600e+01, & - &2.007900e+00,2.007000e+00,1.528300e+01,2.686400e+01,3.552700e+01, & - &3.790100e+01,2.525400e+00,2.524300e+00,1.507700e+01,2.643300e+01, & - &3.487700e+01,3.769700e+01,3.168400e+00,3.166900e+00,1.475700e+01, & - &2.578000e+01,3.392300e+01,3.734200e+01,3.940700e+00,3.938800e+00, & - &1.435700e+01,2.493400e+01,3.277300e+01,3.676900e+01,4.836400e+00, & - &4.833900e+00,1.394500e+01,2.401800e+01,3.149700e+01,3.617200e+01, & - &1.857800e+00,1.856900e+00,1.530300e+01,2.694900e+01,3.565300e+01, & - &3.787700e+01,2.339100e+00,2.338200e+00,1.516000e+01,2.660400e+01, & - &3.513400e+01,3.776300e+01,2.943900e+00,2.942600e+00,1.487600e+01, & - &2.602800e+01,3.425800e+01,3.743900e+01,3.672200e+00,3.670500e+00, & - &1.449200e+01,2.522100e+01,3.316700e+01,3.686200e+01,4.534000e+00, & - &4.531800e+00,1.407600e+01,2.432200e+01,3.192600e+01,3.616900e+01, & - &1.725700e+00,1.724900e+00,1.530000e+01,2.698700e+01,3.571500e+01, & - &3.777100e+01,2.174700e+00,2.173800e+00,1.522800e+01,2.674700e+01, & - &3.534300e+01,3.783500e+01,2.741300e+00,2.740200e+00,1.497700e+01, & - &2.623200e+01,3.456300e+01,3.743600e+01,3.431600e+00,3.430000e+00, & - &1.461600e+01,2.548400e+01,3.352700e+01,3.693000e+01,4.256300e+00, & - &4.254200e+00,1.420300e+01,2.460800e+01,3.232600e+01,3.624500e+01, & - &1.671800e+00,1.671000e+00,1.529500e+01,2.699300e+01,3.573000e+01, & - &3.760800e+01,2.108900e+00,2.108000e+00,1.525400e+01,2.679900e+01, & - &3.542500e+01,3.778600e+01,2.660400e+00,2.659400e+00,1.501300e+01, & - &2.630900e+01,3.468400e+01,3.734100e+01,3.336400e+00,3.334900e+00, & - &1.466400e+01,2.559100e+01,3.367500e+01,3.666900e+01,4.145100e+00, & - &4.143100e+00,1.425400e+01,2.472300e+01,3.248500e+01,3.587100e+01/ - data absb(1:360,14) / & - &3.184542e+01,3.182741e+01,2.428868e+01,1.674179e+01,9.239244e+00, & - &7.230755e+00,3.106028e+01,3.104226e+01,2.370064e+01,1.635716e+01, & - &9.085222e+00,7.070909e+00,3.044420e+01,3.042688e+01,2.323406e+01, & - &1.604316e+01,8.939490e+00,7.169089e+00,2.996376e+01,2.994649e+01, & - &2.286163e+01,1.577747e+01,8.800413e+00,7.641519e+00,2.953622e+01, & - &2.951965e+01,2.252115e+01,1.553821e+01,8.658045e+00,8.608723e+00, & - &3.468232e+01,3.466240e+01,2.643463e+01,1.820363e+01,1.009988e+01, & - &8.016867e+00,3.418069e+01,3.416077e+01,2.604972e+01,1.795434e+01, & - &9.991549e+00,7.768336e+00,3.379980e+01,3.378059e+01,2.576274e+01, & - &1.775314e+01,9.878435e+00,7.628968e+00,3.347781e+01,3.345860e+01, & - &2.550673e+01,1.756683e+01,9.762279e+00,7.692548e+00,3.317609e+01, & - &3.315718e+01,2.526633e+01,1.738714e+01,9.633685e+00,8.076057e+00, & - &3.846461e+01,3.844232e+01,2.927033e+01,2.010525e+01,1.114164e+01, & - &8.939068e+00,3.823267e+01,3.821108e+01,2.909986e+01,1.999325e+01, & - &1.106834e+01,8.655598e+00,3.803313e+01,3.801154e+01,2.893842e+01, & - &1.986906e+01,1.098153e+01,8.406815e+00,3.782507e+01,3.780348e+01, & - &2.876465e+01,1.973374e+01,1.087232e+01,8.275431e+00,3.760811e+01, & - &3.758629e+01,2.858276e+01,1.958327e+01,1.074729e+01,8.324896e+00, & - &4.324292e+01,4.321798e+01,3.287042e+01,2.252027e+01,1.238420e+01, & - &9.982789e+00,4.316569e+01,4.314046e+01,3.279645e+01,2.245451e+01, & - &1.232944e+01,9.670877e+00,4.305568e+01,4.303045e+01,3.269907e+01, & - &2.236916e+01,1.224561e+01,9.380551e+00,4.291526e+01,4.289003e+01, & - &3.257423e+01,2.225802e+01,1.214378e+01,9.197035e+00,4.269952e+01, & - &4.267472e+01,3.239392e+01,2.211400e+01,1.202122e+01,9.127764e+00, & - &4.883054e+01,4.880230e+01,3.705470e+01,2.531207e+01,1.386581e+01, & - &1.120935e+01,4.884723e+01,4.881829e+01,3.705251e+01,2.529435e+01, & - &1.381406e+01,1.087510e+01,4.881592e+01,4.878741e+01,3.700764e+01, & - &2.523712e+01,1.373188e+01,1.055456e+01,4.868115e+01,4.865290e+01, & - &3.688696e+01,2.512770e+01,1.362160e+01,1.032080e+01,4.847574e+01, & - &4.844724e+01,3.671172e+01,2.497812e+01,1.348684e+01,1.017373e+01, & - &5.527930e+01,5.524705e+01,4.188398e+01,2.851891e+01,1.557021e+01, & - &1.265910e+01,5.536460e+01,5.533230e+01,4.193161e+01,2.852933e+01, & - &1.551060e+01,1.230843e+01,5.532491e+01,5.529262e+01,4.188082e+01, & - &2.847043e+01,1.541198e+01,1.195804e+01,5.518922e+01,5.515666e+01, & - &4.175869e+01,2.835822e+01,1.528215e+01,1.168801e+01,5.492425e+01, & - &5.489170e+01,4.153624e+01,2.817923e+01,1.512070e+01,1.149627e+01, & - &6.248013e+01,6.244400e+01,4.727061e+01,3.208892e+01,1.751815e+01, & - &1.439172e+01,6.257306e+01,6.253630e+01,4.732249e+01,3.210127e+01, & - &1.742468e+01,1.401422e+01,6.252411e+01,6.248735e+01,4.726394e+01, & - &3.203456e+01,1.729613e+01,1.363101e+01,6.232882e+01,6.229206e+01, & - &4.709568e+01,3.189220e+01,1.712775e+01,1.330228e+01,6.199516e+01, & - &6.195866e+01,4.682372e+01,3.168321e+01,1.693025e+01,1.304078e+01, & - &7.029470e+01,7.025363e+01,5.310967e+01,3.595417e+01,1.968252e+01, & - &1.641813e+01,7.034454e+01,7.030347e+01,5.312823e+01,3.594270e+01, & - &1.955189e+01,1.598892e+01,7.022099e+01,7.017992e+01,5.301604e+01, & - &3.584135e+01,1.937936e+01,1.555499e+01,6.993046e+01,6.988939e+01, & - &5.277834e+01,3.565552e+01,1.917095e+01,1.515370e+01,6.947406e+01, & - &6.943369e+01,5.241624e+01,3.538654e+01,1.892889e+01,1.482158e+01, & - &7.857581e+01,7.852847e+01,5.929934e+01,4.005219e+01,2.206153e+01, & - &1.871590e+01,7.853359e+01,7.848889e+01,5.924996e+01,3.999527e+01, & - &2.189023e+01,1.821915e+01,7.829527e+01,7.824792e+01,5.905196e+01, & - &3.983839e+01,2.167038e+01,1.770932e+01,7.786442e+01,7.781972e+01, & - &5.870923e+01,3.958130e+01,2.140728e+01,1.722633e+01,7.725205e+01, & - &7.720579e+01,5.822935e+01,3.923489e+01,2.110529e+01,1.681020e+01, & - &8.711705e+01,8.706654e+01,6.568198e+01,4.427737e+01,2.467279e+01, & - &2.123052e+01,8.692889e+01,8.687907e+01,6.552266e+01,4.414567e+01, & - &2.442310e+01,2.063622e+01,8.650826e+01,8.645511e+01,6.518752e+01, & - &4.389613e+01,2.412395e+01,2.003444e+01,8.588461e+01,8.583217e+01, & - &6.470019e+01,4.354597e+01,2.378225e+01,1.946518e+01,8.505013e+01, & - &8.500102e+01,6.405700e+01,4.309048e+01,2.339236e+01,1.896366e+01, & - &9.571324e+01,9.565533e+01,7.210366e+01,4.852710e+01,2.752361e+01, & - &2.396324e+01,9.531409e+01,9.525881e+01,7.178699e+01,4.829116e+01, & - &2.717147e+01,2.326656e+01,9.467808e+01,9.462350e+01,7.129282e+01, & - &4.793691e+01,2.676179e+01,2.255950e+01,9.381732e+01,9.376274e+01, & - &7.062689e+01,4.746898e+01,2.630993e+01,2.187979e+01,9.274090e+01, & - &9.268368e+01,6.980350e+01,4.689505e+01,2.581705e+01,2.126837e+01, & - &1.040733e+02,1.040133e+02,7.835330e+01,5.266721e+01,3.056394e+01, & - &2.690142e+01,1.034475e+02,1.033845e+02,7.786471e+01,5.231922e+01, & - &3.007611e+01,2.606085e+01,1.025858e+02,1.025231e+02,7.719993e+01, & - &5.185007e+01,2.953619e+01,2.521576e+01,1.014534e+02,1.013933e+02, & - &7.633705e+01,5.125017e+01,2.894664e+01,2.439222e+01,1.001075e+02, & - &1.000485e+02,7.531036e+01,5.054097e+01,2.831363e+01,2.363308e+01/ - data absb(361:720,14) / & - &1.119995e+02,1.119343e+02,8.427766e+01,5.667191e+01,3.371302e+01, & - &2.995658e+01,1.111409e+02,1.110761e+02,8.361633e+01,5.617552e+01, & - &3.305929e+01,2.894120e+01,1.099850e+02,1.099205e+02,8.273120e+01, & - &5.553970e+01,3.234997e+01,2.791784e+01,1.085979e+02,1.085337e+02, & - &8.167590e+01,5.479866e+01,3.159493e+01,2.691635e+01,1.069649e+02, & - &1.069007e+02,8.043822e+01,5.394575e+01,3.080319e+01,2.599062e+01, & - &1.193225e+02,1.192506e+02,8.975036e+01,6.052731e+01,3.687984e+01, & - &3.302596e+01,1.181959e+02,1.181266e+02,8.888937e+01,5.983766e+01, & - &3.602378e+01,3.179665e+01,1.167798e+02,1.167079e+02,8.781025e+01, & - &5.903520e+01,3.511792e+01,3.056347e+01,1.150973e+02,1.150287e+02, & - &8.653258e+01,5.810215e+01,3.417554e+01,2.936963e+01,1.131802e+02, & - &1.131120e+02,8.508367e+01,5.707285e+01,3.320667e+01,2.826073e+01, & - &1.259396e+02,1.258666e+02,9.469530e+01,6.413655e+01,3.997108e+01, & - &3.601704e+01,1.245204e+02,1.244470e+02,9.361362e+01,6.325905e+01, & - &3.888746e+01,3.454304e+01,1.228423e+02,1.227689e+02,9.233985e+01, & - &6.224955e+01,3.776890e+01,3.308934e+01,1.208729e+02,1.207999e+02, & - &9.084970e+01,6.113689e+01,3.662356e+01,3.169366e+01,1.186803e+02, & - &1.186084e+02,8.919293e+01,5.991968e+01,3.546323e+01,3.039673e+01, & - &1.317851e+02,1.317077e+02,9.906197e+01,6.747784e+01,4.289211e+01, & - &3.883587e+01,1.301168e+02,1.300397e+02,9.779534e+01,6.637308e+01, & - &4.156659e+01,3.710168e+01,1.281433e+02,1.280666e+02,9.630288e+01, & - &6.516776e+01,4.022278e+01,3.541689e+01,1.259249e+02,1.258485e+02, & - &9.462351e+01,6.385719e+01,3.886829e+01,3.382722e+01,1.234514e+02, & - &1.233781e+02,9.275729e+01,6.246161e+01,3.751153e+01,3.235141e+01, & - &1.368324e+02,1.367515e+02,1.028321e+02,7.051644e+01,4.554898e+01, & - &4.139449e+01,1.349174e+02,1.348373e+02,1.013816e+02,6.917667e+01, & - &4.398311e+01,3.940123e+01,1.326980e+02,1.326209e+02,9.970611e+01, & - &6.774797e+01,4.241089e+01,3.749113e+01,1.301973e+02,1.301198e+02, & - &9.781631e+01,6.622966e+01,4.084734e+01,3.573131e+01,1.274686e+02, & - &1.273919e+02,9.575920e+01,6.464288e+01,3.930328e+01,3.409138e+01, & - &1.411244e+02,1.410405e+02,1.060395e+02,7.321820e+01,4.789925e+01, & - &4.364529e+01,1.389690e+02,1.388851e+02,1.044069e+02,7.164497e+01, & - &4.609380e+01,4.139243e+01,1.365033e+02,1.364195e+02,1.025466e+02, & - &6.998939e+01,4.430660e+01,3.929758e+01,1.337708e+02,1.336899e+02, & - &1.004890e+02,6.827626e+01,4.255141e+01,3.738292e+01,1.307769e+02, & - &1.306991e+02,9.823437e+01,6.649638e+01,4.082573e+01,3.560674e+01, & - &1.446908e+02,1.446036e+02,1.087023e+02,7.554592e+01,4.990076e+01, & - &4.552959e+01,1.422896e+02,1.422054e+02,1.068875e+02,7.373782e+01, & - &4.786354e+01,4.306966e+01,1.396010e+02,1.395194e+02,1.048632e+02, & - &7.187817e+01,4.587732e+01,4.084166e+01,1.366369e+02,1.365564e+02, & - &1.026284e+02,6.997001e+01,4.394676e+01,3.880713e+01,1.334327e+02, & - &1.333526e+02,1.002175e+02,6.801703e+01,4.206316e+01,3.694657e+01, & - &1.475809e+02,1.474907e+02,1.108872e+02,7.748142e+01,5.152969e+01, & - &4.704565e+01,1.449564e+02,1.448718e+02,1.088809e+02,7.545798e+01, & - &4.928976e+01,4.446084e+01,1.420479e+02,1.419640e+02,1.066887e+02, & - &7.340599e+01,4.712704e+01,4.212611e+01,1.388761e+02,1.387946e+02, & - &1.043026e+02,7.131470e+01,4.504303e+01,4.001159e+01,1.354834e+02, & - &1.354022e+02,1.017470e+02,6.921340e+01,4.302387e+01,3.822881e+01, & - &1.498699e+02,1.497819e+02,1.126370e+02,7.903161e+01,5.279979e+01, & - &4.825528e+01,1.470419e+02,1.469536e+02,1.104516e+02,7.682064e+01, & - &5.038740e+01,4.558499e+01,1.439561e+02,1.438685e+02,1.081148e+02, & - &7.461347e+01,4.807907e+01,4.319079e+01,1.405788e+02,1.404949e+02, & - &1.055720e+02,7.235634e+01,4.586206e+01,4.113304e+01,1.370035e+02, & - &1.369203e+02,1.028828e+02,7.011569e+01,4.373555e+01,3.960362e+01, & - &1.517378e+02,1.516468e+02,1.140834e+02,8.031396e+01,5.383392e+01, & - &4.928019e+01,1.487407e+02,1.486527e+02,1.117428e+02,7.794196e+01, & - &5.127944e+01,4.654237e+01,1.454568e+02,1.453696e+02,1.092366e+02, & - &7.557098e+01,4.883664e+01,4.415013e+01,1.419407e+02,1.418561e+02, & - &1.065860e+02,7.320001e+01,4.651696e+01,4.232203e+01,1.381996e+02, & - &1.381161e+02,1.037717e+02,7.082648e+01,4.429199e+01,4.113448e+01, & - &1.534379e+02,1.533435e+02,1.154200e+02,8.152008e+01,5.484338e+01, & - &5.035991e+01,1.503249e+02,1.502339e+02,1.129565e+02,7.901568e+01, & - &5.216503e+01,4.757790e+01,1.469090e+02,1.468210e+02,1.103273e+02, & - &7.651160e+01,4.960600e+01,4.531467e+01,1.432592e+02,1.431716e+02, & - &1.075700e+02,7.402689e+01,4.718673e+01,4.379617e+01,1.393994e+02, & - &1.393159e+02,1.046696e+02,7.155582e+01,4.487663e+01,4.295876e+01, & - &1.551342e+02,1.550401e+02,1.167602e+02,8.276626e+01,5.594604e+01, & - &5.159436e+01,1.519234e+02,1.518324e+02,1.141944e+02,8.013482e+01, & - &5.313907e+01,4.879615e+01,1.484185e+02,1.483298e+02,1.114748e+02, & - &7.752254e+01,5.047090e+01,4.672213e+01,1.446824e+02,1.445971e+02, & - &1.086371e+02,7.493997e+01,4.795616e+01,4.548081e+01,1.407355e+02, & - &1.406517e+02,1.056706e+02,7.237972e+01,4.556515e+01,4.501610e+01/ - data absb(721:1080,14) / & - &1.569970e+02,1.569030e+02,1.182726e+02,8.423516e+01,5.732711e+01, & - &5.312356e+01,1.537480e+02,1.536573e+02,1.156306e+02,8.147592e+01, & - &5.438229e+01,5.026195e+01,1.502295e+02,1.501385e+02,1.128646e+02, & - &7.877435e+01,5.159866e+01,4.823013e+01,1.464408e+02,1.463562e+02, & - &1.099615e+02,7.609863e+01,4.897730e+01,4.712766e+01,1.424517e+02, & - &1.423675e+02,1.069561e+02,7.346497e+01,4.650034e+01,4.687133e+01, & - &1.586598e+02,1.585661e+02,1.196458e+02,8.558335e+01,5.861735e+01, & - &5.459790e+01,1.554146e+02,1.553209e+02,1.169564e+02,8.273001e+01, & - &5.554610e+01,5.172164e+01,1.518585e+02,1.517701e+02,1.141270e+02, & - &7.992622e+01,5.265376e+01,4.981118e+01,1.480500e+02,1.479617e+02, & - &1.111825e+02,7.717249e+01,4.993327e+01,4.892083e+01,1.440240e+02, & - &1.439387e+02,1.081369e+02,7.447062e+01,4.737640e+01,4.896283e+01, & - &1.601108e+02,1.600144e+02,1.208688e+02,8.679533e+01,5.980079e+01, & - &5.603899e+01,1.568718e+02,1.567778e+02,1.181260e+02,8.385870e+01, & - &5.660830e+01,5.324400e+01,1.533007e+02,1.532097e+02,1.152552e+02, & - &8.097242e+01,5.361936e+01,5.157548e+01,1.494712e+02,1.493832e+02, & - &1.122701e+02,7.814771e+01,5.080816e+01,5.103349e+01,1.454219e+02, & - &1.453340e+02,1.091879e+02,7.537637e+01,4.817464e+01,5.152607e+01, & - &1.617231e+02,1.616260e+02,1.222642e+02,8.823235e+01,6.124965e+01, & - &5.762160e+01,1.585108e+02,1.584164e+02,1.194734e+02,8.519449e+01, & - &5.791782e+01,5.469489e+01,1.549732e+02,1.548815e+02,1.165816e+02, & - &8.222737e+01,5.482094e+01,5.292413e+01,1.511722e+02,1.510815e+02, & - &1.135810e+02,7.933935e+01,5.190895e+01,5.237346e+01,1.471221e+02, & - &1.470342e+02,1.104738e+02,7.650078e+01,4.918587e+01,5.293117e+01, & - &1.632065e+02,1.631094e+02,1.235901e+02,8.962567e+01,6.268899e+01, & - &5.919820e+01,1.600530e+02,1.599563e+02,1.207681e+02,8.650068e+01, & - &5.922448e+01,5.611709e+01,1.565551e+02,1.564614e+02,1.178536e+02, & - &8.346086e+01,5.601306e+01,5.422140e+01,1.527840e+02,1.526930e+02, & - &1.148432e+02,8.050130e+01,5.300811e+01,5.363321e+01,1.487601e+02, & - &1.486718e+02,1.117237e+02,7.760638e+01,5.019646e+01,5.421587e+01, & - &1.645693e+02,1.644698e+02,1.248365e+02,9.095834e+01,6.408739e+01, & - &6.076065e+01,1.614684e+02,1.613714e+02,1.219867e+02,8.774877e+01, & - &6.049891e+01,5.756106e+01,1.580292e+02,1.579321e+02,1.190545e+02, & - &8.464617e+01,5.717586e+01,5.556866e+01,1.543061e+02,1.542117e+02, & - &1.160410e+02,8.162429e+01,5.407944e+01,5.498093e+01,1.503056e+02, & - &1.502149e+02,1.129146e+02,7.867393e+01,5.118070e+01,5.564976e+01, & - &1.659673e+02,1.658682e+02,1.261604e+02,9.242094e+01,6.567085e+01, & - &6.251548e+01,1.629643e+02,1.628676e+02,1.233077e+02,8.913902e+01, & - &6.195016e+01,5.913257e+01,1.596072e+02,1.595131e+02,1.203687e+02, & - &8.596821e+01,5.849937e+01,5.696104e+01,1.559130e+02,1.558193e+02, & - &1.173256e+02,8.286375e+01,5.529692e+01,5.628060e+01,1.519834e+02, & - &1.518924e+02,1.142170e+02,7.987100e+01,5.230721e+01,5.695628e+01, & - &1.673270e+02,1.672278e+02,1.275027e+02,9.394044e+01,6.735265e+01, & - &6.438960e+01,1.644186e+02,1.643195e+02,1.246364e+02,9.057653e+01, & - &6.348105e+01,6.080455e+01,1.611637e+02,1.610666e+02,1.216938e+02, & - &8.732848e+01,5.990405e+01,5.844502e+01,1.575683e+02,1.574742e+02, & - &1.186654e+02,8.418125e+01,5.659442e+01,5.765483e+01,1.537028e+02, & - &1.536088e+02,1.155609e+02,8.112598e+01,5.350497e+01,5.833767e+01, & - &1.685616e+02,1.684605e+02,1.287824e+02,9.542812e+01,6.904164e+01, & - &6.631894e+01,1.657759e+02,1.656768e+02,1.259134e+02,9.198727e+01, & - &6.502042e+01,6.257116e+01,1.626200e+02,1.625233e+02,1.229680e+02, & - &8.866894e+01,6.131161e+01,6.007532e+01,1.591205e+02,1.590235e+02, & - &1.199473e+02,8.546833e+01,5.788591e+01,5.924258e+01,1.553158e+02, & - &1.552214e+02,1.168404e+02,8.234859e+01,5.470178e+01,6.003104e+01, & - &1.697586e+02,1.696575e+02,1.300902e+02,9.698868e+01,7.085293e+01, & - &6.838688e+01,1.671150e+02,1.670140e+02,1.272204e+02,9.346104e+01, & - &6.665947e+01,6.445074e+01,1.640689e+02,1.639691e+02,1.242721e+02, & - &9.007026e+01,6.281311e+01,6.182010e+01,1.606842e+02,1.605898e+02, & - &1.212655e+02,8.681335e+01,5.926477e+01,6.091627e+01,1.569605e+02, & - &1.568661e+02,1.181667e+02,8.363699e+01,5.597760e+01,6.181177e+01, & - &1.709669e+02,1.708635e+02,1.314818e+02,9.870863e+01,7.290108e+01, & - &7.067251e+01,1.684684e+02,1.683666e+02,1.286089e+02,9.507687e+01, & - &6.850249e+01,6.646616e+01,1.655691e+02,1.654697e+02,1.256760e+02, & - &9.161577e+01,6.449910e+01,6.358633e+01,1.623067e+02,1.622103e+02, & - &1.226694e+02,8.828008e+01,6.081357e+01,6.242675e+01,1.586899e+02, & - &1.585955e+02,1.195826e+02,8.505630e+01,5.740450e+01,6.325093e+01, & - &1.720799e+02,1.719768e+02,1.328363e+02,1.004503e+02,7.500176e+01, & - &7.307120e+01,1.697162e+02,1.696144e+02,1.299624e+02,9.670069e+01, & - &7.039175e+01,6.863411e+01,1.669650e+02,1.668633e+02,1.270320e+02, & - &9.315349e+01,6.621904e+01,6.557349e+01,1.638448e+02,1.637450e+02, & - &1.240437e+02,8.975533e+01,6.239294e+01,6.426224e+01,1.603482e+02, & - &1.602515e+02,1.209716e+02,8.647207e+01,5.885698e+01,6.513879e+01/ - data absb(1081:1410,14) / & - &1.730928e+02,1.729896e+02,1.341583e+02,1.022101e+02,7.716230e+01, & - &7.560756e+01,1.708748e+02,1.707740e+02,1.312934e+02,9.834249e+01, & - &7.234492e+01,7.100912e+01,1.682918e+02,1.681927e+02,1.283778e+02, & - &9.470963e+01,6.798734e+01,6.787167e+01,1.652900e+02,1.651906e+02, & - &1.253872e+02,9.123347e+01,6.400859e+01,6.659273e+01,1.619322e+02, & - &1.618359e+02,1.223319e+02,8.788799e+01,6.034473e+01,6.776337e+01, & - &1.739862e+02,1.738837e+02,1.353943e+02,1.038962e+02,7.926358e+01, & - &7.801256e+01,1.719028e+02,1.717990e+02,1.325269e+02,9.991505e+01, & - &7.424269e+01,7.314868e+01,1.694497e+02,1.693482e+02,1.296109e+02, & - &9.618138e+01,6.969472e+01,6.979048e+01,1.665857e+02,1.664866e+02, & - &1.266355e+02,9.263680e+01,6.556824e+01,6.831253e+01,1.633584e+02, & - &1.632617e+02,1.235926e+02,8.922992e+01,6.177649e+01,6.944682e+01, & - &1.747839e+02,1.746814e+02,1.365839e+02,1.055661e+02,8.137801e+01, & - &8.039503e+01,1.728274e+02,1.727246e+02,1.337000e+02,1.014652e+02, & - &7.613841e+01,7.521729e+01,1.704917e+02,1.703879e+02,1.307881e+02, & - &9.762057e+01,7.140002e+01,7.153773e+01,1.677816e+02,1.676794e+02, & - &1.278233e+02,9.400344e+01,6.712053e+01,6.976321e+01,1.646820e+02, & - &1.645819e+02,1.247979e+02,9.053993e+01,6.320023e+01,7.065503e+01, & - &1.755087e+02,1.754013e+02,1.377589e+02,1.072805e+02,8.354364e+01, & - &8.291808e+01,1.736885e+02,1.735827e+02,1.348601e+02,1.030328e+02, & - &7.808491e+01,7.742518e+01,1.714785e+02,1.713773e+02,1.319503e+02, & - &9.908698e+01,7.316209e+01,7.349690e+01,1.688992e+02,1.687974e+02, & - &1.289913e+02,9.537626e+01,6.870399e+01,7.154974e+01,1.659413e+02, & - &1.658441e+02,1.259909e+02,9.186371e+01,6.465757e+01,7.234853e+01, & - &1.761731e+02,1.760663e+02,1.389359e+02,1.090439e+02,8.577628e+01, & - &8.556172e+01,1.744739e+02,1.743710e+02,1.360005e+02,1.046268e+02, & - &8.009916e+01,7.983311e+01,1.724044e+02,1.723009e+02,1.330962e+02, & - &1.005779e+02,7.498338e+01,7.575645e+01,1.699441e+02,1.698426e+02, & - &1.301384e+02,9.677193e+01,7.034575e+01,7.379778e+01,1.671395e+02, & - &1.670404e+02,1.271589e+02,9.319388e+01,6.615424e+01,7.477881e+01, & - &1.767323e+02,1.766258e+02,1.400119e+02,1.107067e+02,8.790788e+01, & - &8.789110e+01,1.751497e+02,1.750446e+02,1.370473e+02,1.061310e+02, & - &8.202011e+01,8.168435e+01,1.732160e+02,1.731129e+02,1.341432e+02, & - &1.019751e+02,7.670806e+01,7.706477e+01,1.708816e+02,1.707801e+02, & - &1.312045e+02,9.808318e+01,7.190033e+01,7.441115e+01,1.681810e+02, & - &1.680812e+02,1.282169e+02,9.442206e+01,6.756212e+01,7.437908e+01, & - &1.772427e+02,1.771332e+02,1.410541e+02,1.123486e+02,9.002238e+01, & - &9.011151e+01,1.757640e+02,1.756591e+02,1.380628e+02,1.076242e+02, & - &8.390607e+01,8.344045e+01,1.739274e+02,1.738220e+02,1.351260e+02, & - &1.033316e+02,7.840126e+01,7.809772e+01,1.717206e+02,1.716172e+02, & - &1.322042e+02,9.935444e+01,7.343992e+01,7.444692e+01,1.691428e+02, & - &1.690407e+02,1.292288e+02,9.561964e+01,6.894902e+01,7.295718e+01, & - &1.776827e+02,1.775776e+02,1.420924e+02,1.140176e+02,9.219904e+01, & - &9.245324e+01,1.763218e+02,1.762153e+02,1.390699e+02,1.091450e+02, & - &8.584042e+01,8.544398e+01,1.746060e+02,1.745016e+02,1.361162e+02, & - &1.047116e+02,8.014716e+01,7.944153e+01,1.725130e+02,1.724098e+02, & - &1.331889e+02,1.006427e+02,7.501792e+01,7.495066e+01,1.700551e+02, & - &1.699533e+02,1.302297e+02,9.683227e+01,7.037237e+01,7.233418e+01, & - &1.781041e+02,1.779967e+02,1.431615e+02,1.157385e+02,9.445558e+01, & - &9.490491e+01,1.768482e+02,1.767417e+02,1.400840e+02,1.107131e+02, & - &8.785380e+01,8.755968e+01,1.752297e+02,1.751245e+02,1.370947e+02, & - &1.061235e+02,8.195745e+01,8.107771e+01,1.732583e+02,1.731544e+02, & - &1.341607e+02,1.019518e+02,7.663858e+01,7.589754e+01,1.709164e+02, & - &1.708149e+02,1.312175e+02,9.805969e+01,7.183463e+01,7.230851e+01, & - &1.784223e+02,1.783163e+02,1.441589e+02,1.173983e+02,9.665819e+01, & - &9.732758e+01,1.772804e+02,1.771746e+02,1.410216e+02,1.122221e+02, & - &8.981721e+01,8.965156e+01,1.757892e+02,1.756843e+02,1.380257e+02, & - &1.075065e+02,8.371889e+01,8.286566e+01,1.739252e+02,1.738220e+02, & - &1.350803e+02,1.032180e+02,7.822343e+01,7.700945e+01,1.716897e+02, & - &1.715863e+02,1.321406e+02,9.923855e+01,7.326793e+01,7.254325e+01, & - &1.786007e+02,1.784921e+02,1.446180e+02,1.181232e+02,9.760169e+01, & - &9.837508e+01,1.774724e+02,1.773647e+02,1.414246e+02,1.128623e+02, & - &9.064236e+01,9.044524e+01,1.760207e+02,1.759165e+02,1.384227e+02, & - &1.080898e+02,8.444848e+01,8.341249e+01,1.741956e+02,1.740924e+02, & - &1.354635e+02,1.037430e+02,7.888171e+01,7.713571e+01,1.720081e+02, & - &1.719043e+02,1.325276e+02,9.973367e+01,7.386773e+01,7.180570e+01/ - -! the array selfref contains the coefficient of the water vapor -! self-continuum (including the energy term). the first index -! refers to temperature in 7.2 degree increments. for instance, -! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, -! etc. the second index runs over the g-channel (1 to NG04=14). - - data selfref(:, 1) / & - &2.626280e-01,2.290080e-01,1.996920e-01,1.741290e-01,1.518380e-01, & - &1.324000e-01,1.154510e-01,1.006720e-01,8.778450e-02,7.654690e-02/ - data selfref(:, 2) / & - &2.450510e-01,2.129610e-01,1.850730e-01,1.608370e-01,1.397750e-01, & - &1.214710e-01,1.055640e-01,9.173970e-02,7.972600e-02,6.928560e-02/ - data selfref(:, 3) / & - &2.421940e-01,2.099760e-01,1.820440e-01,1.578270e-01,1.368320e-01, & - &1.186300e-01,1.028490e-01,8.916730e-02,7.730570e-02,6.702210e-02/ - data selfref(:, 4) / & - &2.444850e-01,2.119260e-01,1.837020e-01,1.592370e-01,1.380300e-01, & - &1.196480e-01,1.037140e-01,8.990140e-02,7.792860e-02,6.755030e-02/ - data selfref(:, 5) / & - &2.431200e-01,2.107430e-01,1.826790e-01,1.583510e-01,1.372630e-01, & - &1.189840e-01,1.031390e-01,8.940380e-02,7.749780e-02,6.717740e-02/ - data selfref(:, 6) / & - &2.405580e-01,2.089220e-01,1.814460e-01,1.575830e-01,1.368590e-01, & - &1.188600e-01,1.032290e-01,8.965290e-02,7.786240e-02,6.762250e-02/ - data selfref(:, 7) / & - &2.424960e-01,2.103860e-01,1.825280e-01,1.583590e-01,1.373900e-01, & - &1.191980e-01,1.034150e-01,8.972110e-02,7.784090e-02,6.753370e-02/ - data selfref(:, 8) / & - &2.397810e-01,2.082270e-01,1.808250e-01,1.570290e-01,1.363650e-01, & - &1.184190e-01,1.028360e-01,8.930300e-02,7.755100e-02,6.734560e-02/ - data selfref(:, 9) / & - &2.387070e-01,2.070580e-01,1.796050e-01,1.557920e-01,1.351360e-01, & - &1.172190e-01,1.016770e-01,8.819620e-02,7.650260e-02,6.635940e-02/ - data selfref(:,10) / & - &2.299420e-01,2.006680e-01,1.751210e-01,1.528260e-01,1.333700e-01, & - &1.163900e-01,1.015720e-01,8.864100e-02,7.735600e-02,6.750770e-02/ - data selfref(:,11) / & - &2.398700e-01,2.081200e-01,1.805730e-01,1.566710e-01,1.359340e-01, & - &1.179410e-01,1.023300e-01,8.878540e-02,7.703350e-02,6.683710e-02/ - data selfref(:,12) / & - &2.401960e-01,2.084000e-01,1.808120e-01,1.568770e-01,1.361100e-01, & - &1.180920e-01,1.024600e-01,8.889620e-02,7.712840e-02,6.691840e-02/ - data selfref(:,13) / & - &2.404260e-01,2.086030e-01,1.809910e-01,1.570350e-01,1.362490e-01, & - &1.182140e-01,1.025670e-01,8.899090e-02,7.721170e-02,6.699170e-02/ - data selfref(:,14) / & - &2.406039e-01,2.087537e-01,1.811197e-01,1.571434e-01,1.363411e-01, & - &1.182928e-01,1.026332e-01,8.904696e-02,7.725912e-02,6.703176e-02/ - - data fracrefa(:,:) / & - &0.1557909995,0.1491809934,0.1411380023,0.1312700063,0.1179630011, & - &0.1017429978,0.0828237012,0.0623814985,0.0421344005,0.0045896801, & - &0.0037794900,0.0029873601,0.0022074301,0.0020112700,0.1529279947, & - &0.1500400007,0.1421149969,0.1317670047,0.1182110012,0.1018629968, & - &0.0828804001,0.0624139011,0.0422072001,0.0045900601,0.0037791899, & - &0.0029874300,0.0022074301,0.0020112700,0.1438619941,0.1512529999, & - &0.1465000063,0.1337700039,0.1189590022,0.1022939980,0.0831210986, & - &0.0623952001,0.0422555991,0.0045942799,0.0037886500,0.0029885999, & - &0.0022074301,0.0020112700,0.1435910016,0.1456159949,0.1447930038, & - &0.1374019980,0.1215009987,0.1031540036,0.0835547969,0.0624723993, & - &0.0423097983,0.0045991600,0.0037837301,0.0030006301,0.0022111100, & - &0.0020112700,0.1433759928,0.1445160061,0.1423799992,0.1352050006, & - &0.1235420033,0.1058119982,0.0845180973,0.0626244023,0.0423959009, & - &0.0046029701,0.0037870100,0.0030046599,0.0022189899,0.0020150300, & - &0.1432200074,0.1439740062,0.1411720067,0.1340190023,0.1225550026, & - &0.1077409983,0.0861764997,0.0629642010,0.0424958989,0.0046340600, & - &0.0037824099,0.0030203699,0.0022158299,0.0020290799,0.1430950016, & - &0.1436430067,0.1404390037,0.1334809959,0.1221159995,0.1068470031, & - &0.0882058963,0.0637461022,0.0426472984,0.0046423101,0.0038402199, & - &0.0030342699,0.0022182500,0.0020449802,0.1557909995,0.1491809934, & - &0.1411380023,0.1312700063,0.1179630011,0.1017429978,0.0828237012, & - &0.0623814985,0.0421344005,0.0045896801,0.0037794900,0.0029873601, & - &0.0022074301,0.0020112700,0.1593700051,0.1515949965,0.1424279958, & - &0.1307889968,0.1167130023,0.1003570035,0.0814345032,0.0609384999, & - &0.0410531983,0.0044623301,0.0036984400,0.0029378401,0.0021642500, & - &0.0020596499 / - data fracrefb(:,:) / & - &0.1555829942,0.1493059993,0.1410430074,0.1312409937,0.1179289967, & - &0.1015919968,0.0831412971,0.0624044985,0.0421702005,0.0045931302, & - &0.0037979800,0.0029983500,0.0021895000,0.0020108202,0.1559270024, & - &0.1491899937,0.1409569979,0.1311569959,0.1178890020,0.1015800014, & - &0.0831378028,0.0624024011,0.0421699993,0.0045931302,0.0037979800, & - &0.0029983500,0.0021895000,0.0020108202,0.1594900042,0.1501490027, & - &0.1416220069,0.1308079958,0.1171350032,0.1005709991,0.0817008018, & - &0.0612810999,0.0416559987,0.0045920201,0.0037983500,0.0029971700, & - &0.0021895799,0.0020108300,0.1596789956,0.1503819972,0.1419699937, & - &0.1307480037,0.1170170009,0.1005299985,0.0816079006,0.0612269007, & - &0.0412831008,0.0045659798,0.0037948601,0.0029945699,0.0021901601, & - &0.0020108600,0.1598979980,0.1505730003,0.1420769989,0.1306860000, & - &0.1168290004,0.1005389988,0.0816361010,0.0612187013,0.0412168987, & - &0.0044906102,0.0037123500,0.0029420699,0.0021777800,0.0020034299, & - &0.1595010012,0.1511249989,0.1419910043,0.1307130009,0.1168079972, & - &0.1005460024,0.0817904994,0.0612091012,0.0412604995,0.0044432399, & - &0.0036684300,0.0028936900,0.0021154999,0.0019348300 / - -!........................................! - end module module_radlw_kgb04 ! -!========================================! - - - -!========================================! - module module_radlw_kgb05 ! -!........................................! -! - use machine, only : kind_phys - use module_radlw_parameters, only : NG05 -! - implicit none -! - private -! - integer, public :: MSA05, MSB05, MSF05, MAF05, MBF05 - parameter (MSA05=585, MSB05=1175, MSF05=10, MAF05=9, MBF05=5) - - real (kind=kind_phys), public :: & - & absa(MSA05,NG05), absb(MSB05,NG05), selfref(MSF05,NG05), & - & ccl4(NG05), fracrefa(NG05,MAF05), fracrefb(NG05,MBF05) - -! the array absa(585,NG05) = ka(9,5,13,NG05) contains absorption coefs -! at the NG05=16 g-intervals for a range of pressure levels > ~100mb, -! temperatures, and ratios of water vapor to co2. the first index in -! the array, js, runs from 1 to 9 and corresponds to different water -! vapor to co2 ratios, as expressed through the binary species parameter -! eta, defined as eta = h2o/(h20+rat*co2), where rat is the ratio of -! the integrated line strength in the band of co2 to that of h2o. for -! instance, js=1 refers to dry air (eta = 0), js = 9 corresponds to -! eta = 1.0. the 2nd index in the array, jt, which runs from 1 to 5, -! corresponds to different temperatures. more specifically, jt = 1-5 -! means that the data are for the corresponding temperature of -! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the -! third index, jp, runs from 1 to 13 and refers to the reference -! pressure level (e.g. jp = 1 is for a pressure of 1053.63 mb). the -! fourth index, ig, goes from 1 to NG05=16, and tells us which -! g-interval the absorption coefficients are for. - - data absa(1:270,1) / & - &1.228100e-06,7.344400e-06,1.380200e-05,2.136300e-05,3.402600e-05, & - &5.114900e-05,7.645400e-05,1.149200e-04,5.105100e-05,1.636900e-06, & - &8.961700e-06,1.607200e-05,2.413500e-05,3.410600e-05,4.921400e-05, & - &7.904800e-05,1.390500e-04,5.406300e-05,2.161100e-06,1.109400e-05, & - &1.872600e-05,2.782500e-05,3.828100e-05,5.159200e-05,7.681300e-05, & - &1.361600e-04,6.099400e-05,2.803200e-06,1.391100e-05,2.187300e-05, & - &3.187200e-05,4.366900e-05,5.865000e-05,8.110700e-05,1.324700e-04, & - &6.841300e-05,3.574900e-06,1.739900e-05,2.627000e-05,3.536300e-05, & - &4.847000e-05,6.547900e-05,9.073500e-05,1.409900e-04,5.773100e-05, & - &9.220800e-07,5.666100e-06,1.085300e-05,1.769500e-05,2.811100e-05, & - &4.181100e-05,5.776600e-05,8.817100e-05,3.649900e-05,1.233900e-06, & - &6.871800e-06,1.245000e-05,1.903800e-05,2.742800e-05,4.221400e-05, & - &6.589100e-05,1.080800e-04,3.932800e-05,1.638200e-06,8.473300e-06, & - &1.447000e-05,2.156700e-05,3.017200e-05,4.184200e-05,6.276100e-05, & - &1.135900e-04,4.492600e-05,2.143700e-06,1.058200e-05,1.709000e-05, & - &2.496100e-05,3.431900e-05,4.633400e-05,6.494200e-05,1.088000e-04, & - &4.870600e-05,2.755000e-06,1.330700e-05,2.030300e-05,2.776800e-05, & - &3.864900e-05,5.306900e-05,7.165600e-05,1.117400e-04,4.226400e-05, & - &6.568100e-07,4.292800e-06,8.620600e-06,1.481300e-05,2.279500e-05, & - &3.095600e-05,4.215900e-05,6.714300e-05,2.455800e-05,8.803200e-07, & - &5.085800e-06,9.497900e-06,1.490800e-05,2.330200e-05,3.476100e-05, & - &5.281000e-05,7.808300e-05,2.735200e-05,1.175700e-06,6.247900e-06, & - &1.100700e-05,1.661300e-05,2.354300e-05,3.387900e-05,5.306400e-05, & - &9.390500e-05,3.143300e-05,1.554100e-06,7.754900e-06,1.298700e-05, & - &1.917800e-05,2.619700e-05,3.575000e-05,5.191500e-05,9.222900e-05, & - &2.942300e-05,2.019300e-06,9.763900e-06,1.516700e-05,2.203100e-05, & - &3.001000e-05,4.025800e-05,5.526700e-05,9.011200e-05,2.994300e-05, & - &4.641900e-07,3.223800e-06,7.096800e-06,1.217200e-05,1.673200e-05, & - &2.236900e-05,3.146300e-05,5.322900e-05,1.738100e-05,6.224500e-07, & - &3.772600e-06,7.276600e-06,1.250400e-05,1.925500e-05,2.807900e-05, & - &3.748500e-05,5.740300e-05,1.966700e-05,8.335100e-07,4.565300e-06, & - &8.303600e-06,1.277700e-05,1.881600e-05,2.903000e-05,4.441700e-05, & - &7.086300e-05,2.189500e-05,1.108700e-06,5.638400e-06,9.640500e-06, & - &1.456500e-05,2.032100e-05,2.826400e-05,4.344400e-05,7.744400e-05, & - &2.141400e-05,1.458100e-06,7.072600e-06,1.140200e-05,1.657900e-05, & - &2.301100e-05,3.100900e-05,4.324500e-05,7.370800e-05,2.286300e-05, & - &3.342700e-07,2.533700e-06,5.768000e-06,8.942500e-06,1.224200e-05, & - &1.699500e-05,2.416400e-05,4.423000e-05,1.342200e-05,4.460100e-07, & - &2.840100e-06,5.853100e-06,1.022000e-05,1.541900e-05,2.015300e-05, & - &2.733600e-05,4.372700e-05,1.511500e-05,5.981200e-07,3.353200e-06, & - &6.319100e-06,1.003100e-05,1.595300e-05,2.395000e-05,3.419500e-05, & - &5.060100e-05,1.659100e-05,7.983700e-07,4.128000e-06,7.314700e-06, & - &1.107900e-05,1.585400e-05,2.381000e-05,3.651400e-05,6.259100e-05, & - &1.765800e-05,1.057500e-06,5.144000e-06,8.591000e-06,1.270900e-05, & - &1.759200e-05,2.426200e-05,3.527600e-05,6.236800e-05,1.938800e-05, & - &2.446700e-07,2.011500e-06,4.450600e-06,6.532800e-06,9.213400e-06, & - &1.286700e-05,1.926600e-05,3.422600e-05,1.102000e-05,3.224400e-07, & - &2.180200e-06,4.785900e-06,8.303100e-06,1.102400e-05,1.481600e-05, & - &2.076700e-05,3.386700e-05,1.236100e-05,4.325200e-07,2.503400e-06, & - &4.878800e-06,8.518800e-06,1.335300e-05,1.835300e-05,2.444000e-05, & - &3.722000e-05,1.375600e-05,5.786600e-07,3.022700e-06,5.490100e-06, & - &8.544100e-06,1.329400e-05,1.997000e-05,3.007900e-05,4.548700e-05, & - &1.537000e-05,7.696000e-07,3.750400e-06,6.376700e-06,9.631100e-06, & - &1.356300e-05,1.946400e-05,3.002300e-05,5.303100e-05,1.734900e-05/ - data absa(271:585,1) / & - &1.836300e-07,1.633900e-06,3.236500e-06,4.873600e-06,7.056500e-06, & - &1.016800e-05,1.544800e-05,2.611900e-05,9.997300e-06,2.382800e-07, & - &1.704500e-06,3.944600e-06,5.988500e-06,8.118700e-06,1.116400e-05, & - &1.591000e-05,2.780400e-05,1.125200e-05,3.171200e-07,1.891500e-06, & - &4.013300e-06,6.937100e-06,1.018400e-05,1.324700e-05,1.814400e-05, & - &2.868700e-05,1.276700e-05,4.254900e-07,2.241500e-06,4.200100e-06, & - &7.006600e-06,1.095000e-05,1.632300e-05,2.221800e-05,3.298700e-05, & - &1.459100e-05,5.678200e-07,2.760800e-06,4.854100e-06,7.370500e-06, & - &1.074800e-05,1.639000e-05,2.503500e-05,4.158300e-05,1.675900e-05, & - &1.429700e-07,1.298600e-06,2.429600e-06,3.774000e-06,5.571700e-06, & - &8.100700e-06,1.226900e-05,2.066800e-05,1.122400e-05,1.823700e-07, & - &1.379600e-06,2.984100e-06,4.423200e-06,6.162500e-06,8.607000e-06, & - &1.274900e-05,2.237400e-05,1.305000e-05,2.399500e-07,1.482800e-06, & - &3.230200e-06,5.572100e-06,7.400900e-06,9.958400e-06,1.379300e-05, & - &2.272000e-05,1.503700e-05,3.210900e-07,1.708600e-06,3.305200e-06, & - &5.755200e-06,9.116300e-06,1.213700e-05,1.620000e-05,2.493200e-05, & - &1.731600e-05,4.293300e-07,2.066500e-06,3.685100e-06,5.709300e-06, & - &9.123100e-06,1.361600e-05,2.024000e-05,2.979500e-05,1.981100e-05, & - &1.139100e-07,9.660700e-07,1.859600e-06,2.996000e-06,4.427800e-06, & - &6.449600e-06,9.366800e-06,1.629600e-05,2.317500e-05,1.431800e-07, & - &1.143200e-06,2.191700e-06,3.346500e-06,4.789400e-06,6.858300e-06, & - &1.012400e-05,1.773200e-05,2.842400e-05,1.859400e-07,1.188500e-06, & - &2.696200e-06,4.034300e-06,5.535100e-06,7.551400e-06,1.067500e-05, & - &1.815000e-05,3.405300e-05,2.467000e-07,1.338000e-06,2.750300e-06, & - &4.754900e-06,6.887600e-06,8.908700e-06,1.229500e-05,1.921000e-05, & - &3.983900e-05,3.301000e-07,1.578400e-06,2.851300e-06,4.804900e-06, & - &7.482700e-06,1.109600e-05,1.474900e-05,2.195500e-05,4.559400e-05, & - &9.553000e-08,7.610300e-07,1.482200e-06,2.401300e-06,3.524100e-06, & - &5.086300e-06,7.704100e-06,1.242300e-05,8.906700e-05,1.188200e-07, & - &9.245000e-07,1.697900e-06,2.620700e-06,3.850300e-06,5.465700e-06, & - &7.968400e-06,1.365100e-05,1.112500e-04,1.528900e-07,9.794200e-07, & - &2.084600e-06,3.052400e-06,4.264000e-06,5.921600e-06,8.666600e-06, & - &1.441100e-05,1.337600e-04,2.009400e-07,1.081600e-06,2.233100e-06, & - &3.885500e-06,5.123900e-06,6.814400e-06,9.510200e-06,1.539600e-05, & - &1.562100e-04,2.671100e-07,1.257200e-06,2.328300e-06,3.950200e-06, & - &6.170300e-06,8.447100e-06,1.104700e-05,1.705700e-05,1.781500e-04, & - &8.847900e-08,6.572300e-07,1.258500e-06,2.003900e-06,2.912100e-06, & - &4.195500e-06,6.263700e-06,1.041900e-05,1.721900e-04,1.110300e-07, & - &7.972400e-07,1.438800e-06,2.193800e-06,3.209900e-06,4.538000e-06, & - &6.533400e-06,1.152900e-05,2.139300e-04,1.432500e-07,8.500900e-07, & - &1.779000e-06,2.576200e-06,3.585300e-06,4.902700e-06,7.208700e-06, & - &1.178300e-05,2.554800e-04,1.879600e-07,9.491000e-07,1.879400e-06, & - &3.244800e-06,4.309600e-06,5.700400e-06,7.814600e-06,1.275900e-05, & - &2.957000e-04,2.483000e-07,1.099700e-06,1.998700e-06,3.278800e-06, & - &5.098300e-06,7.094800e-06,9.218500e-06,1.415700e-05,3.341700e-04, & - &7.841100e-08,5.643200e-07,1.056400e-06,1.679200e-06,2.426200e-06, & - &3.387500e-06,5.182400e-06,8.593000e-06,2.197000e-04,9.895800e-08, & - &6.832800e-07,1.221500e-06,1.835000e-06,2.671600e-06,3.778700e-06, & - &5.384900e-06,9.186000e-06,2.720900e-04,1.279700e-07,7.242100e-07, & - &1.520900e-06,2.171100e-06,3.004000e-06,4.082900e-06,6.022900e-06, & - &9.706800e-06,3.238000e-04,1.677200e-07,8.150000e-07,1.584300e-06, & - &2.721200e-06,3.614100e-06,4.759500e-06,6.484000e-06,1.062900e-05, & - &3.733200e-04,2.208100e-07,9.488700e-07,1.706100e-06,2.733800e-06, & - &4.240900e-06,5.962800e-06,7.712300e-06,1.166800e-05,4.200600e-04, & - &6.998400e-08,4.874600e-07,8.993400e-07,1.410100e-06,2.018800e-06, & - &2.799100e-06,4.152100e-06,7.272700e-06,2.286500e-04,8.882100e-08, & - &5.867200e-07,1.042100e-06,1.551700e-06,2.234000e-06,3.134600e-06, & - &4.472700e-06,7.460400e-06,2.826700e-04,1.150400e-07,6.213700e-07, & - &1.301500e-06,1.835000e-06,2.530500e-06,3.407600e-06,4.942600e-06, & - &8.026500e-06,3.357600e-04,1.503600e-07,7.008400e-07,1.348300e-06, & - &2.287500e-06,3.033700e-06,3.983900e-06,5.421000e-06,8.775500e-06, & - &3.863700e-04,1.971200e-07,8.152500e-07,1.445100e-06,2.305100e-06, & - &3.503200e-06,5.002900e-06,6.440700e-06,9.656400e-06,4.338500e-04/ - data absa(1:270,2) / & - &3.701000e-06,1.809100e-05,2.871100e-05,4.886300e-05,7.230700e-05, & - &1.141300e-04,1.877100e-04,3.612200e-04,1.128100e-04,5.326600e-06, & - &2.442300e-05,3.426900e-05,4.770400e-05,7.607800e-05,1.144200e-04, & - &1.643600e-04,3.283800e-04,8.784700e-05,7.517700e-06,3.285400e-05, & - &4.428900e-05,5.491300e-05,7.277900e-05,1.081400e-04,1.790600e-04, & - &2.846700e-04,8.688300e-05,1.039100e-05,4.352200e-05,5.854400e-05, & - &6.969300e-05,8.128800e-05,1.022000e-04,1.504700e-04,3.028500e-04, & - &9.104900e-05,1.402400e-05,5.675800e-05,7.601600e-05,9.166200e-05, & - &1.037200e-04,1.170000e-04,1.499100e-04,2.370400e-04,1.300000e-04, & - &2.790300e-06,1.390200e-05,2.377100e-05,3.919000e-05,6.113700e-05, & - &9.723100e-05,1.525000e-04,2.874600e-04,7.594300e-05,4.056100e-06, & - &1.872000e-05,2.722500e-05,3.974100e-05,6.453700e-05,9.089900e-05, & - &1.460900e-04,2.700800e-04,6.261200e-05,5.788700e-06,2.535300e-05, & - &3.444600e-05,4.375000e-05,5.835200e-05,9.766800e-05,1.421000e-04, & - &2.421100e-04,6.126900e-05,8.078400e-06,3.395000e-05,4.532500e-05, & - &5.392100e-05,6.428000e-05,8.566500e-05,1.368800e-04,2.455600e-04, & - &6.956800e-05,1.101900e-05,4.467200e-05,5.957500e-05,7.116600e-05, & - &7.959500e-05,9.108800e-05,1.252000e-04,2.180200e-04,9.555700e-05, & - &1.947900e-06,1.009500e-05,1.914100e-05,3.070500e-05,5.236300e-05, & - &7.999100e-05,1.282300e-04,2.380600e-04,4.699200e-05,2.850900e-06, & - &1.341300e-05,2.113700e-05,3.410100e-05,4.970600e-05,7.870800e-05, & - &1.280800e-04,2.276900e-04,4.201200e-05,4.118900e-06,1.826500e-05, & - &2.541900e-05,3.468300e-05,5.251300e-05,8.024000e-05,1.148100e-04, & - &2.181600e-04,4.317400e-05,5.823300e-06,2.480100e-05,3.320000e-05, & - &4.018000e-05,5.178600e-05,7.246800e-05,1.254900e-04,1.985600e-04, & - &5.628200e-05,8.061200e-06,3.309400e-05,4.419100e-05,5.180100e-05, & - &5.930000e-05,7.207500e-05,1.038600e-04,2.085900e-04,6.803900e-05, & - &1.343200e-06,7.453800e-06,1.496400e-05,2.562500e-05,4.324300e-05, & - &6.601900e-05,1.053000e-04,1.995200e-04,3.157500e-05,1.959100e-06, & - &9.515500e-06,1.673700e-05,2.679100e-05,4.234500e-05,6.743900e-05, & - &1.027100e-04,1.887100e-04,3.070400e-05,2.853700e-06,1.284500e-05, & - &1.893400e-05,2.875200e-05,4.419900e-05,6.243000e-05,1.020200e-04, & - &1.806200e-04,3.408800e-05,4.088800e-06,1.761200e-05,2.392200e-05, & - &3.074900e-05,4.201000e-05,6.572800e-05,9.656600e-05,1.746000e-04, & - &4.338700e-05,5.738800e-06,2.382900e-05,3.175800e-05,3.778900e-05, & - &4.531200e-05,5.909500e-05,1.006400e-04,1.685000e-04,5.107900e-05, & - &9.488200e-07,5.715500e-06,1.198000e-05,2.229500e-05,3.511600e-05, & - &5.333900e-05,8.872900e-05,1.593700e-04,2.545600e-05,1.366900e-06, & - &6.873900e-06,1.345900e-05,2.139600e-05,3.629700e-05,5.428200e-05, & - &8.604200e-05,1.602500e-04,2.665400e-05,1.988400e-06,9.085900e-06, & - &1.460500e-05,2.367100e-05,3.409300e-05,5.532400e-05,8.646300e-05, & - &1.536300e-04,3.068400e-05,2.870100e-06,1.243000e-05,1.729400e-05, & - &2.458000e-05,3.720300e-05,5.315400e-05,8.196300e-05,1.528100e-04, & - &3.632100e-05,4.070900e-06,1.702900e-05,2.274300e-05,2.790200e-05, & - &3.635300e-05,5.311500e-05,8.486400e-05,1.373200e-04,4.254700e-05, & - &6.898800e-07,4.465200e-06,9.758000e-06,1.767800e-05,2.833200e-05, & - &4.414500e-05,7.010900e-05,1.249300e-04,2.371600e-05,9.731400e-07, & - &5.097400e-06,1.041200e-05,1.748500e-05,2.937600e-05,4.480400e-05, & - &7.012200e-05,1.327600e-04,2.637500e-05,1.397200e-06,6.472400e-06, & - &1.156400e-05,1.885800e-05,2.856800e-05,4.704300e-05,7.020200e-05, & - &1.274800e-04,3.016900e-05,2.015600e-06,8.706300e-06,1.302500e-05, & - &2.035500e-05,3.006900e-05,4.424000e-05,7.133600e-05,1.232400e-04, & - &3.499400e-05,2.875600e-06,1.197600e-05,1.624200e-05,2.114700e-05, & - &3.062900e-05,4.552600e-05,6.547400e-05,1.213000e-04,4.049500e-05/ - data absa(271:585,2) / & - &5.225500e-07,3.441100e-06,7.778900e-06,1.439500e-05,2.296500e-05, & - &3.566200e-05,5.565200e-05,9.907800e-05,2.567700e-05,7.217200e-07, & - &4.017900e-06,8.337600e-06,1.485300e-05,2.433100e-05,3.636400e-05, & - &5.779100e-05,1.056300e-04,2.955600e-05,1.020100e-06,4.721700e-06, & - &9.309500e-06,1.508300e-05,2.536500e-05,3.734700e-05,5.819000e-05, & - &1.060300e-04,3.399800e-05,1.453700e-06,6.174800e-06,1.002000e-05, & - &1.613800e-05,2.396200e-05,3.796700e-05,5.845100e-05,1.037200e-04, & - &3.911900e-05,2.069300e-06,8.436300e-06,1.170500e-05,1.700100e-05, & - &2.582600e-05,3.552700e-05,5.829600e-05,1.038500e-04,4.493600e-05, & - &4.170000e-07,2.763900e-06,6.493800e-06,1.163000e-05,1.837100e-05, & - &2.770600e-05,4.485000e-05,8.069600e-05,3.595600e-05,5.641100e-07, & - &3.155600e-06,6.945700e-06,1.212000e-05,1.939700e-05,2.958100e-05, & - &4.651300e-05,8.472700e-05,4.251100e-05,7.864700e-07,3.653500e-06, & - &7.325500e-06,1.235300e-05,2.007900e-05,3.084400e-05,4.740100e-05, & - &8.652500e-05,4.972400e-05,1.106100e-06,4.542400e-06,7.991700e-06, & - &1.318500e-05,1.979100e-05,3.203800e-05,4.805400e-05,8.545700e-05, & - &5.723300e-05,1.556900e-06,6.059900e-06,9.020900e-06,1.399000e-05, & - &2.081500e-05,3.047500e-05,4.989900e-05,8.465900e-05,6.535600e-05, & - &3.464600e-07,2.333900e-06,5.237600e-06,9.218200e-06,1.433700e-05, & - &2.249000e-05,3.639600e-05,6.141200e-05,1.049000e-04,4.591900e-07, & - &2.458500e-06,5.567600e-06,9.853300e-06,1.555900e-05,2.368300e-05, & - &3.699900e-05,7.067700e-05,1.240500e-04,6.289800e-07,2.926200e-06, & - &5.802200e-06,1.034400e-05,1.684000e-05,2.469100e-05,3.881800e-05, & - &7.003100e-05,1.429000e-04,8.762500e-07,3.447400e-06,6.490400e-06, & - &1.058900e-05,1.737800e-05,2.584900e-05,3.940000e-05,7.071600e-05, & - &1.611200e-04,1.220900e-06,4.492200e-06,7.095800e-06,1.129800e-05, & - &1.693600e-05,2.602000e-05,4.032500e-05,7.208300e-05,1.789300e-04, & - &3.121400e-07,1.953600e-06,4.257600e-06,7.339600e-06,1.162100e-05, & - &1.802100e-05,2.801300e-05,4.774900e-05,4.996200e-04,4.088700e-07, & - &2.059800e-06,4.714900e-06,8.060600e-06,1.257300e-05,1.880900e-05, & - &3.027500e-05,5.618800e-05,5.854800e-04,5.515500e-07,2.417500e-06, & - &4.954500e-06,8.594100e-06,1.345700e-05,2.020400e-05,3.113800e-05, & - &5.628600e-05,6.629100e-04,7.565000e-07,2.829800e-06,5.325600e-06, & - &8.740200e-06,1.397800e-05,2.160100e-05,3.208200e-05,5.769300e-05, & - &7.297200e-04,1.042700e-06,3.540000e-06,5.850100e-06,9.413700e-06, & - &1.405500e-05,2.209200e-05,3.337100e-05,5.768000e-05,7.861100e-04, & - &3.207400e-07,1.727600e-06,3.623900e-06,6.185400e-06,9.660700e-06, & - &1.499300e-05,2.344300e-05,4.106100e-05,1.014200e-03,4.211300e-07, & - &1.811600e-06,4.119900e-06,6.771600e-06,1.054300e-05,1.552600e-05, & - &2.484900e-05,4.545400e-05,1.174200e-03,5.651400e-07,2.155200e-06, & - &4.214800e-06,7.358500e-06,1.123900e-05,1.684600e-05,2.565500e-05, & - &4.553100e-05,1.313900e-03,7.681400e-07,2.532200e-06,4.685200e-06, & - &7.353800e-06,1.183000e-05,1.815500e-05,2.682400e-05,4.713900e-05, & - &1.430500e-03,1.046400e-06,3.231300e-06,5.088900e-06,8.126000e-06, & - &1.174100e-05,1.856700e-05,2.767300e-05,4.768400e-05,1.526100e-03, & - &3.048300e-07,1.498600e-06,3.103600e-06,5.255100e-06,7.988300e-06, & - &1.241100e-05,1.920800e-05,3.389400e-05,1.324300e-03,4.002600e-07, & - &1.574600e-06,3.503400e-06,5.740900e-06,8.924800e-06,1.292800e-05, & - &2.001400e-05,3.740600e-05,1.520200e-03,5.355300e-07,1.887900e-06, & - &3.559800e-06,6.220400e-06,9.450600e-06,1.413100e-05,2.119300e-05, & - &3.729000e-05,1.689200e-03,7.244100e-07,2.226100e-06,4.061100e-06, & - &6.200800e-06,9.986500e-06,1.494100e-05,2.242300e-05,3.876600e-05, & - &1.830100e-03,9.823300e-07,2.878200e-06,4.358500e-06,6.970700e-06, & - &9.799000e-06,1.546300e-05,2.294900e-05,3.965800e-05,1.944100e-03, & - &2.900300e-07,1.300300e-06,2.685100e-06,4.490100e-06,6.684700e-06, & - &1.033600e-05,1.608400e-05,2.820600e-05,1.397100e-03,3.799000e-07, & - &1.388700e-06,2.988800e-06,4.889500e-06,7.488700e-06,1.084800e-05, & - &1.649700e-05,3.092700e-05,1.595100e-03,5.057200e-07,1.653300e-06, & - &3.016600e-06,5.282500e-06,8.008400e-06,1.187700e-05,1.776600e-05, & - &3.047400e-05,1.765300e-03,6.794700e-07,1.970000e-06,3.441000e-06, & - &5.232500e-06,8.439500e-06,1.246000e-05,1.862500e-05,3.215800e-05, & - &1.906700e-03,9.157600e-07,2.577700e-06,3.745900e-06,5.902600e-06, & - &8.296200e-06,1.277200e-05,1.897200e-05,3.294800e-05,2.020200e-03/ - data absa(1:270,3) / & - &1.295500e-05,5.052200e-05,7.194500e-05,8.615400e-05,1.020800e-04, & - &1.259800e-04,1.912300e-04,3.641800e-04,1.318600e-04,1.928700e-05, & - &7.001000e-05,9.959300e-05,1.228600e-04,1.352500e-04,1.554800e-04, & - &2.091800e-04,3.473900e-04,1.732200e-04,2.775900e-05,9.451000e-05, & - &1.325900e-04,1.636600e-04,1.887900e-04,2.094300e-04,2.315700e-04, & - &3.481100e-04,1.615000e-04,3.873800e-05,1.242200e-04,1.722100e-04, & - &2.099200e-04,2.427200e-04,2.745300e-04,3.148800e-04,3.818000e-04, & - &1.624700e-04,5.255100e-05,1.594800e-04,2.180000e-04,2.609100e-04, & - &2.898500e-04,3.167000e-04,3.573000e-04,5.027500e-04,1.676900e-04, & - &1.021500e-05,3.838000e-05,5.304800e-05,6.638100e-05,7.944600e-05, & - &1.024200e-04,1.677100e-04,3.279400e-04,9.631600e-05,1.545100e-05, & - &5.410400e-05,7.560000e-05,9.332400e-05,1.028900e-04,1.233900e-04, & - &1.550800e-04,2.956100e-04,1.195000e-04,2.259700e-05,7.396300e-05, & - &1.025300e-04,1.254900e-04,1.469500e-04,1.550100e-04,1.876600e-04, & - &2.758000e-04,1.196300e-04,3.198100e-05,9.826600e-05,1.345500e-04, & - &1.636300e-04,1.905700e-04,2.140500e-04,2.400900e-04,3.087100e-04, & - &1.194400e-04,4.394900e-05,1.272400e-04,1.721000e-04,2.057600e-04, & - &2.296700e-04,2.564100e-04,2.938700e-04,3.854500e-04,1.283400e-04, & - &7.236500e-06,2.699800e-05,3.647700e-05,4.721700e-05,5.664200e-05, & - &8.793600e-05,1.452900e-04,2.776900e-04,6.962800e-05,1.119900e-05, & - &3.904100e-05,5.356400e-05,6.427200e-05,7.677400e-05,9.085500e-05, & - &1.238200e-04,2.626000e-04,7.753900e-05,1.674600e-05,5.445900e-05, & - &7.453700e-05,8.991700e-05,1.035500e-04,1.157200e-04,1.464900e-04, & - &2.217900e-04,7.998800e-05,2.419100e-05,7.348000e-05,9.961500e-05, & - &1.214000e-04,1.395900e-04,1.571400e-04,1.654900e-04,2.402400e-04, & - &8.566600e-05,3.387000e-05,9.661500e-05,1.293900e-04,1.548300e-04, & - &1.760500e-04,2.003300e-04,2.274700e-04,2.710000e-04,9.729500e-05, & - &4.916400e-06,1.837000e-05,2.472100e-05,3.312100e-05,4.762000e-05, & - &7.526600e-05,1.205200e-04,2.153400e-04,5.253400e-05,7.765900e-06, & - &2.732600e-05,3.636500e-05,4.533100e-05,5.437700e-05,7.004800e-05, & - &1.160600e-04,2.235600e-04,5.660600e-05,1.187200e-05,3.909100e-05, & - &5.275300e-05,6.281000e-05,7.233400e-05,8.551000e-05,1.065500e-04, & - &2.013200e-04,6.101300e-05,1.753700e-05,5.379400e-05,7.222500e-05, & - &8.656600e-05,1.000900e-04,1.090500e-04,1.292700e-04,1.797900e-04, & - &6.724700e-05,2.507700e-05,7.194900e-05,9.558600e-05,1.142200e-04, & - &1.304600e-04,1.487400e-04,1.615100e-04,2.100400e-04,7.807000e-05, & - &3.327400e-06,1.241300e-05,1.689300e-05,2.529700e-05,3.970200e-05, & - &6.247100e-05,9.479900e-05,1.737900e-04,4.335200e-05,5.314400e-06, & - &1.892400e-05,2.459500e-05,3.137800e-05,3.938200e-05,6.222600e-05, & - &9.605100e-05,1.814100e-04,4.907100e-05,8.272900e-06,2.773500e-05, & - &3.685300e-05,4.347300e-05,5.307700e-05,6.011100e-05,8.820500e-05, & - &1.717000e-04,5.358100e-05,1.248300e-05,3.893600e-05,5.194400e-05, & - &6.077100e-05,7.041600e-05,8.140600e-05,9.791200e-05,1.462400e-04, & - &6.050200e-05,1.823400e-05,5.299700e-05,7.021400e-05,8.388900e-05, & - &9.458300e-05,1.064600e-04,1.164500e-04,1.666400e-04,6.952400e-05, & - &2.262700e-06,8.225600e-06,1.266200e-05,2.088100e-05,3.228700e-05, & - &4.984200e-05,7.851400e-05,1.514300e-04,4.218500e-05,3.590200e-06, & - &1.271500e-05,1.677700e-05,2.288300e-05,3.389000e-05,5.080700e-05, & - &8.075300e-05,1.446300e-04,4.859000e-05,5.643600e-06,1.910900e-05, & - &2.499800e-05,3.030500e-05,3.783100e-05,4.725500e-05,7.894500e-05, & - &1.440600e-04,5.529600e-05,8.668000e-06,2.746800e-05,3.641600e-05, & - &4.207000e-05,4.905500e-05,5.824500e-05,7.288900e-05,1.375900e-04, & - &6.269900e-05,1.291000e-05,3.807000e-05,5.055200e-05,5.953100e-05, & - &6.599000e-05,7.548500e-05,9.015100e-05,1.251900e-04,7.115800e-05/ - data absa(271:585,3) / & - &1.626000e-06,5.651200e-06,1.053400e-05,1.654800e-05,2.572200e-05, & - &3.921200e-05,6.525500e-05,1.164200e-04,4.839600e-05,2.497700e-06, & - &8.511100e-06,1.155200e-05,1.862000e-05,2.696400e-05,4.108600e-05, & - &6.532600e-05,1.203800e-04,5.675500e-05,3.893700e-06,1.308300e-05, & - &1.683700e-05,2.103700e-05,2.810300e-05,4.197100e-05,6.491600e-05, & - &1.203500e-04,6.564300e-05,6.013100e-06,1.918200e-05,2.526200e-05, & - &2.957800e-05,3.538000e-05,4.182400e-05,6.438900e-05,1.162500e-04, & - &7.511200e-05,9.077500e-06,2.704900e-05,3.591000e-05,4.167300e-05, & - &4.743000e-05,5.667500e-05,6.466200e-05,1.037600e-04,8.547900e-05, & - &1.276200e-06,4.285500e-06,8.282000e-06,1.305100e-05,1.990700e-05, & - &3.397100e-05,5.044600e-05,8.697100e-05,7.774500e-05,1.884400e-06, & - &5.905000e-06,8.948900e-06,1.480600e-05,2.183900e-05,3.260800e-05, & - &5.254000e-05,9.761000e-05,8.949800e-05,2.838500e-06,8.973700e-06, & - &1.189500e-05,1.587000e-05,2.415600e-05,3.390600e-05,5.360500e-05, & - &9.684900e-05,1.028700e-04,4.310600e-06,1.340400e-05,1.749800e-05, & - &2.100900e-05,2.603600e-05,3.475800e-05,5.411500e-05,9.767100e-05, & - &1.177400e-04,6.493300e-06,1.919800e-05,2.510800e-05,2.953200e-05, & - &3.354700e-05,4.087000e-05,5.067200e-05,9.404800e-05,1.332600e-04, & - &1.070600e-06,3.348900e-06,6.528300e-06,1.019200e-05,1.727800e-05, & - &2.623800e-05,3.904100e-05,7.034600e-05,2.710300e-04,1.523800e-06, & - &4.464700e-06,7.489600e-06,1.180500e-05,1.740400e-05,2.624100e-05, & - &4.507600e-05,7.335700e-05,3.047800e-04,2.224500e-06,6.348200e-06, & - &8.781400e-06,1.318200e-05,1.864900e-05,2.813900e-05,4.243200e-05, & - &8.191800e-05,3.394300e-04,3.285300e-06,9.537700e-06,1.208100e-05, & - &1.504800e-05,2.043800e-05,2.925000e-05,4.449200e-05,8.005400e-05, & - &3.756900e-04,4.834000e-06,1.370400e-05,1.772700e-05,2.084600e-05, & - &2.438900e-05,3.016900e-05,4.555800e-05,7.678000e-05,4.136300e-04, & - &1.008700e-06,2.852200e-06,5.384700e-06,8.758900e-06,1.365600e-05, & - &2.079300e-05,3.026500e-05,5.646600e-05,1.446700e-03,1.389300e-06, & - &3.657200e-06,6.038100e-06,9.565600e-06,1.374400e-05,2.237800e-05, & - &3.607300e-05,5.899900e-05,1.613400e-03,1.960100e-06,4.974600e-06, & - &7.167500e-06,1.078200e-05,1.554800e-05,2.242500e-05,3.481300e-05, & - &6.818800e-05,1.774200e-03,2.804600e-06,7.306100e-06,9.276000e-06, & - &1.201600e-05,1.767400e-05,2.352600e-05,3.662600e-05,6.345100e-05, & - &1.925700e-03,4.020400e-06,1.044800e-05,1.316800e-05,1.571100e-05, & - &1.878000e-05,2.529000e-05,3.717900e-05,6.546800e-05,2.065400e-03, & - &1.116700e-06,2.719600e-06,4.841400e-06,7.575000e-06,1.161900e-05, & - &1.684400e-05,2.592000e-05,4.249700e-05,3.064800e-03,1.517700e-06, & - &3.534200e-06,5.433600e-06,8.434600e-06,1.172900e-05,1.836200e-05, & - &2.919400e-05,5.012900e-05,3.397600e-03,2.098400e-06,4.800600e-06, & - &6.545100e-06,9.502900e-06,1.346500e-05,1.902000e-05,2.869200e-05, & - &5.792800e-05,3.705000e-03,2.933500e-06,6.870800e-06,8.410100e-06, & - &1.086300e-05,1.476200e-05,2.009100e-05,3.037100e-05,5.202800e-05, & - &3.980900e-03,4.100000e-06,9.654300e-06,1.185700e-05,1.371400e-05, & - &1.652600e-05,2.142700e-05,3.146400e-05,5.424500e-05,4.214300e-03, & - &1.126500e-06,2.518600e-06,4.367400e-06,6.519200e-06,9.819300e-06, & - &1.419500e-05,2.166900e-05,3.559100e-05,4.135400e-03,1.527300e-06, & - &3.247100e-06,4.845300e-06,7.492900e-06,9.933300e-06,1.522400e-05, & - &2.449000e-05,4.252000e-05,4.563100e-03,2.093100e-06,4.463200e-06, & - &5.899000e-06,8.172300e-06,1.163700e-05,1.598900e-05,2.380300e-05, & - &4.495800e-05,4.940600e-03,2.892700e-06,6.325000e-06,7.618600e-06, & - &9.466900e-06,1.256300e-05,1.744500e-05,2.522200e-05,4.266800e-05, & - &5.260300e-03,3.984800e-06,8.792100e-06,1.060500e-05,1.200400e-05, & - &1.434100e-05,1.804900e-05,2.652100e-05,4.475400e-05,5.516500e-03, & - &1.132800e-06,2.323800e-06,3.943000e-06,5.693200e-06,8.403800e-06, & - &1.180000e-05,1.782900e-05,3.082000e-05,4.481900e-03,1.531100e-06, & - &3.009800e-06,4.352100e-06,6.667900e-06,8.708100e-06,1.289700e-05, & - &1.988300e-05,3.449300e-05,4.916400e-03,2.085300e-06,4.122300e-06, & - &5.411400e-06,7.255400e-06,1.022900e-05,1.364100e-05,1.972900e-05, & - &3.643800e-05,5.285200e-03,2.850600e-06,5.856800e-06,6.993800e-06, & - &8.484000e-06,1.094200e-05,1.506600e-05,2.127000e-05,3.531300e-05, & - &5.587100e-03,3.871100e-06,8.071200e-06,9.615900e-06,1.071900e-05, & - &1.256100e-05,1.529300e-05,2.268100e-05,3.705800e-05,5.826600e-03/ - data absa(1:270,4) / & - &7.489300e-05,1.766000e-04,2.074300e-04,2.234500e-04,2.554100e-04, & - &3.011300e-04,4.006500e-04,5.114000e-04,1.942000e-04,1.039600e-04, & - &2.301200e-04,2.662200e-04,2.824300e-04,2.942400e-04,3.300000e-04, & - &4.138700e-04,6.561800e-04,1.724800e-04,1.387400e-04,2.917100e-04, & - &3.341300e-04,3.519800e-04,3.573400e-04,3.640100e-04,4.248900e-04, & - &6.440300e-04,1.964100e-04,1.794100e-04,3.643400e-04,4.131700e-04, & - &4.327100e-04,4.372800e-04,4.327900e-04,4.418400e-04,6.129300e-04, & - &2.466000e-04,2.252400e-04,4.470000e-04,5.038900e-04,5.289900e-04, & - &5.422800e-04,5.447300e-04,5.336800e-04,5.642300e-04,3.149200e-04, & - &5.891000e-05,1.373000e-04,1.611100e-04,1.733800e-04,1.997400e-04, & - &2.361400e-04,3.144800e-04,3.886600e-04,1.440500e-04,8.303600e-05, & - &1.813500e-04,2.096400e-04,2.207000e-04,2.315800e-04,2.705700e-04, & - &3.337200e-04,5.472600e-04,1.281700e-04,1.121300e-04,2.328400e-04, & - &2.666200e-04,2.805000e-04,2.837400e-04,2.907200e-04,3.595600e-04, & - &5.306200e-04,1.456700e-04,1.463900e-04,2.933100e-04,3.322900e-04, & - &3.477300e-04,3.477100e-04,3.459800e-04,3.560900e-04,5.379600e-04, & - &1.891700e-04,1.857300e-04,3.633300e-04,4.089900e-04,4.280500e-04, & - &4.359600e-04,4.302300e-04,4.203600e-04,4.731000e-04,2.410600e-04, & - &4.269700e-05,9.973700e-05,1.176200e-04,1.317500e-04,1.520600e-04, & - &1.773800e-04,2.246100e-04,3.001200e-04,9.076000e-05,6.162800e-05, & - &1.345300e-04,1.555300e-04,1.639500e-04,1.786300e-04,2.102600e-04, & - &2.655900e-04,4.066500e-04,9.521300e-05,8.515500e-05,1.758000e-04, & - &2.015600e-04,2.120300e-04,2.126700e-04,2.293500e-04,2.827900e-04, & - &4.302800e-04,1.126500e-04,1.131700e-04,2.238600e-04,2.543800e-04, & - &2.654400e-04,2.660200e-04,2.665300e-04,2.974500e-04,4.274500e-04, & - &1.417300e-04,1.459700e-04,2.804500e-04,3.164900e-04,3.307700e-04, & - &3.324000e-04,3.217500e-04,3.219200e-04,4.115300e-04,1.776500e-04, & - &2.989600e-05,7.070900e-05,8.436000e-05,9.746600e-05,1.087400e-04, & - &1.307400e-04,1.622700e-04,2.546400e-04,6.813400e-05,4.434100e-05, & - &9.696200e-05,1.124700e-04,1.192900e-04,1.378500e-04,1.583400e-04, & - &2.007100e-04,2.918900e-04,7.820600e-05,6.291400e-05,1.290200e-04, & - &1.481700e-04,1.552700e-04,1.584900e-04,1.856900e-04,2.249700e-04, & - &3.412400e-04,9.084500e-05,8.567700e-05,1.668900e-04,1.906800e-04, & - &1.991600e-04,1.997800e-04,2.015500e-04,2.493600e-04,3.534000e-04, & - &1.098800e-04,1.124200e-04,2.114900e-04,2.391500e-04,2.502800e-04, & - &2.498900e-04,2.427200e-04,2.483100e-04,3.670900e-04,1.338100e-04, & - &2.068800e-05,4.920300e-05,5.978500e-05,6.699000e-05,7.812400e-05, & - &9.262400e-05,1.247200e-04,2.074500e-04,6.181200e-05,3.163700e-05, & - &6.927100e-05,8.060400e-05,9.007700e-05,1.018100e-04,1.170700e-04, & - &1.485300e-04,2.172200e-04,7.100500e-05,4.607600e-05,9.362500e-05, & - &1.076900e-04,1.133400e-04,1.217400e-04,1.441400e-04,1.766800e-04, & - &2.580000e-04,8.309400e-05,6.434100e-05,1.234600e-04,1.410300e-04, & - &1.485000e-04,1.469300e-04,1.581500e-04,1.928600e-04,2.881700e-04, & - &9.670100e-05,8.623800e-05,1.586800e-04,1.794200e-04,1.870700e-04, & - &1.880600e-04,1.831900e-04,2.055400e-04,2.861100e-04,1.128700e-04, & - &1.400600e-05,3.334300e-05,4.007900e-05,4.558800e-05,5.410700e-05, & - &6.641800e-05,1.006600e-04,1.419600e-04,6.624300e-05,2.207100e-05, & - &4.861400e-05,5.722800e-05,6.509300e-05,7.172100e-05,8.563500e-05, & - &1.085600e-04,1.802100e-04,7.555400e-05,3.304000e-05,6.668200e-05, & - &7.669800e-05,8.238000e-05,9.355200e-05,1.070000e-04,1.359600e-04, & - &1.940500e-04,8.606300e-05,4.738600e-05,8.979300e-05,1.023700e-04, & - &1.075900e-04,1.096500e-04,1.272600e-04,1.539800e-04,2.270400e-04, & - &9.869600e-05,6.512100e-05,1.175700e-04,1.326800e-04,1.386900e-04, & - &1.400600e-04,1.383600e-04,1.705100e-04,2.366900e-04,1.130500e-04/ - data absa(271:585,4) / & - &9.506100e-06,2.231100e-05,2.608800e-05,3.016200e-05,3.787700e-05, & - &5.450500e-05,7.522700e-05,1.125500e-04,8.348300e-05,1.532300e-05, & - &3.359800e-05,4.038600e-05,4.388100e-05,5.058300e-05,6.249300e-05, & - &8.284200e-05,1.432200e-04,9.431100e-05,2.359600e-05,4.749400e-05, & - &5.455600e-05,6.137200e-05,6.701500e-05,7.935000e-05,9.749600e-05, & - &1.443600e-04,1.070300e-04,3.457000e-05,6.486000e-05,7.369400e-05, & - &7.775400e-05,8.469500e-05,9.702900e-05,1.167800e-04,1.685800e-04, & - &1.212700e-04,4.855100e-05,8.660900e-05,9.761900e-05,1.016400e-04, & - &1.022600e-04,1.088500e-04,1.340500e-04,1.913300e-04,1.365600e-04, & - &6.731100e-06,1.475500e-05,1.693500e-05,2.146300e-05,3.123100e-05, & - &4.074200e-05,5.665600e-05,8.592700e-05,1.504900e-04,1.083800e-05, & - &2.318300e-05,2.745300e-05,3.055300e-05,3.569400e-05,4.637400e-05, & - &6.941900e-05,1.064300e-04,1.686600e-04,1.691400e-05,3.376600e-05, & - &3.898900e-05,4.444700e-05,4.807000e-05,5.719800e-05,7.111600e-05, & - &1.247800e-04,1.877900e-04,2.519500e-05,4.697200e-05,5.302600e-05, & - &5.692700e-05,6.456500e-05,7.192300e-05,9.075100e-05,1.224900e-04, & - &2.080500e-04,3.594200e-05,6.378600e-05,7.172900e-05,7.394900e-05, & - &7.644600e-05,8.816300e-05,1.036700e-04,1.546100e-04,2.306700e-04, & - &5.159900e-06,1.008100e-05,1.177200e-05,1.669800e-05,2.282100e-05, & - &2.993600e-05,4.210500e-05,6.299000e-05,5.873300e-04,8.023100e-06, & - &1.603100e-05,1.858100e-05,2.088900e-05,2.620200e-05,3.850200e-05, & - &5.118800e-05,8.223100e-05,6.445500e-04,1.236500e-05,2.396200e-05, & - &2.778500e-05,3.057400e-05,3.495900e-05,4.143300e-05,5.793900e-05, & - &9.731100e-05,7.019600e-04,1.849400e-05,3.414800e-05,3.852200e-05, & - &4.261000e-05,4.612500e-05,5.456600e-05,6.506600e-05,9.354300e-05, & - &7.583800e-04,2.656000e-05,4.683900e-05,5.242900e-05,5.418300e-05, & - &5.960900e-05,6.714900e-05,7.943600e-05,1.141700e-04,8.124700e-04, & - &4.584500e-06,7.805100e-06,9.369300e-06,1.299100e-05,1.757200e-05, & - &2.343700e-05,3.381300e-05,4.918800e-05,3.367400e-03,6.808400e-06, & - &1.203400e-05,1.368800e-05,1.573300e-05,2.121100e-05,2.909800e-05, & - &3.854500e-05,6.350000e-05,3.639100e-03,1.006200e-05,1.798200e-05, & - &2.040900e-05,2.266300e-05,2.561300e-05,3.178400e-05,4.738500e-05, & - &7.300600e-05,3.899300e-03,1.465800e-05,2.572700e-05,2.878200e-05, & - &3.231000e-05,3.448500e-05,4.075200e-05,4.872000e-05,8.249900e-05, & - &4.149000e-03,2.078600e-05,3.565700e-05,3.965900e-05,4.112300e-05, & - &4.698300e-05,5.055600e-05,6.352100e-05,8.449900e-05,4.377500e-03, & - &5.035600e-06,7.735300e-06,8.883300e-06,1.145200e-05,1.524300e-05, & - &2.104400e-05,2.833800e-05,4.994900e-05,7.257700e-03,7.242300e-06, & - &1.151400e-05,1.279800e-05,1.408600e-05,1.800700e-05,2.455800e-05, & - &3.385100e-05,5.280200e-05,7.815800e-03,1.030900e-05,1.665300e-05, & - &1.840700e-05,2.008900e-05,2.229600e-05,2.701800e-05,3.858600e-05, & - &6.006800e-05,8.335400e-03,1.442100e-05,2.337900e-05,2.574000e-05, & - &2.775000e-05,3.030900e-05,3.485100e-05,4.124500e-05,6.821100e-05, & - &8.829600e-03,1.966300e-05,3.184200e-05,3.499100e-05,3.614000e-05, & - &3.968800e-05,4.298300e-05,5.377600e-05,6.990700e-05,9.268800e-03, & - &5.116500e-06,7.402900e-06,8.194100e-06,1.013800e-05,1.349000e-05, & - &1.725600e-05,2.441900e-05,4.014600e-05,9.944800e-03,7.228300e-06, & - &1.080200e-05,1.188700e-05,1.264200e-05,1.573400e-05,2.054200e-05, & - &2.788600e-05,4.391000e-05,1.070500e-02,1.006500e-05,1.528400e-05, & - &1.664200e-05,1.815700e-05,1.944800e-05,2.320700e-05,3.216800e-05, & - &5.390500e-05,1.140900e-02,1.373100e-05,2.114200e-05,2.278000e-05, & - &2.437800e-05,2.666500e-05,2.973800e-05,3.516300e-05,5.582800e-05, & - &1.205100e-02,1.832800e-05,2.838200e-05,3.085000e-05,3.143000e-05, & - &3.392900e-05,3.701600e-05,4.526600e-05,5.884700e-05,1.260300e-02, & - &5.162800e-06,7.047600e-06,7.678300e-06,9.190100e-06,1.165900e-05, & - &1.499000e-05,2.074600e-05,3.159100e-05,1.097900e-02,7.165600e-06, & - &1.009000e-05,1.095100e-05,1.156200e-05,1.375000e-05,1.739800e-05, & - &2.370100e-05,3.748800e-05,1.181300e-02,9.781000e-06,1.415900e-05, & - &1.500300e-05,1.620700e-05,1.717500e-05,1.996500e-05,2.707900e-05, & - &4.338200e-05,1.257800e-02,1.310400e-05,1.925300e-05,2.039500e-05, & - &2.143600e-05,2.326100e-05,2.564000e-05,2.989500e-05,4.604500e-05, & - &1.323100e-02,1.720800e-05,2.554600e-05,2.742400e-05,2.753500e-05, & - &2.938000e-05,3.254600e-05,3.804000e-05,4.984000e-05,1.374200e-02/ - data absa(1:270,5) / & - &3.109000e-04,4.131200e-04,4.517600e-04,4.685600e-04,4.558600e-04, & - &4.321300e-04,4.539700e-04,7.801500e-04,2.010300e-04,3.839800e-04, & - &5.212200e-04,5.733600e-04,6.021700e-04,6.059100e-04,5.751100e-04, & - &5.342200e-04,6.189600e-04,2.835100e-04,4.653400e-04,6.438200e-04, & - &7.130100e-04,7.543800e-04,7.713400e-04,7.600600e-04,7.081100e-04, & - &7.423400e-04,3.776300e-04,5.598700e-04,7.844200e-04,8.747800e-04, & - &9.307800e-04,9.614500e-04,9.663200e-04,9.405700e-04,8.709400e-04, & - &4.732100e-04,6.657900e-04,9.434800e-04,1.059400e-03,1.132300e-03, & - &1.176900e-03,1.197300e-03,1.194100e-03,1.172000e-03,5.867000e-04, & - &2.473600e-04,3.272400e-04,3.530600e-04,3.617800e-04,3.491200e-04, & - &3.397900e-04,3.688200e-04,6.466100e-04,1.463700e-04,3.100200e-04, & - &4.171700e-04,4.535900e-04,4.728300e-04,4.716800e-04,4.410300e-04, & - &4.412400e-04,5.151900e-04,2.138900e-04,3.807900e-04,5.210700e-04, & - &5.706200e-04,5.997300e-04,6.066200e-04,5.932500e-04,5.374500e-04, & - &5.865200e-04,2.863300e-04,4.621000e-04,6.409400e-04,7.076300e-04, & - &7.477600e-04,7.665200e-04,7.598400e-04,7.320200e-04,6.414000e-04, & - &3.529000e-04,5.554600e-04,7.792500e-04,8.661600e-04,9.186300e-04, & - &9.467400e-04,9.549000e-04,9.409400e-04,9.186700e-04,4.420100e-04, & - &1.863900e-04,2.438700e-04,2.591500e-04,2.590600e-04,2.491800e-04, & - &2.596700e-04,3.165300e-04,4.758000e-04,1.167900e-04,2.379800e-04, & - &3.156400e-04,3.390600e-04,3.500000e-04,3.415700e-04,3.194300e-04, & - &3.274300e-04,4.549600e-04,1.585600e-04,2.973300e-04,4.007000e-04, & - &4.334900e-04,4.518800e-04,4.527000e-04,4.312300e-04,3.988000e-04, & - &4.408100e-04,2.044600e-04,3.650100e-04,4.994600e-04,5.449900e-04, & - &5.717000e-04,5.793200e-04,5.663300e-04,5.270400e-04,5.141400e-04, & - &2.553900e-04,4.441000e-04,6.157800e-04,6.761900e-04,7.113300e-04, & - &7.273800e-04,7.235100e-04,7.013800e-04,6.667300e-04,3.216900e-04, & - &1.380800e-04,1.777500e-04,1.856500e-04,1.817400e-04,1.820200e-04, & - &1.973800e-04,2.685400e-04,3.398000e-04,9.662200e-05,1.783500e-04, & - &2.333100e-04,2.475300e-04,2.513900e-04,2.387700e-04,2.322100e-04, & - &2.539400e-04,4.061800e-04,1.207500e-04,2.270200e-04,3.017000e-04, & - &3.227500e-04,3.326100e-04,3.299800e-04,3.063500e-04,3.042200e-04, & - &3.751300e-04,1.499400e-04,2.832700e-04,3.828800e-04,4.119100e-04, & - &4.282600e-04,4.283700e-04,4.151100e-04,3.729900e-04,4.148800e-04, & - &1.874000e-04,3.477800e-04,4.779800e-04,5.186300e-04,5.406500e-04, & - &5.466500e-04,5.362400e-04,5.055000e-04,4.587400e-04,2.350900e-04, & - &1.009000e-04,1.284000e-04,1.322200e-04,1.309200e-04,1.364900e-04, & - &1.601900e-04,2.167100e-04,2.530300e-04,9.121700e-05,1.329000e-04, & - &1.716100e-04,1.795200e-04,1.769300e-04,1.695700e-04,1.737800e-04, & - &2.203100e-04,3.259300e-04,1.046000e-04,1.716900e-04,2.255600e-04, & - &2.384200e-04,2.426600e-04,2.338700e-04,2.172200e-04,2.237600e-04, & - &3.324900e-04,1.231200e-04,2.176100e-04,2.909500e-04,3.101300e-04, & - &3.177600e-04,3.155600e-04,2.973400e-04,2.762100e-04,3.067400e-04, & - &1.484600e-04,2.697400e-04,3.687300e-04,3.964000e-04,4.087300e-04, & - &4.079600e-04,3.942500e-04,3.615700e-04,3.617400e-04,1.814600e-04, & - &7.209200e-05,9.104800e-05,9.342900e-05,9.522600e-05,1.015000e-04, & - &1.317300e-04,1.498400e-04,1.919600e-04,9.839700e-05,9.744800e-05, & - &1.242300e-04,1.279200e-04,1.241300e-04,1.242400e-04,1.338300e-04, & - &1.796000e-04,2.443400e-04,1.113300e-04,1.273600e-04,1.658400e-04, & - &1.736000e-04,1.720000e-04,1.616700e-04,1.589200e-04,1.715300e-04, & - &2.821800e-04,1.278100e-04,1.637600e-04,2.174200e-04,2.300300e-04, & - &2.326600e-04,2.268600e-04,2.072300e-04,2.053800e-04,2.548900e-04, & - &1.469000e-04,2.055500e-04,2.796000e-04,2.986100e-04,3.050100e-04, & - &3.000300e-04,2.874600e-04,2.598300e-04,2.831300e-04,1.700700e-04/ - data absa(271:585,5) / & - &5.091500e-05,6.409600e-05,6.583900e-05,7.043500e-05,8.247400e-05, & - &1.001600e-04,1.136000e-04,1.459000e-04,1.403200e-04,7.062500e-05, & - &8.909700e-05,9.031400e-05,8.942900e-05,9.325100e-05,1.072400e-04, & - &1.491200e-04,1.886300e-04,1.551800e-04,9.409800e-05,1.212500e-04, & - &1.253700e-04,1.209100e-04,1.160300e-04,1.185700e-04,1.462400e-04, & - &2.250600e-04,1.726200e-04,1.219100e-04,1.610200e-04,1.690100e-04, & - &1.684800e-04,1.582900e-04,1.483000e-04,1.515600e-04,2.203100e-04, & - &1.933900e-04,1.552900e-04,2.097300e-04,2.229700e-04,2.256200e-04, & - &2.189400e-04,2.041000e-04,1.878200e-04,2.102400e-04,2.167100e-04, & - &3.604900e-05,4.529100e-05,4.775400e-05,5.191900e-05,6.118600e-05, & - &6.919000e-05,8.437800e-05,1.164800e-04,2.757200e-04,5.104500e-05, & - &6.389600e-05,6.427200e-05,6.515000e-05,6.995400e-05,8.886800e-05, & - &1.016200e-04,1.459800e-04,3.000000e-04,6.921600e-05,8.825200e-05, & - &9.005000e-05,8.587300e-05,8.535900e-05,9.169300e-05,1.243200e-04, & - &1.574100e-04,3.261900e-04,9.071900e-05,1.185400e-04,1.239100e-04, & - &1.208900e-04,1.116000e-04,1.084500e-04,1.191200e-04,1.906300e-04, & - &3.545900e-04,1.170200e-04,1.560600e-04,1.653100e-04,1.662200e-04, & - &1.593200e-04,1.424800e-04,1.418300e-04,1.713100e-04,3.849700e-04, & - &2.586600e-05,3.232000e-05,3.457600e-05,3.870900e-05,4.622900e-05, & - &5.243800e-05,6.550300e-05,9.373000e-05,1.170300e-03,3.713000e-05, & - &4.604200e-05,4.640900e-05,4.878300e-05,5.617000e-05,6.776200e-05, & - &7.722500e-05,1.127300e-04,1.236400e-03,5.105700e-05,6.423800e-05, & - &6.474700e-05,6.300900e-05,6.385800e-05,7.477900e-05,9.938500e-05, & - &1.213700e-04,1.303500e-03,6.787200e-05,8.707400e-05,9.017100e-05, & - &8.636500e-05,8.177500e-05,8.115000e-05,1.009100e-04,1.584600e-04, & - &1.370600e-03,8.821200e-05,1.156500e-04,1.217000e-04,1.214800e-04, & - &1.125500e-04,1.039200e-04,1.039100e-04,1.503500e-04,1.439300e-03, & - &2.005200e-05,2.459900e-05,2.622400e-05,2.977500e-05,3.437700e-05, & - &3.975300e-05,5.187000e-05,7.061400e-05,6.931000e-03,2.864200e-05, & - &3.500600e-05,3.560100e-05,3.767000e-05,4.419200e-05,5.029700e-05, & - &6.075300e-05,8.840900e-05,7.247300e-03,3.950900e-05,4.880300e-05, & - &4.866800e-05,4.795100e-05,5.070800e-05,6.146900e-05,7.429700e-05, & - &9.617600e-05,7.542400e-03,5.282200e-05,6.632300e-05,6.791800e-05, & - &6.399300e-05,6.206200e-05,6.451900e-05,8.514700e-05,1.123000e-04, & - &7.812100e-03,6.896900e-05,8.831400e-05,9.195700e-05,9.070100e-05, & - &8.206200e-05,7.877900e-05,8.188800e-05,1.305100e-04,8.071400e-03, & - &1.931100e-05,2.294300e-05,2.371200e-05,2.607600e-05,2.976300e-05, & - &3.476100e-05,4.256100e-05,5.762400e-05,1.518700e-02,2.675700e-05, & - &3.217800e-05,3.209800e-05,3.342500e-05,3.756100e-05,4.343200e-05, & - &5.125600e-05,7.333200e-05,1.584000e-02,3.619600e-05,4.410200e-05, & - &4.394800e-05,4.243100e-05,4.409900e-05,5.181100e-05,6.214500e-05, & - &8.065600e-05,1.644900e-02,4.788200e-05,5.911100e-05,6.008600e-05, & - &5.720400e-05,5.437100e-05,5.507600e-05,7.052600e-05,9.294500e-05, & - &1.698900e-02,6.206800e-05,7.817400e-05,8.085900e-05,7.925800e-05, & - &7.273800e-05,6.860700e-05,6.892500e-05,1.061600e-04,1.748100e-02, & - &1.815700e-05,2.112100e-05,2.150900e-05,2.273600e-05,2.614500e-05, & - &3.020000e-05,3.706400e-05,5.045800e-05,2.116400e-02,2.475000e-05, & - &2.926500e-05,2.864000e-05,2.936500e-05,3.181500e-05,3.764400e-05, & - &4.425800e-05,6.089300e-05,2.208300e-02,3.305100e-05,3.966900e-05, & - &3.932300e-05,3.732200e-05,3.833000e-05,4.326800e-05,5.295300e-05, & - &6.645900e-05,2.290400e-02,4.326800e-05,5.275500e-05,5.330500e-05, & - &5.075500e-05,4.718300e-05,4.732100e-05,5.890500e-05,7.821100e-05, & - &2.362500e-02,5.571200e-05,6.931300e-05,7.113400e-05,6.940000e-05, & - &6.415300e-05,5.924400e-05,5.868300e-05,8.677200e-05,2.430400e-02, & - &1.717900e-05,1.977300e-05,1.959900e-05,2.037400e-05,2.348000e-05, & - &2.593500e-05,3.209700e-05,4.380700e-05,2.372200e-02,2.319500e-05, & - &2.701800e-05,2.615500e-05,2.611800e-05,2.765400e-05,3.241300e-05, & - &3.643900e-05,5.148000e-05,2.474800e-02,3.061200e-05,3.620800e-05, & - &3.560300e-05,3.330600e-05,3.323800e-05,3.675400e-05,4.523100e-05, & - &5.737000e-05,2.564600e-02,3.962600e-05,4.773700e-05,4.794100e-05, & - &4.525200e-05,4.165300e-05,4.075300e-05,4.932000e-05,6.566000e-05, & - &2.649200e-02,5.062200e-05,6.213800e-05,6.320300e-05,6.142600e-05, & - &5.625200e-05,5.127200e-05,5.038500e-05,7.086500e-05,2.727900e-02/ - data absa(1:270,6) / & - &7.666800e-04,9.569800e-04,1.045100e-03,1.070600e-03,1.045800e-03, & - &9.854400e-04,8.492500e-04,7.008400e-04,3.679000e-04,9.371500e-04, & - &1.203300e-03,1.326400e-03,1.367800e-03,1.357900e-03,1.295500e-03, & - &1.201900e-03,1.053000e-03,4.937400e-04,1.125900e-03,1.489200e-03, & - &1.650700e-03,1.708600e-03,1.709900e-03,1.666000e-03,1.546800e-03, & - &1.357200e-03,6.946900e-04,1.334600e-03,1.815000e-03,2.012500e-03, & - &2.093000e-03,2.105400e-03,2.060400e-03,1.946100e-03,1.769400e-03, & - &9.362900e-04,1.563100e-03,2.175100e-03,2.410700e-03,2.517700e-03, & - &2.541200e-03,2.499700e-03,2.400300e-03,2.232900e-03,1.194300e-03, & - &6.173600e-04,7.795700e-04,8.449500e-04,8.582200e-04,8.316800e-04, & - &7.671000e-04,6.819700e-04,6.111700e-04,2.755200e-04,7.643100e-04, & - &9.904701e-04,1.082500e-03,1.105900e-03,1.090500e-03,1.028200e-03, & - &9.176300e-04,8.378800e-04,3.811600e-04,9.290600e-04,1.234600e-03, & - &1.356100e-03,1.392500e-03,1.389800e-03,1.344000e-03,1.241100e-03, & - &1.100700e-03,5.277700e-04,1.112600e-03,1.513800e-03,1.662300e-03, & - &1.716600e-03,1.723700e-03,1.679900e-03,1.581300e-03,1.426200e-03, & - &7.085200e-04,1.316100e-03,1.821600e-03,2.002300e-03,2.078000e-03, & - &2.091800e-03,2.057600e-03,1.968900e-03,1.808300e-03,9.005500e-04, & - &4.687400e-04,5.950800e-04,6.378100e-04,6.411700e-04,6.143600e-04, & - &5.482200e-04,5.042100e-04,5.353300e-04,2.033400e-04,5.905500e-04, & - &7.670000e-04,8.289000e-04,8.394600e-04,8.179500e-04,7.603400e-04, & - &6.736800e-04,6.081600e-04,2.814500e-04,7.295500e-04,9.682100e-04, & - &1.049300e-03,1.069600e-03,1.061600e-03,1.015000e-03,9.211200e-04, & - &8.396000e-04,3.860500e-04,8.862100e-04,1.199500e-03,1.300100e-03, & - &1.332200e-03,1.333300e-03,1.293800e-03,1.204400e-03,1.088500e-03, & - &5.076400e-04,1.062000e-03,1.456100e-03,1.581300e-03,1.629100e-03, & - &1.633900e-03,1.606500e-03,1.526500e-03,1.370500e-03,6.470100e-04, & - &3.463100e-04,4.389200e-04,4.653900e-04,4.625200e-04,4.339500e-04, & - &3.855900e-04,3.548700e-04,4.483100e-04,1.511400e-04,4.442500e-04, & - &5.755300e-04,6.153800e-04,6.188300e-04,5.931400e-04,5.416500e-04, & - &4.864000e-04,4.422700e-04,2.051500e-04,5.588300e-04,7.374000e-04, & - &7.903100e-04,7.997400e-04,7.863900e-04,7.369100e-04,6.468000e-04, & - &6.186600e-04,2.773100e-04,6.897400e-04,9.253700e-04,9.922800e-04, & - &1.009800e-03,1.004400e-03,9.665000e-04,8.835800e-04,7.648400e-04, & - &3.626600e-04,8.399000e-04,1.136100e-03,1.220100e-03,1.249600e-03, & - &1.247200e-03,1.219400e-03,1.154000e-03,1.032500e-03,4.643000e-04, & - &2.525000e-04,3.180800e-04,3.338600e-04,3.271400e-04,3.003700e-04, & - &2.739900e-04,2.679100e-04,3.570400e-04,1.290800e-04,3.304300e-04, & - &4.248800e-04,4.501200e-04,4.488900e-04,4.255400e-04,3.820000e-04, & - &3.374500e-04,3.731000e-04,1.634800e-04,4.231600e-04,5.533800e-04, & - &5.874000e-04,5.916000e-04,5.754200e-04,5.310100e-04,4.625700e-04, & - &4.475500e-04,2.105700e-04,5.320900e-04,7.037000e-04,7.478400e-04, & - &7.577300e-04,7.477300e-04,7.116300e-04,6.417000e-04,5.600900e-04, & - &2.699500e-04,6.595400e-04,8.757700e-04,9.313600e-04,9.495600e-04, & - &9.432100e-04,9.142400e-04,8.502100e-04,7.650500e-04,3.440300e-04, & - &1.804100e-04,2.249000e-04,2.333600e-04,2.246400e-04,2.096300e-04, & - &1.942500e-04,2.210700e-04,2.798400e-04,1.489400e-04,2.412900e-04, & - &3.066400e-04,3.220100e-04,3.175300e-04,2.943200e-04,2.642400e-04, & - &2.460800e-04,3.271700e-04,1.715000e-04,3.150600e-04,4.066500e-04, & - &4.282300e-04,4.292400e-04,4.109200e-04,3.707500e-04,3.260800e-04, & - &3.071500e-04,1.999700e-04,4.046700e-04,5.253000e-04,5.538300e-04, & - &5.584200e-04,5.472400e-04,5.124300e-04,4.425400e-04,3.988800e-04, & - &2.376700e-04,5.110600e-04,6.641700e-04,6.997400e-04,7.096700e-04, & - &7.021200e-04,6.716100e-04,6.046400e-04,5.258900e-04,2.859800e-04/ - data absa(271:585,6) / & - &1.278600e-04,1.574100e-04,1.614900e-04,1.538500e-04,1.411300e-04, & - &1.371700e-04,1.792100e-04,2.188400e-04,2.233500e-04,1.747600e-04, & - &2.191400e-04,2.277700e-04,2.208400e-04,2.022900e-04,1.881200e-04, & - &1.801800e-04,2.753800e-04,2.465300e-04,2.333500e-04,2.958900e-04, & - &3.094200e-04,3.076500e-04,2.897700e-04,2.562500e-04,2.327500e-04, & - &2.517000e-04,2.733900e-04,3.058300e-04,3.890200e-04,4.070900e-04, & - &4.081900e-04,3.958800e-04,3.635600e-04,3.136100e-04,2.965800e-04, & - &3.034800e-04,3.935900e-04,5.008400e-04,5.227100e-04,5.261300e-04, & - &5.174200e-04,4.886200e-04,4.369300e-04,3.809200e-04,3.396200e-04, & - &9.077500e-05,1.100500e-04,1.109900e-04,1.050900e-04,9.965000e-05, & - &1.105500e-04,1.483200e-04,1.753000e-04,4.752500e-04,1.266900e-04, & - &1.562900e-04,1.606800e-04,1.536100e-04,1.425000e-04,1.345200e-04, & - &1.493300e-04,2.031000e-04,5.048000e-04,1.728500e-04,2.148300e-04, & - &2.227400e-04,2.183700e-04,2.010700e-04,1.803400e-04,1.696700e-04, & - &2.241800e-04,5.397100e-04,2.307800e-04,2.878400e-04,2.983400e-04, & - &2.968200e-04,2.834800e-04,2.537800e-04,2.196700e-04,2.177500e-04, & - &5.794900e-04,3.020700e-04,3.773000e-04,3.900300e-04,3.894100e-04, & - &3.785100e-04,3.531400e-04,3.032000e-04,2.734500e-04,6.234700e-04, & - &6.492300e-05,7.730100e-05,7.687300e-05,7.250700e-05,7.296800e-05, & - &8.891600e-05,1.062600e-04,1.304700e-04,2.147900e-03,9.206000e-05, & - &1.114400e-04,1.130100e-04,1.067300e-04,9.874100e-05,9.758500e-05, & - &1.220300e-04,1.531500e-04,2.221300e-03,1.278400e-04,1.559100e-04, & - &1.595700e-04,1.539500e-04,1.410100e-04,1.293700e-04,1.290200e-04, & - &1.826900e-04,2.300400e-03,1.736200e-04,2.126500e-04,2.181900e-04, & - &2.146000e-04,2.008800e-04,1.768700e-04,1.611400e-04,1.704500e-04, & - &2.383600e-03,2.306000e-04,2.834600e-04,2.906900e-04,2.869100e-04, & - &2.753800e-04,2.519200e-04,2.156700e-04,2.024200e-04,2.464500e-03, & - &4.962500e-05,5.757200e-05,5.644300e-05,5.499900e-05,5.943500e-05, & - &7.078600e-05,7.629500e-05,1.057300e-04,1.322400e-02,7.013400e-05, & - &8.301400e-05,8.262000e-05,7.796900e-05,7.337700e-05,8.001600e-05, & - &9.839500e-05,1.226600e-04,1.347600e-02,9.783800e-05,1.171600e-04, & - &1.184000e-04,1.125700e-04,1.024700e-04,9.538900e-05,1.038400e-04, & - &1.448800e-04,1.373300e-02,1.341100e-04,1.617500e-04,1.640700e-04, & - &1.591800e-04,1.459200e-04,1.291400e-04,1.223400e-04,1.560100e-04, & - &1.401500e-02,1.794700e-04,2.181300e-04,2.216700e-04,2.166100e-04, & - &2.049700e-04,1.830800e-04,1.570500e-04,1.555600e-04,1.428500e-02, & - &4.683800e-05,5.318800e-05,5.194000e-05,4.956000e-05,5.286700e-05, & - &6.047100e-05,6.713100e-05,8.923500e-05,2.968200e-02,6.477100e-05, & - &7.487900e-05,7.378900e-05,6.908500e-05,6.540200e-05,6.907800e-05, & - &8.240200e-05,9.782300e-05,3.021400e-02,8.897700e-05,1.044300e-04, & - &1.044900e-04,9.883700e-05,8.932500e-05,8.256400e-05,9.025600e-05, & - &1.226400e-04,3.075100e-02,1.203100e-04,1.434100e-04,1.443900e-04, & - &1.390900e-04,1.268400e-04,1.114800e-04,1.034300e-04,1.271000e-04, & - &3.129400e-02,1.596600e-04,1.921700e-04,1.944500e-04,1.892200e-04, & - &1.778500e-04,1.582600e-04,1.342600e-04,1.357200e-04,3.182800e-02, & - &4.401300e-05,4.905100e-05,4.731000e-05,4.508300e-05,4.565500e-05, & - &5.304600e-05,5.584600e-05,7.386800e-05,4.226200e-02,5.981100e-05, & - &6.790500e-05,6.645000e-05,6.148200e-05,5.747100e-05,5.842700e-05, & - &7.023500e-05,8.175500e-05,4.310000e-02,8.077100e-05,9.348300e-05, & - &9.271200e-05,8.729000e-05,7.833500e-05,7.205500e-05,7.561900e-05, & - &1.033000e-04,4.396300e-02,1.077800e-04,1.268400e-04,1.270600e-04, & - &1.218800e-04,1.109200e-04,9.699300e-05,8.853400e-05,1.054500e-04, & - &4.478100e-02,1.417000e-04,1.687400e-04,1.702000e-04,1.654600e-04, & - &1.547000e-04,1.378600e-04,1.155400e-04,1.153400e-04,4.554200e-02, & - &4.209000e-05,4.610100e-05,4.396500e-05,4.101600e-05,4.030000e-05, & - &4.549900e-05,4.885200e-05,6.175900e-05,4.834600e-02,5.624300e-05, & - &6.275300e-05,6.081900e-05,5.571300e-05,5.132200e-05,5.049400e-05, & - &6.060400e-05,6.800300e-05,4.946200e-02,7.445800e-05,8.464300e-05, & - &8.334300e-05,7.825100e-05,6.986900e-05,6.303000e-05,6.320600e-05, & - &8.713300e-05,5.055300e-02,9.770200e-05,1.129800e-04,1.124600e-04, & - &1.075300e-04,9.750700e-05,8.485700e-05,7.678800e-05,8.616700e-05, & - &5.156800e-02,1.269400e-04,1.487100e-04,1.495400e-04,1.448000e-04, & - &1.347300e-04,1.194100e-04,9.941300e-05,9.968800e-05,5.251900e-02/ - data absa(1:270,7) / & - &2.056400e-03,2.235700e-03,2.292100e-03,2.274600e-03,2.180800e-03, & - &2.011800e-03,1.740100e-03,1.303200e-03,9.555200e-04,2.524500e-03, & - &2.778000e-03,2.872200e-03,2.857500e-03,2.763300e-03,2.604600e-03, & - &2.322200e-03,1.813100e-03,1.354000e-03,3.032500e-03,3.377300e-03, & - &3.528400e-03,3.524200e-03,3.430200e-03,3.254700e-03,2.998200e-03, & - &2.661000e-03,1.794200e-03,3.577400e-03,4.032800e-03,4.257000e-03, & - &4.278600e-03,4.173400e-03,3.988000e-03,3.741800e-03,3.644300e-03, & - &2.297700e-03,4.155100e-03,4.749300e-03,5.061200e-03,5.108400e-03, & - &4.989600e-03,4.782800e-03,4.538800e-03,4.672900e-03,2.890100e-03, & - &1.702100e-03,1.872900e-03,1.924700e-03,1.907800e-03,1.821300e-03, & - &1.673700e-03,1.415200e-03,1.041000e-03,7.246500e-04,2.108500e-03, & - &2.347300e-03,2.430600e-03,2.418900e-03,2.337200e-03,2.194600e-03, & - &1.965000e-03,1.450700e-03,1.007000e-03,2.553900e-03,2.879000e-03, & - &3.005600e-03,3.009600e-03,2.921800e-03,2.759600e-03,2.525600e-03, & - &2.156200e-03,1.335800e-03,3.038100e-03,3.468900e-03,3.651800e-03, & - &3.677800e-03,3.575700e-03,3.403200e-03,3.167800e-03,2.964800e-03, & - &1.722900e-03,3.552100e-03,4.121400e-03,4.370400e-03,4.411800e-03, & - &4.301500e-03,4.108200e-03,3.860900e-03,3.804400e-03,2.185200e-03, & - &1.320700e-03,1.465000e-03,1.508100e-03,1.487900e-03,1.413800e-03, & - &1.285900e-03,1.051100e-03,7.881100e-04,5.147900e-04,1.660000e-03, & - &1.864900e-03,1.931200e-03,1.917900e-03,1.842200e-03,1.717800e-03, & - &1.506900e-03,1.126800e-03,7.092400e-04,2.038900e-03,2.320500e-03, & - &2.418500e-03,2.417100e-03,2.333900e-03,2.192900e-03,1.984600e-03, & - &1.636100e-03,9.460100e-04,2.454700e-03,2.832000e-03,2.972600e-03, & - &2.988300e-03,2.892500e-03,2.739300e-03,2.530500e-03,2.245500e-03, & - &1.230600e-03,2.899700e-03,3.405900e-03,3.590600e-03,3.618300e-03, & - &3.517700e-03,3.345400e-03,3.128500e-03,2.951900e-03,1.572900e-03, & - &9.910600e-04,1.107700e-03,1.137600e-03,1.115700e-03,1.052100e-03, & - &9.414800e-04,7.851000e-04,5.682400e-04,3.597500e-04,1.269000e-03, & - &1.435100e-03,1.483500e-03,1.464600e-03,1.399700e-03,1.288900e-03, & - &1.096000e-03,8.928900e-04,4.935300e-04,1.584200e-03,1.814200e-03, & - &1.886600e-03,1.878000e-03,1.801300e-03,1.682000e-03,1.502300e-03, & - &1.183000e-03,6.620300e-04,1.934000e-03,2.247100e-03,2.349900e-03, & - &2.351100e-03,2.264800e-03,2.132200e-03,1.950900e-03,1.676400e-03, & - &8.719400e-04,2.311300e-03,2.735100e-03,2.876200e-03,2.880500e-03, & - &2.787900e-03,2.639500e-03,2.456700e-03,2.240300e-03,1.126200e-03, & - &7.312700e-04,8.229600e-04,8.408700e-04,8.193400e-04,7.623700e-04, & - &6.635500e-04,5.771200e-04,4.258600e-04,2.610600e-04,9.556400e-04, & - &1.086600e-03,1.117500e-03,1.097500e-03,1.042300e-03,9.411500e-04, & - &7.808900e-04,7.027100e-04,3.518600e-04,1.213900e-03,1.396800e-03, & - &1.444700e-03,1.428900e-03,1.365600e-03,1.264200e-03,1.104400e-03, & - &8.551900e-04,4.709000e-04,1.503000e-03,1.755600e-03,1.826500e-03, & - &1.813900e-03,1.742300e-03,1.625600e-03,1.466800e-03,1.230200e-03, & - &6.226200e-04,1.820400e-03,2.165100e-03,2.262500e-03,2.250200e-03, & - &2.171600e-03,2.046900e-03,1.892500e-03,1.662600e-03,8.124000e-04, & - &5.252900e-04,5.943200e-04,6.035200e-04,5.830500e-04,5.330400e-04, & - &4.532800e-04,4.187800e-04,3.578000e-04,2.421700e-04,7.021200e-04, & - &8.020600e-04,8.188500e-04,8.006400e-04,7.526700e-04,6.672000e-04, & - &5.492500e-04,4.713700e-04,2.930400e-04,9.097400e-04,1.050500e-03, & - &1.078400e-03,1.060800e-03,1.008200e-03,9.219100e-04,7.818400e-04, & - &6.555400e-04,3.665000e-04,1.145300e-03,1.342300e-03,1.385200e-03, & - &1.367700e-03,1.307700e-03,1.209700e-03,1.076700e-03,8.564500e-04, & - &4.665300e-04,1.408100e-03,1.678500e-03,1.740800e-03,1.721200e-03, & - &1.652500e-03,1.550200e-03,1.418300e-03,1.215700e-03,5.997300e-04/ - data absa(271:585,7) / & - &3.712000e-04,4.208000e-04,4.247700e-04,4.060400e-04,3.635500e-04, & - &3.146800e-04,2.745200e-04,3.000300e-04,3.432900e-04,5.081100e-04, & - &5.811300e-04,5.897500e-04,5.743300e-04,5.328200e-04,4.571600e-04, & - &3.859100e-04,3.155800e-04,3.802100e-04,6.718900e-04,7.770800e-04, & - &7.924300e-04,7.752800e-04,7.322400e-04,6.599800e-04,5.438400e-04, & - &5.080800e-04,4.251000e-04,8.617200e-04,1.011100e-03,1.035700e-03, & - &1.017100e-03,9.677100e-04,8.886300e-04,7.705300e-04,5.990100e-04, & - &4.832700e-04,1.076200e-03,1.283800e-03,1.320800e-03,1.300700e-03, & - &1.242800e-03,1.156600e-03,1.037800e-03,8.610100e-04,5.625600e-04, & - &2.600500e-04,2.944500e-04,2.954400e-04,2.795400e-04,2.458300e-04, & - &2.164700e-04,1.800200e-04,2.359800e-04,7.909200e-04,3.645900e-04, & - &4.163700e-04,4.201000e-04,4.055600e-04,3.704700e-04,3.094000e-04, & - &2.752400e-04,2.543500e-04,8.347600e-04,4.922100e-04,5.687700e-04, & - &5.763300e-04,5.608900e-04,5.259800e-04,4.646600e-04,3.777600e-04, & - &3.412100e-04,8.796500e-04,6.435100e-04,7.533600e-04,7.668400e-04, & - &7.495500e-04,7.099200e-04,6.486700e-04,5.467100e-04,4.494300e-04, & - &9.304800e-04,8.169600e-04,9.716700e-04,9.927501e-04,9.748500e-04, & - &9.284100e-04,8.544000e-04,7.564200e-04,5.934200e-04,9.899600e-04, & - &1.808700e-04,2.039300e-04,2.031900e-04,1.899600e-04,1.659900e-04, & - &1.484500e-04,1.451700e-04,1.894300e-04,3.784000e-03,2.594700e-04, & - &2.951800e-04,2.959800e-04,2.832300e-04,2.523700e-04,2.133400e-04, & - &1.929700e-04,2.026500e-04,3.874600e-03,3.578800e-04,4.117000e-04, & - &4.150700e-04,4.008500e-04,3.711700e-04,3.171800e-04,2.616400e-04, & - &2.271500e-04,3.964500e-03,4.769900e-04,5.556900e-04,5.620400e-04, & - &5.469900e-04,5.152600e-04,4.640800e-04,3.778400e-04,3.419900e-04, & - &4.056000e-03,6.162100e-04,7.283600e-04,7.395300e-04,7.238900e-04, & - &6.867500e-04,6.269000e-04,5.424400e-04,4.150600e-04,4.148100e-03, & - &1.309400e-04,1.461700e-04,1.440900e-04,1.316600e-04,1.167100e-04, & - &1.084000e-04,1.199400e-04,1.533400e-04,2.467800e-02,1.903600e-04, & - &2.149300e-04,2.139900e-04,2.023900e-04,1.777900e-04,1.520200e-04, & - &1.346100e-04,1.639100e-04,2.481800e-02,2.667000e-04,3.045100e-04, & - &3.051800e-04,2.925200e-04,2.671300e-04,2.254500e-04,1.943000e-04, & - &1.765400e-04,2.494400e-02,3.607700e-04,4.172900e-04,4.198200e-04, & - &4.061900e-04,3.797900e-04,3.360500e-04,2.666500e-04,2.506400e-04, & - &2.504300e-02,4.736800e-04,5.545700e-04,5.600600e-04,5.456000e-04, & - &5.152000e-04,4.668200e-04,3.958700e-04,3.049000e-04,2.518200e-02, & - &1.167200e-04,1.286500e-04,1.257500e-04,1.155200e-04,1.015900e-04, & - &9.216400e-05,9.927000e-05,1.265300e-04,5.755900e-02,1.673200e-04, & - &1.874100e-04,1.855000e-04,1.744200e-04,1.535400e-04,1.313300e-04, & - &1.176700e-04,1.432900e-04,5.768400e-02,2.327600e-04,2.644400e-04, & - &2.634200e-04,2.511800e-04,2.288400e-04,1.926400e-04,1.652400e-04, & - &1.455800e-04,5.785500e-02,3.144300e-04,3.615400e-04,3.620300e-04, & - &3.485700e-04,3.249900e-04,2.871300e-04,2.293400e-04,2.118200e-04, & - &5.798100e-02,4.139200e-04,4.811100e-04,4.831800e-04,4.685200e-04, & - &4.407300e-04,3.980400e-04,3.371900e-04,2.566400e-04,5.801500e-02, & - &1.049500e-04,1.142500e-04,1.106500e-04,1.013900e-04,8.870200e-05, & - &8.027000e-05,8.322700e-05,1.103500e-04,8.477700e-02,1.481100e-04, & - &1.644400e-04,1.613300e-04,1.508800e-04,1.330400e-04,1.132900e-04, & - &1.021100e-04,1.181400e-04,8.505200e-02,2.046100e-04,2.305300e-04, & - &2.279900e-04,2.164700e-04,1.965500e-04,1.651000e-04,1.381300e-04, & - &1.205200e-04,8.532000e-02,2.761400e-04,3.148300e-04,3.131100e-04, & - &3.000500e-04,2.786600e-04,2.456900e-04,1.959500e-04,1.765000e-04, & - &8.555100e-02,3.636900e-04,4.194500e-04,4.187600e-04,4.037400e-04, & - &3.779200e-04,3.399000e-04,2.882100e-04,2.166000e-04,8.558600e-02, & - &9.645100e-05,1.034100e-04,9.926400e-05,9.043600e-05,7.828300e-05, & - &7.135300e-05,7.003800e-05,8.712700e-05,1.001700e-01,1.335300e-04, & - &1.463400e-04,1.421200e-04,1.321100e-04,1.162800e-04,9.784600e-05, & - &8.859300e-05,9.952000e-05,1.006600e-01,1.824700e-04,2.031900e-04, & - &1.992200e-04,1.877000e-04,1.698400e-04,1.428500e-04,1.182200e-04, & - &1.009600e-04,1.011400e-01,2.446300e-04,2.763500e-04,2.726200e-04, & - &2.599100e-04,2.402300e-04,2.110900e-04,1.673900e-04,1.471100e-04, & - &1.015100e-01,3.202300e-04,3.678100e-04,3.646300e-04,3.494900e-04, & - &3.264400e-04,2.924400e-04,2.473700e-04,1.818800e-04,1.016200e-01/ - data absa(1:270,8) / & - &4.423900e-03,4.551900e-03,4.572400e-03,4.417800e-03,4.219800e-03, & - &4.005800e-03,3.661500e-03,3.001900e-03,2.775200e-03,5.379700e-03, & - &5.603400e-03,5.681000e-03,5.545800e-03,5.376800e-03,5.213100e-03, & - &5.034900e-03,4.658700e-03,3.805600e-03,6.434700e-03,6.785900e-03, & - &6.927300e-03,6.848200e-03,6.711800e-03,6.617700e-03,6.601300e-03, & - &6.522500e-03,5.040100e-03,7.564500e-03,8.089200e-03,8.335200e-03, & - &8.308300e-03,8.256000e-03,8.261100e-03,8.384700e-03,8.525200e-03, & - &6.499600e-03,8.768000e-03,9.513000e-03,9.889800e-03,9.947300e-03, & - &1.001100e-02,1.014300e-02,1.042500e-02,1.076900e-02,8.207600e-03, & - &3.895600e-03,4.050200e-03,4.060300e-03,3.935300e-03,3.746500e-03, & - &3.473900e-03,3.090500e-03,2.394300e-03,2.118400e-03,4.791800e-03, & - &5.048400e-03,5.097100e-03,4.996000e-03,4.790100e-03,4.531100e-03, & - &4.245900e-03,3.845500e-03,2.926800e-03,5.785400e-03,6.175700e-03, & - &6.283800e-03,6.212700e-03,6.007100e-03,5.782800e-03,5.608300e-03, & - &5.442700e-03,3.902100e-03,6.858000e-03,7.421700e-03,7.632700e-03, & - &7.590100e-03,7.406200e-03,7.235800e-03,7.162500e-03,7.239700e-03, & - &5.067600e-03,8.010200e-03,8.786000e-03,9.125700e-03,9.129900e-03, & - &8.997700e-03,8.905600e-03,8.946600e-03,9.213200e-03,6.423400e-03, & - &3.218500e-03,3.366700e-03,3.368300e-03,3.270900e-03,3.115800e-03, & - &2.850600e-03,2.427200e-03,1.739300e-03,1.490500e-03,4.027200e-03, & - &4.261700e-03,4.296600e-03,4.214800e-03,4.049500e-03,3.767900e-03, & - &3.409600e-03,2.881700e-03,2.070600e-03,4.925500e-03,5.283800e-03, & - &5.375000e-03,5.310900e-03,5.133800e-03,4.839800e-03,4.550100e-03, & - &4.190900e-03,2.793700e-03,5.907900e-03,6.432500e-03,6.610700e-03, & - &6.563000e-03,6.382000e-03,6.090900e-03,5.861100e-03,5.756200e-03, & - &3.669200e-03,6.969600e-03,7.697500e-03,7.987700e-03,7.981100e-03, & - &7.804000e-03,7.529000e-03,7.361500e-03,7.465000e-03,4.705300e-03, & - &2.554500e-03,2.685900e-03,2.688000e-03,2.620300e-03,2.482300e-03, & - &2.258800e-03,1.832200e-03,1.271300e-03,1.021400e-03,3.257200e-03, & - &3.467700e-03,3.495700e-03,3.437800e-03,3.293100e-03,3.060100e-03, & - &2.671700e-03,2.017000e-03,1.435200e-03,4.044700e-03,4.368400e-03, & - &4.445600e-03,4.395100e-03,4.240500e-03,3.992300e-03,3.633300e-03, & - &3.094400e-03,1.957900e-03,4.919800e-03,5.392100e-03,5.538900e-03, & - &5.506200e-03,5.343400e-03,5.080700e-03,4.740200e-03,4.458700e-03, & - &2.602800e-03,5.881900e-03,6.531700e-03,6.782200e-03,6.776500e-03, & - &6.616200e-03,6.325300e-03,5.995400e-03,5.884000e-03,3.375500e-03, & - &1.975600e-03,2.085600e-03,2.092100e-03,2.039200e-03,1.930900e-03, & - &1.737700e-03,1.339400e-03,9.135300e-04,7.043800e-04,2.568700e-03, & - &2.746800e-03,2.777400e-03,2.734600e-03,2.614100e-03,2.417800e-03, & - &2.084300e-03,1.347100e-03,9.985400e-04,3.245400e-03,3.522600e-03, & - &3.594200e-03,3.558900e-03,3.424600e-03,3.213900e-03,2.896800e-03, & - &2.280800e-03,1.375600e-03,4.007800e-03,4.413500e-03,4.546400e-03, & - &4.522700e-03,4.380100e-03,4.156500e-03,3.822700e-03,3.412900e-03, & - &1.846000e-03,4.857100e-03,5.420800e-03,5.637900e-03,5.631600e-03, & - &5.490800e-03,5.240800e-03,4.884200e-03,4.593200e-03,2.424000e-03, & - &1.475100e-03,1.564900e-03,1.569800e-03,1.525000e-03,1.436700e-03, & - &1.269200e-03,9.243200e-04,6.860100e-04,5.093700e-04,1.961300e-03, & - &2.107100e-03,2.134800e-03,2.094300e-03,1.997600e-03,1.833000e-03, & - &1.533400e-03,9.451200e-04,7.063400e-04,2.528300e-03,2.757200e-03, & - &2.818400e-03,2.783000e-03,2.675600e-03,2.500300e-03,2.223700e-03, & - &1.632000e-03,9.727500e-04,3.177100e-03,3.512000e-03,3.622500e-03, & - &3.595900e-03,3.481900e-03,3.288700e-03,3.015500e-03,2.546800e-03, & - &1.315200e-03,3.908200e-03,4.379600e-03,4.549100e-03,4.547500e-03, & - &4.428000e-03,4.207300e-03,3.910600e-03,3.524000e-03,1.741000e-03/ - data absa(271:585,8) / & - &1.075600e-03,1.145700e-03,1.147400e-03,1.109200e-03,1.032800e-03, & - &8.832800e-04,6.484700e-04,4.958900e-04,5.709300e-04,1.464900e-03, & - &1.582000e-03,1.599000e-03,1.562900e-03,1.480900e-03,1.342300e-03, & - &1.073300e-03,6.594500e-04,6.705900e-04,1.928300e-03,2.113000e-03, & - &2.156400e-03,2.121400e-03,2.032000e-03,1.887500e-03,1.647500e-03, & - &1.099800e-03,8.202800e-04,2.469300e-03,2.740900e-03,2.822000e-03, & - &2.792800e-03,2.693600e-03,2.539000e-03,2.311500e-03,1.875100e-03, & - &1.033200e-03,3.088600e-03,3.474900e-03,3.598900e-03,3.585300e-03, & - &3.479400e-03,3.301400e-03,3.055500e-03,2.685500e-03,1.320200e-03, & - &7.701300e-04,8.226900e-04,8.209600e-04,7.876600e-04,7.205100e-04, & - &5.973400e-04,4.522100e-04,3.681500e-04,1.246500e-03,1.076100e-03, & - &1.166600e-03,1.175300e-03,1.141800e-03,1.074700e-03,9.548600e-04, & - &7.272200e-04,4.902400e-04,1.326500e-03,1.448600e-03,1.593300e-03, & - &1.620600e-03,1.587200e-03,1.511200e-03,1.393100e-03,1.179100e-03, & - &7.703200e-04,1.418300e-03,1.891400e-03,2.109600e-03,2.159500e-03, & - &2.128500e-03,2.044900e-03,1.915000e-03,1.724800e-03,1.323400e-03, & - &1.529700e-03,2.407800e-03,2.719600e-03,2.800800e-03,2.775700e-03, & - &2.682700e-03,2.540400e-03,2.345100e-03,2.026400e-03,1.677000e-03, & - &5.406200e-04,5.789400e-04,5.740600e-04,5.444700e-04,4.869800e-04, & - &3.902800e-04,3.073500e-04,2.818600e-04,6.337700e-03,7.765500e-04, & - &8.439100e-04,8.459900e-04,8.162900e-04,7.601600e-04,6.545000e-04, & - &4.798000e-04,3.641600e-04,6.430500e-03,1.070500e-03,1.179900e-03, & - &1.193600e-03,1.163800e-03,1.101700e-03,1.002300e-03,8.151700e-04, & - &5.467900e-04,6.549500e-03,1.427000e-03,1.595100e-03,1.623200e-03, & - &1.591000e-03,1.521900e-03,1.416800e-03,1.251900e-03,8.787500e-04, & - &6.672900e-03,1.850500e-03,2.095000e-03,2.141500e-03,2.110800e-03, & - &2.030800e-03,1.915300e-03,1.756100e-03,1.467800e-03,6.819000e-03, & - &3.858500e-04,4.137500e-04,4.080600e-04,3.829500e-04,3.337400e-04, & - &2.630200e-04,2.151900e-04,2.194300e-04,4.430700e-02,5.678300e-04, & - &6.177600e-04,6.165900e-04,5.911800e-04,5.427600e-04,4.538600e-04, & - &3.371400e-04,2.817200e-04,4.403900e-02,7.999400e-04,8.826900e-04, & - &8.882000e-04,8.620100e-04,8.118200e-04,7.256200e-04,5.638600e-04, & - &3.815300e-04,4.388700e-02,1.087300e-03,1.216700e-03,1.230500e-03, & - &1.201600e-03,1.143900e-03,1.056900e-03,9.148900e-04,6.001200e-04, & - &4.369500e-02,1.432900e-03,1.626000e-03,1.651100e-03,1.618600e-03, & - &1.550900e-03,1.454900e-03,1.319800e-03,1.061900e-03,4.345400e-02, & - &3.333100e-04,3.585900e-04,3.534700e-04,3.321300e-04,2.891600e-04, & - &2.287700e-04,1.790000e-04,1.996700e-04,1.087800e-01,4.904700e-04, & - &5.355200e-04,5.338100e-04,5.129900e-04,4.711500e-04,3.938800e-04, & - &2.908000e-04,2.362300e-04,1.079300e-01,6.927800e-04,7.675700e-04, & - &7.702500e-04,7.475500e-04,7.044200e-04,6.324400e-04,4.950100e-04, & - &3.302900e-04,1.068700e-01,9.445400e-04,1.062100e-03,1.069900e-03, & - &1.043100e-03,9.916699e-04,9.165800e-04,7.979500e-04,5.440700e-04, & - &1.058600e-01,1.246900e-03,1.425300e-03,1.441100e-03,1.408300e-03, & - &1.345800e-03,1.260700e-03,1.147000e-03,9.309200e-04,1.049900e-01, & - &2.886800e-04,3.101600e-04,3.054600e-04,2.870400e-04,2.514700e-04, & - &1.967600e-04,1.552900e-04,1.694300e-04,1.680000e-01,4.241900e-04, & - &4.634100e-04,4.611500e-04,4.430800e-04,4.080800e-04,3.435100e-04, & - &2.485700e-04,1.958000e-04,1.665600e-01,6.002300e-04,6.661700e-04, & - &6.665000e-04,6.458700e-04,6.078300e-04,5.473600e-04,4.358500e-04, & - &2.877400e-04,1.648500e-01,8.190600e-04,9.252400e-04,9.292100e-04, & - &9.028600e-04,8.562700e-04,7.908000e-04,6.905200e-04,4.803900e-04, & - &1.632400e-01,1.083900e-03,1.243200e-03,1.254600e-03,1.222400e-03, & - &1.163800e-03,1.087400e-03,9.887600e-04,8.138800e-04,1.619500e-01, & - &2.531200e-04,2.698200e-04,2.645800e-04,2.485700e-04,2.180600e-04, & - &1.708100e-04,1.311700e-04,1.389500e-04,2.073900e-01,3.690400e-04, & - &4.014300e-04,3.981700e-04,3.818600e-04,3.513700e-04,2.975700e-04, & - &2.165800e-04,1.637900e-04,2.058600e-01,5.208000e-04,5.781100e-04, & - &5.766100e-04,5.569300e-04,5.222400e-04,4.698500e-04,3.758000e-04, & - &2.480700e-04,2.040900e-01,7.112300e-04,8.034400e-04,8.056700e-04, & - &7.802900e-04,7.371800e-04,6.784800e-04,5.930400e-04,4.223200e-04, & - &2.024500e-01,9.448500e-04,1.081100e-03,1.087500e-03,1.057800e-03, & - &1.004400e-03,9.344300e-04,8.472300e-04,7.031500e-04,2.012900e-01/ - data absa(1:270,9) / & - &1.029200e-02,1.007400e-02,1.043300e-02,1.092000e-02,1.123900e-02, & - &1.130400e-02,1.101800e-02,9.941200e-03,1.026700e-02,1.249500e-02, & - &1.245300e-02,1.304900e-02,1.379200e-02,1.427800e-02,1.449600e-02, & - &1.423600e-02,1.336100e-02,1.392500e-02,1.485900e-02,1.509100e-02, & - &1.601700e-02,1.704500e-02,1.780600e-02,1.819500e-02,1.795200e-02, & - &1.736500e-02,1.846400e-02,1.736300e-02,1.794200e-02,1.928100e-02, & - &2.071800e-02,2.180100e-02,2.242400e-02,2.230000e-02,2.209200e-02, & - &2.394800e-02,1.998400e-02,2.101800e-02,2.286800e-02,2.480800e-02, & - &2.632400e-02,2.724200e-02,2.727600e-02,2.770100e-02,3.048800e-02, & - &9.512800e-03,9.286700e-03,9.549000e-03,9.863300e-03,1.002700e-02, & - &1.005800e-02,9.763600e-03,8.799400e-03,8.557000e-03,1.166800e-02, & - &1.158400e-02,1.207700e-02,1.255900e-02,1.292000e-02,1.306000e-02, & - &1.282500e-02,1.198300e-02,1.175100e-02,1.401100e-02,1.415100e-02, & - &1.494000e-02,1.566000e-02,1.628400e-02,1.657900e-02,1.636700e-02, & - &1.580400e-02,1.574200e-02,1.650800e-02,1.696100e-02,1.810200e-02, & - &1.919700e-02,2.013700e-02,2.066800e-02,2.050500e-02,2.031800e-02, & - &2.061000e-02,1.912200e-02,2.000600e-02,2.159000e-02,2.317400e-02, & - &2.452000e-02,2.528800e-02,2.526100e-02,2.563100e-02,2.646700e-02, & - &8.431600e-03,8.184200e-03,8.341400e-03,8.460100e-03,8.452700e-03, & - &8.346700e-03,8.042000e-03,7.114200e-03,6.546100e-03,1.050800e-02, & - &1.036500e-02,1.070000e-02,1.094100e-02,1.104900e-02,1.103100e-02, & - &1.075100e-02,9.938600e-03,9.144900e-03,1.278500e-02,1.282900e-02, & - &1.338900e-02,1.382500e-02,1.410500e-02,1.423200e-02,1.399100e-02, & - &1.342000e-02,1.242800e-02,1.524500e-02,1.554500e-02,1.639000e-02, & - &1.713200e-02,1.766600e-02,1.797700e-02,1.771600e-02,1.748600e-02, & - &1.647200e-02,1.785900e-02,1.850500e-02,1.973600e-02,2.085200e-02, & - &2.175700e-02,2.222400e-02,2.205600e-02,2.228000e-02,2.140300e-02, & - &7.348400e-03,7.090200e-03,7.138000e-03,7.102400e-03,6.977600e-03, & - &6.740000e-03,6.352100e-03,5.467300e-03,4.829500e-03,9.331000e-03, & - &9.139700e-03,9.315900e-03,9.353800e-03,9.268100e-03,9.055400e-03, & - &8.734400e-03,7.907600e-03,6.882800e-03,1.153400e-02,1.147500e-02, & - &1.181900e-02,1.198800e-02,1.200000e-02,1.186400e-02,1.157500e-02, & - &1.099400e-02,9.490100e-03,1.394300e-02,1.408700e-02,1.464900e-02, & - &1.503200e-02,1.521400e-02,1.517600e-02,1.486500e-02,1.452400e-02, & - &1.277700e-02,1.651700e-02,1.697600e-02,1.782700e-02,1.851900e-02, & - &1.892000e-02,1.900000e-02,1.872000e-02,1.874600e-02,1.680400e-02, & - &6.362400e-03,6.113300e-03,6.063400e-03,5.933000e-03,5.718100e-03, & - &5.402200e-03,4.948300e-03,4.102200e-03,3.489200e-03,8.240700e-03, & - &8.030300e-03,8.063200e-03,7.950400e-03,7.725300e-03,7.396200e-03, & - &6.969800e-03,6.176700e-03,5.074800e-03,1.036300e-02,1.024600e-02, & - &1.038700e-02,1.033500e-02,1.014900e-02,9.838600e-03,9.422500e-03, & - &8.811800e-03,7.140200e-03,1.269500e-02,1.275500e-02,1.304600e-02, & - &1.313800e-02,1.302900e-02,1.275000e-02,1.232700e-02,1.188200e-02, & - &9.741400e-03,1.522100e-02,1.554400e-02,1.606700e-02,1.636700e-02, & - &1.636300e-02,1.614500e-02,1.570200e-02,1.553000e-02,1.296600e-02, & - &5.381900e-03,5.168200e-03,5.048900e-03,4.868200e-03,4.603300e-03, & - &4.257000e-03,3.789200e-03,2.860800e-03,2.451200e-03,7.128000e-03, & - &6.936700e-03,6.848900e-03,6.648700e-03,6.338400e-03,5.957000e-03, & - &5.478400e-03,4.664600e-03,3.635500e-03,9.130200e-03,9.014500e-03, & - &8.982200e-03,8.786800e-03,8.461600e-03,8.056100e-03,7.566200e-03, & - &6.860500e-03,5.201800e-03,1.135800e-02,1.138800e-02,1.145600e-02, & - &1.131800e-02,1.101200e-02,1.059500e-02,1.005800e-02,9.490200e-03, & - &7.222300e-03,1.379800e-02,1.404100e-02,1.428700e-02,1.425700e-02, & - &1.399700e-02,1.358600e-02,1.299100e-02,1.259600e-02,9.727800e-03/ - data absa(271:585,9) / & - &4.420100e-03,4.265500e-03,4.145000e-03,3.947600e-03,3.672200e-03, & - &3.324900e-03,2.845800e-03,1.967100e-03,1.780300e-03,5.999100e-03, & - &5.858800e-03,5.755600e-03,5.502800e-03,5.166100e-03,4.770200e-03, & - &4.275600e-03,3.460800e-03,2.608400e-03,7.839500e-03,7.764300e-03, & - &7.694400e-03,7.401700e-03,7.017000e-03,6.564600e-03,6.042300e-03, & - &5.263000e-03,3.762800e-03,9.918900e-03,9.981500e-03,9.965800e-03, & - &9.672300e-03,9.268500e-03,8.761100e-03,8.172200e-03,7.472300e-03, & - &5.287200e-03,1.222400e-02,1.248700e-02,1.258700e-02,1.233800e-02, & - &1.191800e-02,1.137900e-02,1.071500e-02,1.010100e-02,7.225300e-03, & - &3.535000e-03,3.432500e-03,3.327500e-03,3.160500e-03,2.898800e-03, & - &2.568600e-03,2.109100e-03,1.295500e-03,2.267700e-03,4.924500e-03, & - &4.834100e-03,4.737600e-03,4.516400e-03,4.184400e-03,3.789400e-03, & - &3.307000e-03,2.476200e-03,2.660200e-03,6.572700e-03,6.541300e-03, & - &6.471500e-03,6.192100e-03,5.794800e-03,5.329000e-03,4.796300e-03, & - &4.012300e-03,3.305300e-03,8.467300e-03,8.558500e-03,8.534000e-03, & - &8.225100e-03,7.766000e-03,7.233100e-03,6.618100e-03,5.853700e-03, & - &4.283500e-03,1.059400e-02,1.087700e-02,1.093400e-02,1.063000e-02, & - &1.011800e-02,9.508300e-03,8.795600e-03,8.030600e-03,5.639300e-03, & - &2.740300e-03,2.678700e-03,2.597300e-03,2.457000e-03,2.244300e-03, & - &1.956200e-03,1.518500e-03,8.361600e-04,1.027400e-02,3.927400e-03, & - &3.879600e-03,3.799200e-03,3.614000e-03,3.336700e-03,2.976300e-03, & - &2.517300e-03,1.722300e-03,1.039000e-02,5.363400e-03,5.372100e-03, & - &5.308200e-03,5.070900e-03,4.725000e-03,4.282900e-03,3.757300e-03, & - &2.994000e-03,1.063800e-02,7.045800e-03,7.164000e-03,7.130100e-03, & - &6.861700e-03,6.451100e-03,5.911800e-03,5.297400e-03,4.553100e-03, & - &1.109100e-02,8.961700e-03,9.258900e-03,9.284900e-03,9.008800e-03, & - &8.534500e-03,7.884500e-03,7.154400e-03,6.355300e-03,1.170900e-02, & - &2.131900e-03,2.100400e-03,2.037200e-03,1.921000e-03,1.749700e-03, & - &1.511100e-03,1.130100e-03,5.575600e-04,7.528300e-02,3.136300e-03, & - &3.121200e-03,3.057400e-03,2.901500e-03,2.672200e-03,2.375600e-03, & - &1.957600e-03,1.219500e-03,7.406400e-02,4.373100e-03,4.411700e-03, & - &4.360200e-03,4.160800e-03,3.866900e-03,3.492700e-03,3.005000e-03, & - &2.290200e-03,7.303500e-02,5.845500e-03,5.988100e-03,5.956500e-03, & - &5.727000e-03,5.375400e-03,4.903500e-03,4.312400e-03,3.609100e-03, & - &7.253700e-02,7.546800e-03,7.856600e-03,7.869500e-03,7.628900e-03, & - &7.213300e-03,6.623400e-03,5.902500e-03,5.132200e-03,7.225700e-02, & - &1.974500e-03,1.970300e-03,1.919900e-03,1.812100e-03,1.655900e-03, & - &1.443100e-03,1.116300e-03,5.350000e-04,1.975700e-01,2.899900e-03, & - &2.927900e-03,2.881900e-03,2.735000e-03,2.527700e-03,2.254300e-03, & - &1.874600e-03,1.212400e-03,1.938400e-01,4.044400e-03,4.142000e-03, & - &4.103700e-03,3.924000e-03,3.657800e-03,3.309600e-03,2.856700e-03, & - &2.199800e-03,1.907100e-01,5.408500e-03,5.628700e-03,5.607700e-03, & - &5.405900e-03,5.083400e-03,4.641300e-03,4.070900e-03,3.377600e-03, & - &1.880900e-01,6.994100e-03,7.388000e-03,7.410800e-03,7.204600e-03, & - &6.812600e-03,6.257300e-03,5.547700e-03,4.786100e-03,1.860000e-01, & - &1.799600e-03,1.820600e-03,1.780500e-03,1.682900e-03,1.543300e-03, & - &1.350100e-03,1.057200e-03,5.480800e-04,3.284600e-01,2.642600e-03, & - &2.706800e-03,2.668700e-03,2.539300e-03,2.352000e-03,2.103800e-03, & - &1.767800e-03,1.188900e-03,3.227300e-01,3.685300e-03,3.834300e-03, & - &3.802800e-03,3.641800e-03,3.403100e-03,3.085500e-03,2.671300e-03, & - &2.075500e-03,3.177900e-01,4.935600e-03,5.214200e-03,5.198100e-03, & - &5.022100e-03,4.725200e-03,4.314200e-03,3.796000e-03,3.144400e-03, & - &3.132500e-01,6.394700e-03,6.852000e-03,6.876000e-03,6.687200e-03, & - &6.322200e-03,5.808300e-03,5.161600e-03,4.421400e-03,3.090300e-01, & - &1.615100e-03,1.656700e-03,1.623400e-03,1.537300e-03,1.412400e-03, & - &1.239400e-03,9.856400e-04,5.561600e-04,4.387100e-01,2.371000e-03, & - &2.467800e-03,2.432700e-03,2.318300e-03,2.149500e-03,1.930200e-03, & - &1.633600e-03,1.139800e-03,4.320600e-01,3.312100e-03,3.497800e-03, & - &3.466900e-03,3.326700e-03,3.111300e-03,2.824300e-03,2.458500e-03, & - &1.940200e-03,4.258500e-01,4.445700e-03,4.758700e-03,4.746800e-03, & - &4.587500e-03,4.311000e-03,3.939400e-03,3.477400e-03,2.899300e-03, & - &4.199300e-01,5.768900e-03,6.258900e-03,6.295100e-03,6.105700e-03, & - &5.761900e-03,5.295700e-03,4.723000e-03,4.052800e-03,4.140000e-01/ - data absa(1:270,10) / & - &2.834100e-02,2.494900e-02,2.479400e-02,2.398700e-02,2.381200e-02, & - &2.258600e-02,2.018700e-02,1.937600e-02,2.538100e-02,3.399100e-02, & - &3.019200e-02,3.057400e-02,3.006500e-02,2.984000e-02,2.801300e-02, & - &2.556600e-02,2.604400e-02,3.344700e-02,3.991000e-02,3.627100e-02, & - &3.677400e-02,3.678900e-02,3.616000e-02,3.432800e-02,3.230900e-02, & - &3.390000e-02,4.289100e-02,4.595000e-02,4.325400e-02,4.351500e-02, & - &4.381600e-02,4.327400e-02,4.095800e-02,3.982800e-02,4.303900e-02, & - &5.453600e-02,5.207400e-02,5.017000e-02,5.073500e-02,5.134000e-02, & - &5.069900e-02,4.791600e-02,4.915800e-02,5.357400e-02,6.852000e-02, & - &2.618400e-02,2.329600e-02,2.322600e-02,2.271400e-02,2.251400e-02, & - &2.136300e-02,1.936400e-02,1.825000e-02,2.285600e-02,3.174300e-02, & - &2.859700e-02,2.885400e-02,2.883500e-02,2.819900e-02,2.704600e-02, & - &2.454400e-02,2.445600e-02,3.069900e-02,3.760000e-02,3.475800e-02, & - &3.511200e-02,3.535700e-02,3.450400e-02,3.344100e-02,3.111700e-02, & - &3.205500e-02,4.050900e-02,4.377200e-02,4.149600e-02,4.201200e-02, & - &4.230900e-02,4.169600e-02,3.995900e-02,3.876200e-02,4.041500e-02, & - &5.262900e-02,5.006900e-02,4.833000e-02,4.942700e-02,4.976700e-02, & - &4.931000e-02,4.726000e-02,4.822200e-02,5.058600e-02,6.692900e-02, & - &2.284300e-02,2.082100e-02,2.035000e-02,2.028300e-02,1.989700e-02, & - &1.912000e-02,1.738400e-02,1.617000e-02,1.844600e-02,2.819900e-02, & - &2.606200e-02,2.577600e-02,2.599700e-02,2.544000e-02,2.472300e-02, & - &2.244100e-02,2.171700e-02,2.548300e-02,3.395300e-02,3.191900e-02, & - &3.194100e-02,3.215700e-02,3.174700e-02,3.092200e-02,2.855900e-02, & - &2.870900e-02,3.443900e-02,4.000200e-02,3.842300e-02,3.890200e-02, & - &3.891100e-02,3.882000e-02,3.759400e-02,3.635100e-02,3.671800e-02, & - &4.577500e-02,4.621900e-02,4.515500e-02,4.619700e-02,4.638700e-02, & - &4.615300e-02,4.533400e-02,4.583400e-02,4.653400e-02,5.940100e-02, & - &1.931200e-02,1.799200e-02,1.748000e-02,1.744600e-02,1.711100e-02, & - &1.647700e-02,1.524300e-02,1.339900e-02,1.412100e-02,2.434400e-02, & - &2.295500e-02,2.261700e-02,2.278300e-02,2.249600e-02,2.186700e-02, & - &1.980800e-02,1.893600e-02,1.993800e-02,2.980100e-02,2.852300e-02, & - &2.856600e-02,2.870900e-02,2.868200e-02,2.772500e-02,2.533400e-02, & - &2.528400e-02,2.774300e-02,3.562000e-02,3.474200e-02,3.529900e-02, & - &3.530800e-02,3.545700e-02,3.441900e-02,3.260400e-02,3.301300e-02, & - &3.758700e-02,4.188700e-02,4.132100e-02,4.227400e-02,4.266000e-02, & - &4.293700e-02,4.208100e-02,4.159300e-02,4.262200e-02,4.965300e-02, & - &1.596200e-02,1.509100e-02,1.492600e-02,1.472500e-02,1.447100e-02, & - &1.401600e-02,1.294100e-02,1.078100e-02,1.082000e-02,2.056100e-02, & - &1.965600e-02,1.960600e-02,1.972300e-02,1.959700e-02,1.895900e-02, & - &1.707000e-02,1.599400e-02,1.550700e-02,2.567500e-02,2.481800e-02, & - &2.519600e-02,2.551700e-02,2.543900e-02,2.441200e-02,2.199100e-02, & - &2.155200e-02,2.188800e-02,3.128400e-02,3.068800e-02,3.145200e-02, & - &3.191300e-02,3.193800e-02,3.078100e-02,2.833000e-02,2.879600e-02, & - &3.024700e-02,3.724400e-02,3.703900e-02,3.811300e-02,3.904100e-02, & - &3.940900e-02,3.813800e-02,3.656700e-02,3.773000e-02,4.067900e-02, & - &1.297500e-02,1.225600e-02,1.234000e-02,1.208000e-02,1.189500e-02, & - &1.150600e-02,1.036500e-02,8.538300e-03,8.017200e-03,1.718700e-02, & - &1.632100e-02,1.656100e-02,1.666900e-02,1.661100e-02,1.585800e-02, & - &1.420600e-02,1.263800e-02,1.186600e-02,2.195000e-02,2.103900e-02, & - &2.172100e-02,2.210000e-02,2.198900e-02,2.083400e-02,1.860700e-02, & - &1.764800e-02,1.718700e-02,2.722100e-02,2.649200e-02,2.758200e-02, & - &2.823200e-02,2.803400e-02,2.672000e-02,2.404800e-02,2.409900e-02, & - &2.397500e-02,3.296600e-02,3.259600e-02,3.401300e-02,3.512800e-02, & - &3.517400e-02,3.358500e-02,3.096600e-02,3.214700e-02,3.271400e-02/ - data absa(271:585,10) / & - &1.100300e-02,1.017200e-02,9.968900e-03,9.703000e-03,9.581600e-03, & - &9.186400e-03,8.315700e-03,6.547700e-03,5.858400e-03,1.495400e-02, & - &1.391500e-02,1.370500e-02,1.380500e-02,1.371100e-02,1.291800e-02, & - &1.161300e-02,9.752400e-03,8.892100e-03,1.952500e-02,1.828600e-02, & - &1.835900e-02,1.880300e-02,1.850500e-02,1.739700e-02,1.554500e-02, & - &1.407400e-02,1.314700e-02,2.476500e-02,2.334700e-02,2.385200e-02, & - &2.452100e-02,2.404600e-02,2.274600e-02,2.033800e-02,1.959300e-02, & - &1.871800e-02,3.044400e-02,2.911400e-02,2.998100e-02,3.100100e-02, & - &3.065900e-02,2.911500e-02,2.615300e-02,2.666300e-02,2.577800e-02, & - &9.590300e-03,8.767700e-03,8.275100e-03,7.762800e-03,7.619400e-03, & - &7.219400e-03,6.475700e-03,5.162600e-03,4.544600e-03,1.338600e-02, & - &1.229000e-02,1.166100e-02,1.130600e-02,1.105500e-02,1.045400e-02, & - &9.391800e-03,7.574000e-03,6.621200e-03,1.789500e-02,1.649500e-02, & - &1.587100e-02,1.573000e-02,1.523700e-02,1.434700e-02,1.288000e-02, & - &1.112100e-02,9.965700e-03,2.308800e-02,2.146000e-02,2.093100e-02, & - &2.082800e-02,2.024300e-02,1.903900e-02,1.717800e-02,1.570700e-02, & - &1.436900e-02,2.876800e-02,2.706500e-02,2.673600e-02,2.667800e-02, & - &2.624800e-02,2.487800e-02,2.235900e-02,2.179800e-02,1.997400e-02, & - &8.148900e-03,7.464800e-03,6.980400e-03,6.419100e-03,5.963600e-03, & - &5.490900e-03,4.878400e-03,3.834700e-03,1.531400e-02,1.171200e-02, & - &1.078900e-02,1.010900e-02,9.482900e-03,8.858400e-03,8.227800e-03, & - &7.376400e-03,5.787700e-03,1.624400e-02,1.604600e-02,1.482000e-02, & - &1.405500e-02,1.333200e-02,1.245600e-02,1.163600e-02,1.048900e-02, & - &8.687300e-03,1.749400e-02,2.106600e-02,1.961000e-02,1.893100e-02, & - &1.788800e-02,1.675600e-02,1.578400e-02,1.441700e-02,1.255700e-02, & - &1.932600e-02,2.666700e-02,2.507400e-02,2.452200e-02,2.318900e-02, & - &2.200800e-02,2.099500e-02,1.928100e-02,1.779100e-02,2.165400e-02, & - &6.936600e-03,6.378900e-03,5.959500e-03,5.485200e-03,4.936000e-03, & - &4.320100e-03,3.706000e-03,2.841100e-03,1.086500e-01,1.023600e-02, & - &9.475000e-03,8.850100e-03,8.303600e-03,7.488000e-03,6.614600e-03, & - &5.858000e-03,4.579300e-03,1.062700e-01,1.433200e-02,1.332400e-02, & - &1.260400e-02,1.184500e-02,1.073000e-02,9.574100e-03,8.587600e-03, & - &7.023600e-03,1.049000e-01,1.912000e-02,1.791400e-02,1.731100e-02, & - &1.610800e-02,1.459200e-02,1.325300e-02,1.209700e-02,1.016500e-02, & - &1.042600e-01,2.456100e-02,2.322100e-02,2.264600e-02,2.112200e-02, & - &1.933400e-02,1.796100e-02,1.655900e-02,1.461000e-02,1.051000e-01, & - &7.023700e-03,6.522500e-03,6.104300e-03,5.644400e-03,5.063300e-03, & - &4.339900e-03,3.560700e-03,2.685000e-03,2.889200e-01,1.038400e-02, & - &9.683100e-03,9.083500e-03,8.519200e-03,7.640400e-03,6.652800e-03, & - &5.651400e-03,4.527300e-03,2.816900e-01,1.445600e-02,1.356600e-02, & - &1.299700e-02,1.210700e-02,1.090100e-02,9.542500e-03,8.237400e-03, & - &6.840000e-03,2.773400e-01,1.919500e-02,1.815600e-02,1.765600e-02, & - &1.641900e-02,1.488100e-02,1.320500e-02,1.174100e-02,9.991500e-03, & - &2.733100e-01,2.452100e-02,2.353600e-02,2.297900e-02,2.146400e-02, & - &1.979900e-02,1.777100e-02,1.604500e-02,1.404700e-02,2.706100e-01, & - &6.980100e-03,6.541400e-03,6.146400e-03,5.698800e-03,5.090200e-03, & - &4.419800e-03,3.637000e-03,2.550600e-03,4.960900e-01,1.025200e-02, & - &9.663100e-03,9.210400e-03,8.545100e-03,7.672400e-03,6.708600e-03, & - &5.541200e-03,4.427700e-03,4.867200e-01,1.419400e-02,1.347300e-02, & - &1.301900e-02,1.213000e-02,1.094000e-02,9.605900e-03,8.109100e-03, & - &6.733700e-03,4.777900e-01,1.876400e-02,1.799600e-02,1.754900e-02, & - &1.639100e-02,1.497000e-02,1.336200e-02,1.142400e-02,9.737100e-03, & - &4.709400e-01,2.382200e-02,2.325500e-02,2.279800e-02,2.148700e-02, & - &1.993500e-02,1.789300e-02,1.547700e-02,1.350100e-02,4.640400e-01, & - &6.757000e-03,6.398500e-03,6.064800e-03,5.609000e-03,5.037200e-03, & - &4.389600e-03,3.598400e-03,2.561200e-03,7.012900e-01,9.851600e-03, & - &9.361000e-03,9.038000e-03,8.385700e-03,7.580100e-03,6.603700e-03, & - &5.466000e-03,4.157200e-03,6.862400e-01,1.356500e-02,1.302300e-02, & - &1.269700e-02,1.184500e-02,1.077100e-02,9.512900e-03,8.035500e-03, & - &6.406800e-03,6.734800e-01,1.782300e-02,1.745100e-02,1.703100e-02, & - &1.602500e-02,1.481000e-02,1.322600e-02,1.124800e-02,9.262700e-03, & - &6.625200e-01,2.263500e-02,2.257000e-02,2.202900e-02,2.111600e-02, & - &1.964800e-02,1.764800e-02,1.512500e-02,1.281400e-02,6.522400e-01/ - data absa(1:270,11) / & - &4.042300e-02,3.551100e-02,3.238500e-02,3.130200e-02,2.932900e-02, & - &2.749300e-02,2.523700e-02,2.626200e-02,3.333500e-02,4.806800e-02, & - &4.222400e-02,3.979000e-02,3.847300e-02,3.691600e-02,3.388900e-02, & - &3.238700e-02,3.478400e-02,4.395400e-02,5.596200e-02,4.914700e-02, & - &4.793200e-02,4.649800e-02,4.480800e-02,4.078800e-02,4.114500e-02, & - &4.475200e-02,5.684800e-02,6.392700e-02,5.655400e-02,5.649600e-02, & - &5.514600e-02,5.297200e-02,4.927500e-02,5.221800e-02,5.702800e-02, & - &7.159300e-02,7.190000e-02,6.553300e-02,6.548200e-02,6.406000e-02, & - &6.105400e-02,5.949800e-02,6.485000e-02,7.076900e-02,8.889700e-02, & - &3.829200e-02,3.358800e-02,3.135800e-02,2.990600e-02,2.844700e-02, & - &2.656900e-02,2.394400e-02,2.413200e-02,3.151300e-02,4.599400e-02, & - &4.034500e-02,3.865000e-02,3.717800e-02,3.607700e-02,3.281100e-02, & - &3.118900e-02,3.223200e-02,4.184900e-02,5.398400e-02,4.745600e-02, & - &4.664100e-02,4.556800e-02,4.397300e-02,3.955900e-02,3.977600e-02, & - &4.189500e-02,5.433900e-02,6.215300e-02,5.554100e-02,5.514700e-02, & - &5.441900e-02,5.214500e-02,4.821200e-02,5.004900e-02,5.421100e-02, & - &6.857300e-02,7.049800e-02,6.491200e-02,6.400500e-02,6.367500e-02, & - &6.034000e-02,5.847100e-02,6.176500e-02,6.810600e-02,8.579500e-02, & - &3.435100e-02,3.011400e-02,2.869000e-02,2.703300e-02,2.592200e-02, & - &2.404300e-02,2.141200e-02,2.051900e-02,2.741100e-02,4.194000e-02, & - &3.676700e-02,3.578200e-02,3.418700e-02,3.318800e-02,3.029700e-02, & - &2.855000e-02,2.855100e-02,3.704400e-02,5.002800e-02,4.411800e-02, & - &4.371200e-02,4.251300e-02,4.081800e-02,3.722300e-02,3.689200e-02, & - &3.758500e-02,4.902500e-02,5.838200e-02,5.235000e-02,5.219200e-02, & - &5.136500e-02,4.884000e-02,4.560500e-02,4.668800e-02,4.879500e-02, & - &6.330800e-02,6.685500e-02,6.185100e-02,6.131900e-02,6.044000e-02, & - &5.755300e-02,5.514100e-02,5.750700e-02,6.172600e-02,8.074700e-02, & - &2.991400e-02,2.643400e-02,2.522900e-02,2.396000e-02,2.287200e-02, & - &2.116700e-02,1.861800e-02,1.765400e-02,2.220600e-02,3.731100e-02, & - &3.295500e-02,3.198700e-02,3.081600e-02,2.974600e-02,2.745100e-02, & - &2.549600e-02,2.481600e-02,3.076900e-02,4.521400e-02,4.022500e-02, & - &3.966500e-02,3.883000e-02,3.707300e-02,3.431700e-02,3.349800e-02, & - &3.325900e-02,4.167200e-02,5.352200e-02,4.844000e-02,4.807700e-02, & - &4.749900e-02,4.506000e-02,4.219800e-02,4.287700e-02,4.365900e-02, & - &5.541500e-02,6.211200e-02,5.763700e-02,5.735500e-02,5.636500e-02, & - &5.383100e-02,5.148300e-02,5.357800e-02,5.554800e-02,7.239700e-02, & - &2.552500e-02,2.296100e-02,2.174300e-02,2.104500e-02,1.976200e-02, & - &1.831300e-02,1.600600e-02,1.492800e-02,1.724300e-02,3.256200e-02, & - &2.929700e-02,2.811800e-02,2.737800e-02,2.621900e-02,2.442900e-02, & - &2.237400e-02,2.160800e-02,2.440900e-02,4.023700e-02,3.653000e-02, & - &3.552900e-02,3.494700e-02,3.350700e-02,3.120500e-02,2.986500e-02, & - &2.966800e-02,3.396500e-02,4.848900e-02,4.464000e-02,4.388200e-02, & - &4.318400e-02,4.146600e-02,3.871600e-02,3.883900e-02,3.905300e-02, & - &4.619300e-02,5.707500e-02,5.352000e-02,5.315100e-02,5.181300e-02, & - &5.014300e-02,4.769900e-02,4.957500e-02,5.028700e-02,6.184400e-02, & - &2.118500e-02,1.936600e-02,1.834500e-02,1.786100e-02,1.669600e-02, & - &1.528600e-02,1.353800e-02,1.211000e-02,1.305000e-02,2.773600e-02, & - &2.542100e-02,2.434400e-02,2.368600e-02,2.263200e-02,2.116700e-02, & - &1.899400e-02,1.832700e-02,1.872200e-02,3.509800e-02,3.243300e-02, & - &3.134600e-02,3.089000e-02,2.971700e-02,2.770900e-02,2.562600e-02, & - &2.563900e-02,2.641100e-02,4.303300e-02,4.026100e-02,3.946600e-02, & - &3.884500e-02,3.754500e-02,3.464000e-02,3.386200e-02,3.428700e-02, & - &3.695600e-02,5.141500e-02,4.888900e-02,4.852400e-02,4.740600e-02, & - &4.597700e-02,4.302100e-02,4.412600e-02,4.490600e-02,5.043200e-02/ - data absa(271:585,11) / & - &1.720900e-02,1.591100e-02,1.531200e-02,1.478500e-02,1.378800e-02, & - &1.264400e-02,1.117800e-02,9.426200e-03,9.625000e-03,2.320400e-02, & - &2.153000e-02,2.085000e-02,2.015000e-02,1.919500e-02,1.801300e-02, & - &1.571500e-02,1.496700e-02,1.428300e-02,3.002100e-02,2.810300e-02, & - &2.738400e-02,2.684100e-02,2.591700e-02,2.407100e-02,2.133900e-02, & - &2.136400e-02,2.056200e-02,3.751600e-02,3.549300e-02,3.502200e-02, & - &3.455000e-02,3.342500e-02,3.056200e-02,2.848500e-02,2.910800e-02, & - &2.918600e-02,4.562200e-02,4.370400e-02,4.364100e-02,4.305700e-02, & - &4.166400e-02,3.818600e-02,3.783100e-02,3.889700e-02,4.050500e-02, & - &1.381800e-02,1.282000e-02,1.255500e-02,1.203400e-02,1.117600e-02, & - &1.035900e-02,9.122700e-03,7.190900e-03,7.138500e-03,1.919900e-02, & - &1.786800e-02,1.758500e-02,1.687100e-02,1.607800e-02,1.501600e-02, & - &1.289300e-02,1.187500e-02,1.081100e-02,2.546400e-02,2.391000e-02, & - &2.356600e-02,2.303400e-02,2.231400e-02,2.047200e-02,1.763500e-02, & - &1.725600e-02,1.599200e-02,3.255100e-02,3.072200e-02,3.070400e-02, & - &3.040900e-02,2.933900e-02,2.665000e-02,2.359900e-02,2.404400e-02, & - &2.323600e-02,4.025000e-02,3.845400e-02,3.884200e-02,3.867500e-02, & - &3.714700e-02,3.364700e-02,3.160200e-02,3.283900e-02,3.258100e-02, & - &1.131600e-02,1.037800e-02,1.005800e-02,9.538800e-03,8.958300e-03, & - &8.321500e-03,7.217200e-03,5.379400e-03,1.835500e-02,1.623100e-02, & - &1.492800e-02,1.449800e-02,1.382900e-02,1.324100e-02,1.231300e-02, & - &1.061400e-02,9.266800e-03,1.977000e-02,2.213000e-02,2.049400e-02, & - &1.990300e-02,1.941100e-02,1.877300e-02,1.714300e-02,1.470300e-02, & - &1.379000e-02,2.158100e-02,2.887200e-02,2.689300e-02,2.641000e-02, & - &2.629300e-02,2.518400e-02,2.287500e-02,1.959900e-02,1.945300e-02, & - &2.420700e-02,3.643400e-02,3.416300e-02,3.403900e-02,3.405900e-02, & - &3.248500e-02,2.955800e-02,2.612400e-02,2.690800e-02,2.876600e-02, & - &9.752600e-03,8.847100e-03,8.409500e-03,7.799200e-03,7.273300e-03, & - &6.686100e-03,5.780400e-03,4.072400e-03,1.276300e-01,1.444100e-02, & - &1.314900e-02,1.243600e-02,1.155400e-02,1.104900e-02,1.017300e-02, & - &8.769800e-03,7.145000e-03,1.260000e-01,2.015500e-02,1.843700e-02, & - &1.742600e-02,1.660300e-02,1.585300e-02,1.456100e-02,1.251100e-02, & - &1.107300e-02,1.252800e-01,2.684600e-02,2.460900e-02,2.348600e-02, & - &2.285400e-02,2.162300e-02,1.979600e-02,1.692900e-02,1.599100e-02, & - &1.244700e-01,3.441000e-02,3.174400e-02,3.075000e-02,2.997200e-02, & - &2.839700e-02,2.596600e-02,2.261600e-02,2.244900e-02,1.261000e-01, & - &1.032400e-02,9.372000e-03,8.725200e-03,7.945000e-03,7.248200e-03, & - &6.514700e-03,5.610000e-03,4.166200e-03,3.432900e-01,1.520400e-02, & - &1.388500e-02,1.289100e-02,1.186900e-02,1.095600e-02,9.882600e-03, & - &8.570300e-03,6.806100e-03,3.356500e-01,2.111500e-02,1.936700e-02, & - &1.805800e-02,1.696200e-02,1.561200e-02,1.416500e-02,1.230800e-02, & - &1.052800e-02,3.274600e-01,2.805600e-02,2.586900e-02,2.449500e-02, & - &2.301900e-02,2.119000e-02,1.934000e-02,1.690900e-02,1.535300e-02, & - &3.210500e-01,3.583000e-02,3.326900e-02,3.205300e-02,3.001900e-02, & - &2.776400e-02,2.574600e-02,2.282100e-02,2.201800e-02,3.159700e-01, & - &1.067200e-02,9.754900e-03,9.056100e-03,8.246600e-03,7.361300e-03, & - &6.387500e-03,5.394700e-03,4.088300e-03,5.839400e-01,1.564200e-02, & - &1.438500e-02,1.330700e-02,1.236600e-02,1.105800e-02,9.658500e-03, & - &8.379500e-03,6.635300e-03,5.676900e-01,2.167500e-02,2.000100e-02, & - &1.876400e-02,1.748800e-02,1.570400e-02,1.382800e-02,1.204500e-02, & - &1.008000e-02,5.525500e-01,2.864700e-02,2.666500e-02,2.551400e-02, & - &2.360300e-02,2.125700e-02,1.896600e-02,1.677800e-02,1.483700e-02, & - &5.408800e-01,3.651300e-02,3.428200e-02,3.314000e-02,3.075100e-02, & - &2.794100e-02,2.543000e-02,2.280300e-02,2.131200e-02,5.315500e-01, & - &1.076000e-02,9.916500e-03,9.210700e-03,8.443100e-03,7.504300e-03, & - &6.421900e-03,5.332200e-03,3.994200e-03,8.057400e-01,1.571800e-02, & - &1.457900e-02,1.358000e-02,1.260300e-02,1.124000e-02,9.711800e-03, & - &8.148900e-03,6.554000e-03,7.854600e-01,2.170900e-02,2.024400e-02, & - &1.919600e-02,1.778800e-02,1.593200e-02,1.384700e-02,1.172400e-02, & - &9.812200e-03,7.674700e-01,2.859000e-02,2.685500e-02,2.588800e-02, & - &2.397400e-02,2.161000e-02,1.903100e-02,1.648100e-02,1.441900e-02, & - &7.529000e-01,3.624300e-02,3.452400e-02,3.351800e-02,3.114600e-02, & - &2.858900e-02,2.541600e-02,2.235800e-02,2.040000e-02,7.435900e-01/ - data absa(1:270,12) / & - &5.623100e-02,4.924500e-02,4.243700e-02,3.937700e-02,3.618300e-02, & - &3.214000e-02,3.242300e-02,3.152300e-02,4.675000e-02,6.614800e-02, & - &5.797800e-02,5.104100e-02,4.810400e-02,4.391200e-02,4.167700e-02, & - &4.381700e-02,4.443700e-02,6.258400e-02,7.624400e-02,6.685400e-02, & - &6.148800e-02,5.717300e-02,5.254000e-02,5.287500e-02,5.710300e-02, & - &5.870800e-02,8.076300e-02,8.631000e-02,7.572800e-02,7.213000e-02, & - &6.681700e-02,6.253000e-02,6.525700e-02,7.235400e-02,7.482300e-02, & - &1.029100e-01,9.617200e-02,8.453200e-02,8.258600e-02,7.662400e-02, & - &7.409600e-02,7.988900e-02,9.021500e-02,9.589200e-02,1.276500e-01, & - &5.447100e-02,4.772700e-02,4.133700e-02,3.905600e-02,3.520100e-02, & - &3.168800e-02,3.148300e-02,3.139000e-02,4.412100e-02,6.476100e-02, & - &5.676700e-02,5.047200e-02,4.784300e-02,4.331600e-02,4.142500e-02, & - &4.228800e-02,4.388700e-02,5.902000e-02,7.527800e-02,6.600600e-02, & - &6.089200e-02,5.703600e-02,5.251000e-02,5.258900e-02,5.497300e-02, & - &5.808200e-02,7.674700e-02,8.581400e-02,7.527200e-02,7.165300e-02, & - &6.675200e-02,6.277100e-02,6.516900e-02,7.035000e-02,7.434500e-02, & - &9.874800e-02,9.621400e-02,8.471100e-02,8.253400e-02,7.668800e-02, & - &7.532000e-02,7.951300e-02,8.844300e-02,9.332600e-02,1.239300e-01, & - &5.024000e-02,4.401800e-02,3.853700e-02,3.619000e-02,3.272700e-02, & - &2.926500e-02,2.871800e-02,2.853900e-02,3.854500e-02,6.070000e-02, & - &5.319400e-02,4.769600e-02,4.484900e-02,4.092300e-02,3.840000e-02, & - &3.869900e-02,3.963500e-02,5.269100e-02,7.144600e-02,6.259900e-02, & - &5.776300e-02,5.424300e-02,5.020700e-02,4.918700e-02,5.005200e-02, & - &5.347100e-02,6.925800e-02,8.228900e-02,7.209500e-02,6.841600e-02, & - &6.434400e-02,6.044700e-02,6.124100e-02,6.389100e-02,6.926400e-02, & - &8.956000e-02,9.305200e-02,8.180700e-02,7.912900e-02,7.468600e-02, & - &7.246100e-02,7.587900e-02,8.126200e-02,8.819700e-02,1.130900e-01, & - &4.502800e-02,3.943500e-02,3.533400e-02,3.258000e-02,2.972700e-02, & - &2.638300e-02,2.527900e-02,2.424900e-02,3.283600e-02,5.534000e-02, & - &4.846300e-02,4.423400e-02,4.096500e-02,3.751100e-02,3.470900e-02, & - &3.461700e-02,3.457800e-02,4.599700e-02,6.618300e-02,5.796300e-02, & - &5.392400e-02,5.042500e-02,4.657600e-02,4.493300e-02,4.542700e-02, & - &4.705400e-02,6.172600e-02,7.728300e-02,6.768500e-02,6.440800e-02, & - &6.062000e-02,5.668900e-02,5.667500e-02,5.799400e-02,6.167900e-02, & - &8.086600e-02,8.841800e-02,7.806100e-02,7.514000e-02,7.115500e-02, & - &6.811900e-02,7.086100e-02,7.368300e-02,7.950300e-02,1.028500e-01, & - &3.966200e-02,3.473100e-02,3.164400e-02,2.893800e-02,2.674500e-02, & - &2.326800e-02,2.182500e-02,2.047600e-02,2.739200e-02,4.979500e-02, & - &4.359700e-02,4.042400e-02,3.707600e-02,3.419400e-02,3.102100e-02, & - &3.062300e-02,2.956200e-02,3.949200e-02,6.058400e-02,5.304200e-02, & - &4.989400e-02,4.628900e-02,4.281700e-02,4.088400e-02,4.118100e-02, & - &4.131400e-02,5.408300e-02,7.181000e-02,6.297000e-02,6.028800e-02, & - &5.661100e-02,5.241700e-02,5.236400e-02,5.344700e-02,5.473300e-02, & - &7.189500e-02,8.319100e-02,7.369300e-02,7.113600e-02,6.717500e-02, & - &6.330300e-02,6.579400e-02,6.804700e-02,7.116700e-02,9.309900e-02, & - &3.407300e-02,2.997000e-02,2.744800e-02,2.518700e-02,2.323800e-02, & - &2.015100e-02,1.835600e-02,1.708700e-02,2.182500e-02,4.380500e-02, & - &3.854000e-02,3.580900e-02,3.298900e-02,3.018300e-02,2.706600e-02, & - &2.646000e-02,2.524100e-02,3.226600e-02,5.440800e-02,4.782700e-02, & - &4.495900e-02,4.183200e-02,3.841200e-02,3.615600e-02,3.661600e-02, & - &3.563000e-02,4.529900e-02,6.556600e-02,5.773800e-02,5.499600e-02, & - &5.193800e-02,4.775300e-02,4.743500e-02,4.855900e-02,4.824400e-02, & - &6.146700e-02,7.705500e-02,6.863500e-02,6.583000e-02,6.240400e-02, & - &5.837100e-02,6.064000e-02,6.255300e-02,6.341000e-02,8.173400e-02/ - data absa(271:585,12) / & - &2.870300e-02,2.558300e-02,2.327600e-02,2.169700e-02,1.974700e-02, & - &1.708900e-02,1.507200e-02,1.383500e-02,1.688300e-02,3.793500e-02, & - &3.372800e-02,3.117300e-02,2.904700e-02,2.630400e-02,2.325400e-02, & - &2.249500e-02,2.123300e-02,2.525800e-02,4.810900e-02,4.273300e-02, & - &3.987500e-02,3.741100e-02,3.422100e-02,3.172700e-02,3.201300e-02, & - &3.095400e-02,3.622800e-02,5.901500e-02,5.271200e-02,4.972400e-02, & - &4.709800e-02,4.320100e-02,4.239600e-02,4.342000e-02,4.282100e-02, & - &5.032200e-02,7.056200e-02,6.376500e-02,6.064700e-02,5.732400e-02, & - &5.358100e-02,5.493200e-02,5.675000e-02,5.686100e-02,6.864800e-02, & - &2.379700e-02,2.150700e-02,1.948100e-02,1.832800e-02,1.656700e-02, & - &1.419500e-02,1.222600e-02,1.108400e-02,1.276900e-02,3.229000e-02, & - &2.913200e-02,2.678700e-02,2.515400e-02,2.269800e-02,1.978900e-02, & - &1.873800e-02,1.766800e-02,1.952300e-02,4.197100e-02,3.780900e-02, & - &3.515300e-02,3.303900e-02,3.022700e-02,2.755000e-02,2.740300e-02, & - &2.663300e-02,2.835600e-02,5.264300e-02,4.771100e-02,4.477600e-02, & - &4.238200e-02,3.894100e-02,3.716000e-02,3.796200e-02,3.766000e-02, & - &4.006700e-02,6.412000e-02,5.865700e-02,5.570700e-02,5.273500e-02, & - &4.898900e-02,4.878900e-02,5.047200e-02,5.059800e-02,5.595300e-02, & - &1.925000e-02,1.758800e-02,1.604200e-02,1.514600e-02,1.363100e-02, & - &1.168600e-02,9.985800e-03,8.667700e-03,2.170700e-02,2.701200e-02, & - &2.459500e-02,2.280900e-02,2.136900e-02,1.922600e-02,1.677600e-02, & - &1.529200e-02,1.442500e-02,2.436600e-02,3.605700e-02,3.281000e-02, & - &3.075600e-02,2.882000e-02,2.628700e-02,2.367700e-02,2.269200e-02, & - &2.233400e-02,2.780900e-02,4.627600e-02,4.232300e-02,4.004100e-02, & - &3.777800e-02,3.489500e-02,3.212200e-02,3.205700e-02,3.216300e-02, & - &3.377300e-02,5.728700e-02,5.292800e-02,5.054500e-02,4.812400e-02, & - &4.444200e-02,4.224900e-02,4.333400e-02,4.406700e-02,4.571400e-02, & - &1.572400e-02,1.448000e-02,1.339900e-02,1.260700e-02,1.137100e-02, & - &9.875600e-03,8.220200e-03,7.092000e-03,1.532700e-01,2.274200e-02, & - &2.083900e-02,1.964800e-02,1.833000e-02,1.647200e-02,1.461500e-02, & - &1.279400e-02,1.218500e-02,1.510700e-01,3.111100e-02,2.852600e-02, & - &2.713700e-02,2.531300e-02,2.323600e-02,2.066400e-02,1.895200e-02, & - &1.878200e-02,1.505700e-01,4.063700e-02,3.754900e-02,3.592200e-02, & - &3.397800e-02,3.165200e-02,2.813200e-02,2.700600e-02,2.731900e-02, & - &1.520700e-01,5.122700e-02,4.769900e-02,4.606900e-02,4.417000e-02, & - &4.089100e-02,3.722500e-02,3.706000e-02,3.807100e-02,1.540900e-01, & - &1.555500e-02,1.424100e-02,1.340400e-02,1.254100e-02,1.136000e-02, & - &1.001200e-02,8.334200e-03,7.352300e-03,4.165800e-01,2.256900e-02, & - &2.061900e-02,1.962900e-02,1.821700e-02,1.671300e-02,1.492300e-02, & - &1.279900e-02,1.233700e-02,4.053100e-01,3.100300e-02,2.841400e-02, & - &2.710100e-02,2.543800e-02,2.380300e-02,2.099300e-02,1.871600e-02, & - &1.868600e-02,3.947400e-01,4.072200e-02,3.754300e-02,3.590800e-02, & - &3.457000e-02,3.216800e-02,2.835600e-02,2.622700e-02,2.684800e-02, & - &3.883100e-01,5.156000e-02,4.778300e-02,4.637600e-02,4.506100e-02, & - &4.167000e-02,3.732800e-02,3.596500e-02,3.725100e-02,3.812500e-01, & - &1.583000e-02,1.438700e-02,1.351600e-02,1.241800e-02,1.134600e-02, & - &1.007900e-02,8.372900e-03,7.347200e-03,7.194200e-01,2.305500e-02, & - &2.096200e-02,1.973800e-02,1.814400e-02,1.692900e-02,1.506700e-02, & - &1.270200e-02,1.195500e-02,6.977200e-01,3.184700e-02,2.908100e-02, & - &2.732200e-02,2.561200e-02,2.394000e-02,2.130300e-02,1.848100e-02, & - &1.818100e-02,6.768700e-01,4.196100e-02,3.841300e-02,3.638800e-02, & - &3.488600e-02,3.223600e-02,2.880800e-02,2.579700e-02,2.607700e-02, & - &6.560300e-01,5.331900e-02,4.911700e-02,4.716900e-02,4.523600e-02, & - &4.194300e-02,3.787300e-02,3.535500e-02,3.641200e-02,6.419000e-01, & - &1.649500e-02,1.490900e-02,1.382500e-02,1.254400e-02,1.134000e-02, & - &9.997500e-03,8.343300e-03,7.054600e-03,9.991100e-01,2.410900e-02, & - &2.188500e-02,2.021000e-02,1.848800e-02,1.693600e-02,1.495300e-02, & - &1.266000e-02,1.146700e-02,9.698400e-01,3.322000e-02,3.029600e-02, & - &2.808300e-02,2.618500e-02,2.386000e-02,2.122300e-02,1.834600e-02, & - &1.743700e-02,9.388800e-01,4.383100e-02,4.015800e-02,3.769700e-02, & - &3.528500e-02,3.211600e-02,2.888100e-02,2.560200e-02,2.516400e-02, & - &9.080800e-01,5.567700e-02,5.136800e-02,4.892300e-02,4.570200e-02, & - &4.183200e-02,3.847000e-02,3.531800e-02,3.564600e-02,8.846500e-01/ - data absa(1:270,13) / & - &7.250600e-02,6.344600e-02,5.440800e-02,4.748300e-02,4.238200e-02, & - &4.123900e-02,4.338600e-02,4.407400e-02,6.427100e-02,8.446500e-02, & - &7.395300e-02,6.342700e-02,5.690000e-02,5.237600e-02,5.364800e-02, & - &5.835400e-02,5.910100e-02,8.658300e-02,9.644400e-02,8.443900e-02, & - &7.306300e-02,6.760100e-02,6.542900e-02,6.947400e-02,7.781700e-02, & - &8.120400e-02,1.141300e-01,1.083300e-01,9.486400e-02,8.527800e-02, & - &7.967300e-02,8.108900e-02,9.136700e-02,1.043400e-01,1.117700e-01, & - &1.490400e-01,1.198000e-01,1.049300e-01,9.640600e-02,9.478300e-02, & - &1.013200e-01,1.197100e-01,1.380900e-01,1.496400e-01,1.937500e-01, & - &7.147800e-02,6.257000e-02,5.366400e-02,4.675400e-02,4.268100e-02, & - &4.115600e-02,4.200800e-02,4.248300e-02,6.295900e-02,8.424700e-02, & - &7.374700e-02,6.324900e-02,5.623300e-02,5.353400e-02,5.372700e-02, & - &5.746800e-02,5.817800e-02,8.632800e-02,9.681200e-02,8.474700e-02, & - &7.411600e-02,6.750800e-02,6.678100e-02,6.998300e-02,7.676700e-02, & - &7.785200e-02,1.148500e-01,1.088700e-01,9.529700e-02,8.610800e-02, & - &8.075400e-02,8.291900e-02,8.896700e-02,1.001300e-01,1.049600e-01, & - &1.473800e-01,1.204000e-01,1.054400e-01,9.826200e-02,9.702400e-02, & - &1.012800e-01,1.138900e-01,1.304700e-01,1.412600e-01,1.881000e-01, & - &6.742800e-02,5.901200e-02,5.060000e-02,4.482000e-02,4.028400e-02, & - &3.890500e-02,3.843300e-02,3.822100e-02,5.769500e-02,8.009700e-02, & - &7.009200e-02,6.023100e-02,5.456000e-02,5.123800e-02,5.142700e-02, & - &5.263500e-02,5.359900e-02,7.987300e-02,9.283500e-02,8.128800e-02, & - &7.130300e-02,6.578800e-02,6.516800e-02,6.719600e-02,7.168900e-02, & - &7.264100e-02,1.077100e-01,1.055900e-01,9.248000e-02,8.329900e-02, & - &7.861600e-02,8.167800e-02,8.588200e-02,9.431800e-02,9.625900e-02, & - &1.404300e-01,1.182400e-01,1.035800e-01,9.645500e-02,9.506600e-02, & - &9.997200e-02,1.074700e-01,1.201200e-01,1.267600e-01,1.781600e-01, & - &6.157400e-02,5.389300e-02,4.622100e-02,4.158100e-02,3.701100e-02, & - &3.613500e-02,3.557300e-02,3.437100e-02,5.032000e-02,7.446900e-02, & - &6.519600e-02,5.607300e-02,5.135300e-02,4.782100e-02,4.797100e-02, & - &4.810400e-02,4.815100e-02,7.059800e-02,8.789300e-02,7.696900e-02, & - &6.738000e-02,6.277800e-02,6.174500e-02,6.332700e-02,6.525100e-02, & - &6.660500e-02,9.668800e-02,1.012800e-01,8.866600e-02,7.955800e-02, & - &7.611300e-02,7.871100e-02,8.206700e-02,8.711800e-02,8.968500e-02, & - &1.273400e-01,1.139700e-01,9.979100e-02,9.309500e-02,9.235800e-02, & - &9.781700e-02,1.028300e-01,1.127100e-01,1.161500e-01,1.639400e-01, & - &5.564400e-02,4.870600e-02,4.204200e-02,3.773000e-02,3.381600e-02, & - &3.329600e-02,3.256700e-02,3.130700e-02,4.285200e-02,6.870000e-02, & - &6.014500e-02,5.207800e-02,4.746500e-02,4.425700e-02,4.454200e-02, & - &4.390400e-02,4.355500e-02,6.139700e-02,8.207900e-02,7.184200e-02, & - &6.333600e-02,5.882600e-02,5.777100e-02,5.915000e-02,5.961500e-02, & - &6.027600e-02,8.521300e-02,9.539500e-02,8.350900e-02,7.549100e-02, & - &7.242800e-02,7.461500e-02,7.732300e-02,7.969700e-02,8.237500e-02, & - &1.140800e-01,1.087900e-01,9.522400e-02,8.900800e-02,8.913900e-02, & - &9.427700e-02,9.816200e-02,1.034700e-01,1.093800e-01,1.485000e-01, & - &4.916600e-02,4.303200e-02,3.769700e-02,3.341800e-02,3.027100e-02, & - &2.970700e-02,2.873900e-02,2.710700e-02,3.518000e-02,6.180200e-02, & - &5.409100e-02,4.758500e-02,4.291200e-02,4.033500e-02,4.031000e-02, & - &3.936000e-02,3.819400e-02,5.159000e-02,7.493300e-02,6.558300e-02, & - &5.874300e-02,5.392500e-02,5.304100e-02,5.410600e-02,5.382500e-02, & - &5.372500e-02,7.386500e-02,8.879400e-02,7.771400e-02,7.089200e-02, & - &6.726600e-02,6.941100e-02,7.160200e-02,7.216700e-02,7.419800e-02, & - &1.007200e-01,1.028400e-01,9.001900e-02,8.434600e-02,8.369700e-02, & - &8.885300e-02,9.161800e-02,9.409500e-02,9.949300e-02,1.320000e-01/ - data absa(271:585,13) / & - &4.248100e-02,3.718200e-02,3.294100e-02,2.905300e-02,2.672900e-02, & - &2.585700e-02,2.481700e-02,2.303600e-02,2.851300e-02,5.464600e-02, & - &4.782900e-02,4.249300e-02,3.826000e-02,3.617900e-02,3.584300e-02, & - &3.467500e-02,3.309000e-02,4.306100e-02,6.794900e-02,5.947300e-02, & - &5.362900e-02,4.899700e-02,4.796000e-02,4.851700e-02,4.798000e-02, & - &4.668600e-02,6.322500e-02,8.201100e-02,7.177500e-02,6.563800e-02, & - &6.177900e-02,6.345700e-02,6.498900e-02,6.542000e-02,6.533800e-02, & - &8.811400e-02,9.612100e-02,8.411800e-02,7.908000e-02,7.784000e-02, & - &8.209900e-02,8.473300e-02,8.601300e-02,8.916500e-02,1.178200e-01, & - &3.613700e-02,3.165800e-02,2.823200e-02,2.497400e-02,2.311800e-02, & - &2.208800e-02,2.106400e-02,1.937600e-02,2.274500e-02,4.801600e-02, & - &4.207600e-02,3.750400e-02,3.378900e-02,3.193100e-02,3.121800e-02, & - &3.007700e-02,2.814400e-02,3.523200e-02,6.120500e-02,5.366800e-02, & - &4.837300e-02,4.414500e-02,4.276600e-02,4.300100e-02,4.223400e-02, & - &4.033200e-02,5.327600e-02,7.502500e-02,6.580100e-02,6.017600e-02, & - &5.641000e-02,5.712500e-02,5.870300e-02,5.872100e-02,5.739400e-02, & - &7.614100e-02,8.958800e-02,7.861400e-02,7.326500e-02,7.160900e-02, & - &7.494400e-02,7.784500e-02,7.881700e-02,7.923400e-02,1.040600e-01, & - &3.035400e-02,2.681200e-02,2.380600e-02,2.119000e-02,1.944500e-02, & - &1.824000e-02,1.730000e-02,1.597000e-02,2.746900e-02,4.168300e-02, & - &3.682800e-02,3.267900e-02,2.962200e-02,2.758600e-02,2.637700e-02, & - &2.539600e-02,2.378100e-02,3.198500e-02,5.443100e-02,4.810700e-02, & - &4.319200e-02,3.952900e-02,3.762400e-02,3.719500e-02,3.660700e-02, & - &3.452400e-02,4.434000e-02,6.832100e-02,6.039100e-02,5.461000e-02, & - &5.121100e-02,5.061500e-02,5.193800e-02,5.220600e-02,5.000200e-02, & - &6.437600e-02,8.338200e-02,7.386400e-02,6.760800e-02,6.541600e-02, & - &6.779600e-02,7.054400e-02,7.158100e-02,7.036700e-02,8.982000e-02, & - &2.586600e-02,2.309600e-02,2.035900e-02,1.824400e-02,1.655500e-02, & - &1.524100e-02,1.453700e-02,1.319700e-02,1.820700e-01,3.659700e-02, & - &3.265900e-02,2.889900e-02,2.626200e-02,2.404600e-02,2.244900e-02, & - &2.177400e-02,2.025100e-02,1.826900e-01,4.899000e-02,4.368800e-02, & - &3.909400e-02,3.582700e-02,3.327700e-02,3.259200e-02,3.223400e-02, & - &3.048000e-02,1.833700e-01,6.303100e-02,5.615000e-02,5.061400e-02, & - &4.709800e-02,4.529500e-02,4.657300e-02,4.697400e-02,4.510700e-02, & - &1.852600e-01,7.833700e-02,7.003600e-02,6.390700e-02,6.087500e-02, & - &6.158800e-02,6.440400e-02,6.557400e-02,6.403800e-02,1.900900e-01, & - &2.617000e-02,2.354700e-02,2.083500e-02,1.882500e-02,1.688900e-02, & - &1.540100e-02,1.472700e-02,1.361400e-02,5.081800e-01,3.708700e-02, & - &3.331500e-02,2.985800e-02,2.715100e-02,2.445000e-02,2.283300e-02, & - &2.240400e-02,2.100100e-02,5.010300e-01,4.996300e-02,4.483700e-02, & - &4.062500e-02,3.704400e-02,3.413500e-02,3.357400e-02,3.360200e-02, & - &3.209000e-02,4.919400e-01,6.451600e-02,5.797700e-02,5.320600e-02, & - &4.893700e-02,4.727200e-02,4.844800e-02,4.919200e-02,4.787000e-02, & - &4.832300e-01,8.035700e-02,7.281000e-02,6.742300e-02,6.384600e-02, & - &6.406300e-02,6.680500e-02,6.845800e-02,6.769300e-02,4.822400e-01, & - &2.638200e-02,2.386900e-02,2.142300e-02,1.953000e-02,1.727600e-02, & - &1.559700e-02,1.485200e-02,1.392600e-02,8.861300e-01,3.755400e-02, & - &3.391100e-02,3.098900e-02,2.811400e-02,2.505100e-02,2.335900e-02, & - &2.299400e-02,2.200500e-02,8.712200e-01,5.068900e-02,4.583500e-02, & - &4.237200e-02,3.863900e-02,3.552400e-02,3.447000e-02,3.475200e-02, & - &3.378900e-02,8.529700e-01,6.561100e-02,5.969200e-02,5.567700e-02, & - &5.155500e-02,4.958700e-02,4.944100e-02,5.043600e-02,4.992600e-02, & - &8.344500e-01,8.201200e-02,7.523900e-02,7.100400e-02,6.770100e-02, & - &6.670700e-02,6.791500e-02,6.991500e-02,7.029400e-02,8.192000e-01, & - &2.641100e-02,2.400100e-02,2.200300e-02,2.009800e-02,1.778300e-02, & - &1.591000e-02,1.492100e-02,1.426600e-02,1.249900e+00,3.772800e-02, & - &3.423500e-02,3.189000e-02,2.906900e-02,2.605100e-02,2.413700e-02, & - &2.343100e-02,2.276300e-02,1.223300e+00,5.116800e-02,4.658200e-02, & - &4.372500e-02,4.029600e-02,3.735600e-02,3.554200e-02,3.523100e-02, & - &3.485000e-02,1.197000e+00,6.653200e-02,6.102300e-02,5.767800e-02, & - &5.465800e-02,5.190600e-02,5.020200e-02,5.047700e-02,5.091100e-02, & - &1.170200e+00,8.371300e-02,7.724600e-02,7.418600e-02,7.195600e-02, & - &6.931100e-02,6.813800e-02,6.947200e-02,7.108000e-02,1.142700e+00/ - data absa(1:270,14) / & - &8.440600e-02,7.392300e-02,6.339000e-02,5.366600e-02,5.295600e-02, & - &5.547200e-02,6.063400e-02,5.881300e-02,9.287700e-02,9.837300e-02, & - &8.610900e-02,7.383600e-02,6.754900e-02,6.943100e-02,7.773900e-02, & - &8.643800e-02,8.538800e-02,1.300500e-01,1.122000e-01,9.822700e-02, & - &8.423700e-02,8.612700e-02,9.355800e-02,1.100700e-01,1.229800e-01, & - &1.212000e-01,1.851900e-01,1.258900e-01,1.102100e-01,9.734100e-02, & - &1.080500e-01,1.270200e-01,1.518100e-01,1.689800e-01,1.666400e-01, & - &2.557000e-01,1.389800e-01,1.216700e-01,1.179000e-01,1.353800e-01, & - &1.693600e-01,2.014700e-01,2.246800e-01,2.190100e-01,3.420000e-01, & - &8.696500e-02,7.612200e-02,6.527100e-02,5.592900e-02,5.526600e-02, & - &5.641200e-02,6.116200e-02,5.908400e-02,9.414500e-02,1.021400e-01, & - &8.940400e-02,7.667000e-02,7.102600e-02,7.115200e-02,7.643800e-02, & - &8.431900e-02,8.319800e-02,1.289700e-01,1.175800e-01,1.029400e-01, & - &8.830000e-02,9.030100e-02,9.355200e-02,1.059200e-01,1.188700e-01, & - &1.201700e-01,1.797400e-01,1.332100e-01,1.166500e-01,1.042300e-01, & - &1.137000e-01,1.250500e-01,1.486000e-01,1.671500e-01,1.678400e-01, & - &2.504600e-01,1.486500e-01,1.302000e-01,1.266600e-01,1.395300e-01, & - &1.668200e-01,2.005800e-01,2.255300e-01,2.256500e-01,3.389900e-01, & - &8.607900e-02,7.534000e-02,6.460700e-02,5.545600e-02,5.527200e-02, & - &5.523300e-02,5.826700e-02,5.678300e-02,8.946400e-02,1.030400e-01, & - &9.020500e-02,7.734800e-02,7.051900e-02,7.086200e-02,7.239000e-02, & - &7.879100e-02,7.722900e-02,1.213200e-01,1.205000e-01,1.055000e-01, & - &9.062800e-02,8.968600e-02,9.057800e-02,9.725100e-02,1.083200e-01, & - &1.085700e-01,1.657000e-01,1.379800e-01,1.208100e-01,1.075700e-01, & - &1.136600e-01,1.177100e-01,1.340400e-01,1.511400e-01,1.544600e-01, & - &2.277900e-01,1.552700e-01,1.359400e-01,1.304900e-01,1.406500e-01, & - &1.549800e-01,1.834700e-01,2.092800e-01,2.135700e-01,3.105600e-01, & - &8.365800e-02,7.321900e-02,6.278200e-02,5.442100e-02,5.425200e-02, & - &5.237300e-02,5.287200e-02,5.324900e-02,8.176000e-02,1.017900e-01, & - &8.908400e-02,7.637200e-02,6.932200e-02,6.964600e-02,6.929100e-02, & - &7.279900e-02,7.237000e-02,1.130200e-01,1.205500e-01,1.055300e-01, & - &9.092500e-02,8.815800e-02,8.899700e-02,9.083500e-02,9.877600e-02, & - &9.875200e-02,1.526900e-01,1.397600e-01,1.223900e-01,1.087200e-01, & - &1.112000e-01,1.130400e-01,1.213600e-01,1.354500e-01,1.372000e-01, & - &2.065000e-01,1.596400e-01,1.398400e-01,1.315400e-01,1.387000e-01, & - &1.442800e-01,1.640500e-01,1.857800e-01,1.937100e-01,2.791000e-01, & - &7.961300e-02,6.966700e-02,5.973500e-02,5.289000e-02,5.167200e-02, & - &4.963100e-02,4.798300e-02,4.789100e-02,7.372100e-02,9.844400e-02, & - &8.616500e-02,7.387900e-02,6.800400e-02,6.790600e-02,6.576000e-02, & - &6.682000e-02,6.709500e-02,1.026300e-01,1.187400e-01,1.039300e-01, & - &8.965300e-02,8.676900e-02,8.704800e-02,8.678100e-02,9.170500e-02, & - &9.150300e-02,1.415900e-01,1.400900e-01,1.226600e-01,1.083400e-01, & - &1.095400e-01,1.108300e-01,1.137200e-01,1.236100e-01,1.249600e-01, & - &1.919200e-01,1.619100e-01,1.417900e-01,1.313200e-01,1.366400e-01, & - &1.396200e-01,1.500900e-01,1.680200e-01,1.724600e-01,2.560200e-01, & - &7.332100e-02,6.417300e-02,5.511500e-02,5.004700e-02,4.800300e-02, & - &4.572900e-02,4.341300e-02,4.215700e-02,6.511000e-02,9.295200e-02, & - &8.135500e-02,6.997600e-02,6.525700e-02,6.456100e-02,6.201400e-02, & - &6.059400e-02,6.065500e-02,9.173100e-02,1.143900e-01,1.001400e-01, & - &8.657500e-02,8.391200e-02,8.378600e-02,8.227900e-02,8.355000e-02, & - &8.420100e-02,1.274000e-01,1.370300e-01,1.199700e-01,1.060100e-01, & - &1.065200e-01,1.071500e-01,1.079200e-01,1.140700e-01,1.144700e-01, & - &1.757000e-01,1.604700e-01,1.404800e-01,1.294800e-01,1.338200e-01, & - &1.357100e-01,1.407200e-01,1.534600e-01,1.555700e-01,2.367400e-01/ - data absa(271:585,14) / & - &6.609600e-02,5.784000e-02,5.029100e-02,4.625500e-02,4.374900e-02, & - &4.134600e-02,3.923700e-02,3.718700e-02,5.658100e-02,8.599700e-02, & - &7.527200e-02,6.556400e-02,6.146400e-02,6.008400e-02,5.756600e-02, & - &5.530500e-02,5.441500e-02,8.105200e-02,1.079200e-01,9.446300e-02, & - &8.274600e-02,8.023100e-02,7.965600e-02,7.751900e-02,7.624300e-02, & - &7.663600e-02,1.137600e-01,1.314700e-01,1.150800e-01,1.028900e-01, & - &1.028100e-01,1.032100e-01,1.026700e-01,1.042800e-01,1.061800e-01, & - &1.583100e-01,1.565800e-01,1.370900e-01,1.264800e-01,1.296400e-01, & - &1.318600e-01,1.345800e-01,1.424600e-01,1.435200e-01,2.165600e-01, & - &5.840000e-02,5.110300e-02,4.516800e-02,4.194800e-02,3.925300e-02, & - &3.702000e-02,3.537000e-02,3.229000e-02,4.866300e-02,7.800500e-02, & - &6.826800e-02,6.045300e-02,5.709600e-02,5.490500e-02,5.311700e-02, & - &5.073200e-02,4.889100e-02,7.110100e-02,9.999100e-02,8.751600e-02, & - &7.801900e-02,7.586800e-02,7.462100e-02,7.246300e-02,7.030400e-02, & - &6.956900e-02,1.010400e-01,1.241000e-01,1.086400e-01,9.848900e-02, & - &9.856400e-02,9.809400e-02,9.683300e-02,9.602200e-02,9.683000e-02, & - &1.419300e-01,1.496800e-01,1.310300e-01,1.222700e-01,1.249100e-01, & - &1.271000e-01,1.281100e-01,1.309300e-01,1.335100e-01,1.961000e-01, & - &5.039700e-02,4.409300e-02,3.968300e-02,3.694600e-02,3.457400e-02, & - &3.278400e-02,3.119000e-02,2.778500e-02,4.293800e-02,6.919200e-02, & - &6.055800e-02,5.459400e-02,5.161600e-02,4.951300e-02,4.843200e-02, & - &4.630800e-02,4.323200e-02,6.115000e-02,9.068400e-02,7.936400e-02, & - &7.192800e-02,7.006200e-02,6.884000e-02,6.729300e-02,6.500500e-02, & - &6.260800e-02,8.844300e-02,1.146000e-01,1.002800e-01,9.256900e-02, & - &9.269500e-02,9.196000e-02,9.080800e-02,8.890300e-02,8.787500e-02, & - &1.261800e-01,1.402900e-01,1.227800e-01,1.165800e-01,1.192700e-01, & - &1.203300e-01,1.208600e-01,1.210100e-01,1.221400e-01,1.768300e-01, & - &4.371700e-02,3.827800e-02,3.508000e-02,3.270100e-02,3.071600e-02, & - &2.934200e-02,2.768400e-02,2.447000e-02,2.200900e-01,6.147600e-02, & - &5.386600e-02,4.931900e-02,4.696000e-02,4.525900e-02,4.447800e-02, & - &4.257700e-02,3.925100e-02,2.196300e-01,8.238500e-02,7.223400e-02, & - &6.644500e-02,6.496200e-02,6.437100e-02,6.318000e-02,6.093100e-02, & - &5.743800e-02,2.224200e-01,1.059900e-01,9.300000e-02,8.706500e-02, & - &8.733900e-02,8.728600e-02,8.639600e-02,8.433400e-02,8.129700e-02, & - &2.273000e-01,1.319400e-01,1.158000e-01,1.112400e-01,1.141100e-01, & - &1.153300e-01,1.161200e-01,1.151500e-01,1.141400e-01,2.390600e-01, & - &4.441400e-02,3.912400e-02,3.627600e-02,3.419200e-02,3.270900e-02, & - &3.175700e-02,3.027200e-02,2.727400e-02,6.092300e-01,6.279200e-02, & - &5.534900e-02,5.117500e-02,4.944200e-02,4.878000e-02,4.806800e-02, & - &4.610600e-02,4.278900e-02,6.086200e-01,8.449800e-02,7.452200e-02, & - &6.955300e-02,6.896300e-02,6.910600e-02,6.825300e-02,6.604400e-02, & - &6.233800e-02,6.054500e-01,1.092900e-01,9.640600e-02,9.154300e-02, & - &9.318900e-02,9.364700e-02,9.357400e-02,9.173500e-02,8.825300e-02, & - &5.992200e-01,1.368600e-01,1.206700e-01,1.176600e-01,1.216700e-01, & - &1.245600e-01,1.265200e-01,1.256100e-01,1.239700e-01,5.985600e-01, & - &4.528600e-02,4.019400e-02,3.749800e-02,3.542600e-02,3.472000e-02, & - &3.406400e-02,3.255600e-02,2.960500e-02,1.089900e+00,6.448400e-02, & - &5.725600e-02,5.332100e-02,5.176000e-02,5.195400e-02,5.138600e-02, & - &4.916600e-02,4.558800e-02,1.090900e+00,8.723900e-02,7.740900e-02, & - &7.302100e-02,7.264100e-02,7.336300e-02,7.292300e-02,7.051000e-02, & - &6.653800e-02,1.083700e+00,1.132500e-01,1.004400e-01,9.653200e-02, & - &9.796000e-02,9.971500e-02,1.006100e-01,9.895300e-02,9.507000e-02, & - &1.071400e+00,1.421500e-01,1.262000e-01,1.247600e-01,1.285800e-01, & - &1.334500e-01,1.364500e-01,1.363700e-01,1.337400e-01,1.056300e+00, & - &4.657000e-02,4.167800e-02,3.872500e-02,3.671700e-02,3.639400e-02, & - &3.594600e-02,3.437600e-02,3.145400e-02,1.589500e+00,6.649800e-02, & - &5.946200e-02,5.566000e-02,5.410100e-02,5.446700e-02,5.378800e-02, & - &5.164800e-02,4.804600e-02,1.584900e+00,9.036400e-02,8.070000e-02, & - &7.657700e-02,7.613500e-02,7.684900e-02,7.675300e-02,7.463000e-02, & - &7.042000e-02,1.569800e+00,1.179000e-01,1.051900e-01,1.019500e-01, & - &1.024800e-01,1.053200e-01,1.071400e-01,1.060300e-01,1.017100e-01, & - &1.549200e+00,1.487400e-01,1.332100e-01,1.318900e-01,1.352000e-01, & - &1.417500e-01,1.462900e-01,1.473500e-01,1.439500e-01,1.522800e+00/ - data absa(1:270,15) / & - &1.113100e-01,9.743400e-02,8.353900e-02,6.967300e-02,6.454200e-02, & - &7.490700e-02,8.061000e-02,7.459200e-02,1.298300e-01,1.294800e-01, & - &1.133400e-01,9.720100e-02,8.164700e-02,9.021400e-02,1.053500e-01, & - &1.130800e-01,1.039900e-01,1.847300e-01,1.476500e-01,1.292500e-01, & - &1.110300e-01,1.005900e-01,1.246700e-01,1.456600e-01,1.561500e-01, & - &1.435800e-01,2.554800e-01,1.655100e-01,1.449000e-01,1.242100e-01, & - &1.337600e-01,1.698800e-01,1.983600e-01,2.129600e-01,1.975400e-01, & - &3.483000e-01,1.829500e-01,1.601500e-01,1.443000e-01,1.825000e-01, & - &2.325200e-01,2.730400e-01,2.965800e-01,2.798300e-01,4.775900e-01, & - &1.222900e-01,1.069800e-01,9.175200e-02,7.648000e-02,6.817900e-02, & - &7.632400e-02,8.259500e-02,7.695700e-02,1.349000e-01,1.432400e-01, & - &1.253800e-01,1.074700e-01,9.019100e-02,9.301300e-02,1.090000e-01, & - &1.174900e-01,1.091800e-01,1.945900e-01,1.646600e-01,1.441300e-01, & - &1.235900e-01,1.100100e-01,1.305400e-01,1.530500e-01,1.649700e-01, & - &1.526300e-01,2.737300e-01,1.862200e-01,1.629600e-01,1.397500e-01, & - &1.401900e-01,1.779900e-01,2.081600e-01,2.242100e-01,2.078400e-01, & - &3.736600e-01,2.075500e-01,1.816700e-01,1.593400e-01,1.903300e-01, & - &2.424700e-01,2.847200e-01,3.067500e-01,2.879800e-01,5.093000e-01, & - &1.283500e-01,1.123300e-01,9.633200e-02,8.029400e-02,6.889200e-02, & - &7.238800e-02,7.784100e-02,7.299600e-02,1.300900e-01,1.529600e-01, & - &1.338500e-01,1.148000e-01,9.567800e-02,9.126000e-02,1.038400e-01, & - &1.126500e-01,1.060000e-01,1.877400e-01,1.784100e-01,1.561400e-01, & - &1.338700e-01,1.155100e-01,1.260900e-01,1.483900e-01,1.607400e-01, & - &1.497800e-01,2.691600e-01,2.042100e-01,1.787200e-01,1.532800e-01, & - &1.451400e-01,1.753200e-01,2.057000e-01,2.221700e-01,2.072500e-01, & - &3.750200e-01,2.299300e-01,2.012400e-01,1.729100e-01,1.878200e-01, & - &2.393500e-01,2.809900e-01,3.034900e-01,2.822900e-01,5.127400e-01, & - &1.322000e-01,1.157200e-01,9.917900e-02,8.267600e-02,6.858700e-02, & - &6.992900e-02,7.455500e-02,6.831300e-02,1.261800e-01,1.606000e-01, & - &1.405300e-01,1.204600e-01,1.004200e-01,9.123200e-02,9.657800e-02, & - &1.044300e-01,9.906800e-02,1.746600e-01,1.902700e-01,1.665100e-01, & - &1.427500e-01,1.199800e-01,1.205600e-01,1.387300e-01,1.512900e-01, & - &1.427200e-01,2.514800e-01,2.206600e-01,1.931100e-01,1.655800e-01, & - &1.487700e-01,1.667600e-01,1.968100e-01,2.145200e-01,2.022300e-01, & - &3.588400e-01,2.512200e-01,2.198300e-01,1.884500e-01,1.882900e-01, & - &2.315900e-01,2.725800e-01,2.954500e-01,2.764600e-01,4.997400e-01, & - &1.346500e-01,1.178300e-01,1.010400e-01,8.419100e-02,7.018100e-02, & - &6.776400e-02,7.234900e-02,6.673800e-02,1.218200e-01,1.667800e-01, & - &1.459700e-01,1.251200e-01,1.042800e-01,9.035600e-02,9.354800e-02, & - &1.004700e-01,9.339500e-02,1.683800e-01,2.008000e-01,1.757300e-01, & - &1.506700e-01,1.256400e-01,1.193900e-01,1.289700e-01,1.402100e-01, & - &1.338900e-01,2.336700e-01,2.360100e-01,2.065100e-01,1.770500e-01, & - &1.529900e-01,1.597100e-01,1.840900e-01,2.022300e-01,1.929700e-01, & - &3.336400e-01,2.716400e-01,2.376700e-01,2.037700e-01,1.935100e-01, & - &2.209900e-01,2.614500e-01,2.856900e-01,2.706800e-01,4.759800e-01, & - &1.340600e-01,1.173100e-01,1.005600e-01,8.380600e-02,7.076200e-02, & - &6.623800e-02,6.897100e-02,6.472200e-02,1.136900e-01,1.696300e-01, & - &1.484500e-01,1.272900e-01,1.060600e-01,9.023100e-02,9.072300e-02, & - &9.719900e-02,9.043700e-02,1.613800e-01,2.078600e-01,1.819100e-01, & - &1.559200e-01,1.299500e-01,1.186100e-01,1.227900e-01,1.328700e-01, & - &1.252400e-01,2.206900e-01,2.477900e-01,2.168100e-01,1.858500e-01, & - &1.582300e-01,1.555800e-01,1.701200e-01,1.859400e-01,1.795600e-01, & - &3.060700e-01,2.885000e-01,2.525000e-01,2.164400e-01,1.959300e-01, & - &2.086100e-01,2.420300e-01,2.666000e-01,2.567000e-01,4.356300e-01/ - data absa(271:585,15) / & - &1.310100e-01,1.146400e-01,9.827200e-02,8.190700e-02,7.035000e-02, & - &6.524300e-02,6.499400e-02,6.239700e-02,1.042700e-01,1.696000e-01, & - &1.484100e-01,1.272000e-01,1.060200e-01,9.100700e-02,8.804600e-02, & - &9.198500e-02,8.673400e-02,1.500800e-01,2.115900e-01,1.851200e-01, & - &1.586900e-01,1.322700e-01,1.179900e-01,1.201600e-01,1.284800e-01, & - &1.212300e-01,2.092800e-01,2.559100e-01,2.239300e-01,1.919600e-01, & - &1.624600e-01,1.547400e-01,1.615000e-01,1.757900e-01,1.671000e-01, & - &2.881200e-01,3.021300e-01,2.642900e-01,2.265600e-01,2.007500e-01, & - &2.020600e-01,2.229900e-01,2.448200e-01,2.385200e-01,4.001400e-01, & - &1.257100e-01,1.100200e-01,9.430100e-02,7.866000e-02,6.902800e-02, & - &6.351200e-02,6.038600e-02,5.928300e-02,9.459400e-02,1.665800e-01, & - &1.457800e-01,1.249900e-01,1.043800e-01,9.161800e-02,8.583500e-02, & - &8.631200e-02,8.295400e-02,1.378100e-01,2.118500e-01,1.854000e-01, & - &1.589400e-01,1.329200e-01,1.185900e-01,1.179300e-01,1.229300e-01, & - &1.176700e-01,1.973200e-01,2.612400e-01,2.286000e-01,1.959500e-01, & - &1.648400e-01,1.553500e-01,1.577000e-01,1.688100e-01,1.615900e-01, & - &2.718600e-01,3.137700e-01,2.745500e-01,2.353600e-01,2.052600e-01, & - &2.013900e-01,2.121000e-01,2.320900e-01,2.241800e-01,3.744800e-01, & - &1.177900e-01,1.030700e-01,8.833200e-02,7.450400e-02,6.644600e-02, & - &6.046800e-02,5.613600e-02,5.494700e-02,8.616900e-02,1.603500e-01, & - &1.403100e-01,1.202400e-01,1.016300e-01,9.061700e-02,8.271400e-02, & - &7.992200e-02,7.811000e-02,1.265400e-01,2.092700e-01,1.831200e-01, & - &1.569800e-01,1.322200e-01,1.187300e-01,1.142400e-01,1.145400e-01, & - &1.117400e-01,1.830200e-01,2.634900e-01,2.305400e-01,1.976300e-01, & - &1.662600e-01,1.559800e-01,1.559800e-01,1.616600e-01,1.573600e-01, & - &2.585200e-01,3.216500e-01,2.814800e-01,2.413000e-01,2.079800e-01, & - &2.034900e-01,2.067100e-01,2.214200e-01,2.152800e-01,3.529200e-01, & - &1.109500e-01,9.708700e-02,8.323200e-02,7.137500e-02,6.443100e-02, & - &5.822200e-02,5.343800e-02,5.185600e-02,2.823400e-01,1.556800e-01, & - &1.362300e-01,1.167500e-01,9.977800e-02,9.005300e-02,8.118600e-02, & - &7.619900e-02,7.418500e-02,2.708400e-01,2.078700e-01,1.818900e-01, & - &1.559000e-01,1.329000e-01,1.200100e-01,1.127000e-01,1.097500e-01, & - &1.075900e-01,2.715800e-01,2.663600e-01,2.330600e-01,1.997900e-01, & - &1.702100e-01,1.590000e-01,1.551000e-01,1.561100e-01,1.540300e-01, & - &2.959800e-01,3.297200e-01,2.885000e-01,2.472900e-01,2.145800e-01, & - &2.082800e-01,2.071800e-01,2.160500e-01,2.126900e-01,3.542500e-01, & - &1.230900e-01,1.077000e-01,9.231800e-02,8.016900e-02,7.298700e-02, & - &6.555600e-02,5.959900e-02,5.720700e-02,7.808600e-01,1.730000e-01, & - &1.513800e-01,1.297600e-01,1.125200e-01,1.017200e-01,9.239000e-02, & - &8.648100e-02,8.344100e-02,7.575600e-01,2.309600e-01,2.021000e-01, & - &1.732400e-01,1.502400e-01,1.370500e-01,1.291500e-01,1.247400e-01, & - &1.219100e-01,7.445700e-01,2.955800e-01,2.586700e-01,2.216800e-01, & - &1.932100e-01,1.825300e-01,1.775900e-01,1.773400e-01,1.748400e-01, & - &7.382100e-01,3.661700e-01,3.203900e-01,2.746400e-01,2.454400e-01, & - &2.394200e-01,2.366400e-01,2.448000e-01,2.418600e-01,7.313600e-01, & - &1.353500e-01,1.184300e-01,1.016500e-01,8.983700e-02,8.169000e-02, & - &7.357100e-02,6.679100e-02,6.366100e-02,1.375700e+00,1.899900e-01, & - &1.662300e-01,1.428700e-01,1.262000e-01,1.142500e-01,1.048400e-01, & - &9.818300e-02,9.452300e-02,1.345900e+00,2.536800e-01,2.219500e-01, & - &1.905700e-01,1.684000e-01,1.558400e-01,1.473300e-01,1.418600e-01, & - &1.380700e-01,1.331500e+00,3.257700e-01,2.850600e-01,2.445900e-01, & - &2.185100e-01,2.082400e-01,2.025900e-01,2.014500e-01,1.985000e-01, & - &1.319400e+00,4.045900e-01,3.540500e-01,3.038500e-01,2.786000e-01, & - &2.731900e-01,2.703300e-01,2.768400e-01,2.749000e-01,1.299900e+00, & - &1.466600e-01,1.283200e-01,1.112800e-01,9.967500e-02,9.080800e-02, & - &8.228700e-02,7.473200e-02,7.089400e-02,1.972600e+00,2.065500e-01, & - &1.807200e-01,1.563400e-01,1.398100e-01,1.280000e-01,1.188300e-01, & - &1.108000e-01,1.063300e-01,1.942700e+00,2.767800e-01,2.421800e-01, & - &2.093800e-01,1.871400e-01,1.758300e-01,1.673600e-01,1.609500e-01, & - &1.562600e-01,1.925700e+00,3.557500e-01,3.113300e-01,2.691300e-01, & - &2.448400e-01,2.354300e-01,2.299800e-01,2.279500e-01,2.245400e-01, & - &1.908700e+00,4.417600e-01,3.865700e-01,3.360000e-01,3.131200e-01, & - &3.090000e-01,3.065400e-01,3.116700e-01,3.105900e-01,1.884700e+00/ - data absa(1:270,16) / & - &1.202700e-01,1.052600e-01,9.026800e-02,7.527100e-02,6.824200e-02, & - &7.994600e-02,8.497900e-02,7.621700e-02,1.410300e-01,1.408000e-01, & - &1.232400e-01,1.056700e-01,8.812600e-02,9.608900e-02,1.114000e-01, & - &1.184900e-01,1.062700e-01,1.968400e-01,1.615800e-01,1.414400e-01, & - &1.199300e-01,1.057700e-01,1.344600e-01,1.571300e-01,1.695400e-01, & - &1.545900e-01,2.820500e-01,1.822900e-01,1.595300e-01,1.368300e-01, & - &1.540000e-01,1.949100e-01,2.285900e-01,2.470100e-01,2.239700e-01, & - &4.110900e-01,2.025700e-01,1.773200e-01,1.520500e-01,2.165300e-01, & - &2.774300e-01,3.248500e-01,3.458700e-01,3.168500e-01,5.777600e-01, & - &1.361800e-01,1.191800e-01,1.021800e-01,8.518500e-02,7.206100e-02, & - &8.364100e-02,8.900700e-02,8.077600e-02,1.515800e-01,1.609100e-01, & - &1.408300e-01,1.207300e-01,1.006500e-01,1.021500e-01,1.186400e-01, & - &1.262800e-01,1.133500e-01,2.152100e-01,1.861300e-01,1.629100e-01, & - &1.396700e-01,1.164400e-01,1.397400e-01,1.624400e-01,1.734600e-01, & - &1.553100e-01,2.967800e-01,2.113900e-01,1.850100e-01,1.586200e-01, & - &1.608100e-01,2.053200e-01,2.409900e-01,2.575900e-01,2.324300e-01, & - &4.401400e-01,2.363300e-01,2.068100e-01,1.773400e-01,2.303700e-01, & - &2.935700e-01,3.425000e-01,3.694400e-01,3.349700e-01,6.268300e-01, & - &1.481600e-01,1.296700e-01,1.111500e-01,9.265900e-02,7.415900e-02, & - &8.058300e-02,8.582600e-02,7.792500e-02,1.498700e-01,1.776600e-01, & - &1.554700e-01,1.332800e-01,1.110900e-01,1.010400e-01,1.174800e-01, & - &1.251400e-01,1.136700e-01,2.186700e-01,2.080600e-01,1.820800e-01, & - &1.561200e-01,1.301200e-01,1.410000e-01,1.639800e-01,1.747400e-01, & - &1.587300e-01,3.053900e-01,2.388500e-01,2.090500e-01,1.792000e-01, & - &1.546200e-01,1.970400e-01,2.310400e-01,2.483600e-01,2.274200e-01, & - &4.318700e-01,2.694700e-01,2.358300e-01,2.021800e-01,2.256500e-01, & - &2.881400e-01,3.376900e-01,3.625700e-01,3.301900e-01,6.308000e-01, & - &1.581800e-01,1.384300e-01,1.186800e-01,9.890600e-02,7.914700e-02, & - &7.478200e-02,7.973000e-02,7.244800e-02,1.410100e-01,1.930200e-01, & - &1.689000e-01,1.447900e-01,1.206700e-01,9.694600e-02,1.126600e-01, & - &1.201200e-01,1.091600e-01,2.124900e-01,2.294000e-01,2.007600e-01, & - &1.720600e-01,1.434500e-01,1.388300e-01,1.616200e-01,1.723700e-01, & - &1.566900e-01,3.050100e-01,2.666500e-01,2.333500e-01,2.000200e-01, & - &1.667400e-01,1.911500e-01,2.225800e-01,2.374300e-01,2.158100e-01, & - &4.200400e-01,3.041000e-01,2.661500e-01,2.281100e-01,2.128500e-01, & - &2.737200e-01,3.208300e-01,3.454100e-01,3.159900e-01,6.040500e-01, & - &1.674400e-01,1.465300e-01,1.256100e-01,1.046800e-01,8.376300e-02, & - &7.643000e-02,8.007800e-02,7.182100e-02,1.381700e-01,2.081700e-01, & - &1.821700e-01,1.561700e-01,1.301400e-01,1.041300e-01,1.066600e-01, & - &1.138000e-01,1.035000e-01,2.024500e-01,2.513500e-01,2.199800e-01, & - &1.885700e-01,1.571400e-01,1.352500e-01,1.576100e-01,1.682400e-01, & - &1.530200e-01,2.992100e-01,2.961400e-01,2.591300e-01,2.221400e-01, & - &1.851400e-01,1.909500e-01,2.225600e-01,2.375700e-01,2.160900e-01, & - &4.225300e-01,3.416500e-01,2.989000e-01,2.562600e-01,2.135800e-01, & - &2.627600e-01,3.071000e-01,3.275300e-01,2.987500e-01,5.840300e-01, & - &1.740600e-01,1.523100e-01,1.305600e-01,1.087900e-01,8.703300e-02, & - &7.955700e-02,8.349500e-02,7.497000e-02,1.446100e-01,2.211500e-01, & - &1.935300e-01,1.658700e-01,1.382500e-01,1.105800e-01,1.007900e-01, & - &1.057100e-01,9.535400e-02,1.866900e-01,2.718500e-01,2.378900e-01, & - &2.038900e-01,1.699400e-01,1.359800e-01,1.499300e-01,1.601700e-01, & - &1.458200e-01,2.854600e-01,3.251900e-01,2.845400e-01,2.439100e-01, & - &2.032700e-01,1.866700e-01,2.178000e-01,2.327300e-01,2.119300e-01, & - &4.145400e-01,3.799700e-01,3.325200e-01,2.850200e-01,2.374900e-01, & - &2.597300e-01,3.030800e-01,3.238600e-01,2.950200e-01,5.768000e-01/ - data absa(271:585,16) / & - &1.787500e-01,1.564200e-01,1.340800e-01,1.117500e-01,8.941500e-02, & - &8.183100e-02,8.600500e-02,7.732300e-02,1.492200e-01,2.325700e-01, & - &2.034900e-01,1.744500e-01,1.453800e-01,1.163100e-01,1.061600e-01, & - &1.114700e-01,1.001700e-01,1.929000e-01,2.915500e-01,2.551100e-01, & - &2.187200e-01,1.822600e-01,1.458100e-01,1.405700e-01,1.503200e-01, & - &1.370300e-01,2.679500e-01,3.545300e-01,3.101800e-01,2.658600e-01, & - &2.215800e-01,1.807200e-01,2.105900e-01,2.252800e-01,2.053900e-01, & - &4.013400e-01,4.200100e-01,3.675000e-01,3.150000e-01,2.625200e-01, & - &2.574200e-01,3.007200e-01,3.217200e-01,2.934500e-01,5.727900e-01, & - &1.818400e-01,1.591200e-01,1.363800e-01,1.136700e-01,9.091800e-02, & - &8.333000e-02,8.770800e-02,7.903900e-02,1.523600e-01,2.426600e-01, & - &2.123100e-01,1.819800e-01,1.516800e-01,1.213200e-01,1.109000e-01, & - &1.166400e-01,1.050100e-01,2.019900e-01,3.106000e-01,2.717700e-01, & - &2.329700e-01,1.941100e-01,1.553200e-01,1.415300e-01,1.487400e-01, & - &1.338700e-01,2.575300e-01,3.842200e-01,3.361800e-01,2.882000e-01, & - &2.401700e-01,1.921200e-01,2.019100e-01,2.162200e-01,1.975100e-01, & - &3.848300e-01,4.618300e-01,4.041200e-01,3.463700e-01,2.886100e-01, & - &2.533200e-01,2.962800e-01,3.174300e-01,2.900700e-01,5.642900e-01, & - &1.824200e-01,1.596400e-01,1.368500e-01,1.140300e-01,9.123800e-02, & - &8.365000e-02,8.822100e-02,7.964700e-02,1.534300e-01,2.503100e-01, & - &2.190300e-01,1.877400e-01,1.564500e-01,1.251800e-01,1.145000e-01, & - &1.206900e-01,1.089400e-01,2.090900e-01,3.278000e-01,2.868100e-01, & - &2.458200e-01,2.048400e-01,1.639000e-01,1.494700e-01,1.574400e-01, & - &1.420700e-01,2.717800e-01,4.128800e-01,3.613600e-01,3.097200e-01, & - &2.581000e-01,2.064800e-01,1.924000e-01,2.049900e-01,1.875000e-01, & - &3.652000e-01,5.040100e-01,4.410500e-01,3.779300e-01,3.150400e-01, & - &2.543000e-01,2.885900e-01,3.096400e-01,2.836700e-01,5.500200e-01, & - &1.858100e-01,1.625900e-01,1.393400e-01,1.161300e-01,9.290300e-02, & - &8.514800e-02,9.003400e-02,8.154000e-02,3.459000e-01,2.616300e-01, & - &2.289000e-01,1.961800e-01,1.634900e-01,1.307700e-01,1.196500e-01, & - &1.264400e-01,1.145000e-01,3.286500e-01,3.495800e-01,3.058600e-01, & - &2.622000e-01,2.184900e-01,1.747800e-01,1.595100e-01,1.684500e-01, & - &1.525200e-01,3.120400e-01,4.478700e-01,3.919100e-01,3.359400e-01, & - &2.798900e-01,2.239700e-01,2.037600e-01,2.150600e-01,1.947800e-01, & - &3.790600e-01,5.541400e-01,4.849400e-01,4.156100e-01,3.463600e-01, & - &2.771100e-01,2.869000e-01,3.085700e-01,2.836200e-01,5.573600e-01, & - &2.238700e-01,1.959000e-01,1.679300e-01,1.399500e-01,1.119600e-01, & - &1.024800e-01,1.086600e-01,9.875900e-02,9.723200e-01,3.148700e-01, & - &2.755300e-01,2.361600e-01,1.968200e-01,1.574700e-01,1.438900e-01, & - &1.525100e-01,1.386800e-01,9.235200e-01,4.203400e-01,3.678100e-01, & - &3.152600e-01,2.627400e-01,2.102000e-01,1.915600e-01,2.029500e-01, & - &1.846500e-01,8.761900e-01,5.378300e-01,4.706200e-01,4.033800e-01, & - &3.361900e-01,2.690000e-01,2.446300e-01,2.591000e-01,2.355600e-01, & - &8.352800e-01,6.646500e-01,5.816000e-01,4.985000e-01,4.154500e-01, & - &3.326200e-01,3.438100e-01,3.708700e-01,3.426600e-01,8.360800e-01, & - &2.689800e-01,2.353900e-01,2.017500e-01,1.681200e-01,1.345100e-01, & - &1.229500e-01,1.308200e-01,1.195500e-01,1.725400e+00,3.775900e-01, & - &3.303500e-01,2.832200e-01,2.360200e-01,1.887900e-01,1.723100e-01, & - &1.833500e-01,1.676900e-01,1.636400e+00,5.030200e-01,4.402600e-01, & - &3.773600e-01,3.144000e-01,2.515500e-01,2.289800e-01,2.436900e-01, & - &2.230700e-01,1.567800e+00,6.424900e-01,5.621400e-01,4.819000e-01, & - &4.015400e-01,3.212700e-01,2.940200e-01,3.124700e-01,2.848500e-01, & - &1.525500e+00,7.924800e-01,6.934000e-01,5.943800e-01,4.952000e-01, & - &3.996300e-01,4.114800e-01,4.443300e-01,4.132200e-01,1.541200e+00, & - &3.211100e-01,2.808600e-01,2.408000e-01,2.006300e-01,1.605300e-01, & - &1.464500e-01,1.566300e-01,1.441500e-01,2.468100e+00,4.495200e-01, & - &3.933700e-01,3.370900e-01,2.809500e-01,2.247400e-01,2.049500e-01, & - &2.190900e-01,2.019800e-01,2.382200e+00,5.973900e-01,5.228100e-01, & - &4.480900e-01,3.733300e-01,2.988100e-01,2.721700e-01,2.906300e-01, & - &2.683200e-01,2.323200e+00,7.611200e-01,6.658600e-01,5.707900e-01, & - &4.757000e-01,3.810200e-01,3.528800e-01,3.764000e-01,3.443100e-01, & - &2.295000e+00,9.363100e-01,8.192000e-01,7.022400e-01,5.850800e-01, & - &4.792700e-01,4.919300e-01,5.306200e-01,4.959200e-01,2.313500e+00/ - -! the array absb(1175,NG05) = kb(5,5,13:59,NG05) contains absorption -! coefs at the NG05=16 g-intervals for a range of pressure levels -! < ~100mb, temperatures, and ratios of o3 to co2. the first index in -! the array, js, runs from 1 to 5, and corresponds to different o3 to -! co2 ratios, as expressed through the binary species parameter eta, -! defined as eta = o3/(o3+rat*co2), where rat is the ratio of the -! integrated line strength in the band of co2 to that of o3. for -! instance, js=1 refers to no o3 (eta = 0) and js = 5 corresponds to -! eta = 1.0. the second index, jt, which runs from 1 to 5, -! corresponds to different temperatures. more specifically, jt = 1-5 -! means that the data are for the corresponding temperature of -! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the -! third index, jp, runs from 13 to 59 and refers to the corresponding -! pressure level in pref (e.g. jp = 13 is for a pressure of 95.5835 mb). -! the fourth index, ig, goes from 1 to NG05=16, and tells us which -! g-interval the absorption coefficients are for. - - data absb(1:300,1) / & - &3.447000e-06,2.637200e-04,5.106300e-04,7.525700e-04,1.053400e-03, & - &4.051600e-06,3.294900e-04,6.349900e-04,9.314100e-04,1.301800e-03, & - &5.110800e-06,3.953800e-04,7.577800e-04,1.106000e-03,1.545900e-03, & - &6.799900e-06,4.600100e-04,8.745200e-04,1.271800e-03,1.778700e-03, & - &9.324100e-06,5.227000e-04,9.835000e-04,1.424300e-03,1.997000e-03, & - &2.862400e-06,2.220300e-04,4.296000e-04,6.324200e-04,8.726200e-04, & - &3.387200e-06,2.759700e-04,5.319900e-04,7.793100e-04,1.072600e-03, & - &4.300100e-06,3.299300e-04,6.319500e-04,9.222500e-04,1.266600e-03, & - &5.740600e-06,3.829400e-04,7.270700e-04,1.057600e-03,1.449500e-03, & - &7.886000e-06,4.345900e-04,8.159100e-04,1.181000e-03,1.618700e-03, & - &2.382500e-06,1.869700e-04,3.618300e-04,5.319500e-04,7.258700e-04, & - &2.841900e-06,2.312100e-04,4.455600e-04,6.524000e-04,8.876700e-04, & - &3.630700e-06,2.755000e-04,5.271000e-04,7.694000e-04,1.043500e-03, & - &4.865400e-06,3.191100e-04,6.046600e-04,8.792200e-04,1.189000e-03, & - &6.695200e-06,3.617200e-04,6.772000e-04,9.792800e-04,1.321800e-03, & - &1.985800e-06,1.574200e-04,3.046200e-04,4.474300e-04,6.067900e-04, & - &2.389300e-06,1.937600e-04,3.730300e-04,5.462400e-04,7.381800e-04, & - &3.071700e-06,2.301600e-04,4.396000e-04,6.415700e-04,8.641900e-04, & - &4.130800e-06,2.659900e-04,5.028100e-04,7.305800e-04,9.812000e-04, & - &5.692700e-06,3.010900e-04,5.620200e-04,8.115500e-04,1.087200e-03, & - &1.655900e-06,1.322600e-04,2.558000e-04,3.756800e-04,5.068600e-04, & - &2.008300e-06,1.621200e-04,3.117800e-04,4.565100e-04,6.136800e-04, & - &2.596800e-06,1.920500e-04,3.661300e-04,5.340500e-04,7.156300e-04, & - &3.504700e-06,2.215300e-04,4.178200e-04,6.064100e-04,8.100200e-04, & - &4.835100e-06,2.505600e-04,4.663200e-04,6.721700e-04,8.950800e-04, & - &1.381800e-06,1.110000e-04,2.145400e-04,3.150600e-04,4.233800e-04, & - &1.688700e-06,1.355600e-04,2.603500e-04,3.809900e-04,5.102500e-04, & - &2.195700e-06,1.601600e-04,3.047900e-04,4.441700e-04,5.928400e-04, & - &2.973300e-06,1.844400e-04,3.470400e-04,5.030000e-04,6.689600e-04, & - &4.106100e-06,2.084600e-04,3.868000e-04,5.564900e-04,7.373800e-04, & - &1.153000e-06,9.303800e-05,1.797000e-04,2.638000e-04,3.530900e-04, & - &1.419300e-06,1.132600e-04,2.172200e-04,3.176800e-04,4.237100e-04, & - &1.855100e-06,1.334800e-04,2.535500e-04,3.691400e-04,4.905400e-04, & - &2.519400e-06,1.535600e-04,2.881100e-04,4.169800e-04,5.518200e-04, & - &3.482300e-06,1.733600e-04,3.206800e-04,4.605000e-04,6.066300e-04, & - &9.651400e-07,7.822000e-05,1.509300e-04,2.214600e-04,2.956200e-04, & - &1.197700e-06,9.483700e-05,1.816000e-04,2.653800e-04,3.529500e-04, & - &1.574300e-06,1.115100e-04,2.113300e-04,3.073200e-04,4.070500e-04, & - &2.145200e-06,1.281000e-04,2.395900e-04,3.462500e-04,4.564700e-04, & - &2.967300e-06,1.443400e-04,2.663100e-04,3.816200e-04,5.004700e-04, & - &8.088400e-07,6.573900e-05,1.267000e-04,1.858100e-04,2.474800e-04, & - &1.011800e-06,7.943000e-05,1.518200e-04,2.216600e-04,2.941200e-04, & - &1.337000e-06,9.317700e-05,1.761100e-04,2.558000e-04,3.379000e-04, & - &1.827600e-06,1.068400e-04,1.992800e-04,2.874500e-04,3.777200e-04, & - &2.528900e-06,1.201100e-04,2.212200e-04,3.162800e-04,4.130800e-04, & - &6.877000e-07,5.597700e-05,1.076800e-04,1.577900e-04,2.097500e-04, & - &8.705100e-07,6.726700e-05,1.282200e-04,1.869600e-04,2.475200e-04, & - &1.159300e-06,7.861200e-05,1.480400e-04,2.146500e-04,2.827500e-04, & - &1.591400e-06,8.975200e-05,1.670000e-04,2.402400e-04,3.146200e-04, & - &2.202200e-06,1.005500e-04,1.848200e-04,2.635800e-04,3.428300e-04, & - &5.868100e-07,4.767400e-05,9.150700e-05,1.339300e-04,1.777000e-04, & - &7.514900e-07,5.700300e-05,1.082900e-04,1.576700e-04,2.082500e-04, & - &1.008000e-06,6.628900e-05,1.245000e-04,1.801000e-04,2.365800e-04, & - &1.388700e-06,7.536500e-05,1.399500e-04,2.007900e-04,2.620400e-04, & - &1.920800e-06,8.412600e-05,1.543500e-04,2.197200e-04,2.844900e-04, & - &5.029200e-07,4.063200e-05,7.778800e-05,1.137000e-04,1.505300e-04, & - &6.511800e-07,4.831800e-05,9.150400e-05,1.329900e-04,1.751700e-04, & - &8.797600e-07,5.588600e-05,1.047500e-04,1.511500e-04,1.978700e-04, & - &1.215100e-06,6.326900e-05,1.172700e-04,1.679200e-04,2.182000e-04, & - &1.679000e-06,7.036100e-05,1.288600e-04,1.831700e-04,2.359900e-04/ - data absb(301:600,1) / & - &4.332000e-07,3.467200e-05,6.617200e-05,9.655700e-05,1.275500e-04, & - &5.670600e-07,4.095400e-05,7.739900e-05,1.122400e-04,1.474400e-04, & - &7.712100e-07,4.713000e-05,8.817300e-05,1.269500e-04,1.655900e-04, & - &1.066900e-06,5.311700e-05,9.826400e-05,1.405200e-04,1.817700e-04, & - &1.472200e-06,5.885400e-05,1.075400e-04,1.527100e-04,1.958400e-04, & - &3.760700e-07,2.963700e-05,5.641800e-05,8.216000e-05,1.082800e-04, & - &4.975700e-07,3.476100e-05,6.558100e-05,9.486900e-05,1.242400e-04, & - &6.808800e-07,3.978200e-05,7.428000e-05,1.067800e-04,1.387400e-04, & - &9.425900e-07,4.463400e-05,8.238500e-05,1.176800e-04,1.515700e-04, & - &1.298100e-06,4.927400e-05,8.978700e-05,1.273500e-04,1.626500e-04, & - &3.278300e-07,2.529200e-05,4.806300e-05,6.984000e-05,9.185200e-05, & - &4.379200e-07,2.947600e-05,5.549700e-05,8.015200e-05,1.046600e-04, & - &6.022700e-07,3.355300e-05,6.251400e-05,8.976200e-05,1.162100e-04, & - &8.335400e-07,3.747900e-05,6.900000e-05,9.846200e-05,1.264000e-04, & - &1.144800e-06,4.123900e-05,7.491700e-05,1.061200e-04,1.351400e-04, & - &2.866900e-07,2.155600e-05,4.089200e-05,5.930400e-05,7.783300e-05, & - &3.863500e-07,2.496000e-05,4.690200e-05,6.767000e-05,8.810300e-05, & - &5.333000e-07,2.827000e-05,5.254200e-05,7.536400e-05,9.730800e-05, & - &7.373400e-07,3.144600e-05,5.772700e-05,8.228600e-05,1.053700e-04, & - &1.009600e-06,3.449500e-05,6.245500e-05,8.834000e-05,1.122700e-04, & - &2.520100e-07,1.836100e-05,3.476300e-05,5.035100e-05,6.598700e-05, & - &3.423600e-07,2.112900e-05,3.961700e-05,5.709500e-05,7.421600e-05, & - &4.736100e-07,2.381300e-05,4.413800e-05,6.325500e-05,8.156300e-05, & - &6.538000e-07,2.638700e-05,4.828600e-05,6.873000e-05,8.795900e-05, & - &8.919300e-07,2.885700e-05,5.206200e-05,7.349700e-05,9.341100e-05, & - &2.222100e-07,1.561700e-05,2.950600e-05,4.270100e-05,5.590100e-05, & - &3.039700e-07,1.786500e-05,3.341400e-05,4.810700e-05,6.249100e-05, & - &4.208400e-07,2.003800e-05,3.703500e-05,5.301500e-05,6.835400e-05, & - &5.797400e-07,2.212500e-05,4.035100e-05,5.734100e-05,7.343500e-05, & - &7.876500e-07,2.412700e-05,4.336600e-05,6.109200e-05,7.773300e-05, & - &1.968100e-07,1.327000e-05,2.501800e-05,3.616900e-05,4.737100e-05, & - &2.707100e-07,1.509700e-05,2.815900e-05,4.050000e-05,5.265900e-05, & - &3.747500e-07,1.685800e-05,3.105700e-05,4.439200e-05,5.734900e-05, & - &5.147700e-07,1.854700e-05,3.370500e-05,4.780500e-05,6.138900e-05, & - &6.962500e-07,2.017000e-05,3.611800e-05,5.075800e-05,6.479700e-05, & - &1.748500e-07,1.126500e-05,2.118600e-05,3.060000e-05,4.011900e-05, & - &2.414800e-07,1.274700e-05,2.370400e-05,3.405200e-05,4.436400e-05, & - &3.339100e-07,1.417300e-05,2.602300e-05,3.713400e-05,4.810700e-05, & - &4.571200e-07,1.554400e-05,2.813900e-05,3.982200e-05,5.132000e-05, & - &6.152600e-07,1.685700e-05,3.006400e-05,4.214700e-05,5.400900e-05, & - &1.557000e-07,9.547500e-06,1.791100e-05,2.584200e-05,3.395700e-05, & - &2.154900e-07,1.075100e-05,1.993100e-05,2.859200e-05,3.737000e-05, & - &2.974600e-07,1.190600e-05,2.178300e-05,3.102700e-05,4.035300e-05, & - &4.056500e-07,1.301900e-05,2.347300e-05,3.314600e-05,4.291000e-05, & - &5.430800e-07,1.408200e-05,2.501000e-05,3.497300e-05,4.504000e-05, & - &1.372100e-07,8.046500e-06,1.506000e-05,2.170700e-05,2.858800e-05, & - &1.900200e-07,9.023200e-06,1.668100e-05,2.390000e-05,3.132700e-05, & - &2.618000e-07,9.963000e-06,1.816800e-05,2.583300e-05,3.372000e-05, & - &3.556600e-07,1.086500e-05,1.952300e-05,2.751100e-05,3.576700e-05, & - &4.739100e-07,1.172600e-05,2.075100e-05,2.895400e-05,3.746800e-05, & - &1.172300e-07,6.696400e-06,1.251600e-05,1.803100e-05,2.382100e-05, & - &1.623500e-07,7.492700e-06,1.382900e-05,1.980000e-05,2.605100e-05, & - &2.233500e-07,8.256800e-06,1.502900e-05,2.135000e-05,2.800000e-05, & - &3.027500e-07,8.993000e-06,1.612700e-05,2.269900e-05,2.967100e-05, & - &4.023600e-07,9.696500e-06,1.712100e-05,2.385800e-05,3.106400e-05, & - &9.666200e-08,5.498200e-06,1.027500e-05,1.480400e-05,1.963000e-05, & - &1.338600e-07,6.150100e-06,1.134800e-05,1.624700e-05,2.147400e-05, & - &1.841000e-07,6.775600e-06,1.232900e-05,1.751300e-05,2.309000e-05, & - &2.494700e-07,7.377500e-06,1.322500e-05,1.861200e-05,2.447900e-05, & - &3.313800e-07,7.953900e-06,1.403800e-05,1.955900e-05,2.564500e-05/ - data absb(601:900,1) / & - &7.583300e-08,4.431900e-06,8.296100e-06,1.196500e-05,1.592200e-05, & - &1.050200e-07,4.967400e-06,9.183000e-06,1.316400e-05,1.746900e-05, & - &1.446500e-07,5.483400e-06,9.996700e-06,1.421800e-05,1.883400e-05, & - &1.964500e-07,5.978800e-06,1.073800e-05,1.513300e-05,2.001200e-05, & - &2.616600e-07,6.452900e-06,1.141400e-05,1.592400e-05,2.101000e-05, & - &5.933900e-08,3.567000e-06,6.689300e-06,9.656600e-06,1.290200e-05, & - &8.215500e-08,4.008000e-06,7.423300e-06,1.065300e-05,1.420500e-05, & - &1.133100e-07,4.432500e-06,8.098000e-06,1.153200e-05,1.535900e-05, & - &1.542700e-07,4.841000e-06,8.713200e-06,1.229700e-05,1.636400e-05, & - &2.060300e-07,5.231000e-06,9.273800e-06,1.295700e-05,1.722000e-05, & - &4.645700e-08,2.870600e-06,5.392200e-06,7.791600e-06,1.046300e-05, & - &6.428000e-08,3.233500e-06,5.999500e-06,8.619300e-06,1.156100e-05, & - &8.875300e-08,3.582600e-06,6.558000e-06,9.350900e-06,1.253900e-05, & - &1.210900e-07,3.918600e-06,7.068800e-06,9.989900e-06,1.339800e-05, & - &1.622100e-07,4.240700e-06,7.535000e-06,1.054300e-05,1.413700e-05, & - &3.521300e-08,2.277900e-06,4.290600e-06,6.208700e-06,8.362100e-06, & - &4.862100e-08,2.576900e-06,4.796700e-06,6.902600e-06,9.288400e-06, & - &6.722800e-08,2.865600e-06,5.264300e-06,7.521700e-06,1.012200e-05, & - &9.205100e-08,3.143700e-06,5.691900e-06,8.063200e-06,1.085800e-05, & - &1.239200e-07,3.409900e-06,6.081900e-06,8.531800e-06,1.149500e-05, & - &2.661800e-08,1.801900e-06,3.403600e-06,4.932100e-06,6.661400e-06, & - &3.660800e-08,2.048700e-06,3.826200e-06,5.515400e-06,7.443700e-06, & - &5.067200e-08,2.287200e-06,4.217000e-06,6.038000e-06,8.151600e-06, & - &6.961000e-08,2.517100e-06,4.575600e-06,6.497700e-06,8.782200e-06, & - &9.415200e-08,2.737600e-06,4.902500e-06,6.895900e-06,9.331300e-06, & - &2.015700e-08,1.423400e-06,2.695900e-06,3.911400e-06,5.299900e-06, & - &2.756900e-08,1.626600e-06,3.047800e-06,4.400300e-06,5.958500e-06, & - &3.816800e-08,1.823700e-06,3.374300e-06,4.841200e-06,6.560700e-06, & - &5.257800e-08,2.013700e-06,3.675100e-06,5.230900e-06,7.100100e-06, & - &7.143800e-08,2.196500e-06,3.949100e-06,5.569300e-06,7.573600e-06, & - &1.504800e-08,1.112800e-06,2.114300e-06,3.071900e-06,4.175900e-06, & - &2.040100e-08,1.280500e-06,2.408400e-06,3.483300e-06,4.732600e-06, & - &2.820500e-08,1.443800e-06,2.682800e-06,3.857900e-06,5.246600e-06, & - &3.895100e-08,1.601200e-06,2.935300e-06,4.189700e-06,5.709000e-06, & - &5.319100e-08,1.752500e-06,3.166200e-06,4.479200e-06,6.120000e-06, & - &1.119800e-08,8.643100e-07,1.647300e-06,2.396900e-06,3.270500e-06, & - &1.500700e-08,1.002700e-06,1.893100e-06,2.743300e-06,3.740400e-06, & - &2.066500e-08,1.137600e-06,2.123300e-06,3.060200e-06,4.178200e-06, & - &2.858600e-08,1.268000e-06,2.336300e-06,3.343900e-06,4.576400e-06, & - &3.921800e-08,1.393700e-06,2.530900e-06,3.592100e-06,4.932200e-06, & - &8.375900e-09,6.691000e-07,1.278800e-06,1.863300e-06,2.554100e-06, & - &1.107400e-08,7.831100e-07,1.483800e-06,2.153800e-06,2.950100e-06, & - &1.514400e-08,8.945500e-07,1.676900e-06,2.421700e-06,3.322500e-06, & - &2.095900e-08,1.002800e-06,1.856000e-06,2.663500e-06,3.664400e-06, & - &2.886100e-08,1.106800e-06,2.020500e-06,2.876800e-06,3.973600e-06, & - &6.273900e-09,5.140700e-07,9.852200e-07,1.437700e-06,1.980600e-06, & - &8.152900e-09,6.079700e-07,1.156100e-06,1.680700e-06,2.313600e-06, & - &1.103800e-08,7.000800e-07,1.317900e-06,1.907300e-06,2.630100e-06, & - &1.524900e-08,7.896400e-07,1.468800e-06,2.113300e-06,2.923900e-06, & - &2.105800e-08,8.760600e-07,1.607900e-06,2.296500e-06,3.192000e-06, & - &4.694900e-09,3.899200e-07,7.492700e-07,1.095200e-06,1.515900e-06, & - &5.964500e-09,4.671600e-07,8.915100e-07,1.298200e-06,1.795200e-06, & - &7.961200e-09,5.432100e-07,1.027200e-06,1.489700e-06,2.063300e-06, & - &1.093800e-08,6.174600e-07,1.154500e-06,1.665400e-06,2.315300e-06, & - &1.513200e-08,6.891700e-07,1.272100e-06,1.822800e-06,2.546800e-06, & - &3.553100e-09,2.939300e-07,5.662200e-07,8.288400e-07,1.154400e-06, & - &4.398200e-09,3.572100e-07,6.838800e-07,9.975100e-07,1.387800e-06, & - &5.769900e-09,4.199500e-07,7.974200e-07,1.158600e-06,1.614200e-06, & - &7.854200e-09,4.813200e-07,9.045000e-07,1.307800e-06,1.829700e-06, & - &1.086200e-08,5.409800e-07,1.004100e-06,1.443200e-06,2.030200e-06/ - data absb(901:1175,1) / & - &2.722300e-09,2.201100e-07,4.248000e-07,6.227300e-07,8.752200e-07, & - &3.275100e-09,2.717500e-07,5.216900e-07,7.621600e-07,1.069500e-06, & - &4.207400e-09,3.233800e-07,6.163800e-07,8.971000e-07,1.260500e-06, & - &5.654800e-09,3.740800e-07,7.061900e-07,1.023400e-06,1.444500e-06, & - &7.793100e-09,4.235300e-07,7.903600e-07,1.139100e-06,1.618300e-06, & - &2.117100e-09,1.646100e-07,3.181500e-07,4.670700e-07,6.613100e-07, & - &2.476700e-09,2.065400e-07,3.975100e-07,5.816100e-07,8.212900e-07, & - &3.109800e-09,2.489800e-07,4.760700e-07,6.939700e-07,9.810800e-07, & - &4.119600e-09,2.908200e-07,5.512500e-07,8.003400e-07,1.136400e-06, & - &5.637300e-09,3.316900e-07,6.219300e-07,8.984400e-07,1.284700e-06, & - &1.664500e-09,1.225700e-07,2.371800e-07,3.486500e-07,4.971700e-07, & - &1.896300e-09,1.565300e-07,3.018500e-07,4.422200e-07,6.279700e-07, & - &2.323500e-09,1.912300e-07,3.666700e-07,5.353000e-07,7.605700e-07, & - &3.025400e-09,2.257200e-07,4.294500e-07,6.245300e-07,8.906900e-07, & - &4.099500e-09,2.595000e-07,4.887300e-07,7.074200e-07,1.016300e-06, & - &1.320600e-09,9.057100e-08,1.755000e-07,2.582900e-07,3.719500e-07, & - &1.467000e-09,1.179700e-07,2.278400e-07,3.342400e-07,4.784400e-07, & - &1.750500e-09,1.462300e-07,2.810700e-07,4.109400e-07,5.880100e-07, & - &2.233900e-09,1.746000e-07,3.332900e-07,4.854200e-07,6.969500e-07, & - &2.989900e-09,2.025000e-07,3.829300e-07,5.553800e-07,8.032200e-07, & - &1.057000e-09,6.635500e-08,1.287100e-07,1.896300e-07,2.771900e-07, & - &1.145600e-09,8.830600e-08,1.707900e-07,2.508600e-07,3.633300e-07, & - &1.330400e-09,1.112700e-07,2.143400e-07,3.138100e-07,4.536900e-07, & - &1.659500e-09,1.345400e-07,2.575800e-07,3.757200e-07,5.449600e-07, & - &2.188300e-09,1.575500e-07,2.990600e-07,4.345100e-07,6.348200e-07, & - &8.551800e-10,4.867500e-08,9.447700e-08,1.393100e-07,2.048900e-07, & - &9.053000e-10,6.618600e-08,1.281400e-07,1.884500e-07,2.736500e-07, & - &1.026500e-09,8.478200e-08,1.636000e-07,2.398200e-07,3.468900e-07, & - &1.251500e-09,1.038100e-07,1.992200e-07,2.910000e-07,4.218000e-07, & - &1.623200e-09,1.227600e-07,2.337800e-07,3.401500e-07,4.960300e-07, & - &6.970000e-10,3.557000e-08,6.908000e-08,1.019500e-07,1.499100e-07, & - &7.215000e-10,4.947600e-08,9.589600e-08,1.411900e-07,2.042900e-07, & - &8.002800e-10,6.450200e-08,1.246400e-07,1.829100e-07,2.631100e-07, & - &9.531000e-10,8.001300e-08,1.538800e-07,2.250600e-07,3.238100e-07, & - &1.214000e-09,9.556900e-08,1.825400e-07,2.659700e-07,3.842800e-07, & - &5.718700e-10,2.578800e-08,5.009100e-08,7.397600e-08,1.088400e-07, & - &5.791500e-10,3.675800e-08,7.131600e-08,1.050900e-07,1.516500e-07, & - &6.284900e-10,4.883100e-08,9.446500e-08,1.387900e-07,1.986600e-07, & - &7.309400e-10,6.143600e-08,1.183900e-07,1.733600e-07,2.477200e-07, & - &9.127100e-10,7.420900e-08,1.421000e-07,2.073400e-07,2.970700e-07, & - &4.722000e-10,1.852600e-08,3.596900e-08,5.315100e-08,7.830500e-08, & - &4.685200e-10,2.711100e-08,5.263000e-08,7.761900e-08,1.118100e-07, & - &4.970800e-10,3.676200e-08,7.119100e-08,1.047100e-07,1.492600e-07, & - &5.649900e-10,4.698500e-08,9.069200e-08,1.329700e-07,1.888200e-07, & - &6.903500e-10,5.742900e-08,1.102400e-07,1.610500e-07,2.289900e-07, & - &3.915700e-10,1.327000e-08,2.574700e-08,3.806100e-08,5.598800e-08, & - &3.816200e-10,1.995800e-08,3.876800e-08,5.721700e-08,8.215200e-08, & - &3.964000e-10,2.764600e-08,5.359200e-08,7.890200e-08,1.118700e-07, & - &4.411800e-10,3.591300e-08,6.940700e-08,1.018700e-07,1.436500e-07, & - &5.273400e-10,4.443100e-08,8.545900e-08,1.250000e-07,1.761700e-07, & - &3.225700e-10,1.027400e-08,1.992700e-08,2.946100e-08,4.229300e-08, & - &3.122600e-10,1.563300e-08,3.037100e-08,4.484000e-08,6.316600e-08, & - &3.214800e-10,2.184600e-08,4.236900e-08,6.240500e-08,8.696400e-08, & - &3.548800e-10,2.857900e-08,5.526200e-08,8.115000e-08,1.123800e-07, & - &4.203500e-10,3.553500e-08,6.841100e-08,1.001200e-07,1.382800e-07/ - data absb(1:300,2) / & - &8.017500e-06,1.612500e-03,3.147800e-03,4.675300e-03,6.431600e-03, & - &1.042600e-05,1.878300e-03,3.614000e-03,5.322900e-03,7.343100e-03, & - &1.492700e-05,2.131100e-03,4.047700e-03,5.899300e-03,8.126000e-03, & - &2.280900e-05,2.373800e-03,4.449300e-03,6.405600e-03,8.776700e-03, & - &3.548700e-05,2.607200e-03,4.818100e-03,6.848800e-03,9.299300e-03, & - &6.752400e-06,1.362300e-03,2.647000e-03,3.921300e-03,5.337300e-03, & - &8.890800e-06,1.579600e-03,3.029800e-03,4.445700e-03,6.049500e-03, & - &1.288400e-05,1.786600e-03,3.386600e-03,4.914400e-03,6.653900e-03, & - &1.981300e-05,1.985500e-03,3.714700e-03,5.329700e-03,7.148800e-03, & - &3.091000e-05,2.177900e-03,4.016200e-03,5.695000e-03,7.541200e-03, & - &5.711200e-06,1.147400e-03,2.221600e-03,3.281100e-03,4.431300e-03, & - &7.620800e-06,1.324700e-03,2.536400e-03,3.707100e-03,4.991900e-03, & - &1.117100e-05,1.494400e-03,2.827300e-03,4.090600e-03,5.462300e-03, & - &1.728600e-05,1.657300e-03,3.094800e-03,4.431300e-03,5.842800e-03, & - &2.706400e-05,1.817000e-03,3.340400e-03,4.729000e-03,6.139700e-03, & - &4.841900e-06,9.634100e-04,1.862000e-03,2.740700e-03,3.685800e-03, & - &6.543100e-06,1.108500e-03,2.119100e-03,3.088600e-03,4.131900e-03, & - &9.699100e-06,1.247100e-03,2.355600e-03,3.402700e-03,4.502100e-03, & - &1.511200e-05,1.381300e-03,2.573500e-03,3.679100e-03,4.799200e-03, & - &2.368700e-05,1.514600e-03,2.773900e-03,3.920500e-03,5.029400e-03, & - &4.104600e-06,8.065800e-04,1.556800e-03,2.285000e-03,3.060700e-03, & - &5.612800e-06,9.249100e-04,1.765700e-03,2.570100e-03,3.416500e-03, & - &8.411800e-06,1.038600e-03,1.958900e-03,2.825800e-03,3.710100e-03, & - &1.316300e-05,1.149900e-03,2.136000e-03,3.049300e-03,3.943300e-03, & - &2.060700e-05,1.260500e-03,2.300100e-03,3.244500e-03,4.122700e-03, & - &3.478700e-06,6.737500e-04,1.298700e-03,1.903300e-03,2.539400e-03, & - &4.819300e-06,7.704800e-04,1.469000e-03,2.136200e-03,2.823700e-03, & - &7.291300e-06,8.639300e-04,1.625600e-03,2.342300e-03,3.055800e-03, & - &1.143200e-05,9.562300e-04,1.770400e-03,2.523700e-03,3.240400e-03, & - &1.786800e-05,1.048100e-03,1.905300e-03,2.681200e-03,3.380800e-03, & - &2.946700e-06,5.617700e-04,1.081800e-03,1.584000e-03,2.103500e-03, & - &4.136400e-06,6.409000e-04,1.219900e-03,1.772300e-03,2.330000e-03, & - &6.299900e-06,7.182900e-04,1.347600e-03,1.939800e-03,2.514700e-03, & - &9.887900e-06,7.945600e-04,1.466700e-03,2.086700e-03,2.660800e-03, & - &1.542500e-05,8.710200e-04,1.577300e-03,2.214300e-03,2.770700e-03, & - &2.510000e-06,4.689300e-04,9.016900e-04,1.319200e-03,1.745200e-03, & - &3.570100e-06,5.339800e-04,1.013900e-03,1.471700e-03,1.926100e-03, & - &5.471500e-06,5.977200e-04,1.118100e-03,1.606800e-03,2.072400e-03, & - &8.595000e-06,6.609000e-04,1.215700e-03,1.725300e-03,2.187500e-03, & - &1.336600e-05,7.245000e-04,1.306400e-03,1.829300e-03,2.274100e-03, & - &2.141900e-06,3.912900e-04,7.510800e-04,1.097800e-03,1.447700e-03, & - &3.082300e-06,4.448000e-04,8.422600e-04,1.221100e-03,1.591900e-03, & - &4.751500e-06,4.973400e-04,9.275900e-04,1.330000e-03,1.708000e-03, & - &7.461100e-06,5.497100e-04,1.007500e-03,1.426300e-03,1.798800e-03, & - &1.156700e-05,6.026700e-04,1.081900e-03,1.510800e-03,1.866800e-03, & - &1.869200e-06,3.293000e-04,6.302000e-04,9.198600e-04,1.208700e-03, & - &2.736400e-06,3.732400e-04,7.042600e-04,1.018700e-03,1.322200e-03, & - &4.248300e-06,4.166300e-04,7.737800e-04,1.106200e-03,1.413300e-03, & - &6.661400e-06,4.600100e-04,8.389900e-04,1.183700e-03,1.483600e-03, & - &1.028300e-05,5.044400e-04,8.998600e-04,1.251700e-03,1.535800e-03, & - &1.639900e-06,2.771900e-04,5.286200e-04,7.702700e-04,1.008800e-03, & - &2.439100e-06,3.132800e-04,5.889500e-04,8.495100e-04,1.098000e-03, & - &3.806300e-06,3.490800e-04,6.455500e-04,9.199700e-04,1.168800e-03, & - &5.954800e-06,3.852300e-04,6.987900e-04,9.823299e-04,1.223300e-03, & - &9.146700e-06,4.226200e-04,7.487000e-04,1.037100e-03,1.263500e-03, & - &1.448600e-06,2.334300e-04,4.436200e-04,6.449000e-04,8.415000e-04, & - &2.184700e-06,2.631200e-04,4.926800e-04,7.085800e-04,9.113100e-04, & - &3.419900e-06,2.927300e-04,5.388000e-04,7.652500e-04,9.664600e-04, & - &5.336600e-06,3.230500e-04,5.822100e-04,8.153900e-04,1.008300e-03, & - &8.155700e-06,3.542200e-04,6.235000e-04,8.596300e-04,1.039000e-03/ - data absb(301:600,2) / & - &1.289600e-06,1.967400e-04,3.725000e-04,5.400900e-04,7.020400e-04, & - &1.968500e-06,2.211700e-04,4.123600e-04,5.911900e-04,7.562700e-04, & - &3.086200e-06,2.458700e-04,4.499700e-04,6.367800e-04,7.991500e-04, & - &4.800500e-06,2.712200e-04,4.855000e-04,6.770700e-04,8.312200e-04, & - &7.293900e-06,2.970100e-04,5.197700e-04,7.127900e-04,8.545100e-04, & - &1.160800e-06,1.661200e-04,3.132300e-04,4.528100e-04,5.859400e-04, & - &1.790500e-06,1.863300e-04,3.456200e-04,4.937800e-04,6.280600e-04, & - &2.808300e-06,2.070000e-04,3.762800e-04,5.303000e-04,6.609500e-04, & - &4.349400e-06,2.279600e-04,4.055700e-04,5.626800e-04,6.853800e-04, & - &6.564300e-06,2.492000e-04,4.338200e-04,5.917700e-04,7.028500e-04, & - &1.050000e-06,1.402600e-04,2.633100e-04,3.794300e-04,4.886900e-04, & - &1.632600e-06,1.570900e-04,2.896400e-04,4.122800e-04,5.214200e-04, & - &2.557100e-06,1.742200e-04,3.147700e-04,4.415400e-04,5.466000e-04, & - &3.940200e-06,1.915600e-04,3.389400e-04,4.676400e-04,5.652300e-04, & - &5.905200e-06,2.088300e-04,3.620700e-04,4.915100e-04,5.783300e-04, & - &9.534300e-07,1.184400e-04,2.212200e-04,3.177500e-04,4.073500e-04, & - &1.490400e-06,1.324500e-04,2.427100e-04,3.440800e-04,4.326700e-04, & - &2.328500e-06,1.465800e-04,2.634300e-04,3.675700e-04,4.519800e-04, & - &3.567200e-06,1.607400e-04,2.831500e-04,3.887700e-04,4.661100e-04, & - &5.308600e-06,1.747200e-04,3.019000e-04,4.083000e-04,4.758600e-04, & - &8.713000e-07,1.001300e-04,1.859300e-04,2.660700e-04,3.395900e-04, & - &1.366200e-06,1.116900e-04,2.035700e-04,2.871700e-04,3.591500e-04, & - &2.127200e-06,1.232900e-04,2.205300e-04,3.061300e-04,3.739200e-04, & - &3.236700e-06,1.347500e-04,2.365500e-04,3.234000e-04,3.847500e-04, & - &4.779800e-06,1.461300e-04,2.516300e-04,3.392400e-04,3.919900e-04, & - &7.985700e-07,8.461500e-05,1.562500e-04,2.226600e-04,2.829500e-04, & - &1.252800e-06,9.412500e-05,1.707800e-04,2.396100e-04,2.980600e-04, & - &1.941900e-06,1.035500e-04,1.845200e-04,2.549900e-04,3.094300e-04, & - &2.934200e-06,1.128900e-04,1.975100e-04,2.690600e-04,3.176600e-04, & - &4.298700e-06,1.221000e-04,2.094700e-04,2.817200e-04,3.230700e-04, & - &7.349100e-07,7.147000e-05,1.313900e-04,1.863000e-04,2.358800e-04, & - &1.151400e-06,7.926100e-05,1.432200e-04,1.999700e-04,2.475800e-04, & - &1.775100e-06,8.693400e-05,1.543800e-04,2.125000e-04,2.563300e-04, & - &2.661900e-06,9.450300e-05,1.647000e-04,2.237900e-04,2.626200e-04, & - &3.868200e-06,1.020300e-04,1.742200e-04,2.337900e-04,2.666700e-04, & - &6.776100e-07,6.034400e-05,1.104600e-04,1.558500e-04,1.966100e-04, & - &1.058800e-06,6.668900e-05,1.200600e-04,1.669700e-04,2.056300e-04, & - &1.622200e-06,7.291800e-05,1.290000e-04,1.770200e-04,2.123800e-04, & - &2.412800e-06,7.907300e-05,1.371900e-04,1.860200e-04,2.172000e-04, & - &3.477900e-06,8.526300e-05,1.448100e-04,1.938800e-04,2.202500e-04, & - &6.252700e-07,5.090200e-05,9.281200e-05,1.303700e-04,1.638200e-04, & - &9.733400e-07,5.604800e-05,1.005500e-04,1.393500e-04,1.708200e-04, & - &1.480100e-06,6.110100e-05,1.076600e-04,1.474000e-04,1.761100e-04, & - &2.183800e-06,6.614400e-05,1.142000e-04,1.545200e-04,1.797800e-04, & - &3.122400e-06,7.122500e-05,1.203000e-04,1.606200e-04,1.820400e-04, & - &5.673100e-07,4.273000e-05,7.768500e-05,1.087700e-04,1.361500e-04, & - &8.795000e-07,4.690500e-05,8.388300e-05,1.159800e-04,1.416300e-04, & - &1.328700e-06,5.103400e-05,8.956500e-05,1.224200e-04,1.457400e-04, & - &1.946400e-06,5.514300e-05,9.479700e-05,1.280100e-04,1.485600e-04, & - &2.764000e-06,5.934600e-05,9.973200e-05,1.328000e-04,1.503000e-04, & - &4.927000e-07,3.550100e-05,6.445400e-05,9.010200e-05,1.126200e-04, & - &7.617300e-07,3.890200e-05,6.945000e-05,9.597000e-05,1.170700e-04, & - &1.146400e-06,4.227200e-05,7.402700e-05,1.011200e-04,1.203600e-04, & - &1.672600e-06,4.564000e-05,7.826600e-05,1.055600e-04,1.226400e-04, & - &2.365800e-06,4.909100e-05,8.227900e-05,1.093800e-04,1.240700e-04, & - &4.075300e-07,2.917800e-05,5.299100e-05,7.409000e-05,9.273900e-05, & - &6.296500e-07,3.195300e-05,5.705700e-05,7.888800e-05,9.641800e-05, & - &9.470500e-07,3.470600e-05,6.078400e-05,8.306500e-05,9.916100e-05, & - &1.380800e-06,3.746900e-05,6.424100e-05,8.665800e-05,1.010800e-04, & - &1.952000e-06,4.029400e-05,6.750900e-05,8.974400e-05,1.022900e-04/ - data absb(601:900,2) / & - &3.147600e-07,2.362900e-05,4.302400e-05,6.027400e-05,7.576100e-05, & - &4.877300e-07,2.590000e-05,4.637800e-05,6.426100e-05,7.892900e-05, & - &7.365200e-07,2.815200e-05,4.945500e-05,6.773000e-05,8.132600e-05, & - &1.078300e-06,3.041100e-05,5.230600e-05,7.071200e-05,8.300600e-05, & - &1.530500e-06,3.271700e-05,5.499800e-05,7.328500e-05,8.413300e-05, & - &2.421000e-07,1.911200e-05,3.489500e-05,4.898500e-05,6.188700e-05, & - &3.762700e-07,2.097500e-05,3.767100e-05,5.231300e-05,6.461700e-05, & - &5.705200e-07,2.281800e-05,4.021000e-05,5.519300e-05,6.670100e-05, & - &8.391100e-07,2.466900e-05,4.257000e-05,5.768200e-05,6.821100e-05, & - &1.195800e-06,2.654800e-05,4.478400e-05,5.981800e-05,6.923700e-05, & - &1.862500e-07,1.545900e-05,2.829800e-05,3.980500e-05,5.058600e-05, & - &2.901600e-07,1.698600e-05,3.059400e-05,4.257700e-05,5.294300e-05, & - &4.417300e-07,1.849500e-05,3.269300e-05,4.497000e-05,5.476700e-05, & - &6.525300e-07,2.000500e-05,3.463600e-05,4.703600e-05,5.610600e-05, & - &9.339800e-07,2.154500e-05,3.646700e-05,4.882100e-05,5.705200e-05, & - &1.366800e-07,1.237000e-05,2.273600e-05,3.207500e-05,4.100000e-05, & - &2.137100e-07,1.362500e-05,2.465200e-05,3.441900e-05,4.307100e-05, & - &3.275500e-07,1.486300e-05,2.640400e-05,3.644200e-05,4.468600e-05, & - &4.875400e-07,1.610200e-05,2.802500e-05,3.819100e-05,4.589000e-05, & - &7.030500e-07,1.735100e-05,2.954100e-05,3.970200e-05,4.675700e-05, & - &9.966900e-08,9.877000e-06,1.822800e-05,2.579700e-05,3.316900e-05, & - &1.562800e-07,1.091100e-05,1.983300e-05,2.778300e-05,3.498900e-05, & - &2.410600e-07,1.192600e-05,2.129700e-05,2.949500e-05,3.641200e-05, & - &3.616300e-07,1.293800e-05,2.264500e-05,3.097500e-05,3.749500e-05, & - &5.257600e-07,1.395900e-05,2.390900e-05,3.225800e-05,3.828800e-05, & - &7.267800e-08,7.880100e-06,1.460000e-05,2.072400e-05,2.680800e-05, & - &1.141300e-07,8.732200e-06,1.594400e-05,2.240400e-05,2.840600e-05, & - &1.770500e-07,9.564800e-06,1.716500e-05,2.385500e-05,2.966000e-05, & - &2.676300e-07,1.039400e-05,1.829200e-05,2.510800e-05,3.063100e-05, & - &3.923100e-07,1.122500e-05,1.934000e-05,2.619400e-05,3.135700e-05, & - &5.171000e-08,6.240500e-06,1.161500e-05,1.654500e-05,2.154700e-05, & - &8.112800e-08,6.942800e-06,1.274200e-05,1.797100e-05,2.296400e-05, & - &1.265700e-07,7.628700e-06,1.377300e-05,1.921700e-05,2.408600e-05, & - &1.930800e-07,8.307900e-06,1.471700e-05,2.028700e-05,2.496200e-05, & - &2.858300e-07,8.989600e-06,1.559500e-05,2.121600e-05,2.563200e-05, & - &3.649500e-08,4.919900e-06,9.198900e-06,1.315200e-05,1.725500e-05, & - &5.695100e-08,5.500500e-06,1.014900e-05,1.436800e-05,1.851400e-05, & - &8.923900e-08,6.065200e-06,1.101600e-05,1.543700e-05,1.951900e-05, & - &1.373700e-07,6.622600e-06,1.181100e-05,1.635500e-05,2.031400e-05, & - &2.055400e-07,7.178400e-06,1.254700e-05,1.715200e-05,2.092900e-05, & - &2.590700e-08,3.872100e-06,7.271900e-06,1.043400e-05,1.379000e-05, & - &3.998600e-08,4.351100e-06,8.069700e-06,1.146600e-05,1.490500e-05, & - &6.280400e-08,4.817600e-06,8.801500e-06,1.238200e-05,1.580600e-05, & - &9.742300e-08,5.274900e-06,9.469800e-06,1.317100e-05,1.652300e-05, & - &1.472400e-07,5.730600e-06,1.008900e-05,1.385500e-05,1.708900e-05, & - &1.837300e-08,3.032000e-06,5.719700e-06,8.235800e-06,1.097100e-05, & - &2.784800e-08,3.427700e-06,6.390100e-06,9.114200e-06,1.195600e-05, & - &4.368700e-08,3.813400e-06,7.008500e-06,9.900100e-06,1.276600e-05, & - &6.819400e-08,4.190100e-06,7.572900e-06,1.058100e-05,1.341300e-05, & - &1.041600e-07,4.563300e-06,8.093800e-06,1.116900e-05,1.393300e-05, & - &1.298600e-08,2.353300e-06,4.461500e-06,6.449100e-06,8.654300e-06, & - &1.912800e-08,2.681500e-06,5.025700e-06,7.197100e-06,9.526100e-06, & - &2.977200e-08,3.000100e-06,5.549200e-06,7.873500e-06,1.025500e-05, & - &4.670200e-08,3.311600e-06,6.028200e-06,8.465200e-06,1.084300e-05, & - &7.207000e-08,3.617500e-06,6.467800e-06,8.972600e-06,1.131800e-05, & - &9.341600e-09,1.820000e-06,3.467000e-06,5.029400e-06,6.799000e-06, & - &1.325500e-08,2.091900e-06,3.940500e-06,5.664300e-06,7.569500e-06, & - &2.030500e-08,2.355700e-06,4.382900e-06,6.244900e-06,8.223700e-06, & - &3.189500e-08,2.612900e-06,4.789300e-06,6.756300e-06,8.756300e-06, & - &4.963400e-08,2.864700e-06,5.161400e-06,7.197800e-06,9.190800e-06/ - data absb(901:1175,2) / & - &6.835900e-09,1.401900e-06,2.682600e-06,3.905700e-06,5.323300e-06, & - &9.299600e-09,1.626900e-06,3.079300e-06,4.443100e-06,6.000500e-06, & - &1.390200e-08,1.845200e-06,3.452300e-06,4.938600e-06,6.583500e-06, & - &2.174200e-08,2.058000e-06,3.797000e-06,5.380600e-06,7.067800e-06, & - &3.403500e-08,2.266000e-06,4.112200e-06,5.763900e-06,7.464100e-06, & - &5.117800e-09,1.079200e-06,2.073900e-06,3.030100e-06,4.153200e-06, & - &6.686200e-09,1.265300e-06,2.405500e-06,3.482300e-06,4.738500e-06, & - &9.689700e-09,1.446300e-06,2.719200e-06,3.903900e-06,5.251900e-06, & - &1.498900e-08,1.622100e-06,3.010100e-06,4.282900e-06,5.684100e-06, & - &2.354000e-08,1.793900e-06,3.276900e-06,4.614500e-06,6.040200e-06, & - &3.892800e-09,8.287000e-07,1.599500e-06,2.344400e-06,3.227400e-06, & - &4.897600e-09,9.825100e-07,1.875600e-06,2.723400e-06,3.727400e-06, & - &6.845700e-09,1.132300e-06,2.138500e-06,3.080000e-06,4.175200e-06, & - &1.040400e-08,1.277700e-06,2.383700e-06,3.404400e-06,4.557400e-06, & - &1.632900e-08,1.419500e-06,2.609100e-06,3.689300e-06,4.874300e-06, & - &3.002000e-09,6.336300e-07,1.227900e-06,1.805200e-06,2.497500e-06, & - &3.640000e-09,7.601900e-07,1.456900e-06,2.122000e-06,2.923100e-06, & - &4.892500e-09,8.843200e-07,1.677300e-06,2.423400e-06,3.312700e-06, & - &7.254000e-09,1.004500e-06,1.883400e-06,2.699600e-06,3.648500e-06, & - &1.131600e-08,1.121800e-06,2.073900e-06,2.944400e-06,3.931800e-06, & - &2.348000e-09,4.819400e-07,9.375100e-07,1.381700e-06,1.923600e-06, & - &2.743100e-09,5.856200e-07,1.126800e-06,1.646500e-06,2.285700e-06, & - &3.546400e-09,6.884500e-07,1.311000e-06,1.899900e-06,2.622100e-06, & - &5.090700e-09,7.879700e-07,1.484400e-06,2.134800e-06,2.918400e-06, & - &7.841000e-09,8.847900e-07,1.645000e-06,2.344700e-06,3.171300e-06, & - &1.859400e-09,3.670600e-07,7.162500e-07,1.057500e-06,1.472100e-06, & - &2.105500e-09,4.518100e-07,8.725600e-07,1.278600e-06,1.776200e-06, & - &2.629100e-09,5.366600e-07,1.025700e-06,1.490400e-06,2.059800e-06, & - &3.648200e-09,6.190600e-07,1.170900e-06,1.688700e-06,2.314700e-06, & - &5.521000e-09,6.990100e-07,1.305900e-06,1.868000e-06,2.534200e-06, & - &1.484900e-09,2.789400e-07,5.456000e-07,8.066000e-07,1.118800e-06, & - &1.638300e-09,3.481900e-07,6.746200e-07,9.912700e-07,1.372100e-06, & - &1.980000e-09,4.179900e-07,8.016100e-07,1.167700e-06,1.608400e-06, & - &2.653600e-09,4.861500e-07,9.230600e-07,1.334900e-06,1.824900e-06, & - &3.926000e-09,5.522600e-07,1.036300e-06,1.487000e-06,2.011700e-06, & - &1.193600e-09,2.107500e-07,4.130200e-07,6.113200e-07,8.451300e-07, & - &1.288600e-09,2.672900e-07,5.194200e-07,7.651900e-07,1.055500e-06, & - &1.507700e-09,3.245500e-07,6.245200e-07,9.120200e-07,1.252300e-06, & - &1.952500e-09,3.809800e-07,7.259200e-07,1.052400e-06,1.434500e-06, & - &2.807700e-09,4.356100e-07,8.208400e-07,1.181500e-06,1.594000e-06, & - &9.658300e-10,1.581500e-07,3.104400e-07,4.600500e-07,6.340800e-07, & - &1.021500e-09,2.042600e-07,3.981000e-07,5.876700e-07,8.076600e-07, & - &1.159700e-09,2.511200e-07,4.849100e-07,7.098400e-07,9.717400e-07, & - &1.452300e-09,2.977900e-07,5.693400e-07,8.273900e-07,1.124200e-06, & - &2.021900e-09,3.429600e-07,6.488600e-07,9.365100e-07,1.260200e-06, & - &7.866200e-10,1.183500e-07,2.325500e-07,3.449800e-07,4.738100e-07, & - &8.162500e-10,1.559300e-07,3.046600e-07,4.504000e-07,6.163200e-07, & - &9.034100e-10,1.942700e-07,3.762800e-07,5.521500e-07,7.528400e-07, & - &1.097100e-09,2.327300e-07,4.463200e-07,6.500800e-07,8.794100e-07, & - &1.477900e-09,2.700400e-07,5.127400e-07,7.418800e-07,9.942900e-07, & - &6.435500e-10,9.334400e-08,1.834900e-07,2.723000e-07,3.701100e-07, & - &6.626200e-10,1.240700e-07,2.426100e-07,3.588600e-07,4.855600e-07, & - &7.271200e-10,1.555000e-07,3.015300e-07,4.428400e-07,5.962800e-07, & - &8.715600e-10,1.870400e-07,3.591900e-07,5.236800e-07,6.984200e-07, & - &1.158700e-09,2.177500e-07,4.140800e-07,5.997900e-07,7.913300e-07/ - data absb(1:300,3) / & - &2.035300e-05,5.679500e-03,1.087900e-02,1.583600e-02,2.063100e-02, & - &3.377700e-05,6.506600e-03,1.222100e-02,1.756400e-02,2.263000e-02, & - &5.952200e-05,7.351200e-03,1.349900e-02,1.910900e-02,2.432800e-02, & - &1.034900e-04,8.202800e-03,1.468900e-02,2.046100e-02,2.571800e-02, & - &1.730300e-04,9.051600e-03,1.580600e-02,2.165100e-02,2.682000e-02, & - &1.778300e-05,4.905600e-03,9.335800e-03,1.353500e-02,1.745700e-02, & - &3.001100e-05,5.597700e-03,1.042800e-02,1.490600e-02,1.895800e-02, & - &5.311200e-05,6.297000e-03,1.145400e-02,1.611800e-02,2.021000e-02, & - &9.228400e-05,6.998000e-03,1.242500e-02,1.719400e-02,2.122100e-02, & - &1.539500e-04,7.699000e-03,1.335200e-02,1.815500e-02,2.200600e-02, & - &1.561900e-05,4.198700e-03,7.934200e-03,1.145600e-02,1.464600e-02, & - &2.677400e-05,4.770400e-03,8.815000e-03,1.253700e-02,1.577100e-02, & - &4.756300e-05,5.346200e-03,9.650100e-03,1.350300e-02,1.671300e-02, & - &8.251600e-05,5.923800e-03,1.045200e-02,1.437400e-02,1.746600e-02, & - &1.372800e-04,6.502600e-03,1.122200e-02,1.516100e-02,1.804400e-02, & - &1.377900e-05,3.566000e-03,6.688100e-03,9.617100e-03,1.222000e-02, & - &2.394400e-05,4.035800e-03,7.405700e-03,1.048300e-02,1.308900e-02, & - &4.262000e-05,4.508900e-03,8.094300e-03,1.126600e-02,1.381800e-02, & - &7.389300e-05,4.986100e-03,8.757700e-03,1.197800e-02,1.439100e-02, & - &1.225800e-04,5.463700e-03,9.394000e-03,1.262800e-02,1.482800e-02, & - &1.216000e-05,3.007400e-03,5.606000e-03,8.029600e-03,1.014700e-02, & - &2.137500e-05,3.393500e-03,6.197200e-03,8.731300e-03,1.083000e-02, & - &3.812700e-05,3.783500e-03,6.764300e-03,9.371800e-03,1.139800e-02, & - &6.601100e-05,4.177000e-03,7.310400e-03,9.957500e-03,1.184000e-02, & - &1.091800e-04,4.573800e-03,7.833900e-03,1.049500e-02,1.217300e-02, & - &1.074800e-05,2.524500e-03,4.684700e-03,6.682500e-03,8.403000e-03, & - &1.907600e-05,2.841700e-03,5.171300e-03,7.256000e-03,8.944900e-03, & - &3.407300e-05,3.163600e-03,5.635600e-03,7.781100e-03,9.389100e-03, & - &5.886800e-05,3.488300e-03,6.085000e-03,8.263300e-03,9.733400e-03, & - &9.706000e-05,3.820800e-03,6.514000e-03,8.705800e-03,9.989400e-03, & - &9.493200e-06,2.111100e-03,3.906000e-03,5.550500e-03,6.941900e-03, & - &1.699000e-05,2.372400e-03,4.304100e-03,6.021000e-03,7.371900e-03, & - &3.037900e-05,2.637500e-03,4.685000e-03,6.452600e-03,7.720600e-03, & - &5.231800e-05,2.907300e-03,5.053500e-03,6.846800e-03,7.988000e-03, & - &8.585100e-05,3.186300e-03,5.406900e-03,7.209000e-03,8.184200e-03, & - &8.462100e-06,1.764800e-03,3.256300e-03,4.612200e-03,5.736000e-03, & - &1.525000e-05,1.980200e-03,3.581000e-03,4.997200e-03,6.077900e-03, & - &2.724500e-05,2.199000e-03,3.893200e-03,5.348800e-03,6.351100e-03, & - &4.670700e-05,2.424200e-03,4.195300e-03,5.671000e-03,6.560000e-03, & - &7.616500e-05,2.657500e-03,4.489300e-03,5.966100e-03,6.710800e-03, & - &7.545300e-06,1.473300e-03,2.710400e-03,3.830200e-03,4.737200e-03, & - &1.366000e-05,1.650500e-03,2.975900e-03,4.143400e-03,5.008100e-03, & - &2.436000e-05,1.832500e-03,3.231600e-03,4.430000e-03,5.223200e-03, & - &4.153900e-05,2.020200e-03,3.480400e-03,4.692100e-03,5.386200e-03, & - &6.722600e-05,2.213500e-03,3.724000e-03,4.932100e-03,5.501000e-03, & - &6.987500e-06,1.237700e-03,2.268000e-03,3.195700e-03,3.925300e-03, & - &1.268900e-05,1.384600e-03,2.484400e-03,3.448400e-03,4.137400e-03, & - &2.248500e-05,1.536300e-03,2.694100e-03,3.680100e-03,4.303900e-03, & - &3.795400e-05,1.692500e-03,2.899200e-03,3.891800e-03,4.428000e-03, & - &6.072900e-05,1.852900e-03,3.100200e-03,4.088300e-03,4.514400e-03, & - &6.495300e-06,1.039600e-03,1.896800e-03,2.664200e-03,3.250200e-03, & - &1.179300e-05,1.161900e-03,2.073200e-03,2.868400e-03,3.415900e-03, & - &2.071500e-05,1.287900e-03,2.245900e-03,3.055800e-03,3.544500e-03, & - &3.455100e-05,1.417600e-03,2.414700e-03,3.227500e-03,3.639500e-03, & - &5.464100e-05,1.551200e-03,2.580400e-03,3.388500e-03,3.703400e-03, & - &6.067000e-06,8.736500e-04,1.585900e-03,2.220400e-03,2.689700e-03, & - &1.098100e-05,9.753200e-04,1.730300e-03,2.385200e-03,2.818800e-03, & - &1.907800e-05,1.079900e-03,1.872700e-03,2.536700e-03,2.917500e-03, & - &3.140700e-05,1.187600e-03,2.011400e-03,2.677000e-03,2.989900e-03, & - &4.906700e-05,1.299700e-03,2.148100e-03,2.808600e-03,3.037100e-03/ - data absb(301:600,3) / & - &5.698900e-06,7.348500e-04,1.326400e-03,1.850600e-03,2.225900e-03, & - &1.024000e-05,8.191000e-04,1.445200e-03,1.983600e-03,2.325500e-03, & - &1.758000e-05,9.058700e-04,1.562100e-03,2.106600e-03,2.401400e-03, & - &2.857200e-05,9.958100e-04,1.676200e-03,2.221000e-03,2.455900e-03, & - &4.407500e-05,1.090400e-03,1.789500e-03,2.328500e-03,2.490400e-03, & - &5.404400e-06,6.191700e-04,1.110900e-03,1.543500e-03,1.842800e-03, & - &9.612900e-06,6.890300e-04,1.208600e-03,1.651000e-03,1.919400e-03, & - &1.627900e-05,7.611200e-04,1.304400e-03,1.750900e-03,1.977000e-03, & - &2.609800e-05,8.368800e-04,1.398500e-03,1.844200e-03,2.017800e-03, & - &3.975700e-05,9.174800e-04,1.493100e-03,1.931900e-03,2.042600e-03, & - &5.120800e-06,5.215500e-04,9.303300e-04,1.286900e-03,1.525200e-03, & - &9.005000e-06,5.794700e-04,1.010600e-03,1.374100e-03,1.584100e-03, & - &1.502800e-05,6.399900e-04,1.089100e-03,1.455100e-03,1.627900e-03, & - &2.377100e-05,7.042200e-04,1.167400e-03,1.531300e-03,1.658300e-03, & - &3.578900e-05,7.722000e-04,1.246500e-03,1.603300e-03,1.675900e-03, & - &4.842600e-06,4.393200e-04,7.790900e-04,1.072800e-03,1.261900e-03, & - &8.412300e-06,4.875700e-04,8.449300e-04,1.143500e-03,1.307100e-03, & - &1.383300e-05,5.387400e-04,9.095500e-04,1.209400e-03,1.340600e-03, & - &2.160700e-05,5.932800e-04,9.751300e-04,1.271600e-03,1.362900e-03, & - &3.214600e-05,6.497800e-04,1.041600e-03,1.331000e-03,1.375200e-03, & - &4.584900e-06,3.702300e-04,6.526400e-04,8.945700e-04,1.044500e-03, & - &7.857200e-06,4.108900e-04,7.066500e-04,9.518700e-04,1.079300e-03, & - &1.274100e-05,4.543600e-04,7.603400e-04,1.005500e-03,1.104800e-03, & - &1.964900e-05,4.999800e-04,8.155000e-04,1.056600e-03,1.121300e-03, & - &2.889600e-05,5.468200e-04,8.709300e-04,1.106000e-03,1.129800e-03, & - &4.329700e-06,3.121700e-04,5.466300e-04,7.458000e-04,8.646400e-04, & - &7.312000e-06,3.466800e-04,5.910600e-04,7.923200e-04,8.914300e-04, & - &1.170500e-05,3.833800e-04,6.362700e-04,8.360400e-04,9.107400e-04, & - &1.782800e-05,4.212500e-04,6.824900e-04,8.782400e-04,9.228300e-04, & - &2.592400e-05,4.596600e-04,7.282700e-04,9.196400e-04,9.287500e-04, & - &4.087400e-06,2.636800e-04,4.579100e-04,6.218300e-04,7.161300e-04, & - &6.801500e-06,2.929300e-04,4.949000e-04,6.594900e-04,7.368700e-04, & - &1.074600e-05,3.234800e-04,5.329800e-04,6.954700e-04,7.515900e-04, & - &1.616300e-05,3.548000e-04,5.713600e-04,7.307300e-04,7.605600e-04, & - &2.325100e-05,3.859700e-04,6.089700e-04,7.651500e-04,7.646700e-04, & - &3.851400e-06,2.229700e-04,3.837400e-04,5.182900e-04,5.930500e-04, & - &6.316800e-06,2.475400e-04,4.148500e-04,5.490400e-04,6.092400e-04, & - &9.850100e-06,2.729200e-04,4.468100e-04,5.789700e-04,6.204400e-04, & - &1.463800e-05,2.984600e-04,4.784000e-04,6.085200e-04,6.270700e-04, & - &2.083100e-05,3.236100e-04,5.088300e-04,6.365800e-04,6.299900e-04, & - &3.616300e-06,1.886600e-04,3.219000e-04,4.320500e-04,4.914400e-04, & - &5.850300e-06,2.091200e-04,3.481100e-04,4.573600e-04,5.039700e-04, & - &9.006700e-06,2.299900e-04,3.745600e-04,4.823900e-04,5.123800e-04, & - &1.322600e-05,2.506700e-04,4.003900e-04,5.067600e-04,5.173200e-04, & - &1.863100e-05,2.710700e-04,4.247600e-04,5.296300e-04,5.194400e-04, & - &3.323800e-06,1.590200e-04,2.694600e-04,3.593300e-04,4.064800e-04, & - &5.316600e-06,1.759000e-04,2.913500e-04,3.804700e-04,4.162300e-04, & - &8.093500e-06,1.928900e-04,3.130900e-04,4.013500e-04,4.227300e-04, & - &1.176700e-05,2.096300e-04,3.339800e-04,4.213600e-04,4.264600e-04, & - &1.644100e-05,2.262800e-04,3.534000e-04,4.397600e-04,4.279100e-04, & - &2.906700e-06,1.325900e-04,2.239300e-04,2.973300e-04,3.354000e-04, & - &4.618700e-06,1.464400e-04,2.420600e-04,3.150300e-04,3.432100e-04, & - &6.986900e-06,1.602700e-04,2.599000e-04,3.323600e-04,3.484200e-04, & - &1.010400e-05,1.738700e-04,2.767200e-04,3.488100e-04,3.514500e-04, & - &1.405200e-05,1.874600e-04,2.922600e-04,3.635900e-04,3.526200e-04, & - &2.408900e-06,1.092700e-04,1.845100e-04,2.445500e-04,2.759400e-04, & - &3.823300e-06,1.206000e-04,1.994900e-04,2.593800e-04,2.824200e-04, & - &5.777800e-06,1.318500e-04,2.140400e-04,2.737200e-04,2.868000e-04, & - &8.348400e-06,1.429500e-04,2.276500e-04,2.872700e-04,2.894500e-04, & - &1.160300e-05,1.540700e-04,2.402200e-04,2.991800e-04,2.905400e-04/ - data absb(601:900,3) / & - &1.852500e-06,8.863600e-05,1.501500e-04,1.993200e-04,2.258500e-04, & - &2.959300e-06,9.789400e-05,1.624900e-04,2.117000e-04,2.314800e-04, & - &4.501800e-06,1.070600e-04,1.744400e-04,2.237000e-04,2.354300e-04, & - &6.538300e-06,1.161500e-04,1.855900e-04,2.349200e-04,2.379100e-04, & - &9.129600e-06,1.252300e-04,1.959300e-04,2.447800e-04,2.391100e-04, & - &1.417100e-06,7.180700e-05,1.220600e-04,1.623300e-04,1.848100e-04, & - &2.280400e-06,7.937900e-05,1.322400e-04,1.727100e-04,1.897900e-04, & - &3.491300e-06,8.686700e-05,1.420400e-04,1.827000e-04,1.933500e-04, & - &5.102400e-06,9.429400e-05,1.511900e-04,1.920100e-04,1.956600e-04, & - &7.160300e-06,1.017200e-04,1.597000e-04,2.001500e-04,1.968900e-04, & - &1.083600e-06,5.816600e-05,9.921500e-05,1.322200e-04,1.513300e-04, & - &1.755500e-06,6.434500e-05,1.075800e-04,1.408800e-04,1.557000e-04, & - &2.706200e-06,7.047700e-05,1.156400e-04,1.492100e-04,1.589000e-04, & - &3.979500e-06,7.654600e-05,1.231600e-04,1.569300e-04,1.610300e-04, & - &5.612800e-06,8.262600e-05,1.301800e-04,1.636300e-04,1.623000e-04, & - &7.844500e-07,4.658500e-05,7.990200e-05,1.069200e-04,1.232100e-04, & - &1.286600e-06,5.163400e-05,8.680200e-05,1.141700e-04,1.270800e-04, & - &2.007300e-06,5.665600e-05,9.347800e-05,1.211400e-04,1.299800e-04, & - &2.983700e-06,6.162800e-05,9.968900e-05,1.275800e-04,1.320100e-04, & - &4.247400e-06,6.660100e-05,1.055200e-04,1.331800e-04,1.332600e-04, & - &5.620000e-07,3.723900e-05,6.424500e-05,8.633800e-05,1.002100e-04, & - &9.342300e-07,4.136500e-05,6.992200e-05,9.238700e-05,1.036200e-04, & - &1.475900e-06,4.547300e-05,7.544200e-05,9.821100e-05,1.062300e-04, & - &2.220400e-06,4.954800e-05,8.060300e-05,1.036200e-04,1.081100e-04, & - &3.194100e-06,5.361600e-05,8.544200e-05,1.083100e-04,1.093300e-04, & - &4.011100e-07,2.974300e-05,5.160800e-05,6.966000e-05,8.145300e-05, & - &6.758800e-07,3.312000e-05,5.629500e-05,7.472600e-05,8.445200e-05, & - &1.081500e-06,3.648100e-05,6.086100e-05,7.958700e-05,8.680200e-05, & - &1.647200e-06,3.981800e-05,6.513500e-05,8.409500e-05,8.853500e-05, & - &2.395300e-06,4.315000e-05,6.916300e-05,8.805300e-05,8.970700e-05, & - &2.763400e-07,2.358600e-05,4.120800e-05,5.591600e-05,6.598000e-05, & - &4.733900e-07,2.634900e-05,4.508200e-05,6.017100e-05,6.865500e-05, & - &7.694600e-07,2.909500e-05,4.885800e-05,6.422800e-05,7.076900e-05, & - &1.189900e-06,3.183100e-05,5.241900e-05,6.802000e-05,7.239200e-05, & - &1.754200e-06,3.456000e-05,5.576900e-05,7.137300e-05,7.352000e-05, & - &1.867700e-07,1.863000e-05,3.279000e-05,4.474800e-05,5.332500e-05, & - &3.254500e-07,2.087800e-05,3.598100e-05,4.830400e-05,5.570200e-05, & - &5.381200e-07,2.313200e-05,3.911900e-05,5.170700e-05,5.762500e-05, & - &8.462400e-07,2.537800e-05,4.209400e-05,5.490400e-05,5.911700e-05, & - &1.267000e-06,2.760500e-05,4.487300e-05,5.774000e-05,6.021000e-05, & - &1.257000e-07,1.469700e-05,2.605500e-05,3.575700e-05,4.304300e-05, & - &2.222800e-07,1.653100e-05,2.869600e-05,3.874000e-05,4.516800e-05, & - &3.742500e-07,1.837500e-05,3.128600e-05,4.158400e-05,4.689200e-05, & - &5.985100e-07,2.021000e-05,3.376500e-05,4.427500e-05,4.827300e-05, & - &9.106400e-07,2.204300e-05,3.608600e-05,4.668600e-05,4.930600e-05, & - &8.315100e-08,1.154500e-05,2.062200e-05,2.847500e-05,3.464300e-05, & - &1.490900e-07,1.303800e-05,2.280400e-05,3.096800e-05,3.653800e-05, & - &2.558900e-07,1.455200e-05,2.495800e-05,3.336800e-05,3.809600e-05, & - &4.166800e-07,1.605000e-05,2.701700e-05,3.562600e-05,3.935800e-05, & - &6.451800e-07,1.755400e-05,2.895700e-05,3.767200e-05,4.033100e-05, & - &5.354000e-08,9.004400e-06,1.621900e-05,2.254700e-05,2.773900e-05, & - &9.702900e-08,1.021800e-05,1.802500e-05,2.463500e-05,2.943000e-05, & - &1.698200e-07,1.145400e-05,1.980600e-05,2.665100e-05,3.083600e-05, & - &2.822800e-07,1.268100e-05,2.152200e-05,2.855200e-05,3.198400e-05, & - &4.459300e-07,1.391100e-05,2.314600e-05,3.029800e-05,3.290200e-05, & - &3.455700e-08,7.008400e-06,1.273100e-05,1.781700e-05,2.217000e-05, & - &6.274300e-08,7.991900e-06,1.421600e-05,1.955400e-05,2.366300e-05, & - &1.116900e-07,8.999400e-06,1.568800e-05,2.124600e-05,2.493000e-05, & - &1.897000e-07,1.000900e-05,1.712100e-05,2.285500e-05,2.597700e-05, & - &3.057800e-07,1.101300e-05,1.847900e-05,2.433700e-05,2.683000e-05/ - data absb(901:1175,3) / & - &2.250200e-08,5.440300e-06,9.970100e-06,1.404300e-05,1.768500e-05, & - &4.040700e-08,6.238600e-06,1.118700e-05,1.548900e-05,1.899900e-05, & - &7.290300e-08,7.059200e-06,1.240800e-05,1.690900e-05,2.013800e-05, & - &1.264300e-07,7.887400e-06,1.360200e-05,1.826500e-05,2.109300e-05, & - &2.080300e-07,8.709000e-06,1.473400e-05,1.952300e-05,2.188500e-05, & - &1.509500e-08,4.228700e-06,7.812100e-06,1.107000e-05,1.407800e-05, & - &2.642700e-08,4.876600e-06,8.810500e-06,1.227600e-05,1.522200e-05, & - &4.799100e-08,5.544300e-06,9.819200e-06,1.346000e-05,1.622700e-05, & - &8.467500e-08,6.221500e-06,1.081100e-05,1.460000e-05,1.707800e-05, & - &1.421300e-07,6.895700e-06,1.175700e-05,1.566800e-05,1.779700e-05, & - &1.040900e-08,3.286300e-06,6.116400e-06,8.717700e-06,1.117900e-05, & - &1.747500e-08,3.810100e-06,6.934300e-06,9.720900e-06,1.217200e-05, & - &3.165200e-08,4.354600e-06,7.768300e-06,1.070800e-05,1.304800e-05, & - &5.666400e-08,4.907500e-06,8.589100e-06,1.166300e-05,1.380200e-05, & - &9.697800e-08,5.460600e-06,9.378500e-06,1.256600e-05,1.443800e-05, & - &7.373000e-09,2.548100e-06,4.778100e-06,6.848000e-06,8.855100e-06, & - &1.166500e-08,2.970700e-06,5.448000e-06,7.682600e-06,9.718000e-06, & - &2.083900e-08,3.413600e-06,6.133400e-06,8.501700e-06,1.047600e-05, & - &3.770200e-08,3.865100e-06,6.813300e-06,9.302900e-06,1.114400e-05, & - &6.571900e-08,4.317800e-06,7.471500e-06,1.006400e-05,1.170900e-05, & - &5.375000e-09,1.971000e-06,3.722200e-06,5.365200e-06,6.998500e-06, & - &7.911200e-09,2.310500e-06,4.269600e-06,6.056900e-06,7.745000e-06, & - &1.372700e-08,2.671100e-06,4.833200e-06,6.737600e-06,8.404000e-06, & - &2.494500e-08,3.039100e-06,5.395400e-06,7.407800e-06,8.992200e-06, & - &4.418400e-08,3.409500e-06,5.943300e-06,8.047500e-06,9.495700e-06, & - &4.065300e-09,1.528700e-06,2.905300e-06,4.207800e-06,5.513700e-06, & - &5.561300e-09,1.801700e-06,3.352900e-06,4.782000e-06,6.150600e-06, & - &9.252600e-09,2.094100e-06,3.814300e-06,5.346200e-06,6.712700e-06, & - &1.674000e-08,2.395200e-06,4.279600e-06,5.905100e-06,7.216400e-06, & - &3.003100e-08,2.697900e-06,4.733800e-06,6.440300e-06,7.652400e-06, & - &3.154000e-09,1.185800e-06,2.267000e-06,3.296700e-06,4.328300e-06, & - &4.019600e-09,1.405100e-06,2.633200e-06,3.774100e-06,4.867800e-06, & - &6.337900e-09,1.642300e-06,3.010400e-06,4.241300e-06,5.345500e-06, & - &1.131200e-08,1.887700e-06,3.393500e-06,4.705200e-06,5.768900e-06, & - &2.047700e-08,2.135800e-06,3.770900e-06,5.153700e-06,6.141700e-06, & - &2.488500e-09,9.175100e-07,1.764200e-06,2.575100e-06,3.388000e-06, & - &2.972000e-09,1.094200e-06,2.064100e-06,2.972300e-06,3.844000e-06, & - &4.398800e-09,1.285700e-06,2.371600e-06,3.359600e-06,4.250600e-06, & - &7.654700e-09,1.485900e-06,2.687700e-06,3.743800e-06,4.606500e-06, & - &1.391100e-08,1.688800e-06,2.999700e-06,4.118500e-06,4.923200e-06, & - &1.988600e-09,7.076300e-07,1.368300e-06,2.004100e-06,2.642800e-06, & - &2.250400e-09,8.503500e-07,1.614500e-06,2.335300e-06,3.028300e-06, & - &3.105700e-09,1.004700e-06,1.865000e-06,2.656400e-06,3.373100e-06, & - &5.198700e-09,1.167400e-06,2.124800e-06,2.974000e-06,3.674500e-06, & - &9.415500e-09,1.333500e-06,2.382500e-06,3.286900e-06,3.942400e-06, & - &1.606800e-09,5.459600e-07,1.061000e-06,1.558700e-06,2.058200e-06, & - &1.745900e-09,6.615600e-07,1.263100e-06,1.834300e-06,2.382400e-06, & - &2.252400e-09,7.854500e-07,1.467400e-06,2.100500e-06,2.673300e-06, & - &3.589900e-09,9.179900e-07,1.680600e-06,2.363000e-06,2.929600e-06, & - &6.428100e-09,1.053800e-06,1.893300e-06,2.623700e-06,3.154200e-06, & - &1.311500e-09,4.365500e-07,8.499500e-07,1.249800e-06,1.642700e-06, & - &1.406300e-09,5.310400e-07,1.016100e-06,1.477600e-06,1.908700e-06, & - &1.767000e-09,6.322100e-07,1.183900e-06,1.697500e-06,2.146900e-06, & - &2.753800e-09,7.406400e-07,1.359100e-06,1.914300e-06,2.356300e-06, & - &4.896600e-09,8.519400e-07,1.534300e-06,2.130000e-06,2.537200e-06/ - data absb(1:300,4) / & - &1.483200e-04,1.569800e-02,2.843400e-02,4.000000e-02,5.053500e-02, & - &2.735400e-04,1.767900e-02,3.147600e-02,4.363400e-02,5.437300e-02, & - &4.751400e-04,1.976800e-02,3.449800e-02,4.711300e-02,5.789600e-02, & - &7.657500e-04,2.193400e-02,3.743100e-02,5.036400e-02,6.090100e-02, & - &1.145800e-03,2.414800e-02,4.026400e-02,5.323100e-02,6.325100e-02, & - &1.335000e-04,1.378200e-02,2.485700e-02,3.487000e-02,4.357300e-02, & - &2.459300e-04,1.554700e-02,2.750900e-02,3.800100e-02,4.677600e-02, & - &4.250600e-04,1.740900e-02,3.012200e-02,4.094400e-02,4.947400e-02, & - &6.792700e-04,1.932600e-02,3.259400e-02,4.351900e-02,5.152700e-02, & - &1.007600e-03,2.125500e-02,3.489900e-02,4.567000e-02,5.295100e-02, & - &1.206500e-04,1.202400e-02,2.158200e-02,3.017600e-02,3.737100e-02, & - &2.220700e-04,1.358000e-02,2.384500e-02,3.279500e-02,3.988700e-02, & - &3.807700e-04,1.519100e-02,2.600000e-02,3.511600e-02,4.176400e-02, & - &6.025700e-04,1.681600e-02,2.797900e-02,3.704600e-02,4.307000e-02, & - &8.859900e-04,1.841800e-02,2.979900e-02,3.865300e-02,4.391400e-02, & - &1.093100e-04,1.041900e-02,1.858700e-02,2.588700e-02,3.183300e-02, & - &2.006200e-04,1.175200e-02,2.044300e-02,2.796200e-02,3.365900e-02, & - &3.406100e-04,1.309500e-02,2.214800e-02,2.972100e-02,3.493900e-02, & - &5.334100e-04,1.442600e-02,2.372400e-02,3.118900e-02,3.580700e-02, & - &7.770700e-04,1.574000e-02,2.519400e-02,3.244300e-02,3.634200e-02, & - &9.878700e-05,8.948800e-03,1.584300e-02,2.196800e-02,2.681200e-02, & - &1.803400e-04,1.005300e-02,1.731200e-02,2.356300e-02,2.810500e-02, & - &3.033000e-04,1.115000e-02,1.867700e-02,2.491800e-02,2.901000e-02, & - &4.691500e-04,1.223900e-02,1.996000e-02,2.608300e-02,2.961600e-02, & - &6.786000e-04,1.332500e-02,2.117100e-02,2.708900e-02,2.996200e-02, & - &8.911500e-05,7.611400e-03,1.336400e-02,1.846100e-02,2.237100e-02, & - &1.615100e-04,8.514600e-03,1.454200e-02,1.970600e-02,2.331800e-02, & - &2.685300e-04,9.415700e-03,1.566000e-02,2.078100e-02,2.398200e-02, & - &4.102000e-04,1.031000e-02,1.671200e-02,2.172100e-02,2.441600e-02, & - &5.902900e-04,1.121200e-02,1.771500e-02,2.253700e-02,2.464300e-02, & - &8.009500e-05,6.423100e-03,1.119600e-02,1.541400e-02,1.854900e-02, & - &1.438200e-04,7.166200e-03,1.215900e-02,1.640300e-02,1.925900e-02, & - &2.362300e-04,7.904700e-03,1.308000e-02,1.727100e-02,1.975400e-02, & - &3.568700e-04,8.644400e-03,1.394400e-02,1.803600e-02,2.006500e-02, & - &5.116900e-04,9.392400e-03,1.477200e-02,1.871000e-02,2.021300e-02, & - &7.249200e-05,5.403500e-03,9.358700e-03,1.283100e-02,1.534200e-02, & - &1.284300e-04,6.013800e-03,1.015000e-02,1.362700e-02,1.588200e-02, & - &2.080000e-04,6.621200e-03,1.090500e-02,1.433400e-02,1.625400e-02, & - &3.113900e-04,7.233400e-03,1.161500e-02,1.495900e-02,1.647800e-02, & - &4.456100e-04,7.856800e-03,1.229900e-02,1.551600e-02,1.657400e-02, & - &6.533500e-05,4.529000e-03,7.806300e-03,1.065500e-02,1.266200e-02, & - &1.141900e-04,5.031600e-03,8.454900e-03,1.130200e-02,1.307700e-02, & - &1.825700e-04,5.532300e-03,9.071800e-03,1.188000e-02,1.335700e-02, & - &2.715000e-04,6.038200e-03,9.657100e-03,1.239200e-02,1.352000e-02, & - &3.880100e-04,6.562000e-03,1.022000e-02,1.284900e-02,1.358200e-02, & - &6.092200e-05,3.813900e-03,6.535700e-03,8.871400e-03,1.046100e-02, & - &1.045400e-04,4.227700e-03,7.063700e-03,9.396900e-03,1.077400e-02, & - &1.644400e-04,4.641400e-03,7.568900e-03,9.865800e-03,1.098000e-02, & - &2.425500e-04,5.064000e-03,8.049100e-03,1.027900e-02,1.109300e-02, & - &3.454500e-04,5.501900e-03,8.512200e-03,1.065400e-02,1.112500e-02, & - &5.668900e-05,3.206700e-03,5.463400e-03,7.382600e-03,8.631600e-03, & - &9.555000e-05,3.548300e-03,5.895900e-03,7.807700e-03,8.867500e-03, & - &1.482200e-04,3.890100e-03,6.308000e-03,8.182900e-03,9.016000e-03, & - &2.169300e-04,4.243800e-03,6.702000e-03,8.521200e-03,9.093200e-03, & - &3.073400e-04,4.609100e-03,7.087300e-03,8.825600e-03,9.105000e-03, & - &5.273600e-05,2.694900e-03,4.564100e-03,6.141600e-03,7.116400e-03, & - &8.737200e-05,2.976400e-03,4.918600e-03,6.481700e-03,7.290400e-03, & - &1.339000e-04,3.262000e-03,5.255700e-03,6.785600e-03,7.398200e-03, & - &1.944600e-04,3.556100e-03,5.579700e-03,7.059900e-03,7.446400e-03, & - &2.734500e-04,3.859600e-03,5.898200e-03,7.305700e-03,7.443800e-03/ - data absb(301:600,4) / & - &4.916500e-05,2.265200e-03,3.812400e-03,5.105500e-03,5.862300e-03, & - &8.006800e-05,2.498300e-03,4.102700e-03,5.380000e-03,5.991500e-03, & - &1.211400e-04,2.736000e-03,4.378500e-03,5.625500e-03,6.067300e-03, & - &1.745200e-04,2.980700e-03,4.646000e-03,5.847300e-03,6.095700e-03, & - &2.429700e-04,3.233600e-03,4.907400e-03,6.047000e-03,6.084500e-03, & - &4.613400e-05,1.906500e-03,3.187600e-03,4.245700e-03,4.828500e-03, & - &7.372300e-05,2.099800e-03,3.424000e-03,4.466800e-03,4.922700e-03, & - &1.099200e-04,2.297100e-03,3.650800e-03,4.665000e-03,4.974700e-03, & - &1.568700e-04,2.500900e-03,3.870100e-03,4.843900e-03,4.988400e-03, & - &2.159700e-04,2.713200e-03,4.085700e-03,5.007200e-03,4.972700e-03, & - &4.315600e-05,1.604500e-03,2.664200e-03,3.529300e-03,3.975300e-03, & - &6.761000e-05,1.764500e-03,2.857700e-03,3.707300e-03,4.043500e-03, & - &9.930200e-05,1.928300e-03,3.043400e-03,3.867500e-03,4.078300e-03, & - &1.403500e-04,2.098700e-03,3.223800e-03,4.012600e-03,4.082700e-03, & - &1.911200e-04,2.279000e-03,3.402600e-03,4.144500e-03,4.064500e-03, & - &4.015100e-05,1.349600e-03,2.225600e-03,2.931800e-03,3.270900e-03, & - &6.169300e-05,1.482100e-03,2.384200e-03,3.075600e-03,3.320300e-03, & - &8.931400e-05,1.618300e-03,2.536300e-03,3.205200e-03,3.342300e-03, & - &1.250300e-04,1.762100e-03,2.685000e-03,3.322900e-03,3.341900e-03, & - &1.684700e-04,1.915900e-03,2.834600e-03,3.429800e-03,3.323400e-03, & - &3.720400e-05,1.135700e-03,1.860500e-03,2.436400e-03,2.692500e-03, & - &5.612600e-05,1.245300e-03,1.989600e-03,2.551900e-03,2.727600e-03, & - &8.032900e-05,1.359600e-03,2.115000e-03,2.657600e-03,2.741700e-03, & - &1.111900e-04,1.482100e-03,2.237900e-03,2.752600e-03,2.737600e-03, & - &1.483500e-04,1.613500e-03,2.365300e-03,2.840200e-03,2.720900e-03, & - &3.427800e-05,9.554100e-04,1.554800e-03,2.024200e-03,2.216400e-03, & - &5.080200e-05,1.046500e-03,1.660700e-03,2.117900e-03,2.241100e-03, & - &7.201600e-05,1.143300e-03,1.763100e-03,2.202700e-03,2.249100e-03, & - &9.852200e-05,1.248400e-03,1.867100e-03,2.280700e-03,2.244400e-03, & - &1.303700e-04,1.359000e-03,1.975200e-03,2.352800e-03,2.228900e-03, & - &3.146000e-05,8.037700e-04,1.299400e-03,1.681800e-03,1.825200e-03, & - &4.587700e-05,8.801400e-04,1.385900e-03,1.757500e-03,1.842700e-03, & - &6.441700e-05,9.635600e-04,1.471400e-03,1.826900e-03,1.847600e-03, & - &8.718100e-05,1.052500e-03,1.559600e-03,1.890200e-03,1.842200e-03, & - &1.145300e-04,1.145000e-03,1.651600e-03,1.951300e-03,1.828600e-03, & - &2.874600e-05,6.765000e-04,1.086000e-03,1.397600e-03,1.503600e-03, & - &4.132200e-05,7.416200e-04,1.157000e-03,1.458800e-03,1.515700e-03, & - &5.745300e-05,8.129500e-04,1.229100e-03,1.515200e-03,1.518400e-03, & - &7.706000e-05,8.876000e-04,1.304100e-03,1.567600e-03,1.513000e-03, & - &1.005500e-04,9.644700e-04,1.381600e-03,1.620100e-03,1.501100e-03, & - &2.614900e-05,5.698600e-04,9.074400e-04,1.161100e-03,1.238800e-03, & - &3.718700e-05,6.259000e-04,9.664500e-04,1.210900e-03,1.247500e-03, & - &5.112200e-05,6.862000e-04,1.027800e-03,1.256700e-03,1.248800e-03, & - &6.799200e-05,7.486300e-04,1.091600e-03,1.301500e-03,1.243900e-03, & - &8.826400e-05,8.116500e-04,1.156000e-03,1.346700e-03,1.233900e-03, & - &2.338300e-05,4.791400e-04,7.565600e-04,9.632700e-04,1.020100e-03, & - &3.295200e-05,5.269800e-04,8.064700e-04,1.003800e-03,1.026300e-03, & - &4.489800e-05,5.775900e-04,8.587400e-04,1.042300e-03,1.026800e-03, & - &5.930400e-05,6.290600e-04,9.118400e-04,1.080300e-03,1.022300e-03, & - &7.669700e-05,6.802500e-04,9.651100e-04,1.118600e-03,1.013900e-03, & - &2.013500e-05,3.996100e-04,6.270800e-04,7.956200e-04,8.391500e-04, & - &2.824000e-05,4.398400e-04,6.695300e-04,8.292100e-04,8.443100e-04, & - &3.828400e-05,4.817900e-04,7.133600e-04,8.617600e-04,8.447300e-04, & - &5.038000e-05,5.239900e-04,7.575500e-04,8.943600e-04,8.410500e-04, & - &6.498500e-05,5.653800e-04,8.009600e-04,9.261300e-04,8.339000e-04, & - &1.667200e-05,3.300100e-04,5.165200e-04,6.542900e-04,6.899500e-04, & - &2.335600e-05,3.634100e-04,5.522700e-04,6.823600e-04,6.944700e-04, & - &3.162000e-05,3.979800e-04,5.888000e-04,7.101700e-04,6.951600e-04, & - &4.158600e-05,4.322800e-04,6.253700e-04,7.377100e-04,6.923500e-04, & - &5.361200e-05,4.658100e-04,6.608200e-04,7.642700e-04,6.866900e-04/ - data absb(601:900,4) / & - &1.308700e-05,2.684900e-04,4.211500e-04,5.344200e-04,5.661300e-04, & - &1.838900e-05,2.959600e-04,4.511000e-04,5.581900e-04,5.706000e-04, & - &2.498900e-05,3.242700e-04,4.814400e-04,5.819100e-04,5.717200e-04, & - &3.297500e-05,3.522100e-04,5.117700e-04,6.052500e-04,5.699800e-04, & - &4.260300e-05,3.794900e-04,5.407200e-04,6.273800e-04,5.657100e-04, & - &1.023000e-05,2.181800e-04,3.431600e-04,4.362200e-04,4.645200e-04, & - &1.442800e-05,2.407400e-04,3.681900e-04,4.564000e-04,4.688800e-04, & - &1.969700e-05,2.638900e-04,3.934600e-04,4.766800e-04,4.703700e-04, & - &2.607600e-05,2.866700e-04,4.184700e-04,4.963200e-04,4.694300e-04, & - &3.377200e-05,3.089000e-04,4.421200e-04,5.148800e-04,4.663200e-04, & - &7.995700e-06,1.773400e-04,2.796400e-04,3.560800e-04,3.813700e-04, & - &1.131500e-05,1.957800e-04,3.005600e-04,3.732000e-04,3.854800e-04, & - &1.552100e-05,2.146900e-04,3.215200e-04,3.904400e-04,3.872600e-04, & - &2.062300e-05,2.332700e-04,3.421100e-04,4.069400e-04,3.869600e-04, & - &2.677500e-05,2.514500e-04,3.614600e-04,4.225800e-04,3.847200e-04, & - &6.005900e-06,1.425500e-04,2.260800e-04,2.891300e-04,3.119500e-04, & - &8.560300e-06,1.575900e-04,2.435000e-04,3.036700e-04,3.160200e-04, & - &1.184800e-05,1.730300e-04,2.609200e-04,3.182900e-04,3.180000e-04, & - &1.584800e-05,1.882400e-04,2.779200e-04,3.323300e-04,3.181300e-04, & - &2.065500e-05,2.031700e-04,2.938600e-04,3.455800e-04,3.168000e-04, & - &4.473700e-06,1.144000e-04,1.825400e-04,2.345700e-04,2.549700e-04, & - &6.450100e-06,1.266400e-04,1.970400e-04,2.468500e-04,2.588400e-04, & - &8.990800e-06,1.392300e-04,2.114900e-04,2.592600e-04,2.609700e-04, & - &1.211300e-05,1.517100e-04,2.255200e-04,2.711700e-04,2.615000e-04, & - &1.588200e-05,1.639100e-04,2.386000e-04,2.823200e-04,2.607200e-04, & - &3.319800e-06,9.171800e-05,1.472300e-04,1.901100e-04,2.082900e-04, & - &4.850200e-06,1.017000e-04,1.593100e-04,2.005100e-04,2.119500e-04, & - &6.803900e-06,1.120000e-04,1.713200e-04,2.110800e-04,2.141400e-04, & - &9.242600e-06,1.222200e-04,1.828900e-04,2.211700e-04,2.149500e-04, & - &1.219500e-05,1.322100e-04,1.936700e-04,2.305600e-04,2.146200e-04, & - &2.395300e-06,7.303500e-05,1.181200e-04,1.535000e-04,1.698400e-04, & - &3.561200e-06,8.118700e-05,1.281900e-04,1.623200e-04,1.733000e-04, & - &5.039900e-06,8.954200e-05,1.381300e-04,1.712600e-04,1.755200e-04, & - &6.921400e-06,9.794400e-05,1.477200e-04,1.798400e-04,1.765300e-04, & - &9.208100e-06,1.061500e-04,1.566800e-04,1.878100e-04,1.765900e-04, & - &1.697600e-06,5.792800e-05,9.448100e-05,1.236500e-04,1.382900e-04, & - &2.577600e-06,6.456900e-05,1.028100e-04,1.310700e-04,1.415400e-04, & - &3.691400e-06,7.139500e-05,1.110800e-04,1.386700e-04,1.437600e-04, & - &5.128400e-06,7.825500e-05,1.190500e-04,1.459700e-04,1.449600e-04, & - &6.883900e-06,8.500900e-05,1.265100e-04,1.527400e-04,1.452800e-04, & - &1.193400e-06,4.587700e-05,7.545900e-05,9.946500e-05,1.125200e-04, & - &1.853500e-06,5.131900e-05,8.236600e-05,1.057500e-04,1.155200e-04, & - &2.700800e-06,5.688000e-05,8.924600e-05,1.121600e-04,1.177100e-04, & - &3.783700e-06,6.249400e-05,9.587500e-05,1.183900e-04,1.189900e-04, & - &5.134800e-06,6.802700e-05,1.021000e-04,1.241200e-04,1.195400e-04, & - &8.218200e-07,3.618700e-05,6.009000e-05,7.981800e-05,9.137600e-05, & - &1.311600e-06,4.064200e-05,6.578000e-05,8.512000e-05,9.418400e-05, & - &1.950100e-06,4.518400e-05,7.152000e-05,9.051500e-05,9.627800e-05, & - &2.759600e-06,4.977400e-05,7.704200e-05,9.581600e-05,9.761100e-05, & - &3.792000e-06,5.431600e-05,8.224500e-05,1.007000e-04,9.832100e-05, & - &5.457200e-07,2.835200e-05,4.759000e-05,6.377000e-05,7.393600e-05, & - &9.024900e-07,3.198600e-05,5.225500e-05,6.823800e-05,7.655700e-05, & - &1.376400e-06,3.569100e-05,5.703500e-05,7.276900e-05,7.854700e-05, & - &1.978400e-06,3.944100e-05,6.164300e-05,7.727800e-05,7.992000e-05, & - &2.751800e-06,4.317100e-05,6.601400e-05,8.144300e-05,8.072500e-05, & - &3.561300e-07,2.216700e-05,3.763700e-05,5.085400e-05,5.974100e-05, & - &6.138500e-07,2.512000e-05,4.145100e-05,5.462200e-05,6.217400e-05, & - &9.624500e-07,2.815100e-05,4.540100e-05,5.840900e-05,6.402400e-05, & - &1.413000e-06,3.122000e-05,4.925800e-05,6.223400e-05,6.539700e-05, & - &1.986200e-06,3.426800e-05,5.292200e-05,6.578400e-05,6.627400e-05/ - data absb(901:1175,4) / & - &2.285400e-07,1.730000e-05,2.970500e-05,4.046600e-05,4.819800e-05, & - &4.115200e-07,1.968300e-05,3.282500e-05,4.364900e-05,5.044700e-05, & - &6.660500e-07,2.217500e-05,3.608800e-05,4.682500e-05,5.218100e-05, & - &1.001500e-06,2.468000e-05,3.930500e-05,5.004400e-05,5.351400e-05, & - &1.425300e-06,2.718300e-05,4.238000e-05,5.307300e-05,5.443500e-05, & - &1.467500e-07,1.352400e-05,2.346300e-05,3.219500e-05,3.879600e-05, & - &2.751800e-07,1.544200e-05,2.602000e-05,3.488700e-05,4.083200e-05, & - &4.615300e-07,1.748000e-05,2.869400e-05,3.754100e-05,4.242700e-05, & - &7.109900e-07,1.953500e-05,3.138300e-05,4.025200e-05,4.367600e-05, & - &1.030400e-06,2.159600e-05,3.395900e-05,4.283000e-05,4.458500e-05, & - &9.383000e-08,1.057300e-05,1.852900e-05,2.559400e-05,3.116700e-05, & - &1.825700e-07,1.211300e-05,2.062600e-05,2.786500e-05,3.298300e-05, & - &3.181500e-07,1.377700e-05,2.280700e-05,3.008500e-05,3.443500e-05, & - &5.029600e-07,1.546500e-05,2.504700e-05,3.235200e-05,3.557200e-05, & - &7.437200e-07,1.715000e-05,2.719600e-05,3.453800e-05,3.644200e-05, & - &5.940200e-08,8.253600e-06,1.461300e-05,2.031300e-05,2.499700e-05, & - &1.195000e-07,9.487400e-06,1.632500e-05,2.221800e-05,2.660800e-05, & - &2.166800e-07,1.083900e-05,1.810700e-05,2.408600e-05,2.792700e-05, & - &3.528400e-07,1.222300e-05,1.996000e-05,2.596600e-05,2.896500e-05, & - &5.334800e-07,1.360900e-05,2.175800e-05,2.782200e-05,2.978000e-05, & - &3.734500e-08,6.432400e-06,1.150200e-05,1.608900e-05,2.001400e-05, & - &7.712500e-08,7.421200e-06,1.290000e-05,1.768200e-05,2.144200e-05, & - &1.454200e-07,8.507600e-06,1.435200e-05,1.924600e-05,2.263100e-05, & - &2.452300e-07,9.646000e-06,1.588300e-05,2.081200e-05,2.358500e-05, & - &3.796200e-07,1.078400e-05,1.738200e-05,2.237800e-05,2.434900e-05, & - &2.401800e-08,5.029800e-06,9.072700e-06,1.275700e-05,1.597200e-05, & - &5.028200e-08,5.819100e-06,1.021000e-05,1.408300e-05,1.720200e-05, & - &9.809300e-08,6.693400e-06,1.139800e-05,1.539300e-05,1.824600e-05, & - &1.713600e-07,7.626100e-06,1.265300e-05,1.669500e-05,1.909000e-05, & - &2.715900e-07,8.562000e-06,1.390300e-05,1.801300e-05,1.976800e-05, & - &1.570500e-08,3.936100e-06,7.156000e-06,1.011100e-05,1.271300e-05, & - &3.285200e-08,4.567100e-06,8.083300e-06,1.121500e-05,1.375600e-05, & - &6.599500e-08,5.269100e-06,9.055800e-06,1.230900e-05,1.465800e-05, & - &1.193300e-07,6.030700e-06,1.008200e-05,1.339600e-05,1.539200e-05, & - &1.940700e-07,6.799400e-06,1.112200e-05,1.449700e-05,1.598100e-05, & - &1.042300e-08,3.076400e-06,5.636500e-06,8.003600e-06,1.010700e-05, & - &2.135200e-08,3.582100e-06,6.394700e-06,8.920400e-06,1.098900e-05, & - &4.394100e-08,4.142500e-06,7.186000e-06,9.827500e-06,1.175900e-05, & - &8.221900e-08,4.761200e-06,8.021800e-06,1.073500e-05,1.239900e-05, & - &1.378200e-07,5.393300e-06,8.885900e-06,1.165100e-05,1.291100e-05, & - &7.071600e-09,2.401600e-06,4.433600e-06,6.327300e-06,8.023600e-06, & - &1.386400e-08,2.805800e-06,5.050200e-06,7.082500e-06,8.761600e-06, & - &2.898900e-08,3.252300e-06,5.694900e-06,7.834500e-06,9.420400e-06, & - &5.604900e-08,3.753500e-06,6.376400e-06,8.592600e-06,9.975800e-06, & - &9.711900e-08,4.271700e-06,7.090200e-06,9.351000e-06,1.042200e-05, & - &4.973800e-09,1.877200e-06,3.488900e-06,5.003300e-06,6.367000e-06, & - &9.149100e-09,2.200300e-06,3.990800e-06,5.623400e-06,6.982200e-06, & - &1.920400e-08,2.557700e-06,4.517500e-06,6.248200e-06,7.541100e-06, & - &3.822300e-08,2.960600e-06,5.070800e-06,6.877600e-06,8.017000e-06, & - &6.839800e-08,3.385000e-06,5.659000e-06,7.506200e-06,8.402900e-06, & - &3.873500e-09,1.510700e-06,2.814600e-06,4.042800e-06,5.126900e-06, & - &6.918500e-09,1.773600e-06,3.226600e-06,4.553300e-06,5.626000e-06, & - &1.448400e-08,2.064800e-06,3.658800e-06,5.070400e-06,6.077500e-06, & - &2.910500e-08,2.395200e-06,4.115200e-06,5.593000e-06,6.464800e-06, & - &5.271200e-08,2.743400e-06,4.600400e-06,6.116800e-06,6.776500e-06/ - data absb(1:300,5) / & - &9.520600e-04,3.586700e-02,6.332900e-02,8.827300e-02,1.091900e-01, & - &1.460600e-03,3.949900e-02,6.803800e-02,9.353000e-02,1.139200e-01, & - &2.112200e-03,4.325500e-02,7.275500e-02,9.848500e-02,1.180400e-01, & - &2.934200e-03,4.705500e-02,7.748100e-02,1.032500e-01,1.219400e-01, & - &3.969100e-03,5.099800e-02,8.211100e-02,1.079300e-01,1.255600e-01, & - &8.352900e-04,3.175600e-02,5.590400e-02,7.776300e-02,9.535400e-02, & - &1.270900e-03,3.500900e-02,6.004000e-02,8.237400e-02,9.926200e-02, & - &1.831500e-03,3.833600e-02,6.426900e-02,8.680600e-02,1.029000e-01, & - &2.545000e-03,4.178600e-02,6.852500e-02,9.115500e-02,1.062900e-01, & - &3.451500e-03,4.538100e-02,7.277300e-02,9.539600e-02,1.092800e-01, & - &7.316500e-04,2.792100e-02,4.891400e-02,6.792200e-02,8.266200e-02, & - &1.105200e-03,3.078400e-02,5.260200e-02,7.199000e-02,8.604300e-02, & - &1.589300e-03,3.375200e-02,5.637600e-02,7.592800e-02,8.923500e-02, & - &2.210600e-03,3.689000e-02,6.018900e-02,7.980600e-02,9.198200e-02, & - &3.005300e-03,4.012200e-02,6.400900e-02,8.345000e-02,9.397900e-02, & - &6.393900e-04,2.437100e-02,4.250300e-02,5.890000e-02,7.129000e-02, & - &9.605500e-04,2.687700e-02,4.577300e-02,6.245500e-02,7.425200e-02, & - &1.379400e-03,2.953900e-02,4.911400e-02,6.589800e-02,7.681300e-02, & - &1.921600e-03,3.232100e-02,5.242600e-02,6.909300e-02,7.863200e-02, & - &2.614400e-03,3.514600e-02,5.556700e-02,7.181100e-02,7.961600e-02, & - &5.562100e-04,2.111900e-02,3.670200e-02,5.072900e-02,6.110600e-02, & - &8.323200e-04,2.332400e-02,3.956400e-02,5.376800e-02,6.348200e-02, & - &1.195200e-03,2.564400e-02,4.236800e-02,5.653100e-02,6.519400e-02, & - &1.666400e-03,2.801200e-02,4.505100e-02,5.890700e-02,6.615800e-02, & - &2.269700e-03,3.035500e-02,4.747900e-02,6.087900e-02,6.657400e-02, & - &4.825900e-04,1.818800e-02,3.150300e-02,4.337300e-02,5.194400e-02, & - &7.205300e-04,2.008600e-02,3.387000e-02,4.579500e-02,5.360200e-02, & - &1.034400e-03,2.202400e-02,3.610600e-02,4.786200e-02,5.460100e-02, & - &1.442600e-03,2.395500e-02,3.818700e-02,4.963400e-02,5.510500e-02, & - &1.965200e-03,2.587200e-02,4.012900e-02,5.116500e-02,5.525000e-02, & - &4.179200e-04,1.555100e-02,2.681500e-02,3.674800e-02,4.368500e-02, & - &6.228800e-04,1.712200e-02,2.868100e-02,3.857000e-02,4.472600e-02, & - &8.931400e-04,1.869500e-02,3.043500e-02,4.014500e-02,4.532600e-02, & - &1.245400e-03,2.027200e-02,3.210300e-02,4.153800e-02,4.559200e-02, & - &1.696300e-03,2.186500e-02,3.369200e-02,4.275300e-02,4.558900e-02, & - &3.642000e-04,1.320400e-02,2.262700e-02,3.086900e-02,3.640600e-02, & - &5.412800e-04,1.447800e-02,2.410200e-02,3.226900e-02,3.708600e-02, & - &7.749700e-04,1.576800e-02,2.551300e-02,3.351200e-02,3.745400e-02, & - &1.078800e-03,1.707100e-02,2.687700e-02,3.462800e-02,3.758900e-02, & - &1.468400e-03,1.840900e-02,2.818600e-02,3.559500e-02,3.751300e-02, & - &3.174900e-04,1.112600e-02,1.895700e-02,2.576800e-02,3.015700e-02, & - &4.702300e-04,1.217300e-02,2.014800e-02,2.687800e-02,3.061800e-02, & - &6.717200e-04,1.323300e-02,2.130400e-02,2.787500e-02,3.085200e-02, & - &9.333100e-04,1.432700e-02,2.242300e-02,2.876800e-02,3.090800e-02, & - &1.269400e-03,1.543800e-02,2.350900e-02,2.955800e-02,3.079700e-02, & - &2.840800e-04,9.388300e-03,1.588000e-02,2.149200e-02,2.491600e-02, & - &4.179700e-04,1.024900e-02,1.685500e-02,2.237400e-02,2.522200e-02, & - &5.945300e-04,1.113200e-02,1.780000e-02,2.317000e-02,2.536600e-02, & - &8.230100e-04,1.204700e-02,1.871900e-02,2.389400e-02,2.536500e-02, & - &1.118400e-03,1.297300e-02,1.962900e-02,2.453400e-02,2.523700e-02, & - &2.541800e-04,7.897700e-03,1.326900e-02,1.787400e-02,2.052900e-02, & - &3.714100e-04,8.609200e-03,1.407100e-02,1.858100e-02,2.073500e-02, & - &5.259200e-04,9.350100e-03,1.484200e-02,1.922900e-02,2.081700e-02, & - &7.259600e-04,1.011200e-02,1.561000e-02,1.981300e-02,2.078700e-02, & - &9.868600e-04,1.088800e-02,1.636800e-02,2.034000e-02,2.065800e-02, & - &2.275000e-04,6.631700e-03,1.107500e-02,1.484200e-02,1.688400e-02, & - &3.302600e-04,7.225200e-03,1.172800e-02,1.541500e-02,1.702400e-02, & - &4.657800e-04,7.844000e-03,1.236700e-02,1.594100e-02,1.706300e-02, & - &6.427000e-04,8.480500e-03,1.300800e-02,1.641500e-02,1.701600e-02, & - &8.733900e-04,9.133200e-03,1.363600e-02,1.685500e-02,1.689000e-02/ - data absb(301:600,5) / & - &2.039400e-04,5.563900e-03,9.233900e-03,1.231500e-02,1.387000e-02, & - &2.943900e-04,6.061500e-03,9.769400e-03,1.278000e-02,1.396100e-02, & - &4.140700e-04,6.578400e-03,1.030300e-02,1.320600e-02,1.397500e-02, & - &5.718000e-04,7.112100e-03,1.083500e-02,1.359800e-02,1.391900e-02, & - &7.755700e-04,7.659100e-03,1.136000e-02,1.396300e-02,1.379900e-02, & - &1.838200e-04,4.673700e-03,7.699200e-03,1.021600e-02,1.138800e-02, & - &2.641200e-04,5.089300e-03,8.143000e-03,1.059300e-02,1.144400e-02, & - &3.711200e-04,5.524800e-03,8.588400e-03,1.094200e-02,1.143900e-02, & - &5.120600e-04,5.969600e-03,9.029900e-03,1.126700e-02,1.137800e-02, & - &6.916800e-04,6.426000e-03,9.467500e-03,1.156500e-02,1.126500e-02, & - &1.657100e-04,3.924800e-03,6.417200e-03,8.470100e-03,9.345100e-03, & - &2.375400e-04,4.274700e-03,6.786500e-03,8.778300e-03,9.377100e-03, & - &3.333700e-04,4.637800e-03,7.156700e-03,9.064600e-03,9.360100e-03, & - &4.585800e-04,5.008900e-03,7.524600e-03,9.332600e-03,9.299900e-03, & - &6.168400e-04,5.389900e-03,7.888600e-03,9.580400e-03,9.195600e-03, & - &1.496200e-04,3.296800e-03,5.348600e-03,7.021100e-03,7.665700e-03, & - &2.141400e-04,3.590600e-03,5.654600e-03,7.272700e-03,7.680100e-03, & - &2.995800e-04,3.892700e-03,5.964300e-03,7.509900e-03,7.658200e-03, & - &4.103800e-04,4.201200e-03,6.269300e-03,7.729800e-03,7.598800e-03, & - &5.491400e-04,4.524000e-03,6.572200e-03,7.935900e-03,7.505700e-03, & - &1.356100e-04,2.771600e-03,4.458400e-03,5.820100e-03,6.287200e-03, & - &1.936200e-04,3.016900e-03,4.715500e-03,6.028300e-03,6.292600e-03, & - &2.697700e-04,3.268300e-03,4.971300e-03,6.222100e-03,6.266900e-03, & - &3.673400e-04,3.526900e-03,5.225700e-03,6.404200e-03,6.211800e-03, & - &4.884100e-04,3.803100e-03,5.476900e-03,6.574300e-03,6.130600e-03, & - &1.231100e-04,2.329900e-03,3.717600e-03,4.824100e-03,5.156100e-03, & - &1.749500e-04,2.534400e-03,3.931900e-03,4.995400e-03,5.155500e-03, & - &2.424800e-04,2.744000e-03,4.144800e-03,5.156300e-03,5.129700e-03, & - &3.279800e-04,2.962900e-03,4.355300e-03,5.305400e-03,5.079000e-03, & - &4.329500e-04,3.201700e-03,4.567000e-03,5.446600e-03,5.009500e-03, & - &1.119200e-04,1.959500e-03,3.102400e-03,4.000400e-03,4.231300e-03, & - &1.580000e-04,2.129600e-03,3.280100e-03,4.142100e-03,4.226800e-03, & - &2.175700e-04,2.305400e-03,3.456500e-03,4.273500e-03,4.201700e-03, & - &2.922200e-04,2.494200e-03,3.632800e-03,4.397000e-03,4.157500e-03, & - &3.826100e-04,2.700700e-03,3.814500e-03,4.514600e-03,4.098900e-03, & - &1.016300e-04,1.648100e-03,2.589900e-03,3.318200e-03,3.473300e-03, & - &1.424600e-04,1.790200e-03,2.737100e-03,3.434500e-03,3.466000e-03, & - &1.948000e-04,1.939800e-03,2.883900e-03,3.542700e-03,3.442400e-03, & - &2.595700e-04,2.103500e-03,3.033600e-03,3.646200e-03,3.405000e-03, & - &3.371100e-04,2.280300e-03,3.190800e-03,3.745000e-03,3.356400e-03, & - &9.212600e-05,1.386200e-03,2.161900e-03,2.753300e-03,2.851200e-03, & - &1.281900e-04,1.505900e-03,2.284600e-03,2.849000e-03,2.843500e-03, & - &1.739600e-04,1.635200e-03,2.407900e-03,2.939400e-03,2.822900e-03, & - &2.298800e-04,1.776300e-03,2.536600e-03,3.025300e-03,2.791600e-03, & - &2.964200e-04,1.927000e-03,2.673600e-03,3.111200e-03,2.751500e-03, & - &8.227300e-05,1.162800e-03,1.801800e-03,2.282100e-03,2.340800e-03, & - &1.137700e-04,1.265000e-03,1.903800e-03,2.361600e-03,2.333000e-03, & - &1.532800e-04,1.376700e-03,2.009000e-03,2.436200e-03,2.315400e-03, & - &2.011600e-04,1.496700e-03,2.120500e-03,2.510200e-03,2.289600e-03, & - &2.579400e-04,1.623900e-03,2.237600e-03,2.585000e-03,2.256700e-03, & - &7.098500e-05,9.679200e-04,1.493500e-03,1.886000e-03,1.922400e-03, & - &9.780200e-05,1.055300e-03,1.579100e-03,1.951500e-03,1.916000e-03, & - &1.311400e-04,1.150400e-03,1.669200e-03,2.014900e-03,1.902100e-03, & - &1.714300e-04,1.251500e-03,1.765400e-03,2.078600e-03,1.881400e-03, & - &2.191000e-04,1.357600e-03,1.864600e-03,2.145300e-03,1.855100e-03, & - &5.903500e-05,7.989200e-04,1.230800e-03,1.552300e-03,1.579500e-03, & - &8.121700e-05,8.730500e-04,1.302600e-03,1.607800e-03,1.574900e-03, & - &1.087400e-04,9.528600e-04,1.380000e-03,1.661700e-03,1.564400e-03, & - &1.419800e-04,1.037400e-03,1.461600e-03,1.716900e-03,1.548200e-03, & - &1.813200e-04,1.124900e-03,1.545000e-03,1.775000e-03,1.527900e-03/ - data absb(601:900,5) / & - &4.664100e-05,6.509900e-04,1.005600e-03,1.271400e-03,1.297200e-03, & - &6.434800e-05,7.129200e-04,1.066000e-03,1.318100e-03,1.295100e-03, & - &8.636200e-05,7.791700e-04,1.131400e-03,1.364100e-03,1.287700e-03, & - &1.130900e-04,8.491300e-04,1.199900e-03,1.411800e-03,1.275700e-03, & - &1.447500e-04,9.209700e-04,1.269800e-03,1.461900e-03,1.260100e-03, & - &3.672300e-05,5.300500e-04,8.208900e-04,1.040600e-03,1.065600e-03, & - &5.080900e-05,5.816000e-04,8.717300e-04,1.080200e-03,1.065400e-03, & - &6.841100e-05,6.367100e-04,9.270200e-04,1.119100e-03,1.060200e-03, & - &8.983700e-05,6.944700e-04,9.846900e-04,1.160300e-03,1.051700e-03, & - &1.153100e-04,7.532500e-04,1.043100e-03,1.203200e-03,1.039800e-03, & - &2.889800e-05,4.315800e-04,6.702400e-04,8.516700e-04,8.758600e-04, & - &4.010700e-05,4.745000e-04,7.129100e-04,8.850700e-04,8.767000e-04, & - &5.416800e-05,5.202100e-04,7.596100e-04,9.181500e-04,8.735400e-04, & - &7.135400e-05,5.678900e-04,8.081600e-04,9.542500e-04,8.678700e-04, & - &9.182500e-05,6.159500e-04,8.569300e-04,9.908000e-04,8.587900e-04, & - &2.192600e-05,3.479200e-04,5.436300e-04,6.940600e-04,7.184200e-04, & - &3.061300e-05,3.833400e-04,5.792300e-04,7.221400e-04,7.201100e-04, & - &4.159500e-05,4.210700e-04,6.183500e-04,7.506100e-04,7.187100e-04, & - &5.510800e-05,4.601600e-04,6.589300e-04,7.810900e-04,7.146300e-04, & - &7.127500e-05,4.994000e-04,6.998000e-04,8.126400e-04,7.080000e-04, & - &1.652700e-05,2.799400e-04,4.404100e-04,5.650400e-04,5.889200e-04, & - &2.324000e-05,3.091700e-04,4.700500e-04,5.888700e-04,5.914000e-04, & - &3.177900e-05,3.402500e-04,5.027400e-04,6.129500e-04,5.909500e-04, & - &4.234500e-05,3.722900e-04,5.366900e-04,6.391200e-04,5.884500e-04, & - &5.508800e-05,4.042900e-04,5.708500e-04,6.658700e-04,5.835600e-04, & - &1.242900e-05,2.251400e-04,3.566600e-04,4.597800e-04,4.826800e-04, & - &1.761700e-05,2.492200e-04,3.813000e-04,4.800000e-04,4.855400e-04, & - &2.423400e-05,2.747700e-04,4.086200e-04,5.004200e-04,4.859300e-04, & - &3.248800e-05,3.010000e-04,4.370600e-04,5.227500e-04,4.845600e-04, & - &4.251600e-05,3.271300e-04,4.654900e-04,5.455900e-04,4.811500e-04, & - &9.128800e-06,1.799000e-04,2.876300e-04,3.730700e-04,3.952900e-04, & - &1.307000e-05,1.995500e-04,3.079000e-04,3.899700e-04,3.982600e-04, & - &1.812300e-05,2.205100e-04,3.305700e-04,4.073100e-04,3.993500e-04, & - &2.448900e-05,2.420100e-04,3.543300e-04,4.261400e-04,3.987600e-04, & - &3.228000e-05,2.633600e-04,3.781300e-04,4.457700e-04,3.966900e-04, & - &6.615100e-06,1.432600e-04,2.313800e-04,3.020400e-04,3.233600e-04, & - &9.582200e-06,1.592700e-04,2.480900e-04,3.164400e-04,3.265100e-04, & - &1.341000e-05,1.763900e-04,2.668200e-04,3.309600e-04,3.280900e-04, & - &1.827600e-05,1.939700e-04,2.866400e-04,3.469700e-04,3.282300e-04, & - &2.428600e-05,2.115100e-04,3.064300e-04,3.634900e-04,3.269800e-04, & - &4.773400e-06,1.140300e-04,1.860400e-04,2.444200e-04,2.644900e-04, & - &6.999600e-06,1.269300e-04,1.997300e-04,2.564400e-04,2.676200e-04, & - &9.898200e-06,1.409100e-04,2.151300e-04,2.686500e-04,2.694400e-04, & - &1.360300e-05,1.553300e-04,2.316500e-04,2.821100e-04,2.701000e-04, & - &1.822400e-05,1.697600e-04,2.481600e-04,2.962100e-04,2.696300e-04, & - &3.398300e-06,9.047300e-05,1.492100e-04,1.973200e-04,2.160400e-04, & - &5.051400e-06,1.008400e-04,1.604500e-04,2.075200e-04,2.191600e-04, & - &7.227100e-06,1.122300e-04,1.730500e-04,2.177500e-04,2.211700e-04, & - &1.002600e-05,1.240500e-04,1.867800e-04,2.290600e-04,2.222400e-04, & - &1.355400e-05,1.359200e-04,2.005000e-04,2.409900e-04,2.222600e-04, & - &2.365000e-06,7.141700e-05,1.191900e-04,1.588200e-04,1.761100e-04, & - &3.567900e-06,7.965000e-05,1.283800e-04,1.674800e-04,1.791900e-04, & - &5.177800e-06,8.889200e-05,1.386300e-04,1.759900e-04,1.812800e-04, & - &7.263600e-06,9.853200e-05,1.499500e-04,1.853200e-04,1.825700e-04, & - &9.920000e-06,1.082900e-04,1.613400e-04,1.954300e-04,1.829600e-04, & - &1.634600e-06,5.633500e-05,9.510900e-05,1.276900e-04,1.434200e-04, & - &2.503800e-06,6.285400e-05,1.026100e-04,1.349300e-04,1.463600e-04, & - &3.689600e-06,7.029600e-05,1.109400e-04,1.420900e-04,1.485100e-04, & - &5.240600e-06,7.814600e-05,1.202000e-04,1.497800e-04,1.499200e-04, & - &7.229100e-06,8.617000e-05,1.296600e-04,1.583200e-04,1.506400e-04/ - data absb(901:1175,5) / & - &1.121300e-06,4.439900e-05,7.582900e-05,1.025400e-04,1.167100e-04, & - &1.746500e-06,4.956500e-05,8.195400e-05,1.086300e-04,1.195400e-04, & - &2.614600e-06,5.548500e-05,8.864700e-05,1.146000e-04,1.216400e-04, & - &3.763100e-06,6.190000e-05,9.624600e-05,1.209700e-04,1.231500e-04, & - &5.247800e-06,6.848600e-05,1.041100e-04,1.281000e-04,1.241200e-04, & - &7.721900e-07,3.506000e-05,6.050100e-05,8.233300e-05,9.479900e-05, & - &1.224300e-06,3.917100e-05,6.550800e-05,8.744400e-05,9.743300e-05, & - &1.860100e-06,4.389800e-05,7.097100e-05,9.248100e-05,9.944300e-05, & - &2.713800e-06,4.911300e-05,7.714200e-05,9.777400e-05,1.009300e-04, & - &3.827000e-06,5.450400e-05,8.366600e-05,1.037200e-04,1.019700e-04, & - &5.302400e-07,2.769600e-05,4.826100e-05,6.608300e-05,7.689200e-05, & - &8.573500e-07,3.098300e-05,5.236800e-05,7.041200e-05,7.928900e-05, & - &1.321800e-06,3.473800e-05,5.682400e-05,7.460900e-05,8.118000e-05, & - &1.955900e-06,3.896100e-05,6.183300e-05,7.899800e-05,8.259600e-05, & - &2.789700e-06,4.337200e-05,6.722100e-05,8.392700e-05,8.363600e-05, & - &3.610800e-07,2.186600e-05,3.845400e-05,5.296900e-05,6.233500e-05, & - &5.966700e-07,2.449300e-05,4.183700e-05,5.662500e-05,6.448300e-05, & - &9.348400e-07,2.746500e-05,4.544800e-05,6.012600e-05,6.624600e-05, & - &1.403600e-06,3.087700e-05,4.951700e-05,6.378900e-05,6.757800e-05, & - &2.026800e-06,3.447900e-05,5.393500e-05,6.785500e-05,6.860200e-05, & - &2.433200e-07,1.724400e-05,3.059700e-05,4.240500e-05,5.049800e-05, & - &4.121400e-07,1.934500e-05,3.339000e-05,4.548000e-05,5.242200e-05, & - &6.573000e-07,2.170900e-05,3.632900e-05,4.841500e-05,5.404300e-05, & - &1.001600e-06,2.443400e-05,3.960000e-05,5.143900e-05,5.530100e-05, & - &1.465600e-06,2.736800e-05,4.322700e-05,5.479000e-05,5.629200e-05, & - &1.651100e-07,1.363000e-05,2.437800e-05,3.397900e-05,4.079400e-05, & - &2.868800e-07,1.532600e-05,2.669400e-05,3.655600e-05,4.247200e-05, & - &4.658800e-07,1.720800e-05,2.908900e-05,3.902600e-05,4.389100e-05, & - &7.201200e-07,1.938900e-05,3.174200e-05,4.153300e-05,4.502300e-05, & - &1.067200e-06,2.177600e-05,3.470800e-05,4.430500e-05,4.591700e-05, & - &1.119200e-07,1.078400e-05,1.943300e-05,2.722700e-05,3.288100e-05, & - &1.996600e-07,1.215200e-05,2.134100e-05,2.938500e-05,3.433100e-05, & - &3.305200e-07,1.365400e-05,2.330000e-05,3.145800e-05,3.554600e-05, & - &5.184000e-07,1.539500e-05,2.545000e-05,3.353100e-05,3.653800e-05, & - &7.780800e-07,1.733300e-05,2.786800e-05,3.581300e-05,3.730400e-05, & - &7.512200e-08,8.524400e-06,1.547700e-05,2.178600e-05,2.647300e-05, & - &1.380000e-07,9.627100e-06,1.704100e-05,2.358700e-05,2.773400e-05, & - &2.332800e-07,1.083200e-05,1.865400e-05,2.533300e-05,2.877300e-05, & - &3.717500e-07,1.221700e-05,2.039500e-05,2.705000e-05,2.963700e-05, & - &5.652900e-07,1.378500e-05,2.235800e-05,2.893400e-05,3.030000e-05, & - &4.991100e-08,6.733400e-06,1.231500e-05,1.741100e-05,2.129200e-05, & - &9.456400e-08,7.620800e-06,1.359500e-05,1.891200e-05,2.238700e-05, & - &1.636100e-07,8.590000e-06,1.492200e-05,2.037900e-05,2.327900e-05, & - &2.653300e-07,9.689600e-06,1.633300e-05,2.180600e-05,2.402400e-05, & - &4.089600e-07,1.095500e-05,1.792300e-05,2.335700e-05,2.460500e-05, & - &3.341300e-08,5.322300e-06,9.799700e-06,1.391100e-05,1.711500e-05, & - &6.487600e-08,6.038900e-06,1.085000e-05,1.516400e-05,1.805700e-05, & - &1.150100e-07,6.820200e-06,1.194200e-05,1.639600e-05,1.882400e-05, & - &1.898800e-07,7.696200e-06,1.309300e-05,1.758900e-05,1.946100e-05, & - &2.967000e-07,8.715500e-06,1.437800e-05,1.886200e-05,1.996700e-05, & - &2.532600e-08,4.305900e-06,7.947900e-06,1.129600e-05,1.387200e-05, & - &4.957000e-08,4.893300e-06,8.813800e-06,1.233800e-05,1.464200e-05, & - &8.875900e-08,5.532300e-06,9.714700e-06,1.336000e-05,1.526700e-05, & - &1.476700e-07,6.248400e-06,1.066600e-05,1.435800e-05,1.577500e-05, & - &2.320700e-07,7.084700e-06,1.172800e-05,1.542200e-05,1.617800e-05/ - data absb(1:300,6) / & - &2.646900e-03,7.260300e-02,1.289800e-01,1.808000e-01,2.225300e-01, & - &4.041000e-03,7.806200e-02,1.354600e-01,1.873600e-01,2.276700e-01, & - &5.907600e-03,8.414200e-02,1.423300e-01,1.938000e-01,2.326900e-01, & - &8.315900e-03,9.055000e-02,1.495200e-01,2.002700e-01,2.373700e-01, & - &1.133800e-02,9.697300e-02,1.569200e-01,2.066400e-01,2.417400e-01, & - &2.345900e-03,6.514600e-02,1.156100e-01,1.620500e-01,1.981300e-01, & - &3.574200e-03,7.030900e-02,1.218300e-01,1.683700e-01,2.031000e-01, & - &5.215600e-03,7.595300e-02,1.283000e-01,1.746200e-01,2.077900e-01, & - &7.329700e-03,8.176800e-02,1.350600e-01,1.809000e-01,2.120600e-01, & - &9.979300e-03,8.778500e-02,1.419200e-01,1.868800e-01,2.159700e-01, & - &2.081500e-03,5.807000e-02,1.029000e-01,1.440300e-01,1.751800e-01, & - &3.161600e-03,6.287700e-02,1.087100e-01,1.500300e-01,1.798300e-01, & - &4.599000e-03,6.803400e-02,1.147400e-01,1.560000e-01,1.841300e-01, & - &6.445700e-03,7.335700e-02,1.209400e-01,1.618400e-01,1.881100e-01, & - &8.768800e-03,7.895400e-02,1.271800e-01,1.674300e-01,1.918400e-01, & - &1.843400e-03,5.143100e-02,9.090400e-02,1.269500e-01,1.537300e-01, & - &2.788300e-03,5.585300e-02,9.620200e-02,1.325500e-01,1.580500e-01, & - &4.040500e-03,6.048400e-02,1.017400e-01,1.380900e-01,1.620900e-01, & - &5.654500e-03,6.538800e-02,1.074200e-01,1.434600e-01,1.659400e-01, & - &7.694800e-03,7.055700e-02,1.131700e-01,1.487600e-01,1.694400e-01, & - &1.622800e-03,4.521400e-02,7.962800e-02,1.109500e-01,1.338200e-01, & - &2.444400e-03,4.920100e-02,8.444900e-02,1.161000e-01,1.378200e-01, & - &3.534100e-03,5.340300e-02,8.952000e-02,1.211500e-01,1.416600e-01, & - &4.944200e-03,5.789900e-02,9.465700e-02,1.261000e-01,1.451600e-01, & - &6.731400e-03,6.260500e-02,9.993400e-02,1.307800e-01,1.475900e-01, & - &1.421500e-03,3.949000e-02,6.923100e-02,9.624300e-02,1.156800e-01, & - &2.134600e-03,4.304500e-02,7.360500e-02,1.008900e-01,1.194100e-01, & - &3.082400e-03,4.685500e-02,7.819000e-02,1.054700e-01,1.227700e-01, & - &4.315500e-03,5.088700e-02,8.278900e-02,1.096600e-01,1.251600e-01, & - &5.877300e-03,5.510000e-02,8.724600e-02,1.131900e-01,1.260700e-01, & - &1.239600e-03,3.427300e-02,5.981700e-02,8.293500e-02,9.941900e-02, & - &1.858000e-03,3.743900e-02,6.378700e-02,8.707300e-02,1.026100e-01, & - &2.684200e-03,4.082700e-02,6.773800e-02,9.082200e-02,1.049100e-01, & - &3.759600e-03,4.430800e-02,7.151700e-02,9.393200e-02,1.059300e-01, & - &5.110600e-03,4.790100e-02,7.497800e-02,9.635100e-02,1.058800e-01, & - &1.086300e-03,2.963600e-02,5.150600e-02,7.109400e-02,8.491300e-02, & - &1.625100e-03,3.241300e-02,5.487300e-02,7.443600e-02,8.712900e-02, & - &2.348200e-03,3.525500e-02,5.805100e-02,7.719800e-02,8.829000e-02, & - &3.283000e-03,3.815400e-02,6.096300e-02,7.939100e-02,8.853400e-02, & - &4.449600e-03,4.110500e-02,6.367000e-02,8.121200e-02,8.809600e-02, & - &9.515500e-04,2.547700e-02,4.402300e-02,6.040500e-02,7.174500e-02, & - &1.422700e-03,2.777900e-02,4.670200e-02,6.288700e-02,7.300600e-02, & - &2.051300e-03,3.009900e-02,4.916700e-02,6.489400e-02,7.352100e-02, & - &2.858800e-03,3.246500e-02,5.144800e-02,6.658600e-02,7.341600e-02, & - &3.861200e-03,3.492700e-02,5.367000e-02,6.802600e-02,7.285000e-02, & - &8.571300e-04,2.183200e-02,3.742000e-02,5.094400e-02,6.000200e-02, & - &1.275800e-03,2.368800e-02,3.949500e-02,5.277200e-02,6.067200e-02, & - &1.829100e-03,2.559000e-02,4.142800e-02,5.432200e-02,6.082900e-02, & - &2.533700e-03,2.755600e-02,4.328600e-02,5.566400e-02,6.055500e-02, & - &3.406000e-03,2.965300e-02,4.513100e-02,5.679900e-02,5.994200e-02, & - &7.730800e-04,1.854100e-02,3.154100e-02,4.265300e-02,4.978400e-02, & - &1.143600e-03,2.006000e-02,3.317700e-02,4.407100e-02,5.013500e-02, & - &1.628700e-03,2.163600e-02,3.474300e-02,4.530900e-02,5.010800e-02, & - &2.243300e-03,2.330100e-02,3.627600e-02,4.636900e-02,4.976900e-02, & - &3.001500e-03,2.509300e-02,3.782000e-02,4.728400e-02,4.916100e-02, & - &6.982000e-04,1.566200e-02,2.645100e-02,3.556900e-02,4.110300e-02, & - &1.025200e-03,1.691600e-02,2.776600e-02,3.670500e-02,4.126900e-02, & - &1.450300e-03,1.824300e-02,2.905000e-02,3.768000e-02,4.114800e-02, & - &1.986000e-03,1.966500e-02,3.032800e-02,3.853000e-02,4.078700e-02, & - &2.646900e-03,2.118800e-02,3.163700e-02,3.927700e-02,4.022000e-02/ - data absb(301:600,6) / & - &6.317000e-04,1.319100e-02,2.211300e-02,2.959400e-02,3.383200e-02, & - &9.200100e-04,1.424000e-02,2.318800e-02,3.049600e-02,3.388300e-02, & - &1.292800e-03,1.537000e-02,2.424900e-02,3.127300e-02,3.371600e-02, & - &1.760300e-03,1.657300e-02,2.532900e-02,3.196000e-02,3.336300e-02, & - &2.340200e-03,1.786900e-02,2.644300e-02,3.259000e-02,3.285900e-02, & - &5.741900e-04,1.109700e-02,1.846100e-02,2.458700e-02,2.779100e-02, & - &8.292400e-04,1.198700e-02,1.934300e-02,2.529700e-02,2.777000e-02, & - &1.156500e-03,1.294500e-02,2.023300e-02,2.592800e-02,2.758400e-02, & - &1.568300e-03,1.397200e-02,2.115600e-02,2.649200e-02,2.725600e-02, & - &2.081400e-03,1.507600e-02,2.209900e-02,2.703600e-02,2.681500e-02, & - &5.208500e-04,9.326200e-03,1.539000e-02,2.039400e-02,2.279500e-02, & - &7.461100e-04,1.008300e-02,1.612400e-02,2.096400e-02,2.274000e-02, & - &1.034500e-03,1.089700e-02,1.688200e-02,2.147700e-02,2.255000e-02, & - &1.399700e-03,1.177400e-02,1.766300e-02,2.195400e-02,2.225500e-02, & - &1.854000e-03,1.271100e-02,1.846600e-02,2.242100e-02,2.187400e-02, & - &4.715400e-04,7.835000e-03,1.282000e-02,1.689800e-02,1.868300e-02, & - &6.704100e-04,8.479100e-03,1.344100e-02,1.736200e-02,1.860600e-02, & - &9.261300e-04,9.172900e-03,1.408400e-02,1.778700e-02,1.842700e-02, & - &1.251100e-03,9.918800e-03,1.474600e-02,1.819900e-02,1.816800e-02, & - &1.652800e-03,1.071500e-02,1.543200e-02,1.859700e-02,1.784100e-02, & - &4.272800e-04,6.587200e-03,1.068200e-02,1.399700e-02,1.530600e-02, & - &6.039800e-04,7.136600e-03,1.120900e-02,1.437700e-02,1.522100e-02, & - &8.327500e-04,7.727700e-03,1.175400e-02,1.474000e-02,1.506000e-02, & - &1.121900e-03,8.362500e-03,1.231800e-02,1.508800e-02,1.483300e-02, & - &1.475200e-03,9.042000e-03,1.290200e-02,1.543400e-02,1.455500e-02, & - &3.869500e-04,5.539000e-03,8.902300e-03,1.159200e-02,1.253700e-02, & - &5.451900e-04,6.008900e-03,9.348700e-03,1.191100e-02,1.245100e-02, & - &7.499700e-04,6.511800e-03,9.813300e-03,1.221900e-02,1.230700e-02, & - &1.005700e-03,7.054100e-03,1.029300e-02,1.251700e-02,1.211100e-02, & - &1.315900e-03,7.636000e-03,1.079100e-02,1.281300e-02,1.187600e-02, & - &3.513500e-04,4.663500e-03,7.424100e-03,9.603800e-03,1.026900e-02, & - &4.939400e-04,5.064200e-03,7.804500e-03,9.873600e-03,1.018700e-02, & - &6.764100e-04,5.494000e-03,8.198800e-03,1.013500e-02,1.006100e-02, & - &9.023400e-04,5.956500e-03,8.608100e-03,1.039200e-02,9.896000e-03, & - &1.174200e-03,6.460500e-03,9.035900e-03,1.064600e-02,9.700600e-03, & - &3.200100e-04,3.930800e-03,6.194700e-03,7.962600e-03,8.409700e-03, & - &4.482900e-04,4.272000e-03,6.520300e-03,8.190500e-03,8.336400e-03, & - &6.102400e-04,4.638700e-03,6.854700e-03,8.412200e-03,8.227400e-03, & - &8.090600e-04,5.037500e-03,7.207100e-03,8.633000e-03,8.090200e-03, & - &1.046400e-03,5.482300e-03,7.579200e-03,8.852300e-03,7.928900e-03, & - &2.918700e-04,3.316200e-03,5.175900e-03,6.605900e-03,6.890000e-03, & - &4.064300e-04,3.607500e-03,5.452300e-03,6.798000e-03,6.825100e-03, & - &5.499600e-04,3.921600e-03,5.739100e-03,6.988100e-03,6.733100e-03, & - &7.243800e-04,4.270300e-03,6.042400e-03,7.176200e-03,6.618700e-03, & - &9.306000e-04,4.664300e-03,6.370200e-03,7.368100e-03,6.487800e-03, & - &2.629600e-04,2.791000e-03,4.318400e-03,5.476100e-03,5.645000e-03, & - &3.641700e-04,3.039200e-03,4.555100e-03,5.640300e-03,5.589800e-03, & - &4.897700e-04,3.310400e-03,4.800100e-03,5.802600e-03,5.512900e-03, & - &6.410900e-04,3.617600e-03,5.064900e-03,5.964900e-03,5.418800e-03, & - &8.180400e-04,3.962100e-03,5.354600e-03,6.135400e-03,5.312800e-03, & - &2.291000e-04,2.331300e-03,3.588600e-03,4.528900e-03,4.630000e-03, & - &3.161800e-04,2.541300e-03,3.788500e-03,4.669600e-03,4.585100e-03, & - &4.236500e-04,2.776000e-03,3.999200e-03,4.808500e-03,4.522300e-03, & - &5.520900e-04,3.043500e-03,4.229000e-03,4.949900e-03,4.447300e-03, & - &7.012600e-04,3.341300e-03,4.485800e-03,5.101900e-03,4.362200e-03, & - &1.922000e-04,1.929300e-03,2.964500e-03,3.734700e-03,3.802100e-03, & - &2.651500e-04,2.106900e-03,3.134500e-03,3.854600e-03,3.766300e-03, & - &3.549100e-04,2.308400e-03,3.314700e-03,3.974600e-03,3.718100e-03, & - &4.614800e-04,2.537600e-03,3.514200e-03,4.098900e-03,3.659000e-03, & - &5.853500e-04,2.791100e-03,3.737500e-03,4.233300e-03,3.591400e-03/ - data absb(601:900,6) / & - &1.530500e-04,1.576000e-03,2.430200e-03,3.065300e-03,3.124700e-03, & - &2.120400e-04,1.723900e-03,2.571900e-03,3.167700e-03,3.098900e-03, & - &2.846500e-04,1.893700e-03,2.724300e-03,3.271200e-03,3.062500e-03, & - &3.709300e-04,2.086300e-03,2.895500e-03,3.379100e-03,3.016700e-03, & - &4.714600e-04,2.299200e-03,3.086500e-03,3.496800e-03,2.964000e-03, & - &1.213600e-04,1.285900e-03,1.990600e-03,2.515000e-03,2.568800e-03, & - &1.688700e-04,1.409600e-03,2.109700e-03,2.602800e-03,2.550900e-03, & - &2.275300e-04,1.552300e-03,2.238500e-03,2.692300e-03,2.524000e-03, & - &2.972100e-04,1.713900e-03,2.383700e-03,2.785200e-03,2.488900e-03, & - &3.785800e-04,1.892300e-03,2.547100e-03,2.888800e-03,2.447900e-03, & - &9.616700e-05,1.049500e-03,1.630300e-03,2.063600e-03,2.113200e-03, & - &1.344000e-04,1.152800e-03,1.730400e-03,2.138900e-03,2.100900e-03, & - &1.817000e-04,1.273000e-03,1.838800e-03,2.215300e-03,2.081300e-03, & - &2.379300e-04,1.408600e-03,1.964000e-03,2.296200e-03,2.054900e-03, & - &3.038900e-04,1.558100e-03,2.103000e-03,2.387000e-03,2.023700e-03, & - &7.336100e-05,8.482400e-04,1.327100e-03,1.686600e-03,1.736200e-03, & - &1.033600e-04,9.334400e-04,1.410000e-03,1.751000e-03,1.728700e-03, & - &1.407300e-04,1.033000e-03,1.501200e-03,1.816400e-03,1.714900e-03, & - &1.853500e-04,1.145700e-03,1.606500e-03,1.885800e-03,1.695300e-03, & - &2.379400e-04,1.270100e-03,1.724200e-03,1.964200e-03,1.671500e-03, & - &5.553600e-05,6.845800e-04,1.079000e-03,1.377400e-03,1.425700e-03, & - &7.896500e-05,7.544800e-04,1.147900e-03,1.432300e-03,1.422000e-03, & - &1.083700e-04,8.369200e-04,1.223900e-03,1.487900e-03,1.412600e-03, & - &1.437100e-04,9.302200e-04,1.312700e-03,1.547400e-03,1.398300e-03, & - &1.854300e-04,1.033500e-03,1.411700e-03,1.614900e-03,1.380400e-03, & - &4.192700e-05,5.522300e-04,8.766100e-04,1.124200e-03,1.170500e-03, & - &6.015600e-05,6.096100e-04,9.342300e-04,1.171000e-03,1.169500e-03, & - &8.325800e-05,6.777800e-04,9.975900e-04,1.218700e-03,1.163700e-03, & - &1.111900e-04,7.550100e-04,1.072000e-03,1.269100e-03,1.153400e-03, & - &1.443100e-04,8.405200e-04,1.155400e-03,1.327100e-03,1.139900e-03, & - &3.087100e-05,4.429500e-04,7.096100e-04,9.150100e-04,9.605900e-04, & - &4.481400e-05,4.893900e-04,7.570000e-04,9.549400e-04,9.615200e-04, & - &6.269300e-05,5.452100e-04,8.096100e-04,9.951000e-04,9.584900e-04, & - &8.451500e-05,6.087400e-04,8.713300e-04,1.038100e-03,9.516800e-04, & - &1.104900e-04,6.792900e-04,9.414200e-04,1.087300e-03,9.417600e-04, & - &2.240500e-05,3.541900e-04,5.730000e-04,7.433000e-04,7.876700e-04, & - &3.296600e-05,3.917500e-04,6.123200e-04,7.773800e-04,7.904000e-04, & - &4.667300e-05,4.370600e-04,6.554600e-04,8.113800e-04,7.893700e-04, & - &6.358500e-05,4.891400e-04,7.065600e-04,8.474100e-04,7.849500e-04, & - &8.387100e-05,5.468200e-04,7.647500e-04,8.889400e-04,7.779200e-04, & - &1.618700e-05,2.831100e-04,4.624500e-04,6.034800e-04,6.457400e-04, & - &2.412800e-05,3.132700e-04,4.946200e-04,6.322700e-04,6.492900e-04, & - &3.459800e-05,3.499300e-04,5.301300e-04,6.609700e-04,6.497800e-04, & - &4.768000e-05,3.926200e-04,5.722400e-04,6.913700e-04,6.473600e-04, & - &6.347700e-05,4.398900e-04,6.208000e-04,7.264100e-04,6.426500e-04, & - &1.152000e-05,2.256400e-04,3.722200e-04,4.888400e-04,5.286500e-04, & - &1.743400e-05,2.498600e-04,3.988200e-04,5.133300e-04,5.329900e-04, & - &2.533600e-05,2.792800e-04,4.279000e-04,5.377400e-04,5.347300e-04, & - &3.539100e-05,3.140800e-04,4.624700e-04,5.631600e-04,5.338300e-04, & - &4.762600e-05,3.526800e-04,5.027500e-04,5.925100e-04,5.308900e-04, & - &7.992400e-06,1.790100e-04,2.985500e-04,3.947700e-04,4.322000e-04, & - &1.230900e-05,1.983300e-04,3.205500e-04,4.156300e-04,4.369500e-04, & - &1.818100e-05,2.216200e-04,3.440700e-04,4.361800e-04,4.394500e-04, & - &2.579300e-05,2.496500e-04,3.720200e-04,4.573300e-04,4.396600e-04, & - &3.514700e-05,2.810700e-04,4.051900e-04,4.816500e-04,4.381000e-04, & - &5.498900e-06,1.419200e-04,2.392200e-04,3.184300e-04,3.531100e-04, & - &8.631500e-06,1.573000e-04,2.572600e-04,3.361000e-04,3.579200e-04, & - &1.296600e-05,1.757200e-04,2.764500e-04,3.534300e-04,3.609500e-04, & - &1.868100e-05,1.981700e-04,2.990000e-04,3.710500e-04,3.619700e-04, & - &2.582600e-05,2.236200e-04,3.261000e-04,3.910500e-04,3.614500e-04/ - data absb(901:1175,6) / & - &3.749600e-06,1.124400e-04,1.914600e-04,2.565600e-04,2.882900e-04, & - &6.009600e-06,1.247000e-04,2.063200e-04,2.714500e-04,2.930800e-04, & - &9.182700e-06,1.392100e-04,2.219700e-04,2.860400e-04,2.963000e-04, & - &1.344500e-05,1.571000e-04,2.401000e-04,3.008000e-04,2.980400e-04, & - &1.887300e-05,1.777000e-04,2.621400e-04,3.172600e-04,2.983800e-04, & - &2.567100e-06,8.920200e-05,1.533200e-04,2.067500e-04,2.350100e-04, & - &4.198200e-06,9.903000e-05,1.655200e-04,2.192300e-04,2.394500e-04, & - &6.526700e-06,1.105500e-04,1.784100e-04,2.316300e-04,2.428300e-04, & - &9.711100e-06,1.248200e-04,1.931500e-04,2.440100e-04,2.448600e-04, & - &1.383400e-05,1.414800e-04,2.111400e-04,2.576400e-04,2.457500e-04, & - &1.753100e-06,7.082400e-05,1.228200e-04,1.666500e-04,1.914900e-04, & - &2.926000e-06,7.872600e-05,1.328900e-04,1.770300e-04,1.954900e-04, & - &4.632800e-06,8.788200e-05,1.434200e-04,1.875200e-04,1.987100e-04, & - &7.004600e-06,9.922900e-05,1.553800e-04,1.979100e-04,2.008700e-04, & - &1.013000e-05,1.126600e-04,1.699600e-04,2.091400e-04,2.020200e-04, & - &1.188100e-06,5.617400e-05,9.825200e-05,1.341700e-04,1.558800e-04, & - &2.025700e-06,6.255000e-05,1.065600e-04,1.428000e-04,1.595200e-04, & - &3.268600e-06,6.984500e-05,1.152200e-04,1.516300e-04,1.625100e-04, & - &5.026300e-06,7.880700e-05,1.249100e-04,1.603700e-04,1.647500e-04, & - &7.380800e-06,8.961600e-05,1.367600e-04,1.696600e-04,1.660600e-04, & - &7.983200e-07,4.454200e-05,7.858400e-05,1.080000e-04,1.269100e-04, & - &1.390700e-06,4.965700e-05,8.537100e-05,1.150900e-04,1.301500e-04, & - &2.289400e-06,5.548400e-05,9.250700e-05,1.225100e-04,1.329300e-04, & - &3.581600e-06,6.252400e-05,1.003300e-04,1.298100e-04,1.351000e-04, & - &5.346100e-06,7.117900e-05,1.098600e-04,1.375100e-04,1.365300e-04, & - &5.426600e-07,3.538000e-05,6.293200e-05,8.700900e-05,1.030700e-04, & - &9.627400e-07,3.951900e-05,6.850700e-05,9.285900e-05,1.059000e-04, & - &1.616000e-06,4.419900e-05,7.436400e-05,9.903400e-05,1.083400e-04, & - &2.571100e-06,4.978600e-05,8.077100e-05,1.052000e-04,1.103200e-04, & - &3.898000e-06,5.670600e-05,8.845300e-05,1.115700e-04,1.116800e-04, & - &3.699300e-07,2.815100e-05,5.044700e-05,7.015400e-05,8.362800e-05, & - &6.671200e-07,3.148800e-05,5.500000e-05,7.492500e-05,8.602100e-05, & - &1.141500e-06,3.524300e-05,5.980300e-05,8.005400e-05,8.807700e-05, & - &1.847100e-06,3.968500e-05,6.504000e-05,8.521900e-05,8.979500e-05, & - &2.843600e-06,4.521600e-05,7.123600e-05,9.053700e-05,9.103600e-05, & - &2.512000e-07,2.238400e-05,4.040800e-05,5.652700e-05,6.781800e-05, & - &4.592900e-07,2.505200e-05,4.408900e-05,6.038900e-05,6.983100e-05, & - &8.016700e-07,2.808800e-05,4.806600e-05,6.467400e-05,7.160400e-05, & - &1.320100e-06,3.162600e-05,5.234500e-05,6.899700e-05,7.306700e-05, & - &2.065900e-06,3.602400e-05,5.733800e-05,7.341700e-05,7.420700e-05, & - &1.700400e-07,1.778200e-05,3.234500e-05,4.552500e-05,5.497500e-05, & - &3.141000e-07,1.993300e-05,3.533500e-05,4.866000e-05,5.667800e-05, & - &5.592400e-07,2.236800e-05,3.859500e-05,5.219300e-05,5.818000e-05, & - &9.382600e-07,2.519200e-05,4.209000e-05,5.580900e-05,5.944600e-05, & - &1.492600e-06,2.867700e-05,4.612500e-05,5.948400e-05,6.045500e-05, & - &1.157700e-07,1.415800e-05,2.593200e-05,3.670000e-05,4.457000e-05, & - &2.158700e-07,1.587500e-05,2.834500e-05,3.923300e-05,4.600300e-05, & - &3.913500e-07,1.783500e-05,3.100500e-05,4.212200e-05,4.726200e-05, & - &6.685700e-07,2.010100e-05,3.387300e-05,4.514700e-05,4.833600e-05, & - &1.080600e-06,2.286100e-05,3.714800e-05,4.822100e-05,4.921500e-05, & - &8.830400e-08,1.150600e-05,2.111500e-05,2.992600e-05,3.629300e-05, & - &1.655000e-07,1.291200e-05,2.310500e-05,3.203100e-05,3.744300e-05, & - &3.024000e-07,1.452900e-05,2.531000e-05,3.443100e-05,3.844600e-05, & - &5.208100e-07,1.639400e-05,2.769200e-05,3.694900e-05,3.929000e-05, & - &8.477000e-07,1.868000e-05,3.044400e-05,3.954600e-05,3.997200e-05/ - data absb(1:300,7) / & - &7.641700e-03,1.468500e-01,2.641600e-01,3.686400e-01,4.610900e-01, & - &1.152100e-02,1.545400e-01,2.725100e-01,3.768800e-01,4.633400e-01, & - &1.661300e-02,1.627300e-01,2.804200e-01,3.845300e-01,4.655300e-01, & - &2.302800e-02,1.723200e-01,2.885000e-01,3.913300e-01,4.672600e-01, & - &3.078800e-02,1.835600e-01,2.974100e-01,3.974500e-01,4.677400e-01, & - &6.782600e-03,1.358400e-01,2.441400e-01,3.406000e-01,4.227400e-01, & - &1.024800e-02,1.431500e-01,2.522400e-01,3.488700e-01,4.254000e-01, & - &1.477500e-02,1.512400e-01,2.604000e-01,3.564900e-01,4.276200e-01, & - &2.042900e-02,1.608400e-01,2.690700e-01,3.633300e-01,4.293700e-01, & - &2.729700e-02,1.716700e-01,2.781700e-01,3.702000e-01,4.304900e-01, & - &6.055300e-03,1.244100e-01,2.231800e-01,3.113100e-01,3.838700e-01, & - &9.137400e-03,1.314800e-01,2.311600e-01,3.193600e-01,3.869200e-01, & - &1.312300e-02,1.395900e-01,2.395100e-01,3.268300e-01,3.893800e-01, & - &1.810100e-02,1.489600e-01,2.483600e-01,3.340400e-01,3.914100e-01, & - &2.417500e-02,1.591100e-01,2.577700e-01,3.414100e-01,3.931500e-01, & - &5.413100e-03,1.128300e-01,2.018600e-01,2.815500e-01,3.452700e-01, & - &8.128800e-03,1.197200e-01,2.098100e-01,2.892800e-01,3.486200e-01, & - &1.162700e-02,1.277300e-01,2.181200e-01,2.966800e-01,3.516200e-01, & - &1.600900e-02,1.367100e-01,2.269300e-01,3.042300e-01,3.543900e-01, & - &2.137300e-02,1.462500e-01,2.364800e-01,3.120200e-01,3.567900e-01, & - &4.814900e-03,1.014600e-01,1.808000e-01,2.519000e-01,3.073800e-01, & - &7.192400e-03,1.081600e-01,1.885600e-01,2.593700e-01,3.111500e-01, & - &1.025400e-02,1.158900e-01,1.967500e-01,2.669200e-01,3.146500e-01, & - &1.409200e-02,1.243600e-01,2.056100e-01,2.745700e-01,3.179200e-01, & - &1.880100e-02,1.334500e-01,2.149300e-01,2.823400e-01,3.211000e-01, & - &4.263300e-03,9.046200e-02,1.604900e-01,2.232700e-01,2.712800e-01, & - &6.337100e-03,9.698300e-02,1.679800e-01,2.305400e-01,2.752600e-01, & - &9.004800e-03,1.043400e-01,1.759600e-01,2.379500e-01,2.791900e-01, & - &1.234900e-02,1.123500e-01,1.845500e-01,2.455800e-01,2.830700e-01, & - &1.647700e-02,1.209500e-01,1.936600e-01,2.534900e-01,2.869800e-01, & - &3.755400e-03,8.008600e-02,1.413000e-01,1.961800e-01,2.372900e-01, & - &5.556500e-03,8.634500e-02,1.484000e-01,2.031600e-01,2.415000e-01, & - &7.870200e-03,9.323600e-02,1.561600e-01,2.104300e-01,2.458100e-01, & - &1.078700e-02,1.008000e-01,1.644900e-01,2.179800e-01,2.500800e-01, & - &1.441300e-02,1.088700e-01,1.733000e-01,2.256500e-01,2.535500e-01, & - &3.311100e-03,7.055700e-02,1.235500e-01,1.711700e-01,2.061500e-01, & - &4.876800e-03,7.646700e-02,1.303900e-01,1.778700e-01,2.105700e-01, & - &6.893700e-03,8.293900e-02,1.378300e-01,1.849100e-01,2.150000e-01, & - &9.456800e-03,8.999700e-02,1.457300e-01,1.919000e-01,2.184700e-01, & - &1.264900e-02,9.739800e-02,1.538000e-01,1.983700e-01,2.202400e-01, & - &2.909500e-03,6.185100e-02,1.074500e-01,1.484400e-01,1.781000e-01, & - &4.269200e-03,6.734400e-02,1.139700e-01,1.547900e-01,1.824800e-01, & - &6.033800e-03,7.335000e-02,1.208600e-01,1.610500e-01,1.859200e-01, & - &8.281800e-03,7.970100e-02,1.278400e-01,1.667100e-01,1.876500e-01, & - &1.108100e-02,8.626300e-02,1.346400e-01,1.715200e-01,1.875600e-01, & - &2.618100e-03,5.428700e-02,9.345000e-02,1.284400e-01,1.533500e-01, & - &3.824300e-03,5.934900e-02,9.939300e-02,1.339300e-01,1.566400e-01, & - &5.393500e-03,6.466600e-02,1.053000e-01,1.387900e-01,1.583400e-01, & - &7.392500e-03,7.013700e-02,1.110200e-01,1.428400e-01,1.584000e-01, & - &9.858100e-03,7.573900e-02,1.163700e-01,1.462600e-01,1.572800e-01, & - &2.356700e-03,4.746600e-02,8.089100e-02,1.102900e-01,1.307300e-01, & - &3.430800e-03,5.187600e-02,8.584300e-02,1.144800e-01,1.324700e-01, & - &4.825700e-03,5.635100e-02,9.062000e-02,1.179500e-01,1.327700e-01, & - &6.595800e-03,6.090000e-02,9.510500e-02,1.209200e-01,1.320700e-01, & - &8.759200e-03,6.558600e-02,9.938300e-02,1.235400e-01,1.306400e-01, & - &2.127100e-03,4.119000e-02,6.939500e-02,9.370700e-02,1.100200e-01, & - &3.085600e-03,4.485200e-02,7.335400e-02,9.671400e-02,1.105700e-01, & - &4.325700e-03,4.852400e-02,7.713000e-02,9.932100e-02,1.102400e-01, & - &5.882600e-03,5.229700e-02,8.073400e-02,1.016600e-01,1.092700e-01, & - &7.771700e-03,5.629500e-02,8.427500e-02,1.037800e-01,1.078200e-01/ - data absb(301:600,7) / & - &1.928100e-03,3.541100e-02,5.899800e-02,7.885200e-02,9.156800e-02, & - &2.782400e-03,3.839300e-02,6.215500e-02,8.113800e-02,9.156100e-02, & - &3.880600e-03,4.143300e-02,6.519400e-02,8.321500e-02,9.098100e-02, & - &5.245300e-03,4.463700e-02,6.816800e-02,8.511900e-02,8.995800e-02, & - &6.897700e-03,4.812000e-02,7.117500e-02,8.685500e-02,8.859500e-02, & - &1.758700e-03,3.021400e-02,4.985100e-02,6.599600e-02,7.571000e-02, & - &2.521000e-03,3.267700e-02,5.239700e-02,6.782900e-02,7.543800e-02, & - &3.492800e-03,3.523900e-02,5.489600e-02,6.952800e-02,7.477700e-02, & - &4.690800e-03,3.802900e-02,5.739700e-02,7.108300e-02,7.380000e-02, & - &6.139500e-03,4.106000e-02,5.998600e-02,7.253100e-02,7.255800e-02, & - &1.602900e-03,2.564200e-02,4.192700e-02,5.506500e-02,6.233200e-02, & - &2.281200e-03,2.770000e-02,4.400800e-02,5.657300e-02,6.196100e-02, & - &3.137200e-03,2.991800e-02,4.609400e-02,5.794800e-02,6.130200e-02, & - &4.189900e-03,3.235400e-02,4.822700e-02,5.923900e-02,6.040700e-02, & - &5.466900e-03,3.499100e-02,5.049400e-02,6.048700e-02,5.931300e-02, & - &1.458700e-03,2.169200e-02,3.515200e-02,4.586800e-02,5.119100e-02, & - &2.060000e-03,2.345200e-02,3.688000e-02,4.708500e-02,5.078800e-02, & - &2.814700e-03,2.539000e-02,3.864200e-02,4.822100e-02,5.017400e-02, & - &3.741600e-03,2.750000e-02,4.050000e-02,4.931800e-02,4.937400e-02, & - &4.875800e-03,2.979600e-02,4.246900e-02,5.041800e-02,4.843000e-02, & - &1.328400e-03,1.833400e-02,2.943000e-02,3.815400e-02,4.197700e-02, & - &1.861500e-03,1.986400e-02,3.087700e-02,3.914700e-02,4.158500e-02, & - &2.527300e-03,2.154800e-02,3.240400e-02,4.010100e-02,4.102400e-02, & - &3.350200e-03,2.338300e-02,3.402700e-02,4.105400e-02,4.032900e-02, & - &4.367800e-03,2.537400e-02,3.573000e-02,4.202100e-02,3.952600e-02, & - &1.207700e-03,1.549800e-02,2.461300e-02,3.170000e-02,3.438500e-02, & - &1.679400e-03,1.683000e-02,2.585900e-02,3.252700e-02,3.401900e-02, & - &2.270000e-03,1.829000e-02,2.719400e-02,3.334200e-02,3.352600e-02, & - &3.007600e-03,1.988400e-02,2.860200e-02,3.417900e-02,3.293400e-02, & - &3.923900e-03,2.161800e-02,3.008300e-02,3.503800e-02,3.226700e-02, & - &1.097900e-03,1.311600e-02,2.059500e-02,2.632700e-02,2.815200e-02, & - &1.516900e-03,1.427200e-02,2.168300e-02,2.702400e-02,2.782600e-02, & - &2.045300e-03,1.553800e-02,2.284300e-02,2.773800e-02,2.740500e-02, & - &2.711600e-03,1.692700e-02,2.406600e-02,2.848300e-02,2.691400e-02, & - &3.539400e-03,1.844200e-02,2.535200e-02,2.923800e-02,2.635700e-02, & - &9.974500e-04,1.111100e-02,1.725400e-02,2.186400e-02,2.304500e-02, & - &1.372000e-03,1.211300e-02,1.820200e-02,2.246600e-02,2.275800e-02, & - &1.849600e-03,1.321500e-02,1.921000e-02,2.310500e-02,2.240500e-02, & - &2.453400e-03,1.442900e-02,2.026900e-02,2.375800e-02,2.199400e-02, & - &3.199400e-03,1.576300e-02,2.139100e-02,2.442400e-02,2.153700e-02, & - &9.060900e-04,9.423300e-03,1.447500e-02,1.816700e-02,1.886300e-02, & - &1.244700e-03,1.029600e-02,1.530000e-02,1.870400e-02,1.862000e-02, & - &1.679000e-03,1.125800e-02,1.617100e-02,1.926700e-02,1.832300e-02, & - &2.225200e-03,1.232400e-02,1.709500e-02,1.984400e-02,1.798500e-02, & - &2.895000e-03,1.352100e-02,1.808200e-02,2.043300e-02,1.761400e-02, & - &8.151400e-04,7.975600e-03,1.213700e-02,1.509900e-02,1.544300e-02, & - &1.120400e-03,8.735600e-03,1.284700e-02,1.557700e-02,1.523700e-02, & - &1.511900e-03,9.575800e-03,1.360400e-02,1.607200e-02,1.499400e-02, & - &2.001200e-03,1.052200e-02,1.441000e-02,1.657900e-02,1.472200e-02, & - &2.599500e-03,1.160200e-02,1.528300e-02,1.709800e-02,1.442500e-02, & - &7.122700e-04,6.701800e-03,1.012700e-02,1.252800e-02,1.266000e-02, & - &9.816299e-04,7.356000e-03,1.073900e-02,1.294800e-02,1.249400e-02, & - &1.326300e-03,8.090900e-03,1.139300e-02,1.338200e-02,1.230200e-02, & - &1.756100e-03,8.924200e-03,1.209600e-02,1.382500e-02,1.208500e-02, & - &2.281000e-03,9.894700e-03,1.287300e-02,1.428400e-02,1.185100e-02, & - &6.020200e-04,5.577900e-03,8.401500e-03,1.036600e-02,1.039600e-02, & - &8.331900e-04,6.140000e-03,8.926000e-03,1.073200e-02,1.026800e-02, & - &1.128700e-03,6.773400e-03,9.488000e-03,1.110900e-02,1.011600e-02, & - &1.498300e-03,7.504000e-03,1.010000e-02,1.149700e-02,9.946600e-03, & - &1.949000e-03,8.363700e-03,1.079100e-02,1.190600e-02,9.763600e-03/ - data absb(601:900,7) / & - &4.841600e-04,4.580400e-03,6.908600e-03,8.535500e-03,8.550800e-03, & - &6.749500e-04,5.052000e-03,7.352700e-03,8.851900e-03,8.452700e-03, & - &9.195200e-04,5.589400e-03,7.832500e-03,9.178200e-03,8.335600e-03, & - &1.227200e-03,6.216100e-03,8.361100e-03,9.517200e-03,8.204500e-03, & - &1.603200e-03,6.960300e-03,8.962900e-03,9.876400e-03,8.063100e-03, & - &3.881500e-04,3.758100e-03,5.677800e-03,7.026100e-03,7.035600e-03, & - &5.448900e-04,4.155300e-03,6.055100e-03,7.300100e-03,6.962000e-03, & - &7.472000e-04,4.609600e-03,6.464600e-03,7.582000e-03,6.873500e-03, & - &1.002500e-03,5.145700e-03,6.921000e-03,7.877300e-03,6.774400e-03, & - &1.315800e-03,5.790700e-03,7.446700e-03,8.193700e-03,6.665000e-03, & - &3.111200e-04,3.083900e-03,4.668000e-03,5.784600e-03,5.791100e-03, & - &4.399000e-04,3.418000e-03,4.988000e-03,6.020500e-03,5.738200e-03, & - &6.070100e-04,3.801400e-03,5.338400e-03,6.264900e-03,5.672900e-03, & - &8.192400e-04,4.264700e-03,5.731800e-03,6.520800e-03,5.599000e-03, & - &1.079400e-03,4.823500e-03,6.190400e-03,6.799700e-03,5.515500e-03, & - &2.399900e-04,2.504500e-03,3.811200e-03,4.741900e-03,4.765900e-03, & - &3.427200e-04,2.780700e-03,4.080700e-03,4.943800e-03,4.728100e-03, & - &4.770900e-04,3.101300e-03,4.377200e-03,5.154200e-03,4.679800e-03, & - &6.487600e-04,3.490500e-03,4.711300e-03,5.375900e-03,4.624700e-03, & - &8.608800e-04,3.966100e-03,5.105100e-03,5.619900e-03,4.561600e-03, & - &1.837300e-04,2.030200e-03,3.108100e-03,3.883800e-03,3.921800e-03, & - &2.652100e-04,2.259300e-03,3.335300e-03,4.056600e-03,3.895000e-03, & - &3.726000e-04,2.525200e-03,3.584700e-03,4.236800e-03,3.860500e-03, & - &5.109500e-04,2.852500e-03,3.868000e-03,4.428400e-03,3.819900e-03, & - &6.830200e-04,3.254000e-03,4.203800e-03,4.640800e-03,3.771800e-03, & - &1.402100e-04,1.644700e-03,2.534000e-03,3.179400e-03,3.227100e-03, & - &2.045700e-04,1.834100e-03,2.724400e-03,3.327000e-03,3.209200e-03, & - &2.901400e-04,2.055600e-03,2.935000e-03,3.482400e-03,3.185400e-03, & - &4.012600e-04,2.328900e-03,3.174000e-03,3.647200e-03,3.155400e-03, & - &5.407200e-04,2.668600e-03,3.460300e-03,3.831500e-03,3.119200e-03, & - &1.041800e-04,1.324100e-03,2.056600e-03,2.594900e-03,2.655500e-03, & - &1.539400e-04,1.479200e-03,2.215800e-03,2.720600e-03,2.644600e-03, & - &2.208900e-04,1.660900e-03,2.391200e-03,2.853000e-03,2.628000e-03, & - &3.084300e-04,1.886100e-03,2.591500e-03,2.994900e-03,2.607300e-03, & - &4.197500e-04,2.169600e-03,2.832600e-03,3.153500e-03,2.580700e-03, & - &7.617900e-05,1.062300e-03,1.664800e-03,2.114100e-03,2.184700e-03, & - &1.142000e-04,1.188700e-03,1.797500e-03,2.220500e-03,2.179100e-03, & - &1.658900e-04,1.336700e-03,1.943500e-03,2.333700e-03,2.168900e-03, & - &2.343100e-04,1.521600e-03,2.109700e-03,2.454600e-03,2.154600e-03, & - &3.220900e-04,1.755300e-03,2.311000e-03,2.590100e-03,2.135400e-03, & - &5.538000e-05,8.519000e-04,1.347000e-03,1.721400e-03,1.797400e-03, & - &8.423000e-05,9.541900e-04,1.457100e-03,1.811000e-03,1.795400e-03, & - &1.239800e-04,1.074700e-03,1.578200e-03,1.907200e-03,1.789500e-03, & - &1.771400e-04,1.225400e-03,1.716100e-03,2.010300e-03,1.780700e-03, & - &2.461500e-04,1.418500e-03,1.883600e-03,2.125500e-03,1.767600e-03, & - &3.960800e-05,6.806500e-04,1.086900e-03,1.398900e-03,1.478000e-03, & - &6.125400e-05,7.635900e-04,1.178000e-03,1.474200e-03,1.478800e-03, & - &9.143400e-05,8.613100e-04,1.278600e-03,1.556100e-03,1.476800e-03, & - &1.323100e-04,9.831400e-04,1.392500e-03,1.643700e-03,1.471900e-03, & - &1.859900e-04,1.141100e-03,1.530900e-03,1.741200e-03,1.463600e-03, & - &2.756500e-05,5.408100e-04,8.734600e-04,1.133700e-03,1.214500e-03, & - &4.344400e-05,6.078200e-04,9.486400e-04,1.196600e-03,1.217300e-03, & - &6.591100e-05,6.859900e-04,1.031300e-03,1.265500e-03,1.217700e-03, & - &9.676700e-05,7.830500e-04,1.124600e-03,1.339700e-03,1.215900e-03, & - &1.378600e-04,9.101700e-04,1.237100e-03,1.421200e-03,1.210700e-03, & - &1.901000e-05,4.293400e-04,7.013900e-04,9.184200e-04,9.978100e-04, & - &3.054700e-05,4.832100e-04,7.629800e-04,9.701500e-04,1.001900e-03, & - &4.717200e-05,5.456600e-04,8.308900e-04,1.028000e-03,1.004100e-03, & - &7.031200e-05,6.227000e-04,9.070400e-04,1.090400e-03,1.004300e-03, & - &1.015800e-04,7.245700e-04,9.983900e-04,1.158400e-03,1.001400e-03/ - data absb(901:1175,7) / & - &1.298900e-05,3.404100e-04,5.625400e-04,7.433600e-04,8.196700e-04, & - &2.128800e-05,3.837500e-04,6.128600e-04,7.856600e-04,8.246200e-04, & - &3.350100e-05,4.337100e-04,6.686900e-04,8.339100e-04,8.279100e-04, & - &5.075700e-05,4.947700e-04,7.309900e-04,8.865000e-04,8.297300e-04, & - &7.439100e-05,5.760300e-04,8.051200e-04,9.437800e-04,8.290200e-04, & - &8.910700e-06,2.702800e-04,4.516500e-04,6.020300e-04,6.722400e-04, & - &1.488900e-05,3.052600e-04,4.928100e-04,6.365600e-04,6.775400e-04, & - &2.387700e-05,3.455400e-04,5.389100e-04,6.769100e-04,6.813900e-04, & - &3.677100e-05,3.944400e-04,5.902000e-04,7.214000e-04,6.841400e-04, & - &5.465500e-05,4.594200e-04,6.505400e-04,7.696800e-04,6.848000e-04, & - &6.096100e-06,2.147600e-04,3.628000e-04,4.876500e-04,5.507800e-04, & - &1.038100e-05,2.430700e-04,3.964200e-04,5.158800e-04,5.562300e-04, & - &1.698200e-05,2.755500e-04,4.345100e-04,5.495500e-04,5.602700e-04, & - &2.658700e-05,3.146600e-04,4.766100e-04,5.869700e-04,5.633700e-04, & - &4.010100e-05,3.665000e-04,5.257000e-04,6.274500e-04,5.647800e-04, & - &4.135300e-06,1.706100e-04,2.914500e-04,3.950100e-04,4.513000e-04, & - &7.181800e-06,1.933500e-04,3.186300e-04,4.179300e-04,4.566300e-04, & - &1.198900e-05,2.195600e-04,3.499400e-04,4.457500e-04,4.607400e-04, & - &1.910200e-05,2.508700e-04,3.845500e-04,4.771000e-04,4.639500e-04, & - &2.926600e-05,2.920800e-04,4.245600e-04,5.111000e-04,4.659000e-04, & - &2.777100e-06,1.354300e-04,2.340200e-04,3.197800e-04,3.697100e-04, & - &4.925600e-06,1.536300e-04,2.558300e-04,3.383000e-04,3.748600e-04, & - &8.392700e-06,1.747700e-04,2.814600e-04,3.611300e-04,3.789200e-04, & - &1.362900e-05,1.997800e-04,3.099600e-04,3.873600e-04,3.822200e-04, & - &2.122400e-05,2.324800e-04,3.425400e-04,4.158300e-04,3.845300e-04, & - &1.881100e-06,1.078300e-04,1.882900e-04,2.591500e-04,3.021000e-04, & - &3.408400e-06,1.224200e-04,2.057800e-04,2.741700e-04,3.067300e-04, & - &5.921200e-06,1.395000e-04,2.268000e-04,2.929200e-04,3.104100e-04, & - &9.796600e-06,1.596600e-04,2.503000e-04,3.148300e-04,3.134200e-04, & - &1.550100e-05,1.857700e-04,2.769300e-04,3.387000e-04,3.156300e-04, & - &1.273600e-06,8.596000e-05,1.516400e-04,2.100900e-04,2.465600e-04, & - &2.359800e-06,9.765500e-05,1.656400e-04,2.222900e-04,2.505900e-04, & - &4.177600e-06,1.114500e-04,1.828400e-04,2.376200e-04,2.537700e-04, & - &7.044100e-06,1.277300e-04,2.021900e-04,2.558800e-04,2.563400e-04, & - &1.132300e-05,1.486400e-04,2.241000e-04,2.759300e-04,2.582700e-04, & - &8.547900e-07,6.849500e-05,1.220900e-04,1.702100e-04,2.011400e-04, & - &1.622500e-06,7.781700e-05,1.332500e-04,1.801500e-04,2.046300e-04, & - &2.927000e-06,8.897000e-05,1.472500e-04,1.926200e-04,2.074300e-04, & - &5.034000e-06,1.021000e-04,1.631800e-04,2.077900e-04,2.096500e-04, & - &8.227900e-06,1.188100e-04,1.811700e-04,2.245500e-04,2.113000e-04, & - &5.683200e-07,5.456800e-05,9.824800e-05,1.377900e-04,1.639400e-04, & - &1.106900e-06,6.198200e-05,1.071200e-04,1.459600e-04,1.670900e-04, & - &2.035300e-06,7.094500e-05,1.184700e-04,1.560400e-04,1.695100e-04, & - &3.573200e-06,8.153000e-05,1.315500e-04,1.685500e-04,1.714200e-04, & - &5.945400e-06,9.489600e-05,1.463100e-04,1.825700e-04,1.728600e-04, & - &3.789000e-07,4.356800e-05,7.916300e-05,1.116100e-04,1.336100e-04, & - &7.570000e-07,4.943100e-05,8.619900e-05,1.183100e-04,1.363800e-04, & - &1.419000e-06,5.665100e-05,9.537900e-05,1.264700e-04,1.384300e-04, & - &2.542200e-06,6.521500e-05,1.061200e-04,1.367700e-04,1.400700e-04, & - &4.305600e-06,7.593900e-05,1.182500e-04,1.484700e-04,1.413200e-04, & - &2.871100e-07,3.551200e-05,6.467600e-05,9.131300e-05,1.090500e-04, & - &5.805100e-07,4.037200e-05,7.055800e-05,9.694000e-05,1.113700e-04, & - &1.100900e-06,4.636800e-05,7.824200e-05,1.038500e-04,1.129800e-04, & - &1.992700e-06,5.352800e-05,8.724700e-05,1.125900e-04,1.141800e-04, & - &3.406000e-06,6.257900e-05,9.749700e-05,1.225100e-04,1.150900e-04/ - data absb(1:300,8) / & - &2.397000e-02,3.071000e-01,5.436400e-01,7.521900e-01,9.546200e-01, & - &3.591000e-02,3.219100e-01,5.598600e-01,7.622100e-01,9.475300e-01, & - &5.131400e-02,3.370400e-01,5.751800e-01,7.725000e-01,9.394400e-01, & - &7.054400e-02,3.521500e-01,5.896500e-01,7.820900e-01,9.318700e-01, & - &9.407200e-02,3.681300e-01,6.032200e-01,7.909500e-01,9.265200e-01, & - &2.139400e-02,2.976700e-01,5.263600e-01,7.258800e-01,9.147600e-01, & - &3.200600e-02,3.122100e-01,5.424000e-01,7.377100e-01,9.091500e-01, & - &4.571400e-02,3.274400e-01,5.576000e-01,7.491100e-01,9.026400e-01, & - &6.300500e-02,3.429100e-01,5.720200e-01,7.598500e-01,8.970200e-01, & - &8.422400e-02,3.593800e-01,5.864800e-01,7.695500e-01,8.920700e-01, & - &1.920000e-02,2.855500e-01,5.044700e-01,6.947100e-01,8.682900e-01, & - &2.867400e-02,2.998400e-01,5.200000e-01,7.078300e-01,8.642000e-01, & - &4.103600e-02,3.146500e-01,5.350100e-01,7.202600e-01,8.602400e-01, & - &5.669100e-02,3.302800e-01,5.499100e-01,7.314300e-01,8.559200e-01, & - &7.588400e-02,3.476600e-01,5.650800e-01,7.415200e-01,8.518400e-01, & - &1.728000e-02,2.710600e-01,4.779700e-01,6.582800e-01,8.156600e-01, & - &2.582600e-02,2.850500e-01,4.932700e-01,6.721900e-01,8.141100e-01, & - &3.703800e-02,2.995100e-01,5.084700e-01,6.848700e-01,8.117400e-01, & - &5.119600e-02,3.152600e-01,5.235200e-01,6.962800e-01,8.090400e-01, & - &6.847300e-02,3.332100e-01,5.387900e-01,7.067900e-01,8.064900e-01, & - &1.553800e-02,2.542100e-01,4.477200e-01,6.171000e-01,7.583900e-01, & - &2.327200e-02,2.678500e-01,4.627900e-01,6.308200e-01,7.581600e-01, & - &3.338300e-02,2.823100e-01,4.777200e-01,6.434500e-01,7.575700e-01, & - &4.607000e-02,2.981500e-01,4.927600e-01,6.551100e-01,7.565800e-01, & - &6.141400e-02,3.162100e-01,5.085100e-01,6.661900e-01,7.558800e-01, & - &1.396700e-02,2.357700e-01,4.144000e-01,5.711000e-01,6.964400e-01, & - &2.091900e-02,2.489700e-01,4.290600e-01,5.844400e-01,6.978400e-01, & - &2.992700e-02,2.632000e-01,4.438600e-01,5.970600e-01,6.988100e-01, & - &4.117500e-02,2.793500e-01,4.590800e-01,6.091800e-01,6.997000e-01, & - &5.476800e-02,2.973000e-01,4.751700e-01,6.211700e-01,7.006800e-01, & - &1.253500e-02,2.161200e-01,3.788000e-01,5.219300e-01,6.322600e-01, & - &1.870900e-02,2.288500e-01,3.931600e-01,5.348600e-01,6.349400e-01, & - &2.668300e-02,2.430700e-01,4.078200e-01,5.474600e-01,6.373500e-01, & - &3.660200e-02,2.592300e-01,4.232300e-01,5.601300e-01,6.400300e-01, & - &4.859500e-02,2.771000e-01,4.399600e-01,5.728600e-01,6.433700e-01, & - &1.128700e-02,1.961600e-01,3.427800e-01,4.714600e-01,5.676700e-01, & - &1.676400e-02,2.085900e-01,3.565500e-01,4.841700e-01,5.717100e-01, & - &2.381100e-02,2.228100e-01,3.711000e-01,4.971300e-01,5.758400e-01, & - &3.255200e-02,2.387600e-01,3.867700e-01,5.103900e-01,5.807700e-01, & - &4.315900e-02,2.564600e-01,4.039800e-01,5.241800e-01,5.865300e-01, & - &1.012300e-02,1.764200e-01,3.070200e-01,4.216400e-01,5.049700e-01, & - &1.496000e-02,1.886500e-01,3.204700e-01,4.344200e-01,5.101900e-01, & - &2.115200e-02,2.026800e-01,3.349900e-01,4.476700e-01,5.163000e-01, & - &2.884300e-02,2.184300e-01,3.510600e-01,4.616500e-01,5.235700e-01, & - &3.820400e-02,2.357700e-01,3.685300e-01,4.764400e-01,5.312400e-01, & - &9.287400e-03,1.583100e-01,2.735800e-01,3.746800e-01,4.459000e-01, & - &1.360500e-02,1.704700e-01,2.867900e-01,3.876500e-01,4.528600e-01, & - &1.911400e-02,1.843400e-01,3.015900e-01,4.014400e-01,4.609700e-01, & - &2.596100e-02,1.998200e-01,3.179800e-01,4.160600e-01,4.695100e-01, & - &3.434900e-02,2.166800e-01,3.357000e-01,4.311400e-01,4.772900e-01, & - &8.492100e-03,1.415200e-01,2.423100e-01,3.311000e-01,3.918600e-01, & - &1.234200e-02,1.534800e-01,2.556900e-01,3.442600e-01,4.002200e-01, & - &1.724400e-02,1.671200e-01,2.706100e-01,3.581600e-01,4.090500e-01, & - &2.336600e-02,1.821900e-01,2.868400e-01,3.724200e-01,4.172900e-01, & - &3.090600e-02,1.982600e-01,3.039400e-01,3.865800e-01,4.234900e-01, & - &7.753500e-03,1.262900e-01,2.140500e-01,2.913500e-01,3.430100e-01, & - &1.118300e-02,1.380000e-01,2.273300e-01,3.042700e-01,3.517600e-01, & - &1.557600e-02,1.511800e-01,2.418500e-01,3.174900e-01,3.600200e-01, & - &2.108700e-02,1.654300e-01,2.572800e-01,3.305000e-01,3.660500e-01, & - &2.786200e-02,1.804200e-01,2.731100e-01,3.426900e-01,3.692400e-01/ - data absb(301:600,8) / & - &7.074200e-03,1.126200e-01,1.887100e-01,2.554000e-01,2.990300e-01, & - &1.015500e-02,1.238700e-01,2.014900e-01,2.674400e-01,3.069400e-01, & - &1.411900e-02,1.362100e-01,2.150700e-01,2.790800e-01,3.127900e-01, & - &1.907900e-02,1.492800e-01,2.289700e-01,2.898600e-01,3.158300e-01, & - &2.516400e-02,1.630500e-01,2.428200e-01,2.996100e-01,3.161600e-01, & - &6.481900e-03,1.004600e-01,1.661600e-01,2.229600e-01,2.590600e-01, & - &9.274600e-03,1.109400e-01,1.778900e-01,2.332100e-01,2.646300e-01, & - &1.286000e-02,1.221100e-01,1.898200e-01,2.426100e-01,2.676200e-01, & - &1.734000e-02,1.339000e-01,2.017600e-01,2.510900e-01,2.682000e-01, & - &2.279700e-02,1.464100e-01,2.134600e-01,2.587100e-01,2.670100e-01, & - &5.949600e-03,8.935400e-02,1.455900e-01,1.930100e-01,2.219600e-01, & - &8.482300e-03,9.871300e-02,1.557500e-01,2.012100e-01,2.250200e-01, & - &1.172300e-02,1.086000e-01,1.659200e-01,2.085700e-01,2.259400e-01, & - &1.576000e-02,1.191000e-01,1.758800e-01,2.152800e-01,2.253200e-01, & - &2.064000e-02,1.304200e-01,1.858400e-01,2.215800e-01,2.235700e-01, & - &5.464800e-03,7.895400e-02,1.266400e-01,1.655600e-01,1.879000e-01, & - &7.761200e-03,8.713400e-02,1.352500e-01,1.719700e-01,1.891700e-01, & - &1.068800e-02,9.581600e-02,1.437100e-01,1.779100e-01,1.891000e-01, & - &1.430100e-02,1.051500e-01,1.521800e-01,1.835200e-01,1.880400e-01, & - &1.866800e-02,1.154000e-01,1.609800e-01,1.888900e-01,1.861600e-01, & - &5.036000e-03,6.932500e-02,1.094300e-01,1.409100e-01,1.575900e-01, & - &7.120200e-03,7.642600e-02,1.166300e-01,1.461500e-01,1.579800e-01, & - &9.753300e-03,8.405500e-02,1.238100e-01,1.511500e-01,1.574900e-01, & - &1.299700e-02,9.246300e-02,1.312200e-01,1.559500e-01,1.562800e-01, & - &1.690600e-02,1.018500e-01,1.391800e-01,1.606100e-01,1.545100e-01, & - &4.640200e-03,6.048900e-02,9.404300e-02,1.194200e-01,1.314000e-01, & - &6.526300e-03,6.668900e-02,1.001200e-01,1.238400e-01,1.313900e-01, & - &8.895700e-03,7.351100e-02,1.063500e-01,1.281400e-01,1.307200e-01, & - &1.180600e-02,8.119100e-02,1.130200e-01,1.323000e-01,1.295400e-01, & - &1.532100e-02,8.986100e-02,1.203600e-01,1.365400e-01,1.279500e-01, & - &4.281600e-03,5.259400e-02,8.055600e-02,1.010000e-01,1.092300e-01, & - &5.992800e-03,5.809300e-02,8.578800e-02,1.048400e-01,1.090100e-01, & - &8.125400e-03,6.431300e-02,9.135100e-02,1.085500e-01,1.083200e-01, & - &1.075000e-02,7.140600e-02,9.744000e-02,1.123000e-01,1.072500e-01, & - &1.393400e-02,7.943500e-02,1.042900e-01,1.162700e-01,1.058200e-01, & - &3.957500e-03,4.568200e-02,6.889800e-02,8.541100e-02,9.060200e-02, & - &5.502100e-03,5.065800e-02,7.352200e-02,8.872700e-02,9.029200e-02, & - &7.434500e-03,5.638600e-02,7.856500e-02,9.201300e-02,8.963300e-02, & - &9.822300e-03,6.296000e-02,8.422800e-02,9.546500e-02,8.866000e-02, & - &1.273000e-02,7.042900e-02,9.062500e-02,9.923300e-02,8.744900e-02, & - &3.659100e-03,3.971500e-02,5.894800e-02,7.224100e-02,7.505500e-02, & - &5.063900e-03,4.428600e-02,6.309700e-02,7.512900e-02,7.472200e-02, & - &6.821700e-03,4.960600e-02,6.774300e-02,7.811300e-02,7.412100e-02, & - &9.001000e-03,5.572900e-02,7.303800e-02,8.134900e-02,7.328400e-02, & - &1.169300e-02,6.270200e-02,7.902200e-02,8.499200e-02,7.228600e-02, & - &3.342400e-03,3.448500e-02,5.036400e-02,6.104100e-02,6.210800e-02, & - &4.613600e-03,3.870800e-02,5.413200e-02,6.361200e-02,6.179100e-02, & - &6.208100e-03,4.364100e-02,5.845300e-02,6.636900e-02,6.126900e-02, & - &8.207900e-03,4.932800e-02,6.340000e-02,6.944300e-02,6.057900e-02, & - &1.069000e-02,5.587900e-02,6.902600e-02,7.297600e-02,5.977000e-02, & - &2.961000e-03,2.970800e-02,4.280600e-02,5.141400e-02,5.139900e-02, & - &4.085200e-03,3.356300e-02,4.623900e-02,5.373400e-02,5.112900e-02, & - &5.514600e-03,3.809000e-02,5.022600e-02,5.629400e-02,5.070800e-02, & - &7.319100e-03,4.334800e-02,5.480900e-02,5.922000e-02,5.016900e-02, & - &9.586200e-03,4.944700e-02,6.005100e-02,6.257600e-02,4.954900e-02, & - &2.529100e-03,2.531700e-02,3.613900e-02,4.313900e-02,4.255000e-02, & - &3.508100e-03,2.878700e-02,3.924600e-02,4.524500e-02,4.234900e-02, & - &4.762300e-03,3.288000e-02,4.287500e-02,4.761000e-02,4.203400e-02, & - &6.360000e-03,3.768400e-02,4.708200e-02,5.034400e-02,4.163100e-02, & - &8.382800e-03,4.332800e-02,5.191500e-02,5.348600e-02,4.117400e-02/ - data absb(601:900,8) / & - &2.057200e-03,2.119000e-02,3.017200e-02,3.596600e-02,3.523100e-02, & - &2.874200e-03,2.423400e-02,3.292100e-02,3.784700e-02,3.509700e-02, & - &3.937700e-03,2.785600e-02,3.615600e-02,3.999100e-02,3.488000e-02, & - &5.307500e-03,3.215700e-02,3.992900e-02,4.248500e-02,3.459500e-02, & - &7.053100e-03,3.726600e-02,4.431000e-02,4.536100e-02,3.426600e-02, & - &1.666800e-03,1.771800e-02,2.517900e-02,2.997600e-02,2.917800e-02, & - &2.351200e-03,2.038800e-02,2.761600e-02,3.165400e-02,2.910600e-02, & - &3.248900e-03,2.359900e-02,3.049100e-02,3.358900e-02,2.896500e-02, & - &4.419700e-03,2.744800e-02,3.387600e-02,3.586100e-02,2.877700e-02, & - &5.929100e-03,3.208500e-02,3.785700e-02,3.849900e-02,2.855800e-02, & - &1.350500e-03,1.482400e-02,2.102500e-02,2.498800e-02,2.418300e-02, & - &1.923700e-03,1.716900e-02,2.318100e-02,2.648500e-02,2.415700e-02, & - &2.681200e-03,2.001500e-02,2.574000e-02,2.823200e-02,2.408100e-02, & - &3.689000e-03,2.347000e-02,2.878100e-02,3.030100e-02,2.397400e-02, & - &4.995600e-03,2.768800e-02,3.241000e-02,3.272600e-02,2.384900e-02, & - &1.053500e-03,1.221700e-02,1.738800e-02,2.070900e-02,2.001900e-02, & - &1.517300e-03,1.423300e-02,1.925500e-02,2.202500e-02,2.002900e-02, & - &2.142400e-03,1.670900e-02,2.149900e-02,2.357400e-02,2.000100e-02, & - &2.980600e-03,1.975400e-02,2.418600e-02,2.542500e-02,1.995300e-02, & - &4.084100e-03,2.352100e-02,2.743800e-02,2.761500e-02,1.989100e-02, & - &8.154900e-04,1.003900e-02,1.435200e-02,1.714100e-02,1.656900e-02, & - &1.189600e-03,1.176500e-02,1.596300e-02,1.829500e-02,1.660900e-02, & - &1.700700e-03,1.391000e-02,1.792200e-02,1.966400e-02,1.661600e-02, & - &2.396700e-03,1.658700e-02,2.029500e-02,2.131300e-02,1.660800e-02, & - &3.320900e-03,1.994100e-02,2.319300e-02,2.327900e-02,1.659600e-02, & - &6.288500e-04,8.238900e-03,1.183800e-02,1.418200e-02,1.371700e-02, & - &9.307500e-04,9.714700e-03,1.322600e-02,1.518900e-02,1.377500e-02, & - &1.347600e-03,1.157200e-02,1.493400e-02,1.639700e-02,1.381200e-02, & - &1.922100e-03,1.392100e-02,1.702200e-02,1.786200e-02,1.383500e-02, & - &2.697400e-03,1.690500e-02,1.960800e-02,1.962500e-02,1.385800e-02, & - &4.722500e-04,6.691100e-03,9.697100e-03,1.168200e-02,1.135100e-02, & - &7.093300e-04,7.934800e-03,1.087700e-02,1.255100e-02,1.142400e-02, & - &1.043500e-03,9.515500e-03,1.234400e-02,1.360200e-02,1.148000e-02, & - &1.508200e-03,1.154700e-02,1.415800e-02,1.488600e-02,1.152300e-02, & - &2.145400e-03,1.416300e-02,1.643400e-02,1.645000e-02,1.157300e-02, & - &3.490200e-04,5.401400e-03,7.912200e-03,9.597300e-03,9.390600e-03, & - &5.333600e-04,6.438500e-03,8.904800e-03,1.034100e-02,9.472700e-03, & - &7.964100e-04,7.774100e-03,1.015500e-02,1.124700e-02,9.540800e-03, & - &1.169700e-03,9.510700e-03,1.171800e-02,1.236600e-02,9.599400e-03, & - &1.686600e-03,1.178200e-02,1.370000e-02,1.373700e-02,9.662900e-03, & - &2.564100e-04,4.352400e-03,6.448900e-03,7.877600e-03,7.770000e-03, & - &3.981900e-04,5.213100e-03,7.279600e-03,8.511500e-03,7.856500e-03, & - &6.045200e-04,6.335600e-03,8.340000e-03,9.288300e-03,7.929800e-03, & - &9.022500e-04,7.814800e-03,9.681800e-03,1.025700e-02,7.997800e-03, & - &1.321200e-03,9.777900e-03,1.140200e-02,1.145700e-02,8.073800e-03, & - &1.852400e-04,3.486400e-03,5.234100e-03,6.446600e-03,6.423000e-03, & - &2.931300e-04,4.193100e-03,5.922800e-03,6.983100e-03,6.511700e-03, & - &4.524100e-04,5.127100e-03,6.814200e-03,7.643900e-03,6.588900e-03, & - &6.867400e-04,6.372900e-03,7.956400e-03,8.476800e-03,6.664400e-03, & - &1.022000e-03,8.053800e-03,9.438000e-03,9.519300e-03,6.747600e-03, & - &1.300000e-04,2.766300e-03,4.220800e-03,5.252100e-03,5.302600e-03, & - &2.102500e-04,3.336300e-03,4.782800e-03,5.702000e-03,5.390200e-03, & - &3.304700e-04,4.099500e-03,5.520100e-03,6.255900e-03,5.467900e-03, & - &5.102900e-04,5.129600e-03,6.475500e-03,6.960100e-03,5.544400e-03, & - &7.731700e-04,6.540300e-03,7.729300e-03,7.850300e-03,5.628900e-03, & - &9.025000e-05,2.191400e-03,3.399400e-03,4.273800e-03,4.377100e-03, & - &1.493300e-04,2.647000e-03,3.854700e-03,4.649000e-03,4.461100e-03, & - &2.395000e-04,3.266100e-03,4.458600e-03,5.109100e-03,4.536600e-03, & - &3.763500e-04,4.111600e-03,5.253400e-03,5.700400e-03,4.612400e-03, & - &5.808200e-04,5.288400e-03,6.308600e-03,6.457300e-03,4.697700e-03/ - data absb(901:1175,8) / & - &6.199300e-05,1.733100e-03,2.733000e-03,3.471900e-03,3.611100e-03, & - &1.051100e-04,2.093800e-03,3.100400e-03,3.783600e-03,3.691500e-03, & - &1.721600e-04,2.593200e-03,3.591700e-03,4.165000e-03,3.765300e-03, & - &2.755100e-04,3.282900e-03,4.248600e-03,4.658000e-03,3.840500e-03, & - &4.330100e-04,4.257000e-03,5.131700e-03,5.298500e-03,3.926300e-03, & - &4.267800e-05,1.374500e-03,2.200200e-03,2.821200e-03,2.973700e-03, & - &7.414600e-05,1.660500e-03,2.497400e-03,3.081500e-03,3.047900e-03, & - &1.240600e-04,2.063900e-03,2.898200e-03,3.398800e-03,3.118800e-03, & - &2.025300e-04,2.628200e-03,3.442500e-03,3.811600e-03,3.191300e-03, & - &3.242400e-04,3.436900e-03,4.183000e-03,4.354700e-03,3.273000e-03, & - &2.923700e-05,1.090900e-03,1.771400e-03,2.291700e-03,2.446400e-03, & - &5.216600e-05,1.317600e-03,2.012500e-03,2.510200e-03,2.514800e-03, & - &8.909100e-05,1.642600e-03,2.338800e-03,2.773800e-03,2.580600e-03, & - &1.484000e-04,2.102800e-03,2.787800e-03,3.117600e-03,2.647700e-03, & - &2.420700e-04,2.771400e-03,3.406300e-03,3.576200e-03,2.722700e-03, & - &1.980700e-05,8.653800e-04,1.424900e-03,1.859500e-03,2.012400e-03, & - &3.632200e-05,1.043800e-03,1.620000e-03,2.042200e-03,2.075000e-03, & - &6.351500e-05,1.303700e-03,1.883600e-03,2.260300e-03,2.135200e-03, & - &1.078800e-04,1.676700e-03,2.251700e-03,2.544800e-03,2.197000e-03, & - &1.795800e-04,2.226000e-03,2.765100e-03,2.929500e-03,2.265700e-03, & - &1.324200e-05,6.857300e-04,1.144600e-03,1.506700e-03,1.655000e-03, & - &2.502200e-05,8.253500e-04,1.301800e-03,1.658700e-03,1.711700e-03, & - &4.484900e-05,1.031300e-03,1.513500e-03,1.838500e-03,1.767000e-03, & - &7.772400e-05,1.332100e-03,1.813000e-03,2.072900e-03,1.823900e-03, & - &1.319900e-04,1.779400e-03,2.236500e-03,2.393100e-03,1.887400e-03, & - &8.924800e-06,5.455600e-04,9.216300e-04,1.222500e-03,1.356600e-03, & - &1.737200e-05,6.558100e-04,1.049200e-03,1.349400e-03,1.406300e-03, & - &3.190700e-05,8.197900e-04,1.220200e-03,1.498300e-03,1.455100e-03, & - &5.650600e-05,1.063400e-03,1.464700e-03,1.692200e-03,1.504600e-03, & - &9.783600e-05,1.430100e-03,1.815900e-03,1.959700e-03,1.559600e-03, & - &6.000900e-06,4.345900e-04,7.421500e-04,9.917200e-04,1.109300e-03, & - &1.205000e-05,5.218400e-04,8.461800e-04,1.097700e-03,1.152000e-03, & - &2.269700e-05,6.522700e-04,9.842700e-04,1.221200e-03,1.194100e-03, & - &4.105100e-05,8.494400e-04,1.183700e-03,1.381500e-03,1.236100e-03, & - &7.247200e-05,1.149400e-03,1.474300e-03,1.604600e-03,1.282300e-03, & - &3.989800e-06,3.458900e-04,5.968900e-04,8.035200e-04,9.064900e-04, & - &8.275000e-06,4.147000e-04,6.815300e-04,8.916600e-04,9.430100e-04, & - &1.600300e-05,5.178600e-04,7.927900e-04,9.941000e-04,9.791300e-04, & - &2.958700e-05,6.765500e-04,9.545000e-04,1.125800e-03,1.014900e-03, & - &5.328000e-05,9.205500e-04,1.193800e-03,1.311100e-03,1.053600e-03, & - &2.617300e-06,2.750000e-04,4.794000e-04,6.502200e-04,7.401400e-04, & - &5.618500e-06,3.292800e-04,5.483400e-04,7.233800e-04,7.714800e-04, & - &1.117800e-05,4.103400e-04,6.375800e-04,8.079100e-04,8.022300e-04, & - &2.113100e-05,5.371400e-04,7.677900e-04,9.160400e-04,8.327900e-04, & - &3.885500e-05,7.344600e-04,9.637300e-04,1.068900e-03,8.652700e-04, & - &1.718700e-06,2.189700e-04,3.853700e-04,5.263600e-04,6.039100e-04, & - &3.820400e-06,2.620100e-04,4.415700e-04,5.868900e-04,6.306100e-04, & - &7.817500e-06,3.259600e-04,5.134500e-04,6.570200e-04,6.566900e-04, & - &1.512800e-05,4.273100e-04,6.184800e-04,7.458900e-04,6.825700e-04, & - &2.838300e-05,5.870900e-04,7.789100e-04,8.718500e-04,7.096700e-04, & - &1.307100e-06,1.797100e-04,3.171300e-04,4.340800e-04,4.947900e-04, & - &2.959300e-06,2.159000e-04,3.645500e-04,4.854500e-04,5.165300e-04, & - &6.160600e-06,2.704400e-04,4.258900e-04,5.453800e-04,5.375200e-04, & - &1.211600e-05,3.581500e-04,5.170100e-04,6.225200e-04,5.585400e-04, & - &2.313200e-05,4.990500e-04,6.583000e-04,7.336500e-04,5.802300e-04/ - data absb(1:300,9) / & - &1.610300e-01,6.615800e-01,1.127300e+00,1.563700e+00,2.019300e+00, & - &2.370200e-01,7.050200e-01,1.159700e+00,1.565000e+00,1.988700e+00, & - &3.316500e-01,7.535000e-01,1.197100e+00,1.575900e+00,1.960200e+00, & - &4.455700e-01,8.099800e-01,1.235600e+00,1.590900e+00,1.932900e+00, & - &5.785900e-01,8.760500e-01,1.274600e+00,1.606100e+00,1.905600e+00, & - &1.476100e-01,6.934700e-01,1.179400e+00,1.626200e+00,2.095200e+00, & - &2.166400e-01,7.353900e-01,1.218500e+00,1.632800e+00,2.065600e+00, & - &3.027100e-01,7.809100e-01,1.258000e+00,1.648900e+00,2.036300e+00, & - &4.059900e-01,8.325900e-01,1.296100e+00,1.667200e+00,2.006700e+00, & - &5.263500e-01,8.913600e-01,1.333500e+00,1.686500e+00,1.978400e+00, & - &1.345700e-01,7.210000e-01,1.221900e+00,1.674500e+00,2.150400e+00, & - &1.969400e-01,7.631000e-01,1.265900e+00,1.687200e+00,2.123100e+00, & - &2.743900e-01,8.069100e-01,1.308100e+00,1.708200e+00,2.094400e+00, & - &3.671900e-01,8.545600e-01,1.347400e+00,1.730400e+00,2.066100e+00, & - &4.756100e-01,9.076900e-01,1.384600e+00,1.753300e+00,2.037800e+00, & - &1.220500e-01,7.407700e-01,1.254100e+00,1.707300e+00,2.182700e+00, & - &1.779100e-01,7.839600e-01,1.300200e+00,1.727000e+00,2.158100e+00, & - &2.471500e-01,8.283400e-01,1.343600e+00,1.752100e+00,2.132700e+00, & - &3.303400e-01,8.741800e-01,1.384700e+00,1.778200e+00,2.106700e+00, & - &4.278600e-01,9.227900e-01,1.424400e+00,1.803700e+00,2.080800e+00, & - &1.098200e-01,7.514300e-01,1.272500e+00,1.724200e+00,2.190900e+00, & - &1.595300e-01,7.954900e-01,1.319300e+00,1.750100e+00,2.170300e+00, & - &2.212700e-01,8.405400e-01,1.363600e+00,1.779300e+00,2.148600e+00, & - &2.958400e-01,8.868200e-01,1.405900e+00,1.809100e+00,2.126600e+00, & - &3.838500e-01,9.342200e-01,1.446600e+00,1.836400e+00,2.103900e+00, & - &9.832900e-02,7.524000e-01,1.275600e+00,1.724400e+00,2.175700e+00, & - &1.425100e-01,7.970600e-01,1.322800e+00,1.755600e+00,2.159700e+00, & - &1.977300e-01,8.426400e-01,1.367300e+00,1.788800e+00,2.142700e+00, & - &2.648200e-01,8.890100e-01,1.410100e+00,1.820400e+00,2.124500e+00, & - &3.444800e-01,9.366600e-01,1.451400e+00,1.848300e+00,2.105900e+00, & - &8.781500e-02,7.438400e-01,1.263700e+00,1.706700e+00,2.136200e+00, & - &1.272500e-01,7.882800e-01,1.310200e+00,1.742800e+00,2.125700e+00, & - &1.767900e-01,8.337900e-01,1.354700e+00,1.778600e+00,2.113500e+00, & - &2.372800e-01,8.801000e-01,1.397700e+00,1.810800e+00,2.099100e+00, & - &3.089500e-01,9.282400e-01,1.439300e+00,1.839100e+00,2.083700e+00, & - &7.904100e-02,7.270000e-01,1.237400e+00,1.671900e+00,2.074700e+00, & - &1.145400e-01,7.707000e-01,1.283100e+00,1.710900e+00,2.068500e+00, & - &1.593000e-01,8.156800e-01,1.327300e+00,1.747200e+00,2.060400e+00, & - &2.137600e-01,8.619400e-01,1.370200e+00,1.779900e+00,2.050900e+00, & - &2.784200e-01,9.104500e-01,1.412400e+00,1.809100e+00,2.040800e+00, & - &7.144500e-02,7.024400e-01,1.197000e+00,1.619900e+00,1.992300e+00, & - &1.035300e-01,7.452200e-01,1.241800e+00,1.659600e+00,1.990900e+00, & - &1.438400e-01,7.893400e-01,1.285400e+00,1.696200e+00,1.987500e+00, & - &1.930700e-01,8.354700e-01,1.328600e+00,1.729700e+00,1.983000e+00, & - &2.515100e-01,8.844300e-01,1.371600e+00,1.760800e+00,1.978500e+00, & - &6.653600e-02,6.736200e-01,1.147600e+00,1.555300e+00,1.893000e+00, & - &9.596100e-02,7.154600e-01,1.191500e+00,1.594600e+00,1.896000e+00, & - &1.329300e-01,7.590600e-01,1.235000e+00,1.631400e+00,1.897700e+00, & - &1.779100e-01,8.053600e-01,1.278800e+00,1.666300e+00,1.899100e+00, & - &2.312400e-01,8.550200e-01,1.323000e+00,1.699800e+00,1.900800e+00, & - &6.213000e-02,6.398900e-01,1.088900e+00,1.476400e+00,1.780000e+00, & - &8.920300e-02,6.808000e-01,1.132400e+00,1.516300e+00,1.788500e+00, & - &1.231000e-01,7.242000e-01,1.176300e+00,1.554700e+00,1.796300e+00, & - &1.642300e-01,7.709800e-01,1.221000e+00,1.591800e+00,1.804000e+00, & - &2.127700e-01,8.215400e-01,1.267300e+00,1.628500e+00,1.813200e+00, & - &5.827300e-02,6.030600e-01,1.023800e+00,1.388400e+00,1.659000e+00, & - &8.323200e-02,6.433800e-01,1.067600e+00,1.429700e+00,1.673100e+00, & - &1.142700e-01,6.869200e-01,1.112600e+00,1.470300e+00,1.687400e+00, & - &1.516300e-01,7.344800e-01,1.159100e+00,1.510800e+00,1.703500e+00, & - &1.955200e-01,7.861000e-01,1.207700e+00,1.551900e+00,1.721900e+00/ - data absb(301:600,9) / & - &5.481200e-02,5.647700e-01,9.556900e-01,1.295400e+00,1.534700e+00, & - &7.774800e-02,6.052100e-01,1.000500e+00,1.338600e+00,1.555100e+00, & - &1.060000e-01,6.494700e-01,1.047100e+00,1.382800e+00,1.577900e+00, & - &1.399000e-01,6.979900e-01,1.096300e+00,1.428200e+00,1.603400e+00, & - &1.798300e-01,7.505700e-01,1.148600e+00,1.475100e+00,1.630700e+00, & - &5.171600e-02,5.271300e-01,8.878800e-01,1.201800e+00,1.412600e+00, & - &7.268400e-02,5.682600e-01,9.342700e-01,1.248800e+00,1.441100e+00, & - &9.844900e-02,6.137200e-01,9.837500e-01,1.297700e+00,1.472700e+00, & - &1.293900e-01,6.635200e-01,1.036500e+00,1.348600e+00,1.506400e+00, & - &1.659100e-01,7.172700e-01,1.093000e+00,1.401000e+00,1.540600e+00, & - &4.858400e-02,4.909700e-01,8.225600e-01,1.112100e+00,1.297700e+00, & - &6.775900e-02,5.333500e-01,8.715900e-01,1.163300e+00,1.334200e+00, & - &9.128100e-02,5.803200e-01,9.243500e-01,1.217200e+00,1.373300e+00, & - &1.195800e-01,6.316100e-01,9.811700e-01,1.273000e+00,1.413500e+00, & - &1.530600e-01,6.864000e-01,1.041300e+00,1.329800e+00,1.453200e+00, & - &4.551300e-02,4.577100e-01,7.622100e-01,1.028500e+00,1.192000e+00, & - &6.304300e-02,5.015800e-01,8.140000e-01,1.084000e+00,1.235500e+00, & - &8.457700e-02,5.500800e-01,8.702000e-01,1.142100e+00,1.280700e+00, & - &1.105600e-01,6.026600e-01,9.303700e-01,1.201900e+00,1.326100e+00, & - &1.414600e-01,6.586100e-01,9.936100e-01,1.263000e+00,1.370700e+00, & - &4.263400e-02,4.284000e-01,7.080400e-01,9.529500e-01,1.097600e+00, & - &5.874900e-02,4.737300e-01,7.627400e-01,1.012200e+00,1.146600e+00, & - &7.859400e-02,5.237200e-01,8.219600e-01,1.074000e+00,1.196800e+00, & - &1.025800e-01,5.774100e-01,8.849800e-01,1.137700e+00,1.246900e+00, & - &1.312500e-01,6.341400e-01,9.513300e-01,1.202700e+00,1.296200e+00, & - &3.989900e-02,4.029100e-01,6.603600e-01,8.858400e-01,1.013700e+00, & - &5.477400e-02,4.497100e-01,7.177900e-01,9.483600e-01,1.067400e+00, & - &7.310800e-02,5.007500e-01,7.797400e-01,1.013700e+00,1.122100e+00, & - &9.543900e-02,5.554500e-01,8.455800e-01,1.080900e+00,1.176900e+00, & - &1.221400e-01,6.127400e-01,9.144300e-01,1.149600e+00,1.230700e+00, & - &3.739900e-02,3.815300e-01,6.196400e-01,8.274900e-01,9.411200e-01, & - &5.117000e-02,4.294700e-01,6.796700e-01,8.933000e-01,9.993600e-01, & - &6.826700e-02,4.815700e-01,7.441800e-01,9.618600e-01,1.059000e+00, & - &8.911900e-02,5.368800e-01,8.124700e-01,1.032600e+00,1.118500e+00, & - &1.142000e-01,5.946800e-01,8.835200e-01,1.104500e+00,1.176700e+00, & - &3.511800e-02,3.640600e-01,5.857100e-01,7.781900e-01,8.799500e-01, & - &4.797000e-02,4.129900e-01,6.482300e-01,8.469700e-01,9.429600e-01, & - &6.400400e-02,4.659000e-01,7.151600e-01,9.189200e-01,1.007100e+00, & - &8.361500e-02,5.218900e-01,7.858300e-01,9.929000e-01,1.070900e+00, & - &1.072000e-01,5.800200e-01,8.587200e-01,1.068000e+00,1.133600e+00, & - &3.307700e-02,3.501700e-01,5.583800e-01,7.376200e-01,8.303200e-01, & - &4.516300e-02,4.000100e-01,6.231200e-01,8.095600e-01,8.977600e-01, & - &6.026300e-02,4.536500e-01,6.924300e-01,8.845900e-01,9.661700e-01, & - &7.879300e-02,5.100500e-01,7.649800e-01,9.617700e-01,1.034300e+00, & - &1.010800e-01,5.687500e-01,8.399800e-01,1.039600e+00,1.101100e+00, & - &3.091500e-02,3.378100e-01,5.348600e-01,7.030400e-01,7.883200e-01, & - &4.225200e-02,3.883900e-01,6.016600e-01,7.778900e-01,8.596700e-01, & - &5.647000e-02,4.425500e-01,6.729900e-01,8.558400e-01,9.318700e-01, & - &7.389600e-02,4.992300e-01,7.472700e-01,9.356600e-01,1.003900e+00, & - &9.501800e-02,5.584800e-01,8.240800e-01,1.016000e+00,1.074300e+00, & - &2.813200e-02,3.236500e-01,5.105500e-01,6.689500e-01,7.486400e-01, & - &3.858100e-02,3.745600e-01,5.788900e-01,7.462800e-01,8.233200e-01, & - &5.172100e-02,4.288800e-01,6.516000e-01,8.266500e-01,8.993800e-01, & - &6.795000e-02,4.857400e-01,7.273800e-01,9.086500e-01,9.749300e-01, & - &8.766100e-02,5.453900e-01,8.056600e-01,9.913300e-01,1.048700e+00, & - &2.479400e-02,3.068400e-01,4.837400e-01,6.331500e-01,7.081600e-01, & - &3.421600e-02,3.576400e-01,5.529300e-01,7.123500e-01,7.860900e-01, & - &4.614200e-02,4.118000e-01,6.266000e-01,7.944900e-01,8.655200e-01, & - &6.098300e-02,4.686300e-01,7.034300e-01,8.784600e-01,9.444600e-01, & - &7.910100e-02,5.283300e-01,7.827700e-01,9.632800e-01,1.021200e+00/ - data absb(601:900,9) / & - &2.081500e-02,2.851300e-01,4.508100e-01,5.910100e-01,6.616400e-01, & - &2.902200e-02,3.352100e-01,5.201200e-01,6.712500e-01,7.421100e-01, & - &3.951600e-02,3.888000e-01,5.940000e-01,7.546900e-01,8.243400e-01, & - &5.268500e-02,4.452000e-01,6.713100e-01,8.403000e-01,9.063900e-01, & - &6.890800e-02,5.045000e-01,7.512800e-01,9.268700e-01,9.861300e-01, & - &1.744000e-02,2.653200e-01,4.209000e-01,5.528200e-01,6.199900e-01, & - &2.458500e-02,3.146300e-01,4.901000e-01,6.338500e-01,7.026700e-01, & - &3.382700e-02,3.676300e-01,5.640600e-01,7.184100e-01,7.875100e-01, & - &4.549700e-02,4.235800e-01,6.417200e-01,8.052800e-01,8.723300e-01, & - &6.006100e-02,4.824500e-01,7.221600e-01,8.933400e-01,9.548800e-01, & - &1.463500e-02,2.475800e-01,3.942200e-01,5.188200e-01,5.834600e-01, & - &2.086200e-02,2.961300e-01,4.631700e-01,6.004300e-01,6.682300e-01, & - &2.901000e-02,3.485300e-01,5.371500e-01,6.858500e-01,7.554300e-01, & - &3.939200e-02,4.040200e-01,6.149800e-01,7.737500e-01,8.427200e-01, & - &5.248700e-02,4.624600e-01,6.957400e-01,8.630900e-01,9.280800e-01, & - &1.181700e-02,2.270300e-01,3.636200e-01,4.802400e-01,5.411000e-01, & - &1.709300e-02,2.743800e-01,4.316400e-01,5.617200e-01,6.269200e-01, & - &2.408600e-02,3.257800e-01,5.050800e-01,6.474700e-01,7.155900e-01, & - &3.312000e-02,3.804700e-01,5.825800e-01,7.360400e-01,8.048800e-01, & - &4.464200e-02,4.381600e-01,6.632900e-01,8.263000e-01,8.926300e-01, & - &9.473200e-03,2.077200e-01,3.347200e-01,4.437200e-01,5.009800e-01, & - &1.392400e-02,2.537800e-01,4.016800e-01,5.248100e-01,5.873800e-01, & - &1.989300e-02,3.041200e-01,4.743100e-01,6.105800e-01,6.771100e-01, & - &2.772600e-02,3.579000e-01,5.513300e-01,6.995400e-01,7.680400e-01, & - &3.783500e-02,4.147900e-01,6.318300e-01,7.904500e-01,8.579300e-01, & - &7.568200e-03,1.900700e-01,3.081400e-01,4.099700e-01,4.639500e-01, & - &1.131500e-02,2.347800e-01,3.738600e-01,4.903900e-01,5.506200e-01, & - &1.641400e-02,2.840100e-01,4.455600e-01,5.759600e-01,6.411600e-01, & - &2.318900e-02,3.368700e-01,5.219900e-01,6.650900e-01,7.335000e-01, & - &3.205300e-02,3.929900e-01,6.020500e-01,7.564600e-01,8.252600e-01, & - &5.879200e-03,1.715800e-01,2.802100e-01,3.743900e-01,4.247600e-01, & - &8.966400e-03,2.146500e-01,3.442300e-01,4.535900e-01,5.110900e-01, & - &1.323900e-02,2.624700e-01,4.145100e-01,5.384100e-01,6.019500e-01, & - &1.899900e-02,3.142000e-01,4.899100e-01,6.273400e-01,6.953500e-01, & - &2.664300e-02,3.692600e-01,5.692500e-01,7.188600e-01,7.887700e-01, & - &4.488200e-03,1.536400e-01,2.528300e-01,3.392500e-01,3.860400e-01, & - &6.993600e-03,1.948700e-01,3.148200e-01,4.168300e-01,4.714200e-01, & - &1.053200e-02,2.411000e-01,3.833700e-01,5.005500e-01,5.622600e-01, & - &1.538500e-02,2.915000e-01,4.575000e-01,5.889100e-01,6.563700e-01, & - &2.190700e-02,3.454500e-01,5.359200e-01,6.802300e-01,7.511500e-01, & - &3.402300e-03,1.371800e-01,2.274200e-01,3.064000e-01,3.498600e-01, & - &5.421100e-03,1.764800e-01,2.872400e-01,3.821000e-01,4.339600e-01, & - &8.334400e-03,2.210200e-01,3.539000e-01,4.644300e-01,5.244800e-01, & - &1.241000e-02,2.700700e-01,4.265700e-01,5.518600e-01,6.188900e-01, & - &1.796200e-02,3.228400e-01,5.038900e-01,6.428800e-01,7.148900e-01, & - &2.529800e-03,1.212800e-01,2.026500e-01,2.741700e-01,3.142600e-01, & - &4.131100e-03,1.584900e-01,2.600200e-01,3.475100e-01,3.964400e-01, & - &6.497800e-03,2.012200e-01,3.245300e-01,4.280500e-01,4.861100e-01, & - &9.875600e-03,2.487100e-01,3.953700e-01,5.142300e-01,5.804800e-01, & - &1.456100e-02,3.001600e-01,4.713400e-01,6.046300e-01,6.773200e-01, & - &1.821200e-03,1.053200e-01,1.775500e-01,2.412900e-01,2.775500e-01, & - &3.056800e-03,1.402400e-01,2.319800e-01,3.115500e-01,3.568900e-01, & - &4.931000e-03,1.807800e-01,2.938500e-01,3.897300e-01,4.448200e-01, & - &7.671200e-03,2.263900e-01,3.624500e-01,4.742400e-01,5.385400e-01, & - &1.154800e-02,2.763000e-01,4.367200e-01,5.634700e-01,6.355900e-01, & - &1.295200e-03,9.084800e-02,1.544700e-01,2.107800e-01,2.434500e-01, & - &2.237200e-03,1.233700e-01,2.057400e-01,2.776100e-01,3.196000e-01, & - &3.705600e-03,1.616400e-01,2.648800e-01,3.531500e-01,4.053400e-01, & - &5.906600e-03,2.053000e-01,3.310200e-01,4.355900e-01,4.980400e-01, & - &9.092500e-03,2.535500e-01,4.033500e-01,5.233900e-01,5.949800e-01/ - data absb(901:1175,9) / & - &9.085800e-04,7.777300e-02,1.333300e-01,1.826300e-01,2.120300e-01, & - &1.617800e-03,1.078100e-01,1.812900e-01,2.457000e-01,2.846500e-01, & - &2.756200e-03,1.437900e-01,2.375200e-01,3.182300e-01,3.678100e-01, & - &4.507100e-03,1.853500e-01,3.010600e-01,3.983100e-01,4.591300e-01, & - &7.102800e-03,2.318400e-01,3.711700e-01,4.844200e-01,5.557700e-01, & - &6.384500e-04,6.663200e-02,1.150800e-01,1.581300e-01,1.842000e-01, & - &1.172300e-03,9.433000e-02,1.598800e-01,2.175200e-01,2.529500e-01, & - &2.055500e-03,1.281300e-01,2.131900e-01,2.868600e-01,3.331700e-01, & - &3.450700e-03,1.676200e-01,2.741900e-01,3.645300e-01,4.225200e-01, & - &5.567600e-03,2.123300e-01,3.420400e-01,4.488100e-01,5.183400e-01, & - &4.460600e-04,5.689100e-02,9.886700e-02,1.362700e-01,1.591100e-01, & - &8.454000e-04,8.232900e-02,1.405600e-01,1.918700e-01,2.237500e-01, & - &1.526600e-03,1.139300e-01,1.909200e-01,2.579200e-01,3.006500e-01, & - &2.633000e-03,1.513600e-01,2.493200e-01,3.329800e-01,3.875600e-01, & - &4.353700e-03,1.942600e-01,3.148600e-01,4.151700e-01,4.820500e-01, & - &3.075800e-04,4.817200e-02,8.422500e-02,1.164000e-01,1.363200e-01, & - &6.027300e-04,7.137900e-02,1.227400e-01,1.680600e-01,1.966700e-01, & - &1.122500e-03,1.007400e-01,1.700400e-01,2.305900e-01,2.699600e-01, & - &1.990800e-03,1.361000e-01,2.257100e-01,3.027100e-01,3.541600e-01, & - &3.378100e-03,1.770600e-01,2.887900e-01,3.826300e-01,4.469700e-01, & - &2.090700e-04,4.039400e-02,7.101900e-02,9.839600e-02,1.157100e-01, & - &4.238900e-04,6.142700e-02,1.063000e-01,1.459800e-01,1.716400e-01, & - &8.153600e-04,8.851900e-02,1.504900e-01,2.048000e-01,2.411000e-01, & - &1.490000e-03,1.217400e-01,2.032500e-01,2.737000e-01,3.223500e-01, & - &2.597200e-03,1.606800e-01,2.638000e-01,3.511200e-01,4.132300e-01, & - &1.432200e-04,3.401000e-02,6.006900e-02,8.340700e-02,9.801800e-02, & - &3.007300e-04,5.310100e-02,9.237700e-02,1.271900e-01,1.493900e-01, & - &5.971800e-04,7.812900e-02,1.336800e-01,1.824400e-01,2.146300e-01, & - &1.124100e-03,1.093400e-01,1.836800e-01,2.482200e-01,2.923800e-01, & - &2.013100e-03,1.463900e-01,2.417900e-01,3.231400e-01,3.805000e-01, & - &9.790200e-05,2.855400e-02,5.064200e-02,7.045700e-02,8.250000e-02, & - &2.130300e-04,4.582900e-02,8.013000e-02,1.105600e-01,1.292900e-01, & - &4.370500e-04,6.890600e-02,1.186100e-01,1.622900e-01,1.900400e-01, & - &8.477800e-04,9.814500e-02,1.658900e-01,2.249200e-01,2.638500e-01, & - &1.560400e-03,1.333800e-01,2.215700e-01,2.971700e-01,3.486000e-01, & - &6.598200e-05,2.374900e-02,4.228300e-02,5.893000e-02,6.877000e-02, & - &1.491800e-04,3.926900e-02,6.896600e-02,9.534700e-02,1.110700e-01, & - &3.165100e-04,6.044800e-02,1.046000e-01,1.434800e-01,1.672500e-01, & - &6.338900e-04,8.769900e-02,1.491500e-01,2.028200e-01,2.367900e-01, & - &1.200400e-03,1.210700e-01,2.022500e-01,2.722000e-01,3.180600e-01, & - &4.376700e-05,1.953500e-02,3.491200e-02,4.873200e-02,5.667300e-02, & - &1.031600e-04,3.336500e-02,5.883000e-02,8.150100e-02,9.458000e-02, & - &2.267700e-04,5.268800e-02,9.160800e-02,1.259700e-01,1.461600e-01, & - &4.691600e-04,7.796200e-02,1.333800e-01,1.818700e-01,2.113300e-01, & - &9.158800e-04,1.094200e-01,1.838200e-01,2.482600e-01,2.888600e-01, & - &2.901400e-05,1.604400e-02,2.875300e-02,4.019000e-02,4.655100e-02, & - &7.129200e-05,2.833200e-02,5.013500e-02,6.958300e-02,8.038100e-02, & - &1.626700e-04,4.593000e-02,8.023200e-02,1.105300e-01,1.275700e-01, & - &3.479100e-04,6.935900e-02,1.193200e-01,1.631000e-01,1.884000e-01, & - &7.001800e-04,9.896700e-02,1.672000e-01,2.265000e-01,2.619500e-01, & - &2.263500e-05,1.464300e-02,2.625500e-02,3.669700e-02,4.204800e-02, & - &5.721200e-05,2.633800e-02,4.666400e-02,6.479600e-02,7.396400e-02, & - &1.340500e-04,4.326500e-02,7.570200e-02,1.043600e-01,1.188700e-01, & - &2.932600e-04,6.597000e-02,1.137200e-01,1.555800e-01,1.771100e-01, & - &6.024200e-04,9.482000e-02,1.605700e-01,2.177700e-01,2.478700e-01/ - data absb(1:300,10) / & - &6.775000e-01,1.161200e+00,1.768300e+00,2.483300e+00,3.228000e+00, & - &9.886800e-01,1.319500e+00,1.843000e+00,2.454400e+00,3.158700e+00, & - &1.361900e+00,1.527400e+00,1.940600e+00,2.441100e+00,3.100000e+00, & - &1.789900e+00,1.756500e+00,2.079300e+00,2.469600e+00,3.049400e+00, & - &2.273400e+00,2.012000e+00,2.241500e+00,2.507200e+00,3.002200e+00, & - &6.613400e-01,1.226500e+00,1.937100e+00,2.727500e+00,3.543500e+00, & - &9.543400e-01,1.383900e+00,2.001600e+00,2.700900e+00,3.477400e+00, & - &1.303200e+00,1.570200e+00,2.095900e+00,2.693000e+00,3.419700e+00, & - &1.710300e+00,1.784600e+00,2.213500e+00,2.722700e+00,3.362400e+00, & - &2.170100e+00,2.031300e+00,2.348900e+00,2.740400e+00,3.302000e+00, & - &6.305100e-01,1.306500e+00,2.130200e+00,2.978700e+00,3.864700e+00, & - &9.016600e-01,1.441500e+00,2.206200e+00,2.956800e+00,3.804000e+00, & - &1.228300e+00,1.609900e+00,2.294500e+00,2.961400e+00,3.746400e+00, & - &1.607600e+00,1.807600e+00,2.389800e+00,2.989200e+00,3.681300e+00, & - &2.035000e+00,2.030200e+00,2.495200e+00,3.007800e+00,3.614900e+00, & - &5.890800e-01,1.417900e+00,2.325000e+00,3.238600e+00,4.202800e+00, & - &8.392200e-01,1.523300e+00,2.413200e+00,3.219800e+00,4.139100e+00, & - &1.139000e+00,1.656200e+00,2.508300e+00,3.240000e+00,4.076400e+00, & - &1.486700e+00,1.823900e+00,2.593900e+00,3.270400e+00,4.009000e+00, & - &1.876300e+00,2.020300e+00,2.672800e+00,3.303600e+00,3.936000e+00, & - &5.424800e-01,1.534100e+00,2.520000e+00,3.478500e+00,4.519800e+00, & - &7.692800e-01,1.634100e+00,2.620200e+00,3.479800e+00,4.458300e+00, & - &1.040400e+00,1.737400e+00,2.719400e+00,3.509900e+00,4.392400e+00, & - &1.352200e+00,1.861100e+00,2.802100e+00,3.542200e+00,4.316600e+00, & - &1.700100e+00,2.015000e+00,2.879500e+00,3.584800e+00,4.240900e+00, & - &4.934800e-01,1.638200e+00,2.711900e+00,3.698400e+00,4.797100e+00, & - &6.966900e-01,1.737400e+00,2.813900e+00,3.722100e+00,4.736100e+00, & - &9.376000e-01,1.837300e+00,2.911700e+00,3.752100e+00,4.663300e+00, & - &1.213000e+00,1.940300e+00,3.000100e+00,3.797400e+00,4.589500e+00, & - &1.521500e+00,2.054900e+00,3.082100e+00,3.847500e+00,4.515900e+00, & - &4.429400e-01,1.729400e+00,2.877200e+00,3.890000e+00,5.024600e+00, & - &6.219100e-01,1.829800e+00,2.984500e+00,3.919500e+00,4.957200e+00, & - &8.328000e-01,1.929600e+00,3.081400e+00,3.965100e+00,4.889000e+00, & - &1.075800e+00,2.030700e+00,3.170900e+00,4.028800e+00,4.827200e+00, & - &1.355300e+00,2.131300e+00,3.253000e+00,4.088500e+00,4.762500e+00, & - &3.957100e-01,1.805100e+00,3.009500e+00,4.044300e+00,5.186400e+00, & - &5.518800e-01,1.907600e+00,3.122300e+00,4.086800e+00,5.132000e+00, & - &7.374900e-01,2.007500e+00,3.224400e+00,4.159300e+00,5.076900e+00, & - &9.572100e-01,2.109600e+00,3.316400e+00,4.232400e+00,5.016500e+00, & - &1.210000e+00,2.210900e+00,3.399400e+00,4.296600e+00,4.950700e+00, & - &3.507200e-01,1.855600e+00,3.108000e+00,4.154200e+00,5.287200e+00, & - &4.876600e-01,1.960700e+00,3.223100e+00,4.228300e+00,5.244200e+00, & - &6.544000e-01,2.064700e+00,3.331600e+00,4.316000e+00,5.197700e+00, & - &8.512300e-01,2.167500e+00,3.426800e+00,4.394400e+00,5.144600e+00, & - &1.076000e+00,2.268900e+00,3.513900e+00,4.459200e+00,5.086100e+00, & - &3.170400e-01,1.890900e+00,3.171800e+00,4.221100e+00,5.318800e+00, & - &4.411300e-01,1.996700e+00,3.292100e+00,4.325800e+00,5.289800e+00, & - &5.918200e-01,2.105200e+00,3.400600e+00,4.423500e+00,5.256600e+00, & - &7.685700e-01,2.209700e+00,3.499400e+00,4.505100e+00,5.217600e+00, & - &9.728500e-01,2.312600e+00,3.592700e+00,4.570100e+00,5.172200e+00, & - &2.892700e-01,1.901400e+00,3.196900e+00,4.266600e+00,5.304000e+00, & - &4.019100e-01,2.012500e+00,3.319100e+00,4.379500e+00,5.289000e+00, & - &5.378300e-01,2.122200e+00,3.428900e+00,4.479600e+00,5.266300e+00, & - &6.987500e-01,2.229000e+00,3.533900e+00,4.566500e+00,5.239700e+00, & - &8.860200e-01,2.335900e+00,3.632100e+00,4.637200e+00,5.210100e+00, & - &2.664800e-01,1.891400e+00,3.192700e+00,4.278500e+00,5.247000e+00, & - &3.687200e-01,2.006300e+00,3.312900e+00,4.392500e+00,5.244300e+00, & - &4.933500e-01,2.118100e+00,3.427500e+00,4.494400e+00,5.235800e+00, & - &6.423700e-01,2.228100e+00,3.539100e+00,4.587200e+00,5.222400e+00, & - &8.185300e-01,2.338800e+00,3.642400e+00,4.672100e+00,5.205700e+00/ - data absb(301:600,10) / & - &2.473500e-01,1.867600e+00,3.164400e+00,4.251200e+00,5.145700e+00, & - &3.417200e-01,1.981400e+00,3.283900e+00,4.371600e+00,5.162500e+00, & - &4.579500e-01,2.095200e+00,3.403600e+00,4.480500e+00,5.173000e+00, & - &5.979500e-01,2.211300e+00,3.520800e+00,4.580800e+00,5.173600e+00, & - &7.598400e-01,2.326400e+00,3.633600e+00,4.673800e+00,5.174300e+00, & - &2.336000e-01,1.835200e+00,3.113100e+00,4.194200e+00,5.014800e+00, & - &3.228600e-01,1.947800e+00,3.241000e+00,4.322800e+00,5.053100e+00, & - &4.320400e-01,2.064300e+00,3.366600e+00,4.443200e+00,5.081900e+00, & - &5.601600e-01,2.183800e+00,3.488900e+00,4.553500e+00,5.106300e+00, & - &7.075300e-01,2.305800e+00,3.609200e+00,4.657300e+00,5.126100e+00, & - &2.229400e-01,1.795000e+00,3.049500e+00,4.113300e+00,4.860900e+00, & - &3.070700e-01,1.909300e+00,3.186200e+00,4.256200e+00,4.922700e+00, & - &4.076900e-01,2.028600e+00,3.319200e+00,4.388600e+00,4.978100e+00, & - &5.251700e-01,2.151300e+00,3.448500e+00,4.512800e+00,5.027200e+00, & - &6.610600e-01,2.281100e+00,3.576700e+00,4.630900e+00,5.071400e+00, & - &2.127800e-01,1.751600e+00,2.979300e+00,4.020300e+00,4.702300e+00, & - &2.907700e-01,1.869500e+00,3.127500e+00,4.179000e+00,4.789100e+00, & - &3.837100e-01,1.990700e+00,3.269000e+00,4.329800e+00,4.870300e+00, & - &4.930500e-01,2.119000e+00,3.406200e+00,4.471900e+00,4.948500e+00, & - &6.187200e-01,2.253800e+00,3.541800e+00,4.599800e+00,5.021000e+00, & - &2.027000e-01,1.709400e+00,2.909900e+00,3.928300e+00,4.545500e+00, & - &2.749400e-01,1.832100e+00,3.068500e+00,4.103900e+00,4.664100e+00, & - &3.615400e-01,1.956400e+00,3.221400e+00,4.273600e+00,4.777300e+00, & - &4.630000e-01,2.090300e+00,3.369400e+00,4.431700e+00,4.883800e+00, & - &5.805700e-01,2.228900e+00,3.507900e+00,4.576300e+00,4.983000e+00, & - &1.927900e-01,1.670600e+00,2.846900e+00,3.844000e+00,4.408000e+00, & - &2.600900e-01,1.796200e+00,3.015300e+00,4.040200e+00,4.558300e+00, & - &3.407400e-01,1.928300e+00,3.179400e+00,4.225300e+00,4.703800e+00, & - &4.360400e-01,2.065500e+00,3.333700e+00,4.401100e+00,4.837700e+00, & - &5.476400e-01,2.209200e+00,3.480800e+00,4.559500e+00,4.962800e+00, & - &1.836900e-01,1.636500e+00,2.793800e+00,3.777800e+00,4.298400e+00, & - &2.467900e-01,1.768400e+00,2.972900e+00,3.990500e+00,4.481800e+00, & - &3.226600e-01,1.906100e+00,3.144200e+00,4.195000e+00,4.651900e+00, & - &4.130400e-01,2.047700e+00,3.307400e+00,4.382600e+00,4.811800e+00, & - &5.200000e-01,2.196900e+00,3.463600e+00,4.552700e+00,4.965900e+00, & - &1.755100e-01,1.609700e+00,2.754400e+00,3.728600e+00,4.221100e+00, & - &2.351000e-01,1.748600e+00,2.940700e+00,3.962400e+00,4.426300e+00, & - &3.072400e-01,1.891600e+00,3.121800e+00,4.177800e+00,4.623500e+00, & - &3.939800e-01,2.037900e+00,3.291500e+00,4.376800e+00,4.815600e+00, & - &4.978100e-01,2.192300e+00,3.458800e+00,4.557400e+00,4.986100e+00, & - &1.679900e-01,1.591400e+00,2.727400e+00,3.702400e+00,4.169700e+00, & - &2.249100e-01,1.736800e+00,2.924300e+00,3.949200e+00,4.403100e+00, & - &2.943700e-01,1.883700e+00,3.110900e+00,4.176800e+00,4.630800e+00, & - &3.784200e-01,2.036200e+00,3.289200e+00,4.383300e+00,4.842000e+00, & - &4.805700e-01,2.193100e+00,3.463400e+00,4.572100e+00,5.025600e+00, & - &1.594800e-01,1.577500e+00,2.707700e+00,3.684600e+00,4.140800e+00, & - &2.139000e-01,1.727000e+00,2.913100e+00,3.942900e+00,4.401600e+00, & - &2.808500e-01,1.879100e+00,3.104700e+00,4.179200e+00,4.652600e+00, & - &3.633400e-01,2.037100e+00,3.290400e+00,4.393800e+00,4.873300e+00, & - &4.634400e-01,2.194100e+00,3.471800e+00,4.591100e+00,5.072400e+00, & - &1.474100e-01,1.556700e+00,2.680300e+00,3.656100e+00,4.113900e+00, & - &1.986600e-01,1.709600e+00,2.892200e+00,3.925600e+00,4.401500e+00, & - &2.629300e-01,1.866400e+00,3.089800e+00,4.170900e+00,4.663300e+00, & - &3.426400e-01,2.027600e+00,3.282400e+00,4.394000e+00,4.899300e+00, & - &4.397600e-01,2.184200e+00,3.469500e+00,4.596600e+00,5.113000e+00, & - &1.321400e-01,1.525400e+00,2.638200e+00,3.609300e+00,4.074400e+00, & - &1.795600e-01,1.681300e+00,2.856700e+00,3.889600e+00,4.380600e+00, & - &2.400400e-01,1.841500e+00,3.061000e+00,4.145300e+00,4.657700e+00, & - &3.156500e-01,2.004000e+00,3.259700e+00,4.375600e+00,4.908200e+00, & - &4.087100e-01,2.161000e+00,3.452100e+00,4.583600e+00,5.137300e+00/ - data absb(601:900,10) / & - &1.131600e-01,1.475200e+00,2.568800e+00,3.526100e+00,3.993800e+00, & - &1.555800e-01,1.633700e+00,2.794600e+00,3.818800e+00,4.319400e+00, & - &2.105100e-01,1.795700e+00,3.006600e+00,4.086000e+00,4.612800e+00, & - &2.802800e-01,1.959300e+00,3.211100e+00,4.325900e+00,4.878100e+00, & - &3.668400e-01,2.118300e+00,3.409600e+00,4.543700e+00,5.123100e+00, & - &9.674800e-02,1.427500e+00,2.502500e+00,3.444800e+00,3.917800e+00, & - &1.347000e-01,1.588600e+00,2.735100e+00,3.748900e+00,4.259900e+00, & - &1.844200e-01,1.751400e+00,2.954000e+00,4.026900e+00,4.568400e+00, & - &2.486200e-01,1.916900e+00,3.163700e+00,4.276900e+00,4.849200e+00, & - &3.290500e-01,2.077600e+00,3.367200e+00,4.502700e+00,5.108200e+00, & - &8.284600e-02,1.383400e+00,2.441200e+00,3.368000e+00,3.848500e+00, & - &1.168500e-01,1.546300e+00,2.679600e+00,3.682400e+00,4.203900e+00, & - &1.619400e-01,1.710800e+00,2.904300e+00,3.969900e+00,4.528500e+00, & - &2.208800e-01,1.877900e+00,3.118800e+00,4.229200e+00,4.825000e+00, & - &2.957600e-01,2.039800e+00,3.327500e+00,4.462500e+00,5.097100e+00, & - &6.846000e-02,1.325700e+00,2.357700e+00,3.260300e+00,3.733900e+00, & - &9.798800e-02,1.490300e+00,2.602300e+00,3.587200e+00,4.104500e+00, & - &1.377500e-01,1.655900e+00,2.833600e+00,3.885800e+00,4.445800e+00, & - &1.904500e-01,1.824500e+00,3.054200e+00,4.155900e+00,4.758100e+00, & - &2.584900e-01,1.988600e+00,3.267400e+00,4.399400e+00,5.043200e+00, & - &5.623400e-02,1.269000e+00,2.272000e+00,3.149500e+00,3.613900e+00, & - &8.172400e-02,1.434200e+00,2.523000e+00,3.487500e+00,3.999200e+00, & - &1.166100e-01,1.600700e+00,2.761600e+00,3.797200e+00,4.356700e+00, & - &1.635000e-01,1.770900e+00,2.987000e+00,4.077900e+00,4.684000e+00, & - &2.248200e-01,1.937300e+00,3.203600e+00,4.331400e+00,4.982200e+00, & - &4.609900e-02,1.214600e+00,2.187200e+00,3.038100e+00,3.494500e+00, & - &6.806800e-02,1.379800e+00,2.445200e+00,3.387100e+00,3.893800e+00, & - &9.858700e-02,1.547800e+00,2.689100e+00,3.707200e+00,4.266500e+00, & - &1.402000e-01,1.718700e+00,2.919800e+00,3.998800e+00,4.609200e+00, & - &1.954400e-01,1.886400e+00,3.141400e+00,4.261600e+00,4.921300e+00, & - &3.683700e-02,1.153000e+00,2.088500e+00,2.906700e+00,3.351800e+00, & - &5.533900e-02,1.318100e+00,2.353200e+00,3.266300e+00,3.765000e+00, & - &8.151300e-02,1.486600e+00,2.602800e+00,3.598800e+00,4.152700e+00, & - &1.177300e-01,1.657000e+00,2.839900e+00,3.901200e+00,4.511500e+00, & - &1.666400e-01,1.827800e+00,3.066800e+00,4.175400e+00,4.839600e+00, & - &2.898800e-02,1.088700e+00,1.983000e+00,2.765300e+00,3.196600e+00, & - &4.433800e-02,1.253200e+00,2.254000e+00,3.134400e+00,3.624300e+00, & - &6.650100e-02,1.422200e+00,2.510500e+00,3.478900e+00,4.026000e+00, & - &9.763900e-02,1.593200e+00,2.754300e+00,3.793100e+00,4.402100e+00, & - &1.405200e-01,1.765500e+00,2.984200e+00,4.079800e+00,4.746600e+00, & - &2.267400e-02,1.025700e+00,1.878300e+00,2.622800e+00,3.041200e+00, & - &3.536100e-02,1.190600e+00,2.154400e+00,3.000700e+00,3.482100e+00, & - &5.398400e-02,1.359300e+00,2.417900e+00,3.355800e+00,3.897800e+00, & - &8.068700e-02,1.530200e+00,2.666200e+00,3.683000e+00,4.291600e+00, & - &1.180700e-01,1.703200e+00,2.902600e+00,3.980400e+00,4.653000e+00, & - &1.741000e-02,9.609400e-01,1.767400e+00,2.470600e+00,2.873900e+00, & - &2.778600e-02,1.125600e+00,2.047700e+00,2.856400e+00,3.327200e+00, & - &4.323300e-02,1.293100e+00,2.317400e+00,3.222600e+00,3.757400e+00, & - &6.579500e-02,1.464100e+00,2.572300e+00,3.562700e+00,4.167500e+00, & - &9.801700e-02,1.637200e+00,2.814700e+00,3.870800e+00,4.547400e+00, & - &1.293200e-02,8.907700e-01,1.643900e+00,2.299500e+00,2.682500e+00, & - &2.122300e-02,1.054000e+00,1.928700e+00,2.694600e+00,3.147300e+00, & - &3.377100e-02,1.220700e+00,2.204700e+00,3.071100e+00,3.592600e+00, & - &5.240100e-02,1.391600e+00,2.466700e+00,3.422600e+00,4.017700e+00, & - &7.961400e-02,1.564600e+00,2.714800e+00,3.745400e+00,4.417000e+00, & - &9.485300e-03,8.211600e-01,1.519200e+00,2.127800e+00,2.490300e+00, & - &1.601700e-02,9.836400e-01,1.809400e+00,2.530200e+00,2.965400e+00, & - &2.615100e-02,1.150000e+00,2.089700e+00,2.915200e+00,3.425800e+00, & - &4.145000e-02,1.319600e+00,2.358900e+00,3.279000e+00,3.866100e+00, & - &6.420600e-02,1.492200e+00,2.612500e+00,3.615900e+00,4.285100e+00/ - data absb(901:1175,10) / & - &6.858400e-03,7.526500e-01,1.395100e+00,1.955700e+00,2.298700e+00, & - &1.193400e-02,9.146700e-01,1.688500e+00,2.363100e+00,2.782000e+00, & - &2.001900e-02,1.079700e+00,1.973100e+00,2.756700e+00,3.256900e+00, & - &3.253200e-02,1.248100e+00,2.248400e+00,3.131200e+00,3.714400e+00, & - &5.142300e-02,1.420200e+00,2.508700e+00,3.480200e+00,4.152400e+00, & - &4.958800e-03,6.890700e-01,1.279400e+00,1.794200e+00,2.115300e+00, & - &8.894700e-03,8.504500e-01,1.573900e+00,2.204200e+00,2.603100e+00, & - &1.534800e-02,1.014300e+00,1.863200e+00,2.605600e+00,3.087000e+00, & - &2.560800e-02,1.182100e+00,2.143000e+00,2.988800e+00,3.559600e+00, & - &4.138700e-02,1.353600e+00,2.410100e+00,3.348100e+00,4.011500e+00, & - &3.557100e-03,6.278500e-01,1.167800e+00,1.638600e+00,1.936900e+00, & - &6.589300e-03,7.887600e-01,1.462400e+00,2.049800e+00,2.425700e+00, & - &1.170700e-02,9.517700e-01,1.755100e+00,2.456600e+00,2.916200e+00, & - &2.007400e-02,1.118700e+00,2.038700e+00,2.846600e+00,3.399800e+00, & - &3.327300e-02,1.289000e+00,2.311700e+00,3.216800e+00,3.865100e+00, & - &2.512700e-03,5.682000e-01,1.058300e+00,1.486400e+00,1.762400e+00, & - &4.824800e-03,7.279200e-01,1.351200e+00,1.895200e+00,2.249000e+00, & - &8.834600e-03,8.902900e-01,1.646300e+00,2.305200e+00,2.745200e+00, & - &1.558300e-02,1.055800e+00,1.933600e+00,2.703300e+00,3.239100e+00, & - &2.652900e-02,1.224600e+00,2.211500e+00,3.082400e+00,3.718000e+00, & - &1.745900e-03,5.101000e-01,9.513600e-01,1.336700e+00,1.591600e+00, & - &3.480800e-03,6.672900e-01,1.240300e+00,1.740500e+00,2.074600e+00, & - &6.587200e-03,8.289900e-01,1.536300e+00,2.152900e+00,2.574700e+00, & - &1.196200e-02,9.932500e-01,1.827900e+00,2.557600e+00,3.078300e+00, & - &2.095100e-02,1.161600e+00,2.109600e+00,2.944000e+00,3.571500e+00, & - &1.220400e-03,4.582300e-01,8.557900e-01,1.202500e+00,1.432600e+00, & - &2.528100e-03,6.121200e-01,1.139600e+00,1.599900e+00,1.906900e+00, & - &4.940900e-03,7.733800e-01,1.435000e+00,2.012500e+00,2.404100e+00, & - &9.243600e-03,9.369500e-01,1.729500e+00,2.421500e+00,2.909400e+00, & - &1.667000e-02,1.104000e+00,2.014500e+00,2.814200e+00,3.409500e+00, & - &8.490400e-04,4.103100e-01,7.671400e-01,1.077700e+00,1.281000e+00, & - &1.828900e-03,5.605100e-01,1.044500e+00,1.467500e+00,1.743700e+00, & - &3.695700e-03,7.204900e-01,1.338100e+00,1.877500e+00,2.234600e+00, & - &7.133800e-03,8.832000e-01,1.634200e+00,2.288800e+00,2.735600e+00, & - &1.324800e-02,1.049000e+00,1.922600e+00,2.688600e+00,3.236600e+00, & - &5.818800e-04,3.645100e-01,6.818800e-01,9.577500e-01,1.136400e+00, & - &1.306100e-03,5.101000e-01,9.515700e-01,1.337300e+00,1.584900e+00, & - &2.734800e-03,6.677500e-01,1.241600e+00,1.742600e+00,2.067500e+00, & - &5.450600e-03,8.298200e-01,1.538400e+00,2.156000e+00,2.565600e+00, & - &1.043800e-02,9.946400e-01,1.830400e+00,2.561700e+00,3.064300e+00, & - &3.924900e-04,3.206800e-01,6.004400e-01,8.428000e-01,9.987300e-01, & - &9.203000e-04,4.608300e-01,8.607700e-01,1.209800e+00,1.430200e+00, & - &2.000200e-03,6.154200e-01,1.146000e+00,1.609100e+00,1.902900e+00, & - &4.123500e-03,7.770800e-01,1.442200e+00,2.022700e+00,2.396700e+00, & - &8.147800e-03,9.409800e-01,1.736900e+00,2.432300e+00,2.893300e+00, & - &2.643000e-04,2.812200e-01,5.269500e-01,7.393000e-01,8.742000e-01, & - &6.482100e-04,4.157900e-01,7.774500e-01,1.092200e+00,1.287500e+00, & - &1.462400e-03,5.668500e-01,1.056400e+00,1.484400e+00,1.748900e+00, & - &3.120600e-03,7.274000e-01,1.351000e+00,1.895800e+00,2.235700e+00, & - &6.362800e-03,8.904100e-01,1.647400e+00,2.307500e+00,2.730200e+00, & - &2.099000e-04,2.657500e-01,4.980600e-01,6.985600e-01,8.192200e-01, & - &5.294200e-04,3.978700e-01,7.441600e-01,1.045300e+00,1.221300e+00, & - &1.225400e-03,5.473700e-01,1.020600e+00,1.434200e+00,1.673500e+00, & - &2.684000e-03,7.071200e-01,1.314100e+00,1.844200e+00,2.150700e+00, & - &5.618200e-03,8.700700e-01,1.611100e+00,2.256900e+00,2.637100e+00/ - data absb(1:300,11) / & - &1.080100e+00,1.434800e+00,2.078900e+00,2.876600e+00,3.708800e+00, & - &1.578600e+00,1.690900e+00,2.234400e+00,2.837800e+00,3.615400e+00, & - &2.180600e+00,1.987800e+00,2.394500e+00,2.821200e+00,3.532600e+00, & - &2.872000e+00,2.380000e+00,2.591400e+00,2.838500e+00,3.465500e+00, & - &3.641100e+00,2.891100e+00,2.848000e+00,2.911600e+00,3.422800e+00, & - &1.104400e+00,1.547500e+00,2.249700e+00,3.146300e+00,4.088400e+00, & - &1.597100e+00,1.793900e+00,2.379400e+00,3.105400e+00,3.998000e+00, & - &2.182100e+00,2.098700e+00,2.550700e+00,3.087000e+00,3.920800e+00, & - &2.850200e+00,2.450900e+00,2.767100e+00,3.110800e+00,3.850300e+00, & - &3.588400e+00,2.892100e+00,3.008900e+00,3.170500e+00,3.785100e+00, & - &1.102100e+00,1.658700e+00,2.481500e+00,3.502400e+00,4.563200e+00, & - &1.574300e+00,1.898800e+00,2.574500e+00,3.461200e+00,4.469100e+00, & - &2.131500e+00,2.184800e+00,2.731900e+00,3.437000e+00,4.381900e+00, & - &2.765000e+00,2.513800e+00,2.933100e+00,3.463300e+00,4.303200e+00, & - &3.472700e+00,2.903200e+00,3.157900e+00,3.504400e+00,4.222700e+00, & - &1.071400e+00,1.758800e+00,2.756400e+00,3.874700e+00,5.050800e+00, & - &1.515000e+00,1.987300e+00,2.855000e+00,3.842600e+00,4.960500e+00, & - &2.036800e+00,2.247000e+00,2.977300e+00,3.835100e+00,4.871600e+00, & - &2.636800e+00,2.553300e+00,3.136100e+00,3.853600e+00,4.786300e+00, & - &3.306600e+00,2.915100e+00,3.317400e+00,3.876200e+00,4.694800e+00, & - &1.015100e+00,1.885200e+00,3.051800e+00,4.262800e+00,5.554200e+00, & - &1.425000e+00,2.070000e+00,3.161400e+00,4.228800e+00,5.460100e+00, & - &1.912100e+00,2.300100e+00,3.277600e+00,4.234800e+00,5.367900e+00, & - &2.469400e+00,2.577000e+00,3.403700e+00,4.255800e+00,5.273000e+00, & - &3.089900e+00,2.904900e+00,3.538300e+00,4.289800e+00,5.174700e+00, & - &9.429000e-01,2.048400e+00,3.346900e+00,4.647900e+00,6.057500e+00, & - &1.320500e+00,2.193100e+00,3.472800e+00,4.618300e+00,5.956300e+00, & - &1.765500e+00,2.371700e+00,3.595900e+00,4.641200e+00,5.859100e+00, & - &2.274200e+00,2.601400e+00,3.707600e+00,4.670400e+00,5.757600e+00, & - &2.836800e+00,2.883400e+00,3.814900e+00,4.723900e+00,5.649300e+00, & - &8.643700e-01,2.216700e+00,3.642300e+00,5.010700e+00,6.525800e+00, & - &1.205200e+00,2.353600e+00,3.777800e+00,5.013700e+00,6.433600e+00, & - &1.606300e+00,2.496300e+00,3.907800e+00,5.040900e+00,6.331700e+00, & - &2.061300e+00,2.667300e+00,4.021600e+00,5.084800e+00,6.217200e+00, & - &2.563500e+00,2.885200e+00,4.123300e+00,5.145700e+00,6.096900e+00, & - &7.877900e-01,2.376500e+00,3.926400e+00,5.349900e+00,6.948000e+00, & - &1.092600e+00,2.514800e+00,4.067000e+00,5.383400e+00,6.855300e+00, & - &1.448700e+00,2.652500e+00,4.196200e+00,5.417900e+00,6.749600e+00, & - &1.851300e+00,2.791600e+00,4.314800e+00,5.486200e+00,6.637000e+00, & - &2.299100e+00,2.951000e+00,4.421600e+00,5.549800e+00,6.522800e+00, & - &7.093200e-01,2.517500e+00,4.182400e+00,5.652500e+00,7.295700e+00, & - &9.780100e-01,2.660200e+00,4.330000e+00,5.698400e+00,7.206000e+00, & - &1.290800e+00,2.797700e+00,4.456500e+00,5.767500e+00,7.111500e+00, & - &1.648600e+00,2.933700e+00,4.578400e+00,5.851400e+00,7.011200e+00, & - &2.054800e+00,3.066200e+00,4.688400e+00,5.921100e+00,6.905100e+00, & - &6.463400e-01,2.642700e+00,4.410800e+00,5.911100e+00,7.560300e+00, & - &8.838200e-01,2.788600e+00,4.560500e+00,5.982100e+00,7.487400e+00, & - &1.163000e+00,2.929200e+00,4.695400e+00,6.087900e+00,7.404200e+00, & - &1.488500e+00,3.066400e+00,4.818400e+00,6.185500e+00,7.313600e+00, & - &1.858800e+00,3.197500e+00,4.929300e+00,6.261800e+00,7.215300e+00, & - &5.848900e-01,2.744600e+00,4.594000e+00,6.113500e+00,7.749100e+00, & - &7.968200e-01,2.891200e+00,4.748800e+00,6.235600e+00,7.692800e+00, & - &1.050400e+00,3.034600e+00,4.896800e+00,6.360800e+00,7.628700e+00, & - &1.344700e+00,3.172500e+00,5.024200e+00,6.468900e+00,7.552100e+00, & - &1.680700e+00,3.304800e+00,5.138200e+00,6.552400e+00,7.463200e+00, & - &5.298900e-01,2.819500e+00,4.730100e+00,6.276100e+00,7.855000e+00, & - &7.219800e-01,2.970200e+00,4.897400e+00,6.438000e+00,7.824300e+00, & - &9.513400e-01,3.116400e+00,5.050400e+00,6.581700e+00,7.781600e+00, & - &1.219600e+00,3.253700e+00,5.188500e+00,6.694000e+00,7.724900e+00, & - &1.526500e+00,3.385100e+00,5.308900e+00,6.782200e+00,7.656300e+00/ - data absb(301:600,11) / & - &4.847600e-01,2.869700e+00,4.821800e+00,6.409700e+00,7.902600e+00, & - &6.596900e-01,3.027400e+00,5.002900e+00,6.589000e+00,7.897300e+00, & - &8.690600e-01,3.175400e+00,5.165600e+00,6.741000e+00,7.877200e+00, & - &1.115200e+00,3.312000e+00,5.311100e+00,6.867900e+00,7.846200e+00, & - &1.402400e+00,3.444900e+00,5.436300e+00,6.967400e+00,7.797800e+00, & - &4.492000e-01,2.900400e+00,4.883400e+00,6.504100e+00,7.908900e+00, & - &6.099900e-01,3.062800e+00,5.071300e+00,6.696600e+00,7.930400e+00, & - &8.037600e-01,3.212400e+00,5.245200e+00,6.862900e+00,7.936100e+00, & - &1.035800e+00,3.352300e+00,5.400300e+00,7.002700e+00,7.928500e+00, & - &1.307300e+00,3.483800e+00,5.529900e+00,7.113600e+00,7.907500e+00, & - &4.195200e-01,2.913300e+00,4.916000e+00,6.569300e+00,7.890100e+00, & - &5.691100e-01,3.077400e+00,5.113200e+00,6.775500e+00,7.937800e+00, & - &7.527300e-01,3.229700e+00,5.294800e+00,6.953200e+00,7.970700e+00, & - &9.735100e-01,3.374500e+00,5.456300e+00,7.105400e+00,7.986500e+00, & - &1.229300e+00,3.506400e+00,5.593800e+00,7.229700e+00,7.985700e+00, & - &3.952400e-01,2.911200e+00,4.931600e+00,6.615100e+00,7.847800e+00, & - &5.376500e-01,3.076400e+00,5.135000e+00,6.831300e+00,7.930900e+00, & - &7.126400e-01,3.234300e+00,5.324800e+00,7.020700e+00,7.989800e+00, & - &9.190300e-01,3.381600e+00,5.491500e+00,7.184400e+00,8.026100e+00, & - &1.158500e+00,3.517800e+00,5.638400e+00,7.325100e+00,8.045300e+00, & - &3.785000e-01,2.900600e+00,4.939100e+00,6.642400e+00,7.802500e+00, & - &5.145000e-01,3.067300e+00,5.151200e+00,6.872000e+00,7.913000e+00, & - &6.782500e-01,3.230300e+00,5.344700e+00,7.074400e+00,7.998800e+00, & - &8.709400e-01,3.379700e+00,5.516900e+00,7.252500e+00,8.060300e+00, & - &1.095100e+00,3.526600e+00,5.674500e+00,7.398900e+00,8.096400e+00, & - &3.652400e-01,2.887600e+00,4.940800e+00,6.661300e+00,7.756900e+00, & - &4.937900e-01,3.058100e+00,5.161200e+00,6.905800e+00,7.899000e+00, & - &6.472000e-01,3.221600e+00,5.359400e+00,7.124600e+00,8.007800e+00, & - &8.277600e-01,3.377300e+00,5.542300e+00,7.307400e+00,8.087300e+00, & - &1.038100e+00,3.532700e+00,5.703700e+00,7.462500e+00,8.138800e+00, & - &3.530800e-01,2.878200e+00,4.947700e+00,6.680300e+00,7.726500e+00, & - &4.748800e-01,3.050400e+00,5.172700e+00,6.944100e+00,7.890300e+00, & - &6.200200e-01,3.213100e+00,5.380000e+00,7.168000e+00,8.023800e+00, & - &7.913200e-01,3.376700e+00,5.567500e+00,7.359900e+00,8.123200e+00, & - &9.910300e-01,3.540000e+00,5.731100e+00,7.524900e+00,8.187100e+00, & - &3.415000e-01,2.872000e+00,4.958200e+00,6.713300e+00,7.705400e+00, & - &4.574700e-01,3.043700e+00,5.193000e+00,6.982600e+00,7.902400e+00, & - &5.967000e-01,3.209900e+00,5.402700e+00,7.216900e+00,8.054500e+00, & - &7.607800e-01,3.379700e+00,5.591500e+00,7.416200e+00,8.162100e+00, & - &9.533500e-01,3.546800e+00,5.756700e+00,7.582000e+00,8.248200e+00, & - &3.311200e-01,2.870700e+00,4.978900e+00,6.754400e+00,7.716300e+00, & - &4.424100e-01,3.042900e+00,5.216600e+00,7.030200e+00,7.931000e+00, & - &5.762200e-01,3.214000e+00,5.428800e+00,7.270500e+00,8.089000e+00, & - &7.358700e-01,3.388500e+00,5.620100e+00,7.472000e+00,8.215400e+00, & - &9.241000e-01,3.557200e+00,5.785500e+00,7.637300e+00,8.324000e+00, & - &3.187000e-01,2.867300e+00,5.000300e+00,6.793200e+00,7.735000e+00, & - &4.254500e-01,3.041000e+00,5.238300e+00,7.075700e+00,7.956200e+00, & - &5.547800e-01,3.216500e+00,5.452600e+00,7.318500e+00,8.128900e+00, & - &7.099000e-01,3.394700e+00,5.645300e+00,7.521100e+00,8.280700e+00, & - &8.954800e-01,3.565800e+00,5.809100e+00,7.684500e+00,8.395700e+00, & - &2.989900e-01,2.852800e+00,5.002200e+00,6.809800e+00,7.735200e+00, & - &4.003500e-01,3.029600e+00,5.243500e+00,7.100100e+00,7.973000e+00, & - &5.242500e-01,3.208800e+00,5.461900e+00,7.346600e+00,8.171800e+00, & - &6.740300e-01,3.388500e+00,5.655800e+00,7.552600e+00,8.342600e+00, & - &8.558800e-01,3.563600e+00,5.821500e+00,7.718400e+00,8.469500e+00, & - &2.726700e-01,2.824700e+00,4.981100e+00,6.796700e+00,7.717100e+00, & - &3.673000e-01,3.003600e+00,5.228200e+00,7.096200e+00,7.979400e+00, & - &4.841000e-01,3.186300e+00,5.451400e+00,7.351700e+00,8.206600e+00, & - &6.274500e-01,3.369300e+00,5.648600e+00,7.563400e+00,8.392300e+00, & - &8.026500e-01,3.546200e+00,5.817400e+00,7.733800e+00,8.536300e+00/ - data absb(601:900,11) / & - &2.378900e-01,2.773100e+00,4.924100e+00,6.734600e+00,7.659400e+00, & - &3.237100e-01,2.954600e+00,5.179700e+00,7.051800e+00,7.950200e+00, & - &4.309300e-01,3.139600e+00,5.410300e+00,7.320600e+00,8.206700e+00, & - &5.643200e-01,3.326100e+00,5.615400e+00,7.543000e+00,8.410700e+00, & - &7.292100e-01,3.505500e+00,5.790600e+00,7.723100e+00,8.576700e+00, & - &2.073500e-01,2.724600e+00,4.864300e+00,6.668600e+00,7.600200e+00, & - &2.853000e-01,2.907500e+00,5.130300e+00,7.002300e+00,7.923300e+00, & - &3.834900e-01,3.095200e+00,5.368800e+00,7.283800e+00,8.207900e+00, & - &5.078100e-01,3.283400e+00,5.580500e+00,7.517200e+00,8.432100e+00, & - &6.630700e-01,3.466300e+00,5.763000e+00,7.707200e+00,8.619100e+00, & - &1.808200e-01,2.679700e+00,4.806400e+00,6.600100e+00,7.547600e+00, & - &2.518600e-01,2.865100e+00,5.081900e+00,6.949500e+00,7.907000e+00, & - &3.424000e-01,3.053200e+00,5.328200e+00,7.244600e+00,8.213900e+00, & - &4.584200e-01,3.243900e+00,5.546700e+00,7.489600e+00,8.460200e+00, & - &6.050900e-01,3.429800e+00,5.734100e+00,7.688100e+00,8.668200e+00, & - &1.520700e-01,2.617900e+00,4.717600e+00,6.488600e+00,7.444900e+00, & - &2.151200e-01,2.805900e+00,5.008600e+00,6.860900e+00,7.832800e+00, & - &2.968900e-01,2.994300e+00,5.263800e+00,7.174300e+00,8.166400e+00, & - &4.025400e-01,3.187600e+00,5.491300e+00,7.435700e+00,8.434900e+00, & - &5.378500e-01,3.376300e+00,5.688000e+00,7.647400e+00,8.662700e+00, & - &1.269500e-01,2.554200e+00,4.622800e+00,6.367200e+00,7.329400e+00, & - &1.825200e-01,2.747000e+00,4.928800e+00,6.762800e+00,7.744700e+00, & - &2.561400e-01,2.936300e+00,5.193800e+00,7.096500e+00,8.106400e+00, & - &3.521400e-01,3.128700e+00,5.431600e+00,7.374100e+00,8.398500e+00, & - &4.764200e-01,3.319700e+00,5.639000e+00,7.599500e+00,8.645200e+00, & - &1.057200e-01,2.491400e+00,4.526400e+00,6.242500e+00,7.210300e+00, & - &1.545000e-01,2.689000e+00,4.846000e+00,6.659300e+00,7.650600e+00, & - &2.204600e-01,2.877500e+00,5.122800e+00,7.012900e+00,8.040500e+00, & - &3.079400e-01,3.070400e+00,5.370500e+00,7.307000e+00,8.357600e+00, & - &4.224300e-01,3.265500e+00,5.585900e+00,7.548400e+00,8.623400e+00, & - &8.579900e-02,2.415800e+00,4.406400e+00,6.085400e+00,7.053500e+00, & - &1.277600e-01,2.619800e+00,4.743900e+00,6.528900e+00,7.526000e+00, & - &1.855500e-01,2.811000e+00,5.035800e+00,6.905200e+00,7.945900e+00, & - &2.639900e-01,3.004400e+00,5.293000e+00,7.220000e+00,8.290200e+00, & - &3.676100e-01,3.200300e+00,5.519100e+00,7.479900e+00,8.578600e+00, & - &6.853500e-02,2.335400e+00,4.272100e+00,5.908700e+00,6.876200e+00, & - &1.042100e-01,2.546800e+00,4.628300e+00,6.379200e+00,7.381500e+00, & - &1.542000e-01,2.741800e+00,4.935800e+00,6.781000e+00,7.833600e+00, & - &2.234700e-01,2.933500e+00,5.204400e+00,7.119500e+00,8.208300e+00, & - &3.168200e-01,3.129400e+00,5.446100e+00,7.398100e+00,8.521700e+00, & - &5.445700e-02,2.253500e+00,4.132000e+00,5.723800e+00,6.689400e+00, & - &8.454900e-02,2.471100e+00,4.506500e+00,6.219800e+00,7.229300e+00, & - &1.276100e-01,2.671700e+00,4.832400e+00,6.649200e+00,7.714600e+00, & - &1.883700e-01,2.863300e+00,5.115500e+00,7.010000e+00,8.120500e+00, & - &2.722700e-01,3.059200e+00,5.365300e+00,7.308900e+00,8.460000e+00, & - &4.258900e-02,2.164900e+00,3.978400e+00,5.516300e+00,6.479600e+00, & - &6.756000e-02,2.389300e+00,4.372200e+00,6.043000e+00,7.055100e+00, & - &1.041700e-01,2.596800e+00,4.717300e+00,6.498800e+00,7.574900e+00, & - &1.568600e-01,2.791200e+00,5.015000e+00,6.884400e+00,8.016700e+00, & - &2.310200e-01,2.986000e+00,5.276300e+00,7.208400e+00,8.384400e+00, & - &3.232900e-02,2.063500e+00,3.799000e+00,5.274600e+00,6.227000e+00, & - &5.262100e-02,2.297400e+00,4.214000e+00,5.833800e+00,6.841300e+00, & - &8.296600e-02,2.512400e+00,4.579000e+00,6.318300e+00,7.395700e+00, & - &1.276500e-01,2.711100e+00,4.896200e+00,6.735500e+00,7.877300e+00, & - &1.918300e-01,2.903900e+00,5.173300e+00,7.084900e+00,8.276900e+00, & - &2.426000e-02,1.959000e+00,3.611400e+00,5.021900e+00,5.961400e+00, & - &4.066100e-02,2.201600e+00,4.047100e+00,5.610900e+00,6.616200e+00, & - &6.556700e-02,2.424200e+00,4.435000e+00,6.127200e+00,7.206600e+00, & - &1.031600e-01,2.629700e+00,4.772600e+00,6.574000e+00,7.727700e+00, & - &1.582700e-01,2.823500e+00,5.065000e+00,6.949800e+00,8.163600e+00/ - data absb(901:1175,11) / & - &1.799400e-02,1.849900e+00,3.418200e+00,4.755700e+00,5.686000e+00, & - &3.108800e-02,2.103900e+00,3.873500e+00,5.375400e+00,6.383300e+00, & - &5.145500e-02,2.334800e+00,4.282400e+00,5.925200e+00,7.012100e+00, & - &8.268900e-02,2.547100e+00,4.639500e+00,6.400100e+00,7.572000e+00, & - &1.297700e-01,2.744900e+00,4.949400e+00,6.805400e+00,8.048100e+00, & - &1.337100e-02,1.745900e+00,3.231400e+00,4.495400e+00,5.407800e+00, & - &2.383300e-02,2.008400e+00,3.702600e+00,5.145600e+00,6.141400e+00, & - &4.055900e-02,2.247400e+00,4.129600e+00,5.723600e+00,6.805600e+00, & - &6.664800e-02,2.467100e+00,4.507600e+00,6.225800e+00,7.401800e+00, & - &1.068300e-01,2.669400e+00,4.836300e+00,6.660200e+00,7.913600e+00, & - &9.865300e-03,1.642900e+00,3.045100e+00,4.235800e+00,5.123100e+00, & - &1.820100e-02,1.912400e+00,3.529900e+00,4.911300e+00,5.890300e+00, & - &3.189800e-02,2.160500e+00,3.976400e+00,5.516200e+00,6.586900e+00, & - &5.371200e-02,2.386900e+00,4.374300e+00,6.048900e+00,7.217300e+00, & - &8.777200e-02,2.595500e+00,4.720900e+00,6.508700e+00,7.762500e+00, & - &7.165300e-03,1.538100e+00,2.854400e+00,3.967400e+00,4.830800e+00, & - &1.376500e-02,1.813700e+00,3.354400e+00,4.667500e+00,5.632700e+00, & - &2.485500e-02,2.071200e+00,3.817300e+00,5.300300e+00,6.362500e+00, & - &4.300700e-02,2.305300e+00,4.232900e+00,5.861700e+00,7.026100e+00, & - &7.174600e-02,2.520900e+00,4.597600e+00,6.346400e+00,7.607400e+00, & - &5.111500e-03,1.431900e+00,2.659800e+00,3.692300e+00,4.532700e+00, & - &1.026400e-02,1.713200e+00,3.173200e+00,4.413800e+00,5.364400e+00, & - &1.916800e-02,1.978700e+00,3.649700e+00,5.075000e+00,6.131100e+00, & - &3.414200e-02,2.220600e+00,4.084100e+00,5.662900e+00,6.830500e+00, & - &5.832000e-02,2.442900e+00,4.469400e+00,6.175500e+00,7.452100e+00, & - &3.659900e-03,1.333100e+00,2.476900e+00,3.437200e+00,4.236800e+00, & - &7.695400e-03,1.618900e+00,3.002000e+00,4.175500e+00,5.091000e+00, & - &1.492700e-02,1.890300e+00,3.491400e+00,4.858500e+00,5.881100e+00, & - &2.735400e-02,2.141100e+00,3.943200e+00,5.471800e+00,6.607100e+00, & - &4.788000e-02,2.369400e+00,4.345500e+00,6.011900e+00,7.253000e+00, & - &2.604100e-03,1.237700e+00,2.299900e+00,3.190000e+00,3.937700e+00, & - &5.742900e-03,1.527100e+00,2.834900e+00,3.939700e+00,4.808400e+00, & - &1.160700e-02,1.803600e+00,3.337200e+00,4.643300e+00,5.618300e+00, & - &2.191900e-02,2.062400e+00,3.802400e+00,5.280800e+00,6.360600e+00, & - &3.935700e-02,2.297600e+00,4.220500e+00,5.846200e+00,7.032000e+00, & - &1.821200e-03,1.142300e+00,2.123400e+00,2.941500e+00,3.640200e+00, & - &4.222000e-03,1.434400e+00,2.664800e+00,3.699300e+00,4.521600e+00, & - &8.919900e-03,1.716100e+00,3.179100e+00,4.422400e+00,5.351400e+00, & - &1.744300e-02,1.981800e+00,3.656100e+00,5.084100e+00,6.110900e+00, & - &3.214600e-02,2.223600e+00,4.090400e+00,5.671800e+00,6.803800e+00, & - &1.248700e-03,1.047500e+00,1.945200e+00,2.692000e+00,3.345400e+00, & - &3.055600e-03,1.340700e+00,2.491200e+00,3.456700e+00,4.231800e+00, & - &6.763300e-03,1.626600e+00,3.016500e+00,4.195600e+00,5.079000e+00, & - &1.376200e-02,1.898100e+00,3.505600e+00,4.878100e+00,5.857800e+00, & - &2.606200e-02,2.148100e+00,3.956600e+00,5.490300e+00,6.566300e+00, & - &8.519000e-04,9.576900e-01,1.777000e+00,2.458000e+00,3.067300e+00, & - &2.204800e-03,1.251000e+00,2.324700e+00,3.224900e+00,3.952800e+00, & - &5.122700e-03,1.540400e+00,2.859300e+00,3.974200e+00,4.812000e+00, & - &1.085700e-02,1.816500e+00,3.360700e+00,4.676100e+00,5.610200e+00, & - &2.120700e-02,2.074300e+00,3.824700e+00,5.311100e+00,6.331500e+00, & - &6.915600e-04,9.214800e-01,1.709100e+00,2.363900e+00,2.947000e+00, & - &1.855400e-03,1.214600e+00,2.257300e+00,3.130100e+00,3.822900e+00, & - &4.454600e-03,1.505200e+00,2.795100e+00,3.883400e+00,4.672800e+00, & - &9.702200e-03,1.783300e+00,3.300900e+00,4.592800e+00,5.469600e+00, & - &1.931000e-02,2.044000e+00,3.769900e+00,5.237200e+00,6.182800e+00/ - data absb(1:300,12) / & - &1.656500e+00,1.784800e+00,2.570000e+00,3.571700e+00,4.598800e+00, & - &2.421500e+00,2.127100e+00,2.699900e+00,3.548500e+00,4.464100e+00, & - &3.336900e+00,2.681500e+00,2.957600e+00,3.500900e+00,4.321600e+00, & - &4.403900e+00,3.440100e+00,3.267900e+00,3.486900e+00,4.179800e+00, & - &5.594100e+00,4.325100e+00,3.607900e+00,3.552300e+00,4.071800e+00, & - &1.776200e+00,1.942100e+00,2.786400e+00,3.879500e+00,4.995900e+00, & - &2.572900e+00,2.328900e+00,2.940700e+00,3.834400e+00,4.846000e+00, & - &3.525600e+00,2.853200e+00,3.173500e+00,3.781500e+00,4.693700e+00, & - &4.622500e+00,3.606200e+00,3.487800e+00,3.772700e+00,4.559200e+00, & - &5.838300e+00,4.504000e+00,3.888700e+00,3.865000e+00,4.444500e+00, & - &1.872100e+00,2.119100e+00,3.024100e+00,4.207500e+00,5.443000e+00, & - &2.686200e+00,2.525000e+00,3.199500e+00,4.149900e+00,5.299300e+00, & - &3.654900e+00,3.029500e+00,3.440000e+00,4.104400e+00,5.166500e+00, & - &4.757000e+00,3.725900e+00,3.769100e+00,4.118000e+00,5.047200e+00, & - &5.964800e+00,4.594900e+00,4.161100e+00,4.207900e+00,4.942600e+00, & - &1.929000e+00,2.303800e+00,3.314600e+00,4.643500e+00,6.040700e+00, & - &2.743100e+00,2.708400e+00,3.467300e+00,4.569800e+00,5.896600e+00, & - &3.697000e+00,3.204000e+00,3.734500e+00,4.521400e+00,5.768700e+00, & - &4.771500e+00,3.827200e+00,4.066600e+00,4.554500e+00,5.647600e+00, & - &5.949600e+00,4.612700e+00,4.440200e+00,4.620700e+00,5.533800e+00, & - &1.937300e+00,2.482800e+00,3.669700e+00,5.179600e+00,6.761200e+00, & - &2.725500e+00,2.875500e+00,3.815900e+00,5.104200e+00,6.616700e+00, & - &3.639500e+00,3.355200e+00,4.059100e+00,5.064000e+00,6.479100e+00, & - &4.671400e+00,3.909200e+00,4.362900e+00,5.091900e+00,6.347100e+00, & - &5.813800e+00,4.604000e+00,4.712300e+00,5.132000e+00,6.213600e+00, & - &1.892300e+00,2.660100e+00,4.095000e+00,5.768900e+00,7.529200e+00, & - &2.635800e+00,3.029100e+00,4.249500e+00,5.704500e+00,7.389600e+00, & - &3.500500e+00,3.469900e+00,4.450800e+00,5.682400e+00,7.244900e+00, & - &4.483100e+00,3.985900e+00,4.696800e+00,5.697600e+00,7.097200e+00, & - &5.580300e+00,4.600500e+00,4.991200e+00,5.719100e+00,6.947300e+00, & - &1.802600e+00,2.867500e+00,4.564300e+00,6.396600e+00,8.344600e+00, & - &2.495500e+00,3.175000e+00,4.734600e+00,6.328000e+00,8.185800e+00, & - &3.306500e+00,3.565600e+00,4.909600e+00,6.327800e+00,8.027400e+00, & - &4.233600e+00,4.037300e+00,5.101800e+00,6.340000e+00,7.873400e+00, & - &5.263800e+00,4.596500e+00,5.328100e+00,6.374900e+00,7.718600e+00, & - &1.692400e+00,3.115900e+00,5.061500e+00,7.019300e+00,9.150900e+00, & - &2.334200e+00,3.360900e+00,5.247500e+00,6.965100e+00,8.980200e+00, & - &3.088300e+00,3.680800e+00,5.421600e+00,6.980100e+00,8.812900e+00, & - &3.946300e+00,4.084800e+00,5.577700e+00,7.001200e+00,8.646300e+00, & - &4.896100e+00,4.573600e+00,5.751200e+00,7.066300e+00,8.474300e+00, & - &1.569000e+00,3.391800e+00,5.567900e+00,7.632500e+00,9.935900e+00, & - &2.158600e+00,3.595900e+00,5.763200e+00,7.613100e+00,9.763100e+00, & - &2.847600e+00,3.843900e+00,5.941500e+00,7.631700e+00,9.582900e+00, & - &3.627600e+00,4.163400e+00,6.089400e+00,7.683800e+00,9.402300e+00, & - &4.491700e+00,4.564200e+00,6.227100e+00,7.763000e+00,9.213700e+00, & - &1.469900e+00,3.683800e+00,6.074400e+00,8.220200e+00,1.066400e+01, & - &2.008100e+00,3.877000e+00,6.277900e+00,8.240100e+00,1.048500e+01, & - &2.632200e+00,4.076800e+00,6.452600e+00,8.280400e+00,1.030600e+01, & - &3.338500e+00,4.317400e+00,6.600300e+00,8.366600e+00,1.011500e+01, & - &4.122400e+00,4.629400e+00,6.722000e+00,8.442000e+00,9.916700e+00, & - &1.363500e+00,3.953500e+00,6.557800e+00,8.789100e+00,1.131700e+01, & - &1.847900e+00,4.147200e+00,6.765300e+00,8.830600e+00,1.115100e+01, & - &2.409000e+00,4.329100e+00,6.929900e+00,8.912400e+00,1.097100e+01, & - &3.047600e+00,4.518600e+00,7.075700e+00,9.015800e+00,1.078100e+01, & - &3.767700e+00,4.746600e+00,7.191600e+00,9.085800e+00,1.058000e+01, & - &1.252400e+00,4.196400e+00,7.002700e+00,9.308800e+00,1.189100e+01, & - &1.686000e+00,4.386600e+00,7.206100e+00,9.389400e+00,1.174000e+01, & - &2.191600e+00,4.563200e+00,7.370700e+00,9.516100e+00,1.157400e+01, & - &2.775500e+00,4.731000e+00,7.504000e+00,9.623900e+00,1.139000e+01, & - &3.442100e+00,4.911200e+00,7.614100e+00,9.687300e+00,1.118900e+01/ - data absb(301:600,12) / & - &1.144400e+00,4.409300e+00,7.396300e+00,9.770200e+00,1.238000e+01, & - &1.533800e+00,4.594600e+00,7.595000e+00,9.914000e+00,1.225300e+01, & - &1.995100e+00,4.767900e+00,7.755900e+00,1.007400e+01,1.210100e+01, & - &2.534000e+00,4.928500e+00,7.883700e+00,1.017800e+01,1.192800e+01, & - &3.149000e+00,5.085600e+00,7.986200e+00,1.023000e+01,1.173100e+01, & - &1.047800e+00,4.587400e+00,7.732700e+00,1.019700e+01,1.277700e+01, & - &1.403400e+00,4.772400e+00,7.935200e+00,1.039900e+01,1.267600e+01, & - &1.829000e+00,4.944500e+00,8.094000e+00,1.056000e+01,1.254800e+01, & - &2.326200e+00,5.099500e+00,8.217500e+00,1.066200e+01,1.238500e+01, & - &2.899400e+00,5.250400e+00,8.316800e+00,1.070800e+01,1.218500e+01, & - &9.629500e-01,4.735700e+00,8.018600e+00,1.058200e+01,1.309100e+01, & - &1.291000e+00,4.921500e+00,8.224800e+00,1.081400e+01,1.302800e+01, & - &1.683800e+00,5.089800e+00,8.387100e+00,1.098400e+01,1.291800e+01, & - &2.146600e+00,5.240400e+00,8.511000e+00,1.108400e+01,1.276600e+01, & - &2.687200e+00,5.386100e+00,8.602700e+00,1.112800e+01,1.257200e+01, & - &8.921200e-01,4.860600e+00,8.256800e+00,1.092800e+01,1.335500e+01, & - &1.196000e+00,5.044600e+00,8.474400e+00,1.117800e+01,1.331600e+01, & - &1.563100e+00,5.206100e+00,8.640300e+00,1.135300e+01,1.322700e+01, & - &2.002000e+00,5.354700e+00,8.764200e+00,1.145100e+01,1.308400e+01, & - &2.520900e+00,5.491900e+00,8.846100e+00,1.149100e+01,1.289800e+01, & - &8.343900e-01,4.963000e+00,8.463800e+00,1.124000e+01,1.356900e+01, & - &1.120700e+00,5.145400e+00,8.687500e+00,1.150300e+01,1.355200e+01, & - &1.471700e+00,5.301300e+00,8.858000e+00,1.167300e+01,1.347800e+01, & - &1.893100e+00,5.446100e+00,8.979300e+00,1.177000e+01,1.334700e+01, & - &2.391700e+00,5.571000e+00,9.051400e+00,1.180600e+01,1.317100e+01, & - &7.895300e-01,5.047900e+00,8.648800e+00,1.152000e+01,1.375300e+01, & - &1.063200e+00,5.226400e+00,8.875300e+00,1.178300e+01,1.375500e+01, & - &1.400200e+00,5.376900e+00,9.046300e+00,1.195100e+01,1.369600e+01, & - &1.807800e+00,5.515300e+00,9.156100e+00,1.204900e+01,1.357700e+01, & - &2.291100e+00,5.629400e+00,9.224800e+00,1.207700e+01,1.340700e+01, & - &7.576300e-01,5.118200e+00,8.813500e+00,1.177500e+01,1.390900e+01, & - &1.021600e+00,5.291500e+00,9.042100e+00,1.202700e+01,1.393700e+01, & - &1.347800e+00,5.441300e+00,9.202800e+00,1.219700e+01,1.388600e+01, & - &1.744100e+00,5.569400e+00,9.305500e+00,1.228800e+01,1.377200e+01, & - &2.214400e+00,5.676000e+00,9.368000e+00,1.230300e+01,1.360600e+01, & - &7.346300e-01,5.177600e+00,8.965300e+00,1.199500e+01,1.406600e+01, & - &9.928700e-01,5.348800e+00,9.182300e+00,1.224800e+01,1.409300e+01, & - &1.312400e+00,5.493700e+00,9.336400e+00,1.241200e+01,1.404800e+01, & - &1.697900e+00,5.611600e+00,9.434800e+00,1.249000e+01,1.393800e+01, & - &2.156900e+00,5.718000e+00,9.491500e+00,1.249300e+01,1.376800e+01, & - &7.197700e-01,5.229800e+00,9.098200e+00,1.219600e+01,1.420100e+01, & - &9.735900e-01,5.396700e+00,9.305400e+00,1.244400e+01,1.423100e+01, & - &1.286300e+00,5.536100e+00,9.454200e+00,1.259200e+01,1.419200e+01, & - &1.663500e+00,5.647100e+00,9.543400e+00,1.265600e+01,1.408000e+01, & - &2.116900e+00,5.760600e+00,9.593900e+00,1.265000e+01,1.391200e+01, & - &7.035700e-01,5.271800e+00,9.205800e+00,1.236700e+01,1.431800e+01, & - &9.510000e-01,5.436400e+00,9.408600e+00,1.260300e+01,1.436000e+01, & - &1.257100e+00,5.568300e+00,9.552400e+00,1.274100e+01,1.432100e+01, & - &1.628200e+00,5.677200e+00,9.633100e+00,1.279400e+01,1.420500e+01, & - &2.075900e+00,5.797300e+00,9.680600e+00,1.278000e+01,1.405700e+01, & - &6.712700e-01,5.295400e+00,9.283400e+00,1.249600e+01,1.442900e+01, & - &9.085500e-01,5.458700e+00,9.486400e+00,1.272300e+01,1.448000e+01, & - &1.203300e+00,5.586400e+00,9.626700e+00,1.285800e+01,1.444000e+01, & - &1.564800e+00,5.697500e+00,9.704600e+00,1.290900e+01,1.433600e+01, & - &2.003900e+00,5.820700e+00,9.751200e+00,1.289000e+01,1.420800e+01, & - &6.219200e-01,5.297900e+00,9.327100e+00,1.257600e+01,1.452000e+01, & - &8.454600e-01,5.463700e+00,9.536700e+00,1.280900e+01,1.458300e+01, & - &1.125100e+00,5.590800e+00,9.679000e+00,1.294800e+01,1.455000e+01, & - &1.472500e+00,5.703800e+00,9.759700e+00,1.300400e+01,1.447100e+01, & - &1.898100e+00,5.830600e+00,9.807700e+00,1.298700e+01,1.435300e+01/ - data absb(601:900,12) / & - &5.508900e-01,5.273000e+00,9.324200e+00,1.259500e+01,1.457800e+01, & - &7.554600e-01,5.444600e+00,9.550300e+00,1.285100e+01,1.466300e+01, & - &1.013800e+00,5.577900e+00,9.705400e+00,1.300800e+01,1.464900e+01, & - &1.338800e+00,5.693700e+00,9.796800e+00,1.308000e+01,1.459900e+01, & - &1.740500e+00,5.819600e+00,9.848300e+00,1.307400e+01,1.449700e+01, & - &4.877400e-01,5.244600e+00,9.312100e+00,1.259800e+01,1.462400e+01, & - &6.759600e-01,5.423600e+00,9.553500e+00,1.287800e+01,1.472700e+01, & - &9.158000e-01,5.563500e+00,9.721000e+00,1.305300e+01,1.473800e+01, & - &1.219600e+00,5.681300e+00,9.823600e+00,1.313900e+01,1.472100e+01, & - &1.599500e+00,5.807300e+00,9.879400e+00,1.314700e+01,1.463700e+01, & - &4.331900e-01,5.217100e+00,9.292300e+00,1.259100e+01,1.465500e+01, & - &6.067400e-01,5.401300e+00,9.549100e+00,1.289200e+01,1.477900e+01, & - &8.307600e-01,5.549100e+00,9.728500e+00,1.308300e+01,1.482500e+01, & - &1.116200e+00,5.669300e+00,9.842000e+00,1.318300e+01,1.484800e+01, & - &1.476000e+00,5.793900e+00,9.906500e+00,1.320800e+01,1.478800e+01, & - &3.714600e-01,5.167600e+00,9.235000e+00,1.253300e+01,1.464500e+01, & - &5.284400e-01,5.360800e+00,9.512800e+00,1.286600e+01,1.480400e+01, & - &7.331300e-01,5.519100e+00,9.714800e+00,1.308600e+01,1.488100e+01, & - &9.952800e-01,5.641500e+00,9.844300e+00,1.321000e+01,1.493100e+01, & - &1.329100e+00,5.765700e+00,9.922000e+00,1.325500e+01,1.490200e+01, & - &3.169100e-01,5.112300e+00,9.165400e+00,1.245300e+01,1.461500e+01, & - &4.585400e-01,5.314100e+00,9.464500e+00,1.282000e+01,1.481300e+01, & - &6.449700e-01,5.483200e+00,9.689300e+00,1.307200e+01,1.492100e+01, & - &8.860000e-01,5.614900e+00,9.837600e+00,1.322200e+01,1.500000e+01, & - &1.194900e+00,5.738800e+00,9.926300e+00,1.328900e+01,1.500100e+01, & - &2.699000e-01,5.054500e+00,9.085100e+00,1.235700e+01,1.456800e+01, & - &3.979100e-01,5.266600e+00,9.405900e+00,1.276200e+01,1.481100e+01, & - &5.678600e-01,5.447300e+00,9.653500e+00,1.304200e+01,1.495100e+01, & - &7.898500e-01,5.588900e+00,9.820200e+00,1.322000e+01,1.506200e+01, & - &1.075900e+00,5.710300e+00,9.925600e+00,1.330800e+01,1.509500e+01, & - &2.240800e-01,4.980100e+00,8.975000e+00,1.222000e+01,1.448800e+01, & - &3.374200e-01,5.205000e+00,9.322100e+00,1.266600e+01,1.477900e+01, & - &4.901000e-01,5.396000e+00,9.594500e+00,1.298400e+01,1.495900e+01, & - &6.916900e-01,5.549300e+00,9.788900e+00,1.319700e+01,1.510400e+01, & - &9.530500e-01,5.674500e+00,9.913100e+00,1.331000e+01,1.517600e+01, & - &1.832300e-01,4.893300e+00,8.841000e+00,1.205100e+01,1.437700e+01, & - &2.821700e-01,5.133000e+00,9.221200e+00,1.254300e+01,1.472500e+01, & - &4.183800e-01,5.334700e+00,9.521900e+00,1.290600e+01,1.494900e+01, & - &5.998400e-01,5.504300e+00,9.745700e+00,1.315300e+01,1.513100e+01, & - &8.373000e-01,5.636100e+00,9.888100e+00,1.330200e+01,1.524800e+01, & - &1.490400e-01,4.801400e+00,8.694200e+00,1.185700e+01,1.424300e+01, & - &2.348600e-01,5.059000e+00,9.108700e+00,1.240400e+01,1.465200e+01, & - &3.557800e-01,5.272800e+00,9.436100e+00,1.281100e+01,1.492800e+01, & - &5.190700e-01,5.455100e+00,9.684900e+00,1.309500e+01,1.515500e+01, & - &7.344700e-01,5.597000e+00,9.855100e+00,1.327800e+01,1.531600e+01, & - &1.191000e-01,4.697300e+00,8.526400e+00,1.163500e+01,1.407400e+01, & - &1.926400e-01,4.971300e+00,8.975200e+00,1.223100e+01,1.455200e+01, & - &2.984000e-01,5.199400e+00,9.330200e+00,1.268700e+01,1.488600e+01, & - &4.442000e-01,5.393400e+00,9.610900e+00,1.301700e+01,1.515800e+01, & - &6.382100e-01,5.550100e+00,9.812800e+00,1.323600e+01,1.537100e+01, & - &9.220500e-02,4.572800e+00,8.322200e+00,1.135700e+01,1.384800e+01, & - &1.537600e-01,4.865800e+00,8.806500e+00,1.201400e+01,1.440500e+01, & - &2.442000e-01,5.113500e+00,9.202300e+00,1.252800e+01,1.480500e+01, & - &3.720200e-01,5.320600e+00,9.515000e+00,1.290700e+01,1.512100e+01, & - &5.444000e-01,5.494500e+00,9.745500e+00,1.316800e+01,1.538700e+01, & - &7.045400e-02,4.441200e+00,8.101100e+00,1.104800e+01,1.359000e+01, & - &1.214900e-01,4.754600e+00,8.625700e+00,1.177100e+01,1.423100e+01, & - &1.982600e-01,5.020500e+00,9.057700e+00,1.234500e+01,1.470500e+01, & - &3.091500e-01,5.241500e+00,9.399800e+00,1.277800e+01,1.507700e+01, & - &4.619900e-01,5.430800e+00,9.665200e+00,1.308300e+01,1.539700e+01/ - data absb(901:1175,12) / & - &5.308800e-02,4.300800e+00,7.858700e+00,1.071000e+01,1.330000e+01, & - &9.488600e-02,4.632500e+00,8.426000e+00,1.150300e+01,1.403500e+01, & - &1.596600e-01,4.917300e+00,8.895200e+00,1.213500e+01,1.459300e+01, & - &2.550500e-01,5.157300e+00,9.275500e+00,1.262400e+01,1.502800e+01, & - &3.894100e-01,5.358000e+00,9.574500e+00,1.298000e+01,1.540900e+01, & - &4.006700e-02,4.159600e+00,7.608900e+00,1.037200e+01,1.298800e+01, & - &7.425600e-02,4.512500e+00,8.226000e+00,1.122500e+01,1.381000e+01, & - &1.290100e-01,4.817400e+00,8.731000e+00,1.191500e+01,1.444400e+01, & - &2.111600e-01,5.074000e+00,9.145800e+00,1.246100e+01,1.493400e+01, & - &3.294500e-01,5.287900e+00,9.473800e+00,1.286600e+01,1.537100e+01, & - &3.008200e-02,4.016600e+00,7.347000e+00,1.002400e+01,1.264900e+01, & - &5.786400e-02,4.390400e+00,8.016600e+00,1.093000e+01,1.355500e+01, & - &1.038500e-01,4.710300e+00,8.559300e+00,1.168400e+01,1.426500e+01, & - &1.745100e-01,4.983800e+00,9.006300e+00,1.228000e+01,1.481200e+01, & - &2.782200e-01,5.213000e+00,9.362900e+00,1.273500e+01,1.529700e+01, & - &2.232100e-02,3.863300e+00,7.066900e+00,9.664500e+00,1.228600e+01, & - &4.456800e-02,4.258600e+00,7.788700e+00,1.061500e+01,1.327500e+01, & - &8.276400e-02,4.597600e+00,8.372200e+00,1.143000e+01,1.406700e+01, & - &1.433200e-01,4.889700e+00,8.853300e+00,1.208100e+01,1.468100e+01, & - &2.335900e-01,5.135000e+00,9.245300e+00,1.258900e+01,1.521400e+01, & - &1.632000e-02,3.701700e+00,6.767000e+00,9.285900e+00,1.189000e+01, & - &3.388300e-02,4.121000e+00,7.540800e+00,1.028100e+01,1.297200e+01, & - &6.521100e-02,4.480300e+00,8.173700e+00,1.115200e+01,1.384900e+01, & - &1.165600e-01,4.790100e+00,8.689500e+00,1.186100e+01,1.454000e+01, & - &1.945400e-01,5.051300e+00,9.113800e+00,1.242300e+01,1.513200e+01, & - &1.204400e-02,3.546000e+00,6.476900e+00,8.917500e+00,1.147800e+01, & - &2.600900e-02,3.987800e+00,7.295500e+00,9.957100e+00,1.262800e+01, & - &5.182100e-02,4.366600e+00,7.977900e+00,1.087600e+01,1.358300e+01, & - &9.547400e-02,4.690100e+00,8.527900e+00,1.164400e+01,1.433100e+01, & - &1.634600e-01,4.967900e+00,8.982900e+00,1.225100e+01,1.495300e+01, & - &8.847400e-03,3.387400e+00,6.184900e+00,8.546300e+00,1.105400e+01, & - &1.996400e-02,3.851400e+00,7.046700e+00,9.638700e+00,1.226800e+01, & - &4.115200e-02,4.249800e+00,7.774600e+00,1.059600e+01,1.327900e+01, & - &7.815900e-02,4.590500e+00,8.362300e+00,1.141700e+01,1.408400e+01, & - &1.375000e-01,4.884500e+00,8.846300e+00,1.207300e+01,1.472200e+01, & - &6.408200e-03,3.224400e+00,5.877400e+00,8.165200e+00,1.061000e+01, & - &1.516200e-02,3.710000e+00,6.783800e+00,9.306000e+00,1.189300e+01, & - &3.238800e-02,4.128900e+00,7.556100e+00,1.030100e+01,1.295200e+01, & - &6.347100e-02,4.487900e+00,8.188200e+00,1.117200e+01,1.382300e+01, & - &1.148700e-01,4.797100e+00,8.702800e+00,1.188000e+01,1.449600e+01, & - &4.563100e-03,3.051100e+00,5.558700e+00,7.775000e+00,1.013800e+01, & - &1.136800e-02,3.562200e+00,6.507300e+00,8.955500e+00,1.149900e+01, & - &2.525000e-02,4.002500e+00,7.323200e+00,9.993000e+00,1.261700e+01, & - &5.110500e-02,4.379400e+00,8.001500e+00,1.091000e+01,1.354400e+01, & - &9.517800e-02,4.702300e+00,8.549800e+00,1.167300e+01,1.427000e+01, & - &3.244200e-03,2.881700e+00,5.246900e+00,7.393800e+00,9.664700e+00, & - &8.519600e-03,3.413000e+00,6.233300e+00,8.605800e+00,1.110200e+01, & - &1.973700e-02,3.874000e+00,7.088800e+00,9.692200e+00,1.228700e+01, & - &4.125600e-02,4.269700e+00,7.810700e+00,1.064600e+01,1.325300e+01, & - &7.900500e-02,4.608100e+00,8.392300e+00,1.145900e+01,1.403200e+01, & - &2.755400e-03,2.811500e+00,5.120400e+00,7.238000e+00,9.457400e+00, & - &7.469500e-03,3.352000e+00,6.119100e+00,8.462900e+00,1.091900e+01, & - &1.770000e-02,3.820800e+00,6.991900e+00,9.568800e+00,1.213300e+01, & - &3.759000e-02,4.224600e+00,7.730600e+00,1.053700e+01,1.309200e+01, & - &7.297600e-02,4.569800e+00,8.328600e+00,1.137000e+01,1.386300e+01/ - data absb(1:300,13) / & - &2.652900e+00,2.283100e+00,3.242200e+00,4.442500e+00,5.753200e+00, & - &3.790100e+00,3.001200e+00,3.386800e+00,4.478000e+00,5.630400e+00, & - &5.140700e+00,3.989800e+00,3.703400e+00,4.528400e+00,5.509400e+00, & - &6.684900e+00,5.150500e+00,4.115200e+00,4.552500e+00,5.386300e+00, & - &8.410700e+00,6.441300e+00,4.693900e+00,4.596200e+00,5.259800e+00, & - &2.785900e+00,2.475400e+00,3.570700e+00,4.927400e+00,6.361700e+00, & - &3.981900e+00,3.161600e+00,3.743000e+00,4.946700e+00,6.224800e+00, & - &5.416900e+00,4.198400e+00,4.107600e+00,4.954700e+00,6.080500e+00, & - &7.066000e+00,5.430700e+00,4.523100e+00,4.963400e+00,5.926600e+00, & - &8.914400e+00,6.814000e+00,5.066300e+00,5.004400e+00,5.769000e+00, & - &2.985700e+00,2.721700e+00,3.931600e+00,5.460300e+00,7.039800e+00, & - &4.276400e+00,3.408900e+00,4.142400e+00,5.447600e+00,6.861200e+00, & - &5.821100e+00,4.500200e+00,4.514800e+00,5.420400e+00,6.679000e+00, & - &7.602200e+00,5.827500e+00,4.979000e+00,5.405100e+00,6.497200e+00, & - &9.607700e+00,7.324700e+00,5.564800e+00,5.479000e+00,6.317500e+00, & - &3.252000e+00,3.039800e+00,4.323400e+00,6.008000e+00,7.732200e+00, & - &4.645600e+00,3.762100e+00,4.583300e+00,5.969500e+00,7.529800e+00, & - &6.308600e+00,4.868500e+00,4.950600e+00,5.914300e+00,7.323300e+00, & - &8.226200e+00,6.282000e+00,5.488100e+00,5.895900e+00,7.122900e+00, & - &1.037100e+01,7.883800e+00,6.161700e+00,6.026100e+00,6.937100e+00, & - &3.510300e+00,3.402700e+00,4.757100e+00,6.594600e+00,8.501100e+00, & - &4.985500e+00,4.139600e+00,5.030000e+00,6.521900e+00,8.275200e+00, & - &6.739100e+00,5.221400e+00,5.441000e+00,6.450300e+00,8.054900e+00, & - &8.752700e+00,6.675000e+00,6.044000e+00,6.458900e+00,7.852100e+00, & - &1.097700e+01,8.333000e+00,6.761000e+00,6.607200e+00,7.662300e+00, & - &3.720100e+00,3.771500e+00,5.241000e+00,7.287700e+00,9.444700e+00, & - &5.247300e+00,4.516300e+00,5.513100e+00,7.174700e+00,9.196400e+00, & - &7.056700e+00,5.568100e+00,5.989000e+00,7.088000e+00,8.966300e+00, & - &9.107200e+00,6.958100e+00,6.627300e+00,7.137000e+00,8.754600e+00, & - &1.136700e+01,8.617400e+00,7.348800e+00,7.270400e+00,8.555600e+00, & - &3.856100e+00,4.129900e+00,5.808900e+00,8.119500e+00,1.056400e+01, & - &5.405200e+00,4.894800e+00,6.073900e+00,7.991800e+00,1.030900e+01, & - &7.215800e+00,5.880400e+00,6.589900e+00,7.907100e+00,1.006800e+01, & - &9.261100e+00,7.182200e+00,7.204700e+00,7.951000e+00,9.835200e+00, & - &1.152000e+01,8.758400e+00,7.909200e+00,8.044700e+00,9.602100e+00, & - &3.935200e+00,4.497400e+00,6.485000e+00,9.096800e+00,1.186200e+01, & - &5.465600e+00,5.256700e+00,6.770200e+00,8.955300e+00,1.159200e+01, & - &7.243200e+00,6.180600e+00,7.233900e+00,8.891200e+00,1.132900e+01, & - &9.255900e+00,7.373000e+00,7.805900e+00,8.910900e+00,1.105900e+01, & - &1.147800e+01,8.841400e+00,8.455700e+00,8.964000e+00,1.078500e+01, & - &3.915200e+00,4.866000e+00,7.267500e+00,1.017700e+01,1.327500e+01, & - &5.392500e+00,5.576900e+00,7.567300e+00,1.003200e+01,1.298800e+01, & - &7.117200e+00,6.458000e+00,7.949100e+00,9.986500e+00,1.269000e+01, & - &9.068300e+00,7.518000e+00,8.437000e+00,9.964700e+00,1.237900e+01, & - &1.123800e+01,8.863900e+00,9.012500e+00,9.989500e+00,1.206400e+01, & - &3.890900e+00,5.290000e+00,8.156600e+00,1.130800e+01,1.473200e+01, & - &5.318100e+00,5.920900e+00,8.440200e+00,1.117500e+01,1.441000e+01, & - &6.979500e+00,6.734800e+00,8.759900e+00,1.112200e+01,1.406700e+01, & - &8.868800e+00,7.723700e+00,9.151300e+00,1.107500e+01,1.370900e+01, & - &1.097000e+01,8.930200e+00,9.640800e+00,1.110500e+01,1.334300e+01, & - &3.799700e+00,5.729200e+00,9.091300e+00,1.243600e+01,1.618000e+01, & - &5.159500e+00,6.275300e+00,9.353500e+00,1.233100e+01,1.580900e+01, & - &6.749300e+00,6.992500e+00,9.613700e+00,1.226300e+01,1.542500e+01, & - &8.554200e+00,7.901200e+00,9.910400e+00,1.222000e+01,1.502500e+01, & - &1.056100e+01,8.978100e+00,1.030900e+01,1.225300e+01,1.461400e+01, & - &3.663100e+00,6.190500e+00,1.001100e+01,1.354400e+01,1.757300e+01, & - &4.953000e+00,6.652800e+00,1.026700e+01,1.345500e+01,1.716100e+01, & - &6.455400e+00,7.271500e+00,1.048100e+01,1.337700e+01,1.672600e+01, & - &8.160800e+00,8.060500e+00,1.070900e+01,1.336500e+01,1.628200e+01, & - &1.004800e+01,9.017100e+00,1.100600e+01,1.338200e+01,1.582700e+01/ - data absb(301:600,13) / & - &3.505700e+00,6.659100e+00,1.091200e+01,1.462500e+01,1.888300e+01, & - &4.715400e+00,7.044800e+00,1.115600e+01,1.454100e+01,1.842700e+01, & - &6.122400e+00,7.560200e+00,1.133500e+01,1.447200e+01,1.795400e+01, & - &7.715300e+00,8.224000e+00,1.150800e+01,1.448600e+01,1.746400e+01, & - &9.494100e+00,9.053400e+00,1.171700e+01,1.447300e+01,1.696000e+01, & - &3.337400e+00,7.123500e+00,1.178900e+01,1.566900e+01,2.008800e+01, & - &4.466100e+00,7.443900e+00,1.200700e+01,1.557500e+01,1.959700e+01, & - &5.776900e+00,7.859100e+00,1.214900e+01,1.554500e+01,1.908800e+01, & - &7.275600e+00,8.407800e+00,1.226900e+01,1.555500e+01,1.855500e+01, & - &8.963900e+00,9.110400e+00,1.240100e+01,1.550100e+01,1.800800e+01, & - &3.153300e+00,7.560800e+00,1.261100e+01,1.664200e+01,2.119100e+01, & - &4.199300e+00,7.822000e+00,1.279500e+01,1.657000e+01,2.067200e+01, & - &5.426500e+00,8.146900e+00,1.290000e+01,1.656700e+01,2.012500e+01, & - &6.837800e+00,8.591100e+00,1.296100e+01,1.654400e+01,1.955200e+01, & - &8.446000e+00,9.176100e+00,1.302800e+01,1.643700e+01,1.896500e+01, & - &2.961600e+00,7.955000e+00,1.336200e+01,1.753800e+01,2.218000e+01, & - &3.938300e+00,8.162500e+00,1.350100e+01,1.750200e+01,2.163700e+01, & - &5.089900e+00,8.413700e+00,1.357000e+01,1.750400e+01,2.105400e+01, & - &6.430900e+00,8.765800e+00,1.358200e+01,1.743500e+01,2.044300e+01, & - &7.968700e+00,9.261200e+00,1.358300e+01,1.727400e+01,1.980600e+01, & - &2.779800e+00,8.299600e+00,1.402900e+01,1.836900e+01,2.305600e+01, & - &3.696100e+00,8.461600e+00,1.412300e+01,1.835100e+01,2.249000e+01, & - &4.790000e+00,8.657100e+00,1.415300e+01,1.833900e+01,2.186900e+01, & - &6.080200e+00,8.931300e+00,1.411700e+01,1.821400e+01,2.121400e+01, & - &7.580100e+00,9.359000e+00,1.406500e+01,1.800300e+01,2.053100e+01, & - &2.609700e+00,8.590800e+00,1.460300e+01,1.912100e+01,2.381000e+01, & - &3.479800e+00,8.717700e+00,1.466200e+01,1.912300e+01,2.321000e+01, & - &4.535500e+00,8.868300e+00,1.464800e+01,1.905600e+01,2.254800e+01, & - &5.793900e+00,9.083900e+00,1.457300e+01,1.888100e+01,2.184800e+01, & - &7.276500e+00,9.461500e+00,1.447200e+01,1.862200e+01,2.112300e+01, & - &2.467500e+00,8.838700e+00,1.509700e+01,1.978600e+01,2.444200e+01, & - &3.306500e+00,8.933200e+00,1.512000e+01,1.978200e+01,2.380100e+01, & - &4.337000e+00,9.043800e+00,1.506700e+01,1.966200e+01,2.310300e+01, & - &5.580100e+00,9.226300e+00,1.495500e+01,1.943700e+01,2.236200e+01, & - &7.050900e+00,9.565300e+00,1.481000e+01,1.913000e+01,2.159700e+01, & - &2.357000e+00,9.047400e+00,1.551200e+01,2.037600e+01,2.494100e+01, & - &3.177800e+00,9.111500e+00,1.550800e+01,2.033500e+01,2.426800e+01, & - &4.193400e+00,9.190700e+00,1.541500e+01,2.016100e+01,2.353800e+01, & - &5.430100e+00,9.355700e+00,1.526200e+01,1.988900e+01,2.276700e+01, & - &6.907400e+00,9.674000e+00,1.508200e+01,1.954200e+01,2.197400e+01, & - &2.278900e+00,9.217900e+00,1.586100e+01,2.088400e+01,2.533800e+01, & - &3.089800e+00,9.253900e+00,1.582500e+01,2.078800e+01,2.463500e+01, & - &4.103200e+00,9.316300e+00,1.569200e+01,2.056900e+01,2.387300e+01, & - &5.348800e+00,9.470600e+00,1.550500e+01,2.025400e+01,2.307600e+01, & - &6.848800e+00,9.772100e+00,1.529900e+01,1.986400e+01,2.226800e+01, & - &2.203600e+00,9.353200e+00,1.615300e+01,2.130600e+01,2.567200e+01, & - &3.009600e+00,9.369900e+00,1.608300e+01,2.116800e+01,2.493700e+01, & - &4.027800e+00,9.420800e+00,1.591700e+01,2.090500e+01,2.414800e+01, & - &5.288100e+00,9.568000e+00,1.570600e+01,2.055300e+01,2.333900e+01, & - &6.812700e+00,9.851800e+00,1.547700e+01,2.012400e+01,2.249000e+01, & - &2.091100e+00,9.462800e+00,1.640100e+01,2.165600e+01,2.599200e+01, & - &2.883800e+00,9.462900e+00,1.630300e+01,2.149200e+01,2.523300e+01, & - &3.895900e+00,9.501100e+00,1.611700e+01,2.119800e+01,2.443900e+01, & - &5.156600e+00,9.635200e+00,1.588500e+01,2.081800e+01,2.360300e+01, & - &6.690700e+00,9.896200e+00,1.563300e+01,2.036400e+01,2.273100e+01, & - &1.933600e+00,9.552500e+00,1.661100e+01,2.195900e+01,2.632500e+01, & - &2.700200e+00,9.542800e+00,1.650100e+01,2.178200e+01,2.556300e+01, & - &3.688900e+00,9.562700e+00,1.630200e+01,2.147200e+01,2.476400e+01, & - &4.926800e+00,9.676300e+00,1.605300e+01,2.107400e+01,2.390300e+01, & - &6.444900e+00,9.902500e+00,1.578400e+01,2.060200e+01,2.303900e+01/ - data absb(601:900,13) / & - &1.710400e+00,9.624900e+00,1.679500e+01,2.222800e+01,2.670900e+01, & - &2.425200e+00,9.613500e+00,1.669000e+01,2.206100e+01,2.596000e+01, & - &3.360600e+00,9.610700e+00,1.649100e+01,2.175700e+01,2.516000e+01, & - &4.542000e+00,9.694400e+00,1.623800e+01,2.135600e+01,2.429100e+01, & - &6.003900e+00,9.873400e+00,1.595600e+01,2.087800e+01,2.343200e+01, & - &1.517800e+00,9.687200e+00,1.695300e+01,2.245900e+01,2.705000e+01, & - &2.183700e+00,9.677300e+00,1.685600e+01,2.230000e+01,2.632400e+01, & - &3.066100e+00,9.657600e+00,1.666000e+01,2.200700e+01,2.552700e+01, & - &4.193700e+00,9.712000e+00,1.640600e+01,2.160700e+01,2.465400e+01, & - &5.603900e+00,9.855900e+00,1.611400e+01,2.112500e+01,2.381400e+01, & - &1.355400e+00,9.739000e+00,1.708800e+01,2.265300e+01,2.736100e+01, & - &1.977500e+00,9.731300e+00,1.699800e+01,2.250600e+01,2.666000e+01, & - &2.810700e+00,9.701800e+00,1.680800e+01,2.222400e+01,2.586300e+01, & - &3.890000e+00,9.730500e+00,1.655200e+01,2.182700e+01,2.499500e+01, & - &5.249600e+00,9.847700e+00,1.625100e+01,2.134300e+01,2.418000e+01, & - &1.168100e+00,9.779100e+00,1.720100e+01,2.281800e+01,2.769500e+01, & - &1.729900e+00,9.782700e+00,1.713200e+01,2.270300e+01,2.702300e+01, & - &2.494600e+00,9.746700e+00,1.695500e+01,2.244800e+01,2.624000e+01, & - &3.501700e+00,9.748200e+00,1.670900e+01,2.206000e+01,2.537600e+01, & - &4.783600e+00,9.832900e+00,1.640500e+01,2.159100e+01,2.456100e+01, & - &1.003300e+00,9.810200e+00,1.728600e+01,2.294300e+01,2.800200e+01, & - &1.507900e+00,9.825700e+00,1.724300e+01,2.287200e+01,2.736200e+01, & - &2.206300e+00,9.791300e+00,1.708900e+01,2.264300e+01,2.660100e+01, & - &3.140100e+00,9.769800e+00,1.685100e+01,2.227800e+01,2.574200e+01, & - &4.344000e+00,9.824300e+00,1.656000e+01,2.182600e+01,2.492600e+01, & - &8.633500e-01,9.827300e+00,1.735600e+01,2.304400e+01,2.828300e+01, & - &1.315700e+00,9.856400e+00,1.733500e+01,2.300700e+01,2.767700e+01, & - &1.952200e+00,9.831300e+00,1.720400e+01,2.281400e+01,2.694000e+01, & - &2.814900e+00,9.792600e+00,1.698400e+01,2.248000e+01,2.608600e+01, & - &3.942700e+00,9.825100e+00,1.670400e+01,2.204000e+01,2.528000e+01, & - &7.250800e-01,9.833700e+00,1.739800e+01,2.310900e+01,2.855800e+01, & - &1.122000e+00,9.882900e+00,1.741400e+01,2.312300e+01,2.799900e+01, & - &1.689500e+00,9.868400e+00,1.731400e+01,2.297300e+01,2.729900e+01, & - &2.471600e+00,9.826400e+00,1.711500e+01,2.268100e+01,2.646400e+01, & - &3.509200e+00,9.825400e+00,1.684600e+01,2.225800e+01,2.565500e+01, & - &6.001300e-01,9.824200e+00,1.740700e+01,2.314700e+01,2.881000e+01, & - &9.453900e-01,9.897200e+00,1.746800e+01,2.320700e+01,2.830900e+01, & - &1.444700e+00,9.904100e+00,1.740900e+01,2.311400e+01,2.765800e+01, & - &2.145500e+00,9.862300e+00,1.723500e+01,2.286000e+01,2.684700e+01, & - &3.088400e+00,9.832400e+00,1.698200e+01,2.247000e+01,2.604100e+01, & - &4.946500e-01,9.799200e+00,1.738900e+01,2.316700e+01,2.903100e+01, & - &7.949900e-01,9.898100e+00,1.750900e+01,2.325700e+01,2.859800e+01, & - &1.232700e+00,9.922500e+00,1.747800e+01,2.321900e+01,2.799500e+01, & - &1.856700e+00,9.891500e+00,1.734100e+01,2.301800e+01,2.721400e+01, & - &2.710200e+00,9.849300e+00,1.711500e+01,2.267200e+01,2.642600e+01, & - &4.015500e-01,9.756500e+00,1.732700e+01,2.315000e+01,2.922300e+01, & - &6.588500e-01,9.889500e+00,1.751900e+01,2.328200e+01,2.886500e+01, & - &1.039300e+00,9.938900e+00,1.753800e+01,2.330400e+01,2.832100e+01, & - &1.588100e+00,9.924800e+00,1.743600e+01,2.315500e+01,2.758600e+01, & - &2.351800e+00,9.878700e+00,1.723200e+01,2.285600e+01,2.682000e+01, & - &3.171700e-01,9.692200e+00,1.720800e+01,2.309400e+01,2.937600e+01, & - &5.317600e-01,9.862600e+00,1.749600e+01,2.328100e+01,2.910600e+01, & - &8.564400e-01,9.941000e+00,1.757200e+01,2.335200e+01,2.863900e+01, & - &1.329100e+00,9.948200e+00,1.751700e+01,2.327200e+01,2.796600e+01, & - &1.999400e+00,9.906800e+00,1.734800e+01,2.302900e+01,2.722400e+01, & - &2.486200e-01,9.601700e+00,1.704700e+01,2.300300e+01,2.948300e+01, & - &4.261300e-01,9.814000e+00,1.743300e+01,2.325900e+01,2.931300e+01, & - &7.012900e-01,9.926700e+00,1.758600e+01,2.336700e+01,2.893000e+01, & - &1.107200e+00,9.960900e+00,1.757400e+01,2.335600e+01,2.833000e+01, & - &1.690900e+00,9.936100e+00,1.744900e+01,2.317700e+01,2.763400e+01/ - data absb(901:1175,13) / & - &1.926400e-01,9.493600e+00,1.683100e+01,2.288400e+01,2.953600e+01, & - &3.392700e-01,9.751600e+00,1.732500e+01,2.319800e+01,2.947900e+01, & - &5.699600e-01,9.905500e+00,1.756500e+01,2.335900e+01,2.919100e+01, & - &9.175800e-01,9.966400e+00,1.760900e+01,2.341100e+01,2.868400e+01, & - &1.422500e+00,9.963600e+00,1.753200e+01,2.329700e+01,2.806000e+01, & - &1.499100e-01,9.372000e+00,1.658500e+01,2.274600e+01,2.952600e+01, & - &2.720600e-01,9.677700e+00,1.718400e+01,2.311600e+01,2.958100e+01, & - &4.658700e-01,9.865300e+00,1.752000e+01,2.333900e+01,2.939400e+01, & - &7.652000e-01,9.955600e+00,1.762800e+01,2.342700e+01,2.897500e+01, & - &1.204000e+00,9.973200e+00,1.758500e+01,2.337700e+01,2.841000e+01, & - &1.161300e-01,9.227400e+00,1.631300e+01,2.259100e+01,2.945800e+01, & - &2.174700e-01,9.583700e+00,1.701500e+01,2.301500e+01,2.963400e+01, & - &3.808000e-01,9.812700e+00,1.743800e+01,2.329300e+01,2.954000e+01, & - &6.374000e-01,9.940300e+00,1.762100e+01,2.342200e+01,2.921500e+01, & - &1.019300e+00,9.982800e+00,1.762900e+01,2.343800e+01,2.871600e+01, & - &8.883000e-02,9.060300e+00,1.600200e+01,2.240900e+01,2.933000e+01, & - &1.722800e-01,9.477600e+00,1.679600e+01,2.288700e+01,2.964300e+01, & - &3.097400e-01,9.750200e+00,1.732200e+01,2.322300e+01,2.965900e+01, & - &5.276300e-01,9.911600e+00,1.758900e+01,2.340200e+01,2.943800e+01, & - &8.594900e-01,9.980000e+00,1.764800e+01,2.346500e+01,2.901900e+01, & - &6.688000e-02,8.864700e+00,1.567700e+01,2.219300e+01,2.915500e+01, & - &1.350800e-01,9.349400e+00,1.654500e+01,2.274200e+01,2.961800e+01, & - &2.501300e-01,9.667300e+00,1.717100e+01,2.312800e+01,2.975000e+01, & - &4.341900e-01,9.865600e+00,1.753100e+01,2.336800e+01,2.965000e+01, & - &7.205200e-01,9.964300e+00,1.765600e+01,2.346600e+01,2.933500e+01, & - &5.083900e-02,8.656000e+00,1.537300e+01,2.197400e+01,2.891800e+01, & - &1.067300e-01,9.209500e+00,1.628200e+01,2.258900e+01,2.952300e+01, & - &2.037400e-01,9.577300e+00,1.700000e+01,2.302400e+01,2.974300e+01, & - &3.611600e-01,9.813200e+00,1.744400e+01,2.331300e+01,2.973300e+01, & - &6.093800e-01,9.947800e+00,1.764100e+01,2.345200e+01,2.947900e+01, & - &3.859000e-02,8.438000e+00,1.507100e+01,2.173800e+01,2.862900e+01, & - &8.418700e-02,9.059400e+00,1.600200e+01,2.242000e+01,2.936900e+01, & - &1.660600e-01,9.481200e+00,1.680300e+01,2.290600e+01,2.969200e+01, & - &3.014300e-01,9.756200e+00,1.733300e+01,2.324500e+01,2.973700e+01, & - &5.163100e-01,9.919300e+00,1.760800e+01,2.342900e+01,2.953500e+01, & - &2.892500e-02,8.198100e+00,1.475600e+01,2.146800e+01,2.829200e+01, & - &6.566100e-02,8.886900e+00,1.571300e+01,2.222600e+01,2.916400e+01, & - &1.342600e-01,9.366400e+00,1.657800e+01,2.277200e+01,2.962600e+01, & - &2.502300e-01,9.682000e+00,1.719900e+01,2.315900e+01,2.972300e+01, & - &4.356800e-01,9.877600e+00,1.755300e+01,2.339500e+01,2.959200e+01, & - &2.137300e-02,7.937900e+00,1.443300e+01,2.114800e+01,2.790300e+01, & - &5.064500e-02,8.687900e+00,1.542000e+01,2.201500e+01,2.892800e+01, & - &1.074500e-01,9.233000e+00,1.632800e+01,2.262300e+01,2.951200e+01, & - &2.061000e-01,9.595500e+00,1.703800e+01,2.305700e+01,2.970400e+01, & - &3.659900e-01,9.827900e+00,1.747000e+01,2.334100e+01,2.963200e+01, & - &1.580000e-02,7.675600e+00,1.413000e+01,2.081100e+01,2.748800e+01, & - &3.915400e-02,8.482700e+00,1.513400e+01,2.179100e+01,2.866300e+01, & - &8.605800e-02,9.093600e+00,1.606400e+01,2.246500e+01,2.935800e+01, & - &1.702400e-01,9.504700e+00,1.685100e+01,2.294200e+01,2.966400e+01, & - &3.089900e-01,9.773400e+00,1.736700e+01,2.327500e+01,2.964000e+01, & - &1.383800e-02,7.567700e+00,1.400700e+01,2.066400e+01,2.730700e+01, & - &3.505600e-02,8.396600e+00,1.501700e+01,2.169600e+01,2.854200e+01, & - &7.836300e-02,9.032700e+00,1.595400e+01,2.239500e+01,2.925900e+01, & - &1.572000e-01,9.464900e+00,1.677200e+01,2.289600e+01,2.958700e+01, & - &2.881600e-01,9.749400e+00,1.732100e+01,2.324600e+01,2.956900e+01/ - data absb(1:300,14) / & - &4.678200e+00,3.650900e+00,4.206900e+00,5.596500e+00,7.316100e+00, & - &6.681200e+00,5.130200e+00,4.504200e+00,5.710700e+00,7.295600e+00, & - &9.080200e+00,6.919100e+00,5.085400e+00,5.838900e+00,7.225400e+00, & - &1.184700e+01,8.986000e+00,6.187900e+00,5.982700e+00,7.130800e+00, & - &1.494400e+01,1.130700e+01,7.680700e+00,6.108700e+00,7.009000e+00, & - &4.992300e+00,3.888800e+00,4.738100e+00,6.403700e+00,8.322400e+00, & - &7.143900e+00,5.463500e+00,4.995800e+00,6.512000e+00,8.250500e+00, & - &9.735700e+00,7.402600e+00,5.540200e+00,6.630600e+00,8.145000e+00, & - &1.270900e+01,9.630100e+00,6.672200e+00,6.734100e+00,8.010400e+00, & - &1.603500e+01,1.212000e+01,8.222600e+00,6.843600e+00,7.860000e+00, & - &5.406200e+00,4.210700e+00,5.332900e+00,7.280900e+00,9.409800e+00, & - &7.738300e+00,5.906800e+00,5.582600e+00,7.382500e+00,9.290600e+00, & - &1.051000e+01,7.979300e+00,6.163800e+00,7.487400e+00,9.131600e+00, & - &1.372500e+01,1.038500e+01,7.277500e+00,7.568200e+00,8.952900e+00, & - &1.733400e+01,1.309100e+01,8.911000e+00,7.656400e+00,8.760700e+00, & - &5.907000e+00,4.622700e+00,6.014000e+00,8.233300e+00,1.060000e+01, & - &8.429700e+00,6.420900e+00,6.288100e+00,8.309000e+00,1.041600e+01, & - &1.147600e+01,8.700000e+00,6.953900e+00,8.394400e+00,1.021000e+01, & - &1.498500e+01,1.133300e+01,8.089800e+00,8.454100e+00,9.988700e+00, & - &1.889300e+01,1.426300e+01,9.743300e+00,8.527200e+00,9.751600e+00, & - &6.528600e+00,5.132700e+00,6.770000e+00,9.267000e+00,1.188200e+01, & - &9.311400e+00,7.085300e+00,7.123600e+00,9.322700e+00,1.165000e+01, & - &1.263400e+01,9.570000e+00,7.870500e+00,9.368100e+00,1.140000e+01, & - &1.643700e+01,1.241900e+01,9.021000e+00,9.401300e+00,1.112400e+01, & - &2.069500e+01,1.561000e+01,1.071700e+01,9.503600e+00,1.083600e+01, & - &7.231700e+00,5.733100e+00,7.589500e+00,1.038800e+01,1.328300e+01, & - &1.027200e+01,7.812800e+00,8.048500e+00,1.040800e+01,1.298900e+01, & - &1.386500e+01,1.049000e+01,8.839900e+00,1.041100e+01,1.266800e+01, & - &1.800100e+01,1.359100e+01,1.004400e+01,1.041500e+01,1.233600e+01, & - &2.260700e+01,1.704300e+01,1.181800e+01,1.058400e+01,1.200000e+01, & - &7.981800e+00,6.424100e+00,8.474400e+00,1.159000e+01,1.480800e+01, & - &1.126500e+01,8.575100e+00,9.060800e+00,1.154600e+01,1.443600e+01, & - &1.515900e+01,1.145700e+01,9.899800e+00,1.149400e+01,1.404800e+01, & - &1.962300e+01,1.480300e+01,1.119300e+01,1.151500e+01,1.365900e+01, & - &2.455200e+01,1.849800e+01,1.302800e+01,1.176800e+01,1.328900e+01, & - &8.801600e+00,7.217900e+00,9.444500e+00,1.285900e+01,1.643200e+01, & - &1.235400e+01,9.459900e+00,1.010800e+01,1.276000e+01,1.598900e+01, & - &1.655300e+01,1.250100e+01,1.109400e+01,1.265900e+01,1.554500e+01, & - &2.132000e+01,1.607500e+01,1.247900e+01,1.271200e+01,1.512500e+01, & - &2.658400e+01,2.002300e+01,1.436400e+01,1.302800e+01,1.472200e+01, & - &9.653100e+00,8.096400e+00,1.050100e+01,1.423500e+01,1.823400e+01, & - &1.347700e+01,1.042700e+01,1.122300e+01,1.406900e+01,1.772000e+01, & - &1.794400e+01,1.355500e+01,1.237600e+01,1.394200e+01,1.722400e+01, & - &2.300600e+01,1.734000e+01,1.388600e+01,1.405300e+01,1.675500e+01, & - &2.857400e+01,2.151600e+01,1.581100e+01,1.441600e+01,1.630200e+01, & - &1.076000e+01,9.188800e+00,1.169500e+01,1.574500e+01,2.020500e+01, & - &1.485300e+01,1.164000e+01,1.251700e+01,1.551500e+01,1.961700e+01, & - &1.961500e+01,1.488400e+01,1.382200e+01,1.539700e+01,1.906400e+01, & - &2.496800e+01,1.881000e+01,1.548400e+01,1.556100e+01,1.854000e+01, & - &3.082700e+01,2.320600e+01,1.745600e+01,1.592100e+01,1.803300e+01, & - &1.180200e+01,1.032200e+01,1.299800e+01,1.742100e+01,2.240100e+01, & - &1.613300e+01,1.285000e+01,1.392100e+01,1.712300e+01,2.173700e+01, & - &2.112500e+01,1.616500e+01,1.533900e+01,1.703100e+01,2.110000e+01, & - &2.672600e+01,2.015700e+01,1.710100e+01,1.720900e+01,2.048400e+01, & - &3.282700e+01,2.471200e+01,1.908100e+01,1.751900e+01,1.988400e+01, & - &1.274500e+01,1.144200e+01,1.444500e+01,1.924400e+01,2.480900e+01, & - &1.725300e+01,1.401600e+01,1.544100e+01,1.890100e+01,2.404500e+01, & - &2.244900e+01,1.736500e+01,1.691200e+01,1.881600e+01,2.329500e+01, & - &2.823300e+01,2.139500e+01,1.867200e+01,1.893400e+01,2.255800e+01, & - &3.456000e+01,2.602100e+01,2.065800e+01,1.920200e+01,2.183600e+01/ - data absb(301:600,14) / & - &1.356600e+01,1.254300e+01,1.599600e+01,2.117700e+01,2.733600e+01, & - &1.822700e+01,1.513500e+01,1.703500e+01,2.078300e+01,2.644100e+01, & - &2.356500e+01,1.848300e+01,1.848800e+01,2.067500e+01,2.554900e+01, & - &2.953100e+01,2.253500e+01,2.020400e+01,2.068800e+01,2.466700e+01, & - &3.606300e+01,2.720600e+01,2.216200e+01,2.090800e+01,2.380500e+01, & - &1.432700e+01,1.363100e+01,1.759500e+01,2.311800e+01,2.985900e+01, & - &1.910800e+01,1.621000e+01,1.866300e+01,2.270600e+01,2.880300e+01, & - &2.458900e+01,1.956700e+01,2.004800e+01,2.249400e+01,2.774600e+01, & - &3.071000e+01,2.363100e+01,2.169300e+01,2.240700e+01,2.670500e+01, & - &3.741100e+01,2.832600e+01,2.361300e+01,2.258200e+01,2.568700e+01, & - &1.497400e+01,1.466100e+01,1.920800e+01,2.501700e+01,3.228200e+01, & - &1.986400e+01,1.720900e+01,2.023100e+01,2.456600e+01,3.103700e+01, & - &2.546300e+01,2.056300e+01,2.152800e+01,2.421300e+01,2.980500e+01, & - &3.173200e+01,2.463500e+01,2.311300e+01,2.405400e+01,2.859700e+01, & - &3.859500e+01,2.936800e+01,2.498400e+01,2.418800e+01,2.741500e+01, & - &1.552900e+01,1.562300e+01,2.076300e+01,2.682100e+01,3.449900e+01, & - &2.051600e+01,1.814300e+01,2.172000e+01,2.628300e+01,3.305700e+01, & - &2.623700e+01,2.149500e+01,2.292100e+01,2.581100e+01,3.164500e+01, & - &3.264700e+01,2.558600e+01,2.443800e+01,2.559200e+01,3.027400e+01, & - &3.966200e+01,3.033900e+01,2.626300e+01,2.567800e+01,2.894200e+01, & - &1.606500e+01,1.654400e+01,2.221600e+01,2.847200e+01,3.645800e+01, & - &2.115300e+01,1.904100e+01,2.310400e+01,2.781700e+01,3.482700e+01, & - &2.700000e+01,2.239400e+01,2.422100e+01,2.726700e+01,3.324000e+01, & - &3.354800e+01,2.651900e+01,2.567900e+01,2.700100e+01,3.170200e+01, & - &4.073800e+01,3.132300e+01,2.745700e+01,2.703100e+01,3.022600e+01, & - &1.658300e+01,1.740600e+01,2.354400e+01,2.994700e+01,3.814600e+01, & - &2.179200e+01,1.989900e+01,2.435300e+01,2.915600e+01,3.633000e+01, & - &2.777500e+01,2.326900e+01,2.540500e+01,2.856000e+01,3.457700e+01, & - &3.446800e+01,2.744200e+01,2.681600e+01,2.825500e+01,3.290100e+01, & - &4.184700e+01,3.232600e+01,2.856500e+01,2.823500e+01,3.129400e+01, & - &1.714100e+01,1.821600e+01,2.473200e+01,3.119800e+01,3.953100e+01, & - &2.249100e+01,2.074300e+01,2.547400e+01,3.031800e+01,3.755300e+01, & - &2.862400e+01,2.415800e+01,2.648500e+01,2.969000e+01,3.565600e+01, & - &3.551200e+01,2.841400e+01,2.785400e+01,2.935700e+01,3.385500e+01, & - &4.311500e+01,3.340100e+01,2.961100e+01,2.929000e+01,3.213200e+01, & - &1.777500e+01,1.899100e+01,2.578000e+01,3.223100e+01,4.062900e+01, & - &2.327900e+01,2.157600e+01,2.646700e+01,3.129300e+01,3.851300e+01, & - &2.959600e+01,2.507800e+01,2.745300e+01,3.065100e+01,3.649200e+01, & - &3.670500e+01,2.943300e+01,2.881900e+01,3.029800e+01,3.457500e+01, & - &4.453600e+01,3.453400e+01,3.058400e+01,3.017400e+01,3.275600e+01, & - &1.848900e+01,1.973300e+01,2.668400e+01,3.304700e+01,4.144500e+01, & - &2.418900e+01,2.242400e+01,2.734600e+01,3.209900e+01,3.920900e+01, & - &3.072300e+01,2.603400e+01,2.832000e+01,3.145100e+01,3.709200e+01, & - &3.806300e+01,3.051300e+01,2.970400e+01,3.107000e+01,3.508500e+01, & - &4.611900e+01,3.575100e+01,3.149900e+01,3.091700e+01,3.319100e+01, & - &1.912000e+01,2.038000e+01,2.745100e+01,3.373800e+01,4.209200e+01, & - &2.500300e+01,2.316200e+01,2.808600e+01,3.277400e+01,3.975900e+01, & - &3.174400e+01,2.688300e+01,2.906100e+01,3.212000e+01,3.755900e+01, & - &3.930100e+01,3.148300e+01,3.046400e+01,3.171000e+01,3.548000e+01, & - &4.756200e+01,3.685600e+01,3.229200e+01,3.153600e+01,3.356800e+01, & - &1.933000e+01,2.079400e+01,2.805300e+01,3.439000e+01,4.276300e+01, & - &2.531900e+01,2.359500e+01,2.865600e+01,3.339700e+01,4.034200e+01, & - &3.219100e+01,2.735800e+01,2.960800e+01,3.271700e+01,3.806200e+01, & - &3.988600e+01,3.201100e+01,3.100300e+01,3.226300e+01,3.593800e+01, & - &4.829400e+01,3.746700e+01,3.284000e+01,3.205100e+01,3.400800e+01, & - &1.901000e+01,2.094100e+01,2.851900e+01,3.504400e+01,4.354800e+01, & - &2.501900e+01,2.367400e+01,2.907000e+01,3.399600e+01,4.103800e+01, & - &3.192700e+01,2.739500e+01,2.996800e+01,3.326500e+01,3.867900e+01, & - &3.967200e+01,3.201500e+01,3.132200e+01,3.275800e+01,3.652500e+01, & - &4.815100e+01,3.748100e+01,3.311500e+01,3.249400e+01,3.453000e+01/ - data absb(601:900,14) / & - &1.792600e+01,2.076900e+01,2.887100e+01,3.579300e+01,4.461200e+01, & - &2.380900e+01,2.328500e+01,2.932500e+01,3.464000e+01,4.199700e+01, & - &3.062000e+01,2.682500e+01,3.011800e+01,3.382300e+01,3.955800e+01, & - &3.829600e+01,3.128800e+01,3.136600e+01,3.323500e+01,3.733700e+01, & - &4.672400e+01,3.663400e+01,3.304400e+01,3.289400e+01,3.525900e+01, & - &1.687800e+01,2.061000e+01,2.917200e+01,3.647200e+01,4.560900e+01, & - &2.262300e+01,2.290700e+01,2.953600e+01,3.522700e+01,4.290400e+01, & - &2.932100e+01,2.626000e+01,3.023400e+01,3.432700e+01,4.039500e+01, & - &3.690300e+01,3.055900e+01,3.137500e+01,3.366400e+01,3.810800e+01, & - &4.526200e+01,3.576600e+01,3.295000e+01,3.325500e+01,3.595100e+01, & - &1.590200e+01,2.047400e+01,2.944000e+01,3.708500e+01,4.652100e+01, & - &2.151100e+01,2.257000e+01,2.971900e+01,3.575700e+01,4.373900e+01, & - &2.809400e+01,2.573400e+01,3.032800e+01,3.477800e+01,4.118200e+01, & - &3.557800e+01,2.987700e+01,3.137400e+01,3.405000e+01,3.882000e+01, & - &4.386200e+01,3.494300e+01,3.286200e+01,3.357200e+01,3.660700e+01, & - &1.448700e+01,2.021000e+01,2.967800e+01,3.781400e+01,4.766700e+01, & - &1.985700e+01,2.201300e+01,2.984600e+01,3.637400e+01,4.479800e+01, & - &2.621700e+01,2.488700e+01,3.034200e+01,3.527500e+01,4.215200e+01, & - &3.350800e+01,2.877800e+01,3.123900e+01,3.447700e+01,3.971800e+01, & - &4.162700e+01,3.360100e+01,3.260900e+01,3.390400e+01,3.743500e+01, & - &1.311000e+01,1.995800e+01,2.991200e+01,3.854900e+01,4.880900e+01, & - &1.822100e+01,2.150700e+01,2.996200e+01,3.698800e+01,4.585600e+01, & - &2.433400e+01,2.407000e+01,3.035600e+01,3.576900e+01,4.312600e+01, & - &3.141500e+01,2.769200e+01,3.110000e+01,3.489400e+01,4.062700e+01, & - &3.935000e+01,3.226500e+01,3.234400e+01,3.422000e+01,3.826900e+01, & - &1.183500e+01,1.975200e+01,3.014500e+01,3.925100e+01,4.991000e+01, & - &1.667400e+01,2.108300e+01,3.008000e+01,3.758700e+01,4.688500e+01, & - &2.254000e+01,2.333600e+01,3.036700e+01,3.625600e+01,4.408400e+01, & - &2.938000e+01,2.666800e+01,3.098000e+01,3.528700e+01,4.152300e+01, & - &3.713000e+01,3.099000e+01,3.207800e+01,3.453300e+01,3.909600e+01, & - &1.042400e+01,1.951700e+01,3.039000e+01,4.002800e+01,5.116500e+01, & - &1.494000e+01,2.065100e+01,3.020700e+01,3.826800e+01,4.805900e+01, & - &2.048500e+01,2.254100e+01,3.036300e+01,3.681800e+01,4.517600e+01, & - &2.703400e+01,2.552100e+01,3.085300e+01,3.571500e+01,4.254900e+01, & - &3.452100e+01,2.952900e+01,3.177000e+01,3.489400e+01,4.005100e+01, & - &9.045400e+00,1.930300e+01,3.065400e+01,4.082900e+01,5.248600e+01, & - &1.321000e+01,2.025800e+01,3.036400e+01,3.901800e+01,4.930300e+01, & - &1.841000e+01,2.181100e+01,3.037700e+01,3.742700e+01,4.633800e+01, & - &2.462500e+01,2.440300e+01,3.075100e+01,3.618700e+01,4.364400e+01, & - &3.181000e+01,2.806900e+01,3.148600e+01,3.528700e+01,4.107900e+01, & - &7.799100e+00,1.912400e+01,3.091200e+01,4.162600e+01,5.379300e+01, & - &1.162000e+01,1.993000e+01,3.053500e+01,3.977200e+01,5.054200e+01, & - &1.646200e+01,2.122000e+01,3.042400e+01,3.805300e+01,4.750700e+01, & - &2.234000e+01,2.342400e+01,3.066900e+01,3.667900e+01,4.475300e+01, & - &2.920600e+01,2.671700e+01,3.124300e+01,3.567100e+01,4.211800e+01, & - &6.611400e+00,1.897500e+01,3.119200e+01,4.250500e+01,5.517700e+01, & - &1.007800e+01,1.963600e+01,3.074200e+01,4.055700e+01,5.185400e+01, & - &1.454100e+01,2.071700e+01,3.051000e+01,3.874500e+01,4.874800e+01, & - &2.005000e+01,2.251800e+01,3.061000e+01,3.723600e+01,4.593200e+01, & - &2.657000e+01,2.541300e+01,3.105600e+01,3.608500e+01,4.322200e+01, & - &5.442600e+00,1.884300e+01,3.146800e+01,4.350400e+01,5.670800e+01, & - &8.524300e+00,1.936000e+01,3.098900e+01,4.140800e+01,5.331400e+01, & - &1.257500e+01,2.024500e+01,3.063800e+01,3.955500e+01,5.011900e+01, & - &1.766100e+01,2.168300e+01,3.058000e+01,3.789400e+01,4.723800e+01, & - &2.377900e+01,2.412700e+01,3.089700e+01,3.658500e+01,4.445000e+01, & - &4.427700e+00,1.876100e+01,3.176800e+01,4.455500e+01,5.823900e+01, & - &7.141200e+00,1.915100e+01,3.124400e+01,4.229900e+01,5.478300e+01, & - &1.078900e+01,1.986900e+01,3.080700e+01,4.037900e+01,5.152200e+01, & - &1.545100e+01,2.103800e+01,3.061600e+01,3.858300e+01,4.857200e+01, & - &2.116000e+01,2.302200e+01,3.076800e+01,3.712600e+01,4.570300e+01/ - data absb(901:1175,14) / & - &3.558200e+00,1.872400e+01,3.211000e+01,4.563000e+01,5.977700e+01, & - &5.917600e+00,1.898100e+01,3.151200e+01,4.324600e+01,5.627900e+01, & - &9.176500e+00,1.955500e+01,3.102300e+01,4.120500e+01,5.296800e+01, & - &1.341900e+01,2.051700e+01,3.070600e+01,3.934100e+01,4.995100e+01, & - &1.870900e+01,2.209900e+01,3.070600e+01,3.773200e+01,4.700100e+01, & - &2.862100e+00,1.872200e+01,3.247600e+01,4.665300e+01,6.121000e+01, & - &4.908800e+00,1.887500e+01,3.175400e+01,4.417500e+01,5.768300e+01, & - &7.813500e+00,1.932000e+01,3.123700e+01,4.198700e+01,5.431400e+01, & - &1.167600e+01,2.011700e+01,3.083000e+01,4.008800e+01,5.123200e+01, & - &1.656700e+01,2.141000e+01,3.069600e+01,3.834300e+01,4.821200e+01, & - &2.287100e+00,1.870900e+01,3.286000e+01,4.762500e+01,6.258900e+01, & - &4.054200e+00,1.881100e+01,3.201500e+01,4.512100e+01,5.905800e+01, & - &6.629000e+00,1.914600e+01,3.146700e+01,4.279800e+01,5.563400e+01, & - &1.013100e+01,1.979600e+01,3.098800e+01,4.082300e+01,5.246900e+01, & - &1.463600e+01,2.087800e+01,3.073900e+01,3.897900e+01,4.940500e+01, & - &1.804200e+00,1.868200e+01,3.324600e+01,4.856000e+01,6.393800e+01, & - &3.314100e+00,1.878900e+01,3.232600e+01,4.608100e+01,6.043200e+01, & - &5.574900e+00,1.900100e+01,3.168200e+01,4.364600e+01,5.697400e+01, & - &8.725700e+00,1.952500e+01,3.118100e+01,4.155000e+01,5.373200e+01, & - &1.285600e+01,2.042900e+01,3.082100e+01,3.966600e+01,5.062700e+01, & - &1.401600e+00,1.862100e+01,3.367800e+01,4.949000e+01,6.527900e+01, & - &2.676200e+00,1.877600e+01,3.267100e+01,4.704700e+01,6.180400e+01, & - &4.641200e+00,1.890300e+01,3.191200e+01,4.454500e+01,5.834900e+01, & - &7.451200e+00,1.931100e+01,3.137800e+01,4.230700e+01,5.503600e+01, & - &1.121700e+01,2.006100e+01,3.094000e+01,4.038000e+01,5.188400e+01, & - &1.096100e+00,1.854700e+01,3.411200e+01,5.033200e+01,6.649000e+01, & - &2.175500e+00,1.875700e+01,3.301500e+01,4.791800e+01,6.301800e+01, & - &3.889000e+00,1.884500e+01,3.214900e+01,4.539800e+01,5.955000e+01, & - &6.400800e+00,1.915300e+01,3.158200e+01,4.304600e+01,5.615800e+01, & - &9.838900e+00,1.977300e+01,3.108600e+01,4.104300e+01,5.299100e+01, & - &8.539800e-01,1.849200e+01,3.454500e+01,5.111100e+01,6.762000e+01, & - &1.764300e+00,1.872400e+01,3.334600e+01,4.872300e+01,6.416000e+01, & - &3.255100e+00,1.882700e+01,3.241500e+01,4.623300e+01,6.066500e+01, & - &5.493300e+00,1.902800e+01,3.176100e+01,4.378400e+01,5.721600e+01, & - &8.619800e+00,1.953800e+01,3.125100e+01,4.167300e+01,5.397600e+01, & - &6.558300e-01,1.846600e+01,3.500900e+01,5.185200e+01,6.871300e+01, & - &1.414900e+00,1.866400e+01,3.371400e+01,4.952400e+01,6.531600e+01, & - &2.700100e+00,1.881300e+01,3.270800e+01,4.706900e+01,6.179100e+01, & - &4.679900e+00,1.893800e+01,3.195400e+01,4.456200e+01,5.829200e+01, & - &7.509200e+00,1.934900e+01,3.141700e+01,4.232600e+01,5.494900e+01, & - &4.956900e-01,1.846100e+01,3.547600e+01,5.258600e+01,6.977100e+01, & - &1.120700e+00,1.858800e+01,3.412000e+01,5.032000e+01,6.646200e+01, & - &2.218500e+00,1.878900e+01,3.302600e+01,4.789000e+01,6.294400e+01, & - &3.956100e+00,1.887800e+01,3.216900e+01,4.536800e+01,5.940400e+01, & - &6.500100e+00,1.919400e+01,3.160500e+01,4.302000e+01,5.595500e+01, & - &3.741000e-01,1.847600e+01,3.587800e+01,5.323300e+01,7.072700e+01, & - &8.872200e-01,1.852700e+01,3.451500e+01,5.104800e+01,6.751600e+01, & - &1.823200e+00,1.875700e+01,3.333200e+01,4.865000e+01,6.404300e+01, & - &3.348500e+00,1.885300e+01,3.241000e+01,4.614500e+01,6.047400e+01, & - &5.630800e+00,1.906600e+01,3.177000e+01,4.370700e+01,5.695200e+01, & - &3.322600e-01,1.849900e+01,3.604200e+01,5.348700e+01,7.110800e+01, & - &8.046500e-01,1.851200e+01,3.469200e+01,5.134000e+01,6.794600e+01, & - &1.679600e+00,1.874200e+01,3.346500e+01,4.895400e+01,6.448500e+01, & - &3.124400e+00,1.885100e+01,3.251800e+01,4.646800e+01,6.092400e+01, & - &5.304700e+00,1.902900e+01,3.183900e+01,4.399700e+01,5.733500e+01/ - data absb(1:300,15) / & - &1.473600e+01,1.113700e+01,7.694000e+00,7.107200e+00,9.079400e+00, & - &2.075300e+01,1.565900e+01,1.057200e+01,7.421900e+00,8.941600e+00, & - &2.781000e+01,2.095600e+01,1.410500e+01,8.236500e+00,8.864000e+00, & - &3.575100e+01,2.691100e+01,1.807500e+01,9.616700e+00,8.785200e+00, & - &4.439200e+01,3.339100e+01,2.239100e+01,1.151500e+01,8.675000e+00, & - &1.639600e+01,1.239800e+01,8.653100e+00,8.090100e+00,1.033800e+01, & - &2.302100e+01,1.736800e+01,1.172300e+01,8.455700e+00,1.022500e+01, & - &3.072500e+01,2.314500e+01,1.556800e+01,9.379400e+00,1.016400e+01, & - &3.940500e+01,2.964600e+01,1.989000e+01,1.085700e+01,1.007600e+01, & - &4.888700e+01,3.675300e+01,2.462100e+01,1.281000e+01,9.961900e+00, & - &1.810800e+01,1.368500e+01,9.729600e+00,9.286400e+00,1.189100e+01, & - &2.529200e+01,1.906500e+01,1.292500e+01,9.732000e+00,1.182200e+01, & - &3.365700e+01,2.533300e+01,1.701200e+01,1.068100e+01,1.176500e+01, & - &4.300900e+01,3.234200e+01,2.167700e+01,1.219500e+01,1.164800e+01, & - &5.311900e+01,3.992000e+01,2.672200e+01,1.417400e+01,1.151200e+01, & - &1.976600e+01,1.491800e+01,1.084700e+01,1.076300e+01,1.381400e+01, & - &2.746800e+01,2.068800e+01,1.411400e+01,1.125900e+01,1.375700e+01, & - &3.634100e+01,2.733800e+01,1.837000e+01,1.220000e+01,1.364700e+01, & - &4.626800e+01,3.477500e+01,2.328500e+01,1.371200e+01,1.349300e+01, & - &5.709800e+01,4.289300e+01,2.868800e+01,1.567400e+01,1.333600e+01, & - &2.128300e+01,1.604200e+01,1.203700e+01,1.252100e+01,1.610300e+01, & - &2.946400e+01,2.217200e+01,1.529900e+01,1.302900e+01,1.599400e+01, & - &3.894800e+01,2.927500e+01,1.966900e+01,1.396300e+01,1.582000e+01, & - &4.962100e+01,3.727500e+01,2.493600e+01,1.543800e+01,1.563800e+01, & - &6.125800e+01,4.599900e+01,3.074200e+01,1.736000e+01,1.544900e+01, & - &2.287700e+01,1.723100e+01,1.337500e+01,1.455400e+01,1.863900e+01, & - &3.163900e+01,2.379800e+01,1.660900e+01,1.506700e+01,1.846400e+01, & - &4.185800e+01,3.145700e+01,2.114100e+01,1.598100e+01,1.829300e+01, & - &5.334200e+01,4.006700e+01,2.679500e+01,1.739900e+01,1.808400e+01, & - &6.588400e+01,4.947100e+01,3.306000e+01,1.925800e+01,1.784800e+01, & - &2.462300e+01,1.853100e+01,1.490700e+01,1.683800e+01,2.146200e+01, & - &3.407000e+01,2.561400e+01,1.808400e+01,1.736900e+01,2.126100e+01, & - &4.507900e+01,3.386800e+01,2.278400e+01,1.826200e+01,2.104600e+01, & - &5.737100e+01,4.308600e+01,2.880400e+01,1.959700e+01,2.078800e+01, & - &7.079400e+01,5.315200e+01,3.551100e+01,2.132000e+01,2.047200e+01, & - &2.674000e+01,2.011300e+01,1.668700e+01,1.946300e+01,2.469200e+01, & - &3.689600e+01,2.772900e+01,1.986900e+01,1.996500e+01,2.441700e+01, & - &4.862700e+01,3.652700e+01,2.468600e+01,2.074900e+01,2.410900e+01, & - &6.180000e+01,4.640600e+01,3.101300e+01,2.198000e+01,2.374900e+01, & - &7.619300e+01,5.720000e+01,3.820700e+01,2.358200e+01,2.333500e+01, & - &2.897700e+01,2.178600e+01,1.858800e+01,2.242300e+01,2.831600e+01, & - &3.980100e+01,2.990400e+01,2.184200e+01,2.282900e+01,2.790500e+01, & - &5.236700e+01,3.932800e+01,2.680400e+01,2.345100e+01,2.746700e+01, & - &6.646900e+01,4.990500e+01,3.334500e+01,2.452200e+01,2.696900e+01, & - &8.184800e+01,6.144000e+01,4.103300e+01,2.602300e+01,2.643500e+01, & - &3.198800e+01,2.404100e+01,2.081200e+01,2.565100e+01,3.225500e+01, & - &4.372100e+01,3.284100e+01,2.433400e+01,2.595000e+01,3.168700e+01, & - &5.729400e+01,4.302200e+01,2.956100e+01,2.643200e+01,3.104000e+01, & - &7.247400e+01,5.440900e+01,3.641000e+01,2.733300e+01,3.033800e+01, & - &8.894200e+01,6.676100e+01,4.458300e+01,2.883400e+01,2.961500e+01, & - &3.551600e+01,2.669000e+01,2.333400e+01,2.903600e+01,3.635300e+01, & - &4.828100e+01,3.626400e+01,2.712700e+01,2.924100e+01,3.553900e+01, & - &6.290200e+01,4.723000e+01,3.263300e+01,2.956400e+01,3.466800e+01, & - &7.910800e+01,5.938500e+01,3.979300e+01,3.028000e+01,3.377200e+01, & - &9.670100e+01,7.258000e+01,4.846100e+01,3.182500e+01,3.285900e+01, & - &3.968000e+01,2.982900e+01,2.616000e+01,3.254800e+01,4.046900e+01, & - &5.346800e+01,4.016900e+01,3.014600e+01,3.262900e+01,3.941100e+01, & - &6.915900e+01,5.193200e+01,3.595700e+01,3.275300e+01,3.832500e+01, & - &8.655200e+01,6.496900e+01,4.359100e+01,3.341000e+01,3.721300e+01, & - &1.053200e+02,7.904100e+01,5.278300e+01,3.498900e+01,3.608700e+01/ - data absb(301:600,15) / & - &4.443200e+01,3.340100e+01,2.919400e+01,3.605100e+01,4.462200e+01, & - &5.933000e+01,4.457800e+01,3.343300e+01,3.601700e+01,4.326800e+01, & - &7.626200e+01,5.727300e+01,3.967800e+01,3.598600e+01,4.191400e+01, & - &9.490700e+01,7.125400e+01,4.786100e+01,3.666800e+01,4.056300e+01, & - &1.149000e+02,8.624000e+01,5.760200e+01,3.832000e+01,3.922400e+01, & - &4.994500e+01,3.754200e+01,3.248500e+01,3.952600e+01,4.868500e+01, & - &6.613200e+01,4.968500e+01,3.706700e+01,3.929400e+01,4.702900e+01, & - &8.435800e+01,6.335300e+01,4.387800e+01,3.929300e+01,4.538400e+01, & - &1.041900e+02,7.822400e+01,5.259800e+01,4.003400e+01,4.376900e+01, & - &1.252900e+02,9.404400e+01,6.281300e+01,4.170300e+01,4.220700e+01, & - &5.607000e+01,4.214100e+01,3.590800e+01,4.293000e+01,5.261300e+01, & - &7.348800e+01,5.520600e+01,4.096000e+01,4.246700e+01,5.062700e+01, & - &9.290200e+01,6.976600e+01,4.829500e+01,4.256100e+01,4.868500e+01, & - &1.138900e+02,8.550900e+01,5.751900e+01,4.334500e+01,4.680300e+01, & - &1.360900e+02,1.021500e+02,6.823000e+01,4.500500e+01,4.499800e+01, & - &6.260200e+01,4.704700e+01,3.940700e+01,4.616000e+01,5.636100e+01, & - &8.123900e+01,6.102600e+01,4.497800e+01,4.555600e+01,5.402200e+01, & - &1.018200e+02,7.646000e+01,5.284900e+01,4.568400e+01,5.178100e+01, & - &1.239000e+02,9.301500e+01,6.256700e+01,4.651400e+01,4.962500e+01, & - &1.471200e+02,1.104300e+02,7.374900e+01,4.817900e+01,4.755500e+01, & - &6.962300e+01,5.232000e+01,4.301500e+01,4.912300e+01,5.972900e+01, & - &8.944700e+01,6.718700e+01,4.913400e+01,4.848200e+01,5.705800e+01, & - &1.111200e+02,8.344300e+01,5.753400e+01,4.863000e+01,5.452700e+01, & - &1.342800e+02,1.008100e+02,6.774800e+01,4.948400e+01,5.210500e+01, & - &1.584500e+02,1.189300e+02,7.942500e+01,5.121000e+01,4.978800e+01, & - &7.695600e+01,5.782300e+01,4.666000e+01,5.175800e+01,6.268500e+01, & - &9.790200e+01,7.353300e+01,5.333200e+01,5.116400e+01,5.970600e+01, & - &1.206700e+02,9.061000e+01,6.227400e+01,5.133900e+01,5.688700e+01, & - &1.448100e+02,1.087100e+02,7.297600e+01,5.223700e+01,5.421700e+01, & - &1.697500e+02,1.274100e+02,8.508100e+01,5.402700e+01,5.168500e+01, & - &8.466800e+01,6.361300e+01,5.030800e+01,5.412500e+01,6.516300e+01, & - &1.067000e+02,8.013900e+01,5.757100e+01,5.356700e+01,6.188100e+01, & - &1.304300e+02,9.793200e+01,6.703000e+01,5.378400e+01,5.881600e+01, & - &1.553100e+02,1.165900e+02,7.819500e+01,5.473200e+01,5.592500e+01, & - &1.808300e+02,1.357300e+02,9.062700e+01,5.661700e+01,5.320100e+01, & - &9.265200e+01,6.960200e+01,5.395000e+01,5.619400e+01,6.714700e+01, & - &1.156200e+02,8.682700e+01,6.176100e+01,5.569600e+01,6.360500e+01, & - &1.401600e+02,1.052300e+02,7.172300e+01,5.595600e+01,6.031300e+01, & - &1.657100e+02,1.243900e+02,8.332200e+01,5.696700e+01,5.723500e+01, & - &1.918000e+02,1.439500e+02,9.611200e+01,5.903900e+01,5.435900e+01, & - &1.007200e+02,7.565600e+01,5.752500e+01,5.798100e+01,6.865000e+01, & - &1.245500e+02,9.352600e+01,6.588700e+01,5.753000e+01,6.489800e+01, & - &1.498100e+02,1.124700e+02,7.636200e+01,5.787200e+01,6.142100e+01, & - &1.759200e+02,1.320500e+02,8.834500e+01,5.901800e+01,5.819700e+01, & - &2.024400e+02,1.519300e+02,1.014400e+02,6.125500e+01,5.519100e+01, & - &1.080500e+02,8.115400e+01,6.075200e+01,5.953800e+01,6.985800e+01, & - &1.325800e+02,9.955300e+01,6.961300e+01,5.912700e+01,6.593200e+01, & - &1.584100e+02,1.189300e+02,8.050000e+01,5.951500e+01,6.231600e+01, & - &1.849600e+02,1.388300e+02,9.280400e+01,6.081600e+01,5.896000e+01, & - &2.117500e+02,1.589200e+02,1.061000e+02,6.317600e+01,5.584400e+01, & - &1.129400e+02,8.482600e+01,6.309800e+01,6.091900e+01,7.109900e+01, & - &1.379800e+02,1.036000e+02,7.223000e+01,6.048700e+01,6.701200e+01, & - &1.641800e+02,1.232500e+02,8.333800e+01,6.086200e+01,6.325100e+01, & - &1.910200e+02,1.433800e+02,9.582000e+01,6.222300e+01,5.977800e+01, & - &2.180600e+02,1.636500e+02,1.092500e+02,6.464700e+01,5.655700e+01, & - &1.149700e+02,8.634700e+01,6.439700e+01,6.215300e+01,7.251700e+01, & - &1.402900e+02,1.053400e+02,7.355500e+01,6.164400e+01,6.825600e+01, & - &1.667400e+02,1.251700e+02,8.471400e+01,6.195200e+01,6.435700e+01, & - &1.938100e+02,1.454800e+02,9.723900e+01,6.325100e+01,6.075700e+01, & - &2.210400e+02,1.658900e+02,1.107500e+02,6.565000e+01,5.751900e+01/ - data absb(601:900,15) / & - &1.130100e+02,8.488000e+01,6.433100e+01,6.334600e+01,7.441700e+01, & - &1.383900e+02,1.039100e+02,7.318700e+01,6.265600e+01,6.993600e+01, & - &1.649000e+02,1.238000e+02,8.412400e+01,6.278900e+01,6.585100e+01, & - &1.921000e+02,1.442000e+02,9.650300e+01,6.387000e+01,6.211700e+01, & - &2.195300e+02,1.647600e+02,1.100000e+02,6.608300e+01,5.882000e+01, & - &1.106000e+02,8.307800e+01,6.410300e+01,6.442600e+01,7.620100e+01, & - &1.359900e+02,1.021100e+02,7.263200e+01,6.355500e+01,7.151500e+01, & - &1.625300e+02,1.220200e+02,8.330700e+01,6.350300e+01,6.725900e+01, & - &1.898200e+02,1.424800e+02,9.550900e+01,6.437200e+01,6.341200e+01, & - &2.174000e+02,1.631600e+02,1.089400e+02,6.638200e+01,6.008100e+01, & - &1.080300e+02,8.114400e+01,6.377100e+01,6.541400e+01,7.786800e+01, & - &1.333700e+02,1.001500e+02,7.198200e+01,6.435000e+01,7.297500e+01, & - &1.599300e+02,1.200700e+02,8.239800e+01,6.411400e+01,6.856000e+01, & - &1.872600e+02,1.405700e+02,9.441300e+01,6.479500e+01,6.466200e+01, & - &2.149400e+02,1.613200e+02,1.077100e+02,6.659500e+01,6.131100e+01, & - &1.028200e+02,7.728800e+01,6.271900e+01,6.649700e+01,7.998000e+01, & - &1.278800e+02,9.603800e+01,7.032700e+01,6.513500e+01,7.483400e+01, & - &1.543400e+02,1.158800e+02,8.025200e+01,6.464400e+01,7.022400e+01, & - &1.816300e+02,1.363400e+02,9.195700e+01,6.505100e+01,6.616600e+01, & - &2.093900e+02,1.571600e+02,1.049700e+02,6.653200e+01,6.269500e+01, & - &9.724600e+01,7.326400e+01,6.165400e+01,6.760600e+01,8.211000e+01, & - &1.219600e+02,9.159800e+01,6.863900e+01,6.591800e+01,7.671500e+01, & - &1.482500e+02,1.113100e+02,7.797600e+01,6.516600e+01,7.189800e+01, & - &1.754600e+02,1.317200e+02,8.934100e+01,6.529400e+01,6.766300e+01, & - &2.031900e+02,1.525100e+02,1.020000e+02,6.646600e+01,6.408900e+01, & - &9.164600e+01,6.931900e+01,6.066200e+01,6.873600e+01,8.422500e+01, & - &1.159900e+02,8.711700e+01,6.703500e+01,6.669400e+01,7.858100e+01, & - &1.420100e+02,1.066300e+02,7.577200e+01,6.569400e+01,7.355100e+01, & - &1.691300e+02,1.269800e+02,8.669800e+01,6.553700e+01,6.914300e+01, & - &1.968200e+02,1.477400e+02,9.904600e+01,6.640400e+01,6.546300e+01, & - &8.478900e+01,6.463600e+01,5.956600e+01,7.009900e+01,8.667100e+01, & - &1.085700e+02,8.157100e+01,6.509700e+01,6.758100e+01,8.074900e+01, & - &1.342000e+02,1.007800e+02,7.311200e+01,6.624500e+01,7.546400e+01, & - &1.611200e+02,1.209600e+02,8.340800e+01,6.580600e+01,7.084900e+01, & - &1.887300e+02,1.416700e+02,9.538200e+01,6.629900e+01,6.700600e+01, & - &7.752600e+01,5.988000e+01,5.867400e+01,7.165700e+01,8.933200e+01, & - &1.006200e+02,7.576400e+01,6.321700e+01,6.859500e+01,8.308900e+01, & - &1.257300e+02,9.442500e+01,7.040500e+01,6.688400e+01,7.752800e+01, & - &1.523500e+02,1.143900e+02,7.993500e+01,6.612500e+01,7.267200e+01, & - &1.798500e+02,1.350100e+02,9.148100e+01,6.626400e+01,6.866800e+01, & - &7.049100e+01,5.551000e+01,5.802000e+01,7.331900e+01,9.204700e+01, & - &9.279600e+01,7.022900e+01,6.158300e+01,6.973700e+01,8.546400e+01, & - &1.173300e+02,8.812700e+01,6.793700e+01,6.759400e+01,7.963500e+01, & - &1.435900e+02,1.078100e+02,7.670700e+01,6.652400e+01,7.453500e+01, & - &1.708800e+02,1.282900e+02,8.765000e+01,6.630300e+01,7.037000e+01, & - &6.328500e+01,5.128300e+01,5.748900e+01,7.512600e+01,9.500200e+01, & - &8.464700e+01,6.467500e+01,6.015500e+01,7.110700e+01,8.804200e+01, & - &1.085000e+02,8.154300e+01,6.554000e+01,6.843400e+01,8.193300e+01, & - &1.342500e+02,1.008100e+02,7.345900e+01,6.698500e+01,7.654500e+01, & - &1.612800e+02,1.210900e+02,8.367000e+01,6.646400e+01,7.223300e+01, & - &5.563100e+01,4.711200e+01,5.736600e+01,7.725000e+01,9.839000e+01, & - &7.584700e+01,5.896100e+01,5.900100e+01,7.282900e+01,9.100500e+01, & - &9.881700e+01,7.452200e+01,6.320500e+01,6.951100e+01,8.453500e+01, & - &1.239000e+02,9.305300e+01,7.014700e+01,6.761600e+01,7.882400e+01, & - &1.505300e+02,1.130200e+02,7.944300e+01,6.672200e+01,7.427100e+01, & - &4.843600e+01,4.355300e+01,5.756100e+01,7.939700e+01,1.019300e+02, & - &6.745400e+01,5.382500e+01,5.817200e+01,7.467500e+01,9.410200e+01, & - &8.940900e+01,6.795500e+01,6.127300e+01,7.081600e+01,8.723800e+01, & - &1.137400e+02,8.543300e+01,6.717800e+01,6.839100e+01,8.121400e+01, & - &1.398300e+02,1.050000e+02,7.556100e+01,6.709800e+01,7.644300e+01/ - data absb(901:1175,15) / & - &4.174000e+01,4.061200e+01,5.820100e+01,8.177200e+01,1.056300e+02, & - &5.950800e+01,4.932300e+01,5.771900e+01,7.667500e+01,9.733300e+01, & - &8.035100e+01,6.191900e+01,5.982800e+01,7.236200e+01,9.006200e+01, & - &1.038300e+02,7.814400e+01,6.459200e+01,6.930900e+01,8.376100e+01, & - &1.293100e+02,9.711000e+01,7.199800e+01,6.761700e+01,7.882300e+01, & - &3.593400e+01,3.843900e+01,5.911200e+01,8.411600e+01,1.093100e+02, & - &5.248900e+01,4.563300e+01,5.770300e+01,7.860700e+01,1.005200e+02, & - &7.222800e+01,5.678600e+01,5.888600e+01,7.402200e+01,9.285400e+01, & - &9.480500e+01,7.172800e+01,6.254000e+01,7.037900e+01,8.621500e+01, & - &1.196100e+02,8.983500e+01,6.901500e+01,6.822700e+01,8.103500e+01, & - &3.077100e+01,3.700000e+01,6.026400e+01,8.650600e+01,1.130800e+02, & - &4.609100e+01,4.260400e+01,5.801600e+01,8.060400e+01,1.037400e+02, & - &6.471200e+01,5.230600e+01,5.817500e+01,7.570200e+01,9.566800e+01, & - &8.631800e+01,6.590700e+01,6.092400e+01,7.162600e+01,8.868900e+01, & - &1.104200e+02,8.296800e+01,6.641700e+01,6.895300e+01,8.318700e+01, & - &2.607300e+01,3.604500e+01,6.182200e+01,8.911700e+01,1.170400e+02, & - &4.012900e+01,4.007400e+01,5.868300e+01,8.278800e+01,1.071300e+02, & - &5.759900e+01,4.836500e+01,5.791100e+01,7.753800e+01,9.860900e+01, & - &7.817200e+01,6.056500e+01,5.972800e+01,7.307200e+01,9.129300e+01, & - &1.014400e+02,7.644600e+01,6.416400e+01,6.982000e+01,8.548300e+01, & - &2.182500e+01,3.543100e+01,6.352500e+01,9.191600e+01,1.212000e+02, & - &3.460200e+01,3.812500e+01,5.960000e+01,8.505000e+01,1.106900e+02, & - &5.087100e+01,4.491700e+01,5.793300e+01,7.937300e+01,1.016900e+02, & - &7.035500e+01,5.568900e+01,5.885000e+01,7.467000e+01,9.407100e+01, & - &9.271100e+01,7.029300e+01,6.223500e+01,7.087700e+01,8.799700e+01, & - &1.833700e+01,3.529400e+01,6.510300e+01,9.456800e+01,1.252200e+02, & - &2.995000e+01,3.691500e+01,6.071600e+01,8.722800e+01,1.141400e+02, & - &4.507000e+01,4.222300e+01,5.827600e+01,8.121600e+01,1.046300e+02, & - &6.352000e+01,5.168200e+01,5.824100e+01,7.621800e+01,9.655600e+01, & - &8.497300e+01,6.503500e+01,6.081400e+01,7.203100e+01,8.990500e+01, & - &1.533700e+01,3.548400e+01,6.678300e+01,9.734000e+01,1.292800e+02, & - &2.585200e+01,3.609700e+01,6.209700e+01,8.953700e+01,1.176200e+02, & - &3.985200e+01,4.003500e+01,5.887600e+01,8.312700e+01,1.076000e+02, & - &5.727700e+01,4.824300e+01,5.803700e+01,7.782800e+01,9.902100e+01, & - &7.782100e+01,6.037200e+01,5.979800e+01,7.332000e+01,9.176600e+01, & - &1.267800e+01,3.587300e+01,6.855100e+01,1.003400e+02,1.335200e+02, & - &2.212300e+01,3.555200e+01,6.357100e+01,9.196500e+01,1.212400e+02, & - &3.500100e+01,3.831700e+01,5.966900e+01,8.509400e+01,1.107100e+02, & - &5.136500e+01,4.521000e+01,5.804100e+01,7.941300e+01,1.017000e+02, & - &7.094600e+01,5.607700e+01,5.900700e+01,7.469400e+01,9.390900e+01, & - &1.033900e+01,3.654900e+01,7.041100e+01,1.035700e+02,1.380000e+02, & - &1.874200e+01,3.536300e+01,6.505300e+01,9.445700e+01,1.250200e+02, & - &3.050400e+01,3.710400e+01,6.068100e+01,8.713900e+01,1.139500e+02, & - &4.577300e+01,4.258400e+01,5.833100e+01,8.114300e+01,1.044800e+02, & - &6.436300e+01,5.219000e+01,5.838900e+01,7.615700e+01,9.630200e+01, & - &8.407200e+00,3.738800e+01,7.233800e+01,1.068400e+02,1.424600e+02, & - &1.585500e+01,3.550200e+01,6.660800e+01,9.702300e+01,1.288100e+02, & - &2.657200e+01,3.628900e+01,6.194900e+01,8.926600e+01,1.171900e+02, & - &4.077900e+01,4.044400e+01,5.884400e+01,8.291700e+01,1.072300e+02, & - &5.840400e+01,4.888000e+01,5.813400e+01,7.764700e+01,9.869800e+01, & - &7.709500e+00,3.776300e+01,7.316000e+01,1.082500e+02,1.443400e+02, & - &1.478500e+01,3.562300e+01,6.727300e+01,9.813700e+01,1.304000e+02, & - &2.509200e+01,3.603000e+01,6.250500e+01,9.019300e+01,1.185600e+02, & - &3.887500e+01,3.970900e+01,5.912200e+01,8.365300e+01,1.084000e+02, & - &5.610200e+01,4.764900e+01,5.810900e+01,7.826200e+01,9.970500e+01/ - data absb(1:300,16) / & - &3.226300e+01,2.421000e+01,1.615800e+01,8.647200e+00,1.136100e+01, & - &4.517400e+01,3.389400e+01,2.261400e+01,1.133400e+01,1.096500e+01, & - &6.002900e+01,4.503500e+01,3.004200e+01,1.504800e+01,1.069600e+01, & - &7.646500e+01,5.736200e+01,3.826000e+01,1.915700e+01,1.056400e+01, & - &9.407300e+01,7.056800e+01,4.706400e+01,2.355900e+01,1.064800e+01, & - &3.941800e+01,2.957500e+01,1.973200e+01,1.027100e+01,1.299000e+01, & - &5.473500e+01,4.106300e+01,2.739100e+01,1.371900e+01,1.272200e+01, & - &7.219600e+01,5.415900e+01,3.612200e+01,1.808400e+01,1.248200e+01, & - &9.158100e+01,6.869900e+01,4.581700e+01,2.293500e+01,1.248200e+01, & - &1.126000e+02,8.446600e+01,5.633000e+01,2.819400e+01,1.254100e+01, & - &4.774400e+01,3.581800e+01,2.389200e+01,1.255200e+01,1.503000e+01, & - &6.583900e+01,4.939000e+01,3.294100e+01,1.649200e+01,1.477700e+01, & - &8.676900e+01,6.508900e+01,4.340800e+01,2.172800e+01,1.458600e+01, & - &1.100200e+02,8.252800e+01,5.503600e+01,2.754400e+01,1.466600e+01, & - &1.351600e+02,1.013900e+02,6.761000e+01,3.383300e+01,1.470200e+01, & - &5.764500e+01,4.324300e+01,2.884200e+01,1.526700e+01,1.735900e+01, & - &7.941300e+01,5.957000e+01,3.972700e+01,1.988400e+01,1.705400e+01, & - &1.044000e+02,7.831400e+01,5.222500e+01,2.613500e+01,1.704100e+01, & - &1.320800e+02,9.907100e+01,6.606300e+01,3.305600e+01,1.711900e+01, & - &1.617500e+02,1.213200e+02,8.089900e+01,4.047600e+01,1.715200e+01, & - &6.957500e+01,5.219000e+01,3.480400e+01,1.836900e+01,1.992100e+01, & - &9.542800e+01,7.158000e+01,4.773300e+01,2.388500e+01,1.975600e+01, & - &1.249100e+02,9.369400e+01,6.247600e+01,3.125900e+01,1.981000e+01, & - &1.573500e+02,1.180200e+02,7.869600e+01,3.937000e+01,1.989500e+01, & - &1.918600e+02,1.439100e+02,9.595500e+01,4.800100e+01,1.991000e+01, & - &8.343200e+01,6.258100e+01,4.173100e+01,2.185400e+01,2.322800e+01, & - &1.137800e+02,8.534600e+01,5.690800e+01,2.847100e+01,2.316800e+01, & - &1.480700e+02,1.110600e+02,7.405100e+01,3.704300e+01,2.306300e+01, & - &1.854600e+02,1.391000e+02,9.274700e+01,4.639300e+01,2.305100e+01, & - &2.250100e+02,1.687700e+02,1.125300e+02,5.628600e+01,2.299300e+01, & - &9.905700e+01,7.429900e+01,4.954200e+01,2.594200e+01,2.727200e+01, & - &1.340500e+02,1.005500e+02,6.704200e+01,3.354300e+01,2.714400e+01, & - &1.733400e+02,1.300200e+02,8.668900e+01,4.336400e+01,2.691600e+01, & - &2.164100e+02,1.623200e+02,1.082300e+02,5.414000e+01,2.672500e+01, & - &2.623600e+02,1.967800e+02,1.312100e+02,6.563000e+01,2.653800e+01, & - &1.167000e+02,8.753400e+01,5.836600e+01,3.068000e+01,3.195900e+01, & - &1.570900e+02,1.178300e+02,7.856600e+01,3.930500e+01,3.172400e+01, & - &2.026900e+02,1.520300e+02,1.013700e+02,5.070800e+01,3.137600e+01, & - &2.523000e+02,1.892400e+02,1.261800e+02,6.311400e+01,3.098400e+01, & - &3.047900e+02,2.286100e+02,1.524200e+02,7.623700e+01,3.060600e+01, & - &1.367700e+02,1.025900e+02,6.840800e+01,3.594700e+01,3.729500e+01, & - &1.832700e+02,1.374600e+02,9.165500e+01,4.585000e+01,3.692300e+01, & - &2.353000e+02,1.764800e+02,1.176700e+02,5.886000e+01,3.640500e+01, & - &2.915500e+02,2.186700e+02,1.458000e+02,7.292200e+01,3.587400e+01, & - &3.503300e+02,2.627600e+02,1.751900e+02,8.761900e+01,3.527000e+01, & - &1.623300e+02,1.217600e+02,8.118700e+01,4.265700e+01,4.324800e+01, & - &2.154400e+02,1.615900e+02,1.077400e+02,5.394500e+01,4.270100e+01, & - &2.741000e+02,2.055900e+02,1.370700e+02,6.855700e+01,4.211900e+01, & - &3.368500e+02,2.526500e+02,1.684500e+02,8.424800e+01,4.150900e+01, & - &4.026300e+02,3.019900e+02,2.013400e+02,1.007000e+02,4.081100e+01, & - &1.905300e+02,1.429100e+02,9.528500e+01,5.061700e+01,5.033700e+01, & - &2.501700e+02,1.876400e+02,1.251100e+02,6.299800e+01,4.966000e+01, & - &3.159500e+02,2.369800e+02,1.580000e+02,7.902900e+01,4.892700e+01, & - &3.862800e+02,2.897200e+02,1.931700e+02,9.661200e+01,4.803400e+01, & - &4.592600e+02,3.444600e+02,2.296600e+02,1.148600e+02,4.701800e+01, & - &2.215300e+02,1.661600e+02,1.107900e+02,5.959000e+01,5.841800e+01, & - &2.885800e+02,2.164500e+02,1.443200e+02,7.296400e+01,5.735300e+01, & - &3.617600e+02,2.713400e+02,1.809100e+02,9.048400e+01,5.619100e+01, & - &4.391300e+02,3.293600e+02,2.195900e+02,1.098300e+02,5.489900e+01, & - &5.187100e+02,3.890500e+02,2.593900e+02,1.297200e+02,5.349300e+01/ - data absb(301:600,16) / & - &2.559200e+02,1.919500e+02,1.279900e+02,6.950500e+01,6.695800e+01, & - &3.302100e+02,2.476700e+02,1.651300e+02,8.380500e+01,6.538800e+01, & - &4.103400e+02,3.077700e+02,2.052000e+02,1.026300e+02,6.368400e+01, & - &4.940700e+02,3.705700e+02,2.470600e+02,1.235600e+02,6.188900e+01, & - &5.794500e+02,4.346000e+02,2.897500e+02,1.449000e+02,6.000700e+01, & - &2.937500e+02,2.203300e+02,1.469000e+02,8.024400e+01,7.565700e+01, & - &3.748200e+02,2.811300e+02,1.874400e+02,9.562700e+01,7.342700e+01, & - &4.612600e+02,3.459600e+02,2.306500e+02,1.154600e+02,7.110400e+01, & - &5.513800e+02,4.135400e+02,2.757100e+02,1.378800e+02,6.873200e+01, & - &6.428200e+02,4.821300e+02,3.214300e+02,1.607400e+02,6.629600e+01, & - &3.332100e+02,2.499200e+02,1.666300e+02,9.136600e+01,8.413800e+01, & - &4.209200e+02,3.157000e+02,2.104800e+02,1.078600e+02,8.121600e+01, & - &5.139900e+02,3.855000e+02,2.570100e+02,1.286200e+02,7.818600e+01, & - &6.098800e+02,4.574200e+02,3.049600e+02,1.525000e+02,7.517900e+01, & - &7.061300e+02,5.296000e+02,3.530800e+02,1.765600e+02,7.219100e+01, & - &3.743300e+02,2.807500e+02,1.871800e+02,1.025900e+02,9.214600e+01, & - &4.684700e+02,3.513600e+02,2.342500e+02,1.202300e+02,8.847700e+01, & - &5.671900e+02,4.254000e+02,2.836100e+02,1.420400e+02,8.471100e+01, & - &6.680500e+02,5.010500e+02,3.340400e+02,1.670400e+02,8.105800e+01, & - &7.686100e+02,5.764700e+02,3.843200e+02,1.921700e+02,7.753500e+01, & - &4.172500e+02,3.129400e+02,2.086400e+02,1.139100e+02,9.944400e+01, & - &5.170100e+02,3.877700e+02,2.585200e+02,1.325700e+02,9.495000e+01, & - &6.208000e+02,4.656100e+02,3.104100e+02,1.554200e+02,9.053200e+01, & - &7.255800e+02,5.441900e+02,3.628000e+02,1.814100e+02,8.625400e+01, & - &8.290100e+02,6.217600e+02,4.145100e+02,2.072700e+02,8.215200e+01, & - &4.607400e+02,3.455600e+02,2.303800e+02,1.251000e+02,1.058300e+02, & - &5.654000e+02,4.240600e+02,2.827100e+02,1.446400e+02,1.005700e+02, & - &6.728600e+02,5.046500e+02,3.364400e+02,1.685200e+02,9.550500e+01, & - &7.808800e+02,5.856600e+02,3.904500e+02,1.952300e+02,9.066100e+01, & - &8.868600e+02,6.651500e+02,4.434400e+02,2.217300e+02,8.603600e+01, & - &5.047200e+02,3.785400e+02,2.523700e+02,1.361400e+02,1.111700e+02, & - &6.133900e+02,4.600400e+02,3.067000e+02,1.566100e+02,1.052900e+02, & - &7.243300e+02,5.432500e+02,3.621700e+02,1.814400e+02,9.959100e+01, & - &8.350400e+02,6.262900e+02,4.175300e+02,2.087700e+02,9.422900e+01, & - &9.428000e+02,7.071100e+02,4.714100e+02,2.357100e+02,8.917600e+01, & - &5.485500e+02,4.114200e+02,2.742800e+02,1.467600e+02,1.154800e+02, & - &6.609100e+02,4.956800e+02,3.304600e+02,1.682600e+02,1.090100e+02, & - &7.747700e+02,5.810800e+02,3.873900e+02,1.938800e+02,1.028100e+02, & - &8.873000e+02,6.654800e+02,4.436600e+02,2.218300e+02,9.700400e+01, & - &9.959400e+02,7.469500e+02,4.979700e+02,2.489900e+02,9.160100e+01, & - &5.924200e+02,4.443200e+02,2.962200e+02,1.569400e+02,1.188300e+02, & - &7.077700e+02,5.308300e+02,3.538900e+02,1.795600e+02,1.118300e+02, & - &8.235800e+02,6.176800e+02,4.117900e+02,2.059100e+02,1.052400e+02, & - &9.371300e+02,7.028500e+02,4.685700e+02,2.342900e+02,9.906600e+01, & - &1.045900e+03,7.844600e+02,5.229700e+02,2.614900e+02,9.335400e+01, & - &6.315300e+02,4.736500e+02,3.157700e+02,1.659500e+02,1.215200e+02, & - &7.490400e+02,5.617800e+02,3.745200e+02,1.895200e+02,1.140900e+02, & - &8.662500e+02,6.496900e+02,4.331300e+02,2.165700e+02,1.071400e+02, & - &9.804500e+02,7.353400e+02,4.902300e+02,2.451200e+02,1.007000e+02, & - &1.089700e+03,8.172600e+02,5.448400e+02,2.724300e+02,9.473000e+01, & - &6.582100e+02,4.936600e+02,3.291100e+02,1.724000e+02,1.241900e+02, & - &7.772800e+02,5.829600e+02,3.886400e+02,1.964900e+02,1.163800e+02, & - &8.959400e+02,6.719600e+02,4.479700e+02,2.239900e+02,1.090900e+02, & - &1.010900e+03,7.582100e+02,5.054800e+02,2.527400e+02,1.023900e+02, & - &1.119900e+03,8.399200e+02,5.599500e+02,2.799800e+02,9.618300e+01, & - &6.705900e+02,5.029400e+02,3.353000e+02,1.760400e+02,1.271500e+02, & - &7.909400e+02,5.932000e+02,3.954700e+02,2.001200e+02,1.189700e+02, & - &9.105500e+02,6.829100e+02,4.552800e+02,2.276400e+02,1.113500e+02, & - &1.026600e+03,7.699600e+02,5.133100e+02,2.566600e+02,1.043600e+02, & - &1.136300e+03,8.522100e+02,5.681400e+02,2.840700e+02,9.793400e+01/ - data absb(601:900,16) / & - &6.631900e+02,4.974000e+02,3.316000e+02,1.760100e+02,1.309600e+02, & - &7.842400e+02,5.881800e+02,3.921200e+02,1.993700e+02,1.223600e+02, & - &9.052400e+02,6.789300e+02,4.526200e+02,2.263500e+02,1.143900e+02, & - &1.022600e+03,7.669300e+02,5.112900e+02,2.556500e+02,1.070700e+02, & - &1.134000e+03,8.505300e+02,5.670200e+02,2.835100e+02,1.003300e+02, & - &6.532800e+02,4.899600e+02,3.266400e+02,1.755100e+02,1.346000e+02, & - &7.749700e+02,5.812300e+02,3.874900e+02,1.981100e+02,1.255600e+02, & - &8.967800e+02,6.725900e+02,4.483900e+02,2.245200e+02,1.172600e+02, & - &1.015600e+03,7.616800e+02,5.077900e+02,2.539000e+02,1.096000e+02, & - &1.128900e+03,8.466900e+02,5.644600e+02,2.822300e+02,1.026200e+02, & - &6.425700e+02,4.819300e+02,3.212900e+02,1.747900e+02,1.379200e+02, & - &7.641400e+02,5.731000e+02,3.820700e+02,1.965400e+02,1.285100e+02, & - &8.866400e+02,6.649800e+02,4.433200e+02,2.224300e+02,1.198900e+02, & - &1.006600e+03,7.549500e+02,5.033000e+02,2.516500e+02,1.119200e+02, & - &1.121100e+03,8.408400e+02,5.605600e+02,2.802800e+02,1.047000e+02, & - &6.180800e+02,4.635600e+02,3.090400e+02,1.719200e+02,1.421000e+02, & - &7.397400e+02,5.548100e+02,3.698700e+02,1.923700e+02,1.322100e+02, & - &8.627400e+02,6.470600e+02,4.313700e+02,2.174500e+02,1.232100e+02, & - &9.837700e+02,7.378300e+02,4.918900e+02,2.459400e+02,1.149300e+02, & - &1.100300e+03,8.252600e+02,5.501800e+02,2.750900e+02,1.074000e+02, & - &5.912000e+02,4.434000e+02,2.956000e+02,1.687700e+02,1.463200e+02, & - &7.126800e+02,5.345100e+02,3.563400e+02,1.878700e+02,1.359200e+02, & - &8.359700e+02,6.269800e+02,4.179800e+02,2.120500e+02,1.265500e+02, & - &9.584200e+02,7.188200e+02,4.792100e+02,2.396700e+02,1.179500e+02, & - &1.076600e+03,8.074800e+02,5.383200e+02,2.691600e+02,1.101300e+02, & - &5.638100e+02,4.228700e+02,2.819200e+02,1.658600e+02,1.505400e+02, & - &6.849600e+02,5.137200e+02,3.424800e+02,1.837500e+02,1.396000e+02, & - &8.082100e+02,6.061600e+02,4.041100e+02,2.065700e+02,1.298100e+02, & - &9.313500e+02,6.985100e+02,4.656700e+02,2.332300e+02,1.209300e+02, & - &1.051200e+03,7.884200e+02,5.256200e+02,2.628100e+02,1.127800e+02, & - &5.295500e+02,3.971700e+02,2.648000e+02,1.623900e+02,1.554300e+02, & - &6.492900e+02,4.869700e+02,3.246500e+02,1.786300e+02,1.438400e+02, & - &7.727200e+02,5.795400e+02,3.863600e+02,1.999000e+02,1.336300e+02, & - &8.963800e+02,6.722900e+02,4.481900e+02,2.254200e+02,1.243600e+02, & - &1.017600e+03,7.632200e+02,5.088100e+02,2.544100e+02,1.158500e+02, & - &4.922600e+02,3.692100e+02,2.461800e+02,1.591900e+02,1.607100e+02, & - &6.104900e+02,4.578700e+02,3.052500e+02,1.733300e+02,1.484100e+02, & - &7.331900e+02,5.498900e+02,3.666000e+02,1.927400e+02,1.376500e+02, & - &8.573800e+02,6.430300e+02,4.286900e+02,2.171900e+02,1.280100e+02, & - &9.798000e+02,7.348500e+02,4.899000e+02,2.450000e+02,1.191800e+02, & - &4.553800e+02,3.415500e+02,2.285400e+02,1.564100e+02,1.660900e+02, & - &5.719100e+02,4.289400e+02,2.859700e+02,1.686000e+02,1.531400e+02, & - &6.934200e+02,5.200700e+02,3.467100e+02,1.862900e+02,1.417800e+02, & - &8.173400e+02,6.130100e+02,4.086700e+02,2.090700e+02,1.317200e+02, & - &9.411300e+02,7.058400e+02,4.705600e+02,2.357600e+02,1.225400e+02, & - &4.166900e+02,3.125300e+02,2.118300e+02,1.543200e+02,1.719900e+02, & - &5.303200e+02,3.977500e+02,2.651900e+02,1.640300e+02,1.582500e+02, & - &6.508400e+02,4.881300e+02,3.254200e+02,1.799800e+02,1.462400e+02, & - &7.745300e+02,5.809000e+02,3.872700e+02,2.008900e+02,1.356800e+02, & - &8.988600e+02,6.741400e+02,4.494300e+02,2.262800e+02,1.261800e+02, & - &3.742800e+02,2.807300e+02,1.946400e+02,1.528300e+02,1.787600e+02, & - &4.847900e+02,3.636200e+02,2.425300e+02,1.599000e+02,1.641300e+02, & - &6.029400e+02,4.522100e+02,3.014700e+02,1.732800e+02,1.513400e+02, & - &7.259100e+02,5.444300e+02,3.629500e+02,1.921500e+02,1.402000e+02, & - &8.503700e+02,6.377800e+02,4.251800e+02,2.160700e+02,1.302300e+02, & - &3.334900e+02,2.501400e+02,1.797000e+02,1.530200e+02,1.859100e+02, & - &4.400200e+02,3.300400e+02,2.219500e+02,1.566600e+02,1.703000e+02, & - &5.556300e+02,4.167300e+02,2.778300e+02,1.675200e+02,1.567200e+02, & - &6.772400e+02,5.079300e+02,3.386200e+02,1.844300e+02,1.448900e+02, & - &8.011300e+02,6.008500e+02,4.005600e+02,2.062700e+02,1.344400e+02/ - data absb(901:1175,16) / & - &2.945000e+02,2.209100e+02,1.663300e+02,1.539200e+02,1.935400e+02, & - &3.965500e+02,2.974300e+02,2.037000e+02,1.544400e+02,1.767300e+02, & - &5.089700e+02,3.817400e+02,2.545200e+02,1.627400e+02,1.623600e+02, & - &6.285700e+02,4.714300e+02,3.142800e+02,1.773100e+02,1.497400e+02, & - &7.522200e+02,5.641700e+02,3.761100e+02,1.970600e+02,1.387600e+02, & - &2.598500e+02,1.949100e+02,1.558600e+02,1.561600e+02,2.011300e+02, & - &3.570400e+02,2.678000e+02,1.885100e+02,1.537900e+02,1.831000e+02, & - &4.661800e+02,3.496500e+02,2.337400e+02,1.590700e+02,1.678600e+02, & - &5.834100e+02,4.375700e+02,2.917200e+02,1.713800e+02,1.545900e+02, & - &7.061900e+02,5.296400e+02,3.531000e+02,1.892700e+02,1.430000e+02, & - &2.281000e+02,1.711100e+02,1.478100e+02,1.598600e+02,2.089900e+02, & - &3.203400e+02,2.402800e+02,1.754600e+02,1.541000e+02,1.897000e+02, & - &4.256100e+02,3.192300e+02,2.159900e+02,1.564900e+02,1.734600e+02, & - &5.403900e+02,4.053100e+02,2.702300e+02,1.663800e+02,1.594600e+02, & - &6.616200e+02,4.962100e+02,3.308100e+02,1.824500e+02,1.472500e+02, & - &1.982800e+02,1.499300e+02,1.411900e+02,1.643600e+02,2.174000e+02, & - &2.854000e+02,2.140700e+02,1.638200e+02,1.552000e+02,1.966500e+02, & - &3.862600e+02,2.897100e+02,1.998100e+02,1.546800e+02,1.793500e+02, & - &4.980400e+02,3.735500e+02,2.490800e+02,1.622500e+02,1.645800e+02, & - &6.171800e+02,4.628900e+02,3.085900e+02,1.760700e+02,1.516800e+02, & - &1.705300e+02,1.327100e+02,1.363600e+02,1.698600e+02,2.263000e+02, & - &2.520400e+02,1.890600e+02,1.541700e+02,1.576700e+02,2.040400e+02, & - &3.481900e+02,2.611600e+02,1.855500e+02,1.544200e+02,1.855200e+02, & - &4.565200e+02,3.424100e+02,2.294200e+02,1.588200e+02,1.699200e+02, & - &5.732700e+02,4.299600e+02,2.866500e+02,1.704500e+02,1.563600e+02, & - &1.470500e+02,1.195600e+02,1.341600e+02,1.762400e+02,2.349800e+02, & - &2.231800e+02,1.674700e+02,1.469400e+02,1.612200e+02,2.112600e+02, & - &3.147100e+02,2.360600e+02,1.737300e+02,1.547500e+02,1.916000e+02, & - &4.192900e+02,3.144900e+02,2.134400e+02,1.565700e+02,1.750600e+02, & - &5.337300e+02,4.003100e+02,2.669000e+02,1.659700e+02,1.608300e+02, & - &1.263100e+02,1.086900e+02,1.331600e+02,1.828600e+02,2.438100e+02, & - &1.970900e+02,1.492100e+02,1.413100e+02,1.652200e+02,2.186500e+02, & - &2.839500e+02,2.129900e+02,1.636000e+02,1.557900e+02,1.976900e+02, & - &3.846600e+02,2.885200e+02,1.993100e+02,1.550100e+02,1.801900e+02, & - &4.964200e+02,3.723300e+02,2.482800e+02,1.623800e+02,1.653100e+02, & - &1.074500e+02,1.000100e+02,1.335100e+02,1.898500e+02,2.531300e+02, & - &1.726300e+02,1.340100e+02,1.370200e+02,1.699900e+02,2.263800e+02, & - &2.546100e+02,1.909800e+02,1.550600e+02,1.578800e+02,2.041000e+02, & - &3.512700e+02,2.634700e+02,1.867900e+02,1.547700e+02,1.855600e+02, & - &4.598500e+02,3.449100e+02,2.309600e+02,1.593500e+02,1.699300e+02, & - &9.036900e+01,9.301300e+01,1.354500e+02,1.973200e+02,2.630900e+02, & - &1.499300e+02,1.212500e+02,1.347100e+02,1.759300e+02,2.345700e+02, & - &2.267600e+02,1.701200e+02,1.480400e+02,1.611800e+02,2.109200e+02, & - &3.189600e+02,2.392500e+02,1.753200e+02,1.550100e+02,1.913000e+02, & - &4.241100e+02,3.181000e+02,2.155200e+02,1.570800e+02,1.747900e+02, & - &7.579800e+01,8.796800e+01,1.383900e+02,2.048600e+02,2.731500e+02, & - &1.300200e+02,1.106700e+02,1.335700e+02,1.821100e+02,2.428200e+02, & - &2.017700e+02,1.523400e+02,1.424300e+02,1.648100e+02,2.178000e+02, & - &2.896700e+02,2.172800e+02,1.655400e+02,1.558000e+02,1.969600e+02, & - &3.911800e+02,2.934000e+02,2.019400e+02,1.554800e+02,1.795700e+02, & - &7.042700e+01,8.642000e+01,1.399200e+02,2.081000e+02,2.774700e+02, & - &1.225700e+02,1.069900e+02,1.334200e+02,1.847100e+02,2.462900e+02, & - &1.922500e+02,1.460900e+02,1.406100e+02,1.664900e+02,2.206700e+02, & - &2.782000e+02,2.086800e+02,1.619600e+02,1.564400e+02,1.993600e+02, & - &3.782900e+02,2.837300e+02,1.969300e+02,1.551600e+02,1.815800e+02/ - -! the array selfref contains the coefficient of the water vapor -! self-continuum (including the energy term). the first index -! refers to temperature in 7.2 degree increments. for instance, -! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, -! etc. the second index runs over the g-channel (1 to NG05=16). - - data selfref(:, 1) / & - &1.276640e-01,1.092960e-01,9.357030e-02,8.010750e-02,6.858180e-02, & - &5.871430e-02,5.026660e-02,4.303430e-02,3.684260e-02,3.154170e-02/ - data selfref(:, 2) / & - &1.396200e-01,1.203810e-01,1.037930e-01,8.949080e-02,7.715950e-02, & - &6.652730e-02,5.736010e-02,4.945620e-02,4.264140e-02,3.676560e-02/ - data selfref(:, 3) / & - &1.426280e-01,1.230430e-01,1.061480e-01,9.157260e-02,7.899860e-02, & - &6.815110e-02,5.879310e-02,5.072010e-02,4.375560e-02,3.774740e-02/ - data selfref(:, 4) / & - &1.535690e-01,1.331430e-01,1.154350e-01,1.000820e-01,8.677060e-02, & - &7.522990e-02,6.522410e-02,5.654910e-02,4.902790e-02,4.250700e-02/ - data selfref(:, 5) / & - &1.704910e-01,1.464480e-01,1.257960e-01,1.080560e-01,9.281820e-02, & - &7.972900e-02,6.848560e-02,5.882780e-02,5.053190e-02,4.340590e-02/ - data selfref(:, 6) / & - &1.763940e-01,1.514320e-01,1.300030e-01,1.116060e-01,9.581270e-02, & - &8.225420e-02,7.061440e-02,6.062170e-02,5.204310e-02,4.467840e-02/ - data selfref(:, 7) / & - &1.857060e-01,1.591720e-01,1.364290e-01,1.169360e-01,1.002280e-01, & - &8.590680e-02,7.363220e-02,6.311140e-02,5.409390e-02,4.636480e-02/ - data selfref(:, 8) / & - &1.886470e-01,1.616570e-01,1.385290e-01,1.187100e-01,1.017260e-01, & - &8.717220e-02,7.470050e-02,6.401320e-02,5.485490e-02,4.700680e-02/ - data selfref(:, 9) / & - &1.900740e-01,1.627930e-01,1.394270e-01,1.194150e-01,1.022750e-01, & - &8.759590e-02,7.502330e-02,6.425520e-02,5.503270e-02,4.713380e-02/ - data selfref(:,10) / & - &1.947690e-01,1.663380e-01,1.420570e-01,1.213200e-01,1.036110e-01, & - &8.848630e-02,7.556960e-02,6.453840e-02,5.511750e-02,4.707180e-02/ - data selfref(:,11) / & - &1.906240e-01,1.642290e-01,1.414880e-01,1.218960e-01,1.050170e-01, & - &9.047570e-02,7.794750e-02,6.715420e-02,5.785540e-02,4.984420e-02/ - data selfref(:,12) / & - &1.905020e-01,1.640250e-01,1.412280e-01,1.215990e-01,1.046990e-01, & - &9.014720e-02,7.761810e-02,6.683030e-02,5.754190e-02,4.954440e-02/ - data selfref(:,13) / & - &1.867860e-01,1.616360e-01,1.398720e-01,1.210390e-01,1.047410e-01, & - &9.063800e-02,7.843380e-02,6.787290e-02,5.873400e-02,5.082560e-02/ - data selfref(:,14) / & - &1.991490e-01,1.714750e-01,1.476460e-01,1.271290e-01,1.094620e-01, & - &9.425120e-02,8.115380e-02,6.987640e-02,6.016620e-02,5.180530e-02/ - data selfref(:,15) / & - &2.026760e-01,1.737010e-01,1.488690e-01,1.275870e-01,1.093470e-01, & - &9.371440e-02,8.031700e-02,6.883480e-02,5.899410e-02,5.056030e-02/ - data selfref(:,16) / & - &1.998650e-01,1.726990e-01,1.492250e-01,1.289420e-01,1.114160e-01, & - &9.627210e-02,8.318660e-02,7.187970e-02,6.210970e-02,5.366760e-02/ - - data ccl4 / & - &2.614070e+01,5.397760e+01,6.380850e+01,3.617010e+01,1.540990e+01, & - &1.023116e+01,4.829480e+00,5.038360e+00,1.755580e+00,0.000000e+00, & - &0.000000e+00,0.000000e+00,0.000000e+00,0.000000e+00,0.000000e+00, & - &0.000000e+00 / - - data fracrefa(:,:) / & - &0.1396649927,0.1413889974,0.1376339942,0.1307670027,0.1229910031, & - &0.1074770018,0.0894199982,0.0676919967,0.0458761007,0.0050117299, & - &0.0041580899,0.0032839801,0.0024001501,0.0015622200,0.0005910400, & - &0.0000832300,0.1395819932,0.1433289945,0.1378539950,0.1320540011, & - &0.1219969988,0.1067959964,0.0886107981,0.0671231970,0.0455603004, & - &0.0050086300,0.0041631502,0.0032862900,0.0024002299,0.0015622000, & - &0.0005910400,0.0000832300,0.1390710026,0.1425050050,0.1388960034, & - &0.1329730004,0.1221870035,0.1068380028,0.0883926004,0.0667731017, & - &0.0453856997,0.0049540200,0.0040986300,0.0032821901,0.0024080500, & - &0.0015626600,0.0005910400,0.0000832300,0.1386770010,0.1419010013, & - &0.1393229961,0.1332709938,0.1228080019,0.1069250032,0.0884450972, & - &0.0665851012,0.0451934002,0.0049227602,0.0040883198,0.0032385599, & - &0.0023928899,0.0015569800,0.0005910400,0.0000832300,0.1384499967, & - &0.1415880024,0.1392930001,0.1329559982,0.1234830022,0.1073670015, & - &0.0885948017,0.0665061027,0.0449822992,0.0049133501,0.0040696799, & - &0.0032290099,0.0023466600,0.0015523500,0.0005881300,0.0000832300, & - &0.1383710057,0.1411319971,0.1393049955,0.1328310072,0.1234920025, & - &0.1079640016,0.0889049023,0.0664647967,0.0448599011,0.0048955400, & - &0.0040526399,0.0032031301,0.0023474200,0.0015115900,0.0005843800, & - &0.0000825300,0.1383450031,0.1409350038,0.1389649957,0.1326200068, & - &0.1232689992,0.1082890034,0.0895005018,0.0667461008,0.0447655991, & - &0.0048962398,0.0040096198,0.0031742300,0.0023347901,0.0014824900, & - &0.0005859000,0.0000825300,0.1383129954,0.1406899989,0.1387140006, & - &0.1324760020,0.1225140020,0.1083130017,0.0897708982,0.0677691996, & - &0.0449839011,0.0048411102,0.0039894800,0.0031606900,0.0022974100, & - &0.0015010400,0.0005860800,0.0000825300,0.1402720064,0.1442040056, & - &0.1421570033,0.1344660074,0.1230370030,0.1059610024,0.0865036994, & - &0.0640956983,0.0431231000,0.0047110999,0.0039395401,0.0031085000, & - &0.0022958801,0.0014636600,0.0005819400,0.0000825300 / - data fracrefb(:,:) / & - &0.1433909982,0.1435869932,0.1393530071,0.1330669969,0.1213570014, & - &0.1059060022,0.0868823975,0.0655322000,0.0444674008,0.0048357998, & - &0.0039941301,0.0031622499,0.0023300699,0.0014913500,0.0005624600, & - &0.0000805900,0.1433050036,0.1443029940,0.1405369937,0.1335529983, & - &0.1215120032,0.1052910015,0.0862763003,0.0650523007,0.0438584983, & - &0.0047655501,0.0039500999,0.0031387799,0.0023227299,0.0014935400, & - &0.0005624600,0.0000805900,0.1432839930,0.1444270015,0.1407860070, & - &0.1339010000,0.1213259995,0.1051060036,0.0861366019,0.0649463013, & - &0.0438130982,0.0047537801,0.0039416598,0.0031307600,0.0023123501, & - &0.0014915901,0.0005630100,0.0000805900,0.1432690024,0.1445309967, & - &0.1411419958,0.1339710057,0.1212719977,0.1049339995,0.0860138014, & - &0.0648335963,0.0437889993,0.0047465502,0.0039354898,0.0031258301, & - &0.0023068599,0.0014843300,0.0005650200,0.0000805900,0.1432889998, & - &0.1453270018,0.1417900026,0.1338459998,0.1209369972,0.1046150029, & - &0.0857300982,0.0646134019,0.0436656997,0.0047308700,0.0039253901, & - &0.0031123799,0.0022986501,0.0014757200,0.0005651700,0.0000793900/ - -!........................................! - end module module_radlw_kgb05 ! -!========================================! - - - -!========================================! - module module_radlw_kgb06 ! -!........................................! -! - use machine, only : kind_phys - use module_radlw_parameters, only : NG06 -! - implicit none -! - private -! - integer, public :: MSA06, MSF06 - parameter (MSA06=65, MSF06=10) - - real (kind=kind_phys), public :: & - & absa(MSA06,NG06), selfref(MSF06,NG06), absco2(NG06), & - & cfc11adj(NG06), cfc12(NG06), fracrefa(NG06) - - -! the array absa(65,NG06) = ka(5,13,NG06) contains absorption coefs at -! the NG06=8 chosen g-values for a range of pressure levels > ~100mb -! and temperatures. the first index in the array, jt, which runs from -! 1 to 5, corresponds to different temperatures. more specifically, -! jt = 1-5 means that the data are for the corresponding temperature of -! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the -! second index, jp, runs from 1 to 13 and refers to the corresponding -! pressure level in pref (e.g. jp = 1 is for a pressure of 1053.63 mb). -! the third index, ig, goes from 1 to NG06=8, and tells us which -! g-interval the absorption coefficients are for. - - data absa(:, 1) / & - &2.606157e-05,2.932535e-05,2.854911e-05,2.629371e-05,2.527095e-05, & - &2.123415e-05,2.152584e-05,2.103189e-05,1.927562e-05,2.027191e-05, & - &1.484284e-05,1.463244e-05,1.396693e-05,1.472393e-05,1.473098e-05, & - &1.011545e-05,1.004538e-05,1.057780e-05,1.016540e-05,1.139278e-05, & - &7.352597e-06,7.303390e-06,7.184352e-06,7.786876e-06,9.160921e-06, & - &5.220945e-06,5.321160e-06,5.168642e-06,6.162226e-06,7.972385e-06, & - &3.914604e-06,3.891921e-06,4.414279e-06,5.523085e-06,7.537506e-06, & - &3.502393e-06,3.931886e-06,4.925752e-06,6.348437e-06,8.629327e-06, & - &8.160859e-06,9.454337e-06,1.134030e-05,1.418641e-05,1.831216e-05, & - &2.878107e-05,3.245688e-05,3.724608e-05,4.434263e-05,5.477392e-05, & - &4.047296e-05,4.546352e-05,5.197719e-05,6.124561e-05,7.506821e-05, & - &4.274889e-05,4.798630e-05,5.475019e-05,6.423669e-05,7.849913e-05, & - &3.645375e-05,4.094707e-05,4.666240e-05,5.469361e-05,6.680605e-05/ - data absa(:, 2) / & - &3.043275e-05,3.242614e-05,3.770071e-05,4.364029e-05,4.831790e-05, & - &2.315242e-05,2.780420e-05,2.773780e-05,3.369230e-05,3.408465e-05, & - &1.741592e-05,1.843813e-05,2.090598e-05,2.287960e-05,2.729643e-05, & - &1.161476e-05,1.337374e-05,1.583993e-05,1.937320e-05,2.635659e-05, & - &8.851017e-06,1.125942e-05,1.333431e-05,1.840560e-05,2.709794e-05, & - &7.294314e-06,9.058318e-06,1.211435e-05,1.782786e-05,2.659805e-05, & - &6.511081e-06,8.013850e-06,1.180812e-05,1.819311e-05,2.757518e-05, & - &7.055871e-06,9.480686e-06,1.389688e-05,2.163303e-05,3.366623e-05, & - &1.652827e-05,2.116186e-05,2.956235e-05,4.488579e-05,7.139900e-05, & - &5.477644e-05,6.750079e-05,8.778644e-05,1.268206e-04,1.986827e-04, & - &7.720050e-05,9.459531e-05,1.227246e-04,1.782582e-04,2.802690e-04, & - &8.181027e-05,1.000979e-04,1.302268e-04,1.903718e-04,2.999423e-04, & - &6.999768e-05,8.571955e-05,1.121700e-04,1.650597e-04,2.600166e-04/ - data absa(:, 3) / & - &4.422582e-05,5.166974e-05,5.737233e-05,6.861409e-05,9.877741e-05, & - &3.253963e-05,3.784903e-05,4.858660e-05,5.579585e-05,8.874399e-05, & - &2.708112e-05,2.761148e-05,3.416105e-05,5.403187e-05,8.372906e-05, & - &1.742984e-05,2.104990e-05,3.242459e-05,5.477804e-05,8.035092e-05, & - &1.290687e-05,1.834846e-05,3.401157e-05,5.436421e-05,7.967634e-05, & - &1.156283e-05,1.875588e-05,3.405012e-05,5.380777e-05,8.007938e-05, & - &1.120036e-05,2.080499e-05,3.547876e-05,5.676840e-05,8.698874e-05, & - &1.451982e-05,2.538447e-05,4.351571e-05,7.187170e-05,1.140182e-04, & - &3.335806e-05,5.510380e-05,9.636047e-05,1.652805e-04,2.716898e-04, & - &1.045087e-04,1.591489e-04,2.771397e-04,4.876591e-04,8.283343e-04, & - &1.500551e-04,2.315486e-04,4.067523e-04,7.191070e-04,1.226675e-03, & - &1.620229e-04,2.529781e-04,4.476859e-04,7.939661e-04,1.357844e-03, & - &1.413865e-04,2.235889e-04,3.980350e-04,7.076804e-04,1.213398e-03/ - data absa(:, 4) / & - &6.928247e-05,1.313996e-04,2.347988e-04,3.704338e-04,5.209699e-04, & - &5.462622e-05,1.087000e-04,1.952450e-04,3.113485e-04,4.303355e-04, & - &4.807070e-05,1.120559e-04,1.906221e-04,2.780441e-04,3.827335e-04, & - &5.941425e-05,1.135393e-04,1.790291e-04,2.587663e-04,3.599187e-04, & - &5.897629e-05,1.060839e-04,1.650368e-04,2.421035e-04,3.436673e-04, & - &5.265138e-05,9.437329e-05,1.496312e-04,2.266703e-04,3.310965e-04, & - &5.000593e-05,8.886415e-05,1.462770e-04,2.301868e-04,3.482996e-04, & - &5.564543e-05,1.012680e-04,1.748909e-04,2.875874e-04,4.525777e-04, & - &1.123345e-04,2.174135e-04,3.983506e-04,6.911638e-04,1.140754e-03, & - &3.248800e-04,6.572437e-04,1.265953e-03,2.295551e-03,3.916103e-03, & - &5.288859e-04,1.088726e-03,2.117355e-03,3.862093e-03,6.598491e-03, & - &6.349331e-04,1.327965e-03,2.609035e-03,4.769326e-03,8.151694e-03, & - &6.221684e-04,1.317669e-03,2.605457e-03,4.771030e-03,8.160520e-03/ - data absa(:, 5) / & - &8.935952e-04,1.307433e-03,1.819202e-03,2.478178e-03,3.317495e-03, & - &7.490530e-04,1.098252e-03,1.543804e-03,2.121862e-03,2.869832e-03, & - &5.761330e-04,8.474663e-04,1.212740e-03,1.695444e-03,2.322940e-03, & - &4.595986e-04,6.953022e-04,1.016393e-03,1.452265e-03,2.020566e-03, & - &4.105420e-04,6.497180e-04,9.878685e-04,1.446869e-03,2.059232e-03, & - &3.956085e-04,6.547155e-04,1.025681e-03,1.538960e-03,2.225057e-03, & - &3.972669e-04,6.867258e-04,1.111084e-03,1.709587e-03,2.521755e-03, & - &4.518794e-04,8.212140e-04,1.386026e-03,2.210390e-03,3.355883e-03, & - &8.669021e-04,1.688369e-03,3.026860e-03,5.060647e-03,7.977796e-03, & - &2.287121e-03,4.773993e-03,9.055546e-03,1.585199e-02,2.600936e-02, & - &3.670865e-03,7.665385e-03,1.456497e-02,2.552570e-02,4.197622e-02, & - &4.484997e-03,9.339234e-03,1.769914e-02,3.105764e-02,5.119903e-02, & - &4.526780e-03,9.394404e-03,1.775674e-02,3.117920e-02,5.147662e-02/ - data absa(:, 6) / & - &3.580973e-03,5.036787e-03,6.898480e-03,9.228151e-03,1.204128e-02, & - &3.295598e-03,4.616673e-03,6.319691e-03,8.509783e-03,1.123109e-02, & - &2.740431e-03,3.923390e-03,5.420394e-03,7.350215e-03,9.784985e-03, & - &2.167981e-03,3.177776e-03,4.505247e-03,6.221402e-03,8.357402e-03, & - &1.699581e-03,2.545340e-03,3.679717e-03,5.208719e-03,7.152481e-03, & - &1.351426e-03,2.147752e-03,3.321377e-03,4.954104e-03,7.136909e-03, & - &1.384637e-03,2.427120e-03,4.025534e-03,6.334172e-03,9.475598e-03, & - &1.820885e-03,3.394501e-03,5.887656e-03,9.576642e-03,1.469615e-02, & - &4.242280e-03,8.529356e-03,1.561558e-02,2.653422e-02,4.229011e-02, & - &1.297570e-02,2.831745e-02,5.540870e-02,9.877248e-02,1.632193e-01, & - &2.197675e-02,4.784789e-02,9.321329e-02,1.656133e-01,2.732158e-01, & - &2.738240e-02,5.924668e-02,1.147961e-01,2.032796e-01,3.343061e-01, & - &2.725765e-02,5.840847e-02,1.125076e-01,1.984125e-01,3.254102e-01/ - data absa(:, 7) / & - &7.304864e-03,1.014143e-02,1.384549e-02,1.874684e-02,2.493879e-02, & - &7.152347e-03,1.007544e-02,1.387750e-02,1.879999e-02,2.504482e-02, & - &6.460937e-03,9.122360e-03,1.282418e-02,1.755128e-02,2.357295e-02, & - &5.612940e-03,8.012356e-03,1.132614e-02,1.561380e-02,2.136981e-02, & - &4.779465e-03,6.948161e-03,9.919143e-03,1.382732e-02,1.909885e-02, & - &3.934321e-03,5.837779e-03,8.484887e-03,1.199757e-02,1.674177e-02, & - &3.210892e-03,4.965431e-03,7.540846e-03,1.120376e-02,1.633719e-02, & - &3.285873e-03,5.957630e-03,1.022130e-02,1.677389e-02,2.622432e-02, & - &8.044836e-03,1.676312e-02,3.188863e-02,5.617663e-02,9.223573e-02, & - &2.933763e-02,6.591728e-02,1.320931e-01,2.414959e-01,4.083630e-01, & - &5.667280e-02,1.272088e-01,2.546093e-01,4.639621e-01,7.830551e-01, & - &8.078272e-02,1.809250e-01,3.613638e-01,6.559770e-01,1.104601e+00, & - &9.120736e-02,2.036430e-01,4.049680e-01,7.345410e-01,1.233212e+00/ - data absa(:, 8) / & - &1.102713e-02,1.564112e-02,2.231212e-02,3.194325e-02,4.517760e-02, & - &1.144058e-02,1.647143e-02,2.334249e-02,3.318517e-02,4.729151e-02, & - &1.106102e-02,1.598940e-02,2.252407e-02,3.185669e-02,4.439107e-02, & - &1.062727e-02,1.516593e-02,2.181036e-02,3.061644e-02,4.284305e-02, & - &1.016161e-02,1.461066e-02,2.087458e-02,2.920716e-02,4.154366e-02, & - &9.371884e-03,1.380058e-02,1.989407e-02,2.779577e-02,3.937552e-02, & - &8.582459e-03,1.277661e-02,1.883847e-02,2.677023e-02,3.721979e-02, & - &7.939618e-03,1.172714e-02,1.748808e-02,2.559454e-02,3.710943e-02, & - &1.137870e-02,2.372378e-02,4.550710e-02,8.052528e-02,1.330667e-01, & - &4.423530e-02,9.994844e-02,2.011541e-01,3.690346e-01,6.305224e-01, & - &9.177485e-02,2.073796e-01,4.177063e-01,7.679251e-01,1.309616e+00, & - &1.424324e-01,3.212109e-01,6.474087e-01,1.189348e+00,2.026447e+00, & - &1.767419e-01,3.989483e-01,8.034969e-01,1.476755e+00,2.512328e+00/ - -! the array selfref contains the coefficient of the water vapor -! self-continuum (including the energy term). the first index -! refers to temperature in 7.2 degree increments. for instance, -! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, -! etc. the second index runs over the g-channel (1 to NG06=8). - - data selfref(:, 1) / & - &8.049306e-02,6.732363e-02,5.630941e-02,4.709759e-02,3.939306e-02, & - &3.294923e-02,2.755970e-02,2.305195e-02,1.928169e-02,1.612819e-02/ - data selfref(:, 2) / & - &9.056965e-02,7.667617e-02,6.491424e-02,5.495688e-02,4.652711e-02, & - &3.939067e-02,3.334892e-02,2.823407e-02,2.390376e-02,2.023777e-02/ - data selfref(:, 3) / & - &8.668766e-02,7.538429e-02,6.557451e-02,5.705851e-02,4.966354e-02, & - &4.324012e-02,3.765892e-02,3.280820e-02,2.859099e-02,2.492354e-02/ - data selfref(:, 4) / & - &7.397816e-02,6.603496e-02,5.895270e-02,5.263726e-02,4.700474e-02, & - &4.198067e-02,3.749864e-02,3.349967e-02,2.993115e-02,2.674636e-02/ - data selfref(:, 5) / & - &7.174100e-02,6.352840e-02,5.625628e-02,4.981671e-02,4.411457e-02, & - &3.906528e-02,3.459404e-02,3.063478e-02,2.712874e-02,2.402400e-02/ - data selfref(:, 6) / & - &8.889431e-02,7.691418e-02,6.655024e-02,5.758423e-02,4.982740e-02, & - &4.311657e-02,3.731044e-02,3.228702e-02,2.794064e-02,2.417995e-02/ - data selfref(:, 7) / & - &9.331387e-02,7.985839e-02,6.834511e-02,5.849348e-02,5.006340e-02, & - &4.284954e-02,3.667622e-02,3.139323e-02,2.687205e-02,2.300261e-02/ - data selfref(:, 8) / & - &8.963833e-02,7.716894e-02,6.643733e-02,5.720083e-02,4.925098e-02, & - &4.240815e-02,3.651789e-02,3.144742e-02,2.708243e-02,2.332457e-02/ - - data absco2 / & - &6.877158e-05,7.009324e-05,9.900422e-05,5.945354e-04,1.431677e-03, & - &2.812699e-04,7.357499e-05,4.786956e-05 / - - data cfc11adj / & - &0.000000e+00,9.159319e+01,7.840118e+01,5.366473e+01,5.799243e+01, & - &1.005060e+02,1.678709e+02,2.365097e+02 / - - data cfc12 / & - &5.316576e+01,2.458744e+01,2.874905e+01,2.494402e+01,1.796895e+01, & - &2.334803e+01,2.859035e+01,2.096531e+01 / - - data fracrefa / & - & 0.2799854875, 0.2758025527, 0.2359785736, 0.1487121433, & - & 0.0478294492, 0.0072561502, 0.0038013197, 0.0006346800 / - -!........................................! - end module module_radlw_kgb06 ! -!========================================! - - - -!========================================! - module module_radlw_kgb07 ! -!........................................! -! - use machine, only : kind_phys - use module_radlw_parameters, only : NG07 -! - implicit none -! - private -! - integer, public :: MSA07, MSB07, MSF07, MAF07 - parameter (MSA07=585, MSB07=235, MSF07=10, MAF07=9) - - real (kind=kind_phys), public :: & - & absa(MSA07,NG07), absb(MSB07,NG07), selfref(MSF07,NG07), & - & absco2(NG07), fracrefa(NG07,MAF07), fracrefb(NG07) - -! the array absa(585,NG07) = ka(9,5,13) contains absorption coefs at -! the NG07=12 chosen g-values for a range of pressure levels> ~100mb, -! temperatures, and binary species parameters (see taumol.f for -! definition). the first index in the array, js, runs from 1 to 9, -! and corresponds to different values of the binary species parameter. -! for instance, js=1 refers to dry air, js = 2 corresponds to the -! paramter value 1/8, js = 3 corresponds to the parameter value 2/8, -! etc. the second index in the array, jt, which runs from 1 to 5, -! corresponds to different temperatures. more specifically, jt = 1-5 -! means that the data are for the corresponding temperature of tref-30, -! tref-15, tref, tref+15, and tref+30, respectively. the third index, -! jp, runs from 1 to 13 and refers to the jpth reference pressure level -! (see taumol.f for these levels in mb). the fourth index, ig, goes -! from 1 to NG07=12, and indicates which g-interval the absorption -! coefficients are for. - - data absa(1:270,1) / & - &3.797442e-05,3.588206e-05,3.261211e-05,2.881163e-05,2.487416e-05, & - &2.156274e-05,2.649052e-05,4.395016e-05,2.229981e-05,4.826946e-05, & - &4.590654e-05,4.177186e-05,3.694290e-05,3.172556e-05,2.640780e-05, & - &2.336514e-05,4.536869e-05,2.356067e-05,5.979502e-05,5.725575e-05, & - &5.218432e-05,4.627011e-05,3.983828e-05,3.299177e-05,2.670113e-05, & - &4.058130e-05,2.204060e-05,7.235874e-05,6.976466e-05,6.385402e-05, & - &5.685278e-05,4.915662e-05,4.091686e-05,3.226702e-05,2.899790e-05, & - &2.436296e-05,8.570560e-05,8.328310e-05,7.662451e-05,6.858861e-05, & - &5.956750e-05,4.968985e-05,3.891427e-05,2.828318e-05,2.140017e-05, & - &2.990644e-05,2.830257e-05,2.571955e-05,2.280819e-05,1.986821e-05, & - &1.789177e-05,2.685938e-05,3.900430e-05,1.648268e-05,3.843905e-05, & - &3.660741e-05,3.335283e-05,2.961178e-05,2.550471e-05,2.154821e-05, & - &2.149431e-05,4.021067e-05,1.649802e-05,4.803645e-05,4.610169e-05, & - &4.214798e-05,3.745074e-05,3.221837e-05,2.676209e-05,2.229115e-05, & - &4.014922e-05,1.817477e-05,5.861797e-05,5.665023e-05,5.193573e-05, & - &4.627259e-05,3.994809e-05,3.315721e-05,2.636620e-05,2.969731e-05, & - &1.700929e-05,6.995288e-05,6.817764e-05,6.270398e-05,5.609784e-05, & - &4.863369e-05,4.045539e-05,3.164944e-05,2.457966e-05,1.513436e-05, & - &2.180275e-05,2.065642e-05,1.876768e-05,1.672260e-05,1.487487e-05, & - &1.580148e-05,3.166660e-05,3.481015e-05,1.195809e-05,2.843111e-05, & - &2.711514e-05,2.469491e-05,2.198833e-05,1.910247e-05,1.689963e-05, & - &2.337859e-05,3.612274e-05,1.253872e-05,3.603604e-05,3.459129e-05, & - &3.162426e-05,2.818817e-05,2.435781e-05,2.056065e-05,1.932554e-05, & - &3.683832e-05,1.194559e-05,4.448753e-05,4.305180e-05,3.950140e-05, & - &3.525200e-05,3.048325e-05,2.548423e-05,2.087049e-05,3.521331e-05, & - &1.048383e-05,5.370415e-05,5.238746e-05,4.825602e-05,4.320074e-05, & - &3.750229e-05,3.126641e-05,2.467423e-05,2.517992e-05,1.209951e-05, & - &1.565542e-05,1.482780e-05,1.346721e-05,1.209856e-05,1.150080e-05, & - &1.659190e-05,3.556118e-05,3.102005e-05,8.443816e-06,2.065868e-05, & - &1.972396e-05,1.794322e-05,1.600133e-05,1.415480e-05,1.437344e-05, & - &2.781834e-05,3.200644e-05,7.878662e-06,2.652763e-05,2.547627e-05, & - &2.326477e-05,2.074824e-05,1.805563e-05,1.586357e-05,2.080500e-05, & - &3.314964e-05,6.553312e-06,3.314861e-05,3.207360e-05,2.944126e-05, & - &2.631532e-05,2.284125e-05,1.932061e-05,1.769997e-05,3.358608e-05, & - &8.064609e-06,4.046706e-05,3.949993e-05,3.640479e-05,3.264933e-05, & - &2.835842e-05,2.372478e-05,1.930086e-05,3.096585e-05,1.124919e-05, & - &1.128013e-05,1.067833e-05,9.729265e-06,8.968114e-06,1.041850e-05, & - &1.983699e-05,3.392860e-05,2.711660e-05,5.284504e-06,1.503295e-05, & - &1.435289e-05,1.306124e-05,1.175144e-05,1.097121e-05,1.476012e-05, & - &3.145326e-05,2.940874e-05,3.988411e-06,1.949343e-05,1.873424e-05, & - &1.709562e-05,1.526498e-05,1.351748e-05,1.329244e-05,2.498435e-05, & - &2.973681e-05,4.892224e-06,2.461897e-05,2.382780e-05,2.184122e-05, & - &1.952959e-05,1.705647e-05,1.492437e-05,1.858069e-05,3.019953e-05, & - &7.217594e-06,3.034295e-05,2.963028e-05,2.729431e-05,2.448169e-05, & - &2.134658e-05,1.804019e-05,1.633912e-05,3.051395e-05,1.070995e-05, & - &8.089755e-06,7.661592e-06,7.050070e-06,7.147987e-06,1.177090e-05, & - &2.581339e-05,3.090332e-05,2.470302e-05,2.822097e-06,1.089870e-05, & - &1.040109e-05,9.476518e-06,8.749982e-06,9.627013e-06,1.869886e-05, & - &3.118434e-05,2.625220e-05,2.708387e-06,1.426936e-05,1.371817e-05, & - &1.252061e-05,1.127339e-05,1.044691e-05,1.379519e-05,2.844289e-05, & - &2.734399e-05,4.037631e-06,1.818496e-05,1.760122e-05,1.611833e-05, & - &1.444574e-05,1.277511e-05,1.251469e-05,2.318428e-05,2.741344e-05, & - &6.418464e-06,2.262302e-05,2.208345e-05,2.031713e-05,1.821857e-05, & - &1.595589e-05,1.394887e-05,1.724456e-05,2.768927e-05,9.928696e-06/ - data absa(271:585,1) / & - &5.876813e-06,5.567656e-06,5.284312e-06,7.457573e-06,1.512563e-05, & - &2.829333e-05,2.902506e-05,2.487813e-05,1.621989e-06,8.001270e-06, & - &7.626226e-06,7.005730e-06,6.953498e-06,1.103093e-05,2.390192e-05, & - &2.861879e-05,2.343194e-05,2.161325e-06,1.057569e-05,1.015533e-05, & - &9.274105e-06,8.513878e-06,9.120475e-06,1.754972e-05,2.823703e-05, & - &2.515131e-05,3.614347e-06,1.360347e-05,1.316332e-05,1.202975e-05, & - &1.083278e-05,1.000261e-05,1.323303e-05,2.560490e-05,2.520390e-05, & - &6.011639e-06,1.704460e-05,1.664330e-05,1.527540e-05,1.371316e-05, & - &1.214046e-05,1.182271e-05,2.163246e-05,2.550608e-05,9.628962e-06, & - &4.318581e-06,4.105888e-06,4.398525e-06,8.965264e-06,1.946902e-05, & - &2.931613e-05,2.848988e-05,2.615915e-05,1.364833e-06,5.925547e-06, & - &5.649534e-06,5.347028e-06,7.166586e-06,1.486892e-05,2.691415e-05, & - &2.738006e-05,2.336988e-05,2.207597e-06,7.882367e-06,7.571608e-06, & - &6.965846e-06,6.881788e-06,1.091130e-05,2.290651e-05,2.668953e-05, & - &2.247011e-05,3.823293e-06,1.021532e-05,9.881947e-06,9.034798e-06, & - &8.304309e-06,8.861163e-06,1.734064e-05,2.583686e-05,2.393778e-05, & - &6.561017e-06,1.290271e-05,1.258584e-05,1.152595e-05,1.040456e-05, & - &9.650767e-06,1.299682e-05,2.370660e-05,2.377706e-05,1.085734e-05, & - &3.231009e-06,3.107881e-06,5.208809e-06,1.143946e-05,2.453190e-05, & - &2.830627e-05,2.594776e-05,2.618276e-05,2.820817e-06,4.448252e-06, & - &4.252191e-06,4.464349e-06,8.859231e-06,1.981287e-05,2.694134e-05, & - &2.670432e-05,2.495059e-05,4.285450e-06,5.956947e-06,5.716630e-06, & - &5.423632e-06,6.979619e-06,1.470358e-05,2.504420e-05,2.576099e-05, & - &2.196375e-05,7.217760e-06,7.768673e-06,7.511124e-06,6.912744e-06, & - &6.815500e-06,1.096530e-05,2.164177e-05,2.477106e-05,2.165884e-05, & - &1.251567e-05,9.881151e-06,9.628093e-06,8.808332e-06,8.112991e-06, & - &8.777472e-06,1.697702e-05,2.360308e-05,2.248344e-05,2.133796e-05, & - &2.514077e-06,2.529430e-06,6.239200e-06,1.655234e-05,2.675701e-05, & - &2.828295e-05,2.487967e-05,2.615342e-05,8.946715e-06,3.461942e-06, & - &3.337136e-06,5.266393e-06,1.195831e-05,2.379718e-05,2.661525e-05, & - &2.498433e-05,2.555881e-05,1.207577e-05,4.643499e-06,4.461950e-06, & - &4.666435e-06,9.164633e-06,1.983962e-05,2.514256e-05,2.552510e-05, & - &2.354530e-05,1.899039e-05,6.071807e-06,5.870198e-06,5.558439e-06, & - &7.065301e-06,1.524152e-05,2.355251e-05,2.454227e-05,2.119016e-05, & - &3.227623e-05,7.747106e-06,7.548793e-06,6.959903e-06,6.895690e-06, & - &1.133649e-05,2.054342e-05,2.321182e-05,2.108275e-05,5.554767e-05, & - &2.307112e-06,2.455476e-06,7.007823e-06,1.915502e-05,2.540488e-05, & - &2.734179e-05,2.474547e-05,2.555193e-05,1.250350e-05,3.150005e-06, & - &3.077183e-06,5.785388e-06,1.445252e-05,2.382474e-05,2.561776e-05, & - &2.333232e-05,2.525575e-05,1.674411e-05,4.190455e-06,4.047334e-06, & - &4.754227e-06,1.079360e-05,2.068821e-05,2.389230e-05,2.401397e-05, & - &2.353396e-05,2.617355e-05,5.443986e-06,5.266857e-06,5.146562e-06, & - &8.181343e-06,1.727890e-05,2.259856e-05,2.323388e-05,2.076775e-05, & - &4.434948e-05,6.898622e-06,6.727420e-06,6.258112e-06,6.746679e-06, & - &1.339039e-05,2.042456e-05,2.226478e-05,1.986160e-05,7.614024e-05, & - &2.126746e-06,2.361025e-06,7.015403e-06,1.821782e-05,2.313323e-05, & - &2.498571e-05,2.283714e-05,2.376107e-05,1.317803e-05,2.890491e-06, & - &2.851741e-06,5.668531e-06,1.452065e-05,2.164249e-05,2.331966e-05, & - &2.123103e-05,2.329581e-05,1.762588e-05,3.832492e-06,3.705597e-06, & - &4.548405e-06,1.095254e-05,1.929353e-05,2.177418e-05,2.172302e-05, & - &2.151386e-05,2.751366e-05,4.955201e-06,4.790729e-06,4.735784e-06, & - &8.181602e-06,1.655111e-05,2.040121e-05,2.116341e-05,1.900179e-05, & - &4.654867e-05,6.255335e-06,6.086811e-06,5.695298e-06,6.461968e-06, & - &1.306709e-05,1.873805e-05,2.019796e-05,1.812926e-05,7.983450e-05, & - &1.947568e-06,2.275607e-06,7.341002e-06,1.719716e-05,2.114330e-05, & - &2.258414e-05,2.113261e-05,2.192417e-05,1.123106e-05,2.638120e-06, & - &2.632801e-06,5.650225e-06,1.427238e-05,1.949373e-05,2.119603e-05, & - &1.919521e-05,2.131094e-05,1.503896e-05,3.486643e-06,3.372368e-06, & - &4.398616e-06,1.102497e-05,1.782695e-05,1.984098e-05,1.960150e-05, & - &1.963670e-05,2.349419e-05,4.487680e-06,4.336960e-06,4.401948e-06, & - &8.299497e-06,1.548218e-05,1.857531e-05,1.911999e-05,1.732929e-05, & - &3.973881e-05,5.640286e-06,5.483781e-06,5.180170e-06,6.423327e-06, & - &1.273637e-05,1.717371e-05,1.815586e-05,1.641274e-05,6.813168e-05/ - data absa(1:270,2) / & - &1.477643e-04,1.385741e-04,1.255116e-04,1.110525e-04,9.479215e-05, & - &7.643653e-05,5.007360e-05,5.672139e-05,3.392024e-05,1.641730e-04, & - &1.554062e-04,1.418959e-04,1.260866e-04,1.084715e-04,8.887066e-05, & - &6.522929e-05,4.491522e-05,3.442622e-05,1.804824e-04,1.728627e-04, & - &1.590225e-04,1.421474e-04,1.229800e-04,1.016110e-04,7.636626e-05, & - &3.840220e-05,3.215274e-05,1.972947e-04,1.914764e-04,1.770938e-04, & - &1.591437e-04,1.384325e-04,1.147686e-04,8.747802e-05,5.263475e-05, & - &2.816111e-05,2.150967e-04,2.112763e-04,1.964161e-04,1.775048e-04, & - &1.552740e-04,1.293812e-04,9.995273e-05,6.611079e-05,4.090409e-05, & - &1.317208e-04,1.233347e-04,1.112809e-04,9.781218e-05,8.285162e-05, & - &6.578924e-05,3.957942e-05,5.731834e-05,2.408978e-05,1.460524e-04, & - &1.379341e-04,1.253838e-04,1.106849e-04,9.457447e-05,7.666307e-05, & - &5.405075e-05,4.979073e-05,2.521756e-05,1.602610e-04,1.529689e-04, & - &1.398706e-04,1.242308e-04,1.068676e-04,8.774021e-05,6.545900e-05, & - &3.408049e-05,1.952222e-05,1.747775e-04,1.687549e-04,1.551094e-04, & - &1.386173e-04,1.199733e-04,9.925922e-05,7.532287e-05,4.162867e-05, & - &2.470793e-05,1.899615e-04,1.854766e-04,1.715313e-04,1.541226e-04, & - &1.341955e-04,1.116639e-04,8.596217e-05,5.463006e-05,3.832864e-05, & - &1.138991e-04,1.064672e-04,9.571569e-05,8.359509e-05,7.008435e-05, & - &5.291771e-05,3.347575e-05,5.913489e-05,1.522890e-05,1.262333e-04, & - &1.190153e-04,1.076115e-04,9.439682e-05,7.996392e-05,6.367859e-05, & - &3.920855e-05,5.201728e-05,1.368231e-05,1.385190e-04,1.317850e-04, & - &1.197700e-04,1.056477e-04,9.021284e-05,7.322604e-05,5.265880e-05, & - &4.275603e-05,1.627594e-05,1.508297e-04,1.449972e-04,1.324042e-04, & - &1.174842e-04,1.010650e-04,8.293556e-05,6.238429e-05,3.105788e-05, & - &2.670191e-05,1.634939e-04,1.586497e-04,1.457103e-04,1.301277e-04, & - &1.126625e-04,9.330014e-05,7.128784e-05,4.104447e-05,3.878691e-05, & - &9.789674e-05,9.107176e-05,8.174994e-05,7.099961e-05,5.849144e-05, & - &3.988445e-05,3.666701e-05,5.896401e-05,9.386325e-06,1.084976e-04, & - &1.020164e-04,9.190694e-05,8.016379e-05,6.725602e-05,5.152945e-05, & - &2.975829e-05,5.582486e-05,1.055567e-05,1.190759e-04,1.131045e-04, & - &1.022404e-04,8.964850e-05,7.588853e-05,6.063654e-05,3.819427e-05, & - &4.807758e-05,1.892888e-05,1.297175e-04,1.243961e-04,1.128888e-04, & - &9.948479e-05,8.488295e-05,6.892344e-05,5.003059e-05,3.675193e-05, & - &2.884727e-05,1.404374e-04,1.358134e-04,1.239408e-04,1.098877e-04, & - &9.441441e-05,7.758445e-05,5.867270e-05,2.944499e-05,4.089926e-05, & - &8.409654e-05,7.776435e-05,6.956966e-05,6.001109e-05,4.738599e-05, & - &2.798255e-05,4.979558e-05,5.935577e-05,6.425658e-06,9.319097e-05, & - &8.714062e-05,7.835132e-05,6.796449e-05,5.621846e-05,3.964802e-05, & - &3.340922e-05,5.641319e-05,1.211190e-05,1.023181e-04,9.690435e-05, & - &8.728560e-05,7.611483e-05,6.388147e-05,4.946344e-05,2.650784e-05, & - &5.185395e-05,1.982571e-05,1.113899e-04,1.066809e-04,9.632909e-05, & - &8.444110e-05,7.150709e-05,5.723996e-05,3.693422e-05,4.511226e-05, & - &3.000871e-05,1.205591e-04,1.163484e-04,1.055753e-04,9.308277e-05, & - &7.938880e-05,6.459907e-05,4.724311e-05,3.322857e-05,4.338947e-05, & - &7.194713e-05,6.607663e-05,5.873319e-05,4.992957e-05,3.601066e-05, & - &2.593352e-05,6.507566e-05,6.043248e-05,6.367448e-06,7.976939e-05, & - &7.415709e-05,6.642948e-05,5.729229e-05,4.576241e-05,2.691781e-05, & - &4.479257e-05,5.719364e-05,1.188175e-05,8.759552e-05,8.248024e-05, & - &7.416304e-05,6.430013e-05,5.333764e-05,3.782755e-05,3.023461e-05, & - &5.414010e-05,1.960721e-05,9.533926e-05,9.097437e-05,8.192376e-05, & - &7.142242e-05,6.003718e-05,4.650563e-05,2.494418e-05,4.937409e-05, & - &3.042107e-05,1.031369e-04,9.938147e-05,8.972926e-05,7.868645e-05, & - &6.663343e-05,5.343067e-05,3.482259e-05,4.199804e-05,4.520691e-05/ - data absa(271:585,2) / & - &6.133033e-05,5.593427e-05,4.933089e-05,3.967292e-05,2.477367e-05, & - &3.501711e-05,7.445367e-05,5.855061e-05,6.399614e-06,6.824976e-05, & - &6.308360e-05,5.618812e-05,4.790055e-05,3.498794e-05,2.491571e-05, & - &5.770352e-05,5.919924e-05,1.202033e-05,7.500408e-05,7.018886e-05, & - &6.290894e-05,5.427751e-05,4.370458e-05,2.594982e-05,4.113010e-05, & - &5.541177e-05,2.045385e-05,8.171887e-05,7.747181e-05,6.963419e-05, & - &6.043436e-05,5.019530e-05,3.552476e-05,2.790460e-05,5.200531e-05, & - &3.281357e-05,8.842870e-05,8.476359e-05,7.636034e-05,6.662532e-05, & - &5.600671e-05,4.354029e-05,2.312034e-05,4.596494e-05,5.019980e-05, & - &5.197070e-05,4.710248e-05,4.087233e-05,2.995396e-05,2.364466e-05, & - &5.046110e-05,8.259819e-05,5.574993e-05,7.491141e-06,5.807063e-05, & - &5.335517e-05,4.713903e-05,3.823456e-05,2.393364e-05,3.385118e-05, & - &6.837811e-05,5.853462e-05,1.427363e-05,6.398183e-05,5.952414e-05, & - &5.307166e-05,4.524780e-05,3.302477e-05,2.386030e-05,5.339534e-05, & - &5.755306e-05,2.535332e-05,6.982920e-05,6.578382e-05,5.894645e-05, & - &5.088788e-05,4.103628e-05,2.392352e-05,3.934935e-05,5.302119e-05, & - &4.227973e-05,7.557364e-05,7.203766e-05,6.479987e-05,5.630666e-05, & - &4.675360e-05,3.287168e-05,2.645293e-05,4.915344e-05,6.684610e-05, & - &4.398521e-05,3.960446e-05,3.230240e-05,2.123170e-05,3.101245e-05, & - &6.673099e-05,9.099618e-05,5.429352e-05,1.558565e-05,4.917784e-05, & - &4.487696e-05,3.905596e-05,2.871107e-05,2.242091e-05,4.809834e-05, & - &7.590278e-05,5.668993e-05,3.090080e-05,5.445072e-05,5.036319e-05, & - &4.453543e-05,3.629989e-05,2.250031e-05,3.332754e-05,6.209570e-05, & - &5.835260e-05,5.744731e-05,5.953713e-05,5.574840e-05,4.972204e-05, & - &4.240021e-05,3.054801e-05,2.308476e-05,4.986204e-05,5.487227e-05, & - &1.000075e-04,6.454672e-05,6.110803e-05,5.480708e-05,4.738342e-05, & - &3.809236e-05,2.200906e-05,3.719875e-05,5.125874e-05,1.641360e-04, & - &3.739505e-05,3.342319e-05,2.522163e-05,2.050355e-05,4.532313e-05, & - &7.994479e-05,9.775039e-05,5.330399e-05,4.126432e-05,4.181317e-05, & - &3.793306e-05,3.110228e-05,2.012476e-05,3.118097e-05,6.279285e-05, & - &8.497505e-05,5.540924e-05,8.421080e-05,4.643216e-05,4.269110e-05, & - &3.722263e-05,2.712058e-05,2.251373e-05,4.740958e-05,6.997810e-05, & - &5.702281e-05,1.629610e-04,5.088875e-05,4.739014e-05,4.196394e-05, & - &3.422032e-05,2.066833e-05,3.407566e-05,5.666153e-05,5.750795e-05, & - &2.948864e-04,5.523820e-05,5.199973e-05,4.643942e-05,3.963487e-05, & - &2.808206e-05,2.323377e-05,4.703412e-05,5.348984e-05,5.005132e-04, & - &3.344251e-05,2.976899e-05,2.131134e-05,2.290741e-05,5.250219e-05, & - &8.115802e-05,9.601351e-05,5.372833e-05,5.821329e-05,3.735643e-05, & - &3.385912e-05,2.676534e-05,1.734152e-05,3.646800e-05,6.469457e-05, & - &8.418591e-05,5.549779e-05,1.189729e-04,4.135797e-05,3.801790e-05, & - &3.258079e-05,2.186423e-05,2.593233e-05,5.127526e-05,6.931856e-05, & - &5.637002e-05,2.307109e-04,4.525044e-05,4.211439e-05,3.710998e-05, & - &2.857681e-05,1.866980e-05,3.857554e-05,5.703907e-05,5.658156e-05, & - &4.182899e-04,4.906741e-05,4.614265e-05,4.114052e-05,3.458059e-05, & - &2.197303e-05,2.789580e-05,4.707060e-05,5.326718e-05,7.114311e-04, & - &2.982718e-05,2.643922e-05,1.837134e-05,2.304196e-05,5.021085e-05, & - &7.402181e-05,8.990752e-05,5.421666e-05,6.196222e-05,3.330418e-05, & - &3.015819e-05,2.343371e-05,1.670366e-05,3.621855e-05,5.924810e-05, & - &7.754901e-05,5.497715e-05,1.267746e-04,3.684063e-05,3.384530e-05, & - &2.874973e-05,1.840769e-05,2.579912e-05,4.761334e-05,6.311922e-05, & - &5.569479e-05,2.460823e-04,4.029685e-05,3.746333e-05,3.292622e-05, & - &2.457627e-05,1.820209e-05,3.663252e-05,5.184315e-05,5.444191e-05, & - &4.466842e-04,4.369753e-05,4.104002e-05,3.653166e-05,3.035791e-05, & - &1.874370e-05,2.749899e-05,4.308169e-05,5.011063e-05,7.597063e-04, & - &2.645236e-05,2.331562e-05,1.535540e-05,2.301164e-05,4.745115e-05, & - &6.783127e-05,8.294990e-05,5.461122e-05,5.324430e-05,2.954381e-05, & - &2.671628e-05,2.025170e-05,1.642891e-05,3.551400e-05,5.473334e-05, & - &7.100077e-05,5.464859e-05,1.090519e-04,3.267398e-05,2.999865e-05, & - &2.518923e-05,1.546825e-05,2.545697e-05,4.403159e-05,5.747176e-05, & - &5.371689e-05,2.118322e-04,3.574793e-05,3.318588e-05,2.902949e-05, & - &2.084327e-05,1.839022e-05,3.454894e-05,4.745186e-05,5.195267e-05, & - &3.844803e-04,3.882063e-05,3.641110e-05,3.232449e-05,2.626799e-05, & - &1.606687e-05,2.622592e-05,3.970559e-05,4.690641e-05,6.533504e-04/ - data absa(1:270,3) / & - &2.777800e-04,2.552100e-04,2.268500e-04,1.959100e-04,1.633200e-04, & - &1.287900e-04,9.059600e-05,4.404300e-05,3.234600e-05,2.906600e-04, & - &2.698700e-04,2.407700e-04,2.093200e-04,1.757700e-04,1.404800e-04, & - &1.029400e-04,3.880900e-05,2.942600e-05,3.054400e-04,2.861600e-04, & - &2.575400e-04,2.252500e-04,1.910100e-04,1.545500e-04,1.167800e-04, & - &5.717300e-05,3.395400e-05,3.218400e-04,3.052500e-04,2.770700e-04, & - &2.444100e-04,2.093200e-04,1.723900e-04,1.343000e-04,8.943200e-05, & - &5.930700e-05,3.399700e-04,3.276800e-04,2.997100e-04,2.668500e-04, & - &2.315800e-04,1.953700e-04,1.565000e-04,1.130000e-04,9.145800e-05, & - &2.603600e-04,2.384900e-04,2.121500e-04,1.832500e-04,1.523800e-04, & - &1.197800e-04,8.166600e-05,4.429500e-05,2.449600e-05,2.714700e-04, & - &2.514100e-04,2.243900e-04,1.946200e-04,1.627100e-04,1.292500e-04, & - &9.297300e-05,3.250000e-05,1.952800e-05,2.840700e-04,2.654800e-04, & - &2.384600e-04,2.075900e-04,1.752400e-04,1.405400e-04,1.039600e-04, & - &4.539500e-05,3.343100e-05,2.971900e-04,2.812800e-04,2.542300e-04, & - &2.232000e-04,1.899600e-04,1.540000e-04,1.166800e-04,6.958400e-05, & - &5.749000e-05,3.112200e-04,2.987000e-04,2.722000e-04,2.410000e-04, & - &2.064900e-04,1.703500e-04,1.326600e-04,9.199900e-05,8.300000e-05, & - &2.405000e-04,2.190000e-04,1.950100e-04,1.685900e-04,1.400500e-04, & - &1.094700e-04,5.441600e-05,3.569500e-05,1.325000e-05,2.498000e-04, & - &2.302400e-04,2.060000e-04,1.783900e-04,1.485700e-04,1.172300e-04, & - &8.222200e-05,4.375600e-05,1.977800e-05,2.598600e-04,2.424000e-04, & - &2.177600e-04,1.890700e-04,1.583100e-04,1.259400e-04,9.115600e-05, & - &3.228400e-05,3.834300e-05,2.705000e-04,2.552800e-04,2.302700e-04, & - &2.010500e-04,1.697300e-04,1.362800e-04,1.011000e-04,4.688500e-05, & - &5.963000e-05,2.815100e-04,2.694900e-04,2.444000e-04,2.147800e-04, & - &1.824600e-04,1.482200e-04,1.129600e-04,7.046300e-05,8.254200e-05, & - &2.216700e-04,2.005400e-04,1.775500e-04,1.534600e-04,1.276000e-04, & - &9.887300e-05,4.072000e-05,3.607600e-05,1.082000e-05,2.294900e-04, & - &2.099100e-04,1.879200e-04,1.631800e-04,1.354600e-04,1.061200e-04, & - &6.117800e-05,4.066700e-05,2.568300e-05,2.380700e-04,2.206100e-04, & - &1.987000e-04,1.722400e-04,1.436100e-04,1.134500e-04,8.017000e-05, & - &3.994000e-05,4.261000e-05,2.466200e-04,2.318100e-04,2.090500e-04, & - &1.820200e-04,1.526800e-04,1.218600e-04,8.874900e-05,3.289300e-05, & - &6.183000e-05,2.554600e-04,2.434200e-04,2.202200e-04,1.928100e-04, & - &1.631300e-04,1.312500e-04,9.812400e-05,4.697300e-05,8.608400e-05, & - &2.031200e-04,1.830000e-04,1.609500e-04,1.387200e-04,1.151000e-04, & - &8.673800e-05,4.389200e-05,4.115500e-05,1.461000e-05,2.103200e-04, & - &1.915300e-04,1.704500e-04,1.481800e-04,1.231000e-04,9.512000e-05, & - &3.753000e-05,4.010900e-05,2.795600e-05,2.175400e-04,2.001300e-04, & - &1.804800e-04,1.568300e-04,1.303600e-04,1.021200e-04,6.555900e-05, & - &4.464600e-05,4.399000e-05,2.250600e-04,2.100800e-04,1.899200e-04, & - &1.651200e-04,1.378700e-04,1.093300e-04,7.787800e-05,3.394100e-05, & - &6.463800e-05,2.323800e-04,2.204000e-04,1.993600e-04,1.740300e-04, & - &1.464900e-04,1.172100e-04,8.574500e-05,3.194300e-05,9.148600e-05, & - &1.842000e-04,1.652100e-04,1.448700e-04,1.240100e-04,1.020000e-04, & - &5.111900e-05,5.276400e-05,4.091200e-05,1.520200e-05,1.912500e-04, & - &1.734400e-04,1.533100e-04,1.327400e-04,1.103900e-04,8.304000e-05, & - &4.068400e-05,4.119800e-05,2.786700e-05,1.973500e-04,1.808000e-04, & - &1.619900e-04,1.409700e-04,1.172700e-04,9.093200e-05,3.718000e-05, & - &4.349500e-05,4.455300e-05,2.038300e-04,1.889400e-04,1.707300e-04, & - &1.487600e-04,1.239800e-04,9.775300e-05,6.312100e-05,4.127700e-05, & - &6.731500e-05,2.103300e-04,1.980400e-04,1.795100e-04,1.565500e-04, & - &1.314600e-04,1.045400e-04,7.446200e-05,2.906700e-05,9.738200e-05/ - data absa(271:585,3) / & - &1.670100e-04,1.491200e-04,1.304200e-04,1.110100e-04,8.947600e-05, & - &4.071000e-05,6.085500e-05,4.011600e-05,1.664400e-05,1.726700e-04, & - &1.555700e-04,1.371800e-04,1.178600e-04,9.704900e-05,4.992800e-05, & - &4.878700e-05,4.506200e-05,2.955600e-05,1.783700e-04,1.626300e-04, & - &1.446900e-04,1.254500e-04,1.041600e-04,7.862000e-05,3.642500e-05, & - &4.079600e-05,4.876000e-05,1.837800e-04,1.695600e-04,1.523500e-04, & - &1.326700e-04,1.106300e-04,8.625400e-05,3.285100e-05,4.062000e-05, & - &7.605500e-05,1.894400e-04,1.772400e-04,1.602100e-04,1.400100e-04, & - &1.173300e-04,9.283000e-05,6.106500e-05,3.808100e-05,1.131200e-04, & - &1.513000e-04,1.344800e-04,1.172100e-04,9.903400e-05,5.715500e-05, & - &4.577500e-05,6.541800e-05,3.634800e-05,2.048300e-05,1.549200e-04, & - &1.387400e-04,1.219900e-04,1.040600e-04,8.330100e-05,3.777600e-05, & - &5.852500e-05,4.365700e-05,3.768300e-05,1.601500e-04,1.450400e-04, & - &1.285500e-04,1.107700e-04,9.085700e-05,4.675200e-05,4.382200e-05, & - &4.590000e-05,6.448000e-05,1.648500e-04,1.513100e-04,1.352200e-04, & - &1.173100e-04,9.758400e-05,7.394000e-05,3.276600e-05,4.453700e-05, & - &1.039700e-04,1.697400e-04,1.579100e-04,1.419500e-04,1.238100e-04, & - &1.039000e-04,8.115000e-05,3.201200e-05,4.155500e-05,1.593600e-04, & - &1.356400e-04,1.201200e-04,1.042200e-04,8.657100e-05,3.456100e-05, & - &5.535800e-05,6.813800e-05,3.399600e-05,4.516200e-05,1.389100e-04, & - &1.238500e-04,1.084300e-04,9.166400e-05,5.099200e-05,4.238600e-05, & - &6.580600e-05,4.048500e-05,8.751700e-05,1.428900e-04,1.285900e-04, & - &1.135500e-04,9.715700e-05,7.746900e-05,3.460400e-05,5.569700e-05, & - &4.678100e-05,1.566000e-04,1.474900e-04,1.344900e-04,1.196500e-04, & - &1.033200e-04,8.503800e-05,4.348700e-05,3.908700e-05,4.763100e-05, & - &2.623200e-04,1.517500e-04,1.404800e-04,1.256600e-04,1.092500e-04, & - &9.121600e-05,6.902700e-05,3.057000e-05,4.281800e-05,4.157800e-04, & - &1.205000e-04,1.064400e-04,9.189500e-05,5.422300e-05,4.228200e-05, & - &7.166200e-05,7.384900e-05,3.121600e-05,1.233600e-04,1.238500e-04, & - &1.100700e-04,9.588500e-05,7.907400e-05,3.278500e-05,5.179000e-05, & - &7.033000e-05,3.810600e-05,2.491400e-04,1.270100e-04,1.138900e-04, & - &1.000900e-04,8.485900e-05,4.369700e-05,3.851500e-05,6.456300e-05, & - &4.685700e-05,4.635300e-04,1.310800e-04,1.188900e-04,1.054700e-04, & - &9.038200e-05,7.181100e-05,3.184600e-05,5.307600e-05,4.933400e-05, & - &8.027300e-04,1.351700e-04,1.245500e-04,1.109600e-04,9.611900e-05, & - &7.930000e-05,3.946700e-05,3.698900e-05,4.681600e-05,1.311400e-03, & - &1.076500e-04,9.513300e-05,8.174000e-05,2.968400e-05,4.477100e-05, & - &7.384400e-05,7.445800e-05,3.235300e-05,1.755600e-04,1.108600e-04, & - &9.864300e-05,8.575500e-05,6.395000e-05,3.507200e-05,5.636200e-05, & - &7.381100e-05,3.797400e-05,3.551300e-04,1.139000e-04,1.022600e-04, & - &8.987300e-05,7.533700e-05,2.748800e-05,4.066800e-05,6.669500e-05, & - &4.846900e-05,6.619500e-04,1.176800e-04,1.069500e-04,9.475800e-05, & - &8.081200e-05,5.620300e-05,3.095900e-05,5.496000e-05,5.232500e-05, & - &1.150000e-03,1.214300e-04,1.120000e-04,9.966500e-05,8.631700e-05, & - &7.050700e-05,2.824100e-05,4.010800e-05,4.782300e-05,1.882400e-03, & - &9.555000e-05,8.451000e-05,7.243300e-05,2.469500e-05,4.131900e-05, & - &6.896500e-05,7.583600e-05,3.397200e-05,1.880300e-04,9.858500e-05, & - &8.781600e-05,7.626200e-05,5.062500e-05,3.209900e-05,5.290900e-05, & - &7.128500e-05,4.209200e-05,3.807100e-04,1.017000e-04,9.139700e-05, & - &8.029100e-05,6.660900e-05,2.605300e-05,3.865600e-05,6.206100e-05, & - &5.028800e-05,7.109100e-04,1.053200e-04,9.585900e-05,8.474100e-05, & - &7.219000e-05,4.457100e-05,2.960600e-05,5.114400e-05,5.095000e-05, & - &1.236700e-03,1.087300e-04,1.002600e-04,8.912300e-05,7.710000e-05, & - &6.247500e-05,2.404400e-05,3.781100e-05,4.592900e-05,2.027800e-03, & - &8.420500e-05,7.453900e-05,6.346700e-05,2.353800e-05,3.832500e-05, & - &6.427500e-05,7.553300e-05,3.567100e-05,1.622300e-04,8.713400e-05, & - &7.765800e-05,6.726300e-05,3.816300e-05,2.927600e-05,4.814400e-05, & - &6.688300e-05,4.596200e-05,3.288100e-04,9.017700e-05,8.112200e-05, & - &7.113600e-05,5.805300e-05,2.469900e-05,3.668400e-05,5.740600e-05, & - &5.067800e-05,6.149800e-04,9.356600e-05,8.521700e-05,7.520800e-05, & - &6.381600e-05,3.386200e-05,2.834600e-05,4.732100e-05,4.661800e-05, & - &1.071700e-03,9.673800e-05,8.909800e-05,7.917800e-05,6.835600e-05, & - &5.447100e-05,2.235000e-05,3.519800e-05,4.455900e-05,1.759600e-03/ - data absa(1:270,4) / & - &3.521800e-04,3.206700e-04,2.854200e-04,2.469100e-04,2.071500e-04, & - &1.643000e-04,1.163000e-04,3.060200e-05,2.233400e-05,3.670300e-04, & - &3.377900e-04,3.033000e-04,2.652300e-04,2.234400e-04,1.799900e-04, & - &1.344600e-04,5.163900e-05,3.322600e-05,3.858500e-04,3.597800e-04, & - &3.259300e-04,2.871100e-04,2.447300e-04,2.019600e-04,1.578300e-04, & - &1.032700e-04,6.542000e-05,4.090700e-04,3.857700e-04,3.545000e-04, & - &3.163200e-04,2.747000e-04,2.318200e-04,1.868500e-04,1.363800e-04, & - &1.184700e-04,4.373700e-04,4.187800e-04,3.915800e-04,3.553400e-04, & - &3.136900e-04,2.689400e-04,2.211100e-04,1.702300e-04,1.612600e-04, & - &3.398800e-04,3.082800e-04,2.731900e-04,2.356600e-04,1.967100e-04, & - &1.548800e-04,1.065600e-04,2.463900e-05,2.013500e-05,3.507400e-04, & - &3.214500e-04,2.872000e-04,2.507200e-04,2.101400e-04,1.673300e-04, & - &1.212100e-04,3.918000e-05,2.990100e-05,3.647500e-04,3.382900e-04, & - &3.054600e-04,2.677600e-04,2.259200e-04,1.827700e-04,1.379200e-04, & - &7.352700e-05,6.989200e-05,3.822500e-04,3.582000e-04,3.268800e-04, & - &2.885800e-04,2.466500e-04,2.040300e-04,1.596300e-04,1.103500e-04, & - &1.077400e-04,4.027300e-04,3.826800e-04,3.530400e-04,3.157000e-04, & - &2.751300e-04,2.315400e-04,1.862400e-04,1.378300e-04,1.443800e-04, & - &3.258600e-04,2.935400e-04,2.584000e-04,2.221100e-04,1.849300e-04, & - &1.445900e-04,9.396800e-05,2.683600e-05,1.766700e-05,3.333500e-04, & - &3.032200e-04,2.693800e-04,2.345000e-04,1.958400e-04,1.545800e-04, & - &1.087200e-04,2.786000e-05,4.230500e-05,3.430700e-04,3.156000e-04, & - &2.835600e-04,2.481100e-04,2.085900e-04,1.665700e-04,1.216400e-04, & - &4.304900e-05,7.417300e-05,3.551000e-04,3.306700e-04,3.003000e-04, & - &2.639600e-04,2.234700e-04,1.809400e-04,1.361700e-04,8.054900e-05, & - &1.046200e-04,3.693400e-04,3.488600e-04,3.192500e-04,2.828500e-04, & - &2.424600e-04,1.990400e-04,1.540200e-04,1.074000e-04,1.413400e-04, & - &3.120200e-04,2.800300e-04,2.450700e-04,2.097200e-04,1.736500e-04, & - &1.350300e-04,5.876800e-05,2.931400e-05,2.402300e-05,3.181300e-04, & - &2.879100e-04,2.539400e-04,2.196500e-04,1.837700e-04,1.438900e-04, & - &9.709300e-05,2.333700e-05,5.002100e-05,3.248300e-04,2.967500e-04, & - &2.651000e-04,2.317500e-04,1.944400e-04,1.536000e-04,1.092800e-04, & - &3.071800e-05,7.625200e-05,3.335000e-04,3.082900e-04,2.787200e-04, & - &2.443700e-04,2.059300e-04,1.646900e-04,1.205700e-04,4.498400e-05, & - &1.092100e-04,3.444000e-04,3.228800e-04,2.936800e-04,2.588200e-04, & - &2.195800e-04,1.777200e-04,1.327900e-04,8.334400e-05,1.506800e-04, & - &2.977000e-04,2.656800e-04,2.323100e-04,1.976000e-04,1.626400e-04, & - &1.250100e-04,5.221200e-05,2.785100e-05,2.942500e-05,3.034100e-04, & - &2.731600e-04,2.398800e-04,2.061200e-04,1.717800e-04,1.344400e-04, & - &6.880800e-05,2.423300e-05,5.090200e-05,3.085500e-04,2.804400e-04, & - &2.485100e-04,2.161500e-04,1.816400e-04,1.430000e-04,9.845600e-05, & - &2.256700e-05,7.878900e-05,3.147900e-04,2.889600e-04,2.602000e-04, & - &2.279300e-04,1.918300e-04,1.520300e-04,1.089900e-04,3.388600e-05, & - &1.158600e-04,3.227500e-04,3.006200e-04,2.728700e-04,2.400500e-04, & - &2.024300e-04,1.623000e-04,1.191600e-04,4.864200e-05,1.637500e-04, & - &2.845100e-04,2.527800e-04,2.202800e-04,1.870700e-04,1.529400e-04, & - &1.136800e-04,5.149900e-05,2.249100e-05,2.930000e-05,2.881800e-04, & - &2.575600e-04,2.259200e-04,1.930500e-04,1.596000e-04,1.235800e-04, & - &4.927800e-05,2.801800e-05,5.002000e-05,2.930800e-04,2.647900e-04, & - &2.334200e-04,2.017600e-04,1.683700e-04,1.327800e-04,7.502200e-05, & - &2.467900e-05,7.955400e-05,2.979700e-04,2.717100e-04,2.425200e-04, & - &2.113000e-04,1.779800e-04,1.408000e-04,9.859300e-05,2.641300e-05, & - &1.202900e-04,3.038500e-04,2.803800e-04,2.532000e-04,2.223100e-04, & - &1.874600e-04,1.495300e-04,1.080500e-04,3.495700e-05,1.742800e-04/ - data absa(271:585,4) / & - &2.715400e-04,2.404700e-04,2.086900e-04,1.765300e-04,1.431600e-04, & - &6.307600e-05,5.307600e-05,1.879900e-05,2.945900e-05,2.732200e-04, & - &2.432200e-04,2.124500e-04,1.811300e-04,1.487600e-04,1.119400e-04, & - &4.941600e-05,2.176600e-05,5.197700e-05,2.779500e-04,2.494000e-04, & - &2.193100e-04,1.885300e-04,1.563200e-04,1.217300e-04,4.345900e-05, & - &2.791000e-05,8.551500e-05,2.824500e-04,2.560900e-04,2.272600e-04, & - &1.969500e-04,1.646700e-04,1.302800e-04,8.303000e-05,3.123800e-05, & - &1.332500e-04,2.870300e-04,2.631800e-04,2.359500e-04,2.057900e-04, & - &1.735100e-04,1.381300e-04,9.782600e-05,2.939500e-05,1.986300e-04, & - &2.566600e-04,2.266500e-04,1.962300e-04,1.652800e-04,1.318800e-04, & - &5.267200e-05,5.459000e-05,1.521200e-05,3.533600e-05,2.587100e-04, & - &2.297600e-04,1.998700e-04,1.697600e-04,1.383800e-04,6.229300e-05, & - &5.104900e-05,2.099000e-05,6.516400e-05,2.613100e-04,2.335400e-04, & - &2.047200e-04,1.754200e-04,1.447900e-04,1.093600e-04,4.359300e-05, & - &2.783800e-05,1.116400e-04,2.659700e-04,2.397200e-04,2.121400e-04, & - &1.829300e-04,1.520700e-04,1.187200e-04,4.292800e-05,2.939900e-05, & - &1.800500e-04,2.696500e-04,2.460200e-04,2.194600e-04,1.905900e-04, & - &1.594500e-04,1.267800e-04,8.150600e-05,3.039600e-05,2.757400e-04, & - &2.405100e-04,2.119100e-04,1.831800e-04,1.534800e-04,8.974000e-05, & - &5.644300e-05,5.832300e-05,1.397700e-05,7.871400e-05,2.428000e-04, & - &2.151400e-04,1.865900e-04,1.576600e-04,1.262100e-04,4.811500e-05, & - &5.196200e-05,1.829700e-05,1.528600e-04,2.448000e-04,2.180900e-04, & - &1.904400e-04,1.623800e-04,1.328600e-04,5.971900e-05,4.795500e-05, & - &2.224500e-05,2.737300e-04,2.480000e-04,2.225500e-04,1.961300e-04, & - &1.683600e-04,1.390800e-04,1.047700e-04,3.926200e-05,3.147700e-05, & - &4.576800e-04,2.516100e-04,2.281800e-04,2.028100e-04,1.751500e-04, & - &1.459800e-04,1.146900e-04,3.684600e-05,3.447700e-05,7.222900e-04, & - &2.233000e-04,1.964700e-04,1.694700e-04,1.407000e-04,5.039700e-05, & - &6.437200e-05,5.411900e-05,1.367100e-05,2.181900e-04,2.257900e-04, & - &1.997000e-04,1.728900e-04,1.452800e-04,8.053200e-05,5.436700e-05, & - &6.010400e-05,1.548300e-05,4.439300e-04,2.275900e-04,2.023400e-04, & - &1.762500e-04,1.495000e-04,1.194500e-04,4.435400e-05,5.305200e-05, & - &2.111000e-05,8.268200e-04,2.292200e-04,2.052100e-04,1.801600e-04, & - &1.541000e-04,1.258200e-04,5.348600e-05,4.458100e-05,2.912200e-05, & - &1.429500e-03,2.319800e-04,2.094900e-04,1.855700e-04,1.595000e-04, & - &1.321600e-04,9.877500e-05,3.664300e-05,3.679400e-05,2.322100e-03, & - &2.058300e-04,1.812700e-04,1.563300e-04,1.277600e-04,4.781100e-05, & - &6.973700e-05,5.855700e-05,1.254600e-05,3.151200e-04,2.080800e-04, & - &1.841700e-04,1.595900e-04,1.334100e-04,4.296000e-05,5.258700e-05, & - &6.094300e-05,1.724900e-05,6.430900e-04,2.098500e-04,1.867900e-04, & - &1.627800e-04,1.378600e-04,1.009400e-04,4.292600e-05,5.400000e-05, & - &2.143800e-05,1.200900e-03,2.111300e-04,1.893100e-04,1.663800e-04, & - &1.420800e-04,1.147100e-04,3.599700e-05,4.506400e-05,2.959300e-05, & - &2.080900e-03,2.133200e-04,1.932200e-04,1.710200e-04,1.467800e-04, & - &1.213600e-04,7.671400e-05,3.825500e-05,4.007700e-05,3.393200e-03, & - &1.871900e-04,1.650100e-04,1.422600e-04,1.084000e-04,4.355100e-05, & - &6.513500e-05,6.044900e-05,1.236800e-05,3.413400e-04,1.895200e-04, & - &1.678500e-04,1.455300e-04,1.211700e-04,3.506200e-05,4.857300e-05, & - &6.284100e-05,1.547400e-05,6.980300e-04,1.911800e-04,1.704800e-04, & - &1.486500e-04,1.258300e-04,8.186200e-05,3.761700e-05,5.356400e-05, & - &2.124800e-05,1.305700e-03,1.927000e-04,1.732000e-04,1.523100e-04, & - &1.298300e-04,1.044100e-04,3.334200e-05,4.195900e-05,3.584500e-05, & - &2.269000e-03,1.951800e-04,1.773800e-04,1.568400e-04,1.345700e-04, & - &1.110400e-04,6.494700e-05,3.540700e-05,4.349600e-05,3.712800e-03, & - &1.684400e-04,1.485900e-04,1.280600e-04,8.616500e-05,4.010700e-05, & - &6.013300e-05,6.135700e-05,1.276300e-05,2.973400e-04,1.706900e-04, & - &1.514000e-04,1.313400e-04,1.089100e-04,3.261300e-05,4.687200e-05, & - &6.009400e-05,1.507200e-05,6.088700e-04,1.724400e-04,1.540700e-04, & - &1.344400e-04,1.136100e-04,6.463700e-05,3.462700e-05,4.876500e-05, & - &2.730300e-05,1.141600e-03,1.742200e-04,1.570200e-04,1.380600e-04, & - &1.175600e-04,9.333700e-05,3.014800e-05,3.853800e-05,4.263600e-05, & - &1.990300e-03,1.768500e-04,1.612000e-04,1.423800e-04,1.222200e-04, & - &1.004100e-04,5.294700e-05,3.188600e-05,4.033000e-05,3.263800e-03/ - data absa(1:270,5) / & - &4.388900e-04,3.995800e-04,3.578300e-04,3.133600e-04,2.669800e-04, & - &2.185700e-04,1.642400e-04,4.039900e-05,2.824700e-05,4.597600e-04, & - &4.249700e-04,3.873600e-04,3.458100e-04,3.022000e-04,2.518900e-04, & - &1.963100e-04,1.095400e-04,6.763000e-05,4.894400e-04,4.615900e-04, & - &4.278400e-04,3.896200e-04,3.447600e-04,2.929200e-04,2.351400e-04, & - &1.701400e-04,1.536500e-04,5.294100e-04,5.102300e-04,4.794800e-04, & - &4.421900e-04,3.961800e-04,3.439200e-04,2.863000e-04,2.238700e-04, & - &2.180300e-04,5.797400e-04,5.685900e-04,5.426900e-04,5.051400e-04, & - &4.606200e-04,4.100200e-04,3.533800e-04,2.859900e-04,2.898300e-04, & - &4.277800e-04,3.875100e-04,3.442400e-04,2.983800e-04,2.518800e-04, & - &2.029000e-04,1.487500e-04,2.665800e-05,3.157300e-05,4.427000e-04, & - &4.062100e-04,3.656100e-04,3.215400e-04,2.770800e-04,2.275000e-04, & - &1.730500e-04,6.532400e-05,8.856400e-05,4.631600e-04,4.315400e-04, & - &3.930600e-04,3.539200e-04,3.088800e-04,2.588100e-04,2.032800e-04, & - &1.365200e-04,1.478100e-04,4.889100e-04,4.646700e-04,4.311600e-04, & - &3.931600e-04,3.483500e-04,2.974800e-04,2.423700e-04,1.824000e-04, & - &2.053300e-04,5.224900e-04,5.073500e-04,4.783900e-04,4.417300e-04, & - &3.970000e-04,3.468300e-04,2.928900e-04,2.341000e-04,2.736300e-04, & - &4.166600e-04,3.758700e-04,3.312400e-04,2.850000e-04,2.371900e-04, & - &1.891100e-04,1.326100e-04,2.345200e-05,4.934300e-05,4.269900e-04, & - &3.890600e-04,3.464800e-04,3.008400e-04,2.557000e-04,2.062800e-04, & - &1.509200e-04,2.871300e-05,9.919800e-05,4.402100e-04,4.062900e-04, & - &3.653900e-04,3.226300e-04,2.768500e-04,2.269900e-04,1.725700e-04, & - &8.289800e-05,1.468200e-04,4.567400e-04,4.277800e-04,3.896200e-04, & - &3.491100e-04,3.035200e-04,2.538100e-04,1.999800e-04,1.383500e-04, & - &2.052000e-04,4.777600e-04,4.541500e-04,4.210100e-04,3.817300e-04, & - &3.369800e-04,2.884900e-04,2.351000e-04,1.793600e-04,2.765400e-04, & - &4.096700e-04,3.665300e-04,3.217600e-04,2.747900e-04,2.270300e-04, & - &1.790200e-04,1.157000e-04,2.002600e-05,6.271600e-05,4.172800e-04, & - &3.773700e-04,3.334400e-04,2.876900e-04,2.407600e-04,1.924200e-04, & - &1.365800e-04,2.392300e-05,1.010700e-04,4.253500e-04,3.892800e-04, & - &3.465600e-04,3.025500e-04,2.564800e-04,2.070600e-04,1.523700e-04, & - &3.060800e-05,1.504800e-04,4.367100e-04,4.039400e-04,3.644800e-04, & - &3.210200e-04,2.753000e-04,2.250100e-04,1.708100e-04,9.606000e-05, & - &2.145400e-04,4.497600e-04,4.218100e-04,3.853400e-04,3.435300e-04, & - &2.978000e-04,2.475900e-04,1.947100e-04,1.351700e-04,2.960100e-04, & - &4.080800e-04,3.635800e-04,3.175600e-04,2.705000e-04,2.223800e-04, & - &1.723400e-04,5.973100e-05,1.518300e-05,6.314400e-05,4.117200e-04, & - &3.695000e-04,3.249600e-04,2.781900e-04,2.307700e-04,1.821300e-04, & - &1.244600e-04,2.019400e-05,1.023200e-04,4.169900e-04,3.785500e-04, & - &3.345600e-04,2.899900e-04,2.428400e-04,1.942700e-04,1.398900e-04, & - &2.201300e-05,1.561900e-04,4.231800e-04,3.883100e-04,3.463700e-04, & - &3.027900e-04,2.570700e-04,2.077200e-04,1.535000e-04,3.792300e-05, & - &2.288800e-04,4.318100e-04,3.999900e-04,3.621600e-04,3.191600e-04, & - &2.741200e-04,2.235400e-04,1.694300e-04,1.025700e-04,3.240200e-04, & - &4.091700e-04,3.628200e-04,3.158600e-04,2.675400e-04,2.185100e-04, & - &1.673500e-04,5.030600e-05,1.464700e-05,5.983800e-05,4.072800e-04, & - &3.639300e-04,3.182800e-04,2.714100e-04,2.238800e-04,1.748400e-04, & - &6.625700e-05,1.873400e-05,1.006600e-04,4.109300e-04,3.698900e-04, & - &3.258200e-04,2.799900e-04,2.331000e-04,1.833500e-04,1.280300e-04, & - &1.909100e-05,1.601400e-04,4.143500e-04,3.777500e-04,3.346200e-04, & - &2.905600e-04,2.437700e-04,1.951900e-04,1.416700e-04,2.465100e-05, & - &2.432000e-04,4.188000e-04,3.857200e-04,3.454100e-04,3.021900e-04, & - &2.568400e-04,2.076300e-04,1.538300e-04,5.001200e-05,3.551200e-04/ - data absa(271:585,5) / & - &4.084300e-04,3.606200e-04,3.131100e-04,2.642200e-04,2.146900e-04, & - &1.578800e-04,4.426000e-05,1.047700e-05,5.941900e-05,4.046800e-04, & - &3.598400e-04,3.132900e-04,2.659600e-04,2.176900e-04,1.678100e-04, & - &5.178600e-05,1.464600e-05,1.052400e-04,4.036300e-04,3.613600e-04, & - &3.168300e-04,2.707500e-04,2.241800e-04,1.749500e-04,8.754000e-05, & - &1.804100e-05,1.751400e-04,4.064500e-04,3.677100e-04,3.246800e-04, & - &2.800700e-04,2.338100e-04,1.843100e-04,1.299700e-04,1.828300e-05, & - &2.766300e-04,4.088200e-04,3.744600e-04,3.333900e-04,2.900900e-04, & - &2.438600e-04,1.955400e-04,1.430700e-04,2.610400e-05,4.156100e-04, & - &4.042400e-04,3.559000e-04,3.079500e-04,2.592200e-04,2.090800e-04, & - &7.027200e-05,3.743700e-05,1.069300e-05,7.014800e-05,3.993600e-04, & - &3.536900e-04,3.072500e-04,2.598200e-04,2.113300e-04,1.568700e-04, & - &4.683400e-05,1.406700e-05,1.316300e-04,3.957500e-04,3.531300e-04, & - &3.081800e-04,2.622900e-04,2.156200e-04,1.657700e-04,5.042600e-05, & - &1.532800e-05,2.298300e-04,3.957700e-04,3.559300e-04,3.125900e-04, & - &2.683800e-04,2.223800e-04,1.738000e-04,9.540500e-05,1.773800e-05, & - &3.752600e-04,3.985300e-04,3.621600e-04,3.211800e-04,2.772900e-04, & - &2.319800e-04,1.839100e-04,1.314000e-04,2.310000e-05,5.797100e-04, & - &3.955000e-04,3.475600e-04,2.997600e-04,2.515700e-04,2.005300e-04, & - &6.397100e-05,3.099200e-05,8.561800e-06,1.517700e-04,3.910800e-04, & - &3.452200e-04,2.993600e-04,2.523900e-04,2.035500e-04,7.945900e-05, & - &4.616800e-05,1.006900e-05,3.022200e-04,3.871100e-04,3.443200e-04, & - &2.997600e-04,2.543400e-04,2.077500e-04,1.553100e-04,4.657700e-05, & - &1.462800e-05,5.511200e-04,3.845400e-04,3.447100e-04,3.018200e-04, & - &2.583300e-04,2.128900e-04,1.639900e-04,4.773500e-05,1.831700e-05, & - &9.343400e-04,3.859000e-04,3.490600e-04,3.082000e-04,2.650000e-04, & - &2.198500e-04,1.726200e-04,1.073900e-04,2.004600e-05,1.493200e-03, & - &3.814500e-04,3.348400e-04,2.882400e-04,2.407300e-04,1.374900e-04, & - &6.886400e-05,1.342600e-05,5.425300e-06,4.220800e-04,3.780800e-04, & - &3.331000e-04,2.883600e-04,2.424400e-04,1.922200e-04,5.433200e-05, & - &3.831800e-05,1.354400e-05,8.842000e-04,3.752200e-04,3.329000e-04, & - &2.893300e-04,2.446800e-04,1.982100e-04,8.262500e-05,4.602600e-05, & - &1.385900e-05,1.682200e-03,3.730800e-04,3.336200e-04,2.915400e-04, & - &2.486400e-04,2.041500e-04,1.526900e-04,4.698300e-05,1.420500e-05, & - &2.954700e-03,3.717400e-04,3.355400e-04,2.955200e-04,2.539200e-04, & - &2.096900e-04,1.627000e-04,4.167300e-05,1.782800e-05,4.860700e-03, & - &3.629400e-04,3.187100e-04,2.745100e-04,2.285800e-04,8.357800e-05, & - &6.137200e-05,1.336400e-05,7.791200e-06,6.299200e-04,3.611200e-04, & - &3.185200e-04,2.758000e-04,2.317800e-04,1.803700e-04,5.729500e-05, & - &4.068200e-05,1.252000e-05,1.318200e-03,3.594700e-04,3.194100e-04, & - &2.777900e-04,2.350700e-04,1.902000e-04,4.765000e-05,4.764500e-05, & - &1.408700e-05,2.506400e-03,3.579600e-04,3.206200e-04,2.805600e-04, & - &2.396700e-04,1.964400e-04,1.323500e-04,4.629600e-05,1.516400e-05, & - &4.402500e-03,3.567300e-04,3.225900e-04,2.847900e-04,2.447400e-04, & - &2.020000e-04,1.557800e-04,4.275200e-05,1.889400e-05,7.234000e-03, & - &3.428000e-04,3.011800e-04,2.596700e-04,2.163100e-04,7.220000e-05, & - &5.972700e-05,3.286900e-05,5.565800e-06,7.016400e-04,3.421200e-04, & - &3.021700e-04,2.618200e-04,2.200700e-04,1.643500e-04,5.434000e-05, & - &4.280000e-05,1.113000e-05,1.466800e-03,3.413400e-04,3.036900e-04, & - &2.643500e-04,2.239100e-04,1.807600e-04,4.428200e-05,4.661700e-05, & - &1.288100e-05,2.787600e-03,3.404400e-04,3.054000e-04,2.677300e-04, & - &2.289000e-04,1.871300e-04,1.183800e-04,4.138100e-05,1.355600e-05, & - &4.892300e-03,3.396900e-04,3.078500e-04,2.721600e-04,2.338700e-04, & - &1.930800e-04,1.481900e-04,3.877400e-05,2.336500e-05,8.036700e-03, & - &3.207400e-04,2.820000e-04,2.433500e-04,2.026000e-04,5.975500e-05, & - &5.501200e-05,4.091600e-05,6.597900e-06,6.273400e-04,3.208100e-04, & - &2.837100e-04,2.460100e-04,2.067200e-04,1.426400e-04,4.713100e-05, & - &4.616700e-05,1.027900e-05,1.309800e-03,3.205000e-04,2.854700e-04, & - &2.488800e-04,2.110400e-04,1.695700e-04,3.872000e-05,4.616400e-05, & - &1.064600e-05,2.486800e-03,3.200400e-04,2.876100e-04,2.526100e-04, & - &2.160200e-04,1.764400e-04,1.042500e-04,3.780900e-05,1.786700e-05, & - &4.360900e-03,3.195500e-04,2.904300e-04,2.570300e-04,2.208100e-04, & - &1.825300e-04,1.398800e-04,3.679300e-05,3.083700e-05,7.173500e-03/ - data absa(1:270,6) / & - &5.668500e-04,5.195300e-04,4.693600e-04,4.159200e-04,3.578100e-04, & - &2.988100e-04,2.372100e-04,1.296500e-04,9.755300e-05,6.149800e-04, & - &5.733100e-04,5.273600e-04,4.745600e-04,4.182500e-04,3.633600e-04, & - &3.018100e-04,2.401700e-04,2.294800e-04,6.761100e-04,6.406100e-04, & - &6.011100e-04,5.538800e-04,5.077900e-04,4.551400e-04,3.922300e-04, & - &3.325600e-04,3.427600e-04,7.548000e-04,7.291400e-04,7.025400e-04, & - &6.683500e-04,6.292300e-04,5.767500e-04,5.067300e-04,4.427500e-04, & - &4.713300e-04,8.566800e-04,8.503100e-04,8.384500e-04,8.188300e-04, & - &7.834600e-04,7.265500e-04,6.469300e-04,5.776500e-04,6.251600e-04, & - &5.471000e-04,4.966200e-04,4.451400e-04,3.913500e-04,3.320200e-04, & - &2.734200e-04,2.106200e-04,7.419300e-05,1.144900e-04,5.792000e-04, & - &5.353000e-04,4.886600e-04,4.354400e-04,3.796600e-04,3.226600e-04, & - &2.609900e-04,1.896200e-04,2.181900e-04,6.199800e-04,5.855800e-04, & - &5.453200e-04,4.959800e-04,4.460100e-04,3.926600e-04,3.327000e-04, & - &2.733000e-04,3.154400e-04,6.752200e-04,6.525700e-04,6.197000e-04, & - &5.819900e-04,5.395600e-04,4.895500e-04,4.284800e-04,3.670100e-04, & - &4.334600e-04,7.459300e-04,7.375800e-04,7.213900e-04,6.984300e-04, & - &6.627600e-04,6.156100e-04,5.495400e-04,4.818400e-04,5.791300e-04, & - &5.321400e-04,4.768100e-04,4.234400e-04,3.668000e-04,3.081000e-04, & - &2.472600e-04,1.845300e-04,2.508400e-05,1.512800e-04,5.519100e-04, & - &5.034700e-04,4.523900e-04,3.978400e-04,3.401600e-04,2.816200e-04, & - &2.192000e-04,1.046400e-04,2.334800e-04,5.747700e-04,5.343500e-04, & - &4.890700e-04,4.391100e-04,3.857400e-04,3.287400e-04,2.689000e-04, & - &2.048900e-04,3.368400e-04,6.059600e-04,5.778100e-04,5.406200e-04, & - &4.960400e-04,4.470300e-04,3.951700e-04,3.393800e-04,2.837900e-04, & - &4.683400e-04,6.478500e-04,6.344600e-04,6.081700e-04,5.731200e-04, & - &5.323500e-04,4.868200e-04,4.333400e-04,3.759700e-04,6.325700e-04, & - &5.311000e-04,4.726200e-04,4.162300e-04,3.572300e-04,2.962700e-04, & - &2.332100e-04,1.634000e-04,1.989500e-05,1.613600e-04,5.415300e-04, & - &4.879800e-04,4.337700e-04,3.748700e-04,3.158100e-04,2.548000e-04, & - &1.903600e-04,3.458800e-05,2.510200e-04,5.549700e-04,5.089000e-04, & - &4.576000e-04,4.029200e-04,3.464700e-04,2.869300e-04,2.235400e-04, & - &1.296400e-04,3.698900e-04,5.713900e-04,5.349400e-04,4.880500e-04, & - &4.409600e-04,3.862600e-04,3.303300e-04,2.714300e-04,2.121200e-04, & - &5.245500e-04,5.941500e-04,5.686000e-04,5.330600e-04,4.902500e-04, & - &4.408500e-04,3.915200e-04,3.385000e-04,2.874600e-04,7.189200e-04, & - &5.429000e-04,4.802100e-04,4.200500e-04,3.577300e-04,2.936100e-04, & - &2.284000e-04,1.241200e-04,1.677900e-05,1.647800e-04,5.423400e-04, & - &4.852100e-04,4.273000e-04,3.665500e-04,3.046200e-04,2.408100e-04, & - &1.715800e-04,2.457700e-05,2.643000e-04,5.517600e-04,4.997100e-04, & - &4.443900e-04,3.847300e-04,3.249300e-04,2.619900e-04,1.953000e-04, & - &5.196800e-05,4.010700e-04,5.608200e-04,5.169800e-04,4.645100e-04, & - &4.105500e-04,3.512500e-04,2.912700e-04,2.274600e-04,1.469800e-04, & - &5.831500e-04,5.719300e-04,5.385600e-04,4.914300e-04,4.415400e-04, & - &3.866100e-04,3.308700e-04,2.724200e-04,2.170400e-04,8.166400e-04, & - &5.593300e-04,4.929100e-04,4.284200e-04,3.630500e-04,2.961300e-04, & - &2.272400e-04,5.302300e-05,1.592100e-05,1.608000e-04,5.526500e-04, & - &4.913200e-04,4.302600e-04,3.670500e-04,3.020200e-04,2.361600e-04, & - &1.549200e-04,1.738100e-05,2.687800e-04,5.538300e-04,4.977500e-04, & - &4.388000e-04,3.766100e-04,3.140700e-04,2.492100e-04,1.774600e-04, & - &2.230200e-05,4.222500e-04,5.617800e-04,5.113800e-04,4.549100e-04, & - &3.955600e-04,3.332700e-04,2.681200e-04,2.000100e-04,6.440300e-05, & - &6.315500e-04,5.680600e-04,5.266400e-04,4.738700e-04,4.170800e-04, & - &3.562300e-04,2.944300e-04,2.301600e-04,1.560900e-04,9.063500e-04/ - data absa(271:585,6) / & - &5.791200e-04,5.092900e-04,4.405200e-04,3.717900e-04,3.016900e-04, & - &2.290400e-04,3.673900e-05,9.806500e-06,1.636900e-04,5.705400e-04, & - &5.052600e-04,4.405900e-04,3.740600e-04,3.061000e-04,2.358500e-04, & - &6.539300e-05,1.337200e-05,2.861500e-04,5.639900e-04,5.043500e-04, & - &4.426900e-04,3.782600e-04,3.129400e-04,2.457300e-04,1.669300e-04, & - &2.001500e-05,4.677200e-04,5.658000e-04,5.108600e-04,4.511900e-04, & - &3.893500e-04,3.248900e-04,2.579900e-04,1.851700e-04,2.119300e-05, & - &7.232600e-04,5.719800e-04,5.235300e-04,4.673200e-04,4.065000e-04, & - &3.426100e-04,2.756400e-04,2.063800e-04,8.369800e-05,1.070500e-03, & - &5.987100e-04,5.257400e-04,4.536300e-04,3.815100e-04,3.081800e-04, & - &2.281600e-04,3.169000e-05,9.156300e-06,1.959200e-04,5.894200e-04, & - &5.201900e-04,4.518200e-04,3.823200e-04,3.115000e-04,2.368800e-04, & - &4.487800e-05,1.306200e-05,3.598100e-04,5.814400e-04,5.170500e-04, & - &4.523100e-04,3.849600e-04,3.160000e-04,2.457100e-04,1.030900e-04, & - &1.412900e-05,6.138500e-04,5.744800e-04,5.161000e-04,4.547100e-04, & - &3.901800e-04,3.245700e-04,2.555600e-04,1.754400e-04,1.730400e-05, & - &9.894500e-04,5.748300e-04,5.226200e-04,4.634000e-04,4.022000e-04, & - &3.359700e-04,2.669600e-04,1.936700e-04,2.451400e-05,1.519900e-03, & - &6.165200e-04,5.408100e-04,4.654500e-04,3.905600e-04,3.137900e-04, & - &9.911400e-05,1.394900e-05,3.923900e-06,4.252000e-04,6.062900e-04, & - &5.337600e-04,4.620200e-04,3.899000e-04,3.165500e-04,2.354400e-04, & - &3.738200e-05,8.695100e-06,8.304400e-04,5.969400e-04,5.285800e-04, & - &4.609400e-04,3.912800e-04,3.198400e-04,2.458500e-04,4.745300e-05, & - &1.121900e-05,1.497800e-03,5.881200e-04,5.254000e-04,4.616200e-04, & - &3.942400e-04,3.263500e-04,2.558500e-04,1.379300e-04,1.582300e-05, & - &2.531500e-03,5.809400e-04,5.248900e-04,4.640900e-04,4.015600e-04, & - &3.351600e-04,2.646100e-04,1.860800e-04,1.988700e-05,4.051200e-03, & - &6.296900e-04,5.518100e-04,4.745400e-04,3.970300e-04,3.172400e-04, & - &6.512700e-05,3.745200e-06,3.274100e-06,1.176900e-03,6.195700e-04, & - &5.445900e-04,4.702900e-04,3.958500e-04,3.196800e-04,1.304100e-04, & - &2.451500e-05,7.297500e-06,2.441700e-03,6.093900e-04,5.381300e-04, & - &4.676900e-04,3.965100e-04,3.230500e-04,2.418200e-04,4.380700e-05, & - &1.178300e-05,4.628700e-03,5.995500e-04,5.332900e-04,4.674400e-04, & - &3.983500e-04,3.279000e-04,2.543700e-04,4.642300e-05,1.197000e-05, & - &8.152700e-03,5.905100e-04,5.306900e-04,4.684100e-04,4.033500e-04, & - &3.359900e-04,2.641100e-04,1.690500e-04,1.834700e-05,1.351100e-02, & - &6.327000e-04,5.546900e-04,4.769300e-04,3.991700e-04,3.166900e-04, & - &6.338800e-05,3.672100e-06,3.214700e-07,1.720700e-03,6.232300e-04, & - &5.479200e-04,4.732000e-04,3.983600e-04,3.213200e-04,8.366900e-05, & - &2.542100e-05,6.202400e-06,3.606500e-03,6.134300e-04,5.417400e-04, & - &4.712000e-04,3.996500e-04,3.252400e-04,2.380700e-04,4.528800e-05, & - &1.101000e-05,6.907700e-03,6.042200e-04,5.376000e-04,4.715100e-04, & - &4.021500e-04,3.314500e-04,2.559600e-04,4.643800e-05,1.104600e-05, & - &1.227600e-02,5.951300e-04,5.355300e-04,4.729200e-04,4.078600e-04, & - &3.397700e-04,2.664500e-04,1.353000e-04,1.839600e-05,2.037800e-02, & - &6.301500e-04,5.526400e-04,4.751400e-04,3.975700e-04,3.155600e-04, & - &6.037800e-05,5.168600e-06,4.121700e-06,1.908900e-03,6.215600e-04, & - &5.466100e-04,4.722800e-04,3.979400e-04,3.211500e-04,9.345900e-05, & - &3.591000e-05,6.949100e-06,4.040700e-03,6.128400e-04,5.415300e-04, & - &4.713700e-04,3.999300e-04,3.256200e-04,2.394200e-04,4.545900e-05, & - &1.220700e-05,7.797200e-03,6.043100e-04,5.382700e-04,4.721700e-04, & - &4.031500e-04,3.329700e-04,2.572200e-04,4.499100e-05,1.184200e-05, & - &1.383800e-02,5.961400e-04,5.371900e-04,4.745900e-04,4.096500e-04, & - &3.410900e-04,2.676300e-04,1.432700e-04,1.612200e-05,2.289700e-02, & - &6.206700e-04,5.444200e-04,4.682900e-04,3.920600e-04,3.105900e-04, & - &5.457000e-05,2.532400e-05,1.902700e-06,1.724600e-03,6.133300e-04, & - &5.396600e-04,4.665700e-04,3.935300e-04,3.174100e-04,1.018400e-04, & - &4.182200e-05,6.346800e-06,3.676500e-03,6.061000e-04,5.361700e-04, & - &4.670400e-04,3.962200e-04,3.231700e-04,2.366500e-04,4.592700e-05, & - &1.117600e-05,7.078600e-03,5.990200e-04,5.344300e-04,4.687800e-04, & - &4.006900e-04,3.311800e-04,2.558800e-04,4.467400e-05,1.123900e-05, & - &1.252400e-02,5.923400e-04,5.345400e-04,4.724200e-04,4.079100e-04, & - &3.395100e-04,2.664600e-04,1.467000e-04,2.092100e-05,2.068100e-02/ - data absa(1:270,7) / & - &7.673000e-04,6.953300e-04,6.343500e-04,5.775500e-04,5.274700e-04, & - &4.812700e-04,4.636000e-04,4.715300e-04,5.050300e-04,8.944600e-04, & - &8.314500e-04,7.779100e-04,7.307900e-04,6.815800e-04,6.405400e-04, & - &6.406000e-04,6.775100e-04,7.412700e-04,1.083900e-03,1.032600e-03, & - &9.891000e-04,9.487400e-04,8.899500e-04,8.505900e-04,8.666000e-04, & - &9.385800e-04,1.040400e-03,1.339200e-03,1.297600e-03,1.261700e-03, & - &1.218700e-03,1.150300e-03,1.114200e-03,1.153700e-03,1.260000e-03, & - &1.407400e-03,1.657200e-03,1.619000e-03,1.592800e-03,1.544600e-03, & - &1.469600e-03,1.438500e-03,1.502900e-03,1.655900e-03,1.856300e-03, & - &7.279100e-04,6.576000e-04,5.947800e-04,5.353900e-04,4.804500e-04, & - &4.276600e-04,4.000900e-04,3.973500e-04,4.372800e-04,8.181000e-04, & - &7.567700e-04,7.017200e-04,6.556200e-04,6.048400e-04,5.623800e-04, & - &5.565000e-04,5.826000e-04,6.486100e-04,9.521600e-04,9.050700e-04, & - &8.691000e-04,8.346200e-04,7.878600e-04,7.509600e-04,7.591400e-04, & - &8.164600e-04,9.182700e-04,1.144200e-03,1.114800e-03,1.100900e-03, & - &1.071500e-03,1.024800e-03,9.926700e-04,1.017900e-03,1.107800e-03, & - &1.254100e-03,1.399600e-03,1.390500e-03,1.391400e-03,1.362400e-03, & - &1.317300e-03,1.290600e-03,1.336500e-03,1.470300e-03,1.673300e-03, & - &6.919800e-04,6.209300e-04,5.550000e-04,4.911200e-04,4.285800e-04, & - &3.679600e-04,3.224300e-04,2.706800e-04,3.844500e-04,7.480800e-04, & - &6.819700e-04,6.224400e-04,5.665600e-04,5.093600e-04,4.623500e-04, & - &4.453300e-04,4.571800e-04,5.821200e-04,8.261300e-04,7.735800e-04, & - &7.315900e-04,6.894100e-04,6.439000e-04,6.111800e-04,6.139000e-04, & - &6.568700e-04,8.409700e-04,9.395500e-04,9.093600e-04,8.935800e-04, & - &8.699300e-04,8.375900e-04,8.143100e-04,8.333000e-04,9.068900e-04, & - &1.173600e-03,1.102400e-03,1.102900e-03,1.114400e-03,1.108700e-03, & - &1.085800e-03,1.070100e-03,1.110200e-03,1.220300e-03,1.585500e-03, & - &6.914100e-04,6.157300e-04,5.436500e-04,4.726800e-04,4.018500e-04, & - &3.316900e-04,2.648400e-04,1.194100e-04,4.252500e-04,7.130300e-04, & - &6.431100e-04,5.773000e-04,5.142800e-04,4.489000e-04,3.893500e-04, & - &3.527700e-04,3.280300e-04,6.609800e-04,7.641900e-04,7.011300e-04, & - &6.475600e-04,5.899000e-04,5.339100e-04,4.926500e-04,4.827500e-04, & - &5.073000e-04,9.804500e-04,8.260900e-04,7.818200e-04,7.499100e-04, & - &7.108900e-04,6.744200e-04,6.500900e-04,6.614600e-04,7.185400e-04, & - &1.393800e-03,9.132700e-04,9.024500e-04,8.987700e-04,8.870500e-04, & - &8.703400e-04,8.601000e-04,8.918000e-04,9.810100e-04,1.911800e-03, & - &7.119400e-04,6.307300e-04,5.515200e-04,4.734800e-04,3.951300e-04, & - &3.151900e-04,2.298300e-04,2.745200e-05,4.845300e-04,7.129600e-04, & - &6.379700e-04,5.664600e-04,4.957400e-04,4.227300e-04,3.519600e-04, & - &2.894400e-04,1.724200e-04,7.767100e-04,7.344400e-04,6.657400e-04, & - &6.036900e-04,5.378000e-04,4.714600e-04,4.147300e-04,3.836900e-04, & - &3.763300e-04,1.182400e-03,7.769700e-04,7.199100e-04,6.704500e-04, & - &6.121700e-04,5.605300e-04,5.233600e-04,5.202300e-04,5.586200e-04, & - &1.718100e-03,8.260100e-04,7.911900e-04,7.621300e-04,7.310700e-04, & - &6.988000e-04,6.826600e-04,7.050300e-04,7.770100e-04,2.399100e-03, & - &7.470200e-04,6.591100e-04,5.726200e-04,4.867900e-04,4.013400e-04, & - &3.131800e-04,1.546100e-04,1.675800e-05,5.268800e-04,7.412800e-04, & - &6.585500e-04,5.782600e-04,4.989200e-04,4.178900e-04,3.350100e-04, & - &2.518400e-04,5.393600e-05,8.785000e-04,7.395400e-04,6.641600e-04, & - &5.935900e-04,5.212600e-04,4.450700e-04,3.737000e-04,3.140800e-04, & - &2.223600e-04,1.380900e-03,7.571700e-04,6.900200e-04,6.296200e-04, & - &5.609900e-04,4.955700e-04,4.390200e-04,4.100600e-04,4.148900e-04, & - &2.065500e-03,7.895400e-04,7.375800e-04,6.884100e-04,6.336000e-04, & - &5.815500e-04,5.471300e-04,5.492200e-04,5.998600e-04,2.958900e-03/ - data absa(271:585,7) / & - &7.946700e-04,6.992900e-04,6.042400e-04,5.107300e-04,4.169300e-04, & - &3.208900e-04,5.132500e-05,1.212200e-05,6.025900e-04,7.834300e-04, & - &6.925000e-04,6.035700e-04,5.159200e-04,4.268700e-04,3.354200e-04, & - &2.259200e-04,1.597600e-05,1.050200e-03,7.757300e-04,6.913000e-04, & - &6.099700e-04,5.290800e-04,4.440900e-04,3.590400e-04,2.761600e-04, & - &9.296500e-05,1.710200e-03,7.729400e-04,6.969200e-04,6.265700e-04, & - &5.496500e-04,4.731200e-04,3.992000e-04,3.390300e-04,2.760200e-04, & - &2.631900e-03,7.873100e-04,7.217300e-04,6.588700e-04,5.906500e-04, & - &5.229500e-04,4.649000e-04,4.361800e-04,4.534600e-04,3.866800e-03, & - &8.550100e-04,7.507800e-04,6.465700e-04,5.436600e-04,4.403900e-04, & - &3.329400e-04,2.668800e-05,1.225800e-05,8.128600e-04,8.409900e-04, & - &7.409300e-04,6.422800e-04,5.443000e-04,4.463600e-04,3.455100e-04, & - &1.046800e-04,1.283000e-05,1.492300e-03,8.285500e-04,7.347200e-04, & - &6.420800e-04,5.514700e-04,4.579700e-04,3.615200e-04,2.553800e-04, & - &1.624100e-05,2.536900e-03,8.184000e-04,7.320300e-04,6.492900e-04, & - &5.642500e-04,4.754400e-04,3.876000e-04,3.023600e-04,1.373300e-04, & - &4.037100e-03,8.127000e-04,7.358900e-04,6.634800e-04,5.841200e-04, & - &5.056200e-04,4.282900e-04,3.661600e-04,3.256400e-04,6.090000e-03, & - &9.256000e-04,8.112500e-04,6.981900e-04,5.841300e-04,4.705500e-04, & - &3.501500e-04,5.550000e-06,4.962900e-06,2.029000e-03,9.109300e-04, & - &8.009700e-04,6.913700e-04,5.824900e-04,4.737800e-04,3.619400e-04, & - &3.006200e-05,1.084200e-05,3.953100e-03,8.970900e-04,7.918000e-04, & - &6.877500e-04,5.851800e-04,4.815600e-04,3.736700e-04,1.799900e-04, & - &1.561900e-05,7.040500e-03,8.831700e-04,7.854200e-04,6.889900e-04, & - &5.934500e-04,4.932000e-04,3.921700e-04,2.841200e-04,3.498800e-05, & - &1.163000e-02,8.704200e-04,7.817200e-04,6.965500e-04,6.053400e-04, & - &5.134600e-04,4.203500e-04,3.304900e-04,1.773200e-04,1.808400e-02, & - &1.002000e-03,8.776800e-04,7.545300e-04,6.299400e-04,5.036900e-04, & - &2.002900e-04,4.833800e-06,1.115000e-06,6.182800e-03,9.861400e-04, & - &8.656400e-04,7.452700e-04,6.259600e-04,5.060800e-04,3.805300e-04, & - &2.240700e-05,6.075300e-06,1.270100e-02,9.704100e-04,8.544200e-04, & - &7.400800e-04,6.256300e-04,5.119000e-04,3.929900e-04,5.668500e-05, & - &1.064400e-05,2.359600e-02,9.547400e-04,8.462900e-04,7.375700e-04, & - &6.311000e-04,5.215600e-04,4.081500e-04,2.606900e-04,1.441800e-05, & - &4.033900e-02,9.393600e-04,8.391600e-04,7.414500e-04,6.403700e-04, & - &5.363000e-04,4.302400e-04,3.181500e-04,7.568900e-05,6.452800e-02, & - &1.073300e-03,9.401000e-04,8.082100e-04,6.748100e-04,5.399300e-04, & - &1.730400e-04,4.569000e-06,1.094700e-06,9.505800e-03,1.056200e-03, & - &9.272000e-04,7.985900e-04,6.707100e-04,5.416500e-04,4.038700e-04, & - &2.151400e-05,7.837800e-06,1.953800e-02,1.039100e-03,9.154100e-04, & - &7.927200e-04,6.701600e-04,5.482900e-04,4.203700e-04,4.612800e-05, & - &1.083900e-05,3.627600e-02,1.022200e-03,9.062700e-04,7.902800e-04, & - &6.759000e-04,5.583900e-04,4.372500e-04,2.435800e-04,1.596700e-05, & - &6.205700e-02,1.006200e-03,8.987000e-04,7.941700e-04,6.854000e-04, & - &5.739500e-04,4.594100e-04,3.348700e-04,5.851000e-05,9.955800e-02, & - &1.142900e-03,1.001100e-03,8.606600e-04,7.189100e-04,5.757200e-04, & - &2.370800e-04,4.456700e-06,5.149700e-06,1.079800e-02,1.125200e-03, & - &9.880200e-04,8.514500e-04,7.151800e-04,5.779300e-04,4.351700e-04, & - &2.893100e-05,1.330500e-05,2.218500e-02,1.107800e-03,9.764800e-04, & - &8.458800e-04,7.155700e-04,5.856800e-04,4.502500e-04,8.779700e-05, & - &1.205800e-05,4.121800e-02,1.090700e-03,9.672800e-04,8.441500e-04, & - &7.218800e-04,5.960800e-04,4.674900e-04,2.983900e-04,1.390600e-05, & - &7.074800e-02,1.073700e-03,9.596100e-04,8.483500e-04,7.315400e-04, & - &6.126700e-04,4.904200e-04,3.577500e-04,5.922900e-05,1.139800e-01, & - &1.209300e-03,1.059200e-03,9.106900e-04,7.610400e-04,6.099800e-04, & - &3.014100e-04,8.469200e-06,3.639000e-06,9.750500e-03,1.191600e-03, & - &1.046500e-03,9.022300e-04,7.581000e-04,6.132200e-04,4.633800e-04, & - &3.895700e-05,7.162500e-06,2.004500e-02,1.174200e-03,1.035500e-03, & - &8.970400e-04,7.596400e-04,6.216900e-04,4.785100e-04,1.358900e-04, & - &1.189500e-05,3.738000e-02,1.156500e-03,1.026000e-03,8.962800e-04, & - &7.666000e-04,6.330800e-04,4.971500e-04,3.415000e-04,1.106000e-05, & - &6.445800e-02,1.138200e-03,1.018000e-03,9.006100e-04,7.770600e-04, & - &6.508900e-04,5.214900e-04,3.812900e-04,5.975200e-05,1.043600e-01/ - data absa(1:270,8) / & - &9.492600e-04,8.578600e-04,8.113800e-04,7.643300e-04,7.266300e-04, & - &7.896700e-04,8.878700e-04,9.890300e-04,1.102600e-03,1.239000e-03, & - &1.130000e-03,1.062100e-03,9.880899e-04,9.808399e-04,1.115300e-03, & - &1.275400e-03,1.446300e-03,1.619900e-03,1.628500e-03,1.494100e-03, & - &1.401900e-03,1.314300e-03,1.338800e-03,1.558700e-03,1.796300e-03, & - &2.031900e-03,2.289300e-03,2.107500e-03,1.942900e-03,1.823300e-03, & - &1.726000e-03,1.798700e-03,2.119500e-03,2.463000e-03,2.806500e-03, & - &3.171600e-03,2.667600e-03,2.481000e-03,2.335900e-03,2.232900e-03, & - &2.341600e-03,2.781200e-03,3.255000e-03,3.733400e-03,4.221000e-03, & - &8.902500e-04,8.027400e-04,7.427400e-04,6.860900e-04,6.710200e-04, & - &7.174200e-04,7.968000e-04,8.704500e-04,9.764400e-04,1.101700e-03, & - &1.010000e-03,9.545300e-04,8.927400e-04,8.868200e-04,1.000300e-03, & - &1.130900e-03,1.273700e-03,1.431900e-03,1.439500e-03,1.342400e-03, & - &1.261900e-03,1.193100e-03,1.195600e-03,1.388500e-03,1.598800e-03, & - &1.806100e-03,2.042800e-03,1.861800e-03,1.754400e-03,1.647900e-03, & - &1.585300e-03,1.599300e-03,1.883300e-03,2.184600e-03,2.492700e-03, & - &2.837000e-03,2.368600e-03,2.248600e-03,2.136400e-03,2.067000e-03, & - &2.088200e-03,2.468500e-03,2.890400e-03,3.329500e-03,3.786400e-03, & - &8.497900e-04,7.643300e-04,6.959400e-04,6.337000e-04,5.885300e-04, & - &5.955900e-04,6.566700e-04,7.153300e-04,8.121700e-04,9.360300e-04, & - &8.592100e-04,7.933800e-04,7.550800e-04,7.606200e-04,8.411400e-04, & - &9.492000e-04,1.048700e-03,1.201400e-03,1.143300e-03,1.084600e-03, & - &1.026300e-03,9.923300e-04,1.011900e-03,1.169500e-03,1.335100e-03, & - &1.499500e-03,1.728600e-03,1.472000e-03,1.409300e-03,1.357600e-03, & - &1.312200e-03,1.339400e-03,1.577600e-03,1.825800e-03,2.074400e-03, & - &2.389600e-03,1.878300e-03,1.810700e-03,1.779300e-03,1.729300e-03, & - &1.761200e-03,2.084800e-03,2.432900e-03,2.787300e-03,3.212200e-03, & - &8.559800e-04,7.620000e-04,6.769800e-04,6.027400e-04,5.414300e-04, & - &4.851000e-04,5.080800e-04,5.419500e-04,7.203000e-04,8.782900e-04, & - &7.975400e-04,7.282000e-04,6.813200e-04,6.410500e-04,6.765200e-04, & - &7.532800e-04,8.300000e-04,1.121600e-03,9.694100e-04,9.001900e-04, & - &8.395000e-04,8.270600e-04,8.397200e-04,9.495600e-04,1.083100e-03, & - &1.218100e-03,1.665200e-03,1.149700e-03,1.107600e-03,1.097300e-03, & - &1.074800e-03,1.113900e-03,1.307000e-03,1.505100e-03,1.709100e-03, & - &2.379800e-03,1.442300e-03,1.422800e-03,1.437700e-03,1.411700e-03, & - &1.474100e-03,1.757700e-03,2.049900e-03,2.332400e-03,3.273700e-03, & - &8.890000e-04,7.865200e-04,6.903400e-04,5.966700e-04,5.154500e-04, & - &4.467200e-04,3.952200e-04,3.080100e-04,9.083200e-04,8.925600e-04, & - &7.993300e-04,7.138800e-04,6.467900e-04,5.895300e-04,5.456600e-04, & - &5.877800e-04,6.251700e-04,1.472600e-03,9.163000e-04,8.373100e-04, & - &7.686300e-04,7.334800e-04,7.005300e-04,7.673700e-04,8.621200e-04, & - &9.543900e-04,2.251800e-03,1.003900e-03,9.332500e-04,8.949800e-04, & - &8.817800e-04,9.202500e-04,1.073400e-03,1.237100e-03,1.397600e-03, & - &3.307600e-03,1.138400e-03,1.112500e-03,1.145900e-03,1.144700e-03, & - &1.238400e-03,1.476800e-03,1.723200e-03,1.962100e-03,4.658200e-03, & - &9.488700e-04,8.383900e-04,7.310200e-04,6.249300e-04,5.204200e-04, & - &4.227500e-04,3.355600e-04,3.474000e-06,1.125100e-03,9.367700e-04, & - &8.321800e-04,7.345400e-04,6.459400e-04,5.637800e-04,4.915100e-04, & - &4.499400e-04,4.259700e-04,1.883200e-03,9.392100e-04,8.467300e-04, & - &7.595700e-04,6.963600e-04,6.370600e-04,6.105700e-04,6.747600e-04, & - &7.391200e-04,2.958300e-03,9.571900e-04,8.768800e-04,8.181300e-04, & - &7.796700e-04,7.577500e-04,8.585100e-04,9.860900e-04,1.112100e-03, & - &4.427300e-03,1.029400e-03,9.645700e-04,9.375300e-04,9.258800e-04, & - &1.013300e-03,1.203800e-03,1.402000e-03,1.603400e-03,6.343700e-03/ - data absa(271:585,8) / & - &1.027900e-03,9.043300e-04,7.837500e-04,6.650800e-04,5.448400e-04, & - &4.243100e-04,2.688800e-04,7.801500e-06,1.458800e-03,1.008300e-03, & - &8.924100e-04,7.817200e-04,6.720400e-04,5.712400e-04,4.691400e-04, & - &3.680200e-04,8.613700e-05,2.562500e-03,9.959600e-04,8.923700e-04, & - &7.910800e-04,7.032100e-04,6.155600e-04,5.387100e-04,5.151800e-04, & - &5.405200e-04,4.180500e-03,9.882600e-04,8.963900e-04,8.133400e-04, & - &7.557300e-04,6.882400e-04,6.818300e-04,7.745100e-04,8.680100e-04, & - &6.402700e-03,1.001100e-03,9.223300e-04,8.696400e-04,8.271900e-04, & - &8.332000e-04,9.657100e-04,1.120300e-03,1.285300e-03,9.346100e-03, & - &1.112500e-03,9.747500e-04,8.462800e-04,7.124500e-04,5.822300e-04, & - &4.495500e-04,1.205500e-05,1.497900e-05,2.212600e-03,1.093800e-03, & - &9.665400e-04,8.399700e-04,7.132300e-04,5.925500e-04,4.723000e-04, & - &3.231300e-04,3.426900e-06,4.083600e-03,1.075800e-03,9.548700e-04, & - &8.374100e-04,7.264300e-04,6.216600e-04,5.132300e-04,4.249300e-04, & - &3.011300e-04,6.943700e-03,1.055000e-03,9.486200e-04,8.479900e-04, & - &7.611700e-04,6.702800e-04,5.961400e-04,6.016600e-04,6.564200e-04, & - &1.102400e-02,1.039300e-03,9.508900e-04,8.786600e-04,8.122400e-04, & - &7.540000e-04,7.681500e-04,8.828200e-04,1.022100e-03,1.672400e-02, & - &1.218000e-03,1.066400e-03,9.227000e-04,7.732800e-04,6.247500e-04, & - &4.681500e-04,9.517800e-06,3.377200e-06,6.284600e-03,1.192100e-03, & - &1.049800e-03,9.063500e-04,7.668200e-04,6.231700e-04,4.840600e-04, & - &8.334100e-05,3.834300e-06,1.222700e-02,1.166900e-03,1.031000e-03, & - &8.985200e-04,7.655800e-04,6.427700e-04,5.212100e-04,3.766600e-04, & - &1.204000e-05,2.173400e-02,1.147000e-03,1.023500e-03,9.004400e-04, & - &7.876700e-04,6.818300e-04,5.648900e-04,4.915600e-04,4.508800e-04, & - &3.600600e-02,1.129500e-03,1.017400e-03,9.184900e-04,8.270900e-04, & - &7.302700e-04,6.699400e-04,6.908800e-04,7.918600e-04,5.616200e-02, & - &1.341900e-03,1.174500e-03,1.011200e-03,8.472900e-04,6.792500e-04, & - &4.969700e-04,1.525400e-06,1.534300e-06,2.099900e-02,1.314100e-03, & - &1.153900e-03,9.963000e-04,8.374400e-04,6.791600e-04,5.110100e-04, & - &6.845200e-06,3.045100e-06,4.302400e-02,1.289800e-03,1.137500e-03, & - &9.870300e-04,8.340400e-04,6.864900e-04,5.392900e-04,3.262600e-04, & - &6.017300e-06,7.988500e-02,1.267200e-03,1.126400e-03,9.824900e-04, & - &8.476400e-04,7.122300e-04,5.773000e-04,4.417100e-04,9.989600e-05, & - &1.368000e-01,1.247700e-03,1.117200e-03,9.913500e-04,8.707700e-04, & - &7.477000e-04,6.393400e-04,5.769600e-04,6.165600e-04,2.195200e-01, & - &1.475500e-03,1.291700e-03,1.111900e-03,9.305800e-04,7.474400e-04, & - &5.505100e-04,1.652200e-06,1.541200e-06,3.447500e-02,1.448500e-03, & - &1.271900e-03,1.097100e-03,9.219100e-04,7.474500e-04,5.710900e-04, & - &1.169600e-05,3.124300e-06,7.085000e-02,1.426400e-03,1.257900e-03, & - &1.091400e-03,9.215400e-04,7.585500e-04,5.948200e-04,3.160500e-04, & - &9.630900e-06,1.318300e-01,1.402300e-03,1.245700e-03,1.084900e-03, & - &9.346200e-04,7.788100e-04,6.192500e-04,4.617400e-04,2.105300e-05, & - &2.259700e-01,1.379200e-03,1.234500e-03,1.091600e-03,9.504100e-04, & - &8.061500e-04,6.715700e-04,5.892900e-04,6.021500e-04,3.623300e-01, & - &1.631500e-03,1.428600e-03,1.229600e-03,1.028200e-03,8.245000e-04, & - &6.165200e-04,3.305700e-06,1.546500e-06,4.147400e-02,1.604100e-03, & - &1.408500e-03,1.213500e-03,1.019300e-03,8.240700e-04,6.289000e-04, & - &2.015400e-05,3.248800e-06,8.541800e-02,1.578100e-03,1.390800e-03, & - &1.205200e-03,1.016000e-03,8.351800e-04,6.508700e-04,4.244400e-04, & - &1.152900e-05,1.588100e-01,1.553900e-03,1.377500e-03,1.197900e-03, & - &1.028700e-03,8.555500e-04,6.770200e-04,4.976000e-04,3.669800e-05, & - &2.721900e-01,1.529400e-03,1.366200e-03,1.206900e-03,1.047000e-03, & - &8.842400e-04,7.245900e-04,6.045700e-04,5.883000e-04,4.358000e-01, & - &1.807600e-03,1.582800e-03,1.361300e-03,1.138300e-03,9.146300e-04, & - &6.829900e-04,3.045800e-06,2.147300e-06,3.949500e-02,1.778800e-03, & - &1.560700e-03,1.344400e-03,1.129300e-03,9.128800e-04,6.936600e-04, & - &2.133900e-05,1.172300e-05,8.129400e-02,1.749500e-03,1.540400e-03, & - &1.334300e-03,1.124400e-03,9.222100e-04,7.195500e-04,4.926800e-04, & - &4.337000e-06,1.510100e-01,1.723500e-03,1.527000e-03,1.326900e-03, & - &1.136500e-03,9.447300e-04,7.461200e-04,5.522700e-04,4.686600e-05, & - &2.585600e-01,1.699000e-03,1.517000e-03,1.336800e-03,1.158400e-03, & - &9.748800e-04,7.931800e-04,6.272800e-04,5.696000e-04,4.135400e-01/ - data absa(1:270,9) / & - &1.019600e-03,9.375800e-04,9.031600e-04,8.566700e-04,8.757700e-04, & - &1.023600e-03,1.176300e-03,1.314300e-03,1.471900e-03,1.345900e-03, & - &1.231100e-03,1.157600e-03,1.110000e-03,1.223200e-03,1.457600e-03, & - &1.692400e-03,1.915400e-03,2.148800e-03,1.777700e-03,1.623400e-03, & - &1.512800e-03,1.443700e-03,1.691800e-03,2.037300e-03,2.387200e-03, & - &2.717200e-03,3.076300e-03,2.296900e-03,2.111700e-03,1.979000e-03, & - &1.913100e-03,2.313400e-03,2.790300e-03,3.253700e-03,3.709900e-03, & - &4.206900e-03,2.936400e-03,2.706400e-03,2.548700e-03,2.499500e-03, & - &3.080200e-03,3.734000e-03,4.360600e-03,4.932300e-03,5.615000e-03, & - &9.556400e-04,8.659400e-04,8.224700e-04,7.818400e-04,7.725800e-04, & - &8.906500e-04,1.017700e-03,1.149800e-03,1.289900e-03,1.202900e-03, & - &1.104300e-03,1.047900e-03,9.992400e-04,1.091700e-03,1.301500e-03, & - &1.506700e-03,1.703500e-03,1.938500e-03,1.595700e-03,1.470200e-03, & - &1.383400e-03,1.329200e-03,1.540400e-03,1.848200e-03,2.158700e-03, & - &2.459500e-03,2.808700e-03,2.083600e-03,1.926900e-03,1.821000e-03, & - &1.757700e-03,2.111500e-03,2.549000e-03,2.980200e-03,3.405300e-03, & - &3.876600e-03,2.676100e-03,2.483000e-03,2.369000e-03,2.321800e-03, & - &2.843500e-03,3.429200e-03,4.047800e-03,4.591300e-03,5.276500e-03, & - &9.109800e-04,8.197100e-04,7.545300e-04,6.895500e-04,6.657300e-04, & - &7.436600e-04,8.329100e-04,9.168100e-04,1.050700e-03,1.009500e-03, & - &9.263200e-04,8.791200e-04,8.522200e-04,9.171100e-04,1.079600e-03, & - &1.238400e-03,1.393700e-03,1.603100e-03,1.286000e-03,1.200500e-03, & - &1.144800e-03,1.122400e-03,1.289600e-03,1.540600e-03,1.794700e-03, & - &2.039600e-03,2.340800e-03,1.684000e-03,1.584300e-03,1.507200e-03, & - &1.494600e-03,1.791200e-03,2.155000e-03,2.517400e-03,2.893400e-03, & - &3.332100e-03,2.182100e-03,2.058600e-03,1.986200e-03,1.985700e-03, & - &2.432900e-03,2.947900e-03,3.481800e-03,3.962500e-03,4.598100e-03, & - &9.100700e-04,8.151500e-04,7.401900e-04,6.666600e-04,6.022300e-04, & - &6.171700e-04,6.768800e-04,7.135800e-04,8.737000e-04,9.406100e-04, & - &8.585800e-04,8.002400e-04,7.470700e-04,7.722000e-04,8.898100e-04, & - &1.006400e-03,1.109400e-03,1.349100e-03,1.058000e-03,9.811600e-04, & - &9.271300e-04,9.397500e-04,1.075300e-03,1.266400e-03,1.460000e-03, & - &1.648200e-03,1.998300e-03,1.318500e-03,1.265100e-03,1.223500e-03, & - &1.244900e-03,1.489300e-03,1.782800e-03,2.072300e-03,2.355000e-03, & - &2.866300e-03,1.701200e-03,1.638100e-03,1.620200e-03,1.647800e-03, & - &2.024800e-03,2.455400e-03,2.874700e-03,3.296300e-03,4.005800e-03, & - &9.433600e-04,8.381400e-04,7.459900e-04,6.581500e-04,5.871300e-04, & - &5.195900e-04,5.326400e-04,5.524700e-04,1.057400e-03,9.531200e-04, & - &8.589400e-04,7.829500e-04,7.166600e-04,6.665700e-04,7.269800e-04, & - &8.135000e-04,8.972700e-04,1.726500e-03,9.808301e-04,9.034000e-04, & - &8.453600e-04,8.147900e-04,8.983500e-04,1.048100e-03,1.203000e-03, & - &1.349500e-03,2.664500e-03,1.091900e-03,1.027100e-03,9.943200e-04, & - &1.044700e-03,1.244400e-03,1.484500e-03,1.717100e-03,1.937300e-03, & - &3.934300e-03,1.312500e-03,1.296400e-03,1.306400e-03,1.377600e-03, & - &1.694000e-03,2.039700e-03,2.391100e-03,2.721800e-03,5.548700e-03, & - &1.019100e-03,8.989600e-04,7.850800e-04,6.783100e-04,5.763300e-04, & - &4.921600e-04,4.082600e-04,9.298000e-05,1.393100e-03,1.004700e-03, & - &8.966200e-04,8.020500e-04,7.140200e-04,6.399100e-04,5.838400e-04, & - &6.279400e-04,6.769600e-04,2.355200e-03,1.004700e-03,9.147500e-04, & - &8.326200e-04,7.726400e-04,7.468200e-04,8.359500e-04,9.518900e-04, & - &1.065600e-03,3.718900e-03,1.024600e-03,9.486400e-04,8.932200e-04, & - &8.869000e-04,1.020400e-03,1.202100e-03,1.392500e-03,1.565600e-03, & - &5.569200e-03,1.119200e-03,1.060500e-03,1.048500e-03,1.145100e-03, & - &1.404500e-03,1.685800e-03,1.971300e-03,2.236000e-03,7.962900e-03/ - data absa(271:585,9) / & - &1.110500e-03,9.755400e-04,8.484500e-04,7.231100e-04,5.982200e-04, & - &4.805400e-04,3.591200e-04,1.633400e-05,1.868500e-03,1.095300e-03, & - &9.718100e-04,8.565900e-04,7.363400e-04,6.333900e-04,5.406800e-04, & - &4.819000e-04,4.050400e-04,3.317100e-03,1.077600e-03,9.698800e-04, & - &8.659600e-04,7.722100e-04,7.003400e-04,6.677200e-04,7.406700e-04, & - &8.081400e-04,5.464900e-03,1.063300e-03,9.716300e-04,8.952500e-04, & - &8.404200e-04,8.380300e-04,9.586300e-04,1.099800e-03,1.237300e-03, & - &8.483800e-03,1.072700e-03,1.001700e-03,9.642200e-04,9.768200e-04, & - &1.147400e-03,1.373800e-03,1.607000e-03,1.822700e-03,1.247700e-02, & - &1.221200e-03,1.068600e-03,9.277600e-04,7.803000e-04,6.367900e-04, & - &4.902800e-04,2.570500e-05,3.559800e-06,3.023600e-03,1.190400e-03, & - &1.051500e-03,9.184600e-04,7.858400e-04,6.509800e-04,5.280500e-04, & - &4.141700e-04,7.429900e-06,5.633900e-03,1.165600e-03,1.037300e-03, & - &9.201700e-04,7.990300e-04,6.937500e-04,6.091000e-04,5.700900e-04, & - &5.493200e-04,9.617800e-03,1.149800e-03,1.042400e-03,9.326600e-04, & - &8.426100e-04,7.749200e-04,7.669100e-04,8.681600e-04,9.640800e-04, & - &1.537800e-02,1.131000e-03,1.041600e-03,9.703800e-04,9.228700e-04, & - &9.447500e-04,1.109700e-03,1.292800e-03,1.467300e-03,2.313100e-02, & - &1.334600e-03,1.167700e-03,1.007900e-03,8.463400e-04,6.827800e-04, & - &5.155700e-04,6.217000e-06,3.557500e-07,9.027800e-03,1.300400e-03, & - &1.143700e-03,9.928800e-04,8.440700e-04,6.915200e-04,5.416100e-04, & - &3.040700e-04,7.581100e-06,1.775500e-02,1.271600e-03,1.128200e-03, & - &9.919300e-04,8.497900e-04,7.187700e-04,5.856200e-04,4.744000e-04, & - &1.364200e-04,3.166900e-02,1.249300e-03,1.123200e-03,9.948600e-04, & - &8.757400e-04,7.620800e-04,6.840700e-04,6.700800e-04,7.243000e-04, & - &5.232200e-02,1.229200e-03,1.119000e-03,1.012300e-03,9.220000e-04, & - &8.683900e-04,8.867100e-04,1.023900e-03,1.164500e-03,8.133200e-02, & - &1.470200e-03,1.286600e-03,1.104600e-03,9.277500e-04,7.422700e-04, & - &5.487700e-04,1.566900e-06,2.175000e-07,3.180900e-02,1.438100e-03, & - &1.259100e-03,1.091000e-03,9.175100e-04,7.458100e-04,5.695600e-04, & - &1.440800e-05,2.997700e-06,6.565800e-02,1.408800e-03,1.244300e-03, & - &1.083200e-03,9.200100e-04,7.600600e-04,6.016300e-04,4.098100e-04, & - &3.375200e-06,1.215800e-01,1.383700e-03,1.229900e-03,1.078500e-03, & - &9.317200e-04,7.879200e-04,6.597800e-04,5.650900e-04,4.387000e-04, & - &2.078900e-01,1.358300e-03,1.221400e-03,1.084700e-03,9.607500e-04, & - &8.548100e-04,7.908200e-04,8.290000e-04,9.323900e-04,3.321700e-01, & - &1.625300e-03,1.421900e-03,1.221900e-03,1.023600e-03,8.200300e-04, & - &6.054100e-04,1.423100e-06,1.807100e-07,5.469200e-02,1.595100e-03, & - &1.398500e-03,1.208100e-03,1.015000e-03,8.228400e-04,6.164600e-04, & - &9.620700e-06,2.745200e-06,1.121600e-01,1.564200e-03,1.379000e-03, & - &1.196500e-03,1.011300e-03,8.294300e-04,6.477500e-04,4.357100e-04, & - &8.678500e-06,2.079500e-01,1.536100e-03,1.363000e-03,1.189500e-03, & - &1.020700e-03,8.574400e-04,7.032300e-04,5.880900e-04,4.168200e-04, & - &3.557100e-01,1.506600e-03,1.348800e-03,1.193000e-03,1.048100e-03, & - &9.129500e-04,8.267900e-04,8.210900e-04,9.179200e-04,5.712000e-01, & - &1.804100e-03,1.578900e-03,1.357000e-03,1.138900e-03,9.125700e-04, & - &6.788800e-04,5.165800e-06,1.582900e-07,6.856100e-02,1.773800e-03, & - &1.555800e-03,1.343800e-03,1.129200e-03,9.143600e-04,6.957300e-04, & - &2.082000e-05,3.743300e-06,1.405700e-01,1.741800e-03,1.535300e-03, & - &1.332900e-03,1.126100e-03,9.227000e-04,7.235800e-04,4.795400e-04, & - &1.553500e-05,2.611800e-01,1.709000e-03,1.518000e-03,1.323800e-03, & - &1.137500e-03,9.511100e-04,7.654800e-04,6.063600e-04,4.120900e-04, & - &4.477800e-01,1.677800e-03,1.501700e-03,1.326300e-03,1.162600e-03, & - &9.944900e-04,8.634800e-04,8.170700e-04,9.155200e-04,7.182300e-01, & - &2.016200e-03,1.764300e-03,1.516600e-03,1.270700e-03,1.020000e-03, & - &7.640900e-04,1.393300e-06,1.381400e-07,6.754100e-02,1.980400e-03, & - &1.737800e-03,1.500300e-03,1.259800e-03,1.020800e-03,7.758300e-04, & - &1.051900e-04,2.967700e-05,1.389800e-01,1.946300e-03,1.714100e-03, & - &1.488700e-03,1.258000e-03,1.031900e-03,8.095800e-04,5.460700e-04, & - &8.223600e-06,2.583900e-01,1.911900e-03,1.698600e-03,1.481100e-03, & - &1.274100e-03,1.066500e-03,8.496500e-04,6.366900e-04,4.314400e-04, & - &4.437200e-01,1.880700e-03,1.683500e-03,1.488500e-03,1.302400e-03, & - &1.108100e-03,9.230800e-04,8.285600e-04,9.129600e-04,7.107600e-01/ - data absa(1:270,10) / & - &1.134800e-03,1.051200e-03,1.011200e-03,1.038000e-03,1.259100e-03, & - &1.503400e-03,1.745800e-03,1.991600e-03,2.251500e-03,1.449700e-03, & - &1.325800e-03,1.290200e-03,1.393300e-03,1.740200e-03,2.074900e-03, & - &2.423200e-03,2.784300e-03,3.133600e-03,1.908700e-03,1.743100e-03, & - &1.661600e-03,1.843700e-03,2.325900e-03,2.810600e-03,3.323200e-03, & - &3.767400e-03,4.277700e-03,2.508800e-03,2.292900e-03,2.141500e-03, & - &2.432000e-03,3.090100e-03,3.756300e-03,4.429500e-03,5.051400e-03, & - &5.743500e-03,3.222400e-03,2.951200e-03,2.737500e-03,3.205500e-03, & - &4.114700e-03,5.011600e-03,5.916300e-03,6.764200e-03,7.748600e-03, & - &1.049200e-03,9.647500e-04,9.437500e-04,9.381700e-04,1.114600e-03, & - &1.329200e-03,1.527500e-03,1.738300e-03,1.976300e-03,1.311400e-03, & - &1.205700e-03,1.189900e-03,1.258700e-03,1.555600e-03,1.874500e-03, & - &2.171600e-03,2.473700e-03,2.819900e-03,1.741300e-03,1.592700e-03, & - &1.530100e-03,1.686900e-03,2.132400e-03,2.575600e-03,3.005900e-03, & - &3.427000e-03,3.924400e-03,2.284000e-03,2.108400e-03,1.985000e-03, & - &2.259500e-03,2.893300e-03,3.520300e-03,4.140700e-03,4.711400e-03, & - &5.404700e-03,2.953300e-03,2.747600e-03,2.565800e-03,3.008700e-03, & - &3.877400e-03,4.734000e-03,5.574600e-03,6.347100e-03,7.346500e-03, & - &9.885400e-04,8.934300e-04,8.403500e-04,7.992300e-04,8.960900e-04, & - &1.062200e-03,1.211500e-03,1.390900e-03,1.581300e-03,1.087900e-03, & - &1.011700e-03,1.013400e-03,1.051400e-03,1.283800e-03,1.537400e-03, & - &1.793800e-03,2.036300e-03,2.350800e-03,1.416300e-03,1.322600e-03, & - &1.289700e-03,1.432700e-03,1.816300e-03,2.194100e-03,2.568600e-03, & - &2.931900e-03,3.401200e-03,1.871400e-03,1.749300e-03,1.679100e-03, & - &1.971000e-03,2.526600e-03,3.081700e-03,3.620300e-03,4.127200e-03, & - &4.832000e-03,2.427800e-03,2.302700e-03,2.192300e-03,2.668900e-03, & - &3.438100e-03,4.196900e-03,4.957600e-03,5.652100e-03,6.624700e-03, & - &9.866901e-04,8.850900e-04,8.135200e-04,7.299600e-04,7.181700e-04, & - &8.188100e-04,9.274800e-04,1.040300e-03,1.211600e-03,1.029000e-03, & - &9.442600e-04,8.900000e-04,8.728500e-04,1.028700e-03,1.225400e-03, & - &1.419300e-03,1.604400e-03,1.873400e-03,1.143600e-03,1.084000e-03, & - &1.083300e-03,1.191400e-03,1.498300e-03,1.800500e-03,2.102900e-03, & - &2.387200e-03,2.818200e-03,1.487200e-03,1.409300e-03,1.382500e-03, & - &1.661300e-03,2.128200e-03,2.593900e-03,3.033800e-03,3.469100e-03, & - &4.113900e-03,1.938200e-03,1.852800e-03,1.827700e-03,2.290700e-03, & - &2.950200e-03,3.611300e-03,4.267800e-03,4.866700e-03,5.745300e-03, & - &1.026100e-03,9.172500e-04,8.275900e-04,7.387400e-04,6.451200e-04, & - &6.530500e-04,7.202500e-04,7.525100e-04,1.223600e-03,1.034200e-03, & - &9.333500e-04,8.618000e-04,7.896200e-04,8.453900e-04,9.822400e-04, & - &1.119600e-03,1.242400e-03,1.982300e-03,1.068400e-03,1.003800e-03, & - &9.428600e-04,9.923700e-04,1.223800e-03,1.467100e-03,1.701200e-03, & - &1.919400e-03,3.065700e-03,1.196400e-03,1.140400e-03,1.149500e-03, & - &1.390900e-03,1.763500e-03,2.139100e-03,2.516600e-03,2.855100e-03, & - &4.523300e-03,1.518800e-03,1.474200e-03,1.511300e-03,1.929600e-03, & - &2.475800e-03,3.028500e-03,3.569100e-03,4.102800e-03,6.462700e-03, & - &1.104900e-03,9.788700e-04,8.623000e-04,7.620900e-04,6.533700e-04, & - &5.566600e-04,5.564200e-04,4.345700e-04,1.660100e-03,1.094000e-03, & - &9.824100e-04,8.870400e-04,7.868300e-04,7.256500e-04,7.944700e-04, & - &8.911900e-04,9.657300e-04,2.830800e-03,1.087500e-03,9.970299e-04, & - &9.200900e-04,8.719500e-04,1.002200e-03,1.188800e-03,1.362800e-03, & - &1.515400e-03,4.511600e-03,1.115900e-03,1.044300e-03,1.008600e-03, & - &1.151200e-03,1.449500e-03,1.743700e-03,2.038000e-03,2.295600e-03, & - &6.799300e-03,1.228600e-03,1.176900e-03,1.246100e-03,1.598000e-03, & - &2.042100e-03,2.496100e-03,2.928900e-03,3.355900e-03,9.775200e-03/ - data absa(271:585,10) / & - &1.213700e-03,1.066800e-03,9.338100e-04,8.012600e-04,6.725500e-04, & - &5.482000e-04,4.164000e-04,3.086900e-05,2.341300e-03,1.184800e-03, & - &1.051700e-03,9.347900e-04,8.172700e-04,7.122400e-04,6.507800e-04, & - &7.034100e-04,7.096100e-04,4.181500e-03,1.172000e-03,1.053100e-03, & - &9.485600e-04,8.612900e-04,8.420800e-04,9.585400e-04,1.094300e-03, & - &1.204100e-03,6.920800e-03,1.159200e-03,1.075400e-03,9.955200e-04, & - &9.950401e-04,1.191900e-03,1.425600e-03,1.653100e-03,1.845500e-03, & - &1.082800e-02,1.173100e-03,1.110100e-03,1.108400e-03,1.332000e-03, & - &1.697400e-03,2.052800e-03,2.402300e-03,2.733900e-03,1.608000e-02, & - &1.330200e-03,1.165800e-03,1.013900e-03,8.565600e-04,7.072500e-04, & - &5.490500e-04,1.608200e-04,2.848400e-07,3.995900e-03,1.300400e-03, & - &1.146700e-03,1.001200e-03,8.638500e-04,7.250400e-04,6.128200e-04, & - &5.305700e-04,1.665600e-04,7.509500e-03,1.272300e-03,1.133200e-03, & - &1.008400e-03,8.864800e-04,8.049700e-04,7.690400e-04,8.588600e-04, & - &9.343600e-04,1.295600e-02,1.250400e-03,1.136100e-03,1.032000e-03, & - &9.667100e-04,9.904300e-04,1.153300e-03,1.332500e-03,1.484600e-03, & - &2.083300e-02,1.239300e-03,1.150800e-03,1.096200e-03,1.150900e-03, & - &1.406400e-03,1.690000e-03,1.973700e-03,2.234700e-03,3.162000e-02, & - &1.466300e-03,1.284500e-03,1.107600e-03,9.346900e-04,7.572700e-04, & - &5.830700e-04,1.614500e-06,2.059200e-07,1.257500e-02,1.435600e-03, & - &1.261500e-03,1.095500e-03,9.311000e-04,7.673200e-04,6.075700e-04, & - &4.474200e-04,4.946400e-06,2.496000e-02,1.405200e-03,1.243500e-03, & - &1.094000e-03,9.375600e-04,8.026900e-04,7.053300e-04,6.620800e-04, & - &5.969100e-04,4.494700e-02,1.373400e-03,1.233300e-03,1.094100e-03, & - &9.834500e-04,9.203500e-04,9.197600e-04,1.053000e-03,1.153200e-03, & - &7.504400e-02,1.349500e-03,1.228900e-03,1.132000e-03,1.107300e-03, & - &1.156100e-03,1.369200e-03,1.601400e-03,1.805500e-03,1.173000e-01, & - &1.618700e-03,1.417400e-03,1.215300e-03,1.023900e-03,8.281400e-04, & - &6.145300e-04,6.944400e-06,1.352800e-07,4.644200e-02,1.584500e-03, & - &1.387600e-03,1.204000e-03,1.015300e-03,8.273200e-04,6.306600e-04, & - &6.041400e-06,2.403800e-07,9.706100e-02,1.549600e-03,1.364900e-03, & - &1.191900e-03,1.016700e-03,8.382800e-04,6.932100e-04,5.624400e-04, & - &1.618000e-05,1.818200e-01,1.514300e-03,1.346000e-03,1.189400e-03, & - &1.032100e-03,9.214700e-04,8.336500e-04,8.463500e-04,8.952100e-04, & - &3.135200e-01,1.483400e-03,1.340300e-03,1.202200e-03,1.122400e-03, & - &1.073900e-03,1.131600e-03,1.321800e-03,1.483700e-03,5.023200e-01, & - &1.775700e-03,1.554100e-03,1.333100e-03,1.122200e-03,9.009300e-04, & - &6.609200e-04,2.124900e-07,1.190200e-07,8.498900e-02,1.740100e-03, & - &1.523600e-03,1.320900e-03,1.113100e-03,9.055100e-04,6.845600e-04, & - &5.084900e-06,2.248000e-07,1.766300e-01,1.706200e-03,1.502200e-03, & - &1.311700e-03,1.116500e-03,9.199900e-04,7.478300e-04,5.918600e-04, & - &1.921700e-05,3.295700e-01,1.671400e-03,1.485500e-03,1.308400e-03, & - &1.132700e-03,9.934100e-04,8.888200e-04,8.408100e-04,8.642100e-04, & - &5.654500e-01,1.641900e-03,1.479300e-03,1.319600e-03,1.214500e-03, & - &1.143300e-03,1.142400e-03,1.314800e-03,1.497300e-03,9.055500e-01, & - &1.987300e-03,1.739300e-03,1.492800e-03,1.252000e-03,1.006100e-03, & - &7.456900e-04,3.518000e-06,1.058700e-07,1.133800e-01,1.952000e-03, & - &1.711200e-03,1.478500e-03,1.243700e-03,1.010100e-03,7.590300e-04, & - &1.077500e-04,2.113500e-07,2.344500e-01,1.917400e-03,1.686700e-03, & - &1.468100e-03,1.245800e-03,1.023800e-03,8.162200e-04,6.420300e-04, & - &3.737700e-05,4.356000e-01,1.883400e-03,1.670900e-03,1.465700e-03, & - &1.262800e-03,1.085600e-03,9.486200e-04,8.608500e-04,8.943400e-04, & - &7.451200e-01,1.848600e-03,1.662500e-03,1.476900e-03,1.329800e-03, & - &1.218400e-03,1.174000e-03,1.312000e-03,1.505400e-03,1.191900e+00, & - &2.242700e-03,1.962600e-03,1.685800e-03,1.412300e-03,1.134500e-03, & - &8.481400e-04,1.118700e-05,1.016700e-07,1.186600e-01,2.212400e-03, & - &1.939500e-03,1.673400e-03,1.409400e-03,1.142100e-03,8.648000e-04, & - &5.269600e-04,2.895900e-06,2.443400e-01,2.177500e-03,1.915200e-03, & - &1.667400e-03,1.412100e-03,1.157700e-03,9.119300e-04,6.870800e-04, & - &6.094300e-05,4.528700e-01,2.140900e-03,1.898400e-03,1.662800e-03, & - &1.429000e-03,1.205000e-03,1.016100e-03,8.864200e-04,9.023100e-04, & - &7.745100e-01,2.100600e-03,1.885900e-03,1.673100e-03,1.478300e-03, & - &1.308100e-03,1.219900e-03,1.304500e-03,1.508200e-03,1.240500e+00/ - data absa(1:270,11) / & - &1.325962e-03,1.249287e-03,1.491464e-03,2.069130e-03,2.689546e-03, & - &3.306551e-03,3.887068e-03,4.457124e-03,5.073887e-03,1.642315e-03, & - &1.583647e-03,2.017058e-03,2.868297e-03,3.738513e-03,4.629565e-03, & - &5.489873e-03,6.383059e-03,7.330043e-03,2.109774e-03,2.034941e-03, & - &2.752569e-03,3.959659e-03,5.172835e-03,6.380259e-03,7.515063e-03, & - &8.860644e-03,1.009791e-02,2.734355e-03,2.622701e-03,3.637120e-03, & - &5.253813e-03,6.945313e-03,8.577446e-03,1.008203e-02,1.156637e-02, & - &1.318023e-02,3.517210e-03,3.365894e-03,4.728201e-03,6.877440e-03, & - &9.016803e-03,1.097905e-02,1.304732e-02,1.500333e-02,1.698572e-02, & - &1.242164e-03,1.162446e-03,1.325610e-03,1.803747e-03,2.334982e-03, & - &2.864989e-03,3.492800e-03,3.971275e-03,4.625278e-03,1.524527e-03, & - &1.462683e-03,1.859955e-03,2.633360e-03,3.430828e-03,4.187349e-03, & - &4.955145e-03,5.791893e-03,6.505001e-03,1.947373e-03,1.880147e-03, & - &2.533041e-03,3.630747e-03,4.752726e-03,5.868236e-03,7.011444e-03, & - &7.945241e-03,9.179868e-03,2.545978e-03,2.437036e-03,3.387252e-03, & - &4.893770e-03,6.451441e-03,7.975071e-03,9.404968e-03,1.079094e-02, & - &1.249722e-02,3.304871e-03,3.159323e-03,4.464099e-03,6.479045e-03, & - &8.506626e-03,1.038585e-02,1.227530e-02,1.412904e-02,1.650107e-02, & - &1.134877e-03,1.038037e-03,1.127444e-03,1.496526e-03,1.927646e-03, & - &2.336244e-03,2.845663e-03,3.162676e-03,3.674482e-03,1.311685e-03, & - &1.250375e-03,1.578322e-03,2.205164e-03,2.867493e-03,3.541046e-03, & - &4.178529e-03,4.766332e-03,5.601964e-03,1.627180e-03,1.584801e-03, & - &2.148620e-03,3.140882e-03,4.104920e-03,5.066561e-03,5.959271e-03, & - &6.745647e-03,7.974254e-03,2.111176e-03,2.049931e-03,2.897183e-03, & - &4.188173e-03,5.609360e-03,6.933711e-03,8.271435e-03,9.345308e-03, & - &1.081534e-02,2.771158e-03,2.684649e-03,3.882012e-03,5.636830e-03, & - &7.408676e-03,9.065345e-03,1.090471e-02,1.242278e-02,1.464134e-02, & - &1.116009e-03,1.007171e-03,9.926320e-04,1.218284e-03,1.552272e-03, & - &1.873597e-03,2.182021e-03,2.477051e-03,2.926200e-03,1.181025e-03, & - &1.089151e-03,1.308881e-03,1.792412e-03,2.327370e-03,2.813854e-03, & - &3.373254e-03,3.843868e-03,4.560623e-03,1.352918e-03,1.329294e-03, & - &1.800435e-03,2.588777e-03,3.372719e-03,4.201486e-03,4.935722e-03, & - &5.675645e-03,6.637818e-03,1.709749e-03,1.730011e-03,2.517878e-03, & - &3.639286e-03,4.722535e-03,5.830975e-03,7.012612e-03,7.977604e-03, & - &9.251479e-03,2.237321e-03,2.259022e-03,3.341860e-03,4.875937e-03, & - &6.421443e-03,8.022436e-03,9.423494e-03,1.070460e-02,1.271650e-02, & - &1.174387e-03,1.052473e-03,9.586673e-04,1.021745e-03,1.216488e-03, & - &1.456567e-03,1.686049e-03,1.901634e-03,2.285791e-03,1.173679e-03, & - &1.067172e-03,1.138285e-03,1.453429e-03,1.877661e-03,2.249976e-03, & - &2.709209e-03,3.065067e-03,3.673786e-03,1.225446e-03,1.165433e-03, & - &1.528846e-03,2.131582e-03,2.764705e-03,3.445106e-03,4.065895e-03, & - &4.634668e-03,5.558650e-03,1.390615e-03,1.459538e-03,2.138017e-03, & - &3.072876e-03,4.007330e-03,4.909698e-03,5.879972e-03,6.685129e-03, & - &8.052811e-03,1.776990e-03,1.895248e-03,2.899912e-03,4.217047e-03, & - &5.548888e-03,6.913817e-03,8.148940e-03,9.278436e-03,1.124282e-02, & - &1.280442e-03,1.134904e-03,1.007051e-03,9.357539e-04,9.671840e-04, & - &1.093016e-03,1.272096e-03,1.396037e-03,2.149975e-03,1.250197e-03, & - &1.124779e-03,1.077755e-03,1.200195e-03,1.476543e-03,1.773752e-03, & - &2.091880e-03,2.348727e-03,3.649681e-03,1.243962e-03,1.148736e-03, & - &1.323802e-03,1.753392e-03,2.232621e-03,2.763613e-03,3.250112e-03, & - &3.668949e-03,5.843470e-03,1.272483e-03,1.289295e-03,1.795222e-03, & - &2.557495e-03,3.310461e-03,4.083858e-03,4.836045e-03,5.507929e-03, & - &8.885028e-03,1.411987e-03,1.590109e-03,2.500189e-03,3.617233e-03, & - &4.711591e-03,5.845557e-03,6.875664e-03,7.798348e-03,1.290161e-02/ - data absa(271:585,11) / & - &1.408449e-03,1.233344e-03,1.088746e-03,9.457538e-04,8.641093e-04, & - &8.532602e-04,9.381629e-04,8.308603e-04,2.935158e-03,1.370938e-03, & - &1.225508e-03,1.106608e-03,1.087771e-03,1.178702e-03,1.372840e-03, & - &1.576899e-03,1.765252e-03,5.291611e-03,1.340112e-03,1.216624e-03, & - &1.246616e-03,1.456872e-03,1.805076e-03,2.174272e-03,2.552228e-03, & - &2.874283e-03,8.844023e-03,1.330902e-03,1.275643e-03,1.560125e-03, & - &2.117334e-03,2.717740e-03,3.337655e-03,3.895413e-03,4.457247e-03, & - &1.389660e-02,1.346866e-03,1.437707e-03,2.125165e-03,3.049206e-03, & - &3.949089e-03,4.856580e-03,5.737183e-03,6.485823e-03,2.072699e-02, & - &1.563815e-03,1.367164e-03,1.194043e-03,1.021299e-03,8.573051e-04, & - &7.481287e-04,6.707135e-04,1.693236e-04,5.289671e-03,1.521125e-03, & - &1.348581e-03,1.194139e-03,1.076686e-03,1.036233e-03,1.082559e-03, & - &1.203480e-03,1.284344e-03,1.006241e-02,1.482778e-03,1.337527e-03, & - &1.259377e-03,1.295825e-03,1.454788e-03,1.720964e-03,2.006199e-03, & - &2.229741e-03,1.756585e-02,1.452897e-03,1.355360e-03,1.445922e-03, & - &1.751047e-03,2.205018e-03,2.681323e-03,3.138840e-03,3.538833e-03, & - &2.857489e-02,1.434686e-03,1.432755e-03,1.841857e-03,2.540793e-03, & - &3.278775e-03,4.018369e-03,4.735787e-03,5.380164e-03,4.389973e-02, & - &1.744874e-03,1.526816e-03,1.314385e-03,1.119286e-03,9.183815e-04, & - &7.203826e-04,2.650764e-04,1.573309e-07,1.773275e-02,1.697967e-03, & - &1.488386e-03,1.314156e-03,1.136495e-03,9.928548e-04,9.160729e-04, & - &8.923662e-04,6.115086e-04,3.569387e-02,1.655010e-03,1.480662e-03, & - &1.337886e-03,1.252939e-03,1.246599e-03,1.363581e-03,1.556766e-03, & - &1.683375e-03,6.525122e-02,1.618218e-03,1.474055e-03,1.440759e-03, & - &1.538209e-03,1.790990e-03,2.155088e-03,2.506275e-03,2.800147e-03, & - &1.103589e-01,1.585931e-03,1.523993e-03,1.683134e-03,2.112384e-03, & - &2.702801e-03,3.317115e-03,3.879006e-03,4.372522e-03,1.747978e-01, & - &1.945191e-03,1.702575e-03,1.458965e-03,1.232169e-03,1.005156e-03, & - &7.631638e-04,1.383339e-07,1.304386e-07,6.985086e-02,1.897430e-03, & - &1.659691e-03,1.453158e-03,1.240690e-03,1.039846e-03,8.669755e-04, & - &5.792934e-04,7.764109e-05,1.481177e-01,1.853333e-03,1.646455e-03, & - &1.458282e-03,1.299559e-03,1.188588e-03,1.162772e-03,1.233084e-03, & - &1.193879e-03,2.827057e-01,1.812912e-03,1.633728e-03,1.523210e-03, & - &1.479550e-03,1.564354e-03,1.780893e-03,2.071307e-03,2.252206e-03, & - &4.944142e-01,1.775187e-03,1.667445e-03,1.668916e-03,1.879285e-03, & - &2.280393e-03,2.788885e-03,3.245376e-03,3.624814e-03,8.048866e-01, & - &2.161958e-03,1.890517e-03,1.621811e-03,1.369552e-03,1.115165e-03, & - &8.489970e-04,1.241115e-07,1.167363e-07,1.383722e-01,2.110596e-03, & - &1.846389e-03,1.615416e-03,1.379763e-03,1.153100e-03,9.452966e-04, & - &5.333265e-04,4.108870e-05,2.930288e-01,2.064586e-03,1.833746e-03, & - &1.622066e-03,1.440994e-03,1.287248e-03,1.229121e-03,1.253364e-03, & - &1.122125e-03,5.582275e-01,2.021180e-03,1.820079e-03,1.687735e-03, & - &1.597468e-03,1.647900e-03,1.835468e-03,2.110975e-03,2.284705e-03, & - &9.752542e-01,1.979315e-03,1.854954e-03,1.810590e-03,1.977923e-03, & - &2.341667e-03,2.828581e-03,3.310202e-03,3.679471e-03,1.583145e+00, & - &2.418506e-03,2.114725e-03,1.813572e-03,1.531973e-03,1.245856e-03, & - &9.475662e-04,8.796742e-06,1.060433e-07,2.028853e-01,2.364347e-03, & - &2.069800e-03,1.806722e-03,1.541082e-03,1.286037e-03,1.038145e-03, & - &7.705629e-04,8.701030e-05,4.287580e-01,2.315585e-03,2.053906e-03, & - &1.813165e-03,1.604040e-03,1.404754e-03,1.308325e-03,1.307617e-03, & - &1.189650e-03,8.136923e-01,2.268873e-03,2.035693e-03,1.874226e-03, & - &1.732148e-03,1.740587e-03,1.894666e-03,2.155267e-03,2.350542e-03, & - &1.417793e+00,2.223195e-03,2.066060e-03,1.973812e-03,2.085546e-03, & - &2.418758e-03,2.887853e-03,3.387216e-03,3.774501e-03,2.299890e+00, & - &2.734630e-03,2.392998e-03,2.051595e-03,1.730484e-03,1.403283e-03, & - &1.068160e-03,4.623402e-05,9.300959e-08,2.359879e-01,2.674386e-03, & - &2.341977e-03,2.037121e-03,1.731731e-03,1.438258e-03,1.149295e-03, & - &8.764660e-04,1.836520e-04,4.973328e-01,2.617805e-03,2.318014e-03, & - &2.037642e-03,1.786957e-03,1.540280e-03,1.391317e-03,1.362059e-03, & - &1.310565e-03,9.409367e-01,2.564884e-03,2.291556e-03,2.088476e-03, & - &1.891222e-03,1.845596e-03,1.957771e-03,2.203779e-03,2.417031e-03, & - &1.635006e+00,2.512622e-03,2.311104e-03,2.168805e-03,2.217354e-03, & - &2.505376e-03,2.946841e-03,3.452772e-03,3.865037e-03,2.646232e+00/ - data absa(1:270,12) / & - &1.537657e-03,1.959896e-03,3.811518e-03,5.610160e-03,7.385786e-03, & - &9.122610e-03,1.074022e-02,1.193670e-02,1.355311e-02,1.890973e-03, & - &2.808933e-03,5.374570e-03,7.926714e-03,1.044979e-02,1.287135e-02, & - &1.518843e-02,1.738288e-02,1.967810e-02,2.358206e-03,3.898316e-03, & - &7.488875e-03,1.105404e-02,1.457885e-02,1.802997e-02,2.116003e-02, & - &2.420047e-02,2.750078e-02,2.951259e-03,5.235412e-03,1.008183e-02, & - &1.489834e-02,1.954664e-02,2.417238e-02,2.854820e-02,3.167555e-02, & - &3.598969e-02,3.700732e-03,6.779675e-03,1.315342e-02,1.947236e-02, & - &2.571160e-02,3.165558e-02,3.739366e-02,4.163278e-02,4.704407e-02, & - &1.442383e-03,1.927846e-03,3.702869e-03,5.411468e-03,7.135367e-03, & - &8.818437e-03,1.068001e-02,1.180342e-02,1.402143e-02,1.777662e-03, & - &2.822055e-03,5.438806e-03,8.036711e-03,1.060461e-02,1.307222e-02, & - &1.523205e-02,1.750844e-02,2.014527e-02,2.218376e-03,4.000702e-03, & - &7.665064e-03,1.134183e-02,1.497346e-02,1.852029e-02,2.178207e-02, & - &2.407790e-02,2.854146e-02,2.782873e-03,5.407522e-03,1.050277e-02, & - &1.556307e-02,2.044803e-02,2.530798e-02,2.966825e-02,3.294616e-02, & - &3.894316e-02,3.516450e-03,7.102575e-03,1.381388e-02,2.045261e-02, & - &2.704279e-02,3.344897e-02,3.903461e-02,4.331828e-02,5.159982e-02, & - &1.272116e-03,1.730114e-03,3.299123e-03,4.916645e-03,6.483736e-03, & - &7.854693e-03,9.568170e-03,1.044425e-02,1.276528e-02,1.546363e-03, & - &2.610239e-03,5.064118e-03,7.496617e-03,9.895070e-03,1.216135e-02, & - &1.449902e-02,1.590536e-02,1.962252e-02,1.922830e-03,3.741936e-03, & - &7.198631e-03,1.087606e-02,1.436926e-02,1.776519e-02,2.077501e-02, & - &2.244369e-02,2.823601e-02,2.396435e-03,5.086682e-03,9.936371e-03, & - &1.474600e-02,2.002142e-02,2.475932e-02,2.899365e-02,3.137608e-02, & - &3.859947e-02,3.009276e-03,6.825740e-03,1.330912e-02,1.979957e-02, & - &2.618616e-02,3.222379e-02,3.849262e-02,4.234373e-02,5.188838e-02, & - &1.241533e-03,1.476259e-03,2.882463e-03,4.287082e-03,5.653923e-03, & - &6.847462e-03,7.998343e-03,8.798569e-03,1.108578e-02,1.347956e-03, & - &2.276347e-03,4.433021e-03,6.569740e-03,8.709664e-03,1.064611e-02, & - &1.275001e-02,1.387898e-02,1.758888e-02,1.644028e-03,3.369657e-03, & - &6.489915e-03,9.777246e-03,1.291160e-02,1.609003e-02,1.875870e-02, & - &2.064690e-02,2.619337e-02,2.039044e-03,4.826785e-03,9.459605e-03, & - &1.405257e-02,1.844698e-02,2.279856e-02,2.682794e-02,2.948268e-02, & - &3.623224e-02,2.539608e-03,6.398065e-03,1.256922e-02,1.861926e-02, & - &2.468735e-02,3.130972e-02,3.626431e-02,3.961658e-02,4.956681e-02, & - &1.343139e-03,1.340343e-03,2.391811e-03,3.551446e-03,4.691030e-03, & - &5.656135e-03,6.583008e-03,7.255180e-03,9.255610e-03,1.329396e-03, & - &1.961064e-03,3.825344e-03,5.634125e-03,7.593252e-03,9.105633e-03, & - &1.077957e-02,1.194098e-02,1.499919e-02,1.436179e-03,2.975102e-03, & - &5.711853e-03,8.710316e-03,1.150218e-02,1.399329e-02,1.678951e-02, & - &1.807670e-02,2.343319e-02,1.716133e-03,4.255512e-03,8.358980e-03, & - &1.278065e-02,1.684638e-02,2.068157e-02,2.386368e-02,2.649789e-02, & - &3.295761e-02,2.117083e-03,5.771018e-03,1.133949e-02,1.686319e-02, & - &2.273731e-02,2.821616e-02,3.336986e-02,3.625785e-02,4.518827e-02, & - &1.479189e-03,1.310302e-03,1.871596e-03,2.809488e-03,3.591034e-03, & - &4.381047e-03,5.217120e-03,5.636578e-03,7.432350e-03,1.451128e-03, & - &1.684377e-03,3.150132e-03,4.553039e-03,6.260583e-03,7.546176e-03, & - &8.786043e-03,9.705262e-03,1.235432e-02,1.428573e-03,2.525659e-03, & - &4.833355e-03,7.314646e-03,9.807327e-03,1.183360e-02,1.426600e-02, & - &1.506497e-02,1.977937e-02,1.502884e-03,3.698850e-03,7.259358e-03, & - &1.103205e-02,1.411511e-02,1.777366e-02,2.072382e-02,2.274195e-02, & - &2.886797e-02,1.756770e-03,5.317668e-03,1.044077e-02,1.552585e-02, & - &2.026921e-02,2.513089e-02,2.972296e-02,3.202549e-02,4.190555e-02/ - data absa(271:585,12) / & - &1.657190e-03,1.451599e-03,1.569660e-03,2.104497e-03,2.720390e-03, & - &3.310839e-03,3.939521e-03,4.226417e-03,5.767663e-03,1.628459e-03, & - &1.578099e-03,2.495581e-03,3.616930e-03,4.935515e-03,5.988602e-03, & - &6.868803e-03,7.646835e-03,1.042341e-02,1.597460e-03,2.185083e-03, & - &4.181803e-03,6.049656e-03,8.022441e-03,9.832880e-03,1.163445e-02, & - &1.228162e-02,1.694615e-02,1.574125e-03,3.235100e-03,6.223224e-03, & - &9.437010e-03,1.206715e-02,1.517242e-02,1.771512e-02,1.915905e-02, & - &2.682050e-02,1.608747e-03,4.786531e-03,9.373304e-03,1.368338e-02, & - &1.825693e-02,2.226599e-02,2.588931e-02,2.767466e-02,3.925800e-02, & - &1.884648e-03,1.650198e-03,1.494849e-03,1.676408e-03,2.044093e-03, & - &2.537830e-03,2.873089e-03,3.073193e-03,6.562015e-03,1.859329e-03, & - &1.640936e-03,2.087061e-03,2.876293e-03,3.867231e-03,4.647051e-03, & - &5.296759e-03,5.706501e-03,1.257015e-02,1.823227e-03,2.040851e-03, & - &3.448777e-03,4.951488e-03,6.575783e-03,8.028016e-03,9.393157e-03, & - &1.002203e-02,2.189716e-02,1.792676e-03,2.811400e-03,5.350262e-03, & - &7.951865e-03,1.031960e-02,1.266989e-02,1.486031e-02,1.582302e-02, & - &3.590522e-02,1.759341e-03,4.101687e-03,8.264487e-03,1.188426e-02, & - &1.601728e-02,1.942820e-02,2.236299e-02,2.437512e-02,5.505465e-02, & - &2.165386e-03,1.895870e-03,1.626391e-03,1.509474e-03,1.572041e-03, & - &1.855111e-03,2.012546e-03,1.479046e-03,2.262254e-02,2.134712e-03, & - &1.864042e-03,1.912245e-03,2.276681e-03,2.906797e-03,3.524515e-03, & - &4.047508e-03,4.173548e-03,4.568959e-02,2.095871e-03,2.006031e-03, & - &2.786761e-03,3.985029e-03,5.284299e-03,6.357008e-03,7.421349e-03, & - &7.746039e-03,8.375267e-02,2.062974e-03,2.582853e-03,4.497452e-03, & - &6.656753e-03,8.586695e-03,1.050010e-02,1.222092e-02,1.273999e-02, & - &1.420749e-01,2.027760e-03,3.580557e-03,7.209326e-03,1.029570e-02, & - &1.360231e-02,1.656669e-02,1.912220e-02,2.027212e-02,2.268230e-01, & - &2.512589e-03,2.197731e-03,1.881830e-03,1.580520e-03,1.425644e-03, & - &1.439437e-03,1.394550e-03,1.127755e-07,9.304326e-02,2.467070e-03, & - &2.159013e-03,1.948550e-03,2.071478e-03,2.327714e-03,2.764921e-03, & - &3.102536e-03,3.075278e-03,1.977277e-01,2.426967e-03,2.164952e-03, & - &2.549090e-03,3.355579e-03,4.357694e-03,5.159634e-03,5.786641e-03, & - &6.042825e-03,3.793513e-01,2.382580e-03,2.565850e-03,3.953529e-03, & - &5.616020e-03,7.565228e-03,8.829912e-03,1.009939e-02,1.032703e-02, & - &6.656885e-01,2.339301e-03,3.346127e-03,6.413419e-03,9.291318e-03, & - &1.193747e-02,1.437554e-02,1.637593e-02,1.693951e-02,1.091090e+00, & - &2.892787e-03,2.530207e-03,2.164348e-03,1.820375e-03,1.627317e-03, & - &1.570859e-03,1.381164e-03,9.851049e-08,1.936284e-01,2.844441e-03, & - &2.486938e-03,2.240266e-03,2.323355e-03,2.565665e-03,2.968338e-03, & - &3.254560e-03,3.183476e-03,4.127110e-01,2.793201e-03,2.498082e-03, & - &2.896206e-03,3.629475e-03,4.681349e-03,5.560433e-03,6.044164e-03, & - &6.203840e-03,7.917160e-01,2.738773e-03,2.900034e-03,4.308974e-03, & - &6.060017e-03,8.123966e-03,9.573402e-03,1.054456e-02,1.059794e-02, & - &1.392676e+00,2.683617e-03,3.717604e-03,6.832369e-03,1.003964e-02, & - &1.265430e-02,1.545764e-02,1.716246e-02,1.739364e-02,2.278077e+00, & - &3.325676e-03,2.907767e-03,2.495194e-03,2.099480e-03,1.855009e-03, & - &1.747943e-03,1.622284e-03,8.745635e-08,3.011011e-01,3.266678e-03, & - &2.859351e-03,2.582736e-03,2.600746e-03,2.817423e-03,3.208058e-03, & - &3.451278e-03,3.330482e-03,6.426215e-01,3.208794e-03,2.882807e-03, & - &3.268509e-03,3.960909e-03,5.017800e-03,5.983141e-03,6.579643e-03, & - &6.402391e-03,1.230192e+00,3.146629e-03,3.305402e-03,4.696484e-03, & - &6.825639e-03,8.619955e-03,1.030257e-02,1.136962e-02,1.121089e-02, & - &2.161481e+00,3.087773e-03,4.166378e-03,7.426636e-03,1.083865e-02, & - &1.362604e-02,1.664830e-02,1.826014e-02,1.809311e-02,3.548143e+00, & - &3.806660e-03,3.330996e-03,2.855162e-03,2.412209e-03,2.116039e-03, & - &1.917812e-03,1.801931e-03,5.544458e-04,3.763658e-01,3.735675e-03, & - &3.268370e-03,2.964320e-03,2.934557e-03,3.095650e-03,3.436266e-03, & - &3.663045e-03,3.595426e-03,8.020004e-01,3.676418e-03,3.320089e-03, & - &3.601532e-03,4.336202e-03,5.399913e-03,6.414038e-03,7.010922e-03, & - &6.780417e-03,1.533964e+00,3.607564e-03,3.781472e-03,5.179668e-03, & - &7.379516e-03,9.274062e-03,1.094039e-02,1.210004e-02,1.185057e-02, & - &2.696185e+00,3.538537e-03,4.665185e-03,8.098111e-03,1.167712e-02, & - &1.474710e-02,1.767478e-02,1.942396e-02,1.916787e-02,4.422723e+00/ - -! the array absb(235,NG07) = kb(5,13:59,NG07) contains absorption coefs -! at the NG07=12 chosen g-values for a range of pressure levels<~100mb -! and temperatures. the first index in the array, jt, which runs from -! 1 to 5, corresponds to different temperatures. more specifically, -! jt = 1-5 means that the data are for the corresponding temperature -! of tref-30, tref-15, tref, tref+15, and tref+30, respectively. the -! second index, jp, runs from 13 to 59 and refers to the jpth reference -! pressure level (see taumol.f for the value of these pressure levels -! in mb). the third index, ig, goes from 1 to NG07=12, and tells us -! which g-interval the absorption coefficients are for. - - data absb(:,1) / & - &1.599204e-01,2.166390e-01,2.863340e-01,3.685768e-01,4.632798e-01, & - &1.483893e-01,1.998040e-01,2.618853e-01,3.343055e-01,4.167541e-01, & - &1.373043e-01,1.839369e-01,2.392765e-01,3.031418e-01,3.749084e-01, & - &1.265637e-01,1.688184e-01,2.183964e-01,2.749244e-01,3.373496e-01, & - &1.154123e-01,1.533346e-01,1.974165e-01,2.470412e-01,3.011120e-01, & - &1.041445e-01,1.378236e-01,1.766025e-01,2.197341e-01,2.658059e-01, & - &9.296690e-02,1.224668e-01,1.561075e-01,1.928476e-01,2.314235e-01, & - &8.273488e-02,1.083241e-01,1.370162e-01,1.680430e-01,1.998847e-01, & - &7.306092e-02,9.490441e-02,1.191115e-01,1.449089e-01,1.708600e-01, & - &6.512561e-02,8.371997e-02,1.040681e-01,1.252125e-01,1.461557e-01, & - &5.762261e-02,7.331179e-02,9.017352e-02,1.073130e-01,1.240873e-01, & - &5.068522e-02,6.378756e-02,7.759134e-02,9.140172e-02,1.049079e-01, & - &4.437416e-02,5.520730e-02,6.641583e-02,7.761313e-02,8.852404e-02, & - &3.874617e-02,4.764684e-02,5.677947e-02,6.586494e-02,7.470515e-02, & - &3.365077e-02,4.097520e-02,4.843586e-02,5.582197e-02,6.299964e-02, & - &2.910503e-02,3.514419e-02,4.124302e-02,4.725048e-02,5.308315e-02, & - &2.515626e-02,3.012952e-02,3.512551e-02,4.003017e-02,4.478574e-02, & - &2.170011e-02,2.579661e-02,2.989283e-02,3.390849e-02,3.778100e-02, & - &1.871590e-02,2.209564e-02,2.546039e-02,2.876140e-02,3.191250e-02, & - &1.612715e-02,1.891810e-02,2.169153e-02,2.439636e-02,2.696111e-02, & - &1.388747e-02,1.619871e-02,1.847913e-02,2.069010e-02,2.277261e-02, & - &1.187502e-02,1.377864e-02,1.565143e-02,1.745054e-02,1.914918e-02, & - &9.991425e-03,1.155852e-02,1.309845e-02,1.457339e-02,1.596933e-02, & - &8.259946e-03,9.552713e-03,1.082299e-02,1.204155e-02,1.319699e-02, & - &6.659991e-03,7.728572e-03,8.779028e-03,9.791073e-03,1.075626e-02, & - &5.364533e-03,6.246865e-03,7.117568e-03,7.960157e-03,8.763694e-03, & - &4.324146e-03,5.053347e-03,5.775491e-03,6.478938e-03,7.151826e-03, & - &3.415623e-03,4.014776e-03,4.612406e-03,5.199176e-03,5.761415e-03, & - &2.687945e-03,3.179425e-03,3.672704e-03,4.161143e-03,4.631422e-03, & - &2.112054e-03,2.515082e-03,2.922687e-03,3.328343e-03,3.721527e-03, & - &1.638535e-03,1.968382e-03,2.304435e-03,2.640815e-03,2.971002e-03, & - &1.261385e-03,1.530488e-03,1.807414e-03,2.086564e-03,2.363549e-03, & - &9.689092e-04,1.188042e-03,1.415545e-03,1.646802e-03,1.878650e-03, & - &7.384197e-04,9.154535e-04,1.101646e-03,1.293271e-03,1.486582e-03, & - &5.544622e-04,6.960288e-04,8.477840e-04,1.005562e-03,1.166351e-03, & - &4.144578e-04,5.273172e-04,6.508009e-04,7.806026e-04,9.142413e-04, & - &3.087455e-04,3.984309e-04,4.983316e-04,6.053299e-04,7.163624e-04, & - &2.300160e-04,3.007705e-04,3.808781e-04,4.683223e-04,5.599327e-04, & - &1.709061e-04,2.264144e-04,2.903085e-04,3.612602e-04,4.363973e-04, & - &1.263145e-04,1.699498e-04,2.207318e-04,2.780683e-04,3.398375e-04, & - &9.291747e-05,1.271903e-04,1.674519e-04,2.137149e-04,2.645920e-04, & - &6.829424e-05,9.495068e-05,1.264480e-04,1.631334e-04,2.041430e-04, & - &5.005390e-05,7.056614e-05,9.504611e-05,1.237531e-04,1.563252e-04, & - &3.653220e-05,5.223362e-05,7.126480e-05,9.366409e-05,1.193380e-04, & - &2.653131e-05,3.849647e-05,5.326907e-05,7.068380e-05,9.087801e-05, & - &1.928479e-05,2.839786e-05,3.980974e-05,5.335479e-05,6.917195e-05, & - &1.499739e-05,2.215442e-05,3.113060e-05,4.177661e-05,5.415743e-05/ - data absb(:,2) / & - &2.171933e+00,2.425920e+00,2.682999e+00,2.935479e+00,3.187725e+00, & - &1.934883e+00,2.157399e+00,2.383029e+00,2.607604e+00,2.832766e+00, & - &1.722407e+00,1.917923e+00,2.118823e+00,2.320383e+00,2.521548e+00, & - &1.532326e+00,1.707455e+00,1.887110e+00,2.067165e+00,2.247815e+00, & - &1.361393e+00,1.517766e+00,1.677197e+00,1.836958e+00,1.998960e+00, & - &1.206443e+00,1.345128e+00,1.485056e+00,1.627473e+00,1.771516e+00, & - &1.064759e+00,1.186213e+00,1.309967e+00,1.436219e+00,1.562378e+00, & - &9.372613e-01,1.044161e+00,1.153799e+00,1.264278e+00,1.373796e+00, & - &8.212930e-01,9.153628e-01,1.011476e+00,1.107270e+00,1.201023e+00, & - &7.216596e-01,8.043218e-01,8.875690e-01,9.696758e-01,1.049015e+00, & - &6.314980e-01,7.030139e-01,7.745373e-01,8.441579e-01,9.097636e-01, & - &5.498006e-01,6.113513e-01,6.721516e-01,7.299209e-01,7.827060e-01, & - &4.769047e-01,5.292305e-01,5.795414e-01,6.262807e-01,6.684465e-01, & - &4.126970e-01,4.561740e-01,4.969777e-01,5.341142e-01,5.672675e-01, & - &3.556649e-01,3.910112e-01,4.235884e-01,4.528145e-01,4.785284e-01, & - &3.050318e-01,3.334817e-01,3.591464e-01,3.818918e-01,4.017011e-01, & - &2.606831e-01,2.832879e-01,3.032921e-01,3.209590e-01,3.364855e-01, & - &2.219234e-01,2.396217e-01,2.551901e-01,2.691175e-01,2.814601e-01, & - &1.882766e-01,2.020543e-01,2.143690e-01,2.254682e-01,2.354423e-01, & - &1.591759e-01,1.700327e-01,1.798922e-01,1.888443e-01,1.969914e-01, & - &1.342536e-01,1.429620e-01,1.509274e-01,1.582435e-01,1.649810e-01, & - &1.127912e-01,1.198664e-01,1.263573e-01,1.324230e-01,1.379834e-01, & - &9.413733e-02,9.996228e-02,1.053606e-01,1.104291e-01,1.150324e-01, & - &7.804018e-02,8.289827e-02,8.743177e-02,9.168031e-02,9.552553e-02, & - &6.405057e-02,6.815554e-02,7.199167e-02,7.555173e-02,7.881276e-02, & - &5.256679e-02,5.603407e-02,5.927401e-02,6.227659e-02,6.500009e-02, & - &4.317197e-02,4.610234e-02,4.883761e-02,5.136101e-02,5.366448e-02, & - &3.516199e-02,3.762541e-02,3.994454e-02,4.207854e-02,4.403620e-02, & - &2.860096e-02,3.067823e-02,3.263078e-02,3.443576e-02,3.610777e-02, & - &2.325441e-02,2.500549e-02,2.665705e-02,2.818402e-02,2.960491e-02, & - &1.881906e-02,2.029448e-02,2.169304e-02,2.298990e-02,2.420815e-02, & - &1.518475e-02,1.643113e-02,1.762087e-02,1.872875e-02,1.977057e-02, & - &1.224255e-02,1.329931e-02,1.430926e-02,1.525229e-02,1.614530e-02, & - &9.839009e-03,1.073506e-02,1.158873e-02,1.239640e-02,1.316146e-02, & - &7.857252e-03,8.619013e-03,9.343905e-03,1.003387e-02,1.069089e-02, & - &6.262287e-03,6.910623e-03,7.528572e-03,8.120939e-03,8.684423e-03, & - &4.981582e-03,5.535986e-03,6.063617e-03,6.570593e-03,7.055112e-03, & - &3.962080e-03,4.431592e-03,4.879799e-03,5.311123e-03,5.724842e-03, & - &3.146346e-03,3.541940e-03,3.922230e-03,4.287563e-03,4.639909e-03, & - &2.492404e-03,2.826020e-03,3.149001e-03,3.458920e-03,3.759440e-03, & - &1.970167e-03,2.251083e-03,2.525644e-03,2.789181e-03,3.046001e-03, & - &1.556919e-03,1.790697e-03,2.021317e-03,2.242869e-03,2.458286e-03, & - &1.228734e-03,1.422025e-03,1.613974e-03,1.799064e-03,1.978462e-03, & - &9.674862e-04,1.127449e-03,1.286877e-03,1.441560e-03,1.590595e-03, & - &7.596993e-04,8.921480e-04,1.024373e-03,1.153573e-03,1.277952e-03, & - &5.963471e-04,7.061183e-04,8.153759e-04,9.229260e-04,1.026552e-03, & - &4.825003e-04,5.725274e-04,6.616150e-04,7.496016e-04,8.341466e-04/ - data absb(:,3) / & - &6.914100e+00,7.154500e+00,7.404600e+00,7.683300e+00,7.943200e+00, & - &6.075500e+00,6.298700e+00,6.530600e+00,6.787300e+00,7.027800e+00, & - &5.311600e+00,5.526900e+00,5.751200e+00,5.983500e+00,6.211700e+00, & - &4.634300e+00,4.844900e+00,5.058500e+00,5.283700e+00,5.506900e+00, & - &4.041900e+00,4.243000e+00,4.450800e+00,4.671800e+00,4.882100e+00, & - &3.528100e+00,3.719600e+00,3.925400e+00,4.128900e+00,4.325000e+00, & - &3.085900e+00,3.269700e+00,3.459400e+00,3.642800e+00,3.827900e+00, & - &2.707300e+00,2.876800e+00,3.045000e+00,3.212900e+00,3.388000e+00, & - &2.373700e+00,2.524700e+00,2.675700e+00,2.832700e+00,2.996000e+00, & - &2.085700e+00,2.219900e+00,2.359100e+00,2.503900e+00,2.651900e+00, & - &1.828900e+00,1.951200e+00,2.077800e+00,2.208100e+00,2.343600e+00, & - &1.601400e+00,1.712200e+00,1.826600e+00,1.945400e+00,2.068400e+00, & - &1.399800e+00,1.499900e+00,1.604800e+00,1.713800e+00,1.821700e+00, & - &1.221000e+00,1.313200e+00,1.409700e+00,1.507000e+00,1.601100e+00, & - &1.063300e+00,1.147700e+00,1.234300e+00,1.319700e+00,1.401300e+00, & - &9.247100e-01,1.000300e+00,1.076200e+00,1.150600e+00,1.220700e+00, & - &8.037800e-01,8.699100e-01,9.357100e-01,9.991800e-01,1.057900e+00, & - &6.974500e-01,7.548100e-01,8.112400e-01,8.639400e-01,9.113200e-01, & - &6.046500e-01,6.542000e-01,7.012900e-01,7.441500e-01,7.822000e-01, & - &5.238900e-01,5.657600e-01,6.040800e-01,6.388800e-01,6.701800e-01, & - &4.533900e-01,4.877700e-01,5.189500e-01,5.477800e-01,5.741300e-01, & - &3.904300e-01,4.183800e-01,4.443600e-01,4.685900e-01,4.915000e-01, & - &3.330400e-01,3.564100e-01,3.783700e-01,3.993700e-01,4.196900e-01, & - &2.815900e-01,3.014600e-01,3.204200e-01,3.389400e-01,3.572100e-01, & - &2.352800e-01,2.524300e-01,2.689800e-01,2.854200e-01,3.019000e-01, & - &1.965300e-01,2.113500e-01,2.259300e-01,2.405500e-01,2.553700e-01, & - &1.642400e-01,1.771200e-01,1.900800e-01,2.031400e-01,2.164500e-01, & - &1.359900e-01,1.471200e-01,1.585600e-01,1.701300e-01,1.819100e-01, & - &1.124000e-01,1.220800e-01,1.320800e-01,1.422900e-01,1.526900e-01, & - &9.284800e-02,1.012600e-01,1.100300e-01,1.190200e-01,1.281600e-01, & - &7.627200e-02,8.355100e-02,9.117300e-02,9.905900e-02,1.071000e-01, & - &6.242000e-02,6.870500e-02,7.534700e-02,8.225500e-02,8.930400e-02, & - &5.103700e-02,5.646100e-02,6.222200e-02,6.824500e-02,7.441000e-02, & - &4.157500e-02,4.622000e-02,5.118700e-02,5.643100e-02,6.181400e-02, & - &3.362400e-02,3.756900e-02,4.182500e-02,4.635800e-02,5.105100e-02, & - &2.713300e-02,3.047700e-02,3.412700e-02,3.804900e-02,4.213700e-02, & - &2.185000e-02,2.469500e-02,2.781200e-02,3.119900e-02,3.474900e-02, & - &1.758800e-02,1.999900e-02,2.264000e-02,2.554700e-02,2.861200e-02, & - &1.413300e-02,1.617200e-02,1.840100e-02,2.088000e-02,2.351500e-02, & - &1.133000e-02,1.305200e-02,1.493200e-02,1.704100e-02,1.930400e-02, & - &9.056300e-03,1.051100e-02,1.209600e-02,1.389000e-02,1.583700e-02, & - &7.233700e-03,8.454200e-03,9.777400e-03,1.128000e-02,1.293600e-02, & - &5.767400e-03,6.788800e-03,7.883700e-03,9.127600e-03,1.052800e-02, & - &4.585400e-03,5.440200e-03,6.346100e-03,7.375500e-03,8.545800e-03, & - &3.633400e-03,4.348900e-03,5.099400e-03,5.948600e-03,6.927000e-03, & - &2.878400e-03,3.476100e-03,4.099200e-03,4.797600e-03,5.612200e-03, & - &2.356700e-03,2.855100e-03,3.374400e-03,3.952900e-03,4.631100e-03/ - data absb(:,4) / & - &1.383000e+01,1.401500e+01,1.416000e+01,1.430700e+01,1.452200e+01, & - &1.234000e+01,1.251600e+01,1.266000e+01,1.279300e+01,1.296600e+01, & - &1.092400e+01,1.109200e+01,1.122400e+01,1.135100e+01,1.151600e+01, & - &9.602400e+00,9.750100e+00,9.883600e+00,1.002900e+01,1.021200e+01, & - &8.370800e+00,8.515300e+00,8.664400e+00,8.832900e+00,9.040100e+00, & - &7.256900e+00,7.410200e+00,7.576700e+00,7.774000e+00,8.005100e+00, & - &6.275000e+00,6.441100e+00,6.628300e+00,6.849900e+00,7.092400e+00, & - &5.432400e+00,5.612700e+00,5.820100e+00,6.051500e+00,6.295200e+00, & - &4.719900e+00,4.909800e+00,5.122000e+00,5.351200e+00,5.592900e+00, & - &4.127500e+00,4.317300e+00,4.525000e+00,4.747200e+00,4.987300e+00, & - &3.618600e+00,3.800800e+00,4.000700e+00,4.219400e+00,4.454600e+00, & - &3.178900e+00,3.353500e+00,3.548100e+00,3.760200e+00,3.982600e+00, & - &2.800900e+00,2.970200e+00,3.157100e+00,3.355300e+00,3.566100e+00, & - &2.478700e+00,2.641700e+00,2.816100e+00,3.003500e+00,3.202600e+00, & - &2.199000e+00,2.353700e+00,2.519700e+00,2.697600e+00,2.884500e+00, & - &1.952300e+00,2.101300e+00,2.261800e+00,2.429700e+00,2.603500e+00, & - &1.737000e+00,1.882300e+00,2.036700e+00,2.195800e+00,2.356100e+00, & - &1.549700e+00,1.690400e+00,1.837500e+00,1.987600e+00,2.137600e+00, & - &1.387400e+00,1.522200e+00,1.661700e+00,1.804000e+00,1.944600e+00, & - &1.246000e+00,1.373800e+00,1.506700e+00,1.640800e+00,1.772000e+00, & - &1.122300e+00,1.243600e+00,1.369700e+00,1.495500e+00,1.617200e+00, & - &1.009900e+00,1.124900e+00,1.243400e+00,1.360800e+00,1.473500e+00, & - &9.020900e-01,1.009600e+00,1.119900e+00,1.229900e+00,1.335400e+00, & - &7.973300e-01,8.968800e-01,9.993200e-01,1.102300e+00,1.202800e+00, & - &6.921100e-01,7.834400e-01,8.782100e-01,9.744300e-01,1.070800e+00, & - &6.000600e-01,6.837700e-01,7.714900e-01,8.617100e-01,9.541300e-01, & - &5.204300e-01,5.972600e-01,6.785200e-01,7.634300e-01,8.524400e-01, & - &4.441600e-01,5.139900e-01,5.886200e-01,6.679200e-01,7.526800e-01, & - &3.777600e-01,4.409200e-01,5.093100e-01,5.830800e-01,6.636800e-01, & - &3.207300e-01,3.777700e-01,4.403900e-01,5.090200e-01,5.855900e-01, & - &2.692000e-01,3.202200e-01,3.770700e-01,4.404700e-01,5.126300e-01, & - &2.241900e-01,2.694900e-01,3.208900e-01,3.791900e-01,4.466800e-01, & - &1.861000e-01,2.262300e-01,2.725000e-01,3.258900e-01,3.888100e-01, & - &1.532100e-01,1.884400e-01,2.297300e-01,2.782600e-01,3.364600e-01, & - &1.243400e-01,1.548000e-01,1.911600e-01,2.346200e-01,2.876800e-01, & - &1.003600e-01,1.265300e-01,1.583500e-01,1.971100e-01,2.452800e-01, & - &8.061200e-02,1.029500e-01,1.306100e-01,1.649600e-01,2.084500e-01, & - &6.474300e-02,8.367000e-02,1.075800e-01,1.377700e-01,1.767300e-01, & - &5.183600e-02,6.775200e-02,8.828200e-02,1.146600e-01,1.492600e-01, & - &4.127000e-02,5.457900e-02,7.208800e-02,9.500800e-02,1.255700e-01, & - &3.270300e-02,4.372300e-02,5.855100e-02,7.835800e-02,1.052300e-01, & - &2.593200e-02,3.502500e-02,4.749600e-02,6.443300e-02,8.776300e-02, & - &2.051600e-02,2.798000e-02,3.838400e-02,5.272000e-02,7.277300e-02, & - &1.615700e-02,2.224300e-02,3.086000e-02,4.293300e-02,6.005400e-02, & - &1.266200e-02,1.759400e-02,2.467600e-02,3.477300e-02,4.929900e-02, & - &9.931400e-03,1.391200e-02,1.972300e-02,2.815000e-02,4.043900e-02, & - &8.222400e-03,1.162300e-02,1.665900e-02,2.405500e-02,3.500600e-02/ - data absb(:,5) / & - &2.633500e+01,2.634300e+01,2.631700e+01,2.627800e+01,2.624000e+01, & - &2.433500e+01,2.436800e+01,2.437800e+01,2.436000e+01,2.434600e+01, & - &2.220900e+01,2.227100e+01,2.231700e+01,2.235100e+01,2.236300e+01, & - &2.004100e+01,2.015100e+01,2.023500e+01,2.029700e+01,2.032200e+01, & - &1.792700e+01,1.806000e+01,1.816800e+01,1.824200e+01,1.830400e+01, & - &1.589800e+01,1.604500e+01,1.616400e+01,1.626600e+01,1.637800e+01, & - &1.399200e+01,1.414200e+01,1.428200e+01,1.442700e+01,1.460600e+01, & - &1.222900e+01,1.239600e+01,1.257400e+01,1.278100e+01,1.303100e+01, & - &1.063900e+01,1.083900e+01,1.106800e+01,1.133500e+01,1.164900e+01, & - &9.263600e+00,9.505300e+00,9.784000e+00,1.010800e+01,1.046100e+01, & - &8.095200e+00,8.373800e+00,8.690800e+00,9.036600e+00,9.406000e+00, & - &7.113000e+00,7.414600e+00,7.742900e+00,8.099300e+00,8.486400e+00, & - &6.283700e+00,6.587700e+00,6.920500e+00,7.288300e+00,7.691200e+00, & - &5.574500e+00,5.876000e+00,6.215100e+00,6.592300e+00,7.008000e+00, & - &4.964300e+00,5.268200e+00,5.613400e+00,5.997800e+00,6.412900e+00, & - &4.447300e+00,4.753900e+00,5.102000e+00,5.485700e+00,5.898000e+00, & - &4.013900e+00,4.322800e+00,4.667900e+00,5.047700e+00,5.461100e+00, & - &3.650300e+00,3.957000e+00,4.298200e+00,4.676500e+00,5.090400e+00, & - &3.345800e+00,3.649200e+00,3.989600e+00,4.365700e+00,4.780300e+00, & - &3.088500e+00,3.392400e+00,3.732600e+00,4.108900e+00,4.524200e+00, & - &2.873300e+00,3.179100e+00,3.521000e+00,3.899600e+00,4.319300e+00, & - &2.684400e+00,2.992400e+00,3.334800e+00,3.718100e+00,4.144500e+00, & - &2.498400e+00,2.807500e+00,3.150500e+00,3.535900e+00,3.967500e+00, & - &2.307200e+00,2.615900e+00,2.958200e+00,3.343100e+00,3.776300e+00, & - &2.095400e+00,2.400500e+00,2.738000e+00,3.116800e+00,3.546100e+00, & - &1.903400e+00,2.205500e+00,2.540200e+00,2.915100e+00,3.340300e+00, & - &1.731700e+00,2.031200e+00,2.364700e+00,2.737900e+00,3.161500e+00, & - &1.548100e+00,1.840700e+00,2.170400e+00,2.537700e+00,2.954400e+00, & - &1.377800e+00,1.662800e+00,1.987900e+00,2.350800e+00,2.760200e+00, & - &1.223200e+00,1.499900e+00,1.820300e+00,2.179700e+00,2.582800e+00, & - &1.069800e+00,1.334700e+00,1.646900e+00,2.000800e+00,2.396300e+00, & - &9.258800e-01,1.176000e+00,1.477700e+00,1.824700e+00,2.213200e+00, & - &7.970200e-01,1.031500e+00,1.321000e+00,1.660000e+00,2.042000e+00, & - &6.781800e-01,8.945900e-01,1.168400e+00,1.497300e+00,1.871600e+00, & - &5.658000e-01,7.609700e-01,1.015100e+00,1.328600e+00,1.692300e+00, & - &4.679100e-01,6.421300e-01,8.753200e-01,1.171400e+00,1.522700e+00, & - &3.835300e-01,5.374300e-01,7.492300e-01,1.025700e+00,1.362400e+00, & - &3.139800e-01,4.490600e-01,6.401400e-01,8.968500e-01,1.217200e+00, & - &2.557300e-01,3.732600e-01,5.442700e-01,7.806500e-01,1.083200e+00, & - &2.064700e-01,3.076400e-01,4.593100e-01,6.748700e-01,9.582000e-01, & - &1.652700e-01,2.513000e-01,3.843600e-01,5.791100e-01,8.422700e-01, & - &1.325000e-01,2.052000e-01,3.214400e-01,4.966300e-01,7.394800e-01, & - &1.058600e-01,1.668700e-01,2.674400e-01,4.237900e-01,6.462300e-01, & - &8.391700e-02,1.345900e-01,2.205600e-01,3.588600e-01,5.611400e-01, & - &6.599700e-02,1.075800e-01,1.801900e-01,3.013100e-01,4.836400e-01, & - &5.189900e-02,8.594000e-02,1.470500e-01,2.526300e-01,4.164200e-01, & - &4.427500e-02,7.491500e-02,1.312100e-01,2.301900e-01,3.859100e-01/ - data absb(:,6) / & - &5.096500e+01,5.036100e+01,4.976800e+01,4.917700e+01,4.863200e+01, & - &4.958000e+01,4.913300e+01,4.866900e+01,4.820700e+01,4.774400e+01, & - &4.775500e+01,4.742300e+01,4.705400e+01,4.668400e+01,4.631000e+01, & - &4.543700e+01,4.519700e+01,4.494800e+01,4.467400e+01,4.439800e+01, & - &4.266800e+01,4.254800e+01,4.240100e+01,4.222800e+01,4.202400e+01, & - &3.959000e+01,3.956600e+01,3.949200e+01,3.939300e+01,3.927300e+01, & - &3.629800e+01,3.633500e+01,3.635100e+01,3.633400e+01,3.628200e+01, & - &3.290600e+01,3.301700e+01,3.309900e+01,3.314200e+01,3.316800e+01, & - &2.954700e+01,2.970900e+01,2.984500e+01,2.996900e+01,3.010300e+01, & - &2.631100e+01,2.652400e+01,2.673300e+01,2.695400e+01,2.722200e+01, & - &2.327700e+01,2.355600e+01,2.385400e+01,2.420400e+01,2.463800e+01, & - &2.051700e+01,2.087400e+01,2.130400e+01,2.180100e+01,2.239100e+01, & - &1.808100e+01,1.855000e+01,1.910300e+01,1.974600e+01,2.047400e+01, & - &1.601100e+01,1.659400e+01,1.726400e+01,1.802900e+01,1.887300e+01, & - &1.428700e+01,1.496100e+01,1.572800e+01,1.658700e+01,1.752800e+01, & - &1.285600e+01,1.360500e+01,1.444200e+01,1.537500e+01,1.639800e+01, & - &1.167500e+01,1.247800e+01,1.338000e+01,1.438400e+01,1.547700e+01, & - &1.069500e+01,1.155000e+01,1.251100e+01,1.357800e+01,1.474300e+01, & - &9.898100e+00,1.080700e+01,1.182400e+01,1.295700e+01,1.420000e+01, & - &9.261700e+00,1.021700e+01,1.129400e+01,1.250100e+01,1.381900e+01, & - &8.759600e+00,9.769400e+00,1.091100e+01,1.219600e+01,1.359800e+01, & - &8.343300e+00,9.405600e+00,1.061700e+01,1.197700e+01,1.345900e+01, & - &7.935700e+00,9.042700e+00,1.031400e+01,1.173600e+01,1.328600e+01, & - &7.504600e+00,8.641300e+00,9.952400e+00,1.142500e+01,1.302400e+01, & - &6.987900e+00,8.126500e+00,9.450300e+00,1.094200e+01,1.256700e+01, & - &6.528800e+00,7.664300e+00,8.995200e+00,1.050200e+01,1.214400e+01, & - &6.128600e+00,7.260000e+00,8.592800e+00,1.010900e+01,1.176700e+01, & - &5.668400e+00,6.774000e+00,8.079900e+00,9.580400e+00,1.123300e+01, & - &5.240200e+00,6.313800e+00,7.588200e+00,9.062400e+00,1.070100e+01, & - &4.850600e+00,5.891800e+00,7.132300e+00,8.574000e+00,1.019400e+01, & - &4.443800e+00,5.441200e+00,6.634500e+00,8.029300e+00,9.614500e+00, & - &4.049300e+00,4.998300e+00,6.140000e+00,7.479700e+00,9.018700e+00, & - &3.687600e+00,4.588800e+00,5.678500e+00,6.962300e+00,8.450000e+00, & - &3.338300e+00,4.188000e+00,5.220700e+00,6.445400e+00,7.874500e+00, & - &2.985600e+00,3.778000e+00,4.747200e+00,5.904100e+00,7.261500e+00, & - &2.657200e+00,3.400300e+00,4.307800e+00,5.398600e+00,6.685200e+00, & - &2.348800e+00,3.053500e+00,3.901300e+00,4.927600e+00,6.147200e+00, & - &2.072900e+00,2.747300e+00,3.543600e+00,4.509100e+00,5.665500e+00, & - &1.820600e+00,2.465100e+00,3.219000e+00,4.126400e+00,5.220400e+00, & - &1.585900e+00,2.197700e+00,2.917600e+00,3.769800e+00,4.803600e+00, & - &1.368200e+00,1.944500e+00,2.633300e+00,3.437800e+00,4.413800e+00, & - &1.181200e+00,1.721500e+00,2.380300e+00,3.145300e+00,4.063300e+00, & - &1.015000e+00,1.519300e+00,2.146300e+00,2.877000e+00,3.739800e+00, & - &8.636800e-01,1.330900e+00,1.924100e+00,2.623700e+00,3.437500e+00, & - &7.268200e-01,1.155600e+00,1.713700e+00,2.382400e+00,3.155100e+00, & - &6.096700e-01,1.001200e+00,1.524700e+00,2.162700e+00,2.902000e+00, & - &5.585300e-01,9.359800e-01,1.444800e+00,2.069200e+00,2.792500e+00/ - data absb(:,7) / & - &9.928800e+01,9.785600e+01,9.641900e+01,9.496100e+01,9.347300e+01, & - &1.041200e+02,1.026900e+02,1.012300e+02,9.973600e+01,9.823800e+01, & - &1.081700e+02,1.067900e+02,1.054000e+02,1.039600e+02,1.024900e+02, & - &1.112900e+02,1.100400e+02,1.087300e+02,1.074000e+02,1.060300e+02, & - &1.134000e+02,1.123000e+02,1.111300e+02,1.099500e+02,1.087300e+02, & - &1.143400e+02,1.134200e+02,1.124800e+02,1.114400e+02,1.103400e+02, & - &1.140100e+02,1.133300e+02,1.125600e+02,1.117200e+02,1.108300e+02, & - &1.123400e+02,1.119300e+02,1.114300e+02,1.108500e+02,1.101900e+02, & - &1.094600e+02,1.093500e+02,1.091400e+02,1.088400e+02,1.084600e+02, & - &1.055700e+02,1.057700e+02,1.058800e+02,1.059000e+02,1.058400e+02, & - &1.009400e+02,1.014900e+02,1.019400e+02,1.023300e+02,1.026000e+02, & - &9.581700e+01,9.673600e+01,9.756900e+01,9.833000e+01,9.901000e+01, & - &9.046900e+01,9.179700e+01,9.307400e+01,9.423800e+01,9.533900e+01, & - &8.521200e+01,8.696300e+01,8.867600e+01,9.031300e+01,9.184200e+01, & - &8.023500e+01,8.243700e+01,8.459900e+01,8.673100e+01,8.874700e+01, & - &7.572200e+01,7.838200e+01,8.104000e+01,8.366000e+01,8.617700e+01, & - &7.185100e+01,7.499200e+01,7.813000e+01,8.122300e+01,8.420900e+01, & - &6.867900e+01,7.228600e+01,7.589100e+01,7.942100e+01,8.281100e+01, & - &6.622500e+01,7.027900e+01,7.432600e+01,7.824500e+01,8.196600e+01, & - &6.447900e+01,6.894600e+01,7.336700e+01,7.762700e+01,8.164300e+01, & - &6.339300e+01,6.822500e+01,7.296700e+01,7.750600e+01,8.177100e+01, & - &6.270500e+01,6.784200e+01,7.284800e+01,7.762200e+01,8.208600e+01, & - &6.197000e+01,6.736900e+01,7.261100e+01,7.761400e+01,8.227800e+01, & - &6.096700e+01,6.659800e+01,7.207200e+01,7.730000e+01,8.218500e+01, & - &5.927900e+01,6.514200e+01,7.084600e+01,7.629200e+01,8.143600e+01, & - &5.770100e+01,6.377600e+01,6.969900e+01,7.538200e+01,8.076000e+01, & - &5.627000e+01,6.254600e+01,6.868800e+01,7.461700e+01,8.016200e+01, & - &5.423000e+01,6.069000e+01,6.699600e+01,7.313800e+01,7.885700e+01, & - &5.215600e+01,5.875800e+01,6.523500e+01,7.157200e+01,7.746400e+01, & - &5.012900e+01,5.685500e+01,6.349900e+01,7.001600e+01,7.608000e+01, & - &4.776000e+01,5.459800e+01,6.139900e+01,6.809900e+01,7.435000e+01, & - &4.524900e+01,5.218400e+01,5.913100e+01,6.601000e+01,7.245200e+01, & - &4.277000e+01,4.979000e+01,5.687500e+01,6.391900e+01,7.054700e+01, & - &4.016300e+01,4.724300e+01,5.447900e+01,6.165500e+01,6.846400e+01, & - &3.727900e+01,4.437200e+01,5.168800e+01,5.900700e+01,6.600000e+01, & - &3.445500e+01,4.153100e+01,4.891400e+01,5.635500e+01,6.351600e+01, & - &3.170700e+01,3.873300e+01,4.617900e+01,5.371900e+01,6.103800e+01, & - &2.916800e+01,3.608400e+01,4.353100e+01,5.112700e+01,5.857400e+01, & - &2.676500e+01,3.352300e+01,4.092000e+01,4.855000e+01,5.609800e+01, & - &2.443200e+01,3.103700e+01,3.835900e+01,4.599500e+01,5.363500e+01, & - &2.220800e+01,2.862900e+01,3.585500e+01,4.347400e+01,5.118600e+01, & - &2.020500e+01,2.640100e+01,3.341400e+01,4.097300e+01,4.869900e+01, & - &1.835300e+01,2.428200e+01,3.102400e+01,3.847000e+01,4.617300e+01, & - &1.660100e+01,2.226200e+01,2.873300e+01,3.600300e+01,4.364000e+01, & - &1.494200e+01,2.033200e+01,2.654100e+01,3.357100e+01,4.113700e+01, & - &1.345500e+01,1.858000e+01,2.453000e+01,3.128400e+01,3.873300e+01, & - &1.286500e+01,1.785900e+01,2.364200e+01,3.015200e+01,3.735900e+01/ - data absb(:,8) / & - &1.483600e+02,1.460400e+02,1.437000e+02,1.415500e+02,1.395100e+02, & - &1.643100e+02,1.617400e+02,1.593100e+02,1.570700e+02,1.544700e+02, & - &1.808800e+02,1.784400e+02,1.759800e+02,1.732100e+02,1.704900e+02, & - &1.983700e+02,1.958200e+02,1.929400e+02,1.900700e+02,1.873200e+02, & - &2.155000e+02,2.126800e+02,2.095900e+02,2.063700e+02,2.029900e+02, & - &2.314700e+02,2.281100e+02,2.249100e+02,2.217900e+02,2.187300e+02, & - &2.456100e+02,2.428200e+02,2.399800e+02,2.367300e+02,2.333300e+02, & - &2.587500e+02,2.559700e+02,2.529900e+02,2.497500e+02,2.465000e+02, & - &2.695600e+02,2.669400e+02,2.641600e+02,2.612600e+02,2.582900e+02, & - &2.774200e+02,2.755600e+02,2.734600e+02,2.710900e+02,2.682200e+02, & - &2.825900e+02,2.816700e+02,2.805400e+02,2.787700e+02,2.764000e+02, & - &2.857900e+02,2.859300e+02,2.855500e+02,2.845200e+02,2.828100e+02, & - &2.875900e+02,2.885500e+02,2.889700e+02,2.889900e+02,2.880500e+02, & - &2.882700e+02,2.903900e+02,2.917100e+02,2.925400e+02,2.923200e+02, & - &2.883100e+02,2.916000e+02,2.941000e+02,2.954700e+02,2.958200e+02, & - &2.883000e+02,2.928100e+02,2.959100e+02,2.981700e+02,2.988000e+02, & - &2.881900e+02,2.939000e+02,2.976200e+02,3.003500e+02,3.014000e+02, & - &2.885300e+02,2.950900e+02,2.993100e+02,3.023000e+02,3.038400e+02, & - &2.894100e+02,2.963800e+02,3.009300e+02,3.040700e+02,3.061000e+02, & - &2.906700e+02,2.978700e+02,3.027500e+02,3.057700e+02,3.079500e+02, & - &2.922200e+02,2.994200e+02,3.045600e+02,3.075200e+02,3.096600e+02, & - &2.936300e+02,3.009100e+02,3.060800e+02,3.090400e+02,3.111500e+02, & - &2.942300e+02,3.018200e+02,3.071700e+02,3.101800e+02,3.122900e+02, & - &2.940000e+02,3.020500e+02,3.077100e+02,3.109100e+02,3.131400e+02, & - &2.927700e+02,3.011600e+02,3.074500e+02,3.113200e+02,3.136900e+02, & - &2.910300e+02,3.000800e+02,3.069800e+02,3.112600e+02,3.140500e+02, & - &2.892300e+02,2.989000e+02,3.063700e+02,3.110700e+02,3.151700e+02, & - &2.860900e+02,2.971100e+02,3.049700e+02,3.103600e+02,3.155000e+02, & - &2.825200e+02,2.944800e+02,3.031600e+02,3.094200e+02,3.155600e+02, & - &2.786200e+02,2.916000e+02,3.011300e+02,3.083400e+02,3.155600e+02, & - &2.736100e+02,2.877900e+02,2.983600e+02,3.066600e+02,3.151200e+02, & - &2.678200e+02,2.832400e+02,2.949900e+02,3.045300e+02,3.144100e+02, & - &2.616500e+02,2.782300e+02,2.912000e+02,3.021900e+02,3.136200e+02, & - &2.546200e+02,2.724900e+02,2.869300e+02,2.992900e+02,3.122800e+02, & - &2.462200e+02,2.655600e+02,2.814500e+02,2.952500e+02,3.098300e+02, & - &2.371300e+02,2.580300e+02,2.754100e+02,2.909500e+02,3.071900e+02, & - &2.273900e+02,2.498600e+02,2.688100e+02,2.866200e+02,3.045300e+02, & - &2.177200e+02,2.416900e+02,2.620200e+02,2.815800e+02,3.009400e+02, & - &2.078400e+02,2.333000e+02,2.549600e+02,2.759100e+02,2.966600e+02, & - &1.974600e+02,2.244200e+02,2.474200e+02,2.700400e+02,2.921600e+02, & - &1.866700e+02,2.149800e+02,2.394900e+02,2.640400e+02,2.876600e+02, & - &1.764100e+02,2.055700e+02,2.315200e+02,2.562900e+02,2.813400e+02, & - &1.663000e+02,1.964500e+02,2.235200e+02,2.480100e+02,2.735600e+02, & - &1.559400e+02,1.870000e+02,2.152000e+02,2.399200e+02,2.657600e+02, & - &1.453900e+02,1.772800e+02,2.064800e+02,2.320400e+02,2.572500e+02, & - &1.352400e+02,1.678000e+02,1.978900e+02,2.245900e+02,2.491800e+02, & - &1.311200e+02,1.639100e+02,1.943300e+02,2.215200e+02,2.453500e+02/ - data absb(:,9) / & - &1.655200e+02,1.625900e+02,1.597600e+02,1.570100e+02,1.544000e+02, & - &1.851600e+02,1.823300e+02,1.793300e+02,1.763500e+02,1.736200e+02, & - &2.079400e+02,2.048100e+02,2.017400e+02,1.985900e+02,1.953400e+02, & - &2.325100e+02,2.293400e+02,2.259600e+02,2.219300e+02,2.174700e+02, & - &2.582200e+02,2.544900e+02,2.502800e+02,2.457500e+02,2.411100e+02, & - &2.837700e+02,2.798300e+02,2.751200e+02,2.702200e+02,2.650700e+02, & - &3.087200e+02,3.040300e+02,2.988700e+02,2.937300e+02,2.883300e+02, & - &3.315400e+02,3.266700e+02,3.214900e+02,3.165800e+02,3.111000e+02, & - &3.530300e+02,3.485900e+02,3.436800e+02,3.386300e+02,3.328100e+02, & - &3.730800e+02,3.686600e+02,3.638200e+02,3.585300e+02,3.525900e+02, & - &3.908500e+02,3.866000e+02,3.818500e+02,3.765000e+02,3.712300e+02, & - &4.063100e+02,4.025500e+02,3.982800e+02,3.934800e+02,3.879300e+02, & - &4.193800e+02,4.168600e+02,4.128200e+02,4.082100e+02,4.026900e+02, & - &4.300400e+02,4.286400e+02,4.254500e+02,4.209700e+02,4.154400e+02, & - &4.393200e+02,4.387500e+02,4.360400e+02,4.320100e+02,4.264100e+02, & - &4.470800e+02,4.471500e+02,4.451600e+02,4.412100e+02,4.358400e+02, & - &4.539000e+02,4.543100e+02,4.528200e+02,4.490500e+02,4.435300e+02, & - &4.597800e+02,4.605100e+02,4.591400e+02,4.556300e+02,4.496600e+02, & - &4.650200e+02,4.658200e+02,4.642900e+02,4.609200e+02,4.545100e+02, & - &4.695200e+02,4.702300e+02,4.685400e+02,4.649900e+02,4.583000e+02, & - &4.734800e+02,4.740900e+02,4.719200e+02,4.679400e+02,4.610300e+02, & - &4.768500e+02,4.773100e+02,4.747500e+02,4.702800e+02,4.631900e+02, & - &4.795800e+02,4.800200e+02,4.773600e+02,4.725900e+02,4.655100e+02, & - &4.816900e+02,4.824000e+02,4.798700e+02,4.749900e+02,4.681300e+02, & - &4.829800e+02,4.844600e+02,4.824300e+02,4.780900e+02,4.714700e+02, & - &4.839400e+02,4.860600e+02,4.845900e+02,4.806800e+02,4.740500e+02, & - &4.845100e+02,4.873300e+02,4.863700e+02,4.829100e+02,4.765800e+02, & - &4.842100e+02,4.873600e+02,4.880000e+02,4.852300e+02,4.794600e+02, & - &4.833500e+02,4.876400e+02,4.892700e+02,4.871700e+02,4.820600e+02, & - &4.820400e+02,4.874800e+02,4.900600e+02,4.887500e+02,4.843400e+02, & - &4.797500e+02,4.865400e+02,4.904100e+02,4.900800e+02,4.865200e+02, & - &4.765500e+02,4.849400e+02,4.901900e+02,4.909800e+02,4.883900e+02, & - &4.725300e+02,4.827600e+02,4.894300e+02,4.914500e+02,4.900300e+02, & - &4.673400e+02,4.796800e+02,4.874300e+02,4.914400e+02,4.914200e+02, & - &4.603700e+02,4.753200e+02,4.850300e+02,4.907500e+02,4.923000e+02, & - &4.522600e+02,4.698700e+02,4.819800e+02,4.893200e+02,4.929500e+02, & - &4.429000e+02,4.634200e+02,4.781300e+02,4.870700e+02,4.936400e+02, & - &4.330300e+02,4.563400e+02,4.736200e+02,4.843000e+02,4.931900e+02, & - &4.223100e+02,4.485400e+02,4.682300e+02,4.809700e+02,4.917300e+02, & - &4.102800e+02,4.398300e+02,4.619400e+02,4.769500e+02,4.901800e+02, & - &3.974700e+02,4.300600e+02,4.547500e+02,4.721800e+02,4.889600e+02, & - &3.846800e+02,4.199100e+02,4.473700e+02,4.669900e+02,4.840500e+02, & - &3.714800e+02,4.095300e+02,4.395300e+02,4.615700e+02,4.778900e+02, & - &3.574100e+02,3.982500e+02,4.309200e+02,4.551600e+02,4.729000e+02, & - &3.426100e+02,3.859800e+02,4.215200e+02,4.481300e+02,4.677700e+02, & - &3.278000e+02,3.735900e+02,4.119200e+02,4.407200e+02,4.624900e+02, & - &3.215200e+02,3.683900e+02,4.078000e+02,4.375100e+02,4.601600e+02/ - data absb(:,10) / & - &1.842100e+02,1.816600e+02,1.787900e+02,1.757400e+02,1.725100e+02, & - &2.090300e+02,2.061900e+02,2.032400e+02,1.998800e+02,1.963600e+02, & - &2.378000e+02,2.344200e+02,2.306800e+02,2.266600e+02,2.222500e+02, & - &2.701200e+02,2.657000e+02,2.608400e+02,2.561200e+02,2.516200e+02, & - &3.050700e+02,2.999000e+02,2.947200e+02,2.891300e+02,2.836200e+02, & - &3.426400e+02,3.365300e+02,3.302700e+02,3.238800e+02,3.171300e+02, & - &3.811300e+02,3.745500e+02,3.676500e+02,3.604000e+02,3.529200e+02, & - &4.211900e+02,4.142600e+02,4.065500e+02,3.981300e+02,3.898100e+02, & - &4.619100e+02,4.536300e+02,4.450800e+02,4.361100e+02,4.266200e+02, & - &5.004500e+02,4.918700e+02,4.822800e+02,4.726700e+02,4.626900e+02, & - &5.377100e+02,5.285900e+02,5.183200e+02,5.080300e+02,4.967000e+02, & - &5.722700e+02,5.626000e+02,5.521400e+02,5.407600e+02,5.284600e+02, & - &6.040100e+02,5.938400e+02,5.827900e+02,5.706500e+02,5.572400e+02, & - &6.327500e+02,6.218200e+02,6.097500e+02,5.966800e+02,5.824800e+02, & - &6.578800e+02,6.461200e+02,6.332900e+02,6.191200e+02,6.039300e+02, & - &6.797700e+02,6.674100e+02,6.536800e+02,6.383900e+02,6.218600e+02, & - &6.986000e+02,6.854000e+02,6.705600e+02,6.540700e+02,6.366900e+02, & - &7.142800e+02,7.001400e+02,6.843600e+02,6.668700e+02,6.484300e+02, & - &7.270700e+02,7.122400e+02,6.953500e+02,6.767900e+02,6.573200e+02, & - &7.373900e+02,7.216100e+02,7.035200e+02,6.842400e+02,6.637400e+02, & - &7.452900e+02,7.285200e+02,7.093900e+02,6.894500e+02,6.681000e+02, & - &7.516600e+02,7.338000e+02,7.139000e+02,6.934400e+02,6.714100e+02, & - &7.578500e+02,7.391800e+02,7.187400e+02,6.979900e+02,6.752700e+02, & - &7.643500e+02,7.453800e+02,7.245400e+02,7.035800e+02,6.804000e+02, & - &7.716100e+02,7.534000e+02,7.325100e+02,7.108900e+02,6.880000e+02, & - &7.785300e+02,7.606700e+02,7.398300e+02,7.181600e+02,6.953600e+02, & - &7.846400e+02,7.671300e+02,7.464700e+02,7.247500e+02,7.017800e+02, & - &7.916000e+02,7.741400e+02,7.546500e+02,7.330600e+02,7.100900e+02, & - &7.979500e+02,7.813700e+02,7.625200e+02,7.411700e+02,7.182500e+02, & - &8.036300e+02,7.880500e+02,7.698500e+02,7.488000e+02,7.260400e+02, & - &8.091800e+02,7.950300e+02,7.777400e+02,7.572400e+02,7.347800e+02, & - &8.140500e+02,8.017100e+02,7.856100e+02,7.658400e+02,7.437900e+02, & - &8.178300e+02,8.075900e+02,7.929400e+02,7.739700e+02,7.524000e+02, & - &8.207800e+02,8.130900e+02,8.001000e+02,7.820100e+02,7.613100e+02, & - &8.228800e+02,8.179100e+02,8.068800e+02,7.903100e+02,7.708200e+02, & - &8.236500e+02,8.216700e+02,8.127300e+02,7.979600e+02,7.796300e+02, & - &8.228700e+02,8.243100e+02,8.176300e+02,8.048700e+02,7.879100e+02, & - &8.204500e+02,8.254900e+02,8.212400e+02,8.107300e+02,7.952100e+02, & - &8.164700e+02,8.252600e+02,8.237000e+02,8.156300e+02,8.018000e+02, & - &8.112100e+02,8.236700e+02,8.253100e+02,8.196700e+02,8.078800e+02, & - &8.041100e+02,8.205500e+02,8.257900e+02,8.227200e+02,8.132100e+02, & - &7.958800e+02,8.160700e+02,8.250400e+02,8.247100e+02,8.174300e+02, & - &7.860600e+02,8.109800e+02,8.232800e+02,8.257100e+02,8.207600e+02, & - &7.744500e+02,8.047800e+02,8.205100e+02,8.261000e+02,8.229500e+02, & - &7.608200e+02,7.971100e+02,8.164900e+02,8.255200e+02,8.249300e+02, & - &7.462600e+02,7.880800e+02,8.117400e+02,8.240900e+02,8.262100e+02, & - &7.398700e+02,7.840100e+02,8.095400e+02,8.233400e+02,8.265300e+02/ - data absb(:,11) / & - &2.245464e+02,2.194504e+02,2.149775e+02,2.105017e+02,2.062695e+02, & - &2.553611e+02,2.496887e+02,2.441922e+02,2.388271e+02,2.337178e+02, & - &2.915201e+02,2.848665e+02,2.785031e+02,2.724442e+02,2.667182e+02, & - &3.332863e+02,3.258827e+02,3.190848e+02,3.123687e+02,3.056588e+02, & - &3.820842e+02,3.739445e+02,3.660661e+02,3.584994e+02,3.508713e+02, & - &4.382556e+02,4.292936e+02,4.204839e+02,4.117527e+02,4.027655e+02, & - &5.026505e+02,4.921993e+02,4.818201e+02,4.714294e+02,4.604487e+02, & - &5.739352e+02,5.613049e+02,5.486798e+02,5.358690e+02,5.227288e+02, & - &6.504830e+02,6.355546e+02,6.200776e+02,6.042207e+02,5.882581e+02, & - &7.302535e+02,7.118206e+02,6.930244e+02,6.736060e+02,6.540639e+02, & - &8.115602e+02,7.893175e+02,7.664540e+02,7.427506e+02,7.190481e+02, & - &8.924342e+02,8.657712e+02,8.378885e+02,8.098174e+02,7.816803e+02, & - &9.705789e+02,9.384997e+02,9.057006e+02,8.725797e+02,8.399501e+02, & - &1.042724e+03,1.005380e+03,9.674275e+02,9.292731e+02,8.922710e+02, & - &1.107971e+03,1.065425e+03,1.022281e+03,9.791987e+02,9.379460e+02, & - &1.165123e+03,1.117207e+03,1.069157e+03,1.021696e+03,9.763136e+02, & - &1.213190e+03,1.160221e+03,1.107819e+03,1.056413e+03,1.007248e+03, & - &1.252100e+03,1.194914e+03,1.138612e+03,1.083649e+03,1.031291e+03, & - &1.282237e+03,1.221172e+03,1.161629e+03,1.103736e+03,1.048930e+03, & - &1.304089e+03,1.240140e+03,1.177820e+03,1.117531e+03,1.060719e+03, & - &1.318940e+03,1.252391e+03,1.188104e+03,1.125880e+03,1.067490e+03, & - &1.330075e+03,1.261542e+03,1.195460e+03,1.131774e+03,1.072167e+03, & - &1.343104e+03,1.272788e+03,1.205055e+03,1.139995e+03,1.079155e+03, & - &1.360273e+03,1.288073e+03,1.218718e+03,1.152187e+03,1.090051e+03, & - &1.386354e+03,1.311693e+03,1.240337e+03,1.172428e+03,1.108378e+03, & - &1.410469e+03,1.333935e+03,1.260823e+03,1.191314e+03,1.126364e+03, & - &1.432795e+03,1.354626e+03,1.279815e+03,1.208866e+03,1.142574e+03, & - &1.461972e+03,1.382319e+03,1.305152e+03,1.232452e+03,1.164599e+03, & - &1.491377e+03,1.409840e+03,1.330822e+03,1.256372e+03,1.187018e+03, & - &1.520077e+03,1.436801e+03,1.356031e+03,1.279909e+03,1.209077e+03, & - &1.553061e+03,1.468078e+03,1.385358e+03,1.307391e+03,1.234824e+03, & - &1.588257e+03,1.501323e+03,1.416602e+03,1.336673e+03,1.262378e+03, & - &1.623380e+03,1.534457e+03,1.447880e+03,1.366166e+03,1.290004e+03, & - &1.660583e+03,1.569497e+03,1.481546e+03,1.397621e+03,1.319547e+03, & - &1.701736e+03,1.608666e+03,1.518909e+03,1.432877e+03,1.352669e+03, & - &1.743096e+03,1.648290e+03,1.556649e+03,1.468694e+03,1.386480e+03, & - &1.784707e+03,1.688044e+03,1.594801e+03,1.505128e+03,1.420819e+03, & - &1.823906e+03,1.725758e+03,1.631137e+03,1.539785e+03,1.453547e+03, & - &1.861950e+03,1.762684e+03,1.666933e+03,1.573786e+03,1.485847e+03, & - &1.900078e+03,1.799899e+03,1.703069e+03,1.608287e+03,1.518447e+03, & - &1.937229e+03,1.837387e+03,1.739355e+03,1.643356e+03,1.551687e+03, & - &1.971146e+03,1.872086e+03,1.773014e+03,1.675780e+03,1.582637e+03, & - &2.003663e+03,1.904762e+03,1.805567e+03,1.707542e+03,1.612727e+03, & - &2.035759e+03,1.937112e+03,1.837981e+03,1.739083e+03,1.642994e+03, & - &2.067312e+03,1.969195e+03,1.870574e+03,1.771102e+03,1.673657e+03, & - &2.096147e+03,1.999601e+03,1.901267e+03,1.801538e+03,1.703119e+03, & - &2.107647e+03,2.011911e+03,1.913671e+03,1.813969e+03,1.715099e+03/ - data absb(:,12) / & - &3.123416e+02,3.070567e+02,3.025256e+02,2.962127e+02,2.904766e+02, & - &3.555283e+02,3.507387e+02,3.442835e+02,3.389157e+02,3.328281e+02, & - &4.042675e+02,3.997726e+02,3.944887e+02,3.872654e+02,3.802291e+02, & - &4.627645e+02,4.564169e+02,4.510813e+02,4.421779e+02,4.346409e+02, & - &5.319713e+02,5.239747e+02,5.158752e+02,5.058921e+02,4.961343e+02, & - &6.143708e+02,6.048693e+02,5.927291e+02,5.797203e+02,5.667579e+02, & - &7.122067e+02,6.975530e+02,6.804265e+02,6.637301e+02,6.470669e+02, & - &8.224549e+02,8.024876e+02,7.801501e+02,7.576470e+02,7.364626e+02, & - &9.466819e+02,9.193526e+02,8.905021e+02,8.617885e+02,8.343392e+02, & - &1.080843e+03,1.044742e+03,1.007568e+03,9.710631e+02,9.365580e+02, & - &1.223379e+03,1.176549e+03,1.129496e+03,1.083834e+03,1.039619e+03, & - &1.367283e+03,1.309737e+03,1.252046e+03,1.195489e+03,1.141945e+03, & - &1.510623e+03,1.439669e+03,1.370455e+03,1.302037e+03,1.238455e+03, & - &1.648029e+03,1.561547e+03,1.479574e+03,1.399912e+03,1.325858e+03, & - &1.774664e+03,1.673246e+03,1.578602e+03,1.488496e+03,1.404662e+03, & - &1.887356e+03,1.772472e+03,1.665661e+03,1.565106e+03,1.472343e+03, & - &1.982289e+03,1.855241e+03,1.737574e+03,1.627572e+03,1.527239e+03, & - &2.059730e+03,1.921653e+03,1.794667e+03,1.676579e+03,1.569790e+03, & - &2.118879e+03,1.971283e+03,1.836752e+03,1.712355e+03,1.600257e+03, & - &2.160548e+03,2.005495e+03,1.865542e+03,1.736022e+03,1.620301e+03, & - &2.186624e+03,2.026412e+03,1.882160e+03,1.749406e+03,1.631109e+03, & - &2.205415e+03,2.041368e+03,1.893854e+03,1.758502e+03,1.638331e+03, & - &2.230343e+03,2.061936e+03,1.911111e+03,1.773011e+03,1.650539e+03, & - &2.266491e+03,2.093037e+03,1.937952e+03,1.796192e+03,1.670873e+03, & - &2.324661e+03,2.144182e+03,1.982839e+03,1.837007e+03,1.705977e+03, & - &2.381068e+03,2.193302e+03,2.026089e+03,1.875135e+03,1.738801e+03, & - &2.434213e+03,2.239435e+03,2.066765e+03,1.911249e+03,1.770768e+03, & - &2.506688e+03,2.302793e+03,2.122774e+03,1.960933e+03,1.815058e+03, & - &2.581636e+03,2.368296e+03,2.180544e+03,2.012354e+03,1.860847e+03, & - &2.656672e+03,2.433811e+03,2.238226e+03,2.063737e+03,1.906424e+03, & - &2.746063e+03,2.512022e+03,2.306928e+03,2.125005e+03,1.960673e+03, & - &2.844160e+03,2.597795e+03,2.382352e+03,2.191921e+03,2.020307e+03, & - &2.945292e+03,2.686329e+03,2.460075e+03,2.260549e+03,2.081378e+03, & - &3.057194e+03,2.783623e+03,2.544344e+03,2.335677e+03,2.148136e+03, & - &3.187236e+03,2.896374e+03,2.642608e+03,2.422149e+03,2.224652e+03, & - &3.323796e+03,3.014759e+03,2.745708e+03,2.512697e+03,2.304499e+03, & - &3.468269e+03,3.140156e+03,2.853791e+03,2.607151e+03,2.387744e+03, & - &3.612492e+03,3.264297e+03,2.960173e+03,2.700131e+03,2.469589e+03, & - &3.759924e+03,3.390858e+03,3.069066e+03,2.794484e+03,2.552720e+03, & - &3.915501e+03,3.523426e+03,3.182943e+03,2.893371e+03,2.639337e+03, & - &4.081764e+03,3.663388e+03,3.303190e+03,2.997452e+03,2.729775e+03, & - &4.243406e+03,3.798459e+03,3.419723e+03,3.097858e+03,2.816240e+03, & - &4.406308e+03,3.935716e+03,3.536786e+03,3.196509e+03,2.903004e+03, & - &4.577413e+03,4.080511e+03,3.659346e+03,3.301722e+03,2.992817e+03, & - &4.758161e+03,4.233034e+03,3.788113e+03,3.411380e+03,3.087951e+03, & - &4.941133e+03,4.385830e+03,3.916623e+03,3.520146e+03,3.181772e+03, & - &5.018800e+03,4.449815e+03,3.970426e+03,3.565470e+03,3.220980e+03/ - -! the array selfref contains the coefficient of the water vapor -! self-continuum (including the energy term). the first index -! refers to temperature in 7.2 degree increments. for instance, -! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, -! etc. the second index runs over the g-channel (1 to NG07=12). - - data selfref(:, 1) / & - &4.785674e-02,4.039574e-02,3.411712e-02,2.883068e-02,2.437708e-02, & - &2.062311e-02,1.745702e-02,1.478545e-02,1.252969e-02,1.062402e-02/ - data selfref(:, 2) / & - &4.151273e-02,3.632598e-02,3.178765e-02,2.781662e-02,2.434197e-02, & - &2.130156e-02,1.864117e-02,1.631320e-02,1.427617e-02,1.249362e-02/ - data selfref(:, 3) / & - &3.950700e-02,3.467260e-02,3.042970e-02,2.670600e-02,2.343800e-02, & - &2.056990e-02,1.805280e-02,1.584370e-02,1.390490e-02,1.220340e-02/ - data selfref(:, 4) / & - &3.897480e-02,3.401860e-02,2.969260e-02,2.591680e-02,2.262110e-02, & - &1.974450e-02,1.723370e-02,1.504220e-02,1.312930e-02,1.145970e-02/ - data selfref(:, 5) / & - &3.855270e-02,3.365610e-02,2.938150e-02,2.564970e-02,2.239200e-02, & - &1.954800e-02,1.706520e-02,1.489770e-02,1.300560e-02,1.135370e-02/ - data selfref(:, 6) / & - &3.782120e-02,3.306140e-02,2.890050e-02,2.526330e-02,2.208390e-02, & - &1.930460e-02,1.687510e-02,1.475130e-02,1.289480e-02,1.127200e-02/ - data selfref(:, 7) / & - &3.686240e-02,3.226760e-02,2.824560e-02,2.472480e-02,2.164290e-02, & - &1.894520e-02,1.658380e-02,1.451660e-02,1.270720e-02,1.112330e-02/ - data selfref(:, 8) / & - &3.631350e-02,3.193320e-02,2.808130e-02,2.469400e-02,2.171540e-02, & - &1.909600e-02,1.679260e-02,1.476700e-02,1.298570e-02,1.141930e-02/ - data selfref(:, 9) / & - &3.600180e-02,3.172940e-02,2.796400e-02,2.464540e-02,2.172070e-02, & - &1.914300e-02,1.687130e-02,1.486910e-02,1.310450e-02,1.154940e-02/ - data selfref(:,10) / & - &3.651470e-02,3.191580e-02,2.789620e-02,2.438270e-02,2.131180e-02, & - &1.862770e-02,1.628160e-02,1.423100e-02,1.243860e-02,1.087200e-02/ - data selfref(:,11) / & - &3.784895e-02,3.277659e-02,2.838439e-02,2.458118e-02,2.128781e-02, & - &1.843596e-02,1.596640e-02,1.382784e-02,1.197586e-02,1.037210e-02/ - data selfref(:,12) / & - &3.512270e-02,3.050520e-02,2.649470e-02,2.301150e-02,1.998620e-02, & - &1.735860e-02,1.507650e-02,1.309440e-02,1.137290e-02,9.877750e-03/ - - data absco2 / & - &1.330518e-04,2.300079e-04,3.134040e-04,4.166190e-04,6.273940e-04, & - &1.293860e-03,4.051920e-03,3.970500e-03,7.006340e-04,6.066170e-04, & - &7.295005e-04,7.857446e-04 / - - data fracrefa(:,:) / & - & 0.3135176301, 0.2738987207, 0.1167973280, 0.0998894870, & - & 0.0807865337, 0.0600638390, 0.0402839109, 0.0043589901, & - & 0.0035917300, 0.0028170701, 0.0034177899, 0.0005786601, & - & 0.3138659596, 0.2735698819, 0.1168862507, 0.0998379067, & - & 0.0808514804, 0.0599394813, 0.0402805693, 0.0043593901, & - & 0.0035870799, 0.0028403599, 0.0034212498, 0.0005619100, & - & 0.3138750792, 0.2734651566, 0.1168219522, 0.0999625698, & - & 0.0807403624, 0.0598569214, 0.0404536203, 0.0043620798, & - & 0.0035825700, 0.0028712200, 0.0034480800, 0.0005619100, & - & 0.3140783608, 0.2730998993, 0.1168848574, 0.0997961015, & - & 0.0807368681, 0.0599674098, 0.0404061601, 0.0043986901, & - & 0.0036891000, 0.0029304100, 0.0034514000, 0.0005619100, & - & 0.3138441443, 0.2730660141, 0.1168819070, 0.0996699780, & - & 0.0806638375, 0.0602027513, 0.0404790118, 0.0044669602, & - & 0.0037745601, 0.0029440999, 0.0034461799, 0.0005619100, & - & 0.3129926324, 0.2733785212, 0.1168698296, 0.0998013094, & - & 0.0805828571, 0.0603143014, 0.0408283286, 0.0045050899, & - & 0.0037757400, 0.0029482299, 0.0034427899, 0.0005619100, & - & 0.3096358478, 0.2750704288, 0.1172038168, 0.1002347097, & - & 0.0806639567, 0.0607355386, 0.0412158109, 0.0045120199, & - & 0.0037783200, 0.0029460900, 0.0034427899, 0.0005619100, & - & 0.2883490622, 0.2829742134, 0.1227135137, 0.1041955575, & - & 0.0829453319, 0.0619979389, 0.0415761508, 0.0045284200, & - & 0.0037770399, 0.0029385199, 0.0034431200, 0.0005619000, & - & 0.2909087539, 0.2820100784, 0.1228828281, 0.1035095230, & - & 0.0826945007, 0.0613057911, 0.0414457098, 0.0045209602, & - & 0.0037738199, 0.0029453200, 0.0034417100, 0.0005619100 / - data fracrefb / & - & 0.3066653311, 0.2740471959, 0.1173679233, 0.1011821330, & - & 0.0821525902, 0.0616559088, 0.0416448601, 0.0045114099, & - & 0.0037283699, 0.0029409500, 0.0035205102, 0.0005830800 / - -!........................................! - end module module_radlw_kgb07 ! -!========================================! - - - -!========================================! - module module_radlw_kgb08 ! -!........................................! -! - use machine, only : kind_phys - use module_radlw_parameters, only : NG08 -! - implicit none -! - private -! - integer, public :: MSA08, MSB08, MSF08, MOF08 - parameter (MSA08=35, MSB08=265, MSF08=10, MOF08=59) - - real (kind=kind_phys), public :: & - & absa(MSA08,NG08), absb(MSB08,NG08), selfref(MSF08,NG08), & - & absco2a(NG08), absco2b(NG08), absn2oa(NG08), & - & absn2ob(NG08), cfc12(NG08), cfc22adj(NG08), & - & fracrefa(NG08), fracrefb(NG08), h2oref(MOF08), & - & o3ref(MOF08), n2oref(MOF08) - -! the array absa(35,NG08) = ka(5,7,NG08) contains absorption coefs at -! the NG08=8 chosen g-values for a range of pressure levels > ~100mb -! and temperatures. the first index in the array, jt, which runs from -! 1 to 5, corresponds to different temperatures. more specifically, -! jt = 1-5 means that the data are for the corresponding temperature of -! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the -! second index, jp, runs from 1 to 7 and refers to the corresponding -! pressure level in pref (e.g. jp = 1 is for a pressure of 1053.63 mb). -! the third index, ig, goes from 1 to NG08=8, and tells us which -! g-interval the absorption coefficients are for. - - data absa(:,1) / & - &2.515037e-05,2.469061e-05,2.804704e-05,3.463269e-05,4.286069e-05, & - &1.827606e-05,1.937203e-05,2.330672e-05,2.917710e-05,3.630431e-05, & - &1.439488e-05,1.703416e-05,2.134686e-05,2.681479e-05,3.322359e-05, & - &1.473778e-05,1.833991e-05,2.286470e-05,2.808055e-05,3.396478e-05, & - &1.932574e-05,2.324081e-05,2.801793e-05,3.354787e-05,3.955730e-05, & - &2.909391e-05,3.335412e-05,3.859312e-05,4.475925e-05,5.138113e-05, & - &5.117969e-05,5.642071e-05,6.247113e-05,6.952895e-05,7.747982e-05/ - data absa(:,2) / & - &3.753193e-05,5.350068e-05,7.109182e-05,8.968259e-05,1.108097e-04, & - &3.341736e-05,4.605122e-05,5.954448e-05,7.463968e-05,9.217167e-05, & - &3.242758e-05,4.274185e-05,5.445383e-05,6.824989e-05,8.460213e-05, & - &3.617268e-05,4.529095e-05,5.651210e-05,7.017439e-05,8.660497e-05, & - &4.736185e-05,5.672631e-05,6.799929e-05,8.157511e-05,9.810076e-05, & - &7.125540e-05,8.154577e-05,9.359297e-05,1.078675e-04,1.252115e-04, & - &1.265584e-04,1.386993e-04,1.534144e-04,1.709782e-04,1.911878e-04/ - data absa(:,3) / & - &1.259182e-04,1.669268e-04,2.132709e-04,2.677373e-04,3.316120e-04, & - &1.031932e-04,1.353006e-04,1.735074e-04,2.190656e-04,2.731421e-04, & - &9.457616e-05,1.196573e-04,1.497537e-04,1.861931e-04,2.300996e-04, & - &9.781986e-05,1.208306e-04,1.484882e-04,1.817844e-04,2.214935e-04, & - &1.124188e-04,1.344047e-04,1.615963e-04,1.950780e-04,2.358986e-04, & - &1.492731e-04,1.709636e-04,1.984447e-04,2.329798e-04,2.755980e-04, & - &2.466333e-04,2.730846e-04,3.062175e-04,3.461652e-04,3.946242e-04/ - data absa(:,4) / & - &7.343420e-04,9.457567e-04,1.185881e-03,1.455962e-03,1.757618e-03, & - &5.658314e-04,7.354196e-04,9.306448e-04,1.153243e-03,1.405322e-03, & - &4.218168e-04,5.532872e-04,7.100448e-04,8.934507e-04,1.106043e-03, & - &3.631646e-04,4.636974e-04,5.897640e-04,7.447120e-04,9.313455e-04, & - &4.032581e-04,4.888301e-04,5.917271e-04,7.203628e-04,8.793584e-04, & - &4.865862e-04,5.764429e-04,6.835405e-04,8.094948e-04,9.583862e-04, & - &6.769130e-04,7.732267e-04,8.881355e-04,1.027168e-03,1.195568e-03/ - data absa(:,5) / & - &4.610098e-03,6.051789e-03,7.764093e-03,9.739121e-03,1.194933e-02, & - &4.059887e-03,5.387294e-03,6.971156e-03,8.784360e-03,1.082042e-02, & - &3.301058e-03,4.449711e-03,5.835969e-03,7.437049e-03,9.232331e-03, & - &2.586900e-03,3.550023e-03,4.731118e-03,6.101510e-03,7.649289e-03, & - &2.059652e-03,2.829465e-03,3.824451e-03,5.016866e-03,6.398575e-03, & - &1.983325e-03,2.532471e-03,3.295468e-03,4.282597e-03,5.507926e-03, & - &2.718351e-03,3.143333e-03,3.724444e-03,4.538547e-03,5.615816e-03/ - data absa(:,6) / & - &1.467935e-02,1.908875e-02,2.423060e-02,3.026390e-02,3.744011e-02, & - &1.301995e-02,1.722560e-02,2.226112e-02,2.841851e-02,3.560657e-02, & - &1.107348e-02,1.501866e-02,1.982311e-02,2.557619e-02,3.252293e-02, & - &9.382285e-03,1.294590e-02,1.727540e-02,2.263584e-02,2.917155e-02, & - &7.902426e-03,1.111715e-02,1.501824e-02,1.987923e-02,2.589183e-02, & - &6.496607e-03,9.330872e-03,1.284247e-02,1.728552e-02,2.283026e-02, & - &5.806206e-03,7.786644e-03,1.087014e-02,1.494957e-02,2.027118e-02/ - data absa(:,7) / & - &4.704095e-02,5.964866e-02,7.364956e-02,8.882784e-02,1.050619e-01, & - &4.478429e-02,5.742653e-02,7.154392e-02,8.697747e-02,1.039809e-01, & - &3.928570e-02,5.131323e-02,6.497975e-02,8.049336e-02,9.779689e-02, & - &3.285750e-02,4.403751e-02,5.714907e-02,7.230808e-02,8.953729e-02, & - &2.685029e-02,3.702477e-02,4.940122e-02,6.404381e-02,8.092527e-02, & - &2.133811e-02,3.036957e-02,4.169284e-02,5.539781e-02,7.150242e-02, & - &1.683357e-02,2.472808e-02,3.490115e-02,4.750955e-02,6.264035e-02/ - data absa(:,8) / & - &1.024347e-01,1.309280e-01,1.628283e-01,1.976265e-01,2.350716e-01, & - &1.125134e-01,1.454709e-01,1.825873e-01,2.233549e-01,2.674000e-01, & - &1.152782e-01,1.518639e-01,1.935865e-01,2.398768e-01,2.901988e-01, & - &1.126222e-01,1.516827e-01,1.969014e-01,2.476905e-01,3.035485e-01, & - &1.069779e-01,1.476296e-01,1.953467e-01,2.497762e-01,3.101364e-01, & - &9.770954e-02,1.386532e-01,1.877060e-01,2.444552e-01,3.081700e-01, & - &8.675301e-02,1.269388e-01,1.761523e-01,2.340476e-01,2.999567e-01/ - -! the array absb(265,NG08) = kb(5,7:59,NG08) contains absorption coefs -! at the NG08=8 chosen g-values for a range of pressure levels < ~100mb -! and temperatures. the first index in the array, jt, which runs from 1 -! to 5, corresponds to different temperatures. more specifically, jt = -! 1-5 means that the data are for the corresponding temperature of -! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the -! second index, jp, runs from 7 to 59 and refers to the jpth reference -! pressure level (see taumol.f for the value of these pressure levels -! in mb). the third index, ig, goes from 1 to NG08=8, and tells us -! which g-interval the absorption coefficients are for. - - data absb(:,1) / & - &2.099320e-01,2.172964e-01,2.306599e-01,2.496798e-01,2.732126e-01, & - &1.288191e-01,1.357048e-01,1.440642e-01,1.535852e-01,1.647508e-01, & - &9.077933e-02,9.393022e-02,9.759566e-02,1.015067e-01,1.057339e-01, & - &6.650902e-02,6.787086e-02,6.929946e-02,7.087578e-02,7.249156e-02, & - &5.019574e-02,5.092783e-02,5.166537e-02,5.245239e-02,5.325082e-02, & - &3.923444e-02,3.972850e-02,4.021054e-02,4.066051e-02,4.110799e-02, & - &3.026460e-02,3.060493e-02,3.090334e-02,3.117619e-02,3.142906e-02, & - &2.163192e-02,2.183253e-02,2.198221e-02,2.208431e-02,2.216616e-02, & - &1.570760e-02,1.582170e-02,1.588926e-02,1.592213e-02,1.593078e-02, & - &1.193709e-02,1.201546e-02,1.205352e-02,1.206129e-02,1.204740e-02, & - &9.259963e-03,9.317086e-03,9.339604e-03,9.331666e-03,9.304749e-03, & - &7.317754e-03,7.357631e-03,7.366737e-03,7.352693e-03,7.320602e-03, & - &5.811215e-03,5.838914e-03,5.840021e-03,5.821575e-03,5.787562e-03, & - &4.680719e-03,4.699817e-03,4.697121e-03,4.678515e-03,4.646864e-03, & - &3.787029e-03,3.800706e-03,3.795499e-03,3.777825e-03,3.748727e-03, & - &3.068230e-03,3.076295e-03,3.069466e-03,3.052281e-03,3.025630e-03, & - &2.485807e-03,2.490104e-03,2.482311e-03,2.465962e-03,2.442259e-03, & - &2.008710e-03,2.010096e-03,2.001745e-03,1.986636e-03,1.965380e-03, & - &1.625913e-03,1.624978e-03,1.616838e-03,1.602952e-03,1.584264e-03, & - &1.319223e-03,1.317032e-03,1.309011e-03,1.296445e-03,1.280087e-03, & - &1.072037e-03,1.069130e-03,1.061632e-03,1.050527e-03,1.036625e-03, & - &8.715893e-04,8.682846e-04,8.614228e-04,8.518508e-04,8.400334e-04, & - &7.115008e-04,7.081423e-04,7.020066e-04,6.939235e-04,6.839662e-04, & - &5.810766e-04,5.778853e-04,5.726051e-04,5.657439e-04,5.574084e-04, & - &4.757191e-04,4.727666e-04,4.683279e-04,4.626047e-04,4.557609e-04, & - &3.895441e-04,3.869801e-04,3.832601e-04,3.785063e-04,3.729054e-04, & - &3.191080e-04,3.169631e-04,3.138784e-04,3.099640e-04,3.053033e-04, & - &2.616093e-04,2.597955e-04,2.572222e-04,2.539835e-04,2.501686e-04, & - &2.143948e-04,2.129334e-04,2.108668e-04,2.082248e-04,2.052117e-04, & - &1.755150e-04,1.743913e-04,1.727623e-04,1.707027e-04,1.683368e-04, & - &1.443195e-04,1.435186e-04,1.422939e-04,1.407166e-04,1.388713e-04, & - &1.187517e-04,1.182008e-04,1.172899e-04,1.161009e-04,1.146770e-04, & - &9.776434e-05,9.741825e-05,9.676280e-05,9.588676e-05,9.479017e-05, & - &8.035091e-05,8.016272e-05,7.970819e-05,7.905723e-05,7.823842e-05, & - &6.601760e-05,6.594005e-05,6.564456e-05,6.517669e-05,6.456495e-05, & - &5.423249e-05,5.424059e-05,5.406427e-05,5.374012e-05,5.329500e-05, & - &4.456771e-05,4.464655e-05,4.456645e-05,4.436007e-05,4.405115e-05, & - &3.663157e-05,3.676468e-05,3.675985e-05,3.664583e-05,3.644467e-05, & - &3.011752e-05,3.028797e-05,3.033697e-05,3.029380e-05,3.017599e-05, & - &2.475489e-05,2.494920e-05,2.504108e-05,2.504983e-05,2.499289e-05, & - &2.031721e-05,2.053241e-05,2.065370e-05,2.069892e-05,2.069144e-05, & - &1.668302e-05,1.691242e-05,1.704897e-05,1.712665e-05,1.715562e-05, & - &1.371945e-05,1.395430e-05,1.410705e-05,1.420524e-05,1.426281e-05, & - &1.124979e-05,1.147862e-05,1.163568e-05,1.174123e-05,1.181318e-05, & - &9.206460e-06,9.425268e-06,9.579729e-06,9.685673e-06,9.763869e-06, & - &7.542317e-06,7.748542e-06,7.900157e-06,8.005709e-06,8.086155e-06, & - &6.193308e-06,6.386343e-06,6.533279e-06,6.637930e-06,6.720650e-06, & - &5.033211e-06,5.204677e-06,5.339414e-06,5.435286e-06,5.511372e-06, & - &4.060090e-06,4.209680e-06,4.328328e-06,4.414906e-06,4.479779e-06, & - &3.271697e-06,3.402291e-06,3.506419e-06,3.584074e-06,3.640550e-06, & - &2.633191e-06,2.747922e-06,2.838705e-06,2.908402e-06,2.957761e-06, & - &2.113414e-06,2.213824e-06,2.292546e-06,2.353791e-06,2.397768e-06, & - &1.681907e-06,1.766119e-06,1.829743e-06,1.878248e-06,1.913074e-06/ - data absb(:,2) / & - &4.662741e-01,4.975998e-01,5.407943e-01,5.957637e-01,6.612915e-01, & - &3.154050e-01,3.323738e-01,3.541644e-01,3.808726e-01,4.116167e-01, & - &2.272895e-01,2.358513e-01,2.461792e-01,2.582731e-01,2.721196e-01, & - &1.688720e-01,1.733935e-01,1.786200e-01,1.848460e-01,1.920177e-01, & - &1.316503e-01,1.347500e-01,1.381721e-01,1.421857e-01,1.467120e-01, & - &1.071536e-01,1.094632e-01,1.119006e-01,1.147166e-01,1.179499e-01, & - &8.607253e-02,8.769903e-02,8.941598e-02,9.138414e-02,9.358124e-02, & - &6.477851e-02,6.584534e-02,6.684811e-02,6.789161e-02,6.890900e-02, & - &4.952309e-02,5.020238e-02,5.076917e-02,5.121705e-02,5.159361e-02, & - &3.921235e-02,3.963077e-02,3.992444e-02,4.010563e-02,4.022515e-02, & - &3.138521e-02,3.161867e-02,3.174654e-02,3.178766e-02,3.178186e-02, & - &2.533706e-02,2.546119e-02,2.550248e-02,2.547204e-02,2.540438e-02, & - &2.046230e-02,2.051790e-02,2.050449e-02,2.043528e-02,2.033672e-02, & - &1.666561e-02,1.668571e-02,1.664409e-02,1.656467e-02,1.646570e-02, & - &1.359556e-02,1.359255e-02,1.354236e-02,1.346484e-02,1.337581e-02, & - &1.108503e-02,1.106723e-02,1.101660e-02,1.094660e-02,1.086841e-02, & - &9.031273e-03,9.006249e-03,8.958579e-03,8.896520e-03,8.829765e-03, & - &7.338884e-03,7.311519e-03,7.268119e-03,7.213266e-03,7.151844e-03, & - &5.967419e-03,5.940825e-03,5.902265e-03,5.855127e-03,5.799818e-03, & - &4.860708e-03,4.835499e-03,4.802502e-03,4.761036e-03,4.712984e-03, & - &3.963618e-03,3.941817e-03,3.913622e-03,3.878091e-03,3.837563e-03, & - &3.233554e-03,3.215435e-03,3.190936e-03,3.161017e-03,3.127638e-03, & - &2.647633e-03,2.632531e-03,2.612178e-03,2.588109e-03,2.561613e-03, & - &2.169317e-03,2.156985e-03,2.140652e-03,2.121766e-03,2.100921e-03, & - &1.781927e-03,1.772404e-03,1.760192e-03,1.746056e-03,1.730502e-03, & - &1.464757e-03,1.457874e-03,1.449104e-03,1.438971e-03,1.427590e-03, & - &1.205316e-03,1.200712e-03,1.195014e-03,1.188025e-03,1.180593e-03, & - &9.927307e-04,9.899117e-04,9.863152e-04,9.817014e-04,9.771031e-04, & - &8.175274e-04,8.161843e-04,8.142283e-04,8.118252e-04,8.092858e-04, & - &6.724237e-04,6.722321e-04,6.716768e-04,6.708315e-04,6.697841e-04, & - &5.549689e-04,5.555464e-04,5.557534e-04,5.557726e-04,5.556532e-04, & - &4.583886e-04,4.594425e-04,4.602562e-04,4.609350e-04,4.615794e-04, & - &3.788686e-04,3.803007e-04,3.816443e-04,3.828787e-04,3.841826e-04, & - &3.121675e-04,3.136657e-04,3.151083e-04,3.164054e-04,3.179345e-04, & - &2.570385e-04,2.585324e-04,2.599996e-04,2.613550e-04,2.629331e-04, & - &2.116226e-04,2.131151e-04,2.145565e-04,2.159301e-04,2.175027e-04, & - &1.742039e-04,1.756414e-04,1.770558e-04,1.784321e-04,1.799885e-04, & - &1.433927e-04,1.447794e-04,1.461516e-04,1.475050e-04,1.490160e-04, & - &1.180471e-04,1.193823e-04,1.207162e-04,1.220297e-04,1.234921e-04, & - &9.712025e-05,9.840152e-05,9.965650e-05,1.009281e-04,1.023331e-04, & - &7.976314e-05,8.096371e-05,8.212225e-05,8.332366e-05,8.463361e-05, & - &6.551899e-05,6.665708e-05,6.773683e-05,6.888139e-05,7.012071e-05, & - &5.386921e-05,5.494556e-05,5.597645e-05,5.706754e-05,5.825871e-05, & - &4.417932e-05,4.515722e-05,4.609110e-05,4.708052e-05,4.816509e-05, & - &3.617453e-05,3.704863e-05,3.787455e-05,3.874944e-05,3.971259e-05, & - &2.964133e-05,3.041932e-05,3.115744e-05,3.193840e-05,3.280645e-05, & - &2.432779e-05,2.501789e-05,2.568130e-05,2.639267e-05,2.718842e-05, & - &1.981803e-05,2.040902e-05,2.096584e-05,2.155278e-05,2.221012e-05, & - &1.606375e-05,1.656425e-05,1.701840e-05,1.747680e-05,1.798860e-05, & - &1.301372e-05,1.344071e-05,1.381430e-05,1.417924e-05,1.457749e-05, & - &1.053539e-05,1.090265e-05,1.121357e-05,1.150795e-05,1.181816e-05, & - &8.515924e-06,8.830962e-06,9.091111e-06,9.329749e-06,9.569544e-06, & - &6.854847e-06,7.111013e-06,7.318072e-06,7.496626e-06,7.665128e-06/ - data absb(:,3) / & - &8.750455e-01,9.556917e-01,1.062028e+00,1.193610e+00,1.355685e+00, & - &5.980606e-01,6.416254e-01,6.950648e-01,7.596251e-01,8.352497e-01, & - &4.517547e-01,4.747639e-01,5.024431e-01,5.350266e-01,5.726600e-01, & - &3.628151e-01,3.750975e-01,3.898487e-01,4.078085e-01,4.290533e-01, & - &3.092724e-01,3.181071e-01,3.284351e-01,3.405635e-01,3.551006e-01, & - &2.720644e-01,2.794551e-01,2.878577e-01,2.974252e-01,3.087152e-01, & - &2.352569e-01,2.413839e-01,2.480461e-01,2.557118e-01,2.646916e-01, & - &1.931054e-01,1.971164e-01,2.013630e-01,2.061493e-01,2.117343e-01, & - &1.592612e-01,1.618569e-01,1.643717e-01,1.670786e-01,1.702205e-01, & - &1.330812e-01,1.348304e-01,1.363950e-01,1.380559e-01,1.398863e-01, & - &1.110083e-01,1.121311e-01,1.130729e-01,1.140003e-01,1.148812e-01, & - &9.243140e-02,9.313116e-02,9.362733e-02,9.404705e-02,9.434128e-02, & - &7.650405e-02,7.686880e-02,7.704443e-02,7.709035e-02,7.705948e-02, & - &6.332010e-02,6.347737e-02,6.347378e-02,6.338642e-02,6.326028e-02, & - &5.224349e-02,5.227295e-02,5.219614e-02,5.207660e-02,5.192220e-02, & - &4.294795e-02,4.290955e-02,4.281689e-02,4.269608e-02,4.253641e-02, & - &3.520152e-02,3.514746e-02,3.505382e-02,3.493074e-02,3.478309e-02, & - &2.874420e-02,2.868110e-02,2.858997e-02,2.846750e-02,2.833077e-02, & - &2.346364e-02,2.340029e-02,2.330953e-02,2.320023e-02,2.308259e-02, & - &1.916673e-02,1.910786e-02,1.902512e-02,1.893428e-02,1.883937e-02, & - &1.567165e-02,1.561856e-02,1.555344e-02,1.548267e-02,1.540823e-02, & - &1.281807e-02,1.277552e-02,1.272664e-02,1.267446e-02,1.261456e-02, & - &1.052735e-02,1.049970e-02,1.046779e-02,1.043434e-02,1.038819e-02, & - &8.657781e-03,8.644735e-03,8.629479e-03,8.608714e-03,8.577003e-03, & - &7.150575e-03,7.151958e-03,7.150326e-03,7.141024e-03,7.125648e-03, & - &5.917755e-03,5.931096e-03,5.937756e-03,5.939055e-03,5.939870e-03, & - &4.910588e-03,4.929978e-03,4.943192e-03,4.956251e-03,4.971254e-03, & - &4.076106e-03,4.098194e-03,4.117620e-03,4.140085e-03,4.162386e-03, & - &3.381234e-03,3.405181e-03,3.430169e-03,3.457215e-03,3.484774e-03, & - &2.798522e-03,2.823430e-03,2.850876e-03,2.879622e-03,2.909003e-03, & - &2.320389e-03,2.345805e-03,2.373756e-03,2.402744e-03,2.432477e-03, & - &1.925660e-03,1.951498e-03,1.979099e-03,2.008054e-03,2.037847e-03, & - &1.600251e-03,1.626133e-03,1.653223e-03,1.681922e-03,1.712033e-03, & - &1.323318e-03,1.347076e-03,1.371971e-03,1.398117e-03,1.426144e-03, & - &1.093518e-03,1.114921e-03,1.137521e-03,1.161504e-03,1.187278e-03, & - &9.036653e-04,9.230681e-04,9.435581e-04,9.653036e-04,9.886988e-04, & - &7.463639e-04,7.637995e-04,7.822580e-04,8.021627e-04,8.235835e-04, & - &6.162023e-04,6.320925e-04,6.489836e-04,6.671413e-04,6.864925e-04, & - &5.089790e-04,5.233777e-04,5.387222e-04,5.552975e-04,5.728643e-04, & - &4.199526e-04,4.327827e-04,4.467618e-04,4.617074e-04,4.775732e-04, & - &3.454589e-04,3.568184e-04,3.692751e-04,3.826165e-04,3.967584e-04, & - &2.842581e-04,2.944763e-04,3.056618e-04,3.176291e-04,3.301912e-04, & - &2.342495e-04,2.435128e-04,2.535887e-04,2.642923e-04,2.756166e-04, & - &1.924076e-04,2.005710e-04,2.093740e-04,2.186426e-04,2.285399e-04, & - &1.577032e-04,1.648008e-04,1.723548e-04,1.802833e-04,1.888060e-04, & - &1.293487e-04,1.355094e-04,1.420381e-04,1.488450e-04,1.562457e-04, & - &1.062278e-04,1.116230e-04,1.172769e-04,1.231958e-04,1.296956e-04, & - &8.648034e-05,9.098025e-05,9.567363e-05,1.005556e-04,1.058782e-04, & - &7.001661e-05,7.368252e-05,7.748164e-05,8.139667e-05,8.560465e-05, & - &5.667371e-05,5.965482e-05,6.276233e-05,6.589203e-05,6.923422e-05, & - &4.585881e-05,4.826625e-05,5.083157e-05,5.335931e-05,5.601626e-05, & - &3.707641e-05,3.900220e-05,4.111140e-05,4.314933e-05,4.525645e-05, & - &2.990008e-05,3.136720e-05,3.301503e-05,3.458739e-05,3.614851e-05/ - data absb(:,4) / & - &2.343453e+00,2.662763e+00,3.048369e+00,3.518497e+00,4.090106e+00, & - &1.387597e+00,1.518392e+00,1.675145e+00,1.861946e+00,2.095662e+00, & - &9.755862e-01,1.023938e+00,1.083312e+00,1.160081e+00,1.259474e+00, & - &8.114829e-01,8.356715e-01,8.646708e-01,9.002377e-01,9.460157e-01, & - &7.485183e-01,7.686248e-01,7.912693e-01,8.174903e-01,8.490360e-01, & - &7.201390e-01,7.382354e-01,7.578365e-01,7.801871e-01,8.063323e-01, & - &6.880848e-01,7.040374e-01,7.210690e-01,7.394904e-01,7.604529e-01, & - &6.313854e-01,6.447518e-01,6.579458e-01,6.714007e-01,6.859162e-01, & - &5.804584e-01,5.914762e-01,6.022323e-01,6.129452e-01,6.238511e-01, & - &5.382808e-01,5.479559e-01,5.572243e-01,5.661217e-01,5.749249e-01, & - &4.964239e-01,5.050464e-01,5.129128e-01,5.201437e-01,5.271140e-01, & - &4.545106e-01,4.619662e-01,4.684494e-01,4.741564e-01,4.797704e-01, & - &4.105776e-01,4.168286e-01,4.219556e-01,4.264897e-01,4.306979e-01, & - &3.674793e-01,3.726513e-01,3.768470e-01,3.804525e-01,3.836868e-01, & - &3.248742e-01,3.291072e-01,3.324699e-01,3.353156e-01,3.378642e-01, & - &2.837621e-01,2.870834e-01,2.897244e-01,2.919583e-01,2.939521e-01, & - &2.449278e-01,2.475000e-01,2.495463e-01,2.512022e-01,2.526750e-01, & - &2.089697e-01,2.109156e-01,2.123967e-01,2.135030e-01,2.144248e-01, & - &1.768794e-01,1.783233e-01,1.793151e-01,1.799753e-01,1.805938e-01, & - &1.489381e-01,1.498907e-01,1.504930e-01,1.509627e-01,1.514318e-01, & - &1.247840e-01,1.254007e-01,1.258392e-01,1.263327e-01,1.267580e-01, & - &1.040890e-01,1.045381e-01,1.050142e-01,1.055080e-01,1.059977e-01, & - &8.683112e-02,8.731959e-02,8.789170e-02,8.847055e-02,8.909160e-02, & - &7.240495e-02,7.303213e-02,7.363865e-02,7.431832e-02,7.510781e-02, & - &6.064542e-02,6.130506e-02,6.201873e-02,6.284705e-02,6.387578e-02, & - &5.088407e-02,5.161227e-02,5.242938e-02,5.344556e-02,5.473720e-02, & - &4.283611e-02,4.363345e-02,4.460663e-02,4.584279e-02,4.741921e-02, & - &3.614792e-02,3.703219e-02,3.815165e-02,3.957359e-02,4.131669e-02, & - &3.052078e-02,3.148578e-02,3.270601e-02,3.424027e-02,3.601583e-02, & - &2.572223e-02,2.670456e-02,2.796917e-02,2.950914e-02,3.126106e-02, & - &2.171494e-02,2.269118e-02,2.395481e-02,2.546375e-02,2.718975e-02, & - &1.839976e-02,1.937073e-02,2.062946e-02,2.211271e-02,2.382706e-02, & - &1.567266e-02,1.664572e-02,1.789606e-02,1.937062e-02,2.109293e-02, & - &1.324660e-02,1.416074e-02,1.534556e-02,1.677786e-02,1.842822e-02, & - &1.121139e-02,1.206334e-02,1.317982e-02,1.454911e-02,1.614843e-02, & - &9.522196e-03,1.032044e-02,1.137654e-02,1.268840e-02,1.424343e-02, & - &8.096633e-03,8.838817e-03,9.830670e-03,1.108444e-02,1.259214e-02, & - &6.900008e-03,7.597120e-03,8.537695e-03,9.740876e-03,1.120062e-02, & - &5.902827e-03,6.572476e-03,7.479060e-03,8.648826e-03,1.007555e-02, & - &5.039576e-03,5.699278e-03,6.573016e-03,7.716807e-03,9.150365e-03, & - &4.264321e-03,4.885680e-03,5.731624e-03,6.846920e-03,8.249952e-03, & - &3.613192e-03,4.201728e-03,5.041244e-03,6.145992e-03,7.552846e-03, & - &3.074126e-03,3.638209e-03,4.463651e-03,5.592571e-03,7.056575e-03, & - &2.592743e-03,3.114758e-03,3.897868e-03,5.008669e-03,6.493957e-03, & - &2.178626e-03,2.648290e-03,3.374472e-03,4.443618e-03,5.915009e-03, & - &1.831619e-03,2.261003e-03,2.940462e-03,3.971533e-03,5.438757e-03, & - &1.544505e-03,1.942200e-03,2.590822e-03,3.596696e-03,5.075439e-03, & - &1.265861e-03,1.605514e-03,2.172655e-03,3.072470e-03,4.435374e-03, & - &1.018207e-03,1.292690e-03,1.761034e-03,2.519225e-03,3.704806e-03, & - &8.166558e-04,1.037487e-03,1.421127e-03,2.069847e-03,3.075089e-03, & - &6.531893e-04,8.295752e-04,1.141193e-03,1.680984e-03,2.535790e-03, & - &5.201491e-04,6.593614e-04,9.078089e-04,1.349359e-03,2.061302e-03, & - &4.120554e-04,5.194437e-04,7.051561e-04,1.041163e-03,1.588217e-03/ - data absb(:,5) / & - &9.311964e+00,1.075342e+01,1.273181e+01,1.550828e+01,1.918246e+01, & - &5.102177e+00,5.639430e+00,6.405612e+00,7.387637e+00,8.533798e+00, & - &3.197285e+00,3.297432e+00,3.503150e+00,3.793406e+00,4.166623e+00, & - &2.387390e+00,2.414949e+00,2.494916e+00,2.608148e+00,2.747157e+00, & - &2.031237e+00,2.056088e+00,2.114968e+00,2.199120e+00,2.299386e+00, & - &1.924605e+00,1.955266e+00,2.011841e+00,2.085771e+00,2.171722e+00, & - &1.854103e+00,1.890269e+00,1.944488e+00,2.012372e+00,2.089463e+00, & - &1.732951e+00,1.770365e+00,1.819067e+00,1.875727e+00,1.937264e+00, & - &1.709460e+00,1.750175e+00,1.795308e+00,1.844735e+00,1.895910e+00, & - &1.751824e+00,1.794628e+00,1.839634e+00,1.887717e+00,1.935761e+00, & - &1.819420e+00,1.862913e+00,1.907652e+00,1.953961e+00,2.000186e+00, & - &1.891613e+00,1.934540e+00,1.977745e+00,2.022275e+00,2.065829e+00, & - &1.951248e+00,1.993168e+00,2.035238e+00,2.076895e+00,2.117307e+00, & - &1.995972e+00,2.037580e+00,2.078168e+00,2.118295e+00,2.156414e+00, & - &2.020422e+00,2.061994e+00,2.102271e+00,2.141314e+00,2.177859e+00, & - &2.025666e+00,2.068475e+00,2.109376e+00,2.148621e+00,2.184841e+00, & - &2.010482e+00,2.054851e+00,2.097999e+00,2.138711e+00,2.176460e+00, & - &1.977004e+00,2.024821e+00,2.071160e+00,2.114491e+00,2.155210e+00, & - &1.932164e+00,1.983728e+00,2.034343e+00,2.081359e+00,2.125398e+00, & - &1.880518e+00,1.937414e+00,1.992496e+00,2.043606e+00,2.091426e+00, & - &1.826606e+00,1.889390e+00,1.949045e+00,2.004454e+00,2.056740e+00, & - &1.774220e+00,1.842891e+00,1.907143e+00,1.967478e+00,2.024210e+00, & - &1.728283e+00,1.802004e+00,1.871310e+00,1.937180e+00,1.999274e+00, & - &1.689262e+00,1.767932e+00,1.842730e+00,1.913908e+00,1.981627e+00, & - &1.659936e+00,1.743924e+00,1.824178e+00,1.901089e+00,1.974465e+00, & - &1.639684e+00,1.729297e+00,1.814944e+00,1.897138e+00,1.977120e+00, & - &1.629377e+00,1.723830e+00,1.814978e+00,1.903411e+00,1.991096e+00, & - &1.623020e+00,1.722115e+00,1.818633e+00,1.913785e+00,2.009635e+00, & - &1.613697e+00,1.717676e+00,1.820131e+00,1.922566e+00,2.026160e+00, & - &1.597827e+00,1.707055e+00,1.815529e+00,1.925358e+00,2.034186e+00, & - &1.568337e+00,1.682197e+00,1.795889e+00,1.911900e+00,2.025363e+00, & - &1.541195e+00,1.659782e+00,1.778949e+00,1.901210e+00,2.019293e+00, & - &1.517591e+00,1.641014e+00,1.766280e+00,1.894972e+00,2.018154e+00, & - &1.479469e+00,1.606478e+00,1.735076e+00,1.867516e+00,1.995579e+00, & - &1.440232e+00,1.570930e+00,1.702370e+00,1.838534e+00,1.970878e+00, & - &1.401808e+00,1.536281e+00,1.670776e+00,1.810637e+00,1.947431e+00, & - &1.356210e+00,1.494321e+00,1.631893e+00,1.775497e+00,1.916950e+00, & - &1.307437e+00,1.449239e+00,1.590385e+00,1.737187e+00,1.883640e+00, & - &1.259084e+00,1.404628e+00,1.549803e+00,1.700315e+00,1.851832e+00, & - &1.207802e+00,1.356250e+00,1.505625e+00,1.659893e+00,1.816145e+00, & - &1.149214e+00,1.300256e+00,1.452871e+00,1.610075e+00,1.770965e+00, & - &1.090886e+00,1.244841e+00,1.400488e+00,1.561760e+00,1.727644e+00, & - &1.033284e+00,1.190700e+00,1.349815e+00,1.515972e+00,1.688220e+00, & - &9.771661e-01,1.137127e+00,1.298386e+00,1.467257e+00,1.644121e+00, & - &9.218393e-01,1.083577e+00,1.246515e+00,1.416699e+00,1.597280e+00, & - &8.676382e-01,1.030920e+00,1.196161e+00,1.368088e+00,1.552801e+00, & - &8.153263e-01,9.800266e-01,1.148122e+00,1.322842e+00,1.512322e+00, & - &7.622355e-01,9.262197e-01,1.094336e+00,1.267605e+00,1.455194e+00, & - &7.081593e-01,8.703451e-01,1.036783e+00,1.207158e+00,1.387829e+00, & - &6.549161e-01,8.153692e-01,9.801594e-01,1.148394e+00,1.323802e+00, & - &6.025538e-01,7.613233e-01,9.244469e-01,1.091189e+00,1.262553e+00, & - &5.532352e-01,7.095056e-01,8.709126e-01,1.035480e+00,1.203842e+00, & - &5.261996e-01,6.789641e-01,8.379563e-01,9.986106e-01,1.160585e+00/ - data absb(:,6) / & - &1.985552e+01,2.661665e+01,3.713998e+01,5.106577e+01,6.924258e+01, & - &1.204299e+01,1.298905e+01,1.436157e+01,1.692379e+01,2.222669e+01, & - &8.582796e+00,8.632161e+00,8.919200e+00,9.531450e+00,1.036044e+01, & - &6.057892e+00,6.005542e+00,6.014052e+00,6.316774e+00,6.772913e+00, & - &4.840484e+00,4.858582e+00,4.911480e+00,5.093039e+00,5.375947e+00, & - &4.633090e+00,4.639239e+00,4.685668e+00,4.852166e+00,5.102160e+00, & - &4.312393e+00,4.336341e+00,4.401626e+00,4.556705e+00,4.774879e+00, & - &3.672118e+00,3.742181e+00,3.818477e+00,3.935577e+00,4.089110e+00, & - &3.413819e+00,3.491572e+00,3.571151e+00,3.687717e+00,3.839810e+00, & - &3.634123e+00,3.720876e+00,3.809288e+00,3.920584e+00,4.065851e+00, & - &3.960081e+00,4.055545e+00,4.148518e+00,4.260529e+00,4.399163e+00, & - &4.348994e+00,4.455914e+00,4.560724e+00,4.677072e+00,4.812430e+00, & - &4.783252e+00,4.903444e+00,5.014253e+00,5.133817e+00,5.266688e+00, & - &5.240514e+00,5.369033e+00,5.486835e+00,5.606701e+00,5.741359e+00, & - &5.700870e+00,5.834535e+00,5.954965e+00,6.077714e+00,6.212727e+00, & - &6.174161e+00,6.303037e+00,6.421875e+00,6.543397e+00,6.676188e+00, & - &6.639678e+00,6.764574e+00,6.873069e+00,6.992756e+00,7.119020e+00, & - &7.091660e+00,7.202910e+00,7.302436e+00,7.417573e+00,7.533311e+00, & - &7.512820e+00,7.615674e+00,7.706283e+00,7.813324e+00,7.919513e+00, & - &7.905974e+00,7.996189e+00,8.080071e+00,8.180590e+00,8.274235e+00, & - &8.264173e+00,8.342340e+00,8.422791e+00,8.516447e+00,8.598555e+00, & - &8.581908e+00,8.655190e+00,8.735579e+00,8.817355e+00,8.888310e+00, & - &8.864656e+00,8.939085e+00,9.019457e+00,9.087708e+00,9.149449e+00, & - &9.113987e+00,9.194525e+00,9.269809e+00,9.329163e+00,9.381195e+00, & - &9.336552e+00,9.423975e+00,9.491235e+00,9.547544e+00,9.598140e+00, & - &9.544595e+00,9.623879e+00,9.686876e+00,9.742743e+00,9.788782e+00, & - &9.730135e+00,9.804092e+00,9.866302e+00,9.920574e+00,9.963306e+00, & - &9.888045e+00,9.961735e+00,1.002056e+01,1.006996e+01,1.010623e+01, & - &1.002320e+01,1.009736e+01,1.015506e+01,1.019918e+01,1.024264e+01, & - &1.013466e+01,1.021038e+01,1.026471e+01,1.030809e+01,1.038222e+01, & - &1.021660e+01,1.029491e+01,1.035030e+01,1.039432e+01,1.048882e+01, & - &1.028805e+01,1.037189e+01,1.042822e+01,1.047756e+01,1.059911e+01, & - &1.035265e+01,1.044266e+01,1.050371e+01,1.056427e+01,1.072384e+01, & - &1.038565e+01,1.048320e+01,1.055137e+01,1.061445e+01,1.077582e+01, & - &1.040727e+01,1.051104e+01,1.058969e+01,1.065525e+01,1.081559e+01, & - &1.042245e+01,1.053348e+01,1.062146e+01,1.069327e+01,1.085558e+01, & - &1.042389e+01,1.054461e+01,1.064493e+01,1.072210e+01,1.088214e+01, & - &1.041602e+01,1.054951e+01,1.065936e+01,1.074534e+01,1.090490e+01, & - &1.039911e+01,1.055000e+01,1.066983e+01,1.076792e+01,1.093253e+01, & - &1.036562e+01,1.053986e+01,1.067384e+01,1.078441e+01,1.095476e+01, & - &1.030916e+01,1.051291e+01,1.066266e+01,1.078567e+01,1.095238e+01, & - &1.024253e+01,1.047592e+01,1.064775e+01,1.078486e+01,1.095550e+01, & - &1.016243e+01,1.043134e+01,1.063431e+01,1.078896e+01,1.096975e+01, & - &1.006288e+01,1.037073e+01,1.060207e+01,1.077631e+01,1.095694e+01, & - &9.940714e+00,1.029522e+01,1.055726e+01,1.075267e+01,1.093248e+01, & - &9.808573e+00,1.020921e+01,1.050481e+01,1.072998e+01,1.091594e+01, & - &9.662390e+00,1.011252e+01,1.044685e+01,1.070360e+01,1.090458e+01, & - &9.492215e+00,9.989658e+00,1.035699e+01,1.063946e+01,1.085172e+01, & - &9.313591e+00,9.840121e+00,1.024772e+01,1.055251e+01,1.078568e+01, & - &9.133559e+00,9.680389e+00,1.012973e+01,1.046105e+01,1.071251e+01, & - &8.947382e+00,9.509417e+00,9.996260e+00,1.035988e+01,1.063359e+01, & - &8.755302e+00,9.341474e+00,9.851616e+00,1.025293e+01,1.054753e+01, & - &8.672781e+00,9.266788e+00,9.757618e+00,1.015815e+01,1.046101e+01/ - data absb(:,7) / & - &5.755861e+01,8.450587e+01,1.192409e+02,1.623188e+02,2.139674e+02, & - &1.807953e+01,2.279366e+01,3.109468e+01,4.358148e+01,5.942914e+01, & - &1.196871e+01,1.219206e+01,1.240001e+01,1.345778e+01,1.656928e+01, & - &9.007339e+00,9.065673e+00,9.093054e+00,9.300925e+00,9.980206e+00, & - &7.158729e+00,7.196052e+00,7.205993e+00,7.407037e+00,7.887890e+00, & - &6.706643e+00,6.796947e+00,6.863601e+00,7.073466e+00,7.466385e+00, & - &6.500778e+00,6.607658e+00,6.689723e+00,6.897429e+00,7.278784e+00, & - &5.765316e+00,5.879944e+00,6.001614e+00,6.239968e+00,6.715654e+00, & - &6.245858e+00,6.403555e+00,6.560860e+00,6.747668e+00,7.110226e+00, & - &6.929299e+00,7.105698e+00,7.271648e+00,7.452462e+00,7.760142e+00, & - &7.639289e+00,7.829226e+00,8.006868e+00,8.191349e+00,8.468019e+00, & - &8.351919e+00,8.557695e+00,8.750980e+00,8.941545e+00,9.202357e+00, & - &9.094355e+00,9.314605e+00,9.522607e+00,9.722685e+00,9.967612e+00, & - &9.906568e+00,1.013950e+01,1.036134e+01,1.057673e+01,1.082012e+01, & - &1.079769e+01,1.104034e+01,1.127587e+01,1.149686e+01,1.173921e+01, & - &1.176601e+01,1.202336e+01,1.226198e+01,1.248054e+01,1.272317e+01, & - &1.279848e+01,1.305632e+01,1.328475e+01,1.349040e+01,1.372759e+01, & - &1.385534e+01,1.410106e+01,1.431149e+01,1.449203e+01,1.470994e+01, & - &1.490681e+01,1.512152e+01,1.530190e+01,1.545965e+01,1.565573e+01, & - &1.591251e+01,1.609638e+01,1.624553e+01,1.637061e+01,1.654786e+01, & - &1.685431e+01,1.700134e+01,1.711515e+01,1.721184e+01,1.737181e+01, & - &1.772272e+01,1.782058e+01,1.788610e+01,1.797006e+01,1.812833e+01, & - &1.849380e+01,1.854165e+01,1.858060e+01,1.867623e+01,1.885781e+01, & - &1.916342e+01,1.916959e+01,1.920426e+01,1.932880e+01,1.954302e+01, & - &1.973808e+01,1.972586e+01,1.979720e+01,1.997797e+01,2.021498e+01, & - &2.022657e+01,2.024156e+01,2.038107e+01,2.060392e+01,2.084867e+01, & - &2.066549e+01,2.075217e+01,2.096418e+01,2.120782e+01,2.146325e+01, & - &2.108041e+01,2.124004e+01,2.148273e+01,2.173761e+01,2.201160e+01, & - &2.147602e+01,2.168596e+01,2.194228e+01,2.221827e+01,2.251866e+01, & - &2.183258e+01,2.206609e+01,2.234291e+01,2.264086e+01,2.295598e+01, & - &2.210912e+01,2.235225e+01,2.264218e+01,2.295213e+01,2.328349e+01, & - &2.236443e+01,2.262279e+01,2.293028e+01,2.326191e+01,2.361317e+01, & - &2.261530e+01,2.289483e+01,2.322672e+01,2.358798e+01,2.397593e+01, & - &2.276575e+01,2.304511e+01,2.338395e+01,2.375727e+01,2.415950e+01, & - &2.289498e+01,2.317361e+01,2.351323e+01,2.389567e+01,2.431246e+01, & - &2.301777e+01,2.329451e+01,2.364335e+01,2.403395e+01,2.446942e+01, & - &2.311988e+01,2.339050e+01,2.374096e+01,2.414379e+01,2.459620e+01, & - &2.321445e+01,2.347617e+01,2.383083e+01,2.424728e+01,2.471787e+01, & - &2.331990e+01,2.356955e+01,2.393339e+01,2.436868e+01,2.486472e+01, & - &2.341851e+01,2.365667e+01,2.402467e+01,2.447968e+01,2.500145e+01, & - &2.350352e+01,2.370271e+01,2.407320e+01,2.453443e+01,2.507615e+01, & - &2.360531e+01,2.377910e+01,2.413997e+01,2.461642e+01,2.519104e+01, & - &2.373550e+01,2.388311e+01,2.423798e+01,2.473804e+01,2.535172e+01, & - &2.386419e+01,2.394005e+01,2.428687e+01,2.478964e+01,2.542170e+01, & - &2.400622e+01,2.398699e+01,2.430341e+01,2.480112e+01,2.543890e+01, & - &2.416765e+01,2.405866e+01,2.434606e+01,2.483506e+01,2.548261e+01, & - &2.434280e+01,2.416206e+01,2.442145e+01,2.491440e+01,2.558001e+01, & - &2.451062e+01,2.419712e+01,2.437225e+01,2.481818e+01,2.545707e+01, & - &2.468439e+01,2.425398e+01,2.426926e+01,2.462864e+01,2.519801e+01, & - &2.486373e+01,2.436886e+01,2.421035e+01,2.446930e+01,2.496196e+01, & - &2.504290e+01,2.451751e+01,2.419946e+01,2.434514e+01,2.475671e+01, & - &2.521270e+01,2.467828e+01,2.424676e+01,2.423149e+01,2.455473e+01, & - &2.528672e+01,2.474924e+01,2.425722e+01,2.404383e+01,2.422076e+01/ - data absb(:,8) / & - &2.965737e+02,4.339776e+02,6.021910e+02,7.999757e+02,1.025191e+03, & - &7.941249e+01,1.201011e+02,1.711263e+02,2.324328e+02,3.044941e+02, & - &1.455635e+01,1.861392e+01,2.538443e+01,3.515834e+01,4.816032e+01, & - &1.090724e+01,1.098360e+01,1.105669e+01,1.132710e+01,1.572249e+01, & - &8.940272e+00,9.027608e+00,9.097308e+00,9.379561e+00,1.276096e+01, & - &8.485369e+00,8.574037e+00,8.639222e+00,8.972054e+00,1.212958e+01, & - &7.951668e+00,8.160000e+00,8.390845e+00,8.856442e+00,1.155465e+01, & - &9.194466e+00,9.559516e+00,9.867785e+00,1.013932e+01,1.099076e+01, & - &1.100413e+01,1.140111e+01,1.175072e+01,1.205431e+01,1.236349e+01, & - &1.310026e+01,1.354316e+01,1.392959e+01,1.426838e+01,1.455919e+01, & - &1.550601e+01,1.599069e+01,1.641770e+01,1.678443e+01,1.709647e+01, & - &1.823369e+01,1.875427e+01,1.920882e+01,1.959752e+01,1.990516e+01, & - &2.127050e+01,2.182304e+01,2.228478e+01,2.266395e+01,2.294021e+01, & - &2.460300e+01,2.516314e+01,2.562288e+01,2.594927e+01,2.619185e+01, & - &2.816247e+01,2.871254e+01,2.910155e+01,2.938164e+01,2.956897e+01, & - &3.194194e+01,3.239911e+01,3.270813e+01,3.291090e+01,3.301684e+01, & - &3.575074e+01,3.610212e+01,3.633456e+01,3.643608e+01,3.642660e+01, & - &3.957767e+01,3.981771e+01,3.992323e+01,3.991756e+01,3.977338e+01, & - &4.335563e+01,4.346526e+01,4.342730e+01,4.325055e+01,4.293562e+01, & - &4.702754e+01,4.693361e+01,4.669421e+01,4.632600e+01,4.582833e+01, & - &5.043661e+01,5.012316e+01,4.967037e+01,4.910172e+01,4.843353e+01, & - &5.349872e+01,5.296771e+01,5.232896e+01,5.156184e+01,5.071632e+01, & - &5.619176e+01,5.546276e+01,5.461324e+01,5.365012e+01,5.263241e+01, & - &5.852574e+01,5.756683e+01,5.652543e+01,5.538128e+01,5.433031e+01, & - &6.045044e+01,5.930274e+01,5.807520e+01,5.681587e+01,5.612216e+01, & - &6.199286e+01,6.067209e+01,5.929131e+01,5.829755e+01,5.840500e+01, & - &6.318908e+01,6.173153e+01,6.047072e+01,6.027616e+01,6.164518e+01, & - &6.414423e+01,6.264014e+01,6.193301e+01,6.280308e+01,6.563157e+01, & - &6.501138e+01,6.373012e+01,6.383686e+01,6.590977e+01,7.035608e+01, & - &6.591141e+01,6.503460e+01,6.595781e+01,6.922716e+01,7.530896e+01, & - &6.695375e+01,6.628429e+01,6.766969e+01,7.169391e+01,7.888933e+01, & - &6.794165e+01,6.757893e+01,6.957480e+01,7.456061e+01,8.314804e+01, & - &6.892001e+01,6.904568e+01,7.191405e+01,7.825334e+01,8.875511e+01, & - &6.982989e+01,6.989212e+01,7.283340e+01,7.948328e+01,9.054536e+01, & - &7.067768e+01,7.062284e+01,7.355531e+01,8.038407e+01,9.192707e+01, & - &7.147599e+01,7.135477e+01,7.434808e+01,8.147806e+01,9.366877e+01, & - &7.232495e+01,7.201167e+01,7.490765e+01,8.214685e+01,9.479776e+01, & - &7.321436e+01,7.268721e+01,7.545398e+01,8.278874e+01,9.594685e+01, & - &7.407660e+01,7.343150e+01,7.616737e+01,8.381709e+01,9.780916e+01, & - &7.499639e+01,7.417623e+01,7.680566e+01,8.469205e+01,9.954404e+01, & - &7.599583e+01,7.484525e+01,7.701104e+01,8.464368e+01,9.964695e+01, & - &7.700861e+01,7.558526e+01,7.752521e+01,8.511626e+01,1.007039e+02, & - &7.799619e+01,7.641261e+01,7.833926e+01,8.637929e+01,1.034046e+02, & - &7.890893e+01,7.712506e+01,7.860590e+01,8.641771e+01,1.037749e+02, & - &7.979858e+01,7.781138e+01,7.870496e+01,8.586375e+01,1.028913e+02, & - &8.064459e+01,7.857211e+01,7.900527e+01,8.581781e+01,1.030315e+02, & - &8.151171e+01,7.937186e+01,7.955100e+01,8.640965e+01,1.046523e+02, & - &8.233821e+01,8.009928e+01,7.933107e+01,8.438705e+01,9.997646e+01, & - &8.311225e+01,8.082582e+01,7.917270e+01,8.176305e+01,9.312660e+01, & - &8.388723e+01,8.156625e+01,7.947339e+01,8.013667e+01,8.797913e+01, & - &8.465843e+01,8.233987e+01,8.010639e+01,7.930945e+01,8.422459e+01, & - &8.542928e+01,8.306716e+01,8.077794e+01,7.908731e+01,8.139794e+01, & - &8.575887e+01,8.337860e+01,8.106123e+01,7.888963e+01,7.840176e+01/ - -! selfref is the array for the self-continuum. - - data selfref(:, 1) / & - &3.132752e-02,2.730281e-02,2.379525e-02,2.073845e-02,1.807446e-02, & - &1.575275e-02,1.372931e-02,1.196596e-02,1.042902e-02,9.089628e-03/ - data selfref(:, 2) / & - &3.054248e-02,2.668524e-02,2.331518e-02,2.037074e-02,1.779813e-02, & - &1.555046e-02,1.358660e-02,1.187078e-02,1.037168e-02,9.061845e-03/ - data selfref(:, 3) / & - &2.973036e-02,2.605795e-02,2.283911e-02,2.001788e-02,1.754519e-02, & - &1.537789e-02,1.347831e-02,1.181340e-02,1.035415e-02,9.075150e-03/ - data selfref(:, 4) / & - &2.971572e-02,2.602072e-02,2.278516e-02,1.995194e-02,1.747104e-02, & - &1.529861e-02,1.339629e-02,1.173052e-02,1.027187e-02,8.994634e-03/ - data selfref(:, 5) / & - &2.979240e-02,2.606840e-02,2.280980e-02,1.995862e-02,1.746377e-02, & - &1.528081e-02,1.337072e-02,1.169938e-02,1.023698e-02,8.957337e-03/ - data selfref(:, 6) / & - &2.953816e-02,2.587559e-02,2.266712e-02,1.985645e-02,1.739434e-02, & - &1.523755e-02,1.334812e-02,1.169304e-02,1.024314e-02,8.973047e-03/ - data selfref(:, 7) / & - &2.939852e-02,2.571926e-02,2.250045e-02,1.968451e-02,1.722098e-02, & - &1.506578e-02,1.318031e-02,1.153084e-02,1.008777e-02,8.825303e-03/ - data selfref(:, 8) / & - &2.808660e-02,2.469700e-02,2.171660e-02,1.909580e-02,1.679130e-02, & - &1.476490e-02,1.298300e-02,1.141620e-02,1.003850e-02,8.827040e-03/ - - data absco2a / & - &2.501494e-05,7.532688e-05,1.039062e-04,3.938513e-04,1.556657e-05, & - &7.607721e-08,5.833222e-08,3.627420e-08 / - - data absco2b / & - &3.000413e-08,2.891436e-07,1.607055e-06,2.537035e-05,5.560827e-04, & - &1.823911e-03,1.148560e-02,3.565805e-02 / - - data absn2oa / & - &3.262165e-02,1.283901e-01,3.770140e-01,5.328684e-01,4.094035e-01, & - &2.270706e-01,1.217090e-01,1.494673e-01 / - - data absn2ob / & - &4.005887e-03,1.487225e-02,5.607064e-02,7.478317e-01,2.094968e+00, & - &4.673797e-02,5.886781e-02,2.923303e-01 / - - data cfc12 / & - &8.741203e+01,7.104260e+01,6.062525e+01,6.180445e+01,6.004920e+01, & - &5.801711e+01,3.676788e+01,3.272258e+01 / - - data cfc22adj / & - &1.127704e+02,7.130121e+01,6.180924e+01,6.892368e+01,4.695927e+01, & - &3.454041e+00,5.279695e+00,5.507705e+00 / - - data fracrefa / & - & 0.30760002136, 0.27556997538, 0.21771389246, 0.14272040129, & - & 0.04578797892, 0.00666586030, 0.00339492992, 0.00054808997 / - data fracrefb / & - & 0.28834301233, 0.27596497536, 0.22501100600, 0.15044370294, & - & 0.04875924066, 0.00712381024, 0.00373242004, 0.00062300998 / - - data h2oref / & - & 1.87599e-02,1.22233e-02,5.89086e-03,2.76753e-03,1.40651e-03, & - & 7.59698e-04,3.88758e-04,1.65422e-04,3.71895e-05,7.47648e-06, & - & 4.30818e-06,3.33194e-06,3.20393e-06,3.16186e-06,3.25235e-06, & - & 3.42258e-06,3.62884e-06,3.91482e-06,4.14875e-06,4.30810e-06, & - & 4.44204e-06,4.57783e-06,4.70865e-06,4.79432e-06,4.86971e-06, & - & 4.92603e-06,4.96688e-06,4.99628e-06,5.05266e-06,5.12658e-06, & - & 5.25028e-06,5.35708e-06,5.45085e-06,5.48304e-06,5.50000e-06, & - & 5.50000e-06,5.45359e-06,5.40468e-06,5.35576e-06,5.25327e-06, & - & 5.14362e-06,5.03396e-06,4.87662e-06,4.69787e-06,4.51911e-06, & - & 4.33600e-06,4.14416e-06,3.95232e-06,3.76048e-06,3.57217e-06, & - & 3.38549e-06,3.19881e-06,3.01212e-06,2.82621e-06,2.64068e-06, & - & 2.45515e-06,2.26962e-06,2.08659e-06,1.93029e-06 / - - data o3ref / & - & 3.01700e-08,3.47254e-08,4.24769e-08,5.27592e-08,6.69439e-08, & - & 8.71295e-08,1.13911e-07,1.56771e-07,2.17878e-07,3.24430e-07, & - & 4.65942e-07,5.68057e-07,6.96065e-07,1.11863e-06,1.76175e-06, & - & 2.32689e-06,2.95769e-06,3.65930e-06,4.59503e-06,5.31891e-06, & - & 5.96179e-06,6.51133e-06,7.06350e-06,7.69169e-06,8.25771e-06, & - & 8.70824e-06,8.83245e-06,8.71486e-06,8.09434e-06,7.33071e-06, & - & 6.31014e-06,5.36717e-06,4.48289e-06,3.83913e-06,3.28270e-06, & - & 2.82351e-06,2.49061e-06,2.16453e-06,1.83845e-06,1.66182e-06, & - & 1.50517e-06,1.34852e-06,1.19718e-06,1.04822e-06,8.99264e-07, & - & 7.63432e-07,6.53806e-07,5.44186e-07,4.34564e-07,3.64210e-07, & - & 3.11938e-07,2.59667e-07,2.07395e-07,1.91456e-07,1.93639e-07, & - & 1.95821e-07,1.98004e-07,2.06442e-07,2.81546e-07 / - - data n2oref / & - & 3.20000e-07,3.20000e-07,3.20000e-07,3.20000e-07,3.20000e-07, & - & 3.19652e-07,3.15324e-07,3.03830e-07,2.94221e-07,2.84953e-07, & - & 2.76714e-07,2.64709e-07,2.42847e-07,2.09547e-07,1.71945e-07, & - & 1.37491e-07,1.13319e-07,1.00354e-07,9.12812e-08,8.54633e-08, & - & 8.03631e-08,7.33718e-08,6.59754e-08,5.60386e-08,4.70901e-08, & - & 3.99774e-08,3.29786e-08,2.60642e-08,2.10663e-08,1.65918e-08, & - & 1.30167e-08,1.00900e-08,7.62490e-09,6.11592e-09,4.66725e-09, & - & 3.28574e-09,2.84838e-09,2.46198e-09,2.07557e-09,1.85507e-09, & - & 1.65675e-09,1.45843e-09,1.31948e-09,1.20716e-09,1.09485e-09, & - & 9.97803e-10,9.31260e-10,8.64721e-10,7.98181e-10,7.51380e-10, & - & 7.13670e-10,6.75960e-10,6.38250e-10,6.09811e-10,5.85998e-10, & - & 5.62185e-10,5.38371e-10,5.15183e-10,4.98660e-10 / - -!........................................! - end module module_radlw_kgb08 ! -!========================================! - - - -!========================================! - module module_radlw_kgb09 ! -!........................................! -! - use machine, only : kind_phys - use module_radlw_parameters, only : NG09 -! - implicit none -! - private -! - integer, public :: MSA09, MSB09, MSF09, MAF09, MEF09, MOF09 - parameter (MSA09=715, MSB09=235, MSF09=10) - parameter (MAF09=9, MEF09=11, MOF09=13) - - real (kind=kind_phys), public :: & - & absa(MSA09,NG09), absb(MSB09,NG09), selfref(MSF09,NG09), & - & absn2o(3*NG09), fracrefa(NG09,MAF09), fracrefb(NG09), & - & h2oref(MOF09), ch4ref(MOF09), n2oref(MOF09), etaref(MEF09) - -! the array absa(715,NG09) = ka(11,5,13,NG09) contains absorption coefs -! at the NG09=12 chosen g-values for a range of pressure levels>~100mb, -! temperatures, and binary species parameters (see taumol.f for -! definition). the first index in the array, js, runs from 1 to 11, -! and corresponds to different values of the binary species parameter. -! for instance, js=1 refers to dry air, js = 2 corresponds to the -! paramter value 1/8, js = 3 corresponds to the parameter value 2/8, -! etc. the second index in the array, jt, which runs from 1 to 5, -! corresponds to different temperatures. more specifically, jt = 1-5 -! means that the data are for the corresponding temperature of tref-30, -! tref-15, tref, tref+15, and tref+30, respectively. the third index, -! jp, runs from 1 to 13 and refers to the jpth reference pressure level -! (see taumol.f for these levels in mb). the fourth index, ig, goes -! from 1 to NG09=12, and indicates which g-interval the absorption -! coefficients are for. - - data absa(1:330,1) / & - &1.851100e-03,2.168400e-03,1.980600e-03,1.740200e-03,1.477500e-03, & - &1.196600e-03,8.943300e-04,5.622100e-04,3.042800e-04,1.843900e-04, & - &1.310200e-04,2.089400e-03,2.452300e-03,2.250000e-03,1.981800e-03, & - &1.687500e-03,1.372900e-03,1.029800e-03,6.534400e-04,3.585700e-04, & - &2.208200e-04,1.579400e-04,2.333000e-03,2.744900e-03,2.529400e-03, & - &2.234500e-03,1.909500e-03,1.560200e-03,1.175700e-03,7.551200e-04, & - &4.201500e-04,2.622200e-04,1.899300e-04,2.583500e-03,3.049000e-03, & - &2.822100e-03,2.501800e-03,2.146500e-03,1.759500e-03,1.334400e-03, & - &8.672400e-04,4.889700e-04,3.097100e-04,2.274600e-04,2.840400e-03, & - &3.365500e-03,3.129200e-03,2.785100e-03,2.398400e-03,1.973000e-03, & - &1.506500e-03,9.902300e-04,5.658900e-04,3.641000e-04,2.711600e-04, & - &1.546900e-03,1.826000e-03,1.677900e-03,1.474300e-03,1.252300e-03, & - &1.014600e-03,7.580200e-04,4.736200e-04,2.524800e-04,1.496000e-04, & - &1.031300e-04,1.757300e-03,2.075000e-03,1.914900e-03,1.686700e-03, & - &1.436500e-03,1.168000e-03,8.763200e-04,5.525000e-04,2.987900e-04, & - &1.795100e-04,1.246600e-04,1.973600e-03,2.335000e-03,2.162700e-03, & - &1.910400e-03,1.632200e-03,1.332400e-03,1.003500e-03,6.400000e-04, & - &3.511900e-04,2.134300e-04,1.499100e-04,2.196100e-03,2.605700e-03, & - &2.422700e-03,2.147000e-03,1.841200e-03,1.508400e-03,1.141700e-03, & - &7.366600e-04,4.098000e-04,2.522800e-04,1.795500e-04,2.422600e-03, & - &2.888700e-03,2.697500e-03,2.399500e-03,2.064100e-03,1.696700e-03, & - &1.292200e-03,8.430900e-04,4.752500e-04,2.967600e-04,2.140200e-04, & - &1.248700e-03,1.485900e-03,1.370300e-03,1.203400e-03,1.023300e-03, & - &8.293400e-04,6.187000e-04,3.849100e-04,2.006100e-04,1.164400e-04, & - &8.303400e-05,1.430600e-03,1.700800e-03,1.576200e-03,1.387700e-03, & - &1.182900e-03,9.613800e-04,7.200900e-04,4.511500e-04,2.387100e-04, & - &1.406000e-04,1.002400e-04,1.618900e-03,1.927800e-03,1.792800e-03, & - &1.582700e-03,1.352500e-03,1.102800e-03,8.293900e-04,5.245300e-04, & - &2.819000e-04,1.678900e-04,1.202200e-04,1.813500e-03,2.167100e-03, & - &2.021100e-03,1.789100e-03,1.534100e-03,1.254400e-03,9.474500e-04, & - &6.058900e-04,3.303500e-04,1.988600e-04,1.433500e-04,2.011900e-03, & - &2.417400e-03,2.262800e-03,2.010400e-03,1.728100e-03,1.417100e-03, & - &1.076300e-03,6.955600e-04,3.848500e-04,2.341300e-04,1.702500e-04, & - &9.933200e-04,1.193700e-03,1.104100e-03,9.686800e-04,8.236000e-04, & - &6.672500e-04,4.972900e-04,3.081200e-04,1.570900e-04,8.917700e-05, & - &7.038200e-05,1.148900e-03,1.378200e-03,1.281200e-03,1.127200e-03, & - &9.605200e-04,7.801600e-04,5.830500e-04,3.633300e-04,1.880100e-04, & - &1.083500e-04,8.494900e-05,1.311100e-03,1.573800e-03,1.468500e-03, & - &1.295700e-03,1.106700e-03,9.012600e-04,6.761200e-04,4.245300e-04, & - &2.232200e-04,1.301000e-04,1.018200e-04,1.478400e-03,1.781600e-03, & - &1.667200e-03,1.476000e-03,1.264000e-03,1.031100e-03,7.766300e-04, & - &4.925400e-04,2.627400e-04,1.547900e-04,1.215100e-04,1.649800e-03, & - &2.000500e-03,1.877600e-03,1.668200e-03,1.432100e-03,1.171300e-03, & - &8.863200e-04,5.675000e-04,3.071100e-04,1.830500e-04,1.440600e-04, & - &7.856200e-04,9.548500e-04,8.873100e-04,7.776000e-04,6.604200e-04, & - &5.346500e-04,3.981800e-04,2.450700e-04,1.228000e-04,6.802400e-05, & - &6.289200e-05,9.178800e-04,1.113000e-03,1.038700e-03,9.134800e-04, & - &7.773900e-04,6.307900e-04,4.708300e-04,2.914400e-04,1.478600e-04, & - &8.315000e-05,7.583600e-05,1.056400e-03,1.281500e-03,1.199300e-03, & - &1.058400e-03,9.028600e-04,7.347200e-04,5.498800e-04,3.425700e-04, & - &1.764600e-04,1.004200e-04,9.078400e-05,1.200000e-03,1.460700e-03, & - &1.370600e-03,1.214300e-03,1.038500e-03,8.462600e-04,6.353500e-04, & - &3.992400e-04,2.085900e-04,1.201400e-04,1.078900e-04,1.347000e-03, & - &1.649300e-03,1.553400e-03,1.381500e-03,1.184100e-03,9.667000e-04, & - &7.290200e-04,4.617600e-04,2.447200e-04,1.426200e-04,1.276000e-04, & - &6.130900e-04,7.552900e-04,7.057300e-04,6.181400e-04,5.242300e-04, & - &4.238800e-04,3.149300e-04,1.925300e-04,9.510400e-05,5.140000e-05, & - &5.851100e-05,7.252900e-04,8.903800e-04,8.347000e-04,7.339400e-04, & - &6.238200e-04,5.054000e-04,3.764000e-04,2.313100e-04,1.153700e-04, & - &6.330500e-05,7.059100e-05,8.433400e-04,1.033600e-03,9.718400e-04, & - &8.581200e-04,7.309200e-04,5.938100e-04,4.432900e-04,2.740900e-04, & - &1.384800e-04,7.688400e-05,8.436800e-05,9.659100e-04,1.186100e-03, & - &1.118100e-03,9.918300e-04,8.467700e-04,6.896900e-04,5.157900e-04, & - &3.211200e-04,1.644600e-04,9.242000e-05,9.999600e-05,1.091900e-03, & - &1.346800e-03,1.274300e-03,1.135500e-03,9.718100e-04,7.928600e-04, & - &5.951900e-04,3.731400e-04,1.936700e-04,1.102500e-04,1.178100e-04/ - data absa(331:715,1) / & - &4.715600e-04,5.893700e-04,5.533200e-04,4.846900e-04,4.104800e-04, & - &3.315500e-04,2.455400e-04,1.493800e-04,7.289500e-05,3.859500e-05, & - &5.726400e-05,5.649500e-04,7.029400e-04,6.616700e-04,5.824500e-04, & - &4.943900e-04,4.000200e-04,2.968200e-04,1.814000e-04,8.922700e-05, & - &4.791600e-05,6.967700e-05,6.643900e-04,8.237300e-04,7.772100e-04, & - &6.874400e-04,5.849000e-04,4.744800e-04,3.531800e-04,2.168900e-04, & - &1.078300e-04,5.866700e-05,8.361800e-05,7.690100e-04,9.523900e-04, & - &9.013300e-04,8.007900e-04,6.827600e-04,5.553600e-04,4.144900e-04, & - &2.560200e-04,1.288100e-04,7.093400e-05,9.924500e-05,8.768700e-04, & - &1.088200e-03,1.033700e-03,9.227700e-04,7.886000e-04,6.429800e-04, & - &4.815200e-04,2.991700e-04,1.523500e-04,8.499000e-05,1.166800e-04, & - &3.614900e-04,4.573900e-04,4.317200e-04,3.785600e-04,3.200500e-04, & - &2.578200e-04,1.904500e-04,1.154100e-04,5.576000e-05,2.896800e-05, & - &6.334800e-05,4.385600e-04,5.528400e-04,5.231700e-04,4.612800e-04, & - &3.908000e-04,3.152500e-04,2.333200e-04,1.419600e-04,6.889300e-05, & - &3.625700e-05,7.822700e-05,5.218000e-04,6.549500e-04,6.212200e-04, & - &5.505000e-04,4.673900e-04,3.778300e-04,2.805200e-04,1.714100e-04, & - &8.388400e-05,4.474600e-05,9.484900e-05,6.104100e-04,7.642800e-04, & - &7.262600e-04,6.466700e-04,5.503900e-04,4.461600e-04,3.322000e-04, & - &2.038800e-04,1.008700e-04,5.447900e-05,1.129900e-04,7.026300e-04, & - &8.796100e-04,8.386600e-04,7.502400e-04,6.401200e-04,5.201500e-04, & - &3.885800e-04,2.398700e-04,1.199100e-04,6.560000e-05,1.330000e-04, & - &2.758800e-04,3.536300e-04,3.356400e-04,2.944200e-04,2.484500e-04, & - &1.994400e-04,1.468700e-04,8.884600e-05,4.256400e-05,2.169400e-05, & - &1.163500e-04,3.392600e-04,4.333100e-04,4.125600e-04,3.645600e-04, & - &3.081800e-04,2.478100e-04,1.829200e-04,1.109800e-04,5.324800e-05, & - &2.739500e-05,1.447800e-04,4.086700e-04,5.190100e-04,4.955400e-04, & - &4.407300e-04,3.733800e-04,3.009600e-04,2.228400e-04,1.355800e-04, & - &6.539400e-05,3.410600e-05,1.766500e-04,4.831100e-04,6.115500e-04, & - &5.849600e-04,5.231900e-04,4.442100e-04,3.590100e-04,2.666800e-04, & - &1.626600e-04,7.918500e-05,4.180800e-05,2.118700e-04,5.614500e-04, & - &7.098100e-04,6.809300e-04,6.116400e-04,5.209000e-04,4.221800e-04, & - &3.145100e-04,1.925700e-04,9.469000e-05,5.064400e-05,2.509700e-04, & - &2.132500e-04,2.776100e-04,2.655600e-04,2.333500e-04,1.965100e-04, & - &1.571800e-04,1.152500e-04,6.947500e-05,3.306400e-05,1.659400e-05, & - &2.609300e-04,2.652300e-04,3.441500e-04,3.305900e-04,2.932700e-04, & - &2.472100e-04,1.981400e-04,1.456200e-04,8.801500e-05,4.195600e-05, & - &2.111500e-05,3.238700e-04,3.229800e-04,4.166000e-04,4.008800e-04, & - &3.583600e-04,3.026400e-04,2.432400e-04,1.795100e-04,1.089300e-04, & - &5.207700e-05,2.647500e-05,3.966500e-04,3.855500e-04,4.951500e-04, & - &4.768800e-04,4.287600e-04,3.634200e-04,2.929400e-04,2.170400e-04, & - &1.320300e-04,6.350800e-05,3.266900e-05,4.788800e-04,4.521400e-04, & - &5.786100e-04,5.586900e-04,5.046900e-04,4.296000e-04,3.473800e-04, & - &2.581800e-04,1.575500e-04,7.635300e-05,3.976700e-05,5.695300e-04, & - &1.826300e-04,2.413200e-04,2.337500e-04,2.068900e-04,1.739200e-04, & - &1.388500e-04,1.015300e-04,6.101200e-05,2.884400e-05,1.431800e-05, & - &3.150000e-04,2.272900e-04,2.988200e-04,2.903500e-04,2.599300e-04, & - &2.187300e-04,1.749900e-04,1.283700e-04,7.741100e-05,3.672400e-05, & - &1.824800e-05,3.907500e-04,2.770200e-04,3.618600e-04,3.514200e-04, & - &3.172400e-04,2.680400e-04,2.150500e-04,1.584000e-04,9.589700e-05, & - &4.569800e-05,2.286900e-05,4.780700e-04,3.309000e-04,4.299000e-04, & - &4.178600e-04,3.788700e-04,3.221000e-04,2.591400e-04,1.916600e-04, & - &1.164800e-04,5.575600e-05,2.822700e-05,5.739700e-04,3.879700e-04, & - &5.022200e-04,4.894100e-04,4.456300e-04,3.806900e-04,3.073800e-04, & - &2.281600e-04,1.391700e-04,6.702100e-05,3.433900e-05,6.766900e-04, & - &1.544100e-04,2.056400e-04,2.009600e-04,1.792300e-04,1.506100e-04, & - &1.202000e-04,8.784100e-05,5.271800e-05,2.484100e-05,1.224700e-05, & - &3.077900e-04,1.921200e-04,2.544900e-04,2.489500e-04,2.247100e-04, & - &1.893100e-04,1.514300e-04,1.110300e-04,6.693300e-05,3.166000e-05, & - &1.561700e-05,3.820900e-04,2.341200e-04,3.081500e-04,3.011100e-04, & - &2.735400e-04,2.319600e-04,1.860500e-04,1.369900e-04,8.296900e-05, & - &3.946600e-05,1.959500e-05,4.672700e-04,2.795600e-04,3.658300e-04, & - &3.579300e-04,3.266800e-04,2.786600e-04,2.241300e-04,1.657100e-04, & - &1.008300e-04,4.818700e-05,2.418200e-05,5.591100e-04,3.277000e-04, & - &4.271600e-04,4.190700e-04,3.839000e-04,3.294100e-04,2.657800e-04, & - &1.972200e-04,1.204700e-04,5.791000e-05,2.940200e-05,6.572900e-04, & - &1.292600e-04,1.728500e-04,1.697700e-04,1.524300e-04,1.281500e-04, & - &1.023000e-04,7.479400e-05,4.487600e-05,2.114300e-05,1.039500e-05, & - &2.548100e-04,1.607600e-04,2.139100e-04,2.100100e-04,1.906200e-04, & - &1.610400e-04,1.288300e-04,9.449900e-05,5.696800e-05,2.698300e-05, & - &1.325900e-05,3.162800e-04,1.959100e-04,2.590500e-04,2.540800e-04, & - &2.320300e-04,1.973200e-04,1.582600e-04,1.165500e-04,7.065600e-05, & - &3.365800e-05,1.663800e-05,3.865200e-04,2.339000e-04,3.075100e-04, & - &3.020500e-04,2.769800e-04,2.371200e-04,1.907800e-04,1.410400e-04, & - &8.592900e-05,4.110900e-05,2.053200e-05,4.619900e-04,2.740800e-04, & - &3.591600e-04,3.537100e-04,3.254900e-04,2.804600e-04,2.263000e-04, & - &1.679000e-04,1.026800e-04,4.940200e-05,2.496000e-05,5.428900e-04/ - data absa(1:330,2) / & - &6.040700e-03,7.806500e-03,8.184600e-03,7.890600e-03,7.191000e-03, & - &6.110800e-03,4.690800e-03,3.007000e-03,1.602900e-03,8.966300e-04, & - &5.416100e-04,6.819500e-03,8.671700e-03,9.029800e-03,8.702200e-03, & - &7.933000e-03,6.759700e-03,5.227500e-03,3.398900e-03,1.852000e-03, & - &1.047700e-03,6.383300e-04,7.578800e-03,9.538800e-03,9.903600e-03, & - &9.560400e-03,8.725400e-03,7.450400e-03,5.806400e-03,3.825100e-03, & - &2.123800e-03,1.216100e-03,7.523100e-04,8.330300e-03,1.041900e-02, & - &1.081300e-02,1.046100e-02,9.555600e-03,8.195600e-03,6.432400e-03, & - &4.292100e-03,2.411500e-03,1.405200e-03,8.829400e-04,9.055900e-03, & - &1.132000e-02,1.175300e-02,1.138400e-02,1.042100e-02,8.993200e-03, & - &7.109400e-03,4.802000e-03,2.723300e-03,1.615000e-03,1.032100e-03, & - &5.212400e-03,6.681900e-03,6.978900e-03,6.746500e-03,6.167400e-03, & - &5.254900e-03,4.019300e-03,2.553900e-03,1.346800e-03,7.462100e-04, & - &4.473100e-04,5.876900e-03,7.430000e-03,7.710500e-03,7.454600e-03, & - &6.816900e-03,5.824100e-03,4.483200e-03,2.888400e-03,1.557800e-03, & - &8.744800e-04,5.284900e-04,6.533700e-03,8.186000e-03,8.475900e-03, & - &8.205700e-03,7.506700e-03,6.427300e-03,4.985700e-03,3.255300e-03, & - &1.788000e-03,1.018500e-03,6.232100e-04,7.181600e-03,8.955200e-03, & - &9.274900e-03,8.999300e-03,8.230300e-03,7.066200e-03,5.532300e-03, & - &3.658300e-03,2.036700e-03,1.180400e-03,7.323100e-04,7.805100e-03, & - &9.750600e-03,1.010100e-02,9.807100e-03,8.987300e-03,7.750800e-03, & - &6.124300e-03,4.102200e-03,2.306300e-03,1.358500e-03,8.564700e-04, & - &4.352300e-03,5.552000e-03,5.777500e-03,5.591300e-03,5.122300e-03, & - &4.382600e-03,3.361000e-03,2.116100e-03,1.095100e-03,5.955600e-04, & - &3.785700e-04,4.920900e-03,6.200200e-03,6.408200e-03,6.196500e-03, & - &5.675200e-03,4.874400e-03,3.763600e-03,2.398500e-03,1.270000e-03, & - &7.029100e-04,4.509600e-04,5.486800e-03,6.850200e-03,7.066700e-03, & - &6.842700e-03,6.271200e-03,5.395700e-03,4.194000e-03,2.707700e-03, & - &1.461500e-03,8.215000e-04,5.328600e-04,6.041700e-03,7.516000e-03, & - &7.755300e-03,7.524200e-03,6.905600e-03,5.950900e-03,4.657800e-03, & - &3.047700e-03,1.670300e-03,9.561100e-04,6.257900e-04,6.581800e-03, & - &8.204500e-03,8.468700e-03,8.229000e-03,7.571200e-03,6.544800e-03, & - &5.161800e-03,3.423900e-03,1.898400e-03,1.104900e-03,7.310000e-04, & - &3.603700e-03,4.561900e-03,4.728400e-03,4.575800e-03,4.194200e-03, & - &3.599200e-03,2.769500e-03,1.738000e-03,8.822000e-04,4.688500e-04, & - &3.362500e-04,4.088700e-03,5.114800e-03,5.271000e-03,5.089800e-03, & - &4.663200e-03,4.015700e-03,3.115500e-03,1.980100e-03,1.025600e-03, & - &5.568100e-04,4.036300e-04,4.572900e-03,5.672200e-03,5.830900e-03, & - &5.638400e-03,5.172500e-03,4.461700e-03,3.483700e-03,2.242000e-03, & - &1.183700e-03,6.545100e-04,4.781400e-04,5.050000e-03,6.243500e-03, & - &6.420000e-03,6.217800e-03,5.716800e-03,4.941500e-03,3.879300e-03, & - &2.528000e-03,1.356800e-03,7.638600e-04,5.613900e-04,5.516600e-03, & - &6.832700e-03,7.029200e-03,6.823700e-03,6.295000e-03,5.456800e-03, & - &4.312800e-03,2.842100e-03,1.548500e-03,8.860500e-04,6.540200e-04, & - &2.985300e-03,3.740700e-03,3.855600e-03,3.731200e-03,3.419000e-03, & - &2.942800e-03,2.272300e-03,1.419800e-03,7.109100e-04,3.685500e-04, & - &3.161100e-04,3.402200e-03,4.214100e-03,4.318800e-03,4.165700e-03, & - &3.815200e-03,3.292200e-03,2.562900e-03,1.624400e-03,8.291400e-04, & - &4.395600e-04,3.792000e-04,3.816300e-03,4.690800e-03,4.797600e-03, & - &4.628100e-03,4.245000e-03,3.671900e-03,2.873400e-03,1.846400e-03, & - &9.602300e-04,5.191800e-04,4.504400e-04,4.223800e-03,5.181200e-03, & - &5.298700e-03,5.118700e-03,4.707100e-03,4.081000e-03,3.211100e-03, & - &2.088300e-03,1.104200e-03,6.090100e-04,5.305700e-04,4.624200e-03, & - &5.684900e-03,5.816300e-03,5.631600e-03,5.200500e-03,4.523300e-03, & - &3.578000e-03,2.353600e-03,1.263900e-03,7.082200e-04,6.174800e-04, & - &2.449800e-03,3.047500e-03,3.122000e-03,3.019600e-03,2.765200e-03, & - &2.388900e-03,1.849100e-03,1.148900e-03,5.671400e-04,2.878300e-04, & - &3.108000e-04,2.808000e-03,3.452000e-03,3.515700e-03,3.387000e-03, & - &3.098000e-03,2.679300e-03,2.090300e-03,1.319700e-03,6.650100e-04, & - &3.447200e-04,3.705100e-04,3.164000e-03,3.860100e-03,3.922900e-03, & - &3.777400e-03,3.458900e-03,2.997700e-03,2.351000e-03,1.504000e-03, & - &7.739800e-04,4.089600e-04,4.379600e-04,3.513200e-03,4.279400e-03, & - &4.347800e-03,4.188200e-03,3.847400e-03,3.340300e-03,2.634000e-03, & - &1.706000e-03,8.943100e-04,4.818800e-04,5.144600e-04,3.860400e-03, & - &4.709900e-03,4.788600e-03,4.620500e-03,4.261600e-03,3.713900e-03, & - &2.943800e-03,1.928300e-03,1.027200e-03,5.632400e-04,5.997800e-04/ - data absa(331:715,2) / & - &1.982800e-03,2.455500e-03,2.508900e-03,2.426500e-03,2.222200e-03, & - &1.921900e-03,1.491700e-03,9.216900e-04,4.493500e-04,2.235500e-04, & - &3.290500e-04,2.289800e-03,2.801500e-03,2.840400e-03,2.734300e-03, & - &2.499500e-03,2.163800e-03,1.690500e-03,1.062900e-03,5.297700e-04, & - &2.695300e-04,3.864200e-04,2.595000e-03,3.149500e-03,3.184700e-03, & - &3.060800e-03,2.798800e-03,2.427100e-03,1.906300e-03,1.215700e-03, & - &6.188900e-04,3.212100e-04,4.523800e-04,2.894600e-03,3.506600e-03, & - &3.542600e-03,3.404000e-03,3.122700e-03,2.713500e-03,2.141700e-03, & - &1.382500e-03,7.173900e-04,3.795700e-04,5.278400e-04,3.193100e-03, & - &3.874000e-03,3.915100e-03,3.765400e-03,3.468400e-03,3.025500e-03, & - &2.399200e-03,1.566000e-03,8.265200e-04,4.453700e-04,6.146600e-04, & - &1.598900e-03,1.970200e-03,2.011500e-03,1.947000e-03,1.784400e-03, & - &1.543200e-03,1.199500e-03,7.370900e-04,3.546000e-04,1.723900e-04, & - &4.007700e-04,1.861200e-03,2.266700e-03,2.290400e-03,2.204400e-03, & - &2.014700e-03,1.743900e-03,1.363500e-03,8.534400e-04,4.207400e-04, & - &2.096700e-04,4.658200e-04,2.124400e-03,2.562400e-03,2.578900e-03, & - &2.475500e-03,2.263000e-03,1.962200e-03,1.542500e-03,9.798700e-04, & - &4.931900e-04,2.514200e-04,5.405500e-04,2.381900e-03,2.864900e-03, & - &2.881300e-03,2.761800e-03,2.530600e-03,2.200500e-03,1.738200e-03, & - &1.117900e-03,5.732600e-04,2.983300e-04,6.246800e-04,2.638400e-03, & - &3.177100e-03,3.195300e-03,3.063400e-03,2.817400e-03,2.458300e-03, & - &1.952000e-03,1.269600e-03,6.623300e-04,3.512100e-04,7.193200e-04, & - &1.287400e-03,1.580700e-03,1.610500e-03,1.559600e-03,1.433100e-03, & - &1.240900e-03,9.646700e-04,5.885500e-04,2.787800e-04,1.322300e-04, & - &7.162400e-04,1.512300e-03,1.833600e-03,1.847700e-03,1.775800e-03, & - &1.624900e-03,1.406600e-03,1.099600e-03,6.844800e-04,3.332200e-04, & - &1.624700e-04,8.265100e-04,1.740500e-03,2.086000e-03,2.090200e-03, & - &2.002300e-03,1.831000e-03,1.586400e-03,1.247500e-03,7.893500e-04, & - &3.923900e-04,1.960900e-04,9.517700e-04,1.964500e-03,2.344200e-03, & - &2.345600e-03,2.242700e-03,2.052500e-03,1.783100e-03,1.409600e-03, & - &9.034300e-04,4.575100e-04,2.337400e-04,1.093300e-03,2.185800e-03, & - &2.609700e-03,2.611300e-03,2.495300e-03,2.289700e-03,1.995000e-03, & - &1.586000e-03,1.028800e-03,5.296900e-04,2.760300e-04,1.250800e-03, & - &1.052900e-03,1.286900e-03,1.305700e-03,1.264100e-03,1.162900e-03, & - &1.008000e-03,7.849500e-04,4.762000e-04,2.217000e-04,1.027000e-04, & - &1.358000e-03,1.249000e-03,1.507400e-03,1.513100e-03,1.449500e-03, & - &1.325700e-03,1.147100e-03,8.982500e-04,5.559300e-04,2.668100e-04, & - &1.275000e-04,1.597100e-03,1.449200e-03,1.726000e-03,1.721500e-03, & - &1.642600e-03,1.500500e-03,1.298500e-03,1.021600e-03,6.423900e-04, & - &3.156800e-04,1.547900e-04,1.866700e-03,1.645800e-03,1.948100e-03, & - &1.938500e-03,1.846800e-03,1.687200e-03,1.462500e-03,1.156800e-03, & - &7.372300e-04,3.691700e-04,1.851200e-04,2.159200e-03,1.838800e-03, & - &2.176800e-03,2.165800e-03,2.061300e-03,1.886600e-03,1.639800e-03, & - &1.304100e-03,8.413100e-04,4.282700e-04,2.191300e-04,2.469700e-03, & - &9.365200e-04,1.138500e-03,1.147100e-03,1.104400e-03,1.013300e-03, & - &8.764500e-04,6.841200e-04,4.172400e-04,1.935600e-04,8.882700e-05, & - &1.580700e-03,1.110000e-03,1.332200e-03,1.328200e-03,1.266700e-03, & - &1.157700e-03,1.000200e-03,7.840700e-04,4.862900e-04,2.322400e-04, & - &1.100700e-04,1.854700e-03,1.285600e-03,1.523200e-03,1.512100e-03, & - &1.436800e-03,1.311700e-03,1.133400e-03,8.932900e-04,5.616900e-04, & - &2.743500e-04,1.333100e-04,2.155900e-03,1.454900e-03,1.717500e-03, & - &1.703500e-03,1.617100e-03,1.475900e-03,1.278100e-03,1.011900e-03, & - &6.444200e-04,3.204600e-04,1.589500e-04,2.483400e-03,1.622400e-03, & - &1.918700e-03,1.902300e-03,1.805800e-03,1.650400e-03,1.433400e-03, & - &1.140300e-03,7.350900e-04,3.715700e-04,1.878300e-04,2.835000e-03, & - &8.182700e-04,9.936100e-04,9.959800e-04,9.554800e-04,8.764500e-04, & - &7.589100e-04,5.939800e-04,3.631000e-04,1.683000e-04,7.662700e-05, & - &1.534600e-03,9.679800e-04,1.160400e-03,1.152500e-03,1.096000e-03, & - &1.002700e-03,8.674800e-04,6.818100e-04,4.234100e-04,2.015100e-04, & - &9.470800e-05,1.797100e-03,1.116100e-03,1.323900e-03,1.311800e-03, & - &1.244400e-03,1.136900e-03,9.834600e-04,7.778300e-04,4.895400e-04, & - &2.377400e-04,1.143700e-04,2.082300e-03,1.259500e-03,1.490100e-03, & - &1.476100e-03,1.399600e-03,1.279200e-03,1.109200e-03,8.815900e-04, & - &5.621000e-04,2.774700e-04,1.360900e-04,2.391300e-03,1.401500e-03, & - &1.663100e-03,1.646900e-03,1.563300e-03,1.430900e-03,1.244700e-03, & - &9.932700e-04,6.412700e-04,3.213100e-04,1.604900e-04,2.723000e-03, & - &7.040400e-04,8.565300e-04,8.558300e-04,8.188700e-04,7.512300e-04, & - &6.512300e-04,5.117000e-04,3.140800e-04,1.454700e-04,6.560800e-05, & - &1.289700e-03,8.300800e-04,9.963900e-04,9.884500e-04,9.391100e-04, & - &8.599000e-04,7.446400e-04,5.880200e-04,3.668500e-04,1.739800e-04, & - &8.080700e-05,1.509600e-03,9.529000e-04,1.133800e-03,1.123200e-03, & - &1.065300e-03,9.746200e-04,8.443400e-04,6.710700e-04,4.246200e-04, & - &2.051100e-04,9.733600e-05,1.746700e-03,1.072700e-03,1.273900e-03, & - &1.262400e-03,1.197100e-03,1.095800e-03,9.521400e-04,7.599900e-04, & - &4.876000e-04,2.390200e-04,1.156400e-04,2.002900e-03,1.191200e-03, & - &1.418600e-03,1.406700e-03,1.336500e-03,1.224300e-03,1.067400e-03, & - &8.554500e-04,5.558000e-04,2.762700e-04,1.362900e-04,2.277300e-03/ - data absa(1:330,3) / & - &1.597600e-02,1.856800e-02,1.867700e-02,1.830800e-02,1.743000e-02, & - &1.598000e-02,1.379400e-02,1.003200e-02,5.659300e-03,3.131500e-03, & - &1.472500e-03,1.700900e-02,1.998300e-02,2.015800e-02,1.976500e-02, & - &1.884600e-02,1.730800e-02,1.496500e-02,1.092000e-02,6.244700e-03, & - &3.529100e-03,1.747600e-03,1.807500e-02,2.145600e-02,2.166200e-02, & - &2.125900e-02,2.029800e-02,1.867700e-02,1.616800e-02,1.184500e-02, & - &6.897000e-03,3.973400e-03,2.064700e-03,1.917300e-02,2.298000e-02, & - &2.319400e-02,2.278600e-02,2.182200e-02,2.011500e-02,1.740100e-02, & - &1.282700e-02,7.612800e-03,4.458000e-03,2.433500e-03,2.033800e-02, & - &2.453300e-02,2.477800e-02,2.439700e-02,2.340100e-02,2.159000e-02, & - &1.867700e-02,1.385800e-02,8.379200e-03,4.985800e-03,2.864900e-03, & - &1.380300e-02,1.603000e-02,1.603700e-02,1.559400e-02,1.475600e-02, & - &1.345900e-02,1.161700e-02,8.512200e-03,4.802200e-03,2.656900e-03, & - &1.318200e-03,1.474700e-02,1.731200e-02,1.734600e-02,1.686300e-02, & - &1.596800e-02,1.459200e-02,1.261300e-02,9.270600e-03,5.310200e-03, & - &3.002300e-03,1.546000e-03,1.572000e-02,1.863800e-02,1.867600e-02, & - &1.816600e-02,1.722800e-02,1.577500e-02,1.364600e-02,1.006000e-02, & - &5.875000e-03,3.388200e-03,1.804500e-03,1.675000e-02,1.999300e-02, & - &2.002800e-02,1.949900e-02,1.854200e-02,1.702000e-02,1.471200e-02, & - &1.089600e-02,6.490800e-03,3.812500e-03,2.099000e-03,1.783300e-02, & - &2.136000e-02,2.142400e-02,2.091100e-02,1.990600e-02,1.830700e-02, & - &1.581600e-02,1.176900e-02,7.157300e-03,4.277300e-03,2.443300e-03, & - &1.166100e-02,1.354600e-02,1.352400e-02,1.309300e-02,1.230700e-02, & - &1.115900e-02,9.578000e-03,7.048400e-03,3.967500e-03,2.184600e-03, & - &1.240600e-03,1.250300e-02,1.470700e-02,1.469100e-02,1.420600e-02, & - &1.336000e-02,1.211000e-02,1.040900e-02,7.678800e-03,4.393300e-03, & - &2.471900e-03,1.429800e-03,1.339100e-02,1.588700e-02,1.587400e-02, & - &1.533400e-02,1.444000e-02,1.311100e-02,1.128000e-02,8.338800e-03, & - &4.868800e-03,2.795800e-03,1.652300e-03,1.433600e-02,1.708500e-02, & - &1.706900e-02,1.649500e-02,1.555300e-02,1.416600e-02,1.219500e-02, & - &9.045700e-03,5.386700e-03,3.153300e-03,1.909000e-03,1.532000e-02, & - &1.832100e-02,1.829200e-02,1.770600e-02,1.670400e-02,1.526500e-02, & - &1.314800e-02,9.783600e-03,5.948300e-03,3.549200e-03,2.205900e-03, & - &9.744900e-03,1.129400e-02,1.125800e-02,1.088400e-02,1.019900e-02, & - &9.222700e-03,7.865800e-03,5.776700e-03,3.240600e-03,1.770800e-03, & - &1.272800e-03,1.048700e-02,1.233000e-02,1.228600e-02,1.186200e-02, & - &1.112200e-02,1.004600e-02,8.562900e-03,6.295200e-03,3.592900e-03, & - &2.009300e-03,1.432600e-03,1.128200e-02,1.336900e-02,1.333200e-02, & - &1.285700e-02,1.206400e-02,1.090100e-02,9.293000e-03,6.846300e-03, & - &3.987200e-03,2.277000e-03,1.622700e-03,1.213000e-02,1.443500e-02, & - &1.439600e-02,1.388300e-02,1.302600e-02,1.178600e-02,1.006700e-02, & - &7.437100e-03,4.415300e-03,2.572500e-03,1.843700e-03,1.302200e-02, & - &1.554400e-02,1.550100e-02,1.494100e-02,1.400700e-02,1.270800e-02, & - &1.087600e-02,8.066600e-03,4.876700e-03,2.903500e-03,2.100000e-03, & - &8.118300e-03,9.370600e-03,9.333900e-03,9.003600e-03,8.420900e-03, & - &7.583200e-03,6.444500e-03,4.733100e-03,2.637100e-03,1.426900e-03, & - &1.351200e-03,8.761900e-03,1.027100e-02,1.022600e-02,9.853300e-03, & - &9.217700e-03,8.303400e-03,7.046600e-03,5.162500e-03,2.926100e-03, & - &1.622200e-03,1.497500e-03,9.459000e-03,1.119100e-02,1.113200e-02, & - &1.071700e-02,1.003500e-02,9.043800e-03,7.682500e-03,5.618600e-03, & - &3.248700e-03,1.841900e-03,1.662800e-03,1.021400e-02,1.212900e-02, & - &1.206500e-02,1.161300e-02,1.087400e-02,9.810400e-03,8.337600e-03, & - &6.112700e-03,3.604000e-03,2.084400e-03,1.852600e-03,1.101200e-02, & - &1.311200e-02,1.304500e-02,1.254300e-02,1.173300e-02,1.060500e-02, & - &9.022200e-03,6.640800e-03,3.979600e-03,2.357200e-03,2.077000e-03, & - &6.738700e-03,7.719400e-03,7.690200e-03,7.398600e-03,6.901600e-03, & - &6.180000e-03,5.230400e-03,3.860500e-03,2.139300e-03,1.138400e-03, & - &1.380900e-03,7.290400e-03,8.490100e-03,8.455900e-03,8.134100e-03, & - &7.589700e-03,6.804300e-03,5.749700e-03,4.221900e-03,2.370300e-03, & - &1.295100e-03,1.533600e-03,7.888300e-03,9.295500e-03,9.234500e-03, & - &8.879700e-03,8.293600e-03,7.442100e-03,6.295200e-03,4.602800e-03, & - &2.628500e-03,1.471600e-03,1.693100e-03,8.549400e-03,1.012100e-02, & - &1.004600e-02,9.652200e-03,9.017600e-03,8.104200e-03,6.861300e-03, & - &5.017900e-03,2.916500e-03,1.669300e-03,1.869000e-03,9.245500e-03, & - &1.098900e-02,1.090200e-02,1.046500e-02,9.768900e-03,8.791300e-03, & - &7.449400e-03,5.457200e-03,3.227600e-03,1.890900e-03,2.064300e-03/ - data absa(331:715,3) / & - &5.570800e-03,6.330300e-03,6.293400e-03,6.027600e-03,5.612700e-03, & - &5.005800e-03,4.217200e-03,3.114200e-03,1.728800e-03,9.021400e-04, & - &1.358000e-03,6.039600e-03,6.977100e-03,6.941200e-03,6.655900e-03, & - &6.199300e-03,5.530100e-03,4.652400e-03,3.420700e-03,1.911900e-03, & - &1.025700e-03,1.532900e-03,6.545000e-03,7.664600e-03,7.605900e-03, & - &7.301400e-03,6.803100e-03,6.074100e-03,5.113000e-03,3.741200e-03, & - &2.117200e-03,1.166600e-03,1.725500e-03,7.110500e-03,8.376400e-03, & - &8.303800e-03,7.970500e-03,7.428200e-03,6.639300e-03,5.592800e-03, & - &4.088600e-03,2.347000e-03,1.325800e-03,1.924100e-03,7.708900e-03, & - &9.127000e-03,9.046700e-03,8.673400e-03,8.076000e-03,7.228600e-03, & - &6.094100e-03,4.457400e-03,2.604200e-03,1.504900e-03,2.128900e-03, & - &4.593100e-03,5.183800e-03,5.139800e-03,4.898600e-03,4.543900e-03, & - &4.045000e-03,3.397000e-03,2.502100e-03,1.391500e-03,7.146100e-04, & - &1.434200e-03,4.992300e-03,5.720500e-03,5.683500e-03,5.425500e-03, & - &5.042000e-03,4.481500e-03,3.756900e-03,2.759500e-03,1.537800e-03, & - &8.122300e-04,1.626500e-03,5.418700e-03,6.305900e-03,6.251200e-03, & - &5.977900e-03,5.555200e-03,4.939700e-03,4.140700e-03,3.028300e-03, & - &1.702000e-03,9.237400e-04,1.839500e-03,5.895100e-03,6.915900e-03, & - &6.845600e-03,6.555500e-03,6.092700e-03,5.420300e-03,4.543400e-03, & - &3.314000e-03,1.887400e-03,1.050000e-03,2.072300e-03,6.406700e-03, & - &7.558300e-03,7.482200e-03,7.162400e-03,6.652900e-03,5.921800e-03, & - &4.968000e-03,3.620300e-03,2.098000e-03,1.193300e-03,2.324700e-03, & - &3.772300e-03,4.233400e-03,4.181900e-03,3.964900e-03,3.658800e-03, & - &3.257500e-03,2.730500e-03,2.007200e-03,1.119300e-03,5.674100e-04, & - &1.986000e-03,4.111200e-03,4.676400e-03,4.635700e-03,4.406800e-03, & - &4.079300e-03,3.619800e-03,3.029000e-03,2.219100e-03,1.235800e-03, & - &6.434000e-04,2.258700e-03,4.468100e-03,5.165700e-03,5.116900e-03, & - &4.874200e-03,4.514800e-03,4.003800e-03,3.346600e-03,2.444100e-03, & - &1.367500e-03,7.307000e-04,2.566800e-03,4.866800e-03,5.686600e-03, & - &5.626400e-03,5.367700e-03,4.974800e-03,4.411300e-03,3.684800e-03, & - &2.678000e-03,1.516500e-03,8.309400e-04,2.904400e-03,5.302400e-03, & - &6.233800e-03,6.168300e-03,5.890600e-03,5.456000e-03,4.841600e-03, & - &4.041800e-03,2.931600e-03,1.686800e-03,9.449400e-04,3.275800e-03, & - &3.104800e-03,3.471300e-03,3.414900e-03,3.221500e-03,2.960600e-03, & - &2.632300e-03,2.204000e-03,1.618300e-03,9.051100e-04,4.544200e-04, & - &3.406600e-03,3.392000e-03,3.838700e-03,3.792400e-03,3.589800e-03, & - &3.308400e-03,2.935800e-03,2.450700e-03,1.791500e-03,9.991900e-04, & - &5.134200e-04,3.888900e-03,3.695700e-03,4.245900e-03,4.199400e-03, & - &3.983100e-03,3.676900e-03,3.257100e-03,2.715700e-03,1.977800e-03, & - &1.104800e-03,5.825600e-04,4.435500e-03,4.031800e-03,4.686700e-03, & - &4.634000e-03,4.400000e-03,4.067600e-03,3.600500e-03,2.997100e-03, & - &2.173000e-03,1.225900e-03,6.629700e-04,5.056400e-03,4.403300e-03, & - &5.153800e-03,5.096100e-03,4.847000e-03,4.479600e-03,3.966000e-03, & - &3.297700e-03,2.383900e-03,1.363100e-03,7.547600e-04,5.751600e-03, & - &2.676500e-03,2.982700e-03,2.922700e-03,2.750800e-03,2.522000e-03, & - &2.236300e-03,1.867600e-03,1.367500e-03,7.661200e-04,3.844700e-04, & - &4.048000e-03,2.928600e-03,3.304000e-03,3.253800e-03,3.070300e-03, & - &2.819200e-03,2.496200e-03,2.077200e-03,1.514600e-03,8.462500e-04, & - &4.340900e-04,4.666600e-03,3.200300e-03,3.664800e-03,3.612500e-03, & - &3.411300e-03,3.136200e-03,2.772400e-03,2.302900e-03,1.672200e-03, & - &9.367900e-04,4.922900e-04,5.365400e-03,3.505100e-03,4.053100e-03, & - &3.994700e-03,3.775000e-03,3.476100e-03,3.069300e-03,2.545200e-03, & - &1.840600e-03,1.040400e-03,5.607900e-04,6.151200e-03,3.832100e-03, & - &4.464900e-03,4.402200e-03,4.165400e-03,3.837700e-03,3.387400e-03, & - &2.805300e-03,2.022600e-03,1.157400e-03,6.397400e-04,7.016000e-03, & - &2.303600e-03,2.558300e-03,2.497800e-03,2.344500e-03,2.143000e-03, & - &1.894400e-03,1.576100e-03,1.151700e-03,6.455600e-04,3.234900e-04, & - &4.039200e-03,2.524400e-03,2.845200e-03,2.789900e-03,2.623700e-03, & - &2.399600e-03,2.117100e-03,1.753700e-03,1.275100e-03,7.138400e-04, & - &3.651300e-04,4.669000e-03,2.766400e-03,3.166100e-03,3.108000e-03, & - &2.923000e-03,2.675100e-03,2.355200e-03,1.946200e-03,1.407500e-03, & - &7.907500e-04,4.143500e-04,5.379800e-03,3.037100e-03,3.509000e-03, & - &3.446000e-03,3.243700e-03,2.970600e-03,2.611400e-03,2.154300e-03, & - &1.550700e-03,8.792600e-04,4.725000e-04,6.171100e-03,3.323900e-03, & - &3.870900e-03,3.806300e-03,3.584200e-03,3.285500e-03,2.887200e-03, & - &2.377400e-03,1.707300e-03,9.795100e-04,5.397400e-04,7.032900e-03, & - &1.969300e-03,2.181900e-03,2.126000e-03,1.991700e-03,1.814200e-03, & - &1.597700e-03,1.323000e-03,9.616300e-04,5.372200e-04,2.691400e-04, & - &3.445700e-03,2.160500e-03,2.436300e-03,2.382500e-03,2.234100e-03, & - &2.035800e-03,1.789000e-03,1.474300e-03,1.063700e-03,5.946100e-04, & - &3.042000e-04,3.985900e-03,2.372900e-03,2.717500e-03,2.660700e-03, & - &2.495000e-03,2.274400e-03,1.995600e-03,1.638300e-03,1.173900e-03, & - &6.595800e-04,3.456400e-04,4.595400e-03,2.604200e-03,3.014700e-03, & - &2.955800e-03,2.774100e-03,2.531000e-03,2.216900e-03,1.816500e-03, & - &1.295400e-03,7.351600e-04,3.946200e-04,5.271900e-03,2.848400e-03, & - &3.327300e-03,3.268700e-03,3.067800e-03,2.802400e-03,2.454300e-03, & - &2.006400e-03,1.429100e-03,8.209500e-04,4.510500e-04,5.998000e-03/ - data absa(1:330,4) / & - &3.220600e-02,3.761600e-02,3.744200e-02,3.560200e-02,3.284800e-02, & - &2.921200e-02,2.441100e-02,1.809300e-02,1.108700e-02,6.439600e-03, & - &4.157900e-03,3.398500e-02,4.014100e-02,4.006600e-02,3.822000e-02, & - &3.531000e-02,3.136300e-02,2.627400e-02,1.956300e-02,1.213700e-02, & - &7.234400e-03,4.942100e-03,3.584000e-02,4.265700e-02,4.265700e-02, & - &4.082800e-02,3.771500e-02,3.359200e-02,2.823800e-02,2.114600e-02, & - &1.326300e-02,8.124300e-03,5.837000e-03,3.771000e-02,4.508600e-02, & - &4.528400e-02,4.335800e-02,4.012300e-02,3.580500e-02,3.030800e-02, & - &2.281000e-02,1.450200e-02,9.132900e-03,6.890600e-03,3.954600e-02, & - &4.746500e-02,4.788400e-02,4.587300e-02,4.255800e-02,3.807800e-02, & - &3.245300e-02,2.458000e-02,1.583900e-02,1.028000e-02,8.093500e-03, & - &2.810400e-02,3.246400e-02,3.235800e-02,3.070300e-02,2.826200e-02, & - &2.504900e-02,2.088700e-02,1.537100e-02,9.532100e-03,5.576600e-03, & - &3.412800e-03,2.970900e-02,3.473300e-02,3.470600e-02,3.302900e-02, & - &3.040700e-02,2.697500e-02,2.252500e-02,1.666800e-02,1.044400e-02, & - &6.249300e-03,4.021000e-03,3.136800e-02,3.699700e-02,3.703800e-02, & - &3.530900e-02,3.254100e-02,2.894800e-02,2.424800e-02,1.807800e-02, & - &1.142900e-02,7.002500e-03,4.723400e-03,3.302500e-02,3.919400e-02, & - &3.940600e-02,3.756600e-02,3.472400e-02,3.090700e-02,2.604700e-02, & - &1.955200e-02,1.251100e-02,7.846000e-03,5.553100e-03,3.465800e-02, & - &4.141700e-02,4.175000e-02,3.987000e-02,3.692500e-02,3.292000e-02, & - &2.792200e-02,2.112200e-02,1.368700e-02,8.792500e-03,6.501700e-03, & - &2.425100e-02,2.758500e-02,2.741400e-02,2.589600e-02,2.376900e-02, & - &2.101500e-02,1.749000e-02,1.279900e-02,7.985900e-03,4.682200e-03, & - &3.016700e-03,2.569200e-02,2.954800e-02,2.949200e-02,2.793500e-02, & - &2.563000e-02,2.268000e-02,1.891800e-02,1.390400e-02,8.758400e-03, & - &5.252900e-03,3.480400e-03,2.715900e-02,3.155900e-02,3.155100e-02, & - &2.993200e-02,2.750300e-02,2.439500e-02,2.039900e-02,1.511900e-02, & - &9.588800e-03,5.890500e-03,4.010300e-03,2.860700e-02,3.356000e-02, & - &3.360300e-02,3.194800e-02,2.944700e-02,2.612600e-02,2.192800e-02, & - &1.639900e-02,1.049900e-02,6.600800e-03,4.620000e-03,3.005100e-02, & - &3.556200e-02,3.568300e-02,3.403900e-02,3.143000e-02,2.790800e-02, & - &2.351800e-02,1.775000e-02,1.149300e-02,7.386300e-03,5.313000e-03, & - &2.082100e-02,2.339900e-02,2.311100e-02,2.175100e-02,1.986400e-02, & - &1.748500e-02,1.453000e-02,1.058700e-02,6.617400e-03,3.856000e-03, & - &2.754000e-03,2.214500e-02,2.510800e-02,2.493700e-02,2.351900e-02, & - &2.145800e-02,1.889800e-02,1.572700e-02,1.152800e-02,7.264700e-03, & - &4.330600e-03,3.142700e-03,2.345800e-02,2.689200e-02,2.676700e-02, & - &2.524400e-02,2.306300e-02,2.037400e-02,1.698900e-02,1.255600e-02, & - &7.966300e-03,4.867800e-03,3.592200e-03,2.474200e-02,2.868400e-02, & - &2.856700e-02,2.700200e-02,2.474400e-02,2.189100e-02,1.830200e-02, & - &1.363700e-02,8.732300e-03,5.475600e-03,4.108700e-03,2.603100e-02, & - &3.047800e-02,3.037300e-02,2.883100e-02,2.650200e-02,2.347200e-02, & - &1.965600e-02,1.477500e-02,9.572100e-03,6.146900e-03,4.682000e-03, & - &1.774900e-02,1.980900e-02,1.947400e-02,1.830800e-02,1.665600e-02, & - &1.461200e-02,1.209000e-02,8.752300e-03,5.450600e-03,3.159400e-03, & - &2.600900e-03,1.896200e-02,2.136800e-02,2.111100e-02,1.985600e-02, & - &1.802600e-02,1.579700e-02,1.308700e-02,9.548000e-03,5.992000e-03, & - &3.546500e-03,2.938300e-03,2.015600e-02,2.295500e-02,2.276600e-02, & - &2.137000e-02,1.940200e-02,1.703600e-02,1.413200e-02,1.040900e-02, & - &6.584900e-03,3.990900e-03,3.326700e-03,2.132300e-02,2.455400e-02, & - &2.438000e-02,2.290900e-02,2.085000e-02,1.832500e-02,1.525200e-02, & - &1.131700e-02,7.233200e-03,4.496600e-03,3.766700e-03,2.249900e-02, & - &2.615800e-02,2.597500e-02,2.449700e-02,2.236000e-02,1.968600e-02, & - &1.642100e-02,1.227800e-02,7.938700e-03,5.061000e-03,4.258800e-03, & - &1.500700e-02,1.659800e-02,1.625200e-02,1.529600e-02,1.391800e-02, & - &1.219700e-02,1.007000e-02,7.197300e-03,4.441800e-03,2.563200e-03, & - &2.627000e-03,1.609600e-02,1.800800e-02,1.771500e-02,1.666800e-02, & - &1.511700e-02,1.321700e-02,1.090200e-02,7.857400e-03,4.894000e-03, & - &2.882900e-03,2.909700e-03,1.717500e-02,1.943400e-02,1.920900e-02, & - &1.802000e-02,1.631900e-02,1.427200e-02,1.177200e-02,8.571200e-03, & - &5.392700e-03,3.248200e-03,3.246200e-03,1.823900e-02,2.084700e-02, & - &2.066600e-02,1.938200e-02,1.757500e-02,1.537100e-02,1.271000e-02, & - &9.331400e-03,5.932800e-03,3.661400e-03,3.632400e-03,1.931400e-02, & - &2.227400e-02,2.209900e-02,2.077300e-02,1.887100e-02,1.652300e-02, & - &1.370700e-02,1.014700e-02,6.523000e-03,4.121200e-03,4.066400e-03/ - data absa(331:715,4) / & - &1.256200e-02,1.374900e-02,1.341200e-02,1.265200e-02,1.150100e-02, & - &1.007800e-02,8.300800e-03,5.895100e-03,3.583900e-03,2.064000e-03, & - &2.899000e-03,1.351300e-02,1.499200e-02,1.470600e-02,1.384200e-02, & - &1.254900e-02,1.095600e-02,9.026500e-03,6.434800e-03,3.961800e-03, & - &2.323300e-03,3.154400e-03,1.446300e-02,1.624800e-02,1.600300e-02, & - &1.502100e-02,1.358800e-02,1.186500e-02,9.770400e-03,7.023200e-03, & - &4.375800e-03,2.620800e-03,3.430800e-03,1.541200e-02,1.749700e-02, & - &1.727600e-02,1.619400e-02,1.466300e-02,1.281500e-02,1.057400e-02, & - &7.649100e-03,4.828400e-03,2.953500e-03,3.752600e-03,1.638100e-02, & - &1.874800e-02,1.854600e-02,1.740200e-02,1.577400e-02,1.380000e-02, & - &1.141500e-02,8.330500e-03,5.318300e-03,3.322700e-03,4.119000e-03, & - &1.048900e-02,1.135000e-02,1.104100e-02,1.042100e-02,9.468200e-03, & - &8.268500e-03,6.787000e-03,4.801900e-03,2.890400e-03,1.655200e-03, & - &3.203400e-03,1.130800e-02,1.242700e-02,1.215900e-02,1.145900e-02, & - &1.037300e-02,9.037400e-03,7.407600e-03,5.245000e-03,3.194700e-03, & - &1.862600e-03,3.594900e-03,1.213300e-02,1.351600e-02,1.327300e-02, & - &1.247500e-02,1.126800e-02,9.813000e-03,8.052800e-03,5.731100e-03, & - &3.537000e-03,2.101100e-03,3.988900e-03,1.296500e-02,1.461100e-02, & - &1.436800e-02,1.347300e-02,1.217400e-02,1.062500e-02,8.737200e-03, & - &6.257700e-03,3.907500e-03,2.370900e-03,4.370300e-03,1.381600e-02, & - &1.569900e-02,1.547000e-02,1.450200e-02,1.312300e-02,1.146700e-02, & - &9.453700e-03,6.829800e-03,4.309300e-03,2.666300e-03,4.751200e-03, & - &8.756800e-03,9.369300e-03,9.097500e-03,8.580000e-03,7.789600e-03, & - &6.764500e-03,5.528500e-03,3.903300e-03,2.331000e-03,1.321700e-03, & - &4.573100e-03,9.455300e-03,1.029300e-02,1.005400e-02,9.484500e-03, & - &8.571500e-03,7.431000e-03,6.052600e-03,4.265100e-03,2.574700e-03, & - &1.487800e-03,5.259700e-03,1.017300e-02,1.123800e-02,1.101200e-02, & - &1.036400e-02,9.341000e-03,8.096400e-03,6.604900e-03,4.662000e-03, & - &2.850600e-03,1.677000e-03,5.981400e-03,1.090100e-02,1.218800e-02, & - &1.195200e-02,1.122200e-02,1.010800e-02,8.784600e-03,7.186400e-03, & - &5.105100e-03,3.152800e-03,1.891300e-03,6.737200e-03,1.164300e-02, & - &1.313600e-02,1.289600e-02,1.209100e-02,1.091800e-02,9.504500e-03, & - &7.792300e-03,5.582400e-03,3.479400e-03,2.130300e-03,7.508400e-03, & - &7.321000e-03,7.768200e-03,7.534800e-03,7.091000e-03,6.427600e-03, & - &5.555500e-03,4.519000e-03,3.187400e-03,1.886900e-03,1.061500e-03, & - &8.508900e-03,7.916000e-03,8.557800e-03,8.351300e-03,7.870200e-03, & - &7.105600e-03,6.130700e-03,4.964200e-03,3.482800e-03,2.080000e-03, & - &1.194800e-03,9.884400e-03,8.528600e-03,9.375700e-03,9.172600e-03, & - &8.630100e-03,7.770700e-03,6.700300e-03,5.429200e-03,3.808600e-03, & - &2.303900e-03,1.348200e-03,1.135900e-02,9.163100e-03,1.019100e-02, & - &9.976900e-03,9.378800e-03,8.424300e-03,7.279300e-03,5.922200e-03, & - &4.175600e-03,2.550900e-03,1.519000e-03,1.293100e-02,9.811300e-03, & - &1.101500e-02,1.078800e-02,1.012400e-02,9.115300e-03,7.892600e-03, & - &6.436300e-03,4.574900e-03,2.821900e-03,1.712100e-03,1.460100e-02, & - &6.323800e-03,6.732000e-03,6.534100e-03,6.143200e-03,5.550000e-03, & - &4.777000e-03,3.862500e-03,2.709800e-03,1.593000e-03,8.997100e-04, & - &1.069100e-02,6.837700e-03,7.413200e-03,7.235100e-03,6.804400e-03, & - &6.132800e-03,5.269800e-03,4.248200e-03,2.962600e-03,1.757900e-03, & - &1.014700e-03,1.244600e-02,7.368000e-03,8.111700e-03,7.928100e-03, & - &7.455600e-03,6.702200e-03,5.755200e-03,4.650700e-03,3.245900e-03, & - &1.947600e-03,1.145300e-03,1.432300e-02,7.925000e-03,8.810000e-03, & - &8.619900e-03,8.104200e-03,7.271600e-03,6.261500e-03,5.076300e-03, & - &3.559700e-03,2.159100e-03,1.289100e-03,1.631800e-02,8.499500e-03, & - &9.531000e-03,9.330300e-03,8.768400e-03,7.875500e-03,6.795000e-03, & - &5.525500e-03,3.902300e-03,2.391800e-03,1.451700e-03,1.843000e-02, & - &5.423900e-03,5.794200e-03,5.625400e-03,5.277500e-03,4.753800e-03, & - &4.078300e-03,3.281500e-03,2.291100e-03,1.339000e-03,7.590100e-04, & - &1.106900e-02,5.865000e-03,6.375600e-03,6.214600e-03,5.830100e-03, & - &5.246500e-03,4.494900e-03,3.612300e-03,2.510100e-03,1.478800e-03, & - &8.577300e-04,1.292200e-02,6.332600e-03,6.960500e-03,6.792600e-03, & - &6.382200e-03,5.729500e-03,4.911600e-03,3.959000e-03,2.752700e-03, & - &1.640200e-03,9.678500e-04,1.489000e-02,6.819700e-03,7.561200e-03, & - &7.390100e-03,6.940700e-03,6.224800e-03,5.351300e-03,4.325500e-03, & - &3.021500e-03,1.820200e-03,1.089300e-03,1.696800e-02,7.323900e-03, & - &8.186900e-03,8.010200e-03,7.530500e-03,6.753400e-03,5.818400e-03, & - &4.720000e-03,3.317200e-03,2.017300e-03,1.226500e-03,1.917400e-02, & - &4.605000e-03,4.934200e-03,4.781700e-03,4.466200e-03,4.014700e-03, & - &3.435000e-03,2.750000e-03,1.913500e-03,1.115000e-03,6.343500e-04, & - &9.648200e-03,4.986700e-03,5.419900e-03,5.264300e-03,4.924000e-03, & - &4.421900e-03,3.778200e-03,3.026900e-03,2.100600e-03,1.233500e-03, & - &7.174500e-04,1.127100e-02,5.397100e-03,5.911400e-03,5.751000e-03, & - &5.385500e-03,4.828700e-03,4.131000e-03,3.320500e-03,2.307500e-03, & - &1.369500e-03,8.094600e-04,1.298500e-02,5.820300e-03,6.426200e-03, & - &6.260900e-03,5.866100e-03,5.255200e-03,4.506800e-03,3.633800e-03, & - &2.538000e-03,1.520900e-03,9.116000e-04,1.478500e-02,6.260800e-03, & - &6.964200e-03,6.799100e-03,6.379100e-03,5.713900e-03,4.910100e-03, & - &3.975200e-03,2.791800e-03,1.687000e-03,1.027700e-03,1.669200e-02/ - data absa(1:330,5) / & - &6.942300e-02,7.496000e-02,7.288100e-02,6.785200e-02,6.080400e-02, & - &5.253100e-02,4.282400e-02,3.061000e-02,1.904500e-02,1.197200e-02, & - &9.065600e-03,7.130100e-02,7.792500e-02,7.606400e-02,7.119800e-02, & - &6.417000e-02,5.600800e-02,4.600200e-02,3.321900e-02,2.089800e-02, & - &1.354100e-02,1.084400e-02,7.296000e-02,8.074400e-02,7.939700e-02, & - &7.468600e-02,6.791500e-02,5.961500e-02,4.920500e-02,3.592800e-02, & - &2.290600e-02,1.528400e-02,1.285300e-02,7.448200e-02,8.356800e-02, & - &8.275100e-02,7.837000e-02,7.184000e-02,6.324100e-02,5.261100e-02, & - &3.880000e-02,2.507100e-02,1.719000e-02,1.507800e-02,7.597700e-02, & - &8.641600e-02,8.613200e-02,8.222900e-02,7.572100e-02,6.701500e-02, & - &5.618800e-02,4.179100e-02,2.737900e-02,1.931900e-02,1.754400e-02, & - &6.142800e-02,6.624300e-02,6.401600e-02,5.968600e-02,5.340800e-02, & - &4.590500e-02,3.732500e-02,2.663800e-02,1.653900e-02,1.026100e-02, & - &7.294300e-03,6.315700e-02,6.896300e-02,6.703500e-02,6.287700e-02, & - &5.662800e-02,4.910700e-02,4.014700e-02,2.897000e-02,1.819800e-02, & - &1.156200e-02,8.674700e-03,6.472900e-02,7.165300e-02,7.018300e-02, & - &6.623700e-02,6.008700e-02,5.234700e-02,4.308300e-02,3.142900e-02, & - &1.997800e-02,1.299800e-02,1.026000e-02,6.625200e-02,7.435500e-02, & - &7.332100e-02,6.974100e-02,6.355300e-02,5.569700e-02,4.622800e-02, & - &3.402400e-02,2.187100e-02,1.455600e-02,1.203400e-02,6.778200e-02, & - &7.700900e-02,7.650300e-02,7.317300e-02,6.701600e-02,5.918000e-02, & - &4.950500e-02,3.670700e-02,2.388700e-02,1.629000e-02,1.400400e-02, & - &5.353300e-02,5.743400e-02,5.527700e-02,5.152700e-02,4.603500e-02, & - &3.935200e-02,3.174600e-02,2.252300e-02,1.390800e-02,8.649000e-03, & - &5.928700e-03,5.513700e-02,5.996900e-02,5.809700e-02,5.450200e-02, & - &4.898000e-02,4.217300e-02,3.424400e-02,2.456600e-02,1.535000e-02, & - &9.696200e-03,6.949300e-03,5.667500e-02,6.243100e-02,6.097500e-02, & - &5.758900e-02,5.205600e-02,4.504700e-02,3.685500e-02,2.672900e-02, & - &1.690900e-02,1.085500e-02,8.120600e-03,5.820000e-02,6.492300e-02, & - &6.388200e-02,6.075300e-02,5.507700e-02,4.803700e-02,3.964300e-02, & - &2.901800e-02,1.857500e-02,1.212100e-02,9.475000e-03,5.973300e-02, & - &6.741600e-02,6.684200e-02,6.377600e-02,5.815900e-02,5.116400e-02, & - &4.258500e-02,3.138000e-02,2.034800e-02,1.351400e-02,1.099800e-02, & - &4.635300e-02,4.926400e-02,4.731600e-02,4.401600e-02,3.930300e-02, & - &3.344600e-02,2.672000e-02,1.881700e-02,1.154100e-02,7.272200e-03, & - &5.471200e-03,4.783200e-02,5.157500e-02,4.990500e-02,4.672100e-02, & - &4.194000e-02,3.592400e-02,2.890900e-02,2.056300e-02,1.275600e-02, & - &8.136000e-03,6.289400e-03,4.929200e-02,5.384500e-02,5.247700e-02, & - &4.951100e-02,4.468200e-02,3.843800e-02,3.120600e-02,2.243000e-02, & - &1.408300e-02,9.082200e-03,7.207900e-03,5.075300e-02,5.616700e-02, & - &5.509600e-02,5.229100e-02,4.735400e-02,4.105100e-02,3.362700e-02, & - &2.441800e-02,1.550800e-02,1.011100e-02,8.225800e-03,5.223700e-02, & - &5.845300e-02,5.780700e-02,5.496900e-02,5.004300e-02,4.375000e-02, & - &3.622100e-02,2.649200e-02,1.704400e-02,1.124300e-02,9.358500e-03, & - &4.021500e-02,4.217800e-02,4.034500e-02,3.736600e-02,3.335400e-02, & - &2.828300e-02,2.244600e-02,1.569200e-02,9.537800e-03,6.057400e-03, & - &5.092700e-03,4.156400e-02,4.422300e-02,4.265600e-02,3.974400e-02, & - &3.571200e-02,3.048600e-02,2.432500e-02,1.717300e-02,1.056300e-02, & - &6.799200e-03,5.784800e-03,4.288000e-02,4.629500e-02,4.492900e-02, & - &4.219800e-02,3.810400e-02,3.271100e-02,2.632500e-02,1.875800e-02, & - &1.167400e-02,7.607300e-03,6.572200e-03,4.425000e-02,4.837400e-02, & - &4.725300e-02,4.466900e-02,4.047700e-02,3.496100e-02,2.843200e-02, & - &2.044900e-02,1.288000e-02,8.476200e-03,7.457000e-03,4.563200e-02, & - &5.045700e-02,4.966100e-02,4.707300e-02,4.285700e-02,3.728100e-02, & - &3.064500e-02,2.224100e-02,1.417900e-02,9.422400e-03,8.428900e-03, & - &3.485300e-02,3.609400e-02,3.434000e-02,3.156700e-02,2.807400e-02, & - &2.374700e-02,1.874700e-02,1.303300e-02,7.834400e-03,4.956400e-03, & - &4.766400e-03,3.609500e-02,3.790200e-02,3.636000e-02,3.362700e-02, & - &3.013100e-02,2.563800e-02,2.037100e-02,1.427500e-02,8.697200e-03, & - &5.573500e-03,5.389600e-03,3.729700e-02,3.974500e-02,3.835300e-02, & - &3.576400e-02,3.221900e-02,2.755000e-02,2.208500e-02,1.561500e-02, & - &9.628400e-03,6.255600e-03,6.079000e-03,3.855700e-02,4.159700e-02, & - &4.038900e-02,3.790800e-02,3.428100e-02,2.950700e-02,2.387000e-02, & - &1.704600e-02,1.064300e-02,7.003400e-03,6.848400e-03,3.982400e-02, & - &4.346400e-02,4.247800e-02,4.004700e-02,3.638200e-02,3.152200e-02, & - &2.573600e-02,1.857300e-02,1.173900e-02,7.825000e-03,7.702900e-03/ - data absa(331:715,5) / & - &2.981500e-02,3.060800e-02,2.898800e-02,2.648300e-02,2.344400e-02, & - &1.980600e-02,1.558700e-02,1.072900e-02,6.383400e-03,3.998800e-03, & - &4.771000e-03,3.094600e-02,3.221100e-02,3.072700e-02,2.826200e-02, & - &2.521500e-02,2.140600e-02,1.694000e-02,1.178900e-02,7.092500e-03, & - &4.505900e-03,5.336500e-03,3.206000e-02,3.382300e-02,3.246400e-02, & - &3.009900e-02,2.700400e-02,2.302600e-02,1.836900e-02,1.292100e-02, & - &7.875800e-03,5.068500e-03,5.985700e-03,3.319800e-02,3.548300e-02, & - &3.428300e-02,3.196400e-02,2.878100e-02,2.468900e-02,1.985600e-02, & - &1.413700e-02,8.726000e-03,5.693200e-03,6.696200e-03,3.434200e-02, & - &3.714400e-02,3.611700e-02,3.382500e-02,3.062000e-02,2.641100e-02, & - &2.141600e-02,1.542100e-02,9.644300e-03,6.390500e-03,7.488200e-03, & - &2.528300e-02,2.575100e-02,2.427000e-02,2.207900e-02,1.949600e-02, & - &1.649600e-02,1.294700e-02,8.807800e-03,5.166100e-03,3.195600e-03, & - &5.677500e-03,2.630200e-02,2.718000e-02,2.578100e-02,2.361500e-02, & - &2.101500e-02,1.784300e-02,1.409700e-02,9.706000e-03,5.749400e-03, & - &3.608300e-03,6.162200e-03,2.732000e-02,2.859300e-02,2.730500e-02, & - &2.519500e-02,2.254600e-02,1.922300e-02,1.528200e-02,1.066500e-02, & - &6.391300e-03,4.072800e-03,6.705700e-03,2.833300e-02,3.004100e-02, & - &2.891500e-02,2.682900e-02,2.408800e-02,2.063500e-02,1.652200e-02, & - &1.168500e-02,7.106600e-03,4.589600e-03,7.345500e-03,2.934900e-02, & - &3.152600e-02,3.054000e-02,2.846400e-02,2.570700e-02,2.210900e-02, & - &1.781600e-02,1.275300e-02,7.874600e-03,5.173400e-03,8.074600e-03, & - &2.139300e-02,2.159800e-02,2.024200e-02,1.837000e-02,1.618600e-02, & - &1.370600e-02,1.072200e-02,7.219500e-03,4.174600e-03,2.543900e-03, & - &1.011300e-02,2.230100e-02,2.286300e-02,2.156200e-02,1.967000e-02, & - &1.746600e-02,1.484800e-02,1.170500e-02,7.978100e-03,4.643600e-03, & - &2.871800e-03,1.134200e-02,2.322100e-02,2.408900e-02,2.288300e-02, & - &2.102200e-02,1.877400e-02,1.603000e-02,1.271700e-02,8.785400e-03, & - &5.173000e-03,3.251500e-03,1.250700e-02,2.412000e-02,2.534300e-02, & - &2.428000e-02,2.242500e-02,2.011900e-02,1.724400e-02,1.376700e-02, & - &9.636100e-03,5.761100e-03,3.676500e-03,1.355400e-02,2.501600e-02, & - &2.663800e-02,2.570200e-02,2.386500e-02,2.151600e-02,1.850800e-02, & - &1.486400e-02,1.052900e-02,6.404500e-03,4.154600e-03,1.457200e-02, & - &1.811300e-02,1.813800e-02,1.691500e-02,1.532600e-02,1.349300e-02, & - &1.140400e-02,8.889400e-03,5.916100e-03,3.397400e-03,2.040000e-03, & - &2.315500e-02,1.891100e-02,1.923300e-02,1.804900e-02,1.643300e-02, & - &1.455600e-02,1.237100e-02,9.715200e-03,6.564500e-03,3.785900e-03, & - &2.298400e-03,2.650200e-02,1.972800e-02,2.029500e-02,1.918800e-02, & - &1.757800e-02,1.566000e-02,1.337800e-02,1.058600e-02,7.249200e-03, & - &4.217600e-03,2.603600e-03,2.973200e-02,2.051100e-02,2.137300e-02, & - &2.038600e-02,1.876200e-02,1.682100e-02,1.442400e-02,1.148800e-02, & - &7.963100e-03,4.700100e-03,2.953500e-03,3.282700e-02,2.130400e-02, & - &2.249100e-02,2.160200e-02,2.000400e-02,1.801100e-02,1.551800e-02, & - &1.244000e-02,8.718600e-03,5.230600e-03,3.344500e-03,3.581900e-02, & - &1.569500e-02,1.570200e-02,1.463800e-02,1.326700e-02,1.167900e-02, & - &9.850300e-03,7.667700e-03,5.076100e-03,2.905300e-03,1.722800e-03, & - &2.999300e-02,1.640100e-02,1.663700e-02,1.559900e-02,1.421400e-02, & - &1.258300e-02,1.068600e-02,8.376600e-03,5.641600e-03,3.242800e-03, & - &1.941900e-03,3.419700e-02,1.710600e-02,1.755900e-02,1.660200e-02, & - &1.520400e-02,1.353700e-02,1.156300e-02,9.129500e-03,6.230800e-03, & - &3.614200e-03,2.201800e-03,3.823700e-02,1.778300e-02,1.850400e-02, & - &1.762800e-02,1.622900e-02,1.454200e-02,1.248300e-02,9.920700e-03, & - &6.846600e-03,4.026300e-03,2.504300e-03,4.214900e-02,1.849300e-02, & - &1.948500e-02,1.867600e-02,1.729500e-02,1.557500e-02,1.343800e-02, & - &1.075400e-02,7.505800e-03,4.480100e-03,2.841300e-03,4.592300e-02, & - &1.350600e-02,1.352900e-02,1.262800e-02,1.145200e-02,1.006300e-02, & - &8.468500e-03,6.582800e-03,4.337000e-03,2.467600e-03,1.450100e-03, & - &3.137900e-02,1.412500e-02,1.432500e-02,1.345100e-02,1.227100e-02, & - &1.084600e-02,9.194400e-03,7.193000e-03,4.821800e-03,2.758800e-03, & - &1.635100e-03,3.559800e-02,1.472100e-02,1.512700e-02,1.431800e-02, & - &1.312500e-02,1.167800e-02,9.957100e-03,7.841500e-03,5.324800e-03, & - &3.076300e-03,1.857000e-03,3.975200e-02,1.531700e-02,1.595000e-02, & - &1.520200e-02,1.400900e-02,1.254000e-02,1.075200e-02,8.524600e-03, & - &5.856500e-03,3.425100e-03,2.115800e-03,4.374400e-02,1.596900e-02, & - &1.681200e-02,1.612400e-02,1.493200e-02,1.344200e-02,1.157900e-02, & - &9.237800e-03,6.420300e-03,3.814700e-03,2.403600e-03,4.760400e-02, & - &1.139900e-02,1.144900e-02,1.071000e-02,9.717400e-03,8.532300e-03, & - &7.173000e-03,5.582700e-03,3.668200e-03,2.073000e-03,1.212400e-03, & - &2.716300e-02,1.191600e-02,1.211800e-02,1.141000e-02,1.042400e-02, & - &9.209900e-03,7.805400e-03,6.107300e-03,4.075700e-03,2.319100e-03, & - &1.369300e-03,3.069200e-02,1.241300e-02,1.281000e-02,1.215600e-02, & - &1.116600e-02,9.930000e-03,8.466600e-03,6.663700e-03,4.503600e-03, & - &2.586900e-03,1.558000e-03,3.415800e-02,1.294500e-02,1.352400e-02, & - &1.293000e-02,1.193400e-02,1.068000e-02,9.153800e-03,7.249200e-03, & - &4.953200e-03,2.884400e-03,1.776900e-03,3.748600e-02,1.353400e-02, & - &1.429600e-02,1.374800e-02,1.275000e-02,1.147200e-02,9.867800e-03, & - &7.855500e-03,5.425800e-03,3.216100e-03,2.020300e-03,4.066000e-02/ - data absa(1:330,6) / & - &1.381200e-01,1.382600e-01,1.341200e-01,1.251200e-01,1.122400e-01, & - &9.521700e-02,7.497600e-02,5.133600e-02,3.061400e-02,2.169600e-02, & - &2.037400e-02,1.394100e-01,1.421200e-01,1.389900e-01,1.301500e-01, & - &1.172300e-01,9.970500e-02,7.942300e-02,5.525100e-02,3.393200e-02, & - &2.485100e-02,2.392800e-02,1.406900e-01,1.460600e-01,1.434900e-01, & - &1.349200e-01,1.218200e-01,1.043100e-01,8.437300e-02,5.933000e-02, & - &3.752000e-02,2.850300e-02,2.798100e-02,1.420400e-01,1.498000e-01, & - &1.477300e-01,1.395500e-01,1.263500e-01,1.095300e-01,8.932000e-02, & - &6.366300e-02,4.146400e-02,3.270900e-02,3.251900e-02,1.433500e-01, & - &1.533200e-01,1.519000e-01,1.439300e-01,1.313100e-01,1.149800e-01, & - &9.423100e-02,6.837300e-02,4.571800e-02,3.737900e-02,3.756100e-02, & - &1.254000e-01,1.256900e-01,1.216300e-01,1.128400e-01,1.011900e-01, & - &8.626700e-02,6.781400e-02,4.628100e-02,2.702600e-02,1.820900e-02, & - &1.615500e-02,1.269000e-01,1.294700e-01,1.260900e-01,1.175800e-01, & - &1.059600e-01,9.064800e-02,7.208500e-02,4.989100e-02,2.987600e-02, & - &2.076600e-02,1.904500e-02,1.284500e-01,1.331800e-01,1.303300e-01, & - &1.221100e-01,1.105200e-01,9.525600e-02,7.666400e-02,5.362700e-02, & - &3.298400e-02,2.375000e-02,2.233800e-02,1.299400e-01,1.367900e-01, & - &1.345400e-01,1.264900e-01,1.151300e-01,1.001800e-01,8.113200e-02, & - &5.762300e-02,3.641700e-02,2.717700e-02,2.604700e-02,1.313500e-01, & - &1.403200e-01,1.387400e-01,1.309600e-01,1.202000e-01,1.052100e-01, & - &8.580300e-02,6.199100e-02,4.011100e-02,3.099300e-02,3.018300e-02, & - &1.124900e-01,1.124100e-01,1.079700e-01,9.958200e-02,8.899100e-02, & - &7.612200e-02,5.977600e-02,4.042300e-02,2.338100e-02,1.498900e-02, & - &1.239200e-02,1.141000e-01,1.160600e-01,1.120500e-01,1.039200e-01, & - &9.353800e-02,8.037400e-02,6.375500e-02,4.375000e-02,2.584800e-02, & - &1.706500e-02,1.464700e-02,1.156900e-01,1.196500e-01,1.161300e-01, & - &1.083100e-01,9.790500e-02,8.476500e-02,6.783900e-02,4.719100e-02, & - &2.851400e-02,1.942500e-02,1.723300e-02,1.172600e-01,1.230900e-01, & - &1.203200e-01,1.125900e-01,1.024700e-01,8.938700e-02,7.192800e-02, & - &5.078700e-02,3.145500e-02,2.212800e-02,2.013700e-02,1.187400e-01, & - &1.265800e-01,1.244000e-01,1.170500e-01,1.073900e-01,9.385700e-02, & - &7.624400e-02,5.477100e-02,3.462400e-02,2.515800e-02,2.339800e-02, & - &1.001000e-01,9.968500e-02,9.478700e-02,8.688200e-02,7.719800e-02, & - &6.593400e-02,5.180700e-02,3.473600e-02,1.998000e-02,1.233500e-02, & - &1.014100e-02,1.017000e-01,1.031200e-01,9.862200e-02,9.090500e-02, & - &8.142600e-02,6.990000e-02,5.549400e-02,3.766100e-02,2.213400e-02, & - &1.401300e-02,1.175800e-02,1.033500e-01,1.065100e-01,1.024500e-01, & - &9.506800e-02,8.557000e-02,7.405600e-02,5.916200e-02,4.069800e-02, & - &2.449200e-02,1.592000e-02,1.363700e-02,1.049900e-01,1.097900e-01, & - &1.064200e-01,9.922300e-02,8.997700e-02,7.827300e-02,6.281500e-02, & - &4.399100e-02,2.703700e-02,1.807200e-02,1.582800e-02,1.064800e-01, & - &1.132000e-01,1.103200e-01,1.035500e-01,9.462100e-02,8.244200e-02, & - &6.667800e-02,4.758600e-02,2.976600e-02,2.047600e-02,1.832200e-02, & - &8.864600e-02,8.793300e-02,8.283200e-02,7.547600e-02,6.664000e-02, & - &5.656600e-02,4.440900e-02,2.957400e-02,1.690400e-02,1.027200e-02, & - &9.135100e-03,9.027700e-02,9.108100e-02,8.631800e-02,7.922900e-02, & - &7.049500e-02,6.019200e-02,4.772400e-02,3.210300e-02,1.875000e-02, & - &1.164100e-02,1.054200e-02,9.198400e-02,9.426300e-02,8.992800e-02, & - &8.309300e-02,7.436800e-02,6.399900e-02,5.103000e-02,3.475500e-02, & - &2.078000e-02,1.317100e-02,1.213600e-02,9.357600e-02,9.744700e-02, & - &9.365400e-02,8.700600e-02,7.842400e-02,6.787700e-02,5.437400e-02, & - &3.763800e-02,2.300200e-02,1.489300e-02,1.392300e-02,9.508000e-02, & - &1.006500e-01,9.738300e-02,9.113600e-02,8.260100e-02,7.170100e-02, & - &5.786300e-02,4.079600e-02,2.541200e-02,1.680900e-02,1.590800e-02, & - &7.796000e-02,7.693400e-02,7.184300e-02,6.515600e-02,5.720700e-02, & - &4.815600e-02,3.765900e-02,2.487900e-02,1.412700e-02,8.554100e-03, & - &8.366600e-03,7.960900e-02,7.986600e-02,7.506300e-02,6.859200e-02, & - &6.062300e-02,5.141600e-02,4.060400e-02,2.709900e-02,1.568500e-02, & - &9.691800e-03,9.557200e-03,8.130200e-02,8.283600e-02,7.844500e-02, & - &7.212700e-02,6.413600e-02,5.485700e-02,4.356500e-02,2.936600e-02, & - &1.740000e-02,1.096300e-02,1.092200e-02,8.280200e-02,8.586400e-02, & - &8.190400e-02,7.577000e-02,6.785200e-02,5.833000e-02,4.652200e-02, & - &3.183700e-02,1.927700e-02,1.236400e-02,1.245200e-02,8.422100e-02, & - &8.882300e-02,8.538400e-02,7.963000e-02,7.159000e-02,6.182300e-02, & - &4.965300e-02,3.455400e-02,2.133700e-02,1.390100e-02,1.413600e-02/ - data absa(331:715,6) / & - &6.782800e-02,6.642100e-02,6.152000e-02,5.549700e-02,4.847700e-02, & - &4.052300e-02,3.151900e-02,2.072300e-02,1.168400e-02,7.044200e-03, & - &8.215300e-03,6.938600e-02,6.908400e-02,6.446600e-02,5.862100e-02, & - &5.151300e-02,4.340400e-02,3.411700e-02,2.262000e-02,1.300200e-02, & - &8.009600e-03,9.302300e-03,7.090200e-02,7.178100e-02,6.757100e-02, & - &6.179800e-02,5.466800e-02,4.648500e-02,3.672200e-02,2.459600e-02, & - &1.444100e-02,9.079100e-03,1.052800e-02,7.228200e-02,7.447400e-02, & - &7.067400e-02,6.510200e-02,5.802000e-02,4.958300e-02,3.933400e-02, & - &2.669400e-02,1.600700e-02,1.027100e-02,1.192200e-02,7.358600e-02, & - &7.714100e-02,7.378700e-02,6.856700e-02,6.136900e-02,5.267100e-02, & - &4.210300e-02,2.897900e-02,1.773600e-02,1.157200e-02,1.344700e-02, & - &5.871200e-02,5.704300e-02,5.243800e-02,4.702100e-02,4.085300e-02, & - &3.389500e-02,2.619800e-02,1.721900e-02,9.594400e-03,5.756500e-03, & - &9.790300e-03,6.011100e-02,5.940300e-02,5.510900e-02,4.979200e-02, & - &4.350000e-02,3.640600e-02,2.844100e-02,1.883200e-02,1.071500e-02, & - &6.556500e-03,1.088600e-02,6.146400e-02,6.176500e-02,5.783900e-02, & - &5.259100e-02,4.627600e-02,3.907800e-02,3.073300e-02,2.050800e-02, & - &1.193400e-02,7.456600e-03,1.212100e-02,6.271200e-02,6.414600e-02, & - &6.052700e-02,5.545700e-02,4.922600e-02,4.179700e-02,3.303100e-02, & - &2.230000e-02,1.325200e-02,8.462500e-03,1.348200e-02,6.391400e-02, & - &6.649000e-02,6.323400e-02,5.845700e-02,5.212400e-02,4.450400e-02, & - &3.548400e-02,2.423900e-02,1.470800e-02,9.576600e-03,1.497500e-02, & - &5.068900e-02,4.891900e-02,4.469400e-02,3.983400e-02,3.442600e-02, & - &2.838900e-02,2.181900e-02,1.430200e-02,7.812700e-03,4.662000e-03, & - &2.069600e-02,5.194600e-02,5.097300e-02,4.705600e-02,4.225300e-02, & - &3.673700e-02,3.054400e-02,2.372400e-02,1.566800e-02,8.778000e-03, & - &5.321400e-03,2.191000e-02,5.314300e-02,5.307700e-02,4.943100e-02, & - &4.466500e-02,3.912200e-02,3.281600e-02,2.569200e-02,1.709600e-02, & - &9.803900e-03,6.065600e-03,2.323400e-02,5.426700e-02,5.515700e-02, & - &5.173900e-02,4.716700e-02,4.164400e-02,3.513600e-02,2.768500e-02, & - &1.862600e-02,1.091600e-02,6.906000e-03,2.482600e-02,5.541100e-02, & - &5.722000e-02,5.407400e-02,4.969900e-02,4.412700e-02,3.747700e-02, & - &2.978500e-02,2.027300e-02,1.214800e-02,7.841100e-03,2.660700e-02, & - &4.344100e-02,4.175200e-02,3.799200e-02,3.373200e-02,2.903300e-02, & - &2.389200e-02,1.831500e-02,1.192500e-02,6.365000e-03,3.773000e-03, & - &5.898000e-02,4.457800e-02,4.353400e-02,4.003600e-02,3.580000e-02, & - &3.103800e-02,2.574500e-02,1.992800e-02,1.309500e-02,7.190100e-03, & - &4.326800e-03,6.212700e-02,4.563700e-02,4.536000e-02,4.207400e-02, & - &3.789000e-02,3.310900e-02,2.766200e-02,2.160500e-02,1.431800e-02, & - &8.071700e-03,4.944100e-03,6.493000e-02,4.666500e-02,4.720100e-02, & - &4.407300e-02,4.004100e-02,3.522700e-02,2.963400e-02,2.331000e-02, & - &1.563000e-02,9.007400e-03,5.643100e-03,6.749000e-02,4.772300e-02, & - &4.903700e-02,4.614200e-02,4.222800e-02,3.734800e-02,3.160800e-02, & - &2.507500e-02,1.703600e-02,1.004500e-02,6.426800e-03,6.997700e-02, & - &3.751600e-02,3.615800e-02,3.293300e-02,2.925200e-02,2.520400e-02, & - &2.080300e-02,1.599000e-02,1.037500e-02,5.482700e-03,3.236100e-03, & - &8.101600e-02,3.850600e-02,3.772100e-02,3.470600e-02,3.103100e-02, & - &2.694600e-02,2.241100e-02,1.738600e-02,1.140900e-02,6.200300e-03, & - &3.721000e-03,8.468500e-02,3.943900e-02,3.931000e-02,3.643600e-02, & - &3.283000e-02,2.873600e-02,2.407100e-02,1.883100e-02,1.248700e-02, & - &6.972200e-03,4.262300e-03,8.798000e-02,4.039200e-02,4.094400e-02, & - &3.821700e-02,3.470700e-02,3.054300e-02,2.573100e-02,2.030300e-02, & - &1.364600e-02,7.797000e-03,4.870300e-03,9.098100e-02,4.133200e-02, & - &4.255200e-02,4.005900e-02,3.660300e-02,3.238300e-02,2.745000e-02, & - &2.183300e-02,1.488700e-02,8.708400e-03,5.552700e-03,9.397300e-02, & - &3.219000e-02,3.107100e-02,2.832100e-02,2.515200e-02,2.172800e-02, & - &1.798100e-02,1.382200e-02,8.960200e-03,4.710600e-03,2.756400e-03, & - &8.540200e-02,3.303300e-02,3.240500e-02,2.980600e-02,2.666100e-02, & - &2.321100e-02,1.936100e-02,1.502500e-02,9.864100e-03,5.329700e-03, & - &3.177000e-03,8.873700e-02,3.386400e-02,3.379300e-02,3.129700e-02, & - &2.821100e-02,2.473300e-02,2.077100e-02,1.626500e-02,1.082100e-02, & - &6.002200e-03,3.646700e-03,9.167000e-02,3.469600e-02,3.520300e-02, & - &3.285300e-02,2.981700e-02,2.629600e-02,2.220300e-02,1.754500e-02, & - &1.183400e-02,6.730200e-03,4.167900e-03,9.457400e-02,3.552200e-02, & - &3.662600e-02,3.442300e-02,3.143800e-02,2.787500e-02,2.369700e-02, & - &1.890500e-02,1.292700e-02,7.519100e-03,4.759000e-03,9.761400e-02, & - &2.721000e-02,2.630400e-02,2.399600e-02,2.135900e-02,1.849100e-02, & - &1.531400e-02,1.175500e-02,7.617000e-03,4.009500e-03,2.327500e-03, & - &7.121100e-02,2.794100e-02,2.744100e-02,2.524600e-02,2.262200e-02, & - &1.972900e-02,1.647200e-02,1.276500e-02,8.403400e-03,4.544700e-03, & - &2.686100e-03,7.376900e-02,2.866400e-02,2.863000e-02,2.652000e-02, & - &2.393500e-02,2.102500e-02,1.766200e-02,1.382100e-02,9.235900e-03, & - &5.127300e-03,3.087100e-03,7.613600e-02,2.938700e-02,2.984400e-02, & - &2.783200e-02,2.528700e-02,2.234100e-02,1.888800e-02,1.494000e-02, & - &1.011700e-02,5.752900e-03,3.533400e-03,7.867300e-02,3.012100e-02, & - &3.106400e-02,2.914000e-02,2.665100e-02,2.368000e-02,2.017700e-02, & - &1.613400e-02,1.107700e-02,6.428300e-03,4.040200e-03,8.150500e-02/ - data absa(1:330,7) / & - &2.692600e-01,2.561200e-01,2.395000e-01,2.190300e-01,1.937800e-01, & - &1.650100e-01,1.297300e-01,8.743900e-02,5.395000e-02,4.281100e-02, & - &4.323300e-02,2.686100e-01,2.593000e-01,2.451300e-01,2.256800e-01, & - &2.013300e-01,1.729400e-01,1.371100e-01,9.446400e-02,6.059500e-02, & - &5.071000e-02,5.167700e-02,2.682000e-01,2.623800e-01,2.510200e-01, & - &2.324000e-01,2.091300e-01,1.809100e-01,1.444600e-01,1.022600e-01, & - &6.808400e-02,5.949500e-02,6.103700e-02,2.677100e-01,2.657200e-01, & - &2.565800e-01,2.393500e-01,2.168500e-01,1.883900e-01,1.522200e-01, & - &1.106900e-01,7.627900e-02,6.910800e-02,7.121300e-02,2.671400e-01, & - &2.693600e-01,2.619400e-01,2.464200e-01,2.245000e-01,1.957100e-01, & - &1.608300e-01,1.191800e-01,8.542100e-02,7.968200e-02,8.228000e-02, & - &2.568500e-01,2.449200e-01,2.286500e-01,2.088400e-01,1.844400e-01, & - &1.560100e-01,1.231900e-01,8.174700e-02,4.823000e-02,3.540900e-02, & - &3.461500e-02,2.565700e-01,2.483400e-01,2.344500e-01,2.155100e-01, & - &1.918200e-01,1.637700e-01,1.304200e-01,8.819700e-02,5.389100e-02, & - &4.182200e-02,4.151500e-02,2.562700e-01,2.516300e-01,2.401100e-01, & - &2.223000e-01,1.993700e-01,1.715000e-01,1.375800e-01,9.525400e-02, & - &6.001800e-02,4.902500e-02,4.918900e-02,2.559100e-01,2.551700e-01, & - &2.455800e-01,2.292800e-01,2.070200e-01,1.789900e-01,1.452400e-01, & - &1.025800e-01,6.678200e-02,5.712300e-02,5.763100e-02,2.556200e-01, & - &2.590200e-01,2.509500e-01,2.363800e-01,2.142200e-01,1.866200e-01, & - &1.532900e-01,1.099600e-01,7.440500e-02,6.614200e-02,6.694900e-02, & - &2.410800e-01,2.296500e-01,2.136100e-01,1.944600e-01,1.713300e-01, & - &1.440100e-01,1.134500e-01,7.518500e-02,4.216000e-02,2.858300e-02, & - &2.658400e-02,2.411300e-01,2.331400e-01,2.194200e-01,2.011900e-01, & - &1.784600e-01,1.514600e-01,1.206300e-01,8.117300e-02,4.704400e-02, & - &3.353300e-02,3.201900e-02,2.409400e-01,2.366300e-01,2.250100e-01, & - &2.077300e-01,1.858000e-01,1.590700e-01,1.279800e-01,8.750100e-02, & - &5.231300e-02,3.924400e-02,3.814100e-02,2.407400e-01,2.404300e-01, & - &2.304100e-01,2.144900e-01,1.931700e-01,1.664700e-01,1.355600e-01, & - &9.394900e-02,5.798000e-02,4.577700e-02,4.502000e-02,2.407100e-01, & - &2.443000e-01,2.359100e-01,2.213700e-01,2.001700e-01,1.742500e-01, & - &1.433200e-01,1.004700e-01,6.424500e-02,5.323700e-02,5.273000e-02, & - &2.231100e-01,2.120200e-01,1.966000e-01,1.780400e-01,1.561900e-01, & - &1.306600e-01,1.023900e-01,6.799600e-02,3.690800e-02,2.323500e-02, & - &2.039700e-02,2.232100e-01,2.155200e-01,2.020900e-01,1.844900e-01, & - &1.628400e-01,1.377400e-01,1.093000e-01,7.377500e-02,4.107800e-02, & - &2.700400e-02,2.461400e-02,2.231400e-01,2.190100e-01,2.075300e-01, & - &1.907300e-01,1.698100e-01,1.449400e-01,1.163400e-01,7.980700e-02, & - &4.548300e-02,3.140500e-02,2.948100e-02,2.232700e-01,2.228700e-01, & - &2.128400e-01,1.971600e-01,1.769300e-01,1.522600e-01,1.238100e-01, & - &8.575100e-02,5.027900e-02,3.652800e-02,3.503000e-02,2.236500e-01, & - &2.267300e-01,2.182000e-01,2.037200e-01,1.838500e-01,1.598400e-01, & - &1.313300e-01,9.159300e-02,5.561500e-02,4.245900e-02,4.130600e-02, & - &2.036700e-01,1.933000e-01,1.786700e-01,1.608400e-01,1.402700e-01, & - &1.169300e-01,9.094500e-02,6.046600e-02,3.245500e-02,1.916500e-02, & - &1.792000e-02,2.038700e-01,1.966800e-01,1.838000e-01,1.668200e-01, & - &1.465300e-01,1.234600e-01,9.744300e-02,6.596200e-02,3.613800e-02, & - &2.216900e-02,2.093400e-02,2.040800e-01,2.001500e-01,1.888500e-01, & - &1.726400e-01,1.530300e-01,1.302300e-01,1.041300e-01,7.167600e-02, & - &3.991600e-02,2.558100e-02,2.439300e-02,2.046700e-01,2.039500e-01, & - &1.938900e-01,1.786200e-01,1.596600e-01,1.372500e-01,1.110600e-01, & - &7.728700e-02,4.397600e-02,2.956700e-02,2.844000e-02,2.053800e-01, & - &2.078400e-01,1.989500e-01,1.847400e-01,1.663500e-01,1.445900e-01, & - &1.180700e-01,8.279500e-02,4.848500e-02,3.419500e-02,3.317400e-02, & - &1.837700e-01,1.739800e-01,1.600600e-01,1.431800e-01,1.239700e-01, & - &1.029800e-01,7.952100e-02,5.239700e-02,2.805000e-02,1.593400e-02, & - &1.679100e-02,1.840600e-01,1.771700e-01,1.647400e-01,1.485300e-01, & - &1.298400e-01,1.089800e-01,8.532800e-02,5.749000e-02,3.144700e-02, & - &1.834900e-02,1.951600e-02,1.845800e-01,1.805400e-01,1.693600e-01, & - &1.539200e-01,1.358400e-01,1.151700e-01,9.140900e-02,6.283600e-02, & - &3.488900e-02,2.110600e-02,2.261100e-02,1.854200e-01,1.842100e-01, & - &1.740300e-01,1.594200e-01,1.419600e-01,1.216200e-01,9.792800e-02, & - &6.813900e-02,3.848300e-02,2.424400e-02,2.612400e-02,1.864800e-01, & - &1.880100e-01,1.789000e-01,1.650600e-01,1.482300e-01,1.284000e-01, & - &1.043800e-01,7.330400e-02,4.237800e-02,2.783900e-02,3.005300e-02/ - data absa(331:715,7) / & - &1.627200e-01,1.537200e-01,1.408000e-01,1.251900e-01,1.077100e-01, & - &8.898400e-02,6.827600e-02,4.454100e-02,2.380700e-02,1.345300e-02, & - &1.665500e-02,1.632500e-01,1.567900e-01,1.449800e-01,1.298600e-01, & - &1.129700e-01,9.440200e-02,7.338300e-02,4.904600e-02,2.684500e-02, & - &1.540500e-02,1.913200e-02,1.640000e-01,1.600700e-01,1.491600e-01, & - &1.347300e-01,1.183600e-01,9.994900e-02,7.880600e-02,5.383300e-02, & - &2.995400e-02,1.764500e-02,2.189500e-02,1.650500e-01,1.635300e-01, & - &1.534700e-01,1.398200e-01,1.239200e-01,1.056500e-01,8.463400e-02, & - &5.859700e-02,3.320700e-02,2.017100e-02,2.498600e-02,1.664100e-01, & - &1.672600e-01,1.580800e-01,1.450600e-01,1.297300e-01,1.118200e-01, & - &9.046100e-02,6.333400e-02,3.668900e-02,2.303100e-02,2.847600e-02, & - &1.423000e-01,1.341300e-01,1.223300e-01,1.081300e-01,9.249600e-02, & - &7.590400e-02,5.790600e-02,3.739400e-02,2.001900e-02,1.131000e-02, & - &1.901900e-02,1.430500e-01,1.370800e-01,1.259600e-01,1.121800e-01, & - &9.710900e-02,8.070400e-02,6.233000e-02,4.121800e-02,2.262300e-02, & - &1.302900e-02,2.154600e-02,1.439400e-01,1.401300e-01,1.297000e-01, & - &1.165800e-01,1.019400e-01,8.559100e-02,6.704300e-02,4.534700e-02, & - &2.535900e-02,1.490300e-02,2.432700e-02,1.452500e-01,1.433900e-01, & - &1.337300e-01,1.212600e-01,1.069000e-01,9.068300e-02,7.212900e-02, & - &4.956900e-02,2.822200e-02,1.696400e-02,2.742700e-02,1.467800e-01, & - &1.470200e-01,1.381400e-01,1.261600e-01,1.121700e-01,9.613600e-02, & - &7.725300e-02,5.380000e-02,3.128500e-02,1.927400e-02,3.089000e-02, & - &1.236800e-01,1.161500e-01,1.054700e-01,9.273000e-02,7.889000e-02, & - &6.428800e-02,4.870600e-02,3.119400e-02,1.673500e-02,9.362100e-03, & - &3.947400e-02,1.245300e-01,1.188600e-01,1.086200e-01,9.629900e-02, & - &8.289200e-02,6.844400e-02,5.253400e-02,3.436000e-02,1.894900e-02, & - &1.087500e-02,4.318500e-02,1.256200e-01,1.217700e-01,1.119900e-01, & - &1.002500e-01,8.715700e-02,7.273400e-02,5.656700e-02,3.783700e-02, & - &2.130700e-02,1.252400e-02,4.726200e-02,1.271100e-01,1.249700e-01, & - &1.158500e-01,1.045300e-01,9.159200e-02,7.723700e-02,6.092700e-02, & - &4.147400e-02,2.378300e-02,1.432100e-02,5.160100e-02,1.287700e-01, & - &1.284200e-01,1.200500e-01,1.091100e-01,9.638400e-02,8.205200e-02, & - &6.539000e-02,4.520000e-02,2.642300e-02,1.626400e-02,5.623100e-02, & - &1.069200e-01,1.000500e-01,9.050200e-02,7.921600e-02,6.705700e-02, & - &5.432300e-02,4.089000e-02,2.611900e-02,1.401900e-02,7.752500e-03, & - &1.208200e-01,1.078500e-01,1.025700e-01,9.325100e-02,8.231600e-02, & - &7.051500e-02,5.784800e-02,4.419700e-02,2.876900e-02,1.589200e-02, & - &9.052800e-03,1.255700e-01,1.091200e-01,1.053400e-01,9.634500e-02, & - &8.588800e-02,7.421800e-02,6.159000e-02,4.763900e-02,3.164500e-02, & - &1.792600e-02,1.049700e-02,1.312400e-01,1.106800e-01,1.083600e-01, & - &9.996400e-02,8.981000e-02,7.824400e-02,6.559300e-02,5.133700e-02, & - &3.471100e-02,2.007100e-02,1.208300e-02,1.378400e-01,1.123700e-01, & - &1.116100e-01,1.038800e-01,9.394700e-02,8.258000e-02,6.988300e-02, & - &5.520300e-02,3.792800e-02,2.234800e-02,1.379200e-02,1.451800e-01, & - &9.275400e-02,8.707200e-02,7.863900e-02,6.875500e-02,5.827500e-02, & - &4.724500e-02,3.560200e-02,2.286600e-02,1.233400e-02,6.850500e-03, & - &1.660900e-01,9.393900e-02,8.957100e-02,8.123800e-02,7.171100e-02, & - &6.138100e-02,5.030600e-02,3.844200e-02,2.515600e-02,1.399100e-02, & - &8.012200e-03,1.713800e-01,9.541200e-02,9.228200e-02,8.432400e-02, & - &7.510200e-02,6.478500e-02,5.364000e-02,4.147000e-02,2.763500e-02, & - &1.578700e-02,9.317400e-03,1.777800e-01,9.699600e-02,9.514200e-02, & - &8.774500e-02,7.870800e-02,6.848300e-02,5.728200e-02,4.471400e-02, & - &3.027700e-02,1.770700e-02,1.074900e-02,1.849900e-01,9.865800e-02, & - &9.828400e-02,9.138800e-02,8.253400e-02,7.240400e-02,6.104100e-02, & - &4.811000e-02,3.308300e-02,1.972500e-02,1.230900e-02,1.929400e-01, & - &8.000200e-02,7.539500e-02,6.795300e-02,5.946700e-02,5.045800e-02, & - &4.091900e-02,3.092000e-02,1.992500e-02,1.072700e-02,5.990100e-03, & - &1.750500e-01,8.133200e-02,7.781300e-02,7.056700e-02,6.230700e-02, & - &5.330300e-02,4.361800e-02,3.339100e-02,2.191100e-02,1.218400e-02, & - &7.018900e-03,1.804800e-01,8.279100e-02,8.032400e-02,7.348500e-02, & - &6.542000e-02,5.635200e-02,4.661000e-02,3.604700e-02,2.405600e-02, & - &1.376500e-02,8.180900e-03,1.870400e-01,8.430000e-02,8.306300e-02, & - &7.663700e-02,6.867100e-02,5.964600e-02,4.977400e-02,3.888600e-02, & - &2.635100e-02,1.546300e-02,9.464600e-03,1.941600e-01,8.579900e-02, & - &8.592800e-02,7.992300e-02,7.213800e-02,6.309700e-02,5.307100e-02, & - &4.185100e-02,2.880000e-02,1.726000e-02,1.086900e-02,2.018000e-01, & - &6.774600e-02,6.411700e-02,5.779400e-02,5.068700e-02,4.309100e-02, & - &3.506300e-02,2.660000e-02,1.714300e-02,9.208500e-03,5.173800e-03, & - &1.468400e-01,6.904000e-02,6.632600e-02,6.027200e-02,5.326700e-02, & - &4.564000e-02,3.744600e-02,2.877100e-02,1.887500e-02,1.047200e-02, & - &6.078600e-03,1.519000e-01,7.040200e-02,6.867400e-02,6.293000e-02, & - &5.604400e-02,4.832200e-02,4.004600e-02,3.109300e-02,2.074600e-02, & - &1.185400e-02,7.099200e-03,1.578300e-01,7.172700e-02,7.111600e-02, & - &6.569800e-02,5.895500e-02,5.118800e-02,4.278000e-02,3.353500e-02, & - &2.275100e-02,1.334300e-02,8.233300e-03,1.641400e-01,7.315300e-02, & - &7.369400e-02,6.862100e-02,6.193300e-02,5.416800e-02,4.564800e-02, & - &3.608900e-02,2.487400e-02,1.493200e-02,9.481600e-03,1.707100e-01/ - data absa(1:330,8) / & - &4.929900e-01,4.509700e-01,4.142300e-01,3.742500e-01,3.328800e-01, & - &2.843900e-01,2.312900e-01,1.672400e-01,1.220900e-01,1.183900e-01, & - &1.223100e-01,4.915800e-01,4.541300e-01,4.213000e-01,3.857400e-01, & - &3.455600e-01,2.986200e-01,2.467200e-01,1.828500e-01,1.431600e-01, & - &1.417300e-01,1.465300e-01,4.892100e-01,4.583500e-01,4.289500e-01, & - &3.975500e-01,3.582400e-01,3.131300e-01,2.620800e-01,1.997400e-01, & - &1.663400e-01,1.669600e-01,1.727300e-01,4.866400e-01,4.627900e-01, & - &4.377400e-01,4.088100e-01,3.710300e-01,3.286800e-01,2.771100e-01, & - &2.174000e-01,1.917200e-01,1.940300e-01,2.009100e-01,4.842800e-01, & - &4.666400e-01,4.470400e-01,4.192600e-01,3.840500e-01,3.440700e-01, & - &2.918600e-01,2.366400e-01,2.190600e-01,2.227600e-01,2.307800e-01, & - &5.009800e-01,4.583800e-01,4.190200e-01,3.753800e-01,3.303400e-01, & - &2.797300e-01,2.219500e-01,1.566800e-01,1.058700e-01,9.849000e-02, & - &1.003300e-01,4.998300e-01,4.623500e-01,4.266100e-01,3.865500e-01, & - &3.428200e-01,2.930100e-01,2.361000e-01,1.705600e-01,1.231800e-01, & - &1.187600e-01,1.211400e-01,4.981200e-01,4.673200e-01,4.349200e-01, & - &3.979100e-01,3.551800e-01,3.066300e-01,2.507300e-01,1.848600e-01, & - &1.428100e-01,1.407500e-01,1.437600e-01,4.962300e-01,4.720000e-01, & - &4.436100e-01,4.086900e-01,3.671600e-01,3.209400e-01,2.650300e-01, & - &2.003800e-01,1.645000e-01,1.644700e-01,1.681200e-01,4.944300e-01, & - &4.756500e-01,4.524500e-01,4.188400e-01,3.799100e-01,3.350200e-01, & - &2.789300e-01,2.172600e-01,1.882300e-01,1.899200e-01,1.942600e-01, & - &5.031600e-01,4.605400e-01,4.194800e-01,3.735800e-01,3.253700e-01, & - &2.719900e-01,2.120100e-01,1.440500e-01,9.106100e-02,7.821600e-02, & - &7.843100e-02,5.025000e-01,4.650800e-01,4.275300e-01,3.844800e-01, & - &3.374300e-01,2.847700e-01,2.247100e-01,1.569000e-01,1.046300e-01, & - &9.529700e-02,9.577500e-02,5.015600e-01,4.703400e-01,4.358700e-01, & - &3.959200e-01,3.493800e-01,2.973800e-01,2.378100e-01,1.699000e-01, & - &1.202100e-01,1.140600e-01,1.148100e-01,5.004000e-01,4.752600e-01, & - &4.446300e-01,4.064100e-01,3.611200e-01,3.106300e-01,2.508900e-01, & - &1.836100e-01,1.379500e-01,1.345300e-01,1.355800e-01,4.990400e-01, & - &4.793400e-01,4.534500e-01,4.161900e-01,3.732700e-01,3.237600e-01, & - &2.637600e-01,1.984700e-01,1.577800e-01,1.565900e-01,1.579800e-01, & - &4.980600e-01,4.557700e-01,4.139000e-01,3.671600e-01,3.175600e-01, & - &2.634700e-01,2.023400e-01,1.327100e-01,7.895000e-02,6.098000e-02, & - &6.037900e-02,4.982600e-01,4.610100e-01,4.224200e-01,3.780000e-01, & - &3.300700e-01,2.758500e-01,2.139700e-01,1.441300e-01,8.979400e-02, & - &7.494700e-02,7.463900e-02,4.981100e-01,4.668100e-01,4.309600e-01, & - &3.896200e-01,3.421900e-01,2.878400e-01,2.262000e-01,1.558400e-01, & - &1.022700e-01,9.060900e-02,9.048800e-02,4.974600e-01,4.721300e-01, & - &4.399200e-01,4.006000e-01,3.535900e-01,3.000100e-01,2.382600e-01, & - &1.683500e-01,1.165500e-01,1.079100e-01,1.079500e-01,4.963500e-01, & - &4.767200e-01,4.491400e-01,4.106100e-01,3.651100e-01,3.121800e-01, & - &2.502800e-01,1.818700e-01,1.322600e-01,1.265400e-01,1.267300e-01, & - &4.863800e-01,4.444500e-01,4.024000e-01,3.559500e-01,3.062400e-01, & - &2.523600e-01,1.924600e-01,1.231200e-01,6.900100e-02,4.771500e-02, & - &4.668300e-02,4.871000e-01,4.501400e-01,4.114500e-01,3.670000e-01, & - &3.186200e-01,2.646300e-01,2.037600e-01,1.333100e-01,7.835200e-02, & - &5.872200e-02,5.806800e-02,4.873300e-01,4.564600e-01,4.203800e-01, & - &3.787100e-01,3.308600e-01,2.765700e-01,2.150900e-01,1.438200e-01, & - &8.870300e-02,7.145100e-02,7.107500e-02,4.868800e-01,4.622100e-01, & - &4.295600e-01,3.897700e-01,3.424900e-01,2.884300e-01,2.263800e-01, & - &1.551700e-01,1.001000e-01,8.558600e-02,8.539800e-02,4.860500e-01, & - &4.672500e-01,4.388700e-01,4.000200e-01,3.536900e-01,3.000800e-01, & - &2.378000e-01,1.673800e-01,1.124900e-01,1.009300e-01,1.009100e-01, & - &4.667100e-01,4.260000e-01,3.846600e-01,3.392600e-01,2.906100e-01, & - &2.376800e-01,1.796300e-01,1.142000e-01,6.055200e-02,3.785000e-02, & - &4.192100e-02,4.680300e-01,4.320300e-01,3.939200e-01,3.505300e-01, & - &3.026900e-01,2.496200e-01,1.907700e-01,1.235100e-01,6.851200e-02, & - &4.628400e-02,5.004900e-02,4.684200e-01,4.384000e-01,4.030400e-01, & - &3.619800e-01,3.147200e-01,2.614200e-01,2.020100e-01,1.330400e-01, & - &7.746200e-02,5.608900e-02,5.944000e-02,4.683400e-01,4.443800e-01, & - &4.123300e-01,3.729100e-01,3.260900e-01,2.729900e-01,2.129800e-01, & - &1.432200e-01,8.705400e-02,6.723300e-02,7.002400e-02,4.679200e-01, & - &4.499000e-01,4.213600e-01,3.830500e-01,3.370800e-01,2.843100e-01, & - &2.241100e-01,1.543000e-01,9.708800e-02,7.961800e-02,8.179200e-02/ - data absa(331:715,8) / & - &4.369900e-01,3.983700e-01,3.589600e-01,3.159000e-01,2.695800e-01, & - &2.191900e-01,1.641800e-01,1.034400e-01,5.338200e-02,3.083100e-02, & - &4.295300e-02,4.384300e-01,4.044800e-01,3.681200e-01,3.270100e-01, & - &2.812400e-01,2.305000e-01,1.748200e-01,1.123400e-01,6.020000e-02, & - &3.722900e-02,5.068000e-02,4.391900e-01,4.108600e-01,3.773100e-01, & - &3.379900e-01,2.926500e-01,2.416900e-01,1.856500e-01,1.213100e-01, & - &6.791600e-02,4.473600e-02,5.930300e-02,4.396400e-01,4.170900e-01, & - &3.864200e-01,3.484400e-01,3.034300e-01,2.528900e-01,1.963300e-01, & - &1.309400e-01,7.622200e-02,5.332600e-02,6.850900e-02,4.394700e-01, & - &4.228800e-01,3.953700e-01,3.583200e-01,3.139900e-01,2.636900e-01, & - &2.072000e-01,1.413400e-01,8.484000e-02,6.300000e-02,7.818200e-02, & - &4.009500e-01,3.650800e-01,3.283900e-01,2.882800e-01,2.452600e-01, & - &1.984600e-01,1.474600e-01,9.177700e-02,4.686200e-02,2.576700e-02, & - &4.929800e-02,4.024700e-01,3.710800e-01,3.371800e-01,2.989500e-01, & - &2.560800e-01,2.088300e-01,1.573600e-01,1.001900e-01,5.294400e-02, & - &3.072900e-02,5.672100e-02,4.037900e-01,3.776900e-01,3.462400e-01, & - &3.091300e-01,2.665200e-01,2.191700e-01,1.674400e-01,1.087900e-01, & - &5.961800e-02,3.647900e-02,6.501900e-02,4.044000e-01,3.839300e-01, & - &3.551800e-01,3.191100e-01,2.767100e-01,2.295400e-01,1.775500e-01, & - &1.177600e-01,6.681100e-02,4.307800e-02,7.411300e-02,4.044600e-01, & - &3.896500e-01,3.636600e-01,3.284400e-01,2.866700e-01,2.399500e-01, & - &1.878400e-01,1.274300e-01,7.434700e-02,5.058300e-02,8.369200e-02, & - &3.622000e-01,3.294300e-01,2.956500e-01,2.588800e-01,2.195600e-01, & - &1.768800e-01,1.305300e-01,8.007300e-02,4.046900e-02,2.183900e-02, & - &9.419900e-02,3.641100e-01,3.354700e-01,3.041400e-01,2.687200e-01, & - &2.293500e-01,1.861200e-01,1.393900e-01,8.782100e-02,4.593100e-02, & - &2.582000e-02,1.033200e-01,3.656600e-01,3.419100e-01,3.128400e-01, & - &2.783100e-01,2.389300e-01,1.955300e-01,1.484900e-01,9.585000e-02, & - &5.187000e-02,3.041900e-02,1.136500e-01,3.663400e-01,3.478300e-01, & - &3.211200e-01,2.874700e-01,2.483800e-01,2.051800e-01,1.578600e-01, & - &1.041900e-01,5.826900e-02,3.562000e-02,1.247900e-01,3.668700e-01, & - &3.535200e-01,3.290000e-01,2.961100e-01,2.576900e-01,2.149800e-01, & - &1.674900e-01,1.130700e-01,6.492900e-02,4.147500e-02,1.369000e-01, & - &3.219900e-01,2.927800e-01,2.622200e-01,2.290500e-01,1.937300e-01, & - &1.555800e-01,1.142400e-01,6.941300e-02,3.479800e-02,1.889600e-02, & - &2.833500e-01,3.241900e-01,2.988200e-01,2.703100e-01,2.382200e-01, & - &2.026500e-01,1.638100e-01,1.220300e-01,7.620000e-02,3.965300e-02, & - &2.220300e-02,3.001000e-01,3.255700e-01,3.046800e-01,2.784100e-01, & - &2.469400e-01,2.113400e-01,1.724000e-01,1.302400e-01,8.342300e-02, & - &4.486200e-02,2.600600e-02,3.204100e-01,3.267600e-01,3.104000e-01, & - &2.859600e-01,2.550700e-01,2.198800e-01,1.812100e-01,1.387900e-01, & - &9.098400e-02,5.051900e-02,3.029600e-02,3.428300e-01,3.275600e-01, & - &3.160400e-01,2.932500e-01,2.632100e-01,2.285700e-01,1.901600e-01, & - &1.476200e-01,9.900000e-02,5.648800e-02,3.510500e-02,3.667700e-01, & - &2.841100e-01,2.598800e-01,2.332100e-01,2.041200e-01,1.724900e-01, & - &1.383800e-01,1.017200e-01,6.217800e-02,3.164600e-02,1.750600e-02, & - &3.991700e-01,2.858200e-01,2.653400e-01,2.405700e-01,2.121300e-01, & - &1.803400e-01,1.459300e-01,1.088800e-01,6.821000e-02,3.601100e-02, & - &2.056700e-02,4.227000e-01,2.873900e-01,2.708400e-01,2.478000e-01, & - &2.195900e-01,1.880300e-01,1.537200e-01,1.163600e-01,7.469500e-02, & - &4.072400e-02,2.398600e-02,4.493400e-01,2.887800e-01,2.764400e-01, & - &2.547200e-01,2.270900e-01,1.959700e-01,1.617700e-01,1.240800e-01, & - &8.164200e-02,4.576500e-02,2.777200e-02,4.771700e-01,2.895500e-01, & - &2.814400e-01,2.610200e-01,2.345400e-01,2.041100e-01,1.700200e-01, & - &1.322800e-01,8.882300e-02,5.114100e-02,3.201000e-02,5.055700e-01, & - &2.471000e-01,2.274700e-01,2.044600e-01,1.791000e-01,1.512600e-01, & - &1.214100e-01,8.946600e-02,5.497300e-02,2.849900e-02,1.599900e-02, & - &4.280000e-01,2.490100e-01,2.325800e-01,2.111100e-01,1.859700e-01, & - &1.580500e-01,1.281800e-01,9.580800e-02,6.032100e-02,3.234300e-02, & - &1.880900e-02,4.534000e-01,2.508000e-01,2.379200e-01,2.176600e-01, & - &1.927100e-01,1.652500e-01,1.352100e-01,1.025300e-01,6.604600e-02, & - &3.653600e-02,2.193100e-02,4.792100e-01,2.520400e-01,2.427700e-01, & - &2.235500e-01,1.994800e-01,1.725200e-01,1.425800e-01,1.095200e-01, & - &7.218000e-02,4.102500e-02,2.536800e-02,5.064100e-01,2.534600e-01, & - &2.476100e-01,2.293600e-01,2.063200e-01,1.798500e-01,1.500600e-01, & - &1.169000e-01,7.851700e-02,4.582500e-02,2.915800e-02,5.354200e-01, & - &2.110400e-01,1.953900e-01,1.759100e-01,1.539600e-01,1.299900e-01, & - &1.044800e-01,7.729800e-02,4.796200e-02,2.527500e-02,1.436000e-02, & - &3.624500e-01,2.130600e-01,2.002700e-01,1.818600e-01,1.601000e-01, & - &1.362200e-01,1.106300e-01,8.288800e-02,5.254500e-02,2.868500e-02, & - &1.693000e-02,3.827500e-01,2.146900e-01,2.049600e-01,1.874200e-01, & - &1.661200e-01,1.426700e-01,1.169300e-01,8.883200e-02,5.752500e-02, & - &3.237800e-02,1.976200e-02,4.042400e-01,2.164400e-01,2.096100e-01, & - &1.928500e-01,1.722200e-01,1.491900e-01,1.233900e-01,9.499600e-02, & - &6.283200e-02,3.634600e-02,2.288500e-02,4.276100e-01,2.181200e-01, & - &2.142800e-01,1.985300e-01,1.787700e-01,1.558600e-01,1.301400e-01, & - &1.013800e-01,6.837100e-02,4.059000e-02,2.630500e-02,4.522400e-01/ - data absa(1:330,9) / & - &1.001230e+00,9.047998e-01,8.243523e-01,7.448547e-01,6.663119e-01, & - &5.894117e-01,5.206426e-01,4.969842e-01,5.243000e-01,5.405233e-01, & - &5.536668e-01,9.929694e-01,9.067916e-01,8.330202e-01,7.634397e-01, & - &6.940293e-01,6.269872e-01,5.772082e-01,5.798403e-01,6.206807e-01, & - &6.400254e-01,6.553649e-01,9.849532e-01,9.069810e-01,8.423345e-01, & - &7.826363e-01,7.226778e-01,6.694484e-01,6.425208e-01,6.704811e-01, & - &7.244539e-01,7.470390e-01,7.642683e-01,9.766880e-01,9.062692e-01, & - &8.529756e-01,8.022612e-01,7.542766e-01,7.163574e-01,7.162810e-01, & - &7.689425e-01,8.349071e-01,8.609433e-01,8.799664e-01,9.680461e-01, & - &9.058926e-01,8.634133e-01,8.240095e-01,7.888430e-01,7.700292e-01, & - &7.972474e-01,8.742263e-01,9.513117e-01,9.812464e-01,1.002228e+00, & - &1.051583e+00,9.473853e-01,8.598140e-01,7.735065e-01,6.812513e-01, & - &5.903308e-01,5.021912e-01,4.492467e-01,4.603453e-01,4.746874e-01, & - &4.840078e-01,1.043570e+00,9.492447e-01,8.691988e-01,7.909397e-01, & - &7.066475e-01,6.241295e-01,5.512666e-01,5.237752e-01,5.503139e-01, & - &5.675399e-01,5.784861e-01,1.035386e+00,9.498742e-01,8.798004e-01, & - &8.082490e-01,7.336754e-01,6.618265e-01,6.086799e-01,6.074970e-01, & - &6.481102e-01,6.685478e-01,6.810911e-01,1.027107e+00,9.500450e-01, & - &8.903602e-01,8.266678e-01,7.638195e-01,7.040015e-01,6.740928e-01, & - &6.984681e-01,7.523944e-01,7.762994e-01,7.909532e-01,1.018306e+00, & - &9.508145e-01,9.001257e-01,8.472073e-01,7.955312e-01,7.516931e-01, & - &7.473260e-01,7.967227e-01,8.628037e-01,8.902713e-01,9.069683e-01, & - &1.105222e+00,9.913452e-01,8.950021e-01,7.980484e-01,6.956133e-01, & - &5.896888e-01,4.824903e-01,3.980440e-01,3.852786e-01,3.968384e-01, & - &4.016628e-01,1.097402e+00,9.931620e-01,9.046211e-01,8.169588e-01, & - &7.188604e-01,6.200704e-01,5.237843e-01,4.611503e-01,4.660974e-01, & - &4.805295e-01,4.863888e-01,1.089266e+00,9.945768e-01,9.161980e-01, & - &8.331898e-01,7.440003e-01,6.534880e-01,5.720078e-01,5.338788e-01, & - &5.550229e-01,5.723265e-01,5.793480e-01,1.080891e+00,9.954436e-01, & - &9.281839e-01,8.504552e-01,7.714905e-01,6.907075e-01,6.283032e-01, & - &6.151444e-01,6.509701e-01,6.714902e-01,6.796992e-01,1.072000e+00, & - &9.970731e-01,9.379747e-01,8.701270e-01,8.007426e-01,7.325703e-01, & - &6.922748e-01,7.038437e-01,7.533685e-01,7.772139e-01,7.867031e-01, & - &1.161088e+00,1.037446e+00,9.315758e-01,8.235750e-01,7.120104e-01, & - &5.927111e-01,4.690657e-01,3.559514e-01,3.167361e-01,3.240081e-01, & - &3.265769e-01,1.153660e+00,1.039216e+00,9.414725e-01,8.431550e-01, & - &7.350484e-01,6.198527e-01,5.041485e-01,4.082072e-01,3.871817e-01, & - &3.979467e-01,4.010964e-01,1.145914e+00,1.041466e+00,9.532853e-01, & - &8.607233e-01,7.578284e-01,6.500431e-01,5.448648e-01,4.694425e-01, & - &4.657505e-01,4.797700e-01,4.836293e-01,1.137585e+00,1.043045e+00, & - &9.663877e-01,8.781799e-01,7.827197e-01,6.833981e-01,5.914055e-01, & - &5.387069e-01,5.514298e-01,5.685959e-01,5.731877e-01,1.128758e+00, & - &1.044901e+00,9.773927e-01,8.967662e-01,8.095436e-01,7.202522e-01, & - &6.449317e-01,6.153927e-01,6.439694e-01,6.643631e-01,6.697842e-01, & - &1.218522e+00,1.085524e+00,9.696453e-01,8.506402e-01,7.291014e-01, & - &6.000631e-01,4.628755e-01,3.253317e-01,2.600542e-01,2.606418e-01, & - &2.622248e-01,1.212018e+00,1.087897e+00,9.799280e-01,8.699472e-01, & - &7.524652e-01,6.264417e-01,4.929949e-01,3.679693e-01,3.195102e-01, & - &3.251966e-01,3.271886e-01,1.204720e+00,1.090754e+00,9.917238e-01, & - &8.884435e-01,7.756851e-01,6.537907e-01,5.276607e-01,4.186922e-01, & - &3.873419e-01,3.970827e-01,3.995866e-01,1.196761e+00,1.092662e+00, & - &1.005207e+00,9.068292e-01,7.999556e-01,6.836105e-01,5.671797e-01, & - &4.763870e-01,4.622235e-01,4.756081e-01,4.786428e-01,1.188059e+00, & - &1.094737e+00,1.017649e+00,9.261506e-01,8.255532e-01,7.157081e-01, & - &6.114673e-01,5.411983e-01,5.441623e-01,5.608968e-01,5.644363e-01, & - &1.275468e+00,1.133326e+00,1.006932e+00,8.767711e-01,7.446285e-01, & - &6.062720e-01,4.600572e-01,3.030636e-01,2.134631e-01,2.044879e-01, & - &2.060970e-01,1.269584e+00,1.135996e+00,1.017553e+00,8.954340e-01, & - &7.676721e-01,6.325114e-01,4.882411e-01,3.375814e-01,2.620989e-01, & - &2.594417e-01,2.612827e-01,1.262856e+00,1.139295e+00,1.029050e+00, & - &9.145176e-01,7.912258e-01,6.597955e-01,5.184113e-01,3.785164e-01, & - &3.185527e-01,3.216737e-01,3.237034e-01,1.255100e+00,1.141742e+00, & - &1.042380e+00,9.339231e-01,8.155763e-01,6.890302e-01,5.517772e-01, & - &4.262050e-01,3.825575e-01,3.905323e-01,3.929002e-01,1.246377e+00, & - &1.144041e+00,1.055960e+00,9.537797e-01,8.417635e-01,7.190859e-01, & - &5.894883e-01,4.801363e-01,4.535688e-01,4.655652e-01,4.683143e-01/ - data absa(331:715,9) / & - &1.318749e+00,1.169990e+00,1.034884e+00,8.955747e-01,7.545506e-01, & - &6.085155e-01,4.553291e-01,2.892975e-01,1.777986e-01,1.578816e-01, & - &1.732673e-01,1.313696e+00,1.172911e+00,1.045704e+00,9.135334e-01, & - &7.775525e-01,6.346813e-01,4.829929e-01,3.172033e-01,2.167437e-01, & - &2.036318e-01,2.159393e-01,1.307474e+00,1.176450e+00,1.057020e+00, & - &9.332221e-01,8.019735e-01,6.620300e-01,5.122049e-01,3.505229e-01, & - &2.626522e-01,2.561909e-01,2.656306e-01,1.299696e+00,1.179669e+00, & - &1.070385e+00,9.537685e-01,8.270320e-01,6.910292e-01,5.432732e-01, & - &3.891972e-01,3.157403e-01,3.154009e-01,3.224394e-01,1.291662e+00, & - &1.182450e+00,1.084728e+00,9.745836e-01,8.533064e-01,7.214585e-01, & - &5.758218e-01,4.329491e-01,3.754822e-01,3.804399e-01,3.858327e-01, & - &1.345204e+00,1.192139e+00,1.050327e+00,9.052625e-01,7.577781e-01, & - &6.066602e-01,4.481589e-01,2.777299e-01,1.518667e-01,1.209752e-01, & - &1.982580e-01,1.341460e+00,1.196030e+00,1.062254e+00,9.229974e-01, & - &7.813470e-01,6.327208e-01,4.753336e-01,3.031471e-01,1.820996e-01, & - &1.579096e-01,2.289879e-01,1.335521e+00,1.199799e+00,1.074018e+00, & - &9.436261e-01,8.061754e-01,6.606253e-01,5.036677e-01,3.309146e-01, & - &2.188678e-01,2.014318e-01,2.658931e-01,1.328833e+00,1.204321e+00, & - &1.087544e+00,9.646592e-01,8.320160e-01,6.894482e-01,5.338553e-01, & - &3.627509e-01,2.620872e-01,2.512505e-01,3.089375e-01,1.321978e+00, & - &1.208364e+00,1.102796e+00,9.864269e-01,8.588256e-01,7.196557e-01, & - &5.654644e-01,3.988452e-01,3.116522e-01,3.068820e-01,3.581311e-01, & - &1.359583e+00,1.203778e+00,1.057200e+00,9.076842e-01,7.553108e-01, & - &6.001868e-01,4.383838e-01,2.659975e-01,1.338351e-01,9.290449e-02, & - &4.467883e-01,1.356524e+00,1.208284e+00,1.069659e+00,9.253738e-01, & - &7.786838e-01,6.258733e-01,4.651322e-01,2.898695e-01,1.571662e-01, & - &1.218960e-01,4.874322e-01,1.351229e+00,1.212483e+00,1.081475e+00, & - &9.456097e-01,8.034058e-01,6.537558e-01,4.930745e-01,3.155466e-01, & - &1.859315e-01,1.569545e-01,5.304906e-01,1.345477e+00,1.218021e+00, & - &1.095410e+00,9.668609e-01,8.295224e-01,6.827835e-01,5.223774e-01, & - &3.434430e-01,2.204980e-01,1.979820e-01,5.768373e-01,1.339095e+00, & - &1.223294e+00,1.111318e+00,9.892784e-01,8.568878e-01,7.126575e-01, & - &5.527574e-01,3.739418e-01,2.611902e-01,2.449746e-01,6.254572e-01, & - &1.353471e+00,1.197986e+00,1.050475e+00,8.997557e-01,7.460524e-01, & - &5.897154e-01,4.267969e-01,2.545097e-01,1.222832e-01,7.403302e-02, & - &1.454513e+00,1.350240e+00,1.202643e+00,1.062922e+00,9.172672e-01, & - &7.691012e-01,6.148679e-01,4.526319e-01,2.773691e-01,1.412275e-01, & - &9.684871e-02,1.498699e+00,1.345559e+00,1.207625e+00,1.075098e+00, & - &9.374524e-01,7.935848e-01,6.420461e-01,4.801219e-01,3.014644e-01, & - &1.643463e-01,1.249683e-01,1.551006e+00,1.340010e+00,1.213975e+00, & - &1.089725e+00,9.592615e-01,8.197091e-01,6.706727e-01,5.086682e-01, & - &3.276687e-01,1.922864e-01,1.585041e-01,1.608760e+00,1.334105e+00, & - &1.219876e+00,1.106431e+00,9.821705e-01,8.470313e-01,7.001703e-01, & - &5.382823e-01,3.559282e-01,2.254882e-01,1.976266e-01,1.671405e+00, & - &1.324808e+00,1.175644e+00,1.033759e+00,8.868880e-01,7.375333e-01, & - &5.840220e-01,4.231147e-01,2.514569e-01,1.195307e-01,6.820526e-02, & - &2.155035e+00,1.321031e+00,1.181100e+00,1.046327e+00,9.054400e-01, & - &7.609755e-01,6.092040e-01,4.488181e-01,2.737274e-01,1.374436e-01, & - &8.797865e-02,2.190401e+00,1.316364e+00,1.187414e+00,1.059760e+00, & - &9.270183e-01,7.861538e-01,6.367103e-01,4.758154e-01,2.974575e-01, & - &1.585259e-01,1.125315e-01,2.240888e+00,1.311454e+00,1.194536e+00, & - &1.076132e+00,9.496547e-01,8.130044e-01,6.652381e-01,5.037276e-01, & - &3.228872e-01,1.833624e-01,1.419398e-01,2.303940e+00,1.306489e+00, & - &1.202057e+00,1.094180e+00,9.733384e-01,8.407326e-01,6.946938e-01, & - &5.326120e-01,3.506249e-01,2.125692e-01,1.762040e-01,2.375824e+00, & - &1.270240e+00,1.130679e+00,9.972242e-01,8.573902e-01,7.151610e-01, & - &5.673999e-01,4.123296e-01,2.451761e-01,1.158713e-01,6.363084e-02, & - &2.391905e+00,1.266593e+00,1.137652e+00,1.010193e+00,8.771996e-01, & - &7.388999e-01,5.927191e-01,4.377685e-01,2.666423e-01,1.330374e-01, & - &8.069032e-02,2.427410e+00,1.263005e+00,1.145781e+00,1.025480e+00, & - &8.993564e-01,7.642425e-01,6.203175e-01,4.642512e-01,2.897025e-01, & - &1.526926e-01,1.018823e-01,2.483382e+00,1.259447e+00,1.154286e+00, & - &1.043632e+00,9.227133e-01,7.913855e-01,6.489205e-01,4.916517e-01, & - &3.147320e-01,1.752426e-01,1.275203e-01,2.552982e+00,1.255486e+00, & - &1.163123e+00,1.062544e+00,9.469973e-01,8.196601e-01,6.784650e-01, & - &5.198903e-01,3.418997e-01,2.007924e-01,1.570676e-01,2.630991e+00, & - &1.184292e+00,1.058697e+00,9.362252e-01,8.074638e-01,6.753410e-01, & - &5.367622e-01,3.914167e-01,2.336474e-01,1.107028e-01,5.972873e-02, & - &2.068657e+00,1.182286e+00,1.067924e+00,9.507092e-01,8.283165e-01, & - &6.988096e-01,5.619774e-01,4.160124e-01,2.544320e-01,1.270551e-01, & - &7.442819e-02,2.113539e+00,1.180216e+00,1.077590e+00,9.679323e-01, & - &8.505590e-01,7.243398e-01,5.890899e-01,4.418715e-01,2.768978e-01, & - &1.455073e-01,9.272709e-02,2.174478e+00,1.177549e+00,1.086825e+00, & - &9.865958e-01,8.742344e-01,7.513046e-01,6.173752e-01,4.689755e-01, & - &3.012504e-01,1.662861e-01,1.145755e-01,2.244855e+00,1.175525e+00, & - &1.097678e+00,1.006119e+00,8.987833e-01,7.794309e-01,6.462642e-01, & - &4.972391e-01,3.275990e-01,1.890999e-01,1.398912e-01,2.325516e+00/ - data absa(1:330,10) / & - &1.811894e+00,1.635296e+00,1.534525e+00,1.449204e+00,1.387757e+00, & - &1.435300e+00,1.659850e+00,1.922041e+00,2.099463e+00,2.158216e+00, & - &2.157325e+00,1.767936e+00,1.605388e+00,1.558834e+00,1.491395e+00, & - &1.504883e+00,1.671989e+00,1.974787e+00,2.289131e+00,2.501675e+00, & - &2.571459e+00,2.567607e+00,1.729674e+00,1.593962e+00,1.577350e+00, & - &1.561894e+00,1.667757e+00,1.941481e+00,2.310214e+00,2.679792e+00, & - &2.929397e+00,3.012191e+00,3.007041e+00,1.696394e+00,1.600219e+00, & - &1.596936e+00,1.658197e+00,1.857023e+00,2.226432e+00,2.651493e+00, & - &3.075815e+00,3.363123e+00,3.459301e+00,3.460342e+00,1.666435e+00, & - &1.611536e+00,1.635322e+00,1.767036e+00,2.064962e+00,2.518609e+00, & - &2.999175e+00,3.479090e+00,3.804177e+00,3.914594e+00,3.925195e+00, & - &1.941752e+00,1.744464e+00,1.614938e+00,1.493491e+00,1.411810e+00, & - &1.399161e+00,1.576191e+00,1.824441e+00,1.992481e+00,2.048986e+00, & - &2.059187e+00,1.899204e+00,1.713163e+00,1.628005e+00,1.539897e+00, & - &1.525612e+00,1.623941e+00,1.894695e+00,2.194509e+00,2.397804e+00, & - &2.466702e+00,2.479714e+00,1.862831e+00,1.698593e+00,1.634924e+00, & - &1.616571e+00,1.668278e+00,1.880935e+00,2.224522e+00,2.577600e+00, & - &2.817295e+00,2.899351e+00,2.919001e+00,1.829236e+00,1.700812e+00, & - &1.657528e+00,1.708822e+00,1.836407e+00,2.159046e+00,2.567760e+00, & - &2.976144e+00,3.253420e+00,3.348995e+00,3.372286e+00,1.797334e+00, & - &1.706764e+00,1.705207e+00,1.802871e+00,2.025436e+00,2.445951e+00, & - &2.910376e+00,3.374552e+00,3.689861e+00,3.798460e+00,3.825930e+00, & - &2.118327e+00,1.890177e+00,1.713787e+00,1.556665e+00,1.416645e+00, & - &1.343721e+00,1.426700e+00,1.640665e+00,1.791647e+00,1.843926e+00, & - &1.861060e+00,2.075006e+00,1.858013e+00,1.720097e+00,1.582549e+00, & - &1.521433e+00,1.529025e+00,1.722827e+00,1.993881e+00,2.178077e+00, & - &2.242606e+00,2.263858e+00,2.036857e+00,1.837306e+00,1.720520e+00, & - &1.651861e+00,1.641694e+00,1.756308e+00,2.042277e+00,2.364460e+00, & - &2.584086e+00,2.661540e+00,2.687481e+00,2.000233e+00,1.834388e+00, & - &1.731666e+00,1.740327e+00,1.782015e+00,2.011971e+00,2.376061e+00, & - &2.752469e+00,3.008386e+00,3.099252e+00,3.130271e+00,1.966721e+00, & - &1.831908e+00,1.775267e+00,1.824856e+00,1.947965e+00,2.285771e+00, & - &2.715459e+00,3.146462e+00,3.440088e+00,3.544669e+00,3.579498e+00, & - &2.339500e+00,2.077977e+00,1.849445e+00,1.644730e+00,1.436900e+00, & - &1.298070e+00,1.271433e+00,1.422190e+00,1.552360e+00,1.599404e+00, & - &1.614313e+00,2.295394e+00,2.043751e+00,1.848507e+00,1.653877e+00, & - &1.515429e+00,1.445971e+00,1.529792e+00,1.752122e+00,1.913545e+00, & - &1.971878e+00,1.990491e+00,2.252650e+00,2.014877e+00,1.842730e+00, & - &1.702602e+00,1.621586e+00,1.632151e+00,1.821114e+00,2.105859e+00, & - &2.300299e+00,2.370876e+00,2.393092e+00,2.211639e+00,2.004346e+00, & - &1.841543e+00,1.772564e+00,1.741539e+00,1.853628e+00,2.141716e+00, & - &2.479449e+00,2.709691e+00,2.792597e+00,2.819664e+00,2.174280e+00, & - &1.997747e+00,1.871802e+00,1.848148e+00,1.878049e+00,2.102562e+00, & - &2.475490e+00,2.866668e+00,3.133453e+00,3.229565e+00,3.260476e+00, & - &2.574707e+00,2.280675e+00,2.005849e+00,1.764331e+00,1.500260e+00, & - &1.284638e+00,1.153728e+00,1.215209e+00,1.325991e+00,1.366203e+00, & - &1.378209e+00,2.528479e+00,2.245872e+00,2.006644e+00,1.763756e+00, & - &1.556956e+00,1.399693e+00,1.365581e+00,1.517974e+00,1.657063e+00, & - &1.707771e+00,1.722583e+00,2.484792e+00,2.212572e+00,1.999468e+00, & - &1.796297e+00,1.634163e+00,1.548668e+00,1.621759e+00,1.849688e+00, & - &2.019994e+00,2.082371e+00,2.100585e+00,2.442458e+00,2.198178e+00, & - &1.991724e+00,1.852151e+00,1.734096e+00,1.729073e+00,1.911803e+00, & - &2.206133e+00,2.410177e+00,2.484570e+00,2.506469e+00,2.404297e+00, & - &2.189308e+00,2.009465e+00,1.908593e+00,1.850594e+00,1.948687e+00, & - &2.232731e+00,2.584224e+00,2.823781e+00,2.910921e+00,2.936850e+00, & - &2.803788e+00,2.478899e+00,2.164220e+00,1.898431e+00,1.596125e+00, & - &1.321657e+00,1.088175e+00,1.024689e+00,1.105512e+00,1.139354e+00, & - &1.148466e+00,2.762066e+00,2.448772e+00,2.172938e+00,1.901088e+00, & - &1.644028e+00,1.403143e+00,1.243038e+00,1.290609e+00,1.406776e+00, & - &1.450407e+00,1.461660e+00,2.718198e+00,2.415930e+00,2.173131e+00, & - &1.925867e+00,1.702509e+00,1.517259e+00,1.451524e+00,1.596966e+00, & - &1.743167e+00,1.797312e+00,1.811850e+00,2.678578e+00,2.400573e+00, & - &2.169829e+00,1.973367e+00,1.782068e+00,1.656123e+00,1.704788e+00, & - &1.930910e+00,2.108407e+00,2.174689e+00,2.192717e+00,2.643561e+00, & - &2.397907e+00,2.182213e+00,2.019990e+00,1.874640e+00,1.831681e+00, & - &1.994063e+00,2.292534e+00,2.505489e+00,2.583837e+00,2.606327e+00/ - data absa(331:715,10) / & - &3.040513e+00,2.682719e+00,2.333139e+00,2.041076e+00,1.706307e+00, & - &1.391230e+00,1.077770e+00,8.739367e-01,9.085562e-01,9.368150e-01, & - &9.441550e-01,3.002718e+00,2.659680e+00,2.350856e+00,2.051966e+00, & - &1.751372e+00,1.457885e+00,1.191019e+00,1.096046e+00,1.177372e+00, & - &1.214374e+00,1.223615e+00,2.965691e+00,2.633399e+00,2.360123e+00, & - &2.074724e+00,1.809377e+00,1.542646e+00,1.343568e+00,1.362426e+00, & - &1.482817e+00,1.529917e+00,1.541625e+00,2.933126e+00,2.619911e+00, & - &2.362913e+00,2.121364e+00,1.875819e+00,1.651588e+00,1.538061e+00, & - &1.665222e+00,1.819469e+00,1.877850e+00,1.892147e+00,2.900681e+00, & - &2.622276e+00,2.373930e+00,2.168984e+00,1.949275e+00,1.785516e+00, & - &1.786619e+00,2.004027e+00,2.191640e+00,2.261561e+00,2.279582e+00, & - &3.291495e+00,2.898140e+00,2.520051e+00,2.192268e+00,1.826723e+00, & - &1.466514e+00,1.112512e+00,7.855716e-01,7.367958e-01,7.601731e-01, & - &7.665286e-01,3.258322e+00,2.883153e+00,2.537624e+00,2.214602e+00, & - &1.868861e+00,1.535287e+00,1.193651e+00,9.513689e-01,9.766626e-01, & - &1.007772e+00,1.015532e+00,3.229896e+00,2.866256e+00,2.559797e+00, & - &2.236225e+00,1.929129e+00,1.608882e+00,1.309274e+00,1.172428e+00, & - &1.251251e+00,1.291512e+00,1.301329e+00,3.203398e+00,2.856151e+00, & - &2.571329e+00,2.281141e+00,1.995578e+00,1.694722e+00,1.458570e+00, & - &1.436895e+00,1.559105e+00,1.609390e+00,1.621652e+00,3.174741e+00, & - &2.863154e+00,2.582655e+00,2.331560e+00,2.065813e+00,1.802236e+00, & - &1.646769e+00,1.739240e+00,1.899546e+00,1.961338e+00,1.975925e+00, & - &3.542773e+00,3.110791e+00,2.706983e+00,2.339706e+00,1.947343e+00, & - &1.548048e+00,1.155545e+00,7.441336e-01,5.895474e-01,6.035634e-01, & - &1.529067e+00,3.520117e+00,3.107968e+00,2.726242e+00,2.373598e+00, & - &1.990144e+00,1.621302e+00,1.229019e+00,8.665325e-01,7.963437e-01, & - &8.212072e-01,1.649342e+00,3.502439e+00,3.104771e+00,2.763381e+00, & - &2.401435e+00,2.055621e+00,1.692822e+00,1.322399e+00,1.034849e+00, & - &1.041425e+00,1.075427e+00,1.789550e+00,3.482621e+00,3.100645e+00, & - &2.783538e+00,2.450205e+00,2.123930e+00,1.773657e+00,1.438631e+00, & - &1.250308e+00,1.319641e+00,1.362853e+00,1.941786e+00,3.457697e+00, & - &3.108363e+00,2.799309e+00,2.507065e+00,2.193423e+00,1.864298e+00, & - &1.587399e+00,1.508848e+00,1.625717e+00,1.679297e+00,2.121413e+00, & - &3.802312e+00,3.333764e+00,2.900493e+00,2.493119e+00,2.067159e+00, & - &1.630245e+00,1.204192e+00,7.431698e-01,4.885336e-01,4.845547e-01, & - &6.161865e+00,3.796851e+00,3.344754e+00,2.928618e+00,2.537048e+00, & - &2.112910e+00,1.705431e+00,1.278389e+00,8.375580e-01,6.591491e-01, & - &6.733317e-01,6.322041e+00,3.789855e+00,3.352791e+00,2.974719e+00, & - &2.572576e+00,2.181617e+00,1.780938e+00,1.364056e+00,9.690453e-01, & - &8.691469e-01,8.959289e-01,6.471008e+00,3.776169e+00,3.357049e+00, & - &3.002459e+00,2.625036e+00,2.253793e+00,1.863572e+00,1.468106e+00, & - &1.136632e+00,1.114766e+00,1.151897e+00,6.670895e+00,3.759106e+00, & - &3.370341e+00,3.022501e+00,2.684600e+00,2.328042e+00,1.954894e+00, & - &1.590226e+00,1.344347e+00,1.391217e+00,1.437929e+00,6.908157e+00, & - &4.087570e+00,3.586055e+00,3.123293e+00,2.680726e+00,2.212627e+00, & - &1.744112e+00,1.281172e+00,7.861196e-01,4.766076e-01,4.525195e-01, & - &1.050120e+01,4.094522e+00,3.605792e+00,3.169850e+00,2.730547e+00, & - &2.271578e+00,1.824171e+00,1.358582e+00,8.814230e-01,6.240388e-01, & - &6.262777e-01,1.070390e+01,4.092491e+00,3.619120e+00,3.217904e+00, & - &2.774324e+00,2.346660e+00,1.903116e+00,1.452474e+00,9.959000e-01, & - &8.118581e-01,8.320612e-01,1.088495e+01,4.082211e+00,3.634975e+00, & - &3.242908e+00,2.834274e+00,2.418846e+00,1.991527e+00,1.560048e+00, & - &1.142582e+00,1.037149e+00,1.070000e+00,1.104605e+01,4.069757e+00, & - &3.657602e+00,3.272212e+00,2.895810e+00,2.495497e+00,2.088542e+00, & - &1.680545e+00,1.321088e+00,1.293925e+00,1.337752e+00,1.125000e+01, & - &4.368044e+00,3.834904e+00,3.345190e+00,2.868751e+00,2.361576e+00, & - &1.862681e+00,1.356466e+00,8.274310e-01,4.685388e-01,4.159727e-01, & - &1.317607e+01,4.379128e+00,3.856118e+00,3.403616e+00,2.920481e+00, & - &2.432513e+00,1.946883e+00,1.437589e+00,9.223832e-01,5.940416e-01, & - &5.747305e-01,1.338642e+01,4.379660e+00,3.873723e+00,3.446891e+00, & - &2.974180e+00,2.512922e+00,2.029051e+00,1.537107e+00,1.031779e+00, & - &7.573509e-01,7.638028e-01,1.357253e+01,4.375120e+00,3.903472e+00, & - &3.478307e+00,3.042746e+00,2.589498e+00,2.121786e+00,1.647118e+00, & - &1.157305e+00,9.571216e-01,9.811245e-01,1.372881e+01,4.364407e+00, & - &3.934252e+00,3.519457e+00,3.110929e+00,2.669822e+00,2.221949e+00, & - &1.767850e+00,1.309596e+00,1.193405e+00,1.230686e+00,1.392206e+01, & - &4.580161e+00,4.024466e+00,3.521888e+00,3.015828e+00,2.484824e+00, & - &1.964621e+00,1.423076e+00,8.632280e-01,4.630468e-01,3.769406e-01, & - &1.270406e+01,4.593265e+00,4.046447e+00,3.585392e+00,3.071330e+00, & - &2.565282e+00,2.049582e+00,1.512172e+00,9.580703e-01,5.693308e-01, & - &5.199792e-01,1.290876e+01,4.598585e+00,4.075277e+00,3.629773e+00, & - &3.140009e+00,2.648664e+00,2.140203e+00,1.615637e+00,1.062108e+00, & - &7.079140e-01,6.905936e-01,1.306701e+01,4.596727e+00,4.117485e+00, & - &3.671636e+00,3.215034e+00,2.734897e+00,2.240864e+00,1.725621e+00, & - &1.176403e+00,8.819201e-01,8.905582e-01,1.324214e+01,4.584716e+00, & - &4.146667e+00,3.723243e+00,3.288554e+00,2.824713e+00,2.347562e+00, & - &1.843735e+00,1.307610e+00,1.092147e+00,1.118911e+00,1.346486e+01/ - data absa(1:330,11) / & - &2.641410e+00,2.367703e+00,2.161514e+00,2.266642e+00,2.693198e+00, & - &3.323366e+00,3.965131e+00,4.607984e+00,5.041282e+00,5.178355e+00, & - &5.138917e+00,2.583043e+00,2.347244e+00,2.228469e+00,2.549719e+00, & - &3.171013e+00,3.926727e+00,4.684662e+00,5.443134e+00,5.955358e+00, & - &6.117344e+00,6.073010e+00,2.526258e+00,2.321493e+00,2.358541e+00, & - &2.871974e+00,3.686826e+00,4.566129e+00,5.448391e+00,6.331264e+00, & - &6.927589e+00,7.114813e+00,7.063652e+00,2.470123e+00,2.295468e+00, & - &2.527064e+00,3.240894e+00,4.238084e+00,5.255157e+00,6.274913e+00, & - &7.293662e+00,7.981602e+00,8.195269e+00,8.122955e+00,2.414887e+00, & - &2.290831e+00,2.716019e+00,3.656278e+00,4.814993e+00,5.977907e+00, & - &7.141954e+00,8.305378e+00,9.090443e+00,9.333485e+00,9.238199e+00, & - &2.802552e+00,2.509352e+00,2.272540e+00,2.312961e+00,2.681450e+00, & - &3.282690e+00,3.918521e+00,4.554814e+00,4.983844e+00,5.119741e+00, & - &5.117843e+00,2.737856e+00,2.480284e+00,2.340297e+00,2.579807e+00, & - &3.152473e+00,3.903265e+00,4.661377e+00,5.419393e+00,5.930973e+00, & - &6.090262e+00,6.084837e+00,2.674299e+00,2.448399e+00,2.461442e+00, & - &2.892958e+00,3.687056e+00,4.577153e+00,5.468822e+00,6.360119e+00, & - &6.961525e+00,7.146904e+00,7.135563e+00,2.613662e+00,2.420843e+00, & - &2.612606e+00,3.260977e+00,4.257053e+00,5.288713e+00,6.321982e+00, & - &7.354073e+00,8.051201e+00,8.266913e+00,8.252913e+00,2.558024e+00, & - &2.419073e+00,2.783690e+00,3.689508e+00,4.865734e+00,6.048362e+00, & - &7.232163e+00,8.415207e+00,9.212727e+00,9.460327e+00,9.446997e+00, & - &2.985293e+00,2.672606e+00,2.401190e+00,2.351631e+00,2.609433e+00, & - &3.122010e+00,3.729503e+00,4.337313e+00,4.747193e+00,4.874308e+00, & - &4.907937e+00,2.924719e+00,2.644923e+00,2.462068e+00,2.590564e+00, & - &3.053891e+00,3.762630e+00,4.496848e+00,5.231016e+00,5.726257e+00, & - &5.879606e+00,5.920233e+00,2.864260e+00,2.612936e+00,2.564342e+00, & - &2.877936e+00,3.582337e+00,4.452358e+00,5.323307e+00,6.194060e+00, & - &6.781236e+00,6.963435e+00,7.011391e+00,2.808026e+00,2.583102e+00, & - &2.691563e+00,3.225545e+00,4.169782e+00,5.185909e+00,6.203142e+00, & - &7.219796e+00,7.905060e+00,8.117372e+00,8.171974e+00,2.754997e+00, & - &2.580931e+00,2.843585e+00,3.645844e+00,4.796494e+00,5.968403e+00, & - &7.141662e+00,8.313726e+00,9.103304e+00,9.347648e+00,9.411286e+00, & - &3.192096e+00,2.847085e+00,2.551322e+00,2.432535e+00,2.557254e+00, & - &2.934133e+00,3.495269e+00,4.066812e+00,4.452465e+00,4.573062e+00, & - &4.623832e+00,3.131487e+00,2.828041e+00,2.605053e+00,2.638881e+00, & - &2.963030e+00,3.574733e+00,4.275299e+00,4.974854e+00,5.447361e+00, & - &5.594831e+00,5.657253e+00,3.076643e+00,2.802309e+00,2.707172e+00, & - &2.888671e+00,3.458916e+00,4.275868e+00,5.115479e+00,5.954718e+00, & - &6.521073e+00,6.699556e+00,6.773235e+00,3.027775e+00,2.778458e+00, & - &2.814836e+00,3.208449e+00,4.039594e+00,5.028415e+00,6.017886e+00, & - &7.006801e+00,7.674083e+00,7.882135e+00,7.970282e+00,2.982600e+00, & - &2.777597e+00,2.942652e+00,3.605397e+00,4.681664e+00,5.830527e+00, & - &6.980057e+00,8.129187e+00,8.903493e+00,9.146729e+00,9.247998e+00, & - &3.470759e+00,3.076510e+00,2.752658e+00,2.553347e+00,2.546527e+00, & - &2.771718e+00,3.227627e+00,3.756643e+00,4.113952e+00,4.228211e+00, & - &4.280368e+00,3.411064e+00,3.063644e+00,2.785548e+00,2.734566e+00, & - &2.902387e+00,3.364168e+00,4.006888e+00,4.664565e+00,5.109128e+00, & - &5.251537e+00,5.316523e+00,3.357099e+00,3.041676e+00,2.884341e+00, & - &2.949855e+00,3.361999e+00,4.055295e+00,4.853975e+00,5.652040e+00, & - &6.191489e+00,6.364683e+00,6.442814e+00,3.310157e+00,3.021114e+00, & - &2.989108e+00,3.230130e+00,3.904107e+00,4.820685e+00,5.771630e+00, & - &6.722347e+00,7.364598e+00,7.570871e+00,7.664690e+00,3.268059e+00, & - &3.023612e+00,3.096000e+00,3.597879e+00,4.526577e+00,5.636886e+00, & - &6.750733e+00,7.863629e+00,8.615932e+00,8.857615e+00,8.966446e+00, & - &3.864032e+00,3.403704e+00,3.034289e+00,2.724442e+00,2.589446e+00, & - &2.627054e+00,2.927309e+00,3.396476e+00,3.720694e+00,3.826234e+00, & - &3.874811e+00,3.798580e+00,3.391150e+00,3.038468e+00,2.887908e+00, & - &2.874359e+00,3.158167e+00,3.674087e+00,4.279371e+00,4.688387e+00, & - &4.821837e+00,4.882109e+00,3.747107e+00,3.375238e+00,3.117114e+00, & - &3.057941e+00,3.274999e+00,3.791608e+00,4.506527e+00,5.250257e+00, & - &5.752692e+00,5.917070e+00,5.991310e+00,3.701056e+00,3.355450e+00, & - &3.226116e+00,3.284904e+00,3.768766e+00,4.525150e+00,5.417589e+00, & - &6.312057e+00,6.916710e+00,7.114764e+00,7.202918e+00,3.657440e+00, & - &3.345358e+00,3.313718e+00,3.609778e+00,4.346844e+00,5.338227e+00, & - &6.394710e+00,7.450381e+00,8.165427e+00,8.400568e+00,8.503979e+00/ - data absa(331:715,11) / & - &4.359077e+00,3.822568e+00,3.392040e+00,2.966420e+00,2.721307e+00, & - &2.555605e+00,2.668760e+00,3.022967e+00,3.312400e+00,3.408378e+00, & - &3.450832e+00,4.293044e+00,3.804157e+00,3.375390e+00,3.110235e+00, & - &2.936087e+00,2.996109e+00,3.342393e+00,3.870561e+00,4.241940e+00, & - &4.365101e+00,4.419172e+00,4.236289e+00,3.791481e+00,3.432097e+00, & - &3.262492e+00,3.243783e+00,3.565453e+00,4.133653e+00,4.815223e+00, & - &5.277504e+00,5.430991e+00,5.497705e+00,4.183532e+00,3.771746e+00, & - &3.535401e+00,3.424353e+00,3.670370e+00,4.240435e+00,5.026970e+00, & - &5.857851e+00,6.420390e+00,6.607326e+00,6.688331e+00,4.132841e+00, & - &3.753080e+00,3.622388e+00,3.681313e+00,4.198599e+00,5.013320e+00, & - &5.993610e+00,6.984469e+00,7.655890e+00,7.880369e+00,7.976061e+00, & - &4.962179e+00,4.342451e+00,3.822249e+00,3.289048e+00,2.917126e+00, & - &2.581123e+00,2.447167e+00,2.643812e+00,2.894946e+00,2.980668e+00, & - &3.016204e+00,4.889687e+00,4.305562e+00,3.799595e+00,3.397712e+00, & - &3.101861e+00,2.927386e+00,3.060634e+00,3.462255e+00,3.794781e+00, & - &3.907374e+00,3.953979e+00,4.820759e+00,4.287156e+00,3.824606e+00, & - &3.543087e+00,3.329749e+00,3.401142e+00,3.783113e+00,4.368914e+00, & - &4.789298e+00,4.931317e+00,4.989753e+00,4.753397e+00,4.261742e+00, & - &3.911678e+00,3.680344e+00,3.665145e+00,4.008939e+00,4.621631e+00, & - &5.378761e+00,5.897216e+00,6.072434e+00,6.144428e+00,4.691499e+00, & - &4.234474e+00,4.000271e+00,3.872053e+00,4.112941e+00,4.720492e+00, & - &5.566260e+00,6.487401e+00,7.112051e+00,7.324079e+00,7.411915e+00, & - &5.651992e+00,4.945728e+00,4.320337e+00,3.686676e+00,3.175923e+00, & - &2.691866e+00,2.314459e+00,2.288423e+00,2.474989e+00,2.550081e+00, & - &2.913781e+00,5.572107e+00,4.888690e+00,4.297561e+00,3.758957e+00, & - &3.339642e+00,2.949696e+00,2.819469e+00,3.038759e+00,3.324232e+00, & - &3.425035e+00,3.621082e+00,5.487609e+00,4.853045e+00,4.295716e+00, & - &3.895741e+00,3.526752e+00,3.338480e+00,3.468860e+00,3.910423e+00, & - &4.287126e+00,4.416839e+00,4.513346e+00,5.409386e+00,4.820055e+00, & - &4.361885e+00,4.018967e+00,3.786137e+00,3.849782e+00,4.244906e+00, & - &4.887177e+00,5.358491e+00,5.519308e+00,5.587084e+00,5.340204e+00, & - &4.790142e+00,4.450875e+00,4.172113e+00,4.148256e+00,4.483915e+00, & - &5.133242e+00,5.965070e+00,6.539806e+00,6.736813e+00,6.818452e+00, & - &6.400160e+00,5.600347e+00,4.863749e+00,4.149252e+00,3.505992e+00, & - &2.887240e+00,2.310353e+00,2.031742e+00,2.125689e+00,2.191341e+00, & - &1.060835e+01,6.312964e+00,5.529978e+00,4.850890e+00,4.200175e+00, & - &3.651103e+00,3.096438e+00,2.712988e+00,2.700004e+00,2.918533e+00, & - &3.008423e+00,1.096462e+01,6.228127e+00,5.487247e+00,4.845156e+00, & - &4.317313e+00,3.815631e+00,3.403076e+00,3.266944e+00,3.511537e+00, & - &3.840473e+00,3.958896e+00,1.137606e+01,6.147034e+00,5.449962e+00, & - &4.891618e+00,4.436514e+00,4.033464e+00,3.832637e+00,3.964761e+00, & - &4.455558e+00,4.885997e+00,5.036009e+00,1.168138e+01,6.071448e+00, & - &5.415889e+00,4.977476e+00,4.566355e+00,4.330947e+00,4.390082e+00, & - &4.804681e+00,5.519471e+00,6.052611e+00,6.238091e+00,1.202270e+01, & - &7.174703e+00,6.278028e+00,5.448906e+00,4.668136e+00,3.946758e+00, & - &3.212459e+00,2.518147e+00,2.088877e+00,2.118597e+00,2.184655e+00, & - &2.011948e+01,7.090964e+00,6.215064e+00,5.442349e+00,4.748171e+00, & - &4.081978e+00,3.417158e+00,2.892469e+00,2.724684e+00,2.912465e+00, & - &3.003461e+00,2.048167e+01,7.008026e+00,6.175685e+00,5.466311e+00, & - &4.862252e+00,4.239940e+00,3.707633e+00,3.409544e+00,3.529440e+00, & - &3.840085e+00,3.959854e+00,2.092947e+01,6.928802e+00,6.137731e+00, & - &5.533383e+00,4.968771e+00,4.456701e+00,4.111576e+00,4.081971e+00, & - &4.476665e+00,4.901994e+00,5.053997e+00,2.146934e+01,6.852593e+00, & - &6.102623e+00,5.609060e+00,5.107600e+00,4.747663e+00,4.645196e+00, & - &4.904307e+00,5.559047e+00,6.096572e+00,6.284792e+00,2.188066e+01, & - &8.030228e+00,7.026688e+00,6.096825e+00,5.233011e+00,4.430374e+00, & - &3.568544e+00,2.753155e+00,2.159022e+00,2.104821e+00,2.169559e+00, & - &2.811190e+01,7.946468e+00,6.970268e+00,6.096506e+00,5.352442e+00, & - &4.557732e+00,3.768751e+00,3.103614e+00,2.763850e+00,2.892427e+00, & - &2.983607e+00,2.848196e+01,7.860143e+00,6.931134e+00,6.146779e+00, & - &5.467948e+00,4.711898e+00,4.052040e+00,3.588658e+00,3.543557e+00, & - &3.825181e+00,3.945245e+00,2.894543e+01,7.777241e+00,6.887237e+00, & - &6.241549e+00,5.562636e+00,4.923774e+00,4.433393e+00,4.233030e+00, & - &4.491793e+00,4.902647e+00,5.055562e+00,2.960152e+01,7.697483e+00, & - &6.853195e+00,6.305260e+00,5.697643e+00,5.216200e+00,4.944568e+00, & - &5.034230e+00,5.587162e+00,6.121396e+00,6.311235e+00,3.022405e+01, & - &8.930038e+00,7.815652e+00,6.780858e+00,5.835791e+00,4.944609e+00, & - &3.953085e+00,3.011222e+00,2.244061e+00,2.083908e+00,2.143058e+00, & - &3.010850e+01,8.840109e+00,7.760036e+00,6.786960e+00,5.980539e+00, & - &5.076521e+00,4.157312e+00,3.345096e+00,2.820256e+00,2.864547e+00, & - &2.954517e+00,3.050088e+01,8.751784e+00,7.720745e+00,6.857761e+00, & - &6.107007e+00,5.229319e+00,4.433004e+00,3.804988e+00,3.576454e+00, & - &3.802153e+00,3.921701e+00,3.108710e+01,8.667414e+00,7.674172e+00, & - &6.969258e+00,6.202563e+00,5.442583e+00,4.806755e+00,4.424791e+00, & - &4.511214e+00,4.891178e+00,5.044634e+00,3.183278e+01,8.579697e+00, & - &7.648601e+00,7.038163e+00,6.337715e+00,5.728338e+00,5.295632e+00, & - &5.202099e+00,5.609295e+00,6.129683e+00,6.321453e+00,3.247570e+01/ - data absa(1:330,12) / & - &3.482058e+00,3.063902e+00,4.534842e+00,6.797382e+00,9.059524e+00, & - &1.132183e+01,1.358322e+01,1.583863e+01,1.734648e+01,1.775133e+01, & - &1.720865e+01,3.430213e+00,3.185800e+00,5.300768e+00,7.945054e+00, & - &1.058902e+01,1.323237e+01,1.587610e+01,1.851222e+01,2.027712e+01, & - &2.075047e+01,2.013830e+01,3.376936e+00,3.397019e+00,6.075325e+00, & - &9.105340e+00,1.213611e+01,1.516452e+01,1.819155e+01,2.121674e+01, & - &2.323595e+01,2.378563e+01,2.310588e+01,3.328440e+00,3.661718e+00, & - &6.853461e+00,1.026901e+01,1.368413e+01,1.709882e+01,2.051039e+01, & - &2.391448e+01,2.619296e+01,2.681627e+01,2.607143e+01,3.283015e+00, & - &3.957615e+00,7.644366e+00,1.145068e+01,1.525791e+01,1.906201e+01, & - &2.286212e+01,2.665900e+01,2.919261e+01,2.987088e+01,2.900984e+01, & - &3.701517e+00,3.304986e+00,4.758239e+00,7.077006e+00,9.433357e+00, & - &1.178906e+01,1.414413e+01,1.648983e+01,1.806501e+01,1.850370e+01, & - &1.831041e+01,3.649543e+00,3.467621e+00,5.553440e+00,8.321801e+00, & - &1.109248e+01,1.386239e+01,1.663105e+01,1.939085e+01,2.124364e+01, & - &2.176255e+01,2.154107e+01,3.603812e+00,3.705379e+00,6.410166e+00, & - &9.605021e+00,1.279988e+01,1.599348e+01,1.918483e+01,2.236995e+01, & - &2.450408e+01,2.509769e+01,2.483424e+01,3.559867e+00,3.989665e+00, & - &7.302131e+00,1.093812e+01,1.457328e+01,1.820832e+01,2.183999e+01, & - &2.546793e+01,2.789340e+01,2.855959e+01,2.823026e+01,3.516532e+00, & - &4.302780e+00,8.218306e+00,1.230761e+01,1.639660e+01,2.048434e+01, & - &2.457008e+01,2.864935e+01,3.137356e+01,3.211569e+01,3.172569e+01, & - &4.061521e+00,3.591329e+00,4.839615e+00,6.991693e+00,9.319877e+00, & - &1.164685e+01,1.397422e+01,1.629549e+01,1.785313e+01,1.830175e+01, & - &1.839653e+01,3.980941e+00,3.730633e+00,5.624846e+00,8.347601e+00, & - &1.112426e+01,1.390011e+01,1.667420e+01,1.944331e+01,2.129988e+01, & - &2.182280e+01,2.193597e+01,3.917466e+00,3.965407e+00,6.530183e+00, & - &9.782525e+00,1.303473e+01,1.628604e+01,1.953523e+01,2.277882e+01, & - &2.495377e+01,2.555501e+01,2.568368e+01,3.861175e+00,4.258959e+00, & - &7.528945e+00,1.127654e+01,1.502405e+01,1.877119e+01,2.251758e+01, & - &2.625450e+01,2.875923e+01,2.945439e+01,2.959185e+01,3.808774e+00, & - &4.584143e+00,8.555746e+00,1.281379e+01,1.707188e+01,2.132785e+01, & - &2.558221e+01,2.982733e+01,3.267284e+01,3.346046e+01,3.361626e+01, & - &4.601066e+00,4.028019e+00,4.916484e+00,6.744320e+00,8.989356e+00, & - &1.123448e+01,1.348020e+01,1.572007e+01,1.722381e+01,1.766098e+01, & - &1.786641e+01,4.497872e+00,4.097763e+00,5.668565e+00,8.202510e+00, & - &1.092890e+01,1.365461e+01,1.637956e+01,1.909589e+01,2.092286e+01, & - &2.144656e+01,2.170144e+01,4.410797e+00,4.293808e+00,6.534183e+00, & - &9.770665e+00,1.301588e+01,1.626116e+01,1.950332e+01,2.274449e+01, & - &2.491100e+01,2.552637e+01,2.583428e+01,4.336166e+00,4.561200e+00, & - &7.629344e+00,1.142319e+01,1.521691e+01,1.900938e+01,2.279861e+01, & - &2.658337e+01,2.911894e+01,2.982159e+01,3.019157e+01,4.267582e+00, & - &4.878951e+00,8.775355e+00,1.313653e+01,1.749807e+01,2.186100e+01, & - &2.621841e+01,3.057049e+01,3.347925e+01,3.429470e+01,3.471670e+01, & - &5.282717e+00,4.622788e+00,5.110197e+00,6.530312e+00,8.620849e+00, & - &1.077375e+01,1.292560e+01,1.507338e+01,1.651678e+01,1.693423e+01, & - &1.718533e+01,5.155065e+00,4.608948e+00,5.807633e+00,8.015745e+00, & - &1.068063e+01,1.334542e+01,1.600904e+01,1.867055e+01,2.045194e+01, & - &2.096016e+01,2.127775e+01,5.048546e+00,4.757285e+00,6.605920e+00, & - &9.703171e+00,1.292781e+01,1.615186e+01,1.937403e+01,2.258798e+01, & - &2.474733e+01,2.535619e+01,2.574204e+01,4.954953e+00,4.993401e+00, & - &7.682308e+00,1.150353e+01,1.532349e+01,1.914570e+01,2.296555e+01, & - &2.677192e+01,2.932684e+01,3.004544e+01,3.049965e+01,4.867973e+00, & - &5.289378e+00,8.941955e+00,1.338838e+01,1.783513e+01,2.228050e+01, & - &2.672502e+01,3.115730e+01,3.412643e+01,3.496182e+01,3.550186e+01, & - &6.116804e+00,5.352514e+00,5.427417e+00,6.424881e+00,8.125905e+00, & - &1.015385e+01,1.217849e+01,1.420416e+01,1.555852e+01,1.595716e+01, & - &1.621304e+01,5.966189e+00,5.248962e+00,6.053852e+00,7.753258e+00, & - &1.030194e+01,1.287255e+01,1.544168e+01,1.800585e+01,1.972647e+01, & - &2.022136e+01,2.055169e+01,5.835868e+00,5.328300e+00,6.800551e+00, & - &9.536509e+00,1.270646e+01,1.587776e+01,1.904556e+01,2.220963e+01, & - &2.432839e+01,2.492912e+01,2.534691e+01,5.720572e+00,5.528318e+00, & - &7.728396e+00,1.148267e+01,1.529896e+01,1.911389e+01,2.292845e+01, & - &2.673616e+01,2.928876e+01,3.000911e+01,3.051235e+01,5.614621e+00, & - &5.803902e+00,9.039566e+00,1.353938e+01,1.803904e+01,2.253707e+01, & - &2.703413e+01,3.152296e+01,3.453139e+01,3.537835e+01,3.597136e+01/ - data absa(331:715,12) / & - &7.109128e+00,6.220767e+00,5.876245e+00,6.470729e+00,7.616146e+00, & - &9.443294e+00,1.133042e+01,1.321242e+01,1.447730e+01,1.484088e+01, & - &1.509410e+01,6.929915e+00,6.063960e+00,6.418471e+00,7.632360e+00, & - &9.831535e+00,1.228522e+01,1.473784e+01,1.718511e+01,1.883043e+01, & - &1.930449e+01,1.963486e+01,6.776254e+00,6.055463e+00,7.108500e+00, & - &9.303061e+00,1.238366e+01,1.547317e+01,1.856119e+01,2.164173e+01, & - &2.371370e+01,2.430745e+01,2.472514e+01,6.641516e+00,6.196003e+00, & - &7.933547e+00,1.138148e+01,1.516575e+01,1.894946e+01,2.273031e+01, & - &2.650432e+01,2.903964e+01,2.976220e+01,3.027943e+01,6.528252e+00, & - &6.431612e+00,9.148658e+00,1.360817e+01,1.813219e+01,2.265596e+01, & - &2.717647e+01,3.169464e+01,3.472071e+01,3.558644e+01,3.620721e+01, & - &8.244415e+00,7.214049e+00,6.507166e+00,6.668861e+00,7.301230e+00, & - &8.781542e+00,1.053522e+01,1.228732e+01,1.346281e+01,1.380658e+01, & - &1.404430e+01,8.039243e+00,7.034601e+00,6.937428e+00,7.702303e+00, & - &9.319942e+00,1.161011e+01,1.392982e+01,1.624553e+01,1.780010e+01, & - &1.825595e+01,1.856695e+01,7.876379e+00,6.945247e+00,7.554056e+00, & - &9.173166e+00,1.195853e+01,1.494370e+01,1.792674e+01,2.090692e+01, & - &2.290591e+01,2.349154e+01,2.389519e+01,7.743512e+00,7.022663e+00, & - &8.295646e+00,1.120239e+01,1.491075e+01,1.863144e+01,2.234963e+01, & - &2.606360e+01,2.855919e+01,2.928551e+01,2.979187e+01,7.625713e+00, & - &7.206706e+00,9.397627e+00,1.357410e+01,1.808989e+01,2.260343e+01, & - &2.711496e+01,3.162538e+01,3.465217e+01,3.553254e+01,3.614677e+01, & - &9.586704e+00,8.388608e+00,7.322348e+00,7.037199e+00,7.186309e+00, & - &8.171190e+00,9.755135e+00,1.137700e+01,1.246652e+01,1.278728e+01, & - &1.300866e+01,9.331771e+00,8.165419e+00,7.602248e+00,7.945800e+00, & - &8.966872e+00,1.095213e+01,1.314038e+01,1.532479e+01,1.679143e+01, & - &1.722287e+01,1.751988e+01,9.166145e+00,8.027064e+00,8.129784e+00, & - &9.212634e+00,1.144254e+01,1.428520e+01,1.713774e+01,1.998619e+01, & - &2.189875e+01,2.246356e+01,2.284596e+01,9.023109e+00,8.048354e+00, & - &8.815100e+00,1.108932e+01,1.447844e+01,1.809356e+01,2.170655e+01, & - &2.531282e+01,2.773609e+01,2.845792e+01,2.893873e+01,8.889849e+00, & - &8.178042e+00,9.777390e+00,1.342289e+01,1.784131e+01,2.229443e+01, & - &2.674693e+01,3.119159e+01,3.418079e+01,3.506886e+01,3.565952e+01, & - &1.121946e+01,9.816666e+00,8.429687e+00,7.628439e+00,7.384810e+00, & - &7.889982e+00,9.190550e+00,1.071937e+01,1.174564e+01,1.205326e+01, & - &1.581348e+01,1.090284e+01,9.540278e+00,8.508037e+00,8.404559e+00, & - &8.968774e+00,1.053461e+01,1.261983e+01,1.471855e+01,1.612694e+01, & - &1.655043e+01,1.857275e+01,1.067461e+01,9.340287e+00,8.894903e+00, & - &9.557405e+00,1.127894e+01,1.391875e+01,1.670145e+01,1.947667e+01, & - &2.134258e+01,2.189979e+01,2.262887e+01,1.049924e+01,9.275319e+00, & - &9.543817e+00,1.126678e+01,1.426194e+01,1.781610e+01,2.137466e+01, & - &2.492973e+01,2.731882e+01,2.803400e+01,2.850261e+01,1.033641e+01, & - &9.354157e+00,1.040183e+01,1.353845e+01,1.771301e+01,2.214017e+01, & - &2.656783e+01,3.097976e+01,3.394988e+01,3.484610e+01,3.541805e+01, & - &1.300541e+01,1.137976e+01,9.778574e+00,8.717909e+00,8.302053e+00, & - &8.788318e+00,1.009680e+01,1.177444e+01,1.290723e+01,1.324875e+01, & - &2.811818e+01,1.265644e+01,1.107428e+01,9.819186e+00,9.433456e+00, & - &1.003216e+01,1.162802e+01,1.387433e+01,1.618218e+01,1.773441e+01, & - &1.820239e+01,2.990474e+01,1.239365e+01,1.084456e+01,1.012535e+01, & - &1.067840e+01,1.251424e+01,1.528516e+01,1.833849e+01,2.138773e+01, & - &2.343848e+01,2.406086e+01,3.245377e+01,1.216456e+01,1.073986e+01, & - &1.075392e+01,1.254054e+01,1.566963e+01,1.950943e+01,2.340735e+01, & - &2.730092e+01,2.992167e+01,3.072041e+01,3.601427e+01,1.195714e+01, & - &1.078493e+01,1.171844e+01,1.491537e+01,1.933435e+01,2.416309e+01, & - &2.899011e+01,3.381153e+01,3.706068e+01,3.804819e+01,4.132218e+01, & - &1.507404e+01,1.318974e+01,1.134300e+01,1.002894e+01,9.352989e+00, & - &9.794012e+00,1.106488e+01,1.287964e+01,1.411906e+01,1.449720e+01, & - &4.126076e+01,1.470545e+01,1.286686e+01,1.137280e+01,1.063789e+01, & - &1.122527e+01,1.283027e+01,1.518110e+01,1.770629e+01,1.940834e+01, & - &1.993125e+01,4.276701e+01,1.439639e+01,1.259687e+01,1.163536e+01, & - &1.194025e+01,1.386402e+01,1.670838e+01,2.002528e+01,2.335611e+01, & - &2.559975e+01,2.629189e+01,4.488569e+01,1.411266e+01,1.245941e+01, & - &1.213828e+01,1.395446e+01,1.720533e+01,2.124242e+01,2.548691e+01, & - &2.972743e+01,3.258492e+01,3.346774e+01,4.741280e+01,1.385237e+01, & - &1.245807e+01,1.318681e+01,1.645596e+01,2.102937e+01,2.622472e+01, & - &3.146825e+01,3.670311e+01,4.023255e+01,4.133255e+01,5.111399e+01, & - &1.747895e+01,1.529366e+01,1.316096e+01,1.155178e+01,1.056292e+01, & - &1.090009e+01,1.209159e+01,1.399508e+01,1.534061e+01,1.576296e+01, & - &4.734796e+01,1.705676e+01,1.492454e+01,1.316884e+01,1.209497e+01, & - &1.251195e+01,1.410152e+01,1.647219e+01,1.921345e+01,2.106135e+01, & - &2.164129e+01,4.900891e+01,1.668398e+01,1.460019e+01,1.338835e+01, & - &1.337864e+01,1.533544e+01,1.818327e+01,2.167220e+01,2.528048e+01, & - &2.770932e+01,2.847827e+01,5.119700e+01,1.634145e+01,1.443357e+01, & - &1.383297e+01,1.550798e+01,1.880402e+01,2.293624e+01,2.751007e+01, & - &3.208808e+01,3.518002e+01,3.615547e+01,5.373973e+01,1.603160e+01, & - &1.438683e+01,1.484815e+01,1.812155e+01,2.280049e+01,2.825139e+01, & - &3.389766e+01,3.953983e+01,4.334372e+01,4.454290e+01,5.769435e+01/ - -! the array absb(235,NG09) = kb(5,13:59,NG09) contains absorption coefs -! at the NG09=12 chosen g-values for a range of pressure levels<~100mb -! and temperatures. the first index in the array, jt, which runs from -! 1 to 5, corresponds to different temperatures. more specifically, -! jt = 1-5 means that the data are for the corresponding temperature of -! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the -! second index, jp, runs from 13 to 59 and refers to the jpth reference -! pressure level (see taumol.f for the value of these pressure levels -! in mb). the third index, ig, goes from 1 to NG09=12, and tells us -! which g-interval the absorption coefficients are for. - - data absb(:,1) / & - &4.099400e-03,5.072800e-03,6.142000e-03,7.296900e-03,8.521500e-03, & - &3.560800e-03,4.402500e-03,5.325900e-03,6.323600e-03,7.383800e-03, & - &3.144100e-03,3.883300e-03,4.691100e-03,5.565100e-03,6.486400e-03, & - &2.780400e-03,3.426300e-03,4.131800e-03,4.890300e-03,5.683900e-03, & - &2.517700e-03,3.093100e-03,3.722900e-03,4.395800e-03,5.093200e-03, & - &2.339700e-03,2.866200e-03,3.438300e-03,4.047600e-03,4.676200e-03, & - &2.206700e-03,2.694400e-03,3.219600e-03,3.773000e-03,4.336900e-03, & - &1.990000e-03,2.422900e-03,2.886100e-03,3.366900e-03,3.849800e-03, & - &1.769900e-03,2.147600e-03,2.548900e-03,2.959100e-03,3.369600e-03, & - &1.579100e-03,1.907300e-03,2.249000e-03,2.595300e-03,2.942300e-03, & - &1.408300e-03,1.691300e-03,1.981300e-03,2.272800e-03,2.565600e-03, & - &1.253100e-03,1.494500e-03,1.738600e-03,1.982400e-03,2.227800e-03, & - &1.111600e-03,1.315100e-03,1.519200e-03,1.722700e-03,1.928600e-03, & - &9.810800e-04,1.151000e-03,1.320800e-03,1.491500e-03,1.663600e-03, & - &8.574100e-04,9.981400e-04,1.139400e-03,1.281800e-03,1.424400e-03, & - &7.436200e-04,8.599300e-04,9.767200e-04,1.094200e-03,1.211200e-03, & - &6.417300e-04,7.378700e-04,8.343000e-04,9.307700e-04,1.027500e-03, & - &5.520600e-04,6.311700e-04,7.104300e-04,7.898100e-04,8.691400e-04, & - &4.728200e-04,5.377200e-04,6.029500e-04,6.681000e-04,7.334100e-04, & - &4.042800e-04,4.577900e-04,5.114900e-04,5.652500e-04,6.188000e-04, & - &3.449100e-04,3.891300e-04,4.334400e-04,4.773600e-04,5.208800e-04, & - &2.957600e-04,3.326800e-04,3.692800e-04,4.056700e-04,4.417200e-04, & - &2.507700e-04,2.813600e-04,3.117400e-04,3.419000e-04,3.719000e-04, & - &2.096500e-04,2.351500e-04,2.604100e-04,2.854200e-04,3.105600e-04, & - &1.688100e-04,1.897400e-04,2.105100e-04,2.310600e-04,2.517400e-04, & - &1.351900e-04,1.523800e-04,1.694200e-04,1.863000e-04,2.032300e-04, & - &1.076900e-04,1.217500e-04,1.357100e-04,1.495700e-04,1.634100e-04, & - &8.365900e-05,9.499700e-05,1.062400e-04,1.174200e-04,1.285400e-04, & - &6.455300e-05,7.365800e-05,8.268700e-05,9.164400e-05,1.005500e-04, & - &4.955900e-05,5.684400e-05,6.407400e-05,7.125000e-05,7.838000e-05, & - &3.732500e-05,4.313800e-05,4.888900e-05,5.459900e-05,6.026400e-05, & - &2.771900e-05,3.233000e-05,3.689400e-05,4.141000e-05,4.589900e-05, & - &2.032100e-05,2.399500e-05,2.758600e-05,3.115900e-05,3.470400e-05, & - &1.468400e-05,1.760200e-05,2.043800e-05,2.325500e-05,2.605500e-05, & - &1.049500e-05,1.276100e-05,1.503600e-05,1.725500e-05,1.947200e-05, & - &7.377200e-06,9.106100e-06,1.089700e-05,1.265500e-05,1.439500e-05, & - &5.067300e-06,6.372400e-06,7.734700e-06,9.124900e-06,1.048600e-05, & - &3.530200e-06,4.518000e-06,5.566300e-06,6.649200e-06,7.733600e-06, & - &2.465000e-06,3.211700e-06,4.019600e-06,4.859000e-06,5.720900e-06, & - &1.695900e-06,2.249100e-06,2.860600e-06,3.508100e-06,4.177200e-06, & - &1.146100e-06,1.546600e-06,1.999900e-06,2.490900e-06,3.002400e-06, & - &8.127700e-07,1.115100e-06,1.462300e-06,1.843800e-06,2.247300e-06, & - &5.913200e-07,8.249100e-07,1.096400e-06,1.399000e-06,1.722300e-06, & - &4.277000e-07,6.072000e-07,8.186300e-07,1.057700e-06,1.315800e-06, & - &3.073100e-07,4.444200e-07,6.084100e-07,7.963500e-07,1.001700e-06, & - &2.228600e-07,3.283900e-07,4.565000e-07,6.050800e-07,7.696900e-07, & - &1.893500e-07,2.820800e-07,3.943400e-07,5.245400e-07,6.679300e-07/ - data absb(:,2) / & - &2.035000e-02,2.373700e-02,2.705600e-02,3.042400e-02,3.388000e-02, & - &1.788700e-02,2.069800e-02,2.347400e-02,2.631400e-02,2.921800e-02, & - &1.569900e-02,1.806300e-02,2.041900e-02,2.280700e-02,2.526300e-02, & - &1.370400e-02,1.569600e-02,1.768200e-02,1.968300e-02,2.175800e-02, & - &1.217400e-02,1.387300e-02,1.556500e-02,1.727900e-02,1.905500e-02, & - &1.105100e-02,1.252900e-02,1.401400e-02,1.553200e-02,1.709100e-02, & - &1.013300e-02,1.144200e-02,1.277200e-02,1.414500e-02,1.553200e-02, & - &8.950100e-03,1.007400e-02,1.123200e-02,1.242000e-02,1.361200e-02, & - &7.806100e-03,8.766600e-03,9.763800e-03,1.077600e-02,1.178600e-02, & - &6.798500e-03,7.615400e-03,8.466500e-03,9.316100e-03,1.016100e-02, & - &5.911500e-03,6.609100e-03,7.326400e-03,8.041000e-03,8.746600e-03, & - &5.118200e-03,5.707000e-03,6.303700e-03,6.896900e-03,7.483200e-03, & - &4.418500e-03,4.911700e-03,5.404300e-03,5.893300e-03,6.380200e-03, & - &3.803900e-03,4.212600e-03,4.615700e-03,5.019100e-03,5.422100e-03, & - &3.252600e-03,3.583400e-03,3.913100e-03,4.243000e-03,4.574400e-03, & - &2.758900e-03,3.025300e-03,3.291600e-03,3.560200e-03,3.831500e-03, & - &2.336600e-03,2.552000e-03,2.769400e-03,2.989600e-03,3.211300e-03, & - &1.972100e-03,2.148200e-03,2.326100e-03,2.506200e-03,2.688000e-03, & - &1.664600e-03,1.809300e-03,1.956200e-03,2.105500e-03,2.256000e-03, & - &1.408400e-03,1.528300e-03,1.650800e-03,1.775100e-03,1.900900e-03, & - &1.194200e-03,1.294000e-03,1.396400e-03,1.500700e-03,1.606700e-03, & - &1.022700e-03,1.107500e-03,1.194500e-03,1.283000e-03,1.373500e-03, & - &8.701800e-04,9.421600e-04,1.016000e-03,1.091600e-03,1.169500e-03, & - &7.351500e-04,7.961500e-04,8.590400e-04,9.239200e-04,9.905500e-04, & - &6.021200e-04,6.525200e-04,7.045200e-04,7.583500e-04,8.137000e-04, & - &4.918800e-04,5.333400e-04,5.763200e-04,6.208700e-04,6.668200e-04, & - &4.011800e-04,4.352500e-04,4.707800e-04,5.076500e-04,5.457900e-04, & - &3.180400e-04,3.453500e-04,3.737200e-04,4.033200e-04,4.340300e-04, & - &2.507900e-04,2.725700e-04,2.950900e-04,3.187300e-04,3.432600e-04, & - &1.973400e-04,2.146700e-04,2.325500e-04,2.513400e-04,2.709500e-04, & - &1.533900e-04,1.669700e-04,1.810700e-04,1.957800e-04,2.112500e-04, & - &1.184500e-04,1.290300e-04,1.400600e-04,1.515000e-04,1.635800e-04, & - &9.128000e-05,9.947900e-05,1.080700e-04,1.169800e-04,1.263300e-04, & - &7.019400e-05,7.651600e-05,8.318800e-05,9.012600e-05,9.736700e-05, & - &5.386700e-05,5.879500e-05,6.395200e-05,6.934300e-05,7.496900e-05, & - &4.118900e-05,4.505800e-05,4.904100e-05,5.320600e-05,5.757500e-05, & - &3.134100e-05,3.438200e-05,3.748300e-05,4.069400e-05,4.405100e-05, & - &2.402700e-05,2.644300e-05,2.888400e-05,3.139400e-05,3.399100e-05, & - &1.846800e-05,2.039600e-05,2.232800e-05,2.429600e-05,2.632600e-05, & - &1.414600e-05,1.567600e-05,1.721400e-05,1.876000e-05,2.035000e-05, & - &1.078100e-05,1.199200e-05,1.321700e-05,1.443900e-05,1.568200e-05, & - &8.335000e-06,9.304900e-06,1.028000e-05,1.125800e-05,1.223900e-05, & - &6.482300e-06,7.275300e-06,8.054200e-06,8.837500e-06,9.616300e-06, & - &5.017800e-06,5.680200e-06,6.304100e-06,6.929200e-06,7.549600e-06, & - &3.866300e-06,4.422100e-06,4.927300e-06,5.425400e-06,5.922100e-06, & - &2.980400e-06,3.445700e-06,3.861700e-06,4.260900e-06,4.658000e-06, & - &2.428000e-06,2.816000e-06,3.159500e-06,3.483600e-06,3.804500e-06/ - data absb(:,3) / & - &5.220700e-02,5.821800e-02,6.486700e-02,7.185400e-02,7.926900e-02, & - &4.518600e-02,5.051100e-02,5.622500e-02,6.214000e-02,6.838000e-02, & - &3.907200e-02,4.358800e-02,4.837800e-02,5.336900e-02,5.857900e-02, & - &3.360000e-02,3.741400e-02,4.142000e-02,4.560300e-02,4.992000e-02, & - &2.935200e-02,3.263700e-02,3.607700e-02,3.964400e-02,4.331500e-02, & - &2.623900e-02,2.917000e-02,3.223600e-02,3.540100e-02,3.865200e-02, & - &2.373300e-02,2.639500e-02,2.916100e-02,3.200500e-02,3.496900e-02, & - &2.079500e-02,2.313100e-02,2.553500e-02,2.801100e-02,3.059900e-02, & - &1.804000e-02,2.005700e-02,2.211600e-02,2.426200e-02,2.647800e-02, & - &1.561200e-02,1.732200e-02,1.907000e-02,2.089500e-02,2.275200e-02, & - &1.348400e-02,1.492300e-02,1.641100e-02,1.794700e-02,1.949200e-02, & - &1.155000e-02,1.274400e-02,1.398700e-02,1.526000e-02,1.651700e-02, & - &9.860500e-03,1.084800e-02,1.188200e-02,1.291900e-02,1.395600e-02, & - &8.395800e-03,9.217600e-03,1.006800e-02,1.091800e-02,1.178300e-02, & - &7.088600e-03,7.768900e-03,8.460400e-03,9.162100e-03,9.881000e-03, & - &5.937100e-03,6.491500e-03,7.059400e-03,7.641100e-03,8.233900e-03, & - &4.985100e-03,5.442500e-03,5.914300e-03,6.395900e-03,6.892200e-03, & - &4.181200e-03,4.562700e-03,4.952700e-03,5.355300e-03,5.772800e-03, & - &3.520800e-03,3.837700e-03,4.162400e-03,4.500500e-03,4.852900e-03, & - &2.979400e-03,3.243400e-03,3.517100e-03,3.803300e-03,4.101300e-03, & - &2.529800e-03,2.752500e-03,2.985300e-03,3.229500e-03,3.480000e-03, & - &2.174800e-03,2.365800e-03,2.566900e-03,2.777100e-03,2.991100e-03, & - &1.856700e-03,2.021600e-03,2.195600e-03,2.376000e-03,2.559500e-03, & - &1.573100e-03,1.715300e-03,1.865400e-03,2.020500e-03,2.179100e-03, & - &1.293300e-03,1.411400e-03,1.536400e-03,1.665800e-03,1.798400e-03, & - &1.061600e-03,1.159400e-03,1.263400e-03,1.371200e-03,1.482000e-03, & - &8.712500e-04,9.524500e-04,1.038700e-03,1.128700e-03,1.221300e-03, & - &6.932700e-04,7.582600e-04,8.275200e-04,8.999500e-04,9.747900e-04, & - &5.486800e-04,6.004300e-04,6.557000e-04,7.136200e-04,7.740200e-04, & - &4.335000e-04,4.747500e-04,5.186600e-04,5.649600e-04,6.133900e-04, & - &3.383100e-04,3.707400e-04,4.051800e-04,4.416900e-04,4.799400e-04, & - &2.624400e-04,2.877000e-04,3.145900e-04,3.430100e-04,3.729900e-04, & - &2.033000e-04,2.228200e-04,2.437600e-04,2.658700e-04,2.893100e-04, & - &1.571800e-04,1.722300e-04,1.884700e-04,2.056500e-04,2.238600e-04, & - &1.213700e-04,1.329200e-04,1.454400e-04,1.588100e-04,1.729000e-04, & - &9.360200e-05,1.024500e-04,1.120600e-04,1.224200e-04,1.333300e-04, & - &7.209600e-05,7.885700e-05,8.619800e-05,9.414600e-05,1.025900e-04, & - &5.591300e-05,6.113100e-05,6.676600e-05,7.290100e-05,7.946000e-05, & - &4.351100e-05,4.755900e-05,5.189600e-05,5.662400e-05,6.171300e-05, & - &3.381700e-05,3.696700e-05,4.030800e-05,4.393600e-05,4.787000e-05, & - &2.625100e-05,2.870100e-05,3.127800e-05,3.405500e-05,3.707600e-05, & - &2.056500e-05,2.247200e-05,2.449300e-05,2.664700e-05,2.898700e-05, & - &1.620100e-05,1.766500e-05,1.926500e-05,2.095000e-05,2.277800e-05, & - &1.278100e-05,1.388300e-05,1.514200e-05,1.646800e-05,1.789000e-05, & - &1.008900e-05,1.091600e-05,1.189400e-05,1.294000e-05,1.404200e-05, & - &7.978400e-06,8.608800e-06,9.361000e-06,1.018500e-05,1.104900e-05, & - &6.451000e-06,6.964700e-06,7.575900e-06,8.243900e-06,8.947800e-06/ - data absb(:,4) / & - &1.184100e-01,1.298300e-01,1.415400e-01,1.538100e-01,1.665400e-01, & - &1.016300e-01,1.111900e-01,1.212000e-01,1.316400e-01,1.426200e-01, & - &8.753300e-02,9.545300e-02,1.036000e-01,1.122500e-01,1.214300e-01, & - &7.471800e-02,8.107400e-02,8.791700e-02,9.526900e-02,1.030900e-01, & - &6.459800e-02,7.016100e-02,7.619500e-02,8.269100e-02,8.964500e-02, & - &5.746600e-02,6.258900e-02,6.810900e-02,7.405200e-02,8.044900e-02, & - &5.181800e-02,5.657100e-02,6.169600e-02,6.723200e-02,7.309200e-02, & - &4.533300e-02,4.958300e-02,5.417500e-02,5.911900e-02,6.430700e-02, & - &3.924400e-02,4.298800e-02,4.705600e-02,5.139000e-02,5.592100e-02, & - &3.376200e-02,3.702800e-02,4.059000e-02,4.436700e-02,4.827800e-02, & - &2.896400e-02,3.182500e-02,3.492400e-02,3.819200e-02,4.157000e-02, & - &2.460500e-02,2.708700e-02,2.974400e-02,3.252800e-02,3.539800e-02, & - &2.088800e-02,2.302800e-02,2.529300e-02,2.766400e-02,3.005600e-02, & - &1.776800e-02,1.959500e-02,2.152800e-02,2.352300e-02,2.548000e-02, & - &1.502500e-02,1.658200e-02,1.820800e-02,1.985100e-02,2.144900e-02, & - &1.263000e-02,1.394000e-02,1.528300e-02,1.661900e-02,1.793500e-02, & - &1.067900e-02,1.177700e-02,1.288200e-02,1.398100e-02,1.507700e-02, & - &9.025500e-03,9.933600e-03,1.084700e-02,1.176000e-02,1.267500e-02, & - &7.653600e-03,8.408600e-03,9.174200e-03,9.942900e-03,1.071200e-02, & - &6.518200e-03,7.153600e-03,7.801400e-03,8.451500e-03,9.106500e-03, & - &5.570400e-03,6.111300e-03,6.663000e-03,7.215100e-03,7.782000e-03, & - &4.818100e-03,5.284500e-03,5.755100e-03,6.234700e-03,6.727100e-03, & - &4.134400e-03,4.534200e-03,4.941000e-03,5.360000e-03,5.787600e-03, & - &3.513700e-03,3.856800e-03,4.210500e-03,4.574400e-03,4.947800e-03, & - &2.901500e-03,3.189400e-03,3.486700e-03,3.792800e-03,4.106200e-03, & - &2.392200e-03,2.633600e-03,2.883300e-03,3.140300e-03,3.403300e-03, & - &1.971700e-03,2.174600e-03,2.384600e-03,2.600500e-03,2.821300e-03, & - &1.574400e-03,1.739800e-03,1.911100e-03,2.087400e-03,2.267300e-03, & - &1.249900e-03,1.384100e-03,1.523100e-03,1.666400e-03,1.812200e-03, & - &9.902600e-04,1.099100e-03,1.211700e-03,1.328100e-03,1.446400e-03, & - &7.742400e-04,8.614200e-04,9.518300e-04,1.045200e-03,1.140400e-03, & - &6.010200e-04,6.703400e-04,7.425200e-04,8.170700e-04,8.931100e-04, & - &4.654200e-04,5.203500e-04,5.778300e-04,6.373200e-04,6.979700e-04, & - &3.592900e-04,4.025900e-04,4.481700e-04,4.956100e-04,5.440300e-04, & - &2.763900e-04,3.103500e-04,3.464200e-04,3.841500e-04,4.228300e-04, & - &2.122300e-04,2.386100e-04,2.670900e-04,2.968800e-04,3.277600e-04, & - &1.626600e-04,1.829800e-04,2.052400e-04,2.287100e-04,2.532700e-04, & - &1.255800e-04,1.412800e-04,1.586300e-04,1.772200e-04,1.967200e-04, & - &9.720900e-05,1.093600e-04,1.228800e-04,1.375300e-04,1.530200e-04, & - &7.522800e-05,8.455400e-05,9.502700e-05,1.064800e-04,1.187500e-04, & - &5.818500e-05,6.529100e-05,7.334600e-05,8.226100e-05,9.186500e-05, & - &4.537400e-05,5.084700e-05,5.709700e-05,6.405800e-05,7.160100e-05, & - &3.549100e-05,3.977000e-05,4.463400e-05,5.007000e-05,5.600300e-05, & - &2.773000e-05,3.110700e-05,3.487300e-05,3.910500e-05,4.375400e-05, & - &2.164800e-05,2.431400e-05,2.722900e-05,3.051600e-05,3.414800e-05, & - &1.695100e-05,1.903800e-05,2.131400e-05,2.387200e-05,2.671000e-05, & - &1.366300e-05,1.535100e-05,1.720000e-05,1.927300e-05,2.155800e-05/ - data absb(:,5) / & - &2.773700e-01,2.932200e-01,3.094100e-01,3.262700e-01,3.443400e-01, & - &2.306500e-01,2.443700e-01,2.586300e-01,2.740400e-01,2.908000e-01, & - &1.930600e-01,2.055000e-01,2.189000e-01,2.332900e-01,2.488400e-01, & - &1.628800e-01,1.740800e-01,1.859000e-01,1.985700e-01,2.123800e-01, & - &1.408100e-01,1.506800e-01,1.612300e-01,1.728000e-01,1.853200e-01, & - &1.255300e-01,1.346600e-01,1.446700e-01,1.555700e-01,1.670900e-01, & - &1.135100e-01,1.222100e-01,1.317800e-01,1.420200e-01,1.528300e-01, & - &9.967500e-02,1.077200e-01,1.165200e-01,1.257700e-01,1.356200e-01, & - &8.669500e-02,9.402200e-02,1.019200e-01,1.102500e-01,1.191300e-01, & - &7.487400e-02,8.150200e-02,8.851400e-02,9.595500e-02,1.038500e-01, & - &6.454000e-02,7.039500e-02,7.661200e-02,8.322400e-02,9.009500e-02, & - &5.494600e-02,6.004700e-02,6.551700e-02,7.129600e-02,7.722000e-02, & - &4.667700e-02,5.114100e-02,5.594000e-02,6.091700e-02,6.605300e-02, & - &3.970900e-02,4.364200e-02,4.778700e-02,5.207800e-02,5.650500e-02, & - &3.362300e-02,3.704200e-02,4.059100e-02,4.426300e-02,4.802200e-02, & - &2.832800e-02,3.124500e-02,3.425400e-02,3.736300e-02,4.051000e-02, & - &2.405000e-02,2.652700e-02,2.909800e-02,3.172700e-02,3.439500e-02, & - &2.042000e-02,2.252900e-02,2.472200e-02,2.695000e-02,2.923100e-02, & - &1.742900e-02,1.924200e-02,2.111000e-02,2.303200e-02,2.501400e-02, & - &1.496100e-02,1.652100e-02,1.813000e-02,1.980500e-02,2.154200e-02, & - &1.289700e-02,1.424500e-02,1.565300e-02,1.713100e-02,1.866100e-02, & - &1.125300e-02,1.243800e-02,1.369200e-02,1.500800e-02,1.637400e-02, & - &9.739700e-03,1.078600e-02,1.190200e-02,1.307300e-02,1.429500e-02, & - &8.344400e-03,9.267400e-03,1.025500e-02,1.129900e-02,1.238800e-02, & - &6.946700e-03,7.734400e-03,8.580500e-03,9.476900e-03,1.041400e-02, & - &5.773600e-03,6.445000e-03,7.168700e-03,7.936800e-03,8.742400e-03, & - &4.798100e-03,5.370300e-03,5.988400e-03,6.648000e-03,7.340300e-03, & - &3.857600e-03,4.327400e-03,4.836800e-03,5.382700e-03,5.957400e-03, & - &3.082500e-03,3.465800e-03,3.882700e-03,4.331800e-03,4.806600e-03, & - &2.458000e-03,2.769700e-03,3.110500e-03,3.479300e-03,3.870100e-03, & - &1.933200e-03,2.183600e-03,2.457700e-03,2.755700e-03,3.073200e-03, & - &1.509700e-03,1.709100e-03,1.927600e-03,2.166100e-03,2.422100e-03, & - &1.176300e-03,1.334500e-03,1.508300e-03,1.698500e-03,1.904000e-03, & - &9.129600e-04,1.038000e-03,1.175800e-03,1.327000e-03,1.491300e-03, & - &7.047600e-04,8.036600e-04,9.125200e-04,1.032400e-03,1.162700e-03, & - &5.424100e-04,6.207800e-04,7.061700e-04,8.010100e-04,9.039200e-04, & - &4.160800e-04,4.781200e-04,5.451500e-04,6.196000e-04,7.007500e-04, & - &3.209200e-04,3.702000e-04,4.234300e-04,4.819600e-04,5.463000e-04, & - &2.481000e-04,2.870900e-04,3.294800e-04,3.757000e-04,4.267600e-04, & - &1.914100e-04,2.221300e-04,2.557900e-04,2.924400e-04,3.328000e-04, & - &1.473100e-04,1.714800e-04,1.980800e-04,2.271900e-04,2.589900e-04, & - &1.142400e-04,1.334200e-04,1.544600e-04,1.777200e-04,2.030000e-04, & - &8.890400e-05,1.041400e-04,1.207900e-04,1.393700e-04,1.595600e-04, & - &6.913300e-05,8.118500e-05,9.432500e-05,1.091100e-04,1.252200e-04, & - &5.374200e-05,6.314300e-05,7.356700e-05,8.526500e-05,9.810200e-05, & - &4.190700e-05,4.923800e-05,5.749200e-05,6.673600e-05,7.698400e-05, & - &3.385900e-05,3.981900e-05,4.656500e-05,5.410700e-05,6.250300e-05/ - data absb(:,6) / & - &6.412100e-01,6.673900e-01,6.946800e-01,7.226500e-01,7.510700e-01, & - &5.342800e-01,5.569700e-01,5.804400e-01,6.046600e-01,6.290600e-01, & - &4.425000e-01,4.630700e-01,4.847700e-01,5.067600e-01,5.297200e-01, & - &3.711500e-01,3.907100e-01,4.107100e-01,4.313100e-01,4.529000e-01, & - &3.220100e-01,3.398200e-01,3.577500e-01,3.761900e-01,3.959000e-01, & - &2.886000e-01,3.043300e-01,3.205800e-01,3.377800e-01,3.571100e-01, & - &2.609300e-01,2.754700e-01,2.909200e-01,3.078700e-01,3.271500e-01, & - &2.290600e-01,2.425200e-01,2.570600e-01,2.735300e-01,2.918800e-01, & - &1.992100e-01,2.116300e-01,2.254700e-01,2.410000e-01,2.582600e-01, & - &1.719000e-01,1.834700e-01,1.965200e-01,2.110400e-01,2.272500e-01, & - &1.480700e-01,1.589200e-01,1.710700e-01,1.846400e-01,1.997600e-01, & - &1.263000e-01,1.363900e-01,1.476000e-01,1.601500e-01,1.739500e-01, & - &1.078500e-01,1.170900e-01,1.274300e-01,1.389000e-01,1.514900e-01, & - &9.238300e-02,1.008200e-01,1.103300e-01,1.208200e-01,1.322900e-01, & - &7.881200e-02,8.654200e-02,9.521800e-02,1.047700e-01,1.150800e-01, & - &6.695300e-02,7.400500e-02,8.190000e-02,9.049900e-02,9.966700e-02, & - &5.747200e-02,6.392300e-02,7.108800e-02,7.881000e-02,8.697900e-02, & - &4.950600e-02,5.539400e-02,6.182500e-02,6.871400e-02,7.594800e-02, & - &4.302600e-02,4.835100e-02,5.414500e-02,6.028100e-02,6.664500e-02, & - &3.769500e-02,4.252000e-02,4.771400e-02,5.315800e-02,5.875400e-02, & - &3.325300e-02,3.761200e-02,4.223800e-02,4.705800e-02,5.205700e-02, & - &2.968700e-02,3.363900e-02,3.780200e-02,4.214300e-02,4.671300e-02, & - &2.623800e-02,2.978000e-02,3.351200e-02,3.743300e-02,4.161800e-02, & - &2.287000e-02,2.602000e-02,2.934300e-02,3.288200e-02,3.668100e-02, & - &1.932200e-02,2.206000e-02,2.496500e-02,2.808600e-02,3.145600e-02, & - &1.628900e-02,1.866700e-02,2.120600e-02,2.395300e-02,2.693800e-02, & - &1.372400e-02,1.578700e-02,1.800500e-02,2.042100e-02,2.306400e-02, & - &1.117000e-02,1.290300e-02,1.477700e-02,1.683200e-02,1.909400e-02, & - &9.028900e-03,1.047400e-02,1.204800e-02,1.378300e-02,1.570700e-02, & - &7.278600e-03,8.478400e-03,9.796200e-03,1.125700e-02,1.288900e-02, & - &5.774600e-03,6.757900e-03,7.846800e-03,9.060200e-03,1.042500e-02, & - &4.541500e-03,5.341400e-03,6.233700e-03,7.232600e-03,8.363300e-03, & - &3.560100e-03,4.208100e-03,4.934600e-03,5.755800e-03,6.689100e-03, & - &2.775400e-03,3.297700e-03,3.885500e-03,4.556900e-03,5.323800e-03, & - &2.147500e-03,2.565700e-03,3.038400e-03,3.583600e-03,4.210900e-03, & - &1.656300e-03,1.989200e-03,2.368400e-03,2.808100e-03,3.318400e-03, & - &1.273600e-03,1.536600e-03,1.839600e-03,2.191800e-03,2.605300e-03, & - &9.851400e-04,1.193800e-03,1.436600e-03,1.719900e-03,2.056100e-03, & - &7.630500e-04,9.285300e-04,1.123000e-03,1.350700e-03,1.623700e-03, & - &5.896400e-04,7.204800e-04,8.753900e-04,1.057700e-03,1.278100e-03, & - &4.544200e-04,5.576400e-04,6.804100e-04,8.261400e-04,1.002500e-03, & - &3.527700e-04,4.343500e-04,5.323100e-04,6.490100e-04,7.905600e-04, & - &2.745600e-04,3.389900e-04,4.171400e-04,5.107400e-04,6.243500e-04, & - &2.133100e-04,2.641000e-04,3.261900e-04,4.009700e-04,4.919200e-04, & - &1.654400e-04,2.052600e-04,2.545300e-04,3.140400e-04,3.866000e-04, & - &1.285800e-04,1.598600e-04,1.989700e-04,2.463500e-04,3.045000e-04, & - &1.042400e-04,1.300500e-04,1.624600e-04,2.016800e-04,2.502200e-04/ - data absb(:,7) / & - &1.565100e+00,1.616900e+00,1.670800e+00,1.726300e+00,1.785200e+00, & - &1.303400e+00,1.349500e+00,1.397000e+00,1.447000e+00,1.499000e+00, & - &1.079800e+00,1.120500e+00,1.162700e+00,1.206600e+00,1.252900e+00, & - &9.050200e-01,9.426400e-01,9.816800e-01,1.023200e+00,1.066800e+00, & - &7.853300e-01,8.226400e-01,8.617000e-01,9.029700e-01,9.457400e-01, & - &7.090500e-01,7.460600e-01,7.844500e-01,8.238500e-01,8.649800e-01, & - &6.511700e-01,6.858100e-01,7.208400e-01,7.573800e-01,7.968900e-01, & - &5.805500e-01,6.113000e-01,6.430200e-01,6.774600e-01,7.155300e-01, & - &5.110900e-01,5.388300e-01,5.686700e-01,6.017800e-01,6.386600e-01, & - &4.453500e-01,4.710700e-01,4.996300e-01,5.317300e-01,5.675200e-01, & - &3.869300e-01,4.114700e-01,4.391100e-01,4.701500e-01,5.047200e-01, & - &3.329900e-01,3.562800e-01,3.827700e-01,4.124800e-01,4.455000e-01, & - &2.867400e-01,3.090300e-01,3.344700e-01,3.628600e-01,3.939100e-01, & - &2.479900e-01,2.694500e-01,2.935900e-01,3.203400e-01,3.499700e-01, & - &2.143100e-01,2.346100e-01,2.572300e-01,2.824900e-01,3.106700e-01, & - &1.850500e-01,2.039000e-01,2.250200e-01,2.488700e-01,2.753700e-01, & - &1.614600e-01,1.790800e-01,1.991200e-01,2.216700e-01,2.466700e-01, & - &1.413700e-01,1.580600e-01,1.770600e-01,1.983500e-01,2.220900e-01, & - &1.249800e-01,1.409200e-01,1.589600e-01,1.792700e-01,2.019900e-01, & - &1.116200e-01,1.268600e-01,1.441100e-01,1.636200e-01,1.854400e-01, & - &1.005800e-01,1.151900e-01,1.318500e-01,1.506200e-01,1.716400e-01, & - &9.187200e-02,1.060500e-01,1.222100e-01,1.404900e-01,1.609200e-01, & - &8.313400e-02,9.673100e-02,1.122700e-01,1.298600e-01,1.495200e-01, & - &7.408100e-02,8.689400e-02,1.016300e-01,1.183000e-01,1.370300e-01, & - &6.415300e-02,7.590100e-02,8.951500e-02,1.049900e-01,1.224500e-01, & - &5.545900e-02,6.619900e-02,7.876200e-02,9.314400e-02,1.094500e-01, & - &4.792300e-02,5.773000e-02,6.932800e-02,8.271500e-02,9.796800e-02, & - &3.999100e-02,4.862600e-02,5.896200e-02,7.103300e-02,8.486600e-02, & - &3.313200e-02,4.066800e-02,4.978600e-02,6.060100e-02,7.311000e-02, & - &2.736200e-02,3.390700e-02,4.191500e-02,5.154400e-02,6.283800e-02, & - &2.219600e-02,2.776800e-02,3.467100e-02,4.309000e-02,5.311900e-02, & - &1.781800e-02,2.250100e-02,2.838000e-02,3.565500e-02,4.445500e-02, & - &1.424300e-02,1.815000e-02,2.312800e-02,2.937700e-02,3.704500e-02, & - &1.128600e-02,1.451100e-02,1.868500e-02,2.400000e-02,3.061600e-02, & - &8.830500e-03,1.145300e-02,1.490200e-02,1.935600e-02,2.500100e-02, & - &6.871000e-03,8.988800e-03,1.181400e-02,1.551700e-02,2.029400e-02, & - &5.315000e-03,7.012100e-03,9.305900e-03,1.235700e-02,1.636500e-02, & - &4.130900e-03,5.494400e-03,7.365300e-03,9.887700e-03,1.325400e-02, & - &3.212200e-03,4.302800e-03,5.824600e-03,7.907200e-03,1.073000e-02, & - &2.485500e-03,3.351800e-03,4.579100e-03,6.287000e-03,8.634500e-03, & - &1.914400e-03,2.595800e-03,3.577200e-03,4.967900e-03,6.902900e-03, & - &1.484600e-03,2.024300e-03,2.813100e-03,3.950600e-03,5.558500e-03, & - &1.153100e-03,1.580400e-03,2.214300e-03,3.143600e-03,4.479900e-03, & - &8.924100e-04,1.229600e-03,1.734400e-03,2.487900e-03,3.589200e-03, & - &6.883900e-04,9.520600e-04,1.350900e-03,1.957200e-03,2.857500e-03, & - &5.323600e-04,7.383700e-04,1.053500e-03,1.540600e-03,2.279300e-03, & - &4.359800e-04,6.102200e-04,8.806800e-04,1.303300e-03,1.955300e-03/ - data absb(:,8) / & - &4.776900e+00,4.884800e+00,4.987400e+00,5.091700e+00,5.196800e+00, & - &4.025200e+00,4.122500e+00,4.220300e+00,4.317200e+00,4.417300e+00, & - &3.363600e+00,3.455700e+00,3.544700e+00,3.637900e+00,3.731300e+00, & - &2.821500e+00,2.904500e+00,2.991200e+00,3.077700e+00,3.170300e+00, & - &2.420700e+00,2.504300e+00,2.589500e+00,2.679300e+00,2.773800e+00, & - &2.159600e+00,2.249600e+00,2.342500e+00,2.440400e+00,2.539900e+00, & - &1.987300e+00,2.085300e+00,2.186600e+00,2.289100e+00,2.390500e+00, & - &1.804600e+00,1.902200e+00,2.000700e+00,2.097300e+00,2.193200e+00, & - &1.624500e+00,1.715100e+00,1.803800e+00,1.890700e+00,1.979500e+00, & - &1.446100e+00,1.525800e+00,1.603600e+00,1.683500e+00,1.767700e+00, & - &1.278400e+00,1.348400e+00,1.420200e+00,1.495800e+00,1.578100e+00, & - &1.116200e+00,1.179900e+00,1.246900e+00,1.319700e+00,1.401400e+00, & - &9.729000e-01,1.032300e+00,1.096400e+00,1.168300e+00,1.250700e+00, & - &8.508300e-01,9.074600e-01,9.702800e-01,1.042600e+00,1.125000e+00, & - &7.433100e-01,7.980500e-01,8.606600e-01,9.328200e-01,1.015000e+00, & - &6.487500e-01,7.025800e-01,7.647600e-01,8.362400e-01,9.188000e-01, & - &5.735300e-01,6.270400e-01,6.889800e-01,7.611500e-01,8.445600e-01, & - &5.108100e-01,5.643000e-01,6.267200e-01,6.996000e-01,7.836600e-01, & - &4.606000e-01,5.147400e-01,5.785000e-01,6.527600e-01,7.378400e-01, & - &4.205400e-01,4.758400e-01,5.413800e-01,6.174400e-01,7.041600e-01, & - &3.888100e-01,4.457400e-01,5.132600e-01,5.915800e-01,6.810100e-01, & - &3.658200e-01,4.244600e-01,4.941300e-01,5.750400e-01,6.679700e-01, & - &3.421100e-01,4.015800e-01,4.724300e-01,5.551900e-01,6.509500e-01, & - &3.158400e-01,3.751500e-01,4.459600e-01,5.294800e-01,6.266200e-01, & - &2.833500e-01,3.400000e-01,4.080800e-01,4.892500e-01,5.843300e-01, & - &2.543900e-01,3.083700e-01,3.738200e-01,4.525600e-01,5.455400e-01, & - &2.288400e-01,2.803700e-01,3.433600e-01,4.198800e-01,5.108400e-01, & - &1.989400e-01,2.462100e-01,3.046000e-01,3.762200e-01,4.621700e-01, & - &1.720200e-01,2.150500e-01,2.688900e-01,3.354600e-01,4.163100e-01, & - &1.485100e-01,1.877000e-01,2.371500e-01,2.989500e-01,3.747300e-01, & - &1.260000e-01,1.609500e-01,2.055400e-01,2.618800e-01,3.316900e-01, & - &1.058400e-01,1.366700e-01,1.765200e-01,2.272900e-01,2.909700e-01, & - &8.849300e-02,1.156700e-01,1.511000e-01,1.967200e-01,2.546200e-01, & - &7.323300e-02,9.702200e-02,1.282700e-01,1.689200e-01,2.211400e-01, & - &5.963600e-02,8.016300e-02,1.073800e-01,1.431400e-01,1.896100e-01, & - &4.816700e-02,6.576500e-02,8.934600e-02,1.206700e-01,1.618400e-01, & - &3.856600e-02,5.350000e-02,7.380500e-02,1.011400e-01,1.374000e-01, & - &3.098600e-02,4.365700e-02,6.123500e-02,8.518700e-02,1.173200e-01, & - &2.485500e-02,3.553800e-02,5.072800e-02,7.169000e-02,1.002100e-01, & - &1.977000e-02,2.870400e-02,4.170300e-02,5.994300e-02,8.515700e-02, & - &1.559400e-02,2.297300e-02,3.396700e-02,4.976200e-02,7.185300e-02, & - &1.239500e-02,1.852300e-02,2.787700e-02,4.163000e-02,6.114400e-02, & - &9.857500e-03,1.493800e-02,2.289000e-02,3.484600e-02,5.212100e-02, & - &7.792900e-03,1.197000e-02,1.866100e-02,2.895400e-02,4.416800e-02, & - &6.119500e-03,9.511100e-03,1.508800e-02,2.388200e-02,3.717900e-02, & - &4.810200e-03,7.560400e-03,1.220000e-02,1.971300e-02,3.133400e-02, & - &4.099400e-03,6.564800e-03,1.081300e-02,1.779400e-02,2.875500e-02/ - data absb(:,9) / & - &2.600114e+01,2.615981e+01,2.635965e+01,2.655350e+01,2.675532e+01, & - &2.360266e+01,2.381751e+01,2.404479e+01,2.428431e+01,2.452411e+01, & - &2.102256e+01,2.127975e+01,2.154791e+01,2.181129e+01,2.210487e+01, & - &1.857305e+01,1.885869e+01,1.915372e+01,1.948521e+01,1.982517e+01, & - &1.657185e+01,1.688985e+01,1.724422e+01,1.760892e+01,1.799051e+01, & - &1.507814e+01,1.544564e+01,1.583357e+01,1.624930e+01,1.670071e+01, & - &1.379816e+01,1.420051e+01,1.464179e+01,1.512751e+01,1.565257e+01, & - &1.243119e+01,1.287053e+01,1.336157e+01,1.389487e+01,1.446027e+01, & - &1.117312e+01,1.165231e+01,1.217889e+01,1.274369e+01,1.334935e+01, & - &1.004125e+01,1.054845e+01,1.109884e+01,1.169494e+01,1.234309e+01, & - &9.072685e+00,9.599851e+00,1.017743e+01,1.081141e+01,1.149222e+01, & - &8.202179e+00,8.750739e+00,9.359189e+00,1.001474e+01,1.071622e+01, & - &7.503044e+00,8.074985e+00,8.698424e+00,9.370698e+00,1.009276e+01, & - &6.949685e+00,7.530078e+00,8.166757e+00,8.858006e+00,9.612549e+00, & - &6.454564e+00,7.040952e+00,7.686383e+00,8.397617e+00,9.181076e+00, & - &6.017788e+00,6.605691e+00,7.260716e+00,7.992421e+00,8.800190e+00, & - &5.679920e+00,6.275047e+00,6.945732e+00,7.699288e+00,8.528933e+00, & - &5.418421e+00,6.025084e+00,6.713344e+00,7.484696e+00,8.333704e+00, & - &5.240828e+00,5.863144e+00,6.568347e+00,7.355860e+00,8.226439e+00, & - &5.146067e+00,5.793865e+00,6.515598e+00,7.322800e+00,8.222446e+00, & - &5.122189e+00,5.799891e+00,6.541529e+00,7.375221e+00,8.304205e+00, & - &5.185247e+00,5.902144e+00,6.680776e+00,7.551508e+00,8.514105e+00, & - &5.230693e+00,5.983953e+00,6.804912e+00,7.701705e+00,8.685884e+00, & - &5.234943e+00,6.019438e+00,6.878157e+00,7.802210e+00,8.793500e+00, & - &5.054244e+00,5.840384e+00,6.703391e+00,7.633738e+00,8.619147e+00, & - &4.878265e+00,5.663471e+00,6.527916e+00,7.460559e+00,8.448462e+00, & - &4.714282e+00,5.496000e+00,6.359401e+00,7.291785e+00,8.281866e+00, & - &4.409147e+00,5.162567e+00,5.997046e+00,6.904356e+00,7.869912e+00, & - &4.102313e+00,4.825113e+00,5.625980e+00,6.502968e+00,7.439939e+00, & - &3.812767e+00,4.503941e+00,5.269996e+00,6.113510e+00,7.019261e+00, & - &3.488740e+00,4.140184e+00,4.862827e+00,5.662837e+00,6.528682e+00, & - &3.163939e+00,3.774601e+00,4.451544e+00,5.202827e+00,6.025901e+00, & - &2.860521e+00,3.431981e+00,4.063583e+00,4.767569e+00,5.545313e+00, & - &2.569952e+00,3.104762e+00,3.694442e+00,4.351245e+00,5.081855e+00, & - &2.289189e+00,2.788807e+00,3.340175e+00,3.951947e+00,4.634945e+00, & - &2.028534e+00,2.493493e+00,3.009461e+00,3.579400e+00,4.215777e+00, & - &1.786196e+00,2.218398e+00,2.700056e+00,3.231746e+00,3.823100e+00, & - &1.584744e+00,1.990071e+00,2.442045e+00,2.943277e+00,3.498204e+00, & - &1.407325e+00,1.787763e+00,2.213548e+00,2.687376e+00,3.210963e+00, & - &1.242473e+00,1.598984e+00,1.999563e+00,2.446250e+00,2.940525e+00, & - &1.090402e+00,1.422438e+00,1.797854e+00,2.218119e+00,2.684387e+00, & - &9.668038e-01,1.277006e+00,1.632246e+00,2.031267e+00,2.474374e+00, & - &8.597181e-01,1.149893e+00,1.486333e+00,1.865660e+00,2.288300e+00, & - &7.601419e-01,1.031324e+00,1.347654e+00,1.707968e+00,2.111107e+00, & - &6.676230e-01,9.206372e-01,1.216525e+00,1.558059e+00,1.942162e+00, & - &5.862086e-01,8.230280e-01,1.100028e+00,1.422919e+00,1.789264e+00, & - &5.561795e-01,7.876419e-01,1.058714e+00,1.375108e+00,1.736796e+00/ - data absb(:,10) / & - &9.924211e+01,9.980836e+01,1.001439e+02,1.006382e+02,1.012961e+02, & - &1.009937e+02,1.016216e+02,1.022376e+02,1.030167e+02,1.039660e+02, & - &1.003953e+02,1.012372e+02,1.023211e+02,1.036608e+02,1.046703e+02, & - &9.857956e+01,1.000347e+02,1.017176e+02,1.030948e+02,1.043344e+02, & - &9.789030e+01,9.986755e+01,1.015873e+02,1.032799e+02,1.050998e+02, & - &9.898114e+01,1.011644e+02,1.033548e+02,1.057052e+02,1.080796e+02, & - &9.985255e+01,1.026055e+02,1.055124e+02,1.084976e+02,1.115006e+02, & - &9.846749e+01,1.018143e+02,1.053278e+02,1.089081e+02,1.125740e+02, & - &9.589778e+01,9.989046e+01,1.040066e+02,1.082765e+02,1.125629e+02, & - &9.232195e+01,9.696669e+01,1.017565e+02,1.066516e+02,1.115414e+02, & - &8.852169e+01,9.377573e+01,9.924226e+01,1.047358e+02,1.102876e+02, & - &8.388246e+01,8.973409e+01,9.574004e+01,1.019094e+02,1.080171e+02, & - &7.964352e+01,8.604675e+01,9.273996e+01,9.945458e+01,1.061256e+02, & - &7.639313e+01,8.343685e+01,9.066707e+01,9.785315e+01,1.049345e+02, & - &7.381001e+01,8.138209e+01,8.902140e+01,9.661322e+01,1.040408e+02, & - &7.166463e+01,7.960865e+01,8.758176e+01,9.543894e+01,1.031297e+02, & - &7.068463e+01,7.894322e+01,8.719508e+01,9.530857e+01,1.032401e+02, & - &7.009010e+01,7.857681e+01,8.703870e+01,9.538557e+01,1.034128e+02, & - &7.006171e+01,7.873843e+01,8.741852e+01,9.589575e+01,1.040695e+02, & - &7.053479e+01,7.935788e+01,8.819679e+01,9.691674e+01,1.054168e+02, & - &7.134615e+01,8.027036e+01,8.945393e+01,9.858089e+01,1.075285e+02, & - &7.311488e+01,8.234377e+01,9.188091e+01,1.013418e+02,1.107995e+02, & - &7.421696e+01,8.376690e+01,9.357365e+01,1.035247e+02,1.135381e+02, & - &7.452280e+01,8.438637e+01,9.452244e+01,1.049625e+02,1.156564e+02, & - &7.332423e+01,8.325802e+01,9.349515e+01,1.040503e+02,1.149831e+02, & - &7.213619e+01,8.213512e+01,9.246392e+01,1.031298e+02,1.142136e+02, & - &7.106062e+01,8.114729e+01,9.158975e+01,1.023913e+02,1.136378e+02, & - &6.805803e+01,7.804187e+01,8.846127e+01,9.920215e+01,1.103892e+02, & - &6.487604e+01,7.470816e+01,8.507297e+01,9.573668e+01,1.068453e+02, & - &6.175186e+01,7.145425e+01,8.173816e+01,9.235097e+01,1.033902e+02, & - &5.801210e+01,6.746695e+01,7.755417e+01,8.807853e+01,9.895045e+01, & - &5.414508e+01,6.325102e+01,7.310082e+01,8.346352e+01,9.413405e+01, & - &5.050810e+01,5.919555e+01,6.880164e+01,7.894604e+01,8.947014e+01, & - &4.694504e+01,5.516579e+01,6.442860e+01,7.435118e+01,8.468639e+01, & - &4.338450e+01,5.109390e+01,5.987255e+01,6.948778e+01,7.958252e+01, & - &4.008696e+01,4.727007e+01,5.553455e+01,6.476869e+01,7.460561e+01, & - &3.705061e+01,4.370227e+01,5.146412e+01,6.023081e+01,6.977209e+01, & - &3.439948e+01,4.060892e+01,4.788176e+01,5.616993e+01,6.534379e+01, & - &3.194086e+01,3.783817e+01,4.463284e+01,5.246285e+01,6.121591e+01, & - &2.958361e+01,3.525297e+01,4.157729e+01,4.895064e+01,5.725126e+01, & - &2.731090e+01,3.277246e+01,3.873209e+01,4.563616e+01,5.349601e+01, & - &2.529820e+01,3.057463e+01,3.628503e+01,4.273927e+01,5.017995e+01, & - &2.344008e+01,2.853781e+01,3.405804e+01,4.013056e+01,4.715601e+01, & - &2.167154e+01,2.656373e+01,3.191402e+01,3.767986e+01,4.427699e+01, & - &1.996712e+01,2.465091e+01,2.984634e+01,3.538524e+01,4.156892e+01, & - &1.839436e+01,2.289399e+01,2.791648e+01,3.329524e+01,3.912318e+01, & - &1.766301e+01,2.207220e+01,2.698412e+01,3.227612e+01,3.792807e+01/ - data absb(:,11) / & - &1.931224e+02,1.912925e+02,1.899348e+02,1.889034e+02,1.875543e+02, & - &2.126615e+02,2.111008e+02,2.099126e+02,2.086784e+02,2.071590e+02, & - &2.322375e+02,2.311117e+02,2.300012e+02,2.285656e+02,2.276246e+02, & - &2.515896e+02,2.506855e+02,2.497120e+02,2.490502e+02,2.489167e+02, & - &2.700929e+02,2.698769e+02,2.699093e+02,2.703922e+02,2.710925e+02, & - &2.891880e+02,2.902440e+02,2.916390e+02,2.932258e+02,2.947014e+02, & - &3.104381e+02,3.128147e+02,3.155465e+02,3.180659e+02,3.199248e+02, & - &3.309244e+02,3.344626e+02,3.380007e+02,3.410408e+02,3.430331e+02, & - &3.505686e+02,3.551533e+02,3.594078e+02,3.626118e+02,3.648546e+02, & - &3.682823e+02,3.737862e+02,3.784462e+02,3.820444e+02,3.847799e+02, & - &3.841941e+02,3.906630e+02,3.958466e+02,3.998625e+02,4.032392e+02, & - &3.963619e+02,4.035226e+02,4.095313e+02,4.143489e+02,4.183126e+02, & - &4.069009e+02,4.149555e+02,4.216588e+02,4.272368e+02,4.315240e+02, & - &4.165344e+02,4.254971e+02,4.329496e+02,4.389295e+02,4.435671e+02, & - &4.246797e+02,4.345252e+02,4.426663e+02,4.491365e+02,4.541556e+02, & - &4.316630e+02,4.424493e+02,4.512311e+02,4.581304e+02,4.636006e+02, & - &4.405873e+02,4.520082e+02,4.611718e+02,4.685377e+02,4.743722e+02, & - &4.499807e+02,4.620768e+02,4.716328e+02,4.797087e+02,4.864935e+02, & - &4.614128e+02,4.738287e+02,4.843799e+02,4.932977e+02,5.011242e+02, & - &4.738580e+02,4.870189e+02,4.984782e+02,5.085651e+02,5.169249e+02, & - &4.877885e+02,5.022640e+02,5.147064e+02,5.251710e+02,5.342835e+02, & - &5.026625e+02,5.177709e+02,5.308852e+02,5.421603e+02,5.519907e+02, & - &5.172950e+02,5.335453e+02,5.475194e+02,5.599423e+02,5.714196e+02, & - &5.314931e+02,5.492259e+02,5.644859e+02,5.785414e+02,5.925635e+02, & - &5.357210e+02,5.544244e+02,5.705716e+02,5.856143e+02,6.008257e+02, & - &5.394705e+02,5.592167e+02,5.762756e+02,5.923629e+02,6.087428e+02, & - &5.434756e+02,5.643175e+02,5.824370e+02,5.996639e+02,6.173595e+02, & - &5.388928e+02,5.602757e+02,5.789882e+02,5.965615e+02,6.139047e+02, & - &5.327970e+02,5.548154e+02,5.741792e+02,5.918632e+02,6.088264e+02, & - &5.263889e+02,5.490845e+02,5.692468e+02,5.869156e+02,6.038260e+02, & - &5.167422e+02,5.399550e+02,5.605739e+02,5.784323e+02,5.952043e+02, & - &5.053631e+02,5.291819e+02,5.501952e+02,5.686760e+02,5.850875e+02, & - &4.937186e+02,5.182189e+02,5.398021e+02,5.587936e+02,5.750517e+02, & - &4.809817e+02,5.065448e+02,5.286623e+02,5.480521e+02,5.649532e+02, & - &4.659673e+02,4.934054e+02,5.163188e+02,5.363752e+02,5.537720e+02, & - &4.503038e+02,4.796865e+02,5.037309e+02,5.244010e+02,5.423439e+02, & - &4.338183e+02,4.649754e+02,4.908788e+02,5.122698e+02,5.308364e+02, & - &4.179731e+02,4.506003e+02,4.782159e+02,5.005590e+02,5.195977e+02, & - &4.027101e+02,4.358727e+02,4.649694e+02,4.889579e+02,5.085169e+02, & - &3.876592e+02,4.207693e+02,4.513894e+02,4.769579e+02,4.973522e+02, & - &3.723186e+02,4.059288e+02,4.371213e+02,4.640164e+02,4.860668e+02, & - &3.582162e+02,3.923038e+02,4.233197e+02,4.515653e+02,4.749222e+02, & - &3.448894e+02,3.789284e+02,4.101893e+02,4.389201e+02,4.633757e+02, & - &3.314966e+02,3.656252e+02,3.973989e+02,4.259402e+02,4.515596e+02, & - &3.182313e+02,3.527076e+02,3.843700e+02,4.131777e+02,4.391890e+02, & - &3.055706e+02,3.403364e+02,3.720066e+02,4.011747e+02,4.269625e+02, & - &2.996412e+02,3.343212e+02,3.658133e+02,3.946342e+02,4.201230e+02/ - data absb(:,12) / & - &3.780368e+02,3.688750e+02,3.608506e+02,3.534786e+02,3.492787e+02, & - &4.362766e+02,4.254542e+02,4.156354e+02,4.075294e+02,4.029807e+02, & - &5.012988e+02,4.883620e+02,4.767737e+02,4.686606e+02,4.635288e+02, & - &5.731833e+02,5.580732e+02,5.454150e+02,5.369628e+02,5.306660e+02, & - &6.521205e+02,6.343109e+02,6.218062e+02,6.123808e+02,6.048955e+02, & - &7.364882e+02,7.184149e+02,7.050038e+02,6.945832e+02,6.896292e+02, & - &8.268445e+02,8.080390e+02,7.933064e+02,7.859296e+02,7.891505e+02, & - &9.189818e+02,8.971506e+02,8.820289e+02,8.777612e+02,8.873939e+02, & - &1.010509e+03,9.855601e+02,9.713179e+02,9.718354e+02,9.865349e+02, & - &1.097046e+03,1.072469e+03,1.062998e+03,1.068993e+03,1.088886e+03, & - &1.182124e+03,1.160146e+03,1.155797e+03,1.168781e+03,1.194951e+03, & - &1.264033e+03,1.247689e+03,1.249332e+03,1.268976e+03,1.305250e+03, & - &1.343544e+03,1.333282e+03,1.342829e+03,1.372169e+03,1.421635e+03, & - &1.419079e+03,1.415170e+03,1.433977e+03,1.476134e+03,1.539258e+03, & - &1.492454e+03,1.497983e+03,1.529678e+03,1.586394e+03,1.665746e+03, & - &1.565580e+03,1.584400e+03,1.632332e+03,1.707713e+03,1.806300e+03, & - &1.646201e+03,1.684044e+03,1.754265e+03,1.852680e+03,1.976444e+03, & - &1.740768e+03,1.803565e+03,1.902221e+03,2.028861e+03,2.182463e+03, & - &1.862990e+03,1.961769e+03,2.094563e+03,2.260113e+03,2.453211e+03, & - &2.018773e+03,2.158453e+03,2.335034e+03,2.544838e+03,2.786622e+03, & - &2.220969e+03,2.409249e+03,2.638005e+03,2.905795e+03,3.205559e+03, & - &2.456406e+03,2.700361e+03,2.988734e+03,3.319332e+03,3.683936e+03, & - &2.729022e+03,3.034968e+03,3.392596e+03,3.794504e+03,4.231126e+03, & - &3.034790e+03,3.412380e+03,3.848808e+03,4.332657e+03,4.851384e+03, & - &3.138300e+03,3.541715e+03,4.008900e+03,4.525395e+03,5.078890e+03, & - &3.238198e+03,3.667942e+03,4.165604e+03,4.716207e+03,5.306120e+03, & - &3.351517e+03,3.811977e+03,4.344980e+03,4.935716e+03,5.567487e+03, & - &3.265576e+03,3.710996e+03,4.229717e+03,4.809055e+03,5.435551e+03, & - &3.157202e+03,3.580177e+03,4.075926e+03,4.636599e+03,5.248533e+03, & - &3.054242e+03,3.453423e+03,3.925973e+03,4.468737e+03,5.064125e+03, & - &2.898513e+03,3.258483e+03,3.691784e+03,4.196035e+03,4.755592e+03, & - &2.736095e+03,3.050587e+03,3.438194e+03,3.894020e+03,4.411052e+03, & - &2.594273e+03,2.865033e+03,3.207052e+03,3.616592e+03,4.089839e+03, & - &2.468612e+03,2.693181e+03,2.989850e+03,3.352711e+03,3.777318e+03, & - &2.360743e+03,2.532406e+03,2.780867e+03,3.094088e+03,3.468649e+03, & - &2.279508e+03,2.400012e+03,2.600296e+03,2.866239e+03,3.192113e+03, & - &2.224735e+03,2.297250e+03,2.447001e+03,2.667044e+03,2.945340e+03, & - &2.192954e+03,2.222736e+03,2.325953e+03,2.502493e+03,2.737490e+03, & - &2.178512e+03,2.172188e+03,2.233319e+03,2.364144e+03,2.558439e+03, & - &2.178778e+03,2.141716e+03,2.162094e+03,2.249610e+03,2.403009e+03, & - &2.195528e+03,2.126633e+03,2.113046e+03,2.160317e+03,2.270019e+03, & - &2.221353e+03,2.124161e+03,2.083503e+03,2.093911e+03,2.164137e+03, & - &2.254138e+03,2.134973e+03,2.066684e+03,2.047087e+03,2.081920e+03, & - &2.296418e+03,2.156875e+03,2.061412e+03,2.017148e+03,2.017524e+03, & - &2.346165e+03,2.186836e+03,2.069920e+03,1.999462e+03,1.971865e+03, & - &2.400152e+03,2.223703e+03,2.087793e+03,1.992410e+03,1.942515e+03, & - &2.423059e+03,2.238157e+03,2.091768e+03,1.983964e+03,1.919461e+03/ - - -! the array selfref contains the coefficient of the water vapor -! self-continuum (including the energy term). the first index -! refers to temperature in 7.2 degree increments. for instance, -! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, -! etc. the second index runs over the g-channel (1 to NG09=12). - - data selfref(:, 1) / & - &2.834130e-02,2.514430e-02,2.230780e-02,1.979140e-02,1.755880e-02, & - &1.557800e-02,1.382070e-02,1.226170e-02,1.087850e-02,9.651320e-03/ - data selfref(:, 2) / & - &3.015060e-02,2.695060e-02,2.409010e-02,2.153330e-02,1.924780e-02, & - &1.720490e-02,1.537890e-02,1.374660e-02,1.228760e-02,1.098340e-02/ - data selfref(:, 3) / & - &4.248990e-02,3.771380e-02,3.347450e-02,2.971180e-02,2.637200e-02, & - &2.340770e-02,2.077650e-02,1.844110e-02,1.636820e-02,1.452830e-02/ - data selfref(:, 4) / & - &5.786480e-02,5.169880e-02,4.618990e-02,4.126790e-02,3.687050e-02, & - &3.294160e-02,2.943140e-02,2.629520e-02,2.349320e-02,2.098980e-02/ - data selfref(:, 5) / & - &6.963670e-02,6.367160e-02,5.821750e-02,5.323060e-02,4.867090e-02, & - &4.450180e-02,4.068980e-02,3.720430e-02,3.401740e-02,3.110340e-02/ - data selfref(:, 6) / & - &6.040730e-02,5.908560e-02,5.779290e-02,5.652840e-02,5.529160e-02, & - &5.408190e-02,5.289860e-02,5.174130e-02,5.060920e-02,4.950200e-02/ - data selfref(:, 7) / & - &6.194600e-02,6.028120e-02,5.866120e-02,5.708470e-02,5.555060e-02, & - &5.405770e-02,5.260490e-02,5.119120e-02,4.981550e-02,4.847670e-02/ - data selfref(:, 8) / & - &6.869390e-02,6.584290e-02,6.311020e-02,6.049090e-02,5.798040e-02, & - &5.557400e-02,5.326750e-02,5.105670e-02,4.893770e-02,4.690670e-02/ - data selfref(:, 9) / & - &8.210988e-02,7.804555e-02,7.418377e-02,7.051446e-02,6.702793e-02, & - &6.371494e-02,6.056690e-02,5.757561e-02,5.473304e-02,5.203190e-02/ - data selfref(:,10) / & - &9.475291e-02,8.994983e-02,8.539204e-02,8.106695e-02,7.696255e-02, & - &7.306744e-02,6.937096e-02,6.586292e-02,6.253359e-02,5.937374e-02/ - data selfref(:,11) / & - &1.016067e-01,9.699140e-02,9.259783e-02,8.841508e-02,8.443228e-02, & - &8.063939e-02,7.702699e-02,7.358585e-02,7.030761e-02,6.718399e-02/ - data selfref(:,12) / & - &1.260543e-01,1.216079e-01,1.173253e-01,1.131992e-01,1.092246e-01, & - &1.053955e-01,1.017062e-01,9.815101e-02,9.472512e-02,9.142355e-02/ - - data absn2o / & - &3.262670e-01,2.428690e+00,1.154550e+01,7.394780e+00,5.165500e+00, & - &2.544740e+00,3.530820e+00,3.822780e+00,1.700274e+00,6.987210e-02, & - &1.042138e-03,0.000000e+00,2.086320e-01,1.118650e+00,4.959750e+00, & - &8.109070e+00,1.104080e+01,5.454600e+00,4.186110e+00,3.534220e+00, & - &2.327910e+00,4.266180e-01,8.322215e-04,5.993646e-10,6.200220e-02, & - &2.695210e-01,9.819280e-01,1.650040e+00,3.080890e+00,5.386960e+00, & - &1.146000e+01,2.412110e+01,1.543462e+01,4.588511e-01,2.638398e-01, & - &5.038489e-11 / - - data fracrefa(:,:) / & - & 0.1689890027, 0.1589830071, 0.1357530057, 0.1260090023, & - & 0.1154579967, 0.0987917036, 0.0810682997, 0.0606344007, & - & 0.0441053994, 0.0062541403, 0.0033854898, 0.0005707100, & - & 0.1820939928, 0.1531510055, 0.1357100010, 0.1250499934, & - & 0.1137909964, 0.0968080983, 0.0800857022, 0.0597027987, & - & 0.0435624272, 0.0061874399, 0.0033487598, 0.0005111800, & - & 0.1845950037, 0.1551200002, 0.1339550018, 0.1257680058, & - & 0.1127680019, 0.0964519009, 0.0795665011, 0.0590334013, & - & 0.0429927595, 0.0061297100, 0.0031633298, 0.0004592700, & - & 0.1845880002, 0.1585990041, 0.1327809989, 0.1258929968, & - & 0.1127270013, 0.0959966034, 0.0790302977, 0.0584359989, & - & 0.0424858108, 0.0060179802, 0.0029867599, 0.0004592700, & - & 0.1845930070, 0.1617610008, 0.1323499978, 0.1252820045, & - & 0.1123709977, 0.0961884037, 0.0783376023, 0.0580076985, & - & 0.0419586301, 0.0058080801, 0.0028847801, 0.0004592700, & - & 0.1845439970, 0.1650529951, 0.1322129965, 0.1247659996, & - & 0.1115830019, 0.0961811990, 0.0779734030, 0.0574037991, & - & 0.0413551107, 0.0055851396, 0.0028845600, 0.0004592700, & - & 0.1845200062, 0.1669750065, 0.1344549954, 0.1239129975, & - & 0.1105910018, 0.0959689021, 0.0776105002, 0.0564320013, & - & 0.0406360626, 0.0055564800, 0.0028846501, 0.0004592700, & - & 0.1846099943, 0.1685449928, 0.1392229944, 0.1226639971, & - & 0.1096220016, 0.0945203006, 0.0765379965, 0.0555134006, & - & 0.0398670286, 0.0055567101, 0.0028843801, 0.0004592700, & - & 0.1831250042, 0.1678750068, 0.1472070068, 0.1276649982, & - & 0.1089090034, 0.0893552974, 0.0731087029, 0.0544314012, & - & 0.0394282602, 0.0055603101, 0.0028768200, 0.0004592700 / - data fracrefb / & - & 0.2014860064, 0.1525270045, 0.1337649971, 0.1218459979, & - & 0.1076780036, 0.0930740982, 0.0767456964, 0.0587694012, & - & 0.0442609191, 0.0061685001, 0.0031942599, 0.0004852000 / - - data h2oref / & - & 1.8759999e-02, 1.2223309e-02, 5.8908667e-03, 2.7675382e-03, & - & 1.4065107e-03, 7.5969833e-04, 3.8875898e-04, 1.6542293e-04, & - & 3.7189537e-05, 7.4764857e-06, 4.3081886e-06, 3.3319423e-06, & - & 3.2039343e-06 / - - data ch4ref / & - & 1.7000001e-06, 1.7000001e-06, 1.6998713e-06, 1.6904165e-06, & - & 1.6671424e-06, 1.6350652e-06, 1.6097551e-06, 1.5590465e-06, & - & 1.5119849e-06, 1.4741138e-06, 1.4384609e-06, 1.4002215e-06, & - & 1.3573376e-06 / - - data n2oref / & - & 3.20000e-07,3.20000e-07,3.20000e-07,3.20000e-07,3.20000e-07, & - & 3.19652e-07,3.15324e-07,3.03830e-07,2.94221e-07,2.84953e-07, & - & 2.76714e-07,2.64709e-07,2.42847e-07 / - - data etaref / & - & 0.,0.125,0.25,0.375,0.5,0.625,0.75,0.875,0.96,0.99,1.0 / - - -!........................................! - end module module_radlw_kgb09 ! -!========================================! - - - -!========================================! - module module_radlw_kgb10 ! -!........................................! -! - use machine, only : kind_phys - use module_radlw_parameters, only : NG10 -! - implicit none -! - private -! - integer, public :: MSA10, MSB10 - parameter (MSA10=65, MSB10=235) - - real (kind=kind_phys), public :: & - & absa(MSA10,NG10),absb(MSB10,NG10), fracrefa(NG10), & - & fracrefb(NG10) - -! the array absa(65,NG10) = ka(5,13,NG10) contains absorption coefs at -! the NG10=6 chosen g-values for a range of pressure levels > ~100mb -! and temperatures. the first index in the array, jt, which runs from -! 1 to 5, corresponds to different temperatures. more specifically, -! jt = 1-5 means that the data are for the corresponding temperature of -! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the -! second index, jp, runs from 1 to 13 and refers to the corresponding -! pressure level in pref (e.g. jp = 1 is for a pressure of 1053.63 mb). -! the third index, ig, goes from 1 to NG10=6, and tells us which -! g-interval the absorption coefficients are for. - - data absa(:,1) / & - &5.955061e-02,6.102019e-02,6.259486e-02,6.434516e-02,6.613583e-02, & - &4.672662e-02,4.811792e-02,4.962258e-02,5.122062e-02,5.276341e-02, & - &3.621289e-02,3.752366e-02,3.890708e-02,4.032513e-02,4.170641e-02, & - &2.849955e-02,2.968993e-02,3.090369e-02,3.212063e-02,3.333300e-02, & - &2.270646e-02,2.376433e-02,2.480857e-02,2.584035e-02,2.686432e-02, & - &1.815413e-02,1.908539e-02,1.999033e-02,2.086246e-02,2.172269e-02, & - &1.455984e-02,1.537970e-02,1.617063e-02,1.691992e-02,1.764588e-02, & - &1.182296e-02,1.253520e-02,1.325350e-02,1.391881e-02,1.454534e-02, & - &1.029570e-02,1.100154e-02,1.170777e-02,1.240996e-02,1.308649e-02, & - &1.095668e-02,1.190235e-02,1.284578e-02,1.377747e-02,1.464099e-02, & - &1.063071e-02,1.168762e-02,1.271464e-02,1.369649e-02,1.459564e-02, & - &9.565019e-03,1.058155e-02,1.157120e-02,1.249237e-02,1.333666e-02, & - &8.037396e-03,8.900117e-03,9.727569e-03,1.049402e-02,1.120194e-02/ - data absa(:,2) / & - &1.440417e-01,1.469509e-01,1.497671e-01,1.527257e-01,1.561120e-01, & - &1.149540e-01,1.178211e-01,1.206337e-01,1.235773e-01,1.267090e-01, & - &9.083404e-02,9.361973e-02,9.629960e-02,9.900734e-02,1.018986e-01, & - &7.258354e-02,7.518114e-02,7.763869e-02,8.006838e-02,8.263766e-02, & - &5.853063e-02,6.083499e-02,6.303188e-02,6.520328e-02,6.747472e-02, & - &4.735853e-02,4.937379e-02,5.132171e-02,5.325849e-02,5.523358e-02, & - &3.843164e-02,4.019459e-02,4.191066e-02,4.361494e-02,4.533131e-02, & - &3.150959e-02,3.305135e-02,3.452636e-02,3.601404e-02,3.751886e-02, & - &2.810000e-02,2.946374e-02,3.078151e-02,3.208875e-02,3.340089e-02, & - &3.271293e-02,3.483564e-02,3.629721e-02,3.762486e-02,3.905132e-02, & - &3.365123e-02,3.599019e-02,3.809780e-02,3.965945e-02,4.114706e-02, & - &3.159606e-02,3.387543e-02,3.589115e-02,3.763831e-02,3.903875e-02, & - &2.682820e-02,2.874196e-02,3.046228e-02,3.194459e-02,3.309736e-02/ - data absa(:,3) / & - &4.356217e-01,4.560605e-01,4.749672e-01,4.925307e-01,5.084435e-01, & - &3.532237e-01,3.708910e-01,3.874118e-01,4.022279e-01,4.154377e-01, & - &2.817856e-01,2.972356e-01,3.113224e-01,3.239935e-01,3.354283e-01, & - &2.256788e-01,2.391657e-01,2.513030e-01,2.624586e-01,2.725981e-01, & - &1.810898e-01,1.927988e-01,2.033976e-01,2.132420e-01,2.223744e-01, & - &1.446372e-01,1.548886e-01,1.641815e-01,1.728690e-01,1.810250e-01, & - &1.153620e-01,1.243501e-01,1.325426e-01,1.401904e-01,1.473625e-01, & - &9.237386e-02,1.002086e-01,1.074173e-01,1.141047e-01,1.203941e-01, & - &7.671020e-02,8.351758e-02,8.986732e-02,9.579606e-02,1.014003e-01, & - &7.797295e-02,8.291502e-02,8.861026e-02,9.429142e-02,9.971347e-02, & - &7.906521e-02,8.268867e-02,8.670134e-02,9.138244e-02,9.628069e-02, & - &7.418576e-02,7.693955e-02,8.019060e-02,8.400419e-02,8.847016e-02, & - &6.331097e-02,6.573573e-02,6.859384e-02,7.198081e-02,7.599425e-02/ - data absa(:,4) / & - &2.374896e+00,2.488938e+00,2.592409e+00,2.688907e+00,2.771950e+00, & - &2.071008e+00,2.176421e+00,2.275263e+00,2.364412e+00,2.443353e+00, & - &1.755216e+00,1.854904e+00,1.945683e+00,2.027866e+00,2.099166e+00, & - &1.468684e+00,1.560142e+00,1.644341e+00,1.719164e+00,1.785102e+00, & - &1.215902e+00,1.299500e+00,1.375945e+00,1.444434e+00,1.504967e+00, & - &9.933330e-01,1.068989e+00,1.138654e+00,1.201624e+00,1.257425e+00, & - &8.031874e-01,8.716916e-01,9.344817e-01,9.911501e-01,1.041305e+00, & - &6.442665e-01,7.057762e-01,7.618801e-01,8.121651e-01,8.574181e-01, & - &5.155923e-01,5.699924e-01,6.192293e-01,6.640261e-01,7.052321e-01, & - &4.289777e-01,4.758530e-01,5.188184e-01,5.583524e-01,5.950065e-01, & - &3.784907e-01,4.178330e-01,4.547144e-01,4.891034e-01,5.210695e-01, & - &3.308372e-01,3.646865e-01,3.969130e-01,4.269228e-01,4.548919e-01, & - &2.820456e-01,3.111159e-01,3.386662e-01,3.643700e-01,3.882074e-01/ - data absa(:,5) / & - &1.302180e+01,1.372726e+01,1.439242e+01,1.497421e+01,1.553336e+01, & - &1.331218e+01,1.406522e+01,1.477874e+01,1.543958e+01,1.601381e+01, & - &1.323621e+01,1.405469e+01,1.481460e+01,1.553656e+01,1.618100e+01, & - &1.289295e+01,1.377873e+01,1.461134e+01,1.537532e+01,1.606681e+01, & - &1.234182e+01,1.329896e+01,1.417677e+01,1.499804e+01,1.574451e+01, & - &1.160307e+01,1.260826e+01,1.353863e+01,1.439909e+01,1.518414e+01, & - &1.073853e+01,1.176998e+01,1.273755e+01,1.363696e+01,1.445768e+01, & - &9.775392e+00,1.082113e+01,1.181470e+01,1.274035e+01,1.358460e+01, & - &8.754798e+00,9.808460e+00,1.081249e+01,1.174275e+01,1.261866e+01, & - &7.813394e+00,8.861540e+00,9.847984e+00,1.078561e+01,1.165079e+01, & - &7.366029e+00,8.366948e+00,9.297867e+00,1.017034e+01,1.096239e+01, & - &6.883156e+00,7.799749e+00,8.659523e+00,9.453840e+00,1.019805e+01, & - &6.334818e+00,7.174643e+00,7.958723e+00,8.699636e+00,9.392205e+00/ - data absa(:,6) / & - &3.800557e+01,3.982790e+01,4.188386e+01,4.338985e+01,4.507821e+01, & - &4.350526e+01,4.579300e+01,4.824468e+01,5.024699e+01,5.230871e+01, & - &4.932739e+01,5.245598e+01,5.536251e+01,5.763368e+01,6.016662e+01, & - &5.535187e+01,5.888930e+01,6.228936e+01,6.514977e+01,6.827814e+01, & - &6.147580e+01,6.557922e+01,6.970208e+01,7.309303e+01,7.668188e+01, & - &6.742628e+01,7.231519e+01,7.670844e+01,8.121731e+01,8.551340e+01, & - &7.269618e+01,7.868272e+01,8.408723e+01,8.975346e+01,9.432200e+01, & - &7.814375e+01,8.518819e+01,9.143570e+01,9.813556e+01,1.035297e+02, & - &8.323735e+01,9.118373e+01,9.831161e+01,1.060652e+02,1.123249e+02, & - &8.787476e+01,9.688428e+01,1.055216e+02,1.139757e+02,1.213277e+02, & - &9.609115e+01,1.065758e+02,1.160254e+02,1.253711e+02,1.343534e+02, & - &1.046507e+02,1.164765e+02,1.270979e+02,1.377969e+02,1.474844e+02, & - &1.135871e+02,1.264661e+02,1.384379e+02,1.501340e+02,1.604854e+02/ - -! the array absb(235,NG10) = kb(5,13:59,NG10) contains absorption coefs -! at the NG10=6 chosen g-values for a range of pressure levels < ~100mb -! and temperatures. the first index in the array, jt, which runs from -! 1 to 5, corresponds to different temperatures. more specifically, -! jt = 1-5 means that the data are for the corresponding temperature of -! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the -! second index, jp, runs from 13 to 59 and refers to the jpth reference -! pressure level (see taumol.f for the value of these pressure levels -! in mb). the third index, ig, goes from 1 to NG10=6, and tells us -! which g-interval the absorption coefficients are for. - - data absb(:,1) / & - &8.038042e-03,8.900168e-03,9.727519e-03,1.049397e-02,1.120178e-02, & - &6.748861e-03,7.463630e-03,8.136769e-03,8.765063e-03,9.341115e-03, & - &5.576981e-03,6.147601e-03,6.682812e-03,7.181872e-03,7.634300e-03, & - &4.558548e-03,5.003095e-03,5.422052e-03,5.811790e-03,6.162137e-03, & - &3.697665e-03,4.043394e-03,4.369024e-03,4.670231e-03,4.941957e-03, & - &2.973121e-03,3.238719e-03,3.489168e-03,3.719987e-03,3.930194e-03, & - &2.399975e-03,2.606905e-03,2.801498e-03,2.981058e-03,3.145020e-03, & - &1.959023e-03,2.122892e-03,2.276644e-03,2.418967e-03,2.548282e-03, & - &1.603131e-03,1.733572e-03,1.855959e-03,1.969200e-03,2.071775e-03, & - &1.318572e-03,1.422117e-03,1.519284e-03,1.608902e-03,1.689973e-03, & - &1.084730e-03,1.167029e-03,1.244260e-03,1.315159e-03,1.379205e-03, & - &8.950486e-04,9.609209e-04,1.022400e-03,1.078645e-03,1.129328e-03, & - &7.392647e-04,7.921062e-04,8.410027e-04,8.855462e-04,9.258128e-04, & - &6.123069e-04,6.545715e-04,6.934278e-04,7.287878e-04,7.606560e-04, & - &5.075318e-04,5.412336e-04,5.721294e-04,6.002667e-04,6.255090e-04, & - &4.208058e-04,4.476205e-04,4.722475e-04,4.946165e-04,5.145969e-04, & - &3.482006e-04,3.695061e-04,3.890786e-04,4.067652e-04,4.225445e-04, & - &2.876063e-04,3.045221e-04,3.200703e-04,3.340155e-04,3.464501e-04, & - &2.367327e-04,2.501489e-04,2.624147e-04,2.733659e-04,2.831479e-04, & - &1.950041e-04,2.056617e-04,2.153124e-04,2.239266e-04,2.316190e-04, & - &1.607058e-04,1.691503e-04,1.767363e-04,1.835310e-04,1.895676e-04, & - &1.326124e-04,1.393320e-04,1.453476e-04,1.507195e-04,1.554973e-04, & - &1.089362e-04,1.143211e-04,1.191512e-04,1.234493e-04,1.272760e-04, & - &8.904905e-05,9.342821e-05,9.734727e-05,1.008329e-04,1.039409e-04, & - &7.257020e-05,7.620290e-05,7.946388e-05,8.235835e-05,8.493806e-05, & - &5.912033e-05,6.213921e-05,6.485594e-05,6.726407e-05,6.940458e-05, & - &4.815971e-05,5.066456e-05,5.292930e-05,5.493210e-05,5.670789e-05, & - &3.918110e-05,4.128795e-05,4.320737e-05,4.490503e-05,4.640192e-05, & - &3.186310e-05,3.363732e-05,3.526439e-05,3.670837e-05,3.797737e-05, & - &2.590375e-05,2.739777e-05,2.877148e-05,3.000227e-05,3.108036e-05, & - &2.104498e-05,2.231761e-05,2.348828e-05,2.454534e-05,2.547097e-05, & - &1.708481e-05,1.817664e-05,1.917777e-05,2.008613e-05,2.088832e-05, & - &1.386350e-05,1.479824e-05,1.565632e-05,1.643700e-05,1.712818e-05, & - &1.123001e-05,1.202821e-05,1.276801e-05,1.344258e-05,1.403967e-05, & - &9.067471e-06,9.750651e-06,1.038997e-05,1.097576e-05,1.149753e-05, & - &7.312784e-06,7.897798e-06,8.449550e-06,8.958833e-06,9.415501e-06, & - &5.890452e-06,6.391910e-06,6.867433e-06,7.308789e-06,7.709642e-06, & - &4.744245e-06,5.177697e-06,5.585843e-06,5.967307e-06,6.317189e-06, & - &3.814694e-06,4.193320e-06,4.544403e-06,4.873611e-06,5.178039e-06, & - &3.057757e-06,3.390208e-06,3.695734e-06,3.980368e-06,4.244393e-06, & - &2.443252e-06,2.732971e-06,3.002987e-06,3.250113e-06,3.478975e-06, & - &1.952900e-06,2.204447e-06,2.441275e-06,2.659162e-06,2.858241e-06, & - &1.561907e-06,1.776746e-06,1.983209e-06,2.176387e-06,2.351348e-06, & - &1.249293e-06,1.428912e-06,1.609234e-06,1.778702e-06,1.934318e-06, & - &9.982784e-07,1.149548e-06,1.303230e-06,1.452049e-06,1.590884e-06, & - &7.981844e-07,9.270574e-07,1.055924e-06,1.185760e-06,1.308398e-06, & - &6.536974e-07,7.630563e-07,8.717321e-07,9.810954e-07,1.087053e-06/ - data absb(:,2) / & - &2.682824e-02,2.874196e-02,3.046176e-02,3.194511e-02,3.309584e-02, & - &2.258897e-02,2.415576e-02,2.560839e-02,2.676300e-02,2.769700e-02, & - &1.857947e-02,1.984472e-02,2.101527e-02,2.185989e-02,2.261614e-02, & - &1.506163e-02,1.607756e-02,1.695683e-02,1.758805e-02,1.819420e-02, & - &1.213062e-02,1.293653e-02,1.357049e-02,1.405958e-02,1.453700e-02, & - &9.675707e-03,1.030203e-02,1.074284e-02,1.112511e-02,1.149281e-02, & - &7.773506e-03,8.247525e-03,8.571980e-03,8.870209e-03,9.159289e-03, & - &6.330214e-03,6.684110e-03,6.933291e-03,7.169592e-03,7.402369e-03, & - &5.173323e-03,5.431161e-03,5.628360e-03,5.817140e-03,6.006162e-03, & - &4.240603e-03,4.421479e-03,4.579204e-03,4.731352e-03,4.885194e-03, & - &3.466482e-03,3.601497e-03,3.727893e-03,3.851365e-03,3.976602e-03, & - &2.840687e-03,2.946599e-03,3.048269e-03,3.148672e-03,3.250849e-03, & - &2.328821e-03,2.413752e-03,2.495812e-03,2.578086e-03,2.661604e-03, & - &1.913640e-03,1.982306e-03,2.049040e-03,2.116621e-03,2.185429e-03, & - &1.574501e-03,1.630229e-03,1.684907e-03,1.740226e-03,1.797151e-03, & - &1.296732e-03,1.341911e-03,1.386734e-03,1.432134e-03,1.479527e-03, & - &1.065582e-03,1.102444e-03,1.139177e-03,1.176641e-03,1.215991e-03, & - &8.744587e-04,9.045583e-04,9.345796e-04,9.657291e-04,9.984679e-04, & - &7.150919e-04,7.395201e-04,7.642240e-04,7.901341e-04,8.174743e-04, & - &5.857515e-04,6.056852e-04,6.262426e-04,6.477861e-04,6.706266e-04, & - &4.803659e-04,4.967849e-04,5.139607e-04,5.318244e-04,5.509519e-04, & - &3.952897e-04,4.089308e-04,4.232160e-04,4.381074e-04,4.541066e-04, & - &3.246046e-04,3.359483e-04,3.477640e-04,3.601226e-04,3.733856e-04, & - &2.659152e-04,2.753152e-04,2.850554e-04,2.952413e-04,3.061087e-04, & - &2.178080e-04,2.255465e-04,2.335799e-04,2.419133e-04,2.507730e-04, & - &1.784032e-04,1.847885e-04,1.913874e-04,1.982091e-04,2.054408e-04, & - &1.461379e-04,1.514024e-04,1.568295e-04,1.624015e-04,1.683163e-04, & - &1.198661e-04,1.242134e-04,1.286637e-04,1.332287e-04,1.380538e-04, & - &9.835332e-05,1.019440e-04,1.056031e-04,1.093400e-04,1.132813e-04, & - &8.071249e-05,8.368377e-05,8.669660e-05,8.976532e-05,9.297430e-05, & - &6.639002e-05,6.884896e-05,7.133455e-05,7.385862e-05,7.647825e-05, & - &5.469959e-05,5.673675e-05,5.879368e-05,6.087735e-05,6.301884e-05, & - &4.509903e-05,4.679326e-05,4.850169e-05,5.022691e-05,5.198663e-05, & - &3.719576e-05,3.861947e-05,4.003529e-05,4.146387e-05,4.291600e-05, & - &3.063950e-05,3.188510e-05,3.306279e-05,3.424822e-05,3.545096e-05, & - &2.510621e-05,2.635823e-05,2.734484e-05,2.832848e-05,2.932290e-05, & - &2.048890e-05,2.179001e-05,2.264858e-05,2.346765e-05,2.429128e-05, & - &1.674948e-05,1.794827e-05,1.879858e-05,1.948669e-05,2.017014e-05, & - &1.371054e-05,1.474162e-05,1.562051e-05,1.621444e-05,1.678342e-05, & - &1.123085e-05,1.211807e-05,1.294467e-05,1.351831e-05,1.399937e-05, & - &9.201723e-06,9.977879e-06,1.069098e-05,1.129014e-05,1.170607e-05, & - &7.554186e-06,8.244479e-06,8.861742e-06,9.427917e-06,9.822923e-06, & - &6.205806e-06,6.831212e-06,7.370277e-06,7.862606e-06,8.269621e-06, & - &5.110127e-06,5.664714e-06,6.144959e-06,6.576984e-06,6.967768e-06, & - &4.222028e-06,4.697714e-06,5.140036e-06,5.520346e-06,5.865897e-06, & - &3.506175e-06,3.911223e-06,4.310054e-06,4.652693e-06,4.957387e-06, & - &2.952326e-06,3.296749e-06,3.638288e-06,3.942917e-06,4.205626e-06/ - data absb(:,3) / & - &6.331003e-02,6.573626e-02,6.859716e-02,7.197564e-02,7.599510e-02, & - &5.352644e-02,5.573078e-02,5.827289e-02,6.138192e-02,6.495852e-02, & - &4.440276e-02,4.639551e-02,4.866288e-02,5.151118e-02,5.462790e-02, & - &3.640131e-02,3.817359e-02,4.024936e-02,4.277093e-02,4.539888e-02, & - &2.965314e-02,3.121469e-02,3.310221e-02,3.525281e-02,3.744792e-02, & - &2.395225e-02,2.532270e-02,2.700550e-02,2.879683e-02,3.061246e-02, & - &1.946836e-02,2.067764e-02,2.212117e-02,2.360812e-02,2.510726e-02, & - &1.603931e-02,1.711128e-02,1.834508e-02,1.959386e-02,2.084209e-02, & - &1.325980e-02,1.421012e-02,1.525030e-02,1.629999e-02,1.733307e-02, & - &1.101849e-02,1.185913e-02,1.273281e-02,1.360801e-02,1.445695e-02, & - &9.175163e-03,9.894972e-03,1.062496e-02,1.134601e-02,1.204422e-02, & - &7.666888e-03,8.270908e-03,8.876057e-03,9.469457e-03,1.004872e-02, & - &6.413755e-03,6.916964e-03,7.419865e-03,7.908503e-03,8.390228e-03, & - &5.379742e-03,5.799491e-03,6.214973e-03,6.620682e-03,7.023258e-03, & - &4.515405e-03,4.865425e-03,5.207840e-03,5.546371e-03,5.883223e-03, & - &3.790081e-03,4.080636e-03,4.365414e-03,4.648130e-03,4.930553e-03, & - &3.178747e-03,3.418945e-03,3.656380e-03,3.892659e-03,4.129859e-03, & - &2.663526e-03,2.862759e-03,3.060604e-03,3.258578e-03,3.457984e-03, & - &2.227752e-03,2.393172e-03,2.558588e-03,2.724896e-03,2.892832e-03, & - &1.864888e-03,2.002973e-03,2.141746e-03,2.281834e-03,2.424662e-03, & - &1.562373e-03,1.678082e-03,1.794848e-03,1.913366e-03,2.035361e-03, & - &1.308864e-03,1.406111e-03,1.504636e-03,1.605664e-03,1.709691e-03, & - &1.089706e-03,1.171506e-03,1.254754e-03,1.340517e-03,1.429106e-03, & - &9.005364e-04,9.692048e-04,1.039540e-03,1.112211e-03,1.187574e-03, & - &7.395960e-04,7.974856e-04,8.568791e-04,9.185701e-04,9.826629e-04, & - &6.069867e-04,6.557758e-04,7.059608e-04,7.582130e-04,8.128685e-04, & - &4.980340e-04,5.391235e-04,5.815018e-04,6.257986e-04,6.723750e-04, & - &4.067818e-04,4.413421e-04,4.770660e-04,5.146199e-04,5.542162e-04, & - &3.318725e-04,3.608986e-04,3.910358e-04,4.228177e-04,4.564243e-04, & - &2.705985e-04,2.949591e-04,3.203352e-04,3.471777e-04,3.756714e-04, & - &2.198382e-04,2.402229e-04,2.615242e-04,2.841165e-04,3.082468e-04, & - &1.782438e-04,1.952465e-04,2.130614e-04,2.320320e-04,2.523632e-04, & - &1.444467e-04,1.585607e-04,1.734484e-04,1.893331e-04,2.064183e-04, & - &1.168021e-04,1.284640e-04,1.408410e-04,1.540920e-04,1.684013e-04, & - &9.412960e-05,1.036390e-04,1.138745e-04,1.248733e-04,1.367771e-04, & - &7.607527e-05,8.358939e-05,9.202096e-05,1.011190e-04,1.110018e-04, & - &6.166514e-05,6.745721e-05,7.432568e-05,8.183265e-05,9.001216e-05, & - &5.018275e-05,5.471508e-05,6.016976e-05,6.634020e-05,7.310123e-05, & - &4.098045e-05,4.455884e-05,4.879490e-05,5.383134e-05,5.940990e-05, & - &3.358973e-05,3.637709e-05,3.968264e-05,4.369630e-05,4.828176e-05, & - &2.766285e-05,2.979210e-05,3.239729e-05,3.550718e-05,3.924663e-05, & - &2.297837e-05,2.455597e-05,2.659651e-05,2.902125e-05,3.202674e-05, & - &1.924446e-05,2.036810e-05,2.193482e-05,2.385255e-05,2.620763e-05, & - &1.623859e-05,1.701032e-05,1.817877e-05,1.967206e-05,2.151335e-05, & - &1.381889e-05,1.432765e-05,1.515816e-05,1.630113e-05,1.774975e-05, & - &1.184980e-05,1.217361e-05,1.274528e-05,1.359795e-05,1.472815e-05, & - &1.010039e-05,1.037190e-05,1.080165e-05,1.146301e-05,1.238230e-05/ - data absb(:,4) / & - &2.819713e-01,3.110758e-01,3.386319e-01,3.643843e-01,3.882174e-01, & - &2.418713e-01,2.666434e-01,2.901267e-01,3.119921e-01,3.325188e-01, & - &2.058495e-01,2.267890e-01,2.465413e-01,2.650604e-01,2.826851e-01, & - &1.742109e-01,1.916368e-01,2.080797e-01,2.237415e-01,2.387646e-01, & - &1.467749e-01,1.612310e-01,1.749112e-01,1.880848e-01,2.008541e-01, & - &1.232278e-01,1.351400e-01,1.465554e-01,1.575955e-01,1.684556e-01, & - &1.037612e-01,1.136332e-01,1.231565e-01,1.324201e-01,1.416927e-01, & - &8.842272e-02,9.677187e-02,1.048146e-01,1.128012e-01,1.207937e-01, & - &7.558529e-02,8.265702e-02,8.955802e-02,9.645724e-02,1.034107e-01, & - &6.497380e-02,7.101412e-02,7.699453e-02,8.299150e-02,8.904929e-02, & - &5.579166e-02,6.103851e-02,6.625225e-02,7.151054e-02,7.677845e-02, & - &4.796286e-02,5.254682e-02,5.713142e-02,6.172980e-02,6.633766e-02, & - &4.129384e-02,4.531270e-02,4.933779e-02,5.336478e-02,5.741542e-02, & - &3.569544e-02,3.922383e-02,4.275072e-02,4.630644e-02,4.988470e-02, & - &3.091246e-02,3.400273e-02,3.710608e-02,4.025060e-02,4.341368e-02, & - &2.681996e-02,2.952830e-02,3.226519e-02,3.504452e-02,3.784416e-02, & - &2.328797e-02,2.567157e-02,2.809045e-02,3.053775e-02,3.302828e-02, & - &2.023245e-02,2.233457e-02,2.446660e-02,2.663395e-02,2.884465e-02, & - &1.758162e-02,1.942834e-02,2.130331e-02,2.322170e-02,2.517415e-02, & - &1.531067e-02,1.693290e-02,1.858515e-02,2.027911e-02,2.199853e-02, & - &1.335383e-02,1.477538e-02,1.623221e-02,1.772188e-02,1.923992e-02, & - &1.164077e-02,1.289029e-02,1.417053e-02,1.548304e-02,1.682068e-02, & - &1.004320e-02,1.113781e-02,1.226080e-02,1.341399e-02,1.460027e-02, & - &8.561397e-03,9.515775e-03,1.049876e-02,1.150965e-02,1.255723e-02, & - &7.271213e-03,8.116275e-03,8.993175e-03,9.897953e-03,1.083671e-02, & - &6.171587e-03,6.919947e-03,7.702916e-03,8.512736e-03,9.356447e-03, & - &5.236652e-03,5.899732e-03,6.596521e-03,7.319590e-03,8.080273e-03, & - &4.433825e-03,5.028848e-03,5.655133e-03,6.311248e-03,7.004547e-03, & - &3.752121e-03,4.284848e-03,4.849925e-03,5.447281e-03,6.078773e-03, & - &3.172964e-03,3.649501e-03,4.158718e-03,4.702706e-03,5.279070e-03, & - &2.669172e-03,3.095909e-03,3.556003e-03,4.051055e-03,4.578972e-03, & - &2.237157e-03,2.619428e-03,3.034872e-03,3.486381e-03,3.970956e-03, & - &1.870756e-03,2.213652e-03,2.588321e-03,2.999514e-03,3.444480e-03, & - &1.554228e-03,1.860946e-03,2.198317e-03,2.571641e-03,2.979662e-03, & - &1.275226e-03,1.547845e-03,1.850941e-03,2.187965e-03,2.560741e-03, & - &1.040192e-03,1.281442e-03,1.552822e-03,1.857435e-03,2.198056e-03, & - &8.431972e-04,1.054982e-03,1.297147e-03,1.572426e-03,1.883570e-03, & - &6.828427e-04,8.681741e-04,1.083651e-03,1.332273e-03,1.616715e-03, & - &5.511627e-04,7.123505e-04,9.029551e-04,1.126692e-03,1.385970e-03, & - &4.420140e-04,5.811931e-04,7.491559e-04,9.492786e-04,1.185122e-03, & - &3.521462e-04,4.711940e-04,6.180835e-04,7.966889e-04,1.010289e-03, & - &2.812572e-04,3.829231e-04,5.114540e-04,6.709845e-04,8.646435e-04, & - &2.241594e-04,3.109539e-04,4.230692e-04,5.651079e-04,7.406077e-04, & - &1.776024e-04,2.512501e-04,3.484325e-04,4.743772e-04,6.328486e-04, & - &1.398604e-04,2.018775e-04,2.854840e-04,3.965701e-04,5.393614e-04, & - &1.101438e-04,1.622236e-04,2.341716e-04,3.319349e-04,4.607159e-04, & - &9.278635e-05,1.388307e-04,2.040423e-04,2.942686e-04,4.150569e-04/ - data absb(:,5) / & - &6.332215e+00,7.169696e+00,7.960616e+00,8.699113e+00,9.394804e+00, & - &5.836838e+00,6.596239e+00,7.320914e+00,7.998132e+00,8.629110e+00, & - &5.330974e+00,6.022293e+00,6.673764e+00,7.274517e+00,7.825866e+00, & - &4.832826e+00,5.445528e+00,6.008613e+00,6.531717e+00,7.017191e+00, & - &4.324640e+00,4.848000e+00,5.342279e+00,5.802887e+00,6.233079e+00, & - &3.816411e+00,4.272746e+00,4.702091e+00,5.110783e+00,5.490958e+00, & - &3.341428e+00,3.737641e+00,4.116610e+00,4.472003e+00,4.805812e+00, & - &2.918425e+00,3.265745e+00,3.591503e+00,3.899564e+00,4.191466e+00, & - &2.543510e+00,2.838305e+00,3.120821e+00,3.390052e+00,3.647870e+00, & - &2.222935e+00,2.477879e+00,2.723704e+00,2.959927e+00,3.185467e+00, & - &1.942393e+00,2.164381e+00,2.378819e+00,2.583095e+00,2.780551e+00, & - &1.701236e+00,1.893004e+00,2.076613e+00,2.253318e+00,2.428922e+00, & - &1.493073e+00,1.655713e+00,1.814445e+00,1.971699e+00,2.131341e+00, & - &1.311801e+00,1.452661e+00,1.593697e+00,1.736285e+00,1.881543e+00, & - &1.154008e+00,1.278853e+00,1.406338e+00,1.535934e+00,1.670752e+00, & - &1.018018e+00,1.130763e+00,1.247363e+00,1.366348e+00,1.490025e+00, & - &9.031258e-01,1.005822e+00,1.111796e+00,1.221127e+00,1.337216e+00, & - &8.058292e-01,8.987275e-01,9.958751e-01,1.098775e+00,1.208462e+00, & - &7.229331e-01,8.073447e-01,8.983939e-01,9.957595e-01,1.101763e+00, & - &6.517264e-01,7.308257e-01,8.164216e-01,9.103796e-01,1.014973e+00, & - &5.912167e-01,6.660878e-01,7.483380e-01,8.411595e-01,9.459087e-01, & - &5.383685e-01,6.098833e-01,6.905786e-01,7.824712e-01,8.883944e-01, & - &4.879682e-01,5.567014e-01,6.357950e-01,7.271842e-01,8.340975e-01, & - &4.392781e-01,5.050591e-01,5.823882e-01,6.725016e-01,7.786719e-01, & - &3.904448e-01,4.526691e-01,5.268565e-01,6.139940e-01,7.176002e-01, & - &3.483489e-01,4.075259e-01,4.786955e-01,5.630637e-01,6.639293e-01, & - &3.125585e-01,3.689760e-01,4.372460e-01,5.192377e-01,6.172602e-01, & - &2.776970e-01,3.306863e-01,3.949822e-01,4.731898e-01,5.669774e-01, & - &2.473138e-01,2.967997e-01,3.575149e-01,4.315655e-01,5.210803e-01, & - &2.211896e-01,2.673039e-01,3.245415e-01,3.947129e-01,4.802010e-01, & - &1.965813e-01,2.392743e-01,2.926622e-01,3.581483e-01,4.389039e-01, & - &1.744110e-01,2.138466e-01,2.631692e-01,3.239571e-01,3.996050e-01, & - &1.551215e-01,1.916635e-01,2.371115e-01,2.936439e-01,3.642505e-01, & - &1.376597e-01,1.713333e-01,2.131262e-01,2.657320e-01,3.308224e-01, & - &1.213664e-01,1.519447e-01,1.901857e-01,2.381446e-01,2.980106e-01, & - &1.073214e-01,1.349240e-01,1.700100e-01,2.136944e-01,2.687172e-01, & - &9.535217e-02,1.201210e-01,1.520808e-01,1.920167e-01,2.423997e-01, & - &8.570682e-02,1.078508e-01,1.370415e-01,1.739056e-01,2.201058e-01, & - &7.770064e-02,9.748277e-02,1.240667e-01,1.581038e-01,2.006976e-01, & - &7.090169e-02,8.858616e-02,1.126071e-01,1.440248e-01,1.833330e-01, & - &6.482142e-02,8.100262e-02,1.025793e-01,1.313941e-01,1.677763e-01, & - &5.970185e-02,7.496003e-02,9.450066e-02,1.209958e-01,1.549348e-01, & - &5.515797e-02,6.995240e-02,8.785519e-02,1.122287e-01,1.438916e-01, & - &5.107017e-02,6.542730e-02,8.220129e-02,1.045071e-01,1.340373e-01, & - &4.729317e-02,6.132100e-02,7.731164e-02,9.783074e-02,1.253337e-01, & - &4.387326e-02,5.772787e-02,7.336461e-02,9.253317e-02,1.181971e-01, & - &4.285445e-02,5.683099e-02,7.260057e-02,9.151012e-02,1.166583e-01/ - data absb(:,6) / & - &1.144510e+02,1.265483e+02,1.384776e+02,1.501107e+02,1.603875e+02, & - &1.248008e+02,1.377829e+02,1.505932e+02,1.631617e+02,1.742706e+02, & - &1.345615e+02,1.496943e+02,1.638996e+02,1.762027e+02,1.886959e+02, & - &1.447471e+02,1.609295e+02,1.762797e+02,1.893648e+02,2.026873e+02, & - &1.549957e+02,1.719796e+02,1.870500e+02,2.027851e+02,2.160030e+02, & - &1.648425e+02,1.826375e+02,1.983197e+02,2.148038e+02,2.286862e+02, & - &1.739389e+02,1.922047e+02,2.095276e+02,2.254292e+02,2.402556e+02, & - &1.827828e+02,2.015573e+02,2.194584e+02,2.358312e+02,2.510857e+02, & - &1.909629e+02,2.102683e+02,2.286037e+02,2.453409e+02,2.609120e+02, & - &1.999650e+02,2.199519e+02,2.377742e+02,2.549909e+02,2.707710e+02, & - &2.084700e+02,2.286577e+02,2.465510e+02,2.639640e+02,2.791263e+02, & - &2.165970e+02,2.369161e+02,2.548608e+02,2.723679e+02,2.875031e+02, & - &2.238418e+02,2.448766e+02,2.627724e+02,2.802621e+02,2.952523e+02, & - &2.316367e+02,2.526929e+02,2.704418e+02,2.878040e+02,3.026530e+02, & - &2.391515e+02,2.601107e+02,2.776410e+02,2.948253e+02,3.094572e+02, & - &2.463052e+02,2.671340e+02,2.844041e+02,3.014055e+02,3.157877e+02, & - &2.532821e+02,2.738895e+02,2.908896e+02,3.076868e+02,3.218356e+02, & - &2.599666e+02,2.803648e+02,2.970693e+02,3.135907e+02,3.274518e+02, & - &2.664568e+02,2.866062e+02,3.029944e+02,3.192474e+02,3.328040e+02, & - &2.727803e+02,2.926281e+02,3.086956e+02,3.246077e+02,3.378214e+02, & - &2.788875e+02,2.983883e+02,3.141084e+02,3.296856e+02,3.425593e+02, & - &2.841100e+02,3.033150e+02,3.187129e+02,3.340132e+02,3.465670e+02, & - &2.873263e+02,3.063899e+02,3.216236e+02,3.367376e+02,3.491214e+02, & - &2.883907e+02,3.074784e+02,3.227059e+02,3.378052e+02,3.501450e+02, & - &2.865086e+02,3.058509e+02,3.213347e+02,3.366307e+02,3.491768e+02, & - &2.843231e+02,3.036704e+02,3.196082e+02,3.351754e+02,3.479350e+02, & - &2.820493e+02,3.016622e+02,3.179103e+02,3.336188e+02,3.465764e+02, & - &2.776566e+02,2.976751e+02,3.142908e+02,3.304340e+02,3.437633e+02, & - &2.728022e+02,2.933023e+02,3.103330e+02,3.268761e+02,3.406056e+02, & - &2.677867e+02,2.887341e+02,3.061957e+02,3.231862e+02,3.373065e+02, & - &2.614277e+02,2.829089e+02,3.009034e+02,3.184362e+02,3.330419e+02, & - &2.543227e+02,2.763991e+02,2.949520e+02,3.130417e+02,3.281911e+02, & - &2.470025e+02,2.696496e+02,2.887682e+02,3.074423e+02,3.231209e+02, & - &2.389803e+02,2.622191e+02,2.819375e+02,3.005525e+02,3.178528e+02, & - &2.297389e+02,2.536474e+02,2.740233e+02,2.933060e+02,3.112537e+02, & - &2.202156e+02,2.447775e+02,2.658082e+02,2.857485e+02,3.043856e+02, & - &2.105414e+02,2.356115e+02,2.572866e+02,2.779070e+02,2.972509e+02, & - &2.011470e+02,2.268106e+02,2.491041e+02,2.702933e+02,2.903142e+02, & - &1.918698e+02,2.180543e+02,2.408948e+02,2.626827e+02,2.833377e+02, & - &1.824152e+02,2.090963e+02,2.324796e+02,2.548459e+02,2.761700e+02, & - &1.728191e+02,1.999453e+02,2.238662e+02,2.467928e+02,2.687196e+02, & - &1.639097e+02,1.913942e+02,2.157789e+02,2.392190e+02,2.617203e+02, & - &1.552902e+02,1.830631e+02,2.074878e+02,2.317959e+02,2.548194e+02, & - &1.466005e+02,1.746586e+02,1.994463e+02,2.242049e+02,2.477667e+02, & - &1.379131e+02,1.661306e+02,1.912867e+02,2.164573e+02,2.405580e+02, & - &1.296481e+02,1.579850e+02,1.834409e+02,2.089770e+02,2.335591e+02, & - &1.263431e+02,1.547149e+02,1.802663e+02,2.059590e+02,2.307281e+02/ - - data fracrefa / & - & 0.3141323924, 0.2696491778, 0.2174980938, 0.1422150433, & - & 0.0525375493, 0.0039682100 / - data fracrefb / & - & 0.3183371127, 0.2665695548, 0.2144581676, 0.1431470364, & - & 0.0532786474, 0.0042107701 / - -!........................................! - end module module_radlw_kgb10 ! -!========================================! - - - -!========================================! - module module_radlw_kgb11 ! -!........................................! -! - use machine, only : kind_phys - use module_radlw_parameters, only : NG11 -! - implicit none -! - private -! - integer, public :: MSA11, MSB11, MSF11 - parameter (MSA11=65, MSB11=235, MSF11=10) - - real (kind=kind_phys), public :: & - & absa(MSA11,NG11), absb(MSB11,NG11), selfref(MSF11,NG11), & - & fracrefa(NG11), fracrefb(NG11) - -! the array absa(65,NG11) = ka(5,13,NG11) contains absorption coefs at -! the NG11=8 chosen g-values for a range of pressure levels > ~100mb -! and temperatures. the first index in the array, jt, which runs from -! 1 to 5, corresponds to different temperatures. more specifically, -! jt = 1-5 means that the data are for the corresponding temperature of -! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the -! second index, jp, runs from 1 to 13 and refers to the corresponding -! pressure level in pref (e.g. jp = 1 is for a pressure of 1053.63 mb). -! the third index, ig, goes from 1 to NG11=8, and tells us which -! g-interval the absorption coefficients are for. - - data absa(:,1) / & - &8.352200e-02,8.189700e-02,8.022900e-02,7.857900e-02,7.697000e-02, & - &6.894500e-02,6.757300e-02,6.620600e-02,6.483500e-02,6.348600e-02, & - &5.710200e-02,5.594300e-02,5.481000e-02,5.366800e-02,5.254100e-02, & - &4.766800e-02,4.665700e-02,4.572400e-02,4.475300e-02,4.380800e-02, & - &4.000200e-02,3.912400e-02,3.831500e-02,3.750200e-02,3.670500e-02, & - &3.377600e-02,3.300000e-02,3.228200e-02,3.159600e-02,3.090900e-02, & - &2.883500e-02,2.812800e-02,2.747800e-02,2.686200e-02,2.627300e-02, & - &2.546500e-02,2.480900e-02,2.417000e-02,2.356800e-02,2.301000e-02, & - &2.703100e-02,2.629700e-02,2.556900e-02,2.487800e-02,2.421600e-02, & - &2.695500e-02,2.753300e-02,2.794100e-02,2.826900e-02,2.855600e-02, & - &2.333300e-02,2.402600e-02,2.461300e-02,2.514200e-02,2.560100e-02, & - &1.979300e-02,2.043400e-02,2.098200e-02,2.148400e-02,2.194500e-02, & - &1.644700e-02,1.698100e-02,1.744400e-02,1.786800e-02,1.825200e-02/ - data absa(:,2) / & - &1.841200e-01,1.785800e-01,1.735800e-01,1.691600e-01,1.651600e-01, & - &1.525700e-01,1.480600e-01,1.438900e-01,1.402000e-01,1.368300e-01, & - &1.269200e-01,1.232200e-01,1.197000e-01,1.165400e-01,1.136200e-01, & - &1.064200e-01,1.033600e-01,1.003900e-01,9.768300e-02,9.512800e-02, & - &8.952300e-02,8.697200e-02,8.447600e-02,8.214200e-02,7.995200e-02, & - &7.543000e-02,7.333600e-02,7.124400e-02,6.923500e-02,6.735400e-02, & - &6.377500e-02,6.203100e-02,6.028100e-02,5.857300e-02,5.692500e-02, & - &5.482700e-02,5.322300e-02,5.167600e-02,5.020000e-02,4.874700e-02, & - &5.403000e-02,5.162800e-02,4.955800e-02,4.773200e-02,4.609000e-02, & - &8.344500e-02,7.969500e-02,7.552800e-02,7.134900e-02,6.742700e-02, & - &8.449900e-02,8.200200e-02,7.968400e-02,7.744500e-02,7.471600e-02, & - &7.785600e-02,7.567900e-02,7.380300e-02,7.201400e-02,7.027300e-02, & - &6.585900e-02,6.397400e-02,6.234600e-02,6.081000e-02,5.931700e-02/ - data absa(:,3) / & - &3.828248e-01,3.743176e-01,3.662673e-01,3.589614e-01,3.523886e-01, & - &3.185812e-01,3.113158e-01,3.046717e-01,2.985871e-01,2.932095e-01, & - &2.656570e-01,2.594648e-01,2.537984e-01,2.486878e-01,2.443019e-01, & - &2.235141e-01,2.181980e-01,2.132995e-01,2.089373e-01,2.051902e-01, & - &1.887430e-01,1.841455e-01,1.799035e-01,1.761182e-01,1.728625e-01, & - &1.597288e-01,1.557230e-01,1.520482e-01,1.487484e-01,1.458556e-01, & - &1.354526e-01,1.319429e-01,1.287121e-01,1.258028e-01,1.232326e-01, & - &1.159355e-01,1.127304e-01,1.098068e-01,1.071506e-01,1.047947e-01, & - &1.078017e-01,1.040238e-01,1.006057e-01,9.753046e-02,9.480751e-02, & - &1.421668e-01,1.324308e-01,1.244116e-01,1.177175e-01,1.120450e-01, & - &1.588459e-01,1.468819e-01,1.362129e-01,1.269871e-01,1.192831e-01, & - &1.538822e-01,1.421235e-01,1.317367e-01,1.225641e-01,1.145842e-01, & - &1.307822e-01,1.207240e-01,1.118270e-01,1.040067e-01,9.718569e-02/ - data absa(:,4) / & - &1.199114e+00,1.182060e+00,1.165209e+00,1.148670e+00,1.132498e+00, & - &1.018996e+00,1.004785e+00,9.908429e-01,9.769305e-01,9.630697e-01, & - &8.612305e-01,8.495260e-01,8.378478e-01,8.262064e-01,8.143241e-01, & - &7.300673e-01,7.204316e-01,7.107948e-01,7.009566e-01,6.912522e-01, & - &6.192104e-01,6.113674e-01,6.033356e-01,5.952271e-01,5.872930e-01, & - &5.246534e-01,5.183036e-01,5.116206e-01,5.049127e-01,4.982578e-01, & - &4.439784e-01,4.386761e-01,4.331557e-01,4.274994e-01,4.218530e-01, & - &3.762462e-01,3.717536e-01,3.670009e-01,3.621331e-01,3.573702e-01, & - &3.266772e-01,3.219760e-01,3.171911e-01,3.124596e-01,3.079548e-01, & - &3.251391e-01,3.148463e-01,3.059193e-01,2.980269e-01,2.909778e-01, & - &3.166233e-01,3.015853e-01,2.893019e-01,2.788933e-01,2.700493e-01, & - &2.912232e-01,2.752759e-01,2.621136e-01,2.511927e-01,2.421327e-01, & - &2.466425e-01,2.332400e-01,2.221443e-01,2.130202e-01,2.054941e-01/ - data absa(:,5) / & - &5.412443e+00,5.333065e+00,5.255462e+00,5.176532e+00,5.096982e+00, & - &4.986615e+00,4.908152e+00,4.832284e+00,4.754574e+00,4.678324e+00, & - &4.519390e+00,4.447006e+00,4.375114e+00,4.303865e+00,4.235204e+00, & - &4.064010e+00,3.999493e+00,3.934017e+00,3.869757e+00,3.807269e+00, & - &3.625608e+00,3.567336e+00,3.508191e+00,3.450835e+00,3.392704e+00, & - &3.206764e+00,3.154394e+00,3.102140e+00,3.049098e+00,2.995411e+00, & - &2.810375e+00,2.764497e+00,2.716916e+00,2.668603e+00,2.621549e+00, & - &2.443945e+00,2.402913e+00,2.359962e+00,2.317939e+00,2.277378e+00, & - &2.118066e+00,2.080594e+00,2.042863e+00,2.006577e+00,1.971750e+00, & - &1.859594e+00,1.822370e+00,1.786771e+00,1.752840e+00,1.720353e+00, & - &1.607349e+00,1.572788e+00,1.540293e+00,1.509322e+00,1.480197e+00, & - &1.375164e+00,1.344589e+00,1.315648e+00,1.288913e+00,1.263965e+00, & - &1.159296e+00,1.133557e+00,1.109581e+00,1.087474e+00,1.066278e+00/ - data absa(:,6) / & - &2.033131e+01,2.003956e+01,1.977759e+01,1.952326e+01,1.928568e+01, & - &2.117788e+01,2.089209e+01,2.060783e+01,2.035607e+01,2.012568e+01, & - &2.192275e+01,2.162057e+01,2.133267e+01,2.106360e+01,2.080215e+01, & - &2.238352e+01,2.207194e+01,2.177969e+01,2.148637e+01,2.119785e+01, & - &2.254255e+01,2.221759e+01,2.191853e+01,2.160449e+01,2.129656e+01, & - &2.239886e+01,2.207642e+01,2.176549e+01,2.144111e+01,2.113146e+01, & - &2.194208e+01,2.162713e+01,2.131783e+01,2.099754e+01,2.069383e+01, & - &2.116809e+01,2.086412e+01,2.056307e+01,2.025311e+01,1.994793e+01, & - &2.012030e+01,1.984342e+01,1.954384e+01,1.924047e+01,1.893256e+01, & - &1.885575e+01,1.858229e+01,1.828974e+01,1.799675e+01,1.769732e+01, & - &1.726454e+01,1.699077e+01,1.671586e+01,1.643552e+01,1.615980e+01, & - &1.555364e+01,1.530567e+01,1.505568e+01,1.480951e+01,1.456685e+01, & - &1.382959e+01,1.361035e+01,1.339731e+01,1.318530e+01,1.297661e+01/ - data absa(:,7) / & - &4.907264e+01,4.864800e+01,4.814266e+01,4.766349e+01,4.716323e+01, & - &5.628505e+01,5.571234e+01,5.514188e+01,5.452382e+01,5.385713e+01, & - &6.374154e+01,6.310612e+01,6.235110e+01,6.163082e+01,6.091232e+01, & - &7.111040e+01,7.034544e+01,6.949383e+01,6.863002e+01,6.786493e+01, & - &7.846301e+01,7.751796e+01,7.659081e+01,7.562596e+01,7.477141e+01, & - &8.562089e+01,8.458658e+01,8.354432e+01,8.256830e+01,8.161320e+01, & - &9.260575e+01,9.145367e+01,9.032336e+01,8.924384e+01,8.816264e+01, & - &9.928256e+01,9.801300e+01,9.676464e+01,9.554751e+01,9.436929e+01, & - &1.054108e+02,1.040086e+02,1.027223e+02,1.014247e+02,1.002047e+02, & - &1.107909e+02,1.093952e+02,1.080517e+02,1.066970e+02,1.054164e+02, & - &1.148336e+02,1.134290e+02,1.119951e+02,1.106952e+02,1.093865e+02, & - &1.177423e+02,1.162767e+02,1.148690e+02,1.135178e+02,1.121086e+02, & - &1.190420e+02,1.175759e+02,1.161714e+02,1.147145e+02,1.133409e+02/ - data absa(:,8) / & - &7.090377e+01,7.016795e+01,6.997984e+01,6.976229e+01,6.984875e+01, & - &8.632460e+01,8.556682e+01,8.508820e+01,8.484694e+01,8.470024e+01, & - &1.056612e+02,1.046648e+02,1.038525e+02,1.032479e+02,1.029195e+02, & - &1.272835e+02,1.260956e+02,1.248501e+02,1.239914e+02,1.234281e+02, & - &1.521334e+02,1.501596e+02,1.485764e+02,1.475694e+02,1.465787e+02, & - &1.807484e+02,1.781660e+02,1.761986e+02,1.746992e+02,1.732806e+02, & - &2.132583e+02,2.104653e+02,2.079243e+02,2.057283e+02,2.037646e+02, & - &2.504288e+02,2.472119e+02,2.441919e+02,2.414454e+02,2.390179e+02, & - &2.927261e+02,2.887547e+02,2.849178e+02,2.817791e+02,2.782975e+02, & - &3.386779e+02,3.339022e+02,3.289449e+02,3.253889e+02,3.210715e+02, & - &3.852897e+02,3.792464e+02,3.744565e+02,3.695413e+02,3.645969e+02, & - &4.353740e+02,4.283165e+02,4.224799e+02,4.166790e+02,4.109871e+02, & - &4.883820e+02,4.813530e+02,4.742805e+02,4.671824e+02,4.611249e+02/ - -! the array absb(235,NG11) = kb(5,13:59,NG11) contains absorption coefs -! at the NG11=8 chosen g-values for a range of pressure levels < ~100mb -! and temperatures. the first index in the array, jt, which runs from -! 1 to 5, corresponds to different temperatures. more specifically, -! jt = 1-5 means that the data are for the corresponding temperature of -! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the -! second index, jp, runs from 13 to 59 and refers to the jpth reference -! pressure level (see taumol.f for the value of these pressure levels -! in mb). the third index, ig, goes from 1 to NG11=8, and tells us -! which g-interval the absorption coefficients are for. - - data absb(:,1) / & - &1.644800e-02,1.698100e-02,1.744700e-02,1.786800e-02,1.825200e-02, & - &1.379100e-02,1.422200e-02,1.461000e-02,1.495200e-02,1.526700e-02, & - &1.152000e-02,1.186500e-02,1.217100e-02,1.243700e-02,1.269300e-02, & - &9.536300e-03,9.809700e-03,1.004000e-02,1.025100e-02,1.045000e-02, & - &7.878000e-03,8.082600e-03,8.259600e-03,8.421600e-03,8.565300e-03, & - &6.481700e-03,6.635100e-03,6.769100e-03,6.878000e-03,6.982500e-03, & - &5.345300e-03,5.464000e-03,5.555400e-03,5.633200e-03,5.711100e-03, & - &4.404000e-03,4.493600e-03,4.558400e-03,4.618200e-03,4.677200e-03, & - &3.625800e-03,3.690100e-03,3.739100e-03,3.785400e-03,3.830400e-03, & - &2.983900e-03,3.028300e-03,3.065700e-03,3.100900e-03,3.135800e-03, & - &2.452100e-03,2.484100e-03,2.512600e-03,2.539700e-03,2.567500e-03, & - &2.017100e-03,2.041100e-03,2.063000e-03,2.084400e-03,2.107100e-03, & - &1.658200e-03,1.676500e-03,1.693400e-03,1.710800e-03,1.728800e-03, & - &1.363000e-03,1.377000e-03,1.390500e-03,1.404900e-03,1.418900e-03, & - &1.118900e-03,1.129800e-03,1.141000e-03,1.152800e-03,1.164000e-03, & - &9.176600e-04,9.265600e-04,9.358800e-04,9.454200e-04,9.546400e-04, & - &7.500900e-04,7.575000e-04,7.653200e-04,7.730700e-04,7.805800e-04, & - &6.122900e-04,6.184800e-04,6.249900e-04,6.312600e-04,6.373700e-04, & - &4.982200e-04,5.033700e-04,5.087600e-04,5.137600e-04,5.186700e-04, & - &4.057600e-04,4.100700e-04,4.144700e-04,4.185300e-04,4.224700e-04, & - &3.306600e-04,3.343100e-04,3.378600e-04,3.411800e-04,3.442700e-04, & - &2.703100e-04,2.733600e-04,2.762700e-04,2.789600e-04,2.813700e-04, & - &2.209300e-04,2.234400e-04,2.258400e-04,2.280000e-04,2.299200e-04, & - &1.805000e-04,1.825700e-04,1.845700e-04,1.863400e-04,1.879000e-04, & - &1.475400e-04,1.492800e-04,1.509800e-04,1.524700e-04,1.537900e-04, & - &1.205500e-04,1.220200e-04,1.234600e-04,1.247300e-04,1.258400e-04, & - &9.843900e-05,9.969300e-05,1.008900e-04,1.019800e-04,1.029200e-04, & - &8.052600e-05,8.161800e-05,8.262100e-05,8.358400e-05,8.440400e-05, & - &6.587200e-05,6.681100e-05,6.767000e-05,6.850400e-05,6.922700e-05, & - &5.386100e-05,5.466300e-05,5.540700e-05,5.611000e-05,5.676100e-05, & - &4.404800e-05,4.474300e-05,4.539600e-05,4.600400e-05,4.658600e-05, & - &3.600000e-05,3.662000e-05,3.718700e-05,3.772600e-05,3.822800e-05, & - &2.937000e-05,2.994400e-05,3.044100e-05,3.091300e-05,3.135600e-05, & - &2.389100e-05,2.445800e-05,2.490300e-05,2.531400e-05,2.570800e-05, & - &1.940400e-05,1.992500e-05,2.035700e-05,2.072200e-05,2.106600e-05, & - &1.572500e-05,1.619700e-05,1.660300e-05,1.694500e-05,1.724800e-05, & - &1.272200e-05,1.313900e-05,1.350500e-05,1.382800e-05,1.410600e-05, & - &1.030100e-05,1.066500e-05,1.099600e-05,1.128000e-05,1.154300e-05, & - &8.338500e-06,8.660300e-06,8.950000e-06,9.204300e-06,9.434900e-06, & - &6.745700e-06,7.020100e-06,7.275000e-06,7.502800e-06,7.704700e-06, & - &5.453800e-06,5.681600e-06,5.906100e-06,6.105400e-06,6.286200e-06, & - &4.428500e-06,4.618100e-06,4.808500e-06,4.986200e-06,5.144800e-06, & - &3.603800e-06,3.762400e-06,3.922900e-06,4.080400e-06,4.219300e-06, & - &2.932600e-06,3.065600e-06,3.201000e-06,3.336800e-06,3.460400e-06, & - &2.385900e-06,2.498300e-06,2.612700e-06,2.728000e-06,2.838400e-06, & - &1.943400e-06,2.039000e-06,2.136000e-06,2.234000e-06,2.329800e-06, & - &1.604000e-06,1.685900e-06,1.769400e-06,1.853700e-06,1.935900e-06/ - data absb(:,2) / & - &6.585700e-02,6.397500e-02,6.234800e-02,6.081100e-02,5.931800e-02, & - &5.533500e-02,5.369300e-02,5.224000e-02,5.087700e-02,4.956300e-02, & - &4.555200e-02,4.414500e-02,4.286600e-02,4.167900e-02,4.047900e-02, & - &3.685200e-02,3.565800e-02,3.458400e-02,3.358100e-02,3.243600e-02, & - &2.962200e-02,2.863500e-02,2.774800e-02,2.684700e-02,2.578900e-02, & - &2.357700e-02,2.277600e-02,2.203600e-02,2.118100e-02,2.024400e-02, & - &1.891400e-02,1.826000e-02,1.760100e-02,1.683000e-02,1.602900e-02, & - &1.526000e-02,1.472700e-02,1.413300e-02,1.347000e-02,1.280400e-02, & - &1.233400e-02,1.188600e-02,1.136400e-02,1.080600e-02,1.026000e-02, & - &9.937500e-03,9.545700e-03,9.094300e-03,8.631500e-03,8.187500e-03, & - &8.003400e-03,7.656900e-03,7.275700e-03,6.895200e-03,6.535100e-03, & - &6.464400e-03,6.164900e-03,5.847400e-03,5.536300e-03,5.244700e-03, & - &5.217000e-03,4.961500e-03,4.699000e-03,4.446300e-03,4.211800e-03, & - &4.207800e-03,3.993600e-03,3.778200e-03,3.573600e-03,3.386700e-03, & - &3.392300e-03,3.214900e-03,3.039900e-03,2.875500e-03,2.726500e-03, & - &2.734500e-03,2.588800e-03,2.447400e-03,2.315900e-03,2.197300e-03, & - &2.192700e-03,2.074200e-03,1.960900e-03,1.856600e-03,1.762900e-03, & - &1.753400e-03,1.657700e-03,1.567200e-03,1.484900e-03,1.411100e-03, & - &1.392300e-03,1.315800e-03,1.244200e-03,1.179900e-03,1.122200e-03, & - &1.107300e-03,1.046300e-03,9.900600e-04,9.395600e-04,8.945400e-04, & - &8.816800e-04,8.332100e-04,7.890300e-04,7.494300e-04,7.143700e-04, & - &7.084300e-04,6.698500e-04,6.348300e-04,6.035600e-04,5.759700e-04, & - &5.733500e-04,5.424300e-04,5.143700e-04,4.893500e-04,4.673100e-04, & - &4.678600e-04,4.427900e-04,4.200100e-04,3.996900e-04,3.817500e-04, & - &3.872200e-04,3.665200e-04,3.476500e-04,3.307400e-04,3.157700e-04, & - &3.206400e-04,3.035800e-04,2.879500e-04,2.738700e-04,2.613700e-04, & - &2.654200e-04,2.513900e-04,2.384600e-04,2.267500e-04,2.163200e-04, & - &2.224300e-04,2.107700e-04,1.999400e-04,1.900300e-04,1.811700e-04, & - &1.866200e-04,1.770100e-04,1.679300e-04,1.595600e-04,1.520200e-04, & - &1.564800e-04,1.486300e-04,1.410600e-04,1.340200e-04,1.276100e-04, & - &1.321200e-04,1.258200e-04,1.195200e-04,1.135700e-04,1.081000e-04, & - &1.117400e-04,1.068000e-04,1.016500e-04,9.666300e-05,9.201600e-05, & - &9.423800e-05,9.053600e-05,8.643200e-05,8.229200e-05,7.836700e-05, & - &7.932500e-05,7.671800e-05,7.354400e-05,7.018200e-05,6.689200e-05, & - &6.687900e-05,6.496100e-05,6.268600e-05,6.003300e-05,5.732000e-05, & - &5.641900e-05,5.479300e-05,5.324900e-05,5.126800e-05,4.910400e-05, & - &4.758200e-05,4.622300e-05,4.500800e-05,4.367700e-05,4.200700e-05, & - &4.013400e-05,3.902100e-05,3.799900e-05,3.705400e-05,3.585800e-05, & - &3.388100e-05,3.295000e-05,3.211400e-05,3.133700e-05,3.054000e-05, & - &2.862200e-05,2.782600e-05,2.714400e-05,2.651200e-05,2.590400e-05, & - &2.420200e-05,2.351700e-05,2.293600e-05,2.243700e-05,2.194600e-05, & - &2.055200e-05,1.994700e-05,1.944600e-05,1.902900e-05,1.864300e-05, & - &1.752100e-05,1.698300e-05,1.654700e-05,1.618200e-05,1.586900e-05, & - &1.496400e-05,1.450100e-05,1.411300e-05,1.379700e-05,1.353100e-05, & - &1.278600e-05,1.242800e-05,1.207300e-05,1.179500e-05,1.156700e-05, & - &1.092600e-05,1.067600e-05,1.037000e-05,1.011100e-05,9.914400e-06, & - &9.334300e-06,9.139800e-06,8.884400e-06,8.652500e-06,8.476000e-06/ - data absb(:,3) / & - &1.307774e-01,1.207240e-01,1.118397e-01,1.040067e-01,9.718673e-02, & - &1.088648e-01,1.004437e-01,9.299063e-02,8.645077e-02,8.075929e-02, & - &8.786451e-02,8.104344e-02,7.501505e-02,6.976309e-02,6.522316e-02, & - &6.956298e-02,6.416641e-02,5.943692e-02,5.530665e-02,5.182330e-02, & - &5.476976e-02,5.053910e-02,4.684892e-02,4.365860e-02,4.102857e-02, & - &4.263968e-02,3.938373e-02,3.654233e-02,3.416838e-02,3.220928e-02, & - &3.360090e-02,3.105646e-02,2.886911e-02,2.707414e-02,2.558416e-02, & - &2.675499e-02,2.474470e-02,2.305970e-02,2.167543e-02,2.052260e-02, & - &2.138098e-02,1.979807e-02,1.849386e-02,1.741901e-02,1.652177e-02, & - &1.699315e-02,1.577485e-02,1.477771e-02,1.395307e-02,1.326362e-02, & - &1.352127e-02,1.258898e-02,1.182388e-02,1.119130e-02,1.066040e-02, & - &1.082322e-02,1.010455e-02,9.512973e-03,9.022545e-03,8.610422e-03, & - &8.672263e-03,8.118046e-03,7.661110e-03,7.280858e-03,6.960548e-03, & - &6.958623e-03,6.530672e-03,6.177360e-03,5.882537e-03,5.632906e-03, & - &5.590642e-03,5.259644e-03,4.985552e-03,4.756289e-03,4.561842e-03, & - &4.496556e-03,4.239832e-03,4.027012e-03,3.848162e-03,3.697016e-03, & - &3.602183e-03,3.404622e-03,3.240381e-03,3.102234e-03,2.985670e-03, & - &2.881298e-03,2.729915e-03,2.603751e-03,2.497546e-03,2.408043e-03, & - &2.293461e-03,2.178665e-03,2.082861e-03,2.002076e-03,1.934345e-03, & - &1.830205e-03,1.742994e-03,1.669953e-03,1.608556e-03,1.557035e-03, & - &1.463437e-03,1.397119e-03,1.341425e-03,1.294630e-03,1.255294e-03, & - &1.180002e-03,1.128535e-03,1.085312e-03,1.048994e-03,1.018577e-03, & - &9.575636e-04,9.167992e-04,8.826382e-04,8.538817e-04,8.299741e-04, & - &7.822990e-04,7.493285e-04,7.217042e-04,6.984717e-04,6.792136e-04, & - &6.466518e-04,6.190188e-04,5.958469e-04,5.763989e-04,5.602663e-04, & - &5.348816e-04,5.116378e-04,4.921657e-04,4.758558e-04,4.623095e-04, & - &4.424052e-04,4.228216e-04,4.064610e-04,3.927839e-04,3.813948e-04, & - &3.700483e-04,3.530080e-04,3.388571e-04,3.270237e-04,3.171780e-04, & - &3.102634e-04,2.953195e-04,2.830153e-04,2.727355e-04,2.641925e-04, & - &2.603999e-04,2.472753e-04,2.365374e-04,2.275965e-04,2.201558e-04, & - &2.206275e-04,2.087872e-04,1.991738e-04,1.912336e-04,1.846152e-04, & - &1.880830e-04,1.772713e-04,1.685321e-04,1.613787e-04,1.554221e-04, & - &1.608236e-04,1.509034e-04,1.429264e-04,1.364367e-04,1.310665e-04, & - &1.382927e-04,1.291043e-04,1.217497e-04,1.157945e-04,1.109000e-04, & - &1.197902e-04,1.113713e-04,1.044542e-04,9.889506e-05,9.436000e-05, & - &1.039796e-04,9.648103e-05,9.000407e-05,8.478353e-05,8.054324e-05, & - &9.047308e-05,8.378942e-05,7.792360e-05,7.299009e-05,6.901364e-05, & - &7.876582e-05,7.281700e-05,6.760118e-05,6.306460e-05,5.932368e-05, & - &6.865083e-05,6.342006e-05,5.876838e-05,5.470059e-05,5.120636e-05, & - &5.998541e-05,5.536976e-05,5.123673e-05,4.760396e-05,4.443123e-05, & - &5.258559e-05,4.846040e-05,4.482120e-05,4.156697e-05,3.872084e-05, & - &4.622852e-05,4.250688e-05,3.927030e-05,3.638556e-05,3.383475e-05, & - &4.079153e-05,3.742295e-05,3.451586e-05,3.195792e-05,2.967682e-05, & - &3.615460e-05,3.311017e-05,3.047368e-05,2.817923e-05,2.614859e-05, & - &3.219442e-05,2.944658e-05,2.705300e-05,2.497513e-05,2.315106e-05, & - &2.871016e-05,2.627168e-05,2.410535e-05,2.221344e-05,2.056525e-05, & - &2.502096e-05,2.292284e-05,2.102316e-05,1.935718e-05,1.790818e-05/ - data absb(:,4) / & - &2.466478e-01,2.332447e-01,2.221351e-01,2.130202e-01,2.054841e-01, & - &2.086552e-01,1.977412e-01,1.888164e-01,1.814441e-01,1.753586e-01, & - &1.739667e-01,1.654008e-01,1.584118e-01,1.526072e-01,1.478150e-01, & - &1.421180e-01,1.355985e-01,1.302383e-01,1.258152e-01,1.221761e-01, & - &1.154625e-01,1.105505e-01,1.065048e-01,1.031945e-01,1.004536e-01, & - &9.321930e-02,8.956982e-02,8.659868e-02,8.415633e-02,8.210110e-02, & - &7.585787e-02,7.312562e-02,7.089396e-02,6.904837e-02,6.746523e-02, & - &6.198240e-02,5.991252e-02,5.821558e-02,5.680013e-02,5.555286e-02, & - &5.070956e-02,4.913273e-02,4.783829e-02,4.673875e-02,4.575803e-02, & - &4.136577e-02,4.018559e-02,3.920748e-02,3.835229e-02,3.759610e-02, & - &3.376677e-02,3.288233e-02,3.213072e-02,3.146862e-02,3.088892e-02, & - &2.765103e-02,2.697442e-02,2.639065e-02,2.588003e-02,2.542682e-02, & - &2.264431e-02,2.212252e-02,2.167220e-02,2.127675e-02,2.092595e-02, & - &1.854384e-02,1.814187e-02,1.779641e-02,1.749113e-02,1.722327e-02, & - &1.516779e-02,1.486036e-02,1.459474e-02,1.435972e-02,1.415739e-02, & - &1.239653e-02,1.216224e-02,1.195870e-02,1.178074e-02,1.162779e-02, & - &1.008767e-02,9.911658e-03,9.758403e-03,9.624899e-03,9.512840e-03, & - &8.197181e-03,8.065710e-03,7.951079e-03,7.852442e-03,7.772851e-03, & - &6.634157e-03,6.538325e-03,6.454311e-03,6.384641e-03,6.330144e-03, & - &5.376200e-03,5.306389e-03,5.245693e-03,5.197779e-03,5.162158e-03, & - &4.360479e-03,4.309698e-03,4.267293e-03,4.235284e-03,4.214152e-03, & - &3.554123e-03,3.517009e-03,3.487699e-03,3.467406e-03,3.455888e-03, & - &2.903595e-03,2.876689e-03,2.856457e-03,2.843842e-03,2.838673e-03, & - &2.377752e-03,2.358154e-03,2.344022e-03,2.336616e-03,2.335464e-03, & - &1.958519e-03,1.943713e-03,1.933335e-03,1.928836e-03,1.929760e-03, & - &1.612996e-03,1.601805e-03,1.594487e-03,1.592150e-03,1.594280e-03, & - &1.327652e-03,1.319451e-03,1.314502e-03,1.313811e-03,1.316894e-03, & - &1.099142e-03,1.092817e-03,1.089092e-03,1.088916e-03,1.092090e-03, & - &9.105899e-04,9.056371e-04,9.027797e-04,9.029693e-04,9.060292e-04, & - &7.542572e-04,7.503467e-04,7.481974e-04,7.486205e-04,7.515537e-04, & - &6.262298e-04,6.229194e-04,6.211667e-04,6.215280e-04,6.241322e-04, & - &5.206522e-04,5.176773e-04,5.161412e-04,5.163887e-04,5.186031e-04, & - &4.330559e-04,4.302904e-04,4.289186e-04,4.290409e-04,4.309235e-04, & - &3.607096e-04,3.580097e-04,3.567001e-04,3.566734e-04,3.581827e-04, & - &3.013387e-04,2.985247e-04,2.971056e-04,2.968794e-04,2.979662e-04, & - &2.522728e-04,2.492292e-04,2.476792e-04,2.472590e-04,2.479720e-04, & - &2.117429e-04,2.084444e-04,2.067136e-04,2.060941e-04,2.064760e-04, & - &1.783977e-04,1.748937e-04,1.729520e-04,1.721457e-04,1.722565e-04, & - &1.509325e-04,1.472130e-04,1.450759e-04,1.440796e-04,1.439417e-04, & - &1.282312e-04,1.243700e-04,1.220315e-04,1.208186e-04,1.204553e-04, & - &1.094624e-04,1.055418e-04,1.029830e-04,1.015615e-04,1.009919e-04, & - &9.390381e-05,9.001511e-05,8.734163e-05,8.573446e-05,8.497374e-05, & - &8.102560e-05,7.717885e-05,7.444088e-05,7.268682e-05,7.176073e-05, & - &7.040985e-05,6.655801e-05,6.379325e-05,6.192731e-05,6.083187e-05, & - &6.172712e-05,5.781463e-05,5.501691e-05,5.306325e-05,5.182257e-05, & - &5.459753e-05,5.057750e-05,4.774179e-05,4.573021e-05,4.438570e-05, & - &4.747508e-05,4.368615e-05,4.102446e-05,3.913261e-05,3.784688e-05/ - data absb(:,5) / & - &1.159302e+00,1.133519e+00,1.109599e+00,1.087479e+00,1.066278e+00, & - &9.747881e-01,9.537591e-01,9.342567e-01,9.157921e-01,8.981024e-01, & - &8.240604e-01,8.069808e-01,7.910298e-01,7.755736e-01,7.607832e-01, & - &7.001609e-01,6.862152e-01,6.725980e-01,6.595268e-01,6.470324e-01, & - &5.989282e-01,5.870356e-01,5.753989e-01,5.642077e-01,5.535262e-01, & - &5.132667e-01,5.031701e-01,4.932676e-01,4.837162e-01,4.748233e-01, & - &4.408594e-01,4.321710e-01,4.236593e-01,4.155129e-01,4.081155e-01, & - &3.746105e-01,3.671440e-01,3.598643e-01,3.531119e-01,3.472315e-01, & - &3.158562e-01,3.094330e-01,3.033669e-01,2.979056e-01,2.933895e-01, & - &2.641290e-01,2.588366e-01,2.539959e-01,2.498688e-01,2.464797e-01, & - &2.202338e-01,2.160180e-01,2.123113e-01,2.092754e-01,2.067331e-01, & - &1.837445e-01,1.804487e-01,1.777128e-01,1.754667e-01,1.736541e-01, & - &1.530818e-01,1.506344e-01,1.486747e-01,1.470608e-01,1.458661e-01, & - &1.274483e-01,1.257374e-01,1.243299e-01,1.232709e-01,1.224997e-01, & - &1.059145e-01,1.047325e-01,1.037998e-01,1.031670e-01,1.026969e-01, & - &8.795258e-02,8.717223e-02,8.663715e-02,8.627773e-02,8.606993e-02, & - &7.271878e-02,7.229459e-02,7.204752e-02,7.193376e-02,7.194817e-02, & - &6.012439e-02,5.997367e-02,5.992822e-02,6.001209e-02,6.019264e-02, & - &4.963661e-02,4.967166e-02,4.979466e-02,5.002352e-02,5.033291e-02, & - &4.112930e-02,4.128388e-02,4.153015e-02,4.185165e-02,4.222909e-02, & - &3.417988e-02,3.442554e-02,3.475116e-02,3.512841e-02,3.555072e-02, & - &2.856340e-02,2.887183e-02,2.923303e-02,2.963787e-02,3.008002e-02, & - &2.391379e-02,2.425038e-02,2.462615e-02,2.504226e-02,2.548825e-02, & - &2.003594e-02,2.037883e-02,2.075307e-02,2.116592e-02,2.160525e-02, & - &1.684329e-02,1.718311e-02,1.755335e-02,1.795432e-02,1.838079e-02, & - &1.416024e-02,1.449124e-02,1.485046e-02,1.523805e-02,1.564746e-02, & - &1.190505e-02,1.222138e-02,1.256568e-02,1.293355e-02,1.332307e-02, & - &1.003837e-02,1.033965e-02,1.066795e-02,1.101831e-02,1.139066e-02, & - &8.466596e-03,8.751959e-03,9.063263e-03,9.395018e-03,9.748139e-03, & - &7.138954e-03,7.406832e-03,7.699221e-03,8.011433e-03,8.345243e-03, & - &6.012972e-03,6.262907e-03,6.535925e-03,6.828624e-03,7.143637e-03, & - &5.057553e-03,5.289130e-03,5.543120e-03,5.817652e-03,6.112840e-03, & - &4.248959e-03,4.462323e-03,4.697558e-03,4.952592e-03,5.228227e-03, & - &3.562067e-03,3.756358e-03,3.972810e-03,4.208803e-03,4.463610e-03, & - &2.977066e-03,3.152644e-03,3.349410e-03,3.565361e-03,3.800313e-03, & - &2.482932e-03,2.640559e-03,2.818484e-03,3.014449e-03,3.229358e-03, & - &2.065985e-03,2.206388e-03,2.366024e-03,2.542792e-03,2.738234e-03, & - &1.719983e-03,1.845051e-03,1.987606e-03,2.147756e-03,2.325651e-03, & - &1.430856e-03,1.541739e-03,1.669129e-03,1.813296e-03,1.975559e-03, & - &1.187612e-03,1.285401e-03,1.398572e-03,1.528083e-03,1.674900e-03, & - &9.831950e-04,1.068769e-03,1.168730e-03,1.284211e-03,1.416335e-03, & - &8.165780e-04,8.915639e-04,9.801043e-04,1.083439e-03,1.202789e-03, & - &6.790183e-04,7.446985e-04,8.230401e-04,9.155350e-04,1.023373e-03, & - &5.640477e-04,6.209142e-04,6.899783e-04,7.723831e-04,8.693873e-04, & - &4.679062e-04,5.168215e-04,5.773865e-04,6.502532e-04,7.372017e-04, & - &3.885492e-04,4.305879e-04,4.835122e-04,5.480026e-04,6.256189e-04, & - &3.290366e-04,3.668016e-04,4.149629e-04,4.741178e-04,5.462701e-04/ - data absb(:,6) / & - &1.382729e+01,1.361045e+01,1.339880e+01,1.318528e+01,1.297671e+01, & - &1.215184e+01,1.197005e+01,1.178863e+01,1.160737e+01,1.141693e+01, & - &1.057939e+01,1.042917e+01,1.027458e+01,1.011159e+01,9.945803e+00, & - &9.139043e+00,9.012748e+00,8.876207e+00,8.732092e+00,8.583960e+00, & - &7.845099e+00,7.732578e+00,7.608956e+00,7.482311e+00,7.360061e+00, & - &6.697558e+00,6.593114e+00,6.487607e+00,6.384723e+00,6.288270e+00, & - &5.707173e+00,5.620337e+00,5.535573e+00,5.454279e+00,5.378701e+00, & - &4.868334e+00,4.799218e+00,4.731849e+00,4.667185e+00,4.607309e+00, & - &4.165056e+00,4.109623e+00,4.055659e+00,4.005337e+00,3.958597e+00, & - &3.571646e+00,3.527209e+00,3.484915e+00,3.445205e+00,3.407055e+00, & - &3.076884e+00,3.041030e+00,3.008104e+00,2.975495e+00,2.944268e+00, & - &2.671988e+00,2.644047e+00,2.615901e+00,2.587570e+00,2.562712e+00, & - &2.335961e+00,2.311863e+00,2.286709e+00,2.263647e+00,2.244874e+00, & - &2.051615e+00,2.030472e+00,2.009909e+00,1.992344e+00,1.977838e+00, & - &1.796392e+00,1.780808e+00,1.766767e+00,1.753831e+00,1.744756e+00, & - &1.567214e+00,1.558167e+00,1.549997e+00,1.543555e+00,1.541020e+00, & - &1.351812e+00,1.348162e+00,1.345167e+00,1.344697e+00,1.348087e+00, & - &1.162585e+00,1.162777e+00,1.164413e+00,1.169095e+00,1.176669e+00, & - &9.909682e-01,9.942432e-01,9.997841e-01,1.007788e+00,1.018844e+00, & - &8.466457e-01,8.526688e-01,8.609830e-01,8.717217e-01,8.856425e-01, & - &7.242123e-01,7.326583e-01,7.429296e-01,7.559354e-01,7.719158e-01, & - &6.270406e-01,6.368733e-01,6.489196e-01,6.638034e-01,6.811956e-01, & - &5.445423e-01,5.554183e-01,5.688029e-01,5.844880e-01,6.027883e-01, & - &4.743514e-01,4.860278e-01,5.001292e-01,5.161272e-01,5.350133e-01, & - &4.159151e-01,4.281249e-01,4.424217e-01,4.583518e-01,4.772007e-01, & - &3.642122e-01,3.767261e-01,3.910904e-01,4.070660e-01,4.257219e-01, & - &3.180883e-01,3.306563e-01,3.448963e-01,3.609326e-01,3.795361e-01, & - &2.815414e-01,2.940901e-01,3.082177e-01,3.239779e-01,3.422455e-01, & - &2.496101e-01,2.620658e-01,2.760442e-01,2.915215e-01,3.094204e-01, & - &2.212072e-01,2.333760e-01,2.471110e-01,2.622414e-01,2.797460e-01, & - &1.958290e-01,2.076159e-01,2.209513e-01,2.356639e-01,2.525646e-01, & - &1.730016e-01,1.843435e-01,1.971933e-01,2.113993e-01,2.276880e-01, & - &1.523782e-01,1.632389e-01,1.754938e-01,1.891203e-01,2.047294e-01, & - &1.339711e-01,1.442668e-01,1.558634e-01,1.688358e-01,1.836634e-01, & - &1.177680e-01,1.275595e-01,1.384892e-01,1.507841e-01,1.647601e-01, & - &1.030053e-01,1.122052e-01,1.224203e-01,1.339934e-01,1.471438e-01, & - &8.941823e-02,9.796213e-02,1.073694e-01,1.181260e-01,1.305277e-01, & - &7.855825e-02,8.667751e-02,9.554666e-02,1.056682e-01,1.173969e-01, & - &6.943417e-02,7.722278e-02,8.568031e-02,9.524032e-02,1.063586e-01, & - &6.108065e-02,6.848980e-02,7.650162e-02,8.550330e-02,9.601118e-02, & - &5.335543e-02,6.030016e-02,6.783230e-02,7.624801e-02,8.618742e-02, & - &4.804223e-02,5.491870e-02,6.236790e-02,7.059195e-02,8.011730e-02, & - &4.407223e-02,5.110057e-02,5.872798e-02,6.704820e-02,7.644098e-02, & - &4.042813e-02,4.761779e-02,5.543812e-02,6.394439e-02,7.337458e-02, & - &3.707089e-02,4.442223e-02,5.244429e-02,6.120022e-02,7.079569e-02, & - &3.421562e-02,4.185271e-02,5.018101e-02,5.932213e-02,6.930313e-02, & - &3.437476e-02,4.300112e-02,5.250651e-02,6.302970e-02,7.450133e-02/ - data absb(:,7) / & - &1.190041e+02,1.175623e+02,1.161644e+02,1.147471e+02,1.133323e+02, & - &1.184444e+02,1.170483e+02,1.157435e+02,1.143832e+02,1.130499e+02, & - &1.163096e+02,1.151450e+02,1.138595e+02,1.125953e+02,1.113044e+02, & - &1.128614e+02,1.117902e+02,1.105859e+02,1.094026e+02,1.082326e+02, & - &1.080736e+02,1.070787e+02,1.059994e+02,1.049897e+02,1.039760e+02, & - &1.021131e+02,1.013033e+02,1.004252e+02,9.955048e+01,9.870309e+01, & - &9.537663e+01,9.468456e+01,9.398923e+01,9.335103e+01,9.271488e+01, & - &8.799133e+01,8.750656e+01,8.714561e+01,8.676523e+01,8.641797e+01, & - &8.038831e+01,8.023026e+01,8.016666e+01,8.008650e+01,8.006665e+01, & - &7.291383e+01,7.312939e+01,7.337817e+01,7.364661e+01,7.398444e+01, & - &6.594897e+01,6.647179e+01,6.707553e+01,6.768547e+01,6.839435e+01, & - &5.961938e+01,6.044418e+01,6.134812e+01,6.237325e+01,6.338700e+01, & - &5.398657e+01,5.512030e+01,5.636687e+01,5.766694e+01,5.894657e+01, & - &4.913622e+01,5.057143e+01,5.208431e+01,5.362476e+01,5.516516e+01, & - &4.500526e+01,4.671547e+01,4.844099e+01,5.020451e+01,5.198318e+01, & - &4.158728e+01,4.349689e+01,4.543909e+01,4.742028e+01,4.940939e+01, & - &3.876678e+01,4.086613e+01,4.302674e+01,4.520810e+01,4.738895e+01, & - &3.647603e+01,3.878366e+01,4.114120e+01,4.348392e+01,4.584042e+01, & - &3.466484e+01,3.716917e+01,3.968585e+01,4.218572e+01,4.469382e+01, & - &3.331927e+01,3.598551e+01,3.864928e+01,4.128587e+01,4.389636e+01, & - &3.237078e+01,3.517774e+01,3.796555e+01,4.071112e+01,4.341068e+01, & - &3.166902e+01,3.458294e+01,3.748066e+01,4.030807e+01,4.308524e+01, & - &3.095636e+01,3.395814e+01,3.694269e+01,3.985003e+01,4.269267e+01, & - &3.011815e+01,3.320091e+01,3.626373e+01,3.924416e+01,4.214220e+01, & - &2.897067e+01,3.212206e+01,3.525546e+01,3.830609e+01,4.126802e+01, & - &2.791018e+01,3.112231e+01,3.431163e+01,3.743147e+01,4.044027e+01, & - &2.694851e+01,3.021474e+01,3.345579e+01,3.663050e+01,3.968720e+01, & - &2.575634e+01,2.904807e+01,3.232998e+01,3.556471e+01,3.867527e+01, & - &2.456726e+01,2.789007e+01,3.120958e+01,3.449601e+01,3.765801e+01, & - &2.342662e+01,2.677300e+01,3.012740e+01,3.345963e+01,3.666676e+01, & - &2.214323e+01,2.550113e+01,2.888622e+01,3.225266e+01,3.551360e+01, & - &2.081915e+01,2.417171e+01,2.757432e+01,3.097818e+01,3.428941e+01, & - &1.953527e+01,2.287026e+01,2.628395e+01,2.971899e+01,3.306805e+01, & - &1.821361e+01,2.151911e+01,2.493454e+01,2.838592e+01,3.177396e+01, & - &1.678616e+01,2.005925e+01,2.345294e+01,2.691631e+01,3.033790e+01, & - &1.539205e+01,1.862570e+01,2.199016e+01,2.545562e+01,2.890024e+01, & - &1.403560e+01,1.721929e+01,2.055138e+01,2.400380e+01,2.745971e+01, & - &1.280584e+01,1.592628e+01,1.923172e+01,2.264845e+01,2.611116e+01, & - &1.165618e+01,1.470336e+01,1.796457e+01,2.133844e+01,2.480777e+01, & - &1.055384e+01,1.351527e+01,1.671920e+01,2.005608e+01,2.351268e+01, & - &9.500521e+00,1.235794e+01,1.549355e+01,1.879069e+01,2.222212e+01, & - &8.591905e+00,1.133631e+01,1.439747e+01,1.764655e+01,2.104734e+01, & - &7.766077e+00,1.039707e+01,1.337662e+01,1.656937e+01,1.993274e+01, & - &6.989856e+00,9.501224e+00,1.238500e+01,1.551371e+01,1.883262e+01, & - &6.264458e+00,8.647705e+00,1.142173e+01,1.448221e+01,1.775041e+01, & - &5.628994e+00,7.883840e+00,1.054402e+01,1.352679e+01,1.674016e+01, & - &5.436881e+00,7.633531e+00,1.024110e+01,1.318084e+01,1.636336e+01/ - data absb(:,8) / & - &4.882779e+02,4.814299e+02,4.744679e+02,4.675703e+02,4.606866e+02, & - &5.442115e+02,5.361937e+02,5.278798e+02,5.198406e+02,5.118845e+02, & - &6.025889e+02,5.922932e+02,5.823646e+02,5.737521e+02,5.652055e+02, & - &6.609816e+02,6.496046e+02,6.386595e+02,6.292288e+02,6.195486e+02, & - &7.201794e+02,7.081062e+02,6.960718e+02,6.854215e+02,6.742737e+02, & - &7.798324e+02,7.666280e+02,7.537878e+02,7.410997e+02,7.291517e+02, & - &8.386863e+02,8.236498e+02,8.101107e+02,7.957410e+02,7.822604e+02, & - &8.956940e+02,8.790824e+02,8.637075e+02,8.476681e+02,8.325094e+02, & - &9.496956e+02,9.310414e+02,9.141234e+02,8.963499e+02,8.790138e+02, & - &9.969762e+02,9.776011e+02,9.591561e+02,9.394222e+02,9.203171e+02, & - &1.040068e+03,1.020559e+03,9.989252e+02,9.775448e+02,9.565908e+02, & - &1.077647e+03,1.056687e+03,1.033095e+03,1.010186e+03,9.877375e+02, & - &1.109634e+03,1.087340e+03,1.062131e+03,1.037759e+03,1.014134e+03, & - &1.135990e+03,1.112409e+03,1.085874e+03,1.060398e+03,1.035555e+03, & - &1.157630e+03,1.132902e+03,1.105321e+03,1.078722e+03,1.052835e+03, & - &1.174856e+03,1.149207e+03,1.120573e+03,1.093058e+03,1.066160e+03, & - &1.188118e+03,1.161682e+03,1.132111e+03,1.103654e+03,1.075839e+03, & - &1.198070e+03,1.170675e+03,1.140254e+03,1.111144e+03,1.082644e+03, & - &1.204776e+03,1.176662e+03,1.145553e+03,1.115881e+03,1.086863e+03, & - &1.208745e+03,1.180024e+03,1.148409e+03,1.118203e+03,1.088834e+03, & - &1.210409e+03,1.181172e+03,1.149148e+03,1.118557e+03,1.089007e+03, & - &1.211332e+03,1.181727e+03,1.149256e+03,1.118477e+03,1.088657e+03, & - &1.213850e+03,1.183883e+03,1.151059e+03,1.120070e+03,1.090042e+03, & - &1.218665e+03,1.188374e+03,1.155345e+03,1.123962e+03,1.093644e+03, & - &1.227592e+03,1.196988e+03,1.163465e+03,1.131738e+03,1.101063e+03, & - &1.236104e+03,1.205159e+03,1.171332e+03,1.139182e+03,1.108261e+03, & - &1.243974e+03,1.212784e+03,1.178633e+03,1.146127e+03,1.114943e+03, & - &1.256756e+03,1.223415e+03,1.188916e+03,1.155981e+03,1.124368e+03, & - &1.267762e+03,1.234133e+03,1.199279e+03,1.165989e+03,1.134044e+03, & - &1.278444e+03,1.244600e+03,1.209505e+03,1.175872e+03,1.143580e+03, & - &1.290859e+03,1.256856e+03,1.221424e+03,1.187439e+03,1.154666e+03, & - &1.303887e+03,1.269793e+03,1.234103e+03,1.199746e+03,1.166610e+03, & - &1.316768e+03,1.282682e+03,1.246646e+03,1.211953e+03,1.178463e+03, & - &1.330149e+03,1.294899e+03,1.259935e+03,1.224961e+03,1.191102e+03, & - &1.344900e+03,1.309661e+03,1.274670e+03,1.239426e+03,1.205151e+03, & - &1.359446e+03,1.324325e+03,1.289262e+03,1.253791e+03,1.219309e+03, & - &1.373942e+03,1.338900e+03,1.303870e+03,1.268252e+03,1.233505e+03, & - &1.387213e+03,1.352424e+03,1.318422e+03,1.281802e+03,1.246845e+03, & - &1.399969e+03,1.365396e+03,1.331571e+03,1.295233e+03,1.259770e+03, & - &1.412375e+03,1.378273e+03,1.344612e+03,1.308247e+03,1.272705e+03, & - &1.424616e+03,1.390980e+03,1.357578e+03,1.321252e+03,1.285714e+03, & - &1.433689e+03,1.402463e+03,1.369412e+03,1.333111e+03,1.297636e+03, & - &1.443917e+03,1.413231e+03,1.380597e+03,1.344433e+03,1.309037e+03, & - &1.453758e+03,1.423903e+03,1.391647e+03,1.355685e+03,1.321549e+03, & - &1.463370e+03,1.434271e+03,1.402684e+03,1.366853e+03,1.332935e+03, & - &1.472256e+03,1.443993e+03,1.412864e+03,1.377358e+03,1.343630e+03, & - &1.475724e+03,1.447772e+03,1.416965e+03,1.381553e+03,1.347887e+03/ - -! the array selfref contains the coefficient of the water vapor -! self-continuum (including the energy term). the first index -! refers to temperature in 7.2 degree increments. for instance, -! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, -! etc. the second index runs over the g-channel (1 to NG11=8). - - data selfref(:, 1) / & - &5.959000e-01,5.485330e-01,5.049310e-01,4.647960e-01,4.278500e-01, & - &3.938410e-01,3.625360e-01,3.337190e-01,3.071920e-01,2.827740e-01/ - data selfref(:, 2) / & - &7.471130e-01,6.830840e-01,6.245410e-01,5.710160e-01,5.220790e-01, & - &4.773350e-01,4.364260e-01,3.990230e-01,3.648260e-01,3.335590e-01/ - data selfref(:, 3) / & - &7.988964e-01,7.324023e-01,6.714425e-01,6.155564e-01,5.643218e-01, & - &5.173525e-01,4.742919e-01,4.348158e-01,3.986253e-01,3.654463e-01/ - data selfref(:, 4) / & - &8.126742e-01,7.454770e-01,6.838362e-01,6.272918e-01,5.754224e-01, & - &5.278428e-01,4.841975e-01,4.441605e-01,4.074343e-01,3.737449e-01/ - data selfref(:, 5) / & - &8.182882e-01,7.523750e-01,6.917713e-01,6.360493e-01,5.848154e-01, & - &5.377092e-01,4.943972e-01,4.545738e-01,4.179584e-01,3.842925e-01/ - data selfref(:, 6) / & - &8.344160e-01,7.668902e-01,7.048330e-01,6.478007e-01,5.953856e-01, & - &5.472136e-01,5.029414e-01,4.622543e-01,4.248599e-01,3.904924e-01/ - data selfref(:, 7) / & - &8.438312e-01,7.747597e-01,7.113467e-01,6.531295e-01,5.996813e-01, & - &5.506109e-01,5.055595e-01,4.641982e-01,4.262237e-01,3.913587e-01/ - data selfref(:, 8) / & - &8.871206e-01,8.151222e-01,7.489702e-01,6.881906e-01,6.323459e-01, & - &5.810357e-01,5.338908e-01,4.905733e-01,4.507729e-01,4.142032e-01/ - - data fracrefa / & - & 0.1415281892, 0.1381126046, 0.2801806927, 0.2251492739, & - & 0.1543178260, 0.0491050109, 0.0095453896, 0.0020623801 / - data fracrefb / & - & 0.1087403893, 0.1516488940, 0.2966488302, 0.2321123779, & - & 0.1517885625, 0.0477351174, 0.0092400005, 0.0020862001 / - -!........................................! - end module module_radlw_kgb11 ! -!========================================! - - - -!========================================! - module module_radlw_kgb12 ! -!........................................! -! - use machine, only : kind_phys - use module_radlw_parameters, only : NG12 -! - implicit none -! - private -! - integer, public :: MSA12, MSF12, MAF12 - parameter (MSA12=585, MSF12=10, MAF12=9) - - real (kind=kind_phys), public :: & - & absa(MSA12,NG12), selfref(MSF12,NG12), fracrefa(NG12,MAF12) - -! the array absa(585,NG12) = ka(9,5,13,NG12) contains absorption coefs -! at the NG12=8 chosen g-values for a range of pressure levels> ~100mb, -! temperatures, and binary species parameters (see taumol.f for -! definition). the first index in the array, js, runs from 1 to 9, -! and corresponds to different values of the binary species parameter. -! for instance, js=1 refers to dry air, js = 2 corresponds to the -! paramter value 1/8, js = 3 corresponds to the parameter value 2/8, -! etc. the second index in the array, jt, which runs from 1 to 5, -! corresponds to different temperatures. more specifically, jt = 1-5 -! means that the data are for the corresponding temperature of -! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the -! third index, jp, runs from 1 to 13 and refers to the jpth reference -! pressure level (see taumol.f for these levels in mb). the fourth -! index, ig, goes from 1 to NG12=8, and indicates which g-interval -! the absorption coefficients are for. - - data absa(1:270,1) / & - &1.107100e-04,1.719000e-03,2.129700e-03,2.297400e-03,2.363800e-03, & - &2.337700e-03,2.218200e-03,1.959800e-03,6.064400e-04,1.196100e-04, & - &1.852300e-03,2.313900e-03,2.508700e-03,2.583200e-03,2.550700e-03, & - &2.422600e-03,2.140000e-03,6.678700e-04,1.289700e-04,1.981400e-03, & - &2.490400e-03,2.722400e-03,2.799200e-03,2.761600e-03,2.628500e-03, & - &2.329700e-03,7.422600e-04,1.390000e-04,2.106900e-03,2.661900e-03, & - &2.925600e-03,3.008500e-03,2.976000e-03,2.838300e-03,2.526900e-03, & - &8.201900e-04,1.498000e-04,2.230700e-03,2.825800e-03,3.115300e-03, & - &3.214000e-03,3.191900e-03,3.052900e-03,2.731200e-03,9.030600e-04, & - &9.503300e-05,1.395200e-03,1.734500e-03,1.875700e-03,1.930100e-03, & - &1.908800e-03,1.810900e-03,1.600300e-03,4.814700e-04,1.026400e-04, & - &1.504300e-03,1.886200e-03,2.052400e-03,2.115500e-03,2.089100e-03, & - &1.982800e-03,1.751800e-03,5.317900e-04,1.108800e-04,1.611000e-03, & - &2.032600e-03,2.229600e-03,2.296900e-03,2.267200e-03,2.156500e-03, & - &1.910700e-03,5.906300e-04,1.197800e-04,1.714200e-03,2.174700e-03, & - &2.400400e-03,2.472200e-03,2.448600e-03,2.333800e-03,2.076200e-03, & - &6.525200e-04,1.291700e-04,1.816800e-03,2.312400e-03,2.558900e-03, & - &2.646500e-03,2.631400e-03,2.516200e-03,2.249100e-03,7.192800e-04, & - &7.967200e-05,1.111300e-03,1.381100e-03,1.495000e-03,1.539600e-03, & - &1.523700e-03,1.445000e-03,1.277200e-03,3.775000e-04,8.583500e-05, & - &1.201200e-03,1.507200e-03,1.641200e-03,1.693800e-03,1.676500e-03, & - &1.587800e-03,1.402000e-03,4.169300e-04,9.272400e-05,1.289400e-03, & - &1.628400e-03,1.788700e-03,1.847000e-03,1.826100e-03,1.732800e-03, & - &1.533500e-03,4.622600e-04,1.002100e-04,1.375300e-03,1.746700e-03, & - &1.933400e-03,1.994500e-03,1.976300e-03,1.880700e-03,1.670100e-03, & - &5.113100e-04,1.082600e-04,1.460200e-03,1.862800e-03,2.068400e-03, & - &2.141000e-03,2.129100e-03,2.033300e-03,1.814600e-03,5.635900e-04, & - &6.654100e-05,8.772000e-04,1.088000e-03,1.178900e-03,1.215000e-03, & - &1.204000e-03,1.142900e-03,1.010200e-03,3.006500e-04,7.124000e-05, & - &9.511600e-04,1.192800e-03,1.299700e-03,1.342700e-03,1.331100e-03, & - &1.260200e-03,1.111800e-03,3.311200e-04,7.662700e-05,1.024600e-03, & - &1.292900e-03,1.421400e-03,1.471100e-03,1.455900e-03,1.380000e-03, & - &1.219300e-03,3.662300e-04,8.269700e-05,1.096700e-03,1.391000e-03, & - &1.543400e-03,1.595700e-03,1.580100e-03,1.501900e-03,1.331800e-03, & - &4.047900e-04,8.935300e-05,1.167500e-03,1.488400e-03,1.658400e-03, & - &1.718000e-03,1.706400e-03,1.627300e-03,1.451100e-03,4.459000e-04, & - &5.599800e-05,6.898300e-04,8.527400e-04,9.249300e-04,9.540500e-04, & - &9.477100e-04,9.015600e-04,7.978200e-04,2.447300e-04,5.956900e-05, & - &7.505300e-04,9.393500e-04,1.024700e-03,1.059200e-03,1.050900e-03, & - &9.960900e-04,8.790400e-04,2.687400e-04,6.372800e-05,8.116400e-04, & - &1.022700e-03,1.124500e-03,1.165600e-03,1.155000e-03,1.093900e-03, & - &9.666800e-04,2.963100e-04,6.849300e-05,8.719100e-04,1.104300e-03, & - &1.225400e-03,1.270100e-03,1.257500e-03,1.193800e-03,1.058500e-03, & - &3.269300e-04,7.380400e-05,9.312400e-04,1.185800e-03,1.323100e-03, & - &1.371300e-03,1.361800e-03,1.296700e-03,1.155600e-03,3.595900e-04, & - &4.743300e-05,5.395200e-04,6.630200e-04,7.194100e-04,7.427800e-04, & - &7.399300e-04,7.068200e-04,6.273700e-04,2.050200e-04,5.019400e-05, & - &5.891400e-04,7.343000e-04,8.009300e-04,8.283900e-04,8.223400e-04, & - &7.816100e-04,6.909600e-04,2.241300e-04,5.341200e-05,6.396700e-04, & - &8.039300e-04,8.824600e-04,9.153300e-04,9.087200e-04,8.611100e-04, & - &7.615800e-04,2.461100e-04,5.716700e-05,6.900300e-04,8.718600e-04, & - &9.649900e-04,1.002500e-03,9.932400e-04,9.422800e-04,8.352400e-04, & - &2.708400e-04,6.136900e-05,7.399100e-04,9.397900e-04,1.047300e-03, & - &1.086200e-03,1.078800e-03,1.026600e-03,9.137900e-04,2.972000e-04/ - data absa(271:585,1) / & - &4.020400e-05,4.207100e-04,5.132900e-04,5.570400e-04,5.759800e-04, & - &5.756000e-04,5.529400e-04,4.931100e-04,1.803800e-04,4.240900e-05, & - &4.613900e-04,5.711600e-04,6.232300e-04,6.445100e-04,6.409600e-04, & - &6.114200e-04,5.419600e-04,1.958200e-04,4.496900e-05,5.026700e-04, & - &6.291100e-04,6.893800e-04,7.151100e-04,7.107300e-04,6.754800e-04, & - &5.979000e-04,2.137900e-04,4.792600e-05,5.447100e-04,6.858600e-04, & - &7.565300e-04,7.868200e-04,7.809900e-04,7.411500e-04,6.572300e-04, & - &2.338200e-04,5.130400e-05,5.864500e-04,7.418000e-04,8.244600e-04, & - &8.567400e-04,8.510400e-04,8.096800e-04,7.203300e-04,2.556900e-04, & - &3.440400e-05,3.274200e-04,3.962800e-04,4.304400e-04,4.458200e-04, & - &4.475000e-04,4.325500e-04,3.882400e-04,1.614000e-04,3.610200e-05, & - &3.607800e-04,4.431700e-04,4.834900e-04,5.000600e-04,4.987400e-04, & - &4.778600e-04,4.252900e-04,1.738200e-04,3.823200e-05,3.947700e-04, & - &4.906900e-04,5.371200e-04,5.570300e-04,5.542500e-04,5.284000e-04, & - &4.687800e-04,1.887200e-04,4.072300e-05,4.293500e-04,5.378200e-04, & - &5.916700e-04,6.151300e-04,6.121900e-04,5.819500e-04,5.163700e-04, & - &2.056800e-04,4.353300e-05,4.640500e-04,5.843000e-04,6.472400e-04, & - &6.739400e-04,6.696800e-04,6.373500e-04,5.668500e-04,2.247500e-04, & - &2.943500e-05,2.540700e-04,3.051300e-04,3.315400e-04,3.445000e-04, & - &3.477000e-04,3.382300e-04,3.061200e-04,1.490400e-04,3.083200e-05, & - &2.815600e-04,3.430700e-04,3.739500e-04,3.870700e-04,3.874000e-04, & - &3.730800e-04,3.338400e-04,1.602100e-04,3.254100e-05,3.096700e-04, & - &3.814200e-04,4.175100e-04,4.326200e-04,4.310900e-04,4.124100e-04, & - &3.669900e-04,1.730400e-04,3.459800e-05,3.381500e-04,4.203700e-04, & - &4.616200e-04,4.797100e-04,4.780200e-04,4.557700e-04,4.045800e-04, & - &1.880400e-04,3.700700e-05,3.669000e-04,4.592100e-04,5.069000e-04, & - &5.282300e-04,5.257600e-04,5.005700e-04,4.449100e-04,2.055400e-04, & - &2.492700e-05,1.980600e-04,2.368900e-04,2.575100e-04,2.686700e-04, & - &2.725200e-04,2.664900e-04,2.434000e-04,1.392600e-04,2.629100e-05, & - &2.209900e-04,2.674000e-04,2.913700e-04,3.019400e-04,3.032700e-04, & - &2.934200e-04,2.641400e-04,1.484600e-04,2.795100e-05,2.443700e-04, & - &2.984800e-04,3.265800e-04,3.382700e-04,3.377800e-04,3.241500e-04, & - &2.894600e-04,1.599800e-04,2.990700e-05,2.682100e-04,3.302600e-04, & - &3.623700e-04,3.764300e-04,3.753800e-04,3.586100e-04,3.189100e-04, & - &1.739600e-04,3.207400e-05,2.921300e-04,3.623700e-04,3.991400e-04, & - &4.158000e-04,4.147500e-04,3.950900e-04,3.510500e-04,1.900000e-04, & - &2.103000e-05,1.626200e-04,1.949700e-04,2.121300e-04,2.212400e-04, & - &2.243400e-04,2.194500e-04,2.005600e-04,1.198900e-04,2.221500e-05, & - &1.818200e-04,2.197900e-04,2.398100e-04,2.486000e-04,2.496500e-04, & - &2.415300e-04,2.177100e-04,1.277200e-04,2.385400e-05,2.014000e-04, & - &2.452300e-04,2.686000e-04,2.783400e-04,2.780500e-04,2.668300e-04, & - &2.385300e-04,1.377700e-04,2.593700e-05,2.214500e-04,2.713200e-04, & - &2.979700e-04,3.098000e-04,3.091400e-04,2.953500e-04,2.627600e-04, & - &1.497500e-04,2.820000e-05,2.415700e-04,2.978400e-04,3.282500e-04, & - &3.422400e-04,3.415800e-04,3.254800e-04,2.892100e-04,1.634900e-04, & - &1.743600e-05,1.333600e-04,1.602900e-04,1.746400e-04,1.820600e-04, & - &1.845100e-04,1.804600e-04,1.650600e-04,9.937800e-05,1.842100e-05, & - &1.492200e-04,1.805600e-04,1.972700e-04,2.045200e-04,2.053400e-04, & - &1.986100e-04,1.792300e-04,1.059400e-04,1.977000e-05,1.654600e-04, & - &2.013700e-04,2.208000e-04,2.289500e-04,2.287300e-04,2.195000e-04, & - &1.963400e-04,1.143700e-04,2.153200e-05,1.821400e-04,2.227800e-04, & - &2.448500e-04,2.547700e-04,2.544200e-04,2.431200e-04,2.163300e-04, & - &1.243000e-04,2.366500e-05,1.989400e-04,2.446600e-04,2.698000e-04, & - &2.815500e-04,2.812000e-04,2.680400e-04,2.380700e-04,1.356500e-04, & - &1.438700e-05,1.090800e-04,1.315700e-04,1.436100e-04,1.496500e-04, & - &1.516200e-04,1.482600e-04,1.357000e-04,8.106800e-05,1.522200e-05, & - &1.220800e-04,1.480800e-04,1.620600e-04,1.680600e-04,1.687300e-04, & - &1.632000e-04,1.473700e-04,8.644000e-05,1.633700e-05,1.356100e-04, & - &1.650400e-04,1.812400e-04,1.881500e-04,1.880800e-04,1.804800e-04, & - &1.614600e-04,9.331100e-05,1.778300e-05,1.494700e-04,1.825700e-04, & - &2.009500e-04,2.093300e-04,2.092700e-04,2.000100e-04,1.779200e-04, & - &1.013100e-04,1.957000e-05,1.634500e-04,2.006200e-04,2.215100e-04, & - &2.314400e-04,2.312900e-04,2.204900e-04,1.957700e-04,1.104600e-04/ - data absa(1:270,2) / & - &9.249700e-04,4.314400e-03,5.699100e-03,6.494200e-03,6.893800e-03, & - &6.912800e-03,6.492100e-03,5.636900e-03,1.848300e-03,1.040900e-03, & - &4.638300e-03,6.063300e-03,6.906300e-03,7.316900e-03,7.360800e-03, & - &6.919200e-03,6.002800e-03,2.030000e-03,1.155600e-03,4.976400e-03, & - &6.448800e-03,7.328800e-03,7.771700e-03,7.827900e-03,7.374800e-03, & - &6.383300e-03,2.207200e-03,1.267500e-03,5.312100e-03,6.853700e-03, & - &7.779600e-03,8.249200e-03,8.316200e-03,7.862600e-03,6.786500e-03, & - &2.396900e-03,1.375800e-03,5.641000e-03,7.280400e-03,8.255300e-03, & - &8.752800e-03,8.822600e-03,8.375000e-03,7.219100e-03,2.608900e-03, & - &7.518600e-04,3.610300e-03,4.763500e-03,5.424000e-03,5.753500e-03, & - &5.779700e-03,5.419800e-03,4.683600e-03,1.455600e-03,8.439800e-04, & - &3.887700e-03,5.081900e-03,5.783900e-03,6.117100e-03,6.158000e-03, & - &5.787300e-03,4.998400e-03,1.600600e-03,9.348300e-04,4.171300e-03, & - &5.417000e-03,6.156700e-03,6.511500e-03,6.557200e-03,6.178300e-03, & - &5.323200e-03,1.748900e-03,1.023800e-03,4.454800e-03,5.764700e-03, & - &6.544400e-03,6.927300e-03,6.970800e-03,6.598400e-03,5.670800e-03, & - &1.910900e-03,1.110700e-03,4.735700e-03,6.121900e-03,6.953800e-03, & - &7.365800e-03,7.404600e-03,7.032200e-03,6.041200e-03,2.090400e-03, & - &6.014200e-04,2.952300e-03,3.910400e-03,4.451700e-03,4.717400e-03, & - &4.737200e-03,4.449200e-03,3.824300e-03,1.126300e-03,6.740600e-04, & - &3.182300e-03,4.181100e-03,4.759200e-03,5.029000e-03,5.057500e-03, & - &4.758800e-03,4.094000e-03,1.242800e-03,7.462000e-04,3.421000e-03, & - &4.461800e-03,5.079300e-03,5.362900e-03,5.395000e-03,5.090500e-03, & - &4.373900e-03,1.365700e-03,8.175200e-04,3.659800e-03,4.751500e-03, & - &5.406700e-03,5.717600e-03,5.746000e-03,5.444700e-03,4.667600e-03, & - &1.500700e-03,8.875000e-04,3.896700e-03,5.047900e-03,5.748200e-03, & - &6.092500e-03,6.115400e-03,5.809200e-03,4.982400e-03,1.647100e-03, & - &4.810100e-04,2.390600e-03,3.185300e-03,3.623100e-03,3.836000e-03, & - &3.845200e-03,3.618600e-03,3.101900e-03,8.757300e-04,5.396100e-04, & - &2.578500e-03,3.408500e-03,3.882000e-03,4.098700e-03,4.118300e-03, & - &3.880000e-03,3.330500e-03,9.693200e-04,5.979900e-04,2.776800e-03, & - &3.640600e-03,4.151700e-03,4.379700e-03,4.402800e-03,4.160100e-03, & - &3.570000e-03,1.070300e-03,6.557900e-04,2.975200e-03,3.879500e-03, & - &4.422000e-03,4.679000e-03,4.700100e-03,4.458100e-03,3.819900e-03, & - &1.180800e-03,7.124100e-04,3.172400e-03,4.125700e-03,4.702500e-03, & - &4.991300e-03,5.011300e-03,4.764900e-03,4.084400e-03,1.301100e-03, & - &3.798500e-04,1.929600e-03,2.582300e-03,2.936700e-03,3.105300e-03, & - &3.106800e-03,2.925600e-03,2.507500e-03,6.859000e-04,4.277400e-04, & - &2.082200e-03,2.766500e-03,3.151200e-03,3.326100e-03,3.338400e-03, & - &3.146800e-03,2.700400e-03,7.613400e-04,4.758600e-04,2.244200e-03, & - &2.957500e-03,3.374700e-03,3.561100e-03,3.580400e-03,3.385100e-03, & - &2.903300e-03,8.441400e-04,5.237800e-04,2.406800e-03,3.153400e-03, & - &3.599400e-03,3.809900e-03,3.832600e-03,3.636500e-03,3.117800e-03, & - &9.339200e-04,5.710700e-04,2.567600e-03,3.355900e-03,3.829400e-03, & - &4.068800e-03,4.093100e-03,3.895800e-03,3.341800e-03,1.032900e-03, & - &2.973500e-04,1.548800e-03,2.078100e-03,2.363500e-03,2.496800e-03, & - &2.493100e-03,2.346700e-03,2.008500e-03,5.422300e-04,3.358700e-04, & - &1.670900e-03,2.230800e-03,2.540900e-03,2.680800e-03,2.689500e-03, & - &2.534000e-03,2.171500e-03,6.021500e-04,3.747300e-04,1.800400e-03, & - &2.387500e-03,2.725300e-03,2.875700e-03,2.892100e-03,2.734000e-03, & - &2.341500e-03,6.692000e-04,4.138500e-04,1.933600e-03,2.547400e-03, & - &2.910600e-03,3.079500e-03,3.104100e-03,2.946400e-03,2.523600e-03, & - &7.422700e-04,4.528200e-04,2.064100e-03,2.712500e-03,3.099800e-03, & - &3.293700e-03,3.320100e-03,3.163000e-03,2.712100e-03,8.226400e-04/ - data absa(271:585,2) / & - &2.321600e-04,1.236200e-03,1.661600e-03,1.890800e-03,1.997100e-03, & - &1.990500e-03,1.872000e-03,1.599100e-03,4.417800e-04,2.628900e-04, & - &1.332900e-03,1.789100e-03,2.036900e-03,2.150400e-03,2.155500e-03, & - &2.029000e-03,1.736500e-03,4.912300e-04,2.941700e-04,1.435900e-03, & - &1.915600e-03,2.189600e-03,2.310200e-03,2.325000e-03,2.195800e-03, & - &1.878300e-03,5.468800e-04,3.258500e-04,1.543700e-03,2.046300e-03, & - &2.341900e-03,2.477700e-03,2.498100e-03,2.374400e-03,2.029900e-03, & - &6.074200e-04,3.576200e-04,1.650400e-03,2.179800e-03,2.496700e-03, & - &2.652800e-03,2.676200e-03,2.553300e-03,2.188800e-03,6.738000e-04, & - &1.825400e-04,9.837400e-04,1.324300e-03,1.505700e-03,1.590200e-03, & - &1.582400e-03,1.486900e-03,1.266500e-03,3.985000e-04,2.066600e-04, & - &1.060300e-03,1.427500e-03,1.625900e-03,1.718100e-03,1.720100e-03, & - &1.617400e-03,1.382600e-03,4.416900e-04,2.315700e-04,1.141900e-03, & - &1.531900e-03,1.752000e-03,1.848700e-03,1.861200e-03,1.756600e-03, & - &1.501500e-03,4.890500e-04,2.570000e-04,1.227800e-03,1.637300e-03, & - &1.876500e-03,1.984900e-03,2.001400e-03,1.903100e-03,1.627000e-03, & - &5.421300e-04,2.828300e-04,1.315800e-03,1.745000e-03,2.001700e-03, & - &2.125500e-03,2.146800e-03,2.051800e-03,1.759700e-03,6.008700e-04, & - &1.449200e-04,7.822000e-04,1.052900e-03,1.194800e-03,1.261600e-03, & - &1.253200e-03,1.176300e-03,9.978700e-04,3.827100e-04,1.638500e-04, & - &8.433200e-04,1.136200e-03,1.293500e-03,1.367700e-03,1.366500e-03, & - &1.284700e-03,1.096000e-03,4.206800e-04,1.836600e-04,9.078700e-04, & - &1.222300e-03,1.395900e-03,1.475000e-03,1.483900e-03,1.399300e-03, & - &1.195500e-03,4.666000e-04,2.040100e-04,9.762100e-04,1.307900e-03, & - &1.499100e-03,1.584400e-03,1.598900e-03,1.518600e-03,1.300000e-03, & - &5.201600e-04,2.247700e-04,1.047900e-03,1.394800e-03,1.600600e-03, & - &1.697900e-03,1.715900e-03,1.641500e-03,1.409300e-03,5.781600e-04, & - &1.186900e-04,6.267100e-04,8.408200e-04,9.519000e-04,1.003900e-03, & - &9.969299e-04,9.350400e-04,7.890200e-04,3.514000e-04,1.338100e-04, & - &6.759900e-04,9.091300e-04,1.033200e-03,1.092100e-03,1.089100e-03, & - &1.024300e-03,8.721800e-04,3.876300e-04,1.495900e-04,7.276500e-04, & - &9.795800e-04,1.115900e-03,1.180200e-03,1.185900e-03,1.118300e-03, & - &9.553300e-04,4.301000e-04,1.658900e-04,7.820400e-04,1.049800e-03, & - &1.201300e-03,1.268900e-03,1.281000e-03,1.215600e-03,1.041700e-03, & - &4.771600e-04,1.826000e-04,8.393800e-04,1.120600e-03,1.284700e-03, & - &1.361200e-03,1.375300e-03,1.316100e-03,1.131500e-03,5.294700e-04, & - &1.031100e-04,5.205600e-04,6.963700e-04,7.875000e-04,8.305900e-04, & - &8.257500e-04,7.749000e-04,6.542400e-04,3.028100e-04,1.159000e-04, & - &5.613600e-04,7.529600e-04,8.548000e-04,9.035300e-04,9.021600e-04, & - &8.499900e-04,7.242000e-04,3.350700e-04,1.288900e-04,6.038200e-04, & - &8.110100e-04,9.230200e-04,9.757000e-04,9.818200e-04,9.280600e-04, & - &7.943800e-04,3.728400e-04,1.421100e-04,6.481800e-04,8.686000e-04, & - &9.931100e-04,1.048700e-03,1.059200e-03,1.008100e-03,8.664600e-04, & - &4.145500e-04,1.556600e-04,6.951400e-04,9.271600e-04,1.062100e-03, & - &1.125100e-03,1.136300e-03,1.089800e-03,9.409600e-04,4.609300e-04, & - &8.690600e-05,4.294300e-04,5.738600e-04,6.490700e-04,6.851600e-04, & - &6.823600e-04,6.415000e-04,5.422100e-04,2.534300e-04,9.736300e-05, & - &4.632000e-04,6.205500e-04,7.043000e-04,7.450600e-04,7.451200e-04, & - &7.036900e-04,6.008000e-04,2.807600e-04,1.082200e-04,4.981000e-04, & - &6.681600e-04,7.604500e-04,8.038500e-04,8.103300e-04,7.679100e-04, & - &6.591600e-04,3.126700e-04,1.191900e-04,5.343100e-04,7.154700e-04, & - &8.179800e-04,8.641200e-04,8.731600e-04,8.331800e-04,7.188400e-04, & - &3.480400e-04,1.302000e-04,5.728200e-04,7.640100e-04,8.749300e-04, & - &9.268300e-04,9.362400e-04,8.996200e-04,7.803000e-04,3.873700e-04, & - &7.273600e-05,3.528700e-04,4.710300e-04,5.328500e-04,5.629400e-04, & - &5.618900e-04,5.295200e-04,4.487600e-04,2.084400e-04,8.122000e-05, & - &3.809200e-04,5.095700e-04,5.782400e-04,6.119900e-04,6.131500e-04, & - &5.805300e-04,4.972500e-04,2.311500e-04,9.016400e-05,4.096600e-04, & - &5.489400e-04,6.246000e-04,6.602400e-04,6.662100e-04,6.330800e-04, & - &5.453700e-04,2.575000e-04,9.937600e-05,4.393900e-04,5.881000e-04, & - &6.720000e-04,7.100800e-04,7.177300e-04,6.861700e-04,5.944100e-04, & - &2.868000e-04,1.085400e-04,4.711700e-04,6.283300e-04,7.191800e-04, & - &7.618700e-04,7.698200e-04,7.408600e-04,6.449300e-04,3.193200e-04/ - data absa(1:270,3) / & - &2.826800e-03,8.000700e-03,1.012900e-02,1.160000e-02,1.248400e-02, & - &1.290300e-02,1.275600e-02,1.176200e-02,4.674600e-03,3.128300e-03, & - &8.646300e-03,1.092200e-02,1.243300e-02,1.333900e-02,1.373000e-02, & - &1.355800e-02,1.245400e-02,5.013300e-03,3.455800e-03,9.318900e-03, & - &1.178400e-02,1.333100e-02,1.425800e-02,1.461100e-02,1.438900e-02, & - &1.314900e-02,5.376100e-03,3.800300e-03,1.004000e-02,1.267200e-02, & - &1.428100e-02,1.524000e-02,1.554600e-02,1.524500e-02,1.387300e-02, & - &5.748900e-03,4.136400e-03,1.081000e-02,1.357400e-02,1.526400e-02, & - &1.625900e-02,1.651500e-02,1.612900e-02,1.462400e-02,6.128500e-03, & - &2.378500e-03,6.811100e-03,8.591700e-03,9.806900e-03,1.052000e-02, & - &1.082300e-02,1.066700e-02,9.815200e-03,3.718400e-03,2.640300e-03, & - &7.380500e-03,9.273400e-03,1.050600e-02,1.125300e-02,1.153100e-02, & - &1.134900e-02,1.040300e-02,4.003200e-03,2.925700e-03,7.976600e-03, & - &1.000700e-02,1.126700e-02,1.204000e-02,1.229200e-02,1.206400e-02, & - &1.101400e-02,4.297500e-03,3.221900e-03,8.614800e-03,1.077000e-02, & - &1.208500e-02,1.287800e-02,1.309800e-02,1.279400e-02,1.164900e-02, & - &4.602100e-03,3.508800e-03,9.284200e-03,1.155700e-02,1.293500e-02, & - &1.373700e-02,1.394000e-02,1.357200e-02,1.231000e-02,4.914000e-03, & - &1.938600e-03,5.666000e-03,7.129700e-03,8.142900e-03,8.735700e-03, & - &8.949600e-03,8.774700e-03,8.058200e-03,2.908800e-03,2.157900e-03, & - &6.163700e-03,7.708300e-03,8.725400e-03,9.343500e-03,9.544300e-03, & - &9.348800e-03,8.554500e-03,3.138900e-03,2.396000e-03,6.684200e-03, & - &8.341000e-03,9.362100e-03,1.000400e-02,1.018200e-02,9.952600e-03, & - &9.071500e-03,3.381000e-03,2.645100e-03,7.234500e-03,9.000500e-03, & - &1.005500e-02,1.070400e-02,1.086400e-02,1.057300e-02,9.615800e-03, & - &3.628000e-03,2.885900e-03,7.807800e-03,9.681400e-03,1.078200e-02, & - &1.142100e-02,1.158000e-02,1.124100e-02,1.018700e-02,3.882900e-03, & - &1.560000e-03,4.654600e-03,5.849500e-03,6.699600e-03,7.204400e-03, & - &7.376500e-03,7.186500e-03,6.568200e-03,2.282600e-03,1.736700e-03, & - &5.082300e-03,6.340600e-03,7.186700e-03,7.705800e-03,7.865000e-03, & - &7.661700e-03,6.980200e-03,2.470900e-03,1.930600e-03,5.529900e-03, & - &6.881200e-03,7.722100e-03,8.254900e-03,8.397700e-03,8.162600e-03, & - &7.406700e-03,2.671600e-03,2.134900e-03,5.997100e-03,7.450700e-03, & - &8.311600e-03,8.841300e-03,8.967400e-03,8.686400e-03,7.865800e-03, & - &2.874500e-03,2.333600e-03,6.480700e-03,8.033600e-03,8.935400e-03, & - &9.441600e-03,9.569100e-03,9.248300e-03,8.351700e-03,3.087500e-03, & - &1.264300e-03,3.799200e-03,4.770600e-03,5.482100e-03,5.915600e-03, & - &6.063100e-03,5.887300e-03,5.337400e-03,1.798700e-03,1.402900e-03, & - &4.160100e-03,5.187600e-03,5.893000e-03,6.330400e-03,6.464100e-03, & - &6.280100e-03,5.682800e-03,1.954100e-03,1.556200e-03,4.538100e-03, & - &5.644900e-03,6.347000e-03,6.790300e-03,6.902500e-03,6.693400e-03, & - &6.037100e-03,2.118800e-03,1.719000e-03,4.928500e-03,6.127200e-03, & - &6.844900e-03,7.279700e-03,7.376000e-03,7.129100e-03,6.416700e-03, & - &2.288600e-03,1.880700e-03,5.334100e-03,6.617200e-03,7.373500e-03, & - &7.784600e-03,7.877900e-03,7.597400e-03,6.823600e-03,2.467100e-03, & - &1.021300e-03,3.072100e-03,3.866000e-03,4.455900e-03,4.819700e-03, & - &4.947800e-03,4.798200e-03,4.329000e-03,1.411800e-03,1.132400e-03, & - &3.372800e-03,4.211900e-03,4.795900e-03,5.162800e-03,5.279300e-03, & - &5.122500e-03,4.616200e-03,1.541800e-03,1.254500e-03,3.689200e-03, & - &4.593600e-03,5.174300e-03,5.546700e-03,5.639300e-03,5.466700e-03, & - &4.909100e-03,1.676700e-03,1.384400e-03,4.015100e-03,4.994500e-03, & - &5.588800e-03,5.956200e-03,6.031800e-03,5.825300e-03,5.219800e-03, & - &1.820100e-03,1.516200e-03,4.353000e-03,5.404400e-03,6.030800e-03, & - &6.380800e-03,6.454500e-03,6.216300e-03,5.557500e-03,1.970600e-03/ - data absa(271:585,3) / & - &8.138300e-04,2.469000e-03,3.119000e-03,3.604500e-03,3.907800e-03, & - &4.015200e-03,3.889200e-03,3.506600e-03,1.116200e-03,9.013300e-04, & - &2.720000e-03,3.400700e-03,3.887500e-03,4.189600e-03,4.288700e-03, & - &4.157400e-03,3.746400e-03,1.225300e-03,9.975800e-04,2.982200e-03, & - &3.715400e-03,4.198800e-03,4.507200e-03,4.586400e-03,4.444400e-03, & - &3.991000e-03,1.337400e-03,1.100900e-03,3.253600e-03,4.049900e-03, & - &4.539900e-03,4.847400e-03,4.914000e-03,4.744100e-03,4.248300e-03, & - &1.457200e-03,1.207900e-03,3.532100e-03,4.390500e-03,4.904500e-03, & - &5.200200e-03,5.266500e-03,5.070300e-03,4.526700e-03,1.583400e-03, & - &6.440300e-04,1.971100e-03,2.506100e-03,2.904600e-03,3.155200e-03, & - &3.246700e-03,3.139700e-03,2.827200e-03,9.287900e-04,7.123800e-04, & - &2.177100e-03,2.733500e-03,3.136300e-03,3.388200e-03,3.470200e-03, & - &3.360900e-03,3.027500e-03,1.028200e-03,7.877500e-04,2.392800e-03, & - &2.988800e-03,3.391200e-03,3.650200e-03,3.716100e-03,3.599200e-03, & - &3.232200e-03,1.131200e-03,8.690200e-04,2.617600e-03,3.265300e-03, & - &3.671100e-03,3.930300e-03,3.987300e-03,3.851200e-03,3.447400e-03, & - &1.237200e-03,9.539500e-04,2.843900e-03,3.547200e-03,3.971700e-03, & - &4.222700e-03,4.280400e-03,4.123000e-03,3.679400e-03,1.347200e-03, & - &5.100700e-04,1.565600e-03,2.006000e-03,2.333000e-03,2.537000e-03, & - &2.613200e-03,2.525400e-03,2.269400e-03,9.372900e-04,5.635300e-04, & - &1.732600e-03,2.186900e-03,2.518900e-03,2.728500e-03,2.799500e-03, & - &2.705600e-03,2.435100e-03,1.049300e-03,6.221300e-04,1.908800e-03, & - &2.391500e-03,2.725800e-03,2.942300e-03,2.999500e-03,2.904100e-03, & - &2.606700e-03,1.160700e-03,6.857100e-04,2.092200e-03,2.614900e-03, & - &2.952800e-03,3.172300e-03,3.223100e-03,3.116300e-03,2.786300e-03, & - &1.266900e-03,7.528500e-04,2.275800e-03,2.845900e-03,3.198500e-03, & - &3.413200e-03,3.463800e-03,3.342300e-03,2.979900e-03,1.370800e-03, & - &4.098600e-04,1.251400e-03,1.614900e-03,1.882700e-03,2.047700e-03, & - &2.106800e-03,2.034200e-03,1.826400e-03,9.417200e-04,4.519500e-04, & - &1.387000e-03,1.759400e-03,2.031300e-03,2.204100e-03,2.263700e-03, & - &2.183600e-03,1.963000e-03,1.059200e-03,4.980700e-04,1.530500e-03, & - &1.923200e-03,2.199300e-03,2.378300e-03,2.428200e-03,2.347700e-03, & - &2.105000e-03,1.169100e-03,5.480800e-04,1.678900e-03,2.102200e-03, & - &2.382900e-03,2.565400e-03,2.609100e-03,2.525500e-03,2.256200e-03, & - &1.275900e-03,6.011700e-04,1.828700e-03,2.288800e-03,2.580700e-03, & - &2.762200e-03,2.806600e-03,2.711800e-03,2.419700e-03,1.379800e-03, & - &3.458700e-04,1.048600e-03,1.349800e-03,1.570600e-03,1.706700e-03, & - &1.754100e-03,1.690400e-03,1.518900e-03,8.492200e-04,3.803000e-04, & - &1.161200e-03,1.472000e-03,1.696200e-03,1.839600e-03,1.887700e-03, & - &1.818900e-03,1.632100e-03,9.488600e-04,4.177500e-04,1.279400e-03, & - &1.608300e-03,1.837200e-03,1.986300e-03,2.026900e-03,1.960200e-03, & - &1.753400e-03,1.043500e-03,4.583100e-04,1.401200e-03,1.755800e-03, & - &1.989900e-03,2.142300e-03,2.179100e-03,2.110500e-03,1.884700e-03, & - &1.134200e-03,5.016000e-04,1.523500e-03,1.906800e-03,2.151800e-03, & - &2.303100e-03,2.345200e-03,2.269100e-03,2.027100e-03,1.224600e-03, & - &2.872800e-04,8.713800e-04,1.121200e-03,1.303500e-03,1.416600e-03, & - &1.455600e-03,1.401600e-03,1.259200e-03,7.244700e-04,3.156400e-04, & - &9.643400e-04,1.223500e-03,1.408500e-03,1.527900e-03,1.567900e-03, & - &1.511200e-03,1.354200e-03,8.072800e-04,3.458800e-04,1.061600e-03, & - &1.335700e-03,1.525500e-03,1.650500e-03,1.684200e-03,1.630900e-03, & - &1.458400e-03,8.853800e-04,3.786200e-04,1.161400e-03,1.455900e-03, & - &1.650400e-03,1.778000e-03,1.811800e-03,1.757000e-03,1.571000e-03, & - &9.617400e-04,4.137500e-04,1.260800e-03,1.578300e-03,1.782900e-03, & - &1.909700e-03,1.949000e-03,1.890200e-03,1.692400e-03,1.038300e-03, & - &2.364800e-04,7.205800e-04,9.272100e-04,1.077300e-03,1.171500e-03, & - &1.204100e-03,1.159000e-03,1.040900e-03,5.975000e-04,2.599100e-04, & - &7.970000e-04,1.011900e-03,1.164700e-03,1.264000e-03,1.297700e-03, & - &1.252000e-03,1.121300e-03,6.644200e-04,2.846300e-04,8.764300e-04, & - &1.103500e-03,1.260600e-03,1.365100e-03,1.394700e-03,1.352000e-03, & - &1.209900e-03,7.282900e-04,3.111600e-04,9.584000e-04,1.201500e-03, & - &1.362900e-03,1.469300e-03,1.499700e-03,1.457100e-03,1.305000e-03, & - &7.919500e-04,3.397300e-04,1.039300e-03,1.301100e-03,1.470900e-03, & - &1.577100e-03,1.612500e-03,1.566900e-03,1.407800e-03,8.558000e-04/ - data absa(1:270,4) / & - &6.855600e-03,1.520900e-02,1.896400e-02,2.131100e-02,2.277500e-02, & - &2.357300e-02,2.341200e-02,2.161100e-02,1.075400e-02,7.536000e-03, & - &1.653900e-02,2.038900e-02,2.280900e-02,2.436800e-02,2.512400e-02, & - &2.489300e-02,2.280700e-02,1.140900e-02,8.273100e-03,1.796700e-02, & - &2.185900e-02,2.435400e-02,2.600100e-02,2.673800e-02,2.642400e-02, & - &2.398100e-02,1.202800e-02,9.066900e-03,1.944000e-02,2.338600e-02, & - &2.595100e-02,2.763800e-02,2.840400e-02,2.799300e-02,2.510500e-02, & - &1.262200e-02,9.929700e-03,2.086700e-02,2.499200e-02,2.762000e-02, & - &2.933300e-02,3.014400e-02,2.956100e-02,2.619600e-02,1.324600e-02, & - &6.045800e-03,1.305700e-02,1.617700e-02,1.807200e-02,1.926700e-02, & - &1.986600e-02,1.970800e-02,1.799800e-02,8.618600e-03,6.662500e-03, & - &1.420700e-02,1.742400e-02,1.939000e-02,2.064600e-02,2.122600e-02, & - &2.098900e-02,1.904000e-02,9.159600e-03,7.325800e-03,1.544600e-02, & - &1.873000e-02,2.075600e-02,2.206800e-02,2.264100e-02,2.232000e-02, & - &2.004000e-02,9.671900e-03,8.038900e-03,1.669700e-02,2.008600e-02, & - &2.217600e-02,2.350900e-02,2.412800e-02,2.369100e-02,2.099500e-02, & - &1.016300e-02,8.811600e-03,1.792400e-02,2.149500e-02,2.365900e-02, & - &2.500700e-02,2.564900e-02,2.507000e-02,2.193900e-02,1.068100e-02, & - &5.152900e-03,1.101000e-02,1.357600e-02,1.505700e-02,1.594100e-02, & - &1.639100e-02,1.625200e-02,1.482500e-02,6.796500e-03,5.702100e-03, & - &1.198200e-02,1.464300e-02,1.619200e-02,1.714000e-02,1.756500e-02, & - &1.735500e-02,1.573600e-02,7.249800e-03,6.295100e-03,1.303000e-02, & - &1.575900e-02,1.737100e-02,1.837900e-02,1.879700e-02,1.850600e-02, & - &1.660400e-02,7.674400e-03,6.932900e-03,1.409900e-02,1.692400e-02, & - &1.861400e-02,1.964000e-02,2.008000e-02,1.969700e-02,1.742700e-02, & - &8.085500e-03,7.620800e-03,1.515400e-02,1.813200e-02,1.989900e-02, & - &2.095300e-02,2.140300e-02,2.090700e-02,1.823600e-02,8.512300e-03, & - &4.311700e-03,9.239900e-03,1.133300e-02,1.246000e-02,1.308800e-02, & - &1.338400e-02,1.326400e-02,1.212900e-02,5.363800e-03,4.791900e-03, & - &1.005700e-02,1.223600e-02,1.342500e-02,1.410800e-02,1.438400e-02, & - &1.421500e-02,1.291900e-02,5.744800e-03,5.314100e-03,1.093900e-02, & - &1.317200e-02,1.443000e-02,1.516000e-02,1.543800e-02,1.519800e-02, & - &1.368400e-02,6.106000e-03,5.872600e-03,1.185000e-02,1.416000e-02, & - &1.549800e-02,1.625500e-02,1.654200e-02,1.622600e-02,1.441100e-02, & - &6.454500e-03,6.467500e-03,1.276400e-02,1.519000e-02,1.660800e-02, & - &1.740000e-02,1.769200e-02,1.726900e-02,1.512000e-02,6.807300e-03, & - &3.569000e-03,7.705100e-03,9.436800e-03,1.030500e-02,1.074500e-02, & - &1.091200e-02,1.078500e-02,9.877300e-03,4.253200e-03,3.982000e-03, & - &8.397700e-03,1.019400e-02,1.111200e-02,1.160900e-02,1.175600e-02, & - &1.159500e-02,1.056000e-02,4.573100e-03,4.430500e-03,9.151100e-03, & - &1.099000e-02,1.196700e-02,1.249800e-02,1.265000e-02,1.243000e-02, & - &1.122900e-02,4.883000e-03,4.907900e-03,9.936300e-03,1.183200e-02, & - &1.287200e-02,1.343400e-02,1.359200e-02,1.330700e-02,1.187200e-02, & - &5.181000e-03,5.414800e-03,1.072700e-02,1.271600e-02,1.382000e-02, & - &1.441900e-02,1.458400e-02,1.419700e-02,1.249200e-02,5.478200e-03, & - &2.924900e-03,6.351000e-03,7.784900e-03,8.472100e-03,8.794100e-03, & - &8.883700e-03,8.738800e-03,7.984100e-03,3.371000e-03,3.267200e-03, & - &6.938500e-03,8.420300e-03,9.154100e-03,9.516500e-03,9.590400e-03, & - &9.415200e-03,8.571300e-03,3.637700e-03,3.641800e-03,7.578700e-03, & - &9.088700e-03,9.876500e-03,1.026800e-02,1.034200e-02,1.011600e-02, & - &9.154500e-03,3.899000e-03,4.041400e-03,8.251000e-03,9.809300e-03, & - &1.064600e-02,1.106000e-02,1.113400e-02,1.085400e-02,9.719000e-03, & - &4.154400e-03,4.463300e-03,8.934500e-03,1.057000e-02,1.145700e-02, & - &1.190200e-02,1.197600e-02,1.161400e-02,1.027200e-02,4.406100e-03/ - data absa(271:585,4) / & - &2.397500e-03,5.195900e-03,6.367500e-03,6.924200e-03,7.171700e-03, & - &7.220800e-03,7.081900e-03,6.427800e-03,2.677500e-03,2.679400e-03, & - &5.689900e-03,6.906600e-03,7.494200e-03,7.778700e-03,7.809800e-03, & - &7.646400e-03,6.929000e-03,2.900100e-03,2.984900e-03,6.231600e-03, & - &7.474100e-03,8.105600e-03,8.413900e-03,8.437400e-03,8.228100e-03, & - &7.430200e-03,3.119500e-03,3.312900e-03,6.798400e-03,8.079000e-03, & - &8.760000e-03,9.083700e-03,9.105200e-03,8.845800e-03,7.923100e-03, & - &3.337600e-03,3.659800e-03,7.375700e-03,8.729800e-03,9.454700e-03, & - &9.795800e-03,9.822100e-03,9.486300e-03,8.406000e-03,3.550900e-03, & - &1.943400e-03,4.231800e-03,5.174000e-03,5.637000e-03,5.824600e-03, & - &5.848800e-03,5.732700e-03,5.181000e-03,2.153700e-03,2.175000e-03, & - &4.651100e-03,5.634400e-03,6.115000e-03,6.328600e-03,6.340400e-03, & - &6.203700e-03,5.602900e-03,2.344100e-03,2.426000e-03,5.107000e-03, & - &6.117600e-03,6.629200e-03,6.864100e-03,6.868100e-03,6.688700e-03, & - &6.032900e-03,2.531700e-03,2.697800e-03,5.581200e-03,6.631700e-03, & - &7.184900e-03,7.429800e-03,7.433700e-03,7.201100e-03,6.450300e-03, & - &2.720100e-03,2.985100e-03,6.067100e-03,7.179300e-03,7.774700e-03, & - &8.035800e-03,8.036900e-03,7.742100e-03,6.866000e-03,2.905000e-03, & - &1.562400e-03,3.422400e-03,4.180300e-03,4.561300e-03,4.711700e-03, & - &4.726900e-03,4.631500e-03,4.180200e-03,2.035400e-03,1.746700e-03, & - &3.774900e-03,4.574800e-03,4.970600e-03,5.134300e-03,5.134400e-03, & - &5.024300e-03,4.535000e-03,2.225000e-03,1.949200e-03,4.154700e-03, & - &4.986700e-03,5.405400e-03,5.586800e-03,5.576400e-03,5.428800e-03, & - &4.897700e-03,2.414900e-03,2.170100e-03,4.550800e-03,5.419400e-03, & - &5.874400e-03,6.065900e-03,6.051800e-03,5.854000e-03,5.253700e-03, & - &2.597100e-03,2.402200e-03,4.961300e-03,5.878700e-03,6.372700e-03, & - &6.577800e-03,6.561800e-03,6.306700e-03,5.605300e-03,2.783000e-03, & - &1.265100e-03,2.774400e-03,3.380100e-03,3.690000e-03,3.817800e-03, & - &3.836000e-03,3.760500e-03,3.390700e-03,2.169200e-03,1.411100e-03, & - &3.065700e-03,3.713600e-03,4.042100e-03,4.173500e-03,4.174500e-03, & - &4.086100e-03,3.687200e-03,2.363900e-03,1.574000e-03,3.380600e-03, & - &4.061800e-03,4.410500e-03,4.557100e-03,4.546000e-03,4.424700e-03, & - &3.992300e-03,2.563000e-03,1.752200e-03,3.708400e-03,4.424900e-03, & - &4.803500e-03,4.963900e-03,4.949800e-03,4.780600e-03,4.295600e-03, & - &2.762300e-03,1.938300e-03,4.049500e-03,4.809400e-03,5.222200e-03, & - &5.393400e-03,5.381700e-03,5.161400e-03,4.595100e-03,2.966500e-03, & - &1.074200e-03,2.346800e-03,2.846900e-03,3.103900e-03,3.209800e-03, & - &3.223300e-03,3.162300e-03,2.853700e-03,1.982200e-03,1.196000e-03, & - &2.596500e-03,3.132300e-03,3.407700e-03,3.519400e-03,3.516400e-03, & - &3.438000e-03,3.105600e-03,2.157800e-03,1.331600e-03,2.859900e-03, & - &3.427700e-03,3.726000e-03,3.849700e-03,3.840500e-03,3.726500e-03, & - &3.363000e-03,2.330600e-03,1.478100e-03,3.134400e-03,3.735700e-03, & - &4.061000e-03,4.198700e-03,4.191300e-03,4.034500e-03,3.619200e-03, & - &2.509700e-03,1.628800e-03,3.417700e-03,4.061900e-03,4.418500e-03, & - &4.567200e-03,4.560000e-03,4.366300e-03,3.875600e-03,2.688900e-03, & - &8.987400e-04,1.968900e-03,2.383500e-03,2.597300e-03,2.686400e-03, & - &2.693900e-03,2.642500e-03,2.389500e-03,1.704900e-03,1.000200e-03, & - &2.177800e-03,2.623300e-03,2.856400e-03,2.951700e-03,2.947600e-03, & - &2.876600e-03,2.601900e-03,1.854300e-03,1.112200e-03,2.397300e-03, & - &2.871300e-03,3.126600e-03,3.231000e-03,3.227600e-03,3.123700e-03, & - &2.817700e-03,2.004600e-03,1.231000e-03,2.625400e-03,3.130500e-03, & - &3.411200e-03,3.527500e-03,3.525900e-03,3.389800e-03,3.034900e-03, & - &2.156500e-03,1.351800e-03,2.857500e-03,3.400600e-03,3.709200e-03, & - &3.840300e-03,3.837000e-03,3.675000e-03,3.255700e-03,2.306100e-03, & - &7.453700e-04,1.640900e-03,1.986300e-03,2.164800e-03,2.239900e-03, & - &2.244400e-03,2.198800e-03,1.991600e-03,1.411500e-03,8.294300e-04, & - &1.814300e-03,2.185000e-03,2.382800e-03,2.463900e-03,2.460900e-03, & - &2.397000e-03,2.169200e-03,1.536900e-03,9.214200e-04,1.997000e-03, & - &2.392700e-03,2.609300e-03,2.697100e-03,2.696900e-03,2.607600e-03, & - &2.352100e-03,1.662600e-03,1.016700e-03,2.183700e-03,2.607800e-03, & - &2.847800e-03,2.946700e-03,2.948800e-03,2.834600e-03,2.538300e-03, & - &1.787900e-03,1.113800e-03,2.373300e-03,2.829000e-03,3.092400e-03, & - &3.207900e-03,3.210300e-03,3.077800e-03,2.728400e-03,1.913300e-03/ - data absa(1:270,5) / & - &3.147925e-02,5.237966e-02,6.225811e-02,6.763023e-02,6.898546e-02, & - &6.686752e-02,6.101831e-02,5.001979e-02,3.114864e-02,3.378656e-02, & - &5.619523e-02,6.661712e-02,7.191859e-02,7.300822e-02,7.056648e-02, & - &6.438978e-02,5.293106e-02,3.334449e-02,3.620322e-02,6.004096e-02, & - &7.089037e-02,7.604403e-02,7.686917e-02,7.414359e-02,6.767479e-02, & - &5.592632e-02,3.561350e-02,3.872055e-02,6.387357e-02,7.500163e-02, & - &8.000820e-02,8.062954e-02,7.760493e-02,7.086163e-02,5.897711e-02, & - &3.792721e-02,4.131747e-02,6.773046e-02,7.892098e-02,8.385433e-02, & - &8.431239e-02,8.099253e-02,7.400446e-02,6.208371e-02,4.024756e-02, & - &2.770965e-02,4.618819e-02,5.418125e-02,5.821694e-02,5.895682e-02, & - &5.690954e-02,5.184751e-02,4.246806e-02,2.518851e-02,2.980596e-02, & - &4.965914e-02,5.807182e-02,6.197720e-02,6.251036e-02,6.016648e-02, & - &5.481847e-02,4.505347e-02,2.698326e-02,3.201523e-02,5.313990e-02, & - &6.183784e-02,6.563269e-02,6.594490e-02,6.333279e-02,5.769171e-02, & - &4.770875e-02,2.885175e-02,3.432748e-02,5.662736e-02,6.545497e-02, & - &6.916492e-02,6.929918e-02,6.641687e-02,6.048195e-02,5.040227e-02, & - &3.076952e-02,3.672145e-02,6.010664e-02,6.895198e-02,7.259325e-02, & - &7.259666e-02,6.947418e-02,6.325486e-02,5.313967e-02,3.270581e-02, & - &2.386850e-02,3.979561e-02,4.626079e-02,4.928490e-02,4.966558e-02, & - &4.775134e-02,4.337486e-02,3.546015e-02,1.994411e-02,2.573032e-02, & - &4.291223e-02,4.971322e-02,5.264670e-02,5.279946e-02,5.060641e-02, & - &4.599015e-02,3.769874e-02,2.140668e-02,2.770147e-02,4.604258e-02, & - &5.306125e-02,5.591670e-02,5.584767e-02,5.340789e-02,4.850673e-02, & - &4.000581e-02,2.294419e-02,2.977050e-02,4.917865e-02,5.627152e-02, & - &5.904919e-02,5.884110e-02,5.615751e-02,5.098296e-02,4.235294e-02, & - &2.452918e-02,3.193041e-02,5.232013e-02,5.939356e-02,6.212769e-02, & - &6.179579e-02,5.891211e-02,5.345004e-02,4.470704e-02,2.610935e-02, & - &2.038331e-02,3.378653e-02,3.902043e-02,4.140309e-02,4.157790e-02, & - &3.984404e-02,3.605450e-02,2.937798e-02,1.579029e-02,2.202158e-02, & - &3.656255e-02,4.207408e-02,4.438069e-02,4.437643e-02,4.238343e-02, & - &3.833260e-02,3.131881e-02,1.699714e-02,2.375813e-02,3.936459e-02, & - &4.504359e-02,4.727958e-02,4.710666e-02,4.485823e-02,4.054717e-02, & - &3.329769e-02,1.826312e-02,2.559761e-02,4.217882e-02,4.792511e-02, & - &5.007562e-02,4.977158e-02,4.730816e-02,4.273780e-02,3.529876e-02, & - &1.956996e-02,2.753464e-02,4.496399e-02,5.072931e-02,5.283190e-02, & - &5.240215e-02,4.975405e-02,4.491986e-02,3.731082e-02,2.087830e-02, & - &1.736660e-02,2.848353e-02,3.266129e-02,3.453993e-02,3.463830e-02, & - &3.313937e-02,2.989805e-02,2.423646e-02,1.252381e-02,1.879478e-02, & - &3.094031e-02,3.535340e-02,3.718983e-02,3.712658e-02,3.541515e-02, & - &3.188537e-02,2.590470e-02,1.352332e-02,2.031740e-02,3.342529e-02, & - &3.798370e-02,3.975311e-02,3.955477e-02,3.761513e-02,3.383653e-02, & - &2.759922e-02,1.456437e-02,2.194238e-02,3.591876e-02,4.055989e-02, & - &4.225741e-02,4.192913e-02,3.978930e-02,3.576953e-02,2.931198e-02, & - &1.564075e-02,2.367594e-02,3.837488e-02,4.309861e-02,4.473556e-02, & - &4.430205e-02,4.196611e-02,3.769911e-02,3.105093e-02,1.673424e-02, & - &1.475077e-02,2.384251e-02,2.711139e-02,2.857350e-02,2.862930e-02, & - &2.733986e-02,2.463262e-02,1.989129e-02,9.909011e-03,1.597872e-02, & - &2.598835e-02,2.947249e-02,3.091343e-02,3.082752e-02,2.934605e-02, & - &2.637831e-02,2.131126e-02,1.073631e-02,1.729371e-02,2.817655e-02, & - &3.180560e-02,3.318983e-02,3.297567e-02,3.130289e-02,2.809799e-02, & - &2.274721e-02,1.159585e-02,1.871256e-02,3.036767e-02,3.408922e-02, & - &3.543824e-02,3.508600e-02,3.325180e-02,2.981036e-02,2.421760e-02, & - &1.248472e-02,2.024165e-02,3.252859e-02,3.635108e-02,3.765878e-02, & - &3.720427e-02,3.519444e-02,3.151748e-02,2.571544e-02,1.340498e-02/ - data absa(271:585,5) / & - &1.250533e-02,1.987535e-02,2.240551e-02,2.354337e-02,2.353930e-02, & - &2.243168e-02,2.017449e-02,1.627432e-02,7.845742e-03,1.355332e-02, & - &2.173545e-02,2.447006e-02,2.560163e-02,2.547356e-02,2.419899e-02, & - &2.170421e-02,1.749394e-02,8.523557e-03,1.468764e-02,2.364828e-02, & - &2.653205e-02,2.760876e-02,2.737451e-02,2.593336e-02,2.321914e-02, & - &1.871886e-02,9.237982e-03,1.592224e-02,2.556292e-02,2.855448e-02, & - &2.959866e-02,2.925850e-02,2.766791e-02,2.473165e-02,1.997190e-02, & - &9.973473e-03,1.724704e-02,2.746398e-02,3.055395e-02,3.158332e-02, & - &3.115088e-02,2.940309e-02,2.624938e-02,2.125465e-02,1.074373e-02, & - &1.058499e-02,1.653839e-02,1.848174e-02,1.934829e-02,1.930510e-02, & - &1.835761e-02,1.649255e-02,1.328491e-02,6.242101e-03,1.147290e-02, & - &1.813938e-02,2.028118e-02,2.114446e-02,2.099627e-02,1.991044e-02, & - &1.783475e-02,1.434034e-02,6.800147e-03,1.244648e-02,1.979539e-02, & - &2.208821e-02,2.292228e-02,2.267559e-02,2.145532e-02,1.917405e-02, & - &1.539703e-02,7.390482e-03,1.350141e-02,2.145721e-02,2.387077e-02, & - &2.468576e-02,2.435760e-02,2.299988e-02,2.051255e-02,1.648171e-02, & - &8.001995e-03,1.464443e-02,2.312694e-02,2.563582e-02,2.644990e-02, & - &2.605336e-02,2.456133e-02,2.187103e-02,1.758770e-02,8.643018e-03, & - &8.952131e-03,1.375514e-02,1.523574e-02,1.588007e-02,1.579687e-02, & - &1.499506e-02,1.344743e-02,1.082039e-02,5.334775e-03,9.714980e-03, & - &1.512937e-02,1.679053e-02,1.743358e-02,1.727095e-02,1.635631e-02, & - &1.462716e-02,1.174412e-02,5.848092e-03,1.054544e-02,1.654445e-02, & - &1.836534e-02,1.899831e-02,1.875153e-02,1.772375e-02,1.581289e-02, & - &1.266502e-02,6.388861e-03,1.144831e-02,1.799348e-02,1.992304e-02, & - &2.055617e-02,2.025225e-02,1.909707e-02,1.700854e-02,1.361131e-02, & - &6.957062e-03,1.243199e-02,1.944511e-02,2.148425e-02,2.211328e-02, & - &2.176043e-02,2.049631e-02,1.822771e-02,1.458136e-02,7.542183e-03, & - &7.617912e-03,1.153907e-02,1.267587e-02,1.313642e-02,1.303323e-02, & - &1.234031e-02,1.104924e-02,8.893121e-03,5.889344e-03,8.280607e-03, & - &1.271867e-02,1.400738e-02,1.448624e-02,1.432270e-02,1.353476e-02, & - &1.208944e-02,9.704880e-03,6.548134e-03,8.994833e-03,1.392969e-02, & - &1.537554e-02,1.585930e-02,1.563177e-02,1.475160e-02,1.314491e-02, & - &1.052786e-02,7.222904e-03,9.770720e-03,1.518418e-02,1.673953e-02, & - &1.722741e-02,1.696033e-02,1.598211e-02,1.421506e-02,1.136581e-02, & - &7.915237e-03,1.061958e-02,1.645389e-02,1.811173e-02,1.861399e-02, & - &1.830150e-02,1.723291e-02,1.531227e-02,1.222459e-02,8.617554e-03, & - &6.692902e-03,1.013468e-02,1.107802e-02,1.141917e-02,1.127548e-02, & - &1.063877e-02,9.498417e-03,7.629821e-03,5.905427e-03,7.287378e-03, & - &1.116840e-02,1.224719e-02,1.260101e-02,1.240873e-02,1.169786e-02, & - &1.042461e-02,8.350919e-03,6.603799e-03,7.931724e-03,1.223488e-02, & - &1.342679e-02,1.379244e-02,1.356546e-02,1.278426e-02,1.136889e-02, & - &9.089882e-03,7.322450e-03,8.636197e-03,1.333227e-02,1.461920e-02, & - &1.499901e-02,1.474172e-02,1.388086e-02,1.233787e-02,9.843934e-03, & - &8.045791e-03,9.401822e-03,1.445501e-02,1.583070e-02,1.622946e-02, & - &1.594461e-02,1.500315e-02,1.332511e-02,1.062038e-02,8.770501e-03, & - &5.785845e-03,8.787569e-03,9.587968e-03,9.850757e-03,9.693732e-03, & - &9.127283e-03,8.128585e-03,6.512513e-03,5.356718e-03,6.311928e-03, & - &9.685968e-03,1.059931e-02,1.087333e-02,1.068479e-02,1.005801e-02, & - &8.941711e-03,7.147432e-03,5.995210e-03,6.890189e-03,1.062273e-02, & - &1.162338e-02,1.190795e-02,1.169415e-02,1.100577e-02,9.776170e-03, & - &7.801102e-03,6.646711e-03,7.522676e-03,1.158207e-02,1.266454e-02, & - &1.296414e-02,1.272770e-02,1.197015e-02,1.062815e-02,8.472221e-03, & - &7.298226e-03,8.203101e-03,1.257480e-02,1.373084e-02,1.405125e-02, & - &1.378928e-02,1.296195e-02,1.150294e-02,9.158703e-03,7.947536e-03, & - &4.942267e-03,7.541065e-03,8.227593e-03,8.428739e-03,8.286101e-03, & - &7.800137e-03,6.941106e-03,5.561695e-03,4.578766e-03,5.408526e-03, & - &8.320858e-03,9.093923e-03,9.307683e-03,9.145321e-03,8.613535e-03, & - &7.655689e-03,6.121801e-03,5.125873e-03,5.920948e-03,9.134845e-03, & - &9.979638e-03,1.021030e-02,1.002687e-02,9.440296e-03,8.388767e-03, & - &6.700045e-03,5.679549e-03,6.478062e-03,9.973604e-03,1.089072e-02, & - &1.113879e-02,1.093476e-02,1.028944e-02,9.142550e-03,7.295853e-03, & - &6.234429e-03,7.069435e-03,1.084798e-02,1.182995e-02,1.210167e-02, & - &1.187187e-02,1.116404e-02,9.919625e-03,7.901349e-03,6.790694e-03/ - data absa(1:270,6) / & - &2.653201e-01,2.952081e-01,3.041085e-01,3.032060e-01,2.937008e-01, & - &2.768813e-01,2.526247e-01,2.195510e-01,1.719498e-01,2.742794e-01, & - &3.062590e-01,3.166218e-01,3.167347e-01,3.076895e-01,2.912568e-01, & - &2.672446e-01,2.334965e-01,1.854965e-01,2.833112e-01,3.174812e-01, & - &3.295222e-01,3.303182e-01,3.217743e-01,3.055871e-01,2.815762e-01, & - &2.471548e-01,1.989842e-01,2.924936e-01,3.289599e-01,3.427560e-01, & - &3.441297e-01,3.356738e-01,3.197467e-01,2.955897e-01,2.608286e-01, & - &2.124649e-01,3.018298e-01,3.405847e-01,3.561825e-01,3.579413e-01, & - &3.494508e-01,3.337243e-01,3.094382e-01,2.740791e-01,2.258329e-01, & - &2.357959e-01,2.652092e-01,2.739177e-01,2.729907e-01,2.647006e-01, & - &2.492015e-01,2.258006e-01,1.940346e-01,1.431916e-01,2.442756e-01, & - &2.759378e-01,2.860700e-01,2.860483e-01,2.782520e-01,2.627439e-01, & - &2.392894e-01,2.068645e-01,1.550864e-01,2.530092e-01,2.870691e-01, & - &2.986603e-01,2.993399e-01,2.918474e-01,2.761239e-01,2.524812e-01, & - &2.196676e-01,1.669444e-01,2.619148e-01,2.986456e-01,3.116383e-01, & - &3.128905e-01,3.053427e-01,2.893746e-01,2.656109e-01,2.321845e-01, & - &1.787761e-01,2.706433e-01,3.102778e-01,3.248964e-01,3.264843e-01, & - &3.185594e-01,3.026224e-01,2.787648e-01,2.442523e-01,1.905144e-01, & - &2.069411e-01,2.347816e-01,2.422886e-01,2.409158e-01,2.334742e-01, & - &2.197182e-01,1.981695e-01,1.677240e-01,1.160527e-01,2.149650e-01, & - &2.450930e-01,2.537304e-01,2.532938e-01,2.463817e-01,2.326179e-01, & - &2.104145e-01,1.795717e-01,1.263863e-01,2.233014e-01,2.559659e-01, & - &2.656989e-01,2.659925e-01,2.593379e-01,2.454555e-01,2.226317e-01, & - &1.912247e-01,1.367060e-01,2.315247e-01,2.671507e-01,2.781621e-01, & - &2.790306e-01,2.723142e-01,2.580066e-01,2.348555e-01,2.025843e-01, & - &1.469907e-01,2.395178e-01,2.783467e-01,2.910470e-01,2.922149e-01, & - &2.852678e-01,2.705625e-01,2.470520e-01,2.136908e-01,1.572014e-01, & - &1.805797e-01,2.064835e-01,2.123871e-01,2.103651e-01,2.033464e-01, & - &1.907979e-01,1.719072e-01,1.434490e-01,9.359753e-02,1.880802e-01, & - &2.163477e-01,2.230626e-01,2.219386e-01,2.153254e-01,2.028548e-01, & - &1.833422e-01,1.541784e-01,1.025423e-01,1.958201e-01,2.266543e-01, & - &2.343276e-01,2.338587e-01,2.274777e-01,2.149685e-01,1.946320e-01, & - &1.647414e-01,1.115064e-01,2.033312e-01,2.372484e-01,2.461146e-01, & - &2.461810e-01,2.398071e-01,2.270265e-01,2.058757e-01,1.750499e-01, & - &1.203982e-01,2.106778e-01,2.477132e-01,2.582575e-01,2.586837e-01, & - &2.522513e-01,2.390062e-01,2.170379e-01,1.852456e-01,1.292698e-01, & - &1.570800e-01,1.808137e-01,1.851303e-01,1.827168e-01,1.757681e-01, & - &1.640629e-01,1.472712e-01,1.220896e-01,7.527179e-02,1.641011e-01, & - &1.900529e-01,1.951081e-01,1.934372e-01,1.867540e-01,1.751008e-01, & - &1.579314e-01,1.317445e-01,8.296034e-02,1.711787e-01,1.996501e-01, & - &2.056927e-01,2.044756e-01,1.980305e-01,1.863261e-01,1.684986e-01, & - &1.411725e-01,9.071648e-02,1.779788e-01,2.094374e-01,2.166762e-01, & - &2.159561e-01,2.094856e-01,1.975660e-01,1.788338e-01,1.504926e-01, & - &9.834935e-02,1.846960e-01,2.191611e-01,2.277468e-01,2.276555e-01, & - &2.211469e-01,2.088033e-01,1.890821e-01,1.597614e-01,1.059925e-01, & - &1.360266e-01,1.572404e-01,1.601963e-01,1.573745e-01,1.504484e-01, & - &1.396906e-01,1.246470e-01,1.029806e-01,6.002454e-02,1.424056e-01, & - &1.657371e-01,1.693711e-01,1.671473e-01,1.604418e-01,1.497064e-01, & - &1.342830e-01,1.116165e-01,6.661583e-02,1.488066e-01,1.745253e-01, & - &1.791236e-01,1.772589e-01,1.707789e-01,1.598805e-01,1.438938e-01, & - &1.200132e-01,7.320671e-02,1.551249e-01,1.833754e-01,1.891647e-01, & - &1.878304e-01,1.813675e-01,1.701504e-01,1.534148e-01,1.283994e-01, & - &7.973416e-02,1.613466e-01,1.922278e-01,1.991598e-01,1.985061e-01, & - &1.920585e-01,1.804045e-01,1.629313e-01,1.366833e-01,8.627561e-02/ - data absa(271:585,6) / & - &1.176619e-01,1.360523e-01,1.379935e-01,1.347521e-01,1.279162e-01, & - &1.180983e-01,1.047681e-01,8.592542e-02,4.759377e-02,1.233940e-01, & - &1.438168e-01,1.464072e-01,1.435276e-01,1.369173e-01,1.270900e-01, & - &1.133594e-01,9.363738e-02,5.319495e-02,1.291304e-01,1.518423e-01, & - &1.552525e-01,1.527240e-01,1.463170e-01,1.362788e-01,1.219751e-01, & - &1.011537e-01,5.876290e-02,1.348728e-01,1.598927e-01,1.642201e-01, & - &1.622772e-01,1.558967e-01,1.455254e-01,1.305063e-01,1.086237e-01, & - &6.434296e-02,1.406464e-01,1.679376e-01,1.731725e-01,1.718118e-01, & - &1.655990e-01,1.547966e-01,1.391540e-01,1.160267e-01,6.989944e-02, & - &1.020734e-01,1.177408e-01,1.186962e-01,1.151116e-01,1.085875e-01, & - &9.958379e-02,8.762385e-02,7.117493e-02,3.761831e-02,1.072330e-01, & - &1.248426e-01,1.264136e-01,1.231052e-01,1.166806e-01,1.075988e-01, & - &9.522746e-02,7.794820e-02,4.234172e-02,1.124616e-01,1.321215e-01, & - &1.344139e-01,1.314486e-01,1.251293e-01,1.158071e-01,1.028490e-01, & - &8.465277e-02,4.706179e-02,1.177505e-01,1.394961e-01,1.424596e-01, & - &1.399767e-01,1.337182e-01,1.240494e-01,1.104953e-01,9.134079e-02, & - &5.180439e-02,1.231254e-01,1.469475e-01,1.505083e-01,1.484095e-01, & - &1.422799e-01,1.323418e-01,1.182616e-01,9.794986e-02,5.652887e-02, & - &8.872917e-02,1.020393e-01,1.021544e-01,9.833249e-02,9.216649e-02, & - &8.387575e-02,7.307976e-02,5.862531e-02,2.998517e-02,9.345353e-02, & - &1.085490e-01,1.092110e-01,1.056336e-01,9.949245e-02,9.100445e-02, & - &7.976360e-02,6.451994e-02,3.400474e-02,9.824938e-02,1.152261e-01, & - &1.164632e-01,1.132216e-01,1.071110e-01,9.827568e-02,8.647290e-02, & - &7.040861e-02,3.805358e-02,1.031569e-01,1.220374e-01,1.237755e-01, & - &1.208669e-01,1.147381e-01,1.056132e-01,9.326328e-02,7.630820e-02, & - &4.213583e-02,1.082183e-01,1.289425e-01,1.311654e-01,1.284367e-01, & - &1.222563e-01,1.129740e-01,1.001350e-01,8.221361e-02,4.622971e-02, & - &7.828325e-02,8.953054e-02,8.893975e-02,8.507834e-02,7.915129e-02, & - &7.143430e-02,6.156007e-02,4.857397e-02,2.883725e-02,8.271056e-02, & - &9.561937e-02,9.553587e-02,9.185495e-02,8.584614e-02,7.784805e-02, & - &6.744642e-02,5.370240e-02,3.292295e-02,8.731204e-02,1.018855e-01, & - &1.022632e-01,9.880313e-02,9.278110e-02,8.439639e-02,7.339256e-02, & - &5.882815e-02,3.706079e-02,9.203623e-02,1.083193e-01,1.090664e-01, & - &1.058027e-01,9.967163e-02,9.092857e-02,7.942946e-02,6.399125e-02, & - &4.122135e-02,9.694649e-02,1.148239e-01,1.159407e-01,1.127434e-01, & - &1.064387e-01,9.741887e-02,8.549216e-02,6.920019e-02,4.534882e-02, & - &7.163499e-02,8.177492e-02,8.089424e-02,7.702920e-02,7.125756e-02, & - &6.388524e-02,5.456492e-02,4.241185e-02,3.183708e-02,7.593051e-02, & - &8.764426e-02,8.713480e-02,8.344804e-02,7.755591e-02,6.979464e-02, & - &5.988457e-02,4.685893e-02,3.634349e-02,8.037897e-02,9.365972e-02, & - &9.355267e-02,8.997470e-02,8.391740e-02,7.573804e-02,6.523667e-02, & - &5.136620e-02,4.093196e-02,8.503770e-02,9.983277e-02,1.000737e-01, & - &9.649567e-02,9.023405e-02,8.165658e-02,7.059693e-02,5.592857e-02, & - &4.556596e-02,8.993393e-02,1.061367e-01,1.066708e-01,1.030152e-01, & - &9.650727e-02,8.751981e-02,7.594168e-02,6.051955e-02,5.015662e-02, & - &6.461293e-02,7.388516e-02,7.295180e-02,6.933066e-02,6.392597e-02, & - &5.696105e-02,4.825725e-02,3.698967e-02,3.219441e-02,6.866539e-02, & - &7.934374e-02,7.874526e-02,7.523231e-02,6.966552e-02,6.231630e-02, & - &5.303492e-02,4.089358e-02,3.681686e-02,7.293970e-02,8.495109e-02, & - &8.467305e-02,8.119259e-02,7.542060e-02,6.767565e-02,5.782982e-02, & - &4.485603e-02,4.152663e-02,7.746956e-02,9.076591e-02,9.074099e-02, & - &8.717608e-02,8.117981e-02,7.303279e-02,6.259716e-02,4.885996e-02, & - &4.624423e-02,8.225495e-02,9.678638e-02,9.688960e-02,9.320640e-02, & - &8.694541e-02,7.837644e-02,6.732649e-02,5.285221e-02,5.094538e-02, & - &5.845498e-02,6.680962e-02,6.587266e-02,6.256557e-02,5.754011e-02, & - &5.106067e-02,4.290685e-02,3.243208e-02,3.037189e-02,6.232652e-02, & - &7.195421e-02,7.131400e-02,6.798576e-02,6.275608e-02,5.587900e-02, & - &4.720927e-02,3.590066e-02,3.478040e-02,6.647158e-02,7.730601e-02, & - &7.689576e-02,7.346728e-02,6.799313e-02,6.072547e-02,5.151042e-02, & - &3.939698e-02,3.924742e-02,7.089054e-02,8.290807e-02,8.261536e-02, & - &7.901760e-02,7.328183e-02,6.557745e-02,5.580390e-02,4.289868e-02, & - &4.373289e-02,7.557125e-02,8.867634e-02,8.845564e-02,8.466689e-02, & - &7.862206e-02,7.047276e-02,6.007651e-02,4.638926e-02,4.818623e-02/ - data absa(1:270,7) / & - &2.128005e+00,1.966168e+00,1.924839e+00,1.894504e+00,1.856624e+00, & - &1.795598e+00,1.714073e+00,1.624626e+00,1.694776e+00,2.179204e+00, & - &2.017963e+00,1.985129e+00,1.963974e+00,1.934922e+00,1.881429e+00, & - &1.797331e+00,1.725181e+00,1.817302e+00,2.229010e+00,2.067918e+00, & - &2.043277e+00,2.032301e+00,2.011961e+00,1.963283e+00,1.880577e+00, & - &1.825455e+00,1.938454e+00,2.276689e+00,2.115741e+00,2.099678e+00, & - &2.098927e+00,2.086653e+00,2.042807e+00,1.962600e+00,1.922920e+00, & - &2.058278e+00,2.322508e+00,2.161860e+00,2.154560e+00,2.162991e+00, & - &2.159274e+00,2.118432e+00,2.040568e+00,2.016450e+00,2.173261e+00, & - &2.138658e+00,1.994219e+00,1.961198e+00,1.933156e+00,1.876445e+00, & - &1.799377e+00,1.699851e+00,1.581570e+00,1.613325e+00,2.191668e+00, & - &2.048889e+00,2.025246e+00,2.006733e+00,1.958624e+00,1.888495e+00, & - &1.787161e+00,1.683539e+00,1.737471e+00,2.242787e+00,2.101131e+00, & - &2.087115e+00,2.078483e+00,2.039297e+00,1.974989e+00,1.872640e+00, & - &1.784149e+00,1.860304e+00,2.291821e+00,2.150659e+00,2.146949e+00, & - &2.148184e+00,2.116671e+00,2.058636e+00,1.954780e+00,1.881393e+00, & - &1.979849e+00,2.339708e+00,2.198728e+00,2.204816e+00,2.215069e+00, & - &2.192047e+00,2.136085e+00,2.033017e+00,1.975486e+00,2.094771e+00, & - &2.121049e+00,1.995020e+00,1.969076e+00,1.942091e+00,1.871027e+00, & - &1.775982e+00,1.657725e+00,1.510171e+00,1.495499e+00,2.175281e+00, & - &2.052257e+00,2.037282e+00,2.018816e+00,1.956465e+00,1.867921e+00, & - &1.749246e+00,1.612126e+00,1.619045e+00,2.227550e+00,2.106732e+00, & - &2.102772e+00,2.092824e+00,2.039760e+00,1.956273e+00,1.835591e+00, & - &1.713002e+00,1.741299e+00,2.278336e+00,2.158621e+00,2.165639e+00, & - &2.164623e+00,2.119903e+00,2.041918e+00,1.919256e+00,1.811720e+00, & - &1.860570e+00,2.327904e+00,2.208861e+00,2.225879e+00,2.233749e+00, & - &2.197977e+00,2.121127e+00,1.998433e+00,1.906175e+00,1.974868e+00, & - &2.083776e+00,1.975904e+00,1.955428e+00,1.924732e+00,1.849403e+00, & - &1.738875e+00,1.600501e+00,1.422060e+00,1.359076e+00,2.138921e+00, & - &2.035448e+00,2.027046e+00,2.004265e+00,1.937355e+00,1.832383e+00, & - &1.693710e+00,1.523775e+00,1.481472e+00,2.191658e+00,2.091734e+00, & - &2.095308e+00,2.081257e+00,2.023342e+00,1.922981e+00,1.781065e+00, & - &1.624234e+00,1.601983e+00,2.243139e+00,2.145460e+00,2.160867e+00, & - &2.155890e+00,2.106066e+00,2.009458e+00,1.864971e+00,1.722524e+00, & - &1.720066e+00,2.293447e+00,2.198173e+00,2.223410e+00,2.227790e+00, & - &2.185919e+00,2.090610e+00,1.944682e+00,1.816497e+00,1.833058e+00, & - &2.026534e+00,1.937103e+00,1.921426e+00,1.887566e+00,1.808709e+00, & - &1.691836e+00,1.533622e+00,1.326030e+00,1.216921e+00,2.081408e+00, & - &1.998393e+00,1.996074e+00,1.969402e+00,1.899083e+00,1.787248e+00, & - &1.627061e+00,1.425975e+00,1.336388e+00,2.134976e+00,2.057128e+00, & - &2.067369e+00,2.048887e+00,1.987370e+00,1.878809e+00,1.715503e+00, & - &1.523648e+00,1.452397e+00,2.187968e+00,2.113871e+00,2.135078e+00, & - &2.125752e+00,2.071840e+00,1.965958e+00,1.799492e+00,1.620520e+00, & - &1.567779e+00,2.239101e+00,2.169078e+00,2.200257e+00,2.200332e+00, & - &2.153427e+00,2.048793e+00,1.880177e+00,1.714551e+00,1.680011e+00, & - &1.947875e+00,1.876992e+00,1.865718e+00,1.827213e+00,1.747539e+00, & - &1.628120e+00,1.453091e+00,1.224306e+00,1.071256e+00,2.003104e+00, & - &1.940444e+00,1.942323e+00,1.911522e+00,1.839266e+00,1.723395e+00, & - &1.547413e+00,1.319973e+00,1.184577e+00,2.056530e+00,2.000924e+00, & - &2.014738e+00,1.993010e+00,1.928095e+00,1.815885e+00,1.637399e+00, & - &1.415000e+00,1.296462e+00,2.108710e+00,2.059530e+00,2.084562e+00, & - &2.071320e+00,2.014062e+00,1.904048e+00,1.724015e+00,1.509761e+00, & - &1.408896e+00,2.159907e+00,2.116983e+00,2.152069e+00,2.147422e+00, & - &2.096509e+00,1.988353e+00,1.804463e+00,1.601921e+00,1.518063e+00/ - data absa(271:585,7) / & - &1.852361e+00,1.799912e+00,1.790749e+00,1.749742e+00,1.669795e+00, & - &1.547300e+00,1.366597e+00,1.125160e+00,9.304529e-01,1.906325e+00, & - &1.863849e+00,1.868146e+00,1.835036e+00,1.762320e+00,1.642021e+00, & - &1.461246e+00,1.216521e+00,1.037806e+00,1.959604e+00,1.925503e+00, & - &1.941774e+00,1.917423e+00,1.851117e+00,1.734319e+00,1.552080e+00, & - &1.307619e+00,1.144925e+00,2.011590e+00,1.985496e+00,2.012462e+00, & - &1.996620e+00,1.937483e+00,1.822658e+00,1.640061e+00,1.398941e+00, & - &1.252100e+00,2.061263e+00,2.043419e+00,2.081394e+00,2.073871e+00, & - &2.020271e+00,1.907299e+00,1.723604e+00,1.487844e+00,1.356765e+00, & - &1.746126e+00,1.709615e+00,1.702048e+00,1.658133e+00,1.579846e+00, & - &1.454472e+00,1.277004e+00,1.033040e+00,8.003621e-01,1.799625e+00, & - &1.774247e+00,1.778939e+00,1.744173e+00,1.671117e+00,1.547903e+00, & - &1.370595e+00,1.118754e+00,9.004444e-01,1.851009e+00,1.835920e+00, & - &1.852579e+00,1.826256e+00,1.758713e+00,1.639090e+00,1.461386e+00, & - &1.204868e+00,1.000831e+00,1.900863e+00,1.895612e+00,1.924185e+00, & - &1.905748e+00,1.844275e+00,1.727167e+00,1.548781e+00,1.291227e+00, & - &1.101600e+00,1.949513e+00,1.953908e+00,1.993502e+00,1.984024e+00, & - &1.926682e+00,1.811277e+00,1.632734e+00,1.375052e+00,1.199662e+00, & - &1.632749e+00,1.608497e+00,1.600497e+00,1.555611e+00,1.476828e+00, & - &1.351469e+00,1.179914e+00,9.444458e-01,6.802981e-01,1.683574e+00, & - &1.672502e+00,1.677334e+00,1.640700e+00,1.565865e+00,1.442510e+00, & - &1.271547e+00,1.025954e+00,7.722536e-01,1.733176e+00,1.734121e+00, & - &1.750687e+00,1.722143e+00,1.651398e+00,1.532085e+00,1.361080e+00, & - &1.106620e+00,8.654288e-01,1.781593e+00,1.793974e+00,1.821460e+00, & - &1.801462e+00,1.735173e+00,1.618729e+00,1.447074e+00,1.186417e+00, & - &9.578835e-01,1.828024e+00,1.851762e+00,1.890720e+00,1.878609e+00, & - &1.816978e+00,1.702019e+00,1.530199e+00,1.264543e+00,1.048758e+00, & - &1.520094e+00,1.506973e+00,1.498138e+00,1.451954e+00,1.372000e+00, & - &1.248649e+00,1.084826e+00,8.628570e-01,5.818069e-01,1.568912e+00, & - &1.570326e+00,1.573125e+00,1.534783e+00,1.457488e+00,1.336669e+00, & - &1.173879e+00,9.426516e-01,6.664516e-01,1.616793e+00,1.631806e+00, & - &1.644746e+00,1.615327e+00,1.540284e+00,1.423046e+00,1.260694e+00, & - &1.019027e+00,7.513836e-01,1.662547e+00,1.690505e+00,1.714737e+00, & - &1.692638e+00,1.621742e+00,1.507815e+00,1.344263e+00,1.092684e+00, & - &8.366228e-01,1.706999e+00,1.747852e+00,1.782461e+00,1.768423e+00, & - &1.701588e+00,1.589181e+00,1.425343e+00,1.164997e+00,9.213949e-01, & - &1.429753e+00,1.432469e+00,1.425204e+00,1.381596e+00,1.299820e+00, & - &1.181395e+00,1.027086e+00,8.167487e-01,5.359441e-01,1.476310e+00, & - &1.494207e+00,1.497292e+00,1.460433e+00,1.380727e+00,1.264817e+00, & - &1.111897e+00,8.920969e-01,6.139916e-01,1.521592e+00,1.553692e+00, & - &1.566862e+00,1.536220e+00,1.460030e+00,1.348233e+00,1.193404e+00, & - &9.638057e-01,6.926653e-01,1.565451e+00,1.610952e+00,1.633944e+00, & - &1.610255e+00,1.538773e+00,1.428255e+00,1.272791e+00,1.033527e+00, & - &7.719264e-01,1.608212e+00,1.666214e+00,1.699807e+00,1.682449e+00, & - &1.614741e+00,1.506801e+00,1.348407e+00,1.101497e+00,8.510572e-01, & - &1.338386e+00,1.354916e+00,1.347179e+00,1.301898e+00,1.220716e+00, & - &1.107721e+00,9.641538e-01,7.653352e-01,4.980313e-01,1.382248e+00, & - &1.413638e+00,1.415669e+00,1.375806e+00,1.297410e+00,1.187904e+00, & - &1.042682e+00,8.352433e-01,5.708873e-01,1.425186e+00,1.470528e+00, & - &1.482282e+00,1.447850e+00,1.373662e+00,1.266176e+00,1.118914e+00, & - &9.026883e-01,6.454464e-01,1.466931e+00,1.525562e+00,1.547102e+00, & - &1.518465e+00,1.448348e+00,1.342232e+00,1.192422e+00,9.689946e-01, & - &7.200767e-01,1.507533e+00,1.579057e+00,1.610573e+00,1.587983e+00, & - &1.520364e+00,1.416602e+00,1.262984e+00,1.033665e+00,7.948627e-01, & - &1.250460e+00,1.277336e+00,1.268498e+00,1.218874e+00,1.138738e+00, & - &1.032961e+00,8.965507e-01,7.097661e-01,4.609400e-01,1.293435e+00, & - &1.334108e+00,1.333637e+00,1.288712e+00,1.212440e+00,1.108283e+00, & - &9.694109e-01,7.740534e-01,5.297977e-01,1.335097e+00,1.389103e+00, & - &1.396990e+00,1.357302e+00,1.285701e+00,1.181586e+00,1.039780e+00, & - &8.377348e-01,5.993538e-01,1.375874e+00,1.442959e+00,1.458930e+00, & - &1.425827e+00,1.356200e+00,1.252965e+00,1.108091e+00,9.001483e-01, & - &6.693575e-01,1.415991e+00,1.495590e+00,1.520178e+00,1.491614e+00, & - &1.425473e+00,1.322141e+00,1.174343e+00,9.612775e-01,7.396919e-01/ - data absa(1:270,8) / & - &1.481634e+01,1.296450e+01,1.123122e+01,1.002443e+01,9.482934e+00, & - &9.720777e+00,1.073746e+01,1.252338e+01,1.380490e+01,1.459122e+01, & - &1.276746e+01,1.106617e+01,9.934960e+00,9.504464e+00,9.881556e+00, & - &1.117122e+01,1.303068e+01,1.435175e+01,1.435314e+01,1.255909e+01, & - &1.089015e+01,9.833833e+00,9.511404e+00,1.006069e+01,1.158019e+01, & - &1.350698e+01,1.486969e+01,1.410700e+01,1.234404e+01,1.070441e+01, & - &9.723553e+00,9.526978e+00,1.024720e+01,1.198624e+01,1.398031e+01, & - &1.536963e+01,1.385225e+01,1.212101e+01,1.051269e+01,9.622192e+00, & - &9.547289e+00,1.046075e+01,1.241753e+01,1.448386e+01,1.589945e+01, & - &1.560431e+01,1.365365e+01,1.184756e+01,1.059466e+01,1.018524e+01, & - &1.047320e+01,1.152939e+01,1.342632e+01,1.500832e+01,1.538802e+01, & - &1.346470e+01,1.169117e+01,1.052191e+01,1.022615e+01,1.067609e+01, & - &1.201003e+01,1.400872e+01,1.565020e+01,1.516042e+01,1.326535e+01, & - &1.152379e+01,1.043394e+01,1.025210e+01,1.087888e+01,1.248056e+01, & - &1.455773e+01,1.625539e+01,1.492242e+01,1.305692e+01,1.134677e+01, & - &1.033772e+01,1.029381e+01,1.109140e+01,1.296596e+01,1.512394e+01, & - &1.686265e+01,1.467677e+01,1.284263e+01,1.116300e+01,1.025053e+01, & - &1.034326e+01,1.135075e+01,1.346725e+01,1.570886e+01,1.749996e+01, & - &1.655212e+01,1.448320e+01,1.258538e+01,1.125386e+01,1.087430e+01, & - &1.117309e+01,1.220685e+01,1.417683e+01,1.603250e+01,1.635750e+01, & - &1.431297e+01,1.244949e+01,1.121619e+01,1.095357e+01,1.142377e+01, & - &1.273923e+01,1.485910e+01,1.679990e+01,1.614932e+01,1.413100e+01, & - &1.230215e+01,1.116898e+01,1.102031e+01,1.167709e+01,1.329186e+01, & - &1.550413e+01,1.752517e+01,1.593353e+01,1.394173e+01,1.214652e+01, & - &1.110830e+01,1.109226e+01,1.193661e+01,1.383778e+01,1.614135e+01, & - &1.824181e+01,1.571308e+01,1.374902e+01,1.198719e+01,1.105091e+01, & - &1.116229e+01,1.224488e+01,1.440868e+01,1.680742e+01,1.898255e+01, & - &1.763465e+01,1.543039e+01,1.343858e+01,1.205526e+01,1.156419e+01, & - &1.184022e+01,1.283035e+01,1.486770e+01,1.691105e+01,1.747390e+01, & - &1.528963e+01,1.333728e+01,1.206636e+01,1.170289e+01,1.216219e+01, & - &1.343668e+01,1.565866e+01,1.780728e+01,1.730599e+01,1.514274e+01, & - &1.322695e+01,1.205869e+01,1.181669e+01,1.246978e+01,1.406782e+01, & - &1.640985e+01,1.865985e+01,1.713233e+01,1.499086e+01,1.310493e+01, & - &1.203596e+01,1.192926e+01,1.278871e+01,1.469982e+01,1.714656e+01, & - &1.949311e+01,1.695046e+01,1.483155e+01,1.298342e+01,1.201059e+01, & - &1.204048e+01,1.313893e+01,1.534551e+01,1.789994e+01,2.034558e+01, & - &1.886428e+01,1.650661e+01,1.441395e+01,1.295249e+01,1.234264e+01, & - &1.248837e+01,1.345257e+01,1.550775e+01,1.768262e+01,1.875111e+01, & - &1.640731e+01,1.434856e+01,1.301691e+01,1.254300e+01,1.288182e+01, & - &1.414975e+01,1.642661e+01,1.872920e+01,1.862344e+01,1.629586e+01, & - &1.427108e+01,1.306061e+01,1.271347e+01,1.326595e+01,1.485274e+01, & - &1.731516e+01,1.973837e+01,1.848323e+01,1.617280e+01,1.419298e+01, & - &1.308536e+01,1.288262e+01,1.365587e+01,1.556648e+01,1.815824e+01, & - &2.070136e+01,1.834038e+01,1.604811e+01,1.411535e+01,1.309844e+01, & - &1.304555e+01,1.406127e+01,1.628348e+01,1.899502e+01,2.165250e+01, & - &2.020716e+01,1.768119e+01,1.546859e+01,1.393664e+01,1.316871e+01, & - &1.312837e+01,1.403913e+01,1.600532e+01,1.827143e+01,2.013613e+01, & - &1.761881e+01,1.545418e+01,1.405602e+01,1.344539e+01,1.362293e+01, & - &1.482783e+01,1.708712e+01,1.950397e+01,2.005749e+01,1.755044e+01, & - &1.543361e+01,1.415435e+01,1.369367e+01,1.408681e+01,1.560414e+01, & - &1.810865e+01,2.066995e+01,1.996805e+01,1.747198e+01,1.540330e+01, & - &1.423617e+01,1.392325e+01,1.454865e+01,1.636758e+01,1.906938e+01, & - &2.176295e+01,1.986450e+01,1.738227e+01,1.537047e+01,1.430550e+01, & - &1.415137e+01,1.501484e+01,1.715893e+01,2.001139e+01,2.283609e+01/ - data absa(271:585,8) / & - &2.163589e+01,1.893263e+01,1.661043e+01,1.497705e+01,1.404333e+01, & - &1.382784e+01,1.455174e+01,1.635455e+01,1.868149e+01,2.162343e+01, & - &1.892636e+01,1.665639e+01,1.516875e+01,1.440054e+01,1.442716e+01, & - &1.544002e+01,1.759513e+01,2.009772e+01,2.158927e+01,1.890049e+01, & - &1.669072e+01,1.533233e+01,1.473181e+01,1.498273e+01,1.629942e+01, & - &1.876169e+01,2.142585e+01,2.154008e+01,1.886378e+01,1.672174e+01, & - &1.547992e+01,1.503701e+01,1.552799e+01,1.713422e+01,1.985622e+01, & - &2.267289e+01,2.148900e+01,1.882403e+01,1.674018e+01,1.561000e+01, & - &1.533583e+01,1.606692e+01,1.796293e+01,2.091989e+01,2.388666e+01, & - &2.312192e+01,2.024776e+01,1.781150e+01,1.607690e+01,1.494525e+01, & - &1.455892e+01,1.499913e+01,1.653606e+01,1.889322e+01,2.315799e+01, & - &2.029174e+01,1.793197e+01,1.633658e+01,1.540613e+01,1.526956e+01, & - &1.600118e+01,1.795155e+01,2.050672e+01,2.318598e+01,2.032657e+01, & - &1.803644e+01,1.657930e+01,1.583698e+01,1.592843e+01,1.695518e+01, & - &1.927297e+01,2.201501e+01,2.319995e+01,2.034868e+01,1.812426e+01, & - &1.679907e+01,1.623178e+01,1.656135e+01,1.788094e+01,2.051395e+01, & - &2.342941e+01,2.319626e+01,2.035336e+01,1.820305e+01,1.699256e+01, & - &1.661519e+01,1.718266e+01,1.878044e+01,2.171717e+01,2.480686e+01, & - &2.463197e+01,2.159873e+01,1.905911e+01,1.718863e+01,1.588181e+01, & - &1.528996e+01,1.542223e+01,1.657027e+01,1.890856e+01,2.474272e+01, & - &2.171092e+01,1.925064e+01,1.753899e+01,1.645792e+01,1.612708e+01, & - &1.655111e+01,1.814390e+01,2.072650e+01,2.483438e+01,2.180567e+01, & - &1.942745e+01,1.786388e+01,1.699639e+01,1.689557e+01,1.761316e+01, & - &1.962742e+01,2.242223e+01,2.490311e+01,2.187836e+01,1.959032e+01, & - &1.815953e+01,1.749350e+01,1.762831e+01,1.863892e+01,2.103516e+01, & - &2.403051e+01,2.495897e+01,2.193818e+01,1.972712e+01,1.843527e+01, & - &1.796238e+01,1.833756e+01,1.962739e+01,2.238678e+01,2.557583e+01, & - &2.615004e+01,2.296015e+01,2.032673e+01,1.833279e+01,1.688049e+01, & - &1.608183e+01,1.591247e+01,1.665236e+01,1.889019e+01,2.632995e+01, & - &2.313869e+01,2.060673e+01,1.878207e+01,1.757861e+01,1.704002e+01, & - &1.716185e+01,1.833630e+01,2.090336e+01,2.648042e+01,2.329094e+01, & - &2.087052e+01,1.919032e+01,1.822814e+01,1.792924e+01,1.834343e+01, & - &1.996123e+01,2.279887e+01,2.661609e+01,2.342675e+01,2.109977e+01, & - &1.957693e+01,1.882625e+01,1.876172e+01,1.947633e+01,2.152423e+01, & - &2.458976e+01,2.672958e+01,2.353991e+01,2.131173e+01,1.993220e+01, & - &1.938849e+01,1.957017e+01,2.056447e+01,2.302139e+01,2.629959e+01, & - &2.775971e+01,2.441993e+01,2.176577e+01,1.972218e+01,1.826424e+01, & - &1.736092e+01,1.701486e+01,1.753145e+01,1.975713e+01,2.799824e+01, & - &2.465558e+01,2.212305e+01,2.026027e+01,1.905730e+01,1.841512e+01, & - &1.835443e+01,1.930884e+01,2.190486e+01,2.821027e+01,2.486827e+01, & - &2.245076e+01,2.076865e+01,1.979311e+01,1.938208e+01,1.964078e+01, & - &2.102621e+01,2.393095e+01,2.839690e+01,2.505965e+01,2.275461e+01, & - &2.123808e+01,2.046736e+01,2.031418e+01,2.086446e+01,2.267149e+01, & - &2.584551e+01,2.855390e+01,2.523241e+01,2.302396e+01,2.167681e+01, & - &2.111640e+01,2.119828e+01,2.206103e+01,2.425477e+01,2.767864e+01, & - &2.934690e+01,2.587934e+01,2.322807e+01,2.118533e+01,1.969066e+01, & - &1.868178e+01,1.815103e+01,1.845454e+01,2.059938e+01,2.964601e+01, & - &2.618860e+01,2.366729e+01,2.182398e+01,2.057408e+01,1.981186e+01, & - &1.960219e+01,2.033113e+01,2.286643e+01,2.991134e+01,2.646916e+01, & - &2.406949e+01,2.241815e+01,2.138675e+01,2.087903e+01,2.098599e+01, & - &2.212932e+01,2.500018e+01,3.014622e+01,2.672161e+01,2.443815e+01, & - &2.296921e+01,2.214931e+01,2.189659e+01,2.231796e+01,2.384682e+01, & - &2.703163e+01,3.035127e+01,2.694551e+01,2.477309e+01,2.347701e+01, & - &2.288369e+01,2.286770e+01,2.361429e+01,2.550405e+01,2.897214e+01, & - &3.089835e+01,2.733935e+01,2.468877e+01,2.267357e+01,2.112933e+01, & - &1.998467e+01,1.931246e+01,1.939689e+01,2.138070e+01,3.124375e+01, & - &2.771473e+01,2.521233e+01,2.340646e+01,2.209176e+01,2.121365e+01, & - &2.086651e+01,2.136943e+01,2.374824e+01,3.155797e+01,2.805741e+01, & - &2.569630e+01,2.408627e+01,2.298184e+01,2.238066e+01,2.235595e+01, & - &2.324146e+01,2.599450e+01,3.183738e+01,2.836143e+01,2.614040e+01, & - &2.470339e+01,2.383590e+01,2.349354e+01,2.378613e+01,2.503636e+01, & - &2.813425e+01,3.207875e+01,2.863161e+01,2.653899e+01,2.529418e+01, & - &2.463977e+01,2.456334e+01,2.516596e+01,2.676528e+01,3.017778e+01/ - -! the array selfref contains the coefficient of the water vapor -! self-continuum (including the energy term). the first index -! refers to temperature in 7.2 degree increments. for instance, -! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, -! etc. the second index runs over the g-channel (1 to NG12=8). - - data selfref(:, 1) / & - &2.349730e-02,2.078770e-02,1.839050e-02,1.626980e-02,1.439360e-02, & - &1.273380e-02,1.126540e-02,9.966320e-03,8.817040e-03,7.800300e-03/ - data selfref(:, 2) / & - &3.100900e-02,2.826260e-02,2.575940e-02,2.347790e-02,2.139850e-02, & - &1.950330e-02,1.777590e-02,1.620150e-02,1.476650e-02,1.345870e-02/ - data selfref(:, 3) / & - &5.366760e-02,4.956210e-02,4.577060e-02,4.226920e-02,3.903560e-02, & - &3.604940e-02,3.329170e-02,3.074490e-02,2.839290e-02,2.622090e-02/ - data selfref(:, 4) / & - &9.058440e-02,8.333490e-02,7.666560e-02,7.053000e-02,6.488550e-02, & - &5.969270e-02,5.491550e-02,5.052060e-02,4.647740e-02,4.275780e-02/ - data selfref(:, 5) / & - &1.169105e-01,1.092571e-01,1.021051e-01,9.542122e-02,8.917495e-02, & - &8.333775e-02,7.788278e-02,7.278498e-02,6.802097e-02,6.356890e-02/ - data selfref(:, 6) / & - &1.313184e-01,1.221409e-01,1.136045e-01,1.056652e-01,9.828068e-02, & - &9.141227e-02,8.502415e-02,7.908259e-02,7.355633e-02,6.841631e-02/ - data selfref(:, 7) / & - &1.320197e-01,1.233179e-01,1.151948e-01,1.076109e-01,1.005305e-01, & - &9.392025e-02,8.774848e-02,8.198579e-02,7.660488e-02,7.158029e-02/ - data selfref(:, 8) / & - &1.549932e-01,1.441646e-01,1.340967e-01,1.247363e-01,1.160340e-01, & - &1.079424e-01,1.004186e-01,9.342225e-02,8.691664e-02,8.086698e-02/ - - data fracrefa(:,:) / & - & 0.2124509960, 0.1516470015, 0.1448670030, 0.1307550073, & - & 0.2089565098, 0.1110393032, 0.0377703495, 0.0025157100, & - & 0.1470389962, 0.1693799943, 0.1560570002, 0.1415899992, & - & 0.2214699984, 0.1194058061, 0.0425452814, 0.0025157100, & - & 0.1368930042, 0.1661040038, 0.1572349966, 0.1429949999, & - & 0.2230722010, 0.1253705919, 0.0456136391, 0.0027171599, & - & 0.1305429935, 0.1627379954, 0.1587429941, 0.1427959949, & - & 0.2233920097, 0.1308227926, 0.0476873592, 0.0032784997, & - & 0.1282829940, 0.1582459956, 0.1568839997, 0.1444910020, & - & 0.2230562866, 0.1357017010, 0.0492800288, 0.0040590204, & - & 0.1264979988, 0.1519510001, 0.1564649940, 0.1456969976, & - & 0.2232281864, 0.1399483979, 0.0515311286, 0.0046821800, & - & 0.1250029951, 0.1446059942, 0.1567219943, 0.1472460032, & - & 0.2216909975, 0.1451247931, 0.0540730841, 0.0055353702, & - & 0.1231720001, 0.1411869973, 0.1524199992, 0.1379429996, & - & 0.2277460098, 0.1532972008, 0.0587020218, 0.0055353702, & - & 0.1019359976, 0.1169300005, 0.1323609948, 0.1405320019, & - & 0.2594290078, 0.1766991019, 0.0665789396, 0.0055363504 / - -!........................................! - end module module_radlw_kgb12 ! -!========================================! - - - -!========================================! - module module_radlw_kgb13 ! -!........................................! -! - use machine, only : kind_phys - use module_radlw_parameters, only : NG13 -! - implicit none -! - private -! - integer, public :: MSA13, MSF13, MAF13 - parameter (MSA13=585, MSF13=10, MAF13=9) - - real (kind=kind_phys), public :: & - & absa(MSA13,NG13), selfref(MSF13,NG13), fracrefa(NG13,MAF13) - -! the array absa(585,NG13) = ka(9,5,13,NG13) contains absorption coefs -! at the NG13=4 chosen g-values for a range of pressure levels> ~100mb, -! temperatures, and binary species parameters (see taumol.f for -! definition). the first index in the array, js, runs from 1 to 9, -! and corresponds to different values of the binary species parameter. -! for instance, js=1 refers to dry air, js = 2 corresponds to the -! paramter value 1/8, js = 3 corresponds to the parameter value 2/8, -! etc. the second index in the array, jt, which runs from 1 to 5, -! corresponds to different temperatures. more specifically, jt = 1-5 -! means that the data are for the corresponding temperature of -! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the -! third index, jp, runs from 1 to 13 and refers to the jpth reference -! pressure level (see taumol.f for these levels in mb). the fourth -! index, ig, goes from 1 to NG13=4, and indicates which g-interval -! the absorption coefficients are for. - - data absa(1:270, 1) / & - &1.268257e-04,1.756905e-04,1.935903e-04,2.031017e-04,2.057985e-04, & - &2.016072e-04,1.896075e-04,1.710697e-04,1.440649e-04,1.302391e-04, & - &1.915451e-04,2.162260e-04,2.306972e-04,2.362708e-04,2.332340e-04, & - &2.205717e-04,1.955700e-04,1.641166e-04,1.348449e-04,2.108561e-04, & - &2.433981e-04,2.627459e-04,2.715901e-04,2.697177e-04,2.560827e-04, & - &2.255143e-04,1.896695e-04,1.405733e-04,2.335070e-04,2.747666e-04, & - &2.990881e-04,3.113405e-04,3.105926e-04,2.961917e-04,2.605606e-04, & - &2.210372e-04,1.474390e-04,2.594453e-04,3.095456e-04,3.395333e-04, & - &3.549319e-04,3.561249e-04,3.401583e-04,3.004613e-04,2.585635e-04, & - &1.100207e-04,1.483148e-04,1.613145e-04,1.676504e-04,1.686356e-04, & - &1.640709e-04,1.532580e-04,1.381848e-04,1.402109e-04,1.131544e-04, & - &1.619362e-04,1.806199e-04,1.907971e-04,1.939533e-04,1.901544e-04, & - &1.785877e-04,1.581987e-04,1.556840e-04,1.173603e-04,1.786647e-04, & - &2.038453e-04,2.178318e-04,2.234184e-04,2.204559e-04,2.082520e-04, & - &1.829312e-04,1.761947e-04,1.226172e-04,1.985274e-04,2.307527e-04, & - &2.487126e-04,2.569808e-04,2.548501e-04,2.416371e-04,2.117575e-04, & - &2.018891e-04,1.289350e-04,2.213484e-04,2.606606e-04,2.833970e-04, & - &2.942978e-04,2.933595e-04,2.783708e-04,2.449064e-04,2.329742e-04, & - &9.565221e-05,1.238720e-04,1.321904e-04,1.353343e-04,1.345482e-04, & - &1.295882e-04,1.200361e-04,1.090768e-04,1.706971e-04,9.826485e-05, & - &1.348897e-04,1.477244e-04,1.538329e-04,1.546275e-04,1.501323e-04, & - &1.398728e-04,1.238952e-04,1.823344e-04,1.018544e-04,1.486611e-04, & - &1.667446e-04,1.758411e-04,1.783430e-04,1.745144e-04,1.635976e-04, & - &1.430251e-04,1.982811e-04,1.064242e-04,1.652319e-04,1.889637e-04, & - &2.012579e-04,2.058789e-04,2.026209e-04,1.907379e-04,1.658720e-04, & - &2.191140e-04,1.119583e-04,1.844577e-04,2.140067e-04,2.301281e-04, & - &2.369657e-04,2.343698e-04,2.206127e-04,1.925163e-04,2.451834e-04, & - &8.487777e-05,1.048962e-04,1.094521e-04,1.100565e-04,1.077247e-04, & - &1.025263e-04,9.384039e-05,8.619249e-05,2.372044e-04,8.693195e-05, & - &1.135085e-04,1.216039e-04,1.245077e-04,1.233151e-04,1.182401e-04, & - &1.089900e-04,9.664311e-05,2.463777e-04,8.985352e-05,1.245618e-04, & - &1.367885e-04,1.420557e-04,1.420759e-04,1.374801e-04,1.274539e-04, & - &1.107865e-04,2.587857e-04,9.366106e-05,1.380536e-04,1.547590e-04, & - &1.625900e-04,1.642680e-04,1.600042e-04,1.490476e-04,1.284632e-04, & - &2.754156e-04,9.837694e-05,1.539361e-04,1.753495e-04,1.861640e-04, & - &1.896568e-04,1.856673e-04,1.732218e-04,1.496299e-04,2.973063e-04, & - &7.711362e-05,9.075663e-05,9.252259e-05,9.127534e-05,8.770620e-05, & - &8.216474e-05,7.421396e-05,6.845360e-05,3.440013e-04,7.866973e-05, & - &9.749304e-05,1.018228e-04,1.023055e-04,9.961898e-05,9.415133e-05, & - &8.560403e-05,7.597944e-05,3.504114e-04,8.098540e-05,1.062605e-04, & - &1.137070e-04,1.160556e-04,1.143521e-04,1.090912e-04,9.973073e-05, & - &8.629772e-05,3.596115e-04,8.410079e-05,1.170572e-04,1.280824e-04, & - &1.324879e-04,1.319516e-04,1.268543e-04,1.167139e-04,9.959904e-05, & - &3.725404e-04,8.804555e-05,1.299639e-04,1.448675e-04,1.515920e-04, & - &1.524019e-04,1.473812e-04,1.361422e-04,1.159792e-04,3.903554e-04, & - &7.155324e-05,8.011144e-05,7.975963e-05,7.703071e-05,7.256433e-05, & - &6.663159e-05,5.927891e-05,5.482609e-05,5.082539e-04,7.267221e-05, & - &8.525220e-05,8.671770e-05,8.520694e-05,8.136698e-05,7.554059e-05, & - &6.760325e-05,6.020699e-05,5.087722e-04,7.448209e-05,9.214460e-05, & - &9.582438e-05,9.570572e-05,9.261914e-05,8.691038e-05,7.820723e-05, & - &6.749958e-05,5.129666e-04,7.698506e-05,1.006824e-04,1.070161e-04, & - &1.086108e-04,1.063577e-04,1.007129e-04,9.121386e-05,7.712618e-05, & - &5.213856e-04,8.024718e-05,1.109795e-04,1.204271e-04,1.238093e-04, & - &1.225103e-04,1.167891e-04,1.065252e-04,8.952515e-05,5.347971e-04/ - data absa(271:585, 1) / & - &6.816337e-05,7.305278e-05,7.103909e-05,6.713487e-05,6.194905e-05, & - &5.564247e-05,4.837735e-05,4.441104e-05,8.214907e-04,6.901227e-05, & - &7.703707e-05,7.632777e-05,7.320635e-05,6.843679e-05,6.213362e-05, & - &5.449889e-05,4.844215e-05,8.088044e-04,7.048679e-05,8.246278e-05, & - &8.332870e-05,8.122090e-05,7.691330e-05,7.068837e-05,6.236661e-05, & - &5.335414e-05,8.023228e-04,7.264958e-05,8.927422e-05,9.199891e-05, & - &9.124530e-05,8.749573e-05,8.126669e-05,7.215435e-05,6.027417e-05, & - &8.020200e-04,7.543389e-05,9.750872e-05,1.025941e-04,1.032074e-04, & - &1.001226e-04,9.380090e-05,8.407921e-05,6.950187e-05,8.093129e-04, & - &6.776531e-05,6.997109e-05,6.649428e-05,6.158712e-05,5.562985e-05, & - &4.872902e-05,4.123200e-05,3.710586e-05,1.637430e-03,6.864221e-05, & - &7.327313e-05,7.082204e-05,6.639813e-05,6.069238e-05,5.367579e-05, & - &4.575305e-05,3.975991e-05,1.587205e-03,7.009941e-05,7.783911e-05, & - &7.653449e-05,7.278260e-05,6.730261e-05,6.023643e-05,5.168402e-05, & - &4.313223e-05,1.548926e-03,7.215316e-05,8.363141e-05,8.365482e-05, & - &8.075083e-05,7.557928e-05,6.842880e-05,5.913233e-05,4.813471e-05, & - &1.524919e-03,7.478487e-05,9.058132e-05,9.222572e-05,9.033860e-05, & - &8.550061e-05,7.815237e-05,6.826659e-05,5.498956e-05,1.515534e-03, & - &6.664136e-05,6.673959e-05,6.226917e-05,5.671037e-05,5.037482e-05, & - &4.327883e-05,3.574448e-05,3.172851e-05,6.214582e-03,6.764954e-05, & - &6.970308e-05,6.598899e-05,6.080243e-05,5.450258e-05,4.729645e-05, & - &3.929020e-05,3.334006e-05,5.938951e-03,6.923787e-05,7.376299e-05, & - &7.097772e-05,6.616309e-05,6.002535e-05,5.265596e-05,4.400004e-05, & - &3.582877e-05,5.712335e-03,7.134662e-05,7.902977e-05,7.719191e-05, & - &7.290837e-05,6.697363e-05,5.930629e-05,4.988284e-05,3.933043e-05, & - &5.537936e-03,7.397145e-05,8.529624e-05,8.464318e-05,8.104821e-05, & - &7.521325e-05,6.716300e-05,5.704906e-05,4.439658e-05,5.418951e-03, & - &6.586425e-05,6.439495e-05,5.924291e-05,5.316734e-05,4.647451e-05, & - &3.928765e-05,3.157285e-05,2.727814e-05,2.669162e-02,6.719808e-05, & - &6.723752e-05,6.262059e-05,5.687371e-05,5.021549e-05,4.280323e-05, & - &3.460686e-05,2.851631e-05,2.529030e-02,6.910509e-05,7.115127e-05, & - &6.726083e-05,6.174267e-05,5.508382e-05,4.745149e-05,3.861916e-05, & - &3.041943e-05,2.412184e-02,7.153026e-05,7.616045e-05,7.302107e-05, & - &6.779311e-05,6.117091e-05,5.316068e-05,4.364495e-05,3.316397e-05, & - &2.317638e-02,7.439312e-05,8.218369e-05,7.987343e-05,7.502208e-05, & - &6.837452e-05,5.993043e-05,4.967306e-05,3.723878e-05,2.247273e-02, & - &6.424975e-05,6.223803e-05,5.689001e-05,5.070425e-05,4.393645e-05, & - &3.668247e-05,2.891865e-05,2.355553e-05,3.872555e-02,6.606022e-05, & - &6.542742e-05,6.057063e-05,5.458940e-05,4.773961e-05,4.016162e-05, & - &3.190113e-05,2.492836e-05,3.660895e-02,6.844415e-05,6.962953e-05, & - &6.536254e-05,5.947189e-05,5.250459e-05,4.463132e-05,3.575966e-05, & - &2.667878e-05,3.484922e-02,7.133916e-05,7.489484e-05,7.112169e-05, & - &6.536179e-05,5.830565e-05,5.005235e-05,4.044271e-05,2.951582e-05, & - &3.345920e-02,7.469082e-05,8.100257e-05,7.781535e-05,7.225079e-05, & - &6.509823e-05,5.643033e-05,4.593279e-05,3.330003e-05,3.244531e-02, & - &5.968449e-05,5.749283e-05,5.233613e-05,4.645163e-05,4.002666e-05, & - &3.314965e-05,2.580900e-05,2.011713e-05,4.095690e-02,6.178427e-05, & - &6.077003e-05,5.601060e-05,5.020415e-05,4.364913e-05,3.645427e-05, & - &2.864358e-05,2.134288e-05,3.867768e-02,6.437334e-05,6.496461e-05, & - &6.063926e-05,5.485702e-05,4.814854e-05,4.059669e-05,3.214141e-05, & - &2.314145e-05,3.680657e-02,6.738820e-05,7.007657e-05,6.613229e-05, & - &6.042356e-05,5.351019e-05,4.554029e-05,3.636145e-05,2.579677e-05, & - &3.534447e-02,7.082803e-05,7.592588e-05,7.246285e-05,6.680477e-05, & - &5.969683e-05,5.128523e-05,4.121655e-05,2.924878e-05,3.432332e-02, & - &5.739462e-05,5.482446e-05,4.965413e-05,4.384434e-05,3.752313e-05, & - &3.077633e-05,2.361965e-05,1.723304e-05,3.488567e-02,5.961588e-05, & - &5.809099e-05,5.328269e-05,4.747539e-05,4.098826e-05,3.391669e-05, & - &2.626501e-05,1.852116e-05,3.291555e-02,6.230787e-05,6.224739e-05, & - &5.773284e-05,5.190478e-05,4.521237e-05,3.773922e-05,2.945352e-05, & - &2.035565e-05,3.131494e-02,6.540066e-05,6.716915e-05,6.293584e-05, & - &5.709740e-05,5.015038e-05,4.221938e-05,3.322540e-05,2.288597e-05, & - &3.010163e-02,6.889562e-05,7.277256e-05,6.887173e-05,6.298452e-05, & - &5.576043e-05,4.735062e-05,3.753566e-05,2.602550e-05,2.929330e-02/ - data absa(1:270, 2) / & - &1.738473e-03,1.695641e-03,1.608407e-03,1.478003e-03,1.315160e-03, & - &1.122413e-03,8.994164e-04,6.258009e-04,4.751778e-04,1.781477e-03, & - &1.779546e-03,1.706177e-03,1.582301e-03,1.421640e-03,1.229180e-03, & - &1.006191e-03,7.290306e-04,5.935156e-04,1.835292e-03,1.877927e-03, & - &1.817729e-03,1.703745e-03,1.545665e-03,1.358631e-03,1.134663e-03, & - &8.519847e-04,7.385538e-04,1.898031e-03,1.987691e-03,1.945772e-03, & - &1.841858e-03,1.692903e-03,1.512505e-03,1.284821e-03,9.957349e-04, & - &9.109412e-04,1.969345e-03,2.108715e-03,2.089999e-03,2.000163e-03, & - &1.864963e-03,1.689782e-03,1.459430e-03,1.159174e-03,1.111375e-03, & - &1.550264e-03,1.510058e-03,1.428632e-03,1.305843e-03,1.155696e-03, & - &9.800249e-04,7.771075e-04,5.330824e-04,4.577221e-04,1.590767e-03, & - &1.587100e-03,1.516031e-03,1.399196e-03,1.250837e-03,1.074506e-03, & - &8.705388e-04,6.221239e-04,5.682361e-04,1.641022e-03,1.677970e-03, & - &1.617727e-03,1.508478e-03,1.363002e-03,1.189506e-03,9.834872e-04, & - &7.288533e-04,7.054842e-04,1.699658e-03,1.779461e-03,1.734840e-03, & - &1.635389e-03,1.495794e-03,1.326601e-03,1.116925e-03,8.546987e-04, & - &8.704186e-04,1.766537e-03,1.891600e-03,1.867875e-03,1.780635e-03, & - &1.651463e-03,1.484220e-03,1.272126e-03,9.981922e-04,1.064562e-03, & - &1.361493e-03,1.318892e-03,1.240427e-03,1.125812e-03,9.881209e-04, & - &8.306850e-04,6.504485e-04,4.365863e-04,5.168929e-04,1.397379e-03, & - &1.386624e-03,1.316881e-03,1.205955e-03,1.070044e-03,9.113326e-04, & - &7.284175e-04,5.106960e-04,6.233555e-04,1.442003e-03,1.466453e-03, & - &1.405555e-03,1.300973e-03,1.168671e-03,1.009410e-03,8.237605e-04, & - &5.998047e-04,7.588403e-04,1.494100e-03,1.556598e-03,1.508337e-03, & - &1.412897e-03,1.284055e-03,1.127016e-03,9.374400e-04,7.053483e-04, & - &9.264250e-04,1.553520e-03,1.657830e-03,1.626380e-03,1.542801e-03, & - &1.419539e-03,1.263219e-03,1.070648e-03,8.267778e-04,1.127867e-03, & - &1.188009e-03,1.142675e-03,1.065789e-03,9.613474e-04,8.362444e-04, & - &6.959607e-04,5.386750e-04,3.519389e-04,6.675810e-04,1.219491e-03, & - &1.201092e-03,1.132245e-03,1.028990e-03,9.051485e-04,7.638845e-04, & - &6.023778e-04,4.127726e-04,7.717034e-04,1.257360e-03,1.269473e-03, & - &1.208319e-03,1.109740e-03,9.889649e-04,8.464660e-04,6.812697e-04, & - &4.865023e-04,9.111532e-04,1.302439e-03,1.347174e-03,1.296390e-03, & - &1.205656e-03,1.088943e-03,9.456688e-04,7.761648e-04,5.739587e-04, & - &1.088326e-03,1.355449e-03,1.435605e-03,1.398219e-03,1.318124e-03, & - &1.205382e-03,1.061568e-03,8.882119e-04,6.745633e-04,1.305640e-03, & - &1.028686e-03,9.828531e-04,9.090942e-04,8.149648e-04,7.032856e-04, & - &5.796421e-04,4.431944e-04,2.827696e-04,9.144058e-04,1.055314e-03, & - &1.031741e-03,9.652456e-04,8.713882e-04,7.602784e-04,6.356268e-04, & - &4.956797e-04,3.313763e-04,1.015699e-03,1.087828e-03,1.089302e-03, & - &1.029422e-03,9.387281e-04,8.301254e-04,7.052970e-04,5.606369e-04, & - &3.912786e-04,1.160350e-03,1.127319e-03,1.155813e-03,1.104058e-03, & - &1.019336e-03,9.145205e-04,7.885477e-04,6.390035e-04,4.633623e-04, & - &1.351125e-03,1.174306e-03,1.232769e-03,1.191590e-03,1.115168e-03, & - &1.013976e-03,8.858336e-04,7.320773e-04,5.471355e-04,1.590660e-03, & - &8.800732e-04,8.352382e-04,7.665961e-04,6.824950e-04,5.851237e-04, & - &4.777030e-04,3.606932e-04,2.246572e-04,1.286519e-03,9.021303e-04, & - &8.749512e-04,8.120150e-04,7.286753e-04,6.309944e-04,5.226525e-04, & - &4.030362e-04,2.625988e-04,1.380363e-03,9.299109e-04,9.227111e-04, & - &8.649026e-04,7.834755e-04,6.872095e-04,5.790542e-04,4.556974e-04, & - &3.103964e-04,1.526185e-03,9.639625e-04,9.788279e-04,9.277599e-04, & - &8.499804e-04,7.567035e-04,6.477006e-04,5.195343e-04,3.685663e-04, & - &1.729269e-03,1.004672e-03,1.044372e-03,1.002109e-03,9.307275e-04, & - &8.396832e-04,7.284477e-04,5.957079e-04,4.371829e-04,1.993403e-03/ - data absa(271:585, 2) / & - &7.494611e-04,7.061404e-04,6.433764e-04,5.689348e-04,4.849540e-04, & - &3.928995e-04,2.932287e-04,1.785530e-04,2.045264e-03,7.678865e-04, & - &7.383309e-04,6.800090e-04,6.062988e-04,5.214481e-04,4.281246e-04, & - &3.264017e-04,2.074715e-04,2.133737e-03,7.916451e-04,7.779938e-04, & - &7.234919e-04,6.512309e-04,5.665980e-04,4.730356e-04,3.686881e-04, & - &2.453102e-04,2.285983e-03,8.207975e-04,8.250553e-04,7.760384e-04, & - &7.058571e-04,6.231773e-04,5.287803e-04,4.199964e-04,2.916903e-04, & - &2.508926e-03,8.558902e-04,8.802607e-04,8.384191e-04,7.729189e-04, & - &6.916558e-04,5.952059e-04,4.816311e-04,3.472141e-04,2.812232e-03, & - &6.466291e-04,6.038761e-04,5.457510e-04,4.789685e-04,4.054618e-04, & - &3.261781e-04,2.405659e-04,1.425719e-04,4.208131e-03,6.616410e-04, & - &6.297029e-04,5.746933e-04,5.083724e-04,4.341611e-04,3.532498e-04, & - &2.659003e-04,1.651610e-04,4.315074e-03,6.812300e-04,6.619199e-04, & - &6.099113e-04,5.447881e-04,4.701606e-04,3.885989e-04,2.993335e-04, & - &1.946867e-04,4.517934e-03,7.056190e-04,7.003426e-04,6.528132e-04, & - &5.894661e-04,5.159070e-04,4.335872e-04,3.406108e-04,2.313125e-04, & - &4.821880e-03,7.354678e-04,7.464213e-04,7.048961e-04,6.448176e-04, & - &5.721896e-04,4.880569e-04,3.903627e-04,2.755203e-04,5.240144e-03, & - &5.684415e-04,5.259392e-04,4.711194e-04,4.101219e-04,3.444416e-04, & - &2.746516e-04,2.001889e-04,1.148483e-04,1.695773e-02,5.801829e-04, & - &5.457940e-04,4.931883e-04,4.323692e-04,3.662393e-04,2.951183e-04, & - &2.188958e-04,1.322078e-04,1.729150e-02,5.955121e-04,5.707724e-04, & - &5.204540e-04,4.606754e-04,3.941979e-04,3.220101e-04,2.443944e-04, & - &1.546573e-04,1.793506e-02,6.151319e-04,6.010579e-04,5.541651e-04, & - &4.960012e-04,4.297626e-04,3.571238e-04,2.766206e-04,1.832770e-04, & - &1.888992e-02,6.396829e-04,6.382349e-04,5.960792e-04,5.403319e-04, & - &4.747159e-04,4.003795e-04,3.162973e-04,2.180847e-04,2.016301e-02, & - &5.260629e-04,4.816155e-04,4.274071e-04,3.689440e-04,3.072108e-04, & - &2.425039e-04,1.745135e-04,9.730112e-05,7.992078e-02,5.347336e-04, & - &4.963450e-04,4.437745e-04,3.853418e-04,3.232466e-04,2.576336e-04, & - &1.881955e-04,1.102428e-04,8.175020e-02,5.462285e-04,5.151613e-04, & - &4.642553e-04,4.066046e-04,3.444051e-04,2.778661e-04,2.072429e-04, & - &1.274188e-04,8.489862e-02,5.613597e-04,5.384330e-04,4.901909e-04, & - &4.339402e-04,3.719475e-04,3.047888e-04,2.319385e-04,1.494628e-04, & - &8.944120e-02,5.808941e-04,5.676426e-04,5.231390e-04,4.690898e-04, & - &4.071963e-04,3.387085e-04,2.630562e-04,1.766197e-04,9.537615e-02, & - &5.145444e-04,4.681844e-04,4.133287e-04,3.548358e-04,2.937511e-04, & - &2.303910e-04,1.642640e-04,9.116526e-05,1.333566e-01,5.222859e-04, & - &4.809572e-04,4.271556e-04,3.687635e-04,3.074772e-04,2.433516e-04, & - &1.760466e-04,1.020529e-04,1.382652e-01,5.327426e-04,4.972657e-04, & - &4.447462e-04,3.870743e-04,3.257829e-04,2.609713e-04,1.922857e-04, & - &1.168178e-04,1.453207e-01,5.464583e-04,5.174522e-04,4.672435e-04, & - &4.109155e-04,3.499349e-04,2.840029e-04,2.133847e-04,1.352767e-04, & - &1.545701e-01,5.638590e-04,5.430288e-04,4.963813e-04,4.418809e-04, & - &3.802197e-04,3.129755e-04,2.400605e-04,1.581170e-04,1.661719e-01, & - &4.913753e-04,4.458591e-04,3.924110e-04,3.357083e-04,2.769719e-04, & - &2.163975e-04,1.534056e-04,8.482570e-05,1.571469e-01,4.994145e-04, & - &4.583120e-04,4.054513e-04,3.489026e-04,2.899116e-04,2.285963e-04, & - &1.644040e-04,9.478390e-05,1.648274e-01,5.102879e-04,4.739592e-04, & - &4.221387e-04,3.661993e-04,3.071989e-04,2.450992e-04,1.791676e-04, & - &1.076696e-04,1.746496e-01,5.245928e-04,4.936626e-04,4.438460e-04, & - &3.889311e-04,3.298318e-04,2.660091e-04,1.980543e-04,1.235973e-04, & - &1.871266e-01,5.422179e-04,5.182542e-04,4.715616e-04,4.177776e-04, & - &3.576143e-04,2.922143e-04,2.216009e-04,1.430641e-04,2.024776e-01, & - &4.791279e-04,4.335068e-04,3.803811e-04,3.243749e-04,2.667225e-04, & - &2.075695e-04,1.463286e-04,8.092051e-05,1.503358e-01,4.881978e-04, & - &4.463662e-04,3.934423e-04,3.374846e-04,2.794763e-04,2.194800e-04, & - &1.569223e-04,8.997365e-05,1.594041e-01,4.998927e-04,4.620613e-04, & - &4.100076e-04,3.545333e-04,2.964089e-04,2.354550e-04,1.708686e-04, & - &1.016584e-04,1.704401e-01,5.148989e-04,4.818573e-04,4.316671e-04, & - &3.770437e-04,3.184413e-04,2.555943e-04,1.887152e-04,1.160655e-04, & - &1.837809e-01,5.332653e-04,5.064327e-04,4.591023e-04,4.051389e-04, & - &3.455537e-04,2.806063e-04,2.107215e-04,1.334642e-04,1.998427e-01/ - data absa(1:270, 3) / & - &1.111200e-02,9.898307e-03,8.713432e-03,7.548621e-03,6.398889e-03, & - &5.251897e-03,4.113012e-03,2.981311e-03,3.413072e-03,1.163336e-02, & - &1.044308e-02,9.293795e-03,8.154062e-03,7.021808e-03,5.883307e-03, & - &4.741991e-03,3.602498e-03,4.299595e-03,1.222079e-02,1.106713e-02, & - &9.970411e-03,8.866942e-03,7.755476e-03,6.628979e-03,5.488649e-03, & - &4.344258e-03,5.340023e-03,1.287557e-02,1.178134e-02,1.074313e-02, & - &9.683306e-03,8.598592e-03,7.487632e-03,6.359528e-03,5.217457e-03, & - &6.543505e-03,1.359437e-02,1.258438e-02,1.161589e-02,1.060207e-02, & - &9.554425e-03,8.464918e-03,7.354175e-03,6.228379e-03,7.913168e-03, & - &1.088465e-02,9.685940e-03,8.510649e-03,7.351993e-03,6.202119e-03, & - &5.049885e-03,3.905077e-03,2.752791e-03,3.571303e-03,1.136696e-02, & - &1.018605e-02,9.038665e-03,7.901430e-03,6.758009e-03,5.617216e-03, & - &4.469395e-03,3.310010e-03,4.491469e-03,1.190620e-02,1.075921e-02, & - &9.655711e-03,8.547667e-03,7.421941e-03,6.293121e-03,5.144506e-03, & - &3.983249e-03,5.574943e-03,1.250650e-02,1.141594e-02,1.036750e-02, & - &9.290132e-03,8.194777e-03,7.078121e-03,5.935986e-03,4.777917e-03, & - &6.827967e-03,1.316971e-02,1.215962e-02,1.117547e-02,1.013612e-02, & - &9.074279e-03,7.978775e-03,6.847261e-03,5.704736e-03,8.253277e-03, & - &1.055153e-02,9.371054e-03,8.214716e-03,7.078003e-03,5.942973e-03, & - &4.797399e-03,3.633513e-03,2.461057e-03,4.404748e-03,1.100772e-02, & - &9.840813e-03,8.705297e-03,7.576176e-03,6.433803e-03,5.284477e-03, & - &4.114866e-03,2.935242e-03,5.487118e-03,1.151210e-02,1.037073e-02, & - &9.263691e-03,8.147072e-03,7.011794e-03,5.870936e-03,4.699666e-03, & - &3.515683e-03,6.775673e-03,1.206070e-02,1.096406e-02,9.901109e-03, & - &8.806959e-03,7.693158e-03,6.562540e-03,5.393689e-03,4.212517e-03, & - &8.274125e-03,1.266031e-02,1.163224e-02,1.062576e-02,9.563623e-03, & - &8.477979e-03,7.362291e-03,6.203177e-03,5.037212e-03,9.989052e-03, & - &1.016472e-02,9.009821e-03,7.882498e-03,6.771577e-03,5.661474e-03, & - &4.544312e-03,3.392120e-03,2.196343e-03,6.173505e-03,1.060191e-02, & - &9.455700e-03,8.342901e-03,7.236850e-03,6.119336e-03,4.979821e-03, & - &3.795263e-03,2.591589e-03,7.586596e-03,1.108504e-02,9.959373e-03, & - &8.868482e-03,7.767679e-03,6.639310e-03,5.484283e-03,4.289066e-03, & - &3.081295e-03,9.267603e-03,1.160890e-02,1.051986e-02,9.460613e-03, & - &8.362777e-03,7.238543e-03,6.081106e-03,4.884213e-03,3.677209e-03, & - &1.123539e-02,1.216832e-02,1.113828e-02,1.011503e-02,9.035259e-03, & - &7.930545e-03,6.780747e-03,5.588772e-03,4.393338e-03,1.349926e-02, & - &9.722516e-03,8.603001e-03,7.513492e-03,6.434870e-03,5.362859e-03, & - &4.283110e-03,3.170411e-03,1.982650e-03,8.996966e-03,1.014547e-02, & - &9.029993e-03,7.947201e-03,6.873898e-03,5.790762e-03,4.684023e-03, & - &3.528161e-03,2.307373e-03,1.088237e-02,1.061237e-02,9.514317e-03, & - &8.450889e-03,7.380288e-03,6.278968e-03,5.145431e-03,3.948748e-03, & - &2.717476e-03,1.315720e-02,1.112089e-02,1.005565e-02,9.019128e-03, & - &7.945457e-03,6.836080e-03,5.673419e-03,4.455084e-03,3.221449e-03, & - &1.584209e-02,1.166206e-02,1.064847e-02,9.643494e-03,8.571060e-03, & - &7.460381e-03,6.281006e-03,5.063198e-03,3.834293e-03,1.893774e-02, & - &9.209746e-03,8.135282e-03,7.090289e-03,6.054559e-03,5.026953e-03, & - &3.993437e-03,2.934393e-03,1.798819e-03,1.295483e-02,9.599938e-03, & - &8.528322e-03,7.487934e-03,6.455882e-03,5.418403e-03,4.361660e-03, & - &3.255798e-03,2.064150e-03,1.549092e-02,1.004102e-02,8.983859e-03, & - &7.958963e-03,6.929533e-03,5.875765e-03,4.785940e-03,3.636647e-03, & - &2.398300e-03,1.854368e-02,1.052821e-02,9.499419e-03,8.496710e-03, & - &7.467034e-03,6.395229e-03,5.274505e-03,4.075328e-03,2.819359e-03, & - &2.218471e-02,1.105224e-02,1.006814e-02,9.096118e-03,8.059696e-03, & - &6.981059e-03,5.827759e-03,4.593658e-03,3.337908e-03,2.644375e-02/ - data absa(271:585, 3) / & - &8.662726e-03,7.638939e-03,6.646906e-03,5.661174e-03,4.679362e-03, & - &3.698369e-03,2.698930e-03,1.626154e-03,1.984520e-02,9.021303e-03, & - &8.000869e-03,7.008700e-03,6.022157e-03,5.035232e-03,4.035588e-03, & - &2.987043e-03,1.861509e-03,2.365771e-02,9.433767e-03,8.423966e-03, & - &7.442183e-03,6.459205e-03,5.461666e-03,4.424660e-03,3.330616e-03, & - &2.143323e-03,2.817388e-02,9.892351e-03,8.907651e-03,7.944547e-03, & - &6.965099e-03,5.945452e-03,4.876543e-03,3.735626e-03,2.488984e-03, & - &3.351251e-02,1.039541e-02,9.449590e-03,8.513778e-03,7.530347e-03, & - &6.495525e-03,5.394491e-03,4.199647e-03,2.922003e-03,3.980775e-02, & - &8.113069e-03,7.144524e-03,6.208030e-03,5.273660e-03,4.342818e-03, & - &3.413628e-03,2.472382e-03,1.468821e-03,3.690377e-02,8.441786e-03, & - &7.475339e-03,6.534824e-03,5.597921e-03,4.661849e-03,3.718425e-03, & - &2.734475e-03,1.674752e-03,4.386401e-02,8.828835e-03,7.869025e-03, & - &6.934105e-03,5.998168e-03,5.053972e-03,4.079739e-03,3.042611e-03, & - &1.926958e-03,5.217333e-02,9.271452e-03,8.331135e-03,7.408759e-03, & - &6.475035e-03,5.511209e-03,4.495658e-03,3.413326e-03,2.227339e-03, & - &6.190413e-02,9.755600e-03,8.848547e-03,7.947617e-03,7.011225e-03, & - &6.029536e-03,4.980330e-03,3.842350e-03,2.589056e-03,7.329196e-02, & - &7.505266e-03,6.602571e-03,5.729999e-03,4.857074e-03,3.987428e-03, & - &3.117781e-03,2.240297e-03,1.315950e-03,1.327015e-01,7.799918e-03, & - &6.897477e-03,6.019691e-03,5.143841e-03,4.266972e-03,3.386117e-03, & - &2.476031e-03,1.494287e-03,1.564715e-01,8.154970e-03,7.257998e-03, & - &6.381779e-03,5.503390e-03,4.618338e-03,3.715387e-03,2.752323e-03, & - &1.716598e-03,1.851516e-01,8.571870e-03,7.689055e-03,6.819606e-03, & - &5.940676e-03,5.042154e-03,4.098590e-03,3.085815e-03,1.984672e-03, & - &2.190738e-01,9.035170e-03,8.180189e-03,7.326720e-03,6.448502e-03, & - &5.528323e-03,4.543458e-03,3.477920e-03,2.304143e-03,2.586636e-01, & - &6.866650e-03,6.038737e-03,5.236608e-03,4.433914e-03,3.632678e-03, & - &2.831473e-03,2.022310e-03,1.176730e-03,5.662142e-01,7.131202e-03, & - &6.302355e-03,5.495907e-03,4.689094e-03,3.879940e-03,3.068100e-03, & - &2.232062e-03,1.335140e-03,6.583737e-01,7.456403e-03,6.632686e-03, & - &5.824939e-03,5.013514e-03,4.196994e-03,3.366887e-03,2.483038e-03, & - &1.531301e-03,7.716118e-01,7.844741e-03,7.032517e-03,6.228464e-03, & - &5.415520e-03,4.588992e-03,3.718557e-03,2.785549e-03,1.771209e-03, & - &9.070435e-01,8.284042e-03,7.496048e-03,6.703935e-03,5.890786e-03, & - &5.039873e-03,4.131706e-03,3.144234e-03,2.059409e-03,1.066262e+00, & - &6.326103e-03,5.572581e-03,4.840384e-03,4.106125e-03,3.372684e-03, & - &2.637448e-03,1.889027e-03,1.103220e-03,9.633289e-01,6.584578e-03, & - &5.833031e-03,5.096398e-03,4.358292e-03,3.617477e-03,2.869643e-03, & - &2.091964e-03,1.256946e-03,1.101200e+00,6.906227e-03,6.160875e-03, & - &5.424224e-03,4.682096e-03,3.932523e-03,3.161434e-03,2.336522e-03, & - &1.446926e-03,1.270069e+00,7.289634e-03,6.558267e-03,5.826142e-03, & - &5.081673e-03,4.318164e-03,3.505597e-03,2.634475e-03,1.679603e-03, & - &1.473888e+00,7.719672e-03,7.014357e-03,6.293678e-03,5.547522e-03, & - &4.759764e-03,3.910995e-03,2.985186e-03,1.960372e-03,1.716321e+00, & - &5.829899e-03,5.143367e-03,4.474181e-03,3.802482e-03,3.130683e-03, & - &2.454631e-03,1.761080e-03,1.030301e-03,1.226939e+00,6.086158e-03, & - &5.402491e-03,4.728665e-03,4.052615e-03,3.373543e-03,2.680985e-03, & - &1.955139e-03,1.177420e-03,1.381628e+00,6.406603e-03,5.729287e-03, & - &5.055595e-03,4.374817e-03,3.684273e-03,2.961494e-03,2.193218e-03, & - &1.360645e-03,1.573433e+00,6.779611e-03,6.118383e-03,5.449312e-03, & - &4.765797e-03,4.056024e-03,3.297358e-03,2.482239e-03,1.584537e-03, & - &1.804754e+00,7.198159e-03,6.564276e-03,5.907362e-03,5.221139e-03, & - &4.487764e-03,3.690107e-03,2.823450e-03,1.857297e-03,2.082647e+00, & - &5.452841e-03,4.817597e-03,4.195463e-03,3.571137e-03,2.945659e-03, & - &2.311704e-03,1.657769e-03,9.679680e-04,1.317965e+00,5.715600e-03, & - &5.082091e-03,4.454716e-03,3.823881e-03,3.188193e-03,2.532660e-03, & - &1.844704e-03,1.108297e-03,1.456622e+00,6.036701e-03,5.409007e-03, & - &4.781017e-03,4.144543e-03,3.493582e-03,2.804405e-03,2.076665e-03, & - &1.283902e-03,1.630048e+00,6.406129e-03,5.794525e-03,5.170255e-03, & - &4.529108e-03,3.853827e-03,3.131113e-03,2.354518e-03,1.498705e-03, & - &1.842789e+00,6.821474e-03,6.237132e-03,5.622742e-03,4.974315e-03, & - &4.273564e-03,3.511163e-03,2.684713e-03,1.761842e-03,2.100063e+00/ - data absa(1:270, 4) / & - &6.578204e-02,5.817139e-02,5.270765e-02,4.860030e-02,4.552487e-02, & - &4.362570e-02,4.285527e-02,4.376758e-02,5.465787e-02,7.580157e-02, & - &6.741261e-02,6.203155e-02,5.849528e-02,5.635982e-02,5.566374e-02, & - &5.636876e-02,5.921441e-02,7.260741e-02,8.601060e-02,7.702465e-02, & - &7.204669e-02,6.941821e-02,6.876010e-02,6.969364e-02,7.247914e-02, & - &7.785898e-02,9.405350e-02,9.630261e-02,8.685111e-02,8.266701e-02, & - &8.150201e-02,8.268282e-02,8.582167e-02,9.131283e-02,9.974958e-02, & - &1.191645e-01,1.065775e-01,9.679443e-02,9.379406e-02,9.463743e-02, & - &9.808297e-02,1.040893e-01,1.128787e-01,1.250459e-01,1.480155e-01, & - &6.558032e-02,5.793721e-02,5.220209e-02,4.775334e-02,4.422801e-02, & - &4.177632e-02,4.029552e-02,4.039116e-02,5.774707e-02,7.580097e-02, & - &6.742343e-02,6.180247e-02,5.779392e-02,5.517843e-02,5.367810e-02, & - &5.347093e-02,5.519555e-02,7.584950e-02,8.646508e-02,7.747775e-02, & - &7.224403e-02,6.909730e-02,6.773548e-02,6.766180e-02,6.932219e-02, & - &7.323907e-02,9.744396e-02,9.738036e-02,8.788734e-02,8.335488e-02, & - &8.163365e-02,8.188698e-02,8.386739e-02,8.799803e-02,9.468226e-02, & - &1.227029e-01,1.083677e-01,9.853830e-02,9.508818e-02,9.528679e-02, & - &9.766673e-02,1.023260e-01,1.095800e-01,1.196542e-01,1.517412e-01, & - &6.418970e-02,5.653588e-02,5.040179e-02,4.527702e-02,4.100753e-02, & - &3.771921e-02,3.564928e-02,3.481548e-02,7.405414e-02,7.404730e-02, & - &6.563497e-02,5.949778e-02,5.482085e-02,5.137935e-02,4.900175e-02, & - &4.795494e-02,4.838481e-02,9.464267e-02,8.461414e-02,7.561628e-02, & - &6.986069e-02,6.602150e-02,6.363763e-02,6.246770e-02,6.294090e-02, & - &6.519359e-02,1.185620e-01,9.585746e-02,8.638391e-02,8.124059e-02, & - &7.859055e-02,7.765661e-02,7.821137e-02,8.080883e-02,8.543983e-02, & - &1.459293e-01,1.074893e-01,9.763865e-02,9.344985e-02,9.240914e-02, & - &9.341132e-02,9.637610e-02,1.016628e-01,1.092283e-01,1.767996e-01, & - &6.371854e-02,5.595455e-02,4.933688e-02,4.346278e-02,3.834997e-02, & - &3.395415e-02,3.083569e-02,2.934438e-02,1.160432e-01,7.293147e-02, & - &6.439809e-02,5.762132e-02,5.203342e-02,4.745685e-02,4.396312e-02, & - &4.206355e-02,4.148253e-02,1.450827e-01,8.305529e-02,7.387192e-02, & - &6.729665e-02,6.235974e-02,5.880896e-02,5.659867e-02,5.602885e-02, & - &5.684204e-02,1.779185e-01,9.402257e-02,8.434812e-02,7.827805e-02, & - &7.451436e-02,7.228130e-02,7.169437e-02,7.289379e-02,7.567620e-02, & - &2.143787e-01,1.057073e-01,9.567510e-02,9.060590e-02,8.829559e-02, & - &8.775890e-02,8.927190e-02,9.280467e-02,9.808353e-02,2.542867e-01, & - &6.510942e-02,5.705176e-02,4.983797e-02,4.319860e-02,3.709740e-02, & - &3.158617e-02,2.714573e-02,2.466301e-02,1.916961e-01,7.357898e-02, & - &6.476375e-02,5.731606e-02,5.073074e-02,4.498507e-02,4.019226e-02, & - &3.686084e-02,3.544917e-02,2.392120e-01,8.309408e-02,7.357199e-02, & - &6.611121e-02,5.995980e-02,5.507293e-02,5.140059e-02,4.960923e-02, & - &4.935445e-02,2.917178e-01,9.351782e-02,8.345454e-02,7.631207e-02, & - &7.112189e-02,6.738874e-02,6.544659e-02,6.541159e-02,6.671989e-02, & - &3.488212e-01,1.048388e-01,9.436720e-02,8.798054e-02,8.422329e-02, & - &8.214810e-02,8.235393e-02,8.428954e-02,8.773851e-02,4.102950e-01, & - &6.768439e-02,5.923294e-02,5.137919e-02,4.395218e-02,3.687574e-02, & - &3.027577e-02,2.447407e-02,2.047851e-02,3.090947e-01,7.564839e-02, & - &6.640951e-02,5.820972e-02,5.062143e-02,4.368033e-02,3.749248e-02, & - &3.259324e-02,2.981341e-02,3.893423e-01,8.461943e-02,7.464458e-02, & - &6.626420e-02,5.887069e-02,5.248667e-02,4.721086e-02,4.356832e-02, & - &4.224116e-02,4.786727e-01,9.453599e-02,8.394535e-02,7.567929e-02, & - &6.892185e-02,6.355013e-02,5.966021e-02,5.789017e-02,5.800593e-02, & - &5.754688e-01,1.053827e-01,9.433175e-02,8.652387e-02,8.099716e-02, & - &7.701372e-02,7.514561e-02,7.555486e-02,7.739931e-02,6.786108e-01/ - data absa(271:585, 4) / & - &7.185453e-02,6.287571e-02,5.423694e-02,4.593739e-02,3.791634e-02, & - &3.018543e-02,2.305070e-02,1.752312e-02,5.321013e-01,7.944097e-02, & - &6.961005e-02,6.054633e-02,5.197587e-02,4.382774e-02,3.622799e-02, & - &2.979876e-02,2.518051e-02,6.775699e-01,8.807007e-02,7.746214e-02, & - &6.810128e-02,5.944836e-02,5.152737e-02,4.464933e-02,3.919110e-02, & - &3.597300e-02,8.427547e-01,9.777062e-02,8.644734e-02,7.698524e-02, & - &6.862238e-02,6.147407e-02,5.565027e-02,5.165983e-02,5.021788e-02, & - &1.024665e+00,1.084270e-01,9.654459e-02,8.726430e-02,7.974546e-02, & - &7.377008e-02,6.955613e-02,6.764612e-02,6.802765e-02,1.219525e+00, & - &7.762969e-02,6.792992e-02,5.838916e-02,4.913809e-02,4.008485e-02, & - &3.122199e-02,2.278952e-02,1.568979e-02,1.102598e+00,8.510222e-02, & - &7.449236e-02,6.444930e-02,5.478487e-02,4.540262e-02,3.641149e-02, & - &2.836453e-02,2.197362e-02,1.423740e+00,9.369440e-02,8.223727e-02, & - &7.174735e-02,6.179009e-02,5.235033e-02,4.370662e-02,3.646393e-02, & - &3.106861e-02,1.793240e+00,1.033533e-01,9.108748e-02,8.031177e-02, & - &7.035388e-02,6.132879e-02,5.355682e-02,4.737911e-02,4.357485e-02, & - &2.207119e+00,1.141877e-01,1.012246e-01,9.038012e-02,8.088585e-02, & - &7.268795e-02,6.614121e-02,6.165527e-02,5.986489e-02,2.657825e+00, & - &8.401158e-02,7.351241e-02,6.306458e-02,5.285846e-02,4.277492e-02, & - &3.285297e-02,2.322895e-02,1.461664e-02,4.281786e+00,9.130806e-02, & - &7.989823e-02,6.886618e-02,5.811958e-02,4.760399e-02,3.735215e-02, & - &2.780403e-02,1.973962e-02,5.627482e+00,9.981599e-02,8.748697e-02, & - &7.589967e-02,6.473287e-02,5.394197e-02,4.369709e-02,3.471662e-02, & - &2.735996e-02,7.199266e+00,1.094271e-01,9.623291e-02,8.421400e-02, & - &7.282770e-02,6.209785e-02,5.242592e-02,4.427361e-02,3.810908e-02, & - &8.983301e+00,1.202907e-01,1.062723e-01,9.398904e-02,8.269644e-02, & - &7.253421e-02,6.385768e-02,5.697685e-02,5.252004e-02,1.095802e+01, & - &9.148721e-02,8.005388e-02,6.862602e-02,5.738043e-02,4.623750e-02, & - &3.520773e-02,2.444026e-02,1.445567e-02,1.868401e+01,9.867142e-02, & - &8.633716e-02,7.425325e-02,6.240204e-02,5.074510e-02,3.927760e-02, & - &2.838111e-02,1.872395e-02,2.505419e+01,1.071754e-01,9.386651e-02, & - &8.114958e-02,6.878044e-02,5.668452e-02,4.499782e-02,3.442550e-02, & - &2.529476e-02,3.260857e+01,1.168882e-01,1.026454e-01,8.937389e-02, & - &7.659902e-02,6.430139e-02,5.297925e-02,4.298599e-02,3.474819e-02, & - &4.129169e+01,1.279120e-01,1.127606e-01,9.906423e-02,8.613996e-02, & - &7.418752e-02,6.352342e-02,5.453291e-02,4.766000e-02,5.101561e+01, & - &1.023779e-01,8.958382e-02,7.681963e-02,6.424253e-02,5.175303e-02, & - &3.938842e-02,2.735709e-02,1.609732e-02,3.270245e+01,1.100818e-01, & - &9.632402e-02,8.287343e-02,6.963614e-02,5.657447e-02,4.375029e-02, & - &3.157594e-02,2.055147e-02,4.410218e+01,1.191302e-01,1.043794e-01, & - &9.023137e-02,7.640231e-02,6.286502e-02,4.984999e-02,3.793423e-02, & - &2.736130e-02,5.764812e+01,1.294942e-01,1.137506e-01,9.898967e-02, & - &8.471949e-02,7.097464e-02,5.829078e-02,4.682443e-02,3.710115e-02, & - &7.321178e+01,1.413246e-01,1.246273e-01,1.093881e-01,9.493183e-02, & - &8.149572e-02,6.935268e-02,5.880424e-02,5.034789e-02,9.062722e+01, & - &1.138309e-01,9.959950e-02,8.543943e-02,7.145467e-02,5.755959e-02, & - &4.381263e-02,3.046435e-02,1.787042e-02,4.282969e+01,1.221775e-01, & - &1.069196e-01,9.201457e-02,7.730955e-02,6.276102e-02,4.854992e-02, & - &3.502983e-02,2.255987e-02,5.797749e+01,1.319615e-01,1.156590e-01, & - &9.997803e-02,8.460793e-02,6.954566e-02,5.517226e-02,4.175198e-02, & - &2.964117e-02,7.595358e+01,1.433293e-01,1.259410e-01,1.095503e-01, & - &9.365205e-02,7.838517e-02,6.416164e-02,5.110205e-02,3.973260e-02, & - &9.664208e+01,1.562975e-01,1.378576e-01,1.208813e-01,1.047257e-01, & - &8.965635e-02,7.592159e-02,6.360859e-02,5.336142e-02,1.197719e+02, & - &1.262567e-01,1.104759e-01,9.480494e-02,7.928903e-02,6.386556e-02, & - &4.865284e-02,3.387087e-02,1.980992e-02,4.523100e+01,1.357007e-01, & - &1.187816e-01,1.022374e-01,8.588699e-02,6.971165e-02,5.397048e-02, & - &3.889635e-02,2.480524e-02,6.135177e+01,1.469379e-01,1.288178e-01, & - &1.113352e-01,9.415723e-02,7.735550e-02,6.133647e-02,4.613648e-02, & - &3.224572e-02,8.048458e+01,1.600467e-01,1.406613e-01,1.222909e-01, & - &1.044041e-01,8.729008e-02,7.117344e-02,5.616280e-02,4.276470e-02, & - &1.024679e+02,1.749880e-01,1.543444e-01,1.351869e-01,1.169158e-01, & - &9.978191e-02,8.394174e-02,6.942724e-02,5.688623e-02,1.270700e+02/ - -! the array selfref contains the coefficient of the water vapor -! self-continuum (including the energy term). the first index -! refers to temperature in 7.2 degree increments. for instance, -! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, -! etc. the second index runs over the g-channel (1 to NG13=4). - - data selfref(:, 1) / & - &9.671742e-03,8.355123e-03,7.217826e-03,6.235422e-03,5.386806e-03, & - &4.653743e-03,4.020489e-03,3.473450e-03,3.000878e-03,2.592639e-03/ - data selfref(:, 2) / & - &7.225591e-03,6.319626e-03,5.528513e-03,4.837524e-03,4.233852e-03, & - &3.706341e-03,3.245279e-03,2.842200e-03,2.489737e-03,2.181457e-03/ - data selfref(:, 3) / & - &5.668563e-03,5.043213e-03,4.489408e-03,3.998777e-03,3.563941e-03, & - &3.178403e-03,2.836429e-03,2.532960e-03,2.263542e-03,2.024239e-03/ - data selfref(:, 4) / & - &4.359503e-03,4.243629e-03,4.133381e-03,4.028614e-03,3.929205e-03, & - &3.835024e-03,3.745975e-03,3.661956e-03,3.582888e-03,3.508699e-03/ - - data fracrefa(:,:) / & - & 0.5071610212, 0.3313080966, 0.1534516662, 0.0080804899, & - & 0.5014489889, 0.3341985047, 0.1559497267, 0.0084044300, & - & 0.4989780188, 0.3332740068, 0.1588685066, 0.0088797100, & - & 0.4957039952, 0.3335204124, 0.1613266319, 0.0094510000, & - & 0.4918209910, 0.3343736231, 0.1638295650, 0.0099777104, & - & 0.4868909717, 0.3355847895, 0.1669453382, 0.0105796298, & - & 0.4801110029, 0.3373543024, 0.1710062623, 0.0115293497, & - & 0.4613200426, 0.3464493155, 0.1796631813, 0.0125675797, & - & 0.4522779882, 0.3569740057, 0.1805745065, 0.0101753296 / - -!........................................! - end module module_radlw_kgb13 ! -!========================================! - - - -!========================================! - module module_radlw_kgb14 ! -!........................................! -! - use machine, only : kind_phys - use module_radlw_parameters, only : NG14 -! - implicit none -! - private -! - integer, public :: MSA14, MSB14, MSF14 - parameter (MSA14=65, MSB14=235, MSF14=10) - - real (kind=kind_phys), public :: & - & absa(MSA14,NG14), absb(MSB14,NG14), selfref(MSF14,NG14), & - & fracrefa(NG14), fracrefb(NG14) - -! the array absa(65,NG14) = ka(5,13,NG14) contains absorption coefs -! at the NG14=2 chosen g-values for a range of pressure levels> ~100mb -! and temperatures. the first index in the array, jt, which runs from -! 1 to 5, corresponds to different temperatures. more specifically, -! jt = 1-5 means that the data are for the corresponding temperature of -! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the -! second index, jp, runs from 1 to 13 and refers to the corresponding -! pressure level in pref (e.g. jp = 1 is for a pressure of 1053.63 mb). -! the third index, ig, goes from 1 to NG14=2, and tells us which -! g-interval the absorption coefficients are for. - - data absa(:,1) / & - &3.675372e+01,3.685447e+01,3.700121e+01,3.718361e+01,3.740237e+01, & - &3.292726e+01,3.305658e+01,3.323782e+01,3.346041e+01,3.372661e+01, & - &2.919292e+01,2.934315e+01,2.954436e+01,2.980143e+01,3.010077e+01, & - &2.565299e+01,2.581452e+01,2.603922e+01,2.631744e+01,2.664970e+01, & - &2.238014e+01,2.255093e+01,2.278832e+01,2.309095e+01,2.344968e+01, & - &1.937813e+01,1.955432e+01,1.980391e+01,2.011883e+01,2.049559e+01, & - &1.668624e+01,1.686096e+01,1.711391e+01,1.743741e+01,1.782612e+01, & - &1.430988e+01,1.448124e+01,1.473333e+01,1.505847e+01,1.545135e+01, & - &1.223677e+01,1.240074e+01,1.264696e+01,1.296867e+01,1.335383e+01, & - &1.045750e+01,1.061721e+01,1.085949e+01,1.117323e+01,1.151542e+01, & - &8.996191e+00,9.187340e+00,9.450043e+00,9.734804e+00,1.001895e+01, & - &7.760931e+00,7.970020e+00,8.206289e+00,8.441770e+00,8.683336e+00, & - &6.687234e+00,6.879838e+00,7.074225e+00,7.274055e+00,7.479917e+00/ - data absa(:,2) / & - &7.156276e+02,7.132246e+02,7.099685e+02,7.057861e+02,7.008322e+02, & - &7.798042e+02,7.770245e+02,7.732206e+02,7.685164e+02,7.628334e+02, & - &8.424970e+02,8.394714e+02,8.354156e+02,8.302191e+02,8.241526e+02, & - &9.019229e+02,8.987405e+02,8.943992e+02,8.889943e+02,8.824758e+02, & - &9.568210e+02,9.535380e+02,9.490411e+02,9.433314e+02,9.365009e+02, & - &1.007158e+03,1.003820e+03,9.991945e+02,9.933596e+02,9.863113e+02, & - &1.052341e+03,1.049056e+03,1.044354e+03,1.038451e+03,1.031267e+03, & - &1.092260e+03,1.088991e+03,1.084341e+03,1.078426e+03,1.071271e+03, & - &1.127103e+03,1.123902e+03,1.119352e+03,1.113552e+03,1.106576e+03, & - &1.156981e+03,1.153898e+03,1.149432e+03,1.143725e+03,1.137432e+03, & - &1.181414e+03,1.177778e+03,1.172939e+03,1.167631e+03,1.162337e+03, & - &1.202017e+03,1.198084e+03,1.193668e+03,1.189153e+03,1.184471e+03, & - &1.219951e+03,1.216223e+03,1.212446e+03,1.208480e+03,1.204334e+03/ - -! the array absb(235,NG14) = kb(5,13:59,NG14) contains absorption coefs -! at the NG14=2 chosen g-values for a range of pressure levels < ~100mb -! and temperatures. the first index in the array, jt, which runs from -! 1 to 5, corresponds to different temperatures. more specifically, -! jt = 1-5 means that the data are for the corresponding temperature of -! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the -! second index, jp, runs from 13 to 59 and refers to the jpth reference -! pressure level (see taumol.f for the value of these pressure levels -! in mb). the third index, ig, goes from 1 to NG14=2, and tells us -! which g-interval the absorption coefficients are for. - - data absb(:,1) / & - &6.687002e+00,6.879877e+00,7.074576e+00,7.274072e+00,7.480115e+00, & - &5.757919e+00,5.914829e+00,6.077681e+00,6.246683e+00,6.423878e+00, & - &4.931959e+00,5.060997e+00,5.197669e+00,5.342565e+00,5.497158e+00, & - &4.207409e+00,4.315813e+00,4.432730e+00,4.559036e+00,4.696935e+00, & - &3.578375e+00,3.671292e+00,3.772969e+00,3.884776e+00,4.008567e+00, & - &3.030306e+00,3.111157e+00,3.200777e+00,3.301325e+00,3.415415e+00, & - &2.556621e+00,2.626790e+00,2.706885e+00,2.799098e+00,2.906690e+00, & - &2.151263e+00,2.213687e+00,2.286883e+00,2.373512e+00,2.476515e+00, & - &1.807552e+00,1.864154e+00,1.932401e+00,2.015021e+00,2.113986e+00, & - &1.521288e+00,1.574671e+00,1.640378e+00,1.720784e+00,1.814548e+00, & - &1.282126e+00,1.333779e+00,1.398098e+00,1.474897e+00,1.560683e+00, & - &1.082368e+00,1.133140e+00,1.195850e+00,1.267666e+00,1.344677e+00, & - &9.165391e-01,9.665744e-01,1.026033e+00,1.091275e+00,1.161062e+00, & - &7.798656e-01,8.283033e-01,8.829277e-01,9.418513e-01,1.005004e+00, & - &6.666913e-01,7.117754e-01,7.608725e-01,8.142303e-01,8.716204e-01, & - &5.717680e-01,6.125550e-01,6.569776e-01,7.054476e-01,7.583979e-01, & - &4.916636e-01,5.285704e-01,5.690064e-01,6.135232e-01,6.630598e-01, & - &4.238704e-01,4.574634e-01,4.945496e-01,5.360917e-01,5.828142e-01, & - &3.667552e-01,3.975521e-01,4.320746e-01,4.711806e-01,5.157632e-01, & - &3.186423e-01,3.472241e-01,3.797450e-01,4.169836e-01,4.599181e-01, & - &2.782022e-01,3.050733e-01,3.360031e-01,3.718310e-01,4.137139e-01, & - &2.434768e-01,2.688652e-01,2.984147e-01,3.331153e-01,3.740458e-01, & - &2.122607e-01,2.361016e-01,2.641392e-01,2.975099e-01,3.371553e-01, & - &1.838186e-01,2.059547e-01,2.322212e-01,2.638391e-01,3.015926e-01, & - &1.570356e-01,1.770474e-01,2.011088e-01,2.303596e-01,2.655161e-01, & - &1.342225e-01,1.523377e-01,1.743687e-01,2.014076e-01,2.341203e-01, & - &1.149057e-01,1.313136e-01,1.515318e-01,1.765640e-01,2.070675e-01, & - &9.718633e-02,1.117608e-01,1.299047e-01,1.525812e-01,1.804701e-01, & - &8.209125e-02,9.498841e-02,1.111955e-01,1.316344e-01,1.570352e-01, & - &6.930251e-02,8.075830e-02,9.520564e-02,1.136019e-01,1.367190e-01, & - &5.796601e-02,6.801980e-02,8.075321e-02,9.708949e-02,1.177854e-01, & - &4.823224e-02,5.698118e-02,6.815393e-02,8.251359e-02,1.009142e-01, & - &4.007948e-02,4.766385e-02,5.742772e-02,7.007185e-02,8.636899e-02, & - &3.315600e-02,3.963894e-02,4.809362e-02,5.915080e-02,7.354915e-02, & - &2.715857e-02,3.263298e-02,3.983773e-02,4.934230e-02,6.189341e-02, & - &2.220656e-02,2.680359e-02,3.290839e-02,4.103503e-02,5.192255e-02, & - &1.812507e-02,2.198077e-02,2.711286e-02,3.402726e-02,4.339649e-02, & - &1.482653e-02,1.807883e-02,2.241142e-02,2.830755e-02,3.638313e-02, & - &1.210948e-02,1.487515e-02,1.853783e-02,2.356062e-02,3.050767e-02, & - &9.856701e-03,1.220287e-02,1.531200e-02,1.957006e-02,2.552074e-02, & - &7.991957e-03,9.968713e-03,1.261435e-02,1.622317e-02,2.129148e-02, & - &6.500551e-03,8.170364e-03,1.044326e-02,1.353594e-02,1.788111e-02, & - &5.288695e-03,6.694880e-03,8.639012e-03,1.131094e-02,1.505651e-02, & - &4.291160e-03,5.469921e-03,7.123749e-03,9.420203e-03,1.266247e-02, & - &3.470868e-03,4.454937e-03,5.851143e-03,7.818259e-03,1.062385e-02, & - &2.811362e-03,3.632431e-03,4.810158e-03,6.494720e-03,8.929662e-03, & - &2.373042e-03,3.105640e-03,4.164648e-03,5.710333e-03,7.953564e-03/ - data absb(:,2) / & - &1.219980e+03,1.216240e+03,1.212412e+03,1.208477e+03,1.204364e+03, & - &1.235393e+03,1.232292e+03,1.228923e+03,1.225397e+03,1.221732e+03, & - &1.249071e+03,1.246293e+03,1.243382e+03,1.240248e+03,1.236897e+03, & - &1.261014e+03,1.258565e+03,1.255958e+03,1.253085e+03,1.249992e+03, & - &1.271368e+03,1.269142e+03,1.266747e+03,1.264152e+03,1.261243e+03, & - &1.280369e+03,1.278351e+03,1.276113e+03,1.273659e+03,1.270895e+03, & - &1.288134e+03,1.286099e+03,1.284123e+03,1.281844e+03,1.279140e+03, & - &1.294742e+03,1.292857e+03,1.290975e+03,1.288740e+03,1.286103e+03, & - &1.300277e+03,1.298444e+03,1.296694e+03,1.294482e+03,1.291943e+03, & - &1.304847e+03,1.303090e+03,1.301339e+03,1.299192e+03,1.296650e+03, & - &1.308605e+03,1.307031e+03,1.305176e+03,1.303044e+03,1.300601e+03, & - &1.311798e+03,1.310187e+03,1.308303e+03,1.306251e+03,1.303979e+03, & - &1.314361e+03,1.312746e+03,1.311002e+03,1.308979e+03,1.306767e+03, & - &1.316431e+03,1.314923e+03,1.313099e+03,1.311269e+03,1.309038e+03, & - &1.318194e+03,1.316597e+03,1.314895e+03,1.313030e+03,1.310963e+03, & - &1.319459e+03,1.318069e+03,1.316376e+03,1.314607e+03,1.312528e+03, & - &1.320719e+03,1.319238e+03,1.317576e+03,1.315835e+03,1.313765e+03, & - &1.321537e+03,1.320187e+03,1.318541e+03,1.316804e+03,1.314758e+03, & - &1.322315e+03,1.320973e+03,1.319404e+03,1.317571e+03,1.315554e+03, & - &1.322905e+03,1.321565e+03,1.319942e+03,1.318134e+03,1.316073e+03, & - &1.323384e+03,1.321931e+03,1.320349e+03,1.318535e+03,1.316423e+03, & - &1.323744e+03,1.322392e+03,1.320755e+03,1.318910e+03,1.316722e+03, & - &1.324074e+03,1.322767e+03,1.321147e+03,1.319318e+03,1.317157e+03, & - &1.324617e+03,1.323247e+03,1.321689e+03,1.319783e+03,1.317667e+03, & - &1.325179e+03,1.323855e+03,1.322316e+03,1.320550e+03,1.318454e+03, & - &1.325651e+03,1.324487e+03,1.322963e+03,1.321227e+03,1.319227e+03, & - &1.326144e+03,1.324962e+03,1.323471e+03,1.321840e+03,1.319882e+03, & - &1.326557e+03,1.325505e+03,1.324161e+03,1.322561e+03,1.320636e+03, & - &1.327026e+03,1.325972e+03,1.324679e+03,1.323183e+03,1.321421e+03, & - &1.327471e+03,1.326430e+03,1.325201e+03,1.323779e+03,1.322132e+03, & - &1.327977e+03,1.326884e+03,1.325810e+03,1.324461e+03,1.322919e+03, & - &1.328289e+03,1.327376e+03,1.326335e+03,1.325109e+03,1.323578e+03, & - &1.328779e+03,1.327851e+03,1.326895e+03,1.325661e+03,1.324231e+03, & - &1.329154e+03,1.328259e+03,1.327276e+03,1.326149e+03,1.324874e+03, & - &1.329601e+03,1.328708e+03,1.327784e+03,1.326734e+03,1.325474e+03, & - &1.329943e+03,1.329152e+03,1.328181e+03,1.327193e+03,1.326098e+03, & - &1.330331e+03,1.329499e+03,1.328611e+03,1.327657e+03,1.326657e+03, & - &1.330672e+03,1.329855e+03,1.328976e+03,1.328118e+03,1.327040e+03, & - &1.330875e+03,1.330163e+03,1.329291e+03,1.328483e+03,1.327534e+03, & - &1.331171e+03,1.330384e+03,1.329703e+03,1.328884e+03,1.327942e+03, & - &1.331401e+03,1.330716e+03,1.330045e+03,1.329202e+03,1.328300e+03, & - &1.331666e+03,1.331051e+03,1.330274e+03,1.329586e+03,1.328602e+03, & - &1.331773e+03,1.331302e+03,1.330550e+03,1.329799e+03,1.328923e+03, & - &1.331966e+03,1.331441e+03,1.330770e+03,1.329996e+03,1.329199e+03, & - &1.332116e+03,1.331644e+03,1.331004e+03,1.330331e+03,1.329513e+03, & - &1.332201e+03,1.331761e+03,1.331192e+03,1.330562e+03,1.329793e+03, & - &1.332217e+03,1.331846e+03,1.331272e+03,1.330667e+03,1.329921e+03/ - -! the array selfref contains the coefficient of the water vapor -! self-continuum (including the energy term). the first index -! refers to temperature in 7.2 degree increments. for instance, -! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, -! etc. the second index runs over the g-channel (1 to NG14=2). - - data selfref(:, 1) / & - &3.930100e-03,3.293941e-03,2.760915e-03,2.314281e-03,1.940014e-03, & - &1.626368e-03,1.363513e-03,1.143206e-03,9.585507e-04,8.037703e-04/ - data selfref(:, 2) / & - &3.388742e-03,2.818523e-03,2.344254e-03,1.949793e-03,1.621703e-03, & - &1.348823e-03,1.121864e-03,9.330928e-04,7.760865e-04,6.454987e-04/ - - data fracrefa / 0.9475674629, 0.0524356775 / - data fracrefb / 0.9458647966, 0.0541389883 / - -!........................................! - end module module_radlw_kgb14 ! -!========================================! - - - -!========================================! - module module_radlw_kgb15 ! -!........................................! -! - use machine, only : kind_phys - use module_radlw_parameters, only : NG15 -! - implicit none -! - private -! - integer, public :: MSA15, MSF15, MAF15 - parameter (MSA15=585, MSF15=10, MAF15=9) - - real (kind=kind_phys), public :: & - & absa(MSA15,NG15), selfref(MSF15,NG15), fracrefa(NG15,MAF15) - -! the array absa(585,NG15) = ka(9,5,13,NG15) contains absorption coefs -! at the NG15=2 chosen g-values for a range of pressure levels> ~100mb, -! temperatures, and binary species parameters (see taumol.f for -! definition). the first index in the array, js, runs from 1 to 9, -! and corresponds to different values of the binary species parameter. -! for instance, js=1 refers to dry air, js = 2 corresponds to the -! paramter value 1/8, js = 3 corresponds to the parameter value 2/8, -! etc. the second index in the array, jt, which runs from 1 to 5, -! corresponds to different temperatures. more specifically, jt = 1-5 -! means that the data are for the corresponding temperature of -! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the -! third index, jp, runs from 1 to 13 and refers to the jpth reference -! pressure level (see taumol.f for these levels in mb). the fourth -! index, ig, goes from 1 to NG15=2, and indicates which g-interval -! the absorption coefficients are for. - - data absa(1:270,1) / & - &2.374344e-02,1.028190e-01,1.721558e-01,2.372152e-01,2.983095e-01, & - &3.548749e-01,4.050119e-01,4.437329e-01,6.875349e+00,2.315537e-02, & - &1.038536e-01,1.748612e-01,2.413667e-01,3.037860e-01,3.615350e-01, & - &4.124222e-01,4.507870e-01,6.657693e+00,2.275279e-02,1.049786e-01, & - &1.775308e-01,2.454727e-01,3.091238e-01,3.678321e-01,4.195583e-01, & - &4.575319e-01,6.469861e+00,2.253565e-02,1.061914e-01,1.802067e-01, & - &2.494085e-01,3.141948e-01,3.739007e-01,4.261717e-01,4.639086e-01, & - &6.307592e+00,2.250592e-02,1.074790e-01,1.828109e-01,2.531898e-01, & - &3.190108e-01,3.794707e-01,4.322759e-01,4.698298e-01,6.172204e+00, & - &1.931110e-02,9.413923e-02,1.590656e-01,2.197613e-01,2.766493e-01, & - &3.291344e-01,3.754155e-01,4.125926e-01,5.747068e+00,1.870316e-02, & - &9.532464e-02,1.619523e-01,2.241264e-01,2.822604e-01,3.358308e-01, & - &3.828776e-01,4.191867e-01,5.544618e+00,1.824078e-02,9.659852e-02, & - &1.648529e-01,2.284433e-01,2.878515e-01,3.423619e-01,3.900549e-01, & - &4.256896e-01,5.366210e+00,1.792234e-02,9.794714e-02,1.677487e-01, & - &2.326841e-01,2.931610e-01,3.486080e-01,3.967874e-01,4.319618e-01, & - &5.208416e+00,1.774976e-02,9.936053e-02,1.706035e-01,2.367537e-01, & - &2.982932e-01,3.544630e-01,4.031857e-01,4.378981e-01,5.071098e+00, & - &1.573035e-02,8.535948e-02,1.452830e-01,2.011948e-01,2.535352e-01, & - &3.017941e-01,3.444668e-01,3.804572e-01,4.814745e+00,1.507697e-02, & - &8.660789e-02,1.482179e-01,2.056290e-01,2.592094e-01,3.084460e-01, & - &3.516279e-01,3.865844e-01,4.618203e+00,1.453883e-02,8.795281e-02, & - &1.512323e-01,2.100039e-01,2.647789e-01,3.150178e-01,3.587506e-01, & - &3.928359e-01,4.444095e+00,1.410785e-02,8.938141e-02,1.542358e-01, & - &2.143865e-01,2.702273e-01,3.213187e-01,3.657286e-01,3.990346e-01, & - &4.289181e+00,1.378420e-02,9.087142e-02,1.572372e-01,2.185961e-01, & - &2.755404e-01,3.274184e-01,3.723699e-01,4.050229e-01,4.151255e+00, & - &1.311048e-02,7.705878e-02,1.318328e-01,1.828757e-01,2.305108e-01, & - &2.741202e-01,3.133587e-01,3.476943e-01,4.089342e+00,1.246852e-02, & - &7.832642e-02,1.347462e-01,1.872511e-01,2.361660e-01,2.808243e-01, & - &3.201303e-01,3.533327e-01,3.902145e+00,1.192448e-02,7.973740e-02, & - &1.377864e-01,1.916285e-01,2.417290e-01,2.874913e-01,3.270995e-01, & - &3.592685e-01,3.736779e+00,1.146923e-02,8.122557e-02,1.408124e-01, & - &1.960275e-01,2.472905e-01,2.939659e-01,3.340767e-01,3.653194e-01, & - &3.589291e+00,1.109903e-02,8.279729e-02,1.439040e-01,2.003306e-01, & - &2.526690e-01,3.002979e-01,3.409191e-01,3.712959e-01,3.457680e+00, & - &1.107344e-02,6.926477e-02,1.188073e-01,1.646334e-01,2.070389e-01, & - &2.460192e-01,2.819657e-01,3.143301e-01,3.498396e+00,1.047771e-02, & - &7.053828e-02,1.217314e-01,1.690532e-01,2.128013e-01,2.524406e-01, & - &2.882097e-01,3.194734e-01,3.325284e+00,9.967825e-03,7.196895e-02, & - &1.247717e-01,1.735537e-01,2.185313e-01,2.591236e-01,2.948736e-01, & - &3.250780e-01,3.172536e+00,9.533823e-03,7.347399e-02,1.278615e-01, & - &1.780373e-01,2.243040e-01,2.658854e-01,3.017381e-01,3.309524e-01, & - &3.036571e+00,9.170862e-03,7.507407e-02,1.309706e-01,1.825153e-01, & - &2.298990e-01,2.725185e-01,3.085859e-01,3.368946e-01,2.915471e+00, & - &9.431193e-03,6.167450e-02,1.055354e-01,1.458961e-01,1.831656e-01, & - &2.181227e-01,2.509698e-01,2.811091e-01,3.008641e+00,8.887393e-03, & - &6.301203e-02,1.085428e-01,1.503079e-01,1.886953e-01,2.240036e-01, & - &2.565447e-01,2.857242e-01,2.849627e+00,8.420530e-03,6.448397e-02, & - &1.116686e-01,1.549182e-01,1.945174e-01,2.303276e-01,2.627017e-01, & - &2.909370e-01,2.710260e+00,8.020641e-03,6.604627e-02,1.148998e-01, & - &1.595311e-01,2.003766e-01,2.369217e-01,2.692354e-01,2.965453e-01, & - &2.587192e+00,7.681698e-03,6.766476e-02,1.181294e-01,1.642126e-01, & - &2.062011e-01,2.436028e-01,2.759466e-01,3.023782e-01,2.478024e+00/ - data absa(271:585,1) / & - &8.060327e-03,5.416979e-02,9.240687e-02,1.274560e-01,1.602777e-01, & - &1.914967e-01,2.212422e-01,2.489345e-01,2.617414e+00,7.567982e-03, & - &5.553420e-02,9.538652e-02,1.317624e-01,1.652762e-01,1.966759e-01, & - &2.261319e-01,2.530182e-01,2.470957e+00,7.145381e-03,5.704669e-02, & - &9.849215e-02,1.362696e-01,1.707484e-01,2.024933e-01,2.317164e-01, & - &2.578211e-01,2.343447e+00,6.782513e-03,5.869002e-02,1.017718e-01, & - &1.409115e-01,1.765120e-01,2.087078e-01,2.378126e-01,2.631383e-01, & - &2.231800e+00,6.472759e-03,6.038472e-02,1.050802e-01,1.456259e-01, & - &1.824024e-01,2.151671e-01,2.442407e-01,2.688230e-01,2.133374e+00, & - &6.897713e-03,4.696876e-02,7.988809e-02,1.101404e-01,1.389161e-01, & - &1.666181e-01,1.932278e-01,2.183013e-01,2.322481e+00,6.454574e-03, & - &4.832097e-02,8.271421e-02,1.140442e-01,1.433156e-01,1.710892e-01, & - &1.974609e-01,2.218789e-01,2.185779e+00,6.074659e-03,4.980994e-02, & - &8.576207e-02,1.183603e-01,1.483128e-01,1.763098e-01,2.025068e-01, & - &2.262920e-01,2.067682e+00,5.748662e-03,5.144631e-02,8.893708e-02, & - &1.229026e-01,1.537192e-01,1.820946e-01,2.081742e-01,2.313531e-01, & - &1.964787e+00,5.469596e-03,5.317506e-02,9.225339e-02,1.275114e-01, & - &1.593975e-01,1.882408e-01,2.142991e-01,2.368984e-01,1.874484e+00, & - &5.914346e-03,4.025574e-02,6.822716e-02,9.430929e-02,1.194186e-01, & - &1.437730e-01,1.673160e-01,1.897294e-01,2.051837e+00,5.516425e-03, & - &4.151790e-02,7.085235e-02,9.769458e-02,1.231450e-01,1.475701e-01, & - &1.709496e-01,1.928475e-01,1.925428e+00,5.176403e-03,4.297094e-02, & - &7.372622e-02,1.015987e-01,1.275870e-01,1.521823e-01,1.754589e-01, & - &1.968794e-01,1.816949e+00,4.884973e-03,4.454093e-02,7.679372e-02, & - &1.058773e-01,1.325612e-01,1.574614e-01,1.806987e-01,2.016821e-01, & - &1.722985e+00,4.635570e-03,4.624683e-02,8.000425e-02,1.103907e-01, & - &1.379028e-01,1.632251e-01,1.864608e-01,2.070138e-01,1.641009e+00, & - &5.050829e-03,3.423288e-02,5.795793e-02,8.039668e-02,1.021721e-01, & - &1.233979e-01,1.440196e-01,1.637901e-01,1.803024e+00,4.699447e-03, & - &3.540392e-02,6.025494e-02,8.328275e-02,1.053384e-01,1.266514e-01, & - &1.471705e-01,1.665676e-01,1.688030e+00,4.400161e-03,3.675472e-02, & - &6.293254e-02,8.676285e-02,1.092610e-01,1.307658e-01,1.512541e-01, & - &1.703233e-01,1.590065e+00,4.144558e-03,3.827398e-02,6.582728e-02, & - &9.069113e-02,1.137988e-01,1.355913e-01,1.561252e-01,1.748999e-01, & - &1.505789e+00,3.926263e-03,3.989742e-02,6.890012e-02,9.494229e-02, & - &1.187630e-01,1.409205e-01,1.615196e-01,1.800020e-01,1.432743e+00, & - &4.166673e-03,2.934131e-02,4.978014e-02,6.918378e-02,8.803805e-02, & - &1.064191e-01,1.242922e-01,1.414417e-01,1.529127e+00,3.879573e-03, & - &3.048508e-02,5.195344e-02,7.191695e-02,9.108196e-02,1.096227e-01, & - &1.274945e-01,1.444042e-01,1.432877e+00,3.635699e-03,3.181656e-02, & - &5.450282e-02,7.522533e-02,9.484742e-02,1.136517e-01,1.315970e-01, & - &1.483223e-01,1.351098e+00,3.428020e-03,3.329046e-02,5.730885e-02, & - &7.896098e-02,9.917340e-02,1.182942e-01,1.363458e-01,1.528832e-01, & - &1.281046e+00,3.251499e-03,3.488484e-02,6.024260e-02,8.297703e-02, & - &1.038627e-01,1.233623e-01,1.415492e-01,1.579220e-01,1.220405e+00, & - &3.438113e-03,2.505188e-02,4.262008e-02,5.934166e-02,7.560325e-02, & - &9.147240e-02,1.069109e-01,1.217291e-01,1.313123e+00,3.203892e-03, & - &2.616039e-02,4.467039e-02,6.194234e-02,7.856022e-02,9.465262e-02, & - &1.101738e-01,1.248853e-01,1.231551e+00,3.005211e-03,2.745256e-02, & - &4.707959e-02,6.507216e-02,8.214711e-02,9.853698e-02,1.141961e-01, & - &1.288186e-01,1.162544e+00,2.836672e-03,2.886800e-02,4.973359e-02, & - &6.856260e-02,8.620279e-02,1.029382e-01,1.187633e-01,1.332949e-01, & - &1.103499e+00,2.694509e-03,3.041187e-02,5.253030e-02,7.231462e-02, & - &9.054007e-02,1.075968e-01,1.235325e-01,1.378981e-01,1.052517e+00, & - &2.837305e-03,2.133970e-02,3.640954e-02,5.078678e-02,6.478391e-02, & - &7.844568e-02,9.174499e-02,1.045263e-01,1.169793e+00,2.646110e-03, & - &2.241036e-02,3.834642e-02,5.325756e-02,6.762679e-02,8.155040e-02, & - &9.499435e-02,1.077492e-01,1.097811e+00,2.484501e-03,2.363905e-02, & - &4.059055e-02,5.617540e-02,7.099719e-02,8.524123e-02,9.886367e-02, & - &1.115943e-01,1.036985e+00,2.348287e-03,2.498344e-02,4.305445e-02, & - &5.936041e-02,7.465661e-02,8.919894e-02,1.029621e-01,1.156150e-01, & - &9.850169e-01,2.233056e-03,2.643957e-02,4.561347e-02,6.267763e-02, & - &7.848433e-02,9.332670e-02,1.072179e-01,1.197537e-01,9.398772e-01/ - data absa(1:270,2) / & - &7.565985e+00,6.894474e+00,6.380471e+00,5.935704e+00,5.554964e+00, & - &5.247566e+00,5.044152e+00,5.025438e+00,1.605066e+01,9.768929e+00, & - &8.793833e+00,7.975450e+00,7.229971e+00,6.550543e+00,5.946570e+00, & - &5.453645e+00,5.163364e+00,1.663649e+01,1.227811e+01,1.096139e+01, & - &9.800887e+00,8.715118e+00,7.698676e+00,6.762239e+00,5.938728e+00, & - &5.337658e+00,1.750611e+01,1.507896e+01,1.338403e+01,1.184492e+01, & - &1.038371e+01,8.993959e+00,7.686435e+00,6.499158e+00,5.547015e+00, & - &1.867150e+01,1.813843e+01,1.603303e+01,1.408378e+01,1.221471e+01, & - &1.041919e+01,8.710548e+00,7.125631e+00,5.787508e+00,2.007430e+01, & - &6.651398e+00,6.174229e+00,5.857262e+00,5.608643e+00,5.421803e+00, & - &5.306075e+00,5.290787e+00,5.422710e+00,1.273508e+01,8.713585e+00, & - &7.947962e+00,7.344050e+00,6.812253e+00,6.345779e+00,5.953066e+00, & - &5.666023e+00,5.552527e+00,1.293774e+01,1.109122e+01,9.997541e+00, & - &9.067331e+00,8.212436e+00,7.425341e+00,6.717366e+00,6.119875e+00, & - &5.717329e+00,1.336783e+01,1.376949e+01,1.230967e+01,1.101530e+01, & - &9.799766e+00,8.656260e+00,7.594153e+00,6.649625e+00,5.915482e+00, & - &1.401606e+01,1.672076e+01,1.486065e+01,1.316843e+01,1.155841e+01, & - &1.002297e+01,8.574646e+00,7.246552e+00,6.145072e+00,1.484844e+01, & - &5.489814e+00,5.251690e+00,5.170569e+00,5.154318e+00,5.195919e+00, & - &5.303318e+00,5.501320e+00,5.807124e+00,1.042170e+01,7.350225e+00, & - &6.847709e+00,6.505632e+00,6.231608e+00,6.019254e+00,5.877436e+00, & - &5.833441e+00,5.922477e+00,1.026586e+01,9.533134e+00,8.725163e+00, & - &8.081129e+00,7.509945e+00,7.003298e+00,6.570189e+00,6.242263e+00, & - &6.070467e+00,1.023833e+01,1.202700e+01,1.087387e+01,9.889242e+00, & - &8.980618e+00,8.141701e+00,7.379574e+00,6.725720e+00,6.251247e+00, & - &1.032906e+01,1.481217e+01,1.327683e+01,1.191473e+01,1.063362e+01, & - &9.424080e+00,8.296220e+00,7.280610e+00,6.463994e+00,1.052603e+01, & - &4.403938e+00,4.400874e+00,4.546200e+00,4.751927e+00,5.012804e+00, & - &5.338624e+00,5.735277e+00,6.211227e+00,9.562377e+00,6.049703e+00, & - &5.809247e+00,5.721672e+00,5.697281e+00,5.730989e+00,5.833500e+00, & - &6.022637e+00,6.310494e+00,9.337345e+00,8.020284e+00,7.500371e+00, & - &7.138295e+00,6.844334e+00,6.610939e+00,6.447694e+00,6.384103e+00, & - &6.440574e+00,9.177466e+00,1.031074e+01,9.470554e+00,8.794573e+00, & - &8.189430e+00,7.648042e+00,7.180998e+00,6.820085e+00,6.602672e+00, & - &9.084891e+00,1.290543e+01,1.170524e+01,1.067649e+01,9.723527e+00, & - &8.836593e+00,8.025829e+00,7.328406e+00,6.796798e+00,9.043526e+00, & - &3.491704e+00,3.701684e+00,4.051528e+00,4.461633e+00,4.926925e+00, & - &5.447687e+00,6.017501e+00,6.645255e+00,9.378736e+00,4.931028e+00, & - &4.930413e+00,5.073182e+00,5.278605e+00,5.541967e+00,5.871689e+00, & - &6.263902e+00,6.729200e+00,9.177970e+00,6.693088e+00,6.439483e+00, & - &6.334718e+00,6.295118e+00,6.316875e+00,6.409730e+00,6.580783e+00, & - &6.841630e+00,9.018811e+00,8.780535e+00,8.232513e+00,7.839002e+00, & - &7.513581e+00,7.251542e+00,7.065155e+00,6.971503e+00,6.985098e+00, & - &8.899186e+00,1.118252e+01,1.029901e+01,9.577734e+00,8.926641e+00, & - &8.342723e+00,7.836128e+00,7.435507e+00,7.160306e+00,8.802926e+00, & - &2.697058e+00,3.107388e+00,3.653347e+00,4.255960e+00,4.908487e+00, & - &5.598496e+00,6.322645e+00,7.090517e+00,9.508435e+00,3.931109e+00, & - &4.156480e+00,4.520892e+00,4.946219e+00,5.426208e+00,5.955863e+00, & - &6.530375e+00,7.159333e+00,9.354792e+00,5.480607e+00,5.479966e+00, & - &5.623013e+00,5.829607e+00,6.095361e+00,6.422276e+00,6.804975e+00, & - &7.254416e+00,9.221183e+00,7.355641e+00,7.087161e+00,6.966982e+00, & - &6.915162e+00,6.924570e+00,7.003426e+00,7.150882e+00,7.379204e+00, & - &9.103011e+00,9.554280e+00,8.976573e+00,8.552773e+00,8.199842e+00, & - &7.913217e+00,7.700843e+00,7.570087e+00,7.535066e+00,8.994008e+00/ - data absa(271:585,2) / & - &2.050587e+00,2.645016e+00,3.366799e+00,4.140133e+00,4.949533e+00, & - &5.784747e+00,6.643991e+00,7.536366e+00,9.812034e+00,3.093849e+00, & - &3.527594e+00,4.092645e+00,4.713958e+00,5.381555e+00,6.083381e+00, & - &6.816524e+00,7.591355e+00,9.692565e+00,4.441415e+00,4.674706e+00, & - &5.044832e+00,5.474226e+00,5.957029e+00,6.484078e+00,7.051802e+00, & - &7.670157e+00,9.579874e+00,6.109666e+00,6.100656e+00,6.234274e+00, & - &6.431731e+00,6.686360e+00,6.996173e+00,7.356081e+00,7.776887e+00, & - &9.467607e+00,8.103709e+00,7.810577e+00,7.666665e+00,7.589874e+00, & - &7.574084e+00,7.623214e+00,7.731978e+00,7.913239e+00,9.353916e+00, & - &1.541204e+00,2.300410e+00,3.175321e+00,4.093355e+00,5.035225e+00, & - &5.994529e+00,6.971547e+00,7.973578e+00,1.020955e+01,2.412727e+00, & - &3.033789e+00,3.775725e+00,4.567255e+00,5.392048e+00,6.241037e+00, & - &7.112771e+00,8.016167e+00,1.010570e+01,3.573231e+00,4.018454e+00, & - &4.589573e+00,5.214990e+00,5.883137e+00,6.582856e+00,7.311738e+00, & - &8.079662e+00,1.000092e+01,5.046201e+00,5.274400e+00,5.635345e+00, & - &6.053269e+00,6.522317e+00,7.030718e+00,7.576192e+00,8.168590e+00, & - &9.892662e+00,6.843851e+00,6.812950e+00,6.921587e+00,7.092049e+00, & - &7.317160e+00,7.591283e+00,7.910606e+00,8.285775e+00,9.779657e+00, & - &1.138561e+00,2.043752e+00,3.051963e+00,4.090743e+00,5.145249e+00, & - &6.212035e+00,7.291870e+00,8.390273e+00,1.060591e+01,1.855849e+00, & - &2.644332e+00,3.540691e+00,4.477362e+00,5.436404e+00,6.412157e+00, & - &7.404982e+00,8.421759e+00,1.051244e+01,2.842943e+00,3.478607e+00, & - &4.228113e+00,5.024096e+00,5.850654e+00,6.699834e+00,7.570247e+00, & - &8.470788e+00,1.041432e+01,4.130222e+00,4.573799e+00,5.137212e+00, & - &5.751915e+00,6.405426e+00,7.087733e+00,7.796847e+00,8.542556e+00, & - &1.031055e+01,5.736242e+00,5.945895e+00,6.282625e+00,6.673885e+00, & - &7.111701e+00,7.584912e+00,8.091669e+00,8.641941e+00,1.019986e+01, & - &8.644078e-01,1.889852e+00,3.003514e+00,4.138064e+00,5.283265e+00, & - &6.437469e+00,7.601524e+00,8.779480e+00,1.098832e+01,1.463397e+00, & - &2.389121e+00,3.409468e+00,4.459314e+00,5.524912e+00,6.602472e+00, & - &7.693100e+00,8.801936e+00,1.090321e+01,2.313763e+00,3.106010e+00, & - &3.998109e+00,4.928280e+00,5.879840e+00,6.847593e+00,7.831697e+00, & - &8.839141e+00,1.081128e+01,3.451230e+00,4.071698e+00,4.798632e+00, & - &5.569064e+00,6.367826e+00,7.187836e+00,8.028149e+00,8.897242e+00, & - &1.071134e+01,4.899532e+00,5.307844e+00,5.828862e+00,6.397758e+00, & - &7.002563e+00,7.634287e+00,8.291224e+00,8.982359e+00,1.060283e+01, & - &8.523359e-01,1.946185e+00,3.116576e+00,4.303827e+00,5.499835e+00, & - &6.703648e+00,7.915751e+00,9.139658e+00,1.131246e+01,1.449200e+00, & - &2.444965e+00,3.523793e+00,4.626876e+00,5.742975e+00,6.869172e+00, & - &8.006254e+00,9.159074e+00,1.123119e+01,2.297306e+00,3.160920e+00, & - &4.113407e+00,5.097704e+00,6.099758e+00,7.114935e+00,8.144220e+00, & - &9.193371e+00,1.114036e+01,3.431873e+00,4.125522e+00,4.913674e+00, & - &5.740178e+00,6.589868e+00,7.457197e+00,8.341968e+00,9.251165e+00, & - &1.104014e+01,4.877718e+00,5.360474e+00,5.944846e+00,6.571589e+00, & - &7.228134e+00,7.907164e+00,8.607410e+00,9.337181e+00,1.093209e+01, & - &8.446403e-01,1.998786e+00,3.218337e+00,4.451634e+00,5.692318e+00, & - &6.939411e+00,8.193698e+00,9.457935e+00,1.163095e+01,1.440768e+00, & - &2.498171e+00,3.627473e+00,4.776772e+00,5.936604e+00,7.105070e+00, & - &8.282888e+00,9.473891e+00,1.155047e+01,2.288177e+00,3.214800e+00, & - &4.219388e+00,5.250362e+00,6.296175e+00,7.353198e+00,8.422005e+00, & - &9.507828e+00,1.145940e+01,3.421906e+00,4.180204e+00,5.021951e+00, & - &5.896689e+00,6.790524e+00,7.699138e+00,8.622476e+00,9.566889e+00, & - &1.135970e+01,4.866784e+00,5.415663e+00,6.055115e+00,6.732270e+00, & - &7.434628e+00,8.155786e+00,8.895261e+00,9.660085e+00,1.125319e+01, & - &8.383955e-01,2.045036e+00,3.307142e+00,4.580518e+00,5.860070e+00, & - &7.145129e+00,8.436181e+00,9.735617e+00,1.196562e+01,1.433992e+00, & - &2.545159e+00,3.718237e+00,4.907888e+00,6.106304e+00,7.311980e+00, & - &8.525517e+00,9.750368e+00,1.188442e+01,2.280671e+00,3.262727e+00, & - &4.312704e+00,5.384770e+00,6.469244e+00,7.563027e+00,8.666943e+00, & - &9.785680e+00,1.179303e+01,3.414048e+00,4.229334e+00,5.118430e+00, & - &6.036061e+00,6.970044e+00,7.916253e+00,8.875071e+00,9.851958e+00, & - &1.169434e+01,4.857786e+00,5.465622e+00,6.154920e+00,6.878155e+00, & - &7.621806e+00,8.380994e+00,9.155742e+00,9.952278e+00,1.159406e+01/ - -! the array selfref contains the coefficient of the water vapor -! self-continuum (including the energy term). the first index -! refers to temperature in 7.2 degree increments. for instance, -! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, -! etc. the second index runs over the g-channel (1 to NG15=2). - - data selfref(:, 1) / & - &2.111727e-03,1.732203e-03,1.420900e-03,1.165551e-03,9.560994e-04, & - &7.842932e-04,6.433656e-04,5.277655e-04,4.329401e-04,3.551555e-04/ - data selfref(:, 2) / & - &2.874505e-03,2.379496e-03,1.969721e-03,1.630519e-03,1.349733e-03, & - &1.117293e-03,9.248859e-04,7.656123e-04,6.337676e-04,5.246269e-04/ - - data fracrefa(:,:) / & - & 0.9182857871, 0.0817165971, 0.9299723506, 0.0700289980, & - & 0.9338861704, 0.0661164895, 0.9366340041, 0.0633680895, & - & 0.9396196008, 0.0603826903, 0.9425359368, 0.0574668199, & - & 0.9463133812, 0.0536896810, 0.9515711069, 0.0484329984, & - & 0.9384269118, 0.0615767650 / - -!........................................! - end module module_radlw_kgb15 ! -!========================================! - - - -!========================================! - module module_radlw_kgb16 ! -!........................................! -! - use machine, only : kind_phys - use module_radlw_parameters, only : NG16 -! - implicit none -! - private -! - integer, public :: MSA16, MSF16, MAF16 - parameter (MSA16=585, MSF16=10, MAF16=9) - - real (kind=kind_phys), public :: & - & absa(MSA16,NG16), selfref(MSF16,NG16), fracrefa(NG16,MAF16) - -! the array absa(585,NG16) = ka(9,5,13,NG16) contains absorption coefs -! at the NG16=2 chosen g-values for a range of pressure levels> ~100mb, -! temperatures, and binary species parameters (see taumol.f for -! definition). the first index in the array, js, runs from 1 to 9, -! and corresponds to different values of the binary species parameter. -! for instance, js=1 refers to dry air, js = 2 corresponds to the -! paramter value 1/8, js = 3 corresponds to the parameter value 2/8, -! etc. the second index in the array, jt, which runs from 1 to 5, -! corresponds to different temperatures. more specifically, jt = 1-5 -! means that the data are for the corresponding temperature of -! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the -! third index, jp, runs from 1 to 13 and refers to the jpth reference -! pressure level (see taumol.f for these levels in mb). the fourth -! index, ig, goes from 1 to NG16=2, and indicates which g-interval -! the absorption coefficients are for. - - data absa(1:270,1) / & - &1.876196e-04,2.284367e-04,2.503947e-04,2.661740e-04,2.774509e-04, & - &2.846879e-04,2.876639e-04,2.831299e-04,2.500199e-04,1.879373e-04, & - &2.333516e-04,2.575345e-04,2.749541e-04,2.876580e-04,2.957099e-04, & - &2.993122e-04,2.953168e-04,2.620156e-04,1.886744e-04,2.387940e-04, & - &2.654074e-04,2.845354e-04,2.986880e-04,3.077497e-04,3.119101e-04, & - &3.081486e-04,2.745170e-04,1.891288e-04,2.439448e-04,2.732031e-04, & - &2.943335e-04,3.100126e-04,3.203657e-04,3.251803e-04,3.214910e-04, & - &2.876062e-04,1.902027e-04,2.497655e-04,2.817073e-04,3.050396e-04, & - &3.222250e-04,3.339262e-04,3.393703e-04,3.357794e-04,3.015349e-04, & - &1.743758e-04,2.121137e-04,2.323847e-04,2.468229e-04,2.572697e-04, & - &2.635675e-04,2.653750e-04,2.602517e-04,2.260501e-04,1.747666e-04, & - &2.166578e-04,2.386848e-04,2.544681e-04,2.660424e-04,2.735583e-04, & - &2.764336e-04,2.718694e-04,2.372231e-04,1.755703e-04,2.216306e-04, & - &2.456239e-04,2.629018e-04,2.756405e-04,2.842537e-04,2.880654e-04, & - &2.839277e-04,2.487225e-04,1.763407e-04,2.265495e-04,2.526687e-04, & - &2.716896e-04,2.857147e-04,2.953865e-04,2.998700e-04,2.963744e-04, & - &2.607680e-04,1.772062e-04,2.315344e-04,2.598907e-04,2.808766e-04, & - &2.962546e-04,3.070643e-04,3.121971e-04,3.093570e-04,2.735540e-04, & - &1.614776e-04,1.960905e-04,2.147710e-04,2.282365e-04,2.370327e-04, & - &2.412395e-04,2.413448e-04,2.353310e-04,2.012512e-04,1.619671e-04, & - &2.002225e-04,2.203792e-04,2.349360e-04,2.450914e-04,2.506225e-04, & - &2.516444e-04,2.463504e-04,2.113998e-04,1.625459e-04,2.044712e-04, & - &2.263519e-04,2.420734e-04,2.534691e-04,2.604621e-04,2.623621e-04, & - &2.575209e-04,2.218225e-04,1.636300e-04,2.091793e-04,2.328206e-04, & - &2.499491e-04,2.623957e-04,2.706666e-04,2.734349e-04,2.689723e-04, & - &2.327568e-04,1.644859e-04,2.136348e-04,2.391607e-04,2.578310e-04, & - &2.714201e-04,2.809503e-04,2.847642e-04,2.808402e-04,2.443409e-04, & - &1.488843e-04,1.806197e-04,1.983830e-04,2.103399e-04,2.170537e-04, & - &2.194325e-04,2.175234e-04,2.102642e-04,1.796014e-04,1.494833e-04, & - &1.845266e-04,2.034393e-04,2.166469e-04,2.245804e-04,2.281538e-04, & - &2.271224e-04,2.204918e-04,1.887311e-04,1.501108e-04,1.885315e-04, & - &2.087859e-04,2.231575e-04,2.323963e-04,2.371367e-04,2.370130e-04, & - &2.308527e-04,1.981428e-04,1.509417e-04,1.926308e-04,2.143624e-04, & - &2.300528e-04,2.405021e-04,2.462707e-04,2.470881e-04,2.414552e-04, & - &2.079249e-04,1.523212e-04,1.971829e-04,2.204098e-04,2.373615e-04, & - &2.490265e-04,2.558662e-04,2.576128e-04,2.525079e-04,2.182736e-04, & - &1.367532e-04,1.660320e-04,1.827331e-04,1.929248e-04,1.979241e-04, & - &1.985527e-04,1.948957e-04,1.865408e-04,1.622610e-04,1.374590e-04, & - &1.696848e-04,1.875418e-04,1.988911e-04,2.049801e-04,2.065600e-04, & - &2.036914e-04,1.958519e-04,1.702893e-04,1.381510e-04,1.734582e-04, & - &1.925366e-04,2.050524e-04,2.122918e-04,2.147982e-04,2.127158e-04, & - &2.053227e-04,1.786021e-04,1.390148e-04,1.772825e-04,1.976715e-04, & - &2.114726e-04,2.197390e-04,2.231583e-04,2.219513e-04,2.150026e-04, & - &1.873250e-04,1.404115e-04,1.814938e-04,2.031713e-04,2.182027e-04, & - &2.275729e-04,2.319181e-04,2.315463e-04,2.250751e-04,1.965416e-04, & - &1.251188e-04,1.523260e-04,1.672611e-04,1.757352e-04,1.793361e-04, & - &1.785483e-04,1.736551e-04,1.642179e-04,1.497880e-04,1.258963e-04, & - &1.556952e-04,1.718778e-04,1.814054e-04,1.858671e-04,1.858174e-04, & - &1.815807e-04,1.726550e-04,1.567838e-04,1.266776e-04,1.591836e-04, & - &1.765928e-04,1.872204e-04,1.925844e-04,1.933116e-04,1.897312e-04, & - &1.812163e-04,1.640228e-04,1.275580e-04,1.626817e-04,1.814212e-04, & - &1.932389e-04,1.994316e-04,2.009432e-04,1.980682e-04,1.899299e-04, & - &1.715830e-04,1.286495e-04,1.663104e-04,1.863363e-04,1.993226e-04, & - &2.064775e-04,2.087660e-04,2.066180e-04,1.989297e-04,1.795831e-04/ - data absa(271:585,1) / & - &1.138966e-04,1.392660e-04,1.522388e-04,1.589584e-04,1.613745e-04, & - &1.598076e-04,1.541751e-04,1.439595e-04,1.456306e-04,1.147721e-04, & - &1.424319e-04,1.565887e-04,1.642708e-04,1.674358e-04,1.664114e-04, & - &1.612161e-04,1.514271e-04,1.515891e-04,1.156448e-04,1.456549e-04, & - &1.609972e-04,1.696643e-04,1.736376e-04,1.731815e-04,1.685169e-04, & - &1.590580e-04,1.578879e-04,1.165514e-04,1.488669e-04,1.655033e-04, & - &1.752537e-04,1.799598e-04,1.800901e-04,1.759721e-04,1.668061e-04, & - &1.645824e-04,1.176193e-04,1.521812e-04,1.701180e-04,1.809446e-04, & - &1.864372e-04,1.871495e-04,1.836349e-04,1.748046e-04,1.716403e-04, & - &1.033720e-04,1.267642e-04,1.377710e-04,1.430429e-04,1.444146e-04, & - &1.423433e-04,1.364549e-04,1.259610e-04,1.622799e-04,1.043408e-04, & - &1.297746e-04,1.418651e-04,1.479784e-04,1.499882e-04,1.483521e-04, & - &1.427641e-04,1.324940e-04,1.669200e-04,1.052547e-04,1.328556e-04, & - &1.459983e-04,1.529680e-04,1.556578e-04,1.544892e-04,1.492320e-04, & - &1.392133e-04,1.721767e-04,1.061705e-04,1.358969e-04,1.502379e-04, & - &1.581119e-04,1.614525e-04,1.607405e-04,1.558201e-04,1.460639e-04, & - &1.778740e-04,1.072114e-04,1.389918e-04,1.545528e-04,1.633533e-04, & - &1.673754e-04,1.671010e-04,1.626218e-04,1.531287e-04,1.840100e-04, & - &9.344074e-05,1.147942e-04,1.239403e-04,1.280574e-04,1.287055e-04, & - &1.261671e-04,1.202992e-04,1.100301e-04,2.877572e-04,9.447327e-05, & - &1.176697e-04,1.277911e-04,1.326162e-04,1.337457e-04,1.315915e-04, & - &1.259756e-04,1.157606e-04,2.876850e-04,9.544134e-05,1.205742e-04, & - &1.316725e-04,1.371916e-04,1.388581e-04,1.371205e-04,1.317973e-04, & - &1.216540e-04,2.892241e-04,9.637163e-05,1.234754e-04,1.356195e-04, & - &1.419186e-04,1.441037e-04,1.427665e-04,1.376870e-04,1.276920e-04, & - &2.921068e-04,9.739923e-05,1.264214e-04,1.396320e-04,1.467355e-04, & - &1.494679e-04,1.485068e-04,1.437233e-04,1.339081e-04,2.960236e-04, & - &8.414417e-05,1.036126e-04,1.112562e-04,1.144570e-04,1.145187e-04, & - &1.118045e-04,1.060306e-04,9.628186e-05,7.871613e-04,8.524761e-05, & - &1.063402e-04,1.148443e-04,1.186531e-04,1.191090e-04,1.166742e-04, & - &1.111219e-04,1.013580e-04,7.643289e-04,8.627615e-05,1.090882e-04, & - &1.184668e-04,1.228424e-04,1.237283e-04,1.216508e-04,1.163399e-04, & - &1.065695e-04,7.463988e-04,8.726364e-05,1.118428e-04,1.221465e-04, & - &1.271298e-04,1.284572e-04,1.267372e-04,1.216617e-04,1.118695e-04, & - &7.326087e-04,8.830346e-05,1.146472e-04,1.258686e-04,1.315049e-04, & - &1.333130e-04,1.319358e-04,1.270754e-04,1.173142e-04,7.221906e-04, & - &7.598165e-05,9.429643e-05,1.010564e-04,1.037187e-04,1.034740e-04, & - &1.007265e-04,9.519425e-05,8.608658e-05,1.046778e-03,7.710580e-05, & - &9.690240e-05,1.043699e-04,1.075406e-04,1.076593e-04,1.051739e-04, & - &9.981140e-05,9.062357e-05,1.010390e-03,7.816231e-05,9.950563e-05, & - &1.077270e-04,1.114043e-04,1.118927e-04,1.097057e-04,1.045404e-04, & - &9.528588e-05,9.806325e-04,7.922199e-05,1.021054e-04,1.111381e-04, & - &1.153308e-04,1.162360e-04,1.143331e-04,1.093402e-04,1.000256e-04, & - &9.561496e-04,8.032931e-05,1.047899e-04,1.146224e-04,1.193221e-04, & - &1.206618e-04,1.190846e-04,1.142385e-04,1.048619e-04,9.359335e-04, & - &6.834501e-05,8.542615e-05,9.144763e-05,9.364991e-05,9.321217e-05, & - &9.042789e-05,8.522478e-05,7.670022e-05,1.086761e-03,6.946913e-05, & - &8.792168e-05,9.450995e-05,9.713267e-05,9.704531e-05,9.451513e-05, & - &8.939004e-05,8.077877e-05,1.046791e-03,7.055808e-05,9.038006e-05, & - &9.761302e-05,1.006928e-04,1.009411e-04,9.864486e-05,9.364111e-05, & - &8.494676e-05,1.013609e-03,7.164413e-05,9.287891e-05,1.007571e-04, & - &1.043072e-04,1.049088e-04,1.028559e-04,9.795671e-05,8.917786e-05, & - &9.855330e-04,7.279066e-05,9.547123e-05,1.039688e-04,1.079840e-04, & - &1.089473e-04,1.071832e-04,1.023930e-04,9.349949e-05,9.615266e-04, & - &6.116318e-05,7.697869e-05,8.232280e-05,8.417337e-05,8.361619e-05, & - &8.096566e-05,7.603403e-05,6.803601e-05,9.266356e-04,6.227601e-05, & - &7.933199e-05,8.518261e-05,8.739832e-05,8.712805e-05,8.466904e-05, & - &7.980640e-05,7.171952e-05,8.923263e-04,6.335597e-05,8.167002e-05, & - &8.805688e-05,9.068122e-05,9.071185e-05,8.841971e-05,8.362261e-05, & - &7.545295e-05,8.636475e-04,6.445193e-05,8.406166e-05,9.099072e-05, & - &9.401144e-05,9.433433e-05,9.223902e-05,8.749913e-05,7.923668e-05, & - &8.391325e-04,6.563352e-05,8.654197e-05,9.400235e-05,9.741022e-05, & - &9.805216e-05,9.616710e-05,9.149377e-05,8.312566e-05,8.181485e-04/ - data absa(1:270,2) / & - &1.317823e-02,1.212305e-02,1.137318e-02,1.072304e-02,1.014565e-02, & - &9.633663e-03,9.189881e-03,8.864917e-03,9.023153e-03,1.319151e-02, & - &1.224558e-02,1.164307e-02,1.114997e-02,1.073300e-02,1.039107e-02, & - &1.012043e-02,9.971693e-03,1.031510e-02,1.320424e-02,1.237398e-02, & - &1.192387e-02,1.159472e-02,1.134651e-02,1.118002e-02,1.109254e-02, & - &1.113079e-02,1.167246e-02,1.319383e-02,1.249113e-02,1.220162e-02, & - &1.204392e-02,1.197412e-02,1.199028e-02,1.209519e-02,1.233595e-02, & - &1.308313e-02,1.318321e-02,1.261318e-02,1.248996e-02,1.250598e-02, & - &1.262113e-02,1.282509e-02,1.312975e-02,1.357825e-02,1.454065e-02, & - &1.335802e-02,1.227440e-02,1.147352e-02,1.076691e-02,1.012477e-02, & - &9.549468e-03,9.046649e-03,8.654200e-03,8.764944e-03,1.337498e-02, & - &1.240373e-02,1.175370e-02,1.120486e-02,1.072387e-02,1.030878e-02, & - &9.967863e-03,9.745632e-03,1.004174e-02,1.339049e-02,1.254015e-02, & - &1.204653e-02,1.166167e-02,1.135025e-02,1.110559e-02,1.093777e-02, & - &1.089715e-02,1.138958e-02,1.338855e-02,1.266996e-02,1.234093e-02, & - &1.212693e-02,1.199336e-02,1.193062e-02,1.195118e-02,1.209904e-02, & - &1.279628e-02,1.337085e-02,1.279392e-02,1.263699e-02,1.259945e-02, & - &1.265299e-02,1.277985e-02,1.299763e-02,1.334406e-02,1.425161e-02, & - &1.352824e-02,1.238800e-02,1.150531e-02,1.070705e-02,9.984310e-03, & - &9.335589e-03,8.753041e-03,8.267337e-03,8.299430e-03,1.354981e-02, & - &1.252339e-02,1.178985e-02,1.114677e-02,1.057477e-02,1.007773e-02, & - &9.653324e-03,9.329312e-03,9.546382e-03,1.356091e-02,1.265926e-02, & - &1.208193e-02,1.160415e-02,1.119630e-02,1.085956e-02,1.060558e-02, & - &1.045841e-02,1.086972e-02,1.357052e-02,1.280246e-02,1.238905e-02, & - &1.208099e-02,1.184877e-02,1.168357e-02,1.160739e-02,1.164599e-02, & - &1.225692e-02,1.355538e-02,1.293319e-02,1.269295e-02,1.256381e-02, & - &1.251684e-02,1.253533e-02,1.264578e-02,1.288044e-02,1.369835e-02, & - &1.369125e-02,1.248815e-02,1.151111e-02,1.062782e-02,9.829285e-03, & - &9.101248e-03,8.441898e-03,7.867845e-03,7.792797e-03,1.371822e-02, & - &1.262701e-02,1.179663e-02,1.105878e-02,1.040565e-02,9.823559e-03, & - &9.315378e-03,8.896343e-03,9.000682e-03,1.373522e-02,1.276670e-02, & - &1.209182e-02,1.151231e-02,1.101561e-02,1.059177e-02,1.024582e-02, & - &9.997054e-03,1.029125e-02,1.374117e-02,1.290748e-02,1.239681e-02, & - &1.198388e-02,1.165542e-02,1.140301e-02,1.123012e-02,1.116067e-02, & - &1.165328e-02,1.374471e-02,1.305554e-02,1.271641e-02,1.247876e-02, & - &1.232648e-02,1.225234e-02,1.226020e-02,1.237811e-02,1.307523e-02, & - &1.384526e-02,1.258127e-02,1.152077e-02,1.056541e-02,9.694240e-03, & - &8.893581e-03,8.162003e-03,7.505535e-03,7.322148e-03,1.388007e-02, & - &1.272549e-02,1.180332e-02,1.098600e-02,1.025404e-02,9.595304e-03, & - &9.008388e-03,8.500344e-03,8.488189e-03,1.390230e-02,1.286813e-02, & - &1.209623e-02,1.143076e-02,1.085060e-02,1.034683e-02,9.917188e-03, & - &9.571842e-03,9.743853e-03,1.391280e-02,1.301223e-02,1.240092e-02, & - &1.189638e-02,1.148089e-02,1.114449e-02,1.088213e-02,1.071227e-02, & - &1.107596e-02,1.392051e-02,1.316459e-02,1.272271e-02,1.238829e-02, & - &1.214560e-02,1.198402e-02,1.189889e-02,1.191109e-02,1.247491e-02, & - &1.398680e-02,1.265958e-02,1.153063e-02,1.050639e-02,9.560734e-03, & - &8.686230e-03,7.878016e-03,7.142097e-03,6.856098e-03,1.403042e-02, & - &1.280894e-02,1.180787e-02,1.091463e-02,1.010323e-02,9.364580e-03, & - &8.693580e-03,8.097910e-03,7.972145e-03,1.405962e-02,1.295660e-02, & - &1.209796e-02,1.134880e-02,1.068489e-02,1.009593e-02,9.576442e-03, & - &9.136309e-03,9.184925e-03,1.407616e-02,1.310546e-02,1.239980e-02, & - &1.180591e-02,1.130321e-02,1.087643e-02,1.052056e-02,1.024860e-02, & - &1.048352e-02,1.408046e-02,1.325425e-02,1.271350e-02,1.228668e-02, & - &1.195414e-02,1.170007e-02,1.151829e-02,1.142456e-02,1.185502e-02/ - data absa(271:585,2) / & - &1.411427e-02,1.272928e-02,1.154486e-02,1.046170e-02,9.448067e-03, & - &8.498870e-03,7.615150e-03,6.804971e-03,6.470598e-03,1.416785e-02, & - &1.288432e-02,1.181908e-02,1.085816e-02,9.970565e-03,9.151061e-03, & - &8.398660e-03,7.719770e-03,7.529602e-03,1.420488e-02,1.303667e-02, & - &1.210583e-02,1.128297e-02,1.053615e-02,9.860904e-03,9.253557e-03, & - &8.723619e-03,8.692217e-03,1.422800e-02,1.318971e-02,1.240516e-02, & - &1.173177e-02,1.114040e-02,1.062292e-02,1.017415e-02,9.806067e-03, & - &9.946194e-03,1.423821e-02,1.334284e-02,1.271628e-02,1.220485e-02, & - &1.177948e-02,1.143218e-02,1.115234e-02,1.095832e-02,1.128091e-02, & - &1.422616e-02,1.279616e-02,1.156648e-02,1.042975e-02,9.356028e-03, & - &8.337742e-03,7.381549e-03,6.499134e-03,6.310591e-03,1.429150e-02, & - &1.295676e-02,1.183771e-02,1.081522e-02,9.859492e-03,8.963037e-03, & - &8.129852e-03,7.372017e-03,7.302349e-03,1.433717e-02,1.311229e-02, & - &1.212140e-02,1.122990e-02,1.040821e-02,9.648904e-03,8.955155e-03, & - &8.338274e-03,8.403055e-03,1.436854e-02,1.326856e-02,1.241762e-02, & - &1.167107e-02,1.099809e-02,1.039068e-02,9.851197e-03,9.389836e-03, & - &9.603172e-03,1.438511e-02,1.342411e-02,1.272577e-02,1.213680e-02, & - &1.162522e-02,1.118313e-02,1.080900e-02,1.051538e-02,1.089265e-02, & - &1.432324e-02,1.285780e-02,1.158966e-02,1.040320e-02,9.272785e-03, & - &8.193735e-03,7.168396e-03,6.214133e-03,8.235258e-03,1.440092e-02, & - &1.302357e-02,1.185772e-02,1.077750e-02,9.757139e-03,8.789879e-03, & - &7.878629e-03,7.041458e-03,9.110793e-03,1.445734e-02,1.318429e-02, & - &1.213845e-02,1.118253e-02,1.028910e-02,9.450890e-03,8.670468e-03, & - &7.967657e-03,1.010370e-02,1.449679e-02,1.334312e-02,1.243166e-02, & - &1.161460e-02,1.086378e-02,1.017061e-02,9.537603e-03,8.984079e-03, & - &1.120476e-02,1.452034e-02,1.350101e-02,1.273732e-02,1.207245e-02, & - &1.147853e-02,1.094422e-02,1.047180e-02,1.008024e-02,1.240508e-02, & - &1.441236e-02,1.292535e-02,1.162963e-02,1.040599e-02,9.232221e-03, & - &8.104142e-03,7.025611e-03,6.010986e-03,2.164841e-02,1.450101e-02, & - &1.309649e-02,1.189593e-02,1.077126e-02,9.700739e-03,8.676926e-03, & - &7.703538e-03,6.798085e-03,2.225828e-02,1.456746e-02,1.326255e-02, & - &1.217517e-02,1.116854e-02,1.021842e-02,9.316261e-03,8.466240e-03, & - &7.688375e-03,2.302195e-02,1.461406e-02,1.342482e-02,1.246651e-02, & - &1.159408e-02,1.078086e-02,1.001706e-02,9.307384e-03,8.674061e-03, & - &2.393106e-02,1.464436e-02,1.358526e-02,1.277087e-02,1.204683e-02, & - &1.138466e-02,1.077413e-02,1.022013e-02,9.744905e-03,2.497380e-02, & - &1.453758e-02,1.306763e-02,1.178443e-02,1.056739e-02,9.397205e-03, & - &8.267792e-03,7.183498e-03,6.156879e-03,3.457705e-02,1.462710e-02, & - &1.324166e-02,1.205612e-02,1.093975e-02,9.872701e-03,8.847905e-03, & - &7.869650e-03,6.952952e-03,3.506734e-02,1.469329e-02,1.341042e-02, & - &1.233972e-02,1.134269e-02,1.039705e-02,9.494981e-03,8.640951e-03, & - &7.852716e-03,3.573528e-02,1.473953e-02,1.357583e-02,1.263596e-02, & - &1.177471e-02,1.096639e-02,1.020362e-02,9.491093e-03,8.848281e-03, & - &3.657574e-02,1.476911e-02,1.373840e-02,1.294454e-02,1.223372e-02, & - &1.157748e-02,1.096835e-02,1.041214e-02,9.929275e-03,3.757912e-02, & - &1.465526e-02,1.320429e-02,1.193184e-02,1.072148e-02,9.553678e-03, & - &8.423919e-03,7.333358e-03,6.296222e-03,4.288679e-02,1.474529e-02, & - &1.338087e-02,1.220849e-02,1.109998e-02,1.003551e-02,9.010637e-03, & - &8.027632e-03,7.100994e-03,4.333488e-02,1.481109e-02,1.355198e-02, & - &1.249646e-02,1.150822e-02,1.056602e-02,9.664710e-03,8.807467e-03, & - &8.009680e-03,4.397343e-02,1.485711e-02,1.371950e-02,1.279772e-02, & - &1.194585e-02,1.114202e-02,1.038092e-02,9.665932e-03,9.013787e-03, & - &4.480319e-02,1.488612e-02,1.388363e-02,1.311065e-02,1.241036e-02, & - &1.175974e-02,1.115304e-02,1.059504e-02,1.010381e-02,4.581486e-02, & - &1.476379e-02,1.333281e-02,1.207107e-02,1.086576e-02,9.699520e-03, & - &8.567198e-03,7.471795e-03,6.425716e-03,4.255114e-02,1.485444e-02, & - &1.351222e-02,1.235136e-02,1.124887e-02,1.018702e-02,9.160565e-03, & - &8.173027e-03,7.237752e-03,4.304420e-02,1.492052e-02,1.368544e-02, & - &1.264343e-02,1.166216e-02,1.072329e-02,9.821586e-03,8.960651e-03, & - &8.154297e-03,4.372432e-02,1.496663e-02,1.385495e-02,1.294798e-02, & - &1.210484e-02,1.130499e-02,1.054437e-02,9.826866e-03,9.166411e-03, & - &4.458990e-02,1.499514e-02,1.402112e-02,1.326490e-02,1.257412e-02, & - &1.192850e-02,1.132324e-02,1.076376e-02,1.026384e-02,4.563189e-02/ - -! the array selfref contains the coefficient of the water vapor -! self-continuum (including the energy term). the first index -! refers to temperature in 7.2 degree increments. for instance, -! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, -! etc. the second index runs over the g-channel (1 to NG16=2). - - data selfref(:, 1) / & - &1.358980e-03,1.153258e-03,9.796993e-04,8.331471e-04,7.092914e-04, & - &6.045207e-04,5.158114e-04,4.406282e-04,3.768445e-04,3.226768e-04/ - data selfref(:, 2) / & - &1.641282e-03,1.549356e-03,1.462608e-03,1.380727e-03,1.303452e-03, & - &1.230519e-03,1.161679e-03,1.096710e-03,1.035386e-03,9.775021e-04/ - - data fracrefa(:,:) / & - & 0.9668645263, 0.0331371240, 0.9692655206, 0.0307367910, & - & 0.9703481197, 0.0296534691, 0.9707497358, 0.0292529315, & - & 0.9709156156, 0.0290862601, 0.9711337090, 0.0288693514, & - & 0.9701029062, 0.0298991501, 0.9683401585, 0.0316622071, & - & 0.9634116888, 0.0365910083 / - -!........................................! - end module module_radlw_kgb16 ! -!========================================! diff --git a/src/fim/FIMsrc/fim/column/radlw_main.f b/src/fim/FIMsrc/fim/column/radlw_main.f deleted file mode 100644 index e6f12ca..0000000 --- a/src/fim/FIMsrc/fim/column/radlw_main.f +++ /dev/null @@ -1,4220 +0,0 @@ -!!!!! ========================================================== !!!!! -!!!!! rrtm1 radiation package description !!!!! -!!!!! ========================================================== !!!!! -! ! -! the rrtm1 package includes these parts: ! -! ! -! 'radlw_rrtm1_param.f' ! -! 'radlw_rrtm1_datatb.f' ! -! 'radlw_rrtm1_main.f' ! -! ! -! the 'radlw_rrtm1_param.f' contains: ! -! ! -! 'module_radlw_cntr_para' -- control parameters set up ! -! 'module_radlw_parameters' -- band parameters set up ! -! ! -! the 'radlw_rrtm1_datatb.f' contains: ! -! ! -! 'module_radlw_avplank' -- plank flux data ! -! 'module_radlw_cldprlw' -- cloud property coefficients ! -! 'module_radlw_kgbnn' -- absorption coeffients for 16 ! -! bands, where nn = 01-16 ! -! ! -! the 'radlw_rrtm1_main.f' contains: ! -! ! -! 'module_radlw_main' -- main lw radiation transfer ! -! ! -! in the main module 'module_radlw_main' there are only two ! -! externally callable subroutines: ! -! ! -! ! -! 'lwrad' -- main rrtm1 lw radiation routine ! -! inputs: ! -! (pmid,pint,tmid,tint,qnm,o3mr,gasvmr, ! -! clouds,iovr,aerosols,sfemis, ! -! NPTS, NLAY, NLP1, iflip, lprnt, ! -! outputs: ! -! hlwc,topflx,sfcflx, ! -!! optional outputs: ! -! HLW0,HLWB,FLXPRF) ! -! ! -! 'rlwinit' -- initialization routine ! -! inputs: ! -! ( icwp, me, NLAY ) ! -! outputs: ! -! (none) ! -! ! -! all the lw radiation subprograms become contained subprograms ! -! in module 'module_radlw_main' and many of them are not directly ! -! accessable from places outside the module. ! -! ! -! ! -! derived data type constructs used: ! -! ! -! 1. radiation flux at toa: (from module 'module_radlw_parameters')! -! topflw_type - derived data type for toa rad fluxes ! -! upfxc total sky upward flux at toa ! -! upfx0 clear sky upward flux at toa ! -! ! -! 2. radiation flux at sfc: (from module 'module_radlw_parameters')! -! sfcflw_type - derived data type for sfc rad fluxes ! -! upfxc total sky upward flux at sfc ! -! upfx0 clear sky upward flux at sfc ! -! dnfxc total sky downward flux at sfc ! -! dnfx0 clear sky downward flux at sfc ! -! ! -! 3. radiation flux profiles(from module 'module_radlw_parameters')! -! proflw_type - derived data type for rad vertical prof ! -! upfxc level upward flux for total sky ! -! dnfxc level downward flux for total sky ! -! upfx0 level upward flux for clear sky ! -! dnfx0 level downward flux for clear sky ! -! ! -! external modules referenced: ! -! ! -! 'module machine' ! -! 'module physcons' ! -! ! -! compilation sequence is: ! -! ! -! 'radlw_rrtm1_param.f' ! -! 'radlw_rrtm1_datatb.f' ! -! 'radlw_rrtm1_main.f' ! -! ! -! and all should be put in front of routines that use lw modules ! -! ! -! ! -! ! -! the original program declarations: ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Copyright 2002, 2003, Atmospheric & Environmental Research, Inc.(AER)! -! This software may be used, copied, or redistributed as long as it is ! -! not sold and this copyright notice is reproduced on each copy made. ! -! This model is provided as is without any express or implied warranties -! (http://www.rtweb.aer.com/) ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! rrtm ! -! ! -! rapid radiative transfer model ! -! ! -! atmospheric and environmental research, inc. ! -! 840 memorial drive ! -! cambridge, ma 02139 ! -! ! -! eli j. mlawer ! -! steven j. taubman~ ! -! shepard a. clough ! -! ! -! ~currently at gfdl ! -! ! -! email: mlawer@aer.com ! -! ! -! the authors wish to acknowledge the contributions of the ! -! following people: patrick d. brown, michael j. iacono, ! -! ronald e. farren, luke chen, robert bergstrom. ! -! ! -! ! -! ! -! ncep modifications history log: ! -! ! -! nov 1999, ken campana -- received the original code from aer ! -! updated to link up with ncep mrf model ! -! jun 2000, ken campana ! -! added option to call aer max/ran overlap ! -! 2001, shrinivas moorthi ! -! further updates for mrf model ! -! may 2001, yu-tai hou ! -! updated on trace gases and cloud property based on ! -! rrtm_v3.0 codes ! -! dec 2001, yu-tai hou ! -! rewritten code into fortran 90 ! -! jun 2004, yu-tai hou ! -! add mike iacono's apr 2004 modification of variable ! -! diffusivity angle ! -! apr 2005, yu-tai hou ! -! minor modifications on module structures ! -! mar 2007, yu-tai hou ! -! add aerosol effect for lw radiation ! -! apr 2007, yu-tai hou ! -! add spectral band heating as optional output ! -! ! -! ! -! ! -!!!!! ========================================================== !!!!! -!!!!! end descriptions !!!!! -!!!!! ========================================================== !!!!! - - - -!========================================! - module module_radlw_main ! -!........................................! -! - use machine, only : kind_phys - use physcons, only : con_g, con_cp, con_avgd, con_amd, & - & con_amw, con_amo3 - - use module_radlw_parameters - use module_radlw_cntr_para -! - implicit none -! - private -! -! ... version tag and last revision date -! character(24), parameter :: VTAGLW='RRTM-LW v2.3g Apr 2004' -! character(24), parameter :: VTAGLW='RRTM-LW v2.3g Mar 2007' - character(24), parameter :: VTAGLW='RRTM-LW v2.3g Apr 2007' - -! --- constant values - real (kind=kind_phys) :: eps, oneminus, bpade, stpfac, wtnum & - &, co2fac, f_zero - - parameter (eps=1.0e-6, oneminus=1.0-eps) - parameter (bpade=1.0/0.278) ! pade approximation constant - parameter (stpfac=296./1013.) - parameter (wtnum=0.5) -! parameter (avgdro=6.022e23) ! avogadro constant (1/mol) -!mji parameter (secang=1.66) ! diffusivity angle - parameter (co2fac=3.55e-4) ! factor for cal. of co2mult - parameter (f_zero=0.0) - -! ... atomic weights for conversion from mass to volume mixing ratios - real (kind=kind_phys) :: amdw, amdo3 - - parameter (amdw =con_amd/con_amw) - parameter (amdo3=con_amd/con_amo3) - -! ... band indices - integer :: nspa(NBANDS), nspb(NBANDS), ngb(NGPT) - - data nspa / 1, 1,10, 9, 9, 1, 9, 1,11, 1, 1, 9, 9, 1, 9, 9 / - data nspb / 1, 1, 5, 6, 5, 0, 1, 1, 1, 1, 1, 0, 0, 1, 0, 0 / - data ngb / 8*1, 14*2, 16*3, 14*4, 16*5, 8*6, 12*7, 8*8, & - & 12*9, 6*10, 8*11, 8*12, 4*13, 2*14, 2*15, 2*16 / - -! ... band wavenumber intervals -! real (kind=kind_phys) :: wavenum1(NBANDS), wavenum2(NBANDS) -! data wavenum1/ & -! & 10., 250., 500., 630., 700., 820., 980., 1080., & -! & 1180., 1390., 1480., 1800., 2080., 2250., 2380., 2600. / -! data wavenum2/ & -! & 250., 500., 630., 700., 820., 980., 1080., 1180., & -! & 1390., 1480., 1800., 2080., 2250., 2380., 2600., 3000. / - real (kind=kind_phys) :: delwave(NBANDS) - data delwave / 240., 250., 130., 70., 120., 160., 100., 100., & - & 210., 90., 320., 280., 170., 130., 220., 400. / - -!mji ... coefficients for variable diffusivity angle - real (kind=kind_phys), dimension(NBANDS) :: a0, a1, a2 - data a0 / 1.66, 1.55, 1.58, 1.66, 1.54,1.454, 1.89, 1.33, & - & 1.668, 1.66, 1.66, 1.66, 1.66, 1.66, 1.66, 1.66 / - data a1 / 0.00, 0.25, 0.22, 0.00, 0.13,0.446,-0.10, 0.40, & - & -0.006, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - data a2 / 0.00,-12.0,-11.7, 0.00,-0.72,-0.243,0.19,-0.062, & - & 0.414, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - -! --- reference pressure and temperature - real (kind=kind_phys), dimension(59) :: pref, preflog, tref - -! ... these pressures are chosen such that the ln of the first one -! has only a few non-zero digits (i.e. ln(pref(1)) = 6.96000) and -! each subsequent ln(pref) differs from the previous one by 0.2. - data pref / & - & 1.05363e+03,8.62642e+02,7.06272e+02,5.78246e+02,4.73428e+02, & - & 3.87610e+02,3.17348e+02,2.59823e+02,2.12725e+02,1.74164e+02, & - & 1.42594e+02,1.16746e+02,9.55835e+01,7.82571e+01,6.40715e+01, & - & 5.24573e+01,4.29484e+01,3.51632e+01,2.87892e+01,2.35706e+01, & - & 1.92980e+01,1.57998e+01,1.29358e+01,1.05910e+01,8.67114e+00, & - & 7.09933e+00,5.81244e+00,4.75882e+00,3.89619e+00,3.18993e+00, & - & 2.61170e+00,2.13828e+00,1.75067e+00,1.43333e+00,1.17351e+00, & - & 9.60789e-01,7.86628e-01,6.44036e-01,5.27292e-01,4.31710e-01, & - & 3.53455e-01,2.89384e-01,2.36928e-01,1.93980e-01,1.58817e-01, & - & 1.30029e-01,1.06458e-01,8.71608e-02,7.13612e-02,5.84256e-02, & - & 4.78349e-02,3.91639e-02,3.20647e-02,2.62523e-02,2.14936e-02, & - & 1.75975e-02,1.44076e-02,1.17959e-02,9.65769e-03 / - data preflog / & - & 6.9600e+00, 6.7600e+00, 6.5600e+00, 6.3600e+00, 6.1600e+00, & - & 5.9600e+00, 5.7600e+00, 5.5600e+00, 5.3600e+00, 5.1600e+00, & - & 4.9600e+00, 4.7600e+00, 4.5600e+00, 4.3600e+00, 4.1600e+00, & - & 3.9600e+00, 3.7600e+00, 3.5600e+00, 3.3600e+00, 3.1600e+00, & - & 2.9600e+00, 2.7600e+00, 2.5600e+00, 2.3600e+00, 2.1600e+00, & - & 1.9600e+00, 1.7600e+00, 1.5600e+00, 1.3600e+00, 1.1600e+00, & - & 9.6000e-01, 7.6000e-01, 5.6000e-01, 3.6000e-01, 1.6000e-01, & - & -4.0000e-02,-2.4000e-01,-4.4000e-01,-6.4000e-01,-8.4000e-01, & - & -1.0400e+00,-1.2400e+00,-1.4400e+00,-1.6400e+00,-1.8400e+00, & - & -2.0400e+00,-2.2400e+00,-2.4400e+00,-2.6400e+00,-2.8400e+00, & - & -3.0400e+00,-3.2400e+00,-3.4400e+00,-3.6400e+00,-3.8400e+00, & - & -4.0400e+00,-4.2400e+00,-4.4400e+00,-4.6400e+00 / -! ... these are the temperatures associated with the respective -! pressures for the MLS standard atmosphere. - data tref / & - & 2.9420E+02, 2.8799E+02, 2.7894E+02, 2.6925E+02, 2.5983E+02, & - & 2.5017E+02, 2.4077E+02, 2.3179E+02, 2.2306E+02, 2.1578E+02, & - & 2.1570E+02, 2.1570E+02, 2.1570E+02, 2.1706E+02, 2.1858E+02, & - & 2.2018E+02, 2.2174E+02, 2.2328E+02, 2.2479E+02, 2.2655E+02, & - & 2.2834E+02, 2.3113E+02, 2.3401E+02, 2.3703E+02, 2.4022E+02, & - & 2.4371E+02, 2.4726E+02, 2.5085E+02, 2.5457E+02, 2.5832E+02, & - & 2.6216E+02, 2.6606E+02, 2.6999E+02, 2.7340E+02, 2.7536E+02, & - & 2.7568E+02, 2.7372E+02, 2.7163E+02, 2.6955E+02, 2.6593E+02, & - & 2.6211E+02, 2.5828E+02, 2.5360E+02, 2.4854E+02, 2.4348E+02, & - & 2.3809E+02, 2.3206E+02, 2.2603E+02, 2.2000E+02, 2.1435E+02, & - & 2.0887E+02, 2.0340E+02, 1.9792E+02, 1.9290E+02, 1.8809E+02, & - & 1.8329E+02, 1.7849E+02, 1.7394E+02, 1.7212E+02 / - -!! --- logical flags for optional output fields - - logical :: lhlwb = .false. - logical :: lhlw0 = .false. - logical :: lflxprf= .false. - -! --- those data will be set up only once by "rlwinit" - -! ... fluxfac, heatfac are factors for fluxes (in w/m**2) and heating -! rates (in k/day, or k/sec set by subroutine 'rlwinit') -! semiss0 are default surface emissivity for each bands - - real (kind=kind_phys) :: fluxfac, heatfac, semiss0(NBANDS) - - real (kind=kind_phys), dimension(0:N5000) :: tau, tf, trans - real (kind=kind_phys), dimension(0:N200 ) :: corr1, corr2 - - public lwrad, rlwinit - - -! ================= - contains -! ================= - -!----------------------------------- - subroutine lwrad & -!................................... - -! --- inputs: - & ( pmid,pint,tmid,tint,qnm,o3mr,gasvmr, & - & clouds,iovr,aerosols,sfemis, & - & NPTS, NLAY, NLP1, iflip, lprnt, & -! --- outputs: - & hlwc,topflx,sfcflx & -!! --- optional: - &, HLW0,HLWB,FLXPRF & - & ) - -! ==================== defination of variables =================== ! -! ! -! input variables: ! -! pmid (NPTS,NLAY) - layer pressures (mb) ! -! pint (NPTS,NLP1) - interface pressures (mb) ! -! tmid (NPTS,NLAY) - layer temperature (k) ! -! tint (NPTS,NLP1) - interface temperatures (k) ! -! qnm (NPTS,NLAY) - layer h2o mixing ratio (gm/gm)*see inside! -! o3mr (NPTS,NLAY) - layer o3 mixing ratio (gm/gm) *see inside! -! gasvmr (NPTS,NLAY,:) - atmospheric gases amount: ! -! (check module_radiation_gases for definition) ! -! gasvmr(:,:,1) - co2 volume mixing ratio ! -! gasvmr(:,:,2) - n2o volume mixing ratio ! -! gasvmr(:,:,3) - ch4 volume mixing ratio ! -! gasvmr(:,:,4) - o2 volume mixing ratio ! -! gasvmr(:,:,5) - co volume mixing ratio ! -! gasvmr(:,:,6) - cfc11 volume mixing ratio ! -! gasvmr(:,:,7) - cfc12 volume mixing ratio ! -! gasvmr(:,:,8) - cfc22 volume mixing ratio ! -! gasvmr(:,:,9) - ccl4 volume mixing ratio ! -! clouds (NPTS,NLAY,:) - layer cloud profiles: ! -! (check module_radiation_clouds for definition) ! -! --- for iflagliq > 0 --- ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! -! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! -! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! -! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! -! clouds(:,:,6) - layer rain drop water path (g/m**2) ! -! clouds(:,:,7) - mean eff radius for rain drop (micron) ! -! clouds(:,:,8) - layer snow flake water path (g/m**2) ! -! ** fu's scheme need to be normalized by snow density (g/m**3/1.0e6)! -! clouds(:,:,9) - mean eff radius for snow flake (micron) ! -! --- for iflagliq = 0 --- ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud optical depth ! -! clouds(:,:,3) - layer cloud single scattering albedo ! -! clouds(:,:,4) - layer cloud asymmetry factor ! -! iovr - control flag for cloud overlapping ! -! =0: random overlapping clouds ! -! =1: max/ran overlapping clouds ! -! aerosols(NPTS,NLAY,NBANDS,:) - aerosol optical properties ! -! (check module_radiation_aerosols for definition! -! (:,:,:,1) - optical depth ! -! (:,:,:,2) - single scattering albedo ! -! (:,:,:,3) - asymmetry parameter ! -! sfemis (NPTS) - surface emissivity ! -! NPTS - total number of horizontal points ! -! NLAY,NLP1 - total number of vertical layers, levels ! -! iflip - control flag for in/out vertical index ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! lprnt - cntl flag for diagnostic print out ! -! ! -! control parameters in module "module_radlw_cntr_para": ! -! ilwrate - heating rate unit selections ! -! =1: output in k/day ! -! =2: output in k/second ! -! iaerlw - control flag for aerosols ! -! =0: do not include aerosol effect ! -! >0: include aerosol effect ! -! irgaslw - control flag for rare gases ! -! (ch4,n2o,o2, etc.) ! -! =0: do not include rare gases ! -! =1: include all rare gases ! -! icfclw - control flag for cfc gases ! -! =0: do not include cfc gases ! -! =1: include all cfc gases ! -! iflagliq - liq-cloud optical properties contrl flag ! -! =0: input cld opt dep, ignor iflagice ! -! =1: input cwp,cip, (ccm2) ignor iflagice ! -! =2: input cwp rew, (ccm3 method) ! -! =3: input cwp rew, hu and stamnes (1993) ! -! iflagice - ice-cloud optical properties contrl flag ! -! * * * if iflagliq .lt. 2, iflafice is ignored ! -! =0: input cip rei, (ccm3 method) ! -! =1: input cip rei, ebert and curry (1997)! -! =2: input cip rei, streamer (1996) ! -! ! -! output variables: ! -! hlwc (NPTS,NLAY) - total sky heating rate (k/day or k/sec) ! -! topflx (NPTS) - radiation fluxes at top, component: ! -! (check module_radlw_paramters for definition) ! -! upfxc total sky upward flux at top (w/m2) ! -! upfx0 clear sky upward flux at top (w/m2) ! -! sfcflx (NPTS) - radiation fluxes at sfc, component: ! -! (check module_radlw_paramters for definition) ! -! upfxc total sky upward flux at sfc (w/m2) ! -! upfx0 clear sky upward flux at sfc (w/m2) ! -! dnfxc total sky downward flux at sfc (w/m2) ! -! dnfx0 clear sky downward flux at sfc (w/m2) ! -! ! -!! optional output variables: ! -! hlwb(NPTS,NLAY,NBANDS)- spectral band total sky heating rates ! -! hlw0 (NPTS,NLAY) - clear sky heating rate (k/day or k/sec) ! -! flxprf (NPTS,NLP1) - level radiative fluxes (w/m2), components! -! (check module_radlw_paramters for definition) ! -! upfxc total sky upward flux ! -! dnfxc total sky dnward flux ! -! upfx0 clear sky upward flux ! -! dnfx0 clear sky dnward flux ! -! ! -! module parameters, control and local variables: ! -! NBANDS - number of longwave spectral bands ! -! MAXGAS - maximum number of absorbing gaseous ! -! MAXXSEC - maximum number of cross-sections ! -! NGPT - total number of g-point subintervals ! -! NGnn (nn=1-16) - number of g-points in band nn ! -! nspa,nspb(NBANDS) - number of lower/upper ref atm's per band ! -! delwave(NBANDS) - longwave band width (wavenumbers) ! -! bpade - pade approximation constant (1/0.278) ! -! pavel (NLAY) - layer pressures (mb) ! -! delp (NLAY) - layer pressure thickness (mb) ! -! tavel (NLAY) - layer temperatures (k) ! -! tz (0:NLAY) - level (interface) temperatures (k) ! -! semiss (NBANDS) - surface emissivity for each band ! -! wx (NLAY,MAXXSEC) - cross-section molecules concentration ! -! coldry (NLAY) - dry air column amount ! -! (1.e-20*molecules/cm**2) ! -! cldfrac(0:NLP1) - layer cloud fraction ! -! taucloud(NBANDS,NLAY) - layer cloud optical depth for each band ! -! taug (NGPT,NLAY) - gaseous optical depths ! -! pfrac (NGPT,NLAY) - planck fractions ! -! itr (NGPT,NLAY) - integer look-up table index ! -! colamt (NLAY,MAXGAS) - column amounts of absorbing gases ! -! 1-MAXGAS are for watervapor, carbon ! -! dioxide, ozone, nitrous oxide, methane, ! -! oxigen, carbon monoxide, respectively ! -! (molecules/cm**2) ! -! pwvcm - column precipitable water vapor (cm) ! -! secdiff(NBANDS) - variable diffusivity angle defined as ! -! an exponential function of the column ! -! water amount in bands 2-3 and 5-9. ! -! this reduces the bias of several w/m2 in ! -! downward surface flux in high water ! -! profiles caused by using the constant ! -! diffusivity angle of 1.66. (mji) ! -! co2mult(NLAY) - the factor used to multiply the ave co2 ! -! abs coeff to get the added contribution ! -! to the optical depth relative to 355 ppm.! -! facij (NLAY) - indicator of interpolation factors ! -! =0/1: indicate lower/higher temp & height! -! selffac(NLAY) - scale factor for self-continuum, equals ! -! (w.v. density)/(atm density at 296K,1013 mb)! -! selffrac(NLAY) - factor for temp interpolation of ref ! -! self-continuum data ! -! indself(NLAY) - index of the lower two appropriate ref ! -! temp for the self-continuum interpolation! -! laytrop,layswtch,laylow ! -! - layer at which switch is made from one ! -! combination of key species to another ! -! totuflux(0:NLAY) - upward longwave flux (w/m2) ! -! totdflux(0:NLAY) - downward longwave flux (w/m2) ! -! totuclfl(0:NLAY) - clear-sky upward longwave flux (w/m2) ! -! totdclfl(0:NLAY) - clear-sky downward longwave flux (w/m2) ! -! fnet (0:NLAY) - net longwave flux (w/m2) ! -! fnetc (0:NLAY) - clear-sky net longwave flux (w/m2) ! -! ! -! ! -! ===================== end of definitions =================== ! -! - implicit none - -! --- inputs: - integer, intent(in) :: NPTS, NLAY, NLP1, iovr, iflip - - logical, intent(in) :: lprnt - - real (kind=kind_phys), dimension(:,:), intent(in) :: pint, tint, & - & pmid, tmid, qnm, o3mr - - real (kind=kind_phys), dimension(:,:,:),intent(in) :: gasvmr, & - & clouds - - real (kind=kind_phys), dimension(:), intent(in) :: sfemis - - real (kind=kind_phys), dimension(:,:,:,:),intent(in) :: aerosols - -! --- outputs: - real (kind=kind_phys), dimension(:,:), intent(out) :: hlwc - - type (topflw_type), dimension(:), intent(out) :: topflx - type (sfcflw_type), dimension(:), intent(out) :: sfcflx - -!! --- optional outputs: - real (kind=kind_phys),dimension(:,:,:),optional,intent(out):: hlwb - real (kind=kind_phys),dimension(:,:),optional,intent(out):: hlw0 - type (proflw_type), dimension(:,:),optional,intent(out):: flxprf - -! --- locals: - real (kind=kind_phys), dimension(0:NLP1) :: cldfrac - - real (kind=kind_phys), dimension(0:NLAY) :: totuflux, totdflux, & - & totuclfl, totdclfl, tz - - real (kind=kind_phys), dimension(NLAY) :: htr, htrcl - - real (kind=kind_phys), dimension(NLAY) :: pavel, tavel, delp, & - & taucl, cwp1, cip1, rew1, rei1, cda1, cda2, cda3, cda4, & - & coldry, co2mult, h2ovmr, o3vmr, fac00, fac01, fac10, & - & fac11, forfac, plog, selffac, selffrac, temcol - - real (kind=kind_phys) :: colamt(NLAY,MAXGAS), wx(NLAY,MAXXSEC), & - & taucloud(NBANDS,NLAY), pfrac(NGPT,NLAY), semiss(NBANDS), & - & secdiff(NBANDS), tauaer(NBANDS,NLAY), htrb(NLAY,NBANDS) - - real (kind=kind_phys) :: fp, ft, ft1, tem0, tem1, tem2, pwvcm - - integer, dimension(NLAY) :: jp, jt, jt1, indself - integer :: itr(NGPT,NLAY), laytrop, layswtch, & - & laylow, jp1, j, k, k1, iplon -! -!===> ... begin here -! - - lhlwb = present ( hlwb ) - lhlw0 = present ( hlw0 ) - lflxprf= present ( flxprf ) - -! --- loop over horizontal NPTS profiles - - lab_do_iplon : do iplon = 1, NPTS - - if (sfemis(iplon) > eps .and. sfemis(iplon) <= 1.0) then ! input surface emissivity - do j = 1, NBANDS - semiss(j) = sfemis(iplon) - enddo - else ! use default values - do j = 1, NBANDS - semiss(j) = semiss0(j) - enddo - endif - -! --- prepare atmospheric profile for use in rrtm -! the vertical index of internal array is from surface to top - - if (iflip == 0) then ! input from toa to sfc - - tem1 = 100.0 * con_g - tem2 = 1.0e-20 * 1.0e3 * con_avgd - tz(0) = tint(iplon,NLP1) - - do k = 1, NLAY - k1 = NLP1 - k - pavel(k)= pmid(iplon,k1) - delp(k) = pint(iplon,k1+1) - pint(iplon,k1) - tavel(k)= tmid(iplon,k1) - tz(k) = tint(iplon,k1) - -! --- set absorber amount -!test use -! h2ovmr(k)= max(f_zero,qnm(iplon,k1)*amdw) ! input mass mixing ratio -! h2ovmr(k)= max(f_zero,qnm(iplon,k1)) ! input vol mixing ratio -!ncep model use - h2ovmr(k)= max(f_zero, & - & qnm(iplon,k1)*amdw/(1.0-qnm(iplon,k1))) ! input specific humidity - o3vmr (k)= max(f_zero,o3mr(iplon,k1)*amdo3) ! input mass mixing ratio -!test use o3vmr (k)= max(f_zero,o3mr(iplon,k1)) ! input vol mixing ratio - - tem0 = (1.0 - h2ovmr(k))*con_amd + h2ovmr(k)*con_amw - coldry(k) = tem2 * delp(k) / (tem1*tem0*(1.0 + h2ovmr(k))) - temcol(k) = 1.0e-12 * coldry(k) - - colamt(k,1) = coldry(k)*h2ovmr(k) ! h2o - colamt(k,2) = max(temcol(k), coldry(k)*gasvmr(iplon,k1,1)) ! co2 - colamt(k,3) = coldry(k)*o3vmr(k) ! o3 - enddo - -! --- set aerosol optical properties - - if (iaerlw > 0) then - do k = 1, NLAY - k1 = NLP1 - k - do j = 1, NBANDS - tauaer(j,k) = aerosols(iplon,k1,j,1) & - & * (1.0 - aerosols(iplon,k1,j,2)) - enddo - enddo - else - tauaer(:,:) = f_zero - endif - - if (iflagliq > 0) then ! use prognostic cloud method - do k = 1, NLAY - k1 = NLP1 - k - cldfrac(k)= clouds(iplon,k1,1) - cwp1 (k) = clouds(iplon,k1,2) - rew1 (k) = clouds(iplon,k1,3) - cip1 (k) = clouds(iplon,k1,4) - rei1 (k) = clouds(iplon,k1,5) - cda1 (k) = clouds(iplon,k1,6) - cda2 (k) = clouds(iplon,k1,7) - cda3 (k) = clouds(iplon,k1,8) - cda4 (k) = clouds(iplon,k1,9) - enddo - else ! use diagnostic cloud method - do k = 1, NLAY - k1 = NLP1 - k - cldfrac(k)= clouds(iplon,k1,1) - cda1(k) = clouds(iplon,k1,2) - enddo - endif ! end if_iflagliq - - cldfrac(0) = 1.0 ! padding value only - cldfrac(NLP1) = f_zero ! padding value only - - else ! input from sfc to toa - - tem1 = 100.0 * con_g - tem2 = 1.0e-20 * 1.0e3 * con_avgd - tz(0) = tint(iplon,1) - - do k = 1, NLAY - pavel(k)= pmid(iplon,k) - delp(k) = pint(iplon,k) - pint(iplon,k+1) - tavel(k)= tmid(iplon,k) - tz(k) = tint(iplon,k+1) - -! --- set absorber amount -!test use -! h2ovmr(k)= max(f_zero,qnm(iplon,k)*amdw) ! input mass mixing ratio -! h2ovmr(k)= max(f_zero,qnm(iplon,k)) ! input vol mixing ratio -!ncep model use - h2ovmr(k)= max(f_zero,qnm(iplon,k)*amdw/(1.0-qnm(iplon,k))) ! input specific humidity - o3vmr (k)= max(f_zero,o3mr(iplon,k)*amdo3) ! input mass mixing ratio -!test use o3vmr (k)= max(f_zero,o3mr(iplon,k)) ! input vol mixing ratio - - tem0 = (1.0 - h2ovmr(k))*con_amd + h2ovmr(k)*con_amw - coldry(k) = tem2 * delp(k) / (tem1*tem0*(1.0 + h2ovmr(k))) - temcol(k) = 1.0e-12 * coldry(k) - - colamt(k,1) = coldry(k)*h2ovmr(k) ! h2o - colamt(k,2) = max(temcol(k), coldry(k)*gasvmr(iplon,k,1)) ! co2 - colamt(k,3) = coldry(k)*o3vmr(k) ! o3 - enddo - -! --- set aerosol optical properties - - if (iaerlw > 0) then - do k = 1, NLAY - do j = 1, NBANDS - tauaer(j,k) = aerosols(iplon,k,j,1) & - & * (1.0 - aerosols(iplon,k,j,2)) - enddo - enddo - else - tauaer(:,:) = f_zero - endif - - if (iflagliq > 0) then ! use prognostic cloud method - do k = 1, NLAY - cldfrac(k)= clouds(iplon,k,1) - cwp1 (k) = clouds(iplon,k,2) - rew1 (k) = clouds(iplon,k,3) - cip1 (k) = clouds(iplon,k,4) - rei1 (k) = clouds(iplon,k,5) - cda1 (k) = clouds(iplon,k,6) - cda2 (k) = clouds(iplon,k,7) - cda3 (k) = clouds(iplon,k,8) - cda4 (k) = clouds(iplon,k,9) - enddo - else ! use diagnostic cloud method - do k = 1, NLAY - cldfrac(k)= clouds(iplon,k,1) - cda1(k) = clouds(iplon,k,2) - enddo - endif - - cldfrac(0) = 1.0 ! padding value only - cldfrac(NLP1) = f_zero ! padding value only - - endif ! if_iflip - -! --- set up col amount for rare gases, convert from volume mixing ratio to -! molec/cm2 based on coldry (scaled to 1.0e-20) for use in rrtm - - if (iflip == 0) then ! input from toa to sfc - - if (irgaslw == 1) then - do k = 1, NLAY - k1 = NLP1 - k - colamt(k,4)=max(temcol(k), coldry(k)*gasvmr(iplon,k1,2)) ! n2o - colamt(k,5)=max(temcol(k), coldry(k)*gasvmr(iplon,k1,3)) ! ch4 -! colamt(k,6)=max(f_zero, coldry(k)*gasvmr(iplon,k1,4)) ! o2 - not used -! colamt(k,7)=max(f_zero, coldry(k)*gasvmr(iplon,k1,5)) ! co - not used - enddo - else - do k = 1, NLAY - colamt(k,4) = f_zero ! n2o - colamt(k,5) = f_zero ! ch4 -! colamt(k,6) = f_zero ! o2 - not used -! colamt(k,7) = f_zero ! co - not used - enddo - endif - - if (icfclw == 1) then - do k = 1, NLAY - k1 = NLP1 - k - wx(k,1) = max( f_zero, coldry(k)*gasvmr(iplon,k1,9) ) ! ccl4 - wx(k,2) = max( f_zero, coldry(k)*gasvmr(iplon,k1,6) ) ! cf11 - wx(k,3) = max( f_zero, coldry(k)*gasvmr(iplon,k1,7) ) ! cf12 - wx(k,4) = max( f_zero, coldry(k)*gasvmr(iplon,k1,8) ) ! cf22 - enddo - else - wx(:,:) = f_zero - endif - -! mji - for variable diffusivity angle, sum moist atmos and water over column - tem1 = f_zero - tem2 = f_zero - do k = 1, NLAY - tem1 = tem1 + coldry(k) + colamt(k,1) - tem2 = tem2 + colamt(k,1) - enddo -! mji - calculate column precipitable water and variable diffusivity angle -! tem3 = tem2 / (amdw * tem1) -! pwvcm = tem3 * (1.0e3 * pint(iplon,NLP1)) / (1.0e2 * con_g) - pwvcm = 10.0 * pint(iplon,NLP1) * tem2 /(amdw * tem1* con_g) - - else ! input from sfc to toa - - if (irgaslw == 1) then - do k = 1, NLAY - colamt(k,4)=max(temcol(k), coldry(k)*gasvmr(iplon,k,2)) ! n2o - colamt(k,5)=max(temcol(k), coldry(k)*gasvmr(iplon,k,3)) ! ch4 -! colamt(k,6)=max(f_zero, coldry(k)*gasvmr(iplon,k,4)) ! o2 - not used -! colamt(k,7)=max(f_zero, coldry(k)*gasvmr(iplon,k,5)) ! co - not used - enddo - else - do k = 1, NLAY - colamt(k,4) = f_zero ! n2o - colamt(k,5) = f_zero ! ch4 -! colamt(k,6) = f_zero ! o2 - not used -! colamt(k,7) = f_zero ! co - not used - enddo - endif - - if (icfclw == 1) then - do k = 1, NLAY - wx(k,1) = max( f_zero, coldry(k)*gasvmr(iplon,k,9) ) ! ccl4 - wx(k,2) = max( f_zero, coldry(k)*gasvmr(iplon,k,6) ) ! cf11 - wx(k,3) = max( f_zero, coldry(k)*gasvmr(iplon,k,7) ) ! cf12 - wx(k,4) = max( f_zero, coldry(k)*gasvmr(iplon,k,8) ) ! cf22 - enddo - else - wx(:,:) = f_zero - endif - -! mji - for variable diffusivity angle, sum moist atmos and water over column - tem1 = f_zero - tem2 = f_zero - do k = 1, NLAY - tem1 = tem1 + coldry(k) + colamt(k,1) - tem2 = tem2 + colamt(k,1) - enddo -! mji - calculate column precipitable water and variable diffusivity angle -! tem3 = tem2 / (amdw * tem1) -! pwvcm = tem3 * (1.0e3 * pint(iplon,1)) / (1.0e2 * con_g) - pwvcm = 10.0 * pint(iplon,1) * tem2 /(amdw * tem1* con_g) - - endif ! if_iflip - - do j = 1, NBANDS - if (j==1 .or. j==4 .or. j==10) then - secdiff(j) = 1.66 - else - secdiff(j) = a0(j) + a1(j) * exp( a2(j)*pwvcm ) - endif - enddo - if (pwvcm < 1.0) secdiff(6) = 1.80 - if (pwvcm > 7.1) secdiff(7) = 1.50 -! mji - - do k = 1, NLAY -! ... using e = 1334.2 cm-1. - tem1 = co2fac * coldry(k) - co2mult(k) = (colamt(k,2) - tem1) * 272.63 & - & * exp(-1919.4/tavel(k)) / (8.7604e-4*tavel(k)) - forfac(k) = pavel(k)*stpfac / (tavel(k)*(1.0 + h2ovmr(k))) - enddo - -! if (lprnt) then -! print *,' coldry',coldry -! print *,' wx(*,1) ',(wx(k,1),k=1,NLAY) -! print *,' wx(*,2) ',(wx(k,2),k=1,NLAY) -! print *,' wx(*,3) ',(wx(k,3),k=1,NLAY) -! print *,' wx(*,4) ',(wx(k,4),k=1,NLAY) -! print *,' iplon ',iplon -! print *,' pavel ',pavel -! print *,' delp ',delp -! print *,' tavel ',tavel -! print *,' tz ',tz -! print *,' h2ovmr ',h2ovmr -! print *,' o3vmr ',o3vmr -! endif - -! --- calculate cloud optical properties - - call cldprop & -! --- inputs: - & ( cldfrac, cwp1, cip1, rew1, rei1, cda1, cda2, cda3, cda4, & - & NLAY, NLP1, & -! --- output: - & taucloud & - & ) - -! if (lprnt) then -! print *,' after cldprop' -! print *,' cwp1',cwp1 -! print *,' cip1',cip1 -! print *,' rew1',rew1 -! print *,' rei1',rei1 -! print *,' taucl',cda1 -! print *,' cldfrac',cldfrac -! print *,' taucloud',taucloud -! endif - -! --- calculate information needed by the radiative transfer routine -! that is specific to this atmosphere, especially some of the -! coefficients and indices needed to compute the optical depths -! by interpolating data from stored reference atmospheres. - - laytrop = 0 - layswtch= 0 - laylow = 0 - - do k = 1, NLAY - -! --- find the two reference pressures on either side of the -! layer pressure. store them in jp and jp1. store in fp the -! fraction of the difference (in ln(pressure)) between these -! two values that the layer pressure lies. - - plog(k) = log(pavel(k)) - jp(k)= max(1, min(58, int(36.0 - 5.0*(plog(k)+0.04)) )) - jp1 = jp(k) + 1 -! --- limit pressure extrapolation at the top - fp = max(f_zero, min(1.0, 5.0*(preflog(jp(k))-plog(k)) )) -!org fp = 5.0 * (preflog(jp(k)) - plog(k)) - -! --- determine, for each reference pressure (jp and jp1), which -! reference temperature (these are different for each -! reference pressure) is nearest the layer temperature but does -! not exceed it. store these indices in jt and jt1, resp. -! store in ft (resp. ft1) the fraction of the way between jt -! (jt1) and the next highest reference temperature that the -! layer temperature falls. - - tem1 = (tavel(k) - tref(jp(k))) / 15.0 - tem2 = (tavel(k) - tref(jp1 )) / 15.0 - jt (k) = max(1, min(4, int(3.0 + tem1) )) - jt1(k) = max(1, min(4, int(3.0 + tem2) )) -! --- restrict extrapolation ranges by limiting abs(det t) < 37.5 deg - ft = max(-0.5, min(1.5, tem1 - float(jt (k) - 3) )) - ft1 = max(-0.5, min(1.5, tem2 - float(jt1(k) - 3) )) -!org ft = tem1 - float(jt (k) - 3) -!org ft1 = tem2 - float(jt1(k) - 3) - -! --- we have now isolated the layer ln pressure and temperature, -! between two reference pressures and two reference temperatures -! (for each reference pressure). we multiply the pressure -! fraction fp with the appropriate temperature fractions to get -! the factors that will be needed for the interpolation that yields -! the optical depths (performed in routines taugbn for band n). - - fac10(k) = (1.0 - fp) * ft - fac00(k) = (1.0 - fp) * (1.0 - ft) - fac11(k) = fp * ft1 - fac01(k) = fp * (1.0 - ft1) - - enddo - -! --- if the pressure is less than ~100mb, perform a different -! set of species interpolations. - - do k = 1, NLAY - if (plog(k) > 4.56) then - laytrop = laytrop + 1 - -! --- for one band, the "switch" occurs at ~300 mb. - if (plog(k) >= 5.76) layswtch = layswtch + 1 - if (plog(k) >= 6.62) laylow = laylow + 1 - -! --- set up factors (tem1) needed to separately include the water -! vapor self-continuum in the calculation of absorption -! coefficient. - - tem1 = (tavel(k) - 188.0) / 7.2 - - selffac(k) = h2ovmr(k) * forfac(k) - indself(k) = min(9, max(1, int(tem1)-7 )) - selffrac(k)= tem1 - float(indself(k) + 7) - - else - - selffac(k) = f_zero - indself(k) = 0 - selffrac(k)= f_zero - - endif - enddo - -! --- set laylow for profiles with surface pressure less than 750mb. - if (laylow == 0) laylow = 1 - -! if (lprnt) then -! print *,'laytrop,layswtch,laylow',laytrop,layswtch,laylow -! print *,'colh2o',(colamt(k,1),k=1,NLAY) -! print *,'colco2',(colamt(k,2),k=1,NLAY) -! print *,'colo3', (colamt(k,3),k=1,NLAY) -! print *,'coln2o',(colamt(k,4),k=1,NLAY) -! print *,'colch4',(colamt(k,5),k=1,NLAY) -! print *,'co2mult',co2mult -! print *,'fac00',fac00 -! print *,'fac01',fac01 -! print *,'fac10',fac10 -! print *,'fac11',fac11 -! print *,'jp',jp -! print *,'jt',jt -! print *,'jt1',jt1 -! print *,'selffac',selffac -! print *,'selffrac',selffrac -! print *,'indself',indself -! print *,'forfac',forfac -! endif - - call taumol & -! --- inputs: - & ( laytrop,layswtch,laylow,h2ovmr,colamt,wx,co2mult, & - & fac00,fac01,fac10,fac11,jp,jt,jt1,selffac,selffrac, & - & indself,forfac,secdiff,tauaer, NLAY, & -! --- outputs: - & itr, pfrac & - & ) - -! if (lprnt) then -! print *,' after taumol' -! do k=1,NLAY -! write(6,123) k -!123 format(' k =',i3,5x,'PFRAC') -! write(6,122) (pfrac(j,k),j=1,NGPT) -!122 format(10e14.7) -! write(6,124) k -!124 format(' k =',i3,5x,'ITR') -! write(6,125) (itr(j,k),j=1,NGPT) -!125 format(10i10) -! enddo -! endif - -! --- call the radiative transfer routine. - - if (iovr == 0) then - - call rtrn & -! --- inputs: - & ( tavel,tz,delp,semiss,cldfrac,taucloud,pfrac, & - & secdiff, itr, NLAY, NLP1, & -! --- outputs: - & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb & - & ) - - else - -! write(6,*)'before call to rtrnmr' -! write(6,*)'tavel' -! write(6,*)tavel -! write(6,*)'tz' -! write(6,*)tz -! write(6,*)'delp' -! write(6,*)delp -! write(6,*)'semiss' -! write(6,*)semiss -! write(6,*)'cldfrac' -! write(6,*)cldfrac -! write(6,*)'taucloud' -! write(6,*)taucloud -! write(6,*)'pfrac' -! write(6,*)pfrac -! write(6,*)'secdiff' -! write(6,*)secdiff -! write(6,*)'totuflux' -! write(6,*)totuflux -! write(6,*)'totdflux' -! write(6,*)totdflux -! write(6,*)'htr' -! write(6,*)htr -! write(6,*)'totuclfl' -! write(6,*)totuclfl -! write(6,*)'totdclfl' -! write(6,*)totdclfl -! write(6,*)'htrcl' -! write(6,*)htrcl -! write(6,*)'htrb' -! write(6,*)htrb - call rtrnmr & -! --- inputs: - & ( tavel,tz,delp,semiss,cldfrac,taucloud,pfrac, & - & secdiff, itr, NLAY, NLP1, & -! --- outputs: - & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb & - & ) -! write(6,*)'after call to rtrnmr' -! write(6,*)'tavel' -! write(6,*)tavel -! write(6,*)'tz' -! write(6,*)tz -! write(6,*)'delp' -! write(6,*)delp -! write(6,*)'semiss' -! write(6,*)semiss -! write(6,*)'cldfrac' -! write(6,*)cldfrac -! write(6,*)'taucloud' -! write(6,*)taucloud -! write(6,*)'pfrac' -! write(6,*)pfrac -! write(6,*)'secdiff' -! write(6,*)secdiff -! write(6,*)'totuflux' -! write(6,*)totuflux -! write(6,*)'totdflux' -! write(6,*)totdflux -! write(6,*)'htr' -! write(6,*)htr -! write(6,*)'totuclfl' -! write(6,*)totuclfl -! write(6,*)'totdclfl' -! write(6,*)totdclfl -! write(6,*)'htrcl' -! write(6,*)htrcl -! write(6,*)'htrb' -! write(6,*)htrb - - - endif - - - -! --- output total-sky and clear-sky fluxes and heating rates. - - topflx(iplon)%upfxc = totuflux(NLAY) - topflx(iplon)%upfx0 = totuclfl(NLAY) - - sfcflx(iplon)%upfxc = totuflux(0) - sfcflx(iplon)%upfx0 = totuclfl(0) - sfcflx(iplon)%dnfxc = totdflux(0) - sfcflx(iplon)%dnfx0 = totdclfl(0) - - if (iflip == 0) then ! output from toa to sfc - -!! --- optional fluxes - if ( lflxprf ) then - do k = 0, NLAY - k1 = NLP1 - k - flxprf(iplon,k1)%upfxc = totuflux(k) - flxprf(iplon,k1)%dnfxc = totdflux(k) - flxprf(iplon,k1)%upfx0 = totuclfl(k) - flxprf(iplon,k1)%dnfx0 = totdclfl(k) - enddo - endif - - do k = 1, NLAY - k1 = NLP1 - k - hlwc(iplon,k1) = htr(k) - enddo - -!! --- optional clear sky heating rate - if ( lhlw0 ) then - do k = 1, NLAY - k1 = NLP1 - k - hlw0(iplon,k1) = htrcl(k) - enddo - endif - -!! --- optional spectral band heating rate - if ( lhlwb ) then - do j = 1, NBANDS - do k = 1, NLAY - k1 = NLP1 - k - hlwb(iplon,k1,j) = htrb(k,j) - enddo - enddo - endif - - else ! output from sfc to toa - -!! --- optional fluxes - if ( lflxprf ) then - do k = 0, NLAY - flxprf(iplon,k+1)%upfxc = totuflux(k) - flxprf(iplon,k+1)%dnfxc = totdflux(k) - flxprf(iplon,k+1)%upfx0 = totuclfl(k) - flxprf(iplon,k+1)%dnfx0 = totdclfl(k) - enddo - endif - - do k = 1, NLAY - hlwc(iplon,k) = htr(k) - enddo - -!! --- optional clear sky heating rate - if ( lhlw0 ) then - do k = 1, NLAY - hlw0(iplon,k) = htrcl(k) - enddo - endif - -!! --- optional spectral band heating rate - if ( lhlwb ) then - do j = 1, NBANDS - do k = 1, NLAY - hlwb(iplon,k,j) = htrb(k,j) - enddo - enddo - endif - - endif ! if_iflip - - enddo lab_do_iplon - - return -!................................... - end subroutine lwrad -!----------------------------------- - - - -!----------------------------------- - subroutine rlwinit & -!................................... - -! --- inputs: - & ( icwp, me, NLAY ) -! --- outputs: (none) - -! ******************************************************************* ! -! ! -! rrtm longwave radiative transfer model ! -! atmospheric and environmental research, inc., cambridge, ma ! -! ! -! ! -! original version: michael j. iacono; july, 1998 ! -! revision for ncar ccm: michael j. iacono; september, 1998 ! -! ! -! this subroutine performs calculations necessary for the initialization -! of the lw model, rrtm. lookup tables are computed for use in the lw ! -! radiative transfer, and input absorption coefficient data for each ! -! spectral band are reduced from 256 g-points to 140 for use in rrtm. ! -! ! -! ******************************************************************* ! -! ! -! definitions: ! -! arrays for 5000-point look-up tables: ! -! tau - clear-sky optical depth (used in cloudy radiative transfer)! -! tf tau transition function; i.e. the transition of the planck ! -! function from that for the mean layer temperature to that ! -! for the layer boundary temperature as a function of optical! -! depth. the "linear in tau" method is used to make the table! -! trans- transmittance ! -! ! -! ******************************************************************* ! -! ! -! inputs: ! -! icwp - flag of cloud schemes used by model ! -! =0: diagnostic scheme gives cloud tau, omiga, and g ! -! =1: prognostic scheme gives cloud liq/ice path, etc. ! -! me - print control for parallel process ! -! NLAY - number of vertical layers ! -! ! -! outputs: (none) ! -! ! -! control flags in module "module_radlw_cntr_para": ! -! ilwrate - heating rate unit selections ! -! =1: output in k/day ! -! =2: output in k/second ! -! iaerlw - control flag for aerosols ! -! =0: do not include aerosol effect ! -! >0: include aerosol effect ! -! irgaslw - control flag for rare gases (ch4,n2o,o2, etc.) ! -! =0: do not include rare gases ! -! =1: include all rare gases ! -! icfclw - control flag for cfc gases ! -! =0: do not include cfc gases ! -! =1: include all cfc gases ! -! iflagliq- cloud optical properties contrl flag ! -! =0: input cloud opt depth from diagnostic scheme ! -! >0: input cwp,cip, and other cloud content parameters ! -! ! -! ******************************************************************* ! -! - implicit none -! -! --- inputs: - integer, intent(in) :: icwp, me, NLAY - -! --- outputs: none - -! --- locals: - real (kind=kind_phys) :: tfn, fp, rtfp, pival, explimit - integer :: i -! -!===> ... begin here -! - - if (me == 0) then - print *,' - Using AER Longwave Radiation, Version: ', VTAGLW - - if (iaerlw > 0) then - print *,' --- Using input aerosol parameters for LW' - else - print *,' --- Aerosol effect is NOT included in LW, all' & - & ,' internal aerosol parameters are reset to zeros' - endif - - if (irgaslw == 1) then - print *,' --- Include rare gases N2O, CH4, O2, absorptions',& - & ' in LW' - else - print *,' --- Rare gases effect is NOT included in LW' - endif - - if (icfclw == 1) then - print *,' --- Include CFC gases absorptions in LW' - else - print *,' --- CFC gases effect is NOT included in LW' - endif - endif - -! --- ... check cloud flags for consistency - - if ((icwp == 0 .and. iflagliq /= 0) .or. & - & (icwp == 1 .and. iflagliq == 0)) then - print *, ' *** Model cloud scheme inconsistent with LW', & - & ' radiation cloud radiative property setup !!' - stop - endif - -! --- ... setup default surface emissivity for each band here - - semiss0(:) = 1.0 - -! --- ... setup constant factors for flux and heating rate -! the 1.0e-2 is to convert pressure from mb to N/m**2 - - pival = 2.0*asin(1.0) - fluxfac = pival * 2.0d4 -! fluxfac = 62831.85307179586 ! = 2 * pi * 1.0e4 - - if (ilwrate == 1) then -! heatfac = con_g * 86400. * 1.0e-2 / con_cp ! (in k/day) - heatfac = con_g * 864.0 / con_cp ! (in k/day) - else - heatfac = con_g * 1.0e-2 / con_cp ! (in k/second) - endif - -! --- ... compute lookup tables for transmittance, tau transition -! function, and clear sky tau (for the cloudy sky radiative -! transfer). tau is computed as a function of the tau -! transition function, transmittance is calculated as a -! function of tau, and the tau transition function is -! calculated using the linear in tau formulation at values of -! tau above 0.01. tf is approximated as tau/6 for tau < 0.01. -! all tables are computed at intervals of 0.001. the inverse -! of the constant used in the pade approximation to the tau -! transition function is set to b. - - tau (0) = f_zero - tf (0) = f_zero - trans(0) = 1.0 - - tau (N5000) = 1.e10 - tf (N5000) = 1.0 - trans(N5000) = f_zero - - explimit = aint( -log(tiny(trans(0))) ) - - do i = 1, N5000-1 - tfn = real(i, kind_phys) / real(N5000-i, kind_phys) - tau (i) = bpade * tfn - if (tau(i) >= explimit) then - trans(i) = f_zero - else - trans(i) = exp(-tau(i)) - endif - - if (tau(i) < 0.1) then - tf(i) = tau(i) / 6.0 - else - tf(i) = 1. - 2.*( (1./tau(i)) - (trans(i)/(1.-trans(i))) ) - endif - enddo - -! --- ... calculate lookup tables for functions needed in routine -! taumol (taugb2) - - corr1(0) = 1.0 - corr2(0) = 1.0 - - corr1(N200) = 1.0 - corr2(N200) = 1.0 - - do i = 1, N200-1 - fp = 0.005 * float(i) - rtfp = sqrt(fp) - corr1(i) = rtfp / fp - corr2(i) = (1.0 - rtfp) / (1.0 - fp) - enddo - -!................................... - end subroutine rlwinit -!----------------------------------- - - - -!----------------------------------- - subroutine cldprop & -!................................... - -! --- inputs: - & ( cldfrac,cliqp,cicep,reliq,reice,cdat1,cdat2,cdat3,cdat4, & - & NLAY, NLP1, & -! --- output: - & taucloud & - & ) - -! ******************************************************************* ! -! ! -! purpose: compute the cloud optical depth(s) for each cloudy layer.! -! ! -! ******************************************************************* ! -! ! -! inputs: ! -! cldfrac - layer cloud fraction L ! -! - - - for iflagliq > 0 (prognostic cloud sckeme) - - - ! -! cliqp - layer cloud liquid water path (g/m**2) L ! -! reliq - effective radius for water cloud (micron) L ! -! cicep - layer cloud ice water path (g/m**2) L ! -! reice - effective radius for ice cloud (micron) L ! -! cdat1 - layer rain drop water path (g/m**2) L ! -! cdat2 - effective radius for rain drop (microm) L ! -! cdat3 - layer snow flake water path (g/m**2) L ! -! (if use fu's formula it needs to be normalized by ! -! snow density (g/m**3/1.0e6) to get unit of micron) ! -! cdat4 - effective radius for snow flakes (micron) L ! -! - - - for iflagliq = 0 (diagnostic cloud sckeme) - - - ! -! cdat1 - input cloud optical depth L ! -! cdat2 - optional use L ! -! cdat3 - optional use L ! -! cdat4 - optional use L ! -! cliqp - not used L ! -! reliq - not used L ! -! cicep - not used L ! -! reice - not used L ! -! ! -! NLAY/NLP1-vertical layer/level numbers 1 ! -! ! -! explanation of the method for each value of iflagliq, and iflagice.! -! set up in module "module_radlw_cntr_para" ! -! ! -! iflagliq=0 and =1 do not distingish being liquid and ice clouds. ! -! iflagliq=2 and =3 does distinguish between liquid and ice clouds, ! -! and requires further user input (iflagice) to specify! -! the method to be used to compute the aborption due to! -! liquid and ice parts. ! -! ................................................................... ! -! ! -! iflagliq=0: for each cloudy layer, the cloud fraction and (gray) ! -! optical depth are input. ! -! iflagliq=1: for each cloudy layer, the cloud fraction and cloud ! -! water path (g/m2) are input. using clp only. the ! -! (gray) cloud optical depth is computed as in ccm2. ! -! iflagliq=2: the optical depths due to water clouds are computed ! -! as in ccm3. ! -! iflagliq=3: the water droplet effective radius (microns) is input! -! and the opt depths due to water clouds are computed ! -! as in hu and stamnes, j., clim., 6, 728-742, (1993). ! -! the values for absorption coefficients appropriate for -! the spectral bands in rrtm have been obtained for a ! -! range of effective radii by an averaging procedure ! -! based on the work of j. pinto (private communication). -! linear interpolation is used to get the absorption ! -! coefficients for the input effective radius. ! -! ! -! iflagice=0: the cloud ice path (g/m2) and ice effective radius ! -! (microns) are input and the optical depths due to ice! -! clouds are computed as in ccm3. ! -! iflagice=1: the cloud ice path (g/m2) and ice effective radius ! -! (microns) are input and the optical depths due to ice! -! clouds are computed as in ebert and curry, jgr, 97, ! -! 3831-3836 (1992). the spectral regions in this work ! -! have been matched with the spectral bands in rrtm to ! -! as great an extent as possible: ! -! e&c 1 ib = 5 rrtm bands 9-16 ! -! e&c 2 ib = 4 rrtm bands 6-8 ! -! e&c 3 ib = 3 rrtm bands 3-5 ! -! e&c 4 ib = 2 rrtm band 2 ! -! e&c 5 ib = 1 rrtm band 1 ! -! iflagice=2: the cloud ice path (g/m2) and ice effective radius ! -! (microns) are input and the optical depths due to ice! -! clouds are computed as in streamer (reference: j. key, -! streamer user's guide, technical report 96-01, ! -! department of geography, boston university, 85 pp. ! -! (1996)). the values of absorption coefficients ! -! appropriate for the spectral bands of rrtm were ! -! obtained by an averaging procedure based on the work ! -! of j. pinto (private communication). ! -! ! -! outputs: ! -! taucloud - cloud optical depth NBANDS*L ! -! ! -! ******************************************************************* ! -! - use module_radlw_cldprlw - - implicit none - -! --- inputs: - integer, intent(in) :: NLAY, NLP1 - - real (kind=kind_phys), dimension(0:), intent(in) :: cldfrac - - real (kind=kind_phys), dimension(:), intent(in) :: cliqp, cicep, & - & reliq, reice, cdat1, cdat2, cdat3, cdat4 - -! --- outputs: - real (kind=kind_phys), dimension(:,:), intent(out) :: taucloud - -! --- locals: - real (kind=kind_phys) :: cliq, cice, radliq, radice, factor, fint - real (kind=kind_phys) :: taurain, tausnow - integer :: j, k, index - -! -!===> ... begin here -! - do k = 1, NLAY - do j = 1, NBANDS - taucloud(j,k) = f_zero - enddo - enddo - - lab_do_k : do k = 1, NLAY - - lab_if_cld : if (cldfrac(k) > eps) then - -! --- ice clouds and water clouds combined. - lab_if_liq : if (iflagliq == 0) then - - do j = 1, NBANDS - taucloud(j,k) = cdat1(k) - enddo - - elseif (iflagliq == 1) then lab_if_liq - - taurain = absrain * cdat1(k) ! ncar formula - tausnow = abssnow0 * cdat3(k) ! ncar formula -! tausnow = abssnow1 * cdat3(k) / cdat4(k) ! fu's formula - -! taucloud(1,k) = absliq1 * (cliqp(k) + cicep(k)) -! taucloud(1,k) = absliq1 * cliqp(k) - taucloud(1,k) = absliq1*cliqp(k) + taurain + tausnow - do j = 2,NBANDS - taucloud(j,k) = taucloud(1,k) - enddo - -! --- separate treatement of ice clouds and water clouds. - else lab_if_liq - - taurain = absrain * cdat1(k) ! ncar formula - tausnow = abssnow0 * cdat3(k) ! ncar formula -! tausnow = abssnow1 * cdat3(k) / cdat4(k) ! fu's formula - - cliq = cliqp(k) - cice = cicep(k) - radliq = max(2.5e0, min(60.0e0, real(reliq(k)) )) - radice = reice(k) -! radice = max(13.e0, min(130.e0, real(reice(k)) )) - -! --- calculation of absorption coefficients due to liquid clouds. - if (cliq == f_zero) then - do j = 1, NBANDS - abscoliq(j) = f_zero - enddo - elseif (iflagliq == 2) then - abscoliq(1) = cliq * absliq2 - do j = 2, NBANDS - abscoliq(j) = abscoliq(1) - enddo - elseif (iflagliq == 3) then - factor = radliq - 1.5 - index = min(57, int(factor)) - fint = factor - index - do j = 1, NBANDS - abscoliq(j) = cliq * (absliq3(index,j) + fint * & - & (absliq3(index+1,j) - (absliq3(index,j)))) - enddo - endif - -! --- calculation of absorption coefficients due to ice clouds. - if (cice == f_zero) then - do j = 1, NBANDS - abscoice(j) = f_zero - enddo - elseif (iflagice == 0) then - abscoice(1) = cice * (absice0(1) + absice0(2)/radice) - do j = 2, NBANDS - abscoice(j) = abscoice(1) - enddo - elseif (iflagice == 1) then - do j = 1, NBANDS - index = ipat(j) - abscoice(j) = cice * (absice1(1,index) & - & + absice1(2,index)/radice) - enddo - elseif (iflagice == 2) then - factor = (radice - 10.0) / 3.0 - index = min(39, int(factor)) - fint = factor - index - do j = 1, NBANDS - abscoice(j) = cice * (absice2(index,j) + fint * & - & (absice2(index+1,j) - (absice2(index,j)))) - enddo - endif - - do j = 1, NBANDS -! taucloud(j,k) = abscoice(j) + abscoliq(j) - taucloud(j,k) = abscoice(j) + abscoliq(j) & - & + taurain + tausnow - enddo - - endif lab_if_liq - - endif lab_if_cld - - enddo lab_do_k - - return -!................................... - end subroutine cldprop -!----------------------------------- - - - -!----------------------------------- - subroutine rtrn & -!................................... - -! --- inputs: - & ( tavel,tz,delp,semiss,cldfrac,taucloud,pfrac, & - & secdiff, itr, NLAY, NLP1, & -! --- outputs: - & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb & - & ) - -! ******************************************************************* ! -! ! -! rrtm longwave radiative transfer model ! -! atmospheric and environmental research, inc., cambridge, ma ! -! ! -! original version: e. j. mlawer, et al. ! -! revision for ncar ccm: michael j. iacono; september, 1998 ! -! revision to use variable diffusivity angle instead of the original ! -! fixed value of 1.66: m. j. iacono apr 2004 ! -! ! -! this program calculates the upward fluxes, downward fluxes, and ! -! heating rates for an arbitrary clear or cloudy atmosphere. the input! -! to this program is the atmospheric profile, all planck function ! -! information, and the cloud fraction by layer. a variable diffusivity! -! angle (secdiff) is used forthe angle integration. bands 2-3 and 5-9 ! -! use a value of secdiff that varies from 1.50 to 1.80 as a function of! -! the column water vapor, and other bands use a value of 1.66. the ! -! gaussian weight appropriate to this angle (wtnum=0.5) is applied ! -! here. note that use of a single angle for the flux integration ! -! can cause errors of 1 to 4 w/m2 within cloudy layers. ! -! ! -! ******************************************************************* ! -! - use module_radlw_avplank -! - implicit none - -! --- inputs: - integer, intent(in) :: NLAY, NLP1 - - integer, intent(in) :: itr(:,:) - - real (kind=kind_phys), dimension(0:), intent(in) :: tz, cldfrac - - real (kind=kind_phys), dimension(:), intent(in) :: tavel, delp, & - & semiss, secdiff - - real (kind=kind_phys), dimension(:,:),intent(in) :: taucloud, & - & pfrac - -! --- outputs: - real (kind=kind_phys), dimension(:), intent(out) :: htr, htrcl - real (kind=kind_phys), dimension(:,:),intent(out) :: htrb - - real (kind=kind_phys), dimension(0:), intent(out) :: & - & totuflux, totdflux, totuclfl, totdclfl - -! --- locals: - real (kind=kind_phys), dimension(NGPT,NLAY) :: gassrcu, & - & cldsrcu, trans0 - real (kind=kind_phys), dimension(NGPT,0:NLAY) :: bglev - real (kind=kind_phys), dimension(NGPT) :: radclru, & - & radclrd, radtotu, radtotd - real (kind=kind_phys), dimension(NBANDS,0:NLAY) :: plvl, & - & totufxsb, totdfxsb - real (kind=kind_phys), dimension(NBANDS,NLAY) :: play, odcld, & - & trncld, efcfr1 - real (kind=kind_phys), dimension(0:NLAY) :: fnet, fnetc - - real (kind=kind_phys) :: totdrad, clrdrad, toturad, clrurad - real (kind=kind_phys) :: delbgup, delbgdn, bglay, tau0, tauc, & - & transc, cldsrcd, gassrcd, factot, odsm, tem1, tem2 - - integer :: j, k, ind, inb, itm1, itm2, jtm1, jtm2 - -! ==================== defination of variables ==================== ! -! ! -! input variables: ! -! tavel (NLAY) ! layer temperatures (k) ! -! tz (0:NLAY) ! level (interface) temperature (k) ! -! delp (NLAY) ! layer pressure thickness (mb) ! -! semiss (NBANDS) ! surface emissivities for each band ! -! cldfrac (0:NLP1) ! layer cloud fraction (padded at 2 ends) ! -! taucloud(NBANDS,NLAY)! layer cloud optical depth ! -! pfrac (NGPT,NLAY) ! planck fractions ! -! secdiff(NBANDS) ! variable diffusivity angle defined as an ! -! exponential function of the column water ! -! amount in bands 2-3 and 5-9. this reduces ! -! the bias of several w/m2 in downward surface! -! flux in high water profiles caused by using ! -! the constant diffusivity angle of 1.66.(mji)! -! itr (NGPT,NLAY) ! integer look-up table index ! -! NLAY/NLP1 ! number of model layers/levels ! -! ! -! constants or shared variables: ! -! NGPT ! total number of g-point subintervals ! -! NBANDS ! number of longwave spectral bands ! -! wtnum ! weight for radiance to flux conversion ! -! bpade ! pade constant ! -! tau ! clear sky optical depth look-up table ! -! tf ! tau transition function look-up table ! -! trans ! clear sky transmittance look-up table ! -! ! -! output variables: ! -! totuflux(0:NLAY) ! upward longwave flux (w/m2) ! -! totdflux(0:NLAY) ! downward longwave flux (w/m2) ! -! htr (NLAY) ! longwave heating rate (k/day) ! -! totuclfl(0:NLAY) ! clear sky upward longwave flux (w/m2) ! -! totdclfl(0:NLAY) ! clear sky downward longwave flux (w/m2) ! -! htrcl (NLAY) ! clear sky longwave heating rate (k/day) ! -! htrb (NLAY,NBANDS)! spectral band lw heating rate (k/day) ! -! ! -! local variables: ! -! odcld (NBANDS,NLAY)! cloud optical depth ! -! trncld (NBANDS,NLAY)! cloud transmittance ! -! efcfr1 (NBANDS,NLAY)! effective clear sky fraction ! -! radtotu (NGPT) ! upward radiance ! -! radtotd (NGPT) ! downward radiance ! -! radclru (NGPT) ! clear sky upward radiance ! -! radclrd (NGPT) ! clear sky downward radiance ! -! toturad ! spectrally summed upward radiance ! -! totdrad ! spectrally summed downward radiance ! -! clrurad ! spectrally summed clear sky upward radiance ! -! clrdrad ! spectrally summed clear sky dnward radiance ! -! totufxsb(NBANDS,NLAY)! spectral band upward longwave flux (w/m2) ! -! totdfxsb(NBANDS,NLAY)! spectral band downward longwave flux (w/m2) ! -! ! -! fnet (0:NLAY) ! net longwave flux (w/m2) ! -! fnetc (0:NLAY) ! clear sky net longwave flux (w/m2) ! -! ! -! ===================== end of definitions ==================== ! - -! -!===> ... begin here -! - -! --- ... calculate the integrated planck functions at the level and -! layer temperatures. - - itm1 = min(NPLNK, max(1, int(tz(0)-159.0) )) - itm2 = min(NPLNK, itm1+1) - tem1 = tz(0) - int(tz(0)) - do j = 1, NBANDS - plvl(j,0) = delwave(j) * ( totplnk(itm1,j) & - & + tem1 * (totplnk(itm2,j) - totplnk(itm1,j)) ) - enddo - - do k = 1, NLAY - itm1 = min(NPLNK, max(1, int(tz(k) -159.0) )) - itm2 = min(NPLNK, itm1+1) - jtm1 = min(NPLNK, max(1, int(tavel(k)-159.0) )) - jtm2 = min(NPLNK, jtm1+1) - - tem1 = tz(k) - int(tz(k)) - tem2 = tavel(k) - int(tavel(k)) - - do j = 1, NBANDS - plvl(j,k) = delwave(j) * ( totplnk(itm1,j) & - & + tem1 * (totplnk(itm2,j) - totplnk(itm1,j)) ) - play(j,k) = delwave(j) * ( totplnk(jtm1,j) & - & + tem2 * (totplnk(jtm2,j) - totplnk(jtm1,j)) ) - -! --- ... cloudy sky optical depth and absorptivity. -! mji odcld(j,k) = secang * taucloud(j,k) - odcld(j,k) = secdiff(j) * taucloud(j,k) - trncld(j,k) = exp( -odcld(j,k) ) - efcfr1(j,k) = 1.0 - cldfrac(k) + trncld(j,k)*cldfrac(k) - enddo - - do j = 1, NGPT - inb = ngb(j) ! band index - bglev(j,k-1) = pfrac(j,k) * plvl(inb,k-1) - enddo - enddo - -! --- ... initialize for radiative transfer. - - if ( lhlwb ) then - do k = 0, NLAY - do j = 1, NBANDS - totufxsb(j,k) = f_zero - totdfxsb(j,k) = f_zero - enddo - enddo - endif - - do j = 1, NGPT - inb = ngb(j) ! band index - radclrd(j) = f_zero - radtotd(j) = f_zero - bglev(j,NLAY) = pfrac(j,NLAY) * plvl(inb,NLAY) - enddo - -!===> ... downward radiative transfer -! totdrad holds summed radiance for total sky stream -! clrdrad holds summed radiance for clear sky stream - - do k = NLAY, 1, -1 - - totdrad = f_zero - clrdrad = f_zero - - if (cldfrac(k) > eps) then -! --- ... cloudy layer - - do j = 1, NGPT -! --- ... get lookup table index - ind = itr(j,k) - inb = ngb(j) ! band index - -! --- ... get clear sky transmittance from lookup table - tau0 = tf(ind) - trans0(j,k) = trans(ind) - transc = trans0(j,k) * trncld(inb,k) - -! --- ... add clear sky and cloud optical depths - odsm = tau(ind) + odcld(inb,k) - tauc = odsm / (bpade + odsm) - - bglay = pfrac(j,k) * play(inb,k) - delbgup = bglev(j,k) - bglay - tem1 = bglay + tau0*delbgup - tem2 = bglay + tauc*delbgup - gassrcu(j,k) = tem1 - trans0(j,k)*tem1 - cldsrcu(j,k) = tem2 - transc *tem2 - - delbgdn = bglev(j,k-1) - bglay - tem1 = bglay + tau0*delbgdn - tem2 = bglay + tauc*delbgdn - gassrcd = tem1 - trans0(j,k)*tem1 - cldsrcd = tem2 - transc *tem2 - -! --- ... total sky radiance - radtotd(j) = radtotd(j)*trans0(j,k)*efcfr1(inb,k) & - & + gassrcd + cldfrac(k)*(cldsrcd - gassrcd) - totdrad = totdrad + radtotd(j) - -! --- ... clear sky radiance - radclrd(j) = radclrd(j)*trans0(j,k) + gassrcd - clrdrad = clrdrad + radclrd(j) - enddo - - else - -! --- ... clear layer - - do j = 1, NGPT - ind = itr(j,k) - inb = ngb(j) ! band index - -! --- ... get clear sky transmittance from lookup table - tau0 = tf(ind) - trans0(j,k) = trans(ind) - - bglay = pfrac(j,k) * play(inb,k) - - delbgup = bglev(j,k) - bglay - tem1 = bglay + tau0*delbgup - gassrcu(j,k) = tem1 - trans0(j,k)*tem1 -! cldsrcu(j,k) = 0.0 - - delbgdn = bglev(j,k-1) - bglay - tem2 = bglay + tau0*delbgdn - gassrcd = tem2 - trans0(j,k)*tem2 - -! --- ... total sky radiance - radtotd(j) = radtotd(j)*trans0(j,k) + gassrcd - totdrad = totdrad + radtotd(j) - -! --- ... clear sky radiance - radclrd(j) = radclrd(j)*trans0(j,k) + gassrcd - clrdrad = clrdrad + radclrd(j) - enddo - - endif - - totdflux(k-1) = totdrad - totdclfl(k-1) = clrdrad - -! --- ... total sky radiance for each of the spectral bands - if ( lhlwb ) then - do j = 1, NGPT - inb = ngb(j) ! band index - totdfxsb(inb,k-1) = totdfxsb(inb,k-1) + radtotd(j) - enddo - - totdfxsb(:,NLAY) = f_zero - endif - - enddo ! end do_k_loop - - totdflux(NLAY) = f_zero - totdclfl(NLAY) = f_zero - -! --- ... spectral emissivity & reflectance -! include the contribution of spectrally varying longwave -! emissivity and reflection from the surface to the upward -! radiative transfer. -! note: spectral and lambertian reflection are identical for the one -! angle flux integration used here. - - toturad = f_zero - clrurad = f_zero - - do j = 1, NGPT - inb = ngb(j) ! band index - tem1 = 1.0 - semiss(inb) - tem2 = bglev(j,0) * semiss(inb) - -! --- ... total sky radiance - radtotu(j) = tem2 + tem1 * radtotd(j) - toturad = toturad + radtotu(j) - -! --- ... clear sky radiance - radclru(j) = tem2 + tem1 * radclrd(j) - clrurad = clrurad + radclru(j) - enddo - - totuflux(0) = toturad - totuclfl(0) = clrurad - -! --- ... total sky radiance for each of the spectral bands - if ( lhlwb ) then - do j = 1, NGPT - inb = ngb(j) ! band index - totufxsb(inb,0) = totufxsb(inb,0) + radtotu(j) - enddo - endif - -! print *,' toturad(0)=',totuflux(0) -! print *,' clrurad(0)=',totuclfl(0) - -!===> ... upward radiative transfer -! toturad holds summed radiance for total sky stream -! clrurad holds summed radiance for clear sky stream - - do k = 1, NLAY - - toturad = f_zero - clrurad = f_zero - -! --- ... check flag for cloud in current layer - if (cldfrac(k) > eps) then - -! --- ... cloudy layers - - do j = 1, NGPT - inb = ngb(j) ! band index - -! --- ... total sky radiance - radtotu(j) = radtotu(j)*trans0(j,k)*efcfr1(inb,k) & - & + gassrcu(j,k) + cldfrac(k)*(cldsrcu(j,k)-gassrcu(j,k)) - toturad = toturad + radtotu(j) - -! --- ... clear sky radiance - radclru(j) = radclru(j)*trans0(j,k) + gassrcu(j,k) - clrurad = clrurad + radclru(j) - enddo - - else - -! --- ... clear layer - - do j = 1, NGPT - -! --- ... total sky radiance - radtotu(j) = radtotu(j)*trans0(j,k) + gassrcu(j,k) - toturad = toturad + radtotu(j) - -! --- ... clear sky radiance - radclru(j) = radclru(j)*trans0(j,k) + gassrcu(j,k) - clrurad = clrurad + radclru(j) - enddo - - endif - - totuflux(k) = toturad - totuclfl(k) = clrurad - -! --- ... total sky radiance for each of the spectral bands - if ( lhlwb ) then - do j = 1, NGPT - inb = ngb(j) ! band index - totufxsb(inb,k) = totufxsb(inb,k) + radtotu(j) - enddo - endif - - enddo - -!===> ... convert radiances to fluxes and heating rates for total sky. -! calculates clear sky surface and toa values. to compute clear -! sky profiles, uncomment relevant lines below. - - factot = wtnum * fluxfac - - totuflux(0) = totuflux(0) * factot - totdflux(0) = totdflux(0) * factot - totuclfl(0) = totuclfl(0) * factot - totdclfl(0) = totdclfl(0) * factot - fnet(0) = totuflux(0) - totdflux(0) - - do k = 1, NLAY - totuflux(k) = totuflux(k) * factot - totdflux(k) = totdflux(k) * factot - - totuclfl(k) = totuclfl(k) * factot - totdclfl(k) = totdclfl(k) * factot - - fnet(k) = totuflux(k) - totdflux(k) - htr (k) = heatfac * (fnet(k-1) - fnet(k)) / delp(k) - enddo - -!! --- ... optional clear sky heating rates - if ( lhlw0 ) then - fnetc(0) = totuclfl(0) - totdclfl(0) - - do k = 1, NLAY - fnetc(k) = totuclfl(k) - totdclfl(k) - htrcl(k) = heatfac * (fnetc(k-1) - fnetc(k)) / delp(k) - enddo - endif - -!! --- ... optional spectral band heating rates - if ( lhlwb ) then - do j = 1, NBANDS - totufxsb(j,0) = totufxsb(j,0) * factot - totdfxsb(j,0) = totdfxsb(j,0) * factot - fnet(0) = totufxsb(j,0) - totdfxsb(j,0) - - do k = 1, NLAY - totufxsb(j,k) = totufxsb(j,k) * factot - totdfxsb(j,k) = totdfxsb(j,k) * factot - fnet(k) = totufxsb(j,k) - totdfxsb(j,k) - htrb(k,j) = heatfac * (fnet(k-1) - fnet(k)) / delp(k) - enddo - enddo - endif - - return -!................................... - end subroutine rtrn -!----------------------------------- - - - -!----------------------------------- - subroutine rtrnmr & -!................................... - -! --- inputs: - & ( tavel,tz,delp,semiss,cldfrac,taucloud,pfrac, & - & secdiff, itr, NLAY, NLP1, & -! --- outputs: - & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb & - & ) - -! ******************************************************************* ! -! ! -! rrtm longwave radiative transfer model ! -! atmospheric and environmental research, inc., cambridge, ma ! -! ! -! original version: e. j. mlawer, et al. ! -! revision for ncar ccm: michael j. iacono; september, 1998 ! -! revision to use variable diffusivity angle instead of the original ! -! fixed value of 1.66: m. j. iacono apr 2004 ! -! ! -! this program calculates the upward fluxes, downward fluxes, and ! -! heating rates for an arbitrary clear or cloudy atmosphere. the input! -! to this program is the atmospheric profile, all planck function ! -! information, and the cloud fraction by layer. a variable diffusivity! -! angle (secdiff) is used forthe angle integration. bands 2-3 and 5-9 ! -! use a value of secdiff that varies from 1.50 to 1.80 as a function of! -! the column water vapor, and other bands use a value of 1.66. the ! -! gaussian weight appropriate to this angle (wtnum=0.5) is applied ! -! here. note that use of a single angle for the flux integration ! -! can cause errors of 1 to 4 w/m2 within cloudy layers. ! -! this routine computes a generalized maximum/random cloud overlap. ! -! adjacent cloud layers are treated with maximum overlap in which up ! -! to two previous layers of cloud information is considered. non- ! -! adjacent groups of clouds are treated with random overlap. ! -! ! -! ******************************************************************* ! -! - use module_radlw_avplank -! - implicit none - -! --- inputs: - integer, intent(in) :: NLAY, NLP1 - - integer, intent(in) :: itr(:,:) - - real (kind=kind_phys), dimension(0:), intent(in) :: tz, cldfrac - - real (kind=kind_phys), dimension(:), intent(in) :: tavel, delp, & - & semiss, secdiff - - real (kind=kind_phys), dimension(:,:),intent(in) :: taucloud, & - & pfrac - -! --- outputs: - real (kind=kind_phys), dimension(:), intent(out) :: htr, htrcl - real (kind=kind_phys), dimension(:,:),intent(out) :: htrb - - real (kind=kind_phys), dimension(0:), intent(out) :: & - & totuflux, totdflux, totuclfl, totdclfl - -! --- locals: -! dimensions for radiative transfer - real (kind=kind_phys), dimension(NGPT,NLAY) :: gassrcu, & - & cldsrcu, trans0, transc - real (kind=kind_phys), dimension(NGPT,0:NLAY) :: bglev - real (kind=kind_phys), dimension(NGPT) :: radclru, & - & radclrd, radtotu, radtotd - real (kind=kind_phys), dimension(NBANDS,0:NLAY) :: plvl, & - & totufxsb, totdfxsb - real (kind=kind_phys), dimension(NBANDS,NLAY) :: play, & - & odcld, trncld - real (kind=kind_phys), dimension(0:NLAY) :: fnet, fnetc - - real (kind=kind_phys) :: totdrad, clrdrad, toturad, clrurad - real (kind=kind_phys) :: delbgup, delbgdn, bglay, tau0, tauc, & - & cldsrcd, gassrcd, factot, odsm, tem1, tem2 - - integer :: j, k, ind, inb, itm1, itm2, jtm1, jtm2 - -! dimensions for cloud overlap adjustment - real (kind=kind_phys), dimension(NGPT) :: clrradu, cldradu, & - & clrradd, cldradd, rad - real (kind=kind_phys), dimension(1:NLP1) :: faccld1u, faccld2u, & - & facclr1u, facclr2u, faccmb1u, faccmb2u - real (kind=kind_phys), dimension(0:NLAY) :: faccld1d, faccld2d, & - & facclr1d, facclr2d, faccmb1d, faccmb2d - real (kind=kind_phys) :: fmax, fmin, rat1, rat2, radmod, cldsrc - - logical :: istcldu(NLAY), istcldd(NLAY) - -! ==================== defination of variables ==================== ! -! ! -! input variables: ! -! tavel (NLAY) ! layer temperatures (k) ! -! tZ (0:NLAY) ! level (interface) temperatures (k) ! -! delp (NLAY) ! layer pressure thickness (mb) ! -! semiss (NBANDS) ! surface emissivities for each band ! -! cldfrac (0:NLP1) ! layer cloud fraction (padded at 2 ends) ! -! taucloud(NBANDS,NLAY)! layer cloud optical depth ! -! pfrac (NGPT,NLAY) ! planck fractions ! -! secdiff(NBANDS) ! variable diffusivity angle defined as an ! -! exponential function of the column water ! -! amount in bands 2-3 and 5-9. this reduces ! -! the bias of several w/m2 in downward surface! -! flux in high water profiles caused by using ! -! the constant diffusivity angle of 1.66.(mji)! -! itr (NGPT,NLAY) ! integer look-up table index ! -! NLAY/NLP1 ! number of model layers/levels ! -! ! -! constants or shared variables: ! -! NGPT ! total number of g-point subintervals ! -! NBANDS ! number of longwave spectral bands ! -! wtnum ! weight for radiance to flux conversion ! -! bpade ! pade constant ! -! tau ! clear sky optical depth look-up table ! -! tf ! tau transition function look-up table ! -! trans ! clear sky transmittance look-up table ! -! ! -! output variables: ! -! totuflux(0:NLAY) ! upward longwave flux (w/m2) ! -! totdflux(0:NLAY) ! downward longwave flux (w/m2) ! -! htr (NLAY) ! longwave heating rate (k/d or k/s) ! -! totuclfl(0:NLAY) ! clear sky upward longwave flux (w/m2) ! -! totdclfl(0:NLAY) ! clear sky downward longwave flux (w/m2) ! -! htrcl (NLAY) ! clear sky longwave heating rate (k/d or k/s)! -! htrb (NLAY,NBANDS)! spectral band lw heating rate (k/d or k/s) ! -! ! -! local variables: ! -! odcld (NBANDS,NLAY)! cloud optical depth ! -! trncld (NBANDS,NLAY)! cloud transmittance ! -! radtotu (NGPT) ! upward radiance ! -! radtotd (NGPT) ! downward radiance ! -! radclru (NGPT) ! clear sky upward radiance ! -! radclrd (NGPT) ! clear sky downward radiance ! -! toturad ! spectrally summed upward radiance ! -! totdrad ! spectrally summed downward radiance ! -! clrurad ! spectrally summed clear sky upward radiance ! -! clrdrad ! spectrally summed clear sky dnward radiance ! -! totufxsb(NBANDS,NLAY)! spectral band upward longwave flux (w/m2) ! -! totdfxsb(NBANDS,NLAY)! spectral band downward longwave flux (w/m2) ! -! ! -! fnet (0:NLAY) ! net longwave flux (w/m2) ! -! fnetc (0:NLAY) ! clear sky net longwave flux (w/m2) ! -! ! -! ===================== end of definitions ==================== ! -! - -! -!===> ... begin here -! -! write(6,*)'in rtrnmr heatfac',heatfac - do k = 1, NLP1 - faccld1u(k) = f_zero - faccld2u(k) = f_zero - facclr1u(k) = f_zero - facclr2u(k) = f_zero - faccmb1u(k) = f_zero - faccmb2u(k) = f_zero - enddo - - istcldu(1) = cldfrac(1) > eps - rat1 = f_zero - rat2 = f_zero - - do k = 1, NLAY-1 - - istcldu(k+1) = cldfrac(k+1)>eps .and. cldfrac(k)<=eps - - if (cldfrac(k) > eps) then -! --- ... maximum/random cloud overlap - - if (cldfrac(k+1) >= cldfrac(k)) then - if (istcldu(k)) then - if (cldfrac(k) < 1.0) then - facclr2u(k+1) = (cldfrac(k+1) - cldfrac(k)) & - & / (1.0 - cldfrac(k)) - endif - facclr2u(k) = f_zero - faccld2u(k) = f_zero - else - fmax = max(cldfrac(k), cldfrac(k-1)) - if (cldfrac(k+1) > fmax) then - facclr1u(k+1) = rat2 - facclr2u(k+1) = (cldfrac(k+1) - fmax)/(1.0 - fmax) - elseif (cldfrac(k+1) < fmax) then - facclr1u(k+1) = (cldfrac(k+1) - cldfrac(k)) & - & / (cldfrac(k-1) - cldfrac(k)) - else - facclr1u(k+1) = rat2 - endif - endif - - if (facclr1u(k+1)>f_zero .or. facclr2u(k+1)>f_zero) then - rat1 = 1.0 - rat2 = f_zero - else - rat1 = f_zero - rat2 = f_zero - endif - else - if (istcldu(k)) then - faccld2u(k+1) = (cldfrac(k) - cldfrac(k+1)) / cldfrac(k) - facclr2u(k) = f_zero - faccld2u(k) = f_zero - else - fmin = min(cldfrac(k), cldfrac(k-1)) - if (cldfrac(k+1) <= fmin) then - faccld1u(k+1) = rat1 - faccld2u(k+1) = (fmin - cldfrac(k+1)) / fmin - else - faccld1u(k+1) = (cldfrac(k) - cldfrac(k+1)) & - & / (cldfrac(k) - fmin) - endif - endif - - if (faccld1u(k+1)>f_zero .or. faccld2u(k+1)>f_zero) then - rat1 = f_zero - rat2 = 1.0 - else - rat1 = f_zero - rat2 = f_zero - endif - endif - - faccmb1u(k+1) = facclr1u(k+1) * faccld2u(k) * cldfrac(k-1) - faccmb2u(k+1) = faccld1u(k+1) * facclr2u(k) & - & * (1.0 - cldfrac(k-1)) - endif - - enddo - - do k = 0, NLAY - faccld1d(k) = f_zero - faccld2d(k) = f_zero - facclr1d(k) = f_zero - facclr2d(k) = f_zero - faccmb1d(k) = f_zero - faccmb2d(k) = f_zero - enddo - - istcldd(NLAY) = cldfrac(NLAY) > eps - rat1 = f_zero - rat2 = f_zero - - do k = NLAY, 2, -1 - - istcldd(k-1) = cldfrac(k-1) > eps .and. cldfrac(k)<=eps - - if (cldfrac(k) > eps) then - - if (cldfrac(k-1) >= cldfrac(k)) then - if (istcldd(k)) then - if (cldfrac(k) < 1.0) then - facclr2d(k-1) = (cldfrac(k-1) - cldfrac(k)) & - & / (1.0 - cldfrac(k)) - endif - facclr2d(k) = f_zero - faccld2d(k) = f_zero - else - fmax = max(cldfrac(k), cldfrac(k+1)) - - if (cldfrac(k-1) > fmax) then - facclr1d(k-1) = rat2 - facclr2d(k-1) = (cldfrac(k-1) - fmax)/(1.0 - fmax) - elseif (cldfrac(k-1) < fmax) then - facclr1d(k-1) = (cldfrac(k-1) - cldfrac(k)) & - & / (cldfrac(k+1) - cldfrac(k)) - else - facclr1d(k-1) = rat2 - endif - endif - - if (facclr1d(k-1)>f_zero .or. facclr2d(k-1)>f_zero) then - rat1 = 1.0 - rat2 = f_zero - else - rat1 = f_zero - rat2 = f_zero - endif - else - if (istcldd(k)) then - faccld2d(k-1) = (cldfrac(k) - cldfrac(k-1)) / cldfrac(k) - facclr2d(k) = f_zero - faccld2d(k) = f_zero - else - fmin = min(cldfrac(k), cldfrac(k+1)) - - if (cldfrac(k-1) <= fmin) then - faccld1d(k-1) = rat1 - faccld2d(k-1) = (fmin - cldfrac(k-1)) / fmin - else - faccld1d(k-1) = (cldfrac(k) - cldfrac(k-1)) & - & / (cldfrac(k) - fmin) - endif - endif - - if (faccld1d(k-1)>f_zero .or. faccld2d(k-1)>f_zero) then - rat1 = f_zero - rat2 = 1.0 - else - rat1 = f_zero - rat2 = f_zero - endif - endif - - faccmb1d(k-1) = facclr1d(k-1) * faccld2d(k) * cldfrac(k+1) - faccmb2d(k-1) = faccld1d(k-1) * facclr2d(k) & - & * (1.0 - cldfrac(k+1)) - - endif - - enddo - -! --- ... calculate the integrated planck functions at the level and -! layer temperatures. - - itm1 = min(NPLNK, max(1, int(tz(0)-159.0) )) - itm2 = min(NPLNK, itm1+1) - tem1 = tz(0) - int(tz(0)) - do j = 1, NBANDS - plvl(j,0) = delwave(j) * ( totplnk(itm1,j) & - & + tem1 * (totplnk(itm2,j) - totplnk(itm1,j)) ) - enddo - - do k = 1, NLAY - itm1 = min(NPLNK, max(1, int(tz(k) -159.0) )) - itm2 = min(NPLNK, itm1+1) - jtm1 = min(NPLNK, max(1, int(tavel(k)-159.0) )) - jtm2 = min(NPLNK, jtm1+1) - - tem1 = tz(k) - int(tz(k)) - tem2 = tavel(k) - int(tavel(k)) - - do j = 1, NBANDS - plvl(j,k) = delwave(j) * ( totplnk(itm1,j) & - & + tem1 * (totplnk(itm2,j) - totplnk(itm1,j)) ) - play(j,k) = delwave(j) * ( totplnk(jtm1,j) & - & + tem2 * (totplnk(jtm2,j) - totplnk(jtm1,j)) ) - -! --- ... cloudy sky optical depth and absorptivity. -! mji odcld(j,k) = secang * taucloud(j,k) - odcld(j,k) = secdiff(j) * taucloud(j,k) - trncld(j,k) = exp( -odcld(j,k) ) - enddo - - do j = 1, NGPT - inb = ngb(j) ! band index - bglev(j,k-1) = pfrac(j,k) * plvl(inb,k-1) - enddo - enddo - -! --- ... initialize for radiative transfer. - - if ( lhlwb ) then - do k = 0, NLAY - do j = 1, NBANDS - totufxsb(j,k) = f_zero - totdfxsb(j,k) = f_zero - enddo - enddo - endif - - do j = 1, NGPT - inb = ngb(j) ! band index - radclrd(j) = f_zero - radtotd(j) = f_zero - bglev (j,NLAY) = pfrac(j,NLAY) * plvl(inb,NLAY) - enddo - -!===> ... downward radiative transfer -! totdrad holds summed radiance for total sky stream -! clrdrad holds summed radiance for clear sky stream - - do k = NLAY, 1, -1 - - totdrad = f_zero - clrdrad = f_zero - - if (istcldd(k)) then - do j = 1, NGPT - cldradd(j) = cldfrac(k) * radtotd(j) - clrradd(j) = radtotd(j) - cldradd(j) - rad (j) = f_zero - enddo - endif - - if (cldfrac(k) > eps) then -! --- ... cloudy layer - - do j = 1, NGPT -! --- ... get lookup table index - ind = itr(j,k) - inb = ngb(j) ! band index - -! --- ... get tf from lookup table - tau0 = tf(ind) - trans0(j,k) = trans(ind) - transc(j,k) = trans(ind) * trncld(inb,k) - -! --- ... add clear sky and cloud optical depths - odsm = tau(ind) + odcld(inb,k) - tauc = odsm / (bpade + odsm) - - bglay = pfrac(j,k) * play(inb,k) - delbgup = bglev(j,k) - bglay - tem1 = bglay + tau0*delbgup - tem2 = bglay + tauc*delbgup - gassrcu(j,k) = tem1 - trans0(j,k)*tem1 - cldsrcu(j,k) = tem2 - transc(j,k)*tem2 - - delbgdn = bglev(j,k-1) - bglay - tem1 = bglay + tau0*delbgdn - tem2 = bglay + tauc*delbgdn - gassrcd = tem1 - trans0(j,k)*tem1 - cldsrcd = tem2 - transc(j,k)*tem2 - - cldradd(j) = cldradd(j)*transc(j,k) + cldfrac(k)*cldsrcd - clrradd(j) = clrradd(j)*trans0(j,k) & - & + (1.0-cldfrac(k))*gassrcd - -! --- ... total sky radiance - radtotd(j) = cldradd(j) + clrradd(j) - totdrad = totdrad + radtotd(j) - -! --- ... clear sky radiance - radclrd(j) = radclrd(j)*trans0(j,k) + gassrcd - clrdrad = clrdrad + radclrd(j) - - radmod = rad(j) & - & * (facclr1d(k-1)*trans0(j,k) + faccld1d(k-1)*transc(j,k)) & - & - faccmb1d(k-1)*gassrcd + faccmb2d(k-1)*cldsrcd - - rad(j) = -radmod + facclr2d(k-1)*(clrradd(j) + radmod) & - & - faccld2d(k-1)*(cldradd(j) - radmod) - cldradd(j) = cldradd(j) + rad(j) - clrradd(j) = clrradd(j) - rad(j) - - enddo - - else - -! --- ... clear layer - - do j = 1, NGPT - ind = itr(j,k) - inb = ngb(j) ! band index - -! --- ... get tf from lookup table - tau0 = tf(ind) - trans0(j,k) = trans(ind) - transc(j,k) = f_zero - - bglay = pfrac(j,k) * play(inb,k) - - delbgup = bglev(j,k) - bglay - tem1 = bglay + tau0*delbgup - gassrcu(j,k) = tem1 - trans0(j,k)*tem1 -! cldsrcu(j,k) = 0.0 - - delbgdn = bglev(j,k-1) - bglay - tem2 = bglay + tau0*delbgdn - gassrcd = tem2 - trans0(j,k)*tem2 - -! --- ... total sky radiance - radtotd(j) = radtotd(j)*trans0(j,k) + gassrcd - totdrad = totdrad + radtotd(j) - -! --- ... clear sky radiance - radclrd(j) = radclrd(j)*trans0(j,k) + gassrcd - clrdrad = clrdrad + radclrd(j) - enddo - - endif - - totdflux(k-1) = totdrad - totdclfl(k-1) = clrdrad - -! --- ... total sky radiance for each of the spectral bands - if ( lhlwb ) then - do j = 1, NGPT - inb = ngb(j) ! band index - totdfxsb(inb,k-1) = totdfxsb(inb,k-1) + radtotd(j) - enddo - - totdfxsb(:,NLAY) = f_zero - endif - - enddo ! end do_k_loop - - totdflux(NLAY) = f_zero - totdclfl(NLAY) = f_zero - -! --- ... spectral emissivity & reflectance -! include the contribution of spectrally varying longwave -! emissivity and reflection from the surface to the upward -! radiative transfer. -! note: spectral and lambertian reflection are identical for the one -! angle flux integration used here. - - toturad = f_zero - clrurad = f_zero - - do j = 1, NGPT - inb = ngb(j) ! band index - tem1 = 1.0 - semiss(inb) - tem2 = bglev(j,0) * semiss(inb) - -! --- ... total sky radiance - radtotu(j) = tem2 + tem1 * radtotd(j) - toturad = toturad + radtotu(j) - -! --- ... clear sky radiance - radclru(j) = tem2 + tem1 * radclrd(j) - clrurad = clrurad + radclru(j) - enddo - - totuflux(0) = toturad - totuclfl(0) = clrurad - -! --- ... total sky radiance for each of the spectral bands - if ( lhlwb ) then - do j = 1, NGPT - inb = ngb(j) ! band index - totufxsb(inb,0) = totufxsb(inb,0) + radtotu(j) - enddo - endif - -!===> ... upward radiative transfer -! toturad holds the summed radiance for total sky stream -! clrurad holds the summed radiance for clear sky stream - - do k = 1, NLAY - - toturad = f_zero - clrurad = f_zero - - if (istcldu(k)) then - do j = 1, NGPT - cldradu(j) = radtotu(j) * cldfrac(k) - clrradu(j) = radtotu(j) - cldradu(j) - rad(j) = f_zero - enddo - endif - -! --- ... check flag for cloud in current layer - if (cldfrac(k) > eps) then - -! --- ... cloudy layers - - do j = 1, NGPT - cldradu(j) = cldradu(j)*transc(j,k)+cldfrac(k)*cldsrcu(j,k) - clrradu(j) = clrradu(j)*trans0(j,k) & - & + (1.0 - cldfrac(k))*gassrcu(j,k) - -! --- ... total sky radiance - radtotu(j) = cldradu(j) + clrradu(j) - toturad = toturad + radtotu(j) - -! --- ... clear sky radiance - radclru(j) = radclru(j)*trans0(j,k) + gassrcu(j,k) - clrurad = clrurad + radclru(j) - - radmod = rad(j) & - & * (facclr1u(k+1)*trans0(j,k) + faccld1u(k+1)*transc(j,k)) & - & - faccmb1u(k+1)*gassrcu(j,k) + faccmb2u(k+1)*cldsrcu(j,k) - - rad(j) = -radmod + facclr2u(k+1)*(clrradu(j) + radmod) & - & - faccld2u(k+1)*(cldradu(j) - radmod) - cldradu(j) = cldradu(j) + rad(j) - clrradu(j) = clrradu(j) - rad(j) - enddo - - else - -! --- ... clear layer - - do j = 1, NGPT - -! --- ... total sky radiance - radtotu(j) = radtotu(j)*trans0(j,k) + gassrcu(j,k) - toturad = toturad + radtotu(j) - -! --- ... clear sky radiance -! upward clear and total sky streams must remain separate -! because surface reflectance is different for each. - radclru(j) = radclru(j)*trans0(j,k) + gassrcu(j,k) - clrurad = clrurad + radclru(j) - enddo - - endif - - totuflux(k) = toturad - totuclfl(k) = clrurad - -! --- ... total sky radiance for each of the spectral bands - if ( lhlwb ) then - do j = 1, NGPT - inb = ngb(j) ! band index - totufxsb(inb,k) = totufxsb(inb,k) + radtotu(j) - enddo - endif - - enddo - -!===> ... convert radiances to fluxes and heating rates for total sky. -! calculates clear sky surface and toa values. to compute clear -! sky profiles, uncomment relevant lines below. - - factot = fluxfac * wtnum - - totuflux(0) = totuflux(0) * factot - totdflux(0) = totdflux(0) * factot - totuclfl(0) = totuclfl(0) * factot - totdclfl(0) = totdclfl(0) * factot - fnet(0) = totuflux(0) - totdflux(0) - - do k = 1, NLAY - totuflux(k) = totuflux(k) * factot - totdflux(k) = totdflux(k) * factot - - totuclfl(k) = totuclfl(k) * factot - totdclfl(k) = totdclfl(k) * factot - - fnet(k) = totuflux(k) - totdflux(k) - htr (k) = heatfac * (fnet(k-1) - fnet(k)) / delp(k) - enddo - -!! --- ... optional clear sky heating rates - if ( lhlw0 ) then - fnetc(0) = totuclfl(0) - totdclfl(0) - - do k = 1, NLAY - fnetc(k) = totuclfl(k) - totdclfl(k) - htrcl(k) = heatfac * (fnetc(k-1) - fnetc(k)) / delp(k) - enddo - endif - -!! --- ... optional spectral band heating rates - if ( lhlwb ) then - do j = 1, NBANDS - totufxsb(j,0) = totufxsb(j,0) * factot - totdfxsb(j,0) = totdfxsb(j,0) * factot - fnet(0) = totufxsb(j,0) - totdfxsb(j,0) - - do k = 1, NLAY - totufxsb(j,k) = totufxsb(j,k) * factot - totdfxsb(j,k) = totdfxsb(j,k) * factot - fnet(k) = totufxsb(j,k) - totdfxsb(j,k) - htrb(k,j) = heatfac * (fnet(k-1) - fnet(k)) / delp(k) - enddo - enddo - endif - - return -!................................... - end subroutine rtrnmr -!----------------------------------- - - - - -!----------------------------------- - subroutine taumol & -!................................... -! --- inputs: - & ( laytrop,layswtch,laylow,h2ovmr,colamt,wx,co2mult, & - & fac00,fac01,fac10,fac11,jp,jt,jt1,selffac,selffrac, & - & indself,forfac,secdiff,tauaer, NLAY, & -! --- outputs: - & itr, pfrac & - & ) - -! ************ original subprogram description *************** * -! * -! optical depths developed for the * -! * -! rapid radiative transfer model (rrtm) * -! * -! atmospheric and environmental research, inc. * -! 840 memorial drive * -! cambridge, ma 02139 * -! * -! eli j. mlawer * -! steven j. taubman * -! * -! email: mlawer@aer.com * -! * -! the authors wish to acknowledge the contributions of the * -! following people: patrick d. brown, michael j. iacono, * -! ronald e. farren, luke chen, robert bergstrom. * -! * -! revision for ncar ccm: michael j. iacono; september, 1998 * -! * -! taumol * -! * -! this file contains the subroutines taugbn (where n goes from * -! 1 to 16). taugbn calculates the optical depths and planck * -! fractions per g-value and layer for band n. * -! * -! output: transmittance look-up table index (unitless) * -! fractions needed to compute planck functions at every layer* -! and g-value * -! ! -! description: ! -! NG## - number of g-values in band ## (##=01-16) ! -! nspa(iband) - for the lower atmosphere, the number of reference ! -! atmospheres that are stored for band iband per ! -! pressure level and temperature. each of these ! -! atmospheres has different relative amounts of the ! -! key species for the band (i.e. different binary ! -! species parameters). ! -! nspb(iband) - same for upper atmosphere ! -! oneminus - since problems are caused in some cases by ! -! interpolation parameters equal to or greater than ! -! 1, for these cases these parameters are set to this! -! value, slightly < 1. ! -! laytrop, layswtch,laylow ! -! - layer at which switch is made from one combination ! -! of key species to another ! -! h2ovmr(NLAY)- layer h2o volume mixing ratio (vmr) ! -! colamt(NLAY,MAXGAS) ! -! - column amounts of water vapor,carbon dioxide, ! -! ozone, nitrous oxide, methane, o2, co, respectively! -! (molecules/cm**2) ! -! co2mult(NLAY)-for bands in which carbon dioxide is implemented ! -! as a trace species, this is the factor used to ! -! multiply the band's average co2 absorption ! -! coefficient to get the added contribution to the ! -! optical depth relative to 355 ppm. ! -! facij (NLAY)- for layer lay, these are factors that are needed to! -! compute the interpolation factors that multiply the! -! appropriate reference k-values. a value of 0 (1) ! -! for i,j indicates that the corresponding factor ! -! multiplies reference k-value for the lower (higher)! -! of the two appropriate temperatures, and altitudes,! -! respectively. ! -! jp (NLAY) - the index of the lower (in altitude) of the two ! -! appropriate reference pressure levels needed for ! -! interpolation. ! -! jt, jt1(NLAY)-the indices of the lower of the two appropriate ! -! reference temperatures needed for interpolation ! -! (for pressure levels jp and jp+1, respectively) ! -! selffac(NLAY)-scale factor needed to water vapor self-continuum, ! -! equals (water vapor density)/(atmospheric density ! -! at 296k and 1013 mb) ! -! selffrac(NLAY)factor needed for temperature interpolation of ! -! reference water vapor self-continuum data ! -! indself(NLAY)-index of the lower of the two appropriate reference! -! temperatures needed for the self-continuum ! -! interpolation ! -! secdiff(NBANDS)- variable diffusivity angle defined as an ! -! exponential function of the column water amount in ! -! bands 2-3 and 5-9. this reduces the bias of several! -! w/m2 in downward surface flux in high water ! -! profiles caused by using the constant diffusivity ! -! angle of 1.66.(mji) ! -! tauaer(NBANDS,NLAY)- aerosols optical depth ! -! ! -! data input ! -! absa(nspa(nn),5,13,NGnn), absb(nspb(nn),5,13:59,NGnn), ! -! selfref(10,NGnn) ! -! (note: nn is the band number) ! -! ! -! absa - k-values for low reference atmospheres (no water vapor ! -! self-continuum) (units: cm**2/molecule) ! -! absb - k-values for high reference atmospheres (all sources) ! -! (units: cm**2/molecule) ! -! selfref - k-values for water vapor self-continuum for reference ! -! atmospheres (used below laytrop) ! -! (units: cm**2/molecule) ! -! ! -! ****************************************************************** ! -! - implicit none -! -! --- inputs: - integer, intent(in) :: laytrop, layswtch, laylow, NLAY - - integer, dimension(:), intent(in) :: jp, jt, jt1, indself - - real (kind=kind_phys), dimension(:), intent(in) :: h2ovmr, & - & co2mult, fac00, fac01, fac10, fac11, selffac, selffrac, & - & forfac, secdiff - - real (kind=kind_phys), dimension(:,:),intent(in) :: colamt, wx, & - & tauaer - -! --- outputs: - real (kind=kind_phys), dimension(:,:), intent(out) :: pfrac - - integer, dimension(:,:), intent(out) :: itr - -! --- locals: - real (kind=kind_phys) :: taug(NGPT,NLAY), tem1, tem2 - integer :: j, k, ja, jb, kk, id0(NLAY,NBANDS), id1(NLAY,NBANDS), & - & inb -! -!===> ... begin here -! - do j = 1, NBANDS - ja = 13 - jb = 12 - kk = laytrop - if (j == 8) then - ja = 7 - jb = 6 - kk = layswtch - endif - - do k = 1, kk - id0(k,j) = ((jp(k)-1) *5 + jt (k) - 1) * nspa(j) - id1(k,j) = ( jp(k) *5 + jt1(k) - 1) * nspa(j) - enddo - do k = kk+1, NLAY - id0(k,j) = ((jp(k)-ja)*5 + jt (k) - 1) * nspb(j) - id1(k,j) = ((jp(k)-jb)*5 + jt1(k) - 1) * nspb(j) - enddo - enddo - - call taugb01 - call taugb02 - call taugb03 - call taugb04 - call taugb05 - call taugb06 - call taugb07 - call taugb08 - call taugb09 - call taugb10 - call taugb11 - call taugb12 - call taugb13 - call taugb14 - call taugb15 - call taugb16 - -! mji do k = 1, NLAY -! do j = 1, NGPT -! tem1 = max( f_zero, secang*taug(j,k) ) -! tem2 = tem1 / (bpade + tem1) -! itr(j,k) = 5.0e3 * tem2 + 0.5 -! enddo -! mji enddo - - do j = 1, NGPT - inb = ngb(j) - - do k = 1, NLAY -! tem1 = max( f_zero, secdiff(inb)*taug(j,k) ) - tem1 = max( f_zero, secdiff(inb)*(taug(j,k)+tauaer(inb,k)) ) - tem2 = tem1 / (bpade + tem1) - itr(j,k) = max(0, min(N5000, int(5.0e3*tem2+0.5) )) - enddo - enddo - - -! ================= - contains -! ================= - -!----------------------------------- - subroutine taugb01 -!................................... - -! ------------------------------------------------------------------ ! -! written by eli j. mlawer, atmospheric & environmental research. ! -! revised by michael j.iacono, atmospheric & environmental research! -! ! -! band 1: 10-250 cm-1 (low - h2o; high - h2o) ! -! ! -! compute the optical depth by interpolating in ln(pressure) and ! -! temperature. below laytrop, the water vapor self-continuum ! -! is interpolated (in temperature) separately. ! -! ------------------------------------------------------------------ ! -! - use module_radlw_kgb01 -! - implicit none -! - integer :: j, k, ind01, ind02, ind11, ind12, inds - - do k = 1, laytrop - ind01 = id0(k,1) + 1 - ind02 = ind01 + 1 - ind11 = min(MSA01, id1(k,1) + 1 ) - ind12 = min(MSA01, ind11 + 1) - inds = indself(k) - - do j = 1, NG01 - taug(j,k) = colamt(k,1) & - & * ( fac00(k)*absa(ind01,j) + fac10(k)*absa(ind02,j) + & - & fac01(k)*absa(ind11,j) + fac11(k)*absa(ind12,j) + & - & selffac(k)*( selfref(inds,j) + selffrac(k) * & - & (selfref(inds+1,j) - selfref(inds,j)) ) + & - & forfac(k)*forref(j) ) - - pfrac(j,k) = fracrefa(j) - enddo - enddo - - do k = laytrop+1, NLAY - ind01 = id0(k,1) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,1) + 1 - ind12 = ind11 + 1 - - do j = 1, NG01 - taug(j,k) = colamt(k,1) & - & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) + & - & fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) + & - & forfac(k) * forref(j) ) - - pfrac(j,k) = fracrefb(j) - enddo - enddo - - return -!................................... - end subroutine taugb01 -!----------------------------------- - - -!----------------------------------- - subroutine taugb02 -!................................... - -! band 2: 250-500 cm-1 (low - h2o; high - h2o) -! - use module_radlw_kgb02 -! - implicit none -! - integer :: i, j, k, ind01, ind02, ind11, ind12, inds, ifrac, ifp -! - real (kind=kind_phys) :: fc00, fc01, fc10, fc11, h2oparam, & - & fracint, one - data one / 1.0 / - -! compute the optical depth by interpolating in ln(pressure) and -! temperature. below laytrop, the water vapor self-continuum is -! interpolated (in temperature) separately. - - do k = 1, laytrop - h2oparam = h2ovmr(k) / (h2ovmr(k) + 0.002) - - ifrac = 13 -!!changed b_do_ifrac : do i = 2, 12 - lab_do_ifrac : do i = 2, 13 - if (h2oparam >= refparam(i)) then - ifrac = i - exit lab_do_ifrac - endif - enddo lab_do_ifrac - - fracint = max(-one, min(one, (h2oparam - refparam(ifrac)) & - & / (refparam(ifrac-1) - refparam(ifrac)) )) - - ifp = max( 0, int(2.e2*(fac11(k)+fac01(k))+0.5) ) - fc00 = fac00(k) * corr2(ifp) - fc10 = fac10(k) * corr2(ifp) - fc01 = fac01(k) * corr1(ifp) - fc11 = fac11(k) * corr1(ifp) - - ind01 = id0(k,2) + 1 - ind02 = ind01 + 1 - ind11 = min(MSA02, id1(k,2) + 1 ) - ind12 = min(MSA02, ind11 + 1 ) - inds = indself(k) - - do j = 1, NG02 - taug(NS02+j,k) = colamt(k,1) & - & * ( fc00*absa(ind01,j) + fc10*absa(ind02,j) + & - & fc01*absa(ind11,j) + fc11*absa(ind12,j) + & - & selffac(k)*(selfref(inds,j) + selffrac(k) * & - & ( selfref(inds+1,j) - selfref(inds,j)) ) + & - & forfac(k) * forref(j) ) - - pfrac(NS02+j,k) = fracrefa(j,ifrac) + fracint & - & * (fracrefa(j,ifrac-1) - fracrefa(j,ifrac)) - enddo - enddo - - do k = laytrop+1, NLAY - ifp = max( 0, int(2.e2*(fac11(k)+fac01(k))+0.5) ) - fc00 = fac00(k) * corr2(ifp) - fc10 = fac10(k) * corr2(ifp) - fc01 = fac01(k) * corr1(ifp) - fc11 = fac11(k) * corr1(ifp) - - ind01 = id0(k,2) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,2) + 1 - ind12 = ind11 + 1 - - do j = 1, NG02 - taug(NS02+j,k) = colamt(k,1) & - & * ( fc00*absb(ind01,j) + fc10*absb(ind02,j) + & - & fc01*absb(ind11,j) + fc11*absb(ind12,j) + & - & forfac(k) * forref(j) ) - - pfrac(NS02+j,k) = fracrefb(j) - enddo - enddo - - return -!................................... - end subroutine taugb02 -!----------------------------------- - - -!----------------------------------- - subroutine taugb03 -!................................... - -! band 3: 500-630 cm-1 (low - h2o,co2; high - h2o,co2) -! - use module_radlw_kgb03 -! - implicit none -! - integer :: j, k, ind01, ind02, ind03, ind04, ind11, ind12, ind13, & - & ind14, inds, js, ns, jp0, jp1 -! - real (kind=kind_phys) :: fac000, fac010, fac100, fac110, fac001, & - & fac011, fac101, fac111, strrat, speccomb, specmult, & - & fs, fs1, fp, ratio, n2omult, tem0, tem1, tem2 - - strrat = 1.19268 - -! compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, laytrop - speccomb = colamt(k,1) + strrat*colamt(k,2) - specmult = 8.0 * min(oneminus, colamt(k,1)/speccomb) - - js = 1 + int(specmult) - fs = specmult - int(specmult) - if (js == 8) then - if (fs >= 0.9) then - js = 9 - fs = 10.0 * (fs - 0.9) - else - fs = fs / 0.9 - endif - endif - - fs1 = 1.0 - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,3) + js - ind02 = ind01 + 1 - ind03 = ind01 + 10 - ind04 = ind01 + 11 - ind11 = min(MSA03, id1(k,3) + js ) - ind12 = min(MSA03, ind11 + 1 ) - ind13 = min(MSA03, ind11 + 10) - ind14 = min(MSA03, ind11 + 11) - inds = indself(k) - - jp0 = jp(k) - jp1 = jp0 + 1 - ns = js + int(fs + 0.5) - if (ns == 10) then - tem1 = n2oref(jp0) / h2oref(jp0) - tem2 = n2oref(jp1) / h2oref(jp1) - else - tem0 = (1.0 - etaref(ns)) / strrat - tem1 = tem0 * n2oref(jp0) / co2ref(jp0) - tem2 = tem0 * n2oref(jp1) / co2ref(jp1) - endif - ratio = tem1 + (fac01(k) + fac11(k)) * (tem2 - tem1) - n2omult = colamt(k,4) - speccomb*ratio - - do j = 1, NG03 - taug(NS03+j,k) = speccomb & - & * ( fac000*absa(ind01,j) + fac100*absa(ind02,j) + & - & fac010*absa(ind03,j) + fac110*absa(ind04,j) + & - & fac001*absa(ind11,j) + fac101*absa(ind12,j) + & - & fac011*absa(ind13,j) + fac111*absa(ind14,j) ) & - & + colamt(k,1) * ( selffac(k)*(selfref(inds,j) + & - & selffrac(k)*(selfref(inds+1,j)-selfref(inds,j)) ) + & - & forfac(k) * forref(j) ) & - & + n2omult * absn2oa(j) - - pfrac(NS03+j,k) = fracrefa(j,js) & - & + fs * (fracrefa(j,js+1) - fracrefa(j,js)) - enddo - enddo - - do k = laytrop+1, NLAY - speccomb = colamt(k,1) + strrat*colamt(k,2) - specmult = 4.0 * min(oneminus, colamt(k,1)/speccomb) - - js = 1 + int(specmult) - fs = specmult - int(specmult) - - fs1 = 1.0 - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,3) + js - ind02 = ind01 + 1 - ind03 = ind01 + 5 - ind04 = ind01 + 6 - ind11 = id1(k,3) + js - ind12 = ind11 + 1 - ind13 = ind11 + 5 - ind14 = ind11 + 6 - - jp0 = jp(k) - jp1 = jp0 + 1 - ns = js + int(fs + 0.5) - if (ns == 5) then - tem1 = n2oref(jp0) / h2oref(jp0) - tem2 = n2oref(jp1) / h2oref(jp1) - else - tem0 = (1.0 - etaref(ns)) / strrat - tem1 = tem0 * n2oref(jp0) / co2ref(jp0) - tem2 = tem0 * n2oref(jp1) / co2ref(jp1) - endif - ratio = tem1 + (fac01(k) + fac11(k)) * (tem2 - tem1) - n2omult = colamt(k,4) - speccomb * ratio - - do j = 1, NG03 - taug(NS03+j,k) = speccomb & - & * ( fac000*absb(ind01,j) + fac100*absb(ind02,j) + & - & fac010*absb(ind03,j) + fac110*absb(ind04,j) + & - & fac001*absb(ind11,j) + fac101*absb(ind12,j) + & - & fac011*absb(ind13,j) + fac111*absb(ind14,j) ) & - & + colamt(k,1) * forfac(k)*forref(j) & - & + n2omult * absn2ob(j) - - pfrac(NS03+j,k) = fracrefb(j,js) & - & + fs * (fracrefb(j,js+1) - fracrefb(j,js)) - enddo - enddo - - return -!................................... - end subroutine taugb03 -!----------------------------------- - - -!----------------------------------- - subroutine taugb04 -!................................... - -! band 4: 630-700 cm-1 (low - h2o,co2; high - o3,co2) -! - use module_radlw_kgb04 -! - implicit none -! - integer :: j, k, ind01, ind02, ind03, ind04, ind11, ind12, ind13, & - & ind14, inds, js, ns -! - real (kind=kind_phys) :: fac000, fac010, fac100, fac110, fac001, & - & fac011, fac101, fac111, strrat1, strrat2, speccomb, & - & specmult, fs, fs1 - - strrat1 = 850.577 - strrat2 = 35.7416 - -! compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, laytrop - speccomb = colamt(k,1) + strrat1*colamt(k,2) - specmult = 8.0 * min(oneminus, colamt(k,1)/speccomb) - - js = 1 + int(specmult) - fs = specmult - int(specmult) - - fs1 = 1.0 - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,4) + js - ind02 = ind01 + 1 - ind03 = ind01 + 9 - ind04 = ind01 + 10 - ind11 = min(MSA04, id1(k,4) + js ) - ind12 = min(MSA04, ind11 + 1 ) - ind13 = min(MSA04, ind11 + 9 ) - ind14 = min(MSA04, ind11 + 10) - inds = indself(k) - - do j = 1, NG04 - taug(NS04+j,k) = speccomb & - & * ( fac000*absa(ind01,j) + fac100*absa(ind02,j) + & - & fac010*absa(ind03,j) + fac110*absa(ind04,j) + & - & fac001*absa(ind11,j) + fac101*absa(ind12,j) + & - & fac011*absa(ind13,j) + fac111*absa(ind14,j) ) & - & + colamt(k,1) * selffac(k)*( selfref(inds,j) + & - & selffrac(k)*(selfref(inds+1,j)-selfref(inds,j)) ) - - pfrac(NS04+j,k) = fracrefa(j,js) & - & + fs * (fracrefa(j,js+1) - fracrefa(j,js)) - enddo - enddo - - do k = laytrop+1, NLAY - speccomb = colamt(k,3) + strrat2*colamt(k,2) - specmult = 4.0 * min(oneminus, colamt(k,3)/speccomb) - - js = 1 + int(specmult) - fs = specmult - int(specmult) - if (js > 1) then - js = js + 1 - elseif (fs >= 0.0024) then - js = 2 - fs = (fs - 0.0024) / 0.9976 - else - js = 1 - fs = fs / 0.0024 - endif - - fs1 = 1.0 - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,4) + js - ind02 = ind01 + 1 - ind03 = ind01 + 6 - ind04 = ind01 + 7 - ind11 = id1(k,4) + js - ind12 = ind11 + 1 - ind13 = ind11 + 6 - ind14 = ind11 + 7 - - do j = 1, NG04 - taug(NS04+j,k) = speccomb & - & * ( fac000*absb(ind01,j) + fac100*absb(ind02,j) + & - & fac010*absb(ind03,j) + fac110*absb(ind04,j) + & - & fac001*absb(ind11,j) + fac101*absb(ind12,j) + & - & fac011*absb(ind13,j) + fac111*absb(ind14,j) ) - - pfrac(NS04+j,k) = fracrefb(j,js) & - & + fs * (fracrefb(j,js+1) - fracrefb(j,js)) - enddo - -! empirical modification to code to improve stratospheric cooling rates -! for co2. revised to apply weighting for g-point reduction in this band. -! from mike iacono, aer, april 01, 2003. - - taug(NS04+8, k) = taug(NS04+8, k) * 0.92 - taug(NS04+9, k) = taug(NS04+9, k) * 0.88 - taug(NS04+10,k) = taug(NS04+10,k) * 1.07 - taug(NS04+11,k) = taug(NS04+11,k) * 1.10 - taug(NS04+12,k) = taug(NS04+12,k) * 0.99 - taug(NS04+13,k) = taug(NS04+13,k) * 0.88 - taug(NS04+14,k) = taug(NS04+14,k) * 0.943 - - enddo - - return -!................................... - end subroutine taugb04 -!----------------------------------- - - -!----------------------------------- - subroutine taugb05 -!................................... - -! band 5: 700-820 cm-1 (low - h2o,co2; high - o3,co2) -! - use module_radlw_kgb05 -! - implicit none -! - integer :: j, k, ind01, ind02, ind03, ind04, ind11, ind12, ind13, & - & ind14, inds, js, ns -! - real (kind=kind_phys) :: fac000, fac010, fac100, fac110, fac001, & - & fac011, fac101, fac111, strrat1, strrat2, speccomb, & - & specmult, fs, fs1 - - strrat1 = 90.4894 - strrat2 = 0.900502 - -! compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, laytrop - speccomb = colamt(k,1) + strrat1*colamt(k,2) - specmult = 8.0 * min(oneminus, colamt(k,1)/speccomb) - - js = 1 + int(specmult) - fs = specmult - int(specmult) - - fs1 = 1.0 - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,5) + js - ind02 = ind01 + 1 - ind03 = ind01 + 9 - ind04 = ind01 + 10 - ind11 = min(MSA05, id1(k,5) + js ) - ind12 = min(MSA05, ind11 + 1 ) - ind13 = min(MSA05, ind11 + 9 ) - ind14 = min(MSA05, ind11 + 10) - inds = indself(k) - - do j = 1, NG05 - taug(NS05+j,k) = speccomb & - & * ( fac000*absa(ind01,j) + fac100*absa(ind02,j) + & - & fac010*absa(ind03,j) + fac110*absa(ind04,j) + & - & fac001*absa(ind11,j) + fac101*absa(ind12,j) + & - & fac011*absa(ind13,j) + fac111*absa(ind14,j) ) & - & + colamt(k,1) * selffac(k)*( selfref(inds,j) + & - & selffrac(k)*(selfref(inds+1,j)-selfref(inds,j)) ) & - & + wx(k,1) * ccl4(j) - - pfrac(NS05+j,k) = fracrefa(j,js) & - & + fs * (fracrefa(j,js+1) - fracrefa(j,js)) - enddo - enddo - - do k = laytrop+1, NLAY - speccomb = colamt(k,3) + strrat2*colamt(k,2) - specmult = 4.0 * min(oneminus, colamt(k,3)/speccomb) - - js = 1 + int(specmult) - fs = specmult - int(specmult) - - fs1 = 1.0 - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,5) + js - ind02 = ind01 + 1 - ind03 = ind01 + 5 - ind04 = ind01 + 6 - ind11 = id1(k,5) + js - ind12 = ind11 + 1 - ind13 = ind11 + 5 - ind14 = ind11 + 6 - - do j = 1, NG05 - taug(NS05+j,k) = speccomb & - & * ( fac000*absb(ind01,j) + fac100*absb(ind02,j) + & - & fac010*absb(ind03,j) + fac110*absb(ind04,j) + & - & fac001*absb(ind11,j) + fac101*absb(ind12,j) + & - & fac011*absb(ind13,j) + fac111*absb(ind14,j) ) & - & + wx(k,1) * ccl4(j) - - pfrac(NS05+j,k) = fracrefb(j,js) & - & + fs * (fracrefb(j,js+1) - fracrefb(j,js)) - enddo - enddo - - return -!................................... - end subroutine taugb05 -!----------------------------------- - - -!----------------------------------- - subroutine taugb06 -!................................... - -! band 6: 820-980 cm-1 (low - h2o; high - nothing) -! - use module_radlw_kgb06 -! - implicit none -! - integer :: j, k, ind01, ind02, ind11, ind12, inds, js, ns - -! compute the optical depth by interpolating in ln(pressure) and -! temperature. the water vapor self-continuum is interpolated -! (in temperature) separately. - - do k = 1, laytrop - ind01 = id0(k,6) + 1 - ind02 = ind01 + 1 - ind11 = min(MSA06, id1(k,6) + 1 ) - ind12 = min(MSA06, ind11 + 1 ) - inds = indself(k) - - do j = 1, NG06 - taug(NS06+j,k) = colamt(k,1) & - & * ( fac00(k)*absa(ind01,j) + fac10(k)*absa(ind02,j) + & - & fac01(k)*absa(ind11,j) + fac11(k)*absa(ind12,j) + & - & selffac(k) *( selfref(inds,j) + & - & selffrac(k)*(selfref(inds+1,j)-selfref(inds,j)) ) ) & - & + wx(k,2) * cfc11adj(j) + wx(k,3) * cfc12(j) & - & + co2mult(k) * absco2(j) - - pfrac(NS06+j,k) = fracrefa(j) - enddo - enddo - -! nothing important goes on above laytrop in this band. - do k = laytrop+1, NLAY - do j = 1, NG06 - taug(NS06+j,k) = wx(k,2) * cfc11adj(j) + wx(k,3) * cfc12(j) - - pfrac(NS06+j,k) = fracrefa(j) - enddo - enddo - - return -!................................... - end subroutine taugb06 -!----------------------------------- - - -!----------------------------------- - subroutine taugb07 -!................................... - -! band 7: 980-1080 cm-1 (low - h2o,o3; high - o3) -! - use module_radlw_kgb07 -! - implicit none -! - integer :: j, k, ind01, ind02, ind03, ind04, ind11, ind12, ind13, & - & ind14, inds, js -! - real (kind=kind_phys) :: fac000, fac010, fac100, fac110, fac001, & - & fac011, fac101, fac111, strrat, speccomb, specmult, fs, fs1 - - strrat = 8.21104e4 - -! compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, laytrop - speccomb = colamt(k,1) + strrat*colamt(k,3) - specmult = 8.0 * min(oneminus, colamt(k,1)/speccomb) - - js = 1 + int(specmult) - fs = specmult - int(specmult) - - fs1 = 1.0 - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,7) + js - ind02 = ind01 + 1 - ind03 = ind01 + 9 - ind04 = ind01 + 10 - ind11 = min(MSA07, id1(k,7) + js ) - ind12 = min(MSA07, ind11 + 1 ) - ind13 = min(MSA07, ind11 + 9 ) - ind14 = min(MSA07, ind11 + 10) - inds = indself(k) - - do j = 1, NG07 - taug(NS07+j,k) = speccomb & - & * ( fac000*absa(ind01,j) + fac100*absa(ind02,j) + & - & fac010*absa(ind03,j) + fac110*absa(ind04,j) + & - & fac001*absa(ind11,j) + fac101*absa(ind12,j) + & - & fac011*absa(ind13,j) + fac111*absa(ind14,j) ) & - & + colamt(k,1) * selffac(k)*( selfref(inds,j) + & - & selffrac(k)*(selfref(inds+1,j)-selfref(inds,j)) ) & - & + co2mult(k) * absco2(j) - - pfrac(NS07+j,k) = fracrefa(j,js) & - & + fs * (fracrefa(j,js+1) - fracrefa(j,js)) - enddo - enddo - - do k = laytrop+1, NLAY - - ind01 = id0(k,7) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,7) + 1 - ind12 = ind11 + 1 - - do j = 1, NG07 - taug(NS07+j,k) = colamt(k,3) & - & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) + & - & fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) & - & + co2mult(k) * absco2(j) - - pfrac(NS07+j,k) = fracrefb(j) - enddo - -! empirical modification to code to improve stratospheric cooling rates -! for o3. revised to apply weighting for g-point reduction in this band. -! from mike iacono, aer, april 01, 2003. - - taug(NS07+6, k) = taug(NS07+6, k) * 0.92 - taug(NS07+7, k) = taug(NS07+7, k) * 0.88 - taug(NS07+8, k) = taug(NS07+8, k) * 1.07 - taug(NS07+9, k) = taug(NS07+9, k) * 1.10 - taug(NS07+10,k) = taug(NS07+10,k) * 0.99 - taug(NS07+11,k) = taug(NS07+11,k) * 0.855 - - enddo - - return -!................................... - end subroutine taugb07 -!----------------------------------- - - -!----------------------------------- - subroutine taugb08 -!................................... - -! band 8: 1080-1180 cm-1 (low (i.e.>~300mb) - h2o; high - o3) -! - use module_radlw_kgb08 -! - implicit none -! - integer :: j, k, ind01, ind02, ind11, ind12, inds, jp0, jp1 -! - real (kind=kind_phys) :: ratio, n2omult, tem1, tem2 - -! compute the optical depth by interpolating in ln(pressure) and -! temperature. - - do k = 1, layswtch - ind01 = id0(k,8) + 1 - ind02 = ind01 + 1 - ind11 = min(MSA08, id1(k,8) + 1 ) - ind12 = min(MSA08, ind11 + 1 ) - inds = indself(k) - - jp0 = jp(k) - jp1 = jp0 + 1 - tem1 = n2oref(jp0) / h2oref(jp0) - tem2 = n2oref(jp1) / h2oref(jp1) - ratio = tem1 + (fac01(k) + fac11(k)) * (tem2 - tem1) - n2omult = colamt(k,4) - colamt(K,1)*ratio - - do j = 1, NG08 - taug(NS08+j,k) = colamt(k,1) & - & * ( fac00(k)*absa(ind01,j) + fac10(k)*absa(ind02,j) + & - & fac01(k)*absa(ind11,j) + fac11(k)*absa(ind12,j) + & - & selffac(k)*( selfref(inds,j) + & - & selffrac(k)*(selfref(inds+1,j)-selfref(inds,j)) ) ) & - & + wx(k,3) * cfc12(j) + wx(k,4) * cfc22adj(j) & - & + co2mult(k) * absco2a(j) + n2omult * absn2oa(j) - - pfrac(NS08+j,k) = fracrefa(j) - enddo - enddo - - do k = layswtch+1, NLAY - ind01 = id0(k,8) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,8) + 1 - ind12 = ind11 + 1 - - jp0 = jp(k) - jp1 = jp0 + 1 - tem1 = n2oref(jp0) / o3ref(jp0) - tem2 = n2oref(jp1) / o3ref(jp1) - ratio = tem1 + (fac01(k) + fac11(k)) * (tem2 - tem1) - n2omult = colamt(k,4) - colamt(k,3) * ratio - - do j = 1, NG08 - taug(NS08+j,k) = colamt(k,3) & - & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) + & - & fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) & - & + wx(k,3) * cfc12(j) + wx(k,4) * cfc22adj(j) & - & + co2mult(k) * absco2b(j) + n2omult * absn2ob(j) - - pfrac(NS08+j,k) = fracrefb(j) - enddo - enddo - - return -!................................... - end subroutine taugb08 -!----------------------------------- - - -!----------------------------------- - subroutine taugb09 -!................................... - -! band 9: 1180-1390 cm-1 (low - h2o,ch4; high - ch4) -! - use module_radlw_kgb09 -! - implicit none -! - integer :: j, k, ind01, ind02, ind03, ind04, ind11, ind12, ind13, & - & ind14, inds, js, ns, jfrac, ioff, jp0, jp1 -! - real (kind=kind_phys) :: fac000, fac010, fac100, fac110, fac001, & - & fac011, fac101, fac111, strrat, speccomb, specmult, fs, fs1,& - & ffrac, ratio, n2omult, tem0, tem1, tem2 - - strrat = 21.6282 - ioff = 0 - -! compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, laytrop - if (k == laylow) ioff = NG09 - if (k == layswtch) ioff = 2 * NG09 - - speccomb = colamt(k,1) + strrat*colamt(k,5) - specmult = 8.0 * min(oneminus, colamt(k,1)/speccomb) - - js = 1 + int(specmult) - jfrac = js - fs = specmult - int(specmult) - ffrac = fs - if (js == 8) then - if (fs <= 0.68) then - fs = fs / 0.68 - elseif (fs <= 0.92) then - js = js + 1 - fs = (fs - 0.68) / 0.24 - else - js = js + 2 - fs = (fs - 0.92) / 0.08 - endif - elseif (js == 9) then - js = 10 - fs = 1.0 - jfrac = 8 - ffrac = 1.0 - endif - - fs1 = 1.0 - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,9) + js - ind02 = ind01 + 1 - ind03 = ind01 + 11 - ind04 = ind01 + 12 - ind11 = min(MSA09, id1(k,9) + js ) - ind12 = min(MSA09, ind11 + 1 ) - ind13 = min(MSA09, ind11 + 11) - ind14 = min(MSA09, ind11 + 12) - inds = indself(k) - - jp0 = jp(k) - jp1 = jp0 + 1 - ns = js + int(fs + 0.5) - tem0 = (1.0 - etaref(ns)) / strrat - if (ns == 11) then - tem1 = n2oref(jp0) / h2oref(jp0) - tem2 = n2oref(jp1) / h2oref(jp1) - else - tem1 = tem0 * n2oref(jp0) / ch4ref(jp0) - tem2 = tem0 * n2oref(jp1) / ch4ref(jp1) - endif - ratio = tem1 + (fac01(k) + fac11(k)) * (tem2 - tem1) - n2omult = colamt(k,4) - speccomb*ratio - - do j = 1, NG09 - taug(NS09+j,k) = speccomb & - & * ( fac000*absa(ind01,j) + fac100*absa(ind02,j) + & - & fac010*absa(ind03,j) + fac110*absa(ind04,j) + & - & fac001*absa(ind11,j) + fac101*absa(ind12,j) + & - & fac011*absa(ind13,j) + fac111*absa(ind14,j) ) & - & + colamt(k,1) * selffac(k)*( selfref(inds,j) + & - & selffrac(k)*(selfref(inds+1,j)-selfref(inds,j)) ) & - & + n2omult * absn2o(j+ioff) - - pfrac(NS09+j,k) = fracrefa(j,jfrac) & - & + ffrac * (fracrefa(j,jfrac+1)-fracrefa(j,jfrac)) - enddo - enddo - - do k = laytrop+1, NLAY - ind01 = id0(k,9) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,9) + 1 - ind12 = ind11 + 1 - - do j = 1, NG09 - taug(NS09+j,k) = colamt(k,5) & - & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) + & - & fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) - - pfrac(NS09+j,k) = fracrefb(j) - enddo - enddo - - return -!................................... - end subroutine taugb09 -!----------------------------------- - - -!----------------------------------- - subroutine taugb10 -!................................... - -! band 10: 1390-1480 cm-1 (low - h2o; high - h2o) -! - use module_radlw_kgb10 -! - implicit none -! - integer :: j, k, ind01, ind02, ind11, ind12 -! -! compute the optical depth by interpolating in ln(pressure) and -! temperature. - - do k = 1, laytrop - ind01 = id0(k,10) + 1 - ind02 = ind01 + 1 - ind11 = min(MSA10, id1(k,10) + 1 ) - ind12 = min(MSA10, ind11 + 1 ) - - do j = 1, NG10 - taug(NS10+j,k) = colamt(k,1) & - & * ( fac00(k)*absa(ind01,j) + fac10(k)*absa(ind02,j) + & - & fac01(k)*absa(ind11,j) + fac11(k)*absa(ind12,j) ) - - pfrac(NS10+j,k) = fracrefa(j) - enddo - enddo - - do k = laytrop+1, NLAY - ind01 = id0(k,10) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,10) + 1 - ind12 = ind11 + 1 - - do j = 1, NG10 - taug(NS10+j,k) = colamt(k,1) & - & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) + & - & fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) - - pfrac(NS10+j,k) = fracrefb(j) - enddo - enddo - - return -!................................... - end subroutine taugb10 -!----------------------------------- - - -!----------------------------------- - subroutine taugb11 -!................................... - -! band 11: 1480-1800 cm-1 (low - h2o; high - h2o) -! - use module_radlw_kgb11 -! - implicit none -! - integer :: j, k, ind01, ind02, ind11, ind12, inds -! - -! compute the optical depth by interpolating in ln(pressure) and -! temperature. below laytrop, the water vapor self-continuum -! is interpolated (in temperature) separately. - - do k = 1, laytrop - ind01 = id0(k,11) + 1 - ind02 = ind01 + 1 - ind11 = min(MSA11, id1(k,11) + 1 ) - ind12 = min(MSA11, ind11 + 1 ) - inds = indself(k) - - do j = 1, NG11 - taug(NS11+j,k) = colamt(k,1) & - & * ( fac00(k)*absa(ind01,j) + fac10(k)*absa(ind02,j) + & - & fac01(k)*absa(ind11,j) + fac11(k)*absa(ind12,j) + & - & selffac(k)*( selfref(inds,j) + selffrac(k) * & - & (selfref(inds+1,j)-selfref(inds,j)) ) ) - - pfrac(NS11+j,k) = fracrefa(j) - enddo - enddo - - do k = laytrop+1, NLAY - ind01 = id0(k,11) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,11) + 1 - ind12 = ind11 + 1 - - do j = 1, NG11 - taug(NS11+j,k) = colamt(k,1) & - & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) + & - & fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) - - pfrac(NS11+j,k) = fracrefb(j) - enddo - enddo - - return -!................................... - end subroutine taugb11 -!----------------------------------- - - -!----------------------------------- - subroutine taugb12 -!................................... - -! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing) -! - use module_radlw_kgb12 -! - implicit none -! - integer :: j, k, ind01, ind02, ind03, ind04, ind11, ind12, ind13, & - & ind14, inds, js -! - real (kind=kind_phys) :: fac000, fac010, fac100, fac110, fac001, & - & fac011, fac101, fac111, strrat, speccomb, specmult, fs, fs1 - - strrat = 0.009736757 - -! compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, laytrop - speccomb = colamt(k,1) + strrat*colamt(k,2) - specmult = 8.0 * min(oneminus, colamt(k,1)/speccomb) - - js = 1 + int(specmult) - fs = specmult - int(specmult) - - fs1 = 1.0 - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,12) + js - ind02 = ind01 + 1 - ind03 = ind01 + 9 - ind04 = ind01 + 10 - ind11 = min(MSA12, id1(k,12) + js ) - ind12 = min(MSA12, ind11 + 1 ) - ind13 = min(MSA12, ind11 + 9 ) - ind14 = min(MSA12, ind11 + 10) - inds = indself(k) - - do j = 1, NG12 - taug(NS12+j,k) = speccomb & - & * ( fac000*absa(ind01,j) + fac100*absa(ind02,j) + & - & fac010*absa(ind03,j) + fac110*absa(ind04,j) + & - & fac001*absa(ind11,j) + fac101*absa(ind12,j) + & - & fac011*absa(ind13,j) + fac111*absa(ind14,j) ) & - & + colamt(k,1)*selffac(k)*( selfref(inds,j) + & - & selffrac(k)*(selfref(inds+1,j)-selfref(inds,j)) ) - - pfrac(NS12+j,k) = fracrefa(j,js) & - & + fs * (fracrefa(j,js+1) - fracrefa(j,js)) - enddo - enddo - - do k = laytrop+1, NLAY - do j = 1, NG12 - taug(NS12+j,k) = f_zero - pfrac(NS12+j,k) = f_zero - enddo - enddo - - return -!................................... - end subroutine taugb12 -!----------------------------------- - - -!----------------------------------- - subroutine taugb13 -!................................... - -! band 13: 2080-2250 cm-1 (low - h2o,n2o; high - nothing) -! - use module_radlw_kgb13 -! - implicit none -! - integer :: j, k, ind01, ind02, ind03, ind04, ind11, ind12, ind13, & - & ind14, inds, js -! - real (kind=kind_phys) :: fac000, fac010, fac100, fac110, fac001, & - & fac011, fac101, fac111, strrat, speccomb, specmult, fs, fs1 - - strrat = 16658.87 - -! compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, laytrop - speccomb = colamt(k,1) + strrat*colamt(k,4) - specmult = 8.0 * min(oneminus, colamt(k,1)/speccomb) - - js = 1 + int(specmult) - fs = specmult - int(specmult) - - fs1 = 1.0 - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,13) + js - ind02 = ind01 + 1 - ind03 = ind01 + 9 - ind04 = ind01 + 10 - ind11 = min(MSA13, id1(k,13) + js ) - ind12 = min(MSA13, ind11 + 1 ) - ind13 = min(MSA13, ind11 + 9 ) - ind14 = min(MSA13, ind11 + 10) - inds = indself(k) - - do j = 1, NG13 - taug(NS13+j,k) = speccomb & - & * ( fac000*absa(ind01,j) + fac100*absa(ind02,j) + & - & fac010*absa(ind03,j) + fac110*absa(ind04,j) + & - & fac001*absa(ind11,j) + fac101*absa(ind12,j) + & - & fac011*absa(ind13,j) + fac111*absa(ind14,j) ) & - & + colamt(k,1)*selffac(k)*( selfref(inds,j) + & - & selffrac(k)*(selfref(inds+1,j)-selfref(inds,j)) ) - - pfrac(NS13+j,k) = fracrefa(j,js) & - & + fs * (fracrefa(j,js+1) - fracrefa(j,js)) - enddo - enddo - - do k = laytrop+1, NLAY - do j = 1, NG13 - taug(NS13+j,k) = f_zero - pfrac(NS13+j,k) = f_zero - enddo - enddo - - return -!................................... - end subroutine taugb13 -!----------------------------------- - - -!----------------------------------- - subroutine taugb14 -!................................... - -! band 14: 2250-2380 cm-1 (low - co2; high - co2) -! - use module_radlw_kgb14 -! - implicit none -! - integer :: j, k, ind01, ind02, ind11, ind12, inds -! - -! compute the optical depth by interpolating in ln(pressure) and -! temperature. below laytrop, the water vapor self-continuum -! is interpolated (in temperature) separately. - - do k = 1, laytrop - ind01 = id0(k,14) + 1 - ind02 = ind01 + 1 - ind11 = min(MSA14, id1(k,14) + 1 ) - ind12 = min(MSA14, ind11 + 1 ) - inds = indself(k) - - do j = 1, NG14 - taug(NS14+j,k) = colamt(k,2) & - & * ( fac00(k)*absa(ind01,j) + fac10(k)*absa(ind02,j) + & - & fac01(k)*absa(ind11,j) + fac11(k)*absa(ind12,j) ) & - & + colamt(k,1)*selffac(k)*( selfref(inds,j) + & - & selffrac(k)*(selfref(inds+1,j)-selfref(inds,j)) ) - - pfrac(NS14+j,k) = fracrefa(j) - enddo - enddo - - do k = laytrop+1, NLAY - ind01 = id0(k,14) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,14) + 1 - ind12 = ind11 + 1 - - do j = 1, NG14 - taug(NS14+j,k) = colamt(k,2) & - & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) + & - & fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) - - pfrac(NS14+j,k) = fracrefb(j) - enddo - enddo - - return -!................................... - end subroutine taugb14 -!----------------------------------- - - -!----------------------------------- - subroutine taugb15 -!................................... - -! band 15: 2380-2600 cm-1 (low - n2o,co2; high - nothing) -! - use module_radlw_kgb15 -! - implicit none -! - integer :: j, k, ind01, ind02, ind03, ind04, ind11, ind12, ind13, & - & ind14, inds, js -! - real (kind=kind_phys) :: fac000, fac010, fac100, fac110, fac001, & - & fac011, fac101, fac111, strrat, speccomb, specmult, fs, fs1 - - strrat = 0.2883201 - -! compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, laytrop - speccomb = colamt(k,4) + strrat*colamt(k,2) - specmult = 8.0 * min(oneminus, colamt(k,4)/speccomb) - - js = 1 + int(specmult) - fs = specmult - int(specmult) - - fs1 = 1.0 - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,15) + js - ind02 = ind01 + 1 - ind03 = ind01 + 9 - ind04 = ind01 + 10 - ind11 = min(MSA15, id1(k,15) + js ) - ind12 = min(MSA15, ind11 + 1 ) - ind13 = min(MSA15, ind11 + 9 ) - ind14 = min(MSA15, ind11 + 10) - inds = indself(k) - - do j = 1, NG15 - taug(NS15+j,k) = speccomb & - & * ( fac000*absa(ind01,j) + fac100*absa(ind02,j) + & - & fac010*absa(ind03,j) + fac110*absa(ind04,j) + & - & fac001*absa(ind11,j) + fac101*absa(ind12,j) + & - & fac011*absa(ind13,j) + fac111*absa(ind14,j) ) & - & + colamt(k,1)*selffac(k)*( selfref(inds,j) + & - & selffrac(k)*(selfref(inds+1,j)-selfref(inds,j)) ) - - pfrac(NS15+j,k) = fracrefa(j,js) & - & + fs * (fracrefa(j,js+1) - fracrefa(j,js)) - enddo - enddo - - do k = laytrop+1, NLAY - do j = 1, NG15 - taug(NS15+j,k) = f_zero - pfrac(NS15+j,k) = f_zero - enddo - enddo - - return -!................................... - end subroutine taugb15 -!----------------------------------- - - -!----------------------------------- - subroutine taugb16 -!................................... - -! band 16: 2600-3000 cm-1 (low - h2o,ch4; high - nothing) -! - use module_radlw_kgb16 -! - implicit none -! - integer :: j, k, ind01, ind02, ind03, ind04, ind11, ind12, ind13, & - & ind14, inds, js -! - real (kind=kind_phys) :: fac000, fac010, fac100, fac110, fac001, & - & fac011, fac101, fac111, strrat, speccomb, specmult, fs, fs1 - - strrat = 830.411 - -! compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, laytrop - speccomb = colamt(k,1) + strrat*colamt(k,5) - specmult = 8.0 * min(oneminus, colamt(k,1)/speccomb) - - js = 1 + int(specmult) - fs = specmult - int(specmult) - - fs1 = 1.0 - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,16) + js - ind02 = ind01 + 1 - ind03 = ind01 + 9 - ind04 = ind01 + 10 - ind11 = min(MSA16, id1(k,16) + js ) - ind12 = min(MSA16, ind11 + 1 ) - ind13 = min(MSA16, ind11 + 9 ) - ind14 = min(MSA16, ind11 + 10) - inds = indself(k) - - do j = 1, NG16 - taug(NS16+j,k) = speccomb & - & * ( fac000*absa(ind01,j) + fac100*absa(ind02,j) + & - & fac010*absa(ind03,j) + fac110*absa(ind04,j) + & - & fac001*absa(ind11,j) + fac101*absa(ind12,j) + & - & fac011*absa(ind13,j) + fac111*absa(ind14,j) ) & - & + colamt(k,1)*selffac(k)*( selfref(inds,j) + & - & selffrac(k)*(selfref(inds+1,j)-selfref(inds,j)) ) - - pfrac(NS16+j,k) = fracrefa(j,js) & - & + fs * (fracrefa(j,js+1) - fracrefa(j,js)) - enddo - enddo - - do k = laytrop+1, NLAY - do j = 1, NG16 - taug(NS16+j,k) = f_zero - pfrac(NS16+j,k) = f_zero - enddo - enddo - - return -!................................... - end subroutine taugb16 -!----------------------------------- - - -!................................... - end subroutine taumol -!----------------------------------- - - -! -!........................................! - end module module_radlw_main ! -!========================================! - diff --git a/src/fim/FIMsrc/fim/column/radlw_param.f b/src/fim/FIMsrc/fim/column/radlw_param.f deleted file mode 100644 index cfd61e5..0000000 --- a/src/fim/FIMsrc/fim/column/radlw_param.f +++ /dev/null @@ -1,207 +0,0 @@ -!!!!! ========================================================== !!!!! -!!!!! rrtm1 radiation package description !!!!! -!!!!! ========================================================== !!!!! -! ! -! the rrtm1 package includes these parts: ! -! ! -! 'radlw_rrtm1_param.f' ! -! 'radlw_rrtm1_datatb.f' ! -! 'radlw_rrtm1_main.f' ! -! ! -! the 'radlw_rrtm1_param.f' contains: ! -! ! -! 'module_radlw_cntr_para' -- control parameters set up ! -! 'module_radlw_parameters' -- band parameters set up ! -! ! -! the 'radlw_rrtm1_datatb.f' contains: ! -! ! -! 'module_radlw_avplank' -- plank flux data ! -! 'module_radlw_cldprlw' -- cloud property coefficients ! -! 'module_radlw_kgbnn' -- absorption coeffients for 16 ! -! bands, where nn = 01-16 ! -! ! -! the 'radlw_rrtm1_main.f' contains: ! -! ! -! 'module_radlw_main' -- main lw radiation transfer ! -! ! -! in the main module 'module_radlw_main' there are only two ! -! externally callable subroutines: ! -! ! -! ! -! 'lwrad' -- main rrtm1 lw radiation routine ! -! 'rlwinit' -- to initialize rrtm1 lw radiation ! -! ! -! all the lw radiation subprograms become contained subprograms ! -! in module 'module_radlw_rrtm' and many of them are not directly ! -! accessable from places outside the module. ! -! ! -! compilation sequence is: ! -! ! -! 'radlw_rrtm1_param.f' ! -! 'radlw_rrtm1_datatb.f' ! -! 'radlw_rrtm1_main.f' ! -! ! -! and all should be put in front of routines that use lw modules ! -! ! -! ! -! ! -! the original program declarations: ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Copyright 2002, 2003, Atmospheric & Environmental Research, Inc.(AER)! -! This software may be used, copied, or redistributed as long as it is ! -! not sold and this copyright notice is reproduced on each copy made. ! -! This model is provided as is without any express or implied warranties -! (http://www.rtweb.aer.com/) ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! rrtm ! -! ! -! rapid radiative transfer model ! -! ! -! atmospheric and environmental research, inc. ! -! 840 memorial drive ! -! cambridge, ma 02139 ! -! ! -! eli j. mlawer ! -! steven j. taubman~ ! -! shepard a. clough ! -! ! -! ~currently at gfdl ! -! ! -! email: mlawer@aer.com ! -! ! -! the authors wish to acknowledge the contributions of the ! -! following people: patrick d. brown, michael j. iacono, ! -! ronald e. farren, luke chen, robert bergstrom. ! -! ! -! ! -!!!!! ========================================================== !!!!! -!!!!! end descriptions !!!!! -!!!!! ========================================================== !!!!! - - - -!========================================! - module module_radlw_cntr_para ! -!........................................! -! - implicit none -! - integer :: ilwrate, iaerlw, irgaslw, icfclw, iflagliq, iflagice - -! -! --- set up control parameters for lw radiation -! - parameter ( ilwrate=2 ) !===> ... lw heating rate unit selection - ! =1: output in k/day - !(default) ! =2: output in k/second - - parameter ( iaerlw=1 ) !===> ... control flag for aerosols - ! =0: do not include aerosol effect - !(default) ! =1: aeros opt prop are calc for each spectral band - ! =2: broad band aeros opt prop are used for all bands - - parameter ( irgaslw=1 ) !===> ... control flag for rare gases (ch4,n2o,o2, etc.) - ! =0: do not include rare gases - !(default) ! =1: include all rare gases - - parameter ( icfclw=1 ) !===> ... control flag for halocarbon (cfc) gases - !(default) ! =0: do not include cfc gases - ! =1: include all cfc gases - - parameter ( iflagliq=3 ) !===> ... liq-cloud optical properties contrl flag - ! =0: input cloud opt depth, ignor iflagice setting - ! =1: input cwp,cip, (ccm2 method) ignor iflagice setting - ! =2: input cwp rew, ccm3 method for liquid clouds - !(default) ! =3: input cwp rew, hu and stamnes(1993) method for liq cld - - parameter ( iflagice=1 ) !===> ... ice-cloud optical properties contrl flag - ! only used when iflagliq .ge. 2, else is ignored - ! =0: input cip rei, ccm3 method for ice clouds - !(default) ! =1: input cip rei, ebert and curry(1997) for ice clouds - ! =2: input cip rei, streamer (1996) for ice clouds - -! -!........................................! - end module module_radlw_cntr_para ! -!========================================! - - - -!========================================! - module module_radlw_parameters ! -!........................................! - - use machine, only : kind_phys - - implicit none -! - public -! -! --- define type construct for radiation fluxes at toa -! - type :: topflw_type - real (kind=kind_phys) :: upfxc ! total sky upward flux at toa - real (kind=kind_phys) :: upfx0 ! clear sky upward flux at toa - end type -! -! --- define type construct for radiation fluxes at surface -! - type :: sfcflw_type - real (kind=kind_phys) :: upfxc ! total sky upward flux at sfc - real (kind=kind_phys) :: upfx0 ! clear sky upward flux at sfc - real (kind=kind_phys) :: dnfxc ! total sky downward flux at sfc - real (kind=kind_phys) :: dnfx0 ! clear sky downward flux at sfc - end type -! -! --- define type construct for optional radiation flux profiles -! - type :: proflw_type - real (kind=kind_phys) :: upfxc ! level up flux for total sky - real (kind=kind_phys) :: dnfxc ! level dn flux for total sky - real (kind=kind_phys) :: upfx0 ! level up flux for clear sky - real (kind=kind_phys) :: dnfx0 ! level dn flux for clear sky - end type -! -! --- parameter constants for lw band structures -! - integer, parameter :: NBANDS = 16 ! num of total spectral bands - integer, parameter :: NGPT = 140 ! num of total g-points - integer, parameter :: N5000 = 5000 ! - integer, parameter :: N200 = 200 ! - integer, parameter :: MAXGAS = 6 ! max num of absorbing gases - integer, parameter :: MAXXSEC= 4 ! num of halocarbon gases - integer, parameter :: NPLNK = 181 ! dim for plank function table - - integer, parameter :: NBDLW = NBANDS - -! --- number of g-point in each band - integer :: NG01, NG02, NG03, NG04, NG05, NG06, NG07, NG08, & - & NG09, NG10, NG11, NG12, NG13, NG14, NG15, NG16 - parameter (NG01=08, NG02=14, NG03=16, NG04=14, NG05=16, NG06=08, & - & NG07=12, NG08=08, NG09=12, NG10=06, NG11=08, NG12=08, & - & NG13=04, NG14=02, NG15=02, NG16=02) - -! --- begining index of each band - integer :: NS01, NS02, NS03, NS04, NS05, NS06, NS07, NS08, & - & NS09, NS10, NS11, NS12, NS13, NS14, NS15, NS16 - parameter (NS01=00, NS02=08, NS03=22, NS04=38, NS05=52, NS06=68, & - & NS07=76, NS08=88, NS09=96, NS10=108, NS11=114, & - & NS12=122, NS13=130, NS14=134, NS15=136, NS16=138) - -! --- band spectrum structures (wavenumber in cm**-1) - real (kind=kind_phys) :: wvnlw1(NBANDS), wvnlw2(NBANDS) - data wvnlw1 / & - & 10., 251., 501., 631., 701., 821., 981., 1081., & - & 1181., 1391., 1481., 1801., 2081., 2251., 2381., 2601. / - data wvnlw2 / & - & 250., 500., 630., 700., 820., 980., 1080., 1180., & - & 1390., 1480., 1800., 2080., 2250., 2380., 2600., 3000. / - - -!........................................! - end module module_radlw_parameters ! -!========================================! diff --git a/src/fim/FIMsrc/fim/column/radsw_datatb.f b/src/fim/FIMsrc/fim/column/radsw_datatb.f deleted file mode 100644 index b388540..0000000 --- a/src/fim/FIMsrc/fim/column/radsw_datatb.f +++ /dev/null @@ -1,20975 +0,0 @@ -!!!!! ========================================================== !!!!! -!!!!! sw-rrtm2 radiation package description !!!!! -!!!!! ========================================================== !!!!! -! ! -! the sw-rrtm2 package includes these parts: ! -! ! -! 'radsw_rrtm2_param.f' ! -! 'radsw_rrtm2_datatb.f' ! -! 'radsw_rrtm2_main.f' ! -! ! -! the 'radsw_rrtm2_param.f' contains: ! -! ! -! 'module_radsw_parameters' -- band parameters set up ! -! 'module_radsw_cntr_para' -- control parameters set up ! -! ! -! the 'radsw_rrtm2_datatb.f' contains: ! -! ! -! 'module_radsw_cldprtb' -- cloud property coefficients table ! -! 'module_radsw_sflux' -- spectral solar flux distribution ! -! 'module_radsw_kgbnn' -- absorption coeffients for 14 ! -! bands, where nn = 16-29 ! -! ! -! the 'radsw_rrtm2_main.f' contains: ! -! ! -! 'module_radsw_main' -- main sw radiation transfer ! -! ! -! in the main module 'module_radsw_main' there are only two ! -! externally callable subroutines: ! -! ! -! 'swrad' -- main rrtm2 sw radiation routine ! -! 'rswinit' -- initialization routine ! -! ! -! all the sw radiation subprograms become contained subprograms ! -! in module 'module_radsw_main' and many of them are not directly ! -! accessable from places outside the module. ! -! ! -! compilation sequence is: ! -! ! -! 'radsw_rrtm2_param.f' ! -! 'radsw_rrtm2_datatb.f' ! -! 'radsw_rrtm2_main.f' ! -! ! -! and all should be put in front of routines that use sw modules ! -! ! -!!!!! ========================================================== !!!!! -!!!!! end descriptions !!!!! -!!!!! ========================================================== !!!!! - - - -!========================================! - module module_radsw_cldprtb ! -!........................................! -! -! ********* module descriptions ********* ! -! ! -! this module contains coefficients of cloud-optical properties ! -! for each of the spectral bands. modified from aer/ecmwf rrtm ! -! sw radiation package subroutine "susrtop". ! -! ! -! modify history: ! -! jan. 14, 2004 -- yu-tai hou convert subroutine to data ! -! module for ncep models. ! -! ! -! ********* the original program descriptions ********* ! -! ! -! adapted from j. delamere, atmospheric & environmental research. ! -! by jjmorcrette, ecmwf 02/10/29 ! -! revision: j.d. 2.6 2002/04/04 18:29:47 ! -! reformatted for f90 by jjmorcrette, ecmwf ! -! ! -! name type purpose -! ---- : ---- : --------------------------------------------------! -! xxxliq1 : real : optical properties (extinction coefficient, single! -! scattering albedo, assymetry factor) from ! -! hu & stamnes, 1993, j. clim., 6, 728-742 ! -! xxxice3 : real : optical properties (extinction coefficient, single! -! scattering albedo, assymetry factor) from ! -! fu, 1996, j. clim., 9, ! -! ! -! ********* ********* end description ********* ********* ! - - use machine, only : kind_phys - use module_radsw_parameters, only : NBLOW, NBHGH -! - implicit none -! - private - -! absdatliqn is the liquid water absorption coefficient (m^2/g). -! === for iflagliq = 0, - real (kind=kind_phys), parameter, public :: absdatliq1=0.0602410 - -! === everything below is for iflagliq >= 1. - - real (kind=kind_phys), dimension(58,NBLOW:NBHGH), public :: & - & extdatliq1, ssadatliq1, asydatliq1 - real (kind=kind_phys), dimension(27,NBLOW:NBHGH), public :: & - & extdatice3, ssadatice3, asydatice3, fdldatice3 - - data extdatliq1(:, 16) / & - & 8.981463e-01,6.317895e-01,4.557508e-01,3.481624e-01,2.797950e-01,& - & 2.342753e-01,2.026934e-01,1.800102e-01,1.632408e-01,1.505384e-01,& - & 1.354524e-01,1.246520e-01,1.154342e-01,1.074756e-01,1.005353e-01,& - & 9.442987e-02,8.901760e-02,8.418693e-02,7.984904e-02,7.593229e-02,& - & 7.237827e-02,6.913887e-02,6.617415e-02,6.345061e-02,6.094001e-02,& - & 5.861834e-02,5.646506e-02,5.446250e-02,5.249596e-02,5.081114e-02,& - & 4.922243e-02,4.772189e-02,4.630243e-02,4.495766e-02,4.368189e-02,& - & 4.246995e-02,4.131720e-02,4.021941e-02,3.917276e-02,3.817376e-02,& - & 3.721926e-02,3.630635e-02,3.543237e-02,3.459491e-02,3.379171e-02,& - & 3.302073e-02,3.228007e-02,3.156798e-02,3.088284e-02,3.022315e-02,& - & 2.958753e-02,2.897468e-02,2.838340e-02,2.781258e-02,2.726117e-02,& - & 2.672821e-02,2.621278e-02,2.5714e-02 / - data extdatliq1(:, 17) / & - & 8.293797e-01,6.048371e-01,4.465706e-01,3.460387e-01,2.800064e-01,& - & 2.346584e-01,2.022399e-01,1.782626e-01,1.600153e-01,1.457903e-01,& - & 1.334061e-01,1.228548e-01,1.138396e-01,1.060486e-01,9.924856e-02,& - & 9.326208e-02,8.795158e-02,8.320883e-02,7.894750e-02,7.509792e-02,& - & 7.160323e-02,6.841653e-02,6.549889e-02,6.281763e-02,6.034516e-02,& - & 5.805802e-02,5.593615e-02,5.396226e-02,5.202302e-02,5.036246e-02,& - & 4.879606e-02,4.731610e-02,4.591565e-02,4.458852e-02,4.332912e-02,& - & 4.213243e-02,4.099390e-02,3.990941e-02,3.887522e-02,3.788792e-02,& - & 3.694440e-02,3.604183e-02,3.517760e-02,3.434934e-02,3.355485e-02,& - & 3.279211e-02,3.205925e-02,3.135458e-02,3.067648e-02,3.002349e-02,& - & 2.939425e-02,2.878748e-02,2.820200e-02,2.763673e-02,2.709062e-02,& - & 2.656272e-02,2.605214e-02,2.5558e-02 / - data extdatliq1(:, 18) / & - & 9.193685e-01,6.128292e-01,4.344150e-01,3.303048e-01,2.659500e-01,& - & 2.239727e-01,1.953457e-01,1.751012e-01,1.603515e-01,1.493360e-01,& - & 1.323791e-01,1.219335e-01,1.130076e-01,1.052926e-01,9.855839e-02,& - & 9.262925e-02,8.736918e-02,8.267112e-02,7.844965e-02,7.463585e-02,& - & 7.117343e-02,6.801601e-02,6.512503e-02,6.246815e-02,6.001806e-02,& - & 5.775154e-02,5.564872e-02,5.369250e-02,5.176284e-02,5.011536e-02,& - & 4.856099e-02,4.709211e-02,4.570193e-02,4.438430e-02,4.313375e-02,& - & 4.194529e-02,4.081443e-02,3.973712e-02,3.870966e-02,3.772866e-02,& - & 3.679108e-02,3.589409e-02,3.503514e-02,3.421185e-02,3.342206e-02,& - & 3.266377e-02,3.193513e-02,3.123447e-02,3.056018e-02,2.991081e-02,& - & 2.928502e-02,2.868154e-02,2.809920e-02,2.753692e-02,2.699367e-02,& - & 2.646852e-02,2.596057e-02,2.5469e-02 / - data extdatliq1(:, 19) / & - & 9.136931e-01,5.743244e-01,4.080708e-01,3.150572e-01,2.577261e-01,& - & 2.197900e-01,1.933037e-01,1.740212e-01,1.595056e-01,1.482756e-01,& - & 1.312164e-01,1.209246e-01,1.121227e-01,1.045095e-01,9.785967e-02,& - & 9.200149e-02,8.680170e-02,8.215531e-02,7.797850e-02,7.420361e-02,& - & 7.077530e-02,6.764798e-02,6.478369e-02,6.215063e-02,5.972189e-02,& - & 5.747458e-02,5.538913e-02,5.344866e-02,5.153216e-02,4.989745e-02,& - & 4.835476e-02,4.689661e-02,4.551629e-02,4.420777e-02,4.296563e-02,& - & 4.178497e-02,4.066137e-02,3.959081e-02,3.856963e-02,3.759452e-02,& - & 3.666244e-02,3.577061e-02,3.491650e-02,3.409777e-02,3.331227e-02,& - & 3.255803e-02,3.183322e-02,3.113617e-02,3.046530e-02,2.981918e-02,& - & 2.919646e-02,2.859591e-02,2.801635e-02,2.745671e-02,2.691599e-02,& - & 2.639324e-02,2.588759e-02,2.5398e-02 / - data extdatliq1(:, 20) / & - & 8.447548e-01,5.326840e-01,3.921523e-01,3.119082e-01,2.597055e-01,& - & 2.228737e-01,1.954157e-01,1.741155e-01,1.570881e-01,1.431520e-01,& - & 1.302034e-01,1.200491e-01,1.113571e-01,1.038330e-01,9.725657e-02,& - & 9.145949e-02,8.631112e-02,8.170840e-02,7.756901e-02,7.382641e-02,& - & 7.042616e-02,6.732338e-02,6.448069e-02,6.186672e-02,5.945494e-02,& - & 5.722277e-02,5.515089e-02,5.322262e-02,5.132153e-02,4.969799e-02,& - & 4.816556e-02,4.671686e-02,4.534525e-02,4.404480e-02,4.281014e-02,& - & 4.163643e-02,4.051930e-02,3.945479e-02,3.843927e-02,3.746945e-02,& - & 3.654234e-02,3.565518e-02,3.480547e-02,3.399088e-02,3.320930e-02,& - & 3.245876e-02,3.173745e-02,3.104371e-02,3.037600e-02,2.973287e-02,& - & 2.911300e-02,2.851516e-02,2.793818e-02,2.738101e-02,2.684264e-02,& - & 2.632214e-02,2.581863e-02,2.5331e-02 / - data extdatliq1(:, 21) / & - & 7.727642e-01,5.034865e-01,3.808673e-01,3.080333e-01,2.586453e-01,& - & 2.224989e-01,1.947060e-01,1.725821e-01,1.545096e-01,1.394456e-01,& - & 1.288683e-01,1.188852e-01,1.103317e-01,1.029214e-01,9.643967e-02,& - & 9.072239e-02,8.564194e-02,8.109758e-02,7.700875e-02,7.331026e-02,& - & 6.994879e-02,6.688028e-02,6.406807e-02,6.148133e-02,5.909400e-02,& - & 5.688388e-02,5.483197e-02,5.292185e-02,5.103763e-02,4.942905e-02,& - & 4.791039e-02,4.647438e-02,4.511453e-02,4.382497e-02,4.260043e-02,& - & 4.143616e-02,4.032784e-02,3.927155e-02,3.826375e-02,3.730117e-02,& - & 3.638087e-02,3.550013e-02,3.465646e-02,3.384759e-02,3.307141e-02,& - & 3.232598e-02,3.160953e-02,3.092040e-02,3.025706e-02,2.961810e-02,& - & 2.900220e-02,2.840814e-02,2.783478e-02,2.728106e-02,2.674599e-02,& - & 2.622864e-02,2.572816e-02,2.5244e-02 / - data extdatliq1(:, 22) / & - & 7.416833e-01,4.959591e-01,3.775057e-01,3.056353e-01,2.565943e-01,& - & 2.206935e-01,1.931479e-01,1.712860e-01,1.534837e-01,1.386906e-01,& - & 1.281198e-01,1.182344e-01,1.097595e-01,1.024137e-01,9.598552e-02,& - & 9.031320e-02,8.527093e-02,8.075927e-02,7.669869e-02,7.302481e-02,& - & 6.968491e-02,6.663542e-02,6.384008e-02,6.126838e-02,5.889452e-02,& - & 5.669654e-02,5.465558e-02,5.275540e-02,5.087937e-02,4.927904e-02,& - & 4.776796e-02,4.633895e-02,4.498557e-02,4.370202e-02,4.248306e-02,& - & 4.132399e-02,4.022052e-02,3.916878e-02,3.816523e-02,3.720665e-02,& - & 3.629011e-02,3.541290e-02,3.457257e-02,3.376685e-02,3.299365e-02,& - & 3.225105e-02,3.153728e-02,3.085069e-02,3.018977e-02,2.955310e-02,& - & 2.893940e-02,2.834742e-02,2.777606e-02,2.722424e-02,2.669099e-02,& - & 2.617539e-02,2.567658e-02,2.5194e-02 / - data extdatliq1(:, 23) / & - & 7.058580e-01,4.866573e-01,3.712238e-01,2.998638e-01,2.513441e-01,& - & 2.161972e-01,1.895576e-01,1.686669e-01,1.518437e-01,1.380046e-01,& - & 1.267564e-01,1.170399e-01,1.087026e-01,1.014704e-01,9.513729e-02,& - & 8.954555e-02,8.457221e-02,8.012009e-02,7.611136e-02,7.248294e-02,& - & 6.918317e-02,6.616934e-02,6.340584e-02,6.086273e-02,5.851465e-02,& - & 5.634001e-02,5.432027e-02,5.243946e-02,5.058070e-02,4.899628e-02,& - & 4.749975e-02,4.608411e-02,4.474303e-02,4.347082e-02,4.226237e-02,& - & 4.111303e-02,4.001861e-02,3.897528e-02,3.797959e-02,3.702835e-02,& - & 3.611867e-02,3.524791e-02,3.441364e-02,3.361360e-02,3.284577e-02,& - & 3.210823e-02,3.139923e-02,3.071716e-02,3.006052e-02,2.942791e-02,& - & 2.881806e-02,2.822974e-02,2.766185e-02,2.711335e-02,2.658326e-02,& - & 2.607066e-02,2.557473e-02,2.5095e-02 / - data extdatliq1(:, 24) / & - & 6.822779e-01,4.750373e-01,3.634834e-01,2.940726e-01,2.468060e-01,& - & 2.125768e-01,1.866586e-01,1.663588e-01,1.500326e-01,1.366192e-01,& - & 1.253472e-01,1.158052e-01,1.076101e-01,1.004954e-01,9.426089e-02,& - & 8.875268e-02,8.385090e-02,7.946063e-02,7.550578e-02,7.192466e-02,& - & 6.866669e-02,6.569001e-02,6.295971e-02,6.044642e-02,5.812526e-02,& - & 5.597500e-02,5.397746e-02,5.211690e-02,5.027505e-02,4.870703e-02,& - & 4.722555e-02,4.582373e-02,4.449540e-02,4.323497e-02,4.203742e-02,& - & 4.089821e-02,3.981321e-02,3.877867e-02,3.779118e-02,3.684762e-02,& - & 3.594514e-02,3.508114e-02,3.425322e-02,3.345917e-02,3.269698e-02,& - & 3.196477e-02,3.126082e-02,3.058352e-02,2.993141e-02,2.930310e-02,& - & 2.869732e-02,2.811289e-02,2.754869e-02,2.700371e-02,2.647698e-02,& - & 2.596760e-02,2.547473e-02,2.4998e-02 / - data extdatliq1(:, 25) / & - & 6.666233e-01,4.662044e-01,3.579517e-01,2.902984e-01,2.440475e-01,& - & 2.104431e-01,1.849277e-01,1.648970e-01,1.487555e-01,1.354714e-01,& - & 1.244173e-01,1.149913e-01,1.068903e-01,9.985323e-02,9.368351e-02,& - & 8.823009e-02,8.337507e-02,7.902511e-02,7.510529e-02,7.155482e-02,& - & 6.832386e-02,6.537113e-02,6.266218e-02,6.016802e-02,5.786408e-02,& - & 5.572939e-02,5.374598e-02,5.189830e-02,5.006825e-02,4.851081e-02,& - & 4.703906e-02,4.564623e-02,4.432621e-02,4.307349e-02,4.188312e-02,& - & 4.075060e-02,3.967183e-02,3.864313e-02,3.766111e-02,3.672269e-02,& - & 3.582505e-02,3.496559e-02,3.414196e-02,3.335198e-02,3.259362e-02,& - & 3.186505e-02,3.116454e-02,3.049052e-02,2.984152e-02,2.921617e-02,& - & 2.861322e-02,2.803148e-02,2.746986e-02,2.692733e-02,2.640295e-02,& - & 2.589582e-02,2.540510e-02,2.4930e-02 / - data extdatliq1(:, 26) / & - & 6.535669e-01,4.585865e-01,3.529226e-01,2.867245e-01,2.413848e-01,& - & 2.083956e-01,1.833191e-01,1.636150e-01,1.477247e-01,1.346392e-01,& - & 1.236449e-01,1.143095e-01,1.062828e-01,9.930773e-02,9.319029e-02,& - & 8.778150e-02,8.296497e-02,7.864847e-02,7.475799e-02,7.123343e-02,& - & 6.802549e-02,6.509332e-02,6.240285e-02,5.992538e-02,5.763657e-02,& - & 5.551566e-02,5.354483e-02,5.170870e-02,4.988866e-02,4.834061e-02,& - & 4.687751e-02,4.549264e-02,4.417999e-02,4.293410e-02,4.175006e-02,& - & 4.062344e-02,3.955019e-02,3.852663e-02,3.754943e-02,3.661553e-02,& - & 3.572214e-02,3.486669e-02,3.404683e-02,3.326040e-02,3.250542e-02,& - & 3.178003e-02,3.108254e-02,3.041139e-02,2.976511e-02,2.914235e-02,& - & 2.854187e-02,2.796247e-02,2.740309e-02,2.686271e-02,2.634038e-02,& - & 2.583520e-02,2.534636e-02,2.4873e-02 / - data extdatliq1(:, 27) / & - & 6.448790e-01,4.541425e-01,3.503348e-01,2.850494e-01,2.401966e-01,& - & 2.074811e-01,1.825631e-01,1.629515e-01,1.471142e-01,1.340574e-01,& - & 1.231462e-01,1.138628e-01,1.058802e-01,9.894286e-02,9.285818e-02,& - & 8.747802e-02,8.268676e-02,7.839271e-02,7.452230e-02,7.101580e-02,& - & 6.782418e-02,6.490685e-02,6.222991e-02,5.976484e-02,5.748742e-02,& - & 5.537703e-02,5.341593e-02,5.158883e-02,4.977355e-02,4.823172e-02,& - & 4.677430e-02,4.539465e-02,4.408680e-02,4.284533e-02,4.166539e-02,& - & 4.054257e-02,3.947283e-02,3.845256e-02,3.747842e-02,3.654737e-02,& - & 3.565665e-02,3.480370e-02,3.398620e-02,3.320198e-02,3.244908e-02,& - & 3.172566e-02,3.103002e-02,3.036062e-02,2.971600e-02,2.909482e-02,& - & 2.849582e-02,2.791785e-02,2.735982e-02,2.682072e-02,2.629960e-02,& - & 2.579559e-02,2.530786e-02,2.4836e-02 / - data extdatliq1(:, 28) / & - & 6.422688e-01,4.528453e-01,3.497232e-01,2.847724e-01,2.400815e-01,& - & 2.074403e-01,1.825502e-01,1.629415e-01,1.470934e-01,1.340183e-01,& - & 1.230935e-01,1.138049e-01,1.058201e-01,9.888245e-02,9.279878e-02,& - & 8.742053e-02,8.263175e-02,7.834058e-02,7.447327e-02,7.097000e-02,& - & 6.778167e-02,6.486765e-02,6.219400e-02,5.973215e-02,5.745790e-02,& - & 5.535059e-02,5.339250e-02,5.156831e-02,4.975308e-02,4.821235e-02,& - & 4.675596e-02,4.537727e-02,4.407030e-02,4.282968e-02,4.165053e-02,& - & 4.052845e-02,3.945941e-02,3.843980e-02,3.746628e-02,3.653583e-02,& - & 3.564567e-02,3.479326e-02,3.397626e-02,3.319253e-02,3.244008e-02,& - & 3.171711e-02,3.102189e-02,3.035289e-02,2.970866e-02,2.908784e-02,& - & 2.848920e-02,2.791156e-02,2.735385e-02,2.681507e-02,2.629425e-02,& - & 2.579053e-02,2.530308e-02,2.4831e-02 / - data extdatliq1(:, 29) / & - & 4.614710e-01,4.556116e-01,4.056568e-01,3.529833e-01,3.060334e-01,& - & 2.658127e-01,2.316095e-01,2.024325e-01,1.773749e-01,1.556867e-01,& - & 1.455558e-01,1.332882e-01,1.229052e-01,1.140067e-01,1.062981e-01,& - & 9.955703e-02,9.361333e-02,8.833420e-02,8.361467e-02,7.937071e-02,& - & 7.553420e-02,7.204942e-02,6.887031e-02,6.595851e-02,6.328178e-02,& - & 6.081286e-02,5.852854e-02,5.640892e-02,5.431269e-02,5.252561e-02,& - & 5.084345e-02,4.925727e-02,4.775910e-02,4.634182e-02,4.499907e-02,& - & 4.372512e-02,4.251484e-02,4.136357e-02,4.026710e-02,3.922162e-02,& - & 3.822365e-02,3.727004e-02,3.635790e-02,3.548457e-02,3.464764e-02,& - & 3.384488e-02,3.307424e-02,3.233384e-02,3.162192e-02,3.093688e-02,& - & 3.027723e-02,2.964158e-02,2.902864e-02,2.843722e-02,2.786621e-02,& - & 2.731457e-02,2.678133e-02,2.6266e-02 / - - data ssadatliq1(:, 16) / & - & 8.143821e-01,7.836739e-01,7.550722e-01,7.306269e-01,7.105612e-01,& - & 6.946649e-01,6.825556e-01,6.737762e-01,6.678448e-01,6.642830e-01,& - & 6.679741e-01,6.584607e-01,6.505598e-01,6.440951e-01,6.388901e-01,& - & 6.347689e-01,6.315549e-01,6.290718e-01,6.271432e-01,6.255928e-01,& - & 6.242441e-01,6.229207e-01,6.214464e-01,6.196445e-01,6.173388e-01,& - & 6.143527e-01,6.105099e-01,6.056339e-01,6.108290e-01,6.073939e-01,& - & 6.043073e-01,6.015473e-01,5.990913e-01,5.969173e-01,5.950028e-01,& - & 5.933257e-01,5.918636e-01,5.905944e-01,5.894957e-01,5.885453e-01,& - & 5.877209e-01,5.870003e-01,5.863611e-01,5.857811e-01,5.852381e-01,& - & 5.847098e-01,5.841738e-01,5.836081e-01,5.829901e-01,5.822979e-01,& - & 5.815089e-01,5.806011e-01,5.795521e-01,5.783396e-01,5.769413e-01,& - & 5.753351e-01,5.734986e-01,5.7141e-01 / - data ssadatliq1(:, 17) / & - & 8.165821e-01,8.002015e-01,7.816921e-01,7.634131e-01,7.463721e-01,& - & 7.312469e-01,7.185883e-01,7.088975e-01,7.026671e-01,7.004020e-01,& - & 7.042138e-01,6.960930e-01,6.894243e-01,6.840459e-01,6.797957e-01,& - & 6.765119e-01,6.740325e-01,6.721955e-01,6.708391e-01,6.698013e-01,& - & 6.689201e-01,6.680339e-01,6.669805e-01,6.655982e-01,6.637250e-01,& - & 6.611992e-01,6.578588e-01,6.535420e-01,6.584449e-01,6.553992e-01,& - & 6.526547e-01,6.501917e-01,6.479905e-01,6.460313e-01,6.442945e-01,& - & 6.427605e-01,6.414094e-01,6.402217e-01,6.391775e-01,6.382573e-01,& - & 6.374413e-01,6.367099e-01,6.360433e-01,6.354218e-01,6.348257e-01,& - & 6.342355e-01,6.336313e-01,6.329935e-01,6.323023e-01,6.315383e-01,& - & 6.306814e-01,6.297122e-01,6.286110e-01,6.273579e-01,6.259333e-01,& - & 6.243176e-01,6.224910e-01,6.2043e-01 / - data ssadatliq1(:, 18) / & - & 9.900163e-01,9.854307e-01,9.797730e-01,9.733113e-01,9.664245e-01,& - & 9.594976e-01,9.529055e-01,9.470112e-01,9.421695e-01,9.387304e-01,& - & 9.344918e-01,9.305302e-01,9.267048e-01,9.230072e-01,9.194289e-01,& - & 9.159616e-01,9.125968e-01,9.093260e-01,9.061409e-01,9.030330e-01,& - & 8.999940e-01,8.970154e-01,8.940888e-01,8.912058e-01,8.883579e-01,& - & 8.855368e-01,8.827341e-01,8.799413e-01,8.777423e-01,8.749566e-01,& - & 8.722298e-01,8.695605e-01,8.669469e-01,8.643875e-01,8.618806e-01,& - & 8.594246e-01,8.570179e-01,8.546589e-01,8.523459e-01,8.500773e-01,& - & 8.478516e-01,8.456670e-01,8.435219e-01,8.414148e-01,8.393439e-01,& - & 8.373078e-01,8.353047e-01,8.333330e-01,8.313911e-01,8.294774e-01,& - & 8.275904e-01,8.257282e-01,8.238893e-01,8.220721e-01,8.202751e-01,& - & 8.184965e-01,8.167346e-01,8.1499e-01 / - data ssadatliq1(:, 19) / & - & 9.999916e-01,9.987396e-01,9.966900e-01,9.950738e-01,9.937531e-01,& - & 9.925912e-01,9.914525e-01,9.902018e-01,9.887046e-01,9.868263e-01,& - & 9.849039e-01,9.832372e-01,9.815265e-01,9.797770e-01,9.779940e-01,& - & 9.761827e-01,9.743481e-01,9.724955e-01,9.706303e-01,9.687575e-01,& - & 9.668823e-01,9.650100e-01,9.631457e-01,9.612947e-01,9.594622e-01,& - & 9.576534e-01,9.558734e-01,9.541275e-01,9.522059e-01,9.504258e-01,& - & 9.486459e-01,9.468676e-01,9.450921e-01,9.433208e-01,9.415548e-01,& - & 9.397955e-01,9.380441e-01,9.363022e-01,9.345706e-01,9.328510e-01,& - & 9.311445e-01,9.294524e-01,9.277761e-01,9.261167e-01,9.244755e-01,& - & 9.228540e-01,9.212534e-01,9.196748e-01,9.181197e-01,9.165894e-01,& - & 9.150851e-01,9.136080e-01,9.121596e-01,9.107410e-01,9.093536e-01,& - & 9.079987e-01,9.066775e-01,9.0539e-01 / - data ssadatliq1(:, 20) / & - & 9.979493e-01,9.964113e-01,9.950014e-01,9.937045e-01,9.924964e-01,& - & 9.913546e-01,9.902575e-01,9.891843e-01,9.881136e-01,9.870238e-01,& - & 9.859934e-01,9.849372e-01,9.838873e-01,9.828434e-01,9.818052e-01,& - & 9.807725e-01,9.797450e-01,9.787225e-01,9.777047e-01,9.766914e-01,& - & 9.756823e-01,9.746771e-01,9.736756e-01,9.726775e-01,9.716827e-01,& - & 9.706907e-01,9.697014e-01,9.687145e-01,9.678060e-01,9.668108e-01,& - & 9.658218e-01,9.648391e-01,9.638629e-01,9.628936e-01,9.619313e-01,& - & 9.609763e-01,9.600287e-01,9.590888e-01,9.581569e-01,9.572330e-01,& - & 9.563176e-01,9.554108e-01,9.545128e-01,9.536239e-01,9.527443e-01,& - & 9.518741e-01,9.510137e-01,9.501633e-01,9.493230e-01,9.484931e-01,& - & 9.476740e-01,9.468656e-01,9.460683e-01,9.452824e-01,9.445080e-01,& - & 9.437454e-01,9.429948e-01,9.4226e-01 / - data ssadatliq1(:, 21) / & - & 9.988742e-01,9.982668e-01,9.976935e-01,9.971497e-01,9.966314e-01,& - & 9.961344e-01,9.956545e-01,9.951873e-01,9.947286e-01,9.942741e-01,& - & 9.938457e-01,9.933947e-01,9.929473e-01,9.925032e-01,9.920621e-01,& - & 9.916237e-01,9.911875e-01,9.907534e-01,9.903209e-01,9.898898e-01,& - & 9.894597e-01,9.890304e-01,9.886015e-01,9.881726e-01,9.877435e-01,& - & 9.873138e-01,9.868833e-01,9.864516e-01,9.860698e-01,9.856317e-01,& - & 9.851957e-01,9.847618e-01,9.843302e-01,9.839008e-01,9.834739e-01,& - & 9.830494e-01,9.826275e-01,9.822083e-01,9.817918e-01,9.813782e-01,& - & 9.809675e-01,9.805598e-01,9.801552e-01,9.797538e-01,9.793556e-01,& - & 9.789608e-01,9.785695e-01,9.781817e-01,9.777975e-01,9.774171e-01,& - & 9.770404e-01,9.766676e-01,9.762988e-01,9.759340e-01,9.755733e-01,& - & 9.752169e-01,9.748649e-01,9.7452e-01 / - data ssadatliq1(:, 22) / & - & 9.994441e-01,9.991608e-01,9.988949e-01,9.986439e-01,9.984054e-01,& - & 9.981768e-01,9.979557e-01,9.977396e-01,9.975258e-01,9.973120e-01,& - & 9.971011e-01,9.968852e-01,9.966708e-01,9.964578e-01,9.962462e-01,& - & 9.960357e-01,9.958264e-01,9.956181e-01,9.954108e-01,9.952043e-01,& - & 9.949987e-01,9.947937e-01,9.945892e-01,9.943853e-01,9.941818e-01,& - & 9.939786e-01,9.937757e-01,9.935728e-01,9.933922e-01,9.931825e-01,& - & 9.929739e-01,9.927661e-01,9.925592e-01,9.923534e-01,9.921485e-01,& - & 9.919447e-01,9.917421e-01,9.915406e-01,9.913403e-01,9.911412e-01,& - & 9.909435e-01,9.907470e-01,9.905519e-01,9.903581e-01,9.901659e-01,& - & 9.899751e-01,9.897858e-01,9.895981e-01,9.894120e-01,9.892276e-01,& - & 9.890447e-01,9.888637e-01,9.886845e-01,9.885070e-01,9.883314e-01,& - & 9.881576e-01,9.879859e-01,9.8782e-01 / - data ssadatliq1(:, 23) / & - & 9.999138e-01,9.998730e-01,9.998338e-01,9.997965e-01,9.997609e-01,& - & 9.997270e-01,9.996944e-01,9.996629e-01,9.996321e-01,9.996016e-01,& - & 9.995690e-01,9.995372e-01,9.995057e-01,9.994744e-01,9.994433e-01,& - & 9.994124e-01,9.993817e-01,9.993510e-01,9.993206e-01,9.992903e-01,& - & 9.992600e-01,9.992299e-01,9.991998e-01,9.991698e-01,9.991398e-01,& - & 9.991098e-01,9.990799e-01,9.990499e-01,9.990231e-01,9.989920e-01,& - & 9.989611e-01,9.989302e-01,9.988996e-01,9.988690e-01,9.988386e-01,& - & 9.988084e-01,9.987783e-01,9.987485e-01,9.987187e-01,9.986891e-01,& - & 9.986598e-01,9.986306e-01,9.986017e-01,9.985729e-01,9.985443e-01,& - & 9.985160e-01,9.984879e-01,9.984600e-01,9.984324e-01,9.984050e-01,& - & 9.983778e-01,9.983509e-01,9.983243e-01,9.982980e-01,9.982719e-01,& - & 9.982461e-01,9.982206e-01,9.9820e-01 / - data ssadatliq1(:, 24) / & - & 9.999985e-01,9.999979e-01,9.999972e-01,9.999966e-01,9.999961e-01,& - & 9.999955e-01,9.999950e-01,9.999944e-01,9.999938e-01,9.999933e-01,& - & 9.999927e-01,9.999921e-01,9.999915e-01,9.999910e-01,9.999904e-01,& - & 9.999899e-01,9.999893e-01,9.999888e-01,9.999882e-01,9.999877e-01,& - & 9.999871e-01,9.999866e-01,9.999861e-01,9.999855e-01,9.999850e-01,& - & 9.999844e-01,9.999839e-01,9.999833e-01,9.999828e-01,9.999823e-01,& - & 9.999817e-01,9.999812e-01,9.999807e-01,9.999801e-01,9.999796e-01,& - & 9.999791e-01,9.999786e-01,9.999781e-01,9.999776e-01,9.999770e-01,& - & 9.999765e-01,9.999761e-01,9.999756e-01,9.999751e-01,9.999746e-01,& - & 9.999741e-01,9.999736e-01,9.999732e-01,9.999727e-01,9.999722e-01,& - & 9.999718e-01,9.999713e-01,9.999709e-01,9.999705e-01,9.999701e-01,& - & 9.999697e-01,9.999692e-01,9.9997e-01 / - data ssadatliq1(:, 25) / & - & 9.999999e-01,9.999998e-01,9.999997e-01,9.999997e-01,9.999997e-01,& - & 9.999996e-01,9.999996e-01,9.999995e-01,9.999995e-01,9.999994e-01,& - & 9.999994e-01,9.999993e-01,9.999993e-01,9.999992e-01,9.999992e-01,& - & 9.999991e-01,9.999991e-01,9.999991e-01,9.999990e-01,9.999989e-01,& - & 9.999989e-01,9.999989e-01,9.999988e-01,9.999988e-01,9.999987e-01,& - & 9.999987e-01,9.999986e-01,9.999986e-01,9.999985e-01,9.999985e-01,& - & 9.999984e-01,9.999984e-01,9.999984e-01,9.999983e-01,9.999983e-01,& - & 9.999982e-01,9.999982e-01,9.999982e-01,9.999981e-01,9.999980e-01,& - & 9.999980e-01,9.999980e-01,9.999979e-01,9.999979e-01,9.999978e-01,& - & 9.999978e-01,9.999977e-01,9.999977e-01,9.999977e-01,9.999976e-01,& - & 9.999976e-01,9.999975e-01,9.999975e-01,9.999974e-01,9.999974e-01,& - & 9.999974e-01,9.999973e-01,1.0000e+00 / - data ssadatliq1(:, 26) / & - & 9.999997e-01,9.999995e-01,9.999993e-01,9.999992e-01,9.999990e-01,& - & 9.999989e-01,9.999988e-01,9.999987e-01,9.999986e-01,9.999985e-01,& - & 9.999984e-01,9.999983e-01,9.999982e-01,9.999981e-01,9.999980e-01,& - & 9.999978e-01,9.999977e-01,9.999976e-01,9.999975e-01,9.999974e-01,& - & 9.999973e-01,9.999972e-01,9.999970e-01,9.999969e-01,9.999968e-01,& - & 9.999967e-01,9.999966e-01,9.999965e-01,9.999964e-01,9.999963e-01,& - & 9.999962e-01,9.999961e-01,9.999959e-01,9.999958e-01,9.999957e-01,& - & 9.999956e-01,9.999955e-01,9.999954e-01,9.999953e-01,9.999952e-01,& - & 9.999951e-01,9.999949e-01,9.999949e-01,9.999947e-01,9.999946e-01,& - & 9.999945e-01,9.999944e-01,9.999943e-01,9.999942e-01,9.999941e-01,& - & 9.999940e-01,9.999939e-01,9.999938e-01,9.999937e-01,9.999936e-01,& - & 9.999935e-01,9.999934e-01,9.9999e-01 / - data ssadatliq1(:, 27) / & - & 9.999984e-01,9.999976e-01,9.999969e-01,9.999962e-01,9.999956e-01,& - & 9.999950e-01,9.999945e-01,9.999940e-01,9.999935e-01,9.999931e-01,& - & 9.999926e-01,9.999920e-01,9.999914e-01,9.999908e-01,9.999903e-01,& - & 9.999897e-01,9.999891e-01,9.999886e-01,9.999880e-01,9.999874e-01,& - & 9.999868e-01,9.999863e-01,9.999857e-01,9.999851e-01,9.999846e-01,& - & 9.999840e-01,9.999835e-01,9.999829e-01,9.999824e-01,9.999818e-01,& - & 9.999812e-01,9.999806e-01,9.999800e-01,9.999795e-01,9.999789e-01,& - & 9.999783e-01,9.999778e-01,9.999773e-01,9.999767e-01,9.999761e-01,& - & 9.999756e-01,9.999750e-01,9.999745e-01,9.999739e-01,9.999734e-01,& - & 9.999729e-01,9.999723e-01,9.999718e-01,9.999713e-01,9.999708e-01,& - & 9.999703e-01,9.999697e-01,9.999692e-01,9.999687e-01,9.999683e-01,& - & 9.999678e-01,9.999673e-01,9.9997e-01 / - data ssadatliq1(:, 28) / & - & 9.999981e-01,9.999973e-01,9.999965e-01,9.999958e-01,9.999951e-01,& - & 9.999943e-01,9.999937e-01,9.999930e-01,9.999924e-01,9.999918e-01,& - & 9.999912e-01,9.999905e-01,9.999897e-01,9.999890e-01,9.999883e-01,& - & 9.999876e-01,9.999869e-01,9.999862e-01,9.999855e-01,9.999847e-01,& - & 9.999840e-01,9.999834e-01,9.999827e-01,9.999819e-01,9.999812e-01,& - & 9.999805e-01,9.999799e-01,9.999791e-01,9.999785e-01,9.999778e-01,& - & 9.999771e-01,9.999764e-01,9.999757e-01,9.999750e-01,9.999743e-01,& - & 9.999736e-01,9.999729e-01,9.999722e-01,9.999715e-01,9.999709e-01,& - & 9.999701e-01,9.999695e-01,9.999688e-01,9.999682e-01,9.999675e-01,& - & 9.999669e-01,9.999662e-01,9.999655e-01,9.999649e-01,9.999642e-01,& - & 9.999636e-01,9.999630e-01,9.999624e-01,9.999618e-01,9.999612e-01,& - & 9.999606e-01,9.999600e-01,9.9996e-01 / - data ssadatliq1(:, 29) / & - & 8.505737e-01,8.465102e-01,8.394829e-01,8.279508e-01,8.110806e-01,& - & 7.900397e-01,7.669615e-01,7.444422e-01,7.253055e-01,7.124831e-01,& - & 7.016434e-01,6.885485e-01,6.767340e-01,6.661029e-01,6.565577e-01,& - & 6.480013e-01,6.403373e-01,6.334697e-01,6.273034e-01,6.217440e-01,& - & 6.166983e-01,6.120740e-01,6.077796e-01,6.037249e-01,5.998207e-01,& - & 5.959788e-01,5.921123e-01,5.881354e-01,5.891285e-01,5.851143e-01,& - & 5.814653e-01,5.781606e-01,5.751792e-01,5.724998e-01,5.701016e-01,& - & 5.679634e-01,5.660642e-01,5.643829e-01,5.628984e-01,5.615898e-01,& - & 5.604359e-01,5.594158e-01,5.585083e-01,5.576924e-01,5.569470e-01,& - & 5.562512e-01,5.555838e-01,5.549239e-01,5.542503e-01,5.535420e-01,& - & 5.527781e-01,5.519374e-01,5.509989e-01,5.499417e-01,5.487445e-01,& - & 5.473865e-01,5.458466e-01,5.4410e-01 / - - data asydatliq1(:, 16) / & - & 8.133297e-01,8.133528e-01,8.173865e-01,8.243205e-01,8.333063e-01,& - & 8.436317e-01,8.546611e-01,8.657934e-01,8.764345e-01,8.859837e-01,& - & 8.627394e-01,8.824569e-01,8.976887e-01,9.089541e-01,9.167699e-01,& - & 9.216517e-01,9.241147e-01,9.246743e-01,9.238469e-01,9.221504e-01,& - & 9.201045e-01,9.182299e-01,9.170491e-01,9.170862e-01,9.188653e-01,& - & 9.229111e-01,9.297468e-01,9.398950e-01,9.203269e-01,9.260693e-01,& - & 9.309373e-01,9.349918e-01,9.382935e-01,9.409030e-01,9.428809e-01,& - & 9.442881e-01,9.451851e-01,9.456331e-01,9.456926e-01,9.454247e-01,& - & 9.448902e-01,9.441503e-01,9.432661e-01,9.422987e-01,9.413094e-01,& - & 9.403594e-01,9.395102e-01,9.388230e-01,9.383594e-01,9.381810e-01,& - & 9.383489e-01,9.389251e-01,9.399707e-01,9.415475e-01,9.437167e-01,& - & 9.465399e-01,9.500786e-01,9.5439e-01 / - data asydatliq1(:, 17) / & - & 8.794448e-01,8.819306e-01,8.837667e-01,8.853832e-01,8.871010e-01,& - & 8.892675e-01,8.922584e-01,8.964666e-01,9.022940e-01,9.101456e-01,& - & 8.839999e-01,9.035610e-01,9.184568e-01,9.292315e-01,9.364282e-01,& - & 9.405887e-01,9.422554e-01,9.419703e-01,9.402759e-01,9.377159e-01,& - & 9.348345e-01,9.321769e-01,9.302888e-01,9.297166e-01,9.310075e-01,& - & 9.347080e-01,9.413643e-01,9.515216e-01,9.306286e-01,9.361781e-01,& - & 9.408374e-01,9.446692e-01,9.477363e-01,9.501013e-01,9.518268e-01,& - & 9.529756e-01,9.536105e-01,9.537938e-01,9.535886e-01,9.530574e-01,& - & 9.522633e-01,9.512688e-01,9.501370e-01,9.489306e-01,9.477126e-01,& - & 9.465459e-01,9.454934e-01,9.446183e-01,9.439833e-01,9.436519e-01,& - & 9.436866e-01,9.441508e-01,9.451073e-01,9.466195e-01,9.487501e-01,& - & 9.515621e-01,9.551185e-01,9.5948e-01 / - data asydatliq1(:, 18) / & - & 8.478817e-01,8.269312e-01,8.161352e-01,8.135960e-01,8.173586e-01,& - & 8.254167e-01,8.357072e-01,8.461167e-01,8.544952e-01,8.586776e-01,& - & 8.335562e-01,8.524273e-01,8.669052e-01,8.775014e-01,8.847277e-01,& - & 8.890958e-01,8.911173e-01,8.913038e-01,8.901669e-01,8.882182e-01,& - & 8.859692e-01,8.839315e-01,8.826164e-01,8.825356e-01,8.842004e-01,& - & 8.881223e-01,8.948131e-01,9.047837e-01,8.855951e-01,8.911796e-01,& - & 8.959229e-01,8.998837e-01,9.031209e-01,9.056939e-01,9.076609e-01,& - & 9.090812e-01,9.100134e-01,9.105167e-01,9.106496e-01,9.104712e-01,& - & 9.100404e-01,9.094159e-01,9.086568e-01,9.078218e-01,9.069697e-01,& - & 9.061595e-01,9.054499e-01,9.048999e-01,9.045683e-01,9.045142e-01,& - & 9.047962e-01,9.054730e-01,9.066037e-01,9.082472e-01,9.104623e-01,& - & 9.133079e-01,9.168427e-01,9.2113e-01 / - data asydatliq1(:, 19) / & - & 8.216697e-01,7.982871e-01,7.891147e-01,7.909083e-01,8.003833e-01,& - & 8.142516e-01,8.292290e-01,8.420356e-01,8.493945e-01,8.480316e-01,& - & 8.212381e-01,8.394984e-01,8.534095e-01,8.634813e-01,8.702242e-01,& - & 8.741483e-01,8.757638e-01,8.755808e-01,8.741095e-01,8.718604e-01,& - & 8.693433e-01,8.670686e-01,8.655464e-01,8.652872e-01,8.668006e-01,& - & 8.705973e-01,8.771874e-01,8.870809e-01,8.678284e-01,8.732315e-01,& - & 8.778084e-01,8.816166e-01,8.847146e-01,8.871603e-01,8.890116e-01,& - & 8.903266e-01,8.911632e-01,8.915796e-01,8.916337e-01,8.913834e-01,& - & 8.908869e-01,8.902022e-01,8.893873e-01,8.885001e-01,8.875986e-01,& - & 8.867411e-01,8.859852e-01,8.853891e-01,8.850111e-01,8.849089e-01,& - & 8.851405e-01,8.857639e-01,8.868372e-01,8.884185e-01,8.905656e-01,& - & 8.933368e-01,8.967899e-01,9.0098e-01 / - data asydatliq1(:, 20) / & - & 8.063610e-01,7.938147e-01,7.921304e-01,7.985092e-01,8.101339e-01,& - & 8.242175e-01,8.379913e-01,8.486920e-01,8.535547e-01,8.498083e-01,& - & 8.224849e-01,8.405509e-01,8.542436e-01,8.640770e-01,8.705653e-01,& - & 8.742227e-01,8.755630e-01,8.751004e-01,8.733491e-01,8.708231e-01,& - & 8.680365e-01,8.655035e-01,8.637381e-01,8.632544e-01,8.645665e-01,& - & 8.681885e-01,8.746346e-01,8.844188e-01,8.648180e-01,8.700563e-01,& - & 8.744672e-01,8.781087e-01,8.810393e-01,8.833174e-01,8.850011e-01,& - & 8.861485e-01,8.868183e-01,8.870687e-01,8.869579e-01,8.865441e-01,& - & 8.858857e-01,8.850412e-01,8.840686e-01,8.830263e-01,8.819726e-01,& - & 8.809658e-01,8.800642e-01,8.793260e-01,8.788099e-01,8.785737e-01,& - & 8.786758e-01,8.791746e-01,8.801283e-01,8.815955e-01,8.836340e-01,& - & 8.863024e-01,8.896592e-01,8.9376e-01 / - data asydatliq1(:, 21) / & - & 7.885899e-01,7.937172e-01,8.020658e-01,8.123971e-01,8.235502e-01,& - & 8.343776e-01,8.437336e-01,8.504711e-01,8.534421e-01,8.514978e-01,& - & 8.238888e-01,8.417463e-01,8.552057e-01,8.647853e-01,8.710038e-01,& - & 8.743798e-01,8.754319e-01,8.746786e-01,8.726386e-01,8.698303e-01,& - & 8.667724e-01,8.639836e-01,8.619823e-01,8.612870e-01,8.624165e-01,& - & 8.658893e-01,8.722241e-01,8.819394e-01,8.620216e-01,8.671239e-01,& - & 8.713983e-01,8.749032e-01,8.776970e-01,8.798385e-01,8.813860e-01,& - & 8.823980e-01,8.829332e-01,8.830500e-01,8.828068e-01,8.822623e-01,& - & 8.814750e-01,8.805031e-01,8.794056e-01,8.782407e-01,8.770672e-01,& - & 8.759432e-01,8.749275e-01,8.740784e-01,8.734547e-01,8.731146e-01,& - & 8.731170e-01,8.735199e-01,8.743823e-01,8.757625e-01,8.777191e-01,& - & 8.803105e-01,8.835953e-01,8.8763e-01 / - data asydatliq1(:, 22) / & - & 7.811516e-01,7.962229e-01,8.096199e-01,8.212996e-01,8.312212e-01,& - & 8.393430e-01,8.456236e-01,8.500214e-01,8.524950e-01,8.530031e-01,& - & 8.251485e-01,8.429043e-01,8.562461e-01,8.656954e-01,8.717737e-01,& - & 8.750020e-01,8.759022e-01,8.749953e-01,8.728027e-01,8.698461e-01,& - & 8.666466e-01,8.637257e-01,8.616047e-01,8.608051e-01,8.618483e-01,& - & 8.652557e-01,8.715487e-01,8.812485e-01,8.611645e-01,8.662052e-01,& - & 8.704173e-01,8.738594e-01,8.765901e-01,8.786678e-01,8.801517e-01,& - & 8.810999e-01,8.815713e-01,8.816246e-01,8.813185e-01,8.807114e-01,& - & 8.798621e-01,8.788290e-01,8.776713e-01,8.764470e-01,8.752152e-01,& - & 8.740343e-01,8.729631e-01,8.720602e-01,8.713842e-01,8.709936e-01,& - & 8.709475e-01,8.713041e-01,8.721221e-01,8.734602e-01,8.753774e-01,& - & 8.779319e-01,8.811825e-01,8.8519e-01 / - data asydatliq1(:, 23) / & - & 7.865744e-01,8.093340e-01,8.257596e-01,8.369940e-01,8.441574e-01,& - & 8.483602e-01,8.507096e-01,8.523139e-01,8.542834e-01,8.577321e-01,& - & 8.288960e-01,8.465308e-01,8.597175e-01,8.689830e-01,8.748542e-01,& - & 8.778584e-01,8.785222e-01,8.773728e-01,8.749370e-01,8.717419e-01,& - & 8.683145e-01,8.651816e-01,8.628704e-01,8.619077e-01,8.628205e-01,& - & 8.661356e-01,8.723803e-01,8.820815e-01,8.616715e-01,8.666389e-01,& - & 8.707753e-01,8.741398e-01,8.767912e-01,8.787885e-01,8.801908e-01,& - & 8.810570e-01,8.814460e-01,8.814167e-01,8.810283e-01,8.803395e-01,& - & 8.794095e-01,8.782971e-01,8.770613e-01,8.757610e-01,8.744553e-01,& - & 8.732031e-01,8.720634e-01,8.710951e-01,8.703572e-01,8.699086e-01,& - & 8.698084e-01,8.701155e-01,8.708887e-01,8.721872e-01,8.740698e-01,& - & 8.765957e-01,8.798235e-01,8.8381e-01 / - data asydatliq1(:, 24) / & - & 8.069513e-01,8.262939e-01,8.398241e-01,8.486352e-01,8.538213e-01,& - & 8.564743e-01,8.576854e-01,8.585455e-01,8.601452e-01,8.635755e-01,& - & 8.337383e-01,8.512655e-01,8.643049e-01,8.733896e-01,8.790535e-01,& - & 8.818295e-01,8.822518e-01,8.808533e-01,8.781676e-01,8.747284e-01,& - & 8.710690e-01,8.677229e-01,8.652236e-01,8.641047e-01,8.648993e-01,& - & 8.681413e-01,8.743640e-01,8.841007e-01,8.633558e-01,8.682719e-01,& - & 8.723543e-01,8.756621e-01,8.782547e-01,8.801915e-01,8.815318e-01,& - & 8.823347e-01,8.826598e-01,8.825663e-01,8.821135e-01,8.813608e-01,& - & 8.803674e-01,8.791928e-01,8.778960e-01,8.765366e-01,8.751738e-01,& - & 8.738670e-01,8.726755e-01,8.716585e-01,8.708755e-01,8.703856e-01,& - & 8.702483e-01,8.705229e-01,8.712687e-01,8.725448e-01,8.744109e-01,& - & 8.769260e-01,8.801496e-01,8.8414e-01 / - data asydatliq1(:, 25) / & - & 8.252182e-01,8.379244e-01,8.471709e-01,8.535760e-01,8.577540e-01,& - & 8.603183e-01,8.618820e-01,8.630578e-01,8.644587e-01,8.666970e-01,& - & 8.362159e-01,8.536817e-01,8.666387e-01,8.756240e-01,8.811746e-01,& - & 8.838273e-01,8.841191e-01,8.825871e-01,8.797681e-01,8.761992e-01,& - & 8.724174e-01,8.689593e-01,8.663623e-01,8.651632e-01,8.658988e-01,& - & 8.691064e-01,8.753226e-01,8.850847e-01,8.641620e-01,8.690500e-01,& - & 8.731026e-01,8.763795e-01,8.789400e-01,8.808438e-01,8.821503e-01,& - & 8.829191e-01,8.832095e-01,8.830813e-01,8.825938e-01,8.818064e-01,& - & 8.807787e-01,8.795704e-01,8.782408e-01,8.768493e-01,8.754557e-01,& - & 8.741193e-01,8.728995e-01,8.718561e-01,8.710484e-01,8.705360e-01,& - & 8.703782e-01,8.706347e-01,8.713650e-01,8.726285e-01,8.744849e-01,& - & 8.769933e-01,8.802136e-01,8.8421e-01 / - data asydatliq1(:, 26) / & - & 8.370583e-01,8.467920e-01,8.537769e-01,8.585136e-01,8.615034e-01,& - & 8.632474e-01,8.642468e-01,8.650026e-01,8.660161e-01,8.677882e-01,& - & 8.369760e-01,8.543821e-01,8.672699e-01,8.761782e-01,8.816454e-01,& - & 8.842103e-01,8.844114e-01,8.827872e-01,8.798766e-01,8.762179e-01,& - & 8.723500e-01,8.688112e-01,8.661403e-01,8.648758e-01,8.655563e-01,& - & 8.687206e-01,8.749072e-01,8.846546e-01,8.636289e-01,8.684849e-01,& - & 8.725054e-01,8.757501e-01,8.782785e-01,8.801503e-01,8.814249e-01,& - & 8.821620e-01,8.824211e-01,8.822620e-01,8.817440e-01,8.809268e-01,& - & 8.798699e-01,8.786330e-01,8.772756e-01,8.758572e-01,8.744374e-01,& - & 8.730760e-01,8.718323e-01,8.707660e-01,8.699366e-01,8.694039e-01,& - & 8.692271e-01,8.694661e-01,8.701803e-01,8.714293e-01,8.732727e-01,& - & 8.757702e-01,8.789811e-01,8.8297e-01 / - data asydatliq1(:, 27) / & - & 8.430819e-01,8.510060e-01,8.567270e-01,8.606533e-01,8.631934e-01,& - & 8.647554e-01,8.657471e-01,8.665760e-01,8.676496e-01,8.693754e-01,& - & 8.384298e-01,8.557913e-01,8.686214e-01,8.774605e-01,8.828495e-01,& - & 8.853287e-01,8.854393e-01,8.837215e-01,8.807161e-01,8.769639e-01,& - & 8.730053e-01,8.693812e-01,8.666321e-01,8.652988e-01,8.659219e-01,& - & 8.690419e-01,8.751999e-01,8.849360e-01,8.638013e-01,8.686371e-01,& - & 8.726369e-01,8.758605e-01,8.783674e-01,8.802176e-01,8.814705e-01,& - & 8.821859e-01,8.824234e-01,8.822429e-01,8.817038e-01,8.808658e-01,& - & 8.797887e-01,8.785323e-01,8.771560e-01,8.757196e-01,8.742828e-01,& - & 8.729052e-01,8.716467e-01,8.705666e-01,8.697250e-01,8.691812e-01,& - & 8.689950e-01,8.692264e-01,8.699346e-01,8.711795e-01,8.730209e-01,& - & 8.755181e-01,8.787312e-01,8.8272e-01 / - data asydatliq1(:, 28) / & - & 8.452284e-01,8.522700e-01,8.572973e-01,8.607031e-01,8.628802e-01,& - & 8.642215e-01,8.651198e-01,8.659679e-01,8.671588e-01,8.690853e-01,& - & 8.383803e-01,8.557485e-01,8.685851e-01,8.774303e-01,8.828245e-01,& - & 8.853077e-01,8.854207e-01,8.837034e-01,8.806962e-01,8.769398e-01,& - & 8.729740e-01,8.693393e-01,8.665761e-01,8.652247e-01,8.658253e-01,& - & 8.689182e-01,8.750438e-01,8.847424e-01,8.636140e-01,8.684449e-01,& - & 8.724400e-01,8.756589e-01,8.781613e-01,8.800072e-01,8.812559e-01,& - & 8.819671e-01,8.822007e-01,8.820165e-01,8.814737e-01,8.806322e-01,& - & 8.795518e-01,8.782923e-01,8.769129e-01,8.754737e-01,8.740342e-01,& - & 8.726542e-01,8.713934e-01,8.703111e-01,8.694677e-01,8.689222e-01,& - & 8.687344e-01,8.689646e-01,8.696715e-01,8.709156e-01,8.727563e-01,& - & 8.752531e-01,8.784659e-01,8.8245e-01 / - data asydatliq1(:, 29) / & - & 7.800869e-01,8.091120e-01,8.325369e-01,8.466266e-01,8.515495e-01,& - & 8.499371e-01,8.456203e-01,8.430521e-01,8.470286e-01,8.625431e-01,& - & 8.402261e-01,8.610822e-01,8.776608e-01,8.904485e-01,8.999294e-01,& - & 9.065860e-01,9.108995e-01,9.133503e-01,9.144187e-01,9.145855e-01,& - & 9.143320e-01,9.141402e-01,9.144933e-01,9.158754e-01,9.187716e-01,& - & 9.236677e-01,9.310503e-01,9.414058e-01,9.239108e-01,9.300719e-01,& - & 9.353612e-01,9.398378e-01,9.435609e-01,9.465895e-01,9.489829e-01,& - & 9.508000e-01,9.521002e-01,9.529424e-01,9.533860e-01,9.534902e-01,& - & 9.533143e-01,9.529177e-01,9.523596e-01,9.516997e-01,9.509973e-01,& - & 9.503121e-01,9.497037e-01,9.492317e-01,9.489558e-01,9.489356e-01,& - & 9.492311e-01,9.499019e-01,9.510077e-01,9.526084e-01,9.547636e-01,& - & 9.575331e-01,9.609766e-01,9.6515e-01 / - -! extinction units: (m^2/g) fu, 1996 for ice clouds - - data extdatice3(:, 16) / & - & 2.563732e-01,1.701725e-01,1.273487e-01,1.017429e-01,8.470932e-02,& - & 7.256055e-02,6.345888e-02,5.638569e-02,5.073084e-02,4.610661e-02,& - & 4.225479e-02,3.899676e-02,3.620506e-02,3.378624e-02,3.167029e-02,& - & 2.980368e-02,2.814478e-02,2.666075e-02,2.532534e-02,2.411728e-02,& - & 2.301918e-02,2.201669e-02,2.109785e-02,2.025260e-02,1.947244e-02,& - & 1.875014e-02,1.807949e-02 / - data extdatice3(:, 17) / & - & 2.453326e-01,1.637386e-01,1.229416e-01,9.846334e-02,8.214455e-02,& - & 7.048825e-02,6.174604e-02,5.494654e-02,4.950693e-02,4.505635e-02,& - & 4.134754e-02,3.820930e-02,3.551939e-02,3.318813e-02,3.114828e-02,& - & 2.934841e-02,2.774853e-02,2.631706e-02,2.502873e-02,2.386310e-02,& - & 2.280344e-02,2.183592e-02,2.094903e-02,2.013309e-02,1.937991e-02,& - & 1.868253e-02,1.803496e-02 / - data extdatice3(:, 18) / & - & 2.528265e-01,1.685595e-01,1.264261e-01,1.011460e-01,8.429261e-02,& - & 7.225447e-02,6.322587e-02,5.620363e-02,5.058583e-02,4.598945e-02,& - & 4.215914e-02,3.891810e-02,3.614007e-02,3.373245e-02,3.162577e-02,& - & 2.976695e-02,2.811465e-02,2.663629e-02,2.530576e-02,2.410194e-02,& - & 2.300757e-02,2.200835e-02,2.109241e-02,2.024974e-02,1.947189e-02,& - & 1.875166e-02,1.808288e-02 / - data extdatice3(:, 19) / & - & 2.446454e-01,1.634733e-01,1.228872e-01,9.853560e-02,8.230118e-02,& - & 7.070516e-02,6.200814e-02,5.524380e-02,4.983232e-02,4.540475e-02,& - & 4.171511e-02,3.859311e-02,3.591710e-02,3.359790e-02,3.156859e-02,& - & 2.977803e-02,2.818642e-02,2.676235e-02,2.548068e-02,2.432108e-02,& - & 2.326690e-02,2.230438e-02,2.142208e-02,2.061036e-02,1.986108e-02,& - & 1.916730e-02,1.852307e-02 / - data extdatice3(:, 20) / & - & 2.549633e-01,1.698270e-01,1.272589e-01,1.017180e-01,8.469071e-02,& - & 7.252838e-02,6.340664e-02,5.631195e-02,5.063619e-02,4.599239e-02,& - & 4.212257e-02,3.884809e-02,3.604140e-02,3.360894e-02,3.148053e-02,& - & 2.960252e-02,2.793318e-02,2.643956e-02,2.509530e-02,2.387907e-02,& - & 2.277341e-02,2.176388e-02,2.083849e-02,1.998713e-02,1.920126e-02,& - & 1.847359e-02,1.779791e-02 / - data extdatice3(:, 21) / & - & 2.515626e-01,1.677115e-01,1.257860e-01,1.006306e-01,8.386041e-02,& - & 7.188168e-02,6.289763e-02,5.591004e-02,5.031996e-02,4.574626e-02,& - & 4.193485e-02,3.870981e-02,3.594549e-02,3.354974e-02,3.145346e-02,& - & 2.960381e-02,2.795967e-02,2.648860e-02,2.516463e-02,2.396676e-02,& - & 2.287778e-02,2.188350e-02,2.097207e-02,2.013356e-02,1.935955e-02,& - & 1.864288e-02,1.797739e-02 / - data extdatice3(:, 22) / & - & 2.478082e-01,1.654286e-01,1.242388e-01,9.952488e-02,8.304896e-02,& - & 7.128044e-02,6.245405e-02,5.558908e-02,5.009710e-02,4.560366e-02,& - & 4.185914e-02,3.869069e-02,3.597488e-02,3.362117e-02,3.156168e-02,& - & 2.974448e-02,2.812920e-02,2.668394e-02,2.538321e-02,2.420636e-02,& - & 2.313649e-02,2.215966e-02,2.126423e-02,2.044043e-02,1.968000e-02,& - & 1.897590e-02,1.832210e-02 / - data extdatice3(:, 23) / & - & 2.525944e-01,1.683656e-01,1.262512e-01,1.009826e-01,8.413686e-02,& - & 7.210417e-02,6.307966e-02,5.606059e-02,5.044534e-02,4.585104e-02,& - & 4.202246e-02,3.878289e-02,3.600612e-02,3.359958e-02,3.149386e-02,& - & 2.963587e-02,2.798433e-02,2.650663e-02,2.517670e-02,2.397344e-02,& - & 2.287955e-02,2.188079e-02,2.096526e-02,2.012298e-02,1.934548e-02,& - & 1.862557e-02,1.795709e-02 / - data extdatice3(:, 24) / & - & 2.520891e-01,1.680508e-01,1.260317e-01,1.008202e-01,8.401254e-02,& - & 7.200707e-02,6.300297e-02,5.599978e-02,5.039723e-02,4.581332e-02,& - & 4.199340e-02,3.876116e-02,3.599067e-02,3.358957e-02,3.148862e-02,& - & 2.963483e-02,2.798702e-02,2.651267e-02,2.518574e-02,2.398520e-02,& - & 2.289379e-02,2.189729e-02,2.098383e-02,2.014345e-02,1.936771e-02,& - & 1.864943e-02,1.798247e-02 / - data extdatice3(:, 25) / & - & 2.511494e-01,1.674488e-01,1.255985e-01,1.004884e-01,8.374825e-02,& - & 7.179103e-02,6.282311e-02,5.584806e-02,5.026802e-02,4.570253e-02,& - & 4.189797e-02,3.867871e-02,3.591935e-02,3.352791e-02,3.143539e-02,& - & 2.958906e-02,2.794787e-02,2.647944e-02,2.515785e-02,2.396213e-02,& - & 2.287511e-02,2.188261e-02,2.097282e-02,2.013582e-02,1.936319e-02,& - & 1.864780e-02,1.798351e-02 / - data extdatice3(:, 26) / & - & 2.533059e-01,1.687970e-01,1.265425e-01,1.011899e-01,8.428811e-02,& - & 7.221541e-02,6.316088e-02,5.611848e-02,5.048455e-02,4.587497e-02,& - & 4.203367e-02,3.878332e-02,3.599731e-02,3.358278e-02,3.147005e-02,& - & 2.960589e-02,2.794885e-02,2.646624e-02,2.513189e-02,2.392462e-02,& - & 2.282710e-02,2.182502e-02,2.090645e-02,2.006136e-02,1.928127e-02,& - & 1.855897e-02,1.788827e-02 / - data extdatice3(:, 27) / & - & 2.537632e-01,1.690928e-01,1.267575e-01,1.013564e-01,8.442228e-02,& - & 7.232650e-02,6.325466e-02,5.619879e-02,5.055409e-02,4.593570e-02,& - & 4.208704e-02,3.883048e-02,3.603915e-02,3.361999e-02,3.150323e-02,& - & 2.963550e-02,2.797530e-02,2.648985e-02,2.515294e-02,2.394337e-02,& - & 2.284375e-02,2.183975e-02,2.091942e-02,2.007272e-02,1.929114e-02,& - & 1.856746e-02,1.789548e-02 / - data extdatice3(:, 28) / & - & 2.530253e-01,1.686373e-01,1.264434e-01,1.011270e-01,8.424942e-02,& - & 7.219400e-02,6.315244e-02,5.612011e-02,5.049424e-02,4.589126e-02,& - & 4.205545e-02,3.880977e-02,3.602774e-02,3.361666e-02,3.150696e-02,& - & 2.964547e-02,2.799080e-02,2.651031e-02,2.517787e-02,2.397233e-02,& - & 2.287638e-02,2.187573e-02,2.095847e-02,2.011459e-02,1.933563e-02,& - & 1.861436e-02,1.794462e-02 / - data extdatice3(:, 29) / & - & 2.618508e-01,1.788886e-01,1.354123e-01,1.086880e-01,9.060575e-02,& - & 7.755947e-02,6.770343e-02,5.999534e-02,5.380220e-02,4.871746e-02,& - & 4.446803e-02,4.086373e-02,3.776802e-02,3.508036e-02,3.272505e-02,& - & 3.064405e-02,2.879205e-02,2.713324e-02,2.563888e-02,2.428567e-02,& - & 2.305450e-02,2.192958e-02,2.089773e-02,1.994784e-02,1.907052e-02,& - & 1.825775e-02,1.750268e-02 / - - data ssadatice3(:, 16) / & - & 6.614739e-01,6.483807e-01,6.369927e-01,6.269440e-01,6.180633e-01,& - & 6.102356e-01,6.033669e-01,5.973729e-01,5.921741e-01,5.876935e-01,& - & 5.838558e-01,5.805866e-01,5.778125e-01,5.754603e-01,5.734574e-01,& - & 5.717311e-01,5.702095e-01,5.688205e-01,5.674924e-01,5.661535e-01,& - & 5.647325e-01,5.631579e-01,5.613587e-01,5.592638e-01,5.568023e-01,& - & 5.539034e-01,5.504963e-01 / - data ssadatice3(:, 17) / & - & 7.527420e-01,7.433371e-01,7.345510e-01,7.263483e-01,7.186942e-01,& - & 7.115540e-01,7.048938e-01,6.986796e-01,6.928780e-01,6.874560e-01,& - & 6.823810e-01,6.776205e-01,6.731426e-01,6.689157e-01,6.649085e-01,& - & 6.610902e-01,6.574302e-01,6.538982e-01,6.504646e-01,6.470997e-01,& - & 6.437745e-01,6.404600e-01,6.371279e-01,6.337500e-01,6.302985e-01,& - & 6.267460e-01,6.230654e-01 / - data ssadatice3(:, 18) / & - & 9.855161e-01,9.789038e-01,9.725018e-01,9.663007e-01,9.602909e-01,& - & 9.544630e-01,9.488074e-01,9.433148e-01,9.379758e-01,9.327811e-01,& - & 9.277214e-01,9.227874e-01,9.179698e-01,9.132595e-01,9.086472e-01,& - & 9.041239e-01,8.996803e-01,8.953075e-01,8.909963e-01,8.867378e-01,& - & 8.825229e-01,8.783428e-01,8.741885e-01,8.700510e-01,8.659216e-01,& - & 8.617915e-01,8.576518e-01 / - data ssadatice3(:, 19) / & - & 9.444191e-01,9.271265e-01,9.109299e-01,8.957711e-01,8.815921e-01,& - & 8.683354e-01,8.559433e-01,8.443584e-01,8.335237e-01,8.233820e-01,& - & 8.138765e-01,8.049506e-01,7.965478e-01,7.886118e-01,7.810865e-01,& - & 7.739158e-01,7.670439e-01,7.604152e-01,7.539741e-01,7.476654e-01,& - & 7.414338e-01,7.352244e-01,7.289822e-01,7.226525e-01,7.161809e-01,& - & 7.095127e-01,7.025938e-01 / - data ssadatice3(:, 20) / & - & 9.886944e-01,9.834023e-01,9.782717e-01,9.732952e-01,9.684653e-01,& - & 9.637745e-01,9.592152e-01,9.547801e-01,9.504614e-01,9.462518e-01,& - & 9.421437e-01,9.381295e-01,9.342018e-01,9.303529e-01,9.265752e-01,& - & 9.228612e-01,9.192034e-01,9.155941e-01,9.120258e-01,9.084907e-01,& - & 9.049814e-01,9.014902e-01,8.980095e-01,8.945315e-01,8.910487e-01,& - & 8.875535e-01,8.840381e-01 / - data ssadatice3(:, 21) / & - & 9.876194e-01,9.821439e-01,9.768954e-01,9.718630e-01,9.670357e-01,& - & 9.624027e-01,9.579531e-01,9.536760e-01,9.495606e-01,9.455962e-01,& - & 9.417719e-01,9.380770e-01,9.345008e-01,9.310327e-01,9.276618e-01,& - & 9.243777e-01,9.211696e-01,9.180271e-01,9.149395e-01,9.118963e-01,& - & 9.088869e-01,9.059010e-01,9.029280e-01,8.999575e-01,8.969792e-01,& - & 8.939825e-01,8.909572e-01 / - data ssadatice3(:, 22) / & - & 9.989798e-01,9.985267e-01,9.980703e-01,9.976107e-01,9.971482e-01,& - & 9.966831e-01,9.962156e-01,9.957460e-01,9.952744e-01,9.948012e-01,& - & 9.943265e-01,9.938506e-01,9.933737e-01,9.928962e-01,9.924181e-01,& - & 9.919398e-01,9.914614e-01,9.909833e-01,9.905057e-01,9.900287e-01,& - & 9.895527e-01,9.890778e-01,9.886043e-01,9.881325e-01,9.876625e-01,& - & 9.871946e-01,9.867290e-01 / - data ssadatice3(:, 23) / & - & 9.998201e-01,9.997602e-01,9.996967e-01,9.996297e-01,9.995595e-01,& - & 9.994863e-01,9.994104e-01,9.993318e-01,9.992510e-01,9.991680e-01,& - & 9.990831e-01,9.989965e-01,9.989084e-01,9.988191e-01,9.987287e-01,& - & 9.986376e-01,9.985458e-01,9.984536e-01,9.983613e-01,9.982690e-01,& - & 9.981770e-01,9.980855e-01,9.979948e-01,9.979049e-01,9.978162e-01,& - & 9.977288e-01,9.976431e-01 / - data ssadatice3(:, 24) / & - & 9.999569e-01,9.999686e-01,9.999760e-01,9.999794e-01,9.999785e-01,& - & 9.999744e-01,9.999676e-01,9.999580e-01,9.999459e-01,9.999317e-01,& - & 9.999147e-01,9.998956e-01,9.998749e-01,9.998527e-01,9.998292e-01,& - & 9.998048e-01,9.997797e-01,9.997541e-01,9.997283e-01,9.997026e-01,& - & 9.996771e-01,9.996521e-01,9.996279e-01,9.996047e-01,9.995827e-01,& - & 9.995623e-01,9.995437e-01 / - data ssadatice3(:, 25) / & - & 9.999633e-01,9.999685e-01,9.999708e-01,9.999703e-01,9.999670e-01,& - & 9.999612e-01,9.999531e-01,9.999428e-01,9.999306e-01,9.999164e-01,& - & 9.999006e-01,9.998832e-01,9.998645e-01,9.998447e-01,9.998238e-01,& - & 9.998020e-01,9.997796e-01,9.997567e-01,9.997333e-01,9.997098e-01,& - & 9.996864e-01,9.996630e-01,9.996400e-01,9.996174e-01,9.995955e-01,& - & 9.995744e-01,9.995542e-01 / - data ssadatice3(:, 26) / & - & 9.999565e-01,9.999688e-01,9.999766e-01,9.999771e-01,9.999748e-01,& - & 9.999709e-01,9.999655e-01,9.999586e-01,9.999483e-01,9.999341e-01,& - & 9.999168e-01,9.998974e-01,9.998763e-01,9.998536e-01,9.998297e-01,& - & 9.998047e-01,9.997789e-01,9.997526e-01,9.997261e-01,9.996995e-01,& - & 9.996732e-01,9.996473e-01,9.996222e-01,9.995980e-01,9.995751e-01,& - & 9.995537e-01,9.995340e-01 / - data ssadatice3(:, 27) / & - & 9.999505e-01,9.999586e-01,9.999633e-01,9.999650e-01,9.999638e-01,& - & 9.999597e-01,9.999530e-01,9.999438e-01,9.999329e-01,9.999202e-01,& - & 9.999059e-01,9.998902e-01,9.998734e-01,9.998557e-01,9.998373e-01,& - & 9.998185e-01,9.997996e-01,9.997806e-01,9.997618e-01,9.997436e-01,& - & 9.997260e-01,9.997093e-01,9.996938e-01,9.996798e-01,9.996673e-01,& - & 9.996566e-01,9.996480e-01 / - data ssadatice3(:, 28) / & - & 9.999458e-01,9.999492e-01,9.999489e-01,9.999451e-01,9.999379e-01,& - & 9.999277e-01,9.999145e-01,9.998988e-01,9.998806e-01,9.998601e-01,& - & 9.998377e-01,9.998136e-01,9.997878e-01,9.997608e-01,9.997325e-01,& - & 9.997035e-01,9.996737e-01,9.996435e-01,9.996130e-01,9.995825e-01,& - & 9.995523e-01,9.995225e-01,9.994933e-01,9.994650e-01,9.994376e-01,& - & 9.994118e-01,9.993873e-01 / - data ssadatice3(:, 29) / & - & 7.034058e-01,6.807911e-01,6.623049e-01,6.464293e-01,6.326115e-01,& - & 6.205580e-01,6.100685e-01,6.009834e-01,5.931630e-01,5.864781e-01,& - & 5.808055e-01,5.760258e-01,5.720213e-01,5.686763e-01,5.658754e-01,& - & 5.635039e-01,5.614473e-01,5.595913e-01,5.578216e-01,5.560238e-01,& - & 5.540833e-01,5.518854e-01,5.493154e-01,5.462580e-01,5.425983e-01,& - & 5.382207e-01,5.330097e-01 / - - data asydatice3(:, 16) / & - & 8.488033e-01,8.613170e-01,8.721361e-01,8.815418e-01,8.897017e-01,& - & 8.967471e-01,9.027922e-01,9.079405e-01,9.122881e-01,9.159248e-01,& - & 9.189350e-01,9.213990e-01,9.233930e-01,9.249901e-01,9.262608e-01,& - & 9.272732e-01,9.280937e-01,9.287872e-01,9.294177e-01,9.300478e-01,& - & 9.307395e-01,9.315537e-01,9.325505e-01,9.337885e-01,9.353250e-01,& - & 9.372154e-01,9.395120e-01 / - data asydatice3(:, 17) / & - & 8.808303e-01,8.881341e-01,8.947419e-01,9.007029e-01,9.060643e-01,& - & 9.108720e-01,9.151705e-01,9.190027e-01,9.224104e-01,9.254344e-01,& - & 9.281141e-01,9.304885e-01,9.325953e-01,9.344720e-01,9.361551e-01,& - & 9.376809e-01,9.390850e-01,9.404028e-01,9.416693e-01,9.429191e-01,& - & 9.441865e-01,9.455053e-01,9.469090e-01,9.484304e-01,9.501016e-01,& - & 9.519542e-01,9.540185e-01 / - data asydatice3(:, 18) / & - & 7.981480e-01,8.060835e-01,8.135456e-01,8.205556e-01,8.271346e-01,& - & 8.333034e-01,8.390829e-01,8.444939e-01,8.495571e-01,8.542928e-01,& - & 8.587217e-01,8.628641e-01,8.667404e-01,8.703707e-01,8.737754e-01,& - & 8.769744e-01,8.799879e-01,8.828359e-01,8.855384e-01,8.881152e-01,& - & 8.905862e-01,8.929713e-01,8.952901e-01,8.975624e-01,8.998079e-01,& - & 9.020461e-01,9.042965e-01 / - data asydatice3(:, 19) / & - & 7.935781e-01,8.050413e-01,8.156627e-01,8.254873e-01,8.345593e-01,& - & 8.429222e-01,8.506192e-01,8.576925e-01,8.641841e-01,8.701354e-01,& - & 8.755874e-01,8.805806e-01,8.851553e-01,8.893512e-01,8.932080e-01,& - & 8.967650e-01,9.000615e-01,9.031364e-01,9.060286e-01,9.087768e-01,& - & 9.114197e-01,9.139957e-01,9.165431e-01,9.191001e-01,9.217047e-01,& - & 9.243945e-01,9.272070e-01 / - data asydatice3(:, 20) / & - & 7.723568e-01,7.802421e-01,7.877098e-01,7.947768e-01,8.014596e-01,& - & 8.077747e-01,8.137384e-01,8.193669e-01,8.246762e-01,8.296826e-01,& - & 8.344017e-01,8.388496e-01,8.430419e-01,8.469944e-01,8.507228e-01,& - & 8.542426e-01,8.575696e-01,8.607191e-01,8.637068e-01,8.665482e-01,& - & 8.692586e-01,8.718537e-01,8.743486e-01,8.767590e-01,8.791000e-01,& - & 8.813872e-01,8.836358e-01 / - data asydatice3(:, 21) / & - & 7.683102e-01,7.759729e-01,7.832317e-01,7.901034e-01,7.966041e-01,& - & 8.027500e-01,8.085565e-01,8.140390e-01,8.192125e-01,8.240917e-01,& - & 8.286911e-01,8.330249e-01,8.371073e-01,8.409520e-01,8.445726e-01,& - & 8.479828e-01,8.511958e-01,8.542248e-01,8.570828e-01,8.597828e-01,& - & 8.623376e-01,8.647598e-01,8.670620e-01,8.692565e-01,8.713557e-01,& - & 8.733717e-01,8.753163e-01 / - data asydatice3(:, 22) / & - & 7.631448e-01,7.691736e-01,7.749416e-01,7.804555e-01,7.857220e-01,& - & 7.907475e-01,7.955388e-01,8.001025e-01,8.044452e-01,8.085734e-01,& - & 8.124940e-01,8.162134e-01,8.197384e-01,8.230754e-01,8.262313e-01,& - & 8.292126e-01,8.320260e-01,8.346781e-01,8.371755e-01,8.395249e-01,& - & 8.417330e-01,8.438063e-01,8.457516e-01,8.475755e-01,8.492847e-01,& - & 8.508856e-01,8.523852e-01 / - data asydatice3(:, 23) / & - & 7.627573e-01,7.678960e-01,7.728852e-01,7.777239e-01,7.824110e-01,& - & 7.869455e-01,7.913264e-01,7.955527e-01,7.996234e-01,8.035375e-01,& - & 8.072939e-01,8.108917e-01,8.143300e-01,8.176077e-01,8.207238e-01,& - & 8.236775e-01,8.264677e-01,8.290934e-01,8.315538e-01,8.338479e-01,& - & 8.359747e-01,8.379334e-01,8.397230e-01,8.413424e-01,8.427910e-01,& - & 8.440677e-01,8.451717e-01 / - data asydatice3(:, 24) / & - & 7.616914e-01,7.664414e-01,7.710929e-01,7.756413e-01,7.800823e-01,& - & 7.844113e-01,7.886240e-01,7.927159e-01,7.966825e-01,8.005195e-01,& - & 8.042225e-01,8.077870e-01,8.112088e-01,8.144835e-01,8.176067e-01,& - & 8.205741e-01,8.233813e-01,8.260242e-01,8.284983e-01,8.307994e-01,& - & 8.329232e-01,8.348655e-01,8.366220e-01,8.381884e-01,8.395607e-01,& - & 8.407345e-01,8.417056e-01 / - data asydatice3(:, 25) / & - & 7.593013e-01,7.637291e-01,7.681050e-01,7.724211e-01,7.766700e-01,& - & 7.808441e-01,7.849356e-01,7.889371e-01,7.928409e-01,7.966394e-01,& - & 8.003250e-01,8.038901e-01,8.073271e-01,8.106284e-01,8.137865e-01,& - & 8.167936e-01,8.196424e-01,8.223250e-01,8.248340e-01,8.271618e-01,& - & 8.293008e-01,8.312433e-01,8.329819e-01,8.345089e-01,8.358169e-01,& - & 8.368980e-01,8.377449e-01 / - data asydatice3(:, 26) / & - & 7.535941e-01,7.580057e-01,7.623743e-01,7.666918e-01,7.709498e-01,& - & 7.751400e-01,7.792543e-01,7.832844e-01,7.872221e-01,7.910589e-01,& - & 7.947868e-01,7.983976e-01,8.018829e-01,8.052344e-01,8.084440e-01,& - & 8.115033e-01,8.144042e-01,8.171384e-01,8.196977e-01,8.220737e-01,& - & 8.242583e-01,8.262432e-01,8.280201e-01,8.295807e-01,8.309170e-01,& - & 8.320205e-01,8.328832e-01 / - data asydatice3(:, 27) / & - & 7.441883e-01,7.486528e-01,7.530774e-01,7.574534e-01,7.617724e-01,& - & 7.660258e-01,7.702051e-01,7.743019e-01,7.783075e-01,7.822136e-01,& - & 7.860114e-01,7.896927e-01,7.932487e-01,7.966711e-01,7.999513e-01,& - & 8.030807e-01,8.060510e-01,8.088534e-01,8.114796e-01,8.139210e-01,& - & 8.161692e-01,8.182155e-01,8.200515e-01,8.216686e-01,8.230584e-01,& - & 8.242124e-01,8.251218e-01 / - data asydatice3(:, 28) / & - & 7.265506e-01,7.310442e-01,7.354950e-01,7.398947e-01,7.442354e-01,& - & 7.485089e-01,7.527070e-01,7.568217e-01,7.608449e-01,7.647685e-01,& - & 7.685845e-01,7.722845e-01,7.758606e-01,7.793048e-01,7.826088e-01,& - & 7.857647e-01,7.887641e-01,7.915992e-01,7.942617e-01,7.967436e-01,& - & 7.990368e-01,8.011332e-01,8.030245e-01,8.047030e-01,8.061602e-01,& - & 8.073882e-01,8.083789e-01 / - data asydatice3(:, 29) / & - & 8.563368e-01,8.697433e-01,8.810506e-01,8.909536e-01,8.997129e-01,& - & 9.074712e-01,9.143289e-01,9.203677e-01,9.256608e-01,9.302763e-01,& - & 9.342801e-01,9.377364e-01,9.407087e-01,9.432600e-01,9.454530e-01,& - & 9.473501e-01,9.490142e-01,9.505079e-01,9.518937e-01,9.532349e-01,& - & 9.545945e-01,9.560359e-01,9.576229e-01,9.594196e-01,9.614902e-01,& - & 9.638999e-01,9.667138e-01 / - - data fdldatice3(:, 16) / & - & 4.510171e-02,4.102237e-02,3.732226e-02,3.397908e-02,3.097054e-02,& - & 2.827432e-02,2.586814e-02,2.372969e-02,2.183858e-02,2.017264e-02,& - & 1.870635e-02,1.741623e-02,1.628031e-02,1.527691e-02,1.438482e-02,& - & 1.358457e-02,1.285225e-02,1.216467e-02,1.149953e-02,1.083453e-02,& - & 1.014737e-02,9.415757e-03,8.617384e-03,7.733813e-03,6.791928e-03,& - & 5.835403e-03,4.880892e-03 / - data fdldatice3(:, 17) / & - & 4.955120e-02,4.852068e-02,4.760659e-02,4.679981e-02,4.609121e-02,& - & 4.547167e-02,4.493207e-02,4.446344e-02,4.405662e-02,4.370240e-02,& - & 4.339154e-02,4.311485e-02,4.286317e-02,4.262743e-02,4.239867e-02,& - & 4.216783e-02,4.192582e-02,4.166348e-02,4.137161e-02,4.104109e-02,& - & 4.066280e-02,4.022761e-02,3.972640e-02,3.915047e-02,3.849769e-02,& - & 3.777734e-02,3.703972e-02 / - data fdldatice3(:, 18) / & - & 1.066871e-01,1.071644e-01,1.077095e-01,1.083133e-01,1.089666e-01,& - & 1.096603e-01,1.103854e-01,1.111326e-01,1.118929e-01,1.126572e-01,& - & 1.134163e-01,1.141611e-01,1.148826e-01,1.155716e-01,1.162189e-01,& - & 1.168155e-01,1.173523e-01,1.178201e-01,1.182099e-01,1.185124e-01,& - & 1.187187e-01,1.188195e-01,1.188058e-01,1.186685e-01,1.183984e-01,& - & 1.179864e-01,1.174234e-01 / - data fdldatice3(:, 19) / & - & 1.058067e-01,1.041376e-01,1.025908e-01,1.011547e-01,9.981785e-02,& - & 9.856866e-02,9.739560e-02,9.628714e-02,9.523174e-02,9.421785e-02,& - & 9.323394e-02,9.226847e-02,9.130990e-02,9.034670e-02,8.936731e-02,& - & 8.836021e-02,8.731386e-02,8.621672e-02,8.505724e-02,8.382389e-02,& - & 8.250513e-02,8.108943e-02,7.956524e-02,7.792102e-02,7.614523e-02,& - & 7.422635e-02,7.215282e-02 / - data fdldatice3(:, 20) / & - & 1.125282e-01,1.132384e-01,1.140166e-01,1.148535e-01,1.157399e-01,& - & 1.166665e-01,1.176241e-01,1.186035e-01,1.195954e-01,1.205906e-01,& - & 1.215799e-01,1.225540e-01,1.235037e-01,1.244197e-01,1.252929e-01,& - & 1.261139e-01,1.268735e-01,1.275626e-01,1.281718e-01,1.286920e-01,& - & 1.291139e-01,1.294282e-01,1.296258e-01,1.296973e-01,1.296336e-01,& - & 1.294254e-01,1.290634e-01 / - data fdldatice3(:, 21) / & - & 1.139211e-01,1.145985e-01,1.153456e-01,1.161530e-01,1.170112e-01,& - & 1.179108e-01,1.188423e-01,1.197964e-01,1.207635e-01,1.217342e-01,& - & 1.226990e-01,1.236486e-01,1.245734e-01,1.254641e-01,1.263111e-01,& - & 1.271050e-01,1.278365e-01,1.284960e-01,1.290740e-01,1.295613e-01,& - & 1.299482e-01,1.302254e-01,1.303834e-01,1.304128e-01,1.303041e-01,& - & 1.300479e-01,1.296347e-01 / - data fdldatice3(:, 22) / & - & 1.158664e-01,1.172799e-01,1.187632e-01,1.203067e-01,1.219010e-01,& - & 1.235365e-01,1.252038e-01,1.268933e-01,1.285955e-01,1.303009e-01,& - & 1.320001e-01,1.336834e-01,1.353413e-01,1.369645e-01,1.385433e-01,& - & 1.400683e-01,1.415299e-01,1.429186e-01,1.442250e-01,1.454395e-01,& - & 1.465526e-01,1.475547e-01,1.484365e-01,1.491883e-01,1.498007e-01,& - & 1.502642e-01,1.505692e-01 / - data fdldatice3(:, 23) / & - & 1.167018e-01,1.181642e-01,1.196976e-01,1.212922e-01,1.229385e-01,& - & 1.246269e-01,1.263478e-01,1.280916e-01,1.298488e-01,1.316097e-01,& - & 1.333647e-01,1.351042e-01,1.368187e-01,1.384985e-01,1.401341e-01,& - & 1.417159e-01,1.432343e-01,1.446796e-01,1.460423e-01,1.473128e-01,& - & 1.484816e-01,1.495389e-01,1.504752e-01,1.512810e-01,1.519466e-01,& - & 1.524625e-01,1.528190e-01 / - data fdldatice3(:, 24) / & - & 1.174730e-01,1.189511e-01,1.204991e-01,1.221075e-01,1.237668e-01,& - & 1.254673e-01,1.271996e-01,1.289541e-01,1.307214e-01,1.324919e-01,& - & 1.342560e-01,1.360043e-01,1.377272e-01,1.394152e-01,1.410587e-01,& - & 1.426482e-01,1.441743e-01,1.456273e-01,1.469978e-01,1.482761e-01,& - & 1.494529e-01,1.505185e-01,1.514635e-01,1.522782e-01,1.529533e-01,& - & 1.534791e-01,1.538461e-01 / - data fdldatice3(:, 25) / & - & 1.182775e-01,1.197671e-01,1.213250e-01,1.229417e-01,1.246078e-01,& - & 1.263138e-01,1.280505e-01,1.298082e-01,1.315777e-01,1.333495e-01,& - & 1.351142e-01,1.368623e-01,1.385844e-01,1.402712e-01,1.419132e-01,& - & 1.435010e-01,1.450251e-01,1.464761e-01,1.478447e-01,1.491214e-01,& - & 1.502968e-01,1.513614e-01,1.523058e-01,1.531207e-01,1.537966e-01,& - & 1.543241e-01,1.546937e-01 / - data fdldatice3(:, 26) / & - & 1.194827e-01,1.209930e-01,1.225680e-01,1.241983e-01,1.258751e-01,& - & 1.275890e-01,1.293311e-01,1.310921e-01,1.328631e-01,1.346348e-01,& - & 1.363982e-01,1.381442e-01,1.398636e-01,1.415472e-01,1.431861e-01,& - & 1.447711e-01,1.462931e-01,1.477430e-01,1.491116e-01,1.503899e-01,& - & 1.515687e-01,1.526389e-01,1.535914e-01,1.544171e-01,1.551069e-01,& - & 1.556516e-01,1.560422e-01 / - data fdldatice3(:, 27) / & - & 1.215263e-01,1.230723e-01,1.246757e-01,1.263279e-01,1.280202e-01,& - & 1.297443e-01,1.314914e-01,1.332531e-01,1.350208e-01,1.367859e-01,& - & 1.385398e-01,1.402740e-01,1.419800e-01,1.436491e-01,1.452728e-01,& - & 1.468426e-01,1.483498e-01,1.497860e-01,1.511425e-01,1.524108e-01,& - & 1.535823e-01,1.546485e-01,1.556008e-01,1.564307e-01,1.571295e-01,& - & 1.576887e-01,1.580998e-01 / - data fdldatice3(:, 28) / & - & 1.264232e-01,1.279459e-01,1.295231e-01,1.311465e-01,1.328080e-01,& - & 1.344993e-01,1.362123e-01,1.379388e-01,1.396706e-01,1.413995e-01,& - & 1.431173e-01,1.448158e-01,1.464868e-01,1.481222e-01,1.497138e-01,& - & 1.512533e-01,1.527326e-01,1.541435e-01,1.554778e-01,1.567274e-01,& - & 1.578839e-01,1.589393e-01,1.598853e-01,1.607138e-01,1.614165e-01,& - & 1.619853e-01,1.624121e-01 / - data fdldatice3(:, 29) / & - & 8.549285e-02,7.780694e-02,7.081562e-02,6.447894e-02,5.875695e-02,& - & 5.360975e-02,4.899736e-02,4.487986e-02,4.121732e-02,3.796978e-02,& - & 3.509731e-02,3.256000e-02,3.031787e-02,2.833100e-02,2.655946e-02,& - & 2.496329e-02,2.350257e-02,2.213736e-02,2.082772e-02,1.953369e-02,& - & 1.821538e-02,1.683281e-02,1.534605e-02,1.371517e-02,1.190025e-02,& - & 9.959941e-03,7.929838e-03 / - -! --- ... coefficients to compute tau, ssa, asy for rain drop and -! (chou 1999), and snowflake (fu 2001 private communication) - real (kind=kind_phys), public :: a0r, a1r, a0s, a1s - data a0r,a1r / 3.07e-3, 0.0 /, a0s,a1s / 0.0, 1.5 / ! fu's coeff - - real (kind=kind_phys), dimension(NBLOW:NBHGH), public :: & - & b0r, b0s, b1s, c0r, c0s - data b0r / 0.466, 0.437, 0.416, 0.391, 0.374, 0.352, 0.183, & - & 0.048, 0.012, 0.000, 0.000, 0.000, 0.000, 0.496 / - data c0r / 0.975, 0.965, 0.960, 0.955, 0.952, 0.950, 0.944, & - & 0.894, 0.884, 0.883, 0.883, 0.883, 0.883, 0.980 / - data b0s / 7*0.460, 2*0.000, 4*0.000, 0.460 / - data b1s / 7*0.000, 2*1.62e-5, 4*0.000, 0.000 / - data c0s / 7*0.970, 2*0.970, 4*0.700, 0.970 / - -!........................................! - end module module_radsw_cldprtb ! -!========================================! - - - -!========================================! - module module_radsw_sflux ! -!........................................! -! -! ********* module descriptions ********* ! -! ! -! this module contains spectral distribution of solar radiation ! -! flux used to obtain the incoming solar flux at toa. ! -! ! -! modify history: ! -! originally by j.delamere, atmospheric & environmental research ! -! in 14 bands kgb data table. ! -! feb. 18, 2004 -- yu-tai hou move the reference data table ! -! to a new data module. ! -! ! -! ! -! ********* ********* end description ********* ********* ! -! - use machine, only : kind_phys - use module_radsw_parameters, only : NGMAX, NG16, NG17, NG18, NG19,& - & NG20, NG21, NG22, NG23, NG24, & - & NG25, NG26, NG27, NG28, NG29, & - & NBLOW, NBHGH -! - implicit none -! - private -! - integer, public :: MFS01, MFS02, MFS03, MFB01, MFB02, MFB03 - parameter (MFS01=1, MFS02=5, MFS03=9, MFB01=7, MFB02=2, MFB03=5) -! - real (kind=kind_phys), dimension(NBLOW:NBHGH), public :: & - & strrat, specwt - -! --- original strrat -! data strrat / 2.52131e+2, 3.64641e-1, 3.89589e+1, 5.49281e+0, & -! & 0.00000e+0, 4.53210e-3, 2.27080e-2, 0.00000e+0, 1.24692e-1, & -! & 0.00000e+0, 0.00000e+0, 0.00000e+0, 6.67029e-7, 0.00000e+0 / -! --- strrat(22) has been multified by factor o2adj=1.6 - data strrat / 2.52131e+2, 3.64641e-1, 3.89589e+1, 5.49281e+0, & - & 0.00000e+0, 4.53210e-3, 3.63328e-2, 0.00000e+0, 1.24692e-1, & - & 0.00000e+0, 0.00000e+0, 0.00000e+0, 6.67029e-7, 0.00000e+0 / - - data specwt / 8.,4.,8.,8.,0.,8.,8.,0.,8.,0.,0.,0.,4.,0. / -! - integer, dimension(NBLOW:NBHGH), public :: layreffr, ix1, ix2, ibx - - data layreffr/ 18,30, 6, 3, 3, 8, 2, 6, 1, 2, 0,32,58,49 / - data ix1 / 1, 1, 1, 1, 0, 1, 1, 0, 1, 0, 0, 0, 3, 0 / - data ix2 / 5, 2, 5, 2, 0, 2, 6, 0, 6, 0, 0, 0, 6, 0 / - data ibx / 1, 1, 1, 2, 2, 3, 4, 3, 5, 4, 5, 6, 2, 7 / - - real (kind=kind_phys), parameter, public :: scalekur=50.15/48.37 -! - real (kind=kind_phys), target, public :: & - & sfluxref01(NGMAX,MFS01,MFB01), & - & sfluxref02(NGMAX,MFS02,MFB02), & - & sfluxref03(NGMAX,MFS03,MFB03) - -! --- setup solar sfluxref01 -! ... band 16, NG16=6 - data sfluxref01(:,:,1) / .36511300e+1,& - & .32277700e+1,.26913900e+1,.18039990e+1,.68068900e+0,.54590270e-1,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0/ - -! ... band 20, NG20=10 - data sfluxref01(:,:,2) / .93408100e+1,& - & .89372000e+1,.81934600e+1,.73919600e+1,.61212700e+1,.52395600e+1,& - & .42494100e+1,.32001300e+1,.23949790e+1,.55783362e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0/ - -! ... band 23, NG23=10 - data sfluxref01(:,:,3) / .10462440e+3,& - & .94796000e+2,.40829400e+2,.35180100e+2,.28694700e+2,.21575100e+2,& - & .14638800e+2,.15911100e+1,.23587800e+1,.14541238e+1,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0/ - -! ... band 25, NG25=6 - data sfluxref01(:,:,4) / .42685800e+2,& - & .45772000e+2,.90953400e+2,.88238400e+2,.75011180e+2,.45315347e+1,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0/ - -! ... band 26, NG26=6 - data sfluxref01(:,:,5) / .29007900e+2,& - & .28408800e+2,.33338200e+2,.21820300e+2,.15982813e+2,.93700512e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0/ - -! the following (NG27) values were obtained using the "low resolution" -! version of the kurucz solar source function. for unknown reasons, -! the total irradiance in this band differs from the corresponding -! total in the "high-resolution" version of the Kurucz function. -! therefore, below these values are scaled by the factor scalekur. - -! ... band 27, NG27=8 - data sfluxref01(:,:,6) / .14052600e+2,& - & .11479400e+2,.87259000e+1,.55696600e+1,.38092700e+1,.15769000e+1,& - & .29680079e+1,.19043253e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0/ - -! ... band 29, NG29=12 - data sfluxref01(:,:,7) / .13288000e+1,& - & .21401800e+1,.19761200e+1,.17900000e+1,.27421900e+1,.18615160e+1,& - & .83448990e+0,.12731000e+0,.44698800e-1,.30744100e-1,.11672800e-1,& - & .16557300e-2,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0/ - -! --- setup solar sfluxref02 -! ... band 17, NG17=12 - data sfluxref02(:,:,1) / & - & .31561300e+1,.30344900e+1,.29206900e+1,.26387400e+1,.23458100e+1,& - & .37790500e+1,.12908500e+1,.97039020e+0,.78781300e-1,.10810270e+0,& - & .29412900e-1,.12635380e-1,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.28314700e+1,.29591900e+1,.29667400e+1,.27767700e+1,& - & .24682600e+1,.38472400e+1,.13027900e+1,.97894900e+0,.80212200e-1,& - & .11088140e+0,.29905100e-1,.12675180e-1,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.28230000e+1,.29484500e+1,.29588700e+1,& - & .27759300e+1,.24709600e+1,.38644300e+1,.13079600e+1,.98108860e+0,& - & .80199600e-1,.11130020e+0,.30051500e-1,.12844740e-1,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.28171500e+1,.29378900e+1,& - & .29509100e+1,.27704600e+1,.24771600e+1,.38795600e+1,.13127700e+1,& - & .98414460e+0,.80339100e-1,.11153510e+0,.30072000e-1,.13100450e-1,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.28233500e+1,& - & .29316800e+1,.29145500e+1,.27521300e+1,.24916800e+1,.39013400e+1,& - & .13240100e+1,.99059630e+0,.80519700e-1,.11150350e+0,.30566700e-1,& - & .13155950e-1,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0/ - -! ... band 28, NG28=6 - data sfluxref02(:,:,2) / & - & .10615600e+1,.59991000e+0,.82253900e+0,.47011400e+0,.12054496e+0,& - & .52716294e-2,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.10759800e+1,.58509900e+0,.82292900e+0,.47011400e+0,& - & .12059320e+0,.52233221e-2,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.46164700e+0,.40611300e+0,.64001400e+0,& - & .44662400e+0,.10729748e+1,.52565480e-1,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.13266900e+0,.17505800e+0,& - & .74740500e+0,.82625100e+0,.11385304e+1,.60026497e-1,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.75480000E-1,& - & .23224600e+0,.74740500e+0,.77667600e+0,.11821991e+1,.65932601e-1,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0/ - -! --- setup solar sfluxref03 -! ... band 18, NG18=8 - data sfluxref03(:,:,1) / & - & .36584000e+1,.35437500e+1,.33448100e+1,.31053400e+1,.52272000e+1,& - & .34812500e+1,.12703318e+1,.98650010e-1,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.38637200e+1,.34852100e+1,.33079000E+1,.30810300e+1,& - & .51827400e+1,.34533000e+1,.12591244e+1,.96720520e-1,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.39037000e+1,.35065700e+1,.33062900e+1,& - & .30604600e+1,.51688900e+1,.34381600e+1,.12512870e+1,.94381020e-1,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.39316500e+1,.35205800e+1,& - & .33134600e+1,.30494400e+1,.51550700e+1,.34226800e+1,.12456526e+1,& - & .91203220e-1,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.39408200e+1,& - & .35522100e+1,.33186300e+1,.30473000e+1,.51324600e+1,.34110100e+1,& - & .12380195e+1,.89290320e-1,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .39419800e+1,.35874300e+1,.33210600e+1,.30586600e+1,.51105400e+1,& - & .33948500e+1,.12272675e+1,.87955720e-1,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.39359600e+1,.36336600e+1,.33314400e+1,.30625200e+1,& - & .50954600e+1,.33706900e+1,.12121929e+1,.87814620e-1,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.39252000e+1,.36907800e+1,.33565600e+1,& - & .30705500e+1,.50829200e+1,.33242900e+1,.11916105e+1,.87812520e-1,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.38072100e+1,.37443700e+1,& - & .35020500e+1,.31800900e+1,.50494500e+1,.32007600e+1,.11580073e+1,& - & .87812920e-1,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0 / - -! ... band 19, NG19=8 - data sfluxref03(:,:,2) / & - & .32579100e+1,.32969700e+1,.31603100e+1,.29611500e+1,.50305700e+1,& - & .33767800e+1,.12463848e+1,.97623090e-1,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.32276900e+1,.32881700e+1,.31668700e+1,.29766200e+1,& - & .50388700e+1,.33829100e+1,.12493943e+1,.97174500e-1,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.32229400e+1,.32778000e+1,.31742400e+1,& - & .29714300e+1,.50477800e+1,.33835100e+1,.12527049e+1,.97276400e-1,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.32244500e+1,.32611300e+1,& - & .31843800e+1,.29692100e+1,.50516500e+1,.33840300e+1,.12553459e+1,& - & .97505500e-1,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.32249700e+1,& - & .32510900e+1,.31874100e+1,.29697000e+1,.50548000e+1,.33852500e+1,& - & .12565675e+1,.97922400e-1,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .32263200e+1,.32417400e+1,.31852400e+1,.29740200e+1,.50554900e+1,& - & .33899800e+1,.12562855e+1,.98616200e-1,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.32279300e+1,.32358900e+1,.31772000e+1,.29786900e+1,& - & .50572900e+1,.33942500e+1,.12571685e+1,.99276100e-1,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.32296600e+1,.32408700e+1,.31567600e+1,& - & .29817100e+1,.50586900e+1,.34020900e+1,.12586610e+1,.99259200e-1,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.32724000e+1,.32466600e+1,& - & .31388600e+1,.29523800e+1,.50465000e+1,.34105900e+1,.12610396e+1,& - & .99262600e-1,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0 / - -! ... band 21, NG21=10 - data sfluxref03(:,:,3) / & - & .16164300e+2,.15580600e+2,.14725400e+2,.13554100e+2,.11951900e+2,& - & .10444100e+2,.83788400e+1,.62638400e+1,.47495780e+1,.11187392e+1,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.15645100e+2,.15317000e+2,.14698700e+2,.13735000e+2,& - & .12226700e+2,.10516460e+2,.84715000e+1,.63887300e+1,.48059700e+1,& - & .11263635e+1,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.15609200e+2,.15329300e+2,.14688100e+2,& - & .13669300e+2,.12234200e+2,.10520100e+2,.84944200e+1,.64213800e+1,& - & .48319990e+1,.11333414e+1,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.15578600e+2,.15342200e+2,& - & .14689400e+2,.13604000e+2,.12256700e+2,.10494000e+2,.85352100e+1,& - & .64442700e+1,.48477890e+1,.11392313e+1,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.15538000e+2,& - & .15382600e+2,.14657500e+2,.13572200e+2,.12264600e+2,.10476720e+2,& - & .85715800e+1,.64634300e+1,.48602370e+1,.114454305e+1,.0000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .15512400e+2,.15398600e+2,.14624000e+2,.13553500e+2,.12246800e+2,& - & .10488910e+2,.86043400e+1,.6479850e+1,.48727470e+1,.115032015e+1,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.15491000e+2,.15402800e+2,.14577200e+2,.13550700e+2,& - & .12212200e+2,.10527350e+2,.86265000e+1,.64964400e+1,.48903570e+1,& - & .115687915e+1,.0000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.15456200e+2,.15392800e+2,.14551000e+2,& - & .13512200e+2,.12189000e+2,.10582600e+2,.86584200e+1,.65155800e+1,& - & .49081390e+1,.116541315e+1,.0000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.15006900e+2,.15147900e+2,& - & .14780200e+2,.13608500e+2,.12279300e+2,.10692900e+2,.87272300e+1,& - & .65711400e+1,.49500240e+1,.116747315e+1,.0000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0 / - -! ... band 22, NG22=2 - data sfluxref03(:,:,4) / & - & .22870690e+2,.142292348e+1,.0000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.22872700e+2,.142092788e+1,.0000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.22877410e+2,.141623238e+1,.0000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.0000000e+0,.22879360e+2,.141425888e+1,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.22880890e+2,& - & .14127222e+1,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .22882260e+2,.141135631e+1,.0000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.22883070e+2,.141054121e+1,.0000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.22884580e+2,.140903474e+1,.0000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.0000000e+0,.22885890e+2,.140772281e+1,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0 / - -! ... band 24, NG24=8 - data sfluxref03(:,:,5) / & - & .67485000e+2,.60119600e+2,.46277600e+2,.31190000e+2,.10594640e+2,& - & .15530850e+1,.82783000e+0,.13921180e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.66669400e+2,.58294800e+2,.47994500e+2,.32163300e+2,& - & .10551730e+2,.15462830e+1,.82782300e+0,.13922180e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.66436200e+2,.58556400e+2,.47978900e+2,& - & .32183500e+2,.10528620e+2,.15397570e+1,.82447300e+0,.13921180e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.66368100e+2,.58663000e+2,& - & .47964300e+2,.32188200e+2,.10508680e+2,.15344650e+1,.82105100e+0,& - & .13921180e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.66325500e+2,& - & .58727000e+2,.47967600e+2,.32196900e+2,.10482800e+2,.15295910e+1,& - & .81841600e+0,.13922180e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .66303600e+2,.58785900e+2,.47960400e+2,.32194700e+2,.10462370e+2,& - & .15250500e+1,.81580900e+0,.13921180e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.66332200e+2,.58793500e+2,.47946700e+2,.32196300e+2,& - & .10445690e+2,.15221860e+1,.81413300e+0,.13631770e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.66389100e+2,.58828200e+2,.47920000e+2,& - & .32155700e+2,.10430340e+2,.15208810e+1,.81012300e+0,.13260880e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.67319100e+2,.58382700e+2,& - & .47610800e+2,.32032700e+2,.10390010e+2,.15156730e+1,.80297600e+0,& - & .13316830e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& - & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0 / - -!........................................! - end module module_radsw_sflux ! -!========================================! - - - -!========================================! - module module_radsw_kgb16 ! -!........................................! -! -! ********* the original program descriptions ********* ! -! ! -! originally by j.delamere, atmospheric & environmental research. ! -! revision: 2.4 ! -! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4) ! -! reformatted for f90 by jjmorcrette, ecmwf ! -! ! -! this table has been re-generated for reduced number of g-point ! -! by y.t.hou, ncep ! -! ! -! ********* ********* end description ********* ********* ! -! - use machine, only : kind_phys - use module_radsw_parameters, only : NG16 - -! - implicit none -! - private -! - integer, public :: MSA16, MSB16, MSF16, MFR16 - parameter (MSA16=585, MSB16=235, MSF16=10, MFR16=3) - - real (kind=kind_phys), public :: selfref(MSF16,NG16), & - & absa(MSA16,NG16), absb(MSB16,NG16), forref(MFR16,NG16) - -! --- rayleigh extinction coefficient at v = 2925 cm-1. - real (kind=kind_phys), parameter, public :: rayl = 2.91e-10 - -! the array absa(585,NG16) (ka(9,5,13,NG16)) contains absorption coefs at -! the 16 chosen g-values for a range of pressure levels> ~100mb, -! temperatures, and binary species parameters (see taumol.f for definition). -! the first index in the array, js, runs from 1 to 9, and corresponds -! to different values of the binary species parameter. for instance, -! js=1 refers to dry air, js = 2 corresponds to the paramter value 1/8, -! js = 3 corresponds to the parameter value 2/8, etc. the second index -! in the array, jt, which runs from 1 to 5, corresponds to different -! temperatures. more specifically, jt = 3 means that the data are for -! the reference temperature tref for this pressure level, jt = 2 refers -! to tref-15, jt = 1 is for tref-30, jt = 4 is for tref+15, and jt = 5 -! is for tref+30. the third index, jp, runs from 1 to 13 and refers -! to the jpth reference pressure level (see taumol.f for these levels -! in mb). the fourth index, ig, goes from 1 to 6, and indicates -! which g-interval the absorption coefficients are for. - - data absa( 1:180, 1) / & - & .6164391E-04,.1393981E-03,.1485874E-03,.1470456E-03,.1378359E-03,& - & .1251049E-03,.1080809E-03,.8380100E-04,.4375937E-04,.6303123E-04,& - & .1387829E-03,.1476732E-03,.1465675E-03,.1376116E-03,.1247762E-03,& - & .1082831E-03,.8452911E-04,.4545314E-04,.6421152E-04,.1383722E-03,& - & .1469969E-03,.1464177E-03,.1376712E-03,.1247454E-03,.1085938E-03,& - & .8527181E-04,.4714073E-04,.6487941E-04,.1376604E-03,.1463450E-03,& - & .1456654E-03,.1375752E-03,.1247169E-03,.1088288E-03,.8599534E-04,& - & .4882216E-04,.6543285E-04,.1371565E-03,.1459883E-03,.1450442E-03,& - & .1376047E-03,.1246488E-03,.1084938E-03,.8677500E-04,.5041239E-04,& - & .5313622E-04,.1212259E-03,.1294107E-03,.1289969E-03,.1215056E-03,& - & .1099177E-03,.9560988E-04,.7413197E-04,.3741326E-04,.5429633E-04,& - & .1208023E-03,.1288524E-03,.1287190E-03,.1215251E-03,.1095731E-03,& - & .9593147E-04,.7493945E-04,.3890369E-04,.5532831E-04,.1205422E-03,& - & .1285240E-03,.1281017E-03,.1216844E-03,.1097557E-03,.9586096E-04,& - & .7569726E-04,.4033143E-04,.5592005E-04,.1201155E-03,.1280667E-03,& - & .1275655E-03,.1215386E-03,.1099924E-03,.9556109E-04,.7641040E-04,& - & .4181164E-04,.5617841E-04,.1196101E-03,.1275438E-03,.1270047E-03,& - & .1210925E-03,.1101989E-03,.9565779E-04,.7709991E-04,.4321251E-04,& - & .4531290E-04,.1048278E-03,.1125651E-03,.1126461E-03,.1064403E-03,& - & .9599592E-04,.8416227E-04,.6509075E-04,.3260217E-04,.4640094E-04,& - & .1045811E-03,.1122478E-03,.1120739E-03,.1065744E-03,.9607551E-04,& - & .8395460E-04,.6589635E-04,.3382481E-04,.4717230E-04,.1043514E-03,& - & .1118439E-03,.1116296E-03,.1065479E-03,.9636785E-04,.8372961E-04,& - & .6667225E-04,.3501452E-04,.4770015E-04,.1042243E-03,.1115519E-03,& - & .1111144E-03,.1064012E-03,.9685136E-04,.8410622E-04,.6743058E-04,& - & .3619213E-04,.4786332E-04,.1037274E-03,.1110955E-03,.1107897E-03,& - & .1063675E-03,.9719954E-04,.8449192E-04,.6808715E-04,.3740757E-04,& - & .3843039E-04,.9043110E-04,.9770352E-04,.9799335E-04,.9304240E-04,& - & .8389000E-04,.7321734E-04,.5677836E-04,.2994598E-04,.3931732E-04,& - & .9024615E-04,.9732057E-04,.9745928E-04,.9306943E-04,.8414269E-04,& - & .7304152E-04,.5752626E-04,.3089971E-04,.3999765E-04,.9015208E-04,& - & .9690713E-04,.9702354E-04,.9292115E-04,.8443883E-04,.7337197E-04,& - & .5829869E-04,.3187537E-04,.4043089E-04,.8996634E-04,.9668335E-04,& - & .9670285E-04,.9286755E-04,.8481230E-04,.7380442E-04,.5906049E-04,& - & .3283818E-04,.4073202E-04,.8972393E-04,.9645513E-04,.9660020E-04,& - & .9303706E-04,.8536068E-04,.7423279E-04,.5981517E-04,.3379450E-04/ - - data absa(181:315, 1) / & - & .3239990E-04,.7798454E-04,.8455791E-04,.8504346E-04,.8081384E-04,& - & .7294914E-04,.6337302E-04,.4924460E-04,.2913833E-04,.3322912E-04,& - & .7774352E-04,.8406820E-04,.8454204E-04,.8094382E-04,.7323153E-04,& - & .6358291E-04,.4994292E-04,.2993189E-04,.3380830E-04,.7760287E-04,& - & .8375655E-04,.8415223E-04,.8078676E-04,.7365225E-04,.6386151E-04,& - & .5066949E-04,.3071453E-04,.3417420E-04,.7744463E-04,.8351059E-04,& - & .8385781E-04,.8079307E-04,.7414802E-04,.6412908E-04,.5142302E-04,& - & .3151682E-04,.3444762E-04,.7723103E-04,.8340026E-04,.8386295E-04,& - & .8097163E-04,.7469899E-04,.6465444E-04,.5217398E-04,.3235645E-04,& - & .2715767E-04,.6701770E-04,.7283633E-04,.7341902E-04,.6985462E-04,& - & .6319692E-04,.5481578E-04,.4247223E-04,.2909771E-04,.2792146E-04,& - & .6685295E-04,.7241685E-04,.7300079E-04,.6986342E-04,.6356893E-04,& - & .5491074E-04,.4310004E-04,.2966308E-04,.2845821E-04,.6661135E-04,& - & .7209651E-04,.7266374E-04,.6978860E-04,.6395350E-04,.5508302E-04,& - & .4376855E-04,.3030854E-04,.2875713E-04,.6641988E-04,.7186205E-04,& - & .7238777E-04,.6998777E-04,.6431932E-04,.5551791E-04,.4448282E-04,& - & .3094504E-04,.2891644E-04,.6615229E-04,.7169260E-04,.7229235E-04,& - & .7001252E-04,.6472305E-04,.5607907E-04,.4487260E-04,.3162719E-04,& - & .2261551E-04,.5728902E-04,.6237413E-04,.6297079E-04,.5987738E-04,& - & .5427552E-04,.4703020E-04,.3639661E-04,.2945807E-04,.2329813E-04,& - & .5709378E-04,.6201885E-04,.6258230E-04,.5996529E-04,.5461263E-04,& - & .4701194E-04,.3698989E-04,.3029693E-04,.2379683E-04,.5686371E-04,& - & .6178860E-04,.6234127E-04,.5990707E-04,.5500772E-04,.4729286E-04,& - & .3760923E-04,.3119772E-04,.2405414E-04,.5664356E-04,.6153544E-04,& - & .6214186E-04,.6002313E-04,.5529452E-04,.4777815E-04,.3824621E-04,& - & .3201199E-04,.2417921E-04,.5638188E-04,.6131618E-04,.6200411E-04,& - & .5999630E-04,.5566905E-04,.4832075E-04,.3841731E-04,.3273083E-04/ - - data absa(316:450, 1) / & - & .1878381E-04,.4894749E-04,.5331015E-04,.5389221E-04,.5125674E-04,& - & .4647673E-04,.4004232E-04,.3106983E-04,.2910087E-04,.1940228E-04,& - & .4877469E-04,.5302872E-04,.5356337E-04,.5126792E-04,.4678873E-04,& - & .4012482E-04,.3162012E-04,.3075290E-04,.1985918E-04,.4855059E-04,& - & .5279719E-04,.5333080E-04,.5126898E-04,.4707665E-04,.4046924E-04,& - & .3217345E-04,.3150876E-04,.2014062E-04,.4829423E-04,.5255189E-04,& - & .5319514E-04,.5130651E-04,.4737582E-04,.4091784E-04,.3262566E-04,& - & .3216455E-04,.2025329E-04,.4801466E-04,.5234235E-04,.5308048E-04,& - & .5128923E-04,.4759043E-04,.4140204E-04,.3278753E-04,.3333379E-04,& - & .1546471E-04,.4162009E-04,.4540125E-04,.4587423E-04,.4356518E-04,& - & .3940508E-04,.3397440E-04,.2638191E-04,.3148426E-04,.1606324E-04,& - & .4144674E-04,.4510294E-04,.4559038E-04,.4360139E-04,.3960990E-04,& - & .3411097E-04,.2689026E-04,.3297831E-04,.1647624E-04,.4124716E-04,& - & .4486029E-04,.4540089E-04,.4359331E-04,.3994622E-04,.3443250E-04,& - & .2738815E-04,.3466130E-04,.1674831E-04,.4101176E-04,.4463266E-04,& - & .4523420E-04,.4362159E-04,.4026871E-04,.3484293E-04,.2762312E-04,& - & .3608726E-04,.1688109E-04,.4072506E-04,.4442676E-04,.4508760E-04,& - & .4359419E-04,.4044664E-04,.3522608E-04,.2789812E-04,.3743236E-04,& - & .1262626E-04,.3515542E-04,.3839650E-04,.3883879E-04,.3680058E-04,& - & .3322886E-04,.2866957E-04,.2229743E-04,.3542581E-04,.1323548E-04,& - & .3501861E-04,.3816682E-04,.3862136E-04,.3691204E-04,.3341643E-04,& - & .2882784E-04,.2274500E-04,.3810724E-04,.1360997E-04,.3480644E-04,& - & .3790261E-04,.3840467E-04,.3688940E-04,.3369037E-04,.2909482E-04,& - & .2319725E-04,.4051484E-04,.1386341E-04,.3459077E-04,.3769098E-04,& - & .3821868E-04,.3684829E-04,.3399846E-04,.2945016E-04,.2334606E-04,& - & .4250812E-04,.1401007E-04,.3434705E-04,.3748890E-04,.3806620E-04,& - & .3681278E-04,.3416954E-04,.2981567E-04,.2357415E-04,.4469942E-04/ - - data absa(451:585, 1) / & - & .1054345E-04,.2952630E-04,.3222392E-04,.3265638E-04,.3106790E-04,& - & .2796314E-04,.2415008E-04,.1892216E-04,.3133027E-04,.1103113E-04,& - & .2937313E-04,.3202245E-04,.3244622E-04,.3107680E-04,.2818612E-04,& - & .2432663E-04,.1931576E-04,.3420418E-04,.1132648E-04,.2917577E-04,& - & .3179835E-04,.3224295E-04,.3105314E-04,.2839919E-04,.2458295E-04,& - & .1960995E-04,.3745408E-04,.1151773E-04,.2897659E-04,.3158949E-04,& - & .3206591E-04,.3099578E-04,.2862811E-04,.2491522E-04,.1969533E-04,& - & .4018024E-04,.1162646E-04,.2873280E-04,.3141795E-04,.3192928E-04,& - & .3092122E-04,.2876193E-04,.2527302E-04,.1991005E-04,.4272251E-04,& - & .8773859E-05,.2472331E-04,.2698123E-04,.2731286E-04,.2605313E-04,& - & .2347524E-04,.2028179E-04,.1599354E-04,.2710338E-04,.9175082E-05,& - & .2455642E-04,.2677932E-04,.2714788E-04,.2603439E-04,.2367042E-04,& - & .2044068E-04,.1632502E-04,.2976471E-04,.9405766E-05,.2437939E-04,& - & .2657517E-04,.2695641E-04,.2600791E-04,.2387449E-04,.2068968E-04,& - & .1643613E-04,.3198691E-04,.9551613E-05,.2419222E-04,.2638939E-04,& - & .2678440E-04,.2590383E-04,.2398600E-04,.2098502E-04,.1655507E-04,& - & .3463054E-04,.9634553E-05,.2396313E-04,.2622876E-04,.2664925E-04,& - & .2582504E-04,.2410681E-04,.2125060E-04,.1672669E-04,.3742745E-04,& - & .7283549E-05,.2064472E-04,.2252697E-04,.2280007E-04,.2176915E-04,& - & .1965230E-04,.1697791E-04,.1344921E-04,.2262985E-04,.7614582E-05,& - & .2049273E-04,.2234335E-04,.2265284E-04,.2175650E-04,.1980433E-04,& - & .1713132E-04,.1373534E-04,.2489034E-04,.7799854E-05,.2032918E-04,& - & .2216475E-04,.2247253E-04,.2168451E-04,.1997844E-04,.1730534E-04,& - & .1371476E-04,.2674112E-04,.7917832E-05,.2015404E-04,.2198881E-04,& - & .2232428E-04,.2159377E-04,.2002799E-04,.1753711E-04,.1382698E-04,& - & .2881746E-04,.7981504E-05,.1995296E-04,.2184003E-04,.2217179E-04,& - & .2152204E-04,.2013182E-04,.1776050E-04,.1402084E-04,.3110145E-04/ - - data absa( 1:180, 2) / & - & .2930165E-03,.4205176E-03,.4603190E-03,.4714149E-03,.4679470E-03,& - & .4501949E-03,.4185459E-03,.3688035E-03,.2684515E-03,.2936114E-03,& - & .4252087E-03,.4672427E-03,.4798112E-03,.4769734E-03,.4593456E-03,& - & .4281470E-03,.3781642E-03,.2764789E-03,.2946377E-03,.4315576E-03,& - & .4755024E-03,.4896418E-03,.4876102E-03,.4700407E-03,.4395838E-03,& - & .3880213E-03,.2860406E-03,.2952749E-03,.4370625E-03,.4830699E-03,& - & .4992608E-03,.4981682E-03,.4812406E-03,.4500990E-03,.3988892E-03,& - & .2947867E-03,.2963643E-03,.4435447E-03,.4919681E-03,.5108647E-03,& - & .5100757E-03,.4946687E-03,.4633694E-03,.4116274E-03,.3068946E-03,& - & .2564192E-03,.3741028E-03,.4121845E-03,.4222514E-03,.4178533E-03,& - & .4017900E-03,.3723948E-03,.3265092E-03,.2280897E-03,.2572159E-03,& - & .3784588E-03,.4184094E-03,.4294373E-03,.4260348E-03,.4103047E-03,& - & .3806553E-03,.3334951E-03,.2357658E-03,.2585085E-03,.3843346E-03,& - & .4259985E-03,.4392394E-03,.4361957E-03,.4206279E-03,.3905943E-03,& - & .3429498E-03,.2431183E-03,.2596736E-03,.3898247E-03,.4335148E-03,& - & .4488328E-03,.4466516E-03,.4312067E-03,.4012724E-03,.3532432E-03,& - & .2517667E-03,.2607431E-03,.3954864E-03,.4412810E-03,.4585918E-03,& - & .4573106E-03,.4422671E-03,.4128750E-03,.3642066E-03,.2619245E-03,& - & .2235048E-03,.3314541E-03,.3652461E-03,.3744704E-03,.3699739E-03,& - & .3548398E-03,.3279534E-03,.2865252E-03,.1924155E-03,.2243217E-03,& - & .3351441E-03,.3704468E-03,.3812002E-03,.3769484E-03,.3624388E-03,& - & .3347617E-03,.2927657E-03,.1990504E-03,.2253955E-03,.3397624E-03,& - & .3767056E-03,.3889755E-03,.3852321E-03,.3709575E-03,.3432829E-03,& - & .3003296E-03,.2050004E-03,.2269437E-03,.3455225E-03,.3848163E-03,& - & .3985839E-03,.3955107E-03,.3808205E-03,.3527054E-03,.3092164E-03,& - & .2125103E-03,.2280141E-03,.3507535E-03,.3920562E-03,.4069340E-03,& - & .4049634E-03,.3903833E-03,.3628870E-03,.3187283E-03,.2207668E-03,& - & .1945146E-03,.2918639E-03,.3214502E-03,.3303679E-03,.3254231E-03,& - & .3116270E-03,.2876070E-03,.2498710E-03,.1637253E-03,.1954096E-03,& - & .2951961E-03,.3261050E-03,.3361412E-03,.3314562E-03,.3181672E-03,& - & .2938352E-03,.2559070E-03,.1693706E-03,.1965264E-03,.2992768E-03,& - & .3318268E-03,.3430041E-03,.3386437E-03,.3253725E-03,.3007759E-03,& - & .2623706E-03,.1739993E-03,.1975452E-03,.3039553E-03,.3382589E-03,& - & .3504664E-03,.3467920E-03,.3335199E-03,.3082884E-03,.2693916E-03,& - & .1801702E-03,.1992020E-03,.3099779E-03,.3465283E-03,.3595055E-03,& - & .3565400E-03,.3430057E-03,.3175611E-03,.2774855E-03,.1867273E-03/ - - data absa(181:315, 2) / & - & .1692110E-03,.2560783E-03,.2816239E-03,.2892751E-03,.2854340E-03,& - & .2729454E-03,.2512636E-03,.2176013E-03,.1406685E-03,.1700158E-03,& - & .2591285E-03,.2857505E-03,.2942600E-03,.2906779E-03,.2782649E-03,& - & .2565024E-03,.2227555E-03,.1451134E-03,.1711402E-03,.2627639E-03,& - & .2908575E-03,.3002244E-03,.2969592E-03,.2845936E-03,.2626853E-03,& - & .2280973E-03,.1489243E-03,.1723113E-03,.2667721E-03,.2966815E-03,& - & .3070349E-03,.3041790E-03,.2912783E-03,.2694000E-03,.2338131E-03,& - & .1538692E-03,.1740563E-03,.2722405E-03,.3040666E-03,.3151440E-03,& - & .3128365E-03,.2994324E-03,.2773169E-03,.2405489E-03,.1587634E-03,& - & .1467247E-03,.2239121E-03,.2459341E-03,.2521661E-03,.2491285E-03,& - & .2381498E-03,.2185025E-03,.1886728E-03,.1245807E-03,.1473884E-03,& - & .2265685E-03,.2495294E-03,.2564125E-03,.2535594E-03,.2425776E-03,& - & .2232033E-03,.1930135E-03,.1274953E-03,.1482897E-03,.2296257E-03,& - & .2540362E-03,.2615549E-03,.2589723E-03,.2479233E-03,.2285370E-03,& - & .1976049E-03,.1306204E-03,.1494392E-03,.2332170E-03,.2591337E-03,& - & .2675927E-03,.2648872E-03,.2537659E-03,.2341528E-03,.2022251E-03,& - & .1344888E-03,.1508093E-03,.2374102E-03,.2648426E-03,.2740852E-03,& - & .2718576E-03,.2604781E-03,.2406433E-03,.2081661E-03,.1378196E-03,& - & .1263109E-03,.1951428E-03,.2144975E-03,.2195749E-03,.2170080E-03,& - & .2069188E-03,.1894328E-03,.1633783E-03,.1200887E-03,.1271134E-03,& - & .1973810E-03,.2175147E-03,.2232648E-03,.2204590E-03,.2109194E-03,& - & .1937750E-03,.1670597E-03,.1213160E-03,.1278627E-03,.2000293E-03,& - & .2212521E-03,.2276502E-03,.2250313E-03,.2152307E-03,.1982160E-03,& - & .1708010E-03,.1229746E-03,.1288762E-03,.2031265E-03,.2255973E-03,& - & .2327902E-03,.2301752E-03,.2203853E-03,.2029333E-03,.1746039E-03,& - & .1249396E-03,.1300624E-03,.2067082E-03,.2305851E-03,.2383986E-03,& - & .2363202E-03,.2260966E-03,.2085247E-03,.1797897E-03,.1276706E-03/ - - data absa(316:450, 2) / & - & .1087530E-03,.1695227E-03,.1869845E-03,.1912855E-03,.1886016E-03,& - & .1794107E-03,.1640395E-03,.1407348E-03,.1388109E-03,.1095657E-03,& - & .1712971E-03,.1895043E-03,.1945158E-03,.1916236E-03,.1827598E-03,& - & .1678635E-03,.1438343E-03,.1366925E-03,.1103222E-03,.1736665E-03,& - & .1926247E-03,.1982051E-03,.1955376E-03,.1864091E-03,.1715841E-03,& - & .1469470E-03,.1364063E-03,.1111854E-03,.1763283E-03,.1961855E-03,& - & .2023728E-03,.2000777E-03,.1907608E-03,.1757564E-03,.1506354E-03,& - & .1369112E-03,.1122634E-03,.1793268E-03,.2003957E-03,.2070334E-03,& - & .2051943E-03,.1958970E-03,.1805692E-03,.1551262E-03,.1374744E-03,& - & .9300705E-04,.1464182E-03,.1620111E-03,.1662152E-03,.1638421E-03,& - & .1556181E-03,.1415254E-03,.1207125E-03,.2197460E-03,.9379197E-04,& - & .1478848E-03,.1642219E-03,.1688554E-03,.1664207E-03,.1584541E-03,& - & .1446859E-03,.1233342E-03,.2178811E-03,.9457710E-04,.1498107E-03,& - & .1668492E-03,.1719850E-03,.1697382E-03,.1615171E-03,.1478254E-03,& - & .1260245E-03,.2169464E-03,.9536836E-04,.1520740E-03,.1699345E-03,& - & .1755822E-03,.1735872E-03,.1652759E-03,.1515057E-03,.1293800E-03,& - & .2166357E-03,.9627944E-04,.1547433E-03,.1735275E-03,.1795990E-03,& - & .1780373E-03,.1697434E-03,.1556408E-03,.1331356E-03,.2164129E-03,& - & .7917379E-04,.1259529E-03,.1400562E-03,.1440600E-03,.1421290E-03,& - & .1348884E-03,.1219352E-03,.1031837E-03,.3271209E-03,.7977861E-04,& - & .1271040E-03,.1418834E-03,.1462764E-03,.1442107E-03,.1372758E-03,& - & .1246562E-03,.1054164E-03,.3261360E-03,.8053422E-04,.1287862E-03,& - & .1442112E-03,.1488988E-03,.1470409E-03,.1399784E-03,.1274996E-03,& - & .1079546E-03,.3247606E-03,.8124880E-04,.1308583E-03,.1468362E-03,& - & .1519274E-03,.1504180E-03,.1431923E-03,.1307815E-03,.1110513E-03,& - & .3234572E-03,.8201452E-04,.1331325E-03,.1497495E-03,.1553833E-03,& - & .1542308E-03,.1471022E-03,.1343535E-03,.1143694E-03,.3218489E-03/ - - data absa(451:585, 2) / & - & .6728851E-04,.1080906E-03,.1208580E-03,.1247323E-03,.1232827E-03,& - & .1175266E-03,.1060571E-03,.8883780E-04,.3501958E-03,.6791800E-04,& - & .1091898E-03,.1225378E-03,.1268241E-03,.1253901E-03,.1196653E-03,& - & .1084469E-03,.9082183E-04,.3442870E-03,.6851447E-04,.1107863E-03,& - & .1246494E-03,.1293024E-03,.1281246E-03,.1222490E-03,.1111838E-03,& - & .9324574E-04,.3420183E-03,.6908353E-04,.1126804E-03,.1269928E-03,& - & .1321156E-03,.1312354E-03,.1252083E-03,.1140710E-03,.9617117E-04,& - & .3390113E-03,.6957312E-04,.1148165E-03,.1296320E-03,.1352293E-03,& - & .1346612E-03,.1287087E-03,.1172723E-03,.9910752E-04,.3385633E-03,& - & .5686255E-04,.9216035E-04,.1034858E-03,.1071516E-03,.1060652E-03,& - & .1014159E-03,.9163836E-04,.7623805E-04,.3310437E-03,.5734770E-04,& - & .9329051E-04,.1049670E-03,.1090060E-03,.1081383E-03,.1034188E-03,& - & .9390315E-04,.7812498E-04,.3244905E-03,.5781298E-04,.9473394E-04,& - & .1068652E-03,.1112574E-03,.1106069E-03,.1057391E-03,.9631206E-04,& - & .8054235E-04,.3210568E-03,.5822217E-04,.9640942E-04,.1089655E-03,& - & .1137847E-03,.1134036E-03,.1085277E-03,.9896999E-04,.8309374E-04,& - & .3173487E-03,.5853550E-04,.9825196E-04,.1113394E-03,.1165990E-03,& - & .1165067E-03,.1117023E-03,.1018552E-03,.8573085E-04,.3168446E-03,& - & .4783824E-04,.7831477E-04,.8819578E-04,.9148052E-04,.9081639E-04,& - & .8696960E-04,.7879106E-04,.6529420E-04,.2796540E-03,.4821354E-04,& - & .7934773E-04,.8956662E-04,.9314137E-04,.9269390E-04,.8882919E-04,& - & .8080982E-04,.6704726E-04,.2741660E-03,.4859146E-04,.8061493E-04,& - & .9116325E-04,.9515541E-04,.9486227E-04,.9088828E-04,.8295551E-04,& - & .6935405E-04,.2709349E-03,.4883862E-04,.8204290E-04,.9304806E-04,& - & .9741929E-04,.9740051E-04,.9346855E-04,.8534014E-04,.7158356E-04,& - & .2681460E-03,.4903521E-04,.8353294E-04,.9510393E-04,.9997200E-04,& - & .1001833E-03,.9622958E-04,.8790924E-04,.7395389E-04,.2673945E-03/ - - data absa( 1:180, 3) / & - & .8184572E-03,.1288796E-02,.1495187E-02,.1632713E-02,.1719945E-02,& - & .1761605E-02,.1759635E-02,.1698408E-02,.1367318E-02,.8243726E-03,& - & .1301794E-02,.1514658E-02,.1658937E-02,.1753464E-02,.1802877E-02,& - & .1805416E-02,.1745195E-02,.1405620E-02,.8348880E-03,.1320873E-02,& - & .1542641E-02,.1692748E-02,.1795401E-02,.1852780E-02,.1858131E-02,& - & .1800382E-02,.1449500E-02,.8418718E-03,.1340423E-02,.1571743E-02,& - & .1728235E-02,.1837120E-02,.1903874E-02,.1915521E-02,.1859941E-02,& - & .1503155E-02,.8531253E-03,.1366891E-02,.1607512E-02,.1771740E-02,& - & .1886777E-02,.1961375E-02,.1981251E-02,.1927613E-02,.1561788E-02,& - & .7302326E-03,.1151907E-02,.1334524E-02,.1456839E-02,.1533051E-02,& - & .1567636E-02,.1559387E-02,.1499443E-02,.1187382E-02,.7372791E-03,& - & .1164596E-02,.1352581E-02,.1480270E-02,.1561840E-02,.1601428E-02,& - & .1596993E-02,.1539888E-02,.1219763E-02,.7483530E-03,.1183063E-02,& - & .1378407E-02,.1510357E-02,.1596909E-02,.1642217E-02,.1642410E-02,& - & .1586010E-02,.1257897E-02,.7577399E-03,.1203485E-02,.1406414E-02,& - & .1543415E-02,.1634037E-02,.1686222E-02,.1692333E-02,.1636545E-02,& - & .1301186E-02,.7660501E-03,.1226282E-02,.1437446E-02,.1580408E-02,& - & .1675024E-02,.1733502E-02,.1745352E-02,.1693309E-02,.1350969E-02,& - & .6502794E-03,.1026616E-02,.1186960E-02,.1295393E-02,.1364677E-02,& - & .1394889E-02,.1381785E-02,.1317502E-02,.1017363E-02,.6567559E-03,& - & .1037505E-02,.1202583E-02,.1315591E-02,.1388459E-02,.1421306E-02,& - & .1413547E-02,.1351496E-02,.1044406E-02,.6651689E-03,.1050207E-02,& - & .1223023E-02,.1339830E-02,.1416067E-02,.1452943E-02,.1449484E-02,& - & .1390425E-02,.1076530E-02,.6772722E-03,.1071331E-02,.1249580E-02,& - & .1370662E-02,.1449539E-02,.1490615E-02,.1491899E-02,.1434093E-02,& - & .1111777E-02,.6855463E-03,.1091648E-02,.1276403E-02,.1402863E-02,& - & .1483596E-02,.1529594E-02,.1535466E-02,.1481180E-02,.1152638E-02,& - & .5768479E-03,.9115621E-03,.1053538E-02,.1150084E-02,.1211847E-02,& - & .1236742E-02,.1220110E-02,.1153457E-02,.8691713E-03,.5830135E-03,& - & .9209284E-03,.1066914E-02,.1166765E-02,.1232185E-02,.1259290E-02,& - & .1246437E-02,.1180938E-02,.8912098E-03,.5910480E-03,.9345088E-03,& - & .1084575E-02,.1187678E-02,.1255979E-02,.1286682E-02,.1276512E-02,& - & .1213240E-02,.9180720E-03,.6008298E-03,.9515132E-03,.1106486E-02,& - & .1212563E-02,.1283329E-02,.1317431E-02,.1311088E-02,.1249258E-02,& - & .9471810E-03,.6138388E-03,.9709949E-03,.1132455E-02,.1242798E-02,& - & .1315868E-02,.1353280E-02,.1350757E-02,.1291032E-02,.9816019E-03/ - - data absa(181:315, 3) / & - & .5093571E-03,.8080237E-03,.9381643E-03,.1019789E-02,.1071192E-02,& - & .1090471E-02,.1073488E-02,.1005758E-02,.7418709E-03,.5151626E-03,& - & .8165236E-03,.9496789E-03,.1034266E-02,.1088284E-02,.1110067E-02,& - & .1094940E-02,.1028625E-02,.7599047E-03,.5224485E-03,.8286429E-03,& - & .9624412E-03,.1052107E-02,.1109000E-02,.1133457E-02,.1120200E-02,& - & .1055094E-02,.7812729E-03,.5316862E-03,.8438037E-03,.9798289E-03,& - & .1073448E-02,.1132718E-02,.1160426E-02,.1149517E-02,.1085478E-02,& - & .8053947E-03,.5444831E-03,.8638786E-03,.1002962E-02,.1099774E-02,& - & .1161623E-02,.1191798E-02,.1183243E-02,.1121002E-02,.8340163E-03,& - & .4476728E-03,.7152034E-03,.8303044E-03,.9027280E-03,.9422368E-03,& - & .9566089E-03,.9387208E-03,.8743692E-03,.6315594E-03,.4531060E-03,& - & .7229985E-03,.8401962E-03,.9128749E-03,.9571607E-03,.9729227E-03,& - & .9565139E-03,.8930810E-03,.6455309E-03,.4601132E-03,.7340161E-03,& - & .8531068E-03,.9280096E-03,.9748476E-03,.9926457E-03,.9777088E-03,& - & .9149552E-03,.6618730E-03,.4687606E-03,.7470819E-03,.8686951E-03,& - & .9463629E-03,.9951022E-03,.1015485E-02,.1002244E-02,.9403643E-03,& - & .6808008E-03,.4785595E-03,.7635702E-03,.8869579E-03,.9676686E-03,& - & .1018859E-02,.1041246E-02,.1029537E-02,.9684597E-03,.7044125E-03,& - & .3929615E-03,.6307616E-03,.7313469E-03,.7929589E-03,.8247908E-03,& - & .8356659E-03,.8173907E-03,.7575170E-03,.5383971E-03,.3978536E-03,& - & .6382438E-03,.7406018E-03,.8039178E-03,.8378859E-03,.8488038E-03,& - & .8315811E-03,.7727276E-03,.5497760E-03,.4043732E-03,.6478463E-03,& - & .7517647E-03,.8168558E-03,.8526219E-03,.8656075E-03,.8491574E-03,& - & .7907891E-03,.5627384E-03,.4122128E-03,.6599763E-03,.7657659E-03,& - & .8304335E-03,.8701303E-03,.8849440E-03,.8695717E-03,.8115473E-03,& - & .5782796E-03,.4216792E-03,.6747622E-03,.7823998E-03,.8487735E-03,& - & .8905701E-03,.9067120E-03,.8925209E-03,.8346838E-03,.5962302E-03/ - - data absa(316:450, 3) / & - & .3452083E-03,.5538022E-03,.6406411E-03,.6932554E-03,.7213690E-03,& - & .7269628E-03,.7089993E-03,.6545119E-03,.4847209E-03,.3494976E-03,& - & .5608628E-03,.6492121E-03,.7026395E-03,.7319618E-03,.7381217E-03,& - & .7204878E-03,.6670675E-03,.4924614E-03,.3555168E-03,.5695884E-03,& - & .6593390E-03,.7138651E-03,.7429187E-03,.7522301E-03,.7349547E-03,& - & .6817461E-03,.5010009E-03,.3629721E-03,.5805421E-03,.6721512E-03,& - & .7278957E-03,.7573896E-03,.7683553E-03,.7514496E-03,.6984177E-03,& - & .5116719E-03,.3715828E-03,.5938995E-03,.6869808E-03,.7439941E-03,& - & .7750335E-03,.7864892E-03,.7704733E-03,.7174510E-03,.5246067E-03,& - & .3053224E-03,.4856259E-03,.5588804E-03,.6031584E-03,.6264927E-03,& - & .6296159E-03,.6127370E-03,.5636624E-03,.6772975E-03,.3090662E-03,& - & .4924553E-03,.5671508E-03,.6120265E-03,.6363728E-03,.6394116E-03,& - & .6225004E-03,.5739117E-03,.6640269E-03,.3140506E-03,.5003281E-03,& - & .5762886E-03,.6218129E-03,.6467350E-03,.6509293E-03,.6346838E-03,& - & .5862457E-03,.6537700E-03,.3203596E-03,.5098203E-03,.5876621E-03,& - & .6339281E-03,.6587374E-03,.6641130E-03,.6482634E-03,.5998107E-03,& - & .6477927E-03,.3280678E-03,.5213843E-03,.6008020E-03,.6482465E-03,& - & .6724424E-03,.6792561E-03,.6641693E-03,.6153933E-03,.6458298E-03,& - & .2733291E-03,.4289828E-03,.4894421E-03,.5250706E-03,.5435356E-03,& - & .5455983E-03,.5286069E-03,.4846966E-03,.1525269E-02,.2767436E-03,& - & .4347254E-03,.4967461E-03,.5327268E-03,.5517500E-03,.5540458E-03,& - & .5369648E-03,.4938952E-03,.1462778E-02,.2810846E-03,.4416485E-03,& - & .5047342E-03,.5418403E-03,.5610033E-03,.5634743E-03,.5472960E-03,& - & .5038891E-03,.1415701E-02,.2866866E-03,.4502441E-03,.5146077E-03,& - & .5523415E-03,.5718914E-03,.5740346E-03,.5587333E-03,.5149488E-03,& - & .1375472E-02,.2934865E-03,.4607363E-03,.5263019E-03,.5647079E-03,& - & .5847436E-03,.5869370E-03,.5719471E-03,.5277797E-03,.1341507E-02/ - - data absa(451:585, 3) / & - & .2437828E-03,.3835942E-03,.4355111E-03,.4643060E-03,.4763641E-03,& - & .4751451E-03,.4583198E-03,.4193574E-03,.1825342E-02,.2475557E-03,& - & .3898469E-03,.4421366E-03,.4710873E-03,.4839473E-03,.4831741E-03,& - & .4661299E-03,.4275995E-03,.1756933E-02,.2523063E-03,.3973500E-03,& - & .4497777E-03,.4789579E-03,.4924096E-03,.4921150E-03,.4752010E-03,& - & .4363639E-03,.1708388E-02,.2580622E-03,.4058625E-03,.4589941E-03,& - & .4884064E-03,.5025671E-03,.5020326E-03,.4855219E-03,.4461901E-03,& - & .1669299E-02,.2648941E-03,.4157912E-03,.4698491E-03,.4998329E-03,& - & .5143630E-03,.5136245E-03,.4973797E-03,.4575998E-03,.1623002E-02,& - & .2144367E-03,.3401170E-03,.3854223E-03,.4099266E-03,.4196610E-03,& - & .4161366E-03,.3989091E-03,.3620378E-03,.1821655E-02,.2181060E-03,& - & .3463069E-03,.3922259E-03,.4165637E-03,.4265488E-03,.4233797E-03,& - & .4058075E-03,.3692157E-03,.1752071E-02,.2229514E-03,.3537530E-03,& - & .4002355E-03,.4242150E-03,.4345415E-03,.4315545E-03,.4136194E-03,& - & .3770147E-03,.1694072E-02,.2286334E-03,.3622049E-03,.4092201E-03,& - & .4334592E-03,.4440346E-03,.4406362E-03,.4225253E-03,.3857130E-03,& - & .1645638E-02,.2354630E-03,.3723794E-03,.4193491E-03,.4443949E-03,& - & .4547391E-03,.4513798E-03,.4332059E-03,.3959499E-03,.1604607E-02,& - & .1873934E-03,.2995165E-03,.3394711E-03,.3611157E-03,.3690992E-03,& - & .3648908E-03,.3479275E-03,.3123745E-03,.1574790E-02,.1910454E-03,& - & .3056861E-03,.3461932E-03,.3679395E-03,.3758939E-03,.3716238E-03,& - & .3543646E-03,.3186636E-03,.1513357E-02,.1954531E-03,.3127911E-03,& - & .3540282E-03,.3758084E-03,.3835301E-03,.3790064E-03,.3616108E-03,& - & .3254549E-03,.1464333E-02,.2011139E-03,.3213571E-03,.3628469E-03,& - & .3848293E-03,.3922803E-03,.3876951E-03,.3697429E-03,.3333521E-03,& - & .1424128E-02,.2075183E-03,.3308876E-03,.3732484E-03,.3952328E-03,& - & .4025443E-03,.3978826E-03,.3793694E-03,.3424789E-03,.1389880E-02/ - - data absa( 1:180, 4) / & - & .3736324E-02,.6100560E-02,.7728410E-02,.8959576E-02,.9913897E-02,& - & .1060534E-01,.1095043E-01,.1073709E-01,.9408838E-02,.3792238E-02,& - & .6178500E-02,.7827205E-02,.9076284E-02,.1004324E-01,.1073477E-01,& - & .1108085E-01,.1083940E-01,.9519649E-02,.3871754E-02,.6278718E-02,& - & .7949468E-02,.9221394E-02,.1019996E-01,.1088941E-01,.1123148E-01,& - & .1097176E-01,.9657396E-02,.3934975E-02,.6363492E-02,.8064193E-02,& - & .9370476E-02,.1036793E-01,.1105745E-01,.1140542E-01,.1112862E-01,& - & .9816845E-02,.4020724E-02,.6468817E-02,.8206395E-02,.9541906E-02,& - & .1055918E-01,.1126073E-01,.1160795E-01,.1130758E-01,.9996192E-02,& - & .3402273E-02,.5620650E-02,.7030748E-02,.8098078E-02,.8924472E-02,& - & .9508944E-02,.9801255E-02,.9592074E-02,.8097867E-02,.3451518E-02,& - & .5698898E-02,.7132591E-02,.8219355E-02,.9056752E-02,.9642702E-02,& - & .9930623E-02,.9700146E-02,.8198722E-02,.3525436E-02,.5795932E-02,& - & .7258246E-02,.8364978E-02,.9212267E-02,.9796289E-02,.1008263E-01,& - & .9835560E-02,.8322568E-02,.3594242E-02,.5888324E-02,.7386430E-02,& - & .8518910E-02,.9379100E-02,.9970774E-02,.1025951E-01,.9989379E-02,& - & .8466107E-02,.3660490E-02,.5981362E-02,.7519542E-02,.8678334E-02,& - & .9565719E-02,.1017025E-01,.1045322E-01,.1016255E-01,.8625539E-02,& - & .3102796E-02,.5141091E-02,.6344760E-02,.7250524E-02,.7949175E-02,& - & .8434987E-02,.8669628E-02,.8481084E-02,.6903275E-02,.3148146E-02,& - & .5218469E-02,.6443866E-02,.7368450E-02,.8075641E-02,.8560889E-02,& - & .8792122E-02,.8585149E-02,.6988914E-02,.3201454E-02,.5303035E-02,& - & .6555873E-02,.7497631E-02,.8217284E-02,.8706091E-02,.8936316E-02,& - & .8708232E-02,.7092276E-02,.3275760E-02,.5404005E-02,.6690045E-02,& - & .7649565E-02,.8382414E-02,.8880227E-02,.9103836E-02,.8853150E-02,& - & .7213900E-02,.3333969E-02,.5494628E-02,.6816793E-02,.7800860E-02,& - & .8559397E-02,.9065543E-02,.9281723E-02,.9013731E-02,.7356112E-02,& - & .2831427E-02,.4682414E-02,.5696173E-02,.6452550E-02,.7031440E-02,& - & .7425488E-02,.7615078E-02,.7445178E-02,.5905547E-02,.2873398E-02,& - & .4758548E-02,.5791245E-02,.6565599E-02,.7146886E-02,.7543948E-02,& - & .7728470E-02,.7539994E-02,.5975231E-02,.2922042E-02,.4836804E-02,& - & .5896068E-02,.6683182E-02,.7278970E-02,.7678598E-02,.7858498E-02,& - & .7652488E-02,.6063670E-02,.2979003E-02,.4922733E-02,.6010505E-02,& - & .6817378E-02,.7426977E-02,.7832832E-02,.8004073E-02,.7783099E-02,& - & .6166540E-02,.3051509E-02,.5034845E-02,.6147088E-02,.6974054E-02,& - & .7599704E-02,.8009148E-02,.8169023E-02,.7931032E-02,.6289201E-02/ - - data absa(181:315, 4) / & - & .2581422E-02,.4252396E-02,.5095766E-02,.5725588E-02,.6193716E-02,& - & .6511713E-02,.6657529E-02,.6499613E-02,.5066125E-02,.2622021E-02,& - & .4323928E-02,.5186112E-02,.5827234E-02,.6301641E-02,.6620209E-02,& - & .6758605E-02,.6586843E-02,.5124677E-02,.2667849E-02,.4398967E-02,& - & .5285995E-02,.5935349E-02,.6423419E-02,.6740405E-02,.6875009E-02,& - & .6687854E-02,.5199137E-02,.2719644E-02,.4480894E-02,.5391504E-02,& - & .6059082E-02,.6557515E-02,.6877697E-02,.7004932E-02,.6806128E-02,& - & .5284911E-02,.2786609E-02,.4583687E-02,.5519294E-02,.6203484E-02,& - & .6711011E-02,.7035046E-02,.7152458E-02,.6938895E-02,.5385742E-02,& - & .2339609E-02,.3846094E-02,.4554211E-02,.5067608E-02,.5443590E-02,& - & .5691422E-02,.5796061E-02,.5651788E-02,.4350403E-02,.2380923E-02,& - & .3911794E-02,.4637326E-02,.5161799E-02,.5541208E-02,.5788128E-02,& - & .5888423E-02,.5729114E-02,.4399487E-02,.2424975E-02,.3982801E-02,& - & .4723535E-02,.5261943E-02,.5649668E-02,.5897396E-02,.5992483E-02,& - & .5819539E-02,.4460491E-02,.2474162E-02,.4061310E-02,.4818668E-02,& - & .5372412E-02,.5769446E-02,.6018440E-02,.6107034E-02,.5923338E-02,& - & .4530683E-02,.2528477E-02,.4146106E-02,.4927901E-02,.5493040E-02,& - & .5902213E-02,.6153417E-02,.6234974E-02,.6038909E-02,.4613086E-02,& - & .2108102E-02,.3463767E-02,.4067283E-02,.4486100E-02,.4783508E-02,& - & .4968566E-02,.5039362E-02,.4903349E-02,.3736969E-02,.2149169E-02,& - & .3526123E-02,.4141192E-02,.4568003E-02,.4870426E-02,.5056936E-02,& - & .5123533E-02,.4973057E-02,.3776037E-02,.2192220E-02,.3593626E-02,& - & .4218969E-02,.4658171E-02,.4967303E-02,.5154377E-02,.5214872E-02,& - & .5052489E-02,.3823705E-02,.2239930E-02,.3665815E-02,.4305224E-02,& - & .4760112E-02,.5074184E-02,.5261541E-02,.5315916E-02,.5141203E-02,& - & .3879448E-02,.2291457E-02,.3745249E-02,.4403192E-02,.4867213E-02,& - & .5191513E-02,.5380406E-02,.5427689E-02,.5240706E-02,.3946442E-02/ - - data absa(316:450, 4) / & - & .1888206E-02,.3101989E-02,.3625968E-02,.3971182E-02,.4202567E-02,& - & .4344619E-02,.4384538E-02,.4251354E-02,.3181821E-02,.1928325E-02,& - & .3162679E-02,.3693527E-02,.4045345E-02,.4282687E-02,.4424622E-02,& - & .4458656E-02,.4312656E-02,.3213796E-02,.1970231E-02,.3226941E-02,& - & .3764384E-02,.4127675E-02,.4371933E-02,.4510091E-02,.4538985E-02,& - & .4381451E-02,.3253041E-02,.2016368E-02,.3294141E-02,.3842606E-02,& - & .4216009E-02,.4467372E-02,.4604053E-02,.4627489E-02,.4457971E-02,& - & .3298935E-02,.2065463E-02,.3369431E-02,.3930153E-02,.4311858E-02,& - & .4569900E-02,.4708801E-02,.4723164E-02,.4542339E-02,.3355283E-02,& - & .1679110E-02,.2762441E-02,.3217170E-02,.3511424E-02,.3699441E-02,& - & .3807111E-02,.3820305E-02,.3685883E-02,.2768596E-02,.1718111E-02,& - & .2820629E-02,.3280981E-02,.3579835E-02,.3771324E-02,.3877601E-02,& - & .3885055E-02,.3740150E-02,.2792302E-02,.1759096E-02,.2880777E-02,& - & .3347449E-02,.3654997E-02,.3849489E-02,.3952528E-02,.3955472E-02,& - & .3800453E-02,.2822088E-02,.1804159E-02,.2943869E-02,.3420297E-02,& - & .3734906E-02,.3934456E-02,.4035234E-02,.4031563E-02,.3866511E-02,& - & .2856445E-02,.1852018E-02,.3014249E-02,.3500208E-02,.3821348E-02,& - & .4026208E-02,.4126369E-02,.4113254E-02,.3937685E-02,.2897579E-02,& - & .1485209E-02,.2447369E-02,.2842719E-02,.3098235E-02,.3261684E-02,& - & .3343620E-02,.3333197E-02,.3190317E-02,.4072685E-02,.1522667E-02,& - & .2503774E-02,.2902412E-02,.3163342E-02,.3327673E-02,.3406943E-02,& - & .3392715E-02,.3239642E-02,.4013646E-02,.1562338E-02,.2561154E-02,& - & .2966329E-02,.3232897E-02,.3398043E-02,.3474218E-02,.3456041E-02,& - & .3293328E-02,.3960211E-02,.1605822E-02,.2619463E-02,.3035388E-02,& - & .3307311E-02,.3472770E-02,.3548127E-02,.3523210E-02,.3351454E-02,& - & .3918895E-02,.1652396E-02,.2684419E-02,.3109623E-02,.3386474E-02,& - & .3553371E-02,.3627950E-02,.3594923E-02,.3414383E-02,.3895295E-02/ - - data absa(451:585, 4) / & - & .1327826E-02,.2178249E-02,.2523484E-02,.2748178E-02,.2891129E-02,& - & .2953926E-02,.2925626E-02,.2774151E-02,.5032627E-02,.1363836E-02,& - & .2231507E-02,.2582331E-02,.2811256E-02,.2953861E-02,.3013652E-02,& - & .2982332E-02,.2820761E-02,.4894171E-02,.1402555E-02,.2284583E-02,& - & .2644926E-02,.2877676E-02,.3020940E-02,.3077742E-02,.3041427E-02,& - & .2870356E-02,.4763815E-02,.1444850E-02,.2341577E-02,.2711315E-02,& - & .2948500E-02,.3091276E-02,.3147103E-02,.3103922E-02,.2923523E-02,& - & .4657359E-02,.1491126E-02,.2405746E-02,.2783605E-02,.3023985E-02,& - & .3167614E-02,.3221278E-02,.3170403E-02,.2981808E-02,.4593950E-02,& - & .1198258E-02,.1938520E-02,.2240507E-02,.2433881E-02,.2549827E-02,& - & .2596355E-02,.2561600E-02,.2410177E-02,.5165038E-02,.1231984E-02,& - & .1988536E-02,.2296997E-02,.2493517E-02,.2610218E-02,.2654628E-02,& - & .2615348E-02,.2452955E-02,.4998695E-02,.1267303E-02,.2040113E-02,& - & .2355817E-02,.2557194E-02,.2673983E-02,.2716145E-02,.2670737E-02,& - & .2497659E-02,.4849281E-02,.1307299E-02,.2095435E-02,.2418826E-02,& - & .2623945E-02,.2740846E-02,.2781831E-02,.2728441E-02,.2545893E-02,& - & .4735365E-02,.1350768E-02,.2157279E-02,.2487383E-02,.2694912E-02,& - & .2813081E-02,.2851205E-02,.2790976E-02,.2599947E-02,.4638902E-02,& - & .1094611E-02,.1729442E-02,.1987775E-02,.2148646E-02,.2243224E-02,& - & .2274670E-02,.2235199E-02,.2090113E-02,.4614858E-02,.1125402E-02,& - & .1775981E-02,.2041820E-02,.2205584E-02,.2300560E-02,.2330200E-02,& - & .2284917E-02,.2128857E-02,.4463987E-02,.1159259E-02,.1824840E-02,& - & .2098113E-02,.2265637E-02,.2360409E-02,.2388227E-02,.2336076E-02,& - & .2169572E-02,.4338182E-02,.1196616E-02,.1877338E-02,.2157749E-02,& - & .2328747E-02,.2423999E-02,.2448955E-02,.2390335E-02,.2214290E-02,& - & .4232022E-02,.1237500E-02,.1937731E-02,.2222832E-02,.2395916E-02,& - & .2492122E-02,.2513855E-02,.2450198E-02,.2264343E-02,.4147518E-02/ - - data absa( 1:180, 5) / & - & .7569383E-01,.7127726E-01,.7072055E-01,.7167894E-01,.7293550E-01,& - & .7244916E-01,.7056707E-01,.6926245E-01,.7313178E-01,.7613347E-01,& - & .7151997E-01,.7077247E-01,.7153549E-01,.7263614E-01,.7201405E-01,& - & .7009892E-01,.6889573E-01,.7285660E-01,.7647835E-01,.7168221E-01,& - & .7076014E-01,.7134341E-01,.7231870E-01,.7159794E-01,.6969923E-01,& - & .6859261E-01,.7264748E-01,.7670016E-01,.7175750E-01,.7068442E-01,& - & .7110712E-01,.7197697E-01,.7120664E-01,.6933990E-01,.6836243E-01,& - & .7255382E-01,.7691373E-01,.7183982E-01,.7062341E-01,.7088895E-01,& - & .7164992E-01,.7087382E-01,.6904623E-01,.6822798E-01,.7257501E-01,& - & .7421380E-01,.7089850E-01,.7145266E-01,.7330346E-01,.7466460E-01,& - & .7395589E-01,.7188620E-01,.7007745E-01,.7342812E-01,.7470315E-01,& - & .7115943E-01,.7149768E-01,.7312749E-01,.7437682E-01,.7354337E-01,& - & .7146237E-01,.6973763E-01,.7320381E-01,.7511576E-01,.7137057E-01,& - & .7150213E-01,.7293552E-01,.7408060E-01,.7316493E-01,.7110190E-01,& - & .6944710E-01,.7305691E-01,.7543079E-01,.7151417E-01,.7146139E-01,& - & .7272686E-01,.7376978E-01,.7280501E-01,.7076206E-01,.6923458E-01,& - & .7300795E-01,.7568786E-01,.7161383E-01,.7139697E-01,.7250907E-01,& - & .7343069E-01,.7248294E-01,.7048791E-01,.6909555E-01,.7306492E-01,& - & .7230673E-01,.7021426E-01,.7189722E-01,.7451771E-01,.7579082E-01,& - & .7503288E-01,.7282416E-01,.7049154E-01,.7299906E-01,.7286315E-01,& - & .7051801E-01,.7197408E-01,.7438907E-01,.7552182E-01,.7466506E-01,& - & .7245855E-01,.7016762E-01,.7281308E-01,.7332177E-01,.7075910E-01,& - & .7199437E-01,.7424541E-01,.7524477E-01,.7430774E-01,.7210437E-01,& - & .6988899E-01,.7270099E-01,.7375460E-01,.7098234E-01,.7200912E-01,& - & .7408957E-01,.7497762E-01,.7399034E-01,.7179310E-01,.6966381E-01,& - & .7266033E-01,.7410607E-01,.7113688E-01,.7196716E-01,.7387325E-01,& - & .7467008E-01,.7369947E-01,.7152362E-01,.6950511E-01,.7269904E-01,& - & .7006148E-01,.6923816E-01,.7203176E-01,.7518932E-01,.7630010E-01,& - & .7558723E-01,.7324666E-01,.7030687E-01,.7173847E-01,.7070776E-01,& - & .6960480E-01,.7215580E-01,.7510526E-01,.7608714E-01,.7528596E-01,& - & .7291553E-01,.7001785E-01,.7160799E-01,.7124096E-01,.6989489E-01,& - & .7221590E-01,.7501608E-01,.7584481E-01,.7498936E-01,.7259196E-01,& - & .6976034E-01,.7152087E-01,.7170772E-01,.7013752E-01,.7222754E-01,& - & .7487010E-01,.7559690E-01,.7471465E-01,.7231022E-01,.6954421E-01,& - & .7149408E-01,.7217297E-01,.7036437E-01,.7224475E-01,.7470987E-01,& - & .7536578E-01,.7448130E-01,.7207643E-01,.6939518E-01,.7153955E-01/ - - data absa(181:315, 5) / & - & .6746543E-01,.6789511E-01,.7175811E-01,.7512073E-01,.7623306E-01,& - & .7554875E-01,.7299624E-01,.6947460E-01,.6972139E-01,.6817808E-01,& - & .6831863E-01,.7191880E-01,.7511721E-01,.7607693E-01,.7533587E-01,& - & .7272951E-01,.6921640E-01,.6962219E-01,.6878127E-01,.6866239E-01,& - & .7201451E-01,.7507768E-01,.7588347E-01,.7512346E-01,.7245380E-01,& - & .6898486E-01,.6955882E-01,.6931769E-01,.6894903E-01,.7206127E-01,& - & .7499506E-01,.7568911E-01,.7490453E-01,.7221264E-01,.6878897E-01,& - & .6955676E-01,.6984062E-01,.6921967E-01,.7210380E-01,.7490218E-01,& - & .7552190E-01,.7471412E-01,.7202114E-01,.6866058E-01,.6962597E-01,& - & .6453797E-01,.6619435E-01,.7096321E-01,.7435120E-01,.7557506E-01,& - & .7489358E-01,.7213608E-01,.6797549E-01,.6697223E-01,.6531448E-01,& - & .6667806E-01,.7120136E-01,.7443855E-01,.7550608E-01,.7477578E-01,& - & .7192188E-01,.6776652E-01,.6691692E-01,.6599601E-01,.6708647E-01,& - & .7137864E-01,.7446953E-01,.7539664E-01,.7463387E-01,.7169803E-01,& - & .6757635E-01,.6690442E-01,.6658455E-01,.6741621E-01,.7148953E-01,& - & .7446547E-01,.7527439E-01,.7447360E-01,.7150646E-01,.6741051E-01,& - & .6692725E-01,.6710838E-01,.6769670E-01,.7154133E-01,.7442810E-01,& - & .7515746E-01,.7430715E-01,.7133898E-01,.6729366E-01,.6700931E-01,& - & .6127817E-01,.6414812E-01,.6958749E-01,.7293419E-01,.7429145E-01,& - & .7361146E-01,.7059124E-01,.6583890E-01,.6355716E-01,.6212572E-01,& - & .6469369E-01,.6993766E-01,.7312422E-01,.7433484E-01,.7357556E-01,& - & .7045275E-01,.6569828E-01,.6357688E-01,.6288706E-01,.6516584E-01,& - & .7021271E-01,.7326619E-01,.7432982E-01,.7348213E-01,.7031560E-01,& - & .6555824E-01,.6360213E-01,.6354801E-01,.6556305E-01,.7040342E-01,& - & .7334105E-01,.7430526E-01,.7337063E-01,.7018757E-01,.6542809E-01,& - & .6365427E-01,.6412664E-01,.6589381E-01,.7053384E-01,.7337186E-01,& - & .7426386E-01,.7326847E-01,.7006536E-01,.6533352E-01,.6375247E-01/ - - data absa(316:450, 5) / & - & .5769446E-01,.6178260E-01,.6765439E-01,.7096937E-01,.7236097E-01,& - & .7162253E-01,.6841692E-01,.6322137E-01,.5970130E-01,.5863799E-01,& - & .6240216E-01,.6811545E-01,.7126851E-01,.7252091E-01,.7168532E-01,& - & .6838432E-01,.6313347E-01,.5975507E-01,.5948073E-01,.6294022E-01,& - & .6847433E-01,.7150605E-01,.7262755E-01,.7166820E-01,.6832826E-01,& - & .6301598E-01,.5980255E-01,.6019384E-01,.6338337E-01,.6874609E-01,& - & .7165133E-01,.7270983E-01,.7163959E-01,.6825300E-01,.6292421E-01,& - & .5988086E-01,.6082893E-01,.6376171E-01,.6894902E-01,.7174796E-01,& - & .7275284E-01,.7161814E-01,.6819849E-01,.6284853E-01,.5997885E-01,& - & .5384218E-01,.5913297E-01,.6512641E-01,.6847022E-01,.6981558E-01,& - & .6898244E-01,.6574451E-01,.6014063E-01,.5493742E-01,.5486164E-01,& - & .5981373E-01,.6568933E-01,.6889734E-01,.7011656E-01,.6915288E-01,& - & .6580592E-01,.6008501E-01,.5501675E-01,.5576632E-01,.6040455E-01,& - & .6615529E-01,.6921938E-01,.7034252E-01,.6924287E-01,.6580255E-01,& - & .6001888E-01,.5509485E-01,.5653718E-01,.6090010E-01,.6649772E-01,& - & .6944333E-01,.7051698E-01,.6931819E-01,.6580285E-01,.5995294E-01,& - & .5518924E-01,.5724006E-01,.6133632E-01,.6675529E-01,.6962363E-01,& - & .7062688E-01,.6937140E-01,.6580880E-01,.5991082E-01,.5530789E-01,& - & .4986911E-01,.5625720E-01,.6219195E-01,.6550333E-01,.6673087E-01,& - & .6585114E-01,.6260934E-01,.5664518E-01,.4665462E-01,.5094960E-01,& - & .5701871E-01,.6284240E-01,.6603147E-01,.6716332E-01,.6612920E-01,& - & .6275302E-01,.5663929E-01,.4676883E-01,.5188210E-01,.5764984E-01,& - & .6336343E-01,.6646529E-01,.6749570E-01,.6632743E-01,.6282719E-01,& - & .5662832E-01,.4689733E-01,.5269455E-01,.5818682E-01,.6376950E-01,& - & .6678498E-01,.6774711E-01,.6647465E-01,.6289082E-01,.5661653E-01,& - & .4705226E-01,.5340814E-01,.5863202E-01,.6410648E-01,.6704487E-01,& - & .6795408E-01,.6661171E-01,.6295124E-01,.5663255E-01,.4724050E-01/ - - data absa(451:585, 5) / & - & .4634040E-01,.5350954E-01,.5924519E-01,.6235764E-01,.6342928E-01,& - & .6250075E-01,.5915701E-01,.5294180E-01,.3981576E-01,.4736892E-01,& - & .5426407E-01,.5988551E-01,.6297853E-01,.6392000E-01,.6284030E-01,& - & .5933938E-01,.5297399E-01,.3998733E-01,.4826061E-01,.5489369E-01,& - & .6040498E-01,.6345651E-01,.6430714E-01,.6308766E-01,.5949295E-01,& - & .5300748E-01,.4016986E-01,.4903376E-01,.5542677E-01,.6085024E-01,& - & .6383044E-01,.6465029E-01,.6331517E-01,.5962492E-01,.5307512E-01,& - & .4039950E-01,.4974119E-01,.5589358E-01,.6123797E-01,.6415006E-01,& - & .6494753E-01,.6353101E-01,.5976611E-01,.5317271E-01,.4065617E-01,& - & .4271897E-01,.5052183E-01,.5599851E-01,.5891678E-01,.5984422E-01,& - & .5881804E-01,.5542417E-01,.4913608E-01,.3713988E-01,.4368596E-01,& - & .5124809E-01,.5664483E-01,.5957881E-01,.6039071E-01,.5919218E-01,& - & .5567250E-01,.4923797E-01,.3723585E-01,.4453270E-01,.5188770E-01,& - & .5720401E-01,.6010232E-01,.6087078E-01,.5953237E-01,.5588506E-01,& - & .4936407E-01,.3745797E-01,.4529021E-01,.5243444E-01,.5768876E-01,& - & .6053783E-01,.6126963E-01,.5984905E-01,.5610497E-01,.4950780E-01,& - & .3755909E-01,.4600687E-01,.5293281E-01,.5813232E-01,.6093595E-01,& - & .6163456E-01,.6016722E-01,.5635091E-01,.4968371E-01,.3773583E-01,& - & .3908364E-01,.4730786E-01,.5250316E-01,.5524959E-01,.5601420E-01,& - & .5485012E-01,.5154058E-01,.4532019E-01,.3566372E-01,.3998663E-01,& - & .4803344E-01,.5319099E-01,.5592987E-01,.5663652E-01,.5530572E-01,& - & .5183777E-01,.4553398E-01,.3583037E-01,.4078498E-01,.4865307E-01,& - & .5379331E-01,.5649229E-01,.5715869E-01,.5574035E-01,.5214488E-01,& - & .4574777E-01,.3594123E-01,.4154329E-01,.4922239E-01,.5434666E-01,& - & .5701428E-01,.5763600E-01,.5616885E-01,.5247198E-01,.4597428E-01,& - & .3604552E-01,.4229775E-01,.4978726E-01,.5486411E-01,.5751694E-01,& - & .5809005E-01,.5659205E-01,.5281871E-01,.4623884E-01,.3624776E-01/ - - data absa( 1:180, 6) / & - & .4846620E+00,.4254449E+00,.3666979E+00,.3085003E+00,.2601346E+00,& - & .2464956E+00,.2660087E+00,.3021063E+00,.3287759E+00,.4745246E+00,& - & .4166752E+00,.3592695E+00,.3025580E+00,.2553943E+00,.2432268E+00,& - & .2629249E+00,.2987363E+00,.3245474E+00,.4658709E+00,.4092568E+00,& - & .3530642E+00,.2977163E+00,.2515626E+00,.2405793E+00,.2602783E+00,& - & .2957536E+00,.3209745E+00,.4575145E+00,.4020922E+00,.3470681E+00,& - & .2930793E+00,.2481591E+00,.2381801E+00,.2579191E+00,.2931017E+00,& - & .3178371E+00,.4497966E+00,.3954548E+00,.3415131E+00,.2891031E+00,& - & .2456319E+00,.2359968E+00,.2560087E+00,.2910169E+00,.3153507E+00,& - & .5233277E+00,.4592284E+00,.3955317E+00,.3326601E+00,.2881387E+00,& - & .2814594E+00,.3054605E+00,.3475919E+00,.3858173E+00,.5126637E+00,& - & .4500477E+00,.3878258E+00,.3267077E+00,.2828332E+00,.2774387E+00,& - & .3014139E+00,.3430855E+00,.3803776E+00,.5032811E+00,.4419694E+00,& - & .3810629E+00,.3215530E+00,.2784520E+00,.2739908E+00,.2977829E+00,& - & .3391699E+00,.3757057E+00,.4943912E+00,.4343294E+00,.3746578E+00,& - & .3166441E+00,.2747404E+00,.2708931E+00,.2946970E+00,.3358529E+00,& - & .3717479E+00,.4856925E+00,.4268266E+00,.3684341E+00,.3122038E+00,& - & .2717769E+00,.2679905E+00,.2921861E+00,.3332832E+00,.3686250E+00,& - & .5659721E+00,.4964838E+00,.4273442E+00,.3613333E+00,.3229778E+00,& - & .3207717E+00,.3487909E+00,.3970188E+00,.4483696E+00,.5545946E+00,& - & .4866491E+00,.4190737E+00,.3544937E+00,.3171184E+00,.3157821E+00,& - & .3434204E+00,.3913987E+00,.4416557E+00,.5441901E+00,.4776455E+00,& - & .4115043E+00,.3481950E+00,.3119787E+00,.3113749E+00,.3389006E+00,& - & .3865528E+00,.4358447E+00,.5345476E+00,.4693294E+00,.4045767E+00,& - & .3427926E+00,.3075766E+00,.3073312E+00,.3350898E+00,.3825859E+00,& - & .4311541E+00,.5246854E+00,.4609334E+00,.3978727E+00,.3380061E+00,& - & .3038003E+00,.3036818E+00,.3320521E+00,.3795333E+00,.4274614E+00,& - & .6114156E+00,.5360856E+00,.4610841E+00,.3944939E+00,.3631225E+00,& - & .3640797E+00,.3957193E+00,.4512458E+00,.5140119E+00,.5990211E+00,& - & .5253614E+00,.4520735E+00,.3868300E+00,.3563118E+00,.3576976E+00,& - & .3893012E+00,.4443146E+00,.5057705E+00,.5878031E+00,.5156587E+00,& - & .4439389E+00,.3797822E+00,.3504051E+00,.3520245E+00,.3838216E+00,& - & .4383993E+00,.4987384E+00,.5771932E+00,.5065469E+00,.4365968E+00,& - & .3737334E+00,.3451671E+00,.3469143E+00,.3791776E+00,.4335158E+00,& - & .4929659E+00,.5672493E+00,.4980854E+00,.4298759E+00,.3686864E+00,& - & .3406738E+00,.3425037E+00,.3753823E+00,.4296076E+00,.4882770E+00/ - - data absa(181:315, 6) / & - & .6599457E+00,.5784248E+00,.4971773E+00,.4337450E+00,.4071444E+00,& - & .4110564E+00,.4472427E+00,.5099709E+00,.5830348E+00,.6468482E+00,& - & .5670871E+00,.4876631E+00,.4250777E+00,.3993382E+00,.4031458E+00,& - & .4395792E+00,.5018776E+00,.5735256E+00,.6348396E+00,.5566698E+00,& - & .4790978E+00,.4172804E+00,.3925206E+00,.3961110E+00,.4330389E+00,& - & .4948939E+00,.5653109E+00,.6234166E+00,.5469278E+00,.4713504E+00,& - & .4102887E+00,.3864066E+00,.3900014E+00,.4273461E+00,.4889966E+00,& - & .5583254E+00,.6128604E+00,.5379244E+00,.4642610E+00,.4042901E+00,& - & .3809946E+00,.3847891E+00,.4225472E+00,.4840732E+00,.5525507E+00,& - & .7118405E+00,.6237026E+00,.5373473E+00,.4788483E+00,.4552052E+00,& - & .4622830E+00,.5030364E+00,.5735317E+00,.6569249E+00,.6980451E+00,& - & .6117423E+00,.5269042E+00,.4690257E+00,.4461057E+00,.4528737E+00,& - & .4940744E+00,.5641178E+00,.6458719E+00,.6851401E+00,.6005735E+00,& - & .5173938E+00,.4602048E+00,.4380661E+00,.4445391E+00,.4863645E+00,& - & .5558444E+00,.6361244E+00,.6731826E+00,.5903092E+00,.5088902E+00,& - & .4521990E+00,.4308774E+00,.4373808E+00,.4795420E+00,.5488504E+00,& - & .6279339E+00,.6618869E+00,.5806518E+00,.5011956E+00,.4451372E+00,& - & .4243261E+00,.4313958E+00,.4738124E+00,.5429837E+00,.6210544E+00,& - & .7668972E+00,.6717524E+00,.5822052E+00,.5289402E+00,.5074279E+00,& - & .5174762E+00,.5633483E+00,.6412958E+00,.7351146E+00,.7523724E+00,& - & .6591380E+00,.5705110E+00,.5178052E+00,.4967826E+00,.5066462E+00,& - & .5528830E+00,.6302350E+00,.7222090E+00,.7385919E+00,.6472212E+00,& - & .5598496E+00,.5075245E+00,.4872782E+00,.4974170E+00,.5435990E+00,& - & .6206660E+00,.7110675E+00,.7257857E+00,.6361589E+00,.5503268E+00,& - & .4984685E+00,.4786719E+00,.4893603E+00,.5354629E+00,.6125751E+00,& - & .7016399E+00,.7138973E+00,.6259486E+00,.5417002E+00,.4905437E+00,& - & .4710327E+00,.4822383E+00,.5286586E+00,.6057803E+00,.6935878E+00/ - - data absa(316:450, 6) / & - & .8249134E+00,.7223579E+00,.6318367E+00,.5828461E+00,.5642052E+00,& - & .5774889E+00,.6274321E+00,.7112179E+00,.8154752E+00,.8094743E+00,& - & .7089425E+00,.6188253E+00,.5703294E+00,.5519242E+00,.5651410E+00,& - & .6152177E+00,.6988740E+00,.8012054E+00,.7948100E+00,.6962635E+00,& - & .6071335E+00,.5587642E+00,.5408447E+00,.5546817E+00,.6044782E+00,& - & .6883629E+00,.7888678E+00,.7814861E+00,.6847483E+00,.5966332E+00,& - & .5488036E+00,.5307506E+00,.5452968E+00,.5952041E+00,.6791251E+00,& - & .7781169E+00,.7689261E+00,.6739251E+00,.5871415E+00,.5399440E+00,& - & .5219107E+00,.5368668E+00,.5871449E+00,.6714540E+00,.7691532E+00,& - & .8852145E+00,.7750456E+00,.6871055E+00,.6408984E+00,.6254709E+00,& - & .6421647E+00,.6941504E+00,.7835789E+00,.8985979E+00,.8691028E+00,& - & .7609767E+00,.6728330E+00,.6267061E+00,.6112664E+00,.6281600E+00,& - & .6803225E+00,.7701312E+00,.8830032E+00,.8539650E+00,.7478668E+00,& - & .6598673E+00,.6140672E+00,.5985796E+00,.6161528E+00,.6684674E+00,& - & .7583442E+00,.8692469E+00,.8400620E+00,.7358241E+00,.6484499E+00,& - & .6030312E+00,.5871483E+00,.6051785E+00,.6578534E+00,.7481252E+00,& - & .8573340E+00,.8267308E+00,.7243453E+00,.6382877E+00,.5930271E+00,& - & .5773599E+00,.5955257E+00,.6486068E+00,.7393848E+00,.8471526E+00,& - & .9457456E+00,.8285939E+00,.7451511E+00,.7019917E+00,.6899693E+00,& - & .7089637E+00,.7625561E+00,.8572460E+00,.9824613E+00,.9291323E+00,& - & .8136971E+00,.7298541E+00,.6864425E+00,.6740084E+00,.6934007E+00,& - & .7472875E+00,.8425945E+00,.9655705E+00,.9139136E+00,.8002614E+00,& - & .7162229E+00,.6723573E+00,.6598915E+00,.6797955E+00,.7340436E+00,& - & .8294611E+00,.9506098E+00,.8996396E+00,.7878323E+00,.7040173E+00,& - & .6600638E+00,.6474290E+00,.6677087E+00,.7222527E+00,.8180613E+00,& - & .9373243E+00,.8863343E+00,.7763696E+00,.6928464E+00,.6489803E+00,& - & .6362699E+00,.6568098E+00,.7118980E+00,.8079921E+00,.9257131E+00/ - - data absa(451:585, 6) / & - & .9984509E+00,.8767023E+00,.7981236E+00,.7590051E+00,.7500479E+00,& - & .7704148E+00,.8258274E+00,.9236821E+00,.1057116E+01,.9825580E+00,& - & .8620354E+00,.7830513E+00,.7424078E+00,.7334532E+00,.7542144E+00,& - & .8101460E+00,.9086138E+00,.1040043E+01,.9678310E+00,.8486729E+00,& - & .7694638E+00,.7279026E+00,.7187504E+00,.7400787E+00,.7961034E+00,& - & .8951540E+00,.1024689E+01,.9541401E+00,.8363966E+00,.7569500E+00,& - & .7151152E+00,.7053524E+00,.7272043E+00,.7836771E+00,.8829254E+00,& - & .1010610E+01,.9409238E+00,.8247336E+00,.7452605E+00,.7034806E+00,& - & .6932724E+00,.7155504E+00,.7725713E+00,.8720814E+00,.9982035E+00,& - & .1051209E+01,.9265442E+00,.8532619E+00,.8179703E+00,.8119095E+00,& - & .8341371E+00,.8903756E+00,.9888756E+00,.1095956E+01,.1036235E+01,& - & .9123511E+00,.8382101E+00,.8010032E+00,.7947542E+00,.8176096E+00,& - & .8740008E+00,.9731309E+00,.1080421E+01,.1022216E+01,.8989889E+00,& - & .8242808E+00,.7860446E+00,.7790076E+00,.8024437E+00,.8593689E+00,& - & .9586866E+00,.1065303E+01,.1008831E+01,.8865583E+00,.8113619E+00,& - & .7726307E+00,.7650415E+00,.7885957E+00,.8460657E+00,.9457463E+00,& - & .1053284E+01,.9956237E+00,.8746029E+00,.7991663E+00,.7602091E+00,& - & .7523241E+00,.7758775E+00,.8338469E+00,.9341164E+00,.1042323E+01,& - & .1103094E+01,.9779325E+00,.9101471E+00,.8783812E+00,.8752086E+00,& - & .8997168E+00,.9549270E+00,.1052106E+01,.1130777E+01,.1089042E+01,& - & .9638679E+00,.8946771E+00,.8612419E+00,.8571856E+00,.8822649E+00,& - & .9380724E+00,.1035137E+01,.1114750E+01,.1075742E+01,.9508309E+00,& - & .8802630E+00,.8459304E+00,.8411000E+00,.8660581E+00,.9224269E+00,& - & .1019820E+01,.1101053E+01,.1062410E+01,.9382231E+00,.8666081E+00,& - & .8315446E+00,.8263075E+00,.8509882E+00,.9079071E+00,.1005967E+01,& - & .1089316E+01,.1048876E+01,.9255641E+00,.8536249E+00,.8179717E+00,& - & .8126191E+00,.8371360E+00,.8945910E+00,.9933411E+00,.1078307E+01/ - -! the array absb(235,6) (kb(5,13:59,6)) contains absorption coefs at -! the 16 chosen g-values for a range of pressure levels < ~100mb and -! temperatures. the first index in the array, jt, which runs from 1 to 5, -! corresponds to different temperatures. more specifically, jt = 3 means -! that the data are for the reference temperature tref for this pressure -! level, jt = 2 refers to the temperature tref-15, jt = 1 is for -! tref-30, jt = 4 is for tref+15, and jt = 5 is for tref+30. -! the second index, jp, runs from 13 to 59 and refers to the jpth -! reference pressure level (see taumol.f for the value of these -! pressure levels in mb). the third index, ig, goes from 1 to 6, -! and tells us which g-interval the absorption coefficients are for. -! ----------------------------------------------------------------- - - data absb( 1:120, 1) / & - & .2455108E-02,.2494284E-02,.2520068E-02,.2540222E-02,.2547453E-02,& - & .2053818E-02,.2083023E-02,.2101215E-02,.2116145E-02,.2123172E-02,& - & .1734639E-02,.1758680E-02,.1772416E-02,.1781767E-02,.1788224E-02,& - & .1482314E-02,.1503678E-02,.1512899E-02,.1519630E-02,.1524757E-02,& - & .1284745E-02,.1304855E-02,.1312793E-02,.1316311E-02,.1318005E-02,& - & .1129086E-02,.1146597E-02,.1156453E-02,.1156435E-02,.1156401E-02,& - & .9921713E-03,.1008990E-02,.1018291E-02,.1020213E-02,.1018365E-02,& - & .8471850E-03,.8618578E-03,.8693996E-03,.8719597E-03,.8699465E-03,& - & .7178765E-03,.7312448E-03,.7368809E-03,.7383122E-03,.7377363E-03,& - & .6069271E-03,.6192294E-03,.6230026E-03,.6249060E-03,.6240653E-03,& - & .5123512E-03,.5240166E-03,.5274574E-03,.5289784E-03,.5283974E-03,& - & .4327672E-03,.4433865E-03,.4469695E-03,.4481477E-03,.4479432E-03,& - & .3651769E-03,.3741862E-03,.3784929E-03,.3797155E-03,.3799202E-03,& - & .3081802E-03,.3145936E-03,.3193752E-03,.3209357E-03,.3216224E-03,& - & .2600564E-03,.2641825E-03,.2692918E-03,.2713207E-03,.2719491E-03,& - & .2189889E-03,.2226081E-03,.2271490E-03,.2294557E-03,.2302383E-03,& - & .1846009E-03,.1885356E-03,.1916569E-03,.1944705E-03,.1953784E-03,& - & .1569872E-03,.1601747E-03,.1622966E-03,.1649634E-03,.1666332E-03,& - & .1341940E-03,.1363878E-03,.1381676E-03,.1401546E-03,.1421984E-03,& - & .1150202E-03,.1162012E-03,.1182134E-03,.1193516E-03,.1212431E-03,& - & .9900466E-04,.9989409E-04,.1008343E-03,.1022803E-03,.1033529E-03,& - & .8523323E-04,.8592559E-04,.8646982E-04,.8752563E-04,.8834547E-04,& - & .7355247E-04,.7410040E-04,.7455079E-04,.7505627E-04,.7561834E-04,& - & .6386391E-04,.6399156E-04,.6452062E-04,.6507966E-04,.6511678E-04/ - - data absb(121:235, 1) / & - & .5378377E-04,.5383807E-04,.5419748E-04,.5461584E-04,.5475942E-04,& - & .4529476E-04,.4536607E-04,.4551849E-04,.4582121E-04,.4594236E-04,& - & .3805002E-04,.3835500E-04,.3837164E-04,.3841587E-04,.3870224E-04,& - & .3134721E-04,.3153158E-04,.3158800E-04,.3159241E-04,.3173210E-04,& - & .2572678E-04,.2581660E-04,.2592636E-04,.2593449E-04,.2604293E-04,& - & .2111340E-04,.2114297E-04,.2123906E-04,.2126974E-04,.2132702E-04,& - & .1724042E-04,.1721678E-04,.1726492E-04,.1735856E-04,.1734777E-04,& - & .1400853E-04,.1398539E-04,.1400256E-04,.1407486E-04,.1407744E-04,& - & .1138599E-04,.1138052E-04,.1136754E-04,.1138325E-04,.1144462E-04,& - & .9234875E-05,.9228129E-05,.9225511E-05,.9219129E-05,.9274721E-05,& - & .7450018E-05,.7494669E-05,.7491514E-05,.7465424E-05,.7498018E-05,& - & .5987641E-05,.6060252E-05,.6077441E-05,.6062453E-05,.6062401E-05,& - & .4810640E-05,.4877970E-05,.4932441E-05,.4916522E-05,.4908248E-05,& - & .3869095E-05,.3916912E-05,.3981052E-05,.3989636E-05,.3985085E-05,& - & .3125584E-05,.3158316E-05,.3201951E-05,.3234304E-05,.3229423E-05,& - & .2526771E-05,.2539982E-05,.2565764E-05,.2606671E-05,.2620099E-05,& - & .2033741E-05,.2048230E-05,.2064945E-05,.2094217E-05,.2117279E-05,& - & .1636949E-05,.1651544E-05,.1664769E-05,.1682082E-05,.1707938E-05,& - & .1320644E-05,.1329014E-05,.1342957E-05,.1355072E-05,.1374367E-05,& - & .1063144E-05,.1069247E-05,.1082985E-05,.1092178E-05,.1104704E-05,& - & .8523022E-06,.8613254E-06,.8703544E-06,.8805758E-06,.8889748E-06,& - & .6821306E-06,.6939226E-06,.7000980E-06,.7103676E-06,.7161581E-06,& - & .5473000E-06,.5610035E-06,.5662359E-06,.5739016E-06,.5795604E-06/ - - data absb( 1:120, 2) / & - & .1286743E-01,.1298016E-01,.1307688E-01,.1314196E-01,.1318687E-01,& - & .1084483E-01,.1095286E-01,.1104372E-01,.1107916E-01,.1110333E-01,& - & .9173853E-02,.9249031E-02,.9308829E-02,.9349446E-02,.9373813E-02,& - & .7773824E-02,.7815445E-02,.7855507E-02,.7887027E-02,.7894494E-02,& - & .6635671E-02,.6658973E-02,.6677297E-02,.6693544E-02,.6694290E-02,& - & .5714053E-02,.5714835E-02,.5716276E-02,.5728622E-02,.5719424E-02,& - & .4953027E-02,.4935260E-02,.4928449E-02,.4921707E-02,.4912914E-02,& - & .4202051E-02,.4179936E-02,.4170445E-02,.4154196E-02,.4145879E-02,& - & .3546756E-02,.3522656E-02,.3509107E-02,.3496226E-02,.3483466E-02,& - & .2986324E-02,.2962134E-02,.2946586E-02,.2935316E-02,.2924589E-02,& - & .2520037E-02,.2493976E-02,.2477958E-02,.2467618E-02,.2459527E-02,& - & .2128530E-02,.2102617E-02,.2086920E-02,.2077359E-02,.2068955E-02,& - & .1796044E-02,.1774099E-02,.1757802E-02,.1748933E-02,.1740649E-02,& - & .1511042E-02,.1493208E-02,.1478896E-02,.1469321E-02,.1461744E-02,& - & .1272579E-02,.1259504E-02,.1246012E-02,.1235685E-02,.1229631E-02,& - & .1074471E-02,.1063160E-02,.1050792E-02,.1041724E-02,.1036092E-02,& - & .9106300E-03,.8993222E-03,.8888252E-03,.8805708E-03,.8768352E-03,& - & .7732921E-03,.7632043E-03,.7552638E-03,.7485823E-03,.7491950E-03,& - & .6597355E-03,.6512362E-03,.6451463E-03,.6404871E-03,.6392845E-03,& - & .5654918E-03,.5596233E-03,.5545424E-03,.5500160E-03,.5486305E-03,& - & .4880680E-03,.4838686E-03,.4792352E-03,.4746633E-03,.4742358E-03,& - & .4240329E-03,.4198366E-03,.4158480E-03,.4147475E-03,.4118226E-03,& - & .3707047E-03,.3670166E-03,.3635404E-03,.3627127E-03,.3598610E-03,& - & .3269270E-03,.3238737E-03,.3206578E-03,.3192890E-03,.3166364E-03/ - - data absb(121:235, 2) / & - & .2789970E-03,.2765079E-03,.2739652E-03,.2724815E-03,.2694007E-03,& - & .2383170E-03,.2362195E-03,.2338966E-03,.2321906E-03,.2293814E-03,& - & .2043421E-03,.2022653E-03,.1998851E-03,.1974199E-03,.1958820E-03,& - & .1703638E-03,.1685921E-03,.1664446E-03,.1644332E-03,.1632693E-03,& - & .1414648E-03,.1398222E-03,.1381078E-03,.1364105E-03,.1354620E-03,& - & .1171714E-03,.1160394E-03,.1146163E-03,.1132446E-03,.1124903E-03,& - & .9653894E-04,.9566019E-04,.9459747E-04,.9340503E-04,.9220628E-04,& - & .7932991E-04,.7856317E-04,.7774927E-04,.7682321E-04,.7581347E-04,& - & .6515421E-04,.6441758E-04,.6392018E-04,.6313941E-04,.6221003E-04,& - & .5347743E-04,.5297072E-04,.5245890E-04,.5184866E-04,.5107466E-04,& - & .4396154E-04,.4347687E-04,.4303733E-04,.4259063E-04,.4196826E-04,& - & .3615915E-04,.3568995E-04,.3529007E-04,.3492298E-04,.3444102E-04,& - & .2966497E-04,.2925157E-04,.2889217E-04,.2855828E-04,.2821985E-04,& - & .2430508E-04,.2403992E-04,.2370451E-04,.2340581E-04,.2311943E-04,& - & .1995845E-04,.1971625E-04,.1943619E-04,.1919411E-04,.1893202E-04,& - & .1630421E-04,.1613833E-04,.1595861E-04,.1573142E-04,.1549637E-04,& - & .1329543E-04,.1321689E-04,.1306432E-04,.1287719E-04,.1268925E-04,& - & .1082302E-04,.1082655E-04,.1071501E-04,.1058492E-04,.1042620E-04,& - & .8829908E-05,.8878449E-05,.8804000E-05,.8713675E-05,.8582871E-05,& - & .7229747E-05,.7274906E-05,.7243006E-05,.7161434E-05,.7060580E-05,& - & .5920720E-05,.5930473E-05,.5943800E-05,.5878317E-05,.5803165E-05,& - & .4850374E-05,.4842730E-05,.4872181E-05,.4827114E-05,.4773736E-05,& - & .3998381E-05,.3995704E-05,.4020867E-05,.3990354E-05,.3948657E-05/ - - data absb( 1:120, 3) / & - & .5002398E-01,.5100799E-01,.5223444E-01,.5366230E-01,.5534006E-01,& - & .4416861E-01,.4512229E-01,.4624963E-01,.4763751E-01,.4926106E-01,& - & .3889418E-01,.3989178E-01,.4102991E-01,.4233451E-01,.4377504E-01,& - & .3413273E-01,.3507125E-01,.3618746E-01,.3742424E-01,.3870722E-01,& - & .2995928E-01,.3086478E-01,.3189959E-01,.3307320E-01,.3425277E-01,& - & .2638019E-01,.2725271E-01,.2821585E-01,.2927539E-01,.3033342E-01,& - & .2335920E-01,.2414637E-01,.2503317E-01,.2599890E-01,.2699514E-01,& - & .2029208E-01,.2105095E-01,.2183638E-01,.2270657E-01,.2359078E-01,& - & .1752887E-01,.1822677E-01,.1893693E-01,.1971216E-01,.2049024E-01,& - & .1514301E-01,.1576265E-01,.1644949E-01,.1710856E-01,.1777047E-01,& - & .1307907E-01,.1369568E-01,.1429327E-01,.1484508E-01,.1540994E-01,& - & .1135002E-01,.1190407E-01,.1240533E-01,.1289830E-01,.1336006E-01,& - & .9861342E-02,.1032874E-01,.1078971E-01,.1119067E-01,.1159988E-01,& - & .8543786E-02,.8972343E-02,.9361670E-02,.9707599E-02,.1007270E-01,& - & .7399186E-02,.7765826E-02,.8086950E-02,.8410397E-02,.8722569E-02,& - & .6411375E-02,.6715139E-02,.6991916E-02,.7280002E-02,.7586032E-02,& - & .5526867E-02,.5785983E-02,.6041283E-02,.6303233E-02,.6579648E-02,& - & .4774311E-02,.4997352E-02,.5227375E-02,.5480339E-02,.5877541E-02,& - & .4116828E-02,.4325497E-02,.4545463E-02,.4770394E-02,.5153971E-02,& - & .3578769E-02,.3764998E-02,.3969666E-02,.4197341E-02,.4545465E-02,& - & .3124717E-02,.3305659E-02,.3500480E-02,.3709794E-02,.4038550E-02,& - & .2748728E-02,.2923454E-02,.3112152E-02,.3399419E-02,.3626701E-02,& - & .2422516E-02,.2586643E-02,.2766372E-02,.3049770E-02,.3276646E-02,& - & .2131791E-02,.2289101E-02,.2457066E-02,.2736600E-02,.2953943E-02/ - - data absb(121:235, 3) / & - & .1828665E-02,.1969373E-02,.2131950E-02,.2386197E-02,.2591184E-02,& - & .1565325E-02,.1696357E-02,.1846360E-02,.2083995E-02,.2278216E-02,& - & .1339532E-02,.1462299E-02,.1603891E-02,.1761979E-02,.2010098E-02,& - & .1123112E-02,.1231996E-02,.1361344E-02,.1506360E-02,.1731174E-02,& - & .9386379E-03,.1036085E-02,.1150679E-02,.1280160E-02,.1487488E-02,& - & .7829286E-03,.8681007E-03,.9712611E-03,.1088601E-02,.1279327E-02,& - & .6439906E-03,.7179533E-03,.8068447E-03,.9121069E-03,.1038346E-02,& - & .5251100E-03,.5895043E-03,.6665253E-03,.7582909E-03,.8728263E-03,& - & .4272101E-03,.4822133E-03,.5483728E-03,.6283465E-03,.7297410E-03,& - & .3455385E-03,.3919227E-03,.4490025E-03,.5186610E-03,.6080615E-03,& - & .2772875E-03,.3163585E-03,.3648993E-03,.4245665E-03,.5029312E-03,& - & .2215243E-03,.2545308E-03,.2950909E-03,.3456400E-03,.4140863E-03,& - & .1762697E-03,.2034714E-03,.2368499E-03,.2802197E-03,.3391266E-03,& - & .1409510E-03,.1632263E-03,.1911441E-03,.2283913E-03,.2789978E-03,& - & .1124638E-03,.1310401E-03,.1540205E-03,.1857656E-03,.2289863E-03,& - & .8954236E-04,.1047453E-03,.1237097E-03,.1505540E-03,.1870030E-03,& - & .7098317E-04,.8306387E-04,.9912454E-04,.1212505E-03,.1519558E-03,& - & .5681762E-04,.6665919E-04,.7982178E-04,.9805318E-04,.1239971E-03,& - & .4562520E-04,.5359104E-04,.6438194E-04,.7935790E-04,.1011203E-03,& - & .3653132E-04,.4295380E-04,.5170112E-04,.6400146E-04,.8208662E-04,& - & .2913090E-04,.3439039E-04,.4140146E-04,.5133409E-04,.6632514E-04,& - & .2332055E-04,.2755437E-04,.3319705E-04,.4115994E-04,.5350282E-04,& - & .1945717E-04,.2306888E-04,.2793905E-04,.3476686E-04,.4551954E-04/ - - data absb( 1:120, 4) / & - & .2878234E+00,.2961252E+00,.3050441E+00,.3147630E+00,.3253959E+00,& - & .2743822E+00,.2825368E+00,.2911238E+00,.3003062E+00,.3104320E+00,& - & .2632621E+00,.2715744E+00,.2807089E+00,.2905758E+00,.3014280E+00,& - & .2470711E+00,.2556028E+00,.2648564E+00,.2753382E+00,.2872254E+00,& - & .2312754E+00,.2397378E+00,.2488918E+00,.2593077E+00,.2714135E+00,& - & .2159198E+00,.2248574E+00,.2346644E+00,.2452257E+00,.2571951E+00,& - & .2025752E+00,.2115209E+00,.2212761E+00,.2319679E+00,.2443755E+00,& - & .1870918E+00,.1958476E+00,.2056213E+00,.2168964E+00,.2297077E+00,& - & .1719062E+00,.1808017E+00,.1908654E+00,.2024728E+00,.2155574E+00,& - & .1580850E+00,.1674409E+00,.1780281E+00,.1900585E+00,.2031710E+00,& - & .1462403E+00,.1558822E+00,.1666091E+00,.1789235E+00,.1922377E+00,& - & .1362161E+00,.1459406E+00,.1567969E+00,.1692597E+00,.1829005E+00,& - & .1274087E+00,.1370931E+00,.1484132E+00,.1609035E+00,.1746367E+00,& - & .1194990E+00,.1297509E+00,.1410742E+00,.1539492E+00,.1679681E+00,& - & .1123619E+00,.1230023E+00,.1347556E+00,.1477261E+00,.1617005E+00,& - & .1061193E+00,.1170526E+00,.1291360E+00,.1421656E+00,.1564595E+00,& - & .1006760E+00,.1119479E+00,.1241710E+00,.1376384E+00,.1522244E+00,& - & .9607904E-01,.1075948E+00,.1202361E+00,.1342448E+00,.1520624E+00,& - & .9236167E-01,.1042029E+00,.1173986E+00,.1321571E+00,.1502113E+00,& - & .8989190E-01,.1021932E+00,.1159955E+00,.1310628E+00,.1496169E+00,& - & .8834869E-01,.1013779E+00,.1156618E+00,.1310736E+00,.1499564E+00,& - & .8767587E-01,.1011140E+00,.1157497E+00,.1341003E+00,.1509449E+00,& - & .8642676E-01,.1002241E+00,.1151696E+00,.1339998E+00,.1509668E+00,& - & .8444357E-01,.9839768E-01,.1137899E+00,.1328639E+00,.1500538E+00/ - - data absb(121:235, 4) / & - & .8008552E-01,.9397404E-01,.1092312E+00,.1284086E+00,.1456923E+00,& - & .7606488E-01,.8974941E-01,.1049552E+00,.1241503E+00,.1414966E+00,& - & .7241439E-01,.8585292E-01,.1009126E+00,.1172255E+00,.1376072E+00,& - & .6737037E-01,.8040867E-01,.9512233E-01,.1111766E+00,.1313617E+00,& - & .6249839E-01,.7518420E-01,.8941538E-01,.1051429E+00,.1250058E+00,& - & .5796755E-01,.7023093E-01,.8399825E-01,.9941523E-01,.1191081E+00,& - & .5290880E-01,.6463286E-01,.7799108E-01,.9283777E-01,.1092238E+00,& - & .4784261E-01,.5904001E-01,.7178305E-01,.8613347E-01,.1019882E+00,& - & .4314406E-01,.5383664E-01,.6605552E-01,.7975409E-01,.9510036E-01,& - & .3853322E-01,.4870478E-01,.6029343E-01,.7337748E-01,.8815869E-01,& - & .3389054E-01,.4343173E-01,.5438033E-01,.6682346E-01,.8091510E-01,& - & .2963117E-01,.3852479E-01,.4883852E-01,.6062832E-01,.7400013E-01,& - & .2572970E-01,.3391246E-01,.4359826E-01,.5471276E-01,.6736039E-01,& - & .2233416E-01,.2991585E-01,.3901273E-01,.4954145E-01,.6156569E-01,& - & .1939210E-01,.2638719E-01,.3485100E-01,.4478336E-01,.5620570E-01,& - & .1668291E-01,.2307789E-01,.3098475E-01,.4031918E-01,.5116350E-01,& - & .1420262E-01,.2005395E-01,.2735039E-01,.3608786E-01,.4625548E-01,& - & .1217748E-01,.1754282E-01,.2430328E-01,.3256355E-01,.4217429E-01,& - & .1044921E-01,.1536327E-01,.2163899E-01,.2944083E-01,.3855156E-01,& - & .8884509E-02,.1335574E-01,.1918440E-01,.2646426E-01,.3516363E-01,& - & .7483675E-02,.1152870E-01,.1691180E-01,.2368487E-01,.3190062E-01,& - & .6305579E-02,.9961440E-02,.1489973E-01,.2122728E-01,.2897708E-01,& - & .5828592E-02,.9332797E-02,.1413857E-01,.2030539E-01,.2791717E-01/ - - data absb( 1:120, 5) / & - & .9803355E+01,.1002921E+02,.1022928E+02,.1041986E+02,.1060893E+02,& - & .8901187E+01,.9109354E+01,.9307795E+01,.9507481E+01,.9704484E+01,& - & .8037550E+01,.8238379E+01,.8440990E+01,.8639971E+01,.8841430E+01,& - & .7256235E+01,.7456728E+01,.7656282E+01,.7858569E+01,.8063361E+01,& - & .6549121E+01,.6747154E+01,.6948541E+01,.7154546E+01,.7363018E+01,& - & .5920127E+01,.6112982E+01,.6313644E+01,.6520192E+01,.6735708E+01,& - & .5391811E+01,.5564840E+01,.5751524E+01,.5963164E+01,.6187711E+01,& - & .4979063E+01,.5141211E+01,.5319204E+01,.5518536E+01,.5724852E+01,& - & .4685729E+01,.4829264E+01,.4999371E+01,.5176536E+01,.5377588E+01,& - & .4509733E+01,.4627971E+01,.4769025E+01,.4939138E+01,.5138382E+01,& - & .4441848E+01,.4547145E+01,.4654076E+01,.4777266E+01,.4966192E+01,& - & .4392672E+01,.4508636E+01,.4631472E+01,.4750610E+01,.4893241E+01,& - & .4379451E+01,.4509691E+01,.4639368E+01,.4771997E+01,.4917485E+01,& - & .4383266E+01,.4532070E+01,.4679856E+01,.4811910E+01,.4982307E+01,& - & .4373711E+01,.4538212E+01,.4701877E+01,.4859289E+01,.5032829E+01,& - & .4371956E+01,.4552831E+01,.4722242E+01,.4907609E+01,.5087424E+01,& - & .4332160E+01,.4518631E+01,.4697783E+01,.4891344E+01,.5092684E+01,& - & .4305857E+01,.4488111E+01,.4683919E+01,.4875401E+01,.5098906E+01,& - & .4247319E+01,.4442550E+01,.4629624E+01,.4824728E+01,.5055952E+01,& - & .4214744E+01,.4395695E+01,.4595960E+01,.4805492E+01,.5017792E+01,& - & .4194067E+01,.4374577E+01,.4586487E+01,.4793725E+01,.5028709E+01,& - & .4199133E+01,.4388763E+01,.4601898E+01,.4846199E+01,.5088486E+01,& - & .4205331E+01,.4415572E+01,.4636671E+01,.4889061E+01,.5185128E+01,& - & .4239611E+01,.4448023E+01,.4670143E+01,.4942226E+01,.5271353E+01/ - - data absb(121:235, 5) / & - & .4176844E+01,.4378265E+01,.4607587E+01,.4898813E+01,.5254033E+01,& - & .4099489E+01,.4293386E+01,.4533269E+01,.4877379E+01,.5230256E+01,& - & .4007521E+01,.4213195E+01,.4480775E+01,.4835666E+01,.5209135E+01,& - & .3883977E+01,.4090925E+01,.4376746E+01,.4733176E+01,.5114008E+01,& - & .3759955E+01,.3970704E+01,.4272560E+01,.4618469E+01,.4997992E+01,& - & .3631179E+01,.3846064E+01,.4161525E+01,.4505341E+01,.4888289E+01,& - & .3481107E+01,.3699160E+01,.4022359E+01,.4359341E+01,.4726661E+01,& - & .3305633E+01,.3543449E+01,.3873804E+01,.4204009E+01,.4566058E+01,& - & .3130039E+01,.3398800E+01,.3728888E+01,.4056038E+01,.4401957E+01,& - & .2968975E+01,.3253192E+01,.3573124E+01,.3904086E+01,.4239970E+01,& - & .2811010E+01,.3105040E+01,.3413054E+01,.3741891E+01,.4067138E+01,& - & .2663058E+01,.2951303E+01,.3256042E+01,.3581236E+01,.3900989E+01,& - & .2515451E+01,.2806289E+01,.3104377E+01,.3428028E+01,.3740708E+01,& - & .2378861E+01,.2672260E+01,.2967412E+01,.3283792E+01,.3592902E+01,& - & .2250954E+01,.2549314E+01,.2842896E+01,.3146414E+01,.3454348E+01,& - & .2126384E+01,.2425968E+01,.2718676E+01,.3012722E+01,.3313565E+01,& - & .2000566E+01,.2300064E+01,.2594150E+01,.2881717E+01,.3180487E+01,& - & .1893973E+01,.2183036E+01,.2478401E+01,.2762266E+01,.3053944E+01,& - & .1797191E+01,.2073967E+01,.2365713E+01,.2650269E+01,.2928594E+01,& - & .1699063E+01,.1967053E+01,.2254958E+01,.2539431E+01,.2812870E+01,& - & .1602483E+01,.1870209E+01,.2142381E+01,.2424027E+01,.2698355E+01,& - & .1508607E+01,.1774262E+01,.2038629E+01,.2313372E+01,.2585830E+01,& - & .1519868E+01,.1744553E+01,.1991354E+01,.2260467E+01,.2531035E+01/ - - data absb( 1:120, 6) / & - & .2781168E+03,.2745845E+03,.2712239E+03,.2678704E+03,.2644459E+03,& - & .2904946E+03,.2871655E+03,.2838470E+03,.2803941E+03,.2768948E+03,& - & .3022413E+03,.2989983E+03,.2955817E+03,.2921152E+03,.2885458E+03,& - & .3130565E+03,.3098089E+03,.3064324E+03,.3028900E+03,.2992469E+03,& - & .3228674E+03,.3196371E+03,.3162446E+03,.3126653E+03,.3089740E+03,& - & .3316375E+03,.3284418E+03,.3250265E+03,.3214442E+03,.3176680E+03,& - & .3390155E+03,.3360705E+03,.3328242E+03,.3291721E+03,.3252655E+03,& - & .3449713E+03,.3421655E+03,.3390332E+03,.3355221E+03,.3318374E+03,& - & .3493969E+03,.3468038E+03,.3437556E+03,.3405122E+03,.3368916E+03,& - & .3522054E+03,.3499115E+03,.3472051E+03,.3440347E+03,.3404337E+03,& - & .3535539E+03,.3513906E+03,.3491088E+03,.3465269E+03,.3430700E+03,& - & .3545730E+03,.3522557E+03,.3497503E+03,.3472267E+03,.3443498E+03,& - & .3550447E+03,.3525630E+03,.3499373E+03,.3472388E+03,.3443261E+03,& - & .3552526E+03,.3524843E+03,.3496510E+03,.3469402E+03,.3437094E+03,& - & .3555960E+03,.3526031E+03,.3495395E+03,.3465118E+03,.3432573E+03,& - & .3557797E+03,.3525640E+03,.3494123E+03,.3460217E+03,.3426940E+03,& - & .3564043E+03,.3530960E+03,.3498075E+03,.3463239E+03,.3427123E+03,& - & .3568211E+03,.3535487E+03,.3500420E+03,.3465557E+03,.3428692E+03,& - & .3576037E+03,.3541394E+03,.3507368E+03,.3471845E+03,.3434088E+03,& - & .3580188E+03,.3547035E+03,.3511129E+03,.3473748E+03,.3438292E+03,& - & .3581982E+03,.3548803E+03,.3511249E+03,.3474255E+03,.3435849E+03,& - & .3580668E+03,.3546083E+03,.3508286E+03,.3468622E+03,.3427171E+03,& - & .3579811E+03,.3542519E+03,.3503648E+03,.3462908E+03,.3414558E+03,& - & .3576096E+03,.3539086E+03,.3499965E+03,.3456525E+03,.3403969E+03/ - - data absb(121:235, 6) / & - & .3586604E+03,.3550335E+03,.3510399E+03,.3464481E+03,.3408584E+03,& - & .3598800E+03,.3563594E+03,.3522228E+03,.3469653E+03,.3413783E+03,& - & .3612682E+03,.3576057E+03,.3531275E+03,.3475159E+03,.3418607E+03,& - & .3631576E+03,.3595023E+03,.3547940E+03,.3491532E+03,.3434219E+03,& - & .3650737E+03,.3613720E+03,.3564614E+03,.3509635E+03,.3452500E+03,& - & .3670026E+03,.3632776E+03,.3582252E+03,.3527572E+03,.3469855E+03,& - & .3692557E+03,.3655325E+03,.3603844E+03,.3550208E+03,.3492473E+03,& - & .3718397E+03,.3678903E+03,.3626881E+03,.3574203E+03,.3517227E+03,& - & .3744095E+03,.3701124E+03,.3649258E+03,.3597189E+03,.3542337E+03,& - & .3767816E+03,.3723343E+03,.3673166E+03,.3620799E+03,.3567366E+03,& - & .3791321E+03,.3746009E+03,.3697970E+03,.3646097E+03,.3594172E+03,& - & .3813238E+03,.3769336E+03,.3722063E+03,.3670953E+03,.3619918E+03,& - & .3834849E+03,.3791057E+03,.3745237E+03,.3694845E+03,.3645086E+03,& - & .3854281E+03,.3811015E+03,.3766032E+03,.3716952E+03,.3667988E+03,& - & .3872332E+03,.3829179E+03,.3785031E+03,.3738180E+03,.3689635E+03,& - & .3889780E+03,.3847170E+03,.3803790E+03,.3758553E+03,.3711179E+03,& - & .3907123E+03,.3865429E+03,.3822340E+03,.3778545E+03,.3731887E+03,& - & .3921534E+03,.3881790E+03,.3839339E+03,.3796445E+03,.3751081E+03,& - & .3934377E+03,.3896848E+03,.3855532E+03,.3813151E+03,.3769936E+03,& - & .3947370E+03,.3911513E+03,.3871310E+03,.3829493E+03,.3787443E+03,& - & .3959555E+03,.3924751E+03,.3887103E+03,.3846245E+03,.3804545E+03,& - & .3971711E+03,.3937408E+03,.3901626E+03,.3862220E+03,.3821316E+03,& - & .3970289E+03,.3941655E+03,.3908061E+03,.3869572E+03,.3829149E+03/ - -! --- - data forref(1:3,1: 6) / .6585271E-05,.9433300E-05,.7977931E-04,& - & .8154837E-04,.1197092E-03,.1424472E-03,.2535780E-03,.2329964E-03,& - & .1885349E-03,.3380323E-03,.3052715E-03,.2150602E-03,.3685495E-03,& - & .3314392E-03,.2543625E-03,.3806938E-03,.3823779E-03,.2995716E-03/ - -! the array selfref contains the coefficient of the water vapor -! self-continuum (including the energy term). the first index -! refers to temperature in 7.2 degree increments. for instance, -! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, -! etc. the second index runs over the g-channel (1 to 6). - - data selfref(1:10,1: 6) / & - & .1352797E-02,.1118049E-02,.9240558E-03,.7637369E-03,.6312454E-03,& - & .5217486E-03,.4312539E-03,.3564616E-03,.2946471E-03,.2435560E-03,& - & .3427292E-02,.2856171E-02,.2390076E-02,.2008096E-02,.1693734E-02,& - & .1433911E-02,.1218251E-02,.1038495E-02,.8880442E-03,.7616162E-03,& - & .4545629E-02,.4185794E-02,.3854444E-02,.3549326E-02,.3268367E-02,& - & .3009646E-02,.2771406E-02,.2552033E-02,.2350020E-02,.2163998E-02,& - & .5477838E-02,.5082542E-02,.4715844E-02,.4375667E-02,.4060089E-02,& - & .3767331E-02,.3495734E-02,.3243771E-02,.3010013E-02,.2793137E-02,& - & .5682360E-02,.5292443E-02,.4929650E-02,.4592058E-02,.4277891E-02,& - & .3985497E-02,.3713349E-02,.3460014E-02,.3224177E-02,.3004612E-02,& - & .7004786E-02,.6372419E-02,.5797303E-02,.5274236E-02,.4798502E-02,& - & .4365805E-02,.3972237E-02,.3614256E-02,.3288634E-02,.2992436E-02/ - -!........................................! - end module module_radsw_kgb16 ! -!========================================! - - -!========================================! - module module_radsw_kgb17 ! -!........................................! -! -! ********* the original program descriptions ********* ! -! ! -! originally by j.delamere, atmospheric & environmental research. ! -! revision: 2.4 ! -! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o, co2) ! -! reformatted for f90 by jjmorcrette, ecmwf ! -! ! -! this table has been re-generated for reduced number of g-point ! -! by y.t.hou, ncep ! -! ! -! ********* ********* end description ********* ********* ! -! - use machine, only : kind_phys - use module_radsw_parameters, only : NG17 - -! - implicit none -! - private -! - integer, public :: MSA17, MSB17, MSF17, MFR17 - parameter (MSA17=585, MSB17=1175, MSF17=10, MFR17=4) - - real (kind=kind_phys), public :: selfref(MSF17,NG17), & - & absa(MSA17,NG17), absb(MSB17,NG17), forref(MFR17,NG17) - -! --- rayleigh extinction coefficient at v = 3625 cm-1. - real (kind=kind_phys), parameter, public :: rayl = 6.86e-10 - -! the array absa(585,NG17) (ka((9,5,13,NG17)) contains absorption coefs at -! the 16 chosen g-values for a range of pressure levels> ~100mb, -! temperatures, and binary species parameters (see taumol.f for definition). -! the first index in the array, js, runs from 1 to 9, and corresponds to -! different values of the binary species parameter. for instance, -! js=1 refers to dry air, js = 2 corresponds to the paramter value 1/8, -! js = 3 corresponds to the parameter value 2/8, etc. the second index -! in the array, jt, which runs from 1 to 5, corresponds to different -! temperatures. more specifically, jt = 3 means that the data are for -! the reference temperature tref for this pressure level, jt = 2 refers -! to tref-15, jt = 1 is for tref-30, jt = 4 is for tref+15, and jt = 5 -! is for tref+30. the third index, jp, runs from 1 to 13 and refers -! to the jpth reference pressure level (see taumol.f for these levels -! in mb). the fourth index, ig, goes from 1 to 12, and indicates -! which g-interval the absorption coefficients are for. - - data absa( 1:180, 1) / & - & .1113400E-05,.3209200E-03,.5566300E-03,.7822700E-03,.9942100E-03,& - & .1204500E-02,.1411600E-02,.1606900E-02,.1933000E-02,.1054400E-05,& - & .3543400E-03,.6148000E-03,.8642400E-03,.1105500E-02,.1343100E-02,& - & .1575400E-02,.1795100E-02,.2128000E-02,.9834500E-06,.3898900E-03,& - & .6774700E-03,.9528900E-03,.1219600E-02,.1486400E-02,.1744900E-02,& - & .1989700E-02,.2356400E-02,.9501700E-06,.4258200E-03,.7441900E-03,& - & .1046300E-02,.1342400E-02,.1635300E-02,.1921500E-02,.2193900E-02,& - & .2599300E-02,.9187000E-06,.4637100E-03,.8139400E-03,.1146400E-02,& - & .1471500E-02,.1793700E-02,.2107200E-02,.2407700E-02,.2854000E-02,& - & .9418400E-06,.2653200E-03,.4615700E-03,.6377600E-03,.8108700E-03,& - & .9772800E-03,.1141900E-02,.1299100E-02,.1512100E-02,.8906000E-06,& - & .2941700E-03,.5096700E-03,.7075900E-03,.9020300E-03,.1092000E-02,& - & .1276400E-02,.1454400E-02,.1679500E-02,.8272000E-06,.3236100E-03,& - & .5612400E-03,.7829900E-03,.9971800E-03,.1209400E-02,.1417200E-02,& - & .1616500E-02,.1863700E-02,.7884200E-06,.3549500E-03,.6168400E-03,& - & .8617600E-03,.1099500E-02,.1334500E-02,.1565200E-02,.1785600E-02,& - & .2062100E-02,.7661000E-06,.3872800E-03,.6753800E-03,.9461300E-03,& - & .1208200E-02,.1467500E-02,.1720600E-02,.1964000E-02,.2272000E-02,& - & .7966300E-06,.2136900E-03,.3708800E-03,.5122200E-03,.6454900E-03,& - & .7732200E-03,.8993900E-03,.1020500E-02,.1156800E-02,.7595500E-06,& - & .2378000E-03,.4115300E-03,.5690100E-03,.7200900E-03,.8673500E-03,& - & .1009200E-02,.1147600E-02,.1291300E-02,.7169200E-06,.2627600E-03,& - & .4548800E-03,.6292200E-03,.7983600E-03,.9625900E-03,.1123600E-02,& - & .1279600E-02,.1439800E-02,.6634800E-06,.2889600E-03,.5022100E-03,& - & .6941100E-03,.8822600E-03,.1065800E-02,.1245600E-02,.1419100E-02,& - & .1599100E-02,.6401300E-06,.3164300E-03,.5516600E-03,.7643400E-03,& - & .9721600E-03,.1174500E-02,.1373100E-02,.1565700E-02,.1767100E-02,& - & .6621700E-06,.1696600E-03,.2935800E-03,.4068800E-03,.5111400E-03,& - & .6073900E-03,.7019100E-03,.7944600E-03,.8883200E-03,.6411100E-06,& - & .1890200E-03,.3274200E-03,.4536400E-03,.5708600E-03,.6840100E-03,& - & .7911600E-03,.8950700E-03,.9965500E-03,.6072900E-06,.2100700E-03,& - & .3635400E-03,.5035400E-03,.6345900E-03,.7611300E-03,.8847300E-03,& - & .1003500E-02,.1116300E-02,.5725000E-06,.2320300E-03,.4024500E-03,& - & .5575800E-03,.7029500E-03,.8451500E-03,.9837900E-03,.1116500E-02,& - & .1244400E-02,.5352400E-06,.2552900E-03,.4439900E-03,.6156400E-03,& - & .7762600E-03,.9340500E-03,.1089200E-02,.1236900E-02,.1379500E-02/ - - data absa(181:315, 1) / & - & .5511200E-06,.1342200E-03,.2316600E-03,.3211900E-03,.4026500E-03,& - & .4781200E-03,.5479700E-03,.6187300E-03,.6891200E-03,.5366900E-06,& - & .1499000E-03,.2594900E-03,.3588600E-03,.4523900E-03,.5393600E-03,& - & .6189400E-03,.6971800E-03,.7773200E-03,.5149500E-06,.1670600E-03,& - & .2896000E-03,.4002000E-03,.5046100E-03,.6024900E-03,.6967700E-03,& - & .7846400E-03,.8733400E-03,.4863300E-06,.1854300E-03,.3215900E-03,& - & .4449900E-03,.5609500E-03,.6705500E-03,.7757500E-03,.8771700E-03,& - & .9769400E-03,.4516200E-06,.2047200E-03,.3559100E-03,.4935000E-03,& - & .6216300E-03,.7425300E-03,.8624700E-03,.9751800E-03,.1086400E-02,& - & .4505500E-06,.1055600E-03,.1817600E-03,.2513700E-03,.3143800E-03,& - & .3736300E-03,.4275900E-03,.4788300E-03,.5343700E-03,.4450200E-06,& - & .1181400E-03,.2038300E-03,.2816200E-03,.3554700E-03,.4226100E-03,& - & .4834000E-03,.5406600E-03,.6035200E-03,.4306600E-06,.1321700E-03,& - & .2283600E-03,.3155200E-03,.3976200E-03,.4749300E-03,.5454300E-03,& - & .6106600E-03,.6817600E-03,.4111600E-06,.1473300E-03,.2547200E-03,& - & .3520400E-03,.4433400E-03,.5299700E-03,.6096600E-03,.6862200E-03,& - & .7660700E-03,.3874800E-06,.1634400E-03,.2828100E-03,.3917300E-03,& - & .4930500E-03,.5888000E-03,.6795400E-03,.7648500E-03,.8540100E-03,& - & .3658200E-06,.8295800E-04,.1421000E-03,.1957400E-03,.2444000E-03,& - & .2903900E-03,.3328100E-03,.3717700E-03,.4217800E-03,.3670700E-06,& - & .9290900E-04,.1597700E-03,.2203400E-03,.2774200E-03,.3295500E-03,& - & .3772700E-03,.4195600E-03,.4785900E-03,.3578700E-06,.1043200E-03,& - & .1793000E-03,.2476900E-03,.3115500E-03,.3724200E-03,.4269900E-03,& - & .4747400E-03,.5408300E-03,.3448200E-06,.1168500E-03,.2005500E-03,& - & .2772500E-03,.3486600E-03,.4167700E-03,.4790300E-03,.5351800E-03,& - & .6081200E-03,.3259800E-06,.1300100E-03,.2234100E-03,.3090000E-03,& - & .3891900E-03,.4646500E-03,.5346700E-03,.5992600E-03,.6773300E-03/ - - data absa(316:450, 1) / & - & .2983400E-06,.6500900E-04,.1118300E-03,.1520000E-03,.1896900E-03,& - & .2251700E-03,.2583200E-03,.2873000E-03,.3395500E-03,.2974500E-06,& - & .7287200E-04,.1248200E-03,.1722100E-03,.2158300E-03,.2559600E-03,& - & .2932800E-03,.3252000E-03,.3862000E-03,.2942100E-06,.8203600E-04,& - & .1401000E-03,.1934400E-03,.2436200E-03,.2907100E-03,.3330800E-03,& - & .3686700E-03,.4390100E-03,.2859600E-06,.9225600E-04,.1573800E-03,& - & .2175200E-03,.2732500E-03,.3264300E-03,.3757800E-03,.4171000E-03,& - & .4935800E-03,.2729600E-06,.1032000E-03,.1759800E-03,.2433900E-03,& - & .3059100E-03,.3650500E-03,.4206100E-03,.4687200E-03,.5499300E-03,& - & .2425900E-06,.5062600E-04,.8694500E-04,.1177800E-03,.1469200E-03,& - & .1743100E-03,.2005700E-03,.2213100E-03,.2991900E-03,.2405800E-06,& - & .5696600E-04,.9746700E-04,.1340500E-03,.1675000E-03,.1981400E-03,& - & .2273900E-03,.2528100E-03,.3402200E-03,.2409100E-06,.6432400E-04,& - & .1097100E-03,.1506100E-03,.1899600E-03,.2258000E-03,.2588500E-03,& - & .2869400E-03,.3804500E-03,.2355000E-06,.7245100E-04,.1234500E-03,& - & .1699100E-03,.2136200E-03,.2548400E-03,.2934100E-03,.3252300E-03,& - & .4283600E-03,.2269600E-06,.8135100E-04,.1383900E-03,.1909000E-03,& - & .2398600E-03,.2860800E-03,.3291000E-03,.3663900E-03,.4792500E-03,& - & .1967900E-06,.3976000E-04,.6805200E-04,.9229500E-04,.1149800E-03,& - & .1365600E-03,.1560400E-03,.1717100E-03,.2967900E-03,.1956700E-06,& - & .4484700E-04,.7682900E-04,.1051800E-03,.1310200E-03,.1550900E-03,& - & .1776400E-03,.1984300E-03,.3286300E-03,.1957400E-06,.5056500E-04,& - & .8646600E-04,.1187800E-03,.1492000E-03,.1769800E-03,.2025800E-03,& - & .2252600E-03,.3695900E-03,.1926200E-06,.5712400E-04,.9754600E-04,& - & .1339800E-03,.1680300E-03,.2004600E-03,.2302200E-03,.2557800E-03,& - & .4154300E-03,.1874700E-06,.6426400E-04,.1097100E-03,.1508600E-03,& - & .1892300E-03,.2256500E-03,.2593400E-03,.2892100E-03,.4646300E-03/ - - data absa(451:585, 1) / & - & .1601500E-06,.3302500E-04,.5656200E-04,.7662500E-04,.9564500E-04,& - & .1135800E-03,.1295500E-03,.1426900E-03,.2754500E-03,.1591800E-06,& - & .3714800E-04,.6377500E-04,.8760000E-04,.1089700E-03,.1289300E-03,& - & .1475600E-03,.1646500E-03,.3079900E-03,.1589700E-06,.4199300E-04,& - & .7204000E-04,.9892800E-04,.1243300E-03,.1473300E-03,.1682400E-03,& - & .1869400E-03,.3434000E-03,.1557800E-06,.4744100E-04,.8142600E-04,& - & .1116500E-03,.1398500E-03,.1667300E-03,.1915600E-03,.2126800E-03,& - & .3817600E-03,.1521000E-06,.5339800E-04,.9165700E-04,.1259200E-03,& - & .1576900E-03,.1878100E-03,.2156900E-03,.2406900E-03,.4222800E-03,& - & .1302100E-06,.2727200E-04,.4683200E-04,.6351100E-04,.7920500E-04,& - & .9394900E-04,.1071900E-03,.1182700E-03,.2394400E-03,.1293000E-06,& - & .3068600E-04,.5292500E-04,.7278200E-04,.9052700E-04,.1070800E-03,& - & .1223600E-03,.1362000E-03,.2712100E-03,.1290000E-06,.3472300E-04,& - & .5986700E-04,.8220500E-04,.1032600E-03,.1223800E-03,.1395800E-03,& - & .1549800E-03,.2993000E-03,.1264800E-06,.3925200E-04,.6761800E-04,& - & .9294900E-04,.1163600E-03,.1383500E-03,.1592400E-03,.1765300E-03,& - & .3305000E-03,.1229900E-06,.4421300E-04,.7624400E-04,.1048800E-03,& - & .1313500E-03,.1560100E-03,.1790200E-03,.1997600E-03,.3657900E-03,& - & .1055400E-06,.2238800E-04,.3859700E-04,.5237800E-04,.6540400E-04,& - & .7756700E-04,.8854300E-04,.9780100E-04,.1959900E-03,.1048000E-06,& - & .2518100E-04,.4367000E-04,.6020500E-04,.7488300E-04,.8860500E-04,& - & .1011700E-03,.1124200E-03,.2214600E-03,.1042900E-06,.2853000E-04,& - & .4942200E-04,.6803900E-04,.8543500E-04,.1013600E-03,.1155700E-03,& - & .1282800E-03,.2444700E-03,.1023200E-06,.3230100E-04,.5579700E-04,& - & .7694800E-04,.9644700E-04,.1146200E-03,.1316600E-03,.1461600E-03,& - & .2699900E-03,.9901400E-07,.3639400E-04,.6299400E-04,.8694600E-04,& - & .1090000E-03,.1293700E-03,.1483300E-03,.1654000E-03,.2991600E-03/ - - data absa( 1:180, 2) / & - & .2348800E-04,.1668400E-02,.2957500E-02,.4008300E-02,.4995300E-02,& - & .5902100E-02,.6744600E-02,.7600800E-02,.8703200E-02,.2515600E-04,& - & .1846200E-02,.3271100E-02,.4500800E-02,.5618200E-02,.6628700E-02,& - & .7590900E-02,.8555800E-02,.9754300E-02,.2708400E-04,.2032500E-02,& - & .3603400E-02,.4999200E-02,.6279600E-02,.7413400E-02,.8499400E-02,& - & .9569400E-02,.1084700E-01,.2814700E-04,.2234700E-02,.3962800E-02,& - & .5500500E-02,.6945300E-02,.8242900E-02,.9469900E-02,.1066000E-01,& - & .1199100E-01,.2871900E-04,.2447500E-02,.4336900E-02,.6036000E-02,& - & .7618300E-02,.9087800E-02,.1049300E-01,.1180500E-01,.1320400E-01,& - & .2094700E-04,.1401500E-02,.2472800E-02,.3367600E-02,.4180100E-02,& - & .4924400E-02,.5578700E-02,.6220600E-02,.6974100E-02,.2235200E-04,& - & .1553500E-02,.2739600E-02,.3787000E-02,.4712100E-02,.5557100E-02,& - & .6289200E-02,.7013200E-02,.7809200E-02,.2388200E-04,.1721300E-02,& - & .3034500E-02,.4202000E-02,.5278200E-02,.6228500E-02,.7055600E-02,& - & .7881900E-02,.8733000E-02,.2465000E-04,.1895400E-02,.3338400E-02,& - & .4633600E-02,.5833300E-02,.6931100E-02,.7875100E-02,.8814900E-02,& - & .9691100E-02,.2513600E-04,.2080600E-02,.3664100E-02,.5096600E-02,& - & .6419300E-02,.7628100E-02,.8740300E-02,.9794300E-02,.1070400E-01,& - & .1772000E-04,.1141400E-02,.2004500E-02,.2728800E-02,.3389100E-02,& - & .3975500E-02,.4496700E-02,.4938900E-02,.5385800E-02,.1908700E-04,& - & .1274500E-02,.2233600E-02,.3084100E-02,.3833300E-02,.4498300E-02,& - & .5089500E-02,.5593000E-02,.6066600E-02,.2012500E-04,.1417800E-02,& - & .2479500E-02,.3427800E-02,.4310600E-02,.5060700E-02,.5728000E-02,& - & .6309200E-02,.6828500E-02,.2089500E-04,.1566600E-02,.2734800E-02,& - & .3793400E-02,.4776900E-02,.5662100E-02,.6404600E-02,.7086400E-02,& - & .7602600E-02,.2150800E-04,.1725100E-02,.3015300E-02,.4180900E-02,& - & .5268900E-02,.6246200E-02,.7112500E-02,.7910400E-02,.8438900E-02,& - & .1466100E-04,.9226100E-03,.1608800E-02,.2178800E-02,.2695600E-02,& - & .3161200E-02,.3562600E-02,.3887800E-02,.4152500E-02,.1560700E-04,& - & .1032900E-02,.1797300E-02,.2473500E-02,.3069600E-02,.3595300E-02,& - & .4051100E-02,.4416200E-02,.4699000E-02,.1655900E-04,.1155000E-02,& - & .2001900E-02,.2757700E-02,.3462500E-02,.4066200E-02,.4583100E-02,& - & .4999500E-02,.5307300E-02,.1726300E-04,.1279400E-02,.2218400E-02,& - & .3061400E-02,.3851000E-02,.4566400E-02,.5153200E-02,.5629000E-02,& - & .5943600E-02,.1789500E-04,.1413000E-02,.2452600E-02,.3380500E-02,& - & .4262200E-02,.5055600E-02,.5748900E-02,.6309400E-02,.6625600E-02/ - - data absa(181:315, 2) / & - & .1188500E-04,.7488800E-03,.1282600E-02,.1725800E-02,.2134600E-02,& - & .2497200E-02,.2804600E-02,.3060600E-02,.3232300E-02,.1245200E-04,& - & .8408400E-03,.1438000E-02,.1969800E-02,.2438600E-02,.2853600E-02,& - & .3207500E-02,.3493700E-02,.3656200E-02,.1343900E-04,.9427200E-03,& - & .1606500E-02,.2207900E-02,.2766000E-02,.3238900E-02,.3644000E-02,& - & .3967300E-02,.4139300E-02,.1405300E-04,.1047300E-02,.1789900E-02,& - & .2460300E-02,.3086100E-02,.3652100E-02,.4115600E-02,.4482500E-02,& - & .4652900E-02,.1458600E-04,.1158500E-02,.1988600E-02,.2725700E-02,& - & .3427200E-02,.4059900E-02,.4611500E-02,.5028600E-02,.5208500E-02,& - & .9487200E-05,.5979300E-03,.1021000E-02,.1357200E-02,.1671600E-02,& - & .1951200E-02,.2189000E-02,.2382700E-02,.2534700E-02,.1006000E-04,& - & .6740000E-03,.1143200E-02,.1556400E-02,.1918800E-02,.2238900E-02,& - & .2516100E-02,.2730800E-02,.2877000E-02,.1074300E-04,.7594800E-03,& - & .1280600E-02,.1755100E-02,.2186200E-02,.2554500E-02,.2872900E-02,& - & .3114900E-02,.3271600E-02,.1132200E-04,.8513400E-03,.1432000E-02,& - & .1963000E-02,.2451400E-02,.2893000E-02,.3257800E-02,.3537500E-02,& - & .3691200E-02,.1175500E-04,.9461100E-03,.1598600E-02,.2180400E-02,& - & .2729100E-02,.3230600E-02,.3669500E-02,.3991300E-02,.4143900E-02,& - & .7593100E-05,.4713000E-03,.8121100E-03,.1065800E-02,.1300400E-02,& - & .1517500E-02,.1700200E-02,.1847300E-02,.1986100E-02,.8072400E-05,& - & .5335800E-03,.9116300E-03,.1226100E-02,.1501400E-02,.1748300E-02,& - & .1961200E-02,.2120100E-02,.2259100E-02,.8440400E-05,.6051700E-03,& - & .1023600E-02,.1388700E-02,.1720400E-02,.2003100E-02,.2249700E-02,& - & .2432100E-02,.2582300E-02,.9051100E-05,.6803700E-03,.1147500E-02,& - & .1559600E-02,.1940200E-02,.2278900E-02,.2563300E-02,.2775300E-02,& - & .2924700E-02,.9440500E-05,.7610300E-03,.1283600E-02,.1742200E-02,& - & .2169800E-02,.2558500E-02,.2898900E-02,.3144400E-02,.3301600E-02/ - - data absa(316:450, 2) / & - & .5808000E-05,.3678200E-03,.6351600E-03,.8379900E-03,.1011900E-02,& - & .1175400E-02,.1316100E-02,.1438200E-02,.1583700E-02,.6315600E-05,& - & .4190900E-03,.7197400E-03,.9695200E-03,.1171100E-02,.1361700E-02,& - & .1523400E-02,.1644100E-02,.1811800E-02,.6677600E-05,.4782900E-03,& - & .8115000E-03,.1105600E-02,.1349300E-02,.1564600E-02,.1752400E-02,& - & .1893700E-02,.2069800E-02,.7058200E-05,.5401700E-03,.9133000E-03,& - & .1243400E-02,.1541100E-02,.1788400E-02,.2005700E-02,.2170400E-02,& - & .2354800E-02,.7490200E-05,.6071700E-03,.1026700E-02,.1390800E-02,& - & .1723100E-02,.2028500E-02,.2281000E-02,.2471000E-02,.2663100E-02,& - & .4506100E-05,.2862600E-03,.4944800E-03,.6531700E-03,.7908100E-03,& - & .9106600E-03,.1018200E-02,.1110700E-02,.1459200E-02,.4939200E-05,& - & .3273400E-03,.5655800E-03,.7607700E-03,.9184600E-03,.1057800E-02,& - & .1177600E-02,.1272000E-02,.1677800E-02,.5258000E-05,.3752200E-03,& - & .6384500E-03,.8780500E-03,.1061900E-02,.1219400E-02,.1360600E-02,& - & .1468000E-02,.1925900E-02,.5499100E-05,.4265900E-03,.7210300E-03,& - & .9875600E-03,.1216300E-02,.1400700E-02,.1564700E-02,.1690000E-02,& - & .2177200E-02,.5876900E-05,.4819900E-03,.8146600E-03,.1107200E-02,& - & .1368400E-02,.1598400E-02,.1788700E-02,.1933300E-02,.2433100E-02,& - & .3415400E-05,.2253400E-03,.3878800E-03,.5111300E-03,.6219400E-03,& - & .7143200E-03,.7974300E-03,.8628900E-03,.1475800E-02,.3808500E-05,& - & .2583200E-03,.4474800E-03,.5983500E-03,.7251400E-03,.8328400E-03,& - & .9194100E-03,.9958300E-03,.1735800E-02,.4157800E-05,.2965500E-03,& - & .5055300E-03,.6951100E-03,.8410700E-03,.9637400E-03,.1066600E-02,& - & .1147800E-02,.1962500E-02,.4391700E-05,.3390800E-03,.5735100E-03,& - & .7864000E-03,.9686200E-03,.1110900E-02,.1230900E-02,.1326600E-02,& - & .2210300E-02,.4544600E-05,.3854800E-03,.6488300E-03,.8840100E-03,& - & .1095200E-02,.1270600E-02,.1413600E-02,.1523900E-02,.2475400E-02/ - - data absa(451:585, 2) / & - & .2760400E-05,.1884800E-03,.3253200E-03,.4294900E-03,.5235000E-03,& - & .6008400E-03,.6664000E-03,.7207000E-03,.1369200E-02,.3090800E-05,& - & .2167900E-03,.3725900E-03,.5036600E-03,.6107400E-03,.7015800E-03,& - & .7727100E-03,.8303700E-03,.1568900E-02,.3367400E-05,.2496500E-03,& - & .4224400E-03,.5835300E-03,.7092300E-03,.8133000E-03,.8975000E-03,& - & .9613100E-03,.1797100E-02,.3556800E-05,.2860200E-03,.4804400E-03,& - & .6586800E-03,.8181600E-03,.9385700E-03,.1035700E-02,.1111900E-02,& - & .2050900E-02,.3692100E-05,.3248400E-03,.5462300E-03,.7447500E-03,& - & .9230700E-03,.1075800E-02,.1189500E-02,.1277700E-02,.2325300E-02,& - & .2227200E-05,.1580700E-03,.2716300E-03,.3593500E-03,.4378100E-03,& - & .5032100E-03,.5577600E-03,.6004600E-03,.1185200E-02,.2489800E-05,& - & .1820100E-03,.3100400E-03,.4220600E-03,.5122600E-03,.5882400E-03,& - & .6491900E-03,.6929100E-03,.1362300E-02,.2702100E-05,.2095800E-03,& - & .3532200E-03,.4867600E-03,.5958700E-03,.6836400E-03,.7552700E-03,& - & .8043600E-03,.1565400E-02,.2852600E-05,.2403800E-03,.4026200E-03,& - & .5509600E-03,.6867100E-03,.7910300E-03,.8721100E-03,.9312400E-03,& - & .1789800E-02,.2989900E-05,.2728900E-03,.4590400E-03,.6244800E-03,& - & .7749600E-03,.9021200E-03,.1001800E-02,.1070600E-02,.2026500E-02,& - & .1757600E-05,.1315100E-03,.2251800E-03,.2989000E-03,.3639800E-03,& - & .4188400E-03,.4650500E-03,.5008600E-03,.9791600E-03,.1952400E-05,& - & .1518900E-03,.2568600E-03,.3512300E-03,.4272300E-03,.4906100E-03,& - & .5429300E-03,.5781500E-03,.1126000E-02,.2113400E-05,.1755800E-03,& - & .2938200E-03,.4045700E-03,.4977700E-03,.5715300E-03,.6318500E-03,& - & .6721300E-03,.1296000E-02,.2268100E-05,.2010600E-03,.3358300E-03,& - & .4597700E-03,.5709400E-03,.6627500E-03,.7314900E-03,.7779900E-03,& - & .1485600E-02,.2394000E-05,.2285300E-03,.3832300E-03,.5212600E-03,& - & .6468400E-03,.7545500E-03,.8411500E-03,.8957500E-03,.1681600E-02/ - - data absa( 1:180, 3) / & - & .8715400E-04,.7045600E-02,.1162400E-01,.1600700E-01,.2027700E-01,& - & .2434900E-01,.2790200E-01,.3095600E-01,.3315900E-01,.9267800E-04,& - & .7532400E-02,.1255200E-01,.1744400E-01,.2196700E-01,.2625000E-01,& - & .3024100E-01,.3334800E-01,.3616400E-01,.9795500E-04,.8015300E-02,& - & .1350200E-01,.1881200E-01,.2386200E-01,.2848000E-01,.3251100E-01,& - & .3571300E-01,.3834900E-01,.1040400E-03,.8472400E-02,.1442900E-01,& - & .2013600E-01,.2567200E-01,.3068800E-01,.3501100E-01,.3837900E-01,& - & .4067300E-01,.1111000E-03,.8912300E-02,.1534300E-01,.2147900E-01,& - & .2729000E-01,.3275100E-01,.3745500E-01,.4093100E-01,.4246300E-01,& - & .7321400E-04,.6141000E-02,.1012500E-01,.1365000E-01,.1715800E-01,& - & .2062700E-01,.2362800E-01,.2625100E-01,.2748100E-01,.7793600E-04,& - & .6575100E-02,.1096600E-01,.1487700E-01,.1869300E-01,.2227200E-01,& - & .2563000E-01,.2839500E-01,.2989400E-01,.8306100E-04,.6982800E-02,& - & .1177400E-01,.1606800E-01,.2031700E-01,.2424400E-01,.2774800E-01,& - & .3043200E-01,.3185100E-01,.8856400E-04,.7398500E-02,.1258100E-01,& - & .1722600E-01,.2184200E-01,.2617700E-01,.2996900E-01,.3274800E-01,& - & .3380500E-01,.9493300E-04,.7798800E-02,.1337200E-01,.1836700E-01,& - & .2332300E-01,.2792800E-01,.3196400E-01,.3501300E-01,.3532700E-01,& - & .6094700E-04,.5243600E-02,.8617400E-02,.1152000E-01,.1423100E-01,& - & .1702700E-01,.1946900E-01,.2163400E-01,.2198100E-01,.6492100E-04,& - & .5597500E-02,.9351200E-02,.1252600E-01,.1551600E-01,.1847100E-01,& - & .2127000E-01,.2351200E-01,.2411400E-01,.6952100E-04,.5964800E-02,& - & .1006000E-01,.1358200E-01,.1690300E-01,.2017700E-01,.2305500E-01,& - & .2538000E-01,.2582200E-01,.7434800E-04,.6310400E-02,.1076700E-01,& - & .1459900E-01,.1827300E-01,.2183600E-01,.2498400E-01,.2735800E-01,& - & .2745000E-01,.7978000E-04,.6667100E-02,.1145800E-01,.1559000E-01,& - & .1957900E-01,.2335800E-01,.2680600E-01,.2933500E-01,.2878600E-01,& - & .5079900E-04,.4414800E-02,.7222500E-02,.9648300E-02,.1176700E-01,& - & .1382800E-01,.1584400E-01,.1758800E-01,.1739100E-01,.5422700E-04,& - & .4723100E-02,.7852700E-02,.1049300E-01,.1283500E-01,.1512600E-01,& - & .1746600E-01,.1921900E-01,.1935100E-01,.5815100E-04,.5027700E-02,& - & .8482300E-02,.1141800E-01,.1396900E-01,.1657600E-01,.1890300E-01,& - & .2084000E-01,.2085300E-01,.6243300E-04,.5337200E-02,.9081300E-02,& - & .1232500E-01,.1516300E-01,.1797100E-01,.2059000E-01,.2252900E-01,& - & .2227300E-01,.6685200E-04,.5642900E-02,.9683600E-02,.1318900E-01,& - & .1628000E-01,.1931200E-01,.2213600E-01,.2426300E-01,.2346600E-01/ - - data absa(181:315, 3) / & - & .4259300E-04,.3676000E-02,.5991300E-02,.7981200E-02,.9772900E-02,& - & .1126500E-01,.1287400E-01,.1415000E-01,.1365100E-01,.4577900E-04,& - & .3934400E-02,.6540100E-02,.8703000E-02,.1065000E-01,.1237400E-01,& - & .1413500E-01,.1552900E-01,.1550700E-01,.4886800E-04,.4201300E-02,& - & .7085900E-02,.9491200E-02,.1160900E-01,.1355700E-01,.1538100E-01,& - & .1699300E-01,.1678500E-01,.5250900E-04,.4467400E-02,.7602200E-02,& - & .1027100E-01,.1263000E-01,.1473600E-01,.1683000E-01,.1838700E-01,& - & .1804000E-01,.5619600E-04,.4738100E-02,.8100500E-02,.1102600E-01,& - & .1358600E-01,.1594000E-01,.1816000E-01,.1992000E-01,.1909200E-01,& - & .3611200E-04,.3031600E-02,.4903800E-02,.6532500E-02,.7960600E-02,& - & .9170600E-02,.1028500E-01,.1125200E-01,.1055600E-01,.3850200E-04,& - & .3257500E-02,.5385500E-02,.7130200E-02,.8720000E-02,.1013800E-01,& - & .1131900E-01,.1250400E-01,.1210900E-01,.4107000E-04,.3486900E-02,& - & .5864300E-02,.7802000E-02,.9523200E-02,.1108100E-01,.1241300E-01,& - & .1370000E-01,.1335000E-01,.4403400E-04,.3714200E-02,.6292400E-02,& - & .8486700E-02,.1040000E-01,.1209100E-01,.1361400E-01,.1485000E-01,& - & .1439600E-01,.4702100E-04,.3938700E-02,.6717100E-02,.9131900E-02,& - & .1123100E-01,.1312900E-01,.1474500E-01,.1615500E-01,.1539200E-01,& - & .3000100E-04,.2488400E-02,.3978700E-02,.5326200E-02,.6425400E-02,& - & .7442200E-02,.8241800E-02,.8765100E-02,.8324100E-02,.3206700E-04,& - & .2683100E-02,.4387300E-02,.5800900E-02,.7088100E-02,.8230300E-02,& - & .9111500E-02,.9953000E-02,.9584300E-02,.3441400E-04,.2876200E-02,& - & .4798100E-02,.6365000E-02,.7755500E-02,.9013000E-02,.1005100E-01,& - & .1094400E-01,.1068700E-01,.3654300E-04,.3074900E-02,.5169700E-02,& - & .6954900E-02,.8493900E-02,.9862100E-02,.1101200E-01,.1195000E-01,& - & .1159600E-01,.3898600E-04,.3267200E-02,.5526800E-02,.7495000E-02,& - & .9220600E-02,.1075000E-01,.1197000E-01,.1302900E-01,.1246100E-01/ - - data absa(316:450, 3) / & - & .2471800E-04,.2030400E-02,.3225300E-02,.4295700E-02,.5162100E-02,& - & .5947700E-02,.6554300E-02,.6790100E-02,.6657800E-02,.2622600E-04,& - & .2202700E-02,.3552800E-02,.4684400E-02,.5746300E-02,.6607000E-02,& - & .7356600E-02,.7908600E-02,.7680700E-02,.2809500E-04,.2361400E-02,& - & .3896000E-02,.5152900E-02,.6277300E-02,.7291900E-02,.8147500E-02,& - & .8734400E-02,.8650900E-02,.2985600E-04,.2534600E-02,.4218000E-02,& - & .5650700E-02,.6886700E-02,.7994800E-02,.8916900E-02,.9622600E-02,& - & .9421200E-02,.3143200E-04,.2698900E-02,.4528800E-02,.6115800E-02,& - & .7523100E-02,.8731900E-02,.9744700E-02,.1047000E-01,.1017200E-01,& - & .2015100E-04,.1662200E-02,.2610200E-02,.3434500E-02,.4151800E-02,& - & .4735600E-02,.5119800E-02,.5290100E-02,.5560800E-02,.2129000E-04,& - & .1811200E-02,.2862200E-02,.3777000E-02,.4609800E-02,.5282500E-02,& - & .5871900E-02,.6211500E-02,.6428700E-02,.2260400E-04,.1948300E-02,& - & .3153600E-02,.4141800E-02,.5051300E-02,.5888300E-02,.6519900E-02,& - & .7000000E-02,.7164100E-02,.2403900E-04,.2090900E-02,.3432100E-02,& - & .4563300E-02,.5557500E-02,.6445300E-02,.7180000E-02,.7706200E-02,& - & .7782100E-02,.2527500E-04,.2232500E-02,.3697600E-02,.4972700E-02,& - & .6094500E-02,.7063200E-02,.7869600E-02,.8404800E-02,.8457100E-02,& - & .1652000E-04,.1357900E-02,.2121700E-02,.2765000E-02,.3320900E-02,& - & .3765700E-02,.4026300E-02,.4163200E-02,.5901900E-02,.1730700E-04,& - & .1486800E-02,.2323000E-02,.3061600E-02,.3700000E-02,.4262900E-02,& - & .4695800E-02,.4895600E-02,.6472900E-02,.1821000E-04,.1608600E-02,& - & .2563500E-02,.3348000E-02,.4082700E-02,.4759000E-02,.5242400E-02,& - & .5608800E-02,.7107200E-02,.1926300E-04,.1730800E-02,.2803800E-02,& - & .3701600E-02,.4493300E-02,.5211400E-02,.5822400E-02,.6205300E-02,& - & .7644500E-02,.2045000E-04,.1851400E-02,.3028600E-02,.4056900E-02,& - & .4941700E-02,.5729200E-02,.6380900E-02,.6816200E-02,.8180000E-02/ - - data absa(451:585, 3) / & - & .1374300E-04,.1154400E-02,.1800500E-02,.2338000E-02,.2812700E-02,& - & .3201900E-02,.3418400E-02,.3513700E-02,.5513200E-02,.1431400E-04,& - & .1264800E-02,.1981100E-02,.2579400E-02,.3128300E-02,.3583500E-02,& - & .3963500E-02,.4152400E-02,.6064000E-02,.1498000E-04,.1366700E-02,& - & .2184600E-02,.2831600E-02,.3439000E-02,.4006900E-02,.4428300E-02,& - & .4728200E-02,.6566200E-02,.1584300E-04,.1469100E-02,.2384400E-02,& - & .3134600E-02,.3791500E-02,.4392600E-02,.4910800E-02,.5243100E-02,& - & .7052100E-02,.1680100E-04,.1570900E-02,.2573800E-02,.3425000E-02,& - & .4178100E-02,.4825800E-02,.5377600E-02,.5740000E-02,.7491300E-02,& - & .1126500E-04,.9747300E-03,.1519000E-02,.1977900E-02,.2370800E-02,& - & .2700200E-02,.2895400E-02,.2968900E-02,.4905200E-02,.1170300E-04,& - & .1066000E-02,.1680600E-02,.2174200E-02,.2637000E-02,.3018400E-02,& - & .3346100E-02,.3508100E-02,.5351500E-02,.1227500E-04,.1152400E-02,& - & .1853200E-02,.2401400E-02,.2893200E-02,.3361500E-02,.3733200E-02,& - & .3975900E-02,.5780600E-02,.1296300E-04,.1240500E-02,.2020000E-02,& - & .2657300E-02,.3197800E-02,.3690400E-02,.4122500E-02,.4415100E-02,& - & .6195600E-02,.1369600E-04,.1326600E-02,.2181400E-02,.2893900E-02,& - & .3528400E-02,.4062900E-02,.4519100E-02,.4828300E-02,.6580000E-02,& - & .9117900E-05,.8153100E-03,.1275400E-02,.1659800E-02,.1990000E-02,& - & .2263400E-02,.2444100E-02,.2498400E-02,.4057600E-02,.9503900E-05,& - & .8909300E-03,.1415000E-02,.1828700E-02,.2214300E-02,.2532900E-02,& - & .2809200E-02,.2954600E-02,.4437400E-02,.9976200E-05,.9649400E-03,& - & .1562500E-02,.2028800E-02,.2431900E-02,.2810800E-02,.3137300E-02,& - & .3317700E-02,.4809400E-02,.1050900E-04,.1039800E-02,.1699600E-02,& - & .2244300E-02,.2692500E-02,.3094200E-02,.3448100E-02,.3700300E-02,& - & .5155000E-02,.1103300E-04,.1113400E-02,.1837200E-02,.2440800E-02,& - & .2968200E-02,.3411400E-02,.3785900E-02,.4042400E-02,.5489300E-02/ - - data absa( 1:180, 4) / & - & .2556400E-03,.2394000E-01,.4153500E-01,.5627600E-01,.6856100E-01,& - & .7863000E-01,.8699300E-01,.9179400E-01,.8422900E-01,.2919400E-03,& - & .2517000E-01,.4365900E-01,.5901600E-01,.7230200E-01,.8316700E-01,& - & .9173900E-01,.9677400E-01,.8683800E-01,.3393400E-03,.2643000E-01,& - & .4583500E-01,.6192200E-01,.7561400E-01,.8728500E-01,.9660600E-01,& - & .1015600E+00,.9008400E-01,.3887100E-03,.2773300E-01,.4805800E-01,& - & .6497300E-01,.7909000E-01,.9115600E-01,.1008400E+00,.1058900E+00,& - & .9258300E-01,.4447300E-03,.2902800E-01,.5028700E-01,.6801000E-01,& - & .8280500E-01,.9519300E-01,.1049200E+00,.1099500E+00,.9541900E-01,& - & .2340000E-03,.2075300E-01,.3574200E-01,.4870900E-01,.5954800E-01,& - & .6820600E-01,.7504500E-01,.7891500E-01,.7018000E-01,.2677500E-03,& - & .2183200E-01,.3761100E-01,.5115600E-01,.6276800E-01,.7226700E-01,& - & .7942200E-01,.8326200E-01,.7273500E-01,.3003300E-03,.2296100E-01,& - & .3961800E-01,.5377400E-01,.6577300E-01,.7581900E-01,.8353200E-01,& - & .8749600E-01,.7545900E-01,.3436600E-03,.2411600E-01,.4159700E-01,& - & .5650600E-01,.6894400E-01,.7923100E-01,.8724500E-01,.9133600E-01,& - & .7766900E-01,.3917900E-03,.2528900E-01,.4357500E-01,.5928200E-01,& - & .7213200E-01,.8295600E-01,.9103800E-01,.9493700E-01,.8027200E-01,& - & .2073000E-03,.1804400E-01,.3022700E-01,.4120600E-01,.5062600E-01,& - & .5809500E-01,.6372500E-01,.6672100E-01,.5778000E-01,.2400700E-03,& - & .1897200E-01,.3188300E-01,.4348600E-01,.5357200E-01,.6174200E-01,& - & .6748900E-01,.7055200E-01,.6000900E-01,.2693100E-03,.1993400E-01,& - & .3368100E-01,.4577500E-01,.5625500E-01,.6486900E-01,.7125400E-01,& - & .7423200E-01,.6235000E-01,.3006400E-03,.2096500E-01,.3544800E-01,& - & .4819900E-01,.5903600E-01,.6792100E-01,.7459400E-01,.7768900E-01,& - & .6441000E-01,.3396700E-03,.2197200E-01,.3719200E-01,.5067600E-01,& - & .6188400E-01,.7120700E-01,.7788800E-01,.8094700E-01,.6666700E-01,& - & .1820100E-03,.1559500E-01,.2537200E-01,.3443100E-01,.4240100E-01,& - & .4891500E-01,.5361300E-01,.5595300E-01,.4772700E-01,.2088300E-03,& - & .1642200E-01,.2685100E-01,.3648100E-01,.4507400E-01,.5207800E-01,& - & .5686000E-01,.5928700E-01,.4955300E-01,.2387400E-03,.1728500E-01,& - & .2842500E-01,.3851400E-01,.4754200E-01,.5490400E-01,.6028400E-01,& - & .6256100E-01,.5159500E-01,.2670700E-03,.1820000E-01,.3000700E-01,& - & .4061300E-01,.4998200E-01,.5766200E-01,.6323100E-01,.6566600E-01,& - & .5345000E-01,.3010200E-03,.1911300E-01,.3155200E-01,.4280500E-01,& - & .5253500E-01,.6055900E-01,.6619500E-01,.6854900E-01,.5541500E-01/ - - data absa(181:315, 4) / & - & .1580100E-03,.1329500E-01,.2152400E-01,.2866600E-01,.3514200E-01,& - & .4075700E-01,.4471500E-01,.4674000E-01,.3938400E-01,.1799400E-03,& - & .1405700E-01,.2278600E-01,.3048700E-01,.3756300E-01,.4350900E-01,& - & .4767600E-01,.4963800E-01,.4084900E-01,.2053500E-03,.1481100E-01,& - & .2411600E-01,.3226600E-01,.3976400E-01,.4612200E-01,.5066900E-01,& - & .5241300E-01,.4268300E-01,.2351100E-03,.1559800E-01,.2548100E-01,& - & .3410300E-01,.4192400E-01,.4859200E-01,.5328300E-01,.5523500E-01,& - & .4433500E-01,.2664000E-03,.1640200E-01,.2684400E-01,.3600000E-01,& - & .4418000E-01,.5108600E-01,.5591800E-01,.5779600E-01,.4599100E-01,& - & .1380500E-03,.1122200E-01,.1812500E-01,.2387700E-01,.2893900E-01,& - & .3350600E-01,.3694400E-01,.3867200E-01,.3233500E-01,.1543900E-03,& - & .1188300E-01,.1926200E-01,.2552100E-01,.3106800E-01,.3588200E-01,& - & .3958900E-01,.4113200E-01,.3368400E-01,.1756100E-03,.1255800E-01,& - & .2040900E-01,.2703300E-01,.3305600E-01,.3826000E-01,.4215500E-01,& - & .4363900E-01,.3517500E-01,.1996700E-03,.1323600E-01,.2162800E-01,& - & .2855400E-01,.3493900E-01,.4045900E-01,.4455000E-01,.4614700E-01,& - & .3664300E-01,.2311700E-03,.1393600E-01,.2283600E-01,.3018300E-01,& - & .3690900E-01,.4265200E-01,.4686400E-01,.4844000E-01,.3799200E-01,& - & .1198700E-03,.9398300E-02,.1513000E-01,.1980800E-01,.2379600E-01,& - & .2728500E-01,.3017600E-01,.3190600E-01,.2619300E-01,.1316400E-03,& - & .9974300E-02,.1611800E-01,.2131900E-01,.2560000E-01,.2940400E-01,& - & .3248500E-01,.3390900E-01,.2743900E-01,.1486200E-03,.1055900E-01,& - & .1712400E-01,.2267400E-01,.2737300E-01,.3150100E-01,.3470500E-01,& - & .3611200E-01,.2866700E-01,.1694100E-03,.1114200E-01,.1816300E-01,& - & .2399200E-01,.2902300E-01,.3346100E-01,.3688200E-01,.3828800E-01,& - & .2999000E-01,.1944400E-03,.1174000E-01,.1923100E-01,.2541000E-01,& - & .3070200E-01,.3538000E-01,.3893300E-01,.4032500E-01,.3116300E-01/ - - data absa(316:450, 4) / & - & .1026600E-03,.7813200E-02,.1249500E-01,.1629400E-01,.1955200E-01,& - & .2220300E-01,.2452200E-01,.2615800E-01,.2147700E-01,.1130800E-03,& - & .8299600E-02,.1338500E-01,.1765000E-01,.2111300E-01,.2402600E-01,& - & .2642400E-01,.2777900E-01,.2266100E-01,.1243100E-03,.8811800E-02,& - & .1425400E-01,.1885200E-01,.2271700E-01,.2582200E-01,.2835200E-01,& - & .2966700E-01,.2367400E-01,.1414600E-03,.9308000E-02,.1515200E-01,& - & .2001300E-01,.2415800E-01,.2756900E-01,.3030600E-01,.3149500E-01,& - & .2483800E-01,.1627500E-03,.9828700E-02,.1608000E-01,.2122700E-01,& - & .2559200E-01,.2922600E-01,.3207500E-01,.3335700E-01,.2588700E-01,& - & .8579700E-04,.6441200E-02,.1023100E-01,.1332700E-01,.1592300E-01,& - & .1810300E-01,.1990300E-01,.2118900E-01,.1797500E-01,.9437000E-04,& - & .6851400E-02,.1104100E-01,.1447200E-01,.1729800E-01,.1966100E-01,& - & .2142100E-01,.2263100E-01,.1899000E-01,.1060300E-03,.7287000E-02,& - & .1178600E-01,.1557000E-01,.1871000E-01,.2119500E-01,.2309200E-01,& - & .2415700E-01,.1993400E-01,.1181900E-03,.7721700E-02,.1255900E-01,& - & .1658900E-01,.1999100E-01,.2273800E-01,.2476900E-01,.2577100E-01,& - & .2094600E-01,.1350000E-03,.8162400E-02,.1334600E-01,.1761000E-01,& - & .2122700E-01,.2414000E-01,.2633900E-01,.2738800E-01,.2181900E-01,& - & .7327500E-04,.5314700E-02,.8383200E-02,.1089000E-01,.1299800E-01,& - & .1477200E-01,.1623700E-01,.1716500E-01,.1597200E-01,.8030300E-04,& - & .5659400E-02,.9096400E-02,.1186900E-01,.1418100E-01,.1606500E-01,& - & .1749300E-01,.1844700E-01,.1707500E-01,.8882100E-04,.6028600E-02,& - & .9749100E-02,.1285200E-01,.1538700E-01,.1739400E-01,.1890900E-01,& - & .1970800E-01,.1807800E-01,.1014200E-03,.6396200E-02,.1039200E-01,& - & .1373000E-01,.1652200E-01,.1877100E-01,.2030800E-01,.2109600E-01,& - & .1903700E-01,.1140500E-03,.6775400E-02,.1106500E-01,.1460500E-01,& - & .1758100E-01,.1999100E-01,.2168700E-01,.2245800E-01,.1987500E-01/ - - data absa(451:585, 4) / & - & .6451700E-04,.4513500E-02,.7116500E-02,.9238400E-02,.1099800E-01,& - & .1247400E-01,.1370000E-01,.1438800E-01,.1463100E-01,.7153500E-04,& - & .4807000E-02,.7713700E-02,.1009200E-01,.1202300E-01,.1362300E-01,& - & .1479200E-01,.1544900E-01,.1548100E-01,.7950400E-04,.5119900E-02,& - & .8260000E-02,.1091100E-01,.1307600E-01,.1475500E-01,.1600200E-01,& - & .1654600E-01,.1629800E-01,.9043300E-04,.5435100E-02,.8810100E-02,& - & .1164700E-01,.1401800E-01,.1592200E-01,.1720600E-01,.1771500E-01,& - & .1699100E-01,.1014600E-03,.5759600E-02,.9386500E-02,.1240700E-01,& - & .1492200E-01,.1695100E-01,.1838400E-01,.1889300E-01,.1766600E-01,& - & .5691300E-04,.3836100E-02,.6023800E-02,.7810100E-02,.9294300E-02,& - & .1051500E-01,.1151400E-01,.1205100E-01,.1270800E-01,.6298400E-04,& - & .4088600E-02,.6515300E-02,.8546400E-02,.1016800E-01,.1149800E-01,& - & .1245200E-01,.1293800E-01,.1347300E-01,.7058800E-04,.4356100E-02,& - & .6976100E-02,.9213700E-02,.1106800E-01,.1248200E-01,.1349700E-01,& - & .1389200E-01,.1409000E-01,.7955600E-04,.4622200E-02,.7447200E-02,& - & .9838200E-02,.1185200E-01,.1346100E-01,.1453900E-01,.1486800E-01,& - & .1468400E-01,.8933000E-04,.4903700E-02,.7933200E-02,.1049200E-01,& - & .1261300E-01,.1433100E-01,.1552300E-01,.1586700E-01,.1526600E-01,& - & .4904000E-04,.3247000E-02,.5078200E-02,.6581300E-02,.7825400E-02,& - & .8839800E-02,.9648300E-02,.1009000E-01,.1061400E-01,.5422500E-04,& - & .3461600E-02,.5490600E-02,.7195100E-02,.8571100E-02,.9678100E-02,& - & .1046000E-01,.1084000E-01,.1120600E-01,.6113600E-04,.3687800E-02,& - & .5877700E-02,.7745800E-02,.9318300E-02,.1052800E-01,.1134700E-01,& - & .1168400E-01,.1173000E-01,.6878800E-04,.3921300E-02,.6279100E-02,& - & .8277400E-02,.9976100E-02,.1133200E-01,.1224700E-01,.1249500E-01,& - & .1225000E-01,.7742700E-04,.4164000E-02,.6689000E-02,.8835800E-02,& - & .1062400E-01,.1206900E-01,.1306400E-01,.1334100E-01,.1273000E-01/ - - data absa( 1:180, 5) / & - & .6909800E-02,.8465000E-01,.1300600E+00,.1665200E+00,.1960800E+00,& - & .2197500E+00,.2349600E+00,.2327700E+00,.1800700E+00,.7820000E-02,& - & .8927900E-01,.1363000E+00,.1740900E+00,.2039800E+00,.2271800E+00,& - & .2412900E+00,.2375000E+00,.1843800E+00,.8978700E-02,.9442800E-01,& - & .1429600E+00,.1817000E+00,.2120500E+00,.2345000E+00,.2472600E+00,& - & .2417200E+00,.1887800E+00,.1042600E-01,.1000300E+00,.1500900E+00,& - & .1894300E+00,.2201500E+00,.2420600E+00,.2534100E+00,.2457100E+00,& - & .1932500E+00,.1220900E-01,.1060300E+00,.1578100E+00,.1975600E+00,& - & .2283200E+00,.2496300E+00,.2595700E+00,.2495800E+00,.1974800E+00,& - & .6402000E-02,.7459700E-01,.1145800E+00,.1458100E+00,.1710300E+00,& - & .1910500E+00,.2041200E+00,.2013300E+00,.1524200E+00,.7258600E-02,& - & .7885700E-01,.1202400E+00,.1525700E+00,.1779600E+00,.1976500E+00,& - & .2097200E+00,.2054800E+00,.1562000E+00,.8290300E-02,.8360200E-01,& - & .1262300E+00,.1593100E+00,.1851200E+00,.2042300E+00,.2150300E+00,& - & .2093700E+00,.1599300E+00,.9457800E-02,.8866800E-01,.1327700E+00,& - & .1663500E+00,.1923300E+00,.2109800E+00,.2205000E+00,.2129400E+00,& - & .1639700E+00,.1086500E-01,.9411300E-01,.1398700E+00,.1737500E+00,& - & .1997500E+00,.2177100E+00,.2259200E+00,.2163900E+00,.1674500E+00,& - & .5694300E-02,.6408400E-01,.9929400E-01,.1261400E+00,.1474600E+00,& - & .1641400E+00,.1750300E+00,.1725500E+00,.1273800E+00,.6470200E-02,& - & .6796700E-01,.1042700E+00,.1319700E+00,.1535000E+00,.1698500E+00,& - & .1800800E+00,.1763100E+00,.1308700E+00,.7420000E-02,.7225200E-01,& - & .1095600E+00,.1380100E+00,.1597800E+00,.1756700E+00,.1847600E+00,& - & .1797700E+00,.1342100E+00,.8490700E-02,.7677200E-01,.1153900E+00,& - & .1442700E+00,.1661500E+00,.1816800E+00,.1894700E+00,.1830000E+00,& - & .1376100E+00,.9707800E-02,.8167100E-01,.1217200E+00,.1508200E+00,& - & .1727700E+00,.1876900E+00,.1942700E+00,.1860800E+00,.1406700E+00,& - & .4882900E-02,.5438300E-01,.8507500E-01,.1081500E+00,.1263800E+00,& - & .1402000E+00,.1490300E+00,.1467000E+00,.1061400E+00,.5574000E-02,& - & .5777900E-01,.8943600E-01,.1132300E+00,.1316000E+00,.1451400E+00,& - & .1534900E+00,.1502700E+00,.1094900E+00,.6401500E-02,.6154600E-01,& - & .9413900E-01,.1185000E+00,.1370100E+00,.1501700E+00,.1575700E+00,& - & .1534400E+00,.1125700E+00,.7371900E-02,.6552100E-01,.9923200E-01,& - & .1240300E+00,.1425900E+00,.1554100E+00,.1617500E+00,.1563400E+00,& - & .1155700E+00,.8478900E-02,.6981000E-01,.1047800E+00,.1298500E+00,& - & .1484000E+00,.1607100E+00,.1659700E+00,.1591000E+00,.1183300E+00/ - - data absa(181:315, 5) / & - & .4135700E-02,.4587800E-01,.7186600E-01,.9213000E-01,.1077200E+00,& - & .1193500E+00,.1262700E+00,.1238200E+00,.8849000E-01,.4727800E-02,& - & .4880900E-01,.7572400E-01,.9648500E-01,.1121800E+00,.1236300E+00,& - & .1302300E+00,.1272300E+00,.9164600E-01,.5423400E-02,.5210800E-01,& - & .7992500E-01,.1010500E+00,.1168400E+00,.1279500E+00,.1338900E+00,& - & .1302400E+00,.9438400E-01,.6267200E-02,.5564700E-01,.8443800E-01,& - & .1059100E+00,.1216700E+00,.1325500E+00,.1375900E+00,.1328800E+00,& - & .9703700E-01,.7238700E-02,.5939300E-01,.8932600E-01,.1110200E+00,& - & .1268000E+00,.1372300E+00,.1412800E+00,.1353000E+00,.9958500E-01,& - & .3482000E-02,.3845500E-01,.6010600E-01,.7751500E-01,.9114300E-01,& - & .1009400E+00,.1064900E+00,.1040300E+00,.7350900E-01,.3950700E-02,& - & .4092700E-01,.6340200E-01,.8124000E-01,.9496800E-01,.1046900E+00,& - & .1100100E+00,.1071700E+00,.7642600E-01,.4526600E-02,.4372600E-01,& - & .6704100E-01,.8523400E-01,.9891100E-01,.1084500E+00,.1132900E+00,& - & .1099600E+00,.7886100E-01,.5224200E-02,.4680700E-01,.7093900E-01,& - & .8954700E-01,.1031200E+00,.1124700E+00,.1165300E+00,.1123700E+00,& - & .8125000E-01,.6044900E-02,.5008300E-01,.7517500E-01,.9404100E-01,& - & .1076000E+00,.1165700E+00,.1198000E+00,.1144900E+00,.8354900E-01,& - & .2871100E-02,.3252300E-01,.4997100E-01,.6459700E-01,.7636000E-01,& - & .8491800E-01,.8952300E-01,.8720000E-01,.6061800E-01,.3255000E-02,& - & .3461400E-01,.5280300E-01,.6774000E-01,.7971300E-01,.8820700E-01,& - & .9268100E-01,.9006000E-01,.6333100E-01,.3726300E-02,.3696800E-01,& - & .5590400E-01,.7115300E-01,.8314300E-01,.9150900E-01,.9560700E-01,& - & .9256400E-01,.6559500E-01,.4295300E-02,.3953800E-01,.5928100E-01,& - & .7491200E-01,.8682200E-01,.9495600E-01,.9843800E-01,.9472800E-01,& - & .6768000E-01,.4978800E-02,.4226400E-01,.6295300E-01,.7884200E-01,& - & .9074200E-01,.9851000E-01,.1012900E+00,.9664100E-01,.6974600E-01/ - - data absa(316:450, 5) / & - & .2348000E-02,.2723000E-01,.4167100E-01,.5356500E-01,.6343600E-01,& - & .7099900E-01,.7502000E-01,.7290600E-01,.4938600E-01,.2651700E-02,& - & .2906500E-01,.4401700E-01,.5622500E-01,.6634100E-01,.7393500E-01,& - & .7787900E-01,.7546800E-01,.5175000E-01,.3028500E-02,.3111200E-01,& - & .4659800E-01,.5916100E-01,.6930200E-01,.7680900E-01,.8043900E-01,& - & .7772900E-01,.5390400E-01,.3481600E-02,.3334800E-01,.4944800E-01,& - & .6238000E-01,.7250200E-01,.7978600E-01,.8288700E-01,.7968300E-01,& - & .5573100E-01,.4044400E-02,.3573000E-01,.5254500E-01,.6579400E-01,& - & .7587800E-01,.8288900E-01,.8537900E-01,.8139100E-01,.5750900E-01,& - & .1924700E-02,.2263000E-01,.3475200E-01,.4438700E-01,.5245500E-01,& - & .5883300E-01,.6246800E-01,.6071900E-01,.4188000E-01,.2155700E-02,& - & .2420400E-01,.3675000E-01,.4663600E-01,.5497600E-01,.6142100E-01,& - & .6505200E-01,.6299400E-01,.4401000E-01,.2447700E-02,.2595800E-01,& - & .3898100E-01,.4910800E-01,.5752600E-01,.6390700E-01,.6735100E-01,& - & .6503800E-01,.4592900E-01,.2819600E-02,.2788200E-01,.4143100E-01,& - & .5180200E-01,.6024900E-01,.6648000E-01,.6946700E-01,.6678800E-01,& - & .4755500E-01,.3265400E-02,.2993900E-01,.4407200E-01,.5471400E-01,& - & .6316300E-01,.6920700E-01,.7160000E-01,.6832800E-01,.4907700E-01,& - & .1620000E-02,.1881400E-01,.2891100E-01,.3702500E-01,.4347900E-01,& - & .4869100E-01,.5176700E-01,.5051700E-01,.3656500E-01,.1803100E-02,& - & .2015000E-01,.3063200E-01,.3896700E-01,.4560900E-01,.5094000E-01,& - & .5404600E-01,.5251500E-01,.3842500E-01,.2023200E-02,.2164000E-01,& - & .3257200E-01,.4107900E-01,.4778800E-01,.5310100E-01,.5611400E-01,& - & .5433800E-01,.4016200E-01,.2303800E-02,.2329800E-01,.3470300E-01,& - & .4339300E-01,.5011000E-01,.5529800E-01,.5798200E-01,.5587300E-01,& - & .4178200E-01,.2664900E-02,.2507300E-01,.3698300E-01,.4586800E-01,& - & .5261700E-01,.5764100E-01,.5983300E-01,.5722200E-01,.4324300E-01/ - - data absa(451:585, 5) / & - & .1424100E-02,.1606500E-01,.2458600E-01,.3146500E-01,.3696300E-01,& - & .4109300E-01,.4361700E-01,.4267300E-01,.3234300E-01,.1587800E-02,& - & .1726800E-01,.2614400E-01,.3316900E-01,.3881600E-01,.4298800E-01,& - & .4554600E-01,.4432700E-01,.3405400E-01,.1800300E-02,.1860900E-01,& - & .2788800E-01,.3506600E-01,.4071700E-01,.4486100E-01,.4727700E-01,& - & .4584500E-01,.3556200E-01,.2051300E-02,.2006900E-01,.2979400E-01,& - & .3714700E-01,.4278100E-01,.4677400E-01,.4886900E-01,.4710600E-01,& - & .3688100E-01,.2361000E-02,.2163600E-01,.3178600E-01,.3934100E-01,& - & .4496400E-01,.4883200E-01,.5047800E-01,.4823700E-01,.3813600E-01,& - & .1236700E-02,.1366400E-01,.2084100E-01,.2661900E-01,.3125800E-01,& - & .3476600E-01,.3666500E-01,.3587300E-01,.2781100E-01,.1389800E-02,& - & .1474700E-01,.2223800E-01,.2813400E-01,.3287600E-01,.3639200E-01,& - & .3828600E-01,.3725700E-01,.2921200E-01,.1582200E-02,.1592000E-01,& - & .2380800E-01,.2983000E-01,.3455800E-01,.3801400E-01,.3972800E-01,& - & .3849300E-01,.3051700E-01,.1811700E-02,.1719500E-01,.2547900E-01,& - & .3166400E-01,.3637800E-01,.3967500E-01,.4109800E-01,.3955300E-01,& - & .3170500E-01,.2099600E-02,.1856700E-01,.2722500E-01,.3357100E-01,& - & .3830200E-01,.4143700E-01,.4250100E-01,.4052500E-01,.3274800E-01,& - & .1060600E-02,.1159400E-01,.1761600E-01,.2245600E-01,.2633700E-01,& - & .2928200E-01,.3083100E-01,.3003700E-01,.2325100E-01,.1197500E-02,& - & .1254100E-01,.1885000E-01,.2379500E-01,.2774500E-01,.3067600E-01,& - & .3219100E-01,.3118600E-01,.2446100E-01,.1368600E-02,.1355700E-01,& - & .2023600E-01,.2528700E-01,.2922400E-01,.3208500E-01,.3341100E-01,& - & .3219000E-01,.2553900E-01,.1578700E-02,.1465500E-01,.2168500E-01,& - & .2688700E-01,.3082100E-01,.3353300E-01,.3458100E-01,.3309100E-01,& - & .2648300E-01,.1842200E-02,.1584700E-01,.2320100E-01,.2853500E-01,& - & .3248600E-01,.3505900E-01,.3579100E-01,.3394200E-01,.2734000E-01/ - - data absa( 1:180, 6) / & - & .3839378E+00,.6279180E+00,.7318272E+00,.7920608E+00,.8216785E+00,& - & .8230008E+00,.7947126E+00,.7302326E+00,.5811177E+00,.4128871E+00,& - & .6485557E+00,.7485293E+00,.8043995E+00,.8308183E+00,.8293298E+00,& - & .7988096E+00,.7334673E+00,.5866991E+00,.4408435E+00,.6690805E+00,& - & .7652913E+00,.8177871E+00,.8406473E+00,.8361296E+00,.8033672E+00,& - & .7370020E+00,.5912609E+00,.4672892E+00,.6894163E+00,.7820258E+00,& - & .8313814E+00,.8509556E+00,.8436351E+00,.8085369E+00,.7402632E+00,& - & .5956103E+00,.4927709E+00,.7092005E+00,.7986459E+00,.8452246E+00,& - & .8615155E+00,.8516325E+00,.8138231E+00,.7437317E+00,.5997054E+00,& - & .3325679E+00,.5548358E+00,.6461479E+00,.6995525E+00,.7253118E+00,& - & .7266814E+00,.7024839E+00,.6480527E+00,.5065275E+00,.3575484E+00,& - & .5737759E+00,.6620339E+00,.7123154E+00,.7348811E+00,.7336335E+00,& - & .7074669E+00,.6519501E+00,.5119171E+00,.3814205E+00,.5923353E+00,& - & .6775822E+00,.7253565E+00,.7450096E+00,.7412995E+00,.7131653E+00,& - & .6558395E+00,.5167702E+00,.4042236E+00,.6103975E+00,.6930426E+00,& - & .7383493E+00,.7554787E+00,.7494988E+00,.7190075E+00,.6598135E+00,& - & .5211434E+00,.4265822E+00,.6282698E+00,.7082747E+00,.7513798E+00,& - & .7663755E+00,.7576413E+00,.7252801E+00,.6640475E+00,.5252205E+00,& - & .2819028E+00,.4836690E+00,.5649400E+00,.6121709E+00,.6347883E+00,& - & .6367827E+00,.6170448E+00,.5707116E+00,.4371090E+00,.3032609E+00,& - & .5006309E+00,.5795105E+00,.6243936E+00,.6444057E+00,.6442898E+00,& - & .6228572E+00,.5750819E+00,.4422485E+00,.3236861E+00,.5170268E+00,& - & .5937689E+00,.6365222E+00,.6544181E+00,.6524051E+00,.6289736E+00,& - & .5795020E+00,.4469729E+00,.3434421E+00,.5330792E+00,.6078864E+00,& - & .6485227E+00,.6647491E+00,.6605735E+00,.6354043E+00,.5840256E+00,& - & .4512681E+00,.3630007E+00,.5490413E+00,.6217655E+00,.6606764E+00,& - & .6752251E+00,.6688803E+00,.6420320E+00,.5886154E+00,.4550732E+00,& - & .2364425E+00,.4182373E+00,.4906262E+00,.5320011E+00,.5523509E+00,& - & .5548703E+00,.5383899E+00,.4987899E+00,.3768887E+00,.2546801E+00,& - & .4331987E+00,.5037554E+00,.5432869E+00,.5616903E+00,.5626459E+00,& - & .5445887E+00,.5034773E+00,.3818393E+00,.2721315E+00,.4476600E+00,& - & .5164741E+00,.5543752E+00,.5713544E+00,.5708581E+00,.5510757E+00,& - & .5081946E+00,.3862452E+00,.2892043E+00,.4618692E+00,.5290503E+00,& - & .5654304E+00,.5811711E+00,.5789470E+00,.5577046E+00,.5130234E+00,& - & .3902090E+00,.3062774E+00,.4761272E+00,.5414198E+00,.5765335E+00,& - & .5909044E+00,.5871126E+00,.5644694E+00,.5178294E+00,.3937875E+00/ - - data absa(181:315, 6) / & - & .1976097E+00,.3599556E+00,.4238261E+00,.4601500E+00,.4784937E+00,& - & .4808783E+00,.4668807E+00,.4328773E+00,.3243113E+00,.2131404E+00,& - & .3730680E+00,.4353477E+00,.4703740E+00,.4874113E+00,.4885689E+00,& - & .4731711E+00,.4377759E+00,.3288869E+00,.2280961E+00,.3857179E+00,& - & .4465292E+00,.4804726E+00,.4964950E+00,.4964579E+00,.4796823E+00,& - & .4426578E+00,.3330323E+00,.2427415E+00,.3981437E+00,.4574729E+00,& - & .4906220E+00,.5055377E+00,.5041976E+00,.4863363E+00,.4474608E+00,& - & .3367502E+00,.2574916E+00,.4108035E+00,.4685214E+00,.5005586E+00,& - & .5144711E+00,.5119125E+00,.4929884E+00,.4523415E+00,.3400646E+00,& - & .1644599E+00,.3082155E+00,.3641066E+00,.3958133E+00,.4120577E+00,& - & .4144583E+00,.4024002E+00,.3731548E+00,.2772332E+00,.1776815E+00,& - & .3195976E+00,.3741572E+00,.4049902E+00,.4203131E+00,.4217397E+00,& - & .4086238E+00,.3780822E+00,.2815278E+00,.1904154E+00,.3305911E+00,& - & .3838882E+00,.4140681E+00,.4286082E+00,.4290731E+00,.4150352E+00,& - & .3829532E+00,.2854673E+00,.2029594E+00,.3414094E+00,.3935449E+00,& - & .4230885E+00,.4367885E+00,.4362952E+00,.4213065E+00,.3877874E+00,& - & .2889571E+00,.2156141E+00,.3525176E+00,.4033758E+00,.4319990E+00,& - & .4448634E+00,.4434057E+00,.4275549E+00,.3926902E+00,.2921021E+00,& - & .1365354E+00,.2627938E+00,.3116032E+00,.3390470E+00,.3531982E+00,& - & .3553931E+00,.3450681E+00,.3195057E+00,.2355642E+00,.1476945E+00,& - & .2725931E+00,.3203697E+00,.3471668E+00,.3606270E+00,.3621563E+00,& - & .3510351E+00,.3243608E+00,.2395644E+00,.1584917E+00,.2820807E+00,& - & .3288732E+00,.3551503E+00,.3679817E+00,.3688657E+00,.3570843E+00,& - & .3290971E+00,.2432894E+00,.1692002E+00,.2914586E+00,.3373668E+00,& - & .3630273E+00,.3752511E+00,.3754063E+00,.3629045E+00,.3338612E+00,& - & .2465948E+00,.1800234E+00,.3011255E+00,.3460817E+00,.3709814E+00,& - & .3824342E+00,.3817964E+00,.3686830E+00,.3386098E+00,.2495277E+00/ - - data absa(316:450, 6) / & - & .1130524E+00,.2235733E+00,.2655973E+00,.2894880E+00,.3015165E+00,& - & .3032589E+00,.2943333E+00,.2719817E+00,.1988483E+00,.1224152E+00,& - & .2318861E+00,.2733317E+00,.2965534E+00,.3081331E+00,.3094246E+00,& - & .2999446E+00,.2766238E+00,.2026511E+00,.1315214E+00,.2399609E+00,& - & .2807287E+00,.3034743E+00,.3145900E+00,.3154081E+00,.3054644E+00,& - & .2811905E+00,.2060707E+00,.1406060E+00,.2479709E+00,.2881554E+00,& - & .3103325E+00,.3209441E+00,.3212333E+00,.3107742E+00,.2857474E+00,& - & .2091635E+00,.1498138E+00,.2563308E+00,.2958019E+00,.3173622E+00,& - & .3271974E+00,.3269371E+00,.3159983E+00,.2902250E+00,.2119359E+00,& - & .9301188E-01,.1895129E+00,.2254431E+00,.2461449E+00,.2564128E+00,& - & .2576877E+00,.2498578E+00,.2303767E+00,.1659328E+00,.1009065E+00,& - & .1965526E+00,.2321100E+00,.2522877E+00,.2622065E+00,.2632244E+00,& - & .2549826E+00,.2347053E+00,.1694537E+00,.1085578E+00,.2034287E+00,& - & .2384465E+00,.2583058E+00,.2678405E+00,.2684545E+00,.2599040E+00,& - & .2390279E+00,.1725782E+00,.1162137E+00,.2102907E+00,.2448387E+00,& - & .2642935E+00,.2733148E+00,.2735764E+00,.2646745E+00,.2432888E+00,& - & .1754745E+00,.1240561E+00,.2175246E+00,.2515388E+00,.2703899E+00,& - & .2788204E+00,.2785885E+00,.2693407E+00,.2473703E+00,.1781073E+00,& - & .7640796E-01,.1603808E+00,.1911818E+00,.2086778E+00,.2175552E+00,& - & .2186307E+00,.2116034E+00,.1944515E+00,.1456540E+00,.8306947E-01,& - & .1663339E+00,.1968047E+00,.2139806E+00,.2226600E+00,.2234720E+00,& - & .2162217E+00,.1984391E+00,.1487611E+00,.8952871E-01,.1721996E+00,& - & .2022331E+00,.2191642E+00,.2275327E+00,.2280233E+00,.2205353E+00,& - & .2024797E+00,.1513787E+00,.9600912E-01,.1780570E+00,.2077289E+00,& - & .2243376E+00,.2322476E+00,.2324865E+00,.2247285E+00,.2063451E+00,& - & .1537312E+00,.1026970E+00,.1842930E+00,.2135640E+00,.2296382E+00,& - & .2370510E+00,.2368348E+00,.2288014E+00,.2100442E+00,.1559266E+00/ - - data absa(451:585, 6) / & - & .6498651E-01,.1372893E+00,.1636307E+00,.1784508E+00,.1858229E+00,& - & .1867364E+00,.1805030E+00,.1651282E+00,.1253243E+00,.7051877E-01,& - & .1422924E+00,.1682882E+00,.1829691E+00,.1901293E+00,.1907854E+00,& - & .1844056E+00,.1688531E+00,.1278858E+00,.7594246E-01,.1472381E+00,& - & .1729539E+00,.1873767E+00,.1942330E+00,.1947083E+00,.1880933E+00,& - & .1724213E+00,.1301325E+00,.8152013E-01,.1524039E+00,.1778017E+00,& - & .1918315E+00,.1983471E+00,.1985237E+00,.1916908E+00,.1757953E+00,& - & .1322663E+00,.8732427E-01,.1579555E+00,.1829727E+00,.1965737E+00,& - & .2026361E+00,.2023437E+00,.1952484E+00,.1791155E+00,.1342170E+00,& - & .5506321E-01,.1168681E+00,.1392111E+00,.1518638E+00,.1581057E+00,& - & .1587078E+00,.1534476E+00,.1400850E+00,.1080712E+00,.5967938E-01,& - & .1210769E+00,.1431802E+00,.1556769E+00,.1617277E+00,.1621446E+00,& - & .1567559E+00,.1434036E+00,.1102933E+00,.6432180E-01,.1253570E+00,& - & .1472032E+00,.1594570E+00,.1652341E+00,.1654796E+00,.1599072E+00,& - & .1464712E+00,.1123711E+00,.6912124E-01,.1299527E+00,.1515000E+00,& - & .1634309E+00,.1688516E+00,.1687937E+00,.1630152E+00,.1494484E+00,& - & .1143749E+00,.7411322E-01,.1349524E+00,.1561843E+00,.1676813E+00,& - & .1726787E+00,.1722628E+00,.1662240E+00,.1523717E+00,.1162707E+00,& - & .4671501E-01,.9906607E-01,.1179218E+00,.1285633E+00,.1338684E+00,& - & .1344469E+00,.1299950E+00,.1186902E+00,.9160652E-01,.5062345E-01,& - & .1026419E+00,.1213067E+00,.1318081E+00,.1369356E+00,.1373840E+00,& - & .1328006E+00,.1215065E+00,.9359446E-01,.5459974E-01,.1064175E+00,& - & .1248279E+00,.1351247E+00,.1399943E+00,.1402452E+00,.1355160E+00,& - & .1241771E+00,.9556170E-01,.5873868E-01,.1105265E+00,.1286741E+00,& - & .1386392E+00,.1431974E+00,.1431960E+00,.1382828E+00,.1267833E+00,& - & .9738167E-01,.6302475E-01,.1149971E+00,.1329313E+00,.1425338E+00,& - & .1467358E+00,.1463643E+00,.1411782E+00,.1293360E+00,.9929140E-01/ - - data absa( 1:180, 7) / & - & .2084400E+01,.2334400E+01,.2557600E+01,.2670100E+01,.2701000E+01,& - & .2668100E+01,.2568300E+01,.2365500E+01,.2081000E+01,.2080700E+01,& - & .2330400E+01,.2548900E+01,.2661100E+01,.2692000E+01,.2660900E+01,& - & .2564700E+01,.2364500E+01,.2085900E+01,.2087700E+01,.2334200E+01,& - & .2547700E+01,.2654800E+01,.2684300E+01,.2654100E+01,.2560500E+01,& - & .2363700E+01,.2090300E+01,.2105200E+01,.2345400E+01,.2552000E+01,& - & .2652900E+01,.2677800E+01,.2647800E+01,.2556500E+01,.2363000E+01,& - & .2093500E+01,.2130300E+01,.2363300E+01,.2561900E+01,.2654600E+01,& - & .2674900E+01,.2642900E+01,.2554200E+01,.2361900E+01,.2095800E+01,& - & .1812000E+01,.2110100E+01,.2320400E+01,.2426600E+01,.2465700E+01,& - & .2446900E+01,.2370200E+01,.2193100E+01,.1866900E+01,.1818700E+01,& - & .2113700E+01,.2318800E+01,.2422300E+01,.2462000E+01,.2443600E+01,& - & .2368700E+01,.2194400E+01,.1872600E+01,.1835600E+01,.2125500E+01,& - & .2325600E+01,.2423200E+01,.2459000E+01,.2440700E+01,.2367400E+01,& - & .2196000E+01,.1877600E+01,.1861400E+01,.2144700E+01,.2338600E+01,& - & .2428700E+01,.2459500E+01,.2438700E+01,.2367200E+01,.2197000E+01,& - & .1881600E+01,.1892700E+01,.2168300E+01,.2357900E+01,.2439200E+01,& - & .2463600E+01,.2440700E+01,.2366500E+01,.2197400E+01,.1886400E+01,& - & .1570200E+01,.1894200E+01,.2083700E+01,.2185400E+01,.2232400E+01,& - & .2226600E+01,.2164900E+01,.2013400E+01,.1661700E+01,.1582700E+01,& - & .1903800E+01,.2088600E+01,.2186500E+01,.2232900E+01,.2226600E+01,& - & .2164900E+01,.2016700E+01,.1669500E+01,.1604600E+01,.1921300E+01,& - & .2101900E+01,.2194200E+01,.2236000E+01,.2227100E+01,.2166500E+01,& - & .2019500E+01,.1676200E+01,.1632900E+01,.1944300E+01,.2121300E+01,& - & .2207000E+01,.2242400E+01,.2231100E+01,.2168300E+01,.2021400E+01,& - & .1683000E+01,.1665800E+01,.1971700E+01,.2145200E+01,.2225100E+01,& - & .2253000E+01,.2237100E+01,.2170800E+01,.2023800E+01,.1690400E+01,& - & .1356400E+01,.1686900E+01,.1855000E+01,.1953700E+01,.2004900E+01,& - & .2008500E+01,.1960100E+01,.1828700E+01,.1475600E+01,.1372000E+01,& - & .1700000E+01,.1865500E+01,.1960700E+01,.2010000E+01,.2010500E+01,& - & .1962200E+01,.1833900E+01,.1485400E+01,.1395200E+01,.1720400E+01,& - & .1883700E+01,.1974000E+01,.2018200E+01,.2015400E+01,.1965400E+01,& - & .1838400E+01,.1494800E+01,.1422900E+01,.1746100E+01,.1907200E+01,& - & .1992600E+01,.2030300E+01,.2023400E+01,.1969100E+01,.1842000E+01,& - & .1504000E+01,.1453400E+01,.1775100E+01,.1934500E+01,.2015400E+01,& - & .2046700E+01,.2033700E+01,.1974200E+01,.1846500E+01,.1513100E+01/ - - data absa(181:315, 7) / & - & .1167500E+01,.1490600E+01,.1642200E+01,.1736400E+01,.1787500E+01,& - & .1797000E+01,.1758200E+01,.1645900E+01,.1305700E+01,.1183900E+01,& - & .1506200E+01,.1657300E+01,.1748300E+01,.1795600E+01,.1802000E+01,& - & .1762300E+01,.1652900E+01,.1317600E+01,.1206100E+01,.1528100E+01,& - & .1679000E+01,.1766000E+01,.1808200E+01,.1810600E+01,.1767800E+01,& - & .1658700E+01,.1328900E+01,.1231100E+01,.1554900E+01,.1704800E+01,& - & .1787700E+01,.1825000E+01,.1822200E+01,.1774200E+01,.1664400E+01,& - & .1339800E+01,.1258200E+01,.1583600E+01,.1733800E+01,.1813100E+01,& - & .1845700E+01,.1835900E+01,.1782600E+01,.1671000E+01,.1350700E+01,& - & .9998100E+00,.1308000E+01,.1447700E+01,.1535600E+01,.1582900E+01,& - & .1593600E+01,.1563600E+01,.1468300E+01,.1148200E+01,.1015100E+01,& - & .1325100E+01,.1465500E+01,.1550400E+01,.1594100E+01,.1601500E+01,& - & .1569800E+01,.1476700E+01,.1161900E+01,.1034400E+01,.1347600E+01,& - & .1488700E+01,.1570200E+01,.1609700E+01,.1613000E+01,.1577200E+01,& - & .1484700E+01,.1174300E+01,.1056000E+01,.1373500E+01,.1515500E+01,& - & .1593900E+01,.1629300E+01,.1627600E+01,.1587000E+01,.1492400E+01,& - & .1186400E+01,.1079400E+01,.1399600E+01,.1543800E+01,.1620500E+01,& - & .1652100E+01,.1645100E+01,.1599100E+01,.1500300E+01,.1198200E+01,& - & .8523900E+00,.1141900E+01,.1271400E+01,.1350700E+01,.1393000E+01,& - & .1403900E+01,.1379000E+01,.1297100E+01,.1003400E+01,.8654200E+00,& - & .1159100E+01,.1289800E+01,.1367000E+01,.1406200E+01,.1413900E+01,& - & .1387100E+01,.1307200E+01,.1017900E+01,.8810800E+00,.1180900E+01,& - & .1313000E+01,.1388000E+01,.1424100E+01,.1427800E+01,.1397500E+01,& - & .1317200E+01,.1031000E+01,.8990000E+00,.1204100E+01,.1339000E+01,& - & .1412300E+01,.1445500E+01,.1445300E+01,.1410500E+01,.1326600E+01,& - & .1043400E+01,.9186200E+00,.1227900E+01,.1364900E+01,.1438600E+01,& - & .1469200E+01,.1466400E+01,.1425400E+01,.1336700E+01,.1055800E+01/ - - data absa(316:450, 7) / & - & .7249700E+00,.9920100E+00,.1110700E+01,.1181300E+01,.1219500E+01,& - & .1228500E+01,.1205800E+01,.1135900E+01,.8711000E+00,.7351700E+00,& - & .1008600E+01,.1128500E+01,.1198800E+01,.1234200E+01,.1240500E+01,& - & .1216000E+01,.1147900E+01,.8856800E+00,.7475200E+00,.1028500E+01,& - & .1150700E+01,.1219800E+01,.1253200E+01,.1257000E+01,.1228900E+01,& - & .1158900E+01,.8992700E+00,.7621300E+00,.1048900E+01,.1174700E+01,& - & .1243600E+01,.1275700E+01,.1276900E+01,.1244500E+01,.1170000E+01,& - & .9120300E+00,.7785400E+00,.1069700E+01,.1198000E+01,.1267900E+01,& - & .1300200E+01,.1299400E+01,.1262100E+01,.1181600E+01,.9239200E+00,& - & .6168200E+00,.8584100E+00,.9640300E+00,.1027200E+01,.1060600E+01,& - & .1067900E+01,.1047200E+01,.9871500E+00,.7482500E+00,.6241500E+00,& - & .8740100E+00,.9814000E+00,.1044600E+01,.1076300E+01,.1081100E+01,& - & .1059300E+01,.1000300E+01,.7629400E+00,.6338700E+00,.8910400E+00,& - & .1002200E+01,.1065100E+01,.1096200E+01,.1099700E+01,.1074000E+01,& - & .1012000E+01,.7765900E+00,.6454200E+00,.9087200E+00,.1023000E+01,& - & .1087800E+01,.1118800E+01,.1120700E+01,.1091100E+01,.1024300E+01,& - & .7890500E+00,.6590000E+00,.9267400E+00,.1043600E+01,.1110300E+01,& - & .1142400E+01,.1143500E+01,.1110200E+01,.1037500E+01,.8003400E+00,& - & .5254700E+00,.7422000E+00,.8343300E+00,.8889000E+00,.9174100E+00,& - & .9233600E+00,.9053800E+00,.8531100E+00,.6469600E+00,.5306400E+00,& - & .7560400E+00,.8510700E+00,.9058400E+00,.9336100E+00,.9383600E+00,& - & .9186100E+00,.8662600E+00,.6606200E+00,.5380900E+00,.7703700E+00,& - & .8694200E+00,.9256200E+00,.9540900E+00,.9577400E+00,.9342300E+00,& - & .8787100E+00,.6739100E+00,.5473400E+00,.7857600E+00,.8873400E+00,& - & .9463400E+00,.9761100E+00,.9789000E+00,.9525300E+00,.8919100E+00,& - & .6852600E+00,.5584200E+00,.8012900E+00,.9054200E+00,.9667500E+00,& - & .9978100E+00,.1001300E+01,.9725300E+00,.9059700E+00,.6958300E+00/ - - data absa(451:585, 7) / & - & .4490200E+00,.6464100E+00,.7268200E+00,.7729500E+00,.7967900E+00,& - & .8009500E+00,.7847800E+00,.7388000E+00,.5750000E+00,.4534300E+00,& - & .6581900E+00,.7425900E+00,.7903000E+00,.8150900E+00,.8186600E+00,& - & .7996000E+00,.7513700E+00,.5878400E+00,.4596800E+00,.6709400E+00,& - & .7581200E+00,.8089800E+00,.8352200E+00,.8385400E+00,.8171100E+00,& - & .7646100E+00,.5993900E+00,.4676400E+00,.6841800E+00,.7740200E+00,& - & .8271100E+00,.8551800E+00,.8596800E+00,.8363400E+00,.7785900E+00,& - & .6095400E+00,.4775000E+00,.6979800E+00,.7902100E+00,.8453400E+00,& - & .8748000E+00,.8801100E+00,.8559500E+00,.7926900E+00,.6189600E+00,& - & .3825200E+00,.5612300E+00,.6322100E+00,.6720700E+00,.6919100E+00,& - & .6945100E+00,.6785300E+00,.6367100E+00,.4962400E+00,.3861000E+00,& - & .5715200E+00,.6455900E+00,.6885700E+00,.7099200E+00,.7125000E+00,& - & .6944000E+00,.6494800E+00,.5077200E+00,.3913500E+00,.5825100E+00,& - & .6595300E+00,.7045900E+00,.7279300E+00,.7318800E+00,.7125100E+00,& - & .6631400E+00,.5177100E+00,.3983800E+00,.5940600E+00,.6735700E+00,& - & .7206600E+00,.7457000E+00,.7507500E+00,.7310800E+00,.6769600E+00,& - & .5268000E+00,.4078500E+00,.6062800E+00,.6880200E+00,.7368500E+00,& - & .7634200E+00,.7684200E+00,.7485700E+00,.6913500E+00,.5340800E+00,& - & .3229700E+00,.4855600E+00,.5476000E+00,.5835000E+00,.6007900E+00,& - & .6011600E+00,.5851800E+00,.5469900E+00,.4227600E+00,.3259100E+00,& - & .4944500E+00,.5596300E+00,.5976400E+00,.6165400E+00,.6184400E+00,& - & .6014900E+00,.5597300E+00,.4328000E+00,.3305700E+00,.5040500E+00,& - & .5718400E+00,.6118600E+00,.6323900E+00,.6355700E+00,.6186400E+00,& - & .5730500E+00,.4415100E+00,.3370500E+00,.5142700E+00,.5842800E+00,& - & .6261400E+00,.6482500E+00,.6517500E+00,.6349200E+00,.5868900E+00,& - & .4489300E+00,.3463600E+00,.5254400E+00,.5974000E+00,.6405500E+00,& - & .6634200E+00,.6673600E+00,.6500200E+00,.6005500E+00,.4548700E+00/ - - data absa( 1:180, 8) / & - & .8454475E+01,.7946981E+01,.8106902E+01,.8293415E+01,.8302744E+01,& - & .8132473E+01,.7748332E+01,.7379908E+01,.7837216E+01,.8369020E+01,& - & .7875895E+01,.8045177E+01,.8244563E+01,.8270709E+01,.8116300E+01,& - & .7749859E+01,.7393894E+01,.7847366E+01,.8285211E+01,.7804773E+01,& - & .7981608E+01,.8194058E+01,.8236878E+01,.8095655E+01,.7745523E+01,& - & .7401744E+01,.7853486E+01,.8206631E+01,.7736200E+01,.7920325E+01,& - & .8142313E+01,.8201279E+01,.8071188E+01,.7732988E+01,.7403543E+01,& - & .7855384E+01,.8131353E+01,.7669212E+01,.7859419E+01,.8089006E+01,& - & .8160968E+01,.8041936E+01,.7714112E+01,.7402770E+01,.7854506E+01,& - & .8035329E+01,.7711984E+01,.8054326E+01,.8312552E+01,.8382878E+01,& - & .8255716E+01,.7865615E+01,.7362355E+01,.7659280E+01,.7952578E+01,& - & .7639845E+01,.7991063E+01,.8263177E+01,.8347848E+01,.8239605E+01,& - & .7870529E+01,.7384107E+01,.7682523E+01,.7876313E+01,.7571250E+01,& - & .7929061E+01,.8212430E+01,.8313538E+01,.8219780E+01,.7866208E+01,& - & .7395265E+01,.7697467E+01,.7805455E+01,.7505993E+01,.7868255E+01,& - & .8161157E+01,.8275309E+01,.8195732E+01,.7853413E+01,.7398979E+01,& - & .7704855E+01,.7742281E+01,.7447306E+01,.7808392E+01,.8111167E+01,& - & .8233033E+01,.8164826E+01,.7836884E+01,.7399520E+01,.7708591E+01,& - & .7532706E+01,.7422731E+01,.7921038E+01,.8241749E+01,.8361773E+01,& - & .8264953E+01,.7883764E+01,.7273843E+01,.7366162E+01,.7456853E+01,& - & .7352022E+01,.7858416E+01,.8192991E+01,.8327704E+01,.8251231E+01,& - & .7894283E+01,.7297668E+01,.7395152E+01,.7388143E+01,.7286773E+01,& - & .7797671E+01,.8142220E+01,.8291520E+01,.8232710E+01,.7892900E+01,& - & .7312768E+01,.7415601E+01,.7329897E+01,.7229298E+01,.7738967E+01,& - & .8093725E+01,.8253763E+01,.8209025E+01,.7884574E+01,.7322979E+01,& - & .7429711E+01,.7281243E+01,.7179080E+01,.7684292E+01,.8043638E+01,& - & .8212576E+01,.8180221E+01,.7872560E+01,.7328406E+01,.7440260E+01,& - & .6960506E+01,.7084860E+01,.7692419E+01,.8072395E+01,.8231420E+01,& - & .8158941E+01,.7802620E+01,.7115961E+01,.6985525E+01,.6890460E+01,& - & .7017186E+01,.7632657E+01,.8022920E+01,.8197430E+01,.8148687E+01,& - & .7816871E+01,.7144322E+01,.7020806E+01,.6833009E+01,.6958106E+01,& - & .7575897E+01,.7974036E+01,.8162581E+01,.8133025E+01,.7819855E+01,& - & .7167278E+01,.7050824E+01,.6788341E+01,.6907823E+01,.7522755E+01,& - & .7926643E+01,.8125775E+01,.8111753E+01,.7815827E+01,.7185676E+01,& - & .7075641E+01,.6757259E+01,.6867282E+01,.7475452E+01,.7880340E+01,& - & .8087458E+01,.8084863E+01,.7806464E+01,.7198807E+01,.7097443E+01/ - - data absa(181:315, 8) / & - & .6340185E+01,.6707242E+01,.7374216E+01,.7801587E+01,.7986307E+01,& - & .7935884E+01,.7614843E+01,.6902656E+01,.6547120E+01,.6278416E+01,& - & .6644090E+01,.7317234E+01,.7752832E+01,.7957040E+01,.7930429E+01,& - & .7630569E+01,.6936644E+01,.6589898E+01,.6232993E+01,.6592439E+01,& - & .7264591E+01,.7707509E+01,.7925533E+01,.7918826E+01,.7635078E+01,& - & .6967951E+01,.6630153E+01,.6204934E+01,.6551194E+01,.7219795E+01,& - & .7664391E+01,.7893004E+01,.7899675E+01,.7635240E+01,.6992659E+01,& - & .6663746E+01,.6191620E+01,.6521893E+01,.7181052E+01,.7625747E+01,& - & .7860409E+01,.7878371E+01,.7631859E+01,.7008584E+01,.6691435E+01,& - & .5701027E+01,.6282840E+01,.6983217E+01,.7436614E+01,.7637531E+01,& - & .7613654E+01,.7322878E+01,.6631103E+01,.6068872E+01,.5649363E+01,& - & .6225960E+01,.6931874E+01,.7392920E+01,.7615331E+01,.7612305E+01,& - & .7340268E+01,.6671266E+01,.6121220E+01,.5616215E+01,.6181108E+01,& - & .6886667E+01,.7353790E+01,.7592183E+01,.7603387E+01,.7349200E+01,& - & .6709222E+01,.6171471E+01,.5602211E+01,.6150585E+01,.6849555E+01,& - & .7318623E+01,.7568758E+01,.7589509E+01,.7355024E+01,.6738001E+01,& - & .6212573E+01,.5606495E+01,.6135466E+01,.6822413E+01,.7289641E+01,& - & .7542848E+01,.7572934E+01,.7357114E+01,.6757793E+01,.6246128E+01,& - & .5069814E+01,.5819946E+01,.6539483E+01,.6990273E+01,.7204566E+01,& - & .7201912E+01,.6945088E+01,.6305330E+01,.5574348E+01,.5026679E+01,& - & .5770074E+01,.6492443E+01,.6954397E+01,.7190065E+01,.7204039E+01,& - & .6965377E+01,.6352224E+01,.5636607E+01,.5006597E+01,.5734952E+01,& - & .6454389E+01,.6924197E+01,.7174636E+01,.7200149E+01,.6978142E+01,& - & .6394579E+01,.5692813E+01,.5006429E+01,.5716643E+01,.6426495E+01,& - & .6900048E+01,.7157117E+01,.7191321E+01,.6989772E+01,.6426021E+01,& - & .5738457E+01,.5025396E+01,.5715867E+01,.6411783E+01,.6882764E+01,& - & .7139311E+01,.7183117E+01,.6997950E+01,.6450090E+01,.5778441E+01/ - - data absa(316:450, 8) / & - & .4462234E+01,.5335655E+01,.6051411E+01,.6480333E+01,.6706714E+01,& - & .6719742E+01,.6501878E+01,.5937436E+01,.5082003E+01,.4429084E+01,& - & .5293651E+01,.6011247E+01,.6455537E+01,.6695967E+01,.6727139E+01,& - & .6525443E+01,.5987665E+01,.5149466E+01,.4418913E+01,.5268426E+01,& - & .5981934E+01,.6436217E+01,.6685886E+01,.6728405E+01,.6544585E+01,& - & .6031729E+01,.5208404E+01,.4431057E+01,.5262879E+01,.5965884E+01,& - & .6423698E+01,.6675347E+01,.6726852E+01,.6562473E+01,.6066482E+01,& - & .5259098E+01,.4463604E+01,.5273803E+01,.5964332E+01,.6418269E+01,& - & .6667516E+01,.6727383E+01,.6575984E+01,.6094410E+01,.5304372E+01,& - & .3893017E+01,.4852214E+01,.5530986E+01,.5941479E+01,.6161053E+01,& - & .6192794E+01,.6013485E+01,.5527651E+01,.4603839E+01,.3868292E+01,& - & .4816432E+01,.5499970E+01,.5924581E+01,.6155187E+01,.6204798E+01,& - & .6043116E+01,.5578514E+01,.4673568E+01,.3867315E+01,.4800668E+01,& - & .5481603E+01,.5912694E+01,.6151550E+01,.6211560E+01,.6068531E+01,& - & .5623715E+01,.4735833E+01,.3889089E+01,.4804843E+01,.5478401E+01,& - & .5908385E+01,.6149321E+01,.6219065E+01,.6091671E+01,.5661853E+01,& - & .4790546E+01,.3931954E+01,.4826464E+01,.5491042E+01,.5912928E+01,& - & .6152912E+01,.6229107E+01,.6110084E+01,.5693512E+01,.4840222E+01,& - & .3370800E+01,.4371741E+01,.4996837E+01,.5386824E+01,.5594880E+01,& - & .5641906E+01,.5505250E+01,.5094350E+01,.4102630E+01,.3354024E+01,& - & .4346187E+01,.4976577E+01,.5374389E+01,.5596429E+01,.5658447E+01,& - & .5539483E+01,.5146897E+01,.4175662E+01,.3361375E+01,.4340181E+01,& - & .4971228E+01,.5370928E+01,.5598179E+01,.5672261E+01,.5570116E+01,& - & .5193502E+01,.4240227E+01,.3392497E+01,.4352744E+01,.4980679E+01,& - & .5377112E+01,.5606443E+01,.5688563E+01,.5596813E+01,.5234384E+01,& - & .4299382E+01,.3445749E+01,.4384734E+01,.5004059E+01,.5393218E+01,& - & .5623134E+01,.5706956E+01,.5620707E+01,.5270254E+01,.4350295E+01/ - - data absa(451:585, 8) / & - & .2896690E+01,.3891858E+01,.4467847E+01,.4828220E+01,.5035892E+01,& - & .5103952E+01,.5010639E+01,.4674849E+01,.3670107E+01,.2897792E+01,& - & .3883888E+01,.4462186E+01,.4828076E+01,.5043823E+01,.5124270E+01,& - & .5046967E+01,.4727706E+01,.3740688E+01,.2923572E+01,.3895453E+01,& - & .4471923E+01,.4837551E+01,.5057813E+01,.5145441E+01,.5079272E+01,& - & .4774390E+01,.3805013E+01,.2972461E+01,.3927241E+01,.4497456E+01,& - & .4859388E+01,.5080493E+01,.5168972E+01,.5109386E+01,.4816374E+01,& - & .3861922E+01,.3043384E+01,.3977838E+01,.4537492E+01,.4893037E+01,& - & .5111190E+01,.5197160E+01,.5139056E+01,.4854089E+01,.3912075E+01,& - & .2490281E+01,.3445349E+01,.3966257E+01,.4299151E+01,.4503210E+01,& - & .4585981E+01,.4527887E+01,.4253375E+01,.3285333E+01,.2507718E+01,& - & .3454661E+01,.3975474E+01,.4311153E+01,.4520893E+01,.4611552E+01,& - & .4565739E+01,.4306696E+01,.3353145E+01,.2549112E+01,.3484385E+01,& - & .4000658E+01,.4335871E+01,.4546759E+01,.4639747E+01,.4601392E+01,& - & .4354901E+01,.3414904E+01,.2613534E+01,.3533116E+01,.4041205E+01,& - & .4373302E+01,.4580520E+01,.4672532E+01,.4636635E+01,.4399031E+01,& - & .3469339E+01,.2696279E+01,.3599603E+01,.4096892E+01,.4422225E+01,& - & .4622150E+01,.4711302E+01,.4672921E+01,.4436995E+01,.3520495E+01,& - & .2147723E+01,.3043091E+01,.3506523E+01,.3813045E+01,.4007672E+01,& - & .4097762E+01,.4063337E+01,.3839253E+01,.2937518E+01,.2178826E+01,& - & .3066802E+01,.3529383E+01,.3837562E+01,.4035183E+01,.4129716E+01,& - & .4103957E+01,.3892792E+01,.3003047E+01,.2233352E+01,.3109540E+01,& - & .3568948E+01,.3874858E+01,.4071147E+01,.4166460E+01,.4144730E+01,& - & .3941453E+01,.3061753E+01,.2307024E+01,.3171315E+01,.3623581E+01,& - & .3923493E+01,.4115241E+01,.4208646E+01,.4185941E+01,.3984848E+01,& - & .3115620E+01,.2388613E+01,.3250521E+01,.3691760E+01,.3982688E+01,& - & .4168532E+01,.4255448E+01,.4227404E+01,.4025674E+01,.3167770E+01/ - - data absa( 1:180, 9) / & - & .2529000E+02,.2237800E+02,.1968200E+02,.1909200E+02,.1840100E+02,& - & .1733000E+02,.1719400E+02,.1951300E+02,.2154600E+02,.2515300E+02,& - & .2225100E+02,.1957400E+02,.1900200E+02,.1830900E+02,.1734600E+02,& - & .1716800E+02,.1946900E+02,.2151600E+02,.2499000E+02,.2210800E+02,& - & .1945700E+02,.1889100E+02,.1819700E+02,.1734400E+02,.1715300E+02,& - & .1943500E+02,.2151600E+02,.2478500E+02,.2192600E+02,.1931200E+02,& - & .1877400E+02,.1811100E+02,.1730000E+02,.1716800E+02,.1942600E+02,& - & .2152400E+02,.2456200E+02,.2172900E+02,.1914500E+02,.1865700E+02,& - & .1804300E+02,.1723900E+02,.1719000E+02,.1940000E+02,.2151700E+02,& - & .2673800E+02,.2363500E+02,.2116400E+02,.2088200E+02,.2013300E+02,& - & .1895200E+02,.1839100E+02,.2039700E+02,.2275200E+02,.2657900E+02,& - & .2349300E+02,.2102600E+02,.2077000E+02,.2004600E+02,.1892400E+02,& - & .1835100E+02,.2030200E+02,.2267300E+02,.2636900E+02,.2330400E+02,& - & .2084700E+02,.2063400E+02,.1995500E+02,.1886700E+02,.1835500E+02,& - & .2027400E+02,.2264300E+02,.2614700E+02,.2310800E+02,.2066300E+02,& - & .2049100E+02,.1987000E+02,.1879000E+02,.1836500E+02,.2027100E+02,& - & .2263800E+02,.2587600E+02,.2286700E+02,.2045700E+02,.2030800E+02,& - & .1978800E+02,.1872300E+02,.1835900E+02,.2024200E+02,.2261200E+02,& - & .2780100E+02,.2455800E+02,.2262500E+02,.2245600E+02,.2176600E+02,& - & .2072300E+02,.1978500E+02,.2119300E+02,.2381100E+02,.2758600E+02,& - & .2436600E+02,.2244400E+02,.2234100E+02,.2167000E+02,.2065100E+02,& - & .1973200E+02,.2116300E+02,.2377800E+02,.2736200E+02,.2416600E+02,& - & .2223600E+02,.2220000E+02,.2157500E+02,.2055700E+02,.1971800E+02,& - & .2115500E+02,.2378300E+02,.2708400E+02,.2391900E+02,.2201300E+02,& - & .2201800E+02,.2147100E+02,.2045700E+02,.1970800E+02,.2113600E+02,& - & .2376900E+02,.2679500E+02,.2366600E+02,.2179400E+02,.2182700E+02,& - & .2135500E+02,.2037400E+02,.1965500E+02,.2109200E+02,.2372400E+02,& - & .2832700E+02,.2502600E+02,.2391000E+02,.2372000E+02,.2326500E+02,& - & .2239600E+02,.2108600E+02,.2185900E+02,.2464900E+02,.2809500E+02,& - & .2481600E+02,.2368300E+02,.2359400E+02,.2315600E+02,.2230400E+02,& - & .2102300E+02,.2187300E+02,.2467400E+02,.2781700E+02,.2456900E+02,& - & .2345400E+02,.2344600E+02,.2303100E+02,.2218200E+02,.2102200E+02,& - & .2187800E+02,.2468000E+02,.2752500E+02,.2431000E+02,.2322000E+02,& - & .2326800E+02,.2290800E+02,.2209000E+02,.2102200E+02,.2182400E+02,& - & .2462000E+02,.2719100E+02,.2402300E+02,.2299600E+02,.2307200E+02,& - & .2276900E+02,.2202200E+02,.2098200E+02,.2173700E+02,.2451400E+02/ - - data absa(181:315, 9) / & - & .2825900E+02,.2501400E+02,.2490700E+02,.2470600E+02,.2464200E+02,& - & .2391800E+02,.2233000E+02,.2221900E+02,.2509100E+02,.2799300E+02,& - & .2477100E+02,.2466600E+02,.2459600E+02,.2448700E+02,.2381800E+02,& - & .2234800E+02,.2226900E+02,.2514900E+02,.2769100E+02,.2449900E+02,& - & .2442100E+02,.2443200E+02,.2434000E+02,.2370500E+02,.2242000E+02,& - & .2224200E+02,.2510900E+02,.2735700E+02,.2421400E+02,.2417800E+02,& - & .2425300E+02,.2419100E+02,.2364200E+02,.2242200E+02,.2217400E+02,& - & .2503000E+02,.2700800E+02,.2391600E+02,.2393500E+02,.2406300E+02,& - & .2402000E+02,.2357200E+02,.2235500E+02,.2213200E+02,.2495700E+02,& - & .2762700E+02,.2484100E+02,.2541400E+02,.2551300E+02,.2578800E+02,& - & .2516100E+02,.2356700E+02,.2238400E+02,.2509100E+02,.2731700E+02,& - & .2455000E+02,.2516500E+02,.2538400E+02,.2557800E+02,.2508300E+02,& - & .2366200E+02,.2242300E+02,.2510200E+02,.2699400E+02,.2425900E+02,& - & .2492600E+02,.2520600E+02,.2539100E+02,.2501500E+02,.2375800E+02,& - & .2236300E+02,.2502500E+02,.2664000E+02,.2394500E+02,.2469200E+02,& - & .2500200E+02,.2519300E+02,.2497300E+02,.2373300E+02,.2232800E+02,& - & .2496500E+02,.2626500E+02,.2362500E+02,.2444600E+02,.2478500E+02,& - & .2503700E+02,.2490600E+02,.2365900E+02,.2235200E+02,.2496500E+02,& - & .2643000E+02,.2458100E+02,.2543900E+02,.2614000E+02,.2652400E+02,& - & .2597400E+02,.2455200E+02,.2244100E+02,.2449800E+02,.2610500E+02,& - & .2426300E+02,.2522500E+02,.2597400E+02,.2631500E+02,.2594600E+02,& - & .2467700E+02,.2247100E+02,.2449000E+02,.2575200E+02,.2393800E+02,& - & .2499600E+02,.2574900E+02,.2611300E+02,.2592500E+02,.2475800E+02,& - & .2244200E+02,.2445400E+02,.2538900E+02,.2360900E+02,.2476100E+02,& - & .2549900E+02,.2594000E+02,.2591300E+02,.2472000E+02,.2247300E+02,& - & .2447500E+02,.2501000E+02,.2326000E+02,.2451000E+02,.2526200E+02,& - & .2580400E+02,.2581100E+02,.2464000E+02,.2254700E+02,.2453400E+02/ - - data absa(316:450, 9) / & - & .2476200E+02,.2399700E+02,.2520900E+02,.2646700E+02,.2674800E+02,& - & .2636500E+02,.2509400E+02,.2235700E+02,.2340600E+02,.2442100E+02,& - & .2367200E+02,.2498100E+02,.2621700E+02,.2659500E+02,.2637500E+02,& - & .2519500E+02,.2243500E+02,.2345300E+02,.2406700E+02,.2333600E+02,& - & .2475400E+02,.2595600E+02,.2645500E+02,.2636100E+02,.2524100E+02,& - & .2245800E+02,.2347500E+02,.2369100E+02,.2299600E+02,.2450200E+02,& - & .2569800E+02,.2633000E+02,.2634300E+02,.2519700E+02,.2253300E+02,& - & .2357500E+02,.2331100E+02,.2266000E+02,.2423400E+02,.2545000E+02,& - & .2621500E+02,.2620900E+02,.2512300E+02,.2264200E+02,.2370900E+02,& - & .2280000E+02,.2301100E+02,.2479900E+02,.2618100E+02,.2653300E+02,& - & .2630100E+02,.2504400E+02,.2207700E+02,.2190700E+02,.2243600E+02,& - & .2269700E+02,.2454600E+02,.2594500E+02,.2646000E+02,.2631400E+02,& - & .2512200E+02,.2220400E+02,.2202900E+02,.2207900E+02,.2236700E+02,& - & .2429500E+02,.2570600E+02,.2637000E+02,.2628800E+02,.2516200E+02,& - & .2231400E+02,.2215100E+02,.2171900E+02,.2202900E+02,.2401700E+02,& - & .2548700E+02,.2627300E+02,.2621700E+02,.2511000E+02,.2243500E+02,& - & .2233400E+02,.2134100E+02,.2170700E+02,.2370200E+02,.2528200E+02,& - & .2615900E+02,.2608600E+02,.2506500E+02,.2257800E+02,.2250600E+02,& - & .2060100E+02,.2167800E+02,.2405800E+02,.2535200E+02,.2593100E+02,& - & .2571800E+02,.2443200E+02,.2160700E+02,.2026200E+02,.2025400E+02,& - & .2134500E+02,.2379600E+02,.2518300E+02,.2587500E+02,.2569100E+02,& - & .2450800E+02,.2177400E+02,.2044500E+02,.1989900E+02,.2104800E+02,& - & .2349400E+02,.2500000E+02,.2580000E+02,.2566200E+02,.2453300E+02,& - & .2192200E+02,.2063800E+02,.1954400E+02,.2076600E+02,.2320700E+02,& - & .2482600E+02,.2568600E+02,.2559300E+02,.2452700E+02,.2208500E+02,& - & .2083200E+02,.1919300E+02,.2047000E+02,.2293600E+02,.2467300E+02,& - & .2554400E+02,.2548000E+02,.2453700E+02,.2221800E+02,.2104400E+02/ - - data absa(451:585, 9) / & - & .1817000E+02,.2015500E+02,.2272100E+02,.2414500E+02,.2479800E+02,& - & .2455900E+02,.2340300E+02,.2089500E+02,.1874000E+02,.1783000E+02,& - & .1986000E+02,.2247900E+02,.2401800E+02,.2472100E+02,.2455600E+02,& - & .2346600E+02,.2106900E+02,.1894900E+02,.1749600E+02,.1957600E+02,& - & .2224200E+02,.2388600E+02,.2462100E+02,.2452900E+02,.2352500E+02,& - & .2123100E+02,.1914700E+02,.1716800E+02,.1929200E+02,.2200500E+02,& - & .2373400E+02,.2451400E+02,.2447600E+02,.2358000E+02,.2137600E+02,& - & .1936800E+02,.1684400E+02,.1901300E+02,.2177100E+02,.2357000E+02,& - & .2439000E+02,.2444000E+02,.2365100E+02,.2151700E+02,.1961200E+02,& - & .1576200E+02,.1861500E+02,.2113300E+02,.2263900E+02,.2321400E+02,& - & .2302200E+02,.2206000E+02,.1995800E+02,.1731400E+02,.1545500E+02,& - & .1834100E+02,.2094400E+02,.2251000E+02,.2314800E+02,.2304200E+02,& - & .2216400E+02,.2012700E+02,.1754300E+02,.1515600E+02,.1806800E+02,& - & .2076800E+02,.2237400E+02,.2308400E+02,.2306000E+02,.2225700E+02,& - & .2027500E+02,.1777000E+02,.1486500E+02,.1779400E+02,.2058200E+02,& - & .2223700E+02,.2301800E+02,.2307900E+02,.2235000E+02,.2042700E+02,& - & .1802600E+02,.1461200E+02,.1753400E+02,.2039900E+02,.2208600E+02,& - & .2295600E+02,.2311200E+02,.2244300E+02,.2060700E+02,.1828000E+02,& - & .1351700E+02,.1691400E+02,.1942500E+02,.2079000E+02,.2136700E+02,& - & .2131500E+02,.2060700E+02,.1887100E+02,.1596700E+02,.1324900E+02,& - & .1668800E+02,.1927900E+02,.2069300E+02,.2134400E+02,.2137200E+02,& - & .2072500E+02,.1904300E+02,.1621700E+02,.1299400E+02,.1646700E+02,& - & .1910800E+02,.2060200E+02,.2134300E+02,.2143600E+02,.2083900E+02,& - & .1921200E+02,.1649400E+02,.1278400E+02,.1625000E+02,.1895100E+02,& - & .2050600E+02,.2133500E+02,.2150300E+02,.2096100E+02,.1941500E+02,& - & .1677000E+02,.1273400E+02,.1604900E+02,.1881900E+02,.2043800E+02,& - & .2132900E+02,.2157300E+02,.2110400E+02,.1962300E+02,.1698300E+02/ - - data absa( 1:180,10) / & - & .3587728E+02,.3163298E+02,.2744141E+02,.2457089E+02,.2397093E+02,& - & .2424633E+02,.2723997E+02,.3121916E+02,.3444458E+02,.3583320E+02,& - & .3160263E+02,.2742318E+02,.2450739E+02,.2389581E+02,.2409779E+02,& - & .2700065E+02,.3092695E+02,.3408907E+02,.3574205E+02,.3152702E+02,& - & .2736303E+02,.2442532E+02,.2382519E+02,.2395943E+02,.2677589E+02,& - & .3065092E+02,.3375501E+02,.3559971E+02,.3140018E+02,.2725046E+02,& - & .2431487E+02,.2372351E+02,.2384507E+02,.2657448E+02,.3041293E+02,& - & .3346529E+02,.3540621E+02,.3122776E+02,.2710481E+02,.2417902E+02,& - & .2360279E+02,.2374616E+02,.2639615E+02,.3021059E+02,.3322457E+02,& - & .4028856E+02,.3550073E+02,.3077033E+02,.2797279E+02,.2711240E+02,& - & .2689686E+02,.2944080E+02,.3377959E+02,.3768881E+02,.4023214E+02,& - & .3545689E+02,.3073830E+02,.2787552E+02,.2703385E+02,.2679085E+02,& - & .2921417E+02,.3349222E+02,.3733705E+02,.4012534E+02,.3536466E+02,& - & .3066284E+02,.2776145E+02,.2693419E+02,.2667684E+02,.2898061E+02,& - & .3321866E+02,.3700637E+02,.3994773E+02,.3520594E+02,.3052931E+02,& - & .2761549E+02,.2681235E+02,.2656436E+02,.2878066E+02,.3297874E+02,& - & .3672473E+02,.3972581E+02,.3501021E+02,.3036408E+02,.2745552E+02,& - & .2667155E+02,.2645065E+02,.2861110E+02,.3278003E+02,.3649274E+02,& - & .4476125E+02,.3941959E+02,.3422706E+02,.3167904E+02,.3052481E+02,& - & .2973002E+02,.3165313E+02,.3629435E+02,.4090093E+02,.4471130E+02,& - & .3937886E+02,.3418630E+02,.3155677E+02,.3043113E+02,.2965728E+02,& - & .3143493E+02,.3600307E+02,.4054030E+02,.4457943E+02,.3926295E+02,& - & .3408654E+02,.3140866E+02,.3032055E+02,.2958250E+02,.3123380E+02,& - & .3573596E+02,.4022035E+02,.4439236E+02,.3909796E+02,.3394316E+02,& - & .3123639E+02,.3018674E+02,.2947741E+02,.3105394E+02,.3550064E+02,& - & .3995406E+02,.4412856E+02,.3886401E+02,.3374559E+02,.3104184E+02,& - & .3002428E+02,.2936062E+02,.3091031E+02,.3530951E+02,.3974076E+02,& - & .4910432E+02,.4321511E+02,.3779078E+02,.3556693E+02,.3409226E+02,& - & .3283110E+02,.3395610E+02,.3866004E+02,.4376828E+02,.4902356E+02,& - & .4314962E+02,.3771527E+02,.3544117E+02,.3399674E+02,.3277233E+02,& - & .3377629E+02,.3837960E+02,.4342838E+02,.4888388E+02,.4302756E+02,& - & .3758282E+02,.3527975E+02,.3389250E+02,.3269755E+02,.3359135E+02,& - & .3810582E+02,.4311667E+02,.4865644E+02,.4282619E+02,.3740141E+02,& - & .3507775E+02,.3374861E+02,.3258381E+02,.3342561E+02,.3789331E+02,& - & .4287514E+02,.4836706E+02,.4257131E+02,.3716473E+02,.3485086E+02,& - & .3357022E+02,.3245299E+02,.3329940E+02,.3773038E+02,.4269789E+02/ - - data absa(181:315,10) / & - & .5307594E+02,.4667483E+02,.4130685E+02,.3949369E+02,.3769718E+02,& - & .3615626E+02,.3643522E+02,.4090265E+02,.4638012E+02,.5296984E+02,& - & .4659097E+02,.4119161E+02,.3933623E+02,.3762920E+02,.3609076E+02,& - & .3626818E+02,.4063453E+02,.4606837E+02,.5278655E+02,.4643245E+02,& - & .4102506E+02,.3914923E+02,.3752838E+02,.3600030E+02,.3607944E+02,& - & .4039533E+02,.4580658E+02,.5252049E+02,.4620146E+02,.4079758E+02,& - & .3892166E+02,.3738707E+02,.3586925E+02,.3592354E+02,.4020885E+02,& - & .4560089E+02,.5218739E+02,.4591040E+02,.4053117E+02,.3866135E+02,& - & .3721768E+02,.3572048E+02,.3579033E+02,.4004272E+02,.4542333E+02,& - & .5645060E+02,.4959535E+02,.4476419E+02,.4329540E+02,.4136555E+02,& - & .3958949E+02,.3901626E+02,.4295054E+02,.4873997E+02,.5630605E+02,& - & .4947453E+02,.4458064E+02,.4311329E+02,.4131649E+02,.3950972E+02,& - & .3886403E+02,.4274257E+02,.4850859E+02,.5608434E+02,.4928505E+02,& - & .4434892E+02,.4288710E+02,.4120465E+02,.3940634E+02,.3867749E+02,& - & .4253840E+02,.4828479E+02,.5577797E+02,.4902368E+02,.4406590E+02,& - & .4263870E+02,.4106511E+02,.3925611E+02,.3851716E+02,.4234391E+02,& - & .4807363E+02,.5538906E+02,.4869020E+02,.4373996E+02,.4235043E+02,& - & .4087593E+02,.3908727E+02,.3836821E+02,.4215132E+02,.4786703E+02,& - & .5901771E+02,.5183601E+02,.4798533E+02,.4682270E+02,.4499590E+02,& - & .4308761E+02,.4172136E+02,.4474695E+02,.5079194E+02,.5882554E+02,& - & .5166631E+02,.4772612E+02,.4661016E+02,.4492409E+02,.4299263E+02,& - & .4159694E+02,.4458623E+02,.5061389E+02,.5854583E+02,.5141979E+02,& - & .4742883E+02,.4637327E+02,.4480255E+02,.4286883E+02,.4142281E+02,& - & .4438577E+02,.5039888E+02,.5817816E+02,.5110231E+02,.4708389E+02,& - & .4609738E+02,.4463949E+02,.4268850E+02,.4126044E+02,.4418534E+02,& - & .5018101E+02,.5773974E+02,.5072435E+02,.4670644E+02,.4577129E+02,& - & .4443478E+02,.4250650E+02,.4111702E+02,.4397705E+02,.4997641E+02/ - - data absa(316:450,10) / & - & .6060573E+02,.5344936E+02,.5077793E+02,.4997885E+02,.4845492E+02,& - & .4650628E+02,.4444661E+02,.4611186E+02,.5223587E+02,.6035565E+02,& - & .5321162E+02,.5047679E+02,.4976412E+02,.4835297E+02,.4640277E+02,& - & .4437648E+02,.4597962E+02,.5210068E+02,.6001386E+02,.5290034E+02,& - & .5010907E+02,.4949538E+02,.4818206E+02,.4628144E+02,.4423845E+02,& - & .4582350E+02,.5193692E+02,.5960595E+02,.5253493E+02,.4971769E+02,& - & .4917510E+02,.4797986E+02,.4609629E+02,.4410837E+02,.4565103E+02,& - & .5175207E+02,.5910403E+02,.5209755E+02,.4928800E+02,.4883659E+02,& - & .4774249E+02,.4591174E+02,.4398757E+02,.4546040E+02,.5157175E+02,& - & .6109714E+02,.5440970E+02,.5300408E+02,.5268782E+02,.5157437E+02,& - & .4964597E+02,.4705595E+02,.4702696E+02,.5286716E+02,.6078367E+02,& - & .5409377E+02,.5266455E+02,.5243664E+02,.5140681E+02,.4958118E+02,& - & .4706770E+02,.4700927E+02,.5284723E+02,.6037380E+02,.5371502E+02,& - & .5225748E+02,.5215540E+02,.5119129E+02,.4948761E+02,.4697878E+02,& - & .4691301E+02,.5274423E+02,.5989651E+02,.5328949E+02,.5183758E+02,& - & .5181450E+02,.5096397E+02,.4932968E+02,.4689935E+02,.4677701E+02,& - & .5261482E+02,.5936966E+02,.5280219E+02,.5138276E+02,.5145230E+02,& - & .5070975E+02,.4914571E+02,.4680586E+02,.4662819E+02,.5250407E+02,& - & .6042976E+02,.5467511E+02,.5454288E+02,.5481038E+02,.5409097E+02,& - & .5235706E+02,.4927445E+02,.4742032E+02,.5252935E+02,.6001878E+02,& - & .5427532E+02,.5413495E+02,.5452142E+02,.5389531E+02,.5233375E+02,& - & .4936959E+02,.4752824E+02,.5263857E+02,.5955852E+02,.5382395E+02,& - & .5371774E+02,.5419930E+02,.5366829E+02,.5225894E+02,.4936460E+02,& - & .4753260E+02,.5265555E+02,.5902075E+02,.5331468E+02,.5326153E+02,& - & .5383822E+02,.5344237E+02,.5210269E+02,.4932635E+02,.4747318E+02,& - & .5266176E+02,.5843636E+02,.5278414E+02,.5278267E+02,.5345038E+02,& - & .5319472E+02,.5193593E+02,.4925399E+02,.4743021E+02,.5267090E+02/ - - data absa(451:585,10) / & - & .5841299E+02,.5394652E+02,.5521374E+02,.5605247E+02,.5585908E+02,& - & .5438236E+02,.5102018E+02,.4757287E+02,.5144594E+02,.5792304E+02,& - & .5345752E+02,.5477573E+02,.5572296E+02,.5566296E+02,.5437881E+02,& - & .5115010E+02,.4772352E+02,.5165224E+02,.5737807E+02,.5293116E+02,& - & .5431199E+02,.5537393E+02,.5546638E+02,.5430287E+02,.5118313E+02,& - & .4781700E+02,.5183934E+02,.5678698E+02,.5237535E+02,.5381877E+02,& - & .5500766E+02,.5523934E+02,.5416503E+02,.5117650E+02,.4791639E+02,& - & .5201561E+02,.5615143E+02,.5178837E+02,.5328954E+02,.5460865E+02,& - & .5497459E+02,.5398659E+02,.5113103E+02,.4798503E+02,.5214722E+02,& - & .5536220E+02,.5249053E+02,.5510606E+02,.5651628E+02,.5687411E+02,& - & .5558754E+02,.5214421E+02,.4740469E+02,.4972236E+02,.5479927E+02,& - & .5192667E+02,.5465501E+02,.5620526E+02,.5671006E+02,.5563285E+02,& - & .5229549E+02,.4766073E+02,.5010788E+02,.5421071E+02,.5135180E+02,& - & .5415133E+02,.5586559E+02,.5652158E+02,.5556841E+02,.5239599E+02,& - & .4791820E+02,.5046754E+02,.5358519E+02,.5076397E+02,.5362234E+02,& - & .5548685E+02,.5629675E+02,.5544739E+02,.5247314E+02,.4811189E+02,& - & .5074908E+02,.5294036E+02,.5016394E+02,.5307965E+02,.5511021E+02,& - & .5600283E+02,.5528953E+02,.5251126E+02,.4826838E+02,.5100487E+02,& - & .5148338E+02,.5053874E+02,.5414066E+02,.5624827E+02,.5702373E+02,& - & .5589687E+02,.5255754E+02,.4705268E+02,.4767006E+02,.5089925E+02,& - & .4993871E+02,.5366605E+02,.5594429E+02,.5690194E+02,.5597842E+02,& - & .5278229E+02,.4742535E+02,.4816570E+02,.5028772E+02,.4933321E+02,& - & .5319737E+02,.5560811E+02,.5674811E+02,.5596622E+02,.5298860E+02,& - & .4773920E+02,.4858121E+02,.4966712E+02,.4872563E+02,.5271026E+02,& - & .5528046E+02,.5651701E+02,.5590277E+02,.5315749E+02,.4798366E+02,& - & .4895540E+02,.4904239E+02,.4811862E+02,.5220900E+02,.5494835E+02,& - & .5626643E+02,.5584337E+02,.5327664E+02,.4820949E+02,.4934904E+02/ - - data absa( 1:180,11) / & - & .5140400E+02,.4521200E+02,.3907800E+02,.3297800E+02,.3121300E+02,& - & .3568900E+02,.4223900E+02,.4910900E+02,.5355500E+02,.5145600E+02,& - & .4526300E+02,.3908500E+02,.3297500E+02,.3103400E+02,.3523700E+02,& - & .4175600E+02,.4853100E+02,.5287700E+02,.5141900E+02,.4522600E+02,& - & .3901300E+02,.3293200E+02,.3082600E+02,.3487100E+02,.4137200E+02,& - & .4807000E+02,.5231900E+02,.5131500E+02,.4512200E+02,.3892500E+02,& - & .3288600E+02,.3064300E+02,.3456500E+02,.4105400E+02,.4769000E+02,& - & .5185300E+02,.5113400E+02,.4495800E+02,.3878700E+02,.3281900E+02,& - & .3047600E+02,.3433000E+02,.4079900E+02,.4738400E+02,.5151300E+02,& - & .5957500E+02,.5234300E+02,.4516800E+02,.3815600E+02,.3654900E+02,& - & .4079800E+02,.4843300E+02,.5632000E+02,.6249900E+02,.5965600E+02,& - & .5241500E+02,.4519600E+02,.3815900E+02,.3635600E+02,.4023200E+02,& - & .4780600E+02,.5560300E+02,.6169200E+02,.5963500E+02,.5239500E+02,& - & .4514600E+02,.3811600E+02,.3613900E+02,.3980500E+02,.4733900E+02,& - & .5504600E+02,.6106800E+02,.5952200E+02,.5228500E+02,.4505100E+02,& - & .3806600E+02,.3588900E+02,.3947000E+02,.4698100E+02,.5462100E+02,& - & .6059200E+02,.5930700E+02,.5209400E+02,.4488900E+02,.3796000E+02,& - & .3567700E+02,.3921600E+02,.4668700E+02,.5426800E+02,.6019300E+02,& - & .6880900E+02,.6039700E+02,.5202500E+02,.4416100E+02,.4270100E+02,& - & .4666700E+02,.5552000E+02,.6449300E+02,.7266900E+02,.6892400E+02,& - & .6049900E+02,.5209800E+02,.4413300E+02,.4252100E+02,.4596600E+02,& - & .5473200E+02,.6359400E+02,.7170500E+02,.6895000E+02,.6053100E+02,& - & .5210100E+02,.4410000E+02,.4228500E+02,.4541800E+02,.5409500E+02,& - & .6288300E+02,.7091900E+02,.6885700E+02,.6043400E+02,.5201400E+02,& - & .4404100E+02,.4203100E+02,.4500500E+02,.5356400E+02,.6229100E+02,& - & .7024700E+02,.6866600E+02,.6026500E+02,.5187100E+02,.4394200E+02,& - & .4184200E+02,.4469000E+02,.5313400E+02,.6180600E+02,.6968600E+02,& - & .7931100E+02,.6956100E+02,.5988100E+02,.5127600E+02,.4976100E+02,& - & .5319300E+02,.6339600E+02,.7365600E+02,.8365200E+02,.7951100E+02,& - & .6973600E+02,.6001900E+02,.5117300E+02,.4959400E+02,.5246600E+02,& - & .6246100E+02,.7257800E+02,.8242600E+02,.7956200E+02,.6978900E+02,& - & .6004300E+02,.5107500E+02,.4934600E+02,.5184700E+02,.6163900E+02,& - & .7163200E+02,.8136900E+02,.7951200E+02,.6973300E+02,.5998900E+02,& - & .5097900E+02,.4908800E+02,.5136000E+02,.6094700E+02,.7083600E+02,& - & .8046800E+02,.7932500E+02,.6956900E+02,.5985400E+02,.5087100E+02,& - & .4888200E+02,.5099100E+02,.6036200E+02,.7016100E+02,.7970100E+02/ - - data absa(181:315,11) / & - & .9111200E+02,.7989200E+02,.6878100E+02,.5949600E+02,.5798800E+02,& - & .6041500E+02,.7159500E+02,.8322700E+02,.9485400E+02,.9144700E+02,& - & .8017300E+02,.6902300E+02,.5941600E+02,.5774300E+02,.5967300E+02,& - & .7048300E+02,.8194200E+02,.9339400E+02,.9158300E+02,.8028800E+02,& - & .6910600E+02,.5927600E+02,.5741600E+02,.5903500E+02,.6952800E+02,& - & .8082900E+02,.9213100E+02,.9156600E+02,.8025700E+02,.6907300E+02,& - & .5913600E+02,.5709200E+02,.5852700E+02,.6872400E+02,.7988500E+02,& - & .9105300E+02,.9139000E+02,.8010400E+02,.6893700E+02,.5897300E+02,& - & .5677600E+02,.5810700E+02,.6807900E+02,.7907200E+02,.9012200E+02,& - & .1041900E+03,.9139400E+02,.7865600E+02,.6891600E+02,.6712800E+02,& - & .6846100E+02,.7989400E+02,.9292600E+02,.1060700E+03,.1046300E+03,& - & .9178200E+02,.7900200E+02,.6881900E+02,.6684500E+02,.6773800E+02,& - & .7862800E+02,.9145800E+02,.1044000E+03,.1048600E+03,.9197000E+02,& - & .7915600E+02,.6869800E+02,.6647000E+02,.6706600E+02,.7762800E+02,& - & .9024200E+02,.1030200E+03,.1049400E+03,.9202500E+02,.7920700E+02,& - & .6855500E+02,.6608100E+02,.6654300E+02,.7684300E+02,.8925300E+02,& - & .1018900E+03,.1048100E+03,.9189200E+02,.7910500E+02,.6834400E+02,& - & .6566800E+02,.6610900E+02,.7619000E+02,.8838600E+02,.1009000E+03,& - & .1185000E+03,.1039400E+03,.8942300E+02,.7950900E+02,.7720700E+02,& - & .7719600E+02,.8794300E+02,.1023600E+03,.1169400E+03,.1190500E+03,& - & .1044300E+03,.8986400E+02,.7952800E+02,.7690500E+02,.7649400E+02,& - & .8665000E+02,.1007800E+03,.1151500E+03,.1193900E+03,.1047300E+03,& - & .9011500E+02,.7940100E+02,.7652300E+02,.7585300E+02,.8571500E+02,& - & .9959500E+02,.1138000E+03,.1195100E+03,.1048400E+03,.9022200E+02,& - & .7922000E+02,.7609000E+02,.7540500E+02,.8502200E+02,.9865300E+02,& - & .1127100E+03,.1194200E+03,.1047600E+03,.9016900E+02,.7897600E+02,& - & .7560700E+02,.7501800E+02,.8435200E+02,.9778300E+02,.1116700E+03/ - - data absa(316:450,11) / & - & .1338100E+03,.1173500E+03,.1009500E+03,.9122600E+02,.8818800E+02,& - & .8637900E+02,.9582800E+02,.1115500E+03,.1275500E+03,.1344600E+03,& - & .1179400E+03,.1014500E+03,.9127100E+02,.8794700E+02,.8576600E+02,& - & .9465200E+02,.1100600E+03,.1258300E+03,.1349200E+03,.1183400E+03,& - & .1018000E+03,.9123300E+02,.8761900E+02,.8522800E+02,.9381100E+02,& - & .1089200E+03,.1245200E+03,.1350500E+03,.1184600E+03,.1019200E+03,& - & .9109000E+02,.8715000E+02,.8488700E+02,.9311100E+02,.1079700E+03,& - & .1233700E+03,.1350000E+03,.1184400E+03,.1019200E+03,.9079700E+02,& - & .8662600E+02,.8457000E+02,.9242100E+02,.1071000E+03,.1222600E+03,& - & .1495200E+03,.1311000E+03,.1131600E+03,.1041000E+03,.9992700E+02,& - & .9607400E+02,.1037400E+03,.1206700E+03,.1380100E+03,.1502800E+03,& - & .1317900E+03,.1136000E+03,.1041500E+03,.9987000E+02,.9558900E+02,& - & .1025700E+03,.1191200E+03,.1362300E+03,.1508200E+03,.1322700E+03,& - & .1139200E+03,.1040500E+03,.9957100E+02,.9518900E+02,.1018200E+03,& - & .1180300E+03,.1349600E+03,.1510300E+03,.1324700E+03,.1140300E+03,& - & .1038500E+03,.9912600E+02,.9498000E+02,.1012200E+03,.1172000E+03,& - & .1338800E+03,.1509400E+03,.1324500E+03,.1140100E+03,.1034800E+03,& - & .9855000E+02,.9474600E+02,.1005500E+03,.1163600E+03,.1327600E+03,& - & .1652400E+03,.1448600E+03,.1259400E+03,.1178500E+03,.1122500E+03,& - & .1065400E+03,.1120200E+03,.1296500E+03,.1482900E+03,.1661000E+03,& - & .1456400E+03,.1263600E+03,.1178700E+03,.1123300E+03,.1063000E+03,& - & .1109300E+03,.1281100E+03,.1465300E+03,.1665900E+03,.1460800E+03,& - & .1265600E+03,.1176900E+03,.1121400E+03,.1060900E+03,.1103200E+03,& - & .1271300E+03,.1453200E+03,.1668100E+03,.1463000E+03,.1265900E+03,& - & .1173600E+03,.1116900E+03,.1059700E+03,.1097300E+03,.1262900E+03,& - & .1441600E+03,.1667100E+03,.1462300E+03,.1263900E+03,.1168800E+03,& - & .1111100E+03,.1057600E+03,.1090900E+03,.1254200E+03,.1430300E+03/ - - data absa(451:585,11) / & - & .1806500E+03,.1583200E+03,.1390300E+03,.1320100E+03,.1251900E+03,& - & .1182000E+03,.1204700E+03,.1376000E+03,.1573900E+03,.1813100E+03,& - & .1589300E+03,.1391600E+03,.1318300E+03,.1252000E+03,.1180000E+03,& - & .1197900E+03,.1366000E+03,.1561200E+03,.1816200E+03,.1592500E+03,& - & .1391200E+03,.1314500E+03,.1248700E+03,.1178900E+03,.1192200E+03,& - & .1356600E+03,.1548100E+03,.1816100E+03,.1592700E+03,.1388800E+03,& - & .1309100E+03,.1243200E+03,.1177000E+03,.1185800E+03,.1346200E+03,& - & .1535000E+03,.1812900E+03,.1590100E+03,.1384900E+03,.1302700E+03,& - & .1237100E+03,.1173800E+03,.1180000E+03,.1337800E+03,.1524800E+03,& - & .1943900E+03,.1703100E+03,.1518100E+03,.1457700E+03,.1382800E+03,& - & .1307000E+03,.1297200E+03,.1454600E+03,.1661800E+03,.1948300E+03,& - & .1707300E+03,.1515600E+03,.1454300E+03,.1381200E+03,.1304300E+03,& - & .1291300E+03,.1444300E+03,.1647600E+03,.1949400E+03,.1708700E+03,& - & .1512400E+03,.1449300E+03,.1377100E+03,.1302000E+03,.1284700E+03,& - & .1433000E+03,.1633500E+03,.1947400E+03,.1707300E+03,.1507800E+03,& - & .1442500E+03,.1371800E+03,.1298600E+03,.1277900E+03,.1424000E+03,& - & .1622900E+03,.1942000E+03,.1702900E+03,.1501100E+03,.1433700E+03,& - & .1366600E+03,.1294200E+03,.1272500E+03,.1417100E+03,.1614700E+03,& - & .2056200E+03,.1801400E+03,.1639500E+03,.1588500E+03,.1513100E+03,& - & .1434400E+03,.1392800E+03,.1520100E+03,.1733600E+03,.2058300E+03,& - & .1803400E+03,.1634600E+03,.1584400E+03,.1510200E+03,.1431000E+03,& - & .1386700E+03,.1510100E+03,.1721000E+03,.2057900E+03,.1803400E+03,& - & .1628200E+03,.1578200E+03,.1505100E+03,.1427100E+03,.1380300E+03,& - & .1502600E+03,.1711900E+03,.2053900E+03,.1800200E+03,.1619900E+03,& - & .1569600E+03,.1500500E+03,.1422600E+03,.1374600E+03,.1497700E+03,& - & .1706100E+03,.2047100E+03,.1794600E+03,.1610100E+03,.1558000E+03,& - & .1494200E+03,.1416300E+03,.1368500E+03,.1492200E+03,.1699800E+03/ - - data absa( 1:180,12) / & - & .6180979E+02,.5415023E+02,.4652334E+02,.3927453E+02,.3636930E+02,& - & .4458440E+02,.5332753E+02,.6199779E+02,.6686984E+02,.6201467E+02,& - & .5432712E+02,.4674137E+02,.3945307E+02,.3621804E+02,.4416739E+02,& - & .5281294E+02,.6138502E+02,.6622974E+02,.6212587E+02,.5443223E+02,& - & .4690627E+02,.3958570E+02,.3609178E+02,.4380068E+02,.5235331E+02,& - & .6084698E+02,.6567797E+02,.6210514E+02,.5448391E+02,.4698891E+02,& - & .3965214E+02,.3594726E+02,.4347273E+02,.5194539E+02,.6034581E+02,& - & .6519221E+02,.6202833E+02,.5446118E+02,.4698444E+02,.3963823E+02,& - & .3578608E+02,.4315548E+02,.5153608E+02,.5985270E+02,.6466696E+02,& - & .7408612E+02,.6488258E+02,.5568066E+02,.4672809E+02,.4299401E+02,& - & .5300946E+02,.6345952E+02,.7381337E+02,.8120038E+02,.7431987E+02,& - & .6508647E+02,.5591094E+02,.4696983E+02,.4270620E+02,.5245020E+02,& - & .6277983E+02,.7301412E+02,.8031789E+02,.7445016E+02,.6522132E+02,& - & .5612423E+02,.4716489E+02,.4247167E+02,.5192560E+02,.6214199E+02,& - & .7225979E+02,.7950285E+02,.7449398E+02,.6532501E+02,.5623682E+02,& - & .4725560E+02,.4229442E+02,.5140668E+02,.6150959E+02,.7151980E+02,& - & .7870069E+02,.7445650E+02,.6532487E+02,.5624935E+02,.4725682E+02,& - & .4210652E+02,.5092387E+02,.6091509E+02,.7081995E+02,.7792811E+02,& - & .8862835E+02,.7760021E+02,.6657195E+02,.5566578E+02,.5128990E+02,& - & .6327373E+02,.7579325E+02,.8820522E+02,.9907097E+02,.8897752E+02,& - & .7790504E+02,.6685198E+02,.5596711E+02,.5087545E+02,.6255790E+02,& - & .7492859E+02,.8717970E+02,.9792393E+02,.8915502E+02,.7806522E+02,& - & .6707372E+02,.5618767E+02,.5053795E+02,.6185942E+02,.7408065E+02,& - & .8619344E+02,.9681481E+02,.8920224E+02,.7817532E+02,.6720276E+02,& - & .5630420E+02,.5024670E+02,.6121136E+02,.7329693E+02,.8526792E+02,& - & .9576831E+02,.8916248E+02,.7817526E+02,.6722423E+02,.5632955E+02,& - & .4997369E+02,.6057311E+02,.7252164E+02,.8436173E+02,.9475516E+02,& - & .1056142E+03,.9245626E+02,.7929792E+02,.6618040E+02,.6147280E+02,& - & .7551544E+02,.9049492E+02,.1053424E+03,.1195913E+03,.1061542E+03,& - & .9293152E+02,.7971544E+02,.6661696E+02,.6092308E+02,.7453632E+02,& - & .8931434E+02,.1039588E+03,.1180265E+03,.1064863E+03,.9323304E+02,& - & .8004289E+02,.6692374E+02,.6046019E+02,.7370615E+02,.8831649E+02,& - & .1027830E+03,.1166845E+03,.1066437E+03,.9342567E+02,.8024158E+02,& - & .6710433E+02,.6006174E+02,.7289075E+02,.8732560E+02,.1016334E+03,& - & .1153732E+03,.1066187E+03,.9342970E+02,.8026290E+02,.6712941E+02,& - & .5968287E+02,.7205721E+02,.8632392E+02,.1004504E+03,.1140396E+03/ - - data absa(181:315,12) / & - & .1255319E+03,.1098733E+03,.9422394E+02,.7856981E+02,.7364879E+02,& - & .8993455E+02,.1078090E+03,.1255219E+03,.1431747E+03,.1261993E+03,& - & .1104607E+03,.9472274E+02,.7906163E+02,.7299959E+02,.8871931E+02,& - & .1063433E+03,.1238040E+03,.1412246E+03,.1266478E+03,.1108818E+03,& - & .9515186E+02,.7946770E+02,.7245329E+02,.8760934E+02,.1050151E+03,& - & .1222508E+03,.1394428E+03,.1269276E+03,.1111655E+03,.9543063E+02,& - & .7971950E+02,.7193392E+02,.8655075E+02,.1037357E+03,.1207616E+03,& - & .1377350E+03,.1269774E+03,.1112303E+03,.9549436E+02,.7977777E+02,& - & .7145906E+02,.8552064E+02,.1024909E+03,.1193094E+03,.1360690E+03,& - & .1486316E+03,.1300858E+03,.1115387E+03,.9299465E+02,.8823269E+02,& - & .1068891E+03,.1281501E+03,.1492401E+03,.1705961E+03,.1495263E+03,& - & .1308668E+03,.1122085E+03,.9359013E+02,.8736883E+02,.1053484E+03,& - & .1263026E+03,.1470657E+03,.1681173E+03,.1501396E+03,.1314414E+03,& - & .1127520E+03,.9410033E+02,.8669616E+02,.1039401E+03,.1246072E+03,& - & .1450931E+03,.1658588E+03,.1504832E+03,.1317688E+03,.1130645E+03,& - & .9437770E+02,.8607984E+02,.1025821E+03,.1229795E+03,.1431843E+03,& - & .1636739E+03,.1505906E+03,.1318738E+03,.1131670E+03,.9446367E+02,& - & .8553451E+02,.1012614E+03,.1213902E+03,.1413315E+03,.1615525E+03,& - & .1749535E+03,.1531197E+03,.1312770E+03,.1098627E+03,.1054310E+03,& - & .1267118E+03,.1519465E+03,.1769451E+03,.2025356E+03,.1761867E+03,& - & .1541979E+03,.1321991E+03,.1103506E+03,.1043907E+03,.1247740E+03,& - & .1496095E+03,.1742366E+03,.1994180E+03,.1770334E+03,.1549823E+03,& - & .1329299E+03,.1109139E+03,.1035393E+03,.1229433E+03,.1474132E+03,& - & .1716583E+03,.1964792E+03,.1775830E+03,.1554757E+03,.1333697E+03,& - & .1112711E+03,.1027772E+03,.1211079E+03,.1452057E+03,.1690988E+03,& - & .1935313E+03,.1778130E+03,.1556757E+03,.1335484E+03,.1114211E+03,& - & .1020906E+03,.1193757E+03,.1431352E+03,.1666861E+03,.1907553E+03/ - - data absa(316:450,12) / & - & .2050280E+03,.1794206E+03,.1538132E+03,.1296698E+03,.1256113E+03,& - & .1498126E+03,.1795895E+03,.2091417E+03,.2395094E+03,.2065326E+03,& - & .1807328E+03,.1549517E+03,.1300986E+03,.1242724E+03,.1472448E+03,& - & .1765192E+03,.2055840E+03,.2354240E+03,.2076189E+03,.1817305E+03,& - & .1558434E+03,.1304997E+03,.1232100E+03,.1448216E+03,.1736269E+03,& - & .2021988E+03,.2315773E+03,.2083544E+03,.1823886E+03,.1564141E+03,& - & .1307551E+03,.1223058E+03,.1424212E+03,.1707823E+03,.1989036E+03,& - & .2278090E+03,.2086842E+03,.1826772E+03,.1566702E+03,.1308824E+03,& - & .1214212E+03,.1402293E+03,.1681510E+03,.1958442E+03,.2243003E+03,& - & .2393883E+03,.2094845E+03,.1795806E+03,.1526649E+03,.1492182E+03,& - & .1761707E+03,.2111935E+03,.2459442E+03,.2817236E+03,.2413366E+03,& - & .2111878E+03,.1810490E+03,.1530843E+03,.1474621E+03,.1729020E+03,& - & .2072851E+03,.2414036E+03,.2765008E+03,.2426640E+03,.2123804E+03,& - & .1821044E+03,.1534075E+03,.1461365E+03,.1697315E+03,.2034720E+03,& - & .2369666E+03,.2714312E+03,.2435891E+03,.2131944E+03,.1828085E+03,& - & .1535710E+03,.1449502E+03,.1666087E+03,.1997639E+03,.2326282E+03,& - & .2664788E+03,.2439749E+03,.2135440E+03,.1831044E+03,.1535327E+03,& - & .1438260E+03,.1637945E+03,.1963970E+03,.2287448E+03,.2620139E+03,& - & .2786275E+03,.2438158E+03,.2090742E+03,.1791980E+03,.1764044E+03,& - & .2051521E+03,.2459740E+03,.2864840E+03,.3281621E+03,.2809503E+03,& - & .2458500E+03,.2108110E+03,.1796731E+03,.1742226E+03,.2010652E+03,& - & .2410665E+03,.2807744E+03,.3216182E+03,.2826742E+03,.2473903E+03,& - & .2121402E+03,.1799408E+03,.1725339E+03,.1970313E+03,.2361865E+03,& - & .2750847E+03,.3150950E+03,.2837444E+03,.2483293E+03,.2129494E+03,& - & .1799627E+03,.1710146E+03,.1933057E+03,.2316484E+03,.2698242E+03,& - & .3090609E+03,.2842653E+03,.2487778E+03,.2133179E+03,.1797427E+03,& - & .1695361E+03,.1899175E+03,.2275176E+03,.2649935E+03,.3035329E+03/ - - data absa(451:585,12) / & - & .3246164E+03,.2841571E+03,.2437591E+03,.2099009E+03,.2061338E+03,& - & .2346079E+03,.2807869E+03,.3270860E+03,.3746416E+03,.3270160E+03,& - & .2862343E+03,.2455753E+03,.2101750E+03,.2037891E+03,.2298452E+03,& - & .2746768E+03,.3199854E+03,.3664519E+03,.3287071E+03,.2876768E+03,& - & .2468055E+03,.2102385E+03,.2017300E+03,.2252550E+03,.2691398E+03,& - & .3135254E+03,.3590802E+03,.3296547E+03,.2884880E+03,.2474892E+03,& - & .2100045E+03,.1997651E+03,.2211596E+03,.2640071E+03,.3075507E+03,& - & .3522449E+03,.3298874E+03,.2886932E+03,.2476393E+03,.2093907E+03,& - & .1977676E+03,.2173310E+03,.2589645E+03,.3016760E+03,.3454882E+03,& - & .3764185E+03,.3295629E+03,.2827412E+03,.2448362E+03,.2395515E+03,& - & .2667523E+03,.3170130E+03,.3693427E+03,.4229547E+03,.3787898E+03,& - & .3316408E+03,.2845544E+03,.2447605E+03,.2368444E+03,.2613950E+03,& - & .3103293E+03,.3615554E+03,.4140351E+03,.3801676E+03,.3328413E+03,& - & .2856113E+03,.2443688E+03,.2342033E+03,.2564579E+03,.3041029E+03,& - & .3543252E+03,.4057425E+03,.3807335E+03,.3332994E+03,.2860069E+03,& - & .2436761E+03,.2315207E+03,.2518766E+03,.2980292E+03,.3472163E+03,& - & .3976049E+03,.3804795E+03,.3330315E+03,.2857763E+03,.2425900E+03,& - & .2287390E+03,.2473661E+03,.2919475E+03,.3401341E+03,.3894698E+03,& - & .4337936E+03,.3798110E+03,.3258724E+03,.2839162E+03,.2765829E+03,& - & .3019915E+03,.3551500E+03,.4138455E+03,.4738475E+03,.4358679E+03,& - & .3816444E+03,.3274735E+03,.2832262E+03,.2732493E+03,.2960468E+03,& - & .3477195E+03,.4051747E+03,.4639479E+03,.4367543E+03,.3824308E+03,& - & .3281687E+03,.2821996E+03,.2697997E+03,.2905362E+03,.3403748E+03,& - & .3966217E+03,.4541170E+03,.4367336E+03,.3824073E+03,.3281688E+03,& - & .2807593E+03,.2662071E+03,.2851390E+03,.3330291E+03,.3880528E+03,& - & .4442749E+03,.4356281E+03,.3814241E+03,.3273328E+03,.2789760E+03,& - & .2624596E+03,.2797763E+03,.3260499E+03,.3798827E+03,.4349494E+03/ - -! ----------------------------------------------------------------- -! the array absb(1175,12) (kb(5,5,13:59,12)) contains absorption coefs at -! the 16 chosen g-values for a range of pressure levels < ~100mb and -! temperatures. the first index in the array, jt, which runs from 1 to 5, -! corresponds to different temperatures. more specifically, jt = 3 means -! that the data are for the reference temperature tref for this pressure -! level, jt = 2 refers to the temperature tref-15, jt = 1 is for -! tref-30, jt = 4 is for tref+15, and jt = 5 is for tref+30. -! the second index, jp, runs from 13 to 59 and refers to the jpth -! reference pressure level (see taumol.f for the value of these -! pressure levels in mb). the third index, ig, goes from 1 to 12, -! and tells us which g-interval the absorption coefficients are for. -! ----------------------------------------------------------------- - - data absb( 1:175, 1) / & - & .1055400E-06,.3859600E-04,.6540200E-04,.8854000E-04,.1960100E-03,& - & .1047900E-06,.4367200E-04,.7488900E-04,.1011800E-03,.2214600E-03,& - & .1042900E-06,.4941800E-04,.8542900E-04,.1155700E-03,.2444800E-03,& - & .1023200E-06,.5580200E-04,.9645900E-04,.1316700E-03,.2700100E-03,& - & .9901300E-07,.6299600E-04,.1090000E-03,.1483400E-03,.2991700E-03,& - & .8513600E-07,.3194300E-04,.5440200E-04,.7388700E-04,.1589500E-03,& - & .8459700E-07,.3619600E-04,.6242900E-04,.8447900E-04,.1774900E-03,& - & .8362900E-07,.4098200E-04,.7112600E-04,.9657300E-04,.1974000E-03,& - & .8231000E-07,.4634400E-04,.8045800E-04,.1098400E-03,.2184700E-03,& - & .7870900E-07,.5225200E-04,.9098900E-04,.1239400E-03,.2428100E-03,& - & .6849700E-07,.2639300E-04,.4516400E-04,.6157000E-04,.1249300E-03,& - & .6806200E-07,.2993600E-04,.5191900E-04,.7038700E-04,.1395300E-03,& - & .6676600E-07,.3386300E-04,.5905600E-04,.8069300E-04,.1565300E-03,& - & .6563600E-07,.3829400E-04,.6688500E-04,.9155500E-04,.1751000E-03,& - & .6271100E-07,.4318900E-04,.7575600E-04,.1035500E-03,.1943900E-03,& - & .5508300E-07,.2176100E-04,.3748400E-04,.5130100E-04,.9787500E-04,& - & .5409500E-07,.2467000E-04,.4308400E-04,.5863900E-04,.1099600E-03,& - & .5334000E-07,.2792500E-04,.4897600E-04,.6723400E-04,.1241500E-03,& - & .5141200E-07,.3158800E-04,.5557600E-04,.7635200E-04,.1393900E-03,& - & .4934100E-07,.3567700E-04,.6293700E-04,.8636300E-04,.1554300E-03,& - & .4402200E-07,.1796300E-04,.3110200E-04,.4260400E-04,.7829000E-04,& - & .4316700E-07,.2038200E-04,.3575400E-04,.4887500E-04,.8794100E-04,& - & .4221000E-07,.2309100E-04,.4067400E-04,.5605900E-04,.9925700E-04,& - & .4040200E-07,.2612500E-04,.4616200E-04,.6358600E-04,.1116600E-03,& - & .3853200E-07,.2949400E-04,.5232700E-04,.7196000E-04,.1248000E-03,& - & .3493700E-07,.1490300E-04,.2586800E-04,.3550300E-04,.6336800E-04,& - & .3430800E-07,.1692300E-04,.2978100E-04,.4078900E-04,.7111500E-04,& - & .3299500E-07,.1917100E-04,.3387200E-04,.4681000E-04,.8030200E-04,& - & .3165400E-07,.2167900E-04,.3846800E-04,.5304800E-04,.9043100E-04,& - & .3028200E-07,.2449100E-04,.4359600E-04,.6007800E-04,.1013300E-03,& - & .2797100E-07,.1238500E-04,.2154900E-04,.2961800E-04,.5173200E-04,& - & .2712800E-07,.1404200E-04,.2482600E-04,.3404700E-04,.5806400E-04,& - & .2601800E-07,.1592000E-04,.2822100E-04,.3907200E-04,.6549500E-04,& - & .2471700E-07,.1801700E-04,.3205600E-04,.4428500E-04,.7385900E-04,& - & .2385900E-07,.2036000E-04,.3634100E-04,.5017000E-04,.8294400E-04/ - - data absb(176:350, 1) / & - & .2252900E-07,.1033600E-04,.1799900E-04,.2477600E-04,.4260200E-04,& - & .2173300E-07,.1168500E-04,.2076900E-04,.2850300E-04,.4783300E-04,& - & .2079100E-07,.1328000E-04,.2357100E-04,.3265400E-04,.5399500E-04,& - & .1966300E-07,.1502900E-04,.2678800E-04,.3706600E-04,.6094400E-04,& - & .1916900E-07,.1697500E-04,.3035300E-04,.4199600E-04,.6834400E-04,& - & .1814800E-07,.8603900E-05,.1504100E-04,.2071700E-04,.3514300E-04,& - & .1746500E-07,.9728700E-05,.1734800E-04,.2386200E-04,.3950800E-04,& - & .1653700E-07,.1107300E-04,.1968700E-04,.2727100E-04,.4465200E-04,& - & .1586000E-07,.1252600E-04,.2238800E-04,.3101500E-04,.5026900E-04,& - & .1545200E-07,.1415800E-04,.2533900E-04,.3514100E-04,.5632700E-04,& - & .1454200E-07,.7180700E-05,.1268200E-04,.1747300E-04,.2917900E-04,& - & .1396700E-07,.8157400E-05,.1455000E-04,.2014700E-04,.3279500E-04,& - & .1324100E-07,.9283900E-05,.1654700E-04,.2297100E-04,.3703600E-04,& - & .1274600E-07,.1052200E-04,.1884000E-04,.2611400E-04,.4161700E-04,& - & .1242600E-07,.1188600E-04,.2131300E-04,.2960400E-04,.4670900E-04,& - & .1172400E-07,.6019600E-05,.1070300E-04,.1475300E-04,.2414300E-04,& - & .1112400E-07,.6849900E-05,.1223300E-04,.1700900E-04,.2714700E-04,& - & .1055200E-07,.7789700E-05,.1392700E-04,.1936200E-04,.3066100E-04,& - & .1021300E-07,.8839800E-05,.1585000E-04,.2202400E-04,.3451900E-04,& - & .9962700E-08,.9975500E-05,.1791900E-04,.2494400E-04,.3873000E-04,& - & .9383500E-08,.5050500E-05,.9029800E-05,.1245000E-04,.1994000E-04,& - & .8872200E-08,.5749400E-05,.1028700E-04,.1435100E-04,.2245000E-04,& - & .8471900E-08,.6537400E-05,.1172700E-04,.1632900E-04,.2537800E-04,& - & .8192400E-08,.7418600E-05,.1333400E-04,.1856700E-04,.2856000E-04,& - & .7919400E-08,.8371900E-05,.1505600E-04,.2100300E-04,.3199000E-04,& - & .7453500E-08,.4243700E-05,.7622000E-05,.1052300E-04,.1653100E-04,& - & .7051600E-08,.4830000E-05,.8666700E-05,.1208900E-04,.1861600E-04,& - & .6774600E-08,.5494100E-05,.9892700E-05,.1379000E-04,.2102400E-04,& - & .6537500E-08,.6235700E-05,.1123300E-04,.1566200E-04,.2364200E-04,& - & .6300100E-08,.7028200E-05,.1266900E-04,.1769500E-04,.2647800E-04,& - & .5952000E-08,.3573900E-05,.6435000E-05,.8933000E-05,.1375400E-04,& - & .5664400E-08,.4079700E-05,.7329100E-05,.1022800E-04,.1548900E-04,& - & .5422900E-08,.4636600E-05,.8366400E-05,.1165900E-04,.1748600E-04,& - & .5215500E-08,.5254600E-05,.9482900E-05,.1324600E-04,.1964300E-04,& - & .5002600E-08,.5913400E-05,.1067600E-04,.1493300E-04,.2197900E-04/ - - data absb(351:525, 1) / & - & .4734700E-08,.3011700E-05,.5422300E-05,.7581000E-05,.1142400E-04,& - & .4521500E-08,.3442100E-05,.6195900E-05,.8661900E-05,.1288400E-04,& - & .4333400E-08,.3914300E-05,.7070200E-05,.9876100E-05,.1454300E-04,& - & .4135000E-08,.4427500E-05,.8000500E-05,.1119500E-04,.1631900E-04,& - & .3965300E-08,.4976900E-05,.8993100E-05,.1259800E-04,.1816000E-04,& - & .3794800E-08,.2541500E-05,.4581900E-05,.6433600E-05,.9495600E-05,& - & .3608300E-08,.2903800E-05,.5242600E-05,.7340000E-05,.1071900E-04,& - & .3441800E-08,.3301700E-05,.5973300E-05,.8357500E-05,.1206600E-04,& - & .3263600E-08,.3729700E-05,.6749300E-05,.9455800E-05,.1346800E-04,& - & .3134000E-08,.4187300E-05,.7575900E-05,.1062000E-04,.1495300E-04,& - & .3012100E-08,.2153600E-05,.3884100E-05,.5449100E-05,.7909000E-05,& - & .2877500E-08,.2455700E-05,.4446700E-05,.6224700E-05,.8914800E-05,& - & .2719600E-08,.2790000E-05,.5054300E-05,.7078200E-05,.9994300E-05,& - & .2579800E-08,.3147300E-05,.5701100E-05,.7993600E-05,.1113500E-04,& - & .2478500E-08,.3528700E-05,.6389400E-05,.8962400E-05,.1235700E-04,& - & .2403400E-08,.1823100E-05,.3294500E-05,.4618300E-05,.6583700E-05,& - & .2270200E-08,.2076600E-05,.3767100E-05,.5273500E-05,.7387500E-05,& - & .2155100E-08,.2355900E-05,.4274400E-05,.5993200E-05,.8266500E-05,& - & .2039700E-08,.2654100E-05,.4813700E-05,.6754900E-05,.9207100E-05,& - & .1920800E-08,.2971100E-05,.5388000E-05,.7559800E-05,.1021100E-04,& - & .1911600E-08,.1545400E-05,.2795700E-05,.3922800E-05,.5466400E-05,& - & .1804500E-08,.1757900E-05,.3193800E-05,.4478000E-05,.6120500E-05,& - & .1701500E-08,.1991100E-05,.3616700E-05,.5075300E-05,.6852300E-05,& - & .1604200E-08,.2239300E-05,.4066600E-05,.5709400E-05,.7626000E-05,& - & .1518900E-08,.2503500E-05,.4543900E-05,.6378500E-05,.8456200E-05,& - & .1513400E-08,.1308000E-05,.2376300E-05,.3336000E-05,.4538200E-05,& - & .1425400E-08,.1488600E-05,.2708600E-05,.3799500E-05,.5093800E-05,& - & .1347800E-08,.1683100E-05,.3060500E-05,.4297100E-05,.5693300E-05,& - & .1272600E-08,.1890400E-05,.3435300E-05,.4824700E-05,.6335300E-05,& - & .1202700E-08,.2109800E-05,.3831800E-05,.5380900E-05,.7030200E-05,& - & .1202400E-08,.1108400E-05,.2019300E-05,.2831000E-05,.3784900E-05,& - & .1133800E-08,.1260500E-05,.2294900E-05,.3222100E-05,.4245800E-05,& - & .1067800E-08,.1423100E-05,.2588100E-05,.3636500E-05,.4746000E-05,& - & .1005200E-08,.1596300E-05,.2901000E-05,.4072800E-05,.5280400E-05,& - & .9594600E-09,.1777900E-05,.3230100E-05,.4538100E-05,.5854700E-05/ - - data absb(526:700, 1) / & - & .9575000E-09,.9366500E-06,.1706800E-05,.2395400E-05,.3161100E-05,& - & .8999100E-09,.1063600E-05,.1936600E-05,.2720900E-05,.3544000E-05,& - & .8494400E-09,.1199400E-05,.2180400E-05,.3065100E-05,.3960000E-05,& - & .8086300E-09,.1343100E-05,.2440600E-05,.3428500E-05,.4404500E-05,& - & .7669700E-09,.1493700E-05,.2713800E-05,.3815300E-05,.4873900E-05,& - & .7693100E-09,.7814500E-06,.1424300E-05,.2000400E-05,.2608800E-05,& - & .7255400E-09,.8865200E-06,.1614000E-05,.2268400E-05,.2925500E-05,& - & .6867700E-09,.9987200E-06,.1815900E-05,.2553700E-05,.3267200E-05,& - & .6498600E-09,.1117800E-05,.2031200E-05,.2854200E-05,.3630400E-05,& - & .6217700E-09,.1242000E-05,.2256600E-05,.3173700E-05,.4018700E-05,& - & .6224500E-09,.6423500E-06,.1170900E-05,.1644500E-05,.2121300E-05,& - & .5869600E-09,.7287600E-06,.1326600E-05,.1864600E-05,.2379800E-05,& - & .5569300E-09,.8208900E-06,.1492700E-05,.2099100E-05,.2660000E-05,& - & .5293400E-09,.9187400E-06,.1669500E-05,.2345700E-05,.2957500E-05,& - & .5058500E-09,.1021000E-05,.1854900E-05,.2608500E-05,.3275800E-05,& - & .5115600E-09,.5187200E-06,.9455000E-06,.1328700E-05,.1708900E-05,& - & .4825800E-09,.5890800E-06,.1072200E-05,.1507900E-05,.1918700E-05,& - & .4569400E-09,.6642100E-06,.1207800E-05,.1699200E-05,.2145600E-05,& - & .4350200E-09,.7440800E-06,.1352000E-05,.1900000E-05,.2387600E-05,& - & .4151700E-09,.8275800E-06,.1503400E-05,.2114600E-05,.2647300E-05,& - & .4209400E-09,.4183700E-06,.7626000E-06,.1071900E-05,.1375600E-05,& - & .3970000E-09,.4755700E-06,.8657200E-06,.1218000E-05,.1546200E-05,& - & .3756300E-09,.5368400E-06,.9761300E-06,.1373800E-05,.1728900E-05,& - & .3578300E-09,.6019300E-06,.1093600E-05,.1537400E-05,.1925200E-05,& - & .3410700E-09,.6701400E-06,.1217300E-05,.1712700E-05,.2136900E-05,& - & .3463500E-09,.3373200E-06,.6149200E-06,.8644700E-06,.1105500E-05,& - & .3265400E-09,.3838300E-06,.6986900E-06,.9835500E-06,.1244000E-05,& - & .3090900E-09,.4337100E-06,.7886900E-06,.1110500E-05,.1392400E-05,& - & .2942500E-09,.4868100E-06,.8844600E-06,.1243300E-05,.1552600E-05,& - & .2800000E-09,.5425600E-06,.9855000E-06,.1386800E-05,.1723800E-05,& - & .2873100E-09,.2684300E-06,.4891500E-06,.6881000E-06,.8786700E-06,& - & .2708900E-09,.3060000E-06,.5569800E-06,.7843000E-06,.9907500E-06,& - & .2560700E-09,.3462400E-06,.6296600E-06,.8867700E-06,.1110700E-05,& - & .2437200E-09,.3892600E-06,.7073200E-06,.9943000E-06,.1240200E-05,& - & .2317600E-09,.4346500E-06,.7894300E-06,.1110700E-05,.1378700E-05/ - - data absb(701:875, 1) / & - & .2390300E-09,.2132300E-06,.3885500E-06,.5470100E-06,.6978100E-06,& - & .2248700E-09,.2433200E-06,.4432800E-06,.6239700E-06,.7877400E-06,& - & .2123600E-09,.2758100E-06,.5017000E-06,.7066400E-06,.8842700E-06,& - & .2020400E-09,.3106600E-06,.5643500E-06,.7938400E-06,.9889900E-06,& - & .1920900E-09,.3475300E-06,.6311900E-06,.8878700E-06,.1100700E-05,& - & .1986800E-09,.1695000E-06,.3088500E-06,.4342600E-06,.5533600E-06,& - & .1868100E-09,.1933800E-06,.3525000E-06,.4962200E-06,.6262800E-06,& - & .1764900E-09,.2196300E-06,.3995000E-06,.5626900E-06,.7039600E-06,& - & .1675300E-09,.2477800E-06,.4501300E-06,.6334200E-06,.7877000E-06,& - & .1593000E-09,.2777200E-06,.5043900E-06,.7094500E-06,.8778300E-06,& - & .1657700E-09,.1333200E-06,.2432300E-06,.3418400E-06,.4359400E-06,& - & .1559700E-09,.1524500E-06,.2780100E-06,.3913000E-06,.4946000E-06,& - & .1472100E-09,.1735400E-06,.3158400E-06,.4449900E-06,.5570500E-06,& - & .1393600E-09,.1962500E-06,.3566100E-06,.5018900E-06,.6239800E-06,& - & .1325500E-09,.2204400E-06,.4003400E-06,.5630800E-06,.6963400E-06,& - & .1386100E-09,.1044500E-06,.1905800E-06,.2684100E-06,.3423300E-06,& - & .1302700E-09,.1197400E-06,.2183600E-06,.3074400E-06,.3889700E-06,& - & .1229000E-09,.1366200E-06,.2486400E-06,.3506500E-06,.4391600E-06,& - & .1161100E-09,.1548400E-06,.2815500E-06,.3962700E-06,.4927300E-06,& - & .1104200E-09,.1743100E-06,.3166600E-06,.4454000E-06,.5508700E-06,& - & .1158100E-09,.8191500E-07,.1491500E-06,.2114000E-06,.2698700E-06,& - & .1090600E-09,.9407700E-07,.1714300E-06,.2417300E-06,.3058600E-06,& - & .1025400E-09,.1074500E-06,.1958200E-06,.2760600E-06,.3459300E-06,& - & .9675700E-10,.1220500E-06,.2220100E-06,.3127100E-06,.3887600E-06,& - & .9197900E-10,.1377200E-06,.2501500E-06,.3520800E-06,.4356100E-06,& - & .9688900E-10,.6411600E-07,.1170800E-06,.1645500E-06,.2103600E-06,& - & .9128100E-10,.7364100E-07,.1343600E-06,.1889500E-06,.2395100E-06,& - & .8583000E-10,.8416100E-07,.1536000E-06,.2164300E-06,.2717600E-06,& - & .8104800E-10,.9586700E-07,.1744700E-06,.2458200E-06,.3061300E-06,& - & .7671200E-10,.1084400E-06,.1970600E-06,.2774300E-06,.3432900E-06,& - & .8151600E-10,.4969800E-07,.9059600E-07,.1272700E-06,.1631300E-06,& - & .7660900E-10,.5713200E-07,.1043300E-06,.1469400E-06,.1867200E-06,& - & .7197500E-10,.6553400E-07,.1195500E-06,.1685000E-06,.2121500E-06,& - & .6790800E-10,.7482900E-07,.1361900E-06,.1920900E-06,.2395900E-06,& - & .6411700E-10,.8487200E-07,.1543300E-06,.2173300E-06,.2691500E-06/ - - data absb(876:1050, 1) / & - & .6842900E-10,.3871500E-07,.6985400E-07,.9837700E-07,.1261900E-06,& - & .6423600E-10,.4437500E-07,.8089500E-07,.1147100E-06,.1460400E-06,& - & .6051000E-10,.5102500E-07,.9297700E-07,.1312300E-06,.1654200E-06,& - & .5685100E-10,.5834500E-07,.1063300E-06,.1499100E-06,.1874500E-06,& - & .5367400E-10,.6634600E-07,.1207000E-06,.1700100E-06,.2109500E-06,& - & .5738700E-10,.2980000E-07,.5381700E-07,.7590600E-07,.9771000E-07,& - & .5396000E-10,.3450000E-07,.6320500E-07,.8865500E-07,.1131000E-06,& - & .5074000E-10,.3968400E-07,.7250200E-07,.1019300E-06,.1289200E-06,& - & .4771000E-10,.4541800E-07,.8294100E-07,.1169200E-06,.1464900E-06,& - & .4505000E-10,.5179700E-07,.9432000E-07,.1329600E-06,.1652600E-06,& - & .4801000E-10,.2299900E-07,.4168200E-07,.5897500E-07,.7589800E-07,& - & .4528200E-10,.2691700E-07,.4892900E-07,.6876500E-07,.8798300E-07,& - & .4253100E-10,.3087900E-07,.5640600E-07,.7959300E-07,.1010900E-06,& - & .4000200E-10,.3547000E-07,.6470600E-07,.9131200E-07,.1147300E-06,& - & .3767400E-10,.4054200E-07,.7383400E-07,.1041200E-06,.1296700E-06,& - & .4009400E-10,.1781000E-07,.3241200E-07,.4598500E-07,.5904100E-07,& - & .3790100E-10,.2101300E-07,.3792100E-07,.5347900E-07,.6847900E-07,& - & .3558400E-10,.2410000E-07,.4398800E-07,.6240900E-07,.7931100E-07,& - & .3351600E-10,.2773700E-07,.5054400E-07,.7143600E-07,.8991200E-07,& - & .3150300E-10,.3173800E-07,.5788900E-07,.8159100E-07,.1019500E-06,& - & .3346200E-10,.1382900E-07,.2522700E-07,.3549800E-07,.4579300E-07,& - & .3170300E-10,.1627200E-07,.2939300E-07,.4147600E-07,.5334000E-07,& - & .2985600E-10,.1883600E-07,.3453700E-07,.4849000E-07,.6179100E-07,& - & .2803800E-10,.2168400E-07,.3957800E-07,.5575100E-07,.7042200E-07,& - & .2637500E-10,.2482400E-07,.4538900E-07,.6389800E-07,.8007100E-07,& - & .2785900E-10,.1075700E-07,.1943600E-07,.2736800E-07,.3540100E-07,& - & .2648200E-10,.1257500E-07,.2278600E-07,.3227500E-07,.4150400E-07,& - & .2501300E-10,.1471800E-07,.2678600E-07,.3765700E-07,.4815000E-07,& - & .2348100E-10,.1689000E-07,.3087500E-07,.4356100E-07,.5528400E-07,& - & .2210300E-10,.1940500E-07,.3543500E-07,.5004600E-07,.6282400E-07,& - & .2326200E-10,.8353400E-08,.1503300E-07,.2114200E-07,.2749100E-07,& - & .2207500E-10,.9782100E-08,.1779100E-07,.2529800E-07,.3244700E-07,& - & .2088700E-10,.1154100E-07,.2085200E-07,.2939200E-07,.3764300E-07,& - & .1962900E-10,.1322800E-07,.2416400E-07,.3433000E-07,.4362200E-07,& - & .1847500E-10,.1523300E-07,.2777900E-07,.3930400E-07,.4943200E-07/ - - data absb(1051:1175, 1) / & - & .1936000E-10,.6488800E-08,.1164400E-07,.1638700E-07,.2134000E-07,& - & .1837200E-10,.7636700E-08,.1394700E-07,.1967200E-07,.2540100E-07,& - & .1742100E-10,.9008300E-08,.1627500E-07,.2297100E-07,.2952200E-07,& - & .1641300E-10,.1040200E-07,.1908100E-07,.2685400E-07,.3423300E-07,& - & .1541700E-10,.1198400E-07,.2183500E-07,.3085600E-07,.3895400E-07,& - & .1609400E-10,.5017400E-08,.9028300E-08,.1271800E-07,.1657600E-07,& - & .1526500E-10,.5974700E-08,.1085000E-07,.1529700E-07,.1978300E-07,& - & .1451500E-10,.7014200E-08,.1269900E-07,.1796000E-07,.2317100E-07,& - & .1371500E-10,.8162600E-08,.1494000E-07,.2099400E-07,.2686500E-07,& - & .1288000E-10,.9405400E-08,.1720600E-07,.2422100E-07,.3073900E-07,& - & .1336800E-10,.3883800E-08,.6999100E-08,.9837200E-08,.1282100E-07,& - & .1274300E-10,.4675100E-08,.8424300E-08,.1185600E-07,.1540600E-07,& - & .1208700E-10,.5464200E-08,.9929500E-08,.1406900E-07,.1814400E-07,& - & .1144200E-10,.6446100E-08,.1165700E-07,.1640700E-07,.2107200E-07,& - & .1075900E-10,.7371100E-08,.1347800E-07,.1910600E-07,.2431400E-07,& - & .1108100E-10,.3014800E-08,.5416500E-08,.7642100E-08,.9949600E-08,& - & .1059800E-10,.3633700E-08,.6537500E-08,.9204100E-08,.1202500E-07,& - & .1005200E-10,.4271200E-08,.7784100E-08,.1105300E-07,.1430600E-07,& - & .9530800E-11,.5042900E-08,.9113300E-08,.1286500E-07,.1655400E-07,& - & .8979500E-11,.5797900E-08,.1061500E-07,.1505100E-07,.1921600E-07,& - & .9119400E-11,.2421400E-08,.4349600E-08,.6153100E-08,.8013600E-08,& - & .8728700E-11,.2923200E-08,.5253500E-08,.7396600E-08,.9683000E-08,& - & .8276500E-11,.3441200E-08,.6278800E-08,.8899200E-08,.1153400E-07,& - & .7860500E-11,.4063200E-08,.7345400E-08,.1038200E-07,.1337200E-07,& - & .7412700E-11,.4680100E-08,.8591000E-08,.1213700E-07,.1553000E-07/ - - data absb( 1:175, 2) / & - & .1757600E-05,.2251800E-03,.3639800E-03,.4650500E-03,.9792000E-03,& - & .1952200E-05,.2568800E-03,.4272400E-03,.5429300E-03,.1126100E-02,& - & .2113400E-05,.2938200E-03,.4977800E-03,.6318600E-03,.1296100E-02,& - & .2268000E-05,.3358500E-03,.5709500E-03,.7314900E-03,.1485700E-02,& - & .2393900E-05,.3832600E-03,.6468800E-03,.8412000E-03,.1681500E-02,& - & .1386600E-05,.1881600E-03,.3054100E-03,.3908200E-03,.8061400E-03,& - & .1482500E-05,.2152500E-03,.3590600E-03,.4577200E-03,.9297600E-03,& - & .1642800E-05,.2466400E-03,.4189100E-03,.5334100E-03,.1068900E-02,& - & .1780700E-05,.2821800E-03,.4802100E-03,.6186100E-03,.1223600E-02,& - & .1868500E-05,.3220400E-03,.5438500E-03,.7122300E-03,.1384400E-02,& - & .1048300E-05,.1569900E-03,.2557100E-03,.3280300E-03,.6587300E-03,& - & .1131000E-05,.1801600E-03,.3007100E-03,.3853400E-03,.7591600E-03,& - & .1233000E-05,.2067200E-03,.3518100E-03,.4494000E-03,.8704100E-03,& - & .1342600E-05,.2365000E-03,.4029200E-03,.5224600E-03,.9944500E-03,& - & .1451400E-05,.2697900E-03,.4568400E-03,.6019500E-03,.1117300E-02,& - & .8066300E-06,.1309800E-03,.2138200E-03,.2753900E-03,.5372700E-03,& - & .8574700E-06,.1505800E-03,.2520100E-03,.3240600E-03,.6157300E-03,& - & .9243500E-06,.1728300E-03,.2954200E-03,.3787900E-03,.7014000E-03,& - & .9974700E-06,.1979300E-03,.3380700E-03,.4407600E-03,.7946800E-03,& - & .1081900E-05,.2258200E-03,.3835400E-03,.5066300E-03,.8898000E-03,& - & .6177200E-06,.1094100E-03,.1792600E-03,.2314400E-03,.4355400E-03,& - & .6571800E-06,.1257600E-03,.2117400E-03,.2727500E-03,.4975000E-03,& - & .6994900E-06,.1446100E-03,.2485200E-03,.3193700E-03,.5646200E-03,& - & .7538700E-06,.1658000E-03,.2837400E-03,.3721300E-03,.6350700E-03,& - & .7971500E-06,.1892600E-03,.3223600E-03,.4258800E-03,.7072800E-03,& - & .4718800E-06,.9195200E-04,.1510000E-03,.1949500E-03,.3554300E-03,& - & .5093700E-06,.1051300E-03,.1785200E-03,.2299900E-03,.4025000E-03,& - & .5420600E-06,.1213000E-03,.2095900E-03,.2697900E-03,.4566200E-03,& - & .5732800E-06,.1393600E-03,.2381500E-03,.3145100E-03,.5111300E-03,& - & .6107700E-06,.1591600E-03,.2707500E-03,.3596700E-03,.5707600E-03,& - & .3600500E-06,.7698400E-04,.1274300E-03,.1642200E-03,.2888500E-03,& - & .3898800E-06,.8802900E-04,.1506700E-03,.1939600E-03,.3285400E-03,& - & .4198900E-06,.1017200E-03,.1753900E-03,.2278400E-03,.3704500E-03,& - & .4409200E-06,.1172700E-03,.2000400E-03,.2659200E-03,.4159800E-03,& - & .4688300E-06,.1338600E-03,.2276900E-03,.3028500E-03,.4655000E-03/ - - data absb(176:350, 2) / & - & .2790800E-06,.6445000E-04,.1079500E-03,.1388900E-03,.2387800E-03,& - & .3093400E-06,.7418700E-04,.1277300E-03,.1641700E-03,.2701700E-03,& - & .3308600E-06,.8580100E-04,.1478200E-03,.1930700E-03,.3050800E-03,& - & .3505800E-06,.9886100E-04,.1686800E-03,.2250800E-03,.3424900E-03,& - & .3706900E-06,.1130600E-03,.1918800E-03,.2560100E-03,.3851900E-03,& - & .2241800E-06,.5409500E-04,.9141400E-04,.1175700E-03,.1969700E-03,& - & .2455900E-06,.6256700E-04,.1081900E-03,.1390800E-03,.2228400E-03,& - & .2616900E-06,.7238300E-04,.1248100E-03,.1636800E-03,.2520500E-03,& - & .2788500E-06,.8344600E-04,.1425800E-03,.1891000E-03,.2838600E-03,& - & .2934400E-06,.9554000E-04,.1619800E-03,.2160900E-03,.3194700E-03,& - & .1794100E-06,.4583000E-04,.7817600E-04,.1006100E-03,.1631300E-03,& - & .1939700E-06,.5313900E-04,.9255600E-04,.1190100E-03,.1848200E-03,& - & .2070700E-06,.6159300E-04,.1057900E-03,.1400800E-03,.2096500E-03,& - & .2207100E-06,.7101600E-04,.1210000E-03,.1612800E-03,.2366100E-03,& - & .2314800E-06,.8128600E-04,.1379500E-03,.1840100E-03,.2658000E-03,& - & .1429100E-06,.3882500E-04,.6686600E-04,.8614000E-04,.1351100E-03,& - & .1517900E-06,.4513500E-04,.7845000E-04,.1019400E-03,.1536900E-03,& - & .1632600E-06,.5239900E-04,.8991900E-04,.1200100E-03,.1744100E-03,& - & .1730700E-06,.6044000E-04,.1029300E-03,.1373500E-03,.1966800E-03,& - & .1813700E-06,.6918900E-04,.1175900E-03,.1565100E-03,.2199800E-03,& - & .1124500E-06,.3286200E-04,.5716600E-04,.7382800E-04,.1118500E-03,& - & .1195800E-06,.3828100E-04,.6663500E-04,.8739000E-04,.1274000E-03,& - & .1270200E-06,.4451900E-04,.7660600E-04,.1019000E-03,.1441800E-03,& - & .1346700E-06,.5137300E-04,.8762200E-04,.1170000E-03,.1620500E-03,& - & .1412000E-06,.5887400E-04,.1001900E-03,.1334800E-03,.1818800E-03,& - & .8824200E-07,.2795000E-04,.4901000E-04,.6343400E-04,.9287700E-04,& - & .9438300E-07,.3261000E-04,.5669000E-04,.7511400E-04,.1053100E-03,& - & .9971200E-07,.3792900E-04,.6520400E-04,.8711300E-04,.1193100E-03,& - & .1047300E-06,.4377800E-04,.7480500E-04,.9995000E-04,.1342700E-03,& - & .1098800E-06,.5022900E-04,.8559800E-04,.1140600E-03,.1505000E-03,& - & .6969600E-07,.2389500E-04,.4216600E-04,.5473300E-04,.7714600E-04,& - & .7439000E-07,.2792100E-04,.4838700E-04,.6481700E-04,.8760700E-04,& - & .7885600E-07,.3249700E-04,.5569200E-04,.7469100E-04,.9938700E-04,& - & .8325300E-07,.3749100E-04,.6413000E-04,.8560900E-04,.1119300E-03,& - & .8767500E-07,.4301100E-04,.7339800E-04,.9782800E-04,.1257400E-03/ - - data absb(351:525, 2) / & - & .5461900E-07,.2046900E-04,.3586900E-04,.4725900E-04,.6415100E-04,& - & .5865700E-07,.2392500E-04,.4146800E-04,.5549900E-04,.7291100E-04,& - & .6253200E-07,.2783900E-04,.4773500E-04,.6398500E-04,.8295500E-04,& - & .6618400E-07,.3214100E-04,.5500100E-04,.7345600E-04,.9356700E-04,& - & .6930500E-07,.3660500E-04,.6296800E-04,.8393800E-04,.1051700E-03,& - & .4334800E-07,.1747600E-04,.3069200E-04,.4080300E-04,.5327100E-04,& - & .4634800E-07,.2049600E-04,.3549800E-04,.4762900E-04,.6080900E-04,& - & .4950700E-07,.2385700E-04,.4097400E-04,.5494700E-04,.6922200E-04,& - & .5241900E-07,.2756000E-04,.4720500E-04,.6304400E-04,.7812300E-04,& - & .5484200E-07,.3109400E-04,.5402800E-04,.7211600E-04,.8783400E-04,& - & .3448000E-07,.1502700E-04,.2626800E-04,.3535800E-04,.4471100E-04,& - & .3698500E-07,.1763800E-04,.3040500E-04,.4093800E-04,.5105400E-04,& - & .3947600E-07,.2051200E-04,.3523700E-04,.4720700E-04,.5803400E-04,& - & .4165000E-07,.2369400E-04,.4058600E-04,.5428600E-04,.6570800E-04,& - & .4369300E-07,.2643800E-04,.4646700E-04,.6203500E-04,.7387200E-04,& - & .2740200E-07,.1293200E-04,.2258500E-04,.3036500E-04,.3747100E-04,& - & .2937700E-07,.1518300E-04,.2615800E-04,.3519500E-04,.4286700E-04,& - & .3135300E-07,.1765800E-04,.3034300E-04,.4060600E-04,.4885800E-04,& - & .3305600E-07,.2028600E-04,.3492400E-04,.4673500E-04,.5532900E-04,& - & .3467300E-07,.2245100E-04,.3971700E-04,.5332900E-04,.6215100E-04,& - & .2171600E-07,.1115600E-04,.1942700E-04,.2616900E-04,.3151200E-04,& - & .2331300E-07,.1309100E-04,.2256800E-04,.3037700E-04,.3621600E-04,& - & .2480300E-07,.1522100E-04,.2615700E-04,.3505000E-04,.4125600E-04,& - & .2626000E-07,.1727700E-04,.3009100E-04,.4028800E-04,.4669300E-04,& - & .2733400E-07,.1915900E-04,.3377300E-04,.4589200E-04,.5231400E-04,& - & .1712300E-07,.9645300E-05,.1668800E-04,.2252800E-04,.2664800E-04,& - & .1848900E-07,.1130500E-04,.1946400E-04,.2613700E-04,.3061700E-04,& - & .1962100E-07,.1314300E-04,.2255400E-04,.3023800E-04,.3487600E-04,& - & .2065300E-07,.1469800E-04,.2592800E-04,.3471200E-04,.3939800E-04,& - & .2150000E-07,.1631500E-04,.2865100E-04,.3930200E-04,.4409700E-04,& - & .1341400E-07,.8335500E-05,.1440900E-04,.1946100E-04,.2258200E-04,& - & .1445600E-07,.9764700E-05,.1681800E-04,.2257800E-04,.2592300E-04,& - & .1541600E-07,.1125000E-04,.1945100E-04,.2611900E-04,.2948200E-04,& - & .1618400E-07,.1252000E-04,.2206400E-04,.2991100E-04,.3323000E-04,& - & .1686100E-07,.1381000E-04,.2433200E-04,.3336300E-04,.3713500E-04/ - - data absb(526:700, 2) / & - & .1057500E-07,.7178600E-05,.1240700E-04,.1671900E-04,.1915800E-04,& - & .1132800E-07,.8409300E-05,.1445700E-04,.1943300E-04,.2194000E-04,& - & .1204900E-07,.9586000E-05,.1671800E-04,.2242500E-04,.2493200E-04,& - & .1268900E-07,.1065500E-04,.1877100E-04,.2564700E-04,.2806500E-04,& - & .1324100E-07,.1170300E-04,.2062800E-04,.2818400E-04,.3132300E-04,& - & .8248900E-08,.6085000E-05,.1050500E-04,.1414000E-04,.1600400E-04,& - & .8853200E-08,.7130600E-05,.1225000E-04,.1646300E-04,.1833300E-04,& - & .9346800E-08,.8026900E-05,.1415800E-04,.1898900E-04,.2083500E-04,& - & .9847800E-08,.8945000E-05,.1569100E-04,.2157600E-04,.2342800E-04,& - & .1033200E-07,.9835400E-05,.1729300E-04,.2361800E-04,.2612800E-04,& - & .6395100E-08,.5054500E-05,.8737800E-05,.1177800E-04,.1317600E-04,& - & .6825200E-08,.5934800E-05,.1019300E-04,.1373000E-04,.1510400E-04,& - & .7244500E-08,.6648000E-05,.1178300E-04,.1583200E-04,.1716000E-04,& - & .7587100E-08,.7396000E-05,.1300500E-04,.1786600E-04,.1929500E-04,& - & .7907500E-08,.8155800E-05,.1430600E-04,.1961700E-04,.2153200E-04,& - & .5057400E-08,.4121500E-05,.7124900E-05,.9592300E-05,.1068600E-04,& - & .5396700E-08,.4851800E-05,.8328600E-05,.1120600E-04,.1226900E-04,& - & .5751700E-08,.5441100E-05,.9638300E-05,.1294200E-04,.1395800E-04,& - & .6027300E-08,.6059000E-05,.1064400E-04,.1461900E-04,.1571400E-04,& - & .6277500E-08,.6690000E-05,.1172300E-04,.1607700E-04,.1756000E-04,& - & .3994800E-08,.3353500E-05,.5797600E-05,.7798900E-05,.8654800E-05,& - & .4264200E-08,.3958400E-05,.6793200E-05,.9129000E-05,.9950700E-05,& - & .4552900E-08,.4447800E-05,.7874600E-05,.1056300E-04,.1133800E-04,& - & .4791100E-08,.4959200E-05,.8701900E-05,.1195000E-04,.1278300E-04,& - & .4995900E-08,.5482000E-05,.9596400E-05,.1315500E-04,.1430800E-04,& - & .3160700E-08,.2726000E-05,.4714300E-05,.6338100E-05,.7009400E-05,& - & .3377100E-08,.3226300E-05,.5535200E-05,.7432200E-05,.8069500E-05,& - & .3590700E-08,.3631600E-05,.6425600E-05,.8613300E-05,.9201900E-05,& - & .3792000E-08,.4055500E-05,.7112800E-05,.9767700E-05,.1039200E-04,& - & .3968700E-08,.4488200E-05,.7849900E-05,.1075300E-04,.1164700E-04,& - & .2513700E-08,.2178200E-05,.3770000E-05,.5063600E-05,.5587200E-05,& - & .2695300E-08,.2587200E-05,.4441100E-05,.5953800E-05,.6469300E-05,& - & .2873800E-08,.2941500E-05,.5169700E-05,.6921700E-05,.7380600E-05,& - & .3036500E-08,.3288700E-05,.5757400E-05,.7911500E-05,.8354700E-05,& - & .3182700E-08,.3639100E-05,.6373000E-05,.8711400E-05,.9385400E-05/ - - data absb(701:875, 2) / & - & .2004900E-08,.1735000E-05,.3008900E-05,.4034200E-05,.4443700E-05,& - & .2152200E-08,.2068500E-05,.3553200E-05,.4754200E-05,.5157700E-05,& - & .2297800E-08,.2371600E-05,.4149000E-05,.5545900E-05,.5902900E-05,& - & .2427700E-08,.2660800E-05,.4658500E-05,.6392800E-05,.6701500E-05,& - & .2559200E-08,.2943400E-05,.5161400E-05,.7037600E-05,.7547200E-05,& - & .1600700E-08,.1379300E-05,.2393900E-05,.3220300E-05,.3534700E-05,& - & .1718200E-08,.1650900E-05,.2838800E-05,.3795000E-05,.4106900E-05,& - & .1836400E-08,.1905800E-05,.3325000E-05,.4438600E-05,.4716900E-05,& - & .1945900E-08,.2143600E-05,.3767600E-05,.5138900E-05,.5371000E-05,& - & .2055500E-08,.2378100E-05,.4172200E-05,.5691500E-05,.6061300E-05,& - & .1276300E-08,.1085500E-05,.1884200E-05,.2535500E-05,.2789400E-05,& - & .1369300E-08,.1303800E-05,.2243400E-05,.2999100E-05,.3245200E-05,& - & .1466900E-08,.1522700E-05,.2639400E-05,.3519500E-05,.3740300E-05,& - & .1562100E-08,.1714500E-05,.3018800E-05,.4088100E-05,.4275700E-05,& - & .1646700E-08,.1909300E-05,.3348100E-05,.4576800E-05,.4835700E-05,& - & .1016400E-08,.8490800E-06,.1474100E-05,.1986400E-05,.2174400E-05,& - & .1092600E-08,.1023200E-05,.1764200E-05,.2353600E-05,.2556200E-05,& - & .1171700E-08,.1215600E-05,.2083600E-05,.2775000E-05,.2954700E-05,& - & .1250200E-08,.1367100E-05,.2414900E-05,.3237400E-05,.3385600E-05,& - & .1320400E-08,.1529000E-05,.2680100E-05,.3663100E-05,.3843000E-05,& - & .8096700E-09,.6624700E-06,.1152500E-05,.1555700E-05,.1691100E-05,& - & .8709100E-09,.8011400E-06,.1383800E-05,.1845700E-05,.2007100E-05,& - & .9347100E-09,.9606300E-06,.1641400E-05,.2186200E-05,.2335700E-05,& - & .9999600E-09,.1089800E-05,.1928700E-05,.2558700E-05,.2676500E-05,& - & .1059400E-08,.1225500E-05,.2143700E-05,.2923900E-05,.3049100E-05,& - & .6443800E-09,.5140800E-06,.8969200E-06,.1217600E-05,.1309400E-05,& - & .6933800E-09,.6233500E-06,.1078300E-05,.1440800E-05,.1569700E-05,& - & .7424900E-09,.7519700E-06,.1285900E-05,.1711600E-05,.1828600E-05,& - & .7971000E-09,.8678500E-06,.1518200E-05,.2011700E-05,.2107200E-05,& - & .8496600E-09,.9792300E-06,.1715600E-05,.2335400E-05,.2409600E-05,& - & .5123600E-09,.3948300E-06,.6910000E-06,.9487100E-06,.1005000E-05,& - & .5507500E-09,.4807500E-06,.8332600E-06,.1117100E-05,.1216900E-05,& - & .5915300E-09,.5827900E-06,.9992200E-06,.1330700E-05,.1422700E-05,& - & .6348500E-09,.6834700E-06,.1184500E-05,.1569600E-05,.1647400E-05,& - & .6783300E-09,.7735900E-06,.1359300E-05,.1832900E-05,.1893300E-05/ - - data absb(876:1050, 2) / & - & .4074900E-09,.3016200E-06,.5340800E-06,.7277700E-06,.7676800E-06,& - & .4368200E-09,.3697500E-06,.6420100E-06,.8617400E-06,.9333400E-06,& - & .4698100E-09,.4501500E-06,.7746000E-06,.1030600E-05,.1109200E-05,& - & .5030200E-09,.5391200E-06,.9217100E-06,.1222500E-05,.1287400E-05,& - & .5399900E-09,.6101300E-06,.1079000E-05,.1433400E-05,.1482800E-05,& - & .3228800E-09,.2311500E-06,.4162500E-06,.5531800E-06,.5847600E-06,& - & .3473100E-09,.2835500E-06,.4949300E-06,.6685000E-06,.7160000E-06,& - & .3731000E-09,.3468200E-06,.5982000E-06,.7961700E-06,.8598500E-06,& - & .3997500E-09,.4203400E-06,.7152700E-06,.9504600E-06,.1004100E-05,& - & .4297000E-09,.4834100E-06,.8482900E-06,.1119100E-05,.1158200E-05,& - & .2564600E-09,.1774300E-06,.3242300E-06,.4217500E-06,.4475400E-06,& - & .2766900E-09,.2185600E-06,.3822000E-06,.5210200E-06,.5514100E-06,& - & .2965400E-09,.2680800E-06,.4637500E-06,.6192100E-06,.6702500E-06,& - & .3187200E-09,.3266200E-06,.5568700E-06,.7398500E-06,.7829100E-06,& - & .3419800E-09,.3813600E-06,.6638500E-06,.8759100E-06,.9077100E-06,& - & .2047200E-09,.1369400E-06,.2472600E-06,.3221600E-06,.3422900E-06,& - & .2205400E-09,.1684200E-06,.2964600E-06,.4063500E-06,.4240200E-06,& - & .2365300E-09,.2073100E-06,.3591300E-06,.4802700E-06,.5171400E-06,& - & .2540200E-09,.2537900E-06,.4337700E-06,.5768900E-06,.6122800E-06,& - & .2723300E-09,.3020200E-06,.5194000E-06,.6862600E-06,.7114600E-06,& - & .1642800E-09,.1068700E-06,.1880300E-06,.2451700E-06,.2609000E-06,& - & .1752000E-09,.1297800E-06,.2302500E-06,.3110600E-06,.3251200E-06,& - & .1886500E-09,.1599400E-06,.2772600E-06,.3726100E-06,.3988800E-06,& - & .2026500E-09,.1967000E-06,.3370800E-06,.4484500E-06,.4777900E-06,& - & .2171100E-09,.2373900E-06,.4052800E-06,.5366800E-06,.5582800E-06,& - & .1320600E-09,.8267700E-07,.1428400E-06,.1864000E-06,.1989800E-06,& - & .1393800E-09,.9959700E-07,.1809500E-06,.2372500E-06,.2491100E-06,& - & .1505600E-09,.1230900E-06,.2149400E-06,.2902600E-06,.3072000E-06,& - & .1613600E-09,.1520500E-06,.2614700E-06,.3477400E-06,.3733100E-06,& - & .1731800E-09,.1854700E-06,.3156600E-06,.4185700E-06,.4364900E-06,& - & .1062800E-09,.6352900E-07,.1093800E-06,.1428500E-06,.1528100E-06,& - & .1118100E-09,.7706800E-07,.1403600E-06,.1820100E-06,.1916300E-06,& - & .1199200E-09,.9538700E-07,.1669200E-06,.2287800E-06,.2382400E-06,& - & .1290000E-09,.1180900E-06,.2040600E-06,.2716300E-06,.2907800E-06,& - & .1382800E-09,.1451000E-06,.2467800E-06,.3275300E-06,.3421700E-06/ - - data absb(1051:1175, 2) / & - & .8566400E-10,.4844400E-07,.8393200E-07,.1095000E-06,.1178500E-06,& - & .8999900E-10,.5988500E-07,.1077600E-06,.1402300E-06,.1476300E-06,& - & .9583600E-10,.7394100E-07,.1302300E-06,.1787600E-06,.1842600E-06,& - & .1032300E-09,.9179100E-07,.1588200E-06,.2120200E-06,.2261100E-06,& - & .1108100E-09,.1133600E-06,.1931600E-06,.2564700E-06,.2691800E-06,& - & .6909300E-10,.3683200E-07,.6412300E-07,.8403000E-07,.9097400E-07,& - & .7243300E-10,.4708400E-07,.8261300E-07,.1075800E-06,.1134600E-06,& - & .7661600E-10,.5738800E-07,.1018200E-06,.1376800E-06,.1422400E-06,& - & .8270900E-10,.7129400E-07,.1235500E-06,.1653000E-06,.1754900E-06,& - & .8863600E-10,.8844500E-07,.1509400E-06,.2006700E-06,.2111800E-06,& - & .5598000E-10,.2801800E-07,.4886700E-07,.6485700E-07,.7005500E-07,& - & .5839700E-10,.3662000E-07,.6323200E-07,.8242800E-07,.8745700E-07,& - & .6150900E-10,.4444600E-07,.8051200E-07,.1058000E-06,.1098800E-06,& - & .6601500E-10,.5522200E-07,.9640100E-07,.1293500E-06,.1361400E-06,& - & .7097600E-10,.6882100E-07,.1178000E-06,.1563200E-06,.1658600E-06,& - & .4572200E-10,.2150600E-07,.3732600E-07,.5033300E-07,.5485500E-07,& - & .4709000E-10,.2824900E-07,.4861200E-07,.6344200E-07,.6755000E-07,& - & .4955000E-10,.3443000E-07,.6276900E-07,.8150900E-07,.8491700E-07,& - & .5281700E-10,.4295800E-07,.7517300E-07,.1020400E-06,.1060300E-06,& - & .5686400E-10,.5363700E-07,.9204400E-07,.1222900E-06,.1301100E-06,& - & .3749600E-10,.1725500E-07,.2996700E-07,.4039400E-07,.4405900E-07,& - & .3836700E-10,.2278200E-07,.3914400E-07,.5101900E-07,.5440400E-07,& - & .4034600E-10,.2784200E-07,.5069200E-07,.6571600E-07,.6844000E-07,& - & .4290800E-10,.3476100E-07,.6084600E-07,.8283400E-07,.8571300E-07,& - & .4621300E-10,.4346700E-07,.7462600E-07,.9914400E-07,.1051800E-06/ - - data absb( 1:175, 3) / & - & .9118000E-05,.1275400E-02,.1990000E-02,.2444000E-02,.4057600E-02,& - & .9503700E-05,.1415000E-02,.2214500E-02,.2809400E-02,.4437500E-02,& - & .9975700E-05,.1562600E-02,.2432000E-02,.3137500E-02,.4809700E-02,& - & .1050800E-04,.1699700E-02,.2692600E-02,.3448300E-02,.5155400E-02,& - & .1103300E-04,.1837300E-02,.2968400E-02,.3786100E-02,.5489600E-02,& - & .7320900E-05,.1072700E-02,.1678700E-02,.2088100E-02,.3304100E-02,& - & .7679500E-05,.1193700E-02,.1868300E-02,.2361600E-02,.3624600E-02,& - & .8041700E-05,.1317700E-02,.2056700E-02,.2646500E-02,.3943800E-02,& - & .8429600E-05,.1431700E-02,.2282600E-02,.2902200E-02,.4236800E-02,& - & .8895000E-05,.1549500E-02,.2508400E-02,.3190100E-02,.4499200E-02,& - & .5827500E-05,.8989500E-03,.1416100E-02,.1776000E-02,.2650800E-02,& - & .6116600E-05,.1002500E-02,.1570600E-02,.1989300E-02,.2921900E-02,& - & .6434000E-05,.1105500E-02,.1737500E-02,.2223700E-02,.3171800E-02,& - & .6750100E-05,.1202800E-02,.1929100E-02,.2443300E-02,.3401500E-02,& - & .7084300E-05,.1303400E-02,.2115200E-02,.2689200E-02,.3635000E-02,& - & .4577600E-05,.7523300E-03,.1190600E-02,.1495700E-02,.2107600E-02,& - & .4826200E-05,.8405100E-03,.1319200E-02,.1678000E-02,.2326700E-02,& - & .5102400E-05,.9260300E-03,.1465300E-02,.1867100E-02,.2524200E-02,& - & .5385600E-05,.1009300E-02,.1628800E-02,.2059900E-02,.2713400E-02,& - & .5662500E-05,.1093900E-02,.1783400E-02,.2269300E-02,.2909200E-02,& - & .3597800E-05,.6305500E-03,.1000100E-02,.1261800E-02,.1675900E-02,& - & .3809000E-05,.7051900E-03,.1108000E-02,.1414200E-02,.1856300E-02,& - & .4036500E-05,.7759300E-03,.1235200E-02,.1569200E-02,.2021500E-02,& - & .4269200E-05,.8464800E-03,.1375300E-02,.1736100E-02,.2188200E-02,& - & .4532500E-05,.9181500E-03,.1503100E-02,.1915600E-02,.2351100E-02,& - & .2857700E-05,.5292300E-03,.8406000E-03,.1064100E-02,.1352400E-02,& - & .3018900E-05,.5927500E-03,.9326400E-03,.1192500E-02,.1505100E-02,& - & .3197100E-05,.6514000E-03,.1042200E-02,.1317400E-02,.1641300E-02,& - & .3398100E-05,.7114400E-03,.1159400E-02,.1461300E-02,.1785100E-02,& - & .3612700E-05,.7720000E-03,.1268500E-02,.1616400E-02,.1916600E-02,& - & .2283200E-05,.4448900E-03,.7052300E-03,.8915000E-03,.1105400E-02,& - & .2400500E-05,.4986000E-03,.7859600E-03,.1003300E-02,.1231000E-02,& - & .2546500E-05,.5474600E-03,.8809600E-03,.1108400E-02,.1347900E-02,& - & .2716700E-05,.5976000E-03,.9768500E-03,.1230500E-02,.1466800E-02,& - & .2892700E-05,.6484400E-03,.1069500E-02,.1363200E-02,.1574600E-02/ - - data absb(176:350, 3) / & - & .1842600E-05,.3756700E-03,.5927600E-03,.7500200E-03,.9115900E-03,& - & .1932400E-05,.4204900E-03,.6637600E-03,.8430400E-03,.1017500E-02,& - & .2056300E-05,.4610400E-03,.7456100E-03,.9356800E-03,.1115300E-02,& - & .2195200E-05,.5030200E-03,.8249100E-03,.1041000E-02,.1213100E-02,& - & .2342900E-05,.5457000E-03,.9032400E-03,.1151200E-02,.1300200E-02,& - & .1491400E-05,.3172700E-03,.4987900E-03,.6314100E-03,.7548000E-03,& - & .1571100E-05,.3536700E-03,.5610500E-03,.7085900E-03,.8427800E-03,& - & .1672000E-05,.3877600E-03,.6312200E-03,.7906600E-03,.9249200E-03,& - & .1783000E-05,.4232700E-03,.6965500E-03,.8831100E-03,.1004100E-02,& - & .1906500E-05,.4590500E-03,.7623800E-03,.9732000E-03,.1076700E-02,& - & .1200700E-05,.2697600E-03,.4231600E-03,.5375000E-03,.6274700E-03,& - & .1274400E-05,.2988000E-03,.4784000E-03,.6009400E-03,.7013400E-03,& - & .1357200E-05,.3281300E-03,.5367200E-03,.6734100E-03,.7691600E-03,& - & .1445900E-05,.3576100E-03,.5915400E-03,.7542100E-03,.8337100E-03,& - & .1553800E-05,.3879200E-03,.6466300E-03,.8287700E-03,.8952900E-03,& - & .9686100E-06,.2291800E-03,.3601500E-03,.4571900E-03,.5240400E-03,& - & .1033600E-05,.2532100E-03,.4083400E-03,.5116100E-03,.5835100E-03,& - & .1098500E-05,.2776700E-03,.4557100E-03,.5745900E-03,.6398500E-03,& - & .1176800E-05,.3025200E-03,.5019500E-03,.6419000E-03,.6930300E-03,& - & .1261500E-05,.3279400E-03,.5483100E-03,.7057900E-03,.7454000E-03,& - & .7756000E-06,.1943700E-03,.3074800E-03,.3882800E-03,.4352900E-03,& - & .8258000E-06,.2143800E-03,.3483500E-03,.4361700E-03,.4837300E-03,& - & .8820000E-06,.2349200E-03,.3868000E-03,.4916900E-03,.5318900E-03,& - & .9494700E-06,.2557300E-03,.4263500E-03,.5464100E-03,.5763700E-03,& - & .1018200E-05,.2774500E-03,.4660700E-03,.6004600E-03,.6199800E-03,& - & .6196300E-06,.1645400E-03,.2628400E-03,.3301600E-03,.3628400E-03,& - & .6614600E-06,.1816200E-03,.2971400E-03,.3731500E-03,.4037000E-03,& - & .7111100E-06,.1988200E-03,.3294200E-03,.4213000E-03,.4438200E-03,& - & .7657300E-06,.2166300E-03,.3622800E-03,.4664000E-03,.4805200E-03,& - & .8210000E-06,.2350300E-03,.3962700E-03,.5113200E-03,.5177600E-03,& - & .4971800E-06,.1398200E-03,.2252300E-03,.2827500E-03,.3055800E-03,& - & .5336500E-06,.1543100E-03,.2536800E-03,.3204400E-03,.3389500E-03,& - & .5770500E-06,.1688400E-03,.2808200E-03,.3601900E-03,.3717300E-03,& - & .6206100E-06,.1839300E-03,.3086500E-03,.3986600E-03,.4024300E-03,& - & .6642700E-06,.1996800E-03,.3375700E-03,.4366300E-03,.4330900E-03/ - - data absb(351:525, 3) / & - & .3996100E-06,.1188900E-03,.1936100E-03,.2427000E-03,.2569300E-03,& - & .4313600E-06,.1310000E-03,.2163200E-03,.2759100E-03,.2846300E-03,& - & .4649000E-06,.1433300E-03,.2396600E-03,.3084900E-03,.3110600E-03,& - & .5000900E-06,.1563000E-03,.2634600E-03,.3408300E-03,.3371300E-03,& - & .5380800E-06,.1699900E-03,.2876800E-03,.3732300E-03,.3627900E-03,& - & .3198600E-06,.1010600E-03,.1658500E-03,.2089100E-03,.2155800E-03,& - & .3454000E-06,.1111900E-03,.1850000E-03,.2376000E-03,.2385400E-03,& - & .3722600E-06,.1218300E-03,.2045600E-03,.2641900E-03,.2605300E-03,& - & .4031700E-06,.1329000E-03,.2248700E-03,.2915600E-03,.2826200E-03,& - & .4327100E-06,.1448200E-03,.2454100E-03,.3193400E-03,.3041900E-03,& - & .2567700E-06,.8606000E-04,.1420600E-03,.1802300E-03,.1814100E-03,& - & .2773600E-06,.9467700E-04,.1584100E-03,.2037800E-03,.2008800E-03,& - & .3010400E-06,.1037200E-03,.1751500E-03,.2266300E-03,.2192100E-03,& - & .3258400E-06,.1134000E-03,.1923200E-03,.2495300E-03,.2378900E-03,& - & .3489100E-06,.1236800E-03,.2097600E-03,.2736400E-03,.2557000E-03,& - & .2055600E-06,.7327400E-04,.1217000E-03,.1558800E-03,.1531200E-03,& - & .2237600E-06,.8065100E-04,.1356800E-03,.1752400E-03,.1694800E-03,& - & .2431300E-06,.8848100E-04,.1499200E-03,.1944700E-03,.1847700E-03,& - & .2623300E-06,.9682400E-04,.1645800E-03,.2140900E-03,.2002700E-03,& - & .2824900E-06,.1058000E-03,.1798700E-03,.2343500E-03,.2153200E-03,& - & .1655300E-06,.6253600E-04,.1045700E-03,.1344300E-03,.1296800E-03,& - & .1807800E-06,.6886300E-04,.1164300E-03,.1506000E-03,.1430400E-03,& - & .1961900E-06,.7567000E-04,.1286400E-03,.1668100E-03,.1561500E-03,& - & .2115800E-06,.8289900E-04,.1411400E-03,.1838500E-03,.1691100E-03,& - & .2291500E-06,.9062900E-04,.1545600E-03,.2009900E-03,.1814600E-03,& - & .1338000E-06,.5340700E-04,.8993000E-04,.1159100E-03,.1100500E-03,& - & .1460400E-06,.5888700E-04,.1000100E-03,.1296300E-03,.1210700E-03,& - & .1584800E-06,.6479000E-04,.1104000E-03,.1434900E-03,.1323000E-03,& - & .1719000E-06,.7116900E-04,.1212500E-03,.1579200E-03,.1429700E-03,& - & .1858700E-06,.7779200E-04,.1329200E-03,.1726500E-03,.1530800E-03,& - & .1083000E-06,.4568600E-04,.7733900E-04,.9986700E-04,.9356200E-04,& - & .1176500E-06,.5052600E-04,.8595900E-04,.1115300E-03,.1026900E-03,& - & .1282400E-06,.5562700E-04,.9490000E-04,.1235400E-03,.1120500E-03,& - & .1395800E-06,.6115800E-04,.1044000E-03,.1357300E-03,.1209900E-03,& - & .1507800E-06,.6690900E-04,.1143100E-03,.1486100E-03,.1291800E-03/ - - data absb(526:700, 3) / & - & .8753700E-07,.3907300E-04,.6633000E-04,.8586000E-04,.7929600E-04,& - & .9527000E-07,.4328200E-04,.7374300E-04,.9573300E-04,.8708200E-04,& - & .1042300E-06,.4770100E-04,.8144700E-04,.1060900E-03,.9485700E-04,& - & .1134800E-06,.5248400E-04,.8962400E-04,.1163800E-03,.1021100E-03,& - & .1228900E-06,.5743100E-04,.9812200E-04,.1276000E-03,.1086600E-03,& - & .6989100E-07,.3312900E-04,.5632300E-04,.7303600E-04,.6656800E-04,& - & .7646500E-07,.3672400E-04,.6262700E-04,.8152000E-04,.7317600E-04,& - & .8383300E-07,.4061900E-04,.6929300E-04,.9016100E-04,.7954800E-04,& - & .9143600E-07,.4467100E-04,.7636200E-04,.9907500E-04,.8549700E-04,& - & .9926300E-07,.4888600E-04,.8355000E-04,.1084900E-03,.9072000E-04,& - & .5508000E-07,.2779600E-04,.4726100E-04,.6129900E-04,.5523700E-04,& - & .6056200E-07,.3085000E-04,.5263500E-04,.6851500E-04,.6079400E-04,& - & .6644000E-07,.3420000E-04,.5829800E-04,.7584700E-04,.6609700E-04,& - & .7291300E-07,.3765000E-04,.6431000E-04,.8353000E-04,.7103200E-04,& - & .7954500E-07,.4121600E-04,.7039700E-04,.9130400E-04,.7519300E-04,& - & .4364400E-07,.2299700E-04,.3908800E-04,.5071400E-04,.4537400E-04,& - & .4818200E-07,.2558500E-04,.4366100E-04,.5681300E-04,.5005700E-04,& - & .5306700E-07,.2842900E-04,.4846500E-04,.6302000E-04,.5449000E-04,& - & .5834900E-07,.3136500E-04,.5360300E-04,.6951600E-04,.5858500E-04,& - & .6372700E-07,.3439800E-04,.5871000E-04,.7603200E-04,.6204600E-04,& - & .3466100E-07,.1900300E-04,.3229500E-04,.4189800E-04,.3720700E-04,& - & .3841400E-07,.2120000E-04,.3617000E-04,.4704500E-04,.4115000E-04,& - & .4237800E-07,.2360500E-04,.4024700E-04,.5230600E-04,.4487200E-04,& - & .4659800E-07,.2611000E-04,.4462000E-04,.5780000E-04,.4829300E-04,& - & .5099500E-07,.2868300E-04,.4893500E-04,.6325000E-04,.5115500E-04,& - & .2754500E-07,.1570000E-04,.2666100E-04,.3460300E-04,.3048700E-04,& - & .3055300E-07,.1756800E-04,.2994800E-04,.3893500E-04,.3381300E-04,& - & .3377200E-07,.1960100E-04,.3341100E-04,.4340300E-04,.3692200E-04,& - & .3716400E-07,.2172600E-04,.3711300E-04,.4803000E-04,.3977100E-04,& - & .4079500E-07,.2390100E-04,.4076500E-04,.5260700E-04,.4215200E-04,& - & .2185200E-07,.1281900E-04,.2175700E-04,.2822100E-04,.2474500E-04,& - & .2420700E-07,.1439500E-04,.2452700E-04,.3186700E-04,.2750200E-04,& - & .2680600E-07,.1609200E-04,.2746200E-04,.3564600E-04,.3014500E-04,& - & .2961200E-07,.1789400E-04,.3057200E-04,.3952700E-04,.3254300E-04,& - & .3257700E-07,.1974600E-04,.3367200E-04,.4339900E-04,.3455600E-04/ - - data absb(701:875, 3) / & - & .1733600E-07,.1044100E-04,.1769500E-04,.2295400E-04,.2004200E-04,& - & .1918700E-07,.1177100E-04,.2002500E-04,.2602900E-04,.2234600E-04,& - & .2131100E-07,.1319000E-04,.2251600E-04,.2920100E-04,.2457700E-04,& - & .2359700E-07,.1471200E-04,.2512200E-04,.3246600E-04,.2658400E-04,& - & .2595800E-07,.1628000E-04,.2774400E-04,.3576200E-04,.2829500E-04,& - & .1375200E-07,.8497000E-05,.1437900E-04,.1864000E-04,.1620500E-04,& - & .1524000E-07,.9608200E-05,.1632500E-04,.2122500E-04,.1812400E-04,& - & .1692400E-07,.1080200E-04,.1843000E-04,.2389600E-04,.2002400E-04,& - & .1876700E-07,.1208700E-04,.2060900E-04,.2665100E-04,.2169800E-04,& - & .2066600E-07,.1340900E-04,.2283700E-04,.2942700E-04,.2315300E-04,& - & .1082700E-07,.6862400E-05,.1158600E-04,.1499900E-04,.1297500E-04,& - & .1203000E-07,.7784700E-05,.1320500E-04,.1716400E-04,.1460500E-04,& - & .1335200E-07,.8777900E-05,.1497400E-04,.1941000E-04,.1623100E-04,& - & .1482900E-07,.9862000E-05,.1679500E-04,.2175100E-04,.1763400E-04,& - & .1639600E-07,.1097500E-04,.1868200E-04,.2406600E-04,.1887900E-04,& - & .8573100E-08,.5513200E-05,.9286200E-05,.1200000E-04,.1034700E-04,& - & .9503300E-08,.6281600E-05,.1062900E-04,.1381700E-04,.1171200E-04,& - & .1053700E-07,.7096400E-05,.1210800E-04,.1570000E-04,.1309500E-04,& - & .1172200E-07,.8012000E-05,.1362100E-04,.1767900E-04,.1429600E-04,& - & .1299100E-07,.8945700E-05,.1522000E-04,.1961400E-04,.1535000E-04,& - & .6751500E-08,.4421200E-05,.7424400E-05,.9577600E-05,.8242900E-05,& - & .7499900E-08,.5060300E-05,.8536000E-05,.1109500E-04,.9379100E-05,& - & .8318200E-08,.5741100E-05,.9768600E-05,.1266700E-04,.1052800E-04,& - & .9252600E-08,.6494200E-05,.1102800E-04,.1432800E-04,.1156600E-04,& - & .1026900E-07,.7276900E-05,.1237500E-04,.1596400E-04,.1247200E-04,& - & .5303100E-08,.3530100E-05,.5905000E-05,.7596500E-05,.6545200E-05,& - & .5890700E-08,.4056100E-05,.6823300E-05,.8862100E-05,.7477100E-05,& - & .6542200E-08,.4627000E-05,.7839300E-05,.1016900E-04,.8437000E-05,& - & .7266900E-08,.5243300E-05,.8906100E-05,.1156300E-04,.9326800E-05,& - & .8088000E-08,.5896700E-05,.1001600E-04,.1293000E-04,.1010600E-04,& - & .4145900E-08,.2796500E-05,.4652900E-05,.5964800E-05,.5155200E-05,& - & .4632400E-08,.3225300E-05,.5410000E-05,.7009400E-05,.5911000E-05,& - & .5143300E-08,.3701400E-05,.6239500E-05,.8097600E-05,.6710000E-05,& - & .5704500E-08,.4209100E-05,.7138100E-05,.9253700E-05,.7489600E-05,& - & .6352600E-08,.4754100E-05,.8057300E-05,.1042800E-04,.8154000E-05/ - - data absb(876:1050, 3) / & - & .3254900E-08,.2208900E-05,.3657100E-05,.4666300E-05,.4038700E-05,& - & .3619200E-08,.2558100E-05,.4275200E-05,.5526500E-05,.4658200E-05,& - & .4021500E-08,.2951500E-05,.4955300E-05,.6432700E-05,.5323600E-05,& - & .4473600E-08,.3369000E-05,.5701500E-05,.7385900E-05,.5996000E-05,& - & .4976000E-08,.3827600E-05,.6459600E-05,.8384400E-05,.6564700E-05,& - & .2543200E-08,.1739000E-05,.2860700E-05,.3643800E-05,.3142500E-05,& - & .2836400E-08,.2021900E-05,.3369800E-05,.4341200E-05,.3665400E-05,& - & .3160100E-08,.2347200E-05,.3923200E-05,.5096400E-05,.4214200E-05,& - & .3510100E-08,.2694800E-05,.4542900E-05,.5879700E-05,.4771500E-05,& - & .3898900E-08,.3071800E-05,.5173100E-05,.6719000E-05,.5272000E-05,& - & .2009300E-08,.1370400E-05,.2237300E-05,.2837500E-05,.2455000E-05,& - & .2227000E-08,.1602000E-05,.2662600E-05,.3414400E-05,.2896300E-05,& - & .2479700E-08,.1868600E-05,.3113100E-05,.4034800E-05,.3339800E-05,& - & .2761400E-08,.2159300E-05,.3619900E-05,.4685600E-05,.3801900E-05,& - & .3067400E-08,.2469900E-05,.4151700E-05,.5384400E-05,.4232200E-05,& - & .1590700E-08,.1080300E-05,.1751800E-05,.2206400E-05,.1925400E-05,& - & .1750900E-08,.1269100E-05,.2100000E-05,.2679400E-05,.2283200E-05,& - & .1950900E-08,.1486100E-05,.2472600E-05,.3195700E-05,.2641800E-05,& - & .2170300E-08,.1728400E-05,.2883800E-05,.3732500E-05,.3025700E-05,& - & .2412400E-08,.1984400E-05,.3330500E-05,.4312800E-05,.3401500E-05,& - & .1256400E-08,.8466900E-06,.1371700E-05,.1714700E-05,.1494700E-05,& - & .1379400E-08,.1002400E-05,.1652300E-05,.2099300E-05,.1787000E-05,& - & .1532000E-08,.1179000E-05,.1957700E-05,.2522000E-05,.2084500E-05,& - & .1713000E-08,.1379100E-05,.2295200E-05,.2967700E-05,.2404000E-05,& - & .1904100E-08,.1591400E-05,.2663500E-05,.3443900E-05,.2724700E-05,& - & .9952300E-09,.6621900E-06,.1063200E-05,.1334100E-05,.1155000E-05,& - & .1090300E-08,.7902200E-06,.1291400E-05,.1640100E-05,.1392900E-05,& - & .1208200E-08,.9326600E-06,.1544500E-05,.1984100E-05,.1645200E-05,& - & .1343700E-08,.1096900E-05,.1821200E-05,.2351700E-05,.1902900E-05,& - & .1497200E-08,.1273400E-05,.2127600E-05,.2743100E-05,.2172200E-05,& - & .7878200E-09,.5199300E-06,.8275200E-06,.1042100E-05,.8863200E-06,& - & .8664200E-09,.6244000E-06,.1013800E-05,.1282000E-05,.1095800E-05,& - & .9514100E-09,.7405100E-06,.1222100E-05,.1562600E-05,.1301400E-05,& - & .1062200E-08,.8743800E-06,.1448100E-05,.1867500E-05,.1513800E-05,& - & .1182900E-08,.1021700E-05,.1702500E-05,.2190000E-05,.1734900E-05/ - - data absb(1051:1175, 3) / & - & .6273400E-09,.4084400E-06,.6467500E-06,.8116800E-06,.6801500E-06,& - & .6867000E-09,.4943700E-06,.7982200E-06,.1003100E-05,.8595500E-06,& - & .7555100E-09,.5881300E-06,.9664000E-06,.1230500E-05,.1029000E-05,& - & .8389600E-09,.6976200E-06,.1152900E-05,.1484500E-05,.1202500E-05,& - & .9372700E-09,.8199200E-06,.1361800E-05,.1748900E-05,.1385600E-05,& - & .5021400E-09,.3202800E-06,.5052400E-06,.6314700E-06,.5190300E-06,& - & .5477500E-09,.3884100E-06,.6258900E-06,.7844500E-06,.6709900E-06,& - & .5997100E-09,.4660200E-06,.7635600E-06,.9697800E-06,.8091200E-06,& - & .6646600E-09,.5550900E-06,.9153300E-06,.1176600E-05,.9528400E-06,& - & .7393100E-09,.6562500E-06,.1086400E-05,.1394600E-05,.1105500E-05,& - & .4017100E-09,.2500900E-06,.3921100E-06,.4925000E-06,.3933200E-06,& - & .4337900E-09,.3047300E-06,.4893200E-06,.6134200E-06,.5207600E-06,& - & .4772900E-09,.3687400E-06,.5997800E-06,.7624600E-06,.6355600E-06,& - & .5245400E-09,.4407500E-06,.7248800E-06,.9307900E-06,.7544800E-06,& - & .5854600E-09,.5238900E-06,.8656500E-06,.1110700E-05,.8785800E-06,& - & .3222200E-09,.1953600E-06,.3048400E-06,.3812300E-06,.2979800E-06,& - & .3455000E-09,.2400300E-06,.3820600E-06,.4803300E-06,.4019300E-06,& - & .3793000E-09,.2917900E-06,.4722600E-06,.5993800E-06,.5005600E-06,& - & .4167500E-09,.3503500E-06,.5750000E-06,.7364200E-06,.5983600E-06,& - & .4632000E-09,.4185400E-06,.6904100E-06,.8854800E-06,.7000300E-06,& - & .2616600E-09,.1586800E-06,.2469700E-06,.3089200E-06,.2396400E-06,& - & .2809500E-09,.1955200E-06,.3106800E-06,.3903700E-06,.3246900E-06,& - & .3073000E-09,.2385600E-06,.3855400E-06,.4890200E-06,.4073800E-06,& - & .3378100E-09,.2874900E-06,.4715700E-06,.6028600E-06,.4880300E-06,& - & .3752600E-09,.3443900E-06,.5678900E-06,.7274200E-06,.5723800E-06/ - - data absb( 1:175, 4) / & - & .4903800E-04,.5078100E-02,.7825400E-02,.9648400E-02,.1061400E-01,& - & .5422500E-04,.5490500E-02,.8571000E-02,.1046000E-01,.1120600E-01,& - & .6113400E-04,.5877300E-02,.9318300E-02,.1134700E-01,.1172900E-01,& - & .6879300E-04,.6279400E-02,.9976800E-02,.1224800E-01,.1225000E-01,& - & .7742900E-04,.6689300E-02,.1062400E-01,.1306400E-01,.1273000E-01,& - & .4070600E-04,.4304500E-02,.6624000E-02,.8122700E-02,.8710500E-02,& - & .4578900E-04,.4640400E-02,.7254700E-02,.8850800E-02,.9218300E-02,& - & .5135900E-04,.4967000E-02,.7864900E-02,.9592800E-02,.9659000E-02,& - & .5844800E-04,.5311200E-02,.8416500E-02,.1035600E-01,.1008500E-01,& - & .6658500E-04,.5659000E-02,.8977000E-02,.1102200E-01,.1054000E-01,& - & .3316100E-04,.3637400E-02,.5600700E-02,.6840800E-02,.7039900E-02,& - & .3731600E-04,.3914500E-02,.6131800E-02,.7481200E-02,.7453300E-02,& - & .4218400E-04,.4194900E-02,.6627200E-02,.8109700E-02,.7839300E-02,& - & .4824900E-04,.4486100E-02,.7093400E-02,.8733000E-02,.8226200E-02,& - & .5491200E-04,.4782900E-02,.7568800E-02,.9283000E-02,.8605800E-02,& - & .2659800E-04,.3064900E-02,.4732300E-02,.5774200E-02,.5664400E-02,& - & .3009600E-04,.3295000E-02,.5177800E-02,.6314500E-02,.6019300E-02,& - & .3408500E-04,.3535000E-02,.5580600E-02,.6844700E-02,.6370800E-02,& - & .3891900E-04,.3783100E-02,.5971900E-02,.7346500E-02,.6708800E-02,& - & .4449200E-04,.4039300E-02,.6375000E-02,.7812000E-02,.7024900E-02,& - & .2144900E-04,.2575600E-02,.3993600E-02,.4866200E-02,.4620500E-02,& - & .2410300E-04,.2770600E-02,.4361900E-02,.5316400E-02,.4920200E-02,& - & .2745100E-04,.2976500E-02,.4695900E-02,.5763200E-02,.5212200E-02,& - & .3138100E-04,.3188400E-02,.5022200E-02,.6173500E-02,.5479000E-02,& - & .3595300E-04,.3409900E-02,.5364500E-02,.6565900E-02,.5741900E-02,& - & .1746800E-04,.2164200E-02,.3364200E-02,.4097200E-02,.3792100E-02,& - & .1950600E-04,.2330800E-02,.3668300E-02,.4469600E-02,.4038500E-02,& - & .2232600E-04,.2507200E-02,.3945400E-02,.4850700E-02,.4277300E-02,& - & .2555800E-04,.2690100E-02,.4224000E-02,.5185500E-02,.4500000E-02,& - & .2951900E-04,.2881600E-02,.4513500E-02,.5516800E-02,.4725900E-02,& - & .1416200E-04,.1816500E-02,.2831100E-02,.3449100E-02,.3126300E-02,& - & .1588000E-04,.1959400E-02,.3079200E-02,.3757700E-02,.3327700E-02,& - & .1825000E-04,.2112400E-02,.3311000E-02,.4071700E-02,.3525500E-02,& - & .2094800E-04,.2271100E-02,.3551200E-02,.4354100E-02,.3711400E-02,& - & .2427900E-04,.2436000E-02,.3797200E-02,.4633600E-02,.3906300E-02/ - - data absb(176:350, 4) / & - & .1167700E-04,.1526800E-02,.2385400E-02,.2905400E-02,.2592700E-02,& - & .1312700E-04,.1650200E-02,.2588400E-02,.3164200E-02,.2758400E-02,& - & .1514500E-04,.1782700E-02,.2785400E-02,.3419800E-02,.2922800E-02,& - & .1742600E-04,.1920800E-02,.2991900E-02,.3656300E-02,.3083600E-02,& - & .2018700E-04,.2063800E-02,.3202700E-02,.3895500E-02,.3251700E-02,& - & .9624800E-05,.1283900E-02,.2006900E-02,.2443900E-02,.2152100E-02,& - & .1088400E-04,.1390500E-02,.2175300E-02,.2663400E-02,.2290100E-02,& - & .1257600E-04,.1505700E-02,.2343000E-02,.2871400E-02,.2427100E-02,& - & .1449200E-04,.1624500E-02,.2522900E-02,.3070900E-02,.2565300E-02,& - & .1678500E-04,.1748700E-02,.2705300E-02,.3276900E-02,.2704100E-02,& - & .7898700E-05,.1084100E-02,.1696300E-02,.2064600E-02,.1792000E-02,& - & .9068800E-05,.1178300E-02,.1836400E-02,.2252300E-02,.1905400E-02,& - & .1043600E-04,.1277600E-02,.1983200E-02,.2422000E-02,.2020000E-02,& - & .1205100E-04,.1380000E-02,.2139100E-02,.2590400E-02,.2136400E-02,& - & .1399200E-04,.1487700E-02,.2298300E-02,.2769000E-02,.2251900E-02,& - & .6514300E-05,.9162900E-03,.1433700E-02,.1746800E-02,.1489000E-02,& - & .7529500E-05,.9988000E-03,.1553200E-02,.1901700E-02,.1584400E-02,& - & .8617200E-05,.1084300E-02,.1682800E-02,.2045400E-02,.1682200E-02,& - & .1001700E-04,.1172900E-02,.1817600E-02,.2191200E-02,.1780000E-02,& - & .1164000E-04,.1266800E-02,.1954900E-02,.2344700E-02,.1876500E-02,& - & .5343200E-05,.7757100E-03,.1211400E-02,.1480500E-02,.1237200E-02,& - & .6151500E-05,.8471800E-03,.1315300E-02,.1607800E-02,.1318100E-02,& - & .7092300E-05,.9202400E-03,.1429300E-02,.1730000E-02,.1398900E-02,& - & .8268400E-05,.9974000E-03,.1544700E-02,.1857300E-02,.1481100E-02,& - & .9626800E-05,.1078900E-02,.1662700E-02,.1989200E-02,.1562100E-02,& - & .4393200E-05,.6589800E-03,.1025900E-02,.1256800E-02,.1028700E-02,& - & .5048300E-05,.7197300E-03,.1117400E-02,.1361000E-02,.1097300E-02,& - & .5852700E-05,.7826900E-03,.1215700E-02,.1465800E-02,.1164800E-02,& - & .6825800E-05,.8496800E-03,.1315800E-02,.1577400E-02,.1235400E-02,& - & .7978000E-05,.9209300E-03,.1417100E-02,.1691700E-02,.1302900E-02,& - & .3634900E-05,.5613900E-03,.8723200E-03,.1067100E-02,.8574700E-03,& - & .4176300E-05,.6130700E-03,.9528400E-03,.1155900E-02,.9164000E-03,& - & .4864300E-05,.6676900E-03,.1037700E-02,.1248000E-02,.9741700E-03,& - & .5680600E-05,.7261800E-03,.1123800E-02,.1344300E-02,.1034100E-02,& - & .6657400E-05,.7879100E-03,.1211800E-02,.1442600E-02,.1090800E-02/ - - data absb(351:525, 4) / & - & .2984900E-05,.4784500E-03,.7432400E-03,.9069500E-03,.7165400E-03,& - & .3452800E-05,.5230500E-03,.8140700E-03,.9834800E-03,.7662200E-03,& - & .4038600E-05,.5706700E-03,.8863500E-03,.1064300E-02,.8161700E-03,& - & .4734900E-05,.6215900E-03,.9604500E-03,.1147600E-02,.8666700E-03,& - & .5550400E-05,.6748600E-03,.1037300E-02,.1232700E-02,.9143700E-03,& - & .2447400E-05,.4081900E-03,.6346900E-03,.7718400E-03,.5995900E-03,& - & .2852700E-05,.4469400E-03,.6955000E-03,.8380900E-03,.6415100E-03,& - & .3344400E-05,.4880400E-03,.7579700E-03,.9092100E-03,.6846400E-03,& - & .3933200E-05,.5322900E-03,.8217400E-03,.9810300E-03,.7268000E-03,& - & .4624500E-05,.5786400E-03,.8887200E-03,.1054400E-02,.7672300E-03,& - & .2025300E-05,.3492100E-03,.5436500E-03,.6586500E-03,.5033100E-03,& - & .2372000E-05,.3827800E-03,.5957700E-03,.7172900E-03,.5386400E-03,& - & .2794500E-05,.4188700E-03,.6490700E-03,.7782300E-03,.5758100E-03,& - & .3293600E-05,.4569900E-03,.7048100E-03,.8407400E-03,.6108900E-03,& - & .3888100E-05,.4975700E-03,.7632500E-03,.9035600E-03,.6456400E-03,& - & .1679700E-05,.2991800E-03,.4659800E-03,.5631600E-03,.4227000E-03,& - & .1976400E-05,.3283900E-03,.5107600E-03,.6143900E-03,.4530600E-03,& - & .2338400E-05,.3598500E-03,.5568600E-03,.6671200E-03,.4844500E-03,& - & .2766200E-05,.3930200E-03,.6052500E-03,.7209200E-03,.5142500E-03,& - & .3268700E-05,.4283700E-03,.6561000E-03,.7757000E-03,.5439600E-03,& - & .1399100E-05,.2568700E-03,.3999600E-03,.4830700E-03,.3557000E-03,& - & .1656400E-05,.2824600E-03,.4385800E-03,.5274300E-03,.3821100E-03,& - & .1966000E-05,.3097100E-03,.4785600E-03,.5730900E-03,.4082600E-03,& - & .2333400E-05,.3388100E-03,.5206600E-03,.6191900E-03,.4336700E-03,& - & .2758700E-05,.3696400E-03,.5649900E-03,.6666000E-03,.4596900E-03,& - & .1171100E-05,.2210200E-03,.3439400E-03,.4151200E-03,.2998000E-03,& - & .1392800E-05,.2433700E-03,.3771300E-03,.4535100E-03,.3225300E-03,& - & .1658900E-05,.2670400E-03,.4120200E-03,.4927200E-03,.3444200E-03,& - & .1974000E-05,.2926100E-03,.4485500E-03,.5327400E-03,.3663300E-03,& - & .2332300E-05,.3197300E-03,.4872600E-03,.5738300E-03,.3891500E-03,& - & .9830000E-06,.1904700E-03,.2959200E-03,.3573900E-03,.2530300E-03,& - & .1175100E-05,.2098300E-03,.3247400E-03,.3904300E-03,.2725900E-03,& - & .1402700E-05,.2306500E-03,.3550500E-03,.4240500E-03,.2912000E-03,& - & .1669200E-05,.2530200E-03,.3869900E-03,.4588800E-03,.3101800E-03,& - & .1971600E-05,.2771500E-03,.4211900E-03,.4946800E-03,.3298900E-03/ - - data absb(526:700, 4) / & - & .8291500E-06,.1639600E-03,.2543300E-03,.3070000E-03,.2140600E-03,& - & .9935200E-06,.1808300E-03,.2793500E-03,.3355200E-03,.2304800E-03,& - & .1187700E-05,.1991500E-03,.3057800E-03,.3645500E-03,.2465900E-03,& - & .1413900E-05,.2188600E-03,.3338400E-03,.3947600E-03,.2631700E-03,& - & .1667000E-05,.2402100E-03,.3639000E-03,.4260300E-03,.2800500E-03,& - & .6867000E-06,.1397900E-03,.2167300E-03,.2616100E-03,.1797400E-03,& - & .8243700E-06,.1544800E-03,.2384600E-03,.2861100E-03,.1937700E-03,& - & .9864900E-06,.1704400E-03,.2613900E-03,.3113200E-03,.2076500E-03,& - & .1174000E-05,.1877300E-03,.2860900E-03,.3374000E-03,.2219700E-03,& - & .1383300E-05,.2065200E-03,.3123300E-03,.3644900E-03,.2365800E-03,& - & .5556400E-06,.1178600E-03,.1828300E-03,.2208900E-03,.1495100E-03,& - & .6673100E-06,.1305300E-03,.2015100E-03,.2418900E-03,.1614600E-03,& - & .8004800E-06,.1443200E-03,.2215400E-03,.2636400E-03,.1734800E-03,& - & .9519500E-06,.1593700E-03,.2431000E-03,.2860900E-03,.1857700E-03,& - & .1121700E-05,.1758000E-03,.2660100E-03,.3094900E-03,.1985000E-03,& - & .4452600E-06,.9833400E-04,.1523600E-03,.1839500E-03,.1236900E-03,& - & .5355100E-06,.1092700E-03,.1683700E-03,.2019400E-03,.1338700E-03,& - & .6430700E-06,.1211000E-03,.1855600E-03,.2205900E-03,.1441800E-03,& - & .7668800E-06,.1341100E-03,.2041400E-03,.2398500E-03,.1547700E-03,& - & .9059100E-06,.1484200E-03,.2240500E-03,.2599600E-03,.1656600E-03,& - & .3563000E-06,.8199100E-04,.1269000E-03,.1531200E-03,.1022600E-03,& - & .4291100E-06,.9139100E-04,.1406400E-03,.1684900E-03,.1109500E-03,& - & .5158300E-06,.1016300E-03,.1553800E-03,.1844800E-03,.1197700E-03,& - & .6165400E-06,.1128700E-03,.1713800E-03,.2010100E-03,.1288400E-03,& - & .7302800E-06,.1253000E-03,.1886200E-03,.2182600E-03,.1381600E-03,& - & .2845500E-06,.6836200E-04,.1057200E-03,.1274700E-03,.8449400E-04,& - & .3431300E-06,.7641300E-04,.1175100E-03,.1406000E-03,.9190500E-04,& - & .4130500E-06,.8529900E-04,.1301600E-03,.1543100E-03,.9946300E-04,& - & .4946600E-06,.9504700E-04,.1439600E-03,.1685100E-03,.1072500E-03,& - & .5872100E-06,.1058300E-03,.1588600E-03,.1833200E-03,.1151600E-03,& - & .2241600E-06,.5645100E-04,.8719200E-04,.1050300E-03,.6929900E-04,& - & .2705800E-06,.6332500E-04,.9724100E-04,.1162500E-03,.7563500E-04,& - & .3264000E-06,.7094200E-04,.1080100E-03,.1279200E-03,.8206100E-04,& - & .3917800E-06,.7938100E-04,.1198500E-03,.1400500E-03,.8872200E-04,& - & .4669400E-06,.8867300E-04,.1326100E-03,.1527400E-03,.9543700E-04/ - - data absb(701:875, 4) / & - & .1762000E-06,.4649500E-04,.7182900E-04,.8635100E-04,.5670100E-04,& - & .2129500E-06,.5238300E-04,.8038000E-04,.9593700E-04,.6210000E-04,& - & .2572000E-06,.5890000E-04,.8954800E-04,.1059400E-03,.6756800E-04,& - & .3095700E-06,.6613600E-04,.9964300E-04,.1162300E-03,.7328000E-04,& - & .3700300E-06,.7420300E-04,.1106100E-03,.1270700E-03,.7897900E-04,& - & .1384300E-06,.3823800E-04,.5912400E-04,.7098200E-04,.4633100E-04,& - & .1672600E-06,.4326900E-04,.6642400E-04,.7912500E-04,.5095600E-04,& - & .2023200E-06,.4887000E-04,.7424700E-04,.8766100E-04,.5556100E-04,& - & .2440800E-06,.5511900E-04,.8282700E-04,.9645300E-04,.6044700E-04,& - & .2927600E-06,.6202800E-04,.9222100E-04,.1057000E-03,.6528100E-04,& - & .1079300E-06,.3119100E-04,.4830500E-04,.5794800E-04,.3766600E-04,& - & .1301700E-06,.3546500E-04,.5448900E-04,.6484100E-04,.4155600E-04,& - & .1577100E-06,.4023500E-04,.6117600E-04,.7208200E-04,.4545200E-04,& - & .1906400E-06,.4559900E-04,.6848800E-04,.7957600E-04,.4959300E-04,& - & .2294400E-06,.5155200E-04,.7643100E-04,.8746200E-04,.5371500E-04,& - & .8387900E-07,.2532500E-04,.3929700E-04,.4711800E-04,.3051000E-04,& - & .1008700E-06,.2892000E-04,.4453200E-04,.5292900E-04,.3377200E-04,& - & .1223800E-06,.3297700E-04,.5018900E-04,.5907500E-04,.3706900E-04,& - & .1481300E-06,.3755600E-04,.5645100E-04,.6544800E-04,.4056700E-04,& - & .1787400E-06,.4267200E-04,.6319600E-04,.7215900E-04,.4408500E-04,& - & .6526100E-07,.2051600E-04,.3189500E-04,.3827900E-04,.2465000E-04,& - & .7814500E-07,.2354000E-04,.3631900E-04,.4316100E-04,.2739000E-04,& - & .9480500E-07,.2696200E-04,.4113400E-04,.4835700E-04,.3019000E-04,& - & .1149000E-06,.3085800E-04,.4642900E-04,.5378500E-04,.3313600E-04,& - & .1390500E-06,.3521000E-04,.5221600E-04,.5948200E-04,.3612200E-04,& - & .5066800E-07,.1652600E-04,.2575200E-04,.3095400E-04,.1981700E-04,& - & .6036100E-07,.1905800E-04,.2947100E-04,.3506000E-04,.2212300E-04,& - & .7310100E-07,.2193700E-04,.3356900E-04,.3946100E-04,.2449800E-04,& - & .8874700E-07,.2522200E-04,.3804800E-04,.4403900E-04,.2697300E-04,& - & .1076200E-06,.2893200E-04,.4296400E-04,.4887100E-04,.2949900E-04,& - & .3918500E-07,.1320700E-04,.2062600E-04,.2483500E-04,.1582600E-04,& - & .4633500E-07,.1530300E-04,.2372200E-04,.2827700E-04,.1776200E-04,& - & .5589600E-07,.1770300E-04,.2716200E-04,.3197600E-04,.1978000E-04,& - & .6796200E-07,.2045100E-04,.3094000E-04,.3586700E-04,.2183400E-04,& - & .8253500E-07,.2358300E-04,.3512800E-04,.3993300E-04,.2397200E-04/ - - data absb(876:1050, 4) / & - & .3043500E-07,.1052800E-04,.1645800E-04,.1987100E-04,.1263000E-04,& - & .3565700E-07,.1225500E-04,.1903400E-04,.2275700E-04,.1423000E-04,& - & .4277700E-07,.1424100E-04,.2191600E-04,.2585600E-04,.1591600E-04,& - & .5197700E-07,.1653100E-04,.2509400E-04,.2914200E-04,.1763200E-04,& - & .6324600E-07,.1916200E-04,.2863100E-04,.3258600E-04,.1944700E-04,& - & .2372200E-07,.8365600E-05,.1308800E-04,.1583400E-04,.1006000E-04,& - & .2750900E-07,.9786900E-05,.1522700E-04,.1825200E-04,.1136300E-04,& - & .3276900E-07,.1142600E-04,.1762800E-04,.2085300E-04,.1276700E-04,& - & .3971900E-07,.1332600E-04,.2028500E-04,.2363700E-04,.1422300E-04,& - & .4841500E-07,.1552400E-04,.2326800E-04,.2653000E-04,.1573900E-04,& - & .1862300E-07,.6662000E-05,.1042500E-04,.1263400E-04,.8013200E-05,& - & .2139300E-07,.7826400E-05,.1218800E-04,.1464300E-04,.9075700E-05,& - & .2528100E-07,.9178700E-05,.1418600E-04,.1682500E-04,.1024700E-04,& - & .3053000E-07,.1075800E-04,.1641900E-04,.1917800E-04,.1148200E-04,& - & .3721300E-07,.1259300E-04,.1892000E-04,.2164300E-04,.1274900E-04,& - & .1468100E-07,.5304300E-05,.8295600E-05,.1006400E-04,.6366900E-05,& - & .1671700E-07,.6250800E-05,.9750100E-05,.1173700E-04,.7247300E-05,& - & .1958700E-07,.7364300E-05,.1140000E-04,.1355800E-04,.8229000E-05,& - & .2355500E-07,.8674800E-05,.1326800E-04,.1553700E-04,.9263400E-05,& - & .2867100E-07,.1020900E-04,.1537900E-04,.1763500E-04,.1031600E-04,& - & .1162600E-07,.4214900E-05,.6574000E-05,.7983500E-05,.5059500E-05,& - & .1310200E-07,.4988400E-05,.7775800E-05,.9384600E-05,.5785600E-05,& - & .1520800E-07,.5895500E-05,.9139200E-05,.1089800E-04,.6593700E-05,& - & .1817400E-07,.6975800E-05,.1069200E-04,.1255400E-04,.7456400E-05,& - & .2205700E-07,.8250500E-05,.1246200E-04,.1433100E-04,.8330100E-05,& - & .9213000E-08,.3337800E-05,.5199800E-05,.6300600E-05,.4009700E-05,& - & .1029800E-07,.3970400E-05,.6183900E-05,.7477500E-05,.4607700E-05,& - & .1183100E-07,.4708800E-05,.7306200E-05,.8734500E-05,.5262000E-05,& - & .1403000E-07,.5594200E-05,.8592100E-05,.1011900E-04,.5983800E-05,& - & .1697000E-07,.6644700E-05,.1006300E-04,.1162000E-04,.6720800E-05,& - & .7344300E-08,.2649800E-05,.4122900E-05,.4978800E-05,.3192900E-05,& - & .8145300E-08,.3168900E-05,.4932000E-05,.5970100E-05,.3670600E-05,& - & .9285300E-08,.3774600E-05,.5856100E-05,.7013900E-05,.4210500E-05,& - & .1091300E-07,.4498600E-05,.6919200E-05,.8173300E-05,.4808100E-05,& - & .1315100E-07,.5368900E-05,.8146900E-05,.9437700E-05,.5432000E-05/ - - data absb(1051:1175, 4) / & - & .5869000E-08,.2105600E-05,.3271000E-05,.3936200E-05,.2535700E-05,& - & .6482400E-08,.2529200E-05,.3933500E-05,.4765200E-05,.2926600E-05,& - & .7319500E-08,.3026000E-05,.4694200E-05,.5634600E-05,.3370000E-05,& - & .8529800E-08,.3621600E-05,.5572700E-05,.6599000E-05,.3866200E-05,& - & .1022700E-07,.4336600E-05,.6593500E-05,.7662700E-05,.4388900E-05,& - & .4687900E-08,.1667400E-05,.2584800E-05,.3099200E-05,.2009700E-05,& - & .5157900E-08,.2014500E-05,.3130700E-05,.3787500E-05,.2330400E-05,& - & .5782900E-08,.2419900E-05,.3752900E-05,.4511900E-05,.2696200E-05,& - & .6681700E-08,.2909200E-05,.4478800E-05,.5314200E-05,.3103700E-05,& - & .7954800E-08,.3498500E-05,.5324800E-05,.6206600E-05,.3538700E-05,& - & .3748700E-08,.1317700E-05,.2036200E-05,.2427800E-05,.1588800E-05,& - & .4113200E-08,.1600600E-05,.2486300E-05,.3000100E-05,.1853000E-05,& - & .4579600E-08,.1930100E-05,.2995700E-05,.3605300E-05,.2151500E-05,& - & .5244700E-08,.2330100E-05,.3590200E-05,.4269000E-05,.2484400E-05,& - & .6195200E-08,.2817500E-05,.4289400E-05,.5013300E-05,.2850300E-05,& - & .3005300E-08,.1041900E-05,.1603400E-05,.1907100E-05,.1255000E-05,& - & .3290600E-08,.1271700E-05,.1975000E-05,.2375100E-05,.1476100E-05,& - & .3641200E-08,.1541300E-05,.2395000E-05,.2881700E-05,.1717300E-05,& - & .4132700E-08,.1867300E-05,.2880000E-05,.3430100E-05,.1989300E-05,& - & .4844800E-08,.2269900E-05,.3455900E-05,.4049600E-05,.2293800E-05,& - & .2451700E-08,.8536700E-06,.1312100E-05,.1558700E-05,.1020900E-05,& - & .2681400E-08,.1045900E-05,.1624100E-05,.1950500E-05,.1206700E-05,& - & .2960400E-08,.1272600E-05,.1978600E-05,.2376500E-05,.1407100E-05,& - & .3349000E-08,.1548600E-05,.2388400E-05,.2839300E-05,.1635300E-05,& - & .3917700E-08,.1892300E-05,.2875100E-05,.3364800E-05,.1889600E-05/ - - data absb( 1:175, 5) / & - & .1060600E-02,.1761600E-01,.2633700E-01,.3083200E-01,.2325000E-01,& - & .1197500E-02,.1885100E-01,.2774600E-01,.3219100E-01,.2446100E-01,& - & .1368600E-02,.2023600E-01,.2922400E-01,.3340900E-01,.2553800E-01,& - & .1578800E-02,.2168600E-01,.3082200E-01,.3458100E-01,.2648300E-01,& - & .1842200E-02,.2320100E-01,.3248500E-01,.3579100E-01,.2733900E-01,& - & .9029900E-03,.1493900E-01,.2223500E-01,.2596900E-01,.1945900E-01,& - & .1027600E-02,.1604300E-01,.2346400E-01,.2710200E-01,.2041800E-01,& - & .1184800E-02,.1724400E-01,.2476600E-01,.2813700E-01,.2127900E-01,& - & .1376300E-02,.1849400E-01,.2615900E-01,.2914100E-01,.2203500E-01,& - & .1608700E-02,.1980100E-01,.2758600E-01,.3020800E-01,.2271200E-01,& - & .7616900E-03,.1265700E-01,.1874400E-01,.2180700E-01,.1615500E-01,& - & .8742900E-03,.1362200E-01,.1982000E-01,.2275300E-01,.1690800E-01,& - & .1015300E-02,.1465000E-01,.2096700E-01,.2363700E-01,.1759700E-01,& - & .1186000E-02,.1572800E-01,.2215900E-01,.2452100E-01,.1823600E-01,& - & .1394000E-02,.1685500E-01,.2337700E-01,.2544200E-01,.1880000E-01,& - & .6397900E-03,.1071600E-01,.1578200E-01,.1828000E-01,.1333000E-01,& - & .7399200E-03,.1155000E-01,.1672100E-01,.1907400E-01,.1395500E-01,& - & .8653500E-03,.1243200E-01,.1771500E-01,.1983500E-01,.1451900E-01,& - & .1018000E-02,.1335800E-01,.1873300E-01,.2061200E-01,.1505300E-01,& - & .1202000E-02,.1433000E-01,.1978000E-01,.2139000E-01,.1552300E-01,& - & .5382700E-03,.9067500E-02,.1328200E-01,.1531000E-01,.1100200E-01,& - & .6273300E-03,.9781800E-02,.1409300E-01,.1598500E-01,.1151700E-01,& - & .7389400E-03,.1053600E-01,.1493700E-01,.1664200E-01,.1198200E-01,& - & .8747100E-03,.1132900E-01,.1581300E-01,.1730800E-01,.1243100E-01,& - & .1036900E-02,.1216700E-01,.1671700E-01,.1796600E-01,.1283300E-01,& - & .4563200E-03,.7663100E-02,.1117500E-01,.1282100E-01,.9100700E-02,& - & .5361800E-03,.8274100E-02,.1186700E-01,.1340200E-01,.9528400E-02,& - & .6352000E-03,.8917900E-02,.1259100E-01,.1396000E-01,.9922700E-02,& - & .7551300E-03,.9596600E-02,.1334500E-01,.1452900E-01,.1029400E-01,& - & .8982800E-03,.1032500E-01,.1412700E-01,.1508200E-01,.1063700E-01,& - & .3878200E-03,.6468600E-02,.9394700E-02,.1073800E-01,.7536600E-02,& - & .4582600E-03,.6987200E-02,.9987800E-02,.1123000E-01,.7892000E-02,& - & .5454400E-03,.7538600E-02,.1061300E-01,.1170600E-01,.8221900E-02,& - & .6508500E-03,.8124300E-02,.1126100E-01,.1218300E-01,.8544700E-02,& - & .7760100E-03,.8759800E-02,.1193300E-01,.1266000E-01,.8838800E-02/ - - data absb(176:350, 5) / & - & .3330400E-03,.5462300E-02,.7902800E-02,.8996000E-02,.6263500E-02,& - & .3955300E-03,.5905500E-02,.8415500E-02,.9411100E-02,.6561300E-02,& - & .4718000E-03,.6377900E-02,.8950000E-02,.9817200E-02,.6845900E-02,& - & .5645300E-03,.6886200E-02,.9504800E-02,.1022500E-01,.7124600E-02,& - & .6748600E-03,.7441100E-02,.1008200E-01,.1063700E-01,.7378600E-02,& - & .2869300E-03,.4618000E-02,.6650400E-02,.7537900E-02,.5207100E-02,& - & .3418000E-03,.4994800E-02,.7089800E-02,.7886600E-02,.5464500E-02,& - & .4081100E-03,.5400600E-02,.7547400E-02,.8233100E-02,.5712700E-02,& - & .4887300E-03,.5843400E-02,.8021200E-02,.8584400E-02,.5947000E-02,& - & .5859300E-03,.6326000E-02,.8518200E-02,.8940800E-02,.6166200E-02,& - & .2497400E-03,.3924000E-02,.5620800E-02,.6334500E-02,.4343100E-02,& - & .2974900E-03,.4252600E-02,.5999600E-02,.6626600E-02,.4562400E-02,& - & .3560800E-03,.4604700E-02,.6391900E-02,.6925900E-02,.4773800E-02,& - & .4269900E-03,.4992000E-02,.6799300E-02,.7227600E-02,.4971400E-02,& - & .5119800E-03,.5416600E-02,.7230200E-02,.7538700E-02,.5166000E-02,& - & .2171600E-03,.3337500E-02,.4752800E-02,.5323800E-02,.3625800E-02,& - & .2588600E-03,.3624300E-02,.5079700E-02,.5574000E-02,.3810700E-02,& - & .3102600E-03,.3935300E-02,.5416900E-02,.5830900E-02,.3987600E-02,& - & .3723500E-03,.4275700E-02,.5771100E-02,.6091100E-02,.4158600E-02,& - & .4456800E-03,.4646300E-02,.6147600E-02,.6363300E-02,.4327700E-02,& - & .1873800E-03,.2841200E-02,.4025100E-02,.4475400E-02,.3023200E-02,& - & .2242200E-03,.3093000E-02,.4306200E-02,.4692100E-02,.3178800E-02,& - & .2694200E-03,.3369400E-02,.4598300E-02,.4912600E-02,.3328700E-02,& - & .3231700E-03,.3670200E-02,.4909200E-02,.5139300E-02,.3477100E-02,& - & .3863800E-03,.3995100E-02,.5238500E-02,.5381500E-02,.3623200E-02,& - & .1622400E-03,.2423200E-02,.3414100E-02,.3766100E-02,.2526200E-02,& - & .1946500E-03,.2646300E-02,.3657500E-02,.3954100E-02,.2657700E-02,& - & .2339100E-03,.2893600E-02,.3913000E-02,.4144600E-02,.2784100E-02,& - & .2804400E-03,.3159800E-02,.4185300E-02,.4344200E-02,.2909800E-02,& - & .3348300E-03,.3443700E-02,.4473500E-02,.4562500E-02,.3035100E-02,& - & .1413200E-03,.2073700E-02,.2903600E-02,.3176200E-02,.2115700E-02,& - & .1697700E-03,.2274300E-02,.3115200E-02,.3338200E-02,.2225800E-02,& - & .2040900E-03,.2494700E-02,.3340100E-02,.3504800E-02,.2333800E-02,& - & .2447200E-03,.2729700E-02,.3579800E-02,.3683500E-02,.2442100E-02,& - & .2913100E-03,.2980400E-02,.3830800E-02,.3879700E-02,.2550000E-02/ - - data absb(351:525, 5) / & - & .1229300E-03,.1779700E-02,.2472500E-02,.2682200E-02,.1771800E-02,& - & .1478900E-03,.1959500E-02,.2658400E-02,.2822200E-02,.1865500E-02,& - & .1779000E-03,.2155200E-02,.2858400E-02,.2969500E-02,.1958900E-02,& - & .2131500E-03,.2362400E-02,.3068800E-02,.3130900E-02,.2052000E-02,& - & .2528500E-03,.2582500E-02,.3287600E-02,.3306800E-02,.2144500E-02,& - & .1065700E-03,.1531900E-02,.2109600E-02,.2267800E-02,.1484400E-02,& - & .1285600E-03,.1692000E-02,.2274300E-02,.2389900E-02,.1563900E-02,& - & .1547100E-03,.1863600E-02,.2451100E-02,.2522100E-02,.1643600E-02,& - & .1851200E-03,.2047200E-02,.2636400E-02,.2668100E-02,.1723800E-02,& - & .2187200E-03,.2241100E-02,.2827000E-02,.2826000E-02,.1804800E-02,& - & .9287600E-04,.1323700E-02,.1804900E-02,.1921400E-02,.1247100E-02,& - & .1122600E-03,.1465900E-02,.1951800E-02,.2029500E-02,.1314300E-02,& - & .1351900E-03,.1617100E-02,.2108900E-02,.2149800E-02,.1383300E-02,& - & .1610200E-03,.1777800E-02,.2270300E-02,.2281000E-02,.1452800E-02,& - & .1898100E-03,.1948400E-02,.2437400E-02,.2424900E-02,.1523600E-02,& - & .8082800E-04,.1147100E-02,.1548600E-02,.1630700E-02,.1048200E-02,& - & .9806300E-04,.1271800E-02,.1679700E-02,.1728700E-02,.1105300E-02,& - & .1177200E-03,.1405000E-02,.1817700E-02,.1837900E-02,.1164800E-02,& - & .1398100E-03,.1546900E-02,.1958900E-02,.1956500E-02,.1225800E-02,& - & .1644600E-03,.1694700E-02,.2105500E-02,.2087400E-02,.1288500E-02,& - & .7053900E-04,.9962100E-03,.1332500E-02,.1387900E-02,.8822000E-03,& - & .8558900E-04,.1106300E-02,.1449200E-02,.1477600E-02,.9311300E-03,& - & .1024400E-03,.1224000E-02,.1570100E-02,.1576400E-02,.9823700E-03,& - & .1215100E-03,.1348800E-02,.1694200E-02,.1684600E-02,.1036400E-02,& - & .1424500E-03,.1475300E-02,.1822900E-02,.1804200E-02,.1091000E-02,& - & .6159800E-04,.8670800E-03,.1150600E-02,.1185700E-02,.7439600E-03,& - & .7469800E-04,.9644300E-03,.1253300E-02,.1267300E-02,.7859000E-03,& - & .8909200E-04,.1068400E-02,.1359000E-02,.1357100E-02,.8309000E-03,& - & .1053700E-03,.1176600E-02,.1468200E-02,.1456000E-02,.8782700E-03,& - & .1232700E-03,.1285000E-02,.1581300E-02,.1564300E-02,.9259900E-03,& - & .5374800E-04,.7562900E-03,.9959500E-03,.1016300E-02,.6280900E-03,& - & .6497200E-04,.8426500E-03,.1085600E-02,.1090800E-02,.6641600E-03,& - & .7738600E-04,.9339700E-03,.1178700E-02,.1172700E-02,.7038700E-03,& - & .9113800E-04,.1026600E-02,.1274900E-02,.1263000E-02,.7450700E-03,& - & .1064000E-03,.1118900E-02,.1373800E-02,.1360800E-02,.7883000E-03/ - - data absb(526:700, 5) / & - & .4666700E-04,.6588400E-03,.8604900E-03,.8721400E-03,.5309900E-03,& - & .5626300E-04,.7349000E-03,.9390000E-03,.9394600E-03,.5627800E-03,& - & .6685300E-04,.8138300E-03,.1020900E-02,.1014200E-02,.5977600E-03,& - & .7859800E-04,.8931400E-03,.1105400E-02,.1096300E-02,.6341900E-03,& - & .9150300E-04,.9719300E-03,.1192700E-02,.1184000E-02,.6732000E-03,& - & .3959900E-04,.5686600E-03,.7380300E-03,.7449100E-03,.4468800E-03,& - & .4767700E-04,.6349000E-03,.8068500E-03,.8054000E-03,.4746600E-03,& - & .5663000E-04,.7027900E-03,.8786000E-03,.8733200E-03,.5047600E-03,& - & .6650600E-04,.7706100E-03,.9526200E-03,.9467600E-03,.5373000E-03,& - & .7734300E-04,.8387000E-03,.1029500E-02,.1025000E-02,.5720000E-03,& - & .3276700E-04,.4852300E-03,.6275100E-03,.6318300E-03,.3735300E-03,& - & .3945000E-04,.5426100E-03,.6874400E-03,.6858700E-03,.3974400E-03,& - & .4686100E-04,.6009300E-03,.7497700E-03,.7462300E-03,.4231500E-03,& - & .5495600E-04,.6591600E-03,.8146900E-03,.8115800E-03,.4514400E-03,& - & .6390800E-04,.7182000E-03,.8821200E-03,.8810300E-03,.4816500E-03,& - & .2673400E-04,.4075400E-03,.5264500E-03,.5301400E-03,.3111800E-03,& - & .3227300E-04,.4566100E-03,.5782500E-03,.5776600E-03,.3320600E-03,& - & .3848800E-04,.5069700E-03,.6324500E-03,.6305800E-03,.3547600E-03,& - & .4522800E-04,.5570600E-03,.6891800E-03,.6880900E-03,.3794400E-03,& - & .5267500E-04,.6080800E-03,.7479400E-03,.7493400E-03,.4059800E-03,& - & .2175100E-04,.3420900E-03,.4414600E-03,.4445800E-03,.2592000E-03,& - & .2632600E-04,.3841500E-03,.4860300E-03,.4863200E-03,.2773000E-03,& - & .3151500E-04,.4273600E-03,.5332500E-03,.5326200E-03,.2971400E-03,& - & .3721900E-04,.4706400E-03,.5826300E-03,.5832100E-03,.3189000E-03,& - & .4334400E-04,.5149300E-03,.6340200E-03,.6372900E-03,.3421200E-03,& - & .1764300E-04,.2871700E-03,.3702000E-03,.3728800E-03,.2158000E-03,& - & .2141800E-04,.3234300E-03,.4087100E-03,.4095300E-03,.2315100E-03,& - & .2572500E-04,.3604400E-03,.4496600E-03,.4500500E-03,.2488000E-03,& - & .3047900E-04,.3978500E-03,.4926300E-03,.4944500E-03,.2678300E-03,& - & .3565300E-04,.4364600E-03,.5377100E-03,.5423000E-03,.2882200E-03,& - & .1410200E-04,.2381400E-03,.3073000E-03,.3098100E-03,.1786400E-03,& - & .1718700E-04,.2693400E-03,.3403900E-03,.3414600E-03,.1923400E-03,& - & .2073900E-04,.3013000E-03,.3757100E-03,.3767200E-03,.2073700E-03,& - & .2467000E-04,.3333300E-03,.4128300E-03,.4153800E-03,.2240800E-03,& - & .2904600E-04,.3669400E-03,.4521600E-03,.4572900E-03,.2418700E-03/ - - data absb(701:875, 5) / & - & .1122100E-04,.1971000E-03,.2546500E-03,.2569600E-03,.1477300E-03,& - & .1374700E-04,.2239000E-03,.2830500E-03,.2841300E-03,.1595500E-03,& - & .1664900E-04,.2514500E-03,.3134600E-03,.3146700E-03,.1726900E-03,& - & .1989900E-04,.2793500E-03,.3456300E-03,.3484500E-03,.1871800E-03,& - & .2356800E-04,.3083000E-03,.3797400E-03,.3851200E-03,.2028100E-03,& - & .8914700E-05,.1631400E-03,.2108800E-03,.2129400E-03,.1220500E-03,& - & .1095700E-04,.1859600E-03,.2352300E-03,.2362800E-03,.1322500E-03,& - & .1332700E-04,.2097400E-03,.2613400E-03,.2626300E-03,.1435600E-03,& - & .1600500E-04,.2337800E-03,.2892500E-03,.2920200E-03,.1562100E-03,& - & .1903800E-04,.2591400E-03,.3189700E-03,.3241500E-03,.1698200E-03,& - & .6999500E-05,.1340500E-03,.1733800E-03,.1753500E-03,.1003600E-03,& - & .8640600E-05,.1534500E-03,.1941600E-03,.1951400E-03,.1091000E-03,& - & .1055600E-04,.1737300E-03,.2165900E-03,.2176700E-03,.1188700E-03,& - & .1273900E-04,.1944500E-03,.2405300E-03,.2431100E-03,.1298000E-03,& - & .1523200E-04,.2164000E-03,.2664500E-03,.2710700E-03,.1416900E-03,& - & .5471200E-05,.1097000E-03,.1419500E-03,.1438600E-03,.8226000E-04,& - & .6764400E-05,.1261200E-03,.1596300E-03,.1606100E-03,.8972700E-04,& - & .8297300E-05,.1434800E-03,.1787800E-03,.1797500E-03,.9812200E-04,& - & .1008200E-04,.1613200E-03,.1995200E-03,.2015500E-03,.1075500E-03,& - & .1210700E-04,.1800800E-03,.2217900E-03,.2257600E-03,.1178700E-03,& - & .4276700E-05,.8968000E-04,.1161100E-03,.1178100E-03,.6733800E-04,& - & .5286000E-05,.1036000E-03,.1310700E-03,.1320300E-03,.7372200E-04,& - & .6510700E-05,.1183800E-03,.1473500E-03,.1482900E-03,.8085200E-04,& - & .7950100E-05,.1337400E-03,.1652000E-03,.1669300E-03,.8896900E-04,& - & .9593700E-05,.1499300E-03,.1845600E-03,.1878100E-03,.9789700E-04,& - & .3322600E-05,.7291800E-04,.9463500E-04,.9606900E-04,.5491200E-04,& - & .4118500E-05,.8470500E-04,.1072600E-03,.1080900E-03,.6032500E-04,& - & .5079600E-05,.9741400E-04,.1210600E-03,.1218400E-03,.6641500E-04,& - & .6231100E-05,.1105500E-03,.1362500E-03,.1377200E-03,.7335400E-04,& - & .7559400E-05,.1243900E-03,.1529700E-03,.1556900E-03,.8097200E-04,& - & .2550700E-05,.5875300E-04,.7659900E-04,.7779800E-04,.4450800E-04,& - & .3180000E-05,.6867900E-04,.8724000E-04,.8784300E-04,.4911500E-04,& - & .3927300E-05,.7949700E-04,.9887100E-04,.9942100E-04,.5424900E-04,& - & .4834600E-05,.9078200E-04,.1117300E-03,.1128200E-03,.6011300E-04,& - & .5899500E-05,.1026700E-03,.1259200E-03,.1281500E-03,.6665600E-04/ - - data absb(876:1050, 5) / & - & .1953900E-05,.4717400E-04,.6187400E-04,.6291600E-04,.3597300E-04,& - & .2445200E-05,.5557500E-04,.7085300E-04,.7123800E-04,.3989800E-04,& - & .3040200E-05,.6478300E-04,.8063300E-04,.8092100E-04,.4421400E-04,& - & .3739000E-05,.7443900E-04,.9149800E-04,.9220800E-04,.4916200E-04,& - & .4583600E-05,.8460800E-04,.1035800E-03,.1053100E-03,.5470200E-04,& - & .1494000E-05,.3771600E-04,.4982900E-04,.5080400E-04,.2898700E-04,& - & .1875800E-05,.4477700E-04,.5739200E-04,.5769700E-04,.3231700E-04,& - & .2341300E-05,.5260400E-04,.6560800E-04,.6574800E-04,.3594600E-04,& - & .2896100E-05,.6089100E-04,.7482400E-04,.7518200E-04,.4009900E-04,& - & .3552400E-05,.6958700E-04,.8506800E-04,.8629500E-04,.4480400E-04,& - & .1150000E-05,.3016900E-04,.4015700E-04,.4106900E-04,.2336200E-04,& - & .1445300E-05,.3608900E-04,.4654900E-04,.4679900E-04,.2619300E-04,& - & .1812900E-05,.4273500E-04,.5347400E-04,.5351400E-04,.2924900E-04,& - & .2252900E-05,.4984300E-04,.6123400E-04,.6140400E-04,.3274800E-04,& - & .2776200E-05,.5732800E-04,.7002700E-04,.7078300E-04,.3671200E-04,& - & .8885100E-06,.2409500E-04,.3230300E-04,.3321000E-04,.1880500E-04,& - & .1117700E-05,.2908200E-04,.3770500E-04,.3794400E-04,.2120900E-04,& - & .1406000E-05,.3466700E-04,.4357800E-04,.4357000E-04,.2379200E-04,& - & .1753900E-05,.4073900E-04,.5011400E-04,.5017200E-04,.2672000E-04,& - & .2172900E-05,.4722400E-04,.5759800E-04,.5807000E-04,.3007900E-04,& - & .6852500E-06,.1917800E-04,.2589600E-04,.2680900E-04,.1509700E-04,& - & .8630100E-06,.2333600E-04,.3043400E-04,.3071300E-04,.1712000E-04,& - & .1088900E-05,.2802800E-04,.3542200E-04,.3539700E-04,.1930100E-04,& - & .1364900E-05,.3318700E-04,.4095400E-04,.4092100E-04,.2175200E-04,& - & .1698200E-05,.3874700E-04,.4726000E-04,.4755700E-04,.2458800E-04,& - & .5280900E-06,.1520600E-04,.2068800E-04,.2159200E-04,.1208400E-04,& - & .6649300E-06,.1864700E-04,.2447900E-04,.2481900E-04,.1378100E-04,& - & .8410200E-06,.2257400E-04,.2868300E-04,.2869000E-04,.1562100E-04,& - & .1058500E-05,.2695500E-04,.3336400E-04,.3329800E-04,.1767700E-04,& - & .1323900E-05,.3171000E-04,.3873300E-04,.3886400E-04,.2004900E-04,& - & .4096900E-06,.1209300E-04,.1656400E-04,.1742100E-04,.9688200E-05,& - & .5156900E-06,.1493700E-04,.1973400E-04,.2009400E-04,.1111200E-04,& - & .6529600E-06,.1822900E-04,.2328200E-04,.2332100E-04,.1266400E-04,& - & .8257300E-06,.2195000E-04,.2723100E-04,.2715000E-04,.1439300E-04,& - & .1037300E-05,.2601300E-04,.3179100E-04,.3182800E-04,.1637900E-04/ - - data absb(1051:1175, 5) / & - & .3192800E-06,.9616200E-05,.1325700E-04,.1405300E-04,.7774100E-05,& - & .4011200E-06,.1196300E-04,.1590600E-04,.1625700E-04,.8957800E-05,& - & .5081600E-06,.1471700E-04,.1888600E-04,.1894700E-04,.1026200E-04,& - & .6446500E-06,.1786400E-04,.2220700E-04,.2215500E-04,.1171500E-04,& - & .8132800E-06,.2132600E-04,.2607600E-04,.2606100E-04,.1337600E-04,& - & .2482900E-06,.7620400E-05,.1057800E-04,.1130900E-04,.6220800E-05,& - & .3117600E-06,.9548800E-05,.1278000E-04,.1312500E-04,.7201300E-05,& - & .3950600E-06,.1185000E-04,.1527900E-04,.1534800E-04,.8294700E-05,& - & .5026600E-06,.1449200E-04,.1807400E-04,.1804000E-04,.9515300E-05,& - & .6363800E-06,.1744200E-04,.2133600E-04,.2131000E-04,.1090400E-04,& - & .1930200E-06,.6018700E-05,.8416200E-05,.9079900E-05,.4964900E-05,& - & .2422200E-06,.7595900E-05,.1023300E-04,.1057000E-04,.5770100E-05,& - & .3068800E-06,.9508000E-05,.1231800E-04,.1240300E-04,.6691300E-05,& - & .3908900E-06,.1171900E-04,.1467000E-04,.1464400E-04,.7716600E-05,& - & .4967400E-06,.1421400E-04,.1740200E-04,.1738200E-04,.8872700E-05,& - & .1504600E-06,.4766300E-05,.6699800E-05,.7290800E-05,.3963100E-05,& - & .1885600E-06,.6045900E-05,.8190800E-05,.8520600E-05,.4627000E-05,& - & .2386900E-06,.7630200E-05,.9924500E-05,.1002300E-04,.5397700E-05,& - & .3045900E-06,.9476700E-05,.1191100E-04,.1189400E-04,.6257900E-05,& - & .3882000E-06,.1158800E-04,.1420500E-04,.1418200E-04,.7222600E-05,& - & .1221200E-06,.3933200E-05,.5523000E-05,.6009400E-05,.3249900E-05,& - & .1532400E-06,.5017800E-05,.6787900E-05,.7056600E-05,.3810800E-05,& - & .1941800E-06,.6367800E-05,.8264700E-05,.8344300E-05,.4467200E-05,& - & .2482000E-06,.7954300E-05,.9967000E-05,.9951800E-05,.5202700E-05,& - & .3174000E-06,.9770400E-05,.1196400E-04,.1193800E-04,.6027800E-05/ - - data absb( 1:175, 6) / & - & .4672255E-01,.1179341E+00,.1338757E+00,.1299972E+00,.9161157E-01,& - & .5062470E-01,.1213117E+00,.1369429E+00,.1328028E+00,.9360006E-01,& - & .5459974E-01,.1248223E+00,.1399926E+00,.1355144E+00,.9556280E-01,& - & .5873868E-01,.1286746E+00,.1431991E+00,.1382901E+00,.9738836E-01,& - & .6302530E-01,.1329297E+00,.1467302E+00,.1411782E+00,.9929195E-01,& - & .3968991E-01,.9976895E-01,.1131751E+00,.1100474E+00,.7710072E-01,& - & .4301477E-01,.1026851E+00,.1158037E+00,.1124295E+00,.7893417E-01,& - & .4646290E-01,.1058587E+00,.1184976E+00,.1148060E+00,.8065093E-01,& - & .5002899E-01,.1093646E+00,.1214273E+00,.1173032E+00,.8238971E-01,& - & .5370336E-01,.1132393E+00,.1247403E+00,.1199136E+00,.8410182E-01,& - & .3361226E-01,.8419071E-01,.9544048E-01,.9285444E-01,.6446524E-01,& - & .3646479E-01,.8678678E-01,.9771637E-01,.9491470E-01,.6610593E-01,& - & .3943418E-01,.8966612E-01,.1001521E+00,.9704047E-01,.6769280E-01,& - & .4249750E-01,.9286388E-01,.1028925E+00,.9929778E-01,.6917725E-01,& - & .4559710E-01,.9635024E-01,.1059705E+00,.1017312E+00,.7059703E-01,& - & .2841305E-01,.7093757E-01,.8032314E-01,.7813700E-01,.5373624E-01,& - & .3087001E-01,.7327916E-01,.8235049E-01,.7995476E-01,.5513198E-01,& - & .3341491E-01,.7589200E-01,.8459743E-01,.8187839E-01,.5650567E-01,& - & .3600242E-01,.7879372E-01,.8716029E-01,.8394378E-01,.5783239E-01,& - & .3862500E-01,.8189679E-01,.8997661E-01,.8623580E-01,.5901740E-01,& - & .2401634E-01,.5974102E-01,.6747709E-01,.6564216E-01,.4478664E-01,& - & .2611796E-01,.6185142E-01,.6932940E-01,.6726455E-01,.4600594E-01,& - & .2827920E-01,.6420880E-01,.7144020E-01,.6899927E-01,.4720878E-01,& - & .3044618E-01,.6678350E-01,.7379995E-01,.7092071E-01,.4834282E-01,& - & .3265937E-01,.6948508E-01,.7635424E-01,.7306622E-01,.4936137E-01,& - & .2029779E-01,.5028866E-01,.5661750E-01,.5508955E-01,.3739316E-01,& - & .2208972E-01,.5221100E-01,.5834184E-01,.5654839E-01,.3848438E-01,& - & .2389477E-01,.5432163E-01,.6030221E-01,.5814906E-01,.3951198E-01,& - & .2571656E-01,.5658610E-01,.6243776E-01,.5994219E-01,.4048024E-01,& - & .2759559E-01,.5894005E-01,.6471627E-01,.6189304E-01,.4136898E-01,& - & .1714555E-01,.4232553E-01,.4751571E-01,.4621072E-01,.3128045E-01,& - & .1865226E-01,.4405192E-01,.4911024E-01,.4754554E-01,.3222507E-01,& - & .2016046E-01,.4594242E-01,.5088205E-01,.4903912E-01,.3313354E-01,& - & .2170679E-01,.4792414E-01,.5278935E-01,.5068417E-01,.3395265E-01,& - & .2331129E-01,.4999405E-01,.5480871E-01,.5244342E-01,.3473337E-01/ - - data absb(176:350, 6) / & - & .1449397E-01,.3565245E-01,.3997027E-01,.3878295E-01,.2623894E-01,& - & .1574907E-01,.3721054E-01,.4142074E-01,.4002092E-01,.2707613E-01,& - & .1701927E-01,.3887652E-01,.4300733E-01,.4140562E-01,.2785469E-01,& - & .1834230E-01,.4061477E-01,.4467996E-01,.4289260E-01,.2857492E-01,& - & .1972332E-01,.4243979E-01,.4646142E-01,.4447765E-01,.2929449E-01,& - & .1223686E-01,.3005384E-01,.3364453E-01,.3256819E-01,.2203383E-01,& - & .1329184E-01,.3143872E-01,.3496344E-01,.3371716E-01,.2275179E-01,& - & .1437272E-01,.3289059E-01,.3638637E-01,.3497888E-01,.2343303E-01,& - & .1550047E-01,.3441489E-01,.3787367E-01,.3632111E-01,.2407709E-01,& - & .1668336E-01,.3604499E-01,.3944792E-01,.3774085E-01,.2472138E-01,& - & .1038282E-01,.2542597E-01,.2842132E-01,.2744137E-01,.1852562E-01,& - & .1127312E-01,.2664076E-01,.2962239E-01,.2850810E-01,.1915442E-01,& - & .1219323E-01,.2791660E-01,.3088571E-01,.2965335E-01,.1975054E-01,& - & .1315724E-01,.2927559E-01,.3221079E-01,.3086581E-01,.2032424E-01,& - & .1418884E-01,.3074537E-01,.3362124E-01,.3215085E-01,.2090413E-01,& - & .8810984E-02,.2153212E-01,.2404863E-01,.2318381E-01,.1558634E-01,& - & .9557713E-02,.2259858E-01,.2512473E-01,.2414921E-01,.1614064E-01,& - & .1034460E-01,.2372894E-01,.2624401E-01,.2518234E-01,.1665912E-01,& - & .1117906E-01,.2495670E-01,.2743338E-01,.2627714E-01,.1717734E-01,& - & .1208564E-01,.2629206E-01,.2873101E-01,.2745336E-01,.1769705E-01,& - & .7472179E-02,.1826124E-01,.2037977E-01,.1963051E-01,.1311820E-01,& - & .8105914E-02,.1920286E-01,.2133520E-01,.2050264E-01,.1360311E-01,& - & .8786371E-02,.2021445E-01,.2233873E-01,.2143465E-01,.1406558E-01,& - & .9517597E-02,.2132628E-01,.2342388E-01,.2243468E-01,.1453007E-01,& - & .1031444E-01,.2254987E-01,.2462788E-01,.2351153E-01,.1499827E-01,& - & .6339327E-02,.1551891E-01,.1730563E-01,.1666327E-01,.1106485E-01,& - & .6886916E-02,.1635981E-01,.1815633E-01,.1745076E-01,.1148631E-01,& - & .7479578E-02,.1727214E-01,.1906789E-01,.1829842E-01,.1190414E-01,& - & .8122799E-02,.1828117E-01,.2007236E-01,.1921662E-01,.1232324E-01,& - & .8828155E-02,.1940872E-01,.2120238E-01,.2020565E-01,.1274767E-01,& - & .5392272E-02,.1323113E-01,.1473701E-01,.1419217E-01,.9365787E-02,& - & .5870200E-02,.1398439E-01,.1550589E-01,.1490579E-01,.9737495E-02,& - & .6389745E-02,.1481106E-01,.1634605E-01,.1568477E-01,.1010973E-01,& - & .6958634E-02,.1574163E-01,.1728569E-01,.1652721E-01,.1049045E-01,& - & .7581630E-02,.1678655E-01,.1834875E-01,.1744786E-01,.1088430E-01/ - - data absb(351:525, 6) / & - & .4592919E-02,.1130255E-01,.1258234E-01,.1211906E-01,.7936306E-02,& - & .5013344E-02,.1198363E-01,.1328506E-01,.1277230E-01,.8268918E-02,& - & .5471875E-02,.1274465E-01,.1406720E-01,.1349234E-01,.8605208E-02,& - & .5975738E-02,.1360931E-01,.1495090E-01,.1427336E-01,.8951125E-02,& - & .6524713E-02,.1458353E-01,.1594799E-01,.1514041E-01,.9313867E-02,& - & .3921257E-02,.9679135E-02,.1077668E-01,.1037874E-01,.6732679E-02,& - & .4289466E-02,.1030205E-01,.1142417E-01,.1098668E-01,.7034601E-02,& - & .4696449E-02,.1101261E-01,.1215654E-01,.1165356E-01,.7339816E-02,& - & .5140924E-02,.1181986E-01,.1298600E-01,.1238661E-01,.7655437E-02,& - & .5627986E-02,.1273133E-01,.1391895E-01,.1320853E-01,.7987663E-02,& - & .3358374E-02,.8318578E-02,.9266665E-02,.8925427E-02,.5731495E-02,& - & .3681177E-02,.8898948E-02,.9870888E-02,.9491903E-02,.6003477E-02,& - & .4042382E-02,.9566221E-02,.1056008E-01,.1011534E-01,.6284646E-02,& - & .4437145E-02,.1032409E-01,.1134025E-01,.1081068E-01,.6574647E-02,& - & .4869992E-02,.1118221E-01,.1221978E-01,.1159427E-01,.6878293E-02,& - & .2880952E-02,.7177713E-02,.8000548E-02,.7709187E-02,.4888892E-02,& - & .3168109E-02,.7724358E-02,.8567998E-02,.8237375E-02,.5136819E-02,& - & .3487574E-02,.8352795E-02,.9218971E-02,.8825929E-02,.5394241E-02,& - & .3839297E-02,.9067161E-02,.9957533E-02,.9491401E-02,.5660899E-02,& - & .4223712E-02,.9875806E-02,.1079202E-01,.1023576E-01,.5939546E-02,& - & .2478739E-02,.6226385E-02,.6940669E-02,.6691212E-02,.4181873E-02,& - & .2734468E-02,.6743172E-02,.7478246E-02,.7187563E-02,.4408421E-02,& - & .3017927E-02,.7337488E-02,.8096419E-02,.7749978E-02,.4643233E-02,& - & .3331178E-02,.8012614E-02,.8797666E-02,.8384632E-02,.4887248E-02,& - & .3674803E-02,.8776521E-02,.9606185E-02,.9089542E-02,.5147082E-02,& - & .2139286E-02,.5432558E-02,.6053952E-02,.5837608E-02,.3588363E-02,& - & .2366596E-02,.5923173E-02,.6566620E-02,.6309240E-02,.3794714E-02,& - & .2619079E-02,.6485565E-02,.7155112E-02,.6847354E-02,.4009599E-02,& - & .2899192E-02,.7125771E-02,.7834469E-02,.7451217E-02,.4235186E-02,& - & .3206376E-02,.7850198E-02,.8612179E-02,.8123777E-02,.4476963E-02,& - & .1850772E-02,.4769289E-02,.5310687E-02,.5121509E-02,.3086654E-02,& - & .2053571E-02,.5233812E-02,.5801277E-02,.5573075E-02,.3276182E-02,& - & .2279445E-02,.5767992E-02,.6371794E-02,.6087455E-02,.3472505E-02,& - & .2530319E-02,.6378620E-02,.7028994E-02,.6663834E-02,.3681702E-02,& - & .2802247E-02,.7072716E-02,.7774573E-02,.7310658E-02,.3905465E-02/ - - data absb(526:700, 6) / & - & .1599613E-02,.4199571E-02,.4673794E-02,.4506393E-02,.2664028E-02,& - & .1780622E-02,.4639345E-02,.5147271E-02,.4937749E-02,.2836730E-02,& - & .1982209E-02,.5147946E-02,.5697272E-02,.5427726E-02,.3018582E-02,& - & .2205837E-02,.5730040E-02,.6328408E-02,.5979873E-02,.3214093E-02,& - & .2444633E-02,.6402438E-02,.7040553E-02,.6604978E-02,.3423730E-02,& - & .1370767E-02,.3680434E-02,.4101387E-02,.3951642E-02,.2288026E-02,& - & .1530214E-02,.4092955E-02,.4551071E-02,.4359160E-02,.2445148E-02,& - & .1709076E-02,.4573254E-02,.5075448E-02,.4822350E-02,.2615383E-02,& - & .1905572E-02,.5130202E-02,.5673701E-02,.5348975E-02,.2795090E-02,& - & .2113656E-02,.5770683E-02,.6349792E-02,.5951205E-02,.2990809E-02,& - & .1161344E-02,.3200182E-02,.3576104E-02,.3443194E-02,.1950452E-02,& - & .1300611E-02,.3583463E-02,.3997263E-02,.3823311E-02,.2093149E-02,& - & .1456618E-02,.4035349E-02,.4489225E-02,.4258002E-02,.2249394E-02,& - & .1627537E-02,.4558261E-02,.5050496E-02,.4756449E-02,.2415485E-02,& - & .1808199E-02,.5161226E-02,.5687359E-02,.5329814E-02,.2597049E-02,& - & .9689423E-03,.2745553E-02,.3074976E-02,.2960730E-02,.1661770E-02,& - & .1088391E-02,.3094206E-02,.3461113E-02,.3308475E-02,.1792192E-02,& - & .1222284E-02,.3506981E-02,.3912501E-02,.3709778E-02,.1935066E-02,& - & .1369638E-02,.3987964E-02,.4430278E-02,.4173459E-02,.2088437E-02,& - & .1526024E-02,.4545546E-02,.5021863E-02,.4708792E-02,.2255640E-02,& - & .8077252E-03,.2356556E-02,.2645654E-02,.2547112E-02,.1416723E-02,& - & .9097668E-03,.2673661E-02,.2999603E-02,.2865604E-02,.1535808E-02,& - & .1024815E-02,.3051199E-02,.3413691E-02,.3236220E-02,.1665481E-02,& - & .1151477E-02,.3493356E-02,.3891808E-02,.3667727E-02,.1807129E-02,& - & .1286842E-02,.4009109E-02,.4442138E-02,.4167563E-02,.1962379E-02,& - & .6730887E-03,.2025445E-02,.2280105E-02,.2194379E-02,.1207918E-02,& - & .7604151E-03,.2314345E-02,.2604175E-02,.2486551E-02,.1316161E-02,& - & .8589949E-03,.2660424E-02,.2985221E-02,.2829802E-02,.1435082E-02,& - & .9677787E-03,.3067804E-02,.3427622E-02,.3232026E-02,.1564953E-02,& - & .1084841E-02,.3545518E-02,.3940911E-02,.3699314E-02,.1709431E-02,& - & .5540015E-03,.1719029E-02,.1940291E-02,.1868227E-02,.1025773E-02,& - & .6275728E-03,.1977116E-02,.2231569E-02,.2131986E-02,.1124006E-02,& - & .7113040E-03,.2288889E-02,.2577000E-02,.2444792E-02,.1232036E-02,& - & .8041626E-03,.2658785E-02,.2980992E-02,.2813689E-02,.1351842E-02,& - & .9045868E-03,.3094678E-02,.3453278E-02,.3244781E-02,.1485313E-02/ - - data absb(701:875, 6) / & - & .4548896E-03,.1456307E-02,.1647750E-02,.1587652E-02,.8696717E-03,& - & .5169304E-03,.1686770E-02,.1909185E-02,.1825449E-02,.9593282E-03,& - & .5876050E-03,.1966424E-02,.2220965E-02,.2109507E-02,.1057588E-02,& - & .6666461E-03,.2301238E-02,.2589214E-02,.2446720E-02,.1167507E-02,& - & .7525562E-03,.2698055E-02,.3023141E-02,.2843621E-02,.1289308E-02,& - & .3734897E-03,.1232867E-02,.1398777E-02,.1349075E-02,.7359709E-03,& - & .4253634E-03,.1438755E-02,.1632644E-02,.1562815E-02,.8174284E-03,& - & .4850469E-03,.1689562E-02,.1914018E-02,.1820551E-02,.9077182E-03,& - & .5522656E-03,.1992581E-02,.2249528E-02,.2128458E-02,.1008030E-02,& - & .6258618E-03,.2353791E-02,.2648433E-02,.2493658E-02,.1119658E-02,& - & .3045367E-03,.1033446E-02,.1175577E-02,.1135975E-02,.6197699E-03,& - & .3473823E-03,.1215271E-02,.1382545E-02,.1325828E-02,.6926384E-03,& - & .3970307E-03,.1437673E-02,.1633541E-02,.1556762E-02,.7746954E-03,& - & .4539062E-03,.1708894E-02,.1936090E-02,.1834842E-02,.8669180E-03,& - & .5165865E-03,.2034536E-02,.2299010E-02,.2167541E-02,.9692109E-03,& - & .2472336E-03,.8613164E-03,.9823016E-03,.9514129E-03,.5196099E-03,& - & .2828538E-03,.1020438E-02,.1163949E-02,.1118679E-02,.5847521E-03,& - & .3237516E-03,.1216274E-02,.1386324E-02,.1324100E-02,.6591741E-03,& - & .3714736E-03,.1458189E-02,.1657661E-02,.1574061E-02,.7425059E-03,& - & .4245663E-03,.1749792E-02,.1985372E-02,.1874641E-02,.8368539E-03,& - & .2006002E-03,.7166388E-03,.8191347E-03,.7953709E-03,.4345003E-03,& - & .2300088E-03,.8550124E-03,.9779366E-03,.9420990E-03,.4927929E-03,& - & .2640138E-03,.1027318E-02,.1174304E-02,.1124337E-02,.5593878E-03,& - & .3036185E-03,.1241926E-02,.1416866E-02,.1348159E-02,.6350064E-03,& - & .3483255E-03,.1503311E-02,.1712388E-02,.1619624E-02,.7206305E-03,& - & .1620672E-03,.5924002E-03,.6788004E-03,.6609668E-03,.3615247E-03,& - & .1863562E-03,.7120820E-03,.8162499E-03,.7885530E-03,.4130089E-03,& - & .2144232E-03,.8626280E-03,.9887801E-03,.9492287E-03,.4724825E-03,& - & .2473832E-03,.1051309E-02,.1203656E-02,.1147998E-02,.5403679E-03,& - & .2847841E-03,.1284144E-02,.1468365E-02,.1391452E-02,.6179991E-03,& - & .1299474E-03,.4846482E-03,.5565712E-03,.5436535E-03,.2982511E-03,& - & .1498986E-03,.5864424E-03,.6736990E-03,.6529381E-03,.3434172E-03,& - & .1729325E-03,.7163074E-03,.8229894E-03,.7924220E-03,.3957912E-03,& - & .2000081E-03,.8797706E-03,.1010993E-02,.9670011E-03,.4564930E-03,& - & .2313308E-03,.1085043E-02,.1245383E-02,.1182959E-02,.5264754E-03/ - - data absb(876:1050, 6) / & - & .1041538E-03,.3951902E-03,.4548472E-03,.4454470E-03,.2452479E-03,& - & .1203711E-03,.4813274E-03,.5542653E-03,.5387494E-03,.2845514E-03,& - & .1392557E-03,.5925482E-03,.6823171E-03,.6591592E-03,.3305080E-03,& - & .1615406E-03,.7342118E-03,.8463369E-03,.8118950E-03,.3843966E-03,& - & .1875302E-03,.9137067E-03,.1052775E-02,.1002597E-02,.4471473E-03,& - & .8339613E-04,.3212348E-03,.3702850E-03,.3635514E-03,.2009331E-03,& - & .9663218E-04,.3936340E-03,.4542459E-03,.4427976E-03,.2348384E-03,& - & .1119212E-03,.4884335E-03,.5635159E-03,.5461149E-03,.2749028E-03,& - & .1301921E-03,.6106310E-03,.7057229E-03,.6791355E-03,.3226368E-03,& - & .1518690E-03,.7666828E-03,.8867916E-03,.8470024E-03,.3788358E-03,& - & .6703277E-04,.2615715E-03,.3020685E-03,.2972644E-03,.1647457E-03,& - & .7781745E-04,.3226047E-03,.3728758E-03,.3643763E-03,.1940020E-03,& - & .9035340E-04,.4034207E-03,.4665853E-03,.4531468E-03,.2290995E-03,& - & .1051725E-03,.5090275E-03,.5895403E-03,.5690155E-03,.2711767E-03,& - & .1231606E-03,.6451073E-03,.7487546E-03,.7170779E-03,.3213112E-03,& - & .5388627E-04,.2129730E-03,.2462008E-03,.2426751E-03,.1352080E-03,& - & .6277450E-04,.2640459E-03,.3057224E-03,.2995161E-03,.1599361E-03,& - & .7304733E-04,.3329169E-03,.3859229E-03,.3754737E-03,.1906374E-03,& - & .8515751E-04,.4241494E-03,.4919296E-03,.4761974E-03,.2276739E-03,& - & .9991988E-04,.5432688E-03,.6320927E-03,.6069695E-03,.2723849E-03,& - & .4326262E-04,.1729315E-03,.2000827E-03,.1973909E-03,.1105920E-03,& - & .5057315E-04,.2155302E-03,.2498708E-03,.2454105E-03,.1317820E-03,& - & .5902025E-04,.2738145E-03,.3180329E-03,.3099867E-03,.1580455E-03,& - & .6892231E-04,.3521416E-03,.4093245E-03,.3971150E-03,.1905530E-03,& - & .8105656E-04,.4558123E-03,.5314348E-03,.5116504E-03,.2300912E-03,& - & .3466273E-04,.1400139E-03,.1619739E-03,.1598674E-03,.9004375E-04,& - & .4063512E-04,.1754360E-03,.2034983E-03,.2003206E-03,.1082624E-03,& - & .4757947E-04,.2243047E-03,.2609699E-03,.2549037E-03,.1307310E-03,& - & .5575140E-04,.2912187E-03,.3392706E-03,.3296565E-03,.1588775E-03,& - & .6571337E-04,.3810311E-03,.4450150E-03,.4296054E-03,.1937683E-03,& - & .2781043E-04,.1138793E-03,.1316412E-03,.1298484E-03,.7350396E-04,& - & .3277645E-04,.1433051E-03,.1663826E-03,.1640294E-03,.8913117E-04,& - & .3850357E-04,.1846844E-03,.2150481E-03,.2104981E-03,.1086380E-03,& - & .4522837E-04,.2419881E-03,.2824462E-03,.2747396E-03,.1329710E-03,& - & .5347828E-04,.3200061E-03,.3744878E-03,.3622497E-03,.1637392E-03/ - - data absb(1051:1175, 6) / & - & .2232236E-04,.9267720E-04,.1070487E-03,.1054862E-03,.5992194E-04,& - & .2641653E-04,.1172861E-03,.1361391E-03,.1343624E-03,.7334096E-04,& - & .3117369E-04,.1521353E-03,.1772789E-03,.1738983E-03,.9024944E-04,& - & .3674804E-04,.2011031E-03,.2351698E-03,.2290276E-03,.1115235E-03,& - & .4354793E-04,.2690881E-03,.3153806E-03,.3055401E-03,.1384935E-03,& - & .1785498E-04,.7521527E-04,.8673443E-04,.8536647E-04,.4869020E-04,& - & .2122523E-04,.9568767E-04,.1111031E-03,.1096456E-03,.6010776E-04,& - & .2515713E-04,.1249154E-03,.1456399E-03,.1431298E-03,.7472628E-04,& - & .2980978E-04,.1668004E-03,.1951256E-03,.1902764E-03,.9333750E-04,& - & .3542498E-04,.2255442E-03,.2648513E-03,.2567580E-03,.1168654E-03,& - & .1425709E-04,.6087198E-04,.7014411E-04,.6881006E-04,.3939206E-04,& - & .1702198E-04,.7779210E-04,.9029022E-04,.8913052E-04,.4908012E-04,& - & .2026100E-04,.1023006E-03,.1192918E-03,.1173391E-03,.6161544E-04,& - & .2410865E-04,.1377899E-03,.1613227E-03,.1576056E-03,.7784401E-04,& - & .2878722E-04,.1883410E-03,.2215045E-03,.2149526E-03,.9849260E-04,& - & .1138303E-04,.4934557E-04,.5673238E-04,.5553184E-04,.3186568E-04,& - & .1366146E-04,.6335560E-04,.7355595E-04,.7250807E-04,.4005918E-04,& - & .1632332E-04,.8387900E-04,.9788807E-04,.9633384E-04,.5083176E-04,& - & .1950274E-04,.1140523E-03,.1335383E-03,.1306879E-03,.6491699E-04,& - & .2338070E-04,.1577480E-03,.1855710E-03,.1802136E-03,.8318615E-04,& - & .9393833E-05,.4172083E-04,.4794329E-04,.4688225E-04,.2676670E-04,& - & .1131203E-04,.5413446E-04,.6285587E-04,.6190797E-04,.3404469E-04,& - & .1356891E-04,.7245624E-04,.8467100E-04,.8329182E-04,.4370019E-04,& - & .1627959E-04,.9993465E-04,.1171212E-03,.1145831E-03,.5652037E-04,& - & .1962119E-04,.1401179E-03,.1650762E-03,.1601642E-03,.7346404E-04/ - - data absb( 1:175, 7) / & - & .3229900E+00,.5476000E+00,.6007900E+00,.5851700E+00,.4227600E+00,& - & .3259400E+00,.5596300E+00,.6165300E+00,.6014700E+00,.4328100E+00,& - & .3305600E+00,.5718200E+00,.6323600E+00,.6186300E+00,.4414900E+00,& - & .3370600E+00,.5842600E+00,.6482200E+00,.6348900E+00,.4489300E+00,& - & .3463500E+00,.5973900E+00,.6634300E+00,.6500300E+00,.4548600E+00,& - & .2718500E+00,.4739600E+00,.5208700E+00,.5051800E+00,.3589800E+00,& - & .2745500E+00,.4845400E+00,.5347300E+00,.5205800E+00,.3672500E+00,& - & .2787800E+00,.4952300E+00,.5487600E+00,.5355600E+00,.3747700E+00,& - & .2854000E+00,.5066000E+00,.5624400E+00,.5494800E+00,.3809500E+00,& - & .2947400E+00,.5187600E+00,.5759200E+00,.5625500E+00,.3866000E+00,& - & .2281800E+00,.4082500E+00,.4500300E+00,.4358200E+00,.3035000E+00,& - & .2307400E+00,.4174900E+00,.4622000E+00,.4493000E+00,.3106400E+00,& - & .2351000E+00,.4273700E+00,.4743400E+00,.4620200E+00,.3169600E+00,& - & .2418600E+00,.4378300E+00,.4863700E+00,.4738700E+00,.3226500E+00,& - & .2512100E+00,.4494300E+00,.4985500E+00,.4851900E+00,.3281600E+00,& - & .1912000E+00,.3497500E+00,.3873200E+00,.3750900E+00,.2561700E+00,& - & .1938500E+00,.3582600E+00,.3979900E+00,.3866600E+00,.2625900E+00,& - & .1984600E+00,.3672700E+00,.4087200E+00,.3975000E+00,.2681500E+00,& - & .2053700E+00,.3771200E+00,.4195400E+00,.4077700E+00,.2733000E+00,& - & .2142700E+00,.3886800E+00,.4307100E+00,.4178400E+00,.2785300E+00,& - & .1598800E+00,.2985400E+00,.3318000E+00,.3220100E+00,.2161100E+00,& - & .1627900E+00,.3062800E+00,.3412900E+00,.3318800E+00,.2216200E+00,& - & .1676300E+00,.3146300E+00,.3508500E+00,.3412200E+00,.2266400E+00,& - & .1744400E+00,.3243200E+00,.3606800E+00,.3503200E+00,.2316100E+00,& - & .1827400E+00,.3360900E+00,.3714000E+00,.3594400E+00,.2366500E+00,& - & .1335200E+00,.2540400E+00,.2833000E+00,.2757700E+00,.1822500E+00,& - & .1366700E+00,.2610300E+00,.2917100E+00,.2843100E+00,.1871200E+00,& - & .1416400E+00,.2691000E+00,.3003000E+00,.2925400E+00,.1917600E+00,& - & .1480900E+00,.2788600E+00,.3095900E+00,.3007300E+00,.1963700E+00,& - & .1555100E+00,.2905000E+00,.3202000E+00,.3093000E+00,.2011500E+00,& - & .1117700E+00,.2158000E+00,.2413600E+00,.2355200E+00,.1539200E+00,& - & .1150400E+00,.2224300E+00,.2489000E+00,.2430400E+00,.1583300E+00,& - & .1197500E+00,.2303100E+00,.2568700E+00,.2504800E+00,.1624400E+00,& - & .1255300E+00,.2399400E+00,.2658800E+00,.2581200E+00,.1667100E+00,& - & .1320400E+00,.2510700E+00,.2763900E+00,.2662900E+00,.1711000E+00/ - - data absb(176:350, 7) / & - & .9381800E-01,.1833600E+00,.2053300E+00,.2008300E+00,.1306300E+00,& - & .9715300E-01,.1897500E+00,.2122200E+00,.2075400E+00,.1344500E+00,& - & .1015700E+00,.1975900E+00,.2198900E+00,.2143900E+00,.1381900E+00,& - & .1065600E+00,.2069200E+00,.2288500E+00,.2217000E+00,.1420000E+00,& - & .1121700E+00,.2174100E+00,.2391400E+00,.2297200E+00,.1459500E+00,& - & .7886400E-01,.1558100E+00,.1746700E+00,.1711100E+00,.1109300E+00,& - & .8211500E-01,.1621300E+00,.1811400E+00,.1772200E+00,.1144800E+00,& - & .8609100E-01,.1698900E+00,.1885800E+00,.1836800E+00,.1179500E+00,& - & .9054400E-01,.1788300E+00,.1974000E+00,.1907500E+00,.1214000E+00,& - & .9553100E-01,.1885700E+00,.2071900E+00,.1987200E+00,.1249400E+00,& - & .6653600E-01,.1329300E+00,.1491300E+00,.1461800E+00,.9442900E-01,& - & .6963900E-01,.1393100E+00,.1553700E+00,.1518700E+00,.9768000E-01,& - & .7319400E-01,.1468800E+00,.1628200E+00,.1580500E+00,.1008700E+00,& - & .7720500E-01,.1553600E+00,.1713500E+00,.1650300E+00,.1041400E+00,& - & .8166700E-01,.1642700E+00,.1806600E+00,.1729100E+00,.1074400E+00,& - & .5626100E-01,.1138300E+00,.1276000E+00,.1251200E+00,.8055900E-01,& - & .5908600E-01,.1201400E+00,.1338400E+00,.1304800E+00,.8348500E-01,& - & .6228100E-01,.1273800E+00,.1412100E+00,.1364800E+00,.8646000E-01,& - & .6590600E-01,.1351700E+00,.1493700E+00,.1433600E+00,.8946200E-01,& - & .6999800E-01,.1433500E+00,.1580700E+00,.1509800E+00,.9258800E-01,& - & .4764200E-01,.9793300E-01,.1096300E+00,.1074200E+00,.6875000E-01,& - & .5019300E-01,.1039900E+00,.1158700E+00,.1125800E+00,.7143200E-01,& - & .5308500E-01,.1107700E+00,.1229800E+00,.1184500E+00,.7419400E-01,& - & .5638400E-01,.1179500E+00,.1307000E+00,.1251200E+00,.7697300E-01,& - & .6017400E-01,.1255500E+00,.1387900E+00,.1323700E+00,.7992000E-01,& - & .4043200E-01,.8464500E-01,.9472400E-01,.9263700E-01,.5880500E-01,& - & .4274800E-01,.9040900E-01,.1007900E+00,.9765400E-01,.6128900E-01,& - & .4539200E-01,.9668200E-01,.1075600E+00,.1034100E+00,.6381800E-01,& - & .4843800E-01,.1033500E+00,.1147800E+00,.1097800E+00,.6648100E-01,& - & .5201900E-01,.1105000E+00,.1223400E+00,.1166400E+00,.6920900E-01,& - & .3443000E-01,.7356700E-01,.8234900E-01,.8034100E-01,.5048500E-01,& - & .3655800E-01,.7899700E-01,.8816300E-01,.8529300E-01,.5283500E-01,& - & .3900900E-01,.8481800E-01,.9452100E-01,.9085100E-01,.5518100E-01,& - & .4187600E-01,.9107400E-01,.1012700E+00,.9692200E-01,.5764400E-01,& - & .4529400E-01,.9787400E-01,.1084100E+00,.1034000E+00,.6025800E-01/ - - data absb(351:525, 7) / & - & .2941800E-01,.6428900E-01,.7198400E-01,.7011200E-01,.4351400E-01,& - & .3136700E-01,.6933300E-01,.7750000E-01,.7494500E-01,.4565400E-01,& - & .3365000E-01,.7477900E-01,.8345100E-01,.8028400E-01,.4783800E-01,& - & .3637300E-01,.8069800E-01,.8980300E-01,.8603500E-01,.5018800E-01,& - & .3962500E-01,.8722700E-01,.9660500E-01,.9216300E-01,.5266100E-01,& - & .2520600E-01,.5643600E-01,.6328200E-01,.6157100E-01,.3760200E-01,& - & .2700900E-01,.6114700E-01,.6848100E-01,.6623700E-01,.3956200E-01,& - & .2915000E-01,.6630200E-01,.7407400E-01,.7134100E-01,.4160100E-01,& - & .3175000E-01,.7195500E-01,.8010400E-01,.7678500E-01,.4379400E-01,& - & .3483400E-01,.7826800E-01,.8666200E-01,.8263200E-01,.4619300E-01,& - & .2167200E-01,.4982100E-01,.5598500E-01,.5443100E-01,.3267700E-01,& - & .2336000E-01,.5425700E-01,.6087100E-01,.5891800E-01,.3445300E-01,& - & .2542000E-01,.5915900E-01,.6616800E-01,.6376500E-01,.3639800E-01,& - & .2790800E-01,.6462900E-01,.7193500E-01,.6897700E-01,.3849000E-01,& - & .3084300E-01,.7079100E-01,.7832300E-01,.7461000E-01,.4074700E-01,& - & .1870300E-01,.4423600E-01,.4981900E-01,.4842300E-01,.2850300E-01,& - & .2031500E-01,.4844500E-01,.5442500E-01,.5272000E-01,.3017400E-01,& - & .2230700E-01,.5316300E-01,.5948100E-01,.5735900E-01,.3201800E-01,& - & .2468700E-01,.5849500E-01,.6506400E-01,.6236800E-01,.3402200E-01,& - & .2751000E-01,.6459700E-01,.7135200E-01,.6786000E-01,.3624300E-01,& - & .1622700E-01,.3954600E-01,.4461300E-01,.4338400E-01,.2494700E-01,& - & .1779100E-01,.4357600E-01,.4901000E-01,.4750100E-01,.2657700E-01,& - & .1972000E-01,.4816300E-01,.5387700E-01,.5196200E-01,.2834700E-01,& - & .2201000E-01,.5341900E-01,.5936800E-01,.5684200E-01,.3032600E-01,& - & .2477800E-01,.5953300E-01,.6558200E-01,.6227900E-01,.3246400E-01,& - & .1416800E-01,.3561000E-01,.4022800E-01,.3914500E-01,.2199800E-01,& - & .1570100E-01,.3951800E-01,.4445500E-01,.4310800E-01,.2355100E-01,& - & .1756800E-01,.4402800E-01,.4922800E-01,.4744200E-01,.2530300E-01,& - & .1982200E-01,.4927400E-01,.5464400E-01,.5226900E-01,.2721900E-01,& - & .2249200E-01,.5542900E-01,.6087800E-01,.5769600E-01,.2928900E-01,& - & .1246900E-01,.3232100E-01,.3654800E-01,.3558600E-01,.1953500E-01,& - & .1396700E-01,.3616000E-01,.4067000E-01,.3941400E-01,.2105700E-01,& - & .1580400E-01,.4064600E-01,.4537100E-01,.4369700E-01,.2274800E-01,& - & .1800700E-01,.4593500E-01,.5079000E-01,.4850400E-01,.2458900E-01,& - & .2058300E-01,.5211700E-01,.5708300E-01,.5394900E-01,.2661200E-01/ - - data absb(526:700, 7) / & - & .1103000E-01,.2946200E-01,.3333300E-01,.3245700E-01,.1744100E-01,& - & .1248500E-01,.3325200E-01,.3737400E-01,.3620300E-01,.1890200E-01,& - & .1428400E-01,.3773500E-01,.4203900E-01,.4044900E-01,.2053300E-01,& - & .1640600E-01,.4305000E-01,.4747300E-01,.4525000E-01,.2231500E-01,& - & .1888900E-01,.4922100E-01,.5383800E-01,.5070900E-01,.2429500E-01,& - & .9704500E-02,.2676500E-01,.3029400E-01,.2949400E-01,.1552700E-01,& - & .1111600E-01,.3047100E-01,.3423700E-01,.3315600E-01,.1693600E-01,& - & .1283300E-01,.3490800E-01,.3882700E-01,.3733500E-01,.1849400E-01,& - & .1485100E-01,.4016000E-01,.4422800E-01,.4209500E-01,.2023000E-01,& - & .1722000E-01,.4627500E-01,.5060000E-01,.4752400E-01,.2213700E-01,& - & .8478700E-02,.2413100E-01,.2733900E-01,.2661900E-01,.1375600E-01,& - & .9803300E-02,.2770600E-01,.3114700E-01,.3016600E-01,.1510600E-01,& - & .1140700E-01,.3201500E-01,.3561000E-01,.3423900E-01,.1659300E-01,& - & .1330200E-01,.3714000E-01,.4090700E-01,.3890400E-01,.1825700E-01,& - & .1553700E-01,.4312900E-01,.4718200E-01,.4423600E-01,.2007400E-01,& - & .7268500E-02,.2139200E-01,.2430100E-01,.2367900E-01,.1208700E-01,& - & .8473300E-02,.2475900E-01,.2789800E-01,.2704600E-01,.1334200E-01,& - & .9935300E-02,.2884800E-01,.3215200E-01,.3094000E-01,.1474800E-01,& - & .1167300E-01,.3373400E-01,.3722400E-01,.3542200E-01,.1631900E-01,& - & .1374000E-01,.3948100E-01,.4325600E-01,.4056600E-01,.1804900E-01,& - & .6232600E-02,.1899900E-01,.2164400E-01,.2110300E-01,.1062900E-01,& - & .7326900E-02,.2217000E-01,.2504200E-01,.2429900E-01,.1180700E-01,& - & .8658600E-02,.2604500E-01,.2909800E-01,.2801900E-01,.1313800E-01,& - & .1025400E-01,.3069900E-01,.3395200E-01,.3231600E-01,.1462100E-01,& - & .1216800E-01,.3621100E-01,.3974800E-01,.3728800E-01,.1626300E-01,& - & .5352200E-02,.1692500E-01,.1933700E-01,.1886300E-01,.9369700E-02,& - & .6343700E-02,.1991600E-01,.2255500E-01,.2190000E-01,.1047700E-01,& - & .7560000E-02,.2359000E-01,.2642800E-01,.2545300E-01,.1173200E-01,& - & .9027700E-02,.2802700E-01,.3108100E-01,.2958100E-01,.1314000E-01,& - & .1080400E-01,.3332500E-01,.3665500E-01,.3439600E-01,.1471400E-01,& - & .4518300E-02,.1486200E-01,.1704300E-01,.1664000E-01,.8190600E-02,& - & .5396400E-02,.1763000E-01,.2004300E-01,.1948200E-01,.9233500E-02,& - & .6483500E-02,.2104100E-01,.2367400E-01,.2282100E-01,.1040000E-01,& - & .7810000E-02,.2519700E-01,.2805600E-01,.2673300E-01,.1171800E-01,& - & .9431000E-02,.3020300E-01,.3332200E-01,.3132100E-01,.1320900E-01/ - - data absb(701:875, 7) / & - & .3802000E-02,.1303500E-01,.1500700E-01,.1466500E-01,.7164500E-02,& - & .4579600E-02,.1559200E-01,.1780200E-01,.1732000E-01,.8133200E-02,& - & .5546400E-02,.1874900E-01,.2119100E-01,.2044800E-01,.9231200E-02,& - & .6740800E-02,.2262900E-01,.2530900E-01,.2414300E-01,.1045800E-01,& - & .8215500E-02,.2734700E-01,.3027700E-01,.2850600E-01,.1187100E-01,& - & .3196200E-02,.1144400E-01,.1322900E-01,.1293700E-01,.6278800E-02,& - & .3881500E-02,.1379800E-01,.1582200E-01,.1540700E-01,.7177400E-02,& - & .4742200E-02,.1672200E-01,.1899000E-01,.1833900E-01,.8198600E-02,& - & .5815400E-02,.2034200E-01,.2285700E-01,.2183000E-01,.9359400E-02,& - & .7154600E-02,.2478700E-01,.2754500E-01,.2597300E-01,.1068400E-01,& - & .2654200E-02,.9942100E-02,.1154500E-01,.1129700E-01,.5468100E-02,& - & .3246700E-02,.1208500E-01,.1392600E-01,.1357500E-01,.6301700E-02,& - & .4003700E-02,.1475800E-01,.1684800E-01,.1629600E-01,.7243400E-02,& - & .4953400E-02,.1809400E-01,.2043800E-01,.1955600E-01,.8335400E-02,& - & .6152500E-02,.2223000E-01,.2481700E-01,.2345000E-01,.9575100E-02,& - & .2188100E-02,.8585700E-02,.1001900E-01,.9804300E-02,.4745600E-02,& - & .2693700E-02,.1052500E-01,.1219200E-01,.1189800E-01,.5516800E-02,& - & .3353100E-02,.1295200E-01,.1487000E-01,.1440800E-01,.6393800E-02,& - & .4191600E-02,.1601600E-01,.1818700E-01,.1744100E-01,.7399500E-02,& - & .5252900E-02,.1982500E-01,.2224500E-01,.2107400E-01,.8569300E-02,& - & .1797400E-02,.7403600E-02,.8681900E-02,.8494900E-02,.4110000E-02,& - & .2228300E-02,.9155600E-02,.1066400E-01,.1041400E-01,.4825700E-02,& - & .2799300E-02,.1136000E-01,.1311500E-01,.1273100E-01,.5642300E-02,& - & .3535800E-02,.1416400E-01,.1617000E-01,.1554300E-01,.6586700E-02,& - & .4476200E-02,.1767100E-01,.1992800E-01,.1893100E-01,.7672500E-02,& - & .1466600E-02,.6344300E-02,.7471000E-02,.7309900E-02,.3554000E-02,& - & .1828600E-02,.7914000E-02,.9271900E-02,.9058800E-02,.4198100E-02,& - & .2319600E-02,.9908900E-02,.1150800E-01,.1119200E-01,.4965600E-02,& - & .2957500E-02,.1245100E-01,.1429600E-01,.1377900E-01,.5844100E-02,& - & .3784200E-02,.1566200E-01,.1775800E-01,.1692100E-01,.6866000E-02,& - & .1182200E-02,.5370000E-02,.6348300E-02,.6209000E-02,.3050000E-02,& - & .1481700E-02,.6761600E-02,.7967800E-02,.7787400E-02,.3631700E-02,& - & .1891800E-02,.8539200E-02,.9981800E-02,.9725400E-02,.4324800E-02,& - & .2438200E-02,.1082000E-01,.1250300E-01,.1208800E-01,.5147700E-02,& - & .3153300E-02,.1372500E-01,.1565600E-01,.1497000E-01,.6100000E-02/ - - data absb(876:1050, 7) / & - & .9490600E-03,.4529800E-02,.5370600E-02,.5250600E-02,.2616200E-02,& - & .1196500E-02,.5759700E-02,.6821300E-02,.6669800E-02,.3140300E-02,& - & .1536900E-02,.7338000E-02,.8636800E-02,.8424600E-02,.3768700E-02,& - & .2000800E-02,.9381400E-02,.1091100E-01,.1058000E-01,.4521300E-02,& - & .2615900E-02,.1200200E-01,.1377400E-01,.1322100E-01,.5414200E-02,& - & .7591300E-03,.3804300E-02,.4520300E-02,.4418100E-02,.2237900E-02,& - & .9609700E-03,.4889900E-02,.5813800E-02,.5687800E-02,.2709800E-02,& - & .1244700E-02,.6289500E-02,.7450100E-02,.7272700E-02,.3285900E-02,& - & .1632200E-02,.8112200E-02,.9498900E-02,.9234900E-02,.3972000E-02,& - & .2159700E-02,.1047000E-01,.1209200E-01,.1165000E-01,.4793800E-02,& - & .6094900E-03,.3200900E-02,.3808000E-02,.3720400E-02,.1914800E-02,& - & .7733200E-03,.4163700E-02,.4965800E-02,.4858800E-02,.2349800E-02,& - & .1009900E-02,.5409500E-02,.6441600E-02,.6293800E-02,.2871300E-02,& - & .1335300E-02,.7041700E-02,.8300400E-02,.8084400E-02,.3511400E-02,& - & .1787300E-02,.9169100E-02,.1065800E-01,.1030300E-01,.4264100E-02,& - & .4896000E-03,.2687300E-02,.3200800E-02,.3125900E-02,.1637800E-02,& - & .6218700E-03,.3542300E-02,.4234900E-02,.4144300E-02,.2032500E-02,& - & .8178800E-03,.4652900E-02,.5565600E-02,.5442400E-02,.2516400E-02,& - & .1093500E-02,.6115500E-02,.7256500E-02,.7076500E-02,.3100700E-02,& - & .1477600E-02,.8041600E-02,.9408700E-02,.9119700E-02,.3808500E-02,& - & .3930200E-03,.2243500E-02,.2675400E-02,.2612200E-02,.1389800E-02,& - & .4988900E-03,.3000600E-02,.3594300E-02,.3517200E-02,.1753200E-02,& - & .6592200E-03,.3990600E-02,.4790100E-02,.4688000E-02,.2198000E-02,& - & .8907500E-03,.5298000E-02,.6323700E-02,.6174800E-02,.2741200E-02,& - & .1215000E-02,.7031200E-02,.8283700E-02,.8049700E-02,.3395600E-02,& - & .3153300E-03,.1859800E-02,.2221600E-02,.2169000E-02,.1170500E-02,& - & .3991900E-03,.2529000E-02,.3033800E-02,.2967900E-02,.1505100E-02,& - & .5295800E-03,.3409600E-02,.4103000E-02,.4018900E-02,.1913700E-02,& - & .7214700E-03,.4575600E-02,.5489400E-02,.5367800E-02,.2414700E-02,& - & .9956300E-03,.6132100E-02,.7273900E-02,.7082600E-02,.3028600E-02,& - & .2543400E-03,.1547700E-02,.1850200E-02,.1807500E-02,.9889100E-03,& - & .3222100E-03,.2139800E-02,.2570800E-02,.2514800E-02,.1293500E-02,& - & .4277500E-03,.2927200E-02,.3531500E-02,.3459900E-02,.1674100E-02,& - & .5876200E-03,.3976100E-02,.4790700E-02,.4689600E-02,.2137600E-02,& - & .8205300E-03,.5382400E-02,.6424400E-02,.6266400E-02,.2717300E-02/ - - data absb(1051:1175, 7) / & - & .2061800E-03,.1286600E-02,.1540000E-02,.1505500E-02,.8357200E-03,& - & .2605900E-03,.1809400E-02,.2178700E-02,.2130200E-02,.1109000E-02,& - & .3465100E-03,.2514000E-02,.3039200E-02,.2978000E-02,.1462800E-02,& - & .4788200E-03,.3460800E-02,.4183100E-02,.4100300E-02,.1899200E-02,& - & .6767100E-03,.4733100E-02,.5681700E-02,.5550300E-02,.2436000E-02,& - & .1668100E-03,.1062100E-02,.1272800E-02,.1246100E-02,.7016200E-03,& - & .2106400E-03,.1521300E-02,.1835000E-02,.1794500E-02,.9482800E-03,& - & .2802800E-03,.2150000E-02,.2604500E-02,.2552100E-02,.1272100E-02,& - & .3890600E-03,.3002900E-02,.3638700E-02,.3571000E-02,.1683300E-02,& - & .5556800E-03,.4153400E-02,.5011100E-02,.4902700E-02,.2184900E-02,& - & .1348400E-03,.8716800E-03,.1044400E-02,.1024800E-02,.5851600E-03,& - & .1700700E-03,.1271700E-02,.1536000E-02,.1502400E-02,.8080500E-03,& - & .2260300E-03,.1829600E-02,.2221100E-02,.2175700E-02,.1100600E-02,& - & .3156500E-03,.2596300E-02,.3153100E-02,.3095900E-02,.1485100E-02,& - & .4541700E-03,.3636500E-02,.4405800E-02,.4315700E-02,.1962500E-02,& - & .1093800E-03,.7144900E-03,.8565500E-03,.8424000E-03,.4877200E-03,& - & .1375200E-03,.1062400E-02,.1284900E-02,.1258300E-02,.6868900E-03,& - & .1830700E-03,.1557200E-02,.1895400E-02,.1856600E-02,.9534400E-03,& - & .2567300E-03,.2248100E-02,.2736300E-02,.2687700E-02,.1307900E-02,& - & .3723000E-03,.3192100E-02,.3881200E-02,.3807000E-02,.1757000E-02,& - & .9215300E-04,.6279800E-03,.7537400E-03,.7424300E-03,.4316100E-03,& - & .1167600E-03,.9501900E-03,.1152500E-02,.1129600E-02,.6195900E-03,& - & .1568700E-03,.1416800E-02,.1728500E-02,.1693800E-02,.8746800E-03,& - & .2227800E-03,.2074300E-02,.2530200E-02,.2486300E-02,.1216100E-02,& - & .3272400E-03,.2979700E-02,.3631300E-02,.3566400E-02,.1657700E-02/ - - data absb( 1:175, 8) / & - & .2147772E+01,.3506523E+01,.4007672E+01,.4063247E+01,.2937459E+01,& - & .2178726E+01,.3529383E+01,.4034995E+01,.4103957E+01,.3003216E+01,& - & .2233362E+01,.3568760E+01,.4070770E+01,.4144550E+01,.3061714E+01,& - & .2307004E+01,.3623393E+01,.4115151E+01,.4185941E+01,.3115511E+01,& - & .2388633E+01,.3691850E+01,.4168630E+01,.4227592E+01,.3167839E+01,& - & .1860982E+01,.3098016E+01,.3558079E+01,.3627319E+01,.2627403E+01,& - & .1905280E+01,.3134646E+01,.3595375E+01,.3671395E+01,.2687036E+01,& - & .1969054E+01,.3186559E+01,.3641361E+01,.3716596E+01,.2741361E+01,& - & .2041391E+01,.3252536E+01,.3696281E+01,.3763063E+01,.2795119E+01,& - & .2116579E+01,.3332677E+01,.3758858E+01,.3812101E+01,.2847416E+01,& - & .1617458E+01,.2741093E+01,.3152632E+01,.3221428E+01,.2339877E+01,& - & .1670160E+01,.2788238E+01,.3198512E+01,.3269657E+01,.2396388E+01,& - & .1732677E+01,.2849720E+01,.3253678E+01,.3319736E+01,.2449246E+01,& - & .1797925E+01,.2926437E+01,.3317317E+01,.3372271E+01,.2501129E+01,& - & .1862880E+01,.3012958E+01,.3388595E+01,.3427980E+01,.2552877E+01,& - & .1410490E+01,.2430273E+01,.2789567E+01,.2851573E+01,.2070884E+01,& - & .1462546E+01,.2486398E+01,.2843042E+01,.2903268E+01,.2125260E+01,& - & .1517639E+01,.2557586E+01,.2906093E+01,.2957563E+01,.2178494E+01,& - & .1573385E+01,.2638614E+01,.2977318E+01,.3015588E+01,.2231226E+01,& - & .1630346E+01,.2723778E+01,.3055751E+01,.3077711E+01,.2281963E+01,& - & .1230541E+01,.2156310E+01,.2468500E+01,.2517143E+01,.1827564E+01,& - & .1276117E+01,.2220980E+01,.2528907E+01,.2572462E+01,.1880843E+01,& - & .1322689E+01,.2296509E+01,.2597740E+01,.2631249E+01,.1932799E+01,& - & .1370777E+01,.2376996E+01,.2674941E+01,.2694611E+01,.1983918E+01,& - & .1421644E+01,.2457551E+01,.2758874E+01,.2763587E+01,.2034867E+01,& - & .1070969E+01,.1915020E+01,.2186826E+01,.2218812E+01,.1611091E+01,& - & .1109526E+01,.1984117E+01,.2252013E+01,.2276826E+01,.1661713E+01,& - & .1149568E+01,.2059351E+01,.2326295E+01,.2340036E+01,.1710989E+01,& - & .1192105E+01,.2135358E+01,.2407183E+01,.2409247E+01,.1761075E+01,& - & .1238203E+01,.2211009E+01,.2491678E+01,.2482619E+01,.1811988E+01,& - & .9283756E+00,.1702510E+01,.1938601E+01,.1955270E+01,.1419882E+01,& - & .9616580E+00,.1771777E+01,.2008679E+01,.2016979E+01,.1468037E+01,& - & .9971495E+00,.1842985E+01,.2085977E+01,.2084514E+01,.1515441E+01,& - & .1035954E+01,.1914171E+01,.2167568E+01,.2156971E+01,.1563415E+01,& - & .1079188E+01,.1986694E+01,.2252099E+01,.2233773E+01,.1612851E+01/ - - data absb(176:350, 8) / & - & .8036031E+00,.1516186E+01,.1721627E+01,.1727213E+01,.1252674E+01,& - & .8326793E+00,.1581949E+01,.1794758E+01,.1792292E+01,.1298932E+01,& - & .8648349E+00,.1648188E+01,.1873088E+01,.1862805E+01,.1346221E+01,& - & .9010472E+00,.1716012E+01,.1954493E+01,.1937771E+01,.1392209E+01,& - & .9422352E+00,.1787156E+01,.2036790E+01,.2017682E+01,.1438445E+01,& - & .6953625E+00,.1350659E+01,.1532717E+01,.1530267E+01,.1104610E+01,& - & .7214726E+00,.1411984E+01,.1606492E+01,.1597505E+01,.1150564E+01,& - & .7509696E+00,.1474817E+01,.1683945E+01,.1669864E+01,.1196729E+01,& - & .7851546E+00,.1540757E+01,.1763201E+01,.1747500E+01,.1242539E+01,& - & .8247478E+00,.1610749E+01,.1844223E+01,.1828234E+01,.1287882E+01,& - & .6026917E+00,.1207364E+01,.1372521E+01,.1364577E+01,.9775652E+00,& - & .6273178E+00,.1265727E+01,.1445916E+01,.1433870E+01,.1022600E+01,& - & .6557573E+00,.1326639E+01,.1521041E+01,.1508141E+01,.1067263E+01,& - & .6889575E+00,.1391759E+01,.1598467E+01,.1586453E+01,.1112837E+01,& - & .7278457E+00,.1461987E+01,.1679430E+01,.1668167E+01,.1158214E+01,& - & .5220814E+00,.1081272E+01,.1234021E+01,.1222809E+01,.8668184E+00,& - & .5462161E+00,.1137925E+01,.1304901E+01,.1293790E+01,.9111319E+00,& - & .5743245E+00,.1198422E+01,.1378329E+01,.1368895E+01,.9551067E+00,& - & .6074624E+00,.1263493E+01,.1455169E+01,.1447720E+01,.9999031E+00,& - & .6464214E+00,.1334732E+01,.1536800E+01,.1530362E+01,.1044710E+01,& - & .4530676E+00,.9718752E+00,.1113625E+01,.1102459E+01,.7702607E+00,& - & .4767827E+00,.1027819E+01,.1182580E+01,.1173836E+01,.8131121E+00,& - & .5050006E+00,.1088357E+01,.1255221E+01,.1249573E+01,.8570364E+00,& - & .5385629E+00,.1154487E+01,.1332423E+01,.1329078E+01,.9009956E+00,& - & .5782279E+00,.1226660E+01,.1415277E+01,.1412212E+01,.9457995E+00,& - & .3944211E+00,.8783220E+00,.1009831E+01,.1000358E+01,.6870193E+00,& - & .4180031E+00,.9342002E+00,.1077916E+01,.1071914E+01,.7295172E+00,& - & .4466039E+00,.9953298E+00,.1150465E+01,.1147983E+01,.7723351E+00,& - & .4807452E+00,.1062397E+01,.1228665E+01,.1227974E+01,.8161121E+00,& - & .5212184E+00,.1135828E+01,.1313016E+01,.1312663E+01,.8641655E+00,& - & .3452462E+00,.7999293E+00,.9219804E+00,.9149658E+00,.6174465E+00,& - & .3690573E+00,.8557897E+00,.9899741E+00,.9866927E+00,.6583574E+00,& - & .3981461E+00,.9176898E+00,.1063178E+01,.1062821E+01,.7012026E+00,& - & .4331021E+00,.9859104E+00,.1142768E+01,.1144162E+01,.7470311E+00,& - & .4742396E+00,.1061101E+01,.1229416E+01,.1231158E+01,.7973609E+00/ - - data absb(351:525, 8) / & - & .3040686E+00,.7336469E+00,.8476943E+00,.8430763E+00,.5574518E+00,& - & .3283125E+00,.7901985E+00,.9160319E+00,.9148169E+00,.5982934E+00,& - & .3580998E+00,.8530076E+00,.9905938E+00,.9917986E+00,.6421955E+00,& - & .3937998E+00,.9226604E+00,.1072205E+01,.1075289E+01,.6908810E+00,& - & .4350420E+00,.1000013E+01,.1161544E+01,.1165076E+01,.7420692E+00,& - & .2699261E+00,.6782542E+00,.7854145E+00,.7829386E+00,.5064205E+00,& - & .2947504E+00,.7357341E+00,.8549126E+00,.8551804E+00,.5487324E+00,& - & .3252847E+00,.7997113E+00,.9311639E+00,.9339914E+00,.5953021E+00,& - & .3613092E+00,.8712485E+00,.1015309E+01,.1020027E+01,.6445334E+00,& - & .4023145E+00,.9510193E+00,.1107717E+01,.1113072E+01,.6967532E+00,& - & .2420005E+00,.6327790E+00,.7343674E+00,.7337147E+00,.4659044E+00,& - & .2675426E+00,.6914513E+00,.8056098E+00,.8073577E+00,.5100332E+00,& - & .2985977E+00,.7570808E+00,.8841869E+00,.8886282E+00,.5568586E+00,& - & .3345903E+00,.8307955E+00,.9712488E+00,.9777164E+00,.6069869E+00,& - & .3752790E+00,.9132888E+00,.1067298E+01,.1074521E+01,.6606337E+00,& - & .2193104E+00,.5956904E+00,.6933100E+00,.6941123E+00,.4338918E+00,& - & .2454356E+00,.6558867E+00,.7665763E+00,.7700794E+00,.4783097E+00,& - & .2766892E+00,.7234267E+00,.8479414E+00,.8542122E+00,.5258379E+00,& - & .3125185E+00,.7996635E+00,.9383927E+00,.9468621E+00,.5771763E+00,& - & .3530433E+00,.8851441E+00,.1038330E+01,.1047465E+01,.6323351E+00,& - & .2011174E+00,.5662868E+00,.6614813E+00,.6638455E+00,.4081986E+00,& - & .2276405E+00,.6282768E+00,.7371843E+00,.7426597E+00,.4531121E+00,& - & .2588601E+00,.6982349E+00,.8218536E+00,.8302250E+00,.5017038E+00,& - & .2946400E+00,.7772718E+00,.9161532E+00,.9266575E+00,.5545280E+00,& - & .3351557E+00,.8661253E+00,.1020315E+01,.1031181E+01,.6114083E+00,& - & .1865615E+00,.5436250E+00,.6378358E+00,.6421123E+00,.3878649E+00,& - & .2133106E+00,.6078013E+00,.7166414E+00,.7241786E+00,.4336769E+00,& - & .2445042E+00,.6804884E+00,.8049500E+00,.8154355E+00,.4837168E+00,& - & .2803835E+00,.7627085E+00,.9033997E+00,.9157583E+00,.5381867E+00,& - & .3210362E+00,.8552279E+00,.1011978E+01,.1024218E+01,.5970880E+00,& - & .1749538E+00,.5269996E+00,.6215976E+00,.6279908E+00,.3723894E+00,& - & .2017790E+00,.5937199E+00,.7039645E+00,.7136463E+00,.4194095E+00,& - & .2331437E+00,.6694912E+00,.7962787E+00,.8088205E+00,.4711663E+00,& - & .2692141E+00,.7551867E+00,.8989845E+00,.9129664E+00,.5275761E+00,& - & .3102376E+00,.8516644E+00,.1011909E+01,.1025210E+01,.5885594E+00/ - - data absb(526:700, 8) / & - & .1648200E+00,.5135795E+00,.6093601E+00,.6178369E+00,.3595625E+00,& - & .1916764E+00,.5828141E+00,.6952491E+00,.7068257E+00,.4080742E+00,& - & .2231330E+00,.6615194E+00,.7912997E+00,.8055439E+00,.4615211E+00,& - & .2594329E+00,.7506484E+00,.8977476E+00,.9130454E+00,.5197857E+00,& - & .3009092E+00,.8509191E+00,.1014517E+01,.1028676E+01,.5827702E+00,& - & .1542942E+00,.4984661E+00,.5950172E+00,.6050995E+00,.3460966E+00,& - & .1808778E+00,.5696361E+00,.6834611E+00,.6965516E+00,.3958165E+00,& - & .2120868E+00,.6504539E+00,.7821549E+00,.7977925E+00,.4505357E+00,& - & .2483187E+00,.7421169E+00,.8913076E+00,.9077047E+00,.5102050E+00,& - & .2900951E+00,.8450562E+00,.1010731E+01,.1025679E+01,.5747009E+00,& - & .1428838E+00,.4799142E+00,.5760617E+00,.5872644E+00,.3307220E+00,& - & .1688185E+00,.5520986E+00,.6658687E+00,.6800494E+00,.3810810E+00,& - & .1993677E+00,.6340252E+00,.7660136E+00,.7826397E+00,.4366263E+00,& - & .2351442E+00,.7269414E+00,.8765519E+00,.8938786E+00,.4971268E+00,& - & .2767765E+00,.8312265E+00,.9973781E+00,.1013193E+01,.5625664E+00,& - & .1295255E+00,.4542258E+00,.5478587E+00,.5595381E+00,.3107326E+00,& - & .1542935E+00,.5261193E+00,.6373454E+00,.6520435E+00,.3608896E+00,& - & .1835749E+00,.6075514E+00,.7372141E+00,.7544331E+00,.4164074E+00,& - & .2182062E+00,.6998975E+00,.8474540E+00,.8656087E+00,.4768929E+00,& - & .2589005E+00,.8036978E+00,.9679606E+00,.9848442E+00,.5424313E+00,& - & .1175401E+00,.4307071E+00,.5219632E+00,.5338978E+00,.2926245E+00,& - & .1412629E+00,.5022212E+00,.6108981E+00,.6259401E+00,.3424732E+00,& - & .1693284E+00,.5830370E+00,.7102630E+00,.7278824E+00,.3978669E+00,& - & .2028442E+00,.6746033E+00,.8199129E+00,.8387792E+00,.4582588E+00,& - & .2426035E+00,.7776740E+00,.9399588E+00,.9577662E+00,.5237233E+00,& - & .1069057E+00,.4095696E+00,.4986606E+00,.5107070E+00,.2765051E+00,& - & .1297183E+00,.4806709E+00,.5869321E+00,.6022485E+00,.3260232E+00,& - & .1566724E+00,.5608628E+00,.6856622E+00,.7036230E+00,.3812308E+00,& - & .1891795E+00,.6516100E+00,.7946672E+00,.8140707E+00,.4414800E+00,& - & .2280943E+00,.7538152E+00,.9140427E+00,.9326912E+00,.5067756E+00,& - & .9538147E-01,.3836728E+00,.4692157E+00,.4807161E+00,.2573361E+00,& - & .1169920E+00,.4534590E+00,.5555647E+00,.5707684E+00,.3058432E+00,& - & .1425205E+00,.5320323E+00,.6525202E+00,.6704208E+00,.3602199E+00,& - & .1734620E+00,.6207733E+00,.7596824E+00,.7794089E+00,.4197447E+00,& - & .2108876E+00,.7208589E+00,.8772631E+00,.8967522E+00,.4842904E+00/ - - data absb(701:875, 8) / & - & .8483947E-01,.3588563E+00,.4408601E+00,.4516281E+00,.2391711E+00,& - & .1052687E+00,.4273398E+00,.5251982E+00,.5400986E+00,.2865821E+00,& - & .1294958E+00,.5040617E+00,.6199729E+00,.6376780E+00,.3398708E+00,& - & .1588835E+00,.5906162E+00,.7250743E+00,.7449273E+00,.3985409E+00,& - & .1946890E+00,.6883248E+00,.8405775E+00,.8607468E+00,.4621965E+00,& - & .7543551E-01,.3358861E+00,.4145122E+00,.4243832E+00,.2224114E+00,& - & .9465525E-01,.4026844E+00,.4964574E+00,.5108780E+00,.2686287E+00,& - & .1177290E+00,.4776992E+00,.5890965E+00,.6064776E+00,.3207812E+00,& - & .1456605E+00,.5620963E+00,.6920814E+00,.7118635E+00,.3784909E+00,& - & .1798767E+00,.6573786E+00,.8054007E+00,.8260421E+00,.4411895E+00,& - & .6608792E-01,.3109105E+00,.3855264E+00,.3941304E+00,.2044580E+00,& - & .8394591E-01,.3756301E+00,.4645764E+00,.4780384E+00,.2491451E+00,& - & .1057032E+00,.4484352E+00,.5543433E+00,.5711787E+00,.2997657E+00,& - & .1320096E+00,.5302167E+00,.6546096E+00,.6740082E+00,.3560965E+00,& - & .1642833E+00,.6224082E+00,.7650984E+00,.7859469E+00,.4175347E+00,& - & .5738271E-01,.2860275E+00,.3565059E+00,.3636546E+00,.1867469E+00,& - & .7381553E-01,.3484044E+00,.4324451E+00,.4446271E+00,.2297128E+00,& - & .9417454E-01,.4188318E+00,.5189475E+00,.5351023E+00,.2785779E+00,& - & .1189809E+00,.4980563E+00,.6163102E+00,.6351253E+00,.3333660E+00,& - & .1491626E+00,.5867414E+00,.7235000E+00,.7442712E+00,.3933218E+00,& - & .4966189E-01,.2627287E+00,.3290966E+00,.3348944E+00,.1702478E+00,& - & .6472660E-01,.3227122E+00,.4021344E+00,.4129120E+00,.2114833E+00,& - & .8369235E-01,.3907371E+00,.4852534E+00,.5005355E+00,.2585650E+00,& - & .1070502E+00,.4673220E+00,.5794833E+00,.5976216E+00,.3116401E+00,& - & .1353378E+00,.5528051E+00,.6835756E+00,.7040363E+00,.3701096E+00,& - & .4256723E-01,.2397851E+00,.3016717E+00,.3062819E+00,.1540481E+00,& - & .5622816E-01,.2970953E+00,.3718496E+00,.3810025E+00,.1934507E+00,& - & .7377185E-01,.3626587E+00,.4515842E+00,.4655582E+00,.2385992E+00,& - & .9559465E-01,.4363178E+00,.5420972E+00,.5594484E+00,.2897050E+00,& - & .1220368E+00,.5185878E+00,.6428277E+00,.6627182E+00,.3464809E+00,& - & .3589415E-01,.2161673E+00,.2729648E+00,.2765338E+00,.1375028E+00,& - & .4805408E-01,.2703938E+00,.3401678E+00,.3474504E+00,.1747652E+00,& - & .6397943E-01,.3329344E+00,.4160369E+00,.4283381E+00,.2177681E+00,& - & .8411883E-01,.4035911E+00,.5024152E+00,.5187692E+00,.2666244E+00,& - & .1087145E+00,.4824389E+00,.5992777E+00,.6183786E+00,.3213119E+00/ - - data absb(876:1050, 8) / & - & .3011941E-01,.1941366E+00,.2458479E+00,.2487746E+00,.1221988E+00,& - & .4084506E-01,.2453806E+00,.3101120E+00,.3157807E+00,.1572649E+00,& - & .5518255E-01,.3048452E+00,.3825091E+00,.3929551E+00,.1981390E+00,& - & .7368328E-01,.3724217E+00,.4646897E+00,.4797945E+00,.2447415E+00,& - & .9652937E-01,.4480322E+00,.5576115E+00,.5757517E+00,.2972212E+00,& - & .2515607E-01,.1736587E+00,.2203553E+00,.2229593E+00,.1080693E+00,& - & .3453399E-01,.2219693E+00,.2815682E+00,.2859887E+00,.1409424E+00,& - & .4732652E-01,.2782830E+00,.3508111E+00,.3593155E+00,.1796231E+00,& - & .6419246E-01,.3427924E+00,.4290016E+00,.4424221E+00,.2240016E+00,& - & .8533710E-01,.4152474E+00,.5177134E+00,.5349045E+00,.2742416E+00,& - & .2108838E-01,.1557171E+00,.1978594E+00,.2004336E+00,.9577831E-01,& - & .2927578E-01,.2012690E+00,.2560716E+00,.2596510E+00,.1265930E+00,& - & .4069811E-01,.2546968E+00,.3225058E+00,.3293032E+00,.1632049E+00,& - & .5604639E-01,.3162711E+00,.3971951E+00,.4089321E+00,.2055380E+00,& - & .7561968E-01,.3858696E+00,.4819614E+00,.4980595E+00,.2536384E+00,& - & .1767518E-01,.1394513E+00,.1774120E+00,.1800232E+00,.8475686E-01,& - & .2479537E-01,.1824043E+00,.2325611E+00,.2356543E+00,.1136169E+00,& - & .3495024E-01,.2330902E+00,.2962474E+00,.3017090E+00,.1481769E+00,& - & .4886078E-01,.2917985E+00,.3678777E+00,.3778687E+00,.1885266E+00,& - & .6700377E-01,.3587323E+00,.4490277E+00,.4637480E+00,.2345858E+00,& - & .1476895E-01,.1243742E+00,.1583798E+00,.1609596E+00,.7459372E-01,& - & .2091694E-01,.1647602E+00,.2103847E+00,.2132485E+00,.1015375E+00,& - & .2988238E-01,.2127462E+00,.2712282E+00,.2756073E+00,.1340822E+00,& - & .4238686E-01,.2685463E+00,.3400097E+00,.3482087E+00,.1724055E+00,& - & .5904346E-01,.3326286E+00,.4175653E+00,.4306952E+00,.2164369E+00,& - & .1230374E-01,.1104196E+00,.1406329E+00,.1430549E+00,.6528664E-01,& - & .1757050E-01,.1482205E+00,.1894519E+00,.1922843E+00,.9031455E-01,& - & .2540539E-01,.1934889E+00,.2472646E+00,.2509359E+00,.1208463E+00,& - & .3658763E-01,.2464677E+00,.3133038E+00,.3198840E+00,.1571069E+00,& - & .5175125E-01,.3076675E+00,.3875310E+00,.3989625E+00,.1991350E+00,& - & .1033543E-01,.9851647E-01,.1254426E+00,.1276686E+00,.5744944E-01,& - & .1487034E-01,.1339448E+00,.1713721E+00,.1742024E+00,.8071988E-01,& - & .2174783E-01,.1768075E+00,.2263355E+00,.2295753E+00,.1094349E+00,& - & .3178517E-01,.2272599E+00,.2898005E+00,.2951977E+00,.1438116E+00,& - & .4561407E-01,.2857740E+00,.3612374E+00,.3710210E+00,.1839585E+00/ - - data absb(1051:1175, 8) / & - & .8709412E-02,.8794504E-01,.1119210E+00,.1139728E+00,.5066255E-01,& - & .1262413E-01,.1212030E+00,.1551537E+00,.1579143E+00,.7214590E-01,& - & .1865119E-01,.1616922E+00,.2072178E+00,.2102675E+00,.9913095E-01,& - & .2764278E-01,.2097406E+00,.2681310E+00,.2726069E+00,.1317209E+00,& - & .4023984E-01,.2656768E+00,.3370690E+00,.3452748E+00,.1700699E+00,& - & .7309742E-02,.7805313E-01,.9935397E-01,.1011896E+00,.4454450E-01,& - & .1068078E-01,.1092344E+00,.1398484E+00,.1424507E+00,.6420420E-01,& - & .1594110E-01,.1474371E+00,.1891070E+00,.1921023E+00,.8951479E-01,& - & .2393561E-01,.1930891E+00,.2473383E+00,.2511858E+00,.1203039E+00,& - & .3536639E-01,.2465547E+00,.3138627E+00,.3206321E+00,.1568422E+00,& - & .6111505E-02,.6882934E-01,.8775334E-01,.8932843E-01,.3912454E-01,& - & .9015756E-02,.9808206E-01,.1255190E+00,.1279049E+00,.5696209E-01,& - & .1357531E-01,.1339695E+00,.1719655E+00,.1749408E+00,.8050805E-01,& - & .2064520E-01,.1772958E+00,.2274651E+00,.2308615E+00,.1095380E+00,& - & .3095469E-01,.2282972E+00,.2914883E+00,.2970959E+00,.1442483E+00,& - & .5121725E-02,.6067687E-01,.7763361E-01,.7890932E-01,.3444819E-01,& - & .7639216E-02,.8816021E-01,.1127621E+00,.1149702E+00,.5070163E-01,& - & .1160557E-01,.1219458E+00,.1566131E+00,.1595297E+00,.7248142E-01,& - & .1786695E-01,.1630817E+00,.2094426E+00,.2126006E+00,.9988204E-01,& - & .2716600E-01,.2117945E+00,.2710344E+00,.2757215E+00,.1328837E+00,& - & .4599319E-02,.5738031E-01,.7361124E-01,.7479831E-01,.3257284E-01,& - & .6965718E-02,.8418710E-01,.1077301E+00,.1098721E+00,.4821784E-01,& - & .1072080E-01,.1171779E+00,.1505705E+00,.1534484E+00,.6933089E-01,& - & .1668801E-01,.1574612E+00,.2023452E+00,.2054613E+00,.9606507E-01,& - & .2561291E-01,.2052733E+00,.2629716E+00,.2673724E+00,.1283901E+00/ - - data absb( 1:175, 9) / & - & .1351800E+02,.1942600E+02,.2136800E+02,.2060700E+02,.1596700E+02,& - & .1324900E+02,.1927800E+02,.2134500E+02,.2072500E+02,.1621800E+02,& - & .1299100E+02,.1910600E+02,.2134400E+02,.2083800E+02,.1649300E+02,& - & .1278300E+02,.1895300E+02,.2133700E+02,.2095900E+02,.1676900E+02,& - & .1273500E+02,.1882000E+02,.2132800E+02,.2110400E+02,.1698200E+02,& - & .1150400E+02,.1753400E+02,.1945700E+02,.1913100E+02,.1462500E+02,& - & .1128100E+02,.1739600E+02,.1949100E+02,.1927100E+02,.1493900E+02,& - & .1111200E+02,.1729000E+02,.1952700E+02,.1941500E+02,.1525500E+02,& - & .1111500E+02,.1721300E+02,.1956000E+02,.1958000E+02,.1550400E+02,& - & .1134200E+02,.1713900E+02,.1961500E+02,.1975900E+02,.1570600E+02,& - & .9817000E+01,.1559900E+02,.1762700E+02,.1766600E+02,.1335400E+02,& - & .9674700E+01,.1553300E+02,.1769500E+02,.1784200E+02,.1368700E+02,& - & .9698400E+01,.1550200E+02,.1775500E+02,.1803600E+02,.1400400E+02,& - & .9952200E+01,.1548000E+02,.1782900E+02,.1823500E+02,.1426300E+02,& - & .1034400E+02,.1552500E+02,.1792900E+02,.1841800E+02,.1447500E+02,& - & .8433200E+01,.1380600E+02,.1592600E+02,.1621500E+02,.1222400E+02,& - & .8458300E+01,.1380500E+02,.1602100E+02,.1643700E+02,.1255600E+02,& - & .8706600E+01,.1382300E+02,.1610800E+02,.1666000E+02,.1283400E+02,& - & .9082700E+01,.1392400E+02,.1622600E+02,.1688300E+02,.1307800E+02,& - & .9526300E+01,.1415600E+02,.1638200E+02,.1707900E+02,.1333400E+02,& - & .7306800E+01,.1225200E+02,.1434100E+02,.1481000E+02,.1112900E+02,& - & .7529500E+01,.1229100E+02,.1446300E+02,.1505200E+02,.1143900E+02,& - & .7885300E+01,.1240500E+02,.1460600E+02,.1530900E+02,.1172900E+02,& - & .8304000E+01,.1264300E+02,.1477600E+02,.1554800E+02,.1200600E+02,& - & .8712300E+01,.1303900E+02,.1498200E+02,.1576200E+02,.1228600E+02,& - & .6428700E+01,.1093300E+02,.1287900E+02,.1345100E+02,.1005300E+02,& - & .6744600E+01,.1103900E+02,.1304100E+02,.1374000E+02,.1037700E+02,& - & .7127100E+01,.1126600E+02,.1322200E+02,.1401800E+02,.1069900E+02,& - & .7506700E+01,.1165000E+02,.1345500E+02,.1426300E+02,.1101100E+02,& - & .7879700E+01,.1214400E+02,.1376600E+02,.1451700E+02,.1132300E+02,& - & .5716500E+01,.9819800E+01,.1156300E+02,.1221000E+02,.9028700E+01,& - & .6050400E+01,.1003000E+02,.1175900E+02,.1251100E+02,.9377100E+01,& - & .6387200E+01,.1039000E+02,.1200400E+02,.1278700E+02,.9738200E+01,& - & .6726200E+01,.1085800E+02,.1232500E+02,.1307100E+02,.1010000E+02,& - & .7063000E+01,.1139600E+02,.1272000E+02,.1337100E+02,.1043300E+02/ - - data absb(176:350, 9) / & - & .5107700E+01,.8868000E+01,.1041500E+02,.1105300E+02,.8096300E+01,& - & .5401700E+01,.9210700E+01,.1066200E+02,.1136100E+02,.8475800E+01,& - & .5701500E+01,.9669800E+01,.1098200E+02,.1166800E+02,.8848100E+01,& - & .6004100E+01,.1019600E+02,.1138400E+02,.1200000E+02,.9237600E+01,& - & .6310600E+01,.1073200E+02,.1188400E+02,.1234900E+02,.9625500E+01,& - & .4541400E+01,.8084100E+01,.9433300E+01,.1000100E+02,.7298700E+01,& - & .4806000E+01,.8516900E+01,.9739900E+01,.1032400E+02,.7679900E+01,& - & .5075400E+01,.9031100E+01,.1013400E+02,.1067300E+02,.8069200E+01,& - & .5348900E+01,.9566000E+01,.1062600E+02,.1104600E+02,.8467100E+01,& - & .5622600E+01,.1010000E+02,.1118800E+02,.1146700E+02,.8887800E+01,& - & .4051200E+01,.7453700E+01,.8611300E+01,.9076000E+01,.6640600E+01,& - & .4286100E+01,.7945500E+01,.8998800E+01,.9432600E+01,.7029800E+01,& - & .4528400E+01,.8472300E+01,.9480600E+01,.9828200E+01,.7436500E+01,& - & .4776500E+01,.9002200E+01,.1003600E+02,.1026700E+02,.7853000E+01,& - & .5027300E+01,.9537500E+01,.1064400E+02,.1076200E+02,.8292500E+01,& - & .3627200E+01,.6934500E+01,.7929200E+01,.8282100E+01,.6086200E+01,& - & .3832400E+01,.7441200E+01,.8405800E+01,.8677900E+01,.6481400E+01,& - & .4049600E+01,.7955600E+01,.8949700E+01,.9127700E+01,.6903100E+01,& - & .4273600E+01,.8488100E+01,.9551200E+01,.9635300E+01,.7342300E+01,& - & .4500800E+01,.9023100E+01,.1019900E+02,.1019600E+02,.7810700E+01,& - & .3261700E+01,.6492700E+01,.7381400E+01,.7620400E+01,.5635100E+01,& - & .3445500E+01,.6986400E+01,.7914600E+01,.8066800E+01,.6048200E+01,& - & .3637500E+01,.7498200E+01,.8512400E+01,.8568800E+01,.6479300E+01,& - & .3836100E+01,.8025300E+01,.9153000E+01,.9138400E+01,.6948800E+01,& - & .4043400E+01,.8577000E+01,.9824900E+01,.9770100E+01,.7439200E+01,& - & .2950400E+01,.6099600E+01,.6937800E+01,.7093300E+01,.5269600E+01,& - & .3113400E+01,.6585900E+01,.7519300E+01,.7587400E+01,.5690800E+01,& - & .3285000E+01,.7099100E+01,.8158300E+01,.8145500E+01,.6150400E+01,& - & .3463900E+01,.7635700E+01,.8828900E+01,.8776600E+01,.6639100E+01,& - & .3657500E+01,.8203100E+01,.9533500E+01,.9472800E+01,.7118100E+01,& - & .2678500E+01,.5759200E+01,.6594400E+01,.6679300E+01,.4965900E+01,& - & .2830300E+01,.6251200E+01,.7218000E+01,.7229200E+01,.5415800E+01,& - & .2984500E+01,.6770000E+01,.7885300E+01,.7851700E+01,.5892900E+01,& - & .3149800E+01,.7321800E+01,.8589200E+01,.8540500E+01,.6377900E+01,& - & .3336500E+01,.7909500E+01,.9326000E+01,.9287600E+01,.6859300E+01/ - - data absb(351:525, 9) / & - & .2438100E+01,.5471900E+01,.6329600E+01,.6369900E+01,.4737800E+01,& - & .2583300E+01,.5970600E+01,.6983900E+01,.6980900E+01,.5202400E+01,& - & .2727600E+01,.6503200E+01,.7682300E+01,.7662300E+01,.5684900E+01,& - & .2884300E+01,.7076800E+01,.8422300E+01,.8397300E+01,.6161300E+01,& - & .3077600E+01,.7683700E+01,.9192900E+01,.9187100E+01,.6669700E+01,& - & .2223800E+01,.5236600E+01,.6133500E+01,.6157400E+01,.4570500E+01,& - & .2364800E+01,.5745100E+01,.6815100E+01,.6826600E+01,.5034700E+01,& - & .2506700E+01,.6298000E+01,.7546000E+01,.7554800E+01,.5506400E+01,& - & .2668000E+01,.6893000E+01,.8322300E+01,.8330800E+01,.6010300E+01,& - & .2876300E+01,.7523400E+01,.9126900E+01,.9154700E+01,.6544300E+01,& - & .2034300E+01,.5054000E+01,.6002100E+01,.6036000E+01,.4430600E+01,& - & .2173200E+01,.5578500E+01,.6713400E+01,.6754400E+01,.4892400E+01,& - & .2321700E+01,.6155400E+01,.7482800E+01,.7521700E+01,.5389900E+01,& - & .2499100E+01,.6772700E+01,.8294300E+01,.8334100E+01,.5921100E+01,& - & .2729800E+01,.7430900E+01,.9129400E+01,.9187700E+01,.6477600E+01,& - & .1867800E+01,.4920300E+01,.5929100E+01,.5987500E+01,.4320400E+01,& - & .2010200E+01,.5466700E+01,.6674700E+01,.6743000E+01,.4802600E+01,& - & .2171900E+01,.6068200E+01,.7482700E+01,.7547700E+01,.5328100E+01,& - & .2372000E+01,.6712600E+01,.8325200E+01,.8391000E+01,.5882600E+01,& - & .2626400E+01,.7397700E+01,.9187000E+01,.9272300E+01,.6459800E+01,& - & .1724400E+01,.4837000E+01,.5915600E+01,.6000100E+01,.4255500E+01,& - & .1875500E+01,.5410700E+01,.6699900E+01,.6790400E+01,.4764400E+01,& - & .2057300E+01,.6036300E+01,.7540200E+01,.7627400E+01,.5315500E+01,& - & .2282900E+01,.6709400E+01,.8407900E+01,.8496200E+01,.5890100E+01,& - & .2559000E+01,.7419500E+01,.9290900E+01,.9399400E+01,.6487100E+01,& - & .1606900E+01,.4803000E+01,.5957900E+01,.6063900E+01,.4235600E+01,& - & .1770500E+01,.5403700E+01,.6778800E+01,.6887400E+01,.4771200E+01,& - & .1974200E+01,.6057400E+01,.7644800E+01,.7749100E+01,.5343400E+01,& - & .2224700E+01,.6756000E+01,.8531000E+01,.8638500E+01,.5938100E+01,& - & .2523800E+01,.7488000E+01,.9429200E+01,.9557000E+01,.6549700E+01,& - & .1512800E+01,.4814000E+01,.6050100E+01,.6171400E+01,.4255000E+01,& - & .1694600E+01,.5441700E+01,.6900000E+01,.7021200E+01,.4815500E+01,& - & .1920600E+01,.6121300E+01,.7783900E+01,.7902000E+01,.5406900E+01,& - & .2194600E+01,.6842200E+01,.8682700E+01,.8807500E+01,.6016900E+01,& - & .2517300E+01,.7591300E+01,.9592400E+01,.9737300E+01,.6639800E+01/ - - data absb(526:700, 9) / & - & .1435600E+01,.4841800E+01,.6149500E+01,.6282800E+01,.4289600E+01,& - & .1635700E+01,.5493500E+01,.7018400E+01,.7151600E+01,.4869100E+01,& - & .1883800E+01,.6195700E+01,.7915100E+01,.8045700E+01,.5474200E+01,& - & .2178800E+01,.6932500E+01,.8825600E+01,.8964300E+01,.6095600E+01,& - & .2523800E+01,.7693000E+01,.9743900E+01,.9902100E+01,.6726400E+01,& - & .1362000E+01,.4840000E+01,.6191100E+01,.6334100E+01,.4295000E+01,& - & .1576500E+01,.5507700E+01,.7071700E+01,.7214900E+01,.4887200E+01,& - & .1841600E+01,.6223800E+01,.7977800E+01,.8117300E+01,.5501400E+01,& - & .2152800E+01,.6969400E+01,.8895100E+01,.9043000E+01,.6130400E+01,& - & .2513500E+01,.7737000E+01,.9819100E+01,.9986500E+01,.6766200E+01,& - & .1283600E+01,.4789200E+01,.6154900E+01,.6305000E+01,.4254000E+01,& - & .1507000E+01,.5464900E+01,.7041600E+01,.7192300E+01,.4853600E+01,& - & .1783000E+01,.6187200E+01,.7953100E+01,.8099400E+01,.5473400E+01,& - & .2105500E+01,.6936900E+01,.8874500E+01,.9028800E+01,.6106600E+01,& - & .2475400E+01,.7709000E+01,.9802300E+01,.9975900E+01,.6745900E+01,& - & .1187800E+01,.4654100E+01,.5997500E+01,.6153100E+01,.4135700E+01,& - & .1411400E+01,.5327900E+01,.6883600E+01,.7040700E+01,.4736600E+01,& - & .1690700E+01,.6048800E+01,.7796100E+01,.7949200E+01,.5358700E+01,& - & .2017100E+01,.6798700E+01,.8721400E+01,.8878200E+01,.5993100E+01,& - & .2387900E+01,.7572100E+01,.9650500E+01,.9826300E+01,.6634600E+01,& - & .1101900E+01,.4524100E+01,.5841100E+01,.6001500E+01,.4020600E+01,& - & .1324000E+01,.5193800E+01,.6724800E+01,.6888100E+01,.4621500E+01,& - & .1605000E+01,.5912700E+01,.7637700E+01,.7796900E+01,.5244400E+01,& - & .1934400E+01,.6661400E+01,.8565600E+01,.8724100E+01,.5879700E+01,& - & .2305300E+01,.7435200E+01,.9496100E+01,.9673000E+01,.6523200E+01,& - & .1026100E+01,.4403500E+01,.5692500E+01,.5857100E+01,.3913000E+01,& - & .1245800E+01,.5069400E+01,.6573500E+01,.6741100E+01,.4513000E+01,& - & .1528100E+01,.5784400E+01,.7485300E+01,.7649700E+01,.5135300E+01,& - & .1859000E+01,.6531000E+01,.8413900E+01,.8575200E+01,.5771100E+01,& - & .2229600E+01,.7303100E+01,.9346100E+01,.9523300E+01,.6415500E+01,& - & .9402000E+00,.4225200E+01,.5461800E+01,.5630500E+01,.3751400E+01,& - & .1151000E+01,.4880800E+01,.6335900E+01,.6505100E+01,.4346400E+01,& - & .1426700E+01,.5586500E+01,.7242900E+01,.7411600E+01,.4965900E+01,& - & .1753400E+01,.6328400E+01,.8170600E+01,.8334600E+01,.5600400E+01,& - & .2119600E+01,.7095400E+01,.9103800E+01,.9279000E+01,.6244300E+01/ - - data absb(701:875, 9) / & - & .8612900E+00,.4045700E+01,.5226400E+01,.5397600E+01,.3587900E+01,& - & .1063300E+01,.4691500E+01,.6092400E+01,.6263500E+01,.4176800E+01,& - & .1328300E+01,.5384500E+01,.6992600E+01,.7164900E+01,.4792100E+01,& - & .1648500E+01,.6120100E+01,.7917500E+01,.8084400E+01,.5424000E+01,& - & .2009300E+01,.6881200E+01,.8852200E+01,.9024900E+01,.6066800E+01,& - & .7912300E+00,.3873500E+01,.4996000E+01,.5169900E+01,.3428700E+01,& - & .9829500E+00,.4507200E+01,.5853300E+01,.6025400E+01,.4010900E+01,& - & .1236400E+01,.5187600E+01,.6745900E+01,.6921400E+01,.4621200E+01,& - & .1548400E+01,.5915000E+01,.7666500E+01,.7837300E+01,.5250300E+01,& - & .1902600E+01,.6671600E+01,.8601800E+01,.8772800E+01,.5891500E+01,& - & .7198400E+00,.3672900E+01,.4723500E+01,.4897500E+01,.3239700E+01,& - & .8980800E+00,.4291600E+01,.5569700E+01,.5744300E+01,.3815300E+01,& - & .1136000E+01,.4957400E+01,.6451900E+01,.6628900E+01,.4418400E+01,& - & .1434500E+01,.5672800E+01,.7366000E+01,.7541000E+01,.5043700E+01,& - & .1779300E+01,.6422800E+01,.8299900E+01,.8470500E+01,.5682300E+01,& - & .6528500E+00,.3466700E+01,.4437200E+01,.4608200E+01,.3039900E+01,& - & .8165700E+00,.4067400E+01,.5270100E+01,.5446600E+01,.3609400E+01,& - & .1037000E+01,.4717100E+01,.6140500E+01,.6317500E+01,.4203800E+01,& - & .1319400E+01,.5418400E+01,.7047300E+01,.7224800E+01,.4823700E+01,& - & .1651400E+01,.6158400E+01,.7976000E+01,.8147700E+01,.5458100E+01,& - & .5932400E+00,.3268700E+01,.4161000E+01,.4327000E+01,.2843700E+01,& - & .7429200E+00,.3850200E+01,.4975400E+01,.5152500E+01,.3408100E+01,& - & .9460600E+00,.4483800E+01,.5834700E+01,.6011200E+01,.3993200E+01,& - & .1210300E+01,.5169100E+01,.6731200E+01,.6911300E+01,.4606300E+01,& - & .1528300E+01,.5897000E+01,.7652900E+01,.7828300E+01,.5236500E+01,& - & .5366500E+00,.3066500E+01,.3878800E+01,.4034400E+01,.2639600E+01,& - & .6732600E+00,.3627500E+01,.4668500E+01,.4844500E+01,.3197000E+01,& - & .8596400E+00,.4245000E+01,.5516100E+01,.5694000E+01,.3774200E+01,& - & .1102600E+01,.4911200E+01,.6399200E+01,.6579500E+01,.4378500E+01,& - & .1403000E+01,.5624700E+01,.7312800E+01,.7491800E+01,.5003700E+01,& - & .4796500E+00,.2851200E+01,.3577300E+01,.3719000E+01,.2417900E+01,& - & .6049900E+00,.3389500E+01,.4335300E+01,.4507000E+01,.2965300E+01,& - & .7721100E+00,.3985700E+01,.5165600E+01,.5343900E+01,.3534600E+01,& - & .9928000E+00,.4632000E+01,.6034600E+01,.6213800E+01,.4127800E+01,& - & .1271100E+01,.5327200E+01,.6937700E+01,.7118900E+01,.4746400E+01/ - - data absb(876:1050, 9) / & - & .4265100E+00,.2644500E+01,.3289400E+01,.3414800E+01,.2203300E+01,& - & .5438800E+00,.3161100E+01,.4016100E+01,.4179100E+01,.2737300E+01,& - & .6936800E+00,.3734700E+01,.4820600E+01,.4998900E+01,.3299700E+01,& - & .8927900E+00,.4362000E+01,.5676700E+01,.5855400E+01,.3882200E+01,& - & .1148400E+01,.5036900E+01,.6566800E+01,.6749500E+01,.4491800E+01,& - & .3771300E+00,.2443900E+01,.3016000E+01,.3120600E+01,.1997600E+01,& - & .4876600E+00,.2943400E+01,.3710400E+01,.3859900E+01,.2514300E+01,& - & .6240700E+00,.3493900E+01,.4484700E+01,.4659600E+01,.3068000E+01,& - & .8029800E+00,.4100600E+01,.5325500E+01,.5504900E+01,.3641300E+01,& - & .1035300E+01,.4755400E+01,.6201000E+01,.6382000E+01,.4240700E+01,& - & .3333400E+00,.2257300E+01,.2773000E+01,.2853700E+01,.1814100E+01,& - & .4382400E+00,.2747700E+01,.3435900E+01,.3571200E+01,.2311200E+01,& - & .5655500E+00,.3276700E+01,.4180700E+01,.4349700E+01,.2854000E+01,& - & .7266200E+00,.3863100E+01,.5000300E+01,.5179800E+01,.3420600E+01,& - & .9381100E+00,.4499800E+01,.5863500E+01,.6043300E+01,.4009200E+01,& - & .2934400E+00,.2079200E+01,.2549300E+01,.2604500E+01,.1644700E+01,& - & .3932000E+00,.2563300E+01,.3181100E+01,.3299600E+01,.2120200E+01,& - & .5133500E+00,.3073900E+01,.3896800E+01,.4055400E+01,.2649300E+01,& - & .6599100E+00,.3639600E+01,.4691000E+01,.4869200E+01,.3209500E+01,& - & .8530500E+00,.4260200E+01,.5542800E+01,.5722700E+01,.3789000E+01,& - & .2563400E+00,.1906500E+01,.2337300E+01,.2367500E+01,.1484900E+01,& - & .3508500E+00,.2383200E+01,.2938000E+01,.3036300E+01,.1937900E+01,& - & .4646300E+00,.2880600E+01,.3624500E+01,.3770500E+01,.2449900E+01,& - & .6001400E+00,.3424700E+01,.4390100E+01,.4564400E+01,.3001300E+01,& - & .7750200E+00,.4026800E+01,.5226400E+01,.5406400E+01,.3572900E+01,& - & .2219800E+00,.1738200E+01,.2135500E+01,.2144300E+01,.1332100E+01,& - & .3108800E+00,.2203700E+01,.2707000E+01,.2780900E+01,.1763100E+01,& - & .4186800E+00,.2693700E+01,.3362800E+01,.3493700E+01,.2255100E+01,& - & .5459000E+00,.3217200E+01,.4099400E+01,.4266900E+01,.2795000E+01,& - & .7038200E+00,.3799300E+01,.4913400E+01,.5093400E+01,.3360900E+01,& - & .1927900E+00,.1588400E+01,.1957600E+01,.1951600E+01,.1199100E+01,& - & .2761400E+00,.2042300E+01,.2505300E+01,.2555900E+01,.1610600E+01,& - & .3790000E+00,.2526400E+01,.3132300E+01,.3247300E+01,.2082500E+01,& - & .4995400E+00,.3034400E+01,.3842500E+01,.3999400E+01,.2609000E+01,& - & .6448300E+00,.3596700E+01,.4632000E+01,.4810400E+01,.3168300E+01/ - - data absb(1051:1175, 9) / & - & .1675200E+00,.1450600E+01,.1792400E+01,.1778000E+01,.1076600E+01,& - & .2454600E+00,.1892400E+01,.2321500E+01,.2350200E+01,.1471800E+01,& - & .3428200E+00,.2368600E+01,.2920300E+01,.3017100E+01,.1923800E+01,& - & .4575100E+00,.2865700E+01,.3604800E+01,.3750400E+01,.2434700E+01,& - & .5934500E+00,.3409100E+01,.4369200E+01,.4543600E+01,.2986000E+01,& - & .1444200E+00,.1319100E+01,.1630700E+01,.1615800E+01,.9596600E+00,& - & .2162900E+00,.1745600E+01,.2145400E+01,.2155300E+01,.1338400E+01,& - & .3083800E+00,.2211700E+01,.2718400E+01,.2793900E+01,.1771000E+01,& - & .4178000E+00,.2702400E+01,.3376100E+01,.3508300E+01,.2264700E+01,& - & .5463300E+00,.3227700E+01,.4115300E+01,.4283500E+01,.2805700E+01,& - & .1236900E+00,.1194200E+01,.1475100E+01,.1466000E+01,.8479400E+00,& - & .1894300E+00,.1602500E+01,.1975200E+01,.1970600E+01,.1210400E+01,& - & .2758000E+00,.2057700E+01,.2525300E+01,.2578500E+01,.1624900E+01,& - & .3801500E+00,.2542500E+01,.3155400E+01,.3272400E+01,.2099500E+01,& - & .5022000E+00,.3052800E+01,.3869400E+01,.4027500E+01,.2627900E+01,& - & .1061900E+00,.1081500E+01,.1333800E+01,.1334000E+01,.7492400E+00,& - & .1658600E+00,.1471300E+01,.1818300E+01,.1804700E+01,.1093300E+01,& - & .2466800E+00,.1915000E+01,.2349800E+01,.2382400E+01,.1493100E+01,& - & .3461300E+00,.2393600E+01,.2954200E+01,.3054500E+01,.1948900E+01,& - & .4625100E+00,.2892800E+01,.3643900E+01,.3791400E+01,.2462800E+01,& - & .9878100E-01,.1037400E+01,.1279000E+01,.1283400E+01,.7109100E+00,& - & .1564300E+00,.1419900E+01,.1756000E+01,.1740600E+01,.1047500E+01,& - & .2351200E+00,.1858500E+01,.2281500E+01,.2306100E+01,.1440800E+01,& - & .3325000E+00,.2333800E+01,.2875500E+01,.2968600E+01,.1889800E+01,& - & .4469700E+00,.2829800E+01,.3555500E+01,.3698400E+01,.2397500E+01/ - - data absb( 1:175,10) / & - & .5148311E+02,.5413939E+02,.5702358E+02,.5255781E+02,.4767175E+02,& - & .5089809E+02,.5366563E+02,.5690094E+02,.5278229E+02,.4816697E+02,& - & .5028687E+02,.5319767E+02,.5674627E+02,.5298787E+02,.4858275E+02,& - & .4966788E+02,.5270972E+02,.5651558E+02,.5315507E+02,.4895540E+02,& - & .4904266E+02,.5220812E+02,.5626701E+02,.5327637E+02,.4934862E+02,& - & .4695357E+02,.5244112E+02,.5623255E+02,.5228165E+02,.4528190E+02,& - & .4636862E+02,.5203478E+02,.5620209E+02,.5261290E+02,.4583339E+02,& - & .4578848E+02,.5161094E+02,.5610019E+02,.5291867E+02,.4633999E+02,& - & .4522091E+02,.5118237E+02,.5596404E+02,.5316078E+02,.4686589E+02,& - & .4464656E+02,.5075226E+02,.5579719E+02,.5336823E+02,.4742733E+02,& - & .4214601E+02,.5023928E+02,.5465620E+02,.5137721E+02,.4265810E+02,& - & .4159514E+02,.4989728E+02,.5473059E+02,.5180612E+02,.4330876E+02,& - & .4107738E+02,.4954386E+02,.5475515E+02,.5218532E+02,.4396773E+02,& - & .4057407E+02,.4919951E+02,.5475077E+02,.5253512E+02,.4466305E+02,& - & .4017621E+02,.4885046E+02,.5474194E+02,.5287718E+02,.4535369E+02,& - & .3729887E+02,.4762187E+02,.5248346E+02,.4992379E+02,.3996857E+02,& - & .3682707E+02,.4735522E+02,.5268439E+02,.5045155E+02,.4074890E+02,& - & .3639654E+02,.4710649E+02,.5286499E+02,.5096814E+02,.4156839E+02,& - & .3608349E+02,.4686360E+02,.5304363E+02,.5147530E+02,.4241003E+02,& - & .3594030E+02,.4664103E+02,.5320927E+02,.5198934E+02,.4322855E+02,& - & .3267085E+02,.4471454E+02,.4990144E+02,.4806389E+02,.3737273E+02,& - & .3229921E+02,.4458748E+02,.5027045E+02,.4875782E+02,.3829531E+02,& - & .3205109E+02,.4447599E+02,.5065142E+02,.4944055E+02,.3925216E+02,& - & .3198556E+02,.4439449E+02,.5103374E+02,.5013485E+02,.4020794E+02,& - & .3212562E+02,.4431957E+02,.5139858E+02,.5083922E+02,.4116103E+02,& - & .2840862E+02,.4164567E+02,.4712876E+02,.4597745E+02,.3496902E+02,& - & .2819485E+02,.4169424E+02,.4770395E+02,.4685191E+02,.3600935E+02,& - & .2816868E+02,.4176226E+02,.4829256E+02,.4773086E+02,.3708676E+02,& - & .2836998E+02,.4184080E+02,.4888393E+02,.4862950E+02,.3815932E+02,& - & .2876609E+02,.4198837E+02,.4946530E+02,.4954016E+02,.3924359E+02,& - & .2458838E+02,.3854886E+02,.4433510E+02,.4378221E+02,.3278158E+02,& - & .2458406E+02,.3879353E+02,.4511982E+02,.4485465E+02,.3393561E+02,& - & .2481011E+02,.3904687E+02,.4591165E+02,.4596040E+02,.3509830E+02,& - & .2524181E+02,.3936718E+02,.4670940E+02,.4707856E+02,.3628077E+02,& - & .2588043E+02,.3975083E+02,.4751106E+02,.4819091E+02,.3749205E+02/ - - data absb(176:350,10) / & - & .2128943E+02,.3559835E+02,.4162163E+02,.4164333E+02,.3082318E+02,& - & .2150537E+02,.3602723E+02,.4259734E+02,.4292976E+02,.3205684E+02,& - & .2193801E+02,.3650531E+02,.4361086E+02,.4425346E+02,.3332155E+02,& - & .2259310E+02,.3706210E+02,.4463171E+02,.4558654E+02,.3461692E+02,& - & .2342964E+02,.3772964E+02,.4566117E+02,.4688864E+02,.3593171E+02,& - & .1852062E+02,.3287436E+02,.3903572E+02,.3964314E+02,.2907608E+02,& - & .1891782E+02,.3350332E+02,.4024543E+02,.4114241E+02,.3039091E+02,& - & .1954091E+02,.3421519E+02,.4148282E+02,.4268352E+02,.3174986E+02,& - & .2036981E+02,.3502995E+02,.4273744E+02,.4421574E+02,.3314916E+02,& - & .2138764E+02,.3596408E+02,.4400706E+02,.4569955E+02,.3457774E+02,& - & .1624714E+02,.3047658E+02,.3680690E+02,.3795944E+02,.2761997E+02,& - & .1682346E+02,.3133476E+02,.3822752E+02,.3967654E+02,.2904446E+02,& - & .1761414E+02,.3229856E+02,.3969010E+02,.4139802E+02,.3050220E+02,& - & .1860843E+02,.3338503E+02,.4119523E+02,.4312030E+02,.3200324E+02,& - & .1979142E+02,.3455683E+02,.4269211E+02,.4477201E+02,.3355101E+02,& - & .1441593E+02,.2844847E+02,.3488725E+02,.3654168E+02,.2639799E+02,& - & .1513627E+02,.2951628E+02,.3652960E+02,.3844842E+02,.2793035E+02,& - & .1607257E+02,.3073671E+02,.3822881E+02,.4036376E+02,.2949013E+02,& - & .1721158E+02,.3204955E+02,.3993969E+02,.4224228E+02,.3109975E+02,& - & .1853506E+02,.3344658E+02,.4166331E+02,.4405921E+02,.3276077E+02,& - & .1295279E+02,.2677411E+02,.3332381E+02,.3540024E+02,.2541395E+02,& - & .1380491E+02,.2807574E+02,.3519465E+02,.3748808E+02,.2704929E+02,& - & .1487470E+02,.2950308E+02,.3708718E+02,.3957763E+02,.2871542E+02,& - & .1613680E+02,.3102968E+02,.3900635E+02,.4159900E+02,.3042625E+02,& - & .1756668E+02,.3261608E+02,.4093414E+02,.4356179E+02,.3219685E+02,& - & .1181308E+02,.2545547E+02,.3213568E+02,.3454579E+02,.2465802E+02,& - & .1278415E+02,.2697292E+02,.3418991E+02,.3680560E+02,.2639551E+02,& - & .1396046E+02,.2859206E+02,.3627615E+02,.3903520E+02,.2816396E+02,& - & .1530966E+02,.3030034E+02,.3838513E+02,.4119274E+02,.2998441E+02,& - & .1680246E+02,.3204287E+02,.4046635E+02,.4326902E+02,.3183828E+02,& - & .1095745E+02,.2448401E+02,.3130388E+02,.3400597E+02,.2413910E+02,& - & .1202575E+02,.2618548E+02,.3353135E+02,.3640460E+02,.2597275E+02,& - & .1327161E+02,.2798353E+02,.3579506E+02,.3875055E+02,.2784255E+02,& - & .1467686E+02,.2984441E+02,.3805097E+02,.4101420E+02,.2975816E+02,& - & .1623812E+02,.3172488E+02,.4025111E+02,.4318326E+02,.3168296E+02/ - - data absb(351:525,10) / & - & .1031026E+02,.2379955E+02,.3077002E+02,.3371001E+02,.2381408E+02,& - & .1143882E+02,.2566958E+02,.3315826E+02,.3621895E+02,.2574289E+02,& - & .1273674E+02,.2762295E+02,.3556863E+02,.3865824E+02,.2770335E+02,& - & .1420938E+02,.2960954E+02,.3792581E+02,.4100632E+02,.2969115E+02,& - & .1584019E+02,.3161041E+02,.4022388E+02,.4324073E+02,.3167330E+02,& - & .9809660E+01,.2337401E+02,.3050021E+02,.3361805E+02,.2366649E+02,& - & .1099292E+02,.2539109E+02,.3302281E+02,.3621280E+02,.2568000E+02,& - & .1234898E+02,.2746966E+02,.3553468E+02,.3873037E+02,.2771661E+02,& - & .1389015E+02,.2956157E+02,.3797616E+02,.4114283E+02,.2975703E+02,& - & .1559986E+02,.3165438E+02,.4034450E+02,.4341423E+02,.3178583E+02,& - & .9444252E+01,.2318083E+02,.3046927E+02,.3371915E+02,.2368071E+02,& - & .1068902E+02,.2532385E+02,.3309721E+02,.3637816E+02,.2576903E+02,& - & .1210865E+02,.2749920E+02,.3567757E+02,.3895396E+02,.2786288E+02,& - & .1372527E+02,.2967804E+02,.3817975E+02,.4140126E+02,.2994365E+02,& - & .1551148E+02,.3183065E+02,.4058662E+02,.4368854E+02,.3200806E+02,& - & .9197704E+01,.2317475E+02,.3061830E+02,.3396112E+02,.2382472E+02,& - & .1050749E+02,.2541270E+02,.3332073E+02,.3667202E+02,.2597119E+02,& - & .1200173E+02,.2766533E+02,.3594813E+02,.3928170E+02,.2810254E+02,& - & .1369150E+02,.2990848E+02,.3849061E+02,.4174119E+02,.3021392E+02,& - & .1554967E+02,.3210113E+02,.4091548E+02,.4403004E+02,.3230534E+02,& - & .9070152E+01,.2333358E+02,.3092333E+02,.3432849E+02,.2408369E+02,& - & .1044943E+02,.2564057E+02,.3366988E+02,.3707300E+02,.2627089E+02,& - & .1201766E+02,.2795335E+02,.3632847E+02,.3969279E+02,.2842654E+02,& - & .1377594E+02,.3023853E+02,.3888979E+02,.4215285E+02,.3056150E+02,& - & .1570981E+02,.3246011E+02,.4132215E+02,.4443246E+02,.3266580E+02,& - & .9050881E+01,.2361502E+02,.3134148E+02,.3479389E+02,.2443447E+02,& - & .1049856E+02,.2597874E+02,.3411303E+02,.3755332E+02,.2664478E+02,& - & .1213853E+02,.2833372E+02,.3679073E+02,.4016895E+02,.2881882E+02,& - & .1396914E+02,.3064406E+02,.3935900E+02,.4261289E+02,.3096497E+02,& - & .1597202E+02,.3287736E+02,.4178044E+02,.4487584E+02,.3307507E+02,& - & .9121485E+01,.2399340E+02,.3184110E+02,.3533107E+02,.2484905E+02,& - & .1063898E+02,.2639662E+02,.3462510E+02,.3808849E+02,.2707110E+02,& - & .1235080E+02,.2877918E+02,.3730856E+02,.4068584E+02,.2925606E+02,& - & .1425215E+02,.3109959E+02,.3987030E+02,.4310628E+02,.3140551E+02,& - & .1631751E+02,.3333996E+02,.4227596E+02,.4534660E+02,.3351854E+02/ - - data absb(526:700,10) / & - & .9221530E+01,.2435543E+02,.3229891E+02,.3581316E+02,.2522887E+02,& - & .1079853E+02,.2679042E+02,.3509314E+02,.3856585E+02,.2745675E+02,& - & .1257368E+02,.2918513E+02,.3777390E+02,.4114200E+02,.2964790E+02,& - & .1453244E+02,.3151030E+02,.4032236E+02,.4354185E+02,.3180140E+02,& - & .1664739E+02,.3375272E+02,.4271105E+02,.4575694E+02,.3391150E+02,& - & .9234921E+01,.2453098E+02,.3252381E+02,.3605734E+02,.2542131E+02,& - & .1085339E+02,.2698432E+02,.3532561E+02,.3880579E+02,.2765412E+02,& - & .1266775E+02,.2939222E+02,.3801034E+02,.4137794E+02,.2985073E+02,& - & .1466294E+02,.3172547E+02,.4055737E+02,.4377010E+02,.3200723E+02,& - & .1680944E+02,.3397153E+02,.4293979E+02,.4597565E+02,.3411921E+02,& - & .9122231E+01,.2446628E+02,.3246758E+02,.3601819E+02,.2538766E+02,& - & .1075904E+02,.2694105E+02,.3528642E+02,.3878018E+02,.2762932E+02,& - & .1258935E+02,.2936114E+02,.3798364E+02,.4136006E+02,.2983193E+02,& - & .1459875E+02,.3170547E+02,.4053737E+02,.4375979E+02,.3199342E+02,& - & .1675964E+02,.3396515E+02,.4293329E+02,.4597404E+02,.3411195E+02,& - & .8803526E+01,.2404740E+02,.3199538E+02,.3556585E+02,.2502152E+02,& - & .1042899E+02,.2653898E+02,.3484146E+02,.3835958E+02,.2727937E+02,& - & .1224422E+02,.2898189E+02,.3757031E+02,.4097542E+02,.2949406E+02,& - & .1424127E+02,.3135230E+02,.4015581E+02,.4341193E+02,.3166878E+02,& - & .1639118E+02,.3362956E+02,.4258239E+02,.4565679E+02,.3379358E+02,& - & .8495800E+01,.2362002E+02,.3150999E+02,.3509681E+02,.2464648E+02,& - & .1010745E+02,.2612626E+02,.3438400E+02,.3792281E+02,.2691822E+02,& - & .1190476E+02,.2858932E+02,.3713908E+02,.4057067E+02,.2914314E+02,& - & .1388319E+02,.3098024E+02,.3975563E+02,.4304137E+02,.3132741E+02,& - & .1601937E+02,.3327847E+02,.4221299E+02,.4532208E+02,.3346428E+02,& - & .8209035E+01,.2320772E+02,.3103726E+02,.3463708E+02,.2427972E+02,& - & .9807919E+01,.2572338E+02,.3393496E+02,.3749067E+02,.2656635E+02,& - & .1158465E+02,.2820687E+02,.3671655E+02,.4017333E+02,.2879950E+02,& - & .1354242E+02,.3061364E+02,.3936092E+02,.4267581E+02,.3099415E+02,& - & .1566241E+02,.3293272E+02,.4184735E+02,.4498926E+02,.3314168E+02,& - & .7784536E+01,.2254512E+02,.3026965E+02,.3388321E+02,.2367971E+02,& - & .9354919E+01,.2507029E+02,.3319736E+02,.3677442E+02,.2598726E+02,& - & .1108920E+02,.2757544E+02,.3601743E+02,.3950998E+02,.2823588E+02,& - & .1300857E+02,.3000630E+02,.3870211E+02,.4206119E+02,.3044264E+02,& - & .1509523E+02,.3235435E+02,.4123355E+02,.4442692E+02,.3260463E+02/ - - data absb(701:875,10) / & - & .7359863E+01,.2185814E+02,.2946589E+02,.3308961E+02,.2305342E+02,& - & .8903128E+01,.2438939E+02,.3241822E+02,.3601163E+02,.2537863E+02,& - & .1058971E+02,.2690897E+02,.3527629E+02,.3879993E+02,.2764129E+02,& - & .1246583E+02,.2936503E+02,.3800506E+02,.4140154E+02,.2986144E+02,& - & .1451513E+02,.3174374E+02,.4058041E+02,.4382112E+02,.3203789E+02,& - & .6956382E+01,.2118043E+02,.2866324E+02,.3229115E+02,.2242833E+02,& - & .8461548E+01,.2370968E+02,.3163712E+02,.3524703E+02,.2476677E+02,& - & .1010795E+02,.2624061E+02,.3452870E+02,.3808268E+02,.2704785E+02,& - & .1193898E+02,.2872275E+02,.3729875E+02,.4073465E+02,.2928035E+02,& - & .1394781E+02,.3112498E+02,.3991541E+02,.4320304E+02,.3147062E+02,& - & .6487545E+01,.2036428E+02,.2769057E+02,.3132006E+02,.2167153E+02,& - & .7946649E+01,.2289019E+02,.3068619E+02,.3430975E+02,.2402051E+02,& - & .9549264E+01,.2542789E+02,.3361405E+02,.3719415E+02,.2632349E+02,& - & .1132268E+02,.2793770E+02,.3642692E+02,.3990874E+02,.2857172E+02,& - & .1327981E+02,.3036678E+02,.3909744E+02,.4243907E+02,.3077710E+02,& - & .6005571E+01,.1948807E+02,.2664131E+02,.3026331E+02,.2085818E+02,& - & .7413456E+01,.2201077E+02,.2965560E+02,.3329082E+02,.2321444E+02,& - & .8970318E+01,.2455040E+02,.3261620E+02,.3621899E+02,.2554069E+02,& - & .1068617E+02,.2708083E+02,.3547019E+02,.3899468E+02,.2780284E+02,& - & .1258054E+02,.2953954E+02,.3819719E+02,.4159109E+02,.3002584E+02,& - & .5548432E+01,.1861826E+02,.2559278E+02,.2919402E+02,.2004363E+02,& - & .6900092E+01,.2113681E+02,.2862219E+02,.3226196E+02,.2240744E+02,& - & .8410066E+01,.2367383E+02,.3160742E+02,.3522918E+02,.2474973E+02,& - & .1007047E+02,.2621742E+02,.3450362E+02,.3806349E+02,.2703382E+02,& - & .1190409E+02,.2870722E+02,.3728217E+02,.4072426E+02,.2927143E+02,& - & .5089620E+01,.1770102E+02,.2447913E+02,.2805560E+02,.1917787E+02,& - & .6378669E+01,.2021146E+02,.2751878E+02,.3115717E+02,.2154621E+02,& - & .7837964E+01,.2274529E+02,.3052386E+02,.3415832E+02,.2390212E+02,& - & .9443196E+01,.2529235E+02,.3346307E+02,.3705110E+02,.2620879E+02,& - & .1120944E+02,.2781188E+02,.3628879E+02,.3978127E+02,.2846286E+02,& - & .4610896E+01,.1669349E+02,.2324369E+02,.2677647E+02,.1820576E+02,& - & .5824606E+01,.1918277E+02,.2628270E+02,.2990605E+02,.2058572E+02,& - & .7220182E+01,.2171074E+02,.2930791E+02,.3295106E+02,.2294896E+02,& - & .8769986E+01,.2425684E+02,.3228052E+02,.3589409E+02,.2528213E+02,& - & .1046384E+02,.2679654E+02,.3515901E+02,.3869877E+02,.2755405E+02/ - - data absb(876:1050,10) / & - & .4168305E+01,.1570562E+02,.2201962E+02,.2548007E+02,.1723083E+02,& - & .5302277E+01,.1816020E+02,.2504538E+02,.2864169E+02,.1962267E+02,& - & .6628824E+01,.2068096E+02,.2808483E+02,.3173022E+02,.2199260E+02,& - & .8120143E+01,.2322187E+02,.3108353E+02,.3471491E+02,.2434405E+02,& - & .9751318E+01,.2577042E+02,.3400727E+02,.3758542E+02,.2664002E+02,& - & .3760997E+01,.1474503E+02,.2081030E+02,.2417490E+02,.1625573E+02,& - & .4812522E+01,.1715003E+02,.2381102E+02,.2737145E+02,.1865721E+02,& - & .6065394E+01,.1965574E+02,.2685618E+02,.3049364E+02,.2103561E+02,& - & .7493897E+01,.2218813E+02,.2987458E+02,.3351954E+02,.2339558E+02,& - & .9069722E+01,.2473888E+02,.3283783E+02,.3644425E+02,.2572001E+02,& - & .3407008E+01,.1387327E+02,.1968672E+02,.2295130E+02,.1534229E+02,& - & .4384559E+01,.1621715E+02,.2266121E+02,.2616930E+02,.1774766E+02,& - & .5564493E+01,.1869821E+02,.2569991E+02,.2931565E+02,.2013618E+02,& - & .6930044E+01,.2122343E+02,.2873366E+02,.3238405E+02,.2250272E+02,& - & .8451961E+01,.2376957E+02,.3172435E+02,.3535077E+02,.2484828E+02,& - & .3086932E+01,.1305420E+02,.1860890E+02,.2176702E+02,.1445866E+02,& - & .3998495E+01,.1533239E+02,.2155796E+02,.2498933E+02,.1686364E+02,& - & .5105023E+01,.1777463E+02,.2457856E+02,.2816630E+02,.1926213E+02,& - & .6405638E+01,.2029281E+02,.2762298E+02,.3127387E+02,.2163511E+02,& - & .7876512E+01,.2283418E+02,.3063295E+02,.3427110E+02,.2399217E+02,& - & .2791590E+01,.1226154E+02,.1753948E+02,.2058143E+02,.1357966E+02,& - & .3641206E+01,.1447202E+02,.2046653E+02,.2380567E+02,.1597990E+02,& - & .4672585E+01,.1686375E+02,.2346271E+02,.2701461E+02,.1838557E+02,& - & .5905294E+01,.1936440E+02,.2650933E+02,.3014596E+02,.2076820E+02,& - & .7318334E+01,.2189961E+02,.2953666E+02,.3318455E+02,.2313340E+02,& - & .2518774E+01,.1149827E+02,.1648112E+02,.1939248E+02,.1269754E+02,& - & .3307338E+01,.1363661E+02,.1938353E+02,.2262314E+02,.1509794E+02,& - & .4268652E+01,.1596732E+02,.2235360E+02,.2584534E+02,.1750525E+02,& - & .5428748E+01,.1843909E+02,.2539018E+02,.2900296E+02,.1989679E+02,& - & .6779426E+01,.2096706E+02,.2843121E+02,.3208295E+02,.2226801E+02,& - & .2289464E+01,.1082893E+02,.1552622E+02,.1830474E+02,.1189008E+02,& - & .3020620E+01,.1289378E+02,.1840077E+02,.2154161E+02,.1429147E+02,& - & .3922374E+01,.1516305E+02,.2134768E+02,.2476500E+02,.1669686E+02,& - & .5015015E+01,.1759724E+02,.2436604E+02,.2795197E+02,.1909808E+02,& - & .6305470E+01,.2011705E+02,.2741465E+02,.3106251E+02,.2147332E+02/ - - data absb(1051:1175,10) / & - & .2089789E+01,.1021602E+02,.1463344E+02,.1726758E+02,.1112336E+02,& - & .2767245E+01,.1220573E+02,.1746541E+02,.2050030E+02,.1351996E+02,& - & .3612314E+01,.1441119E+02,.2039079E+02,.2372523E+02,.1592114E+02,& - & .4639139E+01,.1679873E+02,.2338586E+02,.2693757E+02,.1832633E+02,& - & .5869463E+01,.1930265E+02,.2643475E+02,.3007091E+02,.2071169E+02,& - & .1902771E+01,.9617449E+01,.1375735E+02,.1623578E+02,.1036934E+02,& - & .2529334E+01,.1153875E+02,.1653836E+02,.1945888E+02,.1274803E+02,& - & .3320906E+01,.1368161E+02,.1944359E+02,.2269151E+02,.1514962E+02,& - & .4286297E+01,.1601548E+02,.2241651E+02,.2591604E+02,.1755694E+02,& - & .5452967E+01,.1849373E+02,.2545654E+02,.2907074E+02,.1994983E+02,& - & .1725440E+01,.9031381E+01,.1289432E+02,.1520765E+02,.9626329E+01,& - & .2309750E+01,.1089872E+02,.1562812E+02,.1842270E+02,.1197707E+02,& - & .3046266E+01,.1297125E+02,.1850543E+02,.2165803E+02,.1437884E+02,& - & .3954352E+01,.1524573E+02,.2145498E+02,.2488428E+02,.1678481E+02,& - & .5056606E+01,.1768754E+02,.2447686E+02,.2806579E+02,.1918626E+02,& - & .1564823E+01,.8489334E+01,.1209006E+02,.1424280E+02,.8931475E+01,& - & .2117660E+01,.1031347E+02,.1477913E+02,.1744092E+02,.1125085E+02,& - & .2802981E+01,.1231464E+02,.1761845E+02,.2067534E+02,.1364984E+02,& - & .3659632E+01,.1453293E+02,.2055035E+02,.2390260E+02,.1605194E+02,& - & .4698820E+01,.1693318E+02,.2355149E+02,.2710920E+02,.1845815E+02,& - & .1502352E+01,.8276308E+01,.1177375E+02,.1385967E+02,.8655479E+01,& - & .2044007E+01,.1008294E+02,.1444326E+02,.1704897E+02,.1096188E+02,& - & .2709296E+01,.1205664E+02,.1726418E+02,.2027874E+02,.1335631E+02,& - & .3545610E+01,.1425196E+02,.2018817E+02,.2350704E+02,.1575791E+02,& - & .4560655E+01,.1663292E+02,.2318230E+02,.2672443E+02,.1816710E+02/ - - data absb( 1:175,11) / & - & .2056300E+03,.1639500E+03,.1513100E+03,.1392800E+03,.1733600E+03,& - & .2058300E+03,.1634600E+03,.1510200E+03,.1386700E+03,.1720900E+03,& - & .2057900E+03,.1628200E+03,.1505100E+03,.1380300E+03,.1711900E+03,& - & .2053800E+03,.1619800E+03,.1500500E+03,.1374600E+03,.1706200E+03,& - & .2047100E+03,.1610000E+03,.1494200E+03,.1368500E+03,.1699800E+03,& - & .2138700E+03,.1748600E+03,.1641000E+03,.1489600E+03,.1792600E+03,& - & .2139800E+03,.1740700E+03,.1635400E+03,.1484900E+03,.1787200E+03,& - & .2137100E+03,.1730600E+03,.1630000E+03,.1479600E+03,.1783800E+03,& - & .2132000E+03,.1719300E+03,.1623800E+03,.1474800E+03,.1780700E+03,& - & .2123900E+03,.1706200E+03,.1615800E+03,.1466100E+03,.1772600E+03,& - & .2186800E+03,.1839200E+03,.1759700E+03,.1587700E+03,.1840900E+03,& - & .2186100E+03,.1828500E+03,.1753300E+03,.1584500E+03,.1841300E+03,& - & .2183800E+03,.1816800E+03,.1746900E+03,.1581400E+03,.1842300E+03,& - & .2178500E+03,.1802800E+03,.1739200E+03,.1574700E+03,.1839100E+03,& - & .2171400E+03,.1788100E+03,.1728100E+03,.1564400E+03,.1833700E+03,& - & .2198900E+03,.1909000E+03,.1866600E+03,.1682300E+03,.1871700E+03,& - & .2200000E+03,.1898900E+03,.1860400E+03,.1682200E+03,.1879700E+03,& - & .2198200E+03,.1885600E+03,.1853300E+03,.1679400E+03,.1885100E+03,& - & .2195400E+03,.1870900E+03,.1843200E+03,.1671500E+03,.1885400E+03,& - & .2189800E+03,.1854200E+03,.1830300E+03,.1660000E+03,.1883900E+03,& - & .2179300E+03,.1959600E+03,.1960300E+03,.1770300E+03,.1885700E+03,& - & .2182100E+03,.1949200E+03,.1954800E+03,.1772500E+03,.1902300E+03,& - & .2185000E+03,.1936900E+03,.1946200E+03,.1770100E+03,.1913300E+03,& - & .2185500E+03,.1922100E+03,.1934300E+03,.1761600E+03,.1919400E+03,& - & .2183900E+03,.1905700E+03,.1920600E+03,.1749000E+03,.1922500E+03,& - & .2131100E+03,.1993500E+03,.2038500E+03,.1849200E+03,.1886400E+03,& - & .2139900E+03,.1983800E+03,.2033900E+03,.1853600E+03,.1911700E+03,& - & .2147700E+03,.1972700E+03,.2025100E+03,.1851700E+03,.1929600E+03,& - & .2153700E+03,.1960200E+03,.2013100E+03,.1843300E+03,.1942600E+03,& - & .2159400E+03,.1946000E+03,.1998900E+03,.1829900E+03,.1951100E+03,& - & .2062800E+03,.2013100E+03,.2101800E+03,.1918100E+03,.1878000E+03,& - & .2078600E+03,.2006100E+03,.2098500E+03,.1924900E+03,.1911700E+03,& - & .2093900E+03,.1997800E+03,.2091500E+03,.1924500E+03,.1937900E+03,& - & .2107800E+03,.1987600E+03,.2080800E+03,.1915900E+03,.1957800E+03,& - & .2119600E+03,.1976200E+03,.2066600E+03,.1902000E+03,.1972600E+03/ - - data absb(176:350,11) / & - & .1980600E+03,.2021500E+03,.2152500E+03,.1978100E+03,.1864600E+03,& - & .2005400E+03,.2018000E+03,.2152700E+03,.1987400E+03,.1907200E+03,& - & .2029800E+03,.2013200E+03,.2147800E+03,.1987700E+03,.1941300E+03,& - & .2052200E+03,.2007000E+03,.2138400E+03,.1979300E+03,.1968100E+03,& - & .2072500E+03,.1997500E+03,.2124900E+03,.1965900E+03,.1989900E+03,& - & .1891900E+03,.2021700E+03,.2194200E+03,.2029100E+03,.1849900E+03,& - & .1926800E+03,.2023900E+03,.2197400E+03,.2041500E+03,.1901200E+03,& - & .1960900E+03,.2023100E+03,.2194700E+03,.2042500E+03,.1943200E+03,& - & .1992600E+03,.2020100E+03,.2186600E+03,.2034600E+03,.1977000E+03,& - & .2022400E+03,.2013600E+03,.2174200E+03,.2021200E+03,.2004400E+03,& - & .1806400E+03,.2018200E+03,.2227600E+03,.2074000E+03,.1840900E+03,& - & .1851300E+03,.2025300E+03,.2234100E+03,.2087600E+03,.1898800E+03,& - & .1895100E+03,.2028700E+03,.2232900E+03,.2089000E+03,.1947400E+03,& - & .1936800E+03,.2028300E+03,.2225900E+03,.2081200E+03,.1986900E+03,& - & .1975200E+03,.2024800E+03,.2214300E+03,.2067600E+03,.2018500E+03,& - & .1726100E+03,.2012900E+03,.2256000E+03,.2112600E+03,.1836000E+03,& - & .1781300E+03,.2025500E+03,.2264500E+03,.2127700E+03,.1899300E+03,& - & .1834700E+03,.2032200E+03,.2264900E+03,.2128800E+03,.1953400E+03,& - & .1885800E+03,.2034500E+03,.2259300E+03,.2121100E+03,.1997200E+03,& - & .1932500E+03,.2033000E+03,.2247000E+03,.2106600E+03,.2031400E+03,& - & .1655000E+03,.2007900E+03,.2279700E+03,.2145900E+03,.1835200E+03,& - & .1719900E+03,.2024700E+03,.2289900E+03,.2161400E+03,.1903100E+03,& - & .1782900E+03,.2034900E+03,.2292000E+03,.2162100E+03,.1961000E+03,& - & .1842400E+03,.2039500E+03,.2286500E+03,.2154400E+03,.2008000E+03,& - & .1896600E+03,.2039300E+03,.2273500E+03,.2138800E+03,.2043700E+03,& - & .1594900E+03,.2004800E+03,.2299900E+03,.2175800E+03,.1839500E+03,& - & .1669800E+03,.2024700E+03,.2311900E+03,.2190300E+03,.1910800E+03,& - & .1741100E+03,.2037000E+03,.2314400E+03,.2190400E+03,.1971100E+03,& - & .1808800E+03,.2043500E+03,.2308200E+03,.2181700E+03,.2019200E+03,& - & .1871000E+03,.2045000E+03,.2295000E+03,.2164800E+03,.2055900E+03,& - & .1547900E+03,.2003800E+03,.2318100E+03,.2201600E+03,.1849000E+03,& - & .1632200E+03,.2025800E+03,.2330700E+03,.2214500E+03,.1922200E+03,& - & .1711900E+03,.2040100E+03,.2332600E+03,.2214000E+03,.1983100E+03,& - & .1786600E+03,.2047800E+03,.2325900E+03,.2203800E+03,.2031500E+03,& - & .1855300E+03,.2049800E+03,.2312200E+03,.2185400E+03,.2068500E+03/ - - data absb(351:525,11) / & - & .1514300E+03,.2004900E+03,.2334400E+03,.2224100E+03,.1861500E+03,& - & .1607000E+03,.2027900E+03,.2346500E+03,.2235200E+03,.1935300E+03,& - & .1693200E+03,.2043000E+03,.2347300E+03,.2233100E+03,.1996000E+03,& - & .1773700E+03,.2051800E+03,.2340200E+03,.2221200E+03,.2044000E+03,& - & .1847200E+03,.2053700E+03,.2325700E+03,.2201500E+03,.2080700E+03,& - & .1493500E+03,.2007800E+03,.2348700E+03,.2243600E+03,.1876200E+03,& - & .1592600E+03,.2031200E+03,.2359700E+03,.2252300E+03,.1949100E+03,& - & .1683900E+03,.2046700E+03,.2359700E+03,.2248400E+03,.2009200E+03,& - & .1768700E+03,.2055400E+03,.2351600E+03,.2234500E+03,.2056200E+03,& - & .1845300E+03,.2057000E+03,.2335700E+03,.2213500E+03,.2092100E+03,& - & .1484400E+03,.2011700E+03,.2361400E+03,.2260100E+03,.1892700E+03,& - & .1587800E+03,.2035000E+03,.2370700E+03,.2266400E+03,.1964200E+03,& - & .1682900E+03,.2050500E+03,.2369600E+03,.2260100E+03,.2022900E+03,& - & .1770200E+03,.2058500E+03,.2360200E+03,.2244500E+03,.2068500E+03,& - & .1848700E+03,.2059900E+03,.2343000E+03,.2222000E+03,.2103100E+03,& - & .1484100E+03,.2016500E+03,.2372400E+03,.2274200E+03,.1910100E+03,& - & .1590300E+03,.2039500E+03,.2379800E+03,.2277400E+03,.1979600E+03,& - & .1687800E+03,.2054300E+03,.2377400E+03,.2268900E+03,.2036700E+03,& - & .1776500E+03,.2061400E+03,.2366200E+03,.2251500E+03,.2080400E+03,& - & .1855600E+03,.2062600E+03,.2347800E+03,.2227400E+03,.2113300E+03,& - & .1491000E+03,.2021900E+03,.2381600E+03,.2285700E+03,.1928000E+03,& - & .1598700E+03,.2044200E+03,.2387300E+03,.2286000E+03,.1995500E+03,& - & .1697400E+03,.2057800E+03,.2383000E+03,.2275100E+03,.2050300E+03,& - & .1787000E+03,.2064000E+03,.2370300E+03,.2255900E+03,.2091700E+03,& - & .1865600E+03,.2064700E+03,.2350400E+03,.2230300E+03,.2123200E+03,& - & .1503100E+03,.2027900E+03,.2389700E+03,.2294900E+03,.1945900E+03,& - & .1611900E+03,.2048900E+03,.2393100E+03,.2292200E+03,.2011300E+03,& - & .1711000E+03,.2061000E+03,.2386900E+03,.2279100E+03,.2063400E+03,& - & .1800200E+03,.2066200E+03,.2372300E+03,.2258200E+03,.2102900E+03,& - & .1877700E+03,.2065900E+03,.2351000E+03,.2230800E+03,.2132200E+03,& - & .1519700E+03,.2034100E+03,.2396500E+03,.2301900E+03,.1963900E+03,& - & .1628500E+03,.2053400E+03,.2397600E+03,.2296400E+03,.2026700E+03,& - & .1727000E+03,.2063800E+03,.2389300E+03,.2281100E+03,.2075800E+03,& - & .1815100E+03,.2068000E+03,.2372700E+03,.2258400E+03,.2113200E+03,& - & .1891200E+03,.2066500E+03,.2350000E+03,.2229600E+03,.2140600E+03/ - - data absb(526:700,11) / & - & .1535200E+03,.2039100E+03,.2401400E+03,.2306900E+03,.1979000E+03,& - & .1643700E+03,.2056600E+03,.2400600E+03,.2299200E+03,.2039600E+03,& - & .1741600E+03,.2066200E+03,.2390700E+03,.2282300E+03,.2086300E+03,& - & .1828500E+03,.2069500E+03,.2372800E+03,.2258000E+03,.2121800E+03,& - & .1903300E+03,.2066700E+03,.2348700E+03,.2228000E+03,.2147400E+03,& - & .1542100E+03,.2041800E+03,.2405200E+03,.2311000E+03,.1987600E+03,& - & .1650700E+03,.2058600E+03,.2403300E+03,.2302000E+03,.2046800E+03,& - & .1748600E+03,.2067700E+03,.2392400E+03,.2284100E+03,.2092300E+03,& - & .1835000E+03,.2070500E+03,.2373700E+03,.2258900E+03,.2126900E+03,& - & .1909400E+03,.2066900E+03,.2348900E+03,.2228100E+03,.2151400E+03,& - & .1538100E+03,.2042400E+03,.2408000E+03,.2314500E+03,.1988800E+03,& - & .1647800E+03,.2059200E+03,.2406000E+03,.2305500E+03,.2048400E+03,& - & .1746400E+03,.2068400E+03,.2395000E+03,.2287400E+03,.2093800E+03,& - & .1833600E+03,.2071500E+03,.2376200E+03,.2261800E+03,.2128400E+03,& - & .1908600E+03,.2067800E+03,.2351400E+03,.2231100E+03,.2153200E+03,& - & .1517700E+03,.2039400E+03,.2409600E+03,.2317800E+03,.1980200E+03,& - & .1629800E+03,.2057800E+03,.2409100E+03,.2310200E+03,.2041600E+03,& - & .1730700E+03,.2068100E+03,.2399400E+03,.2293400E+03,.2089300E+03,& - & .1820400E+03,.2072100E+03,.2381800E+03,.2268800E+03,.2125500E+03,& - & .1897300E+03,.2069500E+03,.2357300E+03,.2238300E+03,.2151600E+03,& - & .1496800E+03,.2035900E+03,.2410400E+03,.2320200E+03,.1970300E+03,& - & .1611300E+03,.2056000E+03,.2411600E+03,.2314300E+03,.2034100E+03,& - & .1714400E+03,.2067400E+03,.2403300E+03,.2298800E+03,.2083800E+03,& - & .1806300E+03,.2072400E+03,.2386600E+03,.2275200E+03,.2121600E+03,& - & .1885500E+03,.2071000E+03,.2363200E+03,.2245300E+03,.2149300E+03,& - & .1476400E+03,.2032200E+03,.2410600E+03,.2322000E+03,.1960400E+03,& - & .1593200E+03,.2054000E+03,.2413700E+03,.2318000E+03,.2026200E+03,& - & .1698400E+03,.2066500E+03,.2406500E+03,.2303600E+03,.2078100E+03,& - & .1792300E+03,.2072500E+03,.2391000E+03,.2281000E+03,.2117500E+03,& - & .1873700E+03,.2072200E+03,.2368400E+03,.2251700E+03,.2146700E+03,& - & .1443800E+03,.2025400E+03,.2409200E+03,.2322500E+03,.1942500E+03,& - & .1563300E+03,.2049800E+03,.2415200E+03,.2321700E+03,.2011500E+03,& - & .1671800E+03,.2064200E+03,.2410500E+03,.2309600E+03,.2067200E+03,& - & .1769000E+03,.2072000E+03,.2396900E+03,.2288700E+03,.2109300E+03,& - & .1853900E+03,.2073300E+03,.2375800E+03,.2260900E+03,.2141100E+03/ - - data absb(701:875,11) / & - & .1409300E+03,.2017000E+03,.2406200E+03,.2321400E+03,.1922600E+03,& - & .1530900E+03,.2044100E+03,.2415500E+03,.2324300E+03,.1995100E+03,& - & .1643400E+03,.2061300E+03,.2413600E+03,.2314900E+03,.2054500E+03,& - & .1743900E+03,.2070900E+03,.2402200E+03,.2296300E+03,.2100000E+03,& - & .1832500E+03,.2073900E+03,.2382900E+03,.2270000E+03,.2134400E+03,& - & .1374200E+03,.2007200E+03,.2401800E+03,.2318800E+03,.1901700E+03,& - & .1498700E+03,.2038100E+03,.2415100E+03,.2326000E+03,.1977800E+03,& - & .1614400E+03,.2058000E+03,.2415900E+03,.2319400E+03,.2040800E+03,& - & .1718200E+03,.2069300E+03,.2406800E+03,.2303000E+03,.2089700E+03,& - & .1810100E+03,.2073900E+03,.2389400E+03,.2278500E+03,.2126900E+03,& - & .1331600E+03,.1994600E+03,.2395200E+03,.2313400E+03,.1874600E+03,& - & .1459000E+03,.2029900E+03,.2413100E+03,.2326500E+03,.1955500E+03,& - & .1578200E+03,.2053100E+03,.2417600E+03,.2323700E+03,.2022800E+03,& - & .1686000E+03,.2066600E+03,.2411300E+03,.2309900E+03,.2076100E+03,& - & .1781800E+03,.2073300E+03,.2396400E+03,.2287800E+03,.2116600E+03,& - & .1285100E+03,.1979300E+03,.2386000E+03,.2305100E+03,.1844000E+03,& - & .1415600E+03,.2019500E+03,.2409200E+03,.2324900E+03,.1929800E+03,& - & .1538100E+03,.2046800E+03,.2418200E+03,.2326800E+03,.2001500E+03,& - & .1649400E+03,.2062500E+03,.2414800E+03,.2316300E+03,.2059700E+03,& - & .1749900E+03,.2071900E+03,.2402900E+03,.2296900E+03,.2104300E+03,& - & .1237700E+03,.1962200E+03,.2374500E+03,.2293800E+03,.1811400E+03,& - & .1371300E+03,.2007400E+03,.2403500E+03,.2321000E+03,.1902400E+03,& - & .1496900E+03,.2038900E+03,.2417100E+03,.2328300E+03,.1978700E+03,& - & .1612200E+03,.2058000E+03,.2417200E+03,.2321500E+03,.2041700E+03,& - & .1716900E+03,.2069700E+03,.2408500E+03,.2305100E+03,.2090700E+03,& - & .1187100E+03,.1941800E+03,.2360000E+03,.2279000E+03,.1774700E+03,& - & .1323100E+03,.1992900E+03,.2395400E+03,.2314300E+03,.1871200E+03,& - & .1451400E+03,.2028800E+03,.2413800E+03,.2328000E+03,.1952600E+03,& - & .1571100E+03,.2052300E+03,.2418700E+03,.2325700E+03,.2020700E+03,& - & .1680200E+03,.2066400E+03,.2413200E+03,.2312600E+03,.2074900E+03,& - & .1129500E+03,.1915900E+03,.2339800E+03,.2258800E+03,.1731300E+03,& - & .1268300E+03,.1974100E+03,.2383500E+03,.2303100E+03,.1834200E+03,& - & .1399900E+03,.2015900E+03,.2408500E+03,.2325300E+03,.1921700E+03,& - & .1523400E+03,.2044200E+03,.2418600E+03,.2328600E+03,.1994900E+03,& - & .1637300E+03,.2061800E+03,.2416900E+03,.2319400E+03,.2054900E+03/ - - data absb(876:1050,11) / & - & .1071200E+03,.1887100E+03,.2315900E+03,.2234700E+03,.1685000E+03,& - & .1212400E+03,.1952900E+03,.2368700E+03,.2288200E+03,.1794600E+03,& - & .1347300E+03,.2000700E+03,.2400500E+03,.2319100E+03,.1888300E+03,& - & .1474200E+03,.2034200E+03,.2416400E+03,.2329400E+03,.1967000E+03,& - & .1592800E+03,.2056200E+03,.2419200E+03,.2324700E+03,.2032500E+03,& - & .1012000E+03,.1855000E+03,.2288000E+03,.2207100E+03,.1636300E+03,& - & .1155600E+03,.1928500E+03,.2350400E+03,.2269700E+03,.1752400E+03,& - & .1293200E+03,.1983200E+03,.2390100E+03,.2309700E+03,.1852400E+03,& - & .1423800E+03,.2022600E+03,.2412000E+03,.2327800E+03,.1937000E+03,& - & .1546000E+03,.2048800E+03,.2419900E+03,.2328300E+03,.2007800E+03,& - & .9560300E+02,.1821600E+03,.2257600E+03,.2176800E+03,.1587800E+03,& - & .1101500E+03,.1903100E+03,.2329800E+03,.2249000E+03,.1710500E+03,& - & .1241500E+03,.1964600E+03,.2377500E+03,.2297500E+03,.1816600E+03,& - & .1375200E+03,.2009400E+03,.2405800E+03,.2323600E+03,.1906900E+03,& - & .1500700E+03,.2040300E+03,.2418700E+03,.2329900E+03,.1982600E+03,& - & .9013700E+02,.1786800E+03,.2224000E+03,.2144200E+03,.1538400E+03,& - & .1048400E+03,.1875700E+03,.2306600E+03,.2225800E+03,.1667700E+03,& - & .1190700E+03,.1944200E+03,.2362800E+03,.2282400E+03,.1779600E+03,& - & .1326900E+03,.1994800E+03,.2397600E+03,.2316700E+03,.1875600E+03,& - & .1455200E+03,.2030200E+03,.2415400E+03,.2329600E+03,.1956500E+03,& - & .8469000E+02,.1749600E+03,.2186400E+03,.2108000E+03,.1486200E+03,& - & .9947100E+02,.1845300E+03,.2279800E+03,.2199200E+03,.1622500E+03,& - & .1139100E+03,.1921300E+03,.2345100E+03,.2264400E+03,.1740600E+03,& - & .1277700E+03,.1978100E+03,.2387200E+03,.2307000E+03,.1842400E+03,& - & .1409100E+03,.2018900E+03,.2410700E+03,.2327300E+03,.1928600E+03,& - & .7926200E+02,.1709500E+03,.2143600E+03,.2068100E+03,.1431700E+03,& - & .9404700E+02,.1812600E+03,.2249400E+03,.2169000E+03,.1574800E+03,& - & .1086500E+03,.1895800E+03,.2324100E+03,.2243400E+03,.1699400E+03,& - & .1227400E+03,.1959500E+03,.2374200E+03,.2294100E+03,.1807000E+03,& - & .1361800E+03,.2005600E+03,.2404000E+03,.2322400E+03,.1898800E+03,& - & .7431200E+02,.1670100E+03,.2100000E+03,.2028300E+03,.1380100E+03,& - & .8905900E+02,.1780200E+03,.2217700E+03,.2138100E+03,.1528900E+03,& - & .1037900E+03,.1870100E+03,.2302100E+03,.2221400E+03,.1659500E+03,& - & .1180800E+03,.1940300E+03,.2360200E+03,.2279700E+03,.1772800E+03,& - & .1317400E+03,.1991800E+03,.2396100E+03,.2315500E+03,.1869700E+03/ - - data absb(1051:1175,11) / & - & .6961500E+02,.1629600E+03,.2054000E+03,.1986600E+03,.1328800E+03,& - & .8427600E+02,.1746600E+03,.2183500E+03,.2105600E+03,.1482800E+03,& - & .9906600E+02,.1843300E+03,.2278200E+03,.2197700E+03,.1619700E+03,& - & .1135400E+03,.1919900E+03,.2344200E+03,.2263600E+03,.1738300E+03,& - & .1274100E+03,.1977000E+03,.2386600E+03,.2306500E+03,.1840300E+03,& - & .6494400E+02,.1587700E+03,.2004400E+03,.1942100E+03,.1276200E+03,& - & .7952400E+02,.1711400E+03,.2146100E+03,.2070700E+03,.1435100E+03,& - & .9432300E+02,.1814400E+03,.2251400E+03,.2171100E+03,.1577800E+03,& - & .1089400E+03,.1897600E+03,.2325700E+03,.2245200E+03,.1702200E+03,& - & .1230100E+03,.1960500E+03,.2375200E+03,.2295400E+03,.1809400E+03,& - & .6035300E+02,.1543100E+03,.1951400E+03,.1894500E+03,.1222500E+03,& - & .7481500E+02,.1674200E+03,.2104900E+03,.2032900E+03,.1386000E+03,& - & .8956700E+02,.1783700E+03,.2221400E+03,.2141900E+03,.1534300E+03,& - & .1043100E+03,.1873300E+03,.2305000E+03,.2224400E+03,.1664400E+03,& - & .1185600E+03,.1942300E+03,.2361800E+03,.2281600E+03,.1776700E+03,& - & .5609800E+02,.1499100E+03,.1898000E+03,.1846500E+03,.1170600E+03,& - & .7037700E+02,.1636700E+03,.2062200E+03,.1994200E+03,.1337800E+03,& - & .8504900E+02,.1752800E+03,.2190200E+03,.2111900E+03,.1491000E+03,& - & .9985700E+02,.1848200E+03,.2282700E+03,.2202200E+03,.1626800E+03,& - & .1142800E+03,.1923300E+03,.2347000E+03,.2266600E+03,.1744400E+03,& - & .5441800E+02,.1480900E+03,.1875400E+03,.1826100E+03,.1149500E+03,& - & .6859800E+02,.1621000E+03,.2044100E+03,.1977800E+03,.1318000E+03,& - & .8324600E+02,.1739800E+03,.2176800E+03,.2099300E+03,.1473300E+03,& - & .9805500E+02,.1837500E+03,.2273200E+03,.2192700E+03,.1611300E+03,& - & .1125500E+03,.1915300E+03,.2340600E+03,.2260100E+03,.1731000E+03/ - - data absb( 1:175,12) / & - & .4338110E+03,.3258785E+03,.2765841E+03,.3551700E+03,.4738213E+03,& - & .4358591E+03,.3274735E+03,.2732330E+03,.3477157E+03,.4639305E+03,& - & .4367994E+03,.3282050E+03,.2698072E+03,.3403736E+03,.4541170E+03,& - & .4367673E+03,.3281913E+03,.2662171E+03,.3330191E+03,.4442737E+03,& - & .4356257E+03,.3273304E+03,.2624520E+03,.3260525E+03,.4349606E+03,& - & .4965751E+03,.3730543E+03,.3165865E+03,.3940821E+03,.5257811E+03,& - & .4977615E+03,.3739641E+03,.3123416E+03,.3853185E+03,.5140967E+03,& - & .4978529E+03,.3740600E+03,.3078301E+03,.3766318E+03,.5024939E+03,& - & .4965358E+03,.3731122E+03,.3030947E+03,.3681551E+03,.4911078E+03,& - & .4942501E+03,.3714089E+03,.2982254E+03,.3606307E+03,.4809116E+03,& - & .5631880E+03,.4233224E+03,.3594901E+03,.4335570E+03,.5784608E+03,& - & .5634438E+03,.4233039E+03,.3539288E+03,.4233711E+03,.5648410E+03,& - & .5619418E+03,.4221964E+03,.3480452E+03,.4132459E+03,.5512312E+03,& - & .5592483E+03,.4202048E+03,.3418750E+03,.4039045E+03,.5386286E+03,& - & .5551436E+03,.4171466E+03,.3356718E+03,.3953284E+03,.5268417E+03,& - & .6327464E+03,.4759753E+03,.4043694E+03,.4738466E+03,.6318088E+03,& - & .6309974E+03,.4742402E+03,.3971672E+03,.4618354E+03,.6156456E+03,& - & .6278582E+03,.4716973E+03,.3895188E+03,.4502024E+03,.5999656E+03,& - & .6230476E+03,.4681132E+03,.3817116E+03,.4394718E+03,.5854793E+03,& - & .6168383E+03,.4634762E+03,.3737303E+03,.4293418E+03,.5716261E+03,& - & .7031362E+03,.5296686E+03,.4502274E+03,.5144971E+03,.6844628E+03,& - & .6994439E+03,.5260700E+03,.4409153E+03,.5003459E+03,.6654934E+03,& - & .6938124E+03,.5214150E+03,.4313297E+03,.4869200E+03,.6474992E+03,& - & .6865591E+03,.5157531E+03,.4215792E+03,.4743711E+03,.6306843E+03,& - & .6778828E+03,.5092809E+03,.4115306E+03,.4623577E+03,.6144981E+03,& - & .7731573E+03,.5833614E+03,.4960552E+03,.5546751E+03,.7351434E+03,& - & .7667584E+03,.5774695E+03,.4843214E+03,.5381637E+03,.7133093E+03,& - & .7584006E+03,.5703374E+03,.4724758E+03,.5225411E+03,.6927570E+03,& - & .7484491E+03,.5623616E+03,.4604054E+03,.5079339E+03,.6733220E+03,& - & .7367135E+03,.5534249E+03,.4480895E+03,.4939401E+03,.6546934E+03,& - & .8409349E+03,.6358707E+03,.5406929E+03,.5933755E+03,.7826997E+03,& - & .8314773E+03,.6270808E+03,.5263991E+03,.5744137E+03,.7580256E+03,& - & .8200103E+03,.6173497E+03,.5119158E+03,.5563407E+03,.7348534E+03,& - & .8068534E+03,.6066626E+03,.4972618E+03,.5395008E+03,.7127611E+03,& - & .7922845E+03,.5951793E+03,.4826400E+03,.5234260E+03,.6916658E+03/ - - data absb(176:350,12) / & - & .9048913E+03,.6856063E+03,.5829003E+03,.6293251E+03,.8259779E+03,& - & .8920622E+03,.6739392E+03,.5656996E+03,.6076975E+03,.7986291E+03,& - & .8773064E+03,.6613225E+03,.5484044E+03,.5872679E+03,.7727058E+03,& - & .8609036E+03,.6477146E+03,.5311640E+03,.5681427E+03,.7481234E+03,& - & .8431150E+03,.6336171E+03,.5140156E+03,.5498732E+03,.7244630E+03,& - & .9636991E+03,.7316951E+03,.6218536E+03,.6620342E+03,.8647359E+03,& - & .9475066E+03,.7168594E+03,.6016241E+03,.6376903E+03,.8346844E+03,& - & .9293968E+03,.7013269E+03,.5815752E+03,.6149608E+03,.8061544E+03,& - & .9098003E+03,.6849951E+03,.5617381E+03,.5935925E+03,.7790911E+03,& - & .8886450E+03,.6681002E+03,.5420821E+03,.5733205E+03,.7530675E+03,& - & .1015405E+04,.7723224E+03,.6554984E+03,.6893842E+03,.8965322E+03,& - & .9957317E+03,.7543125E+03,.6322716E+03,.6625732E+03,.8641101E+03,& - & .9742889E+03,.7357574E+03,.6095984E+03,.6377464E+03,.8332099E+03,& - & .9513341E+03,.7167192E+03,.5872099E+03,.6143318E+03,.8038674E+03,& - & .9271699E+03,.6973008E+03,.5653278E+03,.5922105E+03,.7757920E+03,& - & .1060462E+04,.8075265E+03,.6843897E+03,.7124747E+03,.9230005E+03,& - & .1037459E+04,.7864953E+03,.6584383E+03,.6833274E+03,.8883530E+03,& - & .1012792E+04,.7651897E+03,.6331576E+03,.6565949E+03,.8552652E+03,& - & .9866354E+03,.7436769E+03,.6084848E+03,.6313485E+03,.8239323E+03,& - & .9595800E+03,.7219245E+03,.5846257E+03,.6076220E+03,.7941595E+03,& - & .1098608E+04,.8371963E+03,.7083084E+03,.7311988E+03,.9441461E+03,& - & .1072494E+04,.8134318E+03,.6798957E+03,.7001704E+03,.9076022E+03,& - & .1044667E+04,.7896182E+03,.6523292E+03,.6716308E+03,.8727223E+03,& - & .1015777E+04,.7658591E+03,.6257102E+03,.6448513E+03,.8396486E+03,& - & .9862086E+03,.7420869E+03,.6001289E+03,.6196814E+03,.8085246E+03,& - & .1130080E+04,.8613842E+03,.7273980E+03,.7455565E+03,.9603143E+03,& - & .1100795E+04,.8351571E+03,.6967578E+03,.7129616E+03,.9220699E+03,& - & .1070329E+04,.8092621E+03,.6672876E+03,.6829948E+03,.8856533E+03,& - & .1038932E+04,.7834641E+03,.6390022E+03,.6549212E+03,.8512901E+03,& - & .1007073E+04,.7578586E+03,.6119071E+03,.6285978E+03,.8190226E+03,& - & .1154817E+04,.8801654E+03,.7415039E+03,.7556111E+03,.9714143E+03,& - & .1122664E+04,.8518781E+03,.7090277E+03,.7218209E+03,.9318180E+03,& - & .1089916E+04,.8241127E+03,.6780777E+03,.6907287E+03,.8943125E+03,& - & .1056461E+04,.7965849E+03,.6484079E+03,.6616194E+03,.8589272E+03,& - & .1022590E+04,.7695324E+03,.6201114E+03,.6344623E+03,.8258624E+03/ - - data absb(351:525,12) / & - & .1173826E+04,.8944232E+03,.7516288E+03,.7622958E+03,.9786164E+03,& - & .1139213E+04,.8644602E+03,.7176974E+03,.7275753E+03,.9379617E+03,& - & .1104499E+04,.8350215E+03,.6855100E+03,.6956267E+03,.8996608E+03,& - & .1069228E+04,.8060327E+03,.6547517E+03,.6658171E+03,.8636644E+03,& - & .1033679E+04,.7777792E+03,.6254959E+03,.6380265E+03,.8299256E+03,& - & .1187612E+04,.9045966E+03,.7582339E+03,.7660705E+03,.9825372E+03,& - & .1151104E+04,.8732077E+03,.7232198E+03,.7307711E+03,.9412613E+03,& - & .1114812E+04,.8425100E+03,.6900707E+03,.6982050E+03,.9022920E+03,& - & .1077922E+04,.8124079E+03,.6584780E+03,.6679077E+03,.8658499E+03,& - & .1040927E+04,.7831204E+03,.6285352E+03,.6396645E+03,.8317461E+03,& - & .1196774E+04,.9111403E+03,.7616196E+03,.7671722E+03,.9834539E+03,& - & .1158870E+04,.8786102E+03,.7258194E+03,.7315277E+03,.9417190E+03,& - & .1121068E+04,.8468836E+03,.6919844E+03,.6985953E+03,.9023781E+03,& - & .1082920E+04,.8159387E+03,.6597813E+03,.6679809E+03,.8657188E+03,& - & .1044783E+04,.7858772E+03,.6294298E+03,.6395237E+03,.8313784E+03,& - & .1202260E+04,.9148111E+03,.7624882E+03,.7661952E+03,.9820032E+03,& - & .1163158E+04,.8813333E+03,.7261740E+03,.7304250E+03,.9399991E+03,& - & .1124180E+04,.8488606E+03,.6918461E+03,.6972877E+03,.9005744E+03,& - & .1084954E+04,.8172592E+03,.6592986E+03,.6665878E+03,.8638719E+03,& - & .1045950E+04,.7865464E+03,.6286194E+03,.6380504E+03,.8294321E+03,& - & .1204456E+04,.9157270E+03,.7610818E+03,.7633951E+03,.9784831E+03,& - & .1164367E+04,.8816366E+03,.7244819E+03,.7276259E+03,.9364715E+03,& - & .1124324E+04,.8486129E+03,.6898842E+03,.6945597E+03,.8971270E+03,& - & .1084324E+04,.8165570E+03,.6571659E+03,.6638568E+03,.8604884E+03,& - & .1044694E+04,.7853529E+03,.6263972E+03,.6354464E+03,.8261775E+03,& - & .1204084E+04,.9146184E+03,.7579482E+03,.7592747E+03,.9734683E+03,& - & .1162995E+04,.8799770E+03,.7211610E+03,.7236223E+03,.9315108E+03,& - & .1122270E+04,.8466270E+03,.6864778E+03,.6906781E+03,.8923413E+03,& - & .1081628E+04,.8142783E+03,.6537748E+03,.6601480E+03,.8559108E+03,& - & .1041535E+04,.7827690E+03,.6229791E+03,.6318521E+03,.8217287E+03,& - & .1201431E+04,.9117433E+03,.7533822E+03,.7540042E+03,.9671155E+03,& - & .1159753E+04,.8768687E+03,.7166394E+03,.7186372E+03,.9254210E+03,& - & .1118355E+04,.8432577E+03,.6819604E+03,.6859134E+03,.8865933E+03,& - & .1077205E+04,.8106161E+03,.6493437E+03,.6556209E+03,.8503919E+03,& - & .1036866E+04,.7790721E+03,.6187296E+03,.6275874E+03,.8165163E+03/ - - data absb(526:700,12) / & - & .1198563E+04,.9088441E+03,.7491554E+03,.7492438E+03,.9613627E+03,& - & .1156284E+04,.8737803E+03,.7124077E+03,.7140741E+03,.9199132E+03,& - & .1114455E+04,.8399712E+03,.6778293E+03,.6816338E+03,.8814481E+03,& - & .1073022E+04,.8072052E+03,.6453367E+03,.6515614E+03,.8454321E+03,& - & .1032356E+04,.7755667E+03,.6148054E+03,.6237372E+03,.8118204E+03,& - & .1198333E+04,.9083513E+03,.7477168E+03,.7473560E+03,.9590262E+03,& - & .1155753E+04,.8731138E+03,.7109009E+03,.7122360E+03,.9176511E+03,& - & .1113496E+04,.8390696E+03,.6762632E+03,.6798170E+03,.8792408E+03,& - & .1071776E+04,.8061247E+03,.6437713E+03,.6498449E+03,.8432884E+03,& - & .1030817E+04,.7743687E+03,.6132096E+03,.6220561E+03,.8097579E+03,& - & .1201812E+04,.9109743E+03,.7497301E+03,.7489114E+03,.9607489E+03,& - & .1158859E+04,.8754611E+03,.7126895E+03,.7135931E+03,.9191682E+03,& - & .1116249E+04,.8411676E+03,.6778498E+03,.6810248E+03,.8806473E+03,& - & .1074182E+04,.8079523E+03,.6451507E+03,.6509316E+03,.8445579E+03,& - & .1033029E+04,.7760505E+03,.6144744E+03,.6230304E+03,.8108939E+03,& - & .1211130E+04,.9186048E+03,.7571510E+03,.7557283E+03,.9686341E+03,& - & .1167769E+04,.8825784E+03,.7195377E+03,.7197860E+03,.9264272E+03,& - & .1124863E+04,.8479369E+03,.6841799E+03,.6866852E+03,.8873138E+03,& - & .1082412E+04,.8143560E+03,.6510060E+03,.6560895E+03,.8507530E+03,& - & .1040908E+04,.7820519E+03,.6199358E+03,.6277981E+03,.8166320E+03,& - & .1220285E+04,.9261353E+03,.7646141E+03,.7626244E+03,.9766109E+03,& - & .1176440E+04,.8896203E+03,.7264230E+03,.7260792E+03,.9337937E+03,& - & .1133375E+04,.8546623E+03,.6905960E+03,.6924389E+03,.8940982E+03,& - & .1090677E+04,.8207879E+03,.6569885E+03,.6613756E+03,.8570661E+03,& - & .1048813E+04,.7881007E+03,.6254696E+03,.6327012E+03,.8225054E+03,& - & .1228866E+04,.9332604E+03,.7717386E+03,.7692485E+03,.9842332E+03,& - & .1184837E+04,.8964165E+03,.7330783E+03,.7321425E+03,.9408794E+03,& - & .1141425E+04,.8610630E+03,.6967646E+03,.6979977E+03,.9006456E+03,& - & .1098473E+04,.8268792E+03,.6626986E+03,.6664793E+03,.8631791E+03,& - & .1056323E+04,.7938687E+03,.6308135E+03,.6374322E+03,.8281892E+03,& - & .1241753E+04,.9440723E+03,.7828610E+03,.7798359E+03,.9964019E+03,& - & .1197417E+04,.9066817E+03,.7434365E+03,.7418632E+03,.9522524E+03,& - & .1153661E+04,.8708987E+03,.7064391E+03,.7069149E+03,.9111337E+03,& - & .1110381E+04,.8362458E+03,.6717052E+03,.6746952E+03,.8729740E+03,& - & .1067895E+04,.8028379E+03,.6392420E+03,.6449926E+03,.8372651E+03/ - - data absb(701:875,12) / & - & .1254711E+04,.9552218E+03,.7944804E+03,.7910279E+03,.1009186E+04,& - & .1210280E+04,.9173371E+03,.7543339E+03,.7521533E+03,.9642251E+03,& - & .1166182E+04,.8810139E+03,.7165982E+03,.7163206E+03,.9222282E+03,& - & .1122776E+04,.8459987E+03,.6811757E+03,.6833364E+03,.8832595E+03,& - & .1079901E+04,.8122269E+03,.6480909E+03,.6529289E+03,.8468137E+03,& - & .1267704E+04,.9665631E+03,.8063197E+03,.8024662E+03,.1022026E+04,& - & .1222982E+04,.9279730E+03,.7652524E+03,.7624963E+03,.9762665E+03,& - & .1178689E+04,.8911031E+03,.7268015E+03,.7258004E+03,.9333389E+03,& - & .1134938E+04,.8556974E+03,.6907044E+03,.6920393E+03,.8935613E+03,& - & .1091744E+04,.8215054E+03,.6569768E+03,.6609780E+03,.8565207E+03,& - & .1282885E+04,.9799862E+03,.8205225E+03,.8164768E+03,.1037659E+04,& - & .1238160E+04,.9407046E+03,.7785501E+03,.7751742E+03,.9909163E+03,& - & .1193461E+04,.9032104E+03,.7391944E+03,.7374586E+03,.9470329E+03,& - & .1149466E+04,.8673209E+03,.7023116E+03,.7027833E+03,.9062086E+03,& - & .1106044E+04,.8327209E+03,.6678128E+03,.6708431E+03,.8683165E+03,& - & .1299221E+04,.9946371E+03,.8360635E+03,.8320461E+03,.1054652E+04,& - & .1254105E+04,.9544361E+03,.7930175E+03,.7891647E+03,.1006958E+04,& - & .1209314E+04,.9163157E+03,.7527076E+03,.7503398E+03,.9620928E+03,& - & .1165150E+04,.8800178E+03,.7151041E+03,.7146356E+03,.9201686E+03,& - & .1121407E+04,.8448306E+03,.6796764E+03,.6817394E+03,.8813213E+03,& - & .1315203E+04,.1009411E+04,.8519211E+03,.8481780E+03,.1072024E+04,& - & .1270148E+04,.9683874E+03,.8077450E+03,.8035704E+03,.1023229E+04,& - & .1225178E+04,.9296125E+03,.7664897E+03,.7634566E+03,.9773360E+03,& - & .1180684E+04,.8926430E+03,.7280109E+03,.7267010E+03,.9343522E+03,& - & .1136746E+04,.8570580E+03,.6917330E+03,.6928240E+03,.8944515E+03,& - & .1332014E+04,.1025376E+04,.8690997E+03,.8658147E+03,.1090797E+04,& - & .1287083E+04,.9833984E+03,.8237334E+03,.8194241E+03,.1040908E+04,& - & .1241959E+04,.9438288E+03,.7814714E+03,.7777789E+03,.9938697E+03,& - & .1197174E+04,.9061941E+03,.7419541E+03,.7398805E+03,.9497877E+03,& - & .1152918E+04,.8700812E+03,.7048184E+03,.7049556E+03,.9087731E+03,& - & .1350647E+04,.1043564E+04,.8888305E+03,.8860745E+03,.1112065E+04,& - & .1305779E+04,.1000456E+04,.8419893E+03,.8378345E+03,.1060921E+04,& - & .1260705E+04,.9599420E+03,.7984917E+03,.7943099E+03,.1012757E+04,& - & .1215666E+04,.9215564E+03,.7578604E+03,.7550366E+03,.9674587E+03,& - & .1171119E+04,.8847872E+03,.7197368E+03,.7188825E+03,.9251420E+03/ - - data absb(876:1050,12) / & - & .1369025E+04,.1061988E+04,.9090576E+03,.9070507E+03,.1133822E+04,& - & .1324283E+04,.1017792E+04,.8607146E+03,.8569957E+03,.1081438E+04,& - & .1279221E+04,.9763247E+03,.8159408E+03,.8115038E+03,.1032081E+04,& - & .1234106E+04,.9370840E+03,.7741603E+03,.7706394E+03,.9855998E+03,& - & .1189255E+04,.8996323E+03,.7349893E+03,.7332176E+03,.9419966E+03,& - & .1387296E+04,.1080897E+04,.9299250E+03,.9288068E+03,.1156040E+04,& - & .1342857E+04,.1035650E+04,.8800130E+03,.8768348E+03,.1102421E+04,& - & .1297820E+04,.9930678E+03,.8338259E+03,.8293976E+03,.1051801E+04,& - & .1252579E+04,.9528599E+03,.7908416E+03,.7867574E+03,.1004167E+04,& - & .1207574E+04,.9146924E+03,.7505619E+03,.7480415E+03,.9593335E+03,& - & .1404104E+04,.1098935E+04,.9500783E+03,.9498735E+03,.1177271E+04,& - & .1360008E+04,.1052670E+04,.8986275E+03,.8960550E+03,.1122511E+04,& - & .1315196E+04,.1009091E+04,.8510987E+03,.8469719E+03,.1070745E+04,& - & .1269965E+04,.9680021E+03,.8068947E+03,.8024578E+03,.1021945E+04,& - & .1224670E+04,.9290678E+03,.7655748E+03,.7624022E+03,.9760562E+03,& - & .1420396E+04,.1116667E+04,.9703151E+03,.9709136E+03,.1198267E+04,& - & .1376519E+04,.1069496E+04,.9171148E+03,.9153343E+03,.1142380E+04,& - & .1331895E+04,.1024943E+04,.8682037E+03,.8645664E+03,.1089458E+04,& - & .1286713E+04,.9828640E+03,.8228042E+03,.8182606E+03,.1039599E+04,& - & .1241514E+04,.9432594E+03,.7805968E+03,.7767631E+03,.9926584E+03,& - & .1436295E+04,.1134602E+04,.9911820E+03,.9925055E+03,.1219679E+04,& - & .1392861E+04,.1086682E+04,.9361507E+03,.9351807E+03,.1162507E+04,& - & .1348464E+04,.1041116E+04,.8857605E+03,.8826630E+03,.1108509E+04,& - & .1303445E+04,.9981438E+03,.8391267E+03,.8346717E+03,.1057512E+04,& - & .1258155E+04,.9576321E+03,.7957736E+03,.7914987E+03,.1009530E+04,& - & .1451947E+04,.1152803E+04,.1012912E+04,.1014725E+04,.1241375E+04,& - & .1409171E+04,.1104184E+04,.9558739E+03,.9558293E+03,.1183310E+04,& - & .1365042E+04,.1057601E+04,.9039098E+03,.9014495E+03,.1128065E+04,& - & .1320122E+04,.1013646E+04,.8559028E+03,.8518298E+03,.1075944E+04,& - & .1274918E+04,.9723353E+03,.8114299E+03,.8068514E+03,.1026857E+04,& - & .1466066E+04,.1169745E+04,.1033600E+04,.1035678E+04,.1261517E+04,& - & .1423885E+04,.1120363E+04,.9744091E+03,.9750701E+03,.1202414E+04,& - & .1380086E+04,.1073062E+04,.9208922E+03,.9191581E+03,.1146254E+04,& - & .1335390E+04,.1028184E+04,.8716013E+03,.8680259E+03,.1093132E+04,& - & .1290197E+04,.9859694E+03,.8260174E+03,.8214000E+03,.1043057E+04/ - - data absb(1051:1175,12) / & - & .1479052E+04,.1186138E+04,.1053992E+04,.1056277E+04,.1281061E+04,& - & .1437721E+04,.1136174E+04,.9928663E+03,.9941031E+03,.1221167E+04,& - & .1394340E+04,.1088094E+04,.9376415E+03,.9367024E+03,.1164059E+04,& - & .1349933E+04,.1042434E+04,.8871475E+03,.8840194E+03,.1109960E+04,& - & .1304838E+04,.9993418E+03,.8403647E+03,.8358995E+03,.1058827E+04,& - & .1492071E+04,.1202807E+04,.1075082E+04,.1077418E+04,.1300751E+04,& - & .1451378E+04,.1152078E+04,.1011888E+04,.1013598E+04,.1240207E+04,& - & .1408590E+04,.1103420E+04,.9548463E+03,.9546446E+03,.1182081E+04,& - & .1364310E+04,.1056805E+04,.9029595E+03,.9004074E+03,.1127003E+04,& - & .1319414E+04,.1012901E+04,.8550197E+03,.8508617E+03,.1074911E+04,& - & .1504643E+04,.1219744E+04,.1096579E+04,.1098934E+04,.1320376E+04,& - & .1464791E+04,.1168191E+04,.1031579E+04,.1033563E+04,.1259497E+04,& - & .1422597E+04,.1118810E+04,.9725173E+03,.9730206E+03,.1200352E+04,& - & .1378559E+04,.1071486E+04,.9191235E+03,.9172829E+03,.1144372E+04,& - & .1333898E+04,.1026715E+04,.8699929E+03,.8663091E+03,.1091312E+04,& - & .1516339E+04,.1236030E+04,.1117522E+04,.1119831E+04,.1339023E+04,& - & .1477239E+04,.1183650E+04,.1050741E+04,.1052932E+04,.1277904E+04,& - & .1435679E+04,.1133650E+04,.9897694E+03,.9909248E+03,.1218096E+04,& - & .1392107E+04,.1085680E+04,.9348858E+03,.9337357E+03,.1161095E+04,& - & .1347658E+04,.1040131E+04,.8845784E+03,.8813290E+03,.1107099E+04,& - & .1520825E+04,.1242563E+04,.1126048E+04,.1128336E+04,.1346460E+04,& - & .1482173E+04,.1189885E+04,.1058578E+04,.1060811E+04,.1285327E+04,& - & .1440948E+04,.1139665E+04,.9968499E+03,.9981671E+03,.1225222E+04,& - & .1397470E+04,.1091462E+04,.9413190E+03,.9405053E+03,.1167923E+04,& - & .1353151E+04,.1045578E+04,.8905298E+03,.8874634E+03,.1113520E+04/ - -! --- - data forref(1:4,1:12) / .5532580E-03,.5554860E-03,.6013390E-03,& - & .7082800E-03,.1585580E-02,.1629570E-02,.2049910E-02,.4758810E-02,& - & .7725420E-02,.7845620E-02,.1119790E-01,.2290160E-01,.2550970E-01,& - & .2562720E-01,.2706910E-01,.2595050E-01,.3232630E-01,.3244950E-01,& - & .3055350E-01,.2639930E-01,.3557280E-01,.3564191E-01,.3329601E-01,& - & .2956313E-01,.3784510E-01,.3753410E-01,.3743690E-01,.3203340E-01,& - & .4098704E-01,.3991769E-01,.3953723E-01,.3197576E-01,.4282540E-01,& - & .4411510E-01,.4088870E-01,.3270770E-01,.4529070E-01,.4526648E-01,& - & .4032414E-01,.3589280E-01,.4839280E-01,.4772840E-01,.3806840E-01,& - & .3879400E-01,.5074618E-01,.4940565E-01,.4711472E-01,.3831108E-01/ - -! the array selfref contains the coefficient of the water vapor -! self-continuum (including the energy term). the first index -! refers to temperature in 7.2 degree increments. for instance, -! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, -! etc. the second index runs over the g-channel (1 to NG17). - - data selfref(1:10,1:12) / & - & .1605370E-01,.1490380E-01,.1383630E-01,.1284520E-01,.1192510E-01,& - & .1107090E-01,.1027790E-01,.9541750E-02,.8858290E-02,.8223790E-02,& - & .3657530E-01,.3422670E-01,.3202880E-01,.2997200E-01,.2804740E-01,& - & .2624630E-01,.2456090E-01,.2298370E-01,.2150780E-01,.2012670E-01,& - & .1274190E+00,.1185530E+00,.1103040E+00,.1026290E+00,.9548830E-01,& - & .8884420E-01,.8266240E-01,.7691070E-01,.7155930E-01,.6658020E-01,& - & .3786870E+00,.3489610E+00,.3215680E+00,.2963250E+00,.2730640E+00,& - & .2516290E+00,.2318760E+00,.2136740E+00,.1969010E+00,.1814440E+00,& - & .4728220E+00,.4350180E+00,.4002360E+00,.3682360E+00,.3387940E+00,& - & .3117060E+00,.2867830E+00,.2638540E+00,.2427570E+00,.2233480E+00,& - & .5168017E+00,.4753661E+00,.4372531E+00,.4021962E+00,.3699493E+00,& - & .3402876E+00,.3130049E+00,.2879097E+00,.2648259E+00,.2435933E+00,& - & .5402220E+00,.4977460E+00,.4586100E+00,.4225510E+00,.3893270E+00,& - & .3587160E+00,.3305110E+00,.3045240E+00,.2805800E+00,.2585190E+00,& - & .5700865E+00,.5267717E+00,.4867481E+00,.4497659E+00,.4155940E+00,& - & .3840184E+00,.3548416E+00,.3278825E+00,.3029720E+00,.2799538E+00,& - & .6451760E+00,.5889570E+00,.5376360E+00,.4907880E+00,.4480220E+00,& - & .4089820E+00,.3733440E+00,.3408120E+00,.3111140E+00,.2840040E+00,& - & .6556933E+00,.6013742E+00,.5515585E+00,.5058718E+00,.4639719E+00,& - & .4255448E+00,.3903026E+00,.3579808E+00,.3283371E+00,.3011502E+00,& - & .6925540E+00,.6355740E+00,.5832820E+00,.5352930E+00,.4912510E+00,& - & .4508340E+00,.4137410E+00,.3797010E+00,.3484610E+00,.3197910E+00,& - & .7229700E+00,.6637789E+00,.6094446E+00,.5595658E+00,.5137786E+00,& - & .4717450E+00,.4331576E+00,.3977321E+00,.3652099E+00,.3353523E+00/ - -!........................................! - end module module_radsw_kgb17 ! -!========================================! - - -!========================================! - module module_radsw_kgb18 ! -!........................................! -! -! ********* the original program descriptions ********* ! -! ! -! originally by j.delamere, atmospheric & environmental research. ! -! revision: 2.4 ! -! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4) ! -! reformatted for f90 by jjmorcrette, ecmwf ! -! ! -! this table has been re-generated for reduced number of g-point ! -! by y.t.hou, ncep ! -! ! -! ********* ********* end description ********* ********* ! -! - use machine, only : kind_phys - use module_radsw_parameters, only : NG18 - -! - implicit none -! - private -! - integer, public :: MSA18, MSB18, MSF18, MFR18 - parameter (MSA18=585, MSB18=235, MSF18=10, MFR18=3) - - real (kind=kind_phys), public :: selfref(MSF18,NG18), & - & absa(MSA18,NG18), absb(MSB18,NG18), forref(MFR18,NG18) - -! --- rayleigh extinction coefficient at v = 4325 cm-1. - real (kind=kind_phys), parameter, public :: rayl = 1.39e-09 - -! the array absa(585,NG18) (ka(9,5,13,NG18)) contains absorption coefs at -! the 16 chosen g-values for a range of pressure levels> ~100mb, -! temperatures, and binary species parameters (see taumol.f for definition). -! the first index in the array, js, runs from 1 to 9, and corresponds -! to different values of the binary species parameter. for instance, -! js=1 refers to dry air, js = 2 corresponds to the paramter value 1/8, -! js = 3 corresponds to the parameter value 2/8, etc. the second index -! in the array, jt, which runs from 1 to 5, corresponds to different -! temperatures. more specifically, Jt = 3 means that the data are for -! the reference temperature tref for this pressure level, jt = 2 refers -! to tref-15, jt = 1 is for tref-30, jt = 4 is for tref+15, and jt = 5 -! is for tref+30. the third index, jp, runs from 1 to 13 and refers -! to the jpth reference pressure level (see taumol.f for these levels -! in mb). the fourth index, ig, goes from 1 to 8, and indicates -! which g-interval the absorption coefficients are for. - - data absa( 1:180, 1) / & - & .1481300E-04,.3984200E-04,.4336200E-04,.4309500E-04,.3981100E-04,& - & .3499400E-04,.2898400E-04,.2060900E-04,.1884500E-05,.1443200E-04,& - & .3874900E-04,.4211900E-04,.4183400E-04,.3890000E-04,.3436500E-04,& - & .2857100E-04,.2050300E-04,.1471500E-05,.1396900E-04,.3766600E-04,& - & .4094200E-04,.4070300E-04,.3798200E-04,.3373100E-04,.2815800E-04,& - & .2035100E-04,.1084200E-05,.1336700E-04,.3660500E-04,.3972900E-04,& - & .3952900E-04,.3703300E-04,.3309600E-04,.2769000E-04,.2015400E-04,& - & .7870200E-06,.1276500E-04,.3558400E-04,.3853600E-04,.3836100E-04,& - & .3607300E-04,.3238400E-04,.2724200E-04,.1993200E-04,.5829600E-06,& - & .1229900E-04,.3417900E-04,.3740500E-04,.3753500E-04,.3471400E-04,& - & .3033500E-04,.2489200E-04,.1752400E-04,.1330100E-05,.1206400E-04,& - & .3322500E-04,.3635700E-04,.3651200E-04,.3387000E-04,.2978900E-04,& - & .2457800E-04,.1743500E-04,.1021700E-05,.1169700E-04,.3230100E-04,& - & .3531600E-04,.3548100E-04,.3304900E-04,.2922600E-04,.2423300E-04,& - & .1730400E-04,.7215200E-06,.1120900E-04,.3139500E-04,.3426300E-04,& - & .3443600E-04,.3217300E-04,.2861000E-04,.2384700E-04,.1716100E-04,& - & .5178700E-06,.1070600E-04,.3049600E-04,.3331100E-04,.3339600E-04,& - & .3129500E-04,.2800200E-04,.2344500E-04,.1697100E-04,.4023000E-06,& - & .1027100E-04,.2927300E-04,.3204900E-04,.3236500E-04,.2985700E-04,& - & .2617100E-04,.2135200E-04,.1481400E-04,.8047000E-06,.1005800E-04,& - & .2845800E-04,.3119600E-04,.3144000E-04,.2913300E-04,.2564000E-04,& - & .2105600E-04,.1475600E-04,.5301000E-06,.9817200E-05,.2765100E-04,& - & .3035200E-04,.3060900E-04,.2839600E-04,.2511000E-04,.2073000E-04,& - & .1465500E-04,.3865200E-06,.9457700E-05,.2687400E-04,.2947500E-04,& - & .2974900E-04,.2766900E-04,.2455300E-04,.2040000E-04,.1453600E-04,& - & .3323600E-06,.9050800E-05,.2612800E-04,.2863100E-04,.2883400E-04,& - & .2695200E-04,.2401500E-04,.2004500E-04,.1438200E-04,.3065900E-06,& - & .8608100E-05,.2489700E-04,.2731700E-04,.2763200E-04,.2546500E-04,& - & .2232800E-04,.1811200E-04,.1246800E-04,.3928600E-06,.8379300E-05,& - & .2427300E-04,.2659000E-04,.2686500E-04,.2487600E-04,.2186700E-04,& - & .1784900E-04,.1242000E-04,.3226600E-06,.8229600E-05,.2358400E-04,& - & .2586900E-04,.2615500E-04,.2425500E-04,.2140300E-04,.1757900E-04,& - & .1233800E-04,.3077500E-06,.7973100E-05,.2291500E-04,.2516600E-04,& - & .2543500E-04,.2362700E-04,.2091700E-04,.1728200E-04,.1224200E-04,& - & .3041800E-06,.7655300E-05,.2225900E-04,.2444000E-04,.2467300E-04,& - & .2300300E-04,.2043700E-04,.1698400E-04,.1211200E-04,.3063800E-06/ - - data absa(181:315, 1) / & - & .7225900E-05,.2108900E-04,.2317700E-04,.2341900E-04,.2158400E-04,& - & .1892600E-04,.1525100E-04,.1041700E-04,.2517000E-06,.7021500E-05,& - & .2056700E-04,.2254100E-04,.2278800E-04,.2110200E-04,.1852600E-04,& - & .1504900E-04,.1037900E-04,.2595800E-06,.6849000E-05,.2001800E-04,& - & .2193800E-04,.2220600E-04,.2057900E-04,.1813900E-04,.1480600E-04,& - & .1031300E-04,.2666600E-06,.6697300E-05,.1944400E-04,.2134000E-04,& - & .2161500E-04,.2007000E-04,.1772800E-04,.1455400E-04,.1023900E-04,& - & .2858900E-06,.6480800E-05,.1888300E-04,.2073800E-04,.2099400E-04,& - & .1954600E-04,.1730400E-04,.1430600E-04,.1014800E-04,.3088600E-06,& - & .6072700E-05,.1779400E-04,.1960900E-04,.1976900E-04,.1822800E-04,& - & .1594600E-04,.1279300E-04,.8655900E-05,.1855900E-06,.5894900E-05,& - & .1739000E-04,.1905900E-04,.1924400E-04,.1782000E-04,.1564700E-04,& - & .1262600E-04,.8635400E-05,.1954400E-06,.5726800E-05,.1693500E-04,& - & .1856400E-04,.1872400E-04,.1740200E-04,.1530400E-04,.1243300E-04,& - & .8588200E-05,.2203300E-06,.5624300E-05,.1645900E-04,.1805400E-04,& - & .1826300E-04,.1698400E-04,.1497100E-04,.1221500E-04,.8526800E-05,& - & .2507200E-06,.5458400E-05,.1598400E-04,.1754800E-04,.1777300E-04,& - & .1655100E-04,.1460100E-04,.1200400E-04,.8456800E-05,.2811000E-06,& - & .5062400E-05,.1496300E-04,.1648200E-04,.1661100E-04,.1533900E-04,& - & .1333300E-04,.1065600E-04,.7157000E-05,.1345300E-06,.4942800E-05,& - & .1463600E-04,.1604000E-04,.1618100E-04,.1499200E-04,.1314400E-04,& - & .1053300E-04,.7153200E-05,.1562000E-06,.4795500E-05,.1425600E-04,& - & .1561100E-04,.1573500E-04,.1464300E-04,.1286500E-04,.1039000E-04,& - & .7124800E-05,.1857100E-06,.4674300E-05,.1387600E-04,.1521300E-04,& - & .1534200E-04,.1429300E-04,.1257600E-04,.1021500E-04,.7073500E-05,& - & .2138200E-06,.4570800E-05,.1347300E-04,.1478200E-04,.1494700E-04,& - & .1393300E-04,.1227400E-04,.1003600E-04,.7017700E-05,.2441900E-06/ - - data absa(316:450, 1) / & - & .4228900E-05,.1252800E-04,.1381700E-04,.1392200E-04,.1286700E-04,& - & .1112600E-04,.8846800E-05,.5901000E-05,.1060000E-06,.4131900E-05,& - & .1228600E-04,.1348000E-04,.1358200E-04,.1258400E-04,.1097300E-04,& - & .8764400E-05,.5904900E-05,.1295100E-06,.4031700E-05,.1199600E-04,& - & .1311600E-04,.1320600E-04,.1229500E-04,.1078600E-04,.8653700E-05,& - & .5889800E-05,.1573100E-06,.3910700E-05,.1166600E-04,.1277100E-04,& - & .1287000E-04,.1201000E-04,.1054600E-04,.8524400E-05,.5853600E-05,& - & .1871600E-06,.3838400E-05,.1134600E-04,.1243500E-04,.1254900E-04,& - & .1170600E-04,.1028900E-04,.8375600E-05,.5810400E-05,.2167900E-06,& - & .3524000E-05,.1041800E-04,.1155800E-04,.1168700E-04,.1074800E-04,& - & .9230500E-05,.7319800E-05,.4851400E-05,.1017600E-06,.3447800E-05,& - & .1029600E-04,.1129600E-04,.1136900E-04,.1053200E-04,.9137500E-05,& - & .7273700E-05,.4863900E-05,.1269500E-06,.3371800E-05,.1006800E-04,& - & .1099600E-04,.1106300E-04,.1029000E-04,.8995700E-05,.7184400E-05,& - & .4858300E-05,.1548200E-06,.3280100E-05,.9799000E-05,.1071200E-04,& - & .1076200E-04,.1005600E-04,.8825500E-05,.7090700E-05,.4836400E-05,& - & .1812300E-06,.3196000E-05,.9535000E-05,.1042700E-04,.1050100E-04,& - & .9805600E-05,.8615700E-05,.6972300E-05,.4801000E-05,.2073800E-06,& - & .2919700E-05,.8618300E-05,.9610000E-05,.9744800E-05,.8918700E-05,& - & .7635400E-05,.6031800E-05,.3973300E-05,.1031000E-06,.2867700E-05,& - & .8556500E-05,.9419100E-05,.9468200E-05,.8765300E-05,.7572500E-05,& - & .6008900E-05,.3995600E-05,.1295100E-06,.2803600E-05,.8412100E-05,& - & .9190200E-05,.9225100E-05,.8581100E-05,.7465300E-05,.5945200E-05,& - & .3996700E-05,.1568400E-06,.2742000E-05,.8203500E-05,.8944000E-05,& - & .8974800E-05,.8381700E-05,.7342200E-05,.5872500E-05,.3984400E-05,& - & .1856400E-06,.2659600E-05,.7973900E-05,.8707400E-05,.8750800E-05,& - & .8178400E-05,.7178100E-05,.5781500E-05,.3956900E-05,.2147600E-06/ - - data absa(451:585, 1) / & - & .2398800E-05,.7113500E-05,.7912100E-05,.8011800E-05,.7337000E-05,& - & .6284400E-05,.4961000E-05,.3264100E-05,.9169700E-07,.2355200E-05,& - & .7058700E-05,.7751900E-05,.7782100E-05,.7211300E-05,.6229700E-05,& - & .4940700E-05,.3281500E-05,.1130700E-06,.2304600E-05,.6936700E-05,& - & .7566200E-05,.7579000E-05,.7063100E-05,.6140900E-05,.4886700E-05,& - & .3281200E-05,.1371500E-06,.2255700E-05,.6763200E-05,.7364000E-05,& - & .7377200E-05,.6897200E-05,.6038100E-05,.4825400E-05,.3270500E-05,& - & .1643600E-06,.2189900E-05,.6574800E-05,.7169500E-05,.7194600E-05,& - & .6729500E-05,.5902200E-05,.4748800E-05,.3247600E-05,.1902500E-06,& - & .1969900E-05,.5867000E-05,.6507500E-05,.6580800E-05,.6030000E-05,& - & .5166500E-05,.4074900E-05,.2678800E-05,.7710000E-07,.1934800E-05,& - & .5814600E-05,.6373000E-05,.6389100E-05,.5926000E-05,.5119600E-05,& - & .4057700E-05,.2692600E-05,.9569300E-07,.1894700E-05,.5713400E-05,& - & .6220700E-05,.6223800E-05,.5809000E-05,.5045900E-05,.4011300E-05,& - & .2691600E-05,.1157200E-06,.1855200E-05,.5570900E-05,.6052200E-05,& - & .6061100E-05,.5669300E-05,.4959400E-05,.3960600E-05,.2682400E-05,& - & .1379700E-06,.1804000E-05,.5413700E-05,.5893500E-05,.5909600E-05,& - & .5529400E-05,.4844300E-05,.3897700E-05,.2663300E-05,.1588400E-06,& - & .1616700E-05,.4827200E-05,.5347500E-05,.5398300E-05,.4950300E-05,& - & .4241300E-05,.3343100E-05,.2195600E-05,.6138100E-07,.1589500E-05,& - & .4780900E-05,.5234200E-05,.5240900E-05,.4865200E-05,.4202100E-05,& - & .3326300E-05,.2207200E-05,.7638200E-07,.1558200E-05,.4698200E-05,& - & .5105500E-05,.5105800E-05,.4771600E-05,.4140600E-05,.3288600E-05,& - & .2205800E-05,.9308300E-07,.1524200E-05,.4583100E-05,.4969600E-05,& - & .4973500E-05,.4653400E-05,.4067800E-05,.3246900E-05,.2196900E-05,& - & .1121100E-06,.1485900E-05,.4449200E-05,.4839200E-05,.4847900E-05,& - & .4537800E-05,.3968900E-05,.3193300E-05,.2181300E-05,.1297000E-06/ - - data absa( 1:180, 2) / & - & .1013800E-03,.2045600E-03,.2211700E-03,.2194800E-03,.2080500E-03,& - & .1837300E-03,.1499900E-03,.9538200E-04,.3321300E-05,.1014100E-03,& - & .2088900E-03,.2245600E-03,.2222300E-03,.2091200E-03,.1846700E-03,& - & .1506000E-03,.9571300E-04,.2847900E-05,.1012500E-03,.2122300E-03,& - & .2271200E-03,.2238800E-03,.2098300E-03,.1851300E-03,.1510000E-03,& - & .9588100E-04,.2633800E-05,.1010500E-03,.2144200E-03,.2286300E-03,& - & .2242100E-03,.2104600E-03,.1854000E-03,.1506000E-03,.9579800E-04,& - & .2763800E-05,.1004000E-03,.2161200E-03,.2289900E-03,.2241600E-03,& - & .2104600E-03,.1857000E-03,.1500100E-03,.9556900E-04,.2931300E-05,& - & .8963900E-04,.1779700E-03,.1928400E-03,.1898600E-03,.1782400E-03,& - & .1578900E-03,.1290600E-03,.8352400E-04,.2392600E-05,.8949900E-04,& - & .1814400E-03,.1956300E-03,.1922700E-03,.1794100E-03,.1584400E-03,& - & .1296100E-03,.8363200E-04,.2196900E-05,.8941100E-04,.1840100E-03,& - & .1975300E-03,.1935000E-03,.1799900E-03,.1588300E-03,.1298900E-03,& - & .8357700E-04,.2315800E-05,.8884100E-04,.1854100E-03,.1987200E-03,& - & .1939800E-03,.1805300E-03,.1590700E-03,.1297200E-03,.8339600E-04,& - & .2376000E-05,.8794900E-04,.1865900E-03,.1990200E-03,.1940700E-03,& - & .1807300E-03,.1591000E-03,.1293700E-03,.8312000E-04,.2524700E-05,& - & .7746600E-04,.1526400E-03,.1670400E-03,.1634200E-03,.1530000E-03,& - & .1349900E-03,.1100700E-03,.7188100E-04,.1783900E-05,.7748300E-04,& - & .1561100E-03,.1695000E-03,.1655100E-03,.1540800E-03,.1358000E-03,& - & .1105500E-03,.7202000E-04,.1856400E-05,.7714200E-04,.1586700E-03,& - & .1711200E-03,.1667200E-03,.1548100E-03,.1361600E-03,.1107700E-03,& - & .7192200E-04,.2022800E-05,.7646000E-04,.1605800E-03,.1718600E-03,& - & .1671700E-03,.1551900E-03,.1364100E-03,.1106000E-03,.7177500E-04,& - & .2171700E-05,.7551000E-04,.1615800E-03,.1721000E-03,.1673000E-03,& - & .1552100E-03,.1364900E-03,.1102200E-03,.7151600E-04,.2314000E-05,& - & .6593100E-04,.1294000E-03,.1429500E-03,.1400500E-03,.1309500E-03,& - & .1149400E-03,.9365600E-04,.6116700E-04,.1709400E-05,.6609000E-04,& - & .1326900E-03,.1454200E-03,.1423300E-03,.1320100E-03,.1155800E-03,& - & .9397500E-04,.6143600E-04,.1852700E-05,.6563000E-04,.1353200E-03,& - & .1471700E-03,.1436400E-03,.1326600E-03,.1160400E-03,.9412600E-04,& - & .6146700E-04,.1957600E-05,.6497100E-04,.1370800E-03,.1481800E-03,& - & .1442700E-03,.1330400E-03,.1161600E-03,.9415200E-04,.6133400E-04,& - & .2061400E-05,.6412200E-04,.1383400E-03,.1486400E-03,.1445100E-03,& - & .1331200E-03,.1163800E-03,.9395500E-04,.6116200E-04,.2164000E-05/ - - data absa(181:315, 2) / & - & .5559400E-04,.1083000E-03,.1206800E-03,.1186500E-03,.1112700E-03,& - & .9792500E-04,.7920800E-04,.5184200E-04,.1595400E-05,.5566900E-04,& - & .1111700E-03,.1229900E-03,.1209100E-03,.1124800E-03,.9864300E-04,& - & .7943300E-04,.5212700E-04,.1696600E-05,.5543000E-04,.1134500E-03,& - & .1247800E-03,.1223500E-03,.1133200E-03,.9911700E-04,.7982300E-04,& - & .5228600E-04,.1830400E-05,.5480000E-04,.1154300E-03,.1260100E-03,& - & .1230400E-03,.1138900E-03,.9934600E-04,.7993500E-04,.5227500E-04,& - & .1947900E-05,.5402700E-04,.1166500E-03,.1266000E-03,.1233900E-03,& - & .1141000E-03,.9953500E-04,.7984000E-04,.5216800E-04,.2058300E-05,& - & .4650000E-04,.8988700E-04,.1004800E-03,.9916100E-04,.9313600E-04,& - & .8227900E-04,.6687200E-04,.4361700E-04,.1473000E-05,.4663200E-04,& - & .9244400E-04,.1027100E-03,.1012300E-03,.9455900E-04,.8313500E-04,& - & .6720400E-04,.4404600E-04,.1621500E-05,.4649000E-04,.9441500E-04,& - & .1044600E-03,.1026900E-03,.9538700E-04,.8367600E-04,.6757900E-04,& - & .4427900E-04,.1735800E-05,.4600400E-04,.9619000E-04,.1057000E-03,& - & .1034600E-03,.9588300E-04,.8403800E-04,.6775300E-04,.4434800E-04,& - & .1809600E-05,.4536200E-04,.9751100E-04,.1064500E-03,.1038400E-03,& - & .9619700E-04,.8434700E-04,.6775800E-04,.4430500E-04,.1888200E-05,& - & .3859700E-04,.7401900E-04,.8288200E-04,.8180700E-04,.7693600E-04,& - & .6827800E-04,.5574400E-04,.3650700E-04,.1340000E-05,.3872800E-04,& - & .7635300E-04,.8503000E-04,.8382200E-04,.7852300E-04,.6922100E-04,& - & .5619900E-04,.3693200E-04,.1476600E-05,.3868800E-04,.7816400E-04,& - & .8669100E-04,.8526900E-04,.7942400E-04,.6984900E-04,.5650700E-04,& - & .3721100E-04,.1607700E-05,.3839900E-04,.7965400E-04,.8788200E-04,& - & .8614500E-04,.7991700E-04,.7021400E-04,.5669800E-04,.3730200E-04,& - & .1736500E-05,.3789900E-04,.8101200E-04,.8870600E-04,.8658900E-04,& - & .8025900E-04,.7042900E-04,.5681000E-04,.3728700E-04,.1859500E-05/ - - data absa(316:450, 2) / & - & .3195900E-04,.6067100E-04,.6796300E-04,.6705300E-04,.6305700E-04,& - & .5628700E-04,.4618700E-04,.3029800E-04,.1207100E-05,.3206200E-04,& - & .6275300E-04,.6989200E-04,.6894100E-04,.6462400E-04,.5718700E-04,& - & .4656600E-04,.3068700E-04,.1358200E-05,.3209800E-04,.6443500E-04,& - & .7142300E-04,.7035900E-04,.6564600E-04,.5788200E-04,.4689700E-04,& - & .3099300E-04,.1521700E-05,.3195600E-04,.6575800E-04,.7265000E-04,& - & .7127500E-04,.6627500E-04,.5829800E-04,.4710000E-04,.3107900E-04,& - & .1679400E-05,.3158400E-04,.6691600E-04,.7350200E-04,.7181900E-04,& - & .6661100E-04,.5850500E-04,.4724300E-04,.3108800E-04,.1825000E-05,& - & .2635500E-04,.4947200E-04,.5541500E-04,.5458400E-04,.5136100E-04,& - & .4613500E-04,.3802700E-04,.2498300E-04,.1354900E-05,.2647200E-04,& - & .5130200E-04,.5716500E-04,.5641700E-04,.5293600E-04,.4704800E-04,& - & .3841700E-04,.2534700E-04,.1494100E-05,.2654500E-04,.5286600E-04,& - & .5856300E-04,.5777600E-04,.5398800E-04,.4770600E-04,.3873900E-04,& - & .2563800E-04,.1656300E-05,.2646900E-04,.5410500E-04,.5974900E-04,& - & .5874600E-04,.5466800E-04,.4816100E-04,.3897000E-04,.2574400E-04,& - & .1826200E-05,.2624800E-04,.5507900E-04,.6061900E-04,.5931700E-04,& - & .5509900E-04,.4843500E-04,.3911500E-04,.2577800E-04,.2023800E-05,& - & .2163100E-04,.4029700E-04,.4517000E-04,.4429800E-04,.4187600E-04,& - & .3769000E-04,.3121200E-04,.2055200E-04,.1632800E-05,.2181400E-04,& - & .4189600E-04,.4668100E-04,.4606500E-04,.4322700E-04,.3860800E-04,& - & .3161400E-04,.2085700E-04,.1861000E-05,.2186400E-04,.4324700E-04,& - & .4794500E-04,.4732700E-04,.4427300E-04,.3920100E-04,.3189400E-04,& - & .2111900E-04,.2077500E-05,.2183500E-04,.4438600E-04,.4898600E-04,& - & .4822800E-04,.4491600E-04,.3963700E-04,.3209300E-04,.2122800E-04,& - & .2254100E-05,.2172800E-04,.4526300E-04,.4980400E-04,.4881800E-04,& - & .4540900E-04,.3995000E-04,.3226900E-04,.2129000E-04,.2452500E-05/ - - data absa(451:585, 2) / & - & .1782300E-04,.3337800E-04,.3733700E-04,.3661900E-04,.3459800E-04,& - & .3111300E-04,.2576100E-04,.1695600E-04,.1504200E-05,.1797000E-04,& - & .3467900E-04,.3858900E-04,.3806500E-04,.3569500E-04,.3186900E-04,& - & .2604400E-04,.1721400E-04,.1684700E-05,.1799700E-04,.3579100E-04,& - & .3961900E-04,.3909700E-04,.3653900E-04,.3237400E-04,.2629800E-04,& - & .1742800E-04,.1888700E-05,.1796700E-04,.3671700E-04,.4046300E-04,& - & .3982100E-04,.3707100E-04,.3271600E-04,.2646100E-04,.1749600E-04,& - & .2054600E-05,.1786800E-04,.3742300E-04,.4112400E-04,.4030400E-04,& - & .3747300E-04,.3297100E-04,.2661200E-04,.1753200E-04,.2224000E-05,& - & .1466500E-04,.2760500E-04,.3081100E-04,.3025000E-04,.2852500E-04,& - & .2564400E-04,.2118600E-04,.1395500E-04,.1258800E-05,.1477500E-04,& - & .2865500E-04,.3185100E-04,.3140800E-04,.2941800E-04,.2626100E-04,& - & .2143000E-04,.1417200E-04,.1418100E-05,.1479900E-04,.2957100E-04,& - & .3268700E-04,.3224200E-04,.3009300E-04,.2668300E-04,.2163600E-04,& - & .1433800E-04,.1561900E-05,.1477700E-04,.3032500E-04,.3337100E-04,& - & .3282600E-04,.3055300E-04,.2694500E-04,.2177500E-04,.1438000E-04,& - & .1691700E-05,.1468500E-04,.3090400E-04,.3390700E-04,.3321400E-04,& - & .3087500E-04,.2715800E-04,.2188300E-04,.1441400E-04,.1842300E-05,& - & .1204400E-04,.2277200E-04,.2537500E-04,.2492600E-04,.2345800E-04,& - & .2105900E-04,.1738700E-04,.1145700E-04,.9912200E-06,.1212800E-04,& - & .2363700E-04,.2624900E-04,.2584200E-04,.2418700E-04,.2158200E-04,& - & .1759000E-04,.1163600E-04,.1103700E-05,.1215200E-04,.2438600E-04,& - & .2691000E-04,.2653100E-04,.2473100E-04,.2192300E-04,.1776000E-04,& - & .1175500E-04,.1202600E-05,.1213000E-04,.2499600E-04,.2746400E-04,& - & .2700600E-04,.2511300E-04,.2213800E-04,.1787400E-04,.1179700E-04,& - & .1302800E-05,.1205000E-04,.2547400E-04,.2789500E-04,.2729700E-04,& - & .2537300E-04,.2230200E-04,.1794800E-04,.1181700E-04,.1401000E-05/ - - data absa( 1:180, 3) / & - & .3682300E-03,.4961300E-03,.5181700E-03,.5053800E-03,.4571100E-03,& - & .3960500E-03,.3148600E-03,.2147400E-03,.1093200E-04,.3700800E-03,& - & .5077800E-03,.5336100E-03,.5177800E-03,.4699500E-03,.4062900E-03,& - & .3230900E-03,.2187800E-03,.1142100E-04,.3698900E-03,.5181200E-03,& - & .5469900E-03,.5292200E-03,.4803600E-03,.4155900E-03,.3296500E-03,& - & .2222600E-03,.1239500E-04,.3672100E-03,.5276300E-03,.5574600E-03,& - & .5395700E-03,.4889100E-03,.4231300E-03,.3354500E-03,.2258800E-03,& - & .1351500E-04,.3631300E-03,.5365200E-03,.5668000E-03,.5479100E-03,& - & .4966400E-03,.4290700E-03,.3404300E-03,.2291600E-03,.1473400E-04,& - & .3241100E-03,.4281500E-03,.4472500E-03,.4381300E-03,.4015000E-03,& - & .3487100E-03,.2791200E-03,.1892900E-03,.8074100E-05,.3256700E-03,& - & .4378600E-03,.4606900E-03,.4502700E-03,.4131900E-03,.3581900E-03,& - & .2863500E-03,.1932500E-03,.8734000E-05,.3242900E-03,.4463800E-03,& - & .4722800E-03,.4607400E-03,.4227200E-03,.3660200E-03,.2920100E-03,& - & .1965300E-03,.9611000E-05,.3213700E-03,.4553100E-03,.4814200E-03,& - & .4695100E-03,.4299600E-03,.3725000E-03,.2970900E-03,.1997400E-03,& - & .1069700E-04,.3177600E-03,.4620700E-03,.4888000E-03,.4765900E-03,& - & .4355100E-03,.3777600E-03,.3013800E-03,.2027400E-03,.1170400E-04,& - & .2848800E-03,.3676700E-03,.3808100E-03,.3743800E-03,.3452500E-03,& - & .3015000E-03,.2433200E-03,.1641500E-03,.6397000E-05,.2853900E-03,& - & .3750900E-03,.3919600E-03,.3851000E-03,.3556600E-03,.3099800E-03,& - & .2496300E-03,.1676600E-03,.7200600E-05,.2839700E-03,.3821500E-03,& - & .4015600E-03,.3942800E-03,.3641800E-03,.3172700E-03,.2544600E-03,& - & .1710700E-03,.7957400E-05,.2813400E-03,.3886700E-03,.4095900E-03,& - & .4023000E-03,.3709300E-03,.3230100E-03,.2589800E-03,.1744700E-03,& - & .8713100E-05,.2788600E-03,.3936000E-03,.4164200E-03,.4085200E-03,& - & .3760900E-03,.3274000E-03,.2631200E-03,.1773700E-03,.9470400E-05,& - & .2492300E-03,.3155500E-03,.3242300E-03,.3173100E-03,.2941000E-03,& - & .2567100E-03,.2076200E-03,.1407400E-03,.5587700E-05,.2497700E-03,& - & .3212000E-03,.3337200E-03,.3265700E-03,.3029500E-03,.2647200E-03,& - & .2130300E-03,.1439600E-03,.6157500E-05,.2486500E-03,.3266800E-03,& - & .3418000E-03,.3344600E-03,.3103300E-03,.2714400E-03,.2177700E-03,& - & .1471400E-03,.6791600E-05,.2470900E-03,.3313300E-03,.3484100E-03,& - & .3413400E-03,.3160000E-03,.2764700E-03,.2217900E-03,.1501600E-03,& - & .7465300E-05,.2445500E-03,.3349100E-03,.3538800E-03,.3470800E-03,& - & .3206900E-03,.2800500E-03,.2252200E-03,.1524200E-03,.8161900E-05/ - - data absa(181:315, 3) / & - & .2152600E-03,.2711500E-03,.2750500E-03,.2680200E-03,.2496800E-03,& - & .2169000E-03,.1748100E-03,.1190600E-03,.5085000E-05,.2161100E-03,& - & .2762100E-03,.2829800E-03,.2762000E-03,.2572200E-03,.2241100E-03,& - & .1800400E-03,.1219700E-03,.5573800E-05,.2158300E-03,.2806000E-03,& - & .2895500E-03,.2828200E-03,.2634600E-03,.2300500E-03,.1841500E-03,& - & .1245100E-03,.6086400E-05,.2144600E-03,.2836300E-03,.2946900E-03,& - & .2889600E-03,.2686000E-03,.2343500E-03,.1876800E-03,.1269000E-03,& - & .6641700E-05,.2121700E-03,.2862600E-03,.2992900E-03,.2937000E-03,& - & .2725000E-03,.2376300E-03,.1907300E-03,.1290900E-03,.7212200E-05,& - & .1826200E-03,.2311200E-03,.2338800E-03,.2268100E-03,.2106200E-03,& - & .1819600E-03,.1463400E-03,.9970700E-04,.4807800E-05,.1839300E-03,& - & .2359100E-03,.2409400E-03,.2336400E-03,.2166300E-03,.1881400E-03,& - & .1511400E-03,.1020500E-03,.5225200E-05,.1837900E-03,.2398400E-03,& - & .2467600E-03,.2395600E-03,.2222100E-03,.1935600E-03,.1548900E-03,& - & .1043400E-03,.5640500E-05,.1827000E-03,.2425800E-03,.2510200E-03,& - & .2445800E-03,.2268500E-03,.1977100E-03,.1580500E-03,.1065500E-03,& - & .6072800E-05,.1806700E-03,.2444600E-03,.2546700E-03,.2489400E-03,& - & .2305100E-03,.2005600E-03,.1608800E-03,.1084400E-03,.6516000E-05,& - & .1526900E-03,.1940700E-03,.1964000E-03,.1907300E-03,.1771500E-03,& - & .1522400E-03,.1218100E-03,.8330200E-04,.4518500E-05,.1545000E-03,& - & .1983400E-03,.2024600E-03,.1967500E-03,.1824200E-03,.1577600E-03,& - & .1261000E-03,.8530600E-04,.4931500E-05,.1545900E-03,.2017800E-03,& - & .2075900E-03,.2017600E-03,.1873700E-03,.1623300E-03,.1295100E-03,& - & .8741700E-04,.5349100E-05,.1536800E-03,.2041000E-03,.2116000E-03,& - & .2062300E-03,.1916100E-03,.1660300E-03,.1324600E-03,.8923700E-04,& - & .5756200E-05,.1520700E-03,.2056700E-03,.2145800E-03,.2099100E-03,& - & .1952500E-03,.1690600E-03,.1348100E-03,.9093200E-04,.6165900E-05/ - - data absa(316:450, 3) / & - & .1267200E-03,.1615900E-03,.1632900E-03,.1582100E-03,.1474600E-03,& - & .1262400E-03,.1011600E-03,.6930600E-04,.4665200E-05,.1285300E-03,& - & .1653900E-03,.1685900E-03,.1635900E-03,.1520800E-03,.1312000E-03,& - & .1051300E-03,.7100500E-04,.5139200E-05,.1290100E-03,.1684100E-03,& - & .1730100E-03,.1681300E-03,.1561400E-03,.1353200E-03,.1082900E-03,& - & .7286300E-04,.5524400E-05,.1283300E-03,.1705800E-03,.1765200E-03,& - & .1718400E-03,.1597100E-03,.1386700E-03,.1108700E-03,.7447500E-04,& - & .5819300E-05,.1271500E-03,.1719700E-03,.1791800E-03,.1751300E-03,& - & .1629200E-03,.1414400E-03,.1130100E-03,.7596500E-04,.6170500E-05,& - & .1042800E-03,.1334800E-03,.1346200E-03,.1299500E-03,.1215800E-03,& - & .1037900E-03,.8300500E-04,.5737100E-04,.5596500E-05,.1061900E-03,& - & .1371000E-03,.1393200E-03,.1346900E-03,.1253800E-03,.1080000E-03,& - & .8663200E-04,.5895400E-04,.6196100E-05,.1069000E-03,.1397800E-03,& - & .1431500E-03,.1387700E-03,.1288500E-03,.1116900E-03,.8964300E-04,& - & .6056800E-04,.6852600E-05,.1066800E-03,.1417800E-03,.1462600E-03,& - & .1421300E-03,.1320700E-03,.1146800E-03,.9198400E-04,.6207000E-04,& - & .7512200E-05,.1058200E-03,.1431600E-03,.1487300E-03,.1450100E-03,& - & .1347100E-03,.1170400E-03,.9387600E-04,.6338800E-04,.8076100E-05,& - & .8547600E-04,.1098200E-03,.1103400E-03,.1064300E-03,.9970200E-04,& - & .8496700E-04,.6800800E-04,.4722900E-04,.6614500E-05,.8724200E-04,& - & .1132200E-03,.1146300E-03,.1104500E-03,.1029300E-03,.8858000E-04,& - & .7111300E-04,.4863100E-04,.7545200E-05,.8811100E-04,.1156300E-03,& - & .1179200E-03,.1140400E-03,.1058700E-03,.9187700E-04,.7379000E-04,& - & .5004400E-04,.8488100E-05,.8820000E-04,.1174300E-03,.1206500E-03,& - & .1170800E-03,.1087000E-03,.9448000E-04,.7589700E-04,.5138400E-04,& - & .9513600E-05,.8758300E-04,.1187100E-03,.1229200E-03,.1195400E-03,& - & .1110300E-03,.9652300E-04,.7752600E-04,.5251800E-04,.1053200E-04/ - - data absa(451:585, 3) / & - & .7055600E-04,.9142800E-04,.9186700E-04,.8846300E-04,.8284600E-04,& - & .7077400E-04,.5663200E-04,.3916700E-04,.6187200E-05,.7193300E-04,& - & .9418200E-04,.9526900E-04,.9164600E-04,.8538300E-04,.7373800E-04,& - & .5921900E-04,.4047400E-04,.6996500E-05,.7256700E-04,.9609800E-04,& - & .9792700E-04,.9460600E-04,.8783700E-04,.7637000E-04,.6132600E-04,& - & .4163300E-04,.7823500E-05,.7252900E-04,.9753200E-04,.1001100E-03,& - & .9707600E-04,.9013400E-04,.7842800E-04,.6301600E-04,.4275400E-04,& - & .8790400E-05,.7199000E-04,.9855200E-04,.1019300E-03,.9908000E-04,& - & .9209100E-04,.8006800E-04,.6434900E-04,.4367400E-04,.9801100E-05,& - & .5807200E-04,.7581500E-04,.7616800E-04,.7325200E-04,.6852100E-04,& - & .5874800E-04,.4702900E-04,.3243000E-04,.5183800E-05,.5914900E-04,& - & .7800500E-04,.7888900E-04,.7585300E-04,.7069100E-04,.6116000E-04,& - & .4910500E-04,.3357200E-04,.5866900E-05,.5961500E-04,.7957200E-04,& - & .8104300E-04,.7830100E-04,.7271600E-04,.6326500E-04,.5077700E-04,& - & .3450600E-04,.6646400E-05,.5950600E-04,.8071200E-04,.8281100E-04,& - & .8032100E-04,.7457100E-04,.6493500E-04,.5216500E-04,.3544700E-04,& - & .7441200E-05,.5906700E-04,.8152000E-04,.8428800E-04,.8197700E-04,& - & .7617200E-04,.6625900E-04,.5328100E-04,.3617800E-04,.8246500E-05,& - & .4764000E-04,.6258300E-04,.6288700E-04,.6048500E-04,.5655900E-04,& - & .4862400E-04,.3890400E-04,.2677300E-04,.4058200E-05,.4849800E-04,& - & .6437900E-04,.6508700E-04,.6264100E-04,.5837700E-04,.5057200E-04,& - & .4056600E-04,.2771700E-04,.4661600E-05,.4884400E-04,.6565600E-04,& - & .6685100E-04,.6462800E-04,.6004200E-04,.5225400E-04,.4191700E-04,& - & .2851000E-04,.5320400E-05,.4872200E-04,.6657400E-04,.6830300E-04,& - & .6630000E-04,.6154700E-04,.5361400E-04,.4305800E-04,.2925400E-04,& - & .5944200E-05,.4835500E-04,.6721700E-04,.6951100E-04,.6765100E-04,& - & .6286400E-04,.5471200E-04,.4399800E-04,.2987500E-04,.6643600E-05/ - - data absa( 1:180, 4) / & - & .8538700E-03,.9726800E-03,.9520100E-03,.8922600E-03,.8146500E-03,& - & .6970700E-03,.5482900E-03,.3588200E-03,.3792000E-04,.8549600E-03,& - & .9874600E-03,.9718800E-03,.9177500E-03,.8352900E-03,.7164900E-03,& - & .5637600E-03,.3706100E-03,.4315500E-04,.8515400E-03,.9990800E-03,& - & .9896900E-03,.9401400E-03,.8560400E-03,.7337900E-03,.5783200E-03,& - & .3818300E-03,.4870200E-04,.8460600E-03,.1009000E-02,.1006800E-02,& - & .9594400E-03,.8743400E-03,.7497500E-03,.5924300E-03,.3918800E-03,& - & .5402200E-04,.8406100E-03,.1017100E-02,.1021800E-02,.9768400E-03,& - & .8890600E-03,.7634500E-03,.6047100E-03,.4018000E-03,.5977800E-04,& - & .7610600E-03,.8676300E-03,.8462000E-03,.7933700E-03,.7236800E-03,& - & .6263300E-03,.4916800E-03,.3234600E-03,.3132200E-04,.7615300E-03,& - & .8814800E-03,.8634900E-03,.8155900E-03,.7448000E-03,.6444800E-03,& - & .5063500E-03,.3343000E-03,.3556600E-04,.7597700E-03,.8919500E-03,& - & .8787100E-03,.8360500E-03,.7628600E-03,.6612700E-03,.5195900E-03,& - & .3447200E-03,.3970500E-04,.7577100E-03,.8998700E-03,.8940600E-03,& - & .8553000E-03,.7812300E-03,.6761200E-03,.5322100E-03,.3544700E-03,& - & .4426600E-04,.7528900E-03,.9065700E-03,.9077100E-03,.8720000E-03,& - & .7971500E-03,.6892600E-03,.5438200E-03,.3637200E-03,.4870800E-04,& - & .6689300E-03,.7624600E-03,.7433400E-03,.6975200E-03,.6350100E-03,& - & .5536200E-03,.4345500E-03,.2884300E-03,.2426000E-04,.6711800E-03,& - & .7758800E-03,.7594400E-03,.7171000E-03,.6546100E-03,.5712200E-03,& - & .4499100E-03,.2990600E-03,.2743400E-04,.6721800E-03,.7850500E-03,& - & .7732800E-03,.7349700E-03,.6728600E-03,.5871800E-03,.4637500E-03,& - & .3093300E-03,.3080800E-04,.6705800E-03,.7924200E-03,.7862700E-03,& - & .7518100E-03,.6894600E-03,.6018300E-03,.4753200E-03,.3174300E-03,& - & .3432400E-04,.6646700E-03,.7982200E-03,.7977600E-03,.7677900E-03,& - & .7048100E-03,.6151000E-03,.4855300E-03,.3252600E-03,.3790500E-04,& - & .5829700E-03,.6602000E-03,.6433700E-03,.6061000E-03,.5522200E-03,& - & .4833800E-03,.3815400E-03,.2553700E-03,.2005400E-04,.5861600E-03,& - & .6731100E-03,.6576400E-03,.6236200E-03,.5699600E-03,.4993900E-03,& - & .3965700E-03,.2641800E-03,.2245700E-04,.5871900E-03,.6829100E-03,& - & .6701400E-03,.6392600E-03,.5870300E-03,.5145300E-03,.4097600E-03,& - & .2728000E-03,.2497400E-04,.5845100E-03,.6892500E-03,.6814400E-03,& - & .6541000E-03,.6031200E-03,.5290300E-03,.4214700E-03,.2809600E-03,& - & .2761300E-04,.5788500E-03,.6936900E-03,.6915300E-03,.6672500E-03,& - & .6166600E-03,.5411400E-03,.4312300E-03,.2890700E-03,.3024300E-04/ - - data absa(181:315, 4) / & - & .5063900E-03,.5689700E-03,.5541200E-03,.5212700E-03,.4734100E-03,& - & .4166900E-03,.3329300E-03,.2221500E-03,.1705700E-04,.5106500E-03,& - & .5811100E-03,.5674000E-03,.5364200E-03,.4897000E-03,.4316600E-03,& - & .3467100E-03,.2311100E-03,.1919100E-04,.5113100E-03,.5892300E-03,& - & .5780200E-03,.5498900E-03,.5051900E-03,.4452000E-03,.3586700E-03,& - & .2395500E-03,.2123800E-04,.5088800E-03,.5943200E-03,.5870000E-03,& - & .5623800E-03,.5189900E-03,.4578700E-03,.3696000E-03,.2473300E-03,& - & .2344200E-04,.5041100E-03,.5980400E-03,.5949700E-03,.5734200E-03,& - & .5315800E-03,.4692400E-03,.3788600E-03,.2545000E-03,.2575600E-04,& - & .4367300E-03,.4878200E-03,.4749900E-03,.4462900E-03,.4035400E-03,& - & .3545700E-03,.2860500E-03,.1908600E-03,.1470200E-04,.4410200E-03,& - & .4983100E-03,.4863900E-03,.4594300E-03,.4187900E-03,.3680800E-03,& - & .2980200E-03,.1998500E-03,.1647100E-04,.4422100E-03,.5051800E-03,& - & .4953800E-03,.4707500E-03,.4318300E-03,.3799500E-03,.3088200E-03,& - & .2076300E-03,.1842000E-04,.4401700E-03,.5099400E-03,.5032300E-03,& - & .4814100E-03,.4436000E-03,.3911600E-03,.3184400E-03,.2146000E-03,& - & .2047300E-04,.4365600E-03,.5124900E-03,.5100000E-03,.4906800E-03,& - & .4542500E-03,.4010700E-03,.3265300E-03,.2210900E-03,.2260000E-04,& - & .3762700E-03,.4152500E-03,.4036500E-03,.3792300E-03,.3425700E-03,& - & .3014700E-03,.2432400E-03,.1609400E-03,.1340000E-04,.3805100E-03,& - & .4248900E-03,.4140000E-03,.3906700E-03,.3555500E-03,.3125700E-03,& - & .2535300E-03,.1694700E-03,.1490500E-04,.3819600E-03,.4315400E-03,& - & .4216900E-03,.4003500E-03,.3670300E-03,.3231100E-03,.2629100E-03,& - & .1767200E-03,.1656600E-04,.3810800E-03,.4358700E-03,.4280900E-03,& - & .4089000E-03,.3769400E-03,.3324600E-03,.2709400E-03,.1830500E-03,& - & .1835200E-04,.3785400E-03,.4388900E-03,.4340200E-03,.4169700E-03,& - & .3853200E-03,.3407400E-03,.2781600E-03,.1887300E-03,.2022000E-04/ - - data absa(316:450, 4) / & - & .3196800E-03,.3530100E-03,.3431000E-03,.3220600E-03,.2890400E-03,& - & .2535600E-03,.2052300E-03,.1343200E-03,.1354800E-04,.3238600E-03,& - & .3622900E-03,.3528800E-03,.3321400E-03,.3003300E-03,.2634500E-03,& - & .2137400E-03,.1419800E-03,.1496600E-04,.3252100E-03,.3684800E-03,& - & .3598600E-03,.3405600E-03,.3104200E-03,.2722200E-03,.2211500E-03,& - & .1484100E-03,.1627800E-04,.3252700E-03,.3725800E-03,.3655300E-03,& - & .3481100E-03,.3191600E-03,.2803400E-03,.2283700E-03,.1544300E-03,& - & .1761400E-04,.3227200E-03,.3753300E-03,.3702500E-03,.3543800E-03,& - & .3263200E-03,.2874000E-03,.2348400E-03,.1595200E-03,.1907500E-04,& - & .2679400E-03,.2965500E-03,.2885100E-03,.2715500E-03,.2429000E-03,& - & .2118200E-03,.1718700E-03,.1115800E-03,.1689300E-04,.2721500E-03,& - & .3047700E-03,.2976500E-03,.2807500E-03,.2533600E-03,.2212000E-03,& - & .1785800E-03,.1179400E-03,.1857600E-04,.2740000E-03,.3106100E-03,& - & .3044700E-03,.2883600E-03,.2622400E-03,.2288600E-03,.1847400E-03,& - & .1237200E-03,.2005600E-04,.2738500E-03,.3142400E-03,.3092300E-03,& - & .2947700E-03,.2697700E-03,.2355400E-03,.1909300E-03,.1288400E-03,& - & .2132100E-04,.2719600E-03,.3164700E-03,.3130800E-03,.3000600E-03,& - & .2760400E-03,.2419100E-03,.1964900E-03,.1335200E-03,.2261100E-04,& - & .2225500E-03,.2471600E-03,.2408700E-03,.2267200E-03,.2021600E-03,& - & .1758200E-03,.1433900E-03,.9252800E-04,.2247100E-04,.2266300E-03,& - & .2542900E-03,.2490800E-03,.2350600E-03,.2116700E-03,.1837700E-03,& - & .1491000E-03,.9797200E-04,.2453600E-04,.2286700E-03,.2596300E-03,& - & .2553200E-03,.2416900E-03,.2192300E-03,.1906700E-03,.1545800E-03,& - & .1029300E-03,.2645300E-04,.2285300E-03,.2627300E-03,.2596000E-03,& - & .2470400E-03,.2254900E-03,.1967900E-03,.1596800E-03,.1072800E-03,& - & .2838300E-04,.2270400E-03,.2646900E-03,.2625900E-03,.2514100E-03,& - & .2308000E-03,.2021600E-03,.1643300E-03,.1111600E-03,.3011100E-04/ - - data absa(451:585, 4) / & - & .1857000E-03,.2079100E-03,.2031000E-03,.1910600E-03,.1706600E-03,& - & .1479700E-03,.1209700E-03,.7870400E-04,.2072000E-04,.1886800E-03,& - & .2135600E-03,.2096900E-03,.1980700E-03,.1782100E-03,.1543400E-03,& - & .1258400E-03,.8317900E-04,.2326800E-04,.1897200E-03,.2173200E-03,& - & .2144700E-03,.2030500E-03,.1841600E-03,.1599300E-03,.1300600E-03,& - & .8713400E-04,.2578100E-04,.1892900E-03,.2195500E-03,.2177100E-03,& - & .2071100E-03,.1890700E-03,.1649300E-03,.1342000E-03,.9069900E-04,& - & .2818100E-04,.1876600E-03,.2209500E-03,.2198700E-03,.2104500E-03,& - & .1931200E-03,.1693400E-03,.1381200E-03,.9384000E-04,.3048900E-04,& - & .1540900E-03,.1739900E-03,.1701000E-03,.1600200E-03,.1431100E-03,& - & .1237600E-03,.1012100E-03,.6642800E-04,.1781300E-04,.1559900E-03,& - & .1783100E-03,.1752100E-03,.1655400E-03,.1489000E-03,.1288100E-03,& - & .1052700E-03,.6996400E-04,.1991800E-04,.1566100E-03,.1811900E-03,& - & .1789200E-03,.1693400E-03,.1536500E-03,.1333800E-03,.1086400E-03,& - & .7314200E-04,.2212100E-04,.1560800E-03,.1829300E-03,.1814500E-03,& - & .1725400E-03,.1574300E-03,.1374700E-03,.1120900E-03,.7597100E-04,& - & .2442500E-04,.1545300E-03,.1838300E-03,.1830900E-03,.1751000E-03,& - & .1606700E-03,.1410200E-03,.1152900E-03,.7860700E-04,.2679100E-04,& - & .1270500E-03,.1448500E-03,.1415500E-03,.1331200E-03,.1191400E-03,& - & .1029900E-03,.8441600E-04,.5559800E-04,.1442900E-04,.1284300E-03,& - & .1482200E-03,.1455500E-03,.1374800E-03,.1237700E-03,.1070200E-03,& - & .8752000E-04,.5840500E-04,.1614700E-04,.1287500E-03,.1504300E-03,& - & .1485000E-03,.1405300E-03,.1275200E-03,.1108100E-03,.9034800E-04,& - & .6093400E-04,.1799200E-04,.1282200E-03,.1517500E-03,.1504900E-03,& - & .1430100E-03,.1305900E-03,.1141300E-03,.9317100E-04,.6329600E-04,& - & .1988800E-04,.1268400E-03,.1523900E-03,.1517900E-03,.1451100E-03,& - & .1332000E-03,.1170200E-03,.9578600E-04,.6546800E-04,.2170600E-04/ - - data absa( 1:180, 5) / & - & .2275875E-02,.2332064E-02,.2216796E-02,.2037339E-02,.1810754E-02,& - & .1542017E-02,.1221835E-02,.8225168E-03,.2378785E-03,.2274525E-02,& - & .2355192E-02,.2253198E-02,.2079119E-02,.1858235E-02,.1590203E-02,& - & .1266759E-02,.8576253E-03,.2590612E-03,.2266023E-02,.2375024E-02,& - & .2283817E-02,.2117878E-02,.1902253E-02,.1637433E-02,.1310064E-02,& - & .8925666E-03,.2839408E-03,.2251924E-02,.2389473E-02,.2311430E-02,& - & .2154739E-02,.1945283E-02,.1682775E-02,.1352510E-02,.9268463E-03,& - & .3108163E-03,.2232455E-02,.2399259E-02,.2336395E-02,.2189553E-02,& - & .1986811E-02,.1727976E-02,.1393776E-02,.9592790E-03,.3382077E-03,& - & .2106993E-02,.2154787E-02,.2043104E-02,.1868719E-02,.1654669E-02,& - & .1404007E-02,.1111065E-02,.7507219E-03,.1949377E-03,.2109908E-02,& - & .2178927E-02,.2078863E-02,.1908781E-02,.1697578E-02,.1448872E-02,& - & .1153419E-02,.7832801E-03,.2139563E-03,.2105465E-02,.2199441E-02,& - & .2109463E-02,.1944753E-02,.1739524E-02,.1492018E-02,.1195120E-02,& - & .8155632E-03,.2349725E-03,.2093796E-02,.2214377E-02,.2136026E-02,& - & .1977275E-02,.1778542E-02,.1533694E-02,.1236220E-02,.8467658E-03,& - & .2569866E-03,.2076724E-02,.2225712E-02,.2159173E-02,.2008267E-02,& - & .1816462E-02,.1574183E-02,.1275209E-02,.8771670E-03,.2791186E-03,& - & .1940537E-02,.1975605E-02,.1864311E-02,.1695911E-02,.1496137E-02,& - & .1263628E-02,.9971610E-03,.6738674E-03,.1565544E-03,.1948245E-02,& - & .2001986E-02,.1900553E-02,.1736295E-02,.1537745E-02,.1305077E-02,& - & .1036131E-02,.7035141E-03,.1728753E-03,.1946880E-02,.2024379E-02,& - & .1930764E-02,.1771154E-02,.1575770E-02,.1344673E-02,.1074374E-02,& - & .7332422E-03,.1899479E-03,.1938868E-02,.2041140E-02,.1955874E-02,& - & .1802287E-02,.1611440E-02,.1382812E-02,.1112406E-02,.7633322E-03,& - & .2072614E-03,.1926362E-02,.2054363E-02,.1977970E-02,.1829838E-02,& - & .1645759E-02,.1419736E-02,.1149822E-02,.7922080E-03,.2267149E-03,& - & .1777321E-02,.1802735E-02,.1693881E-02,.1532687E-02,.1345353E-02,& - & .1130261E-02,.8895753E-03,.5968647E-03,.1247261E-03,.1788584E-02,& - & .1831387E-02,.1729859E-02,.1572174E-02,.1384900E-02,.1169670E-02,& - & .9252263E-03,.6260595E-03,.1385262E-03,.1791618E-02,.1854218E-02,& - & .1759929E-02,.1606995E-02,.1420262E-02,.1206226E-02,.9598075E-03,& - & .6546109E-03,.1526122E-03,.1788339E-02,.1872013E-02,.1786084E-02,& - & .1636442E-02,.1452167E-02,.1240664E-02,.9939639E-03,.6826539E-03,& - & .1672628E-03,.1778773E-02,.1885271E-02,.1807813E-02,.1662029E-02,& - & .1483280E-02,.1274547E-02,.1027899E-02,.7097707E-03,.1836638E-03/ - - data absa(181:315, 5) / & - & .1611039E-02,.1628826E-02,.1528886E-02,.1381805E-02,.1208375E-02,& - & .1011477E-02,.7896015E-03,.5279159E-03,.9908775E-04,.1625251E-02,& - & .1659059E-02,.1564750E-02,.1419820E-02,.1247291E-02,.1047725E-02,& - & .8222728E-03,.5541873E-03,.1104539E-03,.1631934E-02,.1683911E-02,& - & .1595157E-02,.1453710E-02,.1281311E-02,.1080902E-02,.8540548E-03,& - & .5806197E-03,.1219897E-03,.1631403E-02,.1703448E-02,.1621164E-02,& - & .1482847E-02,.1310904E-02,.1111385E-02,.8847073E-03,.6065309E-03,& - & .1346152E-03,.1624079E-02,.1717008E-02,.1643088E-02,.1507761E-02,& - & .1337964E-02,.1141306E-02,.9151343E-03,.6325088E-03,.1481383E-03,& - & .1446415E-02,.1455765E-02,.1361590E-02,.1229351E-02,.1074912E-02,& - & .9006186E-03,.7006813E-03,.4647234E-03,.8189242E-04,.1463779E-02,& - & .1487367E-02,.1398211E-02,.1267666E-02,.1112416E-02,.9358187E-03,& - & .7313361E-03,.4886301E-03,.9135341E-04,.1472351E-02,.1513138E-02,& - & .1428682E-02,.1300953E-02,.1145840E-02,.9675370E-03,.7596020E-03,& - & .5122126E-03,.1005443E-03,.1474221E-02,.1532600E-02,.1454339E-02,& - & .1329459E-02,.1174906E-02,.9956373E-03,.7867852E-03,.5359551E-03,& - & .1109812E-03,.1468517E-02,.1546507E-02,.1474790E-02,.1352688E-02,& - & .1200227E-02,.1022681E-02,.8131587E-03,.5591171E-03,.1219361E-03,& - & .1282142E-02,.1287927E-02,.1202141E-02,.1083733E-02,.9460514E-03,& - & .7915341E-03,.6168183E-03,.4084185E-03,.6913010E-04,.1301052E-02,& - & .1319819E-02,.1238509E-02,.1121340E-02,.9823064E-03,.8254094E-03,& - & .6455635E-03,.4300976E-03,.7651588E-04,.1311903E-02,.1345238E-02,& - & .1268573E-02,.1153718E-02,.1014080E-02,.8553954E-03,.6719282E-03,& - & .4514177E-03,.8484352E-04,.1314609E-02,.1365010E-02,.1292722E-02,& - & .1180653E-02,.1041774E-02,.8822963E-03,.6970864E-03,.4722480E-03,& - & .9377363E-04,.1310264E-02,.1377648E-02,.1311780E-02,.1202781E-02,& - & .1065878E-02,.9070933E-03,.7215140E-03,.4928747E-03,.1032168E-03/ - - data absa(316:450, 5) / & - & .1123722E-02,.1125509E-02,.1049077E-02,.9463051E-03,.8264962E-03,& - & .6910472E-03,.5381327E-03,.3566196E-03,.6074714E-04,.1144528E-02,& - & .1157108E-02,.1084145E-02,.9824251E-03,.8612451E-03,.7227531E-03,& - & .5650534E-03,.3769954E-03,.6752101E-04,.1156115E-02,.1182481E-02,& - & .1113388E-02,.1013135E-02,.8909498E-03,.7510056E-03,.5899576E-03,& - & .3965626E-03,.7509877E-04,.1159636E-02,.1200610E-02,.1136628E-02,& - & .1038419E-02,.9163190E-03,.7757266E-03,.6129711E-03,.4156689E-03,& - & .8319483E-04,.1156675E-02,.1212668E-02,.1153943E-02,.1059223E-02,& - & .9387272E-03,.7983980E-03,.6348116E-03,.4345877E-03,.9149048E-04,& - & .9788217E-03,.9762902E-03,.9076191E-03,.8180805E-03,.7140719E-03,& - & .5979311E-03,.4657057E-03,.3080365E-03,.6376560E-04,.9995801E-03,& - & .1006767E-02,.9409303E-03,.8518710E-03,.7465719E-03,.6272074E-03,& - & .4915396E-03,.3271476E-03,.7043059E-04,.1011283E-02,.1030289E-02,& - & .9679162E-03,.8806454E-03,.7743638E-03,.6533475E-03,.5145414E-03,& - & .3451157E-03,.7748348E-04,.1015523E-02,.1047024E-02,.9891231E-03,& - & .9038676E-03,.7980900E-03,.6765444E-03,.5353367E-03,.3623073E-03,& - & .8485843E-04,.1014685E-02,.1058164E-02,.1005055E-02,.9228604E-03,& - & .8183767E-03,.6971991E-03,.5549716E-03,.3793243E-03,.9265390E-04,& - & .8467257E-03,.8439047E-03,.7839737E-03,.7069600E-03,.6168442E-03,& - & .5161363E-03,.4002993E-03,.2648075E-03,.8538662E-04,.8663801E-03,& - & .8726556E-03,.8143622E-03,.7377253E-03,.6460394E-03,.5429897E-03,& - & .4242444E-03,.2822342E-03,.9232499E-04,.8777160E-03,.8939799E-03,& - & .8388502E-03,.7633777E-03,.6710202E-03,.5661949E-03,.4453570E-03,& - & .2983921E-03,.9968327E-04,.8822976E-03,.9090305E-03,.8576617E-03,& - & .7836215E-03,.6918973E-03,.5865524E-03,.4643056E-03,.3139878E-03,& - & .1075001E-03,.8816821E-03,.9194329E-03,.8721358E-03,.8002626E-03,& - & .7096839E-03,.6047828E-03,.4818629E-03,.3291128E-03,.1153966E-03/ - - data absa(451:585, 5) / & - & .7345259E-03,.7353571E-03,.6844124E-03,.6191407E-03,.5419865E-03,& - & .4543535E-03,.3524790E-03,.2326534E-03,.8831490E-04,.7490617E-03,& - & .7579739E-03,.7093615E-03,.6447658E-03,.5665622E-03,.4774427E-03,& - & .3729073E-03,.2477509E-03,.9439904E-04,.7564292E-03,.7744541E-03,& - & .7287630E-03,.6652977E-03,.5871248E-03,.4970065E-03,.3911667E-03,& - & .2619945E-03,.9990772E-04,.7586881E-03,.7858289E-03,.7437324E-03,& - & .6818515E-03,.6043581E-03,.5141276E-03,.4072910E-03,.2755984E-03,& - & .1066252E-03,.7563639E-03,.7931595E-03,.7548375E-03,.6950726E-03,& - & .6192222E-03,.5294685E-03,.4222590E-03,.2889243E-03,.1133924E-03,& - & .6314226E-03,.6349627E-03,.5926562E-03,.5376114E-03,.4719251E-03,& - & .3962308E-03,.3074879E-03,.2032569E-03,.8003266E-04,.6418725E-03,& - & .6525898E-03,.6125061E-03,.5580757E-03,.4921735E-03,.4155327E-03,& - & .3248794E-03,.2162533E-03,.8576530E-04,.6471266E-03,.6653221E-03,& - & .6276452E-03,.5745768E-03,.5090609E-03,.4319430E-03,.3403545E-03,& - & .2285539E-03,.9041149E-04,.6478227E-03,.6738338E-03,.6394020E-03,& - & .5876220E-03,.5231812E-03,.4462724E-03,.3541410E-03,.2403090E-03,& - & .9584348E-04,.6442291E-03,.6788200E-03,.6475947E-03,.5980228E-03,& - & .5350971E-03,.4588656E-03,.3667841E-03,.2515799E-03,.1017699E-03,& - & .5366413E-03,.5433012E-03,.5091779E-03,.4634801E-03,.4076173E-03,& - & .3421937E-03,.2655508E-03,.1759732E-03,.6609799E-04,.5446297E-03,& - & .5573704E-03,.5249762E-03,.4800512E-03,.4241853E-03,.3581272E-03,& - & .2800981E-03,.1871731E-03,.7047861E-04,.5481742E-03,.5672989E-03,& - & .5373039E-03,.4932643E-03,.4379422E-03,.3716071E-03,.2930461E-03,& - & .1977626E-03,.7433299E-04,.5476171E-03,.5738401E-03,.5461812E-03,& - & .5035685E-03,.4492907E-03,.3832995E-03,.3046021E-03,.2077508E-03,& - & .7880238E-04,.5438946E-03,.5774436E-03,.5525251E-03,.5119901E-03,& - & .4590263E-03,.3938170E-03,.3152705E-03,.2173888E-03,.8388184E-04/ - - data absa( 1:180, 6) / & - & .7453129E-02,.7117405E-02,.6661341E-02,.6078589E-02,.5376308E-02,& - & .4581666E-02,.3692876E-02,.2668674E-02,.1857553E-02,.7414650E-02,& - & .7132841E-02,.6723850E-02,.6175876E-02,.5501579E-02,.4730655E-02,& - & .3847363E-02,.2834084E-02,.2101417E-02,.7367697E-02,.7142450E-02,& - & .6787572E-02,.6271236E-02,.5628812E-02,.4876081E-02,.4005906E-02,& - & .3014246E-02,.2361444E-02,.7309381E-02,.7154158E-02,.6847198E-02,& - & .6364336E-02,.5757194E-02,.5023915E-02,.4174265E-02,.3211257E-02,& - & .2644919E-02,.7240917E-02,.7165375E-02,.6901545E-02,.6460272E-02,& - & .5886974E-02,.5176789E-02,.4355003E-02,.3427381E-02,.2951988E-02,& - & .7302417E-02,.6986029E-02,.6506078E-02,.5915241E-02,.5213714E-02,& - & .4409454E-02,.3509969E-02,.2477433E-02,.1531293E-02,.7272446E-02,& - & .7005207E-02,.6569159E-02,.6009028E-02,.5333024E-02,.4547186E-02,& - & .3651478E-02,.2623452E-02,.1730635E-02,.7229818E-02,.7019119E-02,& - & .6631639E-02,.6101575E-02,.5452906E-02,.4682444E-02,.3795174E-02,& - & .2779605E-02,.1947925E-02,.7174295E-02,.7033174E-02,.6689925E-02,& - & .6193261E-02,.5571003E-02,.4818428E-02,.3945240E-02,.2947728E-02,& - & .2183570E-02,.7110805E-02,.7045732E-02,.6744602E-02,.6284811E-02,& - & .5687916E-02,.4958393E-02,.4105561E-02,.3129372E-02,.2439844E-02,& - & .7107732E-02,.6797516E-02,.6299565E-02,.5698070E-02,.4995391E-02,& - & .4198481E-02,.3302300E-02,.2275195E-02,.1230993E-02,.7086152E-02,& - & .6823070E-02,.6363343E-02,.5788270E-02,.5108424E-02,.4328271E-02,& - & .3431427E-02,.2406277E-02,.1392637E-02,.7052294E-02,.6841431E-02,& - & .6426576E-02,.5878051E-02,.5223227E-02,.4454560E-02,.3563303E-02,& - & .2543558E-02,.1569089E-02,.7006893E-02,.6857640E-02,.6486440E-02,& - & .5967434E-02,.5334883E-02,.4578334E-02,.3699649E-02,.2688020E-02,& - & .1760440E-02,.6949333E-02,.6870773E-02,.6541587E-02,.6057335E-02,& - & .5442169E-02,.4706411E-02,.3839426E-02,.2841732E-02,.1964963E-02,& - & .6855130E-02,.6551944E-02,.6044314E-02,.5438518E-02,.4743060E-02,& - & .3966419E-02,.3087108E-02,.2087789E-02,.9879948E-03,.6846892E-02,& - & .6585398E-02,.6112347E-02,.5528377E-02,.4852610E-02,.4086708E-02,& - & .3208051E-02,.2203856E-02,.1119742E-02,.6824941E-02,.6610372E-02,& - & .6177682E-02,.5615844E-02,.4962743E-02,.4204184E-02,.3329715E-02,& - & .2324960E-02,.1263158E-02,.6787743E-02,.6632257E-02,.6236180E-02,& - & .5702032E-02,.5069502E-02,.4319861E-02,.3453836E-02,.2450583E-02,& - & .1417217E-02,.6740085E-02,.6651560E-02,.6290312E-02,.5788524E-02,& - & .5171266E-02,.4436812E-02,.3580405E-02,.2581552E-02,.1582148E-02/ - - data absa(181:315, 6) / & - & .6558083E-02,.6261779E-02,.5751378E-02,.5145860E-02,.4467228E-02,& - & .3714081E-02,.2872846E-02,.1912747E-02,.7974292E-03,.6563849E-02,& - & .6305787E-02,.5824503E-02,.5238051E-02,.4571578E-02,.3828273E-02,& - & .2985436E-02,.2017845E-02,.9044707E-03,.6552571E-02,.6339245E-02,& - & .5892376E-02,.5324090E-02,.4676050E-02,.3939449E-02,.3097458E-02,& - & .2125514E-02,.1021181E-02,.6528895E-02,.6367176E-02,.5952402E-02,& - & .5408542E-02,.4777701E-02,.4049784E-02,.3211983E-02,.2236558E-02,& - & .1145140E-02,.6494313E-02,.6390805E-02,.6006376E-02,.5490888E-02,& - & .4876710E-02,.4160137E-02,.3328414E-02,.2349602E-02,.1279011E-02,& - & .6217297E-02,.5928758E-02,.5426959E-02,.4833520E-02,.4174155E-02,& - & .3449793E-02,.2650701E-02,.1741615E-02,.6370094E-03,.6238859E-02,& - & .5985757E-02,.5505992E-02,.4926333E-02,.4277869E-02,.3557040E-02,& - & .2755926E-02,.1837721E-02,.7241979E-03,.6246176E-02,.6029777E-02,& - & .5577993E-02,.5013764E-02,.4377842E-02,.3662657E-02,.2861509E-02,& - & .1935493E-02,.8193352E-03,.6236692E-02,.6066266E-02,.5641135E-02,& - & .5097431E-02,.4474642E-02,.3767073E-02,.2967217E-02,.2035588E-02,& - & .9198253E-03,.6214342E-02,.6096770E-02,.5698970E-02,.5179034E-02,& - & .4569107E-02,.3869801E-02,.3075666E-02,.2136680E-02,.1028239E-02,& - & .5843663E-02,.5561987E-02,.5073558E-02,.4502171E-02,.3871558E-02,& - & .3184826E-02,.2432337E-02,.1579438E-02,.5066815E-03,.5883549E-02,& - & .5632733E-02,.5159626E-02,.4598553E-02,.3975656E-02,.3289560E-02,& - & .2531458E-02,.1667525E-02,.5778308E-03,.5906315E-02,.5689718E-02,& - & .5238108E-02,.4688943E-02,.4074005E-02,.3390408E-02,.2630796E-02,& - & .1755973E-02,.6537602E-03,.5911760E-02,.5735215E-02,.5308819E-02,& - & .4775175E-02,.4168666E-02,.3489857E-02,.2728910E-02,.1847257E-02,& - & .7347999E-03,.5905012E-02,.5775036E-02,.5371993E-02,.4856819E-02,& - & .4260538E-02,.3587351E-02,.2827507E-02,.1938584E-02,.8225668E-03/ - - data absa(316:450, 6) / & - & .5448799E-02,.5174237E-02,.4702978E-02,.4159096E-02,.3562636E-02,& - & .2919042E-02,.2216707E-02,.1428474E-02,.4372080E-03,.5503786E-02,& - & .5258826E-02,.4798801E-02,.4260222E-02,.3666742E-02,.3022053E-02,& - & .2311790E-02,.1509380E-02,.4923566E-03,.5542089E-02,.5327495E-02,& - & .4884619E-02,.4354537E-02,.3765908E-02,.3119877E-02,.2406348E-02,& - & .1590203E-02,.5508055E-03,.5564630E-02,.5383808E-02,.4961019E-02,& - & .4443926E-02,.3860688E-02,.3216549E-02,.2498792E-02,.1671379E-02,& - & .6126355E-03,.5570361E-02,.5432506E-02,.5031105E-02,.4526985E-02,& - & .3951398E-02,.3309750E-02,.2590269E-02,.1752856E-02,.6794564E-03,& - & .5025183E-02,.4765836E-02,.4321116E-02,.3810537E-02,.3254592E-02,& - & .2655950E-02,.2006115E-02,.1286407E-02,.4311014E-03,.5098265E-02,& - & .4863995E-02,.4425250E-02,.3917786E-02,.3360874E-02,.2757245E-02,& - & .2097126E-02,.1360829E-02,.4799419E-03,.5154179E-02,.4945399E-02,& - & .4519161E-02,.4017193E-02,.3461670E-02,.2853712E-02,.2187196E-02,& - & .1435268E-02,.5332265E-03,.5190969E-02,.5013790E-02,.4604355E-02,& - & .4110643E-02,.3555937E-02,.2947656E-02,.2275382E-02,.1509403E-02,& - & .5888012E-03,.5208138E-02,.5072165E-02,.4680561E-02,.4195990E-02,& - & .3646519E-02,.3037397E-02,.2361829E-02,.1583627E-02,.6478322E-03,& - & .4623391E-02,.4366790E-02,.3943485E-02,.3465227E-02,.2955259E-02,& - & .2405643E-02,.1812616E-02,.1157161E-02,.4945874E-03,.4710125E-02,& - & .4474615E-02,.4054953E-02,.3577026E-02,.3062985E-02,.2506113E-02,& - & .1900613E-02,.1226503E-02,.5465245E-03,.4776716E-02,.4564405E-02,& - & .4153594E-02,.3680995E-02,.3166029E-02,.2601953E-02,.1986110E-02,& - & .1295516E-02,.6032750E-03,.4823514E-02,.4640328E-02,.4243823E-02,& - & .3778649E-02,.3262225E-02,.2694009E-02,.2069881E-02,.1363711E-02,& - & .6621313E-03,.4852467E-02,.4703395E-02,.4324910E-02,.3866669E-02,& - & .3352109E-02,.2781681E-02,.2151024E-02,.1432036E-02,.7228720E-03/ - - data absa(451:585, 6) / & - & .4268691E-02,.4040183E-02,.3646880E-02,.3203178E-02,.2726389E-02,& - & .2213905E-02,.1666317E-02,.1066325E-02,.4983873E-03,.4358586E-02,& - & .4148745E-02,.3757876E-02,.3313137E-02,.2831232E-02,.2309276E-02,& - & .1749842E-02,.1130782E-02,.5479266E-03,.4428469E-02,.4241143E-02,& - & .3857210E-02,.3414820E-02,.2929730E-02,.2400315E-02,.1831540E-02,& - & .1194311E-02,.6008082E-03,.4479685E-02,.4318791E-02,.3947347E-02,& - & .3507844E-02,.3019422E-02,.2487256E-02,.1910638E-02,.1257207E-02,& - & .6538267E-03,.4513413E-02,.4384415E-02,.4026009E-02,.3591207E-02,& - & .3103605E-02,.2569184E-02,.1986548E-02,.1320050E-02,.7081602E-03,& - & .3915100E-02,.3711716E-02,.3349816E-02,.2944438E-02,.2506601E-02,& - & .2037038E-02,.1533857E-02,.9781961E-03,.4622673E-03,.4005434E-02,& - & .3819687E-02,.3461208E-02,.3053733E-02,.2609936E-02,.2129368E-02,& - & .1612065E-02,.1038339E-02,.5051377E-03,.4076956E-02,.3913286E-02,& - & .3561928E-02,.3154739E-02,.2705010E-02,.2215707E-02,.1687464E-02,& - & .1097449E-02,.5512414E-03,.4130247E-02,.3993297E-02,.3650863E-02,& - & .3245814E-02,.2792524E-02,.2297376E-02,.1759369E-02,.1155953E-02,& - & .5980184E-03,.4167218E-02,.4060665E-02,.3729251E-02,.3327359E-02,& - & .2873454E-02,.2374433E-02,.1829761E-02,.1214279E-02,.6444273E-03,& - & .3565599E-02,.3385516E-02,.3057279E-02,.2688351E-02,.2290666E-02,& - & .1864426E-02,.1405266E-02,.8966862E-03,.3986965E-03,.3656897E-02,& - & .3493575E-02,.3167640E-02,.2795196E-02,.2390148E-02,.1952514E-02,& - & .1480086E-02,.9522316E-03,.4352189E-03,.3729366E-02,.3587046E-02,& - & .3266101E-02,.2893554E-02,.2481255E-02,.2035902E-02,.1551310E-02,& - & .1006380E-02,.4737097E-03,.3784570E-02,.3667287E-02,.3354159E-02,& - & .2981192E-02,.2566707E-02,.2114949E-02,.1619376E-02,.1060223E-02,& - & .5128669E-03,.3823908E-02,.3735653E-02,.3431813E-02,.3061934E-02,& - & .2645587E-02,.2189124E-02,.1685116E-02,.1114442E-02,.5524785E-03/ - - data absa( 1:180, 7) / & - & .2337626E-01,.2175176E-01,.2063054E-01,.1953289E-01,.1869334E-01,& - & .1836575E-01,.1866188E-01,.1986732E-01,.2252135E-01,.2315624E-01,& - & .2164265E-01,.2067161E-01,.1978356E-01,.1921682E-01,.1922562E-01,& - & .1992930E-01,.2155800E-01,.2450575E-01,.2293107E-01,.2154457E-01,& - & .2074715E-01,.2011748E-01,.1985588E-01,.2024390E-01,.2137333E-01,& - & .2342559E-01,.2668727E-01,.2270210E-01,.2145089E-01,.2088033E-01,& - & .2054255E-01,.2062482E-01,.2143098E-01,.2299821E-01,.2549251E-01,& - & .2907234E-01,.2247095E-01,.2137582E-01,.2108331E-01,.2107230E-01,& - & .2155716E-01,.2281018E-01,.2484353E-01,.2780611E-01,.3172795E-01,& - & .2458189E-01,.2285200E-01,.2156813E-01,.2024632E-01,.1900708E-01,& - & .1819156E-01,.1796768E-01,.1857224E-01,.2076937E-01,.2435250E-01,& - & .2275178E-01,.2160965E-01,.2048103E-01,.1947652E-01,.1898219E-01,& - & .1913925E-01,.2015560E-01,.2268231E-01,.2412387E-01,.2265897E-01,& - & .2168600E-01,.2079019E-01,.2005803E-01,.1992705E-01,.2048310E-01,& - & .2192140E-01,.2477362E-01,.2389129E-01,.2256825E-01,.2181441E-01,& - & .2118241E-01,.2077464E-01,.2103762E-01,.2201020E-01,.2389372E-01,& - & .2708335E-01,.2365223E-01,.2248782E-01,.2200444E-01,.2167167E-01,& - & .2165150E-01,.2233835E-01,.2375741E-01,.2611574E-01,.2966311E-01,& - & .2579688E-01,.2397618E-01,.2249064E-01,.2092442E-01,.1929406E-01,& - & .1790138E-01,.1706811E-01,.1698922E-01,.1852242E-01,.2557176E-01,& - & .2388374E-01,.2253992E-01,.2114151E-01,.1969695E-01,.1860179E-01,& - & .1812445E-01,.1843215E-01,.2030655E-01,.2534781E-01,.2379879E-01,& - & .2261460E-01,.2141516E-01,.2020271E-01,.1944733E-01,.1934135E-01,& - & .2004948E-01,.2227174E-01,.2511276E-01,.2371341E-01,.2273562E-01,& - & .2176102E-01,.2083763E-01,.2045509E-01,.2073270E-01,.2187030E-01,& - & .2445363E-01,.2487422E-01,.2363274E-01,.2290622E-01,.2219407E-01,& - & .2162169E-01,.2162715E-01,.2232993E-01,.2392248E-01,.2688023E-01,& - & .2698586E-01,.2506791E-01,.2338609E-01,.2157417E-01,.1958193E-01,& - & .1763778E-01,.1616964E-01,.1538518E-01,.1621144E-01,.2676194E-01,& - & .2498910E-01,.2344897E-01,.2177479E-01,.1993962E-01,.1825433E-01,& - & .1710937E-01,.1668719E-01,.1786207E-01,.2654257E-01,.2491521E-01,& - & .2352676E-01,.2201454E-01,.2038036E-01,.1899998E-01,.1819673E-01,& - & .1814869E-01,.1968096E-01,.2631697E-01,.2483856E-01,.2364114E-01,& - & .2232785E-01,.2093620E-01,.1989270E-01,.1944697E-01,.1980212E-01,& - & .2170612E-01,.2608471E-01,.2475687E-01,.2379589E-01,.2271583E-01,& - & .2161901E-01,.2093691E-01,.2088135E-01,.2166610E-01,.2395288E-01/ - - data absa(181:315, 7) / & - & .2810778E-01,.2610373E-01,.2423479E-01,.2218757E-01,.1986177E-01,& - & .1746306E-01,.1537001E-01,.1389630E-01,.1400744E-01,.2789745E-01,& - & .2604100E-01,.2431619E-01,.2238153E-01,.2019516E-01,.1800500E-01,& - & .1621009E-01,.1507015E-01,.1553290E-01,.2769341E-01,.2597967E-01,& - & .2440064E-01,.2260000E-01,.2059359E-01,.1865773E-01,.1717719E-01,& - & .1638502E-01,.1720845E-01,.2747581E-01,.2591687E-01,.2451639E-01,& - & .2287475E-01,.2108787E-01,.1943977E-01,.1828677E-01,.1786928E-01,& - & .1906661E-01,.2724525E-01,.2584524E-01,.2465979E-01,.2322623E-01,& - & .2169174E-01,.2036043E-01,.1956477E-01,.1955161E-01,.2112946E-01,& - & .2916121E-01,.2706131E-01,.2501249E-01,.2273351E-01,.2011979E-01,& - & .1734949E-01,.1468202E-01,.1254397E-01,.1192697E-01,.2896641E-01,& - & .2702014E-01,.2511575E-01,.2293374E-01,.2042776E-01,.1783904E-01,& - & .1542709E-01,.1359860E-01,.1333064E-01,.2876765E-01,.2697723E-01,& - & .2521010E-01,.2314222E-01,.2079486E-01,.1840512E-01,.1626966E-01,& - & .1476028E-01,.1484637E-01,.2856294E-01,.2693274E-01,.2532642E-01,& - & .2339329E-01,.2123982E-01,.1907661E-01,.1724154E-01,.1606921E-01,& - & .1652405E-01,.2834370E-01,.2687419E-01,.2545751E-01,.2371200E-01,& - & .2178226E-01,.1987947E-01,.1836893E-01,.1756873E-01,.1840173E-01,& - & .3011114E-01,.2792230E-01,.2568609E-01,.2319257E-01,.2034293E-01,& - & .1726900E-01,.1415286E-01,.1138485E-01,.1005692E-01,.2992968E-01,& - & .2790487E-01,.2581306E-01,.2340902E-01,.2064353E-01,.1772380E-01,& - & .1480077E-01,.1231510E-01,.1132697E-01,.2974561E-01,.2787980E-01,& - & .2592483E-01,.2361776E-01,.2099074E-01,.1823014E-01,.1552253E-01,& - & .1333086E-01,.1268422E-01,.2955745E-01,.2785343E-01,.2604522E-01,& - & .2385432E-01,.2139366E-01,.1881776E-01,.1636294E-01,.1447960E-01,& - & .1418800E-01,.2935104E-01,.2781242E-01,.2617843E-01,.2414962E-01,& - & .2187815E-01,.1952002E-01,.1734737E-01,.1580301E-01,.1587593E-01/ - - data absa(316:450, 7) / & - & .3090210E-01,.2863464E-01,.2623745E-01,.2353758E-01,.2049216E-01,& - & .1719200E-01,.1374636E-01,.1041842E-01,.8306976E-02,.3074160E-01,& - & .2864184E-01,.2639435E-01,.2377357E-01,.2080408E-01,.1762587E-01,& - & .1431865E-01,.1122298E-01,.9441247E-02,.3058186E-01,.2864960E-01,& - & .2652689E-01,.2399238E-01,.2114556E-01,.1809030E-01,.1494024E-01,& - & .1210474E-01,.1065458E-01,.3041236E-01,.2865545E-01,.2666041E-01,& - & .2422874E-01,.2152521E-01,.1861362E-01,.1566308E-01,.1310960E-01,& - & .1200349E-01,.3023431E-01,.2863951E-01,.2679661E-01,.2451409E-01,& - & .2196729E-01,.1923952E-01,.1651206E-01,.1426729E-01,.1351982E-01,& - & .3150955E-01,.2917466E-01,.2663128E-01,.2375509E-01,.2054034E-01,& - & .1706533E-01,.1339031E-01,.9619698E-02,.6589618E-02,.3137548E-01,& - & .2921391E-01,.2682829E-01,.2401415E-01,.2086776E-01,.1749458E-01,& - & .1391017E-01,.1031015E-01,.7573865E-02,.3124577E-01,.2926104E-01,& - & .2699356E-01,.2424726E-01,.2121023E-01,.1794016E-01,.1446463E-01,& - & .1107269E-01,.8630532E-02,.3111437E-01,.2930266E-01,.2714520E-01,& - & .2449152E-01,.2158301E-01,.1842118E-01,.1509518E-01,.1193837E-01,& - & .9801078E-02,.3097127E-01,.2932558E-01,.2729444E-01,.2477809E-01,& - & .2199750E-01,.1898438E-01,.1582945E-01,.1293776E-01,.1111997E-01,& - & .3182644E-01,.2948280E-01,.2685783E-01,.2385751E-01,.2050472E-01,& - & .1690419E-01,.1307973E-01,.9016818E-02,.5889262E-02,.3174219E-01,& - & .2957180E-01,.2709658E-01,.2415027E-01,.2085202E-01,.1733699E-01,& - & .1357172E-01,.9617188E-02,.6575397E-02,.3166606E-01,.2967426E-01,& - & .2730658E-01,.2441152E-01,.2120507E-01,.1777789E-01,.1408374E-01,& - & .1027324E-01,.7358277E-02,.3158325E-01,.2976719E-01,.2749330E-01,& - & .2467389E-01,.2157919E-01,.1824104E-01,.1464950E-01,.1102019E-01,& - & .8229230E-02,.3148314E-01,.2984161E-01,.2766625E-01,.2497260E-01,& - & .2198691E-01,.1876667E-01,.1530472E-01,.1188221E-01,.9182963E-02/ - - data absa(451:585, 7) / & - & .3191734E-01,.2961741E-01,.2697787E-01,.2391284E-01,.2049970E-01,& - & .1685955E-01,.1296507E-01,.8750098E-02,.6274631E-02,.3190439E-01,& - & .2977990E-01,.2725815E-01,.2422984E-01,.2087607E-01,.1730510E-01,& - & .1344617E-01,.9295005E-02,.7007386E-02,.3188423E-01,.2993640E-01,& - & .2750670E-01,.2452542E-01,.2126330E-01,.1774973E-01,.1394711E-01,& - & .9900539E-02,.7782927E-02,.3184397E-01,.3007747E-01,.2772343E-01,& - & .2483444E-01,.2166507E-01,.1822702E-01,.1449986E-01,.1058694E-01,& - & .8671897E-02,.3178483E-01,.3018389E-01,.2793133E-01,.2517191E-01,& - & .2210215E-01,.1876481E-01,.1512017E-01,.1136237E-01,.9662908E-02,& - & .3187853E-01,.2963766E-01,.2698548E-01,.2385689E-01,.2040357E-01,& - & .1672870E-01,.1278988E-01,.8497981E-02,.6174837E-02,.3194590E-01,& - & .2988270E-01,.2731430E-01,.2420369E-01,.2080895E-01,.1718277E-01,& - & .1326475E-01,.9006730E-02,.6900214E-02,.3198870E-01,.3010121E-01,& - & .2760049E-01,.2453900E-01,.2122452E-01,.1764036E-01,.1376646E-01,& - & .9568560E-02,.7665374E-02,.3200932E-01,.3028722E-01,.2785313E-01,& - & .2489082E-01,.2164826E-01,.1813119E-01,.1432073E-01,.1019444E-01,& - & .8520390E-02,.3200022E-01,.3043673E-01,.2810016E-01,.2525761E-01,& - & .2211496E-01,.1867947E-01,.1492276E-01,.1090133E-01,.9520500E-02,& - & .3173815E-01,.2955655E-01,.2688573E-01,.2371393E-01,.2023390E-01,& - & .1654567E-01,.1257985E-01,.8246315E-02,.5647340E-02,.3187913E-01,& - & .2987574E-01,.2727046E-01,.2410527E-01,.2067778E-01,.1701522E-01,& - & .1304871E-01,.8729674E-02,.6295753E-02,.3199367E-01,.3016037E-01,& - & .2760193E-01,.2448927E-01,.2112455E-01,.1748698E-01,.1354982E-01,& - & .9254652E-02,.7027536E-02,.3208158E-01,.3040579E-01,.2790109E-01,& - & .2488587E-01,.2157632E-01,.1798983E-01,.1409732E-01,.9833255E-02,& - & .7857223E-02,.3212706E-01,.3060928E-01,.2819618E-01,.2528322E-01,& - & .2206831E-01,.1854255E-01,.1468812E-01,.1048268E-01,.8776360E-02/ - - data absa( 1:180, 8) / & - & .6013431E-01,.5707436E-01,.7233980E-01,.9815382E-01,.1294324E+00,& - & .1617466E+00,.1940373E+00,.2262581E+00,.2513644E+00,.5875631E-01,& - & .5691751E-01,.7437061E-01,.1026345E+00,.1360233E+00,.1699724E+00,& - & .2039042E+00,.2377536E+00,.2641912E+00,.5766566E-01,.5691471E-01,& - & .7651533E-01,.1069690E+00,.1422529E+00,.1777591E+00,.2132449E+00,& - & .2486476E+00,.2761623E+00,.5690082E-01,.5712785E-01,.7881629E-01,& - & .1114369E+00,.1484198E+00,.1854598E+00,.2224755E+00,.2594138E+00,& - & .2880248E+00,.5637766E-01,.5755994E-01,.8139096E-01,.1160220E+00,& - & .1545869E+00,.1931597E+00,.2317210E+00,.2701851E+00,.2998888E+00,& - & .6618075E-01,.6337862E-01,.7888769E-01,.1046010E+00,.1369770E+00,& - & .1711778E+00,.2053496E+00,.2394477E+00,.2688156E+00,.6469675E-01,& - & .6319075E-01,.8109464E-01,.1094837E+00,.1444540E+00,.1805151E+00,& - & .2165594E+00,.2525366E+00,.2834257E+00,.6352136E-01,.6312417E-01,& - & .8332160E-01,.1142143E+00,.1514669E+00,.1892772E+00,.2270740E+00,& - & .2647762E+00,.2971560E+00,.6267746E-01,.6327579E-01,.8565769E-01,& - & .1189657E+00,.1582452E+00,.1977516E+00,.2372313E+00,.2766038E+00,& - & .3104162E+00,.6209896E-01,.6369481E-01,.8824714E-01,.1238764E+00,& - & .1649199E+00,.2060757E+00,.2472064E+00,.2882573E+00,.3234086E+00,& - & .7395912E-01,.7063428E-01,.8565208E-01,.1104255E+00,.1427485E+00,& - & .1783683E+00,.2139880E+00,.2495178E+00,.2828639E+00,.7228712E-01,& - & .7036097E-01,.8793923E-01,.1157395E+00,.1512413E+00,.1890002E+00,& - & .2267276E+00,.2644122E+00,.2997266E+00,.7086841E-01,.7018107E-01,& - & .9023900E-01,.1209004E+00,.1591022E+00,.1988304E+00,.2385408E+00,& - & .2781769E+00,.3153056E+00,.6982927E-01,.7021452E-01,.9257013E-01,& - & .1259826E+00,.1665897E+00,.2081673E+00,.2497368E+00,.2911947E+00,& - & .3300931E+00,.6907982E-01,.7054544E-01,.9512295E-01,.1311315E+00,& - & .1739073E+00,.2173068E+00,.2606881E+00,.3039811E+00,.3445288E+00,& - & .8336981E-01,.7909588E-01,.9293217E-01,.1163289E+00,.1478222E+00,& - & .1841644E+00,.2209570E+00,.2576676E+00,.2934903E+00,.8148502E-01,& - & .7868615E-01,.9524447E-01,.1221028E+00,.1571946E+00,.1961923E+00,& - & .2353851E+00,.2744893E+00,.3126755E+00,.7980558E-01,.7839855E-01,& - & .9757525E-01,.1277440E+00,.1659210E+00,.2072782E+00,.2486777E+00,& - & .2899782E+00,.3303130E+00,.7850723E-01,.7829446E-01,.9994420E-01,& - & .1331287E+00,.1741803E+00,.2176536E+00,.2611345E+00,.3044935E+00,& - & .3468364E+00,.7749949E-01,.7851124E-01,.1025029E+00,.1385272E+00,& - & .1822356E+00,.2277238E+00,.2731983E+00,.3185592E+00,.3628488E+00/ - - data absa(181:315, 8) / & - & .9446343E-01,.8887098E-01,.1010405E+00,.1226819E+00,.1528690E+00,& - & .1887604E+00,.2264637E+00,.2640916E+00,.3014227E+00,.9223331E-01,& - & .8827980E-01,.1033453E+00,.1288736E+00,.1629549E+00,.2021939E+00,& - & .2425871E+00,.2829079E+00,.3229151E+00,.9024155E-01,.8783436E-01,& - & .1057387E+00,.1349856E+00,.1724292E+00,.2146241E+00,.2574756E+00,& - & .3002489E+00,.3427212E+00,.8862647E-01,.8754527E-01,.1081502E+00,& - & .1408020E+00,.1814043E+00,.2262377E+00,.2714152E+00,.3165045E+00,& - & .3612330E+00,.8735280E-01,.8760876E-01,.1107602E+00,.1464752E+00,& - & .1900954E+00,.2373504E+00,.2847413E+00,.3320395E+00,.3789626E+00,& - & .1071919E+00,.1001003E+00,.1101040E+00,.1294657E+00,.1574729E+00,& - & .1915463E+00,.2292568E+00,.2673709E+00,.3054402E+00,.1045794E+00,& - & .9926080E-01,.1123922E+00,.1359833E+00,.1683351E+00,.2062283E+00,& - & .2471625E+00,.2882394E+00,.3292971E+00,.1022687E+00,.9862247E-01,& - & .1148716E+00,.1424605E+00,.1785172E+00,.2200001E+00,.2638803E+00,& - & .3077436E+00,.3515504E+00,.1003101E+00,.9811233E-01,.1173419E+00,& - & .1486525E+00,.1881373E+00,.2329575E+00,.2794837E+00,.3259493E+00,& - & .3723585E+00,.9873698E-01,.9795941E-01,.1200135E+00,.1545733E+00,& - & .1973376E+00,.2452232E+00,.2942202E+00,.3431039E+00,.3919463E+00,& - & .1214673E+00,.1126359E+00,.1204125E+00,.1370664E+00,.1621239E+00,& - & .1935142E+00,.2296249E+00,.2677842E+00,.3060416E+00,.1185186E+00,& - & .1115740E+00,.1227071E+00,.1438053E+00,.1736162E+00,.2092232E+00,& - & .2494502E+00,.2909400E+00,.3324970E+00,.1158775E+00,.1107513E+00,& - & .1251835E+00,.1505785E+00,.1844456E+00,.2241943E+00,.2681063E+00,& - & .3126858E+00,.3573659E+00,.1135645E+00,.1100550E+00,.1276724E+00,& - & .1570942E+00,.1947551E+00,.2383233E+00,.2854861E+00,.3329504E+00,& - & .3805180E+00,.1116111E+00,.1096678E+00,.1303082E+00,.1632798E+00,& - & .2045649E+00,.2516490E+00,.3017320E+00,.3519240E+00,.4021839E+00/ - - data absa(316:450, 8) / & - & .1374520E+00,.1266748E+00,.1318516E+00,.1456457E+00,.1672523E+00,& - & .1950666E+00,.2283281E+00,.2656918E+00,.3037056E+00,.1341802E+00,& - & .1254071E+00,.1340698E+00,.1526186E+00,.1792338E+00,.2117540E+00,& - & .2498928E+00,.2912047E+00,.3328745E+00,.1311544E+00,.1242569E+00,& - & .1365313E+00,.1596294E+00,.1905813E+00,.2277714E+00,.2703124E+00,& - & .3152132E+00,.3603201E+00,.1284296E+00,.1232723E+00,.1390451E+00,& - & .1663760E+00,.2014538E+00,.2429694E+00,.2894262E+00,.3375633E+00,& - & .3858525E+00,.1260194E+00,.1225869E+00,.1416527E+00,.1727500E+00,& - & .2118169E+00,.2572538E+00,.3073512E+00,.3584426E+00,.4097428E+00,& - & .1553761E+00,.1422412E+00,.1444711E+00,.1550385E+00,.1728286E+00,& - & .1965109E+00,.2258295E+00,.2610663E+00,.2984504E+00,.1516669E+00,& - & .1407304E+00,.1465588E+00,.1622080E+00,.1852388E+00,.2140019E+00,& - & .2488334E+00,.2889075E+00,.3302659E+00,.1481522E+00,.1392528E+00,& - & .1489452E+00,.1694320E+00,.1970843E+00,.2308530E+00,.2707638E+00,& - & .3150768E+00,.3601714E+00,.1448954E+00,.1379226E+00,.1514075E+00,& - & .1763709E+00,.2084024E+00,.2469639E+00,.2914326E+00,.3395756E+00,& - & .3881786E+00,.1419554E+00,.1368141E+00,.1539816E+00,.1829006E+00,& - & .2192687E+00,.2621639E+00,.3109195E+00,.3624990E+00,.4144086E+00,& - & .1748198E+00,.1592727E+00,.1584450E+00,.1657904E+00,.1799080E+00,& - & .1994836E+00,.2245418E+00,.2566689E+00,.2810339E+00,.1705294E+00,& - & .1573886E+00,.1604084E+00,.1730449E+00,.1927005E+00,.2176246E+00,& - & .2486329E+00,.2864375E+00,.3169857E+00,.1664134E+00,.1555110E+00,& - & .1626512E+00,.1803894E+00,.2049406E+00,.2351258E+00,.2717671E+00,& - & .3146346E+00,.3505565E+00,.1625805E+00,.1537499E+00,.1650044E+00,& - & .1874575E+00,.2166562E+00,.2519400E+00,.2937443E+00,.3411186E+00,& - & .3823263E+00,.1590426E+00,.1521966E+00,.1674556E+00,.1940812E+00,& - & .2278853E+00,.2678905E+00,.3145120E+00,.3659844E+00,.4129266E+00/ - - data absa(451:585, 8) / & - & .1935762E+00,.1766297E+00,.1744420E+00,.1806968E+00,.1935473E+00,& - & .2114104E+00,.2347348E+00,.2655809E+00,.2757601E+00,.1885866E+00,& - & .1741931E+00,.1762668E+00,.1880588E+00,.2064070E+00,.2298344E+00,& - & .2593418E+00,.2963843E+00,.3112482E+00,.1838929E+00,.1718429E+00,& - & .1783334E+00,.1953918E+00,.2186897E+00,.2477198E+00,.2829811E+00,& - & .3255600E+00,.3451455E+00,.1794971E+00,.1696478E+00,.1805638E+00,& - & .2022902E+00,.2305237E+00,.2647488E+00,.3054649E+00,.3531405E+00,& - & .3769471E+00,.1753728E+00,.1677953E+00,.1828746E+00,.2087886E+00,& - & .2417893E+00,.2809426E+00,.3270047E+00,.3794515E+00,.4073030E+00,& - & .2131992E+00,.1947813E+00,.1912304E+00,.1963678E+00,.2076432E+00,& - & .2236360E+00,.2450570E+00,.2741551E+00,.2789175E+00,.2074072E+00,& - & .1916172E+00,.1927506E+00,.2036992E+00,.2204764E+00,.2423112E+00,& - & .2701300E+00,.3057154E+00,.3147569E+00,.2019948E+00,.1886976E+00,& - & .1945776E+00,.2108178E+00,.2327675E+00,.2604245E+00,.2941651E+00,& - & .3357507E+00,.3491138E+00,.1968339E+00,.1860228E+00,.1965911E+00,& - & .2174692E+00,.2445952E+00,.2776478E+00,.3170335E+00,.3643697E+00,& - & .3816200E+00,.1920176E+00,.1837096E+00,.1986031E+00,.2238583E+00,& - & .2557920E+00,.2940556E+00,.3391509E+00,.3918311E+00,.4121885E+00,& - & .2332827E+00,.2134102E+00,.2085161E+00,.2124079E+00,.2219989E+00,& - & .2359574E+00,.2553647E+00,.2822947E+00,.2887838E+00,.2266775E+00,& - & .2095424E+00,.2096502E+00,.2195248E+00,.2347351E+00,.2548294E+00,& - & .2808212E+00,.3144477E+00,.3259151E+00,.2203906E+00,.2059404E+00,& - & .2111339E+00,.2263053E+00,.2469443E+00,.2730233E+00,.3051566E+00,& - & .3452396E+00,.3610131E+00,.2143742E+00,.2026221E+00,.2127678E+00,& - & .2326886E+00,.2586790E+00,.2903679E+00,.3283839E+00,.3747332E+00,& - & .3941719E+00,.2087774E+00,.1996808E+00,.2143237E+00,.2388436E+00,& - & .2697785E+00,.3069660E+00,.3509603E+00,.4031790E+00,.4260779E+00/ - -! the array absb(235,8) (kb(5,13:59,8)) contains absorption coefs at -! the 16 chosen g-values for a range of pressure levels < ~100mb and -! temperatures. the first index in the array, jt, which runs from 1 to 5, -! corresponds to different temperatures. more specifically, jt = 3 means -! that the data are for the reference temperature tref for this pressure -! level, jt = 2 refers to the temperature tref-15, jt = 1 is for -! tref-30, jt = 4 is for tref+15, and jt = 5 is for tref+30. -! the second index, jp, runs from 13 to 59 and refers to the jpth -! reference pressure level (see taumol.f for the value of these -! pressure levels in mb). the third index, ig, goes from 1 to 8, -! and tells us which g-interval the absorption coefficients are for. - - data absb( 1:120, 1) / & - & .1281000E-03,.1289100E-03,.1289000E-03,.1271300E-03,.1247700E-03,& - & .1065300E-03,.1066700E-03,.1064800E-03,.1047300E-03,.1029300E-03,& - & .9017600E-04,.9007700E-04,.8928600E-04,.8787900E-04,.8598700E-04,& - & .7770400E-04,.7730400E-04,.7587900E-04,.7424600E-04,.7207000E-04,& - & .6718300E-04,.6590600E-04,.6461900E-04,.6300000E-04,.6105600E-04,& - & .5874100E-04,.5764900E-04,.5602800E-04,.5429300E-04,.5250600E-04,& - & .5183900E-04,.5071500E-04,.4905300E-04,.4719500E-04,.4536800E-04,& - & .4432100E-04,.4329700E-04,.4192300E-04,.4029800E-04,.3874400E-04,& - & .3752700E-04,.3651600E-04,.3538000E-04,.3403700E-04,.3295100E-04,& - & .3175200E-04,.3070300E-04,.2958600E-04,.2849900E-04,.2751900E-04,& - & .2663800E-04,.2564300E-04,.2469300E-04,.2383200E-04,.2291300E-04,& - & .2232500E-04,.2148000E-04,.2062100E-04,.1986700E-04,.1906600E-04,& - & .1876400E-04,.1799800E-04,.1726900E-04,.1652700E-04,.1582100E-04,& - & .1565000E-04,.1499200E-04,.1435600E-04,.1371000E-04,.1311900E-04,& - & .1305400E-04,.1247700E-04,.1192900E-04,.1139300E-04,.1094800E-04,& - & .1085200E-04,.1039000E-04,.9919500E-05,.9502000E-05,.9199300E-05,& - & .9099000E-05,.8720900E-05,.8338400E-05,.8002900E-05,.7724500E-05,& - & .7716900E-05,.7366200E-05,.7055200E-05,.6802900E-05,.6574900E-05,& - & .6525000E-05,.6236400E-05,.6017200E-05,.5780400E-05,.5550400E-05,& - & .5516700E-05,.5302100E-05,.5108800E-05,.4911300E-05,.4715000E-05,& - & .4726100E-05,.4553000E-05,.4364100E-05,.4172500E-05,.4007700E-05,& - & .4064600E-05,.3906200E-05,.3747200E-05,.3600900E-05,.3454900E-05,& - & .3547900E-05,.3405700E-05,.3270400E-05,.3142000E-05,.3021900E-05,& - & .3135300E-05,.3027000E-05,.2902400E-05,.2777600E-05,.2660000E-05/ - - data absb(121:235, 1) / & - & .2659500E-05,.2562100E-05,.2464600E-05,.2358200E-05,.2256300E-05,& - & .2246800E-05,.2165100E-05,.2081200E-05,.2004300E-05,.1922100E-05,& - & .1900900E-05,.1833500E-05,.1768500E-05,.1703900E-05,.1640600E-05,& - & .1574600E-05,.1518800E-05,.1466900E-05,.1414800E-05,.1366800E-05,& - & .1300100E-05,.1256100E-05,.1212200E-05,.1171800E-05,.1130600E-05,& - & .1071600E-05,.1038000E-05,.1001800E-05,.9674500E-06,.9347500E-06,& - & .8765100E-06,.8517200E-06,.8245300E-06,.7956000E-06,.7701100E-06,& - & .7156500E-06,.6969900E-06,.6769900E-06,.6540300E-06,.6320200E-06,& - & .5839100E-06,.5694600E-06,.5531800E-06,.5357500E-06,.5177400E-06,& - & .4749000E-06,.4653100E-06,.4517500E-06,.4368600E-06,.4226000E-06,& - & .3871800E-06,.3761000E-06,.3665000E-06,.3558000E-06,.3441700E-06,& - & .3146400E-06,.3049400E-06,.2987200E-06,.2909600E-06,.2823000E-06,& - & .2554200E-06,.2488500E-06,.2431400E-06,.2374500E-06,.2309200E-06,& - & .2074100E-06,.2017500E-06,.1969900E-06,.1930500E-06,.1879100E-06,& - & .1676000E-06,.1640600E-06,.1599300E-06,.1563100E-06,.1532700E-06,& - & .1357900E-06,.1328700E-06,.1298500E-06,.1272500E-06,.1247000E-06,& - & .1100600E-06,.1075700E-06,.1056800E-06,.1031400E-06,.1010100E-06,& - & .8871100E-07,.8713100E-07,.8516200E-07,.8340500E-07,.8158500E-07,& - & .7088900E-07,.6991700E-07,.6869200E-07,.6746300E-07,.6604700E-07,& - & .5665900E-07,.5607700E-07,.5551800E-07,.5446200E-07,.5356300E-07,& - & .4538000E-07,.4515900E-07,.4471800E-07,.4406300E-07,.4311600E-07,& - & .3596200E-07,.3617700E-07,.3599700E-07,.3560000E-07,.3434000E-07,& - & .2857800E-07,.2892400E-07,.2890100E-07,.2817600E-07,.2724600E-07/ - - data absb( 1:120, 2) / & - & .6321500E-03,.6475600E-03,.6573400E-03,.6651500E-03,.6707700E-03,& - & .5237800E-03,.5363100E-03,.5448500E-03,.5507100E-03,.5560500E-03,& - & .4377700E-03,.4481400E-03,.4552100E-03,.4612400E-03,.4670000E-03,& - & .3702300E-03,.3786900E-03,.3856800E-03,.3907000E-03,.3976000E-03,& - & .3175300E-03,.3263200E-03,.3325400E-03,.3381700E-03,.3431200E-03,& - & .2758000E-03,.2831000E-03,.2891500E-03,.2948800E-03,.2985500E-03,& - & .2412900E-03,.2469700E-03,.2530200E-03,.2578500E-03,.2613700E-03,& - & .2047000E-03,.2104000E-03,.2155200E-03,.2196300E-03,.2226000E-03,& - & .1729000E-03,.1778200E-03,.1818800E-03,.1851300E-03,.1879400E-03,& - & .1459900E-03,.1506300E-03,.1538900E-03,.1568200E-03,.1596500E-03,& - & .1239000E-03,.1279700E-03,.1307100E-03,.1334700E-03,.1357100E-03,& - & .1055300E-03,.1087500E-03,.1113400E-03,.1135100E-03,.1151300E-03,& - & .9026300E-04,.9256000E-04,.9466700E-04,.9622500E-04,.9704100E-04,& - & .7654200E-04,.7822700E-04,.7975500E-04,.8076800E-04,.8141200E-04,& - & .6456200E-04,.6602400E-04,.6712100E-04,.6787800E-04,.6799200E-04,& - & .5458700E-04,.5566800E-04,.5643900E-04,.5677800E-04,.5664900E-04,& - & .4624800E-04,.4688500E-04,.4746900E-04,.4747600E-04,.4746400E-04,& - & .3908400E-04,.3970100E-04,.3983600E-04,.3991900E-04,.3976200E-04,& - & .3329700E-04,.3367000E-04,.3378100E-04,.3357100E-04,.3341800E-04,& - & .2847500E-04,.2847900E-04,.2835200E-04,.2820200E-04,.2810700E-04,& - & .2402300E-04,.2397700E-04,.2387400E-04,.2385800E-04,.2372900E-04,& - & .2027600E-04,.2031400E-04,.2026200E-04,.2020500E-04,.2001300E-04,& - & .1717700E-04,.1717900E-04,.1718100E-04,.1704800E-04,.1691500E-04,& - & .1458600E-04,.1463200E-04,.1456900E-04,.1446500E-04,.1440400E-04/ - - data absb(121:235, 2) / & - & .1216500E-04,.1222000E-04,.1216400E-04,.1209900E-04,.1203600E-04,& - & .1017800E-04,.1022400E-04,.1020100E-04,.1013400E-04,.1006000E-04,& - & .8562200E-05,.8582600E-05,.8552000E-05,.8510900E-05,.8437800E-05,& - & .7026300E-05,.7054900E-05,.7033400E-05,.7000000E-05,.6950000E-05,& - & .5751000E-05,.5774900E-05,.5769200E-05,.5738400E-05,.5712100E-05,& - & .4703800E-05,.4726100E-05,.4727800E-05,.4702300E-05,.4686700E-05,& - & .3824900E-05,.3833900E-05,.3849800E-05,.3836400E-05,.3812500E-05,& - & .3097300E-05,.3112000E-05,.3116600E-05,.3120300E-05,.3102200E-05,& - & .2508500E-05,.2526300E-05,.2529300E-05,.2532800E-05,.2524900E-05,& - & .2026100E-05,.2047900E-05,.2056500E-05,.2057500E-05,.2058800E-05,& - & .1631900E-05,.1663900E-05,.1674500E-05,.1674000E-05,.1675900E-05,& - & .1309700E-05,.1344900E-05,.1361100E-05,.1362400E-05,.1358900E-05,& - & .1052100E-05,.1084700E-05,.1105200E-05,.1110200E-05,.1108500E-05,& - & .8466800E-06,.8723500E-06,.8954400E-06,.9060700E-06,.9061600E-06,& - & .6806000E-06,.7018000E-06,.7218700E-06,.7356200E-06,.7380000E-06,& - & .5463400E-06,.5648100E-06,.5825600E-06,.5954300E-06,.6012200E-06,& - & .4386600E-06,.4557700E-06,.4695700E-06,.4817600E-06,.4894000E-06,& - & .3506200E-06,.3664700E-06,.3793500E-06,.3897800E-06,.3969700E-06,& - & .2788300E-06,.2951400E-06,.3039700E-06,.3125100E-06,.3200400E-06,& - & .2209800E-06,.2355000E-06,.2428900E-06,.2501800E-06,.2570800E-06,& - & .1729500E-06,.1862400E-06,.1933200E-06,.1993400E-06,.2058700E-06,& - & .1362300E-06,.1468000E-06,.1540300E-06,.1591200E-06,.1649900E-06,& - & .1086400E-06,.1168000E-06,.1235300E-06,.1284000E-06,.1335200E-06/ - - data absb( 1:120, 3) / & - & .2106900E-02,.2157100E-02,.2194300E-02,.2206100E-02,.2212400E-02,& - & .1741100E-02,.1783300E-02,.1809700E-02,.1822500E-02,.1825100E-02,& - & .1444000E-02,.1479000E-02,.1496300E-02,.1506600E-02,.1506600E-02,& - & .1199800E-02,.1226100E-02,.1239800E-02,.1250000E-02,.1248700E-02,& - & .9998000E-03,.1020200E-02,.1033200E-02,.1039900E-02,.1039200E-02,& - & .8380500E-03,.8562900E-03,.8682700E-03,.8730300E-03,.8754000E-03,& - & .7074300E-03,.7238100E-03,.7325100E-03,.7355000E-03,.7393100E-03,& - & .5934800E-03,.6057200E-03,.6113700E-03,.6149600E-03,.6176100E-03,& - & .4955600E-03,.5048800E-03,.5098700E-03,.5142100E-03,.5158100E-03,& - & .4146100E-03,.4214500E-03,.4258400E-03,.4296900E-03,.4305500E-03,& - & .3468300E-03,.3518100E-03,.3566000E-03,.3591100E-03,.3595800E-03,& - & .2900400E-03,.2938300E-03,.2978700E-03,.2996400E-03,.3004200E-03,& - & .2414600E-03,.2456100E-03,.2487900E-03,.2505300E-03,.2513400E-03,& - & .2016000E-03,.2053700E-03,.2077400E-03,.2092800E-03,.2102300E-03,& - & .1691600E-03,.1722600E-03,.1738600E-03,.1752900E-03,.1763400E-03,& - & .1418300E-03,.1441400E-03,.1460400E-03,.1474100E-03,.1484400E-03,& - & .1195400E-03,.1216100E-03,.1228600E-03,.1238600E-03,.1244800E-03,& - & .1006700E-03,.1020500E-03,.1033100E-03,.1040900E-03,.1047600E-03,& - & .8501400E-04,.8624800E-04,.8702400E-04,.8795800E-04,.8857900E-04,& - & .7193000E-04,.7307400E-04,.7398500E-04,.7493400E-04,.7484800E-04,& - & .6120500E-04,.6225900E-04,.6320900E-04,.6338300E-04,.6346600E-04,& - & .5204600E-04,.5289600E-04,.5342000E-04,.5351600E-04,.5375500E-04,& - & .4438000E-04,.4512100E-04,.4527700E-04,.4560400E-04,.4576100E-04,& - & .3805800E-04,.3840900E-04,.3865700E-04,.3881300E-04,.3862800E-04/ - - data absb(121:235, 3) / & - & .3173500E-04,.3199000E-04,.3219900E-04,.3228800E-04,.3217900E-04,& - & .2637800E-04,.2666700E-04,.2677800E-04,.2684000E-04,.2676000E-04,& - & .2194900E-04,.2219500E-04,.2234000E-04,.2233000E-04,.2228100E-04,& - & .1800100E-04,.1820900E-04,.1833800E-04,.1837600E-04,.1830900E-04,& - & .1471500E-04,.1490600E-04,.1502500E-04,.1509800E-04,.1502600E-04,& - & .1201900E-04,.1219700E-04,.1231200E-04,.1238000E-04,.1234600E-04,& - & .9756600E-05,.9931800E-05,.1003600E-04,.1009600E-04,.1011800E-04,& - & .7881000E-05,.8071600E-05,.8163700E-05,.8220200E-05,.8260800E-05,& - & .6354100E-05,.6517100E-05,.6633000E-05,.6697700E-05,.6723900E-05,& - & .5107700E-05,.5242800E-05,.5363600E-05,.5436300E-05,.5469300E-05,& - & .4088300E-05,.4219600E-05,.4319900E-05,.4407400E-05,.4446200E-05,& - & .3290900E-05,.3394100E-05,.3474600E-05,.3554600E-05,.3608900E-05,& - & .2640100E-05,.2726900E-05,.2800300E-05,.2861600E-05,.2918800E-05,& - & .2122200E-05,.2203200E-05,.2263800E-05,.2312700E-05,.2360300E-05,& - & .1705600E-05,.1783800E-05,.1838600E-05,.1880400E-05,.1913400E-05,& - & .1366200E-05,.1433300E-05,.1485500E-05,.1523800E-05,.1552100E-05,& - & .1088900E-05,.1144500E-05,.1195500E-05,.1230000E-05,.1256000E-05,& - & .8625100E-06,.9155600E-06,.9599900E-06,.9945400E-06,.1017100E-05,& - & .6864000E-06,.7286800E-06,.7738900E-06,.8062700E-06,.8269600E-06,& - & .5433400E-06,.5833900E-06,.6195300E-06,.6519000E-06,.6728500E-06,& - & .4333600E-06,.4651100E-06,.4956100E-06,.5233700E-06,.5449100E-06,& - & .3442800E-06,.3723600E-06,.3968700E-06,.4201700E-06,.4379000E-06,& - & .2788300E-06,.3023700E-06,.3209600E-06,.3397800E-06,.3548500E-06/ - - data absb( 1:120, 4) / & - & .5280600E-02,.5355100E-02,.5383600E-02,.5381000E-02,.5341300E-02,& - & .4359400E-02,.4411400E-02,.4426800E-02,.4418300E-02,.4387700E-02,& - & .3608000E-02,.3642100E-02,.3660300E-02,.3654000E-02,.3630700E-02,& - & .3000700E-02,.3032400E-02,.3047900E-02,.3037700E-02,.3017500E-02,& - & .2511300E-02,.2541500E-02,.2548900E-02,.2542800E-02,.2528100E-02,& - & .2111900E-02,.2134000E-02,.2139600E-02,.2138100E-02,.2123200E-02,& - & .1770500E-02,.1788400E-02,.1794200E-02,.1793100E-02,.1781900E-02,& - & .1471400E-02,.1485400E-02,.1492100E-02,.1492000E-02,.1487400E-02,& - & .1222400E-02,.1234900E-02,.1243200E-02,.1241100E-02,.1239500E-02,& - & .1017000E-02,.1028100E-02,.1031900E-02,.1031000E-02,.1028600E-02,& - & .8468100E-03,.8548400E-03,.8551700E-03,.8554500E-03,.8557100E-03,& - & .7033000E-03,.7087500E-03,.7107800E-03,.7126100E-03,.7111200E-03,& - & .5848100E-03,.5887000E-03,.5915700E-03,.5930500E-03,.5923400E-03,& - & .4864000E-03,.4904400E-03,.4939500E-03,.4946800E-03,.4946600E-03,& - & .4047200E-03,.4091500E-03,.4123500E-03,.4127800E-03,.4134500E-03,& - & .3382600E-03,.3420500E-03,.3436400E-03,.3448000E-03,.3452800E-03,& - & .2830800E-03,.2862700E-03,.2879200E-03,.2891000E-03,.2895800E-03,& - & .2375900E-03,.2399400E-03,.2419600E-03,.2429500E-03,.2427000E-03,& - & .1999300E-03,.2020200E-03,.2039000E-03,.2045600E-03,.2041100E-03,& - & .1685100E-03,.1706000E-03,.1715100E-03,.1716900E-03,.1713300E-03,& - & .1427500E-03,.1439200E-03,.1444500E-03,.1445200E-03,.1439900E-03,& - & .1206000E-03,.1214200E-03,.1218100E-03,.1216500E-03,.1210500E-03,& - & .1016800E-03,.1024000E-03,.1027600E-03,.1026100E-03,.1020200E-03,& - & .8578000E-04,.8663600E-04,.8681500E-04,.8678000E-04,.8672200E-04/ - - data absb(121:235, 4) / & - & .7154000E-04,.7220100E-04,.7242200E-04,.7250100E-04,.7239800E-04,& - & .5960900E-04,.6015200E-04,.6044300E-04,.6054000E-04,.6053400E-04,& - & .4968100E-04,.5019400E-04,.5048100E-04,.5064900E-04,.5064300E-04,& - & .4081500E-04,.4133500E-04,.4156500E-04,.4172900E-04,.4177600E-04,& - & .3347600E-04,.3393200E-04,.3417100E-04,.3430100E-04,.3439700E-04,& - & .2741900E-04,.2782400E-04,.2808300E-04,.2822100E-04,.2829600E-04,& - & .2234900E-04,.2275300E-04,.2297500E-04,.2310000E-04,.2316400E-04,& - & .1819700E-04,.1848800E-04,.1874700E-04,.1887800E-04,.1894300E-04,& - & .1481500E-04,.1508100E-04,.1528400E-04,.1540800E-04,.1549300E-04,& - & .1204600E-04,.1230400E-04,.1247600E-04,.1259000E-04,.1265400E-04,& - & .9783400E-05,.1001800E-04,.1018700E-04,.1029500E-04,.1036500E-04,& - & .7905800E-05,.8158300E-05,.8315800E-05,.8425900E-05,.8479100E-05,& - & .6384700E-05,.6621200E-05,.6773500E-05,.6881800E-05,.6938200E-05,& - & .5161900E-05,.5369800E-05,.5523900E-05,.5623000E-05,.5693100E-05,& - & .4176400E-05,.4354600E-05,.4501800E-05,.4592700E-05,.4660900E-05,& - & .3369600E-05,.3530200E-05,.3658500E-05,.3754800E-05,.3809100E-05,& - & .2714200E-05,.2858500E-05,.2970000E-05,.3063200E-05,.3116300E-05,& - & .2197400E-05,.2317600E-05,.2416900E-05,.2498000E-05,.2555500E-05,& - & .1782000E-05,.1882700E-05,.1964700E-05,.2034700E-05,.2089500E-05,& - & .1444500E-05,.1527400E-05,.1599900E-05,.1655800E-05,.1700400E-05,& - & .1161200E-05,.1239000E-05,.1302000E-05,.1350800E-05,.1388100E-05,& - & .9360600E-06,.1001700E-05,.1059800E-05,.1101600E-05,.1136700E-05,& - & .7668200E-06,.8231800E-06,.8728100E-06,.9120800E-06,.9403700E-06/ - - data absb( 1:120, 5) / & - & .2162906E-01,.2201877E-01,.2224013E-01,.2232097E-01,.2226088E-01,& - & .1828684E-01,.1857354E-01,.1872091E-01,.1873615E-01,.1863965E-01,& - & .1535086E-01,.1556848E-01,.1564923E-01,.1561925E-01,.1551236E-01,& - & .1285052E-01,.1299486E-01,.1303075E-01,.1299836E-01,.1289615E-01,& - & .1075316E-01,.1084397E-01,.1086973E-01,.1082689E-01,.1072798E-01,& - & .9002505E-02,.9072913E-02,.9081241E-02,.9034900E-02,.8955849E-02,& - & .7562305E-02,.7609626E-02,.7609405E-02,.7571232E-02,.7507851E-02,& - & .6329221E-02,.6362683E-02,.6359991E-02,.6325694E-02,.6271378E-02,& - & .5284028E-02,.5311691E-02,.5305973E-02,.5285178E-02,.5242950E-02,& - & .4403121E-02,.4424122E-02,.4421960E-02,.4403212E-02,.4371719E-02,& - & .3670406E-02,.3685830E-02,.3685814E-02,.3671437E-02,.3647935E-02,& - & .3056358E-02,.3068927E-02,.3067363E-02,.3057520E-02,.3043098E-02,& - & .2542912E-02,.2553558E-02,.2555470E-02,.2549363E-02,.2539078E-02,& - & .2116477E-02,.2124848E-02,.2126732E-02,.2124859E-02,.2121688E-02,& - & .1763370E-02,.1771671E-02,.1775722E-02,.1777888E-02,.1775372E-02,& - & .1472312E-02,.1480631E-02,.1485906E-02,.1489295E-02,.1490270E-02,& - & .1235246E-02,.1243142E-02,.1250718E-02,.1254010E-02,.1256275E-02,& - & .1040850E-02,.1049997E-02,.1055542E-02,.1060339E-02,.1065075E-02,& - & .8811911E-03,.8895566E-03,.8956959E-03,.9025351E-03,.9097381E-03,& - & .7497834E-03,.7578993E-03,.7659613E-03,.7738154E-03,.7827692E-03,& - & .6406593E-03,.6501363E-03,.6581906E-03,.6679566E-03,.6771392E-03,& - & .5512107E-03,.5601135E-03,.5694184E-03,.5792748E-03,.5886259E-03,& - & .4749345E-03,.4844659E-03,.4947239E-03,.5042924E-03,.5143445E-03,& - & .4104977E-03,.4207339E-03,.4309147E-03,.4409904E-03,.4509584E-03/ - - data absb(121:235, 5) / & - & .3490867E-03,.3588313E-03,.3687089E-03,.3789368E-03,.3886881E-03,& - & .2966250E-03,.3063019E-03,.3155889E-03,.3255266E-03,.3349869E-03,& - & .2526321E-03,.2616358E-03,.2706359E-03,.2802750E-03,.2890766E-03,& - & .2118746E-03,.2200243E-03,.2284269E-03,.2373129E-03,.2453378E-03,& - & .1772518E-03,.1845848E-03,.1923345E-03,.2004084E-03,.2080501E-03,& - & .1480145E-03,.1547136E-03,.1617671E-03,.1689561E-03,.1761243E-03,& - & .1228565E-03,.1288933E-03,.1351904E-03,.1417161E-03,.1481713E-03,& - & .1015563E-03,.1069125E-03,.1124515E-03,.1181336E-03,.1240966E-03,& - & .8391796E-04,.8846774E-04,.9331366E-04,.9841094E-04,.1037701E-03,& - & .6907800E-04,.7301768E-04,.7725329E-04,.8170854E-04,.8659904E-04,& - & .5663202E-04,.6003002E-04,.6370177E-04,.6762785E-04,.7189491E-04,& - & .4624238E-04,.4927219E-04,.5239730E-04,.5580819E-04,.5956741E-04,& - & .3765713E-04,.4030391E-04,.4301446E-04,.4597554E-04,.4926441E-04,& - & .3073045E-04,.3306204E-04,.3540699E-04,.3792633E-04,.4077919E-04,& - & .2508246E-04,.2707468E-04,.2909111E-04,.3125371E-04,.3371262E-04,& - & .2044678E-04,.2211599E-04,.2384933E-04,.2568808E-04,.2780633E-04,& - & .1657839E-04,.1800707E-04,.1948311E-04,.2105650E-04,.2284205E-04,& - & .1347071E-04,.1469642E-04,.1596158E-04,.1729776E-04,.1878962E-04,& - & .1095998E-04,.1197888E-04,.1307499E-04,.1421130E-04,.1546214E-04,& - & .8897744E-05,.9746282E-05,.1066740E-04,.1163972E-04,.1268761E-04,& - & .7209215E-05,.7906994E-05,.8676190E-05,.9504972E-05,.1037954E-04,& - & .5835869E-05,.6420526E-05,.7058145E-05,.7757162E-05,.8507066E-05,& - & .4829548E-05,.5320639E-05,.5859975E-05,.6447762E-05,.7091888E-05/ - - data absb( 1:120, 6) / & - & .1413456E+00,.1451118E+00,.1482471E+00,.1506848E+00,.1524351E+00,& - & .1284824E+00,.1323235E+00,.1353715E+00,.1377662E+00,.1396511E+00,& - & .1165087E+00,.1201098E+00,.1230983E+00,.1255529E+00,.1275427E+00,& - & .1056253E+00,.1090989E+00,.1120377E+00,.1145066E+00,.1165271E+00,& - & .9552257E-01,.9900700E-01,.1020287E+00,.1046013E+00,.1068915E+00,& - & .8651031E-01,.9000117E-01,.9310752E-01,.9595637E-01,.9839325E-01,& - & .7836450E-01,.8201222E-01,.8531971E-01,.8822345E-01,.9085876E-01,& - & .7092238E-01,.7459607E-01,.7796568E-01,.8111548E-01,.8403243E-01,& - & .6424556E-01,.6792949E-01,.7138543E-01,.7475690E-01,.7782387E-01,& - & .5852648E-01,.6226349E-01,.6593117E-01,.6939257E-01,.7271605E-01,& - & .5365315E-01,.5746839E-01,.6121888E-01,.6482400E-01,.6833360E-01,& - & .4952470E-01,.5342082E-01,.5723031E-01,.6098038E-01,.6470372E-01,& - & .4609148E-01,.5006244E-01,.5398056E-01,.5794359E-01,.6187053E-01,& - & .4334627E-01,.4739302E-01,.5147575E-01,.5560970E-01,.5968009E-01,& - & .4118624E-01,.4532777E-01,.4955345E-01,.5391898E-01,.5813420E-01,& - & .3952662E-01,.4385566E-01,.4826024E-01,.5268550E-01,.5705181E-01,& - & .3841724E-01,.4291105E-01,.4755308E-01,.5207099E-01,.5646855E-01,& - & .3779958E-01,.4252491E-01,.4729707E-01,.5191028E-01,.5641217E-01,& - & .3769831E-01,.4260967E-01,.4736941E-01,.5212121E-01,.5677123E-01,& - & .3802439E-01,.4300132E-01,.4793508E-01,.5274887E-01,.5740482E-01,& - & .3864580E-01,.4371453E-01,.4869077E-01,.5366066E-01,.5849903E-01,& - & .3933702E-01,.4447547E-01,.4962428E-01,.5473829E-01,.5982359E-01,& - & .3971900E-01,.4497057E-01,.5034745E-01,.5572486E-01,.6081806E-01,& - & .3964192E-01,.4514283E-01,.5071851E-01,.5624884E-01,.6141856E-01/ - - data absb(121:235, 6) / & - & .3866583E-01,.4430320E-01,.4992214E-01,.5555938E-01,.6080523E-01,& - & .3776931E-01,.4345093E-01,.4914913E-01,.5483878E-01,.6021309E-01,& - & .3697431E-01,.4267835E-01,.4846432E-01,.5419260E-01,.5971603E-01,& - & .3540090E-01,.4109817E-01,.4690264E-01,.5270132E-01,.5824775E-01,& - & .3376861E-01,.3944516E-01,.4521743E-01,.5105174E-01,.5670807E-01,& - & .3217884E-01,.3777623E-01,.4359346E-01,.4943539E-01,.5515047E-01,& - & .3023451E-01,.3578942E-01,.4155720E-01,.4739287E-01,.5322236E-01,& - & .2814056E-01,.3368562E-01,.3938021E-01,.4520123E-01,.5100155E-01,& - & .2613012E-01,.3159507E-01,.3723484E-01,.4301429E-01,.4881413E-01,& - & .2404068E-01,.2939351E-01,.3504512E-01,.4079501E-01,.4656480E-01,& - & .2179194E-01,.2706163E-01,.3260199E-01,.3830559E-01,.4403615E-01,& - & .1964345E-01,.2472402E-01,.3015571E-01,.3586422E-01,.4157514E-01,& - & .1761158E-01,.2244787E-01,.2779047E-01,.3341890E-01,.3908741E-01,& - & .1578946E-01,.2041434E-01,.2560918E-01,.3115439E-01,.3682998E-01,& - & .1410355E-01,.1854242E-01,.2353769E-01,.2895272E-01,.3464369E-01,& - & .1247313E-01,.1674870E-01,.2151305E-01,.2681285E-01,.3241759E-01,& - & .1093422E-01,.1501782E-01,.1957117E-01,.2466990E-01,.3022010E-01,& - & .9611967E-02,.1347400E-01,.1786246E-01,.2277546E-01,.2821315E-01,& - & .8428789E-02,.1205812E-01,.1629395E-01,.2103849E-01,.2627794E-01,& - & .7314617E-02,.1072816E-01,.1475277E-01,.1935069E-01,.2443117E-01,& - & .6277076E-02,.9462864E-02,.1326850E-01,.1769409E-01,.2260642E-01,& - & .5370648E-02,.8332516E-02,.1192724E-01,.1617813E-01,.2094606E-01,& - & .5000457E-02,.7850552E-02,.1134835E-01,.1553696E-01,.2024820E-01/ - - data absb( 1:120, 7) / & - & .1233797E+01,.1240309E+01,.1245906E+01,.1249038E+01,.1250667E+01,& - & .1227509E+01,.1237527E+01,.1245130E+01,.1250890E+01,.1254582E+01,& - & .1220370E+01,.1233242E+01,.1243916E+01,.1252002E+01,.1257208E+01,& - & .1209755E+01,.1226066E+01,.1239648E+01,.1251101E+01,.1262465E+01,& - & .1198271E+01,.1218221E+01,.1236549E+01,.1253105E+01,.1264757E+01,& - & .1187954E+01,.1214287E+01,.1237014E+01,.1254616E+01,.1268426E+01,& - & .1184097E+01,.1214093E+01,.1238496E+01,.1259993E+01,.1276453E+01,& - & .1180879E+01,.1213827E+01,.1241956E+01,.1265044E+01,.1281987E+01,& - & .1178298E+01,.1215263E+01,.1245209E+01,.1269051E+01,.1287376E+01,& - & .1182695E+01,.1219813E+01,.1250266E+01,.1274554E+01,.1293058E+01,& - & .1187264E+01,.1225491E+01,.1256328E+01,.1280895E+01,.1299927E+01,& - & .1193354E+01,.1231549E+01,.1262983E+01,.1287976E+01,.1307592E+01,& - & .1201358E+01,.1239017E+01,.1270766E+01,.1295922E+01,.1315914E+01,& - & .1210113E+01,.1248264E+01,.1279581E+01,.1304944E+01,.1322887E+01,& - & .1220261E+01,.1258227E+01,.1289322E+01,.1313044E+01,.1333034E+01,& - & .1231439E+01,.1268725E+01,.1298471E+01,.1322363E+01,.1344202E+01,& - & .1243861E+01,.1279684E+01,.1309193E+01,.1334435E+01,.1354444E+01,& - & .1256537E+01,.1292561E+01,.1320904E+01,.1346216E+01,.1368544E+01,& - & .1270814E+01,.1305822E+01,.1336261E+01,.1360944E+01,.1384844E+01,& - & .1288177E+01,.1321480E+01,.1350393E+01,.1377826E+01,.1400827E+01,& - & .1302859E+01,.1337128E+01,.1367775E+01,.1395784E+01,.1419468E+01,& - & .1319163E+01,.1354279E+01,.1387311E+01,.1414162E+01,.1436650E+01,& - & .1332975E+01,.1371023E+01,.1402616E+01,.1431177E+01,.1453004E+01,& - & .1345134E+01,.1383758E+01,.1415866E+01,.1445650E+01,.1471428E+01/ - - data absb(121:235, 7) / & - & .1345082E+01,.1383743E+01,.1417311E+01,.1448976E+01,.1475650E+01,& - & .1344235E+01,.1383125E+01,.1418137E+01,.1452392E+01,.1479460E+01,& - & .1345148E+01,.1385709E+01,.1420152E+01,.1456438E+01,.1484592E+01,& - & .1336140E+01,.1378290E+01,.1414883E+01,.1450315E+01,.1479273E+01,& - & .1326907E+01,.1369209E+01,.1406929E+01,.1443061E+01,.1473182E+01,& - & .1317970E+01,.1361334E+01,.1398756E+01,.1434897E+01,.1468648E+01,& - & .1307925E+01,.1351090E+01,.1391766E+01,.1425847E+01,.1460105E+01,& - & .1292135E+01,.1338462E+01,.1379193E+01,.1415171E+01,.1450080E+01,& - & .1275926E+01,.1325616E+01,.1367315E+01,.1406267E+01,.1439728E+01,& - & .1262168E+01,.1313046E+01,.1356870E+01,.1395704E+01,.1429802E+01,& - & .1243844E+01,.1297984E+01,.1345253E+01,.1384776E+01,.1423560E+01,& - & .1221932E+01,.1280865E+01,.1330001E+01,.1373395E+01,.1410813E+01,& - & .1200347E+01,.1260855E+01,.1314395E+01,.1359376E+01,.1397674E+01,& - & .1181546E+01,.1245642E+01,.1304804E+01,.1351665E+01,.1391744E+01,& - & .1161296E+01,.1229915E+01,.1291786E+01,.1343999E+01,.1385754E+01,& - & .1137476E+01,.1211401E+01,.1274402E+01,.1331651E+01,.1376935E+01,& - & .1111820E+01,.1188448E+01,.1255900E+01,.1313802E+01,.1364916E+01,& - & .1087055E+01,.1170159E+01,.1237638E+01,.1301159E+01,.1353229E+01,& - & .1062808E+01,.1149118E+01,.1221983E+01,.1285669E+01,.1342137E+01,& - & .1033591E+01,.1125023E+01,.1202761E+01,.1269609E+01,.1328922E+01,& - & .1001992E+01,.1099491E+01,.1180679E+01,.1251796E+01,.1314844E+01,& - & .9714260E+00,.1073483E+01,.1159480E+01,.1233092E+01,.1298532E+01,& - & .9605430E+00,.1062574E+01,.1153238E+01,.1229435E+01,.1295998E+01/ - - data absb( 1:120, 8) / & - & .8974716E+01,.8691653E+01,.8415802E+01,.8168444E+01,.7938743E+01,& - & .9715620E+01,.9387697E+01,.9091159E+01,.8812007E+01,.8550103E+01,& - & .1040539E+02,.1005124E+02,.9716540E+01,.9405217E+01,.9117647E+01,& - & .1107237E+02,.1067879E+02,.1030786E+02,.9949266E+01,.9577784E+01,& - & .1169578E+02,.1125483E+02,.1081775E+02,.1038726E+02,.9999236E+01,& - & .1224439E+02,.1171912E+02,.1121989E+02,.1076358E+02,.1033881E+02,& - & .1266035E+02,.1208097E+02,.1155062E+02,.1103907E+02,.1056995E+02,& - & .1303081E+02,.1240926E+02,.1182594E+02,.1128091E+02,.1079129E+02,& - & .1335386E+02,.1267661E+02,.1206291E+02,.1149646E+02,.1098015E+02,& - & .1353946E+02,.1285236E+02,.1221793E+02,.1163647E+02,.1110309E+02,& - & .1368295E+02,.1297221E+02,.1232355E+02,.1172711E+02,.1117398E+02,& - & .1377130E+02,.1305174E+02,.1238638E+02,.1177241E+02,.1119857E+02,& - & .1380231E+02,.1307928E+02,.1239887E+02,.1176960E+02,.1117753E+02,& - & .1379128E+02,.1305118E+02,.1236306E+02,.1171797E+02,.1114040E+02,& - & .1373516E+02,.1298613E+02,.1228873E+02,.1164833E+02,.1103314E+02,& - & .1364257E+02,.1288771E+02,.1219339E+02,.1154194E+02,.1089134E+02,& - & .1350900E+02,.1275874E+02,.1205091E+02,.1137192E+02,.1073702E+02,& - & .1335003E+02,.1258061E+02,.1187564E+02,.1118588E+02,.1051162E+02,& - & .1314747E+02,.1237631E+02,.1163728E+02,.1094357E+02,.1023812E+02,& - & .1288648E+02,.1212623E+02,.1139312E+02,.1065542E+02,.9954987E+01,& - & .1264609E+02,.1186159E+02,.1109721E+02,.1034029E+02,.9619395E+01,& - & .1238368E+02,.1157958E+02,.1077263E+02,.1001950E+02,.9300261E+01,& - & .1217819E+02,.1132895E+02,.1052829E+02,.9741813E+01,.9027899E+01,& - & .1202662E+02,.1116103E+02,.1034657E+02,.9538267E+01,.8771268E+01/ - - data absb(121:235, 8) / & - & .1208641E+02,.1121978E+02,.1038937E+02,.9556683E+01,.8777908E+01,& - & .1215415E+02,.1128733E+02,.1043945E+02,.9575262E+01,.8790855E+01,& - & .1219484E+02,.1131019E+02,.1047069E+02,.9582740E+01,.8782235E+01,& - & .1240319E+02,.1150569E+02,.1064514E+02,.9772131E+01,.8965666E+01,& - & .1261524E+02,.1172536E+02,.1085921E+02,.9982767E+01,.9163514E+01,& - & .1282029E+02,.1192789E+02,.1107155E+02,.1020133E+02,.9340664E+01,& - & .1305607E+02,.1217814E+02,.1129130E+02,.1045671E+02,.9593408E+01,& - & .1336869E+02,.1246260E+02,.1158864E+02,.1074016E+02,.9877648E+01,& - & .1367966E+02,.1274532E+02,.1187204E+02,.1099717E+02,.1016259E+02,& - & .1395988E+02,.1302676E+02,.1213900E+02,.1127751E+02,.1044562E+02,& - & .1430124E+02,.1334454E+02,.1243000E+02,.1157468E+02,.1069646E+02,& - & .1467926E+02,.1368264E+02,.1276261E+02,.1187105E+02,.1102298E+02,& - & .1504278E+02,.1404941E+02,.1309066E+02,.1219578E+02,.1135077E+02,& - & .1535675E+02,.1433897E+02,.1332735E+02,.1242447E+02,.1156923E+02,& - & .1567971E+02,.1462376E+02,.1359863E+02,.1264514E+02,.1177949E+02,& - & .1604096E+02,.1493692E+02,.1391760E+02,.1291724E+02,.1202255E+02,& - & .1641711E+02,.1529760E+02,.1424404E+02,.1325595E+02,.1230184E+02,& - & .1677154E+02,.1558947E+02,.1455293E+02,.1351142E+02,.1256144E+02,& - & .1711050E+02,.1590689E+02,.1481896E+02,.1379270E+02,.1280515E+02,& - & .1750874E+02,.1625687E+02,.1512545E+02,.1407639E+02,.1306970E+02,& - & .1793109E+02,.1661941E+02,.1546240E+02,.1437682E+02,.1334037E+02,& - & .1833366E+02,.1698072E+02,.1578011E+02,.1467905E+02,.1362875E+02,& - & .1847759E+02,.1713162E+02,.1587877E+02,.1475220E+02,.1369335E+02/ - -! --- - data forref(1:3,1: 8) / & - & .8605600E-06,.1304390E-05,.3823780E-05,.8179260E-06,.1585990E-05,& - & .6587710E-04,.1293690E-05,.8244060E-05,.9527780E-04,.4389180E-05,& - & .3753560E-04,.1191110E-03,.5773510E-04,.7309656E-04,.8352278E-04,& - & .2517591E-03,.2051344E-03,.5589648E-04,.3341543E-03,.2978433E-03,& - & .5905554E-04,.4375873E-03,.4018119E-03,.2342177E-03/ - -! the array selfref contains the coefficient of the water vapor -! self-continuum (including the energy term). the first index -! refers to temperature in 7.2 degree increments. for instance, -! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, -! etc. the second index runs over the g-channel (1 to 8). - - data selfref(1:10,1: 8) / & - & .7503700E-03,.6449380E-03,.5543210E-03,.4764360E-03,.4094940E-03,& - & .3519570E-03,.3025050E-03,.2600020E-03,.2234700E-03,.1920710E-03,& - & .1361350E-02,.1131870E-02,.9410760E-03,.7824400E-03,.6505460E-03,& - & .5408850E-03,.4497090E-03,.3739020E-03,.3108740E-03,.2584710E-03,& - & .3339500E-02,.2563910E-02,.1968450E-02,.1511290E-02,.1160300E-02,& - & .8908240E-03,.6839340E-03,.5250930E-03,.4031430E-03,.3095150E-03,& - & .7933920E-02,.5898650E-02,.4385480E-02,.3260480E-02,.2424080E-02,& - & .1802230E-02,.1339910E-02,.9961860E-03,.7406360E-03,.5506420E-03,& - & .8309571E-02,.7388342E-02,.6584621E-02,.5882080E-02,.5266743E-02,& - & .4726659E-02,.4251616E-02,.3832861E-02,.3462890E-02,.3135269E-02,& - & .1297838E-01,.1251031E-01,.1206401E-01,.1163845E-01,.1123247E-01,& - & .1084516E-01,.1047551E-01,.1012259E-01,.9785517E-02,.9463545E-02,& - & .1916794E-01,.1802151E-01,.1694407E-01,.1593151E-01,.1497992E-01,& - & .1408552E-01,.1324501E-01,.1245490E-01,.1171229E-01,.1101426E-01,& - & .2508831E-01,.2343262E-01,.2189176E-01,.2045740E-01,.1912177E-01,& - & .1787778E-01,.1671886E-01,.1563887E-01,.1463222E-01,.1369363E-01/ - -!........................................! - end module module_radsw_kgb18 ! -!========================================! - - -!========================================! - module module_radsw_kgb19 ! -!........................................! -! -! ********* the original program descriptions ********* ! -! ! -! originally by j.delamere, atmospheric & environmental research. ! -! revision: 2.4 ! -! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2) ! -! reformatted for f90 by jjmorcrette, ecmwf ! -! ! -! this table has been re-generated for reduced number of g-point ! -! by y.t.hou, ncep ! -! ! -! ********* ********* end description ********* ********* ! -! - use machine, only : kind_phys - use module_radsw_parameters, only : NG19 - -! - implicit none -! - private -! - integer, public :: MSA19, MSB19, MSF19, MFR19 - parameter (MSA19=585, MSB19=235, MSF19=10, MFR19=3) - - real (kind=kind_phys), public :: selfref(MSF19,NG19), & - & absa(MSA19,NG19), absb(MSB19,NG19), forref(MFR19,NG19) - -! --- rayleigh extinction coefficient at v = 4900 cm-1. - real (kind=kind_phys), parameter, public :: rayl = 2.29e-09 - -! the array absa(585,NG19) (ka(9,5,13,NG19)) contains absorption coefs at -! the 16 chosen g-values for a range of pressure levels> ~100mb, -! temperatures, and binary species parameters (see taumol.f for definition). -! the first index in the array, js, runs from 1 to 9, and corresponds to -! different values of the binary species parameter. for instance, -! js=1 refers to dry air, js = 2 corresponds to the paramter value 1/8, -! js = 3 corresponds to the parameter value 2/8, etc. the second index -! in the array, jt, which runs from 1 to 5, corresponds to different -! temperatures. more specifically, jt = 3 means that the data are for -! the reference temperature tref for this pressure level, jt = 2 refers -! to tref-15, jt = 1 is for tref-30, jt = 4 is for tref+15, and jt = 5 -! is for tref+30. the third index, jp, runs from 1 to 13 and refers -! to the jpth reference pressure level (see taumol.f for these levels -! in mb). the fourth index, ig, goes from 1 to 8, and indicates -! which g-interval the absorption coefficients are for. - - data absa( 1:180, 1) / & - & .1498100E-05,.2665900E-05,.3187400E-05,.3550900E-05,.3759300E-05,& - & .3851400E-05,.3736900E-05,.3501100E-05,.2389400E-05,.1510300E-05,& - & .2734800E-05,.3269200E-05,.3655800E-05,.3892600E-05,.3973700E-05,& - & .3879800E-05,.3656500E-05,.2407200E-05,.1523300E-05,.2809000E-05,& - & .3374400E-05,.3772900E-05,.4025800E-05,.4110700E-05,.4038900E-05,& - & .3822600E-05,.2470400E-05,.1521900E-05,.2897800E-05,.3501500E-05,& - & .3898400E-05,.4156900E-05,.4277100E-05,.4211000E-05,.3996300E-05,& - & .2550400E-05,.1525400E-05,.2963300E-05,.3622400E-05,.4043500E-05,& - & .4297500E-05,.4441000E-05,.4384900E-05,.4184700E-05,.2642000E-05,& - & .1302400E-05,.2369900E-05,.2837000E-05,.3144300E-05,.3332600E-05,& - & .3379800E-05,.3279700E-05,.3007800E-05,.1881900E-05,.1324900E-05,& - & .2429900E-05,.2910300E-05,.3233600E-05,.3430800E-05,.3501900E-05,& - & .3404600E-05,.3132300E-05,.1951100E-05,.1324100E-05,.2505900E-05,& - & .3001900E-05,.3331700E-05,.3551600E-05,.3633300E-05,.3537200E-05,& - & .3261500E-05,.2025400E-05,.1332500E-05,.2584000E-05,.3100900E-05,& - & .3439900E-05,.3669900E-05,.3772700E-05,.3681100E-05,.3401600E-05,& - & .2061100E-05,.1332100E-05,.2660100E-05,.3218900E-05,.3564000E-05,& - & .3801200E-05,.3911300E-05,.3827100E-05,.3549900E-05,.2136800E-05,& - & .1107900E-05,.2075700E-05,.2484600E-05,.2751100E-05,.2888300E-05,& - & .2914200E-05,.2820300E-05,.2570600E-05,.1512400E-05,.1129800E-05,& - & .2127800E-05,.2555100E-05,.2830600E-05,.2981400E-05,.3012600E-05,& - & .2932800E-05,.2672100E-05,.1578400E-05,.1140500E-05,.2181200E-05,& - & .2623700E-05,.2913000E-05,.3081600E-05,.3126500E-05,.3048000E-05,& - & .2778400E-05,.1646800E-05,.1134700E-05,.2247200E-05,.2709400E-05,& - & .3005700E-05,.3182100E-05,.3253600E-05,.3171400E-05,.2883700E-05,& - & .1718900E-05,.1138300E-05,.2315200E-05,.2801600E-05,.3112600E-05,& - & .3305100E-05,.3375900E-05,.3296100E-05,.2999300E-05,.1791900E-05,& - & .9310400E-06,.1800500E-05,.2169300E-05,.2381900E-05,.2482900E-05,& - & .2486000E-05,.2386000E-05,.2158600E-05,.1219800E-05,.9459100E-06,& - & .1830900E-05,.2215300E-05,.2448700E-05,.2557400E-05,.2572100E-05,& - & .2480200E-05,.2245800E-05,.1310500E-05,.9563800E-06,.1875300E-05,& - & .2278800E-05,.2514900E-05,.2649900E-05,.2667100E-05,.2579700E-05,& - & .2333500E-05,.1401700E-05,.9576300E-06,.1937900E-05,.2327100E-05,& - & .2585800E-05,.2743700E-05,.2779200E-05,.2679000E-05,.2426800E-05,& - & .1487200E-05,.9566800E-06,.1987700E-05,.2399700E-05,.2672100E-05,& - & .2838200E-05,.2880600E-05,.2785700E-05,.2522500E-05,.1569800E-05/ - - data absa(181:315, 1) / & - & .7732900E-06,.1535400E-05,.1872300E-05,.2041100E-05,.2109500E-05,& - & .2101700E-05,.1999800E-05,.1801700E-05,.9762900E-06,.7824100E-06,& - & .1566000E-05,.1909100E-05,.2097000E-05,.2178600E-05,.2173000E-05,& - & .2079400E-05,.1873100E-05,.1064500E-05,.7946300E-06,.1594800E-05,& - & .1945800E-05,.2152900E-05,.2255700E-05,.2257600E-05,.2163100E-05,& - & .1946200E-05,.1150700E-05,.7977900E-06,.1638900E-05,.1987700E-05,& - & .2208700E-05,.2327400E-05,.2346200E-05,.2250100E-05,.2020400E-05,& - & .1236600E-05,.7987500E-06,.1686500E-05,.2041000E-05,.2278900E-05,& - & .2404900E-05,.2428300E-05,.2338800E-05,.2100600E-05,.1315500E-05,& - & .6379900E-06,.1307900E-05,.1587300E-05,.1718700E-05,.1768900E-05,& - & .1750900E-05,.1662500E-05,.1495000E-05,.7762400E-06,.6442300E-06,& - & .1318000E-05,.1617300E-05,.1764800E-05,.1825300E-05,.1815200E-05,& - & .1729900E-05,.1548200E-05,.8545700E-06,.6521400E-06,.1348100E-05,& - & .1647600E-05,.1815800E-05,.1886700E-05,.1885900E-05,.1799900E-05,& - & .1608000E-05,.9396800E-06,.6594900E-06,.1372800E-05,.1679500E-05,& - & .1861800E-05,.1950700E-05,.1956800E-05,.1869300E-05,.1671000E-05,& - & .1025600E-05,.6601200E-06,.1405100E-05,.1717400E-05,.1915400E-05,& - & .2011100E-05,.2023000E-05,.1942100E-05,.1736100E-05,.1107200E-05,& - & .5265200E-06,.1099500E-05,.1322100E-05,.1428200E-05,.1462700E-05,& - & .1449400E-05,.1375400E-05,.1235900E-05,.6239900E-06,.5263100E-06,& - & .1104700E-05,.1349800E-05,.1464600E-05,.1509400E-05,.1496100E-05,& - & .1427200E-05,.1279100E-05,.6969200E-06,.5326300E-06,.1123100E-05,& - & .1376300E-05,.1505900E-05,.1560200E-05,.1553300E-05,.1482700E-05,& - & .1325700E-05,.7695900E-06,.5378800E-06,.1144800E-05,.1402600E-05,& - & .1547800E-05,.1612200E-05,.1613700E-05,.1539800E-05,.1374800E-05,& - & .8448800E-06,.5424300E-06,.1166000E-05,.1428800E-05,.1589100E-05,& - & .1661900E-05,.1667200E-05,.1597800E-05,.1426500E-05,.9243900E-06/ - - data absa(316:450, 1) / & - & .4286000E-06,.9120800E-06,.1088700E-05,.1173200E-05,.1200000E-05,& - & .1190100E-05,.1130000E-05,.1018100E-05,.5136000E-06,.4260500E-06,& - & .9135500E-06,.1110500E-05,.1200400E-05,.1235900E-05,.1223800E-05,& - & .1167400E-05,.1049600E-05,.5859300E-06,.4291000E-06,.9245800E-06,& - & .1134100E-05,.1235500E-05,.1275400E-05,.1266700E-05,.1210000E-05,& - & .1087700E-05,.6520900E-06,.4334500E-06,.9402400E-06,.1154000E-05,& - & .1266900E-05,.1318600E-05,.1316300E-05,.1256700E-05,.1128000E-05,& - & .7205100E-06,.4374400E-06,.9584500E-06,.1176400E-05,.1302200E-05,& - & .1359500E-05,.1361800E-05,.1303400E-05,.1167100E-05,.7937300E-06,& - & .3445800E-06,.7484400E-06,.8921700E-06,.9587500E-06,.9824300E-06,& - & .9756600E-06,.9293600E-06,.8361100E-06,.4418100E-06,.3479700E-06,& - & .7530400E-06,.9081600E-06,.9826400E-06,.1008000E-05,.9988900E-06,& - & .9531800E-06,.8604100E-06,.5101300E-06,.3459300E-06,.7602000E-06,& - & .9270700E-06,.1006200E-05,.1039100E-05,.1029600E-05,.9853000E-06,& - & .8901100E-06,.5807000E-06,.3497100E-06,.7708800E-06,.9462300E-06,& - & .1034200E-05,.1072600E-05,.1068900E-05,.1021000E-05,.9202000E-06,& - & .6569700E-06,.3528200E-06,.7851700E-06,.9624500E-06,.1060900E-05,& - & .1107100E-05,.1107300E-05,.1058300E-05,.9505400E-06,.7295600E-06,& - & .2784000E-06,.6103500E-06,.7293000E-06,.7841500E-06,.8045100E-06,& - & .7992400E-06,.7623100E-06,.6872700E-06,.4020800E-06,.2817100E-06,& - & .6179800E-06,.7419700E-06,.8011500E-06,.8218300E-06,.8162100E-06,& - & .7803000E-06,.7042500E-06,.4670000E-06,.2802300E-06,.6226900E-06,& - & .7568500E-06,.8210100E-06,.8453800E-06,.8382100E-06,.8030100E-06,& - & .7266300E-06,.5378100E-06,.2816300E-06,.6315600E-06,.7721400E-06,& - & .8424400E-06,.8718400E-06,.8675200E-06,.8302400E-06,.7500000E-06,& - & .6047800E-06,.2851800E-06,.6407000E-06,.7862800E-06,.8643900E-06,& - & .8996900E-06,.8991000E-06,.8593300E-06,.7737600E-06,.6701600E-06/ - - data absa(451:585, 1) / & - & .2255500E-06,.5004200E-06,.5996000E-06,.6453700E-06,.6632400E-06,& - & .6592400E-06,.6300300E-06,.5689000E-06,.3446600E-06,.2285800E-06,& - & .5070500E-06,.6099700E-06,.6594800E-06,.6768800E-06,.6731100E-06,& - & .6446200E-06,.5833300E-06,.4030000E-06,.2267700E-06,.5117800E-06,& - & .6229900E-06,.6757200E-06,.6962400E-06,.6912600E-06,.6628500E-06,& - & .6009000E-06,.4606600E-06,.2282500E-06,.5190700E-06,.6350000E-06,& - & .6931100E-06,.7179600E-06,.7148400E-06,.6841600E-06,.6185900E-06,& - & .5196600E-06,.2312200E-06,.5259800E-06,.6457400E-06,.7111600E-06,& - & .7404600E-06,.7397900E-06,.7067200E-06,.6370800E-06,.5819600E-06,& - & .1814900E-06,.4082900E-06,.4902200E-06,.5291000E-06,.5440800E-06,& - & .5416300E-06,.5186700E-06,.4693300E-06,.2849600E-06,.1843300E-06,& - & .4137800E-06,.4990800E-06,.5402700E-06,.5552200E-06,.5528600E-06,& - & .5303800E-06,.4810300E-06,.3333600E-06,.1824600E-06,.4179900E-06,& - & .5096500E-06,.5534700E-06,.5713400E-06,.5678700E-06,.5447700E-06,& - & .4946200E-06,.3802300E-06,.1840900E-06,.4234700E-06,.5193600E-06,& - & .5674900E-06,.5887700E-06,.5864800E-06,.5614900E-06,.5082500E-06,& - & .4308100E-06,.1858200E-06,.4288800E-06,.5283000E-06,.5824000E-06,& - & .6064700E-06,.6059800E-06,.5793300E-06,.5227700E-06,.4856500E-06,& - & .1434500E-06,.3292700E-06,.3975000E-06,.4300000E-06,.4431800E-06,& - & .4420100E-06,.4246900E-06,.3853800E-06,.2337700E-06,.1457100E-06,& - & .3335500E-06,.4043000E-06,.4395400E-06,.4525600E-06,.4515900E-06,& - & .4339900E-06,.3946700E-06,.2733800E-06,.1444200E-06,.3371900E-06,& - & .4131600E-06,.4499600E-06,.4657500E-06,.4636400E-06,.4452800E-06,& - & .4051000E-06,.3115400E-06,.1460000E-06,.3414100E-06,.4213600E-06,& - & .4609600E-06,.4793700E-06,.4781700E-06,.4585000E-06,.4159800E-06,& - & .3528900E-06,.1466700E-06,.3460800E-06,.4285300E-06,.4729600E-06,& - & .4930000E-06,.4935200E-06,.4728000E-06,.4275700E-06,.3975200E-06/ - - data absa( 1:180, 2) / & - & .1628800E-04,.2581700E-04,.2959700E-04,.3131900E-04,.3122000E-04,& - & .2953900E-04,.2562700E-04,.1975800E-04,.7294400E-05,.1812300E-04,& - & .2856500E-04,.3263300E-04,.3442700E-04,.3421900E-04,.3222300E-04,& - & .2798700E-04,.2148500E-04,.7955400E-05,.1995700E-04,.3160700E-04,& - & .3603300E-04,.3788700E-04,.3769400E-04,.3539900E-04,.3071800E-04,& - & .2341200E-04,.8529300E-05,.2200500E-04,.3506400E-04,.3976300E-04,& - & .4169400E-04,.4149000E-04,.3889100E-04,.3371500E-04,.2551200E-04,& - & .9123200E-05,.2424000E-04,.3890600E-04,.4389900E-04,.4587000E-04,& - & .4558000E-04,.4261600E-04,.3691200E-04,.2772800E-04,.9779200E-05,& - & .1494400E-04,.2322300E-04,.2579200E-04,.2701900E-04,.2696300E-04,& - & .2543100E-04,.2206900E-04,.1693300E-04,.5907100E-05,.1661500E-04,& - & .2545200E-04,.2832200E-04,.2980000E-04,.2959300E-04,.2777600E-04,& - & .2412300E-04,.1844400E-04,.6314200E-05,.1835500E-04,.2799600E-04,& - & .3133800E-04,.3289200E-04,.3257500E-04,.3047800E-04,.2650400E-04,& - & .2013200E-04,.6789800E-05,.2009200E-04,.3093800E-04,.3468000E-04,& - & .3625500E-04,.3583600E-04,.3350000E-04,.2910600E-04,.2195000E-04,& - & .7334300E-05,.2189700E-04,.3415000E-04,.3827400E-04,.3993100E-04,& - & .3933700E-04,.3675200E-04,.3183100E-04,.2388200E-04,.7870500E-05,& - & .1313000E-04,.2036300E-04,.2237700E-04,.2300300E-04,.2268300E-04,& - & .2142900E-04,.1862100E-04,.1417700E-04,.4789200E-05,.1461000E-04,& - & .2229900E-04,.2448600E-04,.2514000E-04,.2484200E-04,.2341300E-04,& - & .2036100E-04,.1546900E-04,.5225000E-05,.1613300E-04,.2448200E-04,& - & .2687600E-04,.2765300E-04,.2735700E-04,.2566900E-04,.2234100E-04,& - & .1689700E-04,.5664700E-05,.1770800E-04,.2688700E-04,.2952200E-04,& - & .3057700E-04,.3015100E-04,.2822100E-04,.2454500E-04,.1845500E-04,& - & .6073500E-05,.1930500E-04,.2936400E-04,.3252000E-04,.3374100E-04,& - & .3316200E-04,.3097600E-04,.2680000E-04,.2010300E-04,.6486400E-05,& - & .1116300E-04,.1749800E-04,.1906900E-04,.1956100E-04,.1915400E-04,& - & .1790600E-04,.1552200E-04,.1177800E-04,.4046100E-05,.1250500E-04,& - & .1923800E-04,.2091700E-04,.2136500E-04,.2091300E-04,.1947100E-04,& - & .1698600E-04,.1285600E-04,.4393500E-05,.1384800E-04,.2113200E-04,& - & .2297500E-04,.2343300E-04,.2289300E-04,.2132700E-04,.1866200E-04,& - & .1405600E-04,.4701500E-05,.1521900E-04,.2315900E-04,.2525000E-04,& - & .2575300E-04,.2508800E-04,.2343700E-04,.2045500E-04,.1536600E-04,& - & .5023900E-05,.1663100E-04,.2531100E-04,.2765100E-04,.2824300E-04,& - & .2756600E-04,.2577500E-04,.2234400E-04,.1675800E-04,.5359400E-05/ - - data absa(181:315, 2) / & - & .9268800E-05,.1482900E-04,.1603600E-04,.1638800E-04,.1608700E-04,& - & .1504900E-04,.1293900E-04,.9724300E-05,.3506400E-05,.1042800E-04,& - & .1628900E-04,.1759600E-04,.1792800E-04,.1754700E-04,.1634700E-04,& - & .1410800E-04,.1062100E-04,.3789300E-05,.1160000E-04,.1792200E-04,& - & .1940300E-04,.1970100E-04,.1922700E-04,.1783500E-04,.1543900E-04,& - & .1162700E-04,.4042600E-05,.1279500E-04,.1967200E-04,.2136000E-04,& - & .2167700E-04,.2107800E-04,.1953500E-04,.1691900E-04,.1274600E-04,& - & .4301500E-05,.1402900E-04,.2155100E-04,.2341000E-04,.2374600E-04,& - & .2310600E-04,.2139700E-04,.1850000E-04,.1391800E-04,.4566300E-05,& - & .7535800E-05,.1228400E-04,.1332100E-04,.1358000E-04,.1332200E-04,& - & .1245900E-04,.1075700E-04,.8001200E-05,.2859500E-05,.8480100E-05,& - & .1354100E-04,.1460000E-04,.1485700E-04,.1451900E-04,.1352800E-04,& - & .1174700E-04,.8719900E-05,.3125000E-05,.9479700E-05,.1489800E-04,& - & .1608800E-04,.1632900E-04,.1592200E-04,.1478600E-04,.1283900E-04,& - & .9540600E-05,.3392500E-05,.1051000E-04,.1638700E-04,.1770900E-04,& - & .1796800E-04,.1746500E-04,.1620500E-04,.1399900E-04,.1046500E-04,& - & .3678600E-05,.1155400E-04,.1797300E-04,.1944200E-04,.1973600E-04,& - & .1917000E-04,.1775100E-04,.1528800E-04,.1144100E-04,.3961800E-05,& - & .5999400E-05,.1006800E-04,.1090300E-04,.1110000E-04,.1091000E-04,& - & .1020700E-04,.8830100E-05,.6575500E-05,.2353700E-05,.6791100E-05,& - & .1109800E-04,.1196400E-04,.1216100E-04,.1191000E-04,.1111300E-04,& - & .9647500E-05,.7173300E-05,.2602100E-05,.7601200E-05,.1220500E-04,& - & .1316700E-04,.1336800E-04,.1305800E-04,.1213600E-04,.1057100E-04,& - & .7845200E-05,.2841600E-05,.8458200E-05,.1341200E-04,.1451800E-04,& - & .1472100E-04,.1432800E-04,.1332300E-04,.1152700E-04,.8599500E-05,& - & .3092500E-05,.9334600E-05,.1474900E-04,.1597300E-04,.1618000E-04,& - & .1573000E-04,.1459700E-04,.1260100E-04,.9397300E-05,.3328500E-05/ - - data absa(316:450, 2) / & - & .4717400E-05,.8136700E-05,.8818400E-05,.9000700E-05,.8836300E-05,& - & .8305900E-05,.7210100E-05,.5349600E-05,.1886200E-05,.5354300E-05,& - & .8985200E-05,.9690400E-05,.9866600E-05,.9650900E-05,.9036800E-05,& - & .7870000E-05,.5834100E-05,.2114700E-05,.6008800E-05,.9885500E-05,& - & .1066600E-04,.1084900E-04,.1059700E-04,.9882600E-05,.8624300E-05,& - & .6394900E-05,.2367200E-05,.6695800E-05,.1087300E-04,.1175100E-04,& - & .1194500E-04,.1163600E-04,.1085200E-04,.9410100E-05,.7026200E-05,& - & .2632900E-05,.7419100E-05,.1196000E-04,.1294300E-04,.1315200E-04,& - & .1278800E-04,.1188900E-04,.1029700E-04,.7697700E-05,.2901900E-05,& - & .3688600E-05,.6514000E-05,.7068400E-05,.7237700E-05,.7108000E-05,& - & .6707600E-05,.5835300E-05,.4329700E-05,.1641900E-05,.4177200E-05,& - & .7210400E-05,.7779300E-05,.7933500E-05,.7768200E-05,.7290300E-05,& - & .6364000E-05,.4721000E-05,.1872100E-05,.4712300E-05,.7947100E-05,& - & .8566200E-05,.8739600E-05,.8531900E-05,.7976900E-05,.6969400E-05,& - & .5179300E-05,.2101500E-05,.5261200E-05,.8731900E-05,.9436500E-05,& - & .9619100E-05,.9378300E-05,.8758100E-05,.7627700E-05,.5697400E-05,& - & .2350500E-05,.5840100E-05,.9610600E-05,.1040400E-04,.1059400E-04,& - & .1030800E-04,.9603000E-05,.8340200E-05,.6262700E-05,.2617000E-05,& - & .2902300E-05,.5223000E-05,.5666900E-05,.5815800E-05,.5713700E-05,& - & .5424100E-05,.4741600E-05,.3509800E-05,.1422300E-05,.3275200E-05,& - & .5790300E-05,.6254800E-05,.6385900E-05,.6252800E-05,.5888100E-05,& - & .5154200E-05,.3825700E-05,.1655900E-05,.3704700E-05,.6389200E-05,& - & .6892800E-05,.7031200E-05,.6873400E-05,.6435700E-05,.5636100E-05,& - & .4200300E-05,.1924800E-05,.4147100E-05,.7017900E-05,.7592000E-05,& - & .7749600E-05,.7550800E-05,.7062400E-05,.6177800E-05,.4627100E-05,& - & .2207400E-05,.4606100E-05,.7721500E-05,.8369900E-05,.8530000E-05,& - & .8312100E-05,.7749300E-05,.6755100E-05,.5093100E-05,.2504300E-05/ - - data absa(451:585, 2) / & - & .2406000E-05,.4375200E-05,.4737200E-05,.4859800E-05,.4768900E-05,& - & .4529000E-05,.3965300E-05,.2944400E-05,.1225500E-05,.2712300E-05,& - & .4847900E-05,.5233900E-05,.5348200E-05,.5234200E-05,.4927500E-05,& - & .4323900E-05,.3219600E-05,.1428200E-05,.3063200E-05,.5340200E-05,& - & .5766000E-05,.5893600E-05,.5751500E-05,.5387300E-05,.4734400E-05,& - & .3541000E-05,.1663600E-05,.3424500E-05,.5865300E-05,.6355400E-05,& - & .6487800E-05,.6324400E-05,.5914700E-05,.5185500E-05,.3906800E-05,& - & .1885800E-05,.3798400E-05,.6455700E-05,.7003200E-05,.7143200E-05,& - & .6959100E-05,.6493600E-05,.5674800E-05,.4288900E-05,.2152900E-05,& - & .1982200E-05,.3643800E-05,.3943900E-05,.4042800E-05,.3965600E-05,& - & .3762700E-05,.3304800E-05,.2462000E-05,.1034900E-05,.2234700E-05,& - & .4032900E-05,.4355900E-05,.4453500E-05,.4355600E-05,.4101800E-05,& - & .3615600E-05,.2697600E-05,.1207800E-05,.2519600E-05,.4440500E-05,& - & .4796500E-05,.4902500E-05,.4785000E-05,.4485400E-05,.3954200E-05,& - & .2973400E-05,.1390800E-05,.2814200E-05,.4879200E-05,.5288200E-05,& - & .5396200E-05,.5264600E-05,.4920200E-05,.4322900E-05,.3281700E-05,& - & .1589500E-05,.3118200E-05,.5368400E-05,.5825600E-05,.5941300E-05,& - & .5785500E-05,.5404300E-05,.4729800E-05,.3592500E-05,.1805000E-05,& - & .1620600E-05,.3012200E-05,.3261200E-05,.3345100E-05,.3279400E-05,& - & .3114400E-05,.2743000E-05,.2048800E-05,.8526700E-06,.1826700E-05,& - & .3333100E-05,.3600200E-05,.3681600E-05,.3605400E-05,.3395000E-05,& - & .3002100E-05,.2248700E-05,.9949000E-06,.2058700E-05,.3668100E-05,& - & .3965100E-05,.4053100E-05,.3956400E-05,.3712700E-05,.3281500E-05,& - & .2479500E-05,.1142200E-05,.2297300E-05,.4032500E-05,.4372800E-05,& - & .4460000E-05,.4354000E-05,.4071800E-05,.3584800E-05,.2736600E-05,& - & .1305100E-05,.2545200E-05,.4437900E-05,.4816400E-05,.4910000E-05,& - & .4783300E-05,.4467400E-05,.3919400E-05,.2990400E-05,.1481700E-05/ - - data absa( 1:180, 3) / & - & .6664100E-04,.9299000E-04,.9627700E-04,.9518200E-04,.9142400E-04,& - & .8544500E-04,.7701400E-04,.6209100E-04,.1828400E-04,.7535000E-04,& - & .1039100E-03,.1075100E-03,.1060600E-03,.1017400E-03,.9475600E-04,& - & .8448700E-04,.6726700E-04,.2003700E-04,.8528600E-04,.1156300E-03,& - & .1196600E-03,.1177700E-03,.1125900E-03,.1043500E-03,.9207600E-04,& - & .7249200E-04,.2222900E-04,.9613700E-04,.1283600E-03,.1326500E-03,& - & .1303100E-03,.1240400E-03,.1140900E-03,.9975600E-04,.7789700E-04,& - & .2465600E-04,.1073900E-03,.1420900E-03,.1465200E-03,.1436300E-03,& - & .1357900E-03,.1240800E-03,.1074900E-03,.8327300E-04,.2699800E-04,& - & .5700500E-04,.8068800E-04,.8419900E-04,.8306700E-04,.7948000E-04,& - & .7409600E-04,.6632800E-04,.5353200E-04,.1453400E-04,.6451800E-04,& - & .9027400E-04,.9414900E-04,.9249600E-04,.8837400E-04,.8204800E-04,& - & .7269800E-04,.5787100E-04,.1620200E-04,.7301400E-04,.1006500E-03,& - & .1046600E-03,.1027100E-03,.9788000E-04,.9037200E-04,.7936100E-04,& - & .6235700E-04,.1805600E-04,.8229700E-04,.1119500E-03,.1158600E-03,& - & .1136500E-03,.1079900E-03,.9882900E-04,.8592300E-04,.6689100E-04,& - & .1989000E-04,.9217500E-04,.1239900E-03,.1279400E-03,.1253100E-03,& - & .1182500E-03,.1076400E-03,.9274400E-04,.7160800E-04,.2196800E-04,& - & .4732400E-04,.6816700E-04,.7106900E-04,.7029300E-04,.6731300E-04,& - & .6245600E-04,.5564600E-04,.4493300E-04,.1137400E-04,.5365800E-04,& - & .7634200E-04,.7956000E-04,.7854700E-04,.7499700E-04,.6926400E-04,& - & .6111900E-04,.4858700E-04,.1263900E-04,.6090500E-04,.8524700E-04,& - & .8873800E-04,.8738700E-04,.8309800E-04,.7643200E-04,.6673300E-04,& - & .5227500E-04,.1387100E-04,.6883100E-04,.9496000E-04,.9863800E-04,& - & .9677800E-04,.9181600E-04,.8374700E-04,.7240300E-04,.5616500E-04,& - & .1542300E-04,.7725900E-04,.1054900E-03,.1090900E-03,.1067200E-03,& - & .1006500E-03,.9132000E-04,.7840600E-04,.6015700E-04,.1714100E-04,& - & .4010200E-04,.5699000E-04,.5944400E-04,.5873200E-04,.5609100E-04,& - & .5190200E-04,.4624700E-04,.3744200E-04,.9402200E-05,.4493000E-04,& - & .6389300E-04,.6662900E-04,.6569400E-04,.6262700E-04,.5782200E-04,& - & .5081900E-04,.4042100E-04,.1047500E-04,.5053200E-04,.7142400E-04,& - & .7435200E-04,.7322100E-04,.6965100E-04,.6403400E-04,.5543000E-04,& - & .4352900E-04,.1172800E-04,.5695300E-04,.7974000E-04,.8276900E-04,& - & .8131400E-04,.7727800E-04,.7032400E-04,.6039600E-04,.4674700E-04,& - & .1306300E-04,.6401900E-04,.8864700E-04,.9176800E-04,.8992600E-04,& - & .8495800E-04,.7674000E-04,.6556100E-04,.5006600E-04,.1443500E-04/ - - data absa(181:315, 3) / & - & .3380600E-04,.4782600E-04,.4944300E-04,.4877500E-04,.4647700E-04,& - & .4279100E-04,.3815500E-04,.3117500E-04,.7788600E-05,.3797300E-04,& - & .5339200E-04,.5552600E-04,.5471900E-04,.5206200E-04,.4776300E-04,& - & .4202100E-04,.3351000E-04,.8740400E-05,.4275800E-04,.5966600E-04,& - & .6205800E-04,.6112700E-04,.5801200E-04,.5307100E-04,.4597100E-04,& - & .3611400E-04,.9849900E-05,.4800600E-04,.6667900E-04,.6923000E-04,& - & .6798900E-04,.6440000E-04,.5852100E-04,.5019600E-04,.3871000E-04,& - & .1102200E-04,.5365700E-04,.7424400E-04,.7681300E-04,.7530300E-04,& - & .7101100E-04,.6409200E-04,.5459900E-04,.4148100E-04,.1222500E-04,& - & .2795300E-04,.4022300E-04,.4133100E-04,.4033200E-04,.3811400E-04,& - & .3496700E-04,.3115800E-04,.2570100E-04,.6760400E-05,.3159500E-04,& - & .4497500E-04,.4637400E-04,.4522900E-04,.4277500E-04,.3916200E-04,& - & .3437300E-04,.2761600E-04,.7555800E-05,.3564900E-04,.5026300E-04,& - & .5171300E-04,.5051600E-04,.4785500E-04,.4360500E-04,.3770500E-04,& - & .2980000E-04,.8406300E-05,.4008600E-04,.5590500E-04,.5758400E-04,& - & .5634800E-04,.5320000E-04,.4828300E-04,.4133100E-04,.3193600E-04,& - & .9268600E-05,.4493100E-04,.6202500E-04,.6394200E-04,.6249800E-04,& - & .5878800E-04,.5303200E-04,.4508500E-04,.3422900E-04,.1017500E-04,& - & .2282900E-04,.3327800E-04,.3419600E-04,.3338100E-04,.3144400E-04,& - & .2861500E-04,.2533100E-04,.2109600E-04,.6073200E-05,.2591700E-04,& - & .3742400E-04,.3852700E-04,.3758000E-04,.3530200E-04,.3202000E-04,& - & .2795700E-04,.2266000E-04,.6818000E-05,.2938600E-04,.4193300E-04,& - & .4321300E-04,.4203900E-04,.3944500E-04,.3565900E-04,.3078000E-04,& - & .2443200E-04,.7629600E-05,.3318600E-04,.4681100E-04,.4821800E-04,& - & .4684900E-04,.4384800E-04,.3956700E-04,.3385800E-04,.2625700E-04,& - & .8263400E-05,.3722700E-04,.5206000E-04,.5359200E-04,.5194800E-04,& - & .4847100E-04,.4359500E-04,.3702200E-04,.2813000E-04,.9005300E-05/ - - data absa(316:450, 3) / & - & .1833300E-04,.2725900E-04,.2792900E-04,.2723000E-04,.2567200E-04,& - & .2337400E-04,.2057100E-04,.1733300E-04,.5415700E-05,.2094800E-04,& - & .3077400E-04,.3160400E-04,.3082300E-04,.2900200E-04,.2629200E-04,& - & .2273400E-04,.1859300E-04,.6166900E-05,.2388300E-04,.3464200E-04,& - & .3565600E-04,.3467000E-04,.3250700E-04,.2930300E-04,.2511100E-04,& - & .1998500E-04,.6904800E-05,.2709800E-04,.3880200E-04,.4001300E-04,& - & .3877700E-04,.3621400E-04,.3254200E-04,.2767400E-04,.2152600E-04,& - & .7659100E-05,.3046200E-04,.4330700E-04,.4459600E-04,.4312700E-04,& - & .4014200E-04,.3589000E-04,.3027600E-04,.2306500E-04,.8448000E-05,& - & .1451000E-04,.2204900E-04,.2259600E-04,.2202100E-04,.2075000E-04,& - & .1889500E-04,.1668500E-04,.1415800E-04,.5028400E-05,.1671000E-04,& - & .2501200E-04,.2568600E-04,.2501700E-04,.2353700E-04,.2135000E-04,& - & .1851700E-04,.1517000E-04,.5901600E-05,.1913800E-04,.2827100E-04,& - & .2910400E-04,.2827200E-04,.2649300E-04,.2391600E-04,.2053000E-04,& - & .1629700E-04,.6841300E-05,.2179800E-04,.3185900E-04,.3280200E-04,& - & .3176200E-04,.2960300E-04,.2664300E-04,.2265000E-04,.1755900E-04,& - & .7809300E-05,.2459900E-04,.3561800E-04,.3673600E-04,.3545600E-04,& - & .3298100E-04,.2945900E-04,.2487700E-04,.1882100E-04,.8814900E-05,& - & .1145500E-04,.1779600E-04,.1828200E-04,.1783300E-04,.1681400E-04,& - & .1530500E-04,.1352600E-04,.1162800E-04,.4763700E-05,.1329500E-04,& - & .2029000E-04,.2086200E-04,.2031600E-04,.1912500E-04,.1734800E-04,& - & .1504200E-04,.1245500E-04,.5649500E-05,.1529700E-04,.2299400E-04,& - & .2374000E-04,.2307600E-04,.2162600E-04,.1952900E-04,.1676600E-04,& - & .1339900E-04,.6598800E-05,.1748800E-04,.2598600E-04,.2688200E-04,& - & .2602100E-04,.2424600E-04,.2182000E-04,.1855400E-04,.1442700E-04,& - & .7464400E-05,.1980000E-04,.2916000E-04,.3020800E-04,.2916100E-04,& - & .2708600E-04,.2418900E-04,.2046200E-04,.1547400E-04,.8439500E-05/ - - data absa(451:585, 3) / & - & .9636600E-05,.1516800E-04,.1561100E-04,.1523000E-04,.1438100E-04,& - & .1305800E-04,.1145700E-04,.9819500E-05,.4321000E-05,.1122100E-04,& - & .1730400E-04,.1785900E-04,.1739000E-04,.1638300E-04,.1483700E-04,& - & .1282000E-04,.1054100E-04,.5091500E-05,.1292200E-04,.1961100E-04,& - & .2037600E-04,.1976900E-04,.1851000E-04,.1673300E-04,.1429700E-04,& - & .1137500E-04,.5934900E-05,.1475900E-04,.2222600E-04,.2308700E-04,& - & .2231900E-04,.2078900E-04,.1867700E-04,.1585400E-04,.1223300E-04,& - & .6864600E-05,.1668700E-04,.2490100E-04,.2589400E-04,.2502000E-04,& - & .2323400E-04,.2074600E-04,.1745000E-04,.1314300E-04,.7794500E-05,& - & .8072800E-05,.1283300E-04,.1324100E-04,.1293000E-04,.1220900E-04,& - & .1107700E-04,.9687400E-05,.8251800E-05,.3698700E-05,.9409600E-05,& - & .1464700E-04,.1517900E-04,.1478900E-04,.1392900E-04,.1261400E-04,& - & .1086300E-04,.8883900E-05,.4364200E-05,.1082700E-04,.1662500E-04,& - & .1733600E-04,.1682500E-04,.1575700E-04,.1421500E-04,.1213500E-04,& - & .9570200E-05,.5127600E-05,.1234600E-04,.1882300E-04,.1962600E-04,& - & .1901100E-04,.1771500E-04,.1589100E-04,.1347200E-04,.1029700E-04,& - & .5881800E-05,.1395400E-04,.2107100E-04,.2198500E-04,.2127800E-04,& - & .1977300E-04,.1764200E-04,.1481300E-04,.1110900E-04,.6648500E-05,& - & .6719800E-05,.1077700E-04,.1115300E-04,.1090000E-04,.1030100E-04,& - & .9334500E-05,.8143300E-05,.6915600E-05,.3049800E-05,.7828300E-05,& - & .1228300E-04,.1280500E-04,.1249200E-04,.1175700E-04,.1064900E-04,& - & .9151900E-05,.7449500E-05,.3602800E-05,.8996600E-05,.1398300E-04,& - & .1462900E-04,.1421800E-04,.1331500E-04,.1199000E-04,.1023000E-04,& - & .8023700E-05,.4238200E-05,.1025000E-04,.1579400E-04,.1653600E-04,& - & .1605500E-04,.1497900E-04,.1342100E-04,.1135500E-04,.8637100E-05,& - & .4851100E-05,.1157500E-04,.1768900E-04,.1850200E-04,.1795000E-04,& - & .1668900E-04,.1488300E-04,.1247600E-04,.9353700E-05,.5479900E-05/ - - data absa( 1:180, 4) / & - & .2031300E-03,.2641000E-03,.2705400E-03,.2584200E-03,.2379400E-03,& - & .2103300E-03,.1773000E-03,.1383100E-03,.5299500E-04,.2272200E-03,& - & .2905800E-03,.2957200E-03,.2820000E-03,.2589800E-03,.2281400E-03,& - & .1920900E-03,.1495700E-03,.5909600E-04,.2505400E-03,.3158000E-03,& - & .3199100E-03,.3048600E-03,.2795500E-03,.2463400E-03,.2078700E-03,& - & .1617900E-03,.6511800E-04,.2719700E-03,.3397100E-03,.3431000E-03,& - & .3267700E-03,.3000200E-03,.2657400E-03,.2250200E-03,.1752000E-03,& - & .7171100E-04,.2917800E-03,.3621300E-03,.3650300E-03,.3481500E-03,& - & .3211400E-03,.2859900E-03,.2432800E-03,.1895800E-03,.7852300E-04,& - & .1754700E-03,.2301200E-03,.2363900E-03,.2260600E-03,.2079900E-03,& - & .1832600E-03,.1538500E-03,.1188800E-03,.4363300E-04,.1960100E-03,& - & .2526900E-03,.2575100E-03,.2462900E-03,.2262300E-03,.1992600E-03,& - & .1671200E-03,.1287700E-03,.4838200E-04,.2159800E-03,.2742300E-03,& - & .2781200E-03,.2657600E-03,.2440300E-03,.2155200E-03,.1814100E-03,& - & .1398200E-03,.5356000E-04,.2344900E-03,.2948200E-03,.2982000E-03,& - & .2845400E-03,.2617100E-03,.2325400E-03,.1968100E-03,.1519200E-03,& - & .5905400E-04,.2519800E-03,.3140800E-03,.3172300E-03,.3034100E-03,& - & .2804000E-03,.2502200E-03,.2133300E-03,.1648700E-03,.6477900E-04,& - & .1473600E-03,.1948300E-03,.2006500E-03,.1924200E-03,.1772800E-03,& - & .1562700E-03,.1307800E-03,.1003700E-03,.3421700E-04,.1649200E-03,& - & .2144100E-03,.2189200E-03,.2098000E-03,.1928900E-03,.1700000E-03,& - & .1424900E-03,.1090200E-03,.3835200E-04,.1820000E-03,.2329400E-03,& - & .2365800E-03,.2265800E-03,.2082200E-03,.1839100E-03,.1548400E-03,& - & .1188800E-03,.4270000E-04,.1981100E-03,.2509400E-03,.2538500E-03,& - & .2427600E-03,.2233800E-03,.1984100E-03,.1682200E-03,.1294300E-03,& - & .4725700E-04,.2135200E-03,.2678400E-03,.2702700E-03,.2591700E-03,& - & .2396600E-03,.2139900E-03,.1823900E-03,.1405800E-03,.5199700E-04,& - & .1207000E-03,.1628200E-03,.1687000E-03,.1621500E-03,.1496600E-03,& - & .1319500E-03,.1100300E-03,.8374300E-04,.2684100E-04,.1361600E-03,& - & .1797900E-03,.1842000E-03,.1769200E-03,.1628800E-03,.1435100E-03,& - & .1200000E-03,.9132400E-04,.2995600E-04,.1514200E-03,.1960600E-03,& - & .1993300E-03,.1913200E-03,.1758200E-03,.1550600E-03,.1306100E-03,& - & .9988100E-04,.3317500E-04,.1659100E-03,.2117000E-03,.2142100E-03,& - & .2052500E-03,.1888800E-03,.1674700E-03,.1419200E-03,.1090700E-03,& - & .3662500E-04,.1795600E-03,.2265500E-03,.2283300E-03,.2194900E-03,& - & .2028300E-03,.1808600E-03,.1539300E-03,.1186500E-03,.4051300E-04/ - - data absa(181:315, 4) / & - & .9862500E-04,.1348000E-03,.1409900E-03,.1365300E-03,.1260000E-03,& - & .1110700E-03,.9210200E-04,.6941400E-04,.2259700E-04,.1116500E-03,& - & .1497500E-03,.1542900E-03,.1488600E-03,.1371000E-03,.1207600E-03,& - & .1005100E-03,.7604600E-04,.2526500E-04,.1246100E-03,.1639100E-03,& - & .1672500E-03,.1609100E-03,.1479600E-03,.1304700E-03,.1094100E-03,& - & .8319300E-04,.2796200E-04,.1373800E-03,.1776100E-03,.1798200E-03,& - & .1728100E-03,.1591600E-03,.1408700E-03,.1189200E-03,.9097200E-04,& - & .3085500E-04,.1496700E-03,.1906600E-03,.1923100E-03,.1850900E-03,& - & .1710900E-03,.1522700E-03,.1290600E-03,.9913600E-04,.3401700E-04,& - & .7986300E-04,.1103400E-03,.1162200E-03,.1140000E-03,.1053200E-03,& - & .9297800E-04,.7666100E-04,.5728700E-04,.1866400E-04,.9075300E-04,& - & .1231800E-03,.1276600E-03,.1244000E-03,.1148200E-03,.1011000E-03,& - & .8369700E-04,.6266300E-04,.2092800E-04,.1018300E-03,.1353200E-03,& - & .1390700E-03,.1346400E-03,.1239600E-03,.1092500E-03,.9098400E-04,& - & .6851300E-04,.2326400E-04,.1129300E-03,.1474200E-03,.1499500E-03,& - & .1448100E-03,.1335400E-03,.1179700E-03,.9884500E-04,.7496500E-04,& - & .2585000E-04,.1236000E-03,.1591400E-03,.1609000E-03,.1552100E-03,& - & .1436100E-03,.1275500E-03,.1073900E-03,.8191500E-04,.2863500E-04,& - & .6567900E-04,.9008400E-04,.9568100E-04,.9456700E-04,.8733800E-04,& - & .7727500E-04,.6364200E-04,.4709700E-04,.1550800E-04,.7455100E-04,& - & .1008900E-03,.1053100E-03,.1032700E-03,.9536400E-04,.8415400E-04,& - & .6956900E-04,.5142600E-04,.1723400E-04,.8358400E-04,.1113700E-03,& - & .1146900E-03,.1119300E-03,.1032500E-03,.9107500E-04,.7547900E-04,& - & .5622800E-04,.1912700E-04,.9276200E-04,.1217100E-03,.1242000E-03,& - & .1206000E-03,.1114700E-03,.9846500E-04,.8196900E-04,.6152900E-04,& - & .2145200E-04,.1018900E-03,.1318200E-03,.1336400E-03,.1296000E-03,& - & .1200800E-03,.1065200E-03,.8904500E-04,.6733400E-04,.2371100E-04/ - - data absa(316:450, 4) / & - & .5365600E-04,.7410900E-04,.7862900E-04,.7824500E-04,.7232200E-04,& - & .6391500E-04,.5262500E-04,.3859100E-04,.1441600E-04,.6116300E-04,& - & .8310400E-04,.8683200E-04,.8556200E-04,.7899200E-04,.6966600E-04,& - & .5757400E-04,.4209800E-04,.1592100E-04,.6891400E-04,.9190900E-04,& - & .9459400E-04,.9281600E-04,.8559000E-04,.7549100E-04,.6244500E-04,& - & .4610900E-04,.1720900E-04,.7684700E-04,.1005900E-03,.1025600E-03,& - & .1001900E-03,.9249600E-04,.8172900E-04,.6776300E-04,.5044500E-04,& - & .1858900E-04,.8484700E-04,.1090200E-03,.1107100E-03,.1078400E-03,& - & .9981200E-04,.8851600E-04,.7371800E-04,.5525000E-04,.2019400E-04,& - & .4334600E-04,.6060800E-04,.6481800E-04,.6468100E-04,.5965500E-04,& - & .5261700E-04,.4320600E-04,.3157300E-04,.1469600E-04,.4966900E-04,& - & .6838000E-04,.7180000E-04,.7086000E-04,.6526000E-04,.5749600E-04,& - & .4731300E-04,.3440500E-04,.1616400E-04,.5627400E-04,.7604000E-04,& - & .7845400E-04,.7694400E-04,.7066500E-04,.6234700E-04,.5138300E-04,& - & .3766500E-04,.1784100E-04,.6312700E-04,.8345100E-04,.8517800E-04,& - & .8308200E-04,.7643700E-04,.6753800E-04,.5579700E-04,.4126400E-04,& - & .1950400E-04,.7012400E-04,.9080700E-04,.9196000E-04,.8943200E-04,& - & .8252700E-04,.7317600E-04,.6066800E-04,.4517900E-04,.2099200E-04,& - & .3505900E-04,.4953100E-04,.5337600E-04,.5366500E-04,.4964400E-04,& - & .4359200E-04,.3560900E-04,.2584500E-04,.1323100E-04,.4037600E-04,& - & .5617400E-04,.5950200E-04,.5904000E-04,.5439900E-04,.4768700E-04,& - & .3900700E-04,.2818900E-04,.1522300E-04,.4600600E-04,.6289900E-04,& - & .6521400E-04,.6417800E-04,.5897600E-04,.5172600E-04,.4238600E-04,& - & .3084300E-04,.1724100E-04,.5190500E-04,.6939500E-04,.7098800E-04,& - & .6946100E-04,.6380100E-04,.5604000E-04,.4605900E-04,.3383100E-04,& - & .1971400E-04,.5799000E-04,.7573700E-04,.7682600E-04,.7471800E-04,& - & .6883900E-04,.6066400E-04,.5010500E-04,.3704900E-04,.2230800E-04/ - - data absa(451:585, 4) / & - & .3015000E-04,.4273800E-04,.4601100E-04,.4633000E-04,.4290700E-04,& - & .3760500E-04,.3070200E-04,.2196200E-04,.1179100E-04,.3471400E-04,& - & .4851600E-04,.5112000E-04,.5072600E-04,.4691200E-04,.4103300E-04,& - & .3350500E-04,.2395200E-04,.1324200E-04,.3964900E-04,.5432500E-04,& - & .5614600E-04,.5527000E-04,.5090200E-04,.4455900E-04,.3635100E-04,& - & .2626600E-04,.1507500E-04,.4477900E-04,.5989300E-04,.6116600E-04,& - & .5976600E-04,.5507000E-04,.4830300E-04,.3949100E-04,.2884700E-04,& - & .1716400E-04,.4994600E-04,.6541100E-04,.6625600E-04,.6434500E-04,& - & .5947400E-04,.5228700E-04,.4300300E-04,.3161200E-04,.1954200E-04,& - & .2568100E-04,.3662200E-04,.3942800E-04,.3958200E-04,.3678600E-04,& - & .3221000E-04,.2627000E-04,.1862900E-04,.1003500E-04,.2963600E-04,& - & .4162000E-04,.4370100E-04,.4342500E-04,.4015000E-04,.3510500E-04,& - & .2863700E-04,.2036500E-04,.1141600E-04,.3392100E-04,.4662800E-04,& - & .4806200E-04,.4730100E-04,.4363300E-04,.3818900E-04,.3113300E-04,& - & .2240500E-04,.1294600E-04,.3834100E-04,.5140100E-04,.5245700E-04,& - & .5112900E-04,.4723800E-04,.4142900E-04,.3390500E-04,.2454600E-04,& - & .1477000E-04,.4257600E-04,.5615300E-04,.5686300E-04,.5518200E-04,& - & .5111300E-04,.4494000E-04,.3698700E-04,.2689800E-04,.1686500E-04,& - & .2170700E-04,.3114200E-04,.3348700E-04,.3365000E-04,.3130100E-04,& - & .2739600E-04,.2235200E-04,.1574400E-04,.8300500E-05,.2511200E-04,& - & .3547400E-04,.3715800E-04,.3697000E-04,.3417000E-04,.2987100E-04,& - & .2436100E-04,.1731200E-04,.9355900E-05,.2876200E-04,.3971200E-04,& - & .4092400E-04,.4019900E-04,.3716900E-04,.3256500E-04,.2656600E-04,& - & .1907400E-04,.1067000E-04,.3244800E-04,.4380800E-04,.4473400E-04,& - & .4353400E-04,.4032300E-04,.3536700E-04,.2901100E-04,.2089700E-04,& - & .1224000E-04,.3590500E-04,.4777100E-04,.4848200E-04,.4709400E-04,& - & .4370300E-04,.3847400E-04,.3171500E-04,.2289900E-04,.1395800E-04/ - - data absa( 1:180, 5) / & - & .7617673E-03,.8971104E-03,.9278378E-03,.9076002E-03,.8545237E-03,& - & .7758218E-03,.6640038E-03,.5009860E-03,.2100718E-03,.7925828E-03,& - & .9442955E-03,.9755110E-03,.9542425E-03,.9014791E-03,.8188875E-03,& - & .7022179E-03,.5337239E-03,.2374824E-03,.8249630E-03,.9924062E-03,& - & .1024145E-02,.1003594E-02,.9497958E-03,.8633171E-03,.7423153E-03,& - & .5703062E-03,.2679147E-03,.8583524E-03,.1040661E-02,.1074578E-02,& - & .1055443E-02,.9993194E-03,.9103749E-03,.7856031E-03,.6103198E-03,& - & .3005890E-03,.8914210E-03,.1089831E-02,.1127450E-02,.1108978E-02,& - & .1051150E-02,.9598170E-03,.8317411E-03,.6540146E-03,.3372384E-03,& - & .6627779E-03,.7779969E-03,.8008718E-03,.7838334E-03,.7398886E-03,& - & .6733388E-03,.5758040E-03,.4394197E-03,.1791672E-03,.6931434E-03,& - & .8216003E-03,.8453718E-03,.8264838E-03,.7819403E-03,.7110987E-03,& - & .6107270E-03,.4698192E-03,.2021868E-03,.7240368E-03,.8657540E-03,& - & .8908257E-03,.8720081E-03,.8257095E-03,.7512371E-03,.6480081E-03,& - & .5029834E-03,.2276890E-03,.7549662E-03,.9109098E-03,.9378553E-03,& - & .9196391E-03,.8709512E-03,.7935808E-03,.6875784E-03,.5392493E-03,& - & .2558951E-03,.7854858E-03,.9570998E-03,.9870226E-03,.9682145E-03,& - & .9174446E-03,.8393444E-03,.7305754E-03,.5787675E-03,.2867225E-03,& - & .5698218E-03,.6646945E-03,.6811412E-03,.6675254E-03,.6306449E-03,& - & .5735521E-03,.4911267E-03,.3756753E-03,.1468372E-03,.5979398E-03,& - & .7039422E-03,.7219077E-03,.7061823E-03,.6682445E-03,.6070832E-03,& - & .5222789E-03,.4034172E-03,.1660478E-03,.6260630E-03,.7441821E-03,& - & .7640366E-03,.7472492E-03,.7070503E-03,.6422790E-03,.5549202E-03,& - & .4333711E-03,.1875462E-03,.6541096E-03,.7851727E-03,.8072018E-03,& - & .7903360E-03,.7475103E-03,.6804148E-03,.5905641E-03,.4657632E-03,& - & .2111058E-03,.6816820E-03,.8277472E-03,.8519631E-03,.8340047E-03,& - & .7892681E-03,.7212366E-03,.6290190E-03,.5008742E-03,.2367354E-03,& - & .4861342E-03,.5638913E-03,.5756770E-03,.5644357E-03,.5327681E-03,& - & .4835474E-03,.4138863E-03,.3179456E-03,.1189626E-03,.5113753E-03,& - & .5987845E-03,.6124007E-03,.5992699E-03,.5662793E-03,.5134428E-03,& - & .4408138E-03,.3421165E-03,.1351360E-03,.5363872E-03,.6346295E-03,& - & .6504470E-03,.6359055E-03,.6008677E-03,.5448237E-03,.4696582E-03,& - & .3682585E-03,.1527590E-03,.5608616E-03,.6715761E-03,.6895903E-03,& - & .6743859E-03,.6365185E-03,.5786033E-03,.5010073E-03,.3967389E-03,& - & .1724827E-03,.5849723E-03,.7098200E-03,.7303204E-03,.7137716E-03,& - & .6742570E-03,.6146787E-03,.5348228E-03,.4271745E-03,.1936713E-03/ - - data absa(181:315, 5) / & - & .4124715E-03,.4761738E-03,.4853020E-03,.4745565E-03,.4479021E-03,& - & .4057915E-03,.3474465E-03,.2667416E-03,.9516165E-04,.4344911E-03,& - & .5069050E-03,.5177953E-03,.5062569E-03,.4775319E-03,.4319312E-03,& - & .3702139E-03,.2876629E-03,.1085617E-03,.4559645E-03,.5386154E-03,& - & .5518018E-03,.5389479E-03,.5081875E-03,.4599769E-03,.3953892E-03,& - & .3104428E-03,.1229340E-03,.4769668E-03,.5709955E-03,.5869421E-03,& - & .5732638E-03,.5400999E-03,.4895927E-03,.4226193E-03,.3347530E-03,& - & .1391112E-03,.4977864E-03,.6042702E-03,.6230627E-03,.6084073E-03,& - & .5737828E-03,.5212317E-03,.4520350E-03,.3599815E-03,.1565328E-03,& - & .3481462E-03,.3997927E-03,.4064302E-03,.3958879E-03,.3740189E-03,& - & .3386598E-03,.2894388E-03,.2220176E-03,.7721520E-04,.3667478E-03,& - & .4264134E-03,.4347817E-03,.4238152E-03,.3999290E-03,.3615359E-03,& - & .3088615E-03,.2396985E-03,.8791758E-04,.3848509E-03,.4536800E-03,& - & .4643234E-03,.4533341E-03,.4271237E-03,.3859069E-03,.3305190E-03,& - & .2589672E-03,.9917704E-04,.4025904E-03,.4814459E-03,.4948753E-03,& - & .4836881E-03,.4553829E-03,.4119222E-03,.3539441E-03,.2788595E-03,& - & .1117935E-03,.4204129E-03,.5099243E-03,.5262683E-03,.5145801E-03,& - & .4847600E-03,.4394867E-03,.3794179E-03,.3009917E-03,.1256044E-03,& - & .2923436E-03,.3350198E-03,.3390235E-03,.3289566E-03,.3102593E-03,& - & .2807257E-03,.2400716E-03,.1841474E-03,.6514967E-04,.3079436E-03,& - & .3575834E-03,.3635135E-03,.3531948E-03,.3332576E-03,.3010207E-03,& - & .2570614E-03,.1988560E-03,.7422428E-04,.3232435E-03,.3805545E-03,& - & .3886434E-03,.3787663E-03,.3570394E-03,.3221858E-03,.2755102E-03,& - & .2150719E-03,.8445731E-04,.3383325E-03,.4040182E-03,.4144616E-03,& - & .4051543E-03,.3816543E-03,.3448001E-03,.2956857E-03,.2316464E-03,& - & .9529395E-04,.3535369E-03,.4281879E-03,.4413816E-03,.4318028E-03,& - & .4070455E-03,.3690091E-03,.3175244E-03,.2504699E-03,.1070304E-03/ - - data absa(316:450, 5) / & - & .2453512E-03,.2800882E-03,.2825252E-03,.2730919E-03,.2566169E-03,& - & .2318802E-03,.1983126E-03,.1522973E-03,.5516642E-04,.2581699E-03,& - & .2989905E-03,.3031376E-03,.2937127E-03,.2763027E-03,.2495537E-03,& - & .2126952E-03,.1646454E-03,.6300898E-04,.2707693E-03,.3182237E-03,& - & .3242581E-03,.3153146E-03,.2972863E-03,.2680977E-03,.2289101E-03,& - & .1781625E-03,.7205544E-04,.2834359E-03,.3379200E-03,.3459773E-03,& - & .3376659E-03,.3181431E-03,.2874562E-03,.2463233E-03,.1919211E-03,& - & .8179890E-04,.2961968E-03,.3584988E-03,.3687767E-03,.3605384E-03,& - & .3397168E-03,.3080263E-03,.2651369E-03,.2080999E-03,.9227521E-04,& - & .2054310E-03,.2336020E-03,.2346874E-03,.2262676E-03,.2118556E-03,& - & .1911126E-03,.1628566E-03,.1251317E-03,.5265615E-04,.2158983E-03,& - & .2491904E-03,.2518957E-03,.2435142E-03,.2286421E-03,.2061588E-03,& - & .1755758E-03,.1356394E-03,.5986972E-04,.2262897E-03,.2650278E-03,& - & .2694531E-03,.2615131E-03,.2463445E-03,.2220951E-03,.1892217E-03,& - & .1469564E-03,.6762150E-04,.2368500E-03,.2815163E-03,.2876091E-03,& - & .2802849E-03,.2643048E-03,.2385402E-03,.2043353E-03,.1585617E-03,& - & .7608500E-04,.2475469E-03,.2987922E-03,.3069398E-03,.2998091E-03,& - & .2825176E-03,.2560367E-03,.2200683E-03,.1724086E-03,.8542444E-04,& - & .1724065E-03,.1956039E-03,.1956892E-03,.1881402E-03,.1756197E-03,& - & .1579428E-03,.1342625E-03,.1031020E-03,.6401734E-04,.1809875E-03,& - & .2084355E-03,.2098304E-03,.2024866E-03,.1896267E-03,.1710181E-03,& - & .1452408E-03,.1119637E-03,.7219467E-04,.1895575E-03,.2214531E-03,& - & .2244155E-03,.2174338E-03,.2045039E-03,.1844632E-03,.1570651E-03,& - & .1214344E-03,.8097348E-04,.1983280E-03,.2351430E-03,.2396300E-03,& - & .2331386E-03,.2197000E-03,.1984522E-03,.1696161E-03,.1313673E-03,& - & .9012464E-04,.2073235E-03,.2496450E-03,.2559261E-03,.2497870E-03,& - & .2354805E-03,.2133323E-03,.1830084E-03,.1431258E-03,.9946132E-04/ - - data absa(451:585, 5) / & - & .1474531E-03,.1682762E-03,.1683793E-03,.1616613E-03,.1506254E-03,& - & .1352532E-03,.1147895E-03,.8797863E-04,.6244135E-04,.1544785E-03,& - & .1789686E-03,.1802145E-03,.1739110E-03,.1625411E-03,.1464475E-03,& - & .1243412E-03,.9584180E-04,.7111930E-04,.1616375E-03,.1899537E-03,& - & .1924972E-03,.1864886E-03,.1751900E-03,.1580145E-03,.1346723E-03,& - & .1036729E-03,.7851804E-04,.1690889E-03,.2016073E-03,.2056052E-03,& - & .2000516E-03,.1882465E-03,.1701850E-03,.1455146E-03,.1127735E-03,& - & .8728573E-04,.1768424E-03,.2142601E-03,.2196970E-03,.2143761E-03,& - & .2020742E-03,.1832716E-03,.1571724E-03,.1229344E-03,.9627397E-04,& - & .1259909E-03,.1440828E-03,.1441655E-03,.1384718E-03,.1288147E-03,& - & .1155429E-03,.9784118E-04,.7511447E-04,.5542102E-04,.1317506E-03,& - & .1530088E-03,.1541902E-03,.1487423E-03,.1390011E-03,.1250725E-03,& - & .1060741E-03,.8202844E-04,.6380787E-04,.1377366E-03,.1623281E-03,& - & .1647109E-03,.1596366E-03,.1497584E-03,.1350689E-03,.1149756E-03,& - & .8862399E-04,.7101181E-04,.1440326E-03,.1724497E-03,.1760537E-03,& - & .1714078E-03,.1610900E-03,.1456787E-03,.1244204E-03,.9651500E-04,& - & .7800418E-04,.1507641E-03,.1835052E-03,.1883108E-03,.1838011E-03,& - & .1732376E-03,.1570042E-03,.1346136E-03,.1051140E-03,.8602649E-04,& - & .1072501E-03,.1233653E-03,.1231303E-03,.1180489E-03,.1097712E-03,& - & .9835244E-04,.8317681E-04,.6399482E-04,.4621221E-04,.1121185E-03,& - & .1307584E-03,.1315510E-03,.1267530E-03,.1184196E-03,.1064469E-03,& - & .9028401E-04,.6947188E-04,.5321306E-04,.1172881E-03,.1387038E-03,& - & .1405630E-03,.1362742E-03,.1276910E-03,.1151082E-03,.9795080E-04,& - & .7537889E-04,.5873871E-04,.1228106E-03,.1473997E-03,.1504434E-03,& - & .1464443E-03,.1375481E-03,.1243899E-03,.1061458E-03,.8236870E-04,& - & .6477734E-04,.1289014E-03,.1570159E-03,.1610714E-03,.1572623E-03,& - & .1482077E-03,.1342864E-03,.1150946E-03,.8978401E-04,.7158089E-04/ - - data absa( 1:180, 6) / & - & .3618426E-02,.3641770E-02,.3630477E-02,.3560259E-02,.3416323E-02,& - & .3176047E-02,.2830864E-02,.2373983E-02,.1742217E-02,.3598081E-02,& - & .3703258E-02,.3743793E-02,.3712218E-02,.3589778E-02,.3370737E-02,& - & .3037900E-02,.2596162E-02,.1991398E-02,.3584083E-02,.3774324E-02,& - & .3866788E-02,.3867624E-02,.3769761E-02,.3570448E-02,.3255037E-02,& - & .2830185E-02,.2261505E-02,.3577298E-02,.3852926E-02,.3993744E-02,& - & .4026505E-02,.3954894E-02,.3775808E-02,.3481871E-02,.3078695E-02,& - & .2554303E-02,.3579835E-02,.3939097E-02,.4125092E-02,.4189431E-02,& - & .4145315E-02,.3990234E-02,.3720434E-02,.3340287E-02,.2865995E-02,& - & .3248394E-02,.3297351E-02,.3295356E-02,.3225177E-02,.3084542E-02,& - & .2861202E-02,.2553948E-02,.2123300E-02,.1461572E-02,.3235583E-02,& - & .3361291E-02,.3404532E-02,.3369041E-02,.3247031E-02,.3043618E-02,& - & .2745319E-02,.2323230E-02,.1677107E-02,.3231488E-02,.3436144E-02,& - & .3523056E-02,.3516391E-02,.3416868E-02,.3231131E-02,.2944369E-02,& - & .2533343E-02,.1912294E-02,.3237872E-02,.3517820E-02,.3646256E-02,& - & .3668618E-02,.3593949E-02,.3426895E-02,.3151603E-02,.2756947E-02,& - & .2166557E-02,.3253132E-02,.3606661E-02,.3773434E-02,.3826500E-02,& - & .3776601E-02,.3630583E-02,.3369967E-02,.2994163E-02,.2437904E-02,& - & .2886205E-02,.2942447E-02,.2941032E-02,.2863367E-02,.2725094E-02,& - & .2518760E-02,.2241939E-02,.1855734E-02,.1188420E-02,.2880736E-02,& - & .3006642E-02,.3042538E-02,.2997000E-02,.2874870E-02,.2685370E-02,& - & .2415558E-02,.2030078E-02,.1369150E-02,.2886508E-02,.3082007E-02,& - & .3154756E-02,.3134344E-02,.3033232E-02,.2858755E-02,.2598268E-02,& - & .2216396E-02,.1566621E-02,.2902943E-02,.3166339E-02,.3272849E-02,& - & .3277933E-02,.3197754E-02,.3039090E-02,.2789791E-02,.2414716E-02,& - & .1779400E-02,.2928623E-02,.3256730E-02,.3396972E-02,.3427808E-02,& - & .3370428E-02,.3228051E-02,.2990498E-02,.2624579E-02,.2010439E-02,& - & .2540902E-02,.2597254E-02,.2589360E-02,.2508382E-02,.2375438E-02,& - & .2188928E-02,.1938803E-02,.1600312E-02,.9604968E-03,.2542011E-02,& - & .2659586E-02,.2684388E-02,.2628952E-02,.2511349E-02,.2338234E-02,& - & .2094432E-02,.1754453E-02,.1111332E-02,.2555832E-02,.2734832E-02,& - & .2789039E-02,.2755882E-02,.2656417E-02,.2495319E-02,.2258255E-02,& - & .1919151E-02,.1276371E-02,.2581259E-02,.2819185E-02,.2901637E-02,& - & .2889786E-02,.2808889E-02,.2659442E-02,.2431576E-02,.2093659E-02,& - & .1455003E-02,.2614546E-02,.2911442E-02,.3020621E-02,.3031206E-02,& - & .2967469E-02,.2832291E-02,.2614781E-02,.2279966E-02,.1647719E-02/ - - data absa(181:315, 6) / & - & .2219972E-02,.2275081E-02,.2258189E-02,.2178017E-02,.2052724E-02,& - & .1883431E-02,.1661334E-02,.1366404E-02,.7744816E-03,.2227260E-02,& - & .2335504E-02,.2345620E-02,.2284987E-02,.2174042E-02,.2016070E-02,& - & .1799386E-02,.1503145E-02,.9005459E-03,.2248029E-02,.2409026E-02,& - & .2443618E-02,.2400559E-02,.2304822E-02,.2156227E-02,.1945494E-02,& - & .1648525E-02,.1039558E-02,.2279277E-02,.2492598E-02,.2549202E-02,& - & .2524778E-02,.2443050E-02,.2304879E-02,.2101498E-02,.1803888E-02,& - & .1189595E-02,.2314653E-02,.2584274E-02,.2663118E-02,.2656729E-02,& - & .2589557E-02,.2462949E-02,.2266082E-02,.1970673E-02,.1351586E-02,& - & .1926874E-02,.1977274E-02,.1952607E-02,.1874742E-02,.1757624E-02,& - & .1604309E-02,.1409103E-02,.1152190E-02,.6162171E-03,.1939310E-02,& - & .2034841E-02,.2032252E-02,.1970439E-02,.1864280E-02,.1719652E-02,& - & .1530483E-02,.1272154E-02,.7211166E-03,.1964743E-02,.2105464E-02,& - & .2122862E-02,.2074082E-02,.1979741E-02,.1844073E-02,.1659546E-02,& - & .1399922E-02,.8374058E-03,.1996506E-02,.2186938E-02,.2222376E-02,& - & .2187288E-02,.2103966E-02,.1977177E-02,.1797677E-02,.1537669E-02,& - & .9633722E-03,.2032972E-02,.2273283E-02,.2330136E-02,.2309382E-02,& - & .2237782E-02,.2120007E-02,.1943914E-02,.1683301E-02,.1099973E-02,& - & .1663865E-02,.1707960E-02,.1678656E-02,.1605070E-02,.1496908E-02,& - & .1359728E-02,.1186597E-02,.9637506E-03,.4837199E-03,.1679462E-02,& - & .1762213E-02,.1749710E-02,.1688780E-02,.1589709E-02,.1459287E-02,& - & .1291495E-02,.1067463E-02,.5692182E-03,.1705626E-02,.1829062E-02,& - & .1833331E-02,.1782521E-02,.1691254E-02,.1568704E-02,.1405411E-02,& - & .1178417E-02,.6634981E-03,.1737149E-02,.1904246E-02,.1926414E-02,& - & .1885283E-02,.1802747E-02,.1686750E-02,.1526571E-02,.1298759E-02,& - & .7673774E-03,.1774180E-02,.1984243E-02,.2025542E-02,.1997561E-02,& - & .1924977E-02,.1813742E-02,.1655518E-02,.1426328E-02,.8813749E-03/ - - data absa(316:450, 6) / & - & .1431715E-02,.1468745E-02,.1437010E-02,.1368212E-02,.1270165E-02,& - & .1147038E-02,.9947349E-03,.8008574E-03,.3951453E-03,.1448558E-02,& - & .1518890E-02,.1500478E-02,.1441411E-02,.1351002E-02,.1233436E-02,& - & .1085630E-02,.8898114E-03,.4614759E-03,.1473293E-02,.1580156E-02,& - & .1576676E-02,.1525332E-02,.1440556E-02,.1328775E-02,.1183815E-02,& - & .9858304E-03,.5346545E-03,.1503819E-02,.1648007E-02,.1660678E-02,& - & .1618866E-02,.1540977E-02,.1433665E-02,.1289444E-02,.1090469E-02,& - & .6144704E-03,.1540870E-02,.1721704E-02,.1750156E-02,.1719303E-02,& - & .1651341E-02,.1546906E-02,.1402428E-02,.1200202E-02,.7022918E-03,& - & .1229566E-02,.1259757E-02,.1226783E-02,.1162063E-02,.1073623E-02,& - & .9638267E-03,.8304962E-03,.6619654E-03,.3708964E-03,.1245677E-02,& - & .1304848E-02,.1282510E-02,.1226105E-02,.1143293E-02,.1038470E-02,& - & .9077754E-03,.7376031E-03,.4310410E-03,.1268666E-02,.1359022E-02,& - & .1349687E-02,.1300919E-02,.1222896E-02,.1121551E-02,.9925926E-03,& - & .8196689E-03,.4969197E-03,.1297981E-02,.1419642E-02,.1423650E-02,& - & .1383567E-02,.1312384E-02,.1213886E-02,.1083936E-02,.9092041E-03,& - & .5687180E-03,.1333382E-02,.1486555E-02,.1503607E-02,.1472905E-02,& - & .1409828E-02,.1314124E-02,.1183141E-02,.1003566E-02,.6475735E-03,& - & .1053427E-02,.1080875E-02,.1049457E-02,.9889791E-03,.9098076E-03,& - & .8127675E-03,.6957123E-03,.5493509E-03,.3851070E-03,.1068299E-02,& - & .1121177E-02,.1098614E-02,.1045290E-02,.9707095E-03,.8766135E-03,& - & .7618622E-03,.6136871E-03,.4400535E-03,.1090018E-02,.1169156E-02,& - & .1157141E-02,.1111356E-02,.1041184E-02,.9497327E-03,.8348360E-03,& - & .6839361E-03,.4994168E-03,.1118137E-02,.1223841E-02,.1222357E-02,& - & .1184095E-02,.1119621E-02,.1031067E-02,.9147253E-03,.7606201E-03,& - & .5637416E-03,.1150470E-02,.1284547E-02,.1293867E-02,.1263779E-02,& - & .1204832E-02,.1118950E-02,.1001368E-02,.8420516E-03,.6348671E-03/ - - data absa(451:585, 6) / & - & .9046486E-03,.9397347E-03,.9133460E-03,.8617363E-03,.7934190E-03,& - & .7090706E-03,.6066044E-03,.4794255E-03,.3743553E-03,.9212914E-03,& - & .9782734E-03,.9602049E-03,.9151820E-03,.8507753E-03,.7678173E-03,& - & .6660920E-03,.5356152E-03,.4226059E-03,.9442639E-03,.1023620E-02,& - & .1014658E-02,.9758938E-03,.9151114E-03,.8345845E-03,.7318442E-03,& - & .5984128E-03,.4774443E-03,.9713828E-03,.1075284E-02,.1075663E-02,& - & .1042999E-02,.9862816E-03,.9076184E-03,.8041084E-03,.6658818E-03,& - & .5353482E-03,.1002245E-02,.1131170E-02,.1142136E-02,.1116667E-02,& - & .1063668E-02,.9860813E-03,.8820903E-03,.7392501E-03,.5986885E-03,& - & .7757001E-03,.8156004E-03,.7935608E-03,.7501868E-03,.6919875E-03,& - & .6187418E-03,.5293689E-03,.4171913E-03,.3400983E-03,.7936331E-03,& - & .8519754E-03,.8374063E-03,.7995658E-03,.7443953E-03,.6725458E-03,& - & .5825365E-03,.4667964E-03,.3809920E-03,.8158134E-03,.8946178E-03,& - & .8881924E-03,.8553581E-03,.8027948E-03,.7321369E-03,.6414490E-03,& - & .5225120E-03,.4287453E-03,.8413662E-03,.9418592E-03,.9443588E-03,& - & .9171257E-03,.8676347E-03,.7974095E-03,.7054434E-03,.5826005E-03,& - & .4804212E-03,.8686293E-03,.9928428E-03,.1005484E-02,.9842193E-03,& - & .9373691E-03,.8680623E-03,.7750971E-03,.6486142E-03,.5361541E-03,& - & .6656671E-03,.7063220E-03,.6882893E-03,.6520290E-03,.6021008E-03,& - & .5393669E-03,.4616943E-03,.3624013E-03,.2876110E-03,.6827709E-03,& - & .7403802E-03,.7293362E-03,.6972791E-03,.6496824E-03,.5872587E-03,& - & .5091135E-03,.4069669E-03,.3235500E-03,.7030563E-03,.7795754E-03,& - & .7759040E-03,.7481102E-03,.7027456E-03,.6406035E-03,.5612231E-03,& - & .4560596E-03,.3644783E-03,.7249585E-03,.8222986E-03,.8269765E-03,& - & .8039916E-03,.7610904E-03,.6992438E-03,.6179241E-03,.5093407E-03,& - & .4084015E-03,.7487037E-03,.8678454E-03,.8821100E-03,.8646953E-03,& - & .8237630E-03,.7629048E-03,.6800190E-03,.5680363E-03,.4564484E-03/ - - data absa( 1:180, 7) / & - & .1944086E-01,.1794384E-01,.1665104E-01,.1551773E-01,.1445828E-01,& - & .1338923E-01,.1239141E-01,.1193783E-01,.1267749E-01,.1929939E-01,& - & .1802401E-01,.1696529E-01,.1609074E-01,.1524109E-01,.1436017E-01,& - & .1365895E-01,.1355010E-01,.1460849E-01,.1914240E-01,.1812275E-01,& - & .1733603E-01,.1672488E-01,.1609343E-01,.1543656E-01,.1506976E-01,& - & .1532896E-01,.1671755E-01,.1896990E-01,.1824026E-01,.1775719E-01,& - & .1740823E-01,.1702225E-01,.1660281E-01,.1659697E-01,.1723872E-01,& - & .1897711E-01,.1878230E-01,.1836854E-01,.1822350E-01,.1813959E-01,& - & .1798727E-01,.1786818E-01,.1824983E-01,.1930509E-01,.2141343E-01,& - & .2002304E-01,.1846205E-01,.1712703E-01,.1593023E-01,.1477768E-01,& - & .1360259E-01,.1233974E-01,.1147779E-01,.1184062E-01,.1987095E-01,& - & .1854946E-01,.1743597E-01,.1649501E-01,.1555867E-01,.1455749E-01,& - & .1351955E-01,.1298854E-01,.1367056E-01,.1970539E-01,.1864562E-01,& - & .1779988E-01,.1712573E-01,.1640112E-01,.1560634E-01,.1483953E-01,& - & .1466071E-01,.1566922E-01,.1952211E-01,.1876024E-01,.1821996E-01,& - & .1780079E-01,.1732241E-01,.1670897E-01,.1627296E-01,.1646775E-01,& - & .1781807E-01,.1932576E-01,.1888733E-01,.1868624E-01,.1852437E-01,& - & .1828787E-01,.1789646E-01,.1782466E-01,.1840912E-01,.2012300E-01,& - & .2046316E-01,.1881445E-01,.1742883E-01,.1614035E-01,.1486365E-01,& - & .1356768E-01,.1209778E-01,.1077331E-01,.1065343E-01,.2030717E-01,& - & .1890498E-01,.1772206E-01,.1668034E-01,.1562712E-01,.1448379E-01,& - & .1318643E-01,.1216891E-01,.1235738E-01,.2013274E-01,.1900626E-01,& - & .1806511E-01,.1729725E-01,.1644190E-01,.1549571E-01,.1438909E-01,& - & .1370013E-01,.1420354E-01,.1994378E-01,.1911368E-01,.1847290E-01,& - & .1795539E-01,.1733637E-01,.1657610E-01,.1569548E-01,.1535991E-01,& - & .1619433E-01,.1974273E-01,.1923315E-01,.1892487E-01,.1866106E-01,& - & .1828690E-01,.1769725E-01,.1711524E-01,.1715953E-01,.1834492E-01,& - & .2071926E-01,.1899869E-01,.1758640E-01,.1621993E-01,.1481733E-01,& - & .1340442E-01,.1178457E-01,.1005441E-01,.9415201E-02,.2056070E-01,& - & .1908468E-01,.1786585E-01,.1672760E-01,.1555529E-01,.1427366E-01,& - & .1280976E-01,.1132568E-01,.1098244E-01,.2038159E-01,.1918328E-01,& - & .1818981E-01,.1732353E-01,.1633951E-01,.1523974E-01,.1393712E-01,& - & .1273530E-01,.1270208E-01,.2019166E-01,.1930154E-01,.1857522E-01,& - & .1795884E-01,.1719737E-01,.1628902E-01,.1513446E-01,.1425698E-01,& - & .1454259E-01,.1999244E-01,.1941900E-01,.1900880E-01,.1863941E-01,& - & .1812618E-01,.1738164E-01,.1642114E-01,.1589227E-01,.1651351E-01/ - - data absa(181:315, 7) / & - & .2078596E-01,.1902221E-01,.1759185E-01,.1618479E-01,.1468286E-01,& - & .1316356E-01,.1141915E-01,.9423027E-02,.8269424E-02,.2061989E-01,& - & .1909317E-01,.1787631E-01,.1666093E-01,.1538845E-01,.1399494E-01,& - & .1238597E-01,.1057539E-01,.9705846E-02,.2044247E-01,.1918749E-01,& - & .1817839E-01,.1723098E-01,.1614137E-01,.1490895E-01,.1346159E-01,& - & .1185395E-01,.1127991E-01,.2025356E-01,.1930375E-01,.1854460E-01,& - & .1784554E-01,.1696147E-01,.1591307E-01,.1460469E-01,.1324520E-01,& - & .1297427E-01,.2007410E-01,.1943195E-01,.1896380E-01,.1849843E-01,& - & .1785367E-01,.1697392E-01,.1579435E-01,.1474526E-01,.1480343E-01,& - & .2067653E-01,.1889520E-01,.1744869E-01,.1600835E-01,.1443542E-01,& - & .1280811E-01,.1096768E-01,.8811489E-02,.7161785E-02,.2051191E-01,& - & .1895371E-01,.1772735E-01,.1645848E-01,.1509553E-01,.1360134E-01,& - & .1187179E-01,.9849619E-02,.8463973E-02,.2033498E-01,.1904213E-01,& - & .1803233E-01,.1698898E-01,.1581982E-01,.1446262E-01,.1288709E-01,& - & .1101445E-01,.9901719E-02,.2016531E-01,.1915657E-01,.1837300E-01,& - & .1758375E-01,.1659315E-01,.1541743E-01,.1398290E-01,.1227676E-01,& - & .1145224E-01,.2000011E-01,.1929718E-01,.1877422E-01,.1820930E-01,& - & .1743917E-01,.1643489E-01,.1512599E-01,.1364249E-01,.1312614E-01,& - & .2038344E-01,.1861656E-01,.1717360E-01,.1569740E-01,.1410542E-01,& - & .1238154E-01,.1046720E-01,.8234826E-02,.6157987E-02,.2021852E-01,& - & .1866243E-01,.1743952E-01,.1614631E-01,.1471423E-01,.1312828E-01,& - & .1131255E-01,.9181663E-02,.7325752E-02,.2004782E-01,.1874347E-01,& - & .1774105E-01,.1664594E-01,.1539580E-01,.1393665E-01,.1225989E-01,& - & .1024134E-01,.8627463E-02,.1988902E-01,.1886277E-01,.1808084E-01,& - & .1721183E-01,.1612179E-01,.1483288E-01,.1330233E-01,.1139021E-01,& - & .1003993E-01,.1973638E-01,.1901550E-01,.1847625E-01,.1780825E-01,& - & .1691910E-01,.1580549E-01,.1439570E-01,.1263517E-01,.1157007E-01/ - - data absa(316:450, 7) / & - & .1987279E-01,.1815516E-01,.1673357E-01,.1526588E-01,.1367570E-01,& - & .1190873E-01,.9931491E-02,.7668521E-02,.5208898E-02,.1970849E-01,& - & .1819142E-01,.1699015E-01,.1570273E-01,.1425525E-01,.1259893E-01,& - & .1071895E-01,.8538062E-02,.6255037E-02,.1954825E-01,.1826821E-01,& - & .1728456E-01,.1619427E-01,.1489632E-01,.1335233E-01,.1159816E-01,& - & .9521153E-02,.7436933E-02,.1939994E-01,.1839394E-01,.1763047E-01,& - & .1674380E-01,.1557766E-01,.1418956E-01,.1258113E-01,.1057697E-01,& - & .8728022E-02,.1926214E-01,.1855724E-01,.1803115E-01,.1732234E-01,& - & .1632534E-01,.1511381E-01,.1362321E-01,.1171409E-01,.1013851E-01,& - & .1916880E-01,.1752174E-01,.1613409E-01,.1469612E-01,.1312851E-01,& - & .1136007E-01,.9364186E-02,.7102147E-02,.4213687E-02,.1900554E-01,& - & .1754861E-01,.1637886E-01,.1511063E-01,.1368165E-01,.1201315E-01,& - & .1009580E-01,.7893303E-02,.5110717E-02,.1885316E-01,.1762136E-01,& - & .1666679E-01,.1558750E-01,.1430162E-01,.1272233E-01,.1090848E-01,& - & .8800048E-02,.6141449E-02,.1871378E-01,.1775166E-01,.1701481E-01,& - & .1613266E-01,.1495234E-01,.1350195E-01,.1182791E-01,.9791825E-02,& - & .7281500E-02,.1858911E-01,.1792329E-01,.1741640E-01,.1670595E-01,& - & .1566347E-01,.1437003E-01,.1281383E-01,.1084750E-01,.8535050E-02,& - & .1826944E-01,.1672464E-01,.1541276E-01,.1403848E-01,.1252666E-01,& - & .1078514E-01,.8823245E-02,.6591625E-02,.4177613E-02,.1810805E-01,& - & .1674909E-01,.1564423E-01,.1443382E-01,.1304370E-01,.1140669E-01,& - & .9515283E-02,.7318294E-02,.4841751E-02,.1796423E-01,.1682298E-01,& - & .1593052E-01,.1489393E-01,.1363432E-01,.1209430E-01,.1027133E-01,& - & .8153051E-02,.5674979E-02,.1783274E-01,.1695370E-01,.1627489E-01,& - & .1542379E-01,.1427771E-01,.1283692E-01,.1112848E-01,.9081882E-02,& - & .6511275E-02,.1772600E-01,.1713577E-01,.1668031E-01,.1599272E-01,& - & .1497596E-01,.1366160E-01,.1205854E-01,.1007221E-01,.7398941E-02/ - - data absa(451:585, 7) / & - & .1712738E-01,.1578625E-01,.1465104E-01,.1343124E-01,.1204735E-01,& - & .1040471E-01,.8547650E-02,.6380408E-02,.4682263E-02,.1697749E-01,& - & .1582950E-01,.1490046E-01,.1383672E-01,.1256494E-01,.1102596E-01,& - & .9230857E-02,.7091836E-02,.5424321E-02,.1684963E-01,.1592973E-01,& - & .1520871E-01,.1431627E-01,.1316095E-01,.1170953E-01,.9981803E-02,& - & .7904548E-02,.6291977E-02,.1674859E-01,.1609441E-01,.1557937E-01,& - & .1485696E-01,.1380508E-01,.1246505E-01,.1081864E-01,.8796469E-02,& - & .7234547E-02,.1667150E-01,.1630711E-01,.1601588E-01,.1543527E-01,& - & .1451902E-01,.1330051E-01,.1171274E-01,.9750545E-02,.8163171E-02,& - & .1585812E-01,.1473647E-01,.1378249E-01,.1272207E-01,.1146005E-01,& - & .9946309E-02,.8216259E-02,.6139489E-02,.4795601E-02,.1573042E-01,& - & .1480849E-01,.1405564E-01,.1313767E-01,.1198402E-01,.1056976E-01,& - & .8883654E-02,.6832310E-02,.5569244E-02,.1562948E-01,.1493848E-01,& - & .1438406E-01,.1362526E-01,.1258929E-01,.1125212E-01,.9629528E-02,& - & .7616188E-02,.6452525E-02,.1556093E-01,.1513902E-01,.1478476E-01,& - & .1418150E-01,.1324034E-01,.1201861E-01,.1045886E-01,.8467010E-02,& - & .7448495E-02,.1552707E-01,.1538861E-01,.1525660E-01,.1477573E-01,& - & .1397485E-01,.1285192E-01,.1132600E-01,.9383049E-02,.8380165E-02,& - & .1451815E-01,.1362323E-01,.1284326E-01,.1193288E-01,.1079141E-01,& - & .9422285E-02,.7828749E-02,.5876279E-02,.4564233E-02,.1441454E-01,& - & .1372037E-01,.1313620E-01,.1235490E-01,.1132640E-01,.1004968E-01,& - & .8482915E-02,.6542489E-02,.5277165E-02,.1434814E-01,.1388758E-01,& - & .1349254E-01,.1286003E-01,.1193607E-01,.1073461E-01,.9223888E-02,& - & .7293736E-02,.6181241E-02,.1432181E-01,.1412637E-01,.1392568E-01,& - & .1342872E-01,.1260305E-01,.1150145E-01,.1004198E-01,.8104002E-02,& - & .7114973E-02,.1432961E-01,.1441453E-01,.1442859E-01,.1404464E-01,& - & .1335348E-01,.1232881E-01,.1089297E-01,.8984991E-02,.8052181E-02/ - - data absa( 1:180, 8) / & - & .7758517E-01,.6971744E-01,.6856234E-01,.7085104E-01,.7686968E-01,& - & .8798079E-01,.1038826E+00,.1198350E+00,.1359548E+00,.7760111E-01,& - & .7121281E-01,.7343034E-01,.7934822E-01,.9017738E-01,.1066736E+00,& - & .1269235E+00,.1465907E+00,.1664556E+00,.7752743E-01,.7302330E-01,& - & .7902576E-01,.8954413E-01,.1059545E+00,.1282979E+00,.1531287E+00,& - & .1770168E+00,.2010905E+00,.7732969E-01,.7518701E-01,.8549302E-01,& - & .1015046E+00,.1240275E+00,.1528286E+00,.1826322E+00,.2112286E+00,& - & .2400654E+00,.7704248E-01,.7773694E-01,.9279924E-01,.1151544E+00,& - & .1447190E+00,.1798906E+00,.2150779E+00,.2488116E+00,.2828065E+00,& - & .8996337E-01,.8019925E-01,.7649483E-01,.7619075E-01,.7950947E-01,& - & .8744378E-01,.1013048E+00,.1167488E+00,.1333495E+00,.9002593E-01,& - & .8150228E-01,.8115314E-01,.8427387E-01,.9208357E-01,.1052256E+00,& - & .1239442E+00,.1430385E+00,.1634839E+00,.8993043E-01,.8319207E-01,& - & .8655274E-01,.9399363E-01,.1071792E+00,.1260258E+00,.1498926E+00,& - & .1732190E+00,.1980122E+00,.8971818E-01,.8524906E-01,.9277644E-01,& - & .1055693E+00,.1245408E+00,.1502414E+00,.1793335E+00,.2072943E+00,& - & .2370216E+00,.8937589E-01,.8770760E-01,.9989309E-01,.1188472E+00,& - & .1444723E+00,.1773019E+00,.2118836E+00,.2451113E+00,.2803148E+00,& - & .1035251E+00,.9170912E-01,.8469424E-01,.8124545E-01,.8127330E-01,& - & .8520134E-01,.9536063E-01,.1094892E+00,.1259212E+00,.1036314E+00,& - & .9276163E-01,.8901665E-01,.8866608E-01,.9260241E-01,.1015125E+00,& - & .1166863E+00,.1344219E+00,.1546172E+00,.1035650E+00,.9415806E-01,& - & .9411336E-01,.9760915E-01,.1066039E+00,.1208833E+00,.1416737E+00,& - & .1635528E+00,.1881599E+00,.1033569E+00,.9604690E-01,.9993466E-01,& - & .1084464E+00,.1229492E+00,.1435592E+00,.1703234E+00,.1968385E+00,& - & .2265370E+00,.1029798E+00,.9835979E-01,.1066697E+00,.1210700E+00,& - & .1417416E+00,.1696560E+00,.2023878E+00,.2340132E+00,.2693038E+00,& - & .1182256E+00,.1042918E+00,.9385612E-01,.8708706E-01,.8392123E-01,& - & .8386827E-01,.8993733E-01,.1021139E+00,.1178700E+00,.1183624E+00,& - & .1051802E+00,.9770525E-01,.9387938E-01,.9397963E-01,.9866810E-01,& - & .1093764E+00,.1253639E+00,.1447078E+00,.1183448E+00,.1063559E+00,& - & .1024326E+00,.1020095E+00,.1067911E+00,.1165316E+00,.1326917E+00,& - & .1528199E+00,.1764343E+00,.1181015E+00,.1078331E+00,.1078798E+00,& - & .1120521E+00,.1219908E+00,.1374912E+00,.1601454E+00,.1848559E+00,& - & .2134132E+00,.1177256E+00,.1098961E+00,.1142273E+00,.1239094E+00,& - & .1395842E+00,.1620158E+00,.1913771E+00,.2212322E+00,.2554318E+00/ - - data absa(181:315, 8) / & - & .1337645E+00,.1176975E+00,.1042174E+00,.9408829E-01,.8780506E-01,& - & .8428291E-01,.8648117E-01,.9578625E-01,.1107310E+00,.1340095E+00,& - & .1185612E+00,.1073992E+00,.1002667E+00,.9676787E-01,.9754447E-01,& - & .1041226E+00,.1173533E+00,.1356505E+00,.1339933E+00,.1195717E+00,& - & .1117737E+00,.1076768E+00,.1084293E+00,.1139755E+00,.1254459E+00,& - & .1433024E+00,.1656569E+00,.1337898E+00,.1208507E+00,.1168604E+00,& - & .1168941E+00,.1225882E+00,.1334602E+00,.1509971E+00,.1738575E+00,& - & .2010332E+00,.1333402E+00,.1225783E+00,.1227702E+00,.1280534E+00,& - & .1390939E+00,.1563754E+00,.1810270E+00,.2089873E+00,.2415778E+00,& - & .1499294E+00,.1316511E+00,.1153149E+00,.1019770E+00,.9253012E-01,& - & .8589064E-01,.8430058E-01,.8998453E-01,.1039889E+00,.1502123E+00,& - & .1324781E+00,.1179942E+00,.1074361E+00,.1005474E+00,.9758469E-01,& - & .1000820E+00,.1097714E+00,.1269049E+00,.1502509E+00,.1333737E+00,& - & .1216948E+00,.1142169E+00,.1109667E+00,.1125131E+00,.1194607E+00,& - & .1338501E+00,.1548471E+00,.1500164E+00,.1344800E+00,.1264420E+00,& - & .1225692E+00,.1240810E+00,.1304661E+00,.1429117E+00,.1627629E+00,& - & .1883115E+00,.1495747E+00,.1359816E+00,.1319394E+00,.1329504E+00,& - & .1395630E+00,.1517775E+00,.1709091E+00,.1964203E+00,.2271878E+00,& - & .1667524E+00,.1461966E+00,.1270922E+00,.1109576E+00,.9817555E-01,& - & .8876777E-01,.8374701E-01,.8543513E-01,.9818294E-01,.1671368E+00,& - & .1470313E+00,.1293919E+00,.1154650E+00,.1053506E+00,.9907389E-01,& - & .9777459E-01,.1033433E+00,.1192365E+00,.1672667E+00,.1478601E+00,& - & .1325480E+00,.1215247E+00,.1147604E+00,.1125732E+00,.1153357E+00,& - & .1255724E+00,.1452073E+00,.1670804E+00,.1488123E+00,.1366626E+00,& - & .1291483E+00,.1268401E+00,.1291153E+00,.1368015E+00,.1526760E+00,& - & .1766400E+00,.1666531E+00,.1500830E+00,.1416654E+00,.1387987E+00,& - & .1413161E+00,.1488921E+00,.1627763E+00,.1846442E+00,.2135966E+00/ - - data absa(316:450, 8) / & - & .1846850E+00,.1617527E+00,.1399797E+00,.1208986E+00,.1049700E+00,& - & .9268890E-01,.8468015E-01,.8250239E-01,.9346009E-01,.1852004E+00,& - & .1626022E+00,.1419177E+00,.1246679E+00,.1111616E+00,.1018673E+00,& - & .9711144E-01,.9858998E-01,.1128165E+00,.1854002E+00,.1633815E+00,& - & .1446073E+00,.1298548E+00,.1195851E+00,.1140911E+00,.1130781E+00,& - & .1187616E+00,.1368729E+00,.1852584E+00,.1641980E+00,.1481385E+00,& - & .1365970E+00,.1306723E+00,.1293064E+00,.1327425E+00,.1439504E+00,& - & .1663864E+00,.1848096E+00,.1652487E+00,.1525559E+00,.1454722E+00,& - & .1442002E+00,.1476584E+00,.1567932E+00,.1741988E+00,.2014170E+00,& - & .2035660E+00,.1782138E+00,.1538641E+00,.1319292E+00,.1129603E+00,& - & .9769919E-01,.8663861E-01,.8077073E-01,.8932903E-01,.2042261E+00,& - & .1790867E+00,.1555132E+00,.1351430E+00,.1182459E+00,.1056510E+00,& - & .9764716E-01,.9524493E-01,.1071831E+00,.2045296E+00,.1798786E+00,& - & .1578247E+00,.1395652E+00,.1254969E+00,.1165399E+00,.1121007E+00,& - & .1135498E+00,.1294885E+00,.2044541E+00,.1805616E+00,.1608548E+00,& - & .1453947E+00,.1354455E+00,.1305073E+00,.1300663E+00,.1365302E+00,& - & .1570562E+00,.2040215E+00,.1814068E+00,.1647421E+00,.1533244E+00,& - & .1479662E+00,.1475364E+00,.1523061E+00,.1647332E+00,.1901427E+00,& - & .2235492E+00,.1956768E+00,.1686716E+00,.1440048E+00,.1221516E+00,& - & .1041925E+00,.9012153E-01,.8095605E-01,.7543929E-01,.2243439E+00,& - & .1965703E+00,.1701921E+00,.1468360E+00,.1269493E+00,.1112681E+00,& - & .9999583E-01,.9424336E-01,.9351393E-01,.2246860E+00,.1973265E+00,& - & .1722057E+00,.1507546E+00,.1334737E+00,.1209496E+00,.1133134E+00,& - & .1112100E+00,.1153114E+00,.2246584E+00,.1979469E+00,.1749030E+00,& - & .1560431E+00,.1423719E+00,.1337802E+00,.1300644E+00,.1325688E+00,& - & .1435519E+00,.2242020E+00,.1986013E+00,.1783455E+00,.1632177E+00,& - & .1538706E+00,.1497467E+00,.1509387E+00,.1590812E+00,.1779531E+00/ - - data absa(451:585, 8) / & - & .2450204E+00,.2144676E+00,.1850038E+00,.1579688E+00,.1339651E+00,& - & .1141008E+00,.9793249E-01,.8695958E-01,.6939988E-01,.2456964E+00,& - & .2153041E+00,.1865121E+00,.1608968E+00,.1389868E+00,.1214503E+00,& - & .1082108E+00,.1007628E+00,.8668012E-01,.2459004E+00,.2159604E+00,& - & .1885239E+00,.1648976E+00,.1457743E+00,.1314989E+00,.1219175E+00,& - & .1183238E+00,.1082310E+00,.2456185E+00,.2163907E+00,.1911660E+00,& - & .1703594E+00,.1550454E+00,.1445551E+00,.1392768E+00,.1404833E+00,& - & .1353141E+00,.2449307E+00,.2169326E+00,.1945158E+00,.1777645E+00,& - & .1667152E+00,.1608041E+00,.1609850E+00,.1678148E+00,.1694632E+00,& - & .2671603E+00,.2338498E+00,.2019245E+00,.1725008E+00,.1464684E+00,& - & .1244209E+00,.1059693E+00,.9304783E-01,.6959000E-01,.2676057E+00,& - & .2345222E+00,.2033654E+00,.1755662E+00,.1517012E+00,.1320205E+00,& - & .1167556E+00,.1073595E+00,.8673211E-01,.2675630E+00,.2350038E+00,& - & .2053552E+00,.1797362E+00,.1586943E+00,.1424342E+00,.1308446E+00,& - & .1256134E+00,.1083518E+00,.2670071E+00,.2352413E+00,.2078987E+00,& - & .1853108E+00,.1681964E+00,.1557131E+00,.1486669E+00,.1486318E+00,& - & .1350793E+00,.2659779E+00,.2356017E+00,.2111172E+00,.1928578E+00,& - & .1799895E+00,.1723719E+00,.1711124E+00,.1767808E+00,.1695167E+00,& - & .2893519E+00,.2532903E+00,.2190193E+00,.1873805E+00,.1594254E+00,& - & .1350214E+00,.1142355E+00,.9903594E-01,.7490192E-01,.2895758E+00,& - & .2538124E+00,.2204052E+00,.1906072E+00,.1647749E+00,.1428610E+00,& - & .1254558E+00,.1139403E+00,.9307717E-01,.2892263E+00,.2540433E+00,& - & .2223015E+00,.1948310E+00,.1719923E+00,.1535461E+00,.1399201E+00,& - & .1328863E+00,.1147608E+00,.2883124E+00,.2540521E+00,.2247025E+00,& - & .2005493E+00,.1816141E+00,.1671436E+00,.1582248E+00,.1567001E+00,& - & .1426012E+00,.2869377E+00,.2542235E+00,.2278499E+00,.2081519E+00,& - & .1935477E+00,.1842067E+00,.1812086E+00,.1856280E+00,.1773106E+00/ - -! the array absb(235,8) (kb(5,13:59,8)) contains absorption coefs at -! the 16 chosen g-values for a range of pressure levels < ~100mb and -! temperatures. the first index in the array, jt, which runs from 1 to 5, -! corresponds to different temperatures. more specifically, jt = 3 means -! that the data are for the reference temperature tref for this pressure -! level, jt = 2 refers to the temperature tref-15, jt = 1 is for -! tref-30, jt = 4 is for tref+15, and jt = 5 is for tref+30. -! the second index, jp, runs from 13 to 59 and refers to the jpth -! reference pressure level (see taumol.f for the value of these -! pressure levels in mb). the third index, ig, goes from 1 to 8, -! and tells us which g-interval the absorption coefficients are for. - - data absb( 1:120, 1) / & - & .8084900E-06,.8136200E-06,.8139100E-06,.8183200E-06,.8100000E-06,& - & .6259300E-06,.6309000E-06,.6315800E-06,.6282100E-06,.6250200E-06,& - & .4782500E-06,.4785200E-06,.4771300E-06,.4768800E-06,.4798900E-06,& - & .3603900E-06,.3590500E-06,.3606400E-06,.3629800E-06,.3686000E-06,& - & .2767900E-06,.2760800E-06,.2774200E-06,.2811200E-06,.2875900E-06,& - & .2177100E-06,.2182600E-06,.2201900E-06,.2242900E-06,.2299600E-06,& - & .1733400E-06,.1744100E-06,.1768100E-06,.1805500E-06,.1853700E-06,& - & .1397400E-06,.1407600E-06,.1432600E-06,.1469400E-06,.1507000E-06,& - & .1128900E-06,.1139400E-06,.1163100E-06,.1196300E-06,.1228400E-06,& - & .9057400E-07,.9191400E-07,.9404600E-07,.9699800E-07,.9984100E-07,& - & .7248300E-07,.7406900E-07,.7618600E-07,.7848200E-07,.8096400E-07,& - & .5746300E-07,.5913000E-07,.6080200E-07,.6290300E-07,.6521800E-07,& - & .4576700E-07,.4718400E-07,.4869600E-07,.5049400E-07,.5252700E-07,& - & .3663600E-07,.3779400E-07,.3921700E-07,.4076800E-07,.4246500E-07,& - & .2917300E-07,.3018300E-07,.3146900E-07,.3283400E-07,.3421300E-07,& - & .2322500E-07,.2413700E-07,.2516700E-07,.2637800E-07,.2753400E-07,& - & .1867500E-07,.1947200E-07,.2034000E-07,.2134000E-07,.2228600E-07,& - & .1502000E-07,.1569000E-07,.1646800E-07,.1725800E-07,.1806000E-07,& - & .1214900E-07,.1272800E-07,.1337500E-07,.1403500E-07,.1471100E-07,& - & .9859600E-08,.1034400E-07,.1087900E-07,.1142700E-07,.1200300E-07,& - & .8012700E-08,.8419900E-08,.8861000E-08,.9318800E-08,.9810200E-08,& - & .6547300E-08,.6885000E-08,.7247000E-08,.7637900E-08,.8032900E-08,& - & .5310700E-08,.5593000E-08,.5898400E-08,.6216100E-08,.6551100E-08,& - & .4274900E-08,.4507200E-08,.4759200E-08,.5024400E-08,.5303400E-08/ - - data absb(121:235, 1) / & - & .3459300E-08,.3647900E-08,.3855700E-08,.4071400E-08,.4303100E-08,& - & .2798100E-08,.2952500E-08,.3121200E-08,.3298400E-08,.3489000E-08,& - & .2261600E-08,.2387900E-08,.2526600E-08,.2671600E-08,.2829500E-08,& - & .1823200E-08,.1924500E-08,.2036200E-08,.2155400E-08,.2283100E-08,& - & .1467900E-08,.1551100E-08,.1640200E-08,.1737600E-08,.1841300E-08,& - & .1182800E-08,.1248800E-08,.1320000E-08,.1400800E-08,.1484100E-08,& - & .9497000E-09,.1002800E-08,.1061000E-08,.1125400E-08,.1193300E-08,& - & .7621000E-09,.8040100E-09,.8509800E-09,.9020300E-09,.9579400E-09,& - & .6124200E-09,.6447100E-09,.6820500E-09,.7233600E-09,.7684600E-09,& - & .4921400E-09,.5164200E-09,.5463300E-09,.5791600E-09,.6150600E-09,& - & .3955200E-09,.4134300E-09,.4365800E-09,.4626600E-09,.4912100E-09,& - & .3177300E-09,.3316100E-09,.3487800E-09,.3697000E-09,.3923100E-09,& - & .2552600E-09,.2661300E-09,.2790600E-09,.2951000E-09,.3134600E-09,& - & .2057100E-09,.2141900E-09,.2237900E-09,.2362200E-09,.2507600E-09,& - & .1657300E-09,.1725100E-09,.1800200E-09,.1892500E-09,.2007400E-09,& - & .1331200E-09,.1388800E-09,.1448000E-09,.1517000E-09,.1606700E-09,& - & .1071700E-09,.1120000E-09,.1165300E-09,.1218700E-09,.1286400E-09,& - & .8539500E-10,.9019000E-10,.9397800E-10,.9811500E-10,.1032400E-09,& - & .6793300E-10,.7268200E-10,.7585700E-10,.7907900E-10,.8294200E-10,& - & .5357200E-10,.5809500E-10,.6123100E-10,.6373800E-10,.6673800E-10,& - & .4172900E-10,.4638000E-10,.4935700E-10,.5140900E-10,.5374300E-10,& - & .3231900E-10,.3673700E-10,.3957200E-10,.4148700E-10,.4332700E-10,& - & .2582000E-10,.2954100E-10,.3210700E-10,.3376200E-10,.3525000E-10/ - - data absb( 1:120, 2) / & - & .9380900E-05,.1053600E-04,.1177700E-04,.1309800E-04,.1448600E-04,& - & .7705000E-05,.8652000E-05,.9674500E-05,.1075900E-04,.1189100E-04,& - & .6311200E-05,.7091400E-05,.7932000E-05,.8817900E-05,.9734400E-05,& - & .5167200E-05,.5817200E-05,.6496100E-05,.7213300E-05,.7959500E-05,& - & .4247000E-05,.4781700E-05,.5339600E-05,.5922900E-05,.6538500E-05,& - & .3510500E-05,.3951300E-05,.4404200E-05,.4886500E-05,.5398300E-05,& - & .2905700E-05,.3268000E-05,.3640900E-05,.4041900E-05,.4464600E-05,& - & .2413200E-05,.2711100E-05,.3019200E-05,.3349800E-05,.3698500E-05,& - & .2004100E-05,.2248400E-05,.2505200E-05,.2777000E-05,.3066100E-05,& - & .1676200E-05,.1877500E-05,.2090000E-05,.2315800E-05,.2554300E-05,& - & .1401300E-05,.1566500E-05,.1743300E-05,.1930800E-05,.2129000E-05,& - & .1168000E-05,.1303900E-05,.1451500E-05,.1608500E-05,.1773300E-05,& - & .9749100E-06,.1088600E-05,.1211400E-05,.1342800E-05,.1480600E-05,& - & .8160800E-06,.9119800E-06,.1014800E-05,.1124400E-05,.1239200E-05,& - & .6840700E-06,.7643200E-06,.8504800E-06,.9421000E-06,.1039300E-05,& - & .5734000E-06,.6407100E-06,.7131100E-06,.7898800E-06,.8730400E-06,& - & .4823400E-06,.5388600E-06,.5999200E-06,.6655700E-06,.7356500E-06,& - & .4062800E-06,.4538400E-06,.5063800E-06,.5617500E-06,.6208600E-06,& - & .3427600E-06,.3840900E-06,.4281700E-06,.4755100E-06,.5250800E-06,& - & .2902400E-06,.3254800E-06,.3629100E-06,.4026300E-06,.4442300E-06,& - & .2462300E-06,.2759600E-06,.3074800E-06,.3410400E-06,.3757100E-06,& - & .2081400E-06,.2331800E-06,.2597500E-06,.2874600E-06,.3167400E-06,& - & .1739900E-06,.1947600E-06,.2169800E-06,.2402100E-06,.2646300E-06,& - & .1435200E-06,.1607900E-06,.1792000E-06,.1983800E-06,.2185200E-06/ - - data absb(121:235, 2) / & - & .1164400E-06,.1306100E-06,.1456900E-06,.1614800E-06,.1779400E-06,& - & .9432700E-07,.1059700E-06,.1182700E-06,.1312100E-06,.1447100E-06,& - & .7638600E-07,.8593200E-07,.9600400E-07,.1067500E-06,.1178500E-06,& - & .6109300E-07,.6885600E-07,.7708800E-07,.8583100E-07,.9487800E-07,& - & .4878100E-07,.5505800E-07,.6172500E-07,.6885200E-07,.7623400E-07,& - & .3890900E-07,.4398700E-07,.4939100E-07,.5516100E-07,.6119700E-07,& - & .3077900E-07,.3486600E-07,.3922200E-07,.4387000E-07,.4878500E-07,& - & .2424900E-07,.2751400E-07,.3101400E-07,.3477400E-07,.3877200E-07,& - & .1907600E-07,.2169300E-07,.2451400E-07,.2752200E-07,.3075600E-07,& - & .1494900E-07,.1704600E-07,.1930300E-07,.2172100E-07,.2432000E-07,& - & .1162700E-07,.1329400E-07,.1510200E-07,.1704000E-07,.1911500E-07,& - & .9020800E-08,.1035900E-07,.1180300E-07,.1334900E-07,.1500300E-07,& - & .6997900E-08,.8062500E-08,.9207500E-08,.1044500E-07,.1176800E-07,& - & .5450700E-08,.6277700E-08,.7200400E-08,.8189900E-08,.9248800E-08,& - & .4254100E-08,.4893300E-08,.5630400E-08,.6421400E-08,.7272500E-08,& - & .3316100E-08,.3812100E-08,.4397600E-08,.5030100E-08,.5714000E-08,& - & .2581700E-08,.2969100E-08,.3429100E-08,.3936800E-08,.4483600E-08,& - & .2020300E-08,.2322800E-08,.2682300E-08,.3090000E-08,.3528500E-08,& - & .1583300E-08,.1819600E-08,.2102300E-08,.2427600E-08,.2778700E-08,& - & .1240300E-08,.1425000E-08,.1646100E-08,.1904500E-08,.2185500E-08,& - & .9724900E-09,.1116400E-08,.1288100E-08,.1492300E-08,.1717500E-08,& - & .7643100E-09,.8769900E-09,.1010800E-08,.1170900E-08,.1351600E-08,& - & .6155300E-09,.7064900E-09,.8146300E-09,.9431500E-09,.1090700E-08/ - - data absb( 1:120, 3) / & - & .3770800E-04,.4394200E-04,.5058600E-04,.5765600E-04,.6513900E-04,& - & .3169400E-04,.3686200E-04,.4235000E-04,.4819700E-04,.5434100E-04,& - & .2656400E-04,.3082400E-04,.3537200E-04,.4018000E-04,.4523100E-04,& - & .2223200E-04,.2574000E-04,.2951200E-04,.3344700E-04,.3758800E-04,& - & .1857800E-04,.2146700E-04,.2458200E-04,.2783200E-04,.3122100E-04,& - & .1553000E-04,.1792200E-04,.2049800E-04,.2317000E-04,.2597300E-04,& - & .1297200E-04,.1495200E-04,.1705900E-04,.1927000E-04,.2158000E-04,& - & .1085800E-04,.1249800E-04,.1422800E-04,.1606100E-04,.1795800E-04,& - & .9081900E-05,.1044600E-04,.1188000E-04,.1339400E-04,.1495100E-04,& - & .7664800E-05,.8797900E-05,.9993100E-05,.1125500E-04,.1254200E-04,& - & .6463400E-05,.7414000E-05,.8408600E-05,.9454600E-05,.1052700E-04,& - & .5452300E-05,.6246400E-05,.7080900E-05,.7950800E-05,.8844600E-05,& - & .4611000E-05,.5271600E-05,.5969300E-05,.6690400E-05,.7432200E-05,& - & .3913400E-05,.4462000E-05,.5042500E-05,.5643900E-05,.6257700E-05,& - & .3320800E-05,.3777700E-05,.4262900E-05,.4760700E-05,.5271400E-05,& - & .2817700E-05,.3200800E-05,.3603100E-05,.4018700E-05,.4435800E-05,& - & .2393200E-05,.2715800E-05,.3051600E-05,.3394500E-05,.3741600E-05,& - & .2034000E-05,.2303500E-05,.2582700E-05,.2867200E-05,.3155900E-05,& - & .1730800E-05,.1954700E-05,.2186900E-05,.2424300E-05,.2664900E-05,& - & .1473400E-05,.1659300E-05,.1853600E-05,.2051800E-05,.2251400E-05,& - & .1253800E-05,.1409700E-05,.1571800E-05,.1736900E-05,.1901300E-05,& - & .1062600E-05,.1193200E-05,.1329000E-05,.1466200E-05,.1602500E-05,& - & .8899000E-06,.9987800E-06,.1112200E-05,.1226600E-05,.1339500E-05,& - & .7353500E-06,.8269000E-06,.9209900E-06,.1015900E-05,.1109900E-05/ - - data absb(121:235, 3) / & - & .5972800E-06,.6730100E-06,.7512700E-06,.8302100E-06,.9084500E-06,& - & .4848400E-06,.5473700E-06,.6122900E-06,.6776200E-06,.7425800E-06,& - & .3934700E-06,.4448500E-06,.4988600E-06,.5529000E-06,.6067400E-06,& - & .3148800E-06,.3570300E-06,.4014800E-06,.4464000E-06,.4909100E-06,& - & .2513000E-06,.2856100E-06,.3222400E-06,.3595300E-06,.3961800E-06,& - & .2003000E-06,.2284000E-06,.2583400E-06,.2893000E-06,.3196500E-06,& - & .1580700E-06,.1810900E-06,.2054200E-06,.2309400E-06,.2563500E-06,& - & .1241800E-06,.1428200E-06,.1626100E-06,.1836400E-06,.2046500E-06,& - & .9738300E-07,.1124500E-06,.1285500E-06,.1457200E-06,.1630700E-06,& - & .7601500E-07,.8806700E-07,.1012000E-06,.1151000E-06,.1293500E-06,& - & .5881300E-07,.6849300E-07,.7910200E-07,.9027300E-07,.1020000E-06,& - & .4544000E-07,.5314400E-07,.6159700E-07,.7063900E-07,.8025500E-07,& - & .3501500E-07,.4113600E-07,.4786900E-07,.5521600E-07,.6299400E-07,& - & .2705600E-07,.3191000E-07,.3726700E-07,.4321000E-07,.4952200E-07,& - & .2090800E-07,.2475600E-07,.2904400E-07,.3379100E-07,.3890400E-07,& - & .1613100E-07,.1918100E-07,.2258900E-07,.2637800E-07,.3050400E-07,& - & .1241800E-07,.1483500E-07,.1753700E-07,.2054700E-07,.2386000E-07,& - & .9599400E-08,.1151400E-07,.1366200E-07,.1606500E-07,.1871700E-07,& - & .7423900E-08,.8945300E-08,.1065600E-07,.1256900E-07,.1469300E-07,& - & .5730000E-08,.6944100E-08,.8303000E-08,.9819300E-08,.1152300E-07,& - & .4415200E-08,.5381100E-08,.6458100E-08,.7661000E-08,.9020100E-08,& - & .3407200E-08,.4170800E-08,.5029700E-08,.5987600E-08,.7068400E-08,& - & .2730200E-08,.3349200E-08,.4048100E-08,.4826600E-08,.5704600E-08/ - - data absb( 1:120, 4) / & - & .1201500E-03,.1392000E-03,.1593700E-03,.1800100E-03,.1992900E-03,& - & .1025600E-03,.1188300E-03,.1358700E-03,.1525900E-03,.1681200E-03,& - & .8720300E-04,.1009900E-03,.1149800E-03,.1284700E-03,.1411400E-03,& - & .7385900E-04,.8530400E-04,.9681600E-04,.1077400E-03,.1180500E-03,& - & .6233400E-04,.7178600E-04,.8122500E-04,.9009100E-04,.9845400E-04,& - & .5258100E-04,.6034400E-04,.6801800E-04,.7523700E-04,.8190300E-04,& - & .4419700E-04,.5057300E-04,.5684000E-04,.6265600E-04,.6796800E-04,& - & .3715100E-04,.4238400E-04,.4749400E-04,.5219300E-04,.5646700E-04,& - & .3119300E-04,.3548000E-04,.3960000E-04,.4342700E-04,.4687000E-04,& - & .2637400E-04,.2992500E-04,.3322400E-04,.3626100E-04,.3904000E-04,& - & .2231500E-04,.2519800E-04,.2783300E-04,.3029000E-04,.3250900E-04,& - & .1888300E-04,.2118400E-04,.2329100E-04,.2526800E-04,.2704600E-04,& - & .1597700E-04,.1780800E-04,.1952900E-04,.2110600E-04,.2253300E-04,& - & .1352400E-04,.1499600E-04,.1639100E-04,.1765800E-04,.1879600E-04,& - & .1143300E-04,.1263100E-04,.1375700E-04,.1476900E-04,.1567700E-04,& - & .9655800E-05,.1064000E-04,.1153700E-04,.1235700E-04,.1308600E-04,& - & .8163200E-05,.8956000E-05,.9680100E-05,.1033900E-04,.1091900E-04,& - & .6897200E-05,.7532100E-05,.8118900E-05,.8641800E-05,.9112000E-05,& - & .5825500E-05,.6342700E-05,.6811500E-05,.7229100E-05,.7608800E-05,& - & .4923500E-05,.5340400E-05,.5712800E-05,.6045000E-05,.6354000E-05,& - & .4160200E-05,.4490400E-05,.4787300E-05,.5056700E-05,.5308500E-05,& - & .3499300E-05,.3764000E-05,.4003300E-05,.4221700E-05,.4432100E-05,& - & .2916800E-05,.3133100E-05,.3326400E-05,.3507200E-05,.3680800E-05,& - & .2410500E-05,.2586300E-05,.2745900E-05,.2896900E-05,.3043300E-05/ - - data absb(121:235, 4) / & - & .1969900E-05,.2116700E-05,.2249900E-05,.2375100E-05,.2498400E-05,& - & .1608500E-05,.1731600E-05,.1843100E-05,.1948200E-05,.2052000E-05,& - & .1314000E-05,.1417200E-05,.1510200E-05,.1598900E-05,.1686200E-05,& - & .1064300E-05,.1151800E-05,.1230000E-05,.1305200E-05,.1378900E-05,& - & .8610300E-06,.9349400E-06,.1001300E-05,.1064800E-05,.1127500E-05,& - & .6956600E-06,.7580300E-06,.8146800E-06,.8681700E-06,.9211300E-06,& - & .5585600E-06,.6113500E-06,.6599200E-06,.7050100E-06,.7491500E-06,& - & .4464400E-06,.4911300E-06,.5328400E-06,.5706600E-06,.6077600E-06,& - & .3563800E-06,.3938600E-06,.4294700E-06,.4619200E-06,.4929500E-06,& - & .2831700E-06,.3149000E-06,.3450300E-06,.3727600E-06,.3989400E-06,& - & .2234100E-06,.2500200E-06,.2756000E-06,.2995700E-06,.3214400E-06,& - & .1755400E-06,.1979800E-06,.2196200E-06,.2401000E-06,.2587600E-06,& - & .1373700E-06,.1564200E-06,.1745100E-06,.1919200E-06,.2079500E-06,& - & .1075400E-06,.1235700E-06,.1387900E-06,.1534300E-06,.1671200E-06,& - & .8412100E-07,.9744100E-07,.1101800E-06,.1225600E-06,.1341900E-06,& - & .6560400E-07,.7656400E-07,.8735600E-07,.9770300E-07,.1074500E-06,& - & .5094300E-07,.5998800E-07,.6904800E-07,.7762900E-07,.8593300E-07,& - & .3967900E-07,.4712100E-07,.5461400E-07,.6176600E-07,.6878300E-07,& - & .3093400E-07,.3698000E-07,.4311300E-07,.4914200E-07,.5500500E-07,& - & .2405000E-07,.2892300E-07,.3399300E-07,.3904700E-07,.4392800E-07,& - & .1866000E-07,.2255700E-07,.2674800E-07,.3095100E-07,.3500000E-07,& - & .1448800E-07,.1762500E-07,.2104300E-07,.2451100E-07,.2788400E-07,& - & .1167400E-07,.1423400E-07,.1704400E-07,.1990200E-07,.2270200E-07/ - - data absb( 1:120, 5) / & - & .5907500E-03,.6176547E-03,.6462139E-03,.6766147E-03,.7105858E-03,& - & .5021733E-03,.5254919E-03,.5505928E-03,.5781750E-03,.6090718E-03,& - & .4251753E-03,.4458740E-03,.4682385E-03,.4935183E-03,.5206768E-03,& - & .3591813E-03,.3774559E-03,.3977574E-03,.4201300E-03,.4431469E-03,& - & .3027495E-03,.3191476E-03,.3371282E-03,.3563107E-03,.3755935E-03,& - & .2550227E-03,.2694860E-03,.2850784E-03,.3010196E-03,.3174204E-03,& - & .2145715E-03,.2270374E-03,.2400302E-03,.2534708E-03,.2670980E-03,& - & .1804017E-03,.1910788E-03,.2019239E-03,.2130155E-03,.2241997E-03,& - & .1515116E-03,.1603628E-03,.1693253E-03,.1785842E-03,.1878199E-03,& - & .1274750E-03,.1347358E-03,.1422851E-03,.1500079E-03,.1574823E-03,& - & .1070376E-03,.1130951E-03,.1194785E-03,.1258411E-03,.1318753E-03,& - & .8978466E-04,.9494123E-04,.1002546E-03,.1054132E-03,.1102246E-03,& - & .7533356E-04,.7966324E-04,.8405144E-04,.8817180E-04,.9207527E-04,& - & .6331538E-04,.6693246E-04,.7046596E-04,.7375138E-04,.7692004E-04,& - & .5321123E-04,.5620271E-04,.5902917E-04,.6164644E-04,.6430450E-04,& - & .4466516E-04,.4710753E-04,.4935907E-04,.5155918E-04,.5379983E-04,& - & .3751313E-04,.3945958E-04,.4130911E-04,.4316167E-04,.4502731E-04,& - & .3148456E-04,.3306301E-04,.3457534E-04,.3614273E-04,.3767792E-04,& - & .2643306E-04,.2770164E-04,.2898435E-04,.3028820E-04,.3158349E-04,& - & .2217901E-04,.2324093E-04,.2432947E-04,.2540558E-04,.2651303E-04,& - & .1860493E-04,.1950781E-04,.2040165E-04,.2133522E-04,.2227687E-04,& - & .1560186E-04,.1635369E-04,.1712128E-04,.1791364E-04,.1869262E-04,& - & .1303087E-04,.1366605E-04,.1431103E-04,.1497004E-04,.1563111E-04,& - & .1082591E-04,.1136497E-04,.1190838E-04,.1246591E-04,.1301791E-04/ - - data absb(121:235, 5) / & - & .8949161E-05,.9402237E-05,.9857226E-05,.1033892E-04,.1080399E-04,& - & .7398494E-05,.7779511E-05,.8166568E-05,.8566423E-05,.8964480E-05,& - & .6113971E-05,.6437029E-05,.6769198E-05,.7108135E-05,.7445280E-05,& - & .5026369E-05,.5297079E-05,.5578033E-05,.5865750E-05,.6156368E-05,& - & .4126175E-05,.4355500E-05,.4592219E-05,.4836238E-05,.5085641E-05,& - & .3390696E-05,.3580871E-05,.3780710E-05,.3987163E-05,.4198069E-05,& - & .2776281E-05,.2936183E-05,.3106181E-05,.3277157E-05,.3458786E-05,& - & .2266975E-05,.2401731E-05,.2543341E-05,.2688159E-05,.2843911E-05,& - & .1851175E-05,.1964040E-05,.2082434E-05,.2205585E-05,.2334866E-05,& - & .1508390E-05,.1603576E-05,.1702375E-05,.1806116E-05,.1913393E-05,& - & .1224515E-05,.1304492E-05,.1387169E-05,.1474342E-05,.1565346E-05,& - & .9927416E-06,.1060100E-05,.1128545E-05,.1203015E-05,.1278997E-05,& - & .8040118E-06,.8600684E-06,.9178680E-06,.9793761E-06,.1043884E-05,& - & .6511957E-06,.6983405E-06,.7470839E-06,.7982212E-06,.8522692E-06,& - & .5274519E-06,.5672397E-06,.6079811E-06,.6509056E-06,.6959894E-06,& - & .4266819E-06,.4601105E-06,.4940630E-06,.5297410E-06,.5677419E-06,& - & .3444399E-06,.3727641E-06,.4009432E-06,.4307494E-06,.4625489E-06,& - & .2784617E-06,.3023078E-06,.3258711E-06,.3507791E-06,.3773299E-06,& - & .2249763E-06,.2450479E-06,.2650681E-06,.2856452E-06,.3078613E-06,& - & .1813509E-06,.1984089E-06,.2151828E-06,.2323405E-06,.2508149E-06,& - & .1459558E-06,.1603926E-06,.1745826E-06,.1886604E-06,.2039625E-06,& - & .1175460E-06,.1296812E-06,.1415814E-06,.1532665E-06,.1658461E-06,& - & .9640155E-07,.1066253E-06,.1166034E-06,.1263881E-06,.1369759E-06/ - - data absb( 1:120, 6) / & - & .3651810E-02,.3746595E-02,.3858789E-02,.3979164E-02,.4109370E-02,& - & .3141811E-02,.3230210E-02,.3325595E-02,.3429577E-02,.3547976E-02,& - & .2701370E-02,.2775610E-02,.2858077E-02,.2953528E-02,.3061412E-02,& - & .2315393E-02,.2378831E-02,.2454205E-02,.2541014E-02,.2642100E-02,& - & .1977791E-02,.2036050E-02,.2104700E-02,.2186085E-02,.2283190E-02,& - & .1685324E-02,.1740054E-02,.1805015E-02,.1884094E-02,.1978199E-02,& - & .1437021E-02,.1487251E-02,.1550029E-02,.1626786E-02,.1715576E-02,& - & .1225237E-02,.1273610E-02,.1334615E-02,.1407663E-02,.1492701E-02,& - & .1044735E-02,.1092958E-02,.1152692E-02,.1223437E-02,.1303990E-02,& - & .8942887E-03,.9428463E-03,.1001793E-02,.1070477E-02,.1149176E-02,& - & .7694049E-03,.8171499E-03,.8745104E-03,.9407106E-03,.1016851E-02,& - & .6645252E-03,.7113905E-03,.7673264E-03,.8320640E-03,.9036498E-03,& - & .5770389E-03,.6234065E-03,.6779963E-03,.7399304E-03,.8071342E-03,& - & .5049575E-03,.5502834E-03,.6030293E-03,.6613349E-03,.7246181E-03,& - & .4447202E-03,.4886958E-03,.5389704E-03,.5940660E-03,.6530676E-03,& - & .3944259E-03,.4369189E-03,.4843540E-03,.5362101E-03,.5917015E-03,& - & .3520821E-03,.3928555E-03,.4377636E-03,.4866798E-03,.5390983E-03,& - & .3162045E-03,.3551094E-03,.3978195E-03,.4440662E-03,.4940346E-03,& - & .2859841E-03,.3231854E-03,.3639308E-03,.4079919E-03,.4558740E-03,& - & .2600638E-03,.2959725E-03,.3350934E-03,.3776361E-03,.4237286E-03,& - & .2380660E-03,.2725920E-03,.3104257E-03,.3517378E-03,.3964521E-03,& - & .2181478E-03,.2514965E-03,.2881695E-03,.3284820E-03,.3717262E-03,& - & .1983067E-03,.2303075E-03,.2658491E-03,.3047978E-03,.3465710E-03,& - & .1780704E-03,.2085530E-03,.2427653E-03,.2802542E-03,.3204639E-03/ - - data absb(121:235, 6) / & - & .1565144E-03,.1849367E-03,.2172813E-03,.2529291E-03,.2913913E-03,& - & .1374906E-03,.1639820E-03,.1944800E-03,.2286994E-03,.2656361E-03,& - & .1209235E-03,.1455643E-03,.1744351E-03,.2072121E-03,.2429831E-03,& - & .1042521E-03,.1269284E-03,.1536021E-03,.1846991E-03,.2190618E-03,& - & .8956332E-04,.1101797E-03,.1349815E-03,.1642251E-03,.1972149E-03,& - & .7682060E-04,.9563184E-04,.1183845E-03,.1457632E-03,.1774806E-03,& - & .6483539E-04,.8163448E-04,.1023214E-03,.1276117E-03,.1579098E-03,& - & .5421096E-04,.6906822E-04,.8771080E-04,.1108467E-03,.1392070E-03,& - & .4516018E-04,.5817822E-04,.7490186E-04,.9595379E-04,.1222179E-03,& - & .3720506E-04,.4849290E-04,.6322139E-04,.8217544E-04,.1061847E-03,& - & .3014760E-04,.3978783E-04,.5256468E-04,.6924860E-04,.9085729E-04,& - & .2427491E-04,.3242037E-04,.4333198E-04,.5801079E-04,.7732452E-04,& - & .1942608E-04,.2622750E-04,.3554119E-04,.4824771E-04,.6532610E-04,& - & .1560503E-04,.2127119E-04,.2922144E-04,.4016492E-04,.5526442E-04,& - & .1246448E-04,.1717739E-04,.2388696E-04,.3336674E-04,.4667005E-04,& - & .9928517E-05,.1381768E-04,.1943442E-04,.2753949E-04,.3915061E-04,& - & .7845842E-05,.1104661E-04,.1568945E-04,.2259744E-04,.3259294E-04,& - & .6241865E-05,.8874763E-05,.1274389E-04,.1859414E-04,.2728085E-04,& - & .4962728E-05,.7110134E-05,.1034291E-04,.1527272E-04,.2280240E-04,& - & .3921680E-05,.5664841E-05,.8348994E-05,.1247617E-04,.1894519E-04,& - & .3092625E-05,.4493204E-05,.6711569E-05,.1013101E-04,.1563245E-04,& - & .2446444E-05,.3564130E-05,.5373137E-05,.8228205E-05,.1289787E-04,& - & .2061392E-05,.3034672E-05,.4641777E-05,.7229029E-05,.1154580E-04/ - - data absb( 1:120, 7) / & - & .7974511E-01,.7917223E-01,.7880571E-01,.7865688E-01,.7869742E-01,& - & .7216761E-01,.7180196E-01,.7168710E-01,.7178858E-01,.7210934E-01,& - & .6471287E-01,.6460046E-01,.6473991E-01,.6511587E-01,.6570290E-01,& - & .5758865E-01,.5773359E-01,.5813143E-01,.5877105E-01,.5965013E-01,& - & .5098748E-01,.5136835E-01,.5201772E-01,.5291936E-01,.5405095E-01,& - & .4498346E-01,.4559189E-01,.4647453E-01,.4761481E-01,.4899661E-01,& - & .3962956E-01,.4044591E-01,.4154636E-01,.4290895E-01,.4451971E-01,& - & .3494623E-01,.3595631E-01,.3725553E-01,.3882539E-01,.4065371E-01,& - & .3090317E-01,.3209598E-01,.3356918E-01,.3532088E-01,.3734086E-01,& - & .2753735E-01,.2889680E-01,.3055328E-01,.3249469E-01,.3469930E-01,& - & .2472194E-01,.2624583E-01,.2807624E-01,.3018719E-01,.3256894E-01,& - & .2241246E-01,.2409593E-01,.2607770E-01,.2835897E-01,.3091024E-01,& - & .2056186E-01,.2238553E-01,.2452455E-01,.2695966E-01,.2967202E-01,& - & .1912250E-01,.2109409E-01,.2338231E-01,.2597361E-01,.2884315E-01,& - & .1803069E-01,.2014547E-01,.2257560E-01,.2531768E-01,.2833188E-01,& - & .1723757E-01,.1948465E-01,.2205955E-01,.2494239E-01,.2808185E-01,& - & .1671584E-01,.1909967E-01,.2181124E-01,.2481820E-01,.2807426E-01,& - & .1642188E-01,.1893762E-01,.2177522E-01,.2489493E-01,.2825602E-01,& - & .1633447E-01,.1897666E-01,.2192891E-01,.2515422E-01,.2861454E-01,& - & .1642117E-01,.1918126E-01,.2224051E-01,.2556670E-01,.2911713E-01,& - & .1665212E-01,.1952573E-01,.2268617E-01,.2610433E-01,.2973637E-01,& - & .1690445E-01,.1987409E-01,.2312114E-01,.2661658E-01,.3031656E-01,& - & .1697413E-01,.2000260E-01,.2330589E-01,.2685241E-01,.3059806E-01,& - & .1679058E-01,.1984390E-01,.2316985E-01,.2673928E-01,.3050650E-01/ - - data absb(121:235, 7) / & - & .1621314E-01,.1924283E-01,.2254989E-01,.2610500E-01,.2986511E-01,& - & .1565005E-01,.1865129E-01,.2193291E-01,.2546985E-01,.2921685E-01,& - & .1512354E-01,.1809306E-01,.2134739E-01,.2486405E-01,.2859408E-01,& - & .1434388E-01,.1724600E-01,.2044363E-01,.2391201E-01,.2760136E-01,& - & .1356639E-01,.1639374E-01,.1952578E-01,.2293718E-01,.2658026E-01,& - & .1282426E-01,.1557142E-01,.1863464E-01,.2198740E-01,.2557922E-01,& - & .1197741E-01,.1462053E-01,.1760067E-01,.2086625E-01,.2439863E-01,& - & .1111477E-01,.1364234E-01,.1651789E-01,.1969313E-01,.2315038E-01,& - & .1030179E-01,.1271031E-01,.1547643E-01,.1856508E-01,.2193139E-01,& - & .9491085E-02,.1177021E-01,.1441481E-01,.1739504E-01,.2066837E-01,& - & .8639429E-02,.1078206E-01,.1328441E-01,.1613831E-01,.1930011E-01,& - & .7839892E-02,.9857468E-02,.1221482E-01,.1493348E-01,.1797877E-01,& - & .7092072E-02,.8991607E-02,.1120568E-01,.1378380E-01,.1670474E-01,& - & .6432463E-02,.8224187E-02,.1031515E-01,.1275809E-01,.1555586E-01,& - & .5832717E-02,.7522561E-02,.9503860E-02,.1181296E-01,.1448506E-01,& - & .5280145E-02,.6862909E-02,.8736900E-02,.1091927E-01,.1346213E-01,& - & .4760950E-02,.6239258E-02,.8009269E-02,.1007450E-01,.1248495E-01,& - & .4319927E-02,.5706660E-02,.7378235E-02,.9343778E-02,.1163217E-01,& - & .3927425E-02,.5223469E-02,.6805075E-02,.8675949E-02,.1085346E-01,& - & .3566312E-02,.4771326E-02,.6260588E-02,.8040438E-02,.1011504E-01,& - & .3235298E-02,.4349610E-02,.5751274E-02,.7436457E-02,.9414970E-02,& - & .2948268E-02,.3977194E-02,.5291955E-02,.6891886E-02,.8780537E-02,& - & .2838304E-02,.3833360E-02,.5113920E-02,.6679829E-02,.8533277E-02/ - - data absb( 1:120, 8) / & - & .1589380E+01,.1590617E+01,.1588657E+01,.1583627E+01,.1576103E+01,& - & .1709558E+01,.1708607E+01,.1704305E+01,.1697075E+01,.1686632E+01,& - & .1824948E+01,.1821482E+01,.1814617E+01,.1804445E+01,.1791378E+01,& - & .1933407E+01,.1927272E+01,.1917585E+01,.1904625E+01,.1888292E+01,& - & .2032788E+01,.2024036E+01,.2011680E+01,.1995779E+01,.1976689E+01,& - & .2122514E+01,.2111187E+01,.2096103E+01,.2077495E+01,.2055661E+01,& - & .2201894E+01,.2188149E+01,.2170688E+01,.2149637E+01,.2125223E+01,& - & .2271095E+01,.2255113E+01,.2235383E+01,.2211893E+01,.2185029E+01,& - & .2330637E+01,.2312532E+01,.2290760E+01,.2265233E+01,.2236248E+01,& - & .2380235E+01,.2360023E+01,.2336137E+01,.2308453E+01,.2277303E+01,& - & .2421520E+01,.2399497E+01,.2373596E+01,.2343962E+01,.2310850E+01,& - & .2455548E+01,.2431616E+01,.2403985E+01,.2372410E+01,.2337341E+01,& - & .2483000E+01,.2457533E+01,.2427896E+01,.2394579E+01,.2357794E+01,& - & .2504497E+01,.2477271E+01,.2446062E+01,.2410900E+01,.2372279E+01,& - & .2521140E+01,.2492125E+01,.2459283E+01,.2422484E+01,.2382142E+01,& - & .2533448E+01,.2502926E+01,.2468416E+01,.2429941E+01,.2388304E+01,& - & .2541996E+01,.2509801E+01,.2473737E+01,.2433957E+01,.2391015E+01,& - & .2547277E+01,.2513671E+01,.2476134E+01,.2434937E+01,.2390872E+01,& - & .2549698E+01,.2514609E+01,.2475824E+01,.2433436E+01,.2388147E+01,& - & .2549776E+01,.2513277E+01,.2473300E+01,.2429667E+01,.2383220E+01,& - & .2547817E+01,.2510019E+01,.2468803E+01,.2424113E+01,.2376687E+01,& - & .2545438E+01,.2506563E+01,.2464177E+01,.2418709E+01,.2370529E+01,& - & .2545437E+01,.2505887E+01,.2462992E+01,.2416876E+01,.2368167E+01,& - & .2548620E+01,.2508763E+01,.2465654E+01,.2419269E+01,.2370306E+01/ - - data absb(121:235, 8) / & - & .2556882E+01,.2517384E+01,.2474533E+01,.2428347E+01,.2379571E+01,& - & .2564751E+01,.2525708E+01,.2483281E+01,.2437321E+01,.2388806E+01,& - & .2572195E+01,.2533600E+01,.2491357E+01,.2445820E+01,.2397529E+01,& - & .2582733E+01,.2544997E+01,.2503670E+01,.2458754E+01,.2411027E+01,& - & .2593208E+01,.2556450E+01,.2515941E+01,.2471723E+01,.2424698E+01,& - & .2603291E+01,.2567534E+01,.2527827E+01,.2484500E+01,.2438025E+01,& - & .2614485E+01,.2580122E+01,.2541480E+01,.2499317E+01,.2453682E+01,& - & .2626088E+01,.2593101E+01,.2555788E+01,.2514770E+01,.2470119E+01,& - & .2636975E+01,.2605452E+01,.2569448E+01,.2529581E+01,.2486026E+01,& - & .2647757E+01,.2617959E+01,.2583514E+01,.2544917E+01,.2502605E+01,& - & .2659180E+01,.2630964E+01,.2598269E+01,.2561345E+01,.2520508E+01,& - & .2669920E+01,.2643199E+01,.2612358E+01,.2577040E+01,.2537623E+01,& - & .2680036E+01,.2654848E+01,.2625604E+01,.2592088E+01,.2554283E+01,& - & .2688888E+01,.2664859E+01,.2637463E+01,.2605558E+01,.2569275E+01,& - & .2696948E+01,.2674379E+01,.2648210E+01,.2617842E+01,.2583127E+01,& - & .2704362E+01,.2683131E+01,.2658263E+01,.2629633E+01,.2596479E+01,& - & .2711382E+01,.2691630E+01,.2667973E+01,.2640779E+01,.2609393E+01,& - & .2717487E+01,.2698684E+01,.2676350E+01,.2650456E+01,.2620490E+01,& - & .2722676E+01,.2705192E+01,.2684099E+01,.2659244E+01,.2630640E+01,& - & .2727533E+01,.2711288E+01,.2691406E+01,.2667688E+01,.2640330E+01,& - & .2731955E+01,.2717083E+01,.2698177E+01,.2675744E+01,.2649670E+01,& - & .2735798E+01,.2722099E+01,.2704431E+01,.2682979E+01,.2657966E+01,& - & .2737188E+01,.2723903E+01,.2706774E+01,.2685895E+01,.2661240E+01/ - -! --- - - data forref(1:3,1: 8) / & - & .1062750E-05,.1041850E-05,.4201540E-05,.1543430E-05,.6531930E-05,& - & .1745960E-04,.3489170E-05,.1084200E-04,.5408490E-04,.1458220E-04,& - & .1560270E-04,.8812630E-04,.3256123E-04,.1001071E-03,.8710486E-04,& - & .1958190E-03,.1469074E-03,.7616317E-04,.2991387E-03,.1425125E-03,& - & .6636773E-04,.4406950E-03,.1586718E-03,.3817266E-04/ - -! the array selfref contains the coefficient of the water vapor -! self-continuum (including the energy term). the first index -! refers to temperature in 7.2 degree increments. for instance, -! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, -! etc. the second index runs over the g-channel (1 to 8). - - data selfref(1:10,1: 8) / & - & .3317280E-03,.2874800E-03,.2491350E-03,.2159040E-03,.1871060E-03,& - & .1621490E-03,.1405200E-03,.1217770E-03,.1055340E-03,.9145730E-04,& - & .8826280E-03,.6989140E-03,.5534390E-03,.4382440E-03,.3470260E-03,& - & .2747950E-03,.2175980E-03,.1723060E-03,.1364420E-03,.1080420E-03,& - & .1154610E-02,.9372030E-03,.7607300E-03,.6174860E-03,.5012150E-03,& - & .4068370E-03,.3302310E-03,.2680490E-03,.2175760E-03,.1766070E-03,& - & .1034500E-02,.9602680E-03,.8913600E-03,.8273970E-03,.7680240E-03,& - & .7129110E-03,.6617540E-03,.6142670E-03,.5701880E-03,.5292720E-03,& - & .3227190E-02,.2709139E-02,.2274479E-02,.1909745E-02,.1603665E-02,& - & .1346766E-02,.1131137E-02,.9501252E-03,.7981584E-03,.6705633E-03,& - & .3142835E-02,.3104435E-02,.3068990E-02,.3036443E-02,.3006728E-02,& - & .2979763E-02,.2955519E-02,.2933917E-02,.2914907E-02,.2898444E-02,& - & .2729233E-02,.2892026E-02,.3065501E-02,.3250452E-02,.3447726E-02,& - & .3658264E-02,.3883086E-02,.4123283E-02,.4380054E-02,.4654719E-02,& - & .2594476E-02,.2804964E-02,.3065165E-02,.3386332E-02,.3782724E-02,& - & .4272483E-02,.4878732E-02,.5631073E-02,.6567477E-02,.7736768E-02/ - -!........................................! - end module module_radsw_kgb19 ! -!========================================! - - -!========================================! - module module_radsw_kgb20 ! -!........................................! -! -! ********* the original program descriptions ********* ! -! ! -! originally by j.delamere, atmospheric & environmental research. ! -! revision: 2.4 ! -! band 20: 5150-6150 cm-1 (low - h2o; high - h2o) ! -! reformatted for f90 by jjmorcrette, ecmwf ! -! ! -! this table has been re-generated for reduced number of g-point ! -! by y.t.hou, ncep ! -! ! -! ********* ********* end description ********* ********* ! -! - use machine, only : kind_phys - use module_radsw_parameters, only : NG20 - -! - implicit none -! - private -! - integer, public :: MSA20, MSB20, MSF20, MFR20 - parameter (MSA20=65, MSB20=235, MSF20=10, MFR20=4) - - real (kind=kind_phys), public :: forref(MFR20,NG20), absch4(NG20),& - & absa(MSA20,NG20), absb(MSB20,NG20), selfref(MSF20,NG20) - -! --- rayleigh extinction coefficient at v = 5670 cm-1. - real (kind=kind_phys), parameter, public :: rayl = 4.12e-09 - -! the array absa(65,NG20) (ka(5,13,NG20)) contains absorption coefs at -! the 16 chosen g-values for a range of pressure levels> ~100mb, -! temperatures, and binary species parameters (see taumol.f for definition). -! the first index in the array, js, runs from 1 to 9, and corresponds to -! different values of the binary species parameter. for instance, -! js=1 refers to dry air, js = 2 corresponds to the paramter value 1/8, -! js = 3 corresponds to the parameter value 2/8, etc. the second index -! in the array, jt, which runs from 1 to 5, corresponds to different -! temperatures. more specifically, jt = 3 means that the data are for -! the reference temperature tref for this pressure level, jt = 2 refers -! to tref-15, jt = 1 is for tref-30, jt = 4 is for tref+15, and jt = 5 -! is for tref+30. the third index, jp, runs from 1 to 13 and refers -! to the jpth reference pressure level (see taumol.f for these levels -! in mb). the fourth index, ig, goes from 1 to 10, and indicates -! which g-interval the absorption coefficients are for. - data absa( 1: 65, 1) / & - & .7838300E-06,.8622000E-06,.9535900E-06,.1059000E-05,.1178200E-05,& - & .6504000E-06,.7251000E-06,.8131800E-06,.9005900E-06,.9978600E-06,& - & .5807200E-06,.6588800E-06,.7426500E-06,.8185400E-06,.9064500E-06,& - & .5360100E-06,.6076500E-06,.6808800E-06,.7574100E-06,.8380100E-06,& - & .5014200E-06,.5695100E-06,.6402800E-06,.7194400E-06,.7981300E-06,& - & .4716400E-06,.5400800E-06,.6104000E-06,.6800600E-06,.7503400E-06,& - & .4933700E-06,.5617800E-06,.6221500E-06,.6912700E-06,.7606000E-06,& - & .6158100E-06,.7011700E-06,.7894200E-06,.8714500E-06,.9464700E-06,& - & .1415400E-05,.1575400E-05,.1726100E-05,.1873900E-05,.1977400E-05,& - & .3418600E-05,.3701200E-05,.3960200E-05,.4223500E-05,.4425600E-05,& - & .3857400E-05,.4208000E-05,.4470100E-05,.4745400E-05,.5000200E-05,& - & .3579400E-05,.3868600E-05,.4144300E-05,.4393900E-05,.4650000E-05,& - & .2958600E-05,.3193800E-05,.3416700E-05,.3625300E-05,.3825000E-05/ - - data absa( 1: 65, 2) / & - & .5709800E-05,.6463000E-05,.7311700E-05,.8243600E-05,.9194700E-05,& - & .4638400E-05,.5312500E-05,.6030100E-05,.6802800E-05,.7582400E-05,& - & .4065700E-05,.4648600E-05,.5245900E-05,.5895500E-05,.6554600E-05,& - & .3889500E-05,.4425800E-05,.4975900E-05,.5566300E-05,.6170200E-05,& - & .3897100E-05,.4435900E-05,.4993300E-05,.5552300E-05,.6123400E-05,& - & .3953200E-05,.4464400E-05,.4973400E-05,.5487500E-05,.6010200E-05,& - & .4106800E-05,.4583200E-05,.5069800E-05,.5552100E-05,.6017500E-05,& - & .4792200E-05,.5215600E-05,.5681700E-05,.6157600E-05,.6631300E-05,& - & .8319900E-05,.8831700E-05,.9368800E-05,.9975400E-05,.1062000E-04,& - & .1683600E-04,.1852600E-04,.1988700E-04,.2116800E-04,.2210400E-04,& - & .1888200E-04,.2100500E-04,.2289600E-04,.2477700E-04,.2611500E-04,& - & .1774400E-04,.1978000E-04,.2160000E-04,.2352300E-04,.2512800E-04,& - & .1473600E-04,.1635600E-04,.1795500E-04,.1953300E-04,.2086100E-04/ - - data absa( 1: 65, 3) / & - & .4177600E-04,.4815000E-04,.5509700E-04,.6266100E-04,.7092000E-04,& - & .3390900E-04,.3917600E-04,.4462200E-04,.5075400E-04,.5733600E-04,& - & .2743800E-04,.3147300E-04,.3612200E-04,.4113400E-04,.4645600E-04,& - & .2322200E-04,.2653500E-04,.3014100E-04,.3409900E-04,.3841600E-04,& - & .2111400E-04,.2388800E-04,.2688300E-04,.3034000E-04,.3378500E-04,& - & .2075000E-04,.2292600E-04,.2553600E-04,.2849200E-04,.3167600E-04,& - & .2158400E-04,.2411200E-04,.2687200E-04,.2979400E-04,.3294000E-04,& - & .2419400E-04,.2698100E-04,.3013700E-04,.3354600E-04,.3718200E-04,& - & .3746100E-04,.4215800E-04,.4671800E-04,.5104800E-04,.5515400E-04,& - & .7239100E-04,.7716400E-04,.8401600E-04,.8965800E-04,.9551100E-04,& - & .9173600E-04,.9910700E-04,.1046300E-03,.1095200E-03,.1154900E-03,& - & .9120000E-04,.9881200E-04,.1043200E-03,.1089300E-03,.1134900E-03,& - & .7621700E-04,.8270200E-04,.8750000E-04,.9134900E-04,.9534900E-04/ - - data absa( 1: 65, 4) / & - & .7170500E-03,.8274300E-03,.9470000E-03,.1067000E-02,.1190200E-02,& - & .5790900E-03,.6709600E-03,.7672400E-03,.8658200E-03,.9716700E-03,& - & .4477100E-03,.5199700E-03,.5986100E-03,.6796700E-03,.7667600E-03,& - & .3408500E-03,.3983300E-03,.4622600E-03,.5288900E-03,.6000800E-03,& - & .2667800E-03,.3123400E-03,.3634100E-03,.4166300E-03,.4741800E-03,& - & .2090300E-03,.2471800E-03,.2892200E-03,.3335300E-03,.3817600E-03,& - & .1717300E-03,.2033000E-03,.2371100E-03,.2740100E-03,.3144500E-03,& - & .1672200E-03,.1939600E-03,.2230700E-03,.2534700E-03,.2856100E-03,& - & .2504300E-03,.2882400E-03,.3254700E-03,.3619300E-03,.3980600E-03,& - & .4332300E-03,.4866700E-03,.5346200E-03,.5787900E-03,.6204000E-03,& - & .4771900E-03,.5227100E-03,.5640200E-03,.6038800E-03,.6352000E-03,& - & .4506100E-03,.4901400E-03,.5239100E-03,.5527600E-03,.5776000E-03,& - & .3766400E-03,.4095200E-03,.4369000E-03,.4605500E-03,.4801800E-03/ - - data absa( 1: 65, 5) / & - & .6646600E-02,.6868600E-02,.7089700E-02,.7301900E-02,.7491400E-02,& - & .5402300E-02,.5601000E-02,.5800800E-02,.5998700E-02,.6168500E-02,& - & .4321800E-02,.4512700E-02,.4684800E-02,.4864700E-02,.5026700E-02,& - & .3463900E-02,.3647300E-02,.3795100E-02,.3957000E-02,.4104900E-02,& - & .2774500E-02,.2937000E-02,.3075400E-02,.3214800E-02,.3349200E-02,& - & .2202000E-02,.2352000E-02,.2483600E-02,.2596500E-02,.2711900E-02,& - & .1762400E-02,.1896300E-02,.2016100E-02,.2115300E-02,.2211600E-02,& - & .1416900E-02,.1533200E-02,.1635000E-02,.1723100E-02,.1812100E-02,& - & .1303000E-02,.1390400E-02,.1469000E-02,.1550000E-02,.1627500E-02,& - & .1715500E-02,.1816900E-02,.1894300E-02,.1962000E-02,.2021500E-02,& - & .1715600E-02,.1780800E-02,.1841900E-02,.1892500E-02,.1931300E-02,& - & .1526900E-02,.1581100E-02,.1628300E-02,.1668600E-02,.1706100E-02,& - & .1276800E-02,.1320700E-02,.1355500E-02,.1392400E-02,.1423400E-02/ - - data absa( 1: 65, 6) / & - & .1919100E-01,.1946300E-01,.1969200E-01,.1990000E-01,.2011200E-01,& - & .1596700E-01,.1621900E-01,.1642600E-01,.1661300E-01,.1680500E-01,& - & .1318600E-01,.1341100E-01,.1361400E-01,.1378500E-01,.1394400E-01,& - & .1093500E-01,.1113100E-01,.1131800E-01,.1147500E-01,.1162000E-01,& - & .9054100E-02,.9234400E-02,.9403500E-02,.9553700E-02,.9686200E-02,& - & .7472400E-02,.7632000E-02,.7779400E-02,.7929400E-02,.8052800E-02,& - & .6118300E-02,.6264400E-02,.6396100E-02,.6530300E-02,.6647800E-02,& - & .5063800E-02,.5198400E-02,.5322200E-02,.5441200E-02,.5546500E-02,& - & .4287000E-02,.4400900E-02,.4510900E-02,.4597600E-02,.4679600E-02,& - & .4523900E-02,.4607300E-02,.4696800E-02,.4797900E-02,.4895600E-02,& - & .4408900E-02,.4500600E-02,.4588100E-02,.4672100E-02,.4801500E-02,& - & .3959800E-02,.4029000E-02,.4110800E-02,.4189900E-02,.4267200E-02,& - & .3342500E-02,.3414800E-02,.3480800E-02,.3540500E-02,.3598300E-02/ - - data absa( 1: 65, 7) / & - & .5016500E-01,.5034300E-01,.5045200E-01,.5042400E-01,.5032900E-01,& - & .4272300E-01,.4288000E-01,.4293900E-01,.4291000E-01,.4286100E-01,& - & .3611700E-01,.3625500E-01,.3630100E-01,.3629400E-01,.3628800E-01,& - & .3058500E-01,.3072000E-01,.3078700E-01,.3081600E-01,.3084200E-01,& - & .2587900E-01,.2602900E-01,.2611600E-01,.2617900E-01,.2622500E-01,& - & .2182200E-01,.2197800E-01,.2209400E-01,.2217800E-01,.2224400E-01,& - & .1830400E-01,.1847600E-01,.1860600E-01,.1870500E-01,.1878000E-01,& - & .1522400E-01,.1539400E-01,.1551900E-01,.1561900E-01,.1569000E-01,& - & .1283500E-01,.1302900E-01,.1316900E-01,.1328100E-01,.1336900E-01,& - & .1163200E-01,.1171400E-01,.1176000E-01,.1177600E-01,.1180600E-01,& - & .1117000E-01,.1125200E-01,.1128800E-01,.1135700E-01,.1139700E-01,& - & .1040400E-01,.1053300E-01,.1070500E-01,.1083300E-01,.1094700E-01,& - & .9104100E-02,.9267400E-02,.9406800E-02,.9541200E-02,.9676900E-02/ - - data absa( 1: 65, 8) / & - & .1452700E+00,.1448300E+00,.1443200E+00,.1438900E+00,.1434900E+00,& - & .1273900E+00,.1270200E+00,.1266100E+00,.1262400E+00,.1258400E+00,& - & .1109100E+00,.1105800E+00,.1102400E+00,.1099000E+00,.1095300E+00,& - & .9659000E-01,.9633500E-01,.9610500E-01,.9581800E-01,.9553000E-01,& - & .8379900E-01,.8370800E-01,.8357200E-01,.8334700E-01,.8312600E-01,& - & .7236900E-01,.7238800E-01,.7228900E-01,.7214300E-01,.7198100E-01,& - & .6215800E-01,.6224700E-01,.6218500E-01,.6211100E-01,.6200700E-01,& - & .5299800E-01,.5314200E-01,.5316200E-01,.5315400E-01,.5310100E-01,& - & .4477600E-01,.4487300E-01,.4492000E-01,.4494600E-01,.4488500E-01,& - & .3823700E-01,.3851400E-01,.3871600E-01,.3887700E-01,.3896600E-01,& - & .3351100E-01,.3372100E-01,.3384300E-01,.3384000E-01,.3383900E-01,& - & .2970400E-01,.2982500E-01,.2980800E-01,.2978700E-01,.2979400E-01,& - & .2597300E-01,.2600400E-01,.2603200E-01,.2602300E-01,.2610700E-01/ - - data absa( 1: 65, 9) / & - & .6574795E+00,.6554552E+00,.6533155E+00,.6509209E+00,.6484065E+00,& - & .6255494E+00,.6246438E+00,.6232566E+00,.6216554E+00,.6197426E+00,& - & .5862362E+00,.5862909E+00,.5857885E+00,.5847743E+00,.5835312E+00,& - & .5431781E+00,.5440621E+00,.5441314E+00,.5437951E+00,.5431448E+00,& - & .4982859E+00,.4996650E+00,.5003975E+00,.5006596E+00,.5007368E+00,& - & .4522079E+00,.4542740E+00,.4556478E+00,.4567195E+00,.4575025E+00,& - & .4066660E+00,.4093121E+00,.4113888E+00,.4131704E+00,.4142502E+00,& - & .3626680E+00,.3658157E+00,.3685601E+00,.3707145E+00,.3720343E+00,& - & .3201627E+00,.3237696E+00,.3268366E+00,.3290751E+00,.3306950E+00,& - & .2769076E+00,.2802971E+00,.2831727E+00,.2851341E+00,.2866169E+00,& - & .2450947E+00,.2482141E+00,.2507025E+00,.2525044E+00,.2537402E+00,& - & .2182159E+00,.2209177E+00,.2229032E+00,.2242398E+00,.2253965E+00,& - & .1913957E+00,.1940531E+00,.1961425E+00,.1981273E+00,.1993420E+00/ - - data absa( 1: 65,10) / & - & .3268900E+01,.3251984E+01,.3235834E+01,.3221079E+01,.3207393E+01,& - & .3622351E+01,.3601154E+01,.3582181E+01,.3564354E+01,.3547975E+01,& - & .3989098E+01,.3964764E+01,.3942540E+01,.3922453E+01,.3903201E+01,& - & .4343054E+01,.4315865E+01,.4291453E+01,.4268631E+01,.4246808E+01,& - & .4682358E+01,.4653365E+01,.4626500E+01,.4601251E+01,.4576531E+01,& - & .5008731E+01,.4977636E+01,.4948849E+01,.4920625E+01,.4892993E+01,& - & .5317015E+01,.5284091E+01,.5253355E+01,.5222597E+01,.5194092E+01,& - & .5603209E+01,.5569632E+01,.5536865E+01,.5505362E+01,.5476476E+01,& - & .5865108E+01,.5831464E+01,.5798284E+01,.5767336E+01,.5737919E+01,& - & .6093085E+01,.6061308E+01,.6030013E+01,.6000723E+01,.5972079E+01,& - & .6260183E+01,.6230003E+01,.6201202E+01,.6173485E+01,.6146273E+01,& - & .6409424E+01,.6381513E+01,.6354613E+01,.6328684E+01,.6301983E+01,& - & .6564707E+01,.6537322E+01,.6510214E+01,.6481775E+01,.6454592E+01/ - -! the array absb(235,10) (kb(5,13:59,10)) contains absorption coefs at -! the 16 chosen g-values for a range of pressure levels < ~100mb and -! temperatures. the first index in the array, jt, which runs from 1 to 5, -! corresponds to different temperatures. more specifically, jt = 3 means -! that the data are for the reference temperature tref for this pressure -! level, jt = 2 refers to the temperature tref-15, jt = 1 is for -! tref-30, jt = 4 is for tref+15, and jt = 5 is for tref+30. -! the second index, jp, runs from 13 to 59 and refers to the jpth -! reference pressure level (see taumol.f for the value of these -! pressure levels in mb). the third index, ig, goes from 1 to 10, -! and tells us which g-interval the absorption coefficients are for. - - data absb( 1:120, 1) / & - & .2959700E-05,.3192900E-05,.3415900E-05,.3625600E-05,.3826400E-05,& - & .2423300E-05,.2615100E-05,.2786600E-05,.2950200E-05,.3117000E-05,& - & .1920600E-05,.2078900E-05,.2209900E-05,.2338300E-05,.2450500E-05,& - & .1493300E-05,.1607100E-05,.1703900E-05,.1799400E-05,.1881600E-05,& - & .1142900E-05,.1214400E-05,.1289500E-05,.1350300E-05,.1417400E-05,& - & .8413400E-06,.8926400E-06,.9426000E-06,.9900300E-06,.1039100E-05,& - & .6068300E-06,.6414200E-06,.6801800E-06,.7204200E-06,.7547900E-06,& - & .4580900E-06,.4881300E-06,.5193400E-06,.5482300E-06,.5726100E-06,& - & .3521900E-06,.3783500E-06,.4032200E-06,.4277200E-06,.4473600E-06,& - & .2741900E-06,.2954200E-06,.3161700E-06,.3339800E-06,.3493200E-06,& - & .2138500E-06,.2312700E-06,.2467000E-06,.2595100E-06,.2695200E-06,& - & .1676700E-06,.1817900E-06,.1928200E-06,.2013600E-06,.2111300E-06,& - & .1336100E-06,.1430100E-06,.1498000E-06,.1577800E-06,.1661500E-06,& - & .1061500E-06,.1121800E-06,.1188900E-06,.1257400E-06,.1311100E-06,& - & .8366000E-07,.8929600E-07,.9501900E-07,.1000700E-06,.1039700E-06,& - & .6666700E-07,.7121700E-07,.7561500E-07,.7923700E-07,.8223900E-07,& - & .5277600E-07,.5608600E-07,.5982800E-07,.6251300E-07,.6421800E-07,& - & .4142900E-07,.4437000E-07,.4673100E-07,.4855300E-07,.5014300E-07,& - & .3243700E-07,.3452300E-07,.3620800E-07,.3750000E-07,.3857100E-07,& - & .2523700E-07,.2673000E-07,.2786800E-07,.2882900E-07,.2994300E-07,& - & .1954500E-07,.2061400E-07,.2146700E-07,.2228000E-07,.2314100E-07,& - & .1514600E-07,.1586900E-07,.1650900E-07,.1717900E-07,.1798000E-07,& - & .1148200E-07,.1203900E-07,.1254700E-07,.1325500E-07,.1387400E-07,& - & .8617200E-08,.9002300E-08,.9560700E-08,.1010600E-07,.1059500E-07/ - - data absb(121:235, 1) / & - & .6741100E-08,.7078100E-08,.7555300E-08,.7973900E-08,.8401100E-08,& - & .5260400E-08,.5574300E-08,.5941000E-08,.6303100E-08,.6651600E-08,& - & .4112900E-08,.4385400E-08,.4685100E-08,.4977100E-08,.5246300E-08,& - & .3308900E-08,.3528900E-08,.3770200E-08,.4012500E-08,.4241500E-08,& - & .2679400E-08,.2848800E-08,.3042800E-08,.3243700E-08,.3442000E-08,& - & .2167000E-08,.2303000E-08,.2458900E-08,.2625200E-08,.2786700E-08,& - & .1769900E-08,.1885300E-08,.2000100E-08,.2133000E-08,.2265700E-08,& - & .1444600E-08,.1547100E-08,.1639700E-08,.1742300E-08,.1852600E-08,& - & .1173400E-08,.1275400E-08,.1354200E-08,.1424200E-08,.1519300E-08,& - & .9574300E-09,.1047000E-08,.1118300E-08,.1172600E-08,.1238900E-08,& - & .7734500E-09,.8519700E-09,.9218400E-09,.9736800E-09,.1014900E-08,& - & .6250000E-09,.6928800E-09,.7554800E-09,.8044600E-09,.8442800E-09,& - & .5009500E-09,.5596700E-09,.6190400E-09,.6644100E-09,.7033900E-09,& - & .4080600E-09,.4571200E-09,.5053000E-09,.5497400E-09,.5824600E-09,& - & .3310200E-09,.3713000E-09,.4112100E-09,.4502400E-09,.4843600E-09,& - & .2690600E-09,.3073900E-09,.3384500E-09,.3688400E-09,.4002400E-09,& - & .2220200E-09,.2510800E-09,.2793700E-09,.3059200E-09,.3301200E-09,& - & .1866200E-09,.2076100E-09,.2307200E-09,.2534200E-09,.2744500E-09,& - & .1574100E-09,.1714700E-09,.1914600E-09,.2102900E-09,.2285700E-09,& - & .1315100E-09,.1463700E-09,.1597700E-09,.1754700E-09,.1897400E-09,& - & .1087400E-09,.1244700E-09,.1363400E-09,.1475200E-09,.1602200E-09,& - & .9020600E-10,.1048400E-09,.1161700E-09,.1254500E-09,.1347400E-09,& - & .7675900E-10,.8886600E-10,.9934000E-10,.1070600E-09,.1144400E-09/ - - data absb( 1:120, 2) / & - & .1472700E-04,.1635700E-04,.1796100E-04,.1953000E-04,.2085200E-04,& - & .1214800E-04,.1347800E-04,.1481800E-04,.1604900E-04,.1710000E-04,& - & .9690200E-05,.1078700E-04,.1183500E-04,.1277000E-04,.1351500E-04,& - & .7623500E-05,.8457500E-05,.9221700E-05,.9852600E-05,.1044900E-04,& - & .5804900E-05,.6423900E-05,.6973300E-05,.7413100E-05,.7808200E-05,& - & .4320400E-05,.4751000E-05,.5116500E-05,.5457900E-05,.5743400E-05,& - & .3221100E-05,.3532700E-05,.3817500E-05,.4053500E-05,.4224500E-05,& - & .2526500E-05,.2765200E-05,.2964400E-05,.3133100E-05,.3273000E-05,& - & .1992100E-05,.2174900E-05,.2334300E-05,.2437700E-05,.2545800E-05,& - & .1585900E-05,.1725900E-05,.1823600E-05,.1912400E-05,.1994200E-05,& - & .1259100E-05,.1356500E-05,.1430900E-05,.1503200E-05,.1564200E-05,& - & .1001200E-05,.1070100E-05,.1124600E-05,.1181900E-05,.1227900E-05,& - & .7898500E-06,.8407400E-06,.8902900E-06,.9314500E-06,.9708500E-06,& - & .6299600E-06,.6684700E-06,.7063700E-06,.7351300E-06,.7713500E-06,& - & .5028300E-06,.5311100E-06,.5565300E-06,.5830600E-06,.6179900E-06,& - & .3996200E-06,.4232000E-06,.4426500E-06,.4671500E-06,.4951600E-06,& - & .3181000E-06,.3359700E-06,.3519100E-06,.3744800E-06,.3976800E-06,& - & .2524200E-06,.2644700E-06,.2810900E-06,.3008900E-06,.3154300E-06,& - & .1983700E-06,.2095400E-06,.2244200E-06,.2376200E-06,.2518300E-06,& - & .1559900E-06,.1670100E-06,.1778900E-06,.1888000E-06,.2003000E-06,& - & .1230700E-06,.1321100E-06,.1404600E-06,.1511100E-06,.1598800E-06,& - & .9842900E-07,.1049800E-06,.1132600E-06,.1207400E-06,.1277900E-06,& - & .7774300E-07,.8395100E-07,.9047300E-07,.9627700E-07,.1020400E-06,& - & .6122000E-07,.6639900E-07,.7110200E-07,.7594600E-07,.8080300E-07/ - - data absb(121:235, 2) / & - & .4881900E-07,.5296200E-07,.5666900E-07,.6081700E-07,.6470900E-07,& - & .3887100E-07,.4222600E-07,.4537600E-07,.4864100E-07,.5185500E-07,& - & .3086900E-07,.3348500E-07,.3623300E-07,.3886800E-07,.4152300E-07,& - & .2479800E-07,.2698300E-07,.2918000E-07,.3143700E-07,.3360000E-07,& - & .1995100E-07,.2178400E-07,.2351800E-07,.2546000E-07,.2721900E-07,& - & .1609800E-07,.1754200E-07,.1897900E-07,.2054700E-07,.2201600E-07,& - & .1302000E-07,.1414400E-07,.1541400E-07,.1661000E-07,.1787000E-07,& - & .1054800E-07,.1150000E-07,.1249200E-07,.1352000E-07,.1452400E-07,& - & .8560200E-08,.9324500E-08,.1009600E-07,.1097800E-07,.1181900E-07,& - & .6914900E-08,.7565300E-08,.8215400E-08,.8882200E-08,.9600200E-08,& - & .5570800E-08,.6116400E-08,.6667800E-08,.7192200E-08,.7763300E-08,& - & .4480400E-08,.4931200E-08,.5396700E-08,.5866200E-08,.6278000E-08,& - & .3646700E-08,.3986600E-08,.4362800E-08,.4758900E-08,.5120800E-08,& - & .2952400E-08,.3254000E-08,.3547100E-08,.3863800E-08,.4188700E-08,& - & .2388700E-08,.2652600E-08,.2895900E-08,.3150400E-08,.3411200E-08,& - & .1932100E-08,.2164800E-08,.2362500E-08,.2583900E-08,.2817300E-08,& - & .1568400E-08,.1772500E-08,.1947600E-08,.2124000E-08,.2311800E-08,& - & .1279900E-08,.1446700E-08,.1607300E-08,.1749400E-08,.1916000E-08,& - & .1044200E-08,.1191100E-08,.1321600E-08,.1453700E-08,.1577100E-08,& - & .8574100E-09,.9793700E-09,.1093600E-08,.1205600E-08,.1316700E-08,& - & .7035800E-09,.8033400E-09,.9082400E-09,.1005600E-08,.1101000E-08,& - & .5742800E-09,.6644100E-09,.7542000E-09,.8362700E-09,.9248500E-09,& - & .4792200E-09,.5559200E-09,.6349900E-09,.7073100E-09,.7867800E-09/ - - data absb( 1:120, 3) / & - & .7620100E-04,.8269900E-04,.8749900E-04,.9135200E-04,.9534800E-04,& - & .6282100E-04,.6786100E-04,.7186800E-04,.7510800E-04,.7855700E-04,& - & .4977500E-04,.5336700E-04,.5663900E-04,.5900100E-04,.6230300E-04,& - & .3800500E-04,.4088300E-04,.4326900E-04,.4540300E-04,.4813900E-04,& - & .2855000E-04,.3075000E-04,.3233100E-04,.3448900E-04,.3668700E-04,& - & .2097600E-04,.2232200E-04,.2374300E-04,.2555400E-04,.2722300E-04,& - & .1538900E-04,.1642200E-04,.1779200E-04,.1912700E-04,.2029500E-04,& - & .1188300E-04,.1281600E-04,.1396200E-04,.1487200E-04,.1572500E-04,& - & .9294800E-05,.1018700E-04,.1098600E-04,.1171300E-04,.1242600E-04,& - & .7396900E-05,.8084000E-05,.8726300E-05,.9385600E-05,.9953300E-05,& - & .5896100E-05,.6459100E-05,.6964800E-05,.7449400E-05,.7938500E-05,& - & .4744500E-05,.5174200E-05,.5603600E-05,.5975800E-05,.6372400E-05,& - & .3844200E-05,.4179100E-05,.4483700E-05,.4807800E-05,.5129400E-05,& - & .3133500E-05,.3392300E-05,.3640000E-05,.3896100E-05,.4148700E-05,& - & .2549900E-05,.2743200E-05,.2956000E-05,.3154500E-05,.3343300E-05,& - & .2063500E-05,.2223100E-05,.2389700E-05,.2551600E-05,.2693800E-05,& - & .1663500E-05,.1802400E-05,.1927900E-05,.2049800E-05,.2162700E-05,& - & .1335900E-05,.1447400E-05,.1547000E-05,.1634600E-05,.1745700E-05,& - & .1069700E-05,.1147700E-05,.1225400E-05,.1309700E-05,.1391400E-05,& - & .8495800E-06,.9146400E-06,.9818900E-06,.1048900E-05,.1115000E-05,& - & .6817800E-06,.7335600E-06,.7890500E-06,.8422600E-06,.8947600E-06,& - & .5473700E-06,.5899500E-06,.6337400E-06,.6773200E-06,.7218200E-06,& - & .4368000E-06,.4708600E-06,.5077100E-06,.5420900E-06,.5768700E-06,& - & .3461200E-06,.3746600E-06,.4037000E-06,.4307300E-06,.4597900E-06/ - - data absb(121:235, 3) / & - & .2772500E-06,.3004800E-06,.3245100E-06,.3463800E-06,.3710500E-06,& - & .2222800E-06,.2411400E-06,.2604900E-06,.2787100E-06,.2993500E-06,& - & .1779700E-06,.1931700E-06,.2087800E-06,.2241100E-06,.2410200E-06,& - & .1434600E-06,.1560100E-06,.1691300E-06,.1819700E-06,.1956600E-06,& - & .1155900E-06,.1261500E-06,.1369700E-06,.1478500E-06,.1587400E-06,& - & .9335800E-07,.1021400E-06,.1108900E-06,.1199800E-06,.1290400E-06,& - & .7559900E-07,.8269000E-07,.8980800E-07,.9752400E-07,.1051100E-06,& - & .6128500E-07,.6678600E-07,.7293700E-07,.7908700E-07,.8552500E-07,& - & .4972500E-07,.5429400E-07,.5926300E-07,.6421300E-07,.6958300E-07,& - & .4033600E-07,.4418600E-07,.4803400E-07,.5218400E-07,.5653400E-07,& - & .3290400E-07,.3563300E-07,.3895900E-07,.4240200E-07,.4588300E-07,& - & .2672500E-07,.2910400E-07,.3169300E-07,.3431200E-07,.3730400E-07,& - & .2175100E-07,.2384900E-07,.2580300E-07,.2802400E-07,.3035600E-07,& - & .1758700E-07,.1960900E-07,.2121600E-07,.2302200E-07,.2494200E-07,& - & .1437600E-07,.1599000E-07,.1749300E-07,.1887200E-07,.2046300E-07,& - & .1181100E-07,.1310600E-07,.1448900E-07,.1561500E-07,.1683200E-07,& - & .9600100E-08,.1078800E-07,.1192100E-07,.1298500E-07,.1390400E-07,& - & .7824300E-08,.8917800E-08,.9843000E-08,.1084000E-07,.1161900E-07,& - & .6363800E-08,.7367800E-08,.8221400E-08,.8999700E-08,.9756500E-08,& - & .5175300E-08,.6049700E-08,.6841900E-08,.7456000E-08,.8236200E-08,& - & .4216400E-08,.4991600E-08,.5706600E-08,.6330800E-08,.6895000E-08,& - & .3461800E-08,.4142400E-08,.4805400E-08,.5375700E-08,.5809500E-08,& - & .2908300E-08,.3529100E-08,.4093200E-08,.4628500E-08,.4986500E-08/ - - data absb( 1:120, 4) / & - & .3767400E-03,.4095300E-03,.4369000E-03,.4605900E-03,.4800700E-03,& - & .3120200E-03,.3390600E-03,.3606600E-03,.3800300E-03,.3962700E-03,& - & .2513500E-03,.2727100E-03,.2906900E-03,.3066100E-03,.3200500E-03,& - & .1979700E-03,.2152700E-03,.2295500E-03,.2432800E-03,.2545600E-03,& - & .1535400E-03,.1667900E-03,.1793300E-03,.1910100E-03,.2004100E-03,& - & .1174200E-03,.1279700E-03,.1392300E-03,.1483600E-03,.1565400E-03,& - & .9051900E-04,.9938600E-04,.1081900E-03,.1160100E-03,.1231900E-03,& - & .7257900E-04,.7991000E-04,.8707500E-04,.9372800E-04,.9965600E-04,& - & .5886600E-04,.6480500E-04,.7070500E-04,.7615300E-04,.8099600E-04,& - & .4815700E-04,.5288300E-04,.5774000E-04,.6213000E-04,.6610000E-04,& - & .3933700E-04,.4328900E-04,.4727500E-04,.5090600E-04,.5416100E-04,& - & .3228900E-04,.3557700E-04,.3880800E-04,.4181400E-04,.4443300E-04,& - & .2661500E-04,.2930100E-04,.3198400E-04,.3439600E-04,.3650900E-04,& - & .2206000E-04,.2427000E-04,.2646000E-04,.2845000E-04,.3020300E-04,& - & .1834400E-04,.2017700E-04,.2194800E-04,.2359500E-04,.2500100E-04,& - & .1525600E-04,.1678700E-04,.1824200E-04,.1956100E-04,.2069600E-04,& - & .1267900E-04,.1395200E-04,.1517000E-04,.1621100E-04,.1716300E-04,& - & .1055000E-04,.1160500E-04,.1257900E-04,.1345100E-04,.1421000E-04,& - & .8751200E-05,.9632200E-05,.1043300E-04,.1113300E-04,.1176200E-04,& - & .7300100E-05,.8020300E-05,.8674500E-05,.9229200E-05,.9729500E-05,& - & .6095800E-05,.6686200E-05,.7200600E-05,.7635900E-05,.8057600E-05,& - & .5085500E-05,.5567100E-05,.5967000E-05,.6339200E-05,.6686900E-05,& - & .4203300E-05,.4590500E-05,.4925000E-05,.5238400E-05,.5536900E-05,& - & .3438400E-05,.3761800E-05,.4043000E-05,.4306000E-05,.4557700E-05/ - - data absb(121:235, 4) / & - & .2803900E-05,.3074900E-05,.3313500E-05,.3534400E-05,.3745800E-05,& - & .2284200E-05,.2510400E-05,.2712600E-05,.2896600E-05,.3076800E-05,& - & .1858500E-05,.2051000E-05,.2219400E-05,.2373100E-05,.2524900E-05,& - & .1504100E-05,.1667600E-05,.1809700E-05,.1940200E-05,.2068100E-05,& - & .1215400E-05,.1354100E-05,.1474900E-05,.1585200E-05,.1693400E-05,& - & .9803300E-06,.1097500E-05,.1201100E-05,.1294500E-05,.1385900E-05,& - & .7872400E-06,.8862500E-06,.9748600E-06,.1055400E-05,.1130700E-05,& - & .6305900E-06,.7138200E-06,.7894800E-06,.8575500E-06,.9204400E-06,& - & .5042600E-06,.5739100E-06,.6380800E-06,.6971800E-06,.7497200E-06,& - & .4013300E-06,.4585800E-06,.5141400E-06,.5640000E-06,.6096400E-06,& - & .3158000E-06,.3644000E-06,.4112000E-06,.4543300E-06,.4934800E-06,& - & .2484700E-06,.2890700E-06,.3287900E-06,.3653700E-06,.3990300E-06,& - & .1953000E-06,.2285800E-06,.2624700E-06,.2933100E-06,.3221700E-06,& - & .1536400E-06,.1811300E-06,.2091100E-06,.2358900E-06,.2599400E-06,& - & .1207200E-06,.1441300E-06,.1665600E-06,.1895200E-06,.2098300E-06,& - & .9492500E-07,.1139700E-06,.1325500E-06,.1519300E-06,.1696000E-06,& - & .7447300E-07,.9019700E-07,.1057400E-06,.1215300E-06,.1366100E-06,& - & .5900900E-07,.7159400E-07,.8478100E-07,.9775800E-07,.1101800E-06,& - & .4700800E-07,.5699700E-07,.6783800E-07,.7875300E-07,.8911600E-07,& - & .3741500E-07,.4564200E-07,.5442000E-07,.6346600E-07,.7191000E-07,& - & .2989600E-07,.3663500E-07,.4369700E-07,.5103600E-07,.5826700E-07,& - & .2394600E-07,.2952300E-07,.3531600E-07,.4118300E-07,.4739100E-07,& - & .1988100E-07,.2464200E-07,.2939000E-07,.3409900E-07,.3923400E-07/ - - data absb( 1:120, 5) / & - & .1277100E-02,.1320200E-02,.1355700E-02,.1392700E-02,.1423300E-02,& - & .1060800E-02,.1095100E-02,.1124900E-02,.1154900E-02,.1178800E-02,& - & .8675000E-03,.8967900E-03,.9198600E-03,.9439900E-03,.9640500E-03,& - & .7007300E-03,.7250400E-03,.7463000E-03,.7649500E-03,.7816500E-03,& - & .5628000E-03,.5832100E-03,.6015300E-03,.6154400E-03,.6288500E-03,& - & .4494000E-03,.4659800E-03,.4788700E-03,.4905800E-03,.5022300E-03,& - & .3575300E-03,.3706400E-03,.3829000E-03,.3939000E-03,.4038700E-03,& - & .2901300E-03,.3009900E-03,.3117900E-03,.3211700E-03,.3301100E-03,& - & .2365700E-03,.2460200E-03,.2550400E-03,.2634000E-03,.2714500E-03,& - & .1942300E-03,.2022400E-03,.2098700E-03,.2171100E-03,.2243900E-03,& - & .1596300E-03,.1664300E-03,.1730800E-03,.1794900E-03,.1858000E-03,& - & .1316600E-03,.1374500E-03,.1433200E-03,.1487100E-03,.1542800E-03,& - & .1088500E-03,.1139400E-03,.1189600E-03,.1237100E-03,.1284600E-03,& - & .9040300E-04,.9491400E-04,.9915700E-04,.1031000E-03,.1072900E-03,& - & .7526500E-04,.7916600E-04,.8264800E-04,.8620900E-04,.8988200E-04,& - & .6287000E-04,.6605000E-04,.6911100E-04,.7228900E-04,.7545100E-04,& - & .5246500E-04,.5519200E-04,.5788700E-04,.6066000E-04,.6336700E-04,& - & .4388700E-04,.4619100E-04,.4858800E-04,.5091000E-04,.5327800E-04,& - & .3676000E-04,.3876600E-04,.4078300E-04,.4278300E-04,.4478000E-04,& - & .3083100E-04,.3256100E-04,.3426700E-04,.3600000E-04,.3759400E-04,& - & .2590800E-04,.2738900E-04,.2883200E-04,.3029000E-04,.3158100E-04,& - & .2177600E-04,.2302600E-04,.2426600E-04,.2544400E-04,.2651000E-04,& - & .1823300E-04,.1928000E-04,.2032400E-04,.2126600E-04,.2214100E-04,& - & .1516000E-04,.1604200E-04,.1691800E-04,.1768600E-04,.1840600E-04/ - - data absb(121:235, 5) / & - & .1253800E-04,.1328500E-04,.1401500E-04,.1465700E-04,.1526900E-04,& - & .1035700E-04,.1099000E-04,.1159500E-04,.1214800E-04,.1265100E-04,& - & .8556600E-05,.9085600E-05,.9598600E-05,.1005700E-04,.1047800E-04,& - & .7039000E-05,.7482600E-05,.7920000E-05,.8306100E-05,.8663400E-05,& - & .5782700E-05,.6157200E-05,.6526900E-05,.6852800E-05,.7159500E-05,& - & .4747700E-05,.5065600E-05,.5370500E-05,.5648600E-05,.5910000E-05,& - & .3880200E-05,.4153300E-05,.4408900E-05,.4651500E-05,.4871900E-05,& - & .3165800E-05,.3397100E-05,.3617700E-05,.3820500E-05,.4008900E-05,& - & .2579600E-05,.2774000E-05,.2963500E-05,.3133600E-05,.3298600E-05,& - & .2094500E-05,.2263600E-05,.2421400E-05,.2569800E-05,.2707700E-05,& - & .1693100E-05,.1838300E-05,.1972900E-05,.2099600E-05,.2217200E-05,& - & .1365000E-05,.1488900E-05,.1604300E-05,.1713900E-05,.1813600E-05,& - & .1098100E-05,.1204200E-05,.1302800E-05,.1396300E-05,.1482400E-05,& - & .8840700E-06,.9737000E-06,.1058900E-05,.1138300E-05,.1212400E-05,& - & .7115000E-06,.7868200E-06,.8604800E-06,.9271100E-06,.9912800E-06,& - & .5714000E-06,.6351300E-06,.6979000E-06,.7546600E-06,.8094600E-06,& - & .4587100E-06,.5118300E-06,.5649400E-06,.6137600E-06,.6602200E-06,& - & .3688900E-06,.4131900E-06,.4575900E-06,.4997300E-06,.5393300E-06,& - & .2968300E-06,.3339600E-06,.3711000E-06,.4067100E-06,.4402600E-06,& - & .2382800E-06,.2697300E-06,.3004800E-06,.3309900E-06,.3594900E-06,& - & .1908300E-06,.2178200E-06,.2435000E-06,.2688300E-06,.2930900E-06,& - & .1533400E-06,.1759200E-06,.1975300E-06,.2186900E-06,.2390300E-06,& - & .1263500E-06,.1450400E-06,.1632100E-06,.1807400E-06,.1975900E-06/ - - data absb( 1:120, 6) / & - & .3343300E-02,.3415900E-02,.3479800E-02,.3539700E-02,.3599500E-02,& - & .2803900E-02,.2858900E-02,.2909000E-02,.2959500E-02,.3010800E-02,& - & .2313500E-02,.2357900E-02,.2401200E-02,.2447000E-02,.2490000E-02,& - & .1892500E-02,.1928100E-02,.1967100E-02,.2009000E-02,.2044500E-02,& - & .1536500E-02,.1570300E-02,.1603900E-02,.1642400E-02,.1676000E-02,& - & .1242400E-02,.1274600E-02,.1306700E-02,.1339700E-02,.1368700E-02,& - & .1011300E-02,.1041700E-02,.1066400E-02,.1095800E-02,.1123100E-02,& - & .8337500E-03,.8586300E-03,.8809800E-03,.9068000E-03,.9309300E-03,& - & .6884900E-03,.7105600E-03,.7316100E-03,.7540200E-03,.7743200E-03,& - & .5707600E-03,.5900100E-03,.6092500E-03,.6281600E-03,.6453100E-03,& - & .4746200E-03,.4913800E-03,.5081800E-03,.5242100E-03,.5393000E-03,& - & .3955200E-03,.4101100E-03,.4246000E-03,.4386500E-03,.4520600E-03,& - & .3304100E-03,.3431700E-03,.3557300E-03,.3680000E-03,.3800500E-03,& - & .2769900E-03,.2880600E-03,.2989200E-03,.3098300E-03,.3203800E-03,& - & .2325300E-03,.2422900E-03,.2520800E-03,.2614400E-03,.2703900E-03,& - & .1957300E-03,.2044200E-03,.2127600E-03,.2208700E-03,.2286900E-03,& - & .1652800E-03,.1727100E-03,.1797400E-03,.1868100E-03,.1937300E-03,& - & .1394900E-03,.1459900E-03,.1521400E-03,.1583400E-03,.1644800E-03,& - & .1179300E-03,.1234500E-03,.1289100E-03,.1343200E-03,.1397500E-03,& - & .9984500E-04,.1046400E-03,.1094100E-03,.1142500E-03,.1189600E-03,& - & .8472300E-04,.8880800E-04,.9305400E-04,.9725700E-04,.1014400E-03,& - & .7185700E-04,.7547800E-04,.7924500E-04,.8287800E-04,.8652700E-04,& - & .6074100E-04,.6398700E-04,.6719000E-04,.7044500E-04,.7363400E-04,& - & .5109400E-04,.5395300E-04,.5678700E-04,.5964400E-04,.6242100E-04/ - - data absb(121:235, 6) / & - & .4280900E-04,.4532400E-04,.4780500E-04,.5031400E-04,.5279700E-04,& - & .3586200E-04,.3808200E-04,.4024900E-04,.4245900E-04,.4469100E-04,& - & .3004700E-04,.3197000E-04,.3387700E-04,.3584100E-04,.3779200E-04,& - & .2505100E-04,.2673400E-04,.2842900E-04,.3017700E-04,.3185900E-04,& - & .2085800E-04,.2233700E-04,.2383700E-04,.2534800E-04,.2684500E-04,& - & .1735800E-04,.1865300E-04,.1994700E-04,.2127900E-04,.2261400E-04,& - & .1438200E-04,.1550700E-04,.1663700E-04,.1780800E-04,.1897500E-04,& - & .1187500E-04,.1285100E-04,.1384700E-04,.1486500E-04,.1588600E-04,& - & .9782400E-05,.1064100E-04,.1149700E-04,.1238600E-04,.1328800E-04,& - & .8030500E-05,.8771200E-05,.9517000E-05,.1028200E-04,.1107300E-04,& - & .6555400E-05,.7188100E-05,.7833100E-05,.8502200E-05,.9179900E-05,& - & .5339900E-05,.5881800E-05,.6436400E-05,.7009300E-05,.7599200E-05,& - & .4339600E-05,.4799000E-05,.5272700E-05,.5763300E-05,.6278500E-05,& - & .3527200E-05,.3913900E-05,.4323000E-05,.4742300E-05,.5181900E-05,& - & .2862400E-05,.3191300E-05,.3537900E-05,.3897900E-05,.4274400E-05,& - & .2318900E-05,.2596100E-05,.2890700E-05,.3197600E-05,.3520000E-05,& - & .1873600E-05,.2107200E-05,.2357600E-05,.2617900E-05,.2894300E-05,& - & .1515500E-05,.1713500E-05,.1924500E-05,.2145100E-05,.2380800E-05,& - & .1225000E-05,.1392300E-05,.1571400E-05,.1757800E-05,.1959700E-05,& - & .9901200E-06,.1129600E-05,.1280100E-05,.1439500E-05,.1610700E-05,& - & .7987500E-06,.9141800E-06,.1040800E-05,.1177700E-05,.1321200E-05,& - & .6447400E-06,.7410900E-06,.8466400E-06,.9632800E-06,.1084900E-05,& - & .5329600E-06,.6142700E-06,.7038500E-06,.8037500E-06,.9086300E-06/ - - data absb( 1:120, 7) / & - & .9106300E-02,.9268100E-02,.9404500E-02,.9538800E-02,.9673500E-02,& - & .7848300E-02,.7980600E-02,.8123800E-02,.8252800E-02,.8360300E-02,& - & .6626900E-02,.6744500E-02,.6884500E-02,.6991100E-02,.7085400E-02,& - & .5518300E-02,.5641400E-02,.5757400E-02,.5848700E-02,.5940700E-02,& - & .4569300E-02,.4678000E-02,.4774300E-02,.4862500E-02,.4946700E-02,& - & .3761100E-02,.3853500E-02,.3940800E-02,.4023400E-02,.4100700E-02,& - & .3099100E-02,.3180900E-02,.3264700E-02,.3338800E-02,.3404200E-02,& - & .2585800E-02,.2658500E-02,.2734700E-02,.2799000E-02,.2857900E-02,& - & .2167200E-02,.2232600E-02,.2297300E-02,.2354700E-02,.2405800E-02,& - & .1821100E-02,.1880900E-02,.1936400E-02,.1985900E-02,.2035200E-02,& - & .1531400E-02,.1584400E-02,.1633200E-02,.1676000E-02,.1724300E-02,& - & .1292400E-02,.1338500E-02,.1379300E-02,.1420900E-02,.1465900E-02,& - & .1092600E-02,.1132200E-02,.1168900E-02,.1208100E-02,.1249300E-02,& - & .9275600E-03,.9613600E-03,.9960100E-03,.1032400E-02,.1069500E-02,& - & .7883200E-03,.8189300E-03,.8513700E-03,.8846500E-03,.9188500E-03,& - & .6709700E-03,.6997900E-03,.7298500E-03,.7603800E-03,.7921300E-03,& - & .5723100E-03,.5993400E-03,.6272700E-03,.6547100E-03,.6838900E-03,& - & .4899600E-03,.5144100E-03,.5394500E-03,.5656400E-03,.5916400E-03,& - & .4199800E-03,.4423700E-03,.4655100E-03,.4892400E-03,.5132200E-03,& - & .3613300E-03,.3816800E-03,.4029700E-03,.4244100E-03,.4472200E-03,& - & .3115300E-03,.3305500E-03,.3498000E-03,.3697200E-03,.3908600E-03,& - & .2694100E-03,.2865700E-03,.3043600E-03,.3229500E-03,.3425600E-03,& - & .2321000E-03,.2478200E-03,.2641100E-03,.2812100E-03,.2993000E-03,& - & .1990400E-03,.2131100E-03,.2279700E-03,.2438000E-03,.2603000E-03/ - - data absb(121:235, 7) / & - & .1700000E-03,.1830000E-03,.1966600E-03,.2112800E-03,.2264100E-03,& - & .1452800E-03,.1570400E-03,.1697500E-03,.1832000E-03,.1973500E-03,& - & .1241400E-03,.1349600E-03,.1465400E-03,.1589900E-03,.1721100E-03,& - & .1056700E-03,.1154700E-03,.1261800E-03,.1376500E-03,.1499400E-03,& - & .8977400E-04,.9875100E-04,.1085200E-03,.1191800E-03,.1305700E-03,& - & .7623200E-04,.8438300E-04,.9333600E-04,.1031400E-03,.1138100E-03,& - & .6437000E-04,.7168400E-04,.7979700E-04,.8885000E-04,.9873300E-04,& - & .5412500E-04,.6068000E-04,.6804200E-04,.7631300E-04,.8543200E-04,& - & .4537400E-04,.5128000E-04,.5793200E-04,.6542900E-04,.7385200E-04,& - & .3786100E-04,.4307800E-04,.4901600E-04,.5584400E-04,.6353800E-04,& - & .3134200E-04,.3587900E-04,.4117500E-04,.4725200E-04,.5428600E-04,& - & .2582100E-04,.2977700E-04,.3445800E-04,.3988000E-04,.4621800E-04,& - & .2118000E-04,.2461700E-04,.2871900E-04,.3350700E-04,.3918400E-04,& - & .1737700E-04,.2034500E-04,.2391600E-04,.2817700E-04,.3323700E-04,& - & .1422300E-04,.1679000E-04,.1986800E-04,.2365600E-04,.2816300E-04,& - & .1159300E-04,.1378800E-04,.1647900E-04,.1977300E-04,.2376500E-04,& - & .9414100E-05,.1127900E-04,.1359100E-04,.1644700E-04,.1996900E-04,& - & .7662200E-05,.9241700E-05,.1123300E-04,.1370900E-04,.1681900E-04,& - & .6231500E-05,.7567100E-05,.9269900E-05,.1142900E-04,.1418600E-04,& - & .5047300E-05,.6176600E-05,.7631600E-05,.9497900E-05,.1189000E-04,& - & .4077300E-05,.5024200E-05,.6254000E-05,.7859400E-05,.9937800E-05,& - & .3293700E-05,.4086200E-05,.5122800E-05,.6499200E-05,.8311200E-05,& - & .2759300E-05,.3450500E-05,.4371600E-05,.5603500E-05,.7260900E-05/ - - data absb( 1:120, 8) / & - & .2599000E-01,.2599700E-01,.2602400E-01,.2603800E-01,.2613200E-01,& - & .2264800E-01,.2273100E-01,.2280300E-01,.2286100E-01,.2302000E-01,& - & .1964100E-01,.1981200E-01,.1988000E-01,.1999800E-01,.2014100E-01,& - & .1690900E-01,.1703000E-01,.1714800E-01,.1729600E-01,.1750200E-01,& - & .1436500E-01,.1450400E-01,.1464300E-01,.1480800E-01,.1499600E-01,& - & .1207200E-01,.1220700E-01,.1234600E-01,.1251300E-01,.1274200E-01,& - & .1013500E-01,.1026300E-01,.1040200E-01,.1060200E-01,.1079400E-01,& - & .8650800E-02,.8795100E-02,.8976500E-02,.9153000E-02,.9344700E-02,& - & .7422800E-02,.7596400E-02,.7780500E-02,.7944100E-02,.8126600E-02,& - & .6394900E-02,.6592000E-02,.6758400E-02,.6929800E-02,.7096800E-02,& - & .5538900E-02,.5716500E-02,.5883400E-02,.6049000E-02,.6216300E-02,& - & .4798000E-02,.4969600E-02,.5133300E-02,.5305500E-02,.5469500E-02,& - & .4167600E-02,.4335700E-02,.4499900E-02,.4674900E-02,.4817900E-02,& - & .3639100E-02,.3807900E-02,.3983400E-02,.4137400E-02,.4275400E-02,& - & .3191700E-02,.3358000E-02,.3523700E-02,.3673700E-02,.3798200E-02,& - & .2809600E-02,.2970900E-02,.3124200E-02,.3261300E-02,.3382900E-02,& - & .2478600E-02,.2627200E-02,.2770600E-02,.2898600E-02,.3013000E-02,& - & .2190700E-02,.2328200E-02,.2457400E-02,.2577800E-02,.2680600E-02,& - & .1934600E-02,.2056900E-02,.2175700E-02,.2280500E-02,.2374200E-02,& - & .1710100E-02,.1824700E-02,.1930800E-02,.2025600E-02,.2117600E-02,& - & .1517100E-02,.1616800E-02,.1712100E-02,.1803500E-02,.1891100E-02,& - & .1346600E-02,.1439000E-02,.1524600E-02,.1608300E-02,.1692100E-02,& - & .1187100E-02,.1269800E-02,.1353400E-02,.1432000E-02,.1507100E-02,& - & .1038800E-02,.1117900E-02,.1193400E-02,.1264700E-02,.1339100E-02/ - - data absb(121:235, 8) / & - & .9223300E-03,.9985400E-03,.1072200E-02,.1142600E-02,.1211800E-02,& - & .8184300E-03,.8923600E-03,.9660500E-03,.1034000E-02,.1100300E-02,& - & .7273800E-03,.7977700E-03,.8699700E-03,.9349600E-03,.9985200E-03,& - & .6514900E-03,.7209800E-03,.7923500E-03,.8611600E-03,.9247400E-03,& - & .5831800E-03,.6515400E-03,.7216000E-03,.7940000E-03,.8597300E-03,& - & .5212700E-03,.5877000E-03,.6578100E-03,.7311000E-03,.8016500E-03,& - & .4640400E-03,.5296000E-03,.5988600E-03,.6736600E-03,.7472700E-03,& - & .4122900E-03,.4760900E-03,.5442400E-03,.6191800E-03,.6936600E-03,& - & .3653400E-03,.4262400E-03,.4937400E-03,.5666800E-03,.6436400E-03,& - & .3213400E-03,.3798700E-03,.4459700E-03,.5166900E-03,.5946900E-03,& - & .2785500E-03,.3353100E-03,.3985500E-03,.4683200E-03,.5456200E-03,& - & .2409400E-03,.2944000E-03,.3547700E-03,.4228400E-03,.4976700E-03,& - & .2071000E-03,.2571200E-03,.3142500E-03,.3809800E-03,.4546500E-03,& - & .1775700E-03,.2242200E-03,.2790600E-03,.3423100E-03,.4141900E-03,& - & .1519800E-03,.1953800E-03,.2475800E-03,.3079600E-03,.3776500E-03,& - & .1294300E-03,.1690700E-03,.2181200E-03,.2758500E-03,.3428400E-03,& - & .1094600E-03,.1456000E-03,.1910300E-03,.2463300E-03,.3104900E-03,& - & .9295000E-04,.1259900E-03,.1684800E-03,.2210900E-03,.2826600E-03,& - & .7872200E-04,.1088300E-03,.1483100E-03,.1979000E-03,.2577000E-03,& - & .6632300E-04,.9365100E-04,.1298300E-03,.1763800E-03,.2339300E-03,& - & .5564400E-04,.8008500E-04,.1134900E-03,.1574100E-03,.2127400E-03,& - & .4653700E-04,.6844200E-04,.9919000E-04,.1404500E-03,.1932700E-03,& - & .4155800E-04,.6250300E-04,.9237700E-04,.1325800E-03,.1852800E-03/ - - data absb( 1:120, 9) / & - & .1913712E+00,.1940307E+00,.1961583E+00,.1981395E+00,.1992614E+00,& - & .1688802E+00,.1712855E+00,.1734248E+00,.1752061E+00,.1762731E+00,& - & .1486065E+00,.1508840E+00,.1528820E+00,.1544423E+00,.1558272E+00,& - & .1299204E+00,.1323469E+00,.1341015E+00,.1357898E+00,.1371436E+00,& - & .1134080E+00,.1156327E+00,.1174880E+00,.1190475E+00,.1205541E+00,& - & .9849405E-01,.1005410E+00,.1023631E+00,.1040376E+00,.1053612E+00,& - & .8553764E-01,.8752614E-01,.8929406E-01,.9077432E-01,.9251699E-01,& - & .7472428E-01,.7670302E-01,.7818691E-01,.7985497E-01,.8155359E-01,& - & .6533778E-01,.6717463E-01,.6889333E-01,.7050656E-01,.7229544E-01,& - & .5740823E-01,.5919933E-01,.6095743E-01,.6261078E-01,.6444982E-01,& - & .5056393E-01,.5229127E-01,.5411951E-01,.5593955E-01,.5779249E-01,& - & .4478827E-01,.4654763E-01,.4835743E-01,.5018840E-01,.5221163E-01,& - & .3995582E-01,.4170732E-01,.4352502E-01,.4537017E-01,.4745831E-01,& - & .3584681E-01,.3763708E-01,.3940778E-01,.4140061E-01,.4366003E-01,& - & .3241328E-01,.3414397E-01,.3597457E-01,.3798590E-01,.4030971E-01,& - & .2947190E-01,.3126308E-01,.3314326E-01,.3529197E-01,.3770177E-01,& - & .2705105E-01,.2882380E-01,.3077801E-01,.3304753E-01,.3559583E-01,& - & .2495554E-01,.2671043E-01,.2883204E-01,.3115120E-01,.3377072E-01,& - & .2314399E-01,.2503929E-01,.2721446E-01,.2967647E-01,.3240495E-01,& - & .2168424E-01,.2363375E-01,.2593698E-01,.2846534E-01,.3128868E-01,& - & .2052923E-01,.2253442E-01,.2489053E-01,.2751815E-01,.3055501E-01,& - & .1954963E-01,.2161307E-01,.2412847E-01,.2681518E-01,.3006419E-01,& - & .1858710E-01,.2078212E-01,.2330820E-01,.2617072E-01,.2946078E-01,& - & .1751615E-01,.1979783E-01,.2246608E-01,.2526516E-01,.2885677E-01/ - - data absb(121:235, 9) / & - & .1645401E-01,.1873164E-01,.2142687E-01,.2424787E-01,.2779912E-01,& - & .1549653E-01,.1781459E-01,.2042772E-01,.2337789E-01,.2680098E-01,& - & .1464498E-01,.1698778E-01,.1958951E-01,.2255141E-01,.2592896E-01,& - & .1374930E-01,.1598681E-01,.1858564E-01,.2145636E-01,.2483064E-01,& - & .1297376E-01,.1509265E-01,.1767753E-01,.2043917E-01,.2378184E-01,& - & .1225680E-01,.1431909E-01,.1681124E-01,.1957355E-01,.2273600E-01,& - & .1154426E-01,.1346806E-01,.1585020E-01,.1858172E-01,.2161718E-01,& - & .1073729E-01,.1273625E-01,.1500546E-01,.1763766E-01,.2052634E-01,& - & .1003661E-01,.1202377E-01,.1415118E-01,.1671879E-01,.1956038E-01,& - & .9280320E-02,.1124463E-01,.1334817E-01,.1580509E-01,.1857998E-01,& - & .8562651E-02,.1045470E-01,.1255035E-01,.1487256E-01,.1749111E-01,& - & .7862421E-02,.9650932E-02,.1175305E-01,.1399227E-01,.1656834E-01,& - & .7176180E-02,.8968905E-02,.1094204E-01,.1318820E-01,.1566044E-01,& - & .6553611E-02,.8323164E-02,.1026176E-01,.1243120E-01,.1484228E-01,& - & .6016277E-02,.7685907E-02,.9617875E-02,.1169791E-01,.1410813E-01,& - & .5488131E-02,.7123060E-02,.9006212E-02,.1103169E-01,.1339416E-01,& - & .5039153E-02,.6572314E-02,.8368057E-02,.1042322E-01,.1261228E-01,& - & .4678553E-02,.6104245E-02,.7858028E-02,.9862751E-02,.1203004E-01,& - & .4397629E-02,.5698528E-02,.7389611E-02,.9348370E-02,.1154387E-01,& - & .4125069E-02,.5371631E-02,.6928103E-02,.8831411E-02,.1098275E-01,& - & .3904687E-02,.5099382E-02,.6546356E-02,.8396888E-02,.1047269E-01,& - & .3677700E-02,.4862089E-02,.6220196E-02,.7951650E-02,.1006273E-01,& - & .3646869E-02,.4855547E-02,.6218200E-02,.7940987E-02,.1000532E-01/ - - data absb( 1:120,10) / & - & .6563434E+01,.6536173E+01,.6509225E+01,.6480775E+01,.6453855E+01,& - & .6694993E+01,.6668788E+01,.6641684E+01,.6613791E+01,.6586857E+01,& - & .6814067E+01,.6788196E+01,.6761389E+01,.6734157E+01,.6706224E+01,& - & .6922709E+01,.6896320E+01,.6870266E+01,.6842505E+01,.6814432E+01,& - & .7018842E+01,.6992813E+01,.6966297E+01,.6939182E+01,.6910339E+01,& - & .7104680E+01,.7079554E+01,.7053120E+01,.7025060E+01,.6997053E+01,& - & .7178134E+01,.7153173E+01,.7126816E+01,.7099394E+01,.7069733E+01,& - & .7237652E+01,.7212460E+01,.7187023E+01,.7158873E+01,.7129293E+01,& - & .7288276E+01,.7263276E+01,.7236743E+01,.7208943E+01,.7178798E+01,& - & .7329577E+01,.7304627E+01,.7277602E+01,.7249474E+01,.7218919E+01,& - & .7364634E+01,.7339549E+01,.7311831E+01,.7282930E+01,.7252217E+01,& - & .7393382E+01,.7367435E+01,.7340013E+01,.7310737E+01,.7279210E+01,& - & .7416720E+01,.7390784E+01,.7362566E+01,.7332879E+01,.7300963E+01,& - & .7435429E+01,.7408936E+01,.7380806E+01,.7350034E+01,.7317321E+01,& - & .7450559E+01,.7423883E+01,.7395076E+01,.7363982E+01,.7330904E+01,& - & .7462543E+01,.7435279E+01,.7405991E+01,.7374365E+01,.7340536E+01,& - & .7471315E+01,.7443887E+01,.7414078E+01,.7381879E+01,.7347478E+01,& - & .7478800E+01,.7450609E+01,.7419846E+01,.7387182E+01,.7352811E+01,& - & .7483666E+01,.7454950E+01,.7423611E+01,.7390401E+01,.7355051E+01,& - & .7487253E+01,.7457765E+01,.7425717E+01,.7391895E+01,.7356050E+01,& - & .7488506E+01,.7458765E+01,.7426508E+01,.7392054E+01,.7355156E+01,& - & .7489850E+01,.7459250E+01,.7426035E+01,.7391305E+01,.7353645E+01,& - & .7492443E+01,.7461624E+01,.7428244E+01,.7392628E+01,.7354878E+01,& - & .7497726E+01,.7466429E+01,.7432747E+01,.7397279E+01,.7358181E+01/ - - data absb(121:235,10) / & - & .7505737E+01,.7474800E+01,.7440929E+01,.7405596E+01,.7366801E+01,& - & .7513970E+01,.7482707E+01,.7449119E+01,.7413672E+01,.7375439E+01,& - & .7520741E+01,.7489941E+01,.7456502E+01,.7420983E+01,.7383218E+01,& - & .7530440E+01,.7499850E+01,.7466874E+01,.7431912E+01,.7393870E+01,& - & .7538723E+01,.7509468E+01,.7476827E+01,.7442592E+01,.7405041E+01,& - & .7547204E+01,.7518633E+01,.7486628E+01,.7452286E+01,.7415815E+01,& - & .7556213E+01,.7528691E+01,.7497855E+01,.7463955E+01,.7428134E+01,& - & .7565953E+01,.7538872E+01,.7508898E+01,.7475761E+01,.7440938E+01,& - & .7575062E+01,.7548586E+01,.7519907E+01,.7487622E+01,.7453098E+01,& - & .7584131E+01,.7558667E+01,.7530653E+01,.7499618E+01,.7465741E+01,& - & .7593779E+01,.7569486E+01,.7542361E+01,.7512145E+01,.7479280E+01,& - & .7602657E+01,.7580065E+01,.7553432E+01,.7524179E+01,.7492239E+01,& - & .7610916E+01,.7589199E+01,.7564289E+01,.7535843E+01,.7505070E+01,& - & .7618668E+01,.7597891E+01,.7574135E+01,.7546664E+01,.7516426E+01,& - & .7625181E+01,.7605859E+01,.7582588E+01,.7556608E+01,.7527157E+01,& - & .7630829E+01,.7612911E+01,.7590839E+01,.7566252E+01,.7537672E+01,& - & .7636310E+01,.7619845E+01,.7598957E+01,.7575011E+01,.7547925E+01,& - & .7640632E+01,.7625839E+01,.7606042E+01,.7583011E+01,.7556788E+01,& - & .7644312E+01,.7630300E+01,.7612179E+01,.7589767E+01,.7564669E+01,& - & .7647263E+01,.7634539E+01,.7617801E+01,.7596900E+01,.7572581E+01,& - & .7650044E+01,.7638295E+01,.7623237E+01,.7603393E+01,.7580008E+01,& - & .7651936E+01,.7641531E+01,.7627671E+01,.7609561E+01,.7586309E+01,& - & .7652501E+01,.7642169E+01,.7629030E+01,.7611100E+01,.7588572E+01/ - -! --- - data forref(1:4,1:10) / & - & .2145040E-06,.4604180E-06,.3576080E-05,.1920370E-05,.1425760E-05,& - & .3644630E-05,.1170330E-04,.1120850E-04,.1015360E-04,.1240960E-04,& - & .5091900E-04,.5652820E-04,.1433940E-03,.1547000E-03,.4664980E-03,& - & .9188290E-03,.2516310E-02,.2417290E-02,.2400570E-02,.3504080E-02,& - & .4103090E-02,.4168510E-02,.3909250E-02,.3836940E-02,.4453870E-02,& - & .4486570E-02,.4323100E-02,.3707390E-02,.4581500E-02,.4600140E-02,& - & .4502450E-02,.3367180E-02,.4682248E-02,.4680093E-02,.4684726E-02,& - & .3680135E-02,.5243173E-02,.5159096E-02,.5132896E-02,.3931064E-02/ - -! the array selfref contains the coefficient of the water vapor -! self-continuum (including the energy term). the first index -! refers to temperature in 7.2 degree increments. For instance, -! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, -! etc. the second index runs over the g-channel (1 to 10). - - data selfref(1:10,1:10) / & - & .2170580E-03,.1763910E-03,.1433420E-03,.1164860E-03,.9466140E-04,& - & .7692570E-04,.6251310E-04,.5080070E-04,.4128280E-04,.3354810E-04,& - & .5980550E-03,.4848050E-03,.3930000E-03,.3185800E-03,.2582520E-03,& - & .2093480E-03,.1697050E-03,.1375690E-03,.1115180E-03,.9040080E-04,& - & .1026910E-02,.9302810E-03,.8427400E-03,.7634370E-03,.6915960E-03,& - & .6265160E-03,.5675600E-03,.5141520E-03,.4657690E-03,.4219400E-03,& - & .3885690E-02,.3650980E-02,.3430450E-02,.3223240E-02,.3028540E-02,& - & .2845610E-02,.2673720E-02,.2512220E-02,.2360470E-02,.2217890E-02,& - & .3498450E-01,.3266780E-01,.3050450E-01,.2848450E-01,.2659820E-01,& - & .2483690E-01,.2319210E-01,.2165630E-01,.2022220E-01,.1888310E-01,& - & .6137050E-01,.5626760E-01,.5158900E-01,.4729940E-01,.4336650E-01,& - & .3976060E-01,.3645450E-01,.3342330E-01,.3064420E-01,.2809610E-01,& - & .6569810E-01,.6026600E-01,.5528300E-01,.5071200E-01,.4651900E-01,& - & .4267260E-01,.3914430E-01,.3590770E-01,.3293870E-01,.3021530E-01,& - & .6717820E-01,.6164610E-01,.5656950E-01,.5191100E-01,.4763610E-01,& - & .4371320E-01,.4011340E-01,.3681000E-01,.3377870E-01,.3099700E-01,& - & .6790842E-01,.6238861E-01,.5731740E-01,.5265845E-01,.4837825E-01,& - & .4444589E-01,.4083320E-01,.3751416E-01,.3446487E-01,.3166347E-01,& - & .7454175E-01,.6857684E-01,.6309064E-01,.5804463E-01,.5340338E-01,& - & .4913438E-01,.4520762E-01,.4159562E-01,.3827306E-01,.3521673E-01/ - -! --- ch4 - data absch4(1:10) / & - & .1013810E-02,.6336920E-02,.1941850E-01,.4832100E-01,.2365740E-02,& - & .6619730E-03,.5645520E-03,.2831830E-03,.6714756E-04,.2647642E-06/ - -!........................................! - end module module_radsw_kgb20 ! -!========================================! - - -!========================================! - module module_radsw_kgb21 ! -!........................................! -! -! ********* the original program descriptions ********* ! -! ! -! originally by j.delamere, atmospheric & environmental research. ! -! revision: 2.4 ! -! band 21: 6150-7700 cm-1 (low - j2o,co2; high - h2o,co2) ! -! reformatted for f90 by jjmorcrette, ecmwf ! -! ! -! this table has been re-generated for reduced number of g-point ! -! by y.t.hou, ncep ! -! ! -! ********* ********* end description ********* ********* ! -! - use machine, only : kind_phys - use module_radsw_parameters, only : NG21 - -! - implicit none -! - private -! - integer, public :: MSA21, MSB21, MSF21, MFR21 - parameter (MSA21=585, MSB21=1175, MSF21=10, MFR21=4) - - real (kind=kind_phys), public :: forref(MFR21,NG21), & - & absa(MSA21,NG21), absb(MSB21,NG21), selfref(MSF21,NG21) - -! --- rayleigh extinction coefficient at v = 6925 cm-1. - real (kind=kind_phys), parameter, public :: rayl = 9.41e-09 - -! the array absa(585,NG21) (ka((9,5,13,NG21)) contains absorption coefs at -! the 16 chosen g-values for a range of pressure levels> ~100mb, -! temperatures, and binary species parameters (see taumol.f for definition). -! the first index in the array, js, runs from 1 to 9, and corresponds to -! different values of the binary species parameter. for instance, -! js=1 refers to dry air, js = 2 corresponds to the paramter value 1/8, -! js = 3 corresponds to the parameter value 2/8, etc. the second index -! in the array, jt, which runs from 1 to 5, corresponds to different -! temperatures. more specifically, jt = 3 means that the data are for -! the reference temperature tref for this pressure level, jt = 2 refers -! to tref-15, jt = 1 is for tref-30, jt = 4 is for tref+15, and jt = 5 -! is for tref+30. the third index, jp, runs from 1 to 13 and refers -! to the jpth reference pressure level (see taumol.f for these levels -! in mb). the fourth index, ig, goes from 1 to 10, and indicates -! which g-interval the absorption coefficients are for. - - data absa( 1:180, 1) / & - & .3148200E-07,.6401000E-05,.9501700E-05,.1173500E-04,.1356100E-04,& - & .1507700E-04,.1612100E-04,.1613800E-04,.4168700E-06,.2979100E-07,& - & .6820600E-05,.1026000E-04,.1276400E-04,.1488000E-04,.1666500E-04,& - & .1794400E-04,.1817000E-04,.4424600E-06,.2827200E-07,.7244800E-05,& - & .1108300E-04,.1386600E-04,.1625600E-04,.1832300E-04,.1988600E-04,& - & .2022900E-04,.4747200E-06,.2690000E-07,.7693500E-05,.1193400E-04,& - & .1501500E-04,.1765700E-04,.2003800E-04,.2190200E-04,.2236100E-04,& - & .5077000E-06,.2565600E-07,.8166100E-05,.1276900E-04,.1618100E-04,& - & .1912700E-04,.2175500E-04,.2396300E-04,.2442100E-04,.5420500E-06,& - & .2639600E-07,.5222500E-05,.7722100E-05,.9515000E-05,.1100400E-04,& - & .1219500E-04,.1303700E-04,.1298500E-04,.3209700E-06,.2494500E-07,& - & .5573700E-05,.8361200E-05,.1037500E-04,.1211600E-04,.1356900E-04,& - & .1456100E-04,.1471100E-04,.3457900E-06,.2364600E-07,.5933300E-05,& - & .9053100E-05,.1130100E-04,.1324700E-04,.1495600E-04,.1619300E-04,& - & .1639600E-04,.3720000E-06,.2247600E-07,.6314400E-05,.9773200E-05,& - & .1227400E-04,.1443600E-04,.1637700E-04,.1787900E-04,.1822300E-04,& - & .4005100E-06,.2141500E-07,.6713300E-05,.1047100E-04,.1326400E-04,& - & .1568100E-04,.1784300E-04,.1962700E-04,.1995400E-04,.4292900E-06,& - & .2239700E-07,.4193000E-05,.6155900E-05,.7554400E-05,.8690200E-05,& - & .9589600E-05,.1026900E-04,.1011400E-04,.2414800E-06,.2112400E-07,& - & .4483700E-05,.6678600E-05,.8247500E-05,.9635300E-05,.1074200E-04,& - & .1146900E-04,.1155600E-04,.2630400E-06,.1998800E-07,.4783900E-05,& - & .7249900E-05,.9022900E-05,.1056000E-04,.1190000E-04,.1285900E-04,& - & .1293500E-04,.2861800E-06,.1896800E-07,.5104000E-05,.7858600E-05,& - & .9830800E-05,.1155100E-04,.1309400E-04,.1424000E-04,.1445500E-04,& - & .3098300E-06,.1804700E-07,.5436600E-05,.8446200E-05,.1067000E-04,& - & .1258500E-04,.1431300E-04,.1569500E-04,.1593400E-04,.3325500E-06,& - & .1908000E-07,.3340900E-05,.4873800E-05,.5935400E-05,.6787700E-05,& - & .7490000E-05,.7914200E-05,.7720000E-05,.1846600E-06,.1795400E-07,& - & .3591000E-05,.5296000E-05,.6503700E-05,.7574400E-05,.8408200E-05,& - & .8942200E-05,.8930200E-05,.2029200E-06,.1695400E-07,.3831700E-05,& - & .5753600E-05,.7132200E-05,.8342400E-05,.9378800E-05,.1006300E-04,& - & .1009800E-04,.2217300E-06,.1605900E-07,.4093200E-05,.6258600E-05,& - & .7796100E-05,.9147500E-05,.1034700E-04,.1122200E-04,.1131200E-04,& - & .2400500E-06,.1525400E-07,.4367800E-05,.6752500E-05,.8487300E-05,& - & .9999500E-05,.1135300E-04,.1241600E-04,.1258600E-04,.2593900E-06/ - - data absa(181:315, 1) / & - & .1626100E-07,.2654000E-05,.3854100E-05,.4644300E-05,.5296100E-05,& - & .5805400E-05,.6071800E-05,.5854000E-05,.1427400E-06,.1526500E-07,& - & .2859800E-05,.4183100E-05,.5122100E-05,.5911000E-05,.6520700E-05,& - & .6976100E-05,.6868500E-05,.1572500E-06,.1438400E-07,.3062300E-05,& - & .4552800E-05,.5612400E-05,.6565000E-05,.7343600E-05,.7820800E-05,& - & .7852300E-05,.1727100E-06,.1359900E-07,.3272000E-05,.4962200E-05,& - & .6160500E-05,.7224400E-05,.8158200E-05,.8797100E-05,.8809600E-05,& - & .1876600E-06,.1289500E-07,.3498500E-05,.5383300E-05,.6724000E-05,& - & .7909100E-05,.8968800E-05,.9769800E-05,.9863900E-05,.2037500E-06,& - & .1389800E-07,.2098100E-05,.3038400E-05,.3604100E-05,.4104000E-05,& - & .4433400E-05,.4576100E-05,.4395000E-05,.1102500E-06,.1301100E-07,& - & .2264500E-05,.3289000E-05,.4004200E-05,.4585100E-05,.5047300E-05,& - & .5325000E-05,.5185400E-05,.1222700E-06,.1223100E-07,.2432200E-05,& - & .3584200E-05,.4391500E-05,.5125900E-05,.5690300E-05,.6034300E-05,& - & .6016600E-05,.1350600E-06,.1153900E-07,.2603200E-05,.3910700E-05,& - & .4832100E-05,.5652500E-05,.6362500E-05,.6807800E-05,.6802400E-05,& - & .1471900E-06,.1092100E-07,.2786600E-05,.4257800E-05,.5291900E-05,& - & .6218100E-05,.7036200E-05,.7614000E-05,.7651900E-05,.1605200E-06,& - & .1188600E-07,.1656300E-05,.2386000E-05,.2827600E-05,.3144900E-05,& - & .3377100E-05,.3430500E-05,.3282400E-05,.8494300E-07,.1109600E-07,& - & .1787400E-05,.2586100E-05,.3110000E-05,.3542500E-05,.3873700E-05,& - & .4046800E-05,.3893300E-05,.9473400E-07,.1040500E-07,.1928600E-05,& - & .2816600E-05,.3441700E-05,.3978600E-05,.4380400E-05,.4675900E-05,& - & .4583500E-05,.1053100E-06,.9794800E-08,.2068000E-05,.3074100E-05,& - & .3780300E-05,.4416300E-05,.4942000E-05,.5247700E-05,.5250900E-05,& - & .1151700E-06,.9252200E-08,.2214000E-05,.3355800E-05,.4154400E-05,& - & .4871900E-05,.5496800E-05,.5922500E-05,.5902700E-05,.1261800E-06/ - - data absa(316:450, 1) / & - & .1016400E-07,.1305600E-05,.1869000E-05,.2194000E-05,.2421000E-05,& - & .2550400E-05,.2567600E-05,.2444400E-05,.6602100E-07,.9461200E-08,& - & .1410600E-05,.2039800E-05,.2413600E-05,.2742400E-05,.2957800E-05,& - & .3044600E-05,.2918200E-05,.7398500E-07,.8848900E-08,.1525600E-05,& - & .2212300E-05,.2689400E-05,.3070400E-05,.3380800E-05,.3552100E-05,& - & .3452600E-05,.8266600E-07,.8311100E-08,.1639600E-05,.2415900E-05,& - & .2956300E-05,.3450400E-05,.3819600E-05,.4042500E-05,.4009300E-05,& - & .9094000E-07,.7834900E-08,.1757000E-05,.2639800E-05,.3254700E-05,& - & .3806000E-05,.4281300E-05,.4573200E-05,.4546500E-05,.1002200E-06,& - & .8698300E-08,.1028400E-05,.1473400E-05,.1697300E-05,.1855100E-05,& - & .1922300E-05,.1922200E-05,.1828900E-05,.5346000E-07,.8071200E-08,& - & .1114100E-05,.1601600E-05,.1890200E-05,.2102700E-05,.2250400E-05,& - & .2280000E-05,.2174900E-05,.6018000E-07,.7528400E-08,.1203300E-05,& - & .1737600E-05,.2084900E-05,.2371900E-05,.2590600E-05,.2697700E-05,& - & .2591000E-05,.6688600E-07,.7054100E-08,.1297900E-05,.1895900E-05,& - & .2309000E-05,.2669500E-05,.2936700E-05,.3123900E-05,.3057400E-05,& - & .7397800E-07,.6635900E-08,.1393700E-05,.2072000E-05,.2544800E-05,& - & .2968000E-05,.3320800E-05,.3519100E-05,.3509700E-05,.8172400E-07,& - & .7400600E-08,.8170500E-06,.1161000E-05,.1332500E-05,.1430500E-05,& - & .1466800E-05,.1464200E-05,.1376500E-05,.4472400E-07,.6847700E-08,& - & .8830600E-06,.1264000E-05,.1476800E-05,.1632900E-05,.1720900E-05,& - & .1730600E-05,.1644100E-05,.5068800E-07,.6371700E-08,.9552200E-06,& - & .1378300E-05,.1630300E-05,.1854600E-05,.1996300E-05,.2057000E-05,& - & .1967800E-05,.5605200E-07,.5957600E-08,.1033100E-05,.1497500E-05,& - & .1818000E-05,.2077000E-05,.2281300E-05,.2402100E-05,.2335000E-05,& - & .6241200E-07,.5594000E-08,.1110200E-05,.1637000E-05,.1999900E-05,& - & .2334900E-05,.2590000E-05,.2732800E-05,.2705700E-05,.6946600E-07/ - - data absa(451:585, 1) / & - & .6061700E-08,.6716700E-06,.9559400E-06,.1093900E-05,.1176700E-05,& - & .1205900E-05,.1203200E-05,.1131400E-05,.3709300E-07,.5608700E-08,& - & .7270400E-06,.1040600E-05,.1213700E-05,.1343400E-05,.1417100E-05,& - & .1424600E-05,.1352100E-05,.4191800E-07,.5218700E-08,.7868100E-06,& - & .1133800E-05,.1341900E-05,.1525400E-05,.1642600E-05,.1695000E-05,& - & .1620300E-05,.4633900E-07,.4879300E-08,.8501300E-06,.1232700E-05,& - & .1497100E-05,.1710900E-05,.1877600E-05,.1978400E-05,.1924000E-05,& - & .5172500E-07,.4581500E-08,.9142000E-06,.1342700E-05,.1645800E-05,& - & .1922100E-05,.2132300E-05,.2249000E-05,.2226300E-05,.5755500E-07,& - & .4962900E-08,.5522300E-06,.7867700E-06,.8978900E-06,.9677800E-06,& - & .9914800E-06,.9888300E-06,.9302800E-06,.3061000E-07,.4592000E-08,& - & .5983200E-06,.8563200E-06,.9973000E-06,.1105200E-05,.1166500E-05,& - & .1172900E-05,.1112500E-05,.3455300E-07,.4272700E-08,.6476000E-06,& - & .9331500E-06,.1104100E-05,.1255200E-05,.1352100E-05,.1395600E-05,& - & .1333300E-05,.3817600E-07,.3994900E-08,.6992600E-06,.1011000E-05,& - & .1230400E-05,.1408300E-05,.1544200E-05,.1628300E-05,.1583700E-05,& - & .4264800E-07,.3751000E-08,.7523900E-06,.1100600E-05,.1353500E-05,& - & .1578500E-05,.1754700E-05,.1850100E-05,.1829800E-05,.4745200E-07,& - & .4063300E-08,.4537800E-06,.6471900E-06,.7363700E-06,.7957100E-06,& - & .8150300E-06,.8126400E-06,.7648800E-06,.2508000E-07,.3759600E-08,& - & .4920800E-06,.7043000E-06,.8189400E-06,.9085600E-06,.9591900E-06,& - & .9643500E-06,.9141100E-06,.2829300E-07,.3498200E-08,.5325900E-06,& - & .7637000E-06,.9076100E-06,.1031600E-05,.1111600E-05,.1147200E-05,& - & .1095600E-05,.3126700E-07,.3270700E-08,.5748800E-06,.8283300E-06,& - & .1009600E-05,.1157700E-05,.1268800E-05,.1338800E-05,.1301500E-05,& - & .3493000E-07,.3071000E-08,.6183200E-06,.9025000E-06,.1112000E-05,& - & .1296200E-05,.1442400E-05,.1520600E-05,.1503200E-05,.3886100E-07/ - - data absa( 1:180, 2) / & - & .1421500E-06,.6572600E-04,.1132700E-03,.1532400E-03,.1847300E-03,& - & .2065800E-03,.2160300E-03,.2061700E-03,.1325200E-04,.1345200E-06,& - & .6952100E-04,.1205900E-03,.1634200E-03,.1961300E-03,.2198700E-03,& - & .2294600E-03,.2187900E-03,.1481600E-04,.1276600E-06,.7331300E-04,& - & .1278600E-03,.1730300E-03,.2075400E-03,.2332600E-03,.2432400E-03,& - & .2295600E-03,.1653600E-04,.1214700E-06,.7708700E-04,.1352100E-03,& - & .1826300E-03,.2190400E-03,.2461400E-03,.2563700E-03,.2406000E-03,& - & .1809200E-04,.1158400E-06,.8094600E-04,.1423300E-03,.1923000E-03,& - & .2304700E-03,.2586900E-03,.2690400E-03,.2513900E-03,.1976800E-04,& - & .1191800E-06,.5516700E-04,.9455700E-04,.1276000E-03,.1532200E-03,& - & .1714800E-03,.1789400E-03,.1704900E-03,.1071000E-04,.1126400E-06,& - & .5858100E-04,.1011300E-03,.1364800E-03,.1633500E-03,.1828800E-03,& - & .1905900E-03,.1813100E-03,.1206700E-04,.1067800E-06,.6193500E-04,& - & .1075600E-03,.1449700E-03,.1733500E-03,.1943700E-03,.2024500E-03,& - & .1907000E-03,.1355300E-04,.1014900E-06,.6526100E-04,.1140400E-03,& - & .1533100E-03,.1832300E-03,.2055900E-03,.2138500E-03,.2002400E-03,& - & .1480100E-04,.9669900E-07,.6869800E-04,.1203800E-03,.1616700E-03,& - & .1930800E-03,.2163500E-03,.2247900E-03,.2096400E-03,.1624500E-04,& - & .1011200E-06,.4539900E-04,.7722600E-04,.1039700E-03,.1246200E-03,& - & .1395600E-03,.1453100E-03,.1381600E-03,.8363500E-05,.9538100E-07,& - & .4835700E-04,.8298600E-04,.1117300E-03,.1333800E-03,.1489800E-03,& - & .1553400E-03,.1478600E-03,.9491500E-05,.9025700E-07,.5135500E-04,& - & .8872700E-04,.1192000E-03,.1421500E-03,.1585900E-03,.1654100E-03,& - & .1562200E-03,.1068300E-04,.8565300E-07,.5432200E-04,.9436900E-04,& - & .1264600E-03,.1507200E-03,.1683800E-03,.1753600E-03,.1643300E-03,& - & .1176400E-04,.8149200E-07,.5730000E-04,.9994000E-04,.1335500E-03,& - & .1592900E-03,.1780000E-03,.1849600E-03,.1723400E-03,.1297900E-04,& - & .8613200E-07,.3691000E-04,.6234600E-04,.8362800E-04,.1002500E-03,& - & .1122400E-03,.1170600E-03,.1110900E-03,.6471500E-05,.8106200E-07,& - & .3949000E-04,.6727400E-04,.9038400E-04,.1078500E-03,.1202600E-03,& - & .1254300E-03,.1194400E-03,.7399100E-05,.7655300E-07,.4205500E-04,& - & .7226900E-04,.9695600E-04,.1152800E-03,.1283300E-03,.1339600E-03,& - & .1269700E-03,.8389900E-05,.7251600E-07,.4469600E-04,.7723500E-04,& - & .1032100E-03,.1227600E-03,.1367400E-03,.1426000E-03,.1338400E-03,& - & .9305200E-05,.6888100E-07,.4727300E-04,.8211800E-04,.1093500E-03,& - & .1301600E-03,.1450600E-03,.1508000E-03,.1406200E-03,.1031400E-04/ - - data absa(181:315, 2) / & - & .7340100E-07,.2977200E-04,.4995700E-04,.6672000E-04,.8010400E-04,& - & .8976100E-04,.9385300E-04,.8895300E-04,.5017100E-05,.6891600E-07,& - & .3197600E-04,.5421700E-04,.7257000E-04,.8667100E-04,.9665300E-04,& - & .1007300E-03,.9587500E-04,.5774600E-05,.6494500E-07,.3421900E-04,& - & .5841700E-04,.7832700E-04,.9295000E-04,.1035800E-03,.1080300E-03,& - & .1027400E-03,.6619700E-05,.6140500E-07,.3645700E-04,.6269400E-04,& - & .8375600E-04,.9935600E-04,.1105800E-03,.1154200E-03,.1085800E-03,& - & .7372900E-05,.5822900E-07,.3871300E-04,.6705900E-04,.8903300E-04,& - & .1057300E-03,.1176400E-03,.1224300E-03,.1144000E-03,.8214900E-05,& - & .6272300E-07,.2375000E-04,.3964300E-04,.5279600E-04,.6347800E-04,& - & .7115100E-04,.7464000E-04,.7019300E-04,.3889900E-05,.5873500E-07,& - & .2565700E-04,.4327400E-04,.5771900E-04,.6912400E-04,.7737500E-04,& - & .8049800E-04,.7654300E-04,.4483300E-05,.5522200E-07,.2756300E-04,& - & .4686600E-04,.6269900E-04,.7449400E-04,.8294600E-04,.8665300E-04,& - & .8250900E-04,.5163500E-05,.5210300E-07,.2952800E-04,.5047000E-04,& - & .6747300E-04,.7989900E-04,.8900400E-04,.9278600E-04,.8762800E-04,& - & .5810400E-05,.4931700E-07,.3144400E-04,.5417500E-04,.7200000E-04,& - & .8532200E-04,.9488500E-04,.9882600E-04,.9264800E-04,.6499700E-05,& - & .5363400E-07,.1886200E-04,.3132500E-04,.4157500E-04,.5014100E-04,& - & .5619000E-04,.5888200E-04,.5502600E-04,.2979500E-05,.5008400E-07,& - & .2047400E-04,.3434200E-04,.4573200E-04,.5488400E-04,.6149400E-04,& - & .6418700E-04,.6085700E-04,.3458900E-05,.4697300E-07,.2206300E-04,& - & .3741100E-04,.4989300E-04,.5947500E-04,.6627900E-04,.6912900E-04,& - & .6575800E-04,.3998300E-05,.4422400E-07,.2376400E-04,.4048100E-04,& - & .5410700E-04,.6402600E-04,.7135000E-04,.7432800E-04,.7051300E-04,& - & .4552600E-05,.4177700E-07,.2543400E-04,.4355500E-04,.5795800E-04,& - & .6859900E-04,.7630400E-04,.7945600E-04,.7464900E-04,.5104600E-05/ - - data absa(316:450, 2) / & - & .4585700E-07,.1494500E-04,.2459400E-04,.3269600E-04,.3957100E-04,& - & .4434800E-04,.4609000E-04,.4303400E-04,.2283300E-05,.4269700E-07,& - & .1626500E-04,.2719800E-04,.3610800E-04,.4338100E-04,.4864200E-04,& - & .5094300E-04,.4784800E-04,.2666900E-05,.3994400E-07,.1761600E-04,& - & .2977500E-04,.3957700E-04,.4736600E-04,.5279100E-04,.5499200E-04,& - & .5223600E-04,.3093200E-05,.3752200E-07,.1904200E-04,.3235100E-04,& - & .4312600E-04,.5115300E-04,.5698700E-04,.5931600E-04,.5643800E-04,& - & .3566600E-05,.3537600E-07,.2047600E-04,.3494600E-04,.4652100E-04,& - & .5500900E-04,.6122100E-04,.6371400E-04,.6003500E-04,.4003700E-05,& - & .3923300E-07,.1181700E-04,.1925400E-04,.2559600E-04,.3084300E-04,& - & .3457400E-04,.3603500E-04,.3342500E-04,.1767300E-05,.3641800E-07,& - & .1291400E-04,.2140400E-04,.2837200E-04,.3416100E-04,.3832100E-04,& - & .4005300E-04,.3743500E-04,.2075100E-05,.3397900E-07,.1402600E-04,& - & .2357400E-04,.3131600E-04,.3751400E-04,.4197700E-04,.4374700E-04,& - & .4134600E-04,.2415100E-05,.3184400E-07,.1520500E-04,.2577000E-04,& - & .3423100E-04,.4072300E-04,.4531500E-04,.4720200E-04,.4486900E-04,& - & .2815100E-05,.2996100E-07,.1642000E-04,.2795500E-04,.3718700E-04,& - & .4394100E-04,.4887300E-04,.5085600E-04,.4817000E-04,.3173300E-05,& - & .3337300E-07,.9350500E-05,.1521600E-04,.2019800E-04,.2424400E-04,& - & .2707700E-04,.2818600E-04,.2599600E-04,.1394100E-05,.3089300E-07,& - & .1028400E-04,.1690200E-04,.2246800E-04,.2707200E-04,.3038200E-04,& - & .3160300E-04,.2945600E-04,.1635200E-05,.2875400E-07,.1120700E-04,& - & .1871500E-04,.2484900E-04,.2981500E-04,.3337900E-04,.3490100E-04,& - & .3283600E-04,.1918800E-05,.2689200E-07,.1217200E-04,.2057800E-04,& - & .2726900E-04,.3253600E-04,.3618200E-04,.3770300E-04,.3575000E-04,& - & .2246700E-05,.2525500E-07,.1319500E-04,.2242200E-04,.2978100E-04,& - & .3522000E-04,.3915700E-04,.4071900E-04,.3872900E-04,.2553500E-05/ - - data absa(451:585, 2) / & - & .2733500E-07,.7749100E-05,.1260700E-04,.1669500E-04,.2009300E-04,& - & .2243100E-04,.2334500E-04,.2152200E-04,.1156900E-05,.2530300E-07,& - & .8532200E-05,.1402200E-04,.1859300E-04,.2237800E-04,.2513300E-04,& - & .2616100E-04,.2437900E-04,.1370900E-05,.2355100E-07,.9291200E-05,& - & .1553600E-04,.2061800E-04,.2472200E-04,.2764700E-04,.2887400E-04,& - & .2719600E-04,.1609900E-05,.2202500E-07,.1011700E-04,.1711500E-04,& - & .2264500E-04,.2697400E-04,.2994700E-04,.3121000E-04,.2958100E-04,& - & .1884500E-05,.2068400E-07,.1097700E-04,.1864500E-04,.2473400E-04,& - & .2920300E-04,.3245300E-04,.3373300E-04,.3205600E-04,.2132600E-05,& - & .2238000E-07,.6414400E-05,.1043600E-04,.1380200E-04,.1662200E-04,& - & .1855700E-04,.1931400E-04,.1779300E-04,.9590600E-06,.2071600E-07,& - & .7060300E-05,.1162500E-04,.1538500E-04,.1850300E-04,.2077600E-04,& - & .2163000E-04,.2015200E-04,.1136300E-05,.1928200E-07,.7696000E-05,& - & .1288600E-04,.1708700E-04,.2047500E-04,.2286700E-04,.2385600E-04,& - & .2250600E-04,.1340000E-05,.1803200E-07,.8398300E-05,.1420600E-04,& - & .1878300E-04,.2233400E-04,.2476400E-04,.2581500E-04,.2446100E-04,& - & .1563700E-05,.1693400E-07,.9118600E-05,.1549100E-04,.2051300E-04,& - & .2420100E-04,.2686400E-04,.2791700E-04,.2649100E-04,.1770700E-05,& - & .1832300E-07,.5302200E-05,.8627300E-05,.1138500E-04,.1372900E-04,& - & .1531800E-04,.1595200E-04,.1469300E-04,.7892700E-06,.1696100E-07,& - & .5831600E-05,.9620400E-05,.1271700E-04,.1527500E-04,.1714100E-04,& - & .1786300E-04,.1663900E-04,.9365900E-06,.1578700E-07,.6371000E-05,& - & .1067500E-04,.1414000E-04,.1692500E-04,.1888100E-04,.1967500E-04,& - & .1856400E-04,.1105000E-05,.1476400E-07,.6960700E-05,.1177900E-04,& - & .1555400E-04,.1847500E-04,.2046100E-04,.2132000E-04,.2020700E-04,& - & .1286800E-05,.1386500E-07,.7561100E-05,.1284300E-04,.1699100E-04,& - & .2002900E-04,.2220800E-04,.2307900E-04,.2183800E-04,.1456500E-05/ - - data absa( 1:180, 3) / & - & .5594800E-06,.4347200E-03,.6568900E-03,.8023700E-03,.9032600E-03,& - & .9599500E-03,.9424200E-03,.8180100E-03,.1838000E-03,.5317500E-06,& - & .4539500E-03,.6877900E-03,.8404000E-03,.9459800E-03,.1001100E-02,& - & .9848100E-03,.8574800E-03,.1956700E-03,.5064800E-06,.4683500E-03,& - & .7140300E-03,.8768400E-03,.9852000E-03,.1039300E-02,.1023300E-02,& - & .8972900E-03,.2072500E-03,.4833000E-06,.4814300E-03,.7397900E-03,& - & .9106300E-03,.1021200E-02,.1076200E-02,.1060000E-02,.9350700E-03,& - & .2181400E-03,.4619500E-06,.4941300E-03,.7647000E-03,.9420800E-03,& - & .1054700E-02,.1109900E-02,.1096000E-02,.9716400E-03,.2305600E-03,& - & .4681300E-06,.3671100E-03,.5574300E-03,.6807000E-03,.7661400E-03,& - & .8144200E-03,.7994000E-03,.6969100E-03,.1498800E-03,.4445000E-06,& - & .3841300E-03,.5850200E-03,.7150600E-03,.8040900E-03,.8519100E-03,& - & .8372200E-03,.7323100E-03,.1598500E-03,.4230100E-06,.3974400E-03,& - & .6085200E-03,.7474100E-03,.8392000E-03,.8858800E-03,.8720600E-03,& - & .7667700E-03,.1696800E-03,.4033500E-06,.4092700E-03,.6320000E-03,& - & .7783500E-03,.8719000E-03,.9184300E-03,.9046700E-03,.7985900E-03,& - & .1794800E-03,.3852900E-06,.4203400E-03,.6535300E-03,.8075800E-03,& - & .9024800E-03,.9492900E-03,.9371500E-03,.8313600E-03,.1901800E-03,& - & .3959100E-06,.3045900E-03,.4636400E-03,.5659000E-03,.6368000E-03,& - & .6768100E-03,.6651700E-03,.5810600E-03,.1193600E-03,.3753800E-06,& - & .3203600E-03,.4887400E-03,.5964900E-03,.6717000E-03,.7116100E-03,& - & .6994300E-03,.6115900E-03,.1280400E-03,.3567500E-06,.3332100E-03,& - & .5099900E-03,.6259100E-03,.7031900E-03,.7433300E-03,.7301500E-03,& - & .6407000E-03,.1364200E-03,.3397800E-06,.3438200E-03,.5310200E-03,& - & .6539100E-03,.7327800E-03,.7730300E-03,.7599000E-03,.6697900E-03,& - & .1447700E-03,.3242200E-06,.3541600E-03,.5507100E-03,.6804200E-03,& - & .7604100E-03,.8011800E-03,.7891400E-03,.6992300E-03,.1536500E-03,& - & .3359800E-06,.2497000E-03,.3805300E-03,.4646400E-03,.5223400E-03,& - & .5548800E-03,.5467500E-03,.4779400E-03,.9527500E-04,.3180000E-06,& - & .2641500E-03,.4031300E-03,.4921000E-03,.5535900E-03,.5866100E-03,& - & .5769400E-03,.5039300E-03,.1029200E-03,.3017700E-06,.2763800E-03,& - & .4226800E-03,.5182300E-03,.5834800E-03,.6159100E-03,.6049700E-03,& - & .5294700E-03,.1101600E-03,.2870300E-06,.2861200E-03,.4416500E-03,& - & .5432600E-03,.6101000E-03,.6429900E-03,.6315100E-03,.5555800E-03,& - & .1170800E-03,.2735600E-06,.2955000E-03,.4590300E-03,.5670300E-03,& - & .6352200E-03,.6683900E-03,.6581200E-03,.5814200E-03,.1244400E-03/ - - data absa(181:315, 3) / & - & .2851700E-06,.2030500E-03,.3094000E-03,.3785400E-03,.4251600E-03,& - & .4516700E-03,.4461700E-03,.3900600E-03,.7639400E-04,.2694300E-06,& - & .2163100E-03,.3294200E-03,.4027900E-03,.4528100E-03,.4795900E-03,& - & .4727400E-03,.4121900E-03,.8309300E-04,.2552600E-06,.2276000E-03,& - & .3473600E-03,.4260300E-03,.4792800E-03,.5057300E-03,.4975300E-03,& - & .4342300E-03,.8913700E-04,.2424500E-06,.2366100E-03,.3642300E-03,& - & .4483200E-03,.5037300E-03,.5302100E-03,.5209200E-03,.4571500E-03,& - & .9502600E-04,.2307900E-06,.2449000E-03,.3797900E-03,.4695800E-03,& - & .5267100E-03,.5536000E-03,.5442200E-03,.4798200E-03,.1010000E-03,& - & .2425800E-06,.1637400E-03,.2488900E-03,.3052600E-03,.3425600E-03,& - & .3643700E-03,.3605400E-03,.3164300E-03,.6098300E-04,.2287300E-06,& - & .1755700E-03,.2667400E-03,.3266200E-03,.3669800E-03,.3886200E-03,& - & .3839500E-03,.3348100E-03,.6671700E-04,.2163200E-06,.1859600E-03,& - & .2831500E-03,.3471000E-03,.3903200E-03,.4118600E-03,.4059700E-03,& - & .3534700E-03,.7180500E-04,.2051500E-06,.1941200E-03,.2982500E-03,& - & .3667200E-03,.4122300E-03,.4337000E-03,.4265400E-03,.3730800E-03,& - & .7695000E-04,.1950000E-06,.2016300E-03,.3117700E-03,.3857300E-03,& - & .4329800E-03,.4547400E-03,.4465900E-03,.3927300E-03,.8185400E-04,& - & .2064400E-06,.1308800E-03,.1988300E-03,.2445300E-03,.2737900E-03,& - & .2913300E-03,.2897200E-03,.2552700E-03,.4848300E-04,.1942200E-06,& - & .1412300E-03,.2146400E-03,.2630700E-03,.2952000E-03,.3126200E-03,& - & .3097600E-03,.2705700E-03,.5318900E-04,.1833400E-06,.1505600E-03,& - & .2294500E-03,.2810200E-03,.3157000E-03,.3333600E-03,.3292100E-03,& - & .2865700E-03,.5766400E-04,.1735900E-06,.1584500E-03,.2425400E-03,& - & .2981200E-03,.3353300E-03,.3527300E-03,.3473700E-03,.3029000E-03,& - & .6208000E-04,.1647600E-06,.1651500E-03,.2547200E-03,.3149200E-03,& - & .3536800E-03,.3713400E-03,.3646600E-03,.3197100E-03,.6628300E-04/ - - data absa(316:450, 3) / & - & .1756400E-06,.1037700E-03,.1579900E-03,.1944300E-03,.2177500E-03,& - & .2322100E-03,.2317800E-03,.2051800E-03,.3861300E-04,.1648600E-06,& - & .1129100E-03,.1717700E-03,.2106000E-03,.2360500E-03,.2502300E-03,& - & .2486000E-03,.2184000E-03,.4257400E-04,.1553200E-06,.1216000E-03,& - & .1847200E-03,.2261300E-03,.2538300E-03,.2681300E-03,.2656900E-03,& - & .2314900E-03,.4643800E-04,.1467900E-06,.1287100E-03,.1962900E-03,& - & .2411700E-03,.2710100E-03,.2854600E-03,.2814800E-03,.2451100E-03,& - & .5013200E-04,.1391300E-06,.1347000E-03,.2071100E-03,.2558300E-03,& - & .2873500E-03,.3017100E-03,.2965300E-03,.2593100E-03,.5389200E-04,& - & .1495000E-06,.8194100E-04,.1247300E-03,.1536300E-03,.1725700E-03,& - & .1840900E-03,.1842400E-03,.1643900E-03,.3077200E-04,.1399800E-06,& - & .8970200E-04,.1365500E-03,.1676300E-03,.1877900E-03,.1991900E-03,& - & .1987700E-03,.1758100E-03,.3402200E-04,.1316000E-06,.9726300E-04,& - & .1477600E-03,.1808900E-03,.2029200E-03,.2145100E-03,.2131700E-03,& - & .1864000E-03,.3738100E-04,.1241500E-06,.1038900E-03,.1581700E-03,& - & .1940400E-03,.2179400E-03,.2298000E-03,.2271500E-03,.1978400E-03,& - & .4045700E-04,.1174900E-06,.1093400E-03,.1676800E-03,.2068000E-03,& - & .2323400E-03,.2441400E-03,.2402600E-03,.2095900E-03,.4358600E-04,& - & .1265800E-06,.6476300E-04,.9869000E-04,.1217000E-03,.1370900E-03,& - & .1464400E-03,.1470900E-03,.1321500E-03,.2473700E-04,.1182600E-06,& - & .7140500E-04,.1087500E-03,.1336800E-03,.1497800E-03,.1590100E-03,& - & .1593700E-03,.1415300E-03,.2748700E-04,.1109700E-06,.7785700E-04,& - & .1184200E-03,.1451000E-03,.1626100E-03,.1720400E-03,.1712900E-03,& - & .1504100E-03,.3025000E-04,.1045100E-06,.8376400E-04,.1276200E-03,& - & .1562500E-03,.1754400E-03,.1851600E-03,.1834500E-03,.1601000E-03,& - & .3289100E-04,.9876700E-07,.8883300E-04,.1359500E-03,.1672300E-03,& - & .1879800E-03,.1976600E-03,.1947700E-03,.1697900E-03,.3554700E-04/ - - data absa(451:585, 3) / & - & .1036800E-06,.5371400E-04,.8174800E-04,.1008500E-03,.1134900E-03,& - & .1212600E-03,.1218000E-03,.1095000E-03,.2078700E-04,.9685400E-07,& - & .5917500E-04,.9013100E-04,.1108500E-03,.1242500E-03,.1316600E-03,& - & .1320700E-03,.1173300E-03,.2302800E-04,.9088200E-07,.6459300E-04,& - & .9827500E-04,.1204100E-03,.1349700E-03,.1427300E-03,.1421500E-03,& - & .1247900E-03,.2536200E-04,.8560200E-07,.6954500E-04,.1059200E-03,& - & .1298200E-03,.1458300E-03,.1538800E-03,.1522800E-03,.1329700E-03,& - & .2758500E-04,.8088900E-07,.7373100E-04,.1129000E-03,.1391400E-03,& - & .1563700E-03,.1643100E-03,.1618900E-03,.1411600E-03,.2982800E-04,& - & .8488600E-07,.4441800E-04,.6764100E-04,.8349000E-04,.9390600E-04,& - & .1003400E-03,.1007500E-03,.9061400E-04,.1735000E-04,.7929700E-07,& - & .4898100E-04,.7465600E-04,.9182100E-04,.1029900E-03,.1089100E-03,& - & .1093300E-03,.9722100E-04,.1923700E-04,.7440800E-07,.5355300E-04,& - & .8150300E-04,.9987200E-04,.1119600E-03,.1183200E-03,.1178200E-03,& - & .1034100E-03,.2118900E-04,.7008500E-07,.5769800E-04,.8788700E-04,& - & .1078100E-03,.1210700E-03,.1277500E-03,.1262400E-03,.1103400E-03,& - & .2303800E-04,.6622600E-07,.6117700E-04,.9369400E-04,.1156700E-03,& - & .1299500E-03,.1364500E-03,.1343600E-03,.1172600E-03,.2491300E-04,& - & .6949900E-07,.3671600E-04,.5590200E-04,.6906700E-04,.7763500E-04,& - & .8293400E-04,.8330200E-04,.7490500E-04,.1441900E-04,.6492300E-07,& - & .4051100E-04,.6177900E-04,.7598400E-04,.8523900E-04,.9009000E-04,& - & .9045600E-04,.8026400E-04,.1599600E-04,.6092000E-07,.4435600E-04,& - & .6753300E-04,.8274600E-04,.9281600E-04,.9801700E-04,.9759000E-04,& - & .8562100E-04,.1762300E-04,.5738100E-07,.4782600E-04,.7287400E-04,& - & .8944300E-04,.1004000E-03,.1058800E-03,.1045600E-03,.9142900E-04,& - & .1914400E-04,.5422100E-07,.5075000E-04,.7769800E-04,.9600500E-04,& - & .1078400E-03,.1131800E-03,.1113900E-03,.9725800E-04,.2067100E-04/ - - data absa( 1:180, 4) / & - & .3665400E-05,.1368900E-02,.2110800E-02,.2631400E-02,.2945800E-02,& - & .3083100E-02,.3020700E-02,.2600300E-02,.9368900E-03,.3530400E-05,& - & .1402500E-02,.2171600E-02,.2707800E-02,.3055100E-02,.3194800E-02,& - & .3164900E-02,.2725800E-02,.9798300E-03,.3405900E-05,.1434000E-02,& - & .2221400E-02,.2777300E-02,.3134800E-02,.3304900E-02,.3283500E-02,& - & .2846100E-02,.1025100E-02,.3289500E-05,.1461000E-02,.2259600E-02,& - & .2831400E-02,.3211300E-02,.3413100E-02,.3392100E-02,.2950800E-02,& - & .1073000E-02,.3181400E-05,.1481400E-02,.2290500E-02,.2878900E-02,& - & .3278500E-02,.3499600E-02,.3495200E-02,.3052800E-02,.1120500E-02,& - & .3029300E-05,.1160000E-02,.1794600E-02,.2237000E-02,.2520500E-02,& - & .2643200E-02,.2617200E-02,.2269100E-02,.7846600E-03,.2917300E-05,& - & .1191600E-02,.1846800E-02,.2307200E-02,.2609400E-02,.2747700E-02,& - & .2738800E-02,.2380900E-02,.8235600E-03,.2815200E-05,.1220300E-02,& - & .1893900E-02,.2369100E-02,.2681400E-02,.2850600E-02,.2841400E-02,& - & .2482500E-02,.8616100E-03,.2720700E-05,.1245400E-02,.1929100E-02,& - & .2418000E-02,.2748900E-02,.2938000E-02,.2934500E-02,.2580800E-02,& - & .9032800E-03,.2631600E-05,.1264400E-02,.1958600E-02,.2462400E-02,& - & .2814600E-02,.3012500E-02,.3023700E-02,.2669500E-02,.9467800E-03,& - & .2528800E-05,.9734800E-03,.1507000E-02,.1879500E-02,.2120600E-02,& - & .2236200E-02,.2221000E-02,.1936900E-02,.6430800E-03,.2435300E-05,& - & .1003100E-02,.1555200E-02,.1944100E-02,.2201300E-02,.2325700E-02,& - & .2328600E-02,.2036200E-02,.6752900E-03,.2349500E-05,.1029500E-02,& - & .1598600E-02,.2001900E-02,.2266300E-02,.2416000E-02,.2420400E-02,& - & .2127600E-02,.7099100E-03,.2269900E-05,.1053300E-02,.1633700E-02,& - & .2048900E-02,.2328800E-02,.2491100E-02,.2501600E-02,.2214800E-02,& - & .7463500E-03,.2195100E-05,.1072400E-02,.1662500E-02,.2089100E-02,& - & .2389600E-02,.2558200E-02,.2581200E-02,.2292500E-02,.7843200E-03,& - & .2116900E-05,.8105300E-03,.1256800E-02,.1564700E-02,.1765400E-02,& - & .1866200E-02,.1856800E-02,.1626900E-02,.5260800E-03,.2040700E-05,& - & .8387500E-03,.1301900E-02,.1625200E-02,.1838300E-02,.1944100E-02,& - & .1953800E-02,.1713900E-02,.5532500E-03,.1967400E-05,.8632900E-03,& - & .1341700E-02,.1678800E-02,.1898500E-02,.2024600E-02,.2031500E-02,& - & .1797800E-02,.5825300E-03,.1899400E-05,.8855100E-03,.1375300E-02,& - & .1723800E-02,.1956600E-02,.2092300E-02,.2103500E-02,.1872400E-02,& - & .6143800E-03,.1835800E-05,.9044200E-03,.1404200E-02,.1761900E-02,& - & .2011900E-02,.2154200E-02,.2174900E-02,.1942500E-02,.6476200E-03/ - - data absa(181:315, 4) / & - & .1772500E-05,.6714600E-03,.1039600E-02,.1293500E-02,.1457600E-02,& - & .1543700E-02,.1534100E-02,.1353200E-02,.4298100E-03,.1709500E-05,& - & .6977400E-03,.1082300E-02,.1347700E-02,.1522700E-02,.1611700E-02,& - & .1622200E-02,.1430200E-02,.4528600E-03,.1647800E-05,.7204400E-03,& - & .1119000E-02,.1396700E-02,.1578300E-02,.1681700E-02,.1689700E-02,& - & .1504000E-02,.4778200E-03,.1589600E-05,.7413600E-03,.1151200E-02,& - & .1439400E-02,.1630700E-02,.1743500E-02,.1753600E-02,.1568700E-02,& - & .5046800E-03,.1535300E-05,.7597700E-03,.1179000E-02,.1475500E-02,& - & .1681100E-02,.1799000E-02,.1817500E-02,.1627900E-02,.5335300E-03,& - & .1485600E-05,.5516300E-03,.8518200E-03,.1058300E-02,.1193300E-02,& - & .1263300E-02,.1251900E-02,.1112600E-02,.3496900E-03,.1432300E-05,& - & .5753400E-03,.8921100E-03,.1108400E-02,.1251000E-02,.1324800E-02,& - & .1330200E-02,.1181500E-02,.3689300E-03,.1381800E-05,.5970500E-03,& - & .9255200E-03,.1153000E-02,.1301800E-02,.1386000E-02,.1394200E-02,& - & .1243700E-02,.3899100E-03,.1331700E-05,.6167100E-03,.9556800E-03,& - & .1192200E-02,.1348100E-02,.1442600E-02,.1450800E-02,.1300100E-02,& - & .4124800E-03,.1285100E-05,.6341400E-03,.9822700E-03,.1226500E-02,& - & .1393600E-02,.1491300E-02,.1506400E-02,.1351200E-02,.4369600E-03,& - & .1245300E-05,.4498200E-03,.6928600E-03,.8585700E-03,.9711500E-03,& - & .1026800E-02,.1013200E-02,.9066100E-03,.2833300E-03,.1199700E-05,& - & .4716300E-03,.7298400E-03,.9052500E-03,.1020900E-02,.1083000E-02,& - & .1081500E-02,.9682000E-03,.2999100E-03,.1157100E-05,.4917000E-03,& - & .7606400E-03,.9459700E-03,.1068300E-02,.1133700E-02,.1141800E-02,& - & .1021000E-02,.3173800E-03,.1115700E-05,.5096400E-03,.7885900E-03,& - & .9823600E-03,.1108800E-02,.1185900E-02,.1192000E-02,.1069000E-02,& - & .3360000E-03,.1075700E-05,.5257800E-03,.8133000E-03,.1014100E-02,& - & .1149300E-02,.1228500E-02,.1239900E-02,.1115100E-02,.3563100E-03/ - - data absa(316:450, 4) / & - & .1043600E-05,.3647500E-03,.5594800E-03,.6939900E-03,.7869900E-03,& - & .8273300E-03,.8154600E-03,.7344300E-03,.2287400E-03,.1004300E-05,& - & .3846100E-03,.5936500E-03,.7363100E-03,.8290200E-03,.8799600E-03,& - & .8758900E-03,.7874500E-03,.2428100E-03,.9678500E-06,.4022700E-03,& - & .6219100E-03,.7718300E-03,.8706700E-03,.9233800E-03,.9311600E-03,& - & .8333400E-03,.2573500E-03,.9336700E-06,.4188100E-03,.6469700E-03,& - & .8047400E-03,.9075400E-03,.9680600E-03,.9743400E-03,.8743900E-03,& - & .2728600E-03,.9001700E-06,.4337700E-03,.6702600E-03,.8339800E-03,& - & .9426900E-03,.1008000E-02,.1015400E-02,.9147900E-03,.2894800E-03,& - & .8746900E-06,.2934500E-03,.4485700E-03,.5565300E-03,.6337100E-03,& - & .6625300E-03,.6522900E-03,.5900900E-03,.1847500E-03,.8406200E-06,& - & .3115200E-03,.4797500E-03,.5942200E-03,.6707700E-03,.7116800E-03,& - & .7055000E-03,.6367400E-03,.1966900E-03,.8094700E-06,.3277900E-03,& - & .5058200E-03,.6270700E-03,.7070500E-03,.7493600E-03,.7525200E-03,& - & .6768200E-03,.2089600E-03,.7805200E-06,.3426200E-03,.5282000E-03,& - & .6563100E-03,.7400200E-03,.7873100E-03,.7925700E-03,.7115500E-03,& - & .2219700E-03,.7530000E-06,.3561800E-03,.5494000E-03,.6823600E-03,& - & .7697800E-03,.8227100E-03,.8280600E-03,.7465800E-03,.2358800E-03,& - & .7308000E-06,.2361900E-03,.3600200E-03,.4476900E-03,.5100100E-03,& - & .5329400E-03,.5231900E-03,.4749200E-03,.1500500E-03,.7014200E-06,& - & .2522500E-03,.3874200E-03,.4803900E-03,.5428500E-03,.5740700E-03,& - & .5676500E-03,.5144400E-03,.1600000E-03,.6748400E-06,.2668700E-03,& - & .4111900E-03,.5092400E-03,.5737200E-03,.6091200E-03,.6081300E-03,& - & .5494500E-03,.1703600E-03,.6503200E-06,.2800200E-03,.4310400E-03,& - & .5351300E-03,.6029400E-03,.6399800E-03,.6448500E-03,.5788800E-03,& - & .1812000E-03,.6275200E-06,.2918200E-03,.4495000E-03,.5583600E-03,& - & .6284900E-03,.6714800E-03,.6757000E-03,.6091800E-03,.1927100E-03/ - - data absa(451:585, 4) / & - & .5984600E-06,.1960300E-03,.2990200E-03,.3715900E-03,.4236700E-03,& - & .4424100E-03,.4355000E-03,.3961800E-03,.1249800E-03,.5744700E-06,& - & .2095300E-03,.3218700E-03,.3988200E-03,.4502100E-03,.4771700E-03,& - & .4724000E-03,.4289400E-03,.1336200E-03,.5526500E-06,.2218500E-03,& - & .3413300E-03,.4228300E-03,.4761600E-03,.5048100E-03,.5055300E-03,& - & .4565400E-03,.1424600E-03,.5325900E-06,.2330100E-03,.3581600E-03,& - & .4444800E-03,.5004800E-03,.5314700E-03,.5357400E-03,.4816900E-03,& - & .1516800E-03,.5137900E-06,.2430200E-03,.3738300E-03,.4635200E-03,& - & .5220300E-03,.5578300E-03,.5617500E-03,.5073700E-03,.1615300E-03,& - & .4900600E-06,.1625900E-03,.2480200E-03,.3080400E-03,.3511100E-03,& - & .3667200E-03,.3616600E-03,.3296800E-03,.1040100E-03,.4703300E-06,& - & .1737900E-03,.2669700E-03,.3306900E-03,.3729200E-03,.3958700E-03,& - & .3923900E-03,.3567200E-03,.1113800E-03,.4524700E-06,.1841700E-03,& - & .2829500E-03,.3504500E-03,.3946500E-03,.4182500E-03,.4198400E-03,& - & .3786700E-03,.1188200E-03,.4360500E-06,.1935100E-03,.2971600E-03,& - & .3685000E-03,.4148900E-03,.4407400E-03,.4446000E-03,.4003100E-03,& - & .1266700E-03,.4206600E-06,.2020600E-03,.3103800E-03,.3846400E-03,& - & .4333700E-03,.4629700E-03,.4666700E-03,.4220200E-03,.1349800E-03,& - & .4012200E-06,.1346500E-03,.2054100E-03,.2548800E-03,.2900600E-03,& - & .3035800E-03,.2998400E-03,.2737500E-03,.8640600E-04,.3850200E-06,& - & .1439800E-03,.2208600E-03,.2737600E-03,.3083200E-03,.3279400E-03,& - & .3251700E-03,.2956200E-03,.9261400E-04,.3704500E-06,.1526600E-03,& - & .2341600E-03,.2901300E-03,.3267500E-03,.3462200E-03,.3481600E-03,& - & .3140100E-03,.9888000E-04,.3570200E-06,.1605000E-03,.2460800E-03,& - & .3052100E-03,.3433600E-03,.3652200E-03,.3685700E-03,.3324600E-03,& - & .1055900E-03,.3444000E-06,.1677100E-03,.2574200E-03,.3190400E-03,& - & .3594300E-03,.3840500E-03,.3871500E-03,.3508700E-03,.1126200E-03/ - - data absa( 1:180, 5) / & - & .1558300E-03,.3754600E-02,.5353600E-02,.6416100E-02,.7122300E-02,& - & .7498200E-02,.7359600E-02,.6513500E-02,.3517500E-02,.1614800E-03,& - & .3856900E-02,.5525600E-02,.6646100E-02,.7375700E-02,.7753000E-02,& - & .7566500E-02,.6649600E-02,.3684000E-02,.1648400E-03,.3935300E-02,& - & .5674500E-02,.6836400E-02,.7616600E-02,.7971100E-02,.7771700E-02,& - & .6784600E-02,.3848500E-02,.1662100E-03,.3994600E-02,.5794700E-02,& - & .7007100E-02,.7819300E-02,.8158100E-02,.7959200E-02,.6913200E-02,& - & .3976900E-02,.1651800E-03,.4038600E-02,.5892500E-02,.7153000E-02,& - & .7994600E-02,.8325800E-02,.8110700E-02,.7022600E-02,.4113400E-02,& - & .1248200E-03,.3220400E-02,.4610200E-02,.5547500E-02,.6173000E-02,& - & .6500000E-02,.6394200E-02,.5639400E-02,.3000200E-02,.1302700E-03,& - & .3309900E-02,.4761700E-02,.5749700E-02,.6403100E-02,.6718400E-02,& - & .6582900E-02,.5772100E-02,.3144200E-02,.1337000E-03,.3380800E-02,& - & .4884500E-02,.5923500E-02,.6607400E-02,.6904800E-02,.6766000E-02,& - & .5901800E-02,.3278800E-02,.1354900E-03,.3434000E-02,.4988500E-02,& - & .6074500E-02,.6787700E-02,.7078000E-02,.6920200E-02,.6013100E-02,& - & .3394600E-02,.1354300E-03,.3477800E-02,.5074500E-02,.6198100E-02,& - & .6928200E-02,.7222900E-02,.7052100E-02,.6121800E-02,.3509700E-02,& - & .9843700E-04,.2720900E-02,.3903500E-02,.4718500E-02,.5270600E-02,& - & .5557900E-02,.5484600E-02,.4846900E-02,.2507700E-02,.1039600E-03,& - & .2803100E-02,.4038400E-02,.4899300E-02,.5475300E-02,.5757500E-02,& - & .5652500E-02,.4968400E-02,.2636600E-02,.1077000E-03,.2870200E-02,& - & .4151300E-02,.5050400E-02,.5664000E-02,.5924500E-02,.5812500E-02,& - & .5092200E-02,.2747800E-02,.1099600E-03,.2923200E-02,.4245100E-02,& - & .5183800E-02,.5825700E-02,.6079300E-02,.5949800E-02,.5194900E-02,& - & .2849000E-02,.1108800E-03,.2964500E-02,.4325100E-02,.5299200E-02,& - & .5946800E-02,.6209600E-02,.6064800E-02,.5290400E-02,.2949500E-02,& - & .7658700E-04,.2279200E-02,.3273100E-02,.3972400E-02,.4456100E-02,& - & .4710900E-02,.4670600E-02,.4144400E-02,.2081000E-02,.8222500E-04,& - & .2354800E-02,.3394300E-02,.4132500E-02,.4641500E-02,.4893900E-02,& - & .4820000E-02,.4259100E-02,.2192500E-02,.8620300E-04,.2418000E-02,& - & .3499100E-02,.4268400E-02,.4807400E-02,.5041600E-02,.4965100E-02,& - & .4364300E-02,.2293800E-02,.8876600E-04,.2469400E-02,.3587400E-02,& - & .4387500E-02,.4946900E-02,.5181000E-02,.5085000E-02,.4460600E-02,& - & .2379100E-02,.9021800E-04,.2511000E-02,.3661300E-02,.4493700E-02,& - & .5054800E-02,.5298200E-02,.5188300E-02,.4549800E-02,.2465800E-02/ - - data absa(181:315, 5) / & - & .5908000E-04,.1897200E-02,.2729400E-02,.3319500E-02,.3739500E-02,& - & .3968300E-02,.3952300E-02,.3516100E-02,.1719500E-02,.6450800E-04,& - & .1967300E-02,.2837600E-02,.3463200E-02,.3903300E-02,.4134300E-02,& - & .4082600E-02,.3619500E-02,.1817300E-02,.6853800E-04,.2026400E-02,& - & .2934200E-02,.3585600E-02,.4048800E-02,.4266400E-02,.4214100E-02,& - & .3714400E-02,.1908100E-02,.7132800E-04,.2075000E-02,.3016500E-02,& - & .3693300E-02,.4171900E-02,.4388000E-02,.4322100E-02,.3800600E-02,& - & .1981800E-02,.7307300E-04,.2115500E-02,.3086100E-02,.3789200E-02,& - & .4269000E-02,.4490100E-02,.4416100E-02,.3886400E-02,.2058300E-02,& - & .4506900E-04,.1567300E-02,.2259600E-02,.2756600E-02,.3111700E-02,& - & .3316200E-02,.3313500E-02,.2957400E-02,.1408900E-02,.4995900E-04,& - & .1634200E-02,.2357700E-02,.2882800E-02,.3257200E-02,.3462600E-02,& - & .3430200E-02,.3047600E-02,.1495500E-02,.5401300E-04,.1689100E-02,& - & .2445700E-02,.2992600E-02,.3386500E-02,.3580900E-02,.3542700E-02,& - & .3135800E-02,.1576300E-02,.5691000E-04,.1735600E-02,.2522000E-02,& - & .3090300E-02,.3496800E-02,.3685300E-02,.3644300E-02,.3214000E-02,& - & .1642800E-02,.5885200E-04,.1774300E-02,.2586800E-02,.3177100E-02,& - & .3585700E-02,.3778200E-02,.3728400E-02,.3290500E-02,.1707900E-02,& - & .3413100E-04,.1287300E-02,.1861900E-02,.2274500E-02,.2568800E-02,& - & .2749400E-02,.2757400E-02,.2465800E-02,.1144400E-02,.3837900E-04,& - & .1350300E-02,.1949000E-02,.2386900E-02,.2698500E-02,.2876100E-02,& - & .2860700E-02,.2544300E-02,.1224200E-02,.4214600E-04,.1401800E-02,& - & .2028700E-02,.2484300E-02,.2811900E-02,.2984800E-02,.2956900E-02,& - & .2625800E-02,.1295600E-02,.4511600E-04,.1445400E-02,.2098900E-02,& - & .2571800E-02,.2911500E-02,.3074000E-02,.3048200E-02,.2696700E-02,& - & .1353700E-02,.4717800E-04,.1481800E-02,.2159100E-02,.2650900E-02,& - & .2994500E-02,.3159000E-02,.3123500E-02,.2764100E-02,.1410000E-02/ - - data absa(316:450, 5) / & - & .2565600E-04,.1052500E-02,.1526600E-02,.1864800E-02,.2106000E-02,& - & .2266000E-02,.2280700E-02,.2041500E-02,.9248200E-03,.2931300E-04,& - & .1109600E-02,.1602700E-02,.1962800E-02,.2222400E-02,.2373000E-02,& - & .2368300E-02,.2111100E-02,.9936600E-03,.3264300E-04,.1157900E-02,& - & .1673200E-02,.2050300E-02,.2323100E-02,.2472100E-02,.2451200E-02,& - & .2184200E-02,.1057000E-02,.3550900E-04,.1198500E-02,.1737900E-02,& - & .2128400E-02,.2411000E-02,.2551900E-02,.2533900E-02,.2249600E-02,& - & .1111600E-02,.3761600E-04,.1232700E-02,.1793300E-02,.2199600E-02,& - & .2488000E-02,.2625800E-02,.2602900E-02,.2308800E-02,.1159500E-02,& - & .1916600E-04,.8555900E-03,.1244600E-02,.1521300E-02,.1716000E-02,& - & .1852700E-02,.1872300E-02,.1679400E-02,.7431600E-03,.2225100E-04,& - & .9070100E-03,.1310700E-02,.1606100E-02,.1817700E-02,.1945200E-02,& - & .1949600E-02,.1742000E-02,.8016800E-03,.2512300E-04,.9510600E-03,& - & .1372400E-02,.1682600E-02,.1906400E-02,.2035200E-02,.2024100E-02,& - & .1806400E-02,.8565900E-03,.2771300E-04,.9890300E-03,.1430100E-02,& - & .1752300E-02,.1986200E-02,.2107900E-02,.2094400E-02,.1865600E-02,& - & .9065500E-03,.2982100E-04,.1020700E-02,.1481300E-02,.1816300E-02,& - & .2057000E-02,.2173700E-02,.2157400E-02,.1915300E-02,.9488200E-03,& - & .1445500E-04,.6950800E-03,.1014300E-02,.1238200E-02,.1397700E-02,& - & .1510100E-02,.1533900E-02,.1379400E-02,.6006400E-03,.1697500E-04,& - & .7405500E-03,.1071500E-02,.1311700E-02,.1485100E-02,.1593800E-02,& - & .1602600E-02,.1435400E-02,.6503400E-03,.1942100E-04,.7799600E-03,& - & .1124300E-02,.1379100E-02,.1563600E-02,.1670700E-02,.1667800E-02,& - & .1490800E-02,.6987500E-03,.2165900E-04,.8136900E-03,.1174600E-02,& - & .1440800E-02,.1634000E-02,.1737600E-02,.1726700E-02,.1541800E-02,& - & .7433600E-03,.2361600E-04,.8431600E-03,.1221500E-02,.1497200E-02,& - & .1697100E-02,.1794500E-02,.1783400E-02,.1584400E-02,.7804500E-03/ - - data absa(451:585, 5) / & - & .1181200E-04,.5806700E-03,.8465800E-03,.1034900E-02,.1168100E-02,& - & .1262200E-02,.1280600E-02,.1151800E-02,.5019700E-03,.1387000E-04,& - & .6187000E-03,.8936400E-03,.1095700E-02,.1241100E-02,.1330700E-02,& - & .1336600E-02,.1199000E-02,.5441900E-03,.1587200E-04,.6513100E-03,& - & .9384300E-03,.1152000E-02,.1306800E-02,.1396600E-02,.1392700E-02,& - & .1245900E-02,.5841200E-03,.1770600E-04,.6795700E-03,.9812800E-03,& - & .1203700E-02,.1365300E-02,.1451000E-02,.1442300E-02,.1287300E-02,& - & .6208600E-03,.1930700E-04,.7047700E-03,.1020800E-02,.1252200E-02,& - & .1418700E-02,.1500000E-02,.1488200E-02,.1322300E-02,.6527300E-03,& - & .9663300E-05,.4838400E-03,.7046400E-03,.8621400E-03,.9732500E-03,& - & .1052500E-02,.1066100E-02,.9581800E-03,.4183800E-03,.1134600E-04,& - & .5154400E-03,.7437500E-03,.9125500E-03,.1034600E-02,.1108800E-02,& - & .1112400E-02,.9978700E-03,.4543600E-03,.1298300E-04,.5425800E-03,& - & .7819100E-03,.9599400E-03,.1089300E-02,.1163600E-02,.1159500E-02,& - & .1037900E-02,.4876700E-03,.1448300E-04,.5666200E-03,.8179500E-03,& - & .1003600E-02,.1138500E-02,.1209100E-02,.1201200E-02,.1070700E-02,& - & .5181000E-03,.1579000E-04,.5880500E-03,.8516500E-03,.1044700E-02,& - & .1183000E-02,.1250000E-02,.1238900E-02,.1101200E-02,.5450800E-03,& - & .7905700E-05,.4021500E-03,.5851600E-03,.7166600E-03,.8096900E-03,& - & .8751800E-03,.8858100E-03,.7956900E-03,.3482500E-03,.9280800E-05,& - & .4285300E-03,.6181800E-03,.7584700E-03,.8608200E-03,.9216000E-03,& - & .9243600E-03,.8289400E-03,.3787100E-03,.1062100E-04,.4513400E-03,& - & .6502800E-03,.7981500E-03,.9062200E-03,.9675200E-03,.9629100E-03,& - & .8617700E-03,.4064200E-03,.1184900E-04,.4716100E-03,.6809000E-03,& - & .8353000E-03,.9477000E-03,.1005400E-02,.9981500E-03,.8890800E-03,& - & .4314900E-03,.1289700E-04,.4900000E-03,.7094400E-03,.8698200E-03,& - & .9843000E-03,.1039800E-02,.1029700E-02,.9148300E-03,.4545900E-03/ - - data absa( 1:180, 6) / & - & .2357500E-02,.9645700E-02,.1312800E-01,.1536100E-01,.1666200E-01,& - & .1699900E-01,.1630300E-01,.1436800E-01,.1018500E-01,.2450800E-02,& - & .9976800E-02,.1356200E-01,.1578600E-01,.1704600E-01,.1731600E-01,& - & .1653900E-01,.1462700E-01,.1044700E-01,.2517600E-02,.1026200E-01,& - & .1394700E-01,.1618200E-01,.1739000E-01,.1758800E-01,.1675200E-01,& - & .1485700E-01,.1069900E-01,.2562700E-02,.1051000E-01,.1427100E-01,& - & .1651700E-01,.1767800E-01,.1781500E-01,.1694100E-01,.1507300E-01,& - & .1097000E-01,.2590400E-02,.1071200E-01,.1452800E-01,.1678800E-01,& - & .1791200E-01,.1801300E-01,.1712600E-01,.1528200E-01,.1121500E-01,& - & .1942200E-02,.8517900E-02,.1160300E-01,.1356100E-01,.1469400E-01,& - & .1495200E-01,.1427400E-01,.1261600E-01,.8691000E-02,.2023100E-02,& - & .8820800E-02,.1199200E-01,.1394200E-01,.1504300E-01,.1524100E-01,& - & .1450300E-01,.1284900E-01,.8920300E-02,.2082400E-02,.9089200E-02,& - & .1233300E-01,.1428300E-01,.1534300E-01,.1549300E-01,.1470400E-01,& - & .1306500E-01,.9141200E-02,.2123500E-02,.9319300E-02,.1261300E-01,& - & .1457300E-01,.1558600E-01,.1569600E-01,.1490000E-01,.1326900E-01,& - & .9373100E-02,.2150100E-02,.9506400E-02,.1284400E-01,.1480200E-01,& - & .1578900E-01,.1587200E-01,.1507900E-01,.1345900E-01,.9592200E-02,& - & .1571000E-02,.7373900E-02,.1008400E-01,.1179500E-01,.1279100E-01,& - & .1300200E-01,.1240800E-01,.1094800E-01,.7325600E-02,.1644500E-02,& - & .7660300E-02,.1044100E-01,.1213600E-01,.1309800E-01,.1327200E-01,& - & .1262900E-01,.1116900E-01,.7527700E-02,.1701600E-02,.7912000E-02,& - & .1073800E-01,.1244400E-01,.1336500E-01,.1350200E-01,.1282700E-01,& - & .1136500E-01,.7727500E-02,.1741900E-02,.8120400E-02,.1099200E-01,& - & .1270400E-01,.1357900E-01,.1368700E-01,.1302200E-01,.1156500E-01,& - & .7932700E-02,.1769300E-02,.8289600E-02,.1120100E-01,.1290300E-01,& - & .1376100E-01,.1385400E-01,.1319300E-01,.1176000E-01,.8132400E-02,& - & .1256800E-02,.6292500E-02,.8657000E-02,.1015600E-01,.1102000E-01,& - & .1122000E-01,.1071000E-01,.9432900E-02,.6181200E-02,.1324200E-02,& - & .6553200E-02,.8975600E-02,.1046000E-01,.1129200E-01,.1146300E-01,& - & .1092400E-01,.9644900E-02,.6362000E-02,.1378200E-02,.6780700E-02,& - & .9244700E-02,.1073900E-01,.1153100E-01,.1167600E-01,.1111500E-01,& - & .9838400E-02,.6541700E-02,.1418500E-02,.6972800E-02,.9472400E-02,& - & .1096700E-01,.1173200E-01,.1185300E-01,.1129900E-01,.1002900E-01,& - & .6731400E-02,.1446600E-02,.7129400E-02,.9655100E-02,.1115000E-01,& - & .1189700E-01,.1200300E-01,.1145700E-01,.1021200E-01,.6913400E-02/ - - data absa(181:315, 6) / & - & .9981500E-03,.5318400E-02,.7366800E-02,.8666100E-02,.9418900E-02,& - & .9608800E-02,.9186000E-02,.8085400E-02,.5214700E-02,.1059400E-02,& - & .5550200E-02,.7648000E-02,.8938200E-02,.9667500E-02,.9828100E-02,& - & .9390800E-02,.8290400E-02,.5380500E-02,.1109300E-02,.5753400E-02,& - & .7882000E-02,.9187300E-02,.9886000E-02,.1002700E-01,.9573900E-02,& - & .8477400E-02,.5539800E-02,.1148700E-02,.5926400E-02,.8074600E-02,& - & .9395200E-02,.1007000E-01,.1019600E-01,.9746000E-02,.8658600E-02,& - & .5711800E-02,.1177000E-02,.6071500E-02,.8232200E-02,.9559000E-02,& - & .1022500E-01,.1033700E-01,.9889100E-02,.8828200E-02,.5875600E-02,& - & .7848400E-03,.4455700E-02,.6208800E-02,.7323800E-02,.7975800E-02,& - & .8156500E-02,.7823400E-02,.6894900E-02,.4372100E-02,.8410400E-03,& - & .4658400E-02,.6454800E-02,.7572000E-02,.8204900E-02,.8360300E-02,& - & .8013900E-02,.7091200E-02,.4520800E-02,.8870300E-03,.4838600E-02,& - & .6658500E-02,.7793900E-02,.8407700E-02,.8549400E-02,.8187800E-02,& - & .7267300E-02,.4666400E-02,.9242900E-03,.4993900E-02,.6825500E-02,& - & .7979300E-02,.8581100E-02,.8712300E-02,.8342300E-02,.7432400E-02,& - & .4819300E-02,.9528700E-03,.5126900E-02,.6966400E-02,.8121600E-02,& - & .8725600E-02,.8840400E-02,.8479300E-02,.7588500E-02,.4968400E-02,& - & .6117600E-03,.3710500E-02,.5192100E-02,.6149500E-02,.6708600E-02,& - & .6873700E-02,.6619600E-02,.5849900E-02,.3639800E-02,.6635500E-03,& - & .3884500E-02,.5409200E-02,.6368400E-02,.6919100E-02,.7063800E-02,& - & .6796700E-02,.6032900E-02,.3772500E-02,.7058400E-03,.4042900E-02,& - & .5589100E-02,.6566500E-02,.7106100E-02,.7239200E-02,.6956600E-02,& - & .6195800E-02,.3904000E-02,.7401600E-03,.4180400E-02,.5736200E-02,& - & .6730600E-02,.7265600E-02,.7393900E-02,.7100200E-02,.6345800E-02,& - & .4042200E-02,.7679300E-03,.4301300E-02,.5863400E-02,.6860500E-02,& - & .7391700E-02,.7516000E-02,.7229200E-02,.6486700E-02,.4175300E-02/ - - data absa(316:450, 6) / & - & .4738300E-03,.3071900E-02,.4315700E-02,.5129900E-02,.5611300E-02,& - & .5760400E-02,.5558400E-02,.4926300E-02,.3009900E-02,.5203000E-03,& - & .3222400E-02,.4508800E-02,.5325600E-02,.5804900E-02,.5936900E-02,& - & .5724900E-02,.5095000E-02,.3133500E-02,.5589700E-03,.3360100E-02,& - & .4669000E-02,.5500800E-02,.5973300E-02,.6098200E-02,.5870300E-02,& - & .5241600E-02,.3250500E-02,.5905100E-03,.3482300E-02,.4800300E-02,& - & .5649200E-02,.6114700E-02,.6240700E-02,.6001100E-02,.5377600E-02,& - & .3369100E-02,.6163800E-03,.3590800E-02,.4915100E-02,.5768200E-02,& - & .6226900E-02,.6350500E-02,.6122600E-02,.5506100E-02,.3489300E-02,& - & .3645200E-03,.2530100E-02,.3565500E-02,.4255800E-02,.4666800E-02,& - & .4799500E-02,.4639100E-02,.4117600E-02,.2472300E-02,.4052100E-03,& - & .2660900E-02,.3736800E-02,.4431300E-02,.4842200E-02,.4960500E-02,& - & .4787600E-02,.4268200E-02,.2585400E-02,.4404200E-03,.2781100E-02,& - & .3882200E-02,.4587100E-02,.4995100E-02,.5104800E-02,.4918900E-02,& - & .4398800E-02,.2692200E-02,.4693400E-03,.2889000E-02,.4001500E-02,& - & .4720400E-02,.5119500E-02,.5232900E-02,.5039800E-02,.4521100E-02,& - & .2794700E-02,.4929600E-03,.2986300E-02,.4105200E-02,.4829600E-02,& - & .5221200E-02,.5332000E-02,.5151600E-02,.4641000E-02,.2901400E-02,& - & .2814100E-03,.2083900E-02,.2943400E-02,.3525000E-02,.3870500E-02,& - & .3990700E-02,.3857400E-02,.3428000E-02,.2027600E-02,.3164200E-03,& - & .2196200E-02,.3094700E-02,.3679800E-02,.4027900E-02,.4131700E-02,& - & .3990500E-02,.3559100E-02,.2130400E-02,.3474300E-03,.2300200E-02,& - & .3225100E-02,.3816700E-02,.4163200E-02,.4258800E-02,.4107700E-02,& - & .3673700E-02,.2224600E-02,.3733700E-03,.2395800E-02,.3332600E-02,& - & .3935100E-02,.4272700E-02,.4369900E-02,.4216700E-02,.3785000E-02,& - & .2317100E-02,.3946400E-03,.2481800E-02,.3424500E-02,.4034100E-02,& - & .4363500E-02,.4459200E-02,.4313300E-02,.3893100E-02,.2412300E-02/ - - data absa(451:585, 6) / & - & .2304600E-03,.1756100E-02,.2482100E-02,.2969700E-02,.3260300E-02,& - & .3359000E-02,.3246500E-02,.2891100E-02,.1700000E-02,.2590000E-03,& - & .1849900E-02,.2607900E-02,.3098300E-02,.3391400E-02,.3479000E-02,& - & .3359800E-02,.3000000E-02,.1787900E-02,.2843100E-03,.1937100E-02,& - & .2715400E-02,.3212300E-02,.3500900E-02,.3581000E-02,.3458200E-02,& - & .3098900E-02,.1870900E-02,.3055400E-03,.2017500E-02,.2804700E-02,& - & .3309400E-02,.3589700E-02,.3670800E-02,.3550000E-02,.3196400E-02,& - & .1952400E-02,.3229000E-03,.2090600E-02,.2882700E-02,.3390700E-02,& - & .3663800E-02,.3744800E-02,.3632200E-02,.3292100E-02,.2034200E-02,& - & .1887300E-03,.1475300E-02,.2085900E-02,.2493200E-02,.2736200E-02,& - & .2816300E-02,.2723100E-02,.2428700E-02,.1422600E-02,.2120600E-03,& - & .1554200E-02,.2190500E-02,.2599700E-02,.2843600E-02,.2914600E-02,& - & .2818200E-02,.2519600E-02,.1496400E-02,.2327100E-03,.1628200E-02,& - & .2278900E-02,.2693700E-02,.2932000E-02,.2999500E-02,.2900400E-02,& - & .2606300E-02,.1568400E-02,.2500500E-03,.1695900E-02,.2353900E-02,& - & .2773900E-02,.3005200E-02,.3073800E-02,.2978100E-02,.2692400E-02,& - & .1638800E-02,.2642400E-03,.1757900E-02,.2419800E-02,.2841800E-02,& - & .3068800E-02,.3137000E-02,.3047800E-02,.2773400E-02,.1709000E-02,& - & .1545100E-03,.1236200E-02,.1747100E-02,.2085600E-02,.2287000E-02,& - & .2353000E-02,.2275800E-02,.2031800E-02,.1186800E-02,.1735700E-03,& - & .1302700E-02,.1833700E-02,.2173600E-02,.2375200E-02,.2433900E-02,& - & .2354900E-02,.2110400E-02,.1249200E-02,.1904500E-03,.1365100E-02,& - & .1907100E-02,.2252000E-02,.2447900E-02,.2505200E-02,.2425500E-02,& - & .2186200E-02,.1311400E-02,.2045900E-03,.1422500E-02,.1970200E-02,& - & .2319500E-02,.2510900E-02,.2568000E-02,.2490600E-02,.2259200E-02,& - & .1371700E-02,.2162100E-03,.1475100E-02,.2026700E-02,.2377500E-02,& - & .2565400E-02,.2622100E-02,.2551300E-02,.2328300E-02,.1432100E-02/ - - data absa( 1:180, 7) / & - & .1455100E-01,.2628200E-01,.3205300E-01,.3518900E-01,.3660000E-01,& - & .3664600E-01,.3555200E-01,.3321500E-01,.2730900E-01,.1536000E-01,& - & .2684700E-01,.3241100E-01,.3542600E-01,.3680300E-01,.3699400E-01,& - & .3603700E-01,.3367400E-01,.2788100E-01,.1605200E-01,.2735800E-01,& - & .3271100E-01,.3560200E-01,.3700200E-01,.3732200E-01,.3649500E-01,& - & .3409200E-01,.2836500E-01,.1663400E-01,.2776500E-01,.3297500E-01,& - & .3575700E-01,.3719800E-01,.3762900E-01,.3687100E-01,.3448900E-01,& - & .2881700E-01,.1709200E-01,.2808800E-01,.3317300E-01,.3589900E-01,& - & .3736900E-01,.3789400E-01,.3720600E-01,.3485600E-01,.2923600E-01,& - & .1267500E-01,.2375700E-01,.2882700E-01,.3147500E-01,.3264700E-01,& - & .3277900E-01,.3187400E-01,.2965900E-01,.2373500E-01,.1336300E-01,& - & .2426100E-01,.2916500E-01,.3173400E-01,.3290500E-01,.3313700E-01,& - & .3235700E-01,.3011400E-01,.2424100E-01,.1395200E-01,.2467300E-01,& - & .2945800E-01,.3194000E-01,.3316700E-01,.3348600E-01,.3279400E-01,& - & .3054000E-01,.2470400E-01,.1444000E-01,.2501000E-01,.2969200E-01,& - & .3213100E-01,.3340200E-01,.3381600E-01,.3318500E-01,.3094400E-01,& - & .2512300E-01,.1481000E-01,.2524600E-01,.2986500E-01,.3232300E-01,& - & .3362400E-01,.3412500E-01,.3353000E-01,.3129900E-01,.2550100E-01,& - & .1076400E-01,.2118000E-01,.2564500E-01,.2793400E-01,.2889100E-01,& - & .2897800E-01,.2821500E-01,.2625000E-01,.2034000E-01,.1137100E-01,& - & .2161100E-01,.2597600E-01,.2822100E-01,.2920400E-01,.2934700E-01,& - & .2868900E-01,.2668700E-01,.2080300E-01,.1188200E-01,.2197700E-01,& - & .2625800E-01,.2846700E-01,.2949800E-01,.2973000E-01,.2911300E-01,& - & .2711500E-01,.2124100E-01,.1230200E-01,.2227300E-01,.2647700E-01,& - & .2869600E-01,.2976600E-01,.3009900E-01,.2950700E-01,.2750300E-01,& - & .2162000E-01,.1262400E-01,.2248100E-01,.2663100E-01,.2890000E-01,& - & .3003200E-01,.3042500E-01,.2985900E-01,.2784200E-01,.2196600E-01,& - & .8986000E-02,.1865900E-01,.2260500E-01,.2458000E-01,.2538300E-01,& - & .2543500E-01,.2476100E-01,.2303700E-01,.1741400E-01,.9520700E-02,& - & .1904800E-01,.2292400E-01,.2488800E-01,.2573900E-01,.2582300E-01,& - & .2520000E-01,.2345000E-01,.1784700E-01,.9972300E-02,.1938000E-01,& - & .2318200E-01,.2515500E-01,.2606100E-01,.2620900E-01,.2561100E-01,& - & .2386200E-01,.1825100E-01,.1035400E-01,.1964400E-01,.2339700E-01,& - & .2540100E-01,.2634500E-01,.2658000E-01,.2600000E-01,.2423300E-01,& - & .1860000E-01,.1063700E-01,.1982200E-01,.2355600E-01,.2560500E-01,& - & .2661900E-01,.2691300E-01,.2635900E-01,.2456200E-01,.1892500E-01/ - - data absa(181:315, 7) / & - & .7410400E-02,.1626400E-01,.1971700E-01,.2145200E-01,.2217200E-01,& - & .2220700E-01,.2159800E-01,.2007500E-01,.1488000E-01,.7877800E-02,& - & .1662400E-01,.2002200E-01,.2176500E-01,.2253100E-01,.2259600E-01,& - & .2199900E-01,.2045800E-01,.1527900E-01,.8269400E-02,.1692800E-01,& - & .2027700E-01,.2203600E-01,.2285900E-01,.2297800E-01,.2238400E-01,& - & .2083400E-01,.1565000E-01,.8591900E-02,.1716800E-01,.2049800E-01,& - & .2227400E-01,.2314300E-01,.2332600E-01,.2275400E-01,.2118900E-01,& - & .1598000E-01,.8833700E-02,.1733200E-01,.2066400E-01,.2247700E-01,& - & .2340700E-01,.2364800E-01,.2311100E-01,.2150900E-01,.1628300E-01,& - & .6030500E-02,.1400800E-01,.1702800E-01,.1857400E-01,.1923600E-01,& - & .1926900E-01,.1872000E-01,.1734700E-01,.1265600E-01,.6435600E-02,& - & .1433900E-01,.1731800E-01,.1887200E-01,.1958000E-01,.1964500E-01,& - & .1909500E-01,.1770500E-01,.1302500E-01,.6770800E-02,.1462600E-01,& - & .1757500E-01,.1913500E-01,.1988300E-01,.2000400E-01,.1945400E-01,& - & .1805500E-01,.1336600E-01,.7044900E-02,.1485300E-01,.1779500E-01,& - & .1936300E-01,.2015600E-01,.2032400E-01,.1981100E-01,.1839200E-01,& - & .1367900E-01,.7258600E-02,.1501400E-01,.1795400E-01,.1956900E-01,& - & .2040100E-01,.2062200E-01,.2015500E-01,.1870600E-01,.1396300E-01,& - & .4861500E-02,.1193600E-01,.1457400E-01,.1596300E-01,.1657800E-01,& - & .1661500E-01,.1612500E-01,.1490400E-01,.1071800E-01,.5209300E-02,& - & .1224700E-01,.1484500E-01,.1623900E-01,.1689000E-01,.1696500E-01,& - & .1647700E-01,.1523800E-01,.1105000E-01,.5498100E-02,.1252000E-01,& - & .1508900E-01,.1648500E-01,.1716300E-01,.1729600E-01,.1682300E-01,& - & .1556100E-01,.1136700E-01,.5734100E-02,.1273200E-01,.1530200E-01,& - & .1670900E-01,.1741200E-01,.1758700E-01,.1715600E-01,.1588200E-01,& - & .1165700E-01,.5924500E-02,.1287900E-01,.1546000E-01,.1690000E-01,& - & .1764600E-01,.1786200E-01,.1747500E-01,.1618900E-01,.1192400E-01/ - - data absa(316:450, 7) / & - & .3890300E-02,.1008600E-01,.1239300E-01,.1361700E-01,.1417900E-01,& - & .1423000E-01,.1381000E-01,.1274100E-01,.9040200E-02,.4188300E-02,& - & .1037900E-01,.1264200E-01,.1386600E-01,.1445400E-01,.1454900E-01,& - & .1414000E-01,.1305000E-01,.9340700E-02,.4437400E-02,.1062800E-01,& - & .1286600E-01,.1409300E-01,.1470200E-01,.1484700E-01,.1446600E-01,& - & .1335400E-01,.9628900E-02,.4641700E-02,.1082300E-01,.1306700E-01,& - & .1429700E-01,.1493600E-01,.1511300E-01,.1477700E-01,.1365900E-01,& - & .9894600E-02,.4810600E-02,.1095800E-01,.1321200E-01,.1447700E-01,& - & .1515500E-01,.1536900E-01,.1506500E-01,.1395400E-01,.1013700E-01,& - & .3090600E-02,.8471600E-02,.1047500E-01,.1153300E-01,.1203700E-01,& - & .1210200E-01,.1175700E-01,.1084000E-01,.7579000E-02,.3345600E-02,& - & .8738000E-02,.1069800E-01,.1175900E-01,.1228100E-01,.1238400E-01,& - & .1206300E-01,.1112400E-01,.7852400E-02,.3562400E-02,.8963600E-02,& - & .1090800E-01,.1196400E-01,.1250300E-01,.1265100E-01,.1236600E-01,& - & .1141300E-01,.8111600E-02,.3740900E-02,.9139400E-02,.1108500E-01,& - & .1215600E-01,.1271700E-01,.1289500E-01,.1264600E-01,.1170300E-01,& - & .8354300E-02,.3889900E-02,.9266300E-02,.1121000E-01,.1232300E-01,& - & .1292300E-01,.1313500E-01,.1290900E-01,.1197900E-01,.8574800E-02,& - & .2458800E-02,.7099700E-02,.8815600E-02,.9728000E-02,.1017500E-01,& - & .1024600E-01,.9971200E-02,.9195100E-02,.6332400E-02,.2674300E-02,& - & .7339300E-02,.9018300E-02,.9928900E-02,.1038700E-01,.1049600E-01,& - & .1024900E-01,.9456600E-02,.6577000E-02,.2861000E-02,.7535200E-02,& - & .9202800E-02,.1011700E-01,.1058600E-01,.1073000E-01,.1052400E-01,& - & .9730700E-02,.6807700E-02,.3014700E-02,.7689900E-02,.9355000E-02,& - & .1029100E-01,.1078100E-01,.1095400E-01,.1077800E-01,.1000100E-01,& - & .7020100E-02,.3144400E-02,.7805000E-02,.9466800E-02,.1043300E-01,& - & .1097400E-01,.1117300E-01,.1101900E-01,.1025300E-01,.7218900E-02/ - - data absa(451:585, 7) / & - & .2034500E-02,.6024900E-02,.7471600E-02,.8249600E-02,.8645800E-02,& - & .8734000E-02,.8522200E-02,.7865700E-02,.5371400E-02,.2207100E-02,& - & .6217600E-02,.7644000E-02,.8425100E-02,.8827300E-02,.8946100E-02,& - & .8768900E-02,.8112500E-02,.5583500E-02,.2355400E-02,.6372900E-02,& - & .7793200E-02,.8586800E-02,.9005800E-02,.9154800E-02,.9007500E-02,& - & .8366000E-02,.5782700E-02,.2478000E-02,.6494400E-02,.7910600E-02,& - & .8729100E-02,.9185700E-02,.9356500E-02,.9230200E-02,.8603600E-02,& - & .5969500E-02,.2582000E-02,.6580200E-02,.7997400E-02,.8842700E-02,& - & .9348200E-02,.9553900E-02,.9444300E-02,.8818000E-02,.6151200E-02,& - & .1678900E-02,.5090600E-02,.6307800E-02,.6975000E-02,.7317200E-02,& - & .7407800E-02,.7250400E-02,.6701500E-02,.4539400E-02,.1817000E-02,& - & .5243700E-02,.6451200E-02,.7125500E-02,.7479000E-02,.7595900E-02,& - & .7465500E-02,.6930700E-02,.4723700E-02,.1935600E-02,.5368900E-02,& - & .6570100E-02,.7261000E-02,.7641500E-02,.7781100E-02,.7670300E-02,& - & .7150800E-02,.4895300E-02,.2034200E-02,.5464400E-02,.6664000E-02,& - & .7379200E-02,.7792900E-02,.7963500E-02,.7866000E-02,.7353200E-02,& - & .5060700E-02,.2118200E-02,.5532800E-02,.6735200E-02,.7473600E-02,& - & .7928200E-02,.8130700E-02,.8054200E-02,.7540700E-02,.5223400E-02,& - & .1381900E-02,.4282300E-02,.5309600E-02,.5877100E-02,.6174500E-02,& - & .6260100E-02,.6141100E-02,.5689300E-02,.3820100E-02,.1492700E-02,& - & .4407800E-02,.5426100E-02,.6005500E-02,.6316700E-02,.6427800E-02,& - & .6326800E-02,.5889100E-02,.3978900E-02,.1588400E-02,.4509000E-02,& - & .5524600E-02,.6121700E-02,.6457700E-02,.6590300E-02,.6504400E-02,& - & .6075800E-02,.4128800E-02,.1668300E-02,.4585800E-02,.5602900E-02,& - & .6219300E-02,.6585900E-02,.6745400E-02,.6676800E-02,.6250600E-02,& - & .4276500E-02,.1736400E-02,.4641900E-02,.5664400E-02,.6299600E-02,& - & .6699800E-02,.6888800E-02,.6840400E-02,.6418800E-02,.4419800E-02/ - - data absa( 1:180, 8) / & - & .5776000E-01,.6943200E-01,.7640200E-01,.8151700E-01,.8512500E-01,& - & .8728900E-01,.8740800E-01,.8331700E-01,.7472000E-01,.5825600E-01,& - & .6966700E-01,.7672300E-01,.8191100E-01,.8536200E-01,.8728900E-01,& - & .8730600E-01,.8335700E-01,.7517700E-01,.5871000E-01,.6985900E-01,& - & .7697300E-01,.8232800E-01,.8569000E-01,.8742000E-01,.8726400E-01,& - & .8343500E-01,.7570100E-01,.5905200E-01,.7005000E-01,.7717600E-01,& - & .8264200E-01,.8607100E-01,.8766000E-01,.8734100E-01,.8354400E-01,& - & .7623000E-01,.5929800E-01,.7019800E-01,.7737400E-01,.8288300E-01,& - & .8646900E-01,.8797700E-01,.8747300E-01,.8369100E-01,.7676900E-01,& - & .5090800E-01,.6284800E-01,.7000300E-01,.7526300E-01,.7867000E-01,& - & .8059400E-01,.8069400E-01,.7704800E-01,.6704800E-01,.5146900E-01,& - & .6317800E-01,.7039500E-01,.7576300E-01,.7903300E-01,.8077500E-01,& - & .8068600E-01,.7719900E-01,.6760500E-01,.5195600E-01,.6351900E-01,& - & .7074800E-01,.7622100E-01,.7951200E-01,.8106700E-01,.8079700E-01,& - & .7737000E-01,.6818200E-01,.5232900E-01,.6383100E-01,.7111500E-01,& - & .7659100E-01,.8003200E-01,.8144500E-01,.8100100E-01,.7756800E-01,& - & .6876800E-01,.5264800E-01,.6410800E-01,.7144100E-01,.7694100E-01,& - & .8046400E-01,.8186600E-01,.8128200E-01,.7779600E-01,.6937700E-01,& - & .4463600E-01,.5657500E-01,.6366700E-01,.6880400E-01,.7214600E-01,& - & .7394000E-01,.7375600E-01,.7035900E-01,.5944600E-01,.4521600E-01,& - & .5700500E-01,.6411100E-01,.6932800E-01,.7262000E-01,.7422800E-01,& - & .7385400E-01,.7060000E-01,.6008600E-01,.4571600E-01,.5744800E-01,& - & .6459100E-01,.6981600E-01,.7317800E-01,.7461600E-01,.7409300E-01,& - & .7084300E-01,.6073800E-01,.4613700E-01,.5786200E-01,.6506000E-01,& - & .7028300E-01,.7372400E-01,.7506700E-01,.7440800E-01,.7113000E-01,& - & .6138500E-01,.4649000E-01,.5824000E-01,.6553700E-01,.7075200E-01,& - & .7418700E-01,.7554500E-01,.7481700E-01,.7147900E-01,.6199800E-01,& - & .3891000E-01,.5082300E-01,.5750500E-01,.6236400E-01,.6555900E-01,& - & .6715400E-01,.6679800E-01,.6353100E-01,.5240100E-01,.3948800E-01,& - & .5130700E-01,.5802200E-01,.6291200E-01,.6607400E-01,.6751800E-01,& - & .6702500E-01,.6384000E-01,.5309300E-01,.3999100E-01,.5181200E-01,& - & .5856600E-01,.6345100E-01,.6663200E-01,.6801000E-01,.6734800E-01,& - & .6416900E-01,.5378200E-01,.4038700E-01,.5229100E-01,.5911700E-01,& - & .6400100E-01,.6719600E-01,.6851400E-01,.6778900E-01,.6455500E-01,& - & .5447000E-01,.4071900E-01,.5273900E-01,.5969100E-01,.6457200E-01,& - & .6772500E-01,.6903100E-01,.6830700E-01,.6498500E-01,.5509100E-01/ - - data absa(181:315, 8) / & - & .3369200E-01,.4545900E-01,.5170500E-01,.5611100E-01,.5898400E-01,& - & .6038400E-01,.5995100E-01,.5677000E-01,.4593900E-01,.3425400E-01,& - & .4597900E-01,.5225200E-01,.5666400E-01,.5951500E-01,.6081600E-01,& - & .6027300E-01,.5714600E-01,.4664700E-01,.3473800E-01,.4653200E-01,& - & .5284600E-01,.5723800E-01,.6007700E-01,.6135200E-01,.6071400E-01,& - & .5756600E-01,.4735900E-01,.3511700E-01,.4704700E-01,.5345900E-01,& - & .5784900E-01,.6066800E-01,.6190200E-01,.6125900E-01,.5803000E-01,& - & .4803600E-01,.3542800E-01,.4750800E-01,.5408300E-01,.5849300E-01,& - & .6125300E-01,.6248100E-01,.6185100E-01,.5852300E-01,.4864800E-01,& - & .2891000E-01,.4042900E-01,.4617600E-01,.5010800E-01,.5260900E-01,& - & .5375000E-01,.5328900E-01,.5028600E-01,.4006100E-01,.2943300E-01,& - & .4096700E-01,.4673100E-01,.5065300E-01,.5314900E-01,.5423200E-01,& - & .5368700E-01,.5071400E-01,.4075600E-01,.2988300E-01,.4152000E-01,& - & .4734900E-01,.5125100E-01,.5373100E-01,.5479600E-01,.5420700E-01,& - & .5118800E-01,.4144300E-01,.3025200E-01,.4202400E-01,.4799800E-01,& - & .5191800E-01,.5433900E-01,.5538700E-01,.5482000E-01,.5171100E-01,& - & .4208500E-01,.3054200E-01,.4244700E-01,.4863500E-01,.5259800E-01,& - & .5498600E-01,.5603800E-01,.5543000E-01,.5223600E-01,.4267500E-01,& - & .2460000E-01,.3572500E-01,.4095200E-01,.4439800E-01,.4655800E-01,& - & .4746200E-01,.4695000E-01,.4422700E-01,.3475100E-01,.2506000E-01,& - & .3625000E-01,.4149800E-01,.4495000E-01,.4709700E-01,.4797700E-01,& - & .4739900E-01,.4469000E-01,.3541000E-01,.2546600E-01,.3676900E-01,& - & .4211900E-01,.4557200E-01,.4769600E-01,.4854800E-01,.4796500E-01,& - & .4519800E-01,.3605000E-01,.2580400E-01,.3723200E-01,.4276400E-01,& - & .4624900E-01,.4834900E-01,.4917300E-01,.4860300E-01,.4573700E-01,& - & .3664900E-01,.2607500E-01,.3764500E-01,.4337100E-01,.4695000E-01,& - & .4904500E-01,.4985600E-01,.4922300E-01,.4627900E-01,.3719800E-01/ - - data absa(316:450, 8) / & - & .2074700E-01,.3132500E-01,.3601600E-01,.3904700E-01,.4092100E-01,& - & .4165600E-01,.4109700E-01,.3868200E-01,.2995500E-01,.2114500E-01,& - & .3181100E-01,.3654100E-01,.3959700E-01,.4145500E-01,.4216900E-01,& - & .4157500E-01,.3914500E-01,.3057700E-01,.2149700E-01,.3229000E-01,& - & .3715500E-01,.4023800E-01,.4206700E-01,.4274400E-01,.4215400E-01,& - & .3964800E-01,.3117800E-01,.2179600E-01,.3271700E-01,.3776600E-01,& - & .4092300E-01,.4273800E-01,.4339400E-01,.4276800E-01,.4018500E-01,& - & .3173300E-01,.2204400E-01,.3311200E-01,.3833800E-01,.4159700E-01,& - & .4346200E-01,.4408700E-01,.4338500E-01,.4074000E-01,.3225400E-01,& - & .1736000E-01,.2721800E-01,.3140100E-01,.3408400E-01,.3574100E-01,& - & .3637300E-01,.3579800E-01,.3359400E-01,.2566400E-01,.1769300E-01,& - & .2766200E-01,.3190800E-01,.3462200E-01,.3626400E-01,.3687700E-01,& - & .3628500E-01,.3404900E-01,.2625100E-01,.1799200E-01,.2808900E-01,& - & .3247700E-01,.3525500E-01,.3687400E-01,.3744400E-01,.3683100E-01,& - & .3454400E-01,.2681400E-01,.1825800E-01,.2848100E-01,.3305000E-01,& - & .3590900E-01,.3755200E-01,.3807800E-01,.3742100E-01,.3507300E-01,& - & .2733500E-01,.1848400E-01,.2884900E-01,.3360100E-01,.3653600E-01,& - & .3825400E-01,.3875600E-01,.3802600E-01,.3561600E-01,.2782900E-01,& - & .1446200E-01,.2346300E-01,.2718600E-01,.2958800E-01,.3107900E-01,& - & .3162500E-01,.3105300E-01,.2901200E-01,.2191600E-01,.1473700E-01,& - & .2385300E-01,.2766200E-01,.3010900E-01,.3158100E-01,.3211600E-01,& - & .3152700E-01,.2946100E-01,.2246000E-01,.1498300E-01,.2423800E-01,& - & .2818700E-01,.3071000E-01,.3217600E-01,.3266400E-01,.3204400E-01,& - & .2994800E-01,.2298700E-01,.1522800E-01,.2459300E-01,.2871800E-01,& - & .3131200E-01,.3282600E-01,.3328200E-01,.3261500E-01,.3046700E-01,& - & .2347800E-01,.1541100E-01,.2493200E-01,.2922800E-01,.3190300E-01,& - & .3345500E-01,.3394300E-01,.3320700E-01,.3099400E-01,.2393900E-01/ - - data absa(451:585, 8) / & - & .1209700E-01,.2023000E-01,.2355400E-01,.2573700E-01,.2707000E-01,& - & .2752600E-01,.2698700E-01,.2512500E-01,.1884300E-01,.1231600E-01,& - & .2056400E-01,.2401400E-01,.2626500E-01,.2758900E-01,.2802100E-01,& - & .2746200E-01,.2558000E-01,.1934100E-01,.1252500E-01,.2089300E-01,& - & .2449400E-01,.2681700E-01,.2817200E-01,.2857800E-01,.2798500E-01,& - & .2607300E-01,.1981100E-01,.1269800E-01,.2121200E-01,.2497100E-01,& - & .2735800E-01,.2875200E-01,.2919600E-01,.2855400E-01,.2657500E-01,& - & .2025400E-01,.1281300E-01,.2152700E-01,.2542800E-01,.2788600E-01,& - & .2931600E-01,.2979400E-01,.2914400E-01,.2709500E-01,.2066900E-01,& - & .1007900E-01,.1733200E-01,.2032600E-01,.2228300E-01,.2345200E-01,& - & .2384000E-01,.2335100E-01,.2170100E-01,.1615000E-01,.1025300E-01,& - & .1762400E-01,.2073800E-01,.2277200E-01,.2396300E-01,.2434300E-01,& - & .2383000E-01,.2215900E-01,.1660500E-01,.1041200E-01,.1791400E-01,& - & .2116500E-01,.2325700E-01,.2449100E-01,.2490700E-01,.2436400E-01,& - & .2263300E-01,.1703100E-01,.1052800E-01,.1820300E-01,.2158500E-01,& - & .2373200E-01,.2501900E-01,.2546600E-01,.2492500E-01,.2312300E-01,& - & .1744000E-01,.1059500E-01,.1849100E-01,.2198700E-01,.2420500E-01,& - & .2552600E-01,.2601300E-01,.2549700E-01,.2363300E-01,.1782500E-01,& - & .8367500E-02,.1477800E-01,.1745500E-01,.1920100E-01,.2021400E-01,& - & .2054500E-01,.2013300E-01,.1870300E-01,.1381000E-01,.8503700E-02,& - & .1503300E-01,.1782400E-01,.1962100E-01,.2068400E-01,.2105200E-01,& - & .2061600E-01,.1914500E-01,.1421800E-01,.8612900E-02,.1530300E-01,& - & .1819700E-01,.2004300E-01,.2116300E-01,.2157700E-01,.2114300E-01,& - & .1960000E-01,.1461700E-01,.8691200E-02,.1556800E-01,.1856500E-01,& - & .2047200E-01,.2163600E-01,.2209100E-01,.2167400E-01,.2009000E-01,& - & .1499100E-01,.8730200E-02,.1580000E-01,.1891700E-01,.2088700E-01,& - & .2210300E-01,.2259400E-01,.2219800E-01,.2058600E-01,.1535100E-01/ - - data absa( 1:180, 9) / & - & .2875600E+00,.2846608E+00,.3007336E+00,.3116711E+00,.3128429E+00,& - & .3061657E+00,.2955131E+00,.2798330E+00,.2885174E+00,.2846791E+00,& - & .2818630E+00,.2979418E+00,.3088891E+00,.3105850E+00,.3045729E+00,& - & .2947321E+00,.2798508E+00,.2884665E+00,.2823420E+00,.2795426E+00,& - & .2956237E+00,.3062904E+00,.3083329E+00,.3027922E+00,.2937895E+00,& - & .2797232E+00,.2884416E+00,.2804602E+00,.2775936E+00,.2936396E+00,& - & .3040736E+00,.3061042E+00,.3009290E+00,.2927341E+00,.2793614E+00,& - & .2882076E+00,.2789708E+00,.2760060E+00,.2919045E+00,.3021032E+00,& - & .3039633E+00,.2991521E+00,.2914947E+00,.2788660E+00,.2878374E+00,& - & .2691839E+00,.2738289E+00,.2925806E+00,.3047303E+00,.3076965E+00,& - & .3021735E+00,.2903704E+00,.2740484E+00,.2753391E+00,.2667388E+00,& - & .2713965E+00,.2901694E+00,.3021752E+00,.3055593E+00,.3006242E+00,& - & .2897230E+00,.2740378E+00,.2755566E+00,.2649469E+00,.2695060E+00,& - & .2881919E+00,.2999513E+00,.3034581E+00,.2989484E+00,.2889087E+00,& - & .2738977E+00,.2755970E+00,.2636807E+00,.2680315E+00,.2865238E+00,& - & .2980684E+00,.3014061E+00,.2973517E+00,.2879069E+00,.2735423E+00,& - & .2754315E+00,.2627764E+00,.2669319E+00,.2851547E+00,.2963620E+00,& - & .2995768E+00,.2957673E+00,.2866862E+00,.2730982E+00,.2752015E+00,& - & .2490195E+00,.2608954E+00,.2819694E+00,.2948392E+00,.2994181E+00,& - & .2960253E+00,.2839092E+00,.2667913E+00,.2610712E+00,.2470483E+00,& - & .2588078E+00,.2799097E+00,.2926407E+00,.2974527E+00,.2945959E+00,& - & .2834853E+00,.2668456E+00,.2614061E+00,.2457732E+00,.2572386E+00,& - & .2782150E+00,.2907979E+00,.2955550E+00,.2931132E+00,.2827947E+00,& - & .2667547E+00,.2614625E+00,.2450220E+00,.2561881E+00,.2768616E+00,& - & .2892386E+00,.2937867E+00,.2916947E+00,.2819208E+00,.2664583E+00,& - & .2614477E+00,.2447576E+00,.2555647E+00,.2758063E+00,.2878616E+00,& - & .2922788E+00,.2903473E+00,.2808432E+00,.2661024E+00,.2614835E+00,& - & .2278433E+00,.2459460E+00,.2687748E+00,.2823420E+00,.2883606E+00,& - & .2867773E+00,.2761135E+00,.2583114E+00,.2469847E+00,.2262821E+00,& - & .2442492E+00,.2669664E+00,.2804797E+00,.2866383E+00,.2856021E+00,& - & .2758521E+00,.2584755E+00,.2474068E+00,.2254367E+00,.2430836E+00,& - & .2656062E+00,.2789372E+00,.2850299E+00,.2843218E+00,.2753572E+00,& - & .2584303E+00,.2476169E+00,.2252826E+00,.2424728E+00,.2646308E+00,& - & .2777122E+00,.2836401E+00,.2831157E+00,.2746060E+00,.2582669E+00,& - & .2478333E+00,.2256551E+00,.2423529E+00,.2639731E+00,.2766779E+00,& - & .2825116E+00,.2820352E+00,.2736912E+00,.2580734E+00,.2481106E+00/ - - data absa(181:315, 9) / & - & .2062751E+00,.2298044E+00,.2532990E+00,.2676292E+00,.2748784E+00,& - & .2747996E+00,.2666545E+00,.2487411E+00,.2325541E+00,.2051043E+00,& - & .2284554E+00,.2518239E+00,.2660870E+00,.2734853E+00,.2738569E+00,& - & .2665350E+00,.2490789E+00,.2332102E+00,.2047919E+00,.2277211E+00,& - & .2507972E+00,.2649403E+00,.2721940E+00,.2728699E+00,.2661103E+00,& - & .2492251E+00,.2337220E+00,.2051961E+00,.2275744E+00,.2501902E+00,& - & .2640418E+00,.2711870E+00,.2720181E+00,.2654582E+00,.2492504E+00,& - & .2342238E+00,.2061900E+00,.2279645E+00,.2499630E+00,.2633833E+00,& - & .2704230E+00,.2712077E+00,.2647461E+00,.2492510E+00,.2347478E+00,& - & .1853388E+00,.2130833E+00,.2365145E+00,.2513589E+00,.2593134E+00,& - & .2609466E+00,.2549939E+00,.2376988E+00,.2170867E+00,.1845601E+00,& - & .2121024E+00,.2353552E+00,.2502019E+00,.2582784E+00,.2602288E+00,& - & .2550486E+00,.2382771E+00,.2180680E+00,.1846602E+00,.2117219E+00,& - & .2346887E+00,.2493886E+00,.2574166E+00,.2595177E+00,.2547983E+00,& - & .2386926E+00,.2189256E+00,.1855458E+00,.2119966E+00,.2344799E+00,& - & .2488166E+00,.2567948E+00,.2589356E+00,.2543373E+00,.2389459E+00,& - & .2197901E+00,.1870772E+00,.2128598E+00,.2346986E+00,.2485625E+00,& - & .2564000E+00,.2584353E+00,.2538996E+00,.2391912E+00,.2205482E+00,& - & .1654511E+00,.1961135E+00,.2190853E+00,.2338982E+00,.2425818E+00,& - & .2456184E+00,.2412218E+00,.2252744E+00,.2008814E+00,.1650292E+00,& - & .1954131E+00,.2182427E+00,.2330965E+00,.2418982E+00,.2451802E+00,& - & .2414790E+00,.2260855E+00,.2021875E+00,.1654771E+00,.1953910E+00,& - & .2179136E+00,.2326080E+00,.2414414E+00,.2447571E+00,.2414612E+00,& - & .2267328E+00,.2033987E+00,.1667613E+00,.1960735E+00,.2180521E+00,& - & .2324354E+00,.2411480E+00,.2444710E+00,.2413228E+00,.2272824E+00,& - & .2045050E+00,.1686834E+00,.1973572E+00,.2187006E+00,.2325944E+00,& - & .2410697E+00,.2443064E+00,.2412853E+00,.2277903E+00,.2054612E+00/ - - data absa(316:450, 9) / & - & .1466987E+00,.1792921E+00,.2014461E+00,.2160765E+00,.2251959E+00,& - & .2288858E+00,.2256137E+00,.2115906E+00,.1843005E+00,.1465091E+00,& - & .1788078E+00,.2009639E+00,.2155790E+00,.2248838E+00,.2288389E+00,& - & .2260797E+00,.2126564E+00,.1858920E+00,.1472457E+00,.1790577E+00,& - & .2009403E+00,.2154072E+00,.2247365E+00,.2287839E+00,.2263437E+00,& - & .2135828E+00,.1874072E+00,.1487936E+00,.1800885E+00,.2014536E+00,& - & .2156062E+00,.2248091E+00,.2288471E+00,.2265932E+00,.2144085E+00,& - & .1887703E+00,.1510004E+00,.1817540E+00,.2025068E+00,.2162005E+00,& - & .2250829E+00,.2290843E+00,.2269522E+00,.2151187E+00,.1899588E+00,& - & .1290166E+00,.1628134E+00,.1841393E+00,.1984523E+00,.2074091E+00,& - & .2111610E+00,.2086918E+00,.1966022E+00,.1675581E+00,.1290151E+00,& - & .1624988E+00,.1838874E+00,.1982834E+00,.2074512E+00,.2114622E+00,& - & .2094660E+00,.1978766E+00,.1694333E+00,.1299542E+00,.1629858E+00,& - & .1841354E+00,.1984427E+00,.2076315E+00,.2117841E+00,.2100747E+00,& - & .1990529E+00,.1712079E+00,.1317221E+00,.1642880E+00,.1849872E+00,& - & .1989586E+00,.2080569E+00,.2122421E+00,.2107272E+00,.2001600E+00,& - & .1728028E+00,.1340336E+00,.1662556E+00,.1864180E+00,.1999647E+00,& - & .2087569E+00,.2128849E+00,.2114836E+00,.2011527E+00,.1742183E+00,& - & .1126804E+00,.1466556E+00,.1672889E+00,.1811021E+00,.1894716E+00,& - & .1930711E+00,.1911967E+00,.1807203E+00,.1511468E+00,.1128902E+00,& - & .1466324E+00,.1672756E+00,.1812574E+00,.1898492E+00,.1936951E+00,& - & .1922455E+00,.1822647E+00,.1532592E+00,.1140256E+00,.1474289E+00,& - & .1678506E+00,.1817516E+00,.1903705E+00,.1944050E+00,.1932330E+00,& - & .1836902E+00,.1552103E+00,.1159334E+00,.1490190E+00,.1690437E+00,& - & .1826551E+00,.1911836E+00,.1952461E+00,.1942671E+00,.1850452E+00,& - & .1569828E+00,.1181595E+00,.1512541E+00,.1708193E+00,.1840599E+00,& - & .1923574E+00,.1963008E+00,.1954232E+00,.1863167E+00,.1585924E+00/ - - data absa(451:585, 9) / & - & .9798189E-01,.1313265E+00,.1510348E+00,.1641642E+00,.1721410E+00,& - & .1755759E+00,.1741644E+00,.1652309E+00,.1361983E+00,.9876591E-01,& - & .1319241E+00,.1515858E+00,.1647606E+00,.1728744E+00,.1765573E+00,& - & .1754929E+00,.1669557E+00,.1384236E+00,.1003841E+00,.1333210E+00,& - & .1527464E+00,.1657657E+00,.1738505E+00,.1776840E+00,.1768404E+00,& - & .1686021E+00,.1404407E+00,.1023815E+00,.1354349E+00,.1545144E+00,& - & .1673004E+00,.1752277E+00,.1790049E+00,.1782869E+00,.1701818E+00,& - & .1423084E+00,.1045182E+00,.1378387E+00,.1568227E+00,.1693189E+00,& - & .1770176E+00,.1806205E+00,.1797803E+00,.1716817E+00,.1441206E+00,& - & .8513105E-01,.1174272E+00,.1357845E+00,.1479723E+00,.1555369E+00,& - & .1588474E+00,.1576920E+00,.1498764E+00,.1219425E+00,.8639013E-01,& - & .1185546E+00,.1369085E+00,.1490184E+00,.1566903E+00,.1601862E+00,& - & .1592810E+00,.1518099E+00,.1242064E+00,.8811019E-01,.1204518E+00,& - & .1385898E+00,.1506015E+00,.1581843E+00,.1617403E+00,.1609764E+00,& - & .1536670E+00,.1263021E+00,.9004252E-01,.1227432E+00,.1408853E+00,& - & .1527101E+00,.1601143E+00,.1635634E+00,.1627369E+00,.1554561E+00,& - & .1283211E+00,.9212719E-01,.1251177E+00,.1434973E+00,.1553078E+00,& - & .1624820E+00,.1656416E+00,.1645751E+00,.1572251E+00,.1303753E+00,& - & .7386256E-01,.1049065E+00,.1217281E+00,.1327938E+00,.1397977E+00,& - & .1430454E+00,.1419673E+00,.1350204E+00,.1084738E+00,.7529440E-01,& - & .1065145E+00,.1232849E+00,.1343471E+00,.1414069E+00,.1447364E+00,& - & .1438645E+00,.1371204E+00,.1108041E+00,.7697705E-01,.1086621E+00,& - & .1254864E+00,.1364483E+00,.1434325E+00,.1467317E+00,.1458386E+00,& - & .1392068E+00,.1129989E+00,.7887272E-01,.1109542E+00,.1281014E+00,& - & .1390876E+00,.1459050E+00,.1489849E+00,.1479204E+00,.1412350E+00,& - & .1152445E+00,.8092106E-01,.1133621E+00,.1308019E+00,.1420681E+00,& - & .1487342E+00,.1514606E+00,.1501482E+00,.1433560E+00,.1175338E+00/ - - data absa( 1:180,10) / & - & .1892134E+01,.1658490E+01,.1482317E+01,.1379089E+01,.1354260E+01,& - & .1396373E+01,.1493971E+01,.1670802E+01,.1862417E+01,.1891097E+01,& - & .1657654E+01,.1481328E+01,.1378847E+01,.1353670E+01,.1394913E+01,& - & .1490545E+01,.1665288E+01,.1856307E+01,.1886928E+01,.1654075E+01,& - & .1478255E+01,.1377182E+01,.1351932E+01,.1393126E+01,.1486947E+01,& - & .1659721E+01,.1849481E+01,.1880181E+01,.1648189E+01,.1473312E+01,& - & .1373916E+01,.1349297E+01,.1390619E+01,.1483307E+01,.1654665E+01,& - & .1843360E+01,.1870673E+01,.1639925E+01,.1466606E+01,.1369235E+01,& - & .1345693E+01,.1387158E+01,.1479894E+01,.1649791E+01,.1837634E+01,& - & .2033645E+01,.1786076E+01,.1609696E+01,.1508649E+01,.1481540E+01,& - & .1520376E+01,.1619882E+01,.1790721E+01,.2011948E+01,.2032041E+01,& - & .1784578E+01,.1608196E+01,.1508007E+01,.1480683E+01,.1518803E+01,& - & .1616344E+01,.1785487E+01,.2005460E+01,.2027050E+01,.1780171E+01,& - & .1604546E+01,.1505776E+01,.1478425E+01,.1516595E+01,.1612478E+01,& - & .1780218E+01,.1999063E+01,.2019259E+01,.1773344E+01,.1599018E+01,& - & .1501972E+01,.1475347E+01,.1513286E+01,.1608726E+01,.1775367E+01,& - & .1993239E+01,.2008510E+01,.1763923E+01,.1591459E+01,.1496491E+01,& - & .1471124E+01,.1509095E+01,.1605098E+01,.1770446E+01,.1987403E+01,& - & .2178944E+01,.1920080E+01,.1745231E+01,.1648443E+01,.1618386E+01,& - & .1649487E+01,.1748723E+01,.1914679E+01,.2160515E+01,.2176816E+01,& - & .1918278E+01,.1743380E+01,.1647385E+01,.1617218E+01,.1647942E+01,& - & .1744763E+01,.1909779E+01,.2154360E+01,.2171431E+01,.1913602E+01,& - & .1739533E+01,.1644632E+01,.1614855E+01,.1645433E+01,.1740900E+01,& - & .1904856E+01,.2148715E+01,.2162892E+01,.1906049E+01,.1733600E+01,& - & .1640053E+01,.1611602E+01,.1641860E+01,.1736869E+01,.1900085E+01,& - & .2142847E+01,.2151134E+01,.1895842E+01,.1725453E+01,.1633876E+01,& - & .1606822E+01,.1637313E+01,.1732726E+01,.1894852E+01,.2136670E+01,& - & .2323030E+01,.2056823E+01,.1886477E+01,.1793946E+01,.1761503E+01,& - & .1786099E+01,.1877376E+01,.2039031E+01,.2297025E+01,.2320669E+01,& - & .2054539E+01,.1884669E+01,.1792680E+01,.1760212E+01,.1784371E+01,& - & .1873523E+01,.2034631E+01,.2291545E+01,.2314935E+01,.2049383E+01,& - & .1880494E+01,.1789605E+01,.1757829E+01,.1781704E+01,.1869518E+01,& - & .2030102E+01,.2286263E+01,.2305612E+01,.2041188E+01,.1873956E+01,& - & .1784458E+01,.1754036E+01,.1777972E+01,.1865353E+01,.2025199E+01,& - & .2280190E+01,.2293056E+01,.2030193E+01,.1865150E+01,.1777683E+01,& - & .1748548E+01,.1773179E+01,.1860971E+01,.2019743E+01,.2273813E+01/ - - data absa(181:315,10) / & - & .2463042E+01,.2192642E+01,.2030621E+01,.1942197E+01,.1908343E+01,& - & .1927535E+01,.2006081E+01,.2161944E+01,.2425159E+01,.2460420E+01,& - & .2190039E+01,.2028628E+01,.1940843E+01,.1906973E+01,.1925788E+01,& - & .2002593E+01,.2157807E+01,.2420144E+01,.2453905E+01,.2184091E+01,& - & .2024115E+01,.1937152E+01,.1904425E+01,.1922817E+01,.1998960E+01,& - & .2153199E+01,.2414552E+01,.2443881E+01,.2175206E+01,.2017059E+01,& - & .1931637E+01,.1900107E+01,.1918693E+01,.1994945E+01,.2148178E+01,& - & .2408426E+01,.2430382E+01,.2163388E+01,.2007456E+01,.1924180E+01,& - & .1893992E+01,.1913520E+01,.1990266E+01,.2142434E+01,.2401933E+01,& - & .2595361E+01,.2325394E+01,.2174062E+01,.2090012E+01,.2056871E+01,& - & .2069942E+01,.2136930E+01,.2284007E+01,.2549107E+01,.2592280E+01,& - & .2322210E+01,.2171892E+01,.2088399E+01,.2055272E+01,.2068312E+01,& - & .2133783E+01,.2280033E+01,.2544255E+01,.2585394E+01,.2315981E+01,& - & .2166893E+01,.2084474E+01,.2052146E+01,.2065367E+01,.2130298E+01,& - & .2275321E+01,.2538577E+01,.2574759E+01,.2306564E+01,.2159165E+01,& - & .2078513E+01,.2047302E+01,.2061084E+01,.2126258E+01,.2270085E+01,& - & .2532268E+01,.2560534E+01,.2294295E+01,.2148978E+01,.2070421E+01,& - & .2040584E+01,.2055565E+01,.2121352E+01,.2264122E+01,.2525794E+01,& - & .2717730E+01,.2453250E+01,.2313374E+01,.2235402E+01,.2202356E+01,& - & .2210413E+01,.2268848E+01,.2403823E+01,.2668217E+01,.2714408E+01,& - & .2449934E+01,.2311069E+01,.2233513E+01,.2200700E+01,.2208877E+01,& - & .2266063E+01,.2400211E+01,.2663785E+01,.2707312E+01,.2443349E+01,& - & .2305816E+01,.2229419E+01,.2197247E+01,.2206137E+01,.2262718E+01,& - & .2395786E+01,.2658274E+01,.2696315E+01,.2433710E+01,.2297781E+01,& - & .2222901E+01,.2191947E+01,.2201655E+01,.2258338E+01,.2390352E+01,& - & .2652236E+01,.2681738E+01,.2420849E+01,.2287046E+01,.2214166E+01,& - & .2184829E+01,.2195666E+01,.2252886E+01,.2384216E+01,.2646214E+01/ - - data absa(316:450,10) / & - & .2830476E+01,.2574810E+01,.2446984E+01,.2374964E+01,.2342639E+01,& - & .2348427E+01,.2400182E+01,.2520854E+01,.2781859E+01,.2827137E+01,& - & .2571641E+01,.2444361E+01,.2373065E+01,.2340938E+01,.2346711E+01,& - & .2397962E+01,.2517827E+01,.2778017E+01,.2819904E+01,.2565126E+01,& - & .2438846E+01,.2368655E+01,.2337305E+01,.2343718E+01,.2394597E+01,& - & .2513695E+01,.2772893E+01,.2808916E+01,.2555136E+01,.2430441E+01,& - & .2361733E+01,.2331640E+01,.2338952E+01,.2389996E+01,.2508304E+01,& - & .2767177E+01,.2794379E+01,.2541925E+01,.2419332E+01,.2352428E+01,& - & .2324012E+01,.2332369E+01,.2384042E+01,.2502259E+01,.2761425E+01,& - & .2933800E+01,.2689436E+01,.2572674E+01,.2506396E+01,.2476838E+01,& - & .2482312E+01,.2528761E+01,.2636078E+01,.2889382E+01,.2930816E+01,& - & .2686703E+01,.2570265E+01,.2504494E+01,.2475090E+01,.2480774E+01,& - & .2526766E+01,.2633891E+01,.2886327E+01,.2923537E+01,.2680192E+01,& - & .2564715E+01,.2499735E+01,.2471291E+01,.2477512E+01,.2523484E+01,& - & .2630022E+01,.2881726E+01,.2912511E+01,.2670142E+01,.2556117E+01,& - & .2492614E+01,.2465215E+01,.2472392E+01,.2518562E+01,.2624696E+01,& - & .2876581E+01,.2898553E+01,.2656790E+01,.2544582E+01,.2482931E+01,& - & .2457049E+01,.2465309E+01,.2512229E+01,.2618696E+01,.2871034E+01,& - & .3027058E+01,.2797212E+01,.2690074E+01,.2629551E+01,.2604067E+01,& - & .2610197E+01,.2652331E+01,.2748363E+01,.2990031E+01,.3023852E+01,& - & .2794164E+01,.2687619E+01,.2627303E+01,.2602246E+01,.2608704E+01,& - & .2650569E+01,.2746538E+01,.2987720E+01,.3016507E+01,.2787386E+01,& - & .2681752E+01,.2622344E+01,.2598218E+01,.2605186E+01,.2647180E+01,& - & .2742958E+01,.2983973E+01,.3005577E+01,.2777090E+01,.2672822E+01,& - & .2614852E+01,.2591693E+01,.2599702E+01,.2642041E+01,.2737917E+01,& - & .2979411E+01,.2992905E+01,.2763507E+01,.2660993E+01,.2604652E+01,& - & .2582864E+01,.2591914E+01,.2635114E+01,.2731878E+01,.2974194E+01/ - - data absa(451:585,10) / & - & .3108634E+01,.2895420E+01,.2798425E+01,.2744368E+01,.2722653E+01,& - & .2730122E+01,.2769336E+01,.2855617E+01,.3083249E+01,.3103552E+01,& - & .2890636E+01,.2794237E+01,.2740840E+01,.2719834E+01,.2727815E+01,& - & .2767022E+01,.2853516E+01,.3081043E+01,.3094635E+01,.2882058E+01,& - & .2786673E+01,.2734481E+01,.2714488E+01,.2723042E+01,.2762618E+01,& - & .2849365E+01,.3077793E+01,.3083887E+01,.2870120E+01,.2776133E+01,& - & .2725197E+01,.2706459E+01,.2715971E+01,.2756337E+01,.2843995E+01,& - & .3073502E+01,.3072208E+01,.2856377E+01,.2762710E+01,.2713207E+01,& - & .2695854E+01,.2706674E+01,.2748406E+01,.2837477E+01,.3067985E+01,& - & .3179487E+01,.2983632E+01,.2897614E+01,.2850758E+01,.2832739E+01,& - & .2841435E+01,.2878587E+01,.2957109E+01,.3169588E+01,.3172853E+01,& - & .2977291E+01,.2891777E+01,.2845999E+01,.2828739E+01,.2838054E+01,& - & .2875642E+01,.2954402E+01,.3167982E+01,.3164067E+01,.2967272E+01,& - & .2882837E+01,.2838175E+01,.2822030E+01,.2832002E+01,.2870360E+01,& - & .2950082E+01,.3164988E+01,.3154001E+01,.2955025E+01,.2870648E+01,& - & .2827230E+01,.2812357E+01,.2823496E+01,.2863128E+01,.2944286E+01,& - & .3160501E+01,.3142799E+01,.2941633E+01,.2856439E+01,.2813383E+01,& - & .2800017E+01,.2812937E+01,.2854322E+01,.2937121E+01,.3154451E+01,& - & .3241097E+01,.3062217E+01,.2987360E+01,.2948157E+01,.2934292E+01,& - & .2943847E+01,.2979640E+01,.3051660E+01,.3249168E+01,.3234006E+01,& - & .3054284E+01,.2980255E+01,.2942054E+01,.2929013E+01,.2939386E+01,& - & .2975962E+01,.3048876E+01,.3247803E+01,.3225888E+01,.3043668E+01,& - & .2969796E+01,.2932743E+01,.2920751E+01,.2932040E+01,.2969899E+01,& - & .3044051E+01,.3244864E+01,.3216320E+01,.3031794E+01,.2956859E+01,& - & .2920139E+01,.2909436E+01,.2922425E+01,.2961874E+01,.3037648E+01,& - & .3239868E+01,.3205483E+01,.3018784E+01,.2942726E+01,.2905212E+01,& - & .2895638E+01,.2910719E+01,.2952008E+01,.3029378E+01,.3233244E+01/ - -! the array absb(1175,10) (kb(5,5,13:59,10)) contains absorption coefs at -! the 16 chosen g-values for a range of pressure levels < ~100mb and -! temperatures. the first index in the array, jt, which runs from 1 to 5, -! corresponds to different temperatures. more specifically, jt = 3 means -! that the data are for the reference temperature tref for this pressure -! level, jt = 2 refers to the temperature tref-15, jt = 1 is for -! tref-30, jt = 4 is for tref+15, and jt = 5 is for tref+30. -! the second index, jp, runs from 13 to 59 and refers to the jpth -! reference pressure level (see taumol.f for the value of these -! pressure levels in mb). the third index, ig, goes from 1 to 10, -! and tells us which g-interval the absorption coefficients are for. - - data absb( 1:175, 1) / & - & .4063300E-08,.6471800E-06,.7956700E-06,.8126400E-06,.2508000E-07,& - & .3759600E-08,.7042900E-06,.9085500E-06,.9643200E-06,.2829200E-07,& - & .3498200E-08,.7637000E-06,.1031600E-05,.1147200E-05,.3126500E-07,& - & .3270700E-08,.8283400E-06,.1157700E-05,.1338700E-05,.3492800E-07,& - & .3071000E-08,.9025200E-06,.1296200E-05,.1520600E-05,.3885900E-07,& - & .3302600E-08,.5359200E-06,.6617100E-06,.6763300E-06,.2076700E-07,& - & .3057400E-08,.5795900E-06,.7538600E-06,.8039500E-06,.2333400E-07,& - & .2846100E-08,.6289700E-06,.8548600E-06,.9574500E-06,.2584100E-07,& - & .2662100E-08,.6835200E-06,.9613200E-06,.1114800E-05,.2886200E-07,& - & .2500500E-08,.7451700E-06,.1073900E-05,.1263200E-05,.3209300E-07,& - & .2682100E-08,.4408100E-06,.5509300E-06,.5646500E-06,.1718600E-07,& - & .2484500E-08,.4777300E-06,.6263600E-06,.6718000E-06,.1923400E-07,& - & .2314000E-08,.5181100E-06,.7079100E-06,.7965800E-06,.2134800E-07,& - & .2165400E-08,.5641600E-06,.7989300E-06,.9287300E-06,.2383200E-07,& - & .2034700E-08,.6153500E-06,.8898500E-06,.1049900E-05,.2648500E-07,& - & .2177500E-08,.3625400E-06,.4587000E-06,.4712500E-06,.1421100E-07,& - & .2018300E-08,.3937600E-06,.5205300E-06,.5616300E-06,.1586900E-07,& - & .1880800E-08,.4268700E-06,.5869900E-06,.6638600E-06,.1762700E-07,& - & .1760800E-08,.4655900E-06,.6638800E-06,.7706300E-06,.1966400E-07,& - & .1655200E-08,.5074700E-06,.7369900E-06,.8724900E-06,.2184400E-07,& - & .1768200E-08,.2983600E-06,.3810400E-06,.3931400E-06,.1173500E-07,& - & .1639900E-08,.3249300E-06,.4321500E-06,.4689700E-06,.1307700E-07,& - & .1529000E-08,.3520300E-06,.4866500E-06,.5532800E-06,.1453500E-07,& - & .1432100E-08,.3838300E-06,.5503300E-06,.6384400E-06,.1620800E-07,& - & .1346800E-08,.4182200E-06,.6095000E-06,.7237600E-06,.1799500E-07,& - & .1436200E-08,.2456000E-06,.3166700E-06,.3279700E-06,.9683100E-08,& - & .1332700E-08,.2678400E-06,.3587200E-06,.3913400E-06,.1077300E-07,& - & .1243200E-08,.2900800E-06,.4033400E-06,.4602600E-06,.1198000E-07,& - & .1165000E-08,.3163700E-06,.4558300E-06,.5288000E-06,.1335000E-07,& - & .1096000E-08,.3450300E-06,.5036300E-06,.5996700E-06,.1481500E-07,& - & .1166700E-08,.2023100E-06,.2631300E-06,.2735900E-06,.7993400E-08,& - & .1083300E-08,.2208500E-06,.2976000E-06,.3262000E-06,.8880700E-08,& - & .1011000E-08,.2391200E-06,.3342300E-06,.3827100E-06,.9877100E-08,& - & .9477800E-09,.2607300E-06,.3768500E-06,.4379100E-06,.1100200E-07,& - & .8919800E-09,.2842500E-06,.4158900E-06,.4968200E-06,.1220400E-07/ - - data absb(176:350, 1) / & - & .9466800E-09,.1673500E-06,.2182200E-06,.2291400E-06,.6623700E-08,& - & .8795600E-09,.1825500E-06,.2477000E-06,.2729000E-06,.7347000E-08,& - & .8213200E-09,.1977600E-06,.2778600E-06,.3191300E-06,.8173200E-08,& - & .7703200E-09,.2155700E-06,.3119700E-06,.3638000E-06,.9101900E-08,& - & .7252800E-09,.2345800E-06,.3444900E-06,.4125700E-06,.1008400E-07,& - & .7680900E-09,.1385800E-06,.1813800E-06,.1918800E-06,.5492900E-08,& - & .7140800E-09,.1508800E-06,.2061400E-06,.2283500E-06,.6082500E-08,& - & .6671700E-09,.1636600E-06,.2311100E-06,.2662200E-06,.6768000E-08,& - & .6260500E-09,.1781600E-06,.2583400E-06,.3024200E-06,.7534400E-08,& - & .5897000E-09,.1937400E-06,.2854200E-06,.3422200E-06,.8339400E-08,& - & .6201300E-09,.1154700E-06,.1521200E-06,.1622700E-06,.4592600E-08,& - & .5770900E-09,.1255200E-06,.1721100E-06,.1926500E-06,.5072800E-08,& - & .5396400E-09,.1361900E-06,.1936300E-06,.2240200E-06,.5645400E-08,& - & .5067500E-09,.1480500E-06,.2155700E-06,.2532000E-06,.6280500E-08,& - & .4776400E-09,.1609700E-06,.2379900E-06,.2857400E-06,.6941400E-08,& - & .5005500E-09,.9616500E-07,.1277600E-06,.1375200E-06,.3793300E-08,& - & .4662700E-09,.1042100E-06,.1438700E-06,.1622600E-06,.4215400E-08,& - & .4363800E-09,.1132000E-06,.1624000E-06,.1880600E-06,.4676100E-08,& - & .4100900E-09,.1231200E-06,.1800200E-06,.2121400E-06,.5172400E-08,& - & .3867900E-09,.1338000E-06,.1983500E-06,.2383600E-06,.5686300E-08,& - & .4038400E-09,.8017400E-07,.1074200E-06,.1166500E-06,.3143500E-08,& - & .3765600E-09,.8661100E-07,.1206200E-06,.1369400E-06,.3474600E-08,& - & .3527300E-09,.9420300E-07,.1361000E-06,.1572900E-06,.3858600E-08,& - & .3317400E-09,.1024600E-06,.1503500E-06,.1777500E-06,.4270700E-08,& - & .3131000E-09,.1112200E-06,.1654300E-06,.1991700E-06,.4702000E-08,& - & .3256200E-09,.6678500E-07,.9044700E-07,.9905900E-07,.2613400E-08,& - & .3039300E-09,.7213300E-07,.1013900E-06,.1157100E-06,.2887200E-08,& - & .2849500E-09,.7844800E-07,.1138500E-06,.1317800E-06,.3206100E-08,& - & .2682100E-09,.8533900E-07,.1256300E-06,.1491400E-06,.3548900E-08,& - & .2533200E-09,.9244500E-07,.1381400E-06,.1667400E-06,.3906000E-08,& - & .2622400E-09,.5568000E-07,.7636900E-07,.8440000E-07,.2175900E-08,& - & .2450400E-09,.6020400E-07,.8542300E-07,.9788500E-07,.2411800E-08,& - & .2299600E-09,.6547700E-07,.9532100E-07,.1109300E-06,.2677400E-08,& - & .2166300E-09,.7118800E-07,.1052900E-06,.1254400E-06,.2961500E-08,& - & .2047500E-09,.7694000E-07,.1155600E-06,.1397700E-06,.3256900E-08/ - - data absb(351:525, 1) / & - & .2112000E-09,.4638200E-07,.6389400E-07,.7137900E-07,.1817800E-08,& - & .1975600E-09,.5027800E-07,.7203300E-07,.8290900E-07,.2018100E-08,& - & .1855700E-09,.5467000E-07,.7995300E-07,.9350500E-07,.2239600E-08,& - & .1749600E-09,.5940800E-07,.8817900E-07,.1055300E-06,.2473700E-08,& - & .1654900E-09,.6402500E-07,.9669600E-07,.1170400E-06,.2709200E-08,& - & .1701000E-09,.3863100E-07,.5377300E-07,.6057900E-07,.1522000E-08,& - & .1592800E-09,.4200100E-07,.6066000E-07,.6972700E-07,.1690100E-08,& - & .1497600E-09,.4566100E-07,.6706500E-07,.7884500E-07,.1869600E-08,& - & .1413100E-09,.4957100E-07,.7380900E-07,.8848100E-07,.2061100E-08,& - & .1337600E-09,.5330400E-07,.8091000E-07,.9801700E-07,.2256500E-08,& - & .1369600E-09,.3227000E-07,.4539200E-07,.5143800E-07,.1272100E-08,& - & .1283900E-09,.3507900E-07,.5094600E-07,.5872600E-07,.1411800E-08,& - & .1208200E-09,.3815000E-07,.5625800E-07,.6649300E-07,.1562800E-08,& - & .1141000E-09,.4132400E-07,.6184300E-07,.7438700E-07,.1720500E-08,& - & .1080800E-09,.4438700E-07,.6773900E-07,.8221600E-07,.1874500E-08,& - & .1102900E-09,.2697000E-07,.3833000E-07,.4369800E-07,.1065500E-08,& - & .1034900E-09,.2931900E-07,.4273900E-07,.4955200E-07,.1182300E-08,& - & .9748300E-10,.3186900E-07,.4721000E-07,.5605700E-07,.1303800E-08,& - & .9213300E-10,.3443600E-07,.5181200E-07,.6248500E-07,.1428500E-08,& - & .8734000E-10,.3695300E-07,.5670900E-07,.6892100E-07,.1556300E-08,& - & .8880600E-10,.2255500E-07,.3238600E-07,.3712900E-07,.8902900E-09,& - & .8341700E-10,.2451900E-07,.3592100E-07,.4187000E-07,.9854800E-09,& - & .7864400E-10,.2663800E-07,.3960900E-07,.4727300E-07,.1085400E-08,& - & .7438800E-10,.2869400E-07,.4342300E-07,.5243500E-07,.1188000E-08,& - & .7056800E-10,.3077600E-07,.4741100E-07,.5775000E-07,.1293100E-08,& - & .7150700E-10,.1887000E-07,.2733200E-07,.3130900E-07,.7443600E-09,& - & .6723500E-10,.2051200E-07,.3018900E-07,.3540700E-07,.8229400E-09,& - & .6344400E-10,.2225900E-07,.3321800E-07,.3973000E-07,.9048300E-09,& - & .6005800E-10,.2392300E-07,.3640500E-07,.4397600E-07,.9890800E-09,& - & .5701500E-10,.2563400E-07,.3954800E-07,.4834600E-07,.1075000E-08,& - & .5758600E-10,.1577900E-07,.2295000E-07,.2641500E-07,.6225600E-09,& - & .5419900E-10,.1715300E-07,.2535400E-07,.2990400E-07,.6873400E-09,& - & .5118800E-10,.1856900E-07,.2786900E-07,.3340400E-07,.7546700E-09,& - & .4849300E-10,.1993500E-07,.3043700E-07,.3685600E-07,.8236900E-09,& - & .4606900E-10,.2134500E-07,.3298800E-07,.4047800E-07,.8940200E-09/ - - data absb(526:700, 1) / & - & .4648700E-10,.1316100E-07,.1921600E-07,.2221200E-07,.5191000E-09,& - & .4378900E-10,.1430100E-07,.2118200E-07,.2509000E-07,.5724700E-09,& - & .4138600E-10,.1544700E-07,.2320800E-07,.2793800E-07,.6276700E-09,& - & .3923400E-10,.1657100E-07,.2534700E-07,.3079500E-07,.6842600E-09,& - & .3729400E-10,.1772500E-07,.2739200E-07,.3378100E-07,.7417900E-09,& - & .3775600E-10,.1089000E-07,.1588200E-07,.1844100E-07,.4287100E-09,& - & .3558100E-10,.1183000E-07,.1751400E-07,.2081000E-07,.4725100E-09,& - & .3364300E-10,.1275700E-07,.1918400E-07,.2314800E-07,.5176900E-09,& - & .3190500E-10,.1368200E-07,.2094100E-07,.2547700E-07,.5639400E-09,& - & .3033800E-10,.1462800E-07,.2261300E-07,.2794800E-07,.6110000E-09,& - & .3087200E-10,.8929000E-08,.1300700E-07,.1510800E-07,.3503400E-09,& - & .2909600E-10,.9699500E-08,.1434300E-07,.1705100E-07,.3860900E-09,& - & .2751300E-10,.1045600E-07,.1571300E-07,.1896800E-07,.4229600E-09,& - & .2609300E-10,.1121300E-07,.1715300E-07,.2087500E-07,.4607300E-09,& - & .2481200E-10,.1198700E-07,.1852200E-07,.2289900E-07,.4991600E-09,& - & .2547900E-10,.7233800E-08,.1050800E-07,.1216500E-07,.2826800E-09,& - & .2400200E-10,.7859300E-08,.1159400E-07,.1374700E-07,.3117300E-09,& - & .2268700E-10,.8484500E-08,.1271200E-07,.1531500E-07,.3417800E-09,& - & .2150800E-10,.9099700E-08,.1389200E-07,.1688600E-07,.3726000E-09,& - & .2044600E-10,.9732200E-08,.1501200E-07,.1852600E-07,.4039800E-09,& - & .2104100E-10,.5856500E-08,.8483100E-08,.9789200E-08,.2279100E-09,& - & .1981100E-10,.6363600E-08,.9361900E-08,.1107200E-07,.2514800E-09,& - & .1871700E-10,.6878400E-08,.1027600E-07,.1236000E-07,.2759500E-09,& - & .1773800E-10,.7379200E-08,.1123400E-07,.1363800E-07,.3010900E-09,& - & .1685600E-10,.7897100E-08,.1216600E-07,.1497700E-07,.3267100E-09,& - & .1737700E-10,.4741800E-08,.6856100E-08,.7879500E-08,.1837300E-09,& - & .1635300E-10,.5153200E-08,.7562000E-08,.8912800E-08,.2028400E-09,& - & .1544300E-10,.5575200E-08,.8306900E-08,.9966600E-08,.2227900E-09,& - & .1462900E-10,.5985700E-08,.9087200E-08,.1101100E-07,.2432700E-09,& - & .1389600E-10,.6408600E-08,.9861600E-08,.1210400E-07,.2642000E-09,& - & .1444500E-10,.3809100E-08,.5479900E-08,.6275400E-08,.1467900E-09,& - & .1358100E-10,.4139100E-08,.6053000E-08,.7090900E-08,.1622000E-09,& - & .1281500E-10,.4488800E-08,.6655500E-08,.7953200E-08,.1784200E-09,& - & .1213100E-10,.4820700E-08,.7285500E-08,.8807100E-08,.1950900E-09,& - & .1151600E-10,.5164600E-08,.7926800E-08,.9693200E-08,.2121400E-09/ - - data absb(701:875, 1) / & - & .1202100E-10,.3056600E-08,.4360600E-08,.4992100E-08,.1171300E-09,& - & .1129100E-10,.3320500E-08,.4834000E-08,.5625600E-08,.1295400E-09,& - & .1064500E-10,.3605300E-08,.5326100E-08,.6347300E-08,.1426900E-09,& - & .1006900E-10,.3878200E-08,.5834700E-08,.7038600E-08,.1562400E-09,& - & .9552000E-11,.4158000E-08,.6364700E-08,.7751500E-08,.1701300E-09,& - & .1000700E-10,.2451600E-08,.3465300E-08,.3939800E-08,.9347500E-10,& - & .9390200E-11,.2663100E-08,.3858800E-08,.4463500E-08,.1034200E-09,& - & .8844900E-11,.2892600E-08,.4260000E-08,.5046600E-08,.1140600E-09,& - & .8359400E-11,.3119800E-08,.4671900E-08,.5621800E-08,.1250700E-09,& - & .7924400E-11,.3346500E-08,.5106500E-08,.6199900E-08,.1364000E-09,& - & .8364700E-11,.1957800E-08,.2734100E-08,.3082700E-08,.7427700E-10,& - & .7838900E-11,.2126300E-08,.3069000E-08,.3521200E-08,.8211800E-10,& - & .7375200E-11,.2310300E-08,.3386500E-08,.3983600E-08,.9067200E-10,& - & .6963300E-11,.2498400E-08,.3719800E-08,.4456900E-08,.9962800E-10,& - & .6595000E-11,.2683300E-08,.4070900E-08,.4926500E-08,.1088300E-09,& - & .7007000E-11,.1562800E-08,.2152100E-08,.2401700E-08,.5911600E-10,& - & .6557000E-11,.1695400E-08,.2425400E-08,.2777200E-08,.6502700E-10,& - & .6161200E-11,.1841300E-08,.2684500E-08,.3131000E-08,.7189200E-10,& - & .5810600E-11,.1997700E-08,.2954200E-08,.3521100E-08,.7914400E-10,& - & .5497600E-11,.2146400E-08,.3236000E-08,.3904500E-08,.8662900E-10,& - & .5872800E-11,.1250000E-08,.1707900E-08,.1874300E-08,.4664600E-10,& - & .5487300E-11,.1350500E-08,.1910500E-08,.2171900E-08,.5149900E-10,& - & .5149200E-11,.1467000E-08,.2125000E-08,.2459000E-08,.5698200E-10,& - & .4850400E-11,.1593100E-08,.2346400E-08,.2780200E-08,.6283900E-10,& - & .4584400E-11,.1716700E-08,.2573100E-08,.3095400E-08,.6890800E-10,& - & .4932800E-11,.9981100E-09,.1339700E-08,.1445700E-08,.3669400E-10,& - & .4601200E-11,.1074200E-08,.1498600E-08,.1687500E-08,.4074200E-10,& - & .4311300E-11,.1166500E-08,.1681300E-08,.1928100E-08,.4504900E-10,& - & .4055800E-11,.1267300E-08,.1856700E-08,.2181700E-08,.4975100E-10,& - & .3828800E-11,.1370200E-08,.2039900E-08,.2441900E-08,.5467900E-10,& - & .4159200E-11,.7920500E-09,.1043800E-08,.1105500E-08,.2870900E-10,& - & .3871700E-11,.8535700E-09,.1171000E-08,.1301500E-08,.3219800E-10,& - & .3621500E-11,.9251500E-09,.1319600E-08,.1510300E-08,.3544800E-10,& - & .3401600E-11,.1004600E-08,.1461900E-08,.1701000E-08,.3920300E-10,& - & .3206900E-11,.1090400E-08,.1610000E-08,.1916800E-08,.4318700E-10/ - - data absb(876:1050, 1) / & - & .3510000E-11,.6284900E-09,.8131900E-09,.8456700E-09,.2245600E-10,& - & .3260500E-11,.6802100E-09,.9216900E-09,.1004000E-08,.2522900E-10,& - & .3044100E-11,.7329400E-09,.1031400E-08,.1166500E-08,.2790300E-10,& - & .2854700E-11,.7961500E-09,.1149500E-08,.1325100E-08,.3087900E-10,& - & .2687400E-11,.8646300E-09,.1270300E-08,.1499400E-08,.3408200E-10,& - & .2964900E-11,.4986700E-09,.6357200E-09,.6455700E-09,.1755400E-10,& - & .2748000E-11,.5412400E-09,.7187100E-09,.7684000E-09,.1974900E-10,& - & .2560600E-11,.5814000E-09,.8041300E-09,.9005400E-09,.2201200E-10,& - & .2397200E-11,.6309700E-09,.9063700E-09,.1034900E-08,.2430800E-10,& - & .2253400E-11,.6854500E-09,.1000600E-08,.1170400E-08,.2687200E-10,& - & .2501900E-11,.3985300E-09,.4937400E-09,.4961500E-09,.1376200E-10,& - & .2313600E-11,.4295200E-09,.5614100E-09,.5898000E-09,.1550000E-10,& - & .2151700E-11,.4633400E-09,.6328400E-09,.6978800E-09,.1739000E-10,& - & .2011000E-11,.5013000E-09,.7112400E-09,.8090300E-09,.1918400E-10,& - & .1887500E-11,.5444600E-09,.7890800E-09,.9143500E-09,.2123000E-10,& - & .2111100E-11,.3153400E-09,.3855200E-09,.3832400E-09,.1085100E-10,& - & .1947800E-11,.3417900E-09,.4398600E-09,.4535500E-09,.1217600E-10,& - & .1807900E-11,.3701600E-09,.4983500E-09,.5391900E-09,.1368300E-10,& - & .1686800E-11,.3984600E-09,.5574600E-09,.6280500E-09,.1516400E-10,& - & .1580900E-11,.4327200E-09,.6231000E-09,.7158700E-09,.1678500E-10,& - & .1783000E-11,.2493900E-09,.3003300E-09,.2970800E-09,.8548000E-11,& - & .1641000E-11,.2724400E-09,.3446700E-09,.3487000E-09,.9564200E-11,& - & .1520000E-11,.2950700E-09,.3902000E-09,.4150500E-09,.1076400E-10,& - & .1415600E-11,.3173600E-09,.4369300E-09,.4875800E-09,.1201600E-10,& - & .1324600E-11,.3440900E-09,.4924300E-09,.5618100E-09,.1326700E-10,& - & .1507400E-11,.1974600E-09,.2344200E-09,.2302700E-09,.6694200E-11,& - & .1383800E-11,.2175400E-09,.2681200E-09,.2686500E-09,.7509500E-11,& - & .1278900E-11,.2344500E-09,.3051000E-09,.3191600E-09,.8462600E-11,& - & .1188800E-11,.2530500E-09,.3449600E-09,.3790600E-09,.9496300E-11,& - & .1110600E-11,.2735500E-09,.3868000E-09,.4388200E-09,.1048600E-10,& - & .1272200E-11,.1567600E-09,.1843600E-09,.1818800E-09,.5260100E-11,& - & .1164900E-11,.1725600E-09,.2103000E-09,.2087600E-09,.5946500E-11,& - & .1074300E-11,.1870600E-09,.2402200E-09,.2465700E-09,.6675000E-11,& - & .9968300E-12,.2026300E-09,.2720600E-09,.2933700E-09,.7501600E-11,& - & .9297500E-12,.2179800E-09,.3042000E-09,.3420300E-09,.8318200E-11/ - - data absb(1051:1175, 1) / & - & .1073300E-11,.1255200E-09,.1466800E-09,.1447700E-09,.4144000E-11,& - & .9802700E-12,.1370500E-09,.1648000E-09,.1629800E-09,.4713700E-11,& - & .9020900E-12,.1496600E-09,.1891100E-09,.1911700E-09,.5273000E-11,& - & .8354600E-12,.1621000E-09,.2141000E-09,.2275800E-09,.5934900E-11,& - & .7780000E-12,.1742300E-09,.2397200E-09,.2672500E-09,.6616300E-11,& - & .9062400E-12,.9978600E-10,.1167400E-09,.1128600E-09,.3277600E-11,& - & .8254700E-12,.1089700E-09,.1293800E-09,.1270500E-09,.3716100E-11,& - & .7579100E-12,.1200900E-09,.1480400E-09,.1482700E-09,.4164600E-11,& - & .7005800E-12,.1292500E-09,.1683700E-09,.1763000E-09,.4695700E-11,& - & .6513100E-12,.1393700E-09,.1899900E-09,.2089900E-09,.5274200E-11,& - & .7659500E-12,.7882200E-10,.9386300E-10,.8752900E-10,.2603300E-11,& - & .6956800E-12,.8655500E-10,.1019000E-09,.1002200E-09,.2928800E-11,& - & .6372100E-12,.9538500E-10,.1164000E-09,.1153300E-09,.3299400E-11,& - & .5878200E-12,.1032500E-09,.1326400E-09,.1366300E-09,.3718600E-11,& - & .5455200E-12,.1117300E-09,.1504200E-09,.1625300E-09,.4181900E-11,& - & .6469300E-12,.6242100E-10,.7617400E-10,.6832400E-10,.2083300E-11,& - & .5858800E-12,.6927800E-10,.8119700E-10,.7969100E-10,.2313000E-11,& - & .5353500E-12,.7587300E-10,.9141400E-10,.9039800E-10,.2635000E-11,& - & .4928500E-12,.8265300E-10,.1049300E-09,.1061700E-09,.2947300E-11,& - & .4566000E-12,.8964300E-10,.1186100E-09,.1264700E-09,.3323100E-11,& - & .5364500E-12,.5055700E-10,.6224000E-10,.5485400E-10,.1693000E-11,& - & .4852300E-12,.5646800E-10,.6560400E-10,.6482700E-10,.1870200E-11,& - & .4429400E-12,.6144200E-10,.7366700E-10,.7268800E-10,.2129200E-11,& - & .4074400E-12,.6718400E-10,.8449000E-10,.8521700E-10,.2383200E-11,& - & .3772000E-12,.7265700E-10,.9569200E-10,.1014400E-09,.2685200E-11/ - - data absb( 1:175, 2) / & - & .1832300E-07,.8626600E-05,.1372800E-04,.1595200E-04,.7892700E-06,& - & .1696100E-07,.9620300E-05,.1527500E-04,.1786300E-04,.9365900E-06,& - & .1578700E-07,.1067500E-04,.1692400E-04,.1967500E-04,.1105000E-05,& - & .1476400E-07,.1177900E-04,.1847400E-04,.2132000E-04,.1286800E-05,& - & .1386500E-07,.1284300E-04,.2002900E-04,.2308000E-04,.1456500E-05,& - & .1489300E-07,.7188200E-05,.1144300E-04,.1327100E-04,.6583500E-06,& - & .1379300E-07,.8027600E-05,.1273200E-04,.1489000E-04,.7813200E-06,& - & .1284400E-07,.8918900E-05,.1410100E-04,.1633900E-04,.9223300E-06,& - & .1201700E-07,.9830900E-05,.1538400E-04,.1772100E-04,.1067600E-05,& - & .1128900E-07,.1070400E-04,.1667900E-04,.1919400E-04,.1209100E-05,& - & .1209600E-07,.5993400E-05,.9544900E-05,.1105800E-04,.5496900E-06,& - & .1120900E-07,.6693200E-05,.1062300E-04,.1240700E-04,.6519700E-06,& - & .1044300E-07,.7444900E-05,.1174600E-04,.1357100E-04,.7694000E-06,& - & .9774700E-08,.8194800E-05,.1281400E-04,.1473200E-04,.8849600E-06,& - & .9186400E-08,.8918800E-05,.1388300E-04,.1594600E-04,.1002300E-05,& - & .9820500E-08,.5002700E-05,.7964400E-05,.9224800E-05,.4587600E-06,& - & .9106100E-08,.5584600E-05,.8859300E-05,.1033100E-04,.5433400E-06,& - & .8488200E-08,.6218300E-05,.9775700E-05,.1127900E-04,.6405000E-06,& - & .7948600E-08,.6827600E-05,.1066400E-04,.1224400E-04,.7334400E-06,& - & .7473200E-08,.7426800E-05,.1154500E-04,.1322400E-04,.8295500E-06,& - & .7975300E-08,.4171300E-05,.6615300E-05,.7689200E-05,.3824700E-06,& - & .7399400E-08,.4656200E-05,.7375300E-05,.8592200E-05,.4518800E-06,& - & .6900800E-08,.5182900E-05,.8128000E-05,.9363800E-05,.5321100E-06,& - & .6465000E-08,.5676500E-05,.8856000E-05,.1016800E-04,.6064700E-06,& - & .6080700E-08,.6175800E-05,.9589400E-05,.1094900E-04,.6854900E-06,& - & .6477900E-08,.3472700E-05,.5487500E-05,.6400000E-05,.3185100E-06,& - & .6013500E-08,.3875100E-05,.6130800E-05,.7137200E-05,.3755200E-06,& - & .5611100E-08,.4313200E-05,.6747800E-05,.7769800E-05,.4414100E-06,& - & .5259000E-08,.4715000E-05,.7344400E-05,.8437000E-05,.5007500E-06,& - & .4948300E-08,.5134500E-05,.7949500E-05,.9063700E-05,.5660100E-06,& - & .5262700E-08,.2890800E-05,.4558600E-05,.5326000E-05,.2651600E-06,& - & .4888200E-08,.3226000E-05,.5094000E-05,.5920000E-05,.3119000E-06,& - & .4563200E-08,.3584300E-05,.5599200E-05,.6439700E-05,.3660800E-06,& - & .4278600E-08,.3916700E-05,.6092300E-05,.6997200E-05,.4136100E-06,& - & .4027300E-08,.4266700E-05,.6590400E-05,.7502100E-05,.4674100E-06/ - - data absb(176:350, 2) / & - & .4270400E-08,.2407400E-05,.3799000E-05,.4445800E-05,.2210300E-06,& - & .3969000E-08,.2694200E-05,.4239300E-05,.4912000E-05,.2601400E-06,& - & .3707100E-08,.2982700E-05,.4657400E-05,.5348700E-05,.3041600E-06,& - & .3477600E-08,.3260100E-05,.5063500E-05,.5807600E-05,.3430400E-06,& - & .3274700E-08,.3551800E-05,.5470000E-05,.6219700E-05,.3875200E-06,& - & .3464900E-08,.2009600E-05,.3168900E-05,.3707000E-05,.1842400E-06,& - & .3222400E-08,.2250300E-05,.3527100E-05,.4078400E-05,.2170500E-06,& - & .3011400E-08,.2483400E-05,.3873700E-05,.4443600E-05,.2522900E-06,& - & .2826300E-08,.2714900E-05,.4208300E-05,.4806100E-05,.2846400E-06,& - & .2662600E-08,.2955600E-05,.4539400E-05,.5156500E-05,.3214800E-06,& - & .2797600E-08,.1691300E-05,.2663200E-05,.3110800E-05,.1553700E-06,& - & .2604300E-08,.1890800E-05,.2955300E-05,.3406700E-05,.1831100E-06,& - & .2435900E-08,.2081100E-05,.3239000E-05,.3711000E-05,.2109400E-06,& - & .2287800E-08,.2274600E-05,.3514400E-05,.4000900E-05,.2381600E-06,& - & .2156700E-08,.2471400E-05,.3783900E-05,.4291000E-05,.2688600E-06,& - & .2258300E-08,.1423400E-05,.2238800E-05,.2608800E-05,.1314300E-06,& - & .2104300E-08,.1586400E-05,.2477600E-05,.2849300E-05,.1546000E-06,& - & .1969900E-08,.1743600E-05,.2707200E-05,.3100900E-05,.1766900E-06,& - & .1851500E-08,.1905700E-05,.2935500E-05,.3330800E-05,.1995300E-06,& - & .1746500E-08,.2065300E-05,.3154200E-05,.3566300E-05,.2250100E-06,& - & .1822100E-08,.1200100E-05,.1880800E-05,.2186800E-05,.1113800E-06,& - & .1699500E-08,.1331500E-05,.2077900E-05,.2382500E-05,.1306800E-06,& - & .1592300E-08,.1462500E-05,.2264700E-05,.2588400E-05,.1482000E-06,& - & .1497800E-08,.1597200E-05,.2451200E-05,.2777100E-05,.1673400E-06,& - & .1413800E-08,.1725400E-05,.2629600E-05,.2964900E-05,.1884800E-06,& - & .1469300E-08,.1011100E-05,.1580900E-05,.1828600E-05,.9436600E-07,& - & .1371800E-08,.1119900E-05,.1743000E-05,.1995200E-05,.1104500E-06,& - & .1286400E-08,.1227300E-05,.1895700E-05,.2157200E-05,.1244500E-06,& - & .1211000E-08,.1337300E-05,.2046200E-05,.2316200E-05,.1404200E-06,& - & .1143800E-08,.1441000E-05,.2191600E-05,.2464800E-05,.1576700E-06,& - & .1183400E-08,.8533100E-06,.1331600E-05,.1532900E-05,.8021200E-07,& - & .1106100E-08,.9419200E-06,.1462600E-05,.1672900E-05,.9277500E-07,& - & .1038200E-08,.1031700E-05,.1589000E-05,.1800600E-05,.1046200E-06,& - & .9781000E-09,.1120500E-05,.1709900E-05,.1931400E-05,.1180000E-06,& - & .9245700E-09,.1203400E-05,.1827600E-05,.2050400E-05,.1320900E-06/ - - data absb(351:525, 2) / & - & .9531100E-09,.7189000E-06,.1121800E-05,.1286700E-05,.6808400E-07,& - & .8917700E-09,.7925800E-06,.1227500E-05,.1401900E-05,.7799900E-07,& - & .8378100E-09,.8660500E-06,.1330800E-05,.1504000E-05,.8802700E-07,& - & .7899800E-09,.9381500E-06,.1428500E-05,.1609100E-05,.9905700E-07,& - & .7472900E-09,.1004600E-05,.1523600E-05,.1705900E-05,.1107400E-06,& - & .7677100E-09,.6062300E-06,.9442700E-06,.1079600E-05,.5784400E-07,& - & .7190400E-09,.6665300E-06,.1029800E-05,.1169900E-05,.6572600E-07,& - & .6761400E-09,.7268900E-06,.1113100E-05,.1256800E-05,.7400900E-07,& - & .6380600E-09,.7848200E-06,.1192700E-05,.1340600E-05,.8320000E-07,& - & .6040100E-09,.8380600E-06,.1269500E-05,.1418600E-05,.9230600E-07,& - & .6181700E-09,.5105300E-06,.7945000E-06,.9068700E-06,.4907800E-07,& - & .5795800E-09,.5607100E-06,.8640300E-06,.9769000E-06,.5525700E-07,& - & .5455100E-09,.6100900E-06,.9307700E-06,.1049500E-05,.6228600E-07,& - & .5152000E-09,.6563100E-06,.9956700E-06,.1115900E-05,.6995400E-07,& - & .4880600E-09,.6983000E-06,.1057600E-05,.1179000E-05,.7722800E-07,& - & .4978300E-09,.4301400E-06,.6673200E-06,.7605800E-06,.4130600E-07,& - & .4672300E-09,.4714800E-06,.7243400E-06,.8168200E-06,.4653700E-07,& - & .4401500E-09,.5114600E-06,.7780900E-06,.8753700E-06,.5245100E-07,& - & .4160300E-09,.5487700E-06,.8307300E-06,.9288400E-06,.5879300E-07,& - & .3944000E-09,.5815900E-06,.8805400E-06,.9803000E-06,.6463000E-07,& - & .4008700E-09,.3625600E-06,.5606200E-06,.6354900E-06,.3477800E-07,& - & .3766000E-09,.3962000E-06,.6067400E-06,.6831300E-06,.3921300E-07,& - & .3551000E-09,.4285500E-06,.6503700E-06,.7299900E-06,.4417600E-07,& - & .3359000E-09,.4585200E-06,.6930800E-06,.7733800E-06,.4942400E-07,& - & .3186600E-09,.4845900E-06,.7329700E-06,.8148400E-06,.5413700E-07,& - & .3228000E-09,.3054700E-06,.4708300E-06,.5314700E-06,.2935300E-07,& - & .3035600E-09,.3327100E-06,.5077000E-06,.5711200E-06,.3307800E-07,& - & .2864700E-09,.3587600E-06,.5433900E-06,.6085200E-06,.3721100E-07,& - & .2712000E-09,.3821400E-06,.5778100E-06,.6435400E-06,.4129500E-07,& - & .2574600E-09,.4037400E-06,.6099000E-06,.6771100E-06,.4536200E-07,& - & .2599700E-09,.2572300E-06,.3950500E-06,.4446700E-06,.2475400E-07,& - & .2447100E-09,.2792600E-06,.4246900E-06,.4770200E-06,.2790700E-07,& - & .2311300E-09,.3002400E-06,.4538400E-06,.5067200E-06,.3134400E-07,& - & .2189800E-09,.3186200E-06,.4814200E-06,.5351500E-06,.3459000E-07,& - & .2080300E-09,.3362400E-06,.5072100E-06,.5624200E-06,.3795700E-07/ - - data absb(526:700, 2) / & - & .2098700E-09,.2156100E-06,.3303500E-06,.3709300E-06,.2080100E-07,& - & .1977100E-09,.2335600E-06,.3543300E-06,.3972300E-06,.2344300E-07,& - & .1868800E-09,.2504200E-06,.3780400E-06,.4212700E-06,.2627100E-07,& - & .1771600E-09,.2651400E-06,.4002900E-06,.4443300E-06,.2886700E-07,& - & .1684000E-09,.2794900E-06,.4210200E-06,.4661200E-06,.3162000E-07,& - & .1704600E-09,.1790900E-06,.2739700E-06,.3073000E-06,.1728300E-07,& - & .1606600E-09,.1937800E-06,.2936700E-06,.3286900E-06,.1945600E-07,& - & .1519100E-09,.2071600E-06,.3128700E-06,.3482000E-06,.2175900E-07,& - & .1440700E-09,.2193800E-06,.3309000E-06,.3670300E-06,.2385400E-07,& - & .1369900E-09,.2311500E-06,.3477900E-06,.3845900E-06,.2612800E-07,& - & .1393800E-09,.1474200E-06,.2253500E-06,.2526100E-06,.1414500E-07,& - & .1313700E-09,.1594900E-06,.2415500E-06,.2701100E-06,.1591700E-07,& - & .1242300E-09,.1703700E-06,.2572100E-06,.2860600E-06,.1780900E-07,& - & .1178200E-09,.1804400E-06,.2720000E-06,.3014900E-06,.1953000E-07,& - & .1120400E-09,.1901100E-06,.2858200E-06,.3158100E-06,.2139100E-07,& - & .1150300E-09,.1199100E-06,.1833900E-06,.2054000E-06,.1139800E-07,& - & .1083700E-09,.1298500E-06,.1967000E-06,.2199100E-06,.1282900E-07,& - & .1024400E-09,.1389500E-06,.2096400E-06,.2331000E-06,.1437000E-07,& - & .9712200E-10,.1472500E-06,.2218300E-06,.2458200E-06,.1579000E-07,& - & .9232500E-10,.1552600E-06,.2332700E-06,.2576700E-06,.1730800E-07,& - & .9499000E-10,.9743400E-07,.1491200E-06,.1669900E-06,.9174500E-08,& - & .8944900E-10,.1056300E-06,.1600700E-06,.1789000E-06,.1033000E-07,& - & .8451600E-10,.1132200E-06,.1707100E-06,.1898200E-06,.1158500E-07,& - & .8009600E-10,.1200900E-06,.1808400E-06,.2003000E-06,.1275900E-07,& - & .7611300E-10,.1267200E-06,.1902800E-06,.2101200E-06,.1399200E-07,& - & .7844400E-10,.7914700E-07,.1212200E-06,.1357300E-06,.7384600E-08,& - & .7383200E-10,.8590100E-07,.1302200E-06,.1455200E-06,.8318000E-08,& - & .6972900E-10,.9223000E-07,.1389900E-06,.1545900E-06,.9337400E-08,& - & .6605600E-10,.9791900E-07,.1473700E-06,.1632500E-06,.1030700E-07,& - & .6274900E-10,.1034100E-06,.1551800E-06,.1713300E-06,.1131200E-07,& - & .6520700E-10,.6371500E-07,.9775500E-07,.1094500E-06,.5883100E-08,& - & .6131900E-10,.6928900E-07,.1052400E-06,.1175700E-06,.6623700E-08,& - & .5786600E-10,.7469400E-07,.1124500E-06,.1251500E-06,.7445500E-08,& - & .5477900E-10,.7935900E-07,.1194100E-06,.1322900E-06,.8259500E-08,& - & .5200300E-10,.8395700E-07,.1259300E-06,.1390900E-06,.9069800E-08/ - - data absb(701:875, 2) / & - & .5426300E-10,.5117200E-07,.7871400E-07,.8818300E-07,.4674000E-08,& - & .5097800E-10,.5583800E-07,.8493900E-07,.9482800E-07,.5265500E-08,& - & .4806600E-10,.6032800E-07,.9085900E-07,.1011800E-06,.5927300E-08,& - & .4546700E-10,.6426000E-07,.9666700E-07,.1071000E-06,.6627900E-08,& - & .4313400E-10,.6808900E-07,.1020800E-06,.1127900E-06,.7256000E-08,& - & .4517000E-10,.4107300E-07,.6333300E-07,.7106700E-07,.3718500E-08,& - & .4239300E-10,.4496400E-07,.6850700E-07,.7645500E-07,.4186400E-08,& - & .3993600E-10,.4866700E-07,.7338200E-07,.8177200E-07,.4715700E-08,& - & .3774700E-10,.5199600E-07,.7822000E-07,.8668900E-07,.5283400E-08,& - & .3578400E-10,.5517800E-07,.8273900E-07,.9143400E-07,.5804000E-08,& - & .3775400E-10,.3277000E-07,.5066200E-07,.5697900E-07,.2940500E-08,& - & .3538700E-10,.3599700E-07,.5499300E-07,.6135700E-07,.3306600E-08,& - & .3329900E-10,.3907300E-07,.5903600E-07,.6579300E-07,.3726500E-08,& - & .3144200E-10,.4190300E-07,.6301400E-07,.6992000E-07,.4184800E-08,& - & .2978100E-10,.4454600E-07,.6682200E-07,.7384900E-07,.4620400E-08,& - & .3162300E-10,.2605400E-07,.4040500E-07,.4569200E-07,.2291800E-08,& - & .2959900E-10,.2871300E-07,.4401000E-07,.4912200E-07,.2605300E-08,& - & .2781700E-10,.3129600E-07,.4739100E-07,.5281500E-07,.2935300E-08,& - & .2623600E-10,.3367700E-07,.5065500E-07,.5626400E-07,.3302300E-08,& - & .2482500E-10,.3589600E-07,.5386300E-07,.5953800E-07,.3673000E-08,& - & .2650200E-10,.2070500E-07,.3215200E-07,.3644800E-07,.1784100E-08,& - & .2476800E-10,.2286800E-07,.3518500E-07,.3932900E-07,.2051500E-08,& - & .2324700E-10,.2502700E-07,.3799900E-07,.4233800E-07,.2311800E-08,& - & .2190000E-10,.2706300E-07,.4069400E-07,.4525800E-07,.2604800E-08,& - & .2070100E-10,.2890100E-07,.4336100E-07,.4796900E-07,.2917400E-08,& - & .2225800E-10,.1642200E-07,.2548000E-07,.2899100E-07,.1383000E-08,& - & .2076700E-10,.1815800E-07,.2803300E-07,.3144200E-07,.1614400E-08,& - & .1946200E-10,.1995300E-07,.3040200E-07,.3385000E-07,.1816200E-08,& - & .1831200E-10,.2165800E-07,.3263900E-07,.3630800E-07,.2047500E-08,& - & .1728900E-10,.2321100E-07,.3483900E-07,.3858300E-07,.2299400E-08,& - & .1876400E-10,.1295100E-07,.2007200E-07,.2298200E-07,.1064500E-08,& - & .1747300E-10,.1433500E-07,.2221400E-07,.2508500E-07,.1247900E-08,& - & .1634700E-10,.1581300E-07,.2420500E-07,.2697100E-07,.1420700E-08,& - & .1535700E-10,.1725500E-07,.2607500E-07,.2901500E-07,.1600800E-08,& - & .1448000E-10,.1855800E-07,.2788500E-07,.3092200E-07,.1801800E-08/ - - data absb(876:1050, 2) / & - & .1583300E-10,.1018600E-07,.1578200E-07,.1817400E-07,.8171800E-09,& - & .1471300E-10,.1131200E-07,.1755500E-07,.1989100E-07,.9609800E-09,& - & .1374000E-10,.1250900E-07,.1924800E-07,.2148200E-07,.1111200E-08,& - & .1288700E-10,.1371900E-07,.2081100E-07,.2314000E-07,.1251500E-08,& - & .1213400E-10,.1484000E-07,.2231300E-07,.2476900E-07,.1410500E-08,& - & .1337200E-10,.8005000E-08,.1240300E-07,.1428300E-07,.6311700E-09,& - & .1239800E-10,.8939300E-08,.1384000E-07,.1575100E-07,.7390700E-09,& - & .1155600E-10,.9882100E-08,.1526100E-07,.1710400E-07,.8664500E-09,& - & .1082100E-10,.1088400E-07,.1658200E-07,.1844100E-07,.9782900E-09,& - & .1017400E-10,.1184100E-07,.1782800E-07,.1980400E-07,.1103400E-08,& - & .1128200E-10,.6272600E-08,.9747800E-08,.1122600E-07,.4839800E-09,& - & .1043700E-10,.7054600E-08,.1093200E-07,.1251800E-07,.5705100E-09,& - & .9710100E-11,.7819300E-08,.1211400E-07,.1367100E-07,.6699700E-09,& - & .9077200E-11,.8637900E-08,.1321800E-07,.1471200E-07,.7662500E-09,& - & .8521600E-11,.9440500E-08,.1425800E-07,.1584400E-07,.8648800E-09,& - & .9517900E-11,.4925100E-08,.7635600E-08,.8776100E-08,.3721300E-09,& - & .8785600E-11,.5568100E-08,.8622000E-08,.9915900E-08,.4407400E-09,& - & .8157600E-11,.6193000E-08,.9598900E-08,.1086500E-07,.5184300E-09,& - & .7613100E-11,.6851800E-08,.1053900E-07,.1174600E-07,.6021000E-09,& - & .7136600E-11,.7520600E-08,.1140300E-07,.1265900E-07,.6784100E-09,& - & .8036800E-11,.3860800E-08,.6001000E-08,.6844100E-08,.2884800E-09,& - & .7400700E-11,.4390300E-08,.6797400E-08,.7812700E-08,.3424500E-09,& - & .6857700E-11,.4908600E-08,.7595900E-08,.8627900E-08,.4010600E-09,& - & .6388600E-11,.5429700E-08,.8380100E-08,.9377800E-08,.4705800E-09,& - & .5979500E-11,.5982900E-08,.9110300E-08,.1011100E-07,.5321800E-09,& - & .6793200E-11,.3010200E-08,.4726900E-08,.5339500E-08,.2243200E-09,& - & .6239700E-11,.3445000E-08,.5345800E-08,.6144900E-08,.2628200E-09,& - & .5769300E-11,.3876800E-08,.6000600E-08,.6861300E-08,.3102000E-09,& - & .5364700E-11,.4300200E-08,.6653300E-08,.7499000E-08,.3644600E-09,& - & .5012900E-11,.4752700E-08,.7263800E-08,.8071700E-08,.4175900E-09,& - & .5732000E-11,.2358200E-08,.3683700E-08,.4131700E-08,.1747700E-09,& - & .5251800E-11,.2716300E-08,.4204800E-08,.4820800E-08,.2032100E-09,& - & .4845700E-11,.3067800E-08,.4747200E-08,.5447200E-08,.2408100E-09,& - & .4497800E-11,.3414800E-08,.5285100E-08,.5973500E-08,.2834500E-09,& - & .4196300E-11,.3780400E-08,.5800100E-08,.6457000E-08,.3292300E-09/ - - data absb(1051:1175, 2) / & - & .4834700E-11,.1853400E-08,.2853900E-08,.3182800E-08,.1349200E-09,& - & .4418600E-11,.2139200E-08,.3319000E-08,.3781700E-08,.1584800E-09,& - & .4068300E-11,.2432000E-08,.3759200E-08,.4315600E-08,.1883500E-09,& - & .3769300E-11,.2715000E-08,.4199900E-08,.4762500E-08,.2207600E-09,& - & .3511100E-11,.3008200E-08,.4634500E-08,.5173600E-08,.2591600E-09,& - & .4081300E-11,.1454300E-08,.2203800E-08,.2448800E-08,.1032800E-09,& - & .3720100E-11,.1681300E-08,.2637100E-08,.2964000E-08,.1244600E-09,& - & .3417500E-11,.1919100E-08,.2974700E-08,.3411500E-08,.1460400E-09,& - & .3160400E-11,.2157500E-08,.3334800E-08,.3801800E-08,.1720200E-09,& - & .2939100E-11,.2393200E-08,.3693000E-08,.4147200E-08,.2023500E-09,& - & .3448600E-11,.1148000E-08,.1703200E-08,.1877100E-08,.7878700E-10,& - & .3134500E-11,.1318900E-08,.2061500E-08,.2312100E-08,.9683200E-10,& - & .2872800E-11,.1514400E-08,.2344000E-08,.2686300E-08,.1131700E-09,& - & .2651300E-11,.1710200E-08,.2643600E-08,.3024600E-08,.1339300E-09,& - & .2461500E-11,.1902200E-08,.2939400E-08,.3313500E-08,.1577200E-09,& - & .2911900E-11,.8950000E-09,.1302000E-08,.1438300E-08,.6025300E-10,& - & .2639200E-11,.1036900E-08,.1603600E-08,.1789100E-08,.7576500E-10,& - & .2413200E-11,.1197500E-08,.1852300E-08,.2111400E-08,.8826000E-10,& - & .2222700E-11,.1357000E-08,.2095900E-08,.2404500E-08,.1047800E-09,& - & .2060100E-11,.1513900E-08,.2340600E-08,.2645600E-08,.1233100E-09,& - & .2414300E-11,.7185100E-09,.1036200E-08,.1151600E-08,.4808600E-10,& - & .2185700E-11,.8373200E-09,.1289200E-08,.1433500E-08,.6063000E-10,& - & .1996500E-11,.9681500E-09,.1499000E-08,.1703900E-08,.7120800E-10,& - & .1837400E-11,.1098200E-08,.1697300E-08,.1945500E-08,.8451400E-10,& - & .1701700E-11,.1227700E-08,.1898100E-08,.2147200E-08,.9928900E-10/ - - data absb( 1:175, 3) / & - & .6949700E-07,.5590000E-04,.7763400E-04,.8330000E-04,.1441900E-04,& - & .6492300E-07,.6177900E-04,.8523800E-04,.9045800E-04,.1599600E-04,& - & .6092000E-07,.6753200E-04,.9281100E-04,.9758800E-04,.1762200E-04,& - & .5737900E-07,.7287600E-04,.1004000E-03,.1045500E-03,.1914400E-04,& - & .5422000E-07,.7769900E-04,.1078400E-03,.1113900E-03,.2067100E-04,& - & .5653800E-07,.4662700E-04,.6467800E-04,.6939900E-04,.1208600E-04,& - & .5283900E-07,.5153600E-04,.7108000E-04,.7529200E-04,.1341400E-04,& - & .4960000E-07,.5633400E-04,.7738400E-04,.8127700E-04,.1473200E-04,& - & .4673100E-07,.6075100E-04,.8375300E-04,.8706700E-04,.1597300E-04,& - & .4417100E-07,.6479200E-04,.8996300E-04,.9261700E-04,.1721400E-04,& - & .4596300E-07,.3892000E-04,.5392100E-04,.5782400E-04,.1008900E-04,& - & .4297600E-07,.4298700E-04,.5928600E-04,.6261500E-04,.1123800E-04,& - & .4035800E-07,.4701400E-04,.6455700E-04,.6765800E-04,.1229300E-04,& - & .3803700E-07,.5064100E-04,.6987900E-04,.7248700E-04,.1331700E-04,& - & .3596400E-07,.5400300E-04,.7506400E-04,.7708300E-04,.1432100E-04,& - & .3735400E-07,.3247900E-04,.4495300E-04,.4814600E-04,.8407900E-05,& - & .3494400E-07,.3587300E-04,.4945400E-04,.5212000E-04,.9340500E-05,& - & .3282900E-07,.3922000E-04,.5386100E-04,.5629300E-04,.1020900E-04,& - & .3095200E-07,.4215500E-04,.5830900E-04,.6026800E-04,.1108000E-04,& - & .2927400E-07,.4501400E-04,.6261000E-04,.6418400E-04,.1188700E-04,& - & .3036400E-07,.2708600E-04,.3745100E-04,.3999500E-04,.7004900E-05,& - & .2842000E-07,.2991900E-04,.4119400E-04,.4336700E-04,.7773600E-05,& - & .2671000E-07,.3265000E-04,.4490200E-04,.4681700E-04,.8483800E-05,& - & .2519200E-07,.3509800E-04,.4860500E-04,.5010300E-04,.9203800E-05,& - & .2383300E-07,.3750700E-04,.5218800E-04,.5341300E-04,.9860700E-05,& - & .2468700E-07,.2258100E-04,.3121100E-04,.3322000E-04,.5836100E-05,& - & .2311600E-07,.2494000E-04,.3430800E-04,.3607800E-04,.6464000E-05,& - & .2173400E-07,.2718100E-04,.3741400E-04,.3893300E-04,.7034400E-05,& - & .2050600E-07,.2921600E-04,.4051700E-04,.4165300E-04,.7627600E-05,& - & .1940600E-07,.3123700E-04,.4349000E-04,.4439700E-04,.8175300E-05,& - & .2007400E-07,.1881800E-04,.2599900E-04,.2759700E-04,.4866200E-05,& - & .1880500E-07,.2078400E-04,.2856200E-04,.2999300E-04,.5372300E-05,& - & .1768800E-07,.2262600E-04,.3115100E-04,.3236300E-04,.5837700E-05,& - & .1669300E-07,.2430000E-04,.3376000E-04,.3462900E-04,.6317700E-05,& - & .1580200E-07,.2598500E-04,.3622600E-04,.3690300E-04,.6774200E-05/ - - data absb(176:350, 3) / & - & .1630600E-07,.1571700E-04,.2168600E-04,.2295900E-04,.4068000E-05,& - & .1528300E-07,.1735500E-04,.2382600E-04,.2496900E-04,.4470600E-05,& - & .1438100E-07,.1885600E-04,.2599200E-04,.2691200E-04,.4855000E-05,& - & .1357800E-07,.2026500E-04,.2816200E-04,.2881700E-04,.5235500E-05,& - & .1285700E-07,.2163800E-04,.3021500E-04,.3070700E-04,.5622400E-05,& - & .1324500E-07,.1312800E-04,.1809100E-04,.1910700E-04,.3388000E-05,& - & .1242000E-07,.1449500E-04,.1988700E-04,.2079400E-04,.3714400E-05,& - & .1169200E-07,.1570400E-04,.2170300E-04,.2239700E-04,.4041500E-05,& - & .1104300E-07,.1690400E-04,.2348900E-04,.2398400E-04,.4345500E-05,& - & .1046000E-07,.1803700E-04,.2519700E-04,.2555800E-04,.4666200E-05,& - & .1071100E-07,.1104400E-04,.1519900E-04,.1600800E-04,.2840900E-05,& - & .1005200E-07,.1216500E-04,.1669900E-04,.1741900E-04,.3104100E-05,& - & .9469000E-08,.1315800E-04,.1822400E-04,.1873300E-04,.3376800E-05,& - & .8948400E-08,.1416600E-04,.1969100E-04,.2005000E-04,.3623700E-05,& - & .8480400E-08,.1508500E-04,.2110500E-04,.2135600E-04,.3887600E-05,& - & .8660600E-08,.9300200E-05,.1277500E-04,.1342000E-04,.2381500E-05,& - & .8134000E-08,.1021000E-04,.1403400E-04,.1455200E-04,.2595500E-05,& - & .7667100E-08,.1103500E-04,.1530200E-04,.1565700E-04,.2815000E-05,& - & .7249700E-08,.1186300E-04,.1651300E-04,.1677000E-04,.3019800E-05,& - & .6873900E-08,.1261600E-04,.1766400E-04,.1784800E-04,.3238700E-05,& - & .6999500E-08,.7839200E-05,.1075400E-04,.1125000E-04,.1998600E-05,& - & .6579000E-08,.8567400E-05,.1180600E-04,.1218600E-04,.2173800E-05,& - & .6205500E-08,.9266400E-05,.1285000E-04,.1310300E-04,.2346900E-05,& - & .5871000E-08,.9937600E-05,.1385400E-04,.1402700E-04,.2519500E-05,& - & .5569600E-08,.1052700E-04,.1479500E-04,.1491700E-04,.2698800E-05,& - & .5653800E-08,.6611800E-05,.9061000E-05,.9442200E-05,.1675300E-05,& - & .5318400E-08,.7198600E-05,.9938900E-05,.1020900E-04,.1822300E-05,& - & .5019900E-08,.7786300E-05,.1080000E-04,.1098100E-04,.1959000E-05,& - & .4752200E-08,.8341500E-05,.1162600E-04,.1173700E-04,.2102000E-05,& - & .4510500E-08,.8801700E-05,.1237300E-04,.1246800E-04,.2249800E-05,& - & .4562000E-08,.5574900E-05,.7646300E-05,.7928500E-05,.1403200E-05,& - & .4295000E-08,.6059000E-05,.8382200E-05,.8565200E-05,.1525500E-05,& - & .4056900E-08,.6551000E-05,.9088800E-05,.9211600E-05,.1637300E-05,& - & .3842900E-08,.6991800E-05,.9760400E-05,.9832900E-05,.1756100E-05,& - & .3649500E-08,.7356600E-05,.1036700E-04,.1042900E-04,.1876900E-05/ - - data absb(351:525, 3) / & - & .3680900E-08,.4696700E-05,.6458000E-05,.6664900E-05,.1178600E-05,& - & .3468300E-08,.5107200E-05,.7066100E-05,.7190200E-05,.1275900E-05,& - & .3278400E-08,.5505300E-05,.7647000E-05,.7725000E-05,.1369100E-05,& - & .3107400E-08,.5847400E-05,.8189800E-05,.8234000E-05,.1466600E-05,& - & .2952600E-08,.6149300E-05,.8681500E-05,.8719900E-05,.1565000E-05,& - & .2970100E-08,.3958200E-05,.5457300E-05,.5595900E-05,.9903700E-06,& - & .2800800E-08,.4304800E-05,.5954600E-05,.6040600E-05,.1065900E-05,& - & .2649300E-08,.4627700E-05,.6428600E-05,.6474500E-05,.1144200E-05,& - & .2512700E-08,.4894000E-05,.6861200E-05,.6891800E-05,.1225000E-05,& - & .2388800E-08,.5142800E-05,.7265400E-05,.7286500E-05,.1304600E-05,& - & .2395800E-08,.3340900E-05,.4611500E-05,.4705400E-05,.8302100E-06,& - & .2261100E-08,.3626700E-05,.5019200E-05,.5075400E-05,.8915700E-06,& - & .2140200E-08,.3880500E-05,.5405300E-05,.5429100E-05,.9566300E-06,& - & .2031100E-08,.4092900E-05,.5752900E-05,.5768500E-05,.1023200E-05,& - & .1932000E-08,.4301400E-05,.6068400E-05,.6086800E-05,.1087400E-05,& - & .1932800E-08,.2821700E-05,.3895500E-05,.3956200E-05,.6946400E-06,& - & .1825500E-08,.3051500E-05,.4229300E-05,.4260500E-05,.7458800E-06,& - & .1729100E-08,.3249600E-05,.4539000E-05,.4550100E-05,.7995700E-06,& - & .1641900E-08,.3423500E-05,.4819100E-05,.4824900E-05,.8537300E-06,& - & .1562600E-08,.3599200E-05,.5063200E-05,.5080500E-05,.9058200E-06,& - & .1559000E-08,.2384100E-05,.3289000E-05,.3328200E-05,.5810800E-06,& - & .1473600E-08,.2568300E-05,.3560500E-05,.3575600E-05,.6240100E-06,& - & .1396700E-08,.2722300E-05,.3805500E-05,.3811000E-05,.6686200E-06,& - & .1327100E-08,.2865200E-05,.4029500E-05,.4033100E-05,.7121600E-06,& - & .1263700E-08,.3006900E-05,.4225700E-05,.4239300E-05,.7552700E-06,& - & .1257500E-08,.2009900E-05,.2776400E-05,.2798800E-05,.4861400E-06,& - & .1189500E-08,.2155100E-05,.2996100E-05,.2999600E-05,.5219900E-06,& - & .1128200E-08,.2277100E-05,.3190100E-05,.3189700E-05,.5586700E-06,& - & .1072600E-08,.2396900E-05,.3365700E-05,.3369600E-05,.5941000E-06,& - & .1021800E-08,.2507600E-05,.3523200E-05,.3536600E-05,.6296500E-06,& - & .1014400E-08,.1694000E-05,.2342100E-05,.2351900E-05,.4070100E-06,& - & .9602400E-09,.1806600E-05,.2514600E-05,.2514800E-05,.4365700E-06,& - & .9113400E-09,.1905300E-05,.2673800E-05,.2669000E-05,.4665600E-06,& - & .8668900E-09,.2003800E-05,.2810400E-05,.2813900E-05,.4951600E-06,& - & .8263000E-09,.2086000E-05,.2929400E-05,.2948500E-05,.5246200E-06/ - - data absb(526:700, 3) / & - & .8200000E-09,.1423100E-05,.1966100E-05,.1970000E-05,.3399600E-06,& - & .7767200E-09,.1510500E-05,.2104700E-05,.2101800E-05,.3643500E-06,& - & .7375700E-09,.1590800E-05,.2230700E-05,.2227200E-05,.3885100E-06,& - & .7019300E-09,.1670600E-05,.2342100E-05,.2344800E-05,.4121900E-06,& - & .6693600E-09,.1733000E-05,.2434200E-05,.2453800E-05,.4360700E-06,& - & .6665200E-09,.1184200E-05,.1638300E-05,.1638200E-05,.2818300E-06,& - & .6315600E-09,.1254100E-05,.1749900E-05,.1745700E-05,.3019500E-06,& - & .5999000E-09,.1320900E-05,.1850400E-05,.1848400E-05,.3217400E-06,& - & .5710700E-09,.1385000E-05,.1941800E-05,.1943800E-05,.3412400E-06,& - & .5447000E-09,.1434800E-05,.2013500E-05,.2033500E-05,.3605000E-06,& - & .5450600E-09,.9787000E-06,.1354100E-05,.1352000E-05,.2319000E-06,& - & .5165000E-09,.1035400E-05,.1445500E-05,.1440400E-05,.2484500E-06,& - & .4906300E-09,.1091000E-05,.1527000E-05,.1524700E-05,.2646400E-06,& - & .4670700E-09,.1142700E-05,.1601200E-05,.1603300E-05,.2807200E-06,& - & .4455300E-09,.1183300E-05,.1660400E-05,.1677400E-05,.2964300E-06,& - & .4494900E-09,.8010400E-06,.1106600E-05,.1104500E-05,.1888800E-06,& - & .4257900E-09,.8481000E-06,.1182600E-05,.1177700E-05,.2024200E-06,& - & .4043500E-09,.8940400E-06,.1250400E-05,.1247700E-05,.2157800E-06,& - & .3848300E-09,.9373700E-06,.1312400E-05,.1312900E-05,.2289200E-06,& - & .3669900E-09,.9711800E-06,.1361700E-05,.1374400E-05,.2419000E-06,& - & .3708800E-09,.6546800E-06,.9034700E-06,.9014000E-06,.1537100E-06,& - & .3512000E-09,.6942100E-06,.9667600E-06,.9622200E-06,.1648400E-06,& - & .3334000E-09,.7321100E-06,.1023300E-05,.1020300E-05,.1757800E-06,& - & .3172100E-09,.7683800E-06,.1075000E-05,.1074500E-05,.1865600E-06,& - & .3024200E-09,.7967600E-06,.1116400E-05,.1125600E-05,.1973000E-06,& - & .3060300E-09,.5351800E-06,.7375500E-06,.7356000E-06,.1250900E-06,& - & .2896700E-09,.5682700E-06,.7901700E-06,.7860700E-06,.1342000E-06,& - & .2749000E-09,.5994600E-06,.8372900E-06,.8341800E-06,.1432000E-06,& - & .2614800E-09,.6296800E-06,.8804500E-06,.8791900E-06,.1520600E-06,& - & .2492200E-09,.6535800E-06,.9151100E-06,.9218700E-06,.1609200E-06,& - & .2540100E-09,.4349100E-06,.5970600E-06,.5958300E-06,.1010300E-06,& - & .2402700E-09,.4624300E-06,.6412700E-06,.6378000E-06,.1085400E-06,& - & .2278800E-09,.4878900E-06,.6811100E-06,.6778500E-06,.1159600E-06,& - & .2166400E-09,.5137000E-06,.7177600E-06,.7155700E-06,.1231800E-06,& - & .2063900E-09,.5341300E-06,.7473800E-06,.7511600E-06,.1305500E-06/ - - data absb(701:875, 3) / & - & .2110300E-09,.3516200E-06,.4824500E-06,.4818100E-06,.8155100E-07,& - & .1994700E-09,.3757700E-06,.5197500E-06,.5168300E-06,.8762400E-07,& - & .1890600E-09,.3968100E-06,.5537200E-06,.5501600E-06,.9377500E-07,& - & .1796300E-09,.4185600E-06,.5840500E-06,.5817700E-06,.9967700E-07,& - & .1710500E-09,.4361000E-06,.6095700E-06,.6115000E-06,.1057800E-06,& - & .1753600E-09,.2841200E-06,.3894800E-06,.3893300E-06,.6579100E-07,& - & .1656300E-09,.3050400E-06,.4209700E-06,.4185400E-06,.7075200E-07,& - & .1568800E-09,.3226500E-06,.4495700E-06,.4462400E-06,.7579000E-07,& - & .1489700E-09,.3408000E-06,.4750200E-06,.4726800E-06,.8064800E-07,& - & .1417800E-09,.3558400E-06,.4969600E-06,.4974700E-06,.8568500E-07,& - & .1462500E-09,.2282800E-06,.3126900E-06,.3130100E-06,.5285800E-07,& - & .1380000E-09,.2466000E-06,.3394500E-06,.3373600E-06,.5687200E-07,& - & .1306000E-09,.2615000E-06,.3638200E-06,.3605200E-06,.6100500E-07,& - & .1239200E-09,.2763700E-06,.3849600E-06,.3826200E-06,.6506400E-07,& - & .1178600E-09,.2896000E-06,.4043200E-06,.4034600E-06,.6913400E-07,& - & .1222000E-09,.1829900E-06,.2500300E-06,.2507500E-06,.4242600E-07,& - & .1151800E-09,.1985800E-06,.2727100E-06,.2712400E-06,.4560500E-07,& - & .1089000E-09,.2114900E-06,.2930600E-06,.2905900E-06,.4898900E-07,& - & .1032400E-09,.2236100E-06,.3112800E-06,.3090900E-06,.5235700E-07,& - & .9811900E-10,.2354000E-06,.3278200E-06,.3265700E-06,.5565000E-07,& - & .1021500E-09,.1460400E-06,.1995700E-06,.2007900E-06,.3400900E-07,& - & .9616800E-10,.1597600E-06,.2185900E-06,.2178200E-06,.3656500E-07,& - & .9083200E-10,.1709200E-06,.2359400E-06,.2340300E-06,.3933600E-07,& - & .8603900E-10,.1807600E-06,.2514800E-06,.2494000E-06,.4212000E-07,& - & .8170500E-10,.1909100E-06,.2657900E-06,.2641700E-06,.4480600E-07,& - & .8554800E-10,.1160600E-06,.1585800E-06,.1602500E-06,.2713800E-07,& - & .8043000E-10,.1277700E-06,.1746500E-06,.1743900E-06,.2926000E-07,& - & .7588200E-10,.1377100E-06,.1895600E-06,.1880100E-06,.3151900E-07,& - & .7180700E-10,.1459700E-06,.2028200E-06,.2008500E-06,.3379000E-07,& - & .6813100E-10,.1545400E-06,.2148500E-06,.2132100E-06,.3601600E-07,& - & .7188000E-10,.9167700E-07,.1251800E-06,.1271700E-06,.2154800E-07,& - & .6747400E-10,.1018200E-06,.1388500E-06,.1388700E-06,.2336600E-07,& - & .6357300E-10,.1103700E-06,.1515500E-06,.1503700E-06,.2514000E-07,& - & .6008900E-10,.1175700E-06,.1629200E-06,.1611500E-06,.2702300E-07,& - & .5695500E-10,.1246000E-06,.1730300E-06,.1715000E-06,.2888600E-07/ - - data absb(876:1050, 3) / & - & .6043800E-10,.7237800E-07,.9858600E-07,.1007500E-06,.1706800E-07,& - & .5663900E-10,.8066200E-07,.1100300E-06,.1105200E-06,.1864300E-07,& - & .5328800E-10,.8839100E-07,.1206900E-06,.1200700E-06,.2005000E-07,& - & .5030600E-10,.9462400E-07,.1304500E-06,.1291600E-06,.2158700E-07,& - & .4763200E-10,.1002600E-06,.1391400E-06,.1377800E-06,.2313600E-07,& - & .5085600E-10,.5704600E-07,.7756500E-07,.7974100E-07,.1351000E-07,& - & .4757400E-10,.6373000E-07,.8693900E-07,.8782600E-07,.1481100E-07,& - & .4469200E-10,.7036700E-07,.9597400E-07,.9570700E-07,.1599200E-07,& - & .4213600E-10,.7595900E-07,.1044100E-06,.1033600E-06,.1723500E-07,& - & .3985100E-10,.8066200E-07,.1117900E-06,.1106100E-06,.1850100E-07,& - & .4275200E-10,.4499400E-07,.6093300E-07,.6317000E-07,.1073300E-07,& - & .3992000E-10,.5041700E-07,.6869500E-07,.6977600E-07,.1177800E-07,& - & .3744500E-10,.5612900E-07,.7638100E-07,.7629200E-07,.1279600E-07,& - & .3525800E-10,.6091600E-07,.8353300E-07,.8274600E-07,.1377000E-07,& - & .3330900E-10,.6501000E-07,.8993300E-07,.8882800E-07,.1480900E-07,& - & .3593500E-10,.3527800E-07,.4790100E-07,.5005600E-07,.8523900E-08,& - & .3349400E-10,.3989700E-07,.5424500E-07,.5543900E-07,.9356200E-08,& - & .3136800E-10,.4457700E-07,.6068700E-07,.6085400E-07,.1022900E-07,& - & .2949700E-10,.4890600E-07,.6666800E-07,.6621700E-07,.1100900E-07,& - & .2783400E-10,.5234800E-07,.7215400E-07,.7132200E-07,.1185600E-07,& - & .3022700E-10,.2757200E-07,.3752400E-07,.3975400E-07,.6719800E-08,& - & .2811800E-10,.3156000E-07,.4281000E-07,.4403100E-07,.7426700E-08,& - & .2629000E-10,.3531900E-07,.4807900E-07,.4848600E-07,.8151100E-08,& - & .2468700E-10,.3904100E-07,.5314100E-07,.5289800E-07,.8804400E-08,& - & .2326700E-10,.4212300E-07,.5783500E-07,.5717700E-07,.9493400E-08,& - & .2544800E-10,.2145600E-07,.2932400E-07,.3145000E-07,.5303500E-08,& - & .2362300E-10,.2492200E-07,.3370600E-07,.3490300E-07,.5902500E-08,& - & .2204800E-10,.2793100E-07,.3800900E-07,.3854800E-07,.6484200E-08,& - & .2067300E-10,.3111700E-07,.4229300E-07,.4218000E-07,.7045400E-08,& - & .1945900E-10,.3380000E-07,.4631600E-07,.4577600E-07,.7588600E-08,& - & .2139000E-10,.1674300E-07,.2303100E-07,.2487700E-07,.4177700E-08,& - & .1981500E-10,.1961900E-07,.2655600E-07,.2772200E-07,.4703100E-08,& - & .1846300E-10,.2216700E-07,.3010100E-07,.3070800E-07,.5164600E-08,& - & .1728600E-10,.2480400E-07,.3370400E-07,.3371600E-07,.5644800E-08,& - & .1625100E-10,.2718300E-07,.3704900E-07,.3669600E-07,.6078800E-08/ - - data absb(1051:1175, 3) / & - & .1797300E-10,.1303700E-07,.1811500E-07,.1972700E-07,.3291200E-08,& - & .1661500E-10,.1540200E-07,.2094200E-07,.2204300E-07,.3730100E-08,& - & .1545400E-10,.1759200E-07,.2384800E-07,.2448500E-07,.4112900E-08,& - & .1444800E-10,.1973300E-07,.2681500E-07,.2695400E-07,.4514600E-08,& - & .1356500E-10,.2178500E-07,.2963300E-07,.2941400E-07,.4876200E-08,& - & .1511200E-10,.1012700E-07,.1426200E-07,.1563700E-07,.2598600E-08,& - & .1393900E-10,.1208200E-07,.1645800E-07,.1756700E-07,.2951000E-08,& - & .1294200E-10,.1398000E-07,.1887600E-07,.1949900E-07,.3280300E-08,& - & .1208000E-10,.1567700E-07,.2129800E-07,.2151600E-07,.3607800E-08,& - & .1132800E-10,.1742100E-07,.2367400E-07,.2355200E-07,.3914200E-08,& - & .1271600E-10,.7842300E-08,.1121800E-07,.1236800E-07,.2057200E-08,& - & .1170300E-10,.9446800E-08,.1294400E-07,.1393900E-07,.2344900E-08,& - & .1084400E-10,.1105400E-07,.1493300E-07,.1550400E-07,.2616100E-08,& - & .1010500E-10,.1244500E-07,.1689500E-07,.1716700E-07,.2878900E-08,& - & .9462900E-11,.1392900E-07,.1888400E-07,.1883700E-07,.3139100E-08,& - & .1069400E-10,.6108400E-08,.8827800E-08,.9780100E-08,.1619200E-08,& - & .9818000E-11,.7385900E-08,.1020600E-07,.1106400E-07,.1848600E-08,& - & .9079700E-11,.8711300E-08,.1180100E-07,.1234800E-07,.2087200E-08,& - & .8447800E-11,.9900300E-08,.1340900E-07,.1370700E-07,.2296700E-08,& - & .7899800E-11,.1110800E-07,.1506900E-07,.1508200E-07,.2518200E-08,& - & .8851300E-11,.4923900E-08,.7138600E-08,.7917000E-08,.1308900E-08,& - & .8118700E-11,.5954100E-08,.8253900E-08,.8975800E-08,.1495200E-08,& - & .7502100E-11,.7045000E-08,.9556700E-08,.1002400E-07,.1691900E-08,& - & .6975300E-11,.8039100E-08,.1087400E-07,.1114300E-07,.1864600E-08,& - & .6519100E-11,.9026500E-08,.1224000E-07,.1226800E-07,.2047100E-08/ - - data absb( 1:175, 4) / & - & .4011500E-06,.2054200E-03,.2900600E-03,.2998300E-03,.8640400E-04,& - & .3850300E-06,.2208600E-03,.3083300E-03,.3251800E-03,.9261100E-04,& - & .3704200E-06,.2341500E-03,.3267400E-03,.3481400E-03,.9887800E-04,& - & .3569900E-06,.2460700E-03,.3433500E-03,.3685800E-03,.1055900E-03,& - & .3443900E-06,.2574100E-03,.3594300E-03,.3871600E-03,.1126200E-03,& - & .3271700E-06,.1708600E-03,.2412100E-03,.2500100E-03,.7212000E-04,& - & .3141100E-06,.1835800E-03,.2559900E-03,.2708900E-03,.7735100E-04,& - & .3022500E-06,.1945600E-03,.2714900E-03,.2900200E-03,.8267600E-04,& - & .2913200E-06,.2046000E-03,.2854400E-03,.3067800E-03,.8833100E-04,& - & .2810500E-06,.2141000E-03,.2991900E-03,.3227100E-03,.9445100E-04,& - & .2667300E-06,.1422100E-03,.2004800E-03,.2084300E-03,.6021300E-04,& - & .2561500E-06,.1526800E-03,.2126400E-03,.2253100E-03,.6453100E-04,& - & .2465200E-06,.1617000E-03,.2256700E-03,.2415700E-03,.6910200E-04,& - & .2376400E-06,.1702300E-03,.2375000E-03,.2554300E-03,.7389100E-04,& - & .2292600E-06,.1781500E-03,.2491200E-03,.2689200E-03,.7916700E-04,& - & .2174000E-06,.1182400E-03,.1664400E-03,.1738100E-03,.5022700E-04,& - & .2088400E-06,.1269600E-03,.1768300E-03,.1878000E-03,.5390300E-04,& - & .2010400E-06,.1343400E-03,.1876400E-03,.2009400E-03,.5777700E-04,& - & .1938100E-06,.1417700E-03,.1975700E-03,.2125900E-03,.6182100E-04,& - & .1869800E-06,.1482800E-03,.2074700E-03,.2241600E-03,.6632600E-04,& - & .1772400E-06,.9828700E-04,.1381300E-03,.1449600E-03,.4185100E-04,& - & .1702900E-06,.1054800E-03,.1470100E-03,.1563600E-03,.4494300E-04,& - & .1639600E-06,.1116900E-03,.1560500E-03,.1672700E-03,.4817600E-04,& - & .1580900E-06,.1179500E-03,.1643500E-03,.1768400E-03,.5171600E-04,& - & .1525100E-06,.1233200E-03,.1726500E-03,.1868300E-03,.5548000E-04,& - & .1445000E-06,.8170300E-04,.1146400E-03,.1207900E-03,.3484900E-04,& - & .1388700E-06,.8758000E-04,.1222400E-03,.1302800E-03,.3746500E-04,& - & .1337300E-06,.9286900E-04,.1296600E-03,.1390600E-03,.4022500E-04,& - & .1289600E-06,.9803400E-04,.1366800E-03,.1471200E-03,.4322700E-04,& - & .1243900E-06,.1025000E-03,.1436700E-03,.1555700E-03,.4638300E-04,& - & .1178200E-06,.6792200E-04,.9512100E-04,.1005900E-03,.2901400E-04,& - & .1132500E-06,.7275900E-04,.1016600E-03,.1084300E-03,.3123900E-04,& - & .1090900E-06,.7721300E-04,.1076900E-03,.1156300E-03,.3359400E-04,& - & .1052100E-06,.8150700E-04,.1136700E-03,.1224400E-03,.3608700E-04,& - & .1014600E-06,.8522900E-04,.1195100E-03,.1295500E-03,.3876000E-04/ - - data absb(176:350, 4) / & - & .9600500E-07,.5653900E-04,.7904800E-04,.8363800E-04,.2418200E-04,& - & .9231100E-07,.6052200E-04,.8450600E-04,.9030800E-04,.2605200E-04,& - & .8892700E-07,.6430500E-04,.8960800E-04,.9622900E-04,.2807100E-04,& - & .8577500E-07,.6781100E-04,.9465900E-04,.1020300E-03,.3018500E-04,& - & .8270900E-07,.7096700E-04,.9955100E-04,.1079600E-03,.3243800E-04,& - & .7822500E-07,.4709400E-04,.6573600E-04,.6970600E-04,.2016800E-04,& - & .7523500E-07,.5038300E-04,.7030900E-04,.7521000E-04,.2174800E-04,& - & .7249100E-07,.5358100E-04,.7457900E-04,.8010600E-04,.2344200E-04,& - & .6992900E-07,.5644800E-04,.7886400E-04,.8510800E-04,.2524800E-04,& - & .6741900E-07,.5909000E-04,.8293200E-04,.8987000E-04,.2709800E-04,& - & .6357200E-07,.3942600E-04,.5497900E-04,.5844300E-04,.1691300E-04,& - & .6116600E-07,.4209700E-04,.5877900E-04,.6293300E-04,.1825900E-04,& - & .5895100E-07,.4479400E-04,.6233000E-04,.6695200E-04,.1967000E-04,& - & .5687200E-07,.4714700E-04,.6596100E-04,.7123000E-04,.2122100E-04,& - & .5482200E-07,.4937700E-04,.6923400E-04,.7503800E-04,.2274300E-04,& - & .5165600E-07,.3295000E-04,.4605200E-04,.4908400E-04,.1418100E-04,& - & .4972100E-07,.3525000E-04,.4910600E-04,.5267500E-04,.1533000E-04,& - & .4793000E-07,.3743800E-04,.5215200E-04,.5609700E-04,.1653200E-04,& - & .4624200E-07,.3941800E-04,.5516000E-04,.5967400E-04,.1781100E-04,& - & .4457000E-07,.4128000E-04,.5789900E-04,.6265400E-04,.1910000E-04,& - & .4196200E-07,.2760800E-04,.3852700E-04,.4116700E-04,.1190800E-04,& - & .4040500E-07,.2954700E-04,.4109900E-04,.4408100E-04,.1288000E-04,& - & .3895900E-07,.3132100E-04,.4368700E-04,.4705100E-04,.1391200E-04,& - & .3758300E-07,.3299400E-04,.4619000E-04,.4989000E-04,.1496100E-04,& - & .3622700E-07,.3456000E-04,.4847300E-04,.5235800E-04,.1603900E-04,& - & .3407500E-07,.2315300E-04,.3230500E-04,.3456600E-04,.1001400E-04,& - & .3282200E-07,.2476900E-04,.3443500E-04,.3696800E-04,.1082200E-04,& - & .3165500E-07,.2624200E-04,.3663500E-04,.3948400E-04,.1169900E-04,& - & .3052800E-07,.2762400E-04,.3864800E-04,.4177000E-04,.1258800E-04,& - & .2943400E-07,.2895100E-04,.4063200E-04,.4377400E-04,.1347900E-04,& - & .2765200E-07,.1946000E-04,.2711400E-04,.2905200E-04,.8437200E-05,& - & .2664500E-07,.2078500E-04,.2893300E-04,.3109100E-04,.9130500E-05,& - & .2570300E-07,.2201800E-04,.3074900E-04,.3317300E-04,.9856000E-05,& - & .2478000E-07,.2316600E-04,.3240500E-04,.3497100E-04,.1059300E-04,& - & .2390000E-07,.2428600E-04,.3404800E-04,.3666300E-04,.1134600E-04/ - - data absb(351:525, 4) / & - & .2243900E-07,.1637000E-04,.2276300E-04,.2439700E-04,.7108400E-05,& - & .2162800E-07,.1746100E-04,.2431800E-04,.2614000E-04,.7696100E-05,& - & .2086500E-07,.1849300E-04,.2582600E-04,.2782400E-04,.8308000E-05,& - & .2011300E-07,.1945200E-04,.2721500E-04,.2928700E-04,.8920700E-05,& - & .1940500E-07,.2037600E-04,.2854300E-04,.3071000E-04,.9547700E-05,& - & .1820800E-07,.1377700E-04,.1913800E-04,.2052400E-04,.5995200E-05,& - & .1755500E-07,.1467900E-04,.2044800E-04,.2199600E-04,.6490700E-05,& - & .1693600E-07,.1552200E-04,.2166100E-04,.2335700E-04,.6996600E-05,& - & .1632500E-07,.1633400E-04,.2284600E-04,.2453700E-04,.7512400E-05,& - & .1575500E-07,.1708800E-04,.2393100E-04,.2572200E-04,.8030500E-05,& - & .1477200E-07,.1159800E-04,.1611700E-04,.1729400E-04,.5060200E-05,& - & .1424600E-07,.1234600E-04,.1719800E-04,.1852100E-04,.5479900E-05,& - & .1373900E-07,.1304700E-04,.1820500E-04,.1956600E-04,.5899200E-05,& - & .1324700E-07,.1372900E-04,.1917300E-04,.2057400E-04,.6325100E-05,& - & .1278900E-07,.1434100E-04,.2006800E-04,.2153600E-04,.6749600E-05,& - & .1198400E-07,.9767900E-05,.1356800E-04,.1456500E-04,.4272100E-05,& - & .1156000E-07,.1038900E-04,.1446100E-04,.1556000E-04,.4618200E-05,& - & .1114400E-07,.1097300E-04,.1530200E-04,.1641000E-04,.4971500E-05,& - & .1075000E-07,.1153200E-04,.1609100E-04,.1724400E-04,.5321200E-05,& - & .1038100E-07,.1203400E-04,.1682100E-04,.1802300E-04,.5671200E-05,& - & .9720500E-08,.8229600E-05,.1144000E-04,.1228800E-04,.3607900E-05,& - & .9377700E-08,.8743100E-05,.1215800E-04,.1306700E-04,.3897400E-05,& - & .9039100E-08,.9230000E-05,.1286200E-04,.1376900E-04,.4188500E-05,& - & .8721900E-08,.9685400E-05,.1350800E-04,.1445400E-04,.4475600E-05,& - & .8425100E-08,.1010100E-04,.1409000E-04,.1506400E-04,.4764300E-05,& - & .7884200E-08,.6937900E-05,.9637800E-05,.1035000E-04,.3046200E-05,& - & .7605800E-08,.7360500E-05,.1023000E-04,.1096400E-04,.3287900E-05,& - & .7331200E-08,.7768500E-05,.1080600E-04,.1155200E-04,.3525800E-05,& - & .7076100E-08,.8139300E-05,.1132900E-04,.1210900E-04,.3764200E-05,& - & .6837500E-08,.8472300E-05,.1180600E-04,.1258200E-04,.4002700E-05,& - & .6394600E-08,.5848400E-05,.8113200E-05,.8713800E-05,.2572200E-05,& - & .6166800E-08,.6198500E-05,.8615200E-05,.9204300E-05,.2771600E-05,& - & .5946000E-08,.6532900E-05,.9076100E-05,.9691400E-05,.2967200E-05,& - & .5741000E-08,.6834900E-05,.9499100E-05,.1012800E-04,.3164900E-05,& - & .5549000E-08,.7109800E-05,.9897200E-05,.1049400E-04,.3361300E-05/ - - data absb(526:700, 4) / & - & .5193100E-08,.4915500E-05,.6812200E-05,.7300300E-05,.2164800E-05,& - & .5006600E-08,.5210800E-05,.7229900E-05,.7712800E-05,.2328000E-05,& - & .4828900E-08,.5483800E-05,.7607600E-05,.8107700E-05,.2490600E-05,& - & .4663600E-08,.5727100E-05,.7946000E-05,.8449400E-05,.2653400E-05,& - & .4508900E-08,.5954300E-05,.8275100E-05,.8742200E-05,.2815900E-05,& - & .4217700E-08,.4110400E-05,.5691400E-05,.6085200E-05,.1807800E-05,& - & .4079500E-08,.4358000E-05,.6033400E-05,.6427400E-05,.1942100E-05,& - & .3935300E-08,.4581400E-05,.6340700E-05,.6744300E-05,.2076700E-05,& - & .3801200E-08,.4780300E-05,.6619600E-05,.7014400E-05,.2211400E-05,& - & .3675600E-08,.4968200E-05,.6888400E-05,.7253900E-05,.2345800E-05,& - & .3416200E-08,.3414100E-05,.4722400E-05,.5041200E-05,.1496500E-05,& - & .3319600E-08,.3621500E-05,.5003700E-05,.5324100E-05,.1607800E-05,& - & .3219500E-08,.3806400E-05,.5258300E-05,.5581700E-05,.1718800E-05,& - & .3109900E-08,.3971500E-05,.5488100E-05,.5800600E-05,.1830700E-05,& - & .3007200E-08,.4127000E-05,.5706500E-05,.5997400E-05,.1941900E-05,& - & .2800800E-08,.2809400E-05,.3880100E-05,.4139300E-05,.1224800E-05,& - & .2712100E-08,.2983600E-05,.4115500E-05,.4374800E-05,.1316800E-05,& - & .2648200E-08,.3139700E-05,.4328200E-05,.4588500E-05,.1408700E-05,& - & .2557600E-08,.3277900E-05,.4520000E-05,.4770600E-05,.1501300E-05,& - & .2472700E-08,.3408200E-05,.4702300E-05,.4935400E-05,.1593500E-05,& - & .2298400E-08,.2310600E-05,.3185600E-05,.3396100E-05,.1001600E-05,& - & .2222000E-08,.2456300E-05,.3382600E-05,.3591500E-05,.1077600E-05,& - & .2158800E-08,.2588200E-05,.3560000E-05,.3769600E-05,.1153800E-05,& - & .2104000E-08,.2703300E-05,.3719900E-05,.3921300E-05,.1230400E-05,& - & .2033900E-08,.2812200E-05,.3872800E-05,.4059700E-05,.1306700E-05,& - & .1886700E-08,.1899000E-05,.2614700E-05,.2785500E-05,.8189500E-06,& - & .1821900E-08,.2021100E-05,.2778900E-05,.2948200E-05,.8816800E-06,& - & .1767100E-08,.2132400E-05,.2927200E-05,.3096200E-05,.9447500E-06,& - & .1720100E-08,.2228700E-05,.3060700E-05,.3223100E-05,.1008000E-05,& - & .1672900E-08,.2319700E-05,.3188500E-05,.3338900E-05,.1071300E-05,& - & .1556700E-08,.1548600E-05,.2129900E-05,.2269700E-05,.6641800E-06,& - & .1503000E-08,.1652500E-05,.2268600E-05,.2406300E-05,.7159100E-06,& - & .1455900E-08,.1746800E-05,.2393800E-05,.2530400E-05,.7680400E-06,& - & .1414700E-08,.1828400E-05,.2506200E-05,.2637700E-05,.8205300E-06,& - & .1380800E-08,.1905100E-05,.2614200E-05,.2736200E-05,.8728200E-06/ - - data absb(701:875, 4) / & - & .1285500E-08,.1262200E-05,.1732600E-05,.1847200E-05,.5377800E-06,& - & .1241400E-08,.1348600E-05,.1849400E-05,.1961200E-05,.5806200E-06,& - & .1200600E-08,.1429000E-05,.1955100E-05,.2066500E-05,.6236500E-06,& - & .1165500E-08,.1498400E-05,.2050600E-05,.2157000E-05,.6670700E-06,& - & .1136600E-08,.1563000E-05,.2141600E-05,.2240400E-05,.7103500E-06,& - & .1061600E-08,.1027300E-05,.1408500E-05,.1503400E-05,.4351400E-06,& - & .1025000E-08,.1099700E-05,.1507000E-05,.1597300E-05,.4706100E-06,& - & .9903000E-09,.1167900E-05,.1595300E-05,.1686100E-05,.5061300E-06,& - & .9606200E-09,.1227200E-05,.1676600E-05,.1764200E-05,.5421600E-06,& - & .9344300E-09,.1281700E-05,.1752900E-05,.1833300E-05,.5778400E-06,& - & .8788300E-09,.8319900E-06,.1140200E-05,.1216800E-05,.3502500E-06,& - & .8482900E-09,.8925400E-06,.1222500E-05,.1295800E-05,.3796000E-06,& - & .8190300E-09,.9507200E-06,.1296600E-05,.1370800E-05,.4089300E-06,& - & .7936900E-09,.1002000E-05,.1366500E-05,.1437900E-05,.4386200E-06,& - & .7710800E-09,.1047800E-05,.1430200E-05,.1496200E-05,.4681700E-06,& - & .7283800E-09,.6708000E-06,.9196200E-06,.9810200E-06,.2810700E-06,& - & .7027900E-09,.7227100E-06,.9885300E-06,.1049100E-05,.3054000E-06,& - & .6785800E-09,.7720300E-06,.1052200E-05,.1112200E-05,.3295800E-06,& - & .6565100E-09,.8162500E-06,.1111500E-05,.1169700E-05,.3540700E-06,& - & .6372700E-09,.8549500E-06,.1165100E-05,.1219200E-05,.3785000E-06,& - & .6037900E-09,.5404700E-06,.7412800E-06,.7910000E-06,.2253500E-06,& - & .5822800E-09,.5842900E-06,.7985400E-06,.8484100E-06,.2454800E-06,& - & .5622000E-09,.6260600E-06,.8528300E-06,.9015700E-06,.2654100E-06,& - & .5432000E-09,.6642300E-06,.9029600E-06,.9501500E-06,.2855800E-06,& - & .5268600E-09,.6971900E-06,.9483000E-06,.9925400E-06,.3058000E-06,& - & .5010800E-09,.4336100E-06,.5955400E-06,.6343200E-06,.1802300E-06,& - & .4829100E-09,.4712700E-06,.6434900E-06,.6851000E-06,.1967700E-06,& - & .4661200E-09,.5062100E-06,.6894200E-06,.7292900E-06,.2132500E-06,& - & .4500400E-09,.5390300E-06,.7316900E-06,.7709500E-06,.2298600E-06,& - & .4360000E-09,.5674000E-06,.7708100E-06,.8071400E-06,.2465400E-06,& - & .4166500E-09,.3461400E-06,.4756500E-06,.5059800E-06,.1434500E-06,& - & .4011900E-09,.3777900E-06,.5164200E-06,.5501500E-06,.1569700E-06,& - & .3870200E-09,.4075200E-06,.5552500E-06,.5875900E-06,.1706400E-06,& - & .3737200E-09,.4356300E-06,.5907600E-06,.6231800E-06,.1843000E-06,& - & .3613900E-09,.4604100E-06,.6247400E-06,.6551500E-06,.1980000E-06/ - - data absb(876:1050, 4) / & - & .3465800E-09,.2749400E-06,.3792400E-06,.4034900E-06,.1140700E-06,& - & .3334000E-09,.3024300E-06,.4134000E-06,.4406600E-06,.1250800E-06,& - & .3214300E-09,.3275600E-06,.4463500E-06,.4730800E-06,.1363600E-06,& - & .3103200E-09,.3514900E-06,.4766900E-06,.5030900E-06,.1476300E-06,& - & .2996900E-09,.3732300E-06,.5054200E-06,.5306200E-06,.1589200E-06,& - & .2884600E-09,.2177800E-06,.3016800E-06,.3215800E-06,.9060700E-07,& - & .2771600E-09,.2413900E-06,.3307100E-06,.3521400E-06,.9957700E-07,& - & .2670000E-09,.2630400E-06,.3580400E-06,.3804900E-06,.1088100E-06,& - & .2576700E-09,.2831300E-06,.3839400E-06,.4056600E-06,.1181400E-06,& - & .2487500E-09,.3018300E-06,.4083200E-06,.4290600E-06,.1274200E-06,& - & .2399400E-09,.1727600E-06,.2403900E-06,.2564400E-06,.7212400E-07,& - & .2302800E-09,.1927500E-06,.2642900E-06,.2811700E-06,.7938800E-07,& - & .2216200E-09,.2110600E-06,.2875800E-06,.3060600E-06,.8692200E-07,& - & .2137700E-09,.2280700E-06,.3094700E-06,.3271400E-06,.9462800E-07,& - & .2064100E-09,.2440000E-06,.3296200E-06,.3471500E-06,.1022800E-06,& - & .1996000E-09,.1370900E-06,.1910100E-06,.2040700E-06,.5756600E-07,& - & .1913200E-09,.1535200E-06,.2112000E-06,.2245500E-06,.6330800E-07,& - & .1839500E-09,.1692400E-06,.2306800E-06,.2456300E-06,.6942100E-07,& - & .1773200E-09,.1835200E-06,.2492600E-06,.2638300E-06,.7577300E-07,& - & .1711700E-09,.1971500E-06,.2663000E-06,.2806800E-06,.8209700E-07,& - & .1661600E-09,.1085200E-06,.1519100E-06,.1613700E-06,.4597500E-07,& - & .1590100E-09,.1218800E-06,.1685500E-06,.1794300E-06,.5045400E-07,& - & .1527200E-09,.1353500E-06,.1850200E-06,.1970500E-06,.5542400E-07,& - & .1471100E-09,.1476500E-06,.2004200E-06,.2125200E-06,.6061600E-07,& - & .1419400E-09,.1590700E-06,.2148400E-06,.2267300E-06,.6582600E-07,& - & .1383900E-09,.8570400E-07,.1202300E-06,.1274400E-06,.3652300E-07,& - & .1322300E-09,.9660000E-07,.1343800E-06,.1431200E-06,.4015200E-07,& - & .1268400E-09,.1080400E-06,.1478400E-06,.1573500E-06,.4420700E-07,& - & .1220800E-09,.1185100E-06,.1609300E-06,.1710800E-06,.4843500E-07,& - & .1177200E-09,.1281100E-06,.1731300E-06,.1829300E-06,.5273300E-07,& - & .1151600E-09,.6780200E-07,.9540000E-07,.1006500E-06,.2904000E-07,& - & .1098600E-09,.7692700E-07,.1071200E-06,.1142800E-06,.3204400E-07,& - & .1052600E-09,.8629500E-07,.1183300E-06,.1258000E-06,.3533500E-07,& - & .1012200E-09,.9519000E-07,.1293600E-06,.1376300E-06,.3876400E-07,& - & .9754500E-10,.1032400E-06,.1396900E-06,.1476800E-06,.4231200E-07/ - - data absb(1051:1175, 4) / & - & .9583200E-10,.5361000E-07,.7598100E-07,.7966700E-07,.2311700E-07,& - & .9128100E-10,.6113000E-07,.8532900E-07,.9100500E-07,.2565700E-07,& - & .8733500E-10,.6882500E-07,.9473600E-07,.1007500E-06,.2826400E-07,& - & .8389700E-10,.7643500E-07,.1039600E-06,.1107000E-06,.3105700E-07,& - & .8081000E-10,.8327800E-07,.1126900E-06,.1192800E-06,.3397200E-07,& - & .7981000E-10,.4232200E-07,.6037400E-07,.6292600E-07,.1840400E-07,& - & .7586400E-10,.4855900E-07,.6803900E-07,.7224100E-07,.2054800E-07,& - & .7248500E-10,.5477300E-07,.7579900E-07,.8075700E-07,.2258100E-07,& - & .6956000E-10,.6122400E-07,.8355400E-07,.8896700E-07,.2485900E-07,& - & .6695100E-10,.6708400E-07,.9079700E-07,.9624600E-07,.2724500E-07,& - & .6652400E-10,.3332000E-07,.4751600E-07,.4954100E-07,.1462000E-07,& - & .6308100E-10,.3844300E-07,.5402700E-07,.5714200E-07,.1637000E-07,& - & .6018700E-10,.4358700E-07,.6061100E-07,.6460800E-07,.1803600E-07,& - & .5768900E-10,.4897000E-07,.6691500E-07,.7123300E-07,.1989500E-07,& - & .5547800E-10,.5392500E-07,.7304500E-07,.7761800E-07,.2183100E-07,& - & .5544700E-10,.2624000E-07,.3743500E-07,.3898900E-07,.1160600E-07,& - & .5244200E-10,.3046000E-07,.4295500E-07,.4523300E-07,.1304700E-07,& - & .4996200E-10,.3476100E-07,.4841800E-07,.5168000E-07,.1443100E-07,& - & .4782600E-10,.3915200E-07,.5362600E-07,.5704700E-07,.1593400E-07,& - & .4595400E-10,.4338000E-07,.5878600E-07,.6253800E-07,.1751100E-07,& - & .4574000E-10,.2124800E-07,.3026100E-07,.3157700E-07,.9422100E-08,& - & .4321000E-10,.2473000E-07,.3494800E-07,.3672200E-07,.1060800E-07,& - & .4114100E-10,.2828800E-07,.3941000E-07,.4205200E-07,.1175400E-07,& - & .3936100E-10,.3190400E-07,.4374000E-07,.4652700E-07,.1298600E-07,& - & .3780500E-10,.3544200E-07,.4802000E-07,.5108300E-07,.1427800E-07/ - - data absb( 1:175, 5) / & - & .7904500E-05,.5851200E-03,.8096700E-03,.8857800E-03,.3482400E-03,& - & .9280700E-05,.6181800E-03,.8608300E-03,.9243700E-03,.3787000E-03,& - & .1062000E-04,.6502500E-03,.9061700E-03,.9629000E-03,.4063900E-03,& - & .1184700E-04,.6808600E-03,.9476700E-03,.9981500E-03,.4314900E-03,& - & .1289700E-04,.7094100E-03,.9842600E-03,.1029600E-02,.4545900E-03,& - & .6568300E-05,.4879800E-03,.6757000E-03,.7375500E-03,.2917200E-03,& - & .7695700E-05,.5155500E-03,.7185600E-03,.7697800E-03,.3170900E-03,& - & .8785200E-05,.5424300E-03,.7560400E-03,.8014200E-03,.3406400E-03,& - & .9762200E-05,.5681700E-03,.7903800E-03,.8309100E-03,.3609500E-03,& - & .1061400E-04,.5920800E-03,.8201800E-03,.8569100E-03,.3809500E-03,& - & .5464300E-05,.4066000E-03,.5637100E-03,.6128600E-03,.2443500E-03,& - & .6388300E-05,.4297300E-03,.5991400E-03,.6409300E-03,.2647500E-03,& - & .7259300E-05,.4521800E-03,.6300400E-03,.6665900E-03,.2848600E-03,& - & .8052600E-05,.4737300E-03,.6584700E-03,.6912800E-03,.3020000E-03,& - & .8736400E-05,.4939300E-03,.6831800E-03,.7132100E-03,.3193000E-03,& - & .4548200E-05,.3387200E-03,.4700300E-03,.5092000E-03,.2047300E-03,& - & .5289300E-05,.3578500E-03,.4989800E-03,.5330600E-03,.2217100E-03,& - & .5998900E-05,.3767300E-03,.5246700E-03,.5546100E-03,.2380300E-03,& - & .6642600E-05,.3947000E-03,.5482700E-03,.5751500E-03,.2524400E-03,& - & .7175900E-05,.4119300E-03,.5690900E-03,.5936100E-03,.2677300E-03,& - & .3769000E-05,.2817700E-03,.3915300E-03,.4226500E-03,.1715500E-03,& - & .4379000E-05,.2977800E-03,.4153500E-03,.4428800E-03,.1856300E-03,& - & .4954500E-05,.3137100E-03,.4366400E-03,.4609000E-03,.1990800E-03,& - & .5456300E-05,.3288600E-03,.4563700E-03,.4785400E-03,.2109700E-03,& - & .5887900E-05,.3435900E-03,.4741600E-03,.4938700E-03,.2244000E-03,& - & .3126000E-05,.2343200E-03,.3259600E-03,.3508200E-03,.1434800E-03,& - & .3618500E-05,.2478600E-03,.3456100E-03,.3676500E-03,.1554600E-03,& - & .4073200E-05,.2612000E-03,.3634300E-03,.3832500E-03,.1662300E-03,& - & .4483900E-05,.2740300E-03,.3799700E-03,.3981100E-03,.1765900E-03,& - & .4830400E-05,.2867400E-03,.3951300E-03,.4111400E-03,.1881300E-03,& - & .2585300E-05,.1948300E-03,.2712800E-03,.2912600E-03,.1196900E-03,& - & .2983400E-05,.2062300E-03,.2874900E-03,.3054100E-03,.1297800E-03,& - & .3354600E-05,.2175000E-03,.3026700E-03,.3187100E-03,.1387400E-03,& - & .3686300E-05,.2284200E-03,.3165600E-03,.3311500E-03,.1478900E-03,& - & .3963400E-05,.2394200E-03,.3294400E-03,.3422000E-03,.1574200E-03/ - - data absb(176:350, 5) / & - & .2148600E-05,.1622100E-03,.2260900E-03,.2423600E-03,.1001400E-03,& - & .2473500E-05,.1717800E-03,.2394900E-03,.2539900E-03,.1085700E-03,& - & .2774400E-05,.1813600E-03,.2522600E-03,.2653500E-03,.1160400E-03,& - & .3041400E-05,.1907600E-03,.2639700E-03,.2756600E-03,.1239800E-03,& - & .3261000E-05,.2001900E-03,.2748800E-03,.2851000E-03,.1319900E-03,& - & .1787700E-05,.1350700E-03,.1884500E-03,.2016300E-03,.8387900E-04,& - & .2051800E-05,.1431900E-03,.1996800E-03,.2113400E-03,.9085800E-04,& - & .2295300E-05,.1513700E-03,.2103800E-03,.2209400E-03,.9709800E-04,& - & .2509800E-05,.1594700E-03,.2201900E-03,.2294800E-03,.1040200E-03,& - & .2683000E-05,.1674900E-03,.2295000E-03,.2376100E-03,.1106900E-03,& - & .1502200E-05,.1129700E-03,.1577300E-03,.1681900E-03,.7080800E-04,& - & .1715700E-05,.1199800E-03,.1671400E-03,.1764400E-03,.7634500E-04,& - & .1911100E-05,.1269000E-03,.1761100E-03,.1845400E-03,.8180400E-04,& - & .2081200E-05,.1338500E-03,.1842500E-03,.1916400E-03,.8759100E-04,& - & .2214400E-05,.1406600E-03,.1923500E-03,.1986700E-03,.9322800E-04,& - & .1262100E-05,.9468100E-04,.1321000E-03,.1403200E-03,.5963000E-04,& - & .1434600E-05,.1006100E-03,.1400900E-03,.1475100E-03,.6414200E-04,& - & .1590800E-05,.1065500E-03,.1474900E-03,.1541300E-03,.6898800E-04,& - & .1725300E-05,.1124600E-03,.1543700E-03,.1601300E-03,.7389300E-04,& - & .1827200E-05,.1182500E-03,.1613000E-03,.1662700E-03,.7864900E-04,& - & .1061100E-05,.7941900E-04,.1107900E-03,.1173600E-03,.5024400E-04,& - & .1199600E-05,.8448600E-04,.1174900E-03,.1234500E-03,.5405400E-04,& - & .1324100E-05,.8956500E-04,.1236400E-03,.1288300E-03,.5825900E-04,& - & .1430000E-05,.9459200E-04,.1294900E-03,.1340600E-03,.6230000E-04,& - & .1507000E-05,.9954500E-04,.1353800E-03,.1392800E-03,.6648500E-04,& - & .8924800E-06,.6675700E-04,.9304300E-04,.9826900E-04,.4239600E-04,& - & .1003400E-05,.7108200E-04,.9865200E-04,.1033200E-03,.4571900E-04,& - & .1102400E-05,.7540400E-04,.1037500E-03,.1078200E-03,.4922800E-04,& - & .1183500E-05,.7969400E-04,.1088200E-03,.1123400E-03,.5264900E-04,& - & .1240600E-05,.8391500E-04,.1137600E-03,.1167700E-03,.5626400E-04,& - & .7514700E-06,.5624800E-04,.7829100E-04,.8244100E-04,.3578100E-04,& - & .8402500E-06,.5992900E-04,.8291700E-04,.8656200E-04,.3871500E-04,& - & .9172800E-06,.6361800E-04,.8723100E-04,.9044200E-04,.4168200E-04,& - & .9794700E-06,.6728500E-04,.9160600E-04,.9431100E-04,.4461000E-04,& - & .1022200E-05,.7087900E-04,.9575900E-04,.9795400E-04,.4767800E-04/ - - data absb(351:525, 5) / & - & .6322800E-06,.4744800E-04,.6592600E-04,.6921100E-04,.3031200E-04,& - & .7018700E-06,.5058300E-04,.6975200E-04,.7262200E-04,.3284400E-04,& - & .7626300E-06,.5372300E-04,.7343100E-04,.7594300E-04,.3528300E-04,& - & .8097500E-06,.5688400E-04,.7713900E-04,.7923500E-04,.3783700E-04,& - & .8409900E-06,.5993700E-04,.8067000E-04,.8219800E-04,.4039800E-04,& - & .5306200E-06,.4005400E-04,.5553600E-04,.5810500E-04,.2568300E-04,& - & .5858100E-06,.4274800E-04,.5871900E-04,.6098800E-04,.2782900E-04,& - & .6328300E-06,.4544500E-04,.6192700E-04,.6380800E-04,.2991400E-04,& - & .6684100E-06,.4814100E-04,.6503300E-04,.6656700E-04,.3210100E-04,& - & .6913200E-06,.5074400E-04,.6800200E-04,.6902400E-04,.3419600E-04,& - & .4448200E-06,.3387600E-04,.4681300E-04,.4882000E-04,.2182200E-04,& - & .4883000E-06,.3617300E-04,.4953400E-04,.5126700E-04,.2359800E-04,& - & .5252000E-06,.3850700E-04,.5226400E-04,.5370000E-04,.2540700E-04,& - & .5514200E-06,.4079000E-04,.5487900E-04,.5593400E-04,.2723300E-04,& - & .5682100E-06,.4300500E-04,.5737400E-04,.5799500E-04,.2893900E-04,& - & .3724000E-06,.2868800E-04,.3949800E-04,.4108200E-04,.1854200E-04,& - & .4069700E-06,.3066200E-04,.4183200E-04,.4313900E-04,.2003700E-04,& - & .4351800E-06,.3265700E-04,.4413700E-04,.4519800E-04,.2159200E-04,& - & .4545900E-06,.3460000E-04,.4634200E-04,.4703000E-04,.2309900E-04,& - & .4667400E-06,.3646800E-04,.4842700E-04,.4875200E-04,.2452400E-04,& - & .3116700E-06,.2432800E-04,.3336500E-04,.3457700E-04,.1577500E-04,& - & .3388000E-06,.2603300E-04,.3537600E-04,.3634300E-04,.1703700E-04,& - & .3602200E-06,.2772800E-04,.3730600E-04,.3802500E-04,.1833400E-04,& - & .3744300E-06,.2938100E-04,.3915300E-04,.3955100E-04,.1955900E-04,& - & .3830400E-06,.3094000E-04,.4088800E-04,.4101200E-04,.2073500E-04,& - & .2606500E-06,.2066600E-04,.2822600E-04,.2912800E-04,.1340300E-04,& - & .2817900E-06,.2213000E-04,.2993400E-04,.3064200E-04,.1449500E-04,& - & .2979100E-06,.2357200E-04,.3155400E-04,.3200500E-04,.1557600E-04,& - & .3081300E-06,.2496300E-04,.3310100E-04,.3327800E-04,.1658200E-04,& - & .3141200E-06,.2626100E-04,.3451000E-04,.3449700E-04,.1753300E-04,& - & .2176800E-06,.1758100E-04,.2390300E-04,.2455800E-04,.1140500E-04,& - & .2340900E-06,.1882700E-04,.2533300E-04,.2581200E-04,.1233100E-04,& - & .2459600E-06,.2005300E-04,.2669600E-04,.2694200E-04,.1320000E-04,& - & .2533800E-06,.2121100E-04,.2797800E-04,.2801200E-04,.1403700E-04,& - & .2573500E-06,.2229200E-04,.2911300E-04,.2901900E-04,.1478900E-04/ - - data absb(526:700, 5) / & - & .1811100E-06,.1493300E-04,.2022100E-04,.2069100E-04,.9685300E-05,& - & .1937300E-06,.1599300E-04,.2141300E-04,.2170800E-04,.1045900E-04,& - & .2026200E-06,.1702500E-04,.2255100E-04,.2265100E-04,.1117000E-04,& - & .2080200E-06,.1799200E-04,.2360300E-04,.2354000E-04,.1184700E-04,& - & .2106800E-06,.1889200E-04,.2452200E-04,.2437000E-04,.1244400E-04,& - & .1494000E-06,.1260400E-04,.1700100E-04,.1733900E-04,.8163000E-05,& - & .1593400E-06,.1350500E-04,.1800800E-04,.1818300E-04,.8789000E-05,& - & .1662600E-06,.1437400E-04,.1896300E-04,.1897600E-04,.9383800E-05,& - & .1704000E-06,.1518700E-04,.1982400E-04,.1972000E-04,.9922900E-05,& - & .1722900E-06,.1593900E-04,.2058200E-04,.2039400E-04,.1041200E-04,& - & .1222400E-06,.1056000E-04,.1420300E-04,.1444700E-04,.6819600E-05,& - & .1303000E-06,.1132600E-04,.1505500E-04,.1515600E-04,.7332100E-05,& - & .1359000E-06,.1206200E-04,.1585600E-04,.1582300E-04,.7823000E-05,& - & .1392900E-06,.1275000E-04,.1657300E-04,.1644900E-04,.8263200E-05,& - & .1408100E-06,.1338400E-04,.1720800E-04,.1700600E-04,.8665600E-05,& - & .9897900E-07,.8750000E-05,.1175500E-04,.1194300E-04,.5626900E-05,& - & .1058300E-06,.9403500E-05,.1248000E-04,.1254400E-04,.6052800E-05,& - & .1106800E-06,.1003100E-04,.1316100E-04,.1311000E-04,.6460400E-05,& - & .1136500E-06,.1061900E-04,.1376700E-04,.1364200E-04,.6825300E-05,& - & .1151000E-06,.1116200E-04,.1430600E-04,.1410800E-04,.7161500E-05,& - & .8005000E-07,.7243600E-05,.9722500E-05,.9865700E-05,.4637500E-05,& - & .8588600E-07,.7800600E-05,.1033800E-04,.1037800E-04,.4991900E-05,& - & .9010800E-07,.8335500E-05,.1091600E-04,.1085600E-04,.5330300E-05,& - & .9269000E-07,.8838000E-05,.1142900E-04,.1130600E-04,.5634900E-05,& - & .9404600E-07,.9301900E-05,.1188500E-04,.1169600E-04,.5915200E-05,& - & .6472000E-07,.5995500E-05,.8038900E-05,.8148800E-05,.3819200E-05,& - & .6966300E-07,.6469900E-05,.8561300E-05,.8581800E-05,.4115900E-05,& - & .7330500E-07,.6924600E-05,.9050600E-05,.8986100E-05,.4396800E-05,& - & .7558800E-07,.7353000E-05,.9485700E-05,.9363700E-05,.4650500E-05,& - & .7682500E-07,.7749200E-05,.9870800E-05,.9689800E-05,.4884100E-05,& - & .5187100E-07,.4919100E-05,.6599400E-05,.6689000E-05,.3118600E-05,& - & .5612700E-07,.5322700E-05,.7043500E-05,.7057800E-05,.3367800E-05,& - & .5939500E-07,.5712400E-05,.7460900E-05,.7401800E-05,.3602500E-05,& - & .6150100E-07,.6079000E-05,.7833300E-05,.7721000E-05,.3816400E-05,& - & .6271000E-07,.6419400E-05,.8161300E-05,.7998000E-05,.4012200E-05/ - - data absb(701:875, 5) / & - & .4147100E-07,.4027600E-05,.5407600E-05,.5481500E-05,.2540200E-05,& - & .4512700E-07,.4371100E-05,.5784700E-05,.5797100E-05,.2750700E-05,& - & .4801800E-07,.4704000E-05,.6140700E-05,.6088300E-05,.2947900E-05,& - & .4998300E-07,.5017700E-05,.6459500E-05,.6358700E-05,.3128600E-05,& - & .5115300E-07,.5309800E-05,.6738900E-05,.6595000E-05,.3292800E-05,& - & .3310800E-07,.3294500E-05,.4426100E-05,.4487100E-05,.2067400E-05,& - & .3622800E-07,.3586100E-05,.4746200E-05,.4757100E-05,.2245200E-05,& - & .3877600E-07,.3870100E-05,.5050500E-05,.5004600E-05,.2410600E-05,& - & .4058000E-07,.4137800E-05,.5321900E-05,.5232300E-05,.2562200E-05,& - & .4168900E-07,.4388100E-05,.5560700E-05,.5435600E-05,.2701500E-05,& - & .2624300E-07,.2678000E-05,.3602100E-05,.3657800E-05,.1672200E-05,& - & .2890300E-07,.2925400E-05,.3875400E-05,.3888600E-05,.1823500E-05,& - & .3115800E-07,.3167400E-05,.4136300E-05,.4099800E-05,.1962800E-05,& - & .3282800E-07,.3396600E-05,.4368700E-05,.4293500E-05,.2090600E-05,& - & .3389600E-07,.3611200E-05,.4574500E-05,.4468000E-05,.2208800E-05,& - & .2069200E-07,.2168800E-05,.2922600E-05,.2973800E-05,.1348600E-05,& - & .2296100E-07,.2377600E-05,.3155600E-05,.3169900E-05,.1475900E-05,& - & .2493400E-07,.2583400E-05,.3377900E-05,.3350700E-05,.1592600E-05,& - & .2647200E-07,.2780000E-05,.3577900E-05,.3516200E-05,.1701700E-05,& - & .2750400E-07,.2963700E-05,.3755800E-05,.3666600E-05,.1801700E-05,& - & .1626900E-07,.1753700E-05,.2367200E-05,.2413300E-05,.1085600E-05,& - & .1819400E-07,.1929100E-05,.2566300E-05,.2580900E-05,.1192700E-05,& - & .1990300E-07,.2103900E-05,.2755200E-05,.2736000E-05,.1290900E-05,& - & .2129300E-07,.2272100E-05,.2927000E-05,.2877500E-05,.1383900E-05,& - & .2228300E-07,.2429200E-05,.3080200E-05,.3006700E-05,.1468600E-05,& - & .1271200E-07,.1412800E-05,.1911300E-05,.1954800E-05,.8711400E-06,& - & .1435100E-07,.1559600E-05,.2080200E-05,.2094900E-05,.9611800E-06,& - & .1581500E-07,.1707600E-05,.2240400E-05,.2228900E-05,.1043600E-05,& - & .1706200E-07,.1851100E-05,.2388900E-05,.2349200E-05,.1122500E-05,& - & .1799300E-07,.1985500E-05,.2520600E-05,.2460900E-05,.1194800E-05,& - & .9836400E-08,.1130600E-05,.1535300E-05,.1574600E-05,.6955400E-06,& - & .1122600E-07,.1253400E-05,.1676500E-05,.1694400E-05,.7692500E-06,& - & .1248300E-07,.1378400E-05,.1813000E-05,.1808700E-05,.8403600E-06,& - & .1358700E-07,.1500700E-05,.1941800E-05,.1912200E-05,.9071200E-06,& - & .1445700E-07,.1615800E-05,.2055700E-05,.2007300E-05,.9684700E-06/ - - data absb(876:1050, 5) / & - & .7582400E-08,.9032900E-06,.1230700E-05,.1265300E-05,.5534600E-06,& - & .8745300E-08,.1005000E-05,.1349000E-05,.1367600E-05,.6147000E-06,& - & .9819400E-08,.1110100E-05,.1465000E-05,.1465100E-05,.6749200E-06,& - & .1077900E-07,.1214100E-05,.1575600E-05,.1554400E-05,.7316300E-06,& - & .1157900E-07,.1312500E-05,.1674300E-05,.1635900E-05,.7840500E-06,& - & .5821900E-08,.7201500E-06,.9837900E-06,.1014300E-05,.4393300E-06,& - & .6781700E-08,.8042300E-06,.1083200E-05,.1102300E-05,.4901800E-06,& - & .7696600E-08,.8920500E-06,.1181900E-05,.1184600E-05,.5413100E-06,& - & .8522400E-08,.9800500E-06,.1276000E-05,.1261700E-05,.5885800E-06,& - & .9235000E-08,.1064400E-05,.1361500E-05,.1331900E-05,.6335800E-06,& - & .4479000E-08,.5741800E-06,.7863500E-06,.8129600E-06,.3488100E-06,& - & .5257900E-08,.6438800E-06,.8705600E-06,.8889600E-06,.3913500E-06,& - & .6027900E-08,.7172200E-06,.9534800E-06,.9580900E-06,.4344400E-06,& - & .6732400E-08,.7913400E-06,.1033100E-05,.1024300E-05,.4739100E-06,& - & .7355100E-08,.8633000E-06,.1107300E-05,.1084200E-05,.5123400E-06,& - & .3445000E-08,.4575300E-06,.6281400E-06,.6515800E-06,.2762500E-06,& - & .4069000E-08,.5153000E-06,.6989200E-06,.7155500E-06,.3126000E-06,& - & .4708700E-08,.5762400E-06,.7684000E-06,.7747700E-06,.3480400E-06,& - & .5308600E-08,.6384300E-06,.8358000E-06,.8309200E-06,.3818100E-06,& - & .5843900E-08,.6995600E-06,.8996200E-06,.8822500E-06,.4141200E-06,& - & .2645400E-08,.3638700E-06,.5000700E-06,.5217900E-06,.2189400E-06,& - & .3140300E-08,.4117300E-06,.5599700E-06,.5747900E-06,.2487000E-06,& - & .3665500E-08,.4621100E-06,.6181900E-06,.6251100E-06,.2784000E-06,& - & .4173000E-08,.5141500E-06,.6754600E-06,.6730700E-06,.3069500E-06,& - & .4631100E-08,.5658200E-06,.7297300E-06,.7169700E-06,.3340700E-06,& - & .2027500E-08,.2887300E-06,.3974900E-06,.4164700E-06,.1735500E-06,& - & .2419000E-08,.3282100E-06,.4473000E-06,.4606300E-06,.1977400E-06,& - & .2844000E-08,.3698100E-06,.4967700E-06,.5041100E-06,.2221800E-06,& - & .3269000E-08,.4131500E-06,.5448800E-06,.5440800E-06,.2464700E-06,& - & .3659200E-08,.4568000E-06,.5909000E-06,.5818900E-06,.2690200E-06,& - & .1561100E-08,.2296200E-06,.3161300E-06,.3330000E-06,.1373000E-06,& - & .1869600E-08,.2618700E-06,.3580200E-06,.3695400E-06,.1570100E-06,& - & .2210000E-08,.2964100E-06,.3997000E-06,.4068300E-06,.1776400E-06,& - & .2561900E-08,.3325500E-06,.4400900E-06,.4406300E-06,.1980800E-06,& - & .2892800E-08,.3690800E-06,.4789200E-06,.4727000E-06,.2169600E-06/ - - data absb(1051:1175, 5) / & - & .1204100E-08,.1825900E-06,.2510800E-06,.2660800E-06,.1084200E-06,& - & .1446600E-08,.2091800E-06,.2863300E-06,.2967700E-06,.1246800E-06,& - & .1717600E-08,.2376500E-06,.3213900E-06,.3279900E-06,.1421300E-06,& - & .2005800E-08,.2676600E-06,.3552300E-06,.3566400E-06,.1590700E-06,& - & .2285200E-08,.2981800E-06,.3880600E-06,.3838100E-06,.1751200E-06,& - & .9293400E-09,.1449600E-06,.1988700E-06,.2121500E-06,.8518500E-07,& - & .1118000E-08,.1666800E-06,.2284100E-06,.2379900E-06,.9917200E-07,& - & .1333300E-08,.1902400E-06,.2579000E-06,.2638500E-06,.1133100E-06,& - & .1566800E-08,.2151200E-06,.2862600E-06,.2882000E-06,.1275800E-06,& - & .1800000E-08,.2405500E-06,.3140500E-06,.3113400E-06,.1410600E-06,& - & .7174700E-09,.1149100E-06,.1576000E-06,.1690700E-06,.6676200E-07,& - & .8631800E-09,.1326600E-06,.1819800E-06,.1905100E-06,.7884400E-07,& - & .1033200E-08,.1519900E-06,.2064600E-06,.2118500E-06,.9031700E-07,& - & .1220500E-08,.1725500E-06,.2304900E-06,.2328000E-06,.1021100E-06,& - & .1413700E-08,.1937400E-06,.2537700E-06,.2520900E-06,.1134700E-06,& - & .5553400E-09,.9116100E-07,.1249500E-06,.1348100E-06,.5252400E-07,& - & .6679600E-09,.1056400E-06,.1449000E-06,.1524600E-06,.6249100E-07,& - & .8020800E-09,.1214200E-06,.1654000E-06,.1701300E-06,.7192300E-07,& - & .9515500E-09,.1384600E-06,.1856200E-06,.1880300E-06,.8176000E-07,& - & .1110000E-08,.1560800E-06,.2051300E-06,.2042500E-06,.9140500E-07,& - & .4448300E-09,.7420100E-07,.1017500E-06,.1098600E-06,.4262600E-07,& - & .5347800E-09,.8625700E-07,.1181800E-06,.1245300E-06,.5081600E-07,& - & .6426500E-09,.9939000E-07,.1353500E-06,.1392800E-06,.5865800E-07,& - & .7636900E-09,.1136000E-06,.1522400E-06,.1541700E-06,.6684500E-07,& - & .8931600E-09,.1282600E-06,.1685000E-06,.1677500E-06,.7484100E-07/ - - data absb( 1:175, 6) / & - & .1545200E-03,.1747100E-02,.2287000E-02,.2275700E-02,.1186800E-02,& - & .1735800E-03,.1833700E-02,.2375200E-02,.2354900E-02,.1249200E-02,& - & .1904300E-03,.1907000E-02,.2447900E-02,.2425500E-02,.1311400E-02,& - & .2045900E-03,.1970200E-02,.2510900E-02,.2490500E-02,.1371700E-02,& - & .2162100E-03,.2026600E-02,.2565300E-02,.2551200E-02,.1432000E-02,& - & .1279300E-03,.1466200E-02,.1914100E-02,.1903200E-02,.9940400E-03,& - & .1433500E-03,.1536700E-02,.1985200E-02,.1969100E-02,.1046200E-02,& - & .1569800E-03,.1597400E-02,.2045400E-02,.2028500E-02,.1098600E-02,& - & .1683700E-03,.1650500E-02,.2098200E-02,.2082800E-02,.1150900E-02,& - & .1776500E-03,.1699000E-02,.2145200E-02,.2135700E-02,.1202000E-02,& - & .1060000E-03,.1228000E-02,.1598700E-02,.1589900E-02,.8316000E-03,& - & .1184600E-03,.1285800E-02,.1657000E-02,.1643800E-02,.8764100E-03,& - & .1294700E-03,.1336200E-02,.1707300E-02,.1693700E-02,.9203700E-03,& - & .1386000E-03,.1381800E-02,.1751900E-02,.1740100E-02,.9651400E-03,& - & .1460500E-03,.1423100E-02,.1792200E-02,.1784900E-02,.1008800E-02,& - & .8784400E-04,.1026800E-02,.1333700E-02,.1325800E-02,.6947100E-03,& - & .9792100E-04,.1074700E-02,.1381600E-02,.1370400E-02,.7330900E-03,& - & .1067800E-03,.1117300E-02,.1424000E-02,.1412200E-02,.7712600E-03,& - & .1141000E-03,.1156100E-02,.1461900E-02,.1452500E-02,.8098300E-03,& - & .1200800E-03,.1191300E-02,.1495700E-02,.1490400E-02,.8468500E-03,& - & .7273600E-04,.8577000E-03,.1111000E-02,.1104300E-02,.5798800E-03,& - & .8087000E-04,.8973700E-03,.1150800E-02,.1141200E-02,.6131000E-03,& - & .8798400E-04,.9333400E-03,.1186500E-02,.1176900E-02,.6456300E-03,& - & .9390000E-04,.9663700E-03,.1218800E-02,.1211500E-02,.6794600E-03,& - & .9866900E-04,.9968200E-03,.1247700E-02,.1244400E-02,.7112900E-03,& - & .6019600E-04,.7158500E-03,.9248400E-03,.9188500E-03,.4842800E-03,& - & .6675900E-04,.7490200E-03,.9580600E-03,.9500700E-03,.5125400E-03,& - & .7248600E-04,.7793600E-03,.9882800E-03,.9803600E-03,.5411800E-03,& - & .7721000E-04,.8075700E-03,.1015700E-02,.1010100E-02,.5699500E-03,& - & .8104600E-04,.8334400E-03,.1040500E-02,.1039000E-02,.5976200E-03,& - & .4979700E-04,.5971400E-03,.7695100E-03,.7640800E-03,.4048700E-03,& - & .5509800E-04,.6250500E-03,.7972800E-03,.7907100E-03,.4290400E-03,& - & .5969000E-04,.6507100E-03,.8229400E-03,.8167100E-03,.4537500E-03,& - & .6345700E-04,.6749000E-03,.8463500E-03,.8424500E-03,.4783300E-03,& - & .6653800E-04,.6968300E-03,.8680500E-03,.8681200E-03,.5023800E-03/ - - data absb(176:350, 6) / & - & .4127700E-04,.4985400E-03,.6404300E-03,.6358200E-03,.3388500E-03,& - & .4555700E-04,.5219700E-03,.6640800E-03,.6585900E-03,.3596000E-03,& - & .4922600E-04,.5438000E-03,.6858200E-03,.6811100E-03,.3810800E-03,& - & .5223800E-04,.5644200E-03,.7059800E-03,.7036400E-03,.4019900E-03,& - & .5469400E-04,.5832000E-03,.7250400E-03,.7264500E-03,.4228200E-03,& - & .3421800E-04,.4162400E-03,.5331200E-03,.5291200E-03,.2837600E-03,& - & .3767000E-04,.4359700E-03,.5531600E-03,.5489300E-03,.3016100E-03,& - & .4060200E-04,.4546700E-03,.5717800E-03,.5686100E-03,.3202300E-03,& - & .4300900E-04,.4722000E-03,.5893100E-03,.5885000E-03,.3380500E-03,& - & .4496800E-04,.4885000E-03,.6062400E-03,.6086700E-03,.3563300E-03,& - & .2855400E-04,.3487200E-03,.4451900E-03,.4420300E-03,.2386500E-03,& - & .3131200E-04,.3654300E-03,.4621500E-03,.4589600E-03,.2542900E-03,& - & .3362300E-04,.3813600E-03,.4780800E-03,.4762500E-03,.2702000E-03,& - & .3551800E-04,.3963800E-03,.4935200E-03,.4939300E-03,.2856700E-03,& - & .3706000E-04,.4104600E-03,.5083300E-03,.5115200E-03,.3016900E-03,& - & .2382500E-04,.2924100E-03,.3720200E-03,.3695700E-03,.2012000E-03,& - & .2601900E-04,.3066400E-03,.3865000E-03,.3843300E-03,.2148400E-03,& - & .2784000E-04,.3202700E-03,.4003800E-03,.3995700E-03,.2282900E-03,& - & .2932900E-04,.3331700E-03,.4139600E-03,.4149800E-03,.2416900E-03,& - & .3054200E-04,.3454700E-03,.4268100E-03,.4304800E-03,.2556800E-03,& - & .1987900E-04,.2455200E-03,.3113500E-03,.3093600E-03,.1698600E-03,& - & .2161700E-04,.2576700E-03,.3237600E-03,.3222800E-03,.1817300E-03,& - & .2305000E-04,.2693700E-03,.3359000E-03,.3357900E-03,.1932000E-03,& - & .2421700E-04,.2805400E-03,.3477200E-03,.3492200E-03,.2050100E-03,& - & .2516400E-04,.2912100E-03,.3588300E-03,.3628600E-03,.2170800E-03,& - & .1658900E-04,.2064500E-03,.2608700E-03,.2594400E-03,.1436900E-03,& - & .1796100E-04,.2168800E-03,.2716200E-03,.2708300E-03,.1538600E-03,& - & .1908300E-04,.2269700E-03,.2822900E-03,.2825800E-03,.1638300E-03,& - & .1999800E-04,.2366800E-03,.2924500E-03,.2943800E-03,.1741800E-03,& - & .2073700E-04,.2458900E-03,.3021600E-03,.3064700E-03,.1846500E-03,& - & .1385800E-04,.1740200E-03,.2190600E-03,.2180400E-03,.1220500E-03,& - & .1493000E-04,.1830000E-03,.2284300E-03,.2281300E-03,.1306500E-03,& - & .1580700E-04,.1917400E-03,.2377000E-03,.2383000E-03,.1393300E-03,& - & .1652200E-04,.2001000E-03,.2464000E-03,.2487600E-03,.1483700E-03,& - & .1709000E-04,.2079800E-03,.2550000E-03,.2594300E-03,.1574800E-03/ - - data absb(351:525, 6) / & - & .1156500E-04,.1468900E-03,.1842300E-03,.1835800E-03,.1037200E-03,& - & .1240400E-04,.1546600E-03,.1924200E-03,.1924200E-03,.1110400E-03,& - & .1308800E-04,.1622500E-03,.2003500E-03,.2013600E-03,.1187700E-03,& - & .1364400E-04,.1693800E-03,.2079300E-03,.2105400E-03,.1265800E-03,& - & .1407900E-04,.1761400E-03,.2155300E-03,.2200400E-03,.1345500E-03,& - & .9642900E-05,.1242200E-03,.1551800E-03,.1548600E-03,.8824000E-04,& - & .1029700E-04,.1309300E-03,.1622900E-03,.1625500E-03,.9466400E-04,& - & .1082900E-04,.1374400E-03,.1691100E-03,.1704300E-03,.1013700E-03,& - & .1126300E-04,.1435500E-03,.1757700E-03,.1786100E-03,.1081800E-03,& - & .1159300E-04,.1493600E-03,.1824500E-03,.1869800E-03,.1151700E-03,& - & .8035700E-05,.1052500E-03,.1309800E-03,.1308700E-03,.7519900E-04,& - & .8545700E-05,.1110600E-03,.1370900E-03,.1375600E-03,.8087700E-04,& - & .8958500E-05,.1165900E-03,.1429800E-03,.1445800E-03,.8670300E-04,& - & .9293600E-05,.1218500E-03,.1488700E-03,.1518400E-03,.9267900E-04,& - & .9541300E-05,.1268500E-03,.1547600E-03,.1592600E-03,.9877000E-04,& - & .6689100E-05,.8932600E-04,.1107000E-03,.1107500E-03,.6425400E-04,& - & .7085500E-05,.9428000E-04,.1159500E-03,.1166800E-03,.6921500E-04,& - & .7406800E-05,.9902900E-04,.1211200E-03,.1229000E-03,.7427800E-04,& - & .7663400E-05,.1035600E-03,.1263100E-03,.1293300E-03,.7948900E-04,& - & .7849900E-05,.1078500E-03,.1315200E-03,.1358800E-03,.8476200E-04,& - & .5564700E-05,.7594300E-04,.9369500E-04,.9390600E-04,.5500200E-04,& - & .5871900E-05,.8016700E-04,.9822900E-04,.9920400E-04,.5932900E-04,& - & .6121200E-05,.8424900E-04,.1028100E-03,.1047100E-03,.6377800E-04,& - & .6316200E-05,.8812200E-04,.1073800E-03,.1104100E-03,.6831800E-04,& - & .6455300E-05,.9183500E-04,.1120400E-03,.1161400E-03,.7290700E-04,& - & .4624600E-05,.6463300E-04,.7939800E-04,.7983100E-04,.4719000E-04,& - & .4862800E-05,.6825800E-04,.8338300E-04,.8452100E-04,.5095300E-04,& - & .5055700E-05,.7175800E-04,.8741800E-04,.8941700E-04,.5482300E-04,& - & .5203500E-05,.7509900E-04,.9148100E-04,.9442300E-04,.5878500E-04,& - & .5306800E-05,.7831700E-04,.9564600E-04,.9945200E-04,.6276600E-04,& - & .3840300E-05,.5507700E-04,.6741000E-04,.6802400E-04,.4053800E-04,& - & .4024400E-05,.5819900E-04,.7092400E-04,.7218000E-04,.4383900E-04,& - & .4173000E-05,.6120600E-04,.7447500E-04,.7650200E-04,.4722200E-04,& - & .4283500E-05,.6409100E-04,.7811400E-04,.8088300E-04,.5065200E-04,& - & .4360400E-05,.6689800E-04,.8179800E-04,.8529300E-04,.5410200E-04/ - - data absb(526:700, 6) / & - & .3180100E-05,.4688800E-04,.5723300E-04,.5794500E-04,.3478100E-04,& - & .3324400E-05,.4958600E-04,.6031900E-04,.6162500E-04,.3764600E-04,& - & .3438900E-05,.5218300E-04,.6346500E-04,.6542200E-04,.4060600E-04,& - & .3522800E-05,.5469600E-04,.6669700E-04,.6926600E-04,.4357100E-04,& - & .3580400E-05,.5716200E-04,.6996400E-04,.7312000E-04,.4656200E-04,& - & .2620000E-05,.3974200E-04,.4841000E-04,.4914100E-04,.2963900E-04,& - & .2735100E-05,.4207500E-04,.5112200E-04,.5238200E-04,.3214600E-04,& - & .2825300E-05,.4432500E-04,.5391600E-04,.5569800E-04,.3470100E-04,& - & .2890700E-05,.4653000E-04,.5676900E-04,.5906800E-04,.3728000E-04,& - & .2935400E-05,.4870700E-04,.5964900E-04,.6246100E-04,.3986400E-04,& - & .2146900E-05,.3349800E-04,.4074400E-04,.4142700E-04,.2504500E-04,& - & .2240700E-05,.3551300E-04,.4312400E-04,.4426200E-04,.2722700E-04,& - & .2314000E-05,.3748100E-04,.4558800E-04,.4715700E-04,.2943300E-04,& - & .2367300E-05,.3941900E-04,.4810900E-04,.5010700E-04,.3167200E-04,& - & .2403500E-05,.4134500E-04,.5064000E-04,.5308900E-04,.3391100E-04,& - & .1746400E-05,.2798400E-04,.3400700E-04,.3458400E-04,.2089900E-04,& - & .1825200E-05,.2973700E-04,.3608800E-04,.3705100E-04,.2278500E-04,& - & .1887700E-05,.3146000E-04,.3824700E-04,.3957300E-04,.2468700E-04,& - & .1933300E-05,.3316500E-04,.4046000E-04,.4214600E-04,.2662600E-04,& - & .1964700E-05,.3486900E-04,.4269100E-04,.4476500E-04,.2856100E-04,& - & .1419800E-05,.2336400E-04,.2836700E-04,.2885400E-04,.1742200E-04,& - & .1486200E-05,.2489200E-04,.3018600E-04,.3099400E-04,.1904700E-04,& - & .1539400E-05,.2639900E-04,.3207600E-04,.3319200E-04,.2068800E-04,& - & .1578600E-05,.2789800E-04,.3402000E-04,.3544100E-04,.2236000E-04,& - & .1605800E-05,.2940100E-04,.3598300E-04,.3773500E-04,.2403300E-04,& - & .1154100E-05,.1950900E-04,.2366300E-04,.2407200E-04,.1452100E-04,& - & .1210000E-05,.2083700E-04,.2525200E-04,.2592900E-04,.1591500E-04,& - & .1255100E-05,.2215500E-04,.2690200E-04,.2784200E-04,.1733100E-04,& - & .1288800E-05,.2347000E-04,.2860300E-04,.2980600E-04,.1877300E-04,& - & .1312300E-05,.2479400E-04,.3033100E-04,.3181500E-04,.2021600E-04,& - & .9324400E-06,.1617100E-04,.1959900E-04,.1991800E-04,.1197700E-04,& - & .9805900E-06,.1732400E-04,.2097600E-04,.2151900E-04,.1316900E-04,& - & .1019600E-05,.1847500E-04,.2241100E-04,.2317800E-04,.1438700E-04,& - & .1049600E-05,.1962600E-04,.2389700E-04,.2488700E-04,.1562500E-04,& - & .1070600E-05,.2079200E-04,.2541100E-04,.2664100E-04,.1687100E-04/ - - data absb(701:875, 6) / & - & .7520600E-06,.1338100E-04,.1620400E-04,.1644800E-04,.9858200E-05,& - & .7936800E-06,.1438000E-04,.1739500E-04,.1782400E-04,.1087300E-04,& - & .8274200E-06,.1538200E-04,.1864000E-04,.1925900E-04,.1191600E-04,& - & .8539000E-06,.1638800E-04,.1993500E-04,.2074500E-04,.1297900E-04,& - & .8728100E-06,.1741200E-04,.2126100E-04,.2227100E-04,.1405300E-04,& - & .6059100E-06,.1106100E-04,.1338500E-04,.1356800E-04,.8104500E-05,& - & .6418200E-06,.1192600E-04,.1441200E-04,.1475100E-04,.8966100E-05,& - & .6710100E-06,.1279700E-04,.1548900E-04,.1598700E-04,.9857800E-05,& - & .6942700E-06,.1367500E-04,.1661600E-04,.1727400E-04,.1077000E-04,& - & .7112200E-06,.1457300E-04,.1777400E-04,.1860100E-04,.1169000E-04,& - & .4856500E-06,.9092900E-05,.1099800E-04,.1112700E-04,.6613600E-05,& - & .5170300E-06,.9840100E-05,.1187800E-04,.1213600E-04,.7343100E-05,& - & .5424600E-06,.1059400E-04,.1280700E-04,.1319700E-04,.8101900E-05,& - & .5630900E-06,.1135900E-04,.1378200E-04,.1430600E-04,.8881200E-05,& - & .5785400E-06,.1214400E-04,.1479100E-04,.1545600E-04,.9668500E-05,& - & .3877700E-06,.7447800E-05,.9006200E-05,.9092100E-05,.5370900E-05,& - & .4152200E-06,.8091900E-05,.9757000E-05,.9947800E-05,.5988900E-05,& - & .4376100E-06,.8743300E-05,.1055500E-04,.1085600E-04,.6633200E-05,& - & .4558400E-06,.9406300E-05,.1139500E-04,.1180800E-04,.7295500E-05,& - & .4699000E-06,.1009100E-04,.1226900E-04,.1279900E-04,.7969600E-05,& - & .3088800E-06,.6089800E-05,.7363200E-05,.7418100E-05,.4353500E-05,& - & .3329100E-06,.6644000E-05,.8002300E-05,.8141600E-05,.4874100E-05,& - & .3525500E-06,.7205200E-05,.8685500E-05,.8915400E-05,.5420700E-05,& - & .3685400E-06,.7778700E-05,.9406800E-05,.9730800E-05,.5983300E-05,& - & .3812500E-06,.8374500E-05,.1016300E-04,.1058300E-04,.6557800E-05,& - & .2449400E-06,.4959800E-05,.5998700E-05,.6028900E-05,.3512300E-05,& - & .2659500E-06,.5435500E-05,.6541100E-05,.6638300E-05,.3949400E-05,& - & .2832800E-06,.5917300E-05,.7123300E-05,.7294300E-05,.4411300E-05,& - & .2973500E-06,.6412300E-05,.7740600E-05,.7990400E-05,.4888300E-05,& - & .3087600E-06,.6928300E-05,.8391300E-05,.8721100E-05,.5376600E-05,& - & .1928700E-06,.4013400E-05,.4858600E-05,.4871800E-05,.2811400E-05,& - & .2112300E-06,.4420800E-05,.5317800E-05,.5379400E-05,.3178100E-05,& - & .2265800E-06,.4833200E-05,.5810400E-05,.5933500E-05,.3564600E-05,& - & .2391200E-06,.5258200E-05,.6335400E-05,.6523000E-05,.3967600E-05,& - & .2493100E-06,.5702500E-05,.6892000E-05,.7145800E-05,.4382600E-05/ - - data absb(876:1050, 6) / & - & .1513200E-06,.3239500E-05,.3926900E-05,.3928900E-05,.2245800E-05,& - & .1671600E-06,.3586600E-05,.4314400E-05,.4351100E-05,.2551200E-05,& - & .1807600E-06,.3939100E-05,.4729400E-05,.4816100E-05,.2874600E-05,& - & .1919400E-06,.4303000E-05,.5174800E-05,.5314200E-05,.3213500E-05,& - & .2009900E-06,.4684200E-05,.5648800E-05,.5843000E-05,.3564400E-05,& - & .1182800E-06,.2607800E-05,.3167200E-05,.3161700E-05,.1789400E-05,& - & .1318500E-06,.2902900E-05,.3492900E-05,.3512500E-05,.2042300E-05,& - & .1437800E-06,.3203000E-05,.3840900E-05,.3900000E-05,.2312100E-05,& - & .1536900E-06,.3513900E-05,.4217900E-05,.4319800E-05,.2597100E-05,& - & .1617600E-06,.3839100E-05,.4619800E-05,.4766700E-05,.2892900E-05,& - & .9236200E-07,.2099700E-05,.2555600E-05,.2547100E-05,.1426700E-05,& - & .1039000E-06,.2349600E-05,.2828600E-05,.2836800E-05,.1635600E-05,& - & .1142100E-06,.2604900E-05,.3121300E-05,.3160600E-05,.1860900E-05,& - & .1229700E-06,.2869400E-05,.3439200E-05,.3512500E-05,.2099600E-05,& - & .1301200E-06,.3147100E-05,.3779400E-05,.3890000E-05,.2348600E-05,& - & .7202900E-07,.1687900E-05,.2060600E-05,.2050600E-05,.1136500E-05,& - & .8171700E-07,.1899400E-05,.2288600E-05,.2290200E-05,.1308100E-05,& - & .9054700E-07,.2116200E-05,.2534700E-05,.2558800E-05,.1496400E-05,& - & .9823100E-07,.2340700E-05,.2801700E-05,.2853700E-05,.1695800E-05,& - & .1045400E-06,.2577000E-05,.3089100E-05,.3171900E-05,.1905300E-05,& - & .5599400E-07,.1353500E-05,.1658300E-05,.1648300E-05,.9021500E-06,& - & .6406500E-07,.1531800E-05,.1848300E-05,.1845200E-05,.1044700E-05,& - & .7160100E-07,.1715600E-05,.2054100E-05,.2067900E-05,.1200500E-05,& - & .7826500E-07,.1905500E-05,.2278600E-05,.2315100E-05,.1367300E-05,& - & .8382700E-07,.2106200E-05,.2520100E-05,.2581200E-05,.1542600E-05,& - & .4337600E-07,.1082300E-05,.1331600E-05,.1322900E-05,.7138700E-06,& - & .5007800E-07,.1232000E-05,.1489800E-05,.1484300E-05,.8319600E-06,& - & .5644000E-07,.1387300E-05,.1661200E-05,.1667800E-05,.9608500E-06,& - & .6218800E-07,.1548100E-05,.1848900E-05,.1873600E-05,.1099500E-05,& - & .6707200E-07,.1717900E-05,.2052000E-05,.2096400E-05,.1246500E-05,& - & .3366200E-07,.8668500E-06,.1071200E-05,.1063800E-05,.5667500E-06,& - & .3918800E-07,.9923700E-06,.1202400E-05,.1196500E-05,.6640700E-06,& - & .4451700E-07,.1123400E-05,.1345300E-05,.1347700E-05,.7701500E-06,& - & .4941000E-07,.1259100E-05,.1502200E-05,.1518600E-05,.8856800E-06,& - & .5366200E-07,.1402800E-05,.1673200E-05,.1705400E-05,.1008800E-05/ - - data absb(1051:1175, 6) / & - & .2610700E-07,.6940900E-06,.8614800E-06,.8553500E-06,.4499300E-06,& - & .3064800E-07,.7987400E-06,.9705000E-06,.9643200E-06,.5298700E-06,& - & .3507000E-07,.9091900E-06,.1089300E-05,.1088900E-05,.6172700E-06,& - & .3922300E-07,.1023700E-05,.1220600E-05,.1230800E-05,.7134500E-06,& - & .4289700E-07,.1145000E-05,.1364100E-05,.1387800E-05,.8161400E-06,& - & .2018300E-07,.5546100E-06,.6918700E-06,.6868600E-06,.3563400E-06,& - & .2390600E-07,.6414300E-06,.7819300E-06,.7761500E-06,.4213300E-06,& - & .2757300E-07,.7342200E-06,.8805900E-06,.8784800E-06,.4938700E-06,& - & .3106600E-07,.8308300E-06,.9900100E-06,.9960400E-06,.5736200E-06,& - & .3421300E-07,.9330200E-06,.1110300E-05,.1127100E-05,.6590600E-06,& - & .1555300E-07,.4422100E-06,.5547500E-06,.5505100E-06,.2815800E-06,& - & .1859700E-07,.5138700E-06,.6288300E-06,.6238100E-06,.3343200E-06,& - & .2162700E-07,.5916500E-06,.7107900E-06,.7076800E-06,.3942300E-06,& - & .2454800E-07,.6728600E-06,.8015900E-06,.8045100E-06,.4600900E-06,& - & .2722300E-07,.7587000E-06,.9019600E-06,.9137200E-06,.5312600E-06,& - & .1198900E-07,.3527100E-06,.4450400E-06,.4416400E-06,.2224700E-06,& - & .1447300E-07,.4116700E-06,.5059300E-06,.5017900E-06,.2655700E-06,& - & .1695900E-07,.4768100E-06,.5738900E-06,.5705500E-06,.3148800E-06,& - & .1938600E-07,.5450300E-06,.6493300E-06,.6504300E-06,.3692700E-06,& - & .2165500E-07,.6170500E-06,.7328500E-06,.7409200E-06,.4282300E-06,& - & .9574500E-08,.2890900E-06,.3650400E-06,.3622100E-06,.1814300E-06,& - & .1160200E-07,.3386900E-06,.4162500E-06,.4126700E-06,.2175400E-06,& - & .1363900E-07,.3936300E-06,.4734500E-06,.4705300E-06,.2587300E-06,& - & .1563500E-07,.4513200E-06,.5372200E-06,.5377900E-06,.3043600E-06,& - & .1751500E-07,.5125500E-06,.6080400E-06,.6144500E-06,.3539500E-06/ - - data absb( 1:175, 7) / & - & .1381800E-02,.5309500E-02,.6174400E-02,.6140900E-02,.3820100E-02,& - & .1492700E-02,.5426200E-02,.6316900E-02,.6326800E-02,.3978700E-02,& - & .1588200E-02,.5524500E-02,.6457500E-02,.6504200E-02,.4128500E-02,& - & .1668300E-02,.5602800E-02,.6585900E-02,.6676400E-02,.4276600E-02,& - & .1736400E-02,.5664200E-02,.6699600E-02,.6840000E-02,.4419600E-02,& - & .1143900E-02,.4464200E-02,.5205200E-02,.5195400E-02,.3218500E-02,& - & .1232200E-02,.4561200E-02,.5329500E-02,.5355400E-02,.3354400E-02,& - & .1308200E-02,.4642500E-02,.5447400E-02,.5511100E-02,.3486900E-02,& - & .1372300E-02,.4707800E-02,.5556800E-02,.5660500E-02,.3617800E-02,& - & .1427300E-02,.4761400E-02,.5653600E-02,.5800400E-02,.3744500E-02,& - & .9460000E-03,.3745200E-02,.4378600E-02,.4383900E-02,.2706400E-02,& - & .1016600E-02,.3827200E-02,.4484500E-02,.4523800E-02,.2825900E-02,& - & .1077200E-02,.3895100E-02,.4585200E-02,.4656900E-02,.2942400E-02,& - & .1128700E-02,.3950800E-02,.4677600E-02,.4785600E-02,.3057300E-02,& - & .1172700E-02,.3998400E-02,.4763900E-02,.4909400E-02,.3170700E-02,& - & .7817000E-03,.3138600E-02,.3675300E-02,.3692500E-02,.2274900E-02,& - & .8382800E-03,.3206700E-02,.3765500E-02,.3810800E-02,.2379100E-02,& - & .8867700E-03,.3263600E-02,.3852400E-02,.3926700E-02,.2480900E-02,& - & .9281400E-03,.3312700E-02,.3933200E-02,.4038900E-02,.2581900E-02,& - & .9634200E-03,.3356100E-02,.4012300E-02,.4149300E-02,.2682500E-02,& - & .6451300E-03,.2625800E-02,.3079200E-02,.3102700E-02,.1910900E-02,& - & .6906500E-03,.2683000E-02,.3157300E-02,.3205600E-02,.2001300E-02,& - & .7295100E-03,.2732100E-02,.3232600E-02,.3306100E-02,.2090500E-02,& - & .7627900E-03,.2775900E-02,.3305700E-02,.3404900E-02,.2179100E-02,& - & .7912700E-03,.2816400E-02,.3377600E-02,.3503700E-02,.2268000E-02,& - & .5321600E-03,.2194500E-02,.2576800E-02,.2604100E-02,.1604700E-02,& - & .5687800E-03,.2243100E-02,.2645300E-02,.2693400E-02,.1682900E-02,& - & .6000200E-03,.2286400E-02,.2712100E-02,.2781200E-02,.1760500E-02,& - & .6266600E-03,.2326500E-02,.2777800E-02,.2868900E-02,.1838900E-02,& - & .6495600E-03,.2364500E-02,.2843600E-02,.2958700E-02,.1917500E-02,& - & .4387800E-03,.1832800E-02,.2155500E-02,.2184400E-02,.1347000E-02,& - & .4683200E-03,.1874900E-02,.2216000E-02,.2261900E-02,.1414700E-02,& - & .4933700E-03,.1913600E-02,.2275200E-02,.2339500E-02,.1483400E-02,& - & .5148300E-03,.1950900E-02,.2334400E-02,.2417700E-02,.1552600E-02,& - & .5332100E-03,.1986300E-02,.2395000E-02,.2498300E-02,.1622800E-02/ - - data absb(176:350, 7) / & - & .3621800E-03,.1531000E-02,.1804400E-02,.1833300E-02,.1132000E-02,& - & .3858700E-03,.1568100E-02,.1857300E-02,.1901000E-02,.1191100E-02,& - & .4059900E-03,.1603400E-02,.1910500E-02,.1969300E-02,.1251600E-02,& - & .4232700E-03,.1637200E-02,.1964200E-02,.2040000E-02,.1313300E-02,& - & .4380000E-03,.1670200E-02,.2019600E-02,.2112000E-02,.1376000E-02,& - & .2989400E-03,.1279400E-02,.1510900E-02,.1539200E-02,.9519600E-03,& - & .3179500E-03,.1312600E-02,.1557800E-02,.1598500E-02,.1004100E-02,& - & .3340900E-03,.1344400E-02,.1605400E-02,.1659000E-02,.1057500E-02,& - & .3479800E-03,.1375200E-02,.1654200E-02,.1722800E-02,.1112400E-02,& - & .3598200E-03,.1406200E-02,.1704600E-02,.1787200E-02,.1168800E-02,& - & .2477900E-03,.1072000E-02,.1268700E-02,.1295900E-02,.8042800E-03,& - & .2628700E-03,.1101200E-02,.1310400E-02,.1348300E-02,.8504600E-03,& - & .2757000E-03,.1130000E-02,.1353200E-02,.1403200E-02,.8979600E-03,& - & .2867600E-03,.1158300E-02,.1397800E-02,.1460200E-02,.9472200E-03,& - & .2961200E-03,.1187300E-02,.1443900E-02,.1518500E-02,.9981200E-03,& - & .2053600E-03,.8990100E-03,.1066600E-02,.1092500E-02,.6807700E-03,& - & .2173200E-03,.9251400E-03,.1103700E-02,.1139400E-02,.7218900E-03,& - & .2275200E-03,.9510900E-03,.1142600E-02,.1188800E-02,.7643700E-03,& - & .2363200E-03,.9772800E-03,.1183200E-02,.1240300E-02,.8087700E-03,& - & .2436900E-03,.1004000E-02,.1226000E-02,.1293400E-02,.8548900E-03,& - & .1702100E-03,.7550600E-03,.8980000E-03,.9226500E-03,.5778800E-03,& - & .1796900E-03,.7785300E-03,.9314900E-03,.9649700E-03,.6144300E-03,& - & .1877800E-03,.8020700E-03,.9668000E-03,.1009700E-02,.6527800E-03,& - & .1947700E-03,.8262200E-03,.1004100E-02,.1056400E-02,.6929300E-03,& - & .2005500E-03,.8510400E-03,.1043900E-02,.1105300E-02,.7342400E-03,& - & .1411000E-03,.6353100E-03,.7574600E-03,.7810900E-03,.4919500E-03,& - & .1486000E-03,.6562900E-03,.7880100E-03,.8195100E-03,.5247200E-03,& - & .1550200E-03,.6780200E-03,.8201800E-03,.8600500E-03,.5592900E-03,& - & .1605400E-03,.7002300E-03,.8548700E-03,.9027000E-03,.5954600E-03,& - & .1650600E-03,.7233300E-03,.8921300E-03,.9479400E-03,.6329600E-03,& - & .1170400E-03,.5356300E-03,.6408900E-03,.6634800E-03,.4203600E-03,& - & .1229600E-03,.5548200E-03,.6685900E-03,.6984200E-03,.4498600E-03,& - & .1280400E-03,.5746000E-03,.6983800E-03,.7353200E-03,.4811500E-03,& - & .1323700E-03,.5952800E-03,.7308100E-03,.7747200E-03,.5137100E-03,& - & .1358700E-03,.6170800E-03,.7656200E-03,.8164900E-03,.5480000E-03/ - - data absb(351:525, 7) / & - & .9703700E-04,.4526300E-03,.5435300E-03,.5652800E-03,.3603100E-03,& - & .1017100E-03,.4701800E-03,.5689900E-03,.5971000E-03,.3869800E-03,& - & .1057200E-03,.4883300E-03,.5967500E-03,.6309600E-03,.4150500E-03,& - & .1091100E-03,.5076700E-03,.6271300E-03,.6673600E-03,.4446600E-03,& - & .1118200E-03,.5283000E-03,.6594900E-03,.7060000E-03,.4762500E-03,& - & .8041900E-04,.3834900E-03,.4622400E-03,.4830800E-03,.3098200E-03,& - & .8411000E-04,.3994300E-03,.4858400E-03,.5121400E-03,.3338600E-03,& - & .8728300E-04,.4163600E-03,.5118900E-03,.5435300E-03,.3592400E-03,& - & .8991400E-04,.4345600E-03,.5402000E-03,.5769800E-03,.3863500E-03,& - & .9200300E-04,.4540600E-03,.5703000E-03,.6128600E-03,.4155300E-03,& - & .6663700E-04,.3258000E-03,.3945300E-03,.4143900E-03,.2673800E-03,& - & .6955200E-04,.3405200E-03,.4166000E-03,.4411600E-03,.2890400E-03,& - & .7204200E-04,.3563300E-03,.4410200E-03,.4700500E-03,.3121800E-03,& - & .7408200E-04,.3735100E-03,.4673100E-03,.5010800E-03,.3371400E-03,& - & .7569200E-04,.3919000E-03,.4952900E-03,.5344700E-03,.3642100E-03,& - & .5519400E-04,.2775700E-03,.3380400E-03,.3567000E-03,.2314800E-03,& - & .5748900E-04,.2913000E-03,.3587600E-03,.3814300E-03,.2511500E-03,& - & .5944500E-04,.3061900E-03,.3814800E-03,.4081000E-03,.2724200E-03,& - & .6102400E-04,.3223300E-03,.4057800E-03,.4369800E-03,.2955200E-03,& - & .6225100E-04,.3396900E-03,.4318500E-03,.4683000E-03,.3205200E-03,& - & .4570100E-04,.2373600E-03,.2908600E-03,.3083400E-03,.2011400E-03,& - & .4751600E-04,.2502000E-03,.3103200E-03,.3311300E-03,.2191600E-03,& - & .4903400E-04,.2642400E-03,.3313100E-03,.3559300E-03,.2387400E-03,& - & .5024700E-04,.2794300E-03,.3539500E-03,.3829900E-03,.2602400E-03,& - & .5118600E-04,.2957800E-03,.3782900E-03,.4125000E-03,.2834100E-03,& - & .3782900E-04,.2037900E-03,.2514500E-03,.2676100E-03,.1754900E-03,& - & .3925600E-04,.2158500E-03,.2695100E-03,.2887100E-03,.1920700E-03,& - & .4043400E-04,.2290400E-03,.2890300E-03,.3119200E-03,.2103400E-03,& - & .4136700E-04,.2433200E-03,.3102000E-03,.3374400E-03,.2302400E-03,& - & .4207200E-04,.2587300E-03,.3330900E-03,.3652700E-03,.2517900E-03,& - & .3130200E-04,.1757200E-03,.2183000E-03,.2332100E-03,.1537500E-03,& - & .3241900E-04,.1870600E-03,.2350400E-03,.2529100E-03,.1691500E-03,& - & .3332700E-04,.1994000E-03,.2532800E-03,.2747900E-03,.1861700E-03,& - & .3403900E-04,.2128300E-03,.2731500E-03,.2988700E-03,.2046500E-03,& - & .3456800E-04,.2273100E-03,.2947400E-03,.3251900E-03,.2248500E-03/ - - data absb(526:700, 7) / & - & .2585100E-04,.1518200E-03,.1897600E-03,.2035300E-03,.1348300E-03,& - & .2673100E-04,.1624100E-03,.2053100E-03,.2219900E-03,.1491800E-03,& - & .2743700E-04,.1739500E-03,.2223700E-03,.2425800E-03,.1649100E-03,& - & .2798800E-04,.1865600E-03,.2411300E-03,.2652900E-03,.1821700E-03,& - & .2838400E-04,.2001700E-03,.2614400E-03,.2902000E-03,.2011600E-03,& - & .2127100E-04,.1307800E-03,.1642600E-03,.1768500E-03,.1175600E-03,& - & .2197500E-04,.1405800E-03,.1786500E-03,.1940300E-03,.1307200E-03,& - & .2253300E-04,.1513200E-03,.1945600E-03,.2132300E-03,.1452300E-03,& - & .2296600E-04,.1630700E-03,.2120600E-03,.2345400E-03,.1613300E-03,& - & .2327400E-04,.1757900E-03,.2311200E-03,.2580000E-03,.1791100E-03,& - & .1743100E-04,.1120500E-03,.1412800E-03,.1526000E-03,.1016100E-03,& - & .1800400E-04,.1210300E-03,.1544800E-03,.1684000E-03,.1135600E-03,& - & .1845800E-04,.1309500E-03,.1691800E-03,.1861600E-03,.1268700E-03,& - & .1881000E-04,.1418200E-03,.1853900E-03,.2059600E-03,.1417900E-03,& - & .1905900E-04,.1536300E-03,.2031700E-03,.2278800E-03,.1583100E-03,& - & .1420400E-04,.9501000E-04,.1200800E-03,.1299600E-03,.8648200E-04,& - & .1468500E-04,.1031300E-03,.1320000E-03,.1442600E-03,.9717900E-04,& - & .1506900E-04,.1121400E-03,.1453600E-03,.1604200E-03,.1092200E-03,& - & .1536900E-04,.1221100E-03,.1602000E-03,.1785500E-03,.1228200E-03,& - & .1558600E-04,.1329600E-03,.1766100E-03,.1987600E-03,.1379700E-03,& - & .1157100E-04,.8054500E-04,.1020600E-03,.1106300E-03,.7356300E-04,& - & .1197600E-04,.8787500E-04,.1128100E-03,.1235700E-03,.8314900E-04,& - & .1230100E-04,.9606300E-04,.1249500E-03,.1382900E-03,.9402600E-04,& - & .1255700E-04,.1051800E-03,.1385100E-03,.1548700E-03,.1064200E-03,& - & .1274400E-04,.1151500E-03,.1536400E-03,.1735200E-03,.1202900E-03,& - & .9425400E-05,.6833300E-04,.8679800E-04,.9424700E-04,.6260400E-04,& - & .9765700E-05,.7494500E-04,.9649500E-04,.1059500E-03,.7118500E-04,& - & .1004100E-04,.8237600E-04,.1075200E-03,.1193400E-03,.8102200E-04,& - & .1025800E-04,.9068700E-04,.1199200E-03,.1345300E-03,.9231500E-04,& - & .1041900E-04,.9985200E-04,.1338700E-03,.1517700E-03,.1050400E-03,& - & .7645200E-05,.5742800E-04,.7302100E-04,.7933300E-04,.5256800E-04,& - & .7935400E-05,.6331500E-04,.8165000E-04,.8975200E-04,.6014400E-04,& - & .8173900E-05,.6996100E-04,.9154200E-04,.1017600E-03,.6890500E-04,& - & .8362600E-05,.7745600E-04,.1027500E-03,.1155200E-03,.7905900E-04,& - & .8506400E-05,.8579500E-04,.1154200E-03,.1312800E-03,.9057800E-04/ - - data absb(701:875, 7) / & - & .6195300E-05,.4816300E-04,.6128700E-04,.6661600E-04,.4401100E-04,& - & .6441800E-05,.5338300E-04,.6893400E-04,.7584200E-04,.5067000E-04,& - & .6648400E-05,.5931200E-04,.7778500E-04,.8658000E-04,.5844800E-04,& - & .6813400E-05,.6605400E-04,.8787600E-04,.9899500E-04,.6754300E-04,& - & .6940200E-05,.7361400E-04,.9937800E-04,.1133700E-03,.7794200E-04,& - & .5017000E-05,.4035800E-04,.5137800E-04,.5587500E-04,.3679400E-04,& - & .5226600E-05,.4497100E-04,.5814100E-04,.6402400E-04,.4263900E-04,& - & .5404600E-05,.5025000E-04,.6603400E-04,.7360100E-04,.4952700E-04,& - & .5548400E-05,.5630200E-04,.7511100E-04,.8478800E-04,.5765400E-04,& - & .5660000E-05,.6315300E-04,.8555100E-04,.9789800E-04,.6704000E-04,& - & .4049800E-05,.3356300E-04,.4271600E-04,.4643300E-04,.3044700E-04,& - & .4229100E-05,.3760300E-04,.4861900E-04,.5355100E-04,.3551600E-04,& - & .4383300E-05,.4226000E-04,.5558500E-04,.6199900E-04,.4154900E-04,& - & .4509900E-05,.4765000E-04,.6366800E-04,.7196400E-04,.4872800E-04,& - & .4609600E-05,.5379000E-04,.7305300E-04,.8377900E-04,.5710500E-04,& - & .3261600E-05,.2778100E-04,.3533500E-04,.3836600E-04,.2503200E-04,& - & .3416400E-05,.3129600E-04,.4044400E-04,.4453100E-04,.2939900E-04,& - & .3549100E-05,.3537500E-04,.4654000E-04,.5192500E-04,.3463300E-04,& - & .3661000E-05,.4014600E-04,.5368700E-04,.6073800E-04,.4093500E-04,& - & .3750000E-05,.4561800E-04,.6206100E-04,.7129800E-04,.4835600E-04,& - & .2623800E-05,.2295200E-04,.2916200E-04,.3163000E-04,.2052200E-04,& - & .2757100E-05,.2599200E-04,.3356700E-04,.3693800E-04,.2426800E-04,& - & .2871300E-05,.2954900E-04,.3888100E-04,.4338300E-04,.2879200E-04,& - & .2969300E-05,.3376000E-04,.4517700E-04,.5114900E-04,.3430300E-04,& - & .3048200E-05,.3862700E-04,.5262400E-04,.6055100E-04,.4085700E-04,& - & .2105100E-05,.1886700E-04,.2393500E-04,.2591700E-04,.1671000E-04,& - & .2220600E-05,.2148000E-04,.2770500E-04,.3044900E-04,.1989300E-04,& - & .2319100E-05,.2455700E-04,.3229800E-04,.3601900E-04,.2376900E-04,& - & .2404600E-05,.2823900E-04,.3779800E-04,.4280700E-04,.2854500E-04,& - & .2474600E-05,.3254300E-04,.4437400E-04,.5110900E-04,.3429900E-04,& - & .1681700E-05,.1538600E-04,.1946400E-04,.2102400E-04,.1345500E-04,& - & .1782200E-05,.1760500E-04,.2265200E-04,.2484000E-04,.1612400E-04,& - & .1868000E-05,.2023600E-04,.2656700E-04,.2958500E-04,.1940100E-04,& - & .1942300E-05,.2341300E-04,.3131700E-04,.3543300E-04,.2347600E-04,& - & .2004900E-05,.2718100E-04,.3705400E-04,.4266800E-04,.2846600E-04/ - - data absb(876:1050, 7) / & - & .1340500E-05,.1251400E-04,.1577900E-04,.1699300E-04,.1079100E-04,& - & .1428000E-05,.1438500E-04,.1846000E-04,.2018700E-04,.1301700E-04,& - & .1502600E-05,.1662300E-04,.2177300E-04,.2420500E-04,.1576800E-04,& - & .1567100E-05,.1935400E-04,.2585400E-04,.2921800E-04,.1922700E-04,& - & .1622400E-05,.2262900E-04,.3083300E-04,.3547900E-04,.2352500E-04,& - & .1066400E-05,.1014900E-04,.1275100E-04,.1368400E-04,.8618800E-05,& - & .1141800E-05,.1172000E-04,.1499900E-04,.1635200E-04,.1046700E-04,& - & .1206900E-05,.1361200E-04,.1778000E-04,.1971600E-04,.1275900E-04,& - & .1263000E-05,.1594500E-04,.2126200E-04,.2399000E-04,.1567600E-04,& - & .1311300E-05,.1877500E-04,.2556000E-04,.2938200E-04,.1935200E-04,& - & .8480800E-06,.8240100E-05,.1031800E-04,.1103600E-04,.6893900E-05,& - & .9126900E-06,.9551300E-05,.1218900E-04,.1324700E-04,.8420900E-05,& - & .9692800E-06,.1116000E-04,.1453900E-04,.1608400E-04,.1033600E-04,& - & .1017700E-05,.1314600E-04,.1749800E-04,.1971100E-04,.1279000E-04,& - & .1059500E-05,.1559200E-04,.2120700E-04,.2435600E-04,.1592900E-04,& - & .6737800E-06,.6682600E-05,.8338100E-05,.8882800E-05,.5505200E-05,& - & .7287300E-06,.7775300E-05,.9890500E-05,.1071400E-04,.6763600E-05,& - & .7776300E-06,.9136800E-05,.1186600E-04,.1309100E-04,.8355900E-05,& - & .8195300E-06,.1082400E-04,.1437800E-04,.1616800E-04,.1041700E-04,& - & .8556100E-06,.1293300E-04,.1757100E-04,.2015900E-04,.1308700E-04,& - & .5344400E-06,.5406600E-05,.6719700E-05,.7129700E-05,.4381400E-05,& - & .5809500E-06,.6312400E-05,.7998900E-05,.8634600E-05,.5412200E-05,& - & .6228200E-06,.7456100E-05,.9648900E-05,.1061400E-04,.6728900E-05,& - & .6591300E-06,.8891700E-05,.1178000E-04,.1322000E-04,.8449700E-05,& - & .6903200E-06,.1069100E-04,.1450400E-04,.1661500E-04,.1070600E-04,& - & .4230900E-06,.4363500E-05,.5401700E-05,.5704700E-05,.3473300E-05,& - & .4622300E-06,.5109700E-05,.6446500E-05,.6932200E-05,.4312000E-05,& - & .4979100E-06,.6064300E-05,.7816600E-05,.8569000E-05,.5394800E-05,& - & .5294200E-06,.7272600E-05,.9604200E-05,.1074800E-04,.6821100E-05,& - & .5563500E-06,.8807400E-05,.1192400E-04,.1363200E-04,.8717600E-05,& - & .3352500E-06,.3529100E-05,.4353300E-05,.4578300E-05,.2761800E-05,& - & .3680100E-06,.4146400E-05,.5209800E-05,.5582100E-05,.3446800E-05,& - & .3983000E-06,.4944200E-05,.6349500E-05,.6939300E-05,.4339000E-05,& - & .4253000E-06,.5963800E-05,.7852000E-05,.8765200E-05,.5523800E-05,& - & .4485000E-06,.7271100E-05,.9825600E-05,.1121300E-04,.7118000E-05/ - - data absb(1051:1175, 7) / & - & .2656100E-06,.2853500E-05,.3509100E-05,.3674700E-05,.2195300E-05,& - & .2929900E-06,.3363000E-05,.4209300E-05,.4493500E-05,.2754300E-05,& - & .3185500E-06,.4028600E-05,.5155500E-05,.5616000E-05,.3488500E-05,& - & .3414900E-06,.4888400E-05,.6416600E-05,.7143200E-05,.4471200E-05,& - & .3614900E-06,.6008200E-05,.8105300E-05,.9233800E-05,.5811400E-05,& - & .2101700E-06,.2301900E-05,.2821700E-05,.2942000E-05,.1740300E-05,& - & .2329400E-06,.2721500E-05,.3392200E-05,.3607000E-05,.2194300E-05,& - & .2543600E-06,.3273200E-05,.4172000E-05,.4529100E-05,.2795000E-05,& - & .2738300E-06,.3995100E-05,.5225200E-05,.5799000E-05,.3605400E-05,& - & .2910600E-06,.4942900E-05,.6651800E-05,.7561300E-05,.4724600E-05,& - & .1660800E-06,.1853100E-05,.2263900E-05,.2350400E-05,.1376000E-05,& - & .1848800E-06,.2197100E-05,.2727100E-05,.2887000E-05,.1742100E-05,& - & .2027900E-06,.2652000E-05,.3365900E-05,.3639200E-05,.2231600E-05,& - & .2193100E-06,.3254300E-05,.4239100E-05,.4689100E-05,.2894900E-05,& - & .2340400E-06,.4052700E-05,.5438000E-05,.6164900E-05,.3823400E-05,& - & .1313100E-06,.1492700E-05,.1817900E-05,.1878700E-05,.1089300E-05,& - & .1467700E-06,.1774800E-05,.2194600E-05,.2312200E-05,.1383900E-05,& - & .1617100E-06,.2149400E-05,.2717100E-05,.2925600E-05,.1782700E-05,& - & .1756700E-06,.2651400E-05,.3440700E-05,.3792300E-05,.2326900E-05,& - & .1881600E-06,.3323700E-05,.4446600E-05,.5028000E-05,.3095800E-05,& - & .1059900E-06,.1237400E-05,.1506000E-05,.1554300E-05,.8975000E-06,& - & .1186800E-06,.1479500E-05,.1828500E-05,.1925100E-05,.1147900E-05,& - & .1309800E-06,.1804200E-05,.2280700E-05,.2455200E-05,.1489700E-05,& - & .1425200E-06,.2243900E-05,.2915200E-05,.3216300E-05,.1962200E-05,& - & .1529100E-06,.2839600E-05,.3808700E-05,.4313800E-05,.2638700E-05/ - - data absb( 1:175, 8) / & - & .8367300E-02,.1745400E-01,.2021300E-01,.2013200E-01,.1381000E-01,& - & .8503900E-02,.1782400E-01,.2068400E-01,.2061600E-01,.1421900E-01,& - & .8612900E-02,.1819600E-01,.2116300E-01,.2114300E-01,.1461600E-01,& - & .8691300E-02,.1856300E-01,.2163500E-01,.2167400E-01,.1499100E-01,& - & .8730100E-02,.1891600E-01,.2210300E-01,.2219800E-01,.1535100E-01,& - & .6934600E-02,.1495200E-01,.1738000E-01,.1734200E-01,.1180300E-01,& - & .7032800E-02,.1527600E-01,.1780800E-01,.1783000E-01,.1218100E-01,& - & .7111300E-02,.1560400E-01,.1824000E-01,.1832100E-01,.1254400E-01,& - & .7158000E-02,.1593700E-01,.1866700E-01,.1881400E-01,.1288400E-01,& - & .7178500E-02,.1622800E-01,.1909300E-01,.1929900E-01,.1323000E-01,& - & .5730700E-02,.1276300E-01,.1489000E-01,.1491200E-01,.1007300E-01,& - & .5801700E-02,.1305200E-01,.1527800E-01,.1537000E-01,.1041700E-01,& - & .5853300E-02,.1334700E-01,.1566600E-01,.1582800E-01,.1074200E-01,& - & .5882600E-02,.1362800E-01,.1605700E-01,.1628900E-01,.1106600E-01,& - & .5893300E-02,.1387300E-01,.1644400E-01,.1673900E-01,.1138800E-01,& - & .4724700E-02,.1086300E-01,.1272300E-01,.1278800E-01,.8582200E-02,& - & .4775500E-02,.1112400E-01,.1307600E-01,.1321100E-01,.8890700E-02,& - & .4809500E-02,.1138500E-01,.1343100E-01,.1364100E-01,.9190300E-02,& - & .4828300E-02,.1162200E-01,.1379000E-01,.1406600E-01,.9491200E-02,& - & .4833300E-02,.1184100E-01,.1413500E-01,.1448700E-01,.9793800E-02,& - & .3888100E-02,.9231300E-02,.1084800E-01,.1094200E-01,.7300600E-02,& - & .3923800E-02,.9460100E-02,.1117100E-01,.1133300E-01,.7579200E-02,& - & .3946800E-02,.9687400E-02,.1150000E-01,.1173200E-01,.7856000E-02,& - & .3959000E-02,.9896200E-02,.1182600E-01,.1212900E-01,.8137600E-02,& - & .3961200E-02,.1009400E-01,.1214400E-01,.1252100E-01,.8429300E-02,& - & .3195300E-02,.7830900E-02,.9236100E-02,.9352300E-02,.6204800E-02,& - & .3220800E-02,.8037200E-02,.9535000E-02,.9714800E-02,.6459000E-02,& - & .3236500E-02,.8234200E-02,.9838200E-02,.1008200E-01,.6715400E-02,& - & .3244700E-02,.8422900E-02,.1013800E-01,.1045000E-01,.6983800E-02,& - & .3245000E-02,.8606100E-02,.1042700E-01,.1081400E-01,.7262600E-02,& - & .2623500E-02,.6639900E-02,.7859900E-02,.7987500E-02,.5272800E-02,& - & .2641400E-02,.6823100E-02,.8135100E-02,.8323000E-02,.5507000E-02,& - & .2653000E-02,.7000400E-02,.8413800E-02,.8662900E-02,.5746800E-02,& - & .2658300E-02,.7175600E-02,.8688700E-02,.9002900E-02,.6000600E-02,& - & .2657300E-02,.7345700E-02,.8954900E-02,.9342200E-02,.6265800E-02/ - - data absb(176:350, 8) / & - & .2152800E-02,.5630000E-02,.6692800E-02,.6827500E-02,.4488700E-02,& - & .2165900E-02,.5796500E-02,.6948300E-02,.7137400E-02,.4704400E-02,& - & .2174200E-02,.5961700E-02,.7203600E-02,.7450300E-02,.4931400E-02,& - & .2177700E-02,.6125100E-02,.7456200E-02,.7765700E-02,.5170000E-02,& - & .2175700E-02,.6285000E-02,.7706500E-02,.8089100E-02,.5422500E-02,& - & .1765900E-02,.4777800E-02,.5705400E-02,.5841700E-02,.3827100E-02,& - & .1775400E-02,.4929900E-02,.5939300E-02,.6125700E-02,.4026400E-02,& - & .1781700E-02,.5083600E-02,.6175000E-02,.6414800E-02,.4239700E-02,& - & .1783600E-02,.5237000E-02,.6408300E-02,.6712500E-02,.4464700E-02,& - & .1781100E-02,.5387600E-02,.6648000E-02,.7020100E-02,.4707600E-02,& - & .1448600E-02,.4067900E-02,.4882600E-02,.5020500E-02,.3280500E-02,& - & .1455400E-02,.4208500E-02,.5098000E-02,.5282700E-02,.3466900E-02,& - & .1459700E-02,.4351500E-02,.5315300E-02,.5553500E-02,.3667400E-02,& - & .1460600E-02,.4495700E-02,.5535300E-02,.5837600E-02,.3881600E-02,& - & .1457700E-02,.4638300E-02,.5767200E-02,.6130200E-02,.4115600E-02,& - & .1188000E-02,.3469800E-02,.4186100E-02,.4324800E-02,.2819900E-02,& - & .1192900E-02,.3601000E-02,.4386200E-02,.4568900E-02,.2995600E-02,& - & .1195800E-02,.3734400E-02,.4587700E-02,.4827300E-02,.3184300E-02,& - & .1195900E-02,.3869700E-02,.4800700E-02,.5096500E-02,.3390300E-02,& - & .1192900E-02,.4006800E-02,.5023200E-02,.5379100E-02,.3613600E-02,& - & .9740600E-03,.2967500E-02,.3600600E-02,.3737900E-02,.2434400E-02,& - & .9775600E-03,.3089600E-02,.3785000E-02,.3968600E-02,.2599400E-02,& - & .9794600E-03,.3215000E-02,.3977500E-02,.4213500E-02,.2777600E-02,& - & .9789900E-03,.3343000E-02,.4182500E-02,.4470800E-02,.2975300E-02,& - & .9761500E-03,.3476100E-02,.4396600E-02,.4745700E-02,.3190000E-02,& - & .7985600E-03,.2545900E-02,.3107700E-02,.3244700E-02,.2111400E-02,& - & .8011000E-03,.2660500E-02,.3280500E-02,.3464000E-02,.2266400E-02,& - & .8022200E-03,.2777800E-02,.3466600E-02,.3695800E-02,.2437600E-02,& - & .8012900E-03,.2901400E-02,.3662300E-02,.3944400E-02,.2626900E-02,& - & .7985700E-03,.3030200E-02,.3869800E-02,.4212600E-02,.2833500E-02,& - & .6546000E-03,.2193300E-02,.2694400E-02,.2833400E-02,.1841700E-02,& - & .6563900E-03,.2300300E-02,.2859900E-02,.3040900E-02,.1988600E-02,& - & .6568500E-03,.2413200E-02,.3038400E-02,.3263900E-02,.2154500E-02,& - & .6557700E-03,.2532300E-02,.3227500E-02,.3505500E-02,.2336600E-02,& - & .6532500E-03,.2657200E-02,.3429400E-02,.3768700E-02,.2536500E-02/ - - data absb(351:525, 8) / & - & .5365500E-03,.1896600E-02,.2347400E-02,.2487300E-02,.1614200E-02,& - & .5377700E-03,.1997900E-02,.2506900E-02,.2684900E-02,.1757000E-02,& - & .5378300E-03,.2107000E-02,.2677800E-02,.2901000E-02,.1916300E-02,& - & .5366100E-03,.2221800E-02,.2860900E-02,.3137300E-02,.2092500E-02,& - & .5342600E-03,.2343700E-02,.3059100E-02,.3395300E-02,.2287100E-02,& - & .4397300E-03,.1646700E-02,.2056400E-02,.2195000E-02,.1424300E-02,& - & .4404600E-03,.1744500E-02,.2209400E-02,.2385400E-02,.1562200E-02,& - & .4402700E-03,.1849500E-02,.2373700E-02,.2595400E-02,.1716000E-02,& - & .4390200E-03,.1960700E-02,.2552700E-02,.2828000E-02,.1887500E-02,& - & .4369000E-03,.2079700E-02,.2748300E-02,.3080900E-02,.2078300E-02,& - & .3603500E-03,.1437700E-02,.1812900E-02,.1950200E-02,.1266500E-02,& - & .3607800E-03,.1532200E-02,.1959300E-02,.2134600E-02,.1399300E-02,& - & .3603500E-03,.1633300E-02,.2119400E-02,.2340700E-02,.1548900E-02,& - & .3591700E-03,.1741600E-02,.2295800E-02,.2569300E-02,.1716900E-02,& - & .3572200E-03,.1858300E-02,.2489300E-02,.2819900E-02,.1905800E-02,& - & .2952200E-03,.1262500E-02,.1607300E-02,.1744400E-02,.1133700E-02,& - & .2954400E-03,.1353400E-02,.1749300E-02,.1924800E-02,.1262900E-02,& - & .2948900E-03,.1451300E-02,.1906400E-02,.2128100E-02,.1409300E-02,& - & .2937700E-03,.1557500E-02,.2081300E-02,.2353600E-02,.1575100E-02,& - & .2920100E-03,.1672500E-02,.2272800E-02,.2603100E-02,.1763300E-02,& - & .2418600E-03,.1115500E-02,.1435300E-02,.1572900E-02,.1023200E-02,& - & .2418900E-03,.1203200E-02,.1573900E-02,.1750800E-02,.1149800E-02,& - & .2413000E-03,.1298800E-02,.1729600E-02,.1951600E-02,.1294200E-02,& - & .2402500E-03,.1403400E-02,.1903000E-02,.2176400E-02,.1459400E-02,& - & .2386600E-03,.1517000E-02,.2094000E-02,.2427000E-02,.1647100E-02,& - & .1981100E-03,.9918800E-03,.1291400E-02,.1431100E-02,.9315700E-03,& - & .1979900E-03,.1077100E-02,.1428200E-02,.1607300E-02,.1056200E-02,& - & .1974100E-03,.1171100E-02,.1582800E-02,.1806800E-02,.1199900E-02,& - & .1964500E-03,.1274600E-02,.1755900E-02,.2032000E-02,.1365400E-02,& - & .1950300E-03,.1387100E-02,.1947300E-02,.2285100E-02,.1553300E-02,& - & .1622500E-03,.8880300E-03,.1171700E-02,.1313800E-02,.8555600E-03,& - & .1620500E-03,.9717400E-03,.1307700E-02,.1489000E-02,.9793000E-03,& - & .1614800E-03,.1064800E-02,.1462100E-02,.1689100E-02,.1123700E-02,& - & .1605900E-03,.1167300E-02,.1635700E-02,.1916500E-02,.1289600E-02,& - & .1593400E-03,.1279500E-02,.1828800E-02,.2173600E-02,.1479100E-02/ - - data absb(526:700, 8) / & - & .1328600E-03,.7983500E-03,.1068300E-02,.1211700E-02,.7890800E-03,& - & .1326100E-03,.8806600E-03,.1203600E-02,.1386500E-02,.9125200E-03,& - & .1320900E-03,.9727000E-03,.1358000E-02,.1587100E-02,.1057000E-02,& - & .1313000E-03,.1074800E-02,.1531800E-02,.1817100E-02,.1223600E-02,& - & .1302200E-03,.1186600E-02,.1726400E-02,.2078600E-02,.1414800E-02,& - & .1087900E-03,.7156700E-03,.9707500E-03,.1111800E-02,.7235300E-03,& - & .1085500E-03,.7962500E-03,.1104100E-02,.1284500E-02,.8454000E-03,& - & .1081100E-03,.8868600E-03,.1256900E-02,.1484700E-02,.9883100E-03,& - & .1074300E-03,.9876100E-03,.1430000E-02,.1715700E-02,.1154100E-02,& - & .1065000E-03,.1098700E-02,.1625100E-02,.1979900E-02,.1346000E-02,& - & .8909100E-04,.6377300E-03,.8752500E-03,.1010600E-02,.6564300E-03,& - & .8889200E-04,.7157200E-03,.1005000E-02,.1179400E-02,.7748200E-03,& - & .8851000E-04,.8039000E-03,.1154400E-02,.1376800E-02,.9143700E-03,& - & .8795100E-04,.9025300E-03,.1325500E-02,.1606300E-02,.1077900E-02,& - & .8717500E-04,.1012000E-02,.1518700E-02,.1870300E-02,.1267700E-02,& - & .7296700E-04,.5605100E-03,.7758600E-03,.9013900E-03,.5831900E-03,& - & .7281800E-04,.6345900E-03,.8996200E-03,.1062700E-02,.6954500E-03,& - & .7252300E-04,.7190900E-03,.1043300E-02,.1253300E-02,.8289600E-03,& - & .7208700E-04,.8142700E-03,.1209200E-02,.1476600E-02,.9867100E-03,& - & .7148600E-04,.9209300E-03,.1397700E-02,.1735500E-02,.1170800E-02,& - & .5976500E-04,.4932000E-03,.6884400E-03,.8047800E-03,.5184900E-03,& - & .5966000E-04,.5635400E-03,.8064000E-03,.9587600E-03,.6246600E-03,& - & .5943600E-04,.6444000E-03,.9445400E-03,.1142600E-02,.7523600E-03,& - & .5910200E-04,.7363100E-03,.1105200E-02,.1359900E-02,.9043300E-03,& - & .5863500E-04,.8400900E-03,.1289100E-02,.1613400E-02,.1082900E-02,& - & .4895600E-04,.4349900E-03,.6123100E-03,.7201700E-03,.4618900E-03,& - & .4889000E-04,.5018100E-03,.7247800E-03,.8673000E-03,.5624400E-03,& - & .4871700E-04,.5792300E-03,.8577800E-03,.1044800E-02,.6846400E-03,& - & .4845100E-04,.6679900E-03,.1013200E-02,.1256300E-02,.8311200E-03,& - & .4808500E-04,.7689800E-03,.1192800E-02,.1504700E-02,.1004400E-02,& - & .4010700E-04,.3786000E-03,.5359600E-03,.6330200E-03,.4035000E-03,& - & .4006800E-04,.4409900E-03,.6412600E-03,.7710500E-03,.4969700E-03,& - & .3994500E-04,.5139900E-03,.7669400E-03,.9393400E-03,.6116600E-03,& - & .3975200E-04,.5985100E-03,.9152800E-03,.1141600E-02,.7503700E-03,& - & .3946900E-04,.6954400E-03,.1088000E-02,.1380900E-02,.9159300E-03/ - - data absb(701:875, 8) / & - & .3285100E-04,.3287800E-03,.4678600E-03,.5546900E-03,.3512000E-03,& - & .3283900E-04,.3868300E-03,.5660700E-03,.6839400E-03,.4376900E-03,& - & .3274900E-04,.4554200E-03,.6844400E-03,.8425900E-03,.5449000E-03,& - & .3260700E-04,.5356400E-03,.8254700E-03,.1035200E-02,.6758500E-03,& - & .3239500E-04,.6284100E-03,.9913300E-03,.1265200E-02,.8333200E-03,& - & .2690600E-04,.2853400E-03,.4080500E-03,.4853500E-03,.3052600E-03,& - & .2690800E-04,.3392200E-03,.4995000E-03,.6060300E-03,.3850500E-03,& - & .2684600E-04,.4036100E-03,.6107600E-03,.7556400E-03,.4852400E-03,& - & .2673900E-04,.4795300E-03,.7445400E-03,.9388200E-03,.6086100E-03,& - & .2658500E-04,.5681600E-03,.9036300E-03,.1159700E-02,.7582900E-03,& - & .2203400E-04,.2449400E-03,.3512600E-03,.4186200E-03,.2613300E-03,& - & .2204500E-04,.2942800E-03,.4352600E-03,.5296000E-03,.3337900E-03,& - & .2200900E-04,.3539400E-03,.5383800E-03,.6689300E-03,.4259900E-03,& - & .2193300E-04,.4251000E-03,.6639200E-03,.8409000E-03,.5406100E-03,& - & .2182000E-04,.5087800E-03,.8147400E-03,.1050300E-02,.6813900E-03,& - & .1804200E-04,.2087800E-03,.2998800E-03,.3578200E-03,.2216000E-03,& - & .1805800E-04,.2536000E-03,.3762100E-03,.4587500E-03,.2867000E-03,& - & .1804100E-04,.3084500E-03,.4712300E-03,.5872700E-03,.3707000E-03,& - & .1798900E-04,.3745900E-03,.5880400E-03,.7473900E-03,.4765000E-03,& - & .1790600E-04,.4531700E-03,.7300300E-03,.9445400E-03,.6076800E-03,& - & .1477000E-04,.1774300E-03,.2551800E-03,.3046100E-03,.1871800E-03,& - & .1479000E-04,.2179400E-03,.3242400E-03,.3960300E-03,.2453400E-03,& - & .1478500E-04,.2682200E-03,.4113200E-03,.5140600E-03,.3215800E-03,& - & .1475100E-04,.3294800E-03,.5196800E-03,.6628800E-03,.4188900E-03,& - & .1469200E-04,.4030900E-03,.6529800E-03,.8479500E-03,.5407800E-03,& - & .1209100E-04,.1495600E-03,.2150700E-03,.2566400E-03,.1564100E-03,& - & .1211200E-04,.1858500E-03,.2768900E-03,.3385300E-03,.2077800E-03,& - & .1211300E-04,.2315600E-03,.3559700E-03,.4457500E-03,.2761900E-03,& - & .1209400E-04,.2878900E-03,.4557600E-03,.5831300E-03,.3649200E-03,& - & .1205400E-04,.3562800E-03,.5798000E-03,.7552300E-03,.4772100E-03,& - & .9895800E-05,.1243600E-03,.1783800E-03,.2124100E-03,.1284100E-03,& - & .9915700E-05,.1563300E-03,.2327900E-03,.2844300E-03,.1729100E-03,& - & .9922400E-05,.1972400E-03,.3035000E-03,.3801700E-03,.2332300E-03,& - & .9915000E-05,.2483100E-03,.3939600E-03,.5048800E-03,.3127400E-03,& - & .9888100E-05,.3111000E-03,.5078800E-03,.6630400E-03,.4148500E-03/ - - data absb(876:1050, 8) / & - & .8098100E-05,.1028400E-03,.1470100E-03,.1745700E-03,.1046400E-03,& - & .8117000E-05,.1308300E-03,.1945200E-03,.2373400E-03,.1429800E-03,& - & .8125400E-05,.1671600E-03,.2572700E-03,.3223000E-03,.1956500E-03,& - & .8125300E-05,.2132800E-03,.3388700E-03,.4347500E-03,.2665200E-03,& - & .8109200E-05,.2706200E-03,.4430100E-03,.5797200E-03,.3588700E-03,& - & .6626200E-05,.8454200E-04,.1203400E-03,.1424500E-03,.8463600E-04,& - & .6643500E-05,.1090300E-03,.1616800E-03,.1968600E-03,.1174000E-03,& - & .6652700E-05,.1409200E-03,.2168500E-03,.2715600E-03,.1630900E-03,& - & .6656700E-05,.1822900E-03,.2898900E-03,.3721400E-03,.2257200E-03,& - & .6648900E-05,.2344300E-03,.3846100E-03,.5041800E-03,.3088300E-03,& - & .5420200E-05,.6960800E-04,.9868000E-04,.1164600E-03,.6851000E-04,& - & .5437400E-05,.9080200E-04,.1343400E-03,.1633000E-03,.9649900E-04,& - & .5447500E-05,.1191600E-03,.1832700E-03,.2293200E-03,.1362000E-03,& - & .5452100E-05,.1560800E-03,.2484500E-03,.3192800E-03,.1915400E-03,& - & .5449800E-05,.2034800E-03,.3346600E-03,.4393700E-03,.2662600E-03,& - & .4435100E-05,.5708800E-04,.8058200E-04,.9479000E-04,.5525000E-04,& - & .4450400E-05,.7543500E-04,.1113100E-03,.1350300E-03,.7902400E-04,& - & .4459900E-05,.1003700E-03,.1542800E-03,.1929100E-03,.1134300E-03,& - & .4465100E-05,.1333600E-03,.2125200E-03,.2733500E-03,.1621800E-03,& - & .4465300E-05,.1764000E-03,.2907500E-03,.3822900E-03,.2292300E-03,& - & .3629000E-05,.4656500E-04,.6536400E-04,.7659800E-04,.4424000E-04,& - & .3642000E-05,.6231400E-04,.9164400E-04,.1109000E-03,.6423400E-04,& - & .3650900E-05,.8410200E-04,.1291000E-03,.1612500E-03,.9383300E-04,& - & .3655500E-05,.1136200E-03,.1811500E-03,.2329700E-03,.1365700E-03,& - & .3657900E-05,.1522600E-03,.2513600E-03,.3309900E-03,.1962100E-03,& - & .2969200E-05,.3774600E-04,.5263200E-04,.6139700E-04,.3516500E-04,& - & .2980800E-05,.5114900E-04,.7487900E-04,.9033500E-04,.5180700E-04,& - & .2988000E-05,.7002800E-04,.1072400E-03,.1337500E-03,.7701000E-04,& - & .2993100E-05,.9610500E-04,.1531400E-03,.1968900E-03,.1141700E-03,& - & .2995900E-05,.1307400E-03,.2161200E-03,.2849200E-03,.1669700E-03,& - & .2429600E-05,.3069800E-04,.4254400E-04,.4940600E-04,.2807200E-04,& - & .2439300E-05,.4212200E-04,.6145400E-04,.7392700E-04,.4196400E-04,& - & .2446000E-05,.5852800E-04,.8950000E-04,.1114600E-03,.6350300E-04,& - & .2450700E-05,.8161100E-04,.1300900E-03,.1672800E-03,.9594700E-04,& - & .2453500E-05,.1127600E-03,.1868200E-03,.2465400E-03,.1428600E-03/ - - data absb(1051:1175, 8) / & - & .1988300E-05,.2492100E-04,.3431200E-04,.3966600E-04,.2237500E-04,& - & .1996300E-05,.3464100E-04,.5034400E-04,.6038100E-04,.3394200E-04,& - & .2002000E-05,.4886800E-04,.7461800E-04,.9280900E-04,.5228000E-04,& - & .2006500E-05,.6925500E-04,.1104200E-03,.1420300E-03,.8056600E-04,& - & .2008900E-05,.9752700E-04,.1618200E-03,.2137300E-03,.1222800E-03,& - & .1626800E-05,.2012200E-04,.2750600E-04,.3162900E-04,.1771800E-04,& - & .1633700E-05,.2832100E-04,.4096600E-04,.4896000E-04,.2727100E-04,& - & .1638500E-05,.4057900E-04,.6182800E-04,.7674700E-04,.4273900E-04,& - & .1642400E-05,.5849000E-04,.9322000E-04,.1199100E-03,.6723200E-04,& - & .1645000E-05,.8377600E-04,.1391700E-03,.1840100E-03,.1040600E-03,& - & .1331100E-05,.1615100E-04,.2190100E-04,.2504400E-04,.1393400E-04,& - & .1336900E-05,.2300500E-04,.3308300E-04,.3937700E-04,.2175100E-04,& - & .1341100E-05,.3350100E-04,.5088800E-04,.6301400E-04,.3469600E-04,& - & .1344300E-05,.4911100E-04,.7819100E-04,.1005100E-03,.5571100E-04,& - & .1346700E-05,.7158600E-04,.1190200E-03,.1574400E-03,.8802500E-04,& - & .1089200E-05,.1296200E-04,.1744300E-04,.1982500E-04,.1095500E-04,& - & .1094200E-05,.1868800E-04,.2671600E-04,.3166400E-04,.1734800E-04,& - & .1097600E-05,.2765000E-04,.4186400E-04,.5171600E-04,.2815900E-04,& - & .1100400E-05,.4125100E-04,.6563000E-04,.8429900E-04,.4615600E-04,& - & .1102500E-05,.6126100E-04,.1019600E-03,.1349600E-03,.7453600E-04,& - & .8919700E-06,.1104700E-04,.1489900E-04,.1696400E-04,.9299900E-05,& - & .8960500E-06,.1621500E-04,.2329100E-04,.2768600E-04,.1501900E-04,& - & .8987500E-06,.2446200E-04,.3726700E-04,.4624300E-04,.2490500E-04,& - & .9011700E-06,.3717500E-04,.5959400E-04,.7696900E-04,.4167200E-04,& - & .9031000E-06,.5611500E-04,.9418700E-04,.1252800E-03,.6849700E-04/ - - data absb( 1:175, 9) / & - & .7386370E-01,.1217270E+00,.1397997E+00,.1419673E+00,.1084738E+00,& - & .7529449E-01,.1232830E+00,.1414079E+00,.1438635E+00,.1108050E+00,& - & .7697992E-01,.1254793E+00,.1434365E+00,.1458286E+00,.1129988E+00,& - & .7887100E-01,.1280855E+00,.1459070E+00,.1479085E+00,.1152446E+00,& - & .8092090E-01,.1307909E+00,.1487251E+00,.1501501E+00,.1175320E+00,& - & .6403379E-01,.1090204E+00,.1253282E+00,.1274699E+00,.9632574E-01,& - & .6547459E-01,.1110735E+00,.1274271E+00,.1295924E+00,.9864560E-01,& - & .6715540E-01,.1136407E+00,.1299702E+00,.1318704E+00,.1010107E+00,& - & .6906380E-01,.1163504E+00,.1328994E+00,.1343146E+00,.1034582E+00,& - & .7105787E-01,.1191957E+00,.1361107E+00,.1370057E+00,.1059074E+00,& - & .5530200E-01,.9757076E-01,.1121740E+00,.1140513E+00,.8533242E-01,& - & .5675787E-01,.1000348E+00,.1147292E+00,.1164809E+00,.8776543E-01,& - & .5846659E-01,.1027322E+00,.1176838E+00,.1190849E+00,.9029882E-01,& - & .6032734E-01,.1055957E+00,.1209546E+00,.1219366E+00,.9286960E-01,& - & .6209121E-01,.1085948E+00,.1243416E+00,.1250550E+00,.9547001E-01,& - & .4762395E-01,.8734512E-01,.1003708E+00,.1018642E+00,.7561273E-01,& - & .4911368E-01,.8996446E-01,.1032731E+00,.1045503E+00,.7815395E-01,& - & .5080031E-01,.9279755E-01,.1065652E+00,.1074922E+00,.8078702E-01,& - & .5243449E-01,.9581412E-01,.1100211E+00,.1107497E+00,.8346128E-01,& - & .5394988E-01,.9894050E-01,.1135959E+00,.1142797E+00,.8622867E-01,& - & .4090347E-01,.7810647E-01,.8979429E-01,.9092391E-01,.6709977E-01,& - & .4239633E-01,.8087453E-01,.9303629E-01,.9387987E-01,.6971100E-01,& - & .4389973E-01,.8384796E-01,.9650459E-01,.9716037E-01,.7239385E-01,& - & .4532474E-01,.8698861E-01,.1001236E+00,.1007738E+00,.7517902E-01,& - & .4664725E-01,.9022266E-01,.1038715E+00,.1046269E+00,.7808115E-01,& - & .3507354E-01,.6984031E-01,.8045794E-01,.8126652E-01,.5967808E-01,& - & .3641404E-01,.7272845E-01,.8387260E-01,.8449727E-01,.6232326E-01,& - & .3773547E-01,.7581798E-01,.8747042E-01,.8807986E-01,.6506146E-01,& - & .3899381E-01,.7905992E-01,.9126223E-01,.9196437E-01,.6793314E-01,& - & .4015940E-01,.8236350E-01,.9521155E-01,.9607923E-01,.7090836E-01,& - & .2996758E-01,.6248612E-01,.7222878E-01,.7286184E-01,.5319451E-01,& - & .3114015E-01,.6548203E-01,.7573235E-01,.7633337E-01,.5587473E-01,& - & .3229126E-01,.6867140E-01,.7946891E-01,.8015608E-01,.5867307E-01,& - & .3340366E-01,.7198946E-01,.8342015E-01,.8425577E-01,.6160468E-01,& - & .3444385E-01,.7527768E-01,.8753864E-01,.8855726E-01,.6465244E-01/ - - data absb(176:350, 9) / & - & .2552897E-01,.5604549E-01,.6504953E-01,.6568338E-01,.4759673E-01,& - & .2655263E-01,.5914810E-01,.6865615E-01,.6934990E-01,.5031583E-01,& - & .2756945E-01,.6242191E-01,.7252447E-01,.7335652E-01,.5316631E-01,& - & .2855171E-01,.6573444E-01,.7661794E-01,.7759839E-01,.5616029E-01,& - & .2946709E-01,.6902393E-01,.8088256E-01,.8205689E-01,.5928927E-01,& - & .2169323E-01,.5042927E-01,.5880926E-01,.5953518E-01,.4276904E-01,& - & .2259137E-01,.5361379E-01,.6252841E-01,.6336797E-01,.4551161E-01,& - & .2349223E-01,.5691109E-01,.6652380E-01,.6748411E-01,.4841701E-01,& - & .2435866E-01,.6022552E-01,.7072962E-01,.7184630E-01,.5147673E-01,& - & .2516486E-01,.6352693E-01,.7511834E-01,.7646009E-01,.5467556E-01,& - & .1845909E-01,.4576813E-01,.5367465E-01,.5454792E-01,.3878639E-01,& - & .1925599E-01,.4899168E-01,.5752566E-01,.5849933E-01,.4157610E-01,& - & .2005017E-01,.5229447E-01,.6163578E-01,.6272679E-01,.4454755E-01,& - & .2080611E-01,.5562768E-01,.6596785E-01,.6724008E-01,.4767687E-01,& - & .2150826E-01,.5895362E-01,.7048564E-01,.7202217E-01,.5095808E-01,& - & .1570422E-01,.4178498E-01,.4935434E-01,.5034621E-01,.3542605E-01,& - & .1640986E-01,.4501386E-01,.5331082E-01,.5440870E-01,.3827459E-01,& - & .1710795E-01,.4833320E-01,.5753856E-01,.5876524E-01,.4130508E-01,& - & .1776552E-01,.5169642E-01,.6199404E-01,.6343553E-01,.4450482E-01,& - & .1836301E-01,.5505656E-01,.6662521E-01,.6837233E-01,.4786425E-01,& - & .1336950E-01,.3839896E-01,.4576222E-01,.4685100E-01,.3263474E-01,& - & .1399497E-01,.4164334E-01,.4982575E-01,.5104297E-01,.3553968E-01,& - & .1459622E-01,.4499292E-01,.5417389E-01,.5554832E-01,.3863403E-01,& - & .1515950E-01,.4838565E-01,.5872737E-01,.6036693E-01,.4189693E-01,& - & .1567094E-01,.5178762E-01,.6347431E-01,.6547102E-01,.4533998E-01,& - & .1139415E-01,.3556539E-01,.4282652E-01,.4400955E-01,.3034823E-01,& - & .1193609E-01,.3883632E-01,.4700523E-01,.4834132E-01,.3330647E-01,& - & .1245410E-01,.4221330E-01,.5145145E-01,.5300744E-01,.3646560E-01,& - & .1293803E-01,.4565202E-01,.5613109E-01,.5799082E-01,.3980753E-01,& - & .1337501E-01,.4910924E-01,.6099932E-01,.6327343E-01,.4334453E-01,& - & .9722913E-02,.3326032E-01,.4052121E-01,.4180726E-01,.2852809E-01,& - & .1018992E-01,.3656568E-01,.4481036E-01,.4630022E-01,.3155388E-01,& - & .1063595E-01,.3998111E-01,.4937235E-01,.5113650E-01,.3479040E-01,& - & .1105185E-01,.4347100E-01,.5418973E-01,.5629833E-01,.3822398E-01,& - & .1143041E-01,.4699477E-01,.5918778E-01,.6176195E-01,.4186182E-01/ - - data absb(351:525, 9) / & - & .8300709E-02,.3138262E-01,.3871373E-01,.4011993E-01,.2708755E-01,& - & .8705608E-02,.3472930E-01,.4312192E-01,.4478609E-01,.3018835E-01,& - & .9091211E-02,.3820073E-01,.4781870E-01,.4980017E-01,.3350792E-01,& - & .9448828E-02,.4175226E-01,.5277360E-01,.5514398E-01,.3704207E-01,& - & .9783765E-02,.4534922E-01,.5791589E-01,.6079477E-01,.4078994E-01,& - & .7094791E-02,.2988609E-01,.3735115E-01,.3890287E-01,.2597883E-01,& - & .7443776E-02,.3328590E-01,.4189354E-01,.4374887E-01,.2916268E-01,& - & .7777473E-02,.3682175E-01,.4673676E-01,.4894363E-01,.3257840E-01,& - & .8091821E-02,.4045146E-01,.5183182E-01,.5446905E-01,.3621756E-01,& - & .8393762E-02,.4412277E-01,.5711772E-01,.6030049E-01,.4008338E-01,& - & .6072721E-02,.2875406E-01,.3642428E-01,.3814167E-01,.2519233E-01,& - & .6375450E-02,.3222477E-01,.4111499E-01,.4316950E-01,.2846448E-01,& - & .6665401E-02,.3583825E-01,.4610908E-01,.4855053E-01,.3198856E-01,& - & .6947813E-02,.3954583E-01,.5134775E-01,.5425463E-01,.3574183E-01,& - & .7224449E-02,.4329363E-01,.5677163E-01,.6025181E-01,.3971948E-01,& - & .5204996E-02,.2793567E-01,.3586995E-01,.3776366E-01,.2467285E-01,& - & .5467917E-02,.3148948E-01,.4071531E-01,.4297096E-01,.2804493E-01,& - & .5726383E-02,.3518386E-01,.4585588E-01,.4852812E-01,.3168056E-01,& - & .5982991E-02,.3897236E-01,.5123260E-01,.5440198E-01,.3555049E-01,& - & .6240892E-02,.4279660E-01,.5678660E-01,.6055093E-01,.3963932E-01,& - & .4469682E-02,.2742048E-01,.3567286E-01,.3774779E-01,.2440899E-01,& - & .4700641E-02,.3106355E-01,.4067206E-01,.4312796E-01,.2789294E-01,& - & .4936385E-02,.3484450E-01,.4595839E-01,.4885735E-01,.3164155E-01,& - & .5173162E-02,.3871026E-01,.5146122E-01,.5488738E-01,.3562372E-01,& - & .5417514E-02,.4260570E-01,.5713175E-01,.6117015E-01,.3982399E-01,& - & .3844994E-02,.2717409E-01,.3578885E-01,.3804312E-01,.2437272E-01,& - & .4053349E-02,.3090840E-01,.4093856E-01,.4359092E-01,.2797192E-01,& - & .4269342E-02,.3477112E-01,.4635566E-01,.4947518E-01,.3183081E-01,& - & .4494036E-02,.3870776E-01,.5197315E-01,.5564894E-01,.3592188E-01,& - & .4730771E-02,.4267219E-01,.5774228E-01,.6204827E-01,.4022778E-01,& - & .3316155E-02,.2716439E-01,.3617214E-01,.3860092E-01,.2453709E-01,& - & .3507741E-02,.3098644E-01,.4145934E-01,.4430670E-01,.2825000E-01,& - & .3708780E-02,.3492455E-01,.4699683E-01,.5032871E-01,.3221778E-01,& - & .3925552E-02,.3892413E-01,.5271553E-01,.5663089E-01,.3641334E-01,& - & .4158892E-02,.4294570E-01,.5857114E-01,.6313194E-01,.4081644E-01/ - - data absb(526:700, 9) / & - & .2863791E-02,.2722174E-01,.3659228E-01,.3917713E-01,.2474498E-01,& - & .3040588E-02,.3112320E-01,.4199421E-01,.4501754E-01,.2855786E-01,& - & .3233150E-02,.3512719E-01,.4763348E-01,.5115797E-01,.3261841E-01,& - & .3445381E-02,.3917826E-01,.5343694E-01,.5756145E-01,.3690166E-01,& - & .3677438E-02,.4324272E-01,.5935861E-01,.6414300E-01,.4138900E-01,& - & .2465329E-02,.2707028E-01,.3666695E-01,.3936557E-01,.2472691E-01,& - & .2632781E-02,.3103171E-01,.4215043E-01,.4529694E-01,.2860992E-01,& - & .2818872E-02,.3508603E-01,.4786198E-01,.5151711E-01,.3273833E-01,& - & .3025017E-02,.3917768E-01,.5372478E-01,.5798985E-01,.3708084E-01,& - & .3257127E-02,.4327518E-01,.5969457E-01,.6462649E-01,.4162399E-01,& - & .2114507E-02,.2661661E-01,.3628160E-01,.3903834E-01,.2439799E-01,& - & .2271568E-02,.3061795E-01,.4180884E-01,.4501716E-01,.2831780E-01,& - & .2449593E-02,.3470815E-01,.4756236E-01,.5128126E-01,.3248201E-01,& - & .2650872E-02,.3883456E-01,.5346450E-01,.5779235E-01,.3685837E-01,& - & .2883010E-02,.4296394E-01,.5947166E-01,.6446457E-01,.4143251E-01,& - & .1797225E-02,.2566144E-01,.3516915E-01,.3791294E-01,.2356973E-01,& - & .1942471E-02,.2967546E-01,.4069640E-01,.4388416E-01,.2748224E-01,& - & .2110732E-02,.3378859E-01,.4645705E-01,.5014523E-01,.3164309E-01,& - & .2305322E-02,.3794341E-01,.5237303E-01,.5666115E-01,.3601691E-01,& - & .2533979E-02,.4209991E-01,.5839699E-01,.6333729E-01,.4058728E-01,& - & .1528499E-02,.2474850E-01,.3408418E-01,.3680675E-01,.2276935E-01,& - & .1662648E-02,.2877135E-01,.3960487E-01,.4276395E-01,.2666990E-01,& - & .1822270E-02,.3290004E-01,.4536537E-01,.4901380E-01,.3081993E-01,& - & .2010407E-02,.3707876E-01,.5128684E-01,.5551957E-01,.3518382E-01,& - & .2236121E-02,.4125795E-01,.5732398E-01,.6219988E-01,.3974976E-01,& - & .1301157E-02,.2390332E-01,.3306486E-01,.3576088E-01,.2202215E-01,& - & .1425753E-02,.2792846E-01,.3857359E-01,.4169850E-01,.2590697E-01,& - & .1577002E-02,.3206803E-01,.4432843E-01,.4793360E-01,.3004339E-01,& - & .1759961E-02,.3626411E-01,.5025187E-01,.5442732E-01,.3439556E-01,& - & .1982828E-02,.4046418E-01,.5629663E-01,.6110344E-01,.3895158E-01,& - & .1098183E-02,.2271194E-01,.3154937E-01,.3417342E-01,.2093772E-01,& - & .1211979E-02,.2671363E-01,.3701515E-01,.4005573E-01,.2477551E-01,& - & .1352163E-02,.3085276E-01,.4273410E-01,.4624396E-01,.2887103E-01,& - & .1526376E-02,.3505659E-01,.4864130E-01,.5269139E-01,.3318689E-01,& - & .1741576E-02,.3927458E-01,.5467901E-01,.5935019E-01,.3770824E-01/ - - data absb(701:875, 9) / & - & .9256636E-03,.2151927E-01,.3001800E-01,.3256386E-01,.1984971E-01,& - & .1029330E-02,.2548720E-01,.3542880E-01,.3837882E-01,.2363194E-01,& - & .1157935E-02,.2961670E-01,.4110275E-01,.4450903E-01,.2767804E-01,& - & .1322566E-02,.3382477E-01,.4698627E-01,.5090557E-01,.3195340E-01,& - & .1529747E-02,.3805510E-01,.5300873E-01,.5753600E-01,.3643451E-01,& - & .7800682E-03,.2037045E-01,.2853508E-01,.3100101E-01,.1880237E-01,& - & .8728720E-03,.2429814E-01,.3387777E-01,.3673821E-01,.2252410E-01,& - & .9913989E-03,.2840935E-01,.3950510E-01,.4280696E-01,.2651603E-01,& - & .1147051E-02,.3261525E-01,.4535763E-01,.4915180E-01,.3074712E-01,& - & .1345265E-02,.3685628E-01,.5135640E-01,.5573969E-01,.3518635E-01,& - & .6520564E-03,.1905366E-01,.2681157E-01,.2917864E-01,.1759490E-01,& - & .7355199E-03,.2291988E-01,.3206051E-01,.3480883E-01,.2123646E-01,& - & .8430968E-03,.2699435E-01,.3762006E-01,.4079097E-01,.2515653E-01,& - & .9861085E-03,.3118915E-01,.4342129E-01,.4706516E-01,.2932868E-01,& - & .1172376E-02,.3543571E-01,.4939030E-01,.5358864E-01,.3371077E-01,& - & .5429238E-03,.1769119E-01,.2501427E-01,.2727445E-01,.1634645E-01,& - & .6168245E-03,.2147865E-01,.3015275E-01,.3277935E-01,.1989356E-01,& - & .7121998E-03,.2550313E-01,.3563092E-01,.3866373E-01,.2373486E-01,& - & .8424551E-03,.2967789E-01,.4136324E-01,.4485540E-01,.2783187E-01,& - & .1016095E-02,.3392096E-01,.4729347E-01,.5130218E-01,.3215264E-01,& - & .4520417E-03,.1638027E-01,.2327058E-01,.2542894E-01,.1514441E-01,& - & .5155432E-03,.2007947E-01,.2829736E-01,.3080698E-01,.1859499E-01,& - & .6014451E-03,.2404182E-01,.3368120E-01,.3657952E-01,.2235065E-01,& - & .7188950E-03,.2818500E-01,.3934025E-01,.4268031E-01,.2636784E-01,& - & .8790319E-03,.3241918E-01,.4522294E-01,.4905072E-01,.3062540E-01,& - & .3739048E-03,.1504727E-01,.2147687E-01,.2353542E-01,.1391939E-01,& - & .4299766E-03,.1864024E-01,.2638349E-01,.2876868E-01,.1726321E-01,& - & .5043505E-03,.2252541E-01,.3165039E-01,.3441216E-01,.2091919E-01,& - & .6094823E-03,.2662193E-01,.3722724E-01,.4040986E-01,.2485188E-01,& - & .7547889E-03,.3083607E-01,.4304298E-01,.4669398E-01,.2903395E-01,& - & .3059529E-03,.1362998E-01,.1954590E-01,.2150308E-01,.1261761E-01,& - & .3544511E-03,.1709153E-01,.2431072E-01,.2656287E-01,.1583432E-01,& - & .4182967E-03,.2087582E-01,.2943979E-01,.3205269E-01,.1937141E-01,& - & .5101848E-03,.2490407E-01,.3491246E-01,.3792397E-01,.2320561E-01,& - & .6398861E-03,.2908833E-01,.4064101E-01,.4410450E-01,.2729138E-01/ - - data absb(876:1050, 9) / & - & .2498082E-03,.1228614E-01,.1769311E-01,.1955495E-01,.1137919E-01,& - & .2913249E-03,.1560283E-01,.2230066E-01,.2443072E-01,.1445974E-01,& - & .3471061E-03,.1927312E-01,.2729375E-01,.2976141E-01,.1787798E-01,& - & .4260536E-03,.2321801E-01,.3264138E-01,.3549044E-01,.2160039E-01,& - & .5402840E-03,.2735520E-01,.3827674E-01,.4155616E-01,.2559086E-01,& - & .2032306E-03,.1100929E-01,.1592358E-01,.1768796E-01,.1020153E-01,& - & .2392377E-03,.1418860E-01,.2036714E-01,.2238632E-01,.1314703E-01,& - & .2862724E-03,.1772046E-01,.2521008E-01,.2753806E-01,.1643822E-01,& - & .3532839E-03,.2156941E-01,.3041971E-01,.3311704E-01,.2004337E-01,& - & .4535630E-03,.2564413E-01,.3595639E-01,.3905830E-01,.2393631E-01,& - & .1658721E-03,.9881414E-02,.1435034E-01,.1601976E-01,.9156258E-02,& - & .1953876E-03,.1291102E-01,.1860859E-01,.2053398E-01,.1196964E-01,& - & .2372144E-03,.1632300E-01,.2331887E-01,.2552322E-01,.1513690E-01,& - & .2956183E-03,.2005853E-01,.2839017E-01,.3094782E-01,.1862793E-01,& - & .3822967E-03,.2406104E-01,.3381785E-01,.3676346E-01,.2242186E-01,& - & .1347727E-03,.8839179E-02,.1288890E-01,.1446932E-01,.8192478E-02,& - & .1593422E-03,.1172817E-01,.1696668E-01,.1880252E-01,.1087547E-01,& - & .1948108E-03,.1500685E-01,.2152813E-01,.2362440E-01,.1391796E-01,& - & .2456981E-03,.1863185E-01,.2647287E-01,.2889888E-01,.1729864E-01,& - & .3210495E-03,.2255415E-01,.3178001E-01,.3458170E-01,.2098803E-01,& - & .1090472E-03,.7861512E-02,.1150652E-01,.1299630E-01,.7284963E-02,& - & .1294974E-03,.1060140E-01,.1539628E-01,.1714133E-01,.9834191E-02,& - & .1592049E-03,.1374264E-01,.1979296E-01,.2179392E-01,.1275057E-01,& - & .2045251E-03,.1726001E-01,.2461884E-01,.2691705E-01,.1601660E-01,& - & .2700821E-03,.2107733E-01,.2978897E-01,.3245179E-01,.1959460E-01,& - & .8802434E-04,.6944882E-02,.1020032E-01,.1159221E-01,.6430862E-02,& - & .1046855E-03,.9527594E-02,.1389317E-01,.1554646E-01,.8842774E-02,& - & .1292946E-03,.1253134E-01,.1811521E-01,.2002416E-01,.1163053E-01,& - & .1677549E-03,.1591776E-01,.2279809E-01,.2497825E-01,.1477209E-01,& - & .2257215E-03,.1963067E-01,.2784013E-01,.3036876E-01,.1824002E-01,& - & .7112381E-04,.6158932E-02,.9074677E-02,.1037208E-01,.5697312E-02,& - & .8497772E-04,.8594221E-02,.1257729E-01,.1414858E-01,.7977017E-02,& - & .1052109E-03,.1146594E-01,.1663179E-01,.1845837E-01,.1064379E-01,& - & .1377962E-03,.1472932E-01,.2117504E-01,.2325811E-01,.1367082E-01,& - & .1885595E-03,.1833924E-01,.2610150E-01,.2850850E-01,.1703634E-01/ - - data absb(1051:1175, 9) / & - & .5743054E-04,.5454299E-02,.8062707E-02,.9263120E-02,.5037907E-02,& - & .6891997E-04,.7748836E-02,.1137635E-01,.1286665E-01,.7190454E-02,& - & .8575160E-04,.1048793E-01,.1526380E-01,.1700893E-01,.9738840E-02,& - & .1130459E-03,.1362883E-01,.1965917E-01,.2165939E-01,.1265333E-01,& - & .1594488E-03,.1714474E-01,.2448136E-01,.2677687E-01,.1591770E-01,& - & .4626830E-04,.4800265E-02,.7116803E-02,.8217649E-02,.4424823E-02,& - & .5574968E-04,.6951784E-02,.1023739E-01,.1164073E-01,.6446800E-02,& - & .6940184E-04,.9552514E-02,.1395187E-01,.1561652E-01,.8874544E-02,& - & .9239592E-04,.1257225E-01,.1819349E-01,.2011229E-01,.1167577E-01,& - & .1322365E-03,.1597315E-01,.2289106E-01,.2508204E-01,.1483008E-01,& - & .3713644E-04,.4193801E-02,.6237852E-02,.7236320E-02,.3854523E-02,& - & .4495045E-04,.6202948E-02,.9160942E-02,.1047397E-01,.5746268E-02,& - & .5606539E-04,.8661882E-02,.1269376E-01,.1427915E-01,.8047359E-02,& - & .7499774E-04,.1155560E-01,.1677574E-01,.1861487E-01,.1073338E-01,& - & .1090623E-03,.1483830E-01,.2133895E-01,.2343538E-01,.1377716E-01,& - & .2983624E-04,.3660809E-02,.5463957E-02,.6366210E-02,.3353712E-02,& - & .3622972E-04,.5534921E-02,.8199583E-02,.9421109E-02,.5120953E-02,& - & .4528199E-04,.7860566E-02,.1155366E-01,.1306274E-01,.7301227E-02,& - & .6078597E-04,.1062904E-01,.1547773E-01,.1723998E-01,.9874672E-02,& - & .8960328E-04,.1379622E-01,.1990262E-01,.2191965E-01,.1281258E-01,& - & .2476815E-04,.3454037E-02,.5166124E-02,.6030808E-02,.3159940E-02,& - & .3026086E-04,.5275928E-02,.7826736E-02,.9011759E-02,.4878738E-02,& - & .3827593E-04,.7548106E-02,.1110916E-01,.1258647E-01,.7009912E-02,& - & .5239001E-04,.1026550E-01,.1496950E-01,.1670101E-01,.9539209E-02,& - & .7936022E-04,.1338634E-01,.1933796E-01,.2132326E-01,.1243426E-01/ - - data absb( 1:175,10) / & - & .3241099E+01,.2987317E+01,.2934217E+01,.2979591E+01,.3249070E+01,& - & .3234075E+01,.2980277E+01,.2928977E+01,.2975887E+01,.3247797E+01,& - & .3225854E+01,.2969842E+01,.2920752E+01,.2969916E+01,.3244885E+01,& - & .3216237E+01,.2956861E+01,.2909451E+01,.2961989E+01,.3239941E+01,& - & .3205570E+01,.2942860E+01,.2895750E+01,.2952083E+01,.3233269E+01,& - & .3294407E+01,.3067418E+01,.3026193E+01,.3071528E+01,.3320951E+01,& - & .3287555E+01,.3058712E+01,.3019273E+01,.3067009E+01,.3319914E+01,& - & .3279570E+01,.3047161E+01,.3009370E+01,.3060158E+01,.3316506E+01,& - & .3270203E+01,.3034142E+01,.2996595E+01,.3051009E+01,.3310913E+01,& - & .3259714E+01,.3019806E+01,.2981647E+01,.3039634E+01,.3303820E+01,& - & .3341126E+01,.3138576E+01,.3108484E+01,.3154777E+01,.3385204E+01,& - & .3334442E+01,.3128468E+01,.3100116E+01,.3149324E+01,.3383891E+01,& - & .3326558E+01,.3116752E+01,.3088845E+01,.3141443E+01,.3379937E+01,& - & .3317437E+01,.3103447E+01,.3075001E+01,.3130952E+01,.3374048E+01,& - & .3307931E+01,.3088783E+01,.3059530E+01,.3118062E+01,.3366502E+01,& - & .3381819E+01,.3201482E+01,.3181519E+01,.3229413E+01,.3441758E+01,& - & .3375218E+01,.3191080E+01,.3171998E+01,.3223235E+01,.3440199E+01,& - & .3367503E+01,.3178917E+01,.3159508E+01,.3214061E+01,.3435864E+01,& - & .3359300E+01,.3165234E+01,.3145138E+01,.3202140E+01,.3429679E+01,& - & .3350904E+01,.3150191E+01,.3129217E+01,.3187795E+01,.3421572E+01,& - & .3416967E+01,.3257138E+01,.3245938E+01,.3295538E+01,.3491078E+01,& - & .3410526E+01,.3246460E+01,.3235248E+01,.3288412E+01,.3489256E+01,& - & .3403411E+01,.3233801E+01,.3222173E+01,.3278081E+01,.3484896E+01,& - & .3396503E+01,.3220051E+01,.3207563E+01,.3264988E+01,.3478422E+01,& - & .3388687E+01,.3204490E+01,.3190965E+01,.3249372E+01,.3469667E+01,& - & .3447347E+01,.3306390E+01,.3302358E+01,.3353515E+01,.3533939E+01,& - & .3441677E+01,.3295397E+01,.3291151E+01,.3345399E+01,.3532046E+01,& - & .3435433E+01,.3282539E+01,.3277801E+01,.3334036E+01,.3527652E+01,& - & .3428932E+01,.3268231E+01,.3262441E+01,.3319876E+01,.3520689E+01,& - & .3421802E+01,.3252582E+01,.3245243E+01,.3303411E+01,.3511826E+01,& - & .3473639E+01,.3349610E+01,.3351573E+01,.3403647E+01,.3571220E+01,& - & .3468683E+01,.3338245E+01,.3340115E+01,.3394675E+01,.3569195E+01,& - & .3463191E+01,.3325117E+01,.3326306E+01,.3382460E+01,.3564603E+01,& - & .3457226E+01,.3310536E+01,.3310441E+01,.3367641E+01,.3557528E+01,& - & .3450573E+01,.3294967E+01,.3292594E+01,.3350498E+01,.3548320E+01/ - - data absb(176:350,10) / & - & .3496427E+01,.3387213E+01,.3394307E+01,.3446696E+01,.3603551E+01,& - & .3492015E+01,.3375447E+01,.3382527E+01,.3437054E+01,.3601524E+01,& - & .3487054E+01,.3362003E+01,.3368240E+01,.3424123E+01,.3596558E+01,& - & .3481600E+01,.3347475E+01,.3351850E+01,.3408660E+01,.3589083E+01,& - & .3475345E+01,.3331832E+01,.3333426E+01,.3390953E+01,.3579691E+01,& - & .3515729E+01,.3419608E+01,.3431233E+01,.3483605E+01,.3631724E+01,& - & .3512042E+01,.3407688E+01,.3419052E+01,.3473258E+01,.3629302E+01,& - & .3507568E+01,.3394146E+01,.3404283E+01,.3459906E+01,.3623996E+01,& - & .3502487E+01,.3379596E+01,.3387427E+01,.3443990E+01,.3616232E+01,& - & .3496406E+01,.3363737E+01,.3368380E+01,.3425639E+01,.3606532E+01,& - & .3532277E+01,.3446949E+01,.3462235E+01,.3514489E+01,.3655808E+01,& - & .3528770E+01,.3434733E+01,.3449373E+01,.3503513E+01,.3652945E+01,& - & .3524634E+01,.3421100E+01,.3434125E+01,.3489643E+01,.3647282E+01,& - & .3519795E+01,.3406260E+01,.3416576E+01,.3472980E+01,.3639037E+01,& - & .3514104E+01,.3390336E+01,.3397008E+01,.3453854E+01,.3628856E+01,& - & .3546078E+01,.3470188E+01,.3488411E+01,.3540723E+01,.3676433E+01,& - & .3542944E+01,.3457842E+01,.3475086E+01,.3529136E+01,.3673056E+01,& - & .3538969E+01,.3443995E+01,.3459112E+01,.3514554E+01,.3666861E+01,& - & .3534492E+01,.3429012E+01,.3441008E+01,.3497202E+01,.3658321E+01,& - & .3528936E+01,.3412721E+01,.3420721E+01,.3477224E+01,.3647530E+01,& - & .3557812E+01,.3489957E+01,.3510431E+01,.3562900E+01,.3693951E+01,& - & .3554915E+01,.3477501E+01,.3496575E+01,.3550650E+01,.3690213E+01,& - & .3551290E+01,.3463442E+01,.3480042E+01,.3535257E+01,.3683497E+01,& - & .3546841E+01,.3448056E+01,.3461256E+01,.3517075E+01,.3674340E+01,& - & .3541285E+01,.3431269E+01,.3440276E+01,.3496294E+01,.3663228E+01,& - & .3567647E+01,.3506550E+01,.3528762E+01,.3581376E+01,.3708814E+01,& - & .3564997E+01,.3493846E+01,.3514220E+01,.3568244E+01,.3704420E+01,& - & .3561496E+01,.3479527E+01,.3497088E+01,.3552055E+01,.3697250E+01,& - & .3557192E+01,.3463748E+01,.3477590E+01,.3533010E+01,.3687653E+01,& - & .3551616E+01,.3446545E+01,.3455968E+01,.3511360E+01,.3675961E+01,& - & .3576050E+01,.3520359E+01,.3543745E+01,.3596477E+01,.3721344E+01,& - & .3573439E+01,.3507280E+01,.3528498E+01,.3582455E+01,.3716375E+01,& - & .3570110E+01,.3492608E+01,.3510656E+01,.3565258E+01,.3708511E+01,& - & .3565744E+01,.3476407E+01,.3490353E+01,.3545222E+01,.3698329E+01,& - & .3559803E+01,.3458419E+01,.3467812E+01,.3522516E+01,.3686100E+01/ - - data absb(351:525,10) / & - & .3582887E+01,.3531577E+01,.3555722E+01,.3608504E+01,.3731686E+01,& - & .3580475E+01,.3518245E+01,.3539855E+01,.3593592E+01,.3726109E+01,& - & .3577189E+01,.3503133E+01,.3521212E+01,.3575393E+01,.3717607E+01,& - & .3572639E+01,.3486267E+01,.3500027E+01,.3554276E+01,.3706744E+01,& - & .3566732E+01,.3467823E+01,.3476736E+01,.3530687E+01,.3693895E+01,& - & .3588948E+01,.3540932E+01,.3565482E+01,.3618178E+01,.3740395E+01,& - & .3586372E+01,.3527032E+01,.3548694E+01,.3602144E+01,.3734037E+01,& - & .3582904E+01,.3511279E+01,.3529122E+01,.3582894E+01,.3724850E+01,& - & .3578253E+01,.3493847E+01,.3507118E+01,.3560863E+01,.3713367E+01,& - & .3571896E+01,.3474633E+01,.3482868E+01,.3536238E+01,.3699809E+01,& - & .3593753E+01,.3548111E+01,.3572749E+01,.3625342E+01,.3747338E+01,& - & .3591161E+01,.3533619E+01,.3554981E+01,.3608138E+01,.3740209E+01,& - & .3587644E+01,.3517376E+01,.3534583E+01,.3587946E+01,.3730305E+01,& - & .3582824E+01,.3499345E+01,.3511738E+01,.3564886E+01,.3718106E+01,& - & .3576090E+01,.3479444E+01,.3486584E+01,.3539307E+01,.3703918E+01,& - & .3597761E+01,.3553599E+01,.3577948E+01,.3630395E+01,.3752803E+01,& - & .3595135E+01,.3538555E+01,.3559293E+01,.3612190E+01,.3744937E+01,& - & .3591361E+01,.3521618E+01,.3537925E+01,.3590860E+01,.3734257E+01,& - & .3586342E+01,.3502980E+01,.3514239E+01,.3566848E+01,.3721332E+01,& - & .3579098E+01,.3482302E+01,.3488295E+01,.3540497E+01,.3706615E+01,& - & .3601000E+01,.3557421E+01,.3581302E+01,.3633532E+01,.3756941E+01,& - & .3598425E+01,.3541845E+01,.3561786E+01,.3614297E+01,.3748264E+01,& - & .3594258E+01,.3524164E+01,.3539472E+01,.3591996E+01,.3736861E+01,& - & .3588813E+01,.3504757E+01,.3514868E+01,.3567024E+01,.3723189E+01,& - & .3581159E+01,.3483405E+01,.3488066E+01,.3539801E+01,.3707789E+01,& - & .3603721E+01,.3559860E+01,.3582917E+01,.3634951E+01,.3759790E+01,& - & .3600695E+01,.3543471E+01,.3562334E+01,.3614594E+01,.3750203E+01,& - & .3596558E+01,.3525354E+01,.3539343E+01,.3591476E+01,.3738184E+01,& - & .3590489E+01,.3505086E+01,.3513885E+01,.3565600E+01,.3723853E+01,& - & .3582281E+01,.3482974E+01,.3486236E+01,.3537560E+01,.3707796E+01,& - & .3606012E+01,.3561147E+01,.3583252E+01,.3635062E+01,.3761716E+01,& - & .3602690E+01,.3544023E+01,.3561757E+01,.3613695E+01,.3751349E+01,& - & .3598158E+01,.3525175E+01,.3537873E+01,.3589589E+01,.3738443E+01,& - & .3591521E+01,.3504190E+01,.3511600E+01,.3562948E+01,.3723509E+01,& - & .3582782E+01,.3481406E+01,.3483237E+01,.3534221E+01,.3706854E+01/ - - data absb(526:700,10) / & - & .3607593E+01,.3561716E+01,.3582936E+01,.3634631E+01,.3762977E+01,& - & .3604207E+01,.3544117E+01,.3560767E+01,.3612484E+01,.3751904E+01,& - & .3599186E+01,.3524501E+01,.3536083E+01,.3587617E+01,.3738408E+01,& - & .3592335E+01,.3503119E+01,.3509231E+01,.3560224E+01,.3722888E+01,& - & .3583023E+01,.3479645E+01,.3480307E+01,.3530962E+01,.3705868E+01,& - & .3609388E+01,.3563205E+01,.3583835E+01,.3635279E+01,.3764323E+01,& - & .3605668E+01,.3545073E+01,.3561130E+01,.3612628E+01,.3752963E+01,& - & .3600435E+01,.3525079E+01,.3535962E+01,.3587210E+01,.3739092E+01,& - & .3593253E+01,.3503218E+01,.3508581E+01,.3559430E+01,.3723196E+01,& - & .3583674E+01,.3479411E+01,.3479316E+01,.3529774E+01,.3705733E+01,& - & .3610877E+01,.3565753E+01,.3586334E+01,.3637630E+01,.3766564E+01,& - & .3607388E+01,.3547593E+01,.3563510E+01,.3614777E+01,.3754879E+01,& - & .3601974E+01,.3527292E+01,.3538093E+01,.3589236E+01,.3740900E+01,& - & .3594896E+01,.3505409E+01,.3510693E+01,.3561326E+01,.3724918E+01,& - & .3585207E+01,.3481394E+01,.3481186E+01,.3531504E+01,.3707454E+01,& - & .3612619E+01,.3570439E+01,.3591639E+01,.3642767E+01,.3769831E+01,& - & .3609315E+01,.3552400E+01,.3569038E+01,.3620211E+01,.3758468E+01,& - & .3604385E+01,.3532422E+01,.3543881E+01,.3594866E+01,.3744636E+01,& - & .3597500E+01,.3510559E+01,.3516551E+01,.3567108E+01,.3728771E+01,& - & .3588141E+01,.3486709E+01,.3487212E+01,.3537489E+01,.3711452E+01,& - & .3614294E+01,.3574997E+01,.3596711E+01,.3647701E+01,.3772830E+01,& - & .3611060E+01,.3557018E+01,.3574287E+01,.3625347E+01,.3761707E+01,& - & .3606301E+01,.3537069E+01,.3549260E+01,.3600210E+01,.3747990E+01,& - & .3599986E+01,.3515632E+01,.3522343E+01,.3572792E+01,.3732484E+01,& - & .3590746E+01,.3491810E+01,.3493076E+01,.3543289E+01,.3715323E+01,& - & .3615385E+01,.3578875E+01,.3601241E+01,.3652114E+01,.3775522E+01,& - & .3612653E+01,.3561267E+01,.3579150E+01,.3630121E+01,.3764687E+01,& - & .3608225E+01,.3541594E+01,.3554508E+01,.3605343E+01,.3751304E+01,& - & .3601890E+01,.3520037E+01,.3527598E+01,.3578113E+01,.3735943E+01,& - & .3593282E+01,.3496658E+01,.3498659E+01,.3548727E+01,.3718739E+01,& - & .3616729E+01,.3584234E+01,.3607568E+01,.3658316E+01,.3778888E+01,& - & .3614336E+01,.3567065E+01,.3586083E+01,.3636983E+01,.3768550E+01,& - & .3610281E+01,.3547775E+01,.3561945E+01,.3612790E+01,.3755757E+01,& - & .3604549E+01,.3526723E+01,.3535518E+01,.3586033E+01,.3740710E+01,& - & .3596403E+01,.3503693E+01,.3506997E+01,.3557144E+01,.3724043E+01/ - - data absb(701:875,10) / & - & .3617849E+01,.3589442E+01,.3613858E+01,.3664479E+01,.3782091E+01,& - & .3615818E+01,.3572805E+01,.3592899E+01,.3643677E+01,.3772222E+01,& - & .3612124E+01,.3553880E+01,.3569311E+01,.3620106E+01,.3759976E+01,& - & .3606887E+01,.3533209E+01,.3543433E+01,.3593996E+01,.3745475E+01,& - & .3599450E+01,.3510687E+01,.3515389E+01,.3565549E+01,.3729132E+01,& - & .3618859E+01,.3594390E+01,.3619692E+01,.3670127E+01,.3784822E+01,& - & .3617031E+01,.3578150E+01,.3599460E+01,.3650217E+01,.3775829E+01,& - & .3613773E+01,.3559780E+01,.3576444E+01,.3627182E+01,.3764034E+01,& - & .3609186E+01,.3539677E+01,.3551204E+01,.3601833E+01,.3750137E+01,& - & .3602259E+01,.3517530E+01,.3523661E+01,.3573794E+01,.3734189E+01,& - & .3619642E+01,.3599861E+01,.3626247E+01,.3676465E+01,.3787596E+01,& - & .3618160E+01,.3584226E+01,.3606851E+01,.3657509E+01,.3779539E+01,& - & .3615477E+01,.3566520E+01,.3584677E+01,.3635460E+01,.3768627E+01,& - & .3611247E+01,.3546802E+01,.3559989E+01,.3610646E+01,.3755225E+01,& - & .3605074E+01,.3525201E+01,.3533059E+01,.3583351E+01,.3739819E+01,& - & .3620312E+01,.3605283E+01,.3632856E+01,.3682831E+01,.3790274E+01,& - & .3619186E+01,.3590447E+01,.3614470E+01,.3665009E+01,.3783275E+01,& - & .3616882E+01,.3573318E+01,.3593065E+01,.3643837E+01,.3773166E+01,& - & .3613451E+01,.3554344E+01,.3569198E+01,.3619779E+01,.3760340E+01,& - & .3607869E+01,.3533334E+01,.3542978E+01,.3593388E+01,.3745727E+01,& - & .3620861E+01,.3610352E+01,.3639014E+01,.3688623E+01,.3792389E+01,& - & .3619907E+01,.3596190E+01,.3621534E+01,.3671961E+01,.3786487E+01,& - & .3618144E+01,.3579813E+01,.3601034E+01,.3651766E+01,.3777268E+01,& - & .3615214E+01,.3561501E+01,.3578086E+01,.3628673E+01,.3765343E+01,& - & .3610346E+01,.3541102E+01,.3552515E+01,.3602980E+01,.3751243E+01,& - & .3621171E+01,.3615299E+01,.3645122E+01,.3694327E+01,.3794232E+01,& - & .3620700E+01,.3602063E+01,.3628647E+01,.3678772E+01,.3789342E+01,& - & .3619172E+01,.3586367E+01,.3609119E+01,.3659731E+01,.3781216E+01,& - & .3616635E+01,.3568642E+01,.3586973E+01,.3637668E+01,.3770251E+01,& - & .3612602E+01,.3549063E+01,.3562386E+01,.3612958E+01,.3756942E+01,& - & .3621585E+01,.3620432E+01,.3651384E+01,.3699855E+01,.3795401E+01,& - & .3621229E+01,.3608077E+01,.3635997E+01,.3685814E+01,.3792009E+01,& - & .3620075E+01,.3593269E+01,.3617681E+01,.3668163E+01,.3785187E+01,& - & .3618192E+01,.3576439E+01,.3596584E+01,.3647184E+01,.3775165E+01,& - & .3614853E+01,.3557603E+01,.3572939E+01,.3623466E+01,.3762716E+01/ - - data absb(876:1050,10) / & - & .3621531E+01,.3624874E+01,.3656941E+01,.3704801E+01,.3796091E+01,& - & .3621578E+01,.3613665E+01,.3642948E+01,.3692378E+01,.3794280E+01,& - & .3620925E+01,.3599898E+01,.3625750E+01,.3676030E+01,.3788596E+01,& - & .3619395E+01,.3583738E+01,.3605662E+01,.3656221E+01,.3779663E+01,& - & .3616452E+01,.3565615E+01,.3582989E+01,.3633553E+01,.3768255E+01,& - & .3621699E+01,.3629071E+01,.3661985E+01,.3709070E+01,.3796100E+01,& - & .3621985E+01,.3618898E+01,.3649290E+01,.3698155E+01,.3795661E+01,& - & .3621415E+01,.3605926E+01,.3633265E+01,.3683249E+01,.3791501E+01,& - & .3620359E+01,.3590761E+01,.3614336E+01,.3664785E+01,.3783789E+01,& - & .3618117E+01,.3573457E+01,.3592656E+01,.3643288E+01,.3773301E+01,& - & .3621904E+01,.3632715E+01,.3666350E+01,.3712572E+01,.3795707E+01,& - & .3622024E+01,.3623236E+01,.3654773E+01,.3703040E+01,.3796613E+01,& - & .3621869E+01,.3611272E+01,.3639856E+01,.3689474E+01,.3793663E+01,& - & .3621052E+01,.3597007E+01,.3622051E+01,.3672345E+01,.3787216E+01,& - & .3619289E+01,.3580478E+01,.3601357E+01,.3651927E+01,.3777750E+01,& - & .3621852E+01,.3635792E+01,.3669888E+01,.3715191E+01,.3794554E+01,& - & .3622079E+01,.3627138E+01,.3659507E+01,.3707091E+01,.3796772E+01,& - & .3622144E+01,.3616154E+01,.3645824E+01,.3695017E+01,.3795270E+01,& - & .3621572E+01,.3602644E+01,.3629021E+01,.3679124E+01,.3790058E+01,& - & .3620273E+01,.3586904E+01,.3609375E+01,.3659834E+01,.3781548E+01,& - & .3621524E+01,.3638153E+01,.3672641E+01,.3717019E+01,.3792489E+01,& - & .3622011E+01,.3630710E+01,.3663819E+01,.3710696E+01,.3796596E+01,& - & .3622140E+01,.3620549E+01,.3651350E+01,.3700088E+01,.3796517E+01,& - & .3621964E+01,.3607992E+01,.3635644E+01,.3685439E+01,.3792448E+01,& - & .3620930E+01,.3593051E+01,.3617045E+01,.3667379E+01,.3785155E+01,& - & .3621285E+01,.3640375E+01,.3675144E+01,.3718598E+01,.3790284E+01,& - & .3621997E+01,.3633935E+01,.3667680E+01,.3713679E+01,.3795786E+01,& - & .3622336E+01,.3624705E+01,.3656432E+01,.3704538E+01,.3797068E+01,& - & .3622150E+01,.3612954E+01,.3641755E+01,.3691352E+01,.3794423E+01,& - & .3621542E+01,.3598955E+01,.3624346E+01,.3674512E+01,.3788265E+01,& - & .3620995E+01,.3641953E+01,.3676700E+01,.3719069E+01,.3787249E+01,& - & .3621905E+01,.3636516E+01,.3670740E+01,.3715933E+01,.3794540E+01,& - & .3622165E+01,.3628082E+01,.3660699E+01,.3708147E+01,.3797220E+01,& - & .3622324E+01,.3617255E+01,.3647220E+01,.3696381E+01,.3795917E+01,& - & .3621972E+01,.3604029E+01,.3630657E+01,.3680650E+01,.3790740E+01/ - - data absb(1051:1175,10) / & - & .3620526E+01,.3643008E+01,.3677709E+01,.3719079E+01,.3783909E+01,& - & .3621663E+01,.3638625E+01,.3673147E+01,.3717490E+01,.3792683E+01,& - & .3622181E+01,.3631146E+01,.3664388E+01,.3711198E+01,.3796901E+01,& - & .3622567E+01,.3621247E+01,.3652054E+01,.3700619E+01,.3796719E+01,& - & .3622221E+01,.3608539E+01,.3636273E+01,.3686109E+01,.3792815E+01,& - & .3620197E+01,.3643890E+01,.3678333E+01,.3718665E+01,.3780167E+01,& - & .3621325E+01,.3640368E+01,.3675148E+01,.3718577E+01,.3790537E+01,& - & .3622155E+01,.3633956E+01,.3667672E+01,.3713768E+01,.3796050E+01,& - & .3622497E+01,.3624766E+01,.3656479E+01,.3704595E+01,.3797402E+01,& - & .3622419E+01,.3612956E+01,.3641709E+01,.3691233E+01,.3794545E+01,& - & .3619809E+01,.3644465E+01,.3678494E+01,.3717752E+01,.3775862E+01,& - & .3621149E+01,.3642028E+01,.3676823E+01,.3719299E+01,.3787818E+01,& - & .3621940E+01,.3636328E+01,.3670542E+01,.3715827E+01,.3794751E+01,& - & .3622399E+01,.3627949E+01,.3660463E+01,.3707973E+01,.3797438E+01,& - & .3622573E+01,.3617046E+01,.3646813E+01,.3695952E+01,.3795817E+01,& - & .3619235E+01,.3644575E+01,.3678035E+01,.3716081E+01,.3771129E+01,& - & .3620784E+01,.3643128E+01,.3677789E+01,.3719247E+01,.3784648E+01,& - & .3621727E+01,.3638446E+01,.3672940E+01,.3717422E+01,.3793308E+01,& - & .3622318E+01,.3630870E+01,.3663967E+01,.3710850E+01,.3797063E+01,& - & .3622631E+01,.3620709E+01,.3651341E+01,.3700062E+01,.3796727E+01,& - & .3618949E+01,.3644500E+01,.3677804E+01,.3715402E+01,.3769243E+01,& - & .3620600E+01,.3643472E+01,.3678108E+01,.3719204E+01,.3783320E+01,& - & .3621596E+01,.3639124E+01,.3673749E+01,.3717908E+01,.3792537E+01,& - & .3622327E+01,.3631967E+01,.3665327E+01,.3711976E+01,.3796952E+01,& - & .3622725E+01,.3622155E+01,.3653104E+01,.3701619E+01,.3797027E+01/ - -! --- - data forref(1:4,1:10) / & - & .1100080E-06,.6309120E-06,.3631590E-05,.6168920E-05,.4297090E-05,& - & .7891740E-05,.2174160E-04,.6393930E-04,.4362830E-04,.5262470E-04,& - & .1163410E-03,.2056160E-03,.2156270E-03,.2345220E-03,.2804970E-03,& - & .8386680E-03,.5292830E-03,.6208480E-03,.9355610E-03,.1712520E-02,& - & .2122670E-02,.2185640E-02,.2222270E-02,.1996500E-02,.2911200E-02,& - & .2811680E-02,.2595430E-02,.2101590E-02,.3162490E-02,.3106950E-02,& - & .2795010E-02,.2080760E-02,.3591895E-02,.3399762E-02,.3018810E-02,& - & .1801670E-02,.4302254E-02,.4229914E-02,.3954639E-02,.2291698E-02/ - -! the array selfref contains the coefficient of the water vapor -! self-continuum (including the energy term). the first index -! refers to temperature in 7.2 degree increments. for instance, -! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, -! etc. the second index runs over the g-channel (1 to 10). - - data selfref(1:10,1:10) / & - & .1158870E-03,.9265370E-04,.7407830E-04,.5922700E-04,.4735300E-04,& - & .3785960E-04,.3026940E-04,.2420100E-04,.1934910E-04,.1547000E-04,& - & .4595570E-03,.3819620E-03,.3174690E-03,.2638660E-03,.2193130E-03,& - & .1822830E-03,.1515050E-03,.1259240E-03,.1046620E-03,.8699040E-04,& - & .1668210E-02,.1511030E-02,.1368660E-02,.1239700E-02,.1122900E-02,& - & .1017100E-02,.9212660E-03,.8344630E-03,.7558390E-03,.6846230E-03,& - & .4601750E-02,.4213720E-02,.3858420E-02,.3533070E-02,.3235160E-02,& - & .2962360E-02,.2712570E-02,.2483850E-02,.2274400E-02,.2082620E-02,& - & .1015890E-01,.9247420E-02,.8417720E-02,.7662470E-02,.6974970E-02,& - & .6349170E-02,.5779510E-02,.5260960E-02,.4788930E-02,.4359260E-02,& - & .3280430E-01,.3008530E-01,.2759170E-01,.2530480E-01,.2320750E-01,& - & .2128390E-01,.1951980E-01,.1790200E-01,.1641820E-01,.1505740E-01,& - & .4059360E-01,.3760320E-01,.3483310E-01,.3226710E-01,.2989010E-01,& - & .2768830E-01,.2564860E-01,.2375910E-01,.2200890E-01,.2038760E-01,& - & .4483620E-01,.4138110E-01,.3819230E-01,.3524920E-01,.3253290E-01,& - & .3002590E-01,.2771210E-01,.2557660E-01,.2360560E-01,.2178660E-01,& - & .4836264E-01,.4491932E-01,.4172126E-01,.3875097E-01,.3599212E-01,& - & .3342979E-01,.3105000E-01,.2883953E-01,.2678655E-01,.2487982E-01,& - & .6056851E-01,.5576215E-01,.5133769E-01,.4726472E-01,.4351530E-01,& - & .4006365E-01,.3688611E-01,.3396089E-01,.3126793E-01,.2878878E-01/ - -!........................................! - end module module_radsw_kgb21 ! -!========================================! - - -!========================================! - module module_radsw_kgb22 ! -!........................................! -! -! ********* the original program descriptions ********* ! -! ! -! originally by j.delamere, atmospheric & environmental research. ! -! revision: 2.4 ! -! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2) ! -! reformatted for f90 by jjmorcrette, ecmwf ! -! ! -! this table has been re-generated for reduced number of g-point ! -! by y.t.hou, ncep ! -! ! -! ********* ********* end description ********* ********* ! -! - use machine, only : kind_phys - use module_radsw_parameters, only : NG22 - -! - implicit none -! - private -! - integer, public :: MSA22, MSB22, MSF22, MFR22 - parameter (MSA22=585, MSB22=235, MSF22=10, MFR22=3) - - real (kind=kind_phys), public :: forref(MFR22,NG22), & - & absa(MSA22,NG22), absb(MSB22,NG22), selfref(MSF22,NG22), & - & sfluxref(NG22,9) - -! --- rayleigh extinction coefficient at v = 8000 cm-1. - real (kind=kind_phys), parameter, public :: rayl = 1.54e-08 - -! the array absa(585,NG22) (ka(9,5,13,NG22)) contains absorption coefs at -! the 16 chosen g-values for a range of pressure levels> ~100mb, -! temperatures, and binary species parameters (see taumol.f for definition). -! the first index in the array, js, runs from 1 to 9, and corresponds to -! different values of the binary species parameter. for instance, -! js=1 refers to dry air, js = 2 corresponds to the paramter value 1/8, -! js = 3 corresponds to the parameter value 2/8, etc. the second index -! in the array, jt, which runs from 1 to 5, corresponds to different -! temperatures. more specifically, jt = 3 means that the data are for -! the reference temperature tref for this pressure level, jt = 2 refers -! to tref-15, jt = 1 is for tref-30, jt = 4 is for tref+15, and jt = 5 -! is for tref+30. the third index, jp, runs from 1 to 13 and refers -! to the jpth reference pressure level (see taumol.f for these levels -! in mb). the fourth index, ig, goes from 1 to 2, and indicates -! which g-interval the absorption coefficients are for. - - data absa( 1:180, 1) / & - & .4811305E-05,.6129178E-05,.6975295E-05,.7459097E-05,.7681764E-05,& - & .7669132E-05,.7386319E-05,.6757954E-05,.4773633E-05,.4852970E-05,& - & .6482051E-05,.7514931E-05,.8141914E-05,.8481015E-05,.8536849E-05,& - & .8278644E-05,.7661509E-05,.5661537E-05,.4887964E-05,.6857744E-05,& - & .8089331E-05,.8885017E-05,.9332288E-05,.9453783E-05,.9249515E-05,& - & .8659290E-05,.6666955E-05,.4916026E-05,.7226977E-05,.8662139E-05,& - & .9602646E-05,.1014228E-04,.1032751E-04,.1017396E-04,.9601762E-05,& - & .7631048E-05,.4939202E-05,.7613809E-05,.9263194E-05,.1033860E-04,& - & .1098728E-04,.1125104E-04,.1116365E-04,.1062721E-04,.8702900E-05,& - & .4106730E-05,.5324296E-05,.6058728E-05,.6475552E-05,.6675502E-05,& - & .6660409E-05,.6407153E-05,.5864093E-05,.3937516E-05,.4142531E-05,& - & .5645457E-05,.6543640E-05,.7093457E-05,.7392197E-05,.7432767E-05,& - & .7202851E-05,.6679036E-05,.4695930E-05,.4172412E-05,.5983858E-05,& - & .7068059E-05,.7761470E-05,.8155332E-05,.8259215E-05,.8079259E-05,& - & .7583378E-05,.5569182E-05,.4197861E-05,.6325920E-05,.7598301E-05,& - & .8416188E-05,.8900428E-05,.9074421E-05,.8942307E-05,.8472099E-05,& - & .6440222E-05,.4216312E-05,.6670040E-05,.8121375E-05,.9056370E-05,& - & .9638048E-05,.9875647E-05,.9796244E-05,.9352752E-05,.7315977E-05,& - & .3467259E-05,.4530486E-05,.5130556E-05,.5469514E-05,.5627152E-05,& - & .5606389E-05,.5378296E-05,.4903857E-05,.3080725E-05,.3499079E-05,& - & .4815823E-05,.5557660E-05,.6015497E-05,.6256261E-05,.6280454E-05,& - & .6078238E-05,.5616791E-05,.3711088E-05,.3526114E-05,.5110612E-05,& - & .6012398E-05,.6587675E-05,.6901419E-05,.6980572E-05,.6815694E-05,& - & .6375015E-05,.4396734E-05,.3547696E-05,.5422743E-05,.6499204E-05,& - & .7185087E-05,.7588601E-05,.7739029E-05,.7620329E-05,.7212753E-05,& - & .5186395E-05,.3563976E-05,.5729219E-05,.6960032E-05,.7748552E-05,& - & .8240995E-05,.8448645E-05,.8371310E-05,.7991578E-05,.5921336E-05,& - & .2903406E-05,.3807717E-05,.4284968E-05,.4550532E-05,.4671249E-05,& - & .4645256E-05,.4435665E-05,.4014615E-05,.2368786E-05,.2932650E-05,& - & .4056866E-05,.4656270E-05,.5027012E-05,.5216501E-05,.5228575E-05,& - & .5042545E-05,.4630358E-05,.2886709E-05,.2956965E-05,.4316547E-05,& - & .5055602E-05,.5525523E-05,.5778913E-05,.5837818E-05,.5685140E-05,& - & .5291024E-05,.3454518E-05,.2976066E-05,.4585564E-05,.5471875E-05,& - & .6031035E-05,.6358030E-05,.6472254E-05,.6355066E-05,.5985167E-05,& - & .4072052E-05,.2992113E-05,.4870065E-05,.5900799E-05,.6563641E-05,& - & .6978014E-05,.7155318E-05,.7090308E-05,.6756111E-05,.4779983E-05/ - - data absa(181:315, 1) / & - & .2416301E-05,.3175817E-05,.3551611E-05,.3757653E-05,.3845981E-05,& - & .3806815E-05,.3615925E-05,.3248989E-05,.1807537E-05,.2442982E-05,& - & .3391649E-05,.3872022E-05,.4168023E-05,.4314273E-05,.4308869E-05,& - & .4135096E-05,.3773612E-05,.2229249E-05,.2464689E-05,.3616511E-05,& - & .4219290E-05,.4597739E-05,.4800153E-05,.4835853E-05,.4687880E-05,& - & .4341846E-05,.2697930E-05,.2482346E-05,.3851272E-05,.4579688E-05,& - & .5036754E-05,.5303465E-05,.5384276E-05,.5269123E-05,.4942816E-05,& - & .3211571E-05,.2496958E-05,.4103453E-05,.4953618E-05,.5507193E-05,& - & .5845841E-05,.5983458E-05,.5915896E-05,.5620275E-05,.3806808E-05,& - & .1999899E-05,.2625031E-05,.2915420E-05,.3071867E-05,.3124395E-05,& - & .3072646E-05,.2900498E-05,.2587050E-05,.1352887E-05,.2024083E-05,& - & .2809833E-05,.3188693E-05,.3420314E-05,.3522509E-05,.3496553E-05,& - & .3339109E-05,.3027660E-05,.1693245E-05,.2044050E-05,.3003017E-05,& - & .3487914E-05,.3787092E-05,.3938052E-05,.3945979E-05,.3809484E-05,& - & .3508701E-05,.2075300E-05,.2060639E-05,.3207415E-05,.3796719E-05,& - & .4165268E-05,.4370415E-05,.4417121E-05,.4305496E-05,.4021839E-05,& - & .2497828E-05,.2073109E-05,.3422126E-05,.4107505E-05,.4555166E-05,& - & .4814366E-05,.4903671E-05,.4826510E-05,.4567702E-05,.2956470E-05,& - & .1648342E-05,.2157145E-05,.2379934E-05,.2491203E-05,.2516412E-05,& - & .2455538E-05,.2301740E-05,.2037661E-05,.1000718E-05,.1669893E-05,& - & .2314044E-05,.2612275E-05,.2784581E-05,.2848144E-05,.2810417E-05,& - & .2667632E-05,.2403320E-05,.1271614E-05,.1688235E-05,.2479334E-05,& - & .2867128E-05,.3096477E-05,.3197978E-05,.3188985E-05,.3063442E-05,& - & .2806027E-05,.1579154E-05,.1703269E-05,.2655822E-05,.3129870E-05,& - & .3418130E-05,.3565529E-05,.3589051E-05,.3483463E-05,.3238464E-05,& - & .1922786E-05,.1714256E-05,.2841908E-05,.3397528E-05,.3751189E-05,& - & .3946139E-05,.4003586E-05,.3926825E-05,.3703912E-05,.2299592E-05/ - - data absa(316:450, 1) / & - & .1353974E-05,.1765068E-05,.1932966E-05,.2007855E-05,.2012902E-05,& - & .1948449E-05,.1811997E-05,.1592898E-05,.7335145E-06,.1373071E-05,& - & .1897413E-05,.2129239E-05,.2252513E-05,.2286864E-05,.2242429E-05,& - & .2114952E-05,.1891560E-05,.9471789E-06,.1389649E-05,.2038030E-05,& - & .2344379E-05,.2513362E-05,.2580054E-05,.2558580E-05,.2443905E-05,& - & .2225644E-05,.1192247E-05,.1403159E-05,.2190301E-05,.2568252E-05,& - & .2784775E-05,.2889879E-05,.2895016E-05,.2795830E-05,.2587464E-05,& - & .1469124E-05,.1413141E-05,.2349730E-05,.2797042E-05,.3067316E-05,& - & .3212459E-05,.3245440E-05,.3170497E-05,.2979658E-05,.1775814E-05,& - & .1109176E-05,.1438260E-05,.1560320E-05,.1608170E-05,.1598482E-05,& - & .1534740E-05,.1415276E-05,.1235245E-05,.5310552E-06,.1125890E-05,& - & .1549645E-05,.1724605E-05,.1809358E-05,.1823301E-05,.1775680E-05,& - & .1662906E-05,.1476017E-05,.6978386E-06,.1140697E-05,.1669212E-05,& - & .1904678E-05,.2026271E-05,.2067267E-05,.2037250E-05,.1934040E-05,& - & .1748711E-05,.8911666E-06,.1152696E-05,.1799505E-05,.2093197E-05,& - & .2254146E-05,.2325995E-05,.2316830E-05,.2226050E-05,.2048536E-05,& - & .1112322E-05,.1161759E-05,.1935095E-05,.2286766E-05,.2492651E-05,& - & .2596669E-05,.2611477E-05,.2539447E-05,.2375149E-05,.1359322E-05,& - & .9077717E-06,.1174065E-05,.1263812E-05,.1292739E-05,.1275331E-05,& - & .1215719E-05,.1112922E-05,.9650216E-06,.3899969E-06,.9222425E-06,& - & .1268083E-05,.1400764E-05,.1458340E-05,.1460261E-05,.1413218E-05,& - & .1314688E-05,.1159764E-05,.5200394E-06,.9352421E-06,.1370113E-05,& - & .1550495E-05,.1639021E-05,.1662747E-05,.1629076E-05,.1537446E-05,& - & .1381442E-05,.6733322E-06,.9455894E-06,.1481006E-05,.1708811E-05,& - & .1830099E-05,.1878238E-05,.1861201E-05,.1779442E-05,.1628569E-05,& - & .8501168E-06,.9536626E-06,.1596411E-05,.1872605E-05,.2030381E-05,& - & .2104312E-05,.2107801E-05,.2041174E-05,.1900067E-05,.1049009E-05/ - - data absa(451:585, 1) / & - & .7476406E-06,.9904317E-06,.1070509E-05,.1095431E-05,.1080587E-05,& - & .1030695E-05,.9437084E-06,.8190527E-06,.3284667E-06,.7596122E-06,& - & .1072730E-05,.1188660E-05,.1237753E-05,.1239815E-05,.1198979E-05,& - & .1115702E-05,.9855200E-06,.4385665E-06,.7699182E-06,.1162790E-05,& - & .1317244E-05,.1392618E-05,.1412049E-05,.1383498E-05,.1305642E-05,& - & .1175399E-05,.5683962E-06,.7780771E-06,.1258890E-05,.1452488E-05,& - & .1555737E-05,.1595474E-05,.1580904E-05,.1512840E-05,.1387631E-05,& - & .7175693E-06,.7842272E-06,.1356608E-05,.1593107E-05,.1725648E-05,& - & .1788723E-05,.1792615E-05,.1737571E-05,.1621220E-05,.8851099E-06,& - & .6151816E-06,.8344601E-06,.9039065E-06,.9253730E-06,.9133751E-06,& - & .8709904E-06,.7977024E-06,.6919990E-06,.2763894E-06,.6250011E-06,& - & .9064917E-06,.1005419E-05,.1047668E-05,.1048849E-05,.1014123E-05,& - & .9437407E-06,.8343490E-06,.3694765E-06,.6331236E-06,.9841850E-06,& - & .1115823E-05,.1179325E-05,.1194996E-05,.1170425E-05,.1105130E-05,& - & .9965785E-06,.4789252E-06,.6395688E-06,.1066132E-05,.1231039E-05,& - & .1317746E-05,.1350903E-05,.1338577E-05,.1281845E-05,.1177960E-05,& - & .6042803E-06,.6438610E-06,.1149508E-05,.1350173E-05,.1462385E-05,& - & .1516252E-05,.1519539E-05,.1474251E-05,.1378037E-05,.7447887E-06,& - & .5057177E-06,.7019314E-06,.7608992E-06,.7796527E-06,.7694622E-06,& - & .7335795E-06,.6717508E-06,.5829027E-06,.2320809E-06,.5135675E-06,& - & .7639636E-06,.8482237E-06,.8838364E-06,.8842773E-06,.8547719E-06,& - & .7955572E-06,.7038419E-06,.3103090E-06,.5201276E-06,.8305264E-06,& - & .9421352E-06,.9952533E-06,.1007989E-05,.9869406E-06,.9321635E-06,& - & .8418452E-06,.4021416E-06,.5249168E-06,.9003622E-06,.1040066E-05,& - & .1112264E-05,.1140134E-05,.1130238E-05,.1082715E-05,.9969161E-06,& - & .5069884E-06,.5279947E-06,.9718501E-06,.1141014E-05,.1235721E-05,& - & .1280968E-05,.1284659E-05,.1246723E-05,.1167012E-05,.6247983E-06/ - - data absa( 1:180, 2) / & - & .3134144E-03,.2768907E-03,.2479948E-03,.2249616E-03,.2061518E-03,& - & .1911399E-03,.1804902E-03,.1753720E-03,.1923166E-03,.3125459E-03,& - & .2772983E-03,.2516939E-03,.2326523E-03,.2182683E-03,.2084544E-03,& - & .2037087E-03,.2047079E-03,.2282142E-03,.3117491E-03,.2781161E-03,& - & .2564198E-03,.2417736E-03,.2327659E-03,.2290275E-03,.2305224E-03,& - & .2382043E-03,.2687208E-03,.3110029E-03,.2794674E-03,.2621069E-03,& - & .2527413E-03,.2498662E-03,.2527146E-03,.2610136E-03,.2760286E-03,& - & .3138217E-03,.3102439E-03,.2812588E-03,.2688570E-03,.2657349E-03,& - & .2695233E-03,.2795220E-03,.2951889E-03,.3180254E-03,.3635083E-03,& - & .3250728E-03,.2877719E-03,.2582845E-03,.2339301E-03,.2130875E-03,& - & .1957091E-03,.1821765E-03,.1732917E-03,.1869083E-03,.3243276E-03,& - & .2884264E-03,.2623057E-03,.2418236E-03,.2253898E-03,.2131266E-03,& - & .2052326E-03,.2020436E-03,.2226017E-03,.3236251E-03,.2895634E-03,& - & .2672790E-03,.2513043E-03,.2401735E-03,.2337268E-03,.2318615E-03,& - & .2350471E-03,.2629556E-03,.3229411E-03,.2911957E-03,.2732898E-03,& - & .2627372E-03,.2575851E-03,.2574466E-03,.2622274E-03,.2724290E-03,& - & .3080495E-03,.3222901E-03,.2933218E-03,.2805641E-03,.2761631E-03,& - & .2774714E-03,.2843448E-03,.2963172E-03,.3141300E-03,.3578779E-03,& - & .3356807E-03,.2975818E-03,.2669711E-03,.2405827E-03,.2171280E-03,& - & .1965563E-03,.1793297E-03,.1660515E-03,.1747079E-03,.3350220E-03,& - & .2984105E-03,.2711015E-03,.2483929E-03,.2291853E-03,.2134785E-03,& - & .2014226E-03,.1935279E-03,.2091221E-03,.3343949E-03,.2997564E-03,& - & .2761602E-03,.2578485E-03,.2437572E-03,.2334625E-03,.2271012E-03,& - & .2251640E-03,.2482498E-03,.3338041E-03,.3015868E-03,.2822818E-03,& - & .2693005E-03,.2608828E-03,.2565529E-03,.2565695E-03,.2612161E-03,& - & .2921963E-03,.3332193E-03,.3039287E-03,.2897558E-03,.2827271E-03,& - & .2804955E-03,.2828580E-03,.2898279E-03,.3016339E-03,.3409420E-03,& - & .3450280E-03,.3062487E-03,.2743678E-03,.2459208E-03,.2198163E-03,& - & .1960751E-03,.1752958E-03,.1579201E-03,.1604421E-03,.3444259E-03,& - & .3072374E-03,.2785358E-03,.2535346E-03,.2314569E-03,.2122613E-03,& - & .1962491E-03,.1838764E-03,.1931422E-03,.3438771E-03,.3087236E-03,& - & .2835940E-03,.2628376E-03,.2455747E-03,.2314574E-03,.2207572E-03,& - & .2139307E-03,.2305496E-03,.3433424E-03,.3107056E-03,.2897639E-03,& - & .2741158E-03,.2622176E-03,.2537611E-03,.2490381E-03,.2483736E-03,& - & .2727973E-03,.3428143E-03,.3132078E-03,.2972996E-03,.2873501E-03,& - & .2814114E-03,.2793015E-03,.2811140E-03,.2872362E-03,.3200560E-03/ - - data absa(181:315, 2) / & - & .3531053E-03,.3137584E-03,.2806342E-03,.2502419E-03,.2217600E-03,& - & .1953442E-03,.1713669E-03,.1502203E-03,.1465365E-03,.3525451E-03,& - & .3148795E-03,.2847860E-03,.2576829E-03,.2329973E-03,.2107590E-03,& - & .1912366E-03,.1747357E-03,.1774476E-03,.3520500E-03,.3165091E-03,& - & .2898443E-03,.2668091E-03,.2466298E-03,.2291220E-03,.2146066E-03,& - & .2032519E-03,.2129838E-03,.3515817E-03,.3186337E-03,.2960481E-03,& - & .2778468E-03,.2627291E-03,.2506136E-03,.2416613E-03,.2361063E-03,& - & .2533676E-03,.3511001E-03,.3212433E-03,.3036225E-03,.2908003E-03,& - & .2814464E-03,.2753399E-03,.2725583E-03,.2734290E-03,.2989606E-03,& - & .3599961E-03,.3201297E-03,.2856670E-03,.2533754E-03,.2227636E-03,& - & .1938352E-03,.1668527E-03,.1421432E-03,.1323787E-03,.3595027E-03,& - & .3213444E-03,.2897706E-03,.2605819E-03,.2334763E-03,.2084445E-03,& - & .1855378E-03,.1651107E-03,.1612872E-03,.3590452E-03,.3230619E-03,& - & .2947399E-03,.2694228E-03,.2465064E-03,.2258970E-03,.2076219E-03,& - & .1919813E-03,.1947351E-03,.3586303E-03,.3252517E-03,.3009081E-03,& - & .2801177E-03,.2619774E-03,.2463994E-03,.2333786E-03,.2231210E-03,& - & .2329972E-03,.3581989E-03,.3279250E-03,.3083841E-03,.2926945E-03,& - & .2800511E-03,.2701445E-03,.2629339E-03,.2586312E-03,.2762878E-03,& - & .3658182E-03,.3254390E-03,.2896752E-03,.2557287E-03,.2231665E-03,& - & .1919902E-03,.1623152E-03,.1344214E-03,.1190659E-03,.3653707E-03,& - & .3267289E-03,.2936760E-03,.2626621E-03,.2334132E-03,.2057935E-03,& - & .1798675E-03,.1559010E-03,.1460080E-03,.3649726E-03,.3284984E-03,& - & .2985492E-03,.2711719E-03,.2458593E-03,.2223271E-03,.2006879E-03,& - & .1811555E-03,.1773614E-03,.3645857E-03,.3307244E-03,.3046099E-03,& - & .2814987E-03,.2606681E-03,.2418349E-03,.2250909E-03,.2105867E-03,& - & .2134590E-03,.3642185E-03,.3334525E-03,.3119355E-03,.2937036E-03,& - & .2780069E-03,.2645516E-03,.2532548E-03,.2443282E-03,.2545442E-03/ - - data absa(316:450, 2) / & - & .3706916E-03,.3298152E-03,.2928733E-03,.2574333E-03,.2231173E-03,& - & .1899407E-03,.1579051E-03,.1272072E-03,.1069023E-03,.3702964E-03,& - & .3311594E-03,.2967583E-03,.2641125E-03,.2329078E-03,.2029732E-03,& - & .1743745E-03,.1473211E-03,.1319665E-03,.3699285E-03,.3329585E-03,& - & .3015284E-03,.2723221E-03,.2447616E-03,.2186223E-03,.1939959E-03,& - & .1710321E-03,.1612919E-03,.3695766E-03,.3351892E-03,.3074184E-03,& - & .2822618E-03,.2589063E-03,.2371561E-03,.2170927E-03,.1987943E-03,& - & .1952513E-03,.3692655E-03,.3379605E-03,.3145686E-03,.2940369E-03,& - & .2755227E-03,.2588395E-03,.2438914E-03,.2307984E-03,.2341519E-03,& - & .3747630E-03,.3333819E-03,.2953456E-03,.2585076E-03,.2226014E-03,& - & .1875711E-03,.1534395E-03,.1202799E-03,.9562602E-04,.3743949E-03,& - & .3347353E-03,.2991026E-03,.2649281E-03,.2319014E-03,.1998657E-03,& - & .1688739E-03,.1390792E-03,.1188772E-03,.3740704E-03,.3365341E-03,& - & .3037434E-03,.2727874E-03,.2431388E-03,.2146370E-03,.1873092E-03,& - & .1613140E-03,.1462150E-03,.3737686E-03,.3387595E-03,.3094625E-03,& - & .2823102E-03,.2566053E-03,.2321963E-03,.2091128E-03,.1874298E-03,& - & .1780428E-03,.3734709E-03,.3415160E-03,.3163831E-03,.2936218E-03,& - & .2724956E-03,.2528123E-03,.2345043E-03,.2177162E-03,.2147257E-03,& - & .3781153E-03,.3363497E-03,.2974396E-03,.2595086E-03,.2223300E-03,& - & .1858397E-03,.1500339E-03,.1149605E-03,.8681636E-04,.3777843E-03,& - & .3377331E-03,.3011323E-03,.2657468E-03,.2312660E-03,.1975718E-03,& - & .1646999E-03,.1327485E-03,.1086418E-03,.3774794E-03,.3395301E-03,& - & .3057000E-03,.2733530E-03,.2420489E-03,.2116788E-03,.1822379E-03,& - & .1538334E-03,.1343822E-03,.3772048E-03,.3417633E-03,.3112954E-03,& - & .2825617E-03,.2549956E-03,.2284826E-03,.2030187E-03,.1786623E-03,& - & .1644876E-03,.3769456E-03,.3445443E-03,.3180728E-03,.2935143E-03,& - & .2703103E-03,.2482498E-03,.2273178E-03,.2075828E-03,.1993535E-03/ - - data absa(451:585, 2) / & - & .3807336E-03,.3393314E-03,.3005620E-03,.2626883E-03,.2254498E-03,& - & .1887780E-03,.1527070E-03,.1172356E-03,.8770656E-04,.3804457E-03,& - & .3409096E-03,.3045588E-03,.2692926E-03,.2347827E-03,.2009743E-03,& - & .1678340E-03,.1354561E-03,.1098393E-03,.3801856E-03,.3428944E-03,& - & .3094604E-03,.2773048E-03,.2460506E-03,.2155751E-03,.1858896E-03,& - & .1570450E-03,.1359353E-03,.3799496E-03,.3453641E-03,.3154279E-03,& - & .2869512E-03,.2594977E-03,.2329282E-03,.2072109E-03,.1824185E-03,& - & .1664584E-03,.3797085E-03,.3484177E-03,.3225651E-03,.2983903E-03,& - & .2753339E-03,.2532382E-03,.2320873E-03,.2119269E-03,.2018178E-03,& - & .3829042E-03,.3418780E-03,.3032789E-03,.2654560E-03,.2281697E-03,& - & .1913858E-03,.1550847E-03,.1193084E-03,.8855999E-04,.3826538E-03,& - & .3436246E-03,.3075479E-03,.2723898E-03,.2378998E-03,.2039790E-03,& - & .1706332E-03,.1379197E-03,.1109681E-03,.3824225E-03,.3458050E-03,& - & .3127369E-03,.2807746E-03,.2495908E-03,.2190408E-03,.1891472E-03,& - & .1599572E-03,.1373987E-03,.3822117E-03,.3485078E-03,.3190368E-03,& - & .2908289E-03,.2634888E-03,.2368723E-03,.2109681E-03,.1858311E-03,& - & .1683087E-03,.3819986E-03,.3517908E-03,.3265146E-03,.3026775E-03,& - & .2797758E-03,.2576864E-03,.2363700E-03,.2158850E-03,.2040952E-03,& - & .3846876E-03,.3440378E-03,.3056059E-03,.2678315E-03,.2305157E-03,& - & .1936247E-03,.1571344E-03,.1210869E-03,.8928501E-04,.3844746E-03,& - & .3459486E-03,.3101125E-03,.2750561E-03,.2405776E-03,.2065779E-03,& - & .1730455E-03,.1400443E-03,.1119334E-03,.3842745E-03,.3483142E-03,& - & .3155650E-03,.2837694E-03,.2526251E-03,.2220255E-03,.1919644E-03,& - & .1624719E-03,.1386492E-03,.3840848E-03,.3512033E-03,.3221367E-03,& - & .2941685E-03,.2669103E-03,.2402530E-03,.2142043E-03,.1887786E-03,& - & .1698933E-03,.3839069E-03,.3546918E-03,.3299208E-03,.3063646E-03,& - & .2835973E-03,.2614972E-03,.2400614E-03,.2193165E-03,.2060528E-03/ - -! the array iabsb(235,2) (kb(5,13:59,2)) contains absorption coefs at -! the 16 chosen g-values for a range of pressure levels < ~100mb and -! temperatures. the first index in the array, jt, which runs from 1 to 5, -! corresponds to different temperatures. more specifically, jt = 3 means -! that the data are for the reference temperature tref for this pressure -! level, jt = 2 refers to the temperature tref-15, jt = 1 is for -! tref-30, jt = 4 is for tref+15, and jt = 5 is for tref+30. -! the second index, jp, runs from 13 to 59 and refers to the jpth -! reference pressure level (see taumol.f for the value of these -! pressure levels in mb). the third index, ig, goes from 1 to 2, -! and tells us which g-interval the absorption coefficients are for. - - data absb( 1:120, 1) / & - & .1148431E-07,.1166076E-07,.1181018E-07,.1191914E-07,.1198918E-07,& - & .9447302E-08,.9588853E-08,.9702321E-08,.9781170E-08,.9829657E-08,& - & .7768804E-08,.7881241E-08,.7964406E-08,.8027339E-08,.8064535E-08,& - & .6387323E-08,.6478389E-08,.6541760E-08,.6584671E-08,.6611940E-08,& - & .5258216E-08,.5325260E-08,.5372095E-08,.5406858E-08,.5433075E-08,& - & .4325046E-08,.4376631E-08,.4414720E-08,.4442940E-08,.4468040E-08,& - & .3558904E-08,.3599790E-08,.3631084E-08,.3656572E-08,.3675668E-08,& - & .2928994E-08,.2962935E-08,.2992609E-08,.3011945E-08,.3028560E-08,& - & .2410261E-08,.2440986E-08,.2461561E-08,.2481755E-08,.2502470E-08,& - & .1987605E-08,.2009776E-08,.2031171E-08,.2053325E-08,.2074842E-08,& - & .1638935E-08,.1660456E-08,.1681270E-08,.1702299E-08,.1720110E-08,& - & .1354484E-08,.1373198E-08,.1393541E-08,.1411146E-08,.1425870E-08,& - & .1120107E-08,.1139127E-08,.1154912E-08,.1169427E-08,.1184272E-08,& - & .9286718E-09,.9430320E-09,.9571872E-09,.9708633E-09,.9838995E-09,& - & .7699187E-09,.7826246E-09,.7946201E-09,.8067476E-09,.8192210E-09,& - & .6396450E-09,.6506736E-09,.6618526E-09,.6737570E-09,.6838369E-09,& - & .5326710E-09,.5429777E-09,.5542978E-09,.5638603E-09,.5735975E-09,& - & .4444457E-09,.4553219E-09,.4646430E-09,.4739935E-09,.4848399E-09,& - & .3733850E-09,.3825372E-09,.3906037E-09,.4005917E-09,.4095546E-09,& - & .3137446E-09,.3209559E-09,.3301769E-09,.3382360E-09,.3459685E-09,& - & .2630519E-09,.2710057E-09,.2790274E-09,.2856675E-09,.2926209E-09,& - & .2217405E-09,.2292329E-09,.2353810E-09,.2416136E-09,.2479216E-09,& - & .1867928E-09,.1929235E-09,.1984309E-09,.2043657E-09,.2098748E-09,& - & .1569163E-09,.1620869E-09,.1668054E-09,.1724993E-09,.1773310E-09/ - - data absb(121:235, 1) / & - & .1308096E-09,.1354063E-09,.1397323E-09,.1448444E-09,.1490380E-09,& - & .1091276E-09,.1131669E-09,.1173393E-09,.1217436E-09,.1254286E-09,& - & .9109868E-10,.9461754E-10,.9833961E-10,.1018699E-09,.1054553E-09,& - & .7563445E-10,.7868380E-10,.8193156E-10,.8518848E-10,.8844146E-10,& - & .6263641E-10,.6531415E-10,.6821057E-10,.7108715E-10,.7394727E-10,& - & .5187154E-10,.5419548E-10,.5674107E-10,.5926221E-10,.6180436E-10,& - & .4271996E-10,.4475106E-10,.4699608E-10,.4922324E-10,.5127378E-10,& - & .3507508E-10,.3687109E-10,.3881362E-10,.4074018E-10,.4258146E-10,& - & .2877982E-10,.3031418E-10,.3201489E-10,.3369063E-10,.3530266E-10,& - & .2354780E-10,.2487550E-10,.2632461E-10,.2777491E-10,.2921257E-10,& - & .1917857E-10,.2030852E-10,.2155848E-10,.2281480E-10,.2406339E-10,& - & .1560083E-10,.1657804E-10,.1762140E-10,.1871016E-10,.1980295E-10,& - & .1265679E-10,.1349811E-10,.1439672E-10,.1532257E-10,.1626259E-10,& - & .1025893E-10,.1099795E-10,.1174551E-10,.1253606E-10,.1335795E-10,& - & .8310093E-11,.8943449E-11,.9572090E-11,.1024901E-10,.1095019E-10,& - & .6730157E-11,.7257352E-11,.7793431E-11,.8371987E-11,.8975155E-11,& - & .5435177E-11,.5888298E-11,.6335711E-11,.6830724E-11,.7343180E-11,& - & .4401117E-11,.4770132E-11,.5149810E-11,.5568023E-11,.6001500E-11,& - & .3553186E-11,.3856211E-11,.4189341E-11,.4542349E-11,.4912188E-11,& - & .2869971E-11,.3121146E-11,.3397253E-11,.3695718E-11,.4009005E-11,& - & .2316841E-11,.2524409E-11,.2751777E-11,.3000391E-11,.3264281E-11,& - & .1868320E-11,.2038026E-11,.2227552E-11,.2436194E-11,.2658837E-11,& - & .1531264E-11,.1674283E-11,.1835257E-11,.2010670E-11,.2200480E-11/ - - data absb( 1:120, 2) / & - & .8735620E-05,.8730295E-05,.8725985E-05,.8721791E-05,.8717868E-05,& - & .8768835E-05,.8764701E-05,.8760332E-05,.8756520E-05,.8752933E-05,& - & .8796329E-05,.8792037E-05,.8788589E-05,.8785089E-05,.8781325E-05,& - & .8818502E-05,.8814986E-05,.8812031E-05,.8808408E-05,.8804794E-05,& - & .8836927E-05,.8833555E-05,.8830851E-05,.8827746E-05,.8824444E-05,& - & .8852216E-05,.8849478E-05,.8846711E-05,.8842936E-05,.8839425E-05,& - & .8864508E-05,.8861820E-05,.8858820E-05,.8855571E-05,.8852261E-05,& - & .8874870E-05,.8872004E-05,.8869799E-05,.8866369E-05,.8862109E-05,& - & .8883129E-05,.8880356E-05,.8877848E-05,.8874404E-05,.8870894E-05,& - & .8890022E-05,.8886869E-05,.8884553E-05,.8881040E-05,.8876761E-05,& - & .8894947E-05,.8892776E-05,.8889874E-05,.8886360E-05,.8882208E-05,& - & .8899699E-05,.8896942E-05,.8893922E-05,.8890629E-05,.8886217E-05,& - & .8903090E-05,.8900055E-05,.8897299E-05,.8893628E-05,.8888999E-05,& - & .8905522E-05,.8902992E-05,.8899724E-05,.8895896E-05,.8891197E-05,& - & .8907716E-05,.8904994E-05,.8901656E-05,.8897848E-05,.8892455E-05,& - & .8909085E-05,.8906056E-05,.8903176E-05,.8899099E-05,.8893887E-05,& - & .8910421E-05,.8907592E-05,.8904343E-05,.8899582E-05,.8894302E-05,& - & .8911657E-05,.8908291E-05,.8904615E-05,.8899966E-05,.8893877E-05,& - & .8912045E-05,.8908750E-05,.8904978E-05,.8899891E-05,.8893523E-05,& - & .8912007E-05,.8908554E-05,.8905008E-05,.8899598E-05,.8893271E-05,& - & .8912113E-05,.8908681E-05,.8904415E-05,.8899216E-05,.8892224E-05,& - & .8911996E-05,.8908643E-05,.8903701E-05,.8898193E-05,.8891198E-05,& - & .8912323E-05,.8908424E-05,.8904030E-05,.8897838E-05,.8890898E-05,& - & .8912745E-05,.8908995E-05,.8904478E-05,.8898387E-05,.8891021E-05/ - - data absb(121:235, 2) / & - & .8913438E-05,.8910133E-05,.8905684E-05,.8899336E-05,.8892605E-05,& - & .8914238E-05,.8910808E-05,.8906957E-05,.8900965E-05,.8894403E-05,& - & .8915350E-05,.8911585E-05,.8907534E-05,.8901916E-05,.8895407E-05,& - & .8916208E-05,.8912694E-05,.8909062E-05,.8903707E-05,.8897419E-05,& - & .8916842E-05,.8914357E-05,.8910350E-05,.8905322E-05,.8899560E-05,& - & .8918148E-05,.8915052E-05,.8911721E-05,.8906637E-05,.8901314E-05,& - & .8918763E-05,.8916311E-05,.8912939E-05,.8908528E-05,.8903349E-05,& - & .8919788E-05,.8917267E-05,.8914201E-05,.8910219E-05,.8904947E-05,& - & .8920650E-05,.8918085E-05,.8915570E-05,.8911600E-05,.8907370E-05,& - & .8921233E-05,.8919303E-05,.8916881E-05,.8913302E-05,.8909080E-05,& - & .8922720E-05,.8920411E-05,.8917844E-05,.8914538E-05,.8910801E-05,& - & .8923377E-05,.8921620E-05,.8918941E-05,.8916117E-05,.8912493E-05,& - & .8924238E-05,.8922269E-05,.8920225E-05,.8917590E-05,.8913869E-05,& - & .8925304E-05,.8923279E-05,.8920969E-05,.8918470E-05,.8915390E-05,& - & .8926224E-05,.8924279E-05,.8921984E-05,.8919554E-05,.8916354E-05,& - & .8926896E-05,.8924592E-05,.8922547E-05,.8920115E-05,.8917801E-05,& - & .8927945E-05,.8925423E-05,.8923860E-05,.8921064E-05,.8918600E-05,& - & .8928033E-05,.8926417E-05,.8923949E-05,.8921931E-05,.8919379E-05,& - & .8929706E-05,.8927053E-05,.8924754E-05,.8922728E-05,.8920444E-05,& - & .8929850E-05,.8927620E-05,.8925048E-05,.8923373E-05,.8920887E-05,& - & .8931261E-05,.8928697E-05,.8925909E-05,.8924267E-05,.8921512E-05,& - & .8931652E-05,.8929478E-05,.8926979E-05,.8924651E-05,.8922436E-05,& - & .8932405E-05,.8929827E-05,.8927149E-05,.8924663E-05,.8922710E-05/ - -! --- - data forref(1:3,1: 2) / .8005249E-06,& - & .8929867E-06,.9310644E-06,.2367132E-05,.8712965E-06,.2553141E-06/ - -! the array selfref contains the coefficient of the water vapor -! self-continuum (including the energy term). the first index -! refers to temperature in 7.2 degree increments. for instance, -! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, -! etc. the second index runs over the g-channel (1 to 2). - - data selfref(1:10,1: 2) / & - & .1890754E-03,.1626696E-03,.1404954E-03,.1218179E-03,.1060361E-03,& - & .9265747E-04,.8127769E-04,.7156485E-04,.6324571E-04,.5609450E-04,& - & .1435463E-03,.1416034E-03,.1400831E-03,.1390223E-03,.1384643E-03,& - & .1384633E-03,.1390821E-03,.1403951E-03,.1424925E-03,.1454806E-03/ - -!........................................! - end module module_radsw_kgb22 ! -!========================================! - - -!========================================! - module module_radsw_kgb23 ! -!........................................! -! -! ********* the original program descriptions ********* ! -! ! -! originally by j.delamere, atmospheric & environmental research. ! -! revision: 2.4 ! -! band 23: 8050-12850 cm-1 (low - h2o; high - nothing) ! -! reformatted for f90 by jjmorcrette, ecmwf ! -! ! -! this table has been re-generated for reduced number of g-point ! -! by y.t.hou, ncep ! -! ! -! ********* ********* end description ********* ********* ! -! - use machine, only : kind_phys - use module_radsw_parameters, only : NG23 - -! - implicit none -! - private -! - integer, public :: MSA23, MSF23, MFR23 - parameter (MSA23=65, MSF23=10, MFR23=3) - - real (kind=kind_phys), public :: forref(MFR23,NG23), & - & absa(MSA23,NG23), selfref(MSF23,NG23), rayl(NG23) - -! --- average giver et al. correction factor for this band. - real (kind=kind_phys), parameter, public :: givfac = 1.029 - -! --- rayleigh extinction coefficient at all v - data rayl (1:10) / & - & .5828588E-07,.5935776E-07,.5255710E-07,.4733880E-07,.4174660E-07,& - & .3980970E-07,.4007860E-07,.3674780E-07,.3456143E-07,.3212082E-07/ - -! the array absa(65,NG23) (ka(5,13,NG23)) contains absorption coefs at -! the 16 chosen g-values for a range of pressure levels> ~100mb, -! temperatures, and binary species parameters (see taumol.f for definition). -! the first index in the array, js, runs from 1 to 9, and corresponds to -! different values of the binary species parameter. for instance, -! js=1 refers to dry air, js = 2 corresponds to the paramter value 1/8, -! js = 3 corresponds to the parameter value 2/8, etc. the second index -! in the array, jt, which runs from 1 to 5, corresponds to different -! temperatures. more specifically, jt = 3 means that the data are for -! the reference temperature tref for this pressure level, jt = 2 refers -! to tref-15, jt = 1 is for tref-30, jt = 4 is for tref+15, and jt = 5 -! is for tref+30. the third index, jp, runs from 1 to 13 and refers -! to the jpth reference pressure level (see taumol.f for these levels -! in mb). the fourth index, ig, goes from 1 to 10, and indicates -! which g-interval the absorption coefficients are for. - - data absa( 1: 65, 1) / & - & .4349017E-06,.4470059E-06,.4658775E-06,.4619598E-06,.4690252E-06,& - & .3442571E-06,.3522645E-06,.3709106E-06,.3777774E-06,.3744779E-06,& - & .2678674E-06,.2763444E-06,.2843822E-06,.2996831E-06,.2973083E-06,& - & .2115438E-06,.2202997E-06,.2278028E-06,.2342144E-06,.2458529E-06,& - & .1770743E-06,.1850806E-06,.1926042E-06,.1976887E-06,.2082632E-06,& - & .2400161E-06,.2495213E-06,.2584593E-06,.2672377E-06,.2743845E-06,& - & .2965188E-06,.3124621E-06,.3263585E-06,.3361788E-06,.3465234E-06,& - & .5867176E-06,.6150627E-06,.6378628E-06,.6634773E-06,.6794765E-06,& - & .2613851E-05,.2661762E-05,.2697551E-05,.2717845E-05,.2731026E-05,& - & .4391054E-05,.4625930E-05,.4834719E-05,.5033254E-05,.5183516E-05,& - & .5804333E-05,.6050090E-05,.6263521E-05,.6493135E-05,.6671565E-05,& - & .6793586E-05,.7078673E-05,.7345537E-05,.7567607E-05,.7770683E-05,& - & .7689857E-05,.8029923E-05,.8306724E-05,.8523862E-05,.8740922E-05/ - - data absa( 1: 65, 2) / & - & .1671495E-04,.1698172E-04,.1762477E-04,.1736035E-04,.1748475E-04,& - & .1392235E-04,.1415328E-04,.1470623E-04,.1483132E-04,.1457076E-04,& - & .1145651E-04,.1165559E-04,.1181059E-04,.1229573E-04,.1205623E-04,& - & .9472038E-05,.9654257E-05,.9802561E-05,.9927636E-05,.1031608E-04,& - & .7831263E-05,.7996876E-05,.8135117E-05,.8252891E-05,.8598083E-05,& - & .6358154E-05,.6506960E-05,.6630804E-05,.6734304E-05,.6813372E-05,& - & .5148405E-05,.5280721E-05,.5396333E-05,.5487849E-05,.5553536E-05,& - & .5133743E-05,.5259110E-05,.5361676E-05,.5436170E-05,.5502268E-05,& - & .1218538E-04,.1263140E-04,.1302060E-04,.1326091E-04,.1346663E-04,& - & .4141871E-04,.4267769E-04,.4394235E-04,.4496715E-04,.4594083E-04,& - & .7068660E-04,.7240671E-04,.7377895E-04,.7506963E-04,.7606084E-04,& - & .8723266E-04,.8870892E-04,.9006588E-04,.9131091E-04,.9244792E-04,& - & .9151119E-04,.9291720E-04,.9438789E-04,.9568004E-04,.9699178E-04/ - - data absa( 1: 65, 3) / & - & .8285900E-04,.8481700E-04,.8905600E-04,.8805700E-04,.8941000E-04,& - & .7093700E-04,.7268500E-04,.7679600E-04,.7795500E-04,.7673500E-04,& - & .5987600E-04,.6144800E-04,.6283700E-04,.6629300E-04,.6499600E-04,& - & .5059800E-04,.5205400E-04,.5329300E-04,.5433200E-04,.5733300E-04,& - & .4274200E-04,.4403500E-04,.4516400E-04,.4613400E-04,.4893500E-04,& - & .3576900E-04,.3697500E-04,.3803800E-04,.3891700E-04,.3968100E-04,& - & .2974700E-04,.3082400E-04,.3175600E-04,.3258900E-04,.3331400E-04,& - & .2199400E-04,.2294500E-04,.2378600E-04,.2451700E-04,.2515500E-04,& - & .2229800E-04,.2268800E-04,.2312700E-04,.2380300E-04,.2433500E-04,& - & .8889800E-04,.9128000E-04,.9333300E-04,.9522400E-04,.9629800E-04,& - & .1229900E-03,.1240700E-03,.1253600E-03,.1264200E-03,.1281300E-03,& - & .1453900E-03,.1485100E-03,.1502200E-03,.1515700E-03,.1520400E-03,& - & .1594900E-03,.1623900E-03,.1646700E-03,.1666700E-03,.1680100E-03/ - - data absa( 1: 65, 4) / & - & .2533900E-03,.2599500E-03,.2717000E-03,.2696300E-03,.2741300E-03,& - & .2190800E-03,.2240400E-03,.2352200E-03,.2390200E-03,.2371700E-03,& - & .1861100E-03,.1907600E-03,.1951800E-03,.2050300E-03,.2022200E-03,& - & .1576900E-03,.1621000E-03,.1659700E-03,.1694800E-03,.1781700E-03,& - & .1340200E-03,.1379200E-03,.1415300E-03,.1443400E-03,.1526700E-03,& - & .1139000E-03,.1174300E-03,.1206500E-03,.1231600E-03,.1254300E-03,& - & .9641700E-04,.9961200E-04,.1023300E-03,.1045300E-03,.1065200E-03,& - & .8139500E-04,.8420500E-04,.8634600E-04,.8840600E-04,.9012200E-04,& - & .4777600E-04,.4897100E-04,.4973600E-04,.4991700E-04,.5028900E-04,& - & .1069800E-03,.1081500E-03,.1081700E-03,.1079900E-03,.1085100E-03,& - & .2022000E-03,.2072700E-03,.2124100E-03,.2167500E-03,.2198900E-03,& - & .2347400E-03,.2360100E-03,.2397400E-03,.2438300E-03,.2487600E-03,& - & .2341000E-03,.2380900E-03,.2418500E-03,.2455400E-03,.2495200E-03/ - - data absa( 1: 65, 5) / & - & .6702400E-03,.6802600E-03,.7041900E-03,.7015900E-03,.7108900E-03,& - & .5872900E-03,.5977800E-03,.6209700E-03,.6291200E-03,.6242300E-03,& - & .5096700E-03,.5190000E-03,.5276500E-03,.5479400E-03,.5426600E-03,& - & .4416700E-03,.4500600E-03,.4579300E-03,.4646900E-03,.4833500E-03,& - & .3809600E-03,.3888100E-03,.3957600E-03,.4025900E-03,.4208600E-03,& - & .3281800E-03,.3353900E-03,.3419200E-03,.3482900E-03,.3540500E-03,& - & .2825900E-03,.2894600E-03,.2958400E-03,.3020300E-03,.3074200E-03,& - & .2427300E-03,.2491200E-03,.2554600E-03,.2611000E-03,.2660700E-03,& - & .1993700E-03,.2065300E-03,.2131400E-03,.2196800E-03,.2252000E-03,& - & .1330600E-03,.1333100E-03,.1339300E-03,.1353800E-03,.1361600E-03,& - & .1623600E-03,.1615400E-03,.1618700E-03,.1611300E-03,.1620900E-03,& - & .1787200E-03,.1835500E-03,.1861200E-03,.1879200E-03,.1874500E-03,& - & .1897000E-03,.1938400E-03,.1977300E-03,.2026100E-03,.2037700E-03/ - - data absa( 1: 65, 6) / & - & .1813000E-02,.1830500E-02,.1871600E-02,.1865500E-02,.1881400E-02,& - & .1642000E-02,.1660000E-02,.1700600E-02,.1715600E-02,.1710800E-02,& - & .1468700E-02,.1487000E-02,.1504200E-02,.1542300E-02,.1537600E-02,& - & .1306800E-02,.1324800E-02,.1342100E-02,.1359200E-02,.1396000E-02,& - & .1157400E-02,.1175300E-02,.1192800E-02,.1209700E-02,.1246700E-02,& - & .1016700E-02,.1034200E-02,.1051500E-02,.1068100E-02,.1084000E-02,& - & .8899200E-03,.9066200E-03,.9229900E-03,.9384400E-03,.9534700E-03,& - & .7844500E-03,.8003100E-03,.8163900E-03,.8313100E-03,.8463100E-03,& - & .6981200E-03,.7131200E-03,.7280100E-03,.7422200E-03,.7560500E-03,& - & .3252100E-03,.3383500E-03,.3519400E-03,.3638100E-03,.3759400E-03,& - & .3140600E-03,.3201300E-03,.3245600E-03,.3326100E-03,.3374100E-03,& - & .2813200E-03,.2873200E-03,.2967400E-03,.3050900E-03,.3139300E-03,& - & .2570400E-03,.2631600E-03,.2719500E-03,.2773200E-03,.2890500E-03/ - - data absa( 1: 65, 7) / & - & .6737000E-02,.6787300E-02,.6889600E-02,.6881900E-02,.6926800E-02,& - & .6311100E-02,.6362200E-02,.6462300E-02,.6506000E-02,.6502700E-02,& - & .5883400E-02,.5936100E-02,.5985800E-02,.6081100E-02,.6080600E-02,& - & .5475300E-02,.5530900E-02,.5582300E-02,.5630600E-02,.5722900E-02,& - & .5078100E-02,.5137300E-02,.5189500E-02,.5239100E-02,.5332800E-02,& - & .4679100E-02,.4740800E-02,.4794900E-02,.4847000E-02,.4899300E-02,& - & .4272400E-02,.4338100E-02,.4395100E-02,.4450300E-02,.4506100E-02,& - & .3856800E-02,.3925400E-02,.3984800E-02,.4043100E-02,.4100500E-02,& - & .3565700E-02,.3636200E-02,.3699400E-02,.3760800E-02,.3821500E-02,& - & .3377400E-02,.3450100E-02,.3517100E-02,.3581100E-02,.3645000E-02,& - & .2392300E-02,.2462300E-02,.2526300E-02,.2589000E-02,.2651700E-02,& - & .1695900E-02,.1754200E-02,.1807700E-02,.1861400E-02,.1918700E-02,& - & .1173200E-02,.1223200E-02,.1271200E-02,.1322100E-02,.1367700E-02/ - - data absa( 1: 65, 8) / & - & .1960400E-01,.1969800E-01,.1993800E-01,.1985400E-01,.1995000E-01,& - & .1871400E-01,.1880300E-01,.1903500E-01,.1913100E-01,.1910200E-01,& - & .1767600E-01,.1778500E-01,.1790400E-01,.1818900E-01,.1815600E-01,& - & .1666200E-01,.1677300E-01,.1690800E-01,.1705600E-01,.1730300E-01,& - & .1565500E-01,.1577500E-01,.1594200E-01,.1610300E-01,.1635900E-01,& - & .1469400E-01,.1483800E-01,.1502900E-01,.1520000E-01,.1532000E-01,& - & .1379700E-01,.1395900E-01,.1417400E-01,.1435000E-01,.1447100E-01,& - & .1290200E-01,.1308900E-01,.1331300E-01,.1348900E-01,.1362600E-01,& - & .1189700E-01,.1210500E-01,.1233300E-01,.1251200E-01,.1265600E-01,& - & .1183400E-01,.1207200E-01,.1233100E-01,.1254800E-01,.1272100E-01,& - & .1141600E-01,.1169900E-01,.1196800E-01,.1214100E-01,.1231100E-01,& - & .1077600E-01,.1107000E-01,.1130900E-01,.1150700E-01,.1170200E-01,& - & .9957700E-02,.1026300E-01,.1049200E-01,.1071900E-01,.1095100E-01/ - - data absa( 1: 65, 9) / & - & .3722573E-01,.3735001E-01,.3766995E-01,.3757402E-01,.3768499E-01,& - & .3662238E-01,.3678396E-01,.3719958E-01,.3732433E-01,.3724068E-01,& - & .3562867E-01,.3578960E-01,.3595765E-01,.3640607E-01,.3634033E-01,& - & .3435375E-01,.3454391E-01,.3475193E-01,.3497256E-01,.3549406E-01,& - & .3293358E-01,.3315823E-01,.3338119E-01,.3362894E-01,.3419310E-01,& - & .3144491E-01,.3168016E-01,.3191274E-01,.3218704E-01,.3249824E-01,& - & .2994750E-01,.3018681E-01,.3043038E-01,.3073495E-01,.3106162E-01,& - & .2842901E-01,.2866936E-01,.2893935E-01,.2926623E-01,.2960819E-01,& - & .2613286E-01,.2638746E-01,.2667815E-01,.2703098E-01,.2739097E-01,& - & .2645921E-01,.2674553E-01,.2704316E-01,.2742667E-01,.2777404E-01,& - & .2621020E-01,.2647702E-01,.2689048E-01,.2732045E-01,.2775716E-01,& - & .2539997E-01,.2572727E-01,.2619059E-01,.2665103E-01,.2709386E-01,& - & .2408096E-01,.2452980E-01,.2508382E-01,.2552259E-01,.2603640E-01/ - - data absa( 1: 65,10) / & - & .1157665E+00,.1155684E+00,.1154876E+00,.1152633E+00,.1151482E+00,& - & .1272768E+00,.1270495E+00,.1269626E+00,.1267696E+00,.1265036E+00,& - & .1391213E+00,.1389149E+00,.1387068E+00,.1386130E+00,.1382518E+00,& - & .1505134E+00,.1502913E+00,.1500415E+00,.1497761E+00,.1496606E+00,& - & .1614616E+00,.1612169E+00,.1609519E+00,.1606590E+00,.1605876E+00,& - & .1719962E+00,.1717604E+00,.1715010E+00,.1711819E+00,.1708343E+00,& - & .1820676E+00,.1818515E+00,.1815935E+00,.1812537E+00,.1808999E+00,& - & .1917067E+00,.1915304E+00,.1912634E+00,.1909221E+00,.1905620E+00,& - & .2008731E+00,.2007265E+00,.2004847E+00,.2001356E+00,.1997760E+00,& - & .2030412E+00,.2029033E+00,.2026654E+00,.2022945E+00,.2019604E+00,& - & .2081847E+00,.2080855E+00,.2077116E+00,.2073153E+00,.2068695E+00,& - & .2148279E+00,.2146757E+00,.2142582E+00,.2138204E+00,.2133431E+00,& - & .2225531E+00,.2222204E+00,.2216768E+00,.2212495E+00,.2206397E+00/ - -! --- - data forref(1:3,1:10) / & - & .1709528E-06,.1749320E-06,.2303093E-05,.3273721E-05,.3572838E-05,& - & .7664943E-05,.9640070E-05,.1071100E-04,.1044860E-04,.3027750E-04,& - & .3575300E-04,.3407240E-04,.1024370E-03,.1084750E-03,.1052450E-03,& - & .1460540E-03,.1414900E-03,.1330710E-03,.1639780E-03,.1502080E-03,& - & .1428640E-03,.2204120E-03,.1829430E-03,.1509410E-03,.2312169E-03,& - & .2065332E-03,.1728525E-03,.2740557E-03,.2606475E-03,.2434367E-03/ - -! the array selfref contains the coefficient of the water vapor -! self-continuum (including the energy term). the first index -! refers to temperature in 7.2 degree increments. for instance, -! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, -! etc. the second index runs over the g-channel (1 to 10). - - data selfref(1:10,1:10) / & - & .1042197E-04,.8992829E-05,.7807679E-05,.6819782E-05,.5991772E-05,& - & .5293756E-05,.4701789E-05,.4196660E-05,.3762952E-05,.3388235E-05,& - & .7734423E-04,.6990340E-04,.6317978E-04,.5710393E-04,.5161343E-04,& - & .4665177E-04,.4216797E-04,.3811593E-04,.3445388E-04,.3114436E-04,& - & .2064340E-03,.1874350E-03,.1701850E-03,.1545220E-03,.1403010E-03,& - & .1273880E-03,.1156640E-03,.1050190E-03,.9535400E-04,.8657830E-04,& - & .5906450E-03,.5331090E-03,.4811770E-03,.4343050E-03,.3919980E-03,& - & .3538120E-03,.3193460E-03,.2882380E-03,.2601600E-03,.2348170E-03,& - & .1630290E-02,.1487730E-02,.1357630E-02,.1238910E-02,.1130570E-02,& - & .1031700E-02,.9414830E-03,.8591530E-03,.7840230E-03,.7154620E-03,& - & .2045280E-02,.1892580E-02,.1751280E-02,.1620530E-02,.1499540E-02,& - & .1387580E-02,.1283980E-02,.1188120E-02,.1099410E-02,.1017330E-02,& - & .2105890E-02,.1970780E-02,.1844340E-02,.1726010E-02,.1615280E-02,& - & .1511640E-02,.1414660E-02,.1323900E-02,.1238960E-02,.1159470E-02,& - & .2450980E-02,.2337450E-02,.2229180E-02,.2125920E-02,.2027450E-02,& - & .1933530E-02,.1843970E-02,.1758560E-02,.1677100E-02,.1599410E-02,& - & .2838174E-02,.2668321E-02,.2508780E-02,.2358929E-02,.2218161E-02,& - & .2085920E-02,.1961685E-02,.1844964E-02,.1735293E-02,.1632237E-02,& - & .3679539E-02,.3409274E-02,.3159083E-02,.2927474E-02,.2713037E-02,& - & .2514491E-02,.2330645E-02,.2160398E-02,.2002729E-02,.1856699E-02/ - -!........................................! - end module module_radsw_kgb23 ! -!========================================! - - -!========================================! - module module_radsw_kgb24 ! -!........................................! -! -! ********* the original program descriptions ********* ! -! ! -! originally by j.delamere, atmospheric & environmental research. ! -! revision: 2.4 ! -! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2) ! -! reformatted for f90 by jjmorcrette, ecmwf ! -! ! -! this table has been re-generated for reduced number of g-point ! -! by y.t.hou, ncep ! -! ! -! ********* ********* end description ********* ********* ! -! - use machine, only : kind_phys - use module_radsw_parameters, only : NG24 - -! - implicit none -! - private -! - integer, public :: MSA24, MSB24, MSF24, MFR24, MFX24 - parameter (MSA24=585, MSB24=235, MSF24=10, MFR24=3, MFX24=9) - - real (kind=kind_phys), public :: forref(MFR24,NG24), & - & absa(MSA24,NG24), absb(MSB24,NG24), selfref(MSF24,NG24), & - & abso3a(NG24), abso3b(NG24), rayla(NG24,MFX24), raylb(NG24) - -! --- rayleigh extinction coefficient at all v - data rayla (1: 8,1:9) / .1368516E-06,.1805397E-06,& - & .2243572E-06,.2191201E-06,.1450164E-06,.1344697E-06,.1214120E-06,& - & .1199659E-06,.1672218E-06,.2134978E-06,.1793655E-06,.1624268E-06,& - & .1442232E-06,.1377599E-06,.1214250E-06,.1199661E-06,.1708948E-06,& - & .2099293E-06,.1784014E-06,.1622850E-06,.1458217E-06,.1400260E-06,& - & .1241789E-06,.1199661E-06,.1737959E-06,.2064310E-06,.1785495E-06,& - & .1617341E-06,.1480687E-06,.1414056E-06,.1280616E-06,.1199661E-06,& - & .1751957E-06,.2045877E-06,.1784314E-06,.1614815E-06,.1507242E-06,& - & .1421961E-06,.1320991E-06,.1199661E-06,.1757802E-06,.2032567E-06,& - & .1789106E-06,.1613267E-06,.1525379E-06,.1429132E-06,.1360017E-06,& - & .1204062E-06,.1757127E-06,.2027785E-06,.1790739E-06,.1616034E-06,& - & .1535303E-06,.1446526E-06,.1386231E-06,.1317693E-06,.1746465E-06,& - & .2026682E-06,.1793777E-06,.1632574E-06,.1537427E-06,.1462557E-06,& - & .1419684E-06,.1489889E-06,.1524502E-06,.2170624E-06,.1873095E-06,& - & .1679364E-06,.1595036E-06,.1513078E-06,.1490206E-06,.1492883E-06/ - - data raylb (1: 8) / .1320456E-06,.1720100E-06,.2114786E-06,& - & .2446587E-06,.2048151E-06,.1382257E-06,.1353522E-06,.1198919E-06/ - -! --- o3 - data abso3a(1: 8) / .1300197E+00,.1988798E+00,.1272878E+00,& - & .8885802E-01,.6659378E-01,.5166209E-01,.3931020E-01,.2659650E-01/ - - data abso3b(1: 8) / .3634220E-01,.8528316E-01,.1832493E+00,& - & .2884644E+00,.3568897E+00,.3534033E+00,.1043294E+00,.2575196E-01/ - -! the array absa(585,NG24) (ka(9,5,13,NG24)) contains absorption coefs at -! the 16 chosen g-values for a range of pressure levels> ~100mb, -! temperatures, and binary species parameters (see taumol.f for definition). -! the first index in the array, js, runs from 1 to 9, and corresponds to -! different values of the binary species parameter. for instance, -! js=1 refers to dry air, js = 2 corresponds to the paramter value 1/8, -! js = 3 corresponds to the parameter value 2/8, etc. the second index -! in the array, jt, which runs from 1 to 5, corresponds to different -! temperatures. more specifically, jt = 3 means that the data are for -! the reference temperature tref for this pressure level, jt = 2 refers -! to tref-15, jt = 1 is for tref-30, jt = 4 is for tref+15, and jt = 5 -! is for tref+30. the third index, jp, runs from 1 to 13 and refers -! to the jpth reference pressure level (see taumol.f for these levels -! in mb). the fourth index, ig, goes from 1 to 8, and indicates -! which g-interval the absorption coefficients are for. - - data absa( 1:180, 1) / & - & .9478488E-09,.2006042E-07,.2228363E-07,.2263495E-07,.2547446E-07,& - & .2936576E-07,.3475032E-07,.4537659E-07,.1269078E-07,.9492310E-09,& - & .2077413E-07,.2280572E-07,.2371246E-07,.2688328E-07,.3058537E-07,& - & .3544994E-07,.4495120E-07,.1274292E-07,.1009719E-08,.2560505E-07,& - & .2989703E-07,.3567437E-07,.4195170E-07,.4903334E-07,.5753744E-07,& - & .7103506E-07,.2087177E-07,.1021243E-08,.2157727E-07,.2428543E-07,& - & .2545064E-07,.2876447E-07,.3263409E-07,.3724139E-07,.4541822E-07,& - & .1284090E-07,.1028299E-08,.2206984E-07,.2462863E-07,.2608214E-07,& - & .2944973E-07,.3351924E-07,.3801002E-07,.4608904E-07,.1282141E-07,& - & .1105064E-08,.2024352E-07,.2144429E-07,.2292737E-07,.2205869E-07,& - & .2461858E-07,.2882375E-07,.3780175E-07,.1335949E-07,.1115462E-08,& - & .2242119E-07,.2253968E-07,.2374626E-07,.2336119E-07,.2589110E-07,& - & .2968126E-07,.3712386E-07,.1367759E-07,.1127330E-08,.2593823E-07,& - & .3036245E-07,.3217154E-07,.3601214E-07,.4106337E-07,.4749265E-07,& - & .5871813E-07,.2194477E-07,.1151546E-08,.2687708E-07,.3062911E-07,& - & .3274636E-07,.3661706E-07,.4151034E-07,.4800693E-07,.5860615E-07,& - & .2166646E-07,.1215036E-08,.2423972E-07,.2411833E-07,.2469573E-07,& - & .2645282E-07,.2869316E-07,.3165709E-07,.3778384E-07,.1423468E-07,& - & .1327285E-08,.1823139E-07,.2252831E-07,.2249874E-07,.2224138E-07,& - & .2137212E-07,.2379889E-07,.3066259E-07,.3075095E-07,.1374278E-08,& - & .2003317E-07,.2357640E-07,.2309863E-07,.2282640E-07,.2242184E-07,& - & .2479411E-07,.3108145E-07,.3095887E-07,.1409564E-08,.2175633E-07,& - & .2468093E-07,.2423024E-07,.2334201E-07,.2354485E-07,.2574451E-07,& - & .3082158E-07,.3128347E-07,.1450696E-08,.2746727E-07,.3099897E-07,& - & .3259416E-07,.3329255E-07,.3570574E-07,.3986596E-07,.4846921E-07,& - & .4021097E-07,.1442717E-08,.2412402E-07,.2625917E-07,.2602265E-07,& - & .2512855E-07,.2541577E-07,.2680625E-07,.3103534E-07,.3137157E-07,& - & .1649543E-08,.1970815E-07,.2150649E-07,.2298869E-07,.2180025E-07,& - & .2008423E-07,.1973561E-07,.2448138E-07,.8556873E-07,.1735034E-08,& - & .2060802E-07,.2356664E-07,.2443517E-07,.2299440E-07,.2108029E-07,& - & .2105873E-07,.2549524E-07,.8685059E-07,.1736792E-08,.2188572E-07,& - & .2575240E-07,.2521604E-07,.2423738E-07,.2219800E-07,.2218711E-07,& - & .2606412E-07,.8913315E-07,.1802505E-08,.2311836E-07,.2795390E-07,& - & .2628918E-07,.2520889E-07,.2295160E-07,.2272776E-07,.2590098E-07,& - & .9188038E-07,.1819519E-08,.2703557E-07,.3363986E-07,.3350051E-07,& - & .3297237E-07,.3293271E-07,.3417284E-07,.4007015E-07,.1097390E-06/ - - data absa(181:315, 1) / & - & .2076399E-08,.2299543E-07,.2011683E-07,.2214187E-07,.2287048E-07,& - & .2069490E-07,.1709628E-07,.1987151E-07,.2613410E-06,.2054496E-08,& - & .2464912E-07,.2181049E-07,.2435469E-07,.2449140E-07,.2201224E-07,& - & .1834284E-07,.2047387E-07,.2681452E-06,.2212265E-08,.2619392E-07,& - & .2373276E-07,.2675398E-07,.2535082E-07,.2318480E-07,.1957713E-07,& - & .2126646E-07,.2766404E-06,.2373248E-08,.2771181E-07,.2568041E-07,& - & .2923537E-07,.2639253E-07,.2388604E-07,.2054018E-07,.2213864E-07,& - & .2841552E-06,.2343337E-08,.3064130E-07,.3236485E-07,.3551409E-07,& - & .3395783E-07,.3172537E-07,.3073988E-07,.3350972E-07,.3192722E-06,& - & .2376949E-08,.2980194E-07,.2387416E-07,.2049156E-07,.2087214E-07,& - & .2167267E-07,.1825923E-07,.1653693E-07,.6372515E-06,.2667041E-08,& - & .3135808E-07,.2549292E-07,.2250603E-07,.2333514E-07,.2247609E-07,& - & .1950044E-07,.1700265E-07,.6563665E-06,.2966669E-08,.3250866E-07,& - & .2727873E-07,.2457664E-07,.2584670E-07,.2376895E-07,.2074333E-07,& - & .1753015E-07,.6745009E-06,.3145538E-08,.3465169E-07,.2866168E-07,& - & .2652981E-07,.2797349E-07,.2493029E-07,.2162154E-07,.1839404E-07,& - & .6921558E-06,.3048309E-08,.3670297E-07,.3037871E-07,.2846443E-07,& - & .3043302E-07,.2606580E-07,.2240677E-07,.1923357E-07,.7083018E-06,& - & .2954559E-08,.3887753E-07,.2869351E-07,.2420710E-07,.2014166E-07,& - & .1897808E-07,.1853848E-07,.1389583E-07,.1017915E-05,.3249121E-08,& - & .4105480E-07,.3073517E-07,.2582420E-07,.2186903E-07,.2106748E-07,& - & .1950220E-07,.1466410E-07,.1065309E-05,.3560837E-08,.4307434E-07,& - & .3307124E-07,.2749773E-07,.2349186E-07,.2343715E-07,.2046075E-07,& - & .1541227E-07,.1097022E-05,.3768057E-08,.4535221E-07,.3522003E-07,& - & .2913787E-07,.2516808E-07,.2572932E-07,.2163504E-07,.1608168E-07,& - & .1134264E-05,.4127508E-08,.4772213E-07,.3727530E-07,.3084310E-07,& - & .2724223E-07,.2780339E-07,.2276541E-07,.1676406E-07,.1166442E-05/ - - data absa(316:450, 1) / & - & .3755131E-08,.5425837E-07,.4118146E-07,.2970906E-07,.2360125E-07,& - & .1910884E-07,.1685495E-07,.1393367E-07,.1706962E-05,.3837129E-08,& - & .5684497E-07,.4375453E-07,.3243058E-07,.2577570E-07,.2032717E-07,& - & .1872850E-07,.1474043E-07,.1765060E-05,.4347070E-08,.5965052E-07,& - & .4627956E-07,.3497038E-07,.2747824E-07,.2198991E-07,.2061735E-07,& - & .1576341E-07,.1825492E-05,.4988663E-08,.6165437E-07,.4887741E-07,& - & .3754106E-07,.2965672E-07,.2382663E-07,.2246982E-07,.1698318E-07,& - & .1871583E-05,.5424215E-08,.6390254E-07,.5129696E-07,.3972602E-07,& - & .3163844E-07,.2555544E-07,.2420387E-07,.1814940E-07,.1924155E-05,& - & .4442173E-08,.7197256E-07,.5819392E-07,.4306671E-07,.2953792E-07,& - & .2178359E-07,.1602856E-07,.1525612E-07,.4752921E-05,.5074649E-08,& - & .7446008E-07,.6175165E-07,.4628955E-07,.3209104E-07,.2411698E-07,& - & .1784882E-07,.1645798E-07,.4869510E-05,.5728645E-08,.7723379E-07,& - & .6474879E-07,.4922829E-07,.3503195E-07,.2630379E-07,.1935594E-07,& - & .1753886E-07,.4973365E-05,.6351806E-08,.8000072E-07,.6740072E-07,& - & .5210377E-07,.3796839E-07,.2830818E-07,.2112504E-07,.1881638E-07,& - & .5058268E-05,.6912437E-08,.8315033E-07,.7068889E-07,.5412660E-07,& - & .4056832E-07,.3019131E-07,.2281027E-07,.1946796E-07,.5120717E-05,& - & .6424864E-08,.9702677E-07,.8541300E-07,.6566892E-07,.4587460E-07,& - & .2900504E-07,.1935626E-07,.1385212E-07,.8949001E-05,.7095455E-08,& - & .1023503E-06,.8901069E-07,.7031849E-07,.5021834E-07,.3251464E-07,& - & .2150478E-07,.1541222E-07,.9105756E-05,.7837477E-08,.1065872E-06,& - & .9339944E-07,.7381282E-07,.5418142E-07,.3553682E-07,.2351485E-07,& - & .1667046E-07,.9321311E-05,.8700945E-08,.1108036E-06,.9742466E-07,& - & .7752400E-07,.5759385E-07,.3839799E-07,.2580432E-07,.1788370E-07,& - & .9568035E-05,.9372952E-08,.1149751E-06,.1012313E-06,.8204487E-07,& - & .6076544E-07,.4108120E-07,.2793641E-07,.1911302E-07,.9731271E-05/ - - data absa(451:585, 1) / & - & .8979819E-08,.1058443E-06,.1200210E-06,.9695637E-07,.7036848E-07,& - & .4678128E-07,.2686372E-07,.1541405E-07,.1220035E-04,.9805661E-08,& - & .1118530E-06,.1255675E-06,.1030716E-06,.7739733E-07,.5201243E-07,& - & .2992503E-07,.1670143E-07,.1258780E-04,.1069760E-07,.1173469E-06,& - & .1304830E-06,.1095539E-06,.8282101E-07,.5625194E-07,.3263649E-07,& - & .1827566E-07,.1292889E-04,.1119525E-07,.1227001E-06,.1373018E-06,& - & .1148947E-06,.8789054E-07,.5978610E-07,.3529093E-07,.1964769E-07,& - & .1327840E-04,.1201126E-07,.1273789E-06,.1421903E-06,.1200244E-06,& - & .9264785E-07,.6378835E-07,.3808366E-07,.2094784E-07,.1367923E-04,& - & .9719070E-08,.9999501E-07,.1384487E-06,.1213259E-06,.9225490E-07,& - & .6132161E-07,.3331774E-07,.1686558E-07,.1343339E-04,.1109778E-07,& - & .1062708E-06,.1461547E-06,.1279839E-06,.9860632E-07,.6579031E-07,& - & .3628776E-07,.1826740E-07,.1383474E-04,.1211127E-07,.1133042E-06,& - & .1521046E-06,.1333579E-06,.1044442E-06,.7051604E-07,.3966511E-07,& - & .1978957E-07,.1430481E-04,.1342211E-07,.1191516E-06,.1571868E-06,& - & .1380165E-06,.1093802E-06,.7496750E-07,.4327741E-07,.2126680E-07,& - & .1475217E-04,.1467534E-07,.1241612E-06,.1623203E-06,.1431277E-06,& - & .1135740E-06,.7963856E-07,.4685852E-07,.2271310E-07,.1522177E-04,& - & .1161087E-07,.1041677E-06,.1364162E-06,.1423574E-06,.1160046E-06,& - & .7917598E-07,.4352117E-07,.1902079E-07,.1388023E-04,.1297072E-07,& - & .1100490E-06,.1431349E-06,.1479064E-06,.1210891E-06,.8468921E-07,& - & .4817011E-07,.2075879E-07,.1442933E-04,.1434007E-07,.1155767E-06,& - & .1497075E-06,.1533287E-06,.1261775E-06,.8986500E-07,.5204569E-07,& - & .2239805E-07,.1502654E-04,.1566851E-07,.1199822E-06,.1550418E-06,& - & .1587526E-06,.1308995E-06,.9466747E-07,.5568553E-07,.2384695E-07,& - & .1555344E-04,.1683829E-07,.1243538E-06,.1604785E-06,.1641767E-06,& - & .1360688E-06,.9947999E-07,.5921603E-07,.2546256E-07,.1596362E-04/ - - data absa( 1:180, 2) / & - & .4977875E-08,.2921108E-06,.5418060E-06,.7727212E-06,.9911457E-06,& - & .1214800E-05,.1465814E-05,.1829868E-05,.7823624E-06,.4994907E-08,& - & .3018351E-06,.5578764E-06,.7940989E-06,.1016090E-05,.1239397E-05,& - & .1487931E-05,.1836976E-05,.7862442E-06,.5208110E-08,.3874388E-06,& - & .7181819E-06,.1020477E-05,.1309594E-05,.1599138E-05,.1909038E-05,& - & .2327755E-05,.1153932E-05,.5319118E-08,.3178392E-06,.5822238E-06,& - & .8242852E-06,.1050880E-05,.1277685E-05,.1520218E-05,.1852230E-05,& - & .7871951E-06,.5556151E-08,.3235154E-06,.5911725E-06,.8338245E-06,& - & .1062185E-05,.1291143E-05,.1532737E-05,.1857528E-05,.7845580E-06,& - & .5432943E-08,.2394007E-06,.4471522E-06,.6385952E-06,.8269131E-06,& - & .1017096E-05,.1232743E-05,.1559228E-05,.6244771E-06,.5892629E-08,& - & .2459631E-06,.4597979E-06,.6563874E-06,.8463292E-06,.1038052E-05,& - & .1251153E-05,.1563781E-05,.6288295E-06,.5915709E-08,.3242534E-06,& - & .6031237E-06,.8632595E-06,.1113129E-05,.1365831E-05,.1640492E-05,& - & .2027362E-05,.9462585E-06,.6171888E-08,.3261724E-06,.6054889E-06,& - & .8640996E-06,.1112880E-05,.1361041E-05,.1630551E-05,.2003512E-05,& - & .9272718E-06,.6400658E-08,.2632985E-06,.4872328E-06,.6900240E-06,& - & .8829870E-06,.1077466E-05,.1285821E-05,.1578521E-05,.6307027E-06,& - & .6718273E-08,.1967264E-06,.3613932E-06,.5196750E-06,.6756207E-06,& - & .8399391E-06,.1024899E-05,.1319338E-05,.4959268E-06,.7019662E-08,& - & .2019256E-06,.3715815E-06,.5349054E-06,.6929146E-06,.8570698E-06,& - & .1040099E-05,.1317826E-05,.5026796E-06,.6849002E-08,.2066083E-06,& - & .3800896E-06,.5461625E-06,.7072097E-06,.8714979E-06,.1051566E-05,& - & .1319363E-05,.5066881E-06,.7348552E-08,.2698050E-06,.5015846E-06,& - & .7193981E-06,.9328462E-06,.1147717E-05,.1384165E-05,.1724206E-05,& - & .7547895E-06,.7364360E-08,.2140724E-06,.3941245E-06,.5620667E-06,& - & .7253341E-06,.8905787E-06,.1068093E-05,.1327568E-05,.5107295E-06,& - & .7188660E-08,.1608987E-06,.2919364E-06,.4183428E-06,.5474637E-06,& - & .6862098E-06,.8454628E-06,.1112417E-05,.7753418E-06,.7923510E-08,& - & .1660346E-06,.2994130E-06,.4302319E-06,.5615672E-06,.7001230E-06,& - & .8570141E-06,.1102211E-05,.7947637E-06,.8710415E-08,.1699772E-06,& - & .3051256E-06,.4401873E-06,.5730835E-06,.7124193E-06,.8673643E-06,& - & .1099678E-05,.8076872E-06,.9379724E-08,.1733439E-06,.3101037E-06,& - & .4482693E-06,.5824117E-06,.7220472E-06,.8751372E-06,.1103747E-05,& - & .8157169E-06,.9693296E-08,.2255703E-06,.4099284E-06,.5915659E-06,& - & .7704284E-06,.9518875E-06,.1153151E-05,.1447965E-05,.9509966E-06/ - - data absa(181:315, 2) / & - & .8742219E-08,.1401619E-06,.2365810E-06,.3367232E-06,.4389881E-06,& - & .5544262E-06,.6941176E-06,.9221962E-06,.1547996E-05,.9825526E-08,& - & .1439063E-06,.2438132E-06,.3455625E-06,.4507360E-06,.5666773E-06,& - & .7024141E-06,.9173596E-06,.1577601E-05,.1032729E-07,.1470757E-06,& - & .2492266E-06,.3522677E-06,.4609870E-06,.5767649E-06,.7112768E-06,& - & .9130431E-06,.1601942E-05,.1052928E-07,.1495088E-06,.2530720E-06,& - & .3574969E-06,.4695458E-06,.5854586E-06,.7174989E-06,.9137192E-06,& - & .1618037E-05,.1150457E-07,.1903978E-06,.3372032E-06,.4819982E-06,& - & .6322987E-06,.7870872E-06,.9614418E-06,.1220624E-05,.1804705E-05,& - & .1081727E-07,.1563034E-06,.1929738E-06,.2720043E-06,.3525847E-06,& - & .4442876E-06,.5631051E-06,.7626249E-06,.2334044E-05,.1150244E-07,& - & .1599274E-06,.1989339E-06,.2804224E-06,.3618620E-06,.4559776E-06,& - & .5702232E-06,.7643768E-06,.2382319E-05,.1175189E-07,.1620605E-06,& - & .2044243E-06,.2860895E-06,.3693875E-06,.4646579E-06,.5769806E-06,& - & .7565793E-06,.2416745E-05,.1306718E-07,.1630619E-06,.2085618E-06,& - & .2905226E-06,.3757709E-06,.4717225E-06,.5824128E-06,.7540595E-06,& - & .2439861E-05,.1426020E-07,.1645534E-06,.2117139E-06,.2947798E-06,& - & .3794331E-06,.4775901E-06,.5875284E-06,.7558601E-06,.2466640E-05,& - & .1207434E-07,.1674269E-06,.1791693E-06,.2187708E-06,.2826358E-06,& - & .3574471E-06,.4560189E-06,.6292048E-06,.4950228E-05,.1327450E-07,& - & .1717629E-06,.1844629E-06,.2269350E-06,.2920013E-06,.3674358E-06,& - & .4607900E-06,.6289581E-06,.4970699E-05,.1458123E-07,.1756793E-06,& - & .1880198E-06,.2332289E-06,.2991457E-06,.3736616E-06,.4662710E-06,& - & .6243034E-06,.5001187E-05,.1616738E-07,.1790958E-06,.1914327E-06,& - & .2381938E-06,.3052274E-06,.3787455E-06,.4719405E-06,.6206030E-06,& - & .5028994E-05,.1738758E-07,.1816052E-06,.1943182E-06,.2415142E-06,& - & .3091524E-06,.3827622E-06,.4755721E-06,.6213090E-06,.5041895E-05/ - - data absa(316:450, 2) / & - & .1665196E-07,.1938979E-06,.2113958E-06,.2003810E-06,.2278096E-06,& - & .2865973E-06,.3718779E-06,.5164350E-06,.1076729E-04,.1817122E-07,& - & .1993569E-06,.2175471E-06,.2075727E-06,.2358089E-06,.2950307E-06,& - & .3720816E-06,.5129796E-06,.1080841E-04,.1956687E-07,.2035852E-06,& - & .2222226E-06,.2131321E-06,.2435564E-06,.3019781E-06,.3754017E-06,& - & .5134335E-06,.1082806E-04,.2070597E-07,.2074456E-06,.2260920E-06,& - & .2168666E-06,.2488899E-06,.3073148E-06,.3798904E-06,.5077018E-06,& - & .1084943E-04,.2173248E-07,.2098779E-06,.2294201E-06,.2205251E-06,& - & .2538736E-06,.3118254E-06,.3821669E-06,.5055703E-06,.1085222E-04,& - & .2191248E-07,.2365055E-06,.2390465E-06,.2374263E-06,.2072159E-06,& - & .2312165E-06,.3013057E-06,.4184984E-06,.2723092E-04,.2361382E-07,& - & .2462069E-06,.2472867E-06,.2475309E-06,.2196618E-06,.2383569E-06,& - & .3008372E-06,.4161238E-06,.2736074E-04,.2508833E-07,.2530970E-06,& - & .2541614E-06,.2555112E-06,.2280678E-06,.2448032E-06,.3033101E-06,& - & .4166889E-06,.2760212E-04,.2600366E-07,.2555124E-06,.2601272E-06,& - & .2621345E-06,.2330125E-06,.2502924E-06,.3081806E-06,.4117555E-06,& - & .2781471E-04,.2625556E-07,.2585939E-06,.2658891E-06,.2667422E-06,& - & .2373911E-06,.2553542E-06,.3106119E-06,.4101077E-06,.2799279E-04,& - & .2786381E-07,.2663930E-06,.3136530E-06,.2903642E-06,.2699185E-06,& - & .2154845E-06,.2415255E-06,.3414221E-06,.6623836E-04,.3081478E-07,& - & .2743516E-06,.3245697E-06,.3003308E-06,.2804576E-06,.2242044E-06,& - & .2415067E-06,.3388596E-06,.6704072E-04,.3288814E-07,.2818415E-06,& - & .3322102E-06,.3116516E-06,.2890397E-06,.2345975E-06,.2455989E-06,& - & .3380705E-06,.6784378E-04,.3384756E-07,.2878021E-06,.3383139E-06,& - & .3187847E-06,.2960257E-06,.2435067E-06,.2492429E-06,.3358934E-06,& - & .6873920E-04,.3644271E-07,.2922944E-06,.3431136E-06,.3228649E-06,& - & .3009446E-06,.2515472E-06,.2527789E-06,.3321823E-06,.6964582E-04/ - - data absa(451:585, 2) / & - & .4098843E-07,.3384011E-06,.3624859E-06,.3751623E-06,.3279197E-06,& - & .2825050E-06,.2084273E-06,.2761760E-06,.8850341E-04,.4683147E-07,& - & .3426868E-06,.3709702E-06,.3853158E-06,.3371326E-06,.2929673E-06,& - & .2151462E-06,.2724341E-06,.8924994E-04,.4984644E-07,.3465890E-06,& - & .3781183E-06,.3930485E-06,.3467252E-06,.3026766E-06,.2220474E-06,& - & .2731323E-06,.9000607E-04,.5357426E-07,.3496935E-06,.3823149E-06,& - & .4006097E-06,.3557600E-06,.3109094E-06,.2298146E-06,.2691423E-06,& - & .9077335E-04,.5649178E-07,.3523119E-06,.3864299E-06,.4065303E-06,& - & .3608387E-06,.3158353E-06,.2374848E-06,.2683036E-06,.9190915E-04,& - & .5606804E-07,.3942048E-06,.3696286E-06,.3914481E-06,.3666506E-06,& - & .3045442E-06,.2355668E-06,.2246247E-06,.9830605E-04,.5792873E-07,& - & .3951960E-06,.3767630E-06,.4000468E-06,.3765494E-06,.3169486E-06,& - & .2468239E-06,.2208278E-06,.1003406E-03,.6144867E-07,.3964744E-06,& - & .3840637E-06,.4079564E-06,.3868875E-06,.3269661E-06,.2582322E-06,& - & .2208739E-06,.1013645E-03,.6347446E-07,.3944624E-06,.3901494E-06,& - & .4142722E-06,.3972735E-06,.3364436E-06,.2683503E-06,.2181227E-06,& - & .1025965E-03,.6571022E-07,.3935800E-06,.3934698E-06,.4190604E-06,& - & .4047063E-06,.3426999E-06,.2756876E-06,.2187860E-06,.1036640E-03,& - & .6947980E-07,.4277234E-06,.4260311E-06,.3985021E-06,.3938855E-06,& - & .3382988E-06,.2596779E-06,.1845908E-06,.1007433E-03,.7232340E-07,& - & .4309643E-06,.4284737E-06,.4112915E-06,.4041636E-06,.3526595E-06,& - & .2709767E-06,.1835141E-06,.1027545E-03,.7385675E-07,.4323241E-06,& - & .4337810E-06,.4231404E-06,.4150882E-06,.3638010E-06,.2833177E-06,& - & .1825627E-06,.1048033E-03,.7472322E-07,.4340229E-06,.4375142E-06,& - & .4293950E-06,.4227926E-06,.3709701E-06,.2917057E-06,.1845645E-06,& - & .1071308E-03,.7710708E-07,.4377958E-06,.4436351E-06,.4362045E-06,& - & .4261614E-06,.3773780E-06,.2982907E-06,.1879122E-06,.1086672E-03/ - - data absa( 1:180, 3) / & - & .7885147E-08,.2480177E-05,.4465798E-05,.6288079E-05,.8021775E-05,& - & .9713012E-05,.1149293E-04,.1389792E-04,.9583620E-05,.8337260E-08,& - & .2533549E-05,.4538671E-05,.6376335E-05,.8116846E-05,.9823186E-05,& - & .1160281E-04,.1396043E-04,.9711327E-05,.8347835E-08,.2875505E-05,& - & .5166441E-05,.7269794E-05,.9276602E-05,.1119934E-04,.1322573E-04,& - & .1573805E-04,.1164942E-04,.8341010E-08,.2624899E-05,.4665526E-05,& - & .6527056E-05,.8285471E-05,.9970463E-05,.1177728E-04,.1416190E-04,& - & .9853793E-05,.8441087E-08,.2662384E-05,.4716519E-05,.6584497E-05,& - & .8347227E-05,.1002746E-04,.1181802E-04,.1420893E-04,.9876490E-05,& - & .9538043E-08,.2172518E-05,.3916041E-05,.5520408E-05,.7047709E-05,& - & .8561064E-05,.1016253E-04,.1235053E-04,.8228063E-05,.9896959E-08,& - & .2218811E-05,.3982498E-05,.5600469E-05,.7138336E-05,.8647352E-05,& - & .1025838E-04,.1240949E-04,.8337951E-05,.9725183E-08,.2562004E-05,& - & .4611611E-05,.6497303E-05,.8305798E-05,.1005129E-04,.1190483E-04,& - & .1422914E-04,.1028529E-04,.9815185E-08,.2580610E-05,.4626595E-05,& - & .6503599E-05,.8291966E-05,.1002549E-04,.1185886E-04,.1419713E-04,& - & .1021346E-04,.9353012E-08,.2330951E-05,.4132274E-05,.5770881E-05,& - & .7327013E-05,.8826693E-05,.1043691E-04,.1262749E-04,.8444115E-05,& - & .1055499E-07,.1876951E-05,.3395021E-05,.4794118E-05,.6129975E-05,& - & .7457686E-05,.8897848E-05,.1089769E-04,.6935281E-05,.1082740E-07,& - & .1919857E-05,.3454800E-05,.4863748E-05,.6212902E-05,.7539732E-05,& - & .8988633E-05,.1093165E-04,.7014326E-05,.1237586E-07,.1957445E-05,& - & .3508502E-05,.4924591E-05,.6283591E-05,.7606837E-05,.9064706E-05,& - & .1103621E-04,.7066774E-05,.1310556E-07,.2280479E-05,.4102438E-05,& - & .5774148E-05,.7371455E-05,.8939771E-05,.1061982E-04,.1277638E-04,& - & .8882241E-05,.1381953E-07,.2018379E-05,.3585970E-05,.5012832E-05,& - & .6367746E-05,.7692141E-05,.9142910E-05,.1113079E-04,.7092611E-05,& - & .1302165E-07,.1600407E-05,.2913854E-05,.4120799E-05,.5279357E-05,& - & .6430192E-05,.7712566E-05,.9529299E-05,.5293062E-05,.1389129E-07,& - & .1639258E-05,.2967097E-05,.4184307E-05,.5353035E-05,.6512557E-05,& - & .7798666E-05,.9560399E-05,.5349139E-05,.1483348E-07,.1673536E-05,& - & .3015174E-05,.4237461E-05,.5413790E-05,.6575943E-05,.7862585E-05,& - & .9658800E-05,.5382522E-05,.1563210E-07,.1703299E-05,.3054374E-05,& - & .4280442E-05,.5458053E-05,.6620462E-05,.7906329E-05,.9704216E-05,& - & .5391051E-05,.1599402E-07,.2006384E-05,.3612837E-05,.5084142E-05,& - & .6481925E-05,.7864478E-05,.9387955E-05,.1136686E-04,.7116652E-05/ - - data absa(181:315, 3) / & - & .1759652E-07,.1338435E-05,.2477474E-05,.3510671E-05,.4506288E-05,& - & .5498399E-05,.6620804E-05,.8293824E-05,.3301450E-05,.1839690E-07,& - & .1372726E-05,.2524704E-05,.3567406E-05,.4571892E-05,.5574072E-05,& - & .6701396E-05,.8294132E-05,.3333569E-05,.1844120E-07,.1403022E-05,& - & .2565887E-05,.3614241E-05,.4624775E-05,.5628533E-05,.6758496E-05,& - & .8374936E-05,.3343845E-05,.2053628E-07,.1429066E-05,.2600703E-05,& - & .3651806E-05,.4660425E-05,.5666649E-05,.6798791E-05,.8414165E-05,& - & .3333421E-05,.2112872E-07,.1738328E-05,.3156880E-05,.4451390E-05,& - & .5679788E-05,.6911108E-05,.8277220E-05,.1010231E-04,.4801846E-05,& - & .2138930E-07,.1060078E-05,.2077209E-05,.2959831E-05,.3807513E-05,& - & .4658382E-05,.5629044E-05,.7177701E-05,.5287833E-05,.2197261E-07,& - & .1090324E-05,.2118891E-05,.3009588E-05,.3867726E-05,.4725436E-05,& - & .5702333E-05,.7135044E-05,.5295206E-05,.2370908E-07,.1117799E-05,& - & .2154519E-05,.3051661E-05,.3914248E-05,.4773139E-05,.5753687E-05,& - & .7202983E-05,.5282002E-05,.2418585E-07,.1140836E-05,.2184495E-05,& - & .3085157E-05,.3945767E-05,.4806508E-05,.5792297E-05,.7235984E-05,& - & .5240017E-05,.2563587E-07,.1157256E-05,.2206672E-05,.3110571E-05,& - & .3966388E-05,.4824447E-05,.5812975E-05,.7247817E-05,.5173282E-05,& - & .2761854E-07,.8192162E-06,.1695308E-05,.2467470E-05,.3187895E-05,& - & .3913885E-05,.4745695E-05,.6132573E-05,.8445327E-05,.2791826E-07,& - & .8431674E-06,.1731404E-05,.2511477E-05,.3242547E-05,.3969814E-05,& - & .4810419E-05,.6100692E-05,.8456733E-05,.2941384E-07,.8642535E-06,& - & .1763447E-05,.2547427E-05,.3283616E-05,.4013509E-05,.4856118E-05,& - & .6137849E-05,.8444823E-05,.3093995E-07,.8803612E-06,.1788691E-05,& - & .2576812E-05,.3311827E-05,.4043744E-05,.4889006E-05,.6164513E-05,& - & .8438944E-05,.3175649E-07,.8926786E-06,.1807355E-05,.2599811E-05,& - & .3329744E-05,.4060525E-05,.4908054E-05,.6172563E-05,.8415014E-05/ - - data absa(316:450, 3) / & - & .3594320E-07,.5898798E-06,.1300990E-05,.2005624E-05,.2639841E-05,& - & .3258662E-05,.3970239E-05,.5168834E-05,.1389043E-04,.3842574E-07,& - & .6079368E-06,.1330795E-05,.2043110E-05,.2689852E-05,.3308616E-05,& - & .4024395E-05,.5188513E-05,.1404319E-04,.4003510E-07,.6246941E-06,& - & .1356682E-05,.2074572E-05,.2724323E-05,.3347997E-05,.4066594E-05,& - & .5184194E-05,.1421675E-04,.4109691E-07,.6372206E-06,.1377478E-05,& - & .2099971E-05,.2748886E-05,.3373994E-05,.4094365E-05,.5206120E-05,& - & .1431172E-04,.4160609E-07,.6467677E-06,.1391926E-05,.2119005E-05,& - & .2763924E-05,.3389851E-05,.4111985E-05,.5213753E-05,.1436877E-04,& - & .4460131E-07,.3996422E-06,.9634371E-06,.1535190E-05,.2135126E-05,& - & .2688150E-05,.3299750E-05,.4333189E-05,.2704843E-04,.4831887E-07,& - & .4098677E-06,.9845303E-06,.1564750E-05,.2173466E-05,.2731313E-05,& - & .3343042E-05,.4388007E-05,.2787395E-04,.5033440E-07,.4173500E-06,& - & .1002962E-05,.1587816E-05,.2202008E-05,.2765444E-05,.3380831E-05,& - & .4346875E-05,.2836708E-04,.5144378E-07,.4256035E-06,.1017999E-05,& - & .1606384E-05,.2223268E-05,.2789015E-05,.3404990E-05,.4364321E-05,& - & .2885698E-04,.5376703E-07,.4301287E-06,.1025925E-05,.1621665E-05,& - & .2236412E-05,.2802339E-05,.3420850E-05,.4370319E-05,.2935788E-04,& - & .7159604E-07,.4940214E-06,.6385949E-06,.1108740E-05,.1601203E-05,& - & .2163439E-05,.2727326E-05,.3598975E-05,.4606013E-04,.7586834E-07,& - & .4934774E-06,.6516736E-06,.1132261E-05,.1634648E-05,.2197928E-05,& - & .2762190E-05,.3675388E-05,.4725942E-04,.7940266E-07,.4992704E-06,& - & .6618015E-06,.1146976E-05,.1656272E-05,.2222531E-05,.2791013E-05,& - & .3629707E-05,.4765531E-04,.8216318E-07,.4976479E-06,.6706045E-06,& - & .1160539E-05,.1671805E-05,.2236388E-05,.2810390E-05,.3635786E-05,& - & .4814584E-04,.8519042E-07,.4933370E-06,.6756937E-06,.1170724E-05,& - & .1681781E-05,.2243295E-05,.2821977E-05,.3642627E-05,.4872656E-04/ - - data absa(451:585, 3) / & - & .1081928E-06,.5818788E-06,.6386596E-06,.7432114E-06,.1166448E-05,& - & .1632769E-05,.2234855E-05,.3011606E-05,.5082881E-04,.1059761E-06,& - & .5865974E-06,.6439649E-06,.7553534E-06,.1187103E-05,.1654747E-05,& - & .2252083E-05,.3058057E-05,.5151287E-04,.1087338E-06,.5874771E-06,& - & .6413861E-06,.7655310E-06,.1198176E-05,.1670032E-05,.2266997E-05,& - & .3012908E-05,.5289813E-04,.1114046E-06,.5874841E-06,.6406983E-06,& - & .7727642E-06,.1203345E-05,.1677472E-05,.2275155E-05,.3017584E-05,& - & .5372932E-04,.1149838E-06,.5849412E-06,.6431792E-06,.7741413E-06,& - & .1208047E-05,.1681178E-05,.2276094E-05,.3015110E-05,.5370886E-04,& - & .1308163E-06,.5923091E-06,.7055074E-06,.6422362E-06,.8303543E-06,& - & .1235001E-05,.1751640E-05,.2496860E-05,.5055594E-04,.1362223E-06,& - & .6024702E-06,.7146505E-06,.6458685E-06,.8419302E-06,.1248937E-05,& - & .1758098E-05,.2520128E-05,.4923848E-04,.1383439E-06,.6090485E-06,& - & .7121358E-06,.6578181E-06,.8468564E-06,.1256934E-05,.1760117E-05,& - & .2491841E-05,.5060877E-04,.1418196E-06,.6173069E-06,.7165570E-06,& - & .6647670E-06,.8470868E-06,.1257404E-05,.1760260E-05,.2490114E-05,& - & .5072850E-04,.1467094E-06,.6274341E-06,.7144183E-06,.6594283E-06,& - & .8460663E-06,.1255755E-05,.1758322E-05,.2483648E-05,.5190473E-04,& - & .1679150E-06,.6319279E-06,.7600366E-06,.7654140E-06,.6345031E-06,& - & .8895555E-06,.1341549E-05,.2061106E-05,.5170435E-04,.1687483E-06,& - & .6398709E-06,.7658349E-06,.7599068E-06,.6394553E-06,.8948407E-06,& - & .1341176E-05,.2062854E-05,.5191565E-04,.1856866E-06,.6469542E-06,& - & .7612484E-06,.7510875E-06,.6399811E-06,.8962538E-06,.1338671E-05,& - & .2043994E-05,.5247877E-04,.1946851E-06,.6555257E-06,.7574664E-06,& - & .7531901E-06,.6416353E-06,.8973155E-06,.1338204E-05,.2036318E-05,& - & .5249060E-04,.1959063E-06,.6536393E-06,.7490042E-06,.7486915E-06,& - & .6419812E-06,.8937247E-06,.1335333E-05,.2025525E-05,.5294532E-04/ - - data absa( 1:180, 4) / & - & .1305351E-05,.1815013E-04,.2979305E-04,.3999652E-04,.4905169E-04,& - & .5693488E-04,.6409806E-04,.7177995E-04,.6208906E-04,.1399449E-05,& - & .1830100E-04,.3003956E-04,.4034832E-04,.4948205E-04,.5741995E-04,& - & .6471188E-04,.7264387E-04,.6277389E-04,.1500703E-05,.1907688E-04,& - & .3148533E-04,.4244547E-04,.5212651E-04,.6064266E-04,.6853163E-04,& - & .7718017E-04,.6793589E-04,.1602781E-05,.1859572E-04,.3046861E-04,& - & .4090220E-04,.5010077E-04,.5818133E-04,.6567877E-04,.7391640E-04,& - & .6394695E-04,.1701735E-05,.1874689E-04,.3064865E-04,.4112164E-04,& - & .5031423E-04,.5845409E-04,.6607977E-04,.7447772E-04,.6440095E-04,& - & .1064649E-05,.1659392E-04,.2728440E-04,.3661825E-04,.4488879E-04,& - & .5216469E-04,.5901946E-04,.6679678E-04,.5636200E-04,.1144486E-05,& - & .1674885E-04,.2754084E-04,.3698113E-04,.4529662E-04,.5265143E-04,& - & .5963365E-04,.6763659E-04,.5703090E-04,.1229283E-05,.1755590E-04,& - & .2904804E-04,.3914394E-04,.4801072E-04,.5596306E-04,.6357576E-04,& - & .7232186E-04,.6241105E-04,.1311915E-05,.1765175E-04,.2914597E-04,& - & .3924495E-04,.4810414E-04,.5607476E-04,.6377001E-04,.7264059E-04,& - & .6255768E-04,.1393667E-05,.1719840E-04,.2815613E-04,.3775091E-04,& - & .4611483E-04,.5365819E-04,.6097830E-04,.6951518E-04,.5857723E-04,& - & .8510123E-06,.1505886E-04,.2479646E-04,.3323319E-04,.4067061E-04,& - & .4732001E-04,.5376955E-04,.6151348E-04,.5054458E-04,.9176962E-06,& - & .1522049E-04,.2506909E-04,.3359909E-04,.4107044E-04,.4781093E-04,& - & .5439483E-04,.6241934E-04,.5123952E-04,.9852056E-06,.1537278E-04,& - & .2530125E-04,.3390810E-04,.4140644E-04,.4822544E-04,.5493151E-04,& - & .6311719E-04,.5182421E-04,.1051221E-05,.1616403E-04,.2674998E-04,& - & .3597079E-04,.4404185E-04,.5143084E-04,.5876151E-04,.6767562E-04,& - & .5703403E-04,.1116703E-05,.1566305E-04,.2568848E-04,.3436963E-04,& - & .4192613E-04,.4885053E-04,.5577076E-04,.6434502E-04,.5271676E-04,& - & .6706972E-06,.1356834E-04,.2234016E-04,.2988013E-04,.3652444E-04,& - & .4257018E-04,.4855089E-04,.5610533E-04,.4513334E-04,.7245362E-06,& - & .1373634E-04,.2262553E-04,.3024618E-04,.3692628E-04,.4305715E-04,& - & .4917507E-04,.5705200E-04,.4580726E-04,.7792176E-06,.1389124E-04,& - & .2286472E-04,.3055718E-04,.3727285E-04,.4346813E-04,.4973107E-04,& - & .5777942E-04,.4638437E-04,.8325154E-06,.1403502E-04,.2307317E-04,& - & .3081856E-04,.3756897E-04,.4382456E-04,.5020863E-04,.5845074E-04,& - & .4687437E-04,.8857411E-06,.1481254E-04,.2449491E-04,.3281306E-04,& - & .4013490E-04,.4697409E-04,.5391258E-04,.6287210E-04,.5200378E-04/ - - data absa(181:315, 4) / & - & .5167508E-06,.1213015E-04,.1994761E-04,.2666478E-04,.3257689E-04,& - & .3801490E-04,.4351481E-04,.5071048E-04,.3970568E-04,.5611450E-06,& - & .1230180E-04,.2023486E-04,.2701994E-04,.3297257E-04,.3850691E-04,& - & .4413473E-04,.5168590E-04,.4035843E-04,.6074942E-06,.1245708E-04,& - & .2048237E-04,.2733236E-04,.3332457E-04,.3893535E-04,.4469849E-04,& - & .5243452E-04,.4091681E-04,.6497091E-06,.1260117E-04,.2070243E-04,& - & .2759760E-04,.3363226E-04,.3930008E-04,.4517120E-04,.5311341E-04,& - & .4140540E-04,.6918234E-06,.1342830E-04,.2222680E-04,.2973432E-04,& - & .3639360E-04,.4267235E-04,.4915864E-04,.5781325E-04,.4703066E-04,& - & .3889111E-06,.1075212E-04,.1766146E-04,.2361401E-04,.2885114E-04,& - & .3370300E-04,.3869751E-04,.4540779E-04,.2843576E-04,.4255971E-06,& - & .1092624E-04,.1794903E-04,.2396544E-04,.2925012E-04,.3420204E-04,& - & .3932564E-04,.4642134E-04,.2904572E-04,.4617245E-06,.1108153E-04,& - & .1820339E-04,.2427801E-04,.2960841E-04,.3464423E-04,.3989616E-04,& - & .4717937E-04,.2958696E-04,.4963196E-06,.1122268E-04,.1843067E-04,& - & .2454397E-04,.2992123E-04,.3501424E-04,.4036504E-04,.4787143E-04,& - & .3007661E-04,.5288712E-06,.1136116E-04,.1862698E-04,.2476416E-04,& - & .3018301E-04,.3532236E-04,.4075287E-04,.4844677E-04,.3048386E-04,& - & .2818201E-06,.9454122E-05,.1552584E-04,.2075905E-04,.2537253E-04,& - & .2967483E-04,.3416421E-04,.4036992E-04,.1358631E-04,.3116980E-06,& - & .9630115E-05,.1581178E-04,.2110576E-04,.2577640E-04,.3017903E-04,& - & .3479450E-04,.4135899E-04,.1411977E-04,.3391436E-06,.9785821E-05,& - & .1606901E-04,.2141705E-04,.2613954E-04,.3061951E-04,.3535944E-04,& - & .4214515E-04,.1459742E-04,.3649969E-06,.9929644E-05,.1629735E-04,& - & .2168157E-04,.2645134E-04,.3099353E-04,.3582904E-04,.4283092E-04,& - & .1493885E-04,.3909595E-06,.1006778E-04,.1649654E-04,.2190347E-04,& - & .2671526E-04,.3130880E-04,.3622231E-04,.4340255E-04,.1525050E-04/ - - data absa(316:450, 4) / & - & .1885550E-06,.8237115E-05,.1355115E-04,.1812203E-04,.2216406E-04,& - & .2595910E-04,.2995607E-04,.3567120E-04,.1531929E-04,.2087836E-06,& - & .8413745E-05,.1383332E-04,.1846337E-04,.2256351E-04,.2645687E-04,& - & .3058162E-04,.3655441E-04,.1558368E-04,.2296238E-06,.8571555E-05,& - & .1408726E-04,.1876607E-04,.2292379E-04,.2689093E-04,.3112883E-04,& - & .3737211E-04,.1557312E-04,.2500010E-06,.8719796E-05,.1431412E-04,& - & .1902641E-04,.2323430E-04,.2726681E-04,.3159471E-04,.3804543E-04,& - & .1578427E-04,.2711853E-06,.8859111E-05,.1451202E-04,.1924827E-04,& - & .2349894E-04,.2758553E-04,.3199143E-04,.3860292E-04,.1588112E-04,& - & .1230406E-06,.7071075E-05,.1173600E-04,.1570803E-04,.1922851E-04,& - & .2255710E-04,.2608910E-04,.3126942E-04,.3216989E-04,.1333225E-06,& - & .7245254E-05,.1201186E-04,.1604140E-04,.1961962E-04,.2304330E-04,& - & .2669918E-04,.3205734E-04,.3251376E-04,.1467059E-06,.7408812E-05,& - & .1226050E-04,.1633677E-04,.1997347E-04,.2347166E-04,.2723239E-04,& - & .3289453E-04,.3282901E-04,.1619556E-06,.7561287E-05,.1248084E-04,& - & .1659177E-04,.2028185E-04,.2384470E-04,.2769227E-04,.3354727E-04,& - & .3315058E-04,.1762633E-06,.7701606E-05,.1267408E-04,.1681320E-04,& - & .2054736E-04,.2416501E-04,.2808628E-04,.3409678E-04,.3312584E-04,& - & .1086826E-06,.5647058E-05,.1006035E-04,.1354169E-04,.1659919E-04,& - & .1950529E-04,.2261606E-04,.2728891E-04,.4618372E-04,.1056253E-06,& - & .5824652E-05,.1032706E-04,.1386088E-04,.1697733E-04,.1997451E-04,& - & .2320443E-04,.2799400E-04,.4673866E-04,.1091752E-06,.5977988E-05,& - & .1056852E-04,.1414636E-04,.1732210E-04,.2039088E-04,.2372048E-04,& - & .2879946E-04,.4859587E-04,.1162781E-06,.6130784E-05,.1078173E-04,& - & .1439326E-04,.1762377E-04,.2075664E-04,.2416964E-04,.2942961E-04,& - & .4852916E-04,.1200840E-06,.6274589E-05,.1096931E-04,.1461013E-04,& - & .1788556E-04,.2107397E-04,.2455553E-04,.2995813E-04,.4904614E-04/ - - data absa(451:585, 4) / & - & .1675748E-06,.4418138E-05,.8301726E-05,.1168525E-04,.1439259E-04,& - & .1696072E-04,.1973556E-04,.2395464E-04,.4468651E-04,.1734702E-06,& - & .4573506E-05,.8548681E-05,.1197974E-04,.1474159E-04,.1738826E-04,& - & .2027162E-04,.2462762E-04,.4554179E-04,.1739972E-06,.4723577E-05,& - & .8779827E-05,.1223847E-04,.1505819E-04,.1776729E-04,.2074409E-04,& - & .2535087E-04,.4445044E-04,.1750928E-06,.4863503E-05,.8978592E-05,& - & .1246324E-04,.1533399E-04,.1810410E-04,.2114969E-04,.2591012E-04,& - & .4445933E-04,.1808266E-06,.4993518E-05,.9148942E-05,.1266696E-04,& - & .1557959E-04,.1839978E-04,.2150457E-04,.2639122E-04,.4563702E-04,& - & .2010952E-06,.3480775E-05,.6740064E-05,.9826566E-05,.1239046E-04,& - & .1466668E-04,.1712740E-04,.2092359E-04,.4828846E-04,.2004906E-06,& - & .3617594E-05,.6950190E-05,.1010039E-04,.1271291E-04,.1505595E-04,& - & .1761624E-04,.2155447E-04,.4984876E-04,.2193992E-06,.3747107E-05,& - & .7152981E-05,.1032882E-04,.1300048E-04,.1539966E-04,.1804326E-04,& - & .2217884E-04,.4995284E-04,.2317770E-06,.3868823E-05,.7322475E-05,& - & .1053445E-04,.1325413E-04,.1570896E-04,.1841202E-04,.2268552E-04,& - & .5167058E-04,.2292152E-06,.3975147E-05,.7484804E-05,.1073491E-04,& - & .1348680E-04,.1598438E-04,.1873862E-04,.2312606E-04,.4992244E-04,& - & .2573677E-06,.2629386E-05,.5319732E-05,.7892318E-05,.1048730E-04,& - & .1260461E-04,.1478749E-04,.1816822E-04,.4948787E-04,.2535694E-06,& - & .2751139E-05,.5519585E-05,.8143370E-05,.1078554E-04,.1295471E-04,& - & .1522905E-04,.1876027E-04,.5038619E-04,.2296209E-06,.2871168E-05,& - & .5705427E-05,.8368314E-05,.1104763E-04,.1326931E-04,.1561214E-04,& - & .1930238E-04,.4875010E-04,.2285283E-06,.2976458E-05,.5870383E-05,& - & .8562471E-05,.1128721E-04,.1355655E-04,.1595638E-04,.1975997E-04,& - & .4655490E-04,.2277949E-06,.3086384E-05,.6023967E-05,.8743382E-05,& - & .1150669E-04,.1381686E-04,.1626204E-04,.2015870E-04,.4599833E-04/ - - data absa( 1:180, 5) / & - & .1258379E-03,.1792232E-03,.2263834E-03,.2643095E-03,.2960118E-03,& - & .3236055E-03,.3486226E-03,.3708136E-03,.3537227E-03,.1252867E-03,& - & .1784744E-03,.2256677E-03,.2637463E-03,.2957115E-03,.3235207E-03,& - & .3487202E-03,.3710916E-03,.3547494E-03,.1246492E-03,.1788252E-03,& - & .2273405E-03,.2669495E-03,.3004867E-03,.3297723E-03,.3562380E-03,& - & .3799251E-03,.3658619E-03,.1240169E-03,.1766881E-03,.2240641E-03,& - & .2627788E-03,.2953183E-03,.3234639E-03,.3488432E-03,.3713321E-03,& - & .3567172E-03,.1233679E-03,.1757608E-03,.2232662E-03,.2622089E-03,& - & .2951315E-03,.3234287E-03,.3488259E-03,.3713523E-03,.3576976E-03,& - & .1069251E-03,.1638851E-03,.2111585E-03,.2498003E-03,.2830029E-03,& - & .3120257E-03,.3378034E-03,.3624640E-03,.3424007E-03,.1064316E-03,& - & .1632513E-03,.2106727E-03,.2494364E-03,.2829718E-03,.3122311E-03,& - & .3381458E-03,.3630252E-03,.3438497E-03,.1058739E-03,.1637860E-03,& - & .2127118E-03,.2531195E-03,.2882500E-03,.3190771E-03,.3463354E-03,& - & .3723861E-03,.3557833E-03,.1053157E-03,.1629041E-03,.2119399E-03,& - & .2525668E-03,.2878735E-03,.3188283E-03,.3460548E-03,.3719927E-03,& - & .3563658E-03,.1048030E-03,.1609177E-03,.2089982E-03,.2486370E-03,& - & .2829942E-03,.3129743E-03,.3391967E-03,.3638899E-03,.3480124E-03,& - & .9052393E-04,.1496647E-03,.1963928E-03,.2353138E-03,.2692949E-03,& - & .2994397E-03,.3259337E-03,.3522926E-03,.3288949E-03,.9011012E-04,& - & .1491318E-03,.1961079E-03,.2352015E-03,.2695824E-03,.2999606E-03,& - & .3266081E-03,.3531618E-03,.3308028E-03,.8966771E-04,.1485392E-03,& - & .1958028E-03,.2351815E-03,.2698429E-03,.3005448E-03,.3273009E-03,& - & .3538438E-03,.3326818E-03,.8920657E-04,.1491611E-03,.1980348E-03,& - & .2389898E-03,.2753310E-03,.3075620E-03,.3356528E-03,.3632137E-03,& - & .3449423E-03,.8880078E-04,.1472741E-03,.1951287E-03,.2350641E-03,& - & .2704561E-03,.3016661E-03,.3287211E-03,.3549932E-03,.3361806E-03,& - & .7642425E-04,.1365161E-03,.1822415E-03,.2208431E-03,.2550453E-03,& - & .2857390E-03,.3131524E-03,.3407797E-03,.3140906E-03,.7610890E-04,& - & .1361051E-03,.1821158E-03,.2209982E-03,.2556705E-03,.2866395E-03,& - & .3142723E-03,.3419173E-03,.3164057E-03,.7573557E-04,.1356867E-03,& - & .1820099E-03,.2212242E-03,.2562294E-03,.2875830E-03,.3152966E-03,& - & .3429191E-03,.3186642E-03,.7538404E-04,.1352458E-03,.1818638E-03,& - & .2214386E-03,.2568082E-03,.2884658E-03,.3163349E-03,.3438669E-03,& - & .3207779E-03,.7505591E-04,.1360347E-03,.1841939E-03,.2254174E-03,& - & .2624835E-03,.2957188E-03,.3250526E-03,.3534819E-03,.3333120E-03/ - - data absa(181:315, 5) / & - & .6441960E-04,.1243382E-03,.1686492E-03,.2063321E-03,.2401962E-03,& - & .2709669E-03,.2991358E-03,.3279206E-03,.2981254E-03,.6417820E-04,& - & .1241020E-03,.1687386E-03,.2068102E-03,.2412076E-03,.2722842E-03,& - & .3007606E-03,.3294871E-03,.3009391E-03,.6388399E-04,.1238576E-03,& - & .1687898E-03,.2073172E-03,.2421411E-03,.2736197E-03,.3022572E-03,& - & .3309669E-03,.3036272E-03,.6360964E-04,.1235961E-03,.1688422E-03,& - & .2077864E-03,.2431068E-03,.2749041E-03,.3037508E-03,.3323669E-03,& - & .3061923E-03,.6334715E-04,.1246342E-03,.1715166E-03,.2122785E-03,& - & .2493866E-03,.2829267E-03,.3132804E-03,.3430618E-03,.3198672E-03,& - & .5428305E-04,.1131178E-03,.1555172E-03,.1918587E-03,.2248108E-03,& - & .2552688E-03,.2837909E-03,.3135092E-03,.2808167E-03,.5410275E-04,& - & .1130139E-03,.1558251E-03,.1926789E-03,.2262062E-03,.2569617E-03,& - & .2858483E-03,.3156324E-03,.2840877E-03,.5388978E-04,.1129118E-03,& - & .1560839E-03,.1935035E-03,.2275082E-03,.2586750E-03,.2877475E-03,& - & .3176409E-03,.2872619E-03,.5366157E-04,.1128154E-03,.1563700E-03,& - & .1943089E-03,.2288065E-03,.2603020E-03,.2896110E-03,.3195144E-03,& - & .2902915E-03,.5344784E-04,.1126980E-03,.1566320E-03,.1951184E-03,& - & .2300546E-03,.2619121E-03,.2914792E-03,.3214494E-03,.2932874E-03,& - & .4571342E-04,.1026942E-03,.1428236E-03,.1775296E-03,.2091830E-03,& - & .2387595E-03,.2671739E-03,.2978545E-03,.2594784E-03,.4560282E-04,& - & .1027218E-03,.1433756E-03,.1786580E-03,.2109254E-03,.2408706E-03,& - & .2696813E-03,.3004723E-03,.2634130E-03,.4544692E-04,.1027687E-03,& - & .1438888E-03,.1797866E-03,.2125279E-03,.2429678E-03,.2720358E-03,& - & .3029173E-03,.2670716E-03,.4528151E-04,.1028069E-03,.1444180E-03,& - & .1808751E-03,.2141242E-03,.2449535E-03,.2743172E-03,.3052177E-03,& - & .2706270E-03,.4511742E-04,.1028521E-03,.1449287E-03,.1819408E-03,& - & .2156718E-03,.2468811E-03,.2765286E-03,.3074942E-03,.2741063E-03/ - - data absa(316:450, 5) / & - & .3845347E-04,.9301429E-04,.1306852E-03,.1633456E-03,.1934332E-03,& - & .2218378E-03,.2497592E-03,.2809541E-03,.1575108E-03,.3839587E-04,& - & .9318412E-04,.1314652E-03,.1648012E-03,.1954890E-03,.2243498E-03,& - & .2526899E-03,.2840733E-03,.1617842E-03,.3829010E-04,.9337649E-04,& - & .1322053E-03,.1662204E-03,.1974070E-03,.2268068E-03,.2554975E-03,& - & .2869785E-03,.1663258E-03,.3818495E-04,.9357010E-04,.1329542E-03,& - & .1675979E-03,.1993416E-03,.2291758E-03,.2582113E-03,.2897317E-03,& - & .1701293E-03,.3807196E-04,.9375146E-04,.1336930E-03,.1689218E-03,& - & .2012206E-03,.2314740E-03,.2608244E-03,.2924501E-03,.1741563E-03,& - & .3222272E-04,.8402664E-04,.1190004E-03,.1495500E-03,.1778606E-03,& - & .2048436E-03,.2318785E-03,.2632322E-03,.2491014E-04,.3221362E-04,& - & .8435285E-04,.1199991E-03,.1512485E-03,.1802135E-03,.2077441E-03,& - & .2352663E-03,.2668367E-03,.2569053E-04,.3215953E-04,.8468829E-04,& - & .1209883E-03,.1529182E-03,.1824779E-03,.2105732E-03,.2385311E-03,& - & .2702367E-03,.2701309E-04,.3210851E-04,.8503241E-04,.1219626E-03,& - & .1545750E-03,.1847085E-03,.2133101E-03,.2416857E-03,.2734763E-03,& - & .2805465E-04,.3204318E-04,.8537283E-04,.1229412E-03,.1561853E-03,& - & .1869065E-03,.2159588E-03,.2447099E-03,.2766143E-03,.2860049E-04,& - & .2668365E-04,.7570181E-04,.1080203E-03,.1364318E-03,.1629303E-03,& - & .1883981E-03,.2142724E-03,.2453798E-03,.3073231E-04,.2671397E-04,& - & .7619513E-04,.1092103E-03,.1383829E-03,.1655646E-03,.1916417E-03,& - & .2180830E-03,.2494081E-03,.2860411E-04,.2670321E-04,.7667716E-04,& - & .1104090E-03,.1402846E-03,.1681221E-03,.1948231E-03,.2217702E-03,& - & .2532299E-03,.2852470E-04,.2669101E-04,.7717197E-04,.1115742E-03,& - & .1422043E-03,.1706685E-03,.1979160E-03,.2253063E-03,.2569544E-03,& - & .3387605E-04,.2666179E-04,.7765343E-04,.1127755E-03,.1440858E-03,& - & .1731700E-03,.2008739E-03,.2287122E-03,.2605352E-03,.3169336E-04/ - - data absa(451:585, 5) / & - & .2167692E-04,.6827587E-04,.9836512E-04,.1250201E-03,.1498886E-03,& - & .1739600E-03,.1987214E-03,.2293404E-03,.2440081E-04,.2169387E-04,& - & .6891366E-04,.9974241E-04,.1271668E-03,.1528340E-03,.1776053E-03,& - & .2029862E-03,.2337700E-03,.2638768E-04,.2170600E-04,.6954070E-04,& - & .1011255E-03,.1293455E-03,.1556958E-03,.1811079E-03,.2069944E-03,& - & .2380400E-03,.3200312E-04,.2170812E-04,.7016990E-04,.1025105E-03,& - & .1314880E-03,.1585164E-03,.1844769E-03,.2108627E-03,.2421072E-03,& - & .3275541E-04,.2168923E-04,.7080350E-04,.1038948E-03,.1335789E-03,& - & .1612308E-03,.1877502E-03,.2145673E-03,.2460134E-03,.3270936E-04,& - & .1752912E-04,.6154969E-04,.8955810E-04,.1143831E-03,.1376209E-03,& - & .1602880E-03,.1838222E-03,.2134820E-03,.2872965E-04,.1755385E-04,& - & .6231518E-04,.9115429E-04,.1168314E-03,.1408712E-03,.1642185E-03,& - & .1883638E-03,.2183575E-03,.3183547E-04,.1752199E-04,.6309426E-04,& - & .9273525E-04,.1192604E-03,.1440348E-03,.1680514E-03,.1927365E-03,& - & .2230115E-03,.3077672E-04,.1749575E-04,.6385017E-04,.9430365E-04,& - & .1216307E-03,.1471390E-03,.1717409E-03,.1969541E-03,.2274695E-03,& - & .2312932E-04,.1752070E-04,.6462019E-04,.9584906E-04,.1239388E-03,& - & .1501161E-03,.1753754E-03,.2010501E-03,.2317004E-03,.2383092E-04,& - & .1387461E-04,.5546622E-04,.8152797E-04,.1045929E-03,.1262746E-03,& - & .1474566E-03,.1696496E-03,.1981242E-03,.3139074E-04,.1392397E-04,& - & .5636393E-04,.8334885E-04,.1072746E-03,.1297503E-03,.1516626E-03,& - & .1744739E-03,.2033126E-03,.2572972E-04,.1396545E-04,.5726788E-04,& - & .8511400E-04,.1099575E-03,.1332042E-03,.1557803E-03,.1791529E-03,& - & .2083642E-03,.2669035E-04,.1397377E-04,.5816790E-04,.8688926E-04,& - & .1125444E-03,.1365495E-03,.1597819E-03,.1837038E-03,.2131552E-03,& - & .2848091E-04,.1401956E-04,.5906486E-04,.8860992E-04,.1150938E-03,& - & .1398565E-03,.1638183E-03,.1882562E-03,.2178384E-03,.2719011E-04/ - - data absa( 1:180, 6) / & - & .1127779E-02,.1042084E-02,.1103730E-02,.1177585E-02,.1245882E-02,& - & .1305946E-02,.1334440E-02,.1306277E-02,.1318375E-02,.1125070E-02,& - & .1037761E-02,.1098032E-02,.1171270E-02,.1239267E-02,.1299657E-02,& - & .1328359E-02,.1299803E-02,.1315607E-02,.1123280E-02,.1035695E-02,& - & .1095422E-02,.1170386E-02,.1240633E-02,.1304457E-02,.1337002E-02,& - & .1309998E-02,.1335448E-02,.1122248E-02,.1032813E-02,.1088190E-02,& - & .1159040E-02,.1227090E-02,.1287160E-02,.1316759E-02,.1286817E-02,& - & .1309802E-02,.1121332E-02,.1030797E-02,.1084488E-02,.1154404E-02,& - & .1221682E-02,.1281593E-02,.1311385E-02,.1280520E-02,.1306178E-02,& - & .1019965E-02,.9810459E-03,.1068764E-02,.1149672E-02,.1228423E-02,& - & .1296985E-02,.1342592E-02,.1331587E-02,.1337457E-02,.1017770E-02,& - & .9768453E-03,.1063034E-02,.1145111E-02,.1222358E-02,.1291726E-02,& - & .1337570E-02,.1326202E-02,.1335613E-02,.1016813E-02,.9753083E-03,& - & .1061473E-02,.1145518E-02,.1226142E-02,.1297946E-02,.1347626E-02,& - & .1338886E-02,.1357689E-02,.1015843E-02,.9725487E-03,.1057441E-02,& - & .1140180E-02,.1220522E-02,.1291191E-02,.1340908E-02,.1331183E-02,& - & .1353078E-02,.1015463E-02,.9698700E-03,.1050819E-02,.1130971E-02,& - & .1207619E-02,.1275709E-02,.1322301E-02,.1309378E-02,.1327704E-02,& - & .9119475E-03,.9235847E-03,.1031890E-02,.1126261E-02,.1212118E-02,& - & .1287381E-02,.1346323E-02,.1352648E-02,.1351799E-02,.9104425E-03,& - & .9200649E-03,.1026543E-02,.1122353E-02,.1206597E-02,.1282710E-02,& - & .1341997E-02,.1348233E-02,.1350149E-02,.9096645E-03,.9174474E-03,& - & .1022607E-02,.1117149E-02,.1202222E-02,.1277201E-02,.1337011E-02,& - & .1343242E-02,.1348493E-02,.9088794E-03,.9162707E-03,.1022764E-02,& - & .1119302E-02,.1206504E-02,.1284741E-02,.1348507E-02,.1357512E-02,& - & .1369635E-02,.9088680E-03,.9133197E-03,.1016712E-02,.1109724E-02,& - & .1192813E-02,.1268948E-02,.1329585E-02,.1335432E-02,.1344303E-02,& - & .8030336E-03,.8629808E-03,.9905516E-03,.1102706E-02,.1194581E-02,& - & .1276097E-02,.1344985E-02,.1368489E-02,.1358472E-02,.8020685E-03,& - & .8599499E-03,.9864952E-03,.1098943E-02,.1190085E-02,.1271988E-02,& - & .1340997E-02,.1365627E-02,.1358480E-02,.8014347E-03,.8575084E-03,& - & .9835460E-03,.1094344E-02,.1186524E-02,.1267351E-02,.1337492E-02,& - & .1362554E-02,.1358055E-02,.8012884E-03,.8553201E-03,.9810718E-03,& - & .1090482E-02,.1182154E-02,.1264203E-02,.1334958E-02,.1360018E-02,& - & .1357215E-02,.8017028E-03,.8553036E-03,.9828813E-03,.1094204E-02,& - & .1188558E-02,.1274654E-02,.1347715E-02,.1376787E-02,.1377563E-02/ - - data absa(181:315, 6) / & - & .6989341E-03,.8008136E-03,.9474693E-03,.1073693E-02,.1176718E-02,& - & .1263281E-02,.1337495E-02,.1377174E-02,.1357373E-02,.6982803E-03,& - & .7984718E-03,.9443526E-03,.1071067E-02,.1172943E-02,.1259834E-02,& - & .1334341E-02,.1375767E-02,.1358133E-02,.6978266E-03,.7963865E-03,& - & .9422629E-03,.1067324E-02,.1169642E-02,.1256400E-02,.1331961E-02,& - & .1374337E-02,.1358589E-02,.6981011E-03,.7946817E-03,.9401344E-03,& - & .1064498E-02,.1165906E-02,.1254292E-02,.1329925E-02,.1372816E-02,& - & .1358794E-02,.6987926E-03,.7955223E-03,.9431432E-03,.1070202E-02,& - & .1174838E-02,.1266995E-02,.1345241E-02,.1390924E-02,.1382115E-02,& - & .6011592E-03,.7388959E-03,.9023729E-03,.1040717E-02,.1155626E-02,& - & .1247524E-02,.1326820E-02,.1381148E-02,.1347234E-02,.6009151E-03,& - & .7373240E-03,.9002892E-03,.1038951E-02,.1152565E-02,.1245208E-02,& - & .1324569E-02,.1380312E-02,.1349694E-02,.6008914E-03,.7360400E-03,& - & .8989538E-03,.1035946E-02,.1150472E-02,.1242758E-02,.1323179E-02,& - & .1379317E-02,.1351734E-02,.6017350E-03,.7352405E-03,.8972176E-03,& - & .1033783E-02,.1147905E-02,.1241675E-02,.1321813E-02,.1377843E-02,& - & .1353588E-02,.6024658E-03,.7352400E-03,.8961216E-03,.1032038E-02,& - & .1146289E-02,.1240281E-02,.1320537E-02,.1375799E-02,.1354849E-02,& - & .5131365E-03,.6802953E-03,.8558547E-03,.1004257E-02,.1129015E-02,& - & .1228658E-02,.1311670E-02,.1377495E-02,.1326794E-02,.5128417E-03,& - & .6796430E-03,.8551433E-03,.1003333E-02,.1127459E-02,.1227610E-02,& - & .1310680E-02,.1377165E-02,.1331440E-02,.5128844E-03,.6791129E-03,& - & .8543752E-03,.1001545E-02,.1126702E-02,.1226436E-02,.1310287E-02,& - & .1377210E-02,.1336197E-02,.5138776E-03,.6790044E-03,.8533106E-03,& - & .1000677E-02,.1125665E-02,.1226017E-02,.1310194E-02,.1376877E-02,& - & .1340793E-02,.5148503E-03,.6794602E-03,.8527717E-03,.1000386E-02,& - & .1125230E-02,.1225940E-02,.1310446E-02,.1376564E-02,.1344823E-02/ - - data absa(316:450, 6) / & - & .4354937E-03,.6258347E-03,.8095219E-03,.9652907E-03,.1096244E-02,& - & .1204241E-02,.1290647E-02,.1366018E-02,.1291769E-02,.4351834E-03,& - & .6260531E-03,.8097110E-03,.9658306E-03,.1096299E-02,.1204907E-02,& - & .1291676E-02,.1367386E-02,.1299495E-02,.4354926E-03,.6262211E-03,& - & .8099139E-03,.9655329E-03,.1097699E-02,.1205112E-02,.1292665E-02,& - & .1368366E-02,.1307945E-02,.4366061E-03,.6265142E-03,.8100645E-03,& - & .9659489E-03,.1098184E-02,.1206245E-02,.1294118E-02,.1369694E-02,& - & .1316015E-02,.4374936E-03,.6275003E-03,.8106097E-03,.9669869E-03,& - & .1099303E-02,.1207811E-02,.1295643E-02,.1370889E-02,.1323956E-02,& - & .3685128E-03,.5745214E-03,.7639287E-03,.9223177E-03,.1057771E-02,& - & .1170619E-02,.1261579E-02,.1344082E-02,.3978360E-03,.3683928E-03,& - & .5756454E-03,.7650351E-03,.9248369E-03,.1060206E-02,.1174221E-02,& - & .1265274E-02,.1347856E-02,.4071014E-03,.3688375E-03,.5764859E-03,& - & .7661665E-03,.9267124E-03,.1063374E-02,.1176667E-02,.1268148E-02,& - & .1350882E-02,.4149611E-03,.3697059E-03,.5774958E-03,.7676652E-03,& - & .9288451E-03,.1065840E-02,.1179962E-02,.1271481E-02,.1354201E-02,& - & .4230889E-03,.3705971E-03,.5790606E-03,.7693590E-03,.9312187E-03,& - & .1068730E-02,.1183767E-02,.1275156E-02,.1357593E-02,.4395701E-03,& - & .3118513E-03,.5278670E-03,.7179922E-03,.8762847E-03,.1013004E-02,& - & .1129188E-02,.1225380E-02,.1313014E-02,.2823336E-04,.3119642E-03,& - & .5295040E-03,.7205085E-03,.8810719E-03,.1018490E-02,.1135842E-02,& - & .1231411E-02,.1319687E-02,.2591174E-04,.3123480E-03,.5313833E-03,& - & .7231295E-03,.8852977E-03,.1024173E-02,.1141110E-02,.1237009E-02,& - & .1325493E-02,.2490050E-04,.3131033E-03,.5329730E-03,.7261876E-03,& - & .8890594E-03,.1028824E-02,.1147600E-02,.1243500E-02,.1331641E-02,& - & .2358085E-04,.3141200E-03,.5351677E-03,.7291337E-03,.8933695E-03,& - & .1034263E-02,.1154416E-02,.1249926E-02,.1337840E-02,.1914261E-04/ - - data absa(451:585, 6) / & - & .2645518E-03,.4865074E-03,.6737735E-03,.8307780E-03,.9684326E-03,& - & .1087714E-02,.1187390E-02,.1279536E-02,.3096728E-04,.2646171E-03,& - & .4891259E-03,.6781457E-03,.8380014E-03,.9763776E-03,.1095878E-02,& - & .1195388E-02,.1287784E-02,.1937897E-04,.2653275E-03,.4912812E-03,& - & .6826723E-03,.8439569E-03,.9843890E-03,.1104414E-02,.1204820E-02,& - & .1296209E-02,.2310672E-04,.2660999E-03,.4938062E-03,.6869132E-03,& - & .8501984E-03,.9923360E-03,.1114850E-02,.1214879E-02,.1305902E-02,& - & .1551854E-04,.2672744E-03,.4963201E-03,.6913518E-03,.8568207E-03,& - & .1001054E-02,.1124616E-02,.1224913E-02,.1315531E-02,.1902280E-04,& - & .2249381E-03,.4491543E-03,.6314125E-03,.7873093E-03,.9244395E-03,& - & .1044841E-02,.1147218E-02,.1242720E-02,.1795873E-04,.2253436E-03,& - & .4522769E-03,.6374135E-03,.7959199E-03,.9349022E-03,.1056532E-02,& - & .1159671E-02,.1253800E-02,.3013456E-04,.2260901E-03,.4552587E-03,& - & .6435905E-03,.8039747E-03,.9457286E-03,.1069229E-02,.1173356E-02,& - & .1266548E-02,.1199840E-04,.2269143E-03,.4587430E-03,.6495108E-03,& - & .8129332E-03,.9570070E-03,.1082883E-02,.1186741E-02,.1279448E-02,& - & .1794789E-04,.2280730E-03,.4618575E-03,.6559639E-03,.8219928E-03,& - & .9685634E-03,.1095437E-02,.1200070E-02,.1292864E-02,.3604270E-04,& - & .1921277E-03,.4151006E-03,.5920383E-03,.7457881E-03,.8813168E-03,& - & .1001800E-02,.1105493E-02,.1202692E-02,.2297239E-04,.1928316E-03,& - & .4191322E-03,.5996165E-03,.7563148E-03,.8956200E-03,.1018058E-02,& - & .1123450E-02,.1218805E-02,.7650963E-05,.1934147E-03,.4229466E-03,& - & .6073039E-03,.7668297E-03,.9096828E-03,.1035442E-02,.1141697E-02,& - & .1235773E-02,.1552682E-04,.1943616E-03,.4270842E-03,.6149144E-03,& - & .7783265E-03,.9240174E-03,.1052153E-02,.1158854E-02,.1252683E-02,& - & .1480436E-06,.1954216E-03,.4310524E-03,.6232033E-03,.7895004E-03,& - & .9380216E-03,.1067280E-02,.1175445E-02,.1269539E-02,.1885871E-06/ - - data absa( 1:180, 7) / & - & .6726057E-02,.5885484E-02,.5089667E-02,.4459280E-02,.3971837E-02,& - & .3599783E-02,.3258569E-02,.2761804E-02,.3295159E-02,.6741033E-02,& - & .5898281E-02,.5098508E-02,.4461017E-02,.3965454E-02,.3586408E-02,& - & .3239758E-02,.2739181E-02,.3264504E-02,.6753803E-02,.5909939E-02,& - & .5108959E-02,.4465734E-02,.3967543E-02,.3586504E-02,.3237724E-02,& - & .2736408E-02,.3262274E-02,.6761981E-02,.5916777E-02,.5112425E-02,& - & .4461186E-02,.3950994E-02,.3560504E-02,.3206228E-02,.2700475E-02,& - & .3204452E-02,.6766641E-02,.5920869E-02,.5113796E-02,.4457946E-02,& - & .3942736E-02,.3547005E-02,.3190693E-02,.2682249E-02,.3178026E-02,& - & .6602172E-02,.5776872E-02,.5061456E-02,.4534366E-02,.4128541E-02,& - & .3833906E-02,.3516765E-02,.3008287E-02,.3509874E-02,.6617721E-02,& - & .5790525E-02,.5069114E-02,.4531714E-02,.4120691E-02,.3818183E-02,& - & .3497546E-02,.2984974E-02,.3478859E-02,.6628661E-02,.5799925E-02,& - & .5076114E-02,.4533842E-02,.4120334E-02,.3817738E-02,.3496943E-02,& - & .2984746E-02,.3479524E-02,.6637051E-02,.5807576E-02,.5078438E-02,& - & .4529659E-02,.4109342E-02,.3801331E-02,.3478883E-02,.2965136E-02,& - & .3448943E-02,.6644129E-02,.5813792E-02,.5079055E-02,.4521155E-02,& - & .4092528E-02,.3771957E-02,.3445403E-02,.2926792E-02,.3395993E-02,& - & .6403543E-02,.5608393E-02,.4995394E-02,.4569211E-02,.4267045E-02,& - & .4052917E-02,.3769832E-02,.3262352E-02,.3718785E-02,.6418428E-02,& - & .5620905E-02,.5000985E-02,.4564662E-02,.4256975E-02,.4036131E-02,& - & .3749359E-02,.3237816E-02,.3690475E-02,.6431526E-02,.5631313E-02,& - & .5004466E-02,.4561740E-02,.4245515E-02,.4020306E-02,.3730187E-02,& - & .3216366E-02,.3662511E-02,.6443000E-02,.5641170E-02,.5008963E-02,& - & .4562706E-02,.4244648E-02,.4017451E-02,.3728288E-02,.3215678E-02,& - & .3669714E-02,.6454834E-02,.5651225E-02,.5010564E-02,.4555174E-02,& - & .4226789E-02,.3985960E-02,.3691258E-02,.3172291E-02,.3616086E-02,& - & .6136735E-02,.5394093E-02,.4895063E-02,.4573199E-02,.4385068E-02,& - & .4249509E-02,.4003690E-02,.3510981E-02,.3909452E-02,.6155380E-02,& - & .5408904E-02,.4900856E-02,.4569405E-02,.4373257E-02,.4232877E-02,& - & .3984093E-02,.3485462E-02,.3882943E-02,.6172980E-02,.5422475E-02,& - & .4904945E-02,.4567515E-02,.4361079E-02,.4216322E-02,.3963626E-02,& - & .3461480E-02,.3857723E-02,.6190567E-02,.5436595E-02,.4910048E-02,& - & .4565398E-02,.4351183E-02,.4198401E-02,.3942356E-02,.3437743E-02,& - & .3835996E-02,.6207595E-02,.5450671E-02,.4917790E-02,.4569064E-02,& - & .4350510E-02,.4193413E-02,.3939962E-02,.3434045E-02,.3850556E-02/ - - data absa(181:315, 7) / & - & .5805911E-02,.5141666E-02,.4763038E-02,.4558815E-02,.4481648E-02,& - & .4418775E-02,.4218480E-02,.3750496E-02,.4085582E-02,.5829599E-02,& - & .5159492E-02,.4770932E-02,.4555269E-02,.4469546E-02,.4402981E-02,& - & .4198610E-02,.3724260E-02,.4061967E-02,.5854540E-02,.5177705E-02,& - & .4778238E-02,.4554312E-02,.4457721E-02,.4386787E-02,.4178282E-02,& - & .3698112E-02,.4040118E-02,.5879038E-02,.5196952E-02,.4787326E-02,& - & .4553873E-02,.4447674E-02,.4369633E-02,.4158545E-02,.3673692E-02,& - & .4021141E-02,.5902275E-02,.5214049E-02,.4797276E-02,.4557481E-02,& - & .4445243E-02,.4367290E-02,.4159851E-02,.3673710E-02,.4041450E-02,& - & .5423597E-02,.4859083E-02,.4609862E-02,.4529795E-02,.4557832E-02,& - & .4560070E-02,.4409076E-02,.3975219E-02,.4252602E-02,.5454365E-02,& - & .4881607E-02,.4620352E-02,.4527565E-02,.4548530E-02,.4548237E-02,& - & .4391661E-02,.3949326E-02,.4232009E-02,.5488044E-02,.4905751E-02,& - & .4632103E-02,.4528708E-02,.4538967E-02,.4534788E-02,.4373488E-02,& - & .3924420E-02,.4212910E-02,.5518713E-02,.4928892E-02,.4643930E-02,& - & .4529113E-02,.4529842E-02,.4520746E-02,.4357460E-02,.3901482E-02,& - & .4195693E-02,.5549581E-02,.4949387E-02,.4654691E-02,.4528154E-02,& - & .4518717E-02,.4507320E-02,.4341984E-02,.3878945E-02,.4179215E-02,& - & .5010662E-02,.4562289E-02,.4450406E-02,.4497408E-02,.4612122E-02,& - & .4668231E-02,.4573752E-02,.4184611E-02,.4407478E-02,.5048488E-02,& - & .4588791E-02,.4462195E-02,.4495999E-02,.4605287E-02,.4662092E-02,& - & .4561288E-02,.4161583E-02,.4389563E-02,.5087790E-02,.4615970E-02,& - & .4475379E-02,.4496880E-02,.4598974E-02,.4654027E-02,.4547703E-02,& - & .4139097E-02,.4372125E-02,.5124133E-02,.4641212E-02,.4488105E-02,& - & .4495983E-02,.4593289E-02,.4645512E-02,.4535541E-02,.4118063E-02,& - & .4355876E-02,.5162759E-02,.4667582E-02,.4502006E-02,.4496029E-02,& - & .4585626E-02,.4636559E-02,.4523214E-02,.4097252E-02,.4340154E-02/ - - data absa(316:450, 7) / & - & .4587688E-02,.4265942E-02,.4293117E-02,.4465668E-02,.4646838E-02,& - & .4746553E-02,.4710731E-02,.4377367E-02,.4543398E-02,.4630881E-02,& - & .4294688E-02,.4306044E-02,.4466382E-02,.4646169E-02,.4747955E-02,& - & .4704166E-02,.4357348E-02,.4528127E-02,.4671866E-02,.4321409E-02,& - & .4317765E-02,.4465517E-02,.4644351E-02,.4746523E-02,.4697148E-02,& - & .4338778E-02,.4512456E-02,.4713989E-02,.4350596E-02,.4331423E-02,& - & .4464363E-02,.4642472E-02,.4743704E-02,.4690020E-02,.4320460E-02,& - & .4498985E-02,.4761723E-02,.4382334E-02,.4348263E-02,.4465420E-02,& - & .4638543E-02,.4740624E-02,.4683278E-02,.4302003E-02,.4484275E-02,& - & .4164717E-02,.3979215E-02,.4144193E-02,.4422962E-02,.4657806E-02,& - & .4800744E-02,.4824067E-02,.4555259E-02,.4602286E-02,.4211716E-02,& - & .4008521E-02,.4157412E-02,.4428976E-02,.4663384E-02,.4809552E-02,& - & .4822353E-02,.4539339E-02,.4590712E-02,.4257203E-02,.4037513E-02,& - & .4169430E-02,.4432371E-02,.4669584E-02,.4816112E-02,.4822125E-02,& - & .4523735E-02,.4581771E-02,.4307089E-02,.4070222E-02,.4184488E-02,& - & .4434611E-02,.4676070E-02,.4820311E-02,.4822098E-02,.4508261E-02,& - & .4573178E-02,.4362715E-02,.4106878E-02,.4203483E-02,.4440385E-02,& - & .4678627E-02,.4823705E-02,.4820573E-02,.4492558E-02,.4565516E-02,& - & .3757322E-02,.3709073E-02,.4010509E-02,.4365375E-02,.4646644E-02,& - & .4836629E-02,.4911390E-02,.4716037E-02,.2246564E-04,.3804915E-02,& - & .3737287E-02,.4021585E-02,.4379566E-02,.4660941E-02,.4852517E-02,& - & .4918338E-02,.4703233E-02,.1560965E-04,.3856320E-02,.3768752E-02,& - & .4034329E-02,.4388713E-02,.4676333E-02,.4865802E-02,.4925596E-02,& - & .4691751E-02,.2028569E-04,.3915081E-02,.3807123E-02,.4052103E-02,& - & .4397870E-02,.4691010E-02,.4877070E-02,.4930793E-02,.4679143E-02,& - & .8984221E-05,.3978571E-02,.3848618E-02,.4073285E-02,.4408428E-02,& - & .4700559E-02,.4888012E-02,.4935723E-02,.4666034E-02,.2377631E-04/ - - data absa(451:585, 7) / & - & .3392928E-02,.3472731E-02,.3891540E-02,.4305406E-02,.4626003E-02,& - & .4865579E-02,.4987193E-02,.4850053E-02,.7140743E-05,.3445972E-02,& - & .3503144E-02,.3906610E-02,.4325733E-02,.4652048E-02,.4888232E-02,& - & .5003402E-02,.4843920E-02,.1439870E-04,.3506494E-02,.3541411E-02,& - & .3924176E-02,.4343703E-02,.4677805E-02,.4908831E-02,.5016389E-02,& - & .4837310E-02,.2945034E-04,.3573835E-02,.3584076E-02,.3945325E-02,& - & .4362029E-02,.4698214E-02,.4926791E-02,.5027125E-02,.4828102E-02,& - & .4370988E-04,.3640920E-02,.3627224E-02,.3965033E-02,.4380312E-02,& - & .4714810E-02,.4945090E-02,.5036845E-02,.4818793E-02,.2945488E-04,& - & .3062423E-02,.3266343E-02,.3779589E-02,.4238657E-02,.4602824E-02,& - & .4884734E-02,.5053548E-02,.4961911E-02,.2279693E-04,.3122111E-02,& - & .3300450E-02,.3801982E-02,.4268791E-02,.4639422E-02,.4914708E-02,& - & .5076081E-02,.4964486E-02,.3897689E-12,.3189802E-02,.3342291E-02,& - & .3827671E-02,.4296813E-02,.4673472E-02,.4942459E-02,.5094747E-02,& - & .4963101E-02,.2288291E-04,.3258443E-02,.3383882E-02,.3851683E-02,& - & .4323754E-02,.4700766E-02,.4969560E-02,.5112385E-02,.4958514E-02,& - & .5725606E-12,.3332531E-02,.3430641E-02,.3873322E-02,.4350068E-02,& - & .4725169E-02,.4995061E-02,.5126654E-02,.4953566E-02,.2246441E-04,& - & .2769676E-02,.3091600E-02,.3674265E-02,.4169149E-02,.4577937E-02,& - & .4901246E-02,.5107166E-02,.5055949E-02,.2616949E-12,.2834654E-02,& - & .3128534E-02,.3705750E-02,.4210247E-02,.4623099E-02,.4938500E-02,& - & .5137406E-02,.5065069E-02,.1482104E-04,.2902742E-02,.3167333E-02,& - & .3738974E-02,.4249285E-02,.4663578E-02,.4972092E-02,.5164558E-02,& - & .5069435E-02,.4171247E-12,.2976402E-02,.3210834E-02,.3767797E-02,& - & .4287152E-02,.4699067E-02,.5006489E-02,.5189897E-02,.5072755E-02,& - & .2892462E-04,.3057599E-02,.3261050E-02,.3794966E-02,.4320752E-02,& - & .4731977E-02,.5038479E-02,.5208571E-02,.5071823E-02,.5748148E-12/ - - data absa( 1:180, 8) / & - & .2384831E-01,.2086796E-01,.1788674E-01,.1490488E-01,.1192466E-01,& - & .8942720E-02,.6435132E-02,.5216105E-02,.8046861E-02,.2383260E-01,& - & .2085323E-01,.1787386E-01,.1489524E-01,.1191574E-01,.8936646E-02,& - & .6410723E-02,.5172302E-02,.7958914E-02,.2381817E-01,.2084152E-01,& - & .1786363E-01,.1488699E-01,.1190859E-01,.8931517E-02,.6409801E-02,& - & .5184894E-02,.7931542E-02,.2382505E-01,.2084563E-01,.1786745E-01,& - & .1488939E-01,.1191159E-01,.8933625E-02,.6363063E-02,.5080538E-02,& - & .7797373E-02,.2384370E-01,.2086411E-01,.1788240E-01,.1490168E-01,& - & .1192085E-01,.8941188E-02,.6342996E-02,.5038349E-02,.7721574E-02,& - & .2736703E-01,.2394425E-01,.2052396E-01,.1710455E-01,.1368277E-01,& - & .1026855E-01,.7533161E-02,.6102509E-02,.9457556E-02,.2733895E-01,& - & .2392100E-01,.2050455E-01,.1708673E-01,.1366891E-01,.1025512E-01,& - & .7493273E-02,.6042133E-02,.9346029E-02,.2732514E-01,.2390916E-01,& - & .2049354E-01,.1707793E-01,.1366282E-01,.1024661E-01,.7477603E-02,& - & .6033817E-02,.9291851E-02,.2732521E-01,.2390831E-01,.2049329E-01,& - & .1707676E-01,.1366198E-01,.1024619E-01,.7441129E-02,.5964001E-02,& - & .9183864E-02,.2732055E-01,.2390460E-01,.2048954E-01,.1707397E-01,& - & .1365928E-01,.1024450E-01,.7386349E-02,.5857452E-02,.9032475E-02,& - & .3111827E-01,.2722823E-01,.2333792E-01,.1944912E-01,.1556020E-01,& - & .1174017E-01,.8774373E-02,.7126843E-02,.1107681E-01,.3108435E-01,& - & .2719812E-01,.2331276E-01,.1942815E-01,.1554155E-01,.1171142E-01,& - & .8719646E-02,.7046216E-02,.1093045E-01,.3105719E-01,.2717391E-01,& - & .2328911E-01,.1940895E-01,.1552703E-01,.1168858E-01,.8669582E-02,& - & .6965164E-02,.1078986E-01,.3102639E-01,.2714667E-01,.2326970E-01,& - & .1939161E-01,.1551301E-01,.1167462E-01,.8637664E-02,.6932578E-02,& - & .1069100E-01,.3098455E-01,.2711278E-01,.2323876E-01,.1936649E-01,& - & .1549184E-01,.1165288E-01,.8564686E-02,.6812398E-02,.1050557E-01,& - & .3509245E-01,.3070408E-01,.2631947E-01,.2193322E-01,.1754460E-01,& - & .1336963E-01,.1019024E-01,.8304991E-02,.1279060E-01,.3502835E-01,& - & .3065102E-01,.2627132E-01,.2189262E-01,.1751355E-01,.1331920E-01,& - & .1010855E-01,.8200658E-02,.1260628E-01,.3496387E-01,.3059309E-01,& - & .2622344E-01,.2185116E-01,.1748300E-01,.1327541E-01,.1003370E-01,& - & .8097466E-02,.1242619E-01,.3489136E-01,.3053088E-01,.2616852E-01,& - & .2180854E-01,.1744581E-01,.1323085E-01,.9958124E-02,.7996001E-02,& - & .1224573E-01,.3480910E-01,.3045842E-01,.2610586E-01,.2175555E-01,& - & .1740387E-01,.1318718E-01,.9898605E-02,.7943117E-02,.1209514E-01/ - - data absa(181:315, 8) / & - & .3922337E-01,.3432089E-01,.2941855E-01,.2451621E-01,.1961212E-01,& - & .1515625E-01,.1177220E-01,.9640074E-02,.1459421E-01,.3912061E-01,& - & .3423066E-01,.2933971E-01,.2445001E-01,.1956031E-01,.1507474E-01,& - & .1166291E-01,.9508349E-02,.1436943E-01,.3900929E-01,.3413223E-01,& - & .2925716E-01,.2437959E-01,.1950452E-01,.1499589E-01,.1155252E-01,& - & .9377833E-02,.1414677E-01,.3888582E-01,.3402602E-01,.2916246E-01,& - & .2430215E-01,.1944160E-01,.1491429E-01,.1144124E-01,.9247519E-02,& - & .1391910E-01,.3876452E-01,.3391846E-01,.2907242E-01,.2422862E-01,& - & .1938320E-01,.1483471E-01,.1134199E-01,.9163542E-02,.1372356E-01,& - & .4343721E-01,.3800576E-01,.3257544E-01,.2714774E-01,.2177640E-01,& - & .1709399E-01,.1352071E-01,.1113282E-01,.1649120E-01,.4327842E-01,& - & .3786995E-01,.3246159E-01,.2705100E-01,.2168123E-01,.1696268E-01,& - & .1336889E-01,.1097194E-01,.1622011E-01,.4310942E-01,.3772166E-01,& - & .3233366E-01,.2694253E-01,.2158320E-01,.1684054E-01,.1321804E-01,& - & .1080800E-01,.1594714E-01,.4294323E-01,.3757194E-01,.3220476E-01,& - & .2683910E-01,.2148483E-01,.1671415E-01,.1306213E-01,.1064614E-01,& - & .1567355E-01,.4277920E-01,.3742913E-01,.3208316E-01,.2673469E-01,& - & .2139400E-01,.1658867E-01,.1290640E-01,.1049169E-01,.1540259E-01,& - & .4758398E-01,.4163822E-01,.3568958E-01,.2974106E-01,.2404453E-01,& - & .1920360E-01,.1543848E-01,.1277750E-01,.1847724E-01,.4738640E-01,& - & .4146564E-01,.3554040E-01,.2961803E-01,.2390579E-01,.1900947E-01,& - & .1522766E-01,.1257734E-01,.1815308E-01,.4718171E-01,.4128335E-01,& - & .3538475E-01,.2948927E-01,.2375761E-01,.1882582E-01,.1502284E-01,& - & .1237488E-01,.1783112E-01,.4697763E-01,.4110594E-01,.3523272E-01,& - & .2936065E-01,.2361055E-01,.1864217E-01,.1481297E-01,.1217429E-01,& - & .1750726E-01,.4675913E-01,.4091320E-01,.3506988E-01,.2922357E-01,& - & .2347293E-01,.1846131E-01,.1460514E-01,.1197957E-01,.1718605E-01/ - - data absa(316:450, 8) / & - & .5157307E-01,.4512456E-01,.3867815E-01,.3225755E-01,.2639876E-01,& - & .2145781E-01,.1750537E-01,.1456533E-01,.2056891E-01,.5133970E-01,& - & .4492267E-01,.3850493E-01,.3209518E-01,.2619464E-01,.2118929E-01,& - & .1723033E-01,.1431879E-01,.2018920E-01,.5111942E-01,.4472821E-01,& - & .3833961E-01,.3195026E-01,.2598683E-01,.2093775E-01,.1695719E-01,& - & .1406885E-01,.1981018E-01,.5087613E-01,.4451558E-01,.3815604E-01,& - & .3179899E-01,.2578609E-01,.2068553E-01,.1668237E-01,.1381989E-01,& - & .1942343E-01,.5060089E-01,.4427189E-01,.3795104E-01,.3162743E-01,& - & .2558999E-01,.2043394E-01,.1640721E-01,.1357794E-01,.1904337E-01,& - & .5534675E-01,.4842752E-01,.4150943E-01,.3476993E-01,.2883356E-01,& - & .2383857E-01,.1970071E-01,.1648151E-01,.2277280E-01,.5509028E-01,& - & .4820517E-01,.4131655E-01,.3454903E-01,.2856187E-01,.2348302E-01,& - & .1935846E-01,.1617643E-01,.2231934E-01,.5483513E-01,.4798329E-01,& - & .4112957E-01,.3434599E-01,.2827236E-01,.2314776E-01,.1900981E-01,& - & .1587603E-01,.2186150E-01,.5455249E-01,.4773592E-01,.4091413E-01,& - & .3413989E-01,.2798959E-01,.2281411E-01,.1865486E-01,.1557181E-01,& - & .2140320E-01,.5423071E-01,.4745272E-01,.4067235E-01,.3391765E-01,& - & .2771937E-01,.2248276E-01,.1830805E-01,.1527494E-01,.2095422E-01,& - & .5884200E-01,.5148486E-01,.4413720E-01,.3726346E-01,.3131906E-01,& - & .2625246E-01,.2197329E-01,.1846472E-01,.2390318E-01,.5857990E-01,& - & .5125704E-01,.4393628E-01,.3696356E-01,.3095564E-01,.2581323E-01,& - & .2154391E-01,.1810523E-01,.2329308E-01,.5829302E-01,.5100372E-01,& - & .4371805E-01,.3669137E-01,.3057614E-01,.2539516E-01,.2111008E-01,& - & .1774335E-01,.2234009E-01,.5795260E-01,.5070680E-01,.4346190E-01,& - & .3641971E-01,.3020199E-01,.2497397E-01,.2067529E-01,.1737760E-01,& - & .2139251E-01,.5758016E-01,.5038153E-01,.4318130E-01,.3612879E-01,& - & .2984663E-01,.2454856E-01,.2024342E-01,.1701514E-01,.2073609E-01/ - - data absa(451:585, 8) / & - & .6192199E-01,.5417932E-01,.4648962E-01,.3955997E-01,.3362055E-01,& - & .2844545E-01,.2405185E-01,.2035174E-01,.1147313E-01,.6162491E-01,& - & .5392502E-01,.4624284E-01,.3918782E-01,.3314307E-01,.2793088E-01,& - & .2352660E-01,.1992303E-01,.1059037E-01,.6128035E-01,.5361653E-01,& - & .4596296E-01,.3883034E-01,.3266054E-01,.2741823E-01,.2300155E-01,& - & .1948403E-01,.9386733E-02,.6089037E-01,.5327663E-01,.4566324E-01,& - & .3846602E-01,.3220217E-01,.2689963E-01,.2248042E-01,.1904677E-01,& - & .8579093E-02,.6048928E-01,.5292930E-01,.4536869E-01,.3808824E-01,& - & .3175943E-01,.2638003E-01,.2196410E-01,.1861176E-01,.7679777E-02,& - & .6465333E-01,.5657427E-01,.4867177E-01,.4175377E-01,.3579281E-01,& - & .3056479E-01,.2606485E-01,.2228565E-01,.5410855E-02,.6431550E-01,& - & .5627490E-01,.4834862E-01,.4128883E-01,.3521242E-01,.2995578E-01,& - & .2544242E-01,.2175694E-01,.4314129E-02,.6391863E-01,.5593558E-01,& - & .4799090E-01,.4083615E-01,.3463083E-01,.2933897E-01,.2482046E-01,& - & .2122362E-01,.3358717E-02,.6351746E-01,.5557930E-01,.4765095E-01,& - & .4037369E-01,.3408214E-01,.2871059E-01,.2420299E-01,.2070479E-01,& - & .2857525E-02,.6306892E-01,.5519351E-01,.4730897E-01,.3991011E-01,& - & .3354065E-01,.2809407E-01,.2359936E-01,.2018705E-01,.1777796E-02,& - & .6703446E-01,.5865676E-01,.5067634E-01,.4381050E-01,.3782219E-01,& - & .3255454E-01,.2802206E-01,.2421920E-01,.3263487E-02,.6665902E-01,& - & .5832721E-01,.5026612E-01,.4325080E-01,.3713778E-01,.3183964E-01,& - & .2728129E-01,.2358311E-01,.2472960E-02,.6626616E-01,.5798723E-01,& - & .4984365E-01,.4269195E-01,.3646735E-01,.3111990E-01,.2654294E-01,& - & .2295618E-01,.1479400E-02,.6583606E-01,.5760454E-01,.4944157E-01,& - & .4212139E-01,.3581890E-01,.3039518E-01,.2581655E-01,.2233056E-01,& - & .6227714E-03,.6534867E-01,.5717837E-01,.4902999E-01,.4157439E-01,& - & .3517603E-01,.2968487E-01,.2512196E-01,.2172312E-01,.0000000E+00/ - -! the array iabsb(235,8) (kb(5,13:59,8)) contains absorption coefs at -! the 16 chosen g-values for a range of pressure levels < ~100mb and -! temperatures. the first index in the array, jt, which runs from 1 to 5, -! corresponds to different temperatures. more specifically, jt = 3 means -! that the data are for the reference temperature tref for this pressure -! level, jt = 2 refers to the temperature tref-15, jt = 1 is for -! tref-30, jt = 4 is for tref+15, and jt = 5 is for tref+30. -! the second index, jp, runs from 13 to 59 and refers to the jpth -! reference pressure level (see taumol.f for the value of these -! pressure levels in mb). the third index, ig, goes from 1 to 8, -! and tells us which g-interval the absorption coefficients are for. - - data absb( 1:120, 1) / & - & .1504485E-08,.1655173E-08,.1834066E-08,.2005073E-08,.2225228E-08,& - & .2825609E-08,.3120559E-08,.3367595E-08,.3608461E-08,.3837790E-08,& - & .4601061E-08,.4908305E-08,.5119376E-08,.5374147E-08,.5818231E-08,& - & .6064902E-08,.6787357E-08,.7300746E-08,.8100588E-08,.8763709E-08,& - & .9117383E-08,.9716817E-08,.1020886E-07,.1060372E-07,.1107971E-07,& - & .1180416E-07,.1231184E-07,.1271306E-07,.1305533E-07,.1325092E-07,& - & .1466240E-07,.1530788E-07,.1602711E-07,.1636818E-07,.1670250E-07,& - & .1693173E-07,.1796180E-07,.1893120E-07,.2002152E-07,.2083754E-07,& - & .2023944E-07,.2129216E-07,.2220720E-07,.2278656E-07,.2334708E-07,& - & .2244645E-07,.2315295E-07,.2356590E-07,.2386446E-07,.2427953E-07,& - & .2319360E-07,.2372368E-07,.2396595E-07,.2414683E-07,.2427181E-07,& - & .2327042E-07,.2360101E-07,.2379715E-07,.2393742E-07,.2409578E-07,& - & .2292965E-07,.2319441E-07,.2326480E-07,.2333873E-07,.2344359E-07,& - & .2207835E-07,.2228167E-07,.2230807E-07,.2237370E-07,.2237045E-07,& - & .2063469E-07,.2078315E-07,.2069998E-07,.2077522E-07,.2076445E-07,& - & .1888890E-07,.1895087E-07,.1888552E-07,.1896680E-07,.1893800E-07,& - & .1661684E-07,.1660531E-07,.1660816E-07,.1663392E-07,.1655720E-07,& - & .1439584E-07,.1436756E-07,.1440958E-07,.1432625E-07,.1427447E-07,& - & .1206857E-07,.1208380E-07,.1201089E-07,.1199160E-07,.1194784E-07,& - & .1009433E-07,.1006531E-07,.1001838E-07,.9943710E-08,.9961010E-08,& - & .8315238E-08,.8268144E-08,.8236950E-08,.8211572E-08,.8220796E-08,& - & .6957233E-08,.6909506E-08,.6862800E-08,.6872511E-08,.6883916E-08,& - & .5813067E-08,.5757273E-08,.5742704E-08,.5742958E-08,.5758679E-08,& - & .4871874E-08,.4830498E-08,.4812558E-08,.4818784E-08,.4830929E-08/ - - data absb(121:235, 1) / & - & .4145901E-08,.4106507E-08,.4098022E-08,.4099861E-08,.4120380E-08,& - & .3494406E-08,.3465963E-08,.3462820E-08,.3456337E-08,.3467275E-08,& - & .2913432E-08,.2889628E-08,.2883621E-08,.2884851E-08,.2891869E-08,& - & .2518380E-08,.2496362E-08,.2483940E-08,.2484762E-08,.2483586E-08,& - & .2170390E-08,.2145546E-08,.2143039E-08,.2142370E-08,.2144634E-08,& - & .1858046E-08,.1844624E-08,.1839065E-08,.1839091E-08,.1839162E-08,& - & .1593689E-08,.1577154E-08,.1573460E-08,.1568484E-08,.1569186E-08,& - & .1355958E-08,.1341138E-08,.1331384E-08,.1328120E-08,.1330151E-08,& - & .1137083E-08,.1126680E-08,.1120107E-08,.1113883E-08,.1115922E-08,& - & .9476994E-09,.9397984E-09,.9335405E-09,.9287986E-09,.9311504E-09,& - & .7932191E-09,.7894802E-09,.7806572E-09,.7786638E-09,.7792733E-09,& - & .6576028E-09,.6532665E-09,.6444048E-09,.6406832E-09,.6417746E-09,& - & .5317563E-09,.5279691E-09,.5215721E-09,.5171123E-09,.5157522E-09,& - & .4412974E-09,.4375477E-09,.4332457E-09,.4272818E-09,.4275019E-09,& - & .3706852E-09,.3662403E-09,.3636864E-09,.3584788E-09,.3586079E-09,& - & .3049173E-09,.3029969E-09,.3014427E-09,.2964519E-09,.2955262E-09,& - & .2463755E-09,.2449361E-09,.2438107E-09,.2391687E-09,.2384375E-09,& - & .2163852E-09,.2148951E-09,.2136504E-09,.2102694E-09,.2093443E-09,& - & .1986154E-09,.1986504E-09,.1964941E-09,.1948428E-09,.1924552E-09,& - & .1827696E-09,.1814666E-09,.1809023E-09,.1806150E-09,.1773916E-09,& - & .1651185E-09,.1676846E-09,.1675465E-09,.1672040E-09,.1645195E-09,& - & .1529359E-09,.1572349E-09,.1577673E-09,.1563134E-09,.1551000E-09,& - & .1662330E-09,.1742843E-09,.1737219E-09,.1735156E-09,.1726745E-09/ - - data absb( 1:120, 2) / & - & .8620280E-08,.8996610E-08,.9179512E-08,.9273313E-08,.9496698E-08,& - & .1372714E-07,.1415234E-07,.1568014E-07,.1633632E-07,.1660623E-07,& - & .2431506E-07,.2468338E-07,.2511484E-07,.2544479E-07,.2520146E-07,& - & .3107454E-07,.3086269E-07,.3175603E-07,.3173983E-07,.3139772E-07,& - & .3808811E-07,.3902271E-07,.4062594E-07,.4223852E-07,.4271310E-07,& - & .4796946E-07,.4857088E-07,.4939986E-07,.5006781E-07,.5049110E-07,& - & .5417823E-07,.5385088E-07,.5369254E-07,.5418624E-07,.5425686E-07,& - & .5417471E-07,.5315715E-07,.5265850E-07,.5227965E-07,.5182433E-07,& - & .5084925E-07,.4952405E-07,.4900280E-07,.4911242E-07,.4895983E-07,& - & .4638127E-07,.4550613E-07,.4547382E-07,.4602960E-07,.4609687E-07,& - & .4282135E-07,.4200746E-07,.4233769E-07,.4314509E-07,.4364517E-07,& - & .4009028E-07,.3966390E-07,.4021359E-07,.4114239E-07,.4138132E-07,& - & .3718799E-07,.3696495E-07,.3760314E-07,.3889000E-07,.3926156E-07,& - & .3428008E-07,.3436242E-07,.3521050E-07,.3663400E-07,.3706092E-07,& - & .3131405E-07,.3161472E-07,.3286669E-07,.3437652E-07,.3468898E-07,& - & .2838426E-07,.2902508E-07,.3042525E-07,.3175777E-07,.3176690E-07,& - & .2508366E-07,.2604667E-07,.2745713E-07,.2796496E-07,.2814461E-07,& - & .2198601E-07,.2304237E-07,.2412502E-07,.2435339E-07,.2460182E-07,& - & .1894551E-07,.1992262E-07,.2052438E-07,.2042507E-07,.2067876E-07,& - & .1617250E-07,.1693348E-07,.1699496E-07,.1708234E-07,.1690581E-07,& - & .1380557E-07,.1391757E-07,.1389405E-07,.1394496E-07,.1376301E-07,& - & .1155663E-07,.1155203E-07,.1168102E-07,.1152309E-07,.1127853E-07,& - & .9697158E-08,.9695956E-08,.9680578E-08,.9559403E-08,.9302754E-08,& - & .8154203E-08,.8120989E-08,.8036412E-08,.7883272E-08,.7698274E-08/ - - data absb(121:235, 2) / & - & .6967330E-08,.6906568E-08,.6813175E-08,.6653576E-08,.6523040E-08,& - & .5881983E-08,.5845620E-08,.5707887E-08,.5564188E-08,.5496845E-08,& - & .4867982E-08,.4842877E-08,.4723792E-08,.4610581E-08,.4535252E-08,& - & .4220891E-08,.4197573E-08,.4091011E-08,.3984631E-08,.3910118E-08,& - & .3693929E-08,.3663715E-08,.3538644E-08,.3460285E-08,.3368615E-08,& - & .3187896E-08,.3159197E-08,.3046331E-08,.2969790E-08,.2900429E-08,& - & .2727771E-08,.2707740E-08,.2609750E-08,.2537780E-08,.2466859E-08,& - & .2336416E-08,.2288611E-08,.2243157E-08,.2156881E-08,.2077391E-08,& - & .1962744E-08,.1900100E-08,.1900600E-08,.1810939E-08,.1740140E-08,& - & .1641370E-08,.1585025E-08,.1598322E-08,.1519198E-08,.1446996E-08,& - & .1369667E-08,.1331096E-08,.1332974E-08,.1271075E-08,.1212575E-08,& - & .1134932E-08,.1101458E-08,.1088461E-08,.1059785E-08,.1000704E-08,& - & .9094399E-09,.8846586E-09,.8692260E-09,.8514667E-09,.8067748E-09,& - & .7475365E-09,.7309474E-09,.7248197E-09,.7107080E-09,.6704647E-09,& - & .6155314E-09,.6185778E-09,.6128860E-09,.5976466E-09,.5727505E-09,& - & .5007571E-09,.5092447E-09,.5016075E-09,.4940536E-09,.4741181E-09,& - & .3942016E-09,.4100999E-09,.4008001E-09,.3983216E-09,.3787150E-09,& - & .3377646E-09,.3579863E-09,.3566328E-09,.3468912E-09,.3368833E-09,& - & .3036220E-09,.3322234E-09,.3325357E-09,.3256853E-09,.3158305E-09,& - & .2804988E-09,.3017266E-09,.3108715E-09,.2978439E-09,.2936541E-09,& - & .2609790E-09,.2661588E-09,.2860275E-09,.2792342E-09,.2602529E-09,& - & .2458827E-09,.2411410E-09,.2673329E-09,.2554838E-09,.2352146E-09,& - & .2526218E-09,.2394002E-09,.2533229E-09,.2725054E-09,.2570953E-09/ - - data absb( 1:120, 3) / & - & .2094454E-07,.2103723E-07,.2317421E-07,.2429927E-07,.2443259E-07,& - & .3496380E-07,.3490941E-07,.3349223E-07,.3343521E-07,.3310576E-07,& - & .4585045E-07,.4658060E-07,.4768562E-07,.5006330E-07,.5247674E-07,& - & .6284991E-07,.6579582E-07,.6633160E-07,.6800469E-07,.6989589E-07,& - & .7248123E-07,.7171694E-07,.7074783E-07,.6969505E-07,.7027375E-07,& - & .6908485E-07,.6849817E-07,.6716994E-07,.6730050E-07,.6828500E-07,& - & .6934186E-07,.6902567E-07,.6864856E-07,.6846652E-07,.6943860E-07,& - & .6706792E-07,.6726913E-07,.6653898E-07,.6592318E-07,.6689835E-07,& - & .6315693E-07,.6388301E-07,.6354862E-07,.6322257E-07,.6392275E-07,& - & .6021001E-07,.6063825E-07,.6004737E-07,.5982331E-07,.6053882E-07,& - & .5662743E-07,.5727057E-07,.5683287E-07,.5634445E-07,.5728420E-07,& - & .5345713E-07,.5415602E-07,.5376082E-07,.5388461E-07,.5551090E-07,& - & .5097174E-07,.5174221E-07,.5185410E-07,.5170391E-07,.5343406E-07,& - & .4885071E-07,.4964076E-07,.4957246E-07,.4927493E-07,.5181847E-07,& - & .4607099E-07,.4641337E-07,.4642465E-07,.4657013E-07,.4906130E-07,& - & .4289388E-07,.4288894E-07,.4267067E-07,.4328417E-07,.4696503E-07,& - & .3872644E-07,.3855498E-07,.3845341E-07,.4062810E-07,.4336730E-07,& - & .3420706E-07,.3415253E-07,.3481498E-07,.3737966E-07,.3894101E-07,& - & .2944343E-07,.2985002E-07,.3132611E-07,.3395546E-07,.3326394E-07,& - & .2542129E-07,.2622059E-07,.2846268E-07,.2890366E-07,.2912570E-07,& - & .2147717E-07,.2336132E-07,.2481620E-07,.2489857E-07,.2493064E-07,& - & .1865200E-07,.2074963E-07,.2073473E-07,.2113566E-07,.2126999E-07,& - & .1634412E-07,.1718199E-07,.1732143E-07,.1735331E-07,.1757109E-07,& - & .1379461E-07,.1435679E-07,.1452171E-07,.1458681E-07,.1440034E-07/ - - data absb(121:235, 3) / & - & .1173430E-07,.1207008E-07,.1230757E-07,.1227543E-07,.1218723E-07,& - & .9814963E-08,.1008580E-07,.1002846E-07,.1018936E-07,.9936886E-08,& - & .8116338E-08,.8224445E-08,.8137160E-08,.8175235E-08,.7809894E-08,& - & .6934363E-08,.6954010E-08,.7028701E-08,.6954052E-08,.6730920E-08,& - & .6044805E-08,.6051282E-08,.6043548E-08,.5955009E-08,.5737156E-08,& - & .5148115E-08,.5173181E-08,.5143460E-08,.5091858E-08,.4844251E-08,& - & .4357708E-08,.4427891E-08,.4341154E-08,.4374327E-08,.4087965E-08,& - & .3575010E-08,.3758880E-08,.3640315E-08,.3685335E-08,.3462657E-08,& - & .2951838E-08,.3149133E-08,.2949301E-08,.3004140E-08,.2803498E-08,& - & .2384856E-08,.2593067E-08,.2441925E-08,.2455559E-08,.2313264E-08,& - & .1941929E-08,.2123023E-08,.2023449E-08,.2026484E-08,.1914693E-08,& - & .1543067E-08,.1703838E-08,.1718628E-08,.1615796E-08,.1571495E-08,& - & .1183980E-08,.1356359E-08,.1356083E-08,.1273436E-08,.1237516E-08,& - & .9485975E-09,.1113593E-08,.1117504E-08,.1051262E-08,.1016169E-08,& - & .7815940E-09,.9032580E-09,.9357674E-09,.8676745E-09,.8421725E-09,& - & .6380256E-09,.7279036E-09,.7623641E-09,.7144892E-09,.6975727E-09,& - & .5107804E-09,.5598705E-09,.6119439E-09,.5744789E-09,.5583942E-09,& - & .4463278E-09,.4765332E-09,.5199521E-09,.5043420E-09,.4788736E-09,& - & .4250688E-09,.4156415E-09,.4855086E-09,.4508491E-09,.4411532E-09,& - & .3832275E-09,.3697062E-09,.4153029E-09,.4390022E-09,.4199681E-09,& - & .3471974E-09,.3281596E-09,.3530108E-09,.4078183E-09,.4102159E-09,& - & .3136929E-09,.3137942E-09,.3117708E-09,.4176296E-09,.4265890E-09,& - & .3736120E-09,.4038289E-09,.4253194E-09,.5208493E-09,.6353775E-09/ - - data absb( 1:120, 4) / & - & .3207017E-07,.3159502E-07,.2858870E-07,.2844242E-07,.2837738E-07,& - & .3793390E-07,.3899797E-07,.4004916E-07,.4219287E-07,.4324826E-07,& - & .6367926E-07,.6755417E-07,.7008340E-07,.7122591E-07,.7118042E-07,& - & .7271716E-07,.6967355E-07,.6852180E-07,.6761184E-07,.6663393E-07,& - & .6791256E-07,.6626521E-07,.6475029E-07,.6335519E-07,.6341090E-07,& - & .6702275E-07,.6576791E-07,.6566342E-07,.6383917E-07,.6283841E-07,& - & .6421842E-07,.6328175E-07,.6271542E-07,.6152237E-07,.6029747E-07,& - & .6063945E-07,.6050892E-07,.6120783E-07,.6022239E-07,.5821503E-07,& - & .5811689E-07,.5640629E-07,.5625783E-07,.5511738E-07,.5487818E-07,& - & .5348844E-07,.5166798E-07,.5260953E-07,.5132573E-07,.5125687E-07,& - & .5056797E-07,.4945797E-07,.5018027E-07,.5055972E-07,.5015391E-07,& - & .4934735E-07,.4858752E-07,.4903720E-07,.4872055E-07,.4906669E-07,& - & .4696374E-07,.4689614E-07,.4670931E-07,.4783716E-07,.4808487E-07,& - & .4579724E-07,.4485585E-07,.4523316E-07,.4654221E-07,.4697737E-07,& - & .4177011E-07,.4195636E-07,.4315538E-07,.4366803E-07,.4370471E-07,& - & .3826636E-07,.3900949E-07,.4040767E-07,.4050401E-07,.3926292E-07,& - & .3417724E-07,.3398437E-07,.3497769E-07,.3504542E-07,.3635089E-07,& - & .2972685E-07,.3050472E-07,.3019202E-07,.2941542E-07,.3300928E-07,& - & .2569885E-07,.2510078E-07,.2547159E-07,.2603840E-07,.3137309E-07,& - & .2253041E-07,.2113115E-07,.2134413E-07,.2537857E-07,.2492397E-07,& - & .1910416E-07,.1866822E-07,.2015910E-07,.2178797E-07,.2103215E-07,& - & .1751768E-07,.1752356E-07,.1997915E-07,.1876099E-07,.1868247E-07,& - & .1601254E-07,.1739373E-07,.1791673E-07,.1773318E-07,.1719741E-07,& - & .1475039E-07,.1681135E-07,.1649793E-07,.1611369E-07,.1570679E-07/ - - data absb(121:235, 4) / & - & .1303339E-07,.1487026E-07,.1490773E-07,.1478564E-07,.1430577E-07,& - & .1163810E-07,.1261966E-07,.1306776E-07,.1264305E-07,.1269552E-07,& - & .9753745E-08,.1052021E-07,.1077719E-07,.1076181E-07,.1057069E-07,& - & .8428703E-08,.9412717E-08,.9437343E-08,.9161081E-08,.9398817E-08,& - & .6734710E-08,.7798478E-08,.8144691E-08,.8022473E-08,.8252301E-08,& - & .5704222E-08,.6683171E-08,.6786990E-08,.6802772E-08,.7124318E-08,& - & .4641578E-08,.5477035E-08,.5637589E-08,.5540870E-08,.5878158E-08,& - & .3894186E-08,.4572580E-08,.4683803E-08,.4627519E-08,.4835245E-08,& - & .3094846E-08,.3631163E-08,.3872510E-08,.3801876E-08,.4051812E-08,& - & .2505988E-08,.2813430E-08,.3115255E-08,.3108868E-08,.3368799E-08,& - & .1974147E-08,.2337742E-08,.2632663E-08,.2536104E-08,.2818301E-08,& - & .1571250E-08,.1795999E-08,.2019658E-08,.2053809E-08,.2214852E-08,& - & .1279646E-08,.1412932E-08,.1556847E-08,.1606893E-08,.1672149E-08,& - & .1031072E-08,.1097428E-08,.1196985E-08,.1290650E-08,.1288385E-08,& - & .8938603E-09,.8837689E-09,.9745065E-09,.1061662E-08,.1059312E-08,& - & .7322346E-09,.7033864E-09,.7896888E-09,.8643607E-09,.8131766E-09,& - & .5805907E-09,.5690340E-09,.6243145E-09,.6418920E-09,.6258469E-09,& - & .5029656E-09,.4690698E-09,.5424865E-09,.6080127E-09,.5841233E-09,& - & .4250789E-09,.4197107E-09,.4660663E-09,.6124726E-09,.5623562E-09,& - & .4019151E-09,.3994626E-09,.4466929E-09,.5705557E-09,.5871247E-09,& - & .3606061E-09,.4105570E-09,.4275902E-09,.5426140E-09,.6398303E-09,& - & .3779486E-09,.4060351E-09,.4385552E-09,.5030377E-09,.6537476E-09,& - & .5016060E-09,.5443259E-09,.6140966E-09,.6419200E-09,.8282210E-09/ - - data absb( 1:120, 5) / & - & .1729944E-05,.1736124E-05,.1741333E-05,.1742362E-05,.1748113E-05,& - & .1274396E-05,.1276178E-05,.1276894E-05,.1273619E-05,.1277683E-05,& - & .7962882E-06,.7847962E-06,.7761880E-06,.7674539E-06,.7644962E-06,& - & .4154425E-06,.4161228E-06,.4168582E-06,.4153229E-06,.4178350E-06,& - & .1529712E-06,.1587454E-06,.1627009E-06,.1686135E-06,.1698471E-06,& - & .5915086E-07,.5907368E-07,.5815373E-07,.5755800E-07,.5672556E-07,& - & .5797453E-07,.5829676E-07,.5862911E-07,.5886891E-07,.5612632E-07,& - & .5902708E-07,.5607408E-07,.5455860E-07,.5499325E-07,.5710234E-07,& - & .5283276E-07,.5163077E-07,.5070747E-07,.5268528E-07,.5249233E-07,& - & .4705563E-07,.5073384E-07,.5033114E-07,.5234450E-07,.5415567E-07,& - & .4780445E-07,.4964787E-07,.5059932E-07,.4884527E-07,.5386605E-07,& - & .4658544E-07,.4857945E-07,.4939821E-07,.4877906E-07,.5115413E-07,& - & .4761843E-07,.4933275E-07,.5350810E-07,.4890684E-07,.5018725E-07,& - & .4263688E-07,.5007044E-07,.5014879E-07,.4749372E-07,.4465415E-07,& - & .4455329E-07,.4855181E-07,.4368603E-07,.4298662E-07,.4551816E-07,& - & .4053097E-07,.4563140E-07,.3772562E-07,.4071168E-07,.4236715E-07,& - & .3588889E-07,.3889871E-07,.3518841E-07,.3620149E-07,.3217659E-07,& - & .3083266E-07,.2840331E-07,.3135215E-07,.3222827E-07,.3059802E-07,& - & .2609754E-07,.2597536E-07,.2416454E-07,.2407412E-07,.2851713E-07,& - & .1942653E-07,.2176047E-07,.1994188E-07,.2100237E-07,.2564799E-07,& - & .1872337E-07,.1873896E-07,.1659557E-07,.1939157E-07,.1979997E-07,& - & .1520850E-07,.1331818E-07,.1631543E-07,.1634361E-07,.1553305E-07,& - & .1209783E-07,.1336203E-07,.1561210E-07,.1467477E-07,.1431486E-07,& - & .1182141E-07,.1046697E-07,.1289913E-07,.1276273E-07,.1359344E-07/ - - data absb(121:235, 5) / & - & .1184794E-07,.1311106E-07,.1238478E-07,.1217861E-07,.1239514E-07,& - & .9765005E-08,.1222800E-07,.1250535E-07,.1265256E-07,.1275629E-07,& - & .8730087E-08,.1006998E-07,.1108201E-07,.1107370E-07,.1128404E-07,& - & .7184544E-08,.8280430E-08,.9337916E-08,.1097275E-07,.9422199E-08,& - & .7139569E-08,.8403293E-08,.8805228E-08,.8723704E-08,.8768754E-08,& - & .5638776E-08,.6617168E-08,.8131084E-08,.7952481E-08,.7843380E-08,& - & .4925723E-08,.6108668E-08,.6899038E-08,.7204770E-08,.7687590E-08,& - & .4080853E-08,.4506541E-08,.5062322E-08,.5570520E-08,.6245092E-08,& - & .3631086E-08,.3803154E-08,.4237952E-08,.4459341E-08,.4641922E-08,& - & .2798333E-08,.3196813E-08,.3468125E-08,.3333398E-08,.3634127E-08,& - & .2078749E-08,.2197782E-08,.2749626E-08,.2961556E-08,.2737758E-08,& - & .1606200E-08,.1840574E-08,.2290696E-08,.2323292E-08,.2090580E-08,& - & .1242108E-08,.1231152E-08,.1604400E-08,.1622018E-08,.1621244E-08,& - & .1142268E-08,.1161378E-08,.1312609E-08,.1332037E-08,.1336670E-08,& - & .7937740E-09,.9156464E-09,.9774718E-09,.1301830E-08,.1022826E-08,& - & .6792043E-09,.5672534E-09,.8065168E-09,.9174893E-09,.8812439E-09,& - & .4994562E-09,.4116159E-09,.6437120E-09,.8032581E-09,.6371815E-09,& - & .3965500E-09,.4502722E-09,.5469149E-09,.6195100E-09,.6194173E-09,& - & .4642266E-09,.4594787E-09,.4914294E-09,.5762278E-09,.7042388E-09,& - & .3468720E-09,.4302644E-09,.4377266E-09,.5298753E-09,.6737359E-09,& - & .4090614E-09,.3868913E-09,.4712038E-09,.5590598E-09,.5935130E-09,& - & .3717901E-09,.5393381E-09,.5139211E-09,.5362056E-09,.6355660E-09,& - & .5106858E-09,.5935961E-09,.6679782E-09,.7444804E-09,.8364933E-09/ - - data absb( 1:120, 6) / & - & .2395686E-04,.2404438E-04,.2411693E-04,.2423607E-04,.2436738E-04,& - & .2056849E-04,.2065059E-04,.2074045E-04,.2087079E-04,.2099978E-04,& - & .1768295E-04,.1777975E-04,.1792091E-04,.1803977E-04,.1817680E-04,& - & .1516668E-04,.1531217E-04,.1547416E-04,.1561878E-04,.1578350E-04,& - & .1290092E-04,.1310023E-04,.1328029E-04,.1346289E-04,.1365293E-04,& - & .1024835E-04,.1050381E-04,.1075123E-04,.1101880E-04,.1126531E-04,& - & .7489506E-05,.7760773E-05,.8019168E-05,.8297504E-05,.8573388E-05,& - & .5464496E-05,.5734262E-05,.6016157E-05,.6302015E-05,.6577927E-05,& - & .3936259E-05,.4224419E-05,.4513834E-05,.4789178E-05,.5070700E-05,& - & .2805984E-05,.3072729E-05,.3338950E-05,.3623166E-05,.3891777E-05,& - & .1900823E-05,.2167276E-05,.2408743E-05,.2685381E-05,.2917449E-05,& - & .1174025E-05,.1409556E-05,.1643976E-05,.1906921E-05,.2111832E-05,& - & .6636735E-06,.8537937E-06,.1064189E-05,.1305203E-05,.1520120E-05,& - & .3317132E-06,.4631507E-06,.6718687E-06,.8755380E-06,.1099835E-05,& - & .1412547E-06,.2795370E-06,.4605960E-06,.6358157E-06,.8299133E-06,& - & .5886507E-07,.1686485E-06,.3427727E-06,.5009229E-06,.7048885E-06,& - & .5375997E-07,.1921376E-06,.3466112E-06,.4979867E-06,.7234630E-06,& - & .9833696E-07,.2424778E-06,.3777826E-06,.5767946E-06,.7689130E-06,& - & .1780398E-06,.3286727E-06,.5106210E-06,.7063377E-06,.9191132E-06,& - & .2791479E-06,.4463444E-06,.6419014E-06,.8393519E-06,.1186341E-05,& - & .3815600E-06,.5566532E-06,.7712321E-06,.1041457E-05,.1452473E-05,& - & .4683750E-06,.6571130E-06,.8750377E-06,.1244250E-05,.1672199E-05,& - & .5302781E-06,.7255338E-06,.9960660E-06,.1375837E-05,.1817809E-05,& - & .5718819E-06,.7824923E-06,.1082650E-05,.1463943E-05,.1914798E-05/ - - data absb(121:235, 6) / & - & .5779563E-06,.7793008E-06,.1089554E-05,.1465980E-05,.1912492E-05,& - & .6012058E-06,.8101817E-06,.1114671E-05,.1481773E-05,.1917882E-05,& - & .6359830E-06,.8577926E-06,.1156572E-05,.1515261E-05,.1953664E-05,& - & .6218324E-06,.8312575E-06,.1120830E-05,.1466837E-05,.1889580E-05,& - & .6020577E-06,.7988481E-06,.1076839E-05,.1420463E-05,.1818710E-05,& - & .5888633E-06,.7776144E-06,.1041644E-05,.1370194E-05,.1754483E-05,& - & .5631597E-06,.7415089E-06,.9956498E-06,.1305861E-05,.1669685E-05,& - & .5356640E-06,.7073841E-06,.9466091E-06,.1238098E-05,.1585048E-05,& - & .5104786E-06,.6741957E-06,.8973165E-06,.1175203E-05,.1505003E-05,& - & .4827379E-06,.6379585E-06,.8434834E-06,.1105762E-05,.1414222E-05,& - & .4471224E-06,.5931371E-06,.7785484E-06,.1020135E-05,.1311082E-05,& - & .4093237E-06,.5500658E-06,.7202141E-06,.9432841E-06,.1215064E-05,& - & .3743207E-06,.5084612E-06,.6692669E-06,.8748475E-06,.1125655E-05,& - & .3375380E-06,.4645308E-06,.6183099E-06,.8066744E-06,.1040697E-05,& - & .3011207E-06,.4225809E-06,.5687082E-06,.7426667E-06,.9612401E-06,& - & .2668279E-06,.3832441E-06,.5209688E-06,.6850474E-06,.8874070E-06,& - & .2381612E-06,.3456426E-06,.4754255E-06,.6316630E-06,.8198579E-06,& - & .2073586E-06,.3073931E-06,.4304397E-06,.5791758E-06,.7545941E-06,& - & .1768447E-06,.2704831E-06,.3869748E-06,.5275204E-06,.6934370E-06,& - & .1503327E-06,.2353970E-06,.3469204E-06,.4790892E-06,.6362293E-06,& - & .1255561E-06,.2028854E-06,.3081471E-06,.4327060E-06,.5822767E-06,& - & .1038629E-06,.1726647E-06,.2718683E-06,.3906697E-06,.5319483E-06,& - & .8678777E-07,.1522598E-06,.2477843E-06,.3639270E-06,.4979000E-06/ - - data absb( 1:120, 7) / & - & .3453565E-03,.3534617E-03,.3619531E-03,.3711305E-03,.3812639E-03,& - & .3141656E-03,.3221962E-03,.3311595E-03,.3411912E-03,.3521288E-03,& - & .2869233E-03,.2952510E-03,.3048137E-03,.3155602E-03,.3272615E-03,& - & .2633665E-03,.2725298E-03,.2826467E-03,.2940184E-03,.3062037E-03,& - & .2432615E-03,.2533698E-03,.2641385E-03,.2758932E-03,.2885698E-03,& - & .2263129E-03,.2373054E-03,.2487516E-03,.2608205E-03,.2739867E-03,& - & .2120588E-03,.2239554E-03,.2359421E-03,.2484613E-03,.2621061E-03,& - & .2005107E-03,.2131852E-03,.2256599E-03,.2387045E-03,.2528263E-03,& - & .1911925E-03,.2045282E-03,.2175666E-03,.2310156E-03,.2455442E-03,& - & .1846431E-03,.1985047E-03,.2120615E-03,.2260435E-03,.2409818E-03,& - & .1798623E-03,.1940866E-03,.2081664E-03,.2226065E-03,.2379772E-03,& - & .1766175E-03,.1912018E-03,.2057461E-03,.2205236E-03,.2363363E-03,& - & .1746678E-03,.1895715E-03,.2044754E-03,.2196431E-03,.2358377E-03,& - & .1739647E-03,.1892010E-03,.2043935E-03,.2199752E-03,.2365860E-03,& - & .1742702E-03,.1897414E-03,.2051758E-03,.2211667E-03,.2381552E-03,& - & .1753432E-03,.1911018E-03,.2067274E-03,.2230734E-03,.2404076E-03,& - & .1772791E-03,.1932058E-03,.2090684E-03,.2257815E-03,.2433940E-03,& - & .1798122E-03,.1958563E-03,.2119375E-03,.2289267E-03,.2468559E-03,& - & .1828739E-03,.1989598E-03,.2152598E-03,.2325938E-03,.2507241E-03,& - & .1862774E-03,.2023367E-03,.2189782E-03,.2365487E-03,.2548744E-03,& - & .1898946E-03,.2060048E-03,.2229518E-03,.2407447E-03,.2592115E-03,& - & .1930147E-03,.2092865E-03,.2264529E-03,.2444439E-03,.2630292E-03,& - & .1947320E-03,.2110719E-03,.2284152E-03,.2464695E-03,.2651495E-03,& - & .1947235E-03,.2111115E-03,.2284595E-03,.2465787E-03,.2652695E-03/ - - data absb(121:235, 7) / & - & .1923135E-03,.2086721E-03,.2258790E-03,.2439421E-03,.2625178E-03,& - & .1898304E-03,.2061203E-03,.2232301E-03,.2411648E-03,.2597217E-03,& - & .1873764E-03,.2036289E-03,.2206075E-03,.2384662E-03,.2569599E-03,& - & .1832260E-03,.1995592E-03,.2162785E-03,.2339279E-03,.2523120E-03,& - & .1788996E-03,.1952895E-03,.2118287E-03,.2292618E-03,.2475232E-03,& - & .1745665E-03,.1910561E-03,.2074156E-03,.2246436E-03,.2426726E-03,& - & .1693616E-03,.1858699E-03,.2021660E-03,.2190895E-03,.2369106E-03,& - & .1636984E-03,.1802123E-03,.1965993E-03,.2131937E-03,.2307370E-03,& - & .1579848E-03,.1745716E-03,.1910412E-03,.2074387E-03,.2246686E-03,& - & .1517765E-03,.1686193E-03,.1851339E-03,.2014696E-03,.2183450E-03,& - & .1446931E-03,.1619128E-03,.1784332E-03,.1948757E-03,.2113871E-03,& - & .1374469E-03,.1550648E-03,.1717760E-03,.1882836E-03,.2046026E-03,& - & .1301193E-03,.1480729E-03,.1651093E-03,.1816194E-03,.1979742E-03,& - & .1232387E-03,.1413641E-03,.1587786E-03,.1753667E-03,.1918502E-03,& - & .1165074E-03,.1347306E-03,.1525223E-03,.1693426E-03,.1858642E-03,& - & .1098514E-03,.1281199E-03,.1461473E-03,.1632796E-03,.1797964E-03,& - & .1032338E-03,.1214316E-03,.1396126E-03,.1571081E-03,.1737446E-03,& - & .9707472E-04,.1152633E-03,.1335133E-03,.1513622E-03,.1682314E-03,& - & .9122100E-04,.1094451E-03,.1276962E-03,.1457224E-03,.1629077E-03,& - & .8538680E-04,.1036587E-03,.1218392E-03,.1400148E-03,.1575026E-03,& - & .7959199E-04,.9778645E-04,.1159632E-03,.1342022E-03,.1520145E-03,& - & .7417050E-04,.9223069E-04,.1104637E-03,.1287103E-03,.1467060E-03,& - & .7201794E-04,.9003123E-04,.1082584E-03,.1264928E-03,.1445780E-03/ - - data absb( 1:120, 8) / & - & .8358600E-02,.8311878E-02,.8262807E-02,.8209212E-02,.8148456E-02,& - & .8611422E-02,.8564644E-02,.8512562E-02,.8452401E-02,.8387225E-02,& - & .8829188E-02,.8780796E-02,.8724483E-02,.8660460E-02,.8590523E-02,& - & .9017237E-02,.8963386E-02,.8903457E-02,.8835037E-02,.8761588E-02,& - & .9177720E-02,.9117835E-02,.9052597E-02,.8982454E-02,.8905848E-02,& - & .9312725E-02,.9247622E-02,.9178554E-02,.9105643E-02,.9025534E-02,& - & .9426857E-02,.9355560E-02,.9283636E-02,.9207311E-02,.9124846E-02,& - & .9520420E-02,.9444026E-02,.9368533E-02,.9289838E-02,.9203532E-02,& - & .9596404E-02,.9516161E-02,.9437583E-02,.9356012E-02,.9267042E-02,& - & .9652643E-02,.9569500E-02,.9487039E-02,.9401969E-02,.9310716E-02,& - & .9695422E-02,.9609692E-02,.9524686E-02,.9435966E-02,.9342924E-02,& - & .9727439E-02,.9637865E-02,.9550739E-02,.9460899E-02,.9364315E-02,& - & .9747348E-02,.9657887E-02,.9567816E-02,.9475420E-02,.9377002E-02,& - & .9759778E-02,.9668908E-02,.9576933E-02,.9481742E-02,.9380067E-02,& - & .9764468E-02,.9671597E-02,.9578772E-02,.9481823E-02,.9378210E-02,& - & .9763831E-02,.9670378E-02,.9575566E-02,.9476824E-02,.9370080E-02,& - & .9759671E-02,.9663673E-02,.9567437E-02,.9466585E-02,.9358136E-02,& - & .9749029E-02,.9653783E-02,.9555706E-02,.9452450E-02,.9342273E-02,& - & .9736435E-02,.9639659E-02,.9540533E-02,.9435413E-02,.9323567E-02,& - & .9720078E-02,.9623847E-02,.9522512E-02,.9415460E-02,.9302259E-02,& - & .9703088E-02,.9605298E-02,.9501404E-02,.9392140E-02,.9278916E-02,& - & .9686283E-02,.9587583E-02,.9483967E-02,.9371995E-02,.9257294E-02,& - & .9678111E-02,.9578966E-02,.9473567E-02,.9361585E-02,.9246698E-02,& - & .9679790E-02,.9580995E-02,.9474493E-02,.9363423E-02,.9247588E-02/ - - data absb(121:235, 8) / & - & .9697036E-02,.9597631E-02,.9491980E-02,.9381268E-02,.9266303E-02,& - & .9712567E-02,.9614449E-02,.9509960E-02,.9399294E-02,.9284125E-02,& - & .9728855E-02,.9630143E-02,.9527100E-02,.9417372E-02,.9302616E-02,& - & .9755136E-02,.9656175E-02,.9554532E-02,.9445454E-02,.9332069E-02,& - & .9781450E-02,.9682450E-02,.9581889E-02,.9475267E-02,.9362746E-02,& - & .9808399E-02,.9708959E-02,.9609987E-02,.9504452E-02,.9392809E-02,& - & .9839580E-02,.9740865E-02,.9642287E-02,.9538676E-02,.9428802E-02,& - & .9874370E-02,.9776400E-02,.9676193E-02,.9575430E-02,.9467798E-02,& - & .9908878E-02,.9809623E-02,.9710657E-02,.9611071E-02,.9505151E-02,& - & .9946962E-02,.9845757E-02,.9746231E-02,.9647315E-02,.9544139E-02,& - & .9988261E-02,.9885906E-02,.9786939E-02,.9687236E-02,.9586655E-02,& - & .1003101E-01,.9927336E-02,.9827361E-02,.9728363E-02,.9628271E-02,& - & .1007558E-01,.9968398E-02,.9867081E-02,.9768397E-02,.9669498E-02,& - & .1011578E-01,.1000878E-01,.9905269E-02,.9805950E-02,.9706828E-02,& - & .1015569E-01,.1004819E-01,.9942285E-02,.9841944E-02,.9742563E-02,& - & .1019452E-01,.1008719E-01,.9980576E-02,.9878353E-02,.9779624E-02,& - & .1023378E-01,.1012695E-01,.1001916E-01,.9915168E-02,.9815063E-02,& - & .1026952E-01,.1016297E-01,.1005517E-01,.9949717E-02,.9848721E-02,& - & .1030346E-01,.1019748E-01,.1008930E-01,.9983003E-02,.9880655E-02,& - & .1033774E-01,.1023094E-01,.1012441E-01,.1001809E-01,.9912916E-02,& - & .1037133E-01,.1026548E-01,.1015955E-01,.1005208E-01,.9945433E-02,& - & .1040238E-01,.1029750E-01,.1019014E-01,.1008328E-01,.9977541E-02,& - & .1041506E-01,.1031116E-01,.1020458E-01,.1009725E-01,.9990140E-02/ - -! --- - data forref(1:3,1: 8) / & - & .1889348E-07,.2790121E-06,.2442243E-05,.3917008E-06,.7957867E-06,& - & .1584630E-05,.1690886E-05,.1737327E-05,.5814421E-06,.4276674E-05,& - & .3754692E-05,.3297487E-06,.4845389E-05,.3046027E-05,.8469466E-06,& - & .5624835E-05,.1676442E-05,.3856211E-07,.3141158E-05,.1459015E-07,& - & .2568816E-07,.8749816E-12,.8199214E-12,.8132942E-12/ - -! the array selfref contains the coefficient of the water vapor -! self-continuum (including the energy term). the first index -! refers to temperature in 7.2 degree increments. for instance, -! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, -! etc. the second index runs over the g-channel (1 to 8). - - data selfref(1:10,1: 8) / & - & .1216369E-04,.7423490E-05,.4532882E-05,.2769295E-05,.1692770E-05,& - & .1035295E-05,.6335399E-06,.3879104E-06,.2376510E-06,.1456812E-06,& - & .1738951E-04,.1350041E-04,.1061362E-04,.8452065E-05,.6817644E-05,& - & .5568311E-05,.4602063E-05,.3845424E-05,.3245295E-05,.2763136E-05,& - & .2573945E-04,.2373710E-04,.2191428E-04,.2025397E-04,.1874100E-04,& - & .1736167E-04,.1610330E-04,.1495474E-04,.1390567E-04,.1294697E-04,& - & .5188697E-04,.4899932E-04,.4628324E-04,.4372800E-04,.4132363E-04,& - & .3906076E-04,.3693055E-04,.3492493E-04,.3303618E-04,.3125709E-04,& - & .3645284E-04,.3672976E-04,.3702492E-04,.3733989E-04,.3767626E-04,& - & .3803589E-04,.3842086E-04,.3883327E-04,.3927557E-04,.3975032E-04,& - & .1526953E-04,.1771468E-04,.2057485E-04,.2392454E-04,.2785266E-04,& - & .3246491E-04,.3788738E-04,.4427053E-04,.5179416E-04,.6067315E-04,& - & .1304688E-06,.2753468E-06,.5813077E-06,.1227665E-05,.2593570E-05,& - & .5480882E-05,.1158601E-04,.2449863E-04,.5181665E-04,.1096252E-03,& - & .2493662E-06,.2172185E-06,.1892149E-06,.1648213E-06,.1435736E-06,& - & .1250641E-06,.1089414E-06,.9489759E-07,.8266404E-07,.7200766E-07/ - -!........................................! - end module module_radsw_kgb24 ! -!========================================! - - -!========================================! - module module_radsw_kgb25 ! -!........................................! -! -! ********* the original program descriptions ********* ! -! ! -! originally by j.delamere, atmospheric & environmental research. ! -! revision: 2.4 ! -! band 25: 16000-22650 cm-1 (low - h2o; high - nothing) ! -! reformatted for f90 by jjmorcrette, ecmwf ! -! ! -! this table has been re-generated for reduced number of g-point ! -! by y.t.hou, ncep ! -! ! -! ********* ********* end description ********* ********* ! -! - use machine, only : kind_phys - use module_radsw_parameters, only : NG25 - -! - implicit none -! - private -! - integer, public :: MSA25 - parameter (MSA25=65) - - real (kind=kind_phys), public :: & - & absa(MSA25,NG25), rayl(NG25), abso3a(NG25), abso3b(NG25) - -! --- rayleigh extinction coefficient at v = cm-1. - data rayl (1: 6) / .9811320E-06,& - & .8256050E-06,.6146670E-06,.3838724E-06,.4417251E-06,.3613850E-06/ - -! --- o3 - data abso3a(1: 6) / .2326640E-01,& - & .5761540E-01,.1854021E+00,.3896100E+00,.3610619E+00,.4362158E+00/ - - data abso3b(1: 6) / .1769170E-01,& - & .4641850E-01,.1449232E+00,.3484920E+00,.4676420E+00,.5178092E+00/ - -! the array absa(65,NG25) (ka(5,13,NG25)) contains absorption coefs at -! the 16 chosen g-values for a range of pressure levels> ~100mb, -! temperatures, and binary species parameters (see taumol.f for definition). -! the first index in the array, js, runs from 1 to 9, and corresponds to -! different values of the binary species parameter. for instance, -! js=1 refers to dry air, js = 2 corresponds to the paramter value 1/8, -! js = 3 corresponds to the parameter value 2/8, etc. the second index -! in the array, jt, which runs from 1 to 5, corresponds to different -! temperatures. more specifically, jt = 3 means that the data are for -! the reference temperature tref for this pressure level, jt = 2 refers -! to tref-15, jt = 1 is for tref-30, jt = 4 is for tref+15, and jt = 5 -! is for tref+30. the third index, jp, runs from 1 to 13 and refers -! to the jpth reference pressure level (see taumol.f for these levels -! in mb). the fourth index, ig, goes from 1 to 6, and indicates -! which g-interval the absorption coefficients are for. - - data absa( 1: 65, 1) / & - & .1646100E-08,.1678200E-08,.1933900E-08,.1710000E-08,.1704500E-08,& - & .2875900E-08,.2946900E-08,.3378900E-08,.3435700E-08,.2883300E-08,& - & .5514800E-08,.5480800E-08,.5419000E-08,.6826000E-08,.5197200E-08,& - & .9533600E-08,.9455200E-08,.9300100E-08,.9096100E-08,.1445100E-07,& - & .1493000E-07,.1473600E-07,.1443200E-07,.1407400E-07,.2410200E-07,& - & .2277000E-07,.2230100E-07,.2177800E-07,.2119400E-07,.2056900E-07,& - & .3469900E-07,.3395100E-07,.3312400E-07,.3214400E-07,.3122000E-07,& - & .6233900E-07,.6040500E-07,.5954800E-07,.5821400E-07,.5697700E-07,& - & .1741100E-06,.1765400E-06,.1831500E-06,.1810000E-06,.1783900E-06,& - & .2352600E-06,.2272900E-06,.2194700E-06,.2118800E-06,.2045400E-06,& - & .2353500E-06,.2273700E-06,.2195600E-06,.2119600E-06,.2046100E-06,& - & .2353900E-06,.2274000E-06,.2195900E-06,.2119900E-06,.2046500E-06,& - & .2354300E-06,.2274400E-06,.2196200E-06,.2120200E-06,.2046700E-06/ - - data absa( 1: 65, 2) / & - & .6291200E-08,.6155900E-08,.8464000E-08,.5924000E-08,.5821700E-08,& - & .8374900E-08,.8075600E-08,.1162300E-07,.1127200E-07,.7363600E-08,& - & .1330400E-07,.1279500E-07,.1234300E-07,.2123500E-07,.1157700E-07,& - & .2070400E-07,.1973600E-07,.1890000E-07,.1822800E-07,.3160100E-07,& - & .3114900E-07,.2966900E-07,.2831800E-07,.2710100E-07,.4964900E-07,& - & .4571300E-07,.4351900E-07,.4148800E-07,.3991800E-07,.3829100E-07,& - & .7726500E-07,.7384800E-07,.7043700E-07,.6794500E-07,.6612700E-07,& - & .1575400E-06,.1566400E-06,.1537800E-06,.1502700E-06,.1463300E-06,& - & .1643900E-06,.1467800E-06,.1261000E-06,.1153200E-06,.1059100E-06,& - & .1436600E-06,.1350600E-06,.1258300E-06,.1177400E-06,.1101100E-06,& - & .1452100E-06,.1376600E-06,.1307200E-06,.1221800E-06,.1140000E-06,& - & .1452400E-06,.1376900E-06,.1307400E-06,.1224100E-06,.1155200E-06,& - & .1452500E-06,.1377000E-06,.1307500E-06,.1225200E-06,.1155300E-06/ - - data absa( 1: 65, 3) / & - & .2304255E-07,.2212848E-07,.4109493E-07,.2019160E-07,.1941596E-07,& - & .2701108E-07,.2633924E-07,.5665284E-07,.5516586E-07,.2490900E-07,& - & .4992253E-07,.4901988E-07,.4802034E-07,.7658263E-07,.4679826E-07,& - & .9936387E-07,.9737083E-07,.9572112E-07,.9398584E-07,.1435192E-06,& - & .1737489E-06,.1690329E-06,.1649946E-06,.1608759E-06,.2616677E-06,& - & .2850168E-06,.2771528E-06,.2703079E-06,.2636367E-06,.2572958E-06,& - & .4363192E-06,.4270658E-06,.4142017E-06,.4031191E-06,.3921783E-06,& - & .6694834E-06,.6560782E-06,.6423565E-06,.6305881E-06,.6197580E-06,& - & .1127398E-05,.1109264E-05,.1096811E-05,.1079010E-05,.1060076E-05,& - & .1142385E-05,.1123159E-05,.1103836E-05,.1083587E-05,.1063058E-05,& - & .1141922E-05,.1122126E-05,.1101516E-05,.1081516E-05,.1061329E-05,& - & .1142101E-05,.1122316E-05,.1101648E-05,.1081539E-05,.1060666E-05,& - & .1142284E-05,.1122439E-05,.1101810E-05,.1081628E-05,.1060802E-05/ - - data absa( 1: 65, 4) / & - & .5358826E-07,.5191800E-07,.1241794E-06,.4941069E-07,.4826537E-07,& - & .6634855E-07,.6497957E-07,.1011451E-06,.9587780E-07,.6034307E-07,& - & .1109051E-06,.1079549E-06,.1052181E-06,.1673772E-06,.9938209E-07,& - & .1837864E-06,.1778823E-06,.1716021E-06,.1661914E-06,.2696765E-06,& - & .2944786E-06,.2858136E-06,.2767250E-06,.2693989E-06,.4648876E-06,& - & .4455888E-06,.4336889E-06,.4201096E-06,.4076205E-06,.3956245E-06,& - & .6742110E-06,.6611647E-06,.6510830E-06,.6399340E-06,.6276101E-06,& - & .8969775E-06,.8864724E-06,.8790142E-06,.8698967E-06,.8588636E-06,& - & .7342734E-06,.7160851E-06,.6891067E-06,.6701000E-06,.6510138E-06,& - & .7386682E-06,.7215150E-06,.7046031E-06,.6851616E-06,.6677641E-06,& - & .7580174E-06,.7411749E-06,.7247261E-06,.7009916E-06,.6816196E-06,& - & .7649827E-06,.7506295E-06,.7339233E-06,.7090960E-06,.6870193E-06,& - & .7676832E-06,.7529800E-06,.7370035E-06,.7118011E-06,.6888372E-06/ - - data absa( 1: 65, 5) / & - & .7117654E-05,.7054566E-05,.8530292E-05,.6912687E-05,.6834460E-05,& - & .6579625E-05,.6521231E-05,.8074960E-05,.7892008E-05,.6316120E-05,& - & .5972427E-05,.5925015E-05,.5871889E-05,.7336016E-05,.5749214E-05,& - & .5324376E-05,.5290991E-05,.5251560E-05,.5205073E-05,.6531106E-05,& - & .4622548E-05,.4605694E-05,.4579758E-05,.4546281E-05,.5745046E-05,& - & .3863569E-05,.3864350E-05,.3857382E-05,.3842378E-05,.3819669E-05,& - & .3076464E-05,.3091729E-05,.3102707E-05,.3099905E-05,.3090770E-05,& - & .2816484E-05,.2825815E-05,.2821070E-05,.2804759E-05,.2789727E-05,& - & .6454490E-05,.6508164E-05,.6551126E-05,.6559912E-05,.6545487E-05,& - & .1257978E-04,.1269684E-04,.1274689E-04,.1276159E-04,.1276158E-04,& - & .1419438E-04,.1414710E-04,.1407662E-04,.1400149E-04,.1389726E-04,& - & .1419357E-04,.1414993E-04,.1408845E-04,.1402116E-04,.1393645E-04,& - & .1419415E-04,.1414965E-04,.1408763E-04,.1402335E-04,.1394694E-04/ - - data absa( 1: 65, 6) / & - & .1587872E-03,.1576306E-03,.1591069E-03,.1553587E-03,.1542553E-03,& - & .1690035E-03,.1677837E-03,.1693876E-03,.1678861E-03,.1641727E-03,& - & .1796181E-03,.1782899E-03,.1769631E-03,.1785679E-03,.1743591E-03,& - & .1896678E-03,.1882560E-03,.1868296E-03,.1854223E-03,.1871320E-03,& - & .1991122E-03,.1976085E-03,.1961276E-03,.1946438E-03,.1968553E-03,& - & .2076995E-03,.2061273E-03,.2045536E-03,.2029803E-03,.2014317E-03,& - & .2138594E-03,.2121941E-03,.2104844E-03,.2088605E-03,.2072504E-03,& - & .2079296E-03,.2064979E-03,.2051095E-03,.2037779E-03,.2023372E-03,& - & .1359973E-03,.1343382E-03,.1327011E-03,.1314602E-03,.1305188E-03,& - & .2924225E-04,.2660282E-04,.2493377E-04,.2376549E-04,.2266769E-04,& - & .7730806E-06,.9895626E-06,.1411477E-05,.1894061E-05,.2654902E-05,& - & .6900584E-06,.7953827E-06,.1063045E-05,.1425467E-05,.1894041E-05,& - & .6604518E-06,.7863470E-06,.1049399E-05,.1366331E-05,.1711475E-05/ - -!........................................! - end module module_radsw_kgb25 ! -!========================================! - - -!========================================! - module module_radsw_kgb26 ! -!........................................! -! -! ********* the original program descriptions ********* ! -! ! -! originally by j.delamere, atmospheric & environmental research. ! -! revision: 2.4 ! -! band 26: 22650-29000 cm-1 (low - nothing; high - nothing) ! -! reformatted for f90 by jjmorcrette, ecmwf ! -! ! -! this table has been re-generated for reduced number of g-point ! -! by y.t.hou, ncep ! -! ! -! ********* ********* end description ********* ********* ! -! - use machine, only : kind_phys - use module_radsw_parameters, only : NG26 - -! - implicit none -! - private -! - real (kind=kind_phys), public :: rayl(NG26) - -! --- rayleigh extinction coefficient at all v - data rayl (1: 6) / .1212630E-05,& - & .1434280E-05,.1799798E-05,.2307617E-05,.2814376E-05,.3092339E-05/ - -!........................................! - end module module_radsw_kgb26 ! -!========================================! - - -!========================================! - module module_radsw_kgb27 ! -!........................................! -! -! ********* the original program descriptions ********* ! -! ! -! originally by j.delamere, atmospheric & environmental research. ! -! revision: 2.4 ! -! band 27: 29000-38000 cm-1 (low - o3; high - o3) -! reformatted for f90 by jjmorcrette, ecmwf ! -! ! -! this table has been re-generated for reduced number of g-point ! -! by y.t.hou, ncep ! -! ! -! ********* ********* end description ********* ********* ! -! - use machine, only : kind_phys - use module_radsw_parameters, only : NG27 - -! - implicit none -! - private -! - integer, public :: MSA27, MSB27 - parameter (MSA27=65, MSB27=235) - - real (kind=kind_phys), public :: & - & absa(MSA27,NG27), absb(MSB27,NG27), rayl(NG27) - -! --- rayleigh extinction coefficient at v = cm-1. - data rayl (1: 8) / .3445340E-05,.4144800E-05,.4950690E-05,& - & .5812040E-05,.6697480E-05,.7564880E-05,.8886761E-05,.9744758E-05/ - -! the array absa(65,NG27) (ka(5,13,NG27)) contains absorption coefs at -! the 16 chosen g-values for a range of pressure levels> ~100mb, -! temperatures, and binary species parameters (see taumol.f for definition). -! the first index in the array, js, runs from 1 to 9, and corresponds to -! different values of the binary species parameter. for instance, -! js=1 refers to dry air, js = 2 corresponds to the paramter value 1/8, -! js = 3 corresponds to the parameter value 2/8, etc. the second index -! in the array, jt, which runs from 1 to 5, corresponds to different -! temperatures. more specifically, jt = 3 means that the data are for -! the reference temperature tref for this pressure level, jt = 2 refers -! to tref-15, jt = 1 is for tref-30, jt = 4 is for tref+15, and jt = 5 -! is for tref+30. the third index, jp, runs from 1 to 13 and refers -! to the jpth reference pressure level (see taumol.f for these levels -! in mb). the fourth index, ig, goes from 1 to 8, and indicates -! which g-interval the absorption coefficients are for. - - data absa( 1: 65, 1) / & - & .2290700E+00,.2562500E+00,.2877900E+00,.3237600E+00,.3642600E+00,& - & .2191300E+00,.2444500E+00,.2742200E+00,.3083200E+00,.3469400E+00,& - & .2060200E+00,.2286400E+00,.2557400E+00,.2872100E+00,.3231000E+00,& - & .1937900E+00,.2135200E+00,.2377100E+00,.2664300E+00,.2994000E+00,& - & .1836900E+00,.2006100E+00,.2220000E+00,.2478600E+00,.2781600E+00,& - & .1751700E+00,.1892000E+00,.2077100E+00,.2306900E+00,.2581700E+00,& - & .1688800E+00,.1798800E+00,.1955900E+00,.2157700E+00,.2404200E+00,& - & .1644200E+00,.1727300E+00,.1856500E+00,.2031500E+00,.2251200E+00,& - & .1615900E+00,.1673800E+00,.1775200E+00,.1924200E+00,.2117900E+00,& - & .1603700E+00,.1640200E+00,.1720400E+00,.1846300E+00,.2018300E+00,& - & .1603600E+00,.1639900E+00,.1719800E+00,.1845500E+00,.2017300E+00,& - & .1603600E+00,.1639900E+00,.1719800E+00,.1845500E+00,.2017300E+00,& - & .1603600E+00,.1639900E+00,.1719800E+00,.1845500E+00,.2017300E+00/ - - data absa( 1: 65, 2) / & - & .2071600E+01,.2192500E+01,.2332700E+01,.2492100E+01,.2672600E+01,& - & .2027200E+01,.2140100E+01,.2272300E+01,.2423800E+01,.2595000E+01,& - & .1968400E+01,.2069700E+01,.2190200E+01,.2330100E+01,.2489200E+01,& - & .1913300E+01,.2002100E+01,.2110100E+01,.2237500E+01,.2384200E+01,& - & .1867300E+01,.1944100E+01,.2040000E+01,.2155300E+01,.2289800E+01,& - & .1827700E+01,.1892500E+01,.1976000E+01,.2078800E+01,.2200900E+01,& - & .1796300E+01,.1849700E+01,.1921400E+01,.2012100E+01,.2122200E+01,& - & .1774900E+01,.1815600E+01,.1876300E+01,.1955500E+01,.2054000E+01,& - & .1760000E+01,.1788500E+01,.1838800E+01,.1907100E+01,.1994300E+01,& - & .1752600E+01,.1772900E+01,.1812100E+01,.1871600E+01,.1949600E+01,& - & .1752500E+01,.1772700E+01,.1811900E+01,.1871200E+01,.1949100E+01,& - & .1752500E+01,.1772700E+01,.1811900E+01,.1871200E+01,.1949100E+01,& - & .1752500E+01,.1772700E+01,.1811900E+01,.1871200E+01,.1949100E+01/ - - data absa( 1: 65, 3) / & - & .1218900E+02,.1261900E+02,.1311000E+02,.1366300E+02,.1427500E+02,& - & .1203000E+02,.1243400E+02,.1289900E+02,.1342700E+02,.1401500E+02,& - & .1181600E+02,.1218300E+02,.1261100E+02,.1310100E+02,.1365300E+02,& - & .1161100E+02,.1193800E+02,.1232700E+02,.1277700E+02,.1328900E+02,& - & .1143700E+02,.1172600E+02,.1207600E+02,.1248800E+02,.1296100E+02,& - & .1128400E+02,.1153300E+02,.1184300E+02,.1221500E+02,.1264900E+02,& - & .1116000E+02,.1137000E+02,.1164100E+02,.1197500E+02,.1237000E+02,& - & .1106300E+02,.1123700E+02,.1147100E+02,.1176800E+02,.1212600E+02,& - & .1099000E+02,.1112900E+02,.1132700E+02,.1158800E+02,.1191000E+02,& - & .1094500E+02,.1105300E+02,.1122300E+02,.1145400E+02,.1174600E+02,& - & .1094500E+02,.1105200E+02,.1122200E+02,.1145200E+02,.1174400E+02,& - & .1094500E+02,.1105200E+02,.1122200E+02,.1145200E+02,.1174400E+02,& - & .1094500E+02,.1105200E+02,.1122200E+02,.1145200E+02,.1174400E+02/ - - data absa( 1: 65, 4) / & - & .5505700E+02,.5614300E+02,.5736400E+02,.5871900E+02,.6020800E+02,& - & .5464700E+02,.5567700E+02,.5684200E+02,.5814200E+02,.5957500E+02,& - & .5409000E+02,.5503900E+02,.5612300E+02,.5734200E+02,.5869400E+02,& - & .5354800E+02,.5441000E+02,.5540800E+02,.5653900E+02,.5780500E+02,& - & .5307400E+02,.5385300E+02,.5476600E+02,.5581300E+02,.5699500E+02,& - & .5264400E+02,.5333600E+02,.5416200E+02,.5512300E+02,.5621800E+02,& - & .5227900E+02,.5288700E+02,.5362900E+02,.5450500E+02,.5551600E+02,& - & .5197900E+02,.5250700E+02,.5316800E+02,.5396500E+02,.5489500E+02,& - & .5173400E+02,.5218300E+02,.5276700E+02,.5348500E+02,.5433700E+02,& - & .5156500E+02,.5194800E+02,.5246700E+02,.5312000E+02,.5390700E+02,& - & .5156300E+02,.5194600E+02,.5246400E+02,.5311600E+02,.5390200E+02,& - & .5156300E+02,.5194600E+02,.5246400E+02,.5311600E+02,.5390200E+02,& - & .5156300E+02,.5194600E+02,.5246400E+02,.5311600E+02,.5390200E+02/ - - data absa( 1: 65, 5) / & - & .1779400E+03,.1797300E+03,.1816400E+03,.1836600E+03,.1858100E+03,& - & .1772400E+03,.1789800E+03,.1808300E+03,.1828100E+03,.1849100E+03,& - & .1762400E+03,.1779100E+03,.1797000E+03,.1816000E+03,.1836300E+03,& - & .1752300E+03,.1768200E+03,.1785300E+03,.1803600E+03,.1823100E+03,& - & .1742900E+03,.1758100E+03,.1774400E+03,.1792000E+03,.1810700E+03,& - & .1733800E+03,.1748200E+03,.1763800E+03,.1780500E+03,.1798500E+03,& - & .1725300E+03,.1739000E+03,.1753900E+03,.1769900E+03,.1787100E+03,& - & .1717700E+03,.1730700E+03,.1744800E+03,.1760100E+03,.1776700E+03,& - & .1710700E+03,.1723000E+03,.1736400E+03,.1751100E+03,.1766900E+03,& - & .1705200E+03,.1716900E+03,.1729800E+03,.1743800E+03,.1759100E+03,& - & .1705100E+03,.1716800E+03,.1729700E+03,.1743700E+03,.1759000E+03,& - & .1705100E+03,.1716800E+03,.1729700E+03,.1743700E+03,.1759000E+03,& - & .1705100E+03,.1716800E+03,.1729700E+03,.1743700E+03,.1759000E+03/ - - data absa( 1: 65, 6) / & - & .3768000E+05,.3680100E+05,.3601100E+05,.3529800E+05,.3471500E+05,& - & .3928600E+03,.3946300E+03,.3961600E+03,.3974800E+03,.3985800E+03,& - & .3916900E+03,.3935900E+03,.3952600E+03,.3967100E+03,.3979400E+03,& - & .3903400E+03,.3923900E+03,.3942100E+03,.3958000E+03,.3971700E+03,& - & .3889500E+03,.3911300E+03,.3930900E+03,.3948300E+03,.3963400E+03,& - & .3874200E+03,.3897500E+03,.3918500E+03,.3937300E+03,.3953900E+03,& - & .3858500E+03,.3883200E+03,.3905600E+03,.3925800E+03,.3943800E+03,& - & .3842600E+03,.3868600E+03,.3892400E+03,.3914000E+03,.3933300E+03,& - & .3826400E+03,.3853800E+03,.3878900E+03,.3901700E+03,.3922300E+03,& - & .3812300E+03,.3840800E+03,.3867000E+03,.3890900E+03,.3912600E+03,& - & .3812200E+03,.3840600E+03,.3866800E+03,.3890800E+03,.3912500E+03,& - & .3812200E+03,.3840600E+03,.3866800E+03,.3890800E+03,.3912500E+03,& - & .3812200E+03,.3840600E+03,.3866800E+03,.3890800E+03,.3912500E+03/ - - data absa( 1: 65, 7) / & - & .5138014E+07,.5012023E+07,.4897696E+07,.4788104E+07,.4690601E+07,& - & .7716789E+03,.7727576E+03,.7738234E+03,.7748824E+03,.7760097E+03,& - & .7709970E+03,.7720920E+03,.7731683E+03,.7742329E+03,.7752795E+03,& - & .7702703E+03,.7713814E+03,.7724638E+03,.7735352E+03,.7745939E+03,& - & .7695623E+03,.7706840E+03,.7717805E+03,.7728581E+03,.7739261E+03,& - & .7688269E+03,.7699602E+03,.7710739E+03,.7721618E+03,.7732324E+03,& - & .7681233E+03,.7692532E+03,.7703760E+03,.7714779E+03,.7725630E+03,& - & .7674388E+03,.7685763E+03,.7697000E+03,.7708216E+03,.7719092E+03,& - & .7667706E+03,.7679148E+03,.7690491E+03,.7701722E+03,.7712802E+03,& - & .7662119E+03,.7673655E+03,.7684992E+03,.7696303E+03,.7707457E+03,& - & .7662075E+03,.7673571E+03,.7684953E+03,.7696203E+03,.7707387E+03,& - & .7662135E+03,.7673563E+03,.7684924E+03,.7696200E+03,.7707387E+03,& - & .7662080E+03,.7673567E+03,.7684935E+03,.7696200E+03,.7707387E+03/ - - data absa( 1: 65, 8) / & - & .1263473E+08,.1241774E+08,.1224143E+08,.1219450E+08,.1211569E+08,& - & .1001941E+04,.1000716E+04,.9984375E+03,.9948240E+03,.9885902E+03,& - & .1002595E+04,.1001895E+04,.1000220E+04,.9973344E+03,.9934343E+03,& - & .1002661E+04,.1002592E+04,.1001621E+04,.9995163E+03,.9962347E+03,& - & .1002279E+04,.1002873E+04,.1002423E+04,.1001059E+04,.9984745E+03,& - & .1001370E+04,.1002671E+04,.1002871E+04,.1002175E+04,.1000396E+04,& - & .9999024E+03,.1002012E+04,.1002937E+04,.1002823E+04,.1001683E+04,& - & .9980806E+03,.1000892E+04,.1002512E+04,.1003003E+04,.1002533E+04,& - & .9959107E+03,.9994193E+03,.1001722E+04,.1002845E+04,.1002953E+04,& - & .9937920E+03,.9978415E+03,.1000716E+04,.1002445E+04,.1003004E+04,& - & .9937640E+03,.9978135E+03,.1000658E+04,.1002444E+04,.1003004E+04,& - & .9936612E+03,.9978143E+03,.1000698E+04,.1002407E+04,.1003004E+04,& - & .9937589E+03,.9978125E+03,.1000708E+04,.1002433E+04,.1003006E+04/ - -! the array absb(235,8) (kb(5,13:59,8)) contains absorption coefs at -! the 16 chosen g-values for a range of pressure levels < ~100mb and -! temperatures. the first index in the array, jt, which runs from 1 to 5, -! corresponds to different temperatures. more specifically, jt = 3 means -! that the data are for the reference temperature tref for this pressure -! level, jt = 2 refers to the temperature tref-15, jt = 1 is for -! tref-30, jt = 4 is for tref+15, and jt = 5 is for tref+30. -! the second index, jp, runs from 13 to 59 and refers to the jpth -! reference pressure level (see taumol.f for the value of these -! pressure levels in mb). the third index, ig, goes from 1 to 8, -! and tells us which g-interval the absorption coefficients are for. - - data absb( 1:120, 1) / & - & .1603600E+00,.1639900E+00,.1719800E+00,.1845500E+00,.2017300E+00,& - & .1605000E+00,.1645400E+00,.1729200E+00,.1859200E+00,.2035100E+00,& - & .1607100E+00,.1651900E+00,.1740000E+00,.1875000E+00,.2055400E+00,& - & .1609800E+00,.1659300E+00,.1751700E+00,.1892100E+00,.2077200E+00,& - & .1612900E+00,.1667000E+00,.1764200E+00,.1909300E+00,.2099100E+00,& - & .1616400E+00,.1675000E+00,.1777100E+00,.1926700E+00,.2121100E+00,& - & .1620300E+00,.1683200E+00,.1790100E+00,.1944300E+00,.2143100E+00,& - & .1625500E+00,.1693400E+00,.1805900E+00,.1965300E+00,.2169400E+00,& - & .1631300E+00,.1704400E+00,.1822500E+00,.1987300E+00,.2196700E+00,& - & .1641600E+00,.1722700E+00,.1849800E+00,.2022900E+00,.2240600E+00,& - & .1653900E+00,.1743100E+00,.1879600E+00,.2061200E+00,.2287500E+00,& - & .1668400E+00,.1766600E+00,.1912500E+00,.2103200E+00,.2338500E+00,& - & .1685600E+00,.1793900E+00,.1949300E+00,.2149500E+00,.2394300E+00,& - & .1706700E+00,.1826000E+00,.1991900E+00,.2202400E+00,.2457800E+00,& - & .1730600E+00,.1861300E+00,.2037700E+00,.2258800E+00,.2524800E+00,& - & .1757000E+00,.1899400E+00,.2086500E+00,.2318400E+00,.2595200E+00,& - & .1788200E+00,.1941700E+00,.2139900E+00,.2382800E+00,.2670800E+00,& - & .1822300E+00,.1987000E+00,.2196400E+00,.2450500E+00,.2749200E+00,& - & .1860200E+00,.2036400E+00,.2257200E+00,.2522900E+00,.2832500E+00,& - & .1901800E+00,.2089500E+00,.2321900E+00,.2599400E+00,.2920000E+00,& - & .1946600E+00,.2146100E+00,.2390200E+00,.2679500E+00,.3011400E+00,& - & .1988000E+00,.2197600E+00,.2452000E+00,.2750900E+00,.3093200E+00,& - & .2012900E+00,.2228300E+00,.2488600E+00,.2793100E+00,.3141200E+00,& - & .2017000E+00,.2233400E+00,.2494600E+00,.2800000E+00,.3149200E+00/ - - data absb(121:235, 1) / & - & .1992000E+00,.2202600E+00,.2457900E+00,.2757800E+00,.3101000E+00,& - & .1966200E+00,.2170600E+00,.2419700E+00,.2713500E+00,.3050400E+00,& - & .1941400E+00,.2139600E+00,.2382400E+00,.2670400E+00,.3001000E+00,& - & .1900300E+00,.2087700E+00,.2319700E+00,.2596800E+00,.2917100E+00,& - & .1859700E+00,.2035700E+00,.2256400E+00,.2521900E+00,.2831400E+00,& - & .1822000E+00,.1986500E+00,.2195800E+00,.2449800E+00,.2748400E+00,& - & .1779800E+00,.1930400E+00,.2125700E+00,.2365700E+00,.2651000E+00,& - & .1739700E+00,.1874600E+00,.2054800E+00,.2279800E+00,.2549600E+00,& - & .1705300E+00,.1823900E+00,.1989000E+00,.2198900E+00,.2453500E+00,& - & .1673900E+00,.1775400E+00,.1924500E+00,.2118300E+00,.2356800E+00,& - & .1645400E+00,.1729200E+00,.1859200E+00,.2035100E+00,.2255600E+00,& - & .1623900E+00,.1690300E+00,.1801100E+00,.1959000E+00,.2161500E+00,& - & .1609500E+00,.1658400E+00,.1750400E+00,.1890200E+00,.2074700E+00,& - & .1602500E+00,.1634800E+00,.1710900E+00,.1832200E+00,.2000000E+00,& - & .1602100E+00,.1617900E+00,.1678100E+00,.1782100E+00,.1933500E+00,& - & .1607800E+00,.1606800E+00,.1651100E+00,.1738700E+00,.1873100E+00,& - & .1619700E+00,.1601800E+00,.1629900E+00,.1701700E+00,.1818600E+00,& - & .1636200E+00,.1602600E+00,.1615500E+00,.1672900E+00,.1773800E+00,& - & .1657000E+00,.1608300E+00,.1606400E+00,.1649800E+00,.1736500E+00,& - & .1682500E+00,.1618700E+00,.1602000E+00,.1631100E+00,.1704100E+00,& - & .1712900E+00,.1634000E+00,.1602300E+00,.1616900E+00,.1676100E+00,& - & .1746200E+00,.1652900E+00,.1606900E+00,.1607700E+00,.1653500E+00,& - & .1760700E+00,.1661700E+00,.1610000E+00,.1605100E+00,.1645600E+00/ - - data absb( 1:120, 2) / & - & .1752500E+01,.1772700E+01,.1811900E+01,.1871200E+01,.1949100E+01,& - & .1753600E+01,.1775500E+01,.1816500E+01,.1877500E+01,.1957100E+01,& - & .1754900E+01,.1778700E+01,.1821900E+01,.1884700E+01,.1966200E+01,& - & .1756500E+01,.1781900E+01,.1827800E+01,.1892500E+01,.1976100E+01,& - & .1758300E+01,.1785000E+01,.1833600E+01,.1900300E+01,.1985900E+01,& - & .1760300E+01,.1789100E+01,.1839600E+01,.1908200E+01,.1995700E+01,& - & .1762400E+01,.1793400E+01,.1845700E+01,.1916200E+01,.2005600E+01,& - & .1765200E+01,.1798600E+01,.1853000E+01,.1925700E+01,.2017400E+01,& - & .1768300E+01,.1804200E+01,.1860700E+01,.1935600E+01,.2029600E+01,& - & .1773600E+01,.1813300E+01,.1873200E+01,.1951600E+01,.2049200E+01,& - & .1779600E+01,.1823400E+01,.1886800E+01,.1968900E+01,.2070200E+01,& - & .1785700E+01,.1834700E+01,.1901800E+01,.1987700E+01,.2092900E+01,& - & .1794600E+01,.1847500E+01,.1918500E+01,.2008500E+01,.2117800E+01,& - & .1805300E+01,.1862300E+01,.1937700E+01,.2032200E+01,.2146000E+01,& - & .1817200E+01,.1878500E+01,.1958300E+01,.2057400E+01,.2175700E+01,& - & .1830300E+01,.1895900E+01,.1980200E+01,.2083900E+01,.2206900E+01,& - & .1844800E+01,.1915000E+01,.2004200E+01,.2112600E+01,.2240400E+01,& - & .1860600E+01,.1935500E+01,.2029500E+01,.2142800E+01,.2275400E+01,& - & .1878000E+01,.1957700E+01,.2056600E+01,.2174900E+01,.2312500E+01,& - & .1896900E+01,.1981600E+01,.2085500E+01,.2208800E+01,.2351400E+01,& - & .1917200E+01,.2006900E+01,.2116000E+01,.2244300E+01,.2392000E+01,& - & .1935900E+01,.2030000E+01,.2143400E+01,.2276200E+01,.2428200E+01,& - & .1947100E+01,.2043700E+01,.2159700E+01,.2294900E+01,.2449500E+01,& - & .1949000E+01,.2046000E+01,.2162400E+01,.2298000E+01,.2453000E+01/ - - data absb(121:235, 2) / & - & .1937700E+01,.2032200E+01,.2146100E+01,.2279200E+01,.2431700E+01,& - & .1926100E+01,.2017900E+01,.2129100E+01,.2259500E+01,.2409300E+01,& - & .1914900E+01,.2004000E+01,.2112500E+01,.2240200E+01,.2387300E+01,& - & .1896300E+01,.1980700E+01,.2084500E+01,.2207600E+01,.2350100E+01,& - & .1877800E+01,.1957400E+01,.2056300E+01,.2174500E+01,.2312000E+01,& - & .1860400E+01,.1935200E+01,.2029200E+01,.2142500E+01,.2275000E+01,& - & .1840900E+01,.1909900E+01,.1997800E+01,.2105000E+01,.2231500E+01,& - & .1821700E+01,.1884500E+01,.1966000E+01,.2066700E+01,.2186700E+01,& - & .1804600E+01,.1861300E+01,.1936400E+01,.2030600E+01,.2144100E+01,& - & .1788600E+01,.1838900E+01,.1907200E+01,.1994500E+01,.2101100E+01,& - & .1775500E+01,.1816500E+01,.1877500E+01,.1957100E+01,.2055900E+01,& - & .1764400E+01,.1797000E+01,.1850800E+01,.1922800E+01,.2013900E+01,& - & .1756300E+01,.1781600E+01,.1827100E+01,.1891600E+01,.1974900E+01,& - & .1751700E+01,.1770200E+01,.1807400E+01,.1865100E+01,.1941300E+01,& - & .1750400E+01,.1761100E+01,.1790800E+01,.1842000E+01,.1911300E+01,& - & .1752300E+01,.1754700E+01,.1778300E+01,.1821200E+01,.1883900E+01,& - & .1756600E+01,.1751000E+01,.1767500E+01,.1802800E+01,.1858900E+01,& - & .1762300E+01,.1750700E+01,.1759800E+01,.1788100E+01,.1838100E+01,& - & .1769100E+01,.1752400E+01,.1754400E+01,.1777700E+01,.1820100E+01,& - & .1777600E+01,.1756200E+01,.1751200E+01,.1768200E+01,.1804000E+01,& - & .1788100E+01,.1761600E+01,.1750500E+01,.1760600E+01,.1789700E+01,& - & .1799600E+01,.1767800E+01,.1752000E+01,.1755200E+01,.1779400E+01,& - & .1804500E+01,.1770700E+01,.1753000E+01,.1753600E+01,.1775600E+01/ - - data absb( 1:120, 3) / & - & .1094500E+02,.1105200E+02,.1122200E+02,.1145200E+02,.1174400E+02,& - & .1095200E+02,.1106500E+02,.1124000E+02,.1147600E+02,.1177400E+02,& - & .1096100E+02,.1108000E+02,.1126100E+02,.1150300E+02,.1180700E+02,& - & .1097100E+02,.1109700E+02,.1128400E+02,.1153300E+02,.1184400E+02,& - & .1098100E+02,.1111500E+02,.1130700E+02,.1156200E+02,.1187900E+02,& - & .1099200E+02,.1113200E+02,.1133100E+02,.1159200E+02,.1191500E+02,& - & .1100300E+02,.1114900E+02,.1135400E+02,.1162200E+02,.1195100E+02,& - & .1101700E+02,.1117000E+02,.1138200E+02,.1165700E+02,.1199400E+02,& - & .1103100E+02,.1119200E+02,.1141200E+02,.1169400E+02,.1203800E+02,& - & .1105600E+02,.1122800E+02,.1146000E+02,.1175400E+02,.1210900E+02,& - & .1108500E+02,.1126700E+02,.1151100E+02,.1181700E+02,.1218400E+02,& - & .1111800E+02,.1131200E+02,.1156800E+02,.1188600E+02,.1226600E+02,& - & .1115400E+02,.1136100E+02,.1163000E+02,.1196200E+02,.1235400E+02,& - & .1119600E+02,.1141800E+02,.1170200E+02,.1204800E+02,.1245500E+02,& - & .1124300E+02,.1148000E+02,.1177800E+02,.1213800E+02,.1256000E+02,& - & .1129400E+02,.1154500E+02,.1185900E+02,.1223400E+02,.1267000E+02,& - & .1135100E+02,.1161700E+02,.1194600E+02,.1233600E+02,.1278800E+02,& - & .1141100E+02,.1169400E+02,.1203800E+02,.1244300E+02,.1291000E+02,& - & .1147800E+02,.1177600E+02,.1213600E+02,.1255700E+02,.1304000E+02,& - & .1154900E+02,.1186400E+02,.1223900E+02,.1267700E+02,.1317500E+02,& - & .1162600E+02,.1195600E+02,.1234800E+02,.1280100E+02,.1331600E+02,& - & .1169500E+02,.1204000E+02,.1244600E+02,.1291300E+02,.1344200E+02,& - & .1173700E+02,.1208900E+02,.1250300E+02,.1297900E+02,.1351500E+02,& - & .1174400E+02,.1209800E+02,.1251300E+02,.1298900E+02,.1352800E+02/ - - data absb(121:235, 3) / & - & .1170200E+02,.1204800E+02,.1245500E+02,.1292400E+02,.1345400E+02,& - & .1165900E+02,.1199600E+02,.1239500E+02,.1285500E+02,.1337600E+02,& - & .1161700E+02,.1194600E+02,.1233600E+02,.1278700E+02,.1330000E+02,& - & .1154700E+02,.1186100E+02,.1223600E+02,.1267300E+02,.1317100E+02,& - & .1147700E+02,.1177500E+02,.1213400E+02,.1255500E+02,.1303800E+02,& - & .1141100E+02,.1169300E+02,.1203700E+02,.1244200E+02,.1290900E+02,& - & .1133500E+02,.1159800E+02,.1192300E+02,.1230900E+02,.1275700E+02,& - & .1126100E+02,.1150300E+02,.1180700E+02,.1217200E+02,.1259900E+02,& - & .1119300E+02,.1141400E+02,.1169700E+02,.1204200E+02,.1244800E+02,& - & .1112900E+02,.1132800E+02,.1158800E+02,.1191100E+02,.1229500E+02,& - & .1106500E+02,.1124000E+02,.1147600E+02,.1177400E+02,.1213300E+02,& - & .1101200E+02,.1116300E+02,.1137400E+02,.1164700E+02,.1198100E+02,& - & .1096900E+02,.1109500E+02,.1128200E+02,.1153000E+02,.1183900E+02,& - & .1093800E+02,.1104000E+02,.1120400E+02,.1142900E+02,.1171500E+02,& - & .1091600E+02,.1099600E+02,.1113800E+02,.1134000E+02,.1160400E+02,& - & .1090000E+02,.1096000E+02,.1107900E+02,.1125900E+02,.1150000E+02,& - & .1089400E+02,.1093200E+02,.1102800E+02,.1118600E+02,.1140500E+02,& - & .1089500E+02,.1091200E+02,.1098900E+02,.1112700E+02,.1132500E+02,& - & .1090300E+02,.1090000E+02,.1095800E+02,.1107500E+02,.1125500E+02,& - & .1092100E+02,.1089400E+02,.1093300E+02,.1103100E+02,.1119100E+02,& - & .1094400E+02,.1089400E+02,.1091400E+02,.1099300E+02,.1113400E+02,& - & .1097200E+02,.1090100E+02,.1090200E+02,.1096300E+02,.1108400E+02,& - & .1098400E+02,.1090600E+02,.1089800E+02,.1095200E+02,.1106600E+02/ - - data absb( 1:120, 4) / & - & .5156300E+02,.5194600E+02,.5246400E+02,.5311600E+02,.5390200E+02,& - & .5159300E+02,.5198700E+02,.5251700E+02,.5318200E+02,.5398000E+02,& - & .5162600E+02,.5203500E+02,.5257900E+02,.5325600E+02,.5406900E+02,& - & .5166400E+02,.5208700E+02,.5264400E+02,.5333700E+02,.5416300E+02,& - & .5170100E+02,.5213800E+02,.5271000E+02,.5341600E+02,.5425700E+02,& - & .5174000E+02,.5219100E+02,.5277600E+02,.5349600E+02,.5435100E+02,& - & .5177900E+02,.5224400E+02,.5284300E+02,.5357600E+02,.5444400E+02,& - & .5182700E+02,.5230700E+02,.5292200E+02,.5367100E+02,.5455500E+02,& - & .5187700E+02,.5237300E+02,.5300400E+02,.5377000E+02,.5466900E+02,& - & .5195900E+02,.5248100E+02,.5313600E+02,.5392700E+02,.5485100E+02,& - & .5204900E+02,.5259600E+02,.5327800E+02,.5409400E+02,.5504400E+02,& - & .5214800E+02,.5272300E+02,.5343100E+02,.5427400E+02,.5525200E+02,& - & .5225900E+02,.5286200E+02,.5359900E+02,.5447100E+02,.5547700E+02,& - & .5238700E+02,.5302200E+02,.5379000E+02,.5469300E+02,.5573000E+02,& - & .5252500E+02,.5319100E+02,.5399200E+02,.5492600E+02,.5599500E+02,& - & .5267200E+02,.5337100E+02,.5420300E+02,.5517000E+02,.5627100E+02,& - & .5283300E+02,.5356500E+02,.5443000E+02,.5543000E+02,.5656500E+02,& - & .5300300E+02,.5376800E+02,.5466800E+02,.5570200E+02,.5687000E+02,& - & .5318600E+02,.5398600E+02,.5492000E+02,.5598800E+02,.5719000E+02,& - & .5338100E+02,.5421600E+02,.5518400E+02,.5628700E+02,.5752500E+02,& - & .5358700E+02,.5445700E+02,.5546000E+02,.5659900E+02,.5787100E+02,& - & .5377300E+02,.5467300E+02,.5570700E+02,.5687600E+02,.5817900E+02,& - & .5388300E+02,.5480000E+02,.5585200E+02,.5703900E+02,.5835900E+02,& - & .5390100E+02,.5482200E+02,.5587600E+02,.5706600E+02,.5838900E+02/ - - data absb(121:235, 4) / & - & .5379100E+02,.5469400E+02,.5573100E+02,.5690300E+02,.5820800E+02,& - & .5367600E+02,.5456000E+02,.5557800E+02,.5673100E+02,.5801800E+02,& - & .5356300E+02,.5442900E+02,.5542900E+02,.5656300E+02,.5783200E+02,& - & .5337500E+02,.5420800E+02,.5517500E+02,.5627700E+02,.5751300E+02,& - & .5318400E+02,.5398300E+02,.5491600E+02,.5598400E+02,.5718600E+02,& - & .5300100E+02,.5376600E+02,.5466500E+02,.5569900E+02,.5686600E+02,& - & .5279000E+02,.5351300E+02,.5437000E+02,.5536200E+02,.5648800E+02,& - & .5257700E+02,.5325400E+02,.5406600E+02,.5501200E+02,.5609300E+02,& - & .5237900E+02,.5301100E+02,.5377700E+02,.5467800E+02,.5571300E+02,& - & .5218400E+02,.5276800E+02,.5348600E+02,.5433900E+02,.5532600E+02,& - & .5198700E+02,.5251700E+02,.5318200E+02,.5398000E+02,.5491300E+02,& - & .5181200E+02,.5228800E+02,.5289800E+02,.5364300E+02,.5452200E+02,& - & .5165900E+02,.5208100E+02,.5263700E+02,.5332700E+02,.5415200E+02,& - & .5153500E+02,.5190600E+02,.5241200E+02,.5305200E+02,.5382600E+02,& - & .5143300E+02,.5175500E+02,.5221100E+02,.5280200E+02,.5352700E+02,& - & .5134900E+02,.5162200E+02,.5202900E+02,.5257100E+02,.5324700E+02,& - & .5128500E+02,.5150700E+02,.5186500E+02,.5235800E+02,.5298500E+02,& - & .5124000E+02,.5141700E+02,.5173000E+02,.5217800E+02,.5276000E+02,& - & .5121100E+02,.5134600E+02,.5161500E+02,.5202000E+02,.5255900E+02,& - & .5119400E+02,.5128800E+02,.5151400E+02,.5187500E+02,.5237100E+02,& - & .5119000E+02,.5124500E+02,.5142600E+02,.5174600E+02,.5219800E+02,& - & .5120000E+02,.5121600E+02,.5135700E+02,.5163500E+02,.5204600E+02,& - & .5120700E+02,.5120700E+02,.5133300E+02,.5159400E+02,.5198900E+02/ - - data absb( 1:120, 5) / & - & .1705100E+03,.1716800E+03,.1729700E+03,.1743700E+03,.1759000E+03,& - & .1706100E+03,.1717900E+03,.1730900E+03,.1745100E+03,.1760400E+03,& - & .1707300E+03,.1719200E+03,.1732300E+03,.1746600E+03,.1762100E+03,& - & .1708500E+03,.1720500E+03,.1733800E+03,.1748200E+03,.1763800E+03,& - & .1709700E+03,.1721800E+03,.1735200E+03,.1749700E+03,.1765500E+03,& - & .1710900E+03,.1723200E+03,.1736600E+03,.1751300E+03,.1767100E+03,& - & .1712100E+03,.1724500E+03,.1738100E+03,.1752800E+03,.1768800E+03,& - & .1713400E+03,.1726000E+03,.1739700E+03,.1754700E+03,.1770800E+03,& - & .1714900E+03,.1727600E+03,.1741500E+03,.1756500E+03,.1772800E+03,& - & .1717200E+03,.1730100E+03,.1744200E+03,.1759400E+03,.1775900E+03,& - & .1719500E+03,.1732700E+03,.1747000E+03,.1762500E+03,.1779200E+03,& - & .1722100E+03,.1735500E+03,.1750000E+03,.1765800E+03,.1782700E+03,& - & .1724800E+03,.1738500E+03,.1753300E+03,.1769300E+03,.1786500E+03,& - & .1727900E+03,.1741800E+03,.1756900E+03,.1773200E+03,.1790600E+03,& - & .1731100E+03,.1745300E+03,.1760600E+03,.1777200E+03,.1794900E+03,& - & .1734400E+03,.1748800E+03,.1764500E+03,.1781300E+03,.1799400E+03,& - & .1737900E+03,.1752600E+03,.1768600E+03,.1785700E+03,.1804000E+03,& - & .1741400E+03,.1756500E+03,.1772700E+03,.1790200E+03,.1808800E+03,& - & .1745200E+03,.1760500E+03,.1777100E+03,.1794800E+03,.1813700E+03,& - & .1749100E+03,.1764700E+03,.1781600E+03,.1799600E+03,.1818800E+03,& - & .1753100E+03,.1769000E+03,.1786200E+03,.1804500E+03,.1824100E+03,& - & .1756600E+03,.1772800E+03,.1790300E+03,.1808900E+03,.1828700E+03,& - & .1758600E+03,.1775000E+03,.1792600E+03,.1811400E+03,.1831300E+03,& - & .1759000E+03,.1775400E+03,.1793000E+03,.1811800E+03,.1831800E+03/ - - data absb(121:235, 5) / & - & .1756900E+03,.1773200E+03,.1790600E+03,.1809300E+03,.1829100E+03,& - & .1754700E+03,.1770800E+03,.1788100E+03,.1806600E+03,.1826300E+03,& - & .1752600E+03,.1768500E+03,.1785700E+03,.1804000E+03,.1823500E+03,& - & .1748900E+03,.1764600E+03,.1781400E+03,.1799500E+03,.1818700E+03,& - & .1745100E+03,.1760500E+03,.1777000E+03,.1794800E+03,.1813700E+03,& - & .1741400E+03,.1756500E+03,.1772700E+03,.1790100E+03,.1808700E+03,& - & .1736900E+03,.1751600E+03,.1767500E+03,.1784600E+03,.1802800E+03,& - & .1732300E+03,.1746500E+03,.1762000E+03,.1778700E+03,.1796500E+03,& - & .1727700E+03,.1741600E+03,.1756700E+03,.1772900E+03,.1790400E+03,& - & .1723000E+03,.1736500E+03,.1751100E+03,.1766900E+03,.1784000E+03,& - & .1717900E+03,.1730900E+03,.1745100E+03,.1760400E+03,.1777000E+03,& - & .1713000E+03,.1725500E+03,.1739200E+03,.1754100E+03,.1770200E+03,& - & .1708300E+03,.1720400E+03,.1733600E+03,.1748000E+03,.1763600E+03,& - & .1704100E+03,.1715700E+03,.1728500E+03,.1742400E+03,.1757600E+03,& - & .1700200E+03,.1711300E+03,.1723700E+03,.1737200E+03,.1751900E+03,& - & .1696400E+03,.1707100E+03,.1719000E+03,.1732100E+03,.1746400E+03,& - & .1692700E+03,.1703100E+03,.1714500E+03,.1727200E+03,.1741100E+03,& - & .1689600E+03,.1699500E+03,.1710600E+03,.1722800E+03,.1736300E+03,& - & .1686600E+03,.1696200E+03,.1706900E+03,.1718800E+03,.1731800E+03,& - & .1683900E+03,.1693000E+03,.1703300E+03,.1714800E+03,.1727500E+03,& - & .1681200E+03,.1689900E+03,.1699900E+03,.1711000E+03,.1723300E+03,& - & .1678800E+03,.1687100E+03,.1696800E+03,.1707500E+03,.1719500E+03,& - & .1677900E+03,.1686100E+03,.1695500E+03,.1706200E+03,.1718000E+03/ - - data absb( 1:120, 6) / & - & .3812200E+03,.3840600E+03,.3866800E+03,.3890800E+03,.3912500E+03,& - & .3814800E+03,.3843100E+03,.3869100E+03,.3892900E+03,.3914400E+03,& - & .3817800E+03,.3845800E+03,.3871600E+03,.3895100E+03,.3916400E+03,& - & .3820900E+03,.3848700E+03,.3874200E+03,.3897500E+03,.3918600E+03,& - & .3823900E+03,.3851400E+03,.3876700E+03,.3899800E+03,.3920600E+03,& - & .3826800E+03,.3854100E+03,.3879200E+03,.3902000E+03,.3922600E+03,& - & .3829700E+03,.3856800E+03,.3881600E+03,.3904200E+03,.3924600E+03,& - & .3833000E+03,.3859800E+03,.3884400E+03,.3906700E+03,.3926800E+03,& - & .3836300E+03,.3862900E+03,.3887200E+03,.3909200E+03,.3929100E+03,& - & .3841400E+03,.3867500E+03,.3891400E+03,.3913100E+03,.3932500E+03,& - & .3846600E+03,.3872300E+03,.3895800E+03,.3917000E+03,.3936000E+03,& - & .3852000E+03,.3877200E+03,.3900200E+03,.3921000E+03,.3939500E+03,& - & .3857500E+03,.3882300E+03,.3904800E+03,.3925100E+03,.3943200E+03,& - & .3863500E+03,.3887700E+03,.3909800E+03,.3929500E+03,.3947000E+03,& - & .3869400E+03,.3893200E+03,.3914600E+03,.3933900E+03,.3950900E+03,& - & .3875300E+03,.3898500E+03,.3919400E+03,.3938100E+03,.3954600E+03,& - & .3881300E+03,.3903900E+03,.3924300E+03,.3942400E+03,.3958300E+03,& - & .3887100E+03,.3909200E+03,.3929000E+03,.3946600E+03,.3962000E+03,& - & .3893000E+03,.3914500E+03,.3933800E+03,.3950800E+03,.3965500E+03,& - & .3898800E+03,.3919700E+03,.3938400E+03,.3954800E+03,.3969000E+03,& - & .3904500E+03,.3924800E+03,.3942900E+03,.3958700E+03,.3972300E+03,& - & .3909300E+03,.3929100E+03,.3946700E+03,.3962000E+03,.3975100E+03,& - & .3912000E+03,.3931600E+03,.3948800E+03,.3963900E+03,.3976600E+03,& - & .3912500E+03,.3932000E+03,.3949200E+03,.3964200E+03,.3976900E+03/ - - data absb(121:235, 6) / & - & .3909800E+03,.3929500E+03,.3947100E+03,.3962300E+03,.3975400E+03,& - & .3906800E+03,.3926900E+03,.3944700E+03,.3960300E+03,.3973700E+03,& - & .3903900E+03,.3924300E+03,.3942400E+03,.3958300E+03,.3972000E+03,& - & .3898600E+03,.3919600E+03,.3938200E+03,.3954700E+03,.3968900E+03,& - & .3892900E+03,.3914400E+03,.3933700E+03,.3950700E+03,.3965500E+03,& - & .3887100E+03,.3909200E+03,.3929000E+03,.3946600E+03,.3961900E+03,& - & .3879700E+03,.3902500E+03,.3923000E+03,.3941300E+03,.3957400E+03,& - & .3871500E+03,.3895100E+03,.3916400E+03,.3935400E+03,.3952200E+03,& - & .3863100E+03,.3887400E+03,.3909400E+03,.3929200E+03,.3946800E+03,& - & .3853800E+03,.3878900E+03,.3901800E+03,.3922400E+03,.3940700E+03,& - & .3843100E+03,.3869100E+03,.3892900E+03,.3914400E+03,.3933600E+03,& - & .3832000E+03,.3858900E+03,.3883600E+03,.3906000E+03,.3926200E+03,& - & .3820600E+03,.3848400E+03,.3873900E+03,.3897200E+03,.3918300E+03,& - & .3809500E+03,.3838200E+03,.3864600E+03,.3888700E+03,.3910600E+03,& - & .3798500E+03,.3827900E+03,.3855200E+03,.3880200E+03,.3902900E+03,& - & .3787300E+03,.3817500E+03,.3845500E+03,.3871300E+03,.3894900E+03,& - & .3776200E+03,.3806700E+03,.3835500E+03,.3862100E+03,.3886500E+03,& - & .3766100E+03,.3796500E+03,.3826100E+03,.3853500E+03,.3878600E+03,& - & .3755900E+03,.3786700E+03,.3816900E+03,.3845000E+03,.3870800E+03,& - & .3745900E+03,.3776800E+03,.3807400E+03,.3836200E+03,.3862800E+03,& - & .3735300E+03,.3767300E+03,.3797700E+03,.3827200E+03,.3854500E+03,& - & .3725100E+03,.3757700E+03,.3788500E+03,.3818500E+03,.3846500E+03,& - & .3721200E+03,.3753900E+03,.3784700E+03,.3815000E+03,.3843200E+03/ - - data absb( 1:120, 7) / & - & .7662137E+03,.7673567E+03,.7684935E+03,.7696200E+03,.7707387E+03,& - & .7663163E+03,.7674596E+03,.7685948E+03,.7697242E+03,.7708374E+03,& - & .7664298E+03,.7675754E+03,.7687154E+03,.7698361E+03,.7709498E+03,& - & .7665525E+03,.7676972E+03,.7688307E+03,.7699581E+03,.7710677E+03,& - & .7666756E+03,.7678182E+03,.7689507E+03,.7700728E+03,.7711794E+03,& - & .7667902E+03,.7679332E+03,.7690672E+03,.7701907E+03,.7712951E+03,& - & .7669059E+03,.7680487E+03,.7691780E+03,.7703003E+03,.7714030E+03,& - & .7670396E+03,.7681833E+03,.7693099E+03,.7704320E+03,.7715291E+03,& - & .7671791E+03,.7683177E+03,.7694439E+03,.7705613E+03,.7716607E+03,& - & .7673923E+03,.7685297E+03,.7696521E+03,.7707717E+03,.7718639E+03,& - & .7676078E+03,.7687458E+03,.7698715E+03,.7709807E+03,.7720702E+03,& - & .7678360E+03,.7689728E+03,.7700933E+03,.7712034E+03,.7722895E+03,& - & .7680791E+03,.7692104E+03,.7703330E+03,.7714362E+03,.7725191E+03,& - & .7683474E+03,.7694736E+03,.7705880E+03,.7716873E+03,.7727677E+03,& - & .7686113E+03,.7697379E+03,.7708539E+03,.7719439E+03,.7730324E+03,& - & .7688808E+03,.7700069E+03,.7711126E+03,.7722067E+03,.7732788E+03,& - & .7691627E+03,.7702826E+03,.7713890E+03,.7724701E+03,.7735411E+03,& - & .7694444E+03,.7705613E+03,.7716614E+03,.7727369E+03,.7738092E+03,& - & .7697324E+03,.7708439E+03,.7719374E+03,.7730147E+03,.7740850E+03,& - & .7700239E+03,.7711302E+03,.7722186E+03,.7732904E+03,.7743608E+03,& - & .7703148E+03,.7714174E+03,.7725031E+03,.7735736E+03,.7746415E+03,& - & .7705710E+03,.7716646E+03,.7727437E+03,.7738133E+03,.7748784E+03,& - & .7707135E+03,.7718066E+03,.7728840E+03,.7739535E+03,.7750133E+03,& - & .7707385E+03,.7718282E+03,.7729073E+03,.7739754E+03,.7750350E+03/ - - data absb(121:235, 7) / & - & .7705883E+03,.7716906E+03,.7727677E+03,.7738341E+03,.7749005E+03,& - & .7704377E+03,.7715367E+03,.7726181E+03,.7736893E+03,.7747501E+03,& - & .7702833E+03,.7713847E+03,.7724701E+03,.7735404E+03,.7746103E+03,& - & .7700132E+03,.7711226E+03,.7722110E+03,.7732832E+03,.7743549E+03,& - & .7697309E+03,.7708439E+03,.7719342E+03,.7730115E+03,.7740748E+03,& - & .7694415E+03,.7705563E+03,.7716549E+03,.7727369E+03,.7738016E+03,& - & .7690928E+03,.7702101E+03,.7713174E+03,.7724017E+03,.7734724E+03,& - & .7687110E+03,.7698351E+03,.7709476E+03,.7720367E+03,.7731196E+03,& - & .7683270E+03,.7694544E+03,.7705715E+03,.7716689E+03,.7727485E+03,& - & .7679197E+03,.7690513E+03,.7701707E+03,.7712793E+03,.7723644E+03,& - & .7674632E+03,.7685951E+03,.7697242E+03,.7708374E+03,.7719299E+03,& - & .7669980E+03,.7681419E+03,.7692751E+03,.7703917E+03,.7714912E+03,& - & .7665390E+03,.7676847E+03,.7688180E+03,.7699424E+03,.7710534E+03,& - & .7661024E+03,.7672540E+03,.7683924E+03,.7695234E+03,.7706427E+03,& - & .7656917E+03,.7668356E+03,.7679808E+03,.7691095E+03,.7702308E+03,& - & .7652690E+03,.7664166E+03,.7675626E+03,.7687003E+03,.7698229E+03,& - & .7648234E+03,.7659942E+03,.7671451E+03,.7682868E+03,.7694142E+03,& - & .7643942E+03,.7656164E+03,.7667615E+03,.7679051E+03,.7690364E+03,& - & .7640026E+03,.7652413E+03,.7663923E+03,.7675375E+03,.7686735E+03,& - & .7636170E+03,.7648611E+03,.7660227E+03,.7671711E+03,.7683104E+03,& - & .7632407E+03,.7644461E+03,.7656618E+03,.7668033E+03,.7679489E+03,& - & .7628680E+03,.7640652E+03,.7653090E+03,.7664582E+03,.7676042E+03,& - & .7627137E+03,.7639260E+03,.7651678E+03,.7663198E+03,.7674646E+03/ - - data absb( 1:120, 8) / & - & .9936589E+03,.9978124E+03,.1000713E+04,.1002438E+04,.1003006E+04,& - & .9941671E+03,.9981368E+03,.1000893E+04,.1002525E+04,.1002981E+04,& - & .9946170E+03,.9984729E+03,.1001113E+04,.1002623E+04,.1003004E+04,& - & .9950818E+03,.9987774E+03,.1001345E+04,.1002694E+04,.1002984E+04,& - & .9955234E+03,.9990646E+03,.1001517E+04,.1002779E+04,.1002969E+04,& - & .9959436E+03,.9994208E+03,.1001709E+04,.1002856E+04,.1002912E+04,& - & .9963433E+03,.9996951E+03,.1001890E+04,.1002878E+04,.1002898E+04,& - & .9968098E+03,.1000016E+04,.1002055E+04,.1002942E+04,.1002824E+04,& - & .9972440E+03,.1000327E+04,.1002227E+04,.1002982E+04,.1002721E+04,& - & .9979060E+03,.1000761E+04,.1002461E+04,.1002998E+04,.1002590E+04,& - & .9985543E+03,.1001122E+04,.1002633E+04,.1002989E+04,.1002393E+04,& - & .9991623E+03,.1001557E+04,.1002797E+04,.1002959E+04,.1002134E+04,& - & .9997568E+03,.1001925E+04,.1002931E+04,.1002871E+04,.1001821E+04,& - & .1000377E+04,.1002254E+04,.1002986E+04,.1002709E+04,.1001396E+04,& - & .1000957E+04,.1002526E+04,.1002996E+04,.1002513E+04,.1000729E+04,& - & .1001400E+04,.1002743E+04,.1002971E+04,.1002233E+04,.1000328E+04,& - & .1001865E+04,.1002878E+04,.1002898E+04,.1001880E+04,.9997574E+03,& - & .1002181E+04,.1002979E+04,.1002724E+04,.1001454E+04,.9990322E+03,& - & .1002525E+04,.1003008E+04,.1002510E+04,.1000958E+04,.9981303E+03,& - & .1002747E+04,.1002980E+04,.1002223E+04,.1000349E+04,.9972023E+03,& - & .1002906E+04,.1002878E+04,.1001840E+04,.9996791E+03,.9962163E+03,& - & .1002974E+04,.1002724E+04,.1001436E+04,.9990028E+03,.9953155E+03,& - & .1003027E+04,.1002635E+04,.1001189E+04,.9985939E+03,.9947732E+03,& - & .1003027E+04,.1002599E+04,.1001143E+04,.9985204E+03,.9946814E+03/ - - data absb(121:235, 8) / & - & .1002986E+04,.1002724E+04,.1001390E+04,.9989482E+03,.9952234E+03,& - & .1002962E+04,.1002812E+04,.1001649E+04,.9993614E+03,.9957896E+03,& - & .1002875E+04,.1002898E+04,.1001877E+04,.9997601E+03,.9963253E+03,& - & .1002746E+04,.1002968E+04,.1002233E+04,.1000370E+04,.9972315E+03,& - & .1002537E+04,.1002981E+04,.1002514E+04,.1000975E+04,.9981846E+03,& - & .1002227E+04,.1002980E+04,.1002742E+04,.1001469E+04,.9990389E+03,& - & .1001759E+04,.1002861E+04,.1002915E+04,.1001995E+04,.9999268E+03,& - & .1001110E+04,.1002626E+04,.1002989E+04,.1002426E+04,.1000671E+04,& - & .1000338E+04,.1002249E+04,.1002983E+04,.1002727E+04,.1001434E+04,& - & .9993803E+03,.1001695E+04,.1002852E+04,.1002935E+04,.1002009E+04,& - & .9981347E+03,.1000918E+04,.1002522E+04,.1002979E+04,.1002520E+04,& - & .9966771E+03,.9999354E+03,.1002008E+04,.1002956E+04,.1002842E+04,& - & .9950417E+03,.9987633E+03,.1001326E+04,.1002702E+04,.1002988E+04,& - & .9933422E+03,.9974970E+03,.1000473E+04,.1002331E+04,.1002942E+04,& - & .9914154E+03,.9961148E+03,.9995247E+03,.1001775E+04,.1002873E+04,& - & .9892683E+03,.9945791E+03,.9984181E+03,.1001097E+04,.1002599E+04,& - & .9870330E+03,.9928966E+03,.9971671E+03,.1000265E+04,.1002220E+04,& - & .9848582E+03,.9910375E+03,.9958675E+03,.9993760E+03,.1001692E+04,& - & .9825219E+03,.9891516E+03,.9944982E+03,.9983573E+03,.1001066E+04,& - & .9797028E+03,.9871901E+03,.9930195E+03,.9972541E+03,.1000326E+04,& - & .9768957E+03,.9851199E+03,.9912663E+03,.9960243E+03,.9994761E+03,& - & .9741514E+03,.9830479E+03,.9894876E+03,.9947451E+03,.9985504E+03,& - & .9730254E+03,.9819457E+03,.9887533E+03,.9941968E+03,.9981408E+03/ - -!........................................! - end module module_radsw_kgb27 ! -!========================================! - - -!========================================! - module module_radsw_kgb28 ! -!........................................! -! -! ********* the original program descriptions ********* ! -! ! -! originally by j.delamere, atmospheric & environmental research. ! -! revision: 2.4 ! -! band 28: 38000-50000 cm-1 (low - o3,o2; high - o3,o2) ! -! reformatted for f90 by jjmorcrette, ecmwf ! -! ! -! this table has been re-generated for reduced number of g-point ! -! by y.t.hou, ncep ! -! ! -! ********* ********* end description ********* ********* ! -! - use machine, only : kind_phys - use module_radsw_parameters, only : NG28 - -! - implicit none -! - private -! - integer, public :: MSA28, MSB28 - parameter (MSA28=585, MSB28=1175) - - - real (kind=kind_phys), public :: & - & absa(MSA28,NG28), absb(MSB28,NG28), sfluxref(NG28,5) - -! --- rayleigh extinction coefficient at v = cm-1. - real (kind=kind_phys), parameter, public :: rayl = 2.02e-05 - -! the array absa(585,NG28) (ka((9,5,13,NG28)) contains absorption coefs at -! the 16 chosen g-values for a range of pressure levels> ~100mb, -! temperatures, and binary species parameters (see taumol.f for definition). -! the first index in the array, js, runs from 1 to 9, and corresponds to -! different values of the binary species parameter. for instance, -! js=1 refers to dry air, js = 2 corresponds to the paramter value 1/8, -! js = 3 corresponds to the parameter value 2/8, etc. the second index -! in the array, jt, which runs from 1 to 5, corresponds to different -! temperatures. more specifically, jt = 3 means that the data are for -! the reference temperature tref for this pressure level, jt = 2 refers -! to tref-15, jt = 1 is for tref-30, jt = 4 is for tref+15, and jt = 5 -! is for tref+30. the third index, jp, runs from 1 to 13 and refers -! to the jpth reference pressure level (see taumol.f for these levels -! in mb). the fourth index, ig, goes from 1 to 6, and indicates -! which g-interval the absorption coefficients are for. - - data absa( 1:180, 1) / & - & .4644700E+02,.1800100E+03,.3133800E+03,.4465200E+03,.5463600E+03,& - & .5417300E+03,.4570700E+03,.2736300E+03,.3500000E+02,.4527000E+02,& - & .1788600E+03,.3122500E+03,.4454100E+03,.5417700E+03,.5343600E+03,& - & .4493200E+03,.2674800E+03,.3500000E+02,.4421400E+02,.1777600E+03,& - & .3111500E+03,.4442700E+03,.5373300E+03,.5275600E+03,.4422400E+03,& - & .2619500E+03,.3500000E+02,.4325900E+02,.1767300E+03,.3100500E+03,& - & .4430500E+03,.5329800E+03,.5212900E+03,.4357400E+03,.2569600E+03,& - & .3500000E+02,.4239300E+02,.1757500E+03,.3089600E+03,.4417300E+03,& - & .5288300E+03,.5154800E+03,.4297600E+03,.2524200E+03,.3500000E+02,& - & .4290800E+02,.1769500E+03,.3107700E+03,.4443400E+03,.5316100E+03,& - & .5189500E+03,.4333200E+03,.2551200E+03,.3500000E+02,.4189900E+02,& - & .1759600E+03,.3098000E+03,.4433600E+03,.5268600E+03,.5121300E+03,& - & .4263200E+03,.2498400E+03,.3500000E+02,.4099500E+02,.1750200E+03,& - & .3088400E+03,.4423200E+03,.5223000E+03,.5059200E+03,.4199500E+03,& - & .2451100E+03,.3500000E+02,.4018100E+02,.1741200E+03,.3078800E+03,& - & .4411900E+03,.5178500E+03,.5002500E+03,.4141400E+03,.2408500E+03,& - & .3500000E+02,.3944300E+02,.1732600E+03,.3069100E+03,.4399200E+03,& - & .5136400E+03,.4950300E+03,.4088200E+03,.2369900E+03,.3500000E+02,& - & .4012600E+02,.1745700E+03,.3087600E+03,.4424800E+03,.5175500E+03,& - & .4998600E+03,.4137500E+03,.2405600E+03,.3500000E+02,.3924000E+02,& - & .1737000E+03,.3079200E+03,.4414600E+03,.5125400E+03,.4935800E+03,& - & .4073500E+03,.2359300E+03,.3500000E+02,.3845000E+02,.1728800E+03,& - & .3070800E+03,.4403100E+03,.5079300E+03,.4878600E+03,.4015500E+03,& - & .2317900E+03,.3500000E+02,.3774000E+02,.1721000E+03,.3062400E+03,& - & .4390800E+03,.5036800E+03,.4826400E+03,.3962900E+03,.2280800E+03,& - & .3500000E+02,.3709900E+02,.1713400E+03,.3053900E+03,.4378100E+03,& - & .4997500E+03,.4778700E+03,.3914900E+03,.2247300E+03,.3500000E+02,& - & .3781800E+02,.1725800E+03,.3070800E+03,.4396700E+03,.5041200E+03,& - & .4832100E+03,.3968700E+03,.2284800E+03,.3500000E+02,.3703400E+02,& - & .1718300E+03,.3063600E+03,.4383300E+03,.4993500E+03,.4773800E+03,& - & .3910000E+03,.2243900E+03,.3500000E+02,.3633800E+02,.1711100E+03,& - & .3056400E+03,.4370000E+03,.4949600E+03,.4721200E+03,.3857200E+03,& - & .2207500E+03,.3500000E+02,.3571600E+02,.1704300E+03,.3049100E+03,& - & .4356900E+03,.4909400E+03,.4673200E+03,.3809400E+03,.2174900E+03,& - & .3500000E+02,.3515600E+02,.1697700E+03,.3041600E+03,.4343700E+03,& - & .4872600E+03,.4629400E+03,.3766000E+03,.2145600E+03,.3500000E+02/ - - data absa(181:315, 1) / & - & .3585700E+02,.1708900E+03,.3056300E+03,.4361900E+03,.4918600E+03,& - & .4684100E+03,.3820200E+03,.2182200E+03,.3500000E+02,.3516300E+02,& - & .1702300E+03,.3050200E+03,.4347800E+03,.4873100E+03,.4630000E+03,& - & .3766600E+03,.2146000E+03,.3500000E+02,.3455000E+02,.1696100E+03,& - & .3044100E+03,.4333200E+03,.4832100E+03,.4581300E+03,.3718600E+03,& - & .2113900E+03,.3500000E+02,.3400400E+02,.1690200E+03,.3037800E+03,& - & .4319400E+03,.4795000E+03,.4537500E+03,.3675500E+03,.2085300E+03,& - & .3500000E+02,.3351400E+02,.1684400E+03,.3031200E+03,.4305800E+03,& - & .4761100E+03,.4497700E+03,.3636500E+03,.2059700E+03,.3500000E+02,& - & .3421200E+02,.1694600E+03,.3044000E+03,.4324700E+03,.4809200E+03,& - & .4554200E+03,.3692000E+03,.2096200E+03,.3500000E+02,.3359500E+02,& - & .1688900E+03,.3038900E+03,.4309300E+03,.4766700E+03,.4504300E+03,& - & .3643000E+03,.2063900E+03,.3500000E+02,.3305200E+02,.1683500E+03,& - & .3033700E+03,.4294600E+03,.4728700E+03,.4459900E+03,.3599300E+03,& - & .2035500E+03,.3500000E+02,.3257100E+02,.1678400E+03,.3028300E+03,& - & .4280700E+03,.4694700E+03,.4420100E+03,.3560200E+03,.2010300E+03,& - & .3500000E+02,.3214100E+02,.1673300E+03,.3022700E+03,.4267400E+03,& - & .4664000E+03,.4384200E+03,.3525000E+03,.1987900E+03,.3500000E+02,& - & .3281200E+02,.1682300E+03,.3033400E+03,.4285900E+03,.4711800E+03,& - & .4440100E+03,.3579900E+03,.2023000E+03,.3500000E+02,.3226300E+02,& - & .1677400E+03,.3029100E+03,.4270800E+03,.4672700E+03,.4394400E+03,& - & .3535000E+03,.1994200E+03,.3500000E+02,.3178200E+02,.1672800E+03,& - & .3024800E+03,.4255800E+03,.4638100E+03,.4353900E+03,.3495400E+03,& - & .1969100E+03,.3500000E+02,.3135700E+02,.1668300E+03,.3020300E+03,& - & .4241300E+03,.4606900E+03,.4317700E+03,.3459900E+03,.1946800E+03,& - & .3500000E+02,.3098000E+02,.1664000E+03,.3015400E+03,.4227600E+03,& - & .4578700E+03,.4285200E+03,.3428000E+03,.1927100E+03,.3500000E+02/ - - data absa(316:450, 1) / & - & .3161400E+02,.1671600E+03,.3023900E+03,.4247300E+03,.4625900E+03,& - & .4339700E+03,.3481400E+03,.1960300E+03,.3500000E+02,.3112500E+02,& - & .1667400E+03,.3020600E+03,.4231100E+03,.4589600E+03,.4297800E+03,& - & .3440300E+03,.1934700E+03,.3500000E+02,.3069900E+02,.1663500E+03,& - & .3017000E+03,.4216300E+03,.4557300E+03,.4260800E+03,.3403900E+03,& - & .1912400E+03,.3500000E+02,.3032500E+02,.1659700E+03,.3013300E+03,& - & .4202700E+03,.4528600E+03,.4228100E+03,.3371600E+03,.1892800E+03,& - & .3500000E+02,.2999300E+02,.1655900E+03,.3009200E+03,.4190100E+03,& - & .4503000E+03,.4198800E+03,.3342700E+03,.1875500E+03,.3500000E+02,& - & .3059400E+02,.1662400E+03,.3015600E+03,.4208700E+03,.4549300E+03,& - & .4251700E+03,.3394900E+03,.1906900E+03,.3500000E+02,.3015800E+02,& - & .1658900E+03,.3013100E+03,.4193700E+03,.4515700E+03,.4213400E+03,& - & .3357000E+03,.1884100E+03,.3500000E+02,.2978000E+02,.1655600E+03,& - & .3010300E+03,.4180000E+03,.4486400E+03,.4179900E+03,.3323900E+03,& - & .1864300E+03,.3500000E+02,.2945000E+02,.1652300E+03,.3007200E+03,& - & .4167400E+03,.4460600E+03,.4150400E+03,.3294600E+03,.1847100E+03,& - & .3500000E+02,.2915900E+02,.1649100E+03,.3003900E+03,.4155700E+03,& - & .4437700E+03,.4124200E+03,.3268600E+03,.1831800E+03,.3500000E+02,& - & .2969100E+02,.1654100E+03,.3008100E+03,.4172200E+03,.4479500E+03,& - & .4172000E+03,.3316000E+03,.1859700E+03,.3500000E+02,.2930700E+02,& - & .1651200E+03,.3006300E+03,.4158100E+03,.4449300E+03,.4137500E+03,& - & .3281800E+03,.1839600E+03,.3500000E+02,.2897500E+02,.1648500E+03,& - & .3004200E+03,.4145400E+03,.4423100E+03,.4107600E+03,.3252000E+03,& - & .1822200E+03,.3500000E+02,.2868700E+02,.1645800E+03,.3001800E+03,& - & .4134000E+03,.4400200E+03,.4081400E+03,.3225900E+03,.1807100E+03,& - & .3500000E+02,.2843400E+02,.1643100E+03,.2998900E+03,.4123500E+03,& - & .4379900E+03,.4058300E+03,.3202800E+03,.1793900E+03,.3500000E+02/ - - data absa(451:585, 1) / & - & .2876000E+02,.1645900E+03,.3001000E+03,.4132100E+03,.4406000E+03,& - & .4088000E+03,.3232500E+03,.1810900E+03,.3500000E+02,.2844400E+02,& - & .1643600E+03,.2999700E+03,.4120000E+03,.4380700E+03,.4059200E+03,& - & .3203800E+03,.1794400E+03,.3500000E+02,.2817300E+02,.1641400E+03,& - & .2998100E+03,.4109200E+03,.4358700E+03,.4034200E+03,.3178800E+03,& - & .1780200E+03,.3500000E+02,.2793700E+02,.1639200E+03,.2996000E+03,& - & .4099400E+03,.4339500E+03,.4012400E+03,.3157000E+03,.1767900E+03,& - & .3500000E+02,.2773000E+02,.1636900E+03,.2993600E+03,.4090500E+03,& - & .4322400E+03,.3993100E+03,.3137700E+03,.1757100E+03,.3500000E+02,& - & .2799500E+02,.1639100E+03,.2995100E+03,.4097000E+03,.4344300E+03,& - & .4017800E+03,.3162400E+03,.1770900E+03,.3500000E+02,.2773700E+02,& - & .1637400E+03,.2994300E+03,.4086900E+03,.4323000E+03,.3993800E+03,& - & .3138400E+03,.1757400E+03,.3500000E+02,.2751500E+02,.1635600E+03,& - & .2993000E+03,.4077900E+03,.4304600E+03,.3973000E+03,.3117600E+03,& - & .1745800E+03,.3500000E+02,.2732200E+02,.1633800E+03,.2991300E+03,& - & .4069700E+03,.4288300E+03,.3954800E+03,.3099400E+03,.1735700E+03,& - & .3500000E+02,.2715200E+02,.1631800E+03,.2989200E+03,.4062200E+03,& - & .4274000E+03,.3938700E+03,.3083400E+03,.1726800E+03,.3500000E+02,& - & .2736900E+02,.1633600E+03,.2990300E+03,.4067100E+03,.4292400E+03,& - & .3959300E+03,.3103900E+03,.1738200E+03,.3500000E+02,.2715800E+02,& - & .1632300E+03,.2989800E+03,.4058700E+03,.4274500E+03,.3939300E+03,& - & .3084000E+03,.1727100E+03,.3500000E+02,.2697600E+02,.1630900E+03,& - & .2988900E+03,.4051300E+03,.4259000E+03,.3922100E+03,.3066700E+03,& - & .1717600E+03,.3500000E+02,.2681800E+02,.1629300E+03,.2987500E+03,& - & .4044500E+03,.4245500E+03,.3907000E+03,.3051600E+03,.1709300E+03,& - & .3500000E+02,.2667900E+02,.1627600E+03,.2985500E+03,.4038100E+03,& - & .4233500E+03,.3893700E+03,.3038400E+03,.1702100E+03,.3500000E+02/ - - data absa( 1:180, 2) / & - & .1727100E+03,.2764600E+03,.3803900E+03,.4842000E+03,.5693200E+03,& - & .5753400E+03,.4787300E+03,.2814700E+03,.7184000E+02,.1683400E+03,& - & .2724600E+03,.3767800E+03,.4809100E+03,.5647100E+03,.5673400E+03,& - & .4700500E+03,.2759300E+03,.7184000E+02,.1644100E+03,.2688300E+03,& - & .3734100E+03,.4777700E+03,.5603700E+03,.5600300E+03,.4621000E+03,& - & .2709600E+03,.7184000E+02,.1608600E+03,.2654800E+03,.3702500E+03,& - & .4747900E+03,.5562900E+03,.5532700E+03,.4548100E+03,.2664700E+03,& - & .7184000E+02,.1576400E+03,.2623700E+03,.3672500E+03,.4719500E+03,& - & .5523500E+03,.5470100E+03,.4481000E+03,.2623900E+03,.7184000E+02,& - & .1595500E+03,.2650000E+03,.3706700E+03,.4759500E+03,.5548000E+03,& - & .5507400E+03,.4521000E+03,.2648200E+03,.7184000E+02,.1558000E+03,& - & .2615700E+03,.3675600E+03,.4730300E+03,.5502800E+03,.5433900E+03,& - & .4442300E+03,.2600700E+03,.7184000E+02,.1524400E+03,.2584400E+03,& - & .3646500E+03,.4702300E+03,.5461900E+03,.5366400E+03,.4370800E+03,& - & .2558100E+03,.7184000E+02,.1494100E+03,.2555600E+03,.3619100E+03,& - & .4675300E+03,.5425300E+03,.5304100E+03,.4305200E+03,.2519800E+03,& - & .7184000E+02,.1466700E+03,.2528900E+03,.3593000E+03,.4649400E+03,& - & .5390800E+03,.5247000E+03,.4244800E+03,.2485100E+03,.7184000E+02,& - & .1492100E+03,.2560100E+03,.3630800E+03,.4687200E+03,.5423400E+03,& - & .5299900E+03,.4300700E+03,.2517200E+03,.7184000E+02,.1459100E+03,& - & .2530100E+03,.3603600E+03,.4659900E+03,.5383400E+03,.5231300E+03,& - & .4228000E+03,.2475500E+03,.7184000E+02,.1429700E+03,.2502800E+03,& - & .3578200E+03,.4635000E+03,.5345900E+03,.5169600E+03,.4161900E+03,& - & .2438300E+03,.7184000E+02,.1403300E+03,.2477700E+03,.3554200E+03,& - & .4611600E+03,.5310000E+03,.5112200E+03,.4101600E+03,.2404900E+03,& - & .7184000E+02,.1379500E+03,.2454400E+03,.3531300E+03,.4588200E+03,& - & .5275100E+03,.5059100E+03,.4046300E+03,.2374700E+03,.7184000E+02,& - & .1406200E+03,.2485600E+03,.3567800E+03,.4626000E+03,.5313700E+03,& - & .5118600E+03,.4108200E+03,.2408600E+03,.7184000E+02,.1377100E+03,& - & .2459200E+03,.3544000E+03,.4602000E+03,.5273200E+03,.5053700E+03,& - & .4040700E+03,.2371700E+03,.7184000E+02,.1351200E+03,.2435300E+03,& - & .3521900E+03,.4579600E+03,.5234800E+03,.4995400E+03,.3979800E+03,& - & .2338900E+03,.7184000E+02,.1328100E+03,.2413300E+03,.3500800E+03,& - & .4558300E+03,.5198500E+03,.4943100E+03,.3924600E+03,.2309600E+03,& - & .7184000E+02,.1307300E+03,.2392800E+03,.3480700E+03,.4537800E+03,& - & .5164300E+03,.4895700E+03,.3874500E+03,.2283300E+03,.7184000E+02/ - - data absa(181:315, 2) / & - & .1333300E+03,.2422200E+03,.3514100E+03,.4570200E+03,.5205700E+03,& - & .4955000E+03,.3937200E+03,.2316300E+03,.7184000E+02,.1307500E+03,& - & .2399000E+03,.3493400E+03,.4547600E+03,.5165100E+03,.4896300E+03,& - & .3875200E+03,.2283600E+03,.7184000E+02,.1284700E+03,.2378000E+03,& - & .3474100E+03,.4526600E+03,.5127100E+03,.4843800E+03,.3819600E+03,& - & .2254800E+03,.7184000E+02,.1264400E+03,.2358800E+03,.3455700E+03,& - & .4506600E+03,.5091100E+03,.4796200E+03,.3769600E+03,.2229100E+03,& - & .7184000E+02,.1246200E+03,.2340900E+03,.3438100E+03,.4487400E+03,& - & .5057000E+03,.4752600E+03,.3724500E+03,.2206000E+03,.7184000E+02,& - & .1272200E+03,.2369000E+03,.3468800E+03,.4517700E+03,.5103200E+03,& - & .4814400E+03,.3788700E+03,.2238900E+03,.7184000E+02,.1249200E+03,& - & .2348500E+03,.3450800E+03,.4496700E+03,.5062000E+03,.4759800E+03,& - & .3731900E+03,.2209800E+03,.7184000E+02,.1229000E+03,.2330100E+03,& - & .3434000E+03,.4476900E+03,.5024200E+03,.4710800E+03,.3681500E+03,& - & .2184300E+03,.7184000E+02,.1211100E+03,.2313200E+03,.3418000E+03,& - & .4458200E+03,.4989400E+03,.4666800E+03,.3636300E+03,.2161600E+03,& - & .7184000E+02,.1195200E+03,.2297600E+03,.3402600E+03,.4440700E+03,& - & .4957400E+03,.4627000E+03,.3595600E+03,.2141400E+03,.7184000E+02,& - & .1220100E+03,.2323500E+03,.3430000E+03,.4470000E+03,.5005400E+03,& - & .4688900E+03,.3659000E+03,.2173000E+03,.7184000E+02,.1199700E+03,& - & .2305500E+03,.3414500E+03,.4449200E+03,.4965700E+03,.4638300E+03,& - & .3607100E+03,.2147100E+03,.7184000E+02,.1181800E+03,.2289400E+03,& - & .3399900E+03,.4430900E+03,.4929200E+03,.4593400E+03,.3561300E+03,& - & .2124500E+03,.7184000E+02,.1166000E+03,.2274600E+03,.3385900E+03,& - & .4414600E+03,.4895900E+03,.4553300E+03,.3520800E+03,.2104500E+03,& - & .7184000E+02,.1152000E+03,.2260900E+03,.3372400E+03,.4399600E+03,& - & .4865700E+03,.4517500E+03,.3484700E+03,.2086700E+03,.7184000E+02/ - - data absa(316:450, 2) / & - & .1175600E+03,.2284400E+03,.3396500E+03,.4426100E+03,.4914700E+03,& - & .4577600E+03,.3545400E+03,.2116600E+03,.7184000E+02,.1157400E+03,& - & .2268700E+03,.3383000E+03,.4408200E+03,.4876700E+03,.4531300E+03,& - & .3498600E+03,.2093600E+03,.7184000E+02,.1141500E+03,.2254600E+03,& - & .3370400E+03,.4391500E+03,.4842900E+03,.4490800E+03,.3457900E+03,& - & .2073500E+03,.7184000E+02,.1127600E+03,.2241700E+03,.3358400E+03,& - & .4375800E+03,.4812600E+03,.4454900E+03,.3422000E+03,.2055900E+03,& - & .7184000E+02,.1115300E+03,.2229800E+03,.3346600E+03,.4361700E+03,& - & .4785500E+03,.4422800E+03,.3390200E+03,.2040300E+03,.7184000E+02,& - & .1137600E+03,.2251000E+03,.3367400E+03,.4388200E+03,.4833600E+03,& - & .4480700E+03,.3447900E+03,.2068600E+03,.7184000E+02,.1121400E+03,& - & .2237200E+03,.3355900E+03,.4370600E+03,.4798900E+03,.4438800E+03,& - & .3406000E+03,.2048000E+03,.7184000E+02,.1107400E+03,.2225000E+03,& - & .3345100E+03,.4354700E+03,.4767900E+03,.4402000E+03,.3369700E+03,& - & .2030300E+03,.7184000E+02,.1095100E+03,.2213800E+03,.3334800E+03,& - & .4340400E+03,.4740400E+03,.4369400E+03,.3337900E+03,.2014700E+03,& - & .7184000E+02,.1084300E+03,.2203400E+03,.3324600E+03,.4327700E+03,& - & .4715900E+03,.4340500E+03,.3309600E+03,.2001000E+03,.7184000E+02,& - & .1104100E+03,.2221400E+03,.3341400E+03,.4351700E+03,.4760400E+03,& - & .4393200E+03,.3361100E+03,.2026100E+03,.7184000E+02,.1089800E+03,& - & .2209500E+03,.3331700E+03,.4335800E+03,.4728300E+03,.4355200E+03,& - & .3323900E+03,.2008000E+03,.7184000E+02,.1077400E+03,.2198900E+03,& - & .3322600E+03,.4321300E+03,.4700200E+03,.4322200E+03,.3291700E+03,& - & .1992400E+03,.7184000E+02,.1066700E+03,.2189300E+03,.3313900E+03,& - & .4308300E+03,.4675300E+03,.4293200E+03,.3263400E+03,.1978800E+03,& - & .7184000E+02,.1057300E+03,.2180300E+03,.3305300E+03,.4296500E+03,& - & .4653200E+03,.4267700E+03,.3238600E+03,.1966900E+03,.7184000E+02/ - - data absa(451:585, 2) / & - & .1069400E+03,.2191100E+03,.3315200E+03,.4312700E+03,.4681600E+03,& - & .4300500E+03,.3270600E+03,.1982200E+03,.7184000E+02,.1057700E+03,& - & .2181500E+03,.3307400E+03,.4298400E+03,.4654100E+03,.4268700E+03,& - & .3239600E+03,.1967400E+03,.7184000E+02,.1047600E+03,.2172800E+03,& - & .3300000E+03,.4285500E+03,.4630100E+03,.4241100E+03,.3213000E+03,& - & .1954600E+03,.7184000E+02,.1038800E+03,.2164900E+03,.3292800E+03,& - & .4274100E+03,.4608900E+03,.4216900E+03,.3189700E+03,.1943500E+03,& - & .7184000E+02,.1031100E+03,.2157500E+03,.3285500E+03,.4263900E+03,& - & .4590200E+03,.4195400E+03,.3169200E+03,.1933800E+03,.7184000E+02,& - & .1041000E+03,.2166300E+03,.3293700E+03,.4277800E+03,.4614100E+03,& - & .4222900E+03,.3195500E+03,.1946300E+03,.7184000E+02,.1031400E+03,& - & .2158500E+03,.3287500E+03,.4265400E+03,.4590900E+03,.4196100E+03,& - & .3170000E+03,.1934100E+03,.7184000E+02,.1023100E+03,.2151500E+03,& - & .3281500E+03,.4254400E+03,.4570700E+03,.4172900E+03,.3148000E+03,& - & .1923600E+03,.7184000E+02,.1015900E+03,.2144900E+03,.3275400E+03,& - & .4244500E+03,.4553200E+03,.4152600E+03,.3128800E+03,.1914500E+03,& - & .7184000E+02,.1009600E+03,.2138700E+03,.3269200E+03,.4235600E+03,& - & .4537700E+03,.4134700E+03,.3111900E+03,.1906600E+03,.7184000E+02,& - & .1017700E+03,.2146000E+03,.3276100E+03,.4247500E+03,.4557500E+03,& - & .4157600E+03,.3133500E+03,.1916800E+03,.7184000E+02,.1009900E+03,& - & .2139700E+03,.3271200E+03,.4236800E+03,.4538300E+03,.4135300E+03,& - & .3112500E+03,.1906800E+03,.7184000E+02,.1003100E+03,.2134000E+03,& - & .3266300E+03,.4227200E+03,.4521600E+03,.4116000E+03,.3094300E+03,& - & .1898300E+03,.7184000E+02,.9972000E+02,.2128600E+03,.3261200E+03,& - & .4218700E+03,.4507100E+03,.4099100E+03,.3078500E+03,.1890800E+03,& - & .7184000E+02,.9920400E+02,.2123300E+03,.3255800E+03,.4211200E+03,& - & .4494200E+03,.4084200E+03,.3064600E+03,.1884300E+03,.7184000E+02/ - - data absa( 1:180, 3) / & - & .6511264E+03,.6329084E+03,.6146856E+03,.5966652E+03,.6074063E+03,& - & .6528610E+03,.5099603E+03,.3749181E+03,.2774131E+03,.6346287E+03,& - & .6184704E+03,.6023125E+03,.5863930E+03,.6020757E+03,.6446762E+03,& - & .4994119E+03,.3715684E+03,.2774131E+03,.6198152E+03,.6055045E+03,& - & .5912038E+03,.5771678E+03,.5973361E+03,.6369385E+03,.4900862E+03,& - & .3685614E+03,.2774131E+03,.6064342E+03,.5938030E+03,.5811717E+03,& - & .5688415E+03,.5930984E+03,.6294842E+03,.4817900E+03,.3658423E+03,& - & .2774131E+03,.5942932E+03,.5831782E+03,.5720635E+03,.5612806E+03,& - & .5892330E+03,.6221730E+03,.4743525E+03,.3633754E+03,.2774131E+03,& - & .6015146E+03,.5894958E+03,.5774770E+03,.5658111E+03,.5943788E+03,& - & .6267589E+03,.4787630E+03,.3648436E+03,.2774131E+03,.5873680E+03,& - & .5771175E+03,.5668670E+03,.5570576E+03,.5905502E+03,.6181492E+03,& - & .4701504E+03,.3619729E+03,.2774131E+03,.5746935E+03,.5660284E+03,& - & .5573637E+03,.5492284E+03,.5870483E+03,.6098467E+03,.4625325E+03,& - & .3594001E+03,.2774131E+03,.5632785E+03,.5560360E+03,.5487986E+03,& - & .5422048E+03,.5837067E+03,.6020593E+03,.4557839E+03,.3570844E+03,& - & .2774131E+03,.5529351E+03,.5469870E+03,.5410436E+03,.5358636E+03,& - & .5804343E+03,.5946671E+03,.4497552E+03,.3549858E+03,.2774131E+03,& - & .5625080E+03,.5553643E+03,.5482206E+03,.5421149E+03,.5857773E+03,& - & .6015260E+03,.4553353E+03,.3569280E+03,.2774131E+03,.5500901E+03,& - & .5445026E+03,.5389099E+03,.5346354E+03,.5824284E+03,.5925618E+03,& - & .4481108E+03,.3544056E+03,.2774131E+03,.5390110E+03,.5348064E+03,& - & .5306017E+03,.5279541E+03,.5791807E+03,.5842402E+03,.4417818E+03,& - & .3521607E+03,.2774131E+03,.5290630E+03,.5260980E+03,.5231382E+03,& - & .5219585E+03,.5760337E+03,.5766944E+03,.4361804E+03,.3501376E+03,& - & .2774131E+03,.5200781E+03,.5182394E+03,.5163958E+03,.5165553E+03,& - & .5729753E+03,.5696064E+03,.4311945E+03,.3483165E+03,.2774131E+03,& - & .5301497E+03,.5270514E+03,.5239531E+03,.5232218E+03,.5779936E+03,& - & .5775254E+03,.4367865E+03,.3503547E+03,.2774131E+03,.5191743E+03,& - & .5174492E+03,.5157190E+03,.5168800E+03,.5747472E+03,.5688802E+03,& - & .4306977E+03,.3481297E+03,.2774131E+03,.5094140E+03,.5089090E+03,& - & .5084039E+03,.5112313E+03,.5716791E+03,.5610450E+03,.4253723E+03,& - & .3461523E+03,.2774131E+03,.5006908E+03,.5012725E+03,.5018541E+03,& - & .5061415E+03,.5687148E+03,.5539480E+03,.4206699E+03,.3443815E+03,& - & .2774131E+03,.4928322E+03,.4944017E+03,.4959664E+03,.5015429E+03,& - & .5658453E+03,.5474233E+03,.4164958E+03,.3427822E+03,.2774131E+03/ - - data absa(181:315, 3) / & - & .5026617E+03,.5029964E+03,.5033359E+03,.5079576E+03,.5703975E+03,& - & .5555608E+03,.4217244E+03,.3447801E+03,.2774131E+03,.4929459E+03,& - & .4944957E+03,.4960504E+03,.5025983E+03,.5672753E+03,.5475129E+03,& - & .4165470E+03,.3428074E+03,.2774131E+03,.4843464E+03,.4869729E+03,& - & .4895995E+03,.4978824E+03,.5642908E+03,.5402030E+03,.4120341E+03,& - & .3410570E+03,.2774131E+03,.4766902E+03,.4802750E+03,.4838598E+03,& - & .4936340E+03,.5614813E+03,.5336150E+03,.4080600E+03,.3395081E+03,& - & .2774131E+03,.4698243E+03,.4742636E+03,.4787081E+03,.4897906E+03,& - & .5587886E+03,.5276339E+03,.4045435E+03,.3381108E+03,.2774131E+03,& - & .4796093E+03,.4828287E+03,.4860480E+03,.4958831E+03,.5631234E+03,& - & .5361276E+03,.4095724E+03,.3400983E+03,.2774131E+03,.4709554E+03,& - & .4752614E+03,.4795626E+03,.4913793E+03,.5601219E+03,.5286289E+03,& - & .4051219E+03,.3383427E+03,.2774131E+03,.4633537E+03,.4686031E+03,& - & .4738526E+03,.4874207E+03,.5572835E+03,.5219272E+03,.4012664E+03,& - & .3367990E+03,.2774131E+03,.4566014E+03,.4626954E+03,.4687945E+03,& - & .4838547E+03,.5545520E+03,.5159087E+03,.3978937E+03,.3354268E+03,& - & .2774131E+03,.4505703E+03,.4574252E+03,.4642700E+03,.4806076E+03,& - & .5519154E+03,.5104788E+03,.3949126E+03,.3342010E+03,.2774131E+03,& - & .4599800E+03,.4656593E+03,.4713286E+03,.4861245E+03,.5561434E+03,& - & .5189328E+03,.3995824E+03,.3361129E+03,.2774131E+03,.4522794E+03,& - & .4589169E+03,.4655493E+03,.4823660E+03,.5531814E+03,.5120152E+03,& - & .3957540E+03,.3345540E+03,.2774131E+03,.4455371E+03,.4530143E+03,& - & .4604964E+03,.4790627E+03,.5504387E+03,.5058908E+03,.3924488E+03,& - & .3331819E+03,.2774131E+03,.4395801E+03,.4478082E+03,.4560363E+03,& - & .4760716E+03,.5478683E+03,.5004584E+03,.3895600E+03,.3319712E+03,& - & .2774131E+03,.4342899E+03,.4431749E+03,.4520702E+03,.4733295E+03,& - & .5454191E+03,.4955934E+03,.3870166E+03,.3309017E+03,.2774131E+03/ - - data absa(316:450, 3) / & - & .4431908E+03,.4509594E+03,.4587381E+03,.4781967E+03,.5493562E+03,& - & .5037547E+03,.3913036E+03,.3327077E+03,.2774131E+03,.4363300E+03,& - & .4449580E+03,.4535964E+03,.4750441E+03,.5465445E+03,.4974754E+03,& - & .3879943E+03,.3313103E+03,.2774131E+03,.4303582E+03,.4397370E+03,& - & .4491215E+03,.4722875E+03,.5439163E+03,.4918909E+03,.3851474E+03,& - & .3301045E+03,.2774131E+03,.4251124E+03,.4351433E+03,.4451950E+03,& - & .4698098E+03,.5414411E+03,.4869096E+03,.3826759E+03,.3290350E+03,& - & .2774131E+03,.4204694E+03,.4310783E+03,.4417179E+03,.4675130E+03,& - & .5390622E+03,.4824898E+03,.3805037E+03,.3280966E+03,.2774131E+03,& - & .4288912E+03,.4384478E+03,.4480252E+03,.4717437E+03,.5428850E+03,& - & .4904977E+03,.3844535E+03,.3298019E+03,.2774131E+03,.4227713E+03,& - & .4330984E+03,.4434414E+03,.4691286E+03,.5401449E+03,.4846799E+03,& - & .3815770E+03,.3285608E+03,.2774131E+03,.4174811E+03,.4284602E+03,& - & .4394805E+03,.4668405E+03,.5375978E+03,.4796375E+03,.3791166E+03,& - & .3274861E+03,.2774131E+03,.4128529E+03,.4244148E+03,.4360182E+03,& - & .4647682E+03,.5352111E+03,.4752154E+03,.3769855E+03,.3265430E+03,& - & .2774131E+03,.4087727E+03,.4208485E+03,.4329611E+03,.4628378E+03,& - & .5329651E+03,.4713043E+03,.3751287E+03,.3257206E+03,.2774131E+03,& - & .4162315E+03,.4273735E+03,.4385419E+03,.4662891E+03,.5364495E+03,& - & .4784476E+03,.3785445E+03,.3272290E+03,.2774131E+03,.4108377E+03,& - & .4226565E+03,.4345069E+03,.4641370E+03,.5338298E+03,.4732874E+03,& - & .3760645E+03,.3261392E+03,.2774131E+03,.4061995E+03,.4185915E+03,& - & .4310298E+03,.4622539E+03,.5314356E+03,.4688122E+03,.3739650E+03,& - & .3251960E+03,.2774131E+03,.4021541E+03,.4150596E+03,.4280071E+03,& - & .4605480E+03,.5292326E+03,.4648804E+03,.3721593E+03,.3243736E+03,& - & .2774131E+03,.3986074E+03,.4119528E+03,.4253550E+03,.4589564E+03,& - & .5271755E+03,.4613869E+03,.3705866E+03,.3236571E+03,.2774131E+03/ - - data absa(451:585, 3) / & - & .4031715E+03,.4159438E+03,.4287676E+03,.4609884E+03,.5292837E+03,& - & .4658721E+03,.3726094E+03,.3245855E+03,.2774131E+03,.3987507E+03,& - & .4120761E+03,.4254586E+03,.4593570E+03,.5269580E+03,.4615362E+03,& - & .3706474E+03,.3236875E+03,.2774131E+03,.3949475E+03,.4087520E+03,& - & .4226140E+03,.4578984E+03,.5248194E+03,.4578690E+03,.3689687E+03,& - & .3229107E+03,.2774131E+03,.3916430E+03,.4058525E+03,.4201396E+03,& - & .4565441E+03,.5228408E+03,.4544830E+03,.3675280E+03,.3222398E+03,& - & .2774131E+03,.3887335E+03,.4033137E+03,.4179614E+03,.4552601E+03,& - & .5210222E+03,.4515774E+03,.3662647E+03,.3216544E+03,.2774131E+03,& - & .3924531E+03,.4065686E+03,.4207468E+03,.4569108E+03,.5228838E+03,& - & .4553196E+03,.3678766E+03,.3224061E+03,.2774131E+03,.3888324E+03,& - & .4034026E+03,.4180454E+03,.4556544E+03,.5208037E+03,.4516870E+03,& - & .3663098E+03,.3216696E+03,.2774131E+03,.3857204E+03,.4006760E+03,& - & .4157143E+03,.4545126E+03,.5188851E+03,.4485672E+03,.3649658E+03,& - & .3210391E+03,.2774131E+03,.3830138E+03,.3983049E+03,.4136846E+03,& - & .4534319E+03,.5171572E+03,.4458556E+03,.3638040E+03,.3204890E+03,& - & .2774131E+03,.3806279E+03,.3962256E+03,.4118963E+03,.4523829E+03,& - & .5156086E+03,.4434924E+03,.3627937E+03,.3200048E+03,.2774131E+03,& - & .3836807E+03,.3988929E+03,.4141833E+03,.4537401E+03,.5172110E+03,& - & .4465237E+03,.3640918E+03,.3206253E+03,.2774131E+03,.3807168E+03,& - & .3962996E+03,.4119655E+03,.4527776E+03,.5153732E+03,.4435721E+03,& - & .3628289E+03,.3200248E+03,.2774131E+03,.3781631E+03,.3940670E+03,& - & .4100595E+03,.4518853E+03,.5137515E+03,.4410437E+03,.3617483E+03,& - & .3195054E+03,.2774131E+03,.3759453E+03,.3921257E+03,.4084000E+03,& - & .4510200E+03,.5123154E+03,.4388535E+03,.3608140E+03,.3190564E+03,& - & .2774131E+03,.3739993E+03,.3904218E+03,.4069430E+03,.4501424E+03,& - & .5110249E+03,.4369317E+03,.3599960E+03,.3186578E+03,.2774131E+03/ - - data absa( 1:180, 4) / & - & .1490491E+04,.1320345E+04,.1150192E+04,.9800544E+03,.8098902E+03,& - & .7197150E+03,.6792147E+03,.7402425E+03,.8002384E+03,.1452731E+04,& - & .1287287E+04,.1121843E+04,.9564311E+03,.7910079E+03,.7120191E+03,& - & .6771483E+03,.7390036E+03,.7998958E+03,.1418780E+04,.1257599E+04,& - & .1096434E+04,.9352534E+03,.7740540E+03,.7025255E+03,.6751582E+03,& - & .7376910E+03,.7993864E+03,.1388200E+04,.1230836E+04,.1073482E+04,& - & .9161180E+03,.7587353E+03,.6923034E+03,.6731990E+03,.7363185E+03,& - & .7987103E+03,.1360397E+04,.1206504E+04,.1052610E+04,.8987339E+03,& - & .7448387E+03,.6822317E+03,.6712136E+03,.7348370E+03,.7978722E+03,& - & .1376903E+04,.1220978E+04,.1065010E+04,.9090577E+03,.7531056E+03,& - & .6894651E+03,.6733436E+03,.7372884E+03,.8003310E+03,.1344538E+04,& - & .1192629E+04,.1040735E+04,.8888218E+03,.7369143E+03,.6768296E+03,& - & .6715747E+03,.7362303E+03,.8000578E+03,.1315550E+04,.1167251E+04,& - & .1018964E+04,.8706883E+03,.7224512E+03,.6656647E+03,.6698697E+03,& - & .7351070E+03,.7996179E+03,.1289379E+04,.1144358E+04,.9993773E+03,& - & .8543538E+03,.7095866E+03,.6560533E+03,.6681935E+03,.7339123E+03,& - & .7990113E+03,.1265740E+04,.1123642E+04,.9815969E+03,.8395554E+03,& - & .6981281E+03,.6477726E+03,.6664850E+03,.7326277E+03,.7982380E+03,& - & .1287647E+04,.1142819E+04,.9980492E+03,.8532534E+03,.7089617E+03,& - & .6555751E+03,.6687079E+03,.7349497E+03,.8004236E+03,.1259199E+04,& - & .1117994E+04,.9767252E+03,.8354916E+03,.6953763E+03,.6460584E+03,& - & .6671911E+03,.7340872E+03,.8002431E+03,.1233874E+04,.1095802E+04,& - & .9576897E+03,.8196373E+03,.6835316E+03,.6380393E+03,.6657230E+03,& - & .7331401E+03,.7999004E+03,.1211081E+04,.1075833E+04,.9406536E+03,& - & .8054044E+03,.6731147E+03,.6310221E+03,.6642968E+03,.7321310E+03,& - & .7993957E+03,.1190512E+04,.1057848E+04,.9251886E+03,.7925536E+03,& - & .6639048E+03,.6250737E+03,.6628407E+03,.7310159E+03,.7987242E+03,& - & .1213605E+04,.1078027E+04,.9425174E+03,.8069604E+03,.6747932E+03,& - & .6317831E+03,.6648333E+03,.7329850E+03,.8004607E+03,.1188427E+04,& - & .1056052E+04,.9236605E+03,.7912500E+03,.6637826E+03,.6247883E+03,& - & .6635334E+03,.7322842E+03,.8003773E+03,.1166126E+04,.1036497E+04,& - & .9069190E+03,.7772941E+03,.6542493E+03,.6188027E+03,.6622900E+03,& - & .7315166E+03,.8001412E+03,.1146104E+04,.1019036E+04,.8919134E+03,& - & .7648103E+03,.6459064E+03,.6135679E+03,.6610584E+03,.7306623E+03,& - & .7997430E+03,.1128166E+04,.1003292E+04,.8784385E+03,.7535801E+03,& - & .6385155E+03,.6090063E+03,.6598247E+03,.7297259E+03,.7991780E+03/ - - data absa(181:315, 4) / & - & .1150667E+04,.1022958E+04,.8952985E+03,.7676352E+03,.6485262E+03,& - & .6146217E+03,.6614995E+03,.7312576E+03,.8004375E+03,.1128412E+04,& - & .1003487E+04,.8786170E+03,.7537286E+03,.6397248E+03,.6092128E+03,& - & .6603950E+03,.7307176E+03,.8004468E+03,.1108741E+04,.9862884E+03,& - & .8638632E+03,.7414333E+03,.6321640E+03,.6047173E+03,.6593415E+03,& - & .7301049E+03,.8003079E+03,.1091213E+04,.9709590E+03,.8507153E+03,& - & .7304755E+03,.6255493E+03,.6008338E+03,.6583092E+03,.7294008E+03,& - & .8000115E+03,.1075469E+04,.9572202E+03,.8389248E+03,.7206527E+03,& - & .6197031E+03,.5974555E+03,.6572486E+03,.7286139E+03,.7995531E+03,& - & .1097870E+04,.9768019E+03,.8557256E+03,.7346486E+03,.6288307E+03,& - & .6020713E+03,.6586595E+03,.7297565E+03,.8003542E+03,.1078052E+04,& - & .9594624E+03,.8408779E+03,.7222787E+03,.6218550E+03,.5979982E+03,& - & .6577350E+03,.7293614E+03,.8004561E+03,.1060670E+04,.9442276E+03,& - & .8278139E+03,.7113901E+03,.6158860E+03,.5946078E+03,.6568508E+03,& - & .7288896E+03,.8004144E+03,.1045194E+04,.9306942E+03,.8162219E+03,& - & .7017312E+03,.6107127E+03,.5916997E+03,.6559770E+03,.7283342E+03,& - & .8002199E+03,.1031388E+04,.9186406E+03,.8058789E+03,.6931126E+03,& - & .6061547E+03,.5891687E+03,.6550888E+03,.7276821E+03,.7998680E+03,& - & .1052963E+04,.9374921E+03,.8220302E+03,.7065729E+03,.6139864E+03,& - & .5928231E+03,.6561758E+03,.7284058E+03,.8001736E+03,.1035335E+04,& - & .9220734E+03,.8088077E+03,.6955512E+03,.6085341E+03,.5897484E+03,& - & .6554522E+03,.7281509E+03,.8004051E+03,.1019870E+04,.9085454E+03,& - & .7972311E+03,.6859069E+03,.6038862E+03,.5871960E+03,.6547087E+03,& - & .7278186E+03,.8004607E+03,.1006236E+04,.8966542E+03,.7870120E+03,& - & .6773876E+03,.5998494E+03,.5849802E+03,.6539834E+03,.7273980E+03,& - & .8003588E+03,.9941610E+03,.8860349E+03,.7779226E+03,.6698202E+03,& - & .5962793E+03,.5830334E+03,.6532431E+03,.7268747E+03,.8001088E+03/ - - data absa(316:450, 4) / & - & .1014525E+04,.9038521E+03,.7932066E+03,.6825518E+03,.6028710E+03,& - & .5859051E+03,.6539946E+03,.7271787E+03,.7999513E+03,.9987919E+03,& - & .8901187E+03,.7814262E+03,.6727344E+03,.5986427E+03,.5835388E+03,& - & .6534210E+03,.7270632E+03,.8002847E+03,.9851423E+03,.8781550E+03,& - & .7711724E+03,.6641905E+03,.5950831E+03,.5816419E+03,.6528439E+03,& - & .7268557E+03,.8004468E+03,.9731156E+03,.8676435E+03,.7621676E+03,& - & .6566870E+03,.5920005E+03,.5800708E+03,.6522571E+03,.7265599E+03,& - & .8004375E+03,.9624848E+03,.8583463E+03,.7541885E+03,.6500361E+03,& - & .5892896E+03,.5786674E+03,.6516491E+03,.7261614E+03,.8002755E+03,& - & .9817773E+03,.8752109E+03,.7686499E+03,.6620890E+03,.5946884E+03,& - & .5807066E+03,.6520760E+03,.7260596E+03,.7996781E+03,.9677814E+03,& - & .8629603E+03,.7581484E+03,.6533365E+03,.5914754E+03,.5790226E+03,& - & .6516633E+03,.7260782E+03,.8001134E+03,.9556546E+03,.8523548E+03,& - & .7490543E+03,.6457592E+03,.5888086E+03,.5776101E+03,.6512193E+03,& - & .7259955E+03,.8003773E+03,.9450453E+03,.8430869E+03,.7411152E+03,& - & .6391429E+03,.5865198E+03,.5764053E+03,.6507649E+03,.7258146E+03,& - & .8004607E+03,.9357266E+03,.8349146E+03,.7341173E+03,.6333100E+03,& - & .5843768E+03,.5753367E+03,.6502809E+03,.7255256E+03,.8003866E+03,& - & .9528090E+03,.8498570E+03,.7469182E+03,.6439800E+03,.5885144E+03,& - & .5767160E+03,.6503433E+03,.7250381E+03,.7994049E+03,.9404359E+03,& - & .8390577E+03,.7376609E+03,.6362634E+03,.5861145E+03,.5754558E+03,& - & .6500784E+03,.7251769E+03,.7999235E+03,.9298105E+03,.8297558E+03,& - & .7296865E+03,.6296179E+03,.5839417E+03,.5744210E+03,.6497768E+03,& - & .7252044E+03,.8002708E+03,.9205811E+03,.8216675E+03,.7227532E+03,& - & .6238388E+03,.5819578E+03,.5735632E+03,.6494410E+03,.7251291E+03,& - & .8004422E+03,.9124496E+03,.8145610E+03,.7166625E+03,.6187693E+03,& - & .5800439E+03,.5728294E+03,.6490647E+03,.7249410E+03,.8004422E+03/ - - data absa(451:585, 4) / & - & .9228965E+03,.8236997E+03,.7244976E+03,.6252963E+03,.5826587E+03,& - & .5732062E+03,.6487682E+03,.7242367E+03,.7994003E+03,.9127905E+03,& - & .8148481E+03,.7169103E+03,.6189724E+03,.5806411E+03,.5724380E+03,& - & .6486216E+03,.7244324E+03,.7999189E+03,.9040966E+03,.8072260E+03,& - & .7103786E+03,.6135258E+03,.5787682E+03,.5716879E+03,.6484230E+03,& - & .7245206E+03,.8002662E+03,.8965007E+03,.8005998E+03,.7046989E+03,& - & .6087980E+03,.5770291E+03,.5712760E+03,.6481694E+03,.7244914E+03,& - & .8004422E+03,.8898544E+03,.7947815E+03,.6997086E+03,.6046349E+03,& - & .5752976E+03,.5708062E+03,.6478707E+03,.7243347E+03,.8004422E+03,& - & .8983644E+03,.8022304E+03,.7060963E+03,.6099576E+03,.5774937E+03,& - & .5708077E+03,.6474759E+03,.7235789E+03,.7994003E+03,.8901061E+03,& - & .7949847E+03,.6998817E+03,.6047834E+03,.5757149E+03,.5704095E+03,& - & .6474223E+03,.7238307E+03,.7999235E+03,.8829565E+03,.7887454E+03,& - & .6945344E+03,.6003279E+03,.5739676E+03,.5700508E+03,.6473059E+03,& - & .7239504E+03,.8002662E+03,.8767566E+03,.7833188E+03,.6898858E+03,& - & .5964527E+03,.5721368E+03,.5697050E+03,.6471298E+03,.7239527E+03,& - & .8004422E+03,.8713100E+03,.7785510E+03,.6858020E+03,.5930430E+03,& - & .5702838E+03,.5693558E+03,.6468926E+03,.7238360E+03,.8004422E+03,& - & .8782779E+03,.7846517E+03,.6910308E+03,.5974092E+03,.5724839E+03,& - & .5692167E+03,.6464156E+03,.7230395E+03,.7994003E+03,.8714985E+03,& - & .7787195E+03,.6859459E+03,.5931669E+03,.5705842E+03,.5689690E+03,& - & .6464442E+03,.7233274E+03,.7999235E+03,.8656602E+03,.7736099E+03,& - & .6815696E+03,.5895194E+03,.5686553E+03,.5687141E+03,.6463947E+03,& - & .7234879E+03,.8002708E+03,.8605853E+03,.7691745E+03,.6777583E+03,& - & .5863474E+03,.5667574E+03,.5684512E+03,.6462754E+03,.7235209E+03,& - & .8004422E+03,.8561252E+03,.7652692E+03,.6744132E+03,.5835572E+03,& - & .5649152E+03,.5681796E+03,.6460944E+03,.7234350E+03,.8004422E+03/ - - data absa( 1:180, 5) / & - & .1921397E+04,.1686175E+04,.1450918E+04,.1215651E+04,.9804589E+03,& - & .7485868E+03,.8483659E+03,.9768410E+03,.1106468E+04,.1872699E+04,& - & .1643569E+04,.1414370E+04,.1185266E+04,.9561203E+03,.7344024E+03,& - & .8467260E+03,.9754207E+03,.1105202E+04,.1828966E+04,.1605287E+04,& - & .1381610E+04,.1157925E+04,.9342532E+03,.7247494E+03,.8449271E+03,& - & .9738067E+03,.1103587E+04,.1789486E+04,.1570750E+04,.1351993E+04,& - & .1133258E+04,.9145250E+03,.7183685E+03,.8429653E+03,.9719387E+03,& - & .1101677E+04,.1753694E+04,.1539382E+04,.1325155E+04,.1110855E+04,& - & .8966094E+03,.7139851E+03,.8408707E+03,.9698995E+03,.1099550E+04,& - & .1775002E+04,.1558008E+04,.1341156E+04,.1124178E+04,.9072693E+03,& - & .7199288E+03,.8471982E+03,.9765647E+03,.1106903E+04,.1733216E+04,& - & .1521534E+04,.1309834E+04,.1098091E+04,.8863907E+03,.7174123E+03,& - & .8457590E+03,.9752894E+03,.1105710E+04,.1695794E+04,.1488814E+04,& - & .1281745E+04,.1074723E+04,.8676958E+03,.7156385E+03,.8441368E+03,& - & .9737966E+03,.1104271E+04,.1662143E+04,.1459341E+04,.1256502E+04,& - & .1053659E+04,.8508412E+03,.7137237E+03,.8423258E+03,.9720960E+03,& - & .1102513E+04,.1631619E+04,.1432618E+04,.1233592E+04,.1034579E+04,& - & .8355734E+03,.7116486E+03,.8403867E+03,.9701499E+03,.1100500E+04,& - & .1659891E+04,.1457315E+04,.1254812E+04,.1052240E+04,.8497202E+03,& - & .7175527E+03,.8464715E+03,.9765415E+03,.1107518E+04,.1623228E+04,& - & .1425304E+04,.1227301E+04,.1029375E+04,.8314009E+03,.7161499E+03,& - & .8452402E+03,.9754612E+03,.1106487E+04,.1590539E+04,.1396639E+04,& - & .1202788E+04,.1008908E+04,.8150480E+03,.7145901E+03,.8438213E+03,& - & .9741374E+03,.1105224E+04,.1561180E+04,.1371014E+04,.1180792E+04,& - & .9905638E+03,.8003605E+03,.7128878E+03,.8422042E+03,.9726066E+03,& - & .1103635E+04,.1534665E+04,.1347786E+04,.1160902E+04,.9740042E+03,& - & .7871058E+03,.7110306E+03,.8404136E+03,.9708259E+03,.1101753E+04,& - & .1564387E+04,.1373801E+04,.1183199E+04,.9925688E+03,.8019746E+03,& - & .7163274E+03,.8458907E+03,.9765642E+03,.1107990E+04,.1532032E+04,& - & .1345436E+04,.1158880E+04,.9723223E+03,.7857601E+03,.7151483E+03,& - & .8448704E+03,.9756467E+03,.1107164E+04,.1503216E+04,.1320225E+04,& - & .1137324E+04,.9543379E+03,.7713655E+03,.7138061E+03,.8436484E+03,& - & .9745256E+03,.1106074E+04,.1477480E+04,.1297700E+04,.1117987E+04,& - & .9382370E+03,.7585035E+03,.7123059E+03,.8422273E+03,.9731665E+03,& - & .1104675E+04,.1454275E+04,.1277417E+04,.1100599E+04,.9237584E+03,& - & .7469097E+03,.7106555E+03,.8406082E+03,.9715630E+03,.1103011E+04/ - - data absa(181:315, 5) / & - & .1483270E+04,.1302824E+04,.1122346E+04,.9418665E+03,.7613975E+03,& - & .7152456E+03,.8453518E+03,.9765193E+03,.1108347E+04,.1454554E+04,& - & .1277730E+04,.1100817E+04,.9239508E+03,.7470711E+03,.7142698E+03,& - & .8445296E+03,.9757838E+03,.1107704E+04,.1429277E+04,.1255537E+04,& - & .1081803E+04,.9080984E+03,.7343933E+03,.7131346E+03,.8435047E+03,& - & .9748486E+03,.1106819E+04,.1406637E+04,.1235745E+04,.1064862E+04,& - & .8939670E+03,.7230809E+03,.7118341E+03,.8422567E+03,.9736530E+03,& - & .1105584E+04,.1386352E+04,.1217991E+04,.1049654E+04,.8813175E+03,& - & .7129541E+03,.7103644E+03,.8408216E+03,.9722114E+03,.1104099E+04,& - & .1415280E+04,.1243273E+04,.1071368E+04,.8993573E+03,.7273941E+03,& - & .7142932E+03,.8448580E+03,.9764281E+03,.1108541E+04,.1389733E+04,& - & .1220958E+04,.1052188E+04,.8834056E+03,.7146427E+03,.7135269E+03,& - & .8442338E+03,.9758859E+03,.1108141E+04,.1367294E+04,.1201275E+04,& - & .1035372E+04,.8693794E+03,.7034205E+03,.7125886E+03,.8433949E+03,& - & .9751144E+03,.1107408E+04,.1347369E+04,.1183915E+04,.1020401E+04,& - & .8569345E+03,.6934430E+03,.7114752E+03,.8423448E+03,.9741143E+03,& - & .1106423E+04,.1329578E+04,.1168334E+04,.1007064E+04,.8458218E+03,& - & .6845663E+03,.7101924E+03,.8410834E+03,.9728599E+03,.1105097E+04,& - & .1357347E+04,.1192598E+04,.1027874E+04,.8631699E+03,.6984448E+03,& - & .7134207E+03,.8443831E+03,.9763011E+03,.1108758E+04,.1334644E+04,& - & .1172715E+04,.1010833E+04,.8489539E+03,.6870762E+03,.7128438E+03,& - & .8439045E+03,.9759286E+03,.1108430E+04,.1314672E+04,.1155279E+04,& - & .9959069E+03,.8365335E+03,.6771252E+03,.7120902E+03,.8432747E+03,& - & .9753288E+03,.1107888E+04,.1297153E+04,.1139973E+04,.9827356E+03,& - & .8255379E+03,.6683354E+03,.7111590E+03,.8424009E+03,.9744943E+03,& - & .1107103E+04,.1281549E+04,.1126289E+04,.9710294E+03,.8157849E+03,& - & .6605299E+03,.7100490E+03,.8413065E+03,.9734035E+03,.1105937E+04/ - - data absa(316:450, 5) / & - & .1307799E+04,.1149258E+04,.9907270E+03,.8322002E+03,.6736660E+03,& - & .7126027E+03,.8439097E+03,.9761135E+03,.1108805E+04,.1287540E+04,& - & .1131537E+04,.9755603E+03,.8195432E+03,.6635490E+03,.7122058E+03,& - & .8436121E+03,.9758993E+03,.1108673E+04,.1269927E+04,.1116126E+04,& - & .9623208E+03,.8085370E+03,.6547258E+03,.7116273E+03,.8431237E+03,& - & .9754680E+03,.1108244E+04,.1254438E+04,.1102594E+04,.9507274E+03,& - & .7988474E+03,.6469982E+03,.7108636E+03,.8424204E+03,.9747864E+03,& - & .1107597E+04,.1240737E+04,.1090596E+04,.9404282E+03,.7903006E+03,& - & .6401369E+03,.7099113E+03,.8414889E+03,.9738621E+03,.1106649E+04,& - & .1265622E+04,.1112367E+04,.9590789E+03,.8058196E+03,.6525657E+03,& - & .7118328E+03,.8434406E+03,.9758605E+03,.1108716E+04,.1247560E+04,& - & .1096553E+04,.9455416E+03,.7945397E+03,.6435460E+03,.7116013E+03,& - & .8432871E+03,.9758224E+03,.1108744E+04,.1231894E+04,.1082859E+04,& - & .9338167E+03,.7847896E+03,.6357324E+03,.7111927E+03,.8429522E+03,& - & .9755286E+03,.1108560E+04,.1218302E+04,.1070950E+04,.9235833E+03,& - & .7762412E+03,.6289015E+03,.7105830E+03,.8424056E+03,.9749952E+03,& - & .1108010E+04,.1206262E+04,.1060398E+04,.9145570E+03,.7687192E+03,& - & .6229813E+03,.7097942E+03,.8416349E+03,.9742335E+03,.1107264E+04,& - & .1228234E+04,.1079659E+04,.9310619E+03,.7824865E+03,.6338926E+03,& - & .7111057E+03,.8429845E+03,.9755941E+03,.1108579E+04,.1212319E+04,& - & .1065758E+04,.9191269E+03,.7725251E+03,.6260392E+03,.7110095E+03,& - & .8429498E+03,.9756589E+03,.1108771E+04,.1198612E+04,.1053738E+04,& - & .9088499E+03,.7639808E+03,.6194625E+03,.7107383E+03,.8427382E+03,& - & .9755143E+03,.1108675E+04,.1186692E+04,.1043289E+04,.8999106E+03,& - & .7565209E+03,.6138184E+03,.7102789E+03,.8423199E+03,.9751033E+03,& - & .1108322E+04,.1176220E+04,.1034168E+04,.8920570E+03,.7499699E+03,& - & .6090103E+03,.7096231E+03,.8416809E+03,.9744656E+03,.1107679E+04/ - - data absa(451:585, 5) / & - & .1189698E+04,.1045913E+04,.9021705E+03,.7583950E+03,.6153540E+03,& - & .7104698E+03,.8425981E+03,.9754239E+03,.1108576E+04,.1176635E+04,& - & .1034523E+04,.8923869E+03,.7502341E+03,.6094352E+03,.7104222E+03,& - & .8425962E+03,.9755058E+03,.1108734E+04,.1165429E+04,.1024685E+04,& - & .8839611E+03,.7432232E+03,.6045181E+03,.7101914E+03,.8424044E+03,& - & .9753409E+03,.1108675E+04,.1155697E+04,.1016166E+04,.8766431E+03,& - & .7371151E+03,.6003622E+03,.7097679E+03,.8420139E+03,.9749621E+03,& - & .1108322E+04,.1147121E+04,.1008658E+04,.8702118E+03,.7317633E+03,& - & .5967883E+03,.7091490E+03,.8413991E+03,.9743362E+03,.1107679E+04,& - & .1158071E+04,.1018256E+04,.8784521E+03,.7386226E+03,.6015990E+03,& - & .7099541E+03,.8422884E+03,.9752818E+03,.1108579E+04,.1147403E+04,& - & .1008908E+04,.8704370E+03,.7319491E+03,.5971897E+03,.7099414E+03,& - & .8423049E+03,.9753726E+03,.1108766E+04,.1138174E+04,.1000855E+04,& - & .8635459E+03,.7261979E+03,.5935081E+03,.7097458E+03,.8421398E+03,& - & .9752320E+03,.1108695E+04,.1130203E+04,.9938656E+03,.8575435E+03,& - & .7212024E+03,.5905613E+03,.7093511E+03,.8417643E+03,.9748491E+03,& - & .1108322E+04,.1123201E+04,.9877521E+03,.8522707E+03,.7168232E+03,& - & .5880771E+03,.7087599E+03,.8411666E+03,.9742254E+03,.1107679E+04,& - & .1132182E+04,.9955937E+03,.8590183E+03,.7224580E+03,.5914804E+03,& - & .7095304E+03,.8420290E+03,.9751646E+03,.1108576E+04,.1123422E+04,& - & .9879637E+03,.8524632E+03,.7169730E+03,.5885566E+03,.7095493E+03,& - & .8420734E+03,.9752650E+03,.1108766E+04,.1115932E+04,.9813727E+03,& - & .8468160E+03,.7122910E+03,.5862722E+03,.7093820E+03,.8419175E+03,& - & .9751333E+03,.1108697E+04,.1109330E+04,.9756452E+03,.8419083E+03,& - & .7081783E+03,.5843612E+03,.7090122E+03,.8415604E+03,.9747502E+03,& - & .1108322E+04,.1103600E+04,.9706010E+03,.8376039E+03,.7045930E+03,& - & .5827075E+03,.7084398E+03,.8409654E+03,.9741292E+03,.1107699E+04/ - - data absa( 1:180, 6) / & - & .1959531E+04,.1718854E+04,.1478161E+04,.1237527E+04,.9965716E+03,& - & .7556952E+03,.8878598E+03,.1025441E+04,.1163518E+04,.1910117E+04,& - & .1675238E+04,.1441129E+04,.1206451E+04,.9715933E+03,.7486894E+03,& - & .8856157E+03,.1023242E+04,.1161590E+04,.1865741E+04,.1636653E+04,& - & .1407543E+04,.1178524E+04,.9494810E+03,.7463519E+03,.8833101E+03,& - & .1021156E+04,.1159586E+04,.1825329E+04,.1601414E+04,.1377281E+04,& - & .1153436E+04,.9292048E+03,.7441661E+03,.8810616E+03,.1019015E+04,& - & .1157664E+04,.1788734E+04,.1569552E+04,.1349728E+04,.1130211E+04,& - & .9109703E+03,.7423144E+03,.8791860E+03,.1017194E+04,.1156120E+04,& - & .1810667E+04,.1588518E+04,.1365889E+04,.1144195E+04,.9217339E+03,& - & .7496752E+03,.8873525E+03,.1025601E+04,.1164351E+04,.1767935E+04,& - & .1551019E+04,.1334009E+04,.1117420E+04,.9004784E+03,.7475656E+03,& - & .8852456E+03,.1023476E+04,.1162461E+04,.1730070E+04,.1517401E+04,& - & .1305332E+04,.1093709E+04,.8814078E+03,.7453610E+03,.8830458E+03,& - & .1021470E+04,.1160440E+04,.1695360E+04,.1487399E+04,.1279829E+04,& - & .1072014E+04,.8642946E+03,.7431708E+03,.8808442E+03,.1019364E+04,& - & .1158466E+04,.1664351E+04,.1460274E+04,.1256503E+04,.1052675E+04,& - & .8488905E+03,.7412704E+03,.8787936E+03,.1017361E+04,.1156598E+04,& - & .1692847E+04,.1485753E+04,.1277843E+04,.1070752E+04,.8629425E+03,& - & .7489667E+03,.8873589E+03,.1026231E+04,.1165463E+04,.1655805E+04,& - & .1452438E+04,.1250044E+04,.1047170E+04,.8442632E+03,.7470728E+03,& - & .8854219E+03,.1024283E+04,.1163647E+04,.1622518E+04,.1423594E+04,& - & .1225186E+04,.1026305E+04,.8276242E+03,.7450344E+03,.8833410E+03,& - & .1022268E+04,.1161651E+04,.1592305E+04,.1397067E+04,.1202289E+04,& - & .1007702E+04,.8128099E+03,.7429351E+03,.8811642E+03,.1020198E+04,& - & .1159643E+04,.1565538E+04,.1374036E+04,.1182269E+04,.9906999E+03,& - & .7993235E+03,.7408812E+03,.8791490E+03,.1018131E+04,.1157722E+04,& - & .1595853E+04,.1400292E+04,.1205058E+04,.1009761E+04,.8142929E+03,& - & .7485108E+03,.8875129E+03,.1026919E+04,.1166552E+04,.1562424E+04,& - & .1371454E+04,.1180385E+04,.9891526E+03,.7980135E+03,.7468116E+03,& - & .8857444E+03,.1025101E+04,.1164785E+04,.1533329E+04,.1345902E+04,& - & .1157909E+04,.9706094E+03,.7833915E+03,.7449296E+03,.8838178E+03,& - & .1023113E+04,.1162949E+04,.1506815E+04,.1322783E+04,.1138509E+04,& - & .9542707E+03,.7700244E+03,.7429706E+03,.8817581E+03,.1021134E+04,& - & .1160909E+04,.1483525E+04,.1302151E+04,.1120847E+04,.9395369E+03,& - & .7583538E+03,.7409557E+03,.8796852E+03,.1019111E+04,.1158929E+04/ - - data absa(181:315, 6) / & - & .1513129E+04,.1327990E+04,.1143143E+04,.9581972E+03,.7731973E+03,& - & .7481396E+03,.8876647E+03,.1027513E+04,.1167635E+04,.1483937E+04,& - & .1302350E+04,.1121247E+04,.9397374E+03,.7584554E+03,.7466326E+03,& - & .8860686E+03,.1025860E+04,.1165939E+04,.1457483E+04,.1279624E+04,& - & .1101680E+04,.9236394E+03,.7454131E+03,.7449496E+03,.8842965E+03,& - & .1024016E+04,.1164125E+04,.1434740E+04,.1259742E+04,.1084277E+04,& - & .9093323E+03,.7341125E+03,.7431059E+03,.8823611E+03,.1022090E+04,& - & .1162195E+04,.1414268E+04,.1241399E+04,.1069062E+04,.8962430E+03,& - & .7237532E+03,.7411783E+03,.8803301E+03,.1020088E+04,.1160046E+04,& - & .1443413E+04,.1267263E+04,.1090769E+04,.9146514E+03,.7383327E+03,& - & .7478733E+03,.8878478E+03,.1028105E+04,.1168673E+04,.1417362E+04,& - & .1244305E+04,.1071260E+04,.8985200E+03,.7252711E+03,.7465473E+03,& - & .8864251E+03,.1026618E+04,.1167048E+04,.1394536E+04,.1224485E+04,& - & .1054035E+04,.8840393E+03,.7137145E+03,.7450404E+03,.8848148E+03,& - & .1024911E+04,.1165266E+04,.1374225E+04,.1206403E+04,.1039030E+04,& - & .8713103E+03,.7039093E+03,.7433577E+03,.8830245E+03,.1023032E+04,& - & .1163474E+04,.1355994E+04,.1190773E+04,.1025482E+04,.8599459E+03,& - & .6945499E+03,.7415048E+03,.8810884E+03,.1021122E+04,.1161496E+04,& - & .1384460E+04,.1215767E+04,.1046795E+04,.8776721E+03,.7087541E+03,& - & .7476361E+03,.8879985E+03,.1028620E+04,.1169529E+04,.1361124E+04,& - & .1195393E+04,.1029345E+04,.8633440E+03,.6972452E+03,.7464861E+03,& - & .8867535E+03,.1027287E+04,.1168092E+04,.1341125E+04,.1177698E+04,& - & .1014028E+04,.8503722E+03,.6871520E+03,.7451498E+03,.8852979E+03,& - & .1025745E+04,.1166403E+04,.1323047E+04,.1161999E+04,.1000760E+04,& - & .8395248E+03,.6782983E+03,.7436254E+03,.8836587E+03,.1024005E+04,& - & .1164622E+04,.1306967E+04,.1147930E+04,.9887562E+03,.8294106E+03,& - & .6702789E+03,.7419326E+03,.8818404E+03,.1022008E+04,.1162734E+04/ - - data absa(316:450, 6) / & - & .1334109E+04,.1171345E+04,.1008923E+04,.8461200E+03,.6835456E+03,& - & .7474174E+03,.8881153E+03,.1029011E+04,.1170451E+04,.1313327E+04,& - & .1153250E+04,.9930497E+03,.8333106E+03,.6731748E+03,.7464228E+03,& - & .8870239E+03,.1027877E+04,.1168986E+04,.1295219E+04,.1137547E+04,& - & .9799434E+03,.8219514E+03,.6643371E+03,.7452458E+03,.8857278E+03,& - & .1026491E+04,.1167438E+04,.1279553E+04,.1123751E+04,.9678431E+03,& - & .8123012E+03,.6562950E+03,.7438793E+03,.8842286E+03,.1024816E+04,& - & .1165703E+04,.1265724E+04,.1111449E+04,.9576137E+03,.8031933E+03,& - & .6494532E+03,.7423259E+03,.8825429E+03,.1023034E+04,.1163868E+04,& - & .1290515E+04,.1133583E+04,.9764835E+03,.8192474E+03,.6620508E+03,& - & .7472103E+03,.8882292E+03,.1029567E+04,.1171352E+04,.1272606E+04,& - & .1117592E+04,.9626389E+03,.8077755E+03,.6527492E+03,.7463629E+03,& - & .8872547E+03,.1028405E+04,.1169825E+04,.1256652E+04,.1103698E+04,& - & .9508267E+03,.7976036E+03,.6448586E+03,.7453404E+03,.8861112E+03,& - & .1027107E+04,.1168295E+04,.1242559E+04,.1091491E+04,.9403080E+03,& - & .7891129E+03,.6378974E+03,.7441189E+03,.8847532E+03,.1025673E+04,& - & .1166733E+04,.1230258E+04,.1080509E+04,.9310347E+03,.7814702E+03,& - & .6317827E+03,.7427070E+03,.8832010E+03,.1023957E+04,.1164903E+04,& - & .1252792E+04,.1100066E+04,.9479412E+03,.7952615E+03,.6429338E+03,& - & .7470122E+03,.8882931E+03,.1029973E+04,.1172174E+04,.1236775E+04,& - & .1086029E+04,.9357359E+03,.7854390E+03,.6347013E+03,.7462389E+03,& - & .8873859E+03,.1028765E+04,.1170458E+04,.1222725E+04,.1073962E+04,& - & .9252515E+03,.7763294E+03,.6276457E+03,.7453420E+03,.8863540E+03,& - & .1027586E+04,.1169067E+04,.1210413E+04,.1063428E+04,.9161707E+03,& - & .7689610E+03,.6219689E+03,.7442455E+03,.8851226E+03,.1026224E+04,& - & .1167546E+04,.1199891E+04,.1053872E+04,.9082626E+03,.7623785E+03,& - & .6166061E+03,.7429574E+03,.8836539E+03,.1024662E+04,.1165837E+04/ - - data absa(451:585, 6) / & - & .1213435E+04,.1066122E+04,.9182536E+03,.7707858E+03,.6233804E+03,& - & .7465268E+03,.8879869E+03,.1029819E+04,.1172194E+04,.1200202E+04,& - & .1054292E+04,.9083498E+03,.7627042E+03,.6165912E+03,.7457906E+03,& - & .8870951E+03,.1028665E+04,.1170524E+04,.1188659E+04,.1044342E+04,& - & .8998639E+03,.7554328E+03,.6110074E+03,.7449213E+03,.8860867E+03,& - & .1027451E+04,.1169072E+04,.1178858E+04,.1035658E+04,.8922892E+03,& - & .7492634E+03,.6059606E+03,.7438596E+03,.8848729E+03,.1026124E+04,& - & .1167566E+04,.1169796E+04,.1027749E+04,.8857341E+03,.7436862E+03,& - & .6022412E+03,.7425912E+03,.8834588E+03,.1024571E+04,.1165837E+04,& - & .1181101E+04,.1037633E+04,.8940681E+03,.7506851E+03,.6074386E+03,& - & .7461265E+03,.8877353E+03,.1029711E+04,.1172179E+04,.1170091E+04,& - & .1028027E+04,.8859634E+03,.7439636E+03,.6039202E+03,.7454203E+03,& - & .8868566E+03,.1028531E+04,.1170527E+04,.1161160E+04,.1020142E+04,& - & .8789356E+03,.7381596E+03,.6035305E+03,.7445721E+03,.8858628E+03,& - & .1027386E+04,.1169067E+04,.1152818E+04,.1012820E+04,.8728840E+03,& - & .7330614E+03,.6026851E+03,.7435297E+03,.8846310E+03,.1025991E+04,& - & .1167566E+04,.1145364E+04,.1006499E+04,.8676452E+03,.7284487E+03,& - & .6016648E+03,.7422863E+03,.8832630E+03,.1024470E+04,.1165837E+04,& - & .1154769E+04,.1014599E+04,.8744908E+03,.7339035E+03,.6044416E+03,& - & .7457969E+03,.8875272E+03,.1029611E+04,.1172169E+04,.1146093E+04,& - & .1006648E+04,.8677377E+03,.7287407E+03,.6038007E+03,.7451183E+03,& - & .8866614E+03,.1028431E+04,.1170524E+04,.1138431E+04,.1000012E+04,& - & .8620420E+03,.7235398E+03,.6031357E+03,.7442908E+03,.8856774E+03,& - & .1027286E+04,.1169074E+04,.1131504E+04,.9941179E+03,.8570033E+03,& - & .7197199E+03,.6023129E+03,.7432633E+03,.8844627E+03,.1025923E+04,& - & .1167566E+04,.1125720E+04,.9892480E+03,.8524798E+03,.7159207E+03,& - & .6012892E+03,.7420375E+03,.8831033E+03,.1024380E+04,.1165837E+04/ - -! the array absb(1175,6) (kb(5,5,13:59,6)) contains absorption coefs at -! the 16 chosen g-values for a range of pressure levels < ~100mb and -! temperatures. the first index in the array, jt, which runs from 1 to 5, -! corresponds to different temperatures. more specifically, jt = 3 means -! that the data are for the reference temperature tref for this pressure -! level, jt = 2 refers to the temperature tref-15, jt = 1 is for -! tref-30, jt = 4 is for tref+15, and jt = 5 is for tref+30. -! the second index, jp, runs from 13 to 59 and refers to the jpth -! reference pressure level (see taumol.f for the value of these -! pressure levels in mb). the third index, ig, goes from 1 to 6, -! and tells us which g-interval the absorption coefficients are for. - - data absb( 1:175, 1) / & - & .2736900E+02,.2990300E+03,.4292400E+03,.3103900E+03,.3500000E+02,& - & .2715800E+02,.2989800E+03,.4274500E+03,.3084000E+03,.3500000E+02,& - & .2697600E+02,.2988900E+03,.4259000E+03,.3066800E+03,.3500000E+02,& - & .2681800E+02,.2987500E+03,.4245500E+03,.3051700E+03,.3500000E+02,& - & .2667900E+02,.2985500E+03,.4233500E+03,.3038400E+03,.3500000E+02,& - & .2684000E+02,.2986300E+03,.4247400E+03,.3053800E+03,.3500000E+02,& - & .2666900E+02,.2986200E+03,.4232700E+03,.3037500E+03,.3500000E+02,& - & .2652200E+02,.2985400E+03,.4219900E+03,.3023400E+03,.3500000E+02,& - & .2639400E+02,.2984200E+03,.4208800E+03,.3011100E+03,.3500000E+02,& - & .2628200E+02,.2982400E+03,.4199000E+03,.3000200E+03,.3500000E+02,& - & .2640800E+02,.2983100E+03,.4210000E+03,.3012400E+03,.3500000E+02,& - & .2627100E+02,.2983200E+03,.4198000E+03,.2999100E+03,.3500000E+02,& - & .2615200E+02,.2982600E+03,.4187600E+03,.2987700E+03,.3500000E+02,& - & .2604900E+02,.2981400E+03,.4178500E+03,.2977600E+03,.3500000E+02,& - & .2595800E+02,.2979700E+03,.4170500E+03,.2968800E+03,.3500000E+02,& - & .2605700E+02,.2980600E+03,.4179300E+03,.2978400E+03,.3500000E+02,& - & .2594600E+02,.2980700E+03,.4169500E+03,.2967600E+03,.3500000E+02,& - & .2585100E+02,.2980300E+03,.4161000E+03,.2958300E+03,.3500000E+02,& - & .2576700E+02,.2979200E+03,.4153600E+03,.2950200E+03,.3500000E+02,& - & .2569400E+02,.2977600E+03,.4147000E+03,.2943000E+03,.3500000E+02,& - & .2577200E+02,.2978500E+03,.4154000E+03,.2950600E+03,.3500000E+02,& - & .2568300E+02,.2978700E+03,.4146000E+03,.2941900E+03,.3500000E+02,& - & .2560600E+02,.2978400E+03,.4139100E+03,.2934300E+03,.3500000E+02,& - & .2553800E+02,.2977400E+03,.4133100E+03,.2927700E+03,.3500000E+02,& - & .2547900E+02,.2975800E+03,.4127800E+03,.2921900E+03,.3500000E+02,& - & .2554100E+02,.2976800E+03,.4133400E+03,.2928000E+03,.3500000E+02,& - & .2546900E+02,.2977200E+03,.4126900E+03,.2920900E+03,.3500000E+02,& - & .2540700E+02,.2976800E+03,.4121300E+03,.2914700E+03,.3500000E+02,& - & .2535300E+02,.2975800E+03,.4116300E+03,.2909400E+03,.3500000E+02,& - & .2530500E+02,.2974300E+03,.4112000E+03,.2904600E+03,.3500000E+02,& - & .2535400E+02,.2975500E+03,.4116500E+03,.2909500E+03,.3500000E+02,& - & .2529600E+02,.2975800E+03,.4111200E+03,.2903700E+03,.3500000E+02,& - & .2524500E+02,.2975500E+03,.4106700E+03,.2898800E+03,.3500000E+02,& - & .2520100E+02,.2974600E+03,.4102700E+03,.2894400E+03,.3500000E+02,& - & .2516300E+02,.2973000E+03,.4099100E+03,.2890500E+03,.3500000E+02/ - - data absb(176:350, 1) / & - & .2520100E+02,.2974400E+03,.4102600E+03,.2894300E+03,.3500000E+02,& - & .2515400E+02,.2974800E+03,.4098400E+03,.2889700E+03,.3500000E+02,& - & .2511300E+02,.2974500E+03,.4094700E+03,.2885600E+03,.3500000E+02,& - & .2507800E+02,.2973500E+03,.4091400E+03,.2882100E+03,.3500000E+02,& - & .2504700E+02,.2971900E+03,.4088600E+03,.2879000E+03,.3500000E+02,& - & .2507600E+02,.2973600E+03,.4091300E+03,.2881900E+03,.3500000E+02,& - & .2503900E+02,.2973900E+03,.4087900E+03,.2878200E+03,.3500000E+02,& - & .2500600E+02,.2973600E+03,.4084900E+03,.2874900E+03,.3500000E+02,& - & .2497800E+02,.2972600E+03,.4082300E+03,.2872200E+03,.3500000E+02,& - & .2495200E+02,.2971000E+03,.4080000E+03,.2869500E+03,.3500000E+02,& - & .2497300E+02,.2972900E+03,.4081900E+03,.2871700E+03,.3500000E+02,& - & .2494400E+02,.2973200E+03,.4079200E+03,.2868700E+03,.3500000E+02,& - & .2491700E+02,.2972800E+03,.4076800E+03,.2866100E+03,.3500000E+02,& - & .2489500E+02,.2971700E+03,.4074700E+03,.2863800E+03,.3500000E+02,& - & .2487400E+02,.2970000E+03,.4072800E+03,.2861800E+03,.3500000E+02,& - & .2489000E+02,.2972400E+03,.4074300E+03,.2863400E+03,.3500000E+02,& - & .2486600E+02,.2972600E+03,.4072100E+03,.2861000E+03,.3500000E+02,& - & .2484600E+02,.2972100E+03,.4070200E+03,.2858900E+03,.3500000E+02,& - & .2482700E+02,.2971000E+03,.4068500E+03,.2857100E+03,.3500000E+02,& - & .2481100E+02,.2969200E+03,.4067100E+03,.2855400E+03,.3500000E+02,& - & .2482300E+02,.2972100E+03,.4068100E+03,.2856600E+03,.3500000E+02,& - & .2480400E+02,.2972100E+03,.4066400E+03,.2854700E+03,.3500000E+02,& - & .2478700E+02,.2971500E+03,.4064900E+03,.2853000E+03,.3500000E+02,& - & .2477300E+02,.2970300E+03,.4063500E+03,.2851600E+03,.3500000E+02,& - & .2476000E+02,.2968400E+03,.4062300E+03,.2850300E+03,.3500000E+02,& - & .2476900E+02,.2971700E+03,.4063100E+03,.2851100E+03,.3500000E+02,& - & .2475300E+02,.2971700E+03,.4061800E+03,.2849600E+03,.3500000E+02,& - & .2474000E+02,.2971000E+03,.4060600E+03,.2848300E+03,.3500000E+02,& - & .2472900E+02,.2969600E+03,.4059500E+03,.2847200E+03,.3500000E+02,& - & .2471800E+02,.2967600E+03,.4058500E+03,.2846200E+03,.3500000E+02,& - & .2472400E+02,.2971500E+03,.4059100E+03,.2846700E+03,.3500000E+02,& - & .2471200E+02,.2971300E+03,.4058000E+03,.2845600E+03,.3500000E+02,& - & .2470200E+02,.2970400E+03,.4057000E+03,.2844500E+03,.3500000E+02,& - & .2469300E+02,.2968900E+03,.4056200E+03,.2843500E+03,.3500000E+02,& - & .2468400E+02,.2966800E+03,.4055400E+03,.2842700E+03,.3500000E+02/ - - data absb(351:525, 1) / & - & .2468900E+02,.2971300E+03,.4055800E+03,.2843100E+03,.3500000E+02,& - & .2467900E+02,.2970900E+03,.4055000E+03,.2842200E+03,.3500000E+02,& - & .2467100E+02,.2969900E+03,.4054200E+03,.2842300E+03,.3500000E+02,& - & .2466400E+02,.2968300E+03,.4053500E+03,.2840500E+03,.3500000E+02,& - & .2465700E+02,.2966000E+03,.4052900E+03,.2839900E+03,.3500000E+02,& - & .2466000E+02,.2971000E+03,.4053200E+03,.2840400E+03,.3500000E+02,& - & .2465300E+02,.2970600E+03,.4052500E+03,.2839500E+03,.3500000E+02,& - & .2464600E+02,.2969400E+03,.4051900E+03,.2838900E+03,.3500000E+02,& - & .2464000E+02,.2967600E+03,.4051400E+03,.2838300E+03,.3500000E+02,& - & .2463500E+02,.2965100E+03,.4050900E+03,.2837600E+03,.3500000E+02,& - & .2463700E+02,.2970800E+03,.4051100E+03,.2838000E+03,.3500000E+02,& - & .2463100E+02,.2970200E+03,.4050500E+03,.2837400E+03,.3500000E+02,& - & .2462600E+02,.2968900E+03,.4050000E+03,.2836800E+03,.3500000E+02,& - & .2462100E+02,.2966900E+03,.4049600E+03,.2836400E+03,.3500000E+02,& - & .2461700E+02,.2964300E+03,.4049200E+03,.2835900E+03,.3500000E+02,& - & .2461900E+02,.2970600E+03,.4049400E+03,.2836000E+03,.3500000E+02,& - & .2461400E+02,.2969800E+03,.4048900E+03,.2835500E+03,.3500000E+02,& - & .2461000E+02,.2968300E+03,.4048500E+03,.2835100E+03,.3500000E+02,& - & .2460600E+02,.2966200E+03,.4048200E+03,.2834700E+03,.3500000E+02,& - & .2460300E+02,.2963400E+03,.4047900E+03,.2834400E+03,.3500000E+02,& - & .2460400E+02,.2970400E+03,.4048000E+03,.2834500E+03,.3500000E+02,& - & .2460000E+02,.2969400E+03,.4047700E+03,.2834100E+03,.3500000E+02,& - & .2459700E+02,.2967800E+03,.4047300E+03,.2833800E+03,.3500000E+02,& - & .2459400E+02,.2965500E+03,.4047100E+03,.2833600E+03,.3500000E+02,& - & .2459100E+02,.2962500E+03,.4046800E+03,.2833200E+03,.3500000E+02,& - & .2459200E+02,.2970100E+03,.4046900E+03,.2833300E+03,.3500000E+02,& - & .2458900E+02,.2968900E+03,.4046600E+03,.2833000E+03,.3500000E+02,& - & .2458600E+02,.2967200E+03,.4046400E+03,.2832800E+03,.3500000E+02,& - & .2458400E+02,.2964700E+03,.4046100E+03,.2832400E+03,.3500000E+02,& - & .2458200E+02,.2961500E+03,.4045900E+03,.2832500E+03,.3500000E+02,& - & .2458200E+02,.2969800E+03,.4046000E+03,.2832300E+03,.3500000E+02,& - & .2458000E+02,.2968500E+03,.4045800E+03,.2832100E+03,.3500000E+02,& - & .2457800E+02,.2966500E+03,.4045600E+03,.2831800E+03,.3500000E+02,& - & .2457600E+02,.2963900E+03,.4045400E+03,.2831700E+03,.3500000E+02,& - & .2457400E+02,.2960500E+03,.4045200E+03,.2831500E+03,.3500000E+02/ - - data absb(526:700, 1) / & - & .2457400E+02,.2969500E+03,.4045300E+03,.2831500E+03,.3500000E+02,& - & .2457200E+02,.2968000E+03,.4045100E+03,.2831300E+03,.3500000E+02,& - & .2457100E+02,.2965900E+03,.4044900E+03,.2831200E+03,.3500000E+02,& - & .2456900E+02,.2963100E+03,.4044800E+03,.2831000E+03,.3500000E+02,& - & .2456800E+02,.2959600E+03,.4044700E+03,.2830800E+03,.3500000E+02,& - & .2456800E+02,.2969300E+03,.4044700E+03,.2830900E+03,.3500000E+02,& - & .2456700E+02,.2967800E+03,.4044600E+03,.2830800E+03,.3500000E+02,& - & .2456500E+02,.2965600E+03,.4044400E+03,.2830600E+03,.3500000E+02,& - & .2456400E+02,.2962700E+03,.4044300E+03,.2830500E+03,.3500000E+02,& - & .2456300E+02,.2959000E+03,.4044200E+03,.2830400E+03,.3500000E+02,& - & .2456300E+02,.2969200E+03,.4044300E+03,.2830500E+03,.3500000E+02,& - & .2456200E+02,.2967700E+03,.4044200E+03,.2830400E+03,.3500000E+02,& - & .2456100E+02,.2965500E+03,.4044000E+03,.2830100E+03,.3500000E+02,& - & .2456000E+02,.2962600E+03,.4044000E+03,.2830200E+03,.3500000E+02,& - & .2455900E+02,.2958900E+03,.4043900E+03,.2830100E+03,.3500000E+02,& - & .2456000E+02,.2969300E+03,.4043900E+03,.2830100E+03,.3500000E+02,& - & .2455900E+02,.2967900E+03,.4043800E+03,.2829900E+03,.3500000E+02,& - & .2455800E+02,.2965800E+03,.4043700E+03,.2829900E+03,.3500000E+02,& - & .2455700E+02,.2963000E+03,.4043700E+03,.2829700E+03,.3500000E+02,& - & .2455600E+02,.2959400E+03,.4043600E+03,.2829700E+03,.3500000E+02,& - & .2455700E+02,.2969500E+03,.4043600E+03,.2829700E+03,.3500000E+02,& - & .2455600E+02,.2968100E+03,.4043600E+03,.2829600E+03,.3500000E+02,& - & .2455500E+02,.2966100E+03,.4043500E+03,.2829700E+03,.3500000E+02,& - & .2455400E+02,.2963400E+03,.4043400E+03,.2829600E+03,.3500000E+02,& - & .2455400E+02,.2959900E+03,.4043400E+03,.2829400E+03,.3500000E+02,& - & .2455400E+02,.2969600E+03,.4043400E+03,.2829500E+03,.3500000E+02,& - & .2455300E+02,.2968300E+03,.4043300E+03,.2829400E+03,.3500000E+02,& - & .2455300E+02,.2966400E+03,.4043300E+03,.2829300E+03,.3500000E+02,& - & .2455200E+02,.2963800E+03,.4043200E+03,.2829200E+03,.3500000E+02,& - & .2455200E+02,.2960400E+03,.4043200E+03,.2829200E+03,.3500000E+02,& - & .2455200E+02,.2969800E+03,.4043200E+03,.2829200E+03,.3500000E+02,& - & .2455100E+02,.2968700E+03,.4043200E+03,.2829300E+03,.3500000E+02,& - & .2455100E+02,.2966900E+03,.4043100E+03,.2829200E+03,.3500000E+02,& - & .2455000E+02,.2964500E+03,.4043100E+03,.2829100E+03,.3500000E+02,& - & .2455000E+02,.2961300E+03,.4043000E+03,.2829100E+03,.3500000E+02/ - - data absb(701:875, 1) / & - & .2455000E+02,.2969900E+03,.4043100E+03,.2829000E+03,.3500000E+02,& - & .2455000E+02,.2969000E+03,.4043000E+03,.2829100E+03,.3500000E+02,& - & .2454900E+02,.2967400E+03,.4043000E+03,.2828900E+03,.3500000E+02,& - & .2454900E+02,.2965100E+03,.4042900E+03,.2829000E+03,.3500000E+02,& - & .2454900E+02,.2962200E+03,.4042900E+03,.2828900E+03,.3500000E+02,& - & .2454900E+02,.2970000E+03,.4042900E+03,.2828900E+03,.3500000E+02,& - & .2454900E+02,.2969300E+03,.4042900E+03,.2828900E+03,.3500000E+02,& - & .2454800E+02,.2967900E+03,.4042900E+03,.2828900E+03,.3500000E+02,& - & .2454800E+02,.2965800E+03,.4042800E+03,.2828900E+03,.3500000E+02,& - & .2454700E+02,.2963000E+03,.4042800E+03,.2828800E+03,.3500000E+02,& - & .2454800E+02,.2970100E+03,.4042800E+03,.2828800E+03,.3500000E+02,& - & .2454700E+02,.2969600E+03,.4042800E+03,.2828800E+03,.3500000E+02,& - & .2454700E+02,.2968400E+03,.4042800E+03,.2828800E+03,.3500000E+02,& - & .2454700E+02,.2966500E+03,.4042700E+03,.2828800E+03,.3500000E+02,& - & .2454700E+02,.2963900E+03,.4042700E+03,.2828800E+03,.3500000E+02,& - & .2454700E+02,.2970200E+03,.4042700E+03,.2828700E+03,.3500000E+02,& - & .2454700E+02,.2969800E+03,.4042700E+03,.2828700E+03,.3500000E+02,& - & .2454600E+02,.2968800E+03,.4042700E+03,.2828700E+03,.3500000E+02,& - & .2454600E+02,.2967200E+03,.4042700E+03,.2828700E+03,.3500000E+02,& - & .2454600E+02,.2964900E+03,.4042600E+03,.2828600E+03,.3500000E+02,& - & .2454600E+02,.2970100E+03,.4042700E+03,.2828700E+03,.3500000E+02,& - & .2454600E+02,.2970000E+03,.4042600E+03,.2828700E+03,.3500000E+02,& - & .2454600E+02,.2969200E+03,.4042600E+03,.2828600E+03,.3500000E+02,& - & .2454500E+02,.2967800E+03,.4042600E+03,.2828600E+03,.3500000E+02,& - & .2454500E+02,.2965700E+03,.4042600E+03,.2828600E+03,.3500000E+02,& - & .2454500E+02,.2969900E+03,.4042600E+03,.2828700E+03,.3500000E+02,& - & .2454500E+02,.2970100E+03,.4042600E+03,.2828500E+03,.3500000E+02,& - & .2454500E+02,.2969600E+03,.4042600E+03,.2828600E+03,.3500000E+02,& - & .2454500E+02,.2968400E+03,.4042500E+03,.2828500E+03,.3500000E+02,& - & .2454500E+02,.2966500E+03,.4042500E+03,.2828500E+03,.3500000E+02,& - & .2454500E+02,.2969600E+03,.4042500E+03,.2828500E+03,.3500000E+02,& - & .2454500E+02,.2970100E+03,.4042500E+03,.2828600E+03,.3500000E+02,& - & .2454400E+02,.2969900E+03,.4042500E+03,.2828500E+03,.3500000E+02,& - & .2454400E+02,.2969000E+03,.4042500E+03,.2828500E+03,.3500000E+02,& - & .2454400E+02,.2967400E+03,.4042500E+03,.2828600E+03,.3500000E+02/ - - data absb(876:1050, 1) / & - & .2454400E+02,.2969100E+03,.4042500E+03,.2828600E+03,.3500000E+02,& - & .2454400E+02,.2970000E+03,.4042500E+03,.2828500E+03,.3500000E+02,& - & .2454400E+02,.2970100E+03,.4042500E+03,.2828400E+03,.3500000E+02,& - & .2454400E+02,.2969400E+03,.4042500E+03,.2828500E+03,.3500000E+02,& - & .2454400E+02,.2968100E+03,.4042500E+03,.2828400E+03,.3500000E+02,& - & .2454400E+02,.2968500E+03,.4042500E+03,.2828400E+03,.3500000E+02,& - & .2454400E+02,.2969800E+03,.4042500E+03,.2828400E+03,.3500000E+02,& - & .2454400E+02,.2970100E+03,.4042400E+03,.2828400E+03,.3500000E+02,& - & .2454400E+02,.2969700E+03,.4042400E+03,.2828500E+03,.3500000E+02,& - & .2454400E+02,.2968700E+03,.4042400E+03,.2828400E+03,.3500000E+02,& - & .2454400E+02,.2967800E+03,.4042400E+03,.2828400E+03,.3500000E+02,& - & .2454400E+02,.2969400E+03,.4042400E+03,.2828400E+03,.3500000E+02,& - & .2454300E+02,.2970100E+03,.4042400E+03,.2828400E+03,.3500000E+02,& - & .2454300E+02,.2970000E+03,.4042400E+03,.2828400E+03,.3500000E+02,& - & .2454300E+02,.2969200E+03,.4042400E+03,.2828400E+03,.3500000E+02,& - & .2454300E+02,.2967000E+03,.4042400E+03,.2828400E+03,.3500000E+02,& - & .2454300E+02,.2968900E+03,.4042400E+03,.2828400E+03,.3500000E+02,& - & .2454300E+02,.2969900E+03,.4042400E+03,.2828400E+03,.3500000E+02,& - & .2454300E+02,.2970100E+03,.4042400E+03,.2828400E+03,.3500000E+02,& - & .2454300E+02,.2969500E+03,.4042400E+03,.2828400E+03,.3500000E+02,& - & .2454300E+02,.2966000E+03,.4042400E+03,.2828300E+03,.3500000E+02,& - & .2454300E+02,.2968400E+03,.4042400E+03,.2828300E+03,.3500000E+02,& - & .2454300E+02,.2969700E+03,.4042400E+03,.2828300E+03,.3500000E+02,& - & .2454300E+02,.2970100E+03,.4042400E+03,.2828300E+03,.3500000E+02,& - & .2454300E+02,.2969800E+03,.4042400E+03,.2828300E+03,.3500000E+02,& - & .2454300E+02,.2964800E+03,.4042400E+03,.2828300E+03,.3500000E+02,& - & .2454300E+02,.2967600E+03,.4042400E+03,.2828300E+03,.3500000E+02,& - & .2454300E+02,.2969300E+03,.4042400E+03,.2828400E+03,.3500000E+02,& - & .2454300E+02,.2970100E+03,.4042400E+03,.2828300E+03,.3500000E+02,& - & .2454300E+02,.2970000E+03,.4042400E+03,.2828400E+03,.3500000E+02,& - & .2454300E+02,.2963500E+03,.4042400E+03,.2828300E+03,.3500000E+02,& - & .2454300E+02,.2966800E+03,.4042400E+03,.2828400E+03,.3500000E+02,& - & .2454300E+02,.2968800E+03,.4042400E+03,.2828300E+03,.3500000E+02,& - & .2454300E+02,.2969900E+03,.4042300E+03,.2828300E+03,.3500000E+02,& - & .2454300E+02,.2970100E+03,.4042300E+03,.2828500E+03,.3500000E+02/ - - data absb(1051:1175, 1) / & - & .2454300E+02,.2962200E+03,.4042400E+03,.2828500E+03,.3500000E+02,& - & .2454300E+02,.2965900E+03,.4042300E+03,.2828300E+03,.3500000E+02,& - & .2454300E+02,.2968300E+03,.4042300E+03,.2828400E+03,.3500000E+02,& - & .2454300E+02,.2969600E+03,.4042300E+03,.2828300E+03,.3500000E+02,& - & .2454300E+02,.2970100E+03,.4042300E+03,.2828300E+03,.3500000E+02,& - & .2454300E+02,.2960700E+03,.4042300E+03,.2828300E+03,.3500000E+02,& - & .2454300E+02,.2964900E+03,.4042300E+03,.2828300E+03,.3500000E+02,& - & .2454300E+02,.2967600E+03,.4042300E+03,.2828300E+03,.3500000E+02,& - & .2454200E+02,.2969300E+03,.4042300E+03,.2828200E+03,.3500000E+02,& - & .2454200E+02,.2970000E+03,.4042300E+03,.2828300E+03,.3500000E+02,& - & .2454300E+02,.2959100E+03,.4042300E+03,.2828300E+03,.3500000E+02,& - & .2454200E+02,.2963700E+03,.4042300E+03,.2828300E+03,.3500000E+02,& - & .2454200E+02,.2966900E+03,.4042300E+03,.2828300E+03,.3500000E+02,& - & .2454200E+02,.2968900E+03,.4042300E+03,.2828300E+03,.3500000E+02,& - & .2454200E+02,.2969900E+03,.4042300E+03,.2828300E+03,.3500000E+02,& - & .2454200E+02,.2957400E+03,.4042300E+03,.2828200E+03,.3500000E+02,& - & .2454200E+02,.2962400E+03,.4042300E+03,.2828200E+03,.3500000E+02,& - & .2454200E+02,.2966000E+03,.4042300E+03,.2828300E+03,.3500000E+02,& - & .2454200E+02,.2968400E+03,.4042300E+03,.2828400E+03,.3500000E+02,& - & .2454200E+02,.2969700E+03,.4042300E+03,.2828200E+03,.3500000E+02,& - & .2454200E+02,.2956600E+03,.4042300E+03,.2828300E+03,.3500000E+02,& - & .2454200E+02,.2961900E+03,.4042300E+03,.2828200E+03,.3500000E+02,& - & .2454200E+02,.2965700E+03,.4042300E+03,.2828300E+03,.3500000E+02,& - & .2454200E+02,.2968200E+03,.4042300E+03,.2828300E+03,.3500000E+02,& - & .2454200E+02,.2969600E+03,.4042300E+03,.2828300E+03,.3500000E+02/ - - data absb( 1:175, 2) / & - & .1017700E+03,.3276100E+03,.4557500E+03,.3133500E+03,.7183900E+02,& - & .1009900E+03,.3271300E+03,.4538300E+03,.3112500E+03,.7183900E+02,& - & .1003100E+03,.3266300E+03,.4521600E+03,.3094300E+03,.7183900E+02,& - & .9972100E+02,.3261200E+03,.4507100E+03,.3078500E+03,.7183900E+02,& - & .9920400E+02,.3255800E+03,.4494200E+03,.3064600E+03,.7183900E+02,& - & .9980300E+02,.3261300E+03,.4509100E+03,.3080700E+03,.7183900E+02,& - & .9916900E+02,.3257400E+03,.4493400E+03,.3063600E+03,.7183900E+02,& - & .9862200E+02,.3253400E+03,.4479700E+03,.3048900E+03,.7183900E+02,& - & .9814600E+02,.3249100E+03,.4467700E+03,.3036200E+03,.7183900E+02,& - & .9772800E+02,.3244400E+03,.4457100E+03,.3024800E+03,.7183900E+02,& - & .9819800E+02,.3249300E+03,.4469000E+03,.3037500E+03,.7183900E+02,& - & .9768700E+02,.3246200E+03,.4456000E+03,.3023700E+03,.7183900E+02,& - & .9724500E+02,.3242900E+03,.4444800E+03,.3011900E+03,.7183900E+02,& - & .9686100E+02,.3239200E+03,.4435000E+03,.3001400E+03,.7183900E+02,& - & .9652300E+02,.3235000E+03,.4426300E+03,.2992300E+03,.7183900E+02,& - & .9689200E+02,.3239500E+03,.4435800E+03,.3002300E+03,.7183900E+02,& - & .9648000E+02,.3237100E+03,.4425200E+03,.2991200E+03,.7183900E+02,& - & .9612500E+02,.3234300E+03,.4416100E+03,.2981700E+03,.7183900E+02,& - & .9581400E+02,.3231100E+03,.4408100E+03,.2973300E+03,.7183900E+02,& - & .9554100E+02,.3227300E+03,.4401000E+03,.2966100E+03,.7183900E+02,& - & .9583300E+02,.3231600E+03,.4408600E+03,.2973700E+03,.7183900E+02,& - & .9550100E+02,.3229700E+03,.4400000E+03,.2964800E+03,.7183900E+02,& - & .9521400E+02,.3227400E+03,.4392500E+03,.2956900E+03,.7183900E+02,& - & .9496400E+02,.3224500E+03,.4386000E+03,.2950200E+03,.7183900E+02,& - & .9474300E+02,.3221000E+03,.4380300E+03,.2944200E+03,.7183900E+02,& - & .9497400E+02,.3225100E+03,.4386300E+03,.2950400E+03,.7183900E+02,& - & .9470700E+02,.3223600E+03,.4379300E+03,.2943200E+03,.7183900E+02,& - & .9447500E+02,.3221700E+03,.4373300E+03,.2936900E+03,.7183900E+02,& - & .9427200E+02,.3219100E+03,.4368000E+03,.2931500E+03,.7183900E+02,& - & .9409400E+02,.3215800E+03,.4363300E+03,.2926700E+03,.7183900E+02,& - & .9427700E+02,.3219900E+03,.4368100E+03,.2931600E+03,.7183900E+02,& - & .9406100E+02,.3218700E+03,.4362400E+03,.2925800E+03,.7183900E+02,& - & .9387400E+02,.3217000E+03,.4357500E+03,.2920700E+03,.7183900E+02,& - & .9371100E+02,.3214600E+03,.4353200E+03,.2916400E+03,.7183900E+02,& - & .9356600E+02,.3211500E+03,.4349400E+03,.2912500E+03,.7183900E+02/ - - data absb(176:350, 2) / & - & .9370800E+02,.3215700E+03,.4353100E+03,.2916300E+03,.7183900E+02,& - & .9353400E+02,.3214700E+03,.4348500E+03,.2911700E+03,.7183900E+02,& - & .9338300E+02,.3213200E+03,.4344500E+03,.2907600E+03,.7183900E+02,& - & .9325100E+02,.3210900E+03,.4341100E+03,.2904100E+03,.7183900E+02,& - & .9313500E+02,.3207900E+03,.4338000E+03,.2901000E+03,.7183900E+02,& - & .9324600E+02,.3212200E+03,.4340900E+03,.2904000E+03,.7183900E+02,& - & .9310600E+02,.3211400E+03,.4337200E+03,.2900300E+03,.7183900E+02,& - & .9298500E+02,.3210000E+03,.4334000E+03,.2897000E+03,.7183900E+02,& - & .9287800E+02,.3207900E+03,.4331100E+03,.2894100E+03,.7183900E+02,& - & .9278400E+02,.3204900E+03,.4328600E+03,.2891700E+03,.7183900E+02,& - & .9286300E+02,.3209400E+03,.4330700E+03,.2893800E+03,.7183900E+02,& - & .9275100E+02,.3208700E+03,.4327800E+03,.2890800E+03,.7183900E+02,& - & .9265500E+02,.3207300E+03,.4325200E+03,.2888200E+03,.7183900E+02,& - & .9256900E+02,.3205100E+03,.4322900E+03,.2886000E+03,.7183900E+02,& - & .9249400E+02,.3202200E+03,.4320900E+03,.2884000E+03,.7183900E+02,& - & .9255300E+02,.3207200E+03,.4322500E+03,.2885500E+03,.7183900E+02,& - & .9246500E+02,.3206400E+03,.4320100E+03,.2883200E+03,.7183900E+02,& - & .9238700E+02,.3205000E+03,.4318000E+03,.2881100E+03,.7183900E+02,& - & .9231900E+02,.3202900E+03,.4316200E+03,.2879300E+03,.7183900E+02,& - & .9225900E+02,.3199800E+03,.4314600E+03,.2877800E+03,.7183900E+02,& - & .9230300E+02,.3205300E+03,.4315800E+03,.2878900E+03,.7183900E+02,& - & .9223300E+02,.3204600E+03,.4313900E+03,.2877000E+03,.7183900E+02,& - & .9217100E+02,.3203100E+03,.4312200E+03,.2875400E+03,.7183900E+02,& - & .9211700E+02,.3200900E+03,.4310800E+03,.2874000E+03,.7183900E+02,& - & .9206800E+02,.3197800E+03,.4309500E+03,.2872700E+03,.7183900E+02,& - & .9210100E+02,.3203800E+03,.4310300E+03,.2873600E+03,.7183900E+02,& - & .9204500E+02,.3203000E+03,.4308800E+03,.2872100E+03,.7183900E+02,& - & .9199600E+02,.3201500E+03,.4307500E+03,.2870800E+03,.7183900E+02,& - & .9195200E+02,.3199100E+03,.4306400E+03,.2869600E+03,.7183900E+02,& - & .9191400E+02,.3195900E+03,.4305300E+03,.2868400E+03,.7183900E+02,& - & .9193700E+02,.3202500E+03,.4305900E+03,.2869300E+03,.7183900E+02,& - & .9189200E+02,.3201600E+03,.4304700E+03,.2868000E+03,.7183900E+02,& - & .9185300E+02,.3200000E+03,.4303700E+03,.2867000E+03,.7183900E+02,& - & .9181900E+02,.3197500E+03,.4302800E+03,.2866100E+03,.7183900E+02,& - & .9178800E+02,.3194200E+03,.4301900E+03,.2865300E+03,.7183900E+02/ - - data absb(351:525, 2) / & - & .9180500E+02,.3201500E+03,.4302400E+03,.2865800E+03,.7183900E+02,& - & .9177000E+02,.3200500E+03,.4301400E+03,.2864800E+03,.7183900E+02,& - & .9173800E+02,.3198600E+03,.4300600E+03,.2863000E+03,.7183900E+02,& - & .9171100E+02,.3196000E+03,.4299800E+03,.2863300E+03,.7183900E+02,& - & .9168700E+02,.3192500E+03,.4299200E+03,.2862600E+03,.7183900E+02,& - & .9169800E+02,.3200500E+03,.4299500E+03,.2862800E+03,.7183900E+02,& - & .9167000E+02,.3199400E+03,.4298700E+03,.2862200E+03,.7183900E+02,& - & .9164600E+02,.3197400E+03,.4298100E+03,.2861500E+03,.7183900E+02,& - & .9162400E+02,.3194600E+03,.4297500E+03,.2860900E+03,.7183900E+02,& - & .9160400E+02,.3191000E+03,.4297000E+03,.2860500E+03,.7183900E+02,& - & .9161300E+02,.3199700E+03,.4297200E+03,.2860500E+03,.7183900E+02,& - & .9159100E+02,.3198400E+03,.4296600E+03,.2860000E+03,.7183900E+02,& - & .9157100E+02,.3196300E+03,.4296000E+03,.2859500E+03,.7183900E+02,& - & .9155400E+02,.3193300E+03,.4295600E+03,.2859000E+03,.7183900E+02,& - & .9153800E+02,.3189500E+03,.4295200E+03,.2858600E+03,.7183900E+02,& - & .9154400E+02,.3199000E+03,.4295300E+03,.2858900E+03,.7183900E+02,& - & .9152600E+02,.3197500E+03,.4294800E+03,.2858400E+03,.7183900E+02,& - & .9151100E+02,.3195200E+03,.4294400E+03,.2858000E+03,.7183900E+02,& - & .9149700E+02,.3192000E+03,.4294000E+03,.2857700E+03,.7183900E+02,& - & .9148400E+02,.3188000E+03,.4293700E+03,.2857300E+03,.7183900E+02,& - & .9148800E+02,.3198300E+03,.4293800E+03,.2857400E+03,.7183900E+02,& - & .9147400E+02,.3196600E+03,.4293400E+03,.2857100E+03,.7183900E+02,& - & .9146200E+02,.3194100E+03,.4293100E+03,.2856700E+03,.7183900E+02,& - & .9145100E+02,.3190800E+03,.4292800E+03,.2856400E+03,.7183900E+02,& - & .9144100E+02,.3186600E+03,.4292500E+03,.2856200E+03,.7183900E+02,& - & .9144300E+02,.3197600E+03,.4292600E+03,.2856200E+03,.7183900E+02,& - & .9143200E+02,.3195800E+03,.4292300E+03,.2855900E+03,.7183900E+02,& - & .9142300E+02,.3193000E+03,.4292000E+03,.2855700E+03,.7183900E+02,& - & .9141400E+02,.3189500E+03,.4291800E+03,.2855500E+03,.7183900E+02,& - & .9140600E+02,.3185100E+03,.4291600E+03,.2855100E+03,.7183900E+02,& - & .9140700E+02,.3197000E+03,.4291600E+03,.2855300E+03,.7183900E+02,& - & .9139900E+02,.3194900E+03,.4291400E+03,.2855100E+03,.7183900E+02,& - & .9139100E+02,.3192000E+03,.4291200E+03,.2854900E+03,.7183900E+02,& - & .9138400E+02,.3188200E+03,.4291000E+03,.2854700E+03,.7183900E+02,& - & .9137800E+02,.3183700E+03,.4290800E+03,.2854600E+03,.7183900E+02/ - - data absb(526:700, 2) / & - & .9137900E+02,.3196400E+03,.4290800E+03,.2854600E+03,.7183900E+02,& - & .9137200E+02,.3194100E+03,.4290600E+03,.2854400E+03,.7183900E+02,& - & .9136500E+02,.3191000E+03,.4290500E+03,.2854200E+03,.7183900E+02,& - & .9136000E+02,.3187100E+03,.4290300E+03,.2854100E+03,.7183900E+02,& - & .9135500E+02,.3182400E+03,.4290200E+03,.2854000E+03,.7183900E+02,& - & .9135600E+02,.3196000E+03,.4290200E+03,.2853900E+03,.7183900E+02,& - & .9135000E+02,.3193600E+03,.4290100E+03,.2853800E+03,.7183900E+02,& - & .9134500E+02,.3190400E+03,.4289900E+03,.2853700E+03,.7183900E+02,& - & .9134100E+02,.3186300E+03,.4289800E+03,.2853500E+03,.7183900E+02,& - & .9133700E+02,.3181600E+03,.4289700E+03,.2853500E+03,.7183900E+02,& - & .9133800E+02,.3195800E+03,.4289700E+03,.2853500E+03,.7183900E+02,& - & .9133400E+02,.3193400E+03,.4289600E+03,.2853300E+03,.7183900E+02,& - & .9133000E+02,.3190200E+03,.4289500E+03,.2853300E+03,.7183900E+02,& - & .9132600E+02,.3186200E+03,.4289400E+03,.2853000E+03,.7183900E+02,& - & .9132300E+02,.3181400E+03,.4289300E+03,.2853000E+03,.7183900E+02,& - & .9132400E+02,.3195900E+03,.4289400E+03,.2853100E+03,.7183900E+02,& - & .9132000E+02,.3193700E+03,.4289300E+03,.2853000E+03,.7183900E+02,& - & .9131700E+02,.3190600E+03,.4289200E+03,.2852900E+03,.7183900E+02,& - & .9131400E+02,.3186600E+03,.4289100E+03,.2852900E+03,.7183900E+02,& - & .9131100E+02,.3181900E+03,.4289000E+03,.2852700E+03,.7183900E+02,& - & .9131300E+02,.3196100E+03,.4289000E+03,.2852800E+03,.7183900E+02,& - & .9131000E+02,.3193900E+03,.4289000E+03,.2852800E+03,.7183900E+02,& - & .9130700E+02,.3191000E+03,.4288900E+03,.2852600E+03,.7183900E+02,& - & .9130400E+02,.3187100E+03,.4288800E+03,.2852500E+03,.7183900E+02,& - & .9130200E+02,.3182600E+03,.4288800E+03,.2852500E+03,.7183900E+02,& - & .9130300E+02,.3196200E+03,.4288800E+03,.2852500E+03,.7183900E+02,& - & .9130100E+02,.3194200E+03,.4288700E+03,.2852500E+03,.7183900E+02,& - & .9129800E+02,.3191400E+03,.4288600E+03,.2852500E+03,.7183900E+02,& - & .9129600E+02,.3187700E+03,.4288600E+03,.2852400E+03,.7183900E+02,& - & .9129400E+02,.3183200E+03,.4288500E+03,.2852300E+03,.7183900E+02,& - & .9129600E+02,.3196500E+03,.4288600E+03,.2852400E+03,.7183900E+02,& - & .9129300E+02,.3194700E+03,.4288500E+03,.2852200E+03,.7183900E+02,& - & .9129200E+02,.3192100E+03,.4288500E+03,.2852200E+03,.7183900E+02,& - & .9129000E+02,.3188600E+03,.4288400E+03,.2852200E+03,.7183900E+02,& - & .9128800E+02,.3184300E+03,.4288400E+03,.2852100E+03,.7183900E+02/ - - data absb(701:875, 2) / & - & .9128900E+02,.3196800E+03,.4288400E+03,.2852300E+03,.7183900E+02,& - & .9128800E+02,.3195200E+03,.4288400E+03,.2852100E+03,.7183900E+02,& - & .9128600E+02,.3192800E+03,.4288300E+03,.2852200E+03,.7183900E+02,& - & .9128400E+02,.3189500E+03,.4288300E+03,.2852100E+03,.7183900E+02,& - & .9128300E+02,.3185400E+03,.4288200E+03,.2852100E+03,.7183900E+02,& - & .9128400E+02,.3197000E+03,.4288300E+03,.2852100E+03,.7183900E+02,& - & .9128300E+02,.3195700E+03,.4288200E+03,.2852100E+03,.7183900E+02,& - & .9128100E+02,.3193400E+03,.4288200E+03,.2852000E+03,.7183900E+02,& - & .9128000E+02,.3190400E+03,.4288200E+03,.2851900E+03,.7183900E+02,& - & .9127900E+02,.3186500E+03,.4288100E+03,.2852000E+03,.7183900E+02,& - & .9128000E+02,.3197200E+03,.4288200E+03,.2852000E+03,.7183900E+02,& - & .9127900E+02,.3196100E+03,.4288100E+03,.2852000E+03,.7183900E+02,& - & .9127700E+02,.3194200E+03,.4288100E+03,.2851900E+03,.7183900E+02,& - & .9127600E+02,.3191400E+03,.4288100E+03,.2851800E+03,.7183900E+02,& - & .9127500E+02,.3187800E+03,.4288000E+03,.2851800E+03,.7183900E+02,& - & .9127600E+02,.3197400E+03,.4288100E+03,.2851900E+03,.7183900E+02,& - & .9127500E+02,.3196600E+03,.4288000E+03,.2851900E+03,.7183900E+02,& - & .9127400E+02,.3194900E+03,.4288000E+03,.2851800E+03,.7183900E+02,& - & .9127300E+02,.3192400E+03,.4288000E+03,.2851800E+03,.7183900E+02,& - & .9127300E+02,.3189000E+03,.4288000E+03,.2851800E+03,.7183900E+02,& - & .9127400E+02,.3197400E+03,.4288000E+03,.2851800E+03,.7183900E+02,& - & .9127300E+02,.3196900E+03,.4288000E+03,.2851700E+03,.7183900E+02,& - & .9127200E+02,.3195500E+03,.4287900E+03,.2851800E+03,.7183900E+02,& - & .9127100E+02,.3193300E+03,.4287900E+03,.2851700E+03,.7183900E+02,& - & .9127000E+02,.3190300E+03,.4287900E+03,.2851700E+03,.7183900E+02,& - & .9127100E+02,.3197400E+03,.4287900E+03,.2851600E+03,.7183900E+02,& - & .9127000E+02,.3197200E+03,.4287900E+03,.2851700E+03,.7183900E+02,& - & .9127000E+02,.3196100E+03,.4287900E+03,.2851700E+03,.7183900E+02,& - & .9126900E+02,.3194200E+03,.4287900E+03,.2851700E+03,.7183900E+02,& - & .9126800E+02,.3191400E+03,.4287800E+03,.2851600E+03,.7183900E+02,& - & .9126900E+02,.3197300E+03,.4287900E+03,.2851700E+03,.7183900E+02,& - & .9126800E+02,.3197400E+03,.4287800E+03,.2851600E+03,.7183900E+02,& - & .9126800E+02,.3196600E+03,.4287800E+03,.2851600E+03,.7183900E+02,& - & .9126700E+02,.3195100E+03,.4287800E+03,.2851600E+03,.7183900E+02,& - & .9126700E+02,.3192600E+03,.4287800E+03,.2851500E+03,.7183900E+02/ - - data absb(876:1050, 2) / & - & .9126700E+02,.3197000E+03,.4287800E+03,.2851600E+03,.7183900E+02,& - & .9126700E+02,.3197400E+03,.4287800E+03,.2851600E+03,.7183900E+02,& - & .9126600E+02,.3197000E+03,.4287800E+03,.2851700E+03,.7183900E+02,& - & .9126600E+02,.3195800E+03,.4287800E+03,.2851500E+03,.7183900E+02,& - & .9126500E+02,.3193700E+03,.4287800E+03,.2851600E+03,.7183900E+02,& - & .9126600E+02,.3196600E+03,.4287800E+03,.2851600E+03,.7183900E+02,& - & .9126500E+02,.3197300E+03,.4287800E+03,.2851600E+03,.7183900E+02,& - & .9126500E+02,.3197300E+03,.4287700E+03,.2851600E+03,.7183900E+02,& - & .9126500E+02,.3196400E+03,.4287800E+03,.2851500E+03,.7183900E+02,& - & .9126400E+02,.3194600E+03,.4287700E+03,.2851500E+03,.7183900E+02,& - & .9126500E+02,.3196200E+03,.4287700E+03,.2851600E+03,.7183900E+02,& - & .9126400E+02,.3197200E+03,.4287700E+03,.2851500E+03,.7183900E+02,& - & .9126400E+02,.3197400E+03,.4287700E+03,.2851500E+03,.7183900E+02,& - & .9126400E+02,.3196800E+03,.4287700E+03,.2851500E+03,.7183900E+02,& - & .9126300E+02,.3195400E+03,.4287700E+03,.2851500E+03,.7183900E+02,& - & .9126400E+02,.3195800E+03,.4287700E+03,.2851500E+03,.7183900E+02,& - & .9126300E+02,.3196900E+03,.4287700E+03,.2851500E+03,.7183900E+02,& - & .9126300E+02,.3197400E+03,.4287700E+03,.2851500E+03,.7183900E+02,& - & .9126300E+02,.3197100E+03,.4287700E+03,.2851500E+03,.7183900E+02,& - & .9126200E+02,.3196000E+03,.4287700E+03,.2851500E+03,.7183900E+02,& - & .9126300E+02,.3195300E+03,.4287700E+03,.2851500E+03,.7183900E+02,& - & .9126300E+02,.3196500E+03,.4287700E+03,.2851500E+03,.7183900E+02,& - & .9126200E+02,.3197300E+03,.4287700E+03,.2851500E+03,.7183900E+02,& - & .9126200E+02,.3197300E+03,.4287700E+03,.2851500E+03,.7183900E+02,& - & .9126200E+02,.3196500E+03,.4287700E+03,.2851500E+03,.7183900E+02,& - & .9126200E+02,.3194800E+03,.4287700E+03,.2851500E+03,.7183900E+02,& - & .9126200E+02,.3196100E+03,.4287700E+03,.2851500E+03,.7183900E+02,& - & .9126200E+02,.3197100E+03,.4287700E+03,.2851500E+03,.7183900E+02,& - & .9126100E+02,.3197400E+03,.4287600E+03,.2851500E+03,.7183900E+02,& - & .9126100E+02,.3196900E+03,.4287600E+03,.2851400E+03,.7183900E+02,& - & .9126200E+02,.3194200E+03,.4287700E+03,.2851500E+03,.7183900E+02,& - & .9126100E+02,.3195700E+03,.4287700E+03,.2851400E+03,.7183900E+02,& - & .9126100E+02,.3196800E+03,.4287600E+03,.2851500E+03,.7183900E+02,& - & .9126100E+02,.3197300E+03,.4287600E+03,.2851500E+03,.7183900E+02,& - & .9126100E+02,.3197100E+03,.4287600E+03,.2851300E+03,.7183900E+02/ - - data absb(1051:1175, 2) / & - & .9126100E+02,.3193700E+03,.4287600E+03,.2851300E+03,.7183900E+02,& - & .9126100E+02,.3195300E+03,.4287600E+03,.2851500E+03,.7183900E+02,& - & .9126100E+02,.3196500E+03,.4287600E+03,.2851300E+03,.7183900E+02,& - & .9126100E+02,.3197300E+03,.4287600E+03,.2851400E+03,.7183900E+02,& - & .9126000E+02,.3197300E+03,.4287600E+03,.2851500E+03,.7183900E+02,& - & .9126100E+02,.3193200E+03,.4287600E+03,.2851400E+03,.7183900E+02,& - & .9126000E+02,.3194700E+03,.4287600E+03,.2851500E+03,.7183900E+02,& - & .9126000E+02,.3196100E+03,.4287600E+03,.2851500E+03,.7183900E+02,& - & .9126000E+02,.3197100E+03,.4287600E+03,.2851500E+03,.7183900E+02,& - & .9126000E+02,.3197400E+03,.4287600E+03,.2851500E+03,.7183900E+02,& - & .9126000E+02,.3192700E+03,.4287600E+03,.2851400E+03,.7183900E+02,& - & .9126000E+02,.3194300E+03,.4287600E+03,.2851400E+03,.7183900E+02,& - & .9126000E+02,.3195700E+03,.4287600E+03,.2851500E+03,.7183900E+02,& - & .9126000E+02,.3196800E+03,.4287600E+03,.2851400E+03,.7183900E+02,& - & .9126000E+02,.3197400E+03,.4287600E+03,.2851400E+03,.7183900E+02,& - & .9126000E+02,.3192200E+03,.4287600E+03,.2851500E+03,.7183900E+02,& - & .9126000E+02,.3193800E+03,.4287600E+03,.2851500E+03,.7183900E+02,& - & .9126000E+02,.3195300E+03,.4287600E+03,.2851400E+03,.7183900E+02,& - & .9126000E+02,.3196500E+03,.4287600E+03,.2851300E+03,.7183900E+02,& - & .9126000E+02,.3197300E+03,.4287600E+03,.2851500E+03,.7183900E+02,& - & .9126000E+02,.3192000E+03,.4287600E+03,.2851400E+03,.7183900E+02,& - & .9126000E+02,.3193600E+03,.4287600E+03,.2851500E+03,.7183900E+02,& - & .9125900E+02,.3195200E+03,.4287600E+03,.2851500E+03,.7183900E+02,& - & .9125900E+02,.3196400E+03,.4287600E+03,.2851400E+03,.7183900E+02,& - & .9125900E+02,.3197200E+03,.4287600E+03,.2851400E+03,.7183900E+02/ - - data absb( 1:175, 3) / & - & .3836807E+03,.4141833E+03,.5172110E+03,.3640918E+03,.2774131E+03,& - & .3807168E+03,.4119655E+03,.5153720E+03,.3628289E+03,.2774131E+03,& - & .3781683E+03,.4100543E+03,.5137563E+03,.3617431E+03,.2774131E+03,& - & .3759505E+03,.4084000E+03,.5123154E+03,.3608140E+03,.2774131E+03,& - & .3739993E+03,.4069430E+03,.5110249E+03,.3599960E+03,.2774131E+03,& - & .3762615E+03,.4086321E+03,.5121752E+03,.3609451E+03,.2774131E+03,& - & .3738708E+03,.4068442E+03,.5106639E+03,.3599404E+03,.2774131E+03,& - & .3718062E+03,.4053084E+03,.5093378E+03,.3590820E+03,.2774131E+03,& - & .3700131E+03,.4039599E+03,.5081625E+03,.3583348E+03,.2774131E+03,& - & .3684325E+03,.4027847E+03,.5070887E+03,.3576839E+03,.2774131E+03,& - & .3702108E+03,.4041080E+03,.5079686E+03,.3584156E+03,.2774131E+03,& - & .3682844E+03,.4026711E+03,.5067285E+03,.3576132E+03,.2774131E+03,& - & .3666197E+03,.4014215E+03,.5056295E+03,.3569267E+03,.2774131E+03,& - & .3651676E+03,.4003400E+03,.5046264E+03,.3563362E+03,.2774131E+03,& - & .3638932E+03,.3993817E+03,.5037145E+03,.3558113E+03,.2774131E+03,& - & .3652861E+03,.4004288E+03,.5043985E+03,.3563818E+03,.2774131E+03,& - & .3637351E+03,.3992685E+03,.5033654E+03,.3557405E+03,.2774131E+03,& - & .3623914E+03,.3982658E+03,.5024332E+03,.3551856E+03,.2774131E+03,& - & .3612211E+03,.3973916E+03,.5015961E+03,.3547114E+03,.2774131E+03,& - & .3601936E+03,.3966211E+03,.5008297E+03,.3542768E+03,.2774131E+03,& - & .3612951E+03,.3974409E+03,.5013689E+03,.3547466E+03,.2774131E+03,& - & .3600403E+03,.3965075E+03,.5005214E+03,.3542320E+03,.2774131E+03,& - & .3589636E+03,.3957025E+03,.4997495E+03,.3537982E+03,.2774131E+03,& - & .3580154E+03,.3949965E+03,.4990576E+03,.3534148E+03,.2774131E+03,& - & .3571805E+03,.3943741E+03,.4984268E+03,.3530769E+03,.2774131E+03,& - & .3580546E+03,.3950209E+03,.4988311E+03,.3534300E+03,.2774131E+03,& - & .3570472E+03,.3942704E+03,.4981389E+03,.3530214E+03,.2774131E+03,& - & .3561678E+03,.3936184E+03,.4975118E+03,.3526631E+03,.2774131E+03,& - & .3554121E+03,.3930456E+03,.4969402E+03,.3523553E+03,.2774131E+03,& - & .3547353E+03,.3925469E+03,.4964247E+03,.3520830E+03,.2774131E+03,& - & .3554270E+03,.3930604E+03,.4967238E+03,.3523605E+03,.2774131E+03,& - & .3546120E+03,.3924480E+03,.4961563E+03,.3520326E+03,.2774131E+03,& - & .3539056E+03,.3919245E+03,.4956492E+03,.3517500E+03,.2774131E+03,& - & .3532932E+03,.3914654E+03,.4951929E+03,.3514977E+03,.2774131E+03,& - & .3527448E+03,.3910603E+03,.4947773E+03,.3512758E+03,.2774131E+03/ - - data absb(176:350, 3) / & - & .3532784E+03,.3914554E+03,.4949665E+03,.3514929E+03,.2774131E+03,& - & .3526264E+03,.3909667E+03,.4945186E+03,.3512254E+03,.2774131E+03,& - & .3520584E+03,.3905468E+03,.4941167E+03,.3509983E+03,.2774131E+03,& - & .3515593E+03,.3901714E+03,.4937504E+03,.3507916E+03,.2774131E+03,& - & .3511198E+03,.3898455E+03,.4934100E+03,.3506149E+03,.2774131E+03,& - & .3515397E+03,.3901565E+03,.4935235E+03,.3507864E+03,.2774131E+03,& - & .3510113E+03,.3897615E+03,.4931757E+03,.3505745E+03,.2774131E+03,& - & .3505518E+03,.3894209E+03,.4928538E+03,.3503830E+03,.2774131E+03,& - & .3501516E+03,.3891195E+03,.4925527E+03,.3502215E+03,.2774131E+03,& - & .3498009E+03,.3888529E+03,.4922746E+03,.3500751E+03,.2774131E+03,& - & .3500923E+03,.3890750E+03,.4923299E+03,.3501963E+03,.2774131E+03,& - & .3496725E+03,.3887640E+03,.4920480E+03,.3500247E+03,.2774131E+03,& - & .3493070E+03,.3884875E+03,.4917957E+03,.3498784E+03,.2774131E+03,& - & .3489908E+03,.3882505E+03,.4915549E+03,.3497473E+03,.2774131E+03,& - & .3487043E+03,.3880380E+03,.4913246E+03,.3496361E+03,.2774131E+03,& - & .3489268E+03,.3882061E+03,.4913510E+03,.3497221E+03,.2774131E+03,& - & .3485958E+03,.3879591E+03,.4911335E+03,.3495858E+03,.2774131E+03,& - & .3483044E+03,.3877418E+03,.4909320E+03,.3494698E+03,.2774131E+03,& - & .3480474E+03,.3875440E+03,.4907313E+03,.3493639E+03,.2774131E+03,& - & .3478153E+03,.3873763E+03,.4905513E+03,.3492731E+03,.2774131E+03,& - & .3479882E+03,.3874996E+03,.4905518E+03,.3493387E+03,.2774131E+03,& - & .3477164E+03,.3873023E+03,.4903795E+03,.3492327E+03,.2774131E+03,& - & .3474843E+03,.3871294E+03,.4902184E+03,.3491368E+03,.2774131E+03,& - & .3472817E+03,.3869713E+03,.4900628E+03,.3490560E+03,.2774131E+03,& - & .3470992E+03,.3868380E+03,.4899176E+03,.3489804E+03,.2774131E+03,& - & .3472225E+03,.3869268E+03,.4898977E+03,.3490308E+03,.2774131E+03,& - & .3470103E+03,.3867739E+03,.4897703E+03,.3489501E+03,.2774131E+03,& - & .3468274E+03,.3866354E+03,.4896391E+03,.3488745E+03,.2774131E+03,& - & .3466645E+03,.3865122E+03,.4895135E+03,.3488037E+03,.2774131E+03,& - & .3465212E+03,.3864033E+03,.4893984E+03,.3487433E+03,.2774131E+03,& - & .3466053E+03,.3864725E+03,.4893673E+03,.3487785E+03,.2774131E+03,& - & .3464372E+03,.3863441E+03,.4892706E+03,.3487130E+03,.2774131E+03,& - & .3462891E+03,.3862356E+03,.4891699E+03,.3486526E+03,.2774131E+03,& - & .3461606E+03,.3861367E+03,.4890743E+03,.3485970E+03,.2774131E+03,& - & .3460421E+03,.3860479E+03,.4889791E+03,.3485566E+03,.2774131E+03/ - - data absb(351:525, 3) / & - & .3461062E+03,.3860971E+03,.4889425E+03,.3485818E+03,.2774131E+03,& - & .3459729E+03,.3859934E+03,.4888662E+03,.3485263E+03,.2774131E+03,& - & .3458544E+03,.3859146E+03,.4887903E+03,.3484759E+03,.2774131E+03,& - & .3457556E+03,.3858305E+03,.4887099E+03,.3484355E+03,.2774131E+03,& - & .3456567E+03,.3857613E+03,.4886347E+03,.3484003E+03,.2774131E+03,& - & .3457063E+03,.3858009E+03,.4885977E+03,.3484155E+03,.2774131E+03,& - & .3455975E+03,.3857169E+03,.4885414E+03,.3483751E+03,.2774131E+03,& - & .3455086E+03,.3856528E+03,.4884806E+03,.3483347E+03,.2774131E+03,& - & .3454245E+03,.3855836E+03,.4884203E+03,.3483044E+03,.2774131E+03,& - & .3453505E+03,.3855291E+03,.4883603E+03,.3482740E+03,.2774131E+03,& - & .3453801E+03,.3855539E+03,.4883177E+03,.3482844E+03,.2774131E+03,& - & .3452961E+03,.3854947E+03,.4882766E+03,.3482540E+03,.2774131E+03,& - & .3452220E+03,.3854355E+03,.4882358E+03,.3482236E+03,.2774131E+03,& - & .3451580E+03,.3853910E+03,.4881858E+03,.3481984E+03,.2774131E+03,& - & .3450987E+03,.3853414E+03,.4881306E+03,.3481732E+03,.2774131E+03,& - & .3451183E+03,.3853614E+03,.4880977E+03,.3481784E+03,.2774131E+03,& - & .3450543E+03,.3853170E+03,.4880718E+03,.3481480E+03,.2774131E+03,& - & .3449999E+03,.3852674E+03,.4880362E+03,.3481328E+03,.2774131E+03,& - & .3449454E+03,.3852281E+03,.4879958E+03,.3481076E+03,.2774131E+03,& - & .3448962E+03,.3851933E+03,.4879510E+03,.3480925E+03,.2774131E+03,& - & .3449110E+03,.3852033E+03,.4879177E+03,.3480925E+03,.2774131E+03,& - & .3448566E+03,.3851637E+03,.4878970E+03,.3480725E+03,.2774131E+03,& - & .3448121E+03,.3851293E+03,.4878714E+03,.3480521E+03,.2774131E+03,& - & .3447725E+03,.3850996E+03,.4878362E+03,.3480369E+03,.2774131E+03,& - & .3447381E+03,.3850700E+03,.4878014E+03,.3480269E+03,.2774131E+03,& - & .3447429E+03,.3850800E+03,.4877729E+03,.3480269E+03,.2774131E+03,& - & .3446985E+03,.3850504E+03,.4877618E+03,.3480117E+03,.2774131E+03,& - & .3446640E+03,.3850156E+03,.4877414E+03,.3479917E+03,.2774131E+03,& - & .3446344E+03,.3849960E+03,.4877114E+03,.3479765E+03,.2774131E+03,& - & .3445996E+03,.3849712E+03,.4876818E+03,.3479665E+03,.2774131E+03,& - & .3446096E+03,.3849812E+03,.4876577E+03,.3479713E+03,.2774131E+03,& - & .3445752E+03,.3849515E+03,.4876518E+03,.3479613E+03,.2774131E+03,& - & .3445456E+03,.3849267E+03,.4876366E+03,.3479461E+03,.2774131E+03,& - & .3445208E+03,.3849119E+03,.4876118E+03,.3479361E+03,.2774131E+03,& - & .3444960E+03,.3848871E+03,.4875822E+03,.3479261E+03,.2774131E+03/ - - data absb(526:700, 3) / & - & .3444960E+03,.3848971E+03,.4875677E+03,.3479261E+03,.2774131E+03,& - & .3444763E+03,.3848775E+03,.4875670E+03,.3479209E+03,.2774131E+03,& - & .3444515E+03,.3848575E+03,.4875518E+03,.3479057E+03,.2774131E+03,& - & .3444319E+03,.3848427E+03,.4875270E+03,.3478957E+03,.2774131E+03,& - & .3444071E+03,.3848279E+03,.4874973E+03,.3478906E+03,.2774131E+03,& - & .3444171E+03,.3848331E+03,.4874977E+03,.3478957E+03,.2774131E+03,& - & .3443923E+03,.3848183E+03,.4874922E+03,.3478857E+03,.2774131E+03,& - & .3443775E+03,.3847983E+03,.4874818E+03,.3478757E+03,.2774131E+03,& - & .3443579E+03,.3847883E+03,.4874622E+03,.3478706E+03,.2774131E+03,& - & .3443430E+03,.3847734E+03,.4874377E+03,.3478606E+03,.2774131E+03,& - & .3443479E+03,.3847834E+03,.4874377E+03,.3478654E+03,.2774131E+03,& - & .3443330E+03,.3847686E+03,.4874373E+03,.3478554E+03,.2774131E+03,& - & .3443182E+03,.3847538E+03,.4874270E+03,.3478554E+03,.2774131E+03,& - & .3443034E+03,.3847438E+03,.4874122E+03,.3478454E+03,.2774131E+03,& - & .3442886E+03,.3847390E+03,.4873877E+03,.3478402E+03,.2774131E+03,& - & .3442934E+03,.3847442E+03,.4873881E+03,.3478454E+03,.2774131E+03,& - & .3442786E+03,.3847342E+03,.4873873E+03,.3478402E+03,.2774131E+03,& - & .3442638E+03,.3847242E+03,.4873870E+03,.3478302E+03,.2774131E+03,& - & .3442590E+03,.3847094E+03,.4873722E+03,.3478302E+03,.2774131E+03,& - & .3442442E+03,.3846994E+03,.4873477E+03,.3478250E+03,.2774131E+03,& - & .3442490E+03,.3847146E+03,.4873433E+03,.3478250E+03,.2774131E+03,& - & .3442390E+03,.3847046E+03,.4873525E+03,.3478202E+03,.2774131E+03,& - & .3442294E+03,.3846946E+03,.4873522E+03,.3478150E+03,.2774131E+03,& - & .3442194E+03,.3846846E+03,.4873422E+03,.3478150E+03,.2774131E+03,& - & .3442094E+03,.3846798E+03,.4873177E+03,.3478050E+03,.2774131E+03,& - & .3442146E+03,.3846850E+03,.4873085E+03,.3478150E+03,.2774131E+03,& - & .3442046E+03,.3846750E+03,.4873225E+03,.3478050E+03,.2774131E+03,& - & .3441946E+03,.3846698E+03,.4873222E+03,.3478050E+03,.2774131E+03,& - & .3441898E+03,.3846650E+03,.4873173E+03,.3477998E+03,.2774131E+03,& - & .3441798E+03,.3846550E+03,.4872977E+03,.3477998E+03,.2774131E+03,& - & .3441898E+03,.3846650E+03,.4872737E+03,.3477998E+03,.2774131E+03,& - & .3441749E+03,.3846602E+03,.4872929E+03,.3477950E+03,.2774131E+03,& - & .3441701E+03,.3846502E+03,.4872973E+03,.3477898E+03,.2774131E+03,& - & .3441649E+03,.3846453E+03,.4872922E+03,.3477898E+03,.2774131E+03,& - & .3441601E+03,.3846402E+03,.4872825E+03,.3477898E+03,.2774131E+03/ - - data absb(701:875, 3) / & - & .3441601E+03,.3846453E+03,.4872441E+03,.3477898E+03,.2774131E+03,& - & .3441553E+03,.3846453E+03,.4872681E+03,.3477898E+03,.2774131E+03,& - & .3441501E+03,.3846353E+03,.4872773E+03,.3477846E+03,.2774131E+03,& - & .3441453E+03,.3846305E+03,.4872773E+03,.3477798E+03,.2774131E+03,& - & .3441405E+03,.3846253E+03,.4872673E+03,.3477798E+03,.2774131E+03,& - & .3441453E+03,.3846305E+03,.4872244E+03,.3477798E+03,.2774131E+03,& - & .3441353E+03,.3846305E+03,.4872433E+03,.3477798E+03,.2774131E+03,& - & .3441305E+03,.3846205E+03,.4872577E+03,.3477798E+03,.2774131E+03,& - & .3441305E+03,.3846205E+03,.4872622E+03,.3477746E+03,.2774131E+03,& - & .3441205E+03,.3846105E+03,.4872573E+03,.3477746E+03,.2774131E+03,& - & .3441305E+03,.3846205E+03,.4871948E+03,.3477746E+03,.2774131E+03,& - & .3441205E+03,.3846157E+03,.4872237E+03,.3477746E+03,.2774131E+03,& - & .3441157E+03,.3846157E+03,.4872377E+03,.3477746E+03,.2774131E+03,& - & .3441157E+03,.3846057E+03,.4872473E+03,.3477698E+03,.2774131E+03,& - & .3441109E+03,.3846057E+03,.4872473E+03,.3477646E+03,.2774131E+03,& - & .3441157E+03,.3846109E+03,.4871704E+03,.3477698E+03,.2774131E+03,& - & .3441109E+03,.3846057E+03,.4872041E+03,.3477646E+03,.2774131E+03,& - & .3441057E+03,.3846057E+03,.4872229E+03,.3477646E+03,.2774131E+03,& - & .3441009E+03,.3846009E+03,.4872325E+03,.3477646E+03,.2774131E+03,& - & .3441009E+03,.3845957E+03,.4872373E+03,.3477646E+03,.2774131E+03,& - & .3441009E+03,.3846009E+03,.4871412E+03,.3477646E+03,.2774131E+03,& - & .3441009E+03,.3846009E+03,.4871844E+03,.3477646E+03,.2774131E+03,& - & .3440961E+03,.3846009E+03,.4872085E+03,.3477646E+03,.2774131E+03,& - & .3440909E+03,.3845909E+03,.4872225E+03,.3477646E+03,.2774131E+03,& - & .3440909E+03,.3845909E+03,.4872273E+03,.3477646E+03,.2774131E+03,& - & .3440909E+03,.3845961E+03,.4871167E+03,.3477646E+03,.2774131E+03,& - & .3440909E+03,.3845909E+03,.4871600E+03,.3477646E+03,.2774131E+03,& - & .3440861E+03,.3845909E+03,.4871937E+03,.3477594E+03,.2774131E+03,& - & .3440861E+03,.3845861E+03,.4872129E+03,.3477594E+03,.2774131E+03,& - & .3440861E+03,.3845861E+03,.4872225E+03,.3477594E+03,.2774131E+03,& - & .3440861E+03,.3845961E+03,.4870879E+03,.3477594E+03,.2774131E+03,& - & .3440861E+03,.3845861E+03,.4871408E+03,.3477594E+03,.2774131E+03,& - & .3440813E+03,.3845861E+03,.4871741E+03,.3477546E+03,.2774131E+03,& - & .3440761E+03,.3845861E+03,.4871981E+03,.3477546E+03,.2774131E+03,& - & .3440761E+03,.3845809E+03,.4872125E+03,.3477546E+03,.2774131E+03/ - - data absb(876:1050, 3) / & - & .3440761E+03,.3845913E+03,.4870490E+03,.3477546E+03,.2774131E+03,& - & .3440761E+03,.3845861E+03,.4871115E+03,.3477546E+03,.2774131E+03,& - & .3440761E+03,.3845813E+03,.4871548E+03,.3477546E+03,.2774131E+03,& - & .3440713E+03,.3845813E+03,.4871837E+03,.3477546E+03,.2774131E+03,& - & .3440713E+03,.3845761E+03,.4872029E+03,.3477546E+03,.2774131E+03,& - & .3440761E+03,.3845865E+03,.4870153E+03,.3477546E+03,.2774131E+03,& - & .3440713E+03,.3845813E+03,.4870875E+03,.3477546E+03,.2774131E+03,& - & .3440713E+03,.3845761E+03,.4871352E+03,.3477546E+03,.2774131E+03,& - & .3440713E+03,.3845761E+03,.4871689E+03,.3477494E+03,.2774131E+03,& - & .3440713E+03,.3845761E+03,.4871929E+03,.3477494E+03,.2774131E+03,& - & .3440713E+03,.3845917E+03,.4869717E+03,.3477494E+03,.2774131E+03,& - & .3440713E+03,.3845813E+03,.4870582E+03,.3477494E+03,.2774131E+03,& - & .3440713E+03,.3845761E+03,.4871160E+03,.3477494E+03,.2774131E+03,& - & .3440613E+03,.3845713E+03,.4871544E+03,.3477494E+03,.2774131E+03,& - & .3440613E+03,.3845713E+03,.4871833E+03,.3477494E+03,.2774131E+03,& - & .3440665E+03,.3845917E+03,.4869380E+03,.3477494E+03,.2774131E+03,& - & .3440613E+03,.3845765E+03,.4870246E+03,.3477494E+03,.2774131E+03,& - & .3440613E+03,.3845713E+03,.4870919E+03,.3477494E+03,.2774131E+03,& - & .3440613E+03,.3845713E+03,.4871400E+03,.3477494E+03,.2774131E+03,& - & .3440613E+03,.3845713E+03,.4871737E+03,.3477494E+03,.2774131E+03,& - & .3440613E+03,.3845869E+03,.4868891E+03,.3477494E+03,.2774131E+03,& - & .3440613E+03,.3845817E+03,.4869957E+03,.3477494E+03,.2774131E+03,& - & .3440613E+03,.3845713E+03,.4870727E+03,.3477494E+03,.2774131E+03,& - & .3440613E+03,.3845661E+03,.4871256E+03,.3477494E+03,.2774131E+03,& - & .3440565E+03,.3845713E+03,.4871541E+03,.3477494E+03,.2774131E+03,& - & .3440613E+03,.3845921E+03,.4868455E+03,.3477494E+03,.2774131E+03,& - & .3440613E+03,.3845817E+03,.4869569E+03,.3477494E+03,.2774131E+03,& - & .3440565E+03,.3845765E+03,.4870386E+03,.3477494E+03,.2774131E+03,& - & .3440565E+03,.3845713E+03,.4871012E+03,.3477494E+03,.2774131E+03,& - & .3440565E+03,.3845713E+03,.4871396E+03,.3477494E+03,.2774131E+03,& - & .3440565E+03,.3845921E+03,.4867966E+03,.3477494E+03,.2774131E+03,& - & .3440565E+03,.3845869E+03,.4869180E+03,.3477494E+03,.2774131E+03,& - & .3440565E+03,.3845765E+03,.4870146E+03,.3477494E+03,.2774131E+03,& - & .3440565E+03,.3845665E+03,.4870819E+03,.3477494E+03,.2774131E+03,& - & .3440565E+03,.3845613E+03,.4871300E+03,.3477494E+03,.2774131E+03/ - - data absb(1051:1175, 3) / & - & .3440565E+03,.3845972E+03,.4867477E+03,.3477494E+03,.2774131E+03,& - & .3440565E+03,.3845821E+03,.4868843E+03,.3477494E+03,.2774131E+03,& - & .3440565E+03,.3845717E+03,.4869857E+03,.3477494E+03,.2774131E+03,& - & .3440565E+03,.3845665E+03,.4870627E+03,.3477494E+03,.2774131E+03,& - & .3440565E+03,.3845613E+03,.4871156E+03,.3477494E+03,.2774131E+03,& - & .3440565E+03,.3845976E+03,.4866985E+03,.3477494E+03,.2774131E+03,& - & .3440565E+03,.3845872E+03,.4868403E+03,.3477494E+03,.2774131E+03,& - & .3440565E+03,.3845769E+03,.4869520E+03,.3477494E+03,.2774131E+03,& - & .3440565E+03,.3845665E+03,.4870386E+03,.3477494E+03,.2774131E+03,& - & .3440565E+03,.3845665E+03,.4871012E+03,.3477494E+03,.2774131E+03,& - & .3440565E+03,.3846028E+03,.4866393E+03,.3477494E+03,.2774131E+03,& - & .3440565E+03,.3845872E+03,.4868014E+03,.3477494E+03,.2774131E+03,& - & .3440565E+03,.3845769E+03,.4869180E+03,.3477494E+03,.2774131E+03,& - & .3440565E+03,.3845717E+03,.4870146E+03,.3477494E+03,.2774131E+03,& - & .3440465E+03,.3845613E+03,.4870819E+03,.3477494E+03,.2774131E+03,& - & .3440565E+03,.3846028E+03,.4865852E+03,.3477494E+03,.2774131E+03,& - & .3440513E+03,.3845924E+03,.4867526E+03,.3477494E+03,.2774131E+03,& - & .3440465E+03,.3845821E+03,.4868839E+03,.3477494E+03,.2774131E+03,& - & .3440465E+03,.3845717E+03,.4869857E+03,.3477494E+03,.2774131E+03,& - & .3440465E+03,.3845665E+03,.4870627E+03,.3477442E+03,.2774131E+03,& - & .3440465E+03,.3846080E+03,.4865652E+03,.3477494E+03,.2774131E+03,& - & .3440465E+03,.3845924E+03,.4867329E+03,.3477494E+03,.2774131E+03,& - & .3440465E+03,.3845821E+03,.4868695E+03,.3477442E+03,.2774131E+03,& - & .3440465E+03,.3845717E+03,.4869761E+03,.3477442E+03,.2774131E+03,& - & .3440465E+03,.3845665E+03,.4870531E+03,.3477442E+03,.2774131E+03/ - - data absb( 1:175, 4) / & - & .8782833E+03,.6910354E+03,.5724886E+03,.6464156E+03,.7993949E+03,& - & .8715031E+03,.6859459E+03,.5705842E+03,.6464442E+03,.7999135E+03,& - & .8656602E+03,.6815696E+03,.5686553E+03,.6463947E+03,.8002608E+03,& - & .8605853E+03,.6777583E+03,.5667574E+03,.6462801E+03,.8004368E+03,& - & .8561252E+03,.6744132E+03,.5649105E+03,.6460944E+03,.8004368E+03,& - & .8612940E+03,.6782938E+03,.5669216E+03,.6455568E+03,.7994505E+03,& - & .8558228E+03,.6741854E+03,.5649339E+03,.6456484E+03,.7999506E+03,& - & .8511049E+03,.6706518E+03,.5630723E+03,.6456464E+03,.8002840E+03,& - & .8469964E+03,.6675691E+03,.5613310E+03,.6455686E+03,.8004461E+03,& - & .8433882E+03,.6648582E+03,.5596704E+03,.6454205E+03,.8004322E+03,& - & .8474420E+03,.6679062E+03,.5613362E+03,.6448724E+03,.7995061E+03,& - & .8430265E+03,.6645957E+03,.5595545E+03,.6450016E+03,.7999923E+03,& - & .8392252E+03,.6617362E+03,.5578650E+03,.6450418E+03,.8003071E+03,& - & .8359047E+03,.6592484E+03,.5563042E+03,.6449917E+03,.8004461E+03,& - & .8329859E+03,.6570576E+03,.5548590E+03,.6448650E+03,.8004183E+03,& - & .8361725E+03,.6594516E+03,.5562448E+03,.6443217E+03,.7995709E+03,& - & .8326189E+03,.6567852E+03,.5546746E+03,.6444831E+03,.8000339E+03,& - & .8295516E+03,.6544805E+03,.5532717E+03,.6445409E+03,.8003349E+03,& - & .8268752E+03,.6524736E+03,.5519977E+03,.6445269E+03,.8004507E+03,& - & .8245113E+03,.6507091E+03,.5508204E+03,.6444124E+03,.8004090E+03,& - & .8270338E+03,.6525975E+03,.5518584E+03,.6438793E+03,.7996218E+03,& - & .8241743E+03,.6504514E+03,.5505821E+03,.6440683E+03,.8000756E+03,& - & .8216964E+03,.6485930E+03,.5494126E+03,.6441476E+03,.8003534E+03,& - & .8195356E+03,.6469724E+03,.5483183E+03,.6441412E+03,.8004600E+03,& - & .8176273E+03,.6455403E+03,.5473063E+03,.6440475E+03,.8003951E+03,& - & .8196249E+03,.6470370E+03,.5481983E+03,.6435253E+03,.7996774E+03,& - & .8173102E+03,.6453072E+03,.5470865E+03,.6437357E+03,.8001127E+03,& - & .8153180E+03,.6438105E+03,.5460498E+03,.6438219E+03,.8003720E+03,& - & .8135635E+03,.6424969E+03,.5451238E+03,.6438316E+03,.8004553E+03,& - & .8120275E+03,.6413426E+03,.5443103E+03,.6437493E+03,.8003812E+03,& - & .8136081E+03,.6425269E+03,.5450518E+03,.6432481E+03,.7997283E+03,& - & .8117397E+03,.6411295E+03,.5440951E+03,.6434654E+03,.8001451E+03,& - & .8101291E+03,.6399152E+03,.5434568E+03,.6435677E+03,.8003905E+03,& - & .8087217E+03,.6388594E+03,.5425558E+03,.6435788E+03,.8004553E+03,& - & .8074728E+03,.6379229E+03,.5418598E+03,.6434981E+03,.8003720E+03/ - - data absb(176:350, 4) / & - & .8086917E+03,.6388394E+03,.5425140E+03,.6430324E+03,.7997885E+03,& - & .8071950E+03,.6377198E+03,.5416354E+03,.6432465E+03,.8001867E+03,& - & .8058968E+03,.6367433E+03,.5409750E+03,.6433603E+03,.8004044E+03,& - & .8047572E+03,.6358860E+03,.5404031E+03,.6433729E+03,.8004507E+03,& - & .8037507E+03,.6351327E+03,.5398890E+03,.6432929E+03,.8003442E+03,& - & .8047072E+03,.6358514E+03,.5402679E+03,.6428628E+03,.7998441E+03,& - & .8034982E+03,.6349442E+03,.5396729E+03,.6430884E+03,.8002192E+03,& - & .8024525E+03,.6341615E+03,.5391603E+03,.6431890E+03,.8004183E+03,& - & .8015306E+03,.6334675E+03,.5387162E+03,.6432031E+03,.8004461E+03,& - & .8007226E+03,.6328626E+03,.5383107E+03,.6431246E+03,.8003210E+03,& - & .8014021E+03,.6333736E+03,.5385286E+03,.6427532E+03,.7999274E+03,& - & .8004402E+03,.6326495E+03,.5380753E+03,.6429610E+03,.8002701E+03,& - & .7996030E+03,.6320254E+03,.5376858E+03,.6430585E+03,.8004368E+03,& - & .7988743E+03,.6314752E+03,.5373442E+03,.6430640E+03,.8004368E+03,& - & .7982202E+03,.6309896E+03,.5370303E+03,.6429770E+03,.8002794E+03,& - & .7987304E+03,.6313713E+03,.5371412E+03,.6426697E+03,.8000062E+03,& - & .7979624E+03,.6307965E+03,.5368049E+03,.6428597E+03,.8003164E+03,& - & .7972983E+03,.6302955E+03,.5365078E+03,.6429533E+03,.8004507E+03,& - & .7967135E+03,.6298546E+03,.5362486E+03,.6429503E+03,.8004183E+03,& - & .7961933E+03,.6294629E+03,.5359978E+03,.6428455E+03,.8002331E+03,& - & .7965696E+03,.6297507E+03,.5360417E+03,.6426162E+03,.8000849E+03,& - & .7959601E+03,.6292944E+03,.5357832E+03,.6427892E+03,.8003581E+03,& - & .7954299E+03,.6288935E+03,.5355640E+03,.6428696E+03,.8004600E+03,& - & .7949590E+03,.6285410E+03,.5353686E+03,.6428489E+03,.8003905E+03,& - & .7945427E+03,.6282340E+03,.5351678E+03,.6427355E+03,.8001775E+03,& - & .7948251E+03,.6284372E+03,.5351625E+03,.6425749E+03,.8001590E+03,& - & .7943395E+03,.6280755E+03,.5349778E+03,.6427340E+03,.8003951E+03,& - & .7939186E+03,.6277584E+03,.5348178E+03,.6427966E+03,.8004553E+03,& - & .7935415E+03,.6274807E+03,.5346625E+03,.6427574E+03,.8003581E+03,& - & .7932145E+03,.6272282E+03,.5344964E+03,.6426309E+03,.8001127E+03,& - & .7934130E+03,.6273768E+03,.5344664E+03,.6425483E+03,.8002238E+03,& - & .7930260E+03,.6270890E+03,.5343317E+03,.6426996E+03,.8004229E+03,& - & .7926943E+03,.6268366E+03,.5342117E+03,.6427344E+03,.8004461E+03,& - & .7923919E+03,.6266134E+03,.5340864E+03,.6426820E+03,.8003164E+03,& - & .7921295E+03,.6264149E+03,.5339549E+03,.6425323E+03,.8000339E+03/ - - data absb(351:525, 4) / & - & .7922680E+03,.6265242E+03,.5339049E+03,.6425377E+03,.8002886E+03,& - & .7919656E+03,.6262964E+03,.5338156E+03,.6426613E+03,.8004414E+03,& - & .7916978E+03,.6260932E+03,.5337303E+03,.6426876E+03,.8004275E+03,& - & .7914600E+03,.6259147E+03,.5336295E+03,.6426074E+03,.8002608E+03,& - & .7912522E+03,.6257562E+03,.5335134E+03,.6424353E+03,.7999413E+03,& - & .7913561E+03,.6258354E+03,.5334642E+03,.6425425E+03,.8003396E+03,& - & .7911083E+03,.6256569E+03,.5334042E+03,.6426337E+03,.8004553E+03,& - & .7908952E+03,.6254984E+03,.5333388E+03,.6426322E+03,.8004044E+03,& - & .7907120E+03,.6253545E+03,.5332580E+03,.6425389E+03,.8002006E+03,& - & .7905435E+03,.6252260E+03,.5331566E+03,.6423436E+03,.7998395E+03,& - & .7906128E+03,.6252806E+03,.5331127E+03,.6425289E+03,.8003859E+03,& - & .7904242E+03,.6251367E+03,.5330727E+03,.6426115E+03,.8004553E+03,& - & .7902511E+03,.6250128E+03,.5330219E+03,.6425922E+03,.8003673E+03,& - & .7901026E+03,.6248989E+03,.5329519E+03,.6424757E+03,.8001266E+03,& - & .7899687E+03,.6247997E+03,.5328605E+03,.6422481E+03,.7997283E+03,& - & .7900179E+03,.6248343E+03,.5328366E+03,.6425305E+03,.8004183E+03,& - & .7898694E+03,.6247204E+03,.5328112E+03,.6425854E+03,.8004461E+03,& - & .7897355E+03,.6246211E+03,.5327658E+03,.6425429E+03,.8003210E+03,& - & .7896116E+03,.6245319E+03,.5327051E+03,.6423987E+03,.8000432E+03,& - & .7895077E+03,.6244526E+03,.5326190E+03,.6421432E+03,.7995987E+03,& - & .7895370E+03,.6244726E+03,.5326105E+03,.6425329E+03,.8004414E+03,& - & .7894185E+03,.6243834E+03,.5325958E+03,.6425646E+03,.8004275E+03,& - & .7893092E+03,.6243041E+03,.5325597E+03,.6424944E+03,.8002655E+03,& - & .7892153E+03,.6242295E+03,.5325043E+03,.6423270E+03,.7999460E+03,& - & .7891307E+03,.6241702E+03,.5324182E+03,.6420445E+03,.7994598E+03,& - & .7891507E+03,.6241848E+03,.5324351E+03,.6425307E+03,.8004553E+03,& - & .7890568E+03,.6241156E+03,.5324243E+03,.6425392E+03,.8003998E+03,& - & .7889722E+03,.6240463E+03,.5323943E+03,.6424466E+03,.8001960E+03,& - & .7888929E+03,.6239917E+03,.5323429E+03,.6422514E+03,.7998348E+03,& - & .7888283E+03,.6239424E+03,.5322521E+03,.6419319E+03,.7993069E+03,& - & .7888437E+03,.6239471E+03,.5322936E+03,.6425292E+03,.8004553E+03,& - & .7887644E+03,.6238924E+03,.5322836E+03,.6425100E+03,.8003627E+03,& - & .7886998E+03,.6238432E+03,.5322582E+03,.6423942E+03,.8001173E+03,& - & .7886405E+03,.6237985E+03,.5322021E+03,.6421666E+03,.7997144E+03,& - & .7885859E+03,.6237585E+03,.5321068E+03,.6418054E+03,.7991402E+03/ - - data absb(526:700, 4) / & - & .7885959E+03,.6237639E+03,.5321829E+03,.6425185E+03,.8004461E+03,& - & .7885312E+03,.6237193E+03,.5321775E+03,.6424761E+03,.8003210E+03,& - & .7884766E+03,.6236793E+03,.5321475E+03,.6423418E+03,.8000386E+03,& - & .7884320E+03,.6236446E+03,.5320868E+03,.6420918E+03,.7995987E+03,& - & .7883873E+03,.6236100E+03,.5319860E+03,.6416882E+03,.7989828E+03,& - & .7883973E+03,.6236200E+03,.5320921E+03,.6425078E+03,.8004414E+03,& - & .7883527E+03,.6235854E+03,.5320868E+03,.6424568E+03,.8002933E+03,& - & .7883081E+03,.6235507E+03,.5320621E+03,.6423040E+03,.7999923E+03,& - & .7882688E+03,.6235207E+03,.5320014E+03,.6420401E+03,.7995246E+03,& - & .7882288E+03,.6234961E+03,.5318953E+03,.6416133E+03,.7988948E+03,& - & .7882488E+03,.6235061E+03,.5320114E+03,.6424978E+03,.8004368E+03,& - & .7882042E+03,.6234715E+03,.5320168E+03,.6424468E+03,.8002886E+03,& - & .7881696E+03,.6234469E+03,.5319914E+03,.6422940E+03,.7999830E+03,& - & .7881396E+03,.6234269E+03,.5319360E+03,.6420255E+03,.7995153E+03,& - & .7881103E+03,.6234022E+03,.5318299E+03,.6415941E+03,.7988763E+03,& - & .7881249E+03,.6234169E+03,.5319460E+03,.6424924E+03,.8004507E+03,& - & .7880903E+03,.6233922E+03,.5319614E+03,.6424554E+03,.8003164E+03,& - & .7880603E+03,.6233676E+03,.5319414E+03,.6423118E+03,.8000339E+03,& - & .7880357E+03,.6233476E+03,.5318907E+03,.6420618E+03,.7995848E+03,& - & .7880110E+03,.6233276E+03,.5317953E+03,.6416589E+03,.7989689E+03,& - & .7880257E+03,.6233376E+03,.5318907E+03,.6424878E+03,.8004507E+03,& - & .7880010E+03,.6233176E+03,.5319107E+03,.6424646E+03,.8003442E+03,& - & .7879710E+03,.6233030E+03,.5319014E+03,.6423342E+03,.8000849E+03,& - & .7879510E+03,.6232830E+03,.5318553E+03,.6420981E+03,.7996589E+03,& - & .7879318E+03,.6232683E+03,.5317753E+03,.6417184E+03,.7990662E+03,& - & .7879464E+03,.6232783E+03,.5318507E+03,.6424778E+03,.8004553E+03,& - & .7879218E+03,.6232583E+03,.5318707E+03,.6424639E+03,.8003673E+03,& - & .7879018E+03,.6232483E+03,.5318607E+03,.6423574E+03,.8001266E+03,& - & .7878818E+03,.6232337E+03,.5318307E+03,.6421351E+03,.7997283E+03,& - & .7878672E+03,.6232183E+03,.5317553E+03,.6417832E+03,.7991588E+03,& - & .7878772E+03,.6232283E+03,.5318053E+03,.6424639E+03,.8004553E+03,& - & .7878572E+03,.6232137E+03,.5318353E+03,.6424778E+03,.8004044E+03,& - & .7878425E+03,.6232037E+03,.5318407E+03,.6423844E+03,.8002006E+03,& - & .7878225E+03,.6231891E+03,.5318153E+03,.6421946E+03,.7998395E+03,& - & .7878125E+03,.6231791E+03,.5317499E+03,.6418751E+03,.7993116E+03/ - - data absb(701:875, 4) / & - & .7878225E+03,.6231891E+03,.5317645E+03,.6424400E+03,.8004461E+03,& - & .7878079E+03,.6231791E+03,.5317999E+03,.6424770E+03,.8004275E+03,& - & .7877925E+03,.6231691E+03,.5318153E+03,.6424168E+03,.8002655E+03,& - & .7877779E+03,.6231544E+03,.5317999E+03,.6422548E+03,.7999460E+03,& - & .7877679E+03,.6231444E+03,.5317445E+03,.6419769E+03,.7994598E+03,& - & .7877779E+03,.6231544E+03,.5317245E+03,.6424122E+03,.8004183E+03,& - & .7877633E+03,.6231444E+03,.5317699E+03,.6424770E+03,.8004461E+03,& - & .7877533E+03,.6231344E+03,.5317899E+03,.6424400E+03,.8003210E+03,& - & .7877433E+03,.6231244E+03,.5317853E+03,.6423057E+03,.8000432E+03,& - & .7877333E+03,.6231198E+03,.5317445E+03,.6420556E+03,.7996033E+03,& - & .7877433E+03,.6231244E+03,.5316899E+03,.6423705E+03,.8003766E+03,& - & .7877333E+03,.6231144E+03,.5317399E+03,.6424678E+03,.8004553E+03,& - & .7877186E+03,.6231098E+03,.5317699E+03,.6424585E+03,.8003766E+03,& - & .7877086E+03,.6231044E+03,.5317699E+03,.6423566E+03,.8001451E+03,& - & .7876986E+03,.6230998E+03,.5317445E+03,.6421383E+03,.7997561E+03,& - & .7877086E+03,.6231044E+03,.5316492E+03,.6423150E+03,.8003071E+03,& - & .7876986E+03,.6230998E+03,.5317045E+03,.6424392E+03,.8004461E+03,& - & .7876940E+03,.6230898E+03,.5317445E+03,.6424670E+03,.8004229E+03,& - & .7876840E+03,.6230798E+03,.5317599E+03,.6424022E+03,.8002423E+03,& - & .7876786E+03,.6230798E+03,.5317499E+03,.6422216E+03,.7999089E+03,& - & .7876886E+03,.6230898E+03,.5316092E+03,.6422494E+03,.8002238E+03,& - & .7876786E+03,.6230798E+03,.5316792E+03,.6424068E+03,.8004229E+03,& - & .7876740E+03,.6230698E+03,.5317245E+03,.6424717E+03,.8004461E+03,& - & .7876640E+03,.6230698E+03,.5317445E+03,.6424300E+03,.8003210E+03,& - & .7876540E+03,.6230652E+03,.5317445E+03,.6422957E+03,.8000386E+03,& - & .7876640E+03,.6230698E+03,.5315738E+03,.6421614E+03,.8001080E+03,& - & .7876540E+03,.6230652E+03,.5316438E+03,.6423605E+03,.8003720E+03,& - & .7876540E+03,.6230598E+03,.5316992E+03,.6424578E+03,.8004553E+03,& - & .7876440E+03,.6230552E+03,.5317345E+03,.6424578E+03,.8003812E+03,& - & .7876394E+03,.6230552E+03,.5317399E+03,.6423559E+03,.8001590E+03,& - & .7876494E+03,.6230552E+03,.5315245E+03,.6420410E+03,.7999552E+03,& - & .7876440E+03,.6230552E+03,.5316045E+03,.6422957E+03,.8002840E+03,& - & .7876340E+03,.6230452E+03,.5316692E+03,.6424300E+03,.8004414E+03,& - & .7876294E+03,.6230452E+03,.5317145E+03,.6424670E+03,.8004322E+03,& - & .7876294E+03,.6230406E+03,.5317299E+03,.6424068E+03,.8002655E+03/ - - data absb(876:1050, 4) / & - & .7876340E+03,.6230452E+03,.5314838E+03,.6419067E+03,.7997700E+03,& - & .7876294E+03,.6230452E+03,.5315692E+03,.6422077E+03,.8001729E+03,& - & .7876194E+03,.6230352E+03,.5316392E+03,.6423883E+03,.8003998E+03,& - & .7876194E+03,.6230352E+03,.5316892E+03,.6424670E+03,.8004553E+03,& - & .7876194E+03,.6230352E+03,.5317192E+03,.6424439E+03,.8003488E+03,& - & .7876194E+03,.6230352E+03,.5314438E+03,.6417493E+03,.7995616E+03,& - & .7876194E+03,.6230352E+03,.5315284E+03,.6421012E+03,.8000293E+03,& - & .7876094E+03,.6230306E+03,.5316038E+03,.6423281E+03,.8003581E+03,& - & .7876094E+03,.6230252E+03,.5316692E+03,.6424485E+03,.8004507E+03,& - & .7876047E+03,.6230252E+03,.5317045E+03,.6424624E+03,.8004090E+03,& - & .7876094E+03,.6230306E+03,.5314031E+03,.6415826E+03,.7993394E+03,& - & .7876094E+03,.6230252E+03,.5314884E+03,.6419808E+03,.7998719E+03,& - & .7876047E+03,.6230206E+03,.5315738E+03,.6422540E+03,.8002377E+03,& - & .7875994E+03,.6230206E+03,.5316438E+03,.6424115E+03,.8004275E+03,& - & .7875994E+03,.6230206E+03,.5316892E+03,.6424670E+03,.8004414E+03,& - & .7875994E+03,.6230206E+03,.5313623E+03,.6414066E+03,.7991032E+03,& - & .7875994E+03,.6230206E+03,.5314538E+03,.6418512E+03,.7996959E+03,& - & .7875947E+03,.6230152E+03,.5315392E+03,.6421707E+03,.8001266E+03,& - & .7875947E+03,.6230152E+03,.5316138E+03,.6423652E+03,.8003766E+03,& - & .7875894E+03,.6230106E+03,.5316745E+03,.6424578E+03,.8004553E+03,& - & .7875947E+03,.6230152E+03,.5313123E+03,.6412029E+03,.7988393E+03,& - & .7875947E+03,.6230152E+03,.5314184E+03,.6417030E+03,.7995014E+03,& - & .7875894E+03,.6230106E+03,.5315084E+03,.6420688E+03,.7999876E+03,& - & .7875847E+03,.6230106E+03,.5315838E+03,.6423096E+03,.8003071E+03,& - & .7875847E+03,.6230106E+03,.5316538E+03,.6424346E+03,.8004507E+03,& - & .7875894E+03,.6230106E+03,.5312631E+03,.6409852E+03,.7985568E+03,& - & .7875847E+03,.6230106E+03,.5313777E+03,.6415409E+03,.7992838E+03,& - & .7875847E+03,.6230106E+03,.5314738E+03,.6419484E+03,.7998302E+03,& - & .7875847E+03,.6230106E+03,.5315538E+03,.6422355E+03,.8002099E+03,& - & .7875794E+03,.6230052E+03,.5316292E+03,.6424022E+03,.8004183E+03,& - & .7875847E+03,.6230106E+03,.5312184E+03,.6407722E+03,.7982743E+03,& - & .7875847E+03,.6230106E+03,.5313370E+03,.6413696E+03,.7990569E+03,& - & .7875794E+03,.6230006E+03,.5314384E+03,.6418280E+03,.7996635E+03,& - & .7875747E+03,.6230006E+03,.5315284E+03,.6421522E+03,.8001034E+03,& - & .7875747E+03,.6230006E+03,.5315992E+03,.6423559E+03,.8003673E+03/ - - data absb(1051:1175, 4) / & - & .7875794E+03,.6230006E+03,.5311645E+03,.6405500E+03,.7979826E+03,& - & .7875747E+03,.6230006E+03,.5313070E+03,.6411936E+03,.7988254E+03,& - & .7875747E+03,.6230006E+03,.5314031E+03,.6416937E+03,.7994875E+03,& - & .7875747E+03,.6230006E+03,.5314984E+03,.6420642E+03,.7999784E+03,& - & .7875747E+03,.6230006E+03,.5315738E+03,.6423050E+03,.8003025E+03,& - & .7875747E+03,.6230006E+03,.5311153E+03,.6403138E+03,.7976770E+03,& - & .7875747E+03,.6230006E+03,.5312577E+03,.6409991E+03,.7985753E+03,& - & .7875747E+03,.6230006E+03,.5313723E+03,.6415502E+03,.7992977E+03,& - & .7875747E+03,.6230006E+03,.5314684E+03,.6419577E+03,.7998395E+03,& - & .7875701E+03,.6230006E+03,.5315484E+03,.6422401E+03,.8002238E+03,& - & .7875747E+03,.6230006E+03,.5310514E+03,.6400638E+03,.7973482E+03,& - & .7875747E+03,.6230006E+03,.5312184E+03,.6408000E+03,.7983067E+03,& - & .7875701E+03,.6230006E+03,.5313423E+03,.6413927E+03,.7990847E+03,& - & .7875647E+03,.6230006E+03,.5314331E+03,.6418419E+03,.7996866E+03,& - & .7875647E+03,.6229959E+03,.5315238E+03,.6421660E+03,.8001173E+03,& - & .7875701E+03,.6230006E+03,.5309975E+03,.6398091E+03,.7970241E+03,& - & .7875647E+03,.6230006E+03,.5311692E+03,.6405870E+03,.7980382E+03,& - & .7875647E+03,.6229959E+03,.5313023E+03,.6412260E+03,.7988717E+03,& - & .7875647E+03,.6229959E+03,.5314077E+03,.6417115E+03,.7995246E+03,& - & .7875647E+03,.6229906E+03,.5314984E+03,.6420727E+03,.8000015E+03,& - & .7875647E+03,.6229959E+03,.5309682E+03,.6397072E+03,.7968852E+03,& - & .7875647E+03,.6229959E+03,.5311492E+03,.6404983E+03,.7979224E+03,& - & .7875647E+03,.6229906E+03,.5312931E+03,.6411512E+03,.7987791E+03,& - & .7875647E+03,.6229906E+03,.5313977E+03,.6416652E+03,.7994505E+03,& - & .7875647E+03,.6229906E+03,.5314884E+03,.6420356E+03,.7999552E+03/ - - data absb( 1:175, 5) / & - & .1132160E+04,.8590321E+03,.5914771E+03,.8420290E+03,.1108579E+04,& - & .1123473E+04,.8524625E+03,.5885652E+03,.8420681E+03,.1108734E+04,& - & .1115900E+04,.8468347E+03,.5862702E+03,.8419164E+03,.1108697E+04,& - & .1109376E+04,.8419137E+03,.5843636E+03,.8415502E+03,.1108322E+04,& - & .1103614E+04,.8376140E+03,.5827038E+03,.8409654E+03,.1107682E+04,& - & .1110333E+04,.8425995E+03,.5848362E+03,.8418344E+03,.1108619E+04,& - & .1103219E+04,.8373133E+03,.5831283E+03,.8418712E+03,.1108805E+04,& - & .1097195E+04,.8327409E+03,.5816627E+03,.8417168E+03,.1108673E+04,& - & .1091865E+04,.8287858E+03,.5803753E+03,.8413520E+03,.1108225E+04,& - & .1087188E+04,.8252839E+03,.5792120E+03,.8407467E+03,.1107577E+04,& - & .1092412E+04,.8291999E+03,.5808570E+03,.8416771E+03,.1108633E+04,& - & .1086772E+04,.8249577E+03,.5797842E+03,.8417051E+03,.1108778E+04,& - & .1081872E+04,.8212500E+03,.5788998E+03,.8415393E+03,.1108609E+04,& - & .1077591E+04,.8180528E+03,.5780798E+03,.8411541E+03,.1108196E+04,& - & .1073799E+04,.8152246E+03,.5772425E+03,.8405502E+03,.1107530E+04,& - & .1077932E+04,.8183131E+03,.5785343E+03,.8415558E+03,.1108628E+04,& - & .1073370E+04,.8148772E+03,.5779321E+03,.8415699E+03,.1108773E+04,& - & .1069367E+04,.8118993E+03,.5773345E+03,.8413946E+03,.1108586E+04,& - & .1065923E+04,.8093364E+03,.5766911E+03,.8409868E+03,.1108139E+04,& - & .1062906E+04,.8070496E+03,.5759923E+03,.8403687E+03,.1107413E+04,& - & .1066103E+04,.8094792E+03,.5771890E+03,.8414562E+03,.1108645E+04,& - & .1062427E+04,.8067082E+03,.5767835E+03,.8414606E+03,.1108749E+04,& - & .1059242E+04,.8043159E+03,.5763730E+03,.8412660E+03,.1108562E+04,& - & .1056471E+04,.8022149E+03,.5759120E+03,.8408523E+03,.1108069E+04,& - & .1053956E+04,.8003803E+03,.5753382E+03,.8402087E+03,.1107311E+04,& - & .1056573E+04,.8023128E+03,.5763612E+03,.8413744E+03,.1108681E+04,& - & .1053614E+04,.8000761E+03,.5761904E+03,.8413677E+03,.1108744E+04,& - & .1050995E+04,.7981568E+03,.5759572E+03,.8411623E+03,.1108557E+04,& - & .1048738E+04,.7964524E+03,.5755889E+03,.8407256E+03,.1108012E+04,& - & .1046781E+04,.7949640E+03,.5750302E+03,.8400566E+03,.1107234E+04,& - & .1048831E+04,.7964881E+03,.5759871E+03,.8413116E+03,.1108751E+04,& - & .1046421E+04,.7947095E+03,.5759550E+03,.8412858E+03,.1108763E+04,& - & .1044326E+04,.7931394E+03,.5755277E+03,.8410568E+03,.1108455E+04,& - & .1042519E+04,.7917703E+03,.5753386E+03,.8406038E+03,.1107955E+04,& - & .1040912E+04,.7905575E+03,.5748294E+03,.8399213E+03,.1107129E+04/ - - data absb(176:350, 5) / & - & .1042504E+04,.7917365E+03,.5757083E+03,.8412594E+03,.1108725E+04,& - & .1040562E+04,.7902912E+03,.5758192E+03,.8412189E+03,.1108733E+04,& - & .1038874E+04,.7890443E+03,.5756096E+03,.8409680E+03,.1108430E+04,& - & .1037398E+04,.7879351E+03,.5752218E+03,.8404909E+03,.1107888E+04,& - & .1036091E+04,.7869710E+03,.5746527E+03,.8397830E+03,.1107005E+04,& - & .1037338E+04,.7878931E+03,.5757405E+03,.8412192E+03,.1108773E+04,& - & .1035785E+04,.7867242E+03,.5757045E+03,.8411493E+03,.1108704E+04,& - & .1034434E+04,.7857049E+03,.5754770E+03,.8408953E+03,.1108371E+04,& - & .1033255E+04,.7848307E+03,.5750727E+03,.8403820E+03,.1107804E+04,& - & .1032221E+04,.7840296E+03,.5744847E+03,.8396477E+03,.1106878E+04,& - & .1033083E+04,.7846984E+03,.5756617E+03,.8411849E+03,.1108731E+04,& - & .1031809E+04,.7837832E+03,.5755890E+03,.8410839E+03,.1108675E+04,& - & .1030787E+04,.7829597E+03,.5753383E+03,.8407754E+03,.1108320E+04,& - & .1029807E+04,.7822396E+03,.5749009E+03,.8402301E+03,.1107645E+04,& - & .1028979E+04,.7816263E+03,.5742825E+03,.8394539E+03,.1106694E+04,& - & .1029657E+04,.7821089E+03,.5755832E+03,.8411501E+03,.1108780E+04,& - & .1028643E+04,.7813695E+03,.5754905E+03,.8410195E+03,.1108611E+04,& - & .1027767E+04,.7807233E+03,.5752049E+03,.8406589E+03,.1108196E+04,& - & .1027001E+04,.7801530E+03,.5747429E+03,.8400708E+03,.1107518E+04,& - & .1026393E+04,.7796516E+03,.5740912E+03,.8392499E+03,.1106487E+04,& - & .1026855E+04,.7800266E+03,.5755207E+03,.8411092E+03,.1108746E+04,& - & .1026108E+04,.7794325E+03,.5753911E+03,.8409396E+03,.1108560E+04,& - & .1025405E+04,.7789140E+03,.5750771E+03,.8405361E+03,.1108069E+04,& - & .1024798E+04,.7784615E+03,.5745776E+03,.8399056E+03,.1107291E+04,& - & .1024258E+04,.7780677E+03,.5738970E+03,.8390391E+03,.1106226E+04,& - & .1024599E+04,.7783363E+03,.5754652E+03,.8410717E+03,.1108755E+04,& - & .1023976E+04,.7778616E+03,.5752948E+03,.8408626E+03,.1108455E+04,& - & .1023441E+04,.7774535E+03,.5749424E+03,.8404102E+03,.1107910E+04,& - & .1022936E+04,.7771014E+03,.5744109E+03,.8397256E+03,.1107107E+04,& - & .1022522E+04,.7767688E+03,.5736917E+03,.8388102E+03,.1105992E+04,& - & .1022769E+04,.7769692E+03,.5754043E+03,.8410269E+03,.1108704E+04,& - & .1022268E+04,.7765895E+03,.5751966E+03,.8407518E+03,.1108371E+04,& - & .1021836E+04,.7762638E+03,.5748030E+03,.8402567E+03,.1107761E+04,& - & .1021436E+04,.7759755E+03,.5742299E+03,.8395192E+03,.1106876E+04,& - & .1021119E+04,.7757229E+03,.5734692E+03,.8385490E+03,.1105715E+04/ - - data absb(351:525, 5) / & - & .1021292E+04,.7758615E+03,.5753413E+03,.8409718E+03,.1108668E+04,& - & .1020929E+04,.7755643E+03,.5750916E+03,.8406449E+03,.1108220E+04,& - & .1020592E+04,.7753101E+03,.5746540E+03,.8400874E+03,.1107585E+04,& - & .1020272E+04,.7750812E+03,.5740383E+03,.8393001E+03,.1106614E+04,& - & .1019972E+04,.7748751E+03,.5732385E+03,.8382776E+03,.1105351E+04,& - & .1020107E+04,.7749807E+03,.5752706E+03,.8408913E+03,.1108584E+04,& - & .1019789E+04,.7747389E+03,.5749801E+03,.8405246E+03,.1108134E+04,& - & .1019546E+04,.7745422E+03,.5745060E+03,.8399165E+03,.1107403E+04,& - & .1019286E+04,.7743596E+03,.5738419E+03,.8390704E+03,.1106328E+04,& - & .1019084E+04,.7741942E+03,.5730024E+03,.8379946E+03,.1105002E+04,& - & .1019170E+04,.7742594E+03,.5751978E+03,.8408308E+03,.1108460E+04,& - & .1018904E+04,.7740885E+03,.5748611E+03,.8403860E+03,.1107988E+04,& - & .1018723E+04,.7739185E+03,.5743390E+03,.8397187E+03,.1107159E+04,& - & .1018501E+04,.7737687E+03,.5736328E+03,.8388110E+03,.1106037E+04,& - & .1018361E+04,.7736360E+03,.5727529E+03,.8376904E+03,.1104671E+04,& - & .1018405E+04,.7736814E+03,.5751164E+03,.8407303E+03,.1108371E+04,& - & .1018184E+04,.7735401E+03,.5747312E+03,.8402361E+03,.1107809E+04,& - & .1018016E+04,.7734164E+03,.5741681E+03,.8395069E+03,.1106893E+04,& - & .1017890E+04,.7732973E+03,.5734155E+03,.8385510E+03,.1105713E+04,& - & .1017756E+04,.7731912E+03,.5724903E+03,.8373611E+03,.1104249E+04,& - & .1017792E+04,.7732316E+03,.5750249E+03,.8406141E+03,.1108220E+04,& - & .1017606E+04,.7731185E+03,.5745953E+03,.8400642E+03,.1107577E+04,& - & .1017494E+04,.7730061E+03,.5739811E+03,.8392794E+03,.1106592E+04,& - & .1017366E+04,.7729075E+03,.5731866E+03,.8382606E+03,.1105362E+04,& - & .1017266E+04,.7728198E+03,.5722190E+03,.8370243E+03,.1103792E+04,& - & .1017292E+04,.7728676E+03,.5749177E+03,.8404941E+03,.1108136E+04,& - & .1017190E+04,.7727693E+03,.5744446E+03,.8398803E+03,.1107391E+04,& - & .1017083E+04,.7726878E+03,.5737816E+03,.8390343E+03,.1106328E+04,& - & .1016964E+04,.7726050E+03,.5729440E+03,.8379568E+03,.1105000E+04,& - & .1016882E+04,.7725450E+03,.5719281E+03,.8366665E+03,.1103367E+04,& - & .1016898E+04,.7725446E+03,.5748005E+03,.8403534E+03,.1107950E+04,& - & .1016789E+04,.7724810E+03,.5742785E+03,.8396774E+03,.1107107E+04,& - & .1016697E+04,.7724226E+03,.5735704E+03,.8387721E+03,.1105974E+04,& - & .1016611E+04,.7723504E+03,.5726872E+03,.8376384E+03,.1104578E+04,& - & .1016571E+04,.7723041E+03,.5716302E+03,.8363014E+03,.1102913E+04/ - - data absb(526:700, 5) / & - & .1016584E+04,.7723202E+03,.5746950E+03,.8402176E+03,.1107804E+04,& - & .1016488E+04,.7722577E+03,.5741300E+03,.8394890E+03,.1106878E+04,& - & .1016426E+04,.7722026E+03,.5733811E+03,.8385253E+03,.1105713E+04,& - & .1016380E+04,.7721456E+03,.5724560E+03,.8373415E+03,.1104249E+04,& - & .1016306E+04,.7721127E+03,.5713670E+03,.8359703E+03,.1102470E+04,& - & .1016292E+04,.7721168E+03,.5746264E+03,.8401340E+03,.1107701E+04,& - & .1016228E+04,.7720667E+03,.5740386E+03,.8393714E+03,.1106751E+04,& - & .1016205E+04,.7720362E+03,.5732662E+03,.8383847E+03,.1105553E+04,& - & .1016128E+04,.7719854E+03,.5723210E+03,.8371730E+03,.1104011E+04,& - & .1016090E+04,.7719561E+03,.5712032E+03,.8357753E+03,.1102230E+04,& - & .1016110E+04,.7719675E+03,.5746079E+03,.8401177E+03,.1107679E+04,& - & .1016065E+04,.7719395E+03,.5740164E+03,.8393596E+03,.1106716E+04,& - & .1016018E+04,.7718925E+03,.5732410E+03,.8383584E+03,.1105484E+04,& - & .1015979E+04,.7718623E+03,.5722888E+03,.8371394E+03,.1103992E+04,& - & .1015924E+04,.7718361E+03,.5711776E+03,.8357521E+03,.1102176E+04,& - & .1015947E+04,.7718575E+03,.5746707E+03,.8401949E+03,.1107761E+04,& - & .1015896E+04,.7718201E+03,.5741037E+03,.8394653E+03,.1106876E+04,& - & .1015883E+04,.7717903E+03,.5733511E+03,.8384984E+03,.1105710E+04,& - & .1015843E+04,.7717658E+03,.5724260E+03,.8373113E+03,.1104216E+04,& - & .1015798E+04,.7717449E+03,.5713285E+03,.8359335E+03,.1102415E+04,& - & .1015834E+04,.7717612E+03,.5747316E+03,.8402799E+03,.1107885E+04,& - & .1015782E+04,.7717396E+03,.5741902E+03,.8395813E+03,.1107005E+04,& - & .1015801E+04,.7717242E+03,.5734642E+03,.8386440E+03,.1105870E+04,& - & .1015718E+04,.7716962E+03,.5725620E+03,.8374954E+03,.1104414E+04,& - & .1015732E+04,.7716614E+03,.5714866E+03,.8361383E+03,.1102708E+04,& - & .1015729E+04,.7716742E+03,.5747862E+03,.8403517E+03,.1107983E+04,& - & .1015723E+04,.7716656E+03,.5742723E+03,.8396911E+03,.1107164E+04,& - & .1015702E+04,.7716450E+03,.5735710E+03,.8387908E+03,.1106042E+04,& - & .1015640E+04,.7716167E+03,.5726959E+03,.8376665E+03,.1104643E+04,& - & .1015624E+04,.7716061E+03,.5716434E+03,.8363327E+03,.1102967E+04,& - & .1015631E+04,.7716188E+03,.5748861E+03,.8404775E+03,.1108129E+04,& - & .1015600E+04,.7716030E+03,.5744127E+03,.8398706E+03,.1107389E+04,& - & .1015613E+04,.7715764E+03,.5737556E+03,.8390288E+03,.1106328E+04,& - & .1015597E+04,.7715697E+03,.5729199E+03,.8379553E+03,.1105002E+04,& - & .1015567E+04,.7715535E+03,.5719103E+03,.8366668E+03,.1103378E+04/ - - data absb(701:875, 5) / & - & .1015593E+04,.7715621E+03,.5749733E+03,.8405981E+03,.1108255E+04,& - & .1015568E+04,.7715451E+03,.5745491E+03,.8400486E+03,.1107577E+04,& - & .1015524E+04,.7715394E+03,.5739392E+03,.8392612E+03,.1106614E+04,& - & .1015503E+04,.7715146E+03,.5731507E+03,.8382433E+03,.1105384E+04,& - & .1015505E+04,.7715078E+03,.5721820E+03,.8370057E+03,.1103824E+04,& - & .1015532E+04,.7715161E+03,.5750518E+03,.8407005E+03,.1108396E+04,& - & .1015508E+04,.7715165E+03,.5746709E+03,.8402103E+03,.1107804E+04,& - & .1015497E+04,.7714992E+03,.5741118E+03,.8394869E+03,.1106898E+04,& - & .1015491E+04,.7714822E+03,.5733668E+03,.8385286E+03,.1105713E+04,& - & .1015451E+04,.7714746E+03,.5724432E+03,.8373437E+03,.1104253E+04,& - & .1015486E+04,.7714820E+03,.5751302E+03,.8408091E+03,.1108535E+04,& - & .1015439E+04,.7714848E+03,.5748127E+03,.8403847E+03,.1108012E+04,& - & .1015433E+04,.7714633E+03,.5743039E+03,.8397376E+03,.1107232E+04,& - & .1015424E+04,.7714749E+03,.5736175E+03,.8388518E+03,.1106104E+04,& - & .1015410E+04,.7714655E+03,.5727504E+03,.8377374E+03,.1104743E+04,& - & .1015436E+04,.7714612E+03,.5751941E+03,.8408969E+03,.1108616E+04,& - & .1015415E+04,.7714466E+03,.5749379E+03,.8405563E+03,.1108196E+04,& - & .1015431E+04,.7714422E+03,.5744930E+03,.8399786E+03,.1107523E+04,& - & .1015404E+04,.7714254E+03,.5738675E+03,.8391725E+03,.1106533E+04,& - & .1015390E+04,.7714259E+03,.5730571E+03,.8381379E+03,.1105227E+04,& - & .1015396E+04,.7714361E+03,.5752396E+03,.8409521E+03,.1108709E+04,& - & .1015390E+04,.7714279E+03,.5750483E+03,.8406969E+03,.1108371E+04,& - & .1015395E+04,.7714259E+03,.5746631E+03,.8402006E+03,.1107804E+04,& - & .1015371E+04,.7714032E+03,.5740972E+03,.8394745E+03,.1106873E+04,& - & .1015337E+04,.7714081E+03,.5733553E+03,.8385150E+03,.1105708E+04,& - & .1015386E+04,.7714066E+03,.5752600E+03,.8409913E+03,.1108744E+04,& - & .1015370E+04,.7713985E+03,.5751351E+03,.8408196E+03,.1108557E+04,& - & .1015337E+04,.7713964E+03,.5748223E+03,.8404045E+03,.1108012E+04,& - & .1015367E+04,.7713981E+03,.5743244E+03,.8397592E+03,.1107234E+04,& - & .1015333E+04,.7713847E+03,.5736421E+03,.8388851E+03,.1106199E+04,& - & .1015347E+04,.7714005E+03,.5752587E+03,.8410118E+03,.1108805E+04,& - & .1015311E+04,.7713902E+03,.5752086E+03,.8409157E+03,.1108668E+04,& - & .1015318E+04,.7713893E+03,.5749690E+03,.8405927E+03,.1108222E+04,& - & .1015319E+04,.7713841E+03,.5745459E+03,.8400467E+03,.1107577E+04,& - & .1015312E+04,.7713874E+03,.5739392E+03,.8392646E+03,.1106614E+04/ - - data absb(876:1050, 5) / & - & .1015326E+04,.7713768E+03,.5752286E+03,.8409923E+03,.1108751E+04,& - & .1015341E+04,.7713759E+03,.5752489E+03,.8409777E+03,.1108755E+04,& - & .1015327E+04,.7713686E+03,.5750877E+03,.8407611E+03,.1108430E+04,& - & .1015298E+04,.7713645E+03,.5747398E+03,.8402950E+03,.1107885E+04,& - & .1015298E+04,.7713757E+03,.5742018E+03,.8396055E+03,.1107040E+04,& - & .1015315E+04,.7713740E+03,.5751637E+03,.8409394E+03,.1108628E+04,& - & .1015298E+04,.7713705E+03,.5752637E+03,.8410091E+03,.1108775E+04,& - & .1015291E+04,.7713551E+03,.5751720E+03,.8408697E+03,.1108543E+04,& - & .1015296E+04,.7713612E+03,.5748985E+03,.8405081E+03,.1108141E+04,& - & .1015287E+04,.7713533E+03,.5744395E+03,.8399107E+03,.1107418E+04,& - & .1015330E+04,.7713626E+03,.5750740E+03,.8408557E+03,.1108508E+04,& - & .1015299E+04,.7713625E+03,.5752467E+03,.8410077E+03,.1108736E+04,& - & .1015318E+04,.7713499E+03,.5752320E+03,.8409497E+03,.1108707E+04,& - & .1015318E+04,.7713544E+03,.5750237E+03,.8406755E+03,.1108347E+04,& - & .1015282E+04,.7713600E+03,.5746353E+03,.8401644E+03,.1107726E+04,& - & .1015292E+04,.7713486E+03,.5749639E+03,.8407482E+03,.1108372E+04,& - & .1015292E+04,.7713504E+03,.5752056E+03,.8409790E+03,.1108713E+04,& - & .1015299E+04,.7713406E+03,.5752580E+03,.8409900E+03,.1108719E+04,& - & .1015282E+04,.7713457E+03,.5751224E+03,.8408012E+03,.1108533E+04,& - & .1015288E+04,.7713329E+03,.5748024E+03,.8403755E+03,.1108010E+04,& - & .1015278E+04,.7713411E+03,.5748265E+03,.8406142E+03,.1108188E+04,& - & .1015285E+04,.7713391E+03,.5751400E+03,.8409197E+03,.1108633E+04,& - & .1015300E+04,.7713296E+03,.5752623E+03,.8410092E+03,.1108780E+04,& - & .1015260E+04,.7713359E+03,.5751941E+03,.8408949E+03,.1108613E+04,& - & .1015249E+04,.7713381E+03,.5749404E+03,.8405598E+03,.1108215E+04,& - & .1015290E+04,.7713457E+03,.5746781E+03,.8404406E+03,.1107881E+04,& - & .1015286E+04,.7713522E+03,.5750445E+03,.8408353E+03,.1108489E+04,& - & .1015263E+04,.7713448E+03,.5752353E+03,.8410044E+03,.1108763E+04,& - & .1015276E+04,.7713348E+03,.5752379E+03,.8409611E+03,.1108729E+04,& - & .1015251E+04,.7713276E+03,.5750531E+03,.8407073E+03,.1108401E+04,& - & .1015261E+04,.7713452E+03,.5745201E+03,.8402523E+03,.1107669E+04,& - & .1015285E+04,.7713402E+03,.5749379E+03,.8407260E+03,.1108316E+04,& - & .1015244E+04,.7713261E+03,.5751964E+03,.8409694E+03,.1108716E+04,& - & .1015225E+04,.7713244E+03,.5752625E+03,.8409972E+03,.1108744E+04,& - & .1015265E+04,.7713303E+03,.5751375E+03,.8408146E+03,.1108557E+04/ - - data absb(1051:1175, 5) / & - & .1015244E+04,.7713264E+03,.5743548E+03,.8400510E+03,.1107362E+04,& - & .1015239E+04,.7713259E+03,.5748138E+03,.8406007E+03,.1108145E+04,& - & .1015247E+04,.7713243E+03,.5751348E+03,.8409159E+03,.1108592E+04,& - & .1015239E+04,.7713274E+03,.5752584E+03,.8410086E+03,.1108765E+04,& - & .1015225E+04,.7713165E+03,.5751971E+03,.8409024E+03,.1108626E+04,& - & .1015239E+04,.7713283E+03,.5741622E+03,.8398247E+03,.1107071E+04,& - & .1015242E+04,.7713198E+03,.5746895E+03,.8404515E+03,.1107922E+04,& - & .1015259E+04,.7713226E+03,.5750496E+03,.8408398E+03,.1108489E+04,& - & .1015245E+04,.7713144E+03,.5752404E+03,.8410002E+03,.1108765E+04,& - & .1015213E+04,.7713098E+03,.5752355E+03,.8409584E+03,.1108726E+04,& - & .1015251E+04,.7713192E+03,.5739542E+03,.8395683E+03,.1106711E+04,& - & .1015233E+04,.7713215E+03,.5745434E+03,.8402746E+03,.1107712E+04,& - & .1015233E+04,.7713191E+03,.5749555E+03,.8407368E+03,.1108359E+04,& - & .1015225E+04,.7713188E+03,.5752003E+03,.8409744E+03,.1108718E+04,& - & .1015230E+04,.7713144E+03,.5752584E+03,.8409937E+03,.1108785E+04,& - & .1015229E+04,.7713118E+03,.5737443E+03,.8392982E+03,.1106304E+04,& - & .1015223E+04,.7713138E+03,.5743800E+03,.8400877E+03,.1107435E+04,& - & .1015225E+04,.7713224E+03,.5748430E+03,.8406293E+03,.1108163E+04,& - & .1015242E+04,.7713219E+03,.5751451E+03,.8409290E+03,.1108631E+04,& - & .1015245E+04,.7713273E+03,.5752596E+03,.8410108E+03,.1108780E+04,& - & .1015256E+04,.7713168E+03,.5736529E+03,.8391840E+03,.1106202E+04,& - & .1015245E+04,.7713129E+03,.5743168E+03,.8400016E+03,.1107303E+04,& - & .1015228E+04,.7713181E+03,.5747952E+03,.8405779E+03,.1108104E+04,& - & .1015223E+04,.7713094E+03,.5751176E+03,.8408989E+03,.1108617E+04,& - & .1015221E+04,.7713103E+03,.5752541E+03,.8410111E+03,.1108805E+04/ - - data absb( 1:175, 6) / & - & .1154807E+04,.8742824E+03,.6044416E+03,.8875279E+03,.1172179E+04,& - & .1145735E+04,.8678557E+03,.6038007E+03,.8866634E+03,.1170524E+04,& - & .1138341E+04,.8618214E+03,.6031354E+03,.8856771E+03,.1169072E+04,& - & .1131676E+04,.8569035E+03,.6023105E+03,.8844938E+03,.1167566E+04,& - & .1125765E+04,.8523731E+03,.6012823E+03,.8831031E+03,.1165768E+04,& - & .1132423E+04,.8576942E+03,.6040145E+03,.8872823E+03,.1171938E+04,& - & .1125222E+04,.8521701E+03,.6034057E+03,.8864202E+03,.1170389E+04,& - & .1118840E+04,.8476932E+03,.6027501E+03,.8854305E+03,.1168930E+04,& - & .1113657E+04,.8434208E+03,.6018925E+03,.8841002E+03,.1167350E+04,& - & .1108930E+04,.8400398E+03,.6009245E+03,.8828407E+03,.1165664E+04,& - & .1114323E+04,.8441225E+03,.6036531E+03,.8870573E+03,.1171838E+04,& - & .1108136E+04,.8393878E+03,.6030685E+03,.8861976E+03,.1170255E+04,& - & .1103477E+04,.8360310E+03,.6024155E+03,.8851986E+03,.1168810E+04,& - & .1098878E+04,.8326282E+03,.6015839E+03,.8839936E+03,.1167258E+04,& - & .1095319E+04,.8298688E+03,.6005810E+03,.8825764E+03,.1165436E+04,& - & .1099193E+04,.8328782E+03,.6033501E+03,.8868553E+03,.1171666E+04,& - & .1094160E+04,.8293321E+03,.6027849E+03,.8859925E+03,.1170121E+04,& - & .1090881E+04,.8264769E+03,.6021240E+03,.8849814E+03,.1168673E+04,& - & .1087108E+04,.8233209E+03,.6012865E+03,.8837601E+03,.1167082E+04,& - & .1083860E+04,.8212156E+03,.6002431E+03,.8823316E+03,.1165266E+04,& - & .1087573E+04,.8238271E+03,.6030927E+03,.8866823E+03,.1171492E+04,& - & .1083841E+04,.8210481E+03,.6025442E+03,.8858138E+03,.1169959E+04,& - & .1080483E+04,.8185717E+03,.6018720E+03,.8847842E+03,.1168471E+04,& - & .1077525E+04,.8165982E+03,.6010297E+03,.8835474E+03,.1166895E+04,& - & .1075183E+04,.8146439E+03,.6000078E+03,.8821013E+03,.1165101E+04,& - & .1077583E+04,.8165170E+03,.6028710E+03,.8865245E+03,.1171303E+04,& - & .1074539E+04,.8142927E+03,.6023309E+03,.8856430E+03,.1169820E+04,& - & .1072137E+04,.8120580E+03,.6016533E+03,.8845555E+03,.1168326E+04,& - & .1069843E+04,.8106399E+03,.6007990E+03,.8833472E+03,.1166722E+04,& - & .1067730E+04,.8091125E+03,.5997668E+03,.8818852E+03,.1164922E+04,& - & .1069797E+04,.8107198E+03,.6026903E+03,.8863807E+03,.1171163E+04,& - & .1067434E+04,.8085376E+03,.6021520E+03,.8854952E+03,.1169596E+04,& - & .1065302E+04,.8070848E+03,.6014625E+03,.8844335E+03,.1168167E+04,& - & .1063248E+04,.8057185E+03,.6005661E+03,.8831570E+03,.1166538E+04,& - & .1061700E+04,.8046590E+03,.5995523E+03,.8816793E+03,.1164754E+04/ - - data absb(176:350, 6) / & - & .1063387E+04,.8058664E+03,.6025225E+03,.8862332E+03,.1170967E+04,& - & .1061291E+04,.8043546E+03,.6019839E+03,.8853313E+03,.1169477E+04,& - & .1059375E+04,.8029392E+03,.6012771E+03,.8842066E+03,.1167966E+04,& - & .1058118E+04,.8019047E+03,.6003971E+03,.8829591E+03,.1166269E+04,& - & .1057001E+04,.8008290E+03,.5993321E+03,.8814537E+03,.1164472E+04,& - & .1058126E+04,.8017380E+03,.6023731E+03,.8860941E+03,.1170779E+04,& - & .1056377E+04,.8006266E+03,.6018305E+03,.8851768E+03,.1169335E+04,& - & .1055112E+04,.7997092E+03,.6011088E+03,.8838887E+03,.1167803E+04,& - & .1053591E+04,.7985932E+03,.6002092E+03,.8827556E+03,.1166104E+04,& - & .1052710E+04,.7980450E+03,.5991296E+03,.8811895E+03,.1164303E+04,& - & .1053535E+04,.7985078E+03,.6022154E+03,.8859028E+03,.1170510E+04,& - & .1052649E+04,.7973207E+03,.6016135E+03,.8849596E+03,.1169037E+04,& - & .1051227E+04,.7967413E+03,.6008956E+03,.8838144E+03,.1167519E+04,& - & .1050475E+04,.7962211E+03,.5999630E+03,.8824642E+03,.1165766E+04,& - & .1049370E+04,.7952948E+03,.5988541E+03,.8809085E+03,.1163969E+04,& - & .1050325E+04,.7960009E+03,.6020625E+03,.8857073E+03,.1170186E+04,& - & .1049398E+04,.7952026E+03,.6014647E+03,.8847301E+03,.1168748E+04,& - & .1048230E+04,.7945935E+03,.6006799E+03,.8835488E+03,.1167182E+04,& - & .1047667E+04,.7940912E+03,.5997159E+03,.8821562E+03,.1165463E+04,& - & .1047042E+04,.7935326E+03,.5985744E+03,.8805687E+03,.1163647E+04,& - & .1047281E+04,.7937988E+03,.6019135E+03,.8855050E+03,.1169920E+04,& - & .1046440E+04,.7933166E+03,.6012784E+03,.8844912E+03,.1168471E+04,& - & .1045887E+04,.7928309E+03,.6004624E+03,.8832652E+03,.1166849E+04,& - & .1045297E+04,.7923255E+03,.5994646E+03,.8818357E+03,.1165063E+04,& - & .1044505E+04,.7918388E+03,.5982572E+03,.8802121E+03,.1163214E+04,& - & .1045195E+04,.7920747E+03,.6017576E+03,.8852861E+03,.1169584E+04,& - & .1044449E+04,.7917074E+03,.6010868E+03,.8840962E+03,.1168127E+04,& - & .1043910E+04,.7912987E+03,.6002298E+03,.8829669E+03,.1166499E+04,& - & .1043360E+04,.7907238E+03,.5992000E+03,.8814921E+03,.1164668E+04,& - & .1042953E+04,.7905956E+03,.5979889E+03,.8798344E+03,.1162852E+04,& - & .1043336E+04,.7906786E+03,.6015878E+03,.8850466E+03,.1169289E+04,& - & .1042560E+04,.7904597E+03,.6008783E+03,.8839470E+03,.1167776E+04,& - & .1042396E+04,.7901232E+03,.5999833E+03,.8826272E+03,.1166071E+04,& - & .1041865E+04,.7898279E+03,.5989107E+03,.8811075E+03,.1164265E+04,& - & .1041536E+04,.7894512E+03,.5976609E+03,.8794176E+03,.1162232E+04/ - - data absb(351:525, 6) / & - & .1041735E+04,.7896371E+03,.6014126E+03,.8847933E+03,.1168848E+04,& - & .1041235E+04,.7894095E+03,.6006558E+03,.8836405E+03,.1167384E+04,& - & .1040839E+04,.7890744E+03,.5997245E+03,.8822749E+03,.1165633E+04,& - & .1040637E+04,.7888720E+03,.5986096E+03,.8807131E+03,.1163845E+04,& - & .1040454E+04,.7886684E+03,.5973211E+03,.8789887E+03,.1161882E+04,& - & .1040668E+04,.7886417E+03,.6012280E+03,.8845275E+03,.1168593E+04,& - & .1040157E+04,.7885219E+03,.6004316E+03,.8833250E+03,.1166996E+04,& - & .1039836E+04,.7881981E+03,.5994554E+03,.8819140E+03,.1165226E+04,& - & .1039810E+04,.7880131E+03,.5982992E+03,.8802613E+03,.1163390E+04,& - & .1039396E+04,.7878410E+03,.5969813E+03,.8785538E+03,.1161371E+04,& - & .1039719E+04,.7879584E+03,.6010368E+03,.8841057E+03,.1168138E+04,& - & .1039383E+04,.7875535E+03,.6001922E+03,.8829897E+03,.1166558E+04,& - & .1038687E+04,.7875554E+03,.5991728E+03,.8815245E+03,.1164748E+04,& - & .1038748E+04,.7874938E+03,.5979743E+03,.8798787E+03,.1162892E+04,& - & .1038605E+04,.7873559E+03,.5966233E+03,.8780670E+03,.1160883E+04,& - & .1038508E+04,.7874554E+03,.6008293E+03,.8839425E+03,.1167803E+04,& - & .1038655E+04,.7872552E+03,.5999122E+03,.8825924E+03,.1166035E+04,& - & .1038537E+04,.7869660E+03,.5988787E+03,.8811226E+03,.1164305E+04,& - & .1038302E+04,.7868881E+03,.5976363E+03,.8794383E+03,.1162412E+04,& - & .1038080E+04,.7868277E+03,.5962613E+03,.8776832E+03,.1160344E+04,& - & .1037957E+04,.7867389E+03,.6006076E+03,.8836238E+03,.1167419E+04,& - & .1037919E+04,.7865797E+03,.5996797E+03,.8822650E+03,.1165664E+04,& - & .1037579E+04,.7865886E+03,.5985653E+03,.8807029E+03,.1163863E+04,& - & .1037883E+04,.7866633E+03,.5972822E+03,.8789799E+03,.1161882E+04,& - & .1037601E+04,.7866140E+03,.5958926E+03,.8772343E+03,.1159884E+04,& - & .1037461E+04,.7861854E+03,.6003749E+03,.8832869E+03,.1166982E+04,& - & .1037326E+04,.7862094E+03,.5994026E+03,.8818705E+03,.1165163E+04,& - & .1037061E+04,.7861750E+03,.5982418E+03,.8802656E+03,.1163356E+04,& - & .1037419E+04,.7862176E+03,.5969241E+03,.8785113E+03,.1161372E+04,& - & .1037145E+04,.7860371E+03,.5955189E+03,.8767759E+03,.1159373E+04,& - & .1037013E+04,.7863353E+03,.6001314E+03,.8829351E+03,.1166533E+04,& - & .1036952E+04,.7860923E+03,.5991081E+03,.8814656E+03,.1164747E+04,& - & .1036909E+04,.7858192E+03,.5979043E+03,.8797720E+03,.1162848E+04,& - & .1037101E+04,.7860878E+03,.5965532E+03,.8780077E+03,.1160772E+04,& - & .1037052E+04,.7858782E+03,.5951462E+03,.8762643E+03,.1158850E+04/ - - data absb(526:700, 6) / & - & .1036873E+04,.7857554E+03,.5999088E+03,.8825714E+03,.1166104E+04,& - & .1036902E+04,.7858253E+03,.5988157E+03,.8811019E+03,.1164303E+04,& - & .1036596E+04,.7858513E+03,.5976035E+03,.8794171E+03,.1162395E+04,& - & .1036614E+04,.7859297E+03,.5962301E+03,.8776601E+03,.1160341E+04,& - & .1036517E+04,.7857179E+03,.5947950E+03,.8759039E+03,.1158401E+04,& - & .1036789E+04,.7858044E+03,.5997786E+03,.8824249E+03,.1165869E+04,& - & .1036568E+04,.7858527E+03,.5986878E+03,.8808902E+03,.1164075E+04,& - & .1036290E+04,.7856385E+03,.5973952E+03,.8791810E+03,.1162152E+04,& - & .1036375E+04,.7857728E+03,.5960430E+03,.8773906E+03,.1160111E+04,& - & .1036584E+04,.7856477E+03,.5946509E+03,.8756676E+03,.1158142E+04,& - & .1036449E+04,.7856991E+03,.5997524E+03,.8823952E+03,.1165837E+04,& - & .1036546E+04,.7855390E+03,.5986607E+03,.8808071E+03,.1164007E+04,& - & .1036324E+04,.7856328E+03,.5973933E+03,.8791438E+03,.1162099E+04,& - & .1036443E+04,.7855912E+03,.5960116E+03,.8773979E+03,.1160087E+04,& - & .1036138E+04,.7855274E+03,.5946182E+03,.8754914E+03,.1158117E+04,& - & .1036317E+04,.7854628E+03,.5998802E+03,.8825810E+03,.1166071E+04,& - & .1036407E+04,.7855544E+03,.5988135E+03,.8810642E+03,.1164250E+04,& - & .1036350E+04,.7855655E+03,.5975664E+03,.8793754E+03,.1162334E+04,& - & .1036135E+04,.7854510E+03,.5961891E+03,.8776234E+03,.1160316E+04,& - & .1036293E+04,.7854258E+03,.5947873E+03,.8758601E+03,.1158372E+04,& - & .1036190E+04,.7854073E+03,.6000093E+03,.8827730E+03,.1166300E+04,& - & .1036230E+04,.7852517E+03,.5989682E+03,.8812856E+03,.1164529E+04,& - & .1035870E+04,.7851557E+03,.5977157E+03,.8796174E+03,.1162655E+04,& - & .1036108E+04,.7852461E+03,.5963833E+03,.8777687E+03,.1160603E+04,& - & .1035856E+04,.7854329E+03,.5949784E+03,.8761109E+03,.1158641E+04,& - & .1036008E+04,.7854391E+03,.6001409E+03,.8829635E+03,.1166558E+04,& - & .1035672E+04,.7852254E+03,.5991240E+03,.8815002E+03,.1164752E+04,& - & .1035771E+04,.7851997E+03,.5979225E+03,.8798541E+03,.1162890E+04,& - & .1035959E+04,.7853362E+03,.5965775E+03,.8780456E+03,.1160878E+04,& - & .1036077E+04,.7852519E+03,.5951718E+03,.8763106E+03,.1158912E+04,& - & .1036065E+04,.7853034E+03,.6003541E+03,.8832840E+03,.1166995E+04,& - & .1036122E+04,.7852033E+03,.5993846E+03,.8818706E+03,.1165191E+04,& - & .1035790E+04,.7853073E+03,.5982296E+03,.8802674E+03,.1163356E+04,& - & .1035706E+04,.7852523E+03,.5969107E+03,.8785167E+03,.1161368E+04,& - & .1035830E+04,.7852339E+03,.5955085E+03,.8767385E+03,.1159384E+04/ - - data absb(701:875, 6) / & - & .1035691E+04,.7852423E+03,.6005711E+03,.8836138E+03,.1167419E+04,& - & .1035908E+04,.7853193E+03,.5996475E+03,.8822488E+03,.1165664E+04,& - & .1035762E+04,.7850877E+03,.5985371E+03,.8806907E+03,.1163865E+04,& - & .1035976E+04,.7852798E+03,.5972262E+03,.8789734E+03,.1161918E+04,& - & .1035858E+04,.7852361E+03,.5958649E+03,.8772263E+03,.1159899E+04,& - & .1035722E+04,.7852842E+03,.6007813E+03,.8839238E+03,.1167804E+04,& - & .1035719E+04,.7850227E+03,.5999002E+03,.8826192E+03,.1166124E+04,& - & .1035600E+04,.7850937E+03,.5988393E+03,.8811085E+03,.1164303E+04,& - & .1035738E+04,.7852072E+03,.5975958E+03,.8794250E+03,.1162408E+04,& - & .1035762E+04,.7851633E+03,.5962227E+03,.8776696E+03,.1160304E+04,& - & .1035752E+04,.7852392E+03,.6010174E+03,.8841948E+03,.1168330E+04,& - & .1035945E+04,.7849973E+03,.6001604E+03,.8830466E+03,.1166677E+04,& - & .1035925E+04,.7851444E+03,.5991890E+03,.8815961E+03,.1164885E+04,& - & .1035817E+04,.7848046E+03,.5979682E+03,.8799616E+03,.1162996E+04,& - & .1035850E+04,.7847913E+03,.5966615E+03,.8782015E+03,.1161017E+04,& - & .1035638E+04,.7850513E+03,.6012543E+03,.8846111E+03,.1168741E+04,& - & .1035730E+04,.7851337E+03,.6004922E+03,.8834894E+03,.1167254E+04,& - & .1035445E+04,.7850312E+03,.5995458E+03,.8821086E+03,.1165365E+04,& - & .1035700E+04,.7851973E+03,.5984185E+03,.8805353E+03,.1163672E+04,& - & .1035789E+04,.7850241E+03,.5971269E+03,.8788018E+03,.1161708E+04,& - & .1035632E+04,.7849920E+03,.6014692E+03,.8850013E+03,.1169266E+04,& - & .1035755E+04,.7850265E+03,.6007663E+03,.8838589E+03,.1167803E+04,& - & .1035534E+04,.7848868E+03,.5998828E+03,.8825962E+03,.1166100E+04,& - & .1035605E+04,.7851301E+03,.5988206E+03,.8810847E+03,.1164299E+04,& - & .1035576E+04,.7849624E+03,.5975789E+03,.8793971E+03,.1162393E+04,& - & .1035448E+04,.7851267E+03,.6016773E+03,.8853457E+03,.1169825E+04,& - & .1035833E+04,.7851690E+03,.6010423E+03,.8842300E+03,.1168330E+04,& - & .1035814E+04,.7850287E+03,.6002225E+03,.8830915E+03,.1166729E+04,& - & .1035463E+04,.7849992E+03,.5992224E+03,.8816502E+03,.1164925E+04,& - & .1035596E+04,.7851550E+03,.5980443E+03,.8800202E+03,.1163074E+04,& - & .1035621E+04,.7849593E+03,.6018789E+03,.8857046E+03,.1170389E+04,& - & .1035804E+04,.7849848E+03,.6013182E+03,.8847579E+03,.1168918E+04,& - & .1035665E+04,.7849816E+03,.6005690E+03,.8836138E+03,.1167420E+04,& - & .1035718E+04,.7848933E+03,.5996475E+03,.8822566E+03,.1165667E+04,& - & .1035684E+04,.7848079E+03,.5985373E+03,.8806947E+03,.1163864E+04/ - - data absb(876:1050, 6) / & - & .1035396E+04,.7850994E+03,.6020651E+03,.8860430E+03,.1170959E+04,& - & .1035443E+04,.7850165E+03,.6015627E+03,.8851600E+03,.1169522E+04,& - & .1035416E+04,.7850543E+03,.6008940E+03,.8838713E+03,.1168065E+04,& - & .1035678E+04,.7850493E+03,.6000376E+03,.8828269E+03,.1166399E+04,& - & .1035656E+04,.7848387E+03,.5990054E+03,.8813440E+03,.1164574E+04,& - & .1035799E+04,.7849568E+03,.6022304E+03,.8863649E+03,.1171665E+04,& - & .1035662E+04,.7849150E+03,.6017841E+03,.8855314E+03,.1170121E+04,& - & .1035790E+04,.7851167E+03,.6011844E+03,.8845494E+03,.1168673E+04,& - & .1035751E+04,.7849497E+03,.6004028E+03,.8833168E+03,.1167013E+04,& - & .1035765E+04,.7850336E+03,.5994082E+03,.8819645E+03,.1165343E+04,& - & .1035223E+04,.7849097E+03,.6024415E+03,.8866859E+03,.1172339E+04,& - & .1035610E+04,.7848771E+03,.6019601E+03,.8858592E+03,.1170680E+04,& - & .1035292E+04,.7850288E+03,.6014302E+03,.8849412E+03,.1169154E+04,& - & .1035255E+04,.7849051E+03,.6007179E+03,.8837423E+03,.1167730E+04,& - & .1035724E+04,.7847308E+03,.5998232E+03,.8825148E+03,.1166003E+04,& - & .1035548E+04,.7850328E+03,.6026138E+03,.8870664E+03,.1173037E+04,& - & .1035703E+04,.7849473E+03,.6021374E+03,.8861617E+03,.1171252E+04,& - & .1035663E+04,.7850676E+03,.6016439E+03,.8852969E+03,.1169745E+04,& - & .1035770E+04,.7849775E+03,.6010002E+03,.8842177E+03,.1168267E+04,& - & .1035731E+04,.7851009E+03,.6001688E+03,.8830217E+03,.1166634E+04,& - & .1035751E+04,.7850608E+03,.6027803E+03,.8874485E+03,.1173984E+04,& - & .1035764E+04,.7849860E+03,.6023128E+03,.8864542E+03,.1171860E+04,& - & .1035482E+04,.7850930E+03,.6018352E+03,.8856260E+03,.1170255E+04,& - & .1035535E+04,.7849801E+03,.6012570E+03,.8846634E+03,.1168815E+04,& - & .1035673E+04,.7849343E+03,.6004942E+03,.8834988E+03,.1167257E+04,& - & .1035524E+04,.7848552E+03,.6029106E+03,.8880716E+03,.1174957E+04,& - & .1035658E+04,.7846826E+03,.6024834E+03,.8867342E+03,.1172519E+04,& - & .1035489E+04,.7848135E+03,.6020058E+03,.8859421E+03,.1170818E+04,& - & .1035424E+04,.7848886E+03,.6014905E+03,.8850368E+03,.1169362E+04,& - & .1035663E+04,.7850003E+03,.6007966E+03,.8839492E+03,.1167867E+04,& - & .1035504E+04,.7848111E+03,.6031050E+03,.8887172E+03,.1175944E+04,& - & .1035279E+04,.7847971E+03,.6026411E+03,.8871385E+03,.1173254E+04,& - & .1035415E+04,.7850072E+03,.6021673E+03,.8862095E+03,.1171363E+04,& - & .1035656E+04,.7850409E+03,.6016799E+03,.8853554E+03,.1169825E+04,& - & .1035406E+04,.7848736E+03,.6010491E+03,.8843357E+03,.1168391E+04/ - - data absb(1051:1175, 6) / & - & .1035713E+04,.7849729E+03,.6032946E+03,.8893995E+03,.1176941E+04,& - & .1035444E+04,.7849707E+03,.6027864E+03,.8875237E+03,.1174025E+04,& - & .1035565E+04,.7850045E+03,.6023190E+03,.8864702E+03,.1171867E+04,& - & .1035712E+04,.7849606E+03,.6018460E+03,.8856449E+03,.1170317E+04,& - & .1035707E+04,.7850798E+03,.6012695E+03,.8846865E+03,.1168843E+04,& - & .1035705E+04,.7849167E+03,.6035391E+03,.8900967E+03,.1177953E+04,& - & .1035730E+04,.7849972E+03,.6028979E+03,.8880295E+03,.1174870E+04,& - & .1035405E+04,.7849160E+03,.6024731E+03,.8867542E+03,.1172461E+04,& - & .1035544E+04,.7850359E+03,.6019902E+03,.8859187E+03,.1170739E+04,& - & .1035719E+04,.7850739E+03,.6014757E+03,.8850119E+03,.1169315E+04,& - & .1035505E+04,.7850447E+03,.6039271E+03,.8909936E+03,.1179187E+04,& - & .1035517E+04,.7849136E+03,.6030826E+03,.8886380E+03,.1175823E+04,& - & .1035643E+04,.7849538E+03,.6026205E+03,.8870923E+03,.1173152E+04,& - & .1035536E+04,.7849523E+03,.6021490E+03,.8861784E+03,.1171261E+04,& - & .1035534E+04,.7850334E+03,.6016601E+03,.8853177E+03,.1169773E+04,& - & .1035546E+04,.7850318E+03,.6043242E+03,.8919185E+03,.1180418E+04,& - & .1035602E+04,.7849911E+03,.6032555E+03,.8892747E+03,.1176756E+04,& - & .1035555E+04,.7849176E+03,.6027602E+03,.8874056E+03,.1173878E+04,& - & .1035566E+04,.7849074E+03,.6022939E+03,.8864253E+03,.1171787E+04,& - & .1035501E+04,.7847965E+03,.6018145E+03,.8855936E+03,.1170187E+04,& - & .1035450E+04,.7849937E+03,.6045469E+03,.8923132E+03,.1180947E+04,& - & .1035470E+04,.7849930E+03,.6033415E+03,.8895406E+03,.1177165E+04,& - & .1035648E+04,.7849151E+03,.6028185E+03,.8876106E+03,.1174216E+04,& - & .1035655E+04,.7850350E+03,.6023184E+03,.8865228E+03,.1172007E+04,& - & .1035589E+04,.7850346E+03,.6018757E+03,.8856974E+03,.1170389E+04/ - -!........................................! - end module module_radsw_kgb28 ! -!========================================! - - -!========================================! - module module_radsw_kgb29 ! -!........................................! -! -! ********* the original program descriptions ********* ! -! ! -! originally by j.delamere, atmospheric & environmental research. ! -! revision: 2.4 ! -! band 29: 820-2600 cm-1 (low - h2o; high - co2) ! -! reformatted for f90 by jjmorcrette, ecmwf ! -! ! -! this table has been re-generated for reduced number of g-point ! -! by y.t.hou, ncep ! -! ! -! ********* ********* end description ********* ********* ! -! - use machine, only : kind_phys - use module_radsw_parameters, only : NG29 - -! - implicit none -! - private -! - integer, public :: MSA29, MSB29, MSF29, MFR29 - parameter (MSA29=65, MSB29=235, MSF29=10, MFR29=4) - - real (kind=kind_phys), public :: forref(MFR29,NG29), & - & absa(MSA29,NG29), absb(MSB29,NG29), selfref(MSF29,NG29), & - & absh2o(NG29), absco2(NG29) - -! --- rayleigh extinction coefficient at v = 2200 cm-1. - real (kind=kind_phys), parameter, public :: rayl = 9.30e-11 - -! --- h2o - data absh2o (1:12) / .2995080E-03,.3950120E-02,& - & .1493160E-01,.3243840E-01,.9440181E-01,.1006542E+01,.9383158E+01,& - & .2134138E+00,.2155620E+00,.2180870E+00,.2209180E+00,.2185460E+00/ - -! --- co2 - data absco2 (1:12) / .2900730E-05,.2123820E-04,& - & .1030320E-03,.1864810E-03,.5136065E-03,.2118687E-01,.4146680E+01,& - & .4301567E+02,.1641290E+03,.8322820E+03,.4995020E+04,.1267810E+05/ - -! the array absa(65,NG29) (ka(5,13,NG29)) contains absorption coefs at -! the 16 chosen g-values for a range of pressure levels> ~100mb, -! temperatures, and binary species parameters (see taumol.f for definition). -! the first index in the array, js, runs from 1 to 9, and corresponds to -! different values of the binary species parameter. for instance, -! js=1 refers to dry air, js = 2 corresponds to the paramter value 1/8, -! js = 3 corresponds to the parameter value 2/8, etc. the second index -! in the array, jt, which runs from 1 to 5, corresponds to different -! temperatures. more specifically, jt = 3 means that the data are for -! the reference temperature tref for this pressure level, jt = 2 refers -! to tref-15, jt = 1 is for tref-30, jt = 4 is for tref+15, and jt = 5 -! is for tref+30. the third index, jp, runs from 1 to 13 and refers -! to the jpth reference pressure level (see taumol.f for these levels -! in mb). the fourth index, ig, goes from 1 to 12, and indicates -! which g-interval the absorption coefficients are for. - - data absa( 1: 65, 1) / & - & .1156500E-03,.1012300E-03,.9080400E-04,.8228200E-04,.7108300E-04,& - & .9643400E-04,.8283000E-04,.7236600E-04,.6180300E-04,.5249700E-04,& - & .6453900E-04,.5665900E-04,.4660500E-04,.3981500E-04,.3711800E-04,& - & .3441700E-04,.2711300E-04,.2536200E-04,.3034500E-04,.3627500E-04,& - & .1226000E-04,.1585600E-04,.2083400E-04,.2736300E-04,.3611400E-04,& - & .1022100E-04,.1459800E-04,.1969500E-04,.2597600E-04,.3370200E-04,& - & .9756300E-05,.1380900E-04,.2023100E-04,.2723800E-04,.3611000E-04,& - & .1406200E-04,.1958700E-04,.2706900E-04,.3693700E-04,.4941500E-04,& - & .3637100E-04,.4812200E-04,.6158600E-04,.7764700E-04,.9989700E-04,& - & .9920300E-04,.1284200E-03,.1658800E-03,.2083400E-03,.2600000E-03,& - & .1323300E-03,.1731800E-03,.2205900E-03,.2890400E-03,.3606200E-03,& - & .1337900E-03,.1748400E-03,.2368700E-03,.3028600E-03,.3750400E-03,& - & .1174000E-03,.1566700E-03,.2096200E-03,.2676800E-03,.3348500E-03/ - - data absa( 1: 65, 2) / & - & .1024600E-03,.1045000E-03,.9738300E-04,.9639800E-04,.1054900E-03,& - & .1058900E-03,.1024000E-03,.9580100E-04,.9850900E-04,.1199300E-03,& - & .9405400E-04,.8700900E-04,.1094100E-03,.1348600E-03,.1591800E-03,& - & .1188300E-03,.1423600E-03,.1663600E-03,.1823500E-03,.1978500E-03,& - & .1780000E-03,.1934700E-03,.2097700E-03,.2273000E-03,.2511100E-03,& - & .2224300E-03,.2415700E-03,.2656700E-03,.2854900E-03,.3072300E-03,& - & .2924800E-03,.3224200E-03,.3463500E-03,.3791500E-03,.4080300E-03,& - & .4338600E-03,.4861100E-03,.5268100E-03,.5681200E-03,.6064200E-03,& - & .8910900E-03,.1034500E-02,.1179400E-02,.1304500E-02,.1430300E-02,& - & .2153800E-02,.2445900E-02,.2732900E-02,.3093200E-02,.3525300E-02,& - & .2927200E-02,.3267600E-02,.3635300E-02,.4006200E-02,.4544100E-02,& - & .3076200E-02,.3436500E-02,.3814600E-02,.4155600E-02,.4716400E-02,& - & .2780800E-02,.3111400E-02,.3438300E-02,.3795400E-02,.4257600E-02/ - - data absa( 1: 65, 3) / & - & .2404200E-03,.3271900E-03,.4437000E-03,.5683600E-03,.7035700E-03,& - & .2330300E-03,.3190100E-03,.4192600E-03,.5240000E-03,.6236500E-03,& - & .3505000E-03,.4215800E-03,.4749000E-03,.5339000E-03,.6041100E-03,& - & .4995400E-03,.5306700E-03,.5633800E-03,.6085900E-03,.6656900E-03,& - & .6690800E-03,.6972700E-03,.7289800E-03,.7675600E-03,.8035800E-03,& - & .8863400E-03,.9285300E-03,.9685600E-03,.1010100E-02,.1055600E-02,& - & .1165900E-02,.1235500E-02,.1323800E-02,.1388900E-02,.1449100E-02,& - & .1748500E-02,.1822300E-02,.1941100E-02,.2070500E-02,.2202500E-02,& - & .4244200E-02,.4356100E-02,.4506100E-02,.4750500E-02,.5035800E-02,& - & .1094000E-01,.1149900E-01,.1190600E-01,.1257000E-01,.1280300E-01,& - & .1428700E-01,.1501000E-01,.1558100E-01,.1605400E-01,.1660900E-01,& - & .1485600E-01,.1554600E-01,.1607400E-01,.1647800E-01,.1705700E-01,& - & .1325700E-01,.1383400E-01,.1415500E-01,.1472300E-01,.1509500E-01/ - - data absa( 1: 65, 4) / & - & .2439100E-02,.2872000E-02,.3349700E-02,.3892600E-02,.4505400E-02,& - & .2250600E-02,.2600400E-02,.3000200E-02,.3449000E-02,.3957900E-02,& - & .2215300E-02,.2571100E-02,.2932000E-02,.3333000E-02,.3772800E-02,& - & .2248300E-02,.2544500E-02,.2874500E-02,.3248400E-02,.3655400E-02,& - & .2338800E-02,.2598500E-02,.2891400E-02,.3237700E-02,.3611300E-02,& - & .2466900E-02,.2657900E-02,.2883400E-02,.3153800E-02,.3459300E-02,& - & .3253600E-02,.3341300E-02,.3437500E-02,.3590500E-02,.3801000E-02,& - & .5122800E-02,.5196700E-02,.5282000E-02,.5344600E-02,.5379700E-02,& - & .1302900E-01,.1306500E-01,.1289100E-01,.1284800E-01,.1277700E-01,& - & .2991100E-01,.3011700E-01,.2834000E-01,.2732100E-01,.2748500E-01,& - & .3666300E-01,.3687700E-01,.3468800E-01,.3300400E-01,.3243700E-01,& - & .3728200E-01,.3777500E-01,.3491000E-01,.3346300E-01,.3307400E-01,& - & .3341200E-01,.3296100E-01,.3032300E-01,.2943700E-01,.2957200E-01/ - - data absa( 1: 65, 5) / & - & .5737669E-01,.6072679E-01,.6409123E-01,.6738949E-01,.7052420E-01,& - & .5012852E-01,.5294581E-01,.5563579E-01,.5843403E-01,.6127801E-01,& - & .4354787E-01,.4609744E-01,.4874155E-01,.5138444E-01,.5397080E-01,& - & .3827336E-01,.4064492E-01,.4287087E-01,.4511010E-01,.4735934E-01,& - & .3418365E-01,.3615136E-01,.3817782E-01,.4009673E-01,.4202725E-01,& - & .3135060E-01,.3301048E-01,.3465038E-01,.3632036E-01,.3815047E-01,& - & .2990607E-01,.3131211E-01,.3276228E-01,.3421907E-01,.3588465E-01,& - & .3047960E-01,.3187197E-01,.3323626E-01,.3465826E-01,.3619150E-01,& - & .4306469E-01,.4376339E-01,.4465622E-01,.4556160E-01,.4646970E-01,& - & .8678394E-01,.8535671E-01,.8559355E-01,.8558578E-01,.8553480E-01,& - & .1070789E+00,.1044012E+00,.1040583E+00,.1040024E+00,.1036748E+00,& - & .1081364E+00,.1052681E+00,.1050326E+00,.1048529E+00,.1046392E+00,& - & .9356527E-01,.9192786E-01,.9227488E-01,.9212577E-01,.9173403E-01/ - - data absa( 1: 65, 6) / & - & .5500343E+00,.5549109E+00,.5588616E+00,.5629779E+00,.5667564E+00,& - & .4994114E+00,.5037790E+00,.5100008E+00,.5169978E+00,.5240736E+00,& - & .5046611E+00,.5105279E+00,.5158277E+00,.5226637E+00,.5303378E+00,& - & .5302528E+00,.5393967E+00,.5458119E+00,.5537515E+00,.5618237E+00,& - & .5411203E+00,.5556023E+00,.5677558E+00,.5802746E+00,.5898268E+00,& - & .5252486E+00,.5447502E+00,.5651635E+00,.5824674E+00,.6014351E+00,& - & .5100890E+00,.5352169E+00,.5583076E+00,.5833005E+00,.6058393E+00,& - & .5180699E+00,.5497814E+00,.5808233E+00,.6108346E+00,.6398736E+00,& - & .6522488E+00,.6891866E+00,.7325459E+00,.7797722E+00,.8260960E+00,& - & .9640811E+00,.1024659E+01,.1093085E+01,.1161786E+01,.1235652E+01,& - & .1047820E+01,.1114446E+01,.1186733E+01,.1258652E+01,.1334983E+01,& - & .1011033E+01,.1074570E+01,.1140350E+01,.1211241E+01,.1280754E+01,& - & .9007538E+00,.9506568E+00,.1005449E+01,.1058464E+01,.1116021E+01/ - - data absa( 1: 65, 7) / & - & .4649358E+01,.4659442E+01,.4675452E+01,.4685713E+01,.4692899E+01,& - & .4599705E+01,.4611058E+01,.4611629E+01,.4612755E+01,.4607683E+01,& - & .4619900E+01,.4611704E+01,.4611644E+01,.4599592E+01,.4592568E+01,& - & .4687320E+01,.4681368E+01,.4668829E+01,.4653209E+01,.4637546E+01,& - & .4851120E+01,.4815554E+01,.4796404E+01,.4771634E+01,.4773910E+01,& - & .5130952E+01,.5103158E+01,.5076979E+01,.5135909E+01,.5190723E+01,& - & .5614324E+01,.5655787E+01,.5731968E+01,.5785423E+01,.5820571E+01,& - & .6802466E+01,.6894140E+01,.6919677E+01,.6955254E+01,.6983671E+01,& - & .9510364E+01,.9545777E+01,.9589682E+01,.9667897E+01,.9623013E+01,& - & .9447407E+01,.9253876E+01,.9037997E+01,.8820753E+01,.8587497E+01,& - & .9261615E+01,.9040240E+01,.8802081E+01,.8566366E+01,.8317559E+01,& - & .9408423E+01,.9193385E+01,.8974202E+01,.8739541E+01,.8508727E+01,& - & .9731443E+01,.9563647E+01,.9382645E+01,.9207221E+01,.9018631E+01/ - - data absa( 1: 65, 8) / & - & .1544733E+02,.1554976E+02,.1552859E+02,.1550737E+02,.1552125E+02,& - & .1738703E+02,.1741986E+02,.1747727E+02,.1744027E+02,.1739669E+02,& - & .1987281E+02,.1989151E+02,.1998931E+02,.1999712E+02,.1998411E+02,& - & .2258389E+02,.2260003E+02,.2268696E+02,.2264651E+02,.2270608E+02,& - & .2504125E+02,.2510226E+02,.2517712E+02,.2519913E+02,.2495283E+02,& - & .2747847E+02,.2717648E+02,.2695792E+02,.2626421E+02,.2537969E+02,& - & .2961485E+02,.2896370E+02,.2795835E+02,.2715755E+02,.2643866E+02,& - & .2732825E+02,.2612667E+02,.2538192E+02,.2458336E+02,.2384624E+02,& - & .5753079E+01,.4812161E+01,.3663267E+01,.2188469E+01,.1578210E+01,& - & .1936683E+00,.1796201E+00,.1673070E+00,.1564801E+00,.1466219E+00,& - & .2745909E+00,.2544928E+00,.2369058E+00,.2210443E+00,.2070125E+00,& - & .2913703E+00,.2698520E+00,.2503822E+00,.2335086E+00,.2184884E+00,& - & .2490616E+00,.2300611E+00,.2134111E+00,.1990053E+00,.1862957E+00/ - - data absa( 1: 65, 9) / & - & .2967200E+02,.2929100E+02,.2919100E+02,.2917000E+02,.2911600E+02,& - & .2471300E+02,.2496500E+02,.2503900E+02,.2535500E+02,.2565000E+02,& - & .3051000E+02,.3116600E+02,.3066300E+02,.3102100E+02,.3090100E+02,& - & .3869500E+02,.3892200E+02,.3874100E+02,.3920400E+02,.3882600E+02,& - & .4511800E+02,.4433700E+02,.4366400E+02,.4326700E+02,.4352400E+02,& - & .3465200E+02,.3518200E+02,.3533900E+02,.3534000E+02,.3589900E+02,& - & .1880100E+02,.1859800E+02,.1885500E+02,.1881900E+02,.1905200E+02,& - & .1229700E-01,.1142500E-01,.1067000E-01,.9999400E-02,.9413900E-02,& - & .4682100E-01,.4336100E-01,.4036800E-01,.3775200E-01,.3549300E-01,& - & .1981700E+00,.1830300E+00,.1700200E+00,.1588300E+00,.1493300E+00,& - & .2814500E+00,.2599500E+00,.2418100E+00,.2266000E+00,.2132600E+00,& - & .2951000E+00,.2729400E+00,.2551900E+00,.2394700E+00,.2255100E+00,& - & .2483000E+00,.2307400E+00,.2155600E+00,.2022600E+00,.1902900E+00/ - - data absa( 1: 65,10) / & - & .4716800E+02,.4689000E+02,.4661200E+02,.4635300E+02,.4608800E+02,& - & .4777100E+02,.4698000E+02,.4644500E+02,.4582800E+02,.4543700E+02,& - & .4294600E+02,.4265200E+02,.4379100E+02,.4323700E+02,.4410400E+02,& - & .3095700E+02,.3009800E+02,.3005500E+02,.2955500E+02,.2990200E+02,& - & .2839700E+01,.3857200E+01,.4290600E+01,.4709100E+01,.4813500E+01,& - & .3697800E-02,.3459100E-02,.3252400E-02,.3064900E-02,.2901800E-02,& - & .6173300E-02,.5758900E-02,.5392500E-02,.5074200E-02,.4783500E-02,& - & .1239000E-01,.1152600E-01,.1076600E-01,.1009600E-01,.9501000E-02,& - & .4710500E-01,.4364800E-01,.4066500E-01,.3805400E-01,.3572200E-01,& - & .1991500E+00,.1841200E+00,.1709900E+00,.1595700E+00,.1494800E+00,& - & .2828000E+00,.2612400E+00,.2426600E+00,.2264500E+00,.2121400E+00,& - & .2989100E+00,.2761300E+00,.2564800E+00,.2392700E+00,.2242300E+00,& - & .2542100E+00,.2348400E+00,.2180900E+00,.2034700E+00,.1905700E+00/ - - data absa( 1: 65,11) / & - & .6499400E+02,.6428300E+02,.6375500E+02,.6340700E+02,.6328700E+02,& - & .7826600E+02,.7736400E+02,.7672200E+02,.7628500E+02,.7599200E+02,& - & .4171000E+02,.3837900E+02,.3507600E+02,.3541800E+02,.3330600E+02,& - & .1417000E-02,.1340100E-02,.1271600E-02,.1207300E-02,.1153500E-02,& - & .2365900E-02,.2226100E-02,.2104200E-02,.1995000E-02,.1897000E-02,& - & .3743200E-02,.3510500E-02,.3300600E-02,.3122200E-02,.2952100E-02,& - & .6240800E-02,.5825800E-02,.5478200E-02,.5159400E-02,.4876700E-02,& - & .1252200E-01,.1165200E-01,.1092200E-01,.1026500E-01,.9667200E-02,& - & .4754500E-01,.4415200E-01,.4125100E-01,.3866600E-01,.3635800E-01,& - & .2009700E+00,.1859200E+00,.1734100E+00,.1620300E+00,.1523500E+00,& - & .2849900E+00,.2642800E+00,.2458500E+00,.2298000E+00,.2157500E+00,& - & .3017200E+00,.2792900E+00,.2598000E+00,.2430600E+00,.2278900E+00,& - & .2565500E+00,.2373100E+00,.2209200E+00,.2063900E+00,.1936700E+00/ - - data absa( 1: 65,12) / & - & .8081000E+02,.8109900E+02,.8119000E+02,.8110700E+02,.8098900E+02,& - & .9931900E+02,.9970800E+02,.9982200E+02,.9987100E+02,.9999300E+02,& - & .4692700E+02,.5431600E+02,.5735500E+02,.5371500E+02,.5280200E+02,& - & .1280200E-02,.1202700E-02,.1138600E-02,.1086600E-02,.1052500E-02,& - & .2167500E-02,.2071500E-02,.1942200E-02,.1840200E-02,.1768100E-02,& - & .3470700E-02,.3279600E-02,.3098600E-02,.2924600E-02,.2803400E-02,& - & .5865900E-02,.5531000E-02,.5182000E-02,.4882900E-02,.4678400E-02,& - & .1187500E-01,.1118300E-01,.1043800E-01,.9803800E-02,.9366500E-02,& - & .4551900E-01,.4285000E-01,.3971500E-01,.3744700E-01,.3536900E-01,& - & .1939200E+00,.1810800E+00,.1681700E+00,.1588300E+00,.1486400E+00,& - & .2783000E+00,.2571500E+00,.2410000E+00,.2259500E+00,.2132100E+00,& - & .2953300E+00,.2742200E+00,.2563600E+00,.2393600E+00,.2265800E+00,& - & .2531000E+00,.2353500E+00,.2185500E+00,.2055200E+00,.1929300E+00/ - -! the array absb(235,12) (kb(5,13:59,12)) contains absorption coefs at -! the 16 chosen g-values for a range of pressure levels < ~100mb and -! temperatures. the first index in the array, jt, which runs from 1 to 5, -! corresponds to different temperatures. more specifically, jt = 3 means -! that the data are for the reference temperature tref for this pressure -! level, jt = 2 refers to the temperature tref-15, jt = 1 is for -! tref-30, jt = 4 is for tref+15, and jt = 5 is for tref+30. -! the second index, jp, runs from 13 to 59 and refers to the jpth -! reference pressure level (see taumol.f for the value of these -! pressure levels in mb). the third index, ig, goes from 1 to 12, -! and tells us which g-interval the absorption coefficients are for. - - data absb( 1:120, 1) / & - & .1837900E-05,.2329600E-05,.2900700E-05,.3590200E-05,.4343700E-05,& - & .1591900E-05,.1983200E-05,.2472000E-05,.3068300E-05,.3725300E-05,& - & .1385000E-05,.1711500E-05,.2122500E-05,.2629200E-05,.3194500E-05,& - & .1189600E-05,.1468000E-05,.1814200E-05,.2253700E-05,.2728400E-05,& - & .1022800E-05,.1259700E-05,.1553200E-05,.1927200E-05,.2316300E-05,& - & .8824300E-06,.1083500E-05,.1331600E-05,.1660300E-05,.1980800E-05,& - & .7567700E-06,.9292500E-06,.1140100E-05,.1410700E-05,.1690100E-05,& - & .6461400E-06,.7936100E-06,.9735300E-06,.1196400E-05,.1441400E-05,& - & .5532300E-06,.6758000E-06,.8264700E-06,.1013700E-05,.1231800E-05,& - & .4771900E-06,.5814900E-06,.7106000E-06,.8700500E-06,.1060500E-05,& - & .4112800E-06,.5008000E-06,.6110400E-06,.7534700E-06,.9120000E-06,& - & .3530600E-06,.4286000E-06,.5232000E-06,.6515600E-06,.7812200E-06,& - & .3036300E-06,.3673100E-06,.4467300E-06,.5609700E-06,.6679100E-06,& - & .2607300E-06,.3153700E-06,.3873800E-06,.4821000E-06,.5738200E-06,& - & .2230300E-06,.2698600E-06,.3362800E-06,.4116100E-06,.4872200E-06,& - & .1895400E-06,.2295200E-06,.2879700E-06,.3516600E-06,.4144000E-06,& - & .1610600E-06,.1943000E-06,.2466100E-06,.2981500E-06,.3515100E-06,& - & .1363000E-06,.1652800E-06,.2092200E-06,.2519300E-06,.2991300E-06,& - & .1150400E-06,.1427600E-06,.1780700E-06,.2148200E-06,.2545100E-06,& - & .9698000E-07,.1221500E-06,.1515900E-06,.1817900E-06,.2151500E-06,& - & .8159800E-07,.1031500E-06,.1273000E-06,.1519000E-06,.1809300E-06,& - & .6770000E-07,.8597000E-07,.1055900E-06,.1260800E-06,.1500600E-06,& - & .5517700E-07,.6951900E-07,.8596700E-07,.1022300E-06,.1214700E-06,& - & .4392400E-07,.5439500E-07,.6799800E-07,.8114200E-07,.9571700E-07/ - - data absb(121:235, 1) / & - & .3446900E-07,.4103600E-07,.5257500E-07,.6311700E-07,.7430100E-07,& - & .2677700E-07,.3173400E-07,.4055500E-07,.4903200E-07,.5765300E-07,& - & .2067000E-07,.2472100E-07,.3068500E-07,.3787300E-07,.4455500E-07,& - & .1586000E-07,.1903200E-07,.2261200E-07,.2884500E-07,.3424600E-07,& - & .1212900E-07,.1460300E-07,.1735700E-07,.2185100E-07,.2634600E-07,& - & .9231900E-08,.1119900E-07,.1336500E-07,.1617400E-07,.2001900E-07,& - & .6928900E-08,.8453700E-08,.1015900E-07,.1199200E-07,.1494000E-07,& - & .5154600E-08,.6338000E-08,.7659300E-08,.9056200E-08,.1071600E-07,& - & .3833500E-08,.4708500E-08,.5721900E-08,.6814800E-08,.7951800E-08,& - & .2858300E-08,.3472400E-08,.4244700E-08,.5088800E-08,.5949400E-08,& - & .2094500E-08,.2541800E-08,.3105800E-08,.3749400E-08,.4427400E-08,& - & .1516400E-08,.1856000E-08,.2262800E-08,.2737100E-08,.3277300E-08,& - & .1091600E-08,.1346500E-08,.1638700E-08,.1974000E-08,.2386500E-08,& - & .7832400E-09,.9836100E-09,.1197700E-08,.1451700E-08,.1745700E-08,& - & .5726300E-09,.7178600E-09,.8768900E-09,.1070500E-08,.1288100E-08,& - & .4157400E-09,.5126400E-09,.6415200E-09,.7831500E-09,.9470500E-09,& - & .2994000E-09,.3683600E-09,.4588600E-09,.5640500E-09,.6916600E-09,& - & .2261700E-09,.2739500E-09,.3375400E-09,.4209500E-09,.5154400E-09,& - & .1748300E-09,.2084500E-09,.2554600E-09,.3181700E-09,.3911900E-09,& - & .1349600E-09,.1593000E-09,.1938000E-09,.2386100E-09,.2977000E-09,& - & .1040600E-09,.1224700E-09,.1474900E-09,.1807800E-09,.2259700E-09,& - & .8134500E-10,.9481600E-10,.1132900E-09,.1383200E-09,.1716100E-09,& - & .6715900E-10,.7831200E-10,.9474500E-10,.1154400E-09,.1444200E-09/ - - data absb( 1:120, 2) / & - & .1665400E-04,.1872800E-04,.2123800E-04,.2449100E-04,.2903800E-04,& - & .1563600E-04,.1757400E-04,.1991800E-04,.2367100E-04,.2723700E-04,& - & .1485300E-04,.1662900E-04,.1970000E-04,.2260400E-04,.2558600E-04,& - & .1351900E-04,.1592300E-04,.1828900E-04,.2053000E-04,.2279900E-04,& - & .1241100E-04,.1443900E-04,.1643100E-04,.1823500E-04,.2010900E-04,& - & .1126700E-04,.1288000E-04,.1442900E-04,.1600500E-04,.1753800E-04,& - & .1002500E-04,.1133200E-04,.1255000E-04,.1385300E-04,.1510300E-04,& - & .8634200E-05,.9745500E-05,.1077800E-04,.1189800E-04,.1278900E-04,& - & .7400400E-05,.8310700E-05,.9163300E-05,.1007100E-04,.1067400E-04,& - & .6370000E-05,.7054900E-05,.7827100E-05,.8517000E-05,.9002200E-05,& - & .5440400E-05,.6015600E-05,.6639300E-05,.7132000E-05,.7500700E-05,& - & .4599700E-05,.5071800E-05,.5571300E-05,.5945500E-05,.6211800E-05,& - & .3874500E-05,.4261700E-05,.4647900E-05,.4929700E-05,.5163800E-05,& - & .3248800E-05,.3559200E-05,.3868500E-05,.4075900E-05,.4309200E-05,& - & .2699500E-05,.2960100E-05,.3206500E-05,.3366600E-05,.3560900E-05,& - & .2235900E-05,.2442900E-05,.2640800E-05,.2775200E-05,.2929300E-05,& - & .1848700E-05,.2008900E-05,.2166800E-05,.2279300E-05,.2402900E-05,& - & .1529100E-05,.1658900E-05,.1773300E-05,.1870600E-05,.1958400E-05,& - & .1255400E-05,.1358900E-05,.1443600E-05,.1519500E-05,.1592800E-05,& - & .1024800E-05,.1104600E-05,.1171600E-05,.1228800E-05,.1291600E-05,& - & .8327200E-06,.8912000E-06,.9503600E-06,.9904000E-06,.1040900E-05,& - & .6751800E-06,.7209700E-06,.7685400E-06,.8024600E-06,.8391200E-06,& - & .5357700E-06,.5787000E-06,.6171500E-06,.6498700E-06,.6722000E-06,& - & .4240200E-06,.4582500E-06,.4930700E-06,.5200500E-06,.5402900E-06/ - - data absb(121:235, 2) / & - & .3341900E-06,.3621300E-06,.3891100E-06,.4135900E-06,.4317700E-06,& - & .2624000E-06,.2835500E-06,.3053000E-06,.3288100E-06,.3461700E-06,& - & .2046800E-06,.2224500E-06,.2398000E-06,.2577600E-06,.2742400E-06,& - & .1607000E-06,.1747800E-06,.1885600E-06,.2023000E-06,.2180100E-06,& - & .1258300E-06,.1368000E-06,.1485100E-06,.1591700E-06,.1718400E-06,& - & .9849400E-07,.1063900E-06,.1163400E-06,.1250000E-06,.1349000E-06,& - & .7519600E-07,.8280900E-07,.9009500E-07,.9795200E-07,.1050900E-06,& - & .5730500E-07,.6378700E-07,.6922700E-07,.7563500E-07,.8168700E-07,& - & .4296500E-07,.4824500E-07,.5334600E-07,.5806100E-07,.6312000E-07,& - & .3104800E-07,.3645700E-07,.4051400E-07,.4455700E-07,.4855000E-07,& - & .2309400E-07,.2635600E-07,.3044300E-07,.3395400E-07,.3678900E-07,& - & .1685800E-07,.1940200E-07,.2244900E-07,.2540100E-07,.2825400E-07,& - & .1141300E-07,.1405500E-07,.1604600E-07,.1892700E-07,.2108000E-07,& - & .7865000E-08,.9987900E-08,.1184600E-07,.1365400E-07,.1587100E-07,& - & .5541700E-08,.6897700E-08,.8700600E-08,.1010800E-07,.1182900E-07,& - & .3914300E-08,.4802500E-08,.6018000E-08,.7376200E-08,.8585100E-08,& - & .2763700E-08,.3339700E-08,.4199600E-08,.5278700E-08,.6292300E-08,& - & .1969100E-08,.2452900E-08,.3007100E-08,.3804100E-08,.4698100E-08,& - & .1303400E-08,.1825700E-08,.2235900E-08,.2821000E-08,.3538600E-08,& - & .1002600E-08,.1342200E-08,.1668700E-08,.2079300E-08,.2605400E-08,& - & .7773000E-09,.9119000E-09,.1246800E-08,.1530200E-08,.1941800E-08,& - & .6035900E-09,.6784800E-09,.9241400E-09,.1151100E-08,.1440100E-08,& - & .5044100E-09,.5679700E-09,.7736900E-09,.9561200E-09,.1195700E-08/ - - data absb( 1:120, 3) / & - & .9812400E-04,.1014900E-03,.1030300E-03,.1066900E-03,.1087000E-03,& - & .8811000E-04,.8973000E-04,.9067900E-04,.9189200E-04,.9141300E-04,& - & .7855500E-04,.7863300E-04,.7914500E-04,.7768900E-04,.7779100E-04,& - & .6724500E-04,.6774300E-04,.6669000E-04,.6576500E-04,.6595000E-04,& - & .5755300E-04,.5749000E-04,.5601200E-04,.5563400E-04,.5601600E-04,& - & .4972900E-04,.4830200E-04,.4741800E-04,.4726200E-04,.4773200E-04,& - & .4210100E-04,.4090600E-04,.4054100E-04,.4022900E-04,.4067100E-04,& - & .3504600E-04,.3419300E-04,.3403200E-04,.3388100E-04,.3469100E-04,& - & .2919200E-04,.2881300E-04,.2852500E-04,.2848500E-04,.2976400E-04,& - & .2421200E-04,.2397000E-04,.2380400E-04,.2394700E-04,.2431000E-04,& - & .2016700E-04,.1996100E-04,.1983700E-04,.2052800E-04,.1988700E-04,& - & .1681700E-04,.1662400E-04,.1652500E-04,.1726300E-04,.1648100E-04,& - & .1389600E-04,.1380600E-04,.1381000E-04,.1434800E-04,.1363400E-04,& - & .1151500E-04,.1147400E-04,.1155300E-04,.1170500E-04,.1116700E-04,& - & .9500400E-05,.9454300E-05,.9565000E-05,.9531600E-05,.9165100E-05,& - & .7813500E-05,.7786200E-05,.7871500E-05,.7782500E-05,.7487700E-05,& - & .6361500E-05,.6360100E-05,.6419800E-05,.6350700E-05,.6120000E-05,& - & .5173800E-05,.5178100E-05,.5225000E-05,.5170900E-05,.5024300E-05,& - & .4182500E-05,.4224000E-05,.4251000E-05,.4224100E-05,.4105800E-05,& - & .3402400E-05,.3430200E-05,.3451400E-05,.3443600E-05,.3347400E-05,& - & .2751000E-05,.2782800E-05,.2805900E-05,.2812500E-05,.2739400E-05,& - & .2219500E-05,.2251700E-05,.2274300E-05,.2272800E-05,.2225400E-05,& - & .1802900E-05,.1823800E-05,.1843200E-05,.1846100E-05,.1824100E-05,& - & .1447700E-05,.1473400E-05,.1493600E-05,.1511600E-05,.1487400E-05/ - - data absb(121:235, 3) / & - & .1163700E-05,.1192900E-05,.1209800E-05,.1226500E-05,.1207600E-05,& - & .9329200E-06,.9624600E-06,.9816900E-06,.9943500E-06,.9874900E-06,& - & .7492700E-06,.7674200E-06,.7902000E-06,.8060400E-06,.8141500E-06,& - & .6047900E-06,.6174300E-06,.6397300E-06,.6529500E-06,.6626100E-06,& - & .4845000E-06,.4974200E-06,.5136600E-06,.5287600E-06,.5381300E-06,& - & .3829800E-06,.4008800E-06,.4119200E-06,.4265100E-06,.4359500E-06,& - & .3031000E-06,.3190500E-06,.3290700E-06,.3415400E-06,.3500700E-06,& - & .2374500E-06,.2503500E-06,.2622400E-06,.2714500E-06,.2814600E-06,& - & .1865300E-06,.1951000E-06,.2064400E-06,.2151000E-06,.2235400E-06,& - & .1475900E-06,.1532200E-06,.1614500E-06,.1703400E-06,.1774400E-06,& - & .1141000E-06,.1200700E-06,.1250700E-06,.1323700E-06,.1399500E-06,& - & .8832700E-07,.9396700E-07,.9768300E-07,.1025700E-06,.1092100E-06,& - & .6671500E-07,.7217200E-07,.7644200E-07,.7921400E-07,.8400600E-07,& - & .5145800E-07,.5576100E-07,.5923900E-07,.6229200E-07,.6447000E-07,& - & .3995700E-07,.4240000E-07,.4587000E-07,.4859200E-07,.5028700E-07,& - & .3115000E-07,.3272500E-07,.3559800E-07,.3763300E-07,.3960700E-07,& - & .2378300E-07,.2541500E-07,.2663400E-07,.2888500E-07,.3062000E-07,& - & .1853100E-07,.1993800E-07,.2098800E-07,.2267800E-07,.2386700E-07,& - & .1481000E-07,.1577200E-07,.1665100E-07,.1772700E-07,.1886100E-07,& - & .1165200E-07,.1255700E-07,.1331900E-07,.1393000E-07,.1507700E-07,& - & .9152300E-08,.9983500E-08,.1060300E-07,.1108100E-07,.1199900E-07,& - & .7238300E-08,.7906000E-08,.8448900E-08,.8861500E-08,.9445600E-08,& - & .6031500E-08,.6593100E-08,.7100100E-08,.7401200E-08,.7876100E-08/ - - data absb( 1:120, 4) / & - & .2188200E-03,.2096800E-03,.1864800E-03,.1750500E-03,.1732000E-03,& - & .1914000E-03,.1702600E-03,.1590300E-03,.1555200E-03,.1600900E-03,& - & .1600300E-03,.1453100E-03,.1400700E-03,.1451100E-03,.1461900E-03,& - & .1338700E-03,.1242300E-03,.1244400E-03,.1274300E-03,.1274900E-03,& - & .1126600E-03,.1078000E-03,.1111000E-03,.1105100E-03,.1107500E-03,& - & .9615600E-04,.9561700E-04,.9677500E-04,.9622000E-04,.9607800E-04,& - & .8271200E-04,.8294600E-04,.8326500E-04,.8282700E-04,.8204400E-04,& - & .7108000E-04,.7116700E-04,.7104000E-04,.7044300E-04,.6906900E-04,& - & .6011000E-04,.6083600E-04,.5999400E-04,.5899200E-04,.5723700E-04,& - & .5068800E-04,.5129600E-04,.5027100E-04,.4888900E-04,.4847100E-04,& - & .4270600E-04,.4262800E-04,.4176400E-04,.3999900E-04,.4089300E-04,& - & .3580300E-04,.3531600E-04,.3453500E-04,.3322900E-04,.3412700E-04,& - & .2990600E-04,.2920100E-04,.2833600E-04,.2745500E-04,.2804400E-04,& - & .2465900E-04,.2392600E-04,.2315900E-04,.2282700E-04,.2326600E-04,& - & .2022100E-04,.1957800E-04,.1883800E-04,.1885300E-04,.1906700E-04,& - & .1634500E-04,.1591300E-04,.1532700E-04,.1541200E-04,.1556000E-04,& - & .1319500E-04,.1287000E-04,.1243000E-04,.1251800E-04,.1263900E-04,& - & .1062200E-04,.1038400E-04,.1006800E-04,.1015100E-04,.1025600E-04,& - & .8578500E-05,.8352300E-05,.8122700E-05,.8199800E-05,.8331300E-05,& - & .6911400E-05,.6709300E-05,.6575800E-05,.6622200E-05,.6767900E-05,& - & .5545600E-05,.5434200E-05,.5322900E-05,.5361000E-05,.5481900E-05,& - & .4446100E-05,.4389100E-05,.4311200E-05,.4363200E-05,.4456000E-05,& - & .3572500E-05,.3519200E-05,.3470300E-05,.3507500E-05,.3591900E-05,& - & .2884200E-05,.2836200E-05,.2814300E-05,.2809700E-05,.2905700E-05/ - - data absb(121:235, 4) / & - & .2337400E-05,.2298700E-05,.2293400E-05,.2281200E-05,.2345100E-05,& - & .1896600E-05,.1867900E-05,.1861300E-05,.1843700E-05,.1889400E-05,& - & .1530000E-05,.1518000E-05,.1509600E-05,.1491500E-05,.1510700E-05,& - & .1242600E-05,.1235700E-05,.1217100E-05,.1217000E-05,.1222700E-05,& - & .1010200E-05,.1007700E-05,.9859300E-06,.9847800E-06,.9921300E-06,& - & .8220100E-06,.8105000E-06,.8031300E-06,.8018100E-06,.8036100E-06,& - & .6731800E-06,.6534700E-06,.6547800E-06,.6436000E-06,.6472200E-06,& - & .5559800E-06,.5335500E-06,.5277800E-06,.5209700E-06,.5199700E-06,& - & .4615700E-06,.4345700E-06,.4241200E-06,.4213700E-06,.4175000E-06,& - & .3915600E-06,.3569000E-06,.3449800E-06,.3399500E-06,.3361400E-06,& - & .3339200E-06,.2974600E-06,.2807400E-06,.2734400E-06,.2707900E-06,& - & .2706600E-06,.2536900E-06,.2311500E-06,.2221300E-06,.2176600E-06,& - & .2219800E-06,.2139500E-06,.1927400E-06,.1804000E-06,.1754200E-06,& - & .1807000E-06,.1736700E-06,.1647300E-06,.1491600E-06,.1430600E-06,& - & .1459500E-06,.1428700E-06,.1384700E-06,.1241800E-06,.1169700E-06,& - & .1181900E-06,.1158800E-06,.1122500E-06,.1060400E-06,.9626900E-07,& - & .9502800E-07,.9309400E-07,.9130300E-07,.8890000E-07,.8026200E-07,& - & .7700500E-07,.7623800E-07,.7422800E-07,.7252600E-07,.6796500E-07,& - & .6297900E-07,.6269200E-07,.6093000E-07,.5957900E-07,.5770000E-07,& - & .5157100E-07,.5119600E-07,.5003100E-07,.4891600E-07,.4812700E-07,& - & .4260200E-07,.4167800E-07,.4100600E-07,.3970900E-07,.3928300E-07,& - & .3515500E-07,.3405200E-07,.3356100E-07,.3239500E-07,.3205700E-07,& - & .2931800E-07,.2851600E-07,.2809700E-07,.2688800E-07,.2684000E-07/ - - data absb( 1:120, 5) / & - & .5646872E-03,.5312795E-03,.5136090E-03,.4988131E-03,.4861599E-03,& - & .4760303E-03,.4583276E-03,.4410876E-03,.4269357E-03,.4186013E-03,& - & .4126853E-03,.3974268E-03,.3837132E-03,.3732654E-03,.3704958E-03,& - & .3556932E-03,.3439374E-03,.3332957E-03,.3278663E-03,.3305577E-03,& - & .3078248E-03,.2969033E-03,.2891762E-03,.2901475E-03,.2947469E-03,& - & .2641839E-03,.2566180E-03,.2537464E-03,.2556275E-03,.2621378E-03,& - & .2264940E-03,.2242650E-03,.2242408E-03,.2276949E-03,.2362173E-03,& - & .1928877E-03,.1922497E-03,.1939580E-03,.2003837E-03,.2081227E-03,& - & .1635486E-03,.1630146E-03,.1664181E-03,.1738976E-03,.1825902E-03,& - & .1382623E-03,.1384386E-03,.1433107E-03,.1505458E-03,.1586465E-03,& - & .1166097E-03,.1183846E-03,.1231655E-03,.1300138E-03,.1374265E-03,& - & .9834271E-04,.1010835E-03,.1058259E-03,.1119955E-03,.1194249E-03,& - & .8297870E-04,.8621261E-04,.9065743E-04,.9659067E-04,.1036206E-03,& - & .7010856E-04,.7362109E-04,.7751831E-04,.8322905E-04,.8970605E-04,& - & .5878661E-04,.6208067E-04,.6580331E-04,.7089987E-04,.7670386E-04,& - & .4892928E-04,.5181644E-04,.5527233E-04,.5975857E-04,.6469853E-04,& - & .4032031E-04,.4266267E-04,.4576398E-04,.4929704E-04,.5363977E-04,& - & .3303540E-04,.3480435E-04,.3759482E-04,.4053873E-04,.4384522E-04,& - & .2673301E-04,.2829877E-04,.3049062E-04,.3280744E-04,.3503681E-04,& - & .2153689E-04,.2293629E-04,.2454493E-04,.2633007E-04,.2814543E-04,& - & .1733556E-04,.1848199E-04,.1972836E-04,.2105193E-04,.2271445E-04,& - & .1408268E-04,.1485471E-04,.1586389E-04,.1695541E-04,.1841529E-04,& - & .1134570E-04,.1192884E-04,.1268134E-04,.1362048E-04,.1483775E-04,& - & .9049567E-05,.9502726E-05,.1010072E-04,.1086491E-04,.1182301E-04/ - - data absb(121:235, 5) / & - & .7259175E-05,.7610477E-05,.8079510E-05,.8694654E-05,.9481533E-05,& - & .5822175E-05,.6083328E-05,.6462080E-05,.6945629E-05,.7579310E-05,& - & .4661372E-05,.4850691E-05,.5152008E-05,.5531782E-05,.6026600E-05,& - & .3768035E-05,.3907858E-05,.4148848E-05,.4439852E-05,.4849767E-05,& - & .3050174E-05,.3152689E-05,.3345838E-05,.3584204E-05,.3905864E-05,& - & .2466186E-05,.2558199E-05,.2693344E-05,.2890245E-05,.3143101E-05,& - & .1984827E-05,.2063835E-05,.2154679E-05,.2317622E-05,.2513311E-05,& - & .1591044E-05,.1657599E-05,.1723355E-05,.1849164E-05,.2007180E-05,& - & .1271611E-05,.1327766E-05,.1384275E-05,.1468719E-05,.1594678E-05,& - & .1012700E-05,.1059571E-05,.1106049E-05,.1165592E-05,.1261722E-05,& - & .8134862E-06,.8456735E-06,.8847293E-06,.9280001E-06,.9964830E-06,& - & .6601437E-06,.6702279E-06,.7033487E-06,.7382687E-06,.7869122E-06,& - & .5354273E-06,.5343277E-06,.5561338E-06,.5862383E-06,.6207320E-06,& - & .4385697E-06,.4345687E-06,.4441542E-06,.4677126E-06,.4945272E-06,& - & .3616858E-06,.3547589E-06,.3578695E-06,.3746540E-06,.3960932E-06,& - & .2980067E-06,.2907198E-06,.2906884E-06,.2989166E-06,.3168227E-06,& - & .2459704E-06,.2382262E-06,.2364831E-06,.2390246E-06,.2515295E-06,& - & .2050509E-06,.1972206E-06,.1946661E-06,.1956373E-06,.2034775E-06,& - & .1708630E-06,.1642309E-06,.1612950E-06,.1615287E-06,.1659752E-06,& - & .1426277E-06,.1371033E-06,.1336511E-06,.1333485E-06,.1355595E-06,& - & .1182556E-06,.1146132E-06,.1111012E-06,.1106095E-06,.1111974E-06,& - & .9823259E-07,.9553915E-07,.9253575E-07,.9185070E-07,.9208712E-07,& - & .8406156E-07,.8113764E-07,.7830100E-07,.7796398E-07,.7863117E-07/ - - data absb( 1:120, 6) / & - & .1876746E-01,.1987652E-01,.2118689E-01,.2284887E-01,.2484965E-01,& - & .1797735E-01,.1911766E-01,.2049609E-01,.2208055E-01,.2390495E-01,& - & .1742326E-01,.1850993E-01,.1995764E-01,.2157831E-01,.2349113E-01,& - & .1632945E-01,.1753946E-01,.1884180E-01,.2053655E-01,.2251614E-01,& - & .1528056E-01,.1648257E-01,.1780611E-01,.1941673E-01,.2129325E-01,& - & .1439040E-01,.1554780E-01,.1695518E-01,.1850787E-01,.2029757E-01,& - & .1364127E-01,.1485684E-01,.1620134E-01,.1772745E-01,.1951994E-01,& - & .1258716E-01,.1381209E-01,.1512804E-01,.1667637E-01,.1840520E-01,& - & .1143111E-01,.1260773E-01,.1397144E-01,.1543741E-01,.1714336E-01,& - & .1034838E-01,.1151140E-01,.1288246E-01,.1434110E-01,.1596120E-01,& - & .9434287E-02,.1058629E-01,.1186231E-01,.1323644E-01,.1478338E-01,& - & .8644308E-02,.9731339E-02,.1097791E-01,.1231507E-01,.1383818E-01,& - & .7945748E-02,.8966157E-02,.1013410E-01,.1144951E-01,.1288499E-01,& - & .7251090E-02,.8253964E-02,.9351761E-02,.1060751E-01,.1200048E-01,& - & .6579748E-02,.7509664E-02,.8524470E-02,.9703299E-02,.1107385E-01,& - & .5951880E-02,.6756479E-02,.7704468E-02,.8845964E-02,.1010461E-01,& - & .5237878E-02,.5963536E-02,.6868194E-02,.7873626E-02,.9058934E-02,& - & .4564340E-02,.5246869E-02,.6058901E-02,.6986798E-02,.8100707E-02,& - & .3927773E-02,.4563237E-02,.5276212E-02,.6126524E-02,.7132796E-02,& - & .3396746E-02,.3962408E-02,.4607092E-02,.5396614E-02,.6293512E-02,& - & .2938365E-02,.3441438E-02,.4024490E-02,.4739722E-02,.5537536E-02,& - & .2568850E-02,.3016246E-02,.3558015E-02,.4198155E-02,.4896116E-02,& - & .2216648E-02,.2607125E-02,.3108998E-02,.3673395E-02,.4285795E-02,& - & .1888038E-02,.2238310E-02,.2672219E-02,.3167173E-02,.3704008E-02/ - - data absb(121:235, 6) / & - & .1589604E-02,.1898430E-02,.2275337E-02,.2698109E-02,.3168934E-02,& - & .1330328E-02,.1601088E-02,.1927308E-02,.2289886E-02,.2702347E-02,& - & .1106058E-02,.1339532E-02,.1622095E-02,.1933708E-02,.2294633E-02,& - & .9232322E-03,.1129388E-02,.1374137E-02,.1641005E-02,.1954041E-02,& - & .7695851E-03,.9499734E-03,.1161581E-02,.1391249E-02,.1659990E-02,& - & .6391411E-03,.7954699E-03,.9764327E-03,.1175728E-02,.1405980E-02,& - & .5221445E-03,.6543645E-03,.8097738E-03,.9801297E-03,.1177108E-02,& - & .4212175E-03,.5316807E-03,.6646766E-03,.8090125E-03,.9773287E-03,& - & .3365734E-03,.4274844E-03,.5406354E-03,.6629665E-03,.8061362E-03,& - & .2659082E-03,.3406968E-03,.4346710E-03,.5386141E-03,.6603153E-03,& - & .2084988E-03,.2688505E-03,.3471450E-03,.4345779E-03,.5367697E-03,& - & .1617409E-03,.2100645E-03,.2734876E-03,.3468514E-03,.4310783E-03,& - & .1230350E-03,.1615169E-03,.2121423E-03,.2726679E-03,.3415988E-03,& - & .9571658E-04,.1268700E-03,.1676066E-03,.2182467E-03,.2753833E-03,& - & .7483539E-04,.1000772E-03,.1334398E-03,.1757280E-03,.2239868E-03,& - & .5772027E-04,.7803984E-04,.1048734E-03,.1398792E-03,.1799578E-03,& - & .4394505E-04,.6019842E-04,.8138845E-04,.1097945E-03,.1427362E-03,& - & .3482804E-04,.4819989E-04,.6606100E-04,.8999622E-04,.1184452E-03,& - & .2824956E-04,.3942832E-04,.5468547E-04,.7556789E-04,.1004720E-03,& - & .2272475E-04,.3212105E-04,.4507284E-04,.6295422E-04,.8486593E-04,& - & .1816142E-04,.2604650E-04,.3689143E-04,.5210509E-04,.7114512E-04,& - & .1460417E-04,.2125717E-04,.3044873E-04,.4347568E-04,.6004634E-04,& - & .1318588E-04,.1949094E-04,.2845284E-04,.4096246E-04,.5730208E-04/ - - data absb( 1:120, 7) / & - & .3908183E+01,.4021612E+01,.4146726E+01,.4284083E+01,.4438438E+01,& - & .3284599E+01,.3380615E+01,.3488659E+01,.3611242E+01,.3752108E+01,& - & .2750113E+01,.2833708E+01,.2928922E+01,.3039836E+01,.3169125E+01,& - & .2307053E+01,.2379505E+01,.2464791E+01,.2564854E+01,.2681085E+01,& - & .1936077E+01,.2001044E+01,.2079025E+01,.2171276E+01,.2276173E+01,& - & .1622572E+01,.1681244E+01,.1752186E+01,.1836321E+01,.1928176E+01,& - & .1369492E+01,.1421024E+01,.1484095E+01,.1556113E+01,.1634126E+01,& - & .1180311E+01,.1227272E+01,.1282719E+01,.1341372E+01,.1403599E+01,& - & .1020024E+01,.1063783E+01,.1111019E+01,.1162039E+01,.1215624E+01,& - & .8833680E+00,.9215968E+00,.9637706E+00,.1008479E+01,.1057170E+01,& - & .7624334E+00,.7970585E+00,.8346574E+00,.8755899E+00,.9193781E+00,& - & .6579273E+00,.6887119E+00,.7224049E+00,.7595641E+00,.7997812E+00,& - & .5668077E+00,.5946957E+00,.6255016E+00,.6592894E+00,.6963418E+00,& - & .4881446E+00,.5135679E+00,.5418786E+00,.5730494E+00,.6077831E+00,& - & .4200990E+00,.4431037E+00,.4688805E+00,.4974060E+00,.5298295E+00,& - & .3617384E+00,.3821010E+00,.4055724E+00,.4323227E+00,.4633921E+00,& - & .3109227E+00,.3293125E+00,.3507763E+00,.3762455E+00,.4052117E+00,& - & .2674240E+00,.2843698E+00,.3044221E+00,.3282655E+00,.3551022E+00,& - & .2297019E+00,.2456549E+00,.2646151E+00,.2871844E+00,.3119468E+00,& - & .1979105E+00,.2130118E+00,.2313507E+00,.2522008E+00,.2753351E+00,& - & .1710687E+00,.1855135E+00,.2029507E+00,.2226155E+00,.2446203E+00,& - & .1485780E+00,.1623096E+00,.1788155E+00,.1972862E+00,.2180352E+00,& - & .1285687E+00,.1414891E+00,.1566691E+00,.1740024E+00,.1933684E+00,& - & .1107491E+00,.1226288E+00,.1365049E+00,.1524192E+00,.1703572E+00/ - - data absb(121:235, 7) / & - & .9456369E-01,.1051244E+00,.1175196E+00,.1318208E+00,.1481765E+00,& - & .8066956E-01,.9002222E-01,.1011931E+00,.1140601E+00,.1288872E+00,& - & .6867032E-01,.7709429E-01,.8709495E-01,.9877474E-01,.1121550E+00,& - & .5832603E-01,.6556338E-01,.7444062E-01,.8488976E-01,.9692322E-01,& - & .4942472E-01,.5585419E-01,.6358733E-01,.7286335E-01,.8372396E-01,& - & .4180841E-01,.4754454E-01,.5435437E-01,.6256355E-01,.7229908E-01,& - & .3508489E-01,.4013132E-01,.4608275E-01,.5327848E-01,.6197794E-01,& - & .2922066E-01,.3367674E-01,.3885124E-01,.4519646E-01,.5282863E-01,& - & .2427508E-01,.2810853E-01,.3265710E-01,.3827469E-01,.4498559E-01,& - & .2006569E-01,.2335359E-01,.2727995E-01,.3220620E-01,.3815593E-01,& - & .1645503E-01,.1925848E-01,.2264332E-01,.2682076E-01,.3208388E-01,& - & .1342964E-01,.1577348E-01,.1865261E-01,.2224444E-01,.2683651E-01,& - & .1090974E-01,.1285284E-01,.1527245E-01,.1835280E-01,.2231368E-01,& - & .8925769E-02,.1055870E-01,.1261660E-01,.1523191E-01,.1867393E-01,& - & .7332235E-02,.8686707E-02,.1044642E-01,.1267886E-01,.1562635E-01,& - & .6005950E-02,.7116692E-02,.8597108E-02,.1050258E-01,.1303347E-01,& - & .4886737E-02,.5803324E-02,.7029411E-02,.8649638E-02,.1082164E-01,& - & .4045146E-02,.4827713E-02,.5866804E-02,.7255958E-02,.9118484E-02,& - & .3386333E-02,.4055976E-02,.4960277E-02,.6153907E-02,.7764407E-02,& - & .2833529E-02,.3404009E-02,.4187592E-02,.5222472E-02,.6607700E-02,& - & .2365720E-02,.2858268E-02,.3529390E-02,.4419998E-02,.5636682E-02,& - & .1989667E-02,.2413827E-02,.2992976E-02,.3780796E-02,.4842075E-02,& - & .1799658E-02,.2201226E-02,.2751996E-02,.3518772E-02,.4547327E-02/ - - data absb( 1:120, 8) / & - & .4033644E+02,.4167953E+02,.4301570E+02,.4435920E+02,.4567833E+02,& - & .3531377E+02,.3641380E+02,.3752525E+02,.3863489E+02,.3972127E+02,& - & .3071410E+02,.3160600E+02,.3251995E+02,.3343214E+02,.3433462E+02,& - & .2650555E+02,.2724233E+02,.2800390E+02,.2877429E+02,.2956326E+02,& - & .2275030E+02,.2336977E+02,.2400486E+02,.2465588E+02,.2535498E+02,& - & .1940546E+02,.1993156E+02,.2047118E+02,.2104774E+02,.2171625E+02,& - & .1638172E+02,.1683509E+02,.1732028E+02,.1787385E+02,.1854784E+02,& - & .1365200E+02,.1402511E+02,.1446383E+02,.1502684E+02,.1574369E+02,& - & .1137022E+02,.1169679E+02,.1212312E+02,.1267823E+02,.1337177E+02,& - & .9506496E+01,.9827971E+01,.1025128E+02,.1081497E+02,.1148308E+02,& - & .8052710E+01,.8344535E+01,.8752518E+01,.9286286E+01,.9908091E+01,& - & .7005129E+01,.7297737E+01,.7690454E+01,.8150077E+01,.8636301E+01,& - & .6181432E+01,.6493698E+01,.6873626E+01,.7267363E+01,.7701472E+01,& - & .5486352E+01,.5805127E+01,.6164438E+01,.6541233E+01,.6910418E+01,& - & .4874205E+01,.5201845E+01,.5533903E+01,.5877592E+01,.6211504E+01,& - & .4354064E+01,.4662856E+01,.4960467E+01,.5268278E+01,.5590873E+01,& - & .3870676E+01,.4151579E+01,.4424561E+01,.4713940E+01,.5019965E+01,& - & .3432801E+01,.3695370E+01,.3951313E+01,.4223258E+01,.4521613E+01,& - & .3046684E+01,.3280864E+01,.3528685E+01,.3785450E+01,.4072281E+01,& - & .2707644E+01,.2931362E+01,.3163706E+01,.3412966E+01,.3691298E+01,& - & .2413017E+01,.2622420E+01,.2842869E+01,.3091981E+01,.3368488E+01,& - & .2161287E+01,.2357984E+01,.2569356E+01,.2810989E+01,.3097338E+01,& - & .1925443E+01,.2108054E+01,.2317393E+01,.2555114E+01,.2840446E+01,& - & .1703781E+01,.1879720E+01,.2080458E+01,.2316042E+01,.2597137E+01/ - - data absb(121:235, 8) / & - & .1493092E+01,.1657976E+01,.1851046E+01,.2073961E+01,.2343340E+01,& - & .1311161E+01,.1466732E+01,.1645509E+01,.1859825E+01,.2118946E+01,& - & .1150929E+01,.1297548E+01,.1468104E+01,.1672256E+01,.1922471E+01,& - & .1004409E+01,.1141010E+01,.1301607E+01,.1492747E+01,.1726160E+01,& - & .8769985E+00,.1002882E+01,.1151293E+01,.1329471E+01,.1549835E+01,& - & .7649098E+00,.8805424E+00,.1016103E+01,.1181723E+01,.1389132E+01,& - & .6598121E+00,.7637212E+00,.8887136E+00,.1040010E+01,.1230413E+01,& - & .5657958E+00,.6586754E+00,.7718739E+00,.9084100E+00,.1082238E+01,& - & .4835182E+00,.5668068E+00,.6687172E+00,.7926556E+00,.9499754E+00,& - & .4118145E+00,.4852766E+00,.5756963E+00,.6868494E+00,.8286511E+00,& - & .3488019E+00,.4139755E+00,.4938550E+00,.5910229E+00,.7163238E+00,& - & .2935726E+00,.3516563E+00,.4223583E+00,.5090453E+00,.6171835E+00,& - & .2445646E+00,.2963715E+00,.3583947E+00,.4363324E+00,.5322580E+00,& - & .2063336E+00,.2514543E+00,.3069415E+00,.3769572E+00,.4647802E+00,& - & .1745065E+00,.2143204E+00,.2634212E+00,.3259536E+00,.4065898E+00,& - & .1469747E+00,.1815841E+00,.2245475E+00,.2809591E+00,.3526955E+00,& - & .1226579E+00,.1531164E+00,.1907781E+00,.2400747E+00,.3043525E+00,& - & .1036864E+00,.1314203E+00,.1647845E+00,.2083891E+00,.2666072E+00,& - & .8816513E-01,.1136512E+00,.1440561E+00,.1835360E+00,.2351002E+00,& - & .7437710E-01,.9768257E-01,.1255978E+00,.1607081E+00,.2071018E+00,& - & .6227610E-01,.8346943E-01,.1093711E+00,.1408269E+00,.1825617E+00,& - & .5263552E-01,.7135997E-01,.9530909E-01,.1242291E+00,.1612246E+00,& - & .4825418E-01,.6650163E-01,.8992737E-01,.1186811E+00,.1555922E+00/ - - data absb( 1:120, 9) / & - & .1646500E+03,.1629800E+03,.1641300E+03,.1679600E+03,.1742500E+03,& - & .1413400E+03,.1422300E+03,.1458400E+03,.1518300E+03,.1582300E+03,& - & .1233400E+03,.1264200E+03,.1317000E+03,.1371900E+03,.1424800E+03,& - & .1090300E+03,.1135000E+03,.1182500E+03,.1228400E+03,.1272000E+03,& - & .9674400E+02,.1007700E+03,.1047300E+03,.1085600E+03,.1122500E+03,& - & .8536800E+02,.8866900E+02,.9193400E+02,.9512700E+02,.9821600E+02,& - & .7486500E+02,.7756000E+02,.8026300E+02,.8291200E+02,.8549900E+02,& - & .6530400E+02,.6758800E+02,.6984900E+02,.7209900E+02,.7431600E+02,& - & .5670400E+02,.5861600E+02,.6054100E+02,.6245700E+02,.6444400E+02,& - & .4909900E+02,.5078800E+02,.5245100E+02,.5411900E+02,.5597000E+02,& - & .4207600E+02,.4364600E+02,.4523000E+02,.4688800E+02,.4879800E+02,& - & .3545700E+02,.3690400E+02,.3844700E+02,.4026200E+02,.4256500E+02,& - & .2983200E+02,.3103600E+02,.3250800E+02,.3450200E+02,.3697900E+02,& - & .2520500E+02,.2634800E+02,.2779200E+02,.2978800E+02,.3245900E+02,& - & .2148600E+02,.2258600E+02,.2416200E+02,.2626000E+02,.2894400E+02,& - & .1871200E+02,.1969300E+02,.2137000E+02,.2359100E+02,.2615800E+02,& - & .1663000E+02,.1771600E+02,.1936900E+02,.2156500E+02,.2410200E+02,& - & .1492300E+02,.1611900E+02,.1778300E+02,.1998900E+02,.2237900E+02,& - & .1353200E+02,.1485300E+02,.1657600E+02,.1874500E+02,.2108400E+02,& - & .1245300E+02,.1378400E+02,.1558700E+02,.1771800E+02,.2002200E+02,& - & .1158000E+02,.1303800E+02,.1485100E+02,.1689200E+02,.1919200E+02,& - & .1082000E+02,.1237600E+02,.1413400E+02,.1615200E+02,.1840200E+02,& - & .1011600E+02,.1168600E+02,.1340200E+02,.1534600E+02,.1755600E+02,& - & .9393300E+01,.1091000E+02,.1257200E+02,.1443200E+02,.1653600E+02/ - - data absb(121:235, 9) / & - & .8516000E+01,.9975500E+01,.1155400E+02,.1335800E+02,.1535000E+02,& - & .7750500E+01,.9122500E+01,.1067000E+02,.1238000E+02,.1427300E+02,& - & .7089700E+01,.8388500E+01,.9869400E+01,.1150200E+02,.1334300E+02,& - & .6329500E+01,.7550600E+01,.8946600E+01,.1049500E+02,.1228700E+02,& - & .5630200E+01,.6798800E+01,.8095700E+01,.9601300E+01,.1128000E+02,& - & .5023400E+01,.6107100E+01,.7338900E+01,.8781600E+01,.1038000E+02,& - & .4422500E+01,.5428200E+01,.6596300E+01,.7943300E+01,.9466600E+01,& - & .3855800E+01,.4791200E+01,.5890500E+01,.7147800E+01,.8614500E+01,& - & .3357500E+01,.4235100E+01,.5247500E+01,.6429200E+01,.7829600E+01,& - & .2905300E+01,.3707400E+01,.4643200E+01,.5748400E+01,.7067400E+01,& - & .2470600E+01,.3185100E+01,.4052400E+01,.5083700E+01,.6299000E+01,& - & .2090700E+01,.2732000E+01,.3523200E+01,.4468900E+01,.5599800E+01,& - & .1765200E+01,.2339700E+01,.3052500E+01,.3913000E+01,.4964100E+01,& - & .1498000E+01,.1999500E+01,.2638600E+01,.3430900E+01,.4393000E+01,& - & .1288300E+01,.1722900E+01,.2280800E+01,.3005800E+01,.3892100E+01,& - & .1103200E+01,.1487800E+01,.1994500E+01,.2622500E+01,.3432700E+01,& - & .9425600E+00,.1280300E+01,.1743600E+01,.2309500E+01,.3025800E+01,& - & .8084700E+00,.1104500E+01,.1525000E+01,.2057300E+01,.2704800E+01,& - & .6997200E+00,.9500800E+00,.1321500E+01,.1817800E+01,.2432600E+01,& - & .6065900E+00,.8129800E+00,.1143000E+01,.1592500E+01,.2178300E+01,& - & .5266400E+00,.6967000E+00,.9799800E+00,.1389100E+01,.1933300E+01,& - & .4598500E+00,.6068200E+00,.8433700E+00,.1211300E+01,.1718800E+01,& - & .4385300E+00,.5787900E+00,.7901800E+00,.1113000E+01,.1603900E+01/ - - data absb( 1:120,10) / & - & .8601600E+03,.8462600E+03,.8322800E+03,.8181700E+03,.8045000E+03,& - & .7598100E+03,.7466300E+03,.7334500E+03,.7210400E+03,.7122400E+03,& - & .6620100E+03,.6499300E+03,.6389100E+03,.6321000E+03,.6297800E+03,& - & .5701400E+03,.5602700E+03,.5546600E+03,.5537800E+03,.5572100E+03,& - & .4886100E+03,.4835400E+03,.4832400E+03,.4876000E+03,.4960200E+03,& - & .4198700E+03,.4196400E+03,.4241100E+03,.4329100E+03,.4457500E+03,& - & .3630300E+03,.3670200E+03,.3755600E+03,.3883400E+03,.4047100E+03,& - & .3165100E+03,.3242100E+03,.3362700E+03,.3521900E+03,.3707200E+03,& - & .2786700E+03,.2894700E+03,.3043400E+03,.3213100E+03,.3382300E+03,& - & .2491600E+03,.2625100E+03,.2776800E+03,.2929600E+03,.3084400E+03,& - & .2257100E+03,.2393200E+03,.2529100E+03,.2667000E+03,.2806900E+03,& - & .2050300E+03,.2176500E+03,.2302900E+03,.2429100E+03,.2557500E+03,& - & .1857400E+03,.1976300E+03,.2096000E+03,.2215100E+03,.2335600E+03,& - & .1682500E+03,.1794500E+03,.1908500E+03,.2024200E+03,.2140600E+03,& - & .1525400E+03,.1631100E+03,.1740200E+03,.1852100E+03,.1969600E+03,& - & .1381500E+03,.1485700E+03,.1591300E+03,.1702200E+03,.1823800E+03,& - & .1256000E+03,.1357100E+03,.1463000E+03,.1576300E+03,.1701900E+03,& - & .1149700E+03,.1247600E+03,.1355000E+03,.1471900E+03,.1604400E+03,& - & .1060200E+03,.1157700E+03,.1267100E+03,.1388900E+03,.1528900E+03,& - & .9851900E+02,.1085500E+03,.1197800E+03,.1326500E+03,.1474400E+03,& - & .9251700E+02,.1027400E+03,.1145200E+03,.1282200E+03,.1438900E+03,& - & .8744100E+02,.9793600E+02,.1104400E+03,.1249500E+03,.1414800E+03,& - & .8249900E+02,.9333300E+02,.1063500E+03,.1215100E+03,.1387400E+03,& - & .7744200E+02,.8849300E+02,.1018400E+03,.1174000E+03,.1351300E+03/ - - data absb(121:235,10) / & - & .7177100E+02,.8273100E+02,.9603200E+02,.1115800E+03,.1294100E+03,& - & .6672700E+02,.7761000E+02,.9079500E+02,.1063200E+03,.1241500E+03,& - & .6233900E+02,.7311300E+02,.8620000E+02,.1016700E+03,.1194200E+03,& - & .5760100E+02,.6799900E+02,.8072400E+02,.9585800E+02,.1132300E+03,& - & .5328500E+02,.6320300E+02,.7557700E+02,.9024200E+02,.1072600E+03,& - & .4939200E+02,.5890800E+02,.7083400E+02,.8504500E+02,.1016300E+03,& - & .4544600E+02,.5445200E+02,.6575100E+02,.7940200E+02,.9539700E+02,& - & .4162000E+02,.5018400E+02,.6077700E+02,.7378600E+02,.8907600E+02,& - & .3805900E+02,.4628200E+02,.5622600E+02,.6853900E+02,.8313600E+02,& - & .3455400E+02,.4250100E+02,.5182900E+02,.6338300E+02,.7722000E+02,& - & .3100900E+02,.3861000E+02,.4738500E+02,.5805800E+02,.7108000E+02,& - & .2771500E+02,.3493400E+02,.4331900E+02,.5319000E+02,.6534700E+02,& - & .2465800E+02,.3147800E+02,.3950000E+02,.4874300E+02,.5999700E+02,& - & .2203400E+02,.2843700E+02,.3609300E+02,.4489400E+02,.5534600E+02,& - & .1968400E+02,.2562600E+02,.3293700E+02,.4138500E+02,.5115400E+02,& - & .1750400E+02,.2299500E+02,.2992500E+02,.3805700E+02,.4730700E+02,& - & .1555200E+02,.2054400E+02,.2707900E+02,.3483200E+02,.4372200E+02,& - & .1388600E+02,.1847600E+02,.2460700E+02,.3196600E+02,.4054000E+02,& - & .1239600E+02,.1668100E+02,.2238500E+02,.2938400E+02,.3759200E+02,& - & .1102800E+02,.1500600E+02,.2029700E+02,.2695500E+02,.3478000E+02,& - & .9749300E+01,.1345200E+02,.1835400E+02,.2464400E+02,.3209900E+02,& - & .8641100E+01,.1206800E+02,.1662700E+02,.2256900E+02,.2968400E+02,& - & .8089400E+01,.1144900E+02,.1590500E+02,.2175300E+02,.2872800E+02/ - - data absb( 1:120,11) / & - & .5004600E+04,.5003400E+04,.4995000E+04,.4978100E+04,.4954200E+04,& - & .5181200E+04,.5173800E+04,.5158200E+04,.5135700E+04,.5105400E+04,& - & .5279300E+04,.5264500E+04,.5245000E+04,.5217200E+04,.5183600E+04,& - & .5300100E+04,.5281800E+04,.5256800E+04,.5227400E+04,.5192400E+04,& - & .5244800E+04,.5224200E+04,.5200400E+04,.5171500E+04,.5137700E+04,& - & .5120000E+04,.5103100E+04,.5081700E+04,.5057100E+04,.5030800E+04,& - & .4938900E+04,.4928400E+04,.4915300E+04,.4900700E+04,.4881900E+04,& - & .4718100E+04,.4716800E+04,.4716300E+04,.4712900E+04,.4711100E+04,& - & .4471800E+04,.4486500E+04,.4499000E+04,.4515300E+04,.4540300E+04,& - & .4219200E+04,.4249700E+04,.4286100E+04,.4331600E+04,.4380900E+04,& - & .3972700E+04,.4027500E+04,.4093600E+04,.4164600E+04,.4240400E+04,& - & .3750700E+04,.3833600E+04,.3923900E+04,.4020600E+04,.4120900E+04,& - & .3560600E+04,.3669400E+04,.3782600E+04,.3902600E+04,.4024400E+04,& - & .3404300E+04,.3536400E+04,.3673100E+04,.3813000E+04,.3951900E+04,& - & .3280300E+04,.3434600E+04,.3591200E+04,.3747600E+04,.3901400E+04,& - & .3187600E+04,.3361000E+04,.3534400E+04,.3704200E+04,.3869900E+04,& - & .3123900E+04,.3313700E+04,.3499500E+04,.3681300E+04,.3857300E+04,& - & .3085000E+04,.3287200E+04,.3483700E+04,.3674500E+04,.3859100E+04,& - & .3067400E+04,.3279500E+04,.3484800E+04,.3682600E+04,.3872400E+04,& - & .3068300E+04,.3287900E+04,.3499000E+04,.3702200E+04,.3895300E+04,& - & .3083100E+04,.3308700E+04,.3524300E+04,.3730300E+04,.3925000E+04,& - & .3101700E+04,.3330800E+04,.3549600E+04,.3758000E+04,.3952700E+04,& - & .3105700E+04,.3338700E+04,.3560100E+04,.3770000E+04,.3965400E+04,& - & .3089500E+04,.3326000E+04,.3550400E+04,.3763000E+04,.3960600E+04/ - - data absb(121:235,11) / & - & .3040000E+04,.3281100E+04,.3509600E+04,.3726300E+04,.3927700E+04,& - & .2991300E+04,.3236100E+04,.3469000E+04,.3689000E+04,.3894200E+04,& - & .2944100E+04,.3192600E+04,.3429400E+04,.3652600E+04,.3861200E+04,& - & .2872200E+04,.3125400E+04,.3366700E+04,.3594300E+04,.3807300E+04,& - & .2797100E+04,.3054800E+04,.3300400E+04,.3532600E+04,.3750500E+04,& - & .2722600E+04,.2983700E+04,.3233600E+04,.3470100E+04,.3692500E+04,& - & .2633200E+04,.2898100E+04,.3152500E+04,.3394400E+04,.3622300E+04,& - & .2537200E+04,.2805000E+04,.3064300E+04,.3311400E+04,.3544100E+04,& - & .2441700E+04,.2711300E+04,.2974800E+04,.3226800E+04,.3465100E+04,& - & .2339500E+04,.2611500E+04,.2878300E+04,.3135100E+04,.3379200E+04,& - & .2224300E+04,.2499800E+04,.2769400E+04,.3031300E+04,.3281000E+04,& - & .2108300E+04,.2387700E+04,.2659200E+04,.2925700E+04,.3180300E+04,& - & .1992500E+04,.2274100E+04,.2548800E+04,.2818000E+04,.3078300E+04,& - & .1884100E+04,.2166600E+04,.2444700E+04,.2715900E+04,.2980600E+04,& - & .1779800E+04,.2061800E+04,.2342800E+04,.2616000E+04,.2883900E+04,& - & .1676200E+04,.1957400E+04,.2239800E+04,.2515600E+04,.2786200E+04,& - & .1573100E+04,.1853000E+04,.2135800E+04,.2415200E+04,.2687200E+04,& - & .1480200E+04,.1758100E+04,.2040100E+04,.2321900E+04,.2595600E+04,& - & .1391500E+04,.1667500E+04,.1948800E+04,.2231800E+04,.2508000E+04,& - & .1303900E+04,.1577800E+04,.1857700E+04,.2140600E+04,.2420000E+04,& - & .1216700E+04,.1489000E+04,.1767200E+04,.2049300E+04,.2331300E+04,& - & .1134900E+04,.1405700E+04,.1681800E+04,.1963100E+04,.2246400E+04,& - & .1102500E+04,.1372100E+04,.1647600E+04,.1928300E+04,.2211700E+04/ - - data absb( 1:120,12) / & - & .1249200E+05,.1260200E+05,.1267800E+05,.1273000E+05,.1274900E+05,& - & .1469600E+05,.1479200E+05,.1486200E+05,.1489000E+05,.1488900E+05,& - & .1715300E+05,.1724200E+05,.1727500E+05,.1727400E+05,.1723100E+05,& - & .1984300E+05,.1989400E+05,.1989800E+05,.1984500E+05,.1974700E+05,& - & .2272700E+05,.2273100E+05,.2266700E+05,.2255100E+05,.2238600E+05,& - & .2576100E+05,.2568400E+05,.2554400E+05,.2534200E+05,.2507000E+05,& - & .2887800E+05,.2870100E+05,.2845400E+05,.2813100E+05,.2775900E+05,& - & .3198100E+05,.3169500E+05,.3131400E+05,.3087100E+05,.3036000E+05,& - & .3501700E+05,.3457500E+05,.3406400E+05,.3348000E+05,.3282100E+05,& - & .3785400E+05,.3726400E+05,.3658900E+05,.3584000E+05,.3504600E+05,& - & .4047300E+05,.3971000E+05,.3886200E+05,.3796700E+05,.3702300E+05,& - & .4279600E+05,.4186400E+05,.4086900E+05,.3981700E+05,.3871800E+05,& - & .4481300E+05,.4371900E+05,.4257800E+05,.4138000E+05,.4014300E+05,& - & .4650400E+05,.4526300E+05,.4397300E+05,.4264100E+05,.4129400E+05,& - & .4789300E+05,.4650700E+05,.4508700E+05,.4364700E+05,.4219700E+05,& - & .4899300E+05,.4748000E+05,.4595200E+05,.4441700E+05,.4287800E+05,& - & .4982300E+05,.4820600E+05,.4658800E+05,.4496900E+05,.4335300E+05,& - & .5041500E+05,.4871600E+05,.4702500E+05,.4533900E+05,.4365900E+05,& - & .5081100E+05,.4904200E+05,.4728800E+05,.4554300E+05,.4381300E+05,& - & .5103200E+05,.4920300E+05,.4740000E+05,.4561000E+05,.4384100E+05,& - & .5110700E+05,.4923400E+05,.4739300E+05,.4556500E+05,.4377500E+05,& - & .5113000E+05,.4922800E+05,.4735000E+05,.4549700E+05,.4368800E+05,& - & .5125600E+05,.4931600E+05,.4741300E+05,.4554000E+05,.4371100E+05,& - & .5151900E+05,.4955500E+05,.4762600E+05,.4573100E+05,.4388500E+05/ - - data absb(121:235,12) / & - & .5203400E+05,.5004100E+05,.4809000E+05,.4616800E+05,.4430200E+05,& - & .5252900E+05,.5051100E+05,.4853500E+05,.4659500E+05,.4470600E+05,& - & .5298500E+05,.5095200E+05,.4895400E+05,.4699600E+05,.4508500E+05,& - & .5363300E+05,.5157500E+05,.4955600E+05,.4757800E+05,.4564800E+05,& - & .5428900E+05,.5221100E+05,.5017100E+05,.4817100E+05,.4622000E+05,& - & .5493200E+05,.5283600E+05,.5077800E+05,.4875900E+05,.4678500E+05,& - & .5567300E+05,.5356900E+05,.5148800E+05,.4944900E+05,.4745600E+05,& - & .5646100E+05,.5434600E+05,.5224700E+05,.5019000E+05,.4817800E+05,& - & .5724100E+05,.5512100E+05,.5300700E+05,.5092900E+05,.4889700E+05,& - & .5806300E+05,.5593300E+05,.5380600E+05,.5171000E+05,.4965600E+05,& - & .5897800E+05,.5682800E+05,.5469700E+05,.5258200E+05,.5050500E+05,& - & .5989100E+05,.5772000E+05,.5558600E+05,.5345900E+05,.5136700E+05,& - & .6079500E+05,.5862100E+05,.5647200E+05,.5433600E+05,.5222400E+05,& - & .6163900E+05,.5946600E+05,.5729800E+05,.5516200E+05,.5303400E+05,& - & .6244700E+05,.6028400E+05,.5811000E+05,.5596100E+05,.5382400E+05,& - & .6324000E+05,.6109800E+05,.5891600E+05,.5676000E+05,.5461200E+05,& - & .6403000E+05,.6190300E+05,.5972700E+05,.5755800E+05,.5541100E+05,& - & .6473500E+05,.6263700E+05,.6047100E+05,.5828700E+05,.5613800E+05,& - & .6540700E+05,.6333200E+05,.6118100E+05,.5900300E+05,.5683400E+05,& - & .6606900E+05,.6401500E+05,.6188100E+05,.5970200E+05,.5752900E+05,& - & .6672500E+05,.6468300E+05,.6257600E+05,.6041100E+05,.5822500E+05,& - & .6732700E+05,.6531500E+05,.6323200E+05,.6107800E+05,.5889100E+05,& - & .6757700E+05,.6557200E+05,.6349600E+05,.6134900E+05,.5916100E+05/ - -! --- - data forref(1:4,1:12) / .2998180E-05,.2092820E-05,.9883530E-04,& - & .6321780E-03,.6336480E-05,.5092140E-04,.6505350E-03,.2640190E-02,& - & .6367820E-04,.1365770E-03,.1665000E-02,.7508210E-02,.4723140E-03,& - & .9882960E-03,.5857510E-02,.1873520E-01,.1306617E-01,.1521008E-01,& - & .1910962E-01,.1640369E-01,.2664425E-01,.2836468E-01,.1997971E-01,& - & .6508449E-02,.3071268E-01,.1794967E-01,.9099105E-02,.1435908E-02,& - & .3256760E-01,.2153142E-01,.9594611E-03,.2499136E-02,.3451570E-01,& - & .1686790E-01,.5053610E-06,.2766470E-02,.4487650E-01,.1237910E-02,& - & .4883670E-06,.1222450E-02,.4869250E-01,.4643710E-06,.4642410E-06,& - & .7538460E-06,.5305110E-01,.3762340E-06,.4098240E-06,.4706500E-06/ - -! the array selfref contains the coefficient of the water vapor -! self-continuum (including the energy term). the first index -! refers to temperature in 7.2 degree increments. For instance, -! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, -! etc. the second index runs over the g-channel (1 to 12). - - data selfref(1:10,1:12) / & - & .1180690E+00,.7135230E-01,.4311990E-01,.2605840E-01,.1574770E-01,& - & .9516750E-02,.5751210E-02,.3475600E-02,.2100390E-02,.1269320E-02,& - & .1370810E-01,.1390460E-01,.1410400E-01,.1430610E-01,.1451120E-01,& - & .1471930E-01,.1493030E-01,.1514430E-01,.1536140E-01,.1558160E-01,& - & .1665750E-01,.1649160E-01,.1632730E-01,.1616470E-01,.1600370E-01,& - & .1584430E-01,.1568640E-01,.1553020E-01,.1537550E-01,.1522240E-01,& - & .5973790E-01,.5095170E-01,.4345790E-01,.3706620E-01,.3161450E-01,& - & .2696470E-01,.2299880E-01,.1961620E-01,.1673110E-01,.1427030E-01,& - & .3320371E+00,.2986281E+00,.2687252E+00,.2419448E+00,.2179475E+00,& - & .1964309E+00,.1771281E+00,.1598017E+00,.1442398E+00,.1302553E+00,& - & .5353614E+00,.4870549E+00,.4431120E+00,.4031396E+00,.3667769E+00,& - & .3336985E+00,.3036077E+00,.2762334E+00,.2513302E+00,.2286753E+00,& - & .2654145E+00,.2716462E+00,.2780447E+00,.2846162E+00,.2913638E+00,& - & .2982924E+00,.3054070E+00,.3127136E+00,.3202159E+00,.3279193E+00,& - & .3297702E+00,.3292642E+00,.3288167E+00,.3284279E+00,.3280982E+00,& - & .3278270E+00,.3276143E+00,.3274609E+00,.3273666E+00,.3273316E+00,& - & .2274450E+00,.2415450E+00,.2565190E+00,.2724220E+00,.2893110E+00,& - & .3072470E+00,.3262940E+00,.3465230E+00,.3680050E+00,.3908200E+00,& - & .6162030E-02,.1135230E-01,.2091440E-01,.3853070E-01,.7098520E-01,& - & .1307760E+00,.2409290E+00,.4438650E+00,.8177330E+00,.1506510E+01,& - & .2795520E-03,.8084720E-03,.2338120E-02,.6761920E-02,.1955570E-01,& - & .5655550E-01,.1635600E+00,.4730200E+00,.1367990E+01,.3956260E+01,& - & .2610060E-03,.7710430E-03,.2277760E-02,.6728790E-02,.1987770E-01,& - & .5872120E-01,.1734700E+00,.5124520E+00,.1513850E+01,.4472090E+01/ - -!........................................! - end module module_radsw_kgb29 ! -!========================================! - diff --git a/src/fim/FIMsrc/fim/column/radsw_main.f b/src/fim/FIMsrc/fim/column/radsw_main.f deleted file mode 100644 index d158ba1..0000000 --- a/src/fim/FIMsrc/fim/column/radsw_main.f +++ /dev/null @@ -1,3581 +0,0 @@ -!!!!! ========================================================== !!!!! -!!!!! sw-rrtm2 radiation package description !!!!! -!!!!! ========================================================== !!!!! -! ! -! the sw-rrtm2 package includes these parts: ! -! ! -! 'radsw_rrtm2_param.f' ! -! 'radsw_rrtm2_datatb.f' ! -! 'radsw_rrtm2_main.f' ! -! ! -! the 'radsw_rrtm2_param.f' contains: ! -! ! -! 'module_radsw_parameters' -- band parameters set up ! -! 'module_radsw_cntr_para' -- control parameters set up ! -! ! -! the 'radsw_rrtm2_datatb.f' contains: ! -! ! -! 'module_radsw_cldprtb' -- cloud property coefficients table ! -! 'module_radsw_kgbnn' -- absorption coeffients for 14 ! -! bands, where nn = 16-29 ! -! ! -! the 'radsw_rrtm2_main.f' contains: ! -! ! -! 'module_radsw_main' -- main sw radiation transfer ! -! ! -! in the main module 'module_radsw_main' there are only two ! -! externally callable subroutines: ! -! ! -! 'swrad' -- main rrtm2 sw radiation routine ! -! inputs: ! -! (plyr,plvl,tlyr,tlvl,qlyr,olyr,gasvmr, ! -! clouds,iovr,aerosols,sfcalb, ! -! cosz,solcon,NDAY,idxday, ! -! IMAX, NLAY, NLP1, iflip, lprnt, ! -! outputs: ! -! hswc,topflx,sfcflx, ! -!! optional outputs: ! -! HSW0,HSWB,FLXPRF,FDNCMP ! -! ) ! -! ! -! 'rswinit' -- initialization routine ! -! inputs: ! -! ( icwp, me, NLAY ) ! -! outputs: ! -! (none) ! -! ! -! all the sw radiation subprograms become contained subprograms ! -! in module 'module_radsw_main' and many of them are not directly ! -! accessable from places outside the module. ! -! ! -! derived data type constructs used: ! -! ! -! 1. radiation flux at toa: (from module 'module_radsw_parameters')! -! topfsw_type - derived data type for toa rad fluxes ! -! upfxc total sky upward flux at toa ! -! dnfxc total sky downward flux at toa ! -! upfx0 clear sky upward flux at toa ! -! ! -! 2. radiation flux at sfc: (from module 'module_radsw_parameters')! -! sfcfsw_type - derived data type for sfc rad fluxes ! -! upfxc total sky upward flux at sfc ! -! dnfxc total sky downward flux at sfc ! -! upfx0 clear sky upward flux at sfc ! -! dnfx0 clear sky downward flux at sfc ! -! ! -! 3. radiation flux profiles(from module 'module_radsw_parameters')! -! profsw_type - derived data type for rad vertical prof ! -! upfxc total sky level upward flux ! -! dnfxc total sky level downward flux ! -! upfx0 clear sky level upward flux ! -! dnfx0 clear sky level downward flux ! -! ! -! 4. surface component fluxes(from module 'module_radsw_parameters'! -! cmpfsw_type - derived data type for component sfc flux ! -! uvbfc total sky downward uv-b flux at sfc ! -! uvbf0 clear sky downward uv-b flux at sfc ! -! nirbm surface downward nir direct beam flux ! -! nirdf surface downward nir diffused flux ! -! visbm surface downward uv+vis direct beam flx! -! visdf surface downward uv+vis diffused flux ! -! ! -! ! -! external modules referenced: ! -! ! -! 'module machine' ! -! 'module physcons' ! -! ! -! compilation sequence is: ! -! ! -! 'radsw_rrtm2_param.f' ! -! 'radsw_rrtm2_datatb.f' ! -! 'radsw_rrtm2_main.f' ! -! ! -! and all should be put in front of routines that use sw modules ! -! ! -! ! -! ! -! ! -! the original program declarations: ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Copyright 2002, 2003, 2004, Atmospheric & Environmental Research, Inc! -! (AER). This software may be used, copied, or redistributed as long as! -! it is not sold and this copyright notice is reproduced on each copy ! -! made. This model is provided as is without any express or implied ! -! warranties. ! -! (http://www.rtweb.aer.com/) ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! rrtm_sw ! -! ! -! a rapid radiative transfer model ! -! for the solar spectral region ! -! ! -! atmospheric and environmental research, inc. ! -! 840 memorial drive ! -! cambridge, ma 02139 ! -! ! -! eli j. mlawer ! -! jennifer delamere ! -! steven j. taubman~ ! -! shepard a. clough ! -! ! -! ~currently at gfdl ! -! ! -! email: mlawer@aer.com ! -! ! -! the authors wish to acknowledge the contributions of the ! -! following people: patrick d. brown, michael j. iacono, ! -! ronald e. farren, luke chen, robert bergstrom. ! -! ! -! ! -! references: ! -! mlawer, e.j., s.j.taubman, p.d. brown, m.j. iacono, and ! -! s.a. clough (1997): radiative transfer for inhomogeneous ! -! atmospheres: rrtm, a validated correlated-k model for the ! -! longwave. ! -! ! -! ! -! ! -! ncep modifications history log: ! -! ! -! sep 2003, yu-tai hou ! -! received aer's rrtm-sw gcm version code (v224) ! -! jan 2004, yu-tai hou ! -! modified code into standard modular f90 code for ! -! ncep models. ! -! jun 2004, yu-tai hou ! -! modified code based on aer's faster version ! -! rrtmg_sw (v2.0) with 112 g-points. ! -! mar 2005, yu-tai hou ! -! correct cloud double scaling according to aer. ! -! total sky prop. are delta scaled after combining ! -! clear and cloudy parts. test criterion of s.s.a. ! -! is saved before scaling. ! -! apr 2005, yu-tai hou ! -! modified on module structures ! -! apr 2007, yu-tai hou ! -! add spectral band heating as optional output ! -! ! -! ! -! ! -!!!!! ========================================================== !!!!! -!!!!! end descriptions !!!!! -!!!!! ========================================================== !!!!! - - - -!========================================! - module module_radsw_main ! -!........................................! -! - use machine, only : kind_phys - use physcons, only : con_g, con_cp, con_avgd, con_amd, & - & con_amw, con_amo3 - - use module_radsw_parameters - use module_radsw_cntr_para -! - implicit none -! - private -! -! ... version tag and last revision date -! -! character(24), parameter :: VTAGSW='RRTM-SW 112v2.0 jul 2004' -! character(24), parameter :: VTAGSW='RRTM-SW 112v2.3 mar 2005' - character(24), parameter :: VTAGSW='RRTM-SW 112v2.3 Apr 2007' - -! --- constant values - real (kind=kind_phys), parameter :: eps = 1.0e-6 - real (kind=kind_phys), parameter :: oneminus= 1.0 - eps - real (kind=kind_phys), parameter :: ftiny = 1.0e-12 - real (kind=kind_phys), parameter :: stpfac = 296.0/1013.0 - real (kind=kind_phys), parameter :: s0 = 1368.22 ! solar const hard coded in freq bands - real (kind=kind_phys), parameter :: zero = 0.0 - real (kind=kind_phys), parameter :: one = 1.0 - -! ... atomic weights for conversion from mass to volume mixing ratios - real (kind=kind_phys), parameter :: amdw = con_amd/con_amw - real (kind=kind_phys), parameter :: amdo3 = con_amd/con_amo3 - -! ... band indices - integer, dimension(NBLOW:NBHGH) :: NSPA, NSPB, IDXALB, IDXSFC - - data NSPA(:) / 9, 9, 9, 9, 1, 9, 9, 1, 9, 1, 0, 1, 9, 1 / - data NSPB(:) / 1, 5, 1, 1, 1, 5, 1, 0, 1, 0, 0, 1, 5, 1 / - - data IDXALB(:) / 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 1 / - data IDXSFC(:) / 1, 1, 1, 1, 1, 1, 1, 1, 0, 2, 2, 2, 2, 1 / - -! ... band wavenumber intervals -! real (kind=kind_phys), dimension(NBLOW:NBHGH):: wavenum1,wavenum2 -! data wavenum1(:) / & -! & 2600.0, 3250.0, 4000.0, 4650.0, 5150.0, 6150.0, 7700.0, & -! & 8050.0,12850.0,16000.0,22650.0,29000.0,38000.0, 820.0 / -! data wavenum2(:) / & -! 3250.0, 4000.0, 4650.0, 5150.0, 6150.0, 7700.0, 8050.0, & -! & 12850.0,16000.0,22650.0,29000.0,38000.0,50000.0, 2600.0 / -! real (kind=kind_phys), dimension(NBLOW:NBHGH) :: delwave -! data delwave(:) / & -! & 650.0, 750.0, 650.0, 500.0, 1000.0, 1550.0, 350.0, & -! & 4800.0, 3150.0, 6650.0, 6350.0, 9000.0,12000.0, 1780.0 / - - integer, parameter :: nuvb = 27 !uv-b band index - -! --- reference pressure and temperature -! real (kind=kind_phys), dimension(59) :: pref, preflog, tref - real (kind=kind_phys), dimension(59) :: preflog, tref - -! ... these pressures are chosen such that the ln of the first pressure -! has only a few non-zero digits (i.e. ln(pref(1)) = 6.96000) and -! each subsequent ln(pressure) differs from the previous one by 0.2. - -! data pref(:) / & -! & 1.05363e+03,8.62642e+02,7.06272e+02,5.78246e+02,4.73428e+02, & -! & 3.87610e+02,3.17348e+02,2.59823e+02,2.12725e+02,1.74164e+02, & -! & 1.42594e+02,1.16746e+02,9.55835e+01,7.82571e+01,6.40715e+01, & -! & 5.24573e+01,4.29484e+01,3.51632e+01,2.87892e+01,2.35706e+01, & -! & 1.92980e+01,1.57998e+01,1.29358e+01,1.05910e+01,8.67114e+00, & -! & 7.09933e+00,5.81244e+00,4.75882e+00,3.89619e+00,3.18993e+00, & -! & 2.61170e+00,2.13828e+00,1.75067e+00,1.43333e+00,1.17351e+00, & -! & 9.60789e-01,7.86628e-01,6.44036e-01,5.27292e-01,4.31710e-01, & -! & 3.53455e-01,2.89384e-01,2.36928e-01,1.93980e-01,1.58817e-01, & -! & 1.30029e-01,1.06458e-01,8.71608e-02,7.13612e-02,5.84256e-02, & -! & 4.78349e-02,3.91639e-02,3.20647e-02,2.62523e-02,2.14936e-02, & -! & 1.75975e-02,1.44076e-02,1.17959e-02,9.65769e-03 / - - data preflog(:) / & - & 6.9600e+00, 6.7600e+00, 6.5600e+00, 6.3600e+00, 6.1600e+00, & - & 5.9600e+00, 5.7600e+00, 5.5600e+00, 5.3600e+00, 5.1600e+00, & - & 4.9600e+00, 4.7600e+00, 4.5600e+00, 4.3600e+00, 4.1600e+00, & - & 3.9600e+00, 3.7600e+00, 3.5600e+00, 3.3600e+00, 3.1600e+00, & - & 2.9600e+00, 2.7600e+00, 2.5600e+00, 2.3600e+00, 2.1600e+00, & - & 1.9600e+00, 1.7600e+00, 1.5600e+00, 1.3600e+00, 1.1600e+00, & - & 9.6000e-01, 7.6000e-01, 5.6000e-01, 3.6000e-01, 1.6000e-01, & - & -4.0000e-02,-2.4000e-01,-4.4000e-01,-6.4000e-01,-8.4000e-01, & - & -1.0400e+00,-1.2400e+00,-1.4400e+00,-1.6400e+00,-1.8400e+00, & - & -2.0400e+00,-2.2400e+00,-2.4400e+00,-2.6400e+00,-2.8400e+00, & - & -3.0400e+00,-3.2400e+00,-3.4400e+00,-3.6400e+00,-3.8400e+00, & - & -4.0400e+00,-4.2400e+00,-4.4400e+00,-4.6400e+00 / - -! ... these are the temperatures associated with the respective -! pressures for the MLS standard atmosphere. - data tref(:) / & - & 2.9420e+02, 2.8799e+02, 2.7894e+02, 2.6925e+02, 2.5983e+02, & - & 2.5017e+02, 2.4077e+02, 2.3179e+02, 2.2306e+02, 2.1578e+02, & - & 2.1570e+02, 2.1570e+02, 2.1570e+02, 2.1706e+02, 2.1858e+02, & - & 2.2018e+02, 2.2174e+02, 2.2328e+02, 2.2479e+02, 2.2655e+02, & - & 2.2834e+02, 2.3113e+02, 2.3401e+02, 2.3703e+02, 2.4022e+02, & - & 2.4371e+02, 2.4726e+02, 2.5085e+02, 2.5457e+02, 2.5832e+02, & - & 2.6216e+02, 2.6606e+02, 2.6999e+02, 2.7340e+02, 2.7536e+02, & - & 2.7568e+02, 2.7372e+02, 2.7163e+02, 2.6955e+02, 2.6593e+02, & - & 2.6211e+02, 2.5828e+02, 2.5360e+02, 2.4854e+02, 2.4348e+02, & - & 2.3809e+02, 2.3206e+02, 2.2603e+02, 2.2000e+02, 2.1435e+02, & - & 2.0887e+02, 2.0340e+02, 1.9792e+02, 1.9290e+02, 1.8809e+02, & - & 1.8329e+02, 1.7849e+02, 1.7394e+02, 1.7212e+02 / - -!! ... logical flags for optional output fields - - logical :: lhswb = .false. - logical :: lhsw0 = .false. - logical :: lflxprf= .false. - logical :: lfdncmp= .false. - -! --- those data will be set up only once by "rswinit" - -! ... heatfac is the factor for heating rates -! (in k/day, or k/sec set by subroutine 'rlwinit') - - real (kind=kind_phys) :: heatfac - - public swrad, rswinit - - -! ================= - contains -! ================= - -!----------------------------------- - subroutine swrad & -!................................... - -! --- inputs: - & ( plyr,plvl,tlyr,tlvl,qlyr,olyr,gasvmr, & - & clouds,iovr,aerosols,sfcalb, & - & cosz,solcon,NDAY,idxday, & - & IMAX, NLAY, NLP1, iflip, lprnt, & -! --- outputs: - & hswc,topflx,sfcflx & -!! --- optional: - &, HSW0,HSWB,FLXPRF,FDNCMP & - & ) - -! ==================== defination of variables ==================== ! -! ! -! input variables: ! -! plyr (IMAX,NLAY) : model layer mean pressure in mb ! -! plvl (IMAX,NLP1) : model level pressure in mb ! -! tlyr (IMAX,NLAY) : model layer mean temperature in k ! -! tlvl (IMAX,NLP1) : model level temperature in k (not in use) ! -! qlyr (IMAX,NLAY) : layer specific humidity in gm/gm *see inside ! -! olyr (IMAX,NLAY) : layer ozone concentration in gm/gm ! -! gasvmr(IMAX,NLAY,:): atmospheric constent gases: ! -! (check module_radiation_gases for definition) ! -! gasvmr(:,:,1) - co2 volume mixing ratio ! -! gasvmr(:,:,2) - n2o volume mixing ratio ! -! gasvmr(:,:,3) - ch4 volume mixing ratio ! -! gasvmr(:,:,4) - o2 volume mixing ratio ! -! gasvmr(:,:,5) - co volume mixing ratio (not used) ! -! gasvmr(:,:,6) - cfc11 volume mixing ratio (not used) ! -! gasvmr(:,:,7) - cfc12 volume mixing ratio (not used) ! -! gasvmr(:,:,8) - cfc22 volume mixing ratio (not used) ! -! gasvmr(:,:,9) - ccl4 volume mixing ratio (not used) ! -! clouds(IMAX,NLAY,:): cloud profile ! -! (check module_radiation_clouds for definition) ! -! --- for iflagliq > 0 --- ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! -! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! -! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! -! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! -! clouds(:,:,6) - layer rain drop water path (g/m**2) ! -! clouds(:,:,7) - mean eff radius for rain drop (micron) ! -! clouds(:,:,8) - layer snow flake water path (g/m**2) ! -! ** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) ! -! clouds(:,:,9) - mean eff radius for snow flake (micron) ! -! --- for iflagliq = 0 --- ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer cloud optical depth ! -! clouds(:,:,3) - layer cloud single scattering albedo ! -! clouds(:,:,4) - layer cloud asymmetry factor ! -! iovr : control flag for cloud overlapping (approxi only)! -! =0: random overlapping clouds ! -! =1: max/ran overlapping clouds ! -! aerosols(IMAX,NLAY,NBDSW,:) : aerosol optical properties ! -! (check module_radiation_aerosols for definition) ! -! (:,:,:,1) - optical depth ! -! (:,:,:,2) - single scattering albedo ! -! (:,:,:,3) - asymmetry parameter ! -! sfcalb(IMAX, : ) : surface albedo in fraction ! -! (check module_radiation_surface for definition) ! -! ( :, 1 ) - near ir direct beam albedo ! -! ( :, 2 ) - near ir diffused albedo ! -! ( :, 3 ) - uv+vis direct beam albedo ! -! ( :, 4 ) - uv+vis diffused albedo ! -! cosz (IMAX) : cosine of solar zenith angle ! -! solcon : solar constant (w/m**2) ! -! NDAY : num of daytime points ! -! idxday(IMAX) : index array for daytime points ! -! IMAX : number of horizontal points ! -! NLAY,NLP1 : vertical layer/lavel numbers ! -! iflip : control flag for direction of vertical index ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! lprnt : logical check print flag ! -! ! -! control parameters in module "module_radsw_cntr_para": ! -! iswrate: heating rate unit selections ! -! =1: output in k/day ! -! =2: output in k/second ! -! iaersw : flags for aerosols effect ! -! =0: without aerosol effect ! -! >0: include aerosol effect ! -! imodsw : control flag for 2-stream transfer scheme ! -! =1; delta-eddington (joseph et al., 1976) ! -! =2: pifm (zdunkowski et al., 1980) ! -! =3: discrete ordinates (liou, 1973) ! -! irgassw: control flag for rare gases (ch4,n2o,o2, etc.) ! -! =0: do not include rare gases ! -! =1: include all rare gases ! -! iflagliq:control flag for liq-cloud optical properties ! -! =0: input cloud optical depth, fixed ssa, asy ! -! =1: use hu and stamnes(1993) method for liq cld ! -! =2: not used ! -! iflagice:control flag for ice-cloud optical properties ! -! =0: not used ! -! =1: not used ! -! =2: not used ! -! =3: use fu's method (1996) for ice clouds ! -! ! -! output variables: ! -! hswc (IMAX,NLAY): total sky heating rates (k/sec or k/day) ! -! topflx(IMAX) : radiation fluxes at toa (w/m**2), components: ! -! (check module_radsw_parameters for definition) ! -! upfxc - total sky upward flux at toa ! -! dnflx - total sky downward flux at toa ! -! upfx0 - clear sky upward flux at toa ! -! sfcflx(IMAX) : radiation fluxes at sfc (w/m**2), components: ! -! (check module_radsw_parameters for definition) ! -! upfxc - total sky upward flux at sfc ! -! dnfxc - total sky downward flux at sfc ! -! upfx0 - clear sky upward flux at sfc ! -! dnfx0 - clear sky downward flux at sfc ! -! ! -!!optional outputs: ! -! hswb(IMAX,NLAY,NBDSW): spectral band total sky heating rates ! -! hsw0 (IMAX,NLAY): clear sky heating rates (k/sec or k/day) ! -! flxprf(IMAX,NLP1): level radiation fluxes (w/m**2), components: ! -! (check module_radsw_parameters for definition) ! -! dnfxc - total sky downward flux at interface ! -! upfxc - total sky upward flux at interface ! -! dnfx0 - clear sky downward flux at interface ! -! upfx0 - clear sky upward flux at interface ! -! fdncmp(IMAX) : component surface downward fluxes (w/m**2): ! -! (check module_radsw_parameters for definition) ! -! uvbfc - total sky downward uv-b flux at sfc ! -! uvbf0 - clear sky downward uv-b flux at sfc ! -! nirbm - downward surface nir direct beam flux ! -! nirdf - downward surface nir diffused flux ! -! visbm - downward surface uv+vis direct beam flux ! -! visdf - downward surface uv+vis diffused flux ! -! ! -! module parameters, control and local variables: ! -! NBLOW,NBHGH - lower and upper limits of spectral bands ! -! MAXGAS - maximum number of absorbing gaseous ! -! NGPT - total number of g-point subintervals ! -! NGnn (nn=16-29) - number of g-points in band nn ! -! NSPA,NSPB(NBLOW:NBHGH)- number of lower/upper ref atm's per band ! -! pavel (NLAY) - layer pressures (mb) ! -! delp (NLAY) - layer pressure thickness (mb) ! -! tavel (NLAY) - layer temperatures (k) ! -! coldry (NLAY) - dry air column amount ! -! (1.e-20*molecules/cm**2) ! -! colamt (NLAY,MAXGAS) - column amounts of absorbing gases ! -! 1-MAXGAS are for watervapor, carbon ! -! dioxide, ozone, nitrous oxide, methane, ! -! oxigen, respectively (molecules/cm**2) ! -! facij (NLAY) - indicator of interpolation factors ! -! =0/1: indicate lower/higher temp & height ! -! selffac(NLAY) - scale factor for self-continuum, equals ! -! (w.v. density)/(atm density at 296K,1013 mb) ! -! selffrac(NLAY) - factor for temp interpolation of ref ! -! self-continuum data ! -! indself(NLAY) - index of the lower two appropriate ref ! -! temp for the self-continuum interpolation ! -! laytrop ! -! - layer at which switch is made from one ! -! combination of key species to another ! -! pfup (IMAX,NLP1) - total sky upward flux (w/m2) ! -! pcup (IMAX,NLP1) - clear sky upward flux (w/m2) ! -! pfdown(IMAX,NLP1) - total sky downward flux (w/m2) ! -! pcdown(IMAX,NLP1) - clear sky downward flux (w/m2) ! -! pheat (IMAX,NLP1) - total sky heating rate (k/day or k/sec) ! -! pheac (IMAX,NLP1) - clear sky heating rate (k/day or k/sec) ! -! ! -! ! -! program history: ! -! 2003-02-25 j.-j. morcrette, ecmwf, interface to rrtm_sw; ! -! conversion to f90 formatting; addition of 2-stream ! -! radiative transfer. ! -! 2003-08-xx m. j. iacono, aer inc., additional modifications ! -! for gcm application. ! -! 2004-01-20 y.-t. hou, ncep, modified for ncep gfs models, ! -! recode into standard modular format. ! -! 2004-06-28 y.-t. hou, ncep, modified to use aer's rrtmg-sw! -! v2.0 reduced g-point code (112 points). ! -! 2005-03-10 y.-t. hou, ncep, modified to use aer's rrtmg-sw! -! v2.3 to correct double scaling in early version ! -! ! -! ===================== end of definitions ==================== ! -! - implicit none - -! --- inputs: - integer, intent(in) :: IMAX, NLAY, NLP1, iovr, iflip, NDAY - - integer, intent(in) :: idxday(:) - - logical, intent(in) :: lprnt - - real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, tlvl, & - & plyr, tlyr, qlyr, olyr, sfcalb - - real (kind=kind_phys), dimension(:,:,:), intent(in) :: gasvmr, & - & clouds - real (kind=kind_phys), dimension(:,:,:,:), intent(in) :: aerosols - - real (kind=kind_phys), intent(in) :: cosz(:), solcon - -! --- outputs: - real (kind=kind_phys), dimension(:,:), intent(out) :: hswc - - type (topfsw_type), dimension(:), intent(out) :: topflx - type (sfcfsw_type), dimension(:), intent(out) :: sfcflx - -!! --- optional outputs: - real (kind=kind_phys),dimension(:,:,:),optional,intent(out):: hswb - real (kind=kind_phys),dimension(:,:), optional,intent(out):: hsw0 - type (profsw_type), dimension(:,:),optional, intent(out) :: flxprf - type (cmpfsw_type), dimension(:), optional, intent(out) :: fdncmp - -! --- locals: - real (kind=kind_phys), dimension(NLAY) :: pavel, tavel, delp, & - & coldry, colmol, h2ovmr, o3vmr, temcol - - real (kind=kind_phys), dimension(NLAY) :: cfrac, cliqp, reliq, & - & cicep, reice, cdat1, cdat2, cdat3, cdat4, zclfr - - real (kind=kind_phys), dimension(NLAY) :: plog, forfac, forfrac, & - & selffac, selffrac, fac00, fac01, fac10, fac11 - - real (kind=kind_phys), dimension(NLAY,NBLOW:NBHGH) :: & - & taucw, ssacw, asycw, tauae, ssaae, asyae - - real (kind=kind_phys), dimension(2) :: albbm, albdf - - real (kind=kind_phys) :: colamt(NLAY,MAXGAS) - - real (kind=kind_phys), dimension(NLP1) :: fnetc, flxdc, flxuc, & - & flxd0, flxu0 - real (kind=kind_phys), dimension(NLP1,NBDSW) :: flxdcb, flxucb, & - & flxd0b, flxu0b - - real (kind=kind_phys) :: cosz1, sntz1, tem0, tem1, tem2, s0fac, & - & fp, fp1, ft, ft1, ssolar, zdpgcp, zcf0, zcf1 - -!! --- for optional outputs - real (kind=kind_phys), dimension(2) :: sfbmc, sfbm0, sfdfc, sfdf0 - real (kind=kind_phys) :: suvbf0, suvbfc - real (kind=kind_phys) :: fnet0(NLP1), fnetb(NLP1,NBDSW) - - integer, dimension(NLAY) :: indfor, indself, jp, jt, jt1 - - integer :: i, ib, ipts, j1, j2, k, kk, jp1, laytrop, mb - -! -!===> ... begin here -! - - lhswb = present ( hswb ) - lhsw0 = present ( hsw0 ) - lflxprf= present ( flxprf ) - lfdncmp= present ( fdncmp ) - -! --- s0, the solar constant at toa in w/m**2, is hard-coded with -! each spectra band, the total flux is about 1368.22 w/m**2. - - s0fac = solcon / s0 - -! --- initial output arrays - - hswc(:,:) = zero - topflx = topfsw_type ( zero, zero, zero ) - sfcflx = sfcfsw_type ( zero, zero, zero, zero ) - -!! --- initial optional outputs - if ( lflxprf ) then - flxprf = profsw_type ( zero, zero, zero, zero ) - endif - - if ( lfdncmp ) then - fdncmp = cmpfsw_type ( zero, zero, zero, zero, zero, zero ) - endif - - if ( lhsw0 ) then - hsw0(:,:) = zero - endif - - if ( lhswb ) then - hswb(:,:,:) = zero - endif - -! --- loop over each daytime grid point - - lab_do_ipts : do ipts = 1, NDAY - - j1 = idxday(ipts) - - cosz1 = cosz(j1) - sntz1 = one / cosz(j1) - ssolar = s0fac * cosz(j1) - zcf0 = one - zcf1 = one - laytrop= NLAY - -! --- surface albedo - albbm(1) = sfcalb(j1,1) - albdf(1) = sfcalb(j1,2) - albbm(2) = sfcalb(j1,3) - albdf(2) = sfcalb(j1,4) - -! --- prepare atmospheric profile for use in rrtm -! the vertical index of internal array is from surface to top - - if (iflip == 0) then ! input from toa to sfc - - tem1 = 100.0 * con_g - tem2 = 1.0e-20 * 1.0e3 * con_avgd - - do k = 1, NLAY - kk = NLP1 - k - pavel(k) = plyr(j1,kk) - tavel(k) = tlyr(j1,kk) - delp (k) = plvl(j1,kk+1) - plvl(j1,kk) - -! --- set absorber amount -!test use -! h2ovmr(k)= max(zero,qlyr(j1,kk)*amdw) ! input mass mixing ratio -! h2ovmr(k)= max(zero,qlyr(j1,kk)) ! input vol mixing ratio -!ncep model use - h2ovmr(k)= max(zero,qlyr(j1,kk)*amdw/(1.0-qlyr(j1,kk))) ! input specific humidity - o3vmr (k)= max(zero,olyr(j1,kk)*amdo3) ! input mass mixing ratio -!test use o3vmr (k)= max(zero,olyr(j1,kk)) ! input vol mixing ratio - - tem0 = (one - h2ovmr(k))*con_amd + h2ovmr(k)*con_amw - coldry(k) = tem2 * delp(k) / (tem1*tem0*(one + h2ovmr(k))) - temcol(k) = 1.0e-12 * coldry(k) - - colamt(k,1) = coldry(k)*h2ovmr(k) ! h2o - colamt(k,2) = max(temcol(k), coldry(k)*gasvmr(j1,kk,1)) ! co2 - colamt(k,3) = coldry(k)*o3vmr(k) ! o3 - enddo - -! --- set aerosol optical properties - - if (iaersw > 0) then - do ib = 1, NBDSW - j2 = NBLOW + ib -1 - - do k = 1, NLAY - kk = NLP1 - k - - tauae(k,j2) = aerosols(j1,kk,ib,1) - ssaae(k,j2) = aerosols(j1,kk,ib,2) - asyae(k,j2) = aerosols(j1,kk,ib,3) - enddo - enddo - else - tauae(:,:) = zero - ssaae(:,:) = zero - asyae(:,:) = zero - endif - - if (iflagliq > 0) then ! use prognostic cloud method - do k = 1, NLAY - kk = NLP1 - k - cfrac(k) = clouds(j1,kk,1) - cliqp(k) = clouds(j1,kk,2) - reliq(k) = clouds(j1,kk,3) - cicep(k) = clouds(j1,kk,4) - reice(k) = clouds(j1,kk,5) - cdat1(k) = clouds(j1,kk,6) - cdat2(k) = clouds(j1,kk,7) - cdat3(k) = clouds(j1,kk,8) - cdat4(k) = clouds(j1,kk,9) - enddo - else ! use diagnostic cloud method - do k = 1, NLAY - kk = NLP1 - k - cfrac(k) = clouds(j1,kk,1) - cdat1(k) = clouds(j1,kk,2) - cdat2(k) = clouds(j1,kk,3) - cdat3(k) = clouds(j1,kk,4) - enddo - endif ! end if_iflagliq - - else ! input from sfc to toa - - tem1 = 100.0 * con_g - tem2 = 1.0e-20 * 1.0e3 * con_avgd - - do k = 1, NLAY - pavel(k) = plyr(j1,k) - tavel(k) = tlyr(j1,k) - delp (k) = plvl(j1,k) - plvl(j1,k+1) - -! --- set absorber amount -!test use -! h2ovmr(k)= max(zero,qlyr(j1,k)*amdw) ! input mass mixing ratio -! h2ovmr(k)= max(zero,qlyr(j1,k)) ! input vol mixing ratio -!ncep model use - h2ovmr(k)= max(zero,qlyr(j1,k)*amdw/(1.0-qlyr(j1,k))) ! input specific humidity - o3vmr (k)= max(zero,olyr(j1,k)*amdo3) ! input mass mixing ratio -!test use o3vmr (k)= max(zero,olyr(j1,k)) ! input vol mixing ratio - - tem0 = (one - h2ovmr(k))*con_amd + h2ovmr(k)*con_amw - coldry(k) = tem2 * delp(k) / (tem1*tem0*(one + h2ovmr(k))) - temcol(k) = 1.0e-12 * coldry(k) - - colamt(k,1) = coldry(k)*h2ovmr(k) ! h2o - colamt(k,2) = max(temcol(k), coldry(k)*gasvmr(j1,k,1)) ! co2 - colamt(k,3) = coldry(k)*o3vmr(k) ! o3 - enddo - -! --- set aerosol optical properties - - if (iaersw > 0) then - do ib = 1, NBDSW - j2 = NBLOW + ib -1 - - do k = 1, NLAY - tauae(k,j2) = aerosols(j1,k,ib,1) - ssaae(k,j2) = aerosols(j1,k,ib,2) - asyae(k,j2) = aerosols(j1,k,ib,3) - enddo - enddo - else - tauae(:,:) = zero - ssaae(:,:) = zero - asyae(:,:) = zero - endif - - if (iflagliq > 0) then ! use prognostic cloud method - do k = 1, NLAY - cfrac(k) = clouds(j1,k,1) - cliqp(k) = clouds(j1,k,2) - reliq(k) = clouds(j1,k,3) - cicep(k) = clouds(j1,k,4) - reice(k) = clouds(j1,k,5) - cdat1(k) = clouds(j1,k,6) - cdat2(k) = clouds(j1,k,7) - cdat3(k) = clouds(j1,k,8) - cdat4(k) = clouds(j1,k,9) - enddo - else ! use diagnostic cloud method - do k = 1, NLAY - cfrac(k) = clouds(j1,k,1) - cdat1(k) = clouds(j1,k,2) - cdat2(k) = clouds(j1,k,3) - cdat3(k) = clouds(j1,k,4) - enddo - endif ! end if_iflagliq - - endif ! if_iflip - -! --- set up gas column amount, convert from volume mixing ratio to -! molec/cm2 based on coldry (scaled to 1.0e-20) - - if (iflip == 0) then ! input from toa to sfc - - if (irgassw == 1) then - do k = 1, NLAY - kk = NLP1 - k - colamt(k,4) = max(temcol(k), coldry(k)*gasvmr(j1,kk,2)) ! n2o - colamt(k,5) = max(temcol(k), coldry(k)*gasvmr(j1,kk,3)) ! ch4 - colamt(k,6) = max(temcol(k), coldry(k)*gasvmr(j1,kk,4)) ! o2 -! colamt(k,7) = max(temcol(k), coldry(k)*gasvmr(j1,kk,5)) ! co - notused - enddo - else - do k = 1, NLAY - colamt(k,4) = temcol(k) ! n2o - colamt(k,5) = temcol(k) ! ch4 - colamt(k,6) = temcol(k) ! o2 -! colamt(k,7) = temcol(k) ! co - notused - enddo - endif - - else ! input from sfc to toa - - if (irgassw == 1) then - do k = 1, NLAY - colamt(k,4) = max(temcol(k), coldry(k)*gasvmr(j1,k,2)) ! n2o - colamt(k,5) = max(temcol(k), coldry(k)*gasvmr(j1,k,3)) ! ch4 - colamt(k,6) = max(temcol(k), coldry(k)*gasvmr(j1,k,4)) ! o2 -! colamt(k,7) = max(temcol(k), coldry(k)*gasvmr(j1,k,5)) ! co - notused - enddo - else - do k = 1, NLAY - colamt(k,4) = temcol(k) ! n2o - colamt(k,5) = temcol(k) ! ch4 - colamt(k,6) = temcol(k) ! o2 -! colamt(k,7) = temcol(k) ! co - notused - enddo - endif - - endif ! if_iflip - -! --- compute fractions of clear sky view - - if (iovr == 0) then ! random overlapping - do k = 1, NLAY - zcf0 = zcf0 * (one - cfrac(k)) - enddo - else if (iovr == 1) then ! max/ran overlapping - do k = 1, NLAY - if (cfrac(k) > eps) then ! cloudy layer - zcf1 = min ( zcf1, one-cfrac(k) ) - elseif (zcf1 < one) then ! clear layer - zcf0 = zcf0 * zcf1 - zcf1 = one - endif - enddo - zcf0 = zcf0 * zcf1 - else if (iovr == 2) then ! maximum overlapping - do k = 1, NLAY - zcf0 = min ( zcf0, one-cfrac(k) ) - enddo - else - print *,' invalid specification of iovr =',iovr - stop - endif - - if (zcf0 <= eps) zcf0 = zero - if (zcf0 > oneminus) zcf0 = one - zcf1 = one - zcf0 - - if (zcf1 <= eps) then - do k=1, NLAY - zclfr(k) = zero - enddo - else - do k=1, NLAY - zclfr(k) = cfrac(k) / zcf1 - enddo - endif -! -!===> ... compute cloud optical properties -! - - call cldprop & -! --- inputs: - & ( cfrac,cliqp,reliq,cicep,reice,cdat1,cdat2,cdat3,cdat4, & - & NLAY, & -! --- output: - & taucw, ssacw, asycw & - & ) - -! --- calculate needed column amounts. using e = 1334.2 cm-1. - - do k = 1, NLAY - colmol(k) = coldry(k) + colamt(k,1) - forfac(k) = pavel(k)*stpfac / (tavel(k)*(one + h2ovmr(k))) - enddo - - do k = 1, NLAY - -! --- find the two reference pressures on either side of the -! layer pressure. store them in jp and jp1. store in fp the -! fraction of the difference (in ln(pressure)) between these -! two values that the layer pressure lies. - - plog(k) = log(pavel(k)) - jp(k) = max(1, min(58, int(36.0 - 5.0*(plog(k)+0.04)) )) - jp1 = jp(k) + 1 - fp = 5.0 * (preflog(jp(k)) - plog(k)) - -! --- determine, for each reference pressure (jp and jp1), which -! reference temperature (these are different for each -! reference pressure) is nearest the layer temperature but does -! not exceed it. store these indices in jt and jt1, resp. -! store in ft (resp. ft1) the fraction of the way between jt -! (jt1) and the next highest reference temperature that the -! layer temperature falls. - - tem1 = (tavel(k) - tref(jp(k))) / 15.0 - tem2 = (tavel(k) - tref(jp1 )) / 15.0 - jt (k) = max(1, min(4, int(3.0 + tem1) )) - jt1(k) = max(1, min(4, int(3.0 + tem2) )) - ft = tem1 - float(jt (k) - 3) - ft1 = tem2 - float(jt1(k) - 3) - -! --- we have now isolated the layer ln pressure and temperature, -! between two reference pressures and two reference temperatures -! (for each reference pressure). we multiply the pressure -! fraction fp with the appropriate temperature fractions to get -! the factors that will be needed for the interpolation that yields -! the optical depths (performed in routines taugbn for band n). - - fp1 = one - fp - fac10(k) = fp1 * ft - fac00(k) = fp1 * (one - ft) - fac11(k) = fp * ft1 - fac01(k) = fp * (one - ft1) - - enddo ! end_do_k_loop - - do k = 1, NLAY - -! --- if the pressure is less than ~100mb, perform a different -! set of species interpolations. - - if (plog(k) > 4.56) then - laytrop = k - -! --- set up factors needed to separately include the water vapor -! foreign-continuum in the calculation of absorption coefficient. - - tem1 = (332.0 - tavel(k)) / 36.0 - indfor (k) = min(2, max(1, int(tem1))) - forfrac(k) = tem1 - float(indfor(k)) - -! --- set up factors needed to separately include the water vapor -! self-continuum in the calculation of absorption coefficient. - - tem2 = (tavel(k) - 188.0) / 7.2 - indself (k) = min(9, max(1, int(tem2)-7)) - selffrac(k) = tem2 - float(indself(k) + 7) - selffac (k) = h2ovmr(k) * forfac(k) - else -! --- set up factors needed to separately include the water vapor -! foreign-continuum in the calculation of absorption coefficient. - - tem1 = (tavel(k) - 188.0) / 36.0 - indfor (k) = 3 - forfrac(k) = tem1 - one - - indself (k) = 0 - selffrac(k) = zero - selffac (k) = zero - endif - - enddo ! end_do_k_loop - - if ( lfdncmp ) then - - call spcvrt & -! --- inputs: - & ( colamt, colmol, coldry, cosz1, sntz1, albbm, albdf, & - & zcf1, zclfr, taucw, ssacw, asycw, tauae, ssaae, asyae, & - & forfac, forfrac, indfor, selffac, selffrac, indself, & - & fac00, fac01, fac10, fac11, jp, jt, jt1, laytrop, & - & NLAY, NLP1, & -! --- outputs: - & flxdcb, flxucb, flxd0b, flxu0b & -!! --- optional outputs: - &, SFBMC=sfbmc,SFDFC=sfdfc,SFBM0=sfbm0,SFDF0=sfdf0 & - &, SUVBF0=suvbf0,SUVBFC=suvbfc & - & ) - -!! --- optional uv-b surface downward flux - fdncmp(j1)%uvbf0 = ssolar * suvbf0 - fdncmp(j1)%uvbfc = ssolar * (zcf1*suvbfc + zcf0*suvbf0) - -!! --- optional beam and diffuse sfc fluxes - fdncmp(j1)%nirbm = ssolar * (zcf1*sfbmc(1) + zcf0*sfbm0(1)) - fdncmp(j1)%nirdf = ssolar * (zcf1*sfdfc(1) + zcf0*sfdf0(1)) - fdncmp(j1)%visbm = ssolar * (zcf1*sfbmc(2) + zcf0*sfbm0(2)) - fdncmp(j1)%visdf = ssolar * (zcf1*sfdfc(2) + zcf0*sfdf0(2)) - - else - - call spcvrt & -! --- inputs: - & ( colamt, colmol, coldry, cosz1, sntz1, albbm, albdf, & - & zcf1, zclfr, taucw, ssacw, asycw, tauae, ssaae, asyae, & - & forfac, forfrac, indfor, selffac, selffrac, indself, & - & fac00, fac01, fac10, fac11, jp, jt, jt1, laytrop, & - & NLAY, NLP1, & -! --- outputs: - & flxdcb, flxucb, flxd0b, flxu0b & - & ) - - endif ! end if_lfdncmp - - do mb = 1, NBDSW - do k = 1, NLP1 - flxucb(k,mb) = zcf1*flxucb(k,mb) + zcf0*flxu0b(k,mb) - flxdcb(k,mb) = zcf1*flxdcb(k,mb) + zcf0*flxd0b(k,mb) - enddo - enddo - - do k = 1, NLP1 - flxuc(k) = zero - flxdc(k) = zero - flxu0(k) = zero - flxd0(k) = zero - enddo - - do k = 1, NLP1 - do mb = 1, NBDSW - flxuc(k) = flxuc(k) + flxucb(k,mb) - flxdc(k) = flxdc(k) + flxdcb(k,mb) - flxu0(k) = flxu0(k) + flxu0b(k,mb) - flxd0(k) = flxd0(k) + flxd0b(k,mb) - enddo - enddo - - do k = 1, NLP1 - flxuc(k) = ssolar * flxuc(k) - flxdc(k) = ssolar * flxdc(k) - flxu0(k) = ssolar * flxu0(k) - flxd0(k) = ssolar * flxd0(k) - fnetc(k) = flxdc(k) - flxuc(k) - enddo - -! --- toa and sfc fluxes - topflx(j1)%upfxc = flxuc(NLP1) - topflx(j1)%dnfxc = flxdc(NLP1) - topflx(j1)%upfx0 = flxu0(NLP1) - - sfcflx(j1)%upfxc = flxuc(1) - sfcflx(j1)%dnfxc = flxdc(1) - sfcflx(j1)%upfx0 = flxu0(1) - sfcflx(j1)%dnfx0 = flxd0(1) - - if (iflip == 0) then ! output from toa to sfc - -! --- compute heating rates - do k = 1, NLAY - kk = NLP1 - k - hswc(j1,kk) = (fnetc(k+1) - fnetc(k)) * heatfac / delp(k) - enddo - -!! --- optional flux profiles - if ( lflxprf ) then - do k = 1, NLP1 - kk = NLP1 - k + 1 - flxprf(j1,kk)%upfxc = flxuc(k) - flxprf(j1,kk)%dnfxc = flxdc(k) - flxprf(j1,kk)%upfx0 = flxu0(k) - flxprf(j1,kk)%dnfx0 = flxd0(k) - enddo - endif - -!! --- optional clear sky heating rates - if ( lhsw0 ) then - fnet0(:) = flxd0(:) - flxu0(:) - - do k = 1, NLAY - kk = NLP1 - k - hsw0(j1,kk) = (fnet0(k+1) - fnet0(k)) * heatfac / delp(k) - enddo - endif - -!! --- optional spectral band heating rates - if ( lhswb ) then - fnetb(:,:) = ssolar * (flxdcb(:,:) - flxucb(:,:)) - - do k = 1, NLAY - kk = NLP1 - k - do mb = 1, NBDSW - hswb(j1,kk,mb) = (fnetb(k+1,mb) - fnetb(k,mb)) & - & * heatfac / delp(k) - enddo - enddo - endif - - else ! output from sfc to toa - -! --- compute heating rates - do k = 1, NLAY - hswc(j1,k) = (fnetc(k+1) - fnetc(k)) * heatfac / delp(k) - enddo - -!! --- optional flux profiles - if ( lflxprf ) then - do k = 1, NLP1 - flxprf(j1,k)%upfxc = flxuc(k) - flxprf(j1,k)%dnfxc = flxdc(k) - flxprf(j1,k)%upfx0 = flxu0(k) - flxprf(j1,k)%dnfx0 = flxd0(k) - enddo - endif - -!! --- optional clear sky heating rates - if ( lhsw0 ) then - fnet0(:) = flxd0(:) - flxu0(:) - - do k = 1, NLAY - hsw0(j1,k) = (fnet0(k+1) - fnet0(k)) * heatfac / delp(k) - enddo - endif - -!! --- optional spectral band heating rates - if ( lhswb ) then - fnetb(:,:) = ssolar * (flxdcb(:,:) - flxucb(:,:)) - - do k = 1, NLAY - do mb = 1, NBDSW - hswb(j1,k,mb) = (fnetb(k+1,mb) - fnetb(k,mb)) & - & * heatfac / delp(k) - enddo - enddo - endif - - endif ! if_iflip - - enddo lab_do_ipts - - return -!................................... - end subroutine swrad -!----------------------------------- - - - -!----------------------------------- - subroutine rswinit & -!................................... - -! --- inputs: - & ( icwp, me, NLAY ) -! --- outputs: (none) - -! ******************************************************************* ! -! ! -! inputs: ! -! icwp - flag of cloud schemes used by model ! -! =0: diagnostic scheme gives cloud tau, omiga, and g ! -! =1: prognostic scheme gives cloud liq/ice path, etc. ! -! me - print control for parallel process ! -! NLAY - number of vertical layers ! -! ! -! outputs: (none) ! -! ! -! control flags in module "module_radsw_cntr_para": ! -! iswrate - heating rate unit selections ! -! =1: output in k/day ! -! =2: output in k/second ! -! iaersw - flags for aerosols effect ! -! =0: without aerosol effect ! -! >0: include aerosol effect ! -! imodsw - control flag for 2-stream transfer scheme ! -! =1; delta-eddington (joseph et al., 1976) ! -! =2: pifm (zdunkowski et al., 1980) ! -! =3: discrete ordinates (liou, 1973) ! -! irgassw - control flag for rare gases (ch4,n2o,o2, etc.) ! -! =0: do not include rare gases ! -! =1: include all rare gases ! -! iflagliq- cloud optical properties contrl flag ! -! =0: input cloud opt depth from diagnostic scheme ! -! >0: input cwp,cip, and other cloud content parameters ! -! ! -! ******************************************************************* ! -! - implicit none -! -! --- inputs: - integer, intent(in) :: icwp, me, NLAY - -! --- outputs: none - - -! --- locals: - -! -!===> ... begin here -! - - if (me == 0) then - print *,' - Using AER Shortwave Radiation, Version: ',VTAGSW - - if (imodsw == 1) then - print *,' --- Delta-eddington 2-stream transfer scheme' - else if (imodsw == 2) then - print *,' --- PIFM 2-stream transfer scheme' - else if (imodsw == 3) then - print *,' --- Discrete ordinates 2-stream transfer scheme' - endif - - if (iaersw == 0) then - print *,' --- Aerosol effect is NOT included in SW, all' & - & ,' internal aerosol parameters are reset to zeros' - else - print *,' --- Using input aerosol parameters for SW' - endif - - if (irgassw == 0) then - print *,' --- Rare gases absorption is NOT included in SW' - else - print *,' --- Include rare gases N2O, CH4, O2, absorptions',& - & ' in SW' - endif - endif - -! --- ... check cloud flags for consistency - - if ((icwp == 0 .and. iflagliq /= 0) .or. & - & (icwp == 1 .and. iflagliq == 0)) then - print *, ' *** Model cloud scheme inconsistent with SW', & - & ' radiation cloud radiative property setup !!' -!jbao stop - stop - endif - -! --- ... setup constant factors for heating rate -! the 1.0e-2 is to convert pressure from mb to N/m**2 - - if (iswrate == 1) then -! heatfac = con_g * 86400. * 1.0e-2 / con_cp ! (in k/day) - heatfac = con_g * 864.0 / con_cp ! (in k/day) -! heatfac = 8.4391 - else - heatfac = con_g * 1.0e-2 / con_cp ! (in k/second) - endif - - return -!................................... - end subroutine rswinit -!----------------------------------- - - - -!----------------------------------- - subroutine cldprop & -!................................... - -! --- inputs: - & ( cfrac,cliqp,reliq,cicep,reice,cdat1,cdat2,cdat3,cdat4, & - & NLAY, & -! --- output: - & taucw, ssacw, asycw & - & ) - -! ******************************************************************* ! -! ! -! compute the cloud optical property functions for each cloudy layer ! -! ! -! ! -! inputs: ! -! cfrac(NLAY) - layer cloud fraction ! -! --- for iflagliq > 0 --- ! -! cliqp(NLAY) - layer cloud liq water path (g/m**2) ! -! reliq(NLAY) - mean effective radius for liq cloud (micron) ! -! cicep(NLAY) - layer cloud ice water path (g/m**2) ! -! reice(NLAY) - mean effective radius for ice cloud (micron) ! -! cdat1(NLAY) - layer rain drop water path (g/m**2) -not used- ! -! cdat2(NLAY) - mean eff radius for rain drop (micron) -not used- ! -! cdat3(NLAY) - layer snow flake water path(g/m**2) -not used- ! -! ** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) ! -! cdat4(NLAY) - mean effective radius for snow flake(micron) ! -! --- for iflagliq = 0 --- ! -! cdat1(NLAY) - layer cloud optical depth ! -! cdat2(NLAY) - layer cloud single scattering albedo ! -! cdat3(NLAY) - layer cloud asymmetry factor ! -! cdat4(NLAY) - optional use ! -! cliqp(NLAY) - not used ! -! reliq(NLAY) - not used ! -! cicep(NLAY) - not used ! -! reice(NLAY) - not used ! -! ! -! NLAY - vertical layer number ! -! ! -! outputs: ! -! taucw(NLAY,NBLOW:NBHGH) - cloud optical depth ! -! ssacw(NLAY,NBLOW:NBHGH) - weighted cloud single scattering albedo ! -! (ssa = ssacw / taucw) ! -! asycw(NLAY,NBLOW:NBHGH) - weighted cloud asymmetry factor ! -! (asy = asycw / ssacw) ! -! ! -! ******************************************************************* ! -! ! -! explanation of the method for each value of iflagliq, and iflagice.! -! set up in module "module_radlw_cntr_para" ! -! ! -! iflagliq=0 : input cloud optical property (tau, ssa, asy). ! -! (used for diagnostic cloud method) ! -! iflagliq>0 : input cloud liq/ice path and effective radius, also ! -! require the user of 'iflagice' to specify the method ! -! used to compute aborption due to water/ice parts. ! -! ................................................................... ! -! ! -! iflagliq=0: for each cloudy layer, the cloud fraction and (gray) ! -! optical depth, single scattring albedo, and asymmetry! -! factor are inputs. ! -! iflagliq=1: for each cloudy layer, the cloud liquid path, eff. ! -! radius for water cloud are inputs, use method by ! -! hu and stamnes, 1993, j., clim. ! -! ! -! iflagice used only when iglagliq >= 1 ! -! ! -! iflagice=3: the cloud ice path (g/m2) and ice effective radius ! -! (microns) are input and the optical depths due to ice! -! clouds are computed as in fu, 1996, j. clim. ! -! ! -! ! -! ******************************************************************* ! -! original description: ! -! ! -! path: $source: /storm/rc1/cvsroot/rc/rrtm_sw/src/cldprop_sw.f,v ! -! author: $author: jdelamer ! -! revision: $revision: 2.6 ! -! created: $date: 2002/04/04 18:29:47 ! -! ! -! purpose: compute the cloud optical depth(s) for each cloudy ! -! layer. note: only inflag = 0 and inflag=2/liqflag=1/iceflag=3 ! -! (hu & stamnes, q. fu) are implemented. ! -! ! -! ******************************************************************* ! -! - use module_radsw_cldprtb -! - implicit none - -! --- inputs: - integer, intent(in) :: NLAY - - real (kind=kind_phys), dimension(:), intent(in) :: cfrac, & - & cliqp, reliq, cicep, reice, cdat1, cdat2, cdat3, cdat4 - -! --- outputs: - real (kind=kind_phys), dimension(:,NBLOW:), intent(out) :: & - & taucw, ssacw, asycw - -! --- locals: - real (kind=kind_phys), dimension(NBLOW:NBHGH) :: fdelta, & - & extcoice, ssacoice, asycoice, forcoice, & - & extcoliq, ssacoliq, asycoliq, forcoliq - - real (kind=kind_phys) :: ffliq0, ffliq1, ffice0, ffice1, & - & cldliq, refliq, tauliq, ssaliq, asyliq, factor, fint, & - & cldice, refice, tauice, ssaice, asyice, & - & cldrain, refrain, taurain, ssarain, asyrain, & - & cldsnow, refsnow, tausnow, ssasnow, asysnow - - integer :: ib, k, index - -! -!===> ... begin here -! - do ib = NBLOW, NBHGH - do k = 1, NLAY - taucw(k,ib) = zero - ssacw(k,ib) = zero - asycw(k,ib) = zero - enddo - enddo - - lab_do_k : do k = 1, NLAY - - lab_if_cfrac : if (cfrac(k) >= eps) then - -! --- ... ice clouds and water clouds combined. - lab_if_liq : if (iflagliq == 0) then - - do ib = NBLOW, NBHGH - taucw(k,ib) = cdat1(k) - ssacw(k,ib) = cdat2(k) * cdat1(k) - asycw(k,ib) = cdat3(k) * ssacw(k,ib) - enddo - -! --- ... separate treatement of ice clouds and water clouds. - else lab_if_liq - - cldliq = cliqp(k) - refliq = max(2.5e0, min(59.5e0, real(reliq(k)) )) -!error refliq = max(1.5e0, min(60.0e0, real(reliq(k)) )) - - cldice = cicep(k) -! --- ... based on FU, factor 1.5396=8/(3*sqrt(3)) converts -! effective radius to generalized ice particle size - refice = max(10.e0, min(140.e0, 1.5396*reice(k) )) - - cldrain = cdat1(k) - refrain = cdat2(k) - cldsnow = cdat3(k) - refsnow = cdat4(k) - -! --- ... calculation of absorption coefficients due to water clouds. - if (cldliq <= zero) then - do ib = NBLOW, NBHGH - extcoliq(ib) = zero - ssacoliq(ib) = one - asycoliq(ib) = one - forcoliq(ib) = zero - enddo - else - if (iflagliq == 1) then - factor = refliq - 1.5 - index = max(1, min(57, int(factor) )) - fint = factor - index - - do ib = NBLOW, NBHGH - extcoliq(ib) = extdatliq1(index,ib) + fint & - & * (extdatliq1(index+1,ib) - extdatliq1(index,ib)) - ssacoliq(ib) = ssadatliq1(index,ib) + fint & - & * (ssadatliq1(index+1,ib) - ssadatliq1(index,ib)) - asycoliq(ib) = asydatliq1(index,ib) + fint & - & * (asydatliq1(index+1,ib) - asydatliq1(index,ib)) - forcoliq(ib) = asycoliq(ib) * asycoliq(ib) - enddo - else - print *,' Undefined selection of iflagliq =',iflagliq - stop - endif - endif ! end if_cldliq - -! --- ... calculation of absorption coefficients due to ice clouds. - if (cldice <= zero) then - do ib = NBLOW, NBHGH - extcoice(ib) = zero - ssacoice(ib) = one - asycoice(ib) = one - forcoice(ib) = zero - enddo - else - if (iflagice == 3) then - factor = (refice - 5.0) / 5.0 - index = max(1, min(26, int(factor) )) - fint = factor - index - - do ib = NBLOW, NBHGH - extcoice(ib) = extdatice3(index,ib) + fint & - & * (extdatice3(index+1,ib) - extdatice3(index,ib)) - ssacoice(ib) = ssadatice3(index,ib) + fint & - & * (ssadatice3(index+1,ib) - ssadatice3(index,ib)) - asycoice(ib) = asydatice3(index,ib) + fint & - & * (asydatice3(index+1,ib) - asydatice3(index,ib)) - fdelta (ib) = min(one, max(zero, & - & fdldatice3(index,ib) + fint & - & * (fdldatice3(index+1,ib) - fdldatice3(index,ib)))) - - forcoice(ib) = min(asycoice(ib), & - & fdelta(ib) + 0.5/ssacoice(ib) ) ! see fu 1996 p. 2067 - enddo - else - print *,' Undefined selection of iflagice =',iflagice - stop - endif - endif ! end if_cldice - -! --- ... optical depth for rain and snow - - taurain = cldrain * a0r - if (cldsnow>zero .and. refsnow>10.0) then - tausnow = cldsnow * (a0s + a1s/refsnow) - else - tausnow = zero - endif - - do ib = NBLOW, NBHGH - tauliq = cldliq * extcoliq(ib) - ssaliq = tauliq * ssacoliq(ib) - asyliq = ssaliq * asycoliq(ib) - - tauice = cldice * extcoice(ib) - ssaice = tauice * ssacoice(ib) - asyice = ssaice * asycoice(ib) - - ssarain = taurain * (one - b0r(ib)) - asyrain = ssarain * c0r(ib) - - ssasnow = tausnow * (one - (b0s(ib)+b1s(ib)*refsnow)) - asysnow = ssasnow * c0s(ib) - - taucw(k,ib) = tauliq + tauice + taurain + tausnow - ssacw(k,ib) = ssaliq + ssaice + ssarain + ssasnow - asycw(k,ib) = asyliq + asyice + asyrain + asysnow - -! do istr = 1, nstr -! --- ... this commented code is the standard method for delta-m scaling. -! in accordance with the 1996 fu paper, equation a.3, the moments -! for ice were calculated as in the uncommented code. -! xmom(istr,k,ib) = & -! & (ssaliq*(asycoliq(ib)**istr-forcoliq(ib))/ffliq0 & -! & + ssaice*(asycoice(ib)**istr-forcoice(ib))/ffice0) & -! & / (ssaliq + ssaice) -! --- ... the following commented code is used by the original rrtm_sw -! xmom(istr,k,ib) = (one / (ssaliq+ssaice)) & -! & * (ssaliq*(asycoliq(ib)**istr-forcoliq(ib))/ffliq0 & -! & + ssaice*((asycoice(ib)-forcoice(ib))/ffice0)**istr) -! enddo - enddo - - endif lab_if_liq - - endif lab_if_cfrac - - enddo lab_do_k - - return -!................................... - end subroutine cldprop -!----------------------------------- - - - -!----------------------------------- - subroutine spcvrt & -!................................... - -! --- inputs: - & ( colamt, colmol, coldry, cosz, sntz, albbm, albdf, & - & cf1, pclfr, taucw, ssacw, asycw, tauae, ssaae, asyae, & - & forfac, forfrac, indfor, selffac, selffrac, indself, & - & fac00, fac01, fac10, fac11, jp, jt, jt1, laytrop, & - & NLAY, NLP1, & -! --- outputs: - & flxdc, flxuc, flxd0, flxu0 & -!! --- optional outputs: - &, sfbmc, sfdfc, sfbm0, sfdf0 & - &, suvbf0, suvbfc & - & ) - -! ******************************************************************* ! -! ! -! purpose: computes the shortwave radiation fluxes using two-stream ! -! method of howard barker ! -! ! -! interface: "spcvrt" is called by "swrad" ! -! ! -! ******************************************************************* ! -! ! -! input variables: ! -! colamt(NLAY,MAXGAS)- column amounts of absorbing gases the index ! -! 1-MAXGAS are for water vapor, carbon diozide,! -! ozone, nitrous oxide, methane, and oxigen, ! -! respectively (molecules/cm**2) ! -! coldry(NLAY) - dry air column amount(1.e-20*molecules/cm**2)! -! colmol(NLAY) - total column amount (dry air+water vapor) ! -! cosz - cosine of solar zenith angle ! -! sntz - secant of solar zenith angle ! -! albbm (2) - direct beam surface albedo for nir and uv+vis! -! albdf (2) - diffuse surface albedo for nir and uv+vis ! -! cf1 - effective total cloud cover at surface ! -! pclfr (NLAY) - layer cloud fraction ! -! taucw,ssacw,asycw (NLAY,NBLOW:NBHGH) ! -! - layer cloud optical depth, single scattering ! -! albedo, and asymmetry factor (weighted value)! -! tauae,ssaae,asyae (NLAY,NBLOW:NBHGH) ! -! - layer aerosols optical depth, single scatt. ! -! albedo, and asymmetry factor ! -! forfac (NLAY) - scale factor needed to foreign-continuum. ! -! forfrac(NLAY) - factor needed for temperature interpolation ! -! indfor (NLAY) - index of the lower of the two appropriate ! -! reference temperatures needed for foreign- ! -! continuum interpolation ! -! selffac(NLAY) - scale factor needed to h2o self-continuum. ! -! selffrac(NLAY) - factor needed for temperature interpolation ! -! of reference h2o self-continuum data ! -! indself(NLAY) - index of the lower of the two appropriate ! -! reference temperatures needed for the self- ! -! continuum interpolation ! -! facij (NLAY) - for each layer, these are factors that are ! -! needed to compute the interpolation factors ! -! that multiply the appropriate reference k- ! -! values. a value of 0/1 for i,j indicates ! -! that the corresponding factor multiplies ! -! reference k-value for the lower/higher of the! -! two appropriate temperatures, and altitudes, ! -! respectively. ! -! jp (NLAY) - the index of the lower (in altitude) of the ! -! two appropriate ref pressure levels needed ! -! for interpolation. ! -! jt, jt1(NLAY) - the indices of the lower of the two approp ! -! ref temperatures needed for interpolation ! -! (for pressure levels jp and jp+1, respectively)! -! laytrop - layer at which switch is made from one ! -! combination of key species to another ! -! NLAY, NLP1 - number of layers/levels ! -! ! -! output variables: ! -! flxdc (NLP1,NBDSW) - downward flux for cloudy sky ! -! flxuc (NLP1,NBDSW) - upward flux for cloudy sky ! -! flxd0 (NLP1,NBDSW) - downward flux for clear sky ! -! flxu0 (NLP1,NBDSW) - upward flux for clear sky ! -! ! -!! optional output variables: ! -! sfbmc (2) - cloudy sky sfc down beam fluxes (nir,uv+vis) ! -! sfdfc (2) - clousy sky sfc down diff fluxes (nir,uv+vis) ! -! sfbm0 (2) - clear sky sfc down beam fluxes (nir,uv+vis) ! -! sfdf0 (2) - clear sky sfc down diff fluxes (nir,uv+vis) ! -! suvbfc - cloudy sky sfc down uv-b fluxes ! -! suvbf0 - clear sky sfc down uv-b fluxes ! -! ! -! internal subroutines called: taumol16-29, swflux ! -! external subroutines called: none ! -! ! -! reference: see radiation's part of the ecmwf research department ! -! documentation ! -! ! -! program history: ! -! 2003-02-27 jean-jacques morcrette, ecmwf original author ! -! 2004-01-20 yu-tai hou modified for ncep models ! -! ! -! ! -! ******************************************************************* ! -! - use module_radsw_sflux, only : sfluxref01, sfluxref02, & - & sfluxref03, strrat, specwt, & - & scalekur, layreffr, ix1, ix2, ibx -! - implicit none - -! --- inputs: - integer, intent(in) :: NLAY, NLP1, laytrop - - integer, dimension(:), intent(in) :: indfor, indself, jp, jt, jt1 - - real (kind=kind_phys), dimension(:), intent(in) :: pclfr, & - & coldry, colmol, forfac, forfrac, selffac, selffrac, & - & fac00, fac01, fac10, fac11, albbm, albdf - - real (kind=kind_phys), dimension(:,:),intent(in) :: colamt - - real (kind=kind_phys), dimension(:,NBLOW:),intent(in):: & - & taucw, ssacw, asycw, tauae, ssaae, asyae - - real (kind=kind_phys), intent(in) :: cosz, sntz, cf1 - -! --- outputs: - real (kind=kind_phys), dimension(:,:), intent(out) :: flxdc, & - & flxuc, flxd0, flxu0 - -!! --- optional outputs: - real (kind=kind_phys), dimension(:), optional, intent(out) :: & - & sfbmc, sfdfc, sfbm0, sfdf0 - real (kind=kind_phys), optional, intent(out) :: suvbfc, suvbf0 - -! --- locals: - real (kind=kind_phys) :: fs, speccomb, specmult, colm1, colm2 - - real (kind=kind_phys), dimension(:,:), pointer :: sflxptr - - integer, dimension(NLAY,NBLOW:NBHGH) :: id0, id1 - integer :: ibd, ifb, j, jb, js, k, klow, khgh, klim, ks, njb - -! --- direct outputs from "taumol##": - real (kind=kind_phys), dimension(NLAY,NGMAX) :: taug, taur - real (kind=kind_phys), dimension(NGMAX) :: sfluxzen - -! --- direct outputs from "swflux": - real (kind=kind_phys), dimension(NLP1,2) :: fxdn, fxup - -!! --- for optional output from "swflux": - real (kind=kind_phys) :: sflxbc,sflxdc,sflxb0,sflxd0 - -! -!===> ... begin here -! -! --- initialization of output fluxes - do ibd = 1, NBDSW - do k = 1, NLP1 - flxdc(k,ibd)= zero - flxuc(k,ibd)= zero - flxd0(k,ibd)= zero - flxu0(k,ibd)= zero - enddo - enddo - - if ( lfdncmp ) then -!! --- optional uv-b surface downward flux - suvbfc = zero - suvbf0 = zero - -!! --- optional output surface fluxes - sfbmc(1) = zero - sfbmc(2) = zero - sfdfc(1) = zero - sfdfc(2) = zero - sfbm0(1) = zero - sfbm0(2) = zero - sfdf0(1) = zero - sfdf0(2) = zero - endif - - do jb = NBLOW, NBHGH - -! --- indices for layer optical depth - do k = 1, laytrop - id0(k,jb) = ((jp(k)-1)*5 + (jt (k)-1)) * NSPA(jb) - id1(k,jb) = ( jp(k) *5 + (jt1(k)-1)) * NSPA(jb) - enddo - - do k = laytrop+1, NLAY - id0(k,jb) = ((jp(k)-13)*5 + (jt (k)-1)) * NSPB(jb) - id1(k,jb) = ((jp(k)-12)*5 + (jt1(k)-1)) * NSPB(jb) - enddo - - enddo - -! --- loop over each spectral band - - lab_do_jb : do jb = NBLOW, NBHGH - -! --- calculate spectral flux at toa - - ibd = ibx(jb) - njb = NG(jb) - - NULLIFY (sflxptr) - - select case (jb) - - case (16, 20, 23, 25, 26, 29) - - sflxptr => sfluxref01(:,:,ibd) - - do j = 1, njb - sfluxzen(j) = sflxptr(j,1) - enddo - - case (27) - - sflxptr => sfluxref01(:,:,ibd) - - do j = 1, njb - sfluxzen(j) = scalekur * sflxptr(j,1) - enddo - - case default - - if (jb==17 .or. jb==28) then - sflxptr => sfluxref02(:,:,ibd) - klow = laytrop - khgh = NLAY - 1 - klim = NLAY - else - sflxptr => sfluxref03(:,:,ibd) - klow = 1 - khgh = laytrop - 1 - klim = laytrop - endif - - ks = klim - lab_do_k : do k = klow, khgh - if (jp(k)= layreffr(jb)) then - ks = k + 1 - exit lab_do_k - endif - enddo lab_do_k - - colm1 = colamt(ks,ix1(jb)) - colm2 = colamt(ks,ix2(jb)) - speccomb = colm1 + strrat(jb)*colm2 - specmult = specwt(jb) * min( oneminus, colm1/speccomb ) - js = 1 + int( specmult ) - fs = mod(specmult, one) - - do j = 1, njb - sfluxzen(j) = sflxptr(j,js) & - & + fs * (sflxptr(j,js+1) - sflxptr(j,js)) - enddo - - end select - -! --- call taumol## to calculate layer optical depth - - if (jb == 16) then - - call taumol16 - - else if (jb == 17) then - - call taumol17 - - else if (jb == 18) then - - call taumol18 - - else if (jb == 19) then - - call taumol19 - - else if (jb == 20) then - - call taumol20 - - else if (jb == 21) then - - call taumol21 - - else if (jb == 22) then - - call taumol22 - - else if (jb == 23) then - - call taumol23 - - else if (jb == 24) then - - call taumol24 - - else if (jb == 25) then - -!--- visible 16000-22650 cm-1 0.4415 - 0.6250 um - - call taumol25 - - else if (jb == 26) then - -!--- uv-a 22650-29000 cm-1 0.3448 - 0.4415 um - - call taumol26 - - else if (jb == 27) then - -!--- uv-b 29000-38000 cm-1 0.2632 - 0.3448 um - - call taumol27 - - else if (jb == 28) then - -!--- uv-c 38000-50000 cm-1 0.2000 - 0.2632 um - - call taumol28 - - else if (jb == 29) then - - call taumol29 - - endif - -! --- compute radiation fluxes - - call swflux ( jb ) - -! --- accumulation of spectral fluxes over whole spectrum - - ifb = jb - NBLOW + 1 - do k = 1, NLP1 - flxuc(k,ifb) = fxup(k,2) - flxdc(k,ifb) = fxdn(k,2) - flxu0(k,ifb) = fxup(k,1) - flxd0(k,ifb) = fxdn(k,1) - enddo - - if ( lfdncmp ) then -!! --- optional uv-b surface downward flux - if (jb == nuvb) then - suvbf0 = suvbf0 + fxdn(1,1) - suvbfc = suvbfc + fxdn(1,2) - endif - -!! --- optional surface downward flux components - ifb = IDXSFC(jb) - if (ifb .eq. 0) then - sfbmc(1) = sfbmc(1) + 0.5*sflxbc - sfdfc(1) = sfdfc(1) + 0.5*sflxdc - sfbm0(1) = sfbm0(1) + 0.5*sflxb0 - sfdf0(1) = sfdf0(1) + 0.5*sflxd0 - sfbmc(2) = sfbmc(2) + 0.5*sflxbc - sfdfc(2) = sfdfc(2) + 0.5*sflxdc - sfbm0(2) = sfbm0(2) + 0.5*sflxb0 - sfdf0(2) = sfdf0(2) + 0.5*sflxd0 - else - sfbmc(ifb) = sfbmc(ifb) + sflxbc - sfdfc(ifb) = sfdfc(ifb) + sflxdc - sfbm0(ifb) = sfbm0(ifb) + sflxb0 - sfdf0(ifb) = sfdf0(ifb) + sflxd0 - endif - endif ! end if_lfdncmp - - enddo lab_do_jb - - -! ================= - contains -! ================= - -!----------------------------------- - subroutine swflux ( ib ) -!................................... - -! ******************************************************************* ! -! ! -! purpose: computes the upward and downward radiation fluxes ! -! this program combines the original "reftra" and "vrtqdr" ! -! ! -! first (reftra) it computes the reflectivity and ! -! transmissivity of a clear or cloudy layer using a choice ! -! of various approximations. ! -! ! -! then (vrtqdr) performs the vertical quadrature ! -! integration to obtain level fluxes. ! -! ! -! interface: "swflux" is called by "spcvrt" ! -! ! -! ******************************************************************* ! -! ! -! input variables: ! -! ib - spectral band index ! -! input variables (direct from "spcvrt"): ! -! taug (NLAY,NGMAX)- spectral optical depth for gases ! -! taur (NLAY,NGMAX)- spectral optical depth for rayleigh scattering ! -! sfluxzen (NGMAX)- spectral distribution of incoming solar flux ! -! taucw(NLAY,NBLOW:NBHGH) - weighted cloud optical depth ! -! ssacw(NLAY,NBLOW:NBHGH) - weighted cloud single scattering albedo ! -! asycw(NLAY,NBLOW:NBHGH) - weighted cloud asymmetry factor ! -! tauae(NLAY,NBLOW:NBHGH) - aerosols optical depth ! -! ssaae(NLAY,NBLOW:NBHGH) - aerosols single scattering albedo ! -! asyae(NLAY,NBLOW:NBHGH) - aerosols asymmetry factor ! -! cf1 - >0: cloudy sky, otherwise: clear sky ! -! pclfr(NLAY) - layer cloud fraction ! -! cosz - cosine solar zenith angle ! -! sntz - secant solar zenith angle ! -! albbm(2) - surface albedo for direct beam radiation ! -! albdf(2) - surface albedo for diffused radiation ! -! NLAY, NLP1 - number of layers/levels ! -! ! -! control parameters in module "module_radsw_cntr_para": ! -! imodsw - control flag for 2-stream transfer schemes ! -! = 1 delta-eddington (joseph et al., 1976) ! -! = 2 pifm (zdunkowski et al., 1980) ! -! = 3 discrete ordinates (liou, 1973) ! -! ! -! output variables (direct to "spcvrt"): ! -! fxdn (NLP1,2) - downward flux, 1: clear sky, 2: cloudy sky ! -! fzup (NLP1,2) - upward flux, 1: clear sky, 2: cloudy sky ! -! ! -!! optional output variables (direct to "spcvrt"): ! -! sflxbc - cloudy sky sfc downward beam flux ! -! sflxdc - cloudy sky sfc downward diff flux ! -! sflxb0 - clear sky sfc downward beam flux ! -! sflxd0 - clear sky sfc downward diff flux ! -! ! -! internal variables: ! -! zrefb(NLP1,2) - direct beam reflectivity for clear and cloudy ! -! zrefd(NLP1,2) - diffuse reflectivity for clear and cloudy ! -! ztrab(NLP1,2) - direct beam transmissivity for clear and cloudy ! -! ztrad(NLP1,2) - diffuse transmissivity for clear and cloudy ! -! zldbt(NLP1,2) - layer mean beam transmittance for clear and cloudy ! -! ztdbt(NLP1,2) - total beam transmittance at levels for clr and cld ! -! jg - g-point index ! -! ! -! external subroutines called: none ! -! ! -! program history: ! -! 2003-02-27 jean-jacques morcrette, ecmwf original author ! -! 2004-01-20 yu-tai hou modified for ncep models ! -! 2005-03-10 yu-tai hou modified delta scaling ! -! ! -! ******************************************************************* ! -! - implicit none - - real (kind=kind_phys), parameter :: zcrit = 0.9995 ! thresold for conservative scattering -! real (kind=kind_phys), parameter :: zsr3 = sqrt(3.0) -! jbao new gfs phys - real (kind=kind_phys), parameter :: zsr3 = 1.732050808 - -! --- inputs: - integer, intent(in) :: ib - -! --- locals: - real (kind=kind_phys), dimension(NLAY,2) :: ztau, zssa, zasy, & - & zssa0, zexpt - - real (kind=kind_phys), dimension(NLP1,2) :: zrefb, zrefd, ztrab, & - & ztrad, zldbt, ztdbt - - real (kind=kind_phys), dimension(NLAY) :: ztaus, zssas, zasys - - real (kind=kind_phys), dimension(NLP1) :: zrupb, zrupd, zrdnd, & - & ztdn, zfd, zfu - - real (kind=kind_phys) :: ztau1, zssa1, zasy1, zasy3, zwo, & - & zgam1, zgam2, zgam3, zgam4, zc0, zc1, za1, za2, zrk, zrk2, & - & zrp, zrp1, zrm1, zrpp, zrkg1, zrkg3, zrkg4, zexp1, zexm1, & - & zexp2, zexm2, zden1, ze1r45 - - real (kind=kind_phys) :: zr1, zr2, zr3, zr4, zr5, zt1, zt2, zt3 - -!! --- for optional surface fluxes - real (kind=kind_phys), dimension(2) :: sfxbm, sfxdf - - integer :: k, kp, jg, ngt, ipa, iab -! -!===> ... begin here -! - ngt = NG(ib) ! number of g-point in each band - iab = IDXALB(ib) ! surface albedo spectral index - - do k = 1, NLP1 - fxdn(k,1) = zero - fxdn(k,2) = zero - fxup(k,1) = zero - fxup(k,2) = zero - enddo - -!! --- optional surface fluxes - if ( lfdncmp ) then - sfxbm(1) = zero - sfxbm(2) = zero - sfxdf(1) = zero - sfxdf(2) = zero - endif - -! --- loop over all g-points in each band - - lab_do_jg : do jg = 1, ngt - -! --- compute clear-sky optical parameters - - do k = 1, NLAY - ztaus(k) = max(ftiny, taur(k,jg) + taug(k,jg) + tauae(k,ib)) - zssas(k) = taur(k,jg) + tauae(k,ib)*ssaae(k,ib) - zasys(k) = asyae(k,ib)*ssaae(k,ib)*tauae(k,ib) - zssa1 = min(oneminus, zssas(k) / ztaus(k)) - zasy1 = zasys(k) / max(ftiny, zssas(k)) - zssa0(k,1) = zssa1 - -! --- delta scaling - za1 = zasy1 * zasy1 - za2 = zssa1 * za1 - - ztau (k,1) = (one - za2) * ztaus(k) - zssa (k,1) = (zssa1 - za2) / (one - za2) - zasy (k,1) = (zasy1 - za1) / (one - za1) - zexpt(k,1) = exp ( - min( ztau(k,1)*sntz, 200.0) ) - enddo - -! --- compute total sky optical parameters - - if (cf1 > eps) then - - do k = 1, NLAY - if (pclfr(k) > eps) then - ztau1 = ztaus(k) + taucw(k,ib) - zc0 = zssas(k) + ssacw(k,ib) - zc1 = zasys(k) + asycw(k,ib) - zssa1 = min(oneminus, zc0 / ztau1) - zasy1 = zc1 / max(ftiny, zc0) - zssa0(k,2) = zssa1 - -! --- delta scaling - za1 = zasy1 * zasy1 - za2 = zssa1 * za1 - - ztau (k,2) = (one - za2) * ztau1 - zssa (k,2) = (zssa1 - za2) / (one - za2) - zasy (k,2) = (zasy1 - za1) / (one - za1) - zexpt(k,2) = exp ( - min( ztau(k,2)*sntz, 200.0) ) - else - ztau (k,2) = ztau (k,1) - zssa (k,2) = zssa (k,1) - zasy (k,2) = zasy (k,1) - zssa0(k,2) = zssa0(k,1) - zexpt(k,2) = zexpt(k,1) - endif - enddo - - else - - do k = 1, NLAY - ztau (k,2) = ztau (k,1) - zssa (k,2) = zssa (k,1) - zasy (k,2) = zasy (k,1) - zssa0(k,2) = zssa0(k,1) - zexpt(k,2) = zexpt(k,1) - enddo - - endif ! end_if_cf1 - -! --- compute layer reflectance and transmittance - - lab_do_ipa1 : do ipa = 1, 2 ! 1: clear-sky, 2, cloudy-sky - - do k = 1, NLAY - kp = k + 1 - - lab_if_pclfr : if (ipa==1 .or. pclfr(k)>eps) then ! cloudy-layer -! --- save original ssa to test for conservative solution - zwo = zssa0(k,ipa) - - ztau1 = ztau(k,ipa) - zssa1 = zssa(k,ipa) - zasy1 = zasy(k,ipa) - zasy3 = 3.0 * zasy1 - -! --- general two-stream expressions - if (imodsw == 1) then ! delta-eddington - zgam1 = (7.0 - zssa1 * (4.0 + zasy3)) * 0.25 - zgam2 =-(1.0 - zssa1 * (4.0 - zasy3)) * 0.25 - zgam3 = (2.0 - zasy3 * cosz) * 0.25 - else if (imodsw == 2) then ! pifm - zgam1 = (8.0 - zssa1 * (5.0 + zasy3)) * 0.25 - zgam2 = 3.0 * (zssa1 * (1.0 - zasy1)) * 0.25 - zgam3 = (2.0 - zasy3 * cosz) * 0.25 - else if (imodsw == 3) then ! discrete ordinates - zgam1 = zsr3 * (2.0 - zssa1 * (1.0 + zasy1)) * 0.5 - zgam2 = zsr3 * zssa1 * (1.0 - zasy1) * 0.5 - zgam3 = (1.0 - zsr3 * zasy1 * cosz) * 0.5 - endif - zgam4 = one - zgam3 - -! --- for conservative scattering - - lab_if_zwo : if (zwo >= zcrit) then - za1 = zgam1 * cosz - zgam3 - za2 = zgam1 * ztau1 - -! --- compute homogeneous reflectance and transmittance - zexm1 = zexpt(k,ipa) - -! ... collimated beam - zrefb(kp,ipa) = max(zero, & - & (za2 - za1*(one - zexm1))/(one + za2)) - ztrab(kp,ipa) = max(zero, one - zrefb(kp,ipa)) - -! ... isotropic incidence - zrefd(kp,ipa) = max(zero, za2 / (one + za2)) - ztrad(kp,ipa) = max(zero, one - zrefd(kp,ipa)) - -! --- for non-conservative scattering - else lab_if_zwo - - za1 = zgam1*zgam4 + zgam2*zgam3 - za2 = zgam1*zgam3 + zgam2*zgam4 -! zrk = sqrt (zgam1**2 - zgam2**2) - zrk = sqrt ( (zgam1 - zgam2) * (zgam1 + zgam2) ) - zrk2= 2.0 * zrk - - zrp = zrk * cosz - zrp1 = one + zrp - zrm1 = one - zrp - zrpp = one - zrp*zrp - zrkg1= zrk + zgam1 - zrkg3= zrk * zgam3 - zrkg4= zrk * zgam4 - - zr1 = zrm1 * (za2 + zrkg3) - zr2 = zrp1 * (za2 - zrkg3) - zr3 = zrk2 * (zgam3 - za2*cosz) - zr4 = zrpp * zrkg1 - zr5 = zrpp * (zrk - zgam1) - - zt1 = zrp1 * (za1 + zrkg4) - zt2 = zrm1 * (za1 - zrkg4) - zt3 = zrk2 * (zgam4 + za1*cosz) - -! --- compute homogeneous reflectance and transmittance - zexp1 = exp( min(200.0, zrk*ztau1) ) - zexm1 = one / zexp1 - zexm2 = zexpt(k,ipa) - zexp2 = one / zexm2 - ze1r45 = zr4*zexp1 + zr5*zexm1 - -! ... collimated beam - zden1 = zssa1 / ze1r45 - zrefb(kp,ipa) = max(zero, & - & (zr1*zexp1-zr2*zexm1-zr3*zexm2)*zden1 ) - ztrab(kp,ipa) = max(zero, zexm2*(one & - & - (zt1*zexp1-zt2*zexm1-zt3*zexp2)*zden1)) - -! ... diffuse beam - zden1 = zr4 / (ze1r45 * zrkg1) - zrefd(kp,ipa) = max(zero, zgam2*(zexp1-zexm1)*zden1) - ztrad(kp,ipa) = max(zero, zrk2*zden1) - endif lab_if_zwo - - else lab_if_pclfr ! clear-layer - - zrefb(kp,2) = zrefb(kp,1) - ztrab(kp,2) = ztrab(kp,1) - zrefd(kp,2) = zrefd(kp,1) - ztrad(kp,2) = ztrad(kp,1) - - endif lab_if_pclfr - enddo ! end do_k_loop - - if (ipa==1 .and. cf1<=eps) then - do k = 2, NLP1 - zrefb(k,2) = zrefb(k,1) - ztrab(k,2) = ztrab(k,1) - zrefd(k,2) = zrefd(k,1) - ztrad(k,2) = ztrad(k,1) - enddo - - exit lab_do_ipa1 - endif - - enddo lab_do_ipa1 ! end do_ipa_loop - -! --- set up toa direct beam for clear-sky and cloudy-sky - ztdbt(NLP1,1) = one - ztdbt(NLP1,2) = one - -! --- combine clear and cloudy contributions for total sky - - do k = NLAY, 1, -1 - kp = k + 1 - - zc0 = one - pclfr(k) - zc1 = pclfr(k) - - zrefb(kp,2) = zc0*zrefb(kp,1) + zc1*zrefb(kp,2) - zrefd(kp,2) = zc0*zrefd(kp,1) + zc1*zrefd(kp,2) - ztrab(kp,2) = zc0*ztrab(kp,1) + zc1*ztrab(kp,2) - ztrad(kp,2) = zc0*ztrad(kp,1) + zc1*ztrad(kp,2) - -! --- direct beam transmittance - zldbt(kp,1) = max(zero, zexpt(k,1)) - zldbt(kp,2) = zc0*zexpt(k,1) + zc1*zexpt(k,2) - - ztdbt(k,1) = max(zero, zldbt(kp,1) * ztdbt(kp,1)) - ztdbt(k,2) = max(zero, zldbt(kp,2) * ztdbt(kp,2)) - enddo - -! --- set up surface values (beam and diffused) for clear-sky and cloudy-sky - zldbt(1,1) = zero - zldbt(1,2) = zero - - zrefb(1,1) = albbm(iab) - zrefb(1,2) = albbm(iab) - zrefd(1,1) = albdf(iab) - zrefd(1,2) = albdf(iab) - - ztrab(1,1) = zero - ztrab(1,2) = zero - ztrad(1,1) = zero - ztrad(1,2) = zero - -! --- perform vertical quadrature - - lab_do_ipa2 : do ipa = 1, 2 ! 1=clear-sky, 2=cloudy-sky - -! --- link lowest layer with surface - zrupb(1) = zrefb(1,ipa) ! direct beam - zrupd(1) = zrefd(1,ipa) ! diffused - -! --- pass from bottom to top - do k = 1, NLAY - kp = k + 1 - - zden1 = one / ( one - zrupd(k)*zrefd(kp,ipa) ) - zrupb(kp) = zrefb(kp,ipa) + ( ztrad(kp,ipa) & - & * ( (ztrab(kp,ipa) - zldbt(kp,ipa) )*zrupd(k) & - & + zldbt(kp,ipa)*zrupb(k) ) )*zden1 - zrupd(kp) = zrefd(kp,ipa) + ztrad(kp,ipa) & - & * ztrad(kp,ipa)*zrupd(k)*zden1 - enddo - -! --- upper boundary conditions - ztdn (NLP1) = one - zrdnd(NLP1) = zero - ztdn (NLAY) = ztrab(NLP1,ipa) - zrdnd(NLAY) = zrefd(NLP1,ipa) - -! --- pass from top to bottom - do k = NLAY, 2, -1 - zden1 = one / (one - zrefd(k,ipa)*zrdnd(k)) - ztdn (k-1) = ztdbt(k,ipa)*ztrab(k,ipa) & - & + ( ztrad(k,ipa)*( ( ztdn(k) - ztdbt(k,ipa) ) & - & + ztdbt(k,ipa)*zrefb(k,ipa)*zrdnd(k) ) )*zden1 - zrdnd(k-1) = zrefd(k,ipa) + ztrad(k,ipa)*ztrad(k,ipa) & - & * zrdnd(k)*zden1 - enddo - -! --- up and down-welling fluxes at levels - do k = 1, NLP1 - zden1 = one / (one - zrdnd(k)*zrupd(k)) - zfu(k) = ( ztdbt(k,ipa)*zrupb(k) & - & + ( ztdn(k) - ztdbt(k,ipa) )*zrupd(k) )*zden1 - zfd(k) = ztdbt(k,ipa) + (ztdn(k) - ztdbt(k,ipa) & - & + ztdbt(k,ipa)*zrupb(k)*zrdnd(k))*zden1 - enddo - -! --- compute upward and downward fluxes at levels - do k = 1, NLP1 - fxup(k,ipa) = fxup(k,ipa) + sfluxzen(jg)*zfu(k) - fxdn(k,ipa) = fxdn(k,ipa) + sfluxzen(jg)*zfd(k) - enddo - -!! --- optional surface downward flux components - if ( lfdncmp ) then - sfxbm(ipa) = sfxbm(ipa)+sfluxzen(jg)*ztdbt(1,ipa) - sfxdf(ipa) = sfxdf(ipa)+sfluxzen(jg)*(zfd(1)-ztdbt(1,ipa)) - endif - - if (ipa==1 .and. cf1<=eps) then - exit lab_do_ipa2 - endif - enddo lab_do_ipa2 ! end do_ipa_loop - - enddo lab_do_jg - - if (cf1 <= eps) then - do k = 1, NLP1 - fxup(k,2) = fxup(k,1) - fxdn(k,2) = fxdn(k,1) - enddo - endif - - if ( lfdncmp ) then -!! --- optional surface downward flux components - if (cf1 <= eps) then - sfxbm(2) = sfxbm(1) - sfxdf(2) = sfxdf(1) - endif - -!! --- optional surface downward flux components - sflxb0 = sfxbm(1) - sflxd0 = sfxdf(1) - sflxbc = sfxbm(2) - sflxdc = sfxdf(2) - endif - - return -!................................... - end subroutine swflux -!----------------------------------- - - - -!----------------------------------- - subroutine taumol16 -!................................... - -! ------------------------------------------------------------------ ! -! written by eli j. mlawer, atmospheric & environmental research. ! -! ! -! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4) ! -! ! -! modifications ! -! ! -! jjmorcrette 2003-02-24 adapted to ecmwf environment ! -! ! -! ------------------------------------------------------------------ ! -! - use module_radsw_kgb16 -! - implicit none - -! --- locals: - real (kind=kind_phys) :: speccomb, specmult, tauray, fs, fs1, & - & fac000,fac001,fac010,fac011, fac100,fac101,fac110,fac111 - - integer :: ind01, ind02, ind03, ind04, ind11, ind12, ind13, ind14 - integer :: inds, indf, j, js, k - -! -!===> ... begin here -! - -! --- compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, NLAY - tauray = colmol(k) * rayl - - do j = 1 , NG16 - taur(k,j) = tauray - enddo - enddo - - do k = 1, laytrop - speccomb = colamt(k,1) + strrat(16)*colamt(k,5) - specmult = 8.0 * min( oneminus, colamt(k,1)/speccomb ) - - js = 1 + int( specmult ) - fs = mod( specmult, one ) - fs1= one - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,16) + js - ind02 = ind01 + 1 - ind03 = ind01 + 9 - ind04 = ind01 + 10 - ind11 = id1(k,16) + js - ind12 = ind11 + 1 - ind13 = ind11 + 9 - ind14 = ind11 + 10 - inds = indself(k) - indf = indfor (k) - - do j = 1, NG16 - taug(k,j) = speccomb & - & *( fac000 * absa(ind01,j) + fac100 * absa(ind02,j) & - & + fac010 * absa(ind03,j) + fac110 * absa(ind04,j) & - & + fac001 * absa(ind11,j) + fac101 * absa(ind12,j) & - & + fac011 * absa(ind13,j) + fac111 * absa(ind14,j) ) & - & + colamt(k,1) * (selffac(k) * (selfref(inds,j) & - & + selffrac(k) * (selfref(inds+1,j)-selfref(inds,j))) & - & + forfac(k) * (forref(indf,j) + forfrac(k) & - & * (forref(indf+1,j) - forref(indf,j)))) - enddo - enddo - - do k = laytrop+1, NLAY - ind01 = id0(k,16) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,16) + 1 - ind12 = ind11 + 1 - - do j = 1, NG16 - taug(k,j) = colamt(k,5) & - & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) & - & + fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) - enddo - enddo - - return -!................................... - end subroutine taumol16 -!----------------------------------- - - - -!----------------------------------- - subroutine taumol17 -!................................... - -! ------------------------------------------------------------------ ! -! written by eli j. mlawer, atmospheric & environmental research. ! -! ! -! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2) ! -! ! -! modifications ! -! ! -! jjmorcrette 2003-02-24 adapted to ecmwf environment ! -! ------------------------------------------------------------------ ! -! - use module_radsw_kgb17 -! - implicit none - -! --- locals: - real (kind=kind_phys) :: speccomb, specmult, tauray, fs, fs1, & - & fac000,fac001,fac010,fac011, fac100,fac101,fac110,fac111 - - integer :: ind01, ind02, ind03, ind04, ind11, ind12, ind13, ind14 - integer :: inds, indf, j, js, k, ks - -! -!===> ... begin here -! - -! --- compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, NLAY - tauray = colmol(k) * rayl - - do j = 1 , NG17 - taur(k,j) = tauray - enddo - enddo - - do k = 1, laytrop - speccomb = colamt(k,1) + strrat(17)*colamt(k,2) - specmult = 8.0 * min(oneminus, colamt(k,1) / speccomb) - - js = 1 +int(specmult) - fs = mod(specmult, one) - fs1= one - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,17) + js - ind02 = ind01 + 1 - ind03 = ind01 + 9 - ind04 = ind01 + 10 - ind11 = id1(k,17) + js - ind12 = ind11 + 1 - ind13 = ind11 + 9 - ind14 = ind11 + 10 - inds = indself(k) - indf = indfor (k) - - do j = 1, NG17 - taug(k,j) = speccomb & - & * ( fac000 * absa(ind01,j) + fac100 * absa(ind02,j) & - & + fac010 * absa(ind03,j) + fac110 * absa(ind04,j) & - & + fac001 * absa(ind11,j) + fac101 * absa(ind12,j) & - & + fac011 * absa(ind13,j) + fac111 * absa(ind14,j) ) & - & + colamt(k,1) * (selffac(k) * (selfref(inds,j) & - & + selffrac(k) * (selfref(inds+1,j)-selfref(inds,j))) & - & + forfac(k) * (forref(indf,j) + forfrac(k) & - & * (forref(indf+1,j) - forref(indf,j)))) - enddo - enddo - - do k = laytrop+1, NLAY - speccomb = colamt(k,1) + strrat(17)*colamt(k,2) - specmult = 4.0 * min(oneminus, colamt(k,1) / speccomb) - - js = 1 + int(specmult) - fs = mod(specmult, one) - fs1= one - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,17) + js - ind02 = ind01 + 1 - ind03 = ind01 + 5 - ind04 = ind01 + 6 - ind11 = id1(k,17) + js - ind12 = ind11 + 1 - ind13 = ind11 + 5 - ind14 = ind11 + 6 - indf = indfor(k) - - do j = 1, NG17 - taug(k,j) = speccomb & - & * ( fac000 * absb(ind01,j) + fac100 * absb(ind02,j) & - & + fac010 * absb(ind03,j) + fac110 * absb(ind04,j) & - & + fac001 * absb(ind11,j) + fac101 * absb(ind12,j) & - & + fac011 * absb(ind13,j) + fac111 * absb(ind14,j) ) & - & + colamt(k,1) * forfac(k) * (forref(indf,j) & - & + forfrac(k) * (forref(indf+1,j) - forref(indf,j))) - enddo - enddo - - return -!................................... - end subroutine taumol17 -!----------------------------------- - - -!----------------------------------- - subroutine taumol18 -!................................... - -! ------------------------------------------------------------------ ! -! written by eli j. mlawer, atmospheric & environmental research. ! -! ! -! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4) ! -! ------------------------------------------------------------------ ! -! - use module_radsw_kgb18 -! - implicit none - -! --- locals: - real (kind=kind_phys) :: speccomb, specmult, tauray, fs, fs1, & - & fac000,fac001,fac010,fac011, fac100,fac101,fac110,fac111 - - integer :: ind01, ind02, ind03, ind04, ind11, ind12, ind13, ind14 - integer :: inds, indf, j, js, k, ks - -! -!===> ... begin here -! - -! --- compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, NLAY - tauray = colmol(k) * rayl - - do j = 1 , NG18 - taur(k,j) = tauray - enddo - enddo - - do k = 1, laytrop - speccomb = colamt(k,1) + strrat(18)*colamt(k,5) - specmult = 8.0 * min(oneminus, colamt(k,1) / speccomb) - - js = 1 +int(specmult) - fs = mod(specmult, one) - fs1= one - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,18) + js - ind02 = ind01 + 1 - ind03 = ind01 + 9 - ind04 = ind01 + 10 - ind11 = id1(k,18) + js - ind12 = ind11 + 1 - ind13 = ind11 + 9 - ind14 = ind11 + 10 - inds = indself(k) - indf = indfor (k) - - do j = 1, NG18 - taug(k,j) = speccomb & - & * ( fac000 * absa(ind01,j) + fac100 * absa(ind02,j) & - & + fac010 * absa(ind03,j) + fac110 * absa(ind04,j) & - & + fac001 * absa(ind11,j) + fac101 * absa(ind12,j) & - & + fac011 * absa(ind13,j) + fac111 * absa(ind14,j) ) & - & + colamt(k,1) * (selffac(k) * (selfref(inds,j) & - & + selffrac(k) * (selfref(inds+1,j)-selfref(inds,j))) & - & + forfac(k) * (forref(indf,j) + forfrac(k) & - & * (forref(indf+1,j) - forref(indf,j)))) - enddo - enddo - - do k = laytrop+1, NLAY - ind01 = id0(k,18) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,18) + 1 - ind12 = ind11 + 1 - - do j = 1, NG18 - taug(k,j) = colamt(k,5) & - & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) & - & + fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) - enddo - enddo - - return -!................................... - end subroutine taumol18 -!----------------------------------- - - -!----------------------------------- - subroutine taumol19 -!................................... - -! ------------------------------------------------------------------ ! -! written by eli j. mlawer, atmospheric & environmental research. ! -! ! -! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2) ! -! ! -! modifications ! -! ! -! jjmorcrette 2003-02-24 adapted to ecmwf environment ! -! ------------------------------------------------------------------ ! -! - use module_radsw_kgb19 -! - implicit none - -! --- locals: - real (kind=kind_phys) :: speccomb, specmult, tauray, fs, fs1, & - & fac000,fac001,fac010,fac011, fac100,fac101,fac110,fac111 - - integer :: ind01, ind02, ind03, ind04, ind11, ind12, ind13, ind14 - integer :: inds, indf, j, js, k, ks - -! -!===> ... begin here -! - -! --- compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, NLAY - tauray = colmol(k) * rayl - - do j = 1 , NG19 - taur(k,j) = tauray - enddo - enddo - - do k = 1, laytrop - speccomb = colamt(k,1) + strrat(19)*colamt(k,2) - specmult = 8.0 * min(oneminus, colamt(k,1) / speccomb) - - js = 1 +int(specmult) - fs = mod(specmult, one) - fs1= one - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,19) + js - ind02 = ind01 + 1 - ind03 = ind01 + 9 - ind04 = ind01 + 10 - ind11 = id1(k,19) + js - ind12 = ind11 + 1 - ind13 = ind11 + 9 - ind14 = ind11 + 10 - inds = indself(k) - indf = indfor (k) - - do j = 1, NG19 - taug(k,j) = speccomb & - & * ( fac000 * absa(ind01,j) + fac100 * absa(ind02,j) & - & + fac010 * absa(ind03,j) + fac110 * absa(ind04,j) & - & + fac001 * absa(ind11,j) + fac101 * absa(ind12,j) & - & + fac011 * absa(ind13,j) + fac111 * absa(ind14,j) ) & - & + colamt(k,1) * (selffac(k) * (selfref(inds,j) & - & + selffrac(k) * (selfref(inds+1,j)-selfref(inds,j))) & - & + forfac(k) * (forref(indf,j) + forfrac(k) & - & * (forref(indf+1,j) - forref(indf,j)))) - enddo - enddo - - do k = laytrop+1, NLAY - ind01 = id0(k,19) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,19) + 1 - ind12 = ind11 + 1 - - do j = 1, NG19 - taug(k,j) = colamt(k,2) & - & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) & - & + fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) - enddo - enddo - - return -!................................... - end subroutine taumol19 -!----------------------------------- - - -!----------------------------------- - subroutine taumol20 -!................................... - -! ------------------------------------------------------------------ ! -! written by eli j. mlawer, atmospheric & environmental research. ! -! ! -! band 20: 5150-6150 cm-1 (low - h2o; high - h2o) ! -! ! -! modifications ! -! ! -! jjmorcrette 2003-02-24 adapted to ecmwf environment ! -! ------------------------------------------------------------------ ! -! - use module_radsw_kgb20 -! - implicit none - -! --- locals: - real (kind=kind_phys) :: tauray - - integer :: ind01, ind02, ind11, ind12 - integer :: inds, indf, j, k - -! -!===> ... begin here -! - -! --- compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, NLAY - tauray = colmol(k) * rayl - - do j = 1 , NG20 - taur(k,j) = tauray - enddo - enddo - - do k = 1, laytrop - ind01 = id0(k,20) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,20) + 1 - ind12 = ind11 + 1 - inds = indself(k) - indf = indfor (k) - - do j = 1, NG20 - taug(k,j) = colamt(k,1) & - & * ( (fac00(k)*absa(ind01,j) + fac10(k)*absa(ind02,j) & - & + fac01(k)*absa(ind11,j) + fac11(k)*absa(ind12,j)) & - & + selffac(k) * (selfref(inds,j) + selffrac(k) & - & * (selfref(inds+1,j) - selfref(inds,j))) & - & + forfac(k) * (forref(indf,j) + forfrac(k) & - & * (forref(indf+1,j) - forref(indf,j))) ) & - & + colamt(k,5) * absch4(j) - enddo - enddo - - do k = laytrop+1, NLAY - ind01 = id0(k,20) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,20) + 1 - ind12 = ind11 + 1 - indf = indfor(k) - - do j = 1, NG20 - taug(k,j) = colamt(k,1) & - & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) & - & + fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) & - & + forfac(k) * (forref(indf,j) + forfrac(k) & - & * (forref(indf+1,j) - forref(indf,j))) ) & - & + colamt(k,5) * absch4(j) - enddo - enddo - - return -!................................... - end subroutine taumol20 -!----------------------------------- - - -!----------------------------------- - subroutine taumol21 -!................................... - -! ------------------------------------------------------------------ ! -! written by eli j. mlawer, atmospheric & environmental research. ! -! ! -! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2) ! -! ! -! modifications ! -! ! -! jjmorcrette 2003-02-24 adapted to ecmwf environment ! -! ------------------------------------------------------------------ ! -! - use module_radsw_kgb21 -! - implicit none - -! --- locals: - real (kind=kind_phys) :: speccomb, specmult, tauray, fs, fs1, & - & fac000,fac001,fac010,fac011, fac100,fac101,fac110,fac111 - - integer :: ind01, ind02, ind03, ind04, ind11, ind12, ind13, ind14 - integer :: inds, indf, j, js, k, ks - -! -!===> ... begin here -! - -! --- compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, NLAY - tauray = colmol(k) * rayl - - do j = 1 , NG21 - taur(k,j) = tauray - enddo - enddo - - do k = 1, laytrop - speccomb = colamt(k,1) + strrat(21)*colamt(k,2) - specmult = 8.0 * min(oneminus, colamt(k,1) / speccomb) - - js = 1 + int(specmult) - fs = mod(specmult, one) - fs1= one - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,21) + js - ind02 = ind01 + 1 - ind03 = ind01 + 9 - ind04 = ind01 + 10 - ind11 = id1(k,21) + js - ind12 = ind11 + 1 - ind13 = ind11 + 9 - ind14 = ind11 + 10 - inds = indself(k) - indf = indfor (k) - - do j = 1 , NG21 - taug(k,j) = speccomb & - & * ( fac000 * absa(ind01,j) + fac100 * absa(ind02,j) & - & + fac010 * absa(ind03,j) + fac110 * absa(ind04,j) & - & + fac001 * absa(ind11,j) + fac101 * absa(ind12,j) & - & + fac011 * absa(ind13,j) + fac111 * absa(ind14,j) ) & - & + colamt(k,1) * (selffac(k) * (selfref(inds,j) & - & + selffrac(k) * (selfref(inds+1,j)-selfref(inds,j))) & - & + forfac(k) * (forref(indf,j) + forfrac(k) & - & * (forref(indf+1,j) - forref(indf,j)))) - enddo - enddo - - do k = laytrop+1, NLAY - speccomb = colamt(k,1) + strrat(21)*colamt(k,2) - specmult = 4.0 * min(oneminus, colamt(k,1) / speccomb) - - js = 1 + int(specmult) - fs = mod(specmult, one) - fs1= one - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,21) + js - ind02 = ind01 + 1 - ind03 = ind01 + 5 - ind04 = ind01 + 6 - ind11 = id1(k,21) + js - ind12 = ind11 + 1 - ind13 = ind11 + 5 - ind14 = ind11 + 6 - indf = indfor(k) - - do j = 1 , NG21 - taug(k,j) = speccomb & - & * ( fac000 * absb(ind01,j) + fac100 * absb(ind02,j) & - & + fac010 * absb(ind03,j) + fac110 * absb(ind04,j) & - & + fac001 * absb(ind11,j) + fac101 * absb(ind12,j) & - & + fac011 * absb(ind13,j) + fac111 * absb(ind14,j) ) & - & + colamt(k,1) * forfac(k) * (forref(indf,j) & - & + forfrac(k) * (forref(indf+1,j) - forref(indf,j))) - enddo - enddo - - return -!................................... - end subroutine taumol21 -!----------------------------------- - - -!----------------------------------- - subroutine taumol22 -!................................... - -! ------------------------------------------------------------------ ! -! written by eli j. mlawer, atmospheric & environmental research. ! -! ! -! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2) ! -! ! -! modifications ! -! ! -! jjmorcrette 2003-02-24 adapted to ecmwf environment ! -! ------------------------------------------------------------------ ! -! - use module_radsw_kgb22 -! - implicit none - -! --- locals: - real (kind=kind_phys) :: speccomb, specmult, tauray, fs, fs1, & - & fac000,fac001,fac010,fac011, fac100,fac101,fac110,fac111, & - & o2adj, o2cont, o2tem - - integer :: ind01, ind02, ind03, ind04, ind11, ind12, ind13, ind14 - integer :: inds, indf, j, js, k, ks - -! -!===> ... begin here -! -! --- the following factoris the ratio of total o2 bandintensity (lines -! and mate continuum) to o2 bandintensity (line only). itis needed -! to adjust the optical depths since the k'sinclude only lines. - - o2adj = 1.6 - o2tem = 4.35e-4 / (350.0*2.0) - -! --- compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, NLAY - tauray = colmol(k) * rayl - - do j = 1 , NG22 - taur(k,j) = tauray - enddo - enddo - - do k = 1, laytrop - o2cont = o2tem * colamt(k,6) - speccomb = colamt(k,1) + strrat(22)*colamt(k,6) - specmult = 8.0 * min(oneminus, colamt(k,1) / speccomb) - - js = 1 + int(specmult) - fs = mod(specmult, one) - fs1= one - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,22) + js - ind02 = ind01 + 1 - ind03 = ind01 + 9 - ind04 = ind01 + 10 - ind11 = id1(k,22) + js - ind12 = ind11 + 1 - ind13 = ind11 + 9 - ind14 = ind11 + 10 - inds = indself(k) - indf = indfor (k) - - do j = 1 , NG22 - taug(k,j) = speccomb & - & * ( fac000 * absa(ind01,j) + fac100 * absa(ind02,j) & - & + fac010 * absa(ind03,j) + fac110 * absa(ind04,j) & - & + fac001 * absa(ind11,j) + fac101 * absa(ind12,j) & - & + fac011 * absa(ind13,j) + fac111 * absa(ind14,j) ) & - & + colamt(k,1) * (selffac(k) * (selfref(inds,j) & - & + selffrac(k) * (selfref(inds+1,j)-selfref(inds,j))) & - & + forfac(k) * (forref(indf,j) + forfrac(k) & - & * (forref(indf+1,j) - forref(indf,j)))) + o2cont - enddo - enddo - - do k = laytrop+1, NLAY - o2cont = o2tem * colamt(k,6) - - ind01 = id0(k,22) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,22) + 1 - ind12 = ind11 + 1 - - do j = 1 , NG22 - taug(k,j) = colamt(k,6) * o2adj & - & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) & - & + fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) & - & + o2cont - enddo - enddo - - return -!................................... - end subroutine taumol22 -!----------------------------------- - - -!----------------------------------- - subroutine taumol23 -!................................... - -! ------------------------------------------------------------------ ! -! written by eli j. mlawer, atmospheric & environmental research. ! -! ! -! band 23: 8050-12850 cm-1 (low - h2o; high - nothing) ! -! ! -! modifications ! -! ! -! jjmorcrette 2003-02-24 adapted to ecmwf environment ! -! ------------------------------------------------------------------ ! -! - use module_radsw_kgb23 -! - implicit none - -! --- locals: - integer :: ind01, ind02, ind11, ind12 - integer :: inds, indf, j, k - -! -!===> ... begin here -! - -! --- compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, NLAY - do j = 1 , NG23 - taur(k,j) = colmol(k) * rayl(j) - enddo - enddo - - - do k = 1, laytrop - ind01 = id0(k,23) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,23) + 1 - ind12 = ind11 + 1 - inds = indself(k) - indf = indfor (k) - - do j = 1 , NG23 - taug(k,j) = colamt(k,1) * (givfac & - & * ( fac00(k)*absa(ind01,j) + fac10(k)*absa(ind02,j) & - & + fac01(k)*absa(ind11,j) + fac11(k)*absa(ind12,j) ) & - & + selffac(k) * (selfref(inds,j) + selffrac(k) & - & * (selfref(inds+1,j) - selfref(inds,j))) & - & + forfac(k) * (forref(indf,j) + forfrac(k) & - & * (forref(indf+1,j) - forref(indf,j)))) - enddo - enddo - - do k = laytrop+1, NLAY - do j = 1 , NG23 - taug(k,j) = zero - enddo - enddo - - return -!................................... - end subroutine taumol23 -!----------------------------------- - - -!----------------------------------- - subroutine taumol24 -!................................... - -! ------------------------------------------------------------------ ! -! written by eli j. mlawer, atmospheric & environmental research. ! -! ! -! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2) ! -! ! -! modifications ! -! ! -! jjmorcrette 2003-02-24 adapted to ecmwf environment ! -! ------------------------------------------------------------------ ! -! - use module_radsw_kgb24 -! - implicit none - -! --- locals: - real (kind=kind_phys) :: speccomb, specmult, fs, fs1, & - & fac000,fac001,fac010,fac011, fac100,fac101,fac110,fac111 - - integer :: ind01, ind02, ind03, ind04, ind11, ind12, ind13, ind14 - integer :: inds, indf, j, js, k, ks - -! -!===> ... begin here -! - -! --- compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, laytrop - speccomb = colamt(k,1) + strrat(24)*colamt(k,6) - specmult = 8.0 * min(oneminus, colamt(k,1) / speccomb) - - js = 1 + int(specmult) - fs = mod(specmult, one) - fs1= one - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,24) + js - ind02 = ind01 + 1 - ind03 = ind01 + 9 - ind04 = ind01 + 10 - ind11 = id1(k,24) + js - ind12 = ind11 + 1 - ind13 = ind11 + 9 - ind14 = ind11 + 10 - inds = indself(k) - indf = indfor (k) - - do j = 1, NG24 - taug(k,j) = speccomb & - & * ( fac000 * absa(ind01,j) + fac100 * absa(ind02,j) & - & + fac010 * absa(ind03,j) + fac110 * absa(ind04,j) & - & + fac001 * absa(ind11,j) + fac101 * absa(ind12,j) & - & + fac011 * absa(ind13,j) + fac111 * absa(ind14,j) ) & - & + colamt(k,3) * abso3a(j) + colamt(k,1) & - & * (selffac(k) * (selfref(inds,j) + selffrac(k) & - & * (selfref(inds+1,j) - selfref(inds,j))) & - & + forfac(k) * (forref(indf,j) + forfrac(k) & - & * (forref(indf+1,j) - forref(indf,j)))) - - taur(k,j) = colmol(k) & - & * (rayla(j,js) + fs*(rayla(j,js+1) - rayla(j,js))) - enddo - enddo - - do k = laytrop+1, NLAY - ind01 = id0(k,24) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,24) + 1 - ind12 = ind11 + 1 - - do j = 1, NG24 - taug(k,j) = colamt(k,6) & - & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) & - & + fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) & - & + colamt(k,3) * abso3b(j) - - taur(k,j) = colmol(k) * raylb(j) - enddo - enddo - - return -!................................... - end subroutine taumol24 -!----------------------------------- - - -!----------------------------------- - subroutine taumol25 -!................................... - -! ------------------------------------------------------------------ ! -! written by eli j. mlawer, atmospheric & environmental research. ! -! ! -! band 25: 16000-22650 cm-1 (low - h2o; high - nothing) ! -! ! -! modifications ! -! ! -! jjmorcrette 2003-02-24 adapted to ecmwf environment ! -! ------------------------------------------------------------------ ! -! - use module_radsw_kgb25 -! - implicit none - -! --- locals: - integer :: ind01, ind02, ind11, ind12 - integer :: j, k - -! -!===> ... begin here -! - -! --- compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, NLAY - do j = 1, NG25 - taur(k,j) = colmol(k) * rayl(j) - enddo - enddo - - do k = 1, laytrop - ind01 = id0(k,25) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,25) + 1 - ind12 = ind11 + 1 - - do j = 1, NG25 - taug(k,j) = colamt(k,1) & - & * ( fac00(k)*absa(ind01,j) + fac10(k)*absa(ind02,j) & - & + fac01(k)*absa(ind11,j) + fac11(k)*absa(ind12,j) ) & - & + colamt(k,3) * abso3a(j) - enddo - enddo - - do k = laytrop+1, NLAY - do j = 1, NG25 - taug(k,j) = colamt(k,3) * abso3b(j) - enddo - enddo - - return -!................................... - end subroutine taumol25 -!----------------------------------- - - -!----------------------------------- - subroutine taumol26 -!................................... - -! ------------------------------------------------------------------ ! -! written by eli j. mlawer, atmospheric & environmental research. ! -! ! -! band 26: 22650-29000 cm-1 (low - nothing; high - nothing) ! -! ! -! modifications ! -! ! -! jjmorcrette 2003-02-24 adapted to ecmwf environment ! -! ------------------------------------------------------------------ ! -! - use module_radsw_kgb26 -! - implicit none - -! --- locals: - integer :: j, k - -! -!===> ... begin here -! - -! --- compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, NLAY - do j = 1, NG26 - taug(k,j) = zero - taur(k,j) = colmol(k) * rayl(j) - enddo - enddo - - return -!................................... - end subroutine taumol26 -!----------------------------------- - - -!----------------------------------- - subroutine taumol27 -!................................... - -! ------------------------------------------------------------------ ! -! written by eli j. mlawer, atmospheric & environmental research. ! -! ! -! band 27: 29000-38000 cm-1 (low - o3; high - o3) ! -! ! -! modifications ! -! ! -! jjmorcrette 2003-02-24 adapted to ecmwf environment ! -! ------------------------------------------------------------------ ! -! - use module_radsw_kgb27 -! - implicit none - -! --- locals: - integer :: ind01, ind02, ind11, ind12 - integer :: j, k - -! -!===> ... begin here -! - -! --- compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, NLAY - do j = 1, NG27 - taur(k,j) = colmol(k) * rayl(j) - enddo - enddo - - do k = 1, laytrop - ind01 = id0(k,27) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,27) + 1 - ind12 = ind11 + 1 - - do j = 1, NG27 - taug(k,j) = colamt(k,3) & - & * ( fac00(k)*absa(ind01,j) + fac10(k)*absa(ind02,j) & - & + fac01(k)*absa(ind11,j) + fac11(k)*absa(ind12,j) ) - enddo - enddo - - do k = laytrop+1, NLAY - ind01 = id0(k,27) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,27) + 1 - ind12 = ind11 + 1 - - do j = 1, NG27 - taug(k,j) = colamt(k,3) & - & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) & - & + fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) - enddo - enddo - - return -!................................... - end subroutine taumol27 -!----------------------------------- - - -!----------------------------------- - subroutine taumol28 -!................................... - -! ------------------------------------------------------------------ ! -! written by eli j. mlawer, atmospheric & environmental research. ! -! ! -! band 28: 38000-50000 cm-1 (low - o3,o2; high - o3,o2) ! -! ! -! modifications ! -! ! -! jjmorcrette 2003-02-24 adapted to ecmwf environment ! -! ------------------------------------------------------------------ ! -! - use module_radsw_kgb28 -! - implicit none - -! --- locals: - real (kind=kind_phys) :: speccomb, specmult, tauray, fs, fs1, & - & fac000,fac001,fac010,fac011, fac100,fac101,fac110,fac111 - - integer :: ind01, ind02, ind03, ind04, ind11, ind12, ind13, ind14 - integer :: inds, indf, j, js, k, ks - -! -!===> ... begin here -! - -! --- compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, NLAY - tauray = colmol(k) * rayl - - do j = 1, NG28 - taur(k,j) = tauray - enddo - enddo - - do k = 1, laytrop - speccomb = colamt(k,3) + strrat(28)*colamt(k,6) - specmult = 8.0 * min(oneminus, colamt(k,3) / speccomb) - - js = 1 + int(specmult) - fs = mod(specmult, one) - fs1= one - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,28) + js - ind02 = ind01 + 1 - ind03 = ind01 + 9 - ind04 = ind01 + 10 - ind11 = id1(k,28) + js - ind12 = ind11 + 1 - ind13 = ind11 + 9 - ind14 = ind11 + 10 - - do j = 1, NG28 - taug(k,j) = speccomb & - & * ( fac000 * absa(ind01,j) + fac100 * absa(ind02,j) & - & + fac010 * absa(ind03,j) + fac110 * absa(ind04,j) & - & + fac001 * absa(ind11,j) + fac101 * absa(ind12,j) & - & + fac011 * absa(ind13,j) + fac111 * absa(ind14,j) ) - enddo - enddo - - do k = laytrop+1, NLAY - speccomb = colamt(k,3) + strrat(28)*colamt(k,6) - specmult = 4.0 * min(oneminus, colamt(k,3) / speccomb) - - js = 1 + int(specmult) - fs = mod(specmult, one) - fs1= one - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,28) + js - ind02 = ind01 + 1 - ind03 = ind01 + 5 - ind04 = ind01 + 6 - ind11 = id1(k,28) + js - ind12 = ind11 + 1 - ind13 = ind11 + 5 - ind14 = ind11 + 6 - - do j = 1, NG28 - taug(k,j) = speccomb & - & * ( fac000 * absb(ind01,j) + fac100 * absb(ind02,j) & - & + fac010 * absb(ind03,j) + fac110 * absb(ind04,j) & - & + fac001 * absb(ind11,j) + fac101 * absb(ind12,j) & - & + fac011 * absb(ind13,j) + fac111 * absb(ind14,j) ) - enddo - enddo - - return -!................................... - end subroutine taumol28 -!----------------------------------- - - -!----------------------------------- - subroutine taumol29 -!................................... - -! ------------------------------------------------------------------ ! -! written by eli j. mlawer, atmospheric & environmental research. ! -! ! -! band 29: 820-2600 cm-1 (low - h2o; high - co2) ! -! ! -! modifications ! -! ! -! jjmorcrette 2002-10-03 adapted to ecmwf environment ! -! ------------------------------------------------------------------ ! -! - use module_radsw_kgb29 - - implicit none - -! --- locals: - real (kind=kind_phys) :: tauray - - integer :: ind01, ind02, ind11, ind12 - integer :: inds, indf, j, k - -! -!===> ... begin here -! - -! --- compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, NLAY - tauray = colmol(k) * rayl - - do j = 1, NG29 - taur(k,j) = tauray - enddo - enddo - - do k = 1, laytrop - ind01 = id0(k,29) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,29) + 1 - ind12 = ind11 + 1 - inds = indself(k) - indf = indfor (k) - - do j = 1, NG29 - taug(k,j) = colamt(k,1) & - & * ( (fac00(k)*absa(ind01,j) + fac10(k)*absa(ind02,j) & - & + fac01(k)*absa(ind11,j) + fac11(k)*absa(ind12,j) ) & - & + selffac(k) * (selfref(inds,j) + selffrac(k) & - & * (selfref(inds+1,j) - selfref(inds,j))) & - & + forfac(k) * (forref(indf,j) + forfrac(k) & - & * (forref(indf+1,j) - forref(indf,j)))) & - & + colamt(k,2) * absco2(j) - enddo - enddo - - do k = laytrop+1, NLAY - ind01 = id0(k,29) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,29) + 1 - ind12 = ind11 + 1 - - do j = 1, NG29 - taug(k,j) = colamt(k,2) & - & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) & - & + fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) & - & + colamt(k,1) * absh2o(j) - enddo - enddo - - return -!................................... - end subroutine taumol29 -!----------------------------------- - -!................................... - end subroutine spcvrt -!----------------------------------- - -! -!........................................! - end module module_radsw_main ! -!========================================! - diff --git a/src/fim/FIMsrc/fim/column/radsw_param.f b/src/fim/FIMsrc/fim/column/radsw_param.f deleted file mode 100644 index 71875ce..0000000 --- a/src/fim/FIMsrc/fim/column/radsw_param.f +++ /dev/null @@ -1,190 +0,0 @@ -!!!!! ========================================================== !!!!! -!!!!! sw-rrtm2 radiation package description !!!!! -!!!!! ========================================================== !!!!! -! ! -! the sw-rrtm2 package includes these parts: ! -! ! -! 'radsw_rrtm2_param.f' ! -! 'radsw_rrtm2_datatb.f' ! -! 'radsw_rrtm2_main.f' ! -! ! -! the 'radsw_rrtm2_param.f' contains: ! -! ! -! 'module_radsw_parameters' -- band parameters set up ! -! 'module_radsw_cntr_para' -- control parameters set up ! -! ! -! the 'radsw_rrtm2_datatb.f' contains: ! -! ! -! 'module_radsw_cldprtb' -- cloud property coefficients table ! -! 'module_radlw_kgbnn' -- absorption coeffients for 14 ! -! bands, where nn = 16-29 ! -! ! -! the 'radsw_rrtm2_main.f' contains: ! -! ! -! 'module_radsw_main' -- main sw radiation transfer ! -! ! -! in the main module 'module_radsw_main' there are only two ! -! externally callable subroutines: ! -! ! -! 'swrad' -- main rrtm2 sw radiation routine ! -! 'rswinit' -- initialization routine ! -! ! -! all the sw radiation subprograms become contained subprograms ! -! in module 'module_radsw_main' and many of them are not directly ! -! accessable from places outside the module. ! -! ! -! compilation sequence is: ! -! ! -! 'radsw_rrtm2_param.f' ! -! 'radsw_rrtm2_datatb.f' ! -! 'radsw_rrtm2_main.f' ! -! ! -! and all should be put in front of routines that use sw modules ! -! ! -!!!!! ========================================================== !!!!! -!!!!! end descriptions !!!!! -!!!!! ========================================================== !!!!! - - - -!========================================! - module module_radsw_cntr_para ! -!........................................! -! - implicit none -! - integer :: iswrate, iaersw, imodsw, irgassw - integer :: iflagliq, iflagice - -! -! --- set up control parameters for sw radiation -! - parameter ( iswrate=2 ) !===> ... flag for heating rate unit - ! =1: output in k/day - ! (default) ! =2: output in k/second - parameter ( iaersw=1 ) !===> ... flag for aerosols - ! (default) ! =0: without aerosol effect - ! =1: include aerosol effect - - parameter ( imodsw=2 ) !===> ... flag for 2-stream transfer scheme - ! =1: delta-eddington (joseph et al., 1976) - ! (default) ! =2: pifm (zdunkowski et al., 1980) - ! =3: discrete ordinates (liou, 1973) - - parameter ( irgassw=1 ) !===> ... control flag for rare gases (ch4,n2o,o2, etc.) - ! =0: do not include rare gases - ! (default) ! =1: include all rare gases - - parameter ( iflagliq=1 ) !===> ... liq-cloud optical properties contrl flag - ! =0: input cloud opt depth, ignor iflagice setting - !(default) ! =1: input cwp,rew, hu and stamnes(1993) method for liq cld - - parameter ( iflagice=3 ) !===> ... ice-cloud optical properties contrl flag - ! only used when iflagc .ge. 2, else is ignored - ! =0: not set up yet - ! =1: not set up yet - ! =2: not set up yet - !(default) ! =3: input cip rei, fu (1996) for ice clouds - - -! -!........................................! - end module module_radsw_cntr_para ! -!========================================! - - - -!========================================! - module module_radsw_parameters ! -!........................................! - - use machine, only : kind_phys - - implicit none -! - public -! -! --- define type construct for radiation fluxes at toa -! - type :: topfsw_type - real (kind=kind_phys) :: upfxc ! total sky upward flux at toa - real (kind=kind_phys) :: dnfxc ! total sky downward flux at toa - real (kind=kind_phys) :: upfx0 ! clear sky upward flux at toa - end type -! -! --- define type construct for radiation fluxes at surface -! - type :: sfcfsw_type - real (kind=kind_phys) :: upfxc ! total sky upward flux at sfc - real (kind=kind_phys) :: dnfxc ! total sky downward flux at sfc - real (kind=kind_phys) :: upfx0 ! clear sky upward flux at sfc - real (kind=kind_phys) :: dnfx0 ! clear sky downward flux at sfc - end type -! -! --- define type construct for optional radiation flux profiles -! - type :: profsw_type - real (kind=kind_phys) :: upfxc ! total sky level upward flux - real (kind=kind_phys) :: dnfxc ! total sky level downward flux - real (kind=kind_phys) :: upfx0 ! clear sky level upward flux - real (kind=kind_phys) :: dnfx0 ! clear sky level downward flux - end type -! -! --- define type construct for optional component downward fluxes at surface -! - type :: cmpfsw_type - real (kind=kind_phys) :: uvbfc ! total sky downward uv-b flux at sfc - real (kind=kind_phys) :: uvbf0 ! clear sky downward uv-b flux at sfc - - real (kind=kind_phys) :: nirbm ! sfc downward nir direct beam flux - real (kind=kind_phys) :: nirdf ! sfc downward nir diffused flux - real (kind=kind_phys) :: visbm ! sfc downward uv+vis direct beam flx - real (kind=kind_phys) :: visdf ! sfc downward uv+vis diffused flux - end type -! -! --- parameter constants for sw band structures -! - integer, parameter :: NBLOW = 16 ! band range lower limit - integer, parameter :: NBHGH = 29 ! band range upper limit - integer, parameter :: NBANDS = NBHGH-NBLOW+1 ! num of spectral bands - integer, parameter :: NGPT = 112 ! total num of g-point in all bands - integer, parameter :: NGMAX = 16 ! max num of g-point in one band - integer, parameter :: MAXGAS = 6 ! max num of absorbing gases - - integer, parameter :: NSWSTR = 1 - integer, parameter :: NSWEND = NBANDS - integer, parameter :: NBDSW = NBANDS - -! --- number of g-point in each band - integer :: NG16, NG17, NG18, NG19, NG20, NG21, NG22, & - & NG23, NG24, NG25, NG26, NG27, NG28, NG29 - parameter ( NG16=06, NG17=12, NG18=08, NG19=08, NG20=10, & - & NG21=10, NG22=02, NG23=10, NG24=08, NG25=06, & - & NG26=06, NG27=08, NG28=06, NG29=12) - - integer, dimension(NBLOW:NBHGH) :: NG(NBLOW:NBHGH) - data NG / NG16, NG17, NG18, NG19, NG20, NG21, NG22, & - & NG23, NG24, NG25, NG26, NG27, NG28, NG29 / - -! --- starting index of each band - integer :: NS16, NS17, NS18, NS19, NS20, NS21, NS22, & - & NS23, NS24, NS25, NS26, NS27, NS28, NS29 - parameter ( NS16=00, NS17=NS16+NG16, NS18=NS17+NG17, & - & NS19=NS18+NG18, NS20=NS19+NG19, NS21=NS20+NG20, & - & NS22=NS21+NG21, NS23=NS22+NG22, NS24=NS23+NG23, & - & NS25=NS24+NG24, NS26=NS25+NG25, NS27=NS26+NG26, & - & NS28=NS27+NG27, NS29=NS28+NG28 ) - -! --- band wavenumber intervals - real (kind=kind_phys), dimension(NBANDS):: wvnum1, wvnum2 - data wvnum1(:) / & - & 2600.0, 3251.0, 4001.0, 4651.0, 5151.0, 6151.0, 7701.0, & - & 8051.0,12851.0,16001.0,22651.0,29001.0,38001.0, 820.0 / - data wvnum2(:) / & - & 3250.0, 4000.0, 4650.0, 5150.0, 6150.0, 7700.0, 8050.0, & - & 12850.0,16000.0,22650.0,29000.0,38000.0,50000.0, 2600.0 / - -! -!........................................! - end module module_radsw_parameters ! -!========================================! diff --git a/src/fim/FIMsrc/fim/column/rascnvv2_v.f b/src/fim/FIMsrc/fim/column/rascnvv2_v.f deleted file mode 100644 index 0782484..0000000 --- a/src/fim/FIMsrc/fim/column/rascnvv2_v.f +++ /dev/null @@ -1,4696 +0,0 @@ - module module_ras - USE MACHINE , ONLY : kind_phys - use physcons, grav => con_g, cp => con_cp, alhl => con_hvap & - &, alhf => con_hfus, rgas => con_rd, rkap => con_rocp & - &, nu => con_FVirt - implicit none - SAVE -! real, parameter :: nu=0.0 -! - integer, parameter :: nrcmax=12 ! Maximum # of random clouds per 1200s -! integer, parameter :: nrcmax=15 ! Maximum # of random clouds per 1200s -! integer, parameter :: nrcmax=20 - real (kind=kind_phys), parameter :: delt_c=1800.0 - logical, parameter :: fix_ncld_hr=.true. -! - real(kind=kind_phys) ZERO, HALF, ONE, TWO - real(kind=kind_phys) FOUR_P2,FOUR - real(kind=kind_phys) ONE_M1,ONE_M2,ONE_M5,ONE_M6,ONE_M10 - PARAMETER (ZERO=0.0, HALF=0.5, ONE=1.0, TWO=2.0) - PARAMETER (FOUR_P2=4.E2,FOUR=4.,ONE_M10=1.E-10,ONE_M6=1.E-6 & - &, ONE_M5=1.E-5,ONE_M2=1.E-2,ONE_M1=1.E-1) -! - real(kind=kind_phys), parameter :: cmb2pa = 100.0 ! Conversion from MB to PA - real(kind=kind_phys) onebg, gravcon, gravfac, elocp, elfocp, & - & rkapi, rkpp1i, zfac -! - parameter (ONEBG = ONE / GRAV, GRAVCON = cmb2pa * ONEBG & - &, GRAVFAC = GRAV / CMB2PA, ELOCP = ALHL / CP & - &, ELFOCP = (ALHL+ALHF) / CP & - &, RKAPI = ONE / RKAP, RKPP1I = ONE / (ONE+RKAP) & - &, zfac = 0.28888889E-4 * ONEBG) -! -! logical, parameter :: advcld=.false. advups=.true. -! logical, parameter :: advcld=.true., advups=.true., advtvd=.false. - logical, parameter :: advcld=.true., advups=.false., advtvd=.true. -! logical, parameter :: advcld=.false., advups=.false. -! - real(kind=kind_phys), allocatable :: RASAL(:) - real(kind=kind_phys) RHMAX, qudfac, QUAD_LAM, RHRAM, TESTMB, & - & TSTMBI, HCRIT, DD_DP, RKNOB, AFC, EKNOB - -! PARAMETER (DD_DP=1000.0, RKNOB=1.0, EKNOB=1.0) ! No downdraft! -! PARAMETER (DD_DP=100.0, RKNOB=1.0, EKNOB=1.0) -! PARAMETER (DD_DP=200.0, RKNOB=1.0, EKNOB=1.0) -! PARAMETER (DD_DP=250.0, RKNOB=1.0, EKNOB=1.0) -! PARAMETER (DD_DP=300.0, RKNOB=1.0, EKNOB=1.0) -! PARAMETER (DD_DP=450.0, RKNOB=1.0, EKNOB=1.0) -! PARAMETER (DD_DP=500.0, RKNOB=0.5, EKNOB=1.0) -! PARAMETER (DD_DP=500.0, RKNOB=0.70, EKNOB=1.0) -! PARAMETER (DD_DP=500.0, RKNOB=0.75, EKNOB=1.0) -! PARAMETER (DD_DP=500.0, RKNOB=1.0, EKNOB=1.0) - PARAMETER (DD_DP=500.0, RKNOB=1.5, EKNOB=1.0) -!!!!! PARAMETER (DD_DP=450.0, RKNOB=1.5, EKNOB=1.0) -! PARAMETER (DD_DP=450.0, RKNOB=2.0, EKNOB=1.0) -! PARAMETER (DD_DP=450.0, RKNOB=0.5, EKNOB=1.0) -! PARAMETER (DD_DP=350.0, RKNOB=0.5, EKNOB=1.0) -! PARAMETER (DD_DP=350.0, RKNOB=1.0, EKNOB=1.0) -! PARAMETER (DD_DP=350.0, RKNOB=2.0, EKNOB=1.0) -! PARAMETER (DD_DP=350.0, RKNOB=3.0, EKNOB=1.0) -! - PARAMETER (RHMAX=1.0 ) ! MAX RELATIVE HUMIDITY - PARAMETER (QUAD_LAM=1.0) ! MASK FOR QUADRATIC LAMBDA -! PARAMETER (RHRAM=0.15) ! PBL RELATIVE HUMIDITY RAMP - PARAMETER (RHRAM=0.05) ! PBL RELATIVE HUMIDITY RAMP -! PARAMETER (RHRAM=0.10) ! PBL RELATIVE HUMIDITY RAMP - PARAMETER (HCRIT=4000.0) ! Critical Moist Static Energy - parameter (qudfac=quad_lam*half) -! parameter (qudfac=quad_lam*0.25) ! Yogesh's - parameter (testmb=0.1, tstmbi=one/testmb) -! - real(kind=kind_phys) ALMIN1, ALMIN2, ALMAX - real(kind=kind_phys) facdt -! -! PARAMETER (ALMIN1=0.00E-6, ALMIN2=0.00E-5, ALMAX=1.0E-1) -! PARAMETER (ALMIN1=0.00E-6, ALMIN2=0.00E-5, ALMAX=2.0E-2) -! PARAMETER (ALMIN1=0.00E-6, ALMIN2=1.00E-6, ALMAX=2.0E-2) -! PARAMETER (ALMIN1=5.00E-6, ALMIN2=2.50E-5, ALMAX=2.0E-2) -! PARAMETER (ALMIN1=0.00E-6, ALMIN2=2.50E-5, ALMAX=2.0E-2) -!!! PARAMETER (ALMIN1=0.00E-6, ALMIN2=2.50E-5, ALMAX=1.0E-2) -!! PARAMETER (ALMIN1=0.00E-6, ALMIN2=2.50E-5, ALMAX=1.0E-3) -! PARAMETER (ALMIN1=0.00E-6, ALMIN2=1.00E-5, ALMAX=1.0E-2) -! PARAMETER (ALMIN1=0.00E-6, ALMIN2=2.00E-5, ALMAX=1.0E-2) -! PARAMETER (ALMIN1=0.00E-6, ALMIN2=2.50E-5, ALMAX=1.0E-2) - PARAMETER (ALMIN1=0.00E-6, ALMIN2=4.00E-5, ALMAX=1.0E-2) -!cnt PARAMETER (ALMIN1=0.00E-6, ALMIN2=2.50E-5, ALMAX=5.0E-3) -!LL PARAMETER (ALMIN1=0.00E-6, ALMIN2=2.50E-5, ALMAX=4.0E-3) -! PARAMETER (ALMIN1=0.00E-6, ALMIN2=1.00E-5, ALMAX=2.0E-2) -! PARAMETER (ALMIN1=0.00E-6, ALMIN2=5.00E-4, ALMAX=2.0E-2) -! PARAMETER (ALMIN1=0.10E-4, ALMIN2=0.15E-4, ALMAX=1.0E-1) -! PARAMETER (ALMIN1=0.00E-4, ALMIN2=0.40E-4, ALMAX=2.0E-2) -! PARAMETER (ALMIN1=0.20E-4, ALMIN2=0.40E-4, ALMAX=2.0E-2) -! PARAMETER (ALMIN1=0.25E-4, ALMIN2=0.50E-4, ALMAX=2.0E-2) -! PARAMETER (ALMIN1=0.40E-4, ALMIN2=0.50E-4, ALMAX=2.0E-2) -! - real(kind=kind_phys), parameter :: BLDMAX = 200.0 -! - INTEGER KBLMX - real(kind=kind_phys) C0, C0I, QI0, QW0 -! PARAMETER (QI0=1.0E-4, QW0=1.0E-4) -! PARAMETER (QI0=0.0E-5, QW0=0.0E-0) - PARAMETER (QI0=1.0E-5, QW0=1.0E-5) -! PARAMETER (QI0=1.0E-4, QW0=1.0E-5) ! 20050509 -! PARAMETER (QI0=1.0E-5, QW0=1.0E-6) -! PARAMETER (QI0=0.0E-5, QW0=0.0E-5) -!!! PARAMETER (QI0=5.0E-4, QW0=1.0E-5) -! PARAMETER (QI0=5.0E-4, QW0=5.0E-4) -! PARAMETER (QI0=2.0E-4, QW0=2.0E-5) -! PARAMETER (QI0=2.0E-5, QW0=2.0E-5) -! PARAMETER (QI0=2.0E-4, QW0=1.0E-4) -! PARAMETER (QI0=2.0E-4, QW0=1.0E-5) -! PARAMETER (QI0=1.0E-3, QW0=2.0E-5) -! PARAMETER (QI0=1.0E-3, QW0=7.0E-4) -! PARAMETER (C0I=5.0E-4) -! PARAMETER (C0I=4.0E-4) - PARAMETER (C0I=1.0E-3) -! parameter (c0=1.0e-3) -! parameter (c0=1.5e-3) - parameter (c0=2.0e-3) -! parameter (c0=1.0e-3, KBLMX=10, ERRMIN=0.0001, ERRMI2=0.1*ERRMIN) -! parameter (c0=2.0e-3, KBLMX=10, ERRMIN=0.0001, ERRMI2=0.1*ERRMIN) -! - real(kind=kind_phys) TF, TCR, TCRF, TCL -! parameter (TF=130.16, TCR=160.16, TCRF=1.0/(TCR-TF),TCL=2.0) -! parameter (TF=230.16, TCR=260.16, TCRF=1.0/(TCR-TF)) - parameter (TF=233.16, TCR=263.16, TCRF=1.0/(TCR-TF),TCL=2.0) -! -! For Tilting Angle Specification -! - real(kind=kind_phys) REFP(6), REFR(6), TLAC(8), PLAC(8), TLBPL(7) & - &, drdp(5), VTP -! - DATA PLAC/100.0, 200.0, 300.0, 400.0, 500.0, 600.0, 700.0, 800.0/ -! DATA TLAC/ 37.0, 25.0, 17.0, 12.0, 10.0, 8.0, 6.0, 5.0/ -! DATA TLAC/ 35.0, 24.0, 17.0, 12.0, 10.0, 8.0, 6.0, 5.0/ -! DATA TLAC/ 35.0, 25.0, 20.0, 17.5, 15.0, 12.5, 10.0, 5.0/ - DATA TLAC/ 35.0, 25.0, 20.0, 17.5, 15.0, 12.5, 10.0, 7.5/ -! DATA TLAC/ 37.0, 26.0, 18.0, 14.0, 10.0, 8.0, 6.0, 5.0/ -! DATA TLAC/ 25.0, 22.5, 20.0, 17.5, 15.0, 12.5, 10.0, 10.0/ - DATA REFP/500.0, 300.0, 250.0, 200.0, 150.0, 100.0/ -! DATA REFR/ 0.25, 0.5, 0.75, 1.0, 1.5, 2.0/ -! DATA REFR/ 0.5, 1.0, 1.5, 2.0, 3.0, 4.0/ - DATA REFR/ 1.0, 2.0, 3.0, 4.0, 6.0, 8.0/ -! - real(kind=kind_phys) AC(16), AD(16) -! - integer, parameter :: nqrp=500001 - real(kind=kind_phys) C1XQRP, C2XQRP, TBQRP(NQRP), TBQRA(NQRP) & - &, TBQRB(NQRP) -! - integer, parameter :: nvtp=10001 - real(kind=kind_phys) C1XVTP, C2XVTP, TBVTP(NVTP) -! - contains -! - subroutine set_ras_afc(dt) - implicit none - real(kind=kind_phys) DT -! AFC = -(1.04E-4*DT)*(3600./DT)**0.578 - AFC = -(1.01097E-4*DT)*(3600./DT)**0.57777778 - end subroutine set_ras_afc - - subroutine ras_init(levs, me) -! - Implicit none -! - integer levs -! - real(kind=kind_phys) actp, facm, tem, actop - real(kind=kind_phys) rasalf, tem1, tem2 - integer i, l, me -! PARAMETER (ACTP=1.7, FACM=1.20) - PARAMETER (ACTP=1.7, FACM=1.00) -! PARAMETER (ACTP=1.7, FACM=0.90) -! PARAMETER (ACTP=1.7, FACM=0.75) -! PARAMETER (ACTP=1.7, FACM=0.60) -! PARAMETER (ACTP=1.7, FACM=0.5) ! cnt -! PARAMETER (ACTP=1.7, FACM=0.4) -! PARAMETER (ACTP=1.7, FACM=0.0) -! - real(kind=kind_phys) PH(15), A(15) -! - DATA PH/150.0, 200.0, 250.0, 300.0, 350.0, 400.0, 450.0, 500.0 & - &, 550.0, 600.0, 650.0, 700.0, 750.0, 800.0, 850.0/ -! - DATA A/ 1.6851, 1.1686, 0.7663, 0.5255, 0.4100, 0.3677 & - &, 0.3151, 0.2216, 0.1521, 0.1082, 0.0750, 0.0664 & - &, 0.0553, 0.0445, 0.0633/ -! - logical first - data first/.true./ -! - if (first) then -! - allocate (rasal(levs)) -! set critical workfunction arrays - ACTOP = ACTP*FACM - DO L=1,15 - A(L) = A(L)*FACM - ENDDO - DO L=2,15 - TEM = 1.0 / (PH(L) - PH(L-1)) - AC(L) = (PH(L)*A(L-1) - PH(L-1)*A(L)) * TEM - AD(L) = (A(L) - A(L-1)) * TEM - ENDDO - AC(1) = ACTOP - AC(16) = A(15) - AD(1) = 0.0 - AD(16) = 0.0 -! -! CALL SETES - CALL SETQRP - CALL SETVTP -! -! kblmx = levs / 2 -! -! RASALF = 0.10 -! RASALF = 0.20 - RASALF = 0.30 -! RASALF = 0.35 -! - DO L=1,LEVS - RASAL(L) = RASALF - ENDDO -! -! - do i=1,7 - tlbpl(i) = (tlac(i)-tlac(i+1)) / (plac(i)-plac(i+1)) - enddo - do i=1,5 - drdp(i) = (REFR(i+1)-REFR(i)) / (REFP(i+1)-REFP(i)) - enddo -! - VTP = 36.34*SQRT(1.2)* (0.001)**0.1364 -! - if (me .eq. 0) print *,' NO DOWNDRAFT FOR CLOUD TYPES' & - &, ' DETRAINING WITHIN THE BOTTOM ',DD_DP,' hPa LAYERS' -! - first = .false. - endif -! - end subroutine ras_init - end module module_ras -! - module module_rascnv -! - USE MACHINE , ONLY : kind_phys - implicit none - SAVE - -! - logical REVAP, CUMFRC - LOGICAL WRKFUN, CALKBL, CRTFUN, UPDRET, BOTOP - real(kind=kind_phys) FRAC, CRTMSF, MAX_NEG_BOUY, rhfacs, rhfacl & - &, FACE, DELX, DDFAC - parameter (frac=0.5, crtmsf=0.0) -! PARAMETER (MAX_NEG_BOUY=0.25, REVAP=.TRUE., CUMFRC=.true.) -! PARAMETER (MAX_NEG_BOUY=0.20, REVAP=.TRUE., CUMFRC=.true.) -! PARAMETER (MAX_NEG_BOUY=0.15, REVAP=.true., CUMFRC=.true.) -!LL3 PARAMETER (MAX_NEG_BOUY=0.10, REVAP=.TRUE., CUMFRC=.true.) -! PARAMETER (MAX_NEG_BOUY=0.15, REVAP=.true., CUMFRC=.false.) - PARAMETER (MAX_NEG_BOUY=0.15, REVAP=.true., CUMFRC=.true.) -! PARAMETER (MAX_NEG_BOUY=0.15, REVAP=.true., CUMFRC=.false.) -! PARAMETER (MAX_NEG_BOUY=0.05, REVAP=.true., CUMFRC=.true.) - PARAMETER (WRKFUN = .FALSE., UPDRET = .FALSE.) - PARAMETER (CRTFUN = .TRUE., CALKBL = .true., BOTOP=.true.) -! -! parameter (rhfacs=0.70, rhfacl=0.70) -! parameter (rhfacs=0.75, rhfacl=0.75) - parameter (rhfacs=0.80, rhfacl=0.80) -! parameter (rhfacs=0.80, rhfacl=0.85) - PARAMETER (FACE=5.0, DELX=10000.0, DDFAC=FACE*DELX*0.001) -! -! real (kind=kind_phys), parameter :: pgftop=0.7, pgfbot=0.3 & -! real (kind=kind_phys), parameter :: pgftop=0.75, pgfbot=0.35 & - real (kind=kind_phys), parameter :: pgftop=0.80, pgfbot=0.30 & - &, pgfgrad=(pgfbot-pgftop)*0.001 -! - end module module_rascnv -! -! - subroutine rascnv(IM, IX, k, dt, dtf, rannum & - &, tin, qin, uin, vin, ccin, trac & - &, prsi, prsl, prsik, prslk, phil, phii & - &, KPBL, CDRAG, RAINC, kbot, ktop, kuo & - &, DDVEL, FLIPV, facmb, me, garea, lmh, ccwfac& - &, nrcm, rhc, ud_mf, dd_mf, det_mf,lprnt, ipr) -! -!********************************************************************* -!********************************************************************* -!************ Relaxed Arakawa-Schubert ****************** -!************ Parameterization ****************** -!************ Plug Compatible Driver ****************** -!************ 23 May 2002 ****************** -!************ ****************** -!************ Developed By ****************** -!************ ****************** -!************ Shrinivas Moorthi ****************** -!************ ****************** -!************ EMC/NCEP ****************** -!********************************************************************* -!********************************************************************* -! -! - USE MACHINE , ONLY : kind_phys - use module_ras, DPD => DD_DP - use module_rascnv - Implicit none -! - LOGICAL FLIPV, lprnt -! -! input -! - Integer IM, IX, k, ncrnd, me, trac, ipr, nrcm - Integer kbot(im), ktop(im), kuo(im), KPBL(im), lmh(im) -! - real(kind=kind_phys) tin(ix,k), qin(ix,k), uin(ix,k) & - &, vin(ix,k), prsi(ix,k+1) & - &, prsik(ix,k+1), prsl(ix,k), prslk(ix,k+1) & - &, phil(ix,k), phii(ix,k+1),ccwfac(im) & - &, ccin(ix,k,trac+2) & -! &, prsik(ix,k+1), clt(ix,k) & - &, RAINC(im), CDRAG(im), DDVEL(im) & - &, rannum(ix,nrcm) & - &, ud_mf(im,k), dd_mf(im,k), det_mf(im,k) - real(kind=kind_phys) DT, facmb, garea(im), dtf, rhc(im,k) -! -! locals -! - real(kind=kind_phys) RAIN, toi(k), qoi(k), uvi(k,trac+2) & - &, TCU(k), QCU(k), PCU(k), clw(k), cli(k) & - &, QII(k), QLI(k), PRS(k+1), PSJ(k+1) & - &, phi_l(k), phi_h(k+1) & - &, RCU(k,2), wfnc, flx(k+1), FLXD(K+1) -! &, RCU(k,2), rkap, rkapi, rkpp1i, wfnc - real(kind=kind_phys) daylen,pfac,tla,pl,clwmin - integer icm,irnd,ib - - PARAMETER (ICM=100, DAYLEN=86400.0, PFAC=1.0/450.0,clwmin=1.0e-10) - Integer IC(ICM) -! - real(kind=kind_phys), allocatable :: ALFINT(:,:) -! real(kind=kind_phys) ALFINT(K), ALFINQ(K), PRSM(K), PSJM(K) - real(kind=kind_phys) ALFINQ(K), PRSM(K), PSJM(K) & - &, trcfac(trac+2,k) & - &, alfind(K), rhc_l(k), dtvd(2,4) -! &, DPI(K), psjp(k+1) - real(kind=kind_phys) CFAC, TEM, dpi, sgc, ccwf, tem1, tem2 -! - Integer KCR, KFX, NCMX, NC, KTEM, I, L, lm1 & - &, ntrc, ia, ll, km1, kp1, ipt, lv, KBL, n & - &, lmhij, KRMIN, KRMAX, KFMAX -! - LOGICAL DNDRFT, lprint -! - km1 = k - 1 - kp1 = k + 1 -! - ntrc = trac - trcfac(:,:) = 1.0 ! For other tracers - IF (CUMFRC) THEN - ntrc = ntrc + 2 -! trcfac(trac+1) = 0.45 ! For press grad correction c=0.55 -! trcfac(trac+2) = 0.45 ! in momentum mixing calculations - ENDIF -! - if (.not. allocated(alfint)) allocate(alfint(k,ntrc+4)) -! - call set_ras_afc(dt) -! - ccwf = 0.5 - DO IPT=1,IM -! -! Resolution dependent press grad correction momentum mixing -! - IF (CUMFRC) THEN -!!!! tem = max(0.0, min(1.0, sqrt(sqrt(garea(ipt)*0.25E-10)))) -! tem = max(0.0, min(1.0, sqrt(garea(ipt)*0.25E-10))) -! tem = max(0.1, min(1.0, sqrt(garea(ipt)*0.25E-10))) -! tem = max(0.25, min(1.0, sqrt(garea(ipt)*0.25E-10))) -! tem = max(0.50, min(1.0, sqrt(garea(ipt)*0.25E-10))) -! tem = max(0.45, min(1.0, sqrt(garea(ipt)*0.25E-10))) ! for r2 and rf exp -! tem = 1.0 ! for r1 exp -! tem = 0.45 ! for r6 exp - -! trcfac(trac+1,l) = tem ! For press grad correction c=0.55 -! trcfac(trac+2,l) = tem ! in momentum mixing calculations -! - if (ccwfac(ipt) >= 0.0) ccwf = ccwfac(ipt) - ENDIF - do l=1,k - ud_mf(ipt,l) = 0.0 - dd_mf(ipt,l) = 0.0 - det_mf(ipt,l) = 0.0 - enddo -! -! Compute NCRND : here LMH is the number of layers above the -! bottom surface. For sigma coordinate LMH=K. -! - LMHIJ = LMH(ipt) - if (flipv) then - ll = kp1 - LMH(ipt) - tem = 1.0 / prsi(ipt,ll) - else - ll = LMH(ipt) - tem = 1.0 / prsi(ipt,ll+1) - endif - KRMIN = 1 - KRMAX = km1 - KFMAX = KRMAX - DO L=1,LMHIJ-1 - ll = l - if (flipv) ll = kp1 -l ! Input variables are bottom to top! - SGC = prsl(ipt,ll) * tem - IF (SGC .LE. 0.050) KRMIN = L -! IF (SGC .LE. 0.600) KRMAX = L - IF (SGC .LE. 0.700) KRMAX = L -! IF (SGC .LE. 0.800) KRMAX = L -!! IF (SGC .LE. 0.760) KRMAX = L -! IF (SGC .LE. 0.930) KFMAX = L - IF (SGC .LE. 0.970) KFMAX = L ! Commented on 20060202 -!LL2 IF (SGC .LE. 0.950) KFMAX = L - ENDDO -! if (lprnt .and. ipt .eq. ipr) print *,' krmin=',krmin,' krmax=', -! &krmax,' kfmax=',kfmax,' lmhij=',lmhij,' tem=',tem -! - if (fix_ncld_hr) then - NCRND = min(nrcmax, (KRMAX-KRMIN+1)) * (DTF/1200) + 0.50001 -! NCRND = min(nrcmax, (KRMAX-KRMIN+1)) * (DTF/1800) + 0.50001 - facdt = delt_c / dt - else - NCRND = min(nrcmax, (KRMAX-KRMIN+1)) - facdt = 1.0 - endif - IF (DT .GT. DTF) NCRND = (5*NCRND) / 4 - NCRND = max(NCRND, 1) -! - KCR = MIN(LMHIJ,KRMAX) - KTEM = MIN(LMHIJ,KFMAX) - KFX = KTEM - KCR -! if(lprnt)print*,' enter RASCNV k=',k,' ktem=',ktem,' LMHIJ=' -! &, LMHIJ -! &, ' krmax=',krmax,' kfmax=',kfmax -! &, ' kcr=',kcr, ' cdrag=',cdrag(ipr) - - IF (KFX .GT. 0) THEN - IF (BOTOP) THEN - DO NC=1,KFX - IC(NC) = KTEM + 1 - NC - ENDDO - ELSE - DO NC=KFX,1,-1 - IC(NC) = KTEM + 1 - NC - ENDDO - ENDIF - ENDIF -! - NCMX = KFX + NCRND - IF (NCRND .GT. 0) THEN - DO I=1,NCRND - IRND = (RANNUM(ipt,I)-0.0005)*(KCR-KRMIN+1) - IC(KFX+I) = IRND + KRMIN - ENDDO - ENDIF -! -! ia = 1 -! -! print *,' in rascnv: k=',k,'lat=',lat,' lprnt=',lprnt -! if (lprnt) then -! if (me .eq. 0) then -! print *,' tin',(tin(ia,l),l=k,1,-1) -! print *,' qin',(qin(ia,l),l=k,1,-1) -! endif -! -! - lprint = lprnt .and. ipt .eq. ipr - lprint = lprnt -! kuo(ipt) = 0 - do l=1,k - ll = l - if (flipv) ll = kp1 -l ! Input variables are bottom to top! - CLW(l) = 0.0 ! Assumes initial value of Cloud water - CLI(l) = 0.0 ! Assumes initial value of Cloud ice - ! to be zero i.e. no environmental condensate!!! -! CLT(ipt,l) = 0.0 - QII(l) = 0.0 - QLI(l) = 0.0 -! Initialize heating, drying, cloudiness etc. - tcu(l) = 0.0 - qcu(l) = 0.0 - pcu(l) = 0.0 - flx(l) = 0.0 - flxd(l) = 0.0 - rcu(l,1) = 0.0 - rcu(l,2) = 0.0 -! Transfer input prognostic data into local variable - toi(l) = tin(ipt,ll) - qoi(l) = qin(ipt,ll) - uvi(l,trac+1) = uin(ipt,ll) - uvi(l,trac+2) = vin(ipt,ll) -! - do n=1,trac - uvi(l,n) = ccin(ipt,ll,n+2) - enddo -! - enddo - flx(k+1) = 0.0 - flxd(k+1) = 0.0 -! - if (ccin(ipt,1,2) .le. -999.0) then - do l=1,k - ll = l - if (flipv) ll = kp1 -l ! Input variables are bottom to top! - tem = ccin(ipt,ll,1) & - & * MAX(ZERO, MIN(ONE, (TCR-toi(L))*TCRF)) - ccin(ipt,ll,2) = ccin(ipt,ll,1) - tem - ccin(ipt,ll,1) = tem - enddo - endif - if (advcld) then - do l=1,k - ll = l - if (flipv) ll = kp1 -l ! Input variables are bottom to top! - QII(L) = ccin(ipt,ll,1) - QLI(L) = ccin(ipt,ll,2) - enddo - endif -! - KBL = KPBL(ipt) - if (flipv) KBL = MAX(MIN(k, kp1-KPBL(ipt)), k/2) - rain = 0.0 -! - DO L=1,kp1 - ll = l - if (flipv) ll = kp1 + 1 - l ! Input variables are bottom to top! - PRS(LL) = prsi(ipt, L) * facmb ! facmb is for conversion to MB - PSJ(LL) = prsik(ipt,L) - phi_h(LL) = phii(ipt,L) - ENDDO -! - DO L=1,k - ll = l - if (flipv) ll = kp1 - l ! Input variables are bottom to top! - PRSM(LL) = prsl(ipt, L) * facmb ! facmb is for conversion to MB - PSJM(LL) = prslk(ipt,L) - phi_l(LL) = phil(ipt,L) - rhc_l(LL) = rhc(ipt,L) -! -! rhc_l(ll) = 1.0 - ENDDO -! -! if(lprint) print *,' PRS=',PRS -! if(lprint) print *,' PRSM=',PRSM -! if (lprint) then -! print *,' qns=',qns(ia),' qoi=',qn0(ia,k),'qin=',qin(ia,1) -! if (me .eq. 0) then -! print *,' toi',(tn0(ia,l),l=1,k) -! print *,' qoi',(qn0(ia,l),l=1,k),' kbl=',kbl -! endif -! -! -!! PSJP(KP1) = PSJ(KP1) * PRS(KP1) * RKPP1I -! do l=k,kctop(1),-1 -! DPI = RKPP1I / (PRS(L+1) - PRS(L)) -! PSJM(L) = (PSJ(L+1)*PRS(L+1) - PSJ(L)*PRS(L)) * DPI -!! PSJP(L) = PSJ(L) * PRS(L) * RKPP1I -!! DPI(L) = 1.0 / (PRS(L+1) - PRS(L)) -!! PSJM(L) = (PSJP(L+1) - PSJP(L)) * DPI(L) -! PRSM(L) = 1000.0 * PSJM(L) ** (1.0/rkap) -!! PRSM(L) = 1000.0 * PSJM(L) ** rkapi -!! PRSM(L) = 0.5 * (prs(L+1)+prs(L)) -! enddo -! -! -! -! print *,' ipt=',ipt - alfint(:,:) = 0.5 ! For second order scheme - alfind(:) = 0.5 - if (advups) then ! For first order upstream for updraft - alfint(:,:) = 1.0 - elseif (advtvd) then ! TVD flux limiter scheme for updraft - alfint(:,:) = 1.0 - l = krmin - lm1 = l - 1 - dtvd(1,1) = cp*(toi(l)-toi(lm1)) + phi_l(l)-phi_l(lm1) & - & + alhl*(qoi(l)-qoi(lm1)) - dtvd(1,2) = qoi(l) - qoi(lm1) - dtvd(1,3) = qli(l) - qli(lm1) - dtvd(1,4) = qii(l) - qii(lm1) - do l=krmin+1,k - lm1 = l - 1 -! print *,' toi=',toi(l),toi(lm1),' phi_l=',phi_l(l),phi_l(lm1) -! &,' qoi=',qoi(l),qoi(lm1),' cp=',cp,' alhl=',alhl - dtvd(2,1) = cp*(toi(l)-toi(lm1)) + phi_l(l)-phi_l(lm1) & - & + alhl*(qoi(l)-qoi(lm1)) -! print *,' l=',l,' dtvd=',dtvd(:,1) - if (abs(dtvd(2,1)) > 1.0e-10) then - tem1 = dtvd(1,1) / dtvd(2,1) - tem2 = abs(tem1) - alfint(l,1) = 1.0 - 0.5*(tem1 + tem2)/(1.0 + tem2) ! for h - endif -! print *,' alfint=',alfint(l,1),' l=',l,' ipt=',ipt - dtvd(1,1) = dtvd(2,1) -! - dtvd(2,2) = qoi(l) - qoi(lm1) -! print *,' l=',l,' dtvd2=',dtvd(:,2) - if (abs(dtvd(2,2)) > 1.0e-10) then - tem1 = dtvd(1,2) / dtvd(2,2) - tem2 = abs(tem1) - alfint(l,2) = 1.0 - 0.5*(tem1 + tem2)/(1.0 + tem2) ! for q - endif - dtvd(1,2) = dtvd(2,2) -! - dtvd(2,3) = qli(l) - qli(lm1) -! print *,' l=',l,' dtvd3=',dtvd(:,3) - if (abs(dtvd(2,3)) > 1.0e-10) then - tem1 = dtvd(1,3) / dtvd(2,3) - tem2 = abs(tem1) - alfint(l,3) = 1.0 - 0.5*(tem1 + tem2)/(1.0 + tem2) ! for ql - endif - dtvd(1,3) = dtvd(2,3) -! - dtvd(2,4) = qii(l) - qii(lm1) -! print *,' l=',l,' dtvd4=',dtvd(:,4) - if (abs(dtvd(2,4)) > 1.0e-10) then - tem1 = dtvd(1,4) / dtvd(2,4) - tem2 = abs(tem1) - alfint(l,4) = 1.0 - 0.5*(tem1 + tem2)/(1.0 + tem2) ! for qi - endif - dtvd(1,4) = dtvd(2,4) - enddo -! - if (ntrc > 0) then - do n=1,ntrc - l = krmin - dtvd(1,1) = uvi(l,n) - uvi(l-1,n) - do l=krmin+1,k - dtvd(2,1) = uvi(l,n) - uvi(l-1,n) -! print *,' l=',l,' dtvdn=',dtvd(:,1),' n=',n,' l=',l - if (abs(dtvd(2,1)) > 1.0e-10) then - tem1 = dtvd(1,1) / dtvd(2,1) - tem2 = abs(tem1) - alfint(l,n+4) = 1.0 - 0.5*(tem1 + tem2)/(1.0 + tem2) ! for tracers - endif - dtvd(1,1) = dtvd(2,1) - enddo - enddo - endif - endif -! -! print *,' after alfint for ipt=',ipt - if (CUMFRC) then - - do l=krmin,k - tem = 1.0 - max(pgfbot, min(pgftop, pgftop+pgfgrad*prsm(l))) - trcfac(trac+1,l) = tem - trcfac(trac+2,l) = tem - enddo - endif -! - lprint = lprnt .and. ipt .eq. ipr -! if (lprint) then -! print *,' trcfac=',trcfac(1+trac,krmin:k) -! print *,' alfint=',alfint(krmin:k,1) -! print *,' alfinq=',alfint(krmin:k,2) -! print *,' alfini=',alfint(krmin:k,4) -! print *,' alfinu=',alfint(krmin:k,5) -! endif -! - if (calkbl) kbl = k - DO NC=1,NCMX -! - IB = IC(NC) - if (ib .gt. kbl) cycle -! lprint = lprnt .and. ipt .eq. ipr -! lprint = lprnt .and. ipt .eq. ipr .and. ib .eq. 41 -! - DNDRFT = DPD .GT. 0.0 -! -! if (lprint) print *,' calling cloud type ib=',ib,' kbl=',kbl -! *,' kpbl=',kpbl,' alfint=',alfint,' frac=',frac -! *,' ntrc=',ntrc,' ipt=',ipt -! -! if (advtvd) then ! TVD flux limiter scheme for updraft -! l = ib -! lm1 = l - 1 -! dtvd(1,1) = cp*(toi(l)-toi(lm1)) + phi_l(l)-phi_l(lm1) -! & + alhl*(qoi(l)-qoi(lm1)) -! dtvd(1,2) = qoi(l) - qoi(lm1) -! dtvd(1,3) = qli(l) - qli(lm1) -! dtvd(1,4) = qii(l) - qii(lm1) -! do l=ib+1,k -! lm1 = l - 1 -! dtvd(2,1) = cp*(toi(l)-toi(lm1)) + phi_l(l)-phi_l(lm1) -! & + alhl*(qoi(l)-qoi(lm1)) -! if (abs(dtvd(2,1)) > 1.0e-10) then -! tem1 = dtvd(1,1) / dtvd(2,1) -! tem2 = abs(tem1) -! alfint(l,1) = 1.0 - 0.5*(tem1 + tem2)/(1.0 + tem2) ! for h -! endif -! dtvd(1,1) = dtvd(2,1) -! -! dtvd(2,2) = qoi(l) - qoi(lm1) -! if (abs(dtvd(2,2)) > 1.0e-10) then -! tem1 = dtvd(1,2) / dtvd(2,2) -! tem2 = abs(tem1) -! alfint(l,2) = 1.0 - 0.5*(tem1 + tem2)/(1.0 + tem2) ! for q -! endif -! dtvd(1,2) = dtvd(2,2) -! -! dtvd(2,3) = qli(l) - qli(lm1) -! if (abs(dtvd(2,3)) > 1.0e-10) then -! tem1 = dtvd(1,3) / dtvd(2,3) -! tem2 = abs(tem1) -! alfint(l,3) = 1.0 - 0.5*(tem1 + tem2)/(1.0 + tem2) ! for ql -! endif -! dtvd(1,3) = dtvd(2,3) -! -! dtvd(2,4) = qii(l) - qii(lm1) -! if (abs(dtvd(2,4)) > 1.0e-10) then -! tem1 = dtvd(1,4) / dtvd(2,4) -! tem2 = abs(tem1) -! alfint(l,4) = 1.0 - 0.5*(tem1 + tem2)/(1.0 + tem2) ! for qi -! endif -! dtvd(1,4) = dtvd(2,4) -! enddo -! -! if (ntrc > 0) then -! do n=1,ntrc -! l = ib -! dtvd(1,1) = uvi(l,n) - uvi(l-1,n) -! do l=ib+1,k -! dtvd(2,1) = uvi(l,n) - uvi(l-1,n) -! if (abs(dtvd(2,1)) > 1.0e-10) then -! tem1 = dtvd(1,1) / dtvd(2,1) -! tem2 = abs(tem1) -! alfint(l,n+4) = 1.0 - 0.5*(tem1 + tem2)/(1.0 + tem2) ! for tracers -! endif -! dtvd(1,1) = dtvd(2,1) -! enddo -! enddo -! endif -! endif -! -! -! if (lprint) then -! ia = ipt -! print *,' toi=',(toi(ia,l),l=1,K) -! print *,' qoi=',(qoi(ia,l),l=1,K),' kbl=',kbl -! print *,' toi=',(toi(l),l=1,K) -! print *,' qoi=',(qoi(l),l=1,K),' kbl=',kbl -! print *,' prs=',(prs(l),l=1,K) -! endif -! - WFNC = 0.0 - do L=IB,K+1 - FLX(L) = 0.0 - FLXD(L) = 0.0 - enddo -! -! -! if (me .eq. 0) then -! if(lprint)then -! print *,' CALLING CLOUD TYPE IB= ', IB,' DT=',DT,' K=',K -! &, 'ipt=',ipt -! print *,' TOI=',(TOI(L),L=IB,K) -! print *,' QOI=',(QOI(L),L=IB,K) -! endif -! print *,' alft=',alfint -! - TLA = -10.0 -! -! if (lprint) print *,' qliin=',qli -! if (lprint) print *,' qiiin=',qii - CALL CLOUD(lmhij, IB, ntrc & - &, RASAL(IB), FRAC, MAX_NEG_BOUY & - &, ALFINT, rhfacl, rhfacs, garea(ipt) & -! &, ALFINT, ALFINQ, rhfacl, rhfacs, garea(ipt) & - &, alfind, rhc_l & -! - &, TOI, QOI, UVI, PRS, PRSM, phi_l, phi_h & -! &, TOI, QOI, UVI, PRS, PRSM, PSJ, PSJM -! &, TOI, QOI, UVI, PRS, PRSM, PSJ, PSJM, DPI -! &, TOI, QOI, UVI, PRS, PSJ - &, QLI, QII, KBL, DDVEL(ipt) & - &, CDRAG(ipt),lprint, trcfac, ccwf & -! &, IDIAG, lprnt - &, TCU, QCU, RCU, PCU, FLX, FLXD & - &, RAIN, REVAP, DT & - &, WFNC, WRKFUN, CALKBL, CRTFUN, TLA, DNDRFT, DPD) -! &, WFNC, WRKFUN, CALKBL, CRTFUN, TLA, DNDRFT, UPDRET) -! if (lprint) print *,' rain=',rain,' ipt=',ipt -! if (me .eq. 0) then -! if (lprint) then -! print *,' after calling CLOUD TYPE IB= ', IB & -! &,' rain=',rain,' prskd=',prs(ib),' qli=',qli(ib),' qii=',qii(ib) -! print *,' TOI=',(TOI(L),L=1,K),' me=',me,' ib=',ib -! print *,' QOI=',(QOI(L),L=1,K) -! endif -! if (lprint) print *,' qliou=',qli -! if (lprint) print *,' qiiou=',qii -! - do L=IB,K - ll = l - if (flipv) ll = kp1 -l ! Input variables are bottom to top! - ud_mf(ipt,ll) = ud_mf(ipt,ll) + flx(l+1) - dd_mf(ipt,ll) = dd_mf(ipt,ll) + flxd(l+1) - enddo - ll = ib - if (flipv) ll = kp1 - ib - det_mf(ipt,ll) = det_mf(ipt,ll) + flx(ib) -! -! Compute cloud amounts for the Goddard radiation -! -! IF (FLX(KBL) .GT. 0.0) THEN -! PL = 0.5 * (PRS(IB) + PRS(IB+1)) -! CFAC = MIN(1.0, MAX(0.0, (850.0-PL)*PFAC)) -! ELSE -! CFAC = 0.0 -! ENDIF -! -! Warining!!!! -! ------------ -! By doing the following, CLOUD does not contain environmental -! condensate! -! - if (.not. advcld) then - do l=1,K -! clw(l ) = clw(l) + QLI(L) + QII(L) - clw(l ) = clw(l) + QLI(L) - cli(l ) = cli(l) + QII(L) - QLI(L) = 0.0 - QII(L) = 0.0 - enddo - endif -! - ENDDO ! End of the NC loop! -! - RAINC(ipt) = rain * 0.001 ! Output rain is in meters -! if(lprint)print*,' convective precip=',rain*86400/dt,' mm/day' -! 1, ' ipt=',ipt -! -! if (lprint) then -! print *,' toi',(tn0(imax,l),l=1,k) -! print *,' qoi',(qn0(imax,l),l=1,k) -! endif -! - do l=1,k - ll = l - if (flipv) ll = kp1 - l - tin(ipt,ll) = toi(l) ! Temperature - qin(ipt,ll) = qoi(l) ! Specific humidity - uin(ipt,ll) = uvi(l,trac+1) ! U momentum - vin(ipt,ll) = uvi(l,trac+2) ! V momentum -! clw(l) = clw(l) + qli(l) + qii(l) ! Cloud condensate -! ccin(ipt,ll,1) = ccin(ipt,ll,1) + clw(l) - do n=1,trac - ccin(ipt,ll,n+2) = uvi(l,n) ! Tracers - enddo - enddo - if (advcld) then - do l=1,k - ll = l - if (flipv) ll = kp1 - l -! ccin(ipt,ll,1) = qli(l) + qii(l) ! Cloud condensate - ccin(ipt,ll,1) = qii(l) ! Cloud ice - ccin(ipt,ll,2) = qli(l) ! Cloud water - enddo - else - do l=1,k - ll = l - if (flipv) ll = kp1 - l -! ccin(ipt,ll,1) = ccin(ipt,ll,1) + clw(l) - ccin(ipt,ll,1) = ccin(ipt,ll,1) + cli(l) - ccin(ipt,ll,2) = ccin(ipt,ll,2) + clw(l) - enddo - endif -! -! kuo(ipt) = 0 -! - ktop(ipt) = kp1 - kbot(ipt) = 0 - - do l=lmhij-1,1,-1 - if (prs(lmhij+1)-prs(l) .gt. 250.0 .and. tcu(l) .ne. 0.0) then ! for r1 &rf -! if (prs(lmhij+1)-prs(l) .gt. 100.0 .and. tcu(l) .ne. 0.0) then ! for r1 &rf -!1 if (prs(lmhij+1)-prs(l) .gt. 300.0 .and. tcu(l) .ne. 0.0) then -! if (prs(lmhij+1)-prs(l) .gt. 500.0 .and. tcu(l) .ne. 0.0) then -! if (prs(lmhij+1)-prs(l) .gt. 400.0 .and. tcu(l) .ne. 0.0) then -! if (prs(kp1)-prs(l) .gt. 500.0 .and. tcu(l) .ne. 0.0) then ! for r2 exp -! if (prs(kp1)-prs(l) .gt. 400.0 .and. tcu(l) .ne. 0.0) then -! if (prs(lmhij+1)-prs(l) .gt. 200.0 .and. tcu(l) .ne. 0.0) then -! if (prsm(l) .lt. 900.0 .and. tcu(l) .ne. 0.0) then -! if (phi_l(l) .gt. 10000.0 .and. tcu(l) .ne. 0.0) then - kuo(ipt) = 1 - endif -! New test for convective clouds ! added in 08/21/96 - if (clw(l)+cli(l) .gt. 0.0 .OR. & - & qli(l)+qii(l) .gt. clwmin) ktop(ipt) = l - enddo - do l=1,km1 - if (clw(l)+cli(l) .gt. 0.0 .OR. & - & qli(l)+qii(l) .gt. clwmin) kbot(ipt) = l - enddo - if (flipv) then - ktop(ipt) = kp1 - ktop(ipt) - kbot(ipt) = kp1 - kbot(ipt) - endif -! -! if (lprint) then -! print *,' tin',(tin(ia,l),l=k,1,-1) -! print *,' qin',(qin(ia,l),l=k,1,-1) -! endif -! -! Velocity scale from the downdraft! -! - DDVEL(ipt) = DDVEL(ipt) * DDFAC * GRAV / (prs(K+1)-prs(k)) -! - ENDDO ! End of the IPT Loop! - deallocate (alfint) -! - RETURN - END - SUBROUTINE CRTWRK(PL, CCWF, ACR) - USE MACHINE , ONLY : kind_phys - use module_ras , only : ac, ad - Implicit none -! - real(kind=kind_phys) PL, CCWF, ACR - INTEGER IWK -! - IWK = PL * 0.02 - 0.999999999 - IWK = MAX(1, MIN(IWK,16)) - ACR = (AC(IWK) + PL * AD(IWK)) * CCWF -! - RETURN - END - SUBROUTINE CLOUD( & - & K, KD, M & - &, RASALF, FRACBL, MAX_NEG_BOUY & - &, ALFINT, RHFACL, RHFACS, garea & -! &, ALFINT, ALFINQ, RHFACL, RHFACS, garea & - &, alfind, rhc_ls & - - &, TOI, QOI, ROI, PRS, PRSM, phil, phih & -! &, TOI, QOI, ROI, PRS, PRSM, PRJ, PRJM, DPI & -! &, TOI, QOI, ROI, PRS, PRJ & - &, QLI, QII, KPBL, DSFC & - &, CD,lprnt, trcfac,ccwf & -! &, IDIAG, lprnt & - - &, TCU, QCU, RCU, PCU, FLX, FLXD & -! &, TCD, QCD & - &, CUP, REVAP, DT & - &, WFNC, WRKFUN, CALKBL, CRTFUN, TLA, DNDRFT, DPD) - -! -!*********************************************************************** -!******************** Relaxed Arakawa-Schubert ************************ -!****************** Plug Compatible Scalar Version ********************* -!************************ SUBROUTINE CLOUD **************************** -!************************ October 2004 **************************** -!******************** VERSION 2.0 (modified) ************************* -!************* Shrinivas.Moorthi@noaa.gov (301) 763 8000(X7233) ******** -!*********************************************************************** -!*Reference: -!----------- -! NOAA Technical Report NWS/NCEP 99-01: -! Documentation of Version 2 of Relaxed-Arakawa-Schubert -! Cumulus Parameterization with Convective Downdrafts, June 1999. -! by S. Moorthi and M. J. Suarez. -! -!*********************************************************************** -! -!===> UPDATES CLOUD TENDENCIES DUE TO A SINGLE CLOUD -!===> DETRAINING AT LEVEL KD. -! -!*********************************************************************** -! -!===> TOI(K) INOUT TEMPERATURE KELVIN -!===> QOI(K) INOUT SPECIFIC HUMIDITY NON-DIMENSIONAL -!===> ROI(K,M) INOUT TRACER ARBITRARY -!===> QLI(K) INOUT LIQUID WATER NON-DIMENSIONAL -!===> QII(K) INOUT ICE NON-DIMENSIONAL - -!===> PRS(K+1) INPUT PRESSURE @ EDGES MB -!===> PRSM(K) INPUT PRESSURE @ LAYERS MB -!===> PHIH(K+1) INPUT GEOPOTENTIAL @ EDGES IN MKS units -!===> PHIL(K) INPUT GEOPOTENTIAL @ LAYERS IN MKS units -!===> PRJ(K+1) INPUT (P/P0)^KAPPA @ EDGES NON-DIMENSIONAL -!===> PRJM(K) INPUT (P/P0)^KAPPA @ LAYERS NON-DIMENSIONAL - -!===> K INPUT THE RISE & THE INDEX OF THE SUBCLOUD LAYER -!===> KD INPUT DETRAINMENT LEVEL ( 1<= KD < K ) -!===> M INPUT NUMBER OF TRACERS. MAY BE ZERO. -!===> DNDRFT INPUT LOGICAL .TRUE. OR .FALSE. -!===> DPD INPUT Minumum Cloud Depth for DOWNDRFAT Computation hPa -! -!===> TCU(K ) UPDATE TEMPERATURE TENDENCY DEG -!===> QCU(K ) UPDATE WATER VAPOR TENDENCY (G/G) -!===> RCU(K,M) UPDATE TRACER TENDENCIES ND -!===> PCU(K-1) UPDATE PRECIP @ BASE OF LAYER KG/M^2 -!===> FLX(K ) UPDATE MASS FLUX @ TOP OF LAYER KG/M^2 -!===> CUP UPDATE PRECIPITATION AT THE SURFACE KG/M^2 -! - USE MACHINE , ONLY : kind_phys - use module_ras - IMPLICIT NONE -! -! INPUT ARGUMENTS - - LOGICAL REVAP, DNDRFT, WRKFUN, CALKBL, CRTFUN, CALCUP - logical lprnt - INTEGER K, KD, M - - - real(kind=kind_phys) TOI(K), QOI(K ), PRS(K+1), PRSM(K) & - &, QLI(K), QII(K) & - &, PHIH(K+1), ROI(K,M), PHIL(K) -! &, PRJ(K+1), ROI(K,M), PRJM(K) -! &, PRJ(K+1), ROI(K,M), PRJM(K), DPI(K) - real(kind=kind_phys) CD, UFN, DSFC - INTEGER KPBL, KBL, KB1 - -! real(kind=kind_phys) RASALF, FRACBL, MAX_NEG_BOUY, ALFINT(K), & - real(kind=kind_phys) RASALF, FRACBL, MAX_NEG_BOUY, ALFINT(K,M+4), & - & RHFACL, RHFACS, garea, ccwf - real(kind=kind_phys) DPD, alfind(k), rhc_ls(k) -! real(kind=kind_phys) ALFINQ(K), DPD, alfind(k), rhc_ls(k) - real(kind=kind_phys) trcfac(M,k) - -! UPDATE ARGUMENTS - - real(kind=kind_phys) TCU(K), QCU(K), RCU(K,M) & - &, TCD(K), QCD(K), PCU(K) & - &, FLX(K+1), FLXD(K+1), CUP - -! TEMPORARY WORK SPACE - - real(kind=kind_phys) HOL(KD:K), QOL(KD:K), GAF(KD:K+1) & - &, HST(KD:K), QST(KD:K), TOL(KD:K) & - &, GMH(KD:K), GMS(KD:K+1), GAM(KD:K+1) & - &, AKT(KD:K), AKC(KD:K), BKC(KD:K) & - &, LTL(KD:K), RNN(KD:K), FCO(KD:K) & - &, PRI(KD:K) & -! &, PRH(KD:K), PRI(KD:K) & - &, QIL(KD:K), QLL(KD:K) & - &, ZET(KD:K), XI(KD:K), RNS(KD:K) & - &, Q0U(KD:K), Q0D(KD:K), vtf(KD:K) & - &, DLB(KD:K+1),DLT(KD:K+1), ETA(KD:K+1) & - &, PRL(KD:K+1) & - &, CIL(KD:K), CLL(KD:K), ETAI(KD:K) - - real(kind=kind_phys) ALM, DET, HCC, CLP & - &, HSU, HSD, QTL, QTV & - &, AKM, WFN, HOS, QOS & - &, AMB, TX1, TX2, TX3 & - &, TX4, TX5, QIS, QLS & - &, HBL, QBL, RBL(M) & - &, QLB, QIB, PRIS & - &, WFNC, TX6, ACR & - &, TX7, TX8, TX9, RHC & - &, hstkd, qstkd, ltlkd, q0ukd, q0dkd, dlbkd & - &, qtp, qw00, qi00, qrbkd & - &, hstold, rel_fac - -! INTEGER IA, I1, I2, ID1, ID2 -! INTEGER IB, I3 - - LOGICAL UNSAT, ep_wfn - - LOGICAL LOWEST, SKPDD - -! real(kind=kind_phys) TL, PL, QL, QS, DQS, ST1, SGN, C0, TAU, & -! & QTVP, HB, QB, TB, QQQ, C0I, QI0, QW0, & - real(kind=kind_phys) TL, PL, QL, QS, DQS, ST1, SGN, TAU, & - & QTVP, HB, QB, TB, QQQ, & - & HCCP, DS, DH, AMBMAX, X00, EPP, QTLP, & -! & DPHIB, DPHIT, DEL_ETA, DETP, QUDFAC, & -! & DPI, DPHIB, DPHIT, DEL_ETA, DETP, QUDFAC, & - & DPI, DPHIB, DPHIT, DEL_ETA, DETP, & - & TEM, TEM1, TEM2, TEM3, TEM4, & -! & TEM, TEM1, TEM2, TEM3, TEM4, ONEBG, & -! & TSTMBA, HCRIT, RKPP1I, ST2, & - & ST2, ST3, ST4, ST5, & - & ERRMIN, ERRMI2, ERRH, ERRW, ERRE, TEM5, & - & TEM6, HBD, QBD, st1s - parameter (ERRMIN=0.0001, ERRMI2=0.1*ERRMIN) -! parameter (c0=1.0e-3, KBLMX=20, ERRMIN=0.0001, ERRMI2=0.1*ERRMIN) - INTEGER I, L, N, KD1, II & - &, KP1, IT, KM1, KTEM, KK, KK1, LM1, LL, LP1, kbls, kmxh - - real avt, avq, avr, avh -! -! REEVAPORATION -! -! real(kind=kind_phys), parameter :: -! & clfa = -0.452550814376093547E-03 -! &, clfb = 0.161398573159240791E-01 -! &, clfc = -0.163676268676807096 -! &, clfd = 0.447988962175259131 -! &, point3 = 0.3, point01=0.01 - -! real(kind=kind_phys), parameter :: rainmin=1.0e-9 - real(kind=kind_phys), parameter :: rainmin=1.0e-8 - real(kind=kind_phys), parameter :: oneopt9=1.0/0.09 - real(kind=kind_phys), parameter :: oneopt4=1.0/0.04 - - real(kind=kind_phys) CLFRAC, DT, clf, clvfr - - real(kind=kind_phys) ACTEVAP,AREARAT,DELTAQ,MASS,MASSINV,POTEVAP & - &, TEQ,QSTEQ,DQDT,QEQ -! &, ELOCP,GRAVCON, GRAVFAC, AFC, RKNOB, ELFOCP -! -! Temporary workspace and parameters needed for downdraft -! - real(kind=kind_phys) TLA, GMF -! - real(kind=kind_phys) BUY(KD:K+1), QRB(KD:K), QRT(KD:K) & - &, ETD(KD:K+1), HOD(KD:K+1), QOD(KD:K+1) & - &, GHD(KD:K), GSD(KD:K), EVP(KD:K) & - &, ETZ(KD:K), CLDFR(KD:K) & - &, TRAIN, DOF, CLDFRD & - &, FAC, RSUM1, RSUM2, RSUM3, dpneg - INTEGER IDH - LOGICAL DDFT, UPDRET -! real(kind=kind_phys) eps, epsm1, rvi, facw, faci, hsub, tmix, DEN -! real(kind=kind_phys) eps, epsm1, rv, rd, depth -! real(kind=kind_phys) eps, epsm1, rv, rd, fpvs, depth -! -! -!*********************************************************************** -! -!CFPP$ EXPAND (QSATCN, CRTWRK) -!CFPP$ NOCONCUR R -! - do l=1,K - tcd(L) = 0.0 - qcd(L) = 0.0 - enddo -! - KP1 = K + 1 - KM1 = K - 1 - KD1 = KD + 1 - kblmx = k / 2 -! -! if (lprnt) print *,' IN CLOUD for KD=',kd -! if (lprnt) print *,' prs=',prs(Kd:K+1) -! if (lprnt) print *,' phil=',phil(KD:K) -! if (lprnt) print *,' phih=',phih(KD:K+1) -! if (lprnt) print *,' toi=',toi -! if (lprnt) print *,' qoi=',qoi -! -! do l=kd1,k -! alfint(l) = (prjm(l)-prj(l)) / (prjm(l)-prjm(l-1)) -! alfinq(l) = alfint(l) -! enddo -! - CLDFRD = 0.0 - DOF = 0.0 - PRL(KP1) = PRS(KP1) -! - DO L=KD,K - RNN(L) = 0.0 - ZET(L) = 0.0 - XI(L) = 0.0 -! - TOL(L) = TOI(L) - QOL(L) = QOI(L) - PRL(L) = PRS(L) - BUY(L) = 0.0 - CLL(L) = QLI(L) - CIL(L) = QII(L) - ENDDO -! - DO L=KD, K - DPI = ONE / (PRL(L+1) - PRL(L)) - PRI(L) = GRAVFAC * DPI -! - PL = PRSM(L) - TL = TOL(L) - -! if (lprnt) print *,' l=',l,' prl=',prl(l+1),prl(l),' pl=',pl, -! &' dpi=',dpi,' prsm=',prsm(l) - - AKT(L) = (PRL(L+1) - PL) * DPI -! -! if (lprnt) print *,' l=',l,' prl=',prl(l+1),prl(l),' pl=',pl, -! &' dpi=',dpi,' prsm=',prsm(l),' akt=',akt(l) -! - CALL QSATCN(TL, PL, QS, DQS,lprnt) -! -! if(lprnt)print*,' qs=',qs,' tl=',tl,' pl=',pl -! 1, ' dqs=',dqs,' qol=',qol(l) -! -! - QST(L) = QS - GAM(L) = DQS * ELOCP - ST1 = ONE + GAM(L) - GAF(L) = (ONE/ALHL) * (GAM(L)/(ONE + GAM(L))) - - QL = MAX(MIN(QS*RHMAX,QOL(L)), ONE_M10) - QOL(L) = QL - - TEM = CP * TL - LTL(L) = TEM * ST1 / (ONE+NU*(QST(L)+TL*DQS)) - vtf(L) = 1.0 + NU * QL - ETA(L) = ONE / (LTL(L) * VTF(L)) - - HOL(L) = TEM + QL * ALHL - HST(L) = TEM + QS * ALHL -! -! if(lprnt)print*,' l=',l,' hst=',hst(l),' tem=',tem -! 1, ' qs=',qs,' alhl=',alhl -! if (lprnt) print *,' L=',L,' tem=',tem,' ql=',ql,' alhl=',alhl -! &,' alhf=',alhf,' qii=',qii(l),' cp=',cp,' tl=',tl -! &,' qs=',qs,' qol=',qol(l),' rhmax=',rhmax,' hol=',hol(l) -! &,' pl=',pl - - ENDDO -! - ETA(K+1) = ZERO - GMS(K) = ZERO -! - AKT(KD) = HALF - GMS(KD) = ZERO -! - CLP = ZERO -! - GAM(K+1) = GAM(K) - GAF(K+1) = GAF(K) -! - DO L=K,KD1,-1 -! TEM1 = CP * TOL(L) * VTF(L) / PRH(L) - - DPHIB = PHIL(L) - PHIH(L+1) - DPHIT = PHIH(L) - PHIL(L) -! - DLB(L) = DPHIB * ETA(L) - DLT(L) = DPHIT * ETA(L) -! - QRB(L) = DPHIB - QRT(L) = DPHIT -! - ETA(L) = ETA(L+1) + DPHIB - -! if (lprnt) print *,' L=',L,' dphib=',dphib,' dphit=',dphit -! &,' eta=',eta(l),' hol_new=',hol(l)+eta(l) -! &,' cp=',cp,' tol=',tol(l),' vtf=',vtf(l) -! - HOL(L) = HOL(L) + ETA(L) - hstold = hst(l) - HST(L) = HST(L) + ETA(L) -! -! if(lprnt)print*,' l=',l,' hst=',hst(l),' eta=',eta(l) -! 1, ' hstold=',hstold - - ETA(L) = ETA(L) + DPHIT - ENDDO -! -! For the cloud top layer -! - L = KD - - DPHIB = PHIL(L) - PHIH(L+1) -! - DLB(L) = DPHIB * ETA(L) -! - QRB(L) = DPHIB - QRT(L) = DPHIB -! - ETA(L) = ETA(L+1) + DPHIB - - HOL(L) = HOL(L) + ETA(L) - HST(L) = HST(L) + ETA(L) -! -! if (kd .eq. 12) then -! if (lprnt) print *,' IN CLOUD for KD=',KD,' K=',K -! if (lprnt) print *,' l=',l,' hol=',hol(l),' hst=',hst(l) -! if (lprnt) print *,' TOL=',tol -! if (lprnt) print *,' qol=',qol -! if (lprnt) print *,' hol=',hol -! if (lprnt) print *,' hst=',hst -! endif -! -! To determine KBL internally -- If KBL is defined externally -! the following two loop should be skipped -! -! if (lprnt) print *,' calkbl=',calkbl - - IF (CALKBL) THEN - KTEM = MAX(KD, K-KBLMX-2) - kmxh = k - -! DO L=KM1,KTEM,-1 -! if(lprnt) print *,' l=',l,' kmxh=',kmxh,' prl=',prl(l) -! &, prl(k),' hol=',hol(l),hol(kmxh) -! if (prl(k) - prl(l) .gt. 100.0) exit -! if (hol(l) .gt. hol(kmxh)) kmxh = l -! if(lprnt) print *,' l=',l,' kmxh=',kmxh,' prl=',prl(l) -! ENDDO - - DO L=kmxh,KTEM+1,-1 - kbls = l - if (hst(l-1) .gt. hst(l)) exit - ENDDO - KBL = Kmxh - TX1 = ZERO - UNSAT = .FALSE. - DO L=kmxh-1,KTEM,-1 - TEM = HOL(K) - HOL(L) - TX3 = (HOL(L) - HOL(L+1)) / (PRL(L+2) - PRL(L)) - -! if (lprnt) print *,' l=',l,' kbl=',kbl,' tx3=',tx3,' tx1=',tx1 - IF (TX3 .LT. TX1 .AND. TEM .LT. HCRIT) THEN - TX1 = TX3 - KBL = L -! KBL = L+1 - UNSAT = .TRUE. - ELSEIF (UNSAT .AND. & - & ( ((KBL .LT. K-1) .AND. TX3 .GT. 0.5*TX1) & - & .OR. TEM .GT. HCRIT) ) THEN - TX1 = -1.0E20 - ENDIF - ENDDO -! if(lprnt) print *,' kbl=',kbl,' kbls=',kbls,' kmxh=',kmxh -! -! ii = min(kbl,kbls) - ii = kbl - do l=ktem,kmxh-1 -! if (hol(kmxh) .gt. hst(l)) kbl = l - if (hol(kmxh) .gt. hst(l)) kbl = l+1 ! Commented on 09/20/04 - enddo -! if(lprnt) print *,' kblhst=',kbl,' ii=',ii - - if (prl(K+1) - prl(ii) .gt. 50.0 .and. ii .gt. kbl) kbl = ii -! if(lprnt) print *,' kbl2=',kbl,' ii=',ii - if (kbl .ne. ii) then -! kbl = min(K, max(kbl+1, kd-1)) -!!! kbl = min(K, max(kbl, kd-1)) - if (PRL(K+1)-PRL(KBL) .gt. bldmax) kbl = max(kbl,ii) - endif -! if (ii .gt. kbl) then -! if (hol(Kmxh)-hol(kbl) .gt. hcrit) kbl = ii -! endif -! -! ii = kbl -! do l=ii,k -! if (hol(k) .gt. hst(l)) kbl = l -! enddo -!!! kbl = min(K, max(kbl, kd-1)) -! - KBL = min(k, MAX(KBL,K-KBLMX)) -!!!!! kbl = K - 2 -!!! -! tem1 = max(10.0, min(50.0,(prl(k+1) - prl(kd))*0.05)) -!LL2 tem1 = max(10.0, min(50.0,(prl(k+1) - prl(kd))*0.066)) -! do l=k,k-kblmx,-1 -! tem = prl(k+1) - prl(l) -!LL if (tem .gt. 20.0) then -!LL if (tem .gt. 40.0) then -!!r1 if (tem .gt. 50.0) then -! if (tem .gt. tem1) then -! kbl = min(kbl,l) -! exit -! endif -! enddo -! - tem1 = max(prl(k+1)-prl(k), & - & min((prl(kbl) - prl(kd))*0.05, 20.0)) -! & min((prl(kbl) - prl(kd))*0.05, 30.0)) - if (prl(k+1)-prl(kbl) .lt. tem1) then - KTEM = MAX(KD+1, K-KBLMX) - do l=k,KTEM,-1 - tem = prl(k+1) - prl(l) - if (tem .gt. tem1) then - kbl = min(kbl,l) - exit - endif - enddo - endif -!!! - - KPBL = KBL -! if(lprnt)print*,' 1st kbl=',kbl,' kblmx=',kblmx,' kd=',kd -! if(lprnt)print*,' tx3=',tx3,' tx1=',tx1,' tem=',tem -! 1, ' hcrit=',hcrit - ELSE - KBL = KPBL -! if(lprnt)print*,' 2nd kbl=',kbl - ENDIF -! if(lprnt)print*,' after CALKBL l=',l,' hol=',hol(l) -! 1, ' hst=',hst(l) -! - KBL = MAX(KBL,KD) - KB1 = KBL - 1 -!! -!! -! do kbl=k,kd1,-1 -! st1 = 1.0 / (PRL(K+1) - PRL(KBL)) -! tem1 = (PRL(K+1)-PRL(K)) * st1 -! HBL = HOL(K) * tem1 -! -! DO L=KM1,KBL,-1 -! tem2 = (PRL(K+1)-PRL(L)) * st1 -! TEM = tem2 - tem1 -! HBL = HBL + HOL(L) * TEM -! tem1 = tem2 -! enddo -! if(lprnt) print *,' HBL=',HBL,' KBL=',KBL -! KB1 = KBL - 1 -! st2 = 0.5 * (hst(kbl)+hst(kb1)) -! if (st2 .le. hbl) exit -! ENDDO -! if (hst(kbl) .le. hbl) kbl = kbl + 1 -! kbl = min(kbl+1, K) -! KB1 = KBL - 1 -!! if (lprnt) print *,' HBL=',HBL,' HST=',st2,' KBL=',KBL,' kb1=',kb1 -! if(lprnt)print *,' HBL=',HBL,' HST=',hst(l),' KBL=',KBL -! 1, ' kb1=',kb1 -! if (PRL(K+1)-PRL(KBL) .gt. bldmax) return -!! -!! -! -! if (lprnt) print *,' kbl=',kbl,' prlkbl=',prl(kbl),prl(k+1) - if(kb1 .le. kd)then -! if(lprnt)print*,' kb1=',kb1,' kd=',kd,' EXIT CLOUD' - return - endif - if(PRL(K+1)-PRL(KBL) .gt. bldmax)then -! if(lprnt)print*,' prl(k+1)=',prl(k+1),' prl(kbl)=',prl(kbl) -! 1, ' bldmax=',bldmax,' k+1=',k+1,' kbl=',kbl -! 2, ' EXIT CLOUD' - return - endif -! -! if (lprnt) print *,' kbl=',kbl -! - PRIS = ONE / (PRL(K+1)-PRL(KBL)) - TX1 = ETA(KBL) -! - GMS(KBL) = 0.0 - XI(KBL) = 0.0 - ZET(KBL) = 0.0 -! DEPTH = ETA(KD) - ETA(KBL) -! - DO L=K,KD,-1 - IF (L .GE. KBL) THEN - ETA(L) = (PRL(K+1)-PRL(L)) * PRIS - ELSE - ZET(L) = (ETA(L) - TX1) * ONEBG - XI(L) = ZET(L) * ZET(L) * QUDFAC - ETA(L) = ZET(L) - ZET(L+1) - GMS(L) = XI(L) - XI(L+1) - ENDIF - ENDDO -! - HBL = HOL(K) * ETA(K) - QBL = QOL(K) * ETA(K) - QLB = CLL(K) * ETA(K) - QIB = CIL(K) * ETA(K) -! TX1 = QOL(K) / QST(K) * ETA(K) - TX1 = QST(K) * ETA(K) -! - DO L=KM1,KBL,-1 - TEM = ETA(L) - ETA(L+1) - HBL = HBL + HOL(L) * TEM -! if(lprnt)print*,' l=',l,' qbl=',qbl,' qol=',qol(l) -! 1, ' tem=',tem - QBL = QBL + QOL(L) * TEM - QLB = QLB + CLL(L) * TEM - QIB = QIB + CIL(L) * TEM -! TX1 = TX1 + QOL(L) / QST(L) * TEM - TX1 = TX1 + QST(L) * TEM - ENDDO -! if (lprnt) print *,' hbl=',hbl,' qbl=',qbl -! Find Min value of HOL in TX2 - TX2 = HOL(KD) - IDH = KD1 - DO L=KD1,KB1 - IF (HOL(L) .LT. TX2) THEN - TX2 = HOL(L) - IDH = L ! Level of minimum moist static energy! - ENDIF - ENDDO - IDH = 1 - IDH = MAX(KD1, IDH) -! - TEM1 = HBL - HOL(KD) - TEM = HBL - HST(KD1) & - & - LTL(KD1) *( NU *(QOL(KD1)-QST(KD1))) - LOWEST = KD .EQ. KB1 -! - -! TX1 = QBL / TX1 - TX1 = RHFACS - QBL / TX1 ! Average RH -! TX1 = RHFACS - TX1 ! Average of each layer RH - UNSAT = (TEM .GT. ZERO .OR. (LOWEST .AND. TEM1 .GE. ZERO)) & - & .AND. (TX1 .LT. RHRAM) & - & .AND. (KBL .GT. KD) - -! if(lprnt) print *,' unsat=',unsat,' tem=',tem,' tem1=',tem1 -! &,' tx1=',tx1,' rhram=',rhram,' kbl=',kbl,' kd=',kd,' lowest=' -! &,lowest,' rhfacs=',rhfacs,' ltl=',ltl(kd1),' qol=',qol(kd1) -! &,' qst=',qst(kd1),' hst=',hst(kd1),' nu=',nu - -! -!===> IF NO SOUNDING MEETS FIRST CONDITION, RETURN -! if(lprnt .and. (.not. unsat)) print *,' tx1=',tx1,' rhfacs=' -! &,rhfacs, ' tem=',tem,' hst=',hst(kd1) - - IF (.NOT. UNSAT) RETURN -! -! TEM1 = TX1 - RHFACS -! RHC = MAX(ZERO, MIN(ONE, EXP(20.0*TEM1) )) - RHC = MAX(ZERO, MIN(ONE, EXP(-20.0*TX1) )) -! - DO N=1,M - RBL(N) = ROI(K,N) * ETA(K) - ENDDO - DO N=1,M - DO L=KM1,KBL,-1 - RBL(N) = RBL(N) + ROI(L,N)*(ETA(L)-ETA(L+1)) - ENDDO - ENDDO -! - TX4 = 0.0 - TX5 = 0.0 -! - TX3 = QST(KBL) - GAF(KBL) * HST(KBL) - QIL(KBL) = MAX(ZERO, MIN(ONE, (TCR-TCL-TOL(KBL))*TCRF)) -! - DO L=KB1,KD1,-1 - TEM = QST(L) - GAF(L) * HST(L) - TEM1 = (TX3 + TEM) * 0.5 - ST2 = (GAF(L)+GAF(L+1)) * 0.5 -! - FCO(L+1) = TEM1 + ST2 * HBL - -! if(lprnt) print *,' fco=',fco(l+1),' tem1=',tem1,' st2=',st2 -! &,' hbl=',hbl,' tx3=',tx3,' tem=',tem,' gaf=',gaf(l),' l=',l - - RNN(L+1) = ZET(L+1) * TEM1 + ST2 * TX4 - GMH(L+1) = XI(L+1) * TEM1 + ST2 * TX5 -! - TX3 = TEM - TX4 = TX4 + ETA(L) * HOL(L) - TX5 = TX5 + GMS(L) * HOL(L) -! - QIL(L) = MAX(ZERO, MIN(ONE, (TCR-TCL-TOL(L))*TCRF)) - QLL(L+1) = (0.5*ALHF) * ST2 * (QIL(L)+QIL(L+1)) + ONE - ENDDO -! -! FOR THE CLOUD TOP -- L=KD -! - L = KD -! - TEM = QST(L) - GAF(L) * HST(L) - TEM1 = (TX3 + TEM) * 0.5 - ST2 = (GAF(L)+GAF(L+1)) * 0.5 -! - FCO(L+1) = TEM1 + ST2 * HBL - RNN(L+1) = ZET(L+1) * TEM1 + ST2 * TX4 - GMH(L+1) = XI(L+1) * TEM1 + ST2 * TX5 -! - FCO(L) = TEM + GAF(L) * HBL - RNN(L) = TEM * ZET(L) + (TX4 + ETA(L)*HOL(L)) * GAF(L) - GMH(L) = TEM * XI(L) + (TX5 + GMS(L)*HOL(L)) * GAF(L) -! -! Replace FCO for the Bottom -! - FCO(KBL) = QBL - RNN(KBL) = 0.0 - GMH(KBL) = 0.0 -! - QIL(KD) = MAX(ZERO, MIN(ONE, (TCR-TCL-TOL(KD))*TCRF)) - QLL(KD1) = (0.5*ALHF) * ST2 * (QIL(KD) + QIL(KD1)) + ONE - QLL(KD ) = ALHF * GAF(KD) * QIL(KD) + ONE -! -! if (lprnt) print *,' fco=',fco(kd:kbl) -! if (lprnt) print *,' qil=',qil(kd:kbl) -! if (lprnt) print *,' qll=',qll(kd:kbl) -! - st1 = qil(kd) - st2 = c0i * st1 - tem = c0 * (1.0-st1) - tem2 = st2*qi0 + tem*qw0 -! - DO L=KD,KB1 - tx2 = akt(l) * eta(l) - tx1 = tx2 * tem2 - q0u(l) = tx1 - FCO(L) = FCO(L+1) - FCO(L) + tx1 - RNN(L) = RNN(L+1) - RNN(L) & - & + ETA(L)*(QOL(L)+CLL(L)+CIL(L)) + tx1*zet(l) - GMH(L) = GMH(L+1) - GMH(L) & - & + GMS(L)*(QOL(L)+CLL(L)+CIL(L)) + tx1*xi(l) -! - tem1 = (1.0-akt(l)) * eta(l) - -! if(lprnt) print *,' qll=',qll(l),' st2=',st2,' tem=',tem -! &,' tx2=',tx2,' akt=',akt(l),' eta=',eta(l) - - AKT(L) = QLL(L) + (st2 + tem) * tx2 - -! if(lprnt) print *,' akt==',akt(l),' l==',l - - AKC(L) = 1.0 / AKT(L) -! - st1 = 0.5 * (qil(l)+qil(l+1)) - st2 = c0i * st1 - tem = c0 * (1.0-st1) - tem2 = st2*qi0 + tem*qw0 -! - BKC(L) = QLL(L+1) - (st2 + tem) * tem1 -! - tx1 = tem1*tem2 - q0d(l) = tx1 - FCO(L) = FCO(L) + tx1 - RNN(L) = RNN(L) + tx1*zet(l+1) - GMH(L) = GMH(L) + tx1*xi(l+1) - ENDDO - -! if(lprnt) print *,' akt=',akt(kd:kb1) -! if(lprnt) print *,' akc=',akc(kd:kb1) - - qw00 = qw0 - qi00 = qi0 - ii = 0 - 777 continue -! -! if (lprnt) print *,' after 777 ii=',ii,' ep_wfn=',ep_wfn -! - ep_wfn = .false. - RNN(KBL) = 0.0 - TX3 = bkc(kb1) * (QIB + QLB) - TX4 = 0.0 - TX5 = 0.0 - DO L=KB1,KD1,-1 - TEM = BKC(L-1) * AKC(L) -! if (lprnt) print *,' tx3=',tx3,' fco=',fco(l),' akc=',akc(l) -! &,' bkc=',bkc(l-1), ' l=',l - TX3 = (TX3 + FCO(L)) * TEM - TX4 = (TX4 + RNN(L)) * TEM - TX5 = (TX5 + GMH(L)) * TEM - ENDDO - IF (KD .LT. KB1) THEN - HSD = HST(KD1) & - & + LTL(KD1) * NU *(QOL(KD1)-QST(KD1)) - ELSE - HSD = HBL - ENDIF -! -! if (lprnt) print *,' tx3=',tx3,' fco=',fco(kd),' akc=',akc(kd) - TX3 = (TX3 + FCO(KD)) * AKC(KD) - TX4 = (TX4 + RNN(KD)) * AKC(KD) - TX5 = (TX5 + GMH(KD)) * AKC(KD) - ALM = ALHF*QIL(KD) - LTL(KD) * VTF(KD) -! - HSU = HST(KD) + LTL(KD) * NU * (QOL(KD)-QST(KD)) - -! if (lprnt) print *,' hsu=',hsu,' hst=',hst(kd), -! &' ltl=',ltl(kd),' qol=',qol(kd),' qst=',qst(kd) -! -!===> VERTICAL INTEGRALS NEEDED TO COMPUTE THE ENTRAINMENT PARAMETER -! - TX1 = ALM * TX4 - TX2 = ALM * TX5 - - DO L=KD,KB1 - TAU = HOL(L) - HSU - TX1 = TX1 + TAU * ETA(L) - TX2 = TX2 + TAU * GMS(L) - ENDDO -! -! MODIFY HSU TO INCLUDE CLOUD LIQUID WATER AND ICE TERMS -! -! if (lprnt) print *,' hsu=',hsu,' alm=',alm,' tx3=',tx3 - - HSU = HSU - ALM * TX3 -! - CLP = ZERO - ALM = -100.0 - HOS = HOL(KD) - QOS = QOL(KD) - QIS = CIL(KD) - QLS = CLL(KD) - UNSAT = HBL .GT. HSU .and. abs(tx1) .gt. 1.0e-4 - -! if (lprnt) print *,' ii=',ii,' unsat=',unsat,' hsu=',hsu -! &,' hbl=',hbl,' tx1=',tx1,' hsd=',hsd - - -!*********************************************************************** - - - ST1 = HALF*(HSU + HSD) - IF (UNSAT) THEN -! -! STANDARD CASE: -! CLOUD CAN BE NEUTRALLY BOUYANT AT MIDDLE OF LEVEL KD W/ +VE LAMBDA. -! EPP < .25 IS REQUIRED TO HAVE REAL ROOTS. -! - clp = 1.0 - st2 = hbl - hsu - -! if(lprnt) print *,' tx2=',tx2,' tx1=',tx1,' st2=',st2 -! - if (tx2 .eq. 0.0) then - alm = - st2 / tx1 - if (alm .gt. almax) alm = -100.0 - else - x00 = tx2 + tx2 - epp = tx1 * tx1 - (x00+x00)*st2 - if (epp .gt. 0.0) then - x00 = 1.0 / x00 - tem = sqrt(epp) - tem1 = (-tx1-tem)*x00 - tem2 = (-tx1+tem)*x00 - if (tem1 .gt. almax) tem1 = -100.0 - if (tem2 .gt. almax) tem2 = -100.0 - alm = max(tem1,tem2) - -! if (lprnt) print *,' tem1=',tem1,' tem2=',tem2,' alm=',alm -! &,' tx1=',tx1,' tem=',tem,' epp=',epp,' x00=',x00,' st2=',st2 - - endif - endif - -! if (lprnt) print *,' almF=',alm,' ii=',ii,' qw00=',qw00 -! &,' qi00=',qi00 -! -! CLIP CASE: -! NON-ENTRAINIG CLOUD DETRAINS IN LOWER HALF OF TOP LAYER. -! NO CLOUDS ARE ALLOWED TO DETRAIN BELOW THE TOP LAYER. -! - ELSEIF ( (HBL .LE. HSU) .AND. & - & (HBL .GT. ST1 ) ) THEN - ALM = ZERO - CLP = (HBL-ST1) / (HSU-ST1) - ENDIF -! - UNSAT = .TRUE. - IF (ALMIN1 .GT. 0.0) THEN - IF (ALM .GE. ALMIN1) UNSAT = .FALSE. - ELSE - LOWEST = KD .EQ. KB1 - IF ( (ALM .GT. ZERO) .OR. & - & (.NOT. LOWEST .AND. ALM .EQ. ZERO) ) UNSAT = .FALSE. - ENDIF -! -! if (alm*depth/grav .ge. 1.0) UNSAT = .TRUE. -! -!===> IF NO SOUNDING MEETS SECOND CONDITION, RETURN -! - IF (UNSAT) THEN - IF (ii .gt. 0 .or. (qw00 .eq. 0.0 .and. qi00 .eq. 0.0)) RETURN - CLP = 1.0 - ep_wfn = .true. - GO TO 888 - ENDIF -! -! if (lprnt) print *,' hstkd=',hst(kd),' qstkd=',qst(kd) -! &,' ii=',ii,' clp=',clp - - st1s = ONE - IF(CLP.GT.ZERO .AND. CLP.LT.ONE) THEN - ST1 = HALF*(ONE+CLP) - ST2 = ONE - ST1 - st1s = st1 - hstkd = hst(kd) - qstkd = qst(kd) - ltlkd = ltl(kd) - q0ukd = q0u(kd) - q0dkd = q0d(kd) - dlbkd = dlb(kd) - qrbkd = qrb(kd) -! - HST(KD) = HST(KD)*ST1 + HST(KD1)*ST2 - HOS = HOL(KD)*ST1 + HOL(KD1)*ST2 - QST(KD) = QST(KD)*ST1 + QST(KD1)*ST2 - QOS = QOL(KD)*ST1 + QOL(KD1)*ST2 - QLS = CLL(KD)*ST1 + CLL(KD1)*ST2 - QIS = CIL(KD)*ST1 + CIL(KD1)*ST2 - LTL(KD) = LTL(KD)*ST1 + LTL(KD1)*ST2 -! - DLB(KD) = DLB(KD)*CLP - qrb(KD) = qrb(KD)*CLP - ETA(KD) = ETA(KD)*CLP - GMS(KD) = GMS(KD)*CLP - Q0U(KD) = Q0U(KD)*CLP - Q0D(KD) = Q0D(KD)*CLP - ENDIF -! -! -!*********************************************************************** -! -! Critical workfunction is included in this version -! - ACR = 0.0 - TEM = PRL(KD1) - (PRL(KD1)-PRL(KD)) * CLP * HALF - tx1 = PRL(KBL) - TEM -!!! tx2 = min(700.0,max(tx1,100.0)) -!! tx2 = min(900.0,max(tx1,100.0)) -! tx2 = min(800.0,max(tx1,200.0)) -! rel_fac = dt * 600.0 / (3600.0*((800.0-tx2)*0.5+(tx2-200.)*3.0)) -! rel_fac = dt / (6.0*((800.0-tx2)*0.5+(tx2-200.)*3.0)) -! rel_fac = dt * facdt / (4.5*((900.0-tx2)*0.5+(tx2-100.)*3.0)) -!! rel_fac = dt * facdt / (4.5*((900.0-tx2)*0.5+(tx2-100.)*6.0)) -!!! rel_fac = dt * facdt / (6.0*((700.0-tx2)*1.0+(tx2-100.)*3.0)) -!!!! rel_fac = dt * facdt / (6.0*((700.0-tx2)*0.5+(tx2-100.)*2.0)) -! -! -! tx2 = min(800.0,max(tx1,100.0)) -! tem1 = log(tx2*0.01) / log(8.0) - tx2 = min(900.0,max(tx1,100.0)) - tem1 = log(tx2*0.01) / log(10.0) -! rel_fac = (dt * facdt) / (3600.0 * (tem1*4.0 + (1-tem1)*1.0)) - rel_fac = (dt * facdt) / (3600.0 * (tem1*3.0 + (1-tem1)*1.0)) -! rel_fac = (dt * facdt) / (3600.0 * (tem1*2.0 + (1-tem1)*1.0)) -!cnt rel_fac = (dt * facdt) / (3600.0 * 1.5) -! rel_fac = 0.3 -! - rel_fac = max(zero, min(one,rel_fac)) - - IF (CRTFUN) THEN - CALL CRTWRK(TEM, CCWF, ST1) -! ACR = (PRL(K) - TEM) * ST1 - ACR = TX1 * ST1 - ENDIF -! -!===> NORMALIZED MASSFLUX -! -! ETA IS THE THICKNESS COMING IN AND THE MASS FLUX GOING OUT. -! GMS IS THE THICKNESS OF THE SQUARE; IT IS LATER REUSED FOR GAMMA_S -! -! ETA(K) = ONE - - DO L=KB1,KD,-1 - ETA(L) = ETA(L+1) + ALM * (ETA(L) + ALM * GMS(L)) - ENDDO - DO L=KD,KBL - ETAI(L) = 1.0 / ETA(L) - ENDDO - -! if (lprnt) print *,' eta=',eta,' ii=',ii,' alm=',alm -! -!===> CLOUD WORKFUNCTION -! - WFN = ZERO - AKM = ZERO - DET = ZERO - HCC = HBL - UNSAT = .FALSE. - QTL = QST(KB1) - GAF(KB1)*HST(KB1) - TX1 = HBL -! -! tem = qst(kbl) - gaf(kbl)*hst(kbl) -! qtv = 0.5 * ((tem+qtl) + (gaf(kbl)+gaf(kb1))*hbl) -! det = max(ZERO, qbl-qtv) -! qtv = qbl - det -! det = det + qlb + qib -!! - qtv = qbl - det = qlb + qib -! - tx2 = 0.0 - dpneg = 0.0 -! - DO L=KB1,KD1,-1 - DEL_ETA = ETA(L) - ETA(L+1) - HCCP = HCC + DEL_ETA*HOL(L) -! - QTLP = QST(L-1) - GAF(L-1)*HST(L-1) - QTVP = 0.5 * ((QTLP+QTL)*ETA(L) & - & + (GAF(L)+GAF(L-1))*HCCP) - ST1 = ETA(L)*Q0U(L) + ETA(L+1)*Q0D(L) - DETP = (BKC(L)*DET - (QTVP-QTV) & - & + DEL_ETA*(QOL(L)+CLL(L)+CIL(L)) + ST1) * AKC(L) - -! if(lprnt) print *,' detp=',detp,' bkc=',bkc(l),' det=',det -! if (lprnt .and. kd .eq. 15) -! & print *,' detp=',detp,' bkc=',bkc(l),' det=',det -! &,' qtvp=',qtvp,' qtv=',qtv,' del_eta=',del_eta,' qol=' -! &,qol(l),' st1=',st1,' akc=',akc(l) -! - TEM1 = AKT(L) - QLL(L) - TEM2 = QLL(L+1) - BKC(L) - RNS(L) = TEM1*DETP + TEM2*DET - ST1 - - qtp = 0.5 * (qil(L)+qil(L-1)) - tem2 = min(qtp*(detp-eta(l)*qw00), & - & (1.0-qtp)*(detp-eta(l)*qi00)) - st1 = min(tx2,tem2) - tx2 = tem2 -! - IF (rns(l) .lt. zero .or. st1 .lt. zero) ep_wfn = .TRUE. - IF (DETP .LE. ZERO) UNSAT = .TRUE. -! IF (DETP .LE. ZERO .or. rns(l) .lt. zero) UNSAT = .TRUE. - - ST1 = HST(L) - LTL(L)*NU*(QST(L)-QOL(L)) - - - TEM2 = HCCP + DETP * QTP * ALHF -! -! if(lprnt) print *,' hst=',hst(l),' ltl=',ltl(l),' nu=',nu -! if (lprnt .and. kd .eq. 15) -! & print *,' hst=',hst(l),' ltl=',ltl(l),' nu=',nu -! &,' qst=',qst(l),' qol=',qol(l),' hccp=',hccp,' detp=',detp -! *,' qtp=',qtp,' alhf=',alhf,' vtf=',vtf(l) - - ST2 = LTL(L) * VTF(L) - TEM5 = CLL(L) + CIL(L) - TEM3 = (TX1 - ETA(L+1)*ST1 - ST2*(DET-TEM5*eta(l+1))) * DLB(L) - TEM4 = (TEM2 - ETA(L )*ST1 - ST2*(DETP-TEM5*eta(l))) * DLT(L) -! -! if (lprnt) then -! if (lprnt .and. kd .eq. 12) then -! print *,' tem3=',tem3,' tx1=',tx1,' st1=',st1,' eta1=',eta(l+1) -! &, ' st2=',st2,' det=',det,' tem5=',tem5,' dlb=',dlb(l) -! print *,' tem4=',tem4,' tem2=',tem2,' detp=',detp -! &, ' eta=',eta(l),' dlt=',dlt(l),' rns=',rns(l),' l=',l -! print *,' bt1=',tem3/(eta(l+1)*qrb(l)) -! &, ' bt2=',tem4/(eta(l)*qrt(l)) -! endif - - ST1 = TEM3 + TEM4 - -! if (lprnt) print *,' wfn=',wfn,' st1=',st1,' l=',l,' ep_wfn=', -! &ep_wfn,' akm=',akm - - WFN = WFN + ST1 - AKM = AKM - min(ST1,ZERO) - -! if (lprnt) print *,' wfn=',wfn,' akm=',akm -! if (lprnt .and. kd .eq. 12) print *,' wfn=',wfn,' akm=',akm - - if (st1 .lt. zero .and. wfn .lt. zero) then - dpneg = dpneg + prl(l+1) - prl(l) - endif - -! BUY(L) = 0.5 * (ETA(L+1) + ETA(L)) * ST1 -! BUY(L) = ETA(L+1)*tem3 + ETA(L)*tem4 -!! BUY(L) = tem3*ETAI(L+1) + tem4*ETAI(L) - BUY(L) = 0.5 * (tem3/(eta(l+1)*qrb(l)) + tem4/(eta(l)*qrt(l))) -! BUY(L) = 0.5 * st1 / ((eta(l)+eta(l+1))*(qrb(l)+qrt(l))) -! - HCC = HCCP - DET = DETP - QTL = QTLP - QTV = QTVP - TX1 = TEM2 - - ENDDO - - DEL_ETA = ETA(KD) - ETA(KD1) - HCCP = HCC + DEL_ETA*HOS -! - QTLP = QST(KD) - GAF(KD)*HST(KD) - QTVP = QTLP*ETA(KD) + GAF(KD)*HCCP - ST1 = ETA(KD)*Q0U(KD) + ETA(KD1)*Q0D(KD) - DETP = (BKC(KD)*DET - (QTVP-QTV) & - & + DEL_ETA*(QOS+QLS+QIS) + ST1) * AKC(KD) -! - TEM1 = AKT(KD) - QLL(KD) - TEM2 = QLL(KD1) - BKC(KD) - RNS(KD) = TEM1*DETP + TEM2*DET - ST1 -! - IF (rns(kd) .lt. zero) ep_wfn = .TRUE. - IF (DETP.LE.ZERO) UNSAT = .TRUE. -! - 888 continue - -! if (lprnt) print *,' ep_wfn=',ep_wfn,' ii=',ii,' rns=',rns(kd) -! &,' clp=',clp,' hst(kd)=',hst(kd) - - if (ep_wfn) then - IF ((qw00 .eq. 0.0 .and. qi00 .eq. 0.0)) RETURN - if (ii .eq. 0) then - ii = 1 - if (clp .gt. 0.0 .and. clp .lt. 1.0) then - hst(kd) = hstkd - qst(kd) = qstkd - ltl(kd) = ltlkd - q0u(kd) = q0ukd - q0d(kd) = q0dkd - dlb(kd) = dlbkd - qrb(kd) = qrbkd - endif - do l=kd,kb1 - FCO(L) = FCO(L) - q0u(l) - q0d(l) - RNN(L) = RNN(L) - q0u(l)*zet(l) - q0d(l)*zet(l+1) - GMH(L) = GMH(L) - q0u(l)*xi(l) - q0d(l)*zet(l+1) - ETA(L) = ZET(L) - ZET(L+1) - GMS(L) = XI(L) - XI(L+1) - Q0U(L) = 0.0 - Q0D(L) = 0.0 - ENDDO - qw00 = 0.0 - qi00 = 0.0 - -! if (lprnt) print *,' returning to 777 : ii=',ii,' qw00=',qw00,qi00 -! &,' clp=',clp,' hst(kd)=',hst(kd) - - go to 777 - else - unsat = .true. - endif - endif -! -! -! ST1 = 0.5 * (HST(KD) - LTL(KD)*NU*(QST(KD)-QOS) -! & + HST(KD1) - LTL(KD1)*NU*(QST(KD1)-QOL(KD1))) -! - ST1 = HST(KD) - LTL(KD)*NU*(QST(KD)-QOS) - ST2 = LTL(KD) * VTF(KD) - TEM5 = (QLS + QIS) * eta(kd1) - ST1 = HALF * (TX1-ETA(KD1)*ST1-ST2*(DET-TEM5))*DLB(KD) -! -! if (lprnt) print *,' st1=',st1,' st2=',st2,' ltl=',ltl(kd) -! *,ltl(kd1),' qos=',qos,qol(kd1) - - WFN = WFN + ST1 - AKM = AKM - min(ST1,ZERO) ! Commented on 08/26/02 - does not include top -! - -! BUY(KD) = 0.5 * (ETA(KD1) + ETA(KD)) * ST1 -! BUY(KD) = ETA(KD1) * ST1 -!! BUY(KD) = ST1 * ETAI(KD1) - BUY(KD) = ST1 / (ETA(KD1)*qrb(kd)) -! BUY(KD) = 0.5 * ST1 / (qrb(kd) * (eta(kd)+eta(kd1))) -! -! if (lprnt) print *,' wfn=',wfn,' akm=',akm,' st1=',st1 -! &,' dpneg=',dpneg - - DET = DETP - HCC = HCCP - AKM = AKM / WFN - - -!*********************************************************************** -! -! If only to calculate workfunction save it and return -! - IF (WRKFUN) THEN - IF (WFN .GE. 0.0) WFNC = WFN - RETURN - ELSEIF (.NOT. CRTFUN) THEN - ACR = WFNC - ENDIF -! -!===> THIRD CHECK BASED ON CLOUD WORKFUNCTION -! - CALCUP = .FALSE. - -! TEM = MIN(CD*100.0, MAX_NEG_BOUY) - TEM = MIN(CD*200.0, MAX_NEG_BOUY) -!LL2 tem = max_neg_bouy -! tem1 = dpneg / (prl(kbl)-prsm(kd)) - IF (WFN .GT. ACR .AND. (.NOT. UNSAT) & -! & .and. tem1 .le. 0.1 .AND. AKM .LE. TEM) THEN -! & .and. dpneg .lt. 100.0 .AND. AKM .LE. TEM) THEN - & .and. dpneg .lt. 150.0 .AND. AKM .LE. TEM) THEN -! & .and. dpneg .lt. 200.0 .AND. AKM .LE. TEM) THEN -! - CALCUP = .TRUE. - ENDIF - -! if (lprnt) print *,' calcup=',calcup,' akm=',akm,' tem=',tem -! *,' unsat=',unsat,' clp=',clp,' rhc=',rhc,' cd=',cd,' acr=',acr -! -!===> IF NO SOUNDING MEETS THIRD CONDITION, RETURN -! -! if (lprnt .and. kd .eq. 15) stop - IF (.NOT. CALCUP) RETURN -! -! This is for not LL - 20050601 - IF (ALMIN2 .NE. 0.0) THEN -! ST1 = 0.0 - IF (ALMIN1 .NE. ALMIN2) ST1 = 1.0 / max(ONE_M10,(ALMIN2-ALMIN1)) - IF (ALM .LT. ALMIN2) THEN -!! CLP = CLP * (ALM - ALMIN1) * ST1 -!! CLP = CLP * (0.1 + 0.9*(ALM - ALMIN1) * ST1) - CLP = CLP * max(0.0, min(1.0,(0.3 + 0.7*(ALM-ALMIN1)*ST1))) -! CLP = CLP * max(0.0, min(1.0,(0.2 + 0.8*(ALM-ALMIN1)*ST1))) -! CLP = CLP * max(0.0, min(1.0,(0.1 + 0.9*(ALM-ALMIN1)*ST1))) - ENDIF - ENDIF -! -! if (lprnt) print *,' clp=',clp -! - CLP = CLP * RHC - do l=kd,kb1 - rnn(l) = rns(l) - enddo - DO L=KBL,K - RNN(L) = 0.0 - ENDDO -! if (lprnt) print *,' rnn=',rnn -! -! If downdraft is to be invoked, do preliminary check to see -! if enough rain is available and then call DDRFT. -! - DDFT = .FALSE. - IF (DNDRFT) THEN -! - TRAIN = 0.0 - IF (CLP .GT. 0.0) THEN - DO L=KD,KB1 - TRAIN = TRAIN + RNN(L) - ENDDO - ENDIF - - PL = (PRL(KD1) + PRL(KD))*HALF - TEM = PRL(K+1)*(1.0-DPD*0.001) -!cnt TEM = MIN(PRL(K+1)-DPD, PRL(KBL)-50.0) -! TEM = MIN(PRL(K+1)-DPD, PRL(KBL)-300.0) - IF (TRAIN .GT. 1.0E-4 .AND. PL .LE. TEM) DDFT = .TRUE. -! -! if (ddft) then -!! DO L=KBL-3,KD,-1 -!! DO L=KBL-3,KD1,-1 -! DO L=KBL-3,KD1+1,-1 -! IF (BUY(L) .LT. 0.1) THEN -! DDFT = .FALSE. -! EXIT -! ENDIF -! ENDDO -! endif - ENDIF -! -! if (lprnt) print *,' BEFORE CALLING DDRFT KD=',kd,' DDFT=',DDFT -! &, ' PL=',PL,' TRAIN=',TRAIN -! if (lprnt) print *,' buy=',(buy(l),l=kd,kb1) - - IF (DDFT) THEN -! -! Call Downdraft scheme based on (Cheng and Arakawa, 1997) -! - CALL DDRFT( & - & K, KD & - &, TLA, ALFIND & - &, TOL, QOL, HOL, PRL, QST, HST, GAM, GAF, HBL, QBL & - &, QRB, QRT, BUY, KBL, IDH, ETA, RNN, ETAI & - &, ALM, WFN, TRAIN, DDFT & - &, ETD, HOD, QOD, EVP, DOF, CLDFR, ETZ & -! &, ETD, HOD, QOD, EVP, DOF, CLDFRD, ETZ & - &, GMS, GSD, GHD,lprnt) -! &, TX1, TX2, TX3, TX4, TX5, TX6, TX7, TX8, TX9) - - ENDIF -! -! No Downdraft case (including case with no downdraft soln) -! --------------------------------------------------------- -! - IF (.NOT. DDFT) THEN - DO L=KD,K+1 - ETD(L) = 0.0 - HOD(L) = 0.0 - QOD(L) = 0.0 - ENDDO - DO L=KD,K - EVP(L) = 0.0 - ETZ(L) = 0.0 - ENDDO - - ENDIF -! if (lprnt) print *,' hod=',hod -! if (lprnt) print *,' etd=',etd -! -! -!===> CALCULATE GAMMAS i.e. TENDENCIES PER UNIT CLOUD BASE MASSFLUX -! Includes downdraft terms! - - avh = 0.0 - -! -! Fraction of detrained condensate evaporated -! -! tem1 = max(ZERO, min(HALF, (prl(kd)-FOUR_P2)*ONE_M2)) -! tem1 = max(ZERO, min(HALF, (prl(kd)-300.0)*0.005)) - tem1 = 0.0 -! tem1 = 1.0 -! if (kd1 .eq. kbl) tem1 = 0.0 -! - tem2 = 1.0 - tem1 - TEM = DET * QIL(KD) - -! st1 = (HCC-ETA(KD)*HST(KD)) / (1.0+gam(KD)) - - st1 = (HCC+ALHF*TEM-ETA(KD)*HST(KD)) / (1.0+gam(KD)) - DS = ETA(KD1) * (HOS- HOL(KD)) - ALHL*(QOS - QOL(KD)) - DH = ETA(KD1) * (HOS- HOL(KD)) - -! GMS(KD) = (DS + st1 - tem1*det*alhl) * PRI(KD) -! GMS(KD) = (DS + st1 - tem1*(det*alhl+tem*alhf)) * PRI(KD) - - GMS(KD) = (DS + st1 - tem1*det*alhl-tem*alhf) * PRI(KD) -! GMS(KD) = (DS + st1 - det*alhl - tem*alhf) * PRI(KD) - GMH(KD) = PRI(KD) * (HCC-ETA(KD)*HOS + DH) - -! GMH(KD) = PRI(KD) * (HCC-ETA(KD)*HOS + ALHF*tem + DH) -! GMH(KD) = PRI(KD) * (HCC-ETA(KD)*HOS + ALHF*tem*tem1 + DH) - -! if (lprnt) print *,' gmhkd=',gmh(kd),' gmskd=',gms(kd) -! &,' det=',det,' tem=',tem,' tem1=',tem1,' tem2=',tem2 -! -! TENDENCY FOR SUSPENDED ENVIRONMENTAL ICE AND/OR LIQUID WATER -! -! tem2 = 1.0 - tem1 -! tem3 = tem2 * (1.0+alhf/alhl) -! QIL(KD) = (tem3*TEM + ETA(KD1)*(QIS-CIL(KD)) & - - QIL(KD) = (tem2*TEM + ETA(KD1)*(QIS-CIL(KD)) & - & - ETA(KD)*QIS ) * PRI(KD) - QLL(KD) = (tem2*(DET-TEM) + ETA(KD1)*(QLS-CLL(KD)) & - & - ETA(KD)*QLS ) * PRI(KD) -! - GHD(KD) = 0.0 - GSD(KD) = 0.0 -! - DO L=KD1,K - ST1 = ONE - ALFINT(L,1) - ST2 = ONE - ALFINT(L,2) - ST3 = ONE - ALFINT(L,3) - ST4 = ONE - ALFINT(L,4) - ST5 = ONE - ALFIND(L) -! IF (L .LT. KBL) THEN -! IF (L .LT. K) THEN - HB = ALFINT(L,1)*HOL(L-1) + ST1*HOL(L) - QB = ALFINT(L,2)*QOL(L-1) + ST2*QOL(L) - - TEM = ALFINT(L,4)*CIL(L-1) + ST4*CIL(L) - TEM2 = ALFINT(L,3)*CLL(L-1) + ST3*CLL(L) - - TEM1 = ETA(L) * (TEM - CIL(L)) - TEM3 = ETA(L) * (TEM2 - CLL(L)) - - HBD = ALFIND(L)*HOL(L-1) + ST5*HOL(L) - QBD = ALFIND(L)*QOL(L-1) + ST5*QOL(L) - - TEM5 = ETD(L) * (HOD(L) - HBD) - TEM6 = ETD(L) * (QOD(L) - QBD) -! - DH = ETA(L) * (HB - HOL(L)) + TEM5 - DS = DH - ALHL * (ETA(L) * (QB - QOL(L)) + TEM6) - - GMH(L) = DH * PRI(L) - GMS(L) = DS * PRI(L) - -! if (lprnt) print *,' gmh=',gmh(l),' gms=',gms(l) -! &,' dh=',dh,' ds=',ds,' qb=',qb,' qol=',qol(l),' eta=',eta(l) -! &,' hb=',hb,' hol=',hol(l),' l=',l,' hod=',hod(l) -! &,' etd=',etd(l),' qod=',qod(l),' tem5=',tem5,' tem6=',tem6 -! - GHD(L) = TEM5 * PRI(L) - GSD(L) = (TEM5 - ALHL * TEM6) * PRI(L) -! - QIL(L) = TEM1 * PRI(L) - QLL(L) = TEM3 * PRI(L) - - TEM1 = ETA(L) * (CIL(L-1) - TEM) - TEM3 = ETA(L) * (CLL(L-1) - TEM2) - - DH = ETA(L) * (HOL(L-1) - HB) - TEM5 - DS = DH - ALHL * ETA(L) * (QOL(L-1) - QB) & - & + ALHL * (TEM6 - EVP(L-1)) - - GMH(L-1) = GMH(L-1) + DH * PRI(L-1) - GMS(L-1) = GMS(L-1) + DS * PRI(L-1) -! -! if (lprnt) print *,' gmh1=',gmh(l-1),' gms1=',gms(l-1) -! &,' dh=',dh,' ds=',ds,' qb=',qb,' qol=',qol(l-1) -! &,' hb=',hb,' hol=',hol(l-1),' evp=',evp(l-1) -! - GHD(L-1) = GHD(L-1) - TEM5 * PRI(L-1) - GSD(L-1) = GSD(L-1) - (TEM5-ALHL*(TEM6-EVP(L-1))) * PRI(L-1) - - QIL(L-1) = QIL(L-1) + TEM1 * PRI(L-1) - QLL(L-1) = QLL(L-1) + TEM3 * PRI(L-1) -! ELSEIF (L .EQ. KBL) THEN -!! HB = ALFINT(L)*HOL(L-1) + ST1*HBL -!! QB = ALFINT(L)*QOL(L-1) + ST1*QBL -! HB = ALFINT(L)*HOL(L-1) + ST1*HOL(L) -! QB = ALFINT(L)*QOL(L-1) + ST1*QOL(L) - -!! HB = HBL -!! QB = QBL -! HBD = ALFINT(L)*HOL(L-1) + ST1*HOL(L) -! QBD = ALFINT(L)*QOL(L-1) + ST1*QOL(L) - -!! TEM = ALFINQ(L)*CIL(L-1) + ST2*QIB -!! TEM2 = ALFINQ(L)*CLL(L-1) + ST2*QLB -! TEM = ALFINQ(L)*CIL(L-1) + ST2*CIL(L) -! TEM2 = ALFINQ(L)*CLL(L-1) + ST2*CLL(L) - -! TEM1 = ETA(L) * (TEM - QIB) -! TEM3 = ETA(L) * (TEM2 - QLB) - -! TEM5 = ETD(L) * (HOD(L) - HBD) -! TEM6 = ETD(L) * (QOD(L) - QBD) - -! tem4 = GRAVFAC * pris -! TX1 = ETA(L) * (HB - HBL) * TEM4 -! TX2 = TX1 - ALHL * ETA(L) * (QB - QBL) * TEM4 -! DH = TEM5 - -! DS = DH - ALHL * (TEM6 + EVP(L)) - - -! GMH(L) = TX1 + DH * PRI(L) -! GMS(L) = TX2 + DS * PRI(L) -! -! GHD(L) = TEM5 * PRI(L) -! GSD(L) = (TEM5 - ALHL * (TEM6+EVP(L))) * PRI(L) -! -! QIL(L) = TEM1 * tem4 -! QLL(L) = TEM3 * tem4 - -! TEM1 = ETA(L) * (CIL(L-1) - TEM) -! TEM3 = ETA(L) * (CLL(L-1) - TEM2) - -! DH = ETA(L) * (HOL(L-1) - HB) - TEM5 -! DS = DH - ALHL * ETA(L) * (QOL(L-1) - QB) -! * + ALHL * (TEM6 - EVP(L-1)) - -! GMH(L-1) = GMH(L-1) + DH * PRI(L-1) -! GMS(L-1) = GMS(L-1) + DS * PRI(L-1) -! -! GHD(L-1) = GHD(L-1) - TEM5 * PRI(L-1) -! GSD(L-1) = GSD(L-1) - (TEM5-ALHL*(TEM6-EVP(L-1))) -! * * PRI(L-1) - -! QIL(L-1) = QIL(L-1) + TEM1 * PRI(L-1) -! QLL(L-1) = QLL(L-1) + TEM3 * PRI(L-1) -! ELSE -!! HB = ALFINT(L)*HOL(L-1) + ST1*HOL(L) -!! QB = ALFINT(L)*QOL(L-1) + ST1*QOL(L) -!! -!! TEM = ALFINQ(L)*CIL(L-1) + ST2*CIL(L) -!! TEM2 = ALFINQ(L)*CLL(L-1) + ST2*CLL(L) -!! -!! TEM1 = ETA(L) * (TEM - CIL(L)) -!! TEM3 = ETA(L) * (TEM2 - CLL(L)) -!! -!! TEM5 = ETD(L) * (HOD(L) - HB) -!! TEM6 = ETD(L) * (QOD(L) - QB) -! -!! DH = ETA(L) * (HB - HOL(L)) + TEM5 -!! DS = DH - ALHL * (ETA(L) * (QB - QOL(L)) + TEM6) -! -!! GMH(L) = DH * PRI(L) -!1 GMS(L) = DS * PRI(L) - -! if (lprnt) print *,' gmh=',gmh(l),' gms=',gms(l) -! &,' dh=',dh,' ds=',ds,' qb=',qb,' qol=',qol(l),' eta=',eta(l) -! &,' hb=',hb,' hol=',hol(l),' l=',l -! -!! GHD(L) = TEM5 * PRI(L) -!! GSD(L) = (TEM5 - ALHL * TEM6) * PRI(L) -! -!! QIL(L) = TEM1 * PRI(L) -!! QLL(L) = TEM3 * PRI(L) -! -! -! -! HBD = ALFINT(L)*HOL(L-1) + ST1*HOL(L) -! QBD = ALFINT(L)*QOL(L-1) + ST1*QOL(L) -! TEM5 = ETD(L) * (HOD(L) - HBD) -! TEM6 = ETD(L) * (QOD(L) - QBD) -! DH = TEM5 -! DS = DH - ALHL * (TEM6 + EVP(L)) -! -! GMH(L) = TX1 + DH * PRI(L) -! GMS(L) = TX2 + DS * PRI(L) -! GHD(L) = DH * PRI(L) -! GSD(L) = DS * PRI(L) -! -! DH = - TEM5 -! DS = DH + ALHL * TEM6 -! GMH(L-1) = GMH(L-1) + DH * PRI(L-1) -! GMS(L-1) = GMS(L-1) + DS * PRI(L-1) -! -! GHD(L-1) = GHD(L-1) + DH * PRI(L-1) -! GSD(L-1) = GSD(L-1) + DS * PRI(L-1) -! -! QIL(L) = QIL(L-1) -! QLL(L) = QLL(L-1) -! ENDIF - - avh = avh + gmh(l-1)*(prs(l)-prs(l-1)) - - ENDDO -! -!! TEM2 = - ALHL * EVP(K) * PRI(K) -!! GMS(K) = GMS(K) + TEM2 -!! GSD(K) = GSD(K) + TEM2 -! - - HBD = HOL(K) - QBD = QOL(K) - TEM5 = ETD(K+1) * (HOD(K+1) - HBD) - TEM6 = ETD(K+1) * (QOD(K+1) - QBD) - DH = - TEM5 - DS = DH + ALHL * TEM6 - TEM1 = DH * PRI(K) - TEM2 = (DS - ALHL * EVP(K)) * PRI(K) -!! TEM2 = - ALHL * EVP(K) * PRI(K) - GMH(K) = GMH(K) + TEM1 - GMS(K) = GMS(K) + TEM2 - GHD(K) = GHD(K) + TEM1 - GSD(K) = GSD(K) + TEM2 - -! if (lprnt) print *,' gmhk=',gmh(k),' gmsk=',gms(k) -! &,' tem1=',tem1,' tem2=',tem2,' dh=',dh,' ds=',ds -! - avh = avh + gmh(K)*(prs(KP1)-prs(K)) -! - tem4 = - GRAVFAC * pris - TX1 = DH * tem4 - TX2 = DS * tem4 -! - DO L=KBL,K - GMH(L) = GMH(L) + TX1 - GMS(L) = GMS(L) + TX2 - GHD(L) = GHD(L) + TX1 - GSD(L) = GSD(L) + TX2 -! - avh = avh + tx1*(prs(l+1)-prs(l)) - ENDDO - -! DO L=KBL,K -! tem = (eta(l+1) - eta(l)) * pri(l) -! tx1 = dh * tem -! tx2 = ds * tem -! GMH(L) = GMH(L) + TX1 -! GMS(L) = GMS(L) + TX2 -! GHD(L) = GHD(L) + TX1 -! GSD(L) = GSD(L) + TX2 - -! avh = avh + tx1*(prs(l+1)-prs(l)) -! ENDDO -! -! if (lprnt) then -! print *,' gmh=',gmh -! print *,' gms=',gms(KD:K) -! endif -! -!*********************************************************************** -!*********************************************************************** - -!===> KERNEL (AKM) CALCULATION BEGINS - -!===> MODIFY SOUNDING WITH UNIT MASS FLUX -! -! TESTMB = 0.01 - - DO L=KD,K - - TEM1 = GMH(L) - TEM2 = GMS(L) - HOL(L) = HOL(L) + TEM1*TESTMB - QOL(L) = QOL(L) + (TEM1-TEM2) * (TESTMB/ALHL) -! & + ALHF*QIL(L)) * (TESTMB/ALHL) - HST(L) = HST(L) + TEM2*(ONE+GAM(L))*TESTMB - QST(L) = QST(L) + TEM2*GAM(L)*(TESTMB/ALHL) - CLL(L) = CLL(L) + QLL(L) * TESTMB - CIL(L) = CIL(L) + QIL(L) * TESTMB - ENDDO -! - - if (alm .gt. 0.0) then - HOS = HOS + GMH(KD) * TESTMB - QOS = QOS + (GMH(KD)-GMS(KD)) * (TESTMB/ALHL) -! & + ALHF*QIL(KD)) * (TESTMB/ALHL) - - QLS = QLS + QLL(KD) * TESTMB - QIS = QIS + QIL(KD) * TESTMB - else - st2 = 1.0 - st1s - HOS = HOS + (st1s*GMH(KD)+st2*GMH(KD1)) * TESTMB - QOS = QOS + (st1s * (GMH(KD)-GMS(KD)) & - & + st2 * (GMH(KD1)-GMS(KD1))) * (TESTMB/ALHL) -! QOS = QOS + (st1s * (GMH(KD)-GMS(KD)+ALHF*QIL(KD)) & -! & + st2 * (GMH(KD1)-GMS(KD1)+ALHF*QIL(KD1))) & -! & * (TESTMB/ALHL) - HST(kd) = HST(kd) + (st1s*GMS(kd)*(ONE+GAM(kd)) & - & + st2*gms(kd1)*(ONE+GAM(kd1))) * TESTMB - QST(kd) = QST(kd) + (st1s*GMS(kd)*GAM(kd) & - & + st2*gms(kd1)*gam(kd1)) * (TESTMB/ALHL) - - QLS = QLS + (st1s*QLL(KD)+st2*QLL(KD1)) * TESTMB - QIS = QIS + (st1s*QIL(KD)+st2*QIL(KD1)) * TESTMB - endif - -! - TEM = PRL(K+1) - PRL(K) - HBL = HOL(K) * TEM - QBL = QOL(K) * TEM - QLB = CLL(K) * TEM - QIB = CIL(K) * TEM - DO L=KM1,KBL,-1 - TEM = PRL(L+1) - PRL(L) - HBL = HBL + HOL(L) * TEM - QBL = QBL + QOL(L) * TEM - QLB = QLB + CLL(L) * TEM - QIB = QIB + CIL(L) * TEM - ENDDO - HBL = HBL * PRIS - QBL = QBL * PRIS - QLB = QLB * PRIS - QIB = QIB * PRIS - -! if (lprnt) print *,' hbla=',hbl,' qbla=',qbl - -!*********************************************************************** - -!===> CLOUD WORKFUNCTION FOR MODIFIED SOUNDING, THEN KERNEL (AKM) -! - AKM = ZERO - TX1 = ZERO - QTL = QST(KB1) - GAF(KB1)*HST(KB1) - QTV = QBL - HCC = HBL - TX2 = HCC - TX4 = (ALHF*0.5)*MAX(ZERO,MIN(ONE,(TCR-TCL-TOL(KB1))*TCRF)) -! TX4 = (ALHF*0.5)*MAX(0.0,MIN(1.0,(TCR-TOL(KB1))*TCRF)) -! -! tem = qst(kbl) - gaf(kbl)*hst(kbl) -! qtv = 0.5 * ((tem+qtl) + (gaf(kbl)+gaf(kb1))*hbl) -! tx1 = max(ZERO, qbl-qtv) -! qtv = qbl - tx1 -! tx1 = tx1 + qib + qlb -! - qtv = qbl - tx1 = qib + qlb -! - - DO L=KB1,KD1,-1 - DEL_ETA = ETA(L) - ETA(L+1) - HCCP = HCC + DEL_ETA*HOL(L) -! - QTLP = QST(L-1) - GAF(L-1)*HST(L-1) - QTVP = 0.5 * ((QTLP+QTL)*ETA(L) & - & +(GAF(L)+GAF(L-1))*HCCP) - - DETP = (BKC(L)*TX1 - (QTVP-QTV) & - & + DEL_ETA*(QOL(L)+CLL(L)+CIL(L)) & - & + ETA(L)*Q0U(L) + ETA(L+1)*Q0D(L)) * AKC(L) - IF (DETP .LE. ZERO) UNSAT = .TRUE. - - ST1 = HST(L) - LTL(L)*NU*(QST(L)-QOL(L)) - - TEM2 = (ALHF*0.5)*MAX(ZERO,MIN(ONE,(TCR-TCL-TOL(L-1))*TCRF)) -! TEM2 = (ALHF*0.5)*MAX(0.0,MIN(1.0,(TCR-TOL(L-1))*TCRF)) - TEM1 = HCCP + DETP * (TEM2+TX4) - - ST2 = LTL(L) * VTF(L) - TEM5 = CLL(L) + CIL(L) - AKM = AKM + & - & ( (TX2 -ETA(L+1)*ST1-ST2*(TX1-TEM5*eta(l+1))) * DLB(L) & - & + (TEM1 -ETA(L )*ST1-ST2*(DETP-TEM5*eta(l))) * DLT(L) ) -! - HCC = HCCP - TX1 = DETP - TX2 = TEM1 - QTL = QTLP - QTV = QTVP - TX4 = TEM2 - ENDDO -! - if (unsat) return -! -! Eventhough we ignore the change in lambda, we still assume -! that the cLoud-top contribution is zero; as though we still -! had non-bouyancy there. -! -! - ST1 = HST(KD) - LTL(KD)*NU*(QST(KD)-QOS) - ST2 = LTL(KD) * VTF(KD) - TEM5 = (QLS + QIS) * eta(kd1) - AKM = AKM + HALF * (TX2-ETA(KD1)*ST1-ST2*(TX1-TEM5)) * DLB(KD) -! - AKM = (AKM - WFN) * (ONE/TESTMB) - - -!*********************************************************************** - -!===> MASS FLUX - -! if (acr .gt. 0.0) then -! tem = max(0.01, min(0.05, (wfn-acr)/acr)) -! else -! tem = max(0.01, 0.05*min(1.0, wfn)) -! endif -!!! tem2 = (rasalf*(tem-0.01) + 0.05 - tem) * oneopt4 -! tem2 = (rel_fac*(tem-0.01) + 0.05 - tem) * oneopt4 - tem2 = rel_fac -! - AMB = - (WFN-ACR) / AKM -! -! if(lprnt) print *,' wfn=',wfn,' acr=',acr,' akm=',akm & -! &,' amb=',amb,' KD=',kd,' cldfrd=',cldfrd,' tem2=',tem2 & -! &,' rel_fac=',rel_fac,' prskd=',prs(kd) - -!===> RELAXATION AND CLIPPING FACTORS -! - AMB = AMB * CLP * tem2 - -!!! if (DDFT) AMB = MIN(AMB, ONE/CLDFRD) - -!===> SUB-CLOUD LAYER DEPTH LIMIT ON MASS FLUX - - AMBMAX = (PRL(KP1)-PRL(KBL))*(FRACBL*GRAVCON) - AMB = MAX(MIN(AMB, AMBMAX),ZERO) - - -! if(lprnt) print *,' AMB=',amb,' clp=',clp,' ambmax=',ambmax -!*********************************************************************** -!*************************RESULTS*************************************** -!*********************************************************************** - -!===> PRECIPITATION AND CLW DETRAINMENT -! - avt = 0.0 - avq = 0.0 - avr = dof - -! - DSFC = DSFC + AMB * ETD(K) * (1.0/DT) -! -! DO L=KBL,KD,-1 - DO L=K,KD,-1 - PCU(L) = PCU(L) + AMB*RNN(L) ! (A40) - avr = avr + rnn(l) -! if(lprnt) print *,' avr=',avr,' rnn=',rnn(l),' l=',l - ENDDO -! -!===> TEMPARATURE AND Q CHANGE AND CLOUD MASS FLUX DUE TO CLOUD TYPE KD -! - TX1 = AMB * (ONE/CP) - TX2 = AMB * (ONE/ALHL) - DO L=KD,K - ST1 = GMS(L)*TX1 - TOI(L) = TOI(L) + ST1 - TCU(L) = TCU(L) + ST1 - TCD(L) = TCD(L) + GSD(L) * TX1 -! -! st1 = st1 - (alhf/cp) * QIL(L) * AMB - st1 = st1 - (alhl/cp) * (QIL(L) + QLL(L)) * AMB - - avt = avt + st1 * (prs(l+1)-prs(l)) - - FLX(L) = FLX(L) + ETA(L)*AMB - FLXD(L) = FLXD(L) + ETD(L)*AMB -! - QII(L) = QII(L) + QIL(L) * AMB - TEM = 0.0 - - QLI(L) = QLI(L) + QLL(L) * AMB + TEM - - ST1 = (GMH(L)-GMS(L)) * TX2 -! ST1 = (GMH(L)-GMS(L)+ALHF*QIL(L)) * TX2 - - QOI(L) = QOI(L) + ST1 - QCU(L) = QCU(L) + ST1 - QCD(L) = QCD(L) + (GHD(L)-GSD(L)) * TX2 -! - avq = avq + (st1+(QLL(L)+QIL(L))*amb) * (prs(l+1)-prs(l)) -! avq = avq + st1 * (prs(l+1)-prs(l)) -! avr = avr + (QLL(L) + QIL(L)*(1+alhf/alhl)) -! avr = avr + (QLL(L) + QIL(L)) -! * * (prs(l+1)-prs(l)) * gravcon - -! if(lprnt) print *,' avr=',avr,' qll=',qll(l),' l=',l -! &,' qil=',qil(l) - - ENDDO - avr = avr * amb -! -! Correction for negative condensate! -! if (advcld) then -! do l=kd,k -! if (qli(l) .lt. 0.0) then -! qoi(l) = qoi(l) + qli(l) -! toi(l) = toi(l) - (alhl/cp) * qli(l) -! qli(l) = 0.0 -! endif -! if (qii(l) .lt. 0.0) then -! qoi(l) = qoi(l) + qii(l) -! toi(l) = toi(l) - ((alhl+alhf)/cp) * qii(l) -! qii(l) = 0.0 -! endif -! enddo -! endif - -! -! -! if (lprnt) then -! print *,' For KD=',KD -! avt = avt * cp * 100.0*86400.0 / (alhl*DT*grav) -! avq = avq * 100.0*86400.0 / (DT*grav) -! avr = avr * 86400.0 / DT -! print *,' avt=',avt,' avq=',avq,' avr=',avr,' avh=' -! * ,avh,' alm=',alm,' DDFT=',DDFT,' KD=',KD -! &,' TOIK-',toi(k),' TOIK-1=',toi(k-1),' TOIK-2=',toi(k-2) -! if (kd .eq. 12 .and. .not. ddft) stop -! if (avh .gt. 0.1 .or. abs(avt+avq) .gt. 1.0e-5 .or. -! & abs(avt-avr) .gt. 1.0e-5 .or. abs(avr+avq) .gt. 1.0e-5) stop -! -! if (lprnt) then -! print *,' For KD=',KD -! print *,' TCU=',(tcu(l),l=kd,k) -! print *,' QCU=',(Qcu(l),l=kd,k) -! endif -! - TX1 = 0.0 - TX2 = 0.0 -! -! REEVAPORATION OF FALLING CONVECTIVE RAIN -! - IF (REVAP) THEN -! AFC = -(1.04E-4*DT)*(3600./DT)**0.578 -! rknob = 5.0 -! rknob = 3.0 -! rknob = 0.0 -! rknob = 1.9 -! rknob = 2.0 -! - tem = 0.0 - do l=kd,kbl -! tem = tem + pcu(l) - IF (L .lt. IDH .or. (.not. DDFT)) THEN - tem = tem + amb * rnn(l) - endif - enddo - tem = tem + amb * dof - tem = tem * (3600.0/dt) -! tem1 = 4.0E10/max(garea,one) * sqrt((prl(kbl)-prl(kd))/prl(K+1)) -!LLLL tem1 = rknob * sqrt(sqrt(4.0E10/max(garea,one))) -!! tem2 = sqrt(4.0E10/max(garea,one)) -!! tem1 = sqrt(tem2) -!! tem1 = rknob * max(one, tem1*tem2) - tem1 = max(1.0, min(100.0,sqrt((5.0E10/max(garea,one))))) -!Cntnewtem1 = max(1.0, min(100.0,(5.0E10/max(garea,one)))) -!Cnt tem1 = max(1.0, min(100.0,(4.0E10/max(garea,one)))) -! tem1 = rknob * sqrt(4.0E10/max(garea,one)) -! clfrac = ((clfa*tem + clfb)*tem + clfc)*tem + clfd -! clfrac = min(point3, max(point01,clfrac)) - -! if (lprnt) print *,' clfr0=',clf(tem),' tem=',tem,' tem1=',tem1 - - clfrac = max(ZERO, min(ONE, rknob*clf(tem)*tem1)) - -! if (lprnt) print *,' cldfrd=',cldfrd,' amb=',amb -! &,' clfrac=',clfrac - -! TX3 = AMB*ETA(KD)*PRI(KD) -! CLDFRD = MIN(AMB*CLDFRD, ONE) -! if(lprnt) print *,' cldfrd=',cldfrd,' amb=',amb -! CLDFRD = MIN(AMB*CLDFRD, 1.0) -! -! if(lprnt) print *,' tx3=',tx3,' etakd=',eta(kd),' pri=',pri(kd) -! if(lprnt) print *,' RNN=',RNN(kd:k) -! -!cnt DO L=KD,K - DO L=KD,KBL ! Testing on 20070926 -! clvfr = (prl(l)+prl(l+1)) / (prl(k)+prl(k+1)) -!!! clvfr = 0.5 * (prl(l)+prl(l+1)) / prl(k+1) -! clvfr = min(1.0, clvfr * clvfr) -! for L=KD,K - IF (L .GE. IDH .AND. DDFT) THEN - TX2 = TX2 + AMB * RNN(L) - CLDFRD = MIN(AMB*CLDFR(L), clfrac) -!!! CLDFRD = MIN(AMB*CLDFR(L), ONE) -! if (l .eq. kbl) tx2 = tx2 + amb * dof -! if (l .eq. kbl) tx1 = tx1 + amb * dof - ELSE - TX1 = TX1 + AMB * RNN(L) - ENDIF - tx4 = zfac * phil(l) - tx4 = (one - tx4 * (one - half*tx4)) * afc -! -! CLFRAC = MIN(TX3*rknob*1.1, ONE) -! CLFRAC = ONE -! CLFRAC = MIN(TX3*rknob, ONE) -! CLFRAC = MIN(TX3*rknob, 1.0) - - IF (TX1 .GT. 0. .OR. TX2 .GT. 0.0) THEN - TEQ = TOI(L) - QEQ = QOI(L) - PL = 0.5 * (PRL(L+1)+PRL(L)) - - ST1 = MAX(ZERO, MIN(ONE, (TCR-TEQ)*TCRF)) -! ST1 = MAX(0.0, MIN(1.0, (TCR-TEQ)*TCRF)) - ST2 = ST1*ELFOCP + (1.0-ST1)*ELOCP - - CALL QSATCN ( TEQ,PL,QSTEQ,DQDT,.false.) -! -! tx8 = 10.0 * fpvs(teq) ! fpvs is in centibars! -! tx9 = 1.0 / max(pl + epsm1 * tx8, 1.0e-10) -! qsteq = MIN(eps*tx8*tx9, 1.0) -! dqdt = pl * qsteq * alhl * tx9 / (teq*teq*rv) -! - DELTAQ = 0.5 * (QSTEQ*rhc_ls(l)-QEQ) / (1.+ST2*DQDT) -! - QEQ = QEQ + DELTAQ - TEQ = TEQ - DELTAQ*ST2 -! - TEM1 = MAX(ZERO, MIN(ONE, (TCR-TEQ)*TCRF)) -! TEM1 = MAX(0.0, MIN(1.0, (TCR-TEQ)*TCRF)) - TEM2 = TEM1*ELFOCP + (1.0-TEM1)*ELOCP - - CALL QSATCN ( TEQ,PL,QSTEQ,DQDT,.false.) -! -! tx8 = 10.0 * fpvs(teq) ! fpvs is in centibars! -! tx9 = 1.0 / max(pl + epsm1 * tx8, 1.0e-10) -! qsteq = MIN(eps*tx8*tx9, 1.0) -! dqdt = pl * qsteq * alhl * tx9 / (teq*teq*rv) -! - DELTAQ = (QSTEQ*rhc_ls(l)-QEQ) / (1.+TEM2*DQDT) -! - QEQ = QEQ + DELTAQ - TEQ = TEQ - DELTAQ*TEM2 - - IF (QEQ .GT. QOI(L)) THEN - POTEVAP = (QEQ-QOI(L))*(PRL(L+1)-PRL(L))*GRAVCON -! POTEVAP = (QEQ-QOI(L))*(PRL(L+1)-PRL(L))*GRAVCON * 0.85 - -! TEM3 = SQRT(PL*0.001) - tem4 = 0.0 - if (tx1 .gt. 0.0) & - & TEM4 = POTEVAP * (1. - EXP( tx4*TX1**0.57777778 ) ) -! & TEM4 = POTEVAP * (1. - EXP( AFC*tx4*SQRT(TX1) ) ) -! & TEM4 = POTEVAP * (1. - EXP( AFC*SQRT(TX1*TEM3) ) ) -! & TEM4 = POTEVAP * (1. - EXP(-0.32*SQRT(DT*TX1*0.001) ) ) - ACTEVAP = MIN(TX1, TEM4*CLFRAC) -! ACTEVAP = MIN(TX1, TEM4*CLFRAC*clvfr) -! if(lprnt) print *,' L=',L,' actevap=',actevap,' tem4=',tem4, -! &' clfrac=' -! &,clfrac,' potevap=',potevap,'efac=',AFC*SQRT(TX1*TEM3) -! &,' tx1=',tx1 - if (tx1 .lt. rainmin*dt) actevap = min(tx1, potevap) -! - tem4 = 0.0 - if (tx2 .gt. 0.0) & - & TEM4 = POTEVAP * (1. - EXP( tx4*TX2**0.57777778 ) ) -! & TEM4 = POTEVAP * (1. - EXP( AFC*tx4*SQRT(TX2) ) ) -! & TEM4 = POTEVAP * (1. - EXP( AFC*SQRT(TX2*TEM3) ) ) -! & TEM4 = POTEVAP * (1. - EXP(-0.32*SQRT(DT*TX2*0.001) ) ) - TEM4 = min(MIN(TX2, TEM4*CLDFRD), potevap-actevap) - if (tx2 .lt. rainmin*dt) tem4 = min(tx2, potevap-actevap) -! - TX1 = TX1 - ACTEVAP - TX2 = TX2 - TEM4 - ST1 = (ACTEVAP+TEM4) * PRI(L) - QOI(L) = QOI(L) + ST1 - QCU(L) = QCU(L) + ST1 -! - - ST1 = ST1 * ELOCP - TOI(L) = TOI(L) - ST1 - TCU(L) = TCU(L) - ST1 - ENDIF - ENDIF - ENDDO -! -!!! CUP = CUP + TX1 + TX2 - CUP = CUP + TX1 + TX2 + DOF * AMB - ELSE - DO L=KD,K - TX1 = TX1 + AMB * RNN(L) - ENDDO - CUP = CUP + TX1 + DOF * AMB - ENDIF - -! CUP = CUP + TX1 + TX2 + DOF * AMB -! CUP = CUP + TX1 + TX2 -! if (lprnt) print *,' tx1=',tx1,' tx2=',tx2,' dof=',dof -! &,' cup=',cup*86400/dt,' amb=',amb -! &,' amb=',amb,' cup=',cup,' clfrac=',clfrac,' cldfrd=',cldfrd -! &,' ddft=',ddft,' kd=',kd,' kbl=',kbl,' k=',k -! -! MIXING OF PASSIVE TRACERS -! - DO N=1,M - - DO L=KD,K - HOL(L) = ROI(L,N) - ENDDO -! - HCC = RBL(N) - HOD(KD) = HOL(KD) -! Compute downdraft properties for the tracer - DO L=KD1,K - ST1 = ONE - ALFIND(L) - HB = ALFIND(L) * HOL(L-1) + ST1 * HOL(L) - IF (ETZ(L-1) .NE. 0.0) THEN - DEL_ETA = ETD(L) - ETD(L-1) - TEM = 1.0 / ETZ(L-1) - IF (DEL_ETA .GT. 0.0) THEN - HOD(L) = (ETD(L-1)*(HOD(L-1)-HOL(L-1)) & - & + ETD(L) *(HOL(L-1)-HB) & - & + ETZ(L-1)*HB) * TEM - ELSE - HOD(L) = (ETD(L-1)*(HOD(L-1)-HB) + ETZ(L-1)*HB) * TEM - ENDIF - ELSE - HOD(L) = HB - ENDIF - ENDDO - - DO L=KB1,KD,-1 - HCC = HCC + (ETA(L)-ETA(L+1))*HOL(L) - ENDDO -! - GMH(KD) = PRI(KD) * (HCC-ETA(KD)*HOL(KD)) - DO L=KD1,K - ST1 = ONE - ALFINT(L,N+4) - ST2 = ONE - ALFIND(L) -! IF (L .LT. KBL) THEN - HB = ALFINT(L,N+4) * HOL(L-1) + ST1 * HOL(L) - HBD = ALFIND(L) * HOL(L-1) + ST2 * HOL(L) - TEM5 = ETD(L) * (HOD(L) - HBD) -!! DH = ETA(L) * (HB - HOL(L)) * trcfac(n) + TEM5 - DH = ETA(L) * (HB - HOL(L)) + TEM5 -!! GMH(L ) = DH * PRI(L) - GMH(L ) = DH * PRI(L) * trcfac(n,l) -!! DH = ETA(L) * (HOL(L-1) - HB) * trcfac(n) - TEM5 -!! GMH(L-1) = GMH(L-1) + DH * PRI(L-1) - DH = ETA(L) * (HOL(L-1) - HB) - TEM5 - GMH(L-1) = GMH(L-1) + DH * PRI(L-1) * trcfac(n,l) -! ELSEIF (L .EQ. KBL) THEN -! HB = ALFINT(L) * HOL(L-1) + ST1 * RBL(N) -! HBD = ALFINT(L) * HOL(L-1) + ST1 * HOL(L) -! DH = ETD(L) * (HOD(L) - HBD) -! tem4 = GRAVFAC * pris -! TX1 = ETA(L) * (HB - RBL(N)) * TEM4 -! GMH(L) = (TX1 + DH * PRI(L)) * trcfac(n) -! DH = ETA(L) * (HOL(L-1) - HB) - DH -! GMH(L-1) = GMH(L-1) + DH * PRI(L-1) * trcfac(n) -! ELSE -! HBD = ALFINT(L) * HOL(L-1) + ST1 * HOL(L) -! DH = ETD(L) * (HOD(L) - HBD) -! GMH(L) = (TX1 + DH * PRI(L)) * trcfac(n) -! GMH(L-1) = GMH(L-1) - DH * PRI(L-1) * trcfac(n) -! ENDIF - ENDDO -! - DO L=KD,K - ST1 = GMH(L)*AMB - ROI(L,N) = HOL(L) + ST1 - RCU(L,N) = RCU(L,N) + ST1 - ENDDO - ENDDO ! Tracer loop M - -! if (lprnt) print *,' toio=',toi -! if (lprnt) print *,' qoio=',qoi -! if (lprnt .and. kd .eq. 41) stop -! if (toi(K)-toi(k-1) .lt. 20.0) stop -!*********************************************************************** -!*********************************************************************** -!*********************************************************************** - - RETURN - END - - SUBROUTINE DDRFT( & - & K, KD & - &, TLA, ALFIND & - &, TOL, QOL, HOL, PRL, QST, HST, GAM, GAF, HBL, QBL& - &, QRB, QRT, BUY, KBL, IDH, ETA, RNN, ETAI & - &, ALM, WFN, TRAIN, DDFT & - &, ETD, HOD, QOD, EVP, DOF, CLDFRD, WCB & - &, GMS, GSD, GHD,lprnt) -! &, GMS, GSD, GHD,lprnt) -! &, TX1, TX2, TX3, TX4, TX5, TX6, TX7, TX8, TX9) - -! -!*********************************************************************** -!******************** Cumulus Downdraft Subroutine ********************* -!****************** Based on Cheng and Arakawa (1997) ****** ********** -!************************ SUBROUTINE DDRFT **************************** -!************************* October 2004 ****************************** -!*********************************************************************** -!*********************************************************************** -!************* Shrinivas.Moorthi@noaa.gov (301) 763 8000(X7233) ******** -!*********************************************************************** -!*********************************************************************** -!23456789012345678901234567890123456789012345678901234567890123456789012 -! -!===> TOL(K) INPUT TEMPERATURE KELVIN -!===> QOL(K) INPUT SPECIFIC HUMIDITY NON-DIMENSIONAL - -!===> PRL(K+1) INPUT PRESSURE @ EDGES MB - -!===> K INPUT THE RISE & THE INDEX OF THE SUBCLOUD LAYER -!===> KD INPUT DETRAINMENT LEVEL ( 1<= KD < K ) -! - USE MACHINE , ONLY : kind_phys - use module_ras - IMPLICIT NONE -! -! INPUT ARGUMENTS -! - INTEGER K, KD - real(kind=kind_phys) ALFIND(K) - INTEGER KBL, KB1 - - - - LOGICAL SKPDD, SKPUP - - real(kind=kind_phys) HOL(KD:K), QOL(KD:K), GAF(KD:K+1) & - &, HST(KD:K), QST(KD:K), TOL(KD:K) & - &, BUY(KD:K+1), QRB(KD:K), QRT(KD:K) & - &, GAM(KD:K+1), RNN(KD:K), RNS(KD:K) & - &, ETA(KD:K+1), PRL(KD:K+1), ETAI(KD:K) -! - real(kind=kind_phys) HBL, QBL, PRIS & - &, TRAIN, WFN, ALM -! -! TEMPORARY WORK SPACE -! - real(kind=kind_phys) GMS(KD:K+1) - real(kind=kind_phys) TX1, TX2, TX3, TX4 & - &, TX5, TX6, TX7, TX8, TX9 - LOGICAL UNSAT - - real(kind=kind_phys) TL, PL, QL, QS, DQS, ST1, HB, QB, TB & - &, QQQ, PICON, PIINV, DEL_ETA & - &, TEM, TEM1, TEM2, TEM3, TEM4, ST2 & - &, ERRMIN, ERRMI2, ERRH, ERRW, ERRE, TEM5 & - &, TEM6, HBD, QBD - INTEGER I, L, N, IX, KD1, II & - &, KP1, IT, KM1, KTEM, KK, KK1, LM1, LL, LP1 & - &, IP1, JJ, ntla - -! - integer, parameter :: NUMTLA=2 -! integer, parameter :: NUMTLA=4 - parameter (ERRMIN=0.0001, ERRMI2=0.1*ERRMIN) -! parameter (ERRMIN=0.00001, ERRMI2=0.1*ERRMIN) -! - real(kind=kind_phys) TLA, STLA, CTL2, CTL3 - real(kind=kind_phys) GMF, PI, ONPG, CTLA, VTRM, VTPEXP & - &, RPART, QRMIN, AA1, BB1, CC1, DD1 & - &, WC2MIN, WCMIN, WCBASE, F2, F3, F5, GMF1, GMF5 & - &, QRAF, QRBF, CMPOR , del_tla -! &, sialf -! - parameter (ONPG=1.0+0.5, GMF=1.0/ONPG, RPART=0.0) -! parameter (ONPG=1.0+0.5, GMF=1.0/ONPG, RPART=1.0) -! parameter (ONPG=1.0+0.5, GMF=1.0/ONPG, RPART=0.5) -! PARAMETER (AA1=1.0, BB1=1.5, CC1=1.1, DD1=0.85, F3=CC1, F5=2.5) -! PARAMETER (AA1=2.0, BB1=1.5, CC1=1.1, DD1=0.85, F3=CC1, F5=2.5) - PARAMETER (AA1=1.0, BB1=1.0, CC1=1.0, DD1=1.0, F3=CC1, F5=1.0) - parameter (QRMIN=1.0E-6, WC2MIN=0.01, GMF1=GMF/AA1, GMF5=GMF/F5) -! parameter (QRMIN=1.0E-6, WC2MIN=1.00, GMF1=GMF/AA1, GMF5=GMF/F5) -! parameter (sialf=0.5) -! - PARAMETER (PI=3.1415926535897931, PIINV=1.0/PI) - INTEGER ITR, ITRMU, ITRMD, KTPD, ITRMIN, ITRMND -! PARAMETER (ITRMU=25, ITRMD=25, ITRMIN=7) - PARAMETER (ITRMU=25, ITRMD=25, ITRMIN=12, ITRMND=12) -! PARAMETER (ITRMU=25, ITRMD=25, ITRMIN=12) -! PARAMETER (ITRMU=14, ITRMD=18, ITRMIN=7) -! PARAMETER (ITRMU=10, ITRMD=10, ITRMIN=5) - real(kind=kind_phys) QRP(KD:K+1), WVL(KD:K+1), AL2 - real(kind=kind_phys) WVLO(KD:K+1) -! - real(kind=kind_phys) RNF(KD:K), ETD(KD:K+1), WCB(KD:K) & - &, HOD(KD:K+1), QOD(KD:K+1), EVP(KD:K) & - &, ROR(KD:K+1), STLT(KD:K) & - &, GHD(KD:K), GSD(KD:K), CLDFRD(KD:K) & - &, RNT, RNB & - &, ERRQ, RNTP - INTEGER IDW, IDH, IDN(K), idnm - real(kind=kind_phys) ELM(K) -! real(kind=kind_phys) EM(K*K), ELM(K) - real(kind=kind_phys) EDZ, DDZ, CE, QHS, FAC, FACG, ASIN, & - & RSUM1, RSUM2, RSUM3, CEE - LOGICAL DDFT, UPDRET, DDLGK -! - real(kind=kind_phys) AA(KD:K,KD:K+1), QW(KD:K,KD:K) & - &, BUD(KD:K), VT(2), VRW(2), TRW(2) & - &, GQW(KD:K) & - &, QA(3), WA(3), DOF, DOFW & - &, QRPI(KD:K), QRPS(KD:K) -! &, GQW(KD:K), WCB(KD:K) - -!*********************************************************************** - - real(kind=kind_phys) QRPF, VTPF - logical lprnt -!CFPP$ EXPAND (QRPF, QRABF, VTPF) -!CFPP$ NOCONCUR R - -! - -! if(lprnt) print *,' K=',K,' KD=',KD,' In Downdrft' - - KD1 = KD + 1 - KP1 = K + 1 - KM1 = K - 1 - KB1 = KBL - 1 -! - CMPOR = CMB2PA / RGAS -! -! VTP = 36.34*SQRT(1.2)* (0.001)**0.1364 - VTPEXP = -0.3636 -! PIINV = 1.0 / PI - PICON = PI * ONEBG * 0.5 -! -! -! Compute Rain Water Budget of the Updraft (Cheng and Arakawa, 1997) -! - CLDFRD = 0.0 - RNTP = 0.0 - DOF = 0.0 - ERRQ = 10.0 - RNB = 0.0 - RNT = 0.0 - TX2 = PRL(KBL) -! - TX1 = (PRL(KD) + PRL(KD1)) * 0.5 - ROR(KD) = CMPOR*TX1 / (TOL(KD)*(1.0+NU*QOL(KD))) -! GMS(KD) = VTP * ROR(KD) ** VTPEXP - GMS(KD) = VTP * VTPF(ROR(KD)) -! - QRP(KD) = QRMIN -! - TEM = TOL(K) * (1.0 + NU * QOL(K)) - ROR(K+1) = 0.5 * CMPOR * (PRL(K+1)+PRL(K)) / TEM - GMS(K+1) = VTP * VTPF(ROR(K+1)) - QRP(K+1) = QRMIN -!! BUY(KD) = MAX(BUY(KD),ONE_M1) -! BUY(KD) = MAX(BUY(KD), 0.1) -! BUY(KD) = MAX(BUY(KD), 0.0) -! - kk = kbl - DO L=KD1,K - TEM = 0.5 * (TOL(L)+TOL(L-1)) & - & * (1.0 + (0.5*NU) * (QOL(L)+QOL(L-1))) - ROR(L) = CMPOR * PRL(L) / TEM -! GMS(L) = VTP * ROR(L) ** VTPEXP - GMS(L) = VTP * VTPF(ROR(L)) - QRP(L) = QRMIN -!! BUY(L) = MAX(BUY(L),ONE_M1) -! BUY(L) = MAX(BUY(L), 0.1) -! BUY(L) = MAX(BUY(L), 1.0E-5) - if (buy(l) .le. 0.0 .and. kk .eq. KBL) then - kk = l -! if (buy(l) .le. 0.0) then -! if (buy(l-1) .gt. 0.0 .and. buy(l+1) .gt. 0.0) then -! buy(l) = 0.5 * (buy(l+1) + buy(l-1)) -! elseif (buy(l-1) .gt. 0.0) then -! buy(l) = 0.5*buy(l-1) -! buy(l) = 0.25 * buy(l-1) -! else -! BUY(L) = 1.0E-4 -! BUY(L) = 5.0E-4 -! BUY(L) = 1.0E-5 -! endif - endif -! BUY(L) = MAX(BUY(L), 1.0E-4) -! BUY(L) = MAX(BUY(L), 1.0E-5) -! BUY(L) = MAX(BUY(L), 5.0E-4) - ENDDO - if (kk .ne. kbl) then - do l=kk,kbl - buy(l) = 0.9 * buy(l-1) - enddo - endif -! - do l=kd,k - qrpi(l) = buy(l) - enddo - do l=kd1,kb1 - buy(l) = 0.25 * (qrpi(l-1)+qrpi(l)+qrpi(l)+qrpi(l+1)) -! tem = 0.5 * (eta(l)+eta(l+1)) -! buy(l) = buy(l) * tem * tem - enddo -! tem = 0.5 * (eta(KD)+eta(kd1)) -! buy(kd) = buy(kd) * tem * tem - -! -! CALL ANGRAD(TX1, ALM, STLA, CTL2, AL2, PI, TLA, TX2, WFN, TX3) - tx1 = 1000.0 + tx1 - prl(k+1) - CALL ANGRAD(TX1, ALM, AL2, TLA, TX2, WFN, TX3) -! -! Following Ucla approach for rain profile -! - F2 = 2.0*BB1*ONEBG/(PI*0.2) - WCMIN = SQRT(WC2MIN) - WCBASE = WCMIN -! -! del_tla = TLA * 0.2 -! del_tla = TLA * 0.25 - del_tla = TLA * 0.3 - TLA = TLA - DEL_TLA -! -! do ntla=1,numtla -! -! if (errq .lt. 1.0 .or. tla .gt. 45.0) cycle -! -! tla = tla + del_tla -! STLA = SIN(TLA*PI/180.0) -! CTL2 = 1.0 - STLA * STLA -! -! if (lprnt) print *,' tla=',tla,' al2=',al2,' ptop=' -! &,0.5*(prl(kd)+prl(kd1)),' ntla=',ntla -! if (lprnt) print *,' buy=',(buy(l),l=kd,kbl) -! -! STLA = F2 * STLA * AL2 -! CTL2 = DD1 * CTL2 -! CTL3 = 0.1364 * CTL2 -! - DO L=KD,K - RNF(L) = 0.0 - RNS(L) = 0.0 - WVL(L) = 0.0 - STLT(L) = 0.0 - GQW(L) = 0.0 - QRP(L) = QRMIN - DO N=KD,K - QW(N,L) = 0.0 - ENDDO - ENDDO -! -!-----QW(N,L) = D(W(N)*W(N))/DQR(L) -! - KK = KBL -! WVL(KK) = WCBASE - QW(KD,KD) = -QRB(KD) * GMF1 - GHD(KD) = ETA(KD) * ETA(KD) - GQW(KD) = QW(KD,KD) * GHD(KD) - GSD(KD) = ETAI(KD) * ETAI(KD) -! GSD(KD) = 1.0 / GHD(KD) -! - GQW(KK) = - QRB(KK-1) * (GMF1+GMF1) -! - WCB(KK) = WCBASE * WCBASE -! WVL(KK) = WCBASE -! STLT(KBL) = 1.0 / WCBASE - - TX1 = WCB(KK) - GSD(KK) = 1.0 - GHD(KK) = 1.0 -! - TEM = GMF1 + GMF1 -!! TX1 = WCB(KK) + buy(kb1)*tem*qrb(kb1) - DO L=KB1,KD1,-1 - GHD(L) = ETA(L) * ETA(L) - GSD(L) = ETAI(L) * ETAI(L) -! GSD(L) = 1.0 / GHD(L) - GQW(L) = - GHD(L) * (QRB(L-1)+QRT(L)) * TEM - QW(L,L) = - QRT(L) * TEM -! -! TX1 = TX1 + BUY(L) * TEM -!! TX1 = TX1 + BUY(L) * TEM * (qrb(l-1)+qrt(l)) * ghd(l) - st1 = 0.5 * (eta(l) + eta(l+1)) - TX1 = TX1 + BUY(L) * TEM * (qrb(l)+qrt(l)) * st1 * st1 - WCB(L) = TX1 * GSD(L) - ENDDO -! - TEM1 = (QRB(KD) + QRT(KD1) + QRT(KD1)) * GMF1 - GQW(KD1) = - GHD(KD1) * TEM1 -! QW(L,KD1) = - QRT(KD1) * TEM - QW(KD1,KD1) = - QRT(KD1) * TEM -! WCB(KD) = (TX1 + BUY(KD)*TEM) * GSD(KD) - st1 = 0.5 * (eta(kd) + eta(kd1)) - WCB(KD) = (TX1 + BUY(KD)*TEM*qrb(kd)*st1*st1) * GSD(KD) -! - DO L=KD1,KBL - DO N=KD,L-1 - QW(N,L) = GQW(L) * GSD(N) - ENDDO - ENDDO - QW(KBL,KBL) = 0.0 -! -! WVL(KBL) = WCBASE -! STLT(KBL) = 1.0 / WCBASE -! -! - do ntla=1,numtla -! -! if (errq .lt. 1.0 .or. tla .gt. 45.0) cycle - if (errq .lt. 0.1 .or. tla .gt. 45.0) cycle -! - tla = tla + del_tla - STLA = SIN(TLA*PI/180.0) - CTL2 = 1.0 - STLA * STLA -! -! if (lprnt) print *,' tla=',tla,' al2=',al2,' ptop=' -! &,0.5*(prl(kd)+prl(kd1)),' ntla=',ntla,' f2=',f2,' stla=',stla -! if (lprnt) print *,' buy=',(buy(l),l=kd,kbl) -! - STLA = F2 * STLA * AL2 - CTL2 = DD1 * CTL2 - CTL3 = 0.1364 * CTL2 -! - DO L=KD,K - RNF(L) = 0.0 - WVL(L) = 0.0 - STLT(L) = 0.0 - QRP(L) = QRMIN - ENDDO - WVL(KBL) = WCBASE - STLT(KBL) = 1.0 / WCBASE -! - DO L=KD,K+1 - DO N=KD,K - AA(N,L) = 0.0 - ENDDO - ENDDO -! - SKPUP = .FALSE. -! - DO ITR=1,ITRMU ! Rain Profile Iteration starts! - IF (.NOT. SKPUP) THEN - wvlo = wvl -! -!-----CALCULATING THE VERTICAL VELOCITY -! - TX1 = 0.0 - QRPI(KBL) = 1.0 / QRP(KBL) - DO L=KB1,KD,-1 - TX1 = TX1 + QRP(L+1) * GQW(L+1) - ST1 = WCB(L) + QW(L,L) * QRP(L) & - & + TX1 * GSD(L) -! if (st1 .gt. 0.0) then - if (st1 .gt. wc2min) then -! WVL(L) = SQRT(ST1) - WVL(L) = 0.5 * (SQRT(ST1) + WVL(L)) -! if (itr .eq. 1) wvl(l) = wvl(l) * 0.25 - else -! if (lprnt) print *,' l=',l,' st1=',st1,' wcb=',wcb(l),' qw=' -! &,qw(l,l),' qrp=',qrp(l),' tx1=',tx1,' gsd=',gsd(l),' ite=',itr -! wvl(l) = 0.5*(wcmin+wvl(l)) - wvl(l) = 0.5 * (wvl(l) + wvl(l+1)) - qrp(l) = 0.5 * ((wvl(l)*wvl(l)-wcb(l)-tx1*gsd(l))/qw(l,l) & - & + qrp(l)) -!! wvl(l) = 0.5 * (wvl(l) + wvl(l+1)) - endif -! wvl(l) = 0.5 * (wvl(l) + wvlo(l)) -! WVL(L) = SQRT(MAX(ST1,WC2MIN)) - wvl(l) = max(wvl(l), wcbase) - STLT(L) = 1.0 / WVL(L) - QRPI(L) = 1.0 / QRP(L) - ENDDO -! qrps = qrp -! do l=kd1,kb1 -! qrp(l) = 0.25 * (qrps(l-1)+qrps(l)+qrps(l)+qrps(l+1)) -! qrpi(l) = 1.0 / qrp(l) -! enddo -! qrpi(kd) = 1.0 / qrp(kd) -! -! if (lprnt) then -! print *,' ITR=',ITR,' ITRMU=',ITRMU -! print *,' WVL=',(WVL(L),L=KD,KBL) -! print *,' qrp=',(qrp(L),L=KD,KBL) -! print *,' qrpi=',(qrpi(L),L=KD,KBL) -! print *,' rnf=',(rnf(L),L=KD,KBL) -! endif -! -!-----CALCULATING TRW, VRW AND OF -! -! VT(1) = GMS(KD) * QRP(KD)**0.1364 - VT(1) = GMS(KD) * QRPF(QRP(KD)) - TRW(1) = ETA(KD) * QRP(KD) * STLT(KD) - TX6 = TRW(1) * VT(1) - VRW(1) = F3*WVL(KD) - CTL2*VT(1) - BUD(KD) = STLA * TX6 * QRB(KD) * 0.5 - RNF(KD) = BUD(KD) - DOF = 1.1364 * BUD(KD) * QRPI(KD) - DOFW = -BUD(KD) * STLT(KD) -! - RNT = TRW(1) * VRW(1) - TX2 = 0.0 - TX4 = 0.0 - RNB = RNT - TX1 = 0.5 - TX8 = 0.0 -! - IF (RNT .GE. 0.0) THEN - TX3 = (RNT-CTL3*TX6) * QRPI(KD) - TX5 = CTL2 * TX6 * STLT(KD) - ELSE - TX3 = 0.0 - TX5 = 0.0 - RNT = 0.0 - RNB = 0.0 - ENDIF -! - DO L=KD1,KB1 - KTEM = MAX(L-2, KD) - LL = L - 1 -! -! VT(2) = GMS(L) * QRP(L)**0.1364 - VT(2) = GMS(L) * QRPF(QRP(L)) - TRW(2) = ETA(L) * QRP(L) * STLT(L) - VRW(2) = F3*WVL(L) - CTL2*VT(2) - QQQ = STLA * TRW(2) * VT(2) - ST1 = TX1 * QRB(LL) - BUD(L) = QQQ * (ST1 + QRT(L)) -! - QA(2) = DOF - WA(2) = DOFW - DOF = 1.1364 * BUD(L) * QRPI(L) - DOFW = -BUD(L) * STLT(L) -! - RNF(LL) = RNF(LL) + QQQ * ST1 - RNF(L) = QQQ * QRT(L) -! - TEM3 = VRW(1) + VRW(2) - TEM4 = TRW(1) + TRW(2) -! - TX6 = .25 * TEM3 * TEM4 - TEM4 = TEM4 * CTL3 -! -!-----BY QR ABOVE -! -! TEM1 = .25*(TRW(1)*TEM3 - TEM4*VT(1))*TX7 - TEM1 = .25*(TRW(1)*TEM3 - TEM4*VT(1))*QRPI(LL) - ST1 = .25*(TRW(1)*(CTL2*VT(1)-VRW(2)) & - & * STLT(LL) + F3*TRW(2)) -!-----BY QR BELOW - TEM2 = .25*(TRW(2)*TEM3 - TEM4*VT(2))*QRPI(L) - ST2 = .25*(TRW(2)*(CTL2*VT(2)-VRW(1)) & - & * STLT(L) + F3*TRW(1)) -! -! From top to the KBL-2 layer -! - QA(1) = TX2 - QA(2) = QA(2) + TX3 - TEM1 - QA(3) = -TEM2 -! - WA(1) = TX4 - WA(2) = WA(2) + TX5 - ST1 - WA(3) = -ST2 -! - TX2 = TEM1 - TX3 = TEM2 - TX4 = ST1 - TX5 = ST2 -! - VT(1) = VT(2) - TRW(1) = TRW(2) - VRW(1) = VRW(2) -! - IF (WVL(KTEM) .EQ. WCMIN) WA(1) = 0.0 - IF (WVL(LL) .EQ. WCMIN) WA(2) = 0.0 - IF (WVL(L) .EQ. WCMIN) WA(3) = 0.0 - DO N=KTEM,KBL - AA(LL,N) = (WA(1)*QW(KTEM,N) * STLT(KTEM) & - & + WA(2)*QW(LL,N) * STLT(LL) & - & + WA(3)*QW(L,N) * STLT(L) ) * 0.5 - ENDDO - AA(LL,KTEM) = AA(LL,KTEM) + QA(1) - AA(LL,LL) = AA(LL,LL) + QA(2) - AA(LL,L) = AA(LL,L) + QA(3) - BUD(LL) = (TX8 + RNN(LL)) * 0.5 & - & - RNB + TX6 - BUD(LL) - AA(LL,KBL+1) = BUD(LL) - RNB = TX6 - TX1 = 1.0 - TX8 = RNN(LL) - ENDDO - L = KBL - LL = L - 1 -! VT(2) = GMS(L) * QRP(L)**0.1364 - VT(2) = GMS(L) * QRPF(QRP(L)) - TRW(2) = ETA(L) * QRP(L) * STLT(L) - VRW(2) = F3*WVL(L) - CTL2*VT(2) - ST1 = STLA * TRW(2) * VT(2) * QRB(LL) - BUD(L) = ST1 - - QA(2) = DOF - WA(2) = DOFW - DOF = 1.1364 * BUD(L) * QRPI(L) - DOFW = -BUD(L) * STLT(L) -! - RNF(LL) = RNF(LL) + ST1 -! - TEM3 = VRW(1) + VRW(2) - TEM4 = TRW(1) + TRW(2) -! - TX6 = .25 * TEM3 * TEM4 - TEM4 = TEM4 * CTL3 -! -!-----BY QR ABOVE -! - TEM1 = .25*(TRW(1)*TEM3 - TEM4*VT(1))*QRPI(LL) - ST1 = .25*(TRW(1)*(CTL2*VT(1)-VRW(2)) & - & * STLT(LL) + F3*TRW(2)) -!-----BY QR BELOW - TEM2 = .25*(TRW(2)*TEM3 - TEM4*VT(2))*QRPI(L) - ST2 = .25*(TRW(2)*(CTL2*VT(2)-VRW(1)) & - & * STLT(L) + F3*TRW(1)) -! -! For the layer next to the top of the boundary layer -! - QA(1) = TX2 - QA(2) = QA(2) + TX3 - TEM1 - QA(3) = -TEM2 -! - WA(1) = TX4 - WA(2) = WA(2) + TX5 - ST1 - WA(3) = -ST2 -! - TX2 = TEM1 - TX3 = TEM2 - TX4 = ST1 - TX5 = ST2 -! - IDW = MAX(L-2, KD) -! - IF (WVL(IDW) .EQ. WCMIN) WA(1) = 0.0 - IF (WVL(LL) .EQ. WCMIN) WA(2) = 0.0 - IF (WVL(L) .EQ. WCMIN) WA(3) = 0.0 -! - KK = IDW - DO N=KK,L - AA(LL,N) = (WA(1)*QW(KK,N) * STLT(KK) & - & + WA(2)*QW(LL,N) * STLT(LL) & - & + WA(3)*QW(L,N) * STLT(L) ) * 0.5 - - ENDDO -! - AA(LL,IDW) = AA(LL,IDW) + QA(1) - AA(LL,LL) = AA(LL,LL) + QA(2) - AA(LL,L) = AA(LL,L) + QA(3) - BUD(LL) = (TX8+RNN(LL)) * 0.5 - RNB + TX6 - BUD(LL) -! - AA(LL,L+1) = BUD(LL) -! - RNB = TRW(2) * VRW(2) -! -! For the top of the boundary layer -! - IF (RNB .LT. 0.0) THEN - KK = KBL - TEM = VT(2) * TRW(2) - QA(2) = (RNB - CTL3*TEM) * QRPI(KK) - WA(2) = CTL2 * TEM * STLT(KK) - ELSE - RNB = 0.0 - QA(2) = 0.0 - WA(2) = 0.0 - ENDIF -! - QA(1) = TX2 - QA(2) = DOF + TX3 - QA(2) - QA(3) = 0.0 -! - WA(1) = TX4 - WA(2) = DOFW + TX5 - WA(2) - WA(3) = 0.0 -! - KK = KBL - IF (WVL(KK-1) .EQ. WCMIN) WA(1) = 0.0 - IF (WVL(KK) .EQ. WCMIN) WA(2) = 0.0 -! - DO II=1,2 - N = KK + II - 2 - AA(KK,N) = (WA(1)*QW(KK-1,N) * STLT(KK-1) & - & + WA(2)*QW(KK,N) * STLT(KK)) * 0.5 - ENDDO - FAC = 0.5 - LL = KBL - L = LL + 1 - LM1 = LL - 1 - AA(LL,LM1) = AA(LL,LM1) + QA(1) - AA(LL,LL) = AA(LL,LL) + QA(2) - BUD(LL) = 0.5*RNN(LM1) - TX6 + RNB - BUD(LL) - AA(LL,LL+1) = BUD(LL) -! -!-----SOLVING THE BUDGET EQUATIONS FOR DQR -! - DO L=KD1,KBL - LM1 = L - 1 - UNSAT = ABS(AA(LM1,LM1)) .LT. ABS(AA(L,LM1)) - DO N=LM1,KBL+1 - IF (UNSAT) THEN - TX1 = AA(LM1,N) - AA(LM1,N) = AA(L,N) - AA(L,N) = TX1 - ENDIF - ENDDO - TX1 = AA(L,LM1) / AA(LM1,LM1) - DO N=L,KBL+1 - AA(L,N) = AA(L,N) - TX1 * AA(LM1,N) - ENDDO - ENDDO -! -!-----BACK SUBSTITUTION AND CHECK IF THE SOLUTION CONVERGES -! - KK = KBL - KK1 = KK + 1 - AA(KK,KK1) = AA(KK,KK1) / AA(KK,KK) ! Qr correction ! - TX2 = ABS(AA(KK,KK1)) * QRPI(KK) ! Error Measure ! -! if (lprnt) print *,' tx2a=',tx2,' aa1=',aa(kk,kk1) -! &,' qrpi=',qrpi(kk) -! - KK = KBL + 1 - DO L=KB1,KD,-1 - LP1 = L + 1 - TX1 = 0.0 - DO N=LP1,KBL - TX1 = TX1 + AA(L,N) * AA(N,KK) - ENDDO - AA(L,KK) = (AA(L,KK) - TX1) / AA(L,L) ! Qr correction ! - TX2 = MAX(TX2, ABS(AA(L,KK))*QRPI(L)) ! Error Measure ! -! if (lprnt) print *,' tx2b=',tx2,' aa1=',aa(l,kk) -! &,' qrpi=',qrpi(l),' L=',L - ENDDO -! -! tem = 0.5 - if (tx2 .gt. 1.0 .and. abs(errq-tx2) .gt. 0.1) then - tem = 0.5 -!! elseif (tx2 .lt. 0.1) then -!! tem = 1.2 - else - tem = 1.0 - endif -! - DO L=KD,KBL -! QRP(L) = MAX(QRP(L)+AA(L,KBL+1), QRMIN) - QRP(L) = MAX(QRP(L)+AA(L,KBL+1)*tem, QRMIN) - ENDDO -! -! if (lprnt) print *,' itr=',itr,' tx2=',tx2 - IF (ITR .LT. ITRMIN) THEN - TEM = ABS(ERRQ-TX2) - IF (TEM .GE. ERRMI2 .AND. TX2 .GE. ERRMIN) THEN - ERRQ = TX2 ! Further iteration ! - ELSE - SKPUP = .TRUE. ! Converges ! - ERRQ = 0.0 ! Rain profile exists! -! print *,' here1',' tem=',tem,' tx2=',tx2,' errmi2=', -! *errmi2,' errmin=',errmin - ENDIF - ELSE - TEM = ERRQ - TX2 -! IF (TEM .LT. ZERO .AND. ERRQ .GT. 0.1) THEN - IF (TEM .LT. ZERO .AND. ERRQ .GT. 0.5) THEN -! IF (TEM .LT. ZERO .and. & -! & (ntla .lt. numtla .or. ERRQ .gt. 0.5)) THEN -! if (lprnt) print *,' tx2=',tx2,' errq=',errq,' tem=',tem - SKPUP = .TRUE. ! No convergence ! - ERRQ = 10.0 ! No rain profile! -!!!! ELSEIF (ABS(TEM).LT.ERRMI2 .OR. TX2.LT.ERRMIN) THEN - ELSEIF (TX2.LT.ERRMIN) THEN - SKPUP = .TRUE. ! Converges ! - ERRQ = 0.0 ! Rain profile exists! -! print *,' here2' - elseif (tem .lt. zero .and. errq .lt. 0.1) then - skpup = .true. -! if (ntla .eq. numtla .or. tem .gt. -0.003) then - errq = 0.0 -! else -! errq = 10.0 -! endif - ELSE - ERRQ = TX2 ! Further iteration ! -! if (lprnt) print *,' itr=',itr,' errq=',errq -! if (itr .eq. itrmu .and. ERRQ .GT. ERRMIN*10 & -! & .and. ntla .eq. 1) ERRQ = 10.0 - ENDIF - ENDIF -! -! if (lprnt) print *,' ERRQ=',ERRQ - - ENDIF ! SKPUP ENDIF! -! - ENDDO ! End of the ITR Loop!! -! enddo ! End of ntla loop -! -! if(lprnt) then -! print *,' QRP=',(QRP(L),L=KD,KBL) -! print *,'RNF=',(RNF(L),L=KD,KBL),' RNT=',RNT,' RNB=',RNB -! &,' errq=',errq -! endif -! - IF (ERRQ .LT. 0.1) THEN - DDFT = .TRUE. - RNB = - RNB - ! do l=kd1,kb1-1 - ! if (wvl(l)-wcbase .lt. 1.0E-9) ddft = .false. - ! enddo - ELSE - DDFT = .FALSE. - ENDIF -! -! Caution !! Below is an adjustment to rain flux to maintain -! conservation of precip! -! - IF (DDFT) THEN - TX1 = 0.0 - DO L=KD,KB1 - TX1 = TX1 + RNF(L) - ENDDO -! if (lprnt) print *,' tx1+rnt+rnb=',tx1+rnt+rnb, ' train=',train - TX1 = TRAIN / (TX1+RNT+RNB) - IF (ABS(TX1-1.0) .LT. 0.2) THEN - RNT = MAX(RNT*TX1,ZERO) - RNB = RNB * TX1 - ELSE - DDFT = .FALSE. - ERRQ = 10.0 - ENDIF - ENDIF - enddo ! End of ntla loop -! - DOF = 0.0 - IF (.NOT. DDFT) RETURN ! Rain profile did not converge! -! - - DO L=KD,KB1 - RNF(L) = RNF(L) * TX1 - - ENDDO -! if (lprnt) print *,' TRAIN=',TRAIN -! if (lprnt) print *,' RNF=',RNF -! -! Adjustment is over -! -! Downdraft -! - DO L=KD,K - WCB(L) = 0.0 - ENDDO -! - SKPDD = .NOT. DDFT -! - ERRQ = 10.0 - IF (.NOT. SKPDD) THEN -! -! Calculate Downdraft Properties -! - - KK = MAX(KB1,KD1) - DO L=KK,K - STLT(L) = STLT(L-1) - ENDDO - TEM1 = 1.0 / BB1 -! - DO L=KD,K - IF (L .LE. KBL) THEN - TEM = STLA * TEM1 - STLT(L) = ETA(L) * STLT(L) * TEM / ROR(L) - ELSE - STLT(L) = 0.0 - ENDIF - ENDDO -! if (lprnt) print *,' STLT=',stlt - - rsum1 = 0.0 - rsum2 = 0.0 - -! - IDN = 99 - DO L=KD,K+1 - ETD(L) = 0.0 - WVL(L) = 0.0 -! QRP(L) = 0.0 - ENDDO - DO L=KD,K - EVP(L) = 0.0 - BUY(L) = 0.0 - QRP(L+1) = 0.0 - ENDDO - HOD(KD) = HOL(KD) - QOD(KD) = QOL(KD) - TX1 = 0.0 ! sigma at the top -!!! TX1 = STLT(KD)*QRB(KD)*ONE ! sigma at the top -! TX1 = MIN(STLT(KD)*QRB(KD)*ONE, ONE) ! sigma at the top -! TX1 = MIN(STLT(KD)*QRB(KD)*0.5, ONE) ! sigma at the top - RNTP = 0.0 - TX5 = TX1 - QA(1) = 0.0 -! if(lprnt) print *,' stlt=',stlt(kd),' qrb=',qrb(kd) -! *,' tx1=',tx1,' ror=',ror(kd),' gms=',gms(kd),' rpart=',rpart -! *,' rnt=',rnt -! -! Here we assume RPART of detrained rain RNT goes to Pd -! - IF (RNT .GT. 0.0) THEN - if (TX1 .gt. 0.0) THEN - QRP(KD) = (RPART*RNT / (ROR(KD)*TX1*GMS(KD))) & - & ** (1.0/1.1364) - else - tx1 = RPART*RNT / (ROR(KD)*GMS(KD)*QRP(KD)**1.1364) - endif - RNTP = (1.0 - RPART) * RNT - BUY(KD) = - ROR(KD) * TX1 * QRP(KD) - ELSE - QRP(KD) = 0.0 - ENDIF -! -! L-loop for the downdraft iteration from KD1 to K+1 (bottom surface) -! -! BUD(KD) = ROR(KD) - idnm = 1 - DO L=KD1,K+1 - - QA(1) = 0.0 - ddlgk = idn(idnm) .eq. 99 - if (.not. ddlgk) cycle - IF (L .LE. K) THEN - ST1 = 1.0 - ALFIND(L) - WA(1) = ALFIND(L)*HOL(L-1) + ST1*HOL(L) - WA(2) = ALFIND(L)*QOL(L-1) + ST1*QOL(L) - WA(3) = ALFIND(L)*TOL(L-1) + ST1*TOL(L) - QA(2) = ALFIND(L)*HST(L-1) + ST1*HST(L) - QA(3) = ALFIND(L)*QST(L-1) + ST1*QST(L) - ELSE - WA(1) = HOL(K) - WA(2) = QOL(K) - WA(3) = TOL(K) - QA(2) = HST(K) - QA(3) = QST(K) - ENDIF -! - FAC = 2.0 - IF (L .EQ. KD1) FAC = 1.0 - - FACG = FAC * 0.5 * GMF5 ! 12/17/97 -! -! DDLGK = IDN(idnm) .EQ. 99 - BUD(KD) = ROR(L) - -! IF (DDLGK) THEN - TX1 = TX5 - WVL(L) = MAX(WVL(L-1),ONE_M1) - - QRP(L) = MAX(QRP(L-1),QRP(L)) -! -! VT(1) = GMS(L-1) * QRP(L-1) ** 0.1364 - VT(1) = GMS(L-1) * QRPF(QRP(L-1)) - RNT = ROR(L-1) * (WVL(L-1)+VT(1))*QRP(L-1) -! if(lprnt) print *,' l=',l,' qa=',qa(1), ' tx1RNT=',RNT*tx1, -! *' wvl=',wvl(l-1) -! *,' qrp=',qrp(l-1),' tx5=',tx5,' tx1=',tx1,' rnt=',rnt - -! - -! TEM = MAX(ALM, 2.5E-4) * MAX(ETA(L), 1.0) - TEM = MAX(ALM,ONE_M6) * MAX(ETA(L), ONE) -! TEM = MAX(ALM, 1.0E-5) * MAX(ETA(L), 1.0) - TRW(1) = PICON*TEM*(QRB(L-1)+QRT(L-1)) - TRW(2) = 1.0 / TRW(1) -! - VRW(1) = 0.5 * (GAM(L-1) + GAM(L)) - VRW(2) = 1.0 / (VRW(1) + VRW(1)) -! - TX4 = (QRT(L-1)+QRB(L-1))*(ONEBG*FAC*500.00*EKNOB) -! - DOFW = 1.0 / (WA(3) * (1.0 + NU*WA(2))) ! 1.0 / TVbar! -! - ETD(L) = ETD(L-1) - HOD(L) = HOD(L-1) - QOD(L) = QOD(L-1) -! - ERRQ = 10.0 - -! - IF (L .LE. KBL) THEN - TX3 = STLT(L-1) * QRT(L-1) * (0.5*FAC) - TX8 = STLT(L) * QRB(L-1) * (0.5*FAC) - TX9 = TX8 + TX3 - ELSE - TX3 = 0.0 - TX8 = 0.0 - TX9 = 0.0 - ENDIF -! - TEM = WVL(L-1) + VT(1) - IF (TEM .GT. 0.0) THEN - TEM1 = 1.0 / (TEM*ROR(L-1)) - TX3 = VT(1) * TEM1 * ROR(L-1) * TX3 - TX6 = TX1 * TEM1 - ELSE - TX6 = 1.0 - ENDIF -! ENDIF -! - IF (L .EQ. KD1) THEN - IF (RNT .GT. 0.0) THEN - TEM = MAX(QRP(L-1),QRP(L)) - WVL(L) = TX1 * TEM * QRB(L-1)*(FACG*5.0) - ENDIF - WVL(L) = MAX(ONE_M2, WVL(L)) - TRW(1) = TRW(1) * 0.5 - TRW(2) = TRW(2) + TRW(2) - ELSE - IF (DDLGK) EVP(L-1) = EVP(L-2) - ENDIF -! -! No downdraft above level IDH -! - - IF (L .LT. IDH) THEN - - ETD(L) = 0.0 - HOD(L) = WA(1) - QOD(L) = WA(2) - EVP(L-1) = 0.0 - WVL(L) = 0.0 - QRP(L) = 0.0 - BUY(L) = 0.0 - TX5 = TX9 - ERRQ = 0.0 - RNTP = RNTP + RNT * TX1 - RNT = 0.0 - WCB(L-1) = 0.0 - ENDIF -! BUD(KD) = ROR(L) -! -! Iteration loop for a given level L begins -! -! if (lprnt) print *,' tx8=',tx8,' tx9=',tx9,' tx5=',tx5 -! &, ' tx1=',tx1 - DO ITR=1,ITRMD -! -! UNSAT = DDLGK .AND. (ERRQ .GT. ERRMIN) - UNSAT = ERRQ .GT. ERRMIN - IF (UNSAT) THEN -! -! VT(1) = GMS(L) * QRP(L) ** 0.1364 - VT(1) = GMS(L) * QRPF(QRP(L)) - TEM = WVL(L) + VT(1) -! - IF (TEM .GT. 0.0) THEN - ST1 = ROR(L) * TEM * QRP(L) + RNT - IF (ST1 .NE. 0.0) ST1 = 2.0 * EVP(L-1) / ST1 - TEM1 = 1.0 / (TEM*ROR(L)) - TEM2 = VT(1) * TEM1 * ROR(L) * TX8 - ELSE - TEM1 = 0.0 - TEM2 = TX8 - ST1 = 0.0 - ENDIF -! if (lprnt) print *,' st1=',st1,' tem=',tem,' ror=',ror(l) -! &,' qrp=',qrp(l),' rnt=',rnt,' ror1=',ror(l-1),' wvl=',wvl(l) -! &,' wvl1=',wvl(l-1),' tem2=',tem2,' vt=',vt(1),' tx3=',tx3 -! - st2 = tx5 - TEM = ROR(L)*WVL(L) - ROR(L-1)*WVL(L-1) - if (tem .gt. 0.0) then - TX5 = (TX1 - ST1 + TEM2 + TX3)/(1.0+tem*tem1) - else - TX5 = TX1 - tem*tx6 - ST1 + TEM2 + TX3 - endif - TX5 = MAX(TX5,ZERO) - tx5 = 0.5 * (tx5 + st2) -! -! qqq = 1.0 + tem * tem1 * (1.0 - sialf) -! -! if (qqq .gt. 0.0) then -! TX5 = (TX1 - sialf*tem*tx6 - ST1 + TEM2 + TX3) / qqq -! else -! TX5 = (TX1 - tem*tx6 - ST1 + TEM2 + TX3) -! endif -! -! if(lprnt) print *,' tx51=',tx5,' tx1=',tx1,' st1=',st1,' tem2=' -! if(tx5 .le. 0.0 .and. l .gt. kd+2) -! * print *,' tx51=',tx5,' tx1=',tx1,' st1=',st1,' tem2=' -! *,tem2,' tx3=',tx3,' tem=',tem,' tem1=',tem1,' wvl=',wvl(l-1), -! &wvl(l),' l=',l,' itr=',itr,' evp=',evp(l-1),' vt=',vt(1) -! *,' qrp=',qrp(l),' rnt=',rnt,' kd=',kd -! if (lprnt) print *,' etd=',etd(l),' wvl=',wvl(l) -! &,' trw=',trw(1),trw(2),' ror=',ror(l),' wa=',wa - - -! - TEM1 = ETD(L) - ETD(L) = ROR(L) * TX5 * MAX(WVL(L),ZERO) -! - if (etd(l) .gt. 0.0) etd(l) = 0.5 * (etd(l) + tem1) -! - - DEL_ETA = ETD(L) - ETD(L-1) - -! TEM = DEL_ETA * TRW(2) -! TEM2 = MAX(MIN(TEM, 1.0), -1.0) -! IF (ABS(TEM) .GT. 1.0 .AND. ETD(L) .GT. 0.0 ) THEN -! DEL_ETA = TEM2 * TRW(1) -! ETD(L) = ETD(L-1) + DEL_ETA -! ENDIF -! IF (WVL(L) .GT. 0.0) TX5 = ETD(L) / (ROR(L)*WVL(L)) -! - ERRE = ETD(L) - TEM1 -! - tem = max(abs(del_eta), trw(1)) - tem2 = del_eta / tem - TEM1 = SQRT(MAX((tem+DEL_ETA)*(tem-DEL_ETA),ZERO)) -! TEM1 = SQRT(MAX((TRW(1)+DEL_ETA)*(TRW(1)-DEL_ETA),0.0)) - - EDZ = (0.5 + ASIN(TEM2)*PIINV)*DEL_ETA + TEM1*PIINV - - DDZ = EDZ - DEL_ETA - WCB(L-1) = ETD(L) + DDZ -! - TEM1 = HOD(L) - IF (DEL_ETA .GT. 0.0) THEN - QQQ = 1.0 / (ETD(L) + DDZ) - HOD(L) = (ETD(L-1)*HOD(L-1) + DEL_ETA*HOL(L-1) & - & + DDZ*WA(1)) * QQQ - QOD(L) = (ETD(L-1)*QOD(L-1) + DEL_ETA*QOL(L-1) & - & + DDZ*WA(2)) * QQQ - ELSEif((ETD(L-1) + EDZ) .gt. 0.0) then - QQQ = 1.0 / (ETD(L-1) + EDZ) - HOD(L) = (ETD(L-1)*HOD(L-1) + EDZ*WA(1)) * QQQ - QOD(L) = (ETD(L-1)*QOD(L-1) + EDZ*WA(2)) * QQQ - ENDIF - ERRH = HOD(L) - TEM1 - ERRQ = ABS(ERRH/HOD(L)) + ABS(ERRE/MAX(ETD(L),ONE_M5)) -! if (lprnt) print *,' ERRQP=',errq,' errh=',errh,' hod=',hod(l) -! &,' erre=',erre,' etd=',etd(l),' del_eta=',del_eta - DOF = DDZ - VT(2) = QQQ - -! - DDZ = DOF - TEM4 = QOD(L) - TEM1 = VRW(1) -! - QHS = QA(3) + 0.5 * (GAF(L-1)+GAF(L)) & - & * (HOD(L)-QA(2)) -! -! First iteration ! -! - ST2 = PRL(L) * (QHS + TEM1 * (QHS-QOD(L))) - TEM2 = ROR(L) * QRP(L) - CALL QRABF(TEM2,QRAF,QRBF) - TEM6 = TX5 * (1.6 + 124.9 * QRAF) * QRBF * TX4 -! - CE = TEM6 * ST2 / ((5.4E5*ST2 + 2.55E6)*(ETD(L)+DDZ)) -! - TEM2 = - ((1.0+TEM1)*(QHS+CE) + TEM1*QOD(L)) - TEM3 = (1.0 + TEM1) * QHS * (QOD(L)+CE) - TEM = MAX(TEM2*TEM2 - 4.0*TEM1*TEM3,ZERO) - QOD(L) = MAX(TEM4, (- TEM2 - SQRT(TEM)) * VRW(2)) -! - -! -! second iteration ! -! - ST2 = PRL(L) * (QHS + TEM1 * (QHS-QOD(L))) - CE = TEM6 * ST2 / ((5.4E5*ST2 + 2.55E6)*(ETD(L)+DDZ)) -! CEE = CE * (ETD(L)+DDZ) -! - - - TEM2 = - ((1.0+TEM1)*(QHS+CE) + TEM1*tem4) - TEM3 = (1.0 + TEM1) * QHS * (tem4+CE) - TEM = MAX(TEM2*TEM2 - 4.0*TEM1*TEM3,ZERO) - QOD(L) = MAX(TEM4, (- TEM2 - SQRT(TEM)) * VRW(2)) -! Evaporation in Layer L-1 -! - - EVP(L-1) = (QOD(L)-TEM4) * (ETD(L)+DDZ) -! Calculate Pd (L+1/2) - QA(1) = TX1*RNT + RNF(L-1) - EVP(L-1) -! -! if(lprnt) print *,' etd=',etd(l),' tx5=',tx5,' rnt=',rnt -! *,' rnf=',rnf(l-1),' evp=',evp(l-1),' itr=',itr,' L=',L - -! - if (qa(1) .gt. 0.0) then - IF (ETD(L) .GT. 0.0) THEN - TEM = QA(1) / (ETD(L)+ROR(L)*TX5*VT(1)) - QRP(L) = MAX(TEM,ZERO) - ELSEIF (TX5 .GT. 0.0) THEN - QRP(L) = (MAX(ZERO,QA(1)/(ROR(L)*TX5*GMS(L)))) & - & ** (1.0/1.1364) - ELSE - QRP(L) = 0.0 - ENDIF - else - qrp(l) = 0.5 * qrp(l) - endif -! Compute Buoyancy - TEM1 = WA(3)+(HOD(L)-WA(1)-ALHL*(QOD(L)-WA(2))) & - & * (1.0/CP) -! if (lprnt) print *,' tem1=',tem1,' wa3=',wa(3),' hod=' -! &,hod(l),' wa1=',wa(1),' qod=',qod(l),' wa2=',wa(2),' alhl=',alhl -! &,' cmpor=',cmpor,' dofw=',dofw,' prl=',prl(l),' qrp=',qrp(l) - TEM1 = TEM1 * (1.0 + NU*QOD(L)) - ROR(L) = CMPOR * PRL(L) / TEM1 - TEM1 = TEM1 * DOFW -!!! TEM1 = TEM1 * (1.0 + NU*QOD(L)) * DOFW - - BUY(L) = (TEM1 - 1.0 - QRP(L)) * ROR(L) * TX5 -! Compute W (L+1/2) - - TEM1 = WVL(L) -! IF (ETD(L) .GT. 0.0) THEN - WVL(L) = VT(2) * (ETD(L-1)*WVL(L-1) - FACG & - & * (BUY(L-1)*QRT(L-1)+BUY(L)*QRB(L-1))) -! -! if (lprnt) print *,' wvl=',wvl(l),'vt2=',vt(2),' buy1=' -! &,buy(l-1),' buy=',buy(l),' qrt1=',qrt(l-1),' qrb1=',qrb(l-1) -! &,' etd1=',etd(l-1),' wvl1=',wvl(l-1) -! ENDIF -! - if (wvl(l) .lt. 0.0) then -! WVL(L) = max(wvl(l), 0.1*tem1) -! WVL(L) = 0.5*tem1 -! WVL(L) = 0.1*tem1 -! WVL(L) = 0.0 - WVL(L) = 1.0e-10 - else - WVL(L) = 0.5*(WVL(L)+TEM1) - endif - -! -! WVL(L) = max(0.5*(WVL(L)+TEM1), 0.0) - - ERRW = WVL(L) - TEM1 -! - ERRQ = ERRQ + ABS(ERRW/MAX(WVL(L),ONE_M5)) - -! if (lprnt) print *,' errw=',errw,' wvl=',wvl(l) -! if(lprnt .or. tx5 .eq. 0.0) then -! if(tx5 .eq. 0.0 .and. l .gt. kbl) then -! print *,' errq=',errq,' itr=',itr,' l=',l,' wvl=',wvl(l) -! &,' tx5=',tx5,' idnm=',idnm,' etd1=',etd(l-1),' etd=',etd(l) -! &,' kbl=',kbl -! endif -! -! if(lprnt) print *,' itr=',itr,' itrmnd=',itrmnd,' itrmd=',itrmd -! IF (ITR .GE. MIN(ITRMIN,ITRMD/2)) THEN - IF (ITR .GE. MIN(ITRMND,ITRMD/2)) THEN -! if(lprnt) print *,' itr=',itr,' etd1=',etd(l-1),' errq=',errq - IF (ETD(L-1) .EQ. 0.0 .AND. ERRQ .GT. 0.2) THEN -! if(lprnt) print *,' bud=',bud(kd),' wa=',wa(1),wa(2) - ROR(L) = BUD(KD) - ETD(L) = 0.0 - WVL(L) = 0.0 - ERRQ = 0.0 - HOD(L) = WA(1) - QOD(L) = WA(2) -! TX5 = TX1 + TX9 - if (L .le. KBL) then - TX5 = TX9 - else - TX5 = (STLT(KB1) * QRT(KB1) & - & + STLT(KBL) * QRB(KB1)) * (0.5*FAC) - endif - -! if(lprnt) print *,' tx1=',tx1,' rnt=',rnt,' rnf=',rnf(l-1) -! *,' evp=',evp(l-1),' l=',l - EVP(L-1) = 0.0 - TEM = MAX(TX1*RNT+RNF(L-1),ZERO) - QA(1) = TEM - EVP(L-1) -! IF (QA(1) .GT. 0.0) THEN -! if(lprnt) print *,' ror=',ror(l),' tx5=',tx5,' tx1=',tx1 -! *,' tx9=',tx9,' gms=',gms(l),' qa=',qa(1) -! if(lprnt) call mpi_quit(13) -! if (tx5 .eq. 0.0 .or. gms(l) .eq. 0.0) -! if (lprnt) -! * print *,' Atx5=',tx5,' gms=',gms(l),' ror=',ror(l) -! *,' L=',L,' QA=',QA(1),' tx1=',tx1,' tx9=',tx9 -! *,' kbl=',kbl,' etd1=',etd(l-1),' idnm=',idnm,' idn=',idn(idnm) -! *,' errq=',errq - QRP(L) = (QA(1) / (ROR(L)*TX5*GMS(L))) & - & ** (1.0/1.1364) -! endif - BUY(L) = - ROR(L) * TX5 * QRP(L) - WCB(L-1) = 0.0 - ENDIF -! - DEL_ETA = ETD(L) - ETD(L-1) - IF(DEL_ETA .LT. 0.0 .AND. ERRQ .GT. 0.1) THEN - ROR(L) = BUD(KD) - ETD(L) = 0.0 - WVL(L) = 0.0 -!!!!! TX5 = TX1 + TX9 - CLDFRD(L-1) = TX5 -! - DEL_ETA = - ETD(L-1) - EDZ = 0.0 - DDZ = -DEL_ETA - WCB(L-1) = DDZ - -! - HOD(L) = HOD(L-1) - QOD(L) = QOD(L-1) - -! - TEM4 = QOD(L) - TEM1 = VRW(1) -! - QHS = QA(3) + 0.5 * (GAF(L-1)+GAF(L)) & - & * (HOD(L)-QA(2)) - -! -! First iteration ! -! - ST2 = PRL(L) * (QHS + TEM1 * (QHS-QOD(L))) - TEM2 = ROR(L) * QRP(L-1) - CALL QRABF(TEM2,QRAF,QRBF) - TEM6 = TX5 * (1.6 + 124.9 * QRAF) * QRBF * TX4 -! - CE = TEM6*ST2/((5.4E5*ST2 + 2.55E6)*(ETD(L)+DDZ)) -! - - TEM2 = - ((1.0+TEM1)*(QHS+CE) + TEM1*QOD(L)) - TEM3 = (1.0 + TEM1) * QHS * (QOD(L)+CE) - TEM = MAX(TEM2*TEM2 -FOUR*TEM1*TEM3,ZERO) - QOD(L) = MAX(TEM4, (- TEM2 - SQRT(TEM)) * VRW(2)) -! -! second iteration ! -! - ST2 = PRL(L) * (QHS + TEM1 * (QHS-QOD(L))) - CE = TEM6*ST2/((5.4E5*ST2 + 2.55E6)*(ETD(L)+DDZ)) -! CEE = CE * (ETD(L)+DDZ) -! - - - TEM2 = - ((1.0+TEM1)*(QHS+CE) + TEM1*tem4) - TEM3 = (1.0 + TEM1) * QHS * (tem4+CE) - TEM = MAX(TEM2*TEM2 -FOUR*TEM1*TEM3,ZERO) - QOD(L) = MAX(TEM4, (- TEM2 - SQRT(TEM)) * VRW(2)) - -! Evaporation in Layer L-1 -! - EVP(L-1) = (QOD(L)-TEM4) * (ETD(L)+DDZ) - -! Calculate Pd (L+1/2) -! RNN(L-1) = TX1*RNT + RNF(L-1) - EVP(L-1) - QA(1) = TX1*RNT + RNF(L-1) - EVP(L-1) = min(EVP(L-1), QA(1)) - QA(1) = QA(1) - EVP(L-1) - qrp(l) = 0.0 -! -! if (tx5 .eq. 0.0 .or. gms(l) .eq. 0.0) -! if (lprnt) -! * print *,' Btx5=',tx5,' gms=',gms(l),' ror=',ror(l) -! *,' L=',L,' QA=',QA(1),' tx1=',tx1,' tx9=',tx9 -! *,' kbl=',kbl,' etd1=',etd(l-1),' DEL_ETA=',DEL_ETA -! &,' evp=',evp(l-1) -! -! IF (QA(1) .GT. 0.0) THEN -!! RNS(L-1) = QA(1) -!!! tx5 = tx9 -! QRP(L) = (QA(1) / (ROR(L)*TX5*GMS(L))) & -! & ** (1.0/1.1364) -! endif -! ERRQ = 0.0 -! Compute Buoyancy -! TEM1 = WA(3)+(HOD(L)-WA(1)-ALHL*(QOD(L)-WA(2))) & -! & * (1.0/CP) -! TEM1 = TEM1 * (1.0 + NU*QOD(L)) * DOFW - -! BUY(L) = (TEM1 - 1.0 - QRP(L)) * ROR(L) * TX5 -! -! IF (QA(1) .GT. 0.0) RNS(L) = QA(1) - IF (L .LE. K) THEN - RNS(L) = QA(1) - QA(1) = 0.0 - ENDIF - tx5 = tx9 - ERRQ = 0.0 - QRP(L) = 0.0 - BUY(L) = 0.0 - -! - ENDIF - ENDIF - ENDIF -! - - ENDDO ! End of the iteration loop for a given L! -! if (kd .eq. 13 .and. .not. ddft) stop - IF (L .LE. K) THEN - IF (ETD(L-1) .EQ. 0.0 & - & .AND. ERRQ .GT. 0.1 .and. l .le. kbl) THEN -!!! & .AND. ERRQ .GT. ERRMIN*10.0 .and. l .le. kbl) THEN -! & .AND. ERRQ .GT. ERRMIN*10.0) THEN - ROR(L) = BUD(KD) - HOD(L) = WA(1) - QOD(L) = WA(2) - TX5 = TX9 ! Does not make too much difference! -! TX5 = TX1 + TX9 - EVP(L-1) = 0.0 -! EVP(L-1) = CEE * (1.0 - qod(l)/qa(3)) - QA(1) = TX1*RNT + RNF(L-1) - EVP(L-1) = min(EVP(L-1), QA(1)) - QA(1) = QA(1) - EVP(L-1) -! QRP(L) = 0.0 - if (tx5 .eq. 0.0 .or. gms(l) .eq. 0.0) then - print *,' Ctx5=',tx5,' gms=',gms(l),' ror=',ror(l) & - &,' L=',L,' QA=',QA(1),' tx1=',tx1,' tx9=',tx9 & - &,' kbl=',kbl,' etd1=',etd(l-1),' DEL_ETA=',DEL_ETA - endif -! IF (QA(1) .GT. 0.0) THEN - QRP(L) = (QA(1) / (ROR(L)*TX5*GMS(L))) & - & ** (1.0/1.1364) -! ENDIF - ETD(L) = 0.0 - WVL(L) = 0.0 - ST1 = 1.0 - ALFIND(L) - - ERRQ = 0.0 - BUY(L) = - ROR(L) * TX5 * QRP(L) - WCB(L-1) = 0.0 - ENDIF - ENDIF - -! -! - LL = MIN(IDN(idnm), K+1) - IF (ERRQ .LT. 1.0 .AND. L .LE. LL) THEN - IF (ETD(L-1) .GT. 0.0 .AND. ETD(L) .EQ. 0.0) THEN - IDN(idnm) = L - wvl(l) = 0.0 - if (L .lt. KBL .or. tx5 .gt. 0.0) idnm = idnm + 1 - errq = 0.0 - ENDIF - if (etd(l) .eq. 0.0 .and. l .gt. kbl) then - idn(idnm) = l - if (tx5 .gt. 0.0) idnm = idnm + 1 - endif - ENDIF - -! if (lprnt) then -! print *,' ERRQ=',ERRQ,' IDN=',IDN(idnm),' idnm=',idnm -! print *,' L=',L,' QRP=',QRP(L),' ETD=',ETD(L),' QA=',QA(1) -! *,' evp=',evp(l-1),' rnf=',rnf(l-1) -! endif - -! -! If downdraft properties are not obtainable, (i.e.solution does -! not converge) , no downdraft is assumed -! -! IF (ERRQ .GT. ERRMIN*100.0 .AND. IDN(idnm) .EQ. 99) & - IF (ERRQ .GT. 0.1 .AND. IDN(idnm) .EQ. 99) & - & DDFT = .FALSE. -! -! - DOF = 0.0 - IF (.NOT. DDFT) RETURN -! -! if (ddlgk .or. l .le. idn(idnm)) then -! rsum2 = rsum2 + evp(l-1) -! print *,' rsum1=',rsum1,' rsum2=',rsum2,' L=',L,' qa=',qa(1) -! *,' evp=',evp(l-1) -! else -! rsum1 = rsum1 + rnf(l-1) -! print *,' rsum1=',rsum1,' rsum2=',rsum2,' L=',L,' rnf=',rnf(l-1) -! endif - - ENDDO ! End of the L Loop of downdraft ! - - TX1 = 0.0 - - DOF = QA(1) -! -! print *,' dof=',dof,' rntp=',rntp,' rnb=',rnb -! print *,' total=',(rsum1+dof+rntp+rnb) - - ENDIF ! SKPDD endif -! - - RNN(KD) = RNTP - TX1 = EVP(KD) - TX2 = RNTP + RNB + DOF - -! if (lprnt) print *,' tx2=',tx2 - II = IDH - IF (II .GE. KD1+1) THEN - RNN(KD) = RNN(KD) + RNF(KD) - TX2 = TX2 + RNF(KD) - RNN(II-1) = 0.0 - TX1 = EVP(II-1) - ENDIF -! if (lprnt) print *,' tx2=',tx2,' idnm=',idnm,' idn=',idn(idnm) - DO L=KD,K - II = IDH - - IF (L .GT. KD1 .AND. L .LT. II) THEN - RNN(L-1) = RNF(L-1) - TX2 = TX2 + RNN(L-1) - - ELSEIF (L .GE. II .AND. L .LT. IDN(idnm)) THEN -!!! ELSEIF (L .GE. II .AND. L .LE. IDN(idnm)) THEN - -! do jj=2,idnm -! if (l .ge. idn(jj-1) .and. l .lt. idn(jj)) then -!!! RNN(L) = 0.0 -!!! TX1 = TX1 + EVP(L) -! endif -! enddo -! - rnn(l) = rns(l) - tx2 = tx2 + rnn(l) - TX1 = TX1 + EVP(L) - - ELSEIF (L .GE. IDN(idnm)) THEN - ETD(L+1) = 0.0 - HOD(L+1) = 0.0 - QOD(L+1) = 0.0 - EVP(L) = 0.0 - RNN(L) = RNF(L) + RNS(L) - TX2 = TX2 + RNN(L) - ENDIF -! if (lprnt) print *,' tx2=',tx2,' L=',L,' rnn=',rnn(l) - ENDDO -! IF (K+1 .GT. IDN(idnm)) THEN -! ETD(K+1) = 0.0 -! HOD(K+1) = 0.0 -! QOD(K+1) = 0.0 -! EVP(K) = 0.0 -! RNN(K) = RNF(K) -! TX2 = TX2 + RNN(K) -! ENDIF -! -! For Downdraft case the rain is that falls thru the bottom - - L = KBL - - RNN(L) = RNN(L) + RNB - CLDFRD(L) = TX5 - -! -! Caution !! Below is an adjustment to rain flux to maintain -! conservation of precip! - -! -! if (lprnt) print *,' train=',train,' tx2=',tx2,' tx1=',tx1 - - IF (TX1 .GT. 0.0) THEN - TX1 = (TRAIN - TX2) / TX1 - ELSE - TX1 = 0.0 - ENDIF - -! TX5 = EVP(KBL) - -!! EVP(KBL) = EVP(KBL) * TX1 - -! TX3 = RNN(KBL) + EVP(KBL) + DOF -! TX2 = RNN(KBL) -! TX4 = EVP(KBL) - -! DO L=KD,KB1 - DO L=KD,K - -! TX5 = TX5 + EVP(L) - EVP(L) = EVP(L) * TX1 -! TX3 = TX3 + EVP(L) + RNN(L) -! TX2 = TX2 + RNN(L) -! TX4 = TX4 + EVP(L) - ENDDO -! -! if (lprnt .and. kd .eq. 52) stop -!*********************************************************************** -!*********************************************************************** - - RETURN - END - - SUBROUTINE QSATCN(TT,P,Q,DQDT,lprnt) - - USE MACHINE , ONLY : kind_phys - USE FUNCPHYS , ONLY : fpvs - USE PHYSCONS, RV => con_RV, CVAP => con_CVAP, CLIQ => con_CLIQ & - &, CSOL => con_CSOL, TTP => con_TTP, HVAP => con_HVAP & - &, HFUS => con_HFUS, EPS => con_eps, EPSM1 => con_epsm1 - implicit none -! include 'constant.h' -! - real(kind=kind_phys) TT, P, Q, DQDT -! - real(kind=kind_phys) rvi, facw, faci, hsub, tmix, DEN - real(kind=kind_phys) ZERO,ONE,ONE_M10 - PARAMETER (RVI=1.0/RV) - PARAMETER (FACW=CVAP-CLIQ, FACI=CVAP-CSOL) - PARAMETER (HSUB=HVAP+HFUS, tmix=TTP-20.0, DEN=1.0/(TTP-TMIX)) - PARAMETER (ZERO=0.,ONE=1.,ONE_M10=1.E-10) - logical lprnt -! -!CFPP$ NOCONCUR R - real(kind=kind_phys) es, d, hlorv, W -! -! es = 10.0 * fpvs(tt) ! fpvs is in centibars! - es = 0.01 * fpvs(tt) ! fpvs is in Pascals! - D = 1.0 / max(p+epsm1*es,ONE_M10) -! - q = MIN(eps*es*D, ONE) -! - W = max(ZERO, min(ONE, (TT - TMIX)*DEN)) - hlorv = ( W * (HVAP + FACW * (tt-ttp)) & - & + (1.0-W) * (HSUB + FACI * (tt-ttp)) ) * RVI - dqdt = p * q * hlorv * D / (tt*tt) -! - return - end - - SUBROUTINE ANGRAD( PRES, ALM, AL2, TLA, PRB, WFN, UFN) -! SUBROUTINE ANGRAD( PRES, ALM, STLA, CTL2, AL2 & -! &, PI, TLA, PRB, WFN, UFN) - USE MACHINE , ONLY : kind_phys - use module_ras , only : refp, refr, tlac, plac, tlbpl, drdp, almax - implicit none - -! real(kind=kind_phys) PRES, STLA, CTL2, pi, pifac & - real(kind=kind_phys) PRES & - &, ALM, AL2, TLA, TEM, TEM1 & - &, PRB, ACR, WFN, UFN -! - integer i -! -! pifac = pi / 180.0 -! print *,' pres=',pres - IF (TLA .LT. 0.0) THEN - IF (PRES .LE. PLAC(1)) THEN - TLA = TLAC(1) - ELSEIF (PRES .LE. PLAC(2)) THEN - TLA = TLAC(2) + (PRES-PLAC(2))*tlbpl(1) - ELSEIF (PRES .LE. PLAC(3)) THEN - TLA = TLAC(3) + (PRES-PLAC(3))*tlbpl(2) - ELSEIF (PRES .LE. PLAC(4)) THEN - TLA = TLAC(4) + (PRES-PLAC(4))*tlbpl(3) - ELSEIF (PRES .LE. PLAC(5)) THEN - TLA = TLAC(5) + (PRES-PLAC(5))*tlbpl(4) - ELSEIF (PRES .LE. PLAC(6)) THEN - TLA = TLAC(6) + (PRES-PLAC(6))*tlbpl(5) - ELSEIF (PRES .LE. PLAC(7)) THEN - TLA = TLAC(7) + (PRES-PLAC(7))*tlbpl(6) - ELSEIF (PRES .LE. PLAC(8)) THEN - TLA = TLAC(8) + (PRES-PLAC(8))*tlbpl(7) - ELSE - TLA = TLAC(8) - ENDIF -! tla = tla * 1.5 - -! STLA = SIN(TLA*PIFAC) -! TEM1 = COS(TLA*PIFAC) -! CTL2 = TEM1 * TEM1 - - ELSE -! STLA = SIN(TLA*PIFAC) -! TEM1 = COS(TLA*PIFAC) -! CTL2 = TEM1 * TEM1 - - ENDIF - IF (PRES .GE. REFP(1)) THEN - TEM = REFR(1) - ELSEIF (PRES .GE. REFP(2)) THEN - TEM = REFR(1) + (PRES-REFP(1)) * drdp(1) - ELSEIF (PRES .GE. REFP(3)) THEN - TEM = REFR(2) + (PRES-REFP(2)) * drdp(2) - ELSEIF (PRES .GE. REFP(4)) THEN - TEM = REFR(3) + (PRES-REFP(3)) * drdp(3) - ELSEIF (PRES .GE. REFP(5)) THEN - TEM = REFR(4) + (PRES-REFP(4)) * drdp(4) - ELSEIF (PRES .GE. REFP(6)) THEN - TEM = REFR(5) + (PRES-REFP(5)) * drdp(5) - ELSE - TEM = REFR(6) - ENDIF -!! AL2 = min(ALMAX, MAX(ALM, 2.0E-4/TEM)) -! AL2 = min(2.0E-3, MAX(ALM, 2.0E-4/TEM)) -! - tem = 2.0E-4 / tem - al2 = min(4.0*tem, max(alm, tem)) -! - RETURN - END - SUBROUTINE SETQRP - USE MACHINE , ONLY : kind_phys - use module_ras , only : NQRP,C1XQRP,C2XQRP,TBQRP,TBQRA,TBQRB - implicit none - - real(kind=kind_phys) tem2,tem1,x,xinc,xmax,xmin - integer jx -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!CFPP$ NOCONCUR R -! XMIN=1.0E-6 - XMIN=0.0 - XMAX=5.0 - XINC=(XMAX-XMIN)/(NQRP-1) - C1XQRP=1.-XMIN/XINC - C2XQRP=1./XINC - TEM1 = 0.001 ** 0.2046 - TEM2 = 0.001 ** 0.525 - DO JX=1,NQRP - X = XMIN + (JX-1)*XINC - TBQRP(JX) = X ** 0.1364 - TBQRA(JX) = TEM1 * X ** 0.2046 - TBQRB(JX) = TEM2 * X ** 0.525 - ENDDO -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END - FUNCTION QRPF(QRP) -! - USE MACHINE , ONLY : kind_phys - use module_ras , only : NQRP,C1XQRP,C2XQRP,TBQRP,TBQRA,TBQRB - implicit none - - real(kind=kind_phys) QRP, QRPF, XJ, REAL_NQRP, ONE - PARAMETER (ONE=1.) - INTEGER JX -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - REAL_NQRP=REAL(NQRP) - XJ = MIN(MAX(C1XQRP+C2XQRP*QRP,ONE),REAL_NQRP) -! XJ = MIN(MAX(C1XQRP+C2XQRP*QRP,ONE),FLOAT(NQRP)) - JX = MIN(XJ,NQRP-ONE) - QRPF = TBQRP(JX) + (XJ-JX) * (TBQRP(JX+1)-TBQRP(JX)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END - SUBROUTINE QRABF(QRP,QRAF,QRBF) - USE MACHINE , ONLY : kind_phys - use module_ras , only : NQRP,C1XQRP,C2XQRP,TBQRP,TBQRA,TBQRB - implicit none -! - real(kind=kind_phys) QRP, QRAF, QRBF, XJ, REAL_NQRP, ONE - PARAMETER (ONE=1.) - INTEGER JX -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - REAL_NQRP=REAL(NQRP) - XJ = MIN(MAX(C1XQRP+C2XQRP*QRP,ONE),REAL_NQRP) - JX = MIN(XJ,NQRP-ONE) - XJ = XJ - JX - QRAF = TBQRA(JX) + XJ * (TBQRA(JX+1)-TBQRA(JX)) - QRBF = TBQRB(JX) + XJ * (TBQRB(JX+1)-TBQRB(JX)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END - SUBROUTINE SETVTP - USE MACHINE , ONLY : kind_phys - use module_ras , only : NVTP,C1XVTP,C2XVTP,TBVTP - implicit none - - real(kind=kind_phys) vtpexp,xinc,x,xmax,xmin - integer jx - PARAMETER(VTPEXP=-0.3636) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!CFPP$ NOCONCUR R - XMIN=0.05 - XMAX=1.5 - XINC=(XMAX-XMIN)/(NVTP-1) - C1XVTP=1.-XMIN/XINC - C2XVTP=1./XINC - DO JX=1,NVTP - X = XMIN + (JX-1)*XINC - TBVTP(JX) = X ** VTPEXP - ENDDO -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END - FUNCTION VTPF(ROR) -! - USE MACHINE , ONLY : kind_phys - use module_ras , only : NVTP,C1XVTP,C2XVTP,TBVTP - implicit none - real(kind=kind_phys) ROR, VTPF, XJ, REAL_NVTP, ONE - PARAMETER (ONE=1.) - INTEGER JX -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - REAL_NVTP=REAL(NVTP) - XJ = MIN(MAX(C1XVTP+C2XVTP*ROR,ONE),REAL_NVTP) - JX = MIN(XJ,NVTP-ONE) - VTPF = TBVTP(JX) + (XJ-JX) * (TBVTP(JX+1)-TBVTP(JX)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END - FUNCTION CLF(PRATE) -! - USE MACHINE , ONLY : kind_phys - implicit none - real(kind=kind_phys) PRATE, CLF -! - real (kind=kind_phys), parameter :: ccf1=0.30, ccf2=0.09 & - &, ccf3=0.04, ccf4=0.01 & - &, pr1=1.0, pr2=5.0 & - &, pr3=20.0 -! - if (prate .lt. pr1) then - clf = ccf1 - elseif (prate .lt. pr2) then - clf = ccf2 - elseif (prate .lt. pr3) then - clf = ccf3 - else - clf = ccf4 - endif -! - RETURN - END diff --git a/src/fim/FIMsrc/fim/column/resol_def.F90 b/src/fim/FIMsrc/fim/column/resol_def.F90 deleted file mode 100644 index c689c01..0000000 --- a/src/fim/FIMsrc/fim/column/resol_def.F90 +++ /dev/null @@ -1,43 +0,0 @@ - module resol_def - use machine - implicit none - save - integer jcap,jcap1,jcap2,latg,latg2,latr,latr2 - integer levh,levm1,levp1,levs,lnt,lnt2,lnt22 - integer lnte,lnted,lnto,lntod,lnuv - integer lonf,lonfx,lonr,lonrx - integer ntrac - integer nxpt,nypt,jintmx,latgd - integer ntoz,ntcw - integer lsoil,nmtvr,num_p3d,num_p2d - integer ngrids_sfcc, ngrids_flx -! jbao new gfs phys - integer ngrids_nsst,nr_nsst,nf_nsst -! real(kind=kind_evod) rerth - - INTEGER P_GZ,P_ZEM,P_DIM,P_TEM,P_RM,P_QM - INTEGER P_ZE,P_DI,P_TE,P_RQ,P_Q,P_DLAM,P_DPHI,P_ULN,P_VLN - INTEGER P_W,P_X,P_Y,P_RT,P_ZQ - INTEGER LOTS,LOTD,LOTA - - integer kwq,kwte,kwdz,kwrq -!jbao -!JFM parameter (levs = NVL_VALUE, levp1 = levs+1, latr = 1, lonr = 1) -!JFM levs and levp1 are set in physics.F90 - parameter (latr = 1, lonr = 1) - integer thermodyn_id, sfcpress_id ! hmhj - end module resol_def - -! jbao new gfs physics - module ozne_def - use machine , only : kind_phys - implicit none - save - integer, parameter :: kozpl=28, kozc=48 - integer latsozp, levozp, timeoz, latsozc, levozc, timeozc & - &, PL_Coeff - real (kind=kind_phys) blatc, dphiozc - real (kind=kind_phys), allocatable :: PL_LAT(:), PL_Pres(:) & - &, PL_TIME(:) - end module ozne_def -! end jbao new gfs physics diff --git a/src/fim/FIMsrc/fim/column/sascnv_v.f b/src/fim/FIMsrc/fim/column/sascnv_v.f deleted file mode 100644 index b2c31df..0000000 --- a/src/fim/FIMsrc/fim/column/sascnv_v.f +++ /dev/null @@ -1,1720 +0,0 @@ - SUBROUTINE SASCNV(IM,IX,KM,JCAP,DELT,DEL,PRSL,PS,PHIL,QL, -! SUBROUTINE SASCNV(IM,IX,KM,JCAP,DELT,DEL,PRSL,PHIL,QL, - & Q1,T1,U1,V1,RCS,CLDWRK,RN,KBOT,KTOP,KUO,SLIMSK, - & DOT,XKT2,ncloud,ud_mf,dd_mf,dt_mf) -! hchuang code change [r1L] -! & DOT,XKT2,ncloud) -! -! 10/14/2008 Ho-Chun Huang The Cloudmass flux fields was added by Jongil -! -! for cloud water version -! parameter(ncloud=0) -! SUBROUTINE SASCNV(KM,JCAP,DELT,DEL,SL,SLK,PS,QL, -! & Q1,T1,U1,V1,RCS,CLDWRK,RN,KBOT,KTOP,KUO,SLIMSK, -! & DOT,xkt2,ncloud) -! - USE MACHINE , ONLY : kind_phys - USE FUNCPHYS , ONLY : fpvs - USE PHYSCONS, grav => con_g, CP => con_CP, HVAP => con_HVAP - &, RV => con_RV, FV => con_fvirt, T0C => con_T0C - &, CVAP => con_CVAP, CLIQ => con_CLIQ - &, EPS => con_eps, EPSM1 => con_epsm1 - implicit none -! -! - integer IM, IX, KM, JCAP, ncloud, - & KBOT(IM), KTOP(IM), KUO(IM) - real(kind=kind_phys) DELT - real(kind=kind_phys) PS(IM), DEL(IX,KM), PRSL(IX,KM), -! real(kind=kind_phys) DEL(IX,KM), PRSL(IX,KM), - & QL(IX,KM,2),Q1(IX,KM), T1(IX,KM), - & U1(IX,KM), V1(IX,KM), RCS(IM), - & CLDWRK(IM), RN(IM), SLIMSK(IM), - & DOT(IX,KM), XKT2(IM), PHIL(IX,KM) -! hchuang code change [+1L] mass flux output - &, ud_mf(IM,KM),dd_mf(IM,KM),dt_mf(IM,KM) -! - integer I, INDX, jmn, k, knumb, latd, lond, km1 -! - real(kind=kind_phys) adw, alpha, alphal, alphas, - & aup, beta, betal, betas, - & c0, cpoel, dellat, delta, - & desdt, deta, detad, dg, - & dh, dhh, dlnsig, dp, - & dq, dqsdp, dqsdt, dt, - & dt2, dtmax, dtmin, dv1, - & dv1q, dv2, dv2q, dv1u, - & dv1v, dv2u, dv2v, dv3u, - & dv3v, dv3, dv3q, dvq1, - & dz, dz1, e1, edtmax, - & edtmaxl, edtmaxs, el2orc, elocp, - & es, etah, - & evef, evfact, evfactl, fact1, - & fact2, factor, fjcap, fkm, - & fuv, g, gamma, onemf, - & onemfu, pdetrn, pdpdwn, pprime, - & qc, qlk, qrch, qs, - & rain, rfact, shear, tem1, - & tem2, terr, val, val1, - & val2, w1, w1l, w1s, - & w2, w2l, w2s, w3, - & w3l, w3s, w4, w4l, - & w4s, xdby, xpw, xpwd, - & xqc, xqrch, xlambu, mbdt, - & tem -! -! - integer JMIN(IM), KB(IM), KBCON(IM), KBDTR(IM), - & KT2(IM), KTCON(IM), LMIN(IM), - & kbm(IM), kbmax(IM), kmax(IM) -! - real(kind=kind_phys) AA1(IM), ACRT(IM), ACRTFCT(IM), - & DELHBAR(IM), DELQ(IM), DELQ2(IM), - & DELQBAR(IM), DELQEV(IM), DELTBAR(IM), - & DELTV(IM), DTCONV(IM), EDT(IM), - & EDTO(IM), EDTX(IM), FLD(IM), - & HCDO(IM), HKBO(IM), HMAX(IM), - & HMIN(IM), HSBAR(IM), UCDO(IM), - & UKBO(IM), VCDO(IM), VKBO(IM), - & PBCDIF(IM), PDOT(IM), PO(IM,KM), - & PWAVO(IM), PWEVO(IM), -! & PSFC(IM), PWAVO(IM), PWEVO(IM), - & QCDO(IM), QCOND(IM), QEVAP(IM), - & QKBO(IM), RNTOT(IM), VSHEAR(IM), - & XAA0(IM), XHCD(IM), XHKB(IM), - & XK(IM), XLAMB(IM), XLAMD(IM), - & XMB(IM), XMBMAX(IM), XPWAV(IM), - & XPWEV(IM), XQCD(IM), XQKB(IM) -cc -C PHYSICAL PARAMETERS - PARAMETER(G=grav) - PARAMETER(CPOEL=CP/HVAP,ELOCP=HVAP/CP, - & EL2ORC=HVAP*HVAP/(RV*CP)) - PARAMETER(TERR=0.,C0=.002,DELTA=fv) - PARAMETER(FACT1=(CVAP-CLIQ)/RV,FACT2=HVAP/RV-FACT1*T0C) -C LOCAL VARIABLES AND ARRAYS - real(kind=kind_phys) PFLD(IM,KM), TO(IM,KM), QO(IM,KM), - & UO(IM,KM), VO(IM,KM), QESO(IM,KM) -c cloud water - real(kind=kind_phys) QLKO_KTCON(IM), DELLAL(IM), TVO(IM,KM), - & DBYO(IM,KM), ZO(IM,KM), SUMZ(IM,KM), - & SUMH(IM,KM), HEO(IM,KM), HESO(IM,KM), - & QRCD(IM,KM), DELLAH(IM,KM), DELLAQ(IM,KM), - & DELLAU(IM,KM), DELLAV(IM,KM), HCKO(IM,KM), - & UCKO(IM,KM), VCKO(IM,KM), QCKO(IM,KM), - & ETA(IM,KM), ETAU(IM,KM), ETAD(IM,KM), - & QRCDO(IM,KM), PWO(IM,KM), PWDO(IM,KM), - & RHBAR(IM), TX1(IM) -! - LOGICAL TOTFLG, CNVFLG(IM), DWNFLG(IM), DWNFLG2(IM), FLG(IM) -! - real(kind=kind_phys) PCRIT(15), ACRITT(15), ACRIT(15) -cmy SAVE PCRIT, ACRITT - DATA PCRIT/850.,800.,750.,700.,650.,600.,550.,500.,450.,400., - & 350.,300.,250.,200.,150./ - DATA ACRITT/.0633,.0445,.0553,.0664,.075,.1082,.1521,.2216, - & .3151,.3677,.41,.5255,.7663,1.1686,1.6851/ -C GDAS DERIVED ACRIT -C DATA ACRITT/.203,.515,.521,.566,.625,.665,.659,.688, -C & .743,.813,.886,.947,1.138,1.377,1.896/ -cc - real(kind=kind_phys) tf, tcr, tcrf - parameter (TF=233.16, TCR=263.16, TCRF=1.0/(TCR-TF)) ! From Lord(1978) -! -! parameter (tf=258.16, tcr=273.16, tcrf=1.0/(tcr-tf)) -! - real(kind=kind_phys), parameter :: cons_0=0.0 -c -c-------------------------------------------------------------------- -! - km1 = km - 1 -C INITIALIZE ARRAYS -C - DO I=1,IM - RN(I)=0. - KBOT(I)=KM+1 - KTOP(I)=0 -! KUO(I)=0 - CNVFLG(I) = .TRUE. - DTCONV(I) = 3600. - CLDWRK(I) = 0. - PDOT(I) = 0. - KT2(I) = 0 - QLKO_KTCON(I) = 0. - DELLAL(I) = 0. - ENDDO -! hchuang code change [+7L] - DO K = 1, KM - DO I=1,IM - ud_mf(I,k) = 0. - dd_mf(I,k) = 0. - dt_mf(I,k) = 0. - ENDDO - ENDDO -!! - DO K = 1, 15 - ACRIT(K) = ACRITT(K) * (975. - PCRIT(K)) - ENDDO - DT2 = DELT - val = 1200. - dtmin = max(dt2, val ) - val = 3600. - dtmax = max(dt2, val ) -C MODEL TUNABLE PARAMETERS ARE ALL HERE - MBDT = 10. - EDTMAXl = .3 - EDTMAXs = .3 - ALPHAl = .5 - ALPHAs = .5 - BETAl = .15 - betas = .15 - BETAl = .05 - betas = .05 -c EVEF = 0.07 - evfact = 0.3 - evfactl = 0.3 - PDPDWN = 0. - PDETRN = 200. - xlambu = 1.e-4 - fjcap = (float(jcap) / 126.) ** 2 - val = 1. - fjcap = max(fjcap,val) - fkm = (float(km) / 28.) ** 2 - fkm = max(fkm,val) - W1l = -8.E-3 - W2l = -4.E-2 - W3l = -5.E-3 - W4l = -5.E-4 - W1s = -2.E-4 - W2s = -2.E-3 - W3s = -1.E-3 - W4s = -2.E-5 -CCCCC IF(IM.EQ.384) THEN - LATD = 92 - lond = 189 -CCCCC ELSEIF(IM.EQ.768) THEN -CCCCC LATD = 80 -CCCCC ELSE -CCCCC LATD = 0 -CCCCC ENDIF -C -C DEFINE TOP LAYER FOR SEARCH OF THE DOWNDRAFT ORIGINATING LAYER -C AND THE MAXIMUM THETAE FOR UPDRAFT -C - DO I=1,IM - KBMAX(I) = KM - KBM(I) = KM - KMAX(I) = KM - TX1(I) = 1.0 / PS(I) - ENDDO -! - DO K = 1, KM - DO I=1,IM - IF (prSL(I,K)*tx1(I) .GT. 0.45) KBMAX(I) = K + 1 - IF (prSL(I,K)*tx1(I) .GT. 0.70) KBM(I) = K + 1 - IF (prSL(I,K)*tx1(I) .GT. 0.04) KMAX(I) = K + 1 - ENDDO - ENDDO - DO I=1,IM - KBMAX(I) = MIN(KBMAX(I),KMAX(I)) - KBM(I) = MIN(KBM(I),KMAX(I)) - ENDDO -C -C CONVERT SURFACE PRESSURE TO MB FROM CB -C -!! - DO K = 1, KM - DO I=1,IM - if (K .le. kmax(i)) then - PFLD(I,k) = PRSL(I,K) * 10.0 - PWO(I,k) = 0. - PWDO(I,k) = 0. - TO(I,k) = T1(I,k) - QO(I,k) = Q1(I,k) - UO(I,k) = U1(I,k) - VO(I,k) = V1(I,k) - DBYO(I,k) = 0. - SUMZ(I,k) = 0. - SUMH(I,k) = 0. - endif - ENDDO - ENDDO -C -C COLUMN VARIABLES -C P IS PRESSURE OF THE LAYER (MB) -C T IS TEMPERATURE AT T-DT (K)..TN -C Q IS MIXING RATIO AT T-DT (KG/KG)..QN -C TO IS TEMPERATURE AT T+DT (K)... THIS IS AFTER ADVECTION AND TURBULAN -C QO IS MIXING RATIO AT T+DT (KG/KG)..Q1 -C - DO K = 1, KM - DO I=1,IM - if (k .le. kmax(i)) then -!jfe QESO(I,k) = 10. * FPVS(T1(I,k)) -! - QESO(I,k) = 0.01 * fpvs(T1(I,K)) ! fpvs is in Pa -! - QESO(I,k) = EPS * QESO(I,k) / (PFLD(I,k) + EPSM1*QESO(I,k)) - val1 = 1.E-8 - QESO(I,k) = MAX(QESO(I,k), val1) - val2 = 1.e-10 - QO(I,k) = max(QO(I,k), val2 ) -c QO(I,k) = MIN(QO(I,k),QESO(I,k)) - TVO(I,k) = TO(I,k) + DELTA * TO(I,k) * QO(I,k) - endif - ENDDO - ENDDO -C -C HYDROSTATIC HEIGHT ASSUME ZERO TERR -C - DO K = 1, KM - DO I=1,IM - ZO(I,k) = PHIL(I,k) / G - ENDDO - ENDDO -C COMPUTE MOIST STATIC ENERGY - DO K = 1, KM - DO I=1,IM - if (K .le. kmax(i)) then -! tem = G * ZO(I,k) + CP * TO(I,k) - tem = PHIL(I,k) + CP * TO(I,k) - HEO(I,k) = tem + HVAP * QO(I,k) - HESO(I,k) = tem + HVAP * QESO(I,k) -C HEO(I,k) = MIN(HEO(I,k),HESO(I,k)) - endif - ENDDO - ENDDO -C -C DETERMINE LEVEL WITH LARGEST MOIST STATIC ENERGY -C THIS IS THE LEVEL WHERE UPDRAFT STARTS -C - DO I=1,IM - HMAX(I) = HEO(I,1) - KB(I) = 1 - ENDDO -!! - DO K = 2, KM - DO I=1,IM - if (k .le. kbm(i)) then - IF(HEO(I,k).GT.HMAX(I).AND.CNVFLG(I)) THEN - KB(I) = K - HMAX(I) = HEO(I,k) - ENDIF - endif - ENDDO - ENDDO -C DO K = 1, KMAX - 1 -C TOL(k) = .5 * (TO(I,k) + TO(I,k+1)) -C QOL(k) = .5 * (QO(I,k) + QO(I,k+1)) -C QESOL(I,k) = .5 * (QESO(I,k) + QESO(I,k+1)) -C HEOL(I,k) = .5 * (HEO(I,k) + HEO(I,k+1)) -C HESOL(I,k) = .5 * (HESO(I,k) + HESO(I,k+1)) -C ENDDO - DO K = 1, KM1 - DO I=1,IM - if (k .le. kmax(i)-1) then - DZ = .5 * (ZO(I,k+1) - ZO(I,k)) - DP = .5 * (PFLD(I,k+1) - PFLD(I,k)) -!jfe ES = 10. * FPVS(TO(I,k+1)) -! - ES = 0.01 * fpvs(TO(I,K+1)) ! fpvs is in Pa -! - PPRIME = PFLD(I,k+1) + EPSM1 * ES - QS = EPS * ES / PPRIME - DQSDP = - QS / PPRIME - DESDT = ES * (FACT1 / TO(I,k+1) + FACT2 / (TO(I,k+1)**2)) - DQSDT = QS * PFLD(I,k+1) * DESDT / (ES * PPRIME) - GAMMA = EL2ORC * QESO(I,k+1) / (TO(I,k+1)**2) - DT = (G * DZ + HVAP * DQSDP * DP) / (CP * (1. + GAMMA)) - DQ = DQSDT * DT + DQSDP * DP - TO(I,k) = TO(I,k+1) + DT - QO(I,k) = QO(I,k+1) + DQ - PO(I,k) = .5 * (PFLD(I,k) + PFLD(I,k+1)) - endif - ENDDO - ENDDO -! - DO K = 1, KM1 - DO I=1,IM - if (k .le. kmax(I)-1) then -!jfe QESO(I,k) = 10. * FPVS(TO(I,k)) -! - QESO(I,k) = 0.01 * fpvs(TO(I,K)) ! fpvs is in Pa -! - QESO(I,k) = EPS * QESO(I,k) / (PO(I,k) + EPSM1*QESO(I,k)) - val1 = 1.E-8 - QESO(I,k) = MAX(QESO(I,k), val1) - val2 = 1.e-10 - QO(I,k) = max(QO(I,k), val2 ) -c QO(I,k) = MIN(QO(I,k),QESO(I,k)) - HEO(I,k) = .5 * G * (ZO(I,k) + ZO(I,k+1)) + - & CP * TO(I,k) + HVAP * QO(I,k) - HESO(I,k) = .5 * G * (ZO(I,k) + ZO(I,k+1)) + - & CP * TO(I,k) + HVAP * QESO(I,k) - UO(I,k) = .5 * (UO(I,k) + UO(I,k+1)) - VO(I,k) = .5 * (VO(I,k) + VO(I,k+1)) - endif - ENDDO - ENDDO -c k = kmax -c HEO(I,k) = HEO(I,k) -c hesol(k) = HESO(I,k) -c IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I)) THEN -c PRINT *, ' HEO =' -c PRINT 6001, (HEO(I,K),K=1,KMAX) -c PRINT *, ' HESO =' -c PRINT 6001, (HESO(I,K),K=1,KMAX) -c PRINT *, ' TO =' -c PRINT 6002, (TO(I,K)-273.16,K=1,KMAX) -c PRINT *, ' QO =' -c PRINT 6003, (QO(I,K),K=1,KMAX) -c PRINT *, ' QSO =' -c PRINT 6003, (QESO(I,K),K=1,KMAX) -c ENDIF -C -C LOOK FOR CONVECTIVE CLOUD BASE AS THE LEVEL OF FREE CONVECTION -C - DO I=1,IM - IF(CNVFLG(I)) THEN - INDX = KB(I) - HKBO(I) = HEO(I,INDX) - QKBO(I) = QO(I,INDX) - UKBO(I) = UO(I,INDX) - VKBO(I) = VO(I,INDX) - ENDIF - FLG(I) = CNVFLG(I) - KBCON(I) = KMAX(I) - ENDDO -!! - DO K = 1, KM - DO I=1,IM - if (k .le. kbmax(i)) then - IF(FLG(I).AND.K.GT.KB(I)) THEN - HSBAR(I) = HESO(I,k) - IF(HKBO(I).GT.HSBAR(I)) THEN - FLG(I) = .FALSE. - KBCON(I) = K - ENDIF - ENDIF - endif - ENDDO - ENDDO - DO I=1,IM - IF(CNVFLG(I)) THEN - PBCDIF(I) = -PFLD(I,KBCON(I)) + PFLD(I,KB(I)) - PDOT(I) = 10.* DOT(I,KBCON(I)) - IF(PBCDIF(I).GT.150.) CNVFLG(I) = .FALSE. - IF(KBCON(I).EQ.KMAX(I)) CNVFLG(I) = .FALSE. - ENDIF - ENDDO -!! - TOTFLG = .TRUE. - DO I=1,IM - TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I)) - ENDDO - IF(TOTFLG) RETURN -C FOUND LFC, CAN DEFINE REST OF VARIABLES - 6001 FORMAT(2X,-2P10F12.2) - 6002 FORMAT(2X,10F12.2) - 6003 FORMAT(2X,3P10F12.2) -C -C DETERMINE ENTRAINMENT RATE BETWEEN KB AND KBCON -C - DO I = 1, IM - alpha = alphas - if(SLIMSK(I).eq.1.) alpha = alphal - IF(CNVFLG(I)) THEN - IF(KB(I).EQ.1) THEN - DZ = .5 * (ZO(I,KBCON(I)) + ZO(I,KBCON(I)-1)) - ZO(I,1) - ELSE - DZ = .5 * (ZO(I,KBCON(I)) + ZO(I,KBCON(I)-1)) - & - .5 * (ZO(I,KB(I)) + ZO(I,KB(I)-1)) - ENDIF - IF(KBCON(I).NE.KB(I)) THEN - XLAMB(I) = - LOG(ALPHA) / DZ - ELSE - XLAMB(I) = 0. - ENDIF - ENDIF - ENDDO -C DETERMINE UPDRAFT MASS FLUX - DO K = 1, KM - DO I = 1, IM - if (k .le. kmax(i) .and. CNVFLG(I)) then - ETA(I,k) = 1. - ETAU(I,k) = 1. - ENDIF - ENDDO - ENDDO - DO K = KM1, 2, -1 - DO I = 1, IM - if (k .le. kbmax(i)) then - IF(CNVFLG(I).AND.K.LT.KBCON(I).AND.K.GE.KB(I)) THEN - DZ = .5 * (ZO(I,k+1) - ZO(I,k-1)) - ETA(I,k) = ETA(I,k+1) * EXP(-XLAMB(I) * DZ) - ETAU(I,k) = ETA(I,k) - ENDIF - endif - ENDDO - ENDDO - DO I = 1, IM - IF(CNVFLG(I).AND.KB(I).EQ.1.AND.KBCON(I).GT.1) THEN - DZ = .5 * (ZO(I,2) - ZO(I,1)) - ETA(I,1) = ETA(I,2) * EXP(-XLAMB(I) * DZ) - ETAU(I,1) = ETA(I,1) - ENDIF - ENDDO -C -C WORK UP UPDRAFT CLOUD PROPERTIES -C - DO I = 1, IM - IF(CNVFLG(I)) THEN - INDX = KB(I) - HCKO(I,INDX) = HKBO(I) - QCKO(I,INDX) = QKBO(I) - UCKO(I,INDX) = UKBO(I) - VCKO(I,INDX) = VKBO(I) - PWAVO(I) = 0. - ENDIF - ENDDO -C -C CLOUD PROPERTY BELOW CLOUD BASE IS MODIFIED BY THE ENTRAINMENT PROCES -C - DO K = 2, KM1 - DO I = 1, IM - if (k .le. kmax(i)-1) then - IF(CNVFLG(I).AND.K.GT.KB(I).AND.K.LE.KBCON(I)) THEN - FACTOR = ETA(I,k-1) / ETA(I,k) - ONEMF = 1. - FACTOR - HCKO(I,k) = FACTOR * HCKO(I,k-1) + ONEMF * - & .5 * (HEO(I,k) + HEO(I,k+1)) - UCKO(I,k) = FACTOR * UCKO(I,k-1) + ONEMF * - & .5 * (UO(I,k) + UO(I,k+1)) - VCKO(I,k) = FACTOR * VCKO(I,k-1) + ONEMF * - & .5 * (VO(I,k) + VO(I,k+1)) - DBYO(I,k) = HCKO(I,k) - HESO(I,k) - ENDIF - IF(CNVFLG(I).AND.K.GT.KBCON(I)) THEN - HCKO(I,k) = HCKO(I,k-1) - UCKO(I,k) = UCKO(I,k-1) - VCKO(I,k) = VCKO(I,k-1) - DBYO(I,k) = HCKO(I,k) - HESO(I,k) - ENDIF - endif - ENDDO - ENDDO -C DETERMINE CLOUD TOP - DO I = 1, IM - FLG(I) = CNVFLG(I) - KTCON(I) = 1 - ENDDO -C DO K = 2, KMAX -C KK = KMAX - K + 1 -C IF(DBYO(I,kK).GE.0..AND.FLG(I).AND.KK.GT.KBCON(I)) THEN -C KTCON(I) = KK + 1 -C FLG(I) = .FALSE. -C ENDIF -C ENDDO - DO K = 2, KM - DO I = 1, IM - if (k .le. kmax(i)) then - IF(DBYO(I,k).LT.0..AND.FLG(I).AND.K.GT.KBCON(I)) THEN - KTCON(I) = K - FLG(I) = .FALSE. - ENDIF - endif - ENDDO - ENDDO - DO I = 1, IM - IF(CNVFLG(I).AND.(PFLD(I,KBCON(I)) - PFLD(I,KTCON(I))).LT.150.) - & CNVFLG(I) = .FALSE. - ENDDO - TOTFLG = .TRUE. - DO I = 1, IM - TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I)) - ENDDO - IF(TOTFLG) RETURN -C -C SEARCH FOR DOWNDRAFT ORIGINATING LEVEL ABOVE THETA-E MINIMUM -C - DO I = 1, IM - HMIN(I) = HEO(I,KBCON(I)) - LMIN(I) = KBMAX(I) - JMIN(I) = KBMAX(I) - ENDDO - DO I = 1, IM - DO K = KBCON(I), KBMAX(I) - IF(HEO(I,k).LT.HMIN(I).AND.CNVFLG(I)) THEN - LMIN(I) = K + 1 - HMIN(I) = HEO(I,k) - ENDIF - ENDDO - ENDDO -C -C Make sure that JMIN(I) is within the cloud -C - DO I = 1, IM - IF(CNVFLG(I)) THEN - JMIN(I) = MIN(LMIN(I),KTCON(I)-1) - XMBMAX(I) = .1 - JMIN(I) = MAX(JMIN(I),KBCON(I)+1) - ENDIF - ENDDO -C -C ENTRAINING CLOUD -C - do k = 2, km1 - DO I = 1, IM - if (k .le. kmax(i)-1) then - if(CNVFLG(I).and.k.gt.JMIN(I).and.k.le.KTCON(I)) THEN - SUMZ(I,k) = SUMZ(I,k-1) + .5 * (ZO(I,k+1) - ZO(I,k-1)) - SUMH(I,k) = SUMH(I,k-1) + .5 * (ZO(I,k+1) - ZO(I,k-1)) - & * HEO(I,k) - ENDIF - endif - enddo - enddo -!! - DO I = 1, IM - IF(CNVFLG(I)) THEN -c call random_number(XKT2) -c call srand(fhour) -c XKT2(I) = rand() - KT2(I) = nint(XKT2(I)*float(KTCON(I)-JMIN(I))-.5)+JMIN(I)+1 -! KT2(I) = nint(sqrt(XKT2(I))*float(KTCON(I)-JMIN(I))-.5) + JMIN(I) + 1 -c KT2(I) = nint(ranf() *float(KTCON(I)-JMIN(I))-.5) + JMIN(I) + 1 - tem1 = (HCKO(I,JMIN(I)) - HESO(I,KT2(I))) - tem2 = (SUMZ(I,KT2(I)) * HESO(I,KT2(I)) - SUMH(I,KT2(I))) - if (abs(tem2) .gt. 0.000001) THEN - XLAMB(I) = tem1 / tem2 - else - CNVFLG(I) = .false. - ENDIF -! XLAMB(I) = (HCKO(I,JMIN(I)) - HESO(I,KT2(I))) -! & / (SUMZ(I,KT2(I)) * HESO(I,KT2(I)) - SUMH(I,KT2(I))) - XLAMB(I) = max(XLAMB(I),cons_0) - XLAMB(I) = min(XLAMB(I),2.3/SUMZ(I,KT2(I))) - ENDIF - ENDDO -!! - DO I = 1, IM - DWNFLG(I) = CNVFLG(I) - DWNFLG2(I) = CNVFLG(I) - IF(CNVFLG(I)) THEN - if(KT2(I).ge.KTCON(I)) DWNFLG(I) = .false. - if(XLAMB(I).le.1.e-30.or.HCKO(I,JMIN(I))-HESO(I,KT2(I)).le.1.e-30) - & DWNFLG(I) = .false. - do k = JMIN(I), KT2(I) - if(DWNFLG(I).and.HEO(I,k).gt.HESO(I,KT2(I))) DWNFLG(I)=.false. - enddo -c IF(CNVFLG(I).AND.(PFLD(KBCON(I))-PFLD(KTCON(I))).GT.PDETRN) -c & DWNFLG(I)=.FALSE. - IF(CNVFLG(I).AND.(PFLD(I,KBCON(I))-PFLD(I,KTCON(I))).LT.PDPDWN) - & DWNFLG2(I)=.FALSE. - ENDIF - ENDDO -!! - DO K = 2, KM1 - DO I = 1, IM - if (k .le. kmax(i)-1) then - IF(DWNFLG(I).AND.K.GT.JMIN(I).AND.K.LE.KT2(I)) THEN - DZ = .5 * (ZO(I,k+1) - ZO(I,k-1)) -c ETA(I,k) = ETA(I,k-1) * EXP( XLAMB(I) * DZ) -c to simplify matter, we will take the linear approach here -c - ETA(I,k) = ETA(I,k-1) * (1. + XLAMB(I) * dz) - ETAU(I,k) = ETAU(I,k-1) * (1. + (XLAMB(I)+xlambu) * dz) - ENDIF - endif - ENDDO - ENDDO -!! - DO K = 2, KM1 - DO I = 1, IM - if (k .le. kmax(i)-1) then -c IF(.NOT.DWNFLG(I).AND.K.GT.JMIN(I).AND.K.LE.KT2(I)) THEN - IF(.NOT.DWNFLG(I).AND.K.GT.JMIN(I).AND.K.LE.KTCON(I)) THEN - DZ = .5 * (ZO(I,k+1) - ZO(I,k-1)) - ETAU(I,k) = ETAU(I,k-1) * (1. + xlambu * dz) - ENDIF - endif - ENDDO - ENDDO -c IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I)) THEN -c PRINT *, ' LMIN(I), KT2(I)=', LMIN(I), KT2(I) -c PRINT *, ' KBOT, KTOP, JMIN(I) =', KBCON(I), KTCON(I), JMIN(I) -c ENDIF -c IF(LAT.EQ.LATD.AND.lon.eq.lond) THEN -c print *, ' xlamb =', xlamb -c print *, ' eta =', (eta(k),k=1,KT2(I)) -c print *, ' ETAU =', (ETAU(I,k),k=1,KT2(I)) -c print *, ' HCKO =', (HCKO(I,k),k=1,KT2(I)) -c print *, ' SUMZ =', (SUMZ(I,k),k=1,KT2(I)) -c print *, ' SUMH =', (SUMH(I,k),k=1,KT2(I)) -c ENDIF - DO I = 1, IM - if(DWNFLG(I)) THEN - KTCON(I) = KT2(I) - ENDIF - ENDDO -C -C CLOUD PROPERTY ABOVE CLOUD Base IS MODIFIED BY THE DETRAINMENT PROCESS -C - DO K = 2, KM1 - DO I = 1, IM - if (k .le. kmax(i)-1) then -cjfe - IF(CNVFLG(I).AND.K.GT.KBCON(I).AND.K.LE.KTCON(I)) THEN -cjfe IF(K.GT.KBCON(I).AND.K.LE.KTCON(I)) THEN - FACTOR = ETA(I,k-1) / ETA(I,k) - ONEMF = 1. - FACTOR - fuv = ETAU(I,k-1) / ETAU(I,k) - onemfu = 1. - fuv - HCKO(I,k) = FACTOR * HCKO(I,k-1) + ONEMF * - & .5 * (HEO(I,k) + HEO(I,k+1)) - UCKO(I,k) = fuv * UCKO(I,k-1) + ONEMFu * - & .5 * (UO(I,k) + UO(I,k+1)) - VCKO(I,k) = fuv * VCKO(I,k-1) + ONEMFu * - & .5 * (VO(I,k) + VO(I,k+1)) - DBYO(I,k) = HCKO(I,k) - HESO(I,k) - ENDIF - endif - ENDDO - ENDDO -c IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I)) THEN -c PRINT *, ' UCKO=', (UCKO(I,k),k=KBCON(I)+1,KTCON(I)) -c PRINT *, ' uenv=', (.5*(UO(I,k)+UO(I,k-1)),k=KBCON(I)+1,KTCON(I)) -c ENDIF - DO I = 1, IM - if(CNVFLG(I).and.DWNFLG2(I).and.JMIN(I).le.KBCON(I)) - & THEN - CNVFLG(I) = .false. - DWNFLG(I) = .false. - DWNFLG2(I) = .false. - ENDIF - ENDDO -!! - TOTFLG = .TRUE. - DO I = 1, IM - TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I)) - ENDDO - IF(TOTFLG) RETURN -!! -C -C COMPUTE CLOUD MOISTURE PROPERTY AND PRECIPITATION -C - DO I = 1, IM - AA1(I) = 0. - RHBAR(I) = 0. - ENDDO - DO K = 1, KM - DO I = 1, IM - if (k .le. kmax(i)) then - IF(CNVFLG(I).AND.K.GT.KB(I).AND.K.LT.KTCON(I)) THEN - DZ = .5 * (ZO(I,k+1) - ZO(I,k-1)) - DZ1 = (ZO(I,k) - ZO(I,k-1)) - GAMMA = EL2ORC * QESO(I,k) / (TO(I,k)**2) - QRCH = QESO(I,k) - & + GAMMA * DBYO(I,k) / (HVAP * (1. + GAMMA)) - FACTOR = ETA(I,k-1) / ETA(I,k) - ONEMF = 1. - FACTOR - QCKO(I,k) = FACTOR * QCKO(I,k-1) + ONEMF * - & .5 * (QO(I,k) + QO(I,k+1)) - DQ = ETA(I,k) * QCKO(I,k) - ETA(I,k) * QRCH - RHBAR(I) = RHBAR(I) + QO(I,k) / QESO(I,k) -C -C BELOW LFC CHECK IF THERE IS EXCESS MOISTURE TO RELEASE LATENT HEAT -C - IF(DQ.GT.0.) THEN - ETAH = .5 * (ETA(I,k) + ETA(I,k-1)) - QLK = DQ / (ETA(I,k) + ETAH * C0 * DZ) - AA1(I) = AA1(I) - DZ1 * G * QLK - QC = QLK + QRCH - PWO(I,k) = ETAH * C0 * DZ * QLK - QCKO(I,k) = QC - PWAVO(I) = PWAVO(I) + PWO(I,k) - ENDIF - ENDIF - endif - ENDDO - ENDDO - DO I = 1, IM - RHBAR(I) = RHBAR(I) / float(KTCON(I) - KB(I) - 1) - ENDDO -c -c this section is ready for cloud water -c - if(ncloud.gt.0) THEN -c -c compute liquid and vapor separation at cloud top -c - DO I = 1, IM - k = KTCON(I) - IF(CNVFLG(I)) THEN - GAMMA = EL2ORC * QESO(I,K) / (TO(I,K)**2) - QRCH = QESO(I,K) - & + GAMMA * DBYO(I,K) / (HVAP * (1. + GAMMA)) - DQ = QCKO(I,K-1) - QRCH -C -C CHECK IF THERE IS EXCESS MOISTURE TO RELEASE LATENT HEAT -C - IF(DQ.GT.0.) THEN - QLKO_KTCON(I) = dq - QCKO(I,K-1) = QRCH - ENDIF - ENDIF - ENDDO - ENDIF -C -C CALCULATE CLOUD WORK FUNCTION AT T+DT -C - DO K = 1, KM - DO I = 1, IM - if (k .le. kmax(i)) then - IF(CNVFLG(I).AND.K.GT.KBCON(I).AND.K.LE.KTCON(I)) THEN - DZ1 = ZO(I,k) - ZO(I,k-1) - GAMMA = EL2ORC * QESO(I,k-1) / (TO(I,k-1)**2) - RFACT = 1. + DELTA * CP * GAMMA - & * TO(I,k-1) / HVAP - AA1(I) = AA1(I) + - & DZ1 * (G / (CP * TO(I,k-1))) - & * DBYO(I,k-1) / (1. + GAMMA) - & * RFACT - val = 0. - AA1(I)=AA1(I)+ - & DZ1 * G * DELTA * - & MAX(val,(QESO(I,k-1) - QO(I,k-1))) - ENDIF - endif - ENDDO - ENDDO - DO I = 1, IM - IF(CNVFLG(I).AND.AA1(I).LE.0.) DWNFLG(I) = .FALSE. - IF(CNVFLG(I).AND.AA1(I).LE.0.) DWNFLG2(I) = .FALSE. - IF(CNVFLG(I).AND.AA1(I).LE.0.) CNVFLG(I) = .FALSE. - ENDDO -!! - TOTFLG = .TRUE. - DO I = 1, IM - TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I)) - ENDDO - IF(TOTFLG) RETURN -!! -ccccc IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I)) THEN -ccccc PRINT *, ' AA1(I) BEFORE DWNDRFT =', AA1(I) -ccccc ENDIF -C -C------- DOWNDRAFT CALCULATIONS -C -C -C--- DETERMINE DOWNDRAFT STRENGTH IN TERMS OF WINDSHEAR -C - DO I = 1, IM - IF(CNVFLG(I)) THEN - VSHEAR(I) = 0. - ENDIF - ENDDO - DO K = 1, KM - DO I = 1, IM - if (k .le. kmax(i)) then - IF(K.GE.KB(I).AND.K.LE.KTCON(I).AND.CNVFLG(I)) THEN - shear=rcs(I) * sqrt((UO(I,k+1)-UO(I,k)) ** 2 - & + (VO(I,k+1)-VO(I,k)) ** 2) - VSHEAR(I) = VSHEAR(I) + SHEAR - ENDIF - endif - ENDDO - ENDDO - DO I = 1, IM - EDT(I) = 0. - IF(CNVFLG(I)) THEN - KNUMB = KTCON(I) - KB(I) + 1 - KNUMB = MAX(KNUMB,1) - VSHEAR(I) = 1.E3 * VSHEAR(I) / (ZO(I,KTCON(I))-ZO(I,KB(I))) - E1=1.591-.639*VSHEAR(I) - & +.0953*(VSHEAR(I)**2)-.00496*(VSHEAR(I)**3) - EDT(I)=1.-E1 - val = .9 - EDT(I) = MIN(EDT(I),val) - val = .0 - EDT(I) = MAX(EDT(I),val) - EDTO(I)=EDT(I) - EDTX(I)=EDT(I) - ENDIF - ENDDO -C DETERMINE DETRAINMENT RATE BETWEEN 1 AND KBDTR - DO I = 1, IM - KBDTR(I) = KBCON(I) - beta = betas - if(SLIMSK(I).eq.1.) beta = betal - IF(CNVFLG(I)) THEN - KBDTR(I) = KBCON(I) - KBDTR(I) = MAX(KBDTR(I),1) - XLAMD(I) = 0. - IF(KBDTR(I).GT.1) THEN - DZ = .5 * ZO(I,KBDTR(I)) + .5 * ZO(I,KBDTR(I)-1) - & - ZO(I,1) - XLAMD(I) = LOG(BETA) / DZ - ENDIF - ENDIF - ENDDO -C DETERMINE DOWNDRAFT MASS FLUX - DO K = 1, KM - DO I = 1, IM - IF(k .le. kmax(i)) then - IF(CNVFLG(I)) THEN - ETAD(I,k) = 1. - ENDIF - QRCDO(I,k) = 0. - endif - ENDDO - ENDDO - DO K = KM1, 2, -1 - DO I = 1, IM - if (k .le. kbmax(i)) then - IF(CNVFLG(I).AND.K.LT.KBDTR(I)) THEN - DZ = .5 * (ZO(I,k+1) - ZO(I,k-1)) - ETAD(I,k) = ETAD(I,k+1) * EXP(XLAMD(I) * DZ) - ENDIF - endif - ENDDO - ENDDO - K = 1 - DO I = 1, IM - IF(CNVFLG(I).AND.KBDTR(I).GT.1) THEN - DZ = .5 * (ZO(I,2) - ZO(I,1)) - ETAD(I,k) = ETAD(I,k+1) * EXP(XLAMD(I) * DZ) - ENDIF - ENDDO -C -C--- DOWNDRAFT MOISTURE PROPERTIES -C - DO I = 1, IM - PWEVO(I) = 0. - FLG(I) = CNVFLG(I) - ENDDO - DO I = 1, IM - IF(CNVFLG(I)) THEN - JMN = JMIN(I) - HCDO(I) = HEO(I,JMN) - QCDO(I) = QO(I,JMN) - QRCDO(I,JMN) = QESO(I,JMN) - UCDO(I) = UO(I,JMN) - VCDO(I) = VO(I,JMN) - ENDIF - ENDDO - DO K = KM1, 1, -1 - DO I = 1, IM - if (k .le. kmax(i)-1) then - IF(CNVFLG(I).AND.K.LT.JMIN(I)) THEN - DQ = QESO(I,k) - DT = TO(I,k) - GAMMA = EL2ORC * DQ / DT**2 - DH = HCDO(I) - HESO(I,k) - QRCDO(I,k) = DQ+(1./HVAP)*(GAMMA/(1.+GAMMA))*DH - DETAD = ETAD(I,k+1) - ETAD(I,k) - PWDO(I,k) = ETAD(I,k+1) * QCDO(I) - - & ETAD(I,k) * QRCDO(I,k) - PWDO(I,k) = PWDO(I,k) - DETAD * - & .5 * (QRCDO(I,k) + QRCDO(I,k+1)) - QCDO(I) = QRCDO(I,k) - PWEVO(I) = PWEVO(I) + PWDO(I,k) - ENDIF - endif - ENDDO - ENDDO -C IF(LAT.EQ.LATD.AND.lon.eq.lond.and.DWNFLG(I)) THEN -C PRINT *, ' PWAVO(I), PWEVO(I) =', PWAVO(I), PWEVO(I) -C ENDIF -C -C--- FINAL DOWNDRAFT STRENGTH DEPENDENT ON PRECIP -C--- EFFICIENCY (EDT), NORMALIZED CONDENSATE (PWAV), AND -C--- EVAPORATE (PWEV) -C - DO I = 1, IM - edtmax = edtmaxl - if(SLIMSK(I).eq.0.) edtmax = edtmaxs - IF(DWNFLG2(I)) THEN - IF(PWEVO(I).LT.0.) THEN - EDTO(I) = -EDTO(I) * PWAVO(I) / PWEVO(I) - EDTO(I) = MIN(EDTO(I),EDTMAX) - ELSE - EDTO(I) = 0. - ENDIF - ELSE - EDTO(I) = 0. - ENDIF - ENDDO -C -C -C--- DOWNDRAFT CLOUDWORK FUNCTIONS -C -C - DO K = KM1, 1, -1 - DO I = 1, IM - if (k .le. kmax(i)-1) then - IF(DWNFLG2(I).AND.K.LT.JMIN(I)) THEN - GAMMA = EL2ORC * QESO(I,k+1) / TO(I,k+1)**2 - DHH=HCDO(I) - DT=TO(I,k+1) - DG=GAMMA - DH=HESO(I,k+1) - DZ=-1.*(ZO(I,k+1)-ZO(I,k)) - AA1(I)=AA1(I)+EDTO(I)*DZ*(G/(CP*DT))*((DHH-DH)/(1.+DG)) - & *(1.+DELTA*CP*DG*DT/HVAP) - val=0. - AA1(I)=AA1(I)+EDTO(I)* - & DZ*G*DELTA*MAX(val,(QESO(I,k+1)-QO(I,k+1))) - ENDIF - endif - ENDDO - ENDDO -ccccc IF(LAT.EQ.LATD.AND.lon.eq.lond.and.DWNFLG2(I)) THEN -ccccc PRINT *, ' AA1(I) AFTER DWNDRFT =', AA1(I) -ccccc ENDIF - DO I = 1, IM - IF(AA1(I).LE.0.) CNVFLG(I) = .FALSE. - IF(AA1(I).LE.0.) DWNFLG(I) = .FALSE. - IF(AA1(I).LE.0.) DWNFLG2(I) = .FALSE. - ENDDO -!! - TOTFLG = .TRUE. - DO I = 1, IM - TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I)) - ENDDO - IF(TOTFLG) RETURN -!! -C -C -C--- WHAT WOULD THE CHANGE BE, THAT A CLOUD WITH UNIT MASS -C--- WILL DO TO THE ENVIRONMENT? -C - DO K = 1, KM - DO I = 1, IM - IF(k .le. kmax(i) .and. CNVFLG(I)) THEN - DELLAH(I,k) = 0. - DELLAQ(I,k) = 0. - DELLAU(I,k) = 0. - DELLAV(I,k) = 0. - ENDIF - ENDDO - ENDDO - DO I = 1, IM - IF(CNVFLG(I)) THEN - DP = 1000. * DEL(I,1) - DELLAH(I,1) = EDTO(I) * ETAD(I,1) * (HCDO(I) - & - HEO(I,1)) * G / DP - DELLAQ(I,1) = EDTO(I) * ETAD(I,1) * (QCDO(I) - & - QO(I,1)) * G / DP - DELLAU(I,1) = EDTO(I) * ETAD(I,1) * (UCDO(I) - & - UO(I,1)) * G / DP - DELLAV(I,1) = EDTO(I) * ETAD(I,1) * (VCDO(I) - & - VO(I,1)) * G / DP - ENDIF - ENDDO -C -C--- CHANGED DUE TO SUBSIDENCE AND ENTRAINMENT -C - DO K = 2, KM1 - DO I = 1, IM - if (k .le. kmax(i)-1) then - IF(CNVFLG(I).AND.K.LT.KTCON(I)) THEN - AUP = 1. - IF(K.LE.KB(I)) AUP = 0. - ADW = 1. - IF(K.GT.JMIN(I)) ADW = 0. - DV1= HEO(I,k) - DV2 = .5 * (HEO(I,k) + HEO(I,k+1)) - DV3= HEO(I,k-1) - DV1Q= QO(I,k) - DV2Q = .5 * (QO(I,k) + QO(I,k+1)) - DV3Q= QO(I,k-1) - DV1U= UO(I,k) - DV2U = .5 * (UO(I,k) + UO(I,k+1)) - DV3U= UO(I,k-1) - DV1V= VO(I,k) - DV2V = .5 * (VO(I,k) + VO(I,k+1)) - DV3V= VO(I,k-1) - DP = 1000. * DEL(I,K) - DZ = .5 * (ZO(I,k+1) - ZO(I,k-1)) - DETA = ETA(I,k) - ETA(I,k-1) - DETAD = ETAD(I,k) - ETAD(I,k-1) - DELLAH(I,k) = DELLAH(I,k) + - & ((AUP * ETA(I,k) - ADW * EDTO(I) * ETAD(I,k)) * DV1 - & - (AUP * ETA(I,k-1) - ADW * EDTO(I) * ETAD(I,k-1))* DV3 - & - AUP * DETA * DV2 - & + ADW * EDTO(I) * DETAD * HCDO(I)) * G / DP - DELLAQ(I,k) = DELLAQ(I,k) + - & ((AUP * ETA(I,k) - ADW * EDTO(I) * ETAD(I,k)) * DV1Q - & - (AUP * ETA(I,k-1) - ADW * EDTO(I) * ETAD(I,k-1))* DV3Q - & - AUP * DETA * DV2Q - & +ADW*EDTO(I)*DETAD*.5*(QRCDO(I,k)+QRCDO(I,k-1))) * G / DP - DELLAU(I,k) = DELLAU(I,k) + - & ((AUP * ETA(I,k) - ADW * EDTO(I) * ETAD(I,k)) * DV1U - & - (AUP * ETA(I,k-1) - ADW * EDTO(I) * ETAD(I,k-1))* DV3U - & - AUP * DETA * DV2U - & + ADW * EDTO(I) * DETAD * UCDO(I) - & ) * G / DP - DELLAV(I,k) = DELLAV(I,k) + - & ((AUP * ETA(I,k) - ADW * EDTO(I) * ETAD(I,k)) * DV1V - & - (AUP * ETA(I,k-1) - ADW * EDTO(I) * ETAD(I,k-1))* DV3V - & - AUP * DETA * DV2V - & + ADW * EDTO(I) * DETAD * VCDO(I) - & ) * G / DP - ENDIF - endif - ENDDO - ENDDO -C -C------- CLOUD TOP -C - DO I = 1, IM - IF(CNVFLG(I)) THEN - INDX = KTCON(I) - DP = 1000. * DEL(I,INDX) - DV1 = HEO(I,INDX-1) - DELLAH(I,INDX) = ETA(I,INDX-1) * - & (HCKO(I,INDX-1) - DV1) * G / DP - DVQ1 = QO(I,INDX-1) - DELLAQ(I,INDX) = ETA(I,INDX-1) * - & (QCKO(I,INDX-1) - DVQ1) * G / DP - DV1U = UO(I,INDX-1) - DELLAU(I,INDX) = ETA(I,INDX-1) * - & (UCKO(I,INDX-1) - DV1U) * G / DP - DV1V = VO(I,INDX-1) - DELLAV(I,INDX) = ETA(I,INDX-1) * - & (VCKO(I,INDX-1) - DV1V) * G / DP -c -c cloud water -c - DELLAL(I) = ETA(I,INDX-1) * QLKO_KTCON(I) * g / dp - ENDIF - ENDDO -C -C------- FINAL CHANGED VARIABLE PER UNIT MASS FLUX -C - DO K = 1, KM - DO I = 1, IM - if (k .le. kmax(i)) then - IF(CNVFLG(I).and.k.gt.KTCON(I)) THEN - QO(I,k) = Q1(I,k) - TO(I,k) = T1(I,k) - UO(I,k) = U1(I,k) - VO(I,k) = V1(I,k) - ENDIF - IF(CNVFLG(I).AND.K.LE.KTCON(I)) THEN - QO(I,k) = DELLAQ(I,k) * MBDT + Q1(I,k) - DELLAT = (DELLAH(I,k) - HVAP * DELLAQ(I,k)) / CP - TO(I,k) = DELLAT * MBDT + T1(I,k) - val = 1.e-10 - QO(I,k) = max(QO(I,k), val ) - ENDIF - endif - ENDDO - ENDDO -C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -C -C--- THE ABOVE CHANGED ENVIRONMENT IS NOW USED TO CALULATE THE -C--- EFFECT THE ARBITRARY CLOUD (WITH UNIT MASS FLUX) -C--- WOULD HAVE ON THE STABILITY, -C--- WHICH THEN IS USED TO CALCULATE THE REAL MASS FLUX, -C--- NECESSARY TO KEEP THIS CHANGE IN BALANCE WITH THE LARGE-SCALE -C--- DESTABILIZATION. -C -C--- ENVIRONMENTAL CONDITIONS AGAIN, FIRST HEIGHTS -C - DO K = 1, KM - DO I = 1, IM - IF(k .le. kmax(i) .and. CNVFLG(I)) THEN -!jfe QESO(I,k) = 10. * FPVS(TO(I,k)) -! - QESO(I,k) = 0.01 * fpvs(TO(I,K)) ! fpvs is in Pa -! - QESO(I,k) = EPS * QESO(I,k) / (PFLD(I,k)+EPSM1*QESO(I,k)) - val = 1.E-8 - QESO(I,k) = MAX(QESO(I,k), val ) - TVO(I,k) = TO(I,k) + DELTA * TO(I,k) * QO(I,k) - ENDIF - ENDDO - ENDDO - DO I = 1, IM - IF(CNVFLG(I)) THEN - XAA0(I) = 0. - XPWAV(I) = 0. - ENDIF - ENDDO -C -C HYDROSTATIC HEIGHT ASSUME ZERO TERR -C -! DO I = 1, IM -! IF(CNVFLG(I)) THEN -! DLNSIG = LOG(PRSL(I,1)/PS(I)) -! ZO(I,1) = TERR - DLNSIG * RD / G * TVO(I,1) -! ENDIF -! ENDDO -! DO K = 2, KM -! DO I = 1, IM -! IF(k .le. kmax(i) .and. CNVFLG(I)) THEN -! DLNSIG = LOG(PRSL(I,K) / PRSL(I,K-1)) -! ZO(I,k) = ZO(I,k-1) - DLNSIG * RD / G -! & * .5 * (TVO(I,k) + TVO(I,k-1)) -! ENDIF -! ENDDO -! ENDDO -C -C--- MOIST STATIC ENERGY -C - DO K = 1, KM1 - DO I = 1, IM - IF(k .le. kmax(i)-1 .and. CNVFLG(I)) THEN - DZ = .5 * (ZO(I,k+1) - ZO(I,k)) - DP = .5 * (PFLD(I,k+1) - PFLD(I,k)) -cjfe ES = 10. * FPVS(TO(I,k+1)) -! - ES = 0.01 * fpvs(TO(I,K+1)) ! fpvs is in Pa -! - PPRIME = PFLD(I,k+1) + EPSM1 * ES - QS = EPS * ES / PPRIME - DQSDP = - QS / PPRIME - DESDT = ES * (FACT1 / TO(I,k+1) + FACT2 / (TO(I,k+1)**2)) - DQSDT = QS * PFLD(I,k+1) * DESDT / (ES * PPRIME) - GAMMA = EL2ORC * QESO(I,k+1) / (TO(I,k+1)**2) - DT = (G * DZ + HVAP * DQSDP * DP) / (CP * (1. + GAMMA)) - DQ = DQSDT * DT + DQSDP * DP - TO(I,k) = TO(I,k+1) + DT - QO(I,k) = QO(I,k+1) + DQ - PO(I,k) = .5 * (PFLD(I,k) + PFLD(I,k+1)) - ENDIF - ENDDO - ENDDO - DO K = 1, KM1 - DO I = 1, IM - IF(k .le. kmax(i)-1 .and. CNVFLG(I)) THEN -cjfe QESO(I,k) = 10. * FPVS(TO(I,k)) -! - QESO(I,k) = 0.01 * fpvs(TO(I,K)) ! fpvs is in Pa -! - QESO(I,k) = EPS * QESO(I,k) / (PO(I,k) + EPSM1 * QESO(I,k)) - val1 = 1.E-8 - QESO(I,k) = MAX(QESO(I,k), val1) - val2 = 1.e-10 - QO(I,k) = max(QO(I,k), val2 ) -c QO(I,k) = MIN(QO(I,k),QESO(I,k)) - HEO(I,k) = .5 * G * (ZO(I,k) + ZO(I,k+1)) + - & CP * TO(I,k) + HVAP * QO(I,k) - HESO(I,k) = .5 * G * (ZO(I,k) + ZO(I,k+1)) + - & CP * TO(I,k) + HVAP * QESO(I,k) - ENDIF - ENDDO - ENDDO - DO I = 1, IM - k = kmax(i) - IF(CNVFLG(I)) THEN - HEO(I,k) = G * ZO(I,k) + CP * TO(I,k) + HVAP * QO(I,k) - HESO(I,k) = G * ZO(I,k) + CP * TO(I,k) + HVAP * QESO(I,k) -c HEO(I,k) = MIN(HEO(I,k),HESO(I,k)) - ENDIF - ENDDO - DO I = 1, IM - IF(CNVFLG(I)) THEN - INDX = KB(I) - XHKB(I) = HEO(I,INDX) - XQKB(I) = QO(I,INDX) - HCKO(I,INDX) = XHKB(I) - QCKO(I,INDX) = XQKB(I) - ENDIF - ENDDO -C -C -C**************************** STATIC CONTROL -C -C -C------- MOISTURE AND CLOUD WORK FUNCTIONS -C - DO K = 2, KM1 - DO I = 1, IM - if (k .le. kmax(i)-1) then -C IF(CNVFLG(I).AND.K.GT.KB(I).AND.K.LE.KBCON(I)) THEN - IF(CNVFLG(I).AND.K.GT.KB(I).AND.K.LE.KTCON(I)) THEN - FACTOR = ETA(I,k-1) / ETA(I,k) - ONEMF = 1. - FACTOR - HCKO(I,k) = FACTOR * HCKO(I,k-1) + ONEMF * - & .5 * (HEO(I,k) + HEO(I,k+1)) - ENDIF -C IF(CNVFLG(I).AND.K.GT.KBCON(I)) THEN -C HEO(I,k) = HEO(I,k-1) -C ENDIF - endif - ENDDO - ENDDO - DO K = 2, KM1 - DO I = 1, IM - if (k .le. kmax(i)-1) then - IF(CNVFLG(I).AND.K.GT.KB(I).AND.K.LT.KTCON(I)) THEN - DZ = .5 * (ZO(I,k+1) - ZO(I,k-1)) - GAMMA = EL2ORC * QESO(I,k) / (TO(I,k)**2) - XDBY = HCKO(I,k) - HESO(I,k) - val = 0. - XDBY = MAX(XDBY,val) - XQRCH = QESO(I,k) - & + GAMMA * XDBY / (HVAP * (1. + GAMMA)) - FACTOR = ETA(I,k-1) / ETA(I,k) - ONEMF = 1. - FACTOR - QCKO(I,k) = FACTOR * QCKO(I,k-1) + ONEMF * - & .5 * (QO(I,k) + QO(I,k+1)) - DQ = ETA(I,k) * QCKO(I,k) - ETA(I,k) * XQRCH - IF(DQ.GT.0.) THEN - ETAH = .5 * (ETA(I,k) + ETA(I,k-1)) - QLK = DQ / (ETA(I,k) + ETAH * C0 * DZ) - XAA0(I) = XAA0(I) - (ZO(I,k) - ZO(I,k-1)) * G * QLK - XQC = QLK + XQRCH - XPW = ETAH * C0 * DZ * QLK - QCKO(I,k) = XQC - XPWAV(I) = XPWAV(I) + XPW - ENDIF - ENDIF -c IF(CNVFLG(I).AND.K.GT.KBCON(I).AND.K.LT.KTCON(I)) THEN - IF(CNVFLG(I).AND.K.GT.KBCON(I).AND.K.LE.KTCON(I)) THEN - DZ1 = ZO(I,k) - ZO(I,k-1) - GAMMA = EL2ORC * QESO(I,k-1) / (TO(I,k-1)**2) - RFACT = 1. + DELTA * CP * GAMMA - & * TO(I,k-1) / HVAP - XDBY = HCKO(I,k-1) - HESO(I,k-1) - XAA0(I) = XAA0(I) - & + DZ1 * (G / (CP * TO(I,k-1))) - & * XDBY / (1. + GAMMA) - & * RFACT - val=0. - XAA0(I)=XAA0(I)+ - & DZ1 * G * DELTA * - & MAX(val,(QESO(I,k-1) - QO(I,k-1))) - ENDIF - endif - ENDDO - ENDDO -ccccc IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I)) THEN -ccccc PRINT *, ' XAA BEFORE DWNDRFT =', XAA0(I) -ccccc ENDIF -C -C------- DOWNDRAFT CALCULATIONS -C -C -C--- DOWNDRAFT MOISTURE PROPERTIES -C - DO I = 1, IM - XPWEV(I) = 0. - ENDDO - DO I = 1, IM - IF(DWNFLG2(I)) THEN - JMN = JMIN(I) - XHCD(I) = HEO(I,JMN) - XQCD(I) = QO(I,JMN) - QRCD(I,JMN) = QESO(I,JMN) - ENDIF - ENDDO - DO K = KM1, 1, -1 - DO I = 1, IM - if (k .le. kmax(i)-1) then - IF(DWNFLG2(I).AND.K.LT.JMIN(I)) THEN - DQ = QESO(I,k) - DT = TO(I,k) - GAMMA = EL2ORC * DQ / DT**2 - DH = XHCD(I) - HESO(I,k) - QRCD(I,k)=DQ+(1./HVAP)*(GAMMA/(1.+GAMMA))*DH - DETAD = ETAD(I,k+1) - ETAD(I,k) - XPWD = ETAD(I,k+1) * QRCD(I,k+1) - - & ETAD(I,k) * QRCD(I,k) - XPWD = XPWD - DETAD * - & .5 * (QRCD(I,k) + QRCD(I,k+1)) - XPWEV(I) = XPWEV(I) + XPWD - ENDIF - endif - ENDDO - ENDDO -C - DO I = 1, IM - edtmax = edtmaxl - if(SLIMSK(I).eq.0.) edtmax = edtmaxs - IF(DWNFLG2(I)) THEN - IF(XPWEV(I).GE.0.) THEN - EDTX(I) = 0. - ELSE - EDTX(I) = -EDTX(I) * XPWAV(I) / XPWEV(I) - EDTX(I) = MIN(EDTX(I),EDTMAX) - ENDIF - ELSE - EDTX(I) = 0. - ENDIF - ENDDO -C -C -C -C--- DOWNDRAFT CLOUDWORK FUNCTIONS -C -C - DO K = KM1, 1, -1 - DO I = 1, IM - if (k .le. kmax(i)-1) then - IF(DWNFLG2(I).AND.K.LT.JMIN(I)) THEN - GAMMA = EL2ORC * QESO(I,k+1) / TO(I,k+1)**2 - DHH=XHCD(I) - DT= TO(I,k+1) - DG= GAMMA - DH= HESO(I,k+1) - DZ=-1.*(ZO(I,k+1)-ZO(I,k)) - XAA0(I)=XAA0(I)+EDTX(I)*DZ*(G/(CP*DT))*((DHH-DH)/(1.+DG)) - & *(1.+DELTA*CP*DG*DT/HVAP) - val=0. - XAA0(I)=XAA0(I)+EDTX(I)* - & DZ*G*DELTA*MAX(val,(QESO(I,k+1)-QO(I,k+1))) - ENDIF - endif - ENDDO - ENDDO -ccccc IF(LAT.EQ.LATD.AND.lon.eq.lond.and.DWNFLG2(I)) THEN -ccccc PRINT *, ' XAA AFTER DWNDRFT =', XAA0(I) -ccccc ENDIF -C -C CALCULATE CRITICAL CLOUD WORK FUNCTION -C - DO I = 1, IM - ACRT(I) = 0. - IF(CNVFLG(I)) THEN -C IF(CNVFLG(I).AND.SLIMSK(I).NE.1.) THEN - IF(PFLD(I,KTCON(I)).LT.PCRIT(15))THEN - ACRT(I)=ACRIT(15)*(975.-PFLD(I,KTCON(I))) - & /(975.-PCRIT(15)) - ELSE IF(PFLD(I,KTCON(I)).GT.PCRIT(1))THEN - ACRT(I)=ACRIT(1) - ELSE - K = int((850. - PFLD(I,KTCON(I)))/50.) + 2 - K = MIN(K,15) - K = MAX(K,2) - ACRT(I)=ACRIT(K)+(ACRIT(K-1)-ACRIT(K))* - * (PFLD(I,KTCON(I))-PCRIT(K))/(PCRIT(K-1)-PCRIT(K)) - ENDIF -C ELSE -C ACRT(I) = .5 * (PFLD(I,KBCON(I)) - PFLD(I,KTCON(I))) - ENDIF - ENDDO - DO I = 1, IM - ACRTFCT(I) = 1. - IF(CNVFLG(I)) THEN - if(SLIMSK(I).eq.1.) THEN - w1 = w1l - w2 = w2l - w3 = w3l - w4 = w4l - else - w1 = w1s - w2 = w2s - w3 = w3s - w4 = w4s - ENDIF -C IF(CNVFLG(I).AND.SLIMSK(I).EQ.1.) THEN -C ACRTFCT(I) = PDOT(I) / W3 -c -c modify critical cloud workfunction by cloud base vertical velocity -c - IF(PDOT(I).LE.W4) THEN - ACRTFCT(I) = (PDOT(I) - W4) / (W3 - W4) - ELSEIF(PDOT(I).GE.-W4) THEN - ACRTFCT(I) = - (PDOT(I) + W4) / (W4 - W3) - ELSE - ACRTFCT(I) = 0. - ENDIF - val1 = -1. - ACRTFCT(I) = MAX(ACRTFCT(I),val1) - val2 = 1. - ACRTFCT(I) = MIN(ACRTFCT(I),val2) - ACRTFCT(I) = 1. - ACRTFCT(I) -c -c modify ACRTFCT(I) by colume mean rh if RHBAR(I) is greater than 80 percent -c -c if(RHBAR(I).ge..8) THEN -c ACRTFCT(I) = ACRTFCT(I) * (.9 - min(RHBAR(I),.9)) * 10. -c ENDIF -c -c modify adjustment time scale by cloud base vertical velocity -c - DTCONV(I) = DT2 + max((1800. - DT2),cons_0) * - & (PDOT(I) - W2) / (W1 - W2) -c DTCONV(I) = MAX(DTCONV(I), DT2) -c DTCONV(I) = 1800. * (PDOT(I) - w2) / (w1 - w2) - DTCONV(I) = max(DTCONV(I),dtmin) - DTCONV(I) = min(DTCONV(I),dtmax) - - ENDIF - ENDDO -C -C--- LARGE SCALE FORCING -C - DO I= 1, IM - FLG(I) = CNVFLG(I) - IF(CNVFLG(I)) THEN -C F = AA1(I) / DTCONV(I) - FLD(I) = (AA1(I) - ACRT(I) * ACRTFCT(I)) / DTCONV(I) - IF(FLD(I).LE.0.) FLG(I) = .FALSE. - ENDIF - CNVFLG(I) = FLG(I) - IF(CNVFLG(I)) THEN -C XAA0(I) = MAX(XAA0(I),0.) - XK(I) = (XAA0(I) - AA1(I)) / MBDT - IF(XK(I).GE.0.) FLG(I) = .FALSE. - ENDIF -C -C--- KERNEL, CLOUD BASE MASS FLUX -C - CNVFLG(I) = FLG(I) - IF(CNVFLG(I)) THEN - XMB(I) = -FLD(I) / XK(I) - XMB(I) = MIN(XMB(I),XMBMAX(I)) - ENDIF - ENDDO -c IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I)) THEN -c print *, ' RHBAR(I), ACRTFCT(I) =', RHBAR(I), ACRTFCT(I) -c PRINT *, ' A1, XA =', AA1(I), XAA0(I) -c PRINT *, ' XMB(I), ACRT =', XMB(I), ACRT -c ENDIF - TOTFLG = .TRUE. - DO I = 1, IM - TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I)) - ENDDO - IF(TOTFLG) RETURN -c -c restore t0 and QO to t1 and q1 in case convection stops -c - do k = 1, km - DO I = 1, IM - if (k .le. kmax(i)) then - TO(I,k) = T1(I,k) - QO(I,k) = Q1(I,k) -!jfe QESO(I,k) = 10. * FPVS(T1(I,k)) -! - QESO(I,k) = 0.01 * fpvs(T1(I,K)) ! fpvs is in Pa -! - QESO(I,k) = EPS * QESO(I,k) / (PFLD(I,k) + EPSM1*QESO(I,k)) - val = 1.E-8 - QESO(I,k) = MAX(QESO(I,k), val ) - endif - enddo - enddo -C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -C -C--- FEEDBACK: SIMPLY THE CHANGES FROM THE CLOUD WITH UNIT MASS FLUX -C--- MULTIPLIED BY THE MASS FLUX NECESSARY TO KEEP THE -C--- EQUILIBRIUM WITH THE LARGER-SCALE. -C - DO I = 1, IM - DELHBAR(I) = 0. - DELQBAR(I) = 0. - DELTBAR(I) = 0. - QCOND(I) = 0. - ENDDO - DO K = 1, KM - DO I = 1, IM - if (k .le. kmax(i)) then - IF(CNVFLG(I).AND.K.LE.KTCON(I)) THEN - AUP = 1. - IF(K.Le.KB(I)) AUP = 0. - ADW = 1. - IF(K.GT.JMIN(I)) ADW = 0. - DELLAT = (DELLAH(I,k) - HVAP * DELLAQ(I,k)) / CP - T1(I,k) = T1(I,k) + DELLAT * XMB(I) * DT2 - Q1(I,k) = Q1(I,k) + DELLAQ(I,k) * XMB(I) * DT2 - U1(I,k) = U1(I,k) + DELLAU(I,k) * XMB(I) * DT2 - V1(I,k) = V1(I,k) + DELLAV(I,k) * XMB(I) * DT2 - DP = 1000. * DEL(I,K) - DELHBAR(I) = DELHBAR(I) + DELLAH(I,k)*XMB(I)*DP/G - DELQBAR(I) = DELQBAR(I) + DELLAQ(I,k)*XMB(I)*DP/G - DELTBAR(I) = DELTBAR(I) + DELLAT*XMB(I)*DP/G - ENDIF - endif - ENDDO - ENDDO - DO K = 1, KM - DO I = 1, IM - if (k .le. kmax(i)) then - IF(CNVFLG(I).AND.K.LE.KTCON(I)) THEN -!jfe QESO(I,k) = 10. * FPVS(T1(I,k)) -! - QESO(I,k) = 0.01 * fpvs(T1(I,K)) ! fpvs is in Pa -! - QESO(I,k) = EPS * QESO(I,k)/(PFLD(I,k) + EPSM1*QESO(I,k)) - val = 1.E-8 - QESO(I,k) = MAX(QESO(I,k), val ) -c -c cloud water -c - if(ncloud.gt.0.and.cnvflg(i).and.k.eq.ktcon(i)) then - tem = dellal(i) * xmb(i) * dt2 - tem1 = max(0.0, min(1.0, (tcr-t1(i,k))*tcrf)) - if (ql(i,k,2) .gt. -999.0) then - ql(i,k,1) = ql(i,k,1) + tem * tem1 ! ice - ql(i,k,2) = ql(i,k,2) + tem *(1.0-tem1) ! water - else - ql(i,k,1) = ql(i,k,1) + tem - endif - dp = 1000. * del(i,k) - dellal(i) = dellal(i) * xmb(i) * dp / g - endif -! -! if(ncloud.gt.0.and.CNVFLG(I).and.k.eq.KTCON(I)) THEN -! QL(I,k) = QL(I,k) + DELLAL(I) * XMB(I) * dt2 -! dp = 1000. * del(i,k) -! DELLAL(I) = DELLAL(I) * XMB(I) * dp / g -! ENDIF -! - ENDIF - endif - ENDDO - ENDDO -c IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I) ) THEN -c PRINT *, ' DELHBAR, DELQBAR, DELTBAR =' -c PRINT *, DELHBAR, HVAP*DELQBAR, CP*DELTBAR -c PRINT *, ' DELLBAR =' -c PRINT 6003, HVAP*DELLbar -c PRINT *, ' DELLAQ =' -c PRINT 6003, (HVAP*DELLAQ(I,k)*XMB(I),K=1,KMAX) -c PRINT *, ' DELLAT =' -c PRINT 6003, (DELLAH(i,k)*XMB(I)-HVAP*DELLAQ(I,k)*XMB(I), -c & K=1,KMAX) -c ENDIF - DO I = 1, IM - RNTOT(I) = 0. - DELQEV(I) = 0. - DELQ2(I) = 0. - FLG(I) = CNVFLG(I) - ENDDO - DO K = KM, 1, -1 - DO I = 1, IM - if (k .le. kmax(i)) then - IF(CNVFLG(I).AND.K.LE.KTCON(I)) THEN - AUP = 1. - IF(K.Le.KB(I)) AUP = 0. - ADW = 1. - IF(K.GT.JMIN(I)) ADW = 0. - rain = AUP * PWO(I,k) + ADW * EDTO(I) * PWDO(I,k) - RNTOT(I) = RNTOT(I) + rain * XMB(I) * .001 * dt2 - ENDIF - endif - ENDDO - ENDDO - DO K = KM, 1, -1 - DO I = 1, IM - if (k .le. kmax(i)) then - DELTV(I) = 0. - DELQ(I) = 0. - QEVAP(I) = 0. - IF(CNVFLG(I).AND.K.LE.KTCON(I)) THEN - AUP = 1. - IF(K.Le.KB(I)) AUP = 0. - ADW = 1. - IF(K.GT.JMIN(I)) ADW = 0. - rain = AUP * PWO(I,k) + ADW * EDTO(I) * PWDO(I,k) - RN(I) = RN(I) + rain * XMB(I) * .001 * dt2 - ENDIF - IF(FLG(I).AND.K.LE.KTCON(I)) THEN - evef = EDT(I) * evfact - if(SLIMSK(I).eq.1.) evef=EDT(I) * evfactl -! if(SLIMSK(I).eq.1.) evef=.07 -c if(SLIMSK(I).ne.1.) evef = 0. - QCOND(I) = EVEF * (Q1(I,k) - QESO(I,k)) - & / (1. + EL2ORC * QESO(I,k) / T1(I,k)**2) - DP = 1000. * DEL(I,K) - IF(RN(I).GT.0..AND.QCOND(I).LT.0.) THEN - QEVAP(I) = -QCOND(I) * (1.-EXP(-.32*SQRT(DT2*RN(I)))) - QEVAP(I) = MIN(QEVAP(I), RN(I)*1000.*G/DP) - DELQ2(I) = DELQEV(I) + .001 * QEVAP(I) * dp / g - ENDIF - if(RN(I).gt.0..and.QCOND(I).LT.0..and. - & DELQ2(I).gt.RNTOT(I)) THEN - QEVAP(I) = 1000.* g * (RNTOT(I) - DELQEV(I)) / dp - FLG(I) = .false. - ENDIF - IF(RN(I).GT.0..AND.QEVAP(I).gt.0.) THEN - Q1(I,k) = Q1(I,k) + QEVAP(I) - T1(I,k) = T1(I,k) - ELOCP * QEVAP(I) - RN(I) = RN(I) - .001 * QEVAP(I) * DP / G - DELTV(I) = - ELOCP*QEVAP(I)/DT2 - DELQ(I) = + QEVAP(I)/DT2 - DELQEV(I) = DELQEV(I) + .001*dp*QEVAP(I)/g - ENDIF - DELLAQ(I,k) = DELLAQ(I,k) + DELQ(I) / XMB(I) - DELQBAR(I) = DELQBAR(I) + DELQ(I)*DP/G - DELTBAR(I) = DELTBAR(I) + DELTV(I)*DP/G - ENDIF - endif - ENDDO - ENDDO -c IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I) ) THEN -c PRINT *, ' DELLAH =' -c PRINT 6003, (DELLAH(k)*XMB(I),K=1,KMAX) -c PRINT *, ' DELLAQ =' -c PRINT 6003, (HVAP*DELLAQ(I,k)*XMB(I),K=1,KMAX) -c PRINT *, ' DELHBAR, DELQBAR, DELTBAR =' -c PRINT *, DELHBAR, HVAP*DELQBAR, CP*DELTBAR -c PRINT *, ' PRECIP =', HVAP*RN(I)*1000./DT2 -CCCCC PRINT *, ' DELLBAR =' -CCCCC PRINT *, HVAP*DELLbar -c ENDIF -C -C PRECIPITATION RATE CONVERTED TO ACTUAL PRECIP -C IN UNIT OF M INSTEAD OF KG -C - DO I = 1, IM - IF(CNVFLG(I)) THEN -C -C IN THE EVENT OF UPPER LEVEL RAIN EVAPORATION AND LOWER LEVEL DOWNDRAF -C MOISTENING, RN CAN BECOME NEGATIVE, IN THIS CASE, WE BACK OUT OF TH -C HEATING AND THE MOISTENING -C - if(RN(I).lt.0..and..not.FLG(I)) RN(I) = 0. - IF(RN(I).LE.0.) THEN - RN(I) = 0. - ELSE - KTOP(I) = KTCON(I) - KBOT(I) = KBCON(I) - KUO(I) = 1 - CLDWRK(I) = AA1(I) - ENDIF - ENDIF - ENDDO - DO K = 1, KM - DO I = 1, IM - if (k .le. kmax(i)) then - IF(CNVFLG(I).AND.RN(I).LE.0.) THEN - T1(I,k) = TO(I,k) - Q1(I,k) = QO(I,k) - ENDIF - endif - ENDDO - ENDDO -! hchuang code change [+24L] - DO K = 1, KM - DO I = 1, IM - IF(CNVFLG(I).AND.RN(I).gt.0.) THEN - if(k.ge.kb(i) .and. k.lt.ktop(i)) then - ud_mf(i,k) = eta(i,k) * xmb(i) * dt2 - endif - endif - ENDDO - ENDDO - DO I = 1, IM - IF(CNVFLG(I).AND.RN(I).gt.0.) THEN - k = ktop(i)-1 - dt_mf(i,k) = ud_mf(i,k) - endif - ENDDO - DO K = 1, KM - DO I = 1, IM - IF(CNVFLG(I).AND.RN(I).gt.0.) THEN - if(k.ge.1 .and. k.le.jmin(i)) then - dd_mf(i,k) = edto(i) * etad(i,k) * xmb(i) * dt2 - endif - endif - ENDDO - ENDDO -!! - RETURN - END diff --git a/src/fim/FIMsrc/fim/column/sascnvn_v.f b/src/fim/FIMsrc/fim/column/sascnvn_v.f deleted file mode 100755 index ac94b24..0000000 --- a/src/fim/FIMsrc/fim/column/sascnvn_v.f +++ /dev/null @@ -1,1814 +0,0 @@ - subroutine sascnvn(im,ix,km,jcap,delt,del,prsl,ps, - & phil,ql, - & q1,t1,u1,v1,rcs,cldwrk,rn,kbot,ktop,kcnv,slimsk, - & dot,ncloud,ud_mf,dd_mf,dt_mf,sdiaga,sdiagb) -! & dot,ncloud,ud_mf,dd_mf,dt_mf,me) -! - use machine , only : kind_phys - use funcphys , only : fpvs - use physcons, grav => con_g, cp => con_cp, hvap => con_hvap - &, rv => con_rv, fv => con_fvirt, t0c => con_t0c - &, cvap => con_cvap, cliq => con_cliq - &, eps => con_eps, epsm1 => con_epsm1 - implicit none -! - integer im, ix, km, jcap, ncloud, - & kbot(im), ktop(im), kcnv(im) -! &, me - real(kind=kind_phys) delt - real(kind=kind_phys) ps(im), del(ix,km), prsl(ix,km), - & ql(ix,km,2),q1(ix,km), t1(ix,km), - & u1(ix,km), v1(ix,km), rcs(im), - & cldwrk(im), rn(im), slimsk(im), - & dot(ix,km), phil(ix,km) -! hchuang code change mass flux output - &, ud_mf(im,km),dd_mf(im,km),dt_mf(im,km) -! - integer i, j, indx, jmn, k, kk, latd, lond, km1 -! - real(kind=kind_phys) clam, cxlamu, xlamde, xlamdd -! - real(kind=kind_phys) adw, aup, aafac, - & beta, betal, betas, - & c0, cpoel, dellat, delta, - & desdt, deta, detad, dg, - & dh, dhh, dlnsig, dp, - & dq, dqsdp, dqsdt, dt, - & dt2, dtmax, dtmin, dv1h, - & dv1q, dv2h, dv2q, dv1u, - & dv1v, dv2u, dv2v, dv3q, - & dv3h, dv3u, dv3v, dzmax, - & dz, dz1, e1, edtmax, - & edtmaxl, edtmaxs, el2orc, elocp, - & es, etah, cthk, dthk, - & evef, evfact, evfactl, fact1, - & fact2, factor, fjcap, fkm, - & g, gamma, pprime, - & qlk, qrch, qs, c1, - & rain, rfact, shear, tem1, - & tem2, terr, val, val1, - & val2, w1, w1l, w1s, - & w2, w2l, w2s, w3, - & w3l, w3s, w4, w4l, - & w4s, xdby, xpw, xpwd, - & xqrch, mbdt, tem, - & ptem, ptem1, pgcon -! - integer kb(im), kbcon(im), kbcon1(im), - & ktcon(im), ktcon1(im), - & jmin(im), lmin(im), kbmax(im), - & kbm(im), kmax(im) -! - real(kind=kind_phys) aa1(im), acrt(im), acrtfct(im), - & delhbar(im), delq(im), delq2(im), - & delqbar(im), delqev(im), deltbar(im), - & deltv(im), dtconv(im), edt(im), - & edto(im), edtx(im), fld(im), - & hcdo(im,km), hmax(im), hmin(im), - & ucdo(im,km), vcdo(im,km),aa2(im), - & pbcdif(im), pdot(im), po(im,km), - & pwavo(im), pwevo(im), xlamud(im), - & qcdo(im,km), qcond(im), qevap(im), - & rntot(im), vshear(im), xaa0(im), - & xk(im), xlamd(im), - & xmb(im), xmbmax(im), xpwav(im), - & xpwev(im), delubar(im),delvbar(im) -cj - real(kind=kind_phys) cincr, cincrmax, cincrmin -cj -c physical parameters - parameter(g=grav) - parameter(cpoel=cp/hvap,elocp=hvap/cp, - & el2orc=hvap*hvap/(rv*cp)) - parameter(terr=0.,c0=.002,c1=.002,delta=fv) - parameter(fact1=(cvap-cliq)/rv,fact2=hvap/rv-fact1*t0c) - parameter(cthk=150.,cincrmax=180.,cincrmin=120.,dthk=25.) -c local variables and arrays - real(kind=kind_phys) pfld(im,km), to(im,km), qo(im,km), - & uo(im,km), vo(im,km), qeso(im,km) -c cloud water - real(kind=kind_phys) qlko_ktcon(im), dellal(im,km), tvo(im,km), - & dbyo(im,km), zo(im,km), xlamue(im,km), - & fent1(im,km), fent2(im,km), frh(im,km), - & heo(im,km), heso(im,km), - & qrcd(im,km), dellah(im,km), dellaq(im,km), - & dellau(im,km), dellav(im,km), hcko(im,km), - & ucko(im,km), vcko(im,km), qcko(im,km), - & eta(im,km), etad(im,km), zi(im,km), - & qrcdo(im,km), pwo(im,km), pwdo(im,km), - & tx1(im), sumx(im), sdiaga(im,km), - & sdiagb(im,km) -! &, rhbar(im) -! - logical totflg, cnvflg(im), flg(im) -! - real(kind=kind_phys) pcrit(15), acritt(15), acrit(15) -! save pcrit, acritt - data pcrit/850.,800.,750.,700.,650.,600.,550.,500.,450.,400., - & 350.,300.,250.,200.,150./ - data acritt/.0633,.0445,.0553,.0664,.075,.1082,.1521,.2216, - & .3151,.3677,.41,.5255,.7663,1.1686,1.6851/ -c gdas derived acrit -c data acritt/.203,.515,.521,.566,.625,.665,.659,.688, -c & .743,.813,.886,.947,1.138,1.377,1.896/ - real(kind=kind_phys) tf, tcr, tcrf - parameter (tf=233.16, tcr=263.16, tcrf=1.0/(tcr-tf)) -! -c----------------------------------------------------------------------- -! - km1 = km - 1 - dzmax = 0.0 -c -c initialize arrays -c - do i=1,im - cnvflg(i) = .true. - rn(i)=0. - kbot(i)=km+1 - ktop(i)=0 - kbcon(i)=km - ktcon(i)=1 - dtconv(i) = 3600. - cldwrk(i) = 0. - pdot(i) = 0. - pbcdif(i)= 0. - lmin(i) = 1 - jmin(i) = 1 - qlko_ktcon(i) = 0. - edt(i) = 0. - edto(i) = 0. - edtx(i) = 0. - acrt(i) = 0. - acrtfct(i) = 1. - aa1(i) = 0. - aa2(i) = 0. - xaa0(i) = 0. - pwavo(i)= 0. - pwevo(i)= 0. - xpwav(i)= 0. - xpwev(i)= 0. - vshear(i) = 0. - enddo -! hchuang code change - do k = 1, km - do i = 1, im - ud_mf(i,k) = 0. - dd_mf(i,k) = 0. - dt_mf(i,k) = 0. - enddo - enddo -c - do k = 1, 15 - acrit(k) = acritt(k) * (975. - pcrit(k)) - enddo - dt2 = delt - val = 1200. - dtmin = max(dt2, val ) - val = 3600. - dtmax = max(dt2, val ) -c model tunable parameters are all here - mbdt = 10. - edtmaxl = .3 - edtmaxs = .3 - clam = .1 - aafac = .1 -! betal = .15 -! betas = .15 - betal = .05 - betas = .05 -c evef = 0.07 - evfact = 0.3 - evfactl = 0.3 -! - cxlamu = 1.0e-4 - xlamde = 1.0e-4 - xlamdd = 1.0e-4 -! -! pgcon = 0.7 ! Gregory et al. (1997, QJRMS) - pgcon = 0.55 ! Zhang & Wu (2003,JAS) - fjcap = (float(jcap) / 126.) ** 2 - val = 1. - fjcap = max(fjcap,val) - fkm = (float(km) / 28.) ** 2 - fkm = max(fkm,val) - w1l = -8.e-3 - w2l = -4.e-2 - w3l = -5.e-3 - w4l = -5.e-4 - w1s = -2.e-4 - w2s = -2.e-3 - w3s = -1.e-3 - w4s = -2.e-5 -c -c define top layer for search of the downdraft originating layer -c and the maximum thetae for updraft -c - do i=1,im - kbmax(i) = km - kbm(i) = km - kmax(i) = km - tx1(i) = 1.0 / ps(i) - enddo -! - do k = 1, km - do i=1,im -! jbao / s.benjamin - change 9/6/2010 -!jbao if (ps(i).ge.600.) then - if (prsl(i,k)*tx1(i) .gt. 0.04) kmax(i) = k + 1 -!jbao else -!jbao if (prsl(i,k)*tx1(i) .gt. 0.20) kmax(i) = k + 1 -!jbao end if - - if (prsl(i,k)*tx1(i) .gt. 0.45) kbmax(i) = k + 1 - if (prsl(i,k)*tx1(i) .gt. 0.70) kbm(i) = k + 1 - enddo - enddo - do i=1,im - kbmax(i) = min(kbmax(i),kmax(i)) - kbm(i) = min(kbm(i),kmax(i)) - enddo -c -c hydrostatic height assume zero terr and initially assume -c updraft entrainment rate as an inverse function of height -c - do k = 1, km - do i=1,im - zo(i,k) = phil(i,k) / g - enddo - enddo - do k = 1, km1 - do i=1,im - zi(i,k) = 0.5*(zo(i,k)+zo(i,k+1)) - xlamue(i,k) = clam / zi(i,k) - enddo - enddo -c -c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -c convert surface pressure to mb from cb -c - do k = 1, km - do i = 1, im - if (k .le. kmax(i)) then - pfld(i,k) = prsl(i,k) * 10.0 - eta(i,k) = 1. - fent1(i,k)= 1. - fent2(i,k)= 1. - frh(i,k) = 0. - hcko(i,k) = 0. - qcko(i,k) = 0. - ucko(i,k) = 0. - vcko(i,k) = 0. - etad(i,k) = 1. - hcdo(i,k) = 0. - qcdo(i,k) = 0. - ucdo(i,k) = 0. - vcdo(i,k) = 0. - qrcd(i,k) = 0. - qrcdo(i,k)= 0. - dbyo(i,k) = 0. - pwo(i,k) = 0. - pwdo(i,k) = 0. - dellal(i,k) = 0. - to(i,k) = t1(i,k) - qo(i,k) = q1(i,k) - uo(i,k) = u1(i,k) * rcs(i) - vo(i,k) = v1(i,k) * rcs(i) - endif - enddo - enddo -c -c column variables -c p is pressure of the layer (mb) -c t is temperature at t-dt (k)..tn -c q is mixing ratio at t-dt (kg/kg)..qn -c to is temperature at t+dt (k)... this is after advection and turbulan -c qo is mixing ratio at t+dt (kg/kg)..q1 -c - do k = 1, km - do i=1,im - if (k .le. kmax(i)) then - qeso(i,k) = 0.01 * fpvs(to(i,k)) ! fpvs is in pa - qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k)) - val1 = 1.e-8 - qeso(i,k) = max(qeso(i,k), val1) - val2 = 1.e-10 - qo(i,k) = max(qo(i,k), val2 ) -! qo(i,k) = min(qo(i,k),qeso(i,k)) -! tvo(i,k) = to(i,k) + delta * to(i,k) * qo(i,k) - endif - enddo - enddo -c -c compute moist static energy -c - do k = 1, km - do i=1,im - if (k .le. kmax(i)) then -! tem = g * zo(i,k) + cp * to(i,k) - tem = phil(i,k) + cp * to(i,k) - heo(i,k) = tem + hvap * qo(i,k) - heso(i,k) = tem + hvap * qeso(i,k) -c heo(i,k) = min(heo(i,k),heso(i,k)) - endif - enddo - enddo -c -c determine level with largest moist static energy -c this is the level where updraft starts -c - do i=1,im - hmax(i) = heo(i,1) - kb(i) = 1 - enddo - do k = 2, km - do i=1,im - if (k .le. kbm(i)) then - if(heo(i,k).gt.hmax(i)) then - kb(i) = k - hmax(i) = heo(i,k) - endif - endif - enddo - enddo -c - do k = 1, km1 - do i=1,im - if (k .le. kmax(i)-1) then - dz = .5 * (zo(i,k+1) - zo(i,k)) - dzmax = max(dzmax, dz) - dp = .5 * (pfld(i,k+1) - pfld(i,k)) - es = 0.01 * fpvs(to(i,k+1)) ! fpvs is in pa - pprime = pfld(i,k+1) + epsm1 * es - qs = eps * es / pprime - dqsdp = - qs / pprime - desdt = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2)) - dqsdt = qs * pfld(i,k+1) * desdt / (es * pprime) - gamma = el2orc * qeso(i,k+1) / (to(i,k+1)**2) - dt = (g * dz + hvap * dqsdp * dp) / (cp * (1. + gamma)) - dq = dqsdt * dt + dqsdp * dp - to(i,k) = to(i,k+1) + dt - qo(i,k) = qo(i,k+1) + dq - po(i,k) = .5 * (pfld(i,k) + pfld(i,k+1)) - endif - enddo - enddo -! - do k = 1, km1 - do i=1,im - if (k .le. kmax(i)-1) then - qeso(i,k) = 0.01 * fpvs(to(i,k)) ! fpvs is in pa - qeso(i,k) = eps * qeso(i,k) / (po(i,k) + epsm1*qeso(i,k)) - val1 = 1.e-8 - qeso(i,k) = max(qeso(i,k), val1) - val2 = 1.e-10 - qo(i,k) = max(qo(i,k), val2 ) -! qo(i,k) = min(qo(i,k),qeso(i,k)) - frh(i,k) = 1. - min(qo(i,k)/qeso(i,k), 1.) - heo(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) + - & cp * to(i,k) + hvap * qo(i,k) - heso(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) + - & cp * to(i,k) + hvap * qeso(i,k) - uo(i,k) = .5 * (uo(i,k) + uo(i,k+1)) - vo(i,k) = .5 * (vo(i,k) + vo(i,k+1)) - endif - enddo - enddo -c -c look for the level of free convection as cloud base -c - do i=1,im - flg(i) = .true. - kbcon(i) = kmax(i) - enddo - do k = 1, km1 - do i=1,im - if (flg(i).and.k.le.kbmax(i)) then - if(k.gt.kb(i).and.heo(i,kb(i)).gt.heso(i,k)) then - kbcon(i) = k - flg(i) = .false. - endif - endif - enddo - enddo -c - do i=1,im - if(kbcon(i).eq.kmax(i)) cnvflg(i) = .false. - enddo -!! - totflg = .true. - do i=1,im - totflg = totflg .and. (.not. cnvflg(i)) - enddo - if(totflg) return -!! -c -c determine critical convective inhibition -c as a function of vertical velocity at cloud base. -c - do i=1,im - if(cnvflg(i)) then - pdot(i) = 10.* dot(i,kbcon(i)) - endif - enddo - do i=1,im - if(cnvflg(i)) then - if(slimsk(i).eq.1.) then - w1 = w1l - w2 = w2l - w3 = w3l - w4 = w4l - else - w1 = w1s - w2 = w2s - w3 = w3s - w4 = w4s - endif - if(pdot(i).le.w4) then - tem = (pdot(i) - w4) / (w3 - w4) - elseif(pdot(i).ge.-w4) then - tem = - (pdot(i) + w4) / (w4 - w3) - else - tem = 0. - endif - val1 = -1. - tem = max(tem,val1) - val2 = 1. - tem = min(tem,val2) - tem = 1. - tem - tem1= .5*(cincrmax-cincrmin) - cincr = cincrmax - tem * tem1 - pbcdif(i) = pfld(i,kb(i)) - pfld(i,kbcon(i)) - if(pbcdif(i).gt.cincr) then - cnvflg(i) = .false. - endif - endif - enddo -!! - totflg = .true. - do i=1,im - totflg = totflg .and. (.not. cnvflg(i)) - enddo - if(totflg) return -!! -c -c assume that updraft entrainment rate above cloud base is -c same as that at cloud base -c - do k = 2, km1 - do i=1,im - if(cnvflg(i).and. - & (k.gt.kbcon(i).and.k.lt.kmax(i))) then - xlamue(i,k) = xlamue(i,kbcon(i)) - endif - enddo - enddo -c -c assume the detrainment rate for the updrafts to be same as -c the entrainment rate at cloud base -c - do i = 1, im - if(cnvflg(i)) then - xlamud(i) = xlamue(i,kbcon(i)) - endif - enddo -c -c functions rapidly decreasing with height, mimicking a cloud ensemble -c (Bechtold et al., 2008) -c - do k = 2, km1 - do i=1,im - if(cnvflg(i).and. - & (k.gt.kbcon(i).and.k.lt.kmax(i))) then - tem = qeso(i,k)/qeso(i,kbcon(i)) - fent1(i,k) = tem**2 - fent2(i,k) = tem**3 - endif - enddo - enddo -c -c final entrainment rate as the sum of turbulent part and organized entrainment -c depending on the environmental relative humidity -c (Bechtold et al., 2008) -c - do k = 2, km1 - do i=1,im - if(cnvflg(i).and. - & (k.ge.kbcon(i).and.k.lt.kmax(i))) then - tem = cxlamu * frh(i,k) * fent2(i,k) - xlamue(i,k) = xlamue(i,k)*fent1(i,k) + tem - endif - enddo - enddo -c -c determine updraft mass flux for the subcloud layers -c - do k = 1, km1 - do i=1,im - ptem = xlamud(i) - 1/dzmax - xlamue(i,k) = max(xlamue(i,k), ptem) - enddo - enddo - do i=1,im - xlamue(i,km) = xlamue(i,km1) - enddo - do k = km1, 1, -1 - do i = 1, im - if (cnvflg(i)) then - if(k.lt.kbcon(i).and.k.ge.kb(i)) then - dz = zi(i,k+1) - zi(i,k) - ptem = 0.5*(xlamue(i,k)+xlamue(i,k+1))-xlamud(i) - eta(i,k) = eta(i,k+1) / (1. + ptem * dz) - endif - endif - enddo - enddo -c -c compute mass flux above cloud base -c - do k = 2, km1 - do i = 1, im - if(cnvflg(i))then - if(k.gt.kbcon(i).and.k.lt.kmax(i)) then - dz = zi(i,k) - zi(i,k-1) - ptem = 0.5*(xlamue(i,k)+xlamue(i,k-1))-xlamud(i) - eta(i,k) = eta(i,k-1) * (1 + ptem * dz) - endif - endif - enddo - enddo -c -c compute updraft cloud properties -c - do i = 1, im - if(cnvflg(i)) then - indx = kb(i) - hcko(i,indx) = heo(i,indx) - ucko(i,indx) = uo(i,indx) - vcko(i,indx) = vo(i,indx) - pwavo(i) = 0. - endif - enddo -c -c cloud property is modified by the entrainment process -c - do k = 2, km1 - do i = 1, im - if (cnvflg(i)) then - if(k.gt.kb(i).and.k.lt.kmax(i)) then - dz = zi(i,k) - zi(i,k-1) - tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz - tem1 = 0.5 * xlamud(i) * dz - factor = 1. + tem - tem1 - ptem = 0.5 * tem + pgcon - ptem1= 0.5 * tem - pgcon - hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5* - & (heo(i,k)+heo(i,k-1)))/factor - ucko(i,k) = ((1.-tem1)*ucko(i,k-1)+ptem*uo(i,k) - & +ptem1*uo(i,k-1))/factor - vcko(i,k) = ((1.-tem1)*vcko(i,k-1)+ptem*vo(i,k) - & +ptem1*vo(i,k-1))/factor - dbyo(i,k) = hcko(i,k) - heso(i,k) - endif - endif - enddo - enddo -c -c taking account into convection inhibition due to existence of -c dry layers below cloud base -c - do i=1,im - flg(i) = cnvflg(i) - kbcon1(i) = kmax(i) - enddo - do k = 2, km1 - do i=1,im - if (flg(i).and.k.lt.kmax(i)) then - if(k.ge.kbcon(i).and.dbyo(i,k).gt.0.) then - kbcon1(i) = k - flg(i) = .false. - endif - endif - enddo - enddo - do i=1,im - if(cnvflg(i)) then - if(kbcon1(i).eq.kmax(i)) cnvflg(i) = .false. - endif - enddo - do i=1,im - if(cnvflg(i)) then - tem = pfld(i,kbcon(i)) - pfld(i,kbcon1(i)) - if(tem.gt.dthk) then - cnvflg(i) = .false. - endif - endif - enddo -!! - totflg = .true. - do i = 1, im - totflg = totflg .and. (.not. cnvflg(i)) - enddo - if(totflg) return -!! -c -c determine first guess cloud top as the level of zero buoyancy -c - do i = 1, im - flg(i) = cnvflg(i) - ktcon(i) = 1 - enddo - do k = 2, km1 - do i = 1, im - if (flg(i).and.k .lt. kmax(i)) then - if(k.gt.kbcon1(i).and.dbyo(i,k).lt.0.) then - ktcon(i) = k - flg(i) = .false. - endif - endif - enddo - enddo -c - do i = 1, im - if(cnvflg(i)) then - tem = pfld(i,kbcon(i))-pfld(i,ktcon(i)) - if(tem.lt.cthk) cnvflg(i) = .false. - endif - enddo -!! - totflg = .true. - do i = 1, im - totflg = totflg .and. (.not. cnvflg(i)) - enddo - if(totflg) return -!! -c -c search for downdraft originating level above theta-e minimum -c - do i = 1, im - if(cnvflg(i)) then - hmin(i) = heo(i,kbcon1(i)) - lmin(i) = kbmax(i) - jmin(i) = kbmax(i) - endif - enddo - do k = 2, km1 - do i = 1, im - if (cnvflg(i) .and. k .le. kbmax(i)) then - if(k.gt.kbcon1(i).and.heo(i,k).lt.hmin(i)) then - lmin(i) = k + 1 - hmin(i) = heo(i,k) - endif - endif - enddo - enddo -c -c make sure that jmin(i) is within the cloud -c - do i = 1, im - if(cnvflg(i)) then - jmin(i) = min(lmin(i),ktcon(i)-1) - jmin(i) = max(jmin(i),kbcon1(i)+1) - if(jmin(i).ge.ktcon(i)) cnvflg(i) = .false. - endif - enddo -c -c specify upper limit of mass flux at cloud base -c - do i = 1, im - if(cnvflg(i)) then -! xmbmax(i) = .1 -! - k = kbcon(i) - dp = 1000. * del(i,k) - xmbmax(i) = dp / (g * dt2) -! -! tem = dp / (g * dt2) -! xmbmax(i) = min(tem, xmbmax(i)) - endif - enddo -c -c compute cloud moisture property and precipitation -c - do i = 1, im - if (cnvflg(i)) then - aa1(i) = 0. - qcko(i,kb(i)) = qo(i,kb(i)) -! rhbar(i) = 0. - endif - enddo - do k = 2, km1 - do i = 1, im - if (cnvflg(i)) then - if(k.gt.kb(i).and.k.lt.ktcon(i)) then - dz = zi(i,k) - zi(i,k-1) - gamma = el2orc * qeso(i,k) / (to(i,k)**2) - qrch = qeso(i,k) - & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) -cj - tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz - tem1 = 0.5 * xlamud(i) * dz - factor = 1. + tem - tem1 - qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* - & (qo(i,k)+qo(i,k-1)))/factor -cj - dq = eta(i,k) * (qcko(i,k) - qrch) -c -! rhbar(i) = rhbar(i) + qo(i,k) / qeso(i,k) -c -c check if there is excess moisture to release latent heat -c - if(k.ge.kbcon(i).and.dq.gt.0.) then - etah = .5 * (eta(i,k) + eta(i,k-1)) - if(ncloud.gt.0..and.k.gt.jmin(i)) then - dp = 1000. * del(i,k) - qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz) - dellal(i,k) = etah * c1 * dz * qlk * g / dp - else - qlk = dq / (eta(i,k) + etah * c0 * dz) - endif - aa1(i) = aa1(i) - dz * g * qlk - qcko(i,k) = qlk + qrch - pwo(i,k) = etah * c0 * dz * qlk - pwavo(i) = pwavo(i) + pwo(i,k) - endif - endif - endif - enddo - enddo -c -! do i = 1, im -! if(cnvflg(i)) then -! indx = ktcon(i) - kb(i) - 1 -! rhbar(i) = rhbar(i) / float(indx) -! endif -! enddo -c -c calculate cloud work function -c - do k = 2, km1 - do i = 1, im - if (cnvflg(i)) then - if(k.ge.kbcon(i).and.k.lt.ktcon(i)) then - dz1 = zo(i,k+1) - zo(i,k) - gamma = el2orc * qeso(i,k) / (to(i,k)**2) - rfact = 1. + delta * cp * gamma - & * to(i,k) / hvap - aa1(i) = aa1(i) + - & dz1 * (g / (cp * to(i,k))) - & * dbyo(i,k) / (1. + gamma) - & * rfact - val = 0. - aa1(i)=aa1(i)+ - & dz1 * g * delta * - & max(val,(qeso(i,k) - qo(i,k))) - endif - endif - enddo - enddo - do i = 1, im - if(cnvflg(i).and.aa1(i).le.0.) cnvflg(i) = .false. - enddo -!! - totflg = .true. - do i=1,im - totflg = totflg .and. (.not. cnvflg(i)) - enddo - if(totflg) return -!! -c -c estimate the onvective overshooting as the level -c where the [aafac * cloud work function] becomes zero, -c which is the final cloud top -c - do i = 1, im - if (cnvflg(i)) then - aa2(i) = aafac * aa1(i) - endif - enddo -c - do i = 1, im - flg(i) = cnvflg(i) - ktcon1(i) = kmax(i) - 1 - enddo - do k = 2, km1 - do i = 1, im - if (flg(i)) then - if(k.ge.ktcon(i).and.k.lt.kmax(i)) then - dz1 = zo(i,k+1) - zo(i,k) - gamma = el2orc * qeso(i,k) / (to(i,k)**2) - rfact = 1. + delta * cp * gamma - & * to(i,k) / hvap - aa2(i) = aa2(i) + - & dz1 * (g / (cp * to(i,k))) - & * dbyo(i,k) / (1. + gamma) - & * rfact - if(aa2(i).lt.0.) then - ktcon1(i) = k - flg(i) = .false. - endif - endif - endif - enddo - enddo -c -c compute cloud moisture property, detraining cloud water -c and precipitation in overshooting layers -c - do k = 2, km1 - do i = 1, im - if (cnvflg(i)) then - if(k.ge.ktcon(i).and.k.lt.ktcon1(i)) then - dz = zi(i,k) - zi(i,k-1) - gamma = el2orc * qeso(i,k) / (to(i,k)**2) - qrch = qeso(i,k) - & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) -cj - tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz - tem1 = 0.5 * xlamud(i) * dz - factor = 1. + tem - tem1 - qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* - & (qo(i,k)+qo(i,k-1)))/factor -cj - dq = eta(i,k) * (qcko(i,k) - qrch) -c -c check if there is excess moisture to release latent heat -c - if(dq.gt.0.) then - etah = .5 * (eta(i,k) + eta(i,k-1)) - if(ncloud.gt.0.) then - dp = 1000. * del(i,k) - qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz) - dellal(i,k) = etah * c1 * dz * qlk * g / dp - else - qlk = dq / (eta(i,k) + etah * c0 * dz) - endif - qcko(i,k) = qlk + qrch - pwo(i,k) = etah * c0 * dz * qlk - pwavo(i) = pwavo(i) + pwo(i,k) - endif - endif - endif - enddo - enddo -c -c exchange ktcon with ktcon1 -c - do i = 1, im - if(cnvflg(i)) then - kk = ktcon(i) - ktcon(i) = ktcon1(i) - ktcon1(i) = kk - endif - enddo -c -c this section is ready for cloud water -c - if(ncloud.gt.0) then -c -c compute liquid and vapor separation at cloud top -c - do i = 1, im - if(cnvflg(i)) then - k = ktcon(i) - 1 - gamma = el2orc * qeso(i,k) / (to(i,k)**2) - qrch = qeso(i,k) - & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) - dq = qcko(i,k) - qrch -c -c check if there is excess moisture to release latent heat -c - if(dq.gt.0.) then - qlko_ktcon(i) = dq - qcko(i,k) = qrch - endif - endif - enddo - endif -c -ccccc if(lat.eq.latd.and.lon.eq.lond.and.cnvflg(i)) then -ccccc print *, ' aa1(i) before dwndrft =', aa1(i) -ccccc endif -c -c------- downdraft calculations -c -c--- compute precipitation efficiency in terms of windshear -c - do i = 1, im - if(cnvflg(i)) then - vshear(i) = 0. - endif - enddo - do k = 2, km - do i = 1, im - if (cnvflg(i)) then - if(k.gt.kb(i).and.k.le.ktcon(i)) then - shear= sqrt((uo(i,k)-uo(i,k-1)) ** 2 - & + (vo(i,k)-vo(i,k-1)) ** 2) - vshear(i) = vshear(i) + shear - endif - endif - enddo - enddo - do i = 1, im - if(cnvflg(i)) then - vshear(i) = 1.e3 * vshear(i) / (zi(i,ktcon(i))-zi(i,kb(i))) - e1=1.591-.639*vshear(i) - & +.0953*(vshear(i)**2)-.00496*(vshear(i)**3) - edt(i)=1.-e1 - val = .9 - edt(i) = min(edt(i),val) - val = .0 - edt(i) = max(edt(i),val) - edto(i)=edt(i) - edtx(i)=edt(i) - endif - enddo -c -c determine detrainment rate between 1 and kbcon -c - do i = 1, im - if(cnvflg(i)) then - sumx(i) = 0. - endif - enddo - do k = 1, km1 - do i = 1, im - if(cnvflg(i).and.k.ge.1.and.k.lt.kbcon(i)) then - dz = zi(i,k+1) - zi(i,k) - sumx(i) = sumx(i) + dz - endif - enddo - enddo - do i = 1, im - beta = betas - if(slimsk(i).eq.1.) beta = betal - if(cnvflg(i)) then - dz = (sumx(i)+zi(i,1))/float(kbcon(i)) - tem = 1./float(kbcon(i)) - xlamd(i) = (1.-beta**tem)/dz - endif - enddo -c -c determine downdraft mass flux -c - do k = km1, 1, -1 - do i = 1, im - if (cnvflg(i) .and. k .le. kmax(i)-1) then - if(k.lt.jmin(i).and.k.ge.kbcon(i)) then - dz = zi(i,k+1) - zi(i,k) - ptem = xlamdd - xlamde - etad(i,k) = etad(i,k+1) * (1. - ptem * dz) - else if(k.lt.kbcon(i)) then - dz = zi(i,k+1) - zi(i,k) - ptem = xlamd(i) + xlamdd - xlamde - etad(i,k) = etad(i,k+1) * (1. - ptem * dz) - endif - endif - enddo - enddo -c -c--- downdraft moisture properties -c - do i = 1, im - if(cnvflg(i)) then - jmn = jmin(i) - hcdo(i,jmn) = heo(i,jmn) - qcdo(i,jmn) = qo(i,jmn) - qrcdo(i,jmn)= qeso(i,jmn) - ucdo(i,jmn) = uo(i,jmn) - vcdo(i,jmn) = vo(i,jmn) - pwevo(i) = 0. - endif - enddo -cj - do k = km1, 1, -1 - do i = 1, im - if (cnvflg(i) .and. k.lt.jmin(i)) then - dz = zi(i,k+1) - zi(i,k) - if(k.ge.kbcon(i)) then - tem = xlamde * dz - tem1 = 0.5 * xlamdd * dz - else - tem = xlamde * dz - tem1 = 0.5 * (xlamd(i)+xlamdd) * dz - endif - factor = 1. + tem - tem1 - ptem = 0.5 * tem - pgcon - ptem1= 0.5 * tem + pgcon - hcdo(i,k) = ((1.-tem1)*hcdo(i,k+1)+tem*0.5* - & (heo(i,k)+heo(i,k+1)))/factor - ucdo(i,k) = ((1.-tem1)*ucdo(i,k+1)+ptem*uo(i,k+1) - & +ptem1*uo(i,k))/factor - vcdo(i,k) = ((1.-tem1)*vcdo(i,k+1)+ptem*vo(i,k+1) - & +ptem1*vo(i,k))/factor - dbyo(i,k) = hcdo(i,k) - heso(i,k) - endif - enddo - enddo -c - do k = km1, 1, -1 - do i = 1, im - if (cnvflg(i).and.k.lt.jmin(i)) then - gamma = el2orc * qeso(i,k) / (to(i,k)**2) - qrcdo(i,k) = qeso(i,k)+ - & (1./hvap)*(gamma/(1.+gamma))*dbyo(i,k) -! detad = etad(i,k+1) - etad(i,k) -cj - dz = zi(i,k+1) - zi(i,k) - if(k.ge.kbcon(i)) then - tem = xlamde * dz - tem1 = 0.5 * xlamdd * dz - else - tem = xlamde * dz - tem1 = 0.5 * (xlamd(i)+xlamdd) * dz - endif - factor = 1. + tem - tem1 - qcdo(i,k) = ((1.-tem1)*qcdo(i,k+1)+tem*0.5* - & (qo(i,k)+qo(i,k+1)))/factor -cj -! pwdo(i,k) = etad(i,k+1) * qcdo(i,k+1) - -! & etad(i,k) * qrcdo(i,k) -! pwdo(i,k) = pwdo(i,k) - detad * -! & .5 * (qrcdo(i,k) + qrcdo(i,k+1)) -cj - pwdo(i,k) = etad(i,k+1) * (qcdo(i,k) - qrcdo(i,k)) - qcdo(i,k) = qrcdo(i,k) - pwevo(i) = pwevo(i) + pwdo(i,k) - endif - enddo - enddo -c -c--- final downdraft strength dependent on precip -c--- efficiency (edt), normalized condensate (pwav), and -c--- evaporate (pwev) -c - do i = 1, im - edtmax = edtmaxl - if(slimsk(i).eq.0.) edtmax = edtmaxs - if(cnvflg(i)) then - if(pwevo(i).lt.0.) then - edto(i) = -edto(i) * pwavo(i) / pwevo(i) - edto(i) = min(edto(i),edtmax) - else - edto(i) = 0. - endif - endif - enddo -c -c--- downdraft cloudwork functions -c - do k = km1, 1, -1 - do i = 1, im - if (cnvflg(i) .and. k .lt. jmin(i)) then - gamma = el2orc * qeso(i,k) / to(i,k)**2 - dhh=hcdo(i,k) - dt=to(i,k) - dg=gamma - dh=heso(i,k) - dz=-1.*(zo(i,k+1)-zo(i,k)) - aa1(i)=aa1(i)+edto(i)*dz*(g/(cp*dt))*((dhh-dh)/(1.+dg)) - & *(1.+delta*cp*dg*dt/hvap) - val=0. - aa1(i)=aa1(i)+edto(i)* - & dz*g*delta*max(val,(qeso(i,k)-qo(i,k))) - endif - enddo - enddo - do i = 1, im - if(cnvflg(i).and.aa1(i).le.0.) then - cnvflg(i) = .false. - endif - enddo -!! - totflg = .true. - do i=1,im - totflg = totflg .and. (.not. cnvflg(i)) - enddo - if(totflg) return -!! -c -c--- what would the change be, that a cloud with unit mass -c--- will do to the environment? -c - do k = 1, km - do i = 1, im - if(cnvflg(i) .and. k .le. kmax(i)) then - dellah(i,k) = 0. - dellaq(i,k) = 0. - dellau(i,k) = 0. - dellav(i,k) = 0. - endif - enddo - enddo - do i = 1, im - if(cnvflg(i)) then - dp = 1000. * del(i,1) - dellah(i,1) = edto(i) * etad(i,1) * (hcdo(i,1) - & - heo(i,1)) * g / dp - dellaq(i,1) = edto(i) * etad(i,1) * (qcdo(i,1) - & - qo(i,1)) * g / dp - dellau(i,1) = edto(i) * etad(i,1) * (ucdo(i,1) - & - uo(i,1)) * g / dp - dellav(i,1) = edto(i) * etad(i,1) * (vcdo(i,1) - & - vo(i,1)) * g / dp - endif - enddo -c -c--- changed due to subsidence and entrainment -c - do k = 2, km1 - do i = 1, im - if (cnvflg(i).and.k.lt.ktcon(i)) then - aup = 1. - if(k.le.kb(i)) aup = 0. - adw = 1. - if(k.gt.jmin(i)) adw = 0. - dp = 1000. * del(i,k) - dz = zi(i,k) - zi(i,k-1) -c - dv1h = heo(i,k) - dv2h = .5 * (heo(i,k) + heo(i,k-1)) - dv3h = heo(i,k-1) - dv1q = qo(i,k) - dv2q = .5 * (qo(i,k) + qo(i,k-1)) - dv3q = qo(i,k-1) - dv1u = uo(i,k) - dv2u = .5 * (uo(i,k) + uo(i,k-1)) - dv3u = uo(i,k-1) - dv1v = vo(i,k) - dv2v = .5 * (vo(i,k) + vo(i,k-1)) - dv3v = vo(i,k-1) -c - tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) - tem1 = xlamud(i) -c - if(k.le.kbcon(i)) then - ptem = xlamde - ptem1 = xlamd(i)+xlamdd - else - ptem = xlamde - ptem1 = xlamdd - endif -cj - dellah(i,k) = dellah(i,k) + - & ((aup*eta(i,k)-adw*edto(i)*etad(i,k))*dv1h - & - (aup*eta(i,k-1)-adw*edto(i)*etad(i,k-1))*dv3h - & - (aup*tem*eta(i,k-1)+adw*edto(i)*ptem*etad(i,k))*dv2h*dz - & + aup*tem1*eta(i,k-1)*.5*(hcko(i,k)+hcko(i,k-1))*dz - & + adw*edto(i)*ptem1*etad(i,k)*.5*(hcdo(i,k)+hcdo(i,k-1))*dz - & ) *g/dp -cj - dellaq(i,k) = dellaq(i,k) + - & ((aup*eta(i,k)-adw*edto(i)*etad(i,k))*dv1q - & - (aup*eta(i,k-1)-adw*edto(i)*etad(i,k-1))*dv3q - & - (aup*tem*eta(i,k-1)+adw*edto(i)*ptem*etad(i,k))*dv2q*dz - & + aup*tem1*eta(i,k-1)*.5*(qcko(i,k)+qcko(i,k-1))*dz - & + adw*edto(i)*ptem1*etad(i,k)*.5*(qrcdo(i,k)+qrcdo(i,k-1))*dz - & ) *g/dp -cj - dellau(i,k) = dellau(i,k) + - & ((aup*eta(i,k)-adw*edto(i)*etad(i,k))*dv1u - & - (aup*eta(i,k-1)-adw*edto(i)*etad(i,k-1))*dv3u - & - (aup*tem*eta(i,k-1)+adw*edto(i)*ptem*etad(i,k))*dv2u*dz - & + aup*tem1*eta(i,k-1)*.5*(ucko(i,k)+ucko(i,k-1))*dz - & + adw*edto(i)*ptem1*etad(i,k)*.5*(ucdo(i,k)+ucdo(i,k-1))*dz - & - pgcon*(aup*eta(i,k-1)-adw*edto(i)*etad(i,k))*(dv1u-dv3u) - & ) *g/dp -cj - dellav(i,k) = dellav(i,k) + - & ((aup*eta(i,k)-adw*edto(i)*etad(i,k))*dv1v - & - (aup*eta(i,k-1)-adw*edto(i)*etad(i,k-1))*dv3v - & - (aup*tem*eta(i,k-1)+adw*edto(i)*ptem*etad(i,k))*dv2v*dz - & + aup*tem1*eta(i,k-1)*.5*(vcko(i,k)+vcko(i,k-1))*dz - & + adw*edto(i)*ptem1*etad(i,k)*.5*(vcdo(i,k)+vcdo(i,k-1))*dz - & - pgcon*(aup*eta(i,k-1)-adw*edto(i)*etad(i,k))*(dv1v-dv3v) - & ) *g/dp -cj - endif - enddo - enddo -c -c------- cloud top -c - do i = 1, im - if(cnvflg(i)) then - indx = ktcon(i) - dp = 1000. * del(i,indx) - dv1h = heo(i,indx-1) - dellah(i,indx) = eta(i,indx-1) * - & (hcko(i,indx-1) - dv1h) * g / dp - dv1q = qo(i,indx-1) - dellaq(i,indx) = eta(i,indx-1) * - & (qcko(i,indx-1) - dv1q) * g / dp - dv1u = uo(i,indx-1) - dellau(i,indx) = eta(i,indx-1) * - & (ucko(i,indx-1) - dv1u) * g / dp - dv1v = vo(i,indx-1) - dellav(i,indx) = eta(i,indx-1) * - & (vcko(i,indx-1) - dv1v) * g / dp -c -c cloud water -c - dellal(i,indx) = eta(i,indx-1) * - & qlko_ktcon(i) * g / dp - endif - enddo -c -c------- final changed variable per unit mass flux -c - do k = 1, km - do i = 1, im - if (cnvflg(i).and.k .le. kmax(i)) then - if(k.gt.ktcon(i)) then - qo(i,k) = q1(i,k) - to(i,k) = t1(i,k) - endif - if(k.le.ktcon(i)) then - qo(i,k) = dellaq(i,k) * mbdt + q1(i,k) - dellat = (dellah(i,k) - hvap * dellaq(i,k)) / cp - to(i,k) = dellat * mbdt + t1(i,k) - val = 1.e-10 - qo(i,k) = max(qo(i,k), val ) - endif - endif - enddo - enddo -c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -c -c--- the above changed environment is now used to calulate the -c--- effect the arbitrary cloud (with unit mass flux) -c--- would have on the stability, -c--- which then is used to calculate the real mass flux, -c--- necessary to keep this change in balance with the large-scale -c--- destabilization. -c -c--- environmental conditions again, first heights -c - do k = 1, km - do i = 1, im - if(cnvflg(i) .and. k .le. kmax(i)) then - qeso(i,k) = 0.01 * fpvs(to(i,k)) ! fpvs is in pa - qeso(i,k) = eps * qeso(i,k) / (pfld(i,k)+epsm1*qeso(i,k)) - val = 1.e-8 - qeso(i,k) = max(qeso(i,k), val ) -! tvo(i,k) = to(i,k) + delta * to(i,k) * qo(i,k) - endif - enddo - enddo -c -c--- moist static energy -c - do k = 1, km1 - do i = 1, im - if(cnvflg(i) .and. k .le. kmax(i)-1) then - dz = .5 * (zo(i,k+1) - zo(i,k)) - dp = .5 * (pfld(i,k+1) - pfld(i,k)) - es = 0.01 * fpvs(to(i,k+1)) ! fpvs is in pa - pprime = pfld(i,k+1) + epsm1 * es - qs = eps * es / pprime - dqsdp = - qs / pprime - desdt = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2)) - dqsdt = qs * pfld(i,k+1) * desdt / (es * pprime) - gamma = el2orc * qeso(i,k+1) / (to(i,k+1)**2) - dt = (g * dz + hvap * dqsdp * dp) / (cp * (1. + gamma)) - dq = dqsdt * dt + dqsdp * dp - to(i,k) = to(i,k+1) + dt - qo(i,k) = qo(i,k+1) + dq - po(i,k) = .5 * (pfld(i,k) + pfld(i,k+1)) - endif - enddo - enddo - do k = 1, km1 - do i = 1, im - if(cnvflg(i) .and. k .le. kmax(i)-1) then - qeso(i,k) = 0.01 * fpvs(to(i,k)) ! fpvs is in pa - qeso(i,k) = eps * qeso(i,k) / (po(i,k) + epsm1 * qeso(i,k)) - val1 = 1.e-8 - qeso(i,k) = max(qeso(i,k), val1) - val2 = 1.e-10 - qo(i,k) = max(qo(i,k), val2 ) -! qo(i,k) = min(qo(i,k),qeso(i,k)) - heo(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) + - & cp * to(i,k) + hvap * qo(i,k) - heso(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) + - & cp * to(i,k) + hvap * qeso(i,k) - endif - enddo - enddo - do i = 1, im - if(cnvflg(i)) then - k = min(km,kmax(i)) ! jbao - heo(i,k) = g * zo(i,k) + cp * to(i,k) + hvap * qo(i,k) - heso(i,k) = g * zo(i,k) + cp * to(i,k) + hvap * qeso(i,k) -c heo(i,k) = min(heo(i,k),heso(i,k)) - endif - enddo -c -c**************************** static control -c -c------- moisture and cloud work functions -c - do i = 1, im - if(cnvflg(i)) then - xaa0(i) = 0. - xpwav(i) = 0. - endif - enddo -c - do i = 1, im - if(cnvflg(i)) then - indx = kb(i) - hcko(i,indx) = heo(i,indx) - qcko(i,indx) = qo(i,indx) - endif - enddo - do k = 2, km1 - do i = 1, im - if (cnvflg(i)) then - if(k.gt.kb(i).and.k.le.ktcon(i)) then - dz = zi(i,k) - zi(i,k-1) - tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz - tem1 = 0.5 * xlamud(i) * dz - factor = 1. + tem - tem1 - hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5* - & (heo(i,k)+heo(i,k-1)))/factor - endif - endif - enddo - enddo - do k = 2, km1 - do i = 1, im - if (cnvflg(i)) then - if(k.gt.kb(i).and.k.lt.ktcon(i)) then - dz = zi(i,k) - zi(i,k-1) - gamma = el2orc * qeso(i,k) / (to(i,k)**2) - xdby = hcko(i,k) - heso(i,k) - xqrch = qeso(i,k) - & + gamma * xdby / (hvap * (1. + gamma)) -cj - tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz - tem1 = 0.5 * xlamud(i) * dz - factor = 1. + tem - tem1 - qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* - & (qo(i,k)+qo(i,k-1)))/factor -cj - dq = eta(i,k) * (qcko(i,k) - xqrch) -c - if(k.ge.kbcon(i).and.dq.gt.0.) then - etah = .5 * (eta(i,k) + eta(i,k-1)) - if(ncloud.gt.0..and.k.gt.jmin(i)) then - qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz) - else - qlk = dq / (eta(i,k) + etah * c0 * dz) - endif - if(k.lt.ktcon1(i)) then - xaa0(i) = xaa0(i) - dz * g * qlk - endif - qcko(i,k) = qlk + xqrch - xpw = etah * c0 * dz * qlk - xpwav(i) = xpwav(i) + xpw - endif - endif - if(k.ge.kbcon(i).and.k.lt.ktcon1(i)) then - dz1 = zo(i,k+1) - zo(i,k) - gamma = el2orc * qeso(i,k) / (to(i,k)**2) - rfact = 1. + delta * cp * gamma - & * to(i,k) / hvap - xaa0(i) = xaa0(i) - & + dz1 * (g / (cp * to(i,k))) - & * xdby / (1. + gamma) - & * rfact - val=0. - xaa0(i)=xaa0(i)+ - & dz1 * g * delta * - & max(val,(qeso(i,k) - qo(i,k))) - endif - endif - enddo - enddo -c -c------- downdraft calculations -c -c--- downdraft moisture properties -c - do i = 1, im - if(cnvflg(i)) then - jmn = jmin(i) - hcdo(i,jmn) = heo(i,jmn) - qcdo(i,jmn) = qo(i,jmn) - qrcd(i,jmn) = qeso(i,jmn) - xpwev(i) = 0. - endif - enddo -cj - do k = km1, 1, -1 - do i = 1, im - if (cnvflg(i) .and. k.lt.jmin(i)) then - dz = zi(i,k+1) - zi(i,k) - if(k.ge.kbcon(i)) then - tem = xlamde * dz - tem1 = 0.5 * xlamdd * dz - else - tem = xlamde * dz - tem1 = 0.5 * (xlamd(i)+xlamdd) * dz - endif - factor = 1. + tem - tem1 - hcdo(i,k) = ((1.-tem1)*hcdo(i,k+1)+tem*0.5* - & (heo(i,k)+heo(i,k+1)))/factor - endif - enddo - enddo -cj - do k = km1, 1, -1 - do i = 1, im - if (cnvflg(i) .and. k .lt. jmin(i)) then - dq = qeso(i,k) - dt = to(i,k) - gamma = el2orc * dq / dt**2 - dh = hcdo(i,k) - heso(i,k) - qrcd(i,k)=dq+(1./hvap)*(gamma/(1.+gamma))*dh -! detad = etad(i,k+1) - etad(i,k) -cj - dz = zi(i,k+1) - zi(i,k) - if(k.ge.kbcon(i)) then - tem = xlamde * dz - tem1 = 0.5 * xlamdd * dz - else - tem = xlamde * dz - tem1 = 0.5 * (xlamd(i)+xlamdd) * dz - endif - factor = 1. + tem - tem1 - qcdo(i,k) = ((1.-tem1)*qcdo(i,k+1)+tem*0.5* - & (qo(i,k)+qo(i,k+1)))/factor -cj -! xpwd = etad(i,k+1) * qcdo(i,k+1) - -! & etad(i,k) * qrcd(i,k) -! xpwd = xpwd - detad * -! & .5 * (qrcd(i,k) + qrcd(i,k+1)) -cj - xpwd = etad(i,k+1) * (qcdo(i,k) - qrcd(i,k)) - qcdo(i,k)= qrcd(i,k) - xpwev(i) = xpwev(i) + xpwd - endif - enddo - enddo -c - do i = 1, im - edtmax = edtmaxl - if(slimsk(i).eq.0.) edtmax = edtmaxs - if(cnvflg(i)) then - if(xpwev(i).ge.0.) then - edtx(i) = 0. - else - edtx(i) = -edtx(i) * xpwav(i) / xpwev(i) - edtx(i) = min(edtx(i),edtmax) - endif - endif - enddo -c -c -c--- downdraft cloudwork functions -c -c - do k = km1, 1, -1 - do i = 1, im - if (cnvflg(i) .and. k.lt.jmin(i)) then - gamma = el2orc * qeso(i,k) / to(i,k)**2 - dhh=hcdo(i,k) - dt= to(i,k) - dg= gamma - dh= heso(i,k) - dz=-1.*(zo(i,k+1)-zo(i,k)) - xaa0(i)=xaa0(i)+edtx(i)*dz*(g/(cp*dt))*((dhh-dh)/(1.+dg)) - & *(1.+delta*cp*dg*dt/hvap) - val=0. - xaa0(i)=xaa0(i)+edtx(i)* - & dz*g*delta*max(val,(qeso(i,k)-qo(i,k))) - endif - enddo - enddo -c -c calculate critical cloud work function -c - do i = 1, im - if(cnvflg(i)) then - if(pfld(i,ktcon(i)).lt.pcrit(15))then - acrt(i)=acrit(15)*(975.-pfld(i,ktcon(i))) - & /(975.-pcrit(15)) - else if(pfld(i,ktcon(i)).gt.pcrit(1))then - acrt(i)=acrit(1) - else - k = int((850. - pfld(i,ktcon(i)))/50.) + 2 - k = min(k,15) - k = max(k,2) - acrt(i)=acrit(k)+(acrit(k-1)-acrit(k))* - & (pfld(i,ktcon(i))-pcrit(k))/(pcrit(k-1)-pcrit(k)) - endif - endif - enddo - do i = 1, im - if(cnvflg(i)) then - if(slimsk(i).eq.1.) then - w1 = w1l - w2 = w2l - w3 = w3l - w4 = w4l - else - w1 = w1s - w2 = w2s - w3 = w3s - w4 = w4s - endif -c -c modify critical cloud workfunction by cloud base vertical velocity -c - if(pdot(i).le.w4) then - acrtfct(i) = (pdot(i) - w4) / (w3 - w4) - elseif(pdot(i).ge.-w4) then - acrtfct(i) = - (pdot(i) + w4) / (w4 - w3) - else - acrtfct(i) = 0. - endif - val1 = -1. - acrtfct(i) = max(acrtfct(i),val1) - val2 = 1. - acrtfct(i) = min(acrtfct(i),val2) - acrtfct(i) = 1. - acrtfct(i) -c -c modify acrtfct(i) by colume mean rh if rhbar(i) is greater than 80 percent -c -c if(rhbar(i).ge..8) then -c acrtfct(i) = acrtfct(i) * (.9 - min(rhbar(i),.9)) * 10. -c endif -c -c modify adjustment time scale by cloud base vertical velocity -c - dtconv(i) = dt2 + max((1800. - dt2),0.) * - & (pdot(i) - w2) / (w1 - w2) -c dtconv(i) = max(dtconv(i), dt2) -c dtconv(i) = 1800. * (pdot(i) - w2) / (w1 - w2) - dtconv(i) = max(dtconv(i),dtmin) - dtconv(i) = min(dtconv(i),dtmax) -c - endif - enddo -c -c--- large scale forcing -c - do i= 1, im - if(cnvflg(i)) then - fld(i)=(aa1(i)-acrt(i)* acrtfct(i))/dtconv(i) - if(fld(i).le.0.) cnvflg(i) = .false. - endif - if(cnvflg(i)) then -c xaa0(i) = max(xaa0(i),0.) - xk(i) = (xaa0(i) - aa1(i)) / mbdt - if(xk(i).ge.0.) cnvflg(i) = .false. - endif -c -c--- kernel, cloud base mass flux -c - if(cnvflg(i)) then - xmb(i) = -fld(i) / xk(i) - xmb(i) = min(xmb(i),xmbmax(i)) - endif - enddo -!! - totflg = .true. - do i=1,im - totflg = totflg .and. (.not. cnvflg(i)) - enddo - if(totflg) return -!! -c -c restore to,qo,uo,vo to t1,q1,u1,v1 in case convection stops -c - do k = 1, km - do i = 1, im - if (cnvflg(i) .and. k .le. kmax(i)) then - to(i,k) = t1(i,k) - qo(i,k) = q1(i,k) - uo(i,k) = u1(i,k) - vo(i,k) = v1(i,k) - qeso(i,k) = 0.01 * fpvs(t1(i,k)) ! fpvs is in pa - qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k)) - val = 1.e-8 - qeso(i,k) = max(qeso(i,k), val ) - endif - enddo - enddo -c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -c -c--- feedback: simply the changes from the cloud with unit mass flux -c--- multiplied by the mass flux necessary to keep the -c--- equilibrium with the larger-scale. -c - do i = 1, im - delhbar(i) = 0. - delqbar(i) = 0. - deltbar(i) = 0. - delubar(i) = 0. - delvbar(i) = 0. - qcond(i) = 0. - enddo - do k = 1, km - do i = 1, im - if (cnvflg(i) .and. k .le. kmax(i)) then - if(k.le.ktcon(i)) then - dellat = (dellah(i,k) - hvap * dellaq(i,k)) / cp - t1(i,k) = t1(i,k) + dellat * xmb(i) * dt2 -! sdiaga(i,k)=dellat * xmb(i) - q1(i,k) = q1(i,k) + dellaq(i,k) * xmb(i) * dt2 -! sdiagb(i,k)=dellaq(i,k) * xmb(i) - tem = 1./rcs(i) - u1(i,k) = u1(i,k) + dellau(i,k) * xmb(i) * dt2 * tem - v1(i,k) = v1(i,k) + dellav(i,k) * xmb(i) * dt2 * tem - dp = 1000. * del(i,k) - delhbar(i) = delhbar(i) + dellah(i,k)*xmb(i)*dp/g - delqbar(i) = delqbar(i) + dellaq(i,k)*xmb(i)*dp/g - deltbar(i) = deltbar(i) + dellat*xmb(i)*dp/g - delubar(i) = delubar(i) + dellau(i,k)*xmb(i)*dp/g - delvbar(i) = delvbar(i) + dellav(i,k)*xmb(i)*dp/g - endif - endif - enddo - enddo - do k = 1, km - do i = 1, im - if (cnvflg(i) .and. k .le. kmax(i)) then - if(k.le.ktcon(i)) then - qeso(i,k) = 0.01 * fpvs(t1(i,k)) ! fpvs is in pa - qeso(i,k) = eps * qeso(i,k)/(pfld(i,k) + epsm1*qeso(i,k)) - val = 1.e-8 - qeso(i,k) = max(qeso(i,k), val ) - endif - endif - enddo - enddo -c - do i = 1, im - rntot(i) = 0. - delqev(i) = 0. - delq2(i) = 0. - flg(i) = cnvflg(i) - enddo - do k = km, 1, -1 - do i = 1, im - if (cnvflg(i) .and. k .le. kmax(i)) then - if(k.lt.ktcon(i)) then - aup = 1. - if(k.le.kb(i)) aup = 0. - adw = 1. - if(k.ge.jmin(i)) adw = 0. - rain = aup * pwo(i,k) + adw * edto(i) * pwdo(i,k) - rntot(i) = rntot(i) + rain * xmb(i) * .001 * dt2 - endif - endif - enddo - enddo - do k = km, 1, -1 - do i = 1, im - if (k .le. kmax(i)) then - deltv(i) = 0. - delq(i) = 0. - qevap(i) = 0. - if(cnvflg(i).and.k.lt.ktcon(i)) then - aup = 1. - if(k.le.kb(i)) aup = 0. - adw = 1. - if(k.ge.jmin(i)) adw = 0. - rain = aup * pwo(i,k) + adw * edto(i) * pwdo(i,k) - rn(i) = rn(i) + rain * xmb(i) * .001 * dt2 - endif - if(flg(i).and.k.lt.ktcon(i)) then - evef = edt(i) * evfact - if(slimsk(i).eq.1.) evef=edt(i) * evfactl -! if(slimsk(i).eq.1.) evef=.07 -c if(slimsk(i).ne.1.) evef = 0. - qcond(i) = evef * (q1(i,k) - qeso(i,k)) - & / (1. + el2orc * qeso(i,k) / t1(i,k)**2) - dp = 1000. * del(i,k) - if(rn(i).gt.0..and.qcond(i).lt.0.) then - qevap(i) = -qcond(i) * (1.-exp(-.32*sqrt(dt2*rn(i)))) - qevap(i) = min(qevap(i), rn(i)*1000.*g/dp) - delq2(i) = delqev(i) + .001 * qevap(i) * dp / g - endif - if(rn(i).gt.0..and.qcond(i).lt.0..and. - & delq2(i).gt.rntot(i)) then - qevap(i) = 1000.* g * (rntot(i) - delqev(i)) / dp - flg(i) = .false. - endif - if(rn(i).gt.0..and.qevap(i).gt.0.) then - q1(i,k) = q1(i,k) + qevap(i) - t1(i,k) = t1(i,k) - elocp * qevap(i) - rn(i) = rn(i) - .001 * qevap(i) * dp / g - deltv(i) = - elocp*qevap(i)/dt2 - delq(i) = + qevap(i)/dt2 - delqev(i) = delqev(i) + .001*dp*qevap(i)/g - endif - dellaq(i,k) = dellaq(i,k) + delq(i) / xmb(i) - delqbar(i) = delqbar(i) + delq(i)*dp/g - deltbar(i) = deltbar(i) + deltv(i)*dp/g - endif - endif - enddo - enddo -cj -! do i = 1, im -! if(me.eq.31.and.cnvflg(i)) then -! if(cnvflg(i)) then -! print *, ' deep delhbar, delqbar, deltbar = ', -! & delhbar(i),hvap*delqbar(i),cp*deltbar(i) -! print *, ' deep delubar, delvbar = ',delubar(i),delvbar(i) -! print *, ' precip =', hvap*rn(i)*1000./dt2 -! print*,'pdif= ',pfld(i,kbcon(i))-pfld(i,ktcon(i)) -! endif -! enddo -c -c precipitation rate converted to actual precip -c in unit of m instead of kg -c - do i = 1, im - if(cnvflg(i)) then -c -c in the event of upper level rain evaporation and lower level downdraft -c moistening, rn can become negative, in this case, we back out of the -c heating and the moistening -c - if(rn(i).lt.0..and..not.flg(i)) rn(i) = 0. - if(rn(i).le.0.) then - rn(i) = 0. - else - ktop(i) = ktcon(i) - kbot(i) = kbcon(i) - kcnv(i) = 1 - cldwrk(i) = aa1(i) - endif - endif - enddo -c -c cloud water -c - if (ncloud.gt.0) then -! - do k = 1, km - do i = 1, im - if (cnvflg(i) .and. rn(i).gt.0.) then - if (k.gt.kb(i).and.k.le.ktcon(i)) then - tem = dellal(i,k) * xmb(i) * dt2 - tem1 = max(0.0, min(1.0, (tcr-t1(i,k))*tcrf)) - if (ql(i,k,2) .gt. -999.0) then - ql(i,k,1) = ql(i,k,1) + tem * tem1 ! ice - ql(i,k,2) = ql(i,k,2) + tem *(1.0-tem1) ! water - else - ql(i,k,1) = ql(i,k,1) + tem - endif - endif - endif - enddo - enddo -! - endif -c - do k = 1, km - do i = 1, im - if(cnvflg(i).and.rn(i).le.0.) then - if (k .le. kmax(i)) then - t1(i,k) = to(i,k) - q1(i,k) = qo(i,k) - u1(i,k) = uo(i,k) - v1(i,k) = vo(i,k) - endif - endif - enddo - enddo -! -! hchuang code change -! - do k = 1, km - do i = 1, im - if(cnvflg(i).and.rn(i).gt.0.) then - if(k.ge.kb(i) .and. k.lt.ktop(i)) then - ud_mf(i,k) = eta(i,k) * xmb(i) * dt2 - endif - endif - enddo - enddo - do i = 1, im - if(cnvflg(i).and.rn(i).gt.0.) then - k = ktop(i)-1 - dt_mf(i,k) = ud_mf(i,k) - endif - enddo - do k = 1, km - do i = 1, im - if(cnvflg(i).and.rn(i).gt.0.) then - if(k.ge.1 .and. k.le.jmin(i)) then - dd_mf(i,k) = edto(i) * etad(i,k) * xmb(i) * dt2 - endif - endif - enddo - enddo -!! - return - end diff --git a/src/fim/FIMsrc/fim/column/sfc_diag.f b/src/fim/FIMsrc/fim/column/sfc_diag.f deleted file mode 100644 index 9c32a7d..0000000 --- a/src/fim/FIMsrc/fim/column/sfc_diag.f +++ /dev/null @@ -1,104 +0,0 @@ - SUBROUTINE SFC_DIAG(IM,KM,PS,U1,V1,T1,Q1, - & TSKIN,QSURF, - & F10M,U10M,V10M,T2M,Q2M, - & RCL,PRSLKI,SLIMSK, - & EVAP,FM,FH,FM10,FH2) -! - USE MACHINE , ONLY : kind_phys - USE FUNCPHYS, ONLY : fpvs - USE PHYSCONS, grav => con_g, SBC => con_sbc, HVAP => con_HVAP - &, CP => con_CP, HFUS => con_HFUS, JCAL => con_JCAL - &, EPS => con_eps, EPSM1 => con_epsm1 - &, RVRDM1 => con_FVirt, RD => con_RD - implicit none -! -! include 'constant.h' -! - integer IM, km -! - real(kind=kind_phys) PS(IM), U1(IM), V1(IM), - & T1(IM), Q1(IM), - & TSKIN(IM), QSURF(IM), - & F10M(IM), U10M(IM), - & V10M(IM), T2M(IM), Q2M(IM), - & RCL(IM), PRSL1(IM), PRSLKI(IM), - & SLIMSK(IM), EVAP(IM), - & FM(IM), FH(IM), - & FM10(IM), FH2(IM) -! -! Locals -! - real (kind=kind_phys), parameter :: qmin=1.0e-8 - integer k,i -! - real(kind=kind_phys) - & PSURF(IM), QSS(IM), - & THETA1(IM), XRCL(IM) -! - real(kind=kind_phys) g, sig2k -! -cc - PARAMETER (G=grav) -! - LOGICAL FLAG(IM), FLAGSNW(IM) - real(kind=kind_phys) KT1(IM), KT2(IM), KTSOIL, - & ET(IM,KM), - & STSOIL(IM,KM), AI(IM,KM), BI(IM,KM), - & CI(IM,KM), RHSTC(IM,KM) -! -C -C ESTIMATE SIGMA ** K AT 2 M -C - SIG2K = 1. - 4. * G * 2. / (CP * 280.) -C -C INITIALIZE VARIABLES. ALL UNITS ARE SUPPOSEDLY M.K.S. UNLESS SPECIFIE -C PSURF IS IN PASCALS -C THETA1 IS ADIABATIC SURFACE TEMP FROM LEVEL 1 -C -!! - DO I=1,IM - XRCL(I) = SQRT(RCL(I)) - PSURF(I) = 1000. * PS(I) - THETA1(I) = T1(I) * PRSLKI(I) - ENDDO -!! -! - DO I = 1, IM - F10M(I) = FM10(I) / FM(I) - F10M(I) = min(F10M(I),1.) - U10M(I) = F10M(I) * XRCL(I) * U1(I) - V10M(I) = F10M(I) * XRCL(I) * V1(I) - T2M(I) = TSKIN(I) * (1. - FH2(I) / FH(I)) - & + THETA1(I) * FH2(I) / FH(I) - T2M(I) = T2M(I) * SIG2K -C Q2M(I) = QSURF(I) * (1. - FH2(I) / FH(I)) -C & + Q1(I) * FH2(I) / FH(I) -C T2M(I) = T1 -C Q2M(I) = Q1 - IF(EVAP(I).GE.0.) THEN -C -C IN CASE OF EVAPORATION, USE THE INFERRED QSURF TO DEDUCE Q2M -C - Q2M(I) = QSURF(I) * (1. - FH2(I) / FH(I)) - & + max(qmin,Q1(I)) * FH2(I) / FH(I) ! Moorthi -!! & + Q1(I) * FH2(I) / FH(I) - ELSE -C -C FOR DEW FORMATION SITUATION, USE SATURATED Q AT TSKIN -C -cjfe QSS(I) = 1000. * FPVS(TSKIN(I)) - qss(I) = fpvs(tskin(I)) - QSS(I) = EPS * QSS(I) / (PSURF(I) + EPSM1 * QSS(I)) - Q2M(I) = QSS(I) * (1. - FH2(I) / FH(I)) - & + max(qmin,Q1(I)) * FH2(I) / FH(I) ! Moorthi -!! & + Q1(I) * FH2(I) / FH(I) - ENDIF -cjfe QSS(I) = 1000. * FPVS(T2M(I)) - QSS(I) = fpvs(t2m(I)) -! QSS(I) = 1000. * T2MO(I) - QSS(I) = EPS * QSS(I) / (PSURF(I) + EPSM1 * QSS(I)) - Q2M(I) = MIN(Q2M(I),QSS(I)) - ENDDO - - RETURN - END diff --git a/src/fim/FIMsrc/fim/column/sfc_diff.f b/src/fim/FIMsrc/fim/column/sfc_diff.f deleted file mode 100644 index 76ac90f..0000000 --- a/src/fim/FIMsrc/fim/column/sfc_diff.f +++ /dev/null @@ -1,294 +0,0 @@ - SUBROUTINE SFC_DIFF(IM,PS,U1,V1,T1,Q1, - & TSKIN,Z0RL,CM,CH,RB, - & RCL,PRSL1,PRSLKI,SLIMSK, - & STRESS,FM,FH, -Clu_q2m_iter [-1L/+2L]: add tsurf, flag_iter -!* & USTAR,WIND,DDVEL,FM10,FH2) - + USTAR,WIND,DDVEL,FM10,FH2, - + tsurf,flag_iter) -! - USE MACHINE , ONLY : kind_phys - USE FUNCPHYS, ONLY : fpvs - USE PHYSCONS, grav => con_g, SBC => con_sbc - &, CP => con_CP, HFUS => con_HFUS - &, RVRDM1 => con_FVirt, RD => con_RD - &, EPS => con_eps, EPSM1 => con_epsm1 - - implicit none -! -! include 'constant.h' -! - integer IM, km, ipr -! - real(kind=kind_phys) PS(IM), U1(IM), V1(IM), - & T1(IM), Q1(IM), - & TSKIN(IM), Z0RL(IM), - & CM(IM), CH(IM), RB(IM), - & RCL(IM), PRSL1(IM), PRSLKI(IM), - & SLIMSK(IM), STRESS(IM), - & FM(IM), FH(IM), USTAR(IM), - & WIND(IM), DDVEL(IM), - & FM10(IM), FH2(IM) - -Clu_q2m_iter [+1L]: add flag_iter - logical flag_iter(im) - -! -! Locals -! - integer k,i -! - real(kind=kind_phys) DTV(IM), HL1(IM), HL12(IM), - & HLINF(IM), PH(IM), - & PH2(IM), PM(IM), PM10(IM), - & PSURF(IM), Q0(IM), RAT(IM), - & THETA1(IM), THV1(IM), - & TSURF(IM), TV1(IM), - & TVS(IM), XRCL(IM), - & Z0(IM), Z0MAX(IM), Z1(IM), - & ZTMAX(IM), PS1(IM), QS1(IM) - -! - real(kind=kind_phys) a0, a0p, a1, a1p, aa, aa0, - & aa1, adtv, alpha, arnu, b1, b1p, - & b2, b2p, bb, bb0, bb1, bb2, - & ca, cc, cc1, cc2, charnock, - & cq, fms, fhs, g, hl0, hl0inf, - & hl110, hlt, hltinf,OLINF, - & restar, rnu, vis -! -cc - PARAMETER (CHARNOCK=.014,CA=.4)!C CA IS THE VON KARMAN CONSTANT - PARAMETER (G=grav) - PARAMETER (ALPHA=5.,A0=-3.975,A1=12.32,B1=-7.755,B2=6.041) - PARAMETER (A0P=-7.941,A1P=24.75,B1P=-8.705,B2P=7.899,VIS=1.4E-5) - PARAMETER (AA1=-1.076,BB1=.7045,CC1=-.05808) - PARAMETER (BB2=-.1954,CC2=.009999) - PARAMETER (RNU=1.51E-5,ARNU=.135*RNU) -C -C INITIALIZE VARIABLES. ALL UNITS ARE SUPPOSEDLY M.K.S. UNLESS SPECIFIED -C PSURF IS IN PASCALS -C WIND IS WIND SPEED, THETA1 IS ADIABATIC SURFACE TEMP FROM LEVEL 1 -C SURFACE ROUGHNESS LENGTH IS CONVERTED TO M FROM CM -C - DO I=1,IM - if(flag_iter(i)) then - XRCL(I) = SQRT(RCL(I)) - PSURF(I) = 1000. * PS(I) -!** TSURF(I) = TSKIN(I) !! <---- Clu_q2m_iter [-1L] - PS1(I) = 1000. * PRSL1(I) - WIND(I) = XRCL(I) * SQRT(U1(I) * U1(I) + V1(I) * V1(I)) - & + MAX(0.0, MIN(DDVEL(I), 30.0)) - WIND(I) = MAX(WIND(I),1.) - Q0(I) = MAX(Q1(I),1.E-8) - THETA1(I) = T1(I) * PRSLKI(I) - TV1(I) = T1(I) * (1. + RVRDM1 * Q0(I)) - THV1(I) = THETA1(I) * (1. + RVRDM1 * Q0(I)) -Clu_q2m_iter[-1L/+2L]: TVS is computed from avg(tsurf,tskin) -!** TVS(I) = TSURF(I) * (1. + RVRDM1 * Q0(I)) - TVS(I) = 0.5 * (TSURF(I)+TSKIN(I)) * - + (1. + RVRDM1 * Q0(I)) - qs1(i) = fpvs(t1(i)) - QS1(I) = EPS * QS1(I) / (PS1(I) + EPSM1 * QS1(I)) - QS1(I) = MAX(QS1(I), 1.E-8) - Q0(I) = min(QS1(I),Q0(I)) - - Z0(I) = .01 * Z0RL(i) - Z1(I) = -RD * TV1(I) * LOG(PS1(I)/PSURF(I)) / G - endif - ENDDO -!! -C -C COMPUTE STABILITY DEPENDENT EXCHANGE COEFFICIENTS -C -C THIS PORTION OF THE CODE IS PRESENTLY SUPPRESSED -C - DO I=1,IM - if(flag_iter(i)) then - IF(SLIMSK(I).EQ.0.) THEN - USTAR(I) = SQRT(G * Z0(I) / CHARNOCK) - ENDIF -C -C COMPUTE STABILITY INDICES (RB AND HLINF) -C - Z0MAX(I) = MIN(Z0(I),1. * Z1(I)) - ZTMAX(I) = Z0MAX(I) - IF(SLIMSK(I).EQ.0.) THEN - RESTAR = USTAR(I) * Z0MAX(I) / VIS - RESTAR = MAX(RESTAR,.000001) -c RESTAR = ALOG(RESTAR) -c RESTAR = MIN(RESTAR,5.) -c RESTAR = MAX(RESTAR,-5.) -c RAT(I) = AA1 + BB1 * RESTAR + CC1 * RESTAR ** 2 -c RAT(I) = RAT(I) / (1. + BB2 * RESTAR -c & + CC2 * RESTAR ** 2) -c Rat taken from Zeng, Zhao and Dickinson 1997 - RAT(I) = 2.67 * restar ** .25 - 2.57 - RAT(I) = min(RAT(I),7.) - ZTMAX(I) = Z0MAX(I) * EXP(-RAT(I)) - ENDIF - endif - ENDDO -C##DG IF(LAT.EQ.LATD) THEN -C##DG PRINT *, ' z0max, ztmax, restar, RAT(I) =', -C##DG & z0max, ztmax, restar, RAT(I) -C##DG ENDIF - DO I = 1, IM - if(flag_iter(i)) then - DTV(I) = THV1(I) - TVS(I) - ADTV = ABS(DTV(I)) - ADTV = MAX(ADTV,.001) - DTV(I) = SIGN(1.,DTV(I)) * ADTV - RB(I) = G * DTV(I) * Z1(I) / (.5 * (THV1(I) + TVS(I)) - & * WIND(I) * WIND(I)) - RB(I) = MAX(RB(I),-5000.) - FM(I) = LOG((Z0MAX(I)+Z1(I)) / Z0MAX(I)) - FH(I) = LOG((ZTMAX(I)+Z1(I)) / ZTMAX(I)) - HLINF(I) = RB(I) * FM(I) * FM(I) / FH(I) - FM10(I) = LOG((Z0MAX(I)+10.) / Z0MAX(I)) - FH2(I) = LOG((ZTMAX(I)+2.) / ZTMAX(I)) - endif - ENDDO -C##DG IF(LAT.EQ.LATD) THEN -C##DG PRINT *, ' DTV, RB(I), FM(I), FH(I), HLINF =', -C##DG & dtv, rb, FM(I), FH(I), hlinf -C##DG ENDIF -C -C STABLE CASE -C - DO I = 1, IM - if(flag_iter(i)) then - IF(DTV(I).GE.0.) THEN - HL1(I) = HLINF(I) - ENDIF - IF(DTV(I).GE.0..AND.HLINF(I).GT..25) THEN - HL0INF = Z0MAX(I) * HLINF(I) / Z1(I) - HLTINF = ZTMAX(I) * HLINF(I) / Z1(I) - AA = SQRT(1. + 4. * ALPHA * HLINF(I)) - AA0 = SQRT(1. + 4. * ALPHA * HL0INF) - BB = AA - BB0 = SQRT(1. + 4. * ALPHA * HLTINF) - PM(I) = AA0 - AA + LOG((AA + 1.) / (AA0 + 1.)) - PH(I) = BB0 - BB + LOG((BB + 1.) / (BB0 + 1.)) - FMS = FM(I) - PM(I) - FHS = FH(I) - PH(I) - HL1(I) = FMS * FMS * RB(I) / FHS - ENDIF - endif - ENDDO -C -C SECOND ITERATION -C - DO I = 1, IM - if(flag_iter(i)) then - IF(DTV(I).GE.0.) THEN - HL0 = Z0MAX(I) * HL1(I) / Z1(I) - HLT = ZTMAX(I) * HL1(I) / Z1(I) - AA = SQRT(1. + 4. * ALPHA * HL1(I)) - AA0 = SQRT(1. + 4. * ALPHA * HL0) - BB = AA - BB0 = SQRT(1. + 4. * ALPHA * HLT) - PM(I) = AA0 - AA + LOG((AA + 1.) / (AA0 + 1.)) - PH(I) = BB0 - BB + LOG((BB + 1.) / (BB0 + 1.)) - HL110 = HL1(I) * 10. / Z1(I) - AA = SQRT(1. + 4. * ALPHA * HL110) - PM10(I) = AA0 - AA + LOG((AA + 1.) / (AA0 + 1.)) - HL12(I) = HL1(I) * 2. / Z1(I) -C AA = SQRT(1. + 4. * ALPHA * HL12(I)) - BB = SQRT(1. + 4. * ALPHA * HL12(I)) - PH2(I) = BB0 - BB + LOG((BB + 1.) / (BB0 + 1.)) - ENDIF - endif - ENDDO -!! -C##DG IF(LAT.EQ.LATD) THEN -C##DG PRINT *, ' HL1(I), PM, PH =', -C##DG & HL1(I), pm, ph -C##DG ENDIF -C -C UNSTABLE CASE -C -C -C CHECK FOR UNPHYSICAL OBUKHOV LENGTH -C - DO I=1,IM - if(flag_iter(i)) then - IF(DTV(I).LT.0.) THEN - OLINF = Z1(I) / HLINF(I) - IF(ABS(OLINF).LE.50. * Z0MAX(I)) THEN - HLINF(I) = -Z1(I) / (50. * Z0MAX(I)) - ENDIF - ENDIF - endif - ENDDO -C -C GET PM AND PH -C - DO I = 1, IM - if(flag_iter(i)) then - IF(DTV(I).LT.0..AND.HLINF(I).GE.-.5) THEN - HL1(I) = HLINF(I) - PM(I) = (A0 + A1 * HL1(I)) * HL1(I) - & / (1. + B1 * HL1(I) + B2 * HL1(I) * HL1(I)) - PH(I) = (A0P + A1P * HL1(I)) * HL1(I) - & / (1. + B1P * HL1(I) + B2P * HL1(I) * HL1(I)) - HL110 = HL1(I) * 10. / Z1(I) - PM10(I) = (A0 + A1 * HL110) * HL110 - & / (1. + B1 * HL110 + B2 * HL110 * HL110) - HL12(I) = HL1(I) * 2. / Z1(I) - PH2(I) = (A0P + A1P * HL12(I)) * HL12(I) - & / (1. + B1P * HL12(I) + B2P * HL12(I) * HL12(I)) - ENDIF - IF(DTV(I).LT.0.AND.HLINF(I).LT.-.5) THEN - HL1(I) = -HLINF(I) - PM(I) = LOG(HL1(I)) + 2. * HL1(I) ** (-.25) - .8776 - PH(I) = LOG(HL1(I)) + .5 * HL1(I) ** (-.5) + 1.386 - HL110 = HL1(I) * 10. / Z1(I) - PM10(I) = LOG(HL110) + 2. * HL110 ** (-.25) - .8776 - HL12(I) = HL1(I) * 2. / Z1(I) - PH2(I) = LOG(HL12(I)) + .5 * HL12(I) ** (-.5) + 1.386 - ENDIF - endif - ENDDO -C -C FINISH THE EXCHANGE COEFFICIENT COMPUTATION TO PROVIDE FM AND FH -C - DO I = 1, IM - if(flag_iter(i)) then - FM(I) = FM(I) - PM(I) - FH(I) = FH(I) - PH(I) - FM10(I) = FM10(I) - PM10(I) - FH2(I) = FH2(I) - PH2(I) - CM(I) = CA * CA / (FM(I) * FM(I)) - CH(I) = CA * CA / (FM(I) * FH(I)) - CQ = CH(I) - STRESS(I) = CM(I) * WIND(I) * WIND(I) - USTAR(I) = SQRT(STRESS(I)) -! USTAR(I) = SQRT(CM(I) * WIND(I) * WIND(I)) - endif - ENDDO -C##DG IF(LAT.EQ.LATD) THEN -C##DG PRINT *, ' FM, FH, CM, CH(I), USTAR =', -C##DG & FM, FH, CM, ch, USTAR -C##DG ENDIF -C -C UPDATE Z0 OVER OCEAN -C - DO I = 1, IM - if(flag_iter(i)) then - IF(SLIMSK(I).EQ.0.) THEN - Z0(I) = (CHARNOCK / G) * USTAR(I) ** 2 -C NEW IMPLEMENTATION OF Z0 -C CC = USTAR(I) * Z0 / RNU -C PP = CC / (1. + CC) -C FF = G * ARNU / (CHARNOCK * USTAR(I) ** 3) -C Z0 = ARNU / (USTAR(I) * FF ** PP) - Z0(I) = MIN(Z0(I),.1) - Z0(I) = MAX(Z0(I),1.E-7) - Z0RL(I) = 100. * Z0(I) - ENDIF - endif - ENDDO - - RETURN - END diff --git a/src/fim/FIMsrc/fim/column/sfc_drv.f b/src/fim/FIMsrc/fim/column/sfc_drv.f deleted file mode 100644 index 6b19197..0000000 --- a/src/fim/FIMsrc/fim/column/sfc_drv.f +++ /dev/null @@ -1,453 +0,0 @@ - - SUBROUTINE SFC_DRV(IM,KM,PS,U1,V1,T1,Q1, - & SHELEG,SNCOVR1,SNWDPH,TSKIN,QSURF,TPRCP,SRFLAG, - & SMC,STC,SLC,DM,SOILTYP,SIGMAF,VEGTYPE,CANOPY, - & DLWFLX,DSWSFC,SLRAD,DELT,TG3,GFLUX,CM,CH, - & RCL,PRSL1,PRSLKI,SLIMSK, - & DRAIN,EVAP,HFLX,EP,DDVEL, - + RUNOFF,SLOPETYP,SHDMIN,SHDMAX,SNOALB,SFALB, - + CMM,CHH,ZF,EVBS,EVCW,TRANS,SBSNO, - + SNOWC,STM,SNOHF,SMCWLT2,SMCREF2, - + tsurf, flag_iter, flag_guess) -! - USE MACHINE , ONLY : kind_phys - USE FUNCPHYS, ONLY : fpvs - USE PHYSCONS, grav => con_g, HVAP => con_HVAP - &, CP => con_CP, JCAL => con_JCAL - &, EPS => con_eps, EPSM1 => con_epsm1 - &, RVRDM1 => con_FVirt, RD => con_RD - implicit none -! -! include 'constant.h' -! - integer IM, KM - real(kind=kind_phys), parameter :: cpinv=1.0/cp, HVAPI=1.0/HVAP - real(kind=kind_phys) DELT - INTEGER SOILTYP(IM), VEGTYPE(IM) - &, SLOPETYP(IM) - - real(kind=kind_phys) PS(IM), U1(IM), V1(IM), - & T1(IM), Q1(IM), SHELEG(IM), - & SNWDPH(IM), TSKIN(IM), QSURF(IM), - & TPRCP(IM), SRFLAG(IM), - & SMC(IM,KM), STC(IM,KM), SLC(IM,KM), - & DM(IM), SIGMAF(IM), CANOPY(IM), - & DLWFLX(IM), SLRAD(IM), TG3(IM), - & GFLUX(IM), CM(IM), CH(IM), - & RCL(IM), PRSL1(IM), PRSLKI(IM), - & SLIMSK(IM), DRAIN(IM), EVAP(IM), - & HFLX(IM), EP(IM), - & DDVEL(IM), RUNOFF(IM), - & SHDMIN(IM), SHDMAX(IM), - & SNOALB(IM), SFALB(IM) - +, tsurf(im), sncovr1(im),DSWSFC(im) - -Cwei added 10/24/2006 - &, CHH(IM),CMM(IM),ZF(IM),EVBS(IM),EVCW(IM) - &, TRANS(IM),SBSNO(IM),SNOWC(IM),STM(IM) - &, SNOHF(IM),SMCWLT2(IM),SMCREF2(IM) - - logical flag_iter(im), flag_guess(im), FLAG(IM) -! -! Locals -- GFS -! - integer k,i - real(kind=kind_phys) PSURF(IM), PS1(IM), RCH(IM), RHO(IM), - & Q0(IM), QS1(IM), SLWD(IM), - & THETA1(IM), TV1(IM), XRCL(IM), - & WIND(IM), ZSOIL(IM,KM) -! -! land-related prognostic fields -! - real(kind=kind_phys) SHELEG_OLD(IM),SNWDPH_OLD(IM), - + TPRCP_OLD(IM), SRFLAG_OLD(IM), - + TSKIN_OLD(IM), CANOPY_OLD(IM), - + SMC_OLD(IM,KM),STC_OLD(IM,KM),SLC_OLD(IM,KM) - - real(kind=kind_phys) convrad, elocp, g, rhoh2o, tem -! -! Locals -- Noah -! - integer couple, ice, nsoil, nroot, slope, - + stype, vtype -! - real(kind=kind_phys) ET(KM), ZSOIL_NOAH(4), SLDPTH(KM), - & STSOIL(KM), SMSOIL(KM), SLSOIL(KM) - - real(kind=kind_phys) A2, A3, A4, A23M4 -! - real(kind=kind_phys) alb, albedo, beta, chx, cmx, cmc, - & dew, drip, dqsdt2, - & ec, edir, ett, eta, esnow, etp, - & flx1, flx2, flx3, ffrozp, lwdn, - & pc, prcp, ptu, - & q2, q2sat, - & radflx, rc, rcs, rct, rcq, rcsoil, - & rsmin, runoff1, runoff2, runoff3, - & sfcspd, sfcprs, sfctmp, - & sheat, shdfac, shdmin1d, shdmax1d, - & smcwlt, smcdry, smcref, smcmax, - & sneqv, snoalb1d, snowh, snomlt, sncovr, - & soilw, soilm, ssoil, tsea, - & th2, tbot, xlai, zlvl,swdn -! -cc - PARAMETER (G=grav) - PARAMETER (ELOCP=HVAP/CP) - PARAMETER (RHOH2O=1000.,CONVRAD=JCAL*1.E4/60.) -CC declare parameters needed for deriving noah variables - PARAMETER (A2=17.2693882,A3=273.16,A4=35.86, - & A23M4=A2*(A3-A4) ) - DATA ZSOIL_NOAH/-0.1, -0.4, -1.0, -2.0/ - -C -C FLAG for land -C - DO I = 1, IM - FLAG(I) = SLIMSK(I).EQ. 1. - ENDDO - -C -C save land-related prognostic fields for guess run -C - do i=1, im - if(FLAG(I) .AND. flag_guess(i)) then - sheleg_old(i) = sheleg(i) - snwdph_old(i) = snwdph(i) - tskin_old(i) = tskin(i) - canopy_old(i) = canopy(i) - tprcp_old(i) = tprcp(i) - srflag_old(i) = srflag(i) - do k=1, km - smc_old(i,k) = smc(i,k) - stc_old(i,k) = stc(i,k) - slc_old(i,k) = slc(i,k) - enddo - endif - enddo -C** -C** INITIALIZATION BLOCK -C** - DO I=1,IM - IF(flag_iter(i).and. FLAG(I)) THEN - DM(I) = 1. - EP(I) = 0. - EVAP(I) = 0. - HFLX(I) = 0. - GFLUX(I) = 0. - DRAIN(I) = 0. - CANOPY(I)= MAX(CANOPY(I),0.) -Cwei added 10/24/2006 - EVBS(I)=0 - EVCW(I)=0 - TRANS(I)=0 - SBSNO(I)=0 - SNOWC(I)=0 - SNOHF(I)=0 - ENDIF - ENDDO - -C** -C** INITIALIZE VARIABLES -C** - DO I=1,IM - IF(flag_iter(i).and. FLAG(I)) THEN - XRCL(I) = SQRT(RCL(I)) - WIND(I) = XRCL(I) * SQRT(U1(I) * U1(I) + V1(I) * V1(I)) - & + MAX(0.0, MIN(DDVEL(I), 30.0)) - WIND(I) = MAX(WIND(I),1.) - PSURF(I) = 1000. * PS(I) !* convert sfc pressure from cb to Pa - PS1(I) = 1000. * PRSL1(I) -! SLWD(I) = SLRAD(I) * CONVRAD !*convert from cal cm-2 min-1 to w/m2 - SLWD(I) = SLRAD(I) !*rad flx in w/m2 - Q0(I) = MAX(Q1(I),1.E-8) !* Q1=specific humidity at level 1 (Kg/Kg) - THETA1(I) = T1(I) * PRSLKI(I) !* adiabatic temp at level 1 (K) - TV1(I) = T1(I) * (1. + RVRDM1 * Q0(I)) - RHO(I) = PS1(I) / (RD * TV1(I)) - qs1(i) = fpvs(t1(i)) !* qs1=sat. humidity at level 1 (Kg/Kg) - QS1(I) = EPS * QS1(I) / (PS1(I) + EPSM1 * QS1(I)) - QS1(I) = MAX(QS1(I), 1.E-8) - Q0(I) = min(QS1(I),Q0(I)) - ENDIF - ENDDO -!! - DO I=1,IM - IF(flag_iter(i).and. FLAG(I)) THEN - DO K = 1, KM - ZSOIL(I,K) = ZSOIL_NOAH(K) - ENDDO -!CluX: skip QA(slope type) -!** IF(SLOPETYP(I) .GT. 9) SLOPETYP(I) = 9 !<--- QA(SLOPE) -!** IF(SLOPETYP(I) .EQ. 0) SLOPETYP(I) = 2 !<--- QA(SLOPE) - ENDIF - ENDDO - - - DO I=1,IM - IF(flag_iter(i).and. FLAG(I)) THEN -C** -C** GFS -> NOAH: PREPARE VARIABLES TO RUN NOAH LSM -C** -C 1. CONFIGURATION INFORMATION (C): -C COUPLE COUPLE-UNCOUPLE FLAG (=1: COUPLED, =0: UNCOUPLED) -C FFROZP FLAG FOR SNOW-RAIN DETECTION (1.=snow, 0.=rain) -C ICE SEA-ICE FLAG (=1: SEA-ICE, =0: LAND) -C DT TIMESTEP (SEC) (DT SHOULD NOT EXCEED 3600 SECS) = delt -C ZLVL HEIGHT (M) ABOVE GROUND OF ATMOSPHERIC FORCING VARIABLES -C NSOIL NUMBER OF SOIL LAYERS (AT LEAST 2) -C SLDPTH THE THICKNESS OF EACH SOIL LAYER (M) - COUPLE = 1 !!<--- run noah lsm in 'couple' mode - IF(SRFLAG(I) .EQ. 1.) FFROZP = 1. !... snow phase - IF(SRFLAG(I) .EQ. 0.) FFROZP = 0. !... rain phase - ICE = 0 - ZLVL = -RD * TV1(I) * LOG(PS1(I)/PSURF(I)) / G !! Z1 for OSU -Cwei added 10/24/2006 - zf(i)=-RD * TV1(I) * LOG(PS1(I)/PSURF(I)) / G - - NSOIL = km - SLDPTH(1) = - ZSOIL(I,1) - DO K = 2,KM - SLDPTH(K) = ZSOIL(I,K-1) - ZSOIL(I,K) - END DO - -C 2. FORCING DATA (F): -C LWDN LW DOWNWARD RADIATION (W M-2; POSITIVE, NOT NET LONGWAVE) -C RADFLX RADIATION FLUX (SOLDN or FDOWN) -C SFCPRS PRESSURE AT HEIGHT ZLVL ABOVE GROUND (PASCALS) -C PRCP PRECIP RATE (KG M-2 S-1) -C SFCTMP AIR TEMPERATURE (K) AT HEIGHT ZLVL ABOVE GROUND -C TH2 AIR POTENTIAL TEMPERATURE (K) AT HEIGHT ZLVL ABOVE GROUND -C Q2 MIXING RATIO AT HEIGHT ZLVL ABOVE GROUND (KG KG-1) - LWDN = dlwflx(I) !..downward lw flux at sfc in w/m2 - SWDN = DSWSFC(I) !..downward sw flux at sfc in w/m2 - RADFLX = -1.*SLWD(I) !..net downward rad flx at sfc in w/m2 - SFCPRS = PS1(I) - PRCP = RHOH2O * TPRCP(I) / DELT - SFCTMP = T1(I) - TH2 = THETA1(I) - Q2 = Q0(I) - -C 3. OTHER FORCING (INPUT) DATA (I): -C SFCSPD WIND SPEED (M S-1) AT HEIGHT ZLVL ABOVE GROUND -C Q2SAT SAT MIXING RATIO AT HEIGHT ZLVL ABOVE GROUND (KG KG-1) -C DQSDT2 SLOPE OF SAT SPECIFIC HUMIDITY CURVE AT T=SFCTMP (KG KG-1 K-1) - SFCSPD = WIND(I) - Q2SAT = QS1(I) - DQSDT2 = Q2SAT * A23M4/(SFCTMP-A4)**2 - -C 4. CANOPY/SOIL CHARACTERISTICS (S): -C VEGTYP VEGETATION TYPE (INTEGER INDEX) -> VTYPE -C SOILTYP SOIL TYPE (INTEGER INDEX) -> STYPE -C SLOPETYP CLASS OF SFC SLOPE (INTEGER INDEX) -> SLOPE -C SHDFAC AREAL FRACTIONAL COVERAGE OF GREEN VEGETATION (0.0-1.0) -C SHDMIN MINIMUM AREAL FRACTIONAL COVERAGE OF GREEN VEGETATION -> SHDMIN1D -C PTU PHOTO THERMAL UNIT (PLANT PHENOLOGY FOR ANNUALS/CROPS) -C ALB BACKROUND SNOW-FREE SURFACE ALBEDO (FRACTION) -C SNOALB UPPER BOUND ON MAXIMUM ALBEDO OVER DEEP SNOW -> SNOALB1D -C TBOT BOTTOM SOIL TEMPERATURE (LOCAL YEARLY-MEAN SFC AIR TEMP) - VTYPE = VEGTYPE(I) - STYPE = SOILTYP(I) - SLOPE = SLOPETYP(I) - SHDFAC = SIGMAF(I) -!CluX skip the scaling -!* SHDMIN1D = 0.01 * SHDMIN(I) !..convert from percent to fraction -!* SHDMAX1D = 0.01 * SHDMAX(I) !..convert from percent to fraction -!* SNOALB1D = 0.01 * SNOALB(I) !..convert from percent to fraction - SHDMIN1D = SHDMIN(I) - SHDMAX1D = SHDMAX(I) - SNOALB1D = SNOALB(I) - PTU = 0. - ALB = SFALB(I) - TBOT = TG3(I) - -C 5. HISTORY (STATE) VARIABLES (H): -C CMC CANOPY MOISTURE CONTENT (M) -C T1 GROUND/CANOPY/SNOWPACK) EFFECTIVE SKIN TEMPERATURE (K) -> TSEA -C STC(NSOIL) SOIL TEMP (K) -> STSOIL -C SMC(NSOIL) TOTAL SOIL MOISTURE CONTENT (VOLUMETRIC FRACTION) -> SMSOIL -C SH2O(NSOIL) UNFROZEN SOIL MOISTURE CONTENT (VOLUMETRIC FRACTION) -> SLSOIL -C SNOWH ACTUAL SNOW DEPTH (M) -C SNEQV LIQUID WATER-EQUIVALENT SNOW DEPTH (M) -C ALBEDO SURFACE ALBEDO INCLUDING SNOW EFFECT (UNITLESS FRACTION) -C CH SURFACE EXCHANGE COEFFICIENT FOR HEAT AND MOISTURE (M S-1) -> CHX -C0 CM SURFACE EXCHANGE COEFFICIENT FOR MOMENTUM (M S-1) -> CMX - CMC = CANOPY(I)/1000. !.. convert from mm to m -!** TSEA = TSKIN(I) - TSEA = tsurf(I) !!! Clu_q2m_iter - DO K = 1, KM - STSOIL(K) = STC(I,K) - SMSOIL(K) = SMC(I,K) - SLSOIL(K) = SLC(I,K) - END DO - SNOWH = SNWDPH(I) / 1000. !.. convert from mm to m - SNEQV = SHELEG(I) / 1000. !.. convert from mm to m - IF(SNEQV .NE. 0. .AND. SNOWH .EQ. 0.) THEN !<--- QA - SNOWH = 10. * SNEQV - ENDIF -! Added by Moorthi -! IF(SNEQV .GT. 0. .AND. SNOWH .LT. SNEQV) THEN -! SNOWH = 5. * SNEQV -! ENDIF -! up to here - CHX = CH(I) * WIND(I) ! compute conductance - CMX = CM(I) * WIND(I) ! compute conductance -Cwei added 10/24/2005 - CHH(I) = RHO(I)*CH(I) * WIND(I) ! compute conductance - CMM(I) = CM(I) * WIND(I) ! compute conductance - -C** -C** CALL NOAH LSM -C** - - CALL SFLX ( - + COUPLE, -!* C FFROZP,ICE,DT,ZLVL,NSOIL,SLDPTH, - C FFROZP,ICE,DELT,ZLVL,NSOIL,SLDPTH, - F LWDN,SWDN,RADFLX,SFCPRS,PRCP,SFCTMP,Q2,SFCSPD, - I TH2,Q2SAT,DQSDT2, -!* S VEGTYP,SOILTYP,SLOPETYP,SHDFAC,SHDMIN,PTU,ALB,SNOALB,TBOT, - S VTYPE,STYPE,SLOPE,SHDFAC,SHDMIN1D,PTU,ALB,SNOALB1D,TBOT, -!* H CMC,T1,STC,SMC,SH2O,SNOWH,SNEQV,ALBEDO,CH,CM, - H CMC,TSEA,STSOIL,SMSOIL,SLSOIL,SNOWH,SNEQV, - H ALBEDO,CHX,CMX, - O ETA,SHEAT, - O EC,EDIR,ET,ETT,ESNOW,DRIP,DEW, - O BETA,ETP,SSOIL, - O FLX1,FLX2,FLX3, - O SNOMLT,SNCOVR, - O RUNOFF1,RUNOFF2,RUNOFF3, - O RC,PC,RSMIN,XLAI,RCS,RCT,RCQ,RCSOIL, - D SOILW,SOILM, - P SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT) - -C** -C** NOAH -> GFS: PREPARE VARIABLES FOR RETURN TO PARENT MODE -C** -C 6. OUTPUT (O): -C ETA ACTUAL LATENT HEAT FLUX (W M-2: POSITIVE, IF UPWARD FROM SFC) -C SHEAT SENSIBLE HEAT FLUX (W M-2: POSITIVE, IF UPWARD FROM SFC) -C BETA RATIO OF ACTUAL/POTENTIAL EVAP (DIMENSIONLESS) -C ETP POTENTIAL EVAPORATION (W M-2) -C SSOIL SOIL HEAT FLUX (W M-2: NEGATIVE IF DOWNWARD FROM SURFACE) -C RUNOFF1 SURFACE RUNOFF (M S-1), NOT INFILTRATING THE SURFACE -C RUNOFF2 SUBSURFACE RUNOFF (M S-1), DRAINAGE OUT BOTTOM - EVAP(I) = ETA - HFLX(I) = SHEAT - GFLUX(I) = SSOIL -Cwei added 10/24/2006 - EVBS(I)=EDIR - EVCW(I)=EC - TRANS(I)=ETT - SBSNO(I)=ESNOW - SNOWC(I)=SNCOVR - STM(I)=SOILM - SNOHF(I)=FLX1+FLX2+FLX3 - SMCWLT2(I)=SMCWLT - SMCREF2(I)=SMCREF - - - EP(I) = ETP -!* TSKIN(I) = TSEA - tsurf(I) = TSEA !!! Clu_q2m_iter - DO K = 1, KM - STC(I,K) = STSOIL(K) - SMC(I,K) = SMSOIL(K) - SLC(I,K) = SLSOIL(K) - END DO - -C* UNIT CONVERSION (FROM M S-1 to MM S-1) - RUNOFF(I) = RUNOFF1 * 1000. - DRAIN(I) = RUNOFF2 * 1000. - -C* UNIT CONVERSION (FROM M to MM) - CANOPY(I) = CMC * 1000. - SNWDPH(I) = SNOWH * 1000. - SHELEG(I) = SNEQV * 1000. - sncovr1(i)=sncovr - -C Do not return the following output fields to parent model -C EC CANOPY WATER EVAPORATION (M S-1) -C EDIR DIRECT SOIL EVAPORATION (M S-1) -C ET(NSOIL) PLANT TRANSPIRATION FROM A PARTICULAR ROOT LAYER (M S-1) -C ETT TOTAL PLANT TRANSPIRATION (M S-1) -C ESNOW SUBLIMATION FROM (OR DEPOSITION TO IF <0) SNOWPACK (M S-1) -C DRIP THROUGH-FALL OF PRECIP AND/OR DEW IN EXCESS OF CANOPY -C WATER-HOLDING CAPACITY (M) -C DEW DEWFALL (OR FROSTFALL FOR T<273.15) (M) -C BETA RATIO OF ACTUAL/POTENTIAL EVAP (DIMENSIONLESS) -C FLX1 PRECIP-SNOW SFC (W M-2) -C FLX2 FREEZING RAIN LATENT HEAT FLUX (W M-2) -C FLX3 PHASE-CHANGE HEAT FLUX FROM SNOWMELT (W M-2) -C SNOMLT SNOW MELT (M) (WATER EQUIVALENT) -C SNCOVR FRACTIONAL SNOW COVER (UNITLESS FRACTION, 0-1) -C RUNOFF3 NUMERICAL TRUNCTATION IN EXCESS OF POROSITY (SMCMAX) -C FOR A GIVEN SOIL LAYER AT THE END OF A TIME STEP -C RC CANOPY RESISTANCE (S M-1) -C PC PLANT COEFFICIENT (UNITLESS FRACTION, 0-1) WHERE PC*ETP -C = ACTUAL TRANSP -C XLAI LEAF AREA INDEX (DIMENSIONLESS) -C RSMIN MINIMUM CANOPY RESISTANCE (S M-1) -C RCS INCOMING SOLAR RC FACTOR (DIMENSIONLESS) -C RCT AIR TEMPERATURE RC FACTOR (DIMENSIONLESS) -C RCQ ATMOS VAPOR PRESSURE DEFICIT RC FACTOR (DIMENSIONLESS) -C RCSOIL SOIL MOISTURE RC FACTOR (DIMENSIONLESS) -C SOILW AVAILABLE SOIL MOISTURE IN ROOT ZONE (UNITLESS FRACTION -C BETWEEN SMCWLT AND SMCMAX) -C SOILM TOTAL SOIL COLUMN MOISTURE CONTENT (FROZEN+UNFROZEN) (M) -C SMCWLT WILTING POINT (VOLUMETRIC) -C SMCDRY DRY SOIL MOISTURE THRESHOLD WHERE DIRECT EVAP FRM TOP -C LAYER ENDS (VOLUMETRIC) -C SMCREF SOIL MOISTURE THRESHOLD WHERE TRANSPIRATION BEGINS TO -C STRESS (VOLUMETRIC) -C SMCMAX POROSITY, I.E. SATURATED VALUE OF SOIL MOISTURE -C (VOLUMETRIC) -C NROOT NUMBER OF ROOT LAYERS, A FUNCTION OF VEG TYPE, DETERMINED -C IN SUBROUTINE REDPRM. - - ENDIF - ENDDO - -C -C COMPUTE QSURF (specific humidity at sfc) -C - DO I = 1, IM - IF(flag_iter(i).and. FLAG(I)) THEN - RCH(I) = RHO(I) * CP * CH(I) * WIND(I) - QSURF(I) = Q1(I) + EVAP(I) / (ELOCP * RCH(I)) - DM(I) = 1. - ENDIF - ENDDO -C -C - do i=1,im - IF(flag_iter(i).and. FLAG(I)) THEN - tem = 1.0 / rho(i) - hflx(i) = hflx(i) * tem * cpinv - evap(i) = evap(i) * tem * hvapi - ENDIF - enddo - -Clu_q2m_iter [+17L]: restore land-related prognostic fields for guess run - do i=1, im - IF(FLAG(I)) THEN - if(flag_guess(i)) then - sheleg(i) = sheleg_old(i) - snwdph(i) = snwdph_old(i) - tskin(i) = tskin_old(i) - canopy(i) = canopy_old(i) - tprcp(i) = tprcp_old(i) - srflag(i) = srflag_old(i) - do k=1, km - smc(i,k) = smc_old(i,k) - stc(i,k) = stc_old(i,k) - slc(i,k) = slc_old(i,k) - enddo - else - tskin(i) = tsurf(i) - endif - ENDIF - enddo - - RETURN - END - diff --git a/src/fim/FIMsrc/fim/column/sfc_land.f b/src/fim/FIMsrc/fim/column/sfc_land.f deleted file mode 100644 index 3cf97d1..0000000 --- a/src/fim/FIMsrc/fim/column/sfc_land.f +++ /dev/null @@ -1,1066 +0,0 @@ - SUBROUTINE SFC_LAND(IM,KM,PS,U1,V1,T1,Q1, -Clu_Rev6: add TPRCP and SRFLAG -!** & SHELEG,TSKIN,QSURF, - & SHELEG,TSKIN,QSURF,TPRCP,SRFLAG, - & SMC,STC,DM,SOILTYP,SIGMAF,VEGTYPE,CANOPY, - & DLWFLX,SLRAD,SNOWMT,DELT,Z0RL,TG3, - & GFLUX,ZSOIL, - & CM, CH, RHSCNPY,RHSMC,AIM,BIM,CIM, - & RCL,PRSL1,PRSLKI,SLIMSK, - & DRAIN,EVAP,HFLX,EP,DDVEL, - + CMM,CHH,Z1,EVBS,EVCW,TRANS,SBSNO, - + SNOWC,STM,SNOHF,TWILT,TREF, - & tsurf,flag_iter, flag_guess) -! - USE MACHINE , ONLY : kind_phys - USE FUNCPHYS, ONLY : fpvs - USE PHYSCONS, grav => con_g, SBC => con_sbc, HVAP => con_HVAP - &, CP => con_CP, HFUS => con_HFUS, JCAL => con_JCAL - &, EPS => con_eps, EPSM1 => con_epsm1, t0c => con_t0c - &, RVRDM1 => con_FVirt, RD => con_RD - implicit none -! -! include 'constant.h' -! - integer IM, km -! - real(kind=kind_phys), parameter :: cpinv=1.0/cp, HVAPI=1.0/HVAP - real(kind=kind_phys) DELT - INTEGER SOILTYP(IM), VEGTYPE(IM) - real(kind=kind_phys) PS(IM), U1(IM), V1(IM), - & T1(IM), Q1(IM), SHELEG(IM), - & TSKIN(IM), QSURF(IM), SMC(IM,KM), - & STC(IM,KM), DM(IM), SIGMAF(IM), - & CANOPY(IM), DLWFLX(IM), SLRAD(IM), - & SNOWMT(IM), Z0RL(IM), TG3(IM), - & GFLUX(IM), - & ZSOIL(IM,KM), CM(IM), CH(IM), - & RHSCNPY(IM), RHSMC(IM,KM), - & AIM(IM,KM), BIM(IM,KM), CIM(IM,KM), - & RCL(IM), PRSL1(IM), PRSLKI(IM), - & SLIMSK(IM), DRAIN(IM), EVAP(IM), - & HFLX(IM), RNET(IM), EP(IM), - & WIND(IM), DDVEL(IM) -Clu_Rev6: add TPRCP and SRFLAG - &, TPRCP(IM), SRFLAG(IM) -Cwei added 10/24/2006 - &, CHH(IM),CMM(IM),EVBS(IM),EVCW(IM) - &, TRANS(IM),SBSNO(IM),SNOWC(IM),STM(IM),SNOHF(IM) - -! -! land-related prognostic fields -! - real(kind=kind_phys) SHELEG_OLD(IM), - + TPRCP_OLD(IM), SRFLAG_OLD(IM), - + TSKIN_OLD(IM), CANOPY_OLD(IM), - + STC_OLD(IM,KM) - - - logical flag_iter(im), flag_guess(im) -! -! Locals -! - integer k,i -! - real(kind=kind_phys) CANFAC(IM), - & DDZ(IM), DDZ2(IM), DELTA(IM), - & DEW(IM), DF1(IM), DFT0(IM), - & DFT2(IM), DFT1(IM), - & DMDZ(IM), DMDZ2(IM), DTDZ1(IM), - & DTDZ2(IM), DTV(IM), EC(IM), - & EDIR(IM), ETPFAC(IM), - & FACTSNW(IM), FH2(IM), - & FX(IM), GX(IM), - & HCPCT(IM), HL1(IM), HL12(IM), - & HLINF(IM), PARTLND(IM), PH(IM), - & PH2(IM), PM(IM), PM10(IM), - & PSURF(IM), Q0(IM), QS1(IM), - & QSS(IM), RAT(IM), RCAP(IM), - & RCH(IM), RHO(IM), RS(IM), - & RSMALL(IM), SLWD(IM), SMCZ(IM), - & SNET(IM), SNOEVP(IM), SNOWD(IM), - & T1O(IM), T2MO(IM), TERM1(IM), - & TERM2(IM), THETA1(IM), THV1(IM), - & TREF(IM), TSURF(IM), TV1(IM), - & TVS(IM), TSEA(IM), TWILT(IM), - & XX(IM), XRCL(IM), YY(IM), - & Z0(IM), Z0MAX(IM), Z1(IM), - & ZTMAX(IM), ZZ(IM), PS1(IM) -! - real(kind=kind_phys) a0, a0p, a1, a1p, aa, aa0, - & aa1, adtv, alpha, arnu, b1, b1p, - & b2, b2p, bb, bb0, bb1, bb2, - & bfact, ca, cc, cc1, cc2, cfactr, - & ch2o, charnock, cice, convrad, cq, csoil, - & ctfil1,ctfil2, delt2, df2, dfsnow, - & elocp, eth, ff, FMS, - & fhs, funcdf, funckt,g, hl0, hl0inf, - & hl110, hlt, hltinf,OLINF, rcq, rcs, - & rct, restar, rhoh2o,rnu, RSI, - & rss, scanop, sig2k, sigma, smcdry, - & t12, t14, tflx, tgice, topt, - & val, vis, zbot, snomin, tem -! -cc - PARAMETER (CHARNOCK=.014,CA=.4)!C CA IS THE VON KARMAN CONSTANT - PARAMETER (G=grav,sigma=sbc) - - PARAMETER (ALPHA=5.,A0=-3.975,A1=12.32,B1=-7.755,B2=6.041) - PARAMETER (A0P=-7.941,A1P=24.75,B1P=-8.705,B2P=7.899,VIS=1.4E-5) - PARAMETER (AA1=-1.076,BB1=.7045,CC1=-.05808) - PARAMETER (BB2=-.1954,CC2=.009999) - PARAMETER (ELOCP=HVAP/CP,DFSNOW=.31,CH2O=4.2E6,CSOIL=1.26E6) - PARAMETER (SCANOP=.5,CFACTR=.5,ZBOT=-3.,TGICE=271.2) - PARAMETER (CICE=1880.*917.,topt=298.) - PARAMETER (RHOH2O=1000.,CONVRAD=JCAL*1.E4/60.) - PARAMETER (CTFIL1=.5,CTFIL2=1.-CTFIL1) - PARAMETER (RNU=1.51E-5,ARNU=.135*RNU) - parameter (snomin=1.0e-9) -! - LOGICAL FLAG(IM), FLAGSNW(IM) - real(kind=kind_phys) KT1(IM), KT2(IM), KTSOIL, - & ET(IM,KM), - & STSOIL(IM,KM), AI(IM,KM), BI(IM,KM), - & CI(IM,KM), RHSTC(IM,KM) - real(kind=kind_phys) rsmax(13), rgl(13), rsmin(13), hs(13), - & smmax(9), smdry(9), smref(9), smwlt(9) -c -c the 13 vegetation types are: -c -c 1 ... broadleave-evergreen trees (tropical forest) -c 2 ... broadleave-deciduous trees -c 3 ... broadleave and needle leave trees (mixed forest) -c 4 ... needleleave-evergreen trees -c 5 ... needleleave-deciduous trees (larch) -c 6 ... broadleave trees with groundcover (savanna) -c 7 ... groundcover only (perenial) -c 8 ... broadleave shrubs with perenial groundcover -c 9 ... broadleave shrubs with bare soil -c 10 ... dwarf trees and shrubs with ground cover (trunda) -c 11 ... bare soil -c 12 ... cultivations (use parameters from type 7) -c 13 ... glacial -c - data rsmax/13*5000./ - data rsmin/150.,100.,125.,150.,100.,70.,40., - & 300.,400.,150.,999.,40.,999./ - data rgl/5*30.,65.,4*100.,999.,100.,999./ - data hs/41.69,54.53,51.93,47.35,47.35,54.53,36.35, - & 3*42.00,999.,36.35,999./ - data smmax/.421,.464,.468,.434,.406,.465,.404,.439,.421/ - data smdry/.07,.14,.22,.08,.18,.16,.12,.10,.07/ - data smref/.283,.387,.412,.312,.338,.382,.315,.329,.283/ - data smwlt/.029,.119,.139,.047,.010,.103,.069,.066,.029/ -! - save rsmax, rsmin, rgl, hs, smmax, smdry, smref, smwlt -! - DELT2 = DELT * 2. -C -C ESTIMATE SIGMA ** K AT 2 M -C - SIG2K = 1. - 4. * G * 2. / (CP * 280.) - -C -C FLAG for land -C - DO I = 1, IM - FLAG(I) = SLIMSK(I).EQ. 1. - ENDDO - - -C -C save land-related prognostic fields for guess run -C - do i=1, im - if(FLAG(I) .AND. flag_guess(i)) then - sheleg_old(i) = sheleg(i) - tskin_old(i) = tskin(i) - canopy_old(i) = canopy(i) - tprcp_old(i) = tprcp(i) - srflag_old(i) = srflag(i) - do k=1, km - stc_old(i,k) = stc(i,k) - enddo - endif - enddo - -C -CWei_FIX_3: you need to remove snow-rain detection here -C For OSU LSM, the snow-rain detection is done inside gbphys routine !! -C -Clu_Rev6: snow-rain detection -C -C DO I=1,IM -C IF(FLAG(I).AND. flag_guess(i)) THEN -C IF(SRFLAG(I) .EQ. 1.) THEN -C SHELEG(i) = SHELEG(i) + 1.E3*TPRCP(i) -C TPRCP(i) = 0. -C ENDIF -C ENDIF -C ENDDO -C -C INITIALIZE VARIABLES. ALL UNITS ARE SUPPOSEDLY M.K.S. UNLESS SPECIFIE -C PSURF IS IN PASCALS -C WIND IS WIND SPEED, THETA1 IS ADIABATIC SURFACE TEMP FROM LEVEL 1 -C RHO IS DENSITY, QS1 IS SAT. HUM. AT LEVEL1 AND QSS IS SAT. HUM. AT -C SURFACE -C CONVERT SLRAD TO THE CIVILIZED UNIT FROM LANGLEY MINUTE-1 K-4 -C SURFACE ROUGHNESS LENGTH IS CONVERTED TO M FROM CM -C -!! -! qs1 = fpvs(t1) -! qss = fpvs(tskin) - DO I=1,IM - IF(flag_iter(i).and. FLAG(I)) THEN - XRCL(I) = SQRT(RCL(I)) - PSURF(I) = 1000. * PS(I) - PS1(I) = 1000. * PRSL1(I) -! SLWD(I) = SLRAD(I) * CONVRAD - SLWD(I) = SLRAD(I) -c -c DLWFLX has been given a negative sign for downward longwave -c snet is the net shortwave flux -c - SNET(I) = -SLWD(I) - DLWFLX(I) - WIND(I) = XRCL(I) * SQRT(U1(I) * U1(I) + V1(I) * V1(I)) - & + MAX(0.0, MIN(DDVEL(I), 30.0)) - WIND(I) = MAX(WIND(I),1.) - Q0(I) = MAX(Q1(I),1.E-8) -! TSURF(I) = TSKIN(I) - TSEA(I) = tsurf(I) !!! Cwei_q2m_iter - THETA1(I) = T1(I) * PRSLKI(I) - TV1(I) = T1(I) * (1. + RVRDM1 * Q0(I)) - THV1(I) = THETA1(I) * (1. + RVRDM1 * Q0(I)) - TVS(I) = TSEA(I) * (1. + RVRDM1 * Q0(I)) - RHO(I) = PS1(I) / (RD * TV1(I)) -cjfe QS1(I) = 1000. * FPVS(T1(I)) - qs1(i) = fpvs(t1(i)) - QS1(I) = EPS * QS1(I) / (PS1(I) + EPSM1 * QS1(I)) - QS1(I) = MAX(QS1(I), 1.E-8) - Q0(I) = min(QS1(I),Q0(I)) -cjfe QSS(I) = 1000. * FPVS(TSEA(I)) - qss(i) = fpvs(tskin(i)) !!! change to tsurf? - QSS(I) = EPS * QSS(I) / (PSURF(I) + EPSM1 * QSS(I)) -c RS = PLANTR - RS(I) = 0. - if(VEGTYPE(I).gt.0.) RS(I) = rsmin(VEGTYPE(I)) - Z0(I) = .01 * Z0RL(i) - CANOPY(I)= MAX(CANOPY(I),0.) - DM(I) = 1. - FACTSNW(I) = 10. -Clu IF(SLIMSK(I).EQ.2.) FACTSNW(I) = 3. -C -C SNOW DEPTH IN WATER EQUIVALENT IS CONVERTED FROM MM TO M UNIT -C - SNOWD(I) = SHELEG(I) / 1000. - FLAGSNW(I) = .FALSE. -C -C WHEN SNOW DEPTH IS LESS THAN 1 MM, A PATCHY SNOW IS ASSUMED AND -C SOIL IS ALLOWED TO INTERACT WITH THE ATMOSPHERE. -C WE SHOULD EVENTUALLY MOVE TO A LINEAR COMBINATION OF SOIL AND -C SNOW UNDER THE CONDITION OF PATCHY SNOW. -C - IF(SNOWD(I).GT..001.OR.SLIMSK(I).EQ.2.) RS(I) = 0. - IF(SNOWD(I).GT..001) FLAGSNW(I) = .TRUE. -C##DG IF(LAT.EQ.LATD) THEN -C##DG PRINT *, ' WIND,TV1,TVS,Q1,QS1,SNOW,SLIMSK=', -C##DG& WIND,TV1,TVS,Q1,QS1,SNOWD,SLIMSK -C##DG PRINT *, ' SNET, SLWD =', SNET, SLWD(I) -C##DG ENDIF - ENDIF - ENDDO -!! - DO I=1,IM - IF(flag_iter(i).and. FLAG(I)) THEN - ZSOIL(I,1) = -.10 - - DO K = 2, KM - ZSOIL(I,K) = ZSOIL(I,K-1) - & + (-2. - ZSOIL(I,1)) / (KM - 1) - ENDDO -CWei [+5] use the same soil layer structure as Noah if running with 4-layer - if(km.gt.2)then - ZSOIL(I,2) = -.40 - ZSOIL(I,3) = -1.0 - ZSOIL(I,4) = -2.0 - endif - ENDIF - ENDDO -!! - DO I=1,IM - IF(flag_iter(i).and. FLAG(I)) THEN - Z1(I) = -RD * TV1(I) * LOG(PS1(I)/PSURF(I)) / G - DRAIN(I) = 0. - ENDIF - ENDDO -!! - DO K = 1, KM - DO I=1,IM - IF(flag_iter(i).and. FLAG(I)) THEN - ET(I,K) = 0. - RHSMC(I,K) = 0. - AIM(I,K) = 0. - BIM(I,K) = 1. - CIM(I,K) = 0. - STSOIL(I,K) = STC(I,K) - ENDIF - ENDDO - ENDDO - DO I=1,IM - IF(flag_iter(i).and. FLAG(I)) THEN - EDIR(I) = 0. - EC(I) = 0. - EVAP(I) = 0. - HFLX(I) = 0. - EP(I) = 0. - SNOWMT(I) = 0. - GFLUX(I) = 0. - RHSCNPY(I) = 0. - FX(I) = 0. - ETPFAC(I) = 0. - CANFAC(I) = 0. -Cwei added 10/24/2006 - EVBS(I)=0 - EVCW(I)=0 - TRANS(I)=0 - SBSNO(I)=0 - SNOWC(I)=0 - SNOHF(I)=0 - ENDIF - ENDDO - -C -C RCP = RHO CP CH V -C - DO I = 1, IM - IF(flag_iter(i).and. FLAG(I)) THEN - RCH(I) = RHO(I) * CP * CH(I) * WIND(I) -Cwei added 10/24/2006 - CMM(I)=CM(I)* WIND(I) - CHH(I)=RHO(I)*CH(I)* WIND(I) - ENDIF - ENDDO - -C -C COMPUTE SOIL/SNOW/ICE HEAT FLUX IN PREPARATION FOR SURFACE ENERGY -C BALANCE CALCULATION -C - DO I = 1, IM -Clu GFLUX(I) = 0. - IF(flag_iter(i).and. FLAG(I)) THEN - SMCZ(I) = .5 * (SMC(I,1) + .20) - DFT0(I) = KTSOIL(SMCZ(I),SOILTYP(I)) -Clu ELSEIF(SLIMSK(I).EQ.2.) THEN -C DF FOR ICE IS TAKEN FROM MAYKUT AND UNTERSTEINER -C DF IS IN SI UNIT OF W K-1 M-1 -Clu DFT0(I) = 2.2 - ENDIF - ENDDO -!! - DO I=1,IM - IF(flag_iter(i).and. FLAG(I)) THEN -C IF(SNOWD(I).GT..001) THEN - IF(FLAGSNW(I)) THEN -C -C WHEN SNOW COVERED, GROUND HEAT FLUX COMES FROM SNOW -C - TFLX = MIN(T1(I), TSEA(I)) - GFLUX(I) = -DFSNOW * (TFLX - STSOIL(I,1)) - & / (FACTSNW(I) * MAX(SNOWD(I),.001)) - ELSE - GFLUX(I) = DFT0(I) * (STSOIL(I,1) - TSEA(I)) - & / (-.5 * ZSOIL(I,1)) - ENDIF - GFLUX(I) = MAX(GFLUX(I),-200.) - GFLUX(I) = MIN(GFLUX(I),+200.) - ENDIF - ENDDO - DO I = 1, IM - IF(flag_iter(i).and. FLAG(I)) THEN - PARTLND(I) = 1. - IF(SNOWD(I).GT.0..AND.SNOWD(I).LE..001) THEN - PARTLND(I) = 1. - SNOWD(I) / .001 - ENDIF - ENDIF - ENDDO - DO I = 1, IM - IF(flag_iter(i).and. FLAG(I)) THEN - SNOEVP(I) = 0. - if(SNOWD(I).gt..001) PARTLND(I) = 0. - ENDIF - ENDDO -C -C COMPUTE POTENTIAL EVAPORATION FOR LAND AND SEA ICE -C - DO I = 1, IM - IF(flag_iter(i).and. FLAG(I)) THEN - T12 = T1(I) * T1(I) - T14 = T12 * T12 -C -C RCAP = FNET - SIGMA T**4 + GFLX - RHO CP CH V (T1-THETA1) -C - RCAP(I) = -SLWD(I) - SIGMA * T14 + GFLUX(I) - & - RCH(I) * (T1(I) - THETA1(I)) -C -C RSMALL = 4 SIGMA T**3 / RCH(I) + 1 -C - RSMALL(I) = 4. * SIGMA * T1(I) * T12 / RCH(I) + 1. -C -C DELTA = L / CP * DQS/DT -C - DELTA(I) = ELOCP * EPS * HVAP * QS1(I) / (RD * T12) -C -C POTENTIAL EVAPOTRANSPIRATION ( WATTS / M**2 ) AND -C POTENTIAL EVAPORATION -C - TERM1(I) = ELOCP * RSMALL(I) * RCH(I)*(QS1(I)-Q0(I)) - TERM2(I) = RCAP(I) * DELTA(I) - EP(I) = (ELOCP * RSMALL(I) * RCH(I) * (QS1(I) - Q0(I)) - & + RCAP(I) * DELTA(I)) - EP(I) = EP(I) / (RSMALL(I) + DELTA(I)) - ENDIF - ENDDO -C -C ACTUAL EVAPORATION OVER LAND IN THREE PARTS : EDIR, ET, AND EC -C -C DIRECT EVAPORATION FROM SOIL, THE UNIT GOES FROM M S-1 TO KG M-2 S-1 -C - DO I = 1, IM - FLAG(I) = SLIMSK(I).EQ.1..AND.EP(I).GT.0. - ENDDO - DO I = 1, IM - IF(flag_iter(i))THEN - IF(FLAG(I)) THEN - DF1(I) = FUNCDF(SMC(I,1),SOILTYP(I)) - KT1(I) = FUNCKT(SMC(I,1),SOILTYP(I)) - endif - if(FLAG(I).and.STC(I,1).lt.t0c) then - DF1(I) = 0. - KT1(I) = 0. - endif - IF(FLAG(I)) THEN -c TREF = .75 * THSAT(SOILTYP(I)) - TREF(I) = smref(SOILTYP(I)) -c TWILT = TWLT(SOILTYP(I)) - TWILT(I) = smwlt(SOILTYP(I)) - smcdry = smdry(SOILTYP(I)) -c FX(I) = -2. * DF1(I) * (SMC(I,1) - .23) / ZSOIL(I,1) -c & - KT1(I) - FX(I) = -2. * DF1(I) * (SMC(I,1) - smcdry) / ZSOIL(I,1) - & - KT1(I) - FX(I) = MIN(FX(I), EP(I)/HVAP) - FX(I) = MAX(FX(I),0.) -C -C SIGMAF IS THE FRACTION OF AREA COVERED BY VEGETATION -C - EDIR(I) = FX(I) * (1. - SIGMAF(I)) * PARTLND(I) - ENDIF - endif - ENDDO -c -c calculate stomatal resistance -c - DO I = 1, IM - if(flag_iter(i).and.FLAG(I)) then -c -c resistance due to PAR. We use net solar flux as proxy at the present time -c - ff = .55 * 2. * SNET(I) / rgl(VEGTYPE(I)) - rcs = (ff + RS(I)/rsmax(VEGTYPE(I))) / (1. + ff) - rcs = max(rcs,.0001) - rct = 1. - rcq = 1. -c -c resistance due to thermal effect -c -c rct = 1. - .0016 * (topt - theta1) ** 2 -c rct = max(rct,.0001) -c -c resistance due to humidity -c -c rcq = 1. / (1. + hs(VEGTYPE(I)) * (QS1(I) - Q0(I))) -c rcq = max(rcq,.0001) -c -c compute resistance without the effect of soil moisture -c - RS(I) = RS(I) / (rcs * rct * rcq) - endif - ENDDO -C -C TRANSPIRATION FROM ALL LEVELS OF THE SOIL -C - DO I = 1, IM - IF(flag_iter(i).and.FLAG(I)) THEN - CANFAC(I) = (CANOPY(I) / SCANOP) ** CFACTR - ETPFAC(I) = SIGMAF(I) - & * (1. - CANFAC(I)) / HVAP - GX(I) = (SMC(I,1) - TWILT(I)) / (TREF(I) - TWILT(I)) - GX(I) = MAX(GX(I),0.) - GX(I) = MIN(GX(I),1.) -c -c resistance due to soil moisture deficit -c - rss = GX(I) * (ZSOIL(I,1) / ZSOIL(I,km)) - rss = max(rss,.0001) - RSI = RS(I) / rss -c -c transpiration a la Monteith -c - eth = (TERM1(I) + TERM2(I)) / - & (DELTA(I) + RSMALL(I) * (1. + RSI * CH(I) * WIND(I))) - ET(I,1) = ETPFAC(I) * eth - & * PARTLND(I) - ENDIF - ENDDO -!! - DO K = 2, KM - DO I=1,IM - IF(flag_iter(i).and.FLAG(I)) THEN - GX(I) = (SMC(I,K) - TWILT(I)) / (TREF(I) - TWILT(I)) - GX(I) = MAX(GX(I),0.) - GX(I) = MIN(GX(I),1.) -c -c resistance due to soil moisture deficit -c - rss = GX(I) * ((ZSOIL(I,k) - ZSOIL(I,k-1))/ZSOIL(I,km)) - rss = max(rss,1.e-6) - RSI = RS(I) / rss -c -c transpiration a la Monteith -c - eth = (TERM1(I) + TERM2(I)) / - & (DELTA(I) + RSMALL(I) * (1. + RSI * CH(I) * WIND(I))) - ET(I,K) = eth - & * ETPFAC(I) * PARTLND(I) - ENDIF - ENDDO - ENDDO -!! - 400 CONTINUE -C -C CANOPY RE-EVAPORATION -C - DO I=1,IM - IF(flag_iter(i).and.FLAG(I)) THEN - EC(I) = SIGMAF(I) * CANFAC(I) * EP(I) / HVAP - EC(I) = EC(I) * PARTLND(I) - EC(I) = min(EC(I),CANOPY(I)/delt) - ENDIF - ENDDO -C -C SUM UP TOTAL EVAPORATION -C - DO I = 1, IM - IF(flag_iter(i).and.FLAG(I)) THEN - EVAP(I) = EDIR(I) + EC(I) - ENDIF - ENDDO -!! - DO K = 1, KM - DO I=1,IM - IF(flag_iter(i).and.FLAG(I)) THEN - EVAP(I) = EVAP(I) + ET(I,K) - ENDIF - ENDDO - ENDDO -!! -C -C RETURN EVAP UNIT FROM KG M-2 S-1 TO WATTS M-2 -C - DO I=1,IM - IF(flag_iter(i).and.FLAG(I)) THEN - EVAP(I) = MIN(EVAP(I)*HVAP,EP(I)) - ENDIF - ENDDO -C##DG IF(LAT.EQ.LATD) THEN -C##DG PRINT *, 'FX(I), SIGMAF, EDIR(I), ETPFAC=', FX(I)*HVAP,SIGMAF, -C##DG& EDIR(I)*HVAP,ETPFAC*HVAP -C##DG PRINT *, ' ET =', (ET(K)*HVAP,K=1,KM) -C##DG PRINT *, ' CANFAC(I), EC(I), EVAP', CANFAC(I),EC(I)*HVAP,EVAP -C##DG ENDIF - -C -C TREAT DOWNWARD MOISTURE FLUX SITUATION -C (EVAP WAS PRESET TO ZERO SO NO UPDATE NEEDED) -C DEW IS CONVERTED FROM KG M-2 TO M TO CONFORM TO PRECIP UNIT -C - DO I = 1, IM - FLAG(I) = SLIMSK(I).EQ.1..AND.EP(I).LE.0. - DEW(I) = 0. - ENDDO - DO I = 1, IM - IF(flag_iter(i).and.FLAG(I)) THEN - DEW(I) = -EP(I) * DELT / (HVAP * RHOH2O) - EVAP(I) = EP(I) - DEW(I) = DEW(I) * PARTLND(I) - EVAP(I) = EVAP(I) * PARTLND(I) - DM(I) = 1. - ENDIF - ENDDO -C -C SNOW COVERED LAND -C - DO I = 1, IM - FLAG(I) = SLIMSK(I).EQ.1..AND.SNOWD(I).GT.0. - ENDDO -C -C CHANGE OF SNOW DEPTH DUE TO EVAPORATION OR SUBLIMATION -C -C CONVERT EVAP FROM KG M-2 S-1 TO M S-1 TO DETERMINE THE REDUCTION OF S -C - DO I = 1, IM - IF(flag_iter(i).and.FLAG(I)) THEN - BFACT = SNOWD(I) / (DELT * EP(I) / (HVAP * RHOH2O)) - BFACT = MIN(BFACT,1.) -C -C THE EVAPORATION OF SNOW -C - IF(EP(I).LE.0.) BFACT = 1. - IF(SNOWD(I).LE..001) THEN -c EVAP = (SNOWD(I)/.001)*BFACT*EP(I) + EVAP -! SNOEVP(I) = bfact * EP(I) * (1. - PARTLND(I)) -! EVAP = EVAP + SNOEVP(I) - SNOEVP(I) = bfact * EP(I) -! EVAP = EVAP + SNOEVP(I) * (1. - PARTLND(I)) - EVAP(I)=EVAP(I)+SNOEVP(I)*(1.-PARTLND(I)) - ELSE -c EVAP(I) = BFACT * EP(I) - SNOEVP(I) = bfact * EP(I) - EVAP(I) = SNOEVP(I) - ENDIF - TSEA(I) = T1(I) + - & (RCAP(I) - GFLUX(I) - DFSNOW * (T1(I) - STSOIL(I,1)) - & /(FACTSNW(I) * MAX(SNOWD(I),.001)) -c & + THETA1 - T1 -c & - BFACT * EP(I)) / (RSMALL(I) * RCH(I) - & - SNOEVP(I)) / (RSMALL(I) * RCH(I) - & + DFSNOW / (FACTSNW(I)* MAX(SNOWD(I),.001))) -c SNOWD(I) = SNOWD(I) - BFACT * EP(I) * DELT / (RHOH2O * HVAP) - SNOWD(I) = SNOWD(I) - SNOEVP(I) * delt / (rhoh2o * hvap) - SNOWD(I) = MAX(SNOWD(I),0.) - ENDIF - ENDDO -C -C SNOW MELT (M) -C - 500 CONTINUE - DO I = 1, IM - FLAG(I) = SLIMSK(I).EQ.1. - & .AND.SNOWD(I).GT..0 - ENDDO - DO I = 1, IM - IF(flag_iter(i))THEN - IF(FLAG(I).AND.TSEA(I).GT.T0C) THEN - SNOWMT(I) = RCH(I) * RSMALL(I) * DELT - & * (TSEA(I) - T0C) / (RHOH2O * HFUS) - SNOWMT(I) = min(SNOWMT(I),SNOWD(I)) - SNOWD(I) = SNOWD(I) - SNOWMT(I) - SNOWD(I) = MAX(SNOWD(I),0.) - TSEA(I) = MAX(T0C,TSEA(I) - & -HFUS*SNOWMT(I)*RHOH2O/(RCH(I)*RSMALL(I)*DELT)) - ENDIF - ENDIF - ENDDO -c -c We need to re-evaluate evaporation because of snow melt -c the skin temperature is now bounded to 0 deg C -c -! qss = fpvs(TSEA) - DO I = 1, IM - FLAG(I) = SLIMSK(I).EQ. 1. - IF(flag_iter(i).and.FLAG(I))THEN -! IF (SNOWD(I) .GT. 0.0) THEN - IF (SNOWD(I) .GT. snomin) THEN -cjfe QSS(I) = 1000. * FPVS(TSEA(I)) - qss(i) = fpvs(TSEA(i)) - QSS(I) = EPS * QSS(I) / (PSURF(I) + EPSM1 * QSS(I)) - EVAP(I) = elocp * RCH(I) * (QSS(I) - Q0(I)) - ENDIF - ENDIF - ENDDO -C -C PREPARE TENDENCY TERMS FOR THE SOIL MOISTURE FIELD WITHOUT PRECIPITAT -C THE UNIT OF MOISTURE FLUX NEEDS TO BECOME M S-1 FOR SOIL MOISTURE -C HENCE THE FACTOR OF RHOH2O -C - DO I = 1, IM - IF(flag_iter(i))THEN - if(FLAG(I)) then - DF1(I) = FUNCDF(SMCZ(I),SOILTYP(I)) - KT1(I) = FUNCKT(SMCZ(I),SOILTYP(I)) - endif - if(FLAG(I).and.STC(I,1).lt.t0c) then - DF1(I) = 0. - KT1(I) = 0. - endif - IF(FLAG(I)) THEN - RHSCNPY(I) = -EC(I) + SIGMAF(I) * RHOH2O * DEW(I) / DELT - SMCZ(I) = MAX(SMC(I,1), SMC(I,2)) - DMDZ(I) = (SMC(I,1) - SMC(I,2)) / (-.5 * ZSOIL(I,2)) - RHSMC(I,1) = (DF1(I) * DMDZ(I) + KT1(I) - & + (EDIR(I) + ET(I,1))) / (ZSOIL(I,1) * RHOH2O) - RHSMC(I,1) = RHSMC(I,1) - (1. - SIGMAF(I)) * DEW(I) / - & ( ZSOIL(I,1) * delt) - DDZ(I) = 1. / (-.5 * ZSOIL(I,2)) -C -C AIM, BIM, AND CIM ARE THE ELEMENTS OF THE TRIDIAGONAL MATRIX FOR THE -C IMPLICIT UPDATE OF THE SOIL MOISTURE -C - AIM(I,1) = 0. - BIM(I,1) = DF1(I) * DDZ(I) / (-ZSOIL(I,1) * RHOH2O) - CIM(I,1) = -BIM(I,1) - ENDIF - ENDIF - ENDDO -!! - DO K = 2, KM - IF(K.LT.KM) THEN - DO I=1,IM - IF(flag_iter(i))THEN - IF(FLAG(I)) THEN - DF2 = FUNCDF(SMCZ(I),SOILTYP(I)) - KT2(I) = FUNCKT(SMCZ(I),SOILTYP(I)) - ENDIF - IF(FLAG(I).and.STC(I,k).lt.t0c) THEN - df2 = 0. - KT2(I) = 0. - ENDIF - IF(FLAG(I)) THEN - DMDZ2(I) = (SMC(I,K) - SMC(I,K+1)) - & / (.5 * (ZSOIL(I,K-1) - ZSOIL(I,K+1))) - SMCZ(I) = MAX(SMC(I,K), SMC(I,K+1)) - RHSMC(I,K) = (DF2 * DMDZ2(I) + KT2(I) - & - DF1(I) * DMDZ(I) - KT1(I) + ET(I,K)) - & / (RHOH2O*(ZSOIL(I,K) - ZSOIL(I,K-1))) - DDZ2(I) = 2. / (ZSOIL(I,K-1) - ZSOIL(I,K+1)) - CIM(I,K) = -DF2 * DDZ2(I) - & / ((ZSOIL(I,K-1) - ZSOIL(I,K))*RHOH2O) - ENDIF - ENDIF - ENDDO - ELSE - DO I = 1, IM - IF(flag_iter(i))THEN - IF(FLAG(I)) THEN - KT2(I) = FUNCKT(SMC(I,K),SOILTYP(I)) - ENDIF - if(FLAG(I).and.STC(I,k).lt.t0c) KT2(I) = 0. - IF(FLAG(I)) THEN - RHSMC(I,K) = (KT2(I) - & - DF1(I) * DMDZ(I) - KT1(I) + ET(I,K)) - & / (RHOH2O*(ZSOIL(I,K) - ZSOIL(I,K-1))) - DRAIN(I) = KT2(I) - CIM(I,K) = 0. - ENDIF - ENDIF - ENDDO - ENDIF - DO I = 1, IM - IF(flag_iter(i).and.FLAG(I)) THEN - AIM(I,K) = -DF1(I) * DDZ(I) - & / ((ZSOIL(I,K-1) - ZSOIL(I,K))*RHOH2O) - BIM(I,K) = -(AIM(I,K) + CIM(I,K)) - DF1(I) = DF2 - KT1(I) = KT2(I) - DMDZ(I) = DMDZ2(I) - DDZ(I) = DDZ2(I) - ENDIF - ENDDO - ENDDO -!! - 600 CONTINUE -C -C UPDATE SOIL TEMPERATURE -C - DO I=1,IM -Clu FLAG(I) = SLIMSK(I).NE.0. - FLAG(I) = SLIMSK(I).EQ.1. - ENDDO -C -C SURFACE TEMPERATURE IS PART OF THE UPDATE WHEN SNOW IS ABSENT -C - DO I=1,IM -C IF(FLAG(I).AND.SNOWD(I).LE..001) THEN - IF(flag_iter(i))THEN - IF(FLAG(I).AND..NOT.FLAGSNW(I)) THEN - YY(I) = T1(I) + -c & (RCAP(I)-GFLUX(I) + THETA1 - T1(I) - & (RCAP(I)-GFLUX(I) - & - EVAP(I)) / (RSMALL(I) * RCH(I)) - ZZ(I) = 1. + DFT0(I) / (-.5 * ZSOIL(I,1) * RCH(I) * RSMALL(I)) - XX(I) = DFT0(I) * (STSOIL(I,1) - YY(I)) / - & (.5 * ZSOIL(I,1) * ZZ(I)) - ENDIF -C IF(FLAG(I).AND.SNOWD(I).GT..001) THEN - IF(FLAG(I).AND.FLAGSNW(I)) THEN - YY(I) = STSOIL(I,1) -C -C HEAT FLUX FROM SNOW IS EXPLICIT IN TIME -C - ZZ(I) = 1. - XX(I) = DFSNOW * (STSOIL(I,1) - TSEA(I)) - & / (-FACTSNW(I) * MAX(SNOWD(I),.001)) - ENDIF - ENDIF - ENDDO -C -C COMPUTE THE FORCING AND THE IMPLICIT MATRIX ELEMENTS FOR UPDATE -C -C CH2O IS THE HEAT CAPACITY OF WATER AND CSOIL IS THE HEAT CAPACITY OF -C - DO I = 1, IM - IF(flag_iter(i).and.FLAG(I)) THEN - SMCZ(I) = MAX(SMC(I,1), SMC(I,2)) - DTDZ1(I) = (STSOIL(I,1) - STSOIL(I,2)) / (-.5 * ZSOIL(I,2)) - DFT1(I) = KTSOIL(SMCZ(I),SOILTYP(I)) - HCPCT(I) = SMC(I,1) * CH2O + (1. - SMC(I,1)) * CSOIL - DFT2(I) = DFT1(I) - DDZ(I) = 1. / (-.5 * ZSOIL(I,2)) -C -C AI, BI, AND CI ARE THE ELEMENTS OF THE TRIDIAGONAL MATRIX FOR THE -C IMPLICIT UPDATE OF THE SOIL TEMPERATURE -C - AI(I,1) = 0. - BI(I,1) = DFT1(I) * DDZ(I) / (-ZSOIL(I,1) * HCPCT(I)) - CI(I,1) = -BI(I,1) - BI(I,1) = BI(I,1) - & + DFT0(I) / (.5 * ZSOIL(I,1) **2 * HCPCT(I) * ZZ(I)) -C SS = DFT0(I) * (STSOIL(I,1) - YY(I)) -C & / (.5 * ZSOIL(I,1) * ZZ(I)) -C RHSTC(1) = (DFT1(I) * DTDZ1(I) - SS) - RHSTC(I,1) = (DFT1(I) * DTDZ1(I) - XX(I)) - & / (ZSOIL(I,1) * HCPCT(I)) - ENDIF - ENDDO -!! - DO K = 2, KM - DO I=1,IM - IF(flag_iter(i).and.FLAG(I)) THEN - HCPCT(I) = SMC(I,K) * CH2O + (1. - SMC(I,K)) * CSOIL - ENDIF - ENDDO - IF(K.LT.KM) THEN - DO I = 1, IM - IF(flag_iter(i).and.FLAG(I)) THEN - DTDZ2(I) = (STSOIL(I,K) - STSOIL(I,K+1)) - & / (.5 * (ZSOIL(I,K-1) - ZSOIL(I,K+1))) - SMCZ(I) = MAX(SMC(I,K), SMC(I,K+1)) - DFT2(I) = KTSOIL(SMCZ(I),SOILTYP(I)) - DDZ2(I) = 2. / (ZSOIL(I,K-1) - ZSOIL(I,K+1)) - CI(I,K) = -DFT2(I) * DDZ2(I) - & / ((ZSOIL(I,K-1) - ZSOIL(I,K)) * HCPCT(I)) - ENDIF - ENDDO - ELSE -C -C AT THE BOTTOM, CLIMATOLOGY IS ASSUMED AT 2M DEPTH FOR LAND AND -C FREEZING TEMPERATURE IS ASSUMED FOR SEA ICE AT Z(KM) - DO I = 1, IM - IF(flag_iter(i).and.FLAG(I)) THEN - DTDZ2(I) = (STSOIL(I,K) - TG3(I)) - & / (.5 * (ZSOIL(I,K-1) + ZSOIL(I,K)) - ZBOT) - DFT2(I) = KTSOIL(SMC(I,K),SOILTYP(I)) - CI(I,K) = 0. - ENDIF - ENDDO - ENDIF - DO I = 1, IM - IF(flag_iter(i).and.FLAG(I)) THEN - RHSTC(I,K) = (DFT2(I) * DTDZ2(I) - DFT1(I) * DTDZ1(I)) - & / ((ZSOIL(I,K) - ZSOIL(I,K-1)) * HCPCT(I)) - AI(I,K) = -DFT1(I) * DDZ(I) - & / ((ZSOIL(I,K-1) - ZSOIL(I,K)) * HCPCT(I)) - BI(I,K) = -(AI(I,K) + CI(I,K)) - DFT1(I) = DFT2(I) - DTDZ1(I) = DTDZ2(I) - DDZ(I) = DDZ2(I) - ENDIF - ENDDO - ENDDO -!! - 700 CONTINUE -C -C SOLVE THE TRI-DIAGONAL MATRIX -C - DO K = 1, KM - DO I=1,IM - IF(flag_iter(i).and.FLAG(I)) THEN - RHSTC(I,K) = RHSTC(I,K) * DELT2 - AI(I,K) = AI(I,K) * DELT2 - BI(I,K) = 1. + BI(I,K) * DELT2 - CI(I,K) = CI(I,K) * DELT2 - ENDIF - ENDDO - ENDDO -C FORWARD ELIMINATION - DO I=1,IM - IF(flag_iter(i).and.FLAG(I)) THEN - CI(I,1) = -CI(I,1) / BI(I,1) - RHSTC(I,1) = RHSTC(I,1) / BI(I,1) - ENDIF - ENDDO -!! - DO K = 2, KM - DO I=1,IM - IF(flag_iter(i).and.FLAG(I)) THEN - CC = 1. / (BI(I,K) + AI(I,K) * CI(I,K-1)) - CI(I,K) = -CI(I,K) * CC - RHSTC(I,K) = (RHSTC(I,K) - AI(I,K) * RHSTC(I,K-1)) * CC - ENDIF - ENDDO - ENDDO -!! -C BACKWARD SUBSTITUTTION - DO I=1,IM - IF(flag_iter(i).and.FLAG(I)) THEN - CI(I,KM) = RHSTC(I,KM) - ENDIF - ENDDO -!! - DO K = KM-1, 1 - DO I=1,IM - IF(flag_iter(i).and.FLAG(I)) THEN - CI(I,K) = CI(I,K) * CI(I,K+1) + RHSTC(I,K) - ENDIF - ENDDO - ENDDO -C -C UPDATE SOIL AND ICE TEMPERATURE -C - DO K = 1, KM - DO I=1,IM - IF(flag_iter(i).and.FLAG(I)) THEN - STSOIL(I,K) = STSOIL(I,K) + CI(I,K) - ENDIF - ENDDO - ENDDO -C -C UPDATE SURFACE TEMPERATURE FOR SNOW FREE SURFACES -C - DO I=1,IM - IF(flag_iter(i))THEN - IF(FLAG(I).AND..NOT.FLAGSNW(I)) THEN - TSEA(I) = (YY(I) + (ZZ(I) - 1.) * STSOIL(I,1)) / ZZ(I) - ENDIF - ENDIF - ENDDO -!! -C -C TIME FILTER FOR SOIL AND SKIN TEMPERATURE -C - DO I=1,IM - IF(flag_iter(i).and. FLAG(I)) THEN - TSURF(I) = CTFIL1 * TSEA(I) + CTFIL2 * TSURF(I) - ENDIF - ENDDO - DO K = 1, KM - DO I=1,IM - IF(flag_iter(i).and. FLAG(I)) THEN - STC(I,K) = CTFIL1 * STSOIL(I,K) + CTFIL2 * STC(I,K) - ENDIF - ENDDO - ENDDO -C -C GFLUX CALCULATION -C -c DO I=1,IM -c FLAG(I) = SLIMSK(I).EQ.1. -c & .AND.FLAGSNW(I) -c ENDDO - DO I = 1, IM - IF(flag_iter(i).and.FLAG(I)) THEN - if(FLAGSNW(I))then - GFLUX(I) = -DFSNOW * (TSURF(I) - STC(I,1)) - & / (FACTSNW(I) * MAX(SNOWD(I),.001)) - else - GFLUX(I) = DFT0(I) * (STC(I,1) - TSURF(I)) - & / (-.5 * ZSOIL(I,1)) - endif - ENDIF - ENDDO -c DO I = 1, IM -c FLAG(I) = SLIMSK(I).EQ.1. -c IF(flag_iter(i))THEN -c IF(FLAG(I).AND..NOT.FLAGSNW(I)) THEN -c GFLUX(I) = DFT0(I) * (STC(I,1) - TSURF(I)) -c & / (-.5 * ZSOIL(I,1)) -c ENDIF -c ENDIF -c ENDDO -C -C CALCULATE SENSIBLE HEAT FLUX -C - DO I = 1, IM - IF(flag_iter(i).and. FLAG(I)) THEN - HFLX(I) = RCH(I) * (TSURF(I) - THETA1(I)) - ENDIF - ENDDO -C -C THE REST OF THE OUTPUT -C - DO I = 1, IM - IF(flag_iter(i).and. FLAG(I)) THEN - QSURF(I) = Q1(I) + EVAP(I) / (ELOCP * RCH(I)) - DM(I) = 1. -C -Cwei added 10/24/2006 - EVBS(I)=EDIR(I) - EVCW(I)=EC(I) - SBSNO(I)=SNOEVP(I) - SNOWC(I)=1-PARTLND(I) - STM(I)=-1.0*SMC(I,1)*ZSOIL(I,1) - SNOHF(I)=DFSNOW * (T1(I) - STSOIL(I,1)) - TRANS(I)=ET(I,1) - DO K=2,KM - STM(I)=STM(I)+SMC(I,K)*(ZSOIL(I,K-1)-ZSOIL(I,K)) - TRANS(I)=TRANS(I)+ET(I,K) - ENDDO -C CONVERT SNOW DEPTH BACK TO MM OF WATER EQUIVALENT -C - SHELEG(I) = SNOWD(I) * 1000. - ENDIF - ENDDO -! - do i=1,im - IF(flag_iter(i).and. FLAG(I)) THEN - tem = 1.0 / rho(i) - hflx(i) = hflx(i) * tem * cpinv - evap(i) = evap(i) * tem * hvapi - ENDIF - enddo - -Clu_q2m_iter [+17L]: restore land-related prognostic fields for guess run - do i=1, im - IF(FLAG(I)) THEN - if(flag_guess(i)) then - sheleg(i) = sheleg_old(i) - tskin(i) = tskin_old(i) - canopy(i) = canopy_old(i) - tprcp(i) = tprcp_old(i) - srflag(i) = srflag_old(i) - do k=1, km - stc(i,k) = stc_old(i,k) - enddo - else - tskin(i) = tsurf(i) - endif - ENDIF - enddo - -! -C##DG IF(LAT.EQ.LATD) THEN -CC RBAL = -SLWD-SIGMA*TSKIN**4+GFLUX -CC & -EVAP - HFLX -C##DG PRINT 6000,HFLX,EVAP,GFLUX, -C##DG& STC(1), STC(2),TSKIN,RNET,SLWD -C##DG PRINT *, ' T1 =', T1 - 6000 FORMAT(8(F8.2,',')) -CC PRINT *, ' EP, ETP,T2M(I) =', EP, ETP,T2M(I) -CC PRINT *, ' FH, FH2 =', FH, FH2 -CC PRINT *, ' PH, PH2 =', PH, PH2 -CC PRINT *, ' CH, RCH =', CH, RCH -CC PRINT *, ' TERM1, TERM2 =', TERM1, TERM2 -CC PRINT *, ' RS(I), PLANTR =', RS(I), PLANTR -C##DG ENDIF - RETURN - END diff --git a/src/fim/FIMsrc/fim/column/sfc_nsstac.f b/src/fim/FIMsrc/fim/column/sfc_nsstac.f deleted file mode 100755 index 169e0dc..0000000 --- a/src/fim/FIMsrc/fim/column/sfc_nsstac.f +++ /dev/null @@ -1,333 +0,0 @@ - - SUBROUTINE SFC_NSSTAC(IM,KM,PS,U1,V1,T1,Q1, - & TSKIN,QSURF,DM,GFLUX,CM,CH, - & RCL,PRSL1,PRSLKI,SLIMSK, - & xlon,sinlat,stress,DLWFLX,SLRAD, - & rain,timestep,kdt, ! input - + ifd,time_old,time_ins,I_Sw,I_Q,I_Qrain, - + I_M,I_Tau,I_Sw_Zw,I_Q_Ts,I_M_Ts, - + Tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d, - - & CMM,CHH, - & EVAP,HFLX,EP,DDVEL,flag_iter, - & lprnt, ipr) -! - USE MACHINE , ONLY : kind_phys - USE FUNCPHYS, ONLY : fpvs - USE PHYSCONS, HVAP => con_HVAP - &, CP => con_CP, HFUS => con_HFUS - &, EPS => con_eps, EPSM1 => con_epsm1 - &, RVRDM1 => con_FVirt, RD => con_RD - &, RHW0 => con_rhw0, SBC => con_sbc, pi => con_pi - USE date_def, only: idate - USE module_nsst_parameters, ONLY : t0K,cp_w - USE module_nsst_water_prop, ONLY : solar_time_from_julian, - & density, rhocoef, compjd - USE ocean_model, ONLY : - & cool_skin,warm_layer,jacobi_temp -! USE resol_def, ONLY : nr_ocn,nf_ocn - USE layout1 - implicit none -! - integer IM, km - integer ipr - logical lprnt, lprint -! - real(kind=kind_phys), parameter :: cpinv=1.0/cp, HVAPI=1.0/HVAP, - & rad2deg=180./pi -! real (kind=kind_phys), parameter :: EMISSIV=0.97 - real (kind=kind_phys), parameter :: EMISSIV=1.0 - real (kind=kind_phys), parameter :: f24 = 24.0 ! hours/day - real (kind=kind_phys), parameter :: f1440 = 1440.0 ! minutes/day - real(kind=kind_phys) PS(IM), U1(IM), V1(IM), - & T1(IM), Q1(IM), - & TSKIN(IM), QSURF(IM), DM(IM), - & GFLUX(IM), - & CM(IM), CH(IM), RCL(IM), - & PRSL1(IM), PRSLKI(IM), SLIMSK(IM), - & EVAP(IM), HFLX(IM), - & EP(IM), DDVEL(IM) - &, CMM(IM), CHH(IM) - - logical flag_iter(im), FLAG(IM) - -! -! Locals -! - integer :: k,i,kdt -! - real(kind=kind_phys) PSURF(IM), PS1(IM), Q0(IM), - & QSS(IM), RCH(IM), RHO(IM), - & THETA1(IM), TV1(IM), XRCL(IM), - & WIND(IM), STRESS(IM), USTAR_A(IM), - & USTAR_W(IM), XLON(IM), SINLAT(IM), - & ULWFLX(IM), DLWFLX(IM), SLRAD(IM), - & NSWSFC(IM), ALPHA(IM), BETA(IM), - & RHW(IM), QPRATE(IM), PRATE(IM), - & F_nsol(IM), rain(IM), z_w_prev(IM), - & soltim(IM), Qrain(IM) - - real(kind=kind_phys) ifd(im), time_old(im), time_ins(im), - & I_Sw(im), I_Q(im), I_Qrain(im), - & I_M(im), I_Tau(im), I_Sw_Zw(im), - & I_Q_Ts(im), I_M_Ts(im), Tref(im), - & dt_cool(im), z_c(im), dt_warm(im), - & z_w(im), c_0(im), c_d(im), - & w_0(im), w_d(im) - -!=============================================================================== -! Li added for oceanic components -! -! variables required for restart oceanic model -! Index of time integral started mode : ifd -! Solar time at previous time : time_old -! The period of time integral : time_ins -! Time integral of solar radiation flux : I_Sw -! Time integral of non-solar heat flux : I_Q -! Time integral of rain caused sensible heat flux : I_Qrain -! Time integral of mass flux S(E-P) : I_M -! Time integral of momentum flux : I_Tau -! Time integral of d(I_Sw)/d(z_w) : I_Sw_Zw -! Time integral of d(I_Q)/d(Ts) : I_Q_Ts -! Time integral of d(I_M)/d(Ts) : I_M_Ts - -! variables required for GSI -! Reference/foundation temperature : T_ref -! Sub-layer cooling amount : dt_cool -! Sub-layer cooling thickness : z_c -! Diurnal warming amount : dt_warm -! Diurnal warming layer depth : z_w -! W_0 (time integral) -! W_d (time integral) -! C_0 (current time step) -! C_d (current time step) - - integer :: iyear,imon,iday,ihr,imin,jd - integer :: idat(8),jdat(8) - real(kind=kind_phys) elocp,tem,sss,Le,dwat,dtmp,wetc,alfac - real(kind=kind_phys) Hs_Ts,Hl_Ts,RF_Ts - real(kind=kind_phys) rinc(5) - real(kind=kind_phys) timestep,jday,jday_old - real(kind=kind_phys) t12,t14,alon,es,Qs - - - real (kind=kind_phys) :: jdf_tmp,fjd - real (kind=kind_phys) :: fjd1,jd1,jd0 - -! external functions called: iw3jdn - integer :: iw3jdn -!====================================================================================================== -cc - PARAMETER (ELOCP=HVAP/CP) - - - sss = 34.0 ! temporarily, when sea surface salinity data is not ready - - idat(1) = idate(4) - idat(2) = idate(2) - idat(3) = idate(3) - idat(4) = 0 - idat(5) = idate(1) - idat(6) = 0 - idat(7) = 0 - idat(8) = 0 -! write(*,*) ' sfc_nsstac, idat : ',idat - rinc(1) = 0. - rinc(2) = 0. - rinc(3) = float(kdt)*timestep/60.0 - rinc(4) = 0. - rinc(5) = 0. - call w3movdat(rinc, idat, jdat) - - iyear = jdat(1) - imon = jdat(2) - iday = jdat(3) - ihr = jdat(5) - imin = jdat(6) - -! --- ... calculate forecast julian day and fraction of julian day - - jd0 = iw3jdn(1899,12,31) - jd1 = iw3jdn(iyear,imon,iday) - -! --- ... unlike in normal applications, where day starts from 0 hr, -! in astronomy applications, day stats from noon. - - if (ihr < 12) then - jd1 = jd1 - 1 - fjd1= 0.5 + float(ihr)/f24 + float(imin)/f1440 - else - fjd1= float(ihr - 12)/f24 + float(imin)/f1440 - endif - - jday = jd1 - jd0 + fjd1 -C -C FLAG for open water -C - DO I = 1, IM - FLAG(I) = SLIMSK(I).EQ. 0. .AND. flag_iter(i) - ENDDO - -C -C INITIALIZE VARIABLES. ALL UNITS ARE M.K.S. UNLESS SPECIFIED -C PSURF IS IN PASCALS -C WIND IS WIND SPEED, THETA1 IS ADIABATIC SURFACE TEMP FROM LEVEL 1 -C RHO IS AIR DENSITY, QSS IS SAT. HUM. AT SURFACE -C -! if (lprnt) print *,' t1=',t1(ipr),' prslki=',prslki(ipr) -!! - DO I=1,IM - IF(FLAG(I)) THEN -! ocnf(i,1) = TSKIN(I) - NSWSFC(I) = -SLRAD(I) - DLWFLX(I) ! net solar radiation at the air-sea surface (positive = downward) - - XRCL(I) = SQRT(RCL(I)) - PSURF(I) = 1000. * PS(I) - PS1(I) = 1000. * PRSL1(I) - WIND(I) = XRCL(I) * SQRT(U1(I) * U1(I) + V1(I) * V1(I)) - & + MAX(0.0, MIN(DDVEL(I), 30.0)) - WIND(I) = MAX(WIND(I),1.) - Q0(I) = MAX(Q1(I),1.E-8) - THETA1(I) = T1(I) * PRSLKI(I) - TV1(I) = T1(I) * (1. + RVRDM1 * Q0(I)) - RHO(I) = PS1(I) / (RD * TV1(I)) - QSS(I) = FPVS(TSKIN(I)) ! Pa - QSS(I) = EPS * QSS(I) / (PSURF(I) + EPSM1 * QSS(I)) ! Pa - - CALL density(TSKIN(I),SSS,RHW(I)) ! Sea water density - CALL rhocoef(TSKIN(I),SSS,RHW(I),ALPHA(I),BETA(I)) ! alpha & beta - - USTAR_A(I) = SQRT(STRESS(I)/RHO(I)) ! friction velocity in air -! - EVAP(I) = 0. - HFLX(I) = 0. - GFLUX(I) = 0. - EP(I) = 0. -! -! RCP = RHO CP CH V -! - RCH(I) = RHO(I) * CP * CH(I) * WIND(I) -Cwei added 10/24/2006 - CMM(I) = CM(I)* WIND(I) - CHH(I) = RHO(I)*CH(I)* WIND(I) -! -! LATENT and SENSIBLE HEAT FLUX OVER OPEN WATER with TSKIN -! at previous time step - EVAP(I) = ELOCP * RCH(I) * (QSS(I) - Q0(I)) - QSURF(I) = QSS(I) - HFLX(I) = RCH(I) * (TSKIN(I) - THETA1(I)) - ENDIF - ENDDO -!! -! if (lprnt) print *,' tskin=',tskin(ipr),' theta1=', -! &theta1(ipr),' hflx=',hflx(ipr) -! -! CALCULATE (1) Sub-layer cooling amount and thickness -! (2) Diurnal warming amount and depth -! (3) Coefficients to calculate Jacobian or sensitivity -! of Tz to Tref required in GSI -! UPDATE TSKIN -! - - DO I = 1, IM - lprint = .false. - if (lprnt .and. i == ipr) lprint = .true. - IF(FLAG(I)) THEN - t12 = TSKIN(i)*TSKIN(i) -! t14 = t12*t12 - ULWFLX(I) = emissiv*sbc*t12*t12 - alon = xlon(i)*rad2deg - - CALL solar_time_from_julian(jday,alon,soltim(i)) - - time_old(i) = max(0.0, soltim(i)-timestep) -! if ( time_old(i) < 0.0 ) then -! time_old(i) = 0.0 -! endif - - F_nsol(i) = HFLX(I) + EVAP(I) + ULWFLX(I) - DLWFLX(I) ! input heat flux as upward = positive to models here - - call cool_skin(ustar_a(i),alpha(i),beta(i),rhw(i),rho(i), - & TSKIN(i), - & F_nsol(i),NSWSFC(i),sss,evap(i),sinlat(i), - & dt_cool(i),z_c(i)) -! -! for sensible heat flux caused by rainfall -! - Le = (2.501-.00237*TSKIN(I))*1e6 - dwat = 2.11e-5*(T1(I)/t0K)**1.94 !! water vapour diffusivity - dtmp = (1.+3.309e-3*(T1(I)-t0K)-1.44e-6*(T1(I)-t0K)* - & (T1(I)-t0K))*0.02411/(RHO(I)*CP) !! heat diffusivity - wetc = 622.0*Le*QSS(I)/(RD*T1(I)*T1(I)) - alfac = 1/(1+(wetc*Le*dwat)/(CP*dtmp)) !! wet bulb factor - Qrain(I) = (1000.*rain(I)/RHW0)*alfac*cp_w* - & (TSKIN(I)-T1(I)+(1000.*QSS(I)-1000.*Q0(I))*Le/CP) - - if (lprnt .and. i == ipr) then - print *,' dt_cool=',dt_cool(i),' tskin=',tskin(i),' qrain=', - & qrain(i),' qss=',qss(i),' q0=',q0(i),' rain=',rain(i), - & ' t1=',t1(i) - endif - - call warm_layer(alpha(i),beta(i),sss,rhw(i),NSWSFC(i), - & F_nsol(i),stress(i),evap(i),rain(i), - & Qrain(i),TSKIN(i), - & timestep,sinlat(i),soltim(i), - + ifd(i),time_old(i),time_ins(i),I_Sw(i), - & I_Q(i),I_Qrain(i), - + I_M(i),I_Tau(i),dt_warm(i),z_w(i), - & kdt,lprint) - - if (lprnt .and. i == ipr) print *,' kdt=',kdt,' dt_warm=', - & dt_warm(ipr) - - Hs_Ts = rch(i) - Hl_Ts = rch(i)*elocp*eps*hvap*qss(i)/(rd*t12) - RF_Ts = (1000.*rain(i)/RHW0)*alfac*cp_w*(1+rch(i)*Hl_Ts) - - call Jacobi_Temp - & (alpha(i),beta(i),sss,T1(i),PS1(i),Q0(i),ustar_a(i),rhw(i), - & rho(i),rain(i),EVAP(i),HFLX(i),DLWFLX(i),ULWFLX(i),NSWSFC(i), - & TSKIN(i),timestep,sinlat(i),soltim(i),Hs_Ts,Hl_Ts,RF_Ts, - & I_Sw(i),I_Q(i),I_M(i),I_Sw_Zw(i),I_Q_Ts(i),I_M_Ts(i), - & dt_cool(i),z_c(i),dt_warm(i),z_w(i), - & c_0(i),c_d(i),w_0(i),w_d(i), - & kdt) - -! if ( rain(i) > 0.001 ) then -! write(*,'(a,2F10.6,2F10.3,5F10.6,F11.4,3F10.6)') 'Qprate: ', -! & QSS(i),Q0(i),TSKIN(i),T1(i),dwat,dtmp, -! & wetc,alfac,rain(i),Qrain(i), -! & Hs_Ts,Hl_Ts,RF_Ts -! endif - - ENDIF - ENDDO - -! -! LATENT AND SENSIBLE HEAT FLUX OVER OPEN WATER with updated TSKIN -! - DO I = 1, IM - IF(FLAG(I)) THEN - TSKIN(i) = Tref(i) + dt_warm(i) - dt_cool(i) - QSS(I) = FPVS(TSKIN(I)) - QSS(I) = EPS * QSS(I) / (PSURF(I) + EPSM1 * QSS(I)) - DM(I) = 1. - QSURF(I) = QSS(I) - tem = 1.0 / rho(i) - EVAP(I) = ELOCP * RCH(I) * (QSS(I) - Q0(I)) * tem * hvapi - HFLX(I) = RCH(I) * (TSKIN(I) - THETA1(I)) * tem * cpinv - ENDIF - ENDDO -!! -C -C THE REST OF THE OUTPUT <---- Note: Redundant calculation -C -!* DO I = 1, IM -!* IF(SLIMSK(I).EQ.0.) THEN -!* QSURF(I) = Q1(I) + EVAP(I) / (ELOCP * RCH(I)) -!* DM(I) = 1. -!* ENDDO -! - RETURN - END diff --git a/src/fim/FIMsrc/fim/column/sfc_ocean.f b/src/fim/FIMsrc/fim/column/sfc_ocean.f deleted file mode 100644 index 72f7452..0000000 --- a/src/fim/FIMsrc/fim/column/sfc_ocean.f +++ /dev/null @@ -1,135 +0,0 @@ - - SUBROUTINE SFC_OCEAN(IM,KM,PS,U1,V1,T1,Q1, - & TSKIN,QSURF,DM,GFLUX,CM,CH, - & RCL,PRSL1,PRSLKI,SLIMSK, - & CMM,CHH, - + EVAP,HFLX,EP,DDVEL,flag_iter) -! - USE MACHINE , ONLY : kind_phys - USE FUNCPHYS, ONLY : fpvs - USE PHYSCONS, HVAP => con_HVAP - &, CP => con_CP, HFUS => con_HFUS, JCAL => con_JCAL - &, EPS => con_eps, EPSM1 => con_epsm1 - &, RVRDM1 => con_FVirt, RD => con_RD - implicit none -! -! include 'constant.h' -! - integer IM, km -! - real(kind=kind_phys), parameter :: cpinv=1.0/cp, HVAPI=1.0/HVAP - real(kind=kind_phys) PS(IM), U1(IM), V1(IM), - & T1(IM), Q1(IM), - & TSKIN(IM), QSURF(IM), DM(IM), - & GFLUX(IM), - & CM(IM), CH(IM), RCL(IM), - & PRSL1(IM), PRSLKI(IM), SLIMSK(IM), - & EVAP(IM), HFLX(IM), - & EP(IM), DDVEL(IM) - &, CMM(IM), CHH(IM) - - logical flag_iter(im), FLAG(IM) - -! -! Locals -! - integer k,i -! - real(kind=kind_phys) PSURF(IM), PS1(IM), Q0(IM), - & QSS(IM), RCH(IM), RHO(IM), - & THETA1(IM), TV1(IM), XRCL(IM), - & WIND(IM) -! - real(kind=kind_phys) elocp, tem -cc - PARAMETER (ELOCP=HVAP/CP) - -C -C FLAG for open water -C - DO I = 1, IM - FLAG(I) = SLIMSK(I).EQ. 0. .AND. flag_iter(i) - ENDDO - -C -C INITIALIZE VARIABLES. ALL UNITS ARE SUPPOSEDLY M.K.S. UNLESS SPECIFIED -C PSURF IS IN PASCALS -C WIND IS WIND SPEED, THETA1 IS ADIABATIC SURFACE TEMP FROM LEVEL 1 -C RHO IS DENSITY, QSS IS SAT. HUM. AT SURFACE -C -!! - DO I=1,IM - IF(FLAG(I)) THEN - XRCL(I) = SQRT(RCL(I)) - PSURF(I) = 1000. * PS(I) - PS1(I) = 1000. * PRSL1(I) - WIND(I) = XRCL(I) * SQRT(U1(I) * U1(I) + V1(I) * V1(I)) - & + MAX(0.0, MIN(DDVEL(I), 30.0)) - WIND(I) = MAX(WIND(I),1.) - Q0(I) = MAX(Q1(I),1.E-8) - THETA1(I) = T1(I) * PRSLKI(I) - TV1(I) = T1(I) * (1. + RVRDM1 * Q0(I)) - RHO(I) = PS1(I) / (RD * TV1(I)) - qss(i) = fpvs(tskin(i)) - QSS(I) = EPS * QSS(I) / (PSURF(I) + EPSM1 * QSS(I)) - ENDIF - ENDDO - - DO I=1,IM - IF(FLAG(I)) THEN - EVAP(I) = 0. - HFLX(I) = 0. - GFLUX(I) = 0. - EP(I) = 0. - ENDIF - ENDDO - -C -C RCP = RHO CP CH V -C - DO I = 1, IM - IF(FLAG(I)) THEN - RCH(I) = RHO(I) * CP * CH(I) * WIND(I) -Cwei added 10/24/2006 - CMM(I)=CM(I)* WIND(I) - CHH(I)=RHO(I)*CH(I)* WIND(I) - ENDIF - ENDDO -C -C SENSIBLE AND LATENT HEAT FLUX OVER OPEN WATER -C - DO I = 1, IM - IF(FLAG(I)) THEN - EVAP(I) = ELOCP * RCH(I) * (QSS(I) - Q0(I)) - DM(I) = 1. - QSURF(I) = QSS(I) - ENDIF - ENDDO -!! -C -C CALCULATE SENSIBLE HEAT FLUX -C - DO I = 1, IM - IF(FLAG(I)) THEN - HFLX(I) = RCH(I) * (TSKIN(I) - THETA1(I)) - ENDIF - ENDDO -C -C THE REST OF THE OUTPUT <---- Note: Redundant calculation -C -!* DO I = 1, IM -!* IF(SLIMSK(I).EQ.0.) THEN -!* QSURF(I) = Q1(I) + EVAP(I) / (ELOCP * RCH(I)) -!* DM(I) = 1. -!* ENDDO -! - do i=1,im - IF(FLAG(I)) THEN - tem = 1.0 / rho(i) - hflx(i) = hflx(i) * tem * cpinv - evap(i) = evap(i) * tem * hvapi - ENDIF - enddo -! - RETURN - END diff --git a/src/fim/FIMsrc/fim/column/sfc_sice.f b/src/fim/FIMsrc/fim/column/sfc_sice.f deleted file mode 100644 index 6963fad..0000000 --- a/src/fim/FIMsrc/fim/column/sfc_sice.f +++ /dev/null @@ -1,587 +0,0 @@ - SUBROUTINE SFC_SICE(IM,KM,PS,U1,V1,T1,Q1, - & HICE ,FICE ,TICE, SFCDSW, - & SHELEG,SNWDPH,TSKIN,QSURF,TPRCP,SRFLAG,STC,DM, - & DLWFLX,SLRAD,SNOWMT,DELT,GFLUX,CM,CH, - & RCL,PRSL1,PRSLKI,SLIMSK, - + CMM,CHH,ZLVL, -Clu_q2m_iter [-1L/+1L]: add flag_iter -!* & EVAP,HFLX,EP,DDVEL) - & EVAP,HFLX,EP,DDVEL,flag_iter,MOM4ICE,lsm) -! - USE MACHINE , ONLY : kind_phys - USE FUNCPHYS, ONLY : fpvs - USE PHYSCONS, SBC => con_sbc, HVAP => con_HVAP, TGICE => con_tice - &, CP => con_CP, HFUS => con_HFUS, JCAL => con_JCAL - &, EPS => con_eps, EPSM1 => con_epsm1, grav => con_g - &, RVRDM1 => con_FVirt, T0C => con_T0C, RD => con_RD - implicit none -! -! include 'constant.h' -! - integer IM, km, kmi, lsm -! - real(kind=kind_phys), parameter :: cpinv=1.0/cp, HVAPI=1.0/HVAP - real(kind=kind_phys) DELT - real(kind=kind_phys) PS(IM), U1(IM), V1(IM), - & T1(IM), Q1(IM), SHELEG(IM), - & TSKIN(IM), QSURF(IM), STC(IM,KM), - & DM(IM), DLWFLX(IM), SLRAD(IM), - & SNOWMT(IM), GFLUX(IM), - & CM(IM), CH(IM), - & RCL(IM), PRSL1(IM), PRSLKI(IM), - & SLIMSK(IM), EVAP(IM), HFLX(IM), - & RNET(IM), EP(IM), DDVEL(IM) - &, TPRCP(IM), SRFLAG(IM) - &, SFCDSW(IM), FICE(IM), HICE(IM) - &, CMM(IM),CHH(IM),ZLVL(IM) - &, SNWDPH(IM) - real(kind=kind_phys) TICE(IM), FFW(IM), EVAPI(IM), - & EVAPW(IM), HFLXI(IM), HFLXW(IM), - & SNETI(IM), SNETW(IM), QSSI(IM), - & QSSW(IM) - real(kind=kind_phys) hf(IM), hfd(IM), hfi(IM), - & hfw(IM), focn(IM), snof(IM) - real(kind=kind_phys) hi_save(IM), hs_save(IM) - -Clu_q2m_iter [+1L]: add flag_iter - logical flag_iter(im) - -! -! Locals -! - integer k,i -! - real(kind=kind_phys) - & PSURF(IM), Q0(IM), QS1(IM), - & QSS(IM), RCAP(IM), RCH(IM), - & RHO(IM), SLWD(IM), SNET(IM), - & SNOEVP(IM), SNOWD(IM),THETA1(IM), - & TSURF(IM), TV1(IM), XRCL(IM), - & PS1(IM), WIND(IM) -! - real(kind=kind_phys) - & elocp, sigma, cimin, himin, - & himax, hsmax, timin, - & t12, t14, tem - real(kind=kind_phys) albfw, emissiv -! -cc - PARAMETER (kmi=2) ! 2-layer of ice - PARAMETER (sigma=sbc) - PARAMETER (ELOCP=HVAP/CP) -! PARAMETER (CIMIN=0.15) ! minimum ice concentration required - PARAMETER (HIMAX=8.0) ! maximum ice thickness allowed - PARAMETER (HIMIN=0.1) ! minimum ice thickness required - PARAMETER (HSMAX=2.) ! maximum snow depth allowed - PARAMETER (TIMIN=173.) ! minimum temperature allowed for snow/ice -! PARAMETER (CICE=1880.*917.) - PARAMETER (ALBFW=0.06) ! Albedo for lead -! PARAMETER (EMISSIV=0.95) ! emissivity of snow and ice - PARAMETER (EMISSIV=1.0) ! emissivity of snow and ice - real, PARAMETER :: DSI=1.0/0.33 -! - LOGICAL FLAG(IM), FLAGSNW(IM) - LOGICAL MOM4ICE - real(kind=kind_phys) STSICE(IM,KMI) - - IF (MOM4ICE) then - CIMIN=0.15 ! MOM4ICE and MASK - ELSE - CIMIN=0.50 ! GFS ONLY - ENDIF - -! -C -C FLAG for sea-ice -C - DO I = 1, IM - FLAG(I) = SLIMSK(I).GE.2. .AND. flag_iter(i) - ENDDO - IF (MOM4ICE) then - DO I = 1, IM - IF(FLAG(I)) THEN - HI_save(I)=HICE(I) - HS_save(I)=SHELEG(I)*0.001 - ENDIF - ENDDO - ENDIF - DO I = 1, IM - IF (flag_iter(i).AND.SLIMSK(I).LT.1.5) THEN - HICE(I )= 0. - FICE(I )= 0. - ENDIF - ENDDO -C -C snow-rain detection -C - if (.not. mom4ice .and. lsm > 0) then - DO I=1,IM - IF(FLAG(I)) THEN - IF(SRFLAG(I) .EQ. 1.) THEN - EP(I) = 0. - SHELEG(i) = SHELEG(i) + 1.E3*TPRCP(i) - TPRCP(i) = 0. - ENDIF - ENDIF - ENDDO - endif - -C -C INITIALIZE VARIABLES. ALL UNITS ARE SUPPOSEDLY M.K.S. UNLESS SPECIFIE -C PSURF IS IN PASCALS -C WIND IS WIND SPEED, THETA1 IS ADIABATIC SURFACE TEMP FROM LEVEL 1 -C RHO IS DENSITY, QS1 IS SAT. HUM. AT LEVEL1 AND QSS IS SAT. HUM. AT -C SURFACE -C CONVERT SLRAD TO THE CIVILIZED UNIT FROM LANGLEY MINUTE-1 K-4 -C -! qs1 = fpvs(t1) -! qss = fpvs(tskin) - DO I=1,IM - IF(FLAG(I)) THEN - XRCL(I) = SQRT(RCL(I)) - PSURF(I) = 1000. * PS(I) - PS1(I) = 1000. * PRSL1(I) - SLWD(I) = SLRAD(I) -c -c DLWFLX has been given a negative sign for downward longwave -c snet is the net shortwave flux -c - SNET(I) = -SLWD(I) - DLWFLX(I) - WIND(I) = XRCL(I) * SQRT(U1(I) * U1(I) + V1(I) * V1(I)) - & + MAX(0.0, MIN(DDVEL(I), 30.0)) - WIND(I) = MAX(WIND(I),1.) - Q0(I) = MAX(Q1(I),1.E-8) - TSURF(I) = TSKIN(I) - THETA1(I) = T1(I) * PRSLKI(I) - TV1(I) = T1(I) * (1. + RVRDM1 * Q0(I)) - RHO(I) = PS1(I) / (RD * TV1(I)) -cjfe QS1(I) = 1000. * FPVS(T1(I)) - qs1(i) = fpvs(t1(i)) - QS1(I) = EPS * QS1(I) / (PS1(I) + EPSM1 * QS1(I)) - QS1(I) = MAX(QS1(I), 1.E-8) - Q0(I) = min(QS1(I),Q0(I)) -cjfe QSS(I) = 1000. * FPVS(TSURF(I)) -! qss(i) = fpvs(tskin(i)) -! QSS(I) = EPS * QSS(I) / (PSURF(I) + EPSM1 * QSS(I)) - FFW(I) = 1.0-FICE(I) -! IF (FICE(I) .GE. cimin) THEN -! TICE(I) = (TSKIN(I)-TGICE*FFW(I))/FICE(I) -! ELSE - IF (FICE(I) .LT. cimin) THEN - PRINT *,'WARNING: ice fraction is low:', FICE(I) - FICE(I )= cimin - FFW(I) = 1.0-FICE(I) - TICE(I) = tgice - TSKIN(I)= tgice - PRINT *,'Fix ice fraction: reset it to:', FICE(I) - ENDIF - qssi(i) = fpvs(tice(i)) - QSSI(I) = EPS * QSSI(I) / (PSURF(I) + EPSM1 * QSSI(I)) - qssw(i) = fpvs(tgice) - QSSW(I) = EPS * QSSW(I) / (PSURF(I) + EPSM1 * QSSW(I)) -C -C SNOW DEPTH IN WATER EQUIVALENT IS CONVERTED FROM MM TO M UNIT -C - IF (MOM4ICE) then - SNOWD(I) = SHELEG(I) * 0.001 / FICE(I) - ELSE - SNOWD(I) = SHELEG(I) / 1000. - ENDIF - FLAGSNW(I) = .FALSE. -C -C WHEN SNOW DEPTH IS LESS THAN 1 MM, A PATCHY SNOW IS ASSUMED AND -C SOIL IS ALLOWED TO INTERACT WITH THE ATMOSPHERE. -C WE SHOULD EVENTUALLY MOVE TO A LINEAR COMBINATION OF SOIL AND -C SNOW UNDER THE CONDITION OF PATCHY SNOW. -C - IF(SNOWD(I).GT..001) FLAGSNW(I) = .TRUE. - ENDIF - ENDDO -!! - -C -C RCP = RHO CP CH V -C - DO I = 1, IM - IF(FLAG(I)) THEN - RCH(I) = RHO(I) * CP * CH(I) * WIND(I) -Cwei added 10/24/2006 - CMM(I)=CM(I)* WIND(I) - CHH(I)=RHO(I)*CH(I)* WIND(I) - ZLVL(I) = -RD * TV1(I) * LOG(PS1(I)/PSURF(I)) / GRAV - ENDIF - ENDDO - -C -C SENSIBLE AND LATENT HEAT FLUX OVER OPEN WATER & SEA ICE -C - DO I = 1, IM - IF(FLAG(I)) THEN - EVAPI(I) = ELOCP * RCH(I) * (QSSI(I) - Q0(I)) - EVAPW(I) = ELOCP * RCH(I) * (QSSW(I) - Q0(I)) -! EVAP(I) = FICE(I)*EVAPI(I) + FFW(I)*EVAPW(I) - ENDIF - ENDDO - -C -C UPDATE SEA ICE TEMPERATURE -C - DO K = 1, KMI - DO I=1,IM - IF(FLAG(I)) THEN - STSICE(I,K) = STC(I,K) - ENDIF - ENDDO - ENDDO - DO I=1,IM - IF(FLAG(I)) THEN - SNETW(I) = SFCDSW(I)*(1.0-ALBFW) - SNETW(I) = min(3.*SNET(I)/(1.+2.*FFW(I)),SNETW(I)) - SNETI(I) = (SNET(I)-FFW(I)*SNETW(I))/FICE(I) - t12=tice(i)*tice(i) - t14=t12*t12 -C hfi = Net non-solar and upIR heat flux @ ice surface - hfi(i) =-dlwflx(i)+emissiv*sigma*t14 + evapi(i) - & +rch(i)*(tice(i)-theta1(i)) -C hfd = Heat flux derivat @ surface -C = 4 emissivity T**3 + RCH [ 1 + L/CP * DQS/DT) ] - hfd(i) = 4.*emissiv*sigma*tice(i)*t12 - & +(1.+elocp*eps*hvap*qs1(i)/(rd*t12))*rch(i) - t12=tgice*tgice - t14=t12*t12 -C hfw = Net heat flux @ water surface (within ice) - hfw(i) =-dlwflx(i)+emissiv*sigma*t14 + evapw(i) - & +rch(i)*(tgice-theta1(i))-snetw(i) - focn(i) = 2. ! heat flux from ocean - should be from ocn model - snof(i) = 0. ! snowfall rate - snow accumulates in gbphys -CCC...QC - if (hice(i) .GT. himax) hice(i)=himax - if (hice(i) .LT. himin) hice(i)=himin - if (snowd(i) .GT. hsmax) snowd(i)=hsmax - if (snowd(i) .GT. (2.*hice(i))) then - print *,'WARNING: too much snow :',snowd(i) - snowd(i)=2.*hice(i) - print *,'FIX: decrease snow depth to:',snowd(i) - endif -CCC...QC END - ENDIF - ENDDO - call ice3lay(IM,kmi,snowd,hice,fice,flag, - & stsice,tice,hfi,sneti,hfd,hfw,focn, - & snof,snowmt,gflux,delt) - IF (MOM4ICE) then - DO I = 1, IM - IF(FLAG(I)) THEN - HICE(I) = HI_save(I) - SNOWD(I) = HS_save(I) - ENDIF - ENDDO - ENDIF - DO I=1,IM - IF(FLAG(I)) THEN - if (tice(i).LT.timin) then - print *,'WARNING: snow/ice temperature is too low:',tice(i) - tice(i)=timin - PRINT *,'Fix snow/ice temperature: reset it to:',tice(i) - endif - if (stsice(i,1).LT.timin) then - print *,'WARNING: Layer 1 ice temp is too low:',stsice(i,1) - stsice(i,1)=timin - PRINT *,'Fix Layer 1 ice temp: reset it to:',stsice(i,1) - endif - if (stsice(i,2).LT.timin) then - print *,'WARNING: Layer 2 ice temp is too low:',stsice(i,2) - stsice(i,2)=timin - PRINT *,'Fix Layer 2 ice temp: reset it to:',stsice(i,2) - endif - tskin(i) = tice(i)*fice(i) + tgice*ffw(i) - ENDIF - ENDDO - DO k=1,KMI - DO I=1,IM - IF(FLAG(I)) THEN - stc(i,k) = min(stsice(i,k),T0C) - ENDIF - ENDDO - ENDDO -C -C CALCULATE SENSIBLE HEAT FLUX (& EVAP over SEA ICE) -C - DO I = 1, IM - IF (FLAG(I)) THEN - HFLXI(I) = RCH(I) * (TICE(I) - THETA1(I)) - HFLXW(I) = RCH(I) * (TGICE - THETA1(I)) - HFLX(I) = FICE(I)*HFLXI(I) + FFW(I)*HFLXW(I) - EVAP(I) = FICE(I)*EVAPI(I) + FFW(I)*EVAPW(I) - ENDIF - ENDDO - -C -C THE REST OF THE OUTPUT -C - DO I = 1, IM - IF(FLAG(I)) THEN - QSURF(I) = Q1(I) + EVAP(I) / (ELOCP * RCH(I)) - DM(I) = 1. -C -C CONVERT SNOW DEPTH BACK TO MM OF WATER EQUIVALENT -C - SHELEG(I) = SNOWD(I) * 1000. - SNWDPH(I) = SHELEG(I) * DSI ! Snow depth in mm - ENDIF - ENDDO -! - do i=1,im - IF(FLAG(I)) THEN - tem = 1.0 / rho(i) - hflx(i) = hflx(i) * tem * cpinv - evap(i) = evap(i) * tem * hvapi - ENDIF - enddo -! - RETURN - END - - SUBROUTINE ICE3LAY(IM,kmi,hs,hi,fice,flag, - & TI,TS,HF,SOL,HFD,FRZMLT,FB, - & SNOW,SNOWMT,GFLUX,DT) -C -C************************************************************************** -C * -C THREE-LAYER SEA ICE VERTICAL THERMODYNAMICS * -C * -C Based on: M. Winton, "A reformulated three-layer sea ice model", * -C Journal of Atmospheric and Oceanic Technology, 2000 * -C * -C * -C -> +---------+ <- ts - diagnostic surface temperature ( <= 0C ) * -C / | | * -C hs | snow | <- 0-heat capacity snow layer * -C \ | | * -C => +---------+ * -C / | | * -C / | | <- t1 - upper 1/2 ice temperature; this layer has * -C / | | a variable (T/S dependent) heat capacity * -C hi |...ice...| * -C \ | | * -C \ | | <- t2 - lower 1/2 ice temp. (fixed heat capacity) * -C \ | | * -C -> +---------+ <- base of ice fixed at seawater freezing temp. * -C * -C************************************************************************** -C - USE MACHINE , ONLY : kind_phys - implicit none -C -C *************************************************************** -C * -C Argument Description Units Changed? * -C -------- ----------- ----- -------- * -C * -C INPUT/OUTPUT: * -C * -C hs Snow Thickness m y * -C hi Ice Thickness m y * -C ts Surface Temperature deg C y * -C ti(1) Temp @ Midpt of Ice1 deg C y * -C ti(2) Temp @ Midpt of Ice2 deg C y * -C hf(+) Net non-solar and upIR * -C heat flux @ surface watt/m^2 n * -C sol(+) Net solar incoming top watt/m^2 n * -C hfd(+) Heat flux derivat @ sfc watt/(m^2deg-C) n * -C fb(+) Heat Flux from Ocean watt/m^2 n * -C snow Snowfall Rate m/sec n * -C dt timestep sec n * -C * -C ADDITIONAL: * -C * -C snowmt snow melt during dt m y * -C gflux conductive heat flux watt/m^2 y * -C flag Ice mask flag n * -C * -C LOCAL: * -C * -C hdi ice-water interface m y * -C hsni snow-ice m y * -C *************************************************************** -C - integer IM, kmi - real (kind=kind_phys) KS, DS, I0, KI, DI, CI, DICI, - & LI, SI, MU, TFI, TFW, DILI, DSLI - real (kind=kind_phys) DW,tffresh,TFI0 - real (kind=kind_phys) ki4, dt, dt2, dt4, dt6 - real (kind=kind_phys) r0,r1,r2,r4,p5 -C -C variables for temperature calculation [see Winton (2000) 2.a] -C - real (kind=kind_phys) A(IM), B(IM), Ip(IM), - & A1(IM),B1(IM),C1(IM), - & A10(IM),B10(IM), - & K12(IM),K32(IM), - & TSF(IM),SNOWD(IM), - & H1(IM),H2(IM),DH(IM), - & F1(IM),TMELT(IM),BMELT(IM) - real (kind=kind_phys) HF(IM),HFD(IM), - & HS(IM),TS(IM),SOL(IM), - & GFLUX(IM),SNOWMT(IM), - & FB(IM),SNOW(IM), - & HI(IM),TI(IM,KMI) - real (kind=kind_phys) FICE(IM),FRZMLT(IM) - real (kind=kind_phys) HSNI(IM),HDI(IM) - LOGICAL FLAG(IM) - integer I - -C properties of ice, snow, and seawater (local) - PARAMETER (DS=330.0) ! snow (over sea ice) density - 330 kg/(m^3) - PARAMETER (DW=1000.0) ! fresh water density - 1000 kg/(m^3) - PARAMETER (TFFRESH=273.15) ! Freezing temp of fresh ice (K) - PARAMETER (KS = 0.31) ! conductivity of snow - 0.31 W/(mK) - PARAMETER (I0 = 0.3) ! ice surface penetrating solar fraction - PARAMETER (KI = 2.03) ! conductivity of ice - 2.03 W/(mK) - PARAMETER (DI = 917.0) ! density of ice - 917 kg/(m^3) - PARAMETER (CI = 2054.0) ! heat capacity of fresh ice - 2054 J/(kg K) - PARAMETER (LI = 3.34e5) ! latent heat of fusion - 334e3 J/(kg-ice) - PARAMETER (SI = 1.0) ! salinity of sea ice - PARAMETER (MU = 0.054) ! relates freezing temp. to salinity - PARAMETER (TFI = -MU*SI) ! sea ice freezing temp. = -mu*salinity - PARAMETER (TFW = -1.8) ! TFW - seawater freezing temperature -1.8 C - PARAMETER (r0 = 0.) ! r0=0 - PARAMETER (r1 = 1.) ! r1=1 - PARAMETER (r2 = 2.) ! r2=2 - PARAMETER (r4 = 4.) ! r4=4 - PARAMETER (p5 = r1/r2) ! p5=1/2 - PARAMETER (TFI0 = TFI-0.0001) ! TFI-0.0001 - PARAMETER (DICI = DI*CI) - PARAMETER (DILI = DI*LI) - PARAMETER (DSLI = DS*LI) - PARAMETER (KI4 = KI*r4) - - dt2 = dt*r2 - dt4 = dt*r4 - dt6 = dt*6. - - DO I=1,IM - IF(FLAG(I)) THEN - hs(i) = hs(i)*DW/DS - hdi(i) = (DS*hs(i)+DI*hi(i))/DW - if (hi(i).LT.hdi(i)) then - hs(i)=hs(i)+hi(i)-hdi(i) - hsni(i)=(hdi(i)-hi(i))*DS/DI - hi(i)=hi(i)+hsni(i) - endif - snow(i) = snow(i)*DW/DS - ts(i) = TS(I)-TFFRESH ! degC - ti(i,1) = min(TI(I,1)-TFFRESH,TFI0) ! degC - ti(i,2) = min(TI(I,2)-TFFRESH,TFI0) ! degC - Ip(i) = I0*sol(i) ! Ip +v (in Winton Ip=-I0*sol as sol -v) - if (hs(i) .gt. r0) then - tsf(i) = r0 - Ip(i) = r0 - else - tsf(i) = TFI - Ip(i) = I0*sol(i) ! Ip +v here (in Winton Ip=-I0*sol) - endif - ts(i) = min(TS(I),TSF(I)) -C -C Compute ice temperature -C - B(i) = hfd(i) - A(i) = hf(i)-sol(i)+Ip(i)-ts(i)*B(i) ! +v sol input here - K12(i) = KI4*KS/(KS*hi(i)+KI4*hs(i)) - K32(i) = r2*KI/hi(i) - - A10(i) = DICI*hi(i)/dt2 + K32(i)*(dt4*K32(i)+DICI*hi(i)) - & /(dt6*K32(i)+DICI*hi(i)) - B10(i) = -DI*hi(i)*(CI*ti(i,1)+LI*TFI/ti(i,1))/dt2 - Ip(i) - & -K32(i)*(dt4*K32(i)*TFW+DICI*hi(i)*ti(i,2)) - & /(dt6*K32(i)+DICI*hi(i)) - - A1(i) = A10(i)+K12(i)*B(i)/(K12(i)+B(i)) - B1(i) = B10(i)+A(i)*K12(i)/(K12(i)+B(i)) - C1(i) = DILI*TFI/dt2*hi(i) - ti(i,1) = -(sqrt(B1(i)*B1(i)-r4*A1(i)*C1(i))+B1(i))/(r2*A1(i)) - ts(i) = (K12(i)*ti(i,1)-A(i))/(K12(i)+B(i)) - if (ts(i) .gt. tsf(i)) then - A1(i) = A10(i)+K12(i) - B1(i) = B10(i)-K12(i)*tsf(i) - ti(i,1) = -(sqrt(B1(i)*B1(i)-r4*A1(i)*C1(i))+B1(i))/(r2*A1(i)) - ts(i) = tsf(i) - tmelt(i) = (K12(i)*(ti(i,1)-tsf(i))-(A(i)+B(i)*tsf(i)))*dt - else - tmelt(i) = r0 - hs(i) = hs(i) + snow(i)*dt - endif - - ti(i,2) = (dt2*K32(i)*(ti(i,1)+r2*TFW)+DICI*hi(i)*ti(i,2)) - & /(dt6*K32(i)+DICI*hi(i)) - - bmelt(i) = (fb(i)+KI4*(ti(i,2)-TFW)/hi(i))*dt -C -C Resize the ice ... -C - h1(i) = p5*hi(i) - h2(i) = p5*hi(i) -C -C ... top ... -C - if (tmelt(i) .le. hs(i)*DSLI) then - snowmt(i) = tmelt(i)/DSLI - hs(i) = hs(i) - tmelt(i)/DSLI - else - snowmt(i) = hs(i) - h1(i)=h1(i) - & -(tmelt(i)-hs(i)*DSLI)/(DI*(CI-LI/ti(i,1))*(TFI-ti(i,1))) - hs(i) = r0 - endif -C -C ... and bottom -C - if (bmelt(i) .lt. r0) then - dh(i) = -bmelt(i)/(DILI+DICI*(TFI-TFW)) - ti(i,2) = (h2(i)*ti(i,2)+dh(i)*TFW)/(h2(i)+dh(i)) - h2(i) = h2(i)+dh(i) - else - h2(i) = h2(i)-bmelt(i)/(DILI+DICI*(TFI-ti(i,2))) - endif -C -C if ice remains, even up 2 layers, else, pass negative energy back in snow -C - hi(i) = h1(i) + h2(i) - - if (hi(i) .gt. r0) then - if (h1(i) .gt. p5*hi(i)) then - f1(i) = r1-r2*h2(i)/hi(i) - ti(i,2)=f1(i)*(ti(i,1)+LI*TFI/(CI*ti(i,1))) - & +(r1-f1(i))*ti(i,2) - if (ti(i,2).GT.TFI) then - hi(i)=hi(i)-h2(i)*CI*(TI(i,2)-TFI)/(LI*dt) - ti(i,2)=TFI - endif - else - f1(i) = r2*h1(i)/hi(i) - ti(i,1)=f1(i)*(ti(i,1)+LI*TFI/(CI*ti(i,1))) - & +(r1-f1(i))*ti(i,2) - ti(i,1) = (ti(i,1)-sqrt(ti(i,1)*ti(i,1)-r4*TFI*LI/CI))/r2 - endif - K12(i) = KI4*KS/(KS*hi(i)+KI4*hs(i)) - gflux(i) = k12(i) * (ti(i,1) - ts(i)) - else - hs(i) = hs(i) + (h1(i)*(CI*(ti(i,1)-TFI)-LI*(r1-TFI/ti(i,1))) - & +h2(i)*(CI*(ti(i,2)-TFI)-LI))/LI - hi(i) = max(r0,hs(i)*DS/DI) - hs(i) = r0 - ti(i,1) = TFW - ti(i,2) = TFW - gflux(i) = r0 - endif - - gflux(i) = fice(i)*gflux(i) - snowmt(i)=snowmt(i)*DS/DW - hs(i)=hs(i)*DS/DW - ts(i)=ts(i)+tffresh - ti(i,1)=ti(i,1)+tffresh - ti(i,2)=ti(i,2)+tffresh - ENDIF ! FLAG - ENDDO ! IM - return - end diff --git a/src/fim/FIMsrc/fim/column/sflx.f b/src/fim/FIMsrc/fim/column/sflx.f deleted file mode 100644 index a5b2558..0000000 --- a/src/fim/FIMsrc/fim/column/sflx.f +++ /dev/null @@ -1,5046 +0,0 @@ - SUBROUTINE SFLX ( -Clu.....add COUPLE -C C FFROZP,ICE,DT,ZLVL,NSOIL,SLDPTH, - C COUPLE,FFROZP,ICEIN,DT,ZLVL,NSOIL,SLDPTH, -Clu.....pass in RADFLX instead of SOLDN and SOLNET -Clu F LWDN,SOLDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2,SFCSPD, - F LWDN,SWDN, RADFLX,SFCPRS,PRCP,SFCTMP,Q2,SFCSPD, - I TH2,Q2SAT,DQSDT2, - S VEGTYP,SOILTYP,SLOPETYP,SHDFAC,SHDMIN,PTU,ALB,SNOALB,TBOT, - H CMC,T1,STC,SMC,SH2O,SNOWH,SNEQV,ALBEDO,CH,CM, - O ETA,SHEAT, -C ---------------------------------------------------------------------- -C OUTPUTS, DIAGNOSTICS, PARAMETERS BELOW GENERALLY NOT NECESSARY WHEN -C COUPLED WITH E.G. A NWP MODEL (SUCH AS THE NOAA/NWS/NCEP MESOSCALE ETA -C MODEL). OTHER APPLICATIONS MAY REQUIRE DIFFERENT OUTPUT VARIABLES. -C ---------------------------------------------------------------------- - O EC,EDIR,ET,ETT,ESNOW,DRIP,DEW, - O BETA,ETP,SSOIL, - O FLX1,FLX2,FLX3, - O SNOMLT,SNCOVR, - O RUNOFF1,RUNOFF2,RUNOFF3, - O RC,PC,RSMIN,XLAI,RCS,RCT,RCQ,RCSOIL, - D SOILW,SOILM, - P SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT) - - IMPLICIT NONE - -Clu --------------------------------------------------------------------- -C (1) MODIFY CALLING ARGUMENT -C 1. ADD 'COUPLE' (=1: COUPLED, =0: UNCOUPLED) -C 2. REPLACE (SOLDN,SOLNET) BY (RADFLX) -C (2) MODIFY SOURCE CODE -C 1. INVOKE THE SECTION OF SFCDIF IF COUPLE=0 -C 2. APPLY TIME FILTER TO STC AND TSKIN -C 3. MODIFY HOW NAMELIST IS READ IN -Clu --------------------------------------------------------------------- - -C ---------------------------------------------------------------------- -C SUBROUTINE SFLX - VERSION 2.7 - June 2nd 2003 -C ---------------------------------------------------------------------- -C SUB-DRIVER FOR "NOAH/OSU LSM" FAMILY OF PHYSICS SUBROUTINES FOR A -C SOIL/VEG/SNOWPACK LAND-SURFACE MODEL TO UPDATE SOIL MOISTURE, SOIL -C ICE, SOIL TEMPERATURE, SKIN TEMPERATURE, SNOWPACK WATER CONTENT, -C SNOWDEPTH, AND ALL TERMS OF THE SURFACE ENERGY BALANCE AND SURFACE -C WATER BALANCE (EXCLUDING INPUT ATMOSPHERIC FORCINGS OF DOWNWARD -C RADIATION AND PRECIP) -C ---------------------------------------------------------------------- -C SFLX ARGUMENT LIST KEY: -C ---------------------------------------------------------------------- -C C CONFIGURATION INFORMATION -C F FORCING DATA -C I OTHER (INPUT) FORCING DATA -C S SURFACE CHARACTERISTICS -C H HISTORY (STATE) VARIABLES -C O OUTPUT VARIABLES -C D DIAGNOSTIC OUTPUT -C ---------------------------------------------------------------------- -C 1. CONFIGURATION INFORMATION (C): -C ---------------------------------------------------------------------- -C COUPLE 0=UNCOUPLED (LAND MODEL ONLY) -C 1=COUPLED ...WITH PARENT ATMOS MODEL -C ICEIN SEA-ICE FLAG (= 1: SEA-ICE, = 0: LAND) -C DT TIMESTEP (SEC) (DT SHOULD NOT EXCEED 3600 SECS, RECOMMEND -C 1800 SECS OR LESS) -C ZLVL HEIGHT (M) ABOVE GROUND OF ATMOSPHERIC FORCING VARIABLES -C NSOIL NUMBER OF SOIL LAYERS (AT LEAST 2, AND NOT GREATER THAN -C PARAMETER NSOLD SET BELOW) -C SLDPTH THE THICKNESS OF EACH SOIL LAYER (M) -C ---------------------------------------------------------------------- -C 2. FORCING DATA (F): -C ---------------------------------------------------------------------- -C LWDN LW DOWNWARD RADIATION (W M-2; POSITIVE, NOT NET LONGWAVE) -C SWDN SW DOWNWARD RADIATION (W M-2; POSITIVE, NOT NET SHORTWAVE) -C RADFLX COUPLED MODE = NET SOLAR + DOWNWARD LONGWAVE -C UNCOUPLED MODE = DOWNWARD (INCOMING) SOLAR, NOT NET SOLAR -C SOLDN SOLAR DOWNWARD RADIATION (W M-2; POSITIVE, NOT NET SOLAR) -C SOLNET NET SOLAR DOWNWARD RADIATION (W M-2; POSITIVE) -C SFCPRS PRESSURE AT HEIGHT ZLVL ABOVE GROUND (PASCALS) -C PRCP PRECIP RATE (KG M-2 S-1) (NOTE, THIS IS A RATE) -C SFCTMP AIR TEMPERATURE (K) AT HEIGHT ZLVL ABOVE GROUND -C TH2 AIR POTENTIAL TEMPERATURE (K) AT HEIGHT ZLVL ABOVE GROUND -C Q2 MIXING RATIO AT HEIGHT ZLVL ABOVE GROUND (KG KG-1) -C ---------------------------------------------------------------------- -C 3. OTHER FORCING (INPUT) DATA (I): -C ---------------------------------------------------------------------- -C SFCSPD WIND SPEED (M S-1) AT HEIGHT ZLVL ABOVE GROUND -C Q2SAT SAT MIXING RATIO AT HEIGHT ZLVL ABOVE GROUND (KG KG-1) -C DQSDT2 SLOPE OF SAT SPECIFIC HUMIDITY CURVE AT T=SFCTMP -C (KG KG-1 K-1) -C ---------------------------------------------------------------------- -C 4. CANOPY/SOIL CHARACTERISTICS (S): -C ---------------------------------------------------------------------- -C VEGTYP VEGETATION TYPE (INTEGER INDEX) -C SOILTYP SOIL TYPE (INTEGER INDEX) -C SLOPETYP CLASS OF SFC SLOPE (INTEGER INDEX) -C SHDFAC AREAL FRACTIONAL COVERAGE OF GREEN VEGETATION -C (FRACTION= 0.0-1.0) -C SHDMIN MINIMUM AREAL FRACTIONAL COVERAGE OF GREEN VEGETATION -C (FRACTION= 0.0-1.0) <= SHDFAC -C PTU PHOTO THERMAL UNIT (PLANT PHENOLOGY FOR ANNUALS/CROPS) -C (NOT YET USED, BUT PASSED TO REDPRM FOR FUTURE USE IN -C VEG PARMS) -C ALB BACKROUND SNOW-FREE SURFACE ALBEDO (FRACTION), FOR JULIAN -C DAY OF YEAR (USUALLY FROM TEMPORAL INTERPOLATION OF -C MONTHLY MEAN VALUES' CALLING PROG MAY OR MAY NOT -C INCLUDE DIURNAL SUN ANGLE EFFECT) -C SNOALB UPPER BOUND ON MAXIMUM ALBEDO OVER DEEP SNOW (E.G. FROM -C ROBINSON AND KUKLA, 1985, J. CLIM. & APPL. METEOR.) -C TBOT BOTTOM SOIL TEMPERATURE (LOCAL YEARLY-MEAN SFC AIR -C TEMPERATURE) -C ---------------------------------------------------------------------- -C 5. HISTORY (STATE) VARIABLES (H): -C ---------------------------------------------------------------------- -C CMC CANOPY MOISTURE CONTENT (M) -C T1 GROUND/CANOPY/SNOWPACK) EFFECTIVE SKIN TEMPERATURE (K) -C STC(NSOIL) SOIL TEMP (K) -C SMC(NSOIL) TOTAL SOIL MOISTURE CONTENT (VOLUMETRIC FRACTION) -C SH2O(NSOIL) UNFROZEN SOIL MOISTURE CONTENT (VOLUMETRIC FRACTION) -C NOTE: FROZEN SOIL MOISTURE = SMC - SH2O -C SNOWH ACTUAL SNOW DEPTH (M) -C SNEQV LIQUID WATER-EQUIVALENT SNOW DEPTH (M) -C NOTE: SNOW DENSITY = SNEQV/SNOWH -C ALBEDO SURFACE ALBEDO INCLUDING SNOW EFFECT (UNITLESS FRACTION) -C =SNOW-FREE ALBEDO (ALB) WHEN SNEQV=0, OR -C =FCT(MSNOALB,ALB,VEGTYP,SHDFAC,SHDMIN) WHEN SNEQV>0 -C CH SURFACE EXCHANGE COEFFICIENT FOR HEAT AND MOISTURE -C (M S-1); NOTE: CH IS TECHNICALLY A CONDUCTANCE SINCE -C IT HAS BEEN MULTIPLIED BY WIND SPEED. -C CM SURFACE EXCHANGE COEFFICIENT FOR MOMENTUM (M S-1); NOTE: -C CM IS TECHNICALLY A CONDUCTANCE SINCE IT HAS BEEN -C MULTIPLIED BY WIND SPEED. CM IS NOT NEEDED IN SFLX -C ---------------------------------------------------------------------- -C 6. OUTPUT (O): -C ---------------------------------------------------------------------- -C OUTPUT VARIABLES NECESSARY FOR A COUPLED NUMERICAL WEATHER PREDICTION -C MODEL, E.G. NOAA/NWS/NCEP MESOSCALE ETA MODEL. FOR THIS APPLICATION, -C THE REMAINING OUTPUT/DIAGNOSTIC/PARAMETER BLOCKS BELOW ARE NOT -C NECESSARY. OTHER APPLICATIONS MAY REQUIRE DIFFERENT OUTPUT VARIABLES. -C ETA ACTUAL LATENT HEAT FLUX (W M-2: NEGATIVE, IF UP FROM -C SURFACE) -C SHEAT SENSIBLE HEAT FLUX (W M-2: NEGATIVE, IF UPWARD FROM -C SURFACE) -C ---------------------------------------------------------------------- -C EC CANOPY WATER EVAPORATION (W M-2) -C EDIR DIRECT SOIL EVAPORATION (W M-2) -C ET(NSOIL) PLANT TRANSPIRATION FROM A PARTICULAR ROOT (SOIL) LAYER -C (W M-2) -C ETT TOTAL PLANT TRANSPIRATION (W M-2) -C ESNOW SUBLIMATION FROM SNOWPACK (W M-2) -C DRIP THROUGH-FALL OF PRECIP AND/OR DEW IN EXCESS OF CANOPY -C WATER-HOLDING CAPACITY (M) -C DEW DEWFALL (OR FROSTFALL FOR T<273.15) (M) -C ---------------------------------------------------------------------- -C BETA RATIO OF ACTUAL/POTENTIAL EVAP (DIMENSIONLESS) -C ETP POTENTIAL EVAPORATION (W M-2) -C SSOIL SOIL HEAT FLUX (W M-2: NEGATIVE IF DOWNWARD FROM SURFACE) -C ---------------------------------------------------------------------- -C FLX1 PRECIP-SNOW SFC (W M-2) -C FLX2 FREEZING RAIN LATENT HEAT FLUX (W M-2) -C FLX3 PHASE-CHANGE HEAT FLUX FROM SNOWMELT (W M-2) -C ---------------------------------------------------------------------- -C SNOMLT SNOW MELT (M) (WATER EQUIVALENT) -C SNCOVR FRACTIONAL SNOW COVER (UNITLESS FRACTION, 0-1) -C ---------------------------------------------------------------------- -C RUNOFF1 SURFACE RUNOFF (M S-1), NOT INFILTRATING THE SURFACE -C RUNOFF2 SUBSURFACE RUNOFF (M S-1), DRAINAGE OUT BOTTOM OF LAST -C SOIL LAYER, ALSO KNOWN AS BASEFLOW -C RUNOFF3 NUMERICAL TRUNCTATION IN EXCESS OF POROSITY (SMCMAX) -C FOR A GIVEN SOIL LAYER AT THE END OF A TIME STEP -C ---------------------------------------------------------------------- -C RC CANOPY RESISTANCE (S M-1) -C PC PLANT COEFFICIENT (UNITLESS FRACTION, 0-1) WHERE PC*ETP -C = ACTUAL TRANSPIRATION -C XLAI LEAF AREA INDEX (DIMENSIONLESS) -C RSMIN MINIMUM CANOPY RESISTANCE (S M-1) -C RCS INCOMING SOLAR RC FACTOR (DIMENSIONLESS) -C RCT AIR TEMPERATURE RC FACTOR (DIMENSIONLESS) -C RCQ ATMOS VAPOR PRESSURE DEFICIT RC FACTOR (DIMENSIONLESS) -C RCSOIL SOIL MOISTURE RC FACTOR (DIMENSIONLESS) -C ---------------------------------------------------------------------- -C 7. DIAGNOSTIC OUTPUT (D): -C ---------------------------------------------------------------------- -C SOILW AVAILABLE SOIL MOISTURE IN ROOT ZONE (UNITLESS FRACTION -C BETWEEN SMCWLT AND SMCMAX) -C SOILM TOTAL SOIL COLUMN MOISTURE CONTENT (FROZEN+UNFROZEN) (M) -C ---------------------------------------------------------------------- -C 8. PARAMETERS (P): -C ---------------------------------------------------------------------- -C SMCWLT WILTING POINT (VOLUMETRIC) -C SMCDRY DRY SOIL MOISTURE THRESHOLD WHERE DIRECT EVAP FRM TOP -C LAYER ENDS (VOLUMETRIC) -C SMCREF SOIL MOISTURE THRESHOLD WHERE TRANSPIRATION BEGINS TO -C STRESS (VOLUMETRIC) -C SMCMAX POROSITY, I.E. SATURATED VALUE OF SOIL MOISTURE -C (VOLUMETRIC) -C NROOT NUMBER OF ROOT LAYERS, A FUNCTION OF VEG TYPE, DETERMINED -C IN SUBROUTINE REDPRM. -C ---------------------------------------------------------------------- - INTEGER NSOLD - PARAMETER(NSOLD = 4) - -C ---------------------------------------------------------------------- -C DECLARATIONS - LOGICAL -C ---------------------------------------------------------------------- - LOGICAL FRZGRA - LOGICAL SATURATED - LOGICAL SNOWNG - -C ---------------------------------------------------------------------- -C DECLARATIONS - INTEGER -C ---------------------------------------------------------------------- - INTEGER COUPLE !...***Clu*** - INTEGER ICEIN - INTEGER ICE - INTEGER K - INTEGER KZ - INTEGER NSOIL - INTEGER NROOT - INTEGER SLOPETYP - INTEGER SOILTYP - INTEGER VEGTYP - -C ---------------------------------------------------------------------- -C DECLARATIONS - REAL -C ---------------------------------------------------------------------- - REAL ALBEDO - REAL ALB - REAL BEXP - REAL BETA - REAL CFACTR - REAL CH - REAL CM - REAL CMC - REAL CMCMAX - REAL CP - REAL CSNOW - REAL CSOIL - REAL CZIL - REAL DEW - REAL DF1 - REAL DF1H - REAL DF1A - REAL DKSAT - REAL DT - REAL DWSAT - REAL DQSDT2 - REAL DSOIL - REAL DTOT - REAL DRIP - REAL EC - REAL EDIR - REAL ESNOW - REAL ET(NSOIL) - REAL ETT - REAL FRCSNO - REAL FRCSOI - REAL EPSCA - REAL ETA - REAL ETP - REAL FDOWN - REAL F1 - REAL FLX1 - REAL FLX2 - REAL FLX3 - REAL FXEXP - REAL FRZX - REAL SHEAT - REAL HS - REAL KDT - REAL LWDN - REAL SWDN - REAL LVH2O - REAL PC - REAL PRCP - REAL PTU - REAL PRCP1 - REAL PSISAT - REAL Q2 - REAL Q2SAT - REAL QUARTZ - REAL R - REAL RADFLX ! ... *** Clu *** - REAL RCH - REAL REFKDT - REAL RR - REAL RTDIS(NSOLD) - REAL RUNOFF1 - REAL RUNOFF2 - REAL RGL - REAL RUNOFF3 - REAL RSMAX - REAL RC - REAL RSMIN - REAL RCQ - REAL RCS - REAL RCSOIL - REAL RCT - REAL RSNOW - REAL SNDENS - REAL SNCOND - REAL SSOIL - REAL SBETA - REAL SFCPRS - REAL SFCSPD - REAL SFCTMP - REAL SHDFAC - REAL SHDMIN - REAL SH2O(NSOIL) - REAL SLDPTH(NSOIL) - REAL SMCDRY - REAL SMCMAX - REAL SMCREF - REAL SMCWLT - REAL SMC(NSOIL) - REAL SNEQV - REAL SNCOVR - REAL SNOWH - REAL SN_NEW - REAL SLOPE - REAL SNUP - REAL SALP - REAL SNOALB - REAL STC(NSOIL) - REAL SNOMLT - REAL SOLDN - REAL SOILM - REAL SOILW - REAL SOILWM - REAL SOILWW - REAL T1 - REAL T1V - REAL T24 - REAL T2V - REAL TBOT - REAL TH2 - REAL TH2V - REAL TOPT - REAL TFREEZ - REAL TSNOW - REAL XLAI - REAL ZLVL - REAL ZBOT - REAL Z0 - REAL ZSOIL(NSOLD) - - REAL FFROZP - REAL SOLNET - REAL LSUBS - -C ---------------------------------------------------------------------- -C DECLARATIONS - PARAMETERS -C ---------------------------------------------------------------------- - PARAMETER(TFREEZ = 273.15) - PARAMETER(LVH2O = 2.501E+6) - PARAMETER(LSUBS = 2.83E+6) - PARAMETER(R = 287.04) - PARAMETER(CP = 1004.5) - -C ---------------------------------------------------------------------- -C INITIALIZATION -C ---------------------------------------------------------------------- - RUNOFF1 = 0.0 - RUNOFF2 = 0.0 - RUNOFF3 = 0.0 - SNOMLT = 0.0 - -C ---------------------------------------------------------------------- -C DEFINE LOCAL VARIABLE ICE TO ACHIEVE: -C SEA-ICE CASE, ICE = 1 -C NON-GLACIAL LAND, ICE = 0 -C GLACIAL-ICE LAND, ICE = -1 -C IF VEGTYPE=13 (GLACIAL-ICE), RE-SET ICE FLAG = -1 (GLACIAL-ICE) -C NOTE: FOR OPEN-SEA, SFLX SHOULD *NOT* HAVE BEEN CALLED. -C SET GREEN VEGETATION FRACTION (SHDFAC) = 0. -C ---------------------------------------------------------------------- - ICE = ICEIN - IF (VEGTYP .EQ. 13) THEN - ICE = -1 - SHDFAC = 0.0 - ENDIF - - IF (ICE .EQ. 1) THEN - SHDFAC = 0.0 -C ---------------------------------------------------------------------- -C SET GREEN VEGETATION FRACTION (SHDFAC) = 0. -C SET SEA-ICE LAYERS OF EQUAL THICKNESS AND SUM TO 3 METERS -C ---------------------------------------------------------------------- - DO KZ = 1,NSOIL - ZSOIL(KZ) = -3.*FLOAT(KZ)/FLOAT(NSOIL) - END DO - - ELSE -C ---------------------------------------------------------------------- -C CALCULATE DEPTH (NEGATIVE) BELOW GROUND FROM TOP SKIN SFC TO BOTTOM OF -C EACH SOIL LAYER. NOTE: SIGN OF ZSOIL IS NEGATIVE (DENOTING BELOW -C GROUND) -C ---------------------------------------------------------------------- - ZSOIL(1) = -SLDPTH(1) - DO KZ = 2,NSOIL - ZSOIL(KZ) = -SLDPTH(KZ)+ZSOIL(KZ-1) - END DO - - ENDIF - -C ---------------------------------------------------------------------- -C NEXT IS CRUCIAL CALL TO SET THE LAND-SURFACE PARAMETERS, INCLUDING -C SOIL-TYPE AND VEG-TYPE DEPENDENT PARAMETERS. -C SET SHDFAC=0.0 FOR BARE SOIL SURFACES -C ---------------------------------------------------------------------- - CALL REDPRM (VEGTYP,SOILTYP,SLOPETYP, - + CFACTR,CMCMAX,RSMAX,TOPT,REFKDT,KDT,SBETA, - O SHDFAC,RSMIN,RGL,HS,ZBOT,FRZX,PSISAT,SLOPE, - + SNUP,SALP,BEXP,DKSAT,DWSAT,SMCMAX,SMCWLT,SMCREF, - O SMCDRY,F1,QUARTZ,FXEXP,RTDIS,SLDPTH,ZSOIL, - + NROOT,NSOIL,Z0,CZIL,XLAI,CSOIL,PTU) - -C ---------------------------------------------------------------------- -C INITIALIZE PRECIPITATION LOGICALS. -C ---------------------------------------------------------------------- - SNOWNG = .FALSE. - FRZGRA = .FALSE. - -C ---------------------------------------------------------------------- -C OVER SEA-ICE OR GLACIAL-ICE, IF S.W.E. (SNEQV) BELOW THRESHOLD LOWER -C BOUND (0.01 M FOR SEA-ICE, 0.10 M FOR GLACIAL-ICE), THEN SET AT LOWER -C BOUND AND STORE THE SOURCE INCREMENT IN SUBSURFACE RUNOFF/BASEFLOW -C (RUNOFF2). NOTE: RUNOFF2 IS THEN A NEGATIVE VALUE (AS A FLAG) OVER -C SEA-ICE OR GLACIAL-ICE, IN ORDER TO ACHIEVE WATER BALANCE. -C ---------------------------------------------------------------------- - IF (ICE .EQ. 1) THEN - IF (SNEQV .LT. 0.01) THEN -c SNDENS = SNEQV/SNOWH -c RUNOFF2 = -(0.01-SNEQV)/DT - SNEQV = 0.01 - SNOWH = 0.10 -c SNOWH = SNEQV/SNDENS - ENDIF - ELSEIF (ICE .EQ. -1) THEN - IF (SNEQV .LT. 0.10) THEN -c SNDENS = SNEQV/SNOWH -c RUNOFF2 = -(0.10-SNEQV)/DT - SNEQV = 0.10 - SNOWH = 1.00 -c SNOWH = SNEQV/SNDENS - ENDIF - ENDIF - -C ---------------------------------------------------------------------- -C FOR SEA-ICE AND GLACIAL-ICE CASES, SET SMC AND SH20 VALUES = 1 AS A -C FLAG FOR NON-SOIL MEDIUM -C ---------------------------------------------------------------------- - IF (ICE .NE. 0) THEN - DO KZ = 1,NSOIL - SMC(KZ) = 1.0 - SH2O(KZ) = 1.0 - END DO - ENDIF - -C ---------------------------------------------------------------------- -C IF INPUT SNOWPACK IS NONZERO, THEN COMPUTE SNOW DENSITY "SNDENS" AND -C SNOW THERMAL CONDUCTIVITY "SNCOND" (NOTE THAT CSNOW IS A FUNCTION -C SUBROUTINE) -C ---------------------------------------------------------------------- - IF (SNEQV .EQ. 0.0) THEN - SNDENS = 0.0 - SNOWH = 0.0 - SNCOND = 1.0 - ELSE - SNDENS = SNEQV/SNOWH - sndens = max(0.0, min(1.0, sndens)) ! Added by Moorthi - SNCOND = CSNOW(SNDENS) - ENDIF - -C ---------------------------------------------------------------------- -C DETERMINE IF IT'S PRECIPITATING AND WHAT KIND OF PRECIP IT IS. -C IF IT'S PRCPING AND THE AIR TEMP IS COLDER THAN 0 C, IT'S SNOWING! -C IF IT'S PRCPING AND THE AIR TEMP IS WARMER THAN 0 C, BUT THE GRND -C TEMP IS COLDER THAN 0 C, FREEZING RAIN IS PRESUMED TO BE FALLING. -C ---------------------------------------------------------------------- - IF (PRCP .GT. 0.0) THEN -C IF (SFCTMP .LE. TFREEZ) THEN - IF (FFROZP .GT. 0.5) THEN - SNOWNG = .TRUE. - ELSE - IF (T1 .LE. TFREEZ) FRZGRA = .TRUE. - ENDIF - ENDIF - -C ---------------------------------------------------------------------- -C IF EITHER PRCP FLAG IS SET, DETERMINE NEW SNOWFALL (CONVERTING PRCP -C RATE FROM KG M-2 S-1 TO A LIQUID EQUIV SNOW DEPTH IN METERS) AND ADD -C IT TO THE EXISTING SNOWPACK. -C NOTE THAT SINCE ALL PRECIP IS ADDED TO SNOWPACK, NO PRECIP INFILTRATES -C INTO THE SOIL SO THAT PRCP1 IS SET TO ZERO. -C ---------------------------------------------------------------------- - IF ( (SNOWNG) .OR. (FRZGRA) ) THEN - SN_NEW = PRCP * DT * 0.001 - SNEQV = SNEQV + SN_NEW - PRCP1 = 0.0 - -C ---------------------------------------------------------------------- -C UPDATE SNOW DENSITY BASED ON NEW SNOWFALL, USING OLD AND NEW SNOW. -C UPDATE SNOW THERMAL CONDUCTIVITY -C ---------------------------------------------------------------------- - CALL SNOW_NEW (SFCTMP,SN_NEW,SNOWH,SNDENS) - SNCOND = CSNOW (SNDENS) - ELSE - -C ---------------------------------------------------------------------- -C PRECIP IS LIQUID (RAIN), HENCE SAVE IN THE PRECIP VARIABLE THAT -C LATER CAN WHOLELY OR PARTIALLY INFILTRATE THE SOIL (ALONG WITH -C ANY CANOPY "DRIP" ADDED TO THIS LATER) -C ---------------------------------------------------------------------- - PRCP1 = PRCP - - ENDIF - -C ---------------------------------------------------------------------- -C DETERMINE SNOWCOVER FRACTION AND ALBEDO FRACTION OVER LAND. -C ---------------------------------------------------------------------- - IF (ICE .NE. 0) THEN -C ---------------------------------------------------------------------- -C SNOW COVER, ALBEDO OVER SEA-ICE, GLACIAL-ICE -C ---------------------------------------------------------------------- - SNCOVR = 1.0 - ALBEDO = 0.65 - - ELSE -C ---------------------------------------------------------------------- -C NON-GLACIAL LAND -C IF SNOW DEPTH=0, SET SNOWCOVER FRACTION=0, ALBEDO=SNOW FREE ALBEDO. -C ---------------------------------------------------------------------- - IF (SNEQV .EQ. 0.0) THEN - SNCOVR = 0.0 - ALBEDO = ALB - - ELSE -C ---------------------------------------------------------------------- -C DETERMINE SNOW FRACTION COVER. -C DETERMINE SURFACE ALBEDO MODIFICATION DUE TO SNOWDEPTH STATE. -C ---------------------------------------------------------------------- - CALL SNFRAC (SNEQV,SNUP,SALP,SNOWH,SNCOVR) - CALL ALCALC (ALB,SNOALB,SHDFAC,SHDMIN,SNCOVR,TSNOW,ALBEDO) - ENDIF - - ENDIF - -C ---------------------------------------------------------------------- -C THERMAL CONDUCTIVITY FOR SEA-ICE CASE, GLACIAL-ICE CASE -C ---------------------------------------------------------------------- - IF (ICE .NE. 0) THEN - DF1 = 2.2 - - ELSE - -C ---------------------------------------------------------------------- -C NEXT CALCULATE THE SUBSURFACE HEAT FLUX, WHICH FIRST REQUIRES -C CALCULATION OF THE THERMAL DIFFUSIVITY. TREATMENT OF THE -C LATTER FOLLOWS THAT ON PAGES 148-149 FROM "HEAT TRANSFER IN -C COLD CLIMATES", BY V. J. LUNARDINI (PUBLISHED IN 1981 -C BY VAN NOSTRAND REINHOLD CO.) I.E. TREATMENT OF TWO CONTIGUOUS -C "PLANE PARALLEL" MEDIUMS (NAMELY HERE THE FIRST SOIL LAYER -C AND THE SNOWPACK LAYER, IF ANY). THIS DIFFUSIVITY TREATMENT -C BEHAVES WELL FOR BOTH ZERO AND NONZERO SNOWPACK, INCLUDING THE -C LIMIT OF VERY THIN SNOWPACK. THIS TREATMENT ALSO ELIMINATES -C THE NEED TO IMPOSE AN ARBITRARY UPPER BOUND ON SUBSURFACE -C HEAT FLUX WHEN THE SNOWPACK BECOMES EXTREMELY THIN. -C ---------------------------------------------------------------------- -C FIRST CALCULATE THERMAL DIFFUSIVITY OF TOP SOIL LAYER, USING -C BOTH THE FROZEN AND LIQUID SOIL MOISTURE, FOLLOWING THE -C SOIL THERMAL DIFFUSIVITY FUNCTION OF PETERS-LIDARD ET AL. -C (1998,JAS, VOL 55, 1209-1224), WHICH REQUIRES THE SPECIFYING -C THE QUARTZ CONTENT OF THE GIVEN SOIL CLASS (SEE ROUTINE REDPRM) -C ---------------------------------------------------------------------- - CALL TDFCND (DF1,SMC(1),QUARTZ,SMCMAX,SH2O(1)) - -C ---------------------------------------------------------------------- -C NEXT ADD SUBSURFACE HEAT FLUX REDUCTION EFFECT FROM THE -C OVERLYING GREEN CANOPY, ADAPTED FROM SECTION 2.1.2 OF -C PETERS-LIDARD ET AL. (1997, JGR, VOL 102(D4)) -C ---------------------------------------------------------------------- - DF1 = DF1 * EXP(SBETA*SHDFAC) - ENDIF - -C ---------------------------------------------------------------------- -C FINALLY "PLANE PARALLEL" SNOWPACK EFFECT FOLLOWING -C V.J. LINARDINI REFERENCE CITED ABOVE. NOTE THAT DTOT IS -C COMBINED DEPTH OF SNOWDEPTH AND THICKNESS OF FIRST SOIL LAYER -C ---------------------------------------------------------------------- - DSOIL = -(0.5 * ZSOIL(1)) - - IF (SNEQV .EQ. 0.) THEN - SSOIL = DF1 * (T1 - STC(1) ) / DSOIL - ELSE - DTOT = SNOWH + DSOIL - FRCSNO = SNOWH/DTOT - FRCSOI = DSOIL/DTOT -C -C 1. HARMONIC MEAN (SERIES FLOW) -C DF1 = (SNCOND*DF1)/(FRCSOI*SNCOND+FRCSNO*DF1) - DF1H = (SNCOND*DF1)/(FRCSOI*SNCOND+FRCSNO*DF1) -C 2. ARITHMETIC MEAN (PARALLEL FLOW) -C DF1 = FRCSNO*SNCOND + FRCSOI*DF1 - DF1A = FRCSNO*SNCOND + FRCSOI*DF1 -C -C 3. GEOMETRIC MEAN (INTERMEDIATE BETWEEN HARMONIC AND ARITHMETIC MEAN) -C DF1 = (SNCOND**FRCSNO)*(DF1**FRCSOI) -C TEST - MBEK, 10 Jan 2002 -C weigh DF by snow fraction -c DF1 = DF1H*SNCOVR + DF1A*(1.0-SNCOVR) -c DF1 = DF1H*SNCOVR + DF1*(1.0-SNCOVR) - DF1 = DF1A*SNCOVR + DF1*(1.0-SNCOVR) - -C ---------------------------------------------------------------------- -C CALCULATE SUBSURFACE HEAT FLUX, SSOIL, FROM FINAL THERMAL DIFFUSIVITY -C OF SURFACE MEDIUMS, DF1 ABOVE, AND SKIN TEMPERATURE AND TOP -C MID-LAYER SOIL TEMPERATURE -C ---------------------------------------------------------------------- - SSOIL = DF1 * (T1 - STC(1) ) / DTOT - ENDIF - -C ---------------------------------------------------------------------- -C DETERMINE SURFACE ROUGHNESS OVER SNOWPACK USING SNOW CONDITION FROM -C THE PREVIOUS TIMESTEP. -C ---------------------------------------------------------------------- - IF (COUPLE .EQ. 0) THEN -C UNCOUPLED MODE - IF (SNCOVR .GT. 0.) THEN - CALL SNOWZ0 (SNCOVR,Z0) - ENDIF - ENDIF - -C ---------------------------------------------------------------------- -C NEXT CALL ROUTINE SFCDIF TO CALCULATE THE SFC EXCHANGE COEF (CH) FOR -C HEAT AND MOISTURE. -C -C NOTE !!! -C COMMENT OUT CALL SFCDIF, IF SFCDIF ALREADY CALLED IN CALLING PROGRAM -C (SUCH AS IN COUPLED ATMOSPHERIC MODEL). -C -C NOTE !!! -C DO NOT CALL SFCDIF UNTIL AFTER ABOVE CALL TO REDPRM, IN CASE -C ALTERNATIVE VALUES OF ROUGHNESS LENGTH (Z0) AND ZILINTINKEVICH COEF -C (CZIL) ARE SET THERE VIA NAMELIST I/O. -C -C NOTE !!! -C ROUTINE SFCDIF RETURNS A CH THAT REPRESENTS THE WIND SPD TIMES THE -C "ORIGINAL" NONDIMENSIONAL "Ch" TYPICAL IN LITERATURE. HENCE THE CH -C RETURNED FROM SFCDIF HAS UNITS OF M/S. THE IMPORTANT COMPANION -C COEFFICIENT OF CH, CARRIED HERE AS "RCH", IS THE CH FROM SFCDIF TIMES -C AIR DENSITY AND PARAMETER "CP". "RCH" IS COMPUTED IN "CALL PENMAN". -C RCH RATHER THAN CH IS THE COEFF USUALLY INVOKED LATER IN EQNS. -C -C NOTE !!! -C SFCDIF ALSO RETURNS THE SURFACE EXCHANGE COEFFICIENT FOR MOMENTUM, CM, -C ALSO KNOWN AS THE SURFACE DRAGE COEFFICIENT, BUT CM IS NOT USED HERE. -C ---------------------------------------------------------------------- -C CALC VIRTUAL TEMPS AND VIRTUAL POTENTIAL TEMPS NEEDED BY SUBROUTINES -C SFCDIF AND PENMAN. -C ---------------------------------------------------------------------- - T2V = SFCTMP * (1.0 + 0.61 * Q2 ) - -C xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx -C KEY REQUIRED RADIATION TERM IS THE TOTAL DOWNWARD RADIATION (FDOWN) = -C NET SOLAR (SOLNET) + DOWNWARD LONGWAVE (LWDN), FOR USE IN PENMAN EP -C CALCULATION (PENMAN) AND OTHER SURFACE ENERGY BUDGET CALCUATIONS. -C -C ALSO NEED DOWNWARD SOLAR (SOLDN) FOR CANOPY RESISTANCE ROUTINE -C (CANRES). -C -C FDOWN, SOLDN ARE DERIVED DIFFERENTLY IN THE UNCOUPLED AND COUPLED -C MODES. -C xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx - - IF (COUPLE .EQ. 0) THEN !......uncoupled mode -C ---------------------------------------------------------------------- -C UNCOUPLED MODE: -C -C COMPUTE SURFACE EXCHANGE COEFFICIENTS -C ---------------------------------------------------------------------- - T1V = T1 * (1.0 + 0.61 * Q2) - TH2V = TH2 * (1.0 + 0.61 * Q2) - - CALL SFCDIF (ZLVL,Z0,T1V,TH2V,SFCSPD,CZIL,CM,CH) - -C ---------------------------------------------------------------------- -C RADFLX = DOWNWARD (INCOMING) SOLAR, NOT NET SOLAR -C ---------------------------------------------------------------------- - SOLDN = RADFLX - SOLNET = SOLDN*(1.0-ALBEDO) - FDOWN = SOLNET + LWDN - - ELSE !......coupled mode -C ---------------------------------------------------------------------- -C COUPLED MODE (COUPLE .NE. 0): -c -C SURFACE EXCHANGE COEFFICIENTS COMPUTED EXTERNALLY AND PASSED IN, HENCE -C SUBROUTINE SFCDIF NOT CALLED. -C -C RADFLX = FDOWN = NET SOLAR + DOWNWARD LONGWAVE -C ---------------------------------------------------------------------- - FDOWN = RADFLX - SOLNET = FDOWN - LWDN -c SOLDN = SOLNET/(1.0-ALBEDO) - SOLDN=SWDN - - ENDIF - -C ---------------------------------------------------------------------- -C CALL PENMAN SUBROUTINE TO CALCULATE POTENTIAL EVAPORATION (ETP), AND -C OTHER PARTIAL PRODUCTS AND SUMS SAVE IN COMMON/RITE FOR LATER -C CALCULATIONS. -C ---------------------------------------------------------------------- - CALL PENMAN (SFCTMP,SFCPRS,CH,T2V,TH2,PRCP,FDOWN,T24,SSOIL, - & Q2,Q2SAT,ETP,RCH,EPSCA,RR,SNOWNG,FRZGRA, - & DQSDT2,FLX2) - - -C ---------------------------------------------------------------------- -C CALL CANRES TO CALCULATE THE CANOPY RESISTANCE AND CONVERT IT INTO PC -C IF NONZERO GREENNESS FRACTION -C ---------------------------------------------------------------------- - IF (SHDFAC .GT. 0.) THEN - -C ---------------------------------------------------------------------- -C FROZEN GROUND EXTENSION: TOTAL SOIL WATER "SMC" WAS REPLACED -C BY UNFROZEN SOIL WATER "SH2O" IN CALL TO CANRES BELOW -C ---------------------------------------------------------------------- - CALL CANRES (SOLDN,CH,SFCTMP,Q2,SFCPRS,SH2O,ZSOIL,NSOIL, - & SMCWLT,SMCREF,RSMIN,RC,PC,NROOT,Q2SAT,DQSDT2, - & TOPT,RSMAX,RGL,HS,XLAI, - & RCS,RCT,RCQ,RCSOIL) - - ENDIF - -C ---------------------------------------------------------------------- -C NOW DECIDE MAJOR PATHWAY BRANCH TO TAKE DEPENDING ON WHETHER SNOWPACK -C EXISTS OR NOT: -C ---------------------------------------------------------------------- - ESNOW = 0.0 - IF (SNEQV .EQ. 0.0) THEN - CALL NOPAC (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, - & SMCREF,SMCDRY,CMC,CMCMAX,NSOIL,DT,SHDFAC, - & SBETA,Q2,T1,SFCTMP,T24,TH2,FDOWN,F1,SSOIL, - & STC,EPSCA,BEXP,PC,RCH,RR,CFACTR, - & SH2O,SLOPE,KDT,FRZX,PSISAT,ZSOIL, - & DKSAT,DWSAT,TBOT,ZBOT,RUNOFF1,RUNOFF2, - & RUNOFF3,EDIR,EC,ET,ETT,NROOT,ICE,RTDIS, - & QUARTZ,FXEXP,CSOIL, - & BETA,DRIP,DEW,FLX1,FLX2,FLX3) - ELSE - CALL SNOPAC (ETP,ETA,PRCP,PRCP1,SNOWNG,SMC,SMCMAX,SMCWLT, - & SMCREF,SMCDRY,CMC,CMCMAX,NSOIL,DT, - & SBETA,DF1, - & Q2,T1,SFCTMP,T24,TH2,FDOWN,F1,SSOIL,STC,EPSCA, - & SFCPRS,BEXP,PC,RCH,RR,CFACTR,SNCOVR,SNEQV,SNDENS, - & SNOWH,SH2O,SLOPE,KDT,FRZX,PSISAT,SNUP, - & ZSOIL,DWSAT,DKSAT,TBOT,ZBOT,SHDFAC,RUNOFF1, - & RUNOFF2,RUNOFF3,EDIR,EC,ET,ETT,NROOT,SNOMLT, - & ICE,RTDIS,QUARTZ,FXEXP,CSOIL, - & BETA,DRIP,DEW,FLX1,FLX2,FLX3,ESNOW) - ENDIF - -C ---------------------------------------------------------------------- -C PREPARE SENSIBLE HEAT (H) FOR RETURN TO PARENT MODEL -C ---------------------------------------------------------------------- - SHEAT = -(CH * CP * SFCPRS)/(R * T2V) * ( TH2 - T1 ) - -C ---------------------------------------------------------------------- -C CONVERT UNITS AND/OR SIGN OF TOTAL EVAP (ETA), POTENTIAL EVAP (ETP), -C SUBSURFACE HEAT FLUX (S), AND RUNOFFS FOR WHAT PARENT MODEL EXPECTS -C CONVERT ETA FROM KG M-2 S-1 TO W M-2 -C ---------------------------------------------------------------------- -c ETA = ETA*LVH2O -c ETP = ETP*LVH2O - -C ---------------------------------------------------------------------- - EDIR = EDIR * LVH2O - EC = EC * LVH2O - DO K=1,4 - ET(K) = ET(K) * LVH2O - ENDDO - ETT = ETT * LVH2O - ESNOW = ESNOW * LSUBS - ETP = ETP*((1.-SNCOVR)*LVH2O + SNCOVR*LSUBS) - IF (ETP .GT. 0.) THEN - ETA = EDIR + EC + ETT + ESNOW - ELSE - ETA = ETP - ENDIF - BETA = ETA/ETP -C ---------------------------------------------------------------------- - -C ---------------------------------------------------------------------- -C CONVERT THE SIGN OF SOIL HEAT FLUX SO THAT: -C SSOIL>0: WARM THE SURFACE (NIGHT TIME) -C SSOIL<0: COOL THE SURFACE (DAY TIME) -C ---------------------------------------------------------------------- - SSOIL = -1.0*SSOIL - - IF (ICE .EQ. 0) THEN -C ---------------------------------------------------------------------- -C FOR THE CASE OF LAND (BUT NOT GLACIAL-ICE): -C CONVERT RUNOFF3 (INTERNAL LAYER RUNOFF FROM SUPERSAT) FROM M TO M S-1 -C AND ADD TO SUBSURFACE RUNOFF/BASEFLOW (RUNOFF2). RUNOFF2 IS ALREADY -C A RATE AT THIS POINT. -C ---------------------------------------------------------------------- - RUNOFF3 = RUNOFF3/DT - RUNOFF2 = RUNOFF2+RUNOFF3 - - ELSE -C ---------------------------------------------------------------------- -C FOR THE CASE OF SEA-ICE (ICE=1) OR GLACIAL-ICE (ICE=-1), ADD ANY -C SNOWMELT DIRECTLY TO SURFACE RUNOFF (RUNOFF1) SINCE THERE IS NO -C SOIL MEDIUM, AND THUS NO CALL TO SUBROUTINE SMFLX (FOR SOIL MOISTURE -C TENDENCY). -C ---------------------------------------------------------------------- - RUNOFF1 = SNOMLT/DT - ENDIF - -C ---------------------------------------------------------------------- -C TOTAL COLUMN SOIL MOISTURE IN METERS (SOILM) AND ROOT-ZONE -C SOIL MOISTURE AVAILABILITY (FRACTION) RELATIVE TO POROSITY/SATURATION -C ---------------------------------------------------------------------- - SOILM = -1.0*SMC(1)*ZSOIL(1) - DO K = 2,NSOIL - SOILM = SOILM+SMC(K)*(ZSOIL(K-1)-ZSOIL(K)) - END DO - SOILWM = -1.0*(SMCMAX-SMCWLT)*ZSOIL(1) - SOILWW = -1.0*(SMC(1)-SMCWLT)*ZSOIL(1) - DO K = 2,NROOT - SOILWM = SOILWM+(SMCMAX-SMCWLT)*(ZSOIL(K-1)-ZSOIL(K)) - SOILWW = SOILWW+(SMC(K)-SMCWLT)*(ZSOIL(K-1)-ZSOIL(K)) - END DO - SOILW = SOILWW/SOILWM - -C ---------------------------------------------------------------------- -C END SUBROUTINE SFLX -C ---------------------------------------------------------------------- - RETURN - END - SUBROUTINE ALCALC (ALB,SNOALB,SHDFAC,SHDMIN,SNCOVR,TSNOW,ALBEDO) - - IMPLICIT NONE - -C ---------------------------------------------------------------------- -C CALCULATE ALBEDO INCLUDING SNOW EFFECT (0 -> 1) -C ALB SNOWFREE ALBEDO -C SNOALB MAXIMUM (DEEP) SNOW ALBEDO -C SHDFAC AREAL FRACTIONAL COVERAGE OF GREEN VEGETATION -C SHDMIN MINIMUM AREAL FRACTIONAL COVERAGE OF GREEN VEGETATION -C SNCOVR FRACTIONAL SNOW COVER -C ALBEDO SURFACE ALBEDO INCLUDING SNOW EFFECT -C TSNOW SNOW SURFACE TEMPERATURE (K) -C ---------------------------------------------------------------------- - REAL ALB, SNOALB, SHDFAC, SHDMIN, SNCOVR, ALBEDO, TSNOW - -C ---------------------------------------------------------------------- -C SNOALB IS ARGUMENT REPRESENTING MAXIMUM ALBEDO OVER DEEP SNOW, -C AS PASSED INTO SFLX, AND ADAPTED FROM THE SATELLITE-BASED MAXIMUM -C SNOW ALBEDO FIELDS PROVIDED BY D. ROBINSON AND G. KUKLA -C (1985, JCAM, VOL 24, 402-411) -C ---------------------------------------------------------------------- -C changed in version 2.6 on June 2nd 2003 -C ALBEDO = ALB + (1.0-(SHDFAC-SHDMIN))*SNCOVR*(SNOALB-ALB) - ALBEDO = ALB + SNCOVR*(SNOALB-ALB) - IF (ALBEDO .GT. SNOALB) ALBEDO=SNOALB - -C BASE FORMULATION (DICKINSON ET AL., 1986, COGLEY ET AL., 1990) -C IF (TSNOW.LE.263.16) THEN -C ALBEDO=SNOALB -C ELSE -C IF (TSNOW.LT.273.16) THEN -C TM=0.1*(TSNOW-263.16) -C ALBEDO=0.5*((0.9-0.2*(TM**3))+(0.8-0.16*(TM**3))) -C ELSE -C ALBEDO=0.67 -C ENDIF -C ENDIF - -C ISBA FORMULATION (VERSEGHY, 1991; BAKER ET AL., 1990) -C IF (TSNOW.LT.273.16) THEN -C ALBEDO=SNOALB-0.008*DT/86400 -C ELSE -C ALBEDO=(SNOALB-0.5)*EXP(-0.24*DT/86400)+0.5 -C ENDIF - -C ---------------------------------------------------------------------- -C END SUBROUTINE ALCALC -C ---------------------------------------------------------------------- - RETURN - END - SUBROUTINE CANRES (SOLAR,CH,SFCTMP,Q2,SFCPRS,SMC,ZSOIL,NSOIL, - & SMCWLT,SMCREF,RSMIN,RC,PC,NROOT,Q2SAT,DQSDT2, - & TOPT,RSMAX,RGL,HS,XLAI, - & RCS,RCT,RCQ,RCSOIL) - - IMPLICIT NONE - -C ---------------------------------------------------------------------- -C SUBROUTINE CANRES -C ---------------------------------------------------------------------- -C CALCULATE CANOPY RESISTANCE WHICH DEPENDS ON INCOMING SOLAR RADIATION, -C AIR TEMPERATURE, ATMOSPHERIC WATER VAPOR PRESSURE DEFICIT AT THE -C LOWEST MODEL LEVEL, AND SOIL MOISTURE (PREFERABLY UNFROZEN SOIL -C MOISTURE RATHER THAN TOTAL) -C ---------------------------------------------------------------------- -C SOURCE: JARVIS (1976), NOILHAN AND PLANTON (1989, MWR), JACQUEMIN AND -C NOILHAN (1990, BLM) -C SEE ALSO: CHEN ET AL (1996, JGR, VOL 101(D3), 7251-7268), EQNS 12-14 -C AND TABLE 2 OF SEC. 3.1.2 -C ---------------------------------------------------------------------- -C INPUT: -C SOLAR INCOMING SOLAR RADIATION -C CH SURFACE EXCHANGE COEFFICIENT FOR HEAT AND MOISTURE -C SFCTMP AIR TEMPERATURE AT 1ST LEVEL ABOVE GROUND -C Q2 AIR HUMIDITY AT 1ST LEVEL ABOVE GROUND -C Q2SAT SATURATION AIR HUMIDITY AT 1ST LEVEL ABOVE GROUND -C DQSDT2 SLOPE OF SATURATION HUMIDITY FUNCTION WRT TEMP -C SFCPRS SURFACE PRESSURE -C SMC VOLUMETRIC SOIL MOISTURE -C ZSOIL SOIL DEPTH (NEGATIVE SIGN, AS IT IS BELOW GROUND) -C NSOIL NO. OF SOIL LAYERS -C NROOT NO. OF SOIL LAYERS IN ROOT ZONE (1.LE.NROOT.LE.NSOIL) -C XLAI LEAF AREA INDEX -C SMCWLT WILTING POINT -C SMCREF REFERENCE SOIL MOISTURE (WHERE SOIL WATER DEFICIT STRESS -C SETS IN) -C RSMIN, RSMAX, TOPT, RGL, HS ARE CANOPY STRESS PARAMETERS SET IN -C SURBOUTINE REDPRM -C OUTPUT: -C PC PLANT COEFFICIENT -C RC CANOPY RESISTANCE -C ---------------------------------------------------------------------- - INTEGER NSOLD - PARAMETER(NSOLD = 4) - - INTEGER K - INTEGER NROOT - INTEGER NSOIL - - REAL CH - REAL CP - REAL DELTA - REAL DQSDT2 - REAL FF - REAL GX - REAL HS - REAL P - REAL PART(NSOLD) - REAL PC - REAL Q2 - REAL Q2SAT - REAL RC - REAL RSMIN - REAL RCQ - REAL RCS - REAL RCSOIL - REAL RCT - REAL RD - REAL RGL - REAL RR - REAL RSMAX - REAL SFCPRS - REAL SFCTMP - REAL SIGMA - REAL SLV - REAL SMC(NSOIL) - REAL SMCREF - REAL SMCWLT - REAL SOLAR - REAL TOPT - REAL SLVCP - REAL ST1 - REAL TAIR4 - REAL XLAI - REAL ZSOIL(NSOIL) - - PARAMETER(CP = 1004.5) - PARAMETER(RD = 287.04) - PARAMETER(SIGMA = 5.67E-8) - PARAMETER(SLV = 2.501000E6) - -C ---------------------------------------------------------------------- -C INITIALIZE CANOPY RESISTANCE MULTIPLIER TERMS. -C ---------------------------------------------------------------------- - RCS = 0.0 - RCT = 0.0 - RCQ = 0.0 - RCSOIL = 0.0 - RC = 0.0 - -C ---------------------------------------------------------------------- -C CONTRIBUTION DUE TO INCOMING SOLAR RADIATION -C ---------------------------------------------------------------------- - FF = 0.55*2.0*SOLAR/(RGL*XLAI) - RCS = (FF + RSMIN/RSMAX) / (1.0 + FF) - RCS = MAX(RCS,0.0001) - -C ---------------------------------------------------------------------- -C CONTRIBUTION DUE TO AIR TEMPERATURE AT FIRST MODEL LEVEL ABOVE GROUND -C RCT EXPRESSION FROM NOILHAN AND PLANTON (1989, MWR). -C ---------------------------------------------------------------------- - RCT = 1.0 - 0.0016*((TOPT-SFCTMP)**2.0) - RCT = MAX(RCT,0.0001) - -C ---------------------------------------------------------------------- -C CONTRIBUTION DUE TO VAPOR PRESSURE DEFICIT AT FIRST MODEL LEVEL. -C RCQ EXPRESSION FROM SSIB -C ---------------------------------------------------------------------- - RCQ = 1.0/(1.0+HS*(Q2SAT-Q2)) - RCQ = MAX(RCQ,0.01) - -C ---------------------------------------------------------------------- -C CONTRIBUTION DUE TO SOIL MOISTURE AVAILABILITY. -C DETERMINE CONTRIBUTION FROM EACH SOIL LAYER, THEN ADD THEM UP. -C ---------------------------------------------------------------------- - GX = (SMC(1) - SMCWLT) / (SMCREF - SMCWLT) - IF (GX .GT. 1.) GX = 1. - IF (GX .LT. 0.) GX = 0. - -C ---------------------------------------------------------------------- -C USE SOIL DEPTH AS WEIGHTING FACTOR -C ---------------------------------------------------------------------- - PART(1) = (ZSOIL(1)/ZSOIL(NROOT)) * GX -C ---------------------------------------------------------------------- -C USE ROOT DISTRIBUTION AS WEIGHTING FACTOR -C PART(1) = RTDIS(1) * GX -C ---------------------------------------------------------------------- - DO K = 2,NROOT - GX = (SMC(K) - SMCWLT) / (SMCREF - SMCWLT) - IF (GX .GT. 1.) GX = 1. - IF (GX .LT. 0.) GX = 0. -C ---------------------------------------------------------------------- -C USE SOIL DEPTH AS WEIGHTING FACTOR -C ---------------------------------------------------------------------- - PART(K) = ((ZSOIL(K)-ZSOIL(K-1))/ZSOIL(NROOT)) * GX -C ---------------------------------------------------------------------- -C USE ROOT DISTRIBUTION AS WEIGHTING FACTOR -C PART(K) = RTDIS(K) * GX -C ---------------------------------------------------------------------- - END DO - - DO K = 1,NROOT - RCSOIL = RCSOIL+PART(K) - END DO - RCSOIL = MAX(RCSOIL,0.0001) - -C ---------------------------------------------------------------------- -C DETERMINE CANOPY RESISTANCE DUE TO ALL FACTORS. CONVERT CANOPY -C RESISTANCE (RC) TO PLANT COEFFICIENT (PC) TO BE USED WITH POTENTIAL -C EVAP IN DETERMINING ACTUAL EVAP. PC IS DETERMINED BY: -C PC * LINERIZED PENMAN POTENTIAL EVAP = -C PENMAN-MONTEITH ACTUAL EVAPORATION (CONTAINING RC TERM). -C ---------------------------------------------------------------------- - RC = RSMIN/(XLAI*RCS*RCT*RCQ*RCSOIL) - -c TAIR4 = SFCTMP**4. -c ST1 = (4.*SIGMA*RD)/CP -c SLVCP = SLV/CP -c RR = ST1*TAIR4/(SFCPRS*CH) + 1.0 - RR = (4.*SIGMA*RD/CP)*(SFCTMP**4.)/(SFCPRS*CH) + 1.0 - DELTA = (SLV/CP)*DQSDT2 - - PC = (RR+DELTA)/(RR*(1.+RC*CH)+DELTA) - -C ---------------------------------------------------------------------- -C END SUBROUTINE CANRES -C ---------------------------------------------------------------------- - RETURN - END - FUNCTION CSNOW (DSNOW) - - IMPLICIT NONE - -C ---------------------------------------------------------------------- -C FUNCTION CSNOW -C ---------------------------------------------------------------------- -C CALCULATE SNOW TERMAL CONDUCTIVITY -C ---------------------------------------------------------------------- - REAL C - REAL DSNOW - REAL CSNOW - REAL UNIT - - PARAMETER(UNIT = 0.11631) - -C ---------------------------------------------------------------------- -C CSNOW IN UNITS OF CAL/(CM*HR*C), RETURNED IN W/(M*C) -C BASIC VERSION IS DYACHKOVA EQUATION (1960), FOR RANGE 0.1-0.4 -C ---------------------------------------------------------------------- - C=0.328*10**(2.25*DSNOW) - CSNOW=UNIT*C - -C ---------------------------------------------------------------------- -C DE VAUX EQUATION (1933), IN RANGE 0.1-0.6 -C ---------------------------------------------------------------------- -C CSNOW=0.0293*(1.+100.*DSNOW**2) - -C ---------------------------------------------------------------------- -C E. ANDERSEN FROM FLERCHINGER -C ---------------------------------------------------------------------- -C CSNOW=0.021+2.51*DSNOW**2 - -C ---------------------------------------------------------------------- -C END FUNCTION CSNOW -C ---------------------------------------------------------------------- - RETURN - END - SUBROUTINE DEVAP (EDIR1,ETP1,SMC,ZSOIL,SHDFAC,SMCMAX,BEXP, -c FUNCTION DEVAP (ETP1,SMC,ZSOIL,SHDFAC,SMCMAX,BEXP, - & DKSAT,DWSAT,SMCDRY,SMCREF,SMCWLT,FXEXP) - - IMPLICIT NONE - -C ---------------------------------------------------------------------- -C SUBROUTINE DEVAP -C FUNCTION DEVAP -C ---------------------------------------------------------------------- -C CALCULATE DIRECT SOIL EVAPORATION -C ---------------------------------------------------------------------- - REAL BEXP -c REAL DEVAP - REAL EDIR1 - REAL DKSAT - REAL DWSAT - REAL ETP1 - REAL FX - REAL FXEXP - REAL SHDFAC - REAL SMC - REAL SMCDRY - REAL SMCMAX - REAL ZSOIL - REAL SMCREF - REAL SMCWLT - REAL SRATIO - -C ---------------------------------------------------------------------- -C DIRECT EVAP A FUNCTION OF RELATIVE SOIL MOISTURE AVAILABILITY, LINEAR -C WHEN FXEXP=1. -C FX > 1 REPRESENTS DEMAND CONTROL -C FX < 1 REPRESENTS FLUX CONTROL -C ---------------------------------------------------------------------- - SRATIO = (SMC - SMCDRY) / (SMCMAX - SMCDRY) - IF (SRATIO .GT. 0.) THEN - FX = SRATIO**FXEXP - FX = MAX ( MIN ( FX, 1. ) ,0. ) - ELSE - FX = 0. - ENDIF - -C ---------------------------------------------------------------------- -C ALLOW FOR THE DIRECT-EVAP-REDUCING EFFECT OF SHADE -C ---------------------------------------------------------------------- -c DEVAP = FX * ( 1.0 - SHDFAC ) * ETP1 - EDIR1 = FX * ( 1.0 - SHDFAC ) * ETP1 - -C ---------------------------------------------------------------------- -C END SUBROUTINE DEVAP -C END FUNCTION DEVAP -C ---------------------------------------------------------------------- - RETURN - END - SUBROUTINE EVAPO (ETA1,SMC,NSOIL,CMC,ETP1,DT,ZSOIL, - & SH2O, - & SMCMAX,BEXP,PC,SMCWLT,DKSAT,DWSAT, - & SMCREF,SHDFAC,CMCMAX, - & SMCDRY,CFACTR, - & EDIR1,EC1,ET1,ETT1,SFCTMP,Q2,NROOT,RTDIS,FXEXP) - - IMPLICIT NONE - -C ---------------------------------------------------------------------- -C SUBROUTINE EVAPO -C ---------------------------------------------------------------------- -C CALCULATE SOIL MOISTURE FLUX. THE SOIL MOISTURE CONTENT (SMC - A PER -C UNIT VOLUME MEASUREMENT) IS A DEPENDENT VARIABLE THAT IS UPDATED WITH -C PROGNOSTIC EQNS. THE CANOPY MOISTURE CONTENT (CMC) IS ALSO UPDATED. -C FROZEN GROUND VERSION: NEW STATES ADDED: SH2O, AND FROZEN GROUND -C CORRECTION FACTOR, FRZFACT AND PARAMETER SLOPE. -C ---------------------------------------------------------------------- - INTEGER NSOLD - PARAMETER(NSOLD = 4) - - INTEGER I - INTEGER K - INTEGER NSOIL - INTEGER NROOT - - REAL BEXP - REAL CFACTR - REAL CMC - REAL CMC2MS - REAL CMCMAX -c REAL DEVAP - REAL DKSAT - REAL DT - REAL DWSAT - REAL EC1 - REAL EDIR1 - REAL ET1(NSOIL) - REAL ETA1 - REAL ETP1 - REAL ETT1 - REAL FXEXP - REAL PC - REAL Q2 - REAL RTDIS(NSOIL) - REAL SFCTMP - REAL SHDFAC - REAL SMC(NSOIL) - REAL SH2O(NSOIL) - REAL SMCDRY - REAL SMCMAX - REAL SMCREF - REAL SMCWLT - REAL ZSOIL(NSOIL) - -C ---------------------------------------------------------------------- -C EXECUTABLE CODE BEGINS HERE IF THE POTENTIAL EVAPOTRANSPIRATION IS -C GREATER THAN ZERO. -C ---------------------------------------------------------------------- - EDIR1 = 0. - EC1 = 0. - DO K = 1,NSOIL - ET1(K) = 0. - END DO - ETT1 = 0. - - IF (ETP1 .GT. 0.0) THEN - -C ---------------------------------------------------------------------- -C RETRIEVE DIRECT EVAPORATION FROM SOIL SURFACE. CALL THIS FUNCTION -C ONLY IF VEG COVER NOT COMPLETE. -C FROZEN GROUND VERSION: SH2O STATES REPLACE SMC STATES. -C ---------------------------------------------------------------------- - IF (SHDFAC .LT. 1.) THEN - CALL DEVAP (EDIR1,ETP1,SH2O(1),ZSOIL(1),SHDFAC,SMCMAX, -c EDIR = DEVAP(ETP1,SH2O(1),ZSOIL(1),SHDFAC,SMCMAX, - & BEXP,DKSAT,DWSAT,SMCDRY,SMCREF,SMCWLT,FXEXP) - ENDIF - -C ---------------------------------------------------------------------- -C INITIALIZE PLANT TOTAL TRANSPIRATION, RETRIEVE PLANT TRANSPIRATION, -C AND ACCUMULATE IT FOR ALL SOIL LAYERS. -C ---------------------------------------------------------------------- - IF (SHDFAC.GT.0.0) THEN - - CALL TRANSP (ET1,NSOIL,ETP1,SH2O,CMC,ZSOIL,SHDFAC,SMCWLT, - & CMCMAX,PC,CFACTR,SMCREF,SFCTMP,Q2,NROOT,RTDIS) - - DO K = 1,NSOIL - ETT1 = ETT1 + ET1(K) - END DO - -C ---------------------------------------------------------------------- -C CALCULATE CANOPY EVAPORATION. -C IF STATEMENTS TO AVOID TANGENT LINEAR PROBLEMS NEAR CMC=0.0. -C ---------------------------------------------------------------------- - IF (CMC .GT. 0.0) THEN - EC1 = SHDFAC * ( ( CMC / CMCMAX ) ** CFACTR ) * ETP1 - ELSE - EC1 = 0.0 - ENDIF - -C ---------------------------------------------------------------------- -C EC SHOULD BE LIMITED BY THE TOTAL AMOUNT OF AVAILABLE WATER ON THE -C CANOPY. -F.CHEN, 18-OCT-1994 -C ---------------------------------------------------------------------- - CMC2MS = CMC / DT - EC1 = MIN ( CMC2MS, EC1 ) - ENDIF - ENDIF - -C ---------------------------------------------------------------------- -C TOTAL UP EVAP AND TRANSP TYPES TO OBTAIN ACTUAL EVAPOTRANSP -C ---------------------------------------------------------------------- - ETA1 = EDIR1 + ETT1 + EC1 - -C ---------------------------------------------------------------------- -C END SUBROUTINE EVAPO -C ---------------------------------------------------------------------- - RETURN - END - FUNCTION FRH2O (TKELV,SMC,SH2O,SMCMAX,BEXP,PSIS) - - IMPLICIT NONE - -C ---------------------------------------------------------------------- -C FUNCTION FRH2O -C ---------------------------------------------------------------------- -C CALCULATE AMOUNT OF SUPERCOOLED LIQUID SOIL WATER CONTENT IF -C TEMPERATURE IS BELOW 273.15K (T0). REQUIRES NEWTON-TYPE ITERATION TO -C SOLVE THE NONLINEAR IMPLICIT EQUATION GIVEN IN EQN 17 OF KOREN ET AL -C (1999, JGR, VOL 104(D16), 19569-19585). -C ---------------------------------------------------------------------- -C NEW VERSION (JUNE 2001): MUCH FASTER AND MORE ACCURATE NEWTON -C ITERATION ACHIEVED BY FIRST TAKING LOG OF EQN CITED ABOVE -- LESS THAN -C 4 (TYPICALLY 1 OR 2) ITERATIONS ACHIEVES CONVERGENCE. ALSO, EXPLICIT -C 1-STEP SOLUTION OPTION FOR SPECIAL CASE OF PARAMETER CK=0, WHICH -C REDUCES THE ORIGINAL IMPLICIT EQUATION TO A SIMPLER EXPLICIT FORM, -C KNOWN AS THE "FLERCHINGER EQN". IMPROVED HANDLING OF SOLUTION IN THE -C LIMIT OF FREEZING POINT TEMPERATURE T0. -C ---------------------------------------------------------------------- -C INPUT: -C -C TKELV.........TEMPERATURE (Kelvin) -C SMC...........TOTAL SOIL MOISTURE CONTENT (VOLUMETRIC) -C SH2O..........LIQUID SOIL MOISTURE CONTENT (VOLUMETRIC) -C SMCMAX........SATURATION SOIL MOISTURE CONTENT (FROM REDPRM) -C B.............SOIL TYPE "B" PARAMETER (FROM REDPRM) -C PSIS..........SATURATED SOIL MATRIC POTENTIAL (FROM REDPRM) -C -C OUTPUT: -C FRH2O.........SUPERCOOLED LIQUID WATER CONTENT -C ---------------------------------------------------------------------- - REAL BEXP - REAL BLIM - REAL BX - REAL CK - REAL DENOM - REAL DF - REAL DH2O - REAL DICE - REAL DSWL - REAL ERROR - REAL FK - REAL FRH2O - REAL GS - REAL HLICE - REAL PSIS - REAL SH2O - REAL SMC - REAL SMCMAX - REAL SWL - REAL SWLK - REAL TKELV - REAL T0 - - INTEGER NLOG - INTEGER KCOUNT - - PARAMETER(CK = 8.0) -C PARAMETER(CK = 0.0) - PARAMETER(BLIM = 5.5) - PARAMETER(ERROR = 0.005) - - PARAMETER(HLICE = 3.335E5) - PARAMETER(GS = 9.81) - PARAMETER(DICE = 920.0) - PARAMETER(DH2O = 1000.0) - PARAMETER(T0 = 273.15) - -C ---------------------------------------------------------------------- -C LIMITS ON PARAMETER B: B < 5.5 (use parameter BLIM) -C SIMULATIONS SHOWED IF B > 5.5 UNFROZEN WATER CONTENT IS -C NON-REALISTICALLY HIGH AT VERY LOW TEMPERATURES. -C ---------------------------------------------------------------------- - BX = BEXP - IF (BEXP .GT. BLIM) BX = BLIM - -C ---------------------------------------------------------------------- -C INITIALIZING ITERATIONS COUNTER AND ITERATIVE SOLUTION FLAG. -C ---------------------------------------------------------------------- - NLOG=0 - KCOUNT=0 - -C ---------------------------------------------------------------------- -C IF TEMPERATURE NOT SIGNIFICANTLY BELOW FREEZING (T0), SH2O = SMC -C ---------------------------------------------------------------------- - IF (TKELV .GT. (T0 - 1.E-3)) THEN - FRH2O = SMC - ELSE - IF (CK .NE. 0.0) THEN - -C ---------------------------------------------------------------------- -C OPTION 1: ITERATED SOLUTION FOR NONZERO CK -C IN KOREN ET AL, JGR, 1999, EQN 17 -C ---------------------------------------------------------------------- -C INITIAL GUESS FOR SWL (frozen content) -C ---------------------------------------------------------------------- - SWL = SMC-SH2O - -C ---------------------------------------------------------------------- -C KEEP WITHIN BOUNDS. -C ---------------------------------------------------------------------- - IF (SWL .GT. (SMC-0.02)) SWL = SMC-0.02 - IF (SWL .LT. 0.) SWL = 0. - -C ---------------------------------------------------------------------- -C START OF ITERATIONS -C ---------------------------------------------------------------------- - DO WHILE ( (NLOG .LT. 10) .AND. (KCOUNT .EQ. 0) ) - NLOG = NLOG+1 - DF = ALOG(( PSIS*GS/HLICE ) * ( ( 1.+CK*SWL )**2. ) * - & ( SMCMAX/(SMC-SWL) )**BX) - ALOG(-(TKELV-T0)/TKELV) - DENOM = 2. * CK / ( 1.+CK*SWL ) + BX / ( SMC - SWL ) - SWLK = SWL - DF/DENOM -C ---------------------------------------------------------------------- -C BOUNDS USEFUL FOR MATHEMATICAL SOLUTION. -C ---------------------------------------------------------------------- - IF (SWLK .GT. (SMC-0.02)) SWLK = SMC - 0.02 - IF (SWLK .LT. 0.) SWLK = 0. - -C ---------------------------------------------------------------------- -C MATHEMATICAL SOLUTION BOUNDS APPLIED. -C ---------------------------------------------------------------------- - DSWL = ABS(SWLK-SWL) - SWL = SWLK - -C ---------------------------------------------------------------------- -C IF MORE THAN 10 ITERATIONS, USE EXPLICIT METHOD (CK=0 APPROX.) -C WHEN DSWL LESS OR EQ. ERROR, NO MORE ITERATIONS REQUIRED. -C ---------------------------------------------------------------------- - IF ( DSWL .LE. ERROR ) THEN - KCOUNT = KCOUNT+1 - ENDIF - END DO - -C ---------------------------------------------------------------------- -C END OF ITERATIONS -C ---------------------------------------------------------------------- -C BOUNDS APPLIED WITHIN DO-BLOCK ARE VALID FOR PHYSICAL SOLUTION. -C ---------------------------------------------------------------------- - FRH2O = SMC - SWL - -C ---------------------------------------------------------------------- -C END OPTION 1 -C ---------------------------------------------------------------------- - ENDIF - -C ---------------------------------------------------------------------- -C OPTION 2: EXPLICIT SOLUTION FOR FLERCHINGER EQ. i.e. CK=0 -C IN KOREN ET AL., JGR, 1999, EQN 17 -C APPLY PHYSICAL BOUNDS TO FLERCHINGER SOLUTION -C ---------------------------------------------------------------------- - IF (KCOUNT .EQ. 0) THEN -!Clu........comment out the following line to shorten the standard output -!* Print*,'Flerchinger used in NEW version. Iterations=',NLOG - - FK = (((HLICE/(GS*(-PSIS)))* - & ((TKELV-T0)/TKELV))**(-1/BX))*SMCMAX - IF (FK .LT. 0.02) FK = 0.02 - FRH2O = MIN (FK, SMC) -C ---------------------------------------------------------------------- -C END OPTION 2 -C ---------------------------------------------------------------------- - ENDIF - - ENDIF - -C ---------------------------------------------------------------------- -C END FUNCTION FRH2O -C ---------------------------------------------------------------------- - RETURN - END - SUBROUTINE HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1, - & TBOT,ZBOT,PSISAT,SH2O,DT,BEXP, - & F1,DF1,QUARTZ,CSOIL,AI,BI,CI) - - IMPLICIT NONE - -C ---------------------------------------------------------------------- -C SUBROUTINE HRT -C ---------------------------------------------------------------------- -C CALCULATE THE RIGHT HAND SIDE OF THE TIME TENDENCY TERM OF THE SOIL -C THERMAL DIFFUSION EQUATION. ALSO TO COMPUTE ( PREPARE ) THE MATRIX -C COEFFICIENTS FOR THE TRI-DIAGONAL MATRIX OF THE IMPLICIT TIME SCHEME. -C ---------------------------------------------------------------------- - INTEGER NSOLD - PARAMETER(NSOLD = 4) - - LOGICAL ITAVG - - INTEGER I - INTEGER K - INTEGER NSOIL - -C ---------------------------------------------------------------------- -C DECLARE WORK ARRAYS NEEDED IN TRI-DIAGONAL IMPLICIT SOLVER -C ---------------------------------------------------------------------- - REAL AI(NSOLD) - REAL BI(NSOLD) - REAL CI(NSOLD) - -C ---------------------------------------------------------------------- -C DECLARATIONS -C ---------------------------------------------------------------------- - REAL BEXP - REAL CAIR - REAL CH2O - REAL CICE - REAL CSOIL - REAL DDZ - REAL DDZ2 - REAL DENOM - REAL DF1 - REAL DF1N - REAL DF1K - REAL DT - REAL DTSDZ - REAL DTSDZ2 - REAL F1 - REAL HCPCT - REAL PSISAT - REAL QUARTZ - REAL QTOT - REAL RHSTS(NSOIL) - REAL SSOIL - REAL SICE - REAL SMC(NSOIL) - REAL SH2O(NSOIL) - REAL SMCMAX - REAL SNKSRC - REAL STC(NSOIL) - REAL T0 - REAL TAVG - REAL TBK - REAL TBK1 - REAL TBOT - REAL ZBOT - REAL TSNSR - REAL TSURF - REAL YY - REAL ZSOIL(NSOIL) - REAL ZZ1 - - PARAMETER(T0 = 273.15) - -C ---------------------------------------------------------------------- -C SET SPECIFIC HEAT CAPACITIES OF AIR, WATER, ICE, SOIL MINERAL -C ---------------------------------------------------------------------- - PARAMETER(CAIR = 1004.0) - PARAMETER(CH2O = 4.2E6) - PARAMETER(CICE = 2.106E6) -C NOTE: CSOIL NOW SET IN ROUTINE REDPRM AND PASSED IN -C PARAMETER(CSOIL = 1.26E6) - -C ---------------------------------------------------------------------- -C INITIALIZE LOGICAL FOR SOIL LAYER TEMPERATURE AVERAGING. -C ---------------------------------------------------------------------- - ITAVG = .TRUE. -C ITAVG = .FALSE. - -C ---------------------------------------------------------------------- -C BEGIN SECTION FOR TOP SOIL LAYER -C ---------------------------------------------------------------------- -C CALC THE HEAT CAPACITY OF THE TOP SOIL LAYER -C ---------------------------------------------------------------------- - HCPCT = SH2O(1)*CH2O + (1.0-SMCMAX)*CSOIL + (SMCMAX-SMC(1))*CAIR - & + ( SMC(1) - SH2O(1) )*CICE - -C ---------------------------------------------------------------------- -C CALC THE MATRIX COEFFICIENTS AI, BI, AND CI FOR THE TOP LAYER -C ---------------------------------------------------------------------- - DDZ = 1.0 / ( -0.5 * ZSOIL(2) ) - AI(1) = 0.0 - CI(1) = (DF1 * DDZ) / (ZSOIL(1) * HCPCT) - BI(1) = -CI(1) + DF1 / (0.5 * ZSOIL(1) * ZSOIL(1)*HCPCT*ZZ1) - -C ---------------------------------------------------------------------- -C CALCULATE THE VERTICAL SOIL TEMP GRADIENT BTWN THE 1ST AND 2ND SOIL -C LAYERS. THEN CALCULATE THE SUBSURFACE HEAT FLUX. USE THE TEMP -C GRADIENT AND SUBSFC HEAT FLUX TO CALC "RIGHT-HAND SIDE TENDENCY -C TERMS", OR "RHSTS", FOR TOP SOIL LAYER. -C ---------------------------------------------------------------------- - DTSDZ = (STC(1) - STC(2)) / (-0.5 * ZSOIL(2)) - SSOIL = DF1 * (STC(1) - YY) / (0.5 * ZSOIL(1) * ZZ1) - RHSTS(1) = (DF1 * DTSDZ - SSOIL) / (ZSOIL(1) * HCPCT) - -C ---------------------------------------------------------------------- -C NEXT CAPTURE THE VERTICAL DIFFERENCE OF THE HEAT FLUX AT TOP AND -C BOTTOM OF FIRST SOIL LAYER FOR USE IN HEAT FLUX CONSTRAINT APPLIED TO -C POTENTIAL SOIL FREEZING/THAWING IN ROUTINE SNKSRC. -C ---------------------------------------------------------------------- - QTOT = SSOIL - DF1*DTSDZ - -C ---------------------------------------------------------------------- -C IF TEMPERATURE AVERAGING INVOKED (ITAVG=TRUE; ELSE SKIP): -C SET TEMP "TSURF" AT TOP OF SOIL COLUMN (FOR USE IN FREEZING SOIL -C PHYSICS LATER IN FUNCTION SUBROUTINE SNKSRC). IF SNOWPACK CONTENT IS -C ZERO, THEN TSURF EXPRESSION BELOW GIVES TSURF = SKIN TEMP. IF -C SNOWPACK IS NONZERO (HENCE ARGUMENT ZZ1=1), THEN TSURF EXPRESSION -C BELOW YIELDS SOIL COLUMN TOP TEMPERATURE UNDER SNOWPACK. THEN -C CALCULATE TEMPERATURE AT BOTTOM INTERFACE OF 1ST SOIL LAYER FOR USE -C LATER IN FUNCTION SUBROUTINE SNKSRC -C ---------------------------------------------------------------------- - IF (ITAVG) THEN - TSURF = (YY + (ZZ1-1) * STC(1)) / ZZ1 - CALL TBND (STC(1),STC(2),ZSOIL,ZBOT,1,NSOIL,TBK) - ENDIF - -C ---------------------------------------------------------------------- -C CALCULATE FROZEN WATER CONTENT IN 1ST SOIL LAYER. -C ---------------------------------------------------------------------- - SICE = SMC(1) - SH2O(1) - -C ---------------------------------------------------------------------- -C IF FROZEN WATER PRESENT OR ANY OF LAYER-1 MID-POINT OR BOUNDING -C INTERFACE TEMPERATURES BELOW FREEZING, THEN CALL SNKSRC TO -C COMPUTE HEAT SOURCE/SINK (AND CHANGE IN FROZEN WATER CONTENT) -C DUE TO POSSIBLE SOIL WATER PHASE CHANGE -C ---------------------------------------------------------------------- - IF ( (SICE .GT. 0.) .OR. (TSURF .LT. T0) .OR. - & (STC(1) .LT. T0) .OR. (TBK .LT. T0) ) THEN - - IF (ITAVG) THEN - CALL TMPAVG(TAVG,TSURF,STC(1),TBK,ZSOIL,NSOIL,1) - ELSE - TAVG = STC(1) - ENDIF - TSNSR = SNKSRC (TAVG,SMC(1),SH2O(1), - & ZSOIL,NSOIL,SMCMAX,PSISAT,BEXP,DT,1,QTOT) - - RHSTS(1) = RHSTS(1) - TSNSR / ( ZSOIL(1) * HCPCT ) - ENDIF - -C ---------------------------------------------------------------------- -C THIS ENDS SECTION FOR TOP SOIL LAYER. -C ---------------------------------------------------------------------- -C INITIALIZE DDZ2 -C ---------------------------------------------------------------------- - DDZ2 = 0.0 - -C ---------------------------------------------------------------------- -C LOOP THRU THE REMAINING SOIL LAYERS, REPEATING THE ABOVE PROCESS -C (EXCEPT SUBSFC OR "GROUND" HEAT FLUX NOT REPEATED IN LOWER LAYERS) -C ---------------------------------------------------------------------- - DF1K = DF1 - DO K = 2,NSOIL - -C ---------------------------------------------------------------------- -C CALCULATE HEAT CAPACITY FOR THIS SOIL LAYER. -C ---------------------------------------------------------------------- - HCPCT = SH2O(K)*CH2O +(1.0-SMCMAX)*CSOIL +(SMCMAX-SMC(K))*CAIR - & + ( SMC(K) - SH2O(K) )*CICE - - IF (K .NE. NSOIL) THEN -C ---------------------------------------------------------------------- -C THIS SECTION FOR LAYER 2 OR GREATER, BUT NOT LAST LAYER. -C ---------------------------------------------------------------------- -C CALCULATE THERMAL DIFFUSIVITY FOR THIS LAYER. -C ---------------------------------------------------------------------- - CALL TDFCND (DF1N,SMC(K),QUARTZ,SMCMAX,SH2O(K)) - -C ---------------------------------------------------------------------- -C CALC THE VERTICAL SOIL TEMP GRADIENT THRU THIS LAYER -C ---------------------------------------------------------------------- - DENOM = 0.5 * ( ZSOIL(K-1) - ZSOIL(K+1) ) - DTSDZ2 = ( STC(K) - STC(K+1) ) / DENOM - -C ---------------------------------------------------------------------- -C CALC THE MATRIX COEF, CI, AFTER CALC'NG ITS PARTIAL PRODUCT -C ---------------------------------------------------------------------- - DDZ2 = 2. / (ZSOIL(K-1) - ZSOIL(K+1)) - CI(K) = -DF1N * DDZ2 / ((ZSOIL(K-1) - ZSOIL(K)) * HCPCT) - -C ---------------------------------------------------------------------- -C IF TEMPERATURE AVERAGING INVOKED (ITAVG=TRUE; ELSE SKIP): CALCULATE -C TEMP AT BOTTOM OF LAYER. -C ---------------------------------------------------------------------- - IF (ITAVG) THEN - CALL TBND (STC(K),STC(K+1),ZSOIL,ZBOT,K,NSOIL,TBK1) - ENDIF - ELSE - -C ---------------------------------------------------------------------- -C SPECIAL CASE OF BOTTOM SOIL LAYER: CALCULATE THERMAL DIFFUSIVITY FOR -C BOTTOM LAYER. -C ---------------------------------------------------------------------- - CALL TDFCND (DF1N,SMC(K),QUARTZ,SMCMAX,SH2O(K)) - -C ---------------------------------------------------------------------- -C CALC THE VERTICAL SOIL TEMP GRADIENT THRU BOTTOM LAYER. -C ---------------------------------------------------------------------- - DENOM = .5 * (ZSOIL(K-1) + ZSOIL(K)) - ZBOT - DTSDZ2 = (STC(K)-TBOT) / DENOM - -C ---------------------------------------------------------------------- -C SET MATRIX COEF, CI TO ZERO IF BOTTOM LAYER. -C ---------------------------------------------------------------------- - CI(K) = 0. - -C ---------------------------------------------------------------------- -C IF TEMPERATURE AVERAGING INVOKED (ITAVG=TRUE; ELSE SKIP): CALCULATE -C TEMP AT BOTTOM OF LAST LAYER. -C ---------------------------------------------------------------------- - IF (ITAVG) THEN - CALL TBND (STC(K),TBOT,ZSOIL,ZBOT,K,NSOIL,TBK1) - ENDIF - - ENDIF -C ---------------------------------------------------------------------- -C THIS ENDS SPECIAL LOOP FOR BOTTOM LAYER. -C ---------------------------------------------------------------------- -C CALCULATE RHSTS FOR THIS LAYER AFTER CALC'NG A PARTIAL PRODUCT. -C ---------------------------------------------------------------------- - DENOM = ( ZSOIL(K) - ZSOIL(K-1) ) * HCPCT - RHSTS(K) = ( DF1N * DTSDZ2 - DF1K * DTSDZ ) / DENOM - QTOT = -1.0*DENOM*RHSTS(K) - SICE = SMC(K) - SH2O(K) - - IF ( (SICE .GT. 0.) .OR. (TBK .LT. T0) .OR. - & (STC(K) .LT. T0) .OR. (TBK1 .LT. T0) ) THEN - - IF (ITAVG) THEN - CALL TMPAVG(TAVG,TBK,STC(K),TBK1,ZSOIL,NSOIL,K) - ELSE - TAVG = STC(K) - ENDIF - TSNSR = SNKSRC(TAVG,SMC(K),SH2O(K),ZSOIL,NSOIL, - & SMCMAX,PSISAT,BEXP,DT,K,QTOT) - RHSTS(K) = RHSTS(K) - TSNSR / DENOM - ENDIF - -C ---------------------------------------------------------------------- -C CALC MATRIX COEFS, AI, AND BI FOR THIS LAYER. -C ---------------------------------------------------------------------- - AI(K) = - DF1 * DDZ / ((ZSOIL(K-1) - ZSOIL(K)) * HCPCT) - BI(K) = -(AI(K) + CI(K)) - -C ---------------------------------------------------------------------- -C RESET VALUES OF DF1, DTSDZ, DDZ, AND TBK FOR LOOP TO NEXT SOIL LAYER. -C ---------------------------------------------------------------------- - TBK = TBK1 - DF1K = DF1N - DTSDZ = DTSDZ2 - DDZ = DDZ2 - END DO - -C ---------------------------------------------------------------------- -C END SUBROUTINE HRT -C ---------------------------------------------------------------------- - RETURN - END - SUBROUTINE HRTICE (RHSTS,STC,NSOIL,ZSOIL,YY,ZZ1,DF1,AI,BI,CI, - & ICE,TBOT) - - IMPLICIT NONE - -C ---------------------------------------------------------------------- -C SUBROUTINE HRTICE -C ---------------------------------------------------------------------- -C CALCULATE THE RIGHT HAND SIDE OF THE TIME TENDENCY TERM OF THE SOIL -C THERMAL DIFFUSION EQUATION FOR SEA-ICE (ICE = 1) OR GLACIAL-ICE (ICE). -C COMPUTE (PREPARE) THE MATRIX COEFFICIENTS FOR THE TRI-DIAGONAL MATRIX -C OF THE IMPLICIT TIME SCHEME. -C -C (NOTE: THIS SUBROUTINE ONLY CALLED FOR SEA-ICE OR GLACIAL ICE, BUT -C NOT FOR NON-GLACIAL LAND (ICE = 0). -C ---------------------------------------------------------------------- - INTEGER NSOLD - PARAMETER(NSOLD = 4) - - INTEGER ICE - INTEGER K - INTEGER NSOIL - - REAL AI(NSOLD) - REAL BI(NSOLD) - REAL CI(NSOLD) - - REAL DDZ - REAL DDZ2 - REAL DENOM - REAL DF1 - REAL DTSDZ - REAL DTSDZ2 - REAL HCPCT - REAL RHSTS(NSOIL) - REAL SSOIL - REAL STC(NSOIL) - REAL TBOT - REAL YY - REAL ZBOT - REAL ZSOIL(NSOIL) - REAL ZZ1 - -c DATA TBOT /271.16/ - -C ---------------------------------------------------------------------- -C SET A NOMINAL UNIVERSAL VALUE OF THE SEA-ICE SPECIFIC HEAT CAPACITY, -C HCPCT = 1880.0*917.0 = 1.72396E+6 (SOURCE: FEI CHEN, 1995) -C SET BOTTOM OF SEA-ICE PACK TEMPERATURE -C TBOT = 271.16 -C SET A NOMINAL UNIVERSAL VALUE OF GLACIAL-ICE SPECIFIC HEAT CAPACITY, -C HCPCT = 2100.0*900.0 = 1.89000E+6 (SOURCE: BOB GRUMBINE, 2005) -C TBOT PASSED IN AS ARGUMENT, VALUE FROM GLOBAL DATA SET -C ---------------------------------------------------------------------- -c PARAMETER(HCPCT = 1.72396E+6) - IF (ICE .EQ. 1) THEN -C ---------------------------------------------------------------------- -C SEA-ICE -C ---------------------------------------------------------------------- - HCPCT = 1.72396E+6 - TBOT = 271.16 - ELSE -C ---------------------------------------------------------------------- -C GLACIAL-ICE -C ---------------------------------------------------------------------- - HCPCT = 1.89000E+6 - ENDIF - -C ---------------------------------------------------------------------- -C THE INPUT ARGUMENT DF1 IS A UNIVERSALLY CONSTANT VALUE OF SEA-ICE -C AND GLACIAL-ICE THERMAL DIFFUSIVITY, SET IN SFLX AS DF1 = 2.2. -C ---------------------------------------------------------------------- -C SET ICE PACK DEPTH. USE TBOT AS ICE PACK LOWER BOUNDARY TEMPERATURE -C (THAT OF UNFROZEN SEA WATER AT BOTTOM OF SEA ICE PACK). ASSUME ICE -C PACK IS OF N=NSOIL LAYERS SPANNING A UNIFORM CONSTANT ICE PACK -C THICKNESS AS DEFINED BY ZSOIL(NSOIL) IN ROUTINE SFLX. -C IF GLACIAL-ICE, SET ZBOT = -25 METERS -C ---------------------------------------------------------------------- - IF (ICE .EQ. 1) THEN -C ---------------------------------------------------------------------- -C SEA-ICE -C ---------------------------------------------------------------------- - ZBOT = ZSOIL(NSOIL) - ELSE -C ---------------------------------------------------------------------- -C GLACIAL-ICE -C ---------------------------------------------------------------------- - ZBOT = -25.0 - ENDIF - -C ---------------------------------------------------------------------- -C CALC THE MATRIX COEFFICIENTS AI, BI, AND CI FOR THE TOP LAYER -C ---------------------------------------------------------------------- - DDZ = 1.0 / ( -0.5 * ZSOIL(2) ) - AI(1) = 0.0 - CI(1) = (DF1 * DDZ) / (ZSOIL(1) * HCPCT) - BI(1) = -CI(1) + DF1/(0.5 * ZSOIL(1) * ZSOIL(1) * HCPCT * ZZ1) - -C ---------------------------------------------------------------------- -C CALC THE VERTICAL SOIL TEMP GRADIENT BTWN THE TOP AND 2ND SOIL LAYERS. -C RECALC/ADJUST THE SOIL HEAT FLUX. USE THE GRADIENT AND FLUX TO CALC -C RHSTS FOR THE TOP SOIL LAYER. -C ---------------------------------------------------------------------- - DTSDZ = ( STC(1) - STC(2) ) / ( -0.5 * ZSOIL(2) ) - SSOIL = DF1 * ( STC(1) - YY ) / ( 0.5 * ZSOIL(1) * ZZ1 ) - RHSTS(1) = ( DF1 * DTSDZ - SSOIL ) / ( ZSOIL(1) * HCPCT ) - -C ---------------------------------------------------------------------- -C INITIALIZE DDZ2 -C ---------------------------------------------------------------------- - DDZ2 = 0.0 - -C ---------------------------------------------------------------------- -C LOOP THRU THE REMAINING SOIL LAYERS, REPEATING THE ABOVE PROCESS -C ---------------------------------------------------------------------- - DO K = 2,NSOIL - IF (K .NE. NSOIL) THEN - -C ---------------------------------------------------------------------- -C CALC THE VERTICAL SOIL TEMP GRADIENT THRU THIS LAYER. -C ---------------------------------------------------------------------- - DENOM = 0.5 * ( ZSOIL(K-1) - ZSOIL(K+1) ) - DTSDZ2 = ( STC(K) - STC(K+1) ) / DENOM - -C ---------------------------------------------------------------------- -C CALC THE MATRIX COEF, CI, AFTER CALC'NG ITS PARTIAL PRODUCT. -C ---------------------------------------------------------------------- - DDZ2 = 2. / (ZSOIL(K-1) - ZSOIL(K+1)) - CI(K) = -DF1 * DDZ2 / ((ZSOIL(K-1) - ZSOIL(K)) * HCPCT) - ELSE - -C ---------------------------------------------------------------------- -C CALC THE VERTICAL SOIL TEMP GRADIENT THRU THE LOWEST LAYER. -C ---------------------------------------------------------------------- - DTSDZ2 = (STC(K)-TBOT)/(.5 * (ZSOIL(K-1) + ZSOIL(K))-ZBOT) - -C ---------------------------------------------------------------------- -C SET MATRIX COEF, CI TO ZERO. -C ---------------------------------------------------------------------- - CI(K) = 0. - ENDIF - -C ---------------------------------------------------------------------- -C CALC RHSTS FOR THIS LAYER AFTER CALC'NG A PARTIAL PRODUCT. -C ---------------------------------------------------------------------- - DENOM = ( ZSOIL(K) - ZSOIL(K-1) ) * HCPCT - RHSTS(K) = ( DF1 * DTSDZ2 - DF1 * DTSDZ ) / DENOM - -C ---------------------------------------------------------------------- -C CALC MATRIX COEFS, AI, AND BI FOR THIS LAYER. -C ---------------------------------------------------------------------- - AI(K) = - DF1 * DDZ / ((ZSOIL(K-1) - ZSOIL(K)) * HCPCT) - BI(K) = -(AI(K) + CI(K)) - -C ---------------------------------------------------------------------- -C RESET VALUES OF DTSDZ AND DDZ FOR LOOP TO NEXT SOIL LYR. -C ---------------------------------------------------------------------- - DTSDZ = DTSDZ2 - DDZ = DDZ2 - - END DO -C ---------------------------------------------------------------------- -C END SUBROUTINE HRTICE -C ---------------------------------------------------------------------- - RETURN - END - SUBROUTINE HSTEP (STCOUT,STCIN,RHSTS,DT,NSOIL,AI,BI,CI) - - IMPLICIT NONE - -C ---------------------------------------------------------------------- -C SUBROUTINE HSTEP -C ---------------------------------------------------------------------- -C CALCULATE/UPDATE THE SOIL TEMPERATURE FIELD. -C ---------------------------------------------------------------------- - INTEGER NSOLD - PARAMETER(NSOLD = 4) - - INTEGER K - INTEGER NSOIL - - REAL AI(NSOLD) - REAL BI(NSOLD) - REAL CI(NSOLD) - REAL CIin(NSOLD) - REAL DT - REAL RHSTS(NSOIL) - REAL RHSTSin(NSOIL) - REAL STCIN(NSOIL) - REAL STCOUT(NSOIL) - -C ---------------------------------------------------------------------- -C CREATE FINITE DIFFERENCE VALUES FOR USE IN ROSR12 ROUTINE -C ---------------------------------------------------------------------- - DO K = 1,NSOIL - RHSTS(K) = RHSTS(K) * DT - AI(K) = AI(K) * DT - BI(K) = 1. + BI(K) * DT - CI(K) = CI(K) * DT - END DO - -C ---------------------------------------------------------------------- -C COPY VALUES FOR INPUT VARIABLES BEFORE CALL TO ROSR12 -C ---------------------------------------------------------------------- - DO K = 1,NSOIL - RHSTSin(K) = RHSTS(K) - END DO - DO K = 1,NSOLD - CIin(K) = CI(K) - END DO - -C ---------------------------------------------------------------------- -C SOLVE THE TRI-DIAGONAL MATRIX EQUATION -C ---------------------------------------------------------------------- - CALL ROSR12(CI,AI,BI,CIin,RHSTSin,RHSTS,NSOIL) - -C ---------------------------------------------------------------------- -C CALC/UPDATE THE SOIL TEMPS USING MATRIX SOLUTION -C ---------------------------------------------------------------------- - DO K = 1,NSOIL - STCOUT(K) = STCIN(K) + CI(K) - END DO - -C ---------------------------------------------------------------------- -C END SUBROUTINE HSTEP -C ---------------------------------------------------------------------- - RETURN - END - SUBROUTINE NOPAC(ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, - & SMCREF,SMCDRY,CMC,CMCMAX,NSOIL,DT,SHDFAC, - & SBETA,Q2,T1,SFCTMP,T24,TH2,FDOWN,F1,SSOIL, - & STC,EPSCA,BEXP,PC,RCH,RR,CFACTR, - & SH2O,SLOPE,KDT,FRZFACT,PSISAT,ZSOIL, - & DKSAT,DWSAT,TBOT,ZBOT,RUNOFF1,RUNOFF2, - & RUNOFF3,EDIR,EC,ET,ETT,NROOT,ICE,RTDIS, - & QUARTZ,FXEXP,CSOIL, - & BETA,DRIP,DEW,FLX1,FLX2,FLX3) - - IMPLICIT NONE - -C ---------------------------------------------------------------------- -C SUBROUTINE NOPAC -C ---------------------------------------------------------------------- -C CALCULATE SOIL MOISTURE AND HEAT FLUX VALUES AND UPDATE SOIL MOISTURE -C CONTENT AND SOIL HEAT CONTENT VALUES FOR THE CASE WHEN NO SNOW PACK IS -C PRESENT. -C ---------------------------------------------------------------------- - INTEGER ICE - INTEGER NROOT - INTEGER NSOIL - - REAL BEXP - REAL BETA - REAL CFACTR - REAL CMC - REAL CMCMAX - REAL CP - REAL CSOIL - REAL DEW - REAL DF1 - REAL DKSAT - REAL DRIP - REAL DT - REAL DWSAT - REAL EC - REAL EDIR - REAL EPSCA - REAL ETA - REAL ETA1 - REAL ETP - REAL ETP1 - REAL ET(NSOIL) - REAL ETT - REAL FDOWN - REAL F1 - REAL FXEXP - REAL FLX1 - REAL FLX2 - REAL FLX3 - REAL FRZFACT - REAL KDT - REAL PC - REAL PRCP - REAL PRCP1 - REAL PSISAT - REAL Q2 - REAL QUARTZ - REAL RCH - REAL RR - REAL RTDIS(NSOIL) - REAL RUNOFF1 - REAL RUNOFF2 - REAL RUNOFF3 - REAL SSOIL - REAL SBETA - REAL SFCTMP - REAL SHDFAC - REAL SH2O(NSOIL) - REAL SIGMA - REAL SLOPE - REAL SMC(NSOIL) - REAL SMCDRY - REAL SMCMAX - REAL SMCREF - REAL SMCWLT - REAL STC(NSOIL) - REAL T1 - REAL T24 - REAL TBOT - REAL TH2 - REAL YY - REAL YYNUM - REAL ZBOT - REAL ZSOIL(NSOIL) - REAL ZZ1 - - REAL EC1 - REAL EDIR1 - REAL ET1(NSOIL) - REAL ETT1 - - INTEGER K - - PARAMETER(CP = 1004.5) - PARAMETER(SIGMA = 5.67E-8) - -C ---------------------------------------------------------------------- -C EXECUTABLE CODE BEGINS HERE: -C CONVERT ETP FROM KG M-2 S-1 TO MS-1 AND INITIALIZE DEW. -C ---------------------------------------------------------------------- - PRCP1 = PRCP * 0.001 - ETP1 = ETP * 0.001 - DEW = 0.0 - - EDIR = 0. - EDIR1 = 0. - EC = 0. - EC1 = 0. - DO K = 1,NSOIL - ET(K) = 0. - ET1(K) = 0. - END DO - ETT = 0. - ETT1 = 0. - - IF (ETP .GT. 0.0) THEN - -C ---------------------------------------------------------------------- -C CONVERT PRCP FROM 'KG M-2 S-1' TO 'M S-1'. -C ---------------------------------------------------------------------- - CALL EVAPO (ETA1,SMC,NSOIL,CMC,ETP1,DT,ZSOIL, - & SH2O,SMCMAX,BEXP,PC,SMCWLT,DKSAT,DWSAT, - & SMCREF,SHDFAC,CMCMAX, - & SMCDRY,CFACTR, - & EDIR1,EC1,ET1,ETT1,SFCTMP,Q2,NROOT,RTDIS,FXEXP) - CALL SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, - & SH2O,SLOPE,KDT,FRZFACT, - & SMCMAX,BEXP,SMCWLT,DKSAT,DWSAT, - & SHDFAC,CMCMAX, - & RUNOFF1,RUNOFF2,RUNOFF3, - & EDIR1,EC1,ET1, - & DRIP) - -C ---------------------------------------------------------------------- -C CONVERT MODELED EVAPOTRANSPIRATION FM M S-1 TO KG M-2 S-1 -C ---------------------------------------------------------------------- -c ETA = ETA1 * 1000.0 - -C ---------------------------------------------------------------------- -c EDIR = EDIR1 * 1000.0 -c EC = EC1 * 1000.0 -c ETT = ETT1 * 1000.0 -c ET(1) = ET1(1) * 1000.0 -c ET(2) = ET1(2) * 1000.0 -c ET(3) = ET1(3) * 1000.0 -c ET(4) = ET1(4) * 1000.0 -C ---------------------------------------------------------------------- - - ELSE - -C ---------------------------------------------------------------------- -C IF ETP < 0, ASSUME DEW FORMS (TRANSFORM ETP1 INTO DEW AND REINITIALIZE -C ETP1 TO ZERO). -C ---------------------------------------------------------------------- - DEW = -ETP1 -c ETP1 = 0.0 - ETA1 = 0.0 ! jbao new gfs physics - -C ---------------------------------------------------------------------- -C CONVERT PRCP FROM 'KG M-2 S-1' TO 'M S-1' AND ADD DEW AMOUNT. -C ---------------------------------------------------------------------- - PRCP1 = PRCP1 + DEW -C -c CALL EVAPO (ETA1,SMC,NSOIL,CMC,ETP1,DT,ZSOIL, -c & SH2O,SMCMAX,BEXP,PC,SMCWLT,DKSAT,DWSAT, -c & SMCREF,SHDFAC,CMCMAX, -c & SMCDRY,CFACTR, -c & EDIR1,EC1,ET1,ETT,SFCTMP,Q2,NROOT,RTDIS,FXEXP) - CALL SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, - & SH2O,SLOPE,KDT,FRZFACT, - & SMCMAX,BEXP,SMCWLT,DKSAT,DWSAT, - & SHDFAC,CMCMAX, - & RUNOFF1,RUNOFF2,RUNOFF3, - & EDIR1,EC1,ET1, - & DRIP) - -C ---------------------------------------------------------------------- -C CONVERT MODELED EVAPOTRANSPIRATION FROM 'M S-1' TO 'KG M-2 S-1'. -C ---------------------------------------------------------------------- -c ETA = ETA1 * 1000.0 - -C ---------------------------------------------------------------------- -c EDIR = EDIR1 * 1000.0 -c EC = EC1 * 1000.0 -c ETT = ETT1 * 1000.0 -c ET(1) = ET1(1) * 1000.0 -c ET(2) = ET1(2) * 1000.0 -c ET(3) = ET1(3) * 1000.0 -c ET(4) = ET1(4) * 1000.0 -C ---------------------------------------------------------------------- - - ENDIF - -C ---------------------------------------------------------------------- -C CONVERT MODELED EVAPOTRANSPIRATION FM M S-1 TO KG M-2 S-1 -C ---------------------------------------------------------------------- - ETA = ETA1 * 1000.0 - -C ---------------------------------------------------------------------- - EDIR = EDIR1 * 1000.0 - EC = EC1 * 1000.0 - DO K = 1,NSOIL - ET(K) = ET1(K) * 1000.0 -c ET(1) = ET1(1) * 1000.0 -c ET(2) = ET1(2) * 1000.0 -c ET(3) = ET1(3) * 1000.0 -c ET(4) = ET1(4) * 1000.0 - ENDDO - ETT = ETT1 * 1000.0 -C ---------------------------------------------------------------------- - -C ---------------------------------------------------------------------- -C BASED ON ETP AND E VALUES, DETERMINE BETA -C ---------------------------------------------------------------------- - IF ( ETP .LE. 0.0 ) THEN - BETA = 0.0 - IF ( ETP .LT. 0.0 ) THEN - BETA = 1.0 -c ETA = ETP - ENDIF - ELSE - BETA = ETA / ETP - ENDIF - -C ---------------------------------------------------------------------- -C GET SOIL THERMAL DIFFUXIVITY/CONDUCTIVITY FOR TOP SOIL LYR, -C CALC. ADJUSTED TOP LYR SOIL TEMP AND ADJUSTED SOIL FLUX, THEN -C CALL SHFLX TO COMPUTE/UPDATE SOIL HEAT FLUX AND SOIL TEMPS. -C ---------------------------------------------------------------------- - CALL TDFCND (DF1,SMC(1),QUARTZ,SMCMAX,SH2O(1)) - -C ---------------------------------------------------------------------- -C VEGETATION GREENNESS FRACTION REDUCTION IN SUBSURFACE HEAT FLUX -C VIA REDUCTION FACTOR, WHICH IS CONVENIENT TO APPLY HERE TO THERMAL -C DIFFUSIVITY THAT IS LATER USED IN HRT TO COMPUTE SUB SFC HEAT FLUX -C (SEE ADDITIONAL COMMENTS ON VEG EFFECT SUB-SFC HEAT FLX IN -C ROUTINE SFLX) -C ---------------------------------------------------------------------- - DF1 = DF1 * EXP(SBETA*SHDFAC) - -C ---------------------------------------------------------------------- -C COMPUTE INTERMEDIATE TERMS PASSED TO ROUTINE HRT (VIA ROUTINE -C SHFLX BELOW) FOR USE IN COMPUTING SUBSURFACE HEAT FLUX IN HRT -C ---------------------------------------------------------------------- - YYNUM = FDOWN - SIGMA * T24 - YY = SFCTMP + (YYNUM/RCH+TH2-SFCTMP-BETA*EPSCA) / RR - ZZ1 = DF1 / ( -0.5 * ZSOIL(1) * RCH * RR ) + 1.0 - - CALL SHFLX (SSOIL,STC,SMC,SMCMAX,NSOIL,T1,DT,YY,ZZ1,ZSOIL, - & TBOT,ZBOT,SMCWLT,PSISAT,SH2O,BEXP,F1,DF1,ICE, - & QUARTZ,CSOIL) - -C ---------------------------------------------------------------------- -C SET FLX1 AND FLX3 (SNOPACK PHASE CHANGE HEAT FLUXES) TO ZERO SINCE -C THEY ARE NOT USED HERE IN SNOPAC. FLX2 (FREEZING RAIN HEAT FLUX) WAS -C SIMILARLY INITIALIZED IN THE PENMAN ROUTINE. -C ---------------------------------------------------------------------- - FLX1 = 0.0 - FLX3 = 0.0 - -C ---------------------------------------------------------------------- -C END SUBROUTINE NOPAC -C ---------------------------------------------------------------------- - RETURN - END - SUBROUTINE PENMAN (SFCTMP,SFCPRS,CH,T2V,TH2,PRCP,FDOWN,T24,SSOIL, - & Q2,Q2SAT,ETP,RCH,EPSCA,RR,SNOWNG,FRZGRA, - & DQSDT2,FLX2) - - IMPLICIT NONE - -C ---------------------------------------------------------------------- -C SUBROUTINE PENMAN -C ---------------------------------------------------------------------- -C CALCULATE POTENTIAL EVAPORATION FOR THE CURRENT POINT. VARIOUS -C PARTIAL SUMS/PRODUCTS ARE ALSO CALCULATED AND PASSED BACK TO THE -C CALLING ROUTINE FOR LATER USE. -C ---------------------------------------------------------------------- - LOGICAL SNOWNG - LOGICAL FRZGRA - - REAL A - REAL BETA - REAL CH - REAL CP - REAL CPH2O - REAL CPICE - REAL DELTA - REAL DQSDT2 - REAL ELCP - REAL EPSCA - REAL ETP - REAL FDOWN - REAL FLX2 - REAL FNET - REAL LSUBC - REAL LSUBF - REAL PRCP - REAL Q2 - REAL Q2SAT - REAL R - REAL RAD - REAL RCH - REAL RHO - REAL RR - REAL SSOIL - REAL SFCPRS - REAL SFCTMP - REAL SIGMA - REAL T24 - REAL T2V - REAL TH2 - - PARAMETER(CP = 1004.6) - PARAMETER(CPH2O = 4.218E+3) - PARAMETER(CPICE = 2.106E+3) - PARAMETER(R = 287.04) - PARAMETER(ELCP = 2.4888E+3) - PARAMETER(LSUBF = 3.335E+5) - PARAMETER(LSUBC = 2.501000E+6) - PARAMETER(SIGMA = 5.67E-8) - -C ---------------------------------------------------------------------- -C EXECUTABLE CODE BEGINS HERE: -C ---------------------------------------------------------------------- - FLX2 = 0.0 - -C ---------------------------------------------------------------------- -C PREPARE PARTIAL QUANTITIES FOR PENMAN EQUATION. -C ---------------------------------------------------------------------- - DELTA = ELCP * DQSDT2 - T24 = SFCTMP * SFCTMP * SFCTMP * SFCTMP - RR = T24 * 6.48E-8 /(SFCPRS * CH) + 1.0 - RHO = SFCPRS / (R * T2V) - RCH = RHO * CP * CH - -C ---------------------------------------------------------------------- -C ADJUST THE PARTIAL SUMS / PRODUCTS WITH THE LATENT HEAT -C EFFECTS CAUSED BY FALLING PRECIPITATION. -C ---------------------------------------------------------------------- - IF (.NOT. SNOWNG) THEN - IF (PRCP .GT. 0.0) RR = RR + CPH2O*PRCP/RCH - ELSE - RR = RR + CPICE*PRCP/RCH - ENDIF - - FNET = FDOWN - SIGMA*T24 - SSOIL - -C ---------------------------------------------------------------------- -C INCLUDE THE LATENT HEAT EFFECTS OF FRZNG RAIN CONVERTING TO ICE ON -C IMPACT IN THE CALCULATION OF FLX2 AND FNET. -C ---------------------------------------------------------------------- - IF (FRZGRA) THEN - FLX2 = -LSUBF * PRCP - FNET = FNET - FLX2 - ENDIF - -C ---------------------------------------------------------------------- -C FINISH PENMAN EQUATION CALCULATIONS. -C ---------------------------------------------------------------------- - RAD = FNET/RCH + TH2 - SFCTMP - A = ELCP * (Q2SAT - Q2) - EPSCA = (A*RR + RAD*DELTA) / (DELTA + RR) - ETP = EPSCA * RCH / LSUBC - -C ---------------------------------------------------------------------- -C END SUBROUTINE PENMAN -C ---------------------------------------------------------------------- - RETURN - END - SUBROUTINE REDPRM ( - & VEGTYP,SOILTYP,SLOPETYP, - & CFACTR,CMCMAX,RSMAX,TOPT,REFKDT,KDT,SBETA, - & SHDFAC,RSMIN,RGL,HS,ZBOT,FRZX,PSISAT,SLOPE, - & SNUP,SALP,BEXP,DKSAT,DWSAT, - & SMCMAX,SMCWLT,SMCREF, - & SMCDRY,F1,QUARTZ,FXEXP,RTDIS,SLDPTH,ZSOIL, - & NROOT,NSOIL,Z0,CZIL,LAI,CSOIL,PTU) - -C ---------------------------------------------------------------------- -C SUBROUTINE REDPRM -C ---------------------------------------------------------------------- -C ALL SOIL, VEG, SLOPE, AND UNIVERSAL PARAMETERS VALUES ARE DEFINED -C EXTERNALLY (IN SUBROUTINE "set_soilveg.f") AND THEN ACCESSED VIA "use -C namelist_soilveg" (BELOW) AND THEN SET HERE. -C ---------------------------------------------------------------------- - use namelist_soilveg - IMPLICIT NONE - -C ---------------------------------------------------------------------- -C SUBROUTINE REDPRM -C ---------------------------------------------------------------------- -C INTERNALLY SET (DEFAULT VALUESS), OR OPTIONALLY READ-IN VIA NAMELIST -C I/O, ALL SOIL AND VEGETATION PARAMETERS REQUIRED FOR THE EXECUSION OF -C THE NOAH LSM. -C -C OPTIONAL NON-DEFAULT PARAMETERS CAN BE READ IN, ACCOMMODATING UP TO 30 -C SOIL, VEG, OR SLOPE CLASSES, IF THE DEFAULT MAX NUMBER OF SOIL, VEG, -C AND/OR SLOPE TYPES IS RESET. -C -C FUTURE UPGRADES OF ROUTINE REDPRM MUST EXPAND TO INCORPORATE SOME OF -C THE EMPIRICAL PARAMETERS OF THE FROZEN SOIL AND SNOWPACK PHYSICS (SUCH -C AS IN ROUTINES FRH2O, SNOWPACK, AND SNOW_NEW) NOT YET SET IN THIS -C REDPRM ROUTINE, BUT RATHER SET IN LOWER LEVEL SUBROUTINES. -C -C SET MAXIMUM NUMBER OF SOIL-, VEG-, AND SLOPETYP IN DATA STATEMENT. -C ---------------------------------------------------------------------- - - - -C ---------------------------------------------------------------------- -C SET-UP SOIL PARAMETERS FOR GIVEN SOIL TYPE -C INPUT: SOLTYP: SOIL TYPE (INTEGER INDEX) -C OUTPUT: SOIL PARAMETERS: -C MAXSMC: MAX SOIL MOISTURE CONTENT (POROSITY) -C REFSMC: REFERENCE SOIL MOISTURE (ONSET OF SOIL MOISTURE -C STRESS IN TRANSPIRATION) -C WLTSMC: WILTING PT SOIL MOISTURE CONTENTS -C DRYSMC: AIR DRY SOIL MOIST CONTENT LIMITS -C SATPSI: SATURATED SOIL POTENTIAL -C SATDK: SATURATED SOIL HYDRAULIC CONDUCTIVITY -C BB: THE 'B' PARAMETER -C SATDW: SATURATED SOIL DIFFUSIVITY -C F11: USED TO COMPUTE SOIL DIFFUSIVITY/CONDUCTIVITY -C QUARTZ: SOIL QUARTZ CONTENT -C ---------------------------------------------------------------------- -C SOIL TYPES ZOBLER (1986) COSBY ET AL (1984) (quartz cont.(1)) -C 1 COARSE LOAMY SAND (0.82) -C 2 MEDIUM SILTY CLAY LOAM (0.10) -C 3 FINE LIGHT CLAY (0.25) -C 4 COARSE-MEDIUM SANDY LOAM (0.60) -C 5 COARSE-FINE SANDY CLAY (0.52) -C 6 MEDIUM-FINE CLAY LOAM (0.35) -C 7 COARSE-MED-FINE SANDY CLAY LOAM (0.60) -C 8 ORGANIC LOAM (0.40) -C 9 GLACIAL LAND ICE LOAMY SAND (NA using 0.82) -C 13: >>>OLD>>>GLACIAL LAND ICE<<>>OLD>>>GLACIAL (THE SAME PARAMETERS AS FOR TYPE 11)<< 30 -C 4 0-30 -C 5 0-8 & > 30 -C 6 8-30 & > 30 -C 7 0-8, 8-30, > 30 -C 9 GLACIAL ICE -C BLANK OCEAN/SEA -C ---------------------------------------------------------------------- -C NOTE: -C CLASS 9 FROM 'ZOBLER' FILE SHOULD BE REPLACED BY 8 AND 'BLANK' 9 -C ---------------------------------------------------------------------- - REAL SLOPE - - -C ---------------------------------------------------------------------- -C SET NAMELIST FILE NAME -C ---------------------------------------------------------------------- - CHARACTER*50 NAMELIST_NAME - -C ** Clu: Retain definition status to quarantee 'one-time' execution - SAVE LFIRST - -C ---------------------------------------------------------------------- -C SET UNIVERSAL PARAMETERS (NOT DEPENDENT ON SOIL, VEG, SLOPE TYPE) -C ---------------------------------------------------------------------- - INTEGER I - INTEGER NSOIL - INTEGER SLOPETYP - INTEGER SOILTYP - INTEGER VEGTYP - - - - - - - - LOGICAL LFIRST - DATA LFIRST /.TRUE./ - -C ---------------------------------------------------------------------- -C PARAMETER USED TO CALCULATE ROUGHNESS LENGTH OF HEAT. -C ---------------------------------------------------------------------- - REAL CZIL - - -C ---------------------------------------------------------------------- -C PARAMETER USED TO CALUCULATE VEGETATION EFFECT ON SOIL HEAT FLUX. -C ---------------------------------------------------------------------- - REAL SBETA - - - -C ---------------------------------------------------------------------- -C BARE SOIL EVAPORATION EXPONENT USED IN DEVAP. -C ---------------------------------------------------------------------- - REAL FXEXP - - - -C ---------------------------------------------------------------------- -C SOIL HEAT CAPACITY [J M-3 K-1] -C ---------------------------------------------------------------------- - REAL CSOIL - - -C ---------------------------------------------------------------------- -C SPECIFY SNOW DISTRIBUTION SHAPE PARAMETER SALP - SHAPE PARAMETER OF -C DISTRIBUTION FUNCTION OF SNOW COVER. FROM ANDERSON'S DATA (HYDRO-17) -C BEST FIT IS WHEN SALP = 2.6 -C ---------------------------------------------------------------------- - REAL SALP - - -C ---------------------------------------------------------------------- -C KDT IS DEFINED BY REFERENCE REFKDT AND DKSAT; REFDK=2.E-6 IS THE SAT. -C DK. VALUE FOR THE SOIL TYPE 2 -C ---------------------------------------------------------------------- - REAL REFDK - - - - REAL REFKDT - - - - REAL FRZX - REAL KDT - -C ---------------------------------------------------------------------- -C FROZEN GROUND PARAMETER, FRZK, DEFINITION: ICE CONTENT THRESHOLD ABOVE -C WHICH FROZEN SOIL IS IMPERMEABLE REFERENCE VALUE OF THIS PARAMETER FOR -C THE LIGHT CLAY SOIL (TYPE=3) FRZK = 0.15 M. -C ---------------------------------------------------------------------- - REAL FRZK - - - - REAL RTDIS(NSOIL) - REAL SLDPTH(NSOIL) - REAL ZSOIL(NSOIL) - -C ---------------------------------------------------------------------- -C SET TWO CANOPY WATER PARAMETERS. -C ---------------------------------------------------------------------- - REAL CFACTR - - - - REAL CMCMAX - - - -C ---------------------------------------------------------------------- -C SET MAX. STOMATAL RESISTANCE. -C ---------------------------------------------------------------------- - REAL RSMAX - - - -C ---------------------------------------------------------------------- -C SET OPTIMUM TRANSPIRATION AIR TEMPERATURE. -C ---------------------------------------------------------------------- - REAL TOPT - - - -C ---------------------------------------------------------------------- -C SPECIFY DEPTH[M] OF LOWER BOUNDARY SOIL TEMPERATURE. -C ---------------------------------------------------------------------- - REAL ZBOT - - - -C ---------------------------------------------------------------------- -C NAMELIST DEFINITION: -C ---------------------------------------------------------------------- -c$$$ NAMELIST /SOIL_VEG/ SLOPE_DATA, RSMTBL, RGLTBL, HSTBL, SNUPX, -c$$$ & BB, DRYSMC, F11, MAXSMC, REFSMC, SATPSI, SATDK, SATDW, -c$$$ & WLTSMC, QTZ, LPARAM, ZBOT_DATA, SALP_DATA, CFACTR_DATA, -c$$$ & CMCMAX_DATA, SBETA_DATA, RSMAX_DATA, TOPT_DATA, -c$$$ & REFDK_DATA, FRZK_DATA, BARE, DEFINED_VEG, DEFINED_SOIL, -c$$$ & DEFINED_SLOPE, FXEXP_DATA, NROOT_DATA, REFKDT_DATA, Z0_DATA, -c$$$ & CZIL_DATA, LAI_DATA, CSOIL_DATA - -c -cmy moved lfirst block to gfs_init -c - IF (SOILTYP .GT. DEFINED_SOIL) THEN - WRITE(*,*) 'Warning: too many soil types' - STOP 333 - ENDIF - IF (VEGTYP .GT. DEFINED_VEG) THEN - WRITE(*,*) 'Warning: too many veg types' - STOP 333 - ENDIF - IF (SLOPETYP .GT. DEFINED_SLOPE) THEN - WRITE(*,*) 'Warning: too many slope types' - STOP 333 - ENDIF - -C ---------------------------------------------------------------------- -C SET-UP UNIVERSAL PARAMETERS (NOT DEPENDENT ON SOILTYP, VEGTYP OR -C SLOPETYP) -C ---------------------------------------------------------------------- - ZBOT = ZBOT_DATA - SALP = SALP_DATA - CFACTR = CFACTR_DATA - CMCMAX = CMCMAX_DATA - SBETA = SBETA_DATA - RSMAX = RSMAX_DATA - TOPT = TOPT_DATA - REFDK = REFDK_DATA - FRZK = FRZK_DATA - FXEXP = FXEXP_DATA - REFKDT = REFKDT_DATA - CZIL = CZIL_DATA - CSOIL = CSOIL_DATA - -C ---------------------------------------------------------------------- -C SET-UP SOIL PARAMETERS -C ---------------------------------------------------------------------- - BEXP = BB(SOILTYP) - DKSAT = SATDK(SOILTYP) - DWSAT = SATDW(SOILTYP) - F1 = F11(SOILTYP) - KDT = REFKDT * DKSAT/REFDK - PSISAT = SATPSI(SOILTYP) - QUARTZ = QTZ(SOILTYP) - SMCDRY = DRYSMC(SOILTYP) - SMCMAX = MAXSMC(SOILTYP) - SMCREF = REFSMC(SOILTYP) - SMCWLT = WLTSMC(SOILTYP) - FRZFACT = (SMCMAX / SMCREF) * (0.412 / 0.468) - -C ---------------------------------------------------------------------- -C TO ADJUST FRZK PARAMETER TO ACTUAL SOIL TYPE: FRZK * FRZFACT -C ---------------------------------------------------------------------- - FRZX = FRZK * FRZFACT - -C ---------------------------------------------------------------------- -C SET-UP VEGETATION PARAMETERS -C ---------------------------------------------------------------------- - NROOT = NROOT_DATA(VEGTYP) - SNUP = SNUPX(VEGTYP) - RSMIN = RSMTBL(VEGTYP) - RGL = RGLTBL(VEGTYP) - HS = HSTBL(VEGTYP) - Z0 = Z0_DATA(VEGTYP) - LAI = LAI_DATA(VEGTYP) - IF (VEGTYP .EQ. BARE) SHDFAC = 0.0 - - IF (NROOT .GT. NSOIL) THEN - WRITE(*,*) 'Warning: too many root layers' - STOP 333 - ENDIF - -C ---------------------------------------------------------------------- -C CALCULATE ROOT DISTRIBUTION. PRESENT VERSION ASSUMES UNIFORM -C DISTRIBUTION BASED ON SOIL LAYER DEPTHS. -C ---------------------------------------------------------------------- - DO I = 1,NROOT - RTDIS(I) = -SLDPTH(I)/ZSOIL(NROOT) - END DO - -C ---------------------------------------------------------------------- -C SET-UP SLOPE PARAMETER -C ---------------------------------------------------------------------- - SLOPE = SLOPE_DATA(SLOPETYP) - -C ---------------------------------------------------------------------- -C END SUBROUTINE REDPRM -C ---------------------------------------------------------------------- - RETURN - END - SUBROUTINE ROSR12 (P,A,B,C,D,DELTA,NSOIL) - - IMPLICIT NONE - -C ---------------------------------------------------------------------- -C SUBROUTINE ROSR12 -C ---------------------------------------------------------------------- -C INVERT (SOLVE) THE TRI-DIAGONAL MATRIX PROBLEM SHOWN BELOW: -C ### ### ### ### ### ### -C #B(1), C(1), 0 , 0 , 0 , . . . , 0 # # # # # -C #A(2), B(2), C(2), 0 , 0 , . . . , 0 # # # # # -C # 0 , A(3), B(3), C(3), 0 , . . . , 0 # # # # D(3) # -C # 0 , 0 , A(4), B(4), C(4), . . . , 0 # # P(4) # # D(4) # -C # 0 , 0 , 0 , A(5), B(5), . . . , 0 # # P(5) # # D(5) # -C # . . # # . # = # . # -C # . . # # . # # . # -C # . . # # . # # . # -C # 0 , . . . , 0 , A(M-2), B(M-2), C(M-2), 0 # #P(M-2)# #D(M-2)# -C # 0 , . . . , 0 , 0 , A(M-1), B(M-1), C(M-1)# #P(M-1)# #D(M-1)# -C # 0 , . . . , 0 , 0 , 0 , A(M) , B(M) # # P(M) # # D(M) # -C ### ### ### ### ### ### -C ---------------------------------------------------------------------- - INTEGER K - INTEGER KK - INTEGER NSOIL - - REAL A(NSOIL) - REAL B(NSOIL) - REAL C(NSOIL) - REAL D(NSOIL) - REAL DELTA(NSOIL) - REAL P(NSOIL) - -C ---------------------------------------------------------------------- -C INITIALIZE EQN COEF C FOR THE LOWEST SOIL LAYER -C ---------------------------------------------------------------------- - C(NSOIL) = 0.0 - -C ---------------------------------------------------------------------- -C SOLVE THE COEFS FOR THE 1ST SOIL LAYER -C ---------------------------------------------------------------------- - P(1) = -C(1) / B(1) - DELTA(1) = D(1) / B(1) - -C ---------------------------------------------------------------------- -C SOLVE THE COEFS FOR SOIL LAYERS 2 THRU NSOIL -C ---------------------------------------------------------------------- - DO K = 2,NSOIL - P(K) = -C(K) * ( 1.0 / (B(K) + A (K) * P(K-1)) ) - DELTA(K) = (D(K)-A(K)*DELTA(K-1))*(1.0/(B(K)+A(K)*P(K-1))) - END DO - -C ---------------------------------------------------------------------- -C SET P TO DELTA FOR LOWEST SOIL LAYER -C ---------------------------------------------------------------------- - P(NSOIL) = DELTA(NSOIL) - -C ---------------------------------------------------------------------- -C ADJUST P FOR SOIL LAYERS 2 THRU NSOIL -C ---------------------------------------------------------------------- - DO K = 2,NSOIL - KK = NSOIL - K + 1 - P(KK) = P(KK) * P(KK+1) + DELTA(KK) - END DO - -C ---------------------------------------------------------------------- -C END SUBROUTINE ROSR12 -C ---------------------------------------------------------------------- - RETURN - END - SUBROUTINE SFCDIF (ZLM,Z0,THZ0,THLM,SFCSPD,CZIL,AKMS,AKHS) - - IMPLICIT NONE - -C ---------------------------------------------------------------------- -C SUBROUTINE SFCDIF -C ---------------------------------------------------------------------- -C CALCULATE SURFACE LAYER EXCHANGE COEFFICIENTS VIA ITERATIVE PROCESS. -C SEE CHEN ET AL (1997, BLM) -C ---------------------------------------------------------------------- - - REAL WWST, WWST2, G, VKRM, EXCM, BETA, BTG, ELFC, WOLD, WNEW - REAL PIHF, EPSU2, EPSUST, EPSIT, EPSA, ZTMIN, ZTMAX, HPBL, SQVISC - REAL RIC, RRIC, FHNEU, RFC, RFAC, ZZ, PSLMU, PSLMS, PSLHU, PSLHS - REAL XX, PSPMU, YY, PSPMS, PSPHU, PSPHS, ZLM, Z0, THZ0, THLM - REAL SFCSPD, CZIL, AKMS, AKHS, ZILFC, ZU, ZT, RDZ, CXCH - REAL DTHV, DU2, BTGH, WSTAR2, USTAR, ZSLU, ZSLT, RLOGU, RLOGT - REAL RLMO, ZETALT, ZETALU, ZETAU, ZETAT, XLU4, XLT4, XU4, XT4 - REAL XLU, XLT, XU, XT, PSMZ, SIMM, PSHZ, SIMH, USTARK, RLMN, RLMA -CCC ......REAL ZTFC - - INTEGER ITRMX, ILECH, ITR - - PARAMETER - & (WWST=1.2,WWST2=WWST*WWST,G=9.8,VKRM=0.40,EXCM=0.001 - & ,BETA=1./270.,BTG=BETA*G,ELFC=VKRM*BTG - & ,WOLD=.15,WNEW=1.-WOLD,ITRMX=05,PIHF=3.14159265/2.) -C ---------------------------------------------------------------------- - PARAMETER - & (EPSU2=1.E-4,EPSUST=0.07,EPSIT=1.E-4,EPSA=1.E-8 - & ,ZTMIN=-5.,ZTMAX=1.,HPBL=1000.0 - & ,SQVISC=258.2) -C ---------------------------------------------------------------------- - PARAMETER - & (RIC=0.183,RRIC=1.0/RIC,FHNEU=0.8,RFC=0.191 - & ,RFAC=RIC/(FHNEU*RFC*RFC)) - -C ---------------------------------------------------------------------- -C NOTE: THE TWO CODE BLOCKS BELOW DEFINE FUNCTIONS -C ---------------------------------------------------------------------- -C LECH'S SURFACE FUNCTIONS -C ---------------------------------------------------------------------- - PSLMU(ZZ)=-0.96*log(1.0-4.5*ZZ) - PSLMS(ZZ)=ZZ*RRIC-2.076*(1.-1./(ZZ+1.)) - PSLHU(ZZ)=-0.96*log(1.0-4.5*ZZ) - PSLHS(ZZ)=ZZ*RFAC-2.076*(1.-1./(ZZ+1.)) - -C ---------------------------------------------------------------------- -C PAULSON'S SURFACE FUNCTIONS -C ---------------------------------------------------------------------- - PSPMU(XX)=-2.*log((XX+1.)*0.5)-log((XX*XX+1.)*0.5)+2.*ATAN(XX) - & -PIHF - PSPMS(YY)=5.*YY - PSPHU(XX)=-2.*log((XX*XX+1.)*0.5) - PSPHS(YY)=5.*YY - -C ---------------------------------------------------------------------- -C THIS ROUTINE SFCDIF CAN HANDLE BOTH OVER OPEN WATER (SEA, OCEAN) AND -C OVER SOLID SURFACE (LAND, SEA-ICE). -C ---------------------------------------------------------------------- - ILECH=0 - -C ---------------------------------------------------------------------- -C ZTFC: RATIO OF ZOH/ZOM LESS OR EQUAL THAN 1 -C C......ZTFC=0.1 -C CZIL: CONSTANT C IN Zilitinkevich, S. S.1995,:NOTE ABOUT ZT -C ---------------------------------------------------------------------- - ZILFC=-CZIL*VKRM*SQVISC - -C ---------------------------------------------------------------------- - ZU=Z0 -C C.......ZT=Z0*ZTFC - RDZ=1./ZLM - CXCH=EXCM*RDZ - DTHV=THLM-THZ0 - DU2=MAX(SFCSPD*SFCSPD,EPSU2) - -C ---------------------------------------------------------------------- -C BELJARS CORRECTION OF USTAR -C ---------------------------------------------------------------------- - BTGH=BTG*HPBL -ccc If statements to avoid TANGENT LINEAR problems near zero - IF (BTGH*AKHS*DTHV .NE. 0.0) THEN - WSTAR2=WWST2*ABS(BTGH*AKHS*DTHV)**(2./3.) - ELSE - WSTAR2=0.0 - ENDIF - USTAR=MAX(SQRT(AKMS*SQRT(DU2+WSTAR2)),EPSUST) - -C ---------------------------------------------------------------------- -C ZILITINKEVITCH APPROACH FOR ZT -C ---------------------------------------------------------------------- - ZT=EXP(ZILFC*SQRT(USTAR*Z0))*Z0 - -C ---------------------------------------------------------------------- - ZSLU=ZLM+ZU - ZSLT=ZLM+ZT -C PRINT*,'ZSLT=',ZSLT -C PRINT*,'ZLM=',ZLM -C PRINT*,'ZT=',ZT -C - RLOGU=log(ZSLU/ZU) - RLOGT=log(ZSLT/ZT) -C - RLMO=ELFC*AKHS*DTHV/USTAR**3 -C PRINT*,'RLMO=',RLMO -C PRINT*,'ELFC=',ELFC -C PRINT*,'AKHS=',AKHS -C PRINT*,'DTHV=',DTHV -C PRINT*,'USTAR=',USTAR - - DO ITR=1,ITRMX -C ---------------------------------------------------------------------- -C 1./MONIN-OBUKKHOV LENGTH-SCALE -C ---------------------------------------------------------------------- - ZETALT=MAX(ZSLT*RLMO,ZTMIN) - RLMO=ZETALT/ZSLT - ZETALU=ZSLU*RLMO - ZETAU=ZU*RLMO - ZETAT=ZT*RLMO - - IF(ILECH.EQ.0) THEN - IF(RLMO.LT.0.)THEN - XLU4=1.-16.*ZETALU - XLT4=1.-16.*ZETALT - XU4 =1.-16.*ZETAU - XT4 =1.-16.*ZETAT - - XLU=SQRT(SQRT(XLU4)) - XLT=SQRT(SQRT(XLT4)) - XU =SQRT(SQRT(XU4)) - XT =SQRT(SQRT(XT4)) - - PSMZ=PSPMU(XU) -C PRINT*,'-----------1------------' -C PRINT*,'PSMZ=',PSMZ -C PRINT*,'PSPMU(ZETAU)=',PSPMU(ZETAU) -C PRINT*,'XU=',XU -C PRINT*,'------------------------' - SIMM=PSPMU(XLU)-PSMZ+RLOGU - PSHZ=PSPHU(XT) - SIMH=PSPHU(XLT)-PSHZ+RLOGT - ELSE - ZETALU=MIN(ZETALU,ZTMAX) - ZETALT=MIN(ZETALT,ZTMAX) - PSMZ=PSPMS(ZETAU) -C PRINT*,'-----------2------------' -C PRINT*,'PSMZ=',PSMZ -C PRINT*,'PSPMS(ZETAU)=',PSPMS(ZETAU) -C PRINT*,'ZETAU=',ZETAU -C PRINT*,'------------------------' - SIMM=PSPMS(ZETALU)-PSMZ+RLOGU - PSHZ=PSPHS(ZETAT) - SIMH=PSPHS(ZETALT)-PSHZ+RLOGT - ENDIF - ELSE -C ---------------------------------------------------------------------- -C LECH'S FUNCTIONS -C ---------------------------------------------------------------------- - IF(RLMO.LT.0.)THEN - PSMZ=PSLMU(ZETAU) -C PRINT*,'-----------3------------' -C PRINT*,'PSMZ=',PSMZ -C PRINT*,'PSLMU(ZETAU)=',PSLMU(ZETAU) -C PRINT*,'ZETAU=',ZETAU -C PRINT*,'------------------------' - SIMM=PSLMU(ZETALU)-PSMZ+RLOGU - PSHZ=PSLHU(ZETAT) - SIMH=PSLHU(ZETALT)-PSHZ+RLOGT - ELSE - ZETALU=MIN(ZETALU,ZTMAX) - ZETALT=MIN(ZETALT,ZTMAX) -C - PSMZ=PSLMS(ZETAU) -C PRINT*,'-----------4------------' -C PRINT*,'PSMZ=',PSMZ -C PRINT*,'PSLMS(ZETAU)=',PSLMS(ZETAU) -C PRINT*,'ZETAU=',ZETAU -C PRINT*,'------------------------' - SIMM=PSLMS(ZETALU)-PSMZ+RLOGU - PSHZ=PSLHS(ZETAT) - SIMH=PSLHS(ZETALT)-PSHZ+RLOGT - ENDIF - ENDIF -C ---------------------------------------------------------------------- -C BELJAARS CORRECTION FOR USTAR -C ---------------------------------------------------------------------- - USTAR=MAX(SQRT(AKMS*SQRT(DU2+WSTAR2)),EPSUST) - -C ---------------------------------------------------------------------- -C ZILITINKEVITCH FIX FOR ZT -C ---------------------------------------------------------------------- - ZT=EXP(ZILFC*SQRT(USTAR*Z0))*Z0 - - ZSLT=ZLM+ZT - RLOGT=log(ZSLT/ZT) -C----------------------------------------------------------------------- - USTARK=USTAR*VKRM - AKMS=MAX(USTARK/SIMM,CXCH) - AKHS=MAX(USTARK/SIMH,CXCH) -C----------------------------------------------------------------------- -C IF STATEMENTS TO AVOID TANGENT LINEAR PROBLEMS NEAR ZERO -C----------------------------------------------------------------------- - IF (BTGH*AKHS*DTHV .NE. 0.0) THEN - WSTAR2=WWST2*ABS(BTGH*AKHS*DTHV)**(2./3.) - ELSE - WSTAR2=0.0 - ENDIF - RLMN=ELFC*AKHS*DTHV/USTAR**3 -C----------------------------------------------------------------------- - RLMA=RLMO*WOLD+RLMN*WNEW -C----------------------------------------------------------------------- -C IF(ABS((RLMN-RLMO)/RLMA).LT.EPSIT) GO TO 110 -C----------------------------------------------------------------------- - RLMO=RLMA -C----------------------------------------------------------------------- - END DO - -C PRINT*,'----------------------------' -C PRINT*,'SFCDIF OUTPUT ! ! ! ! ! ! ! ! ! ! ! !' -C -C PRINT*,'ZLM=',ZLM -C PRINT*,'Z0=',Z0 -C PRINT*,'THZ0=',THZ0 -C PRINT*,'THLM=',THLM -C PRINT*,'SFCSPD=',SFCSPD -C PRINT*,'CZIL=',CZIL -C PRINT*,'AKMS=',AKMS -C PRINT*,'AKHS=',AKHS -C PRINT*,'----------------------------' -C -C ---------------------------------------------------------------------- -C END SUBROUTINE SFCDIF -C ---------------------------------------------------------------------- - RETURN - END - SUBROUTINE SHFLX (SSOIL,STC,SMC,SMCMAX,NSOIL,T1,DT,YY,ZZ1,ZSOIL, - & TBOT,ZBOT,SMCWLT,PSISAT,SH2O,BEXP,F1,DF1,ICE, - & QUARTZ,CSOIL) - - IMPLICIT NONE - -C ---------------------------------------------------------------------- -C SUBROUTINE SHFLX -C ---------------------------------------------------------------------- -C UPDATE THE TEMPERATURE STATE OF THE SOIL COLUMN BASED ON THE THERMAL -C DIFFUSION EQUATION AND UPDATE THE FROZEN SOIL MOISTURE CONTENT BASED -C ON THE TEMPERATURE. -C ---------------------------------------------------------------------- - INTEGER NSOLD - PARAMETER(NSOLD = 4) - - INTEGER I - INTEGER ICE - INTEGER IFRZ - INTEGER NSOIL - - REAL AI(NSOLD) - REAL BI(NSOLD) - REAL CI(NSOLD) - - REAL BEXP - REAL CSOIL - REAL DF1 - REAL DT - REAL F1 - REAL PSISAT - REAL QUARTZ - REAL RHSTS(NSOLD) - REAL SSOIL - REAL SH2O(NSOIL) - REAL SMC(NSOIL) - REAL SMCMAX - REAL SMCWLT - REAL STC(NSOIL) - REAL STCF(NSOLD) - REAL T0 - REAL T1 - REAL TBOT - REAL YY - REAL ZBOT - REAL ZSOIL(NSOIL) - REAL ZZ1 -Clu_timefilter - REAL OLDT1 - REAL STSOIL(NSOIL) - REAL CTFIL1,CTFIL2 - PARAMETER (CTFIL1=.5,CTFIL2=1.-CTFIL1) - - PARAMETER(T0 = 273.15) - -Clu_timefilter - OLDT1 = T1 - DO I = 1,NSOIL - STSOIL(I) = STC(I) - END DO - -C ---------------------------------------------------------------------- -C HRT ROUTINE CALCS THE RIGHT HAND SIDE OF THE SOIL TEMP DIF EQN -C ---------------------------------------------------------------------- - IF (ICE.NE.0) THEN - -C ---------------------------------------------------------------------- -C SEA-ICE CASE, GLACIAL-ICE CASE -C ---------------------------------------------------------------------- - CALL HRTICE (RHSTS,STC,NSOIL,ZSOIL,YY,ZZ1,DF1,AI,BI,CI, - & ICE,TBOT) - - CALL HSTEP (STCF,STC,RHSTS,DT,NSOIL,AI,BI,CI) - - ELSE - -C ---------------------------------------------------------------------- -C LAND-MASS CASE -C ---------------------------------------------------------------------- - CALL HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1,TBOT, - & ZBOT,PSISAT,SH2O,DT, - & BEXP,F1,DF1,QUARTZ,CSOIL,AI,BI,CI) - - CALL HSTEP (STCF,STC,RHSTS,DT,NSOIL,AI,BI,CI) - - ENDIF - - DO I = 1,NSOIL - STC(I) = STCF(I) - END DO - -C ---------------------------------------------------------------------- -C IN THE NO SNOWPACK CASE (VIA ROUTINE NOPAC BRANCH,) UPDATE THE GRND -C (SKIN) TEMPERATURE HERE IN RESPONSE TO THE UPDATED SOIL TEMPERATURE -C PROFILE ABOVE. (NOTE: INSPECTION OF ROUTINE SNOPAC SHOWS THAT T1 -C BELOW IS A DUMMY VARIABLE ONLY, AS SKIN TEMPERATURE IS UPDATED -C DIFFERENTLY IN ROUTINE SNOPAC) -C ---------------------------------------------------------------------- - T1 = (YY + (ZZ1 - 1.0) * STC(1)) / ZZ1 - -Clu_timefilter - T1 = CTFIL1 * T1 + CTFIL2 * OLDT1 - DO I = 1, NSOIL - STC(I) = CTFIL1 * STC(I) + CTFIL2 * STSOIL(I) - ENDDO - - -C ---------------------------------------------------------------------- -C CALCULATE SURFACE SOIL HEAT FLUX -C ---------------------------------------------------------------------- - SSOIL = DF1 * (STC(1) - T1) / (0.5 * ZSOIL(1)) - -C ---------------------------------------------------------------------- -C END SUBROUTINE SHFLX -C ---------------------------------------------------------------------- - RETURN - END - SUBROUTINE SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, - & SH2O,SLOPE,KDT,FRZFACT, - & SMCMAX,BEXP,SMCWLT,DKSAT,DWSAT, - & SHDFAC,CMCMAX, - & RUNOFF1,RUNOFF2,RUNOFF3, - & EDIR1,EC1,ET1, - & DRIP) - - IMPLICIT NONE - -C ---------------------------------------------------------------------- -C SUBROUTINE SMFLX -C ---------------------------------------------------------------------- -C CALCULATE SOIL MOISTURE FLUX. THE SOIL MOISTURE CONTENT (SMC - A PER -C UNIT VOLUME MEASUREMENT) IS A DEPENDENT VARIABLE THAT IS UPDATED WITH -C PROGNOSTIC EQNS. THE CANOPY MOISTURE CONTENT (CMC) IS ALSO UPDATED. -C FROZEN GROUND VERSION: NEW STATES ADDED: SH2O, AND FROZEN GROUND -C CORRECTION FACTOR, FRZFACT AND PARAMETER SLOPE. -C ---------------------------------------------------------------------- - INTEGER NSOLD - PARAMETER(NSOLD = 4) - - INTEGER I - INTEGER K - INTEGER NSOIL - - REAL AI(NSOLD) - REAL BI(NSOLD) - REAL CI(NSOLD) - - REAL BEXP - REAL CMC - REAL CMCMAX - REAL DKSAT - REAL DRIP - REAL DT - REAL DUMMY - REAL DWSAT - REAL EC1 - REAL EDIR1 - REAL ET1(NSOIL) - REAL EXCESS - REAL FRZFACT - REAL KDT - REAL PCPDRP - REAL PRCP1 - REAL RHSCT - REAL RHSTT(NSOLD) - REAL RUNOFF1 - REAL RUNOFF2 - REAL RUNOFF3 - REAL SHDFAC - REAL SMC(NSOIL) - REAL SH2O(NSOIL) - REAL SICE(NSOLD) - REAL SH2OA(NSOLD) - REAL SH2OFG(NSOLD) - REAL SLOPE - REAL SMCMAX - REAL SMCWLT - REAL TRHSCT - REAL ZSOIL(NSOIL) - -C ---------------------------------------------------------------------- -C EXECUTABLE CODE BEGINS HERE. -C ---------------------------------------------------------------------- - DUMMY = 0. - -C ---------------------------------------------------------------------- -C COMPUTE THE RIGHT HAND SIDE OF THE CANOPY EQN TERM ( RHSCT ) -C ---------------------------------------------------------------------- - RHSCT = SHDFAC * PRCP1 - EC1 - -C ---------------------------------------------------------------------- -C CONVERT RHSCT (A RATE) TO TRHSCT (AN AMOUNT) AND ADD IT TO EXISTING -C CMC. IF RESULTING AMT EXCEEDS MAX CAPACITY, IT BECOMES DRIP AND WILL -C FALL TO THE GRND. -C ---------------------------------------------------------------------- - DRIP = 0. - TRHSCT = DT * RHSCT - EXCESS = CMC + TRHSCT - IF (EXCESS .GT. CMCMAX) DRIP = EXCESS - CMCMAX - -C ---------------------------------------------------------------------- -C PCPDRP IS THE COMBINED PRCP1 AND DRIP (FROM CMC) THAT GOES INTO THE -C SOIL -C ---------------------------------------------------------------------- - PCPDRP = (1. - SHDFAC) * PRCP1 + DRIP / DT - -C ---------------------------------------------------------------------- -C STORE ICE CONTENT AT EACH SOIL LAYER BEFORE CALLING SRT & SSTEP -C ---------------------------------------------------------------------- - DO I = 1,NSOIL - SICE(I) = SMC(I) - SH2O(I) - END DO - -C ---------------------------------------------------------------------- -C CALL SUBROUTINES SRT AND SSTEP TO SOLVE THE SOIL MOISTURE -C TENDENCY EQUATIONS. -C -C IF THE INFILTRATING PRECIP RATE IS NONTRIVIAL, -C (WE CONSIDER NONTRIVIAL TO BE A PRECIP TOTAL OVER THE TIME STEP -C EXCEEDING ONE ONE-THOUSANDTH OF THE WATER HOLDING CAPACITY OF -C THE FIRST SOIL LAYER) -C THEN CALL THE SRT/SSTEP SUBROUTINE PAIR TWICE IN THE MANNER OF -C TIME SCHEME "F" (IMPLICIT STATE, AVERAGED COEFFICIENT) -C OF SECTION 2 OF KALNAY AND KANAMITSU (1988, MWR, VOL 116, -C PAGES 1945-1958)TO MINIMIZE 2-DELTA-T OSCILLATIONS IN THE -C SOIL MOISTURE VALUE OF THE TOP SOIL LAYER THAT CAN ARISE BECAUSE -C OF THE EXTREME NONLINEAR DEPENDENCE OF THE SOIL HYDRAULIC -C DIFFUSIVITY COEFFICIENT AND THE HYDRAULIC CONDUCTIVITY ON THE -C SOIL MOISTURE STATE -C OTHERWISE CALL THE SRT/SSTEP SUBROUTINE PAIR ONCE IN THE MANNER OF -C TIME SCHEME "D" (IMPLICIT STATE, EXPLICIT COEFFICIENT) -C OF SECTION 2 OF KALNAY AND KANAMITSU -C PCPDRP IS UNITS OF KG/M**2/S OR MM/S, ZSOIL IS NEGATIVE DEPTH IN M -C ---------------------------------------------------------------------- -C IF ( PCPDRP .GT. 0.0 ) THEN - IF ( (PCPDRP*DT) .GT. (0.001*1000.0*(-ZSOIL(1))*SMCMAX) ) THEN - -C ---------------------------------------------------------------------- -C FROZEN GROUND VERSION: -C SMC STATES REPLACED BY SH2O STATES IN SRT SUBR. SH2O & SICE STATES -C INCLUDED IN SSTEP SUBR. FROZEN GROUND CORRECTION FACTOR, FRZFACT -C ADDED. ALL WATER BALANCE CALCULATIONS USING UNFROZEN WATER -C ---------------------------------------------------------------------- - CALL SRT (RHSTT,EDIR1,ET1,SH2O,SH2O,NSOIL,PCPDRP,ZSOIL, - & DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, - & RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZFACT,SICE,AI,BI,CI) - - CALL SSTEP (SH2OFG,SH2O,DUMMY,RHSTT,RHSCT,DT,NSOIL,SMCMAX, - & CMCMAX,RUNOFF3,ZSOIL,SMC,SICE,AI,BI,CI) - - DO K = 1,NSOIL - SH2OA(K) = (SH2O(K) + SH2OFG(K)) * 0.5 - END DO - - CALL SRT (RHSTT,EDIR1,ET1,SH2O,SH2OA,NSOIL,PCPDRP,ZSOIL, - & DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, - & RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZFACT,SICE,AI,BI,CI) - - CALL SSTEP (SH2O,SH2O,CMC,RHSTT,RHSCT,DT,NSOIL,SMCMAX, - & CMCMAX,RUNOFF3,ZSOIL,SMC,SICE,AI,BI,CI) - - ELSE - - CALL SRT (RHSTT,EDIR1,ET1,SH2O,SH2O,NSOIL,PCPDRP,ZSOIL, - & DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, - & RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZFACT,SICE,AI,BI,CI) - - CALL SSTEP (SH2O,SH2O,CMC,RHSTT,RHSCT,DT,NSOIL,SMCMAX, - & CMCMAX,RUNOFF3,ZSOIL,SMC,SICE,AI,BI,CI) - - ENDIF - -c RUNOF = RUNOFF - -C ---------------------------------------------------------------------- -C END SUBROUTINE SMFLX -C ---------------------------------------------------------------------- - RETURN - END - SUBROUTINE SNFRAC (SNEQV,SNUP,SALP,SNOWH,SNCOVR) - - IMPLICIT NONE - -C ---------------------------------------------------------------------- -C SUBROUTINE SNFRAC -C ---------------------------------------------------------------------- -C CALCULATE SNOW FRACTION (0 -> 1) -C SNEQV SNOW WATER EQUIVALENT (M) -C SNUP THRESHOLD SNEQV DEPTH ABOVE WHICH SNCOVR=1 -C SALP TUNING PARAMETER -C SNCOVR FRACTIONAL SNOW COVER -C ---------------------------------------------------------------------- - REAL SNEQV, SNUP, SALP, SNCOVR, RSNOW, Z0N, SNOWH - -C ---------------------------------------------------------------------- -C SNUP IS VEG-CLASS DEPENDENT SNOWDEPTH THRESHHOLD (SET IN ROUTINE -C REDPRM) ABOVE WHICH SNOCVR=1. -C ---------------------------------------------------------------------- - IF (SNEQV .LT. SNUP) THEN - RSNOW = SNEQV/SNUP - SNCOVR = 1. - ( EXP(-SALP*RSNOW) - RSNOW*EXP(-SALP)) - ELSE - SNCOVR = 1.0 - ENDIF - - Z0N=0.035 -C FORMULATION OF DICKINSON ET AL. 1986 - -C SNCOVR=SNOWH/(SNOWH + 5*Z0N) - -C FORMULATION OF MARSHALL ET AL. 1994 -C SNCOVR=SNEQV/(SNEQV + 2*Z0N) - -C ---------------------------------------------------------------------- -C END SUBROUTINE SNFRAC -C ---------------------------------------------------------------------- - RETURN - END - FUNCTION SNKSRC (TAVG,SMC,SH2O,ZSOIL,NSOIL, - & SMCMAX,PSISAT,BEXP,DT,K,QTOT) - - IMPLICIT NONE - -C ---------------------------------------------------------------------- -C FUNCTION SNKSRC -C ---------------------------------------------------------------------- -C CALCULATE SINK/SOURCE TERM OF THE TERMAL DIFFUSION EQUATION. (SH2O) IS -C AVAILABLE LIQUED WATER. -C ---------------------------------------------------------------------- - INTEGER K - INTEGER NSOIL - - REAL BEXP - REAL DF - REAL DH2O - REAL DT - REAL DZ - REAL DZH - REAL FREE - REAL FRH2O - REAL HLICE - REAL PSISAT - REAL QTOT - REAL SH2O - REAL SMC - REAL SMCMAX - REAL SNKSRC - REAL T0 - REAL TAVG - REAL TDN - REAL TM - REAL TUP - REAL TZ - REAL X0 - REAL XDN - REAL XH2O - REAL XUP - REAL ZSOIL (NSOIL) - - PARAMETER(DH2O = 1.0000E3) - PARAMETER(HLICE = 3.3350E5) - PARAMETER(T0 = 2.7315E2) - - IF (K .EQ. 1) THEN - DZ = -ZSOIL(1) - ELSE - DZ = ZSOIL(K-1)-ZSOIL(K) - ENDIF - -C ---------------------------------------------------------------------- -C VIA FUNCTION FRH2O, COMPUTE POTENTIAL OR 'EQUILIBRIUM' UNFROZEN -C SUPERCOOLED FREE WATER FOR GIVEN SOIL TYPE AND SOIL LAYER TEMPERATURE. -C FUNCTION FRH20 INVOKES EQN (17) FROM V. KOREN ET AL (1999, JGR, VOL. -C 104, PG 19573). (ASIDE: LATTER EQN IN JOURNAL IN CENTIGRADE UNITS. -C ROUTINE FRH2O USE FORM OF EQN IN KELVIN UNITS.) -C ---------------------------------------------------------------------- - FREE = FRH2O(TAVG,SMC,SH2O,SMCMAX,BEXP,PSISAT) - -C ---------------------------------------------------------------------- -C IN NEXT BLOCK OF CODE, INVOKE EQN 18 OF V. KOREN ET AL (1999, JGR, -C VOL. 104, PG 19573.) THAT IS, FIRST ESTIMATE THE NEW AMOUNTOF LIQUID -C WATER, 'XH2O', IMPLIED BY THE SUM OF (1) THE LIQUID WATER AT THE BEGIN -C OF CURRENT TIME STEP, AND (2) THE FREEZE OF THAW CHANGE IN LIQUID -C WATER IMPLIED BY THE HEAT FLUX 'QTOT' PASSED IN FROM ROUTINE HRT. -C SECOND, DETERMINE IF XH2O NEEDS TO BE BOUNDED BY 'FREE' (EQUIL AMT) OR -C IF 'FREE' NEEDS TO BE BOUNDED BY XH2O. -C ---------------------------------------------------------------------- - XH2O = SH2O + QTOT*DT/(DH2O*HLICE*DZ) - -C ---------------------------------------------------------------------- -C FIRST, IF FREEZING AND REMAINING LIQUID LESS THAN LOWER BOUND, THEN -C REDUCE EXTENT OF FREEZING, THEREBY LETTING SOME OR ALL OF HEAT FLUX -C QTOT COOL THE SOIL TEMP LATER IN ROUTINE HRT. -C ---------------------------------------------------------------------- - IF ( XH2O .LT. SH2O .AND. XH2O .LT. FREE) THEN - IF ( FREE .GT. SH2O ) THEN - XH2O = SH2O - ELSE - XH2O = FREE - ENDIF - ENDIF - -C ---------------------------------------------------------------------- -C SECOND, IF THAWING AND THE INCREASE IN LIQUID WATER GREATER THAN UPPER -C BOUND, THEN REDUCE EXTENT OF THAW, THEREBY LETTING SOME OR ALL OF HEAT -C FLUX QTOT WARM THE SOIL TEMP LATER IN ROUTINE HRT. -C ---------------------------------------------------------------------- - IF ( XH2O .GT. SH2O .AND. XH2O .GT. FREE ) THEN - IF ( FREE .LT. SH2O ) THEN - XH2O = SH2O - ELSE - XH2O = FREE - ENDIF - ENDIF - - IF (XH2O .LT. 0.) XH2O = 0. - IF (XH2O .GT. SMC) XH2O = SMC - -C ---------------------------------------------------------------------- -C CALCULATE PHASE-CHANGE HEAT SOURCE/SINK TERM FOR USE IN ROUTINE HRT -C AND UPDATE LIQUID WATER TO REFLCET FINAL FREEZE/THAW INCREMENT. -C ---------------------------------------------------------------------- - SNKSRC = -DH2O*HLICE*DZ*(XH2O-SH2O)/DT - SH2O = XH2O - -C ---------------------------------------------------------------------- -C END FUNCTION SNKSRC -C ---------------------------------------------------------------------- -77 RETURN - END - SUBROUTINE SNOPAC (ETP,ETA,PRCP,PRCP1,SNOWNG,SMC,SMCMAX,SMCWLT, - & SMCREF,SMCDRY,CMC,CMCMAX,NSOIL,DT, - & SBETA,DF1, - & Q2,T1,SFCTMP,T24,TH2,FDOWN,F1,SSOIL,STC,EPSCA, - & SFCPRS,BEXP,PC,RCH,RR,CFACTR,SNCOVR,ESD,SNDENS, - & SNOWH,SH2O,SLOPE,KDT,FRZFACT,PSISAT,SNUP, - & ZSOIL,DWSAT,DKSAT,TBOT,ZBOT,SHDFAC,RUNOFF1, - & RUNOFF2,RUNOFF3,EDIR,EC,ET,ETT,NROOT,SNOMLT, - & ICE,RTDIS,QUARTZ,FXEXP,CSOIL, - & BETA,DRIP,DEW,FLX1,FLX2,FLX3,ESNOW) - - IMPLICIT NONE - -C ---------------------------------------------------------------------- -C SUBROUTINE SNOPAC -C ---------------------------------------------------------------------- -C CALCULATE SOIL MOISTURE AND HEAT FLUX VALUES & UPDATE SOIL MOISTURE -C CONTENT AND SOIL HEAT CONTENT VALUES FOR THE CASE WHEN A SNOW PACK IS -C PRESENT. -C ---------------------------------------------------------------------- - INTEGER ICE - INTEGER NROOT - INTEGER NSOIL - - LOGICAL SNOWNG - - REAL BEXP - REAL BETA - REAL CFACTR - REAL CMC - REAL CMCMAX - REAL CP - REAL CPH2O - REAL CPICE - REAL CSOIL - REAL DENOM - REAL DEW - REAL DF1 - REAL DKSAT - REAL DRIP - REAL DSOIL - REAL DTOT - REAL DT - REAL DWSAT - REAL EC - REAL EDIR - REAL EPSCA - REAL ESD - REAL ESDMIN - REAL EXPSNO - REAL EXPSOI - REAL ETA - REAL ETA1 - REAL ETP - REAL ETP1 - REAL ETP2 - REAL ET(NSOIL) - REAL ETT - REAL EX - REAL EXPFAC - REAL FDOWN - REAL FXEXP - REAL FLX1 - REAL FLX2 - REAL FLX3 - REAL F1 - REAL KDT - REAL LSUBF - REAL LSUBC - REAL LSUBS - REAL PC - REAL PRCP - REAL PRCP1 - REAL Q2 - REAL RCH - REAL RR - REAL RTDIS(NSOIL) - REAL SSOIL - REAL SBETA - REAL SSOIL1 - REAL SFCTMP - REAL SHDFAC - REAL SIGMA - REAL SMC(NSOIL) - REAL SH2O(NSOIL) - REAL SMCDRY - REAL SMCMAX - REAL SMCREF - REAL SMCWLT - REAL SNOMLT - REAL SNOEXP !!!!!<-------- for Noah V2.7.1 - REAL SNOWH - REAL STC(NSOIL) - REAL T1 - REAL T11 - REAL T12 - REAL T12A - REAL T12B - REAL T24 - REAL TBOT - REAL ZBOT - REAL TH2 - REAL YY - REAL ZSOIL(NSOIL) - REAL ZZ1 - REAL TFREEZ - REAL SALP - REAL SFCPRS - REAL SLOPE - REAL FRZFACT - REAL PSISAT - REAL SNUP - REAL RUNOFF1 - REAL RUNOFF2 - REAL RUNOFF3 - REAL QUARTZ - REAL SNDENS - REAL SNCOND - REAL RSNOW - REAL SNCOVR - REAL QSAT - REAL ETP3 - REAL SEH - REAL T14 - REAL CSNOW - - REAL EC1 - REAL EDIR1 - REAL ET1(NSOIL) - REAL ETT1 - - REAL ETNS - REAL ETNS1 - REAL ESNOW - REAL ESNOW1 - REAL ESNOW2 - REAL ETANRG - - INTEGER K - - PARAMETER(CP = 1004.5) - PARAMETER(CPH2O = 4.218E+3) - PARAMETER(CPICE = 2.106E+3) - PARAMETER(ESDMIN = 1.E-6) - PARAMETER(LSUBF = 3.335E+5) - PARAMETER(LSUBC = 2.501000E+6) - PARAMETER(LSUBS = 2.83E+6) - PARAMETER(SIGMA = 5.67E-8) - PARAMETER(TFREEZ = 273.15) - -! DATA SNOEXP /1.0/ !!! <----- for Noah V2.7 - DATA SNOEXP /2.0/ !!! <----- for Noah V2.7.1 - -C ---------------------------------------------------------------------- -C EXECUTABLE CODE BEGINS HERE: -C CONVERT POTENTIAL EVAP (ETP) FROM KG M-2 S-1 TO M S-1 AND THEN TO AN -C AMOUNT (M) GIVEN TIMESTEP (DT) AND CALL IT AN EFFECTIVE SNOWPACK -C REDUCTION AMOUNT, ESNOW2 (M) FOR A SNOWCOVER FRACTION = 1.0. THIS IS -c THE AMOUNT THE SNOWPACK WOULD BE REDUCED DUE TO SUBLIMATION FROM THE -C SNOW SFC DURING THE TIMESTEP. SUBLIMATION WILL PROCEED AT THE -C POTENTIAL RATE UNLESS THE SNOW DEPTH IS LESS THAN THE EXPECTED -C SNOWPACK REDUCTION. FOR SNOWCOVER FRACTION = 1.0, 0=EDIR=ET=EC, AND -C HENCE TOTAL EVAP = ESNOW = SUBLIMATION (POTENTIAL EVAP RATE) -C ---------------------------------------------------------------------- -C IF SEA-ICE (ICE=1) OR GLACIAL-ICE (ICE=-1), SNOWCOVER FRACTION = 1.0, -C AND SUBLIMATION IS AT THE POTENTIAL RATE. -C FOR NON-GLACIAL LAND (ICE=0), IF SNOWCOVER FRACTION < 1.0, TOTAL -C EVAPORATION < POTENTIAL DUE TO NON-POTENTIAL CONTRIBUTION FROM -C NON-SNOW COVERED FRACTION. -C ---------------------------------------------------------------------- - PRCP1 = PRCP1*0.001 - -C ---------------------------------------------------------------------- - EDIR = 0.0 - EDIR1 = 0.0 - EC = 0.0 - EC1 = 0.0 - DO K = 1,NSOIL - ET(K) = 0.0 - ET1(K) = 0.0 - ENDDO - ETT = 0.0 - ETT1 = 0.0 - ETNS = 0.0 - ETNS1 = 0.0 - ESNOW = 0.0 - ESNOW1 = 0.0 - ESNOW2 = 0.0 -C ---------------------------------------------------------------------- - - DEW = 0.0 - ETP1 = ETP*0.001 - - IF (ETP .LT. 0.0) THEN -C ---------------------------------------------------------------------- -C IF ETP<0 (DOWNWARD) THEN DEWFALL (=FROSTFALL IN THIS CASE). -C ---------------------------------------------------------------------- - DEW = -ETP1 - ESNOW2 = ETP1 * DT - ETANRG = ETP*((1.-SNCOVR)*LSUBC + SNCOVR*LSUBS) - ELSE -C ---------------------------------------------------------------------- -C ETP >= 0, UPWARD MOISTURE FLUX -C ---------------------------------------------------------------------- - IF (ICE .NE. 0) THEN -C ---------------------------------------------------------------------- -C SEA-ICE AND GLACIAL-ICE CASE -C ---------------------------------------------------------------------- - ESNOW = ETP - ESNOW1 = ESNOW*0.001 - ESNOW2 = ESNOW1*DT - ETANRG = ESNOW*LSUBS - ELSE -C ---------------------------------------------------------------------- -C NON-GLACIAL LAND CASE -C ---------------------------------------------------------------------- - IF (SNCOVR .LT. 1.) THEN - CALL EVAPO (ETNS1,SMC,NSOIL,CMC,ETP1,DT,ZSOIL, - & SH2O,SMCMAX,BEXP,PC,SMCWLT,DKSAT,DWSAT, - & SMCREF,SHDFAC,CMCMAX, - & SMCDRY,CFACTR, - & EDIR1,EC1,ET1,ETT1,SFCTMP,Q2,NROOT,RTDIS,FXEXP) -C ---------------------------------------------------------------------- - EDIR1 = EDIR1*(1.-SNCOVR) - EC1 = EC1*(1.-SNCOVR) - DO K = 1,NSOIL - ET1(K) = ET1(K)*(1.-SNCOVR) - END DO - ETT1 = ETT1*(1.-SNCOVR) - ETNS1 = ETNS1*(1.-SNCOVR) -C ---------------------------------------------------------------------- - EDIR = EDIR1 * 1000.0 - EC = EC1 * 1000.0 - DO K = 1,NSOIL - ET(K) = ET1(K) * 1000.0 - END DO - ETT = ETT1 * 1000.0 - ETNS = ETNS1 * 1000.0 -C ---------------------------------------------------------------------- - ENDIF - ESNOW = ETP*SNCOVR -c ESNOW1 = ETP*0.001 - ESNOW1 = ESNOW*0.001 - ESNOW2 = ESNOW1*DT - ETANRG = ESNOW*LSUBS + ETNS*LSUBC - ENDIF - ENDIF - -C ---------------------------------------------------------------------- -C IF PRECIP IS FALLING, CALCULATE HEAT FLUX FROM SNOW SFC TO NEWLY -C ACCUMULATING PRECIP. NOTE THAT THIS REFLECTS THE FLUX APPROPRIATE FOR -C THE NOT-YET-UPDATED SKIN TEMPERATURE (T1). ASSUMES TEMPERATURE OF THE -C SNOWFALL STRIKING THE GOUND IS =SFCTMP (LOWEST MODEL LEVEL AIR TEMP). -C ---------------------------------------------------------------------- - FLX1 = 0.0 - IF (SNOWNG) THEN - FLX1 = CPICE * PRCP * (T1 - SFCTMP) - ELSE - IF (PRCP .GT. 0.0) FLX1 = CPH2O * PRCP * (T1 - SFCTMP) - ENDIF - -C ---------------------------------------------------------------------- -C CALCULATE AN 'EFFECTIVE SNOW-GRND SFC TEMP' (T12) BASED ON HEAT FLUXES -C BETWEEN THE SNOW PACK AND THE SOIL AND ON NET RADIATION. -C INCLUDE FLX1 (PRECIP-SNOW SFC) AND FLX2 (FREEZING RAIN LATENT HEAT) -C FLUXES. -C FLX2 REFLECTS FREEZING RAIN LATENT HEAT FLUX USING T1 CALCULATED IN -C PENMAN. -C ---------------------------------------------------------------------- - DSOIL = -(0.5 * ZSOIL(1)) - DTOT = SNOWH + DSOIL - DENOM = 1.0 + DF1 / (DTOT * RR * RCH) -c T12A = ( (FDOWN-FLX1-FLX2-SIGMA*T24)/RCH -c & + TH2 - SFCTMP - BETA*EPSCA ) / RR - T12A = ( (FDOWN-FLX1-FLX2-SIGMA*T24)/RCH - & + TH2 - SFCTMP - ETANRG/RCH ) / RR - T12B = DF1 * STC(1) / (DTOT * RR * RCH) - T12 = (SFCTMP + T12A + T12B) / DENOM - -C ---------------------------------------------------------------------- -C IF THE 'EFFECTIVE SNOW-GRND SFC TEMP' IS AT OR BELOW FREEZING, NO SNOW -C MELT WILL OCCUR. SET THE SKIN TEMP TO THIS EFFECTIVE TEMP. REDUCE -C (BY SUBLIMINATION ) OR INCREASE (BY FROST) THE DEPTH OF THE SNOWPACK, -C DEPENDING ON SIGN OF ETP. -C UPDATE SOIL HEAT FLUX (SSOIL) USING NEW SKIN TEMPERATURE (T1) -C SINCE NO SNOWMELT, SET ACCUMULATED SNOWMELT TO ZERO, SET 'EFFECTIVE' -C PRECIP FROM SNOWMELT TO ZERO, SET PHASE-CHANGE HEAT FLUX FROM SNOWMELT -C TO ZERO. -C ---------------------------------------------------------------------- - IF (T12 .LE. TFREEZ) THEN - T1 = T12 - SSOIL = DF1 * (T1 - STC(1)) / DTOT -c ESD = MAX(0.0, ESD-ETP2) - ESD = MAX(0.0, ESD-ESNOW2) - FLX3 = 0.0 - EX = 0.0 - SNOMLT = 0.0 - - ELSE -C ---------------------------------------------------------------------- -C IF THE 'EFFECTIVE SNOW-GRND SFC TEMP' IS ABOVE FREEZING, SNOW MELT -C WILL OCCUR. CALL THE SNOW MELT RATE,EX AND AMT, SNOMLT. REVISE THE -C EFFECTIVE SNOW DEPTH. REVISE THE SKIN TEMP BECAUSE IT WOULD HAVE CHGD -C DUE TO THE LATENT HEAT RELEASED BY THE MELTING. CALC THE LATENT HEAT -C RELEASED, FLX3. SET THE EFFECTIVE PRECIP, PRCP1 TO THE SNOW MELT RATE, -C EX FOR USE IN SMFLX. ADJUSTMENT TO T1 TO ACCOUNT FOR SNOW PATCHES. -C CALCULATE QSAT VALID AT FREEZING POINT. NOTE THAT ESAT (SATURATION -C VAPOR PRESSURE) VALUE OF 6.11E+2 USED HERE IS THAT VALID AT FRZZING -C POINT. NOTE THAT ETP FROM CALL PENMAN IN SFLX IS IGNORED HERE IN -C FAVOR OF BULK ETP OVER 'OPEN WATER' AT FREEZING TEMP. -C UPDATE SOIL HEAT FLUX (S) USING NEW SKIN TEMPERATURE (T1) -C ---------------------------------------------------------------------- - -c....Noah V2.7.1 -c mek Feb2004 -c non-linear weighting of snow vs non-snow covered portions of gridbox -c so with SNOEXP = 2.0 (>1), surface skin temperature is higher than for -c the linear case (SNOEXP = 1). - -!! T1 = TFREEZ * SNCOVR + T12 * (1.0 - SNCOVR) - T1=TFREEZ * SNCOVR**SNOEXP+T12*(1.0 - SNCOVR**SNOEXP) - -c QSAT = (0.622*6.11E2)/(SFCPRS-0.378*6.11E2) -c ETP = RCH*(QSAT-Q2)/CP -c ETP2 = ETP*0.001*DT - BETA = 1.0 - SSOIL = DF1 * (T1 - STC(1)) / DTOT - -C ---------------------------------------------------------------------- -C IF POTENTIAL EVAP (SUBLIMATION) GREATER THAN DEPTH OF SNOWPACK. -C BETA<1 -C SNOWPACK HAS SUBLIMATED AWAY, SET DEPTH TO ZERO. -C ---------------------------------------------------------------------- -c IF (ESD .LE. ETP2) THEN -c IF (ESD .LE. ESNOW2) THEN - IF (ESD-ESNOW2 .LE. ESDMIN) THEN -c BETA = ESD / ETP2 - ESD = 0.0 - EX = 0.0 - SNOMLT = 0.0 - FLX3 = 0.0 - - ELSE -C ---------------------------------------------------------------------- -C POTENTIAL EVAP (SUBLIMATION) LESS THAN DEPTH OF SNOWPACK, RETAIN -C BETA=1. -C SNOWPACK (ESD) REDUCED BY POTENTIAL EVAP RATE -C ETP3 (CONVERT TO FLUX) -C ---------------------------------------------------------------------- -c ESD = ESD-ETP2 - ESD = ESD-ESNOW2 -c ETP3 = ETP*LSUBC - SEH = RCH*(T1-TH2) - T14 = T1*T1 - T14 = T14*T14 -c FLX3 = FDOWN - FLX1 - FLX2 - SIGMA*T14 - SSOIL - SEH - ETP3 - FLX3 = FDOWN - FLX1 - FLX2 - SIGMA*T14 - SSOIL - SEH - ETANRG - IF (FLX3 .LE .0.0) FLX3 = 0.0 - EX = FLX3*0.001/LSUBF - -C ---------------------------------------------------------------------- -C SNOWMELT REDUCTION DEPENDING ON SNOW COVER -C IF SNOW COVER LESS THAN 5% NO SNOWMELT REDUCTION -C ***NOTE: DOES 'IF' BELOW FAIL TO MATCH THE MELT WATER WITH THE MELT -C ENERGY? -C ---------------------------------------------------------------------- -c IF (SNCOVR .GT. 0.05) EX = EX * SNCOVR - SNOMLT = EX * DT - -C ---------------------------------------------------------------------- -C ESDMIN REPRESENTS A SNOWPACK DEPTH THRESHOLD VALUE BELOW WHICH WE -C CHOOSE NOT TO RETAIN ANY SNOWPACK, AND INSTEAD INCLUDE IT IN SNOWMELT. -C ---------------------------------------------------------------------- - IF (ESD-SNOMLT .GE. ESDMIN) THEN - ESD = ESD - SNOMLT - - ELSE -C ---------------------------------------------------------------------- -C SNOWMELT EXCEEDS SNOW DEPTH -C ---------------------------------------------------------------------- - EX = ESD/DT - FLX3 = EX*1000.0*LSUBF - SNOMLT = ESD - ESD = 0.0 - - ENDIF -C ---------------------------------------------------------------------- -C END OF 'ESD .LE. ETP2' IF-BLOCK -C ---------------------------------------------------------------------- - ENDIF - -c PRCP1 = PRCP1 + EX -C ---------------------------------------------------------------------- -C IF NON-GLACIAL LAND, ADD SNOWMELT RATE (EX) TO PRECIP RATE TO BE USED -C IN SUBROUTINE SMFLX (SOIL MOISTURE EVOLUTION) VIA INFILTRATION. -C -C FOR SEA-ICE AND GLACIAL-ICE, THE SNOWMELT WILL BE ADDED TO SUBSURFACE -C RUNOFF/BASEFLOW LATER NEAR THE END OF SFLX (AFTER RETURN FROM CALL TO -C SUBROUTINE SNOPAC) -C ---------------------------------------------------------------------- - IF (ICE .EQ. 0) PRCP1 = PRCP1 + EX - -C ---------------------------------------------------------------------- -C END OF 'T12 .LE. TFREEZ' IF-BLOCK -C ---------------------------------------------------------------------- - ENDIF - -C ---------------------------------------------------------------------- -C FINAL BETA NOW IN HAND, SO COMPUTE EVAPORATION. EVAP EQUALS ETP -C UNLESS BETA<1. -C ---------------------------------------------------------------------- -c ETA = BETA*ETP - -C ---------------------------------------------------------------------- -C SMFLX RETURNS UPDATED SOIL MOISTURE VALUES FOR NON-GLACIAL LAND. -C IF SEA-ICE (ICE=1) OR GLACIAL-ICE (ICE=-1), SKIP CALL TO SMFLX, SINCE -C NO SOIL MEDIUM FOR SEA-ICE OR GLACIAL-ICE -C ---------------------------------------------------------------------- - IF (ICE .EQ. 0) THEN - CALL SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, - & SH2O,SLOPE,KDT,FRZFACT, - & SMCMAX,BEXP,SMCWLT,DKSAT,DWSAT, - & SHDFAC,CMCMAX, - & RUNOFF1,RUNOFF2,RUNOFF3, - & EDIR1,EC1,ET1, - & DRIP) - - ENDIF - -C ---------------------------------------------------------------------- -C BEFORE CALL SHFLX IN THIS SNOWPACK CASE, SET ZZ1 AND YY ARGUMENTS TO -C SPECIAL VALUES THAT ENSURE THAT GROUND HEAT FLUX CALCULATED IN SHFLX -C MATCHES THAT ALREADY COMPUTER FOR BELOW THE SNOWPACK, THUS THE SFC -C HEAT FLUX TO BE COMPUTED IN SHFLX WILL EFFECTIVELY BE THE FLUX AT THE -C SNOW TOP SURFACE. T11 IS A DUMMY ARGUEMENT SO WE WILL NOT USE THE -C SKIN TEMP VALUE AS REVISED BY SHFLX. -C ---------------------------------------------------------------------- - ZZ1 = 1.0 - YY = STC(1)-0.5*SSOIL*ZSOIL(1)*ZZ1/DF1 - T11 = T1 - -C ---------------------------------------------------------------------- -C SHFLX WILL CALC/UPDATE THE SOIL TEMPS. NOTE: THE SUB-SFC HEAT FLUX -C (SSOIL1) AND THE SKIN TEMP (T11) OUTPUT FROM THIS SHFLX CALL ARE NOT -C USED IN ANY SUBSEQUENT CALCULATIONS. RATHER, THEY ARE DUMMY VARIABLES -C HERE IN THE SNOPAC CASE, SINCE THE SKIN TEMP AND SUB-SFC HEAT FLUX ARE -C UPDATED INSTEAD NEAR THE BEGINNING OF THE CALL TO SNOPAC. -C ---------------------------------------------------------------------- - CALL SHFLX (SSOIL1,STC,SMC,SMCMAX,NSOIL,T11,DT,YY,ZZ1,ZSOIL, - & TBOT,ZBOT,SMCWLT,PSISAT,SH2O,BEXP,F1,DF1,ICE, - & QUARTZ,CSOIL) - -C ---------------------------------------------------------------------- -C SNOW DEPTH AND DENSITY ADJUSTMENT BASED ON SNOW COMPACTION. YY IS -C ASSUMED TO BE THE SOIL TEMPERTURE AT THE TOP OF THE SOIL COLUMN. -C ---------------------------------------------------------------------- - IF (ICE .EQ. 0) THEN -C NON-GLACIAL LAND - IF (ESD .GT. 0.) THEN - CALL SNOWPACK (ESD,DT,SNOWH,SNDENS,T1,YY) - ELSE - ESD = 0. - SNOWH = 0. - SNDENS = 0. - SNCOND = 1. - SNCOVR = 0. - ENDIF -C ---------------------------------------------------------------------- -C OVER SEA-ICE OR GLACIAL-ICE, IF S.W.E. (ESD) BELOW THRESHOLD LOWER -C BOUND (0.01 M FOR SEA-ICE, 0.10 M FOR GLACIAL-ICE), THEN SET AT LOWER -C BOUND AND STORE THE SOURCE INCREMENT IN SUBSURFACE RUNOFF/BASEFLOW -C (RUNOFF2). NOTE: RUNOFF2 IS THEN A NEGATIVE VALUE (AS A FLAG) OVER -C SEA-ICE OR GLACIAL-ICE, IN ORDER TO ACHIEVE WATER BALANCE. -C ---------------------------------------------------------------------- - ELSEIF (ICE .EQ. 1) THEN -C SEA-ICE - IF (ESD .GE. 0.01) THEN - CALL SNOWPACK (ESD,DT,SNOWH,SNDENS,T1,YY) - ELSE -c SNDENS = ESD/SNOWH -c RUNOFF2 = -(0.01-ESD)/DT - ESD = 0.01 - SNOWH = 0.05 - SNCOVR = 1.0 -c SNOWH = ESD/SNDENS - ENDIF - ELSE -C GLACIAL-ICE - IF (ESD .GE. 0.10) THEN - CALL SNOWPACK (ESD,DT,SNOWH,SNDENS,T1,YY) - ELSE -c SNDENS = ESD/SNOWH -c RUNOFF2 = -(0.10-ESD)/DT - ESD = 0.10 - SNOWH = 0.50 - SNCOVR = 1.0 -c SNOWH = ESD/SNDENS - ENDIF - ENDIF - -C ---------------------------------------------------------------------- -C END SUBROUTINE SNOPAC -C ---------------------------------------------------------------------- - RETURN - END - SUBROUTINE SNOWPACK (ESD,DTSEC,SNOWH,SNDENS,TSNOW,TSOIL) - - IMPLICIT NONE - -C ---------------------------------------------------------------------- -C SUBROUTINE SNOWPACK -C ---------------------------------------------------------------------- -C CALCULATE COMPACTION OF SNOWPACK UNDER CONDITIONS OF INCREASING SNOW -C DENSITY, AS OBTAINED FROM AN APPROXIMATE SOLUTION OF E. ANDERSON'S -C DIFFERENTIAL EQUATION (3.29), NOAA TECHNICAL REPORT NWS 19, BY VICTOR -C KOREN, 03/25/95. -C ---------------------------------------------------------------------- -C ESD WATER EQUIVALENT OF SNOW (M) -C DTSEC TIME STEP (SEC) -C SNOWH SNOW DEPTH (M) -C SNDENS SNOW DENSITY (G/CM3=DIMENSIONLESS FRACTION OF H2O DENSITY) -C TSNOW SNOW SURFACE TEMPERATURE (K) -C TSOIL SOIL SURFACE TEMPERATURE (K) -C -C SUBROUTINE WILL RETURN NEW VALUES OF SNOWH AND SNDENS -C ---------------------------------------------------------------------- - INTEGER IPOL, J - - REAL BFAC,C1,C2,SNDENS,DSX,DTHR,DTSEC,DW,SNOWHC,SNOWH,PEXP,TAVGC, - & TSNOW,TSNOWC,TSOIL,TSOILC,ESD,ESDC,ESDCX,G,KN - - PARAMETER(C1 = 0.01, C2=21.0, G=9.81, KN=4000.0) - -C ---------------------------------------------------------------------- -C CONVERSION INTO SIMULATION UNITS -C ---------------------------------------------------------------------- - SNOWHC = SNOWH*100. - ESDC = ESD*100. - DTHR = DTSEC/3600. - TSNOWC = TSNOW-273.15 - TSOILC = TSOIL-273.15 - -C ---------------------------------------------------------------------- -C CALCULATING OF AVERAGE TEMPERATURE OF SNOW PACK -C ---------------------------------------------------------------------- - TAVGC = 0.5*(TSNOWC+TSOILC) - -C ---------------------------------------------------------------------- -C CALCULATING OF SNOW DEPTH AND DENSITY AS A RESULT OF COMPACTION -C SNDENS=DS0*(EXP(BFAC*ESD)-1.)/(BFAC*ESD) -C BFAC=DTHR*C1*EXP(0.08*TAVGC-C2*DS0) -C NOTE: BFAC*ESD IN SNDENS EQN ABOVE HAS TO BE CAREFULLY TREATED -C NUMERICALLY BELOW: -C C1 IS THE FRACTIONAL INCREASE IN DENSITY (1/(CM*HR)) -C C2 IS A CONSTANT (CM3/G) KOJIMA ESTIMATED AS 21 CMS/G -C ---------------------------------------------------------------------- - IF (ESDC .GT. 1.E-2) THEN - ESDCX = ESDC - ELSE - ESDCX = 1.E-2 - ENDIF - BFAC = DTHR*C1*EXP(0.08*TAVGC-C2*SNDENS) - -C DSX = SNDENS*((DEXP(BFAC*ESDC)-1.)/(BFAC*ESDC)) -C ---------------------------------------------------------------------- -C THE FUNCTION OF THE FORM (e**x-1)/x IMBEDDED IN ABOVE EXPRESSION -C FOR DSX WAS CAUSING NUMERICAL DIFFICULTIES WHEN THE DENOMINATOR "x" -C (I.E. BFAC*ESDC) BECAME ZERO OR APPROACHED ZERO (DESPITE THE FACT THAT -C THE ANALYTICAL FUNCTION (e**x-1)/x HAS A WELL DEFINED LIMIT AS -C "x" APPROACHES ZERO), HENCE BELOW WE REPLACE THE (e**x-1)/x -C EXPRESSION WITH AN EQUIVALENT, NUMERICALLY WELL-BEHAVED -C POLYNOMIAL EXPANSION. -C -C NUMBER OF TERMS OF POLYNOMIAL EXPANSION, AND HENCE ITS ACCURACY, -C IS GOVERNED BY ITERATION LIMIT "IPOL". -C IPOL GREATER THAN 9 ONLY MAKES A DIFFERENCE ON DOUBLE -C PRECISION (RELATIVE ERRORS GIVEN IN PERCENT %). -C IPOL=9, FOR REL.ERROR <~ 1.6 E-6 % (8 SIGNIFICANT DIGITS) -C IPOL=8, FOR REL.ERROR <~ 1.8 E-5 % (7 SIGNIFICANT DIGITS) -C IPOL=7, FOR REL.ERROR <~ 1.8 E-4 % ... -C ---------------------------------------------------------------------- - IPOL = 4 - PEXP = 0. - DO J = IPOL,1,-1 -C PEXP = (1. + PEXP)*BFAC*ESDC/REAL(J+1) - PEXP = (1. + PEXP)*BFAC*ESDCX/REAL(J+1) - END DO - PEXP = PEXP + 1. - - DSX = SNDENS*(PEXP) -C ---------------------------------------------------------------------- -C ABOVE LINE ENDS POLYNOMIAL SUBSTITUTION -C ---------------------------------------------------------------------- -C END OF KOREAN FORMULATION - -C BASE FORMULATION (COGLEY ET AL., 1990) -C CONVERT DENSITY FROM G/CM3 TO KG/M3 -C DSM=SNDENS*1000.0 - -C DSX=DSM+DTSEC*0.5*DSM*G*ESD/ -C & (1E7*EXP(-0.02*DSM+KN/(TAVGC+273.16)-14.643)) - -C CONVERT DENSITY FROM KG/M3 TO G/CM3 -C DSX=DSX/1000.0 - -C END OF COGLEY ET AL. FORMULATION - -C ---------------------------------------------------------------------- -C SET UPPER/LOWER LIMIT ON SNOW DENSITY -C ---------------------------------------------------------------------- - IF (DSX .GT. 0.40) DSX = 0.40 - IF (DSX .LT. 0.05) DSX = 0.05 - SNDENS = DSX -C ---------------------------------------------------------------------- -C UPDATE OF SNOW DEPTH AND DENSITY DEPENDING ON LIQUID WATER DURING -C SNOWMELT. ASSUMED THAT 13% OF LIQUID WATER CAN BE STORED IN SNOW PER -C DAY DURING SNOWMELT TILL SNOW DENSITY 0.40. -C ---------------------------------------------------------------------- - IF (TSNOWC .GE. 0.) THEN - DW = 0.13*DTHR/24. - SNDENS = SNDENS*(1.-DW)+DW - IF (SNDENS .GT. 0.40) SNDENS = 0.40 - ENDIF - -C ---------------------------------------------------------------------- -C CALCULATE SNOW DEPTH (CM) FROM SNOW WATER EQUIVALENT AND SNOW DENSITY. -C CHANGE SNOW DEPTH UNITS TO METERS -C ---------------------------------------------------------------------- - SNOWHC = ESDC/SNDENS - SNOWH = SNOWHC*0.01 - -C ---------------------------------------------------------------------- -C END SUBROUTINE SNOWPACK -C ---------------------------------------------------------------------- - RETURN - END - SUBROUTINE SNOWZ0 (SNCOVR,Z0) - - IMPLICIT NONE - -C ---------------------------------------------------------------------- -C SUBROUTINE SNOWZ0 -C ---------------------------------------------------------------------- -C CALCULATE TOTAL ROUGHNESS LENGTH OVER SNOW -C SNCOVR FRACTIONAL SNOW COVER -C Z0 ROUGHNESS LENGTH (m) -C Z0S SNOW ROUGHNESS LENGTH:=0.001 (m) -C ---------------------------------------------------------------------- - REAL SNCOVR, Z0, Z0S -c PARAMETER (Z0S=0.001) - -C CURRENT NOAH LSM CONDITION - MBEK, 09-OCT-2001 - Z0S = Z0 -C - Z0 = (1-SNCOVR)*Z0 + SNCOVR*Z0S -C ---------------------------------------------------------------------- -C END SUBROUTINE SNOWZ0 -C ---------------------------------------------------------------------- - RETURN - END - SUBROUTINE SNOW_NEW (TEMP,NEWSN,SNOWH,SNDENS) - - IMPLICIT NONE - -C ---------------------------------------------------------------------- -C SUBROUTINE SNOW_NEW -C ---------------------------------------------------------------------- -C CALCULATE SNOW DEPTH AND DENSITITY TO ACCOUNT FOR THE NEW SNOWFALL. -C NEW VALUES OF SNOW DEPTH & DENSITY RETURNED. -C -C TEMP AIR TEMPERATURE (K) -C NEWSN NEW SNOWFALL (M) -C SNOWH SNOW DEPTH (M) -C SNDENS SNOW DENSITY (G/CM3=DIMENSIONLESS FRACTION OF H2O DENSITY) -C ---------------------------------------------------------------------- - REAL SNDENS - REAL DSNEW - REAL SNOWHC - REAL HNEWC - REAL SNOWH - REAL NEWSN - REAL NEWSNC - REAL TEMP - REAL TEMPC - -C ---------------------------------------------------------------------- -C CONVERSION INTO SIMULATION UNITS -C ---------------------------------------------------------------------- - SNOWHC = SNOWH*100. - NEWSNC = NEWSN*100. - TEMPC = TEMP-273.15 - -C ---------------------------------------------------------------------- -C CALCULATING NEW SNOWFALL DENSITY DEPENDING ON TEMPERATURE -C EQUATION FROM GOTTLIB L. 'A GENERAL RUNOFF MODEL FOR SNOWCOVERED -C AND GLACIERIZED BASIN', 6TH NORDIC HYDROLOGICAL CONFERENCE, -C VEMADOLEN, SWEDEN, 1980, 172-177PP. -C----------------------------------------------------------------------- - IF (TEMPC .LE. -15.) THEN - DSNEW = 0.05 - ELSE - DSNEW = 0.05+0.0017*(TEMPC+15.)**1.5 - ENDIF - -C ---------------------------------------------------------------------- -C ADJUSTMENT OF SNOW DENSITY DEPENDING ON NEW SNOWFALL -C ---------------------------------------------------------------------- - HNEWC = NEWSNC/DSNEW - SNDENS = (SNOWHC*SNDENS+HNEWC*DSNEW)/(SNOWHC+HNEWC) - SNOWHC = SNOWHC+HNEWC - SNOWH = SNOWHC*0.01 - -C ---------------------------------------------------------------------- -C END SUBROUTINE SNOW_NEW -C ---------------------------------------------------------------------- - RETURN - END - SUBROUTINE SRT (RHSTT,EDIR,ET,SH2O,SH2OA,NSOIL,PCPDRP, - & ZSOIL,DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, - & RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZX,SICE,AI,BI,CI) - - IMPLICIT NONE - -C ---------------------------------------------------------------------- -C SUBROUTINE SRT -C ---------------------------------------------------------------------- -C CALCULATE THE RIGHT HAND SIDE OF THE TIME TENDENCY TERM OF THE SOIL -C WATER DIFFUSION EQUATION. ALSO TO COMPUTE ( PREPARE ) THE MATRIX -C COEFFICIENTS FOR THE TRI-DIAGONAL MATRIX OF THE IMPLICIT TIME SCHEME. -C ---------------------------------------------------------------------- - INTEGER NSOLD - PARAMETER(NSOLD = 4) - - INTEGER CVFRZ - INTEGER IALP1 - INTEGER IOHINF - INTEGER J - INTEGER JJ - INTEGER K - INTEGER KS - INTEGER NSOIL - - REAL ACRT - REAL AI(NSOLD) - REAL BEXP - REAL BI(NSOLD) - REAL CI(NSOLD) - REAL DD - REAL DDT - REAL DDZ - REAL DDZ2 - REAL DENOM - REAL DENOM2 - REAL DICE - REAL DKSAT - REAL DMAX(NSOLD) - REAL DSMDZ - REAL DSMDZ2 - REAL DT - REAL DT1 - REAL DWSAT - REAL EDIR - REAL ET(NSOIL) - REAL FCR - REAL FRZX - REAL INFMAX - REAL KDT - REAL MXSMC - REAL MXSMC2 - REAL NUMER - REAL PCPDRP - REAL PDDUM - REAL PX - REAL RHSTT(NSOIL) - REAL RUNOFF1 - REAL RUNOFF2 - REAL SH2O(NSOIL) - REAL SH2OA(NSOIL) - REAL SICE(NSOIL) - REAL SICEMAX - REAL SLOPE - REAL SLOPX - REAL SMCAV - REAL SMCMAX - REAL SMCWLT - REAL SSTT - REAL SUM - REAL VAL - REAL WCND - REAL WCND2 - REAL WDF - REAL WDF2 - REAL ZSOIL(NSOIL) - -C ---------------------------------------------------------------------- -C FROZEN GROUND VERSION: -C REFERENCE FROZEN GROUND PARAMETER, CVFRZ, IS A SHAPE PARAMETER OF -C AREAL DISTRIBUTION FUNCTION OF SOIL ICE CONTENT WHICH EQUALS 1/CV. -C CV IS A COEFFICIENT OF SPATIAL VARIATION OF SOIL ICE CONTENT. BASED -C ON FIELD DATA CV DEPENDS ON AREAL MEAN OF FROZEN DEPTH, AND IT CLOSE -C TO CONSTANT = 0.6 IF AREAL MEAN FROZEN DEPTH IS ABOVE 20 CM. THAT IS -C WHY PARAMETER CVFRZ = 3 (INT{1/0.6*0.6}). -C CURRENT LOGIC DOESN'T ALLOW CVFRZ BE BIGGER THAN 3 -C ---------------------------------------------------------------------- - PARAMETER(CVFRZ = 3) - -C ---------------------------------------------------------------------- -C DETERMINE RAINFALL INFILTRATION RATE AND RUNOFF. INCLUDE THE -C INFILTRATION FORMULE FROM SCHAAKE AND KOREN MODEL. -C MODIFIED BY Q DUAN -C ---------------------------------------------------------------------- - IOHINF=1 - -C ---------------------------------------------------------------------- -C LET SICEMAX BE THE GREATEST, IF ANY, FROZEN WATER CONTENT WITHIN SOIL -C LAYERS. -C ---------------------------------------------------------------------- - SICEMAX = 0.0 - DO KS=1,NSOIL - IF (SICE(KS) .GT. SICEMAX) SICEMAX = SICE(KS) - END DO - -C ---------------------------------------------------------------------- -C DETERMINE RAINFALL INFILTRATION RATE AND RUNOFF -C ---------------------------------------------------------------------- - PDDUM = PCPDRP - RUNOFF1 = 0.0 - IF (PCPDRP .NE. 0.0) THEN - -C ---------------------------------------------------------------------- -C MODIFIED BY Q. DUAN, 5/16/94 -C ---------------------------------------------------------------------- -C IF (IOHINF .EQ. 1) THEN - - DT1 = DT/86400. - SMCAV = SMCMAX - SMCWLT - DMAX(1)=-ZSOIL(1)*SMCAV - -C ---------------------------------------------------------------------- -C FROZEN GROUND VERSION: -C ---------------------------------------------------------------------- - DICE = -ZSOIL(1) * SICE(1) - - DMAX(1)=DMAX(1)*(1.0 - (SH2OA(1)+SICE(1)-SMCWLT)/SMCAV) - DD=DMAX(1) - - DO KS=2,NSOIL - -C ---------------------------------------------------------------------- -C FROZEN GROUND VERSION: -C ---------------------------------------------------------------------- - DICE = DICE + ( ZSOIL(KS-1) - ZSOIL(KS) ) * SICE(KS) - - DMAX(KS) = (ZSOIL(KS-1)-ZSOIL(KS))*SMCAV - DMAX(KS) = DMAX(KS)*(1.0 - (SH2OA(KS)+SICE(KS)-SMCWLT)/SMCAV) - DD = DD+DMAX(KS) - END DO - -C ---------------------------------------------------------------------- -C VAL = (1.-EXP(-KDT*SQRT(DT1))) -C IN BELOW, REMOVE THE SQRT IN ABOVE -C ---------------------------------------------------------------------- - VAL = (1.-EXP(-KDT*DT1)) - DDT = DD*VAL - PX = PCPDRP*DT - IF (PX .LT. 0.0) PX = 0.0 - INFMAX = (PX*(DDT/(PX+DDT)))/DT - -C ---------------------------------------------------------------------- -C FROZEN GROUND VERSION: -C REDUCTION OF INFILTRATION BASED ON FROZEN GROUND PARAMETERS -C ---------------------------------------------------------------------- - FCR = 1. - IF (DICE .GT. 1.E-2) THEN - ACRT = CVFRZ * FRZX / DICE - SUM = 1. - IALP1 = CVFRZ - 1 - DO J = 1,IALP1 - K = 1 - DO JJ = J+1,IALP1 - K = K * JJ - END DO - SUM = SUM + (ACRT ** ( CVFRZ-J)) / FLOAT (K) - END DO - FCR = 1. - EXP(-ACRT) * SUM - ENDIF - INFMAX = INFMAX * FCR - -C ---------------------------------------------------------------------- -C CORRECTION OF INFILTRATION LIMITATION: -C IF INFMAX .LE. HYDROLIC CONDUCTIVITY ASSIGN INFMAX THE VALUE OF -C HYDROLIC CONDUCTIVITY -C ---------------------------------------------------------------------- -C MXSMC = MAX ( SH2OA(1), SH2OA(2) ) - MXSMC = SH2OA(1) - - CALL WDFCND (WDF,WCND,MXSMC,SMCMAX,BEXP,DKSAT,DWSAT, - & SICEMAX) - - INFMAX = MAX(INFMAX,WCND) - INFMAX = MIN(INFMAX,PX) - - IF (PCPDRP .GT. INFMAX) THEN - RUNOFF1 = PCPDRP - INFMAX - PDDUM = INFMAX - ENDIF - - ENDIF - -C ---------------------------------------------------------------------- -C TO AVOID SPURIOUS DRAINAGE BEHAVIOR, 'UPSTREAM DIFFERENCING' IN LINE -C BELOW REPLACED WITH NEW APPROACH IN 2ND LINE: -C 'MXSMC = MAX(SH2OA(1), SH2OA(2))' -C ---------------------------------------------------------------------- - MXSMC = SH2OA(1) - - CALL WDFCND (WDF,WCND,MXSMC,SMCMAX,BEXP,DKSAT,DWSAT, - & SICEMAX) - -C ---------------------------------------------------------------------- -C CALC THE MATRIX COEFFICIENTS AI, BI, AND CI FOR THE TOP LAYER -C ---------------------------------------------------------------------- - DDZ = 1. / ( -.5 * ZSOIL(2) ) - AI(1) = 0.0 - BI(1) = WDF * DDZ / ( -ZSOIL(1) ) - CI(1) = -BI(1) - -C ---------------------------------------------------------------------- -C CALC RHSTT FOR THE TOP LAYER AFTER CALC'NG THE VERTICAL SOIL MOISTURE -C GRADIENT BTWN THE TOP AND NEXT TO TOP LAYERS. -C ---------------------------------------------------------------------- - DSMDZ = ( SH2O(1) - SH2O(2) ) / ( -.5 * ZSOIL(2) ) - RHSTT(1) = (WDF * DSMDZ + WCND - PDDUM + EDIR + ET(1))/ZSOIL(1) - SSTT = WDF * DSMDZ + WCND + EDIR + ET(1) - -C ---------------------------------------------------------------------- -C INITIALIZE DDZ2 -C ---------------------------------------------------------------------- - DDZ2 = 0.0 - -C ---------------------------------------------------------------------- -C LOOP THRU THE REMAINING SOIL LAYERS, REPEATING THE ABV PROCESS -C ---------------------------------------------------------------------- - DO K = 2,NSOIL - DENOM2 = (ZSOIL(K-1) - ZSOIL(K)) - IF (K .NE. NSOIL) THEN - SLOPX = 1. - -C ---------------------------------------------------------------------- -C AGAIN, TO AVOID SPURIOUS DRAINAGE BEHAVIOR, 'UPSTREAM DIFFERENCING' IN -C LINE BELOW REPLACED WITH NEW APPROACH IN 2ND LINE: -C 'MXSMC2 = MAX (SH2OA(K), SH2OA(K+1))' -C ---------------------------------------------------------------------- - MXSMC2 = SH2OA(K) - - CALL WDFCND (WDF2,WCND2,MXSMC2,SMCMAX,BEXP,DKSAT,DWSAT, - & SICEMAX) - -C ---------------------------------------------------------------------- -C CALC SOME PARTIAL PRODUCTS FOR LATER USE IN CALC'NG RHSTT -C ---------------------------------------------------------------------- - DENOM = (ZSOIL(K-1) - ZSOIL(K+1)) - DSMDZ2 = (SH2O(K) - SH2O(K+1)) / (DENOM * 0.5) - -C ---------------------------------------------------------------------- -C CALC THE MATRIX COEF, CI, AFTER CALC'NG ITS PARTIAL PRODUCT -C ---------------------------------------------------------------------- - DDZ2 = 2.0 / DENOM - CI(K) = -WDF2 * DDZ2 / DENOM2 - ELSE - -C ---------------------------------------------------------------------- -C SLOPE OF BOTTOM LAYER IS INTRODUCED -C ---------------------------------------------------------------------- - SLOPX = SLOPE - -C ---------------------------------------------------------------------- -C RETRIEVE THE SOIL WATER DIFFUSIVITY AND HYDRAULIC CONDUCTIVITY FOR -C THIS LAYER -C ---------------------------------------------------------------------- - CALL WDFCND (WDF2,WCND2,SH2OA(NSOIL),SMCMAX,BEXP,DKSAT,DWSAT, - & SICEMAX) - -C ---------------------------------------------------------------------- -C CALC A PARTIAL PRODUCT FOR LATER USE IN CALC'NG RHSTT -C ---------------------------------------------------------------------- - DSMDZ2 = 0.0 - -C ---------------------------------------------------------------------- -C SET MATRIX COEF CI TO ZERO -C ---------------------------------------------------------------------- - CI(K) = 0.0 - ENDIF - -C ---------------------------------------------------------------------- -C CALC RHSTT FOR THIS LAYER AFTER CALC'NG ITS NUMERATOR -C ---------------------------------------------------------------------- - NUMER = (WDF2 * DSMDZ2) + SLOPX * WCND2 - (WDF * DSMDZ) - & - WCND + ET(K) - RHSTT(K) = NUMER / (-DENOM2) - -C ---------------------------------------------------------------------- -C CALC MATRIX COEFS, AI, AND BI FOR THIS LAYER -C ---------------------------------------------------------------------- - AI(K) = -WDF * DDZ / DENOM2 - BI(K) = -( AI(K) + CI(K) ) - -C ---------------------------------------------------------------------- -C RESET VALUES OF WDF, WCND, DSMDZ, AND DDZ FOR LOOP TO NEXT LYR -C RUNOFF2: SUB-SURFACE OR BASEFLOW RUNOFF -C ---------------------------------------------------------------------- - IF (K .EQ. NSOIL) THEN - RUNOFF2 = SLOPX * WCND2 - ENDIF - - IF (K .NE. NSOIL) THEN - WDF = WDF2 - WCND = WCND2 - DSMDZ = DSMDZ2 - DDZ = DDZ2 - ENDIF - END DO - -C ---------------------------------------------------------------------- -C END SUBROUTINE SRT -C ---------------------------------------------------------------------- - RETURN - END - SUBROUTINE SSTEP (SH2OOUT,SH2OIN,CMC,RHSTT,RHSCT,DT, - & NSOIL,SMCMAX,CMCMAX,RUNOFF3,ZSOIL,SMC,SICE, - & AI,BI,CI) - - IMPLICIT NONE - -C ---------------------------------------------------------------------- -C SUBROUTINE SSTEP -C ---------------------------------------------------------------------- -C CALCULATE/UPDATE SOIL MOISTURE CONTENT VALUES AND CANOPY MOISTURE -C CONTENT VALUES. -C ---------------------------------------------------------------------- - INTEGER NSOLD - PARAMETER(NSOLD = 4) - - INTEGER I - INTEGER K - INTEGER KK11 - INTEGER NSOIL - - REAL AI(NSOLD) - REAL BI(NSOLD) - REAL CI(NSOLD) - REAL CIin(NSOLD) - REAL CMC - REAL CMCMAX - REAL DDZ - REAL DT - REAL RHSCT - REAL RHSTT(NSOIL) - REAL RHSTTin(NSOIL) - REAL RUNOFF3 - REAL SH2OIN(NSOIL) - REAL SH2OOUT(NSOIL) - REAL SICE(NSOIL) - REAL SMC(NSOIL) - REAL SMCMAX - REAL STOT - REAL WPLUS - REAL ZSOIL(NSOIL) - -C ---------------------------------------------------------------------- -C CREATE 'AMOUNT' VALUES OF VARIABLES TO BE INPUT TO THE -C TRI-DIAGONAL MATRIX ROUTINE. -C ---------------------------------------------------------------------- - DO K = 1,NSOIL - RHSTT(K) = RHSTT(K) * DT - AI(K) = AI(K) * DT - BI(K) = 1. + BI(K) * DT - CI(K) = CI(K) * DT - END DO - -C ---------------------------------------------------------------------- -C COPY VALUES FOR INPUT VARIABLES BEFORE CALL TO ROSR12 -C ---------------------------------------------------------------------- - DO K = 1,NSOIL - RHSTTin(K) = RHSTT(K) - END DO - DO K = 1,NSOLD - CIin(K) = CI(K) - END DO - -C ---------------------------------------------------------------------- -C CALL ROSR12 TO SOLVE THE TRI-DIAGONAL MATRIX -C ---------------------------------------------------------------------- - CALL ROSR12 (CI,AI,BI,CIin,RHSTTin,RHSTT,NSOIL) - -C ---------------------------------------------------------------------- -C SUM THE PREVIOUS SMC VALUE AND THE MATRIX SOLUTION TO GET A -C NEW VALUE. MIN ALLOWABLE VALUE OF SMC WILL BE 0.02. -C RUNOFF3: RUNOFF WITHIN SOIL LAYERS -C ---------------------------------------------------------------------- - WPLUS = 0.0 - RUNOFF3 = 0. - DDZ = -ZSOIL(1) - - DO K = 1,NSOIL - IF (K .NE. 1) DDZ = ZSOIL(K - 1) - ZSOIL(K) - SH2OOUT(K) = SH2OIN(K) + CI(K) + WPLUS / DDZ - - STOT = SH2OOUT(K) + SICE(K) - IF (STOT .GT. SMCMAX) THEN - IF (K .EQ. 1) THEN - DDZ = -ZSOIL(1) - ELSE - KK11 = K - 1 - DDZ = -ZSOIL(K) + ZSOIL(KK11) - ENDIF - WPLUS = (STOT-SMCMAX) * DDZ - ELSE - WPLUS = 0. - ENDIF - SMC(K) = MAX ( MIN(STOT,SMCMAX),0.02 ) - SH2OOUT(K) = MAX((SMC(K)-SICE(K)),0.0) - END DO - - RUNOFF3 = WPLUS - -C ---------------------------------------------------------------------- -C UPDATE CANOPY WATER CONTENT/INTERCEPTION (CMC). CONVERT RHSCT TO -C AN 'AMOUNT' VALUE AND ADD TO PREVIOUS CMC VALUE TO GET NEW CMC. -C ---------------------------------------------------------------------- - CMC = CMC + DT * RHSCT - IF (CMC .LT. 1.E-20) CMC=0.0 - CMC = MIN(CMC,CMCMAX) - -C ---------------------------------------------------------------------- -C END SUBROUTINE SSTEP -C ---------------------------------------------------------------------- - RETURN - END - SUBROUTINE TBND (TU,TB,ZSOIL,ZBOT,K,NSOIL,TBND1) - - IMPLICIT NONE - -C ---------------------------------------------------------------------- -C SUBROUTINE TBND -C ---------------------------------------------------------------------- -C CALCULATE TEMPERATURE ON THE BOUNDARY OF THE LAYER BY INTERPOLATION OF -C THE MIDDLE LAYER TEMPERATURES -C ---------------------------------------------------------------------- - INTEGER NSOIL - INTEGER K - - REAL TBND1 - REAL T0 - REAL TU - REAL TB - REAL ZB - REAL ZBOT - REAL ZUP - REAL ZSOIL (NSOIL) - - PARAMETER(T0 = 273.15) - -C ---------------------------------------------------------------------- -C USE SURFACE TEMPERATURE ON THE TOP OF THE FIRST LAYER -C ---------------------------------------------------------------------- - IF (K .EQ. 1) THEN - ZUP = 0. - ELSE - ZUP = ZSOIL(K-1) - ENDIF - -C ---------------------------------------------------------------------- -C USE DEPTH OF THE CONSTANT BOTTOM TEMPERATURE WHEN INTERPOLATE -C TEMPERATURE INTO THE LAST LAYER BOUNDARY -C ---------------------------------------------------------------------- - IF (K .EQ. NSOIL) THEN - ZB = 2.*ZBOT-ZSOIL(K) - ELSE - ZB = ZSOIL(K+1) - ENDIF - -C ---------------------------------------------------------------------- -C LINEAR INTERPOLATION BETWEEN THE AVERAGE LAYER TEMPERATURES -C ---------------------------------------------------------------------- - TBND1 = TU+(TB-TU)*(ZUP-ZSOIL(K))/(ZUP-ZB) - -C ---------------------------------------------------------------------- -C END SUBROUTINE TBND -C ---------------------------------------------------------------------- - RETURN - END - SUBROUTINE TDFCND ( DF, SMC, QZ, SMCMAX, SH2O) - - IMPLICIT NONE - -C ---------------------------------------------------------------------- -C SUBROUTINE TDFCND -C ---------------------------------------------------------------------- -C CALCULATE THERMAL DIFFUSIVITY AND CONDUCTIVITY OF THE SOIL FOR A GIVEN -C POINT AND TIME. -C ---------------------------------------------------------------------- -C PETERS-LIDARD APPROACH (PETERS-LIDARD et al., 1998) -C June 2001 CHANGES: FROZEN SOIL CONDITION. -C ---------------------------------------------------------------------- - REAL DF - REAL GAMMD - REAL THKDRY - REAL AKE - REAL THKICE - REAL THKO - REAL THKQTZ - REAL THKSAT - REAL THKS - REAL THKW - REAL QZ - REAL SATRATIO - REAL SH2O - REAL SMC - REAL SMCMAX - REAL XU - REAL XUNFROZ - -C ---------------------------------------------------------------------- -C WE NOW GET QUARTZ AS AN INPUT ARGUMENT (SET IN ROUTINE REDPRM): -C DATA QUARTZ /0.82, 0.10, 0.25, 0.60, 0.52, -C & 0.35, 0.60, 0.40, 0.82/ -C ---------------------------------------------------------------------- -C IF THE SOIL HAS ANY MOISTURE CONTENT COMPUTE A PARTIAL SUM/PRODUCT -C OTHERWISE USE A CONSTANT VALUE WHICH WORKS WELL WITH MOST SOILS -C ---------------------------------------------------------------------- -C THKW ......WATER THERMAL CONDUCTIVITY -C THKQTZ ....THERMAL CONDUCTIVITY FOR QUARTZ -C THKO ......THERMAL CONDUCTIVITY FOR OTHER SOIL COMPONENTS -C THKS ......THERMAL CONDUCTIVITY FOR THE SOLIDS COMBINED(QUARTZ+OTHER) -C THKICE ....ICE THERMAL CONDUCTIVITY -C SMCMAX ....POROSITY (= SMCMAX) -C QZ .........QUARTZ CONTENT (SOIL TYPE DEPENDENT) -C ---------------------------------------------------------------------- -C USE AS IN PETERS-LIDARD, 1998 (MODIF. FROM JOHANSEN, 1975). -C -C PABLO GRUNMANN, 08/17/98 -C REFS.: -C FAROUKI, O.T.,1986: THERMAL PROPERTIES OF SOILS. SERIES ON ROCK -C AND SOIL MECHANICS, VOL. 11, TRANS TECH, 136 PP. -C JOHANSEN, O., 1975: THERMAL CONDUCTIVITY OF SOILS. PH.D. THESIS, -C UNIVERSITY OF TRONDHEIM, -C PETERS-LIDARD, C. D., ET AL., 1998: THE EFFECT OF SOIL THERMAL -C CONDUCTIVITY PARAMETERIZATION ON SURFACE ENERGY FLUXES -C AND TEMPERATURES. JOURNAL OF THE ATMOSPHERIC SCIENCES, -C VOL. 55, PP. 1209-1224. -C ---------------------------------------------------------------------- -C NEEDS PARAMETERS -C POROSITY(SOIL TYPE): -C POROS = SMCMAX -C SATURATION RATIO: - SATRATIO = SMC/SMCMAX - -C PARAMETERS W/(M.K) - THKICE = 2.2 - THKW = 0.57 - THKO = 2.0 -C IF (QZ .LE. 0.2) THKO = 3.0 - THKQTZ = 7.7 -C SOLIDS' CONDUCTIVITY - THKS = (THKQTZ**QZ)*(THKO**(1.- QZ)) - -C UNFROZEN FRACTION (FROM 1., i.e., 100%LIQUID, TO 0. (100% FROZEN)) - XUNFROZ = (SH2O + 1.E-9) / (SMC + 1.E-9) - -C UNFROZEN VOLUME FOR SATURATION (POROSITY*XUNFROZ) - XU=XUNFROZ*SMCMAX -C SATURATED THERMAL CONDUCTIVITY - THKSAT = THKS**(1.-SMCMAX)*THKICE**(SMCMAX-XU)*THKW**(XU) - -C DRY DENSITY IN KG/M3 - GAMMD = (1. - SMCMAX)*2700. - -C DRY THERMAL CONDUCTIVITY IN W.M-1.K-1 - THKDRY = (0.135*GAMMD + 64.7)/(2700. - 0.947*GAMMD) - - IF ( (SH2O + 0.0005) .LT. SMC ) THEN -C FROZEN - AKE = SATRATIO - ELSE -C UNFROZEN -C RANGE OF VALIDITY FOR THE KERSTEN NUMBER (AKE) - IF ( SATRATIO .GT. 0.1 ) THEN - -C KERSTEN NUMBER (USING "FINE" FORMULA, VALID FOR SOILS CONTAINING AT -C LEAST 5% OF PARTICLES WITH DIAMETER LESS THAN 2.E-6 METERS.) -C (FOR "COARSE" FORMULA, SEE PETERS-LIDARD ET AL., 1998). - - AKE = LOG10(SATRATIO) + 1.0 - - ELSE - -C USE K = KDRY - AKE = 0.0 - - ENDIF - ENDIF - -C THERMAL CONDUCTIVITY - - DF = AKE*(THKSAT - THKDRY) + THKDRY - -C ---------------------------------------------------------------------- -C END SUBROUTINE TDFCND -C ---------------------------------------------------------------------- - RETURN - END - SUBROUTINE TMPAVG (TAVG,TUP,TM,TDN,ZSOIL,NSOIL,K) - - IMPLICIT NONE - -C ---------------------------------------------------------------------- -C SUBROUTINE TMPAVG -C ---------------------------------------------------------------------- -C CALCULATE SOIL LAYER AVERAGE TEMPERATURE (TAVG) IN FREEZING/THAWING -C LAYER USING UP, DOWN, AND MIDDLE LAYER TEMPERATURES (TUP, TDN, TM), -C WHERE TUP IS AT TOP BOUNDARY OF LAYER, TDN IS AT BOTTOM BOUNDARY OF -C LAYER. TM IS LAYER PROGNOSTIC STATE TEMPERATURE. -C ---------------------------------------------------------------------- - INTEGER K - INTEGER NSOIL - - REAL DZ - REAL DZH - REAL T0 - REAL TAVG - REAL TDN - REAL TM - REAL TUP - REAL X0 - REAL XDN - REAL XUP - REAL ZSOIL (NSOIL) - - PARAMETER(T0 = 2.7315E2) - -C ---------------------------------------------------------------------- - IF (K .EQ. 1) THEN - DZ = -ZSOIL(1) - ELSE - DZ = ZSOIL(K-1)-ZSOIL(K) - ENDIF - - DZH=DZ*0.5 - - IF (TUP .LT. T0) THEN - IF (TM .LT. T0) THEN - IF (TDN .LT. T0) THEN -C ---------------------------------------------------------------------- -C TUP, TM, TDN < T0 -C ---------------------------------------------------------------------- - TAVG = (TUP + 2.0*TM + TDN)/ 4.0 - ELSE -C ---------------------------------------------------------------------- -C TUP & TM < T0, TDN >= T0 -C ---------------------------------------------------------------------- - X0 = (T0 - TM) * DZH / (TDN - TM) - TAVG = 0.5 * (TUP*DZH+TM*(DZH+X0)+T0*(2.*DZH-X0)) / DZ - ENDIF - ELSE - IF (TDN .LT. T0) THEN -C ---------------------------------------------------------------------- -C TUP < T0, TM >= T0, TDN < T0 -C ---------------------------------------------------------------------- - XUP = (T0-TUP) * DZH / (TM-TUP) - XDN = DZH - (T0-TM) * DZH / (TDN-TM) - TAVG = 0.5 * (TUP*XUP+T0*(2.*DZ-XUP-XDN)+TDN*XDN) / DZ - ELSE -C ---------------------------------------------------------------------- -C TUP < T0, TM >= T0, TDN >= T0 -C ---------------------------------------------------------------------- - XUP = (T0-TUP) * DZH / (TM-TUP) - TAVG = 0.5 * (TUP*XUP+T0*(2.*DZ-XUP)) / DZ - ENDIF - ENDIF - ELSE - IF (TM .LT. T0) THEN - IF (TDN .LT. T0) THEN -C ---------------------------------------------------------------------- -C TUP >= T0, TM < T0, TDN < T0 -C ---------------------------------------------------------------------- - XUP = DZH - (T0-TUP) * DZH / (TM-TUP) - TAVG = 0.5 * (T0*(DZ-XUP)+TM*(DZH+XUP)+TDN*DZH) / DZ - ELSE -C ---------------------------------------------------------------------- -C TUP >= T0, TM < T0, TDN >= T0 -C ---------------------------------------------------------------------- - XUP = DZH - (T0-TUP) * DZH / (TM-TUP) - XDN = (T0-TM) * DZH / (TDN-TM) - TAVG = 0.5 * (T0*(2.*DZ-XUP-XDN)+TM*(XUP+XDN)) / DZ - ENDIF - ELSE - IF (TDN .LT. T0) THEN -C ---------------------------------------------------------------------- -C TUP >= T0, TM >= T0, TDN < T0 -C ---------------------------------------------------------------------- - XDN = DZH - (T0-TM) * DZH / (TDN-TM) - TAVG = (T0*(DZ-XDN)+0.5*(T0+TDN)*XDN) / DZ - ELSE -C ---------------------------------------------------------------------- -C TUP >= T0, TM >= T0, TDN >= T0 -C ---------------------------------------------------------------------- - TAVG = (TUP + 2.0*TM + TDN) / 4.0 - ENDIF - ENDIF - ENDIF -C ---------------------------------------------------------------------- -C END SUBROUTINE TMPAVG -C ---------------------------------------------------------------------- - RETURN - END - SUBROUTINE TRANSP (ET1,NSOIL,ETP1,SMC,CMC,ZSOIL,SHDFAC,SMCWLT, - & CMCMAX,PC,CFACTR,SMCREF,SFCTMP,Q2,NROOT,RTDIS) - - IMPLICIT NONE - -C ---------------------------------------------------------------------- -C SUBROUTINE TRANSP -C ---------------------------------------------------------------------- -C CALCULATE TRANSPIRATION FOR THE VEG CLASS. -C ---------------------------------------------------------------------- - INTEGER I - INTEGER K - INTEGER NSOIL - INTEGER NROOT - - REAL CFACTR - REAL CMC - REAL CMCMAX - REAL DENOM - REAL ET1(NSOIL) - REAL ETP1 - REAL ETP1A - REAL GX (7) -C.....REAL PART(NSOIL) - REAL PC - REAL Q2 - REAL RTDIS(NSOIL) - REAL RTX - REAL SFCTMP - REAL SGX - REAL SHDFAC - REAL SMC(NSOIL) - REAL SMCREF - REAL SMCWLT - REAL ZSOIL(NSOIL) - -C ---------------------------------------------------------------------- -C INITIALIZE PLANT TRANSP TO ZERO FOR ALL SOIL LAYERS. -C ---------------------------------------------------------------------- - DO K = 1,NSOIL - ET1(K) = 0. - END DO - -C ---------------------------------------------------------------------- -C CALCULATE AN 'ADJUSTED' POTENTIAL TRANSPIRATION -C IF STATEMENT BELOW TO AVOID TANGENT LINEAR PROBLEMS NEAR ZERO -C NOTE: GX AND OTHER TERMS BELOW REDISTRIBUTE TRANSPIRATION BY LAYER, -C ET(K), AS A FUNCTION OF SOIL MOISTURE AVAILABILITY, WHILE PRESERVING -C TOTAL ETP1A. -C ---------------------------------------------------------------------- - IF (CMC .NE. 0.0) THEN - ETP1A = SHDFAC * PC * ETP1 * (1.0 - (CMC /CMCMAX) ** CFACTR) - ELSE - ETP1A = SHDFAC * PC * ETP1 - ENDIF - - SGX = 0.0 - DO I = 1,NROOT - GX(I) = ( SMC(I) - SMCWLT ) / ( SMCREF - SMCWLT ) - GX(I) = MAX ( MIN ( GX(I), 1. ), 0. ) - SGX = SGX + GX (I) - END DO - SGX = SGX / NROOT - - DENOM = 0. - DO I = 1,NROOT - RTX = RTDIS(I) + GX(I) - SGX - GX(I) = GX(I) * MAX ( RTX, 0. ) - DENOM = DENOM + GX(I) - END DO - IF (DENOM .LE. 0.0) DENOM = 1. - - DO I = 1,NROOT - ET1(I) = ETP1A * GX(I) / DENOM - END DO - -C ---------------------------------------------------------------------- -C ABOVE CODE ASSUMES A VERTICALLY UNIFORM ROOT DISTRIBUTION -C CODE BELOW TESTS A VARIABLE ROOT DISTRIBUTION -C ---------------------------------------------------------------------- -C ET(1) = ( ZSOIL(1) / ZSOIL(NROOT) ) * GX * ETP1A -C ET(1) = ( ZSOIL(1) / ZSOIL(NROOT) ) * ETP1A -C ---------------------------------------------------------------------- -C USING ROOT DISTRIBUTION AS WEIGHTING FACTOR -C ---------------------------------------------------------------------- -C ET(1) = RTDIS(1) * ETP1A -C ET(1) = ETP1A * PART(1) -C ---------------------------------------------------------------------- -C LOOP DOWN THRU THE SOIL LAYERS REPEATING THE OPERATION ABOVE, -C BUT USING THE THICKNESS OF THE SOIL LAYER (RATHER THAN THE -C ABSOLUTE DEPTH OF EACH LAYER) IN THE FINAL CALCULATION. -C ---------------------------------------------------------------------- -C DO K = 2,NROOT -C GX = ( SMC(K) - SMCWLT ) / ( SMCREF - SMCWLT ) -C GX = MAX ( MIN ( GX, 1. ), 0. ) -C TEST CANOPY RESISTANCE -C GX = 1.0 -C ET(K) = ((ZSOIL(K)-ZSOIL(K-1))/ZSOIL(NROOT))*GX*ETP1A -C ET(K) = ((ZSOIL(K)-ZSOIL(K-1))/ZSOIL(NROOT))*ETP1A -C ---------------------------------------------------------------------- -C USING ROOT DISTRIBUTION AS WEIGHTING FACTOR -C ---------------------------------------------------------------------- -C ET(K) = RTDIS(K) * ETP1A -C ET(K) = ETP1A*PART(K) -C END DO -C ---------------------------------------------------------------------- -C END SUBROUTINE TRANSP -C ---------------------------------------------------------------------- - RETURN - END - SUBROUTINE WDFCND (WDF,WCND,SMC,SMCMAX,BEXP,DKSAT,DWSAT, - & SICEMAX) - - IMPLICIT NONE - -C ---------------------------------------------------------------------- -C SUBROUTINE WDFCND -C ---------------------------------------------------------------------- -C CALCULATE SOIL WATER DIFFUSIVITY AND SOIL HYDRAULIC CONDUCTIVITY. -C ---------------------------------------------------------------------- - REAL BEXP - REAL DKSAT - REAL DWSAT - REAL EXPON - REAL FACTR1 - REAL FACTR2 - REAL SICEMAX - REAL SMC - REAL SMCMAX - REAL VKwgt - REAL WCND - REAL WDF - -C ---------------------------------------------------------------------- -C CALC THE RATIO OF THE ACTUAL TO THE MAX PSBL SOIL H2O CONTENT -C ---------------------------------------------------------------------- - SMC = SMC - SMCMAX = SMCMAX - FACTR1 = 0.2 / SMCMAX - FACTR2 = SMC / SMCMAX - -C ---------------------------------------------------------------------- -C PREP AN EXPNTL COEF AND CALC THE SOIL WATER DIFFUSIVITY -C ---------------------------------------------------------------------- - EXPON = BEXP + 2.0 - WDF = DWSAT * FACTR2 ** EXPON - -C ---------------------------------------------------------------------- -C FROZEN SOIL HYDRAULIC DIFFUSIVITY. VERY SENSITIVE TO THE VERTICAL -C GRADIENT OF UNFROZEN WATER. THE LATTER GRADIENT CAN BECOME VERY -C EXTREME IN FREEZING/THAWING SITUATIONS, AND GIVEN THE RELATIVELY -C FEW AND THICK SOIL LAYERS, THIS GRADIENT SUFFERES SERIOUS -C TRUNCTION ERRORS YIELDING ERRONEOUSLY HIGH VERTICAL TRANSPORTS OF -C UNFROZEN WATER IN BOTH DIRECTIONS FROM HUGE HYDRAULIC DIFFUSIVITY. -C THEREFORE, WE FOUND WE HAD TO ARBITRARILY CONSTRAIN WDF -C -- -C VERSION D_10CM: ........ FACTR1 = 0.2/SMCMAX -C WEIGHTED APPROACH...................... PABLO GRUNMANN, 28_SEP_1999. -C ---------------------------------------------------------------------- - IF (SICEMAX .GT. 0.0) THEN - VKWGT = 1./(1.+(500.*SICEMAX)**3.) - WDF = VKWGT*WDF + (1.- VKWGT)*DWSAT*FACTR1**EXPON - ENDIF - -C ---------------------------------------------------------------------- -C RESET THE EXPNTL COEF AND CALC THE HYDRAULIC CONDUCTIVITY -C ---------------------------------------------------------------------- - EXPON = (2.0 * BEXP) + 3.0 - WCND = DKSAT * FACTR2 ** EXPON - -C ---------------------------------------------------------------------- -C END SUBROUTINE WDFCND -C ---------------------------------------------------------------------- - RETURN - END diff --git a/src/fim/FIMsrc/fim/column/shalcnv_v.f b/src/fim/FIMsrc/fim/column/shalcnv_v.f deleted file mode 100755 index 9e67427..0000000 --- a/src/fim/FIMsrc/fim/column/shalcnv_v.f +++ /dev/null @@ -1,1112 +0,0 @@ - subroutine shalcnv(im,ix,km,jcap,delt,del,prsl,ps,phil,ql, - & q1,t1,u1,v1,rcs,rn,kbot,ktop,kcnv,slimsk, - & dot,ncloud,hpbl,heat,evap,ud_mf,dt_mf) -! & dot,ncloud,hpbl,heat,evap,ud_mf,dt_mf,me) -! - use machine , only : kind_phys - use funcphys , only : fpvs - use physcons, grav => con_g, cp => con_cp, hvap => con_hvap - &, rv => con_rv, fv => con_fvirt, t0c => con_t0c - &, rd => con_rd, cvap => con_cvap, cliq => con_cliq - &, eps => con_eps, epsm1 => con_epsm1 - implicit none -! - integer im, ix, km, jcap, ncloud, - & kbot(im), ktop(im), kcnv(im) -! &, me - real(kind=kind_phys) delt - real(kind=kind_phys) ps(im), del(ix,km), prsl(ix,km), - & ql(ix,km,2),q1(ix,km), t1(ix,km), - & u1(ix,km), v1(ix,km), rcs(im), - & rn(im), slimsk(im), - & dot(ix,km), phil(ix,km), hpbl(im), - & heat(im), evap(im) -! hchuang code change mass flux output - &, ud_mf(im,km),dt_mf(im,km) -! - integer i,j,indx, jmn, k, kk, latd, lond, km1 - integer kpbl(im) -! - real(kind=kind_phys) c0, cpoel, dellat, delta, - & desdt, deta, detad, dg, - & dh, dhh, dlnsig, dp, - & dq, dqsdp, dqsdt, dt, - & dt2, dtmax, dtmin, dv1h, - & dv1q, dv2h, dv2q, dv1u, - & dv1v, dv2u, dv2v, dv3q, - & dv3h, dv3u, dv3v, clam, - & dz, dz1, e1, dzmax, - & el2orc, elocp, aafac, - & es, etah, h1, dthk, - & evef, evfact, evfactl, fact1, - & fact2, factor, fjcap, - & g, gamma, pprime, betaw, - & qlk, qrch, qs, c1, - & rain, rfact, shear, tem1, - & tem2, terr, val, val1, - & val2, w1, w1l, w1s, - & w2, w2l, w2s, w3, - & w3l, w3s, w4, w4l, - & w4s, tem, ptem, ptem1, - & pgcon -! - integer kb(im), kbcon(im), kbcon1(im), - & ktcon(im), ktcon1(im), - & kbm(im), kmax(im) -! - real(kind=kind_phys) aa1(im), - & delhbar(im), delq(im), delq2(im), - & delqbar(im), delqev(im), deltbar(im), - & deltv(im), edt(im), - & wstar(im), sflx(im), - & pdot(im), po(im,km), - & qcond(im), qevap(im), hmax(im), - & rntot(im), vshear(im), - & xlamud(im), xmb(im), xmbmax(im), - & delubar(im), delvbar(im) -c - real(kind=kind_phys) cincr, cincrmax, cincrmin -cc -c physical parameters - parameter(g=grav) - parameter(cpoel=cp/hvap,elocp=hvap/cp, - & el2orc=hvap*hvap/(rv*cp)) - parameter(terr=0.,c0=.002,c1=5.e-4,delta=fv) - parameter(fact1=(cvap-cliq)/rv,fact2=hvap/rv-fact1*t0c) - parameter(cincrmax=180.,cincrmin=120.,dthk=25.) - parameter(h1=0.33333333) -c local variables and arrays - real(kind=kind_phys) pfld(im,km), to(im,km), qo(im,km), - & uo(im,km), vo(im,km), qeso(im,km) -c cloud water -! real(kind=kind_phys) qlko_ktcon(im), dellal(im,km), tvo(im,km), - real(kind=kind_phys) qlko_ktcon(im), dellal(im,km), - & dbyo(im,km), zo(im,km), xlamue(im,km), - & heo(im,km), heso(im,km), - & dellah(im,km), dellaq(im,km), - & dellau(im,km), dellav(im,km), hcko(im,km), - & ucko(im,km), vcko(im,km), qcko(im,km), - & eta(im,km), zi(im,km), pwo(im,km), - & tx1(im) -! - logical totflg, cnvflg(im), flg(im) -! - real(kind=kind_phys) tf, tcr, tcrf - parameter (tf=233.16, tcr=263.16, tcrf=1.0/(tcr-tf)) -! -c----------------------------------------------------------------------- -! - km1 = km - 1 - dzmax = 0.0 -c -c compute surface buoyancy flux -c - do i=1,im - sflx(i) = heat(i)+fv*t1(i,1)*evap(i) - enddo -c -c initialize arrays -c - do i=1,im - cnvflg(i) = .true. - if(kcnv(i).eq.1) cnvflg(i) = .false. - if(sflx(i).le.0.) cnvflg(i) = .false. - if(cnvflg(i)) then - kbot(i)=km+1 - ktop(i)=0 - endif - rn(i)=0. - kbcon(i)=km - ktcon(i)=1 - kb(i)=km - pdot(i) = 0. - qlko_ktcon(i) = 0. - edt(i) = 0. - aa1(i) = 0. - vshear(i) = 0. - enddo -! hchuang code change - do k = 1, km - do i = 1, im - ud_mf(i,k) = 0. - dt_mf(i,k) = 0. - enddo - enddo -!! - totflg = .true. - do i=1,im - totflg = totflg .and. (.not. cnvflg(i)) - enddo - if(totflg) return -!! -c - dt2 = delt - val = 1200. - dtmin = max(dt2, val ) - val = 3600. - dtmax = max(dt2, val ) -c model tunable parameters are all here - clam = .3 - aafac = .1 - betaw = .03 -c evef = 0.07 - evfact = 0.3 - evfactl = 0.3 -! -! pgcon = 0.7 ! Gregory et al. (1997, QJRMS) - pgcon = 0.55 ! Zhang & Wu (2003,JAS) - fjcap = (float(jcap) / 126.) ** 2 - val = 1. - fjcap = max(fjcap,val) - w1l = -8.e-3 - w2l = -4.e-2 - w3l = -5.e-3 - w4l = -5.e-4 - w1s = -2.e-4 - w2s = -2.e-3 - w3s = -1.e-3 - w4s = -2.e-5 -c -c define top layer for search of the downdraft originating layer -c and the maximum thetae for updraft -c - do i=1,im - kbm(i) = km - kmax(i) = km - tx1(i) = 1.0 / ps(i) - enddo -! - do k = 1, km - do i=1,im - if (prsl(i,k)*tx1(i) .gt. 0.70) kbm(i) = k + 1 - if (prsl(i,k)*tx1(i) .gt. 0.60) kmax(i) = k + 1 -!jbao if (prsl(i,k)*tx1(i) .gt. 0.90) kbm(i) = k + 1 -!jbao if (prsl(i,k)*tx1(i) .gt. 0.60) kmax(i) = k + 1 - enddo - enddo - do i=1,im - kbm(i) = min(kbm(i),kmax(i)) - enddo -c -c hydrostatic height assume zero terr and compute -c updraft entrainment rate as an inverse function of height -c - do k = 1, km - do i=1,im - zo(i,k) = phil(i,k) / g - enddo - enddo - do k = 1, km1 - do i=1,im - zi(i,k) = 0.5*(zo(i,k)+zo(i,k+1)) - xlamue(i,k) = clam / zi(i,k) - enddo - enddo - do i=1,im - xlamue(i,km) = xlamue(i,km1) - enddo -c -c pbl height -c - do i=1,im - flg(i) = cnvflg(i) - kpbl(i)= 1 - enddo - do k = 2, km1 - do i=1,im - if (flg(i).and.zo(i,k).le.hpbl(i)) then - kpbl(i) = k - else - flg(i) = .false. - endif - enddo - enddo - do i=1,im - kpbl(i)= min(kpbl(i),kbm(i)) - enddo -c -c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -c convert surface pressure to mb from cb -c - do k = 1, km - do i = 1, im - if (cnvflg(i) .and. k .le. kmax(i)) then - pfld(i,k) = prsl(i,k) * 10.0 - eta(i,k) = 1. - hcko(i,k) = 0. - qcko(i,k) = 0. - ucko(i,k) = 0. - vcko(i,k) = 0. - dbyo(i,k) = 0. - pwo(i,k) = 0. - dellal(i,k) = 0. - to(i,k) = t1(i,k) - qo(i,k) = q1(i,k) - uo(i,k) = u1(i,k) * rcs(i) - vo(i,k) = v1(i,k) * rcs(i) - endif - enddo - enddo -c -c column variables -c p is pressure of the layer (mb) -c t is temperature at t-dt (k)..tn -c q is mixing ratio at t-dt (kg/kg)..qn -c to is temperature at t+dt (k)... this is after advection and turbulan -c qo is mixing ratio at t+dt (kg/kg)..q1 -c - do k = 1, km - do i=1,im - if (cnvflg(i) .and. k .le. kmax(i)) then - qeso(i,k) = 0.01 * fpvs(to(i,k)) ! fpvs is in pa - qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k)) - val1 = 1.e-8 - qeso(i,k) = max(qeso(i,k), val1) - val2 = 1.e-10 - qo(i,k) = max(qo(i,k), val2 ) -! qo(i,k) = min(qo(i,k),qeso(i,k)) -! tvo(i,k) = to(i,k) + delta * to(i,k) * qo(i,k) - endif - enddo - enddo -c -c compute moist static energy -c - do k = 1, km - do i=1,im - if (cnvflg(i) .and. k .le. kmax(i)) then -! tem = g * zo(i,k) + cp * to(i,k) - tem = phil(i,k) + cp * to(i,k) - heo(i,k) = tem + hvap * qo(i,k) - heso(i,k) = tem + hvap * qeso(i,k) -c heo(i,k) = min(heo(i,k),heso(i,k)) - endif - enddo - enddo -c -c determine level with largest moist static energy within pbl -c this is the level where updraft starts -c - do i=1,im - if (cnvflg(i)) then - hmax(i) = heo(i,1) - kb(i) = 1 - endif - enddo - do k = 2, km - do i=1,im - if (cnvflg(i).and.k.le.kpbl(i)) then - if(heo(i,k).gt.hmax(i)) then - kb(i) = k - hmax(i) = heo(i,k) - endif - endif - enddo - enddo -c - do k = 1, km1 - do i=1,im - if (cnvflg(i) .and. k .le. kmax(i)-1) then - dz = .5 * (zo(i,k+1) - zo(i,k)) - dzmax = max(dzmax, dz) - dp = .5 * (pfld(i,k+1) - pfld(i,k)) - es = 0.01 * fpvs(to(i,k+1)) ! fpvs is in pa - pprime = pfld(i,k+1) + epsm1 * es - qs = eps * es / pprime - dqsdp = - qs / pprime - desdt = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2)) - dqsdt = qs * pfld(i,k+1) * desdt / (es * pprime) - gamma = el2orc * qeso(i,k+1) / (to(i,k+1)**2) - dt = (g * dz + hvap * dqsdp * dp) / (cp * (1. + gamma)) - dq = dqsdt * dt + dqsdp * dp - to(i,k) = to(i,k+1) + dt - qo(i,k) = qo(i,k+1) + dq - po(i,k) = .5 * (pfld(i,k) + pfld(i,k+1)) - endif - enddo - enddo -! - do k = 1, km1 - do i=1,im - if (cnvflg(i) .and. k .le. kmax(i)-1) then - qeso(i,k) = 0.01 * fpvs(to(i,k)) ! fpvs is in pa - qeso(i,k) = eps * qeso(i,k) / (po(i,k) + epsm1*qeso(i,k)) - val1 = 1.e-8 - qeso(i,k) = max(qeso(i,k), val1) - val2 = 1.e-10 - qo(i,k) = max(qo(i,k), val2 ) -! qo(i,k) = min(qo(i,k),qeso(i,k)) - heo(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) + - & cp * to(i,k) + hvap * qo(i,k) - heso(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) + - & cp * to(i,k) + hvap * qeso(i,k) - uo(i,k) = .5 * (uo(i,k) + uo(i,k+1)) - vo(i,k) = .5 * (vo(i,k) + vo(i,k+1)) - endif - enddo - enddo -c -c look for the level of free convection as cloud base -c - do i=1,im - flg(i) = cnvflg(i) - if(flg(i)) kbcon(i) = kmax(i) - enddo - do k = 2, km1 - do i=1,im - if (flg(i).and.k.lt.kbm(i)) then - if(k.gt.kb(i).and.heo(i,kb(i)).gt.heso(i,k)) then - kbcon(i) = k - flg(i) = .false. - endif - endif - enddo - enddo -c - do i=1,im - if(cnvflg(i)) then - if(kbcon(i).eq.kmax(i)) cnvflg(i) = .false. - endif - enddo -!! - totflg = .true. - do i=1,im - totflg = totflg .and. (.not. cnvflg(i)) - enddo - if(totflg) return -!! -c -c determine critical convective inhibition -c as a function of vertical velocity at cloud base. -c - do i=1,im - if(cnvflg(i)) then - pdot(i) = 10.* dot(i,kbcon(i)) - endif - enddo - do i=1,im - if(cnvflg(i)) then - if(slimsk(i).eq.1.) then - w1 = w1l - w2 = w2l - w3 = w3l - w4 = w4l - else - w1 = w1s - w2 = w2s - w3 = w3s - w4 = w4s - endif - if(pdot(i).le.w4) then - ptem = (pdot(i) - w4) / (w3 - w4) - elseif(pdot(i).ge.-w4) then - ptem = - (pdot(i) + w4) / (w4 - w3) - else - ptem = 0. - endif - val1 = -1. - ptem = max(ptem,val1) - val2 = 1. - ptem = min(ptem,val2) - ptem = 1. - ptem - ptem1= .5*(cincrmax-cincrmin) - cincr = cincrmax - ptem * ptem1 - tem1 = pfld(i,kb(i)) - pfld(i,kbcon(i)) - if(tem1.gt.cincr) then - cnvflg(i) = .false. - endif - endif - enddo -!! - totflg = .true. - do i=1,im - totflg = totflg .and. (.not. cnvflg(i)) - enddo - if(totflg) return -!! -c -c assume the detrainment rate for the updrafts to be same as -c the entrainment rate at cloud base -c - do i = 1, im - if(cnvflg(i)) then - xlamud(i) = xlamue(i,kbcon(i)) - endif - enddo -c -c determine updraft mass flux for the subcloud layers -c - do k = 1, km1 - do i=1,im - ptem = xlamud(i) - 1/dzmax - xlamue(i,k) = max(xlamue(i,k), ptem) - enddo - enddo - do i=1,im - xlamue(i,km) = xlamue(i,km1) - enddo - do k = km1, 1, -1 - do i = 1, im - if (cnvflg(i)) then - if(k.lt.kbcon(i).and.k.ge.kb(i)) then - dz = zi(i,k+1) - zi(i,k) - ptem = 0.5*(xlamue(i,k)+xlamue(i,k+1))-xlamud(i) - eta(i,k) = eta(i,k+1) / (1. + ptem * dz) - endif - endif - enddo - enddo -c -c compute mass flux above cloud base -c - do k = 2, km1 - do i = 1, im - if(cnvflg(i))then - if(k.gt.kbcon(i).and.k.lt.kmax(i)) then - dz = zi(i,k) - zi(i,k-1) - ptem = 0.5*(xlamue(i,k)+xlamue(i,k-1))-xlamud(i) - eta(i,k) = eta(i,k-1) * (1 + ptem * dz) - endif - endif - enddo - enddo -c -c compute updraft cloud property -c - do i = 1, im - if(cnvflg(i)) then - indx = kb(i) - hcko(i,indx) = heo(i,indx) - ucko(i,indx) = uo(i,indx) - vcko(i,indx) = vo(i,indx) - endif - enddo -c - do k = 2, km1 - do i = 1, im - if (cnvflg(i)) then - if(k.gt.kb(i).and.k.lt.kmax(i)) then - dz = zi(i,k) - zi(i,k-1) - tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz - tem1 = 0.5 * xlamud(i) * dz - factor = 1. + tem - tem1 - ptem = 0.5 * tem + pgcon - ptem1= 0.5 * tem - pgcon - hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5* - & (heo(i,k)+heo(i,k-1)))/factor - ucko(i,k) = ((1.-tem1)*ucko(i,k-1)+ptem*uo(i,k) - & +ptem1*uo(i,k-1))/factor - vcko(i,k) = ((1.-tem1)*vcko(i,k-1)+ptem*vo(i,k) - & +ptem1*vo(i,k-1))/factor - dbyo(i,k) = hcko(i,k) - heso(i,k) - endif - endif - enddo - enddo -c -c taking account into convection inhibition due to existence of -c dry layers below cloud base -c - do i=1,im - flg(i) = cnvflg(i) - kbcon1(i) = kmax(i) - enddo - do k = 2, km1 - do i=1,im - if (flg(i).and.k.lt.kbm(i)) then - if(k.ge.kbcon(i).and.dbyo(i,k).gt.0.) then - kbcon1(i) = k - flg(i) = .false. - endif - endif - enddo - enddo - do i=1,im - if(cnvflg(i)) then - if(kbcon1(i).eq.kmax(i)) cnvflg(i) = .false. - endif - enddo - do i=1,im - if(cnvflg(i)) then - tem = pfld(i,kbcon(i)) - pfld(i,kbcon1(i)) - if(tem.gt.dthk) then - cnvflg(i) = .false. - endif - endif - enddo -!! - totflg = .true. - do i = 1, im - totflg = totflg .and. (.not. cnvflg(i)) - enddo - if(totflg) return -!! -c -c determine first guess cloud top as the level of zero buoyancy -c limited to the level of sigma=0.7 -c - do i = 1, im - flg(i) = cnvflg(i) - if(flg(i)) ktcon(i) = kbm(i) - enddo - do k = 2, km1 - do i=1,im - if (flg(i).and.k .lt. kbm(i)) then - if(k.gt.kbcon1(i).and.dbyo(i,k).lt.0.) then - ktcon(i) = k - flg(i) = .false. - endif - endif - enddo - enddo -c -c turn off shallow convection if cloud top is less than pbl top -c -! do i=1,im -! if(cnvflg(i)) then -! kk = kpbl(i)+1 -! if(ktcon(i).le.kk) cnvflg(i) = .false. -! endif -! enddo -!! -! totflg = .true. -! do i = 1, im -! totflg = totflg .and. (.not. cnvflg(i)) -! enddo -! if(totflg) return -!! -c -c specify upper limit of mass flux at cloud base -c - do i = 1, im - if(cnvflg(i)) then -! xmbmax(i) = .1 -! - k = kbcon(i) - dp = 1000. * del(i,k) - xmbmax(i) = dp / (g * dt2) -! -! tem = dp / (g * dt2) -! xmbmax(i) = min(tem, xmbmax(i)) - endif - enddo -c -c compute cloud moisture property and precipitation -c - do i = 1, im - if (cnvflg(i)) then - aa1(i) = 0. - qcko(i,kb(i)) = qo(i,kb(i)) - endif - enddo - do k = 2, km1 - do i = 1, im - if (cnvflg(i)) then - if(k.gt.kb(i).and.k.lt.ktcon(i)) then - dz = zi(i,k) - zi(i,k-1) - gamma = el2orc * qeso(i,k) / (to(i,k)**2) - qrch = qeso(i,k) - & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) -cj - tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz - tem1 = 0.5 * xlamud(i) * dz - factor = 1. + tem - tem1 - qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* - & (qo(i,k)+qo(i,k-1)))/factor -cj - dq = eta(i,k) * (qcko(i,k) - qrch) -c -! rhbar(i) = rhbar(i) + qo(i,k) / qeso(i,k) -c -c below lfc check if there is excess moisture to release latent heat -c - if(k.ge.kbcon(i).and.dq.gt.0.) then - etah = .5 * (eta(i,k) + eta(i,k-1)) - if(ncloud.gt.0.) then - dp = 1000. * del(i,k) - qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz) - dellal(i,k) = etah * c1 * dz * qlk * g / dp - else - qlk = dq / (eta(i,k) + etah * c0 * dz) - endif - aa1(i) = aa1(i) - dz * g * qlk - qcko(i,k)= qlk + qrch - pwo(i,k) = etah * c0 * dz * qlk - endif - endif - endif - enddo - enddo -c -c calculate cloud work function -c - do k = 2, km1 - do i = 1, im - if (cnvflg(i)) then - if(k.ge.kbcon(i).and.k.lt.ktcon(i)) then - dz1 = zo(i,k+1) - zo(i,k) - gamma = el2orc * qeso(i,k) / (to(i,k)**2) - rfact = 1. + delta * cp * gamma - & * to(i,k) / hvap - aa1(i) = aa1(i) + - & dz1 * (g / (cp * to(i,k))) - & * dbyo(i,k) / (1. + gamma) - & * rfact - val = 0. - aa1(i)=aa1(i)+ - & dz1 * g * delta * - & max(val,(qeso(i,k) - qo(i,k))) - endif - endif - enddo - enddo - do i = 1, im - if(cnvflg(i).and.aa1(i).le.0.) cnvflg(i) = .false. - enddo -!! - totflg = .true. - do i=1,im - totflg = totflg .and. (.not. cnvflg(i)) - enddo - if(totflg) return -!! -c -c estimate the onvective overshooting as the level -c where the [aafac * cloud work function] becomes zero, -c which is the final cloud top -c limited to the level of sigma=0.7 -c - do i = 1, im - if (cnvflg(i)) then - aa1(i) = aafac * aa1(i) - endif - enddo -c - do i = 1, im - flg(i) = cnvflg(i) - ktcon1(i) = kbm(i) - enddo - do k = 2, km1 - do i = 1, im - if (flg(i)) then - if(k.ge.ktcon(i).and.k.lt.kbm(i)) then - dz1 = zo(i,k+1) - zo(i,k) - gamma = el2orc * qeso(i,k) / (to(i,k)**2) - rfact = 1. + delta * cp * gamma - & * to(i,k) / hvap - aa1(i) = aa1(i) + - & dz1 * (g / (cp * to(i,k))) - & * dbyo(i,k) / (1. + gamma) - & * rfact - if(aa1(i).lt.0.) then - ktcon1(i) = k - flg(i) = .false. - endif - endif - endif - enddo - enddo -c -c compute cloud moisture property, detraining cloud water -c and precipitation in overshooting layers -c - do k = 2, km1 - do i = 1, im - if (cnvflg(i)) then - if(k.ge.ktcon(i).and.k.lt.ktcon1(i)) then - dz = zi(i,k) - zi(i,k-1) - gamma = el2orc * qeso(i,k) / (to(i,k)**2) - qrch = qeso(i,k) - & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) -cj - tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz - tem1 = 0.5 * xlamud(i) * dz - factor = 1. + tem - tem1 - qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* - & (qo(i,k)+qo(i,k-1)))/factor -cj - dq = eta(i,k) * (qcko(i,k) - qrch) -c -c check if there is excess moisture to release latent heat -c - if(dq.gt.0.) then - etah = .5 * (eta(i,k) + eta(i,k-1)) - if(ncloud.gt.0.) then - dp = 1000. * del(i,k) - qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz) - dellal(i,k) = etah * c1 * dz * qlk * g / dp - else - qlk = dq / (eta(i,k) + etah * c0 * dz) - endif - qcko(i,k) = qlk + qrch - pwo(i,k) = etah * c0 * dz * qlk - endif - endif - endif - enddo - enddo -c -c exchange ktcon with ktcon1 -c - do i = 1, im - if(cnvflg(i)) then - kk = ktcon(i) - ktcon(i) = ktcon1(i) - ktcon1(i) = kk - endif - enddo -c -c this section is ready for cloud water -c - if(ncloud.gt.0) then -c -c compute liquid and vapor separation at cloud top -c - do i = 1, im - if(cnvflg(i)) then - k = ktcon(i) - 1 - gamma = el2orc * qeso(i,k) / (to(i,k)**2) - qrch = qeso(i,k) - & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) - dq = qcko(i,k) - qrch -c -c check if there is excess moisture to release latent heat -c - if(dq.gt.0.) then - qlko_ktcon(i) = dq - qcko(i,k) = qrch - endif - endif - enddo - endif -c -c--- compute precipitation efficiency in terms of windshear -c - do i = 1, im - if(cnvflg(i)) then - vshear(i) = 0. - endif - enddo - do k = 2, km - do i = 1, im - if (cnvflg(i)) then - if(k.gt.kb(i).and.k.le.ktcon(i)) then - shear= sqrt((uo(i,k)-uo(i,k-1)) ** 2 - & + (vo(i,k)-vo(i,k-1)) ** 2) - vshear(i) = vshear(i) + shear - endif - endif - enddo - enddo - do i = 1, im - if(cnvflg(i)) then - vshear(i) = 1.e3 * vshear(i) / (zi(i,ktcon(i))-zi(i,kb(i))) - e1=1.591-.639*vshear(i) - & +.0953*(vshear(i)**2)-.00496*(vshear(i)**3) - edt(i)=1.-e1 - val = .9 - edt(i) = min(edt(i),val) - val = .0 - edt(i) = max(edt(i),val) - endif - enddo -c -c--- what would the change be, that a cloud with unit mass -c--- will do to the environment? -c - do k = 1, km - do i = 1, im - if(cnvflg(i) .and. k .le. kmax(i)) then - dellah(i,k) = 0. - dellaq(i,k) = 0. - dellau(i,k) = 0. - dellav(i,k) = 0. - endif - enddo - enddo -c -c--- changed due to subsidence and entrainment -c - do k = 2, km1 - do i = 1, im - if (cnvflg(i)) then - if(k.gt.kb(i).and.k.lt.ktcon(i)) then - dp = 1000. * del(i,k) - dz = zi(i,k) - zi(i,k-1) -c - dv1h = heo(i,k) - dv2h = .5 * (heo(i,k) + heo(i,k-1)) - dv3h = heo(i,k-1) - dv1q = qo(i,k) - dv2q = .5 * (qo(i,k) + qo(i,k-1)) - dv3q = qo(i,k-1) - dv1u = uo(i,k) - dv2u = .5 * (uo(i,k) + uo(i,k-1)) - dv3u = uo(i,k-1) - dv1v = vo(i,k) - dv2v = .5 * (vo(i,k) + vo(i,k-1)) - dv3v = vo(i,k-1) -c - tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) - tem1 = xlamud(i) -cj - dellah(i,k) = dellah(i,k) + - & ( eta(i,k)*dv1h - eta(i,k-1)*dv3h - & - tem*eta(i,k-1)*dv2h*dz - & + tem1*eta(i,k-1)*.5*(hcko(i,k)+hcko(i,k-1))*dz - & ) *g/dp -cj - dellaq(i,k) = dellaq(i,k) + - & ( eta(i,k)*dv1q - eta(i,k-1)*dv3q - & - tem*eta(i,k-1)*dv2q*dz - & + tem1*eta(i,k-1)*.5*(qcko(i,k)+qcko(i,k-1))*dz - & ) *g/dp -cj - dellau(i,k) = dellau(i,k) + - & ( eta(i,k)*dv1u - eta(i,k-1)*dv3u - & - tem*eta(i,k-1)*dv2u*dz - & + tem1*eta(i,k-1)*.5*(ucko(i,k)+ucko(i,k-1))*dz - & - pgcon*eta(i,k-1)*(dv1u-dv3u) - & ) *g/dp -cj - dellav(i,k) = dellav(i,k) + - & ( eta(i,k)*dv1v - eta(i,k-1)*dv3v - & - tem*eta(i,k-1)*dv2v*dz - & + tem1*eta(i,k-1)*.5*(vcko(i,k)+vcko(i,k-1))*dz - & - pgcon*eta(i,k-1)*(dv1v-dv3v) - & ) *g/dp -cj - endif - endif - enddo - enddo -c -c------- cloud top -c - do i = 1, im - if(cnvflg(i)) then - indx = ktcon(i) - dp = 1000. * del(i,indx) - dv1h = heo(i,indx-1) - dellah(i,indx) = eta(i,indx-1) * - & (hcko(i,indx-1) - dv1h) * g / dp - dv1q = qo(i,indx-1) - dellaq(i,indx) = eta(i,indx-1) * - & (qcko(i,indx-1) - dv1q) * g / dp - dv1u = uo(i,indx-1) - dellau(i,indx) = eta(i,indx-1) * - & (ucko(i,indx-1) - dv1u) * g / dp - dv1v = vo(i,indx-1) - dellav(i,indx) = eta(i,indx-1) * - & (vcko(i,indx-1) - dv1v) * g / dp -c -c cloud water -c - dellal(i,indx) = eta(i,indx-1) * - & qlko_ktcon(i) * g / dp - endif - enddo -c -c mass flux at cloud base for shallow convection -c (Grant, 2001) -c - do i= 1, im - if(cnvflg(i)) then - k = kbcon(i) -! ptem = g*sflx(i)*zi(i,k)/t1(i,1) - ptem = g*sflx(i)*hpbl(i)/t1(i,1) - wstar(i) = ptem**h1 - tem = po(i,k)*100. / (rd*t1(i,k)) - xmb(i) = betaw*tem*wstar(i) - xmb(i) = min(xmb(i),xmbmax(i)) - endif - enddo -c -c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -c - do k = 1, km - do i = 1, im - if (cnvflg(i) .and. k .le. kmax(i)) then - qeso(i,k) = 0.01 * fpvs(t1(i,k)) ! fpvs is in pa - qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k)) - val = 1.e-8 - qeso(i,k) = max(qeso(i,k), val ) - endif - enddo - enddo -c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -c - do i = 1, im - delhbar(i) = 0. - delqbar(i) = 0. - deltbar(i) = 0. - delubar(i) = 0. - delvbar(i) = 0. - qcond(i) = 0. - enddo - do k = 1, km - do i = 1, im - if (cnvflg(i)) then - if(k.gt.kb(i).and.k.le.ktcon(i)) then - dellat = (dellah(i,k) - hvap * dellaq(i,k)) / cp - t1(i,k) = t1(i,k) + dellat * xmb(i) * dt2 - q1(i,k) = q1(i,k) + dellaq(i,k) * xmb(i) * dt2 - tem = 1./rcs(i) - u1(i,k) = u1(i,k) + dellau(i,k) * xmb(i) * dt2 * tem - v1(i,k) = v1(i,k) + dellav(i,k) * xmb(i) * dt2 * tem - dp = 1000. * del(i,k) - delhbar(i) = delhbar(i) + dellah(i,k)*xmb(i)*dp/g - delqbar(i) = delqbar(i) + dellaq(i,k)*xmb(i)*dp/g - deltbar(i) = deltbar(i) + dellat*xmb(i)*dp/g - delubar(i) = delubar(i) + dellau(i,k)*xmb(i)*dp/g - delvbar(i) = delvbar(i) + dellav(i,k)*xmb(i)*dp/g - endif - endif - enddo - enddo - do k = 1, km - do i = 1, im - if (cnvflg(i)) then - if(k.gt.kb(i).and.k.le.ktcon(i)) then - qeso(i,k) = 0.01 * fpvs(t1(i,k)) ! fpvs is in pa - qeso(i,k) = eps * qeso(i,k)/(pfld(i,k) + epsm1*qeso(i,k)) - val = 1.e-8 - qeso(i,k) = max(qeso(i,k), val ) - endif - endif - enddo - enddo -c - do i = 1, im - rntot(i) = 0. - delqev(i) = 0. - delq2(i) = 0. - flg(i) = cnvflg(i) - enddo - do k = km, 1, -1 - do i = 1, im - if (cnvflg(i)) then - if(k.lt.ktcon(i).and.k.gt.kb(i)) then - rntot(i) = rntot(i) + pwo(i,k) * xmb(i) * .001 * dt2 - endif - endif - enddo - enddo -c -c evaporating rain -c - do k = km, 1, -1 - do i = 1, im - if (k .le. kmax(i)) then - deltv(i) = 0. - delq(i) = 0. - qevap(i) = 0. - if(cnvflg(i)) then - if(k.lt.ktcon(i).and.k.gt.kb(i)) then - rn(i) = rn(i) + pwo(i,k) * xmb(i) * .001 * dt2 - endif - endif - if(flg(i).and.k.lt.ktcon(i)) then - evef = edt(i) * evfact - if(slimsk(i).eq.1.) evef=edt(i) * evfactl -! if(slimsk(i).eq.1.) evef=.07 -c if(slimsk(i).ne.1.) evef = 0. - qcond(i) = evef * (q1(i,k) - qeso(i,k)) - & / (1. + el2orc * qeso(i,k) / t1(i,k)**2) - dp = 1000. * del(i,k) - if(rn(i).gt.0..and.qcond(i).lt.0.) then - qevap(i) = -qcond(i) * (1.-exp(-.32*sqrt(dt2*rn(i)))) - qevap(i) = min(qevap(i), rn(i)*1000.*g/dp) - delq2(i) = delqev(i) + .001 * qevap(i) * dp / g - endif - if(rn(i).gt.0..and.qcond(i).lt.0..and. - & delq2(i).gt.rntot(i)) then - qevap(i) = 1000.* g * (rntot(i) - delqev(i)) / dp - flg(i) = .false. - endif - if(rn(i).gt.0..and.qevap(i).gt.0.) then - tem = .001 * dp / g - tem1 = qevap(i) * tem - if(tem1.gt.rn(i)) then - qevap(i) = rn(i) / tem - rn(i) = 0. - else - rn(i) = rn(i) - tem1 - endif - q1(i,k) = q1(i,k) + qevap(i) - t1(i,k) = t1(i,k) - elocp * qevap(i) - deltv(i) = - elocp*qevap(i)/dt2 - delq(i) = + qevap(i)/dt2 - delqev(i) = delqev(i) + .001*dp*qevap(i)/g - endif - dellaq(i,k) = dellaq(i,k) + delq(i) / xmb(i) - delqbar(i) = delqbar(i) + delq(i)*dp/g - deltbar(i) = deltbar(i) + deltv(i)*dp/g - endif - endif - enddo - enddo -cj -! do i = 1, im -! if(me.eq.31.and.cnvflg(i)) then -! if(cnvflg(i)) then -! print *, ' shallow delhbar, delqbar, deltbar = ', -! & delhbar(i),hvap*delqbar(i),cp*deltbar(i) -! print *, ' shallow delubar, delvbar = ',delubar(i),delvbar(i) -! print *, ' precip =', hvap*rn(i)*1000./dt2 -! print*,'pdif= ',pfld(i,kbcon(i))-pfld(i,ktcon(i)) -! endif -! enddo -cj - do i = 1, im - if(cnvflg(i)) then - if(rn(i).lt.0..or..not.flg(i)) rn(i) = 0. - ktop(i) = ktcon(i) - kbot(i) = kbcon(i) - kcnv(i) = 0 - endif - enddo -c -c cloud water -c - if (ncloud.gt.0) then -! - do k = 1, km1 - do i = 1, im - if (cnvflg(i)) then - if (k.gt.kb(i).and.k.le.ktcon(i)) then - tem = dellal(i,k) * xmb(i) * dt2 - tem1 = max(0.0, min(1.0, (tcr-t1(i,k))*tcrf)) - if (ql(i,k,2) .gt. -999.0) then - ql(i,k,1) = ql(i,k,1) + tem * tem1 ! ice - ql(i,k,2) = ql(i,k,2) + tem *(1.0-tem1) ! water - else - ql(i,k,1) = ql(i,k,1) + tem - endif - endif - endif - enddo - enddo -! - endif -! -! hchuang code change -! - do k = 1, km - do i = 1, im - if(cnvflg(i)) then - if(k.ge.kb(i) .and. k.lt.ktop(i)) then - ud_mf(i,k) = eta(i,k) * xmb(i) * dt2 - endif - endif - enddo - enddo - do i = 1, im - if(cnvflg(i)) then - k = ktop(i)-1 - dt_mf(i,k) = ud_mf(i,k) - endif - enddo -!! - return - end diff --git a/src/fim/FIMsrc/fim/column/shalcv_v.f b/src/fim/FIMsrc/fim/column/shalcv_v.f deleted file mode 100644 index ecde4ec..0000000 --- a/src/fim/FIMsrc/fim/column/shalcv_v.f +++ /dev/null @@ -1,237 +0,0 @@ - SUBROUTINE SHALCV(IM,IX,KM,DT,DEL,PRSI,PRSL,PRSLK,KUO,Q,T,levshc -! SUBROUTINE SHALCV(IM,IX,KM,DT,DEL,PRSI,PRSL,PRSLK,KUO,Q,T,DPSHC - &, phil, kinver, ctei_r, ctei_rm) -! SUBROUTINE SHALCV(IM,IX,KM,DT,DEL,PRSI,PRSL,PRSLK,KUO,Q,T,DPSHC -! &, kinver) -! - USE MACHINE , ONLY : kind_phys - USE PHYSCONS, grav => con_g, CP => con_CP, HVAP => con_HVAP - &, RD => con_RD - implicit none -! -! include 'constant.h' -! - integer IM, IX, KM, KUO(IM), kinver(im), levshc(im) - real(kind=kind_phys) DEL(IX,KM), PRSI(IX,KM+1), PRSL(IX,KM), - & PRSLK(IX,KM), phil(ix,km), - & Q(IX,KM), T(IX,KM), DT - &, ctei_r(im), ctei_rm -! & Q(IX,KM), T(IX,KM), DT, DPSHC(IM) -! -! Locals -! - real(kind=kind_phys) ck, cpdt, dmse, dsdz1, dsdz2, - & dsig, dtodsl, dtodsu, eldq, g, - & gocp, rtdls -! - integer k,k1,k2,kliftl,kliftu,kt,N2,I,iku,ik1,ik,ii - integer INDEX2(IM), KLCL(IM), KBOT(IM), KTOP(IM),kk - &, KTOPM(IM) -cc -C PHYSICAL PARAMETERS - PARAMETER(G=GRAV, GOCP=G/CP) -C BOUNDS OF PARCEL ORIGIN - PARAMETER(KLIFTL=2,KLIFTU=2) - LOGICAL LSHC(IM) - real(kind=kind_phys) Q2(IM*KM), T2(IM*KM), - & PRSL2(IM*KM), PRSLK2(IM*KM), - & AL(IM*(KM-1)), AD(IM*KM), AU(IM*(KM-1)) -C----------------------------------------------------------------------- -C COMPRESS FIELDS TO POINTS WITH NO DEEP CONVECTION -C AND MOIST STATIC INSTABILITY. - DO I=1,IM - LSHC(I)=.FALSE. - ENDDO - DO K=1,KM-1 - DO I=1,IM - IF(KUO(I).EQ.0) THEN - ELDQ = HVAP*(Q(I,K)-Q(I,K+1)) - CPDT = CP*(T(I,K)-T(I,K+1)) -! RTDLS = (PRSL(I,K)-PRSL(I,K+1)) / -! & PRSI(I,K+1)*RD*0.5*(T(I,K)+T(I,K+1)) -! DMSE = ELDQ+CPDT-RTDLS -! print *,' i=',i,' eldq=',eldq,' cpdt=',cpdt -! &,'rtdls=',rtdls,' phil=',phil(i,k),phil(i,k+1) -! &,' dmse=',dmse,' k=',k - DMSE = ELDQ + CPDT + phil(i,k) - phil(i,k+1) -! print*,' i=',i,' dmse=',dmse,' k=',k - LSHC(I) = LSHC(I).OR.DMSE.GT.0. - ENDIF - ENDDO - ENDDO - N2 = 0 - DO I=1,IM - IF(LSHC(I)) THEN - N2 = N2 + 1 - INDEX2(N2) = I - ENDIF - ENDDO - IF(N2.EQ.0) RETURN - DO K=1,KM - KK = (K-1)*N2 - DO I=1,N2 - IK = KK + I - ii = index2(i) - Q2(IK) = Q(II,K) - T2(IK) = T(II,K) - PRSL2(IK) = PRSL(II,K) - PRSLK2(IK) = PRSLK(II,K) - ENDDO - ENDDO -! - do i=1,N2 -! ktopm(i) = KM - ii = index2(i) - ktopm(i) = levshc(ii) -! if (ctei_r(ii) > ctei_rm) then - if (ctei_r(ii) < ctei_rm) then - ktopm(i) = min(ktopm(i),kinver(ii)) - endif - enddo -! do k=2,KM -! do i=1,N2 -! ii = index2(i) -! if (prsi(ii,1)-prsi(ii,k) .le. dpshc(ii)) ktopm(i) = k -! enddo -! enddo -! do i=1,N2 -! ktopm(i) = min(ktopm(i),kinver(index2(i))) -! enddo -C----------------------------------------------------------------------- -C COMPUTE MOIST ADIABAT AND DETERMINE LIMITS OF SHALLOW CONVECTION. -C CHECK FOR MOIST STATIC INSTABILITY AGAIN WITHIN CLOUD. - CALL MSTADBT3(N2,KM-1,KLIFTL,KLIFTU,PRSL2,PRSLK2,T2,Q2, - & KLCL,KBOT,KTOP,AL,AU) - DO I=1,N2 - KBOT(I) = min(KLCL(I)-1, ktopm(i)-1) - KTOP(I) = min(KTOP(I)+1, ktopm(i)) - LSHC(I) = .FALSE. - ENDDO - DO K=1,KM-1 - KK = (K-1)*N2 - DO I=1,N2 - IF(K.GE.KBOT(I).AND.K.LT.KTOP(I)) THEN - IK = KK + I - IKU = IK + N2 - ELDQ = HVAP * (Q2(IK)-Q2(IKU)) - CPDT = CP * (T2(IK)-T2(IKU)) -! RTDLS = (PRSL2(IK)-PRSL2(IKU)) / -! & PRSI(index2(i),K+1)*RD*0.5*(T2(IK)+T2(IKU)) - RTDLS = phil(index2(i),k+1) - phil(index2(i),k) - DMSE = ELDQ + CPDT - RTDLS - LSHC(I) = LSHC(I).OR.DMSE.GT.0. - AU(IK) = G/RTDLS - ENDIF - ENDDO - ENDDO - K1=KM+1 - K2=0 - DO I=1,N2 - IF(.NOT.LSHC(I)) THEN - KBOT(I) = KM+1 - KTOP(I) = 0 - ENDIF - K1 = MIN(K1,KBOT(I)) - K2 = MAX(K2,KTOP(I)) - ENDDO - KT = K2-K1+1 - IF(KT.LT.2) RETURN -C----------------------------------------------------------------------- -C SET EDDY VISCOSITY COEFFICIENT CKU AT SIGMA INTERFACES. -C COMPUTE DIAGONALS AND RHS FOR TRIDIAGONAL MATRIX SOLVER. -C EXPAND FINAL FIELDS. - KK = (K1-1) * N2 - DO I=1,N2 - IK = KK + I - AD(IK) = 1. - ENDDO -! -! DTODSU=DT/DEL(K1) - DO K=K1,K2-1 -! DTODSL=DTODSU -! DTODSU= DT/DEL(K+1) -! DSIG=SL(K)-SL(K+1) - KK = (K-1) * N2 - DO I=1,N2 - ii = index2(i) - DTODSL = DT/DEL(II,K) - DTODSU = DT/DEL(II,K+1) - DSIG = PRSL(II,K) - PRSL(II,K+1) - IK = KK + I - IKU = IK + N2 - IF(K.EQ.KBOT(I)) THEN - CK=1.5 - ELSEIF(K.EQ.KTOP(I)-1) THEN - CK=1. - ELSEIF(K.EQ.KTOP(I)-2) THEN - CK=3. - ELSEIF(K.GT.KBOT(I).AND.K.LT.KTOP(I)-2) THEN - CK=5. - ELSE - CK=0. - ENDIF - DSDZ1 = CK*DSIG*AU(IK)*GOCP - DSDZ2 = CK*DSIG*AU(IK)*AU(IK) - AU(IK) = -DTODSL*DSDZ2 - AL(IK) = -DTODSU*DSDZ2 - AD(IK) = AD(IK)-AU(IK) - AD(IKU) = 1.-AL(IK) - T2(IK) = T2(IK)+DTODSL*DSDZ1 - T2(IKU) = T2(IKU)-DTODSU*DSDZ1 - ENDDO - ENDDO - IK1=(K1-1)*N2+1 - CALL TRIDI2T3(N2,KT,AL(IK1),AD(IK1),AU(IK1),Q2(IK1),T2(IK1), - & AU(IK1),Q2(IK1),T2(IK1)) - DO K=K1,K2 - KK = (K-1)*N2 - DO I=1,N2 - IK = KK + I - Q(INDEX2(I),K) = Q2(IK) - T(INDEX2(I),K) = T2(IK) - ENDDO - ENDDO -C----------------------------------------------------------------------- - RETURN - END -C----------------------------------------------------------------------- - SUBROUTINE TRIDI2T3(L,N,CL,CM,CU,R1,R2,AU,A1,A2) -cyt INCLUDE DBTRIDI2; -cc - USE MACHINE , ONLY : kind_phys - implicit none - integer k,n,l,i - real(kind=kind_phys) fk -cc - real(kind=kind_phys) - & CL(L,2:N),CM(L,N),CU(L,N-1),R1(L,N),R2(L,N), - & AU(L,N-1),A1(L,N),A2(L,N) -C----------------------------------------------------------------------- - DO I=1,L - FK=1./CM(I,1) - AU(I,1)=FK*CU(I,1) - A1(I,1)=FK*R1(I,1) - A2(I,1)=FK*R2(I,1) - ENDDO - DO K=2,N-1 - DO I=1,L - FK=1./(CM(I,K)-CL(I,K)*AU(I,K-1)) - AU(I,K)=FK*CU(I,K) - A1(I,K)=FK*(R1(I,K)-CL(I,K)*A1(I,K-1)) - A2(I,K)=FK*(R2(I,K)-CL(I,K)*A2(I,K-1)) - ENDDO - ENDDO - DO I=1,L - FK=1./(CM(I,N)-CL(I,N)*AU(I,N-1)) - A1(I,N)=FK*(R1(I,N)-CL(I,N)*A1(I,N-1)) - A2(I,N)=FK*(R2(I,N)-CL(I,N)*A2(I,N-1)) - ENDDO - DO K=N-1,1,-1 - DO I=1,L - A1(I,K)=A1(I,K)-AU(I,K)*A1(I,K+1) - A2(I,K)=A2(I,K)-AU(I,K)*A2(I,K+1) - ENDDO - ENDDO -C----------------------------------------------------------------------- - RETURN - END diff --git a/src/fim/FIMsrc/fim/column/shalcv_v_opr.f b/src/fim/FIMsrc/fim/column/shalcv_v_opr.f deleted file mode 100755 index 5acb6b8..0000000 --- a/src/fim/FIMsrc/fim/column/shalcv_v_opr.f +++ /dev/null @@ -1,165 +0,0 @@ - SUBROUTINE SHALCVT3(IM,IX,KM,DT,DEL,PRSI,PRSL,PRSLK,KUO,Q,T) -! - USE MACHINE , ONLY : kind_phys - USE PHYSCONS, grav => con_g, CP => con_CP, HVAP => con_HVAP - &, RD => con_RD - implicit none -! -! include 'constant.h' -! - integer IM, IX, KM, KUO(IM) - real(kind=kind_phys) DEL(IX,KM), PRSI(IX,KM+1), PRSL(IX,KM), - & PRSLK(IX,KM), - & Q(IX,KM), T(IX,KM), DT -! -! Locals -! - real(kind=kind_phys) ck, cpdt, dmse, dsdz1, dsdz2, - & dsig, dtodsl, dtodsu, eldq, g, - & gocp, rtdls -! - integer k,k1,k2,kliftl,kliftu,kt,N2,I,iku,ik1,ik,ii - integer INDEX2(IM), KLCL(IM), KBOT(IM), KTOP(IM),kk -cc -C PHYSICAL PARAMETERS - PARAMETER(G=GRAV, GOCP=G/CP) -C BOUNDS OF PARCEL ORIGIN - PARAMETER(KLIFTL=2,KLIFTU=2) - LOGICAL LSHC(IM) - real(kind=kind_phys) Q2(IM*KM), T2(IM*KM), - & PRSL2(IM*KM), PRSLK2(IM*KM), - & AL(IM*(KM-1)), AD(IM*KM), AU(IM*(KM-1)) -C----------------------------------------------------------------------- -C COMPRESS FIELDS TO POINTS WITH NO DEEP CONVECTION -C AND MOIST STATIC INSTABILITY. - DO I=1,IM - LSHC(I)=.FALSE. - ENDDO - DO K=1,KM-1 - DO I=1,IM - IF(KUO(I).EQ.0) THEN - ELDQ = HVAP*(Q(I,K)-Q(I,K+1)) - CPDT = CP*(T(I,K)-T(I,K+1)) - RTDLS = (PRSL(I,K)-PRSL(I,K+1)) / - & PRSI(I,K+1)*RD*0.5*(T(I,K)+T(I,K+1)) - DMSE = ELDQ+CPDT-RTDLS - LSHC(I) = LSHC(I).OR.DMSE.GT.0. - ENDIF - ENDDO - ENDDO - N2 = 0 - DO I=1,IM - IF(LSHC(I)) THEN - N2 = N2 + 1 - INDEX2(N2) = I - ENDIF - ENDDO - IF(N2.EQ.0) RETURN - DO K=1,KM - KK = (K-1)*N2 - DO I=1,N2 - IK = KK + I - ii = index2(i) - Q2(IK) = Q(II,K) - T2(IK) = T(II,K) - PRSL2(IK) = PRSL(II,K) - PRSLK2(IK) = PRSLK(II,K) - ENDDO - ENDDO -C----------------------------------------------------------------------- -C COMPUTE MOIST ADIABAT AND DETERMINE LIMITS OF SHALLOW CONVECTION. -C CHECK FOR MOIST STATIC INSTABILITY AGAIN WITHIN CLOUD. - CALL MSTADBT3(N2,KM-1,KLIFTL,KLIFTU,PRSL2,PRSLK2,T2,Q2, - & KLCL,KBOT,KTOP,AL,AU) - DO I=1,N2 - KBOT(I) = KLCL(I)-1 - KTOP(I) = KTOP(I)+1 - LSHC(I) = .FALSE. - ENDDO - DO K=1,KM-1 - KK = (K-1)*N2 - DO I=1,N2 - IF(K.GE.KBOT(I).AND.K.LT.KTOP(I)) THEN - IK = KK + I - IKU = IK + N2 - ELDQ = HVAP * (Q2(IK)-Q2(IKU)) - CPDT = CP * (T2(IK)-T2(IKU)) - RTDLS = (PRSL2(IK)-PRSL2(IKU)) / - & PRSI(index2(i),K+1)*RD*0.5*(T2(IK)+T2(IKU)) - DMSE = ELDQ + CPDT - RTDLS - LSHC(I) = LSHC(I).OR.DMSE.GT.0. - AU(IK) = G/RTDLS - ENDIF - ENDDO - ENDDO - K1=KM+1 - K2=0 - DO I=1,N2 - IF(.NOT.LSHC(I)) THEN - KBOT(I) = KM+1 - KTOP(I) = 0 - ENDIF - K1 = MIN(K1,KBOT(I)) - K2 = MAX(K2,KTOP(I)) - ENDDO - KT = K2-K1+1 - IF(KT.LT.2) RETURN -C----------------------------------------------------------------------- -C SET EDDY VISCOSITY COEFFICIENT CKU AT SIGMA INTERFACES. -C COMPUTE DIAGONALS AND RHS FOR TRIDIAGONAL MATRIX SOLVER. -C EXPAND FINAL FIELDS. - KK = (K1-1) * N2 - DO I=1,N2 - IK = KK + I - AD(IK) = 1. - ENDDO -! -! DTODSU=DT/DEL(K1) - DO K=K1,K2-1 -! DTODSL=DTODSU -! DTODSU= DT/DEL(K+1) -! DSIG=SL(K)-SL(K+1) - KK = (K-1) * N2 - DO I=1,N2 - ii = index2(i) - DTODSL = DT/DEL(II,K) - DTODSU = DT/DEL(II,K+1) - DSIG = PRSL(II,K) - PRSL(II,K+1) - IK = KK + I - IKU = IK + N2 - IF(K.EQ.KBOT(I)) THEN - CK=1.5 - ELSEIF(K.EQ.KTOP(I)-1) THEN - CK=1. - ELSEIF(K.EQ.KTOP(I)-2) THEN - CK=3. - ELSEIF(K.GT.KBOT(I).AND.K.LT.KTOP(I)-2) THEN - CK=5. - ELSE - CK=0. - ENDIF - DSDZ1 = CK*DSIG*AU(IK)*GOCP - DSDZ2 = CK*DSIG*AU(IK)*AU(IK) - AU(IK) = -DTODSL*DSDZ2 - AL(IK) = -DTODSU*DSDZ2 - AD(IK) = AD(IK)-AU(IK) - AD(IKU) = 1.-AL(IK) - T2(IK) = T2(IK)+DTODSL*DSDZ1 - T2(IKU) = T2(IKU)-DTODSU*DSDZ1 - ENDDO - ENDDO - IK1=(K1-1)*N2+1 - CALL TRIDI2T3(N2,KT,AL(IK1),AD(IK1),AU(IK1),Q2(IK1),T2(IK1), - & AU(IK1),Q2(IK1),T2(IK1)) - DO K=K1,K2 - KK = (K-1)*N2 - DO I=1,N2 - IK = KK + I - Q(INDEX2(I),K) = Q2(IK) - T(INDEX2(I),K) = T2(IK) - ENDDO - ENDDO -C----------------------------------------------------------------------- - RETURN - END -C----------------------------------------------------------------------- diff --git a/src/fim/FIMsrc/fim/column/sig2press.f b/src/fim/FIMsrc/fim/column/sig2press.f deleted file mode 100644 index ad6322e..0000000 --- a/src/fim/FIMsrc/fim/column/sig2press.f +++ /dev/null @@ -1,42 +0,0 @@ - subroutine sig2press(njeff,nsize_ar,pgr,sl,si,slk,sik,prsi,prsl - &, prsik, prslk) - - use machine , only : kind_phys - use resol_def - use coordinate_def - use physcons, rk => con_rocp - implicit none - - integer njeff,nsize_ar - real(kind=kind_phys) sl(levs), si(levp1) - real(kind=kind_phys) slk(levs), sik(levp1), pgrk(nsize_ar) - real(kind=kind_phys) prsl(nsize_ar,levs), prslk(nsize_ar,levs) - real(kind=kind_phys) prsi(nsize_ar,levs+1), prsik(nsize_ar,levs+1) - real(kind=kind_phys) pgr(nsize_ar) - real (kind=kind_phys), parameter :: PT01=0.01 - - integer iq,ilat,me - integer i,k - -! sik(levs+1) = (si(levs+1)*0.01) ** rk -! do k=1,levs -! slk(k) = (sl(k)*0.01) ** rk -! sik(k) = (si(k)*0.01) ** rk -! enddo - do i=1,njeff - prsi(i,levs+1) = si(levs+1)*pgr(i) ! prsi are now pressures - pgrk(i) = (pgr(i)*pt01) ** rk - prsik(i,levs+1) = sik(levs+1) * pgrk(i) - enddo - do k=1,levs - do i=1,njeff - prsi(i,k) = si(k)*pgr(i) ! prsi are now pressures - prsl(i,k) = sl(k)*pgr(i) - prsik(i,k) = sik(k) * pgrk(i) - prslk(i,k) = slk(k) * pgrk(i) - enddo - enddo - - - return - end diff --git a/src/fim/FIMsrc/fim/column/swave.f b/src/fim/FIMsrc/fim/column/swave.f deleted file mode 100644 index 92edad7..0000000 --- a/src/fim/FIMsrc/fim/column/swave.f +++ /dev/null @@ -1,2272 +0,0 @@ - SUBROUTINE SWR95(S0,ISRC,PL,TA,WA,OA,CO2,COSZ,TAUCL, - & CCLY,CFAC,ICFC,ICWP,CWP,CIP,REW,REI,FICE, - & ALBUVB,ALBUVD,ALBIRB,ALBIRD,KPRF,IDXC,CMIX,DENN,RH, - & HTRC,TUPFXC,TDNFLX,SUPFXC,SDNFXC, - & TUPFX0,SUPFX0,SDNFX0, - & SDNFVB,SDNFVD,SDNFNB,SDNFND, NDAY, IR, -! --- FOR UV-B BAND FLUXES - & SUVBFC,SUVBF0, -! --- END UV-B - & L, LP1, IMAX, NSRC, NBD, NVB, NAE, NDM, NXC, NDN, - & HAER, IDM, DZ, HZ, TAUR, me, ix2) -! &, lprnt) -CFPP$ NOCONCUR R -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: SWR95 COMPUTES SHORT-WAVE RADIATIVE HEATING -! PROGRAMMER: YU-TAI HOU ORG: W/NMC20 DATE: 95-02-09 -! -! ABSTRACT: THIS CODE IS A MODIFIED VERSION OF M.D. CHOU'S SW -! RADIATION CODE TO FIT NMC MRF AND CLIMATE MODELS. IT COMPUTES -! SW ATMOSPHERIC ABSORPTION AND SCATTERING EFFECTS DUE TO O3, -! H2O,CO2,O2,CLOUDS, AND AEROSOLS, ETC. -! IT HAS 8 UV+VIS BANDS AND 3 NIR BANDS (10 K-VALUES EACH). -! -! REFERENCES: CHOU (1986, J. CLIM. APPL.METEOR.) -! CHOU (1990, J. CLIM.), AND CHOU (1992, J. ATMS. SCI.) -! CHOU AND SUAREZ (1999, NASA/TM-1999-104606,VOL.15) -! -! PROGRAM HISTORY LOG: -! 94-06-12 M.D. CHOU, GLA. -! 95-02-09 YU-TAI HOU - RECODE FOR NMC MODELS -! 98-08-03 YU-TAI HOU - UPDATED CLOUD RADIATIVE PROPERTIES -! CALCULATION. USE SLINGO'S METHOD (JAS 1989) ON WATER -! CLOUD, EBERT AND CURRY'S METHOD (JGR 1992) ON ICE CLOUD. -! 99-03-25 YU-TAI HOU - UPDATED CLOUD RADIATIVE PROPERTY -! CALCULATIONS USE CHOU ET AL. NEW METHOD (J. CLIM 1998) -! 99-04-27 YU-TAI HOU - UPDATED CLOUD RADIATIVE PROPERTY -! CALCULATIONS USE LINEAR T-ADJUSTED METHOD. -! 99-09-13 YU-TAI HOU - UPDATED TO CHOU'S JUNE,99 VERSION -! -! USAGE: CALL SWR95 -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 77 & Fortran 90 -! MACHINE: CRAY C-90, IBM SP, SGI -! -! INPUT PARAMETERS: -! S0 : SOLAR CONSTANT -! ISRC : FLAGS FOR SELECTING ABSORBERS -! 1:AEROSOLS, 2:O2, 3:CO2, 4:H2O, 5:O3 -! =0:WITHOUT IT, =1: WITH IT. -! PL : MODEL LEVEL PRESSURE IN MB -! TA : MODEL LAYER TEMPERATURE IN K -! WA : LAYER SPECIFIC HUMIDITY IN GM/GM -! OA : LAYER OZONE CONCENTRATION IN GM/GM -! CO2 : CO2 MIXING RATION BY VOLUME -! COSZ : COSINE OF SOLAR ZENITH ANGLE -! TAUCL : OPTICAL DEPTH OF CLOUD LAYERS -! CCLY : LAYER CLOUD FRACTION -! CFAC : FRACTION OF CLEAR SKY VIEW AT THE LAYER INTERFACE -! ICFC : =0 NO CLOUD FACTOR TO WEIGH CLEAR AND CLOUDY FLUXES -! =1 USE CLOUD FACTOR TO WEIGH CLEAR AND CLOUDY FLUXES -! ICWP : FLAG INDICATES THE METHOD USED FOR CLOUD PROPERTIES -! CALCULATIONS, =0 USE T-P; =1 USE CWC/CIC. -! CWP : LAYER CLOUD WATER PATH (G/M**2) -! CIP : LAYER CLOUD ICE PATH (G/M**2) -! REW : LAYER WATER CLOUD DROP EFFECTIVE RADIUS (MICRON) -! REI : LAYER ICE CLOUD DROP EFFECTIVE RADIUS -! FICE : FRACTION OF CLOUD ICE CONTENT -! ALBUVB : UV+VIS SURF DIRECT ALBEDO -! ALBUVD : UV+VIS SURF DIFFUSED ALBEDO -! ALBIRB : NIR SURF DIRECT ALBEDO -! ALBIRD : NIR SURF DIFFUSED ALBEDO -! PAER : AEROSOL PROFILES (FRACTION) -! -! OUTPUT PARAMETER: -! HTRC : HEATING RATES FOR CLOUDY SKY IN K/DAY -! TUPFXC : UPWARD FLUX AT TOA FOR CLOUDY SKY W/M**2 -! TDNFLX : DNWARD FLUX AT TOA FOR ALL SKY W/M**2 -! SUPFXC : UPWARD FLUX AT SFC FOR CLOUDY SKY W/M**2 -! SDNFXC : DNWARD FLUX AT SFC FOR CLOUDY SKY W/M**2 -! TUPFX0 : UPWARD FLUX AT TOA FOR CLEAR SKY W/M**2 -! SUPFX0 : UPWARD FLUX AT SFC FOR CLEAR SKY W/M**2 -! SDNFX0 : DNWARD FLUX AT SFC FOR CLEAR SKY W/M**2 -! SDNFVB : DOWNWARD SURFACE VIS BEAM FLUX W/M**2 -! SDNFNB : DOWNWARD SURFACE NIR BEAM FLUX W/M**2 -! SDNFVD : DOWNWARD SURFACE VIS DIFF FLUX W/M**2 -! SDNFND : DOWNWARD SURFACE NIR DIFF FLUX W/M**2 -! -! NOTE: -! FOR ALL QUANTITIES, K=1 IS THE TOP LEVEL/LAYER, EXCEPT -! SI AND SL, FOR WHICH K=1 IS THE SURFACE LEVEL/LAYER. -! -!$$$ -! - USE MACHINE , ONLY : kind_rad - implicit none -! - integer L, LP1, IMAX, NSRC, NBD, NVB, NAE, NDM, NXC, NDN - &, ICFC, ICWP, NDAY, IR(NDAY), me, ix2 -! - integer IDM (ix2,L,NAE), IDXC(NXC,IMAX), KPRF(IMAX) - integer ISRC(NSRC) - real (kind=kind_rad) HAER(NDM,NAE) - &, DZ(IMAX,L), HZ(IMAX,L+1), TAUR(ix2,L,NBD) - &, CMIX(NXC,IMAX), DENN(NDN,IMAX) -! --- INPUT - real (kind=kind_rad) S0, CO2 - &, PL (IMAX,LP1), TA(IMAX,L), WA(IMAX,L), OA(IMAX,L) - &, TAUCL(IMAX,L), CCLY(IMAX,L), CFAC(IMAX,LP1), COSZ(IMAX) - &, ALBUVB(IMAX), ALBUVD(IMAX), ALBIRB(IMAX), ALBIRD(IMAX) - &, RH(IMAX,L), FICE(IMAX,L) - &, CWP(IMAX,L), CIP(IMAX,L), REW(IMAX,L), REI(IMAX,L) - -! --- OUTPUT - real (kind=kind_rad) - & TUPFXC(IMAX), SUPFXC(IMAX), SDNFXC(IMAX), TDNFLX(IMAX) - &, TUPFX0(IMAX), SUPFX0(IMAX), SDNFX0(IMAX), HTRC(IMAX,L) - &, SDNFVB(IMAX), SDNFVD(IMAX), SDNFNB(IMAX), SDNFND(IMAX) - &, SDN0VB(IMAX), SDN0VD(IMAX), SDN0NB(IMAX), SDN0ND(IMAX) - -! --- OUTPUT FOR UV-B BAND DOWNWARD SURFACE AND TOP DOWNWARD FLUXES - real (kind=kind_rad) - & SUVBF0(IMAX), SUVBFC(IMAX) - -! --- INTERNAL ARRAY - real (kind=kind_rad) HTR0 (IMAX,L) -! -! Locals -! - real (kind=kind_rad) - & PL1 (NDAY,LP1), TA1(NDAY,L), WA1(NDAY,L), OA1(NDAY,L) - &, TAUCL1(NDAY,L), CCLY1(NDAY,L), CFAC1(NDAY,LP1), COSZ1(NDAY) - &, AL1UVB(NDAY), AL1UVD(NDAY), AL1IRB(NDAY), AL1IRD(NDAY) - &, RH1(NDAY,L), FICE1(NDAY,L) - &, CWP1(NDAY,L), CIP1(NDAY,L), REW1(NDAY,L), REI1(NDAY,L) - -! --- OUTPUT FOR UV-B BAND DOWNWARD SURFACE AND TOP DOWNWARD FLUXES - real (kind=kind_rad) - & SUV1F0(NDAY), SUV1FC(NDAY) - - real (kind=kind_rad) - & TU1FXC(NDAY), SU1FXC(NDAY), SD1FXC(NDAY), TD1FLX(NDAY) - &, TU1FX0(NDAY), SU1FX0(NDAY), SD1FX0(NDAY), HTRC1(NDAY,L) - &, SD1FVB(NDAY), SD1FVD(NDAY), SD1FNB(NDAY), SD1FND(NDAY) - &, SD10VB(NDAY), SD10VD(NDAY), SD10NB(NDAY), SD10ND(NDAY) - &, HTR01(NDAY,L) - real (kind=kind_rad) CMIX1(NXC,NDAY), DENN1(NDN,NDAY) - &, DZ1(NDAY,L), HZ1(NDAY,L+1) - &, TAUR1(nday,L,NBD) - integer IDXC1(NXC,NDAY), KPRF1(NDAY), idm1(nday,L,NAE) -! - integer i, ii, k, j -! logical lprnt -! integer ipnGlobal,its,mype -! logical DiagPrint -! call PhysicsGetIpnItsMype(ipnGlobal,its,mype,DiagPrint) -! -! -!===> ... BEGIN HERE -! - DO I=1,NDAY - II = IR(I) - TDNFLX(II) = S0 * COSZ(II) - SDN0VB(I) = 0.0 - SDN0VD(I) = 0.0 - SDN0NB(I) = 0.0 - SDN0ND(I) = 0.0 - ENDDO -! -! Reduce the vectors -! - DO K=1,L - DO I=1,NDAY - II = IR(I) - PL1(I,K) = PL(II,K) - TA1(I,K) = TA(II,K) - WA1(I,K) = WA(II,K) - OA1(I,K) = OA(II,K) - TAUCL1(I,K) = TAUCL(II,K) - CFAC1(I,K) = CFAC(II,K) - CCLY1(I,K) = CCLY(II,K) - FICE1(I,K) = FICE(II,K) - CWP1(I,K) = CWP(II,K) - CIP1(I,K) = CIP(II,K) - REW1(I,K) = REW(II,K) - REI1(I,K) = REI(II,K) - RH1(I,K) = RH(II,K) -! - HZ1(I,K) = HZ(II,K) - DZ1(I,K) = DZ(II,K) - ENDDO - ENDDO - DO I=1,NDAY - II = IR(I) - PL1(I,LP1) = PL(II,LP1) - CFAC1(I,LP1) = CFAC(II,LP1) - AL1UVB(I) = ALBUVB(II) - AL1UVD(I) = ALBUVD(II) - AL1IRB(I) = ALBIRB(II) - AL1IRD(I) = ALBIRD(II) - COSZ1(I) = COSZ(II) - TD1FLX(I) = TDNFLX(II) -! - KPRF1(I) = KPRF(II) - HZ1(I,LP1) = HZ(II,LP1) - ENDDO - DO K=1,NXC - DO I=1,NDAY - II = IR(I) - IDXC1(K,I) = IDXC(K,II) - CMIX1(K,I) = CMIX(K,II) - ENDDO - ENDDO - DO K=1,NDN - DO I=1,NDAY - II = IR(I) - DENN1(K,I) = DENN(K,II) - ENDDO - ENDDO - DO J=1,NBD - DO K=1,L - DO I=1,NDAY - II = IR(I) - TAUR1(I,K,J) = TAUR(II,K,J) - ENDDO - ENDDO - ENDDO - DO J=1,NAE - DO K=1,L - DO I=1,NDAY - II = IR(I) - IDM1(I,K,J) = IDM(II,K,J) - ENDDO - ENDDO - ENDDO -! - CALL SWR95A(S0,ISRC,PL1,TA1,WA1,OA1,CO2,COSZ1,TAUCL1, - & CCLY1,CFAC1,ICFC,ICWP,CWP1,CIP1,REW1,REI1,FICE1, - & AL1UVB,AL1UVD,AL1IRB,AL1IRD,KPRF1,IDXC1,CMIX1,DENN1, - & RH1, - & HTRC1,TU1FXC,TD1FLX,SU1FXC,SD1FXC, - & TU1FX0,SU1FX0,SD1FX0, - & SD1FVB,SD1FVD,SD1FNB,SD1FND, -! --- FOR UV-B BAND FLUXES - & SUV1FC,SUV1F0, -! --- END UV-B - & L, LP1, NDAY, NSRC, NBD, NVB, NAE, NDM, NXC, NDN, - & HAER, IDM1, DZ1, HZ1, TAUR1, me) -! &, lprnt) -! - DO I=1,NDAY - II = IR(I) - SDNFNB(II) = SD1FNB(I) - SDNFND(II) = SD1FND(I) - SDNFVB(II) = SD1FVB(I) - SDNFVD(II) = SD1FVD(I) - TUPFX0(II) = TU1FX0(I) - TUPFXC(II) = TU1FXC(I) - SUPFX0(II) = SU1FX0(I) - SUPFXC(II) = SU1FXC(I) - SDNFX0(II) = SD1FX0(I) - SDNFXC(II) = SD1FXC(I) - -! --- FOR UV-B BAND FLUXES - SUVBF0(II) = SUV1F0(I) - SUVBFC(II) = SUV1FC(I) -! --- END UV-B - ENDDO -! - DO K=1,L - DO I=1,NDAY - HTRC(IR(I),K) = HTRC1(I,K) - ENDDO - ENDDO -! - RETURN - END - SUBROUTINE SWR95A(S0,ISRC,PL,TA,WA,OA,CO2,COSZ,TAUCL, - & CCLY,CFAC,ICFC,ICWP,CWP,CIP,REW,REI,FICE, - & ALBUVB,ALBUVD,ALBIRB,ALBIRD,KPRF,IDXC,CMIX,DENN,RH, - & HTRC,TUPFXC,TDNFLX,SUPFXC,SDNFXC, - & TUPFX0,SUPFX0,SDNFX0, - & SDNFVB,SDNFVD,SDNFNB,SDNFND, -! --- FOR UV-B BAND FLUXES - & SUVBFC,SUVBF0, -! --- END UV-B - & L, LP1, IMAX, NSRC, NBD, NVB, NAE, NDM, NXC, NDN, - & HAER, IDM, DZ, HZ, TAUR, me) -! &, lprnt) -!FPP$ NOCONCUR R -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: SWR95 COMPUTES SHORT-WAVE RADIATIVE HEATING -! PROGRAMMER: YU-TAI HOU ORG: W/NMC20 DATE: 95-02-09 -! -! ABSTRACT: THIS CODE IS A MODIFIED VERSION OF M.D. CHOU'S SW -! RADIATION CODE TO FIT NMC MRF AND CLIMATE MODELS. IT COMPUTES -! SW ATMOSPHERIC ABSORPTION AND SCATTERING EFFECTS DUE TO O3, -! H2O,CO2,O2,CLOUDS, AND AEROSOLS, ETC. -! IT HAS 8 UV+VIS BANDS AND 3 NIR BANDS (10 K-VALUES EACH). -! -! REFERENCES: CHOU (1986, J. CLIM. APPL.METEOR.) -! CHOU (1990, J. CLIM.), AND CHOU (1992, J. ATMS. SCI.) -! CHOU AND SUAREZ (1999, NASA/TM-1999-104606,VOL.15) -! -! PROGRAM HISTORY LOG: -! 94-06-12 M.D. CHOU, GLA. -! 95-02-09 YU-TAI HOU - RECODE FOR NMC MODELS -! 98-08-03 YU-TAI HOU - UPDATED CLOUD RADIATIVE PROPERTIES -! CALCULATION. USE SLINGO'S METHOD (JAS 1989) ON WATER -! CLOUD, EBERT AND CURRY'S METHOD (JGR 1992) ON ICE CLOUD. -! 99-03-25 YU-TAI HOU - UPDATED CLOUD RADIATIVE PROPERTY -! CALCULATIONS USE CHOU ET AL. NEW METHOD (J. CLIM 1998) -! 99-04-27 YU-TAI HOU - UPDATED CLOUD RADIATIVE PROPERTY -! CALCULATIONS USE LINEAR T-ADJUSTED METHOD. -! 99-09-13 YU-TAI HOU - UPDATED TO CHOU'S JUNE,99 VERSION -! -! USAGE: CALL SWR95 -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 77 & Fortran 90 -! MACHINE: CRAY C-90, IBM SP, SGI -! -! INPUT PARAMETERS: -! S0 : SOLAR CONSTANT -! ISRC : FLAGS FOR SELECTING ABSORBERS -! 1:AEROSOLS, 2:O2, 3:CO2, 4:H2O, 5:O3 -! =0:WITHOUT IT, =1: WITH IT. -! PL : MODEL LEVEL PRESSURE IN MB -! TA : MODEL LAYER TEMPERATURE IN K -! WA : LAYER SPECIFIC HUMIDITY IN GM/GM -! OA : LAYER OZONE CONCENTRATION IN GM/GM -! CO2 : CO2 MIXING RATION BY VOLUME -! COSZ : COSINE OF SOLAR ZENITH ANGLE -! TAUCL : OPTICAL DEPTH OF CLOUD LAYERS -! CCLY : LAYER CLOUD FRACTION -! CFAC : FRACTION OF CLEAR SKY VIEW AT THE LAYER INTERFACE -! ICFC : =0 NO CLOUD FACTOR TO WEIGH CLEAR AND CLOUDY FLUXES -! =1 USE CLOUD FACTOR TO WEIGH CLEAR AND CLOUDY FLUXES -! ICWP : FLAG INDICATES THE METHOD USED FOR CLOUD PROPERTIES -! CALCULATIONS, =0 USE T-P; =1 USE CWC/CIC. -! CWP : LAYER CLOUD WATER PATH (G/M**2) -! CIP : LAYER CLOUD ICE PATH (G/M**2) -! REW : LAYER WATER CLOUD DROP EFFECTIVE RADIUS (MICRON) -! REI : LAYER ICE CLOUD DROP EFFECTIVE RADIUS -! FICE : FRACTION OF CLOUD ICE CONTENT -! ALBUVB : UV+VIS SURF DIRECT ALBEDO -! ALBUVD : UV+VIS SURF DIFFUSED ALBEDO -! ALBIRB : NIR SURF DIRECT ALBEDO -! ALBIRD : NIR SURF DIFFUSED ALBEDO -! PAER : AEROSOL PROFILES (FRACTION) -! -! OUTPUT PARAMETER: -! HTRC : HEATING RATES FOR CLOUDY SKY IN K/DAY -! TUPFXC : UPWARD FLUX AT TOA FOR CLOUDY SKY W/M**2 -! TDNFLX : DNWARD FLUX AT TOA FOR ALL SKY W/M**2 -! SUPFXC : UPWARD FLUX AT SFC FOR CLOUDY SKY W/M**2 -! SDNFXC : DNWARD FLUX AT SFC FOR CLOUDY SKY W/M**2 -! TUPFX0 : UPWARD FLUX AT TOA FOR CLEAR SKY W/M**2 -! SUPFX0 : UPWARD FLUX AT SFC FOR CLEAR SKY W/M**2 -! SDNFX0 : DNWARD FLUX AT SFC FOR CLEAR SKY W/M**2 -! SDNFVB : DOWNWARD SURFACE VIS BEAM FLUX W/M**2 -! SDNFNB : DOWNWARD SURFACE NIR BEAM FLUX W/M**2 -! SDNFVD : DOWNWARD SURFACE VIS DIFF FLUX W/M**2 -! SDNFND : DOWNWARD SURFACE NIR DIFF FLUX W/M**2 -! -! NOTE: -! FOR ALL QUANTITIES, K=1 IS THE TOP LEVEL/LAYER, EXCEPT -! SI AND SL, FOR WHICH K=1 IS THE SURFACE LEVEL/LAYER. -! -!$$$ -! -! - USE MACHINE , ONLY : kind_rad,kind_phys - implicit none -! - integer L, LP1, IMAX, NSRC, NBD, NVB, NAE, NDM, NXC, NDN - &, ICFC, ICWP, me - integer IDM (IMAX,L,NAE), IDXC(NXC,IMAX), KPRF(IMAX), ISRC(NSRC) - real (kind=kind_rad) HAER(NDM,NAE) - &, DZ(IMAX,L), HZ(IMAX,L+1), TAUR(IMAX,L,NBD) - &, CMIX(NXC,IMAX), DENN(NDN,IMAX) -! -! --- INPUT - real (kind=kind_rad) S0, CO2 - &, PL (IMAX,LP1), TA(IMAX,L), WA(IMAX,L), OA(IMAX,L) - &, TAUCL(IMAX,L), CCLY(IMAX,L), CFAC(IMAX,LP1),COSZ(IMAX) - &, ALBUVB(IMAX), ALBUVD(IMAX), ALBIRB(IMAX), ALBIRD(IMAX) - &, RH(IMAX,L), FICE(IMAX,L) - &, CWP(IMAX,L), CIP(IMAX,L), REW(IMAX,L), REI(IMAX,L) -! - -! --- OUTPUT - real (kind=kind_rad) - & TUPFXC(IMAX), SUPFXC(IMAX), SDNFXC(IMAX), TDNFLX(IMAX) - &, TUPFX0(IMAX), SUPFX0(IMAX), SDNFX0(IMAX), HTRC(IMAX,L) - &, SDNFVB(IMAX), SDNFVD(IMAX), SDNFNB(IMAX), SDNFND(IMAX) - &, SDN0VB(IMAX), SDN0VD(IMAX), SDN0NB(IMAX), SDN0ND(IMAX) - -! --- OUTPUT FOR UV-B BAND DOWNWARD SURFACE AND TOP DOWNWARD FLUXES - real (kind=kind_rad) - & SUVBFC(IMAX), SUVBF0(IMAX) - -! --- INTERNAL ARRAY - real (kind=kind_rad) - & FNET0(IMAX,LP1), FNETC(IMAX,LP1), HTR0 (IMAX,LP1) - &, DFLX0(IMAX,LP1), DFLXC(IMAX,LP1), DP (IMAX,L) - &, SCAL (IMAX,L), SWH (IMAX,LP1), SO2 (IMAX,LP1) - &, WH (IMAX,L), OH (IMAX,L), SWU (IMAX,LP1) - &, CF0 (IMAX), CF1 (IMAX), SNT (IMAX) - &, CNT (IMAX) - real (kind=kind_rad) rewi(imax,L), reii(imax,L) -! logical lprnt -! - real (kind=kind_rad) ZTHIK(IMAX,L), CSMIK(IMAX,L) -! - real (kind=kind_rad) taucrt - integer IFPR, IBND - DATA TAUCRT / 0.05 /, IFPR / 0 / - DATA IBND / 1 / !===> ... IBND=1:USE ONE NIR BAND -! DATA IBND / 2 / !===> ... IBND=2:USE TWO NIR BANDS -c$$$ SAVE TAUCRT, IFPR, IBND -! - real (kind=kind_rad) tfac, tem, rcf1, ccc, xa, to2 - &, u1, du, w1, dw, fac - integer i, k, jtop -! - include 'co2tab_sw.h' -! -cc -cc-------------------------------------------------------------------- -cc - real(kind=kind_rad) cons_1pdm11 !constant - integer ipnGlobal,its,mype - logical DiagPrint -cc - cons_1pdm11 = 1.d-11 !constant -cc -cc-------------------------------------------------------------------- -cc -!===> ... BEGIN HERE -! call PhysicsGetIpnItsMype(ipnGlobal,its,mype,DiagPrint) - -! This AEROSOL print shuold be uncommented and printed when PrintDiags is true - JFM -! IF (IFPR .EQ. 0) THEN -! if (me.eq.0) WRITE(6,12) (ISRC(I),I=1,NSRC) -! 12 FORMAT(3X,'AEROSOL, O2, CO2, H2O, O3 =',5I3) -! IFPR = 1 -! END IF -! - DFLXC(:,:) = 0.0 - DO I=1,IMAX - SWH (I,1) = 0.0 - SO2 (I,1) = 0.0 - TUPFXC(I) = 0.0 - TUPFX0(I) = 0.0 - SUPFXC(I) = 0.0 - SUPFX0(I) = 0.0 - SDNFXC(I) = 0.0 - SDNFX0(I) = 0.0 - CF0(I) = CFAC(I,LP1) - CF1(I) = 1.0 - CF0(I) - SNT(I) = 1.0 / COSZ(I) ! SNT = SECANT OF SOLAR ZENITH ANGLE -! - SDNFVB(I) = 0.0 - SDNFVD(I) = 0.0 - SDNFNB(I) = 0.0 - SDNFND(I) = 0.0 - SDN0VB(I) = 0.0 - SDN0VD(I) = 0.0 - SDN0NB(I) = 0.0 - SDN0ND(I) = 0.0 - -! --- FOR UV-B FLUXES - SUVBFC(I) = 0.0 - SUVBF0(I) = 0.0 -! --- END UV-B - - ENDDO -! - TFAC = 0.5 / 300.0 - DO K=1,L - DO I=1,IMAX -!===> ... LAYER THICKNESS AND PRESSURE SCALING FUNCTION FOR -! WATER VAPOR ABSORPTION - DP (I,K) = PL(I,K+1) - PL(I,K) - SCAL(I,K) = DP(I,K) * (TFAC*(PL(I,K)+PL(I,K+1)))**0.8 -!===> ... SCALED ABSORBER AMOUNTS FOR H2O(WH,SWH), UNIT : G/CM**2 - TEM = 0.00135*(TA(I,K)-240.0) - WH(I,K) = 1.02 * WA(I,K) * SCAL(I,K) -! & * EXP(0.00135*(TA(I,K)-240.0)) - & * (1.0 + TEM + 0.5*TEM*TEM) + 1.0E-11 - ENDDO - ENDDO - DO K=1,L - DO I=1,IMAX - SWH(I,K+1) = SWH(I,K) + WH(I,K) - ZTHIK(I,K) = COSZ(I) - CSMIK(I,K) = SNT(I) - ENDDO - ENDDO -! -!===> ... INITIALIZE FLUXES -! - DO K=1,LP1 - DO I=1,IMAX - FNET0(I,K) = 0.0 - FNETC(I,K) = 0.0 - DFLX0(I,K) = 0.0 - ENDDO - ENDDO -! - IF (ICFC .EQ. 1) THEN - DO I=1,IMAX - CFAC(I,LP1) = 0.0 - END DO - DO K=1,L - DO I=1,IMAX - IF (CF1(I) .GT. 0.0) THEN - RCF1 = 1.0 / CF1(I) - CFAC(I,K) = (CFAC(I,K) - CF0(I)) * RCF1 - CCLY(I,K) = CCLY(I,K) * RCF1 - END IF - END DO - END DO - END IF -! - IF (ICWP.NE. 1) THEN - DO K=1,L - DO I=1,IMAX -!0900 TAUCL(I,K) = TAUCL(I,K) * CCLY(I,K) - TAUCL(I,K) = TAUCL(I,K) * CCLY(I,K) * SQRT(CCLY(I,K)) - END DO - END DO - ELSE - DO K=1,L - DO I=1,IMAX -!0799 CCC = CCLY(I,K) * SQRT(CCLY(I,K)) - CCC = CCLY(I,K) - CWP(I,K) = CWP(I,K) * CCC - CIP(I,K) = CIP(I,K) * CCC - REWI(I,K) = 1.0 / REW(I,K) - REII(I,K) = 1.0 / REI(I,K) - END DO - END DO - END IF -! - IF (ISRC(4) .EQ. 1) THEN !===> ... COMPUTE NIR FLUXES -! ------------------ - CALL SOLIR(WH,TA,TAUCL,CSMIK,ZTHIK,IBND,FICE, - & ISRC(1),KPRF,IDXC,CMIX,DENN,RH,ALBIRB,ALBIRD, - & ICWP,CWP,CIP,CCLY,REW,REI,REWI,REII, - & TUPFXC,SUPFXC,SDNFXC,TUPFX0,SUPFX0,SDNFX0, - & FNET0,FNETC,SDN0NB,SDN0ND,SDNFNB,SDNFND, - & L, LP1, IMAX, NBD, NVB, NAE, NDM, NXC, NDN, - & HAER, IDM, DZ, HZ, TAUR) -! &, lprnt) - END IF -! - IF (ISRC(5) .EQ. 1) THEN !===> ... COMPUTE UV+VISIBLE FLUXES -! ------------------------- -! SCALED AMOUNTS FOR O3(WH), UNIT : (CM-AMT)STP FOR O3. - XA = 1.02 * 466.7 - DO K=1,L - DO I=1,IMAX - OH(I,K) = XA * OA(I,K) * DP(I,K) + 1.0E-11 - ENDDO - ENDDO -! - CALL SOLUV(WH,OH,TA,TAUCL,CSMIK,ZTHIK,FICE, - & ISRC(1),KPRF,IDXC,CMIX,DENN,RH,ALBUVB,ALBUVD, - & ICWP,CWP,CIP,CCLY,REW,REI,REWI,REII, - & TUPFXC,SUPFXC,SDNFXC,TUPFX0,SUPFX0,SDNFX0, - & FNET0,FNETC,SDN0VB,SDN0VD,SDNFVB,SDNFVD, -! --- FOR UV-B BAND FLUXES - & SUVBFC,SUVBF0, -! --- END UV-B - & L, LP1, IMAX, NBD, NVB, NAE, NDM, NXC, NDN, - & HAER, IDM, DZ, HZ, TAUR) -! &, lprnt) - - END IF -! -!===> ... COMPUTE THE ABSORPTION DUE TO OXYGEN,CHOU(1990,J.CLIMATE,209-217) -! PRESSURE SCALED AMOUNTS FOR O2(O2,SO2), UNIT IS (CM-ATM)STP FOR O2. -! THE CONSTANT 165.22=(1000/980)*23.14%*(22400/32) -! - IF (ISRC(2) .EQ. 1) THEN - DO I=1,IMAX - CNT(I) = 165.22 * SNT(I) - END DO - DO K=1,L - DO I=1,IMAX - SO2(I,K+1) = SO2(I,K) + CNT(I) * SCAL(I,K) - ENDDO - ENDDO -!===> ... COMPUTE FLUX REDUCTION DUE TO OXYGEN, THE CONSTANT 0.0633 IS -! THE FRACTION OF INSOLATION CONTAINED IN THE OXYGEN BANDS. -! TO2 IS THE BROADBAND TRANSMISSION FUNCTION FOR OXYGEN - DO K=2,LP1 - DO I=1,IMAX - TO2 = EXP(-0.145E-3 * SQRT(SO2(I,K)) ) - DFLX0(I,K) = 0.0633 * (1.0 - TO2) - ENDDO - ENDDO - END IF -! -!===> ... TABLE LOOK-UP FOR THE ABSORPTION DUE TO CO2 -! COMPUTE SCALED AMOUNTS FOR CO2(WC,SO2). -! THE CONSTANT 789=(1000/980)*(44/28.97)*(22400/44) -! - IF (ISRC(3) .EQ. 1) THEN - DO I=1,IMAX - CNT(I) = CO2 * SNT(I) - SO2(I,1) = MAX(SO2(I,1), cons_1pdm11) !constant - END DO - DO K=1,L - DO I=1,IMAX - SO2(I,K+1) = SO2(I,K) + 789.0 * CNT(I)*SCAL(I,K) - ENDDO - ENDDO -! -!===> ... FOR CO2 ABSORPTION IN SPECTRUM 1.220-2.270 MICRON -! BOTH WATER VAPOR AND CO2 ABSORPTIONS ARE MODERATE -! SO2 AND SWH ARE THE CO2 AND WATER VAPOR AMOUNTS -! INTEGRATED FROM THE TOP OF THE ATMOSPHERE -! - U1 = -3.0 - DU = 0.15 - W1 = -4.0 - DW = 0.15 - DO K=2,LP1 - DO I=1,IMAX - SWU(I,K) = LOG10(SO2(I,K)) - SWH(I,K) = LOG10(SWH(I,K)*SNT(I)) - END DO - END DO -! -!===> ... DFLX0 IS THE UPDATED FLUX REDUCTION -! - CALL FLXCO2(SWU,U1,DU,NU,SWH,W1,DW,NW,CAH,DFLX0 - &, L, IMAX) -! -!===> ... FOR CO2 ABSORPTION IN SPECTRUM 2.270-10.00 MICRON -! WHERE THE CO2 ABSORPTION HAS A LARGE IMPACT ON THE -! HEATING OF MIDDLE ATMOSPHERE -! - U1 = 0.250E-3 - DU = 0.050E-3 - W1 = -2.0 - DW = 0.05 -!===> ... CO2 MIXING RATIO IS INDEPENDENT OF SPACE -! SWH IS THE LOGARITHM OF PRESSURE - DO K=2,LP1 - DO I=1,IMAX - SWU(I,K) = CNT(I) - SWH(I,K) = LOG10(PL(I,K)) - END DO - END DO -!===> ... DFLX0 IS THE UPDATED FLUX REDUCTION -! - CALL FLXCO2(SWU,U1,DU,NX,SWH,W1,DW,NY,COA,DFLX0 - &, L, IMAX) -! - ENDIF -! -!===> ... ADJUST FOR THE EFFECT OF O2 AND CO2 ON CLEAR SKY NET FLUX -! - IF (ISRC(2).EQ.1 .OR. ISRC(3).EQ.1) THEN -! DO K=1,LP1 -! DO I=1,IMAX -! FNET0(I,K) = FNET0(I,K) - DFLX0(I,K) -! ENDDO -! ENDDO -! -!===> ... ADJUST FOR THE EFFECT OF O2 AND CO2 ON CLOUD SKY NET FLUX -! - DO I=1,IMAX - JTOP = LP1 -!===> ... ABOVE CLOUDS - DO K=1,LP1 - DFLXC(I,K) = DFLX0(I,K) - IF (CFAC(I,K) .LT. 1.0) THEN - JTOP = K - EXIT - END IF - END DO -!===> ... BELOW CLOUD TOP - IF (JTOP .LT. LP1) THEN - DO K=JTOP+1,LP1 - DFLXC(I,K) = DFLX0(I,K) * (FNETC(I,K)/FNET0(I,K)) - END DO - END IF - DO K=1,LP1 - FNET0(I,K) = FNET0(I,K) - DFLX0(I,K) - FNETC(I,K) = FNETC(I,K) - DFLXC(I,K) - END DO - ENDDO -! -!===> ... ADJUST FOR OTHER FLUXES -! - DO I=1,IMAX - SDNFX0(I) = SDNFX0(I) - DFLX0(I,LP1) - SDNFXC(I) = SDNFXC(I) - DFLXC(I,LP1) - SDN0NB(I) = SDN0NB(I) - DFLX0(I,LP1) - SDNFNB(I) = SDNFNB(I) - DFLXC(I,LP1) - ENDDO - END IF -! - IF (ICFC .EQ. 1) THEN -!===> ... COMPUTE FINAL FLUXES AT TOP AND SURFACE - DO I=1,IMAX - SDNFVB(I) = CF0(I)*SDN0VB(I) + CF1(I)*SDNFVB(I) - SDNFVD(I) = CF0(I)*SDN0VD(I) + CF1(I)*SDNFVD(I) - SDNFNB(I) = CF0(I)*SDN0NB(I) + CF1(I)*SDNFNB(I) - SDNFND(I) = CF0(I)*SDN0ND(I) + CF1(I)*SDNFND(I) - TUPFXC(I) = CF0(I)*TUPFX0(I) + CF1(I)*TUPFXC(I) - SUPFXC(I) = CF0(I)*SUPFX0(I) + CF1(I)*SUPFXC(I) - SDNFXC(I) = CF0(I)*SDNFX0(I) + CF1(I)*SDNFXC(I) -! --- FOR UV-B FLUX - SUVBFC(I) = CF0(I)*SUVBF0(I) + CF1(I)*SUVBFC(I) -! --- END UV-B - ENDDO - DO K=1,LP1 - DO I=1,IMAX - FNETC (I,K) = CF0(I)*FNET0(I,K) + CF1(I)*FNETC(I,K) - ENDDO - ENDDO - END IF -! -!===> ... CONVERT FLUX UNIT TO W/M**2 -! - DO K=1,LP1 - DO I=1,IMAX -!CLEAR FNET0 (I,K) = FNET0(I,K) * TDNFLX(I) - FNETC (I,K) = FNETC(I,K) * TDNFLX(I) - ENDDO - ENDDO - DO I=1,IMAX - SDNFNB(I) = SDNFNB(I) * TDNFLX(I) - SDNFND(I) = SDNFND(I) * TDNFLX(I) - SDNFVB(I) = SDNFVB(I) * TDNFLX(I) - SDNFVD(I) = SDNFVD(I) * TDNFLX(I) - TUPFX0(I) = TUPFX0(I) * TDNFLX(I) - TUPFXC(I) = TUPFXC(I) * TDNFLX(I) - SUPFX0(I) = SUPFX0(I) * TDNFLX(I) - SUPFXC(I) = SUPFXC(I) * TDNFLX(I) - SDNFX0(I) = SDNFX0(I) * TDNFLX(I) - SDNFXC(I) = SDNFXC(I) * TDNFLX(I) - -! --- FOR UV-B BAND FLUXES - SUVBF0(I) = SUVBF0(I) * TDNFLX(I) - SUVBFC(I) = SUVBFC(I) * TDNFLX(I) -! --- END UV-B - - ENDDO -! -!===> ... FAC IS THE FACTOR FOR HEATING RATES (IN K/DAY) -! IF USE K/SEC, RESULT SHOULD BE DEVIDED BY 86400. -! -! FAC = 3.6*24./10.031*.98 - FAC = 8.4410328 -! - DO K=1,L - DO I=1,IMAX -!CLEAR HTR0(I,K) = (FNET0(I,K)-FNET0(I,K+1)) * FAC / DP(I,K) - HTRC(I,K) = (FNETC(I,K)-FNETC(I,K+1)) * FAC / DP(I,K) - ENDDO - ENDDO -! - RETURN - END - SUBROUTINE SOLUV(WZ,OZ,TA,TAUCL,CSM,ZTH,FICE, - & KAER,KPRF,IDXC,CMIX,DENN,RH,ALBB,ALBD, - & ICWP,CWP,CIP,CCLY,REW,REI,REWI,REII, - & TUPFXC,SUPFXC,SDNFXC,TUPFX0,SUPFX0,SDNFX0, - & FNET0,FNETC,DWSFB0,DWSFD0,DWSFBC,DWSFDC, -! --- FOR UV-B BAND FLUXES - & SUVBFC,SUVBF0, -! --- END UV-B - & L,LP1,IMAX,NBD,NVB,NAE,NDM,NXC,NDN, - & HAER,IDM,DZ,HZ,TAUR) -! &, lprnt) -!FPP$ NOCONCUR R -!******************************************************************* -! COMPUTE SOLAR FLUX IN THE UV+VISIBLE REGION -! THE UV+VISIBLE REGION IS GROUPED INTO 8 BANDS: -! UV-C (.175-.225);(.225-.245,.260-.280);(.245-.260); -! UV-B (.280-.295);(.295-.310);(.310-.320); -! UV-A (.320-.400); -! PAR (.400-.700) -! -! INPUT PARAMETERS: UNITS -! WZ,OZ,TA,TAUCL,CSM,FICE,KAER,PAER,ALBB,ALBD -! ICWP,CWP,CIP,CCLV,REW,REI -! -! OUTPUT PARAMETERS: -! FNET0 : CLEAR SKY NET FLUX -! FNETC : CLOUDY SKY NET FLUX -! TUPFXC : CLOUDY SKY UPWARD FLUX AT TOA -! SUPFXC : CLOUDY SKY UPWARD FLUX AT SFC -! SDNFXC : CLOUDY SKY DOWNWARD FLUX AT SFC -! TUPFX0 : CLEAR SKY UPWARD FLUX AT TOA -! SUPFX0 : CLEAR SKY UPWARD FLUX AT SFC -! SDNFX0 : CLEAR SKY DOWNWARD FLUX AT SFC -! DWSFB0 : CLEAR SKY SFC DOWN DIR. FLUX -! DWSFD0 : CLEAR SKY SFC DOWN DIF. FLUX -! DWSFBC : CLOUDY SKY SFC DOWN DIR. FLUX -! DWSFDC : CLOUDY SKY SFC DOWN DIF. FLUX -! -! FIXED INPUT DATA: -! FRACTION OF SOLAR FLUX CONTAINED -! IN THE 8 BANDS (SS) FRACTION -! RAYLEIGH OPTICAL THICKNESS (TAURAY) /MB -! OZONE ABSORPTION COEFFICIENT (AK) /(CM-ATM)STP -! -! THE FOLLOWING PARAMETERS MUST BE SPECIFIED BY USERS: -! CLOUD ASYMMETRY FACTOR (ASYCL) N/D -! AEROSOL PARAMETERS ARE FROM SUBPROGRAM AEROS: -! -! PROGRAM HISTORY LOG: -! 94-06-12 M.D. CHOU, GLA. -! 95-02-09 YU-TAI HOU - RECODE FOR NMC MODELS -! 98-08-03 YU-TAI HOU - UPDATED CLOUD RADIATIVE PROPERTIES -! CALCULATION. USE SLINGO'S METHOD (JAS 1989) ON WATER -! CLOUD, EBERT AND CURRY'S METHOD (JGR 1992) ON ICE CLOUD. -! 99-03-25 YU-TAI HOU - UPDATED CLOUD PROPERTIES USE THE -! MOST RECENT CHOU ET AL. DATA (J. CLIM 1998) -! 99-04-27 YU-TAI HOU - UPDATED CLOUD RADIATIVE PROPERTY -! CALCULATIONS USE LINEAR T-ADJUSTED METHOD. -! 99-09-13 YU-TAI HOU - UPDATED TO CHOU'S JUNE,1999 VERSION -! -!******************************************************************** -! -! - USE MACHINE , ONLY : kind_rad - implicit none -! - integer nvbb -! PARAMETER (NVBB=4) - PARAMETER (NVBB=8) -! - integer L, LP1, IMAX, NBD, NVB, NAE, NDM, NXC, NDN - &, KAER, ICWP -! - integer IDM (IMAX,L,NAE), IDXC(NXC,IMAX), KPRF(IMAX) - real (kind=kind_rad) HAER(NDM,NAE) - &, DZ(IMAX,L), HZ(IMAX,L+1), TAUR(IMAX,L,NBD) - &, CMIX(NXC,IMAX), DENN(NDN,IMAX) -! -! --- INPUT - real (kind=kind_rad) - & OZ(IMAX,L), TAUCL(IMAX,L), ALBB(IMAX), ALBD(IMAX) - &, CSM(IMAX,L), ZTH(IMAX,L), RH(IMAX,L) - &, TA(IMAX,L), FICE(IMAX,L) - &, CWP(IMAX,L), CIP(IMAX,L), REW(IMAX,L), REI(IMAX,L) - &, CCLY(IMAX,L), WZ(IMAX,L) - &, REWI(IMAX,L), REII(IMAX,L) -! --- OUTPUT - real (kind=kind_rad) - & FNET0 (IMAX,LP1), DWSFB0(IMAX), DWSFD0(IMAX) - &, FNETC (IMAX,LP1), DWSFBC(IMAX), DWSFDC(IMAX) - &, TUPFXC(IMAX), SUPFXC(IMAX), SDNFXC(IMAX) - &, TUPFX0(IMAX), SUPFX0(IMAX), SDNFX0(IMAX) -! --- OUTPUT FOR UV-B BAND DOWNWARD SURFACE FLUXES - real (kind=kind_rad) - & SUVBFC(IMAX), SUVBF0(IMAX) -! --- TEMPORARY ARRAY - real (kind=kind_rad) - & UPFLUX(IMAX,LP1), DWFLUX(IMAX,LP1) - &, DWSFXB(IMAX), DWSFXD(IMAX) - &, TAUTO (IMAX,L), SSATO (IMAX,L), ASYTO (IMAX,L) - &, TAURS (IMAX,L), SSAT1 (IMAX,L), ASYT1 (IMAX,L) - &, TAUAER(IMAX,L), SSAAER(IMAX,L), ASYAER(IMAX,L) - &, FFFCW (IMAX,L), FFFT1 (IMAX,L), FFFTO (IMAX,L) - &, ASYCW (IMAX,L), SSACW (IMAX,L) -! --- SOLAR FLUX AND ABSORPTION COEFFICIENTS - &, SS(NVBB), AK(NVBB), WK(NVBB) -!0499 -! --- T ADJUSTED CLD PROPERTY METHOD - &, A0W(2), A1W(2), B0W(2), B1W(2), B0I(2), B1I(2), B2I(2) - &, A0I(2), A1I(2), C0W(2), C1W(2), C0I(2), C1I(2), C2I(2) - &, SSAW0(2), SSAI0(2), ASYW0(2), ASYI0(2) - &, FACW(IMAX,L), FACI(IMAX,L) - &, FFFRS0, FPMIN, FPMAX -! - logical cloudy(imax) - Integer ncloud -! logical lprnt -! -! - DATA SS / 0.00057, 0.00367, 0.00083, 0.00417, - & 0.00600, 0.00556, 0.05913, 0.39081 / - DATA AK / 30.47, 187.2, 301.9, 42.83, - & 7.090, 1.250, .0345, .0572 / - DATA WK / 7*0.0E0, 0.75E-3 / - DATA SSAW0 /.999998,.999998/, SSAI0 /.999994,.999995/ - & ASYW0 / 0.853, 0.853 /, ASYI0 / 0.7991, 0.7998/ - &, FFFRS0 / 0.1 / - DATA FPMIN, FPMAX / 1.0E-8, 0.999999 / -!0898 - COEFF FOR WATER CLOUD - D A T A -! --- T ADJUSTED WATER/ICE CLOUD COEFF. - & A0W / 0.2807E-1,0.2798E-1 /, A1W / 0.1307E+1,0.1309E+1 / - &, B0W / -.1176E-6,-.1810E-6 /, C0W / 0.8276E+0,0.8272E+0 / - &, B1W / 0.1770E-6,0.1778E-6 /, C1W / 0.2541E-2,0.2565E-2 / - &, A0I / -.3011E-4,-.5975E-5 /, A1I / 0.2519E+1,0.2517E+1 / - &, B0I / 0.1688E-6,0.1721E-6 /, C0I / 0.7473E+0,0.7480E+0 / - &, B1I / 0.9936E-7,0.9177E-7 /, C1I / 0.1015E-2,0.1015E-2 / - &, B2I /-.1114E-10,-.1125E-10/, C2I / -.2524E-5,-.2531E-5 / -! -c$$$ SAVE SS, AK, WK, ASYW0, ASYI0, SSAW0, SSAI0, FFFRS0, FPMIN, FPMAX -c$$$ SAVE A0W,A1W,B0W,B1W,C0W,C1W, -c$$$ & A0I,A1I,B0I,B1I,C0I,C1I,B2I,C2I -! - real (kind=kind_rad) tau1, tau2, ssa1, ssa2, asy1, asy2 - &, ssaw1, ssaw2, asyw1, asyw2, tauoz, tauwv - &, tem - integer i, k, iv -cc -cc-------------------------------------------------------------------- -cc - real(kind=kind_rad) cons_0 !constant - real(kind=kind_rad) cons_10 !constant - real(kind=kind_rad) cons_30 !constant -! integer ipnGlobal,its,mype -! logical DiagPrint -! call PhysicsGetIpnItsMype(ipnGlobal,its,mype,DiagPrint) - -cc - cons_0 = 0.d0 !constant - cons_10 = 10.d0 !constant - cons_30 = 30.d0 !constant -cc -cc-------------------------------------------------------------------- -cc -! - DO K=1,L - DO I=1,IMAX - FACW(I,K) = MAX(cons_0, MIN(cons_10,273.15-TA(I,K)))*0.1 !constant - FACI(I,K) = MAX(cons_0, MIN(cons_30,263.15-TA(I,K)))/30.0 !constant - ENDDO - ENDDO - cloudy(:) = .false. -! - IF (NVB .NE. NVBB) THEN - PRINT *,' NVB=',NVB,' NVBB=',NVBB,' RUN STOPPED' - STOP - ENDIF -! - IF (ICWP .NE. 1) THEN - DO K=1,L - DO I=1,IMAX - IF (TAUCL(I,K) .GT. 0.0) THEN - TAU2 = FICE(I,K) * TAUCL(I,K) - TAU1 = TAUCL(I,K) - TAU2 -C0499 - T-ADJ PROP FROM SPECIFIED SSA AND ASY - SSA1 = FACW(I,K)*SSAW0(1) + (1.0-FACW(I,K))*SSAW0(2) - SSA2 = FACI(I,K)*SSAI0(1) + (1.0-FACI(I,K))*SSAI0(2) - SSAW1 = SSA1 * TAU1 - SSAW2 = SSA2 * TAU2 -! SSA1 = (1.0-FICE(I,K))*(FACW(I,K) *SSAW0(1) -! & + (1.0-FACW(I,K))*SSAW0(2) ) -! SSA2 = FICE(I,K) *(FACI(I,K) *SSAI0(1) -! & + (1.0-FACI(I,K))*SSAI0(2) ) -! SSAW1 = SSA1 * TAUCL(I,K) -! SSAW2 = SSA2 * TAUCL(I,K) - SSACW(I,K) = SSAW1 + SSAW2 -! ASY1 = (1.0-FICE(I,K))*(FACW(I,K) *ASYW0(1) -! & + (1.0-FACW(I,K))*ASYW0(2) ) -! ASY2 = FICE(I,K) *(FACI(I,K) *ASYI0(1) -! & + (1.0-FACI(I,K))*ASYI0(2) ) - ASY1 = FACW(I,K)*ASYW0(1) + (1.0-FACW(I,K))*ASYW0(2) - ASY2 = FACI(I,K)*ASYI0(1) + (1.0-FACI(I,K))*ASYI0(2) - ASYW1 = ASY1 * SSAW1 - ASYW2 = ASY2 * SSAW2 - ASYCW(I,K) = ASYW1 + ASYW2 - FFFCW(I,K) = ASY1*ASYW1 + ASY2*ASYW2 - cloudy(i) = .true. - ELSE - SSACW(I,K) = 1.0 - ASYCW(I,K) = 0.0 - FFFCW(I,K) = 0.0 - END IF - ENDDO - ENDDO - ELSE - DO K=1,L - DO I=1,IMAX - IF (CCLY(I,K) .GT. 0.01) THEN -!0499 --- T-ADJ PROP FROM ICE/WATER PATHS - TAU1 = CWP(I,K)*( FACW(I,K) *(A0W(1)+A1W(1)*REWI(I,K)) - & +(1.-FACW(I,K))*(A0W(2)+A1W(2)*REWI(I,K))) - TAU2 = CIP(I,K)*( FACI(I,K) *(A0I(1)+A1I(1)*REII(I,K)) - & +(1.-FACI(I,K))*(A0I(2)+A1I(2)*REII(I,K))) - TAUCL(I,K) = TAU1 + TAU2 - SSA1 = 1.0 - ( FACW(I,K) *(B0W(1)+B1W(1)*REW(I,K)) - & + (1.-FACW(I,K))*(B0W(2)+B1W(2)*REW(I,K)) ) - SSA2 = 1.0 - ( FACI(I,K) *(B0I(1) - & + (B1I(1)+B2I(1)*REI(I,K))*REI(I,K)) - & + (1.-FACI(I,K))*(B0I(2) - & + (B1I(2)+B2I(2)*REI(I,K))*REI(I,K)) ) - SSAW1 = SSA1 * TAU1 - SSAW2 = SSA2 * TAU2 - SSACW(I,K) = SSAW1 + SSAW2 - ASY1 = FACW(I,K) *(C0W(1)+C1W(1)*REW(I,K)) - & + (1.-FACW(I,K))*(C0W(2)+C1W(2)*REW(I,K)) - ASY2 = FACI(I,K) *(C0I(1) - & + (C1I(1)+C2I(1)*REI(I,K))*REI(I,K) ) - & + (1.-FACI(I,K))*(C0I(2) - & + (C1I(2)+C2I(2)*REI(I,K))*REI(I,K) ) - ASYW1 = ASY1 * SSAW1 - ASYW2 = ASY2 * SSAW2 - ASYCW(I,K) = ASYW1 + ASYW2 - FFFCW(I,K) = ASY1*ASYW1 + ASY2*ASYW2 - cloudy(i) = .true. - ELSE - TAUCL(I,K) = 0.0 - SSACW(I,K) = 1.0 - ASYCW(I,K) = 0.0 - FFFCW(I,K) = 0.0 - END IF - ENDDO - ENDDO - END IF -! - NCLOUD = 0 - DO I=1,IMAX - if (cloudy(i)) ncloud = ncloud + 1 - ENDDO -! -!===> ... INTEGRATION OVER SPECTRAL BANDS -! - DO IV=1,NVB -! -!===> ... LAYER OPTICAL DEPTH DUE TO RAYLEIGH SCATTERING -! - DO K=1,L - DO I=1,IMAX - TAURS(I,K) = TAUR(I,K,IV) - SSAAER(I,K) = 0.0 - ASYAER(I,K) = 0.0 - TAUAER(I,K) = 0.0 - ENDDO - ENDDO -!JFM commented out the call to aeros -! if (kaer .ge. 1) then !==> AEROSOL OPTICAL PROPERTIES -! CALL AEROS(IV,KPRF,IDXC,CMIX,DENN,RH -! &, TAUAER,SSAAER,ASYAER -! &, L,IMAX,NAE,NBD,NDM,NXC, NDN -! &, HAER,IDM,DZ,HZ) -! endif -! -!===> ... COMPUTE TOTAL OPTICAL THICKNESS, SINGLE SCATTERING ALBEDO, -! AND ASYMMETRY FACTOR FOR CLEAR SKY -! - DO K=1,L - DO I=1,IMAX - TAUOZ = AK(IV)*OZ(I,K) - TAUWV = WK(IV)*WZ(I,K) - TAUTO(I,K) = MAX(FPMIN, TAUOZ+TAUWV+TAUAER(I,K)+TAURS(I,K)) - SSAT1(I,K) = SSAAER(I,K)*TAUAER(I,K) + TAURS(I,K) - ASYT1(I,K) = ASYAER(I,K)*SSAAER(I,K)*TAUAER(I,K) - FFFT1(I,K) = ASYAER(I,K)*ASYT1(I,K) + FFFRS0*TAURS(I,K) -! - SSATO(I,K) = MIN(FPMAX, SSAT1(I,K)/TAUTO(I,K)) - TEM = 1.0 / MAX(FPMIN, SSAT1(I,K)) - ASYTO(I,K) = ASYT1(I,K) * TEM - FFFTO(I,K) = FFFT1(I,K) * TEM - ENDDO - ENDDO -! -!===> ... CLEAR SKY FLUXES CALCULATIONS -! - CALL SWFLUX(TAUTO,SSATO,ASYTO,FFFTO,CSM,ZTH,ALBB,ALBD, - & UPFLUX,DWFLUX,DWSFXB,DWSFXD, L, LP1, IMAX) -! &, lprnt) -! - DO K=1,LP1 - DO I=1,IMAX -!JFM and BAO limited FNET0 by .01 - FNET0(I,K) = max(.01,FNET0(I,K) + - & (DWFLUX(I,K) - UPFLUX(I,K))*SS(IV)) - ENDDO - ENDDO - DO I=1,IMAX - TUPFX0(I) = TUPFX0(I) + UPFLUX(I,1) * SS(IV) - SUPFX0(I) = SUPFX0(I) + UPFLUX(I,LP1) * SS(IV) - SDNFX0(I) = SDNFX0(I) + DWFLUX(I,LP1) * SS(IV) - DWSFB0(I) = DWSFB0(I) + DWSFXB(I) * SS(IV) - DWSFD0(I) = DWSFD0(I) + DWSFXD(I) * SS(IV) - ENDDO - -! --- FOR UV-B FLUX OUTPUT - IF (IV.GE.5 .AND. IV.LE.6) THEN - DO I=1,IMAX - SUVBF0(I) = SUVBF0(I) + DWFLUX(I,LP1) * SS(IV) - ENDDO - END IF -! --- END UV-B - - IF (NCLOUD .GT. 0) THEN -! -!===> ... COMPUTE TOTAL OPTICAL THICKNESS, SINGLE SCATTERING ALBEDO, -! AND ASYMMETRY FACTOR FOR CLOUDY SKY -! - DO K=1,L - DO I=1,IMAX - IF (TAUCL(I,K) .GT. 0.0) THEN - TAUTO(I,K) = TAUCL(I,K) + TAUTO(I,K) - SSAT1(I,K) = SSACW(I,K) + SSAT1(I,K) - SSATO(I,K) = MIN(FPMAX, SSAT1(I,K)/TAUTO(I,K)) - TEM = 1.0 / MAX(FPMIN, SSAT1(I,K)) - ASYTO(I,K) = (ASYCW(I,K) + ASYT1(I,K)) * TEM - FFFTO(I,K) = (FFFCW(I,K) + FFFT1(I,K)) * TEM - END IF - ENDDO - ENDDO -C -C===> ... CLOUDY SKY FLUXES CALCULATIONS -C - CALL SWFLUX(TAUTO,SSATO,ASYTO,FFFTO,CSM,ZTH,ALBB,ALBD, - & UPFLUX,DWFLUX,DWSFXB,DWSFXD, L, LP1, IMAX) -! &, lprnt) -! - DO K=1,LP1 - DO I=1,IMAX - FNETC(I,K) = FNETC(I,K) + (DWFLUX(I,K) - UPFLUX(I,K))*SS(IV) - ENDDO - ENDDO - DO I=1,IMAX - TUPFXC(I) = TUPFXC(I) + UPFLUX(I,1) * SS(IV) - SUPFXC(I) = SUPFXC(I) + UPFLUX(I,LP1) * SS(IV) - SDNFXC(I) = SDNFXC(I) + DWFLUX(I,LP1) * SS(IV) - DWSFBC(I) = DWSFBC(I) + DWSFXB(I) * SS(IV) - DWSFDC(I) = DWSFDC(I) + DWSFXD(I) * SS(IV) - ENDDO - -! --- FOR UV-B FLUX OUTPUT - IF (IV.GE.5 .AND. IV.LE.6) THEN - DO I=1,IMAX - SUVBFC(I) = SUVBFC(I) + DWFLUX(I,LP1) * SS(IV) - ENDDO - END IF -! --- END UV-B - - ELSE - DO K=1,LP1 - DO I=1,IMAX - FNETC(I,K) = FNET0(I,K) - ENDDO - ENDDO - DO I=1,IMAX - TUPFXC(I) = TUPFX0(I) - SUPFXC(I) = SUPFX0(I) - SDNFXC(I) = SDNFX0(I) - DWSFBC(I) = DWSFB0(I) - DWSFDC(I) = DWSFD0(I) - ENDDO - - ENDIF -! - ENDDO ! INTEGRATION OVER SPECTRAL BANDS LOOP END -! - RETURN - END - - SUBROUTINE SOLIR(WH,TA,TAUCL,CSM,ZTH,IBND,FICE, - & KAER,KPRF,IDXC,CMIX,DENN,RH,ALBB,ALBD, - & ICWP,CWP,CIP,CCLY,REW,REI,REWI,REII, - & TUPFXC,SUPFXC,SDNFXC,TUPFX0,SUPFX0,SDNFX0, - & FNET0,FNETC,DWSFB0,DWSFD0,DWSFBC,DWSFDC, - & L,LP1,IMAX,NBD,NVB,NAE,NDM,NXC,NDN, - & HAER,IDM,DZ,HZ,TAUR) -! &, lprnt) -!FPP$ NOCONCUR R -!******************************************************************** -! COMPUTE SOLAR FLUX IN THE NIR REGION (3 BANDS, 10-K PER BAND) -! THE NIR REGION HAS THREE WATER VAPOR BANDS, TEN K's FOR EACH BAND. -! 1. 1000-4400 (/cm) 2.27-10.0 (micron) -! 2. 4400-8200 1.22-2.27 -! 3. 8200-14300 0.70-1.22 -! -! INPUT PARAMETERS: UNITS -! WH,TA,TAUCL,CSM,IBND,FICE,KAER,PAER,ALBB,ALBD -! ICWP,CWP,CIP,CCLV,REW,REI -! FIXED INPUT DATA: -! H2O ABSORPTION COEFFICIENT (XK) CM**2/GM -! K-DISTRIBUTION FUNCTION (HK) FRACTION -! -! THE FOLLOWING PARAMETERS MUST SPECIFIED BY USERS: -! CLOUD SINGLE SCATTERING ALBEDO (SACL) N/D -! CLOUD ASYMMETRY FACTOR (ASYCL) N/D -! AEROSOLS OPTICAL PARAMETERS ARE OBTAINED FROM CALLING -! SUBPROGRAM AEROS -! -! OUTPUT PARAMETERS: -! FNET0 : CLEAR SKY NET FLUX -! FNETC : CLOUDY SKY NET FLUX -! TUPFXC : CLOUDY SKY UPWARD FLUX AT TOA -! SUPFXC : CLOUDY SKY UPWARD FLUX AT SFC -! SDNFXC : CLOUDY SKY DOWNWARD FLUX AT SFC -! TUPFX0 : CLEAR SKY UPWARD FLUX AT TOA -! SUPFX0 : CLEAR SKY UPWARD FLUX AT SFC -! SDNFX0 : CLEAR SKY DOWNWARD FLUX AT SFC -! DWSFB0 : CLEAR SKY SFC DOWN DIR. FLUX -! DWSFD0 : CLEAR SKY SFC DOWN DIF. FLUX -! DWSFBC : CLOUDY SKY SFC DOWN DIR. FLUX -! DWSFDC : CLOUDY SKY SFC DOWN DIF. FLUX -! -! PROGRAM HISTORY LOG: -! 94-06-12 M.D. CHOU, GLA. -! 95-02-09 YU-TAI HOU - RECODE FOR NMC MODELS -! 98-08-03 YU-TAI HOU - UPDATED CLOUD RADIATIVE PROPERTIES -! CALCULATION. USE SLINGO'S METHOD (JAS 1989) ON WATER -! CLOUD, EBERT AND CURRY'S METHOD (JGR 1992) ON ICE CLOUD. -! 99-03-25 YU-TAI HOU - UPDATED CLOUD PROPERTIES USE THE -! MOST RECENT CHOU ET AL. DATA (J. CLIM 1998) -! 99-04-27 YU-TAI HOU - UPDATED CLOUD RADIATIVE PROPERTY -! CALCULATIONS USE LINEAR T-ADJUSTED METHOD. -!C 99-04-27 YU-TAI HOU - UPDATED CLOUD RADIATIVE PROPERTY -! CALCULATIONS USE LINEAR T-ADJUSTED METHOD. -! 99-09-13 YU-TAI HOU - UPDATED TO CHOU'S JUNE,1999 VERSION -! -!******************************************************************** -! -! - USE MACHINE , ONLY : kind_rad - implicit none -! - integer NRB, NK0 - PARAMETER (NRB=4,NK0=10) -! - integer L, LP1, IMAX, NBD, NVB, NAE, NDM, NXC, NDN - &, KAER, ICWP, IBND -! - integer IDM (IMAX,L,NAE), IDXC(NXC,IMAX), KPRF(IMAX) - real (kind=kind_rad) HAER(NDM,NAE) - &, DZ(IMAX,L), HZ(IMAX,L+1), TAUR(IMAX,L,NBD) - &, CMIX(NXC,IMAX), DENN(NDN,IMAX) -! -! --- INPUT - real (kind=kind_rad) - & WH(IMAX,L), TAUCL(IMAX,L), CSM(IMAX,L), RH(IMAX,L) - &, ALBB(IMAX), ALBD(IMAX), ZTH(IMAX,L) - &, CWP(IMAX,L), CIP(IMAX,L), REW(IMAX,L), REI(IMAX,L) - &, CCLY(IMAX,L), TA(IMAX,L), FICE(IMAX,L) - &, REWI(IMAX,L), REII(IMAX,L) -C --- OUTPUT - real (kind=kind_rad) - & FNET0 (IMAX,LP1), DWSFB0(IMAX), DWSFD0(IMAX) - &, FNETC (IMAX,LP1), DWSFBC(IMAX), DWSFDC(IMAX) - &, TUPFXC(IMAX), SUPFXC(IMAX), SDNFXC(IMAX) - &, TUPFX0(IMAX), SUPFX0(IMAX), SDNFX0(IMAX) -! - Integer ncloud - logical cloudy(imax) -! logical lprnt -! -! --- TEMPORARY ARRAY - real (kind=kind_rad) - & UPFLUX(IMAX,LP1), DWFLUX(IMAX,LP1) - &, DWSFXB(IMAX), DWSFXD(IMAX) - &, TAUTO (IMAX,L), SSATO (IMAX,L), ASYTO (IMAX,L) - &, TAURS (IMAX,L), SSAT1 (IMAX,L), ASYT1 (IMAX,L) - &, TAUAER(IMAX,L), SSAAER(IMAX,L), ASYAER(IMAX,L) - &, XK (NK0), HK (NK0,NRB) -!0499 --- T ADJUSTED CLD PROPERTY METHOD - &, SSAW0(NRB,2), SSAI0(NRB,2), ASYW0(NRB,2), ASYI0(NRB,2) - &, FFFCW (IMAX,L), FFFT1 (IMAX,L), FFFTO (IMAX,L) - &, ASYCW(IMAX,L), SSACW(IMAX,L) -! - real (kind=kind_rad) - & A0W(NRB,2), A1W(NRB,2), B0W(NRB,2), B1W(NRB,2) - &, A0I(NRB,2), A1I(NRB,2), C0W(NRB,2), C1W(NRB,2) - &, B0I(NRB,2), B1I(NRB,2), B2I(NRB,2), FACW(IMAX,L) - &, C0I(NRB,2), C1I(NRB,2), C2I(NRB,2), FACI(IMAX,L) - &, FFFRS0, FPMIN, FPMAX -! - DATA XK / 0.0010, 0.0133, 0.0422, 0.1334, 0.4217, - & 1.3340, 5.6230, 31.620, 177.80, 1000.0 / - DATA HK / .01074, .00360, .00411, .00421, .00389, - & .00326, .00499, .00465, .00245, .00145, - & .08236, .01157, .01133, .01143, .01240, - & .01258, .01381, .00650, .00244, .00094, - & .20673, .03497, .03011, .02260, .01336, - & .00696, .00441, .00115, .00026, .00000, - & .29983, .05014, .04555, .03824, .02965, - & .02280, .02321, .01230, .00515, .00239 / -! - DATA SSAW0/.7578,.9869,.9997,.9869, .7570,.9868,.9998,.9916/ - &, ASYW0/.8678,.8185,.8354,.8315, .8723,.8182,.8354,.8311/ - &, SSAI0/.7283,.9442,.9994,.9620, .7368,.9485,.9995,.9750/ - &, ASYI0/.9058,.8322,.8068,.8220, .9070,.8304,.8067,.8174/ - DATA FFFRS0 / 0.1 / - DATA FPMIN,FPMAX /1.0E-8, 0.999999/ -! - D A T A -!0499 - T-ADJUSTED CLD PROP COEFF, WATER CLOUD - & A0W / 1.466E-2, 2.276E-2, 2.654E-2, 2.494E-2 - &, 1.528E-2, 2.286E-2, 2.642E-2, 2.517E-2 / - &, A1W / 1.617E+0, 1.451E+0, 1.351E+0, 1.392E+0 - &, 1.611E+0, 1.449E+0, 1.353E+0, 1.386E+0 / - &, B0W / 1.708E-1, 5.314E-4,-4.594E-6, 6.473E-3 - &, 1.674E-1, 5.427E-4,-3.306E-6, 3.218E-3 / - &, B1W / 7.142E-3, 1.258E-3, 2.588E-5, 6.649E-4 - &, 7.561E-3, 1.263E-3, 2.287E-5, 5.217E-4 / - &, C0W / 8.266E-1, 7.507E-1, 7.925E-1, 7.811E-1 - &, 8.344E-1, 7.501E-1, 7.922E-1, 7.808E-1 / - &, C1W / 4.119E-3, 6.770E-3, 4.297E-3, 5.034E-3 - &, 3.797E-3, 6.812E-3, 4.323E-3, 5.031E-3 / -! - D A T A -!0499 - T-ADJUSTED CLD PROP COEFF, ICE CLOUD - & A0I / 2.822E-4,-3.248E-5,-3.758E-5,-1.214E-5 - &, 2.712E-4,-4.308E-5,-3.917E-5,-2.456E-5 / - &, A1I / 2.491E+0, 2.522E+0, 2.522E+0, 2.520E00 - &, 2.489E+0, 2.523E+0, 2.522E+0, 2.521E00 / - &, B0I / 1.853E-1, 2.544E-3,-7.701E-7, 1.461E-2 - &, 1.738E-1, 2.461E-3,-8.979E-7, 7.083E-3 / - &, B1I / 1.841E-3, 1.023E-3, 9.849E-6, 4.612E-4 - &, 1.887E-3, 9.436E-4, 8.102E-6, 3.495E-4 / - &, B2I /-6.671E-6,-2.266E-6,-.3988E-9,-1.202E-6 - &, -6.615E-6,-2.107E-6,-.1862E-9,-8.500E-7 / - &, C0I / 8.388E-1, 7.572E-1, 7.519E-1, 7.600E-1 - &, 8.414E-1, 7.566E-1, 7.519E-1, 7.566E-1 / - &, C1I / 1.519E-3, 1.563E-3, 1.099E-3, 1.275E-3 - &, 1.477E-3, 1.537E-3, 1.097E-3, 1.241E-3 / - &, C2I /-6.702E-6,-5.232E-6,-3.081E-6,-4.020E-6 - &, -6.403E-6,-5.130E-6,-3.070E-6,-3.804E-6 / -! -c$$$ SAVE XK, HK, SSAW0,SSAI0, ASYW0,ASYI0, FFFRS0, FPMIN, FPMAX -c$$$ SAVE A0W,A1W,B0W,B1W,C0W,C1W,A0I,A1I,B0I,B1I,B2I,C0I,C1I,C2I -! - real (kind=kind_rad) tau1, tau2, ssa1, ssa2, asy1, asy2 - &, ssaw1, ssaw2, asyw1, asyw2, tauwv - &, tem - integer i, k, ibb1, ibb2, ib, ib1, ik -cc -cc-------------------------------------------------------------------- -cc - real(kind=kind_rad) cons_0 !constant - real(kind=kind_rad) cons_10 !constant - real(kind=kind_rad) cons_30 !constant -! integer ipnGlobal,its,mype -! logical DiagPrint -! call PhysicsGetIpnItsMype(ipnGlobal,its,mype,DiagPrint) - -cc - cons_0 = 0.d0 !constant - cons_10 = 10.d0 !constant - cons_30 = 30.d0 !constant -cc -cc-------------------------------------------------------------------- -cc -! - DO K=1,L - DO I=1,IMAX - FACW(I,K) = MAX(cons_0, MIN(cons_10,273.15-TA(I,K)))*0.1 !constant - FACI(I,K) = MAX(cons_0, MIN(cons_30,263.15-TA(I,K)))/30.0 !constant - ENDDO - ENDDO -! -!===> ... LOOP OVER THREE NIR BANDS -! - IF (IBND .EQ. 1) THEN - IBB1 = NRB - IBB2 = NRB - ELSE - IBB1 = 1 - IBB2 = NRB - 1 - END IF - DO IB=IBB1,IBB2 - IB1 = NVB + IB -! -!===> ... LAYER OPTICAL DEPTH DUE TO RAYLEIGH SCATTERING -! - DO K=1,L - DO I=1,IMAX - TAURS(I,K) = TAUR(I,K,IB1) - SSAAER(I,K) = 0.0 - ASYAER(I,K) = 0.0 - TAUAER(I,K) = 0.0 - ENDDO - ENDDO -!JFM commented out the call to aeros -! if (kaer .ge. 1) then !==> AEROSOL OPTICAL PROPERTIES -! CALL AEROS(IB1,KPRF,IDXC,CMIX,DENN,RH -! &, TAUAER,SSAAER,ASYAER -! &, L,IMAX,NAE,NBD,NDM,NXC, NDN -! &, HAER,IDM,DZ,HZ) -! endif - cloudy(:) = .false. -! -!0898 ... GET CLOUD PROPERTIES FROM CWP AND CIP -! - IF (ICWP .EQ. 1) THEN - DO K=1,L - DO I=1,IMAX - IF (CCLY(I,K) .GT. 0.0) THEN -! --- T-ADJ METHOD - TAU1=CWP(I,K)*( FACW(I,K) *(A0W(IB,1)+A1W(IB,1)*REWI(I,K)) - & +(1.0-FACW(I,K))*(A0W(IB,2)+A1W(IB,2)*REWI(I,K))) - TAU2=CIP(I,K)*( FACI(I,K) *(A0I(IB,1)+A1I(IB,1)*REII(I,K)) - & +(1.0-FACI(I,K))*(A0I(IB,2)+A1I(IB,2)*REII(I,K))) - TAUCL(I,K) = TAU1 + TAU2 - SSA1 = 1.0 - ( FACW(I,K) *(B0W(IB,1)+B1W(IB,1)*REW(I,K)) - & + (1.0-FACW(I,K))*(B0W(IB,2)+B1W(IB,2)*REW(I,K))) - SSA2 = 1.0 - ( FACI(I,K) *(B0I(IB,1) - & + (B1I(IB,1)+B2I(IB,1)*REI(I,K))*REI(I,K)) - & + (1.0-FACI(I,K))*(B0I(IB,2) - & + (B1I(IB,2)+B2I(IB,2)*REI(I,K))*REI(I,K)) ) - SSAW1 = SSA1 * TAU1 - SSAW2 = SSA2 * TAU2 - SSACW(I,K) = SSAW1 + SSAW2 - ASY1 = FACW(I,K) *(C0W(IB,1)+C1W(IB,1)*REW(I,K)) - & + (1.0-FACW(I,K))*(C0W(IB,2)+C1W(IB,2)*REW(I,K)) - ASY2 = FACI(I,K) *(C0I(IB,1) - & + (C1I(IB,1)+C2I(IB,1)*REI(I,K))*REI(I,K)) - & + (1.0-FACI(I,K))*(C0I(IB,2) - & + (C1I(IB,2)+C2I(IB,2)*REI(I,K))*REI(I,K)) - ASYW1 = ASY1 * SSAW1 - ASYW2 = ASY2 * SSAW2 - ASYCW(I,K) = ASYW1 + ASYW2 - FFFCW(I,K) = ASY1*ASYW1 + ASY2*ASYW2 - cloudy(i) = .true. - ELSE - TAUCL(I,K) = 0.0 - SSACW(I,K) = 1.0 - ASYCW(I,K) = 0.0 - FFFCW(I,K) = 0.0 - END IF - ENDDO - ENDDO - ELSE - DO K=1,L - DO I=1,IMAX - IF (TAUCL(I,K) .GT. 0.0) THEN - TAU2 = FICE(I,K) * TAUCL(I,K) - TAU1 = TAUCL(I,K) - TAU2 - SSA1 = FACW(I,K)*SSAW0(IB,1) + (1.0-FACW(I,K))*SSAW0(IB,2) - SSA2 = FACI(I,K)*SSAI0(IB,1) + (1.0-FACI(I,K))*SSAI0(IB,2) - SSAW1 = SSA1 * TAU1 - SSAW2 = SSA2 * TAU2 -! SSA1 = (1.0-FICE(I,K)) * (FACW(I,K) * SSAW0(IB,1) -! & + (1.0-FACW(I,K))* SSAW0(IB,2)) -! SSA2 = FICE(I,K) * (FACI(I,K) * SSAI0(IB,1) -! & + (1.0-FACI(I,K))* SSAI0(IB,2)) -! SSAW1 = SSA1 * TAUCL(I,K) -! SSAW2 = SSA2 * TAUCL(I,K) - SSACW(I,K) = SSAW1 + SSAW2 -! ASY1 = (1.0-FICE(I,K)) * (FACW(I,K) * ASYW0(IB,1) -! & + (1.0-FACW(I,K))* ASYW0(IB,2)) -! ASY2 = FICE(I,K) * (FACI(I,K) * ASYI0(IB,1) -! & + (1.0-FACI(I,K))* ASYI0(IB,2)) - ASY1 = FACW(I,K)*ASYW0(IB,1) + (1.0-FACW(I,K))*ASYW0(IB,2) - ASY2 = FACI(I,K)*ASYI0(IB,1) + (1.0-FACI(I,K))*ASYI0(IB,2) - ASYW1 = ASY1 * SSAW1 - ASYW2 = ASY2 * SSAW2 - ASYCW(I,K) = ASYW1 + ASYW2 - FFFCW(I,K) = ASY1*ASYW1 + ASY2*ASYW2 - cloudy(i) = .true. - ELSE - SSACW(I,K) = 1.0 - ASYCW(I,K) = 0.0 - FFFCW(I,K) = 0.0 - END IF - ENDDO - ENDDO - END IF -! - NCLOUD = 0 - DO I=1,IMAX - if (cloudy(i)) ncloud = ncloud + 1 - ENDDO -! -!===> ... IK IS THE INDEX FOR THE K-DISTRIBUTION FUNCTION (OR THE -! ABSORPTION COEFFICIENT) -! - DO IK=1,NK0 -! - IF (HK(IK,IB) .GE. 0.00001) THEN -! -!===> ... COMPUTE TATAL OPTICAL THICKNESS, SINGLE SCATTERING ALBEDO, -! AND ASYMMETRY FACTOR FOR CLEAR SKY -! - DO K=1,L - DO I=1,IMAX - TAUWV = XK(IK)*WH(I,K) - TAUTO(I,K) = MAX(FPMIN, TAUWV+TAUAER(I,K)+TAURS(I,K)) - SSAT1(I,K) = SSAAER(I,K)*TAUAER(I,K)+TAURS(I,K) - ASYT1(I,K) = ASYAER(I,K)*SSAAER(I,K)*TAUAER(I,K) - FFFT1(I,K) = ASYAER(I,K)*ASYT1(I,K) + FFFRS0*TAURS(I,K) - SSATO(I,K) = MIN(FPMAX, SSAT1(I,K)/TAUTO(I,K)) - TEM = 1.0 / MAX(FPMIN, SSAT1(I,K)) - ASYTO(I,K) = ASYT1(I,K) * TEM - FFFTO(I,K) = FFFT1(I,K) * TEM - ENDDO - ENDDO -! -!===> ... CLEAR SKY FLUXES CALCULATIONS -! - CALL SWFLUX(TAUTO,SSATO,ASYTO,FFFTO,CSM,ZTH,ALBB,ALBD, - & UPFLUX,DWFLUX,DWSFXB,DWSFXD, L, LP1, IMAX) -! &, lprnt) -! - DO K=1,LP1 - DO I=1,IMAX -!JFM and BAO limited FNET0 to .01 - FNET0 (I,K) = max(.01,FNET0 (I,K) - & + (DWFLUX(I,K) - UPFLUX(I,K))*HK(IK,IB)) - ENDDO - ENDDO - DO I=1,IMAX - TUPFX0(I) = TUPFX0(I) + UPFLUX(I,1) * HK(IK,IB) - SUPFX0(I) = SUPFX0(I) + UPFLUX(I,LP1) * HK(IK,IB) - SDNFX0(I) = SDNFX0(I) + DWFLUX(I,LP1) * HK(IK,IB) - DWSFB0(I) = DWSFB0(I) + DWSFXB(I) * HK(IK,IB) - DWSFD0(I) = DWSFD0(I) + DWSFXD(I) * HK(IK,IB) - ENDDO - IF (NCLOUD .GT. 0) THEN -! -!===> ... COMPUTE TATAL OPTICAL THICKNESS, SINGLE SCATTERING ALBEDO, -! AND ASYMMETRY FACTOR FOR CLOUDY SKY -! - DO K=1,L - DO I=1,IMAX - IF (TAUCL(I,K) .GE. 0.001) THEN - TAUTO(I,K) = TAUCL(I,K) + TAUTO(I,K) - SSAT1(I,K) = SSACW(I,K) + SSAT1(I,K) - SSATO(I,K) = MIN(FPMAX, SSAT1(I,K)/TAUTO(I,K)) - TEM = 1.0 / MAX(FPMIN, SSAT1(I,K)) - ASYTO(I,K) = (ASYCW(I,K) + ASYT1(I,K)) * TEM - FFFTO(I,K) = (FFFCW(I,K) + FFFT1(I,K)) * TEM - END IF - ENDDO - ENDDO -! -!===> ... CLOUDY SKY FLUXES CALCULATIONS -! - CALL SWFLUX(TAUTO,SSATO,ASYTO,FFFTO,CSM,ZTH,ALBB,ALBD, - & UPFLUX,DWFLUX,DWSFXB,DWSFXD, L, LP1, IMAX) -! &, lprnt) -! - DO K=1,LP1 - DO I=1,IMAX - FNETC(I,K) = FNETC(I,K) - & + (DWFLUX(I,K) - UPFLUX(I,K))*HK(IK,IB) - ENDDO - ENDDO - DO I=1,IMAX - TUPFXC(I) = TUPFXC(I) + UPFLUX(I,1) * HK(IK,IB) - SUPFXC(I) = SUPFXC(I) + UPFLUX(I,LP1) * HK(IK,IB) - SDNFXC(I) = SDNFXC(I) + DWFLUX(I,LP1) * HK(IK,IB) - DWSFBC(I) = DWSFBC(I) + DWSFXB(I) * HK(IK,IB) - DWSFDC(I) = DWSFDC(I) + DWSFXD(I) * HK(IK,IB) - ENDDO - ELSE - DO K=1,LP1 - DO I=1,IMAX - FNETC(I,K) = FNET0(I,K) - ENDDO - ENDDO - DO I=1,IMAX - TUPFXC(I) = TUPFX0(I) - SUPFXC(I) = SUPFX0(I) - SDNFXC(I) = SDNFX0(I) - DWSFBC(I) = DWSFB0(I) - DWSFDC(I) = DWSFD0(I) - ENDDO - ENDIF -! - ENDIF - ENDDO ! K-distribution loop ends here - ENDDO ! Loop over NIR bands ends here -! - RETURN - END - - SUBROUTINE SWFLUX(TAU,SSC,G0,FF,CSM,ZTH,ALB,ALD, - & UPFLUX,DWFLUX,DWSFCB,DWSFCD, L, LP1, IMAX) -! &, lprnt) -!FPP$ NOCONCUR R -!******************************************************************** -! USES THE DELTA-EDDINGTON APPROXIMATION TO COMPUTE THE BULK -! SCATTERING PROPERTIES OF A SINGLE LAYER CODED FOLLOWING -! COAKLEY ET AL. (JAS, 1982) -! -! INPUTS: -! TAU: THE EFFECTIVE OPTICAL THICKNESS -! SSC: THE EFFECTIVE SINGLE SCATTERING ALBEDO -! G0: THE EFFECTIVE ASYMMETRY FACTOR -! FF: THE EFFECTIVE FORWARD SCATTERING FACTOR -! CSM: THE EFFECTIVE SECANT OF THE ZENITH ANGLE -! ALB: SURFACE ALBEDO FOR DIRECT RADIATION -! ALD: SURFACE ALBEDO FOR DIFFUSED RADIATION -! -! OUTPUTS: -! UPFLUX: UPWARD FLUXES -! DWFLUX: DOWNWARD FLUXES -! DWSFCB: DOWNWARD SURFACE FLUX DIRECT COMPONENT -! DWSFCD: DOWNWARD SURFACE FLUX DIFFUSED COMPONENT -!******************************************************************** -! -! - USE MACHINE , ONLY : kind_rad - implicit none -! - integer L, LP1, IMAX -! -! --- INPUT - real (kind=kind_rad) - & TAU(IMAX,L), SSC(IMAX,L), G0(IMAX,L), FF(IMAX,L) - &, CSM(IMAX,L), ZTH(IMAX,L), ALB(IMAX), ALD(IMAX) -! --- OUTPUT - real (kind=kind_rad) - & UPFLUX(IMAX,LP1),DWFLUX(IMAX,LP1),DWSFCB(IMAX),DWSFCD(IMAX) -! --- TEMPORARY - real (kind=kind_rad) - & TTB(IMAX,LP1),TDN(IMAX,LP1),RUP(IMAX,LP1), TT (IMAX,LP1,2) - &, RFU(IMAX,LP1),RFD(IMAX,LP1),TB (IMAX,LP1), RR (IMAX,LP1,2) -! logical lprnt -! - real (kind=kind_rad) ZTHD, CSMD, EPSLN, AA, TAUP, SSCP, GP - &, OMS1, OGS1, TLAM, U1, U1P1, U1M1, E1 - &, U1E, U1EPE, U1EME, DEN, RF1, TF1, ZZTH - &, ZZ, DEN1, GAMA, ALFA, AMG, APG, ZA - &, SLAM, BB - integer I, K, KM1 -cc -cc-------------------------------------------------------------------- -cc - real(kind=kind_rad) cons_0 !constant - real(kind=kind_rad) cons_m30 !constant - real(kind=kind_rad) cons_30 !constant -! integer ipnGlobal,its,mype -! logical DiagPrint -! call PhysicsGetIpnItsMype(ipnGlobal,its,mype,DiagPrint) - -cc - cons_0 = 0.d0 !constant - cons_m30 = -30.d0 !constant - cons_30 = 30.d0 !constant -cc -cc-------------------------------------------------------------------- -cc -! -!===> ... DIFFUSE INCIDENT RADIATION IS APPROXIMATED BY BEAM RADIATION -! WITH AN INCIDENT ANGLE OF 53 DEGREES. COS(53) = 0.602 - ZTHD = 0.602 - CSMD = 1.0 / ZTHD - epsln = 1.0e-30 -! -!===> ... DELTA-EDDINGTON SCALING OF SINGLE SCATTERING ALBEDO, -! OPTICAL THICKNESS, AND ASYMMETRY FACTOR, K & H EQS(27-29) -! - - DO K=1,L - DO I=1,IMAX - AA = 1.0 - FF(I,K)*SSC(I,K) - TAUP = TAU(I,K) * AA - SSCP = SSC(I,K) * (1.0 - FF(I,K)) / AA - GP = (G0(I,K) - FF(I,K)) / (1.0 - FF(I,K)) -! - OMS1 = 1.0 - SSCP - OGS1 = 1.0 - SSCP*GP - TLAM = 3.0 * OMS1*OGS1 - SLAM = SQRT(TLAM) -! - U1 = 1.5 * OGS1 / SLAM - U1P1 = U1 + 1.0 - U1M1 = U1 - 1.0 - E1 = EXP(max(-TAUP*SLAM, cons_m30)) !constant - U1E = U1 * E1 - U1EPE = U1E + E1 - U1EME = U1E - E1 - DEN = 1.0 / ((U1P1 + U1EME)*(U1P1 - U1EME)) - RF1 = (U1P1 + U1EPE) * (U1M1 - U1EME) * DEN - TF1 = 4.0 * U1E * DEN -! -!===> ... COMPUTE LAYER TRANSMISSIONS AND REFLECTIONS -! (I,K,J) J=1,2 FOR LAYER K ILLUMINATED BY DIFFUSE AND -! DIRECT INCOMING RADIATION -! RR : LAYER REFLECTION -! TT : LAYER TOTAL TRANSMISSION -! TB : LAYER DIRECT TRANSMISSION -! -! Diffuse Radiation -! ----------------- - ZZTH = ZTHD - ZZ = ZZTH * ZZTH - DEN1 = 1.0 - TLAM*ZZ - IF (ABS(DEN1) .LT. 1.0E-8) THEN !===> ... SAFETY CHECK - ZZTH = ZZTH + 0.001 - ZZ = ZZTH * ZZTH - DEN1 = 1.0 - TLAM*ZZ - END IF - DEN1 = SSCP / DEN1 -! - GAMA = 0.50 * (1.0 + 3.0*GP*OMS1*ZZ)*DEN1 - ALFA = 0.75 * ZTHD * (GP + OGS1)*DEN1 - AMG = ALFA - GAMA - APG = ALFA + GAMA -! - TB(I,K) = EXP( -MIN(cons_30, TAUP*CSMD) ) !constant - ZA = AMG * TB(I,K) - RR(I,K,1) = ZA*TF1 + APG*RF1 - AMG - TT(I,K,1) = ZA*RF1 + APG*TF1 + (1.0-APG)*TB(I,K) -! -! Direct Radiation -! ---------------- - ZZTH = ZTH(I,K) - ZZ = ZZTH * ZZTH - DEN1 = 1.0 - TLAM*ZZ - IF (ABS(DEN1) .LT. 1.0E-8) THEN !===> ... SAFETY CHECK - ZZTH = ZZTH + 0.001 - ZZ = ZZTH * ZZTH - DEN1 = 1.0 - TLAM*ZZ - END IF - DEN1 = SSCP / DEN1 -! - GAMA = 0.50 * (1.0 + 3.0*GP*OMS1*ZZ)*DEN1 - ALFA = 0.75 * ZTH(I,K) * (GP + OGS1)*DEN1 - AMG = ALFA - GAMA - APG = ALFA + GAMA -! - TB(I,K) = EXP( -MIN(cons_30, TAUP*CSM(I,K)) ) !constant - ZA = AMG * TB(I,K) - RR(I,K,2) = ZA*TF1 + APG*RF1 - AMG - TT(I,K,2) = ZA*RF1 + APG*TF1 + (1.0-APG)*TB(I,K) -! - TB(I,K) = MAX(cons_0, TB(I,K)) !constant - RR(I,K,2) = MAX(cons_0, RR(I,K,2)) !constant - TT(I,K,2) = MAX(cons_0, TT(I,K,2)) !constant - RR(I,K,1) = MAX(cons_0, RR(I,K,1)) !constant - TT(I,K,1) = MAX(cons_0, TT(I,K,1)) !constant - ENDDO - ENDDO -! -! --- AT THE SURFACE -! - DO I=1,IMAX - TB(I,LP1) = 0.0 - RR(I,LP1,2) = ALB(I) - TT(I,LP1,2) = 0.0 - RR(I,LP1,1) = ALD(I) - TT(I,LP1,1) = 0.0 - END DO -! - DO I=1,IMAX - TTB(I,1) = TB(I,1) - TDN(I,1) = TT(I,1,2) - RFD(I,1) = RR(I,1,1) - TTB(I,L) = 0.0 - ENDDO -! -!===> ... LAYERS ADDED DOWNWARD STARTING FROM TOP -! - DO K=2,LP1 - DO I=1,IMAX - DEN = TT(I,K,1) / (1.0 - RFD(I,K-1) * RR(I,K,1)) - TTB(I,K) = TTB(I,K-1) * TB(I,K) - if (ttb(i,k) .lt. epsln) ttb(i,k) = 0.0 - TDN(I,K) = TTB(I,K-1)*TT(I,K,2)+(TDN(I,K-1)-TTB(I,K-1) - 1 + TTB(I,K-1)*RR(I,K,2)*RFD(I,K-1)) * DEN - RFD(I,K) = RR(I,K,1) + TT(I,K,1)*RFD(I,K-1) * DEN - ENDDO - ENDDO -! -!===> ... LAYERS ADDED UPWARD STARTING FROM SURFACE -! - DO I=1,IMAX - RFU(I,LP1) = RR(I,LP1,1) - RUP(I,LP1) = RR(I,LP1,2) - ENDDO - DO K=L,1,-1 - DO I=1,IMAX - DEN = TT(I,K,1) / (1.0 - RFU(I,K+1) * RR(I,K,1)) - RUP(I,K) = RR(I,K,2) + ((TT(I,K,2)-TB(I,K))*RFU(I,K+1) - 1 + TB(I,K)*RUP(I,K+1)) * DEN - RFU(I,K) = RR(I,K,1) + TT(I,K,1)*RFU(I,K+1) * DEN - ENDDO - ENDDO -! -!===> ... FIND UPWARD AND DOWNWARD FLUXES -! - DO I=1,IMAX - UPFLUX(I,1) = RUP(I,1) - DWFLUX(I,1) = 1.0 - ENDDO - DO K=2,LP1 - KM1 = K - 1 - DO I=1,IMAX - DEN = 1.0 / (1.0 - RFD(I,KM1)*RFU(I,K)) - AA = TTB(I,KM1) * RUP(I,K) - BB = TDN(I,KM1) - TTB(I,KM1) - UPFLUX(I,K) = (AA + BB*RFU(I,K)) * DEN - DWFLUX(I,K) = TTB(I,KM1) + (AA*RFD(I,KM1) + BB) * DEN - ENDDO - ENDDO - -! -!===> ... SURFACE DOWNWARD FLUXES -! - DO I=1,IMAX - DWSFCB(I) = TTB(I,L) - DWSFCD(I) = DWFLUX(I,LP1)-DWSFCB(I) - ENDDO -! - RETURN - END - - SUBROUTINE FLXCO2(SWC,U1,DU,NU,SWH,W1,DW,NW,TBL,DFLX - &, L, IMAX) -!FPP$ NOCONCUR R -!******************************************************************** -! COMPUTE THE ABSORPTION DUE TO CO2. REF: CHOU (J. CLIMATE, 1990, -! 209-217) -! UPDATED SEP. 1999 BASED ON NASA/TM-1999-104606, VOL 15. -! THE EFFECT OF CO2 ABSORPTION BELOW THE CLOUD TOP IS NEGLECTED. -! INPUT VARIABLES: -! SWC : COLUMN AMOUNT OF CO2 -! SWH : COLUMN AMOUNT OF WATER VAPOR -! U1,DU,W1,DW : COEFFICIENTS -! TBL : LOOK UP CO2 ABSORPTION TABLE -! NU,NW : TABLE DIMENSIONS -! OUTPUT VARIABLES: -! DFLX : ADDITIONAL FLUX REDUCTION DUE TO CO2 FOR CLEAR SKY -! -!******************************************************************** -! - USE MACHINE , ONLY : kind_rad - implicit none -! - integer imax, L, NU, NW - real (kind=kind_rad) SWC(IMAX,L+1), SWH(IMAX,L+1) - &, DFLX(IMAX,L+1), TBL(NU,NW) - real (kind=kind_rad) u1, du, w1, dw, x1, y1, clog, wlog, dc, dd - &, x2, y2 - integer i, k, ic, iw, ic1, iw1 -! -! ... TABLE LOOK-UP FOR THE REDUCTION OF CLEAR-SKY SOLAR -! - X1 = U1 - 0.5*DU - Y1 = W1 - 0.5*DW - DO K=2,L+1 - DO I=1,IMAX - CLOG = SWC(I,K) - WLOG = SWH(I,K) - IC = INT( (CLOG - X1)/DU + 1.0) - IW = INT( (WLOG - Y1)/Dw + 1.0) - IC = MAX(2, MIN(NU, IC)) - IW = MAX(2, MIN(NW, IW)) - IC1 = IC - 1 - IW1 = IW - 1 - DC = CLOG - FLOAT(IC-2)*DU - U1 - DD = WLOG - FLOAT(IW-2)*DW - W1 - X2 = TBL(IC1,IW1) + (TBL(IC1,IW)-TBL(IC1,IW1))/DW * DD - Y2 = X2 + (TBL(IC,IW1) - TBL(IC1,IW1))/DU * DC - DFLX(I,K) = DFLX(I,K) + Y2 - ENDDO - ENDDO -! - RETURN - END - SUBROUTINE AEROS(IB,KPRF,IDXC,CMIX,DENN,RH - &, TAU,SSA,ASY - &, L, IMAX, NAE, NBD, NDM, NXC, NDN - &, HAER, IDM, DZ, HZ) -!FPP$ NOCONCUR R -!******************************************************************** -! COMPUTE AEROSOLS OPTICAL PROPERTIES IN EIGHT UV+VIS BANDS AND -! FOUR NIR BANDS. THERE ARE SEVEN DIFFERENT VERTICAL PROFILE -! STRUCTURES. IN THE TROPOSPHERE, AEROSOL DISTRIBUTION AT EACH -! GRID POINT IS COMPOSED FROM UP TO SIX COMPONENTS OUT OF A TOTAL -! OF TEN DIFFERENT SUBSTANCES. -! REF: WMO REPORT WCP-112 (1986) -! -! 1999-10-13 Y.H. UPDATED TO OPAC DATA (1998) -! -! BAND: 1. 0.175-0.225 (UV-C) 2. 0.225-0.245;0.260-0.280 (UV-C) -! 3. 0.245-0.260 (UV-C) 4. 0.280-0.295 (UV-B) -! 5. 0.295-0.310 (UV-B) 6. 0.310-0.320 (UV-B) -! 7. 0.320-0.400 (UV-A) 8. 0.400-0.700 (PAR) -! 9. 2.27 - 4.0 (NIR) 10. 1.22 - 2.27 (NIR) -! 11. 0.70 - 1.22 (NIR) 12. 0.70 - 4.0 (NIR) -! -! INPUT VARIABLES: -! IB - SPECTRAL BAND INDEX - 1 -! KAER - =0 DO NOT COMPUTE AEROSOLS - 1 -! =1 COMPUTE AEROSOL PROFILES -! KPRF - INDECIES OF AEROSOL PROF STRUCTURES - IMAX -! IDXC - INDECIES OF AEROSOL COMPONENTS - NXC*IMAX -! CMIX - MIXING RATIOES OF AEROSOL COMPONENTS - NXC*IMAX -! DENN - AEROSOL NUMBER DENSITIES - NDN*IMAX -! RH - RELATIVE HUMIDITY - IMAX*L -! -! OUTPUT VARIABLES: -! TAU - OPTICAL DEPTH - IMAX*L -! SSA - SINGLE SCATTERING ALBEDO - IMAX*L -! ASY - ASYMMETRY PARAMETER - IMAX*L -! TAURS- RAYLEIGH SCATTERING OPTICAL DEPTH - IMAX*L -! -! VARIALBES IN COMMON BLOCK: -! HAER - SCALE HEIGHT OF AEROSOLS KM NDM*NAE -! IDM - AEROSOL DOMAIN INDEX - L*NAE -! DZ - LAYER THICKNESS KM L -! HZ - LEVEL HEIGHT KM L+1 -! TAUR - RAYLEIGH SCATTERING OPTICAL DEPTH - L*NBD -!******************************************************************** -! - USE MACHINE , ONLY : kind_rad - implicit none -! - integer ncm1, ncm2, ncm, ncf, nbdd - PARAMETER (NCM1=6, NCM2=4, NCM=NCM1+NCM2, NCF=3, NBDD=12) -! -! --- INPUT - integer L, IMAX, NAE, NBD, NDM, NXC, NDN - integer IDXC(NXC,IMAX), KPRF(IMAX), IDM(IMAX,L,NAE) -! - real (kind=kind_rad) CMIX(NXC,IMAX), DENN(NDN,IMAX), RH(IMAX,L) -! --- OUTPUT - real (kind=kind_rad) - & TAU(IMAX,L), SSA(IMAX,L), ASY(IMAX,L) -! --- AEROSOL DATA - real (kind=kind_rad) - & EXT0(NCM1,NBDD), SCA0(NCM1,NBDD), SSA0(NCM1,NBDD) - &, AEXT(NCF,NCM2,NBDD),BSCA(NCF,NCM2,NBDD),ASF0(NCM1,NBDD) - &, CSSA(NCF,NCM2,NBDD),DASF(NCF,NCM2,NBDD),ABPW(NCM2,NBDD) - &, ESTR(NBDD) -! - real (kind=kind_rad) HAER(NDM,NAE), DZ(IMAX,L), HZ(IMAX,L+1) -! - real (kind=kind_rad) crt1, crt2 - DATA CRT1,CRT2 / 30.0, 0.03333 / - SAVE CRT1, CRT2 - &, EXT0,SCA0,SSA0,AEXT,BSCA,ASF0,CSSA,DASF,ABPW,ESTR -! - integer i, j, k, idom, kpf, icmp, ib, ic, ic1 -! -! --- EXTINCTION COEFFS OF 6 NONE RH DEP COMPNTS IN 12 BANDS -! INSO SOOT MINM MIAM MICM MITR - DATA EXT0 - & /8.052E-03,1.356E-06,1.032E-04,2.821E-03,7.597E-02,5.445E-03, - & 8.076E-03,1.313E-06,1.023E-04,2.835E-03,7.608E-02,5.465E-03, - & 8.060E-03,1.342E-06,1.029E-04,2.826E-03,7.601E-02,5.452E-03, - & 8.112E-03,1.248E-06,1.010E-04,2.857E-03,7.625E-02,5.496E-03, - & 8.148E-03,1.173E-06,9.940E-05,2.879E-03,7.641E-02,5.527E-03, - & 8.156E-03,1.154E-06,9.895E-05,2.884E-03,7.645E-02,5.534E-03, - & 8.282E-03,8.612E-07,9.008E-05,2.969E-03,7.703E-02,5.650E-03, - & 8.524E-03,5.432E-07,6.925E-05,3.140E-03,7.811E-02,5.876E-03, - & 6.435E-03,7.664E-08,3.429E-06,2.452E-03,9.026E-02,6.150E-03, - & 9.062E-03,1.471E-07,1.413E-05,3.365E-03,8.368E-02,6.691E-03, - & 9.021E-03,2.626E-07,3.506E-05,3.411E-03,8.040E-02,6.348E-03, - & 8.823E-03,2.132E-07,2.628E-05,3.325E-03,8.214E-02,6.442E-03/ -! -! --- SCATTERING COEFFS OF 6 NONE RH DEP COMPNTS IN 12 BANDS -! INSO SOOT MINM MIAM MICM MITR - DATA SCA0 - & /4.447E-03,4.177E-07,8.264E-05,1.625E-03,4.142E-02,3.034E-03, - & 4.723E-03,4.061E-07,8.314E-05,1.662E-03,4.150E-02,3.080E-03, - & 4.539E-03,4.138E-07,8.281E-05,1.637E-03,4.145E-02,3.049E-03, - & 5.136E-03,3.887E-07,8.389E-05,1.718E-03,4.162E-02,3.149E-03, - & 5.404E-03,3.623E-07,8.453E-05,1.795E-03,4.184E-02,3.252E-03, - & 5.423E-03,3.540E-07,8.464E-05,1.817E-03,4.192E-02,3.285E-03, - & 5.729E-03,2.301E-07,8.277E-05,2.178E-03,4.367E-02,3.840E-03, - & 6.255E-03,1.129E-07,6.675E-05,2.750E-03,5.242E-02,4.909E-03, - & 5.553E-03,7.201E-10,2.423E-06,2.140E-03,6.357E-02,5.264E-03, - & 7.757E-03,6.464E-09,1.348E-05,3.178E-03,6.539E-02,6.172E-03, - & 7.229E-03,2.859E-08,3.417E-05,3.205E-03,6.186E-02,5.805E-03, - & 7.253E-03,1.972E-08,2.546E-05,3.119E-03,6.317E-02,5.886E-03/ -! -! --- SING SCTR ALBEDOES OF 6 NONE RH DEP COMPNTS IN 12 BANDS -! INSO SOOT MINM MIAM MICM MITR - DATA SSA0 - & /5.524E-01,3.081E-01,8.004E-01,5.760E-01,5.452E-01,5.571E-01, - & 5.846E-01,3.095E-01,8.125E-01,5.860E-01,5.455E-01,5.634E-01, - & 5.631E-01,3.086E-01,8.044E-01,5.793E-01,5.453E-01,5.592E-01, - & 6.329E-01,3.116E-01,8.307E-01,6.011E-01,5.459E-01,5.728E-01, - & 6.631E-01,3.084E-01,8.509E-01,6.230E-01,5.476E-01,5.884E-01, - & 6.647E-01,3.061E-01,8.560E-01,6.298E-01,5.483E-01,5.935E-01, - & 6.918E-01,2.672E-01,9.189E-01,7.336E-01,5.670E-01,6.797E-01, - & 7.336E-01,2.025E-01,9.651E-01,8.748E-01,6.708E-01,8.345E-01, - & 8.612E-01,8.972E-03,7.039E-01,8.739E-01,7.035E-01,8.567E-01, - & 8.565E-01,4.103E-02,9.460E-01,9.438E-01,7.816E-01,9.224E-01, - & 8.009E-01,1.024E-01,9.733E-01,9.395E-01,7.693E-01,9.142E-01, - & 8.228E-01,7.671E-02,9.463E-01,9.367E-01,7.693E-01,9.133E-01/ -! -! --- ASYMMETRY FACTORS OF 6 NONE RH DEP COMPNTS IN 12 BANDS -! INSO SOOT MINM MIAM MICM MITR - DATA ASF0 - & /9.390E-01,5.020E-01,7.320E-01,9.030E-01,9.460E-01,9.310E-01, - & 9.219E-01,4.873E-01,7.272E-01,8.946E-01,9.469E-01,9.256E-01, - & 9.333E-01,4.971E-01,7.304E-01,9.002E-01,9.463E-01,9.292E-01, - & 8.963E-01,4.653E-01,7.200E-01,8.820E-01,9.482E-01,9.175E-01, - & 8.798E-01,4.468E-01,7.126E-01,8.668E-01,9.484E-01,9.064E-01, - & 8.787E-01,4.437E-01,7.109E-01,8.627E-01,9.481E-01,9.031E-01, - & 8.600E-01,3.960E-01,6.880E-01,8.030E-01,9.400E-01,8.500E-01, - & 8.280E-01,3.306E-01,6.616E-01,7.342E-01,8.923E-01,7.742E-01, - & 8.989E-01,7.289E-02,3.909E-01,6.921E-01,8.067E-01,7.122E-01, - & 8.136E-01,1.494E-01,5.319E-01,6.878E-01,8.103E-01,6.977E-01, - & 7.864E-01,2.302E-01,6.087E-01,6.942E-01,8.406E-01,7.178E-01, - & 8.045E-01,1.937E-01,5.688E-01,6.920E-01,8.282E-01,7.110E-01/ -! -! --- FITTING COEFFS OF EXT OF 4 RH DEP COMPNTS IN 12 BANDS -! WASO/SSCM SSAM/SUSO - DATA (((AEXT(I,J,K),I=1,NCF),J=1,NCM2),K=1,6) - & /1.595E-05,1.330E-05,4.237E-10, 2.304E-03,2.784E-03,1.272E-09, - & 1.448E-01,1.770E-01,9.004E-08, 2.309E-04,2.389E-04,7.845E-10, - & 1.528E-05,1.268E-05,4.174E-10, 2.320E-03,2.798E-03,1.275E-09, - & 1.451E-01,1.773E-01,9.000E-08, 2.302E-04,2.409E-04,7.955E-10, - & 1.573E-05,1.310E-05,4.216E-10, 2.309E-03,2.789E-03,1.273E-09, - & 1.449E-01,1.771E-01,9.003E-08, 2.307E-04,2.396E-04,7.882E-10, - & 1.426E-05,1.176E-05,4.079E-10, 2.344E-03,2.820E-03,1.279E-09, - & 1.455E-01,1.778E-01,8.994E-08, 2.292E-04,2.440E-04,8.120E-10, - & 1.331E-05,1.090E-05,3.976E-10, 2.368E-03,2.842E-03,1.282E-09, - & 1.458E-01,1.782E-01,8.997E-08, 2.272E-04,2.461E-04,8.286E-10, - & 1.312E-05,1.073E-05,3.951E-10, 2.374E-03,2.848E-03,1.283E-09, - & 1.459E-01,1.782E-01,9.000E-08, 2.265E-04,2.462E-04,8.322E-10/ - DATA (((AEXT(I,J,K),I=1,NCF),J=1,NCM2),K=7,NBDD) - & /1.011E-05,8.090E-06,3.512E-10, 2.468E-03,2.964E-03,1.291E-09, - & 1.470E-01,1.805E-01,8.984E-08, 2.115E-04,2.436E-04,8.894E-10, - & 6.646E-06,5.898E-06,6.175E-11, 2.609E-03,3.191E-03,1.322E-09, - & 1.485E-01,1.805E-01,9.088E-08, 1.718E-04,2.079E-04,9.422E-10, - & 4.815E-07,8.023E-07,3.772E-12, 1.482E-03,2.153E-03,1.589E-09, - & 1.673E-01,1.966E-01,9.462E-08, 2.483E-05,3.554E-05,1.950E-11, - & 9.357E-07,7.900E-07,5.441E-12, 2.246E-03,3.217E-03,1.599E-09, - & 1.580E-01,1.893E-01,9.297E-08, 4.494E-05,6.263E-05,3.156E-11, - & 2.732E-06,2.527E-06,1.241E-11, 2.666E-03,3.547E-03,1.433E-09, - & 1.524E-01,1.844E-01,9.179E-08, 9.999E-05,1.327E-04,1.971E-10, - & 2.007E-06,1.856E-06,9.589E-12, 2.439E-03,3.323E-03,1.496E-09, - & 1.553E-01,1.868E-01,9.237E-08, 7.643E-05,1.000E-04,1.695E-10/ -! -! --- FITTING COEFFS OF SCA OF 4 RH DEP COMPNTS IN 12 BANDS -! WASO/SSCM SSAM/SUSO - DATA (((BSCA(I,J,K),I=1,NCF),J=1,NCM2),K=1,6) - & /1.431E-05,1.314E-05,4.229E-10, 2.303E-03,2.784E-03,1.272E-09, - & 1.448E-01,1.771E-01,8.997E-08, 2.309E-04,2.389E-04,7.845E-10, - & 1.400E-05,1.257E-05,4.168E-10, 2.319E-03,2.798E-03,1.275E-09, - & 1.451E-01,1.774E-01,8.996E-08, 2.302E-04,2.409E-04,7.955E-10, - & 1.421E-05,1.295E-05,4.209E-10, 2.309E-03,2.789E-03,1.273E-09, - & 1.449E-01,1.772E-01,8.997E-08, 2.307E-04,2.396E-04,7.882E-10, - & 1.355E-05,1.172E-05,4.077E-10, 2.344E-03,2.820E-03,1.279E-09, - & 1.455E-01,1.779E-01,8.993E-08, 2.292E-04,2.440E-04,8.120E-10, - & 1.294E-05,1.091E-05,3.976E-10, 2.368E-03,2.843E-03,1.282E-09, - & 1.458E-01,1.782E-01,8.997E-08, 2.272E-04,2.461E-04,8.286E-10, - & 1.276E-05,1.074E-05,3.951E-10, 2.374E-03,2.848E-03,1.283E-09, - & 1.459E-01,1.782E-01,9.000E-08, 2.265E-04,2.462E-04,8.322E-10/ - DATA (((BSCA(I,J,K),I=1,NCF),J=1,NCM2),K=7,NBDD) - & /9.919E-06,8.093E-06,3.512E-10, 2.468E-03,2.964E-03,1.291E-09, - & 1.470E-01,1.805E-01,8.984E-08, 2.115E-04,2.436E-04,8.894E-10, - & 6.505E-06,5.900E-06,6.173E-11, 2.609E-03,3.191E-03,1.322E-09, - & 1.485E-01,1.805E-01,9.088E-08, 1.718E-04,2.079E-04,9.422E-10, - & 1.224E-07,1.088E-07,1.425E-12, 1.088E-03,1.420E-03,1.191E-09, - & 1.223E-01,1.253E-01,6.140E-08, 9.093E-06,1.152E-05,1.221E-11, - & 8.152E-07,7.708E-07,5.416E-12, 2.240E-03,3.214E-03,1.588E-09, - & 1.542E-01,1.867E-01,8.824E-08, 4.481E-05,6.249E-05,3.148E-11, - & 2.570E-06,2.513E-06,1.240E-11, 2.665E-03,3.547E-03,1.432E-09, - & 1.518E-01,1.844E-01,9.171E-08, 9.999E-05,1.327E-04,1.971E-10, - & 1.848E-06,1.798E-06,9.430E-12, 2.411E-03,3.277E-03,1.467E-09, - & 1.507E-01,1.814E-01,8.835E-08, 7.545E-05,9.867E-05,1.674E-10/ -! -! --- FITTING COEFFS OF SSA OF 4 RH DEP COMPNTS IN 12 BANDS -! WASO/SSCM SSAM/SUSO - DATA (((CSSA(I,J,K),I=1,NCF),J=1,NCM2),K=1,6) - & /8.820E-01,1.329E-01,8.925E-02, 9.999E-01,2.130E-04,4.523E-05, - & 9.994E-01,1.319E-03,-8.368E-4, 1.000E+00,0.000E+00,0.000E+00, - & 9.071E-01,1.059E-01,6.894E-02, 9.999E-01,1.776E-04,-2.168E-5, - & 9.995E-01,1.062E-03,-6.559E-4, 1.000E+00,0.000E+00,0.000E+00, - & 8.904E-01,1.239E-01,8.248E-02, 9.999E-01,2.012E-04,2.292E-05, - & 9.994E-01,1.233E-03,-7.760E-4, 1.000E+00,0.000E+00,0.000E+00, - & 9.449E-01,6.534E-02,3.848E-02, 1.000E+00,1.244E-04,-1.202E-4, - & 9.997E-01,6.763E-04,-3.884E-4, 1.000E+00,0.000E+00,0.000E+00, - & 9.684E-01,3.971E-02,1.988E-02, 1.000E+00,7.586E-05,-1.400E-4, - & 9.998E-01,3.888E-04,-2.249E-4, 1.000E+00,0.000E+00,0.000E+00, - & 9.697E-01,3.814E-02,1.904E-02, 1.000E+00,6.654E-05,-1.230E-4, - & 9.999E-01,3.521E-04,-2.188E-4, 1.000E+00,0.000E+00,0.000E+00/ - DATA (((CSSA(I,J,K),I=1,NCF),J=1,NCM2),K=7,NBDD) - & /9.790E-01,2.712E-02,1.340E-02, 1.000E+00,0.000E+00,0.000E+00, - & 1.000E+00,0.000E+00,0.000E+00, 1.000E+00,0.000E+00,0.000E+00, - & 9.742E-01,3.376E-02,1.754E-02, 1.000E+00,0.000E+00,0.000E+00, - & 1.000E+00,0.000E+00,0.000E+00, 1.000E+00,0.000E+00,0.000E+00, - & 4.741E-01,-2.284E-2,4.737E-01, 7.713E-01,-2.185E-1,3.434E-01, - & 7.285E-01,-2.238E-1,2.247E-01, 4.767E-01,2.866E-01,2.205E-01, - & 8.438E-01,1.973E-01,1.269E-01, 9.962E-01,5.396E-04,-7.588E-3, - & 9.782E-01,-7.483E-3,-5.631E-2, 9.936E-01,4.980E-03,6.300E-04, - & 9.198E-01,1.049E-01,6.285E-02, 9.995E-01,1.023E-03,-7.783E-4, - & 9.960E-01,7.559E-03,-4.647E-3, 1.000E+00,-1.103E-7,-1.787E-6, - & 8.678E-01,1.263E-01,1.084E-01, 9.842E-01,-1.268E-2,1.762E-02, - & 9.728E-01,-1.375E-2,-1.121E-2, 9.651E-01,1.992E-02,1.374E-02/ -! -! --- FITTING COEFFS OF ASF OF 4 RH DEP COMPNTS IN 12 BANDS -! WASO/SSCM SSAM/SUSO - DATA (((DASF(I,J,K),I=1,NCF),J=1,NCM2),K=1,6) - & /7.240E-01,8.256E-02,3.256E-02, 7.758E-01,1.140E-01,1.584E-02, - & 8.495E-01,2.280E-02,-1.158E-1, 7.431E-01,7.601E-02,-1.690E-2, - & 7.178E-01,9.182E-02,3.936E-02, 7.739E-01,1.174E-01,1.304E-02, - & 8.500E-01,2.590E-02,-1.115E-1, 7.470E-01,7.510E-02,-2.346E-2, - & 7.220E-01,8.564E-02,3.483E-02, 7.752E-01,1.151E-01,1.491E-02, - & 8.497E-01,2.383E-02,-1.144E-1, 7.444E-01,7.571E-02,-1.909E-2, - & 7.085E-01,1.057E-01,4.957E-02, 7.710E-01,1.225E-01,8.826E-03, - & 8.507E-01,3.054E-02,-1.052E-1, 7.527E-01,7.373E-02,-3.331E-2, - & 7.013E-01,1.156E-01,5.817E-02, 7.681E-01,1.260E-01,7.093E-03, - & 8.505E-01,3.608E-02,-9.727E-2, 7.574E-01,7.191E-02,-3.971E-2, - & 7.003E-01,1.167E-01,5.963E-02, 7.674E-01,1.263E-01,7.395E-03, - & 8.502E-01,3.756E-02,-9.510E-2, 7.581E-01,7.138E-02,-4.017E-2/ - DATA (((DASF(I,J,K),I=1,NCF),J=1,NCM2),K=7,NBDD) - & /6.851E-01,1.307E-01,8.454E-02, 7.614E-01,1.239E-01,4.612E-03, - & 8.486E-01,5.475E-02,-6.403E-2, 7.681E-01,6.680E-02,-4.495E-2, - & 6.554E-01,1.454E-01,1.182E-01, 7.606E-01,1.143E-01,-2.758E-2, - & 8.424E-01,6.848E-02,-4.633E-2, 7.632E-01,8.161E-02,-2.990E-2, - & 3.633E-01,1.483E-01,2.637E-01, 7.303E-01,1.911E-01,8.386E-03, - & 8.526E-01,1.819E-01,-1.123E-1, 5.014E-01,2.269E-01,2.352E-01, - & 5.068E-01,1.733E-01,2.345E-01, 7.797E-01,1.068E-01,-9.434E-2, - & 8.157E-01,1.042E-01,4.413E-03, 6.629E-01,1.697E-01,1.018E-01, - & 5.899E-01,1.605E-01,1.771E-01, 7.728E-01,9.568E-02,-8.258E-2, - & 8.304E-01,8.425E-02,-3.121E-2, 7.264E-01,1.228E-01,2.347E-02, - & 5.476E-01,1.640E-01,2.019E-01, 7.725E-01,1.059E-01,-7.896E-2, - & 8.272E-01,9.706E-02,-2.339E-2, 6.906E-01,1.454E-01,6.351E-02/ -! -! --- POWER FACTOR FOR EXT, SCA FITTING COEFFS OF 4 RH DEP COMPNTS -! WASO SSAM SSCM SUSO WASO SSAM SSCM SUSO - DATA ABPW - & / 24.0, 33.0, 33.0, 28.0, 24.0, 33.0, 33.0, 28.0, - & 24.0, 33.0, 33.0, 28.0, 24.0, 33.0, 33.0, 28.0, - & 24.0, 33.0, 33.0, 28.0, 24.0, 33.0, 33.0, 28.0, - & 24.0, 33.0, 33.0, 28.0, 27.0, 33.0, 33.0, 28.0, - & 29.0, 33.0, 33.0, 34.0, 29.0, 33.0, 33.0, 34.0, - & 29.0, 33.0, 33.0, 31.0, 29.0, 33.0, 33.0, 31.0 / -! --- EXTINGCTION COEFFS IN STRATOSPHERE FOR 12 BANDS - DATA ESTR - & / 3.39E-4, 3.34E-4, 3.38E-4, 3.28E-4, 3.22E-4, 3.18E-4, - & 3.01E-4, 2.09E-4, 1.70E-5, 5.01E-5, 1.03E-4, 7.72E-5 / -! - real (kind=kind_rad) drh, ext1, sca1, ssa1, asf1, drh1, drh2 - &, ex00, sc00, ss00, as00, ssa2, asf2, ext2 - &, ex01, sc01, ss01, as01 - &, ex02, sc02, ss02, as02 - &, ex03, sc03, ss03, as03, hd, sig0u - &, sig0l, ratio, hdi, tt - if (NBD .NE. NBDD) then - print *,' IN AEROS NBD =', NBD,' NBDD=',NBDD - CALL ABORT - endif - DO I=1,IMAX -! - KPF = KPRF(I) - DO K=1,L - IDOM = IDM(I,K,KPF) - DRH = RH(I,K) - 0.5 -! - IF (IDOM .EQ. 1) THEN -! --- 1ST DOMAN - MIXING LAYER - EXT1 = 0.0 - SCA1 = 0.0 - SSA1 = 0.0 - ASF1 = 0.0 - DO ICMP=1,NXC - IC = IDXC(ICMP,I) - IF (IC .GT. NCM1) THEN - IC1 = IC - NCM1 - DRH1 = EXP(ABPW(IC1,IB)*DRH) - DRH2 = DRH * DRH - EX00 = AEXT(1,IC1,IB) + AEXT(2,IC1,IB)*DRH - & + AEXT(3,IC1,IB)*DRH1 - SC00 = BSCA(1,IC1,IB) + BSCA(2,IC1,IB)*DRH - & + BSCA(3,IC1,IB)*DRH1 - SS00 = CSSA(1,IC1,IB) + CSSA(2,IC1,IB)*DRH - & + CSSA(3,IC1,IB)*DRH2 - AS00 = DASF(1,IC1,IB) + DASF(2,IC1,IB)*DRH - & + DASF(3,IC1,IB)*DRH2 - ELSE IF (IC .GT. 0) THEN - EX00 = EXT0(IC,IB) - SC00 = SCA0(IC,IB) - SS00 = SSA0(IC,IB) - AS00 = ASF0(IC,IB) - ELSE - EX00 = 0.0 - SC00 = 0.0 - SS00 = 0.0 - AS00 = 0.0 - END IF - EXT1 = EXT1 + CMIX(ICMP,I) * EX00 - SCA1 = SCA1 + CMIX(ICMP,I) * SC00 - SSA1 = SSA1 + CMIX(ICMP,I) * SS00 * EX00 - ASF1 = ASF1 + CMIX(ICMP,I) * AS00 * SC00 - END DO - EXT2 = EXT1 * DENN(1,I) - SSA2 = SSA1 / EXT1 - ASF2 = ASF1 / SCA1 - ELSE IF (IDOM .EQ. 2) THEN -! --- 2ND DOMAIN - MINERAL TRANSPORT LAYERS - EXT2 = EXT0(6,IB) * DENN(2,I) - SSA2 = SSA0(6,IB) - ASF2 = ASF0(6,IB) - ELSE IF (IDOM .EQ. 3) THEN -! --- 3RD DOMAIN - FREE TROPOSPHERIC LAYERS -! 1:INSO 0.17E-3; 2:SOOT 0.4; 7:WASO 0.59983; N:730 - DRH1 = EXP(ABPW(1,IB)*DRH) - DRH2 = DRH * DRH - EX01 = EXT0(1,IB) - SC01 = SCA0(1,IB) - SS01 = SSA0(1,IB) - AS01 = ASF0(1,IB) - EX02 = EXT0(2,IB) - SC02 = SCA0(2,IB) - SS02 = SSA0(2,IB) - AS02 = ASF0(2,IB) - EX03 = AEXT(1,1,IB) + AEXT(2,1,IB)*DRH + AEXT(3,1,IB)*DRH1 - SC03 = BSCA(1,1,IB) + BSCA(2,1,IB)*DRH + BSCA(3,1,IB)*DRH1 - SS03 = CSSA(1,1,IB) + CSSA(2,1,IB)*DRH + CSSA(3,1,IB)*DRH2 - AS03 = DASF(1,1,IB) + DASF(2,1,IB)*DRH + DASF(3,1,IB)*DRH2 - EXT1 = 0.17E-3*EX01 + 0.4*EX02 + 0.59983*EX03 - SCA1 = 0.17E-3*SC01 + 0.4*SC02 + 0.59983*SC03 - SSA1 = 0.17E-3*SS01*EX01 + 0.4*SS02*EX02 + 0.59983*SS03*EX03 - ASF1 = 0.17E-3*AS01*SC01 + 0.4*AS02*SC02 + 0.59983*AS03*SC03 - EXT2 = EXT1 * 730.0 - SSA2 = SSA1 / EXT1 - ASF2 = ASF1 / SCA1 - ELSE IF (IDOM .EQ. 4) THEN -! --- 4TH DOMAIN - STRATOSPHERIC LAYERS - EXT2 = ESTR(IB) - SSA2 = 0.9 - ASF2 = 0.6 - ELSE -! --- UPPER STRATOSPHERE ASSUME NO AEROSOL - EXT2 = 0.0 - SSA2 = 1.0 - ASF2 = 0.0 - END IF -! - HD = HAER(IDOM,KPF) - IF (HD .GT. 0.0E0) THEN - HDI = 1.0 / HD - SIG0U = EXP(-HZ(I,K) *HDI) - SIG0L = EXP(-HZ(I,K+1)*HDI) - TAU(I,K) = EXT2 * HD*(SIG0L - SIG0U) - ELSE - TAU(I,K) = EXT2 * DZ(I,K) -! TAU(I,K) = (EXT2-HD*HH(K)*ALOG(0.5*(SIG0U+SIG0L)))*DZ(K) - END IF - SSA(I,K) = SSA2 - ASY(I,K) = ASF2 -! write(6,112) IB,K,I,IDOM,HD,HH(K),DRH,DZ(K),SIG0U,SIG0L, -! & DENN(1,I),DENN(2,I),EXT2,TAU(I,K),SSA2,ASF2 -!112 format(1x,'IB,K,I=',3i3,' IDOM,HD,HH,DRH=',i2,3f5.2, -! & ' DZ,SIG0U,SIG0L=',3f6.3,/' DENN=',2f8.2, -! & ' EXT2,TAU,SSA,ASF=',4f6.3) - END DO - END DO -! -!===> ... SMOOTH PROFILE AT DOMAIN BOUNDARIES -! - DO K=2,L - DO I=1,IMAX - RATIO = 1.0 - IF (TAU(I,K) .GT. 0.0) RATIO = TAU(I,K-1) / TAU(I,K) - TT = TAU(I,K) + TAU(I,K-1) - IF (RATIO .GT. CRT1) THEN - TAU(I,K) = 0.2 * TT - TAU(I,K-1) = TT - TAU(I,K) - ELSE IF (RATIO .LT. CRT2) THEN - TAU(I,K) = 0.8 * TT - TAU(I,K-1) = TT - TAU(I,K) - END IF - ENDDO - ENDDO -! - RETURN - END diff --git a/src/fim/FIMsrc/fim/column/tracer_const_h-new.f b/src/fim/FIMsrc/fim/column/tracer_const_h-new.f deleted file mode 100755 index bb63837..0000000 --- a/src/fim/FIMsrc/fim/column/tracer_const_h-new.f +++ /dev/null @@ -1,38 +0,0 @@ - module tracer_const - use machine , only : kind_phys - implicit none - SAVE - - real(kind=kind_phys) ri(0:20),cpi(0:20) - integer, parameter :: num_tracer=3 - - contains -! ------------------------------------------------------------------- - subroutine set_tracer_const (ntrac,me,nlunit) - use machine , only : kind_phys - use physcons , only : rd => con_rd , cpd => con_cp - implicit none - integer ntrac,me,nlunit - namelist /tracer_constant/ ri,cpi - -c - if( ntrac.ne.num_tracer ) then - if( me.eq.0 ) then - write(*,*) ' Error ; inconsistent number of tracer ' - write(*,*) ' ntrac=',ntrac,' num_tracer=',num_tracer - endif - call abort - endif - - ri=0.0 - cpi=0.0 - ri(0)=rd - cpi(0)=cpd - - rewind(nlunit) - read(nlunit, tracer_constant) - - return - end subroutine set_tracer_const - - end module tracer_const diff --git a/src/fim/FIMsrc/fim/column/vert_def.f b/src/fim/FIMsrc/fim/column/vert_def.f deleted file mode 100644 index 815ad0d..0000000 --- a/src/fim/FIMsrc/fim/column/vert_def.f +++ /dev/null @@ -1,11 +0,0 @@ - module vert_def -! use resol_def - use machine - implicit none - - save - REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: am(:,:),bm(:,:),cm(:,:), - . dm(:,:,:),tor(:), si(:),sl(:),del(:),rdel2(:),ci(:), - . cl(:),tov(:),sv(:) - real(kind=kind_evod), allocatable :: slk(:), sik(:) - end module vert_def diff --git a/src/fim/FIMsrc/fim/column_chem/FIM_COLUMNC_OBJECTS b/src/fim/FIMsrc/fim/column_chem/FIM_COLUMNC_OBJECTS deleted file mode 100644 index 9d40e44..0000000 --- a/src/fim/FIMsrc/fim/column_chem/FIM_COLUMNC_OBJECTS +++ /dev/null @@ -1,34 +0,0 @@ -# column_chem objects - -OBJS = \ - module_aer_opt_out.o \ - module_aer_ra.o \ - module_chem_plumerise_scalar.o \ - module_data_rrtmgaeropt.o \ - module_chem_prep_fim.o \ - module_ctrans_grell.o \ - module_cu_g3.o \ - module_data_gocart_chem.o \ - module_data_gocart_dust.o \ - module_data_gocart_seas.o \ - module_data_sorgam.o \ - module_dry_dep_driver.o \ - module_gocart_aerosols.o \ - module_gocart_chem.o \ - module_gocart_dmsemis.o \ - module_gocart_drydep.o \ - module_gocart_dust.o \ - module_gocart_dust_afwa.o \ - module_gocart_opt.o \ - module_gocart_seasalt.o \ - module_gocart_settling.o \ - module_optical_averaging.o \ - module_optical_driver.o \ - module_peg_util.o \ - module_phot_mad.o \ - module_plumerise1.o \ - module_species_decs.o \ - module_vash_settling.o \ - module_vertmx_wrf.o \ - module_wetdep_ls.o \ - module_zero_plumegen_coms.o diff --git a/src/fim/FIMsrc/fim/column_chem/Makefile b/src/fim/FIMsrc/fim/column_chem/Makefile deleted file mode 100644 index 4a3515c..0000000 --- a/src/fim/FIMsrc/fim/column_chem/Makefile +++ /dev/null @@ -1,31 +0,0 @@ -# column_chem Makefile - -SHELL = /bin/sh - -include ../../macros.make -include FIM_COLUMNC_OBJECTS - -.SUFFIXES: -.SUFFIXES: .o .f .F90 .a - -.f.o .F90.o: - $(FC) -c $(FLAGS) -I../../cntl -I../../utils $(FREEFLAG) $< - -all: DEPENDENCIES $(OBJS) - -DEPENDENCIES: - $(RM) -f Filepath Srcfiles - echo "." > Filepath - ls -1 *.F90 > Srcfiles - $(MKDEPENDS) -m Filepath Srcfiles > $@ - -# The following -O0 rule ensures bitwise-exact output between serial & parallel -# runs built using ifort 9.1. - -module_cu_g3.o: - $(FC) -c $(FLAGS) $(FREEFLAG) -O0 module_cu_g3.F90 - --include DEPENDENCIES - -clean: - $(RM) -f *.o *.mod *.a DEPENDENCIES diff --git a/src/fim/FIMsrc/fim/column_chem/convert_gocart.F b/src/fim/FIMsrc/fim/column_chem/convert_gocart.F deleted file mode 100644 index 8bc2ab8..0000000 --- a/src/fim/FIMsrc/fim/column_chem/convert_gocart.F +++ /dev/null @@ -1,400 +0,0 @@ -! This is a program that converts biobenic emissions data -! into WRF input data. -! - -PROGRAM convert_gocart_background -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - USE module_machine - USE module_domain - USE module_initialize_real - USE module_integrate - USE module_driver_constants - USE module_configure - USE module_io - USE module_utility - USE module_timing - USE module_wrf_error - USE module_input_gocart_background -#ifdef DM_PARALLEL - USE module_dm -#endif -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!new for bc - USE module_bc - USE module_big_step_utilities_em - USE module_get_file_names - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - IMPLICIT NONE - - INTERFACE - SUBROUTINE init_domain_constants_em_ptr ( parent , nest ) - USE module_domain - USE module_configure - TYPE(domain), POINTER :: parent , nest - END SUBROUTINE init_domain_constants_em_ptr - - END INTERFACE - - - INTERFACE - SUBROUTINE Setup_Timekeeping( grid ) - USE module_domain - TYPE(domain), POINTER :: grid - END SUBROUTINE Setup_Timekeeping - END INTERFACE - - REAL :: time - - INTEGER :: loop , levels_to_process - INTEGER :: rc - - TYPE(domain) , POINTER :: keep_grid, grid_ptr, null_domain, grid, ingrid - TYPE (grid_config_rec_type) :: config_flags, config_flags_in - INTEGER :: number_at_same_level - - INTEGER :: max_dom, domain_id - INTEGER :: id1 , id , fid, ierr - INTEGER :: idum1, idum2 , ihour, icnt -#ifdef DM_PARALLEL - INTEGER :: nbytes - INTEGER, PARAMETER :: configbuflen = 4* CONFIG_BUF_LEN - INTEGER :: configbuf( configbuflen ) - LOGICAL , EXTERNAL :: wrf_dm_on_monitor -#endif - - REAL :: dt_from_file, tstart_from_file, tend_from_file - INTEGER :: ids , ide , jds , jde , kds , kde - INTEGER :: ims , ime , jms , jme , kms , kme - INTEGER :: i , j , k , idts, ntsd, emi_frame, nemi_frames - INTEGER :: debug_level = 0 - - CHARACTER (LEN=80) :: message - - CHARACTER(LEN=24) :: previous_date , this_date , next_date - CHARACTER(LEN=19) :: start_date_char , end_date_char , current_date_char , next_date_char - CHARACTER(LEN= 4) :: loop_char - - INTEGER :: start_year , start_month , start_day , start_hour , start_minute , start_second - INTEGER :: end_year , end_month , end_day , end_hour , end_minute , end_second - INTEGER :: interval_seconds , real_data_init_type - INTEGER :: time_loop_max , time_loop - - REAL :: cen_lat, cen_lon, moad_cen_lat, truelat1, truelat2, gmt, stand_lon, dum1 - INTEGER :: map_proj, julyr, julday, iswater, isice, isurban, isoilwater - - REAL :: dx,dy - - CHARACTER(LEN= 8) :: chlanduse - - - CHARACTER (LEN=80) :: inpname , eminame, dum_str, wrfinname - -! these are needed on some compilers, eg compaq/alpha, to -! permit pass by reference through the registry generated -! interface to med_read_emissions, below -#ifdef DEREF_KLUDGE - INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33 -#endif - -#include "version_decl" - - ! Get the NAMELIST data for input. - - ! Define the name of this program (program_name defined in module_domain) - - program_name = "WRF V3 GOCART BACKGROUND PREPROCESSOR" - -#ifdef DM_PARALLEL - CALL disable_quilting -#endif - -! CALL init_modules - CALL wrf_debug ( 100 , 'convert_emiss: calling init_modules ' ) - CALL init_modules(1) ! Phase 1 returns after MPI_INIT() (if it is called) - CALL WRFU_Initialize( defaultCalendar=WRFU_CAL_GREGORIAN, rc=rc ) - CALL init_modules(2) ! Phase 2 resumes after MPI_INIT() (if it is called) - - -#ifdef DM_PARALLEL - IF ( wrf_dm_on_monitor() ) THEN - CALL initial_config - CALL get_config_as_buffer( configbuf, configbuflen, nbytes ) - CALL wrf_dm_bcast_bytes( configbuf, nbytes ) - CALL set_config_as_buffer( configbuf, configbuflen ) - ENDIF - CALL wrf_dm_initialize -#else - CALL initial_config -#endif - - ! And here is an instance of using the information in the NAMELIST. - - CALL nl_get_debug_level ( 1, debug_level ) - CALL set_wrf_debug_level ( debug_level ) - - ! Allocated and configure the mother domain. Since we are in the nesting down - ! mode, we know a) we got a nest, and b) we only got 1 nest. - - NULLIFY( null_domain ) - - CALL wrf_message ( program_name ) - write(message,FMT='(A)') ' allocate for wrfinput_d01 ' - CALL alloc_and_configure_domain ( domain_id = 1 , & - grid = head_grid , & - parent = null_domain , & - kid = -1 ) - grid => head_grid - - ! Set up time initializations. - - CALL Setup_Timekeeping ( grid ) - - CALL domain_clock_set( head_grid, & - time_step_seconds=model_config_rec%interval_seconds ) - CALL wrf_debug ( 100 , 'convert_gocart: calling model_to_grid_config_rec ' ) - CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) - CALL wrf_debug ( 100 , 'convert_gocart: calling set_scalar_indices_from_config ' ) - CALL set_scalar_indices_from_config ( grid%id , idum1, idum2 ) - - ! Initialize the I/O for WRF. - - CALL wrf_debug ( 100 , 'convert_gocart: calling init_wrfio' ) - CALL init_wrfio - -#ifdef DM_PARALLEL - CALL get_config_as_buffer( configbuf, configbuflen, nbytes ) - CALL wrf_dm_bcast_bytes( configbuf, nbytes ) - CALL set_config_as_buffer( configbuf, configbuflen ) -#endif - -! ! Get the grid info from the wrfinput file - - CALL wrf_debug ( 100, message ) - write(message,FMT='(A)') ' set scalars for wrfinput_d01 ' - CALL wrf_debug ( 100, message ) - CALL set_scalar_indices_from_config ( grid%id , idum1, idum2 ) - - write(message,FMT='(A)') ' construct filename for wrfinput_d01 ' - CALL wrf_debug ( 100, message ) - CALL construct_filename1( wrfinname , 'wrfinput' , grid%id , 2 ) - - write(message,FMT='(A,A)') ' open file ',TRIM(wrfinname) - CALL wrf_message ( message ) - CALL open_r_dataset ( fid, TRIM(wrfinname) , head_grid , config_flags , "DATASET=INPUT", ierr ) - - - write(message,FMT='(A)') ' wrfinput open error check ' - CALL wrf_debug ( 100, message ) - IF ( ierr .NE. 0 ) THEN - WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) & - 'program convert_emiss: error opening ',TRIM(wrfinname),' for reading ierr=',ierr - CALL WRF_ERROR_FATAL ( wrf_err_message ) - ENDIF - write(message,FMT='(A)') ' past opening wrfinput_d01 ' - CALL wrf_debug ( 100, message ) - -! CALL wrf_get_dom_ti_integer ( fid , 'MAP_PROJ' , map_proj , 1 , idum1 , ierr ) -! CALL wrf_get_dom_ti_real ( fid , 'CEN_LAT' , cen_lat , 1 , idum1 , ierr ) -! CALL wrf_get_dom_ti_real ( fid , 'CEN_LON' , cen_lon , 1 , idum1 , ierr ) -! CALL wrf_get_dom_ti_real ( fid , 'MOAD_CEN_LAT' , moad_cen_lat , 1 , idum1 , ierr ) -! CALL wrf_get_dom_ti_real ( fid , 'STAND_LON' , stand_lon , 1 , idum1 , ierr ) -! CALL wrf_get_dom_ti_real ( fid , 'TRUELAT1' , truelat1 , 1 , idum1 , ierr ) -! CALL wrf_get_dom_ti_real ( fid , 'TRUELAT2' , truelat2 , 1 , idum1 , ierr ) -! CALL wrf_get_dom_ti_real ( fid , 'GMT' , gmt , 1 , idum1 , ierr ) -! CALL wrf_get_dom_ti_integer ( fid , 'JULYR' , julyr , 1 , idum1 , ierr ) -! CALL wrf_get_dom_ti_integer ( fid , 'JULDAY' , julday , 1 , idum1 , ierr ) -! CALL wrf_get_dom_ti_integer ( fid , 'ISWATER' , iswater , 1 , idum1 , ierr ) -! CALL wrf_get_dom_ti_integer ( fid , 'ISICE ' , isice , 1 , idum1 , ierr ) -! CALL wrf_get_dom_ti_integer ( fid , 'ISURBAN' , isurban , 1 , idum1 , ierr ) -! CALL wrf_get_dom_ti_integer ( fid , 'ISOILWATER' , isoilwater , 1 , idum1 , ierr ) -! CALL wrf_get_dom_ti_char ( fid , 'MMINLU' , chlanduse , ierr ) - ! Get the coarse grid info for later transfer to the fine grid domain. - - CALL wrf_get_dom_ti_integer ( fid , 'MAP_PROJ' , map_proj , 1 , icnt , ierr ) - CALL wrf_get_dom_ti_real ( fid , 'DX' , dx , 1 , icnt , ierr ) - CALL wrf_get_dom_ti_real ( fid , 'DY' , dy , 1 , icnt , ierr ) - CALL wrf_get_dom_ti_real ( fid , 'CEN_LAT' , cen_lat , 1 , icnt , ierr ) - CALL wrf_get_dom_ti_real ( fid , 'CEN_LON' , cen_lon , 1 , icnt , ierr ) - CALL wrf_get_dom_ti_real ( fid , 'TRUELAT1' , truelat1 , 1 , icnt , ierr ) - CALL wrf_get_dom_ti_real ( fid , 'TRUELAT2' , truelat2 , 1 , icnt , ierr ) - CALL wrf_get_dom_ti_real ( fid , 'MOAD_CEN_LAT' , moad_cen_lat , 1 , icnt , ierr ) - CALL wrf_get_dom_ti_real ( fid , 'STAND_LON' , stand_lon , 1 , icnt , ierr ) -! CALL wrf_get_dom_ti_real ( fid , 'GMT' , gmt , 1 , icnt , ierr ) -! CALL wrf_get_dom_ti_integer ( fid , 'JULYR' , julyr , 1 , icnt , ierr ) -! CALL wrf_get_dom_ti_integer ( fid , 'JULDAY' , julday , 1 , icnt , ierr ) - CALL wrf_get_dom_ti_integer ( fid , 'ISWATER' , iswater , 1 , icnt , ierr ) - - CALL close_dataset ( fid , config_flags , "DATASET=INPUT" ) - -!TBH print *, map_proj, dx, dy, cen_lat, cen_lon,truelat1,truelat2,moad_cen_lat,iswater - - ! An available simple timer from the timing module. - - CALL set_scalar_indices_from_config ( grid%id , idum1, idum2 ) - - CALL Setup_Timekeeping ( grid ) - CALL domain_clock_set( grid, & - time_step_seconds=model_config_rec%interval_seconds ) - CALL domain_clock_get ( grid, current_timestr=message ) - write(message,FMT='(A,A)') ' current_time ',Trim(message) - CALL wrf_debug ( 100, message ) - - CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) - -! print *,'start date=',model_config_rec%start_year(grid%id),model_config_rec%start_month(grid%id),& -! model_config_rec%start_day(grid%id),model_config_rec%start_hour(grid%id) -! print *,'end date=',model_config_rec%end_year(grid%id),model_config_rec%end_month(grid%id),& -! model_config_rec%end_day(grid%id),model_config_rec%end_hour(grid%id) -! print *,'interval =',model_config_rec%interval_seconds -! print *,'init_typ =',model_config_rec%real_data_init_type - - ! Figure out the starting and ending dates in a character format. - - start_year = model_config_rec%start_year (grid%id) - start_month = model_config_rec%start_month (grid%id) - start_day = model_config_rec%start_day (grid%id) - start_hour = model_config_rec%start_hour (grid%id) - start_minute = model_config_rec%start_minute(grid%id) - start_second = model_config_rec%start_second(grid%id) - - end_year = model_config_rec% end_year (grid%id) - end_month = model_config_rec% end_month (grid%id) - end_day = model_config_rec% end_day (grid%id) - end_hour = model_config_rec% end_hour (grid%id) - end_minute = model_config_rec% end_minute(grid%id) - end_second = model_config_rec% end_second(grid%id) - - interval_seconds = 3600 - real_data_init_type = model_config_rec%real_data_init_type - - WRITE ( start_date_char , FMT = '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) & - start_year,start_month,start_day,start_hour,start_minute,start_second - WRITE ( end_date_char , FMT = '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) & - end_year, end_month, end_day, end_hour, end_minute, end_second - -! these are needed on some compilers, eg compaq/alpha, to -! permit pass by reference through the registry generated -! interface to med_read_emissions, below -#ifdef DEREF_KLUDGE - sm31 = grid%sm31 - em31 = grid%em31 - sm32 = grid%sm32 - em32 = grid%em32 - sm33 = grid%sm33 - em33 = grid%em33 -#endif - - ihour = start_hour - write(message,FMT='(A)') ' READ GOCART BACKGROUND DATA ' - CALL wrf_debug ( 100, message ) - CALL input_ext_chem_gocart_bg ( grid ) - write(message,FMT='(A)') ' PAST GOCART BACKGROUND DATA' - CALL wrf_debug ( 100, message ) - - grid%input_from_file = .false. - - write(message,FMT='(A)') ' OPEN GOCART BACKGROUND DATA WRF file' - CALL wrf_debug ( 100, message ) - - CALL construct_filename1( inpname , 'wrfchemi_gocart_bg' , grid%id , 2 ) - CALL open_w_dataset ( id1, TRIM(inpname) , grid , config_flags , output_aux_model_input9 , "DATASET=AUXINPUT9", ierr ) - write(message,FMT='(A,A)') ' GOCART BACKGROUND DATA file name: ',TRIM(inpname) - CALL wrf_message ( message ) - - IF ( ierr .NE. 0 ) THEN - CALL wrf_error_fatal( 'real: error opening wrfchem emissions file for writing' ) - ENDIF - - write(message,FMT='(A)') ' PAST OPEN GOCART BACKGROUND DATA WRF file ' - CALL wrf_debug ( 100, message ) - - CALL calc_current_date ( grid%id , 0. ) - CALL geth_newdate ( current_date_char, current_date, 3600 ) - current_date = current_date_char // '.0000' - - if( stand_lon == 0. ) then - stand_lon = cen_lon - endif - - if( moad_cen_lat == 0. ) then - moad_cen_lat = cen_lat - endif - - write(message,FMT='(A)') ' GOCART BACKGROUND DATA : fix global attributes ' - CALL wrf_debug ( 100, message ) - - ! write global atributes into wrf emissions file - - idum1 = 1 -! call wrf_put_dom_ti_char ( id1 , 'START_DATE' ,TRIM(start_date_char) , ierr ) -! CALL wrf_put_dom_ti_integer ( id1 , 'MAP_PROJ' , map_proj , 1 , ierr ) -! CALL wrf_put_dom_ti_real ( id1 , 'MOAD_CEN_LAT' , moad_cen_lat, 1 , ierr ) -! CALL wrf_put_dom_ti_real ( id1 , 'CEN_LAT' , cen_lat , 1 , ierr ) -! CALL wrf_put_dom_ti_real ( id1 , 'CEN_LON' , cen_lon , 1 , ierr ) -! CALL wrf_put_dom_ti_real ( id1 , 'STAND_LON' , stand_lon , 1 , ierr ) -! CALL wrf_put_dom_ti_real ( id1 , 'TRUELAT1' , truelat1 , 1 , ierr ) -! CALL wrf_put_dom_ti_real ( id1 , 'TRUELAT2' , truelat2 , 1 , ierr ) -! CALL wrf_put_dom_ti_real ( id1 , 'GMT' , gmt , 1 , ierr ) -! CALL wrf_put_dom_ti_integer ( id1 , 'JULYR' , julyr , 1 , ierr ) -! CALL wrf_put_dom_ti_integer ( id1 , 'JULDAY' , julday , 1 , ierr ) -!! CALL wrf_put_dom_ti_integer ( id1 , 'CHEM_OPT' , chem_opt , 1 , ierr ) -! CALL wrf_put_dom_ti_integer ( id1 , 'ISWATER' , iswater , 1 , ierr ) -! CALL wrf_put_dom_ti_integer ( id1 , 'ISICE ' , isice , 1 , ierr ) -! CALL wrf_put_dom_ti_integer ( id1 , 'ISURBAN' , isurban , 1 , ierr ) -! CALL wrf_put_dom_ti_integer ( id1 , 'ISOILWATER' , isoilwater , 1 , ierr ) -! CALL wrf_put_dom_ti_char ( id1 , 'MMINLU' , TRIM(chlanduse) , ierr ) - -! CALL wrf_put_dom_ti_integer ( id1 , 'MAP_PROJ' , config_flags%map_proj , 1 , ierr ) - - CALL wrf_put_dom_ti_integer ( id1 , 'MAP_PROJ' , map_proj , 1 , ierr ) - -! CALL wrf_put_dom_ti_integer ( id1 , 'MAP_PROJ' , map_proj , 1 , ierr ) - CALL wrf_put_dom_ti_real ( id1 , 'DX' , config_flags%dx , 1 , ierr ) - CALL wrf_put_dom_ti_real ( id1 , 'DY' , config_flags%dy , 1 , ierr ) - CALL wrf_put_dom_ti_real ( id1 , 'CEN_LAT' , config_flags%cen_lat , 1 , ierr ) - CALL wrf_put_dom_ti_real ( id1 , 'CEN_LON' , config_flags%cen_lon , 1 , ierr ) - CALL wrf_put_dom_ti_real ( id1 , 'TRUELAT1' , config_flags%truelat1 , 1 , ierr ) - CALL wrf_put_dom_ti_real ( id1 , 'TRUELAT2' , config_flags%truelat2 , 1 , ierr ) - CALL wrf_put_dom_ti_real ( id1 , 'MOAD_CEN_LAT' , config_flags%moad_cen_lat , 1 , ierr ) - CALL wrf_put_dom_ti_real ( id1 , 'STAND_LON' , config_flags%stand_lon , 1 , ierr ) -! CALL wrf_put_dom_ti_real ( id1 , 'GMT' , gmt , 1 , ierr ) -! CALL wrf_put_dom_ti_integer ( id1 , 'JULYR' , julyr , 1 , ierr ) -! CALL wrf_put_dom_ti_integer ( id1 , 'JULDAY' , julday , 1 , ierr ) - CALL wrf_put_dom_ti_integer ( id1 , 'ISWATER' , iswater , 1 , ierr ) - - config_flags%map_proj = map_proj - config_flags%iswater = iswater - -!TBH print *, map_proj, dx, dy, cen_lat, cen_lon,truelat1,truelat2,moad_cen_lat,iswater - - config_flags%cen_lat = cen_lat - config_flags%cen_lon = cen_lon - config_flags%moad_cen_lat = moad_cen_lat - config_flags%truelat1 = truelat1 - config_flags%truelat2 = truelat2 - config_flags%stand_lon = stand_lon - -!TBH print *, map_proj,config_flags%dx, config_flags%dy, config_flags%cen_lat, config_flags%cen_lon, & -!TBH config_flags%truelat1,config_flags%truelat2,config_flags%moad_cen_lat,iswater - - CALL output_aux_model_input9 ( id1 , grid , config_flags , ierr ) - - CALL close_dataset ( id1 , config_flags , "DATASET=AUXOUTPUT9" ) - - write(message,FMT='(A)') ' GOCART BACKGROUND DATA: end of program ' - CALL wrf_message ( message ) - - - CALL wrf_shutdown - CALL WRFU_Finalize( rc=rc ) - -!#ifdef DM_PARALLEL -! CALL wrf_dm_shutdown -!#endif - - STOP - -END PROGRAM convert_gocart_background - diff --git a/src/fim/FIMsrc/fim/column_chem/module_aer_opt_out.F90 b/src/fim/FIMsrc/fim/column_chem/module_aer_opt_out.F90 deleted file mode 100644 index aff24c8..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_aer_opt_out.F90 +++ /dev/null @@ -1,110 +0,0 @@ -MODULE module_aer_opt_out - USE module_initial_chem_namelists,only:p_extcof3,p_extcof55,p_extcof106, & - p_extcof3_5,p_extcof8_12, & - p_bscof3,p_bscof55,p_bscof106, & - p_asympar3,p_asympar55,p_asympar106 -! SAM lower and upper wavelength limits (microns) for AFWA band averaging - 2 averaging bins considered here - REAL, PARAMETER, PRIVATE :: afwalowv1 = 3. ! lower wavelength for first AFWA band average extinction coefficent - REAL, PARAMETER, PRIVATE :: afwahiwv1 = 5. ! upper wavelength for first AFWA band average extinction coefficent - REAL, PARAMETER, PRIVATE :: afwalowv2 = 8. ! lower wavelength for second AFWA band average extinction coefficent - REAL, PARAMETER, PRIVATE :: afwahiwv2 = 12. ! upper wavelength for second AFWA band average extinction coefficent -CONTAINS - SUBROUTINE aer_opt_out(aodi,dz8w & - ,ext_coeff,bscat_coeff,asym_par & - ,tauaersw,gaersw,waersw,tauaerlw & - ,num_ext_coef,num_bscat_coef,num_asym_par & - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte ) - IMPLICIT NONE - - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - num_ext_coef,num_bscat_coef,num_asym_par - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, 1:num_ext_coef ), INTENT (OUT) :: ext_coeff - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, 1:num_bscat_coef ), INTENT (OUT) :: bscat_coeff - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, 1:num_asym_par ), INTENT (OUT) :: asym_par - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, 4 ), & - INTENT(IN ) :: tauaersw,gaersw,waersw - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, 16 ), & - INTENT(IN ) :: tauaerlw - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & - INTENT(IN ) :: dz8w - real :: ang,slope,slopeg,slopessa,onemang - integer :: i,j,k - real, dimension (ims:ime,jms:jme), intent(INOUT) :: aodi - real, dimension (ims:ime,jms:jme) :: aod - - -!SAM 10/22/09 AFWA ouput. Fill following arrays: -! 0.3 micron extinction coefficient (1/km), scattering coefficient (1/km), assymetry coefficient (unitless) -! 0.55 micron extinction coefficient (1/km), scattering coefficient (1/km), assymetry coefficient (unitless) -! 1.06 micron extinction coefficient (1/km), scattering coefficient (1/km), assymetry coefficient (unitless) -! 3. - 5. micron band averaged extinction coefficient (1/km) -! 8. - 12. micron band averaged extinction coefficient (1/km) -! As in PNNL MOSAIC, extrapolate or interpolate based on 300-999 nm Angstrom coefficient, -! or linear interpolation/extrapolation between 300 and 999 nm for assymetry coefficient - do j = jts,jte - do k = kts,kte - do i = its,ite -! convert optical properties at 300,400,600, and 999 to conform to the band wavelengths -! these are: 300, 550 and 1060 -! 300 nm already calculated in aerosol_optical_averaging and miecalc - ext_coeff(i,k,j,p_extcof3)=tauaersw(i,k,j,1)*1.E3/dz8w(i,k,j) ! 300nm ext. coeff. (1/km) - bscat_coeff(i,k,j,p_bscof3)=tauaersw(i,k,j,1)*waersw(i,k,j,1)*1.E3/dz8w(i,k,j) ! 300nm scat. coeff. (1/km) - asym_par(i,k,j,p_asympar3)=gaersw(i,k,j,1) ! 300nm assym. parameter (no units) -! 550 nm done like PNNL - ang=log(tauaersw(i,k,j,1)/tauaersw(i,k,j,4))/log(999./300.) - slopessa=(waersw(i,k,j,3)-waersw(i,k,j,2))/.2 - slopeg=(gaersw(i,k,j,3)-gaersw(i,k,j,2))/.2 - ext_coeff(i,k,j,p_extcof55)=tauaersw(i,k,j,2)*1.E3*((0.4/0.55)**ang)/dz8w(i,k,j) ! 550nm ext. coeff. (1/km) -! if(j.eq.18072)then -! write(6,*)'in AEROPTOUT',k,j,ext_coeff(i,k,j,p_extcof55) -! write(6,*)tauaersw(i,k,j,1),tauaersw(i,k,j,2),tauaersw(i,k,j,4),dz8w(i,k,j) -! endif - slope= slopessa*(0.55-.6)+waersw(i,k,j,3) ! slope is scratch variable, = single scat albedo at .55 micron - slope=AMIN1(1.0,AMAX1(0.4,slope)) ! SSA has same limits as in PNNL - bscat_coeff(i,k,j,p_bscof55)=ext_coeff(i,k,j,p_extcof55)*slope ! 550nm scat. coeff. (1/km) - asym_par(i,k,j,p_asympar55)=AMIN1(1.,AMAX1(0.5,slopeg*(.55-.6)+gaersw(i,k,j,3))) ! 550nm assym. parameter (no units) -! 1060 nm done like PNNL - slopessa=(waersw(i,k,j,4)-waersw(i,k,j,3))/.399 - slopeg=(gaersw(i,k,j,4)-gaersw(i,k,j,3))/.399 - ext_coeff(i,k,j,p_extcof106)=tauaersw(i,k,j,2)*1.E3*((0.4/1.06)**ang)/dz8w(i,k,j) ! 1060nm ext. coeff. (1/km) - slope= slopessa*(1.06-.999)+waersw(i,k,j,4) ! slope is scratch variable, = single scat albedo at 1.06 micron - slope=AMIN1(1.0,AMAX1(0.4,slope)) ! SSA has same limits as in PNNL - bscat_coeff(i,k,j,p_bscof106)=ext_coeff(i,k,j,p_extcof106)*slope ! 1060nm scat. coeff. (1/km) - asym_par(i,k,j,p_asympar106)=AMIN1(1.,AMAX1(0.5,slopeg*(1.06-.999)+gaersw(i,k,j,3))) ! 1060nm assym. parameter (no units) -! 3.-5. and 8. - 12. micron band averages done by extrapolating .3-.999 calculations, like PNNL - onemang=1.-ang - if(abs(onemang).gt.1.E-3)then ! if ang sufficiently different than one, no need to worry about singularity - slope = tauaersw(i,k,j,2)*(0.4/afwalowv1)**ang ! Dummy incrumental tau at afwa lower wavelength for band average - slopeg = tauaersw(i,k,j,2)*(0.4/afwahiwv1)**ang ! Dummy incrumental tau at afwa high wavelength for band average - ext_coeff(i,k,j,p_extcof3_5) = (slopeg*afwahiwv1-slope*afwalowv1)/(afwahiwv1-afwalowv1)/onemang - slope = tauaersw(i,k,j,2)*(0.4/afwalowv2)**ang ! Dummy incrumental tau at afwa lower wavelength for band average - slopeg = tauaersw(i,k,j,2)*(0.4/afwahiwv2)**ang ! Dummy incrumental tau at afwa high wavelength for band average - ext_coeff(i,k,j,p_extcof8_12) = (slopeg*afwahiwv2-slope*afwalowv2)/(afwahiwv2-afwalowv2)/onemang - else ! ang is close to 1., avoid singularity - ext_coeff(i,k,j,p_extcof3_5) = tauaersw(i,k,j,2)*0.4*log(afwahiwv1/afwalowv1)/(afwahiwv1-afwalowv1) - ext_coeff(i,k,j,p_extcof8_12) = tauaersw(i,k,j,2)*0.4*log(afwahiwv2/afwalowv2)/(afwahiwv2-afwalowv2) - endif -! Convert band average incrumental taus to extinction coefficients (1/km) - ext_coeff(i,k,j,p_extcof3_5) = ext_coeff(i,k,j,p_extcof3_5)*1.E3/dz8w(i,k,j) - ext_coeff(i,k,j,p_extcof8_12) = ext_coeff(i,k,j,p_extcof8_12)*1.E3/dz8w(i,k,j) - end do - end do - end do - do j = jts,jte - do i = its,ite - aod(i,j)=0. - aodi(i,j)=0. - do k = kts,kte - aodi(i,j)=aodi(i,j)+ext_coeff(i,k,j,p_extcof55)*dz8w(i,k,j)*1.e-3 - aod(i,j)=aod(i,j)+ext_coeff(i,k,j,p_extcof55)*dz8w(i,k,j)*1.e-3 - end do -! if(j.eq.18072)write(6,*)'aod = ',aod(i,j) - end do - end do - END SUBROUTINE AER_OPT_OUT -END MODULE module_aer_opt_out - diff --git a/src/fim/FIMsrc/fim/column_chem/module_aer_ra.F90 b/src/fim/FIMsrc/fim/column_chem/module_aer_ra.F90 deleted file mode 100644 index 03570f1..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_aer_ra.F90 +++ /dev/null @@ -1,97 +0,0 @@ -MODULE module_aer_ra -CONTAINS - SUBROUTINE aer_ra(dz8w & - ,extt,ssca,asympar,nbands & - ,tauaersw,gaersw,waersw,tauaerlw & - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte ) - IMPLICIT NONE - - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte,nbands - REAL, DIMENSION( ims:ime, kms:kme, jms:jme,nbands ), INTENT (OUT) :: extt - REAL, DIMENSION( ims:ime, kms:kme, jms:jme,nbands ), INTENT (OUT) :: ssca - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, nbands), INTENT (OUT) :: asympar - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, 4 ), & - INTENT(IN ) :: tauaersw,gaersw,waersw - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & - INTENT(IN ) :: dz8w - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, 16 ), & - INTENT(IN ) :: tauaerlw - real :: ang,slope,slopeg,slopessa,onemang - integer :: i,j,k,ib - real, dimension(NBANDS) :: midbands ! jcb - REAL, PARAMETER :: thresh=1.e-9 -! --- band wavenumber intervals - real , dimension(14):: wvnum1, wvnum2 - data wvnum1/ & - & 2600.0, 3251.0, 4001.0, 4651.0, 5151.0, 6151.0, 7701.0, & - & 8051.0,12851.0,16001.0,22651.0,29001.0,38001.0, 820.0 / - data wvnum2/ & - & 3250.0, 4000.0, 4650.0, 5150.0, 6150.0, 7700.0, 8050.0, & - & 12850.0,16000.0,22650.0,29000.0,38000.0,50000.0, 2600.0 / - -! data midbands/.2,.235,.27,.2875,.3025,.305,.3625,.55,1.92,1.745,6.135/ - - -! As in PNNL MOSAIC, extrapolate or interpolate based on 300-999 nm Angstrom coefficient, -! or linear interpolation/extrapolation between 300 and 999 nm for assymetry coefficient - do ib=1,nbands - midbands(ib)=(1./wvnum1(ib)+1./wvnum2(ib))*.5e4 -! write(6,*)'midband = ',midbands(ib) - do j = jts,jte - do k = kts,kte - do i = its,ite - if(tauaersw(i,k,j,1).gt.thresh .and. tauaersw(i,k,j,4).gt.thresh) then - ang=alog(tauaersw(i,k,j,1)/tauaersw(i,k,j,4))/alog(999./300.) - extt(i,k,j,ib)=tauaersw(i,k,j,2)*(0.4/midbands(ib))**ang - -! ssa - linear interpolation; extrapolation - slope=(waersw(i,k,j,3)-waersw(i,k,j,2))/.2 - ssca(i,k,j,ib) = slope*(midbands(ib)-.6)+waersw(i,k,j,3) - if(ssca(i,k,j,ib).lt.0.4) ssca(i,k,j,ib)=0.4 - if(ssca(i,k,j,ib).ge.1.0) ssca(i,k,j,ib)=1.0 - -! g - linear interpolation;extrapolation - slope=(gaersw(i,k,j,3)-gaersw(i,k,j,2))/.2 - asympar(i,k,j,ib) = slope*(midbands(ib)-.6)+gaersw(i,k,j,3) - if(asympar(i,k,j,ib).lt.0.5) asympar(i,k,j,ib)=0.5 - if(asympar(i,k,j,ib).ge.1.0) asympar(i,k,j,ib)=1.0 - else - extt(i,k,j,ib)=0. - ssca(i,k,j,ib)=1. - asympar(i,k,j,ib)=0. - endif - - end do - end do - end do - end do -! - do ib=1,nbands - do j = jts,jte - do i = its,ite - slope = 0. !use slope as a sum holder - do k = kts,kte - slope = slope + extt(i,k,j,ib) - end do - if( slope < 0. ) then - write(0,*)'ERROR: Negative total optical depth',j,slope - else if( slope > 6. ) then - write(0,*)'adjusting extt ',ib,j,slope - do k = kts,kte - extt(i,k,j,ib)=extt(i,k,j,ib)*6./slope - enddo - endif - end do - end do - end do - -! print *,'in aer_ra ',maxval(extt) -! print *,'in aer_ra ',maxval(ssca) -! print *,'in aer_ra ',maxval(asympar) - END SUBROUTINE aer_ra -END MODULE module_aer_ra - diff --git a/src/fim/FIMsrc/fim/column_chem/module_chem_plumerise_scalar.F90 b/src/fim/FIMsrc/fim/column_chem/module_chem_plumerise_scalar.F90 deleted file mode 100644 index 11735c3..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_chem_plumerise_scalar.F90 +++ /dev/null @@ -1,2231 +0,0 @@ -Module module_chem_plumerise_scalar -! USE module_plumerise1 -! use module_model_constants - USE module_constants,only: g=>grvity,cp,r_d=>rd,r_v=>rv,p1000mb=>p1000 - use module_zero_plumegen_coms - real,parameter :: rgas=r_d - real,parameter :: cpor=cp/r_d - real,parameter :: p00=p1000mb -! real, external:: esat_pr -CONTAINS -subroutine plumerise(m1,m2,m3,ia,iz,ja,jz,firesize,mean_fct & - ,nspecies,eburn_in,eburn_out & - ,up,vp,wp,theta,pp,dn0,rv,zt_rams,zm_rams) -! use module_zero_plumegen_coms, only : ucon,vcon,wcon,thtcon,rvcon,picon,tmpcon& -! ,dncon,prcon,zcon,zzcon,scon - - implicit none - - - integer :: ng,m1,m2,m3,ia,iz,ja,jz,ibcon,mynum,i,j,k,iveg_ag,& - imm,k1,k2,ixx,ispc,nspecies - - integer :: ncall = 0 - integer :: kmt - real,dimension(m1,nspecies), intent(out) :: eburn_out - real,dimension(nspecies), intent(in) :: eburn_in - - real, dimension(m1,m2,m3) :: up, vp, wp,theta,pp,dn0,rv - - real, dimension(m1) :: zt_rams,zm_rams - - real :: burnt_area,STD_burnt_area,dz_flam,rhodzi,dzi - real, dimension(2) :: ztopmax - - real :: q_smold_kgm2 - -! From plumerise1.F routine - integer, parameter :: nveg_agreg = 4 - integer, parameter :: tropical_forest = 1 - integer, parameter :: boreal_forest = 2 - integer, parameter :: savannah = 3 - - integer, parameter :: grassland = 4 - real, dimension(nveg_agreg) :: firesize,mean_fct - - eburn_out=0.0 - - !Fator de conversao de unidades - !!fcu=1. !=> kg [gas/part] /kg [ar] - !!fcu =1.e+12 !=> ng [gas/part] /kg [ar] - !!real,parameter :: fcu =1.e+6 !=> mg [gas/part] /kg [ar] - !---------------------------------------------------------------------- - ! indexacao para o array "plume(k,i,j)" - ! k - ! 1 => area media (m^2) dos focos em biomas floresta dentro do gribox i,j - ! 2 => area media (m^2) dos focos em biomas savana dentro do gribox i,j - ! 3 => area media (m^2) dos focos em biomas pastagem dentro do gribox i,j - ! 4 => desvio padrao da area media (m^2) dos focos : floresta - ! 5 => desvio padrao da area media (m^2) dos focos : savana - ! 6 => desvio padrao da area media (m^2) dos focos : pastagem - ! 7 a 9 => sem uso - !10(=k_CO_smold) => parte da emissao total de CO correspondente a fase smoldering - !11, 12 e 13 => este array guarda a relacao entre - ! qCO( flaming, floresta) e a quantidade total emitida - ! na fase smoldering, isto e; - ! qCO( flaming, floresta) = plume(11,i,j)*plume(10,i,j) - ! qCO( flaming, savana ) = plume(12,i,j)*plume(10,i,j) - ! qCO( flaming, pastagem) = plume(13,i,j)*plume(10,i,j) - !20(=k_PM25_smold),21,22 e 23 o mesmo para PM25 - ! - !24-n1 => sem uso - !---------------------------------------------------------------------- -! print *,' Plumerise_scalar 1',ncall - if (ncall == 0) then - ncall = 1 - call zero_plumegen_coms - endif -! print *,' Plumerise_scalar 1',ncall - - -! print *,' Plumerise_scalar 2',m1 - j=1 - i=1 -! do j = ja,jz ! loop em j -! do i = ia,iz ! loop em i - - !- if the max value of flaming is close to zero => there is not emission with - !- plume rise => cycle - - do k = 1,m1 - !ucon (k)=up(k,i,j) ! u wind - !vcon (k)=vp(k,i,j) ! v wind - !wcon (k)=wp(k,i,j) ! w wind - thtcon(k)=theta(k,i,j) ! pot temperature - picon (k)=pp(k,i,j) ! exner function - !tmpcon(k)=thtcon(k)*picon(k)/cp ! temperature (K) - !dncon (k)=dn0(k,i,j) ! dry air density (basic state) - !prcon (k)=(picon(k)/cp)**cpor*p00 ! pressure (Pa) - rvcon (k)=rv(k,i,j) ! water vapor mixing ratio - zcon (k)=zt_rams(k) ! termod-point height - zzcon (k)=zm_rams(k) ! W-point height -! print*,'PL:',k,zcon(k),picon (k),thtcon(k),1000.*rvcon (k) - enddo - do ispc=1,nspecies - eburn_out(1,ispc) = eburn_in(ispc) - enddo - - !- get envinronmental state (temp, water vapor mix ratio, ...) - call get_env_condition(1,m1,kmt) - - !- loop nos 4 biomas agregados com possivel queimada - do iveg_ag=1,nveg_agreg -! print *,'iveg_ag = ',iveg_ag,mean_fct(iveg_ag) - - - !- verifica a existencia de emissao flaming para um bioma especifico - !orig: if( plume( k_CO_smold + iveg_ag ,i,j) < 1.e-6 ) cycle - if(mean_fct(iveg_ag) < 1.e-6 ) cycle - - ! burnt area and standard deviation - burnt_area = firesize(iveg_ag) - - !not em use - !STD_burnt_area= plume(3+iveg_ag,i,j) - STD_burnt_area= 0. - - !- loop nos valores minimo e maximo da taxa de calor - do imm=1,2 - -!-------------------- - !ixx=iveg_ag*10 + imm -! print*,'i j veg=',i, j, iveg_ag,imm -!-------------------- - - !- get fire properties (burned area, plume radius, heating rates ...) - call get_fire_properties(imm,iveg_ag,burnt_area,STD_burnt_area) - - !------ generates the plume rise ------ - - !-- only one value for eflux of GRASSLAND - ! if(iveg_ag == GRASSLAND .and. imm == 2) then - if(iveg_ag == 4 .and. imm == 2) then - ztopmax(2)=ztopmax(1) - ztopmax(1)=zzcon(1) -! print *,'cycle',ztopmax(1),ztopmax(2) - cycle - endif - - call makeplume (kmt,ztopmax(imm),ixx) - - enddo ! enddo do loop em imm - - !- define o dominio vertical onde a emissao flaming ira ser colocada - call set_flam_vert(ztopmax,k1,k2) - - !- espessura da camada vertical - dz_flam=zzcon(k2)-zzcon(k1-1) - - !- distribui a emissao flaming entre os niveis k1 e k2 -! print *,'distribui, k1,k2,dz_flam',k1,k2,dz_flam - do k=k1,k2 - !use this in case the emission src is already in mixing ratio - !rhodzi= 1./(dn0(k,i,j) * dz_flam) - !use this in case the emission src is tracer density - dzi= 1./( dz_flam) - - do ispc = 1, nspecies - - !- get back the smoldering emission in kg/m2 (actually in 1e-9 kg/m2) - - !use this in case the emission src is already in mixing ratio - !q_smold_kgm2 = (1/dzt(2) * dn0(2,i,j) )* & - ! chem1_src_g(bburn,ispc,ng)%sc_src(2,i,j) - - !use this in case the emission src is tracer density -! q_smold_kgm2 = ((zt_rams(2)-zt_rams(1)) )* & -! eburn_in(ispc) - q_smold_kgm2 = eburn_in(ispc) - - ! units = already in ppbm, don't need "fcu" factor - eburn_out(k,ispc) = eburn_out(k,ispc) +& - mean_fct(iveg_ag) *& - q_smold_kgm2 * & - dzi !use this in case the emission src is tracer density - !rhodzi !use this in case the emission src is already in mixing ratio -! if(ispc.eq. 1) print *,' Plume: ',k,eburn_out(k,ispc),mean_fct(iveg_ag),q_smold_kgm2,dzi - - - - !srcCO(k,i,j)= srcCO(k,i,j) + plume(k_CO_smold+iveg_ag,i,j)*& - ! plume(k_CO_smold ,i,j)*& - ! rhodzi*fcu - enddo - - enddo - - enddo ! enddo do loop em iveg_ag - !----- - !stop 333 - !endif - !----- -! enddo ! loop em i -! enddo ! loop em j -!stop 4544 -end subroutine plumerise -!------------------------------------------------------------------------- - -subroutine get_env_condition(k1,k2,kmt) - -!se module_zero_plumegen_coms -!use rconstants -implicit none -integer :: k1,k2,k,kcon,klcl,kmt,nk,nkmid,i -real :: znz,themax,tlll,plll,rlll,zlll,dzdd,dzlll,tlcl,plcl,dzlcl,dummy -integer :: n_setgrid = 0 - -if( n_setgrid == 0) then - n_setgrid = 1 - call set_grid ! define vertical grid of plume model - ! zt(k) = thermo and water levels - ! zm(k) = dynamical levels -endif - -znz=zcon(k2) -do k=nkp,1,-1 - if(zt(k).lt.znz)go to 13 -enddo -stop ' envir stop 12' -13 continue -kmt=k - -nk=k2-k1+1 -!call htint(nk, wcon,zzcon(k1),kmt,wpe,zt) -!call htint(nk, ucon,zcon(k1),kmt,upe,zt) -!call htint(nk, vcon,zcon(k1),kmt,vpe,zt) - call htint(nk,thtcon,zcon(k1),kmt,the ,zt) - call htint(nk, rvcon,zcon(k1),kmt,qvenv,zt) -do k=1,kmt - qvenv(k)=max(qvenv(k),1e-8) -enddo - -pke(1)=picon(1) -do k=1,kmt - thve(k)=the(k)*(1.+.61*qvenv(k)) ! virtual pot temperature -enddo -do k=2,kmt - pke(k)=pke(k-1)-g*2.*(zt(k)-zt(k-1)) & ! exner function - /(thve(k)+thve(k-1)) -enddo -do k=1,kmt - te(k) = the(k)*pke(k)/cp ! temperature (K) - pe(k) = (pke(k)/cp)**cpor*p00 ! pressure (Pa) - dne(k)= pe(k)/(rgas*te(k)*(1.+.61*qvenv(k))) ! dry air density (kg/m3) -! print*,'ENV=',the(k), te(k),pe(k),zt(k) -enddo - -!-use este para gerar o RAMS.out -! ------- print environment state -!print*,'k,zt(k),pe(k),te(k)-273.15,qvenv(k)*1000' -!do k=1,kmt -! write(*,100) k,zt(k),pe(k),te(k)-273.15,qvenv(k)*1000. -! 100 format(1x,I5,4f20.12) -!enddo -!stop 333 - - -!--------- nao eh necessario este calculo -!do k=1,kmt -! call thetae(pe(k),te(k),qvenv(k),thee(k)) -!enddo - - -!--------- converte press de Pa para kPa para uso modelo de plumerise -do k=1,kmt - pe(k) = pe(k)*1.e-3 -enddo - -return -end subroutine get_env_condition - -!------------------------------------------------------------------------- - -subroutine set_grid() -!use module_zero_plumegen_coms -implicit none -integer :: k,mzp - -dz=100. ! set constant grid spacing of plume grid model(meters) - -mzp=nkp -zt(1) = zsurf -zm(1) = zsurf -zt(2) = zt(1) + 0.5*dz -zm(2) = zm(1) + dz -do k=3,mzp - zt(k) = zt(k-1) + dz ! thermo and water levels - zm(k) = zm(k-1) + dz ! dynamical levels -enddo -!print*,zsurf -!Print*,zt(:) -do k = 1,mzp-1 - dzm(k) = 1. / (zt(k+1) - zt(k)) -enddo -dzm(mzp)=dzm(mzp-1) - -do k = 2,mzp - dzt(k) = 1. / (zm(k) - zm(k-1)) -enddo -dzt(1) = dzt(2) * dzt(2) / dzt(3) - -! dzm(1) = 0.5/dz -! dzm(2:mzp) = 1./dz -return -end subroutine set_grid -!------------------------------------------------------------------------- - -subroutine set_flam_vert(ztopmax,k1,k2) -! use module_zero_plumegen_coms, only : nkp,zzcon - implicit none - integer imm,k,k1,k2 - real, dimension(2) :: ztopmax - integer, dimension(2) :: k_lim - - - do imm=1,2 -! checar -! do k=1,m1-1 - do k=1,nkp-1 - if(zzcon(k) > ztopmax(imm) ) exit - enddo - k_lim(imm) = k - enddo - k1=max(3,k_lim(1)) - k2=max(3,k_lim(2)) - - if(k2 < k1) then - !print*,'1: ztopmax k=',ztopmax(1), k1 - !print*,'2: ztopmax k=',ztopmax(2), k2 - k2=k1 - !stop 1234 - endif - -end subroutine set_flam_vert -!------------------------------------------------------------------------- - -subroutine get_fire_properties(imm,iveg_ag,burnt_area,STD_burnt_area) -!use module_zero_plumegen_coms -implicit none -integer :: moist, i, icount,imm,iveg_ag -real:: bfract, effload, heat, hinc ,burnt_area,STD_burnt_area,heat_fluxW -real, dimension(2,4) :: heat_flux - - -data heat_flux/ & -!--------------------------------------------------------------------- -! heat flux !IGBP Land Cover ! -! min ! max !Legend and ! reference -! kW/m^2 !description ! -!-------------------------------------------------------------------- - 30.0, 80.0, &! Tropical Forest ! igbp 2 & 4 - 30.0, 80.0, &! Boreal forest ! igbp 1 & 3 - 4.4, 23.0, &! cerrado/woody savanna | igbp 5 thru 9 - 3.3, 3.3 /! Grassland/cropland ! igbp 10 thru 17 -!-------------------------------------------------------------------- - - -!-- fire at the surface -! -!area = 20.e+4 ! area of burn, m^2 -area = burnt_area! area of burn, m^2 - -!fluxo de calor para o bioma -heat_fluxW = heat_flux(imm,iveg_ag) * 1000. ! converte para W/m^2 - -mdur = 53 ! duration of burn, minutes -bload = 10. ! total loading, kg/m**2 -moist = 10 ! fuel moisture, %. average fuel moisture,percent dry -maxtime =mdur+2 ! model time, min -!heat = 21.e6 !- joules per kg of fuel consumed -!heat = 15.5e6 !joules/kg - cerrado -heat = 19.3e6 !joules/kg - floresta em alta floresta (mt) -alpha = 0.1 !- entrainment constant - -!-------------------- printout ---------------------------------------- - -!!WRITE ( * , * ) ' SURFACE =', ZSURF, 'M', ' LCL =', ZBASE, 'M' -! -!PRINT*,'=======================================================' -!print * , ' FIRE BOUNDARY CONDITION :' -!print * , ' DURATION OF BURN, MINUTES =',MDUR -!print * , ' AREA OF BURN, HA =',AREA*1.e-4 -!print * , ' HEAT FLUX, kW/m^2 =',heat_fluxW*1.e-3 -!print * , ' TOTAL LOADING, KG/M**2 =',BLOAD -!print * , ' FUEL MOISTURE, % =',MOIST !average fuel moisture,percent dry -!print * , ' MODEL TIME, MIN. =',MAXTIME -! -! -! -! ******************** fix up inputs ********************************* -! - -!IF (MOD (MAXTIME, 2) .NE.0) MAXTIME = MAXTIME+1 !make maxtime even - -MAXTIME = MAXTIME * 60 ! and put in seconds -! -RSURF = SQRT (AREA / 3.14159) !- entrainment surface radius (m) - -FMOIST = MOIST / 100. !- fuel moisture fraction -! -! -! calculate the energy flux and water content at lboundary. -! fills heating() on a minute basis. could ask for a file at this po -! in the program. whatever is input has to be adjusted to a one -! minute timescale. -! - - DO I = 1, ntime !- make sure of energy release - HEATING (I) = 0.0001 !- avoid possible divide by 0 - enddo -! - TDUR = MDUR * 60. !- number of seconds in the burn - - bfract = 1. !- combustion factor - - EFFLOAD = BLOAD * BFRACT !- patchy burning - -! spread the burning evenly over the interval -! except for the first few minutes for stability - ICOUNT = 1 -! - if(MDUR > NTIME) STOP 'Increase time duration (ntime) in min - see file "plumerise_mod.f90"' - - DO WHILE (ICOUNT.LE.MDUR) -! HEATING (ICOUNT) = HEAT * EFFLOAD / TDUR ! W/m**2 -! HEATING (ICOUNT) = 80000. * 0.55 ! W/m**2 - - HEATING (ICOUNT) = heat_fluxW * 0.55 ! W/m**2 (0.55 converte para energia convectiva) - ICOUNT = ICOUNT + 1 - ENDDO -! ramp for 5 minutes - - HINC = HEATING (1) / 4. - HEATING (1) = 0.1 - HEATING (2) = HINC - HEATING (3) = 2. * HINC - HEATING (4) = 3. * HINC -! - -return -end subroutine get_fire_properties -!------------------------------------------------------------------------------- -! -SUBROUTINE MAKEPLUME ( kmt,ztopmax,ixx) -! -! ********************************************************************* -! -! EQUATION SOURCE--Kessler Met.Monograph No. 32 V.10 (K) -! Alan Weinstein, JAS V.27 pp 246-255. (W), -! Ogura and Takahashi, Monthly Weather Review V.99,pp895-911 (OT) -! Roger Pielke,Mesoscale Meteorological Modeling,Academic Press,1984 -! Originally developed by: Don Latham (USFS) -! -! -! ************************ VARIABLE ID ******************************** -! -! DT=COMPUTING TIME INCREMENT (SEC) -! DZ=VERTICAL INCREMENT (M) -! LBASE=LEVEL ,CLOUD BASE -! -! CONSTANTS: -! G = GRAVITATIONAL ACCELERATION 9.80796 (M/SEC/SEC). -! R = DRY AIR GAS CONSTANT (287.04E6 JOULE/KG/DEG K) -! CP = SPECIFIC HT. (1004 JOULE/KG/DEG K) -! HEATCOND = HEAT OF CONDENSATION (2.5E6 JOULE/KG) -! HEATFUS = HEAT OF FUSION (3.336E5 JOULE/KG) -! HEATSUBL = HEAT OF SUBLIMATION (2.83396E6 JOULE/KG) -! EPS = RATIO OF MOL.WT. OF WATER VAPOR TO THAT OF DRY AIR (0.622) -! DES = DIFFERENCE BETWEEN VAPOR PRESSURE OVER WATER AND ICE (MB) -! TFREEZE = FREEZING TEMPERATURE (K) -! -! -! PARCEL VALUES: -! T = TEMPERATURE (K) -! TXS = TEMPERATURE EXCESS (K) -! QH = HYDROMETEOR WATER CONTENT (G/G DRY AIR) -! QHI = HYDROMETEOR ICE CONTENT (G/G DRY AIR) -! QC = WATER CONTENT (G/G DRY AIR) -! QVAP = WATER VAPOR MIXING RATIO (G/G DRY AIR) -! QSAT = SATURATION MIXING RATIO (G/G DRY AIR) -! RHO = DRY AIR DENSITY (G/M**3) MASSES = RHO*Q'S IN G/M**3 -! ES = SATURATION VAPOR PRESSURE (kPa) -! -! ENVIRONMENT VALUES: -! TE = TEMPERATURE (K) -! PE = PRESSURE (kPa) -! QVENV = WATER VAPOR (G/G) -! RHE = RELATIVE HUMIDITY FRACTION (e/esat) -! DNE = dry air density (kg/m^3) -! -! HEAT VALUES: -! HEATING = HEAT OUTPUT OF FIRE (WATTS/M**2) -! MDUR = DURATION OF BURN, MINUTES -! -! W = VERTICAL VELOCITY (M/S) -! RADIUS=ENTRAINMENT RADIUS (FCN OF Z) -! RSURF = ENTRAINMENT RADIUS AT GROUND (SIMPLE PLUME, TURNER) -! ALPHA = ENTRAINMENT CONSTANT -! MAXTIME = TERMINATION TIME (MIN) -! -! -!********************************************************************** -!********************************************************************** -!use module_zero_plumegen_coms -implicit none -!logical :: endspace -character (len=10) :: varn -integer :: izprint, iconv, itime, k, kk, kkmax, deltak,ilastprint,kmt & - ,ixx,nrectotal,i_micro,n_sub_step -real :: vc, g, r, cp, eps, & - tmelt, heatsubl, heatfus, heatcond, tfreeze, & - ztopmax, wmax, rmaxtime, es, esat, heat,dt_save !ESAT_PR, -character (len=2) :: cixx - -! real, external:: esat_pr! -! -! ******************* SOME CONSTANTS ********************************** -! -! XNO=10.0E06 median volume diameter raindrop (K table 4) -! VC = 38.3/(XNO**.125) mean volume fallspeed eqn. (K) -! -parameter (vc = 5.107387) -parameter (g = 9.80796, r = 287.04, cp = 1004., eps = 0.622, tmelt = 273.3) -parameter (heatsubl = 2.834e6, heatfus = 3.34e5, heatcond = 2.501e6) -parameter (tfreeze = 269.3) -! -tstpf = 2.0 !- timestep factor -viscosity = 500.!- viscosity constant (original value: 0.001) - -nrectotal=150 -! -!*************** PROBLEM SETUP AND INITIAL CONDITIONS ***************** -mintime = 1 -ztopmax = 0. -ztop = 0. - time = 0. - dt = 1. - wmax = 1. -kkmax = 10 -deltaK = 20 -ilastprint=0 -L = 1 ! L initialization - -!--- initialization -CALL INITIAL(kmt) - -!--- initial print fields: -izprint = 0 ! if = 0 => no printout -if (izprint.ne.0) then - write(cixx(1:2),'(i2.2)') ixx - open(2, file = 'debug.'//cixx//'.dat') - open(19,file='plumegen9.'//cixx//'.gra', & - form='unformatted',access='direct',status='unknown', & - recl=4*nrectotal) !PC -! recl=1*nrectotal) !sx6 e tupay - call printout (izprint,nrectotal) - ilastprint=2 -endif - -! ******************* model evolution ****************************** -rmaxtime = float(maxtime) -! -!print * ,' TIME=',time,' RMAXTIME=',rmaxtime -!print*,'=======================================================' - DO WHILE (TIME.LE.RMAXTIME) !beginning of time loop - -! do itime=1,120 - -!-- set model top integration - nm1 = min(kmt, kkmax + deltak) - -!-- set timestep - !dt = (zm(2)-zm(1)) / (tstpf * wmax) - dt = min(5.,(zm(2)-zm(1)) / (tstpf * wmax)) - -!-- elapsed time, sec - time = time+dt -!-- elapsed time, minutes - mintime = 1 + int (time) / 60 - wmax = 1. !no zeroes allowed. -!************************** BEGIN SPACE LOOP ************************** - -!-- zerout all model tendencies - call tend0_plumerise - -!-- bounday conditions (k=1) - L=1 - call lbound() - -!-- dynamics for the level k>1 -!-- W advection -! call vel_advectc_plumerise(NM1,WC,WT,DNE,DZM) - call vel_advectc_plumerise(NM1,WC,WT,RHO,DZM) - -!-- scalars advection 1 - call scl_advectc_plumerise('SC',NM1) - -!-- scalars advection 2 - !call scl_advectc_plumerise2('SC',NM1) - -!-- scalars entrainment, adiabatic - call scl_misc(NM1) - -!-- gravity wave damping using Rayleigh friction layer fot T - call damp_grav_wave(1,nm1,deltak,dt,zt,zm,w,t,tt,qv,qh,qi,qc,te,pe,qvenv) - -!-- microphysics -! goto 101 ! bypass microphysics - dt_save=dt - n_sub_step=3 - dt=dt/float(n_sub_step) - - do i_micro=1,n_sub_step -!-- sedim ? - call fallpart(NM1) -!-- microphysics - do L=2,nm1-1 - WBAR = 0.5*(W(L)+W(L-1)) - ES = ESAT_PR (T(L)) !BLOB SATURATION VAPOR PRESSURE, EM KPA - QSAT(L) = (EPS * ES) / (PE(L) - ES) !BLOB SATURATION LWC G/G DRY AIR - EST (L) = ES - RHO (L) = 3483.8 * PE (L) / T (L) ! AIR PARCEL DENSITY , G/M**3 -!srf18jun2005 -! IF (W(L) .ge. 0.) DQSDZ = (QSAT(L ) - QSAT(L-1)) / (ZT(L ) -ZT(L-1)) -! IF (W(L) .lt. 0.) DQSDZ = (QSAT(L+1) - QSAT(L )) / (ZT(L+1) -ZT(L )) - IF (W(L) .ge. 0.) then - DQSDZ = (QSAT(L+1) - QSAT(L-1)) / (ZT(L+1 )-ZT(L-1)) - ELSE - DQSDZ = (QSAT(L+1) - QSAT(L-1)) / (ZT(L+1) -ZT(L-1)) - ENDIF - - call waterbal - enddo - enddo - dt=dt_save -! - 101 continue -! -!-- W-viscosity for stability - call visc_W(nm1,deltak,kmt) - -!-- update scalars - call update_plumerise(nm1,'S') - - call hadvance_plumerise(1,nm1,dt,WC,WT,W,mintime) - -!-- Buoyancy - call buoyancy_plumerise(NM1, T, TE, QV, QVENV, QH, QI, QC, WT, SCR1) - -!-- Entrainment - call entrainment(NM1,W,WT,RADIUS,ALPHA) - -!-- update W - call update_plumerise(nm1,'W') - - call hadvance_plumerise(2,nm1,dt,WC,WT,W,mintime) - - -!-- misc - do k=2,nm1 -! pe esta em kpa - esat do rams esta em mbar = 100 Pa = 0.1 kpa -! es = 0.1*esat (t(k)) !blob saturation vapor pressure, em kPa -! rotina do plumegen calcula em kPa - es = esat_pr (t(k)) !blob saturation vapor pressure, em kPa - qsat(k) = (eps * es) / (pe(k) - es) !blob saturation lwc g/g dry air - est (k) = es - txs (k) = t(k) - te(k) - rho (k) = 3483.8 * pe (k) / t (k) ! air parcel density , g/m**3 - ! no pressure diff with radius - - if((abs(wc(k))).gt.wmax) wmax = abs(wc(k)) ! keep wmax largest w - enddo - -! Gravity wave damping using Rayleigh friction layer for W - call damp_grav_wave(2,nm1,deltak,dt,zt,zm,w,t,tt,qv,qh,qi,qc,te,pe,qvenv) -!--- - -!-- try to find the plume top (above surface height) - kk = 1 - do while (w (kk) .gt. 1.) - kk = kk + 1 - ztop = zm(kk) - !print*,'W=',w (kk) - enddo -! - ztop_(mintime) = ztop - ztopmax = max (ztop, ztopmax) - kkmax = max (kk , kkmax ) - !print * ,'ztopmax=', mintime,'mn ',ztop_(mintime), ztopmax - -! -!srf-27082005 -! if the solution is going to a stationary phase, exit - if(mintime > 10) then - if( abs(ztop_(mintime)-ztop_(mintime-10)) < DZ ) exit - endif - - if(ilastprint == mintime) then - call printout (izprint,nrectotal) - ilastprint = mintime+1 - endif - - -ENDDO !do next timestep - -!print * ,' ztopmax=',ztopmax,'m',mintime,'mn ' -!print*,'=======================================================' -! -!the last printout -if (izprint.ne.0) then - call printout (izprint,nrectotal) - close (2) - close (19) -endif - -RETURN -END SUBROUTINE MAKEPLUME -!------------------------------------------------------------------------------- -! -SUBROUTINE BURN(EFLUX, WATER) -! -!- calculates the energy flux and water content at lboundary -!use module_zero_plumegen_coms -!real, parameter :: HEAT = 21.E6 !Joules/kg -!real, parameter :: HEAT = 15.5E6 !Joules/kg - cerrado -real, parameter :: HEAT = 19.3E6 !Joules/kg - floresta em Alta Floresta (MT) -real :: eflux,water -! -! The emission factor for water is 0.5. The water produced, in kg, -! is then fuel mass*0.5 + (moist/100)*mass per square meter. -! The fire burns for DT out of TDUR seconds, the total amount of -! fuel burned is AREA*BLOAD*(DT/TDUR) kg. this amount of fuel is -! considered to be spread over area AREA and so the mass burned per -! unit area is BLOAD*(DT/TDUR), and the rate is BLOAD/TDUR. -! -IF (TIME.GT.TDUR) THEN !is the burn over? - EFLUX = 0.000001 !prevent a potential divide by zero - WATER = 0. - RETURN -ELSE -! - EFLUX = HEATING (MINTIME) ! Watts/m**2 -! WATER = EFLUX * (DT / HEAT) * (0.5 + FMOIST) ! kg/m**2 - WATER = EFLUX * (DT / HEAT) * (0.5 + FMOIST) /0.55 ! kg/m**2 - WATER = WATER * 1000. ! g/m**2 -! -! print*,'BURN:',time,EFLUX/1.e+9 -ENDIF -! -RETURN -END SUBROUTINE BURN -!------------------------------------------------------------------------------- -! -SUBROUTINE LBOUND () -! -! ********** BOUNDARY CONDITIONS AT ZSURF FOR PLUME AND CLOUD ******** -! -! source of equations: J.S. Turner Buoyancy Effects in Fluids -! Cambridge U.P. 1973 p.172, -! G.A. Briggs Plume Rise, USAtomic Energy Commissio -! TID-25075, 1969, P.28 -! -! fundamentally a point source below ground. at surface, this produces -! a velocity w(1) and temperature T(1) which vary with time. There is -! also a water load which will first saturate, then remainder go into -! QC(1). -! EFLUX = energy flux at ground,watt/m**2 for the last DT -! -!use module_zero_plumegen_coms -implicit none -real, parameter :: g = 9.80796, r = 287.04, cp = 1004.6, eps = 0.622,tmelt = 273.3 -real, parameter :: tfreeze = 269.3, pi = 3.14159, e1 = 1./3., e2 = 5./3. -real :: es, esat, eflux, water, pres, c1, c2, f, zv, denscor, xwater !,ESAT_PR -! real, external:: esat_pr! - -! -QH (1) = QH (2) !soak up hydrometeors -QI (1) = QI (2) -QC (1) = 0. !no cloud here -! -! - CALL BURN (EFLUX, WATER) -! -! calculate parameters at boundary from a virtual buoyancy point source -! - PRES = PE (1) * 1000. !need pressure in N/m**2 - - C1 = 5. / (6. * ALPHA) !alpha is entrainment constant - - C2 = 0.9 * ALPHA - - F = EFLUX / (PRES * CP * PI) - - F = G * R * F * AREA !buoyancy flux - - ZV = C1 * RSURF !virtual boundary height - - W (1) = C1 * ( (C2 * F) **E1) / ZV**E1 !boundary velocity - - DENSCOR = C1 * F / G / (C2 * F) **E1 / ZV**E2 !density correction - - T (1) = TE (1) / (1. - DENSCOR) !temperature of virtual plume at zsurf - -! - WC(1) = W(1) - - !SC(1) = SCE(1)+F/1000.*dt ! gas/particle (g/g) - -! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -! match dw/dz,dt/dz at the boundary. F is conserved. -! - !WBAR = W (1) * (1. - 1. / (6. * ZV) ) - !ADVW = WBAR * W (1) / (3. * ZV) - !ADVT = WBAR * (5. / (3. * ZV) ) * (DENSCOR / (1. - DENSCOR) ) - !ADVC = 0. - !ADVH = 0. - !ADVI = 0. - !ADIABAT = - WBAR * G / CP - VTH (1) = - 4. - VTI (1) = - 3. - TXS (1) = T (1) - TE (1) - - VISC (1) = VISCOSITY - - RHO (1) = 3483.8 * PE (1) / T (1) !air density at level 1, g/m**3 - - XWATER = WATER / (W (1) * DT * RHO (1) ) !firewater mixing ratio - - QV (1) = XWATER + QVENV (1) !plus what's already there - - -! PE esta em kPa - ESAT do RAMS esta em mbar = 100 Pa = 0.1 kPa -! ES = 0.1*ESAT (T(1)) !blob saturation vapor pressure, em kPa -! rotina do plumegen ja calcula em kPa - ES = ESAT_PR (T(1)) !blob saturation vapor pressure, em kPa - - EST (1) = ES - QSAT (1) = (EPS * ES) / (PE (1) - ES) !blob saturation lwc g/g dry air - - IF (QV (1) .gt. QSAT (1) ) THEN - QC (1) = QV (1) - QSAT (1) + QC (1) !remainder goes into cloud drops - QV (1) = QSAT (1) - ENDIF -! - CALL WATERBAL -! -RETURN -END SUBROUTINE LBOUND -!------------------------------------------------------------------------------- -! -SUBROUTINE INITIAL ( kmt) -! -! ************* SETS UP INITIAL CONDITIONS FOR THE PROBLEM ************ -!use module_zero_plumegen_coms -implicit none -real, parameter :: tfreeze = 269.3 -integer :: isub, k, n1, n2, n3, lbuoy, itmp, isubm1 ,kmt -real :: xn1, xi, es, esat!,ESAT_PR -! -N=kmt -! initialize temperature structure,to the end of equal spaced sounding, - do k = 1, N - TXS (k) = 0.0 - W (k) = 0.0 - T (k) = TE(k) !blob set to environment - WC(k) = 0.0 - WT(k) = 0.0 - QV(k) = QVENV (k) !blob set to environment - VTH(k) = 0. !initial rain velocity = 0 - VTI(k) = 0. !initial ice velocity = 0 - QH(k) = 0. !no rain - QI(k) = 0. !no ice - QC(k) = 0. !no cloud drops -! PE esta em kPa - ESAT do RAMS esta em mbar = 100 Pa = 0.1 kPa -! ES = 0.1*ESAT (T(k)) !blob saturation vapor pressure, em kPa -! rotina do plumegen calcula em kPa - ES = ESAT_PR (T(k)) !blob saturation vapor pressure, em kPa - EST (k) = ES - QSAT (k) = (.622 * ES) / (PE (k) - ES) !saturation lwc g/g - RHO (k) = 3483.8 * PE (k) / T (k) !dry air density g/m**3 - enddo - -! Initialize the entrainment radius, Turner-style plume - radius(1) = rsurf - do k=2,N - radius(k) = radius(k-1)+(6./5.)*alpha*(zt(k)-zt(k-1)) - enddo - -! Initialize the viscosity - VISC (1) = VISCOSITY - do k=2,N - VISC (k) = VISCOSITY!max(1.e-3,visc(k-1) - 1.* VISCOSITY/float(nkp)) - enddo -!-- Initialize gas/concentration - !DO k =10,20 - ! SC(k) = 20. - !ENDDO - !stop 333 - - CALL LBOUND() - -RETURN -END SUBROUTINE INITIAL -!------------------------------------------------------------------------------- -! -subroutine damp_grav_wave(ifrom,nm1,deltak,dt,zt,zm,w,t,tt,qv,qh,qi,qc,te,pe,qvenv) -implicit none -integer nm1,ifrom,deltak -real dt -real, dimension(nm1) :: w,t,tt,qv,qh,qi,qc,te,pe,qvenv,dummy,zt,zm - -if(ifrom==1) then - call friction(ifrom,nm1,deltak,dt,zt,zm,t,tt ,te) -!call friction(ifrom,nm1,dt,zt,zm,qv,qvt,qvenv) - return -endif - -dummy(:) = 0. -if(ifrom==2) call friction(ifrom,nm1,deltak,dt,zt,zm,w,dummy ,dummy) -!call friction(ifrom,nm1,dt,zt,zm,qi,qit ,dummy) -!call friction(ifrom,nm1,dt,zt,zm,qh,qht ,dummy) -!call friction(ifrom,nm1,dt,zt,zm,qc,qct ,dummy) -return -end subroutine damp_grav_wave -!------------------------------------------------------------------------------- -! -subroutine friction(ifrom,nm1,deltak,dt,zt,zm,var1,vart,var2) -implicit none -real, dimension(nm1) :: var1,var2,vart,zt,zm -integer k,nfpt,kf,nm1,ifrom,deltak -real zmkf,ztop,distim,c1,c2,dt - -!nfpt=50 -!kf = nm1 - nfpt -kf = nm1 - int(deltak/2) - -zmkf = zm(kf) !old: float(kf )*dz -ztop = zm(nm1) -!distim = min(4.*dt,200.) -distim = 60. - -c1 = 1. / (distim * (ztop - zmkf)) -c2 = dt * c1 - -if(ifrom == 1) then - do k = nm1,2,-1 - if (zt(k) .le. zmkf) cycle - vart(k) = vart(k) + c1 * (zt(k) - zmkf)*(var2(k) - var1(k)) - enddo -elseif(ifrom == 2) then - do k = nm1,2,-1 - if (zt(k) .le. zmkf) cycle - var1(k) = var1(k) + c2 * (zt(k) - zmkf)*(var2(k) - var1(k)) - enddo -endif -return -end subroutine friction -!------------------------------------------------------------------------------- -! -subroutine vel_advectc_plumerise(m1,wc,wt,rho,dzm) - -implicit none -integer :: k,m1 -real, dimension(m1) :: wc,wt,flxw,dzm,rho -real, dimension(m1) :: dn0 ! var local -real :: c1z - -!dzm(:)= 1./dz - -dn0(1:m1)=rho(1:m1)*1.e-3 ! converte de cgs para mks - -flxw(1) = wc(1) * dn0(1) - -do k = 2,m1-1 - flxw(k) = wc(k) * .5 * (dn0(k) + dn0(k+1)) -enddo - -! Compute advection contribution to W tendency - -c1z = .5 - -do k = 2,m1-2 - - wt(k) = wt(k) & - + c1z * dzm(k) / (dn0(k) + dn0(k+1)) * ( & - (flxw(k) + flxw(k-1)) * (wc(k) + wc(k-1)) & - - (flxw(k) + flxw(k+1)) * (wc(k) + wc(k+1)) & - + (flxw(k+1) - flxw(k-1)) * 2.* wc(k) ) - -enddo - -return -end subroutine vel_advectc_plumerise -!------------------------------------------------------------------------------- -! -subroutine hadvance_plumerise(iac,m1,dt,wc,wt,wp,mintime) - -implicit none -integer :: k,iac -integer :: m1,mintime -real, dimension(m1) :: dummy, wc,wt,wp -real eps,dt -! It is here that the Asselin filter is applied. For the velocities -! and pressure, this must be done in two stages, the first when -! IAC=1 and the second when IAC=2. - - -eps = .2 -if(mintime == 1) eps=0.5 - -! For both IAC=1 and IAC=2, call PREDICT for U, V, W, and P. -! -call predict_plumerise(m1,wc,wp,wt,dummy,iac,2.*dt,eps) -!print*,'mintime',mintime,eps -!do k=1,m1 -! print*,'W-HAD',k,wc(k),wp(k),wt(k) -!enddo -return -end subroutine hadvance_plumerise -!------------------------------------------------------------------------------- -! -subroutine predict_plumerise(npts,ac,ap,fa,af,iac,dtlp,epsu) -implicit none -integer :: npts,iac,m -real :: epsu,dtlp -real, dimension(*) :: ac,ap,fa,af - -! For IAC=3, this routine moves the arrays AC and AP forward by -! 1 time level by adding in the prescribed tendency. It also -! applies the Asselin filter given by: - -! {AC} = AC + EPS * (AP - 2 * AC + AF) - -! where AP,AC,AF are the past, current and future time levels of A. -! All IAC=1 does is to perform the {AC} calculation without the AF -! term present. IAC=2 completes the calculation of {AC} by adding -! the AF term only, and advances AC by filling it with input AP -! values which were already updated in ACOUSTC. -! - -if (iac .eq. 1) then - do m = 1,npts - ac(m) = ac(m) + epsu * (ap(m) - 2. * ac(m)) - enddo - return -elseif (iac .eq. 2) then - do m = 1,npts - af(m) = ap(m) - ap(m) = ac(m) + epsu * af(m) - enddo -!elseif (iac .eq. 3) then -! do m = 1,npts -! af(m) = ap(m) + dtlp * fa(m) -! enddo -! if (ngrid .eq. 1 .and. ipara .eq. 0) call cyclic(nzp,nxp,nyp,af,'T') -! do m = 1,npts -! ap(m) = ac(m) + epsu * (ap(m) - 2. * ac(m) + af(m)) -! enddo -endif - -do m = 1,npts - ac(m) = af(m) -enddo -return -end subroutine predict_plumerise -!------------------------------------------------------------------------------- -! -subroutine buoyancy_plumerise(m1, T, TE, QV, QVENV, QH, QI, QC, WT, scr1) -implicit none -integer :: k,m1 -real, parameter :: g = 9.8, eps = 0.622, gama = 0.5 ! mass virtual coeff. -real, dimension(m1) :: T, TE, QV, QVENV, QH, QI, QC, WT, scr1 -real :: TV,TVE,QWTOTL,umgamai -real, parameter :: mu = 0.15 - -!- orig -umgamai = 1./(1.+gama) ! compensa a falta do termo de aceleracao associado `as - ! das pertubacoes nao-hidrostaticas no campo de pressao - -!- new ! Siesbema et al, 2004 -!umgamai = 1./(1.-2.*mu) - -do k = 2,m1-1 - - TV = T(k) * (1. + (QV(k) /EPS))/(1. + QV(k) ) !blob virtual temp. - TVE = TE(k) * (1. + (QVENV(k)/EPS))/(1. + QVENV(k)) !and environment - - QWTOTL = QH(k) + QI(k) + QC(k) ! QWTOTL*G is drag -!- orig - !scr1(k)= G*( umgamai*( TV - TVE) / TVE - QWTOTL) - scr1(k)= G* umgamai*( (TV - TVE) / TVE - QWTOTL) - - !if(k .lt. 10)print*,'BT',k,TV,TVE,TVE,QWTOTL -enddo - -do k = 2,m1-2 - wt(k) = wt(k)+0.5*(scr1(k)+scr1(k+1)) -! print*,'W-BUO',k,wt(k),scr1(k),scr1(k+1) -enddo - -end subroutine buoyancy_plumerise -!------------------------------------------------------------------------------- -! -subroutine ENTRAINMENT(m1,w,wt,radius,ALPHA) -implicit none -integer :: k,m1 -real, dimension(m1) :: w,wt,radius -real DMDTM,ALPHA,WBAR,RADIUS_BAR,umgamai -real, parameter :: mu = 0.15 ,gama = 0.5 ! mass virtual coeff. - -!- new - Siesbema et al, 2004 -!umgamai = 1./(1.-2.*mu) - -!- orig -!umgamai = 1 -umgamai = 1./(1.+gama) ! compensa a falta do termo de aceleracao associado `as - ! das pertubacoes nao-hidrostaticas no campo de pressao - -! -!-- ALPHA/RADIUS(L) = (1/M)DM/DZ (W 14a) - do k=2,m1-1 - -!-- for W: WBAR is only W(k) -! WBAR=0.5*(W(k)+W(k-1)) - WBAR=W(k) - RADIUS_BAR = 0.5*(RADIUS(k) + RADIUS(k+1)) -! orig - !DMDTM = 2. * ALPHA * ABS (WBAR) / RADIUS_BAR != (1/M)DM/DT - DMDTM = umgamai * 2. * ALPHA * ABS (WBAR) / RADIUS_BAR != (1/M)DM/DT - -!-- DMDTM*W(L) entrainment, - wt(k) = wt(k) - DMDTM*ABS (WBAR) - !print*,'W-ENTR=',k,w(k),- DMDTM*ABS (WBAR) - enddo -end subroutine ENTRAINMENT -!------------------------------------------------------------------------------- -! -subroutine scl_advectc_plumerise(varn,mzp) -!use module_zero_plumegen_coms -implicit none -integer :: mzp -character(len=*) :: varn -real :: dtlto2 -integer :: k - -! wp => w -!- Advect scalars - dtlto2 = .5 * dt -! vt3dc(1) = (w(1) + wc(1)) * dtlto2 * dne(1) - vt3dc(1) = (w(1) + wc(1)) * dtlto2 * rho(1)*1.e-3!converte de CGS p/ MKS - vt3df(1) = .5 * (w(1) + wc(1)) * dtlto2 * dzm(1) - - do k = 2,mzp -! vt3dc(k) = (w(k) + wc(k)) * dtlto2 *.5 * (dne(k) + dne(k+1)) - vt3dc(k) = (w(k) + wc(k)) * dtlto2 *.5 * (rho(k) + rho(k+1))*1.e-3 - vt3df(k) = (w(k) + wc(k)) * dtlto2 *.5 * dzm(k) - !print*,'vt3df-vt3dc',k,vt3dc(k),vt3df(k) - enddo - - -!-srf-24082005 -! do k = 1,mzp-1 - do k = 1,mzp - vctr1(k) = (zt(k+1) - zm(k)) * dzm(k) - vctr2(k) = (zm(k) - zt(k)) * dzm(k) -! vt3dk(k) = dzt(k) / dne(k) - vt3dk(k) = dzt(k) /(rho(k)*1.e-3) - !print*,'VT3dk',k,dzt(k) , dne(k) - enddo - -! scalarp => scalar_tab(n,ngrid)%var_p -! scalart => scalar_tab(n,ngrid)%var_t - -!- temp advection tendency (TT) - scr1=T - call fa_zc_plumerise(mzp & - ,T ,scr1 (1) & - ,vt3dc (1) ,vt3df (1) & - ,vt3dg (1) ,vt3dk (1) & - ,vctr1,vctr2 ) - - call advtndc_plumerise(mzp,T,scr1(1),TT,dt) - -!- water vapor advection tendency (QVT) - scr1=QV - call fa_zc_plumerise(mzp & - ,QV ,scr1 (1) & - ,vt3dc (1) ,vt3df (1) & - ,vt3dg (1) ,vt3dk (1) & - ,vctr1,vctr2 ) - - call advtndc_plumerise(mzp,QV,scr1(1),QVT,dt) - -!- liquid advection tendency (QCT) - scr1=QC - call fa_zc_plumerise(mzp & - ,QC ,scr1 (1) & - ,vt3dc (1) ,vt3df (1) & - ,vt3dg (1) ,vt3dk (1) & - ,vctr1,vctr2 ) - - call advtndc_plumerise(mzp,QC,scr1(1),QCT,dt) - -!- ice advection tendency (QIT) - scr1=QI - call fa_zc_plumerise(mzp & - ,QI ,scr1 (1) & - ,vt3dc (1) ,vt3df (1) & - ,vt3dg (1) ,vt3dk (1) & - ,vctr1,vctr2 ) - - call advtndc_plumerise(mzp,QI,scr1(1),QIT,dt) - -!- hail/rain advection tendency (QHT) -! if(ak1 > 0. .or. ak2 > 0.) then - - scr1=QH - call fa_zc_plumerise(mzp & - ,QH ,scr1 (1) & - ,vt3dc (1) ,vt3df (1) & - ,vt3dg (1) ,vt3dk (1) & - ,vctr1,vctr2 ) - - call advtndc_plumerise(mzp,QH,scr1(1),QHT,dt) -! endif - - return - -!- gas/particle advection tendency (SCT) -! if(varn == 'SC')return - scr1=SC - call fa_zc_plumerise(mzp & - ,SC ,scr1 (1) & - ,vt3dc (1) ,vt3df (1) & - ,vt3dg (1) ,vt3dk (1) & - ,vctr1,vctr2 ) - - call advtndc_plumerise(mzp,SC,scr1(1),SCT,dt) - - -return -end subroutine scl_advectc_plumerise -!------------------------------------------------------------------------------- -! -subroutine fa_zc_plumerise(m1,scp,scr1,vt3dc,vt3df,vt3dg,vt3dk,vctr1,vctr2) - -implicit none -integer :: m1,k -real :: dfact -real, dimension(m1) :: scp,scr1,vt3dc,vt3df,vt3dg,vt3dk -real, dimension(m1) :: vctr1,vctr2 - -dfact = .5 - -! Compute scalar flux VT3DG - do k = 1,m1-1 - vt3dg(k) = vt3dc(k) & - * (vctr1(k) * scr1(k) & - + vctr2(k) * scr1(k+1) & - + vt3df(k) * (scr1(k) - scr1(k+1))) - enddo - -! Modify fluxes to retain positive-definiteness on scalar quantities. -! If a flux will remove 1/2 quantity during a timestep, -! reduce to first order flux. This will remain positive-definite -! under the assumption that ABS(CFL(i)) + ABS(CFL(i-1)) < 1.0 if -! both fluxes are evacuating the box. - -do k = 1,m1-1 - if (vt3dc(k) .gt. 0.) then - if (vt3dg(k) * vt3dk(k) .gt. dfact * scr1(k)) then - vt3dg(k) = vt3dc(k) * scr1(k) - endif - elseif (vt3dc(k) .lt. 0.) then - if (-vt3dg(k) * vt3dk(k+1) .gt. dfact * scr1(k+1)) then - vt3dg(k) = vt3dc(k) * scr1(k+1) - endif - endif - -enddo - -! Compute flux divergence - -do k = 2,m1-1 - scr1(k) = scr1(k) & - + vt3dk(k) * ( vt3dg(k-1) - vt3dg(k) & - + scp (k) * ( vt3dc(k) - vt3dc(k-1))) -enddo -return -end subroutine fa_zc_plumerise -!------------------------------------------------------------------------------- -! -subroutine advtndc_plumerise(m1,scp,sca,sct,dtl) -implicit none -integer :: m1,k -real :: dtl,dtli -real, dimension(m1) :: scp,sca,sct - -dtli = 1. / dtl -do k = 2,m1-1 - sct(k) = sct(k) + (sca(k)-scp(k)) * dtli -enddo -return -end subroutine advtndc_plumerise -!------------------------------------------------------------------------------- -! -subroutine tend0_plumerise -!use module_zero_plumegen_coms, only: nm1,wt,tt,qvt,qct,qht,qit,sct - wt(1:nm1) = 0. - tt(1:nm1) = 0. -qvt(1:nm1) = 0. -qct(1:nm1) = 0. -qht(1:nm1) = 0. -qit(1:nm1) = 0. -!sct(1:nm1) = 0. -end subroutine tend0_plumerise - -! **************************************************************** - -subroutine scl_misc(m1) -!use module_zero_plumegen_coms -implicit none -real, parameter :: g = 9.81, cp=1004. -integer m1,k -real dmdtm - - do k=2,m1-1 - WBAR = 0.5*(W(k)+W(k-1)) -!-- dry adiabat - ADIABAT = - WBAR * G / CP -! -!-- entrainment - DMDTM = 2. * ALPHA * ABS (WBAR) / RADIUS (k) != (1/M)DM/DT - -!-- tendency temperature = adv + adiab + entrainment - TT(k) = TT(K) + ADIABAT - DMDTM * ( T (k) - TE (k) ) - -!-- tendency water vapor = adv + entrainment - QVT(K) = QVT(K) - DMDTM * ( QV (k) - QVENV (k) ) - - QCT(K) = QCT(K) - DMDTM * ( QC (k) ) - QHT(K) = QHT(K) - DMDTM * ( QH (k) ) - QIT(K) = QIT(K) - DMDTM * ( QI (k) ) - -!-- tendency gas/particle = adv + entrainment -! SCT(K) = SCT(K) - DMDTM * ( SC (k) - SCE (k) ) - -enddo -end subroutine scl_misc - -! **************************************************************** - -subroutine visc_W(m1,deltak,kmt) -!use module_zero_plumegen_coms -implicit none -integer m1,k,deltak,kmt,m2 -real dz1t,dz1m,dz2t,dz2m,d2wdz,d2tdz ,d2qvdz ,d2qhdz ,d2qcdz ,d2qidz ,d2scdz - -!srf--- 17/08/2005 -!m2=min(m1+deltak,kmt) -m2=min(m1,kmt) - -!do k=2,m1-1 -do k=2,m2-1 - DZ1T = 0.5*(ZT(K+1)-ZT(K-1)) - DZ2T = VISC (k) / (DZ1T * DZ1T) - DZ1M = 0.5*(ZM(K+1)-ZM(K-1)) - DZ2M = VISC (k) / (DZ1M * DZ1M) - D2WDZ = (W (k + 1) - 2 * W (k) + W (k - 1) ) * DZ2M - D2TDZ = (T (k + 1) - 2 * T (k) + T (k - 1) ) * DZ2T - D2QVDZ = (QV (k + 1) - 2 * QV (k) + QV (k - 1) ) * DZ2T - D2QHDZ = (QH (k + 1) - 2 * QH (k) + QH (k - 1) ) * DZ2T - D2QCDZ = (QC (k + 1) - 2 * QC (k) + QC (k - 1) ) * DZ2T - D2QIDZ = (QI (k + 1) - 2 * QI (k) + QI (k - 1) ) * DZ2T - !D2SCDZ = (SC (k + 1) - 2 * SC (k) + SC (k - 1) ) * DZ2T - - WT(k) = WT(k) + D2WDZ - TT(k) = TT(k) + D2TDZ - QVT(k) = QVT(k) + D2QVDZ - QCT(k) = QCT(k) + D2QCDZ - QHT(k) = QHT(k) + D2QHDZ - QIT(k) = QIT(k) + D2QIDZ - !SCT(k) = SCT(k) + D2SCDZ - !print*,'W-VISC=',k,D2WDZ -enddo - -end subroutine visc_W - -! **************************************************************** - -subroutine update_plumerise(m1,varn) -!use module_zero_plumegen_coms -integer m1,k -character(len=*) :: varn - -if(varn == 'W') then - - do k=2,m1-1 - W(k) = W(k) + WT(k) * DT - enddo - return - -else -do k=2,m1-1 - T(k) = T(k) + TT(k) * DT - - QV(k) = QV(k) + QVT(k) * DT - - QC(k) = QC(k) + QCT(k) * DT !cloud drops travel with air - QH(k) = QH(k) + QHT(k) * DT - QI(k) = QI(k) + QIT(k) * DT -! SC(k) = SC(k) + SCT(k) * DT - -!srf---18jun2005 - QV(k) = max(0., QV(k)) - QC(k) = max(0., QC(k)) - QH(k) = max(0., QH(k)) - QI(k) = max(0., QI(k)) -! SC(k) = max(0., SC(k)) - - enddo -endif -end subroutine update_plumerise -!------------------------------------------------------------------------------- -! -subroutine fallpart(m1) -!use module_zero_plumegen_coms -integer m1,k -real vtc, dfhz,dfiz,dz1 -!srf================================== -! verificar se o gradiente esta correto -! -!srf================================== -! -! XNO=1.E7 [m**-4] median volume diameter raindrop,Kessler -! VC = 38.3/(XNO**.125), median volume fallspeed eqn., Kessler -! for ice, see (OT18), use F0=0.75 per argument there. rho*q -! values are in g/m**3, velocities in m/s - -real, PARAMETER :: VCONST = 5.107387, EPS = 0.622, F0 = 0.75 -real, PARAMETER :: G = 9.81, CP = 1004. -! -do k=2,m1-1 - - VTC = VCONST * RHO (k) **.125 ! median volume fallspeed (KTable4) - -! hydrometeor assembly velocity calculations (K Table4) -! VTH(k)=-VTC*QH(k)**.125 !median volume fallspeed, water - VTH (k) = - 4. !small variation with qh - - VHREL = W (k) + VTH (k) !relative to surrounding cloud - -! rain ventilation coefficient for evaporation - CVH(k) = 1.6 + 0.57E-3 * (ABS (VHREL) ) **1.5 -! -! VTI(k)=-VTC*F0*QI(k)**.125 !median volume fallspeed,ice - VTI (k) = - 3. !small variation with qi - - VIREL = W (k) + VTI (k) !relative to surrounding cloud -! -! ice ventilation coefficient for sublimation - CVI(k) = 1.6 + 0.57E-3 * (ABS (VIREL) ) **1.5 / F0 -! -! - IF (VHREL.GE.0.0) THEN - DFHZ=QH(k)*(RHO(k )*VTH(k )-RHO(k-1)*VTH(k-1))/RHO(k-1) - ELSE - DFHZ=QH(k)*(RHO(k+1)*VTH(k+1)-RHO(k )*VTH(k ))/RHO(k) - ENDIF - ! - ! - IF (VIREL.GE.0.0) THEN - DFIZ=QI(k)*(RHO(k )*VTI(k )-RHO(k-1)*VTI(k-1))/RHO(k-1) - ELSE - DFIZ=QI(k)*(RHO(k+1)*VTI(k+1)-RHO(k )*VTI(k ))/RHO(k) - ENDIF - - DZ1=ZM(K)-ZM(K-1) - - qht(k) = qht(k) - DFHZ / DZ1 !hydrometeors don't - - qit(k) = qit(k) - DFIZ / DZ1 !nor does ice? hail, what about - -enddo -end subroutine fallpart -!------------------------------------------------------------------------------- -!------------------------------------------------------------------------------- -! -subroutine printout (izprint,nrectotal) -!use module_zero_plumegen_coms -real, parameter :: tmelt = 273.3 -integer, save :: nrec -data nrec/0/ -integer :: ko,izprint,interval,nrectotal -real :: pea, btmp,etmp,vap1,vap2,gpkc,gpkh,gpki,deficit -interval = 1 !debug time interval,min - -! -IF (IZPRINT.EQ.0) RETURN - -IF(MINTIME == 1) nrec = 0 -! -WRITE (2, 430) MINTIME, DT, TIME -WRITE (2, 431) ZTOP -WRITE (2, 380) -! -! do the print -! - DO 390 KO = 1, nrectotal, interval - - PEA = PE (KO) * 10. !pressure is stored in decibars(kPa),print in mb; - BTMP = T (KO) - TMELT !temps in Celsius - ETMP = T (KO) - TE (KO) !temperature excess - VAP1 = QV (KO) * 1000. !printout in g/kg for all water, - VAP2 = QSAT (KO) * 1000. !vapor (internal storage is in g/g) - GPKC = QC (KO) * 1000. !cloud water - GPKH = QH (KO) * 1000. !raindrops - GPKI = QI (KO) * 1000. !ice particles - DEFICIT = VAP2 - VAP1 !vapor deficit -! - WRITE (2, 400) zt(KO)/1000., PEA, W (KO), BTMP, ETMP, VAP1, & - VAP2, GPKC, GPKH, GPKI, VTH (KO), SC(KO) -! -! -! !end of printout - - 390 CONTINUE - - nrec=nrec+1 - write (19,rec=nrec) (W (KO), KO=1,nrectotal) - nrec=nrec+1 - write (19,rec=nrec) (T (KO), KO=1,nrectotal) - nrec=nrec+1 - write (19,rec=nrec) (TE(KO), KO=1,nrectotal) - nrec=nrec+1 - write (19,rec=nrec) (QV(KO)*1000., KO=1,nrectotal) - nrec=nrec+1 - write (19,rec=nrec) (QC(KO)*1000., KO=1,nrectotal) - nrec=nrec+1 - write (19,rec=nrec) (QH(KO)*1000., KO=1,nrectotal) - nrec=nrec+1 - write (19,rec=nrec) (QI(KO)*1000., KO=1,nrectotal) - nrec=nrec+1 -! write (19,rec=nrec) (SC(KO), KO=1,nrectotal) - write (19,rec=nrec) (QSAT(KO)*1000., KO=1,nrectotal) - nrec=nrec+1 - write (19,rec=nrec) (QVENV(KO)*1000., KO=1,nrectotal) - - - -!print*,'ntimes=',nrec/(9) -! -RETURN -! -! ************** FORMATS ********************************************* -! - 380 FORMAT(/,' Z(KM) P(MB) W(MPS) T(C) T-TE VAP SAT QC QH' & -' QI VTH(MPS) SCAL'/) -! - 400 FORMAT(1H , F4.1,F7.2,F7.2,F6.1,6F6.2,F7.2,1X,F6.2) -! - 430 FORMAT(1H ,//I5,' MINUTES DT= ',F6.2,' SECONDS TIME= ' & - ,F8.2,' SECONDS') - 431 FORMAT(' ZTOP= ',F10.2) -! -end subroutine printout -! -! ********************************************************************* -SUBROUTINE WATERBAL -!use module_zero_plumegen_coms -! - -IF (QC (L) .LE.1.0E-10) QC (L) = 0. !DEFEAT UNDERFLOW PROBLEM -IF (QH (L) .LE.1.0E-10) QH (L) = 0. -IF (QI (L) .LE.1.0E-10) QI (L) = 0. -! -CALL EVAPORATE !vapor to cloud,cloud to vapor -! -CALL SUBLIMATE !vapor to ice -! -CALL GLACIATE !rain to ice - -CALL MELT !ice to rain -! -!if(ak1 > 0. .or. ak2 > 0.) & -CALL CONVERT () !(auto)conversion and accretion -!CALL CONVERT2 () !(auto)conversion and accretion -! - -RETURN -END SUBROUTINE WATERBAL -! ********************************************************************* -SUBROUTINE EVAPORATE -! -!- evaporates cloud,rain and ice to saturation -! -!use module_zero_plumegen_coms -implicit none -! -! XNO=10.0E06 -! HERC = 1.93*1.E-6*XN035 !evaporation constant -! -real, PARAMETER :: HERC = 5.44E-4, CP = 1.004, HEATCOND = 2.5E3 -real, PARAMETER :: HEATSUBL = 2834., TMELT = 273., TFREEZE = 269.3 - -real, PARAMETER :: FRC = HEATCOND / CP, SRC = HEATSUBL / CP - -real :: evhdt, evidt, evrate, evap, sd, quant, dividend, divisor, devidt - -! -! -SD = QSAT (L) - QV (L) !vapor deficit -IF (SD.EQ.0.0) RETURN -!IF (abs(SD).lt.1.e-7) RETURN - - -EVHDT = 0. -EVIDT = 0. -!evrate =0.; evap=0.; sd=0.0; quant=0.0; dividend=0.0; divisor=0.0; devidt=0.0 - -EVRATE = ABS (WBAR * DQSDZ) !evaporation rate (Kessler 8.32) -EVAP = EVRATE * DT !what we can get in DT - - -IF (SD.LE.0.0) THEN ! condense. SD is negative - - IF (EVAP.GE.ABS (SD) ) THEN !we get it all - - QC (L) = QC (L) - SD !deficit,remember? - QV (L) = QSAT(L) !set the vapor to saturation - T (L) = T (L) - SD * FRC !heat gained through condensation - !per gram of dry air - RETURN - - ELSE - - QC (L) = QC (L) + EVAP !get what we can in DT - QV (L) = QV (L) - EVAP !remove it from the vapor - T (L) = T (L) + EVAP * FRC !get some heat - - RETURN - - ENDIF -! -ELSE !SD is positive, need some water -! -! not saturated. saturate if possible. use everything in order -! cloud, rain, ice. SD is positive - - IF (EVAP.LE.QC (L) ) THEN !enough cloud to last DT -! - - IF (SD.LE.EVAP) THEN !enough time to saturate - - QC (L) = QC (L) - SD !remove cloud - QV (L) = QSAT (L) !saturate - T (L) = T (L) - SD * FRC !cool the parcel - RETURN !done -! - - ELSE !not enough time - - SD = SD-EVAP !use what there is - QV (L) = QV (L) + EVAP !add vapor - T (L) = T (L) - EVAP * FRC !lose heat - QC (L) = QC (L) - EVAP !lose cloud - !go on to rain. - ENDIF -! - ELSE !not enough cloud to last DT -! - IF (SD.LE.QC (L) ) THEN !but there is enough to sat - - QV (L) = QSAT (L) !use it - QC (L) = QC (L) - SD - T (L) = T (L) - SD * FRC - RETURN - - ELSE !not enough to sat - SD = SD-QC (L) - QV (L) = QV (L) + QC (L) - T (L) = T (L) - QC (L) * FRC - QC (L) = 0.0 !all gone - - ENDIF !on to rain - ENDIF !finished with cloud -! -! but still not saturated, so try to use some rain -! this is tricky, because we only have time DT to evaporate. if there -! is enough rain, we can evaporate it for dt. ice can also sublimate -! at the same time. there is a compromise here.....use rain first, then -! ice. saturation may not be possible in one DT time. -! rain evaporation rate (W12),(OT25),(K Table 4). evaporate rain first -! sd is still positive or we wouldn't be here. - - - IF (QH (L) .LE.1.E-10) GOTO 33 - -!srf-25082005 -! QUANT = ( QC (L) + QV (L) - QSAT (L) ) * RHO (L) !g/m**3 - QUANT = ( QSAT (L)- QC (L) - QV (L) ) * RHO (L) !g/m**3 -! - EVHDT = (DT * HERC * (QUANT) * (QH (L) * RHO (L) ) **.65) / RHO (L) -! rain evaporation in time DT - - IF (EVHDT.LE.QH (L) ) THEN !enough rain to last DT - - IF (SD.LE.EVHDT) THEN !enough time to saturate - QH (L) = QH (L) - SD !remove rain - QV (L) = QSAT (L) !saturate - T (L) = T (L) - SD * FRC !cool the parcel - - RETURN !done -! - ELSE !not enough time - SD = SD-EVHDT !use what there is - QV (L) = QV (L) + EVHDT !add vapor - T (L) = T (L) - EVHDT * FRC !lose heat - QH (L) = QH (L) - EVHDT !lose rain - - ENDIF !go on to ice. -! - ELSE !not enough rain to last DT -! - IF (SD.LE.QH (L) ) THEN !but there is enough to sat - QV (L) = QSAT (L) !use it - QH (L) = QH (L) - SD - T (L) = T (L) - SD * FRC - RETURN -! - ELSE !not enough to sat - SD = SD-QH (L) - QV (L) = QV (L) + QH (L) - T (L) = T (L) - QH (L) * FRC - QH (L) = 0.0 !all gone - - ENDIF !on to ice -! - - ENDIF !finished with rain -! -! -! now for ice -! equation from (OT); correction factors for units applied -! - 33 continue - IF (QI (L) .LE.1.E-10) RETURN !no ice there -! - DIVIDEND = ( (1.E6 / RHO (L) ) **0.475) * (SD / QSAT (L) & - - 1) * (QI (L) **0.525) * 1.13 - DIVISOR = 7.E5 + 4.1E6 / (10. * EST (L) ) - - DEVIDT = - CVI(L) * DIVIDEND / DIVISOR !rate of change - - EVIDT = DEVIDT * DT !what we could get -! -! logic here is identical to rain. could get fancy and make subroutine -! but duplication of code is easier. God bless the screen editor. -! - - IF (EVIDT.LE.QI (L) ) THEN !enough ice to last DT -! - - IF (SD.LE.EVIDT) THEN !enough time to saturate - QI (L) = QI (L) - SD !remove ice - QV (L) = QSAT (L) !saturate - T (L) = T (L) - SD * SRC !cool the parcel - - RETURN !done -! - - ELSE !not enough time - - SD = SD-EVIDT !use what there is - QV (L) = QV (L) + EVIDT !add vapor - T (L) = T (L) - EVIDT * SRC !lose heat - QI (L) = QI (L) - EVIDT !lose ice - - ENDIF !go on,unsatisfied -! - ELSE !not enough ice to last DT -! - IF (SD.LE.QI (L) ) THEN !but there is enough to sat - - QV (L) = QSAT (L) !use it - QI (L) = QI (L) - SD - T (L) = T (L) - SD * SRC - - RETURN -! - ELSE !not enough to sat - SD = SD-QI (L) - QV (L) = QV (L) + QI (L) - T (L) = T (L) - QI (L) * SRC - QI (L) = 0.0 !all gone - - ENDIF !on to better things - !finished with ice - ENDIF -! -ENDIF !finished with the SD decision -! -RETURN -! -END SUBROUTINE EVAPORATE -! -! ********************************************************************* -SUBROUTINE CONVERT () -! -!- ACCRETION AND AUTOCONVERSION -! -!use module_zero_plumegen_coms -! -real, PARAMETER :: AK1 = 0.001 !conversion rate constant -real, PARAMETER :: AK2 = 0.0052 !collection (accretion) rate -real, PARAMETER :: TH = 0.5 !Kessler threshold -integer, PARAMETER ::iconv = 1 !- Kessler conversion (=0) - -!real, parameter :: ANBASE = 50.!*1.e+6 !Berry-number at cloud base #/m^3(maritime) - real, parameter :: ANBASE =100000.!*1.e+6 !Berry-number at cloud base #/m^3(continental) -!real, parameter :: BDISP = 0.366 !Berry--size dispersion (maritime) - real, parameter :: BDISP = 0.146 !Berry--size dispersion (continental) -real, parameter :: TFREEZE = 269.3 !ice formation temperature -! -real :: accrete, con, q, h, bc1, bc2, total - - -IF (T (L) .LE. TFREEZE) RETURN !process not allowed above ice -! -IF (QC (L) .EQ. 0. ) RETURN - -ACCRETE = 0. -CON = 0. -Q = RHO (L) * QC (L) -H = RHO (L) * QH (L) -! -! selection rules -! -! -IF (QH (L) .GT. 0. ) ACCRETE = AK2 * Q * (H**.875) !accretion, Kessler -! -IF (ICONV.NE.0) THEN !select Berry or Kessler -! -!old BC1 = 120. -!old BC2 = .0266 * ANBASE * 60. -!old CON = BDISP * Q * Q * Q / (BC1 * Q * BDISP + BC2) - - CON = Q*Q*Q*BDISP/(60.*(5.*Q*BDISP+0.0366*ANBASE)) -! -ELSE -! -! CON = AK1 * (Q - TH) !Kessler autoconversion rate -! -! IF (CON.LT.0.0) CON = 0.0 !havent reached threshold - - CON = max(0.,AK1 * (Q - TH)) ! versao otimizada -! -ENDIF -! -! -TOTAL = (CON + ACCRETE) * DT / RHO (L) - -! -IF (TOTAL.LT.QC (L) ) THEN -! - QC (L) = QC (L) - TOTAL - QH (L) = QH (L) + TOTAL !no phase change involved - RETURN -! -ELSE -! - QH (L) = QH (L) + QC (L) !uses all there is - QC (L) = 0.0 -! -ENDIF -! -RETURN -! -END SUBROUTINE CONVERT -! -!********************************************************************** -! -SUBROUTINE CONVERT2 () -!use module_zero_plumegen_coms -implicit none -LOGICAL AEROSOL -parameter(AEROSOL=.true.) -! -real, parameter :: TNULL=273.16, LAT=2.5008E6 & - ,EPSI=0.622 ,DB=1. ,NB=1500. !ALPHA=0.2 -real :: KA,KEINS,KZWEI,KDREI,VT -real :: A,B,C,D, CON,ACCRETE,total - -real Y(6),ROH - -A=0. -B=0. -Y(1) = T(L) -Y(4) = W(L) -y(2) = QC(L) -y(3) = QH(L) -Y(5) = RADIUS(L) -ROH = RHO(L)*1.e-3 ! dens (MKS) ?? - - -! autoconversion - -KA = 0.0005 -IF( Y(1) .LT. 258.15 )THEN -! KEINS=0.00075 - KEINS=0.0009 - KZWEI=0.0052 - KDREI=15.39 -ELSE - KEINS=0.0015 - KZWEI=0.00696 - KDREI=11.58 -ENDIF - -! ROH=PE/RD/TE -VT=-KDREI* (Y(3)/ROH)**0.125 - - -IF (Y(4).GT.0.0 ) THEN - IF (AEROSOL) THEN - A = 1/y(4) * y(2)*y(2)*1000./( 60. *( 5. + 0.0366*NB/(y(2)*1000.*DB) ) ) - ELSE - IF (y(2).GT.(KA*ROH)) THEN - !print*,'1',y(2),KA*ROH - A = KEINS/y(4) *(y(2) - KA*ROH ) - ENDIF - ENDIF -ELSE - A = 0.0 -ENDIF - -! accretion - -IF(y(4).GT.0.0) THEN - B = KZWEI/(y(4) - VT) * MAX(0.,y(2)) * & - MAX(0.001,ROH)**(-0.875)*(MAX(0.,y(3)))**(0.875) -ELSE - B = 0.0 -ENDIF - - - !PSATW=610.7*EXP( 17.25 *( Y(1) - TNULL )/( Y(1)-36. ) ) - !PSATE=610.7*EXP( 22.33 *( Y(1) - TNULL )/( Y(1)- 2. ) ) - - !QSATW=EPSI*PSATW/( PE-(1.-EPSI)*PSATW ) - !QSATE=EPSI*PSATE/( PE-(1.-EPSI)*PSATE ) - - !MU=2.*ALPHA/Y(5) - - !C = MU*( ROH*QSATW - ROH*QVE + y(2) ) - !D = ROH*LAT*QSATW*EPSI/Y1/Y1/RD *DYDX1 - - - !DYDX(2) = - A - B - C - D ! d rc/dz - !DYDX(3) = A + B ! d rh/dz - - - ! rc=rc+dydx(2)*dz - ! rh=rh+dydx(3)*dz - -CON = A -ACCRETE = B - -TOTAL = (CON + ACCRETE) *(1/DZM(L)) /ROH ! DT / RHO (L) - -!print*,'L=',L,total,QC(L),dzm(l) - -! -IF (TOTAL.LT.QC (L) ) THEN -! - QC (L) = QC (L) - TOTAL - QH (L) = QH (L) + TOTAL !no phase change involved - RETURN -! -ELSE -! - QH (L) = QH (L) + QC (L) !uses all there is - QC (L) = 0.0 -! -ENDIF -! -RETURN -! -END SUBROUTINE CONVERT2 -! ice - effect on temperature -! TTD = 0.0 -! TTE = 0.0 -! CALL ICE(QSATW,QSATE,Y(1),Y(2),Y(3), & -! TTA,TTB,TTC,DZ,ROH,D,C,TTD,TTE) -! DYDX(1) = DYDX(1) + TTD + TTE ! DT/DZ on Temp -! -!********************************************************************** -! -SUBROUTINE SUBLIMATE -! -! ********************* VAPOR TO ICE (USE EQUATION OT22)*************** -!use module_zero_plumegen_coms -! -real, PARAMETER :: EPS = 0.622, HEATFUS = 334., HEATSUBL = 2834., CP = 1.004 -real, PARAMETER :: SRC = HEATSUBL / CP, FRC = HEATFUS / CP, TMELT = 273.3 -real, PARAMETER :: TFREEZE = 269.3 - -real ::dtsubh, dividend,divisor, subl -! -DTSUBH = 0. -! -!selection criteria for sublimation -IF (T (L) .GT. TFREEZE ) RETURN -IF (QV (L) .LE. QSAT (L) ) RETURN -! -! from (OT); correction factors for units applied -! - DIVIDEND = ( (1.E6 / RHO (L) ) **0.475) * (QV (L) / QSAT (L) & - - 1) * (QI (L) **0.525) * 1.13 - DIVISOR = 7.E5 + 4.1E6 / (10. * EST (L) ) -! - - DTSUBH = ABS (DIVIDEND / DIVISOR) !sublimation rate - SUBL = DTSUBH * DT !and amount possible -! -! again check the possibilities -! -IF (SUBL.LT.QV (L) ) THEN -! - QV (L) = QV (L) - SUBL !lose vapor - QI (L) = QI (L) + SUBL !gain ice - T (L) = T (L) + SUBL * SRC !energy change, warms air - - !print*,'5',l,qi(l),SUBL - - RETURN -! -ELSE -! - QI (L) = QV (L) !use what there is - T (L) = T (L) + QV (L) * SRC !warm the air - QV (L) = 0.0 - !print*,'6',l,qi(l) -! -ENDIF -! -RETURN -END SUBROUTINE SUBLIMATE -! -! ********************************************************************* -! -SUBROUTINE GLACIATE -! -! *********************** CONVERSION OF RAIN TO ICE ******************* -! uses equation OT 16, simplest. correction from W not applied, but -! vapor pressure differences are supplied. -! -!use module_zero_plumegen_coms -! -real, PARAMETER :: HEATFUS = 334., CP = 1.004, EPS = 0.622, HEATSUBL = 2834. -real, PARAMETER :: FRC = HEATFUS / CP, FRS = HEATSUBL / CP, TFREEZE = 269.3 -real, PARAMETER :: GLCONST = 0.025 !glaciation time constant, 1/sec -real dfrzh -! - - DFRZH = 0. !rate of mass gain in ice -! -!selection rules for glaciation -IF (QH (L) .LE. 0. ) RETURN -IF (QV (L) .LT. QSAT (L) ) RETURN -IF (T (L) .GT. TFREEZE ) RETURN -! -! NT=TMELT-T(L) -! IF (NT.GT.50) NT=50 -! - - DFRZH = DT * GLCONST * QH (L) ! from OT(16) -! -IF (DFRZH.LT.QH (L) ) THEN -! - QI (L) = QI (L) + DFRZH - QH (L) = QH (L) - DFRZH - T (L) = T (L) + FRC * DFRZH !warms air - - !print*,'7',l,qi(l),DFRZH - - - RETURN -! -ELSE -! - QI (L) = QI (L) + QH (L) - T (L) = T (L) + FRC * QH (L) - QH (L) = 0.0 - - !print*,'8',l,qi(l), QH (L) -! -ENDIF -! -RETURN -! -END SUBROUTINE GLACIATE -! -! -! ********************************************************************* -SUBROUTINE MELT -! -! ******************* MAKES WATER OUT OF ICE ************************** -!use module_zero_plumegen_coms -! -real, PARAMETER :: FRC = 332.27, TMELT = 273., F0 = 0.75 !ice velocity factor -real DTMELT -! - DTMELT = 0. !conversion,ice to rain -! -!selection rules -IF (QI (L) .LE. 0.0 ) RETURN -IF (T (L) .LT. TMELT) RETURN -! - !OT(23,24) - DTMELT = DT * (2.27 / RHO (L) ) * CVI(L) * (T (L) - TMELT) * ( (RHO(L) & - * QI (L) * 1.E-6) **0.525) * (F0** ( - 0.42) ) - !after Mason,1956 -! -! check the possibilities -! -IF (DTMELT.LT.QI (L) ) THEN -! - QH (L) = QH (L) + DTMELT - QI (L) = QI (L) - DTMELT - T (L) = T (L) - FRC * DTMELT !cools air - !print*,'9',l,qi(l),DTMELT - - - RETURN -! -ELSE -! - QH (L) = QH (L) + QI (L) !get all there is to get - T (L) = T (L) - FRC * QI (L) - QI (L) = 0.0 - !print*,'10',l,qi(l) -! -ENDIF -! -RETURN -! -END SUBROUTINE MELT - -SUBROUTINE htint (nzz1, vctra, eleva, nzz2, vctrb, elevb) - IMPLICIT NONE - INTEGER, INTENT(IN ) :: nzz1 - INTEGER, INTENT(IN ) :: nzz2 - REAL, INTENT(IN ) :: vctra(nzz1) - REAL, INTENT(OUT) :: vctrb(nzz2) - REAL, INTENT(IN ) :: eleva(nzz1) - REAL, INTENT(IN ) :: elevb(nzz2) - - INTEGER :: l - INTEGER :: k - INTEGER :: kk - REAL :: wt - - l=1 - - DO k=1,nzz2 - DO - IF ( (elevb(k) < eleva(1)) .OR. & - ((elevb(k) >= eleva(l)) .AND. (elevb(k) <= eleva(l+1))) ) THEN - wt = (elevb(k)-eleva(l))/(eleva(l+1)-eleva(l)) - vctrb(k) = vctra(l)+(vctra(l+1)-vctra(l))*wt - EXIT - ELSE IF ( elevb(k) > eleva(nzz1)) THEN - wt = (elevb(k)-eleva(nzz1))/(eleva(nzz1-1)-eleva(nzz1)) - vctrb(k) = vctra(nzz1)+(vctra(nzz1-1)-vctra(nzz1))*wt - EXIT - END IF - - l=l+1 - IF(l == nzz1) THEN - PRINT *,'htint:nzz1',nzz1 - DO kk=1,l - PRINT*,'kk,eleva(kk),elevb(kk)',eleva(kk),elevb(kk) - END DO - STOP 'htint' - END IF - END DO - END DO -END SUBROUTINE htint -!----------------------------------------------------------------------------- -FUNCTION ESAT_PR (TEM) -! -! ******* Vapor Pressure A.L. Buck JAM V.20 p.1527. (1981) *********** -! -real, PARAMETER :: CI1 = 6.1115, CI2 = 22.542, CI3 = 273.48 -real, PARAMETER :: CW1 = 6.1121, CW2 = 18.729, CW3 = 257.87, CW4 = 227.3 -real, PARAMETER :: TMELT = 273.3 - -real ESAT_PR -real temc , tem,esatm -! -! formulae from Buck, A.L., JAM 20,1527-1532 -! custom takes esat wrt water always. formula for h2o only -! good to -40C so: -! -! -TEMC = TEM - TMELT -IF (TEMC.GT. - 40.0) GOTO 230 -ESATM = CI1 * EXP (CI2 * TEMC / (TEMC + CI3) ) !ice, millibars -ESAT_PR = ESATM / 10. !kPa - -RETURN -! -230 ESATM = CW1 * EXP ( ( (CW2 - (TEMC / CW4) ) * TEMC) / (TEMC + CW3)) - -ESAT_PR = ESATM / 10. !kPa -RETURN -END function ESAT_PR -! ****************************************************************** - -! ------------------------------------------------------------------------ -END Module module_chem_plumerise_scalar diff --git a/src/fim/FIMsrc/fim/column_chem/module_chem_prep_fim.F90 b/src/fim/FIMsrc/fim/column_chem/module_chem_prep_fim.F90 deleted file mode 100644 index 8d57646..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_chem_prep_fim.F90 +++ /dev/null @@ -1,778 +0,0 @@ -MODULE MODULE_CHEM_PREP_FIM -USE module_data_gocart_chem,only:airmw,mw_so4_aer -USE module_gocart_chem,only:szangle -!USE module_chem_namelist_defaults - USE module_initial_chem_namelists ! ,only:p_bc1,p_oc1,p_sulf,p_e_bc,p_e_oc,p_e_sulf -CONTAINS - subroutine chem_prep_fim(ktau,dtstep,rh3d,tr3d,tk3d,st3d,sm3d,dp3d,mp3d,ts2d,us2d, & - sw2d,pr3d,emiss_ash_mass,emiss_ash_height,emiss_ash_dt,dm0, & - emiss_tr_mass,emiss_tr_height,emiss_tr_dt, & - VFRAC2d,VTYPE2d,STYPE2d,us3d,vs3d,ws3d,slmsk2d,zorl2d,exch,pb2d,hf2d,& - oh_backgd,h2o2_backgd,no3_backgd,backg_oh,backg_h2o2,backg_no3,p_gocart,nvl_gocart, & - ttday,tcosz,gmt,julday,dtstepc, & - ph3d,area,ero1,ero2,ero3,rcav,raincv_b,deg_lat,deg_lon,nvl,nvlp1,ntra, & - relhum,rri,t_phy,moist,u_phy,v_phy,p_phy,chem,tsk,ntrb,g,rd,p1000,cp, & - erod,emis_ant,emis_vol,e_co,dms_0,& - u10,v10,ivgtyp,isltyp,gsw,vegfra,rmol,ust,znt,xland,dxy,t8w,p8w,exch_h,pbl,hfx, & - xlat,xlong,z_at_w,zmid,dz8w,vvel,rho_phy,smois,num_soil_layers,num_chem,num_moist,& - emiss_abu,ebu_in_oc,ebu_in_bc,ebu_in_pm25,ebu_in_pm10,ebu_in_so2,ebu_in_sulf, & - emiss_ab,num_emis_ant,num_emis_vol,kemit,call_gocart,ids,ide, jds,jde, kds,kde, & - plumestuff,mean_fct_agtf,mean_fct_agef,mean_fct_agsv,mean_fct_aggr, & - firesize_agtf,firesize_agef,firesize_agsv,firesize_aggr, & - chem_in_opt,ims,ime, jms,jme, kms,kme, & - its,ite,jts,jte,kts,kte) -! -! input fim variables -! -IMPLICIT NONE -INTEGER, INTENT(IN ) :: chem_in_opt,ktau,nvl,nvlp1,ntra,ntrb,nvl_gocart,call_gocart -REAL, INTENT(IN ) :: g,rd,p1000,cp,dtstep,dtstepc,gmt -real, intent(in) :: dp3d(nvl,jms:jme) ! del p between coord levels (pascals) -real, intent(in) :: mp3d(nvl,jms:jme) ! Montgomery Potential (m^2/s^2) -real, intent(inout) :: tk3d(nvl,jms:jme) ! temperature, kelvin -real, intent(in) :: rh3d(nvl,jms:jme) ! temperature, kelvin -real, intent(in) :: exch(nvl,jms:jme) ! -real, intent(in) :: oh_backgd(nvl_gocart,jms:jme) ! -real, intent(in) :: h2o2_backgd(nvl_gocart,jms:jme) ! -real, intent(in) :: no3_backgd(nvl_gocart,jms:jme) ! -real, intent(in) :: tr3d(nvl,jms:jme,ntra+ntrb) ! 1=pot.temp, 2=water vapor, 3=cloud water, 4=ozone -real, intent(in) :: st3d(4,jms:jme) ! soil temperature -real, intent(in) :: sm3d(4,jms:jme) ! soil moisture -real, intent(in) :: ts2d(jms:jme) ! skin temperature -real, intent(in) :: us2d(jms:jme) ! friction velocity/equivalent momentum flux -real, intent(in) :: pb2d(jms:jme) ! -real, intent(in) :: rcav(jms:jme) ! -real, intent(in) :: hf2d(jms:jme) ! -real, intent(in) :: sw2d(jms:jme) ! downward short-wave radiation flux -real, intent(in) :: pr3d(nvlp1,jms:jme) ! pressure (pascal) -!real, intent(in) :: ex3d(nvlp1,jms:jme) ! exner function -real, intent(in) :: ph3d(nvlp1,jms:jme) ! geopotential (=gz), m^2/s^2 -real, intent(in) :: emiss_ab(jms:jme,num_emis_ant) ! -real, intent(in) :: emiss_abu(jms:jme,num_emis_ant) ! -real, intent(in) :: plumestuff(jms:jme,8) ! -real, intent(in) :: ero1(jms:jme) ! -real, intent(in) :: ero2(jms:jme) ! -real, intent(in) :: ero3(jms:jme) ! -real, intent(inout) :: emiss_ash_mass(jms:jme) ! -real, intent(inout) :: emiss_ash_height(jms:jme) ! -real, intent(in) :: emiss_ash_dt(jms:jme) ! -real, intent(in) :: emiss_tr_mass(jms:jme) ! -real, intent(in) :: emiss_tr_height(jms:jme) ! -real, intent(in) :: emiss_tr_dt(jms:jme) ! -real, intent(in) :: dm0(jms:jme) ! -real, intent(in) :: p_gocart(56) ! -real, intent(in) :: area(jms:jme) ! the area of cell polygon (m**2) -real, dimension (jms:jme), intent(in) :: vfrac2d,VTYPE2d,STYPE2d,zorl2d,slmsk2d -real, dimension (nvl,jms:jme), intent(in) :: us3d,vs3d,ws3d -real, intent(in) :: deg_lat(jms:jme),deg_lon(jms:jme) ! lat and lon in degrees - - INTEGER, INTENT(IN ) :: num_soil_layers,num_chem,num_moist,julday, & - num_emis_vol,num_emis_ant,ids,ide, jds,jde, kds,kde, & - kemit,ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & - INTENT(OUT ) :: moist - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & - INTENT(OUT ) :: chem - REAL, DIMENSION( ims:ime, kms:kemit, jms:jme, num_emis_ant ), & - INTENT(inout ) :: emis_ant - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_emis_vol ), & - INTENT(inout ) :: emis_vol - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & - INTENT(OUT ) :: & - rri, & - t_phy, & - p_phy, & - relhum, dz8w,p8w,t8w, & - z_at_w , zmid ,exch_h, & - u_phy,v_phy,vvel,rho_phy - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & - INTENT(OUT ) :: & - backg_oh,backg_h2o2,backg_no3 - REAL, DIMENSION( ims:ime , jms:jme ) , & - INTENT(OUT ) :: & - ttday,tcosz - REAL,DIMENSION( ims:ime , jms:jme ) , & - INTENT(OUT ) :: & - ebu_in_oc,ebu_in_bc,ebu_in_pm25,ebu_in_pm10,ebu_in_so2,ebu_in_sulf - REAL,DIMENSION( ims:ime , jms:jme ) , & - INTENT(OUT ) :: & - mean_fct_agtf,mean_fct_agef,mean_fct_agsv,mean_fct_aggr, & - firesize_agtf,firesize_agef,firesize_agsv,firesize_aggr - INTEGER,DIMENSION( ims:ime , jms:jme ) , & - INTENT(OUT ) :: & - ivgtyp, & - isltyp - REAL, DIMENSION( ims:ime, jms:jme,3)::& - erod - - REAL, DIMENSION( ims:ime , jms:jme ) , & - INTENT(OUT ) :: & - u10, & - v10, & - gsw, & - vegfra, & - rmol, & - ust, & - xland, & - xlat,e_co,dms_0, & - xlong,tsk,raincv_b, & - dxy,znt,pbl,hfx - REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ) , & - INTENT(OUT) :: smois - integer i,j,k,kk,nv,jmax,jmaxi,l,ll,n,ndystep,ixhour - real maxv,factor,factor2,pu,pl,aln,pwant,rlat - real thv,xhour,xmin,gmtp,xlonn,xtime,real_time - real, DIMENSION (1,1) :: sza,cosszax - real, DIMENSION (jms:jme) :: so2_mass -! volcanic stuff - integer :: ko,k_final,k_initial,kl,kk4,curr_hours,curr_secs - real :: percen_mass_umbrel,x1,base_umbrel,ashz_above_vent,base_umbrel2 - real, DIMENSION (kms:kme) :: vert_mass_dist - real :: eh,h1,h2,h3,h4,h5,h6 -! .. Intrinsic Functions .. - INTRINSIC max, min, float -! - so2_mass(:)=0. -! h1=1-0 -! h2=7-0 -! h3=19-0 -! h4=69-0 -! h5=84-0 - h1=9-0 - h2=16-0 - h3=58-0 - h4=79-0 - h5=109-0 - h6=129-0 -! -! use these values for real-time default (if volcano starts at h1 =0 ) -! if h1 ne.0, then care has to be taken that ash_height is correct (below is hardwird for special case) -! ash_height can come in through FIMnamelist (read in in chem_init.F90) -! - h1=240 - h2=240 - h3=240 - h4=240 - h5=240 - h6=240 - percen_mass_umbrel=.75 - base_umbrel=.25 ! fraction - base_umbrel2=1. ! evenly distribution - real_time=float(ktau)*dtstep/60. - - - if(ktau.le.1)then - emis_ant(:,:,:,:)=0. - emis_vol(:,:,:,:)=0. - endif - e_co(:,:)=0. - do i=its,ite - do j=jts,jte - z_at_w(i,kts,j)=max(0.,ph3d(kts,j)/g) - enddo - enddo - do i=its,ite - do k=kts,kte - do j=jts,jte - dz8w(i,k,j)=(ph3d(k+1,j)-ph3d(k,j))/g - if(dz8w(i,k,j).lt.0.)dz8w(i,k,j)=-dz8w(i,k,j) - z_at_w(i,k+1,j)=z_at_w(i,k,j)+dz8w(i,k,j) - enddo - enddo - enddo - do i=its,ite - do k=kts,kte+1 - do j=jts,jte -! z_at_w(i,k,j)=ph3d(k,j)/g - p8w(i,k,j)=pr3d(k,j) - enddo - enddo - enddo - do i=its,ite - do j=jts,jte - raincv_b(i,j)=rcav(j) - pbl(i,j)=pb2d(j) - dms_0(i,j)=dm0(j) - hfx(i,j)=hf2d(j) - erod(i,j,1)=ero1(j) - erod(i,j,2)=ero2(j) - erod(i,j,3)=ero3(j) - xlat(i,j)=deg_lat(j) - xlong(i,j)=deg_lon(j) - ust(i,j)=us2d(j) - tsk(i,j)=ts2d(j) - ivgtyp(i,j)=VTYPE2d(j) - isltyp(i,j)=STYPE2d(j) - gsw(i,j)=sw2d(j) - vegfra(i,j)=VFRAC2d(j) -! if(j.eq.681)write(6,*)ivgtyp(i,j),isltyp(i,j),vegfra(i,j),slmsk2d(j) -! if(ivgtyp(i,j).ne.0)write(6,*)i,j,ivgtyp(i,j),isltyp(i,j),vegfra(i,j),pb2d(j),VTYPE2d(j) - rmol(i,j)=0. - znt(i,j)=zorl2d(j)*.01 -!SLMSK - SEA(0),LAND(1),ICE(2) MASK - xland(i,j)=1. - if(slmsk2d(j).eq.0)xland(i,j)=0. - if(slmsk2d(j).eq.1)xland(i,j)=1. - if(slmsk2d(j).eq.2)xland(i,j)=2. -! if (slmsk2d(j).gt.0.)write(6,*)j,slmsk2d(j) - dxy(i,j)=area(j) - u10(i,j)=us3d(1,j) - v10(i,j)=vs3d(1,j) - enddo - enddo - factor=0. - jmax=0 - jmaxi=0 - k=1 - if(p_bc2 .gt. 1)then ! "regular" chem options - do i=its,ite - do j=jts,jte - k=1 - emis_ant(i,k,j,p_e_bc)=emiss_ab(j,p_e_bc) - emis_ant(i,k,j,p_e_oc)=emiss_ab(j,p_e_oc) - emis_ant(i,k,j,p_e_sulf)=emiss_ab(j,p_e_sulf) - emis_ant(i,k,j,p_e_so2)=emiss_ab(j,p_e_so2) -! - ebu_in_oc(i,j)=emiss_abu(j,p_e_oc) - ebu_in_bc(i,j)=emiss_abu(j,p_e_bc) - ebu_in_pm25(i,j)=emiss_abu(j,p_e_pm_25) - ebu_in_pm10(i,j)=emiss_abu(j,p_e_pm_10) - ebu_in_so2(i,j)=emiss_abu(j,p_e_so2) - ebu_in_sulf(i,j)=0. ! for now - mean_fct_agtf(i,j)=plumestuff(j,1) - mean_fct_agef(i,j)=plumestuff(j,2) - mean_fct_agsv(i,j)=plumestuff(j,3) - mean_fct_aggr(i,j)=plumestuff(j,4) - firesize_agtf(i,j)=plumestuff(j,5) - firesize_agef(i,j)=plumestuff(j,6) - firesize_agsv(i,j)=plumestuff(j,7) - firesize_aggr(i,j)=plumestuff(j,8) - enddo - enddo - else if (p_tr2 .gt. 1) then ! tracer options -! tracer run - do i=its,ite - do j=jts,jte - k=kts - emis_ant(i,k,j,p_e_tr1)=emiss_ab(j,p_e_tr1) - emis_ant(i,k,j,p_e_tr2)=emiss_ab(j,p_e_tr2) - enddo - enddo - else if ((p_tr2 .gt. 1) .and. (p_bc2 .gt. 1))then - stop 'in chem_prep_fim, 111' - endif - do i=its,ite - do k=kts,kte - do j=jts,jte - thv=tr3d(k,j,1)/(1.+0.6078*tr3d(k,j,2)) - tk3d(k,j)=thv*(.5*(p8w(i,k,j)+p8w(i,k+1,j))/p1000)**(rd/cp) - enddo - enddo - enddo - do i=its,ite - do k=kts,kte+1 - kk=min(k,kte) - do j=jts,jte - zmid(i,k,j)=.5*(ph3d(kk+1,j)+ph3d(kk,j))/g - dz8w(i,k,j)=z_at_w(i,kk+1,j)-z_at_w(i,kk,j) - t_phy(i,k,j)=tk3d(kk,j) -! relhum(i,k,j)=rh3d(kk,j) - p_phy(i,k,j)=.5*(p8w(i,kk,j)+p8w(i,kk+1,j)) - u_phy(i,k,j)=us3d(kk,j) - exch_h(i,k,j)=exch(kk,j) - v_phy(i,k,j)=vs3d(kk,j) - rho_phy(i,k,j)= p_phy(i,k,j)/(RD*T_phy(i,k,j)*(1.+.608*tr3d(kk,j,2))) - rri(i,k,j)=1./rho_phy(i,k,j) - vvel(i,k,j)=-ws3d(kk,j)*rri(i,k,j)/g - moist(i,k,j,:)=0. - moist(i,k,j,1)=tr3d(kk,j,2) - if(t_phy(i,k,j).gt.265.)then - moist(i,k,j,2)=tr3d(kk,j,3) - moist(i,k,j,3)=0. - if(moist(i,k,j,2).lt.1.e-8)moist(i,k,j,2)=0. - else - moist(i,k,j,2)=0. - moist(i,k,j,3)=tr3d(kk,j,3) - if(moist(i,k,j,3).lt.1.e-8)moist(i,k,j,3)=0. - endif - relhum(i,k,j) = .95 - relhum(i,k,j) = MIN( .95, moist(i,k,j,1) / & - (3.80*exp(17.27*(t_phy(i,k,j)-273.)/ & - (t_phy(i,k,j)-36.))/(.01*p_phy(i,k,j)))) - relhum(i,k,j)=max(0.1,relhum(i,k,j)) - - enddo - enddo - enddo - do nv=1,num_chem - do i=its,ite - do k=kts,kte+1 - kk=min(k,kte) - do j=jts,jte - chem(i,k,j,nv)=tr3d(kk,j,ntra+nv) - enddo - enddo - enddo - enddo -! -! gocart background fields only if gocart is called -! - if(call_gocart.eq.1)then - do i=its,ite - do j=jts,jte - do k=kts,kte - do ll=2,nvl_gocart - l=ll - if(p_gocart(l).lt..01*p_phy(i,k,j))exit - enddo - pu=alog(p_gocart(l)) - pl=alog(p_gocart(l-1)) - pwant=alog(.01*p_phy(i,k,j)) - if(pwant.gt.pl)then - backg_oh(i,k,j)=oh_backgd(l,j) - backg_h2o2(i,k,j)=h2o2_backgd(l,j) - backg_no3(i,k,j)=no3_backgd(l,j) - else - aln=(oh_backgd(l,j)*(pwant-pl)+ & - oh_backgd(l-1,j)*(pu-pwant))/(pu-pl) - backg_oh(i,k,j)=aln - aln=(h2o2_backgd(l,j)*(pwant-pl)+ & - h2o2_backgd(l-1,j)*(pu-pwant))/(pu-pl) - backg_h2o2(i,k,j)=aln - aln=(no3_backgd(l,j)*(pwant-pl)+ & - no3_backgd(l-1,j)*(pu-pwant))/(pu-pl) - backg_no3(i,k,j)=aln - endif - enddo - enddo - enddo - endif ! end gocart stuff - nv=1 - k=1 -! emis_ant=0. -!TBH write(6,*)"airmw,mw_so4_aer,p_e_bc,p_e_oc=",airmw,mw_so4_aer,p_e_bc,p_e_oc -!TBH write(6,*)"dtstep,rri(1,k,jmax),dz8w(1,k,jmax)=",dtstep,rri(1,k,jmax),dz8w(1,k,jmax) - factor2=0. - factor=0. - if(p_bc2 .gt. 1)then -!!SMS$SERIAL BEGIN -! write(0,*)'adding emissions for gocart',dtstep -! write(0,*)'max ebc = ',maxval(emis_ant(:,:,:,p_e_bc)) -! write(0,*)'max eso2 = ',maxval(emis_ant(:,:,:,p_e_so2)) -! write(0,*)'max rri1 = ',maxval(rri(:,1,:)) -! write(0,*)'max dz1 = ',maxval(dz8w(:,1,:)) -!!SMS$SERIAL END - do i=its,ite -!TBH write(6,*)"i = ",i,k - do j=jts,jte - factor=dtstep*rri(i,k,j)/dz8w(i,k,j) - factor2=4.828e-4*dtstep*rri(i,k,j)/(60.*dz8w(i,k,j)) - chem(i,k,j,p_bc1)=chem(i,k,j,p_bc1)+emis_ant(i,k,j,p_e_bc)*factor - chem(i,k,j,p_oc1)=chem(i,k,j,p_oc1)+emis_ant(i,k,j,p_e_oc)*factor - chem(i,k,j,p_sulf)=chem(i,k,j,p_sulf)+emis_ant(i,k,j,p_e_sulf)*factor2 - chem(i,k,j,p_so2)=chem(i,k,j,p_so2)+emis_ant(i,k,j,p_e_so2)*factor2 - enddo - enddo - else if (p_tr2 .gt. 1)then !co2 here - do i=its,ite - do j=jts,jte -! factor2=dtstep*rri(i,k,j)/dz8w(i,k,j) - factor2=4.828e-4*dtstep*rri(i,k,j)/(60.*dz8w(i,k,j)) - chem(i,k,j,p_tr1)=chem(i,k,j,p_tr1)+emis_ant(i,k,j,p_e_tr1)*factor2 - chem(i,k,j,p_tr2)=chem(i,k,j,p_tr2)+emis_ant(i,k,j,p_e_tr2)*factor2 - enddo - enddo - else if ((p_tr2 .gt. 1) .and. (p_bc2 .gt. 1))then - stop 'in chem_prep_fim, 112' - endif - do i=its,ite - do j=jts,jte - do nv=1,num_soil_layers - smois(i,nv,j)=sm3d(nv,j) - enddo - enddo - enddo - curr_secs=ktau*ifix(dtstep) - curr_hours=curr_secs/3600 -! -! do volcanoes if avaiable -! -! if(chem_opt == 502 ) then -! do j=jts,jte -! if(emiss_ash_dt(j).le.0)CYCLE -! emiss_ash_mass(j)=0. -! emiss_ash_height(j)=0. -! enddo -! -! default -! - do j=jts,jte - if(emiss_ash_dt(j).le.0)CYCLE - so2_mass(j)=1.5e4*3600.*1.e9/64./area(j) - eh=2600.*(emiss_ash_height(j)*.0005)**4.1494 - emiss_ash_mass(j)=eh*1.e9/area(j) -! write(0,*)'h0 default ash mass = ',j,emiss_ash_dt(j),emiss_ash_height(j),emiss_ash_mass(j) - enddo -! hard code for special retro case (set h1 - h6 properly -! - if(curr_hours.ge.h1 .and. curr_hours.lt.h2)then - do j=jts,jte -! if(j.eq.jts)write(0,*)'curr_secs,curr_hours = ',curr_secs,curr_hours - if(emiss_ash_dt(j).le.0)CYCLE - emiss_ash_height(j)=5834. -! eh=2600.*(emiss_ash_height(j)*.0005)**4.1494 - eh=3.11e5 - emiss_ash_mass(j)=eh*1.e9/area(j) -! write(6,*)'h1 adjusted ash mass = ',emiss_ash_mass(j) - enddo - else if(curr_hours.ge.h2 .and. curr_hours.lt.h3)then - do j=jts,jte - if(emiss_ash_dt(j).le.0)CYCLE - emiss_ash_height(j)=3834. -! eh=2600.*(emiss_ash_height(j)*.0005)**4.1494 - eh=3.87e4 - emiss_ash_mass(j)=eh*1.e9/area(j) -! write(6,*)'h2 adjusted ash mass = ',emiss_ash_mass(j) - enddo - else if(curr_hours.ge.h3 .and. curr_hours.lt.h4)then - do j=jts,jte - if(emiss_ash_dt(j).le.0)CYCLE - emiss_ash_height(j)=5834. -! eh=2600.*(emiss_ash_height(j)*.0005)**4.1494 - eh=3.11e5 - emiss_ash_mass(j)=eh*1.e9/area(j) -! write(6,*)'h3 adjusted ash mass = ',emiss_ash_mass(j) - enddo - else if(curr_hours.ge.h4 .and. curr_hours.lt.h5)then - do j=jts,jte - if(emiss_ash_dt(j).le.0)CYCLE - emiss_ash_height(j)=3334. -! eh=2600.*(emiss_ash_height(j)*.0005)**4.1494 - eh=2.17e4 - emiss_ash_mass(j)=eh*1.e9/area(j) -! write(6,*)'h4 adjusted ash mass = ',emiss_ash_mass(j) - enddo - else if(curr_hours.ge.h5 .and. curr_hours.lt.h6)then - do j=jts,jte - if(emiss_ash_dt(j).le.0)CYCLE - emiss_ash_height(j)=3334. -! eh=2600.*(emiss_ash_height(j)*.0005)**4.1494 - eh=2.17e4 - emiss_ash_mass(j)=eh*1.e9/area(j) -! write(6,*)'h5 adjusted ash mass = ',emiss_ash_mass(j) - enddo - else if(curr_hours.ge.h6)then - do j=jts,jte - if(emiss_ash_dt(j).le.0)CYCLE - emiss_ash_height(j)=2334. - eh=4.93e3 - emiss_ash_mass(j)=eh*1.e9/area(j) - enddo - - endif ! every o often -! endif ! chem_opt = 502 -! real-time application, keeping eruption constant -! - if(ktau.le.2)then - emis_vol(:,:,:,:)=0. -! if(curr_hours.eq.h1 .or. curr_hours.eq.h2 .or. curr_hours.eq.h3 & -! .or. curr_hours.eq.h4 .or. curr_hours.eq.h5 .or. curr_hours.eq.h6 .or. h1.gt.239)then -! .or. curr_hours.eq.0)then -! if(chem_opt == 316 .or. chem_opt == 317 .or. chem_opt == 502) then -! volcanic emissions -! - do j=jts,jte - do i=its,ite - if(emiss_ash_dt(j).le.0)CYCLE - if(emiss_ash_height(j).le.0.)CYCLE - ashz_above_vent=emiss_ash_height(j) +z_at_w(i,kts,j) -! write(0,*)'found and adjusted active volcano at j,kts,kpe = ',j,kts,kte -! write(0,*)emiss_ash_height(j),emiss_ash_mass(j),emiss_ash_dt(j),ashz_above_vent - do k=kte-1,kts,-1 - if(z_at_w(i,k,j) < ashz_above_vent)then - k_final=k+1 - exit - endif !inner - enddo - do k=kte-1,kts,-1 - if(z_at_w(i,k,j) < (1.-base_umbrel)*ashz_above_vent)then - k_initial=k - exit - endif !inner - enddo - vert_mass_dist=0. -! k_initial=int((k_final+k_initial)*0.5) - - !- parabolic vertical distribution between k_initial and k_final - kk4 = k_final-k_initial+2 - do ko=1,kk4-1 - kl=ko+k_initial-1 - vert_mass_dist(kl) = 6.*percen_mass_umbrel* float(ko)/float(kk4)**2 * (1. - float(ko)/float(kk4)) - enddo - if(sum(vert_mass_dist(kts:kte)) .ne. percen_mass_umbrel) then - x1= ( percen_mass_umbrel- sum(vert_mass_dist(kts:kte)) )/float(k_final-k_initial+1) - do ko=k_initial,k_final - vert_mass_dist(ko) = vert_mass_dist(ko)+ x1 !- values between 0 and 1. - enddo - !pause - endif !inner - !k_final > 0 .and. k_initial > - - !linear detrainment from vent to base of umbrella - do ko=1,k_initial-1 - vert_mass_dist(ko)=float(ko)/float(k_initial-1) - enddo - x1=sum(vert_mass_dist(1:k_initial-1)) - - do ko=1,k_initial-1 - vert_mass_dist(ko)=(1.-percen_mass_umbrel)*vert_mass_dist(ko)/x1 - enddo - if(chem_opt == 316 ) then - do ko=1,k_final - emis_vol(i,ko,j,p_e_vash1)=.02*vert_mass_dist(ko)*emiss_ash_mass(j) - emis_vol(i,ko,j,p_e_vash2)=.04*vert_mass_dist(ko)*emiss_ash_mass(j) - emis_vol(i,ko,j,p_e_vash3)=.11*vert_mass_dist(ko)*emiss_ash_mass(j) - emis_vol(i,ko,j,p_e_vash4)=.09*vert_mass_dist(ko)*emiss_ash_mass(j) - emis_vol(i,ko,j,p_e_vash5)=.09*vert_mass_dist(ko)*emiss_ash_mass(j) - emis_vol(i,ko,j,p_e_vash6)=.13*vert_mass_dist(ko)*emiss_ash_mass(j) - emis_vol(i,ko,j,p_e_vash7)=.16*vert_mass_dist(ko)*emiss_ash_mass(j) - emis_vol(i,ko,j,p_e_vash8)=.16*vert_mass_dist(ko)*emiss_ash_mass(j) - emis_vol(i,ko,j,p_e_vash9)=.1*vert_mass_dist(ko)*emiss_ash_mass(j) - emis_vol(i,ko,j,p_e_vash10)=.1*vert_mass_dist(ko)*emiss_ash_mass(j) - enddo - do ko=k_final+1,kte - emis_vol(i,ko,j,p_e_vash1)=0. - emis_vol(i,ko,j,p_e_vash2)=0. - emis_vol(i,ko,j,p_e_vash3)=0. - emis_vol(i,ko,j,p_e_vash4)=0. - emis_vol(i,ko,j,p_e_vash5)=0. - emis_vol(i,ko,j,p_e_vash6)=0. - emis_vol(i,ko,j,p_e_vash7)=0. - emis_vol(i,ko,j,p_e_vash8)=0. - emis_vol(i,ko,j,p_e_vash9)=0. - emis_vol(i,ko,j,p_e_vash10)=0. - enddo - elseif (chem_opt == 317 .or. chem_opt == 502) then -! -! reduced vocanic ash transport -! - do ko=1,k_final - emis_vol(i,ko,j,p_e_vash1)=.11*vert_mass_dist(ko)*emiss_ash_mass(j) - emis_vol(i,ko,j,p_e_vash2)=.08*vert_mass_dist(ko)*emiss_ash_mass(j) - emis_vol(i,ko,j,p_e_vash3)=.05*vert_mass_dist(ko)*emiss_ash_mass(j) - emis_vol(i,ko,j,p_e_vash4)=.035*vert_mass_dist(ko)*emiss_ash_mass(j) - enddo - elseif (chem_opt == 300) then -! -! if applied to gocart we only need finest ash bins, we use the coarse one for so2 -! - do ko=1,k_final - emis_vol(i,ko,j,p_e_vash1)=vert_mass_dist(ko)*so2_mass(j) - emis_vol(i,ko,j,p_e_vash2)=.08*vert_mass_dist(ko)*emiss_ash_mass(j) - emis_vol(i,ko,j,p_e_vash3)=.05*vert_mass_dist(ko)*emiss_ash_mass(j) - emis_vol(i,ko,j,p_e_vash4)=.035*vert_mass_dist(ko)*emiss_ash_mass(j) - enddo - endif !chem_opt==316 or 317,300,502 - - do ko=k_final+1,kte - emis_vol(i,ko,j,p_e_vash1)=0. - emis_vol(i,ko,j,p_e_vash2)=0. - emis_vol(i,ko,j,p_e_vash3)=0. - emis_vol(i,ko,j,p_e_vash4)=0. - enddo - enddo - enddo -! endif ! chem_opt == 316 .or. chem_opt == 317 .or. chem_opt == 502 - endif ! curr_mins -! initialy -! - if(ktau.le.1)then - - if(chem_in_opt == 0 ) then - if(chem_opt >= 300 .and. chem_opt < 500 ) then - do j=jts,jte - do k=kts,kte - do i=its,ite - do n=1,num_chem - chem(i,k,j,n)=1.e-12 - enddo - chem(i,k,j,p_dms)=0.1e-6 - chem(i,k,j,p_so2)=5.e-6 - chem(i,k,j,p_sulf)=3.e-6 - chem(i,k,j,p_msa)=0.1e-6 - chem(i,k,j,p_bc1)=0.1e-3 - chem(i,k,j,p_bc2)=0.1e-3 - chem(i,k,j,p_oc1)=0.1e-3 - chem(i,k,j,p_oc2)=0.1e-3 - chem(i,k,j,p_p25)=1. - chem(i,k,j,p_p10)=1. - enddo - enddo - enddo - endif ! chem_opt >= 300 .and. chem_opt < 500 - endif ! chem_in_opt == 0 - -! -! next is done to scale background oh and no3 in dependence on average zenith angle and day/night for no3 -! this is done since background values are only available as average/month. It will not be necessary if other -! chemistry packages are used that provide oh,no3,h2o2 -! - if(chem_opt >= 300 .and. chem_opt < 500 ) then - ndystep=86400/ifix(dtstepc) - do i=its,ite - do j=jts,jte - tcosz(i,j)=0. - ttday(i,j)=0. - rlat=xlat(i,j)*3.1415926535590/180. - xlonn=xlong(i,j) -! if(j.eq.681)then -! write(6,*)'szangle1',xlat(i,j),xlong(i,j) -! write(6,*)julday, sza, xlonn,rlat -! write(6,*)'ndystep,dtstepc,gmt = ',ndystep,dtstepc,gmt -! endif - do n=1,ndystep - xtime=n*dtstepc/60. - ixhour=ifix(gmt+.01)+ifix(xtime/60.) - xhour=float(ixhour) - xmin=60.*gmt+(xtime-xhour*60.) - gmtp=mod(xhour,24.) - gmtp=gmtp+xmin/60. - CALL szangle(1, 1, julday, gmtp, sza, cosszax,xlonn,rlat) - TCOSZ(i,j)=TCOSZ(I,J)+cosszax(1,1) - if(cosszax(1,1).gt.0.)ttday(i,j)=ttday(i,j)+dtstepc - enddo -!if (TCOSZ(i,j) == 0.0) then -!endif -! if(j.eq.681)then -! write(6,*)'szangle' -! write(6,*)TCOSZ(i,j),ttday(i,j),julday, gmtp, sza, cosszax,xlonn,rlat -! endif - enddo - enddo - endif !chem_opt >= 300 .and. chem_opt < 500 - endif ! end ktau <=1 - if(CHEM_OPT == 316 ) then - do i=its,ite - do j=jts,jte - if(emiss_ash_dt(j).le.0.)CYCLE - do k=kts,kte-2 - factor2=dtstep*rri(i,k,j)/dz8w(i,k,j) - chem(i,k,j,p_vash_1)=chem(i,k,j,p_vash_1)+emis_vol(i,k,j,p_e_vash1)*factor2 - chem(i,k,j,p_vash_2)=chem(i,k,j,p_vash_2)+emis_vol(i,k,j,p_e_vash2)*factor2 - chem(i,k,j,p_vash_3)=chem(i,k,j,p_vash_3)+emis_vol(i,k,j,p_e_vash3)*factor2 - chem(i,k,j,p_vash_4)=chem(i,k,j,p_vash_4)+emis_vol(i,k,j,p_e_vash4)*factor2 - chem(i,k,j,p_vash_5)=chem(i,k,j,p_vash_5)+emis_vol(i,k,j,p_e_vash5)*factor2 - chem(i,k,j,p_vash_6)=chem(i,k,j,p_vash_6)+emis_vol(i,k,j,p_e_vash6)*factor2 - chem(i,k,j,p_vash_7)=chem(i,k,j,p_vash_7)+emis_vol(i,k,j,p_e_vash7)*factor2 - chem(i,k,j,p_vash_8)=chem(i,k,j,p_vash_8)+emis_vol(i,k,j,p_e_vash8)*factor2 - chem(i,k,j,p_vash_9)=chem(i,k,j,p_vash_9)+emis_vol(i,k,j,p_e_vash9)*factor2 - chem(i,k,j,p_vash_10)=chem(i,k,j,p_vash_10)+emis_vol(i,k,j,p_e_vash10)*factor2 - enddo - enddo - enddo - endif - if(CHEM_OPT == 317 .or. CHEM_OPT == 502) then - do i=its,ite - do j=jts,jte - if(emiss_ash_dt(j).le.0.)CYCLE -! print *,'adding volcanic ash emissions, dt = ',dtstep,rri(i,k_final,j),dz8w(i,k_final,j) - do k=kts,kte-2 - factor2=dtstep*rri(i,k,j)/dz8w(i,k,j) - chem(i,k,j,p_vash_1)=chem(i,k,j,p_vash_1)+emis_vol(i,k,j,p_e_vash1)*factor2 - chem(i,k,j,p_vash_2)=chem(i,k,j,p_vash_2)+emis_vol(i,k,j,p_e_vash2)*factor2 - chem(i,k,j,p_vash_3)=chem(i,k,j,p_vash_3)+emis_vol(i,k,j,p_e_vash3)*factor2 - chem(i,k,j,p_vash_4)=chem(i,k,j,p_vash_4)+emis_vol(i,k,j,p_e_vash4)*factor2 - enddo - enddo - enddo - endif - if(CHEM_OPT == 300 ) then -! -! for gocart only lump ash into p25 and p10 -! - do i=its,ite - do j=jts,jte - if(emiss_ash_dt(j).le.0.)CYCLE - do k=kts,kte-2 - factor=4.828e-4*dtstep*rri(i,k,j)/(60.*dz8w(i,k,j)) - factor2=dtstep*rri(i,k,j)/dz8w(i,k,j) - chem(i,k,j,p_p25)=chem(i,k,j,p_p25) & - +emis_vol(i,k,j,p_e_vash4)*factor2 - chem(i,k,j,p_so2)=chem(i,k,j,p_so2) & - +emis_vol(i,k,j,p_e_vash1)*factor - chem(i,k,j,p_p10)=chem(i,k,j,p_p10) & -! +.5* emis_vol(i,k,j,p_e_vash4)*factor2 & - +1.* emis_vol(i,k,j,p_e_vash3)*factor2 & - +.5* emis_vol(i,k,j,p_e_vash2)*factor2 - enddo - enddo - enddo - endif -! -! option 501 was only used for cesium ensemble - Japan 2010 -! - if(chem_opt == 501 ) then -! explosive tr emissions -! - do j=jts,jte - do i=its,ite - if(emiss_tr_dt(j).le.0 .or. emiss_tr_height(j).le.0.)CYCLE - ashz_above_vent=emiss_tr_height(j)+z_at_w(i,kts,j) - do k=kte-1,kts,-1 - if(z_at_w(i,k,j) < ashz_above_vent)then - k_final=k+1 - exit - endif - enddo - do k=kte-1,kts,-1 - if(z_at_w(i,k,j) < (1.-base_umbrel)*ashz_above_vent)then - k_initial=k - exit - endif - enddo - vert_mass_dist=0. - k_initial=int((k_final+k_initial)*0.5) - - !- parabolic vertical distribution between k_initial and k_final - kk4 = k_final-k_initial+2 - do ko=1,kk4-1 - kl=ko+k_initial-1 - vert_mass_dist(kl) = 6.*percen_mass_umbrel* float(ko)/float(kk4)**2 * (1. - float(ko)/float(kk4)) - enddo - if(sum(vert_mass_dist(kts:kte)) .ne. percen_mass_umbrel) then - x1= ( percen_mass_umbrel- sum(vert_mass_dist(kts:kte)) )/float(k_final-k_initial+1) - do ko=k_initial,k_final - vert_mass_dist(ko) = vert_mass_dist(ko)+ x1 !- values between 0 and 1. - enddo - endif - - !linear detrainment from vent to base of umbrella - do ko=1,k_initial-1 - vert_mass_dist(ko)=float(ko)/float(k_initial-1) - enddo - x1=sum(vert_mass_dist(1:k_initial-1)) - - do ko=1,k_initial-1 - vert_mass_dist(ko)=(1.-percen_mass_umbrel)*vert_mass_dist(ko)/x1 - enddo -! tr emissions for umbrella (explosive) type emissons -! - do ko=1,k_final - emis_ant(i,ko,j,p_e_tr1)=vert_mass_dist(ko)*emiss_tr_mass(j) - emis_ant(i,ko,j,p_e_tr2)=1./float(k_final)*emiss_tr_mass(j) - enddo - if(emiss_tr_dt(j).le.0.)CYCLE - do k=kts,kte-2 - factor2=dtstep*rri(i,k,j)/dz8w(i,k,j) - chem(i,k,j,p_tr2)=chem(i,k,j,p_tr2)+emis_ant(i,k,j,p_e_tr2)*factor2 - if(real_time.gt.360.)chem(i,k,j,p_tr1)=chem(i,k,j,p_tr1)+emis_ant(i,k,j,p_e_tr2)*factor2 - enddo - enddo - enddo - endif - - - -END subroutine chem_prep_fim -END MODULE MODULE_CHEM_PREP_FIM diff --git a/src/fim/FIMsrc/fim/column_chem/module_chemvars.F90 b/src/fim/FIMsrc/fim/column_chem/module_chemvars.F90 deleted file mode 100644 index 4fc8a9c..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_chemvars.F90 +++ /dev/null @@ -1,206 +0,0 @@ -MODULE MODULE_CHEMVARS - - IMPLICIT NONE - -! -! the next are variables that chemdriver will need -! - REAL, PARAMETER :: epsilc = 1.e-16 -! INTEGER, PARAMETER :: num_emis_ant = 9 - INTEGER, PARAMETER :: num_emis_dust = 5 - INTEGER, PARAMETER :: num_emis_seas = 4 - INTEGER, PARAMETER :: ne_area = 41 - INTEGER, PARAMETER :: nmegan = 1 -! INTEGER, PARAMETER :: kemit = 1 - INTEGER :: stepbioe,stepfirepl - REAL, ALLOCATABLE :: chem( :, :, :, : ) - REAL, ALLOCATABLE :: emis_ant( :, :, :,:) - REAL, ALLOCATABLE :: emis_vol( :, :, :,:) - REAL, ALLOCATABLE :: relhum( :, :, : ) - REAL, ALLOCATABLE :: h2oai( :, :, : ) - REAL, ALLOCATABLE :: h2oaj( :, :, : ) - REAL, ALLOCATABLE :: e_bio( :, :, : ) - REAL, ALLOCATABLE :: dms_0( :, :) - REAL, ALLOCATABLE :: ttday( :, :) - REAL, ALLOCATABLE :: tcosz( :, :) - REAL, ALLOCATABLE :: erod( :, :,:) - REAL, ALLOCATABLE :: emis_dust( :, :, :,:) - REAL, ALLOCATABLE :: emis_seas( :, :, :,:) - REAL, ALLOCATABLE :: backg_oh( :, :, : ) - REAL, ALLOCATABLE :: backg_h2o2( :, :, : ) - REAL, ALLOCATABLE :: backg_no3( :, :, : ) - REAL, ALLOCATABLE :: ebu_in_no( :, : ) - REAL, ALLOCATABLE :: ebu_in_co( :, : ) - REAL, ALLOCATABLE :: ebu_in_co2( :, : ) - REAL, ALLOCATABLE :: ebu_in_eth( :, : ) - REAL, ALLOCATABLE :: ebu_in_hc3( :, : ) - REAL, ALLOCATABLE :: ebu_in_hc5( :, : ) - REAL, ALLOCATABLE :: ebu_in_hc8( :, : ) - REAL, ALLOCATABLE :: ebu_in_ete( :, : ) - REAL, ALLOCATABLE :: ebu_in_olt( :, : ) - REAL, ALLOCATABLE :: ebu_in_oli( :, : ) - REAL, ALLOCATABLE :: ebu_in_pm25( :, : ) - REAL, ALLOCATABLE :: ebu_in_pm10( :, : ) - REAL, ALLOCATABLE :: ebu_in_oc( :, : ) - REAL, ALLOCATABLE :: ebu_in_bc( :, : ) - REAL, ALLOCATABLE :: ebu_in_so2( :, : ) - REAL, ALLOCATABLE :: ebu_in_sulf( :, : ) - REAL, ALLOCATABLE :: ebu_in_dien( :, : ) - REAL, ALLOCATABLE :: ebu_in_iso( :, : ) - REAL, ALLOCATABLE :: ebu_in_api( :, : ) - REAL, ALLOCATABLE :: ebu_in_lim( :, : ) - REAL, ALLOCATABLE :: ebu_in_tol( :, : ) - REAL, ALLOCATABLE :: ebu_in_xyl( :, : ) - REAL, ALLOCATABLE :: ebu_in_csl( :, : ) - REAL, ALLOCATABLE :: ebu_in_hcho( :, : ) - REAL, ALLOCATABLE :: ebu_in_ald( :, : ) - REAL, ALLOCATABLE :: ebu_in_ket( :, : ) - REAL, ALLOCATABLE :: ebu_in_macr( :, : ) - REAL, ALLOCATABLE :: ebu_in_ora1( :, : ) - REAL, ALLOCATABLE :: ebu_in_ora2( :, : ) - REAL, ALLOCATABLE :: ebu_no( :, :, : ) - REAL, ALLOCATABLE :: ebu_co( :, :, : ) - REAL, ALLOCATABLE :: ebu_co2( :, :, : ) - REAL, ALLOCATABLE :: ebu_eth( :, :, : ) - REAL, ALLOCATABLE :: ebu_hc3( :, :, : ) - REAL, ALLOCATABLE :: ebu_hc5( :, :, : ) - REAL, ALLOCATABLE :: ebu_hc8( :, :, : ) - REAL, ALLOCATABLE :: ebu_ete( :, :, : ) - REAL, ALLOCATABLE :: ebu_olt( :, :, : ) - REAL, ALLOCATABLE :: ebu_oli( :, :, : ) - REAL, ALLOCATABLE :: ebu_pm25( :, :, : ) - REAL, ALLOCATABLE :: ebu_pm10( :, :, : ) - REAL, ALLOCATABLE :: ebu_oc( :, :, : ) - REAL, ALLOCATABLE :: ebu_bc( :, :, : ) - REAL, ALLOCATABLE :: ebu_so2( :, :, : ) - REAL, ALLOCATABLE :: ebu_sulf( :, :, : ) - REAL, ALLOCATABLE :: ebu_dien( :, :, : ) - REAL, ALLOCATABLE :: ebu_iso( :, :, : ) - REAL, ALLOCATABLE :: ebu_api( :, :, : ) - REAL, ALLOCATABLE :: ebu_lim( :, :, : ) - REAL, ALLOCATABLE :: ebu_tol( :, :, : ) - REAL, ALLOCATABLE :: ebu_xyl( :, :, : ) - REAL, ALLOCATABLE :: ebu_csl( :, :, : ) - REAL, ALLOCATABLE :: ebu_hcho( :, :, : ) - REAL, ALLOCATABLE :: ebu_ald( :, :, : ) - REAL, ALLOCATABLE :: ebu_ket( :, :, : ) - REAL, ALLOCATABLE :: ebu_macr( :, :, : ) - REAL, ALLOCATABLE :: ebu_ora1( :, :, : ) - REAL, ALLOCATABLE :: ebu_ora2( :, :, : ) - REAL, ALLOCATABLE :: mean_fct_agtf( :, : ) - REAL, ALLOCATABLE :: mean_fct_agef( :, : ) - REAL, ALLOCATABLE :: mean_fct_agsv( :, : ) - REAL, ALLOCATABLE :: mean_fct_aggr( :, : ) - REAL, ALLOCATABLE :: firesize_agtf( :, : ) - REAL, ALLOCATABLE :: firesize_agef( :, : ) - REAL, ALLOCATABLE :: firesize_agsv( :, : ) - REAL, ALLOCATABLE :: firesize_aggr( :, : ) - REAL, ALLOCATABLE :: ash_fall( :, : ) - REAL, ALLOCATABLE :: dust_fall( :, : ) - REAL, ALLOCATABLE :: pm2_5_dry( : , : , : ) - REAL, ALLOCATABLE :: pm2_5_dry_ec( : , : , : ) - REAL, ALLOCATABLE :: pm10( : , : , : ) - REAL, ALLOCATABLE :: sebio_iso( : , : ) - REAL, ALLOCATABLE :: sebio_oli( : , : ) - REAL, ALLOCATABLE :: sebio_api( : , : ) - REAL, ALLOCATABLE :: sebio_lim( : , : ) - REAL, ALLOCATABLE :: sebio_xyl( : , : ) - REAL, ALLOCATABLE :: sebio_hc3( : , : ) - REAL, ALLOCATABLE :: sebio_ete( : , : ) - REAL, ALLOCATABLE :: sebio_olt( : , : ) - REAL, ALLOCATABLE :: sebio_ket( : , : ) - REAL, ALLOCATABLE :: sebio_ald( : , : ) - REAL, ALLOCATABLE :: sebio_hcho( : , : ) - REAL, ALLOCATABLE :: sebio_eth( : , : ) - REAL, ALLOCATABLE :: sebio_ora2( : , : ) - REAL, ALLOCATABLE :: sebio_co( : , : ) - REAL, ALLOCATABLE :: sebio_nr( : , : ) - REAL, ALLOCATABLE :: noag_grow( : , : ) - REAL, ALLOCATABLE :: noag_nongrow( : , : ) - REAL, ALLOCATABLE :: nononag( : , : ) - REAL, ALLOCATABLE :: slai( : , : ) - REAL, ALLOCATABLE :: ebio_iso( : , : ) - REAL, ALLOCATABLE :: ebio_oli( : , : ) - REAL, ALLOCATABLE :: ebio_api( : , : ) - REAL, ALLOCATABLE :: ebio_lim( : , : ) - REAL, ALLOCATABLE :: ebio_xyl( : , : ) - REAL, ALLOCATABLE :: ebio_hc3( : , : ) - REAL, ALLOCATABLE :: ebio_ete( : , : ) - REAL, ALLOCATABLE :: ebio_olt( : , : ) - REAL, ALLOCATABLE :: ebio_ket( : , : ) - REAL, ALLOCATABLE :: ebio_ald( : , : ) - REAL, ALLOCATABLE :: ebio_hcho( : , : ) - REAL, ALLOCATABLE :: ebio_eth( : , : ) - REAL, ALLOCATABLE :: ebio_ora2( : , : ) - REAL, ALLOCATABLE :: ebio_co( : , : ) - REAL, ALLOCATABLE :: ebio_nr( : , : ) - REAL, ALLOCATABLE :: ebio_no( : , : ) - - !shc stuff for MEGAN v2.04 - - real, ALLOCATABLE :: EFmegan(:, : , :) - - - real, ALLOCATABLE :: msebio_isop(:, : ) - real, ALLOCATABLE :: pftp_bt(:, : ) - real, ALLOCATABLE :: pftp_nt(:, : ) - real, ALLOCATABLE :: pftp_sb(:, : ) - real, ALLOCATABLE :: pftp_hb(:, : ) - - real, ALLOCATABLE :: mlai(:, :, : ) - real, ALLOCATABLE :: mtsa(:, :, : ) - real, ALLOCATABLE :: mswdown(:, :, : ) - - real, ALLOCATABLE :: mebio_isop(:, : ) - real, ALLOCATABLE :: mebio_apin(:, : ) - real, ALLOCATABLE :: mebio_bpin(:, : ) - real, ALLOCATABLE :: mebio_bcar(:, : ) - real, ALLOCATABLE :: mebio_acet(:, : ) - real, ALLOCATABLE :: mebio_mbo(:, : ) - real, ALLOCATABLE :: mebio_no(:, : ) -! -! stuff for optical driver -! -! next three are for feedback to physics -! - REAL, ALLOCATABLE :: extt( :, :, :, : ) - REAL, ALLOCATABLE :: ssca( :, :, :, : ) - REAL, ALLOCATABLE :: asympar( :, :, :, : ) -! -! output diagnosics -! - REAL, ALLOCATABLE :: aod( :,: ) - REAL, ALLOCATABLE :: ext_coeff( :, :, :,:) - REAL, ALLOCATABLE :: bscat_coeff( :, :, :,:) - REAL, ALLOCATABLE :: asym_par( :, :, :,:) -! -! optical calculations, necessary for feedback to physics and diagnostics - real, ALLOCATABLE :: tauaersw(:, : , :, : ) - real, ALLOCATABLE :: tauaerlw(:, : , :, : ) - real, ALLOCATABLE :: bscoefsw(:, : , :, : ) - real, ALLOCATABLE :: gaersw(:, : , :, : ) - real, ALLOCATABLE :: waersw(:, : , :, : ) - real, ALLOCATABLE :: tauaer1(:, : , : ) - real, ALLOCATABLE :: tauaer2(:, : , : ) - real, ALLOCATABLE :: tauaer3(:, : , : ) - real, ALLOCATABLE :: tauaer4(:, : , : ) - real, ALLOCATABLE :: gaer1(:, : , : ) - real, ALLOCATABLE :: gaer2(:, : , : ) - real, ALLOCATABLE :: gaer3(:, : , : ) - real, ALLOCATABLE :: gaer4(:, : , : ) - real, ALLOCATABLE :: waer1(:, : , : ) - real, ALLOCATABLE :: waer2(:, : , : ) - real, ALLOCATABLE :: waer3(:, : , : ) - real, ALLOCATABLE :: waer4(:, : , : ) - real, ALLOCATABLE :: bscoef1(:, : , : ) - real, ALLOCATABLE :: bscoef2(:, : , : ) - real, ALLOCATABLE :: bscoef3(:, : , : ) - real, ALLOCATABLE :: bscoef4(:, : , : ) - real, ALLOCATABLE :: l2aer(:, : , : , : ) - real, ALLOCATABLE :: l3aer(:, : , : , : ) - real, ALLOCATABLE :: l4aer(:, : , : , : ) - real, ALLOCATABLE :: l5aer(:, : , : , : ) - real, ALLOCATABLE :: l6aer(:, : , : , : ) - real, ALLOCATABLE :: l7aer(:, : , : , : ) - -END MODULE MODULE_CHEMVARS diff --git a/src/fim/FIMsrc/fim/column_chem/module_ctrans_grell.F90 b/src/fim/FIMsrc/fim/column_chem/module_ctrans_grell.F90 deleted file mode 100644 index 70e3fbf..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_ctrans_grell.F90 +++ /dev/null @@ -1,1759 +0,0 @@ -!WRF:MODEL_LAYER:PHYSICS -! - -MODULE module_ctrans_grell -USE module_initial_chem_namelists -USE module_chemvars,only:epsilc -USE module_cu_g3 -!USE module_dep_simple - -CONTAINS - -!------------------------------------------------------------- - SUBROUTINE GRELLDRVCT(DT,itimestep, & - rho_phy,RAINCV,chem,trfall, & - U,V,t_phy,moist,dz8w,p_phy, & - XLV,CP,G,r_v,z,cu_co_ten, & - numgas,chemopt, & - num_chem,num_moist, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) -! USE module_configure -! USE module_state_description -!------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------- - INTEGER, INTENT(IN ) :: & - numgas,chemopt, & - num_chem,num_moist, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - - - INTEGER, INTENT(IN ) :: ITIMESTEP - - REAL, INTENT(IN ) :: XLV, R_v - REAL, INTENT(IN ) :: CP,G - - REAL, DIMENSION( ims:ime , kms:kme , jms:jme,num_moist ) , & - INTENT(IN ) :: moist - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & - INTENT(IN ) :: & - U, & - V, & - t_phy, & - z, & - p_phy, & - dz8w, & - rho_phy -! -! on output for control only, purely diagnostic -! - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & - INTENT(INOUT ) :: & - cu_co_ten - - -! - REAL, INTENT(IN ) :: DT -! - REAL, DIMENSION( ims:ime , kms:kme , jms:jme, num_chem ), & - INTENT(INOUT) :: & - chem - REAL, DIMENSION( ims:ime , jms:jme, num_chem ), & - INTENT(INOUT) :: & - trfall - - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(IN) :: RAINCV - -! LOCAL VARS - real, dimension (its:ite,kts:kte) :: & - OUTT,OUTQ,OUTQC - real, dimension (its:ite) :: & - pret, ter11 - -! -! basic environmental input includes moisture convergence (mconv) -! omega (omeg), windspeed (us,vs), and a flag (aaeq) to turn off -! convection for this call only and at that particular gridpoint -! - real, dimension (its:ite,kts:kte) :: & - T,TN,q,qo,PO,P,US,VS,hstary - real, dimension (its:ite,kts:kte,num_chem) :: & - tracer,tracert - real, dimension (its:ite,num_chem) :: & - trdep - real, dimension (its:ite) :: & - Z1,PSUR,AAEQ - integer, dimension (its:ite) :: & - ktop -! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - - INTEGER :: nv,i,j,k,ICLDCK,ipr,jpr,npr - REAL :: tcrit,dp,dq - INTEGER :: itf,jtf,ktf,iopt -! epsilc=1.e-30 -! return -! ipr=111 -! jpr=40 -! if(itimestep.lt.34.or.itimestep.gt.36)ipr=0 -! if(itimestep.lt.34.or.itimestep.gt.36)jpr=0 -! ipr=61 -! jpr=60 - ipr=0 - jpr=0 - npr=10 - tcrit=258. - iopt=0 - itf=MIN(ite,ide) - ktf=MIN(kte,kde) - jtf=MIN(jte,jde) -! -! -! write(6,*)'in ctrans' - trfall(:,:,:)=0. -123 continue - DO 100 J = jts,jtf - if(j.eq.jpr)print *,'dt = ',dt - DO I=ITS,ITF - ktop(i)=0 - PSUR(I)=p_phy(I,kts,J)*.01 - TER11(I)=z(i,kts,j) - aaeq(i)=0. -! -! rainrate is input for this transport/wet-deposition routine -! - pret(i)=raincv(i,j)/dt - if(pret(i).le.0.)aaeq(i)=20. - ENDDO - DO K=kts,ktf - DO I=ITS,ITF - po(i,k)=p_phy(i,k,j)*.01 - P(I,K)=PO(i,k) - US(I,K) =u(i,k,j) - VS(I,K) =v(i,k,j) - T(I,K)=t_phy(i,k,j) - q(I,K)=moist(i,k,j,p_qv) - IF(Q(I,K).LT.1.E-08)Q(I,K)=1.E-08 - ENDDO - ENDDO - do nv=1,num_chem - DO I=ITS,ITF - trdep(i,nv)=0. - ENDDO - DO K=kts,ktf - DO I=ITS,ITF - tracer(i,k,nv)=max(epsilc,chem(i,k,j,nv)) - tracert(i,k,nv)=0. - ENDDO - ENDDO - ENDDO - DO K=kts,ktf - DO I=ITS,ITF - cu_co_ten(i,k,j)=0. -! hstary(i,k)=hstar4(nv)*exp(dhr(nv)*(1./t(i,k)-1./298.)) -! if(i.eq.ipr.and.j.eq.jpr)then -! print *,k,pret(i),tracer(i,k,npr),p(i,k),z(i,k,j) -! endif - ENDDO - ENDDO -! ENDDO -! -!---- CALL NON_RESOLVED CONVECTIVE TRANSPORT -! - CALL CUP_ct(ktop,tracer,j,AAEQ,T,Q,TER11,PRET,P,tracert, & - hstary,DT,PSUR,US,VS,trdep,tcrit, & - xlv,r_v,cp,g,0,0,npr,num_chem,chemopt, & - numgas,itf,jtf,ktf, & - its,ite, jts,jte, kts,kte ) - - do nv=1,num_chem - DO I=its,itf - if(pret(i).le.0.)then - DO K=kts,ktf - tracert(i,k,nv)=0. - ENDDO - endif - enddo - enddo - CALL neg_check_ct(pret,ktop,epsilc,dt,tracer,tracert,iopt,num_chem, & - its,ite,kts,kte,itf,ktf,ipr,jpr,npr,j) - do nv=1,num_chem - DO I=its,itf - if(pret(i).gt.0.)then - trfall(i,j,nv)=trdep(i,nv) - DO K=kts,ktf-1 - - chem(i,k,j,nv)=max(epsilc,chem(i,k,j,nv)+tracert(i,k,nv)*dt) - if(nv.eq.npr)then - cu_co_ten(i,k,j)=tracert(i,k,npr)*dt - if(i.eq.ipr.and.j.eq.jpr)print *,k,chem(i,k,j,nv),cu_co_ten(i,k,j) - endif - ENDDO - else - DO K=kts,ktf-1 - tracert(i,k,nv)=0. - if(nv.eq.npr)cu_co_ten(i,k,j)=0. - enddo - endif - ENDDO - ENDDO - - - 100 continue - - END SUBROUTINE GRELLDRVCT - - - SUBROUTINE CUP_ct(ktop,tracer,J,AAEQ,T,Q,Z1, & - PRE,P,tracert,hstary,DTIME,PSUR,US,VS,TRFALL,TCRIT, & - xl,rv,cp,g,ipr,jpr,npr,num_chem,chemopt, & - numgas,itf,jtf,ktf, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE - - integer & - ,intent (in ) :: & - num_chem,itf,jtf,ktf, & - its,ite, jts,jte, kts,kte,ipr,jpr,npr,chemopt,numgas - integer, intent (in ) :: & - j - ! - ! - ! - !tracert = output temp tendency (per s) - ! pre = input precip - real, dimension (its:ite,kts:kte,num_chem) & - ,intent (inout ) :: & - tracert,tracer - real, dimension (its:ite,num_chem) & - ,intent (inout ) :: & - trfall - real, dimension (its:ite) & - ,intent (inout ) :: & - pre - integer, dimension (its:ite) & - ,intent (inout ) :: & - ktop - integer, dimension (its:ite) :: & - kbcon - ! - ! basic environmental input includes moisture convergence (mconv) - ! omega (omeg), windspeed (us,vs), and a flag (aaeq) to turn off - ! convection for this call only and at that particular gridpoint - ! - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - T,P,US,VS,HSTARY - real, dimension (its:ite,kts:kte) & - ,intent (inout) :: & - Q - real, dimension (its:ite) & - ,intent (in ) :: & - Z1,PSUR,AAEQ - - - real & - ,intent (in ) :: & - dtime,tcrit,xl,cp,rv,g - - - real, dimension (its:ite,1:3) :: & - edtc -! -! -! -!***************** the following are your basic environmental -! variables. They carry a "_cup" if they are -! on model cloud levels (staggered). They carry -! an "o"-ending (z becomes zo), if they are the forced -! variables. They are preceded by x (z becomes xz) -! to indicate modification by some typ of cloud -! - ! z = heights of model levels - ! q = environmental mixing ratio - ! qes = environmental saturation mixing ratio - ! t = environmental temp - ! p = environmental pressure - ! he = environmental moist static energy - ! hes = environmental saturation moist static energy - ! z_cup = heights of model cloud levels - ! q_cup = environmental q on model cloud levels - ! qes_cup = saturation q on model cloud levels - ! t_cup = temperature (Kelvin) on model cloud levels - ! p_cup = environmental pressure - ! he_cup = moist static energy on model cloud levels - ! hes_cup = saturation moist static energy on model cloud levels - ! gamma_cup = gamma on model cloud levels -! -! - ! hcd = moist static energy in downdraft - ! zd normalized downdraft mass flux - ! dby = buoancy term - ! entr = entrainment rate - ! zd = downdraft normalized mass flux - ! entr= entrainment rate - ! hcd = h in model cloud - ! bu = buoancy term - ! zd = normalized downdraft mass flux - ! gamma_cup = gamma on model cloud levels - ! mentr_rate = entrainment rate - ! qcd = cloud q (including liquid water) after entrainment - ! qrch = saturation q in cloud - ! pwd = evaporate at that level - ! pwev = total normalized integrated evaoprate (I2) - ! entr= entrainment rate - ! z1 = terrain elevation - ! entr = downdraft entrainment rate - ! jmin = downdraft originating level - ! kdet = level above ground where downdraft start detraining - ! psur = surface pressure - ! z1 = terrain elevation - ! zd = downdraft normalized mass flux - ! zu = updraft normalized mass flux - ! mbdt = arbitrary numerical parameter - ! dtime = dt over which forcing is applied - ! kbcon = LFC of parcel from k22 - ! k22 = updraft originating level - ! dby = buoancy term - ! ktop = cloud top (output) - ! xmb = total base mass flux - ! hc = cloud moist static energy - ! hkb = moist static energy at originating level - ! mentr_rate = entrainment rate - - real, dimension (its:ite,kts:kte) :: & - he,hes,qes,z,pwdper, & - - qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup, & - - dby,qc,qrcd,pwd,pw,hcd,qcd,dbyd,hc,qrc,zu,zd,clw_all, & - - ! cd = detrainment function for updraft - ! cdd = detrainment function for downdraft - - cd,cdd,scr1,DELLAH,DELLAQ,DELLAT,DELLAQC - - ! edt = epsilon - ! edt = epsilon - real, dimension (its:ite) :: & - edt,HKB,QKB, & - XMB,PWAV,PWEV,BU,cap_max,cap_max_increment - real, dimension (its:ite,kts:kte,num_chem) :: & - tr_c,tr_up,tr_dd,tre_cup,tr_pw,tr_pwd - real, dimension (its:ite,num_chem) :: & - trkb - integer, dimension (its:ite) :: & - kzdown,KDET,K22,KB,JMIN,kstabi,kstabm, & !-lxz - ierr,KBMAX - - integer :: & - nv,ki,I,K,KK - real :: & - day,dz,mbdt,entr_rate,radius,entrd_rate,mentr_rate,mentrd_rate, & - zcutdown,edtmax,edtmin,depth_min,zkbmax,z_detr,zktop, & - dh,cap_maxs - - - -!sms$distribute end - day=86400. -! -!--- specify entrainmentrate and detrainmentrate -! - radius=12000. -! -!--- gross entrainment rate (these may be changed later on in the -!--- program, depending what your detrainment is!!) -! - entr_rate=.2/radius -! -!--- entrainment of mass -! - mentrd_rate=0. - mentr_rate=entr_rate -! -!--- initial detrainmentrates -! - do k=kts,ktf - do i=its,itf - cd(i,k)=0.1*entr_rate - cdd(i,k)=0. - clw_all(i,k)=0. - enddo - enddo -! -!--- max/min allowed value for epsilon (ratio downdraft base mass flux/updraft -! base mass flux -! - edtmax=.8 - edtmin=.2 -! -!--- minimum depth (m), clouds must have -! - depth_min=500. -! -!--- maximum depth (mb) of capping -!--- inversion (larger cap = no convection) -! - cap_maxs=175. -!sms$to_local(grid_dh: <1, mix :size>, <2, mjx :size>) begin - DO 7 i=its,itf - kbmax(i)=1 - cap_max_increment(i)=0. - edt(i)=0. - kstabm(i)=ktf-1 - IERR(i)=0 - if(aaeq(i).ne.0.)then - ierr(i)=20 - endif - 7 CONTINUE - do i=its,itf - cap_max(i)=cap_maxs - enddo -! -!--- max height(m) above ground where updraft air can originate -! - zkbmax=4000. -! -!--- height(m) above which no downdrafts are allowed to originate -! - zcutdown=3000. -! -!--- depth(m) over which downdraft detrains all its mass -! - z_detr=1250. -! - mbdt=dtime*4.E-03 -! -!--- calculate moist static energy, heights, qes -! - call cup_env(z,qes,he,hes,t,q,p,z1, & - psur,ierr,tcrit,0,xl,cp, & - itf,jtf,ktf,& - its,ite, jts,jte, kts,kte) -! -!--- environmental values on cloud levels -! - call cup_env_clev(t,qes,q,he,hes,z,p,qes_cup,q_cup,he_cup, & - hes_cup,z_cup,p_cup,gamma_cup,t_cup,psur, & - ierr,z1,xl,rv,cp, & - itf,jtf,ktf,& - its,ite, jts,jte, kts,kte) - call cup_env_clev_tr(tracer,tre_cup,num_chem,ierr, & - itf,jtf,ktf,& - its,ite, jts,jte, kts,kte) - do i=its,itf - if(ierr(i).eq.0)then -! - do k=kts,ktf-2 - if(z_cup(i,k).gt.zkbmax+z1(i))then - kbmax(i)=k - go to 25 - endif - enddo - 25 continue -! -! -!--- level where detrainment for downdraft starts -! - do k=kts,ktf - if(z_cup(i,k).gt.z_detr+z1(i))then - kdet(i)=k - go to 26 - endif - enddo - 26 continue -! - endif - enddo -! -! -! -!------- DETERMINE LEVEL WITH HIGHEST MOIST STATIC ENERGY CONTENT - K22 -! - CALL cup_MAXIMI(HE_CUP,3,KBMAX,K22,ierr, & - itf,jtf,ktf,& - its,ite, jts,jte, kts,kte) - DO 36 i=its,itf - IF(ierr(I).eq.0.)THEN - IF(K22(I).GE.KBMAX(i))ierr(i)=2 - endif - 36 CONTINUE -! -!--- DETERMINE THE LEVEL OF CONVECTIVE CLOUD BASE - KBCON -! - call cup_kbcon(cap_max_increment,1,k22,kbcon,he_cup,hes_cup, & - ierr,kbmax,p_cup,cap_max, & - itf,jtf,ktf,& - its,ite, jts,jte, kts,kte) -! -!--- increase detrainment in stable layers -! - CALL cup_minimi(HEs_cup,Kbcon,kstabm,kstabi,ierr, & - itf,jtf,ktf,& - its,ite, jts,jte, kts,kte) - do i=its,itf - IF(ierr(I).eq.0.)THEN - if(kstabm(i)-1.gt.kstabi(i))then - do k=kstabi(i),kstabm(i)-1 - cd(i,k)=cd(i,k-1)+1.5*entr_rate - if(cd(i,k).gt.10.0*entr_rate)cd(i,k)=10.0*entr_rate - enddo - ENDIF - ENDIF - ENDDO -! -!--- calculate incloud moist static energy -! - call cup_up_he(k22,hkb,z_cup,cd,mentr_rate,he_cup,hc, & - kbcon,ierr,dby,he,hes_cup, & - itf,jtf,ktf,& - its,ite, jts,jte, kts,kte) - -!--- DETERMINE CLOUD TOP - KTOP -! - call cup_ktop(1,dby,kbcon,ktop,ierr, & - itf,jtf,ktf,& - its,ite, jts,jte, kts,kte) - DO 37 i=its,itf - kzdown(i)=0 - if(ierr(i).eq.0)then - zktop=(z_cup(i,ktop(i))-z1(i))*.6 - zktop=min(zktop+z1(i),zcutdown+z1(i)) - do k=kts,ktf - if(z_cup(i,k).gt.zktop)then - kzdown(i)=k - go to 37 - endif - enddo - endif - 37 CONTINUE -! -!--- DOWNDRAFT ORIGINATING LEVEL - JMIN -! - call cup_minimi(HEs_cup,K22,kzdown,JMIN,ierr, & - itf,jtf,ktf,& - its,ite, jts,jte, kts,kte) - DO 100 i=its,ite - IF(ierr(I).eq.0.)THEN -! -!--- check whether it would have buoyancy, if there where -!--- no entrainment/detrainment -! -101 continue - if(jmin(i)-1.lt.KDET(I))kdet(i)=jmin(i)-1 - if(jmin(i).ge.Ktop(I)-1)jmin(i)=ktop(i)-2 - ki=jmin(i) - hcd(i,ki)=hes_cup(i,ki) - DZ=Z_cup(i,Ki+1)-Z_cup(i,Ki) - dh=dz*(HCD(i,Ki)-hes_cup(i,ki)) - dh=0. -! - do k=ki-1,1,-1 - hcd(i,k)=hes_cup(i,jmin(i)) - DZ=Z_cup(i,K+1)-Z_cup(i,K) - dh=dh+dz*(HCD(i,K)-hes_cup(i,k)) - if(dh.gt.0.)then - jmin(i)=jmin(i)-1 - if(jmin(i).gt.3)then - go to 101 - else if(jmin(i).le.3)then - ierr(i)=9 - go to 100 - endif - endif - enddo - - IF(JMIN(I).LE.3)then - ierr(i)=4 - endif - - ENDIF -100 continue -! -! - Must have at least depth_min m between cloud convective base -! and cloud top. -! - do i=its,itf - IF(ierr(I).eq.0.)THEN - IF(-z_cup(I,KBCON(I))+z_cup(I,KTOP(I)).LT.depth_min)then - ierr(i)=6 - endif - endif - enddo - -! -!c--- normalized updraft mass flux profile -! - call cup_up_nms(zu,z_cup,mentr_rate,cd,kbcon,ktop,ierr,k22, & - itf,jtf,ktf,& - its,ite, jts,jte, kts,kte) -! -!c--- normalized downdraft mass flux profile,also work on bottom detrainment -!--- in this routine -! - call cup_dd_nms(zd,z_cup,cdd,mentrd_rate,jmin,ierr, & - 0,kdet,z1, & - itf,jtf,ktf,& - its,ite, jts,jte, kts,kte) -! -!--- downdraft moist static energy -! - call cup_dd_he(hes_cup,zd,hcd,z_cup,cdd,mentrd_rate, & - jmin,ierr,he,dbyd,he_cup, & - itf,jtf,ktf,& - its,ite, jts,jte, kts,kte) -! -!--- calculate moisture properties of downdraft -! - - call cup_dd_moisture_3d(zd,hcd,hes_cup,qcd,qes_cup, & - pwd,q_cup,z_cup,cdd,mentrd_rate,jmin,ierr,gamma_cup, & - pwev,bu,qrcd,q,he,t_cup,2,xl,0, & - itf,jtf,ktf,& - its,ite, jts,jte, kts,kte) -! -!--- calculate moisture properties of updraft -! - call cup_up_moisture(ierr,z_cup,qc,qrc,pw,pwav, & - kbcon,ktop,cd,dby,mentr_rate,clw_all, & - q,GAMMA_cup,zu,qes_cup,k22,q_cup,xl, & - itf,jtf,ktf,& - its,ite, jts,jte, kts,kte) -! -!--- DETERMINE DOWNDRAFT STRENGTH IN TERMS OF WINDSHEAR -! - call cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & - pwev,edtmax,edtmin,3,edtc, & - itf,jtf,ktf,& - its,ite, jts,jte, kts,kte) - do i=its,itf - if(ierr(i).eq.0)then - edt(i)=edtc(i,2) - endif - enddo -! -! massflux from precip and normalized cloud properties -! - pwdper=0. - do i=its,itf - - if(ierr(i).gt.0)pre(i)=0. - if(ierr(i).eq.0)then - xmb(i)=pre(i)/(pwav(i)+edt(i)*pwev(i)) -! -!--- percent of that that is evaporated (pwd is negative) -! - if(i.eq.ipr.and.j.eq.jpr)then - print *,'xmb,edt,pwav = ',xmb(i),edt(i),pwav(i) - print *,'k,pwdper(i,k),pw,pwd(i,k)',z1(i) - endif - do k=1,ktop(i) - pwdper(i,k)=-edt(i)*pwd(i,k)/pwav(i) - if(i.eq.ipr.and.j.eq.jpr)then - print *,k,pwdper(i,k),pw(i,k),pwd(i,k) - endif - enddo - endif - enddo -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!! NOW WE HAVE EVREYTHING TO CALCULATE TRACER TRANSPORT AND WET DEPOSITION !!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!--- calculate incloud tracer distribution -! - if(j.eq.jpr)print *,'calling up_tracer' - call cup_up_tracer(ierr,tcrit,t,pre,z_cup,p,tracer,tre_cup,tr_up,tr_pw, & - tr_c,hstary,pw,clw_all,kbcon,ktop,cd,mentr_rate,zu,k22,& - num_chem,numgas,chemopt,itf,jtf,ktf,& - its,ite, jts,jte, kts,kte,ipr,jpr,j,npr) - if(chem_opt == 500)then - do nv=1,num_chem - do i=its,ite - IF(ierr(I).eq.0)then - do k=kts,ktop(i) - trfall(i,nv)=trfall(i,nv)+tr_pw(i,k,nv)*xmb(i)*dtime - enddo - endif - enddo - enddo - endif - - if(j.eq.jpr)print *,'called up_tracer' - call cup_dd_tracer(ierr,z_cup,qrcd,tracer,tre_cup,tr_up,tr_dd, & - tr_pw,tr_pwd,jmin,cdd,mentrd_rate,zd,pwdper,k22, & - num_chem,itf,jtf,ktf,& - its,ite, jts,jte, kts,kte) - if(j.eq.jpr)print *,'called dd_tracer' - - -! - if(j.eq.jpr)then - i=ipr - print *,'in 250 loop ',edt(ipr),ierr(ipr) -! if(ierr(i).eq.0.or.ierr(i).eq.3)then - print *,k22(I),kbcon(i),ktop(i),jmin(i) - print *,edt(i) - do k=kts,ktf - print *,k,z(i,k),he(i,k),hes(i,k) - enddo - do k=1,ktop(i)+1 - print *,zu(i,k),zd(i,k),pw(i,k),pwd(i,k) - enddo - print *,'tr_up(i,k,6),tr_dd(i,k,6),tr_pw(i,k,6),tr_pwd(i,k,6)' - do k=1,ktop(i)+1 - print *,tr_up(i,k,npr),tr_dd(i,k,npr),tr_pw(i,k,npr),tr_pwd(i,k,npr) - enddo - endif -! endif -! -!--- calculate transport tendencies -! -!--- 1. in bottom layer -! - call cup_dellabot_tr(ipr,jpr,tre_cup,ierr,z_cup,p,tr_dd,edt, & - zd,cdd,tracer,tracert,j,mentrd_rate,z,g,xmb, & - num_chem,itf,jtf,ktf,& - its,ite, jts,jte, kts,kte) -! -!--- 2. everywhere else -! - - call cup_dellas_tr(ierr,z_cup,p_cup,tr_dd,edt,zd,cdd, & - tracer,tracert,j,mentrd_rate,zu,g,xmb, & - cd,tr_up,ktop,k22,kbcon,mentr_rate,jmin,tre_cup,kdet, & - k22,ipr,jpr,npr,'deep',num_chem, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte ) - if(j.eq.jpr)then - i=ipr - do k=kts,ktf - print *,k,tracer(i,k,npr),tracert(i,k,npr) - enddo - endif -! -! may need more below for wet deposition...... -! -! -! call cup_output_wd ( & -! itf,jtf,ktf,& -! its,ite, jts,jte, kts,kte) - - END SUBROUTINE CUP_CT - - SUBROUTINE cup_dellabot_tr(ipr,jpr,tre_cup,ierr,z_cup,p_cup, & - tr_dd,edt,zd,cdd,tracer,tracert,j,mentrd_rate,z,g,xmb, & - num_chem,itf,jtf,ktf, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE - - integer & - ,intent (in ) :: & - num_chem,itf,jtf,ktf, & - its,ite, jts,jte, kts,kte - integer, intent (in ) :: & - j,ipr,jpr - ! - ! ierr error value, maybe modified in this routine - ! - real, dimension (its:ite,kts:kte,1:num_chem) & - ,intent (out ) :: & - tracert - real, dimension (its:ite,kts:kte,1:num_chem) & - ,intent (in ) :: & - tre_cup,tracer,tr_dd - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - z_cup,p_cup,zd,cdd,z - real, dimension (its:ite) & - ,intent (in ) :: & - edt,xmb - real & - ,intent (in ) :: & - g,mentrd_rate - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr -! -! local variables in this routine -! - - integer i - real detdo,detdo1,detdo2,entdo,dp,dz,subin, & - totmas -! - integer :: nv, npr - npr=24 -! -! - if(j.eq.jpr)print *,'in cup dellabot ' - tracert=0. - do 100 i=its,itf - if(ierr(i).ne.0)go to 100 - dz=z_cup(i,2)-z_cup(i,1) - DP=100.*(p_cup(i,1)-P_cup(i,2)) - detdo1=edt(i)*zd(i,2)*CDD(i,1)*DZ - detdo2=edt(i)*zd(i,1) - entdo=edt(i)*zd(i,2)*mentrd_rate*dz - subin=-EDT(I)*zd(i,2) - detdo=detdo1+detdo2-entdo+subin - do nv=1,num_chem - tracert(I,1,nv)=(detdo1*.5*(tr_dd(i,1,nv)+tr_dd(i,2,nv)) & - +detdo2*tr_dd(i,1,nv) & - +subin*tre_cup(i,2,nv) & - -entdo*tracer(i,1,nv))*g/dp*xmb(i) - enddo - if(j.eq.jpr.and.i.eq.ipr)print *,'in cup dellabot ',tracert(I,1,npr), & - detdo1,detdo2,subin,entdo,tr_dd(i,1,npr),tr_dd(i,2,npr),tracer(i,1,npr) - 100 CONTINUE - - END SUBROUTINE cup_dellabot_tr - - - SUBROUTINE cup_dellas_tr(ierr,z_cup,p_cup,tr_dd,edt,zd,cdd, & - tracer,tracert,j,mentrd_rate,zu,g,xmb, & - cd,tr_up,ktop,k22,kbcon,mentr_rate,jmin,tre_cup,kdet,kpbl, & - ipr,jpr,npr,name,num_chem, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE - - integer & - ,intent (in ) :: & - num_chem,itf,jtf,ktf, & - its,ite, jts,jte, kts,kte - integer, intent (in ) :: & - j,ipr,jpr,npr - ! - ! ierr error value, maybe modified in this routine - ! - real, dimension (its:ite,kts:kte,1:num_chem) & - ,intent (inout ) :: & - tracert - real, dimension (its:ite,kts:kte,1:num_chem) & - ,intent (in ) :: & - tr_up,tr_dd,tre_cup,tracer - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - z_cup,p_cup,zd,cdd,cd,zu - real, dimension (its:ite) & - ,intent (in ) :: & - edt,xmb - real & - ,intent (in ) :: & - g,mentrd_rate,mentr_rate - integer, dimension (its:ite) & - ,intent (in ) :: & - kbcon,ktop,k22,jmin,kdet,kpbl - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr - character *(*), intent (in) :: & - name -! -! local variables in this routine -! - - integer i,k,nv - real detdo1,detdo2,entdo,dp,dz,subin,detdo,entup, & - detup,subdown,entdoj,entupk,detupk,totmas -! -! npr=24 -! -! - i=ipr - if(j.eq.jpr)then - print *,'in dellas kpbl(i),k22(i),kbcon(i),ktop(i),jmin(i)' - print *,kpbl(i),k22(i),kbcon(i),ktop(i),jmin(i) - endif - do nv=1,num_chem - DO K=kts+1,kte - do i=its,itf - tracert(i,k,nv)=0. - enddo - enddo - enddo -! - DO 100 k=kts+1,ktf-1 - DO 100 i=its,ite - IF(ierr(i).ne.0)GO TO 100 - IF(K.Gt.KTOP(I))GO TO 100 -! -!--- SPECIFY DETRAINMENT OF DOWNDRAFT, HAS TO BE CONSISTENT -!--- WITH ZD CALCULATIONS IN SOUNDD. -! - DZ=Z_cup(I,K+1)-Z_cup(I,K) - detdo=edt(i)*CDD(i,K)*DZ*ZD(i,k+1) - entdo=edt(i)*mentrd_rate*dz*zd(i,k+1) - subin=zu(i,k+1)-zd(i,k+1)*edt(i) - entup=0. - detup=0. - if(k.ge.kbcon(i).and.k.lt.ktop(i))then - entup=mentr_rate*dz*zu(i,k) - detup=CD(i,K+1)*DZ*ZU(i,k) - endif - subdown=(zu(i,k)-zd(i,k)*edt(i)) - entdoj=0. - entupk=0. - detupk=0. -! - if(k.eq.jmin(i))then - entdoj=edt(i)*zd(i,k) - endif - - if(k.eq.k22(i)-1)then - entupk=zu(i,kpbl(i)) - endif - - if(k.gt.kdet(i))then - detdo=0. - endif - - if(k.eq.ktop(i)-0)then - detupk=zu(i,ktop(i)) - subin=0. - endif - if(k.lt.kbcon(i))then - detup=0. - endif -!C -!C--- CHANGED DUE TO SUBSIDENCE AND ENTRAINMENT -!C - totmas=subin-subdown+detup-entup-entdo+ & - detdo-entupk-entdoj+detupk - if(j.eq.jpr.and.i.eq.ipr)print *,'k,totmas,sui,sud = ',k, & - totmas,subin,subdown -! if(j.eq.jpr.and.i.eq.ipr)print *,'updr stuff = ',detup, -! 1 entup,entupk,detupk -! if(j.eq.jpr.and.i.eq.ipr)print *,'dddr stuff = ',entdo, -! 1 detdo,entdoj - if(abs(totmas).gt.1.e-6)then - print *,'*********************',i,j,k,totmas,name - print *,kpbl(i),k22(i),kbcon(i),ktop(i) -!c print *,'updr stuff = ',subin, -!c 1 subdown,detup,entup,entupk,detupk -!c print *,'dddr stuff = ',entdo, -!c 1 detdo,entdoj -! CALL wrf_error_fatal ( 'cup_dellas_tr: TOTMAS > CRITICAL VALUE') - endif - dp=100.*(p_cup(i,k-1)-p_cup(i,k)) - do nv=1,num_chem -! tracert(i,k,nv)=(subin*tre_cup(i,k+1,nv) & -! -subdown*tre_cup(i,k,nv) & - tracert(i,k,nv)=(subin*tracer(i,k+1,nv) & - -subdown*tracer(i,k,nv) & - +detup*.5*(tr_up(i,K+1,nv)+tr_up(i,K,nv)) & - +detdo*.5*(tr_dd(i,K+1,nv)+tr_dd(i,K,nv)) & - -entup*tracer(i,k,nv) & - -entdo*tracer(i,k,nv) & - -entupk*tre_cup(i,k22(i),nv) & - -entdoj*tre_cup(i,jmin(i),nv) & - +detupk*tr_up(i,ktop(i),nv) & - )*g/dp*xmb(i) - enddo - if(i.eq.ipr.and.j.eq.jpr)then - print *,k,tracert(i,k,npr),subin*tre_cup(i,k+1,npr),subdown*tre_cup(i,k,npr), & - detdo*.5*(tr_dd(i,K+1,npr)+tr_dd(i,K,npr)) - print *,k,detup*.5*(tr_up(i,K+1,npr)+tr_up(i,K,npr)),detupk*tr_up(i,ktop(i),npr), & - entup*tracer(i,k,npr),entdo*tracer(i,k,npr) - print *,k,entupk*tre_cup(i,k,npr),detupk,tr_up(i,ktop(i),npr) - endif - - 100 CONTINUE - - END SUBROUTINE cup_dellas_tr - SUBROUTINE cup_env_clev_tr(tracer,tre_cup,num_chem,ierr, & - itf,jtf,ktf,& - its,ite, jts,jte, kts,kte) - implicit none - integer & - ,intent (in ) :: & - num_chem,itf,jtf,ktf, & - its,ite, jts,jte, kts,kte - integer, dimension (its:ite) & - ,intent (in) :: & - ierr - - real, dimension (its:ite,kts:kte,1:num_chem) & - ,intent (in ) :: & - tracer - real, dimension (its:ite,kts:kte,1:num_chem) & - ,intent (out ) :: & - tre_cup -! -! local variables in this routine -! - - integer :: & - i,k,nv - do nv=1,num_chem - do k=kts+1,ktf - do i=its,ite - if(ierr(i).eq.0)then - tre_cup(i,k,nv)=.5*(tracer(i,k-1,nv)+tracer(i,k,nv)) - endif - enddo - enddo - enddo - do nv=1,num_chem - do i=its,ite - if(ierr(i).eq.0)then - tre_cup(i,kts,nv)=tracer(i,kts,nv) - endif - enddo - enddo - - -END subroutine cup_env_clev_tr - - - SUBROUTINE cup_up_tracer(ierr,tcrit,t,pre,z_cup,p,tracer,tre_cup,tr_up, & - tr_pw,tr_c,hstary,cupclw,clw_all,kbcon,ktop,cd,mentr_rate,zu,k22, & - num_chem,numgas,chemopt,itf,jtf,ktf,& - its,ite, jts,jte, kts,kte,ipr,jpr,j,npr) -! USE module_configure -! USE module_state_description -! USE module_ctrans_aqchem - implicit none -! Aqeuous species pointers INCLUDE File - -!...........PARAMETERS and their descriptions: - - INTEGER NGAS ! number of gas phase species for AQCHEM - PARAMETER ( NGAS = 11 ) - - INTEGER NAER ! number of aerosol species for AQCHEM - PARAMETER ( NAER = 23 ) - -!...pointers for the AQCHEM array GAS - - INTEGER LSO2 ! local pointer to SO2 - PARAMETER ( LSO2 = 1 ) - - INTEGER LHNO3 ! local pointer to HNO3 - PARAMETER ( LHNO3 = 2 ) - - INTEGER LN2O5 ! local pointer to N2O5 - PARAMETER ( LN2O5 = 3 ) - INTEGER LCO2 ! local pointer to CO2 - PARAMETER ( LCO2 = 4 ) - - INTEGER LNH3 ! local pointer to NH3 - PARAMETER ( LNH3 = 5 ) - - INTEGER LH2O2 ! local pointer to H2O2 - PARAMETER ( LH2O2 = 6 ) - - INTEGER LO3 ! local pointer to O3 - PARAMETER ( LO3 = 7 ) - - INTEGER LFOA ! local pointer to FOA - PARAMETER ( LFOA = 8 ) - - INTEGER LMHP ! local pointer to MHP - PARAMETER ( LMHP = 9 ) - - INTEGER LPAA ! local pointer to PAA - PARAMETER ( LPAA = 10 ) - - INTEGER LH2SO4 ! local pointer to H2SO4 - PARAMETER ( LH2SO4 = 11 ) - -!...pointers for the AQCHEM array AEROSOL - - INTEGER LSO4AKN ! local pointer to SO4I aerosol - PARAMETER ( LSO4AKN = 1 ) - - INTEGER LSO4ACC ! local pointer to SO4 aerosol - PARAMETER ( LSO4ACC = 2 ) - - INTEGER LNH4AKN ! local pointer to NH4I aerosol - PARAMETER ( LNH4AKN = 3 ) - - INTEGER LNH4ACC ! local pointer to NH4 aerosol - PARAMETER ( LNH4ACC = 4 ) - - INTEGER LNO3AKN ! local pointer to NO3I aerosol - PARAMETER ( LNO3AKN = 5 ) - - INTEGER LNO3ACC ! local pointer to NO3 aerosol - PARAMETER ( LNO3ACC = 6 ) - - INTEGER LNO3COR ! local pointer to course aerosol nitrate - PARAMETER ( LNO3COR = 7 ) - - INTEGER LORGAKN ! local pointer to organic I aerosol - PARAMETER ( LORGAKN = 8 ) - - INTEGER LORGACC ! local pointer to organic aerosol - PARAMETER ( LORGACC = 9 ) - - INTEGER LPRIAKN ! local pointer to primary I aerosol - PARAMETER ( LPRIAKN = 10 ) - - INTEGER LPRIACC ! local pointer to primary aerosol - PARAMETER ( LPRIACC = 11 ) - - INTEGER LPRICOR ! local pointer to primary I aerosol - PARAMETER ( LPRICOR = 12 ) - - INTEGER LCACO3 ! local pointer to CaCO3 aerosol - PARAMETER ( LCACO3 = 13 ) - - INTEGER LMGCO3 ! local pointer to MgCO3 aerosol - PARAMETER ( LMGCO3 = 14 ) - - INTEGER LNACL ! local pointer to NaCl aerosol - PARAMETER ( LNACL = 15 ) - - INTEGER LA3FE ! local pointer to Fe+++ aerosol - PARAMETER ( LA3FE = 16 ) - - INTEGER LB2MN ! local pointer to Mn++ aerosol - PARAMETER ( LB2MN = 17 ) - - INTEGER LKCL ! local pointer to NaCl aerosol - PARAMETER ( LKCL = 18 ) - - INTEGER LNUMAKN ! local pointer to # Aitken aerosol - PARAMETER ( LNUMAKN = 19 ) - - INTEGER LNUMACC ! local pointer to # accumulation aerosol - PARAMETER ( LNUMACC = 20 ) - - INTEGER LNUMCOR ! local pointer to # coarse aerosol - PARAMETER ( LNUMCOR = 21 ) - - INTEGER LSRFAKN ! local pointer to sfc area Aitken aerosol - PARAMETER ( LSRFAKN = 22 ) - - INTEGER LSRFACC ! local pntr to sfc area accumulation aerosol - PARAMETER ( LSRFACC = 23 ) - - -! -! on input -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - num_chem,numgas,itf,jtf,ktf, & - chemopt, & - its,ite, jts,jte, kts,kte,ipr,jpr,j,npr - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - z_cup,cd,zu,p,hstary,t - real, dimension (its:ite,kts:kte) & - ,intent (inout ) :: & - cupclw,clw_all - real, dimension (its:ite,kts:kte,1:num_chem) & - ,intent (inout ) :: & - tr_up,tr_c,tr_pw - real, dimension (its:ite,kts:kte,1:num_chem) & - ,intent (in ) :: & - tre_cup,tracer - real, dimension (its:ite) & - ,intent (in ) :: & - pre - - ! entr= entrainment rate - real & - ,intent (in ) :: & - mentr_rate,tcrit - integer, dimension (its:ite) & - ,intent (in ) :: & - kbcon,ktop,k22 - ! ierr error value, maybe modified in this routine - - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr -! local variables in this routine -! - real :: conc_equi,conc_mxr,partialp,taucld - - integer :: & - iall,i,k,iwd,nv - real :: & - alpha,trcc,trch,dh,qrch,c0,dz,radius,airm,dens - integer :: & - iaer,igas -! -! aerosol scavenging coeffs for aitken mode -! - real alfa0,alfa2,alfa3 -! output variables -! hpwdep h+ deposition - real, dimension (ngas) :: gas,gaswdep - real, dimension (naer) :: aerosol,aerwdep - real hpwdep - alfa0=0. - alfa2=0. - alfa3=0. - gas(lco2)=340. - taucld=1800. - qrch=0. - -! - iall=0 - c0=.002 - iwd=0 -! -!--- no precip for small clouds -! - if(mentr_rate.gt.0.)then - radius=.2/mentr_rate - if(radius.lt.900.)c0=0. -! if(radius.lt.900.)iall=0 - endif - do nv=1,num_chem - do k=kts,ktf - do i=its,itf - tr_pw(i,k,nv)=0. - if(ierr(i).eq.0)tr_up(i,k,nv)=tre_cup(i,k,nv) - tr_c(i,k,nv)=0. - enddo - enddo - enddo - do nv=1,num_chem - do i=its,itf - if(ierr(i).eq.0.)then - do k=k22(i),kbcon(i)-1 - tr_up(i,k,nv)=tre_cup(i,k22(i),nv) - enddo - endif - enddo - enddo - if(j.eq.jpr)print *,'p_so2,o_o3 = ',p_so2,p_o3 - DO 100 k=kts+1,ktf-1 - DO 100 i=its,itf - AEROSOL=0. - GAS=0. - IF(ierr(i).ne.0)GO TO 100 - IF(K.Lt.KBCON(I))GO TO 100 - IF(K.Gt.KTOP(I)+1)GO TO 100 - DZ=Z_cup(i,K)-Z_cup(i,K-1) - if(cupclw(i,k).le.0.)cupclw(i,k)=0. - if(clw_all(i,k).le.0.)clw_all(i,k)=0. -! -!------ 1. steady state plume equation, for what could -!------ be in cloud before anything happens (kg/kg) -!------ tr_up would be the concentration if tr would be conserved -! -! - do nv=1,num_chem - if(i.eq.ipr.and.j.eq.jpr.and.nv.eq.npr)print *,k,tr_up(i,K-1,nv),tr_up(i,K,nv),tr_pw(i,k-1,nv),clw_all(i,k),cupclw(i,k) - tr_up(i,K,nv)=(tr_up(i,K-1,nv)*(1.-.5*CD(i,K)*DZ)+mentr_rate* & - DZ*tracer(i,K-1,nv))/(1.+mentr_rate*DZ-.5*cd(i,k)*dz) - tr_up(i,k,nv)=max(1.e-16,tr_up(i,K,nv)) - enddo -! -! sources or sinks due to aq chem -! - -!!!!!!!! the following only for made/sorgam !!!!!!!!!! - if(chemopt.eq.2)then - dens=1000.*p(i,k)*100./t(i,k)/287./28.9628 - airm=dens*dz -!...gas concentrations (ppm) - - GAS( LCO2 ) = 370.0 - GAS( LFOA ) = 0.0 ! ??? - GAS( LMHP ) = 0.0 ! ??? - - GAS( LSO2 ) = tr_up(i,k,p_so2) - GAS( LH2SO4 ) = tr_up(i,k,p_sulf) - GAS( LNH3 ) = tr_up(i,k,p_nh3) - GAS( LH2O2 ) = tr_up(i,k,p_h2o2) - - GAS( LO3 ) = tr_up(i,k,p_o3) - GAS( LPAA ) = tr_up(i,k,p_paa) - GAS( LHNO3 ) = tr_up(i,k,p_hno3) - GAS( LN2O5 ) = tr_up(i,k,p_n2o5) -!...convert to mol/mol - - DO IGAS=1,NGAS - GAS( IGAS ) = GAS( IGAS ) * 1.0E-6 - END DO - -!...aerosol concentrations (ug/m3) - -! AEROSOL( LSO4ACC ) = 20.0 -! AEROSOL( LNH4ACC ) = 6.65 -! AEROSOL( LNO3ACC ) = 10.0 -! AEROSOL( LNACL ) = 1.71 -!! AEROSOL( LA3FE ) = 0.5 -! AEROSOL( LB2MN ) = 0.02 -! AEROSOL( LNO3COR ) = 0.0 - AEROSOL( LORGACC ) = 0.0 - AEROSOL( LPRIACC ) = 0.0 -! AEROSOL( LCACO3 ) = 3.05 -! AEROSOL( LMGCO3 ) = 0.0 - - AEROSOL( LSO4ACC ) = tr_up(i,k,p_so4aj) - AEROSOL( LNH4ACC ) = tr_up(i,k,p_nh4aj) - AEROSOL( LNO3ACC ) = tr_up(i,k,p_no3aj) - AEROSOL( LNACL ) = 0. - AEROSOL( LA3FE ) = .5 - AEROSOL( LB2MN ) = .02 - AEROSOL( LNO3COR ) = 0. -! AEROSOL( LORGACC ) = tr_up(i,k,) + tr_up(i,k,) + tr_up(i,k,) -! AEROSOL( LPRIACC ) = tr_up(i,k,) + tr_up(i,k,) - AEROSOL( LCACO3 ) = 0. - AEROSOL( LMGCO3 ) = 0. - - -!...convert to mol/mol -! - -! DO IAER=1,NAER -! AEROSOL( IAER ) = AEROSOL( IAER ) * 1.0E-6 * CTHK1 -! & / ( SGRAERMW( IAER ) * AIRM ) -! END DO - DO IAER=1,NAER - AEROSOL( IAER ) = AEROSOL( IAER ) * 1.0E-6 - END DO -! first clw is water, second is total - - GASWDEP=0. - AERWDEP=0. - HPWDEP=0. -! if(clw_all(i,k).gt.1.e-12)then -! if(cupclw(i,k).gt.1.e-12)then -! CALL AQCHEM (t(i,k),p(i,k)*100.,taucld,cupclw(i,k)/3600., & -! clw_all(i,k)*dens,clw_all(i,k)*dens,airm,ALFA0,ALFA2,ALFA3,GAS, & -! AEROSOL, GASWDEP, AERWDEP, HPWDEP ) -! endif -! endif - - - - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! FOLLOWING FOR WET DEPOSITION !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! - do nv=1,num_chem - tr_c(i,k,nv)=0. - tr_pw(i,k,nv)=c0*dz*tr_C(I,K,nv)*zu(i,k) - if(tr_c(i,k,nv).le.0.)then - tr_c(i,k,nv)=0. - endif -! -!--- iall.eq.1, if all cloudwater goes to rain -! - if(iall.eq.1)then - tr_c(i,k,nv)=0. - tr_pw(i,k,nv)=(tr_c(I,K,nv)-QRCH)*zu(i,k) - if(tr_pw(i,k,nv).lt.0.)tr_pw(i,k,nv)=0. - endif - enddo - -! -!----- set next level -! tr_up(I,K,nv)=tr_c(I,K,nv)+qrch - tr_up(i,k,p_so2)=gas(lso2)*1.e6 - tr_up(i,k,p_sulf)=gas(lh2so4)*1.e6 - tr_up(i,k,p_nh3)=gas(lnh3)*1.e6 - tr_up(i,k,p_h2o2)=gas(lh2o2)*1.e6 - - tr_up(i,k,p_o3)=gas(lo3)*1.e6 - tr_up(i,k,p_paa)=gas(lpaa)*1.e6 - tr_up(i,k,p_hno3)=gas(lhno3)*1.e6 - tr_up(i,k,p_n2o5)=gas(ln2o5)*1.e6 - tr_up(i,k,p_so4aj)=AEROSOL( LSO4ACC )*1.e6 - tr_up(i,k,p_nh4aj)=AEROSOL( LNH4ACC )*1.e6 - tr_up(i,k,p_no3aj)=AEROSOL( LNO3ACC ) *1.e6 - - tr_pw(i,k,p_so2)=gaswdep(lso2)*1.e6 - tr_pw(i,k,p_sulf)=gaswdep(lh2so4)*1.e6 - tr_pw(i,k,p_nh3)=gaswdep(lnh3)*1.e6 - tr_pw(i,k,p_h2o2)=gaswdep(lh2o2)*1.e6 - - tr_pw(i,k,p_o3)=gaswdep(lo3)*1.e6 - tr_pw(i,k,p_paa)=gaswdep(lpaa)*1.e6 - tr_pw(i,k,p_hno3)=gaswdep(lhno3)*1.e6 - tr_pw(i,k,p_n2o5)=gaswdep(ln2o5)*1.e6 - tr_pw(i,k,p_so4aj)=AERwdep( LSO4ACC )*1.e6 - tr_pw(i,k,p_nh4aj)=AERwdep( LNH4ACC )*1.e6 - tr_pw(i,k,p_no3aj)=AERwdep( LNO3ACC ) *1.e6 - if(i.eq.ipr.and.j.eq.jpr)then - write(6,*)'a',tr_up(i,k,npr),tracer(i,K-1,npr),tr_pw(i,k,npr) - endif - else ! NOT MADE SORGAM - do nv=1,num_chem -! we definitely need wet deposition for sulf -! tr_c would be conc_mxr for other tracers, like: -! partialp=1.e-6*qc(i,k)*29./wtm(name)*p(i,k)/1013. -! conc_equi=partialp*hstary(i,k) -! -!--- conc_mxr would be "my" qc-qrch (Kg/Kg) -! -! conc_mxr=conc_equi*cupclw(i,j,k)*wtm(name) - -! setting it to zero, takes away wet deposition for now - tr_c(i,k,nv)=0. - tr_pw(i,k,nv)=c0*dz*tr_C(I,K,nv)*zu(i,k) - if(tr_c(i,k,nv).le.0.)then - tr_c(i,k,nv)=0. - endif -! -! here comes nonzero stuff -! -! if(nv.eq.p_sulf.and.p_sulf.gt.1.and.chemopt.ne.300.and.chemopt.ne.301)then -! tr_c(i,k,nv)=tr_up(i,k,nv) -! trch=tr_up(i,k,nv)-tr_c(i,k,nv) -! trcc=(tr_up(i,k,nv)-trch)/(1.+c0*dz*zu(i,k)) -! tr_pw(i,k,nv)=c0*dz*trcc*zu(i,k) -! tr_up(i,k,nv)=trcc - if(chemopt.ge.300.and. chemopt .lt. 500 )then - if(nv.gt.numgas)then - alpha = .5 ! scavenging factor - if(nv.eq.p_bc1 .or. nv.eq.p_oc1 .or. nv.eq.p_dms)alpha=0. - if(nv.eq.p_bc2 .or. nv.eq.p_oc2)alpha=0.8 - tr_c(i,k,nv)=.1*alpha*tr_up(i,k,nv) - trch=tr_up(i,k,nv)-tr_c(i,k,nv) -! - if(nv.eq.p_sulf .or. nv.eq.p_seas_1 .or. nv.eq.p_seas_2 .or. & - nv.eq.p_seas_3 .or. nv.eq.p_seas_4)then - alpha=1. - tr_c(i,k,nv)=tr_up(i,k,nv) - trch = 0. - endif - trcc=(tr_up(i,k,nv)-trch)/(1.+c0*dz*zu(i,k)) - tr_pw(i,k,nv)=c0*dz*trcc*zu(i,k) - tr_up(i,k,nv)=trcc+trch !conc total = conc in liq water (= trcc ) - endif - ! + conc in air (= trch ) - - else if(chemopt.ge.500)then - alpha = 0. ! scavenging factor - if(chemopt == 501 .or. chemopt == 502)alpha = .5 ! scavenging factor - tr_c(i,k,nv)=alpha*tr_up(i,k,nv) - trch=tr_up(i,k,nv)-tr_c(i,k,nv) - trcc=(tr_up(i,k,nv)-trch)/(1.+c0*dz*zu(i,k)) - tr_pw(i,k,nv)=c0*dz*trcc*zu(i,k) - tr_up(i,k,nv)=trcc+trch !conc total = conc in liq water (= trcc ) - ! + conc in air (= trch ) - - endif - enddo ! enddo nv - -! -! for gocart assuming scavenging factor of .6 -! -! else if((chemopt.ge.300.and.nv.gt.numgas).or.(chemopt.ge.300.and.nv.eq.p_sulf))then -! else if(chemopt.ge.300.and.nv.gt.numgas)then -! alpha = .5 ! scavenging factor -! if(nv.eq.p_bc1 .or. nv.eq.p_oc1 .or. nv.eq.p_dms)alpha=0. -! if(nv.eq.p_sulf .or. nv.eq.p_seas_1 .or. nv.eq.p_seas_2)alpha=1. -! if(nv.eq.p_bc2 .or. nv.eq.p_oc2)alpha=0.8 -! -! tr_c(i,k,nv)=alpha*tr_up(i,k,nv) -! trch=tr_up(i,k,nv)-tr_c(i,k,nv) -! trcc=(tr_up(i,k,nv)-trch)/(1.+c0*dz*zu(i,k)) -! tr_pw(i,k,nv)=c0*dz*trcc*zu(i,k) -! tr_up(i,k,nv)=trcc+trch !conc total = conc in liq water (= trcc ) -! ! + conc in air (= trch ) - -! endif -! enddo ! enddo nv -! -!--- iall.eq.1, if all cloudwater goes to rain -! -! if(iall.eq.1)then -! tr_c(i,k,nv)=0. -! tr_pw(i,k,nv)=(tr_c(I,K,nv)-QRCH)*zu(i,k) -! if(tr_pw(i,k,nv).lt.0.)tr_pw(i,k,nv)=0. -! endif - endif ! END CHEMOPT - - 100 CONTINUE - - -END subroutine cup_up_tracer - - - - SUBROUTINE cup_dd_tracer(ierr,z_cup,qrcd,tracer,tre_cup,tr_up,tr_dd, & - tr_pw,tr_pwd,jmin,cdd,entr,zd,pwdper,k22, & - num_chem,itf,jtf,ktf,& - its,ite, jts,jte, kts,kte) -! USE module_configure -! USE module_state_description - implicit none -! -! on input -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - num_chem,itf,jtf,ktf, & - its,ite, jts,jte, kts,kte - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - pwdper,zd,cdd,qrcd,z_cup - real, dimension (its:ite,kts:kte,1:num_chem) & - ,intent (inout ) :: & - tr_dd,tr_pwd,tr_up - real, dimension (its:ite,kts:kte,1:num_chem) & - ,intent (in ) :: & - tre_cup,tracer,tr_pw - real, dimension (its:ite,1:num_chem) :: pwav - - ! entr= entrainment rate - real & - ,intent (in ) :: & - entr - integer, dimension (its:ite) & - ,intent (in ) :: & - jmin - ! ierr error value, maybe modified in this routine - - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr,k22 -! local variables in this routine -! - - integer :: & - iall,i,k,nv,ki - real :: & - dh,qrch,c0,dz,radius - logical iaer (num_chem) - iaer = .false. - - if(p_so4aj.gt.1)iaer(p_so4aj) = .true. - if(p_nh4aj.gt.1)iaer(p_nh4aj) = .true. - if(p_no3aj.gt.1)iaer(p_no3aj) = .true. - -! - qrch=0. - do nv=1,num_chem - do k=kts+1,kte - do i=its,ite - tr_dd(i,k,nv)=0. - tr_pwd(i,k,nv)=0. - enddo - enddo - do i=its,ite - pwav(i,nv)=0. - IF(ierr(I).eq.0)then - do k=kts,ktf - pwav(i,nv)=pwav(i,nv)+tr_pw(i,k,nv) - enddo - endif - enddo - enddo -! -!--- in downdraft, do only transport of tracers, other -!--- than evaporation of part of the rainwater (see below) -! -! - do 100 i=its,ite - IF(ierr(I).eq.0)then -! -!--- assume no gas takeup by rain during falling -!--- for now -! -! - do nv=1,num_chem - tr_dd(i,jmin(i),nv)=tre_cup(i,jmin(i),nv) - enddo - do ki=jmin(i)-1,1,-1 - DZ=Z_cup(i,Ki+1)-Z_cup(i,Ki) - do nv=1,num_chem - tr_pwd(i,jmin(i),nv)=0. - tr_dd(i,Ki,nv)=(tr_dd(i,Ki+1,nv)*(1.-.5*CDD(i,Ki)*DZ) & - +entr*DZ*tracer(i,Ki,nv) & - )/(1.+entr*DZ-.5*CDD(i,Ki)*DZ) -! -!--- if tracer conserved -! - qrch=tr_dd(i,Ki,nv) -! -!--- part of dissolved liquid phase material that is being evaporated -! need percentage of rainwater that evaporates at level -! pwdper -! qcd=qcd+pwdper -! -! tr_pwd(i,ki,nv)=pwdper(i,ki)*pwav(i,nv) - if(iaer(nv))then - tr_pwd(i,ki,nv)=0. - else - tr_pwd(i,ki,nv)=pwdper(i,ki)*pwav(i,nv) - endif - tr_dd(i,ki,nv)=qrch+tr_pwd(i,ki,nv) - enddo -! -!--- end loop over nv - enddo - endif -100 continue - -END subroutine cup_dd_tracer - - - - - SUBROUTINE neg_check_ct(pret,ktop,epsilc,dt,q,outq,iopt,num_chem, & - its,ite,kts,kte,itf,ktf,ipr,jpr,npr,j) - - INTEGER, INTENT(IN ) :: iopt,num_chem,its,ite,kts,kte,itf,ktf,ipr,jpr,npr,j - - real, dimension (its:ite,kts:kte,num_chem ) , & - intent(inout ) :: & - q,outq - real, dimension (its:ite ) , & - intent(in ) :: & - pret - integer, dimension (its:ite ) , & - intent(in ) :: & - ktop - real & - ,intent (in ) :: & - dt,epsilc - real :: tracermin,tracermax,thresh,qmem,qmemf,qmem2,qtest,qmem1 -! -! check whether routine produces negative q's. This can happen, since -! tendencies are calculated based on forced q's. This should have no -! influence on conservation properties, it scales linear through all -! tendencies. Use iopt=0 to test for each tracer seperately, iopt=1 -! for a more severe limitation... -! - thresh=epsilc -! thresh=1.e-30 - if(iopt.eq.0)then - do nv=1,num_chem - do 100 i=its,itf - if(pret(i).le.0.)go to 100 - tracermin=q(i,kts,nv) - tracermax=q(i,kts,nv) - do k=kts+1,kte-1 - tracermin=min(tracermin,q(i,k,nv)) - tracermax=max(tracermax,q(i,k,nv)) - enddo - tracermin=max(tracermin,thresh) - qmemf=1. -! -! first check for minimum restriction -! - do k=kts,ktop(i) -! -! tracer tendency -! - qmem=outq(i,k,nv) -! -! only necessary if there is a tendency -! - if(qmem.lt.0.)then - qtest=q(i,k,nv)+outq(i,k,nv)*dt - if(qtest.lt.tracermin)then -! -! qmem2 would be the maximum allowable tendency -! - qmem1=outq(i,k,nv) - qmem2=(tracermin-q(i,k,nv))/dt - qmemf=min(qmemf,qmem2/qmem1) - if(qmemf.gt.1.)print *,'something wrong in negct_1',qmem2,qmem1 - if(i.eq.ipr.and.j.eq.jpr.and.nv.eq.npr)then - print *,k,qtest,qmem2,qmem1,qmemf - endif - qmemf=max(qmemf,0.) - endif - endif - enddo - do k=kts,ktop(i) - outq(i,k,nv)=outq(i,k,nv)*qmemf - enddo -! -! now check max -! - qmemf=1. - do k=kts,ktop(i) -! -! tracer tendency -! - qmem=outq(i,k,nv) -! -! only necessary if there is a tendency -! - if(qmem.gt.0.)then - qtest=q(i,k,nv)+outq(i,k,nv)*dt - if(qtest.gt.tracermax)then -! -! qmem2 would be the maximum allowable tendency -! - qmem1=outq(i,k,nv) - qmem2=(tracermax-q(i,k,nv))/dt - qmemf=min(qmemf,qmem2/qmem1) - if(qmemf.gt.1.)print *,'something wrong in negct_2',qmem2,qmem1 - if(i.eq.ipr.and.j.eq.jpr.and.nv.eq.npr)then - print *,'2',k,qtest,qmem2,qmem1,qmemf - endif - qmemf=max(qmemf,0.) - endif - endif - enddo - do k=kts,ktop(i) - outq(i,k,nv)=outq(i,k,nv)*qmemf - enddo - 100 continue - enddo -! -! ELSE -! - elseif(iopt.eq.1)then - do i=its,itf - qmemf=1. - do k=kts,ktop(i) - do nv=1,num_chem -! -! tracer tendency -! - qmem=outq(i,k,nv) -! -! only necessary if tendency is larger than zero -! - if(qmem.lt.0.)then - qtest=q(i,k,nv)+outq(i,k,nv)*dt - if(qtest.lt.thresh)then -! -! qmem2 would be the maximum allowable tendency -! - qmem1=outq(i,k,nv) - qmem2=(thresh-q(i,k,nv))/dt - qmemf=min(qmemf,qmem2/qmem1) - qmemf=max(0.,qmemf) - endif - endif - enddo - enddo - do nv=1,num_chem - do k=kts,ktop(i) - outq(i,k,nv)=outq(i,k,nv)*qmemf - enddo - enddo - enddo - endif - - END SUBROUTINE neg_check_ct - - -!------------------------------------------------------- -END MODULE module_ctrans_grell diff --git a/src/fim/FIMsrc/fim/column_chem/module_cu_g3.F90 b/src/fim/FIMsrc/fim/column_chem/module_cu_g3.F90 deleted file mode 100644 index 1de0c9c..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_cu_g3.F90 +++ /dev/null @@ -1,5256 +0,0 @@ -!WRF:MODEL_LAYER:PHYSICS -! - -MODULE module_cu_g3 - -CONTAINS - -!------------------------------------------------------------- - SUBROUTINE G3DRV( & - DT,itimestep,DX & - ,rho,RAINCV,PRATEC & - ,U,V,t,W,q,p,pi & - ,dz8w,p8w,XLV,CP,G,r_v & - ,STEPCU,htop,hbot & - ,CU_ACT_FLAG,warm_rain & - ,APR_GR,APR_W,APR_MC,APR_ST,APR_AS & - ,APR_CAPMA,APR_CAPME,APR_CAPMI & - ,MASS_FLUX,XF_ENS,PR_ENS,HT,XLAND,gsw,edt_out & - ,GDC,GDC2 & - ,cugd_tten,cugd_qvten ,cugd_qcten & - ,cugd_ttens,cugd_qvtens,cugd_avedx,imomentum & - ,ensdim,maxiens,maxens,maxens2,maxens3,ichoice & - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,ips,ipe, jps,jpe, kps,kpe & - ,its,ite, jts,jte, kts,kte & - ,periodic_x,periodic_y & - ,RQVCUTEN,RQCCUTEN,RQICUTEN & - ,RQVFTEN,RTHFTEN,RTHCUTEN & - ,RUCUTEN,RVCUTEN & - ,F_QV ,F_QC ,F_QR ,F_QI ,F_QS & - ) -!------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------- - INTEGER, INTENT(IN ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - ips,ipe, jps,jpe, kps,kpe, & - its,ite, jts,jte, kts,kte - LOGICAL periodic_x,periodic_y - integer, parameter :: ens4_spread = 3 ! max(3,cugd_avedx) - integer, parameter :: ens4=ens4_spread*ens4_spread - - integer, intent (in ) :: & - ensdim,maxiens,maxens,maxens2,maxens3,ichoice - - INTEGER, INTENT(IN ) :: STEPCU, ITIMESTEP,cugd_avedx,imomentum - LOGICAL, INTENT(IN ) :: warm_rain - - REAL, INTENT(IN ) :: XLV, R_v - REAL, INTENT(IN ) :: CP,G - - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & - INTENT(IN ) :: & - U, & - V, & - W, & - pi, & - t, & - q, & - p, & - dz8w, & - p8w, & - rho - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & - OPTIONAL , & - INTENT(INOUT ) :: & - GDC,GDC2 - - REAL, DIMENSION( ims:ime , jms:jme ),INTENT(IN) :: GSW,HT,XLAND -! - REAL, INTENT(IN ) :: DT, DX -! - - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(INOUT) :: pratec,RAINCV, MASS_FLUX, & - APR_GR,APR_W,APR_MC,APR_ST,APR_AS, & - edt_out,APR_CAPMA,APR_CAPME,APR_CAPMI,htop,hbot -!+lxz -! REAL, DIMENSION( ims:ime , jms:jme ) :: & !, INTENT(INOUT) :: & -! HTOP, &! highest model layer penetrated by cumulus since last reset in radiation_driver -! HBOT ! lowest model layer penetrated by cumulus since last reset in radiation_driver -! ! HBOT>HTOP follow physics leveling convention - - LOGICAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(INOUT) :: CU_ACT_FLAG - -! -! Optionals -! - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - OPTIONAL, & - INTENT(INOUT) :: RTHFTEN, & - cugd_tten,cugd_qvten,cugd_qcten, & - cugd_ttens,cugd_qvtens, & - RQVFTEN - - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - OPTIONAL, & - INTENT(INOUT) :: & - RTHCUTEN, & - RQVCUTEN, & - RQCCUTEN, & - RUCUTEN, & - RVCUTEN, & - RQICUTEN -! -! Flags relating to the optional tendency arrays declared above -! Models that carry the optional tendencies will provdide the -! optional arguments at compile time; these flags all the model -! to determine at run-time whether a particular tracer is in -! use or not. -! - LOGICAL, OPTIONAL :: & - F_QV & - ,F_QC & - ,F_QR & - ,F_QI & - ,F_QS - - - -! LOCAL VARS - real, dimension(ims:ime,jms:jme,1:ensdim),intent(inout) :: & - xf_ens,pr_ens - real, dimension ( its:ite , jts:jte , 1:ensdim) :: & - massflni,xfi_ens,pri_ens - REAL, DIMENSION( its:ite , jts:jte ) :: MASSI_FLX, & - APRi_GR,APRi_W,APRi_MC,APRi_ST,APRi_AS, & - edti_out,APRi_CAPMA,APRi_CAPME,APRi_CAPMI,gswi - real, dimension (its:ite,kts:kte) :: & - SUBT,SUBQ,OUTT,OUTQ,OUTQC,phh,subm,cupclw,outu,outv - real, dimension (its:ite,kts:kte+1) :: phf - real, dimension (its:ite) :: & - pret, ter11, aa0, fp,xlandi -!+lxz - integer, dimension (its:ite) :: & - kbcon, ktop -!.lxz - integer, dimension (its:ite,jts:jte) :: & - iact_old_gr - integer :: iens,ibeg,iend,jbeg,jend,n,nn,ens4n - integer :: ibegh,iendh,jbegh,jendh - integer :: ibegc,iendc,jbegc,jendc - -! -! basic environmental input includes moisture convergence (mconv) -! omega (omeg), windspeed (us,vs), and a flag (aaeq) to turn off -! convection for this call only and at that particular gridpoint -! - real, dimension (its:ite,kts:kte) :: & - T2d,q2d,PO,P2d,US,VS,tn,qo - real, dimension (ips-2:ipe+2,kps:kpe,jps-2:jpe+2) :: & - ave_f_t,ave_f_q - real, dimension (its:ite,kts:kte,1:ens4) :: & - omeg,tx,qx - real, dimension (its:ite) :: & - Z1,PSUR,AAEQ,direction,cuten,umean,vmean,pmean - real, dimension (its:ite,1:ens4) :: & - mconv - - INTEGER :: i,j,k,ICLDCK,ipr,jpr - REAL :: tcrit,dp,dq,sub_spread,subcenter - INTEGER :: itf,jtf,ktf,iss,jss,nbegin,nend - INTEGER :: high_resolution - REAL :: rkbcon,rktop !-lxz -! ruc variable - real, dimension (its:ite) :: tkm - - high_resolution=0 - if(cugd_avedx.gt.1) high_resolution=1 - subcenter=0. -! subcenter=1./float(cugd_avedx) - sub_spread=max(1.,float(cugd_avedx*cugd_avedx-1)) - sub_spread=(1.-subcenter)/sub_spread - iens=1 - ipr=37 - jpr=1 - ipr=0 - jpr=0 -! if(itimestep.eq.8)then -! ipr=37 -! jpr=16 -! endif - IF ( periodic_x ) THEN - ibeg=max(its,ids) - iend=min(ite,ide-1) - ibegc=max(its,ids) - iendc=min(ite,ide-1) - ELSE - ibeg=max(its,ids) - iend=min(ite,ide-1) - ibegc=max(its,ids+4) - iendc=min(ite,ide-5) - END IF - IF ( periodic_y ) THEN - jbeg=max(jts,jds) - jend=min(jte,jde-1) - jbegc=max(jts,jds) - jendc=min(jte,jde-1) - ELSE - jbeg=max(jts,jds) - jend=min(jte,jde-1) - jbegc=max(jts,jds+4) - jendc=min(jte,jde-5) - END IF - tcrit=258. - ave_f_t=0. - ave_f_q=0. - - itf=MIN(ite,ide) - ktf=MIN(kte,kde) - jtf=MIN(jte,jde) -! -#if ( EM_CORE == 1 ) - if(high_resolution.eq.1)then -! -! calculate these on the halo...the incominh tendencies have been exchanged on a 24pt halo -! only neede for high resolution run -! - ibegh=its - jbegh=jts - iendh=ite - jendh=jte - if(its.eq.ips)ibegh=max(its-1,ids) - if(jts.eq.jps)jbegh=max(jts-1,jds) - if(jte.eq.jpe)jendh=min(jte+1,jde-1) - if(ite.eq.ipe)iendh=min(ite+1,ide-1) - DO J = jbegh,jendh - DO k= kts,ktf - DO I= ibegh,iendh - ave_f_t(i,k,j)=(rthften(i-1,k,j-1)+rthften(i-1,k,j) + rthften(i-1,k,j+1)+ & - rthften(i,k,j-1) +rthften(i,k,j) +rthften(i,k,j+1)+ & - rthften(i+1,k,j-1) +rthften(i+1,k,j) +rthften(i+1,k,j+1))/9. - ave_f_q(i,k,j)=(rqvften(i-1,k,j-1)+rqvften(i-1,k,j) + rqvften(i-1,k,j+1)+ & - rqvften(i,k,j-1) +rqvften(i,k,j) +rqvften(i,k,j+1)+ & - rqvften(i+1,k,j-1) +rqvften(i+1,k,j) +rqvften(i+1,k,j+1))/9. -! ave_f_t(i,k,j)=rthften(i,k,j) -! ave_f_q(i,k,j)=rqvften(i,k,j) - ENDDO - ENDDO - ENDDO - endif -#endif - DO 100 J = jts,jtf - if(imomentum.eq.1)then - do k= kts,ktf - DO I= its,itf - outu(i,k)=0. - outv(i,k)=0. - ENDDO - ENDDO - endif - - DO n= 1,ensdim - DO I= its,itf - xfi_ens(i,j,n)=0. - pri_ens(i,j,n)=0. - ENDDO - ENDDO - DO I= its,itf - kbcon(i)=0 - ktop(i)=0 - tkm(i)=0. - iact_old_gr(i,j)=0 - mass_flux(i,j)=0. - massi_flx(i,j)=0. - raincv(i,j)=0. - pratec (i,j)=0. - edt_out(i,j)=0. - edti_out(i,j)=0. - gswi(i,j)=gsw(i,j) - xlandi(i)=xland(i,j) - APRi_GR(i,j)=apr_gr(i,j) - APRi_w(i,j)=apr_w(i,j) - APRi_mc(i,j)=apr_mc(i,j) - APRi_st(i,j)=apr_st(i,j) - APRi_as(i,j)=apr_as(i,j) - APRi_capma(i,j)=apr_capma(i,j) - APRi_capme(i,j)=apr_capme(i,j) - APRi_capmi(i,j)=apr_capmi(i,j) - CU_ACT_FLAG(i,j) = .true. - ENDDO - do k=kts,kte - DO I= its,itf - cugd_tten(i,k,j)=0. - cugd_ttens(i,k,j)=0. - cugd_qvten(i,k,j)=0. - cugd_qvtens(i,k,j)=0. - cugd_qcten(i,k,j)=0. - ENDDO - ENDDO - DO n=1,ens4 - DO I= its,itf - mconv(i,n)=0. - ENDDO - do k=kts,kte - DO I= its,itf - omeg(i,k,n)=0. - tx(i,k,n)=0. - qx(i,k,n)=0. - ENDDO - ENDDO - ENDDO - DO k=1,ensdim - DO I= its,itf - massflni(i,j,k)=0. - ENDDO - ENDDO -#if ( EM_CORE == 1 ) - ! hydrostatic pressure, first on full levels - DO I=ITS,ITF - phf(i,1) = p8w(i,1,j) - ENDDO - ! integrate up, dp = -rho * g * dz - DO K=kts+1,ktf+1 - DO I=ITS,ITF - phf(i,k) = phf(i,k-1) - rho(i,k-1,j) * g * dz8w(i,k-1,j) - ENDDO - ENDDO - ! scale factor so that pressure is not zero after integration - DO I=ITS,ITF - fp(i) = (p8w(i,kts,j)-p8w(i,kte,j))/(phf(i,kts)-phf(i,kte)) - ENDDO - ! re-integrate up, dp = -rho * g * dz * scale_factor - DO K=kts+1,ktf+1 - DO I=ITS,ITF - phf(i,k) = phf(i,k-1) - rho(i,k-1,j) * g * dz8w(i,k-1,j) * fp(i) - ENDDO - ENDDO - ! put hydrostatic pressure on half levels - DO K=kts,ktf - DO I=ITS,ITF - phh(i,k) = (phf(i,k) + phf(i,k+1))*0.5 - ENDDO - ENDDO - -#endif - DO I=ITS,ITF -#if ( EM_CORE == 1 ) - PSUR(I)=p8w(I,1,J)*.01 -#endif -#if ( NMM_CORE == 1 ) - PSUR(I)=p(I,1,J)*.01 -#endif -! PSUR(I)=p(I,1,J)*.01 - TER11(I)=HT(i,j) - aaeq(i)=0. - direction(i)=0. - pret(i)=0. - umean(i)=0. - vmean(i)=0. - pmean(i)=0. - ENDDO - DO K=kts,ktf - DO I=ITS,ITF -#if ( EM_CORE == 1 ) - po(i,k)=phh(i,k)*.01 -#endif - -#if ( NMM_CORE == 1 ) - po(i,k)=p(i,k,j)*.01 -#endif - subm(i,k)=0. - P2d(I,K)=PO(i,k) - US(I,K) =u(i,k,j) - VS(I,K) =v(i,k,j) - T2d(I,K)=t(i,k,j) - q2d(I,K)=q(i,k,j) - IF(Q2d(I,K).LT.1.E-08)Q2d(I,K)=1.E-08 - SUBT(I,K)=0. - SUBQ(I,K)=0. - OUTT(I,K)=0. - OUTQ(I,K)=0. - OUTQC(I,K)=0. - TN(I,K)=t2d(i,k)+RTHFTEN(i,k,j)*dt - QO(I,K)=q2d(i,k)+RQVFTEN(i,k,j)*dt - if(high_resolution.eq.1)then - TN(I,K)=t2d(i,k)+ave_f_t(i,k,j)*dt - QO(I,K)=q2d(i,k)+ave_f_q(i,k,j)*dt - endif - IF(TN(I,K).LT.200.)TN(I,K)=T2d(I,K) - IF(QO(I,K).LT.1.E-08)QO(I,K)=1.E-08 - ENDDO - ENDDO - ens4n=0 - nbegin=0 - nend=0 - if(ens4_spread.gt.1)then - nbegin=-ens4_spread/2 - nend=ens4_spread/2 - endif - do nn=nbegin,nend,1 - jss=max(j+nn,jds+0) - jss=min(jss,jde-1) - do n=nbegin,nend,1 - ens4n=ens4n+1 - DO K=kts,ktf - DO I=ITS,ITF - iss=max(i+n,ids+0) - iss=min(iss,ide-1) - omeg(I,K,ens4n)= -g*rho(i,k,j)*w(iss,k,jss) -! omeg(I,K,ens4n)= -g*rho(i,k,j)*w(i,k,j) - Tx(I,K,ens4n)=t2d(i,k)+RTHFTEN(iss,k,jss)*dt -! Tx(I,K,ens4n)=t2d(i,k)+RTHFTEN(i,k,j)*dt - if(high_resolution.eq.1)Tx(I,K,ens4n)=t2d(i,k)+ave_f_t(iss,k,jss)*dt - IF(Tx(I,K,ens4n).LT.200.)Tx(I,K,ens4n)=T2d(I,K) - Qx(I,K,ens4n)=q2d(i,k)+RQVFTEN(iss,k,jss)*dt - Qx(I,K,ens4n)=q2d(i,k)+RQVFTEN(i,k,j)*dt - if(high_resolution.eq.1)qx(I,K,ens4n)=q2d(i,k)+ave_f_q(iss,k,jss)*dt - IF(Qx(I,K,ens4n).LT.1.E-08)Qx(I,K,ens4n)=1.E-08 - enddo - enddo - enddo !n - enddo !nn - do k= kts+1,ktf-1 - DO I = its,itf - if((p2d(i,1)-p2d(i,k)).gt.150.and.p2d(i,k).gt.300)then - dp=-.5*(p2d(i,k+1)-p2d(i,k-1)) - umean(i)=umean(i)+us(i,k)*dp - vmean(i)=vmean(i)+vs(i,k)*dp - pmean(i)=pmean(i)+dp - endif - enddo - enddo - DO I = its,itf - umean(i)=umean(i)/pmean(i) - vmean(i)=vmean(i)/pmean(i) - direction(i)=(atan2(umean(i),vmean(i))+3.1415926)*57.29578 - if(direction(i).gt.360.)direction(i)=direction(i)-360. - ENDDO - do n=1,ens4 - DO K=kts,ktf-1 - DO I = its,itf - dq=(q2d(i,k+1)-q2d(i,k)) - mconv(i,n)=mconv(i,n)+omeg(i,k,n)*dq/g - enddo - ENDDO - ENDDO - do n=1,ens4 - DO I = its,itf - if(mconv(i,n).lt.0.)mconv(i,n)=0. - ENDDO - ENDDO -! -!---- CALL CUMULUS PARAMETERIZATION -! - CALL CUP_enss_3d(outqc,j,AAEQ,T2d,Q2d,TER11,subm,TN,QO,PO,PRET, & - P2d,OUTT,OUTQ,DT,itimestep,tkm,PSUR,US,VS,tcrit,iens,tx,qx, & - mconv,massflni,iact_old_gr,omeg,direction,MASSi_FLX, & - outu,outv,maxiens,maxens,maxens2,maxens3,ensdim, & - APRi_GR,APRi_W,APRi_MC,APRi_ST,APRi_AS, & - APRi_CAPMA,APRi_CAPME,APRi_CAPMI,kbcon,ktop,cupclw, & - xfi_ens,pri_ens,XLANDi,gswi,edti_out,subt,subq, & -! ruc lv_p,rv_p,cpd_p,g0_p,ichoice,ipr,jpr, & - xlv,r_v,cp,g,ichoice,ipr,jpr,ens4,high_resolution, & - itf,jtf,ktf,imomentum, & - its,ite, jts,jte, kts,kte ) - - - if(j.lt.jbegc.or.j.gt.jendc)go to 100 - DO I=ibegc,iendc - cuten(i)=0. - if(pret(i).gt.0.)then - cuten(i)=1. -! raincv(i,j)=pret(i)*dt - endif - ENDDO - DO I=ibegc,iendc - DO K=kts,ktf - cugd_ttens(I,K,J)=subt(i,k)*cuten(i)*sub_spread - cugd_qvtens(I,K,J)=subq(i,k)*cuten(i)*sub_spread - cugd_tten(I,K,J)=outt(i,k)*cuten(i) - cugd_qvten(I,K,J)=outq(i,k)*cuten(i) - cugd_qcten(I,K,J)=outqc(i,k)*cuten(i) - ENDDO - ENDDO - DO I=ibegc,iendc - if(pret(i).gt.0.)then - raincv(i,j)=pret(i)*dt - pratec(i,j)=pret(i) - rkbcon = kte+kts - kbcon(i) - rktop = kte+kts - ktop(i) - if (ktop(i) > HTOP(i,j)) HTOP(i,j) = ktop(i)+.001 - if (kbcon(i) < HBOT(i,j)) HBOT(i,j) = kbcon(i)+.001 - endif - ENDDO - DO n= 1,ensdim - DO I= ibegc,iendc - xf_ens(i,j,n)=xfi_ens(i,j,n) - pr_ens(i,j,n)=pri_ens(i,j,n) - ENDDO - ENDDO - DO I= ibegc,iendc - APR_GR(i,j)=apri_gr(i,j) - APR_w(i,j)=apri_w(i,j) - APR_mc(i,j)=apri_mc(i,j) - APR_st(i,j)=apri_st(i,j) - APR_as(i,j)=apri_as(i,j) - APR_capma(i,j)=apri_capma(i,j) - APR_capme(i,j)=apri_capme(i,j) - APR_capmi(i,j)=apri_capmi(i,j) - mass_flux(i,j)=massi_flx(i,j) - edt_out(i,j)=edti_out(i,j) - ENDDO - if(imomentum.eq.1.and.high_resolution.eq.0)then - IF(PRESENT(RUCUTEN)) THEN - DO K=kts,ktf - DO I=ibegc,iendc - RUCUTEN(i,k,j)=outu(i,k)*cuten(i) - ENDDO - ENDDO - ENDIF - IF(PRESENT(RUCUTEN)) THEN - DO K=kts,ktf - DO I=ibegc,iendc - RVCUTEN(i,k,j)=outv(i,k)*cuten(i) - ENDDO - ENDDO - ENDIF - ELSE IF (imomentum.eq.1.and.high_resolution.eq.1)then -! CALL wrf_error_fatal('Do not run this option with high resolution option') - stop - ENDIF - IF(PRESENT(RQCCUTEN)) THEN - IF ( F_QC ) THEN - DO K=kts,ktf - DO I=ibegc,iendc - RQCCUTEN(I,K,J)=outqc(I,K)*cuten(i) - IF ( PRESENT( GDC ) ) GDC(I,K,J)=CUPCLW(I,K)*cuten(i) - IF ( PRESENT( GDC2 ) ) GDC2(I,K,J)=0. - ENDDO - ENDDO - ENDIF - ENDIF - -!...... QSTEN STORES GRAUPEL TENDENCY IF IT EXISTS, OTHERISE SNOW (V2) - - IF(PRESENT(RQICUTEN).AND.PRESENT(RQCCUTEN))THEN - IF (F_QI) THEN - DO K=kts,ktf - DO I=ibegc,iendc - if(t2d(i,k).lt.258.)then - RQICUTEN(I,K,J)=outqc(I,K)*cuten(i) - cugd_qcten(i,k,j)=0. - RQCCUTEN(I,K,J)=0. - IF ( PRESENT( GDC2 ) ) GDC2(I,K,J)=CUPCLW(I,K)*cuten(i) - else - RQICUTEN(I,K,J)=0. - RQCCUTEN(I,K,J)=outqc(I,K)*cuten(i) - IF ( PRESENT( GDC ) ) GDC(I,K,J)=CUPCLW(I,K)*cuten(i) - endif - ENDDO - ENDDO - ENDIF - ENDIF - - 100 continue - - END SUBROUTINE G3DRV - - SUBROUTINE CUP_enss_3d(OUTQC,J,AAEQ,T,Q,Z1,sub_mas, & - TN,QO,PO,PRE,P,OUTT,OUTQ,DTIME,ktau,tkmax,PSUR,US,VS, & - TCRIT,iens,tx,qx,mconv,massfln,iact, & - omeg,direction,massflx,outu,outv,maxiens, & - maxens,maxens2,maxens3,ensdim, & - APR_GR,APR_W,APR_MC,APR_ST,APR_AS, & - APR_CAPMA,APR_CAPME,APR_CAPMI,kbcon,ktop,cupclw, & !-lxz - xf_ens,pr_ens,xland,gsw,edt_out,subt,subq, & - xl,rv,cp,g,ichoice,ipr,jpr,ens4,high_resolution, & - itf,jtf,ktf,imomentum, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE - - integer & - ,intent (in ) :: & - itf,jtf,ktf,ktau,imomentum, & - its,ite, jts,jte, kts,kte,ipr,jpr,ens4,high_resolution - integer, intent (in ) :: & - j,ensdim,maxiens,maxens,maxens2,maxens3,ichoice,iens - ! - ! - ! - real, dimension (its:ite,jts:jte,1:ensdim) & - ,intent (inout) :: & - massfln,xf_ens,pr_ens - real, dimension (its:ite,jts:jte) & - ,intent (inout ) :: & - APR_GR,APR_W,APR_MC,APR_ST,APR_AS,APR_CAPMA, & - APR_CAPME,APR_CAPMI,massflx,edt_out - real, dimension (its:ite,jts:jte) & - ,intent (in ) :: & - gsw - integer, dimension (its:ite,jts:jte) & - ,intent (in ) :: & - iact - ! outtem = output temp tendency (per s) - ! outq = output q tendency (per s) - ! outqc = output qc tendency (per s) - ! pre = output precip - real, dimension (its:ite,kts:kte) & - ,intent (inout ) :: & - OUTT,OUTQ,OUTQC,subt,subq,sub_mas,cupclw,outu,outv - real, dimension (its:ite) & - ,intent (out ) :: & - pre -!+lxz - integer, dimension (its:ite) & - ,intent (out ) :: & - kbcon,ktop -!.lxz - ! - ! basic environmental input includes moisture convergence (mconv) - ! omega (omeg), windspeed (us,vs), and a flag (aaeq) to turn off - ! convection for this call only and at that particular gridpoint - ! - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - T,PO,P,US,VS,tn - real, dimension (its:ite,kts:kte,1:ens4) & - ,intent (inout ) :: & - omeg,tx,qx - real, dimension (its:ite,kts:kte) & - ,intent (inout) :: & - Q,QO - real, dimension (its:ite) & - ,intent (in ) :: & - Z1,PSUR,AAEQ,direction,tkmax,xland - real, dimension (its:ite,1:ens4) & - ,intent (in ) :: & - mconv - - - real & - ,intent (in ) :: & - dtime,tcrit,xl,cp,rv,g - - -! -! local ensemble dependent variables in this routine -! - real, dimension (its:ite,1:maxens) :: & - xaa0_ens - real, dimension (1:maxens) :: & - mbdt_ens - real, dimension (1:maxens2) :: & - edt_ens - real, dimension (its:ite,1:maxens2) :: & - edtc - real, dimension (its:ite,kts:kte,1:maxens2) :: & - dellat_ens,dellaqc_ens,dellaq_ens,pwo_ens,subt_ens,subq_ens -! -! -! -!***************** the following are your basic environmental -! variables. They carry a "_cup" if they are -! on model cloud levels (staggered). They carry -! an "o"-ending (z becomes zo), if they are the forced -! variables. They are preceded by x (z becomes xz) -! to indicate modification by some typ of cloud -! - ! z = heights of model levels - ! q = environmental mixing ratio - ! qes = environmental saturation mixing ratio - ! t = environmental temp - ! p = environmental pressure - ! he = environmental moist static energy - ! hes = environmental saturation moist static energy - ! z_cup = heights of model cloud levels - ! q_cup = environmental q on model cloud levels - ! qes_cup = saturation q on model cloud levels - ! t_cup = temperature (Kelvin) on model cloud levels - ! p_cup = environmental pressure - ! he_cup = moist static energy on model cloud levels - ! hes_cup = saturation moist static energy on model cloud levels - ! gamma_cup = gamma on model cloud levels -! -! - ! hcd = moist static energy in downdraft - ! zd normalized downdraft mass flux - ! dby = buoancy term - ! entr = entrainment rate - ! zd = downdraft normalized mass flux - ! entr= entrainment rate - ! hcd = h in model cloud - ! bu = buoancy term - ! zd = normalized downdraft mass flux - ! gamma_cup = gamma on model cloud levels - ! mentr_rate = entrainment rate - ! qcd = cloud q (including liquid water) after entrainment - ! qrch = saturation q in cloud - ! pwd = evaporate at that level - ! pwev = total normalized integrated evaoprate (I2) - ! entr= entrainment rate - ! z1 = terrain elevation - ! entr = downdraft entrainment rate - ! jmin = downdraft originating level - ! kdet = level above ground where downdraft start detraining - ! psur = surface pressure - ! z1 = terrain elevation - ! pr_ens = precipitation ensemble - ! xf_ens = mass flux ensembles - ! massfln = downdraft mass flux ensembles used in next timestep - ! omeg = omega from large scale model - ! mconv = moisture convergence from large scale model - ! zd = downdraft normalized mass flux - ! zu = updraft normalized mass flux - ! dir = "storm motion" - ! mbdt = arbitrary numerical parameter - ! dtime = dt over which forcing is applied - ! iact_gr_old = flag to tell where convection was active - ! kbcon = LFC of parcel from k22 - ! k22 = updraft originating level - ! icoic = flag if only want one closure (usually set to zero!) - ! dby = buoancy term - ! ktop = cloud top (output) - ! xmb = total base mass flux - ! hc = cloud moist static energy - ! hkb = moist static energy at originating level - ! mentr_rate = entrainment rate - - real, dimension (its:ite,kts:kte) :: & - he,hes,qes,z, & - heo,heso,qeso,zo, & - xhe,xhes,xqes,xz,xt,xq, & - - qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup, & - qeso_cup,qo_cup,heo_cup,heso_cup,zo_cup,po_cup,gammao_cup, & - tn_cup, & - xqes_cup,xq_cup,xhe_cup,xhes_cup,xz_cup,xp_cup,xgamma_cup, & - xt_cup, & - - dby,qc,qrcd,pwd,pw,hcd,qcd,dbyd,hc,qrc,zu,zd,clw_all, & - dbyo,qco,qrcdo,pwdo,pwo,hcdo,qcdo,dbydo,hco,qrco,zuo,zdo, & - xdby,xqc,xqrcd,xpwd,xpw,xhcd,xqcd,xhc,xqrc,xzu,xzd, & - - ! cd = detrainment function for updraft - ! cdd = detrainment function for downdraft - ! dellat = change of temperature per unit mass flux of cloud ensemble - ! dellaq = change of q per unit mass flux of cloud ensemble - ! dellaqc = change of qc per unit mass flux of cloud ensemble - - cd,cdd,scr1,DELLAH,DELLAQ,DELLAT,DELLAQC,dsubt,dsubq -! -! following for momentum transport if needed -! - real, dimension (its:ite,kts:kte) :: & - uc,vc,ucd,vcd,u_cup,v_cup,dellau,dellav,ukb,vkb - - - ! aa0 cloud work function for downdraft - ! edt = epsilon - ! aa0 = cloud work function without forcing effects - ! aa1 = cloud work function with forcing effects - ! xaa0 = cloud work function with cloud effects (ensemble dependent) - ! edt = epsilon - real, dimension (its:ite) :: & - edt,edto,edtx,AA1,AA0,XAA0,HKB,HKBO,aad,XHKB,QKB,QKBO, & - XMB,XPWAV,XPWEV,PWAV,PWEV,PWAVO,PWEVO,BU,BUO,cap_max,xland1, & - cap_max_increment,closure_n - real, dimension (its:ite,1:ens4) :: & - axx - integer, dimension (its:ite) :: & - kzdown,KDET,K22,KB,JMIN,kstabi,kstabm,K22x, & !-lxz - KBCONx,KBx,KTOPx,ierr,ierr2,ierr3,KBMAX - - integer :: & - nall,iedt,nens,nens3,ki,I,K,KK,iresult - real :: & - day,dz,mbdt,entr_rate,radius,entrd_rate,mentr_rate,mentrd_rate, & - zcutdown,edtmax,edtmin,depth_min,zkbmax,z_detr,zktop, & - massfld,dh,cap_maxs,trash - - integer :: jmini - logical :: keep_going - - - - day=86400. - do i=its,itf - closure_n(i)=16. - xland1(i)=1. - if(xland(i).gt.1.5)xland1(i)=0. -! cap_max_increment(i)=50. - cap_max_increment(i)=25. - enddo -! -!--- specify entrainmentrate and detrainmentrate -! - if(iens.le.4)then - radius=14000.-float(iens)*2000. - else - radius=12000. - endif -! -!--- gross entrainment rate (these may be changed later on in the -!--- program, depending what your detrainment is!!) -! - entr_rate=.2/radius -! -!--- entrainment of mass -! - mentrd_rate=0. - mentr_rate=entr_rate -! -!--- initial detrainmentrates -! - do k=kts,ktf - do i=its,itf - cupclw(i,k)=0. - cd(i,k)=0.01*entr_rate - cdd(i,k)=0. - enddo - enddo -! -!--- max/min allowed value for epsilon (ratio downdraft base mass flux/updraft -! base mass flux -! - edtmax=1. - edtmin=.2 -! -!--- minimum depth (m), clouds must have -! - depth_min=500. -! -!--- maximum depth (mb) of capping -!--- inversion (larger cap = no convection) -! -! cap_maxs=125. - cap_maxs=75. - DO i=its,itf - kbmax(i)=1 - aa0(i)=0. - aa1(i)=0. - aad(i)=0. - edt(i)=0. - kstabm(i)=ktf-1 - IERR(i)=0 - IERR2(i)=0 - IERR3(i)=0 - if(aaeq(i).lt.-0.1)then - ierr(i)=20 - endif - enddo -! -!--- first check for upstream convection -! - do i=its,itf - cap_max(i)=cap_maxs - if(gsw(i,j).lt.1.or.high_resolution.eq.1)cap_max(i)=25. - iresult=0 - - enddo -! -!--- max height(m) above ground where updraft air can originate -! - zkbmax=4000. -! -!--- height(m) above which no downdrafts are allowed to originate -! - zcutdown=3000. -! -!--- depth(m) over which downdraft detrains all its mass -! - z_detr=1250. -! - do nens=1,maxens - mbdt_ens(nens)=(float(nens)-3.)*dtime*1.e-3+dtime*5.E-03 - enddo - do nens=1,maxens2 - edt_ens(nens)=.95-float(nens)*.01 - enddo -! -!--- environmental conditions, FIRST HEIGHTS -! - do i=its,itf - if(ierr(i).ne.20)then - do k=1,maxens*maxens2*maxens3 - xf_ens(i,j,(iens-1)*maxens*maxens2*maxens3+k)=0. - pr_ens(i,j,(iens-1)*maxens*maxens2*maxens3+k)=0. - enddo - endif - enddo -! -!--- calculate moist static energy, heights, qes -! - call cup_env(z,qes,he,hes,t,q,p,z1, & - psur,ierr,tcrit,0,xl,cp, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - call cup_env(zo,qeso,heo,heso,tn,qo,po,z1, & - psur,ierr,tcrit,0,xl,cp, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) -! -!--- environmental values on cloud levels -! - call cup_env_clev(t,qes,q,he,hes,z,p,qes_cup,q_cup,he_cup, & - hes_cup,z_cup,p_cup,gamma_cup,t_cup,psur, & - ierr,z1,xl,rv,cp, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - if(imomentum.eq.1)then - call cup_env_clev_uv(us,vs,u_cup,v_cup,ierr, & - its,ite, jts,jte, kts,kte, itf,ktf) - endif - call cup_env_clev(tn,qeso,qo,heo,heso,zo,po,qeso_cup,qo_cup, & - heo_cup,heso_cup,zo_cup,po_cup,gammao_cup,tn_cup,psur, & - ierr,z1,xl,rv,cp, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - do i=its,itf - if(ierr(i).eq.0)then -! - do k=kts,ktf - if(zo_cup(i,k).gt.zkbmax+z1(i))then - kbmax(i)=k - go to 25 - endif - enddo - 25 continue -! -!--- level where detrainment for downdraft starts -! - do k=kts,ktf - if(zo_cup(i,k).gt.z_detr+z1(i))then - kdet(i)=k - go to 26 - endif - enddo - 26 continue -! - endif - enddo -! -! -! -!------- DETERMINE LEVEL WITH HIGHEST MOIST STATIC ENERGY CONTENT - K22 -! - CALL cup_MAXIMI(HEO_CUP,3,KBMAX,K22,ierr, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - DO 36 i=its,itf - IF(ierr(I).eq.0.)THEN - IF(K22(I).GE.KBMAX(i))ierr(i)=2 - endif - 36 CONTINUE -! -!--- DETERMINE THE LEVEL OF CONVECTIVE CLOUD BASE - KBCON -! - call cup_kbcon(cap_max_increment,1,k22,kbcon,heo_cup,heso_cup, & - ierr,kbmax,po_cup,cap_max, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) -! -!--- increase detrainment in stable layers -! - CALL cup_minimi(HEso_cup,Kbcon,kstabm,kstabi,ierr, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - do i=its,itf - IF(ierr(I).eq.0.)THEN - if(kstabm(i)-1.gt.kstabi(i))then - do k=kstabi(i),kstabm(i)-1 - cd(i,k)=cd(i,k-1)+.15*entr_rate - if(cd(i,k).gt.1.0*entr_rate)cd(i,k)=1.0*entr_rate - enddo - ENDIF - ENDIF - ENDDO -! -!--- calculate incloud moist static energy -! - call cup_up_he(k22,hkb,z_cup,cd,mentr_rate,he_cup,hc, & - kbcon,ierr,dby,he,hes_cup, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - call cup_up_he(k22,hkbo,zo_cup,cd,mentr_rate,heo_cup,hco, & - kbcon,ierr,dbyo,heo,heso_cup, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - -!--- DETERMINE CLOUD TOP - KTOP -! - call cup_ktop(1,dbyo,kbcon,ktop,ierr, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - DO 37 i=its,itf - kzdown(i)=0 - if(ierr(i).eq.0)then - zktop=(zo_cup(i,ktop(i))-z1(i))*.6 - zktop=min(zktop+z1(i),zcutdown+z1(i)) - do k=kts,kte - if(zo_cup(i,k).gt.zktop)then - kzdown(i)=k - go to 37 - endif - enddo - endif - 37 CONTINUE -! -!--- DOWNDRAFT ORIGINATING LEVEL - JMIN -! - call cup_minimi(HEso_cup,K22,kzdown,JMIN,ierr, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - DO 100 i=its,ite - IF(ierr(I).eq.0.)THEN -! -!--- check whether it would have buoyancy, if there where -!--- no entrainment/detrainment -! - jmini = jmin(i) - keep_going = .TRUE. - do while ( keep_going ) - keep_going = .FALSE. - if ( jmini - 1 .lt. kdet(i) ) kdet(i) = jmini-1 - if ( jmini .ge. ktop(i)-1 ) jmini = ktop(i) - 2 - ki = jmini - hcdo(i,ki)=heso_cup(i,ki) - DZ=Zo_cup(i,Ki+1)-Zo_cup(i,Ki) - dh=0. - do k=ki-1,1,-1 - hcdo(i,k)=heso_cup(i,jmini) - DZ=Zo_cup(i,K+1)-Zo_cup(i,K) - dh=dh+dz*(HCDo(i,K)-heso_cup(i,k)) - if(dh.gt.0.)then - jmini=jmini-1 - if ( jmini .gt. 3 ) then - keep_going = .TRUE. - else - ierr(i) = 9 - exit - endif - endif - enddo - enddo - jmin(i) = jmini - if ( jmini .le. 3 ) then - ierr(i)=4 - endif - ENDIF -100 continue -! -! - Must have at least depth_min m between cloud convective base -! and cloud top. -! - do i=its,itf - IF(ierr(I).eq.0.)THEN - IF(-zo_cup(I,KBCON(I))+zo_cup(I,KTOP(I)).LT.depth_min)then - ierr(i)=6 - endif - endif - enddo - -! -!c--- normalized updraft mass flux profile -! - call cup_up_nms(zu,z_cup,mentr_rate,cd,kbcon,ktop,ierr,k22, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - call cup_up_nms(zuo,zo_cup,mentr_rate,cd,kbcon,ktop,ierr,k22, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) -! -!c--- normalized downdraft mass flux profile,also work on bottom detrainment -!--- in this routine -! - call cup_dd_nms(zd,z_cup,cdd,mentrd_rate,jmin,ierr, & - 0,kdet,z1, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - call cup_dd_nms(zdo,zo_cup,cdd,mentrd_rate,jmin,ierr, & - 1,kdet,z1, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) -! -!--- downdraft moist static energy -! - call cup_dd_he(hes_cup,zd,hcd,z_cup,cdd,mentrd_rate, & - jmin,ierr,he,dbyd,he_cup, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - call cup_dd_he(heso_cup,zdo,hcdo,zo_cup,cdd,mentrd_rate, & - jmin,ierr,heo,dbydo,he_cup,& - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) -! for momenum we only need to do this once!!! - if(imomentum.eq.1)then - call cup_up_uv(k22,ukb,vkb,zo_cup,cd,cdd,mentr_rate, & - mentrd_rate,vcd,ucd,jmin,u_cup, & - v_cup,uc,vc,kbcon,ierr,us,vs, & - its,ite, jts,jte, kts,kte, itf,ktf ) - endif -! -!--- calculate moisture properties of downdraft -! - call cup_dd_moisture_3d(zd,hcd,hes_cup,qcd,qes_cup, & - pwd,q_cup,z_cup,cdd,mentrd_rate,jmin,ierr,gamma_cup, & - pwev,bu,qrcd,q,he,t_cup,2,xl,high_resolution, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - call cup_dd_moisture_3d(zdo,hcdo,heso_cup,qcdo,qeso_cup, & - pwdo,qo_cup,zo_cup,cdd,mentrd_rate,jmin,ierr,gammao_cup, & - pwevo,bu,qrcdo,qo,heo,tn_cup,1,xl,high_resolution, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) -! -!--- calculate moisture properties of updraft -! - call cup_up_moisture(ierr,z_cup,qc,qrc,pw,pwav, & - kbcon,ktop,cd,dby,mentr_rate,clw_all, & - q,GAMMA_cup,zu,qes_cup,k22,q_cup,xl, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - do k=kts,ktf - do i=its,itf - cupclw(i,k)=qrc(i,k) - enddo - enddo - call cup_up_moisture(ierr,zo_cup,qco,qrco,pwo,pwavo, & - kbcon,ktop,cd,dbyo,mentr_rate,clw_all, & - qo,GAMMAo_cup,zuo,qeso_cup,k22,qo_cup,xl,& - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) -! -!--- calculate workfunctions for updrafts -! - call cup_up_aa0(aa0,z,zu,dby,GAMMA_CUP,t_cup, & - kbcon,ktop,ierr, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - call cup_up_aa0(aa1,zo,zuo,dbyo,GAMMAo_CUP,tn_cup, & - kbcon,ktop,ierr, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - do i=its,itf - if(ierr(i).eq.0)then - if(aa1(i).eq.0.)then - ierr(i)=17 - endif - endif - enddo - call cup_axx(tcrit,kbmax,z1,p,psur,xl,rv,cp,tx,qx,axx,ierr, & - cap_max,cap_max_increment,entr_rate,mentr_rate,& - j,itf,jtf,ktf, & - its,ite, jts,jte, kts,kte,ens4) - -! -!--- DETERMINE DOWNDRAFT STRENGTH IN TERMS OF WINDSHEAR -! - call cup_dd_edt(ierr,us,vs,zo,ktop,kbcon,edt,po,pwavo, & - pwevo,edtmax,edtmin,maxens2,edtc, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - do 250 iedt=1,maxens2 - do i=its,itf - if(ierr(i).eq.0)then - edt(i)=edtc(i,iedt) - edto(i)=edtc(i,iedt) - edtx(i)=edtc(i,iedt) - edt_out(i,j)=edtc(i,2) - if(high_resolution.eq.1)then - edt(i)=edtc(i,3) - edto(i)=edtc(i,3) - edtx(i)=edtc(i,3) - edt_out(i,j)=edtc(i,3) - endif - endif - enddo - do k=kts,ktf - do i=its,itf - subt_ens(i,k,iedt)=0. - subq_ens(i,k,iedt)=0. - dellat_ens(i,k,iedt)=0. - dellaq_ens(i,k,iedt)=0. - dellaqc_ens(i,k,iedt)=0. - pwo_ens(i,k,iedt)=0. - enddo - enddo -! - if(j.eq.jpr.and.iedt.eq.1.and.ipr.gt.its.and.ipr.lt.ite)then -! if(j.eq.jpr)then - i=ipr -! write(0,*)'in 250 loop ',iedt,edt(ipr),ierr(ipr) -! if(ierr(i).eq.0.or.ierr(i).eq.3)then - write(0,*)'250',k22(I),kbcon(i),ktop(i),jmin(i) - write(0,*)edt(i),aa0(i),aa1(i) - do k=kts,ktf - write(0,*)k,z(i,k),he(i,k),hes(i,k) - enddo - write(0,*)'end 250 loop ',iedt,edt(ipr),ierr(ipr) - do k=1,ktop(i)+1 - write(0,*)zu(i,k),zd(i,k),pw(i,k),pwd(i,k) - enddo -! endif - endif - do i=its,itf - aad(i)=0. - enddo -! -!--- change per unit mass that a model cloud would modify the environment -! -!--- 1. in bottom layer -! - call cup_dellabot(ipr,jpr,heo_cup,ierr,zo_cup,po,hcdo,edto, & - zdo,cdd,heo,dellah,dsubt,j,mentrd_rate,zo,g, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - call cup_dellabot(ipr,jpr,qo_cup,ierr,zo_cup,po,qrcdo,edto, & - zdo,cdd,qo,dellaq,dsubq,j,mentrd_rate,zo,g,& - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - if(imomentum.eq.1)then - call cup_dellabotuv(ipr,jpr,u_cup,v_cup,ierr,zo_cup,po,ucd,vcd,edto, & - zdo,cdd,us,vs,dellau,dellav,j,mentrd_rate,zo,g,& - its,ite, jts,jte, kts,kte, itf,ktf) - endif - -! -!--- 2. everywhere else -! - call cup_dellas_3d(ierr,zo_cup,po_cup,hcdo,edto,zdo,cdd, & - heo,dellah,dsubt,j,mentrd_rate,zuo,g, & - cd,hco,ktop,k22,kbcon,mentr_rate,jmin,heo_cup,kdet, & - k22,ipr,jpr,'deep',high_resolution, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - if(imomentum.eq.1)then - call cup_dellasuv(ierr,zo_cup,po_cup,ucd,vcd,edto,zdo,cdd, & - us,vs,dellau,dellav,j,mentrd_rate,zuo,g, & - cd,uc,vc,ktop,k22,kbcon,mentr_rate,jmin,u_cup, & - v_cup,kdet,k22,ipr,jpr,'deep', & - its,ite, jts,jte, kts,kte, itf,ktf ) - endif -! -!-- take out cloud liquid water for detrainment -! -!?? do k=kts,ktf - do k=kts,ktf-1 - do i=its,itf - scr1(i,k)=0. - dellaqc(i,k)=0. - if(ierr(i).eq.0)then - scr1(i,k)=qco(i,k)-qrco(i,k) - if(k.eq.ktop(i)-0)dellaqc(i,k)= & - .01*zuo(i,ktop(i))*qrco(i,ktop(i))* & - 9.81/(po_cup(i,k)-po_cup(i,k+1)) - if(k.lt.ktop(i).and.k.gt.kbcon(i))then - dz=zo_cup(i,k+1)-zo_cup(i,k) - dellaqc(i,k)=.01*9.81*cd(i,k)*dz*zuo(i,k) & - *.5*(qrco(i,k)+qrco(i,k+1))/ & - (po_cup(i,k)-po_cup(i,k+1)) - endif - endif - enddo - enddo - call cup_dellas_3d(ierr,zo_cup,po_cup,qrcdo,edto,zdo,cdd, & - qo,dellaq,dsubq,j,mentrd_rate,zuo,g, & - cd,qco,ktop,k22,kbcon,mentr_rate,jmin,qo_cup,kdet, & - k22,ipr,jpr,'deep',high_resolution, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte ) -! -!--- using dellas, calculate changed environmental profiles -! -! do 200 nens=1,maxens - mbdt=mbdt_ens(2) - do i=its,itf - xaa0_ens(i,1)=0. - xaa0_ens(i,2)=0. - xaa0_ens(i,3)=0. - enddo - - if(j.eq.jpr)then - write(0,*)'xt',xl,'DELLAH(I,K),DELLAQ(I,K),dsubq(I,K),dsubt(i,k)' - endif - do k=kts,ktf - do i=its,itf - dellat(i,k)=0. - if(ierr(i).eq.0)then - trash=dsubt(i,k) - XHE(I,K)=(dsubt(i,k)+DELLAH(I,K))*MBDT+HEO(I,K) - XQ(I,K)=(dsubq(i,k)+DELLAQ(I,K))*MBDT+QO(I,K) - DELLAT(I,K)=(1./cp)*(DELLAH(I,K)-xl*DELLAQ(I,K)) - dSUBT(I,K)=(1./cp)*(dsubt(i,k)-xl*dsubq(i,k)) - XT(I,K)= (DELLAT(I,K)+dsubt(i,k))*MBDT+TN(I,K) - IF(XQ(I,K).LE.0.)XQ(I,K)=1.E-08 - if(i.eq.ipr.and.j.eq.jpr)then - write(0,*)k,trash,DELLAQ(I,K),dsubq(I,K),dsubt(i,k) - endif - ENDIF - enddo - enddo - do i=its,itf - if(ierr(i).eq.0)then - XHE(I,ktf)=HEO(I,ktf) - XQ(I,ktf)=QO(I,ktf) - XT(I,ktf)=TN(I,ktf) - IF(XQ(I,ktf).LE.0.)XQ(I,ktf)=1.E-08 - endif - enddo -! -!--- calculate moist static energy, heights, qes -! - call cup_env(xz,xqes,xhe,xhes,xt,xq,po,z1, & - psur,ierr,tcrit,2,xl,cp, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) -! -!--- environmental values on cloud levels -! - call cup_env_clev(xt,xqes,xq,xhe,xhes,xz,po,xqes_cup,xq_cup, & - xhe_cup,xhes_cup,xz_cup,po_cup,gamma_cup,xt_cup,psur, & - ierr,z1,xl,rv,cp, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) -! -! -!**************************** static control -! -!--- moist static energy inside cloud -! - do i=its,itf - if(ierr(i).eq.0)then - xhkb(i)=xhe(i,k22(i)) - endif - enddo - call cup_up_he(k22,xhkb,xz_cup,cd,mentr_rate,xhe_cup,xhc, & - kbcon,ierr,xdby,xhe,xhes_cup, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) -! -!c--- normalized mass flux profile -! - call cup_up_nms(xzu,xz_cup,mentr_rate,cd,kbcon,ktop,ierr,k22, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) -! -!--- moisture downdraft -! - call cup_dd_nms(xzd,xz_cup,cdd,mentrd_rate,jmin,ierr, & - 1,kdet,z1, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - call cup_dd_he(xhes_cup,xzd,xhcd,xz_cup,cdd,mentrd_rate, & - jmin,ierr,xhe,dbyd,xhe_cup,& - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - call cup_dd_moisture_3d(xzd,xhcd,xhes_cup,xqcd,xqes_cup, & - xpwd,xq_cup,xz_cup,cdd,mentrd_rate,jmin,ierr,gamma_cup, & - xpwev,bu,xqrcd,xq,xhe,xt_cup,3,xl,high_resolution, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - -! -!------- MOISTURE updraft -! - call cup_up_moisture(ierr,xz_cup,xqc,xqrc,xpw,xpwav, & - kbcon,ktop,cd,xdby,mentr_rate,clw_all, & - xq,GAMMA_cup,xzu,xqes_cup,k22,xq_cup,xl, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) -! -!--- workfunctions for updraft -! - call cup_up_aa0(xaa0,xz,xzu,xdby,GAMMA_CUP,xt_cup, & - kbcon,ktop,ierr, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - do 200 nens=1,maxens - do i=its,itf - if(ierr(i).eq.0)then - xaa0_ens(i,nens)=xaa0(i) - nall=(iens-1)*maxens3*maxens*maxens2 & - +(iedt-1)*maxens*maxens3 & - +(nens-1)*maxens3 - do k=kts,ktf - if(k.le.ktop(i))then - do nens3=1,maxens3 - if(nens3.eq.7)then -!--- b=0 - pr_ens(i,j,nall+nens3)=pr_ens(i,j,nall+nens3) & - +edto(i)*pwdo(i,k) & - +pwo(i,k) -!--- b=beta - else if(nens3.eq.8)then - pr_ens(i,j,nall+nens3)=pr_ens(i,j,nall+nens3)+ & - pwo(i,k) -!--- b=beta/2 - else if(nens3.eq.9)then - pr_ens(i,j,nall+nens3)=pr_ens(i,j,nall+nens3) & - +.5*edto(i)*pwdo(i,k) & - + pwo(i,k) - else - pr_ens(i,j,nall+nens3)=pr_ens(i,j,nall+nens3)+ & - pwo(i,k)+edto(i)*pwdo(i,k) - endif - enddo - endif - enddo - if(pr_ens(i,j,nall+7).lt.1.e-6)then - ierr(i)=18 - do nens3=1,maxens3 - pr_ens(i,j,nall+nens3)=0. - enddo - endif - do nens3=1,maxens3 - if(pr_ens(i,j,nall+nens3).lt.1.e-4)then - pr_ens(i,j,nall+nens3)=0. - endif - enddo - endif - enddo - 200 continue -! -!--- LARGE SCALE FORCING -! -! -!------- CHECK wether aa0 should have been zero -! -! - CALL cup_MAXIMI(HEO_CUP,3,KBMAX,K22x,ierr, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - do i=its,itf - ierr2(i)=ierr(i) - ierr3(i)=ierr(i) - enddo - call cup_kbcon(cap_max_increment,2,k22x,kbconx,heo_cup, & - heso_cup,ierr2,kbmax,po_cup,cap_max, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - call cup_kbcon(cap_max_increment,3,k22x,kbconx,heo_cup, & - heso_cup,ierr3,kbmax,po_cup,cap_max, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) -! -!--- DETERMINE THE LEVEL OF CONVECTIVE CLOUD BASE - KBCON -! - - call cup_forcing_ens_3d(closure_n,xland1,aa0,aa1,xaa0_ens,mbdt_ens,dtime, & - ierr,ierr2,ierr3,xf_ens,j,'deeps',axx, & - maxens,iens,iedt,maxens2,maxens3,mconv, & - po_cup,ktop,omeg,zdo,k22,zuo,pr_ens,edto,kbcon, & - massflx,iact,direction,ensdim,massfln,ichoice,edt_out, & - high_resolution,itf,jtf,ktf, & - its,ite, jts,jte, kts,kte,ens4,ktau) -! - do k=kts,ktf - do i=its,itf - if(ierr(i).eq.0)then - subt_ens(i,k,iedt)=dsubt(i,k) - subq_ens(i,k,iedt)=dsubq(i,k) - dellat_ens(i,k,iedt)=dellat(i,k) - dellaq_ens(i,k,iedt)=dellaq(i,k) - dellaqc_ens(i,k,iedt)=dellaqc(i,k) - pwo_ens(i,k,iedt)=pwo(i,k)+edt(i)*pwdo(i,k) - else - subt_ens(i,k,iedt)=0. - subq_ens(i,k,iedt)=0. - dellat_ens(i,k,iedt)=0. - dellaq_ens(i,k,iedt)=0. - dellaqc_ens(i,k,iedt)=0. - pwo_ens(i,k,iedt)=0. - endif - if(i.eq.ipr.and.j.eq.jpr)then - write(0,*)'1',iens,iedt,dellat(i,k),dellat_ens(i,k,iedt), & - dellaq(i,k), dellaqc(i,k) - write(0,*)'2',k,subt_ens(i,k,iedt),subq_ens(i,k,iedt) - endif - enddo - enddo - 250 continue -! -!--- FEEDBACK -! - call cup_output_ens_3d(xf_ens,ierr,dellat_ens,dellaq_ens, & - dellaqc_ens,subt_ens,subq_ens,subt,subq,outt, & - outq,outqc,zuo,sub_mas,pre,pwo_ens,xmb,ktop, & - j,'deep',maxens2,maxens,iens,ierr2,ierr3, & - pr_ens,maxens3,ensdim,massfln, & - APR_GR,APR_W,APR_MC,APR_ST,APR_AS, & - APR_CAPMA,APR_CAPME,APR_CAPMI,closure_n,xland1, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - k=1 - do i=its,itf - PRE(I)=MAX(PRE(I),0.) - if(pre(i).gt.0.)then - do k=kts,ktf-1 - outu(i,k)=dellau(i,k)*xmb(i) - outv(i,k)=dellav(i,k)*xmb(i) - enddo - endif - enddo -! -!---------------------------done------------------------------ -! - do i=its,itf - if(ierr(i).eq.0)then - if(i.eq.ipr.and.j.eq.jpr)then - write(0,*)'on output, pre =',pre(i),its,itf,kts,ktf - do k=kts,ktf - write(0,*)z(i,k),outt(i,k)*86400.,subt(i,k)*86400. - enddo - write(0,*)i,j,(axx(i,k),k=1,ens4) - endif - endif - enddo -! print *,'ierr(i) = ',ierr(i),pre(i) - - END SUBROUTINE CUP_enss_3d - - - SUBROUTINE cup_dd_aa0(edt,ierr,aa0,jmin,gamma_cup,t_cup, & - hcd,hes_cup,z,zd, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE -! -! on input -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte - ! aa0 cloud work function for downdraft - ! gamma_cup = gamma on model cloud levels - ! t_cup = temperature (Kelvin) on model cloud levels - ! hes_cup = saturation moist static energy on model cloud levels - ! hcd = moist static energy in downdraft - ! edt = epsilon - ! zd normalized downdraft mass flux - ! z = heights of model levels - ! ierr error value, maybe modified in this routine - ! - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - z,zd,gamma_cup,t_cup,hes_cup,hcd - real, dimension (its:ite) & - ,intent (in ) :: & - edt - integer, dimension (its:ite) & - ,intent (in ) :: & - jmin -! -! input and output -! - - - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr - real, dimension (its:ite) & - ,intent (out ) :: & - aa0 -! -! local variables in this routine -! - - integer :: & - i,k,kk - real :: & - dz -! - do i=its,itf - aa0(i)=0. - enddo -! -!?? DO k=kts,kte-1 - DO k=kts,ktf-1 - do i=its,itf - IF(ierr(I).eq.0.and.k.lt.jmin(i))then - KK=JMIN(I)-K -! -!--- ORIGINAL -! - DZ=(Z(I,KK)-Z(I,KK+1)) - AA0(I)=AA0(I)+zd(i,kk)*EDT(I)*DZ*(9.81/(1004.*T_cup(I,KK))) & - *((hcd(i,kk)-hes_cup(i,kk))/(1.+GAMMA_cup(i,kk))) - endif - enddo - enddo - - END SUBROUTINE CUP_dd_aa0 - - - SUBROUTINE cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & - pwev,edtmax,edtmin,maxens2,edtc, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE - - integer & - ,intent (in ) :: & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte - integer, intent (in ) :: & - maxens2 - ! - ! ierr error value, maybe modified in this routine - ! - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - us,vs,z,p - real, dimension (its:ite,1:maxens2) & - ,intent (out ) :: & - edtc - real, dimension (its:ite) & - ,intent (out ) :: & - edt - real, dimension (its:ite) & - ,intent (in ) :: & - pwav,pwev - real & - ,intent (in ) :: & - edtmax,edtmin - integer, dimension (its:ite) & - ,intent (in ) :: & - ktop,kbcon - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr -! -! local variables in this routine -! - - integer i,k,kk - real einc,pef,pefb,prezk,zkbc - real, dimension (its:ite) :: & - vshear,sdp,vws - -! -!--- DETERMINE DOWNDRAFT STRENGTH IN TERMS OF WINDSHEAR -! -! */ calculate an average wind shear over the depth of the cloud -! - do i=its,itf - edt(i)=0. - vws(i)=0. - sdp(i)=0. - vshear(i)=0. - enddo - do k=1,maxens2 - do i=its,itf - edtc(i,k)=0. - enddo - enddo - do kk = kts,ktf-1 - do 62 i=its,itf - IF(ierr(i).ne.0)GO TO 62 - if (kk .le. min0(ktop(i),ktf) .and. kk .ge. kbcon(i)) then - vws(i) = vws(i)+ & - (abs((us(i,kk+1)-us(i,kk))/(z(i,kk+1)-z(i,kk))) & - + abs((vs(i,kk+1)-vs(i,kk))/(z(i,kk+1)-z(i,kk)))) * & - (p(i,kk) - p(i,kk+1)) - sdp(i) = sdp(i) + p(i,kk) - p(i,kk+1) - endif - if (kk .eq. ktf)vshear(i) = 1.e3 * vws(i) / sdp(i) - 62 continue - end do - do i=its,itf - IF(ierr(i).eq.0)then - pef=(1.591-.639*VSHEAR(I)+.0953*(VSHEAR(I)**2) & - -.00496*(VSHEAR(I)**3)) - if(pef.gt.1.)pef=1. - if(pef.lt.0.)pef=0. -! -!--- cloud base precip efficiency -! - zkbc=z(i,kbcon(i))*3.281e-3 - prezk=.02 - if(zkbc.gt.3.)then - prezk=.96729352+zkbc*(-.70034167+zkbc*(.162179896+zkbc & - *(- 1.2569798E-2+zkbc*(4.2772E-4-zkbc*5.44E-6)))) - endif - if(zkbc.gt.25)then - prezk=2.4 - endif - pefb=1./(1.+prezk) - if(pefb.gt.1.)pefb=1. - if(pefb.lt.0.)pefb=0. - EDT(I)=1.-.5*(pefb+pef) -!--- edt here is 1-precipeff! - einc=.2*edt(i) - do k=1,maxens2 - edtc(i,k)=edt(i)+float(k-2)*einc - enddo - endif - enddo - do i=its,itf - IF(ierr(i).eq.0)then - do k=1,maxens2 - EDTC(I,K)=-EDTC(I,K)*PWAV(I)/PWEV(I) - IF(EDTC(I,K).GT.edtmax)EDTC(I,K)=edtmax - IF(EDTC(I,K).LT.edtmin)EDTC(I,K)=edtmin - enddo - endif - enddo - - END SUBROUTINE cup_dd_edt - - - SUBROUTINE cup_dd_he(hes_cup,zd,hcd,z_cup,cdd,entr, & - jmin,ierr,he,dby,he_cup, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE -! -! on input -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte - ! hcd = downdraft moist static energy - ! he = moist static energy on model levels - ! he_cup = moist static energy on model cloud levels - ! hes_cup = saturation moist static energy on model cloud levels - ! dby = buoancy term - ! cdd= detrainment function - ! z_cup = heights of model cloud levels - ! entr = entrainment rate - ! zd = downdraft normalized mass flux - ! - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - he,he_cup,hes_cup,z_cup,cdd,zd - ! entr= entrainment rate - real & - ,intent (in ) :: & - entr - integer, dimension (its:ite) & - ,intent (in ) :: & - jmin -! -! input and output -! - - ! ierr error value, maybe modified in this routine - - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr - - real, dimension (its:ite,kts:kte) & - ,intent (out ) :: & - hcd,dby -! -! local variables in this routine -! - - integer :: & - i,k,ki - real :: & - dz - - - do k=kts+1,ktf - do i=its,itf - dby(i,k)=0. - IF(ierr(I).eq.0)then - hcd(i,k)=hes_cup(i,k) - endif - enddo - enddo -! - do 100 i=its,itf - IF(ierr(I).eq.0)then - k=jmin(i) - hcd(i,k)=hes_cup(i,k) - dby(i,k)=hcd(i,jmin(i))-hes_cup(i,k) -! - do ki=jmin(i)-1,1,-1 - DZ=Z_cup(i,Ki+1)-Z_cup(i,Ki) - HCD(i,Ki)=(HCD(i,Ki+1)*(1.-.5*CDD(i,Ki)*DZ) & - +entr*DZ*HE(i,Ki) & - )/(1.+entr*DZ-.5*CDD(i,Ki)*DZ) - dby(i,ki)=HCD(i,Ki)-hes_cup(i,ki) - enddo -! - endif -!--- end loop over i -100 continue - - - END SUBROUTINE cup_dd_he - - - SUBROUTINE cup_dd_moisture_3d(zd,hcd,hes_cup,qcd,qes_cup, & - pwd,q_cup,z_cup,cdd,entr,jmin,ierr, & - gamma_cup,pwev,bu,qrcd, & - q,he,t_cup,iloop,xl,high_resolution, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE - - integer & - ,intent (in ) :: & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte,high_resolution - ! cdd= detrainment function - ! q = environmental q on model levels - ! q_cup = environmental q on model cloud levels - ! qes_cup = saturation q on model cloud levels - ! hes_cup = saturation h on model cloud levels - ! hcd = h in model cloud - ! bu = buoancy term - ! zd = normalized downdraft mass flux - ! gamma_cup = gamma on model cloud levels - ! mentr_rate = entrainment rate - ! qcd = cloud q (including liquid water) after entrainment - ! qrch = saturation q in cloud - ! pwd = evaporate at that level - ! pwev = total normalized integrated evaoprate (I2) - ! entr= entrainment rate - ! - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - zd,t_cup,hes_cup,hcd,qes_cup,q_cup,z_cup,cdd,gamma_cup,q,he - real & - ,intent (in ) :: & - entr,xl - integer & - ,intent (in ) :: & - iloop - integer, dimension (its:ite) & - ,intent (in ) :: & - jmin - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr - real, dimension (its:ite,kts:kte) & - ,intent (out ) :: & - qcd,qrcd,pwd - real, dimension (its:ite) & - ,intent (out ) :: & - pwev,bu -! -! local variables in this routine -! - - integer :: & - i,k,ki - real :: & - dh,dz,dqeva - - do i=its,itf - bu(i)=0. - pwev(i)=0. - enddo - do k=kts,ktf - do i=its,itf - qcd(i,k)=0. - qrcd(i,k)=0. - pwd(i,k)=0. - enddo - enddo -! -! -! - do 100 i=its,itf - IF(ierr(I).eq.0)then - k=jmin(i) - DZ=Z_cup(i,K+1)-Z_cup(i,K) - qcd(i,k)=q_cup(i,k) - if(high_resolution.eq.1)qcd(i,k)=.5*(qes_cup(i,k)+q_cup(i,k)) - qrcd(i,k)=qes_cup(i,k) - pwd(i,jmin(i))=min(0.,qcd(i,k)-qrcd(i,k)) - pwev(i)=pwev(i)+pwd(i,jmin(i)) - qcd(i,k)=qes_cup(i,k) -! - DH=HCD(I,k)-HES_cup(I,K) - bu(i)=dz*dh - do ki=jmin(i)-1,1,-1 - DZ=Z_cup(i,Ki+1)-Z_cup(i,Ki) - QCD(i,Ki)=(qCD(i,Ki+1)*(1.-.5*CDD(i,Ki)*DZ) & - +entr*DZ*q(i,Ki) & - )/(1.+entr*DZ-.5*CDD(i,Ki)*DZ) -! -!--- to be negatively buoyant, hcd should be smaller than hes! -! - DH=HCD(I,ki)-HES_cup(I,Ki) - bu(i)=bu(i)+dz*dh - QRCD(I,Ki)=qes_cup(i,ki)+(1./XL)*(GAMMA_cup(i,ki) & - /(1.+GAMMA_cup(i,ki)))*DH - dqeva=qcd(i,ki)-qrcd(i,ki) - if(dqeva.gt.0.)dqeva=0. - pwd(i,ki)=zd(i,ki)*dqeva - qcd(i,ki)=qrcd(i,ki) - pwev(i)=pwev(i)+pwd(i,ki) -! if(iloop.eq.1.and.i.eq.102.and.j.eq.62)then -! print *,'in cup_dd_moi ', hcd(i,ki),HES_cup(I,Ki),dh,dqeva -! endif - enddo -! -!--- end loop over i - if(pwev(I).eq.0.and.iloop.eq.1)then -! print *,'problem with buoy in cup_dd_moisture',i - ierr(i)=7 - endif - if(BU(I).GE.0.and.iloop.eq.1)then -! print *,'problem with buoy in cup_dd_moisture',i - ierr(i)=7 - endif - endif -100 continue - - END SUBROUTINE cup_dd_moisture_3d - - - SUBROUTINE cup_dd_nms(zd,z_cup,cdd,entr,jmin,ierr, & - itest,kdet,z1, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE -! -! on input -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte - ! z_cup = height of cloud model level - ! z1 = terrain elevation - ! entr = downdraft entrainment rate - ! jmin = downdraft originating level - ! kdet = level above ground where downdraft start detraining - ! itest = flag to whether to calculate cdd - - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - z_cup - real, dimension (its:ite) & - ,intent (in ) :: & - z1 - real & - ,intent (in ) :: & - entr - integer, dimension (its:ite) & - ,intent (in ) :: & - jmin,kdet - integer & - ,intent (in ) :: & - itest -! -! input and output -! - - ! ierr error value, maybe modified in this routine - - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr - ! zd is the normalized downdraft mass flux - ! cdd is the downdraft detrainmen function - - real, dimension (its:ite,kts:kte) & - ,intent (out ) :: & - zd - real, dimension (its:ite,kts:kte) & - ,intent (inout) :: & - cdd -! -! local variables in this routine -! - - integer :: & - i,k,ki - real :: & - a,perc,dz - -! -!--- perc is the percentage of mass left when hitting the ground -! - perc=.03 - - do k=kts,ktf - do i=its,itf - zd(i,k)=0. - if(itest.eq.0)cdd(i,k)=0. - enddo - enddo - a=1.-perc -! -! -! - do 100 i=its,itf - IF(ierr(I).eq.0)then - zd(i,jmin(i))=1. -! -!--- integrate downward, specify detrainment(cdd)! -! - do ki=jmin(i)-1,1,-1 - DZ=Z_cup(i,Ki+1)-Z_cup(i,Ki) - if(ki.le.kdet(i).and.itest.eq.0)then - cdd(i,ki)=entr+(1.- (a*(z_cup(i,ki)-z1(i)) & - +perc*(z_cup(i,kdet(i))-z1(i)) ) & - /(a*(z_cup(i,ki+1)-z1(i)) & - +perc*(z_cup(i,kdet(i))-z1(i))))/dz - endif - zd(i,ki)=zd(i,ki+1)*(1.+(entr-cdd(i,ki))*dz) - enddo -! - endif -!--- end loop over i -100 continue - - END SUBROUTINE cup_dd_nms - - - SUBROUTINE cup_dellabot(ipr,jpr,he_cup,ierr,z_cup,p_cup, & - hcd,edt,zd,cdd,he,della,subs,j,mentrd_rate,z,g, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE - - integer & - ,intent (in ) :: & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte - integer, intent (in ) :: & - j,ipr,jpr - ! - ! ierr error value, maybe modified in this routine - ! - real, dimension (its:ite,kts:kte) & - ,intent (out ) :: & - della,subs - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - z_cup,p_cup,hcd,zd,cdd,he,z,he_cup - real, dimension (its:ite) & - ,intent (in ) :: & - edt - real & - ,intent (in ) :: & - g,mentrd_rate - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr -! -! local variables in this routine -! - - integer i - real detdo,detdo1,detdo2,entdo,dp,dz,subin, & - totmas -! -! - do 100 i=its,itf - della(i,1)=0. - subs(i,1)=0. - if(ierr(i).ne.0)go to 100 - dz=z_cup(i,2)-z_cup(i,1) - DP=100.*(p_cup(i,1)-P_cup(i,2)) - detdo1=edt(i)*zd(i,2)*CDD(i,1)*DZ - detdo2=edt(i)*zd(i,1) - entdo=edt(i)*zd(i,2)*mentrd_rate*dz - subin=-EDT(I)*zd(i,2) - detdo=detdo1+detdo2-entdo+subin - DELLA(I,1)=(detdo1*.5*(HCD(i,1)+HCD(i,2)) & - +detdo2*hcd(i,1) & - +subin*he_cup(i,2) & - -entdo*he(i,1))*g/dp - SUBS(I,1)=0. - if(i.eq.ipr.and.j.eq.jpr)then - write(0,*)'db1',della(i,1),subs(i,1),subin,entdo - write(0,*)'db2',detdo1,detdo2,detdo1+detdo2-entdo+subin - endif - 100 CONTINUE - - END SUBROUTINE cup_dellabot - - - SUBROUTINE cup_dellas_3d(ierr,z_cup,p_cup,hcd,edt,zd,cdd, & - he,della,subs,j,mentrd_rate,zu,g, & - cd,hc,ktop,k22,kbcon,mentr_rate,jmin,he_cup,kdet,kpbl, & - ipr,jpr,name,high_res, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE - - integer & - ,intent (in ) :: & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte - integer, intent (in ) :: & - j,ipr,jpr,high_res - ! - ! ierr error value, maybe modified in this routine - ! - real, dimension (its:ite,kts:kte) & - ,intent (out ) :: & - della,subs - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - z_cup,p_cup,hcd,zd,cdd,he,hc,cd,zu,he_cup - real, dimension (its:ite) & - ,intent (in ) :: & - edt - real & - ,intent (in ) :: & - g,mentrd_rate,mentr_rate - integer, dimension (its:ite) & - ,intent (in ) :: & - kbcon,ktop,k22,jmin,kdet,kpbl - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr - character *(*), intent (in) :: & - name -! -! local variables in this routine -! - - integer i,k - real detdo1,detdo2,entdo,dp,dz,subin,detdo,entup, & - detup,subdown,entdoj,entupk,detupk,totmas -! - i=ipr - DO K=kts+1,ktf - do i=its,itf - della(i,k)=0. - subs(i,k)=0. - enddo - enddo -! - DO 100 k=kts+1,ktf-1 - DO 100 i=its,ite - IF(ierr(i).ne.0)GO TO 100 - IF(K.Gt.KTOP(I))GO TO 100 -! -!--- SPECIFY DETRAINMENT OF DOWNDRAFT, HAS TO BE CONSISTENT -!--- WITH ZD CALCULATIONS IN SOUNDD. -! - DZ=Z_cup(I,K+1)-Z_cup(I,K) - detdo=edt(i)*CDD(i,K)*DZ*ZD(i,k+1) - entdo=edt(i)*mentrd_rate*dz*zd(i,k+1) -!3d subin=zu(i,k+1)-zd(i,k+1)*edt(i) - subin=-zd(i,k+1)*edt(i) - entup=0. - detup=0. - if(k.ge.kbcon(i).and.k.lt.ktop(i))then - entup=mentr_rate*dz*zu(i,k) - detup=CD(i,K+1)*DZ*ZU(i,k) - endif -!3d subdown=(zu(i,k)-zd(i,k)*edt(i)) - subdown=-zd(i,k)*edt(i) - entdoj=0. - entupk=0. - detupk=0. -! - if(k.eq.jmin(i))then - entdoj=edt(i)*zd(i,k) - endif - - if(k.eq.k22(i)-1)then - entupk=zu(i,kpbl(i)) - subin=zu(i,k+1)-zd(i,k+1)*edt(i) - if(high_res.eq.1)subin=-zd(i,k+1)*edt(i) -! subin=-zd(i,k+1)*edt(i) - endif - - if(k.gt.kdet(i))then - detdo=0. - endif - - if(k.eq.ktop(i)-0)then - detupk=zu(i,ktop(i)) - subin=0. -! -! this subsidene for ktop now in subs term! -! subdown=zu(i,k) - subdown=0. - endif - if(k.lt.kbcon(i))then - detup=0. - endif -!C -!C--- CHANGED DUE TO SUBSIDENCE AND ENTRAINMENT -!C - totmas=subin-subdown+detup-entup-entdo+ & - detdo-entupk-entdoj+detupk -! if(j.eq.jpr.and.i.eq.ipr)print *,'k,totmas,sui,sud = ',k, -! 1 totmas,subin,subdown -! if(j.eq.jpr.and.i.eq.ipr)print *,'updr stuff = ',detup, -! 1 entup,entupk,detupk -! if(j.eq.jpr.and.i.eq.ipr)print *,'dddr stuff = ',entdo, -! 1 detdo,entdoj - if(abs(totmas).gt.1.e-6)then -! print *,'*********************',i,j,k,totmas,name -! print *,kpbl(i),k22(i),kbcon(i),ktop(i) -!c print *,'updr stuff = ',subin, -!c 1 subdown,detup,entup,entupk,detupk -!c print *,'dddr stuff = ',entdo, -!c 1 detdo,entdoj -! call wrf_error_fatal ( 'totmas .gt.1.e-6' ) - endif - dp=100.*(p_cup(i,k-1)-p_cup(i,k)) - della(i,k)=(detup*.5*(HC(i,K+1)+HC(i,K)) & - +detdo*.5*(HCD(i,K+1)+HCD(i,K)) & - -entup*he(i,k) & - -entdo*he(i,k) & - +subin*he_cup(i,k+1) & - -subdown*he_cup(i,k) & - +detupk*(hc(i,ktop(i))-he_cup(i,ktop(i))) & - -entupk*he_cup(i,k22(i)) & - -entdoj*he_cup(i,jmin(i)) & - )*g/dp - if(high_res.eq.1)then -! the first term includes entr and detr into/from updraft as well as (entup-detup)*he(i,k) from -! neighbouring point, to make things mass consistent.... -! if(k.ge.k22(i))then - della(i,k)=( & - detup*.5*(HC(i,K+1)+HC(i,K))-entup*he(i,k)+(entup-detup)*he(i,k) & - +detdo*.5*(HCD(i,K+1)+HCD(i,K)) & - -entdo*he(i,k) & - +subin*he_cup(i,k+1) & - -subdown*he_cup(i,k) & - +detupk*(hc(i,ktop(i))-he(i,ktop(i))) & - -entdoj*he_cup(i,jmin(i)) & - -entupk*he_cup(i,k22(i))+entupk*he(i,k) & - )*g/dp -! else if(k.eq.k22(i)-1)then -! della(i,k)=(-entupk*he_cup(i,k22(i))+entupk*he(i,k))*g/dp - endif -!3d subin=zu(i,k+1)-zd(i,k+1)*edt(i) -! -! updraft subsidence only -! - if(k.ge.k22(i).and.k.lt.ktop(i))then - subs(i,k)=(zu(i,k+1)*he_cup(i,k+1) & - -zu(i,k)*he_cup(i,k))*g/dp -! else if(k.eq.ktop(i))then -! subs(i,k)=-detupk*he_cup(i,k)*g/dp - endif -! -! in igh res case, subsidence terms are for meighbouring points only. This has to be -! done mass consistent with the della term - if(high_res.eq.1)then - if(k.ge.k22(i).and.k.lt.ktop(i))then - subs(i,k)=(zu(i,k+1)*he_cup(i,k+1)-zu(i,k)*he_cup(i,k)-(entup-detup)*he(i,k))*g/dp - else if(k.eq.ktop(i))then - subs(i,k)=detupk*(he(i,ktop(i))-he_cup(i,ktop(i)))*g/dp - else if(k.eq.k22(i)-1)then - subs(i,k)=(entupk*he(i,k)-entupk*he_cup(i,k))*g/dp - endif - endif - if(i.eq.ipr.and.j.eq.jpr)then - write(0,*)'d',k,della(i,k),subs(i,k),subin,subdown -! write(0,*)'d',detup,entup,entdo,entupk,entdoj -! print *,k,della(i,k),subin*he_cup(i,k+1),subdown*he_cup(i,k), -! 1 detdo*.5*(HCD(i,K+1)+HCD(i,K)) -! print *,k,detup*.5*(HC(i,K+1)+HC(i,K)),detupk*hc(i,ktop(i)), -! 1 entup*he(i,k),entdo*he(i,k) -! print *,k,he_cup(i,k+1),he_cup(i,k),entupk*he_cup(i,k) - endif - - 100 CONTINUE - - END SUBROUTINE cup_dellas_3d - - - SUBROUTINE cup_direction2(i,j,dir,id,massflx, & - iresult,imass,massfld, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE - - integer & - ,intent (in ) :: & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte - integer, intent (in ) :: & - i,j,imass - integer, intent (out ) :: & - iresult - ! - ! ierr error value, maybe modified in this routine - ! - integer, dimension (its:ite,jts:jte) & - ,intent (in ) :: & - id - real, dimension (its:ite,jts:jte) & - ,intent (in ) :: & - massflx - real, dimension (its:ite) & - ,intent (inout) :: & - dir - real & - ,intent (out ) :: & - massfld -! -! local variables in this routine -! - - integer k,ia,ja,ib,jb - real diff -! -! -! - if(imass.eq.1)then - massfld=massflx(i,j) - endif - iresult=0 -! return - diff=22.5 - if(dir(i).lt.22.5)dir(i)=360.+dir(i) - if(id(i,j).eq.1)iresult=1 -! ja=max(2,j-1) -! ia=max(2,i-1) -! jb=min(mjx-1,j+1) -! ib=min(mix-1,i+1) - ja=j-1 - ia=i-1 - jb=j+1 - ib=i+1 - if(dir(i).gt.90.-diff.and.dir(i).le.90.+diff)then -!--- steering flow from the east - if(id(ib,j).eq.1)then - iresult=1 - if(imass.eq.1)then - massfld=max(massflx(ib,j),massflx(i,j)) - endif - return - endif - else if(dir(i).gt.135.-diff.and.dir(i).le.135.+diff)then -!--- steering flow from the south-east - if(id(ib,ja).eq.1)then - iresult=1 - if(imass.eq.1)then - massfld=max(massflx(ib,ja),massflx(i,j)) - endif - return - endif -!--- steering flow from the south - else if(dir(i).gt.180.-diff.and.dir(i).le.180.+diff)then - if(id(i,ja).eq.1)then - iresult=1 - if(imass.eq.1)then - massfld=max(massflx(i,ja),massflx(i,j)) - endif - return - endif -!--- steering flow from the south west - else if(dir(i).gt.225.-diff.and.dir(i).le.225.+diff)then - if(id(ia,ja).eq.1)then - iresult=1 - if(imass.eq.1)then - massfld=max(massflx(ia,ja),massflx(i,j)) - endif - return - endif -!--- steering flow from the west - else if(dir(i).gt.270.-diff.and.dir(i).le.270.+diff)then - if(id(ia,j).eq.1)then - iresult=1 - if(imass.eq.1)then - massfld=max(massflx(ia,j),massflx(i,j)) - endif - return - endif -!--- steering flow from the north-west - else if(dir(i).gt.305.-diff.and.dir(i).le.305.+diff)then - if(id(ia,jb).eq.1)then - iresult=1 - if(imass.eq.1)then - massfld=max(massflx(ia,jb),massflx(i,j)) - endif - return - endif -!--- steering flow from the north - else if(dir(i).gt.360.-diff.and.dir(i).le.360.+diff)then - if(id(i,jb).eq.1)then - iresult=1 - if(imass.eq.1)then - massfld=max(massflx(i,jb),massflx(i,j)) - endif - return - endif -!--- steering flow from the north-east - else if(dir(i).gt.45.-diff.and.dir(i).le.45.+diff)then - if(id(ib,jb).eq.1)then - iresult=1 - if(imass.eq.1)then - massfld=max(massflx(ib,jb),massflx(i,j)) - endif - return - endif - endif - - END SUBROUTINE cup_direction2 - - - SUBROUTINE cup_env(z,qes,he,hes,t,q,p,z1, & - psur,ierr,tcrit,itest,xl,cp, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE - - integer & - ,intent (in ) :: & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte - ! - ! ierr error value, maybe modified in this routine - ! q = environmental mixing ratio - ! qes = environmental saturation mixing ratio - ! t = environmental temp - ! tv = environmental virtual temp - ! p = environmental pressure - ! z = environmental heights - ! he = environmental moist static energy - ! hes = environmental saturation moist static energy - ! psur = surface pressure - ! z1 = terrain elevation - ! - ! - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - p,t - real, dimension (its:ite,kts:kte) & - ,intent (out ) :: & - he,hes,qes - real, dimension (its:ite,kts:kte) & - ,intent (inout) :: & - z,q - real, dimension (its:ite) & - ,intent (in ) :: & - psur,z1 - real & - ,intent (in ) :: & - xl,cp - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr - integer & - ,intent (in ) :: & - itest -! -! local variables in this routine -! - - integer :: & - i,k,iph - real, dimension (1:2) :: AE,BE,HT - real, dimension (its:ite,kts:kte) :: tv - real :: tcrit,e,tvbar - - - HT(1)=XL/CP - HT(2)=2.834E6/CP - BE(1)=.622*HT(1)/.286 - AE(1)=BE(1)/273.+ALOG(610.71) - BE(2)=.622*HT(2)/.286 - AE(2)=BE(2)/273.+ALOG(610.71) -! print *, 'TCRIT = ', tcrit,its,ite - DO k=kts,ktf - do i=its,itf - if(ierr(i).eq.0)then -!Csgb - IPH is for phase, dependent on TCRIT (water or ice) - IPH=1 - IF(T(I,K).LE.TCRIT)IPH=2 -! print *, 'AE(IPH),BE(IPH) = ',AE(IPH),BE(IPH),AE(IPH)-BE(IPH),T(i,k),i,k - E=EXP(AE(IPH)-BE(IPH)/T(I,K)) -! print *, 'P, E = ', P(I,K), E - QES(I,K)=.622*E/(100.*P(I,K)-E) - IF(QES(I,K).LE.1.E-08)QES(I,K)=1.E-08 - IF(Q(I,K).GT.QES(I,K))Q(I,K)=QES(I,K) - TV(I,K)=T(I,K)+.608*Q(I,K)*T(I,K) - endif - enddo - enddo -! -!--- z's are calculated with changed h's and q's and t's -!--- if itest=2 -! - if(itest.ne.2)then - do i=its,itf - if(ierr(i).eq.0)then - Z(I,1)=max(0.,Z1(I))-(ALOG(P(I,1))- & - ALOG(PSUR(I)))*287.*TV(I,1)/9.81 - endif - enddo - -! --- calculate heights - DO K=kts+1,ktf - do i=its,itf - if(ierr(i).eq.0)then - TVBAR=.5*TV(I,K)+.5*TV(I,K-1) - Z(I,K)=Z(I,K-1)-(ALOG(P(I,K))- & - ALOG(P(I,K-1)))*287.*TVBAR/9.81 - endif - enddo - enddo - else - do k=kts,ktf - do i=its,itf - if(ierr(i).eq.0)then - z(i,k)=(he(i,k)-1004.*t(i,k)-2.5e6*q(i,k))/9.81 - z(i,k)=max(1.e-3,z(i,k)) - endif - enddo - enddo - endif -! -!--- calculate moist static energy - HE -! saturated moist static energy - HES -! - DO k=kts,ktf - do i=its,itf - if(ierr(i).eq.0)then - if(itest.eq.0)HE(I,K)=9.81*Z(I,K)+1004.*T(I,K)+2.5E06*Q(I,K) - HES(I,K)=9.81*Z(I,K)+1004.*T(I,K)+2.5E06*QES(I,K) - IF(HE(I,K).GE.HES(I,K))HE(I,K)=HES(I,K) - endif - enddo - enddo - - END SUBROUTINE cup_env - - - SUBROUTINE cup_env_clev(t,qes,q,he,hes,z,p,qes_cup,q_cup, & - he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup,psur, & - ierr,z1,xl,rv,cp, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE - - integer & - ,intent (in ) :: & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte - ! - ! ierr error value, maybe modified in this routine - ! q = environmental mixing ratio - ! q_cup = environmental mixing ratio on cloud levels - ! qes = environmental saturation mixing ratio - ! qes_cup = environmental saturation mixing ratio on cloud levels - ! t = environmental temp - ! t_cup = environmental temp on cloud levels - ! p = environmental pressure - ! p_cup = environmental pressure on cloud levels - ! z = environmental heights - ! z_cup = environmental heights on cloud levels - ! he = environmental moist static energy - ! he_cup = environmental moist static energy on cloud levels - ! hes = environmental saturation moist static energy - ! hes_cup = environmental saturation moist static energy on cloud levels - ! gamma_cup = gamma on cloud levels - ! psur = surface pressure - ! z1 = terrain elevation - ! - ! - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - qes,q,he,hes,z,p,t - real, dimension (its:ite,kts:kte) & - ,intent (out ) :: & - qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup - real, dimension (its:ite) & - ,intent (in ) :: & - psur,z1 - real & - ,intent (in ) :: & - xl,rv,cp - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr -! -! local variables in this routine -! - - integer :: & - i,k - - - do k=kts+1,ktf - do i=its,itf - if(ierr(i).eq.0)then - qes_cup(i,k)=.5*(qes(i,k-1)+qes(i,k)) - q_cup(i,k)=.5*(q(i,k-1)+q(i,k)) - hes_cup(i,k)=.5*(hes(i,k-1)+hes(i,k)) - he_cup(i,k)=.5*(he(i,k-1)+he(i,k)) - if(he_cup(i,k).gt.hes_cup(i,k))he_cup(i,k)=hes_cup(i,k) - z_cup(i,k)=.5*(z(i,k-1)+z(i,k)) - p_cup(i,k)=.5*(p(i,k-1)+p(i,k)) - t_cup(i,k)=.5*(t(i,k-1)+t(i,k)) - gamma_cup(i,k)=(xl/cp)*(xl/(rv*t_cup(i,k) & - *t_cup(i,k)))*qes_cup(i,k) - endif - enddo - enddo - do i=its,itf - if(ierr(i).eq.0)then - qes_cup(i,1)=qes(i,1) - q_cup(i,1)=q(i,1) - hes_cup(i,1)=hes(i,1) - he_cup(i,1)=he(i,1) - z_cup(i,1)=.5*(z(i,1)+z1(i)) - p_cup(i,1)=.5*(p(i,1)+psur(i)) - t_cup(i,1)=t(i,1) - gamma_cup(i,1)=xl/cp*(xl/(rv*t_cup(i,1) & - *t_cup(i,1)))*qes_cup(i,1) - endif - enddo - - END SUBROUTINE cup_env_clev - - - SUBROUTINE cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2,ierr3,& - xf_ens,j,name,axx,maxens,iens,iedt,maxens2,maxens3,mconv, & - p_cup,ktop,omeg,zd,k22,zu,pr_ens,edt,kbcon,massflx, & - iact_old_gr,dir,ensdim,massfln,icoic,edt_out, & - high_resolution,itf,jtf,ktf, & - its,ite, jts,jte, kts,kte,ens4,ktau ) - - IMPLICIT NONE - - integer & - ,intent (in ) :: & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte,ens4,high_resolution,ktau - integer, intent (in ) :: & - j,ensdim,maxens,iens,iedt,maxens2,maxens3 - ! - ! ierr error value, maybe modified in this routine - ! pr_ens = precipitation ensemble - ! xf_ens = mass flux ensembles - ! massfln = downdraft mass flux ensembles used in next timestep - ! omeg = omega from large scale model - ! mconv = moisture convergence from large scale model - ! zd = downdraft normalized mass flux - ! zu = updraft normalized mass flux - ! aa0 = cloud work function without forcing effects - ! aa1 = cloud work function with forcing effects - ! xaa0 = cloud work function with cloud effects (ensemble dependent) - ! edt = epsilon - ! dir = "storm motion" - ! mbdt = arbitrary numerical parameter - ! dtime = dt over which forcing is applied - ! iact_gr_old = flag to tell where convection was active - ! kbcon = LFC of parcel from k22 - ! k22 = updraft originating level - ! icoic = flag if only want one closure (usually set to zero!) - ! name = deep or shallow convection flag - ! - real, dimension (its:ite,jts:jte,1:ensdim) & - ,intent (inout) :: & - pr_ens - real, dimension (its:ite,jts:jte,1:ensdim) & - ,intent (out ) :: & - xf_ens,massfln - real, dimension (its:ite,jts:jte) & - ,intent (inout ) :: & - edt_out - real, dimension (its:ite,jts:jte) & - ,intent (in ) :: & - massflx - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - zd,zu,p_cup - real, dimension (its:ite,kts:kte,1:ens4) & - ,intent (in ) :: & - omeg - real, dimension (its:ite,1:maxens) & - ,intent (in ) :: & - xaa0 - real, dimension (its:ite) & - ,intent (in ) :: & - aa1,edt,dir,xland - real, dimension (its:ite,1:ens4) & - ,intent (in ) :: & - mconv,axx - real, dimension (its:ite) & - ,intent (inout) :: & - aa0,closure_n - real, dimension (1:maxens) & - ,intent (in ) :: & - mbdt - real & - ,intent (in ) :: & - dtime - integer, dimension (its:ite,jts:jte) & - ,intent (in ) :: & - iact_old_gr - integer, dimension (its:ite) & - ,intent (in ) :: & - k22,kbcon,ktop - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr,ierr2,ierr3 - integer & - ,intent (in ) :: & - icoic - character *(*), intent (in) :: & - name -! -! local variables in this routine -! - - real, dimension (1:maxens3) :: & - xff_ens3 - real, dimension (1:maxens) :: & - xk - integer :: & - i,k,nall,n,ne,nens,nens3,iresult,iresultd,iresulte,mkxcrt,kclim - parameter (mkxcrt=15) - real :: & - fens4,a1,massfld,a_ave,xff0,xff00,xxx,xomg,aclim1,aclim2,aclim3,aclim4 - real, dimension(1:mkxcrt) :: & - pcrit,acrit,acritt - - integer :: nall2,ixxx,irandom - integer, dimension (8) :: seed - - - DATA PCRIT/850.,800.,750.,700.,650.,600.,550.,500.,450.,400., & - 350.,300.,250.,200.,150./ - DATA ACRIT/.0633,.0445,.0553,.0664,.075,.1082,.1521,.2216, & - .3151,.3677,.41,.5255,.7663,1.1686,1.6851/ -! GDAS DERIVED ACRIT - DATA ACRITT/.203,.515,.521,.566,.625,.665,.659,.688, & - .743,.813,.886,.947,1.138,1.377,1.896/ -! - seed=0 - seed(2)=j - seed(3)=ktau - nens=0 - irandom=1 - if(high_resolution.eq.1)irandom=0 - irandom=0 - fens4=float(ens4) - -!--- LARGE SCALE FORCING -! - DO 100 i=its,itf - if(name.eq.'deeps'.and.ierr(i).gt.995)then - aa0(i)=0. - ierr(i)=0 - endif - IF(ierr(i).eq.0)then -! -!--- -! - if(name.eq.'deeps')then -! - a_ave=0. - do ne=1,ens4 - a_ave=a_ave+axx(i,ne) - enddo - a_ave=max(0.,a_ave/fens4) - a_ave=min(a_ave,aa1(i)) - a_ave=max(0.,a_ave) - do ne=1,16 - xff_ens3(ne)=0. - enddo - xff0= (AA1(I)-AA0(I))/DTIME - if(high_resolution.eq.1)xff0= (a_ave-AA0(I))/DTIME - xff_ens3(1)=(AA1(I)-AA0(I))/dtime - xff_ens3(2)=(a_ave-AA0(I))/dtime - if(irandom.eq.1)then - seed(1)=i - call random_seed (PUT=seed) - call random_number (xxx) - ixxx=min(ens4,max(1,int(fens4*xxx+1.e-8))) - xff_ens3(3)=(axx(i,ixxx)-AA0(I))/dtime - call random_number (xxx) - ixxx=min(ens4,max(1,int(fens4*xxx+1.e-8))) - xff_ens3(13)=(axx(i,ixxx)-AA0(I))/dtime - else - xff_ens3(3)=(AA1(I)-AA0(I))/dtime - xff_ens3(13)=(AA1(I)-AA0(I))/dtime - endif - if(high_resolution.eq.1)then - xff_ens3(1)=(a_ave-AA0(I))/dtime - xff_ens3(2)=(a_ave-AA0(I))/dtime - xff_ens3(3)=(a_ave-AA0(I))/dtime - xff_ens3(13)=(a_ave-AA0(I))/dtime - endif -! -!--- more original Arakawa-Schubert (climatologic value of aa0) -! -! -!--- omeg is in bar/s, mconv done with omeg in Pa/s -! more like Brown (1979), or Frank-Cohen (199?) -! - xff_ens3(14)=0. - do ne=1,ens4 - xff_ens3(14)=xff_ens3(14)-omeg(i,k22(i),ne)/(fens4*9.81) - enddo - if(xff_ens3(14).lt.0.)xff_ens3(14)=0. - xff_ens3(5)=0. - do ne=1,ens4 - xff_ens3(5)=xff_ens3(5)-omeg(i,kbcon(i),ne)/(fens4*9.81) - enddo - if(xff_ens3(5).lt.0.)xff_ens3(5)=0. -! -! minimum below kbcon -! - if(high_resolution.eq.0)then - xff_ens3(4)=-omeg(i,2,1)/9.81 - do k=2,kbcon(i)-1 - do ne=1,ens4 - xomg=-omeg(i,k,ne)/9.81 - if(xomg.lt.xff_ens3(4))xff_ens3(4)=xomg - enddo - enddo - if(xff_ens3(4).lt.0.)xff_ens3(4)=0. -! -! max below kbcon - xff_ens3(6)=-omeg(i,2,1)/9.81 - do k=2,kbcon(i)-1 - do ne=1,ens4 - xomg=-omeg(i,k,ne)/9.81 - if(xomg.gt.xff_ens3(6))xff_ens3(6)=xomg - enddo - enddo - if(xff_ens3(6).lt.0.)xff_ens3(6)=0. - endif - if(high_resolution.eq.1)then - xff_ens3(5)=min(xff_ens3(5),xff_ens3(14)) - xff_ens3(4)=xff_ens3(5) - xff_ens3(6)=xff_ens3(5) - endif -! -!--- more like Krishnamurti et al.; pick max and average values -! - xff_ens3(7)=mconv(i,1) - xff_ens3(8)=mconv(i,1) - xff_ens3(9)=mconv(i,1) - if(ens4.gt.1)then - do ne=2,ens4 - if (mconv(i,ne).gt.xff_ens3(7))xff_ens3(7)=mconv(i,ne) - enddo - do ne=2,ens4 - if (mconv(i,ne).lt.xff_ens3(8))xff_ens3(8)=mconv(i,ne) - enddo - do ne=2,ens4 - xff_ens3(9)=xff_ens3(9)+mconv(i,ne) - enddo - xff_ens3(9)=xff_ens3(9)/fens4 - endif - if(high_resolution.eq.1)then - xff_ens3(7)=xff_ens3(9) - xff_ens3(8)=xff_ens3(9) - xff_ens3(15)=xff_ens3(9) - endif -! - if(high_resolution.eq.0)then - if(irandom.eq.1)then - seed(1)=i - call random_seed (PUT=seed) - call random_number (xxx) - ixxx=min(ens4,max(1,int(fens4*xxx+1.e-8))) - xff_ens3(15)=mconv(i,ixxx) - else - xff_ens3(15)=mconv(i,1) - endif - endif -! -!--- more like Fritsch Chappel or Kain Fritsch (plus triggers) -! - xff_ens3(10)=A_AVE/(60.*40.) - xff_ens3(11)=AA1(I)/(60.*40.) - if(irandom.eq.1)then - seed(1)=i - call random_seed (PUT=seed) - call random_number (xxx) - ixxx=min(ens4,max(1,int(fens4*xxx+1.e-8))) - xff_ens3(12)=AXX(I,ixxx)/(60.*40.) - else - xff_ens3(12)=AA1(I)/(60.*40.) - endif - if(high_resolution.eq.1)then - xff_ens3(11)=xff_ens3(10) - xff_ens3(12)=xff_ens3(10) - endif -! -!--- more original Arakawa-Schubert (climatologic value of aa0) -! -! edt_out(i,j)=xff0 - if(icoic.eq.0)then - if(xff0.lt.0.)then - xff_ens3(1)=0. - xff_ens3(2)=0. - xff_ens3(3)=0. - xff_ens3(13)=0. - xff_ens3(10)=0. - xff_ens3(11)=0. - xff_ens3(12)=0. - endif - endif - - - - do nens=1,maxens - XK(nens)=(XAA0(I,nens)-AA1(I))/MBDT(2) - if(xk(nens).le.0.and.xk(nens).gt.-1.e-6) & - xk(nens)=-1.e-6 - if(xk(nens).gt.0.and.xk(nens).lt.1.e-6) & - xk(nens)=1.e-6 - enddo -! -!--- add up all ensembles -! - do 350 ne=1,maxens -! -!--- for every xk, we have maxens3 xffs -!--- iens is from outermost ensemble (most expensive! -! -!--- iedt (maxens2 belongs to it) -!--- is from second, next outermost, not so expensive -! -!--- so, for every outermost loop, we have maxens*maxens2*3 -!--- ensembles!!! nall would be 0, if everything is on first -!--- loop index, then ne would start counting, then iedt, then iens.... -! - iresult=0 - iresultd=0 - iresulte=0 - nall=(iens-1)*maxens3*maxens*maxens2 & - +(iedt-1)*maxens*maxens3 & - +(ne-1)*maxens3 -! -! over water, enfor!e small cap for some of the closures -! - if(xland(i).lt.0.1)then - if(ierr2(i).gt.0.or.ierr3(i).gt.0)then - xff_ens3(1) =0. - massfln(i,j,nall+1)=0. - xff_ens3(2) =0. - massfln(i,j,nall+2)=0. - xff_ens3(3) =0. - massfln(i,j,nall+3)=0. - xff_ens3(10) =0. - massfln(i,j,nall+10)=0. - xff_ens3(11) =0. - massfln(i,j,nall+11)=0. - xff_ens3(12) =0. - massfln(i,j,nall+12)=0. - xff_ens3(7) =0. - massfln(i,j,nall+7)=0. - xff_ens3(8) =0. - massfln(i,j,nall+8)=0. - xff_ens3(9) =0. - massfln(i,j,nall+9)=0. - closure_n(i)=closure_n(i)-1. - xff_ens3(13) =0. - massfln(i,j,nall+13)=0. - xff_ens3(15) =0. - massfln(i,j,nall+15)=0. - endif - endif -! -! end water treatment -! -! -!--- check for upwind convection -! iresult=0 - massfld=0. - -! call cup_direction2(i,j,dir,iact_old_gr, & -! massflx,iresult,1, & -! massfld, & -! itf,jtf,ktf, & -! ims,ime, jms,jme, kms,kme, & -! its,ite, jts,jte, kts,kte ) -! if(i.eq.ipr.and.j.eq.jpr.and.iedt.eq.1.and.ne.eq.1)then -! if(iedt.eq.1.and.ne.eq.1)then -! print *,massfld,ne,iedt,iens -! print *,xk(ne),xff_ens3(1),xff_ens3(2),xff_ens3(3) -! endif -! print *,i,j,massfld,aa0(i),aa1(i) - IF(XK(ne).lt.0.and.xff0.gt.0.)iresultd=1 - iresulte=max(iresult,iresultd) - iresulte=1 - if(iresulte.eq.1)then -! -!--- special treatment for stability closures -! - - if(xff0.ge.0.)then - xf_ens(i,j,nall+1)=massfld - xf_ens(i,j,nall+2)=massfld - xf_ens(i,j,nall+3)=massfld - xf_ens(i,j,nall+13)=massfld - if(xff_ens3(1).gt.0)xf_ens(i,j,nall+1)=max(0.,-xff_ens3(1)/xk(ne)) & - +massfld - if(xff_ens3(2).gt.0)xf_ens(i,j,nall+2)=max(0.,-xff_ens3(2)/xk(ne)) & - +massfld - if(xff_ens3(3).gt.0)xf_ens(i,j,nall+3)=max(0.,-xff_ens3(3)/xk(ne)) & - +massfld - if(xff_ens3(13).gt.0)xf_ens(i,j,nall+13)=max(0.,-xff_ens3(13)/xk(ne)) & - +massfld -! endif - else - xf_ens(i,j,nall+1)=massfld - xf_ens(i,j,nall+2)=massfld - xf_ens(i,j,nall+3)=massfld - xf_ens(i,j,nall+13)=massfld - endif -! -!--- if iresult.eq.1, following independent of xff0 -! - xf_ens(i,j,nall+4)=max(0.,xff_ens3(4) & - +massfld) - xf_ens(i,j,nall+5)=max(0.,xff_ens3(5) & - +massfld) - xf_ens(i,j,nall+6)=max(0.,xff_ens3(6) & - +massfld) - xf_ens(i,j,nall+14)=max(0.,xff_ens3(14) & - +massfld) - a1=max(1.e-3,pr_ens(i,j,nall+7)) - xf_ens(i,j,nall+7)=max(0.,xff_ens3(7) & - /a1) - a1=max(1.e-3,pr_ens(i,j,nall+8)) - xf_ens(i,j,nall+8)=max(0.,xff_ens3(8) & - /a1) - a1=max(1.e-3,pr_ens(i,j,nall+9)) - xf_ens(i,j,nall+9)=max(0.,xff_ens3(9) & - /a1) - a1=max(1.e-3,pr_ens(i,j,nall+15)) - xf_ens(i,j,nall+15)=max(0.,xff_ens3(15) & - /a1) - if(XK(ne).lt.0.)then - xf_ens(i,j,nall+10)=max(0., & - -xff_ens3(10)/xk(ne)) & - +massfld - xf_ens(i,j,nall+11)=max(0., & - -xff_ens3(11)/xk(ne)) & - +massfld - xf_ens(i,j,nall+12)=max(0., & - -xff_ens3(12)/xk(ne)) & - +massfld - else - xf_ens(i,j,nall+10)=massfld - xf_ens(i,j,nall+11)=massfld - xf_ens(i,j,nall+12)=massfld - endif - if(icoic.ge.1)then - closure_n(i)=0. - xf_ens(i,j,nall+1)=xf_ens(i,j,nall+icoic) - xf_ens(i,j,nall+2)=xf_ens(i,j,nall+icoic) - xf_ens(i,j,nall+3)=xf_ens(i,j,nall+icoic) - xf_ens(i,j,nall+4)=xf_ens(i,j,nall+icoic) - xf_ens(i,j,nall+5)=xf_ens(i,j,nall+icoic) - xf_ens(i,j,nall+6)=xf_ens(i,j,nall+icoic) - xf_ens(i,j,nall+7)=xf_ens(i,j,nall+icoic) - xf_ens(i,j,nall+8)=xf_ens(i,j,nall+icoic) - xf_ens(i,j,nall+9)=xf_ens(i,j,nall+icoic) - xf_ens(i,j,nall+10)=xf_ens(i,j,nall+icoic) - xf_ens(i,j,nall+11)=xf_ens(i,j,nall+icoic) - xf_ens(i,j,nall+12)=xf_ens(i,j,nall+icoic) - xf_ens(i,j,nall+13)=xf_ens(i,j,nall+icoic) - xf_ens(i,j,nall+14)=xf_ens(i,j,nall+icoic) - xf_ens(i,j,nall+15)=xf_ens(i,j,nall+icoic) - xf_ens(i,j,nall+16)=xf_ens(i,j,nall+icoic) - endif -! -! 16 is a randon pick from the oher 15 -! - if(irandom.eq.1)then - call random_number (xxx) - ixxx=min(15,max(1,int(15.*xxx+1.e-8))) - xf_ens(i,j,nall+16)=xf_ens(i,j,nall+ixxx) - else - xf_ens(i,j,nall+16)=xf_ens(i,j,nall+1) - endif -! -! -!--- store new for next time step -! - do nens3=1,maxens3 - massfln(i,j,nall+nens3)=edt(i) & - *xf_ens(i,j,nall+nens3) - massfln(i,j,nall+nens3)=max(0., & - massfln(i,j,nall+nens3)) - enddo -! -! -!--- do some more on the caps!!! ne=1 for 175, ne=2 for 100,.... -! -! do not care for caps here for closure groups 1 and 5, -! they are fine, do not turn them off here -! -! - if(ne.eq.2.and.ierr2(i).gt.0)then - xf_ens(i,j,nall+1) =0. - xf_ens(i,j,nall+2) =0. - xf_ens(i,j,nall+3) =0. - xf_ens(i,j,nall+4) =0. - xf_ens(i,j,nall+5) =0. - xf_ens(i,j,nall+6) =0. - xf_ens(i,j,nall+7) =0. - xf_ens(i,j,nall+8) =0. - xf_ens(i,j,nall+9) =0. - xf_ens(i,j,nall+10)=0. - xf_ens(i,j,nall+11)=0. - xf_ens(i,j,nall+12)=0. - xf_ens(i,j,nall+13)=0. - xf_ens(i,j,nall+14)=0. - xf_ens(i,j,nall+15)=0. - xf_ens(i,j,nall+16)=0. - massfln(i,j,nall+1)=0. - massfln(i,j,nall+2)=0. - massfln(i,j,nall+3)=0. - massfln(i,j,nall+4)=0. - massfln(i,j,nall+5)=0. - massfln(i,j,nall+6)=0. - massfln(i,j,nall+7)=0. - massfln(i,j,nall+8)=0. - massfln(i,j,nall+9)=0. - massfln(i,j,nall+10)=0. - massfln(i,j,nall+11)=0. - massfln(i,j,nall+12)=0. - massfln(i,j,nall+13)=0. - massfln(i,j,nall+14)=0. - massfln(i,j,nall+15)=0. - massfln(i,j,nall+16)=0. - endif - if(ne.eq.3.and.ierr3(i).gt.0)then - xf_ens(i,j,nall+1) =0. - xf_ens(i,j,nall+2) =0. - xf_ens(i,j,nall+3) =0. - xf_ens(i,j,nall+4) =0. - xf_ens(i,j,nall+5) =0. - xf_ens(i,j,nall+6) =0. - xf_ens(i,j,nall+7) =0. - xf_ens(i,j,nall+8) =0. - xf_ens(i,j,nall+9) =0. - xf_ens(i,j,nall+10)=0. - xf_ens(i,j,nall+11)=0. - xf_ens(i,j,nall+12)=0. - xf_ens(i,j,nall+13)=0. - xf_ens(i,j,nall+14)=0. - xf_ens(i,j,nall+15)=0. - xf_ens(i,j,nall+16)=0. - massfln(i,j,nall+1)=0. - massfln(i,j,nall+2)=0. - massfln(i,j,nall+3)=0. - massfln(i,j,nall+4)=0. - massfln(i,j,nall+5)=0. - massfln(i,j,nall+6)=0. - massfln(i,j,nall+7)=0. - massfln(i,j,nall+8)=0. - massfln(i,j,nall+9)=0. - massfln(i,j,nall+10)=0. - massfln(i,j,nall+11)=0. - massfln(i,j,nall+12)=0. - massfln(i,j,nall+13)=0. - massfln(i,j,nall+14)=0. - massfln(i,j,nall+15)=0. - massfln(i,j,nall+16)=0. - endif - - endif - 350 continue -! ne=1, cap=175 -! - nall=(iens-1)*maxens3*maxens*maxens2 & - +(iedt-1)*maxens*maxens3 -! ne=2, cap=100 -! - nall2=(iens-1)*maxens3*maxens*maxens2 & - +(iedt-1)*maxens*maxens3 & - +(2-1)*maxens3 - xf_ens(i,j,nall+4) = xf_ens(i,j,nall2+4) - xf_ens(i,j,nall+5) =xf_ens(i,j,nall2+5) - xf_ens(i,j,nall+6) =xf_ens(i,j,nall2+6) - xf_ens(i,j,nall+14) =xf_ens(i,j,nall2+14) - xf_ens(i,j,nall+7) =xf_ens(i,j,nall2+7) - xf_ens(i,j,nall+8) =xf_ens(i,j,nall2+8) - xf_ens(i,j,nall+9) =xf_ens(i,j,nall2+9) - xf_ens(i,j,nall+15) =xf_ens(i,j,nall2+15) - xf_ens(i,j,nall+10)=xf_ens(i,j,nall2+10) - xf_ens(i,j,nall+11)=xf_ens(i,j,nall2+11) - xf_ens(i,j,nall+12)=xf_ens(i,j,nall2+12) - go to 100 - endif - elseif(ierr(i).ne.20.and.ierr(i).ne.0)then - do n=1,ensdim - xf_ens(i,j,n)=0. - massfln(i,j,n)=0. - enddo - endif - 100 continue - - END SUBROUTINE cup_forcing_ens_3d - - - SUBROUTINE cup_kbcon(cap_inc,iloop,k22,kbcon,he_cup,hes_cup, & - ierr,kbmax,p_cup,cap_max, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte - ! - ! - ! - ! ierr error value, maybe modified in this routine - ! - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - he_cup,hes_cup,p_cup - real, dimension (its:ite) & - ,intent (in ) :: & - cap_max,cap_inc - integer, dimension (its:ite) & - ,intent (in ) :: & - kbmax - integer, dimension (its:ite) & - ,intent (inout) :: & - kbcon,k22,ierr - integer & - ,intent (in ) :: & - iloop -! -! local variables in this routine -! - - integer :: & - i - real :: & - pbcdif,plus -! -!--- DETERMINE THE LEVEL OF CONVECTIVE CLOUD BASE - KBCON -! - DO 27 i=its,itf - kbcon(i)=1 - IF(ierr(I).ne.0)GO TO 27 - KBCON(I)=K22(I) - GO TO 32 - 31 CONTINUE - KBCON(I)=KBCON(I)+1 - IF(KBCON(I).GT.KBMAX(i)+2)THEN - if(iloop.lt.4)ierr(i)=3 -! if(iloop.lt.4)ierr(i)=997 - GO TO 27 - ENDIF - 32 CONTINUE - IF(HE_cup(I,K22(I)).LT.HES_cup(I,KBCON(I)))GO TO 31 - -! cloud base pressure and max moist static energy pressure -! i.e., the depth (in mb) of the layer of negative buoyancy - if(KBCON(I)-K22(I).eq.1)go to 27 - PBCDIF=-P_cup(I,KBCON(I))+P_cup(I,K22(I)) - plus=max(25.,cap_max(i)-float(iloop-1)*cap_inc(i)) - if(iloop.eq.4)plus=cap_max(i) - IF(PBCDIF.GT.plus)THEN - K22(I)=K22(I)+1 - KBCON(I)=K22(I) - GO TO 32 - ENDIF - 27 CONTINUE - - END SUBROUTINE cup_kbcon - - - SUBROUTINE cup_ktop(ilo,dby,kbcon,ktop,ierr, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE -! -! on input -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte - ! dby = buoancy term - ! ktop = cloud top (output) - ! ilo = flag - ! ierr error value, maybe modified in this routine - ! - real, dimension (its:ite,kts:kte) & - ,intent (inout) :: & - dby - integer, dimension (its:ite) & - ,intent (in ) :: & - kbcon - integer & - ,intent (in ) :: & - ilo - integer, dimension (its:ite) & - ,intent (out ) :: & - ktop - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr -! -! local variables in this routine -! - - integer :: & - i,k -! - DO 42 i=its,itf - ktop(i)=1 - IF(ierr(I).EQ.0)then - DO 40 K=KBCON(I)+1,ktf-1 - IF(DBY(I,K).LE.0.)THEN - KTOP(I)=K-1 - GO TO 41 - ENDIF - 40 CONTINUE - if(ilo.eq.1)ierr(i)=5 -! if(ilo.eq.2)ierr(i)=998 - GO TO 42 - 41 CONTINUE - do k=ktop(i)+1,ktf - dby(i,k)=0. - enddo - endif - 42 CONTINUE - - END SUBROUTINE cup_ktop - - - SUBROUTINE cup_MAXIMI(ARRAY,KS,KE,MAXX,ierr, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE -! -! on input -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte - ! array input array - ! x output array with return values - ! kt output array of levels - ! ks,kend check-range - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - array - integer, dimension (its:ite) & - ,intent (in ) :: & - ierr,ke - integer & - ,intent (in ) :: & - ks - integer, dimension (its:ite) & - ,intent (out ) :: & - maxx - real, dimension (its:ite) :: & - x - real :: & - xar - integer :: & - i,k - - DO 200 i=its,itf - MAXX(I)=KS - if(ierr(i).eq.0)then - X(I)=ARRAY(I,KS) -! - DO 100 K=KS,KE(i) - XAR=ARRAY(I,K) - IF(XAR.GE.X(I)) THEN - X(I)=XAR - MAXX(I)=K - ENDIF - 100 CONTINUE - endif - 200 CONTINUE - - END SUBROUTINE cup_MAXIMI - - - SUBROUTINE cup_minimi(ARRAY,KS,KEND,KT,ierr, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE -! -! on input -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte - ! array input array - ! x output array with return values - ! kt output array of levels - ! ks,kend check-range - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - array - integer, dimension (its:ite) & - ,intent (in ) :: & - ierr,ks,kend - integer, dimension (its:ite) & - ,intent (out ) :: & - kt - real, dimension (its:ite) :: & - x - integer :: & - i,k,kstop - - DO 200 i=its,itf - KT(I)=KS(I) - if(ierr(i).eq.0)then - X(I)=ARRAY(I,KS(I)) - KSTOP=MAX(KS(I)+1,KEND(I)) -! - DO 100 K=KS(I)+1,KSTOP - IF(ARRAY(I,K).LT.X(I)) THEN - X(I)=ARRAY(I,K) - KT(I)=K - ENDIF - 100 CONTINUE - endif - 200 CONTINUE - - END SUBROUTINE cup_MINIMI - - - SUBROUTINE cup_output_ens_3d(xf_ens,ierr,dellat,dellaq,dellaqc, & - subt_ens,subq_ens,subt,subq,outtem,outq,outqc, & - zu,sub_mas,pre,pw,xmb,ktop, & - j,name,nx,nx2,iens,ierr2,ierr3,pr_ens, & - maxens3,ensdim,massfln, & - APR_GR,APR_W,APR_MC,APR_ST,APR_AS, & - APR_CAPMA,APR_CAPME,APR_CAPMI,closure_n,xland1, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - - IMPLICIT NONE -! -! on input -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte - integer, intent (in ) :: & - j,ensdim,nx,nx2,iens,maxens3 - ! xf_ens = ensemble mass fluxes - ! pr_ens = precipitation ensembles - ! dellat = change of temperature per unit mass flux of cloud ensemble - ! dellaq = change of q per unit mass flux of cloud ensemble - ! dellaqc = change of qc per unit mass flux of cloud ensemble - ! outtem = output temp tendency (per s) - ! outq = output q tendency (per s) - ! outqc = output qc tendency (per s) - ! pre = output precip - ! xmb = total base mass flux - ! xfac1 = correction factor - ! pw = pw -epsilon*pd (ensemble dependent) - ! ierr error value, maybe modified in this routine - ! - real, dimension (its:ite,jts:jte,1:ensdim) & - ,intent (inout) :: & - xf_ens,pr_ens,massfln - real, dimension (its:ite,jts:jte) & - ,intent (inout) :: & - APR_GR,APR_W,APR_MC,APR_ST,APR_AS,APR_CAPMA, & - APR_CAPME,APR_CAPMI - - real, dimension (its:ite,kts:kte) & - ,intent (out ) :: & - outtem,outq,outqc,subt,subq,sub_mas - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - zu - real, dimension (its:ite) & - ,intent (out ) :: & - pre,xmb - real, dimension (its:ite) & - ,intent (inout ) :: & - closure_n,xland1 - real, dimension (its:ite,kts:kte,1:nx) & - ,intent (in ) :: & - subt_ens,subq_ens,dellat,dellaqc,dellaq,pw - integer, dimension (its:ite) & - ,intent (in ) :: & - ktop - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr,ierr2,ierr3 -! -! local variables in this routine -! - - integer :: & - i,k,n,ncount - real :: & - outtes,ddtes,dtt,dtq,dtqc,dtpw,tuning,prerate,clos_wei,xmbhelp - real :: & - dtts,dtqs - real, dimension (its:ite) :: & - xfac1,xfac2 - real, dimension (its:ite):: & - xmb_ske,xmb_ave,xmb_std,xmb_cur,xmbweight - real, dimension (its:ite):: & - pr_ske,pr_ave,pr_std,pr_cur - real, dimension (its:ite,jts:jte):: & - pr_gr,pr_w,pr_mc,pr_st,pr_as,pr_capma, & - pr_capme,pr_capmi - real, dimension (5) :: weight,wm,wm1,wm2,wm3 - real, dimension (its:ite,5) :: xmb_w - -! - character *(*), intent (in) :: & - name -! - weight(1) = -999. !this will turn off weights - wm(1)=-999. - - tuning=0. -! -! - DO k=kts,ktf - do i=its,itf - outtem(i,k)=0. - outq(i,k)=0. - outqc(i,k)=0. - subt(i,k)=0. - subq(i,k)=0. - sub_mas(i,k)=0. - enddo - enddo - do i=its,itf - pre(i)=0. - xmb(i)=0. - xfac1(i)=0. - xfac2(i)=0. - xmbweight(i)=1. - enddo - do i=its,itf - IF(ierr(i).eq.0)then - do n=(iens-1)*nx*nx2*maxens3+1,iens*nx*nx2*maxens3 - if(pr_ens(i,j,n).le.0.)then - xf_ens(i,j,n)=0. - endif - enddo - endif - enddo -! -!--- calculate ensemble average mass fluxes -! - call massflx_stats(xf_ens,ensdim,nx2,nx,maxens3, & - xmb_ave,xmb_std,xmb_cur,xmb_ske,j,ierr,1, & - APR_GR,APR_W,APR_MC,APR_ST,APR_AS, & - APR_CAPMA,APR_CAPME,APR_CAPMI, & - pr_gr,pr_w,pr_mc,pr_st,pr_as, & - pr_capma,pr_capme,pr_capmi, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte ) - xmb_w=0. - call massflx_stats(pr_ens,ensdim,nx2,nx,maxens3, & - pr_ave,pr_std,pr_cur,pr_ske,j,ierr,2, & - APR_GR,APR_W,APR_MC,APR_ST,APR_AS, & - APR_CAPMA,APR_CAPME,APR_CAPMI, & - pr_gr,pr_w,pr_mc,pr_st,pr_as, & - pr_capma,pr_capme,pr_capmi, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte ) -! -!-- now do feedback -! - ddtes=100. - do i=its,itf - if(ierr(i).eq.0)then - if(xmb_ave(i).le.0.)then - ierr(i)=13 - xmb_ave(i)=0. - endif - xmb(i)=max(.1*xmb_ave(i),xmb_ave(i)-tuning*xmb_std(i)) -! --- Now use proper count of how many closures were actually -! used in cup_forcing_ens (including screening of some -! closures over water) to properly normalize xmb - clos_wei=16./max(1.,closure_n(i)) - if (xland1(i).lt.0.5)xmb(i)=xmb(i)*clos_wei - if(xmb(i).eq.0.)then - ierr(i)=19 - endif - if(xmb(i).gt.100.)then - ierr(i)=19 - endif - xfac1(i)=xmb(i) - xfac2(i)=xmb(i) - - endif -! if(weight(1).lt.-100.)xfac1(i)=xmb_ave(i) -! if(weight(1).lt.-100.)xfac2(i)=xmb_ave(i) - ENDDO - DO k=kts,ktf - do i=its,itf - dtt=0. - dtts=0. - dtq=0. - dtqs=0. - dtqc=0. - dtpw=0. - IF(ierr(i).eq.0.and.k.le.ktop(i))then - do n=1,nx - dtt=dtt+dellat(i,k,n) - dtts=dtts+subt_ens(i,k,n) - dtq=dtq+dellaq(i,k,n) - dtqs=dtqs+subq_ens(i,k,n) - dtqc=dtqc+dellaqc(i,k,n) - dtpw=dtpw+pw(i,k,n) - enddo - OUTTEM(I,K)=XMB(I)*dtt/float(nx) - SUBT(I,K)=XMB(I)*dtts/float(nx) - OUTQ(I,K)=XMB(I)*dtq/float(nx) - SUBQ(I,K)=XMB(I)*dtqs/float(nx) - OUTQC(I,K)=XMB(I)*dtqc/float(nx) - PRE(I)=PRE(I)+XMB(I)*dtpw/float(nx) - sub_mas(i,k)=zu(i,k)*xmb(i) - endif - enddo - enddo - - do i=its,itf - if(ierr(i).eq.0)then - do k=(iens-1)*nx*nx2*maxens3+1,iens*nx*nx2*maxens3 - massfln(i,j,k)=massfln(i,j,k)*xfac1(i) - xf_ens(i,j,k)=xf_ens(i,j,k)*xfac1(i) - enddo - endif - ENDDO - - END SUBROUTINE cup_output_ens_3d - - - SUBROUTINE cup_up_aa0(aa0,z,zu,dby,GAMMA_CUP,t_cup, & - kbcon,ktop,ierr, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE -! -! on input -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte - ! aa0 cloud work function - ! gamma_cup = gamma on model cloud levels - ! t_cup = temperature (Kelvin) on model cloud levels - ! dby = buoancy term - ! zu= normalized updraft mass flux - ! z = heights of model levels - ! ierr error value, maybe modified in this routine - ! - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - z,zu,gamma_cup,t_cup,dby - integer, dimension (its:ite) & - ,intent (in ) :: & - kbcon,ktop -! -! input and output -! - - - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr - real, dimension (its:ite) & - ,intent (out ) :: & - aa0 -! -! local variables in this routine -! - - integer :: & - i,k - real :: & - dz,da -! - do i=its,itf - aa0(i)=0. - enddo - DO 100 k=kts+1,ktf - DO 100 i=its,itf - IF(ierr(i).ne.0)GO TO 100 - IF(K.LE.KBCON(I))GO TO 100 - IF(K.Gt.KTOP(I))GO TO 100 - DZ=Z(I,K)-Z(I,K-1) - da=zu(i,k)*DZ*(9.81/(1004.*( & - (T_cup(I,K)))))*DBY(I,K-1)/ & - (1.+GAMMA_CUP(I,K)) - IF(K.eq.KTOP(I).and.da.le.0.)go to 100 - AA0(I)=AA0(I)+da - if(aa0(i).lt.0.)aa0(i)=0. -100 continue - - END SUBROUTINE cup_up_aa0 - - - SUBROUTINE cup_up_he(k22,hkb,z_cup,cd,entr,he_cup,hc, & - kbcon,ierr,dby,he,hes_cup, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE -! -! on input -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte - ! hc = cloud moist static energy - ! hkb = moist static energy at originating level - ! he = moist static energy on model levels - ! he_cup = moist static energy on model cloud levels - ! hes_cup = saturation moist static energy on model cloud levels - ! dby = buoancy term - ! cd= detrainment function - ! z_cup = heights of model cloud levels - ! entr = entrainment rate - ! - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - he,he_cup,hes_cup,z_cup,cd - ! entr= entrainment rate - real & - ,intent (in ) :: & - entr - integer, dimension (its:ite) & - ,intent (in ) :: & - kbcon,k22 -! -! input and output -! - - ! ierr error value, maybe modified in this routine - - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr - - real, dimension (its:ite,kts:kte) & - ,intent (out ) :: & - hc,dby - real, dimension (its:ite) & - ,intent (out ) :: & - hkb -! -! local variables in this routine -! - - integer :: & - i,k - real :: & - dz -! -!--- moist static energy inside cloud -! - do k=kts,ktf - do i=its,itf - hc(i,k)=0. - DBY(I,K)=0. - enddo - enddo - do i=its,itf - hkb(i)=0. - enddo - do i=its,itf - if(ierr(i).eq.0.)then - hkb(i)=he_cup(i,k22(i)) - do k=1,k22(i) - hc(i,k)=he_cup(i,k) -! DBY(I,K)=0. - enddo - do k=k22(i),kbcon(i)-1 - hc(i,k)=hkb(i) -! DBY(I,K)=0. - enddo - k=kbcon(i) - hc(i,k)=hkb(i) - DBY(I,Kbcon(i))=Hkb(I)-HES_cup(I,K) - endif - enddo - do k=kts+1,ktf - do i=its,itf - if(k.gt.kbcon(i).and.ierr(i).eq.0.)then - DZ=Z_cup(i,K)-Z_cup(i,K-1) - HC(i,K)=(HC(i,K-1)*(1.-.5*CD(i,K)*DZ)+entr* & - DZ*HE(i,K-1))/(1.+entr*DZ-.5*cd(i,k)*dz) - DBY(I,K)=HC(I,K)-HES_cup(I,K) - endif - enddo - - enddo - - END SUBROUTINE cup_up_he - - - SUBROUTINE cup_up_moisture(ierr,z_cup,qc,qrc,pw,pwav, & - kbcon,ktop,cd,dby,mentr_rate,clw_all, & - q,GAMMA_cup,zu,qes_cup,k22,qe_cup,xl, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE -! -! on input -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte - ! cd= detrainment function - ! q = environmental q on model levels - ! qe_cup = environmental q on model cloud levels - ! qes_cup = saturation q on model cloud levels - ! dby = buoancy term - ! cd= detrainment function - ! zu = normalized updraft mass flux - ! gamma_cup = gamma on model cloud levels - ! mentr_rate = entrainment rate - ! - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - q,zu,gamma_cup,qe_cup,dby,qes_cup,z_cup,cd - ! entr= entrainment rate - real & - ,intent (in ) :: & - mentr_rate,xl - integer, dimension (its:ite) & - ,intent (in ) :: & - kbcon,ktop,k22 -! -! input and output -! - - ! ierr error value, maybe modified in this routine - - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr - ! qc = cloud q (including liquid water) after entrainment - ! qrch = saturation q in cloud - ! qrc = liquid water content in cloud after rainout - ! pw = condensate that will fall out at that level - ! pwav = totan normalized integrated condensate (I1) - ! c0 = conversion rate (cloud to rain) - - real, dimension (its:ite,kts:kte) & - ,intent (out ) :: & - qc,qrc,pw,clw_all - real, dimension (its:ite) & - ,intent (out ) :: & - pwav -! -! local variables in this routine -! - - integer :: & - iall,i,k - real :: & - dh,qrch,c0,dz,radius -! - iall=0 - c0=.002 -! -!--- no precip for small clouds -! - if(mentr_rate.gt.0.)then - radius=.2/mentr_rate - if(radius.lt.900.)c0=0. -! if(radius.lt.900.)iall=0 - endif - do i=its,itf - pwav(i)=0. - enddo - do k=kts,ktf - do i=its,itf - pw(i,k)=0. - qc(i,k)=0. - if(ierr(i).eq.0)qc(i,k)=qes_cup(i,k) - clw_all(i,k)=0. - qrc(i,k)=0. - enddo - enddo - do i=its,itf - if(ierr(i).eq.0.)then - do k=k22(i),kbcon(i)-1 - qc(i,k)=qe_cup(i,k22(i)) - enddo - endif - enddo - - DO 100 k=kts+1,ktf - DO 100 i=its,itf - IF(ierr(i).ne.0)GO TO 100 - IF(K.Lt.KBCON(I))GO TO 100 - IF(K.Gt.KTOP(I))GO TO 100 - DZ=Z_cup(i,K)-Z_cup(i,K-1) -! -!------ 1. steady state plume equation, for what could -!------ be in cloud without condensation -! -! - QC(i,K)=(QC(i,K-1)*(1.-.5*CD(i,K)*DZ)+mentr_rate* & - DZ*Q(i,K-1))/(1.+mentr_rate*DZ-.5*cd(i,k)*dz) -! -!--- saturation in cloud, this is what is allowed to be in it -! - QRCH=QES_cup(I,K)+(1./XL)*(GAMMA_cup(i,k) & - /(1.+GAMMA_cup(i,k)))*DBY(I,K) -! -!------- LIQUID WATER CONTENT IN cloud after rainout -! - clw_all(i,k)=QC(I,K)-QRCH - QRC(I,K)=(QC(I,K)-QRCH)/(1.+C0*DZ) - if(qrc(i,k).lt.0.)then - qrc(i,k)=0. - endif -! -!------- 3.Condensation -! - PW(i,k)=c0*dz*QRC(I,K)*zu(i,k) - if(iall.eq.1)then - qrc(i,k)=0. - pw(i,k)=(QC(I,K)-QRCH)*zu(i,k) - if(pw(i,k).lt.0.)pw(i,k)=0. - endif -! -!----- set next level -! - QC(I,K)=QRC(I,K)+qrch -! -!--- integrated normalized ondensate -! - PWAV(I)=PWAV(I)+PW(I,K) - 100 CONTINUE - - END SUBROUTINE cup_up_moisture - - - SUBROUTINE cup_up_nms(zu,z_cup,entr,cd,kbcon,ktop,ierr,k22, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE - -! -! on input -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte - ! cd= detrainment function - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - z_cup,cd - ! entr= entrainment rate - real & - ,intent (in ) :: & - entr - integer, dimension (its:ite) & - ,intent (in ) :: & - kbcon,ktop,k22 -! -! input and output -! - - ! ierr error value, maybe modified in this routine - - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr - ! zu is the normalized mass flux - - real, dimension (its:ite,kts:kte) & - ,intent (out ) :: & - zu -! -! local variables in this routine -! - - integer :: & - i,k - real :: & - dz -! -! initialize for this go around -! - do k=kts,ktf - do i=its,itf - zu(i,k)=0. - enddo - enddo -! -! do normalized mass budget -! - do i=its,itf - IF(ierr(I).eq.0)then - do k=k22(i),kbcon(i) - zu(i,k)=1. - enddo - DO K=KBcon(i)+1,KTOP(i) - DZ=Z_cup(i,K)-Z_cup(i,K-1) - ZU(i,K)=ZU(i,K-1)*(1.+(entr-cd(i,k))*DZ) - enddo - endif - enddo - - END SUBROUTINE cup_up_nms - -!==================================================================== - SUBROUTINE g3init(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN, & - MASS_FLUX,cp,restart, & - P_QC,P_QI,P_FIRST_SCALAR, & - RTHFTEN, RQVFTEN, & - APR_GR,APR_W,APR_MC,APR_ST,APR_AS, & - APR_CAPMA,APR_CAPME,APR_CAPMI, & - cugd_tten,cugd_ttens,cugd_qvten, & - cugd_qvtens,cugd_qcten, & - allowed_to_read, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte ) -!-------------------------------------------------------------------- - IMPLICIT NONE -!-------------------------------------------------------------------- - LOGICAL , INTENT(IN) :: restart,allowed_to_read - INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte - INTEGER , INTENT(IN) :: P_FIRST_SCALAR, P_QI, P_QC - REAL, INTENT(IN) :: cp - - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: & - CUGD_TTEN, & - CUGD_TTENS, & - CUGD_QVTEN, & - CUGD_QVTENS, & - CUGD_QCTEN - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: & - RTHCUTEN, & - RQVCUTEN, & - RQCCUTEN, & - RQICUTEN - - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: & - RTHFTEN, & - RQVFTEN - - REAL, DIMENSION( ims:ime , jms:jme ) , INTENT(OUT) :: & - APR_GR,APR_W,APR_MC,APR_ST,APR_AS, & - APR_CAPMA,APR_CAPME,APR_CAPMI, & - MASS_FLUX - - INTEGER :: i, j, k, itf, jtf, ktf - - jtf=min0(jte,jde-1) - ktf=min0(kte,kde-1) - itf=min0(ite,ide-1) - - IF(.not.restart)THEN - DO j=jts,jte - DO k=kts,kte - DO i=its,ite - RTHCUTEN(i,k,j)=0. - RQVCUTEN(i,k,j)=0. - ENDDO - ENDDO - ENDDO - DO j=jts,jte - DO k=kts,kte - DO i=its,ite - cugd_tten(i,k,j)=0. - cugd_ttens(i,k,j)=0. - cugd_qvten(i,k,j)=0. - cugd_qvtens(i,k,j)=0. - ENDDO - ENDDO - ENDDO - - DO j=jts,jtf - DO k=kts,ktf - DO i=its,itf - RTHFTEN(i,k,j)=0. - RQVFTEN(i,k,j)=0. - ENDDO - ENDDO - ENDDO - - IF (P_QC .ge. P_FIRST_SCALAR) THEN - DO j=jts,jtf - DO k=kts,ktf - DO i=its,itf - RQCCUTEN(i,k,j)=0. - cugd_qcten(i,k,j)=0. - ENDDO - ENDDO - ENDDO - ENDIF - - IF (P_QI .ge. P_FIRST_SCALAR) THEN - DO j=jts,jtf - DO k=kts,ktf - DO i=its,itf - RQICUTEN(i,k,j)=0. - ENDDO - ENDDO - ENDDO - ENDIF - - DO j=jts,jtf - DO i=its,itf - mass_flux(i,j)=0. - ENDDO - ENDDO - - ENDIF - DO j=jts,jtf - DO i=its,itf - APR_GR(i,j)=0. - APR_ST(i,j)=0. - APR_W(i,j)=0. - APR_MC(i,j)=0. - APR_AS(i,j)=0. - APR_CAPMA(i,j)=0. - APR_CAPME(i,j)=0. - APR_CAPMI(i,j)=0. - ENDDO - ENDDO - - END SUBROUTINE g3init - - - SUBROUTINE massflx_stats(xf_ens,ensdim,maxens,maxens2,maxens3, & - xt_ave,xt_std,xt_cur,xt_ske,j,ierr,itest, & - APR_GR,APR_W,APR_MC,APR_ST,APR_AS, & - APR_CAPMA,APR_CAPME,APR_CAPMI, & - pr_gr,pr_w,pr_mc,pr_st,pr_as, & - pr_capma,pr_capme,pr_capmi, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - - IMPLICIT NONE - - integer, intent (in ) :: & - j,ensdim,maxens3,maxens,maxens2,itest - INTEGER, INTENT(IN ) :: & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte - - - real, dimension (its:ite) & - , intent(inout) :: & - xt_ave,xt_cur,xt_std,xt_ske - integer, dimension (its:ite), intent (in) :: & - ierr - real, dimension (its:ite,jts:jte,1:ensdim) & - , intent(in ) :: & - xf_ens - real, dimension (its:ite,jts:jte) & - , intent(inout) :: & - APR_GR,APR_W,APR_MC,APR_ST,APR_AS, & - APR_CAPMA,APR_CAPME,APR_CAPMI - real, dimension (its:ite,jts:jte) & - , intent(inout) :: & - pr_gr,pr_w,pr_mc,pr_st,pr_as, & - pr_capma,pr_capme,pr_capmi - -! -! local stuff -! - real, dimension (its:ite , 1:maxens3 ) :: & - x_ave,x_cur,x_std,x_ske - real, dimension (its:ite , 1:maxens ) :: & - x_ave_cap - - - integer, dimension (1:maxens3) :: nc1 - integer :: i,k - integer :: num,kk,num2,iedt - real :: a3,a4 - - num=ensdim/maxens3 - num2=ensdim/maxens - if(itest.eq.1)then - do i=its,ite - pr_gr(i,j) = 0. - pr_w(i,j) = 0. - pr_mc(i,j) = 0. - pr_st(i,j) = 0. - pr_as(i,j) = 0. - pr_capma(i,j) = 0. - pr_capme(i,j) = 0. - pr_capmi(i,j) = 0. - enddo - endif - - do k=1,maxens - do i=its,ite - x_ave_cap(i,k)=0. - enddo - enddo - do k=1,maxens3 - do i=its,ite - x_ave(i,k)=0. - x_std(i,k)=0. - x_ske(i,k)=0. - x_cur(i,k)=0. - enddo - enddo - do i=its,ite - xt_ave(i)=0. - xt_std(i)=0. - xt_ske(i)=0. - xt_cur(i)=0. - enddo - do kk=1,num - do k=1,maxens3 - do i=its,ite - if(ierr(i).eq.0)then - x_ave(i,k)=x_ave(i,k)+xf_ens(i,j,maxens3*(kk-1)+k) - endif - enddo - enddo - enddo - do iedt=1,maxens2 - do k=1,maxens - do kk=1,maxens3 - do i=its,ite - if(ierr(i).eq.0)then - x_ave_cap(i,k)=x_ave_cap(i,k) & - +xf_ens(i,j,maxens3*(k-1)+(iedt-1)*maxens*maxens3+kk) - endif - enddo - enddo - enddo - enddo - do k=1,maxens - do i=its,ite - if(ierr(i).eq.0)then - x_ave_cap(i,k)=x_ave_cap(i,k)/float(num2) - endif - enddo - enddo - - do k=1,maxens3 - do i=its,ite - if(ierr(i).eq.0)then - x_ave(i,k)=x_ave(i,k)/float(num) - endif - enddo - enddo - do k=1,maxens3 - do i=its,ite - if(ierr(i).eq.0)then - xt_ave(i)=xt_ave(i)+x_ave(i,k) - endif - enddo - enddo - do i=its,ite - if(ierr(i).eq.0)then - xt_ave(i)=xt_ave(i)/float(maxens3) - endif - enddo -! -!--- now do std, skewness,curtosis -! - do kk=1,num - do k=1,maxens3 - do i=its,ite - if(ierr(i).eq.0.and.x_ave(i,k).gt.0.)then -! print *,i,j,k,kk,x_std(i,k),xf_ens(i,j,maxens3*(kk-1)+k),x_ave(i,k) - x_std(i,k)=x_std(i,k)+(xf_ens(i,j,maxens3*(kk-1)+k)-x_ave(i,k))**2 - x_ske(i,k)=x_ske(i,k)+(xf_ens(i,j,maxens3*(kk-1)+k)-x_ave(i,k))**3 - x_cur(i,k)=x_cur(i,k)+(xf_ens(i,j,maxens3*(kk-1)+k)-x_ave(i,k))**4 - endif - enddo - enddo - enddo - do k=1,maxens3 - do i=its,ite - if(ierr(i).eq.0.and.xt_ave(i).gt.0.)then - xt_std(i)=xt_std(i)+(x_ave(i,k)-xt_ave(i))**2 - xt_ske(i)=xt_ske(i)+(x_ave(i,k)-xt_ave(i))**3 - xt_cur(i)=xt_cur(i)+(x_ave(i,k)-xt_ave(i))**4 - endif - enddo - enddo - do k=1,maxens3 - do i=its,ite - if(ierr(i).eq.0.and.x_std(i,k).gt.0.)then - x_std(i,k)=x_std(i,k)/float(num) - a3=max(1.e-6,x_std(i,k)) - x_std(i,k)=sqrt(a3) - a3=max(1.e-6,x_std(i,k)**3) - a4=max(1.e-6,x_std(i,k)**4) - x_ske(i,k)=x_ske(i,k)/float(num)/a3 - x_cur(i,k)=x_cur(i,k)/float(num)/a4 - endif -! print*,' ' -! print*,'Some statistics at gridpoint i,j, ierr',i,j,ierr(i) -! print*,'statistics for closure number ',k -! print*,'Average= ',x_ave(i,k),' Std= ',x_std(i,k) -! print*,'Skewness= ',x_ske(i,k),' Curtosis= ',x_cur(i,k) -! print*,' ' - - enddo - enddo - do i=its,ite - if(ierr(i).eq.0.and.xt_std(i).gt.0.)then - xt_std(i)=xt_std(i)/float(maxens3) - a3=max(1.e-6,xt_std(i)) - xt_std(i)=sqrt(a3) - a3=max(1.e-6,xt_std(i)**3) - a4=max(1.e-6,xt_std(i)**4) - xt_ske(i)=xt_ske(i)/float(maxens3)/a3 - xt_cur(i)=xt_cur(i)/float(maxens3)/a4 -! print*,' ' -! print*,'Total ensemble independent statistics at i =',i -! print*,'Average= ',xt_ave(i),' Std= ',xt_std(i) -! print*,'Skewness= ',xt_ske(i),' Curtosis= ',xt_cur(i) -! print*,' ' -! -! first go around: store massflx for different closures/caps -! - if(itest.eq.1)then - pr_gr(i,j) = .25*(x_ave(i,1)+x_ave(i,2)+x_ave(i,3)+x_ave(i,13)) - pr_w(i,j) = .25*(x_ave(i,4)+x_ave(i,5)+x_ave(i,6)+x_ave(i,14)) - pr_mc(i,j) = .25*(x_ave(i,7)+x_ave(i,8)+x_ave(i,9)+x_ave(i,15)) - pr_st(i,j) = .333*(x_ave(i,10)+x_ave(i,11)+x_ave(i,12)) - pr_as(i,j) = x_ave(i,16) - pr_capma(i,j) = x_ave_cap(i,1) - pr_capme(i,j) = x_ave_cap(i,2) - pr_capmi(i,j) = x_ave_cap(i,3) -! -! second go around: store preciprates (mm/hour) for different closures/caps -! - else if (itest.eq.2)then - APR_GR(i,j)=.25*(x_ave(i,1)+x_ave(i,2)+x_ave(i,3)+x_ave(i,13))* & - 3600.*pr_gr(i,j) +APR_GR(i,j) - APR_W(i,j)=.25*(x_ave(i,4)+x_ave(i,5)+x_ave(i,6)+x_ave(i,14))* & - 3600.*pr_w(i,j) +APR_W(i,j) - APR_MC(i,j)=.25*(x_ave(i,7)+x_ave(i,8)+x_ave(i,9)+x_ave(i,15))* & - 3600.*pr_mc(i,j) +APR_MC(i,j) - APR_ST(i,j)=.333*(x_ave(i,10)+x_ave(i,11)+x_ave(i,12))* & - 3600.*pr_st(i,j) +APR_ST(i,j) - APR_AS(i,j)=x_ave(i,16)* & - 3600.*pr_as(i,j) +APR_AS(i,j) - APR_CAPMA(i,j) = x_ave_cap(i,1)* & - 3600.*pr_capma(i,j) +APR_CAPMA(i,j) - APR_CAPME(i,j) = x_ave_cap(i,2)* & - 3600.*pr_capme(i,j) +APR_CAPME(i,j) - APR_CAPMI(i,j) = x_ave_cap(i,3)* & - 3600.*pr_capmi(i,j) +APR_CAPMI(i,j) - endif - endif - enddo - - END SUBROUTINE massflx_stats - - SUBROUTINE cup_axx(tcrit,kbmax,z1,p,psur,xl,rv,cp,tx,qx,axx,ierr, & - cap_max,cap_max_increment,entr_rate,mentr_rate,& - j,itf,jtf,ktf, & - its,ite, jts,jte, kts,kte,ens4) - IMPLICIT NONE - INTEGER, INTENT(IN ) :: & - j,itf,jtf,ktf, & - its,ite, jts,jte, kts,kte,ens4 - real, dimension (its:ite,kts:kte,1:ens4) & - , intent(inout) :: & - tx,qx - real, dimension (its:ite,kts:kte) & - , intent(in) :: & - p - real, dimension (its:ite) & - , intent(in) :: & - z1,psur,cap_max,cap_max_increment - real, intent(in) :: & - tcrit,xl,rv,cp,mentr_rate,entr_rate - real, dimension (its:ite,1:ens4) & - , intent(out) :: & - axx - integer, dimension (its:ite), intent (in) :: & - ierr,kbmax - integer, dimension (its:ite) :: & - ierrxx,k22xx,kbconxx,ktopxx,kstabm,kstabi - real, dimension (1:2) :: AE,BE,HT - real, dimension (its:ite,kts:kte) :: tv - real :: e,tvbar - integer n,i,k,iph - real, dimension (its:ite,kts:kte) :: & - he,hes,qes,z, & - qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup, & - tn_cup, & - dby,qc,qrcd,pwd,pw,hcd,qcd,dbyd,hc,qrc,zu,zd,cd - - real, dimension (its:ite) :: & - AA0,HKB,QKB, & - PWAV,BU - do n=1,ens4 - do i=its,ite - axx(i,n)=0. - enddo - enddo - HT(1)=XL/CP - HT(2)=2.834E6/CP - BE(1)=.622*HT(1)/.286 - AE(1)=BE(1)/273.+ALOG(610.71) - BE(2)=.622*HT(2)/.286 - AE(2)=BE(2)/273.+ALOG(610.71) -! -! - do 100 n=1,ens4 - - do k=kts,ktf - do i=its,itf - cd(i,k)=0.1*entr_rate - enddo - enddo - - - do i=its,itf - ierrxx(i)=ierr(i) - k22xx(i)=1 - kbconxx(i)=1 - ktopxx(i)=1 - kstabm(i)=ktf-1 - enddo - DO k=kts,ktf - do i=its,itf - if(ierrxx(i).eq.0)then - IPH=1 - IF(Tx(I,K,n).LE.TCRIT)IPH=2 - E=EXP(AE(IPH)-BE(IPH)/TX(I,K,N)) - QES(I,K)=.622*E/(100.*P(I,K)-E) - IF(QES(I,K).LE.1.E-08)QES(I,K)=1.E-08 - IF(Qx(I,K,N).GT.QES(I,K))Qx(I,K,N)=QES(I,K) - TV(I,K)=Tx(I,K,N)+.608*Qx(I,K,N)*Tx(I,K,N) - endif - enddo - enddo -! - do i=its,itf - if(ierrxx(i).eq.0)then - Z(I,KTS)=max(0.,Z1(I))-(ALOG(P(I,KTS))- & - ALOG(PSUR(I)))*287.*TV(I,KTS)/9.81 - endif - enddo - -! --- calculate heights - DO K=kts+1,ktf - do i=its,itf - if(ierrxx(i).eq.0)then - TVBAR=.5*TV(I,K)+.5*TV(I,K-1) - Z(I,K)=Z(I,K-1)-(ALOG(P(I,K))- & - ALOG(P(I,K-1)))*287.*TVBAR/9.81 - endif - enddo - enddo -! -!--- calculate moist static energy - HE -! saturated moist static energy - HES -! - DO k=kts,ktf - do i=its,itf - if(ierrxx(i).eq.0)then - HE(I,K)=9.81*Z(I,K)+1004.*Tx(I,K,n)+2.5E06*Qx(I,K,n) - HES(I,K)=9.81*Z(I,K)+1004.*Tx(I,K,n)+2.5E06*QES(I,K) - IF(HE(I,K).GE.HES(I,K))HE(I,K)=HES(I,K) - endif - enddo - enddo - -! cup levels -! - do k=kts+1,ktf - do i=its,itf - if(ierrxx(i).eq.0)then - qes_cup(i,k)=.5*(qes(i,k-1)+qes(i,k)) - q_cup(i,k)=.5*(qx(i,k-1,n)+qx(i,k,n)) - hes_cup(i,k)=.5*(hes(i,k-1)+hes(i,k)) - he_cup(i,k)=.5*(he(i,k-1)+he(i,k)) - if(he_cup(i,k).gt.hes_cup(i,k))he_cup(i,k)=hes_cup(i,k) - z_cup(i,k)=.5*(z(i,k-1)+z(i,k)) - p_cup(i,k)=.5*(p(i,k-1)+p(i,k)) - t_cup(i,k)=.5*(tx(i,k-1,n)+tx(i,k,n)) - gamma_cup(i,k)=(xl/cp)*(xl/(rv*t_cup(i,k) & - *t_cup(i,k)))*qes_cup(i,k) - endif - enddo - enddo - do i=its,itf - if(ierrxx(i).eq.0)then - qes_cup(i,1)=qes(i,1) - q_cup(i,1)=qx(i,1,n) - hes_cup(i,1)=hes(i,1) - he_cup(i,1)=he(i,1) - z_cup(i,1)=.5*(z(i,1)+z1(i)) - p_cup(i,1)=.5*(p(i,1)+psur(i)) - t_cup(i,1)=tx(i,1,n) - gamma_cup(i,1)=xl/cp*(xl/(rv*t_cup(i,1) & - *t_cup(i,1)))*qes_cup(i,1) - endif - enddo -! -! -!------- DETERMINE LEVEL WITH HIGHEST MOIST STATIC ENERGY CONTENT - K22 -! - CALL cup_MAXIMI(HE_CUP,3,KBMAX,K22XX,ierrxx, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - DO 36 i=its,itf - IF(ierrxx(I).eq.0.)THEN - IF(K22xx(I).GE.KBMAX(i))ierrxx(i)=2 - endif - 36 CONTINUE -! -!--- DETERMINE THE LEVEL OF CONVECTIVE CLOUD BASE - KBCON -! - call cup_kbcon(cap_max_increment,1,k22xx,kbconxx,he_cup,hes_cup, & - ierrxx,kbmax,p_cup,cap_max, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) -! -!--- increase detrainment in stable layers -! - CALL cup_minimi(HEs_cup,Kbconxx,kstabm,kstabi,ierrxx, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - do i=its,itf - IF(ierrxx(I).eq.0.)THEN - if(kstabm(i)-1.gt.kstabi(i))then - do k=kstabi(i),kstabm(i)-1 - cd(i,k)=cd(i,k-1)+1.5*entr_rate - if(cd(i,k).gt.10.0*entr_rate)cd(i,k)=10.0*entr_rate - enddo - ENDIF - ENDIF - ENDDO -! -!--- calculate incloud moist static energy -! - call cup_up_he(k22xx,hkb,z_cup,cd,mentr_rate,he_cup,hc, & - kbconxx,ierrxx,dby,he,hes_cup, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - -!--- DETERMINE CLOUD TOP - KTOP -! - call cup_ktop(1,dby,kbconxx,ktopxx,ierrxx, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) -! -!c--- normalized updraft mass flux profile -! - call cup_up_nms(zu,z_cup,mentr_rate,cd,kbconxx,ktopxx,ierrxx,k22xx, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) -! -!--- calculate workfunctions for updrafts -! - call cup_up_aa0(aa0,z,zu,dby,GAMMA_CUP,t_cup, & - kbconxx,ktopxx,ierrxx, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte) - do i=its,itf - if(ierrxx(i).eq.0)axx(i,n)=aa0(i) - enddo -100 continue - END SUBROUTINE cup_axx - - SUBROUTINE conv_grell_spread3d(rthcuten,rqvcuten,rqccuten,raincv, & - & cugd_avedx,cugd_tten,cugd_qvten,rqicuten,cugd_ttens, & - & cugd_qvtens,cugd_qcten,pi_phy,moist_qv,pratec,dt,num_tiles,& - & imomentum,F_QV ,F_QC ,F_QR ,F_QI ,F_QS, & - & ids, ide, jds, jde, kds, kde, & - & ips, ipe, jps, jpe, kps, kpe, & - & ims, ime, jms, jme, kms, kme, & - & i_start,i_end,j_start,j_end,kts,kte ) - -! - - INTEGER, INTENT(IN ) :: num_tiles,imomentum - INTEGER, DIMENSION(num_tiles), INTENT(IN) :: & - & i_start,i_end,j_start,j_end - INTEGER, INTENT(IN ) :: ids, ide, jds, jde, kds, kde,& - ims,ime, jms,jme, kms,kme, & - ips,ipe, jps,jpe, kps,kpe, & - kts,kte,cugd_avedx - REAL, DIMENSION (ims:ime,kms:kme,jms:jme), optional,INTENT (INOUT) :: & - & rthcuten,rqvcuten,rqccuten,rqicuten,cugd_tten, & - & cugd_qvten,cugd_ttens,cugd_qvtens,cugd_qcten - REAL, DIMENSION (ims:ime,kms:kme,jms:jme),INTENT (IN) :: & - moist_qv - REAL, DIMENSION (ims:ime,kms:kme,jms:jme), INTENT (IN) :: & - PI_PHY - REAL, DIMENSION (ims:ime,jms:jme), INTENT (INOUT) :: & - RAINCV,PRATEC - REAL, INTENT(IN) :: dt - INTEGER :: ikk1,ikk2,ikk11,i,j,k,kk,nn,smoothh,smoothv - INTEGER :: ifs,ife,jfs,jfe,its,ite,jts,jte,ido,jdo,cugd_spread - LOGICAL :: new -! -! Flags relating to the optional tendency arrays declared above -! Models that carry the optional tendencies will provdide the -! optional arguments at compile time; these flags all the model -! to determine at run-time whether a particular tracer is in -! use or not. -! - LOGICAL, OPTIONAL :: & - F_QV & - ,F_QC & - ,F_QR & - ,F_QI & - ,F_QS - REAL, DIMENSION (ips-2:ipe+2,kps:kpe,jps-2:jpe+2) :: & - rthcutent,rqvcutent - real, dimension (ips-2:ipe+2,jps-2:jpe+2) :: qmem - real, dimension (ips-1:ipe+1,jps-1:jpe+1) :: smtt,smtq - real, dimension (kts:kte) :: conv_trasht,conv_trashq - REAL :: qmem1,qmem2,qmemf,thresh - smoothh=1 - smoothv=1 - cugd_spread=cugd_avedx/2 -! SET START AND END POINTS FOR TILES - !$OMP PARALLEL DO & - !$OMP PRIVATE ( ij ,ifs,ife,jfs,jfe,its,ite,jts,jte, i,j,k,ikk1,ikk2,ikk11,qmemf,qmem1,qmem2,qmem) - - DO ij = 1 , num_tiles - its = i_start(ij) - ite = min(i_end(ij),ide-1) - jts = j_start(ij) - jte = min(j_end(ij),jde-1) - - do j=jts-2,jte+2 - do i=its-2,ite+2 - qmem(i,j)=1. - enddo - enddo - do j=jps-1,jpe+1 - do i=ips-1,ipe+1 - smtt(i,j)=0. - smtq(i,j)=0. - enddo - enddo - do j=jts,jte - do k=kts,kte - do i=its,ite - rthcuten(i,k,j)=0. - rqvcuten(i,k,j)=0. - enddo - enddo - enddo - do j=jps-2,jpe+2 - do k=kts,kte - do i=ips-2,ipe+2 - rthcutent(i,k,j)=0. - rqvcutent(i,k,j)=0. - enddo - enddo - enddo -! - ifs=max(its,ids) - jfs=max(jts,jds) - ife=min(ite,ide-1) - jfe=min(jte,jde-1) -! -! -! -! prelims finished, now go real for every grid point -! - ifs=max(its,ids) - ife=min(ite,ide-1) - jfs=max(jts,jds) - jfe=min(jte,jde-1) - if(cugd_spread.gt.0.or.smoothh.eq.1)then - if(its.eq.ips)ifs=max(its-1,ids) - if(ite.eq.ipe)ife=min(ite+1,ide-1) - if(jts.eq.jps)jfs=max(jts-1,jds) - if(jte.eq.jpe)jfe=min(jte+1,jde-1) - endif - do j=jfs,jfe - do i=ifs,ife -! - do k=kts,kte - rthcutent(i,k,j)=cugd_tten(i,k,j) - rqvcutent(i,k,j)=cugd_qvten(i,k,j) - enddo -! -! for high res run, spread the subsidence -! this is tricky......only consider grid points where there was no rain, -! so cugd_tten and such are zero! -! - if(cugd_spread.gt.0)then - do k=kts,kte - do nn=-1,1,1 - do kk=-1,1,1 - ido=max(i+kk,ids) - ido=min(ido,ide-1) - jdo=max(j+kk,jds) - jdo=min(jdo,jde-1) - rthcutent(i,k,j)=rthcutent(i,k,j) & - +qmem(ido,jdo)*cugd_ttens(ido,k,jdo) - rqvcutent(i,k,j)=rqvcutent(i,k,j) & - +qmem(ido,jdo)*cugd_qvtens(ido,k,jdo) - enddo - enddo - enddo - endif -! -! end spreading - - if(cugd_spread.eq.0)then - do k=kts,kte - rthcutent(i,k,j)=rthcutent(i,k,j)+cugd_ttens(i,k,j) - rqvcutent(i,k,j)=rqvcutent(i,k,j)+cugd_qvtens(i,k,j) - enddo - endif - enddo ! end j - enddo ! end i -! smooth - do k=kts,kte - if(smoothh.eq.0)then - ifs=max(its,ids+4) - ife=min(ite,ide-5) - jfs=max(jts,jds+4) - jfe=min(jte,jde-5) - do i=ifs,ife - do j=jfs,jfe - rthcuten(i,k,j)=rthcutent(i,k,j) - rqvcuten(i,k,j)=rqvcutent(i,k,j) - enddo ! end j - enddo ! end j - else if(smoothh.eq.1)then ! smooth - ifs=max(its,ids) - ife=min(ite,ide-1) - jfs=max(jts,jds) - jfe=min(jte,jde-1) -! we need an extra row for j (halo comp) - if(jts.eq.jps)jfs=max(jts-1,jds) - if(jte.eq.jpe)jfe=min(jte+1,jde-1) - do i=ifs,ife - do j=jfs,jfe - smtt(i,j)=.25*(rthcutent(i-1,k,j)+2.*rthcutent(i,k,j)+rthcutent(i+1,k,j)) - smtq(i,j)=.25*(rqvcutent(i-1,k,j)+2.*rqvcutent(i,k,j)+rqvcutent(i+1,k,j)) - enddo ! end j - enddo ! end j - ifs=max(its,ids+4) - ife=min(ite,ide-5) - jfs=max(jts,jds+4) - jfe=min(jte,jde-5) - do i=ifs,ife - do j=jfs,jfe - rthcuten(i,k,j)=.25*(smtt(i,j-1)+2.*smtt(i,j)+smtt(i,j+1)) - rqvcuten(i,k,j)=.25*(smtq(i,j-1)+2.*smtq(i,j)+smtq(i,j+1)) - enddo ! end j - enddo ! end i - endif ! smoothh - - enddo ! end k -! -! check moistening rates -! - ifs=max(its,ids+4) - ife=min(ite,ide-5) - jfs=max(jts,jds+4) - jfe=min(jte,jde-5) - do j=jfs,jfe - do i=ifs,ife - qmemf=1. - thresh=1.e-20 - do k=kts,kte - if(rqvcuten(i,k,j).lt.0.)then - - qmem1=moist_qv(i,k,j)+rqvcuten(i,k,j)*dt - if(qmem1.lt.thresh)then - qmem1=rqvcuten(i,k,j) - qmem2=(thresh-moist_qv(i,k,j))/dt - qmemf=min(qmemf,qmem2/qmem1) - qmemf=max(0.,qmemf) - qmemf=min(1.,qmemf) - endif - - endif - enddo - do k=kts,kte - rqvcuten(i,k,j)=rqvcuten(i,k,j)*qmemf - rthcuten(i,k,j)=rthcuten(i,k,j)*qmemf - enddo - if(present(rqccuten))then - if(f_qc) then - do k=kts,kte - rqccuten(i,k,j)=rqccuten(i,k,j)*qmemf - enddo - endif - endif - if(present(rqicuten))then - if(f_qi) then - do k=kts,kte - rqicuten(i,k,j)=rqicuten(i,k,j)*qmemf - enddo - endif - endif - RAINCV(I,J)=RAINCV(I,J)*qmemf - PRATEC(I,J)=PRATEC(I,J)*qmemf -! -! check heating rates - -! - thresh=200. - qmemf=1. - qmem1=0. - do k=kts,kte - qmem1=abs(rthcuten(i,k,j))*86400. - - if(qmem1.gt.thresh)then - qmem2=thresh/qmem1 - qmemf=min(qmemf,qmem2) - qmemf=max(0.,qmemf) - endif - - enddo - RAINCV(I,J)=RAINCV(I,J)*qmemf - PRATEC(I,J)=PRATEC(I,J)*qmemf - do k=kts,kte - rqvcuten(i,k,j)=rqvcuten(i,k,j)*qmemf - rthcuten(i,k,j)=rthcuten(i,k,j)*qmemf - enddo - if(present(rqccuten))then - if(f_qc) then - do k=kts,kte - rqccuten(i,k,j)=rqccuten(i,k,j)*qmemf - enddo - endif - endif - if(present(rqicuten))then - if(f_qi) then - do k=kts,kte - rqicuten(i,k,j)=rqicuten(i,k,j)*qmemf - enddo - endif - endif - if(smoothv.eq.1)then -! -! smooth for now -! - do k=kts+2,kte-2 - conv_trasht(k)= .25*(rthcuten(i,k-1,j)+2.*rthcuten(i,k,j)+rthcuten(i,k+1,j)) - conv_trashq(k)= .25*(rqvcuten(i,k-1,j)+2.*rqvcuten(i,k,j)+rqvcuten(i,k+1,j)) - enddo - do k=kts+2,kte-2 - rthcuten(i,k,j)=conv_trasht(k) - rqvcuten(i,k,j)=conv_trashq(k) - enddo - endif - do k=kts,kte - rthcuten(i,k,j)=rthcuten(i,k,j)/pi_phy(i,k,j) - enddo - enddo ! end j - enddo ! end i - ENDDO !$OMP END PARALLEL DO - - - END SUBROUTINE CONV_GRELL_SPREAD3D -!------------------------------------------------------- - SUBROUTINE cup_up_uv(k22,ukb,vkb,z_cup,cd,cdd,entr, & - entrd,vcd,ucd,jmin,u_cup,v_cup,uc,vc,kbcon, & - ierr,u,v, & - its,ite, jts,jte, kts,kte, itf,ktf ) - - IMPLICIT NONE -! -! on input -! - - ! only local wrf dimensions are need as of now in this routine - integer & - ,intent (in ) :: & - its,ite, jts,jte, kts,kte - integer, intent (in) :: itf,ktf - ! hc = cloud moist static energy - ! hkb = moist static energy at originating level - ! he = moist static energy on model levels - ! he_cup = moist static energy on model cloud levels - ! hes_cup = saturation moist static energy on model cloud levels - ! dby = buoancy term - ! cd= detrainment function - ! z_cup = heights of model cloud levels - ! entr = entrainment rate - ! - real , dimension (its:ite,kts:kte) & - ,intent (in ) :: & - u,v,u_cup,v_cup,z_cup,cd,cdd - ! entr= entrainment rate - real & - ,intent (in ) :: & - entr,entrd - integer, dimension (its:ite) & - ,intent (in ) :: & - kbcon,k22,jmin -! -! input and output -! - - ! ierr error value, maybe modified in this routine - - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr - - real , dimension (its:ite,kts:kte) & - ,intent (out ) :: & - uc,vc,ucd,vcd - real , dimension (its:ite) & - ,intent (out ) :: & - ukb,vkb -! -! local variables in this routine -! - real , dimension (its:ite) :: & - ukbd,vkbd - - integer :: & - i,k,ki - real :: & - dz - do i=its,itf - if(ierr(i).eq.0.)then - ukb(i)=u_cup(i,k22(i)) - vkb(i)=v_cup(i,k22(i)) - ukbd(i)=u_cup(i,jmin(i)) - vkbd(i)=v_cup(i,jmin(i)) - do k=kts,ktf - ucd(i,k)=u_cup(i,k) - vcd(i,k)=v_cup(i,k) - enddo - do k=1,k22(i) - uc(i,k)=u_cup(i,k) - vc(i,k)=v_cup(i,k) - enddo - do k=k22(i),kbcon(i) - uc(i,k)=ukb(i) - vc(i,k)=vkb(i) - enddo - endif - enddo - do k=kts+1,ktf - do i=its,itf - if(k.gt.kbcon(i).and.ierr(i).eq.0.)then - DZ=Z_cup(i,K)-Z_cup(i,K-1) - UC(i,K)=(UC(i,K-1)*(1.-.5*CD(i,K)*DZ)+entr* & - DZ*U(i,K-1))/(1.+entr*DZ-.5*cd(i,k)*dz) - VC(i,K)=(VC(i,K-1)*(1.-.5*CD(i,K)*DZ)+entr* & - DZ*V(i,K-1))/(1.+entr*DZ-.5*cd(i,k)*dz) - endif - enddo - enddo - do i=its,itf - IF(ierr(I).eq.0)then - k=jmin(i) - ucd(i,k)=u_cup(i,k) - vcd(i,k)=v_cup(i,k) -! - do ki=jmin(i)-1,1,-1 - DZ=Z_cup(i,Ki+1)-Z_cup(i,Ki) - uCD(i,Ki)=(uCD(i,Ki+1)*(1.-.5*CDD(i,Ki)*DZ) & - +entr*DZ*u(i,Ki) & - )/(1.+entr*DZ-.5*CDD(i,Ki)*DZ) - vCD(i,Ki)=(vCD(i,Ki+1)*(1.-.5*CDD(i,Ki)*DZ) & - +entr*DZ*v(i,Ki) & - )/(1.+entr*DZ-.5*CDD(i,Ki)*DZ) - enddo -! - endif -!--- end loop over i - enddo - - - END SUBROUTINE cup_up_uv - SUBROUTINE cup_env_clev_uv(us,vs,u_cup,v_cup,ierr, & - its,ite, jts,jte, kts,kte, itf,ktf) - IMPLICIT NONE - - integer & - ,intent (in ) :: & - its,ite, jts,jte, kts,kte - integer, intent (in) :: itf,ktf - real , dimension (its:ite,kts:kte) & - ,intent (in ) :: & - us,vs - real , dimension (its:ite,kts:kte) & - ,intent (out ) :: & - u_cup,v_cup - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr -! -! local variables in this routine -! - - integer :: & - i,k -! -! - do k=kts+1,ktf - do i=its,itf - if(ierr(i).eq.0)then - u_cup(i,k)=.5*(us(i,k-1)+us(i,k)) - v_cup(i,k)=.5*(vs(i,k-1)+vs(i,k)) - endif - enddo - do i=its,itf - if(ierr(i).eq.0)then - u_cup(i,1)=us(i,1) - v_cup(i,1)=vs(i,1) - endif - enddo - enddo - - - END SUBROUTINE cup_env_clev_uv - SUBROUTINE cup_dellabotuv(ipr,jpr,u_cup,v_cup,ierr,z_cup,p_cup, & - ucd,vcd,edt,zd,cdd,u,v,dellau,dellav,j,mentrd_rate,z,g, & - its,ite, jts,jte, kts,kte, itf,ktf ) - - IMPLICIT NONE - - integer & - ,intent (in ) :: & - its,ite, jts,jte, kts,kte - integer, intent (in) :: itf,ktf - integer, intent (in ) :: & - j,ipr,jpr - ! - ! ierr error value, maybe modified in this routine - ! - real, dimension (its:ite,kts:kte) & - ,intent (out ) :: & - dellau,dellav - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - z_cup,p_cup,ucd,vcd,zd,cdd,u,v,z,u_cup,v_cup - real, dimension (its:ite) & - ,intent (in ) :: & - edt - real & - ,intent (in ) :: & - g,mentrd_rate - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr -! -! local variables in this routine -! - - integer i - real detdo,detdo1,detdo2,entdo,dp,dz,subin, & - totmas - do 100 i=its,itf - dellau(i,1)=0. - dellav(i,1)=0. - if(ierr(i).ne.0)go to 100 - dz=z_cup(i,2)-z_cup(i,1) - DP=100.*(p_cup(i,1)-P_cup(i,2)) - detdo1=edt(i)*zd(i,2)*CDD(i,1)*DZ - detdo2=edt(i)*zd(i,1) - entdo=edt(i)*zd(i,2)*mentrd_rate*dz - subin=-EDT(I)*zd(i,2) - detdo=detdo1+detdo2-entdo+subin - DELLAU(I,1)=(detdo1*.5*(UCD(i,1)+UCD(i,2)) & - +detdo2*ucd(i,1) & - +subin*u_cup(i,2) & - -entdo*u(i,1))*g/dp - DELLAV(I,1)=(detdo1*.5*(VCD(i,1)+VCD(i,2)) & - +detdo2*vcd(i,1) & - +subin*v_cup(i,2) & - -entdo*v(i,1))*g/dp - 100 CONTINUE - - END SUBROUTINE cup_dellabotuv - SUBROUTINE cup_dellasuv(ierr,z_cup,p_cup,ucd,vcd,edt,zd,cdd, & - u,v,dellau,dellav,j,mentrd_rate,zu,g, & - cd,uc,vc,ktop,k22,kbcon,mentr_rate,jmin,u_cup, & - v_cup,kdet,kpbl,ipr,jpr,name, & - its,ite, jts,jte, kts,kte, itf,ktf ) - - IMPLICIT NONE - - integer & - ,intent (in ) :: & - its,ite, jts,jte, kts,kte - integer, intent (in) :: itf,ktf - integer, intent (in ) :: & - j,ipr,jpr - ! - ! ierr error value, maybe modified in this routine - ! - real, dimension (its:ite,kts:kte) & - ,intent (out ) :: & - dellau,dellav - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - z_cup,p_cup,ucd,vcd,zd,cdd,u,v,uc,vc,cd,zu,u_cup,v_cup - real, dimension (its:ite) & - ,intent (in ) :: & - edt - real & - ,intent (in ) :: & - g,mentrd_rate,mentr_rate - integer, dimension (its:ite) & - ,intent (in ) :: & - kbcon,ktop,k22,jmin,kdet,kpbl - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr - character *(*), intent (in) :: & - name -! -! local variables in this routine -! - integer i,k - real detdo1,detdo2,entdo,dp,dz,subin,detdo,entup,& - detup,subdown,entdoj,entupk,detupk,totmas - DO K=kts+1,ktf - do i=its,itf - dellau(i,k)=0. - dellav(i,k)=0. - enddo - enddo - DO 100 k=kts+1,ktf-1 - DO 100 i=its,ite - IF(ierr(i).ne.0)GO TO 100 - IF(K.Gt.KTOP(I))GO TO 100 -! -!--- SPECIFY DETRAINMENT OF DOWNDRAFT, HAS TO BE CONSISTENT -!--- WITH ZD CALCULATIONS IN SOUNDD. -! - DZ=Z_cup(I,K+1)-Z_cup(I,K) - detdo=edt(i)*CDD(i,K)*DZ*ZD(i,k+1) - entdo=edt(i)*mentrd_rate*dz*zd(i,k+1) - subin=zu(i,k+1)-zd(i,k+1)*edt(i) - entup=0. - detup=0. - if(k.ge.kbcon(i).and.k.lt.ktop(i))then - entup=mentr_rate*dz*zu(i,k) - detup=CD(i,K+1)*DZ*ZU(i,k) - endif - subdown=(zu(i,k)-zd(i,k)*edt(i)) - entdoj=0. - entupk=0. - detupk=0. -! - if(k.eq.jmin(i))then - entdoj=edt(i)*zd(i,k) - endif - - if(k.eq.k22(i)-1)then - entupk=zu(i,kpbl(i)) - endif - - if(k.gt.kdet(i))then - detdo=0. - endif - - if(k.eq.ktop(i)-0)then - detupk=zu(i,ktop(i)) - subin=0. - endif - if(k.lt.kbcon(i))then - detup=0. - endif - dp=100.*(p_cup(i,k-1)-p_cup(i,k)) - - dellav(i,k)=(subin*v_cup(i,k+1) & - -subdown*v_cup(i,k) & - +detup*.5*(vC(i,K+1)+vC(i,K)) & - +detdo*.5*(vCD(i,K+1)+vCD(i,K)) & - -entup*v(i,k) & - -entdo*v(i,k) & - -entupk*v_cup(i,k22(i)) & - -entdoj*v_cup(i,jmin(i)) & - +detupk*vc(i,ktop(i)) & - )*g/dp - dellau(i,k)=(subin*u_cup(i,k+1) & - -subdown*u_cup(i,k) & - +detup*.5*(uC(i,K+1)+uC(i,K)) & - +detdo*.5*(uCD(i,K+1)+uCD(i,K)) & - -entup*u(i,k) & - -entdo*u(i,k) & - -entupk*u_cup(i,k22(i)) & - -entdoj*u_cup(i,jmin(i)) & - +detupk*uc(i,ktop(i)) & - )*g/dp - 100 CONTINUE - - END SUBROUTINE cup_dellasuv - -! -END MODULE module_cu_g3 diff --git a/src/fim/FIMsrc/fim/column_chem/module_data_gocart_chem.F90 b/src/fim/FIMsrc/fim/column_chem/module_data_gocart_chem.F90 deleted file mode 100644 index 71b41c9..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_data_gocart_chem.F90 +++ /dev/null @@ -1,24 +0,0 @@ -MODULE module_data_gocart_chem - - IMPLICIT NONE - - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! tracer info - !----------------------------------------------------------------------- - ! Tracer index: - ! default initialization for all sulfur and carbon species is 0 (undefined) - ! 1. DMS = Dimethyl sulfide = CH3SCH3 - ! 2. SO2 = Sulfur dioxide = SO2 - ! 3. SO4 = Sulfate = SO4 - ! 4. MSA = Methane sulfonic acid = CH3SO3H - INTEGER :: NDMS=1, NSO2=2, NSO4=3, NMSA=4 - REAL, PARAMETER :: airmw = 28.97 - REAL, PARAMETER :: mw_so4_aer = 96.066 - REAL, PARAMETER :: smw = 32.00 - REAL, PARAMETER :: nh4_mfac = 1.375 ! increase sulf (output ond AOD only) - ! to account for missing nh4 - REAL, PARAMETER :: oc_mfac = 1.8 ! increase oc (output ond AOD nly) - ! to account for Carbon to Organic ma - -END MODULE module_data_gocart_chem diff --git a/src/fim/FIMsrc/fim/column_chem/module_data_gocart_dust.F90 b/src/fim/FIMsrc/fim/column_chem/module_data_gocart_dust.F90 deleted file mode 100644 index 029e6ae..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_data_gocart_dust.F90 +++ /dev/null @@ -1,19 +0,0 @@ -Module module_data_gocart_dust - INTEGER, PARAMETER :: ndust=5,ndcls=3,ndsrc=1,maxstypes=100,nsalt=9 - real, dimension (maxstypes),save :: porosity - REAL :: ch_dust(ndust,12) - REAL, PARAMETER :: dyn_visc = 1.5E-5 - real*8, DIMENSION (5), PARAMETER :: den_dust(5)=(/2500.,2650.,2650.,2650.,2650./) - real*8, DIMENSION (5), PARAMETER :: reff_dust(5)=(/0.73D-6,1.4D-6,2.4D-6,4.5D-6,8.0D-6/) - INTEGER, DIMENSION (5), PARAMETER :: ipoint(5)=(/3,2,2,2,2/) - REAL, DIMENSION (5), PARAMETER :: frac_s(5)=(/0.1,0.25,0.25,0.25,0.25/) - real*8, DIMENSION (nsalt), PARAMETER :: reff_salt=(/0.71D-6,1.37D-6,2.63D-6,5.00D-6,9.50D-6,18.1D-6,34.5D-6,65.5D-6,125.D-6/) - real*8, DIMENSION (nsalt), PARAMETER :: den_salt=(/2500.,2650.,2650.,2650.,2650.,2650.,2650.,2650.,2650./) - INTEGER, DIMENSION (nsalt), PARAMETER :: spoint=(/1,2,2,2,2,2,3,3,3/) ! 1 Clay, 2 Silt, 3 Sand - real*8, DIMENSION (nsalt), PARAMETER :: frac_salt=(/1.,0.2,0.2,0.2,0.2,0.2,0.333,0.333,0.333/) - real*8, DIMENSION (ndust), PARAMETER :: lo_dust=(/0.1D-6,1.0D-6,1.8D-6,3.0D-6,6.0D-6/) - real*8, DIMENSION (ndust), PARAMETER :: up_dust=(/1.0D-6,1.8D-6,3.0D-6,6.0D-6,10.0D-6/) -! real*8, DIMENSION (9), PARAMETER :: lo_salt(9)=(/0.50D-6,1.00D-6,1.90D-6,3.63D-6,6.90D-6,13.13,25.0D-6,47.6D-6,90.5D-6/) -! real*8, DIMENSION (9), PARAMETER :: up_salt(9)=(/1.00D-6,1.90D-6,3.63D-6,6.90D-6,13.13,25.0D-6,47.6D-6,90.5D-6,173.D-6/) -! real*8, DIMENSION (5), PARAMETER :: distr_dust(5)=(/0.107,0.101,0.208,0.482,0.102/) -END Module module_data_gocart_dust diff --git a/src/fim/FIMsrc/fim/column_chem/module_data_gocart_seas.F90 b/src/fim/FIMsrc/fim/column_chem/module_data_gocart_seas.F90 deleted file mode 100644 index e5049cc..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_data_gocart_seas.F90 +++ /dev/null @@ -1,8 +0,0 @@ -Module module_data_gocart_seas - real*8, DIMENSION (4), PARAMETER :: ra(4)=(/1.d-1,5.d-1,1.5d0,5.0d0/) - real*8, DIMENSION (4), PARAMETER :: rb(4)=(/5.d-1,1.5d0,5.d0,1.d1/) - real*8, DIMENSION (4), PARAMETER :: den_seas(4)=(/2.2d3,2.2d3,2.2d3,2.2d3/) - real*8, DIMENSION (4), PARAMETER :: reff_seas(4)=(/0.30D-6,1.00D-6,3.25D-6,7.50D-6/) - real*8, PARAMETER :: pi=3.141592653559 - REAL*8 :: ch_ss(4,12) -END Module module_data_gocart_seas diff --git a/src/fim/FIMsrc/fim/column_chem/module_data_rrtmgaeropt.F90 b/src/fim/FIMsrc/fim/column_chem/module_data_rrtmgaeropt.F90 deleted file mode 100644 index a9e83b1..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_data_rrtmgaeropt.F90 +++ /dev/null @@ -1,138 +0,0 @@ - -MODULE module_data_rrtmgaeropt -! - IMPLICIT NONE - INTEGER nswbands,nlwbands ! wave bands for rrtmg radiation scheme - PARAMETER (nswbands =4,nlwbands=16) - -!************************************************************* -!czhao hard coding the refractive index of water and aerosols -! -! * Most of the wavelength refractive indices below are based on values -! used in the Community Atmosphere Model (CAM) -! * For now, shortwave refractive index is not wavelength depenedent -! and set to 0.003 as described in Zhao et al. ACP (2010) -! * Wavelength dependant shortwave refractive index used by CAM is -! commented out for now -! - !water - real,dimension(1:nswbands),save :: refrwsw,refiwsw - real,dimension(1:nlwbands),save :: refrwlw,refiwlw - data refrwsw /1.35,1.34,1.33,1.33/ - data refiwsw /1.524e-8,2.494e-9,1.638e-9,3.128e-6/ - data refrwlw /1.532,1.524,1.420,1.274,1.161,1.142,1.232,1.266,1.296, & - 1.321,1.342,1.315,1.330,1.339,1.350,1.408/ - data refiwlw / 0.336,0.360,0.426,0.403,0.321,0.115,0.0471,0.039,0.034, & - 0.0344,0.092,0.012,0.013,0.01,0.0049,0.0142/ - - !dust - real,dimension(1:nswbands),save :: refrsw_dust,refisw_dust - real,dimension(1:nlwbands),save :: refrlw_dust,refilw_dust - !data refrsw_dust /nswbands*1.530/ - data refrsw_dust /nswbands*1.550/ -! data refisw_dust /0.024,0.0135,0.0063,0.004/ - data refisw_dust /0.015,0.0125,0.006,0.005/ ! SAM 7/24/11 Otto et al, ACP,2007 Sahara imaginary index for dust in visible -! data refisw_dust /nswbands*0.003/ ! SAM 7/24/11 original imaginary index for dust in visible - data refrlw_dust /2.340,2.904,1.748,1.508,1.911,1.822,2.917,1.557, & - 1.242,1.447,1.432,1.473,1.495,1.5,1.5,1.51/ - data refilw_dust /0.7,0.857,0.462,0.263,0.319,0.26,0.65,0.373,0.093, & - 0.105,0.061,0.0245,0.011,0.008,0.0068,0.018/ - - !BC - real,dimension(1:nswbands),save :: refrsw_bc,refisw_bc - real,dimension(1:nlwbands),save :: refrlw_bc,refilw_bc - data refrsw_bc /nswbands*1.95/ - data refisw_bc /nswbands*0.79/ - data refrlw_bc /nlwbands*1.95/ - data refilw_bc /nlwbands*0.79/ - - !OC - real,dimension(1:nswbands),save :: refrsw_oc,refisw_oc - real,dimension(1:nlwbands),save :: refrlw_oc,refilw_oc - !data refrsw_oc /1.53,1.53,1.53,1.52/ - data refrsw_oc /nswbands*1.45/ - !data refisw_oc /0.00776,0.005,0.00567,0.0156/ - data refisw_oc /nswbands*0.0/ - data refrlw_oc /1.86,1.91,1.988,1.439,1.606,1.7,1.888,2.489,1.219, & - 1.419,1.426,1.446,1.457,1.458,1.455,1.443/ - data refilw_oc /0.5,0.268,0.185,0.198,0.059,0.0488,0.11,0.3345,0.065, & - 0.058,0.0261,0.0142,0.013,0.01,0.005,0.0057/ - - !Sea-salt - real,dimension(1:nswbands),save :: refrsw_seas,refisw_seas - real,dimension(1:nlwbands),save :: refrlw_seas,refilw_seas - data refrsw_seas /1.51,1.5,1.5,1.47/ - data refisw_seas /0.866e-6,7.019e-8,1.184e-8,0.00015/ - data refrlw_seas /1.74,1.76,1.78,1.456,1.41,1.48,1.56,1.63,1.4,1.43, & - 1.56,1.45,1.485,1.486,1.48,1.48 / - data refilw_seas /0.1978,0.1978,0.129,0.038,0.019,0.014,0.016,0.03,0.012, & - 0.0064,0.0196,0.0029,0.0017,0.0014,0.0014,0.00176/ - - !Sulfate - real,dimension(1:nswbands),save :: refrsw_sulf,refisw_sulf - real,dimension(1:nlwbands),save :: refrlw_sulf,refilw_sulf - !data refrsw_sulf /1.468,1.442,1.43,1.422/ - data refrsw_sulf /nswbands*1.52/ - data refisw_sulf /3*1.0e-9,1.75e-6/ - data refrlw_sulf /1.89,1.91,1.93,1.586,1.678,1.758,1.855,1.597,1.15, & - 1.26,1.42,1.35,1.379,1.385,1.385,1.367/ - data refilw_sulf /0.22,0.152,0.0846,0.2225,0.195,0.441,0.696,0.695, & - 0.459,0.161,0.172,0.14,0.12,0.122,0.126,0.158/ - -!************************************************************* - !wavelength - real, save :: wavmin(nswbands) ! Min wavelength (um) of interval - !data wavmin /3.077,2.500,2.150,1.942,1.626,1.299, & - data wavmin /0.25,0.35,0.55,0.998/ - real, save :: wavmax(nswbands) ! Max wavelength (um) of interval - !data wavmax/3.846,3.077,2.500,2.150,1.942,1.626, & - data wavmax/0.35,0.45,0.65,1.000/ - real, save :: wavenumber1_longwave(nlwbands) !Longwave limits (cm-1) - data wavenumber1_longwave /10.,350.,500.,630.,700.,820.,980.,1080.,1180.,1390.,1480.,1800.,2080.,2250.,2390.,2600./ - real, save :: wavenumber2_longwave(nlwbands) !Longwave limits (cm-1) - data wavenumber2_longwave /350.,500.,630.,700.,820.,980.,1080.,1180.,1390.,1480.,1800.,2080., 2250.,2390.,2600.,3250./ - - !mode or size bin - integer,parameter :: maxd_amode=3 - integer,parameter :: ntot_amode=3 - integer,parameter :: maxd_bin=8 - integer,parameter :: ntot_bin=8 - - !Chebychev polynomial - !integer,parameter :: prefr=7,prefi=10 - integer,parameter :: prefr=7,prefi=7 - integer,parameter :: ncoef=50 - real,parameter :: rmmin=0.005e-4,rmmax=50.e-4 ! cm - real,save:: refrtabsw(prefr,nswbands) - real,save:: refitabsw(prefi,nswbands) - real,save:: refrtablw(prefr,nlwbands) - real,save:: refitablw(prefi,nlwbands) - !coefficients for parameterizing aerosol radiative properties - !in terms of refractive index and wet radius - real,save:: extpsw(ncoef,prefr,prefi,nswbands) !specific extinction - real,save:: abspsw(ncoef,prefr,prefi,nswbands) !specific absorption - real,save:: ascatpsw(ncoef,prefr,prefi,nswbands) !specific scattering - real,save:: asmpsw(ncoef,prefr,prefi,nswbands) !asymmetry factor - real,save:: sbackpsw(ncoef,prefr,prefi,nswbands) - real,save:: pmom2psw(ncoef,prefr,prefi,nswbands) - real,save:: pmom3psw(ncoef,prefr,prefi,nswbands) - real,save:: pmom4psw(ncoef,prefr,prefi,nswbands) - real,save:: pmom5psw(ncoef,prefr,prefi,nswbands) - real,save:: pmom6psw(ncoef,prefr,prefi,nswbands) - real,save:: pmom7psw(ncoef,prefr,prefi,nswbands) - real,save:: extplw(ncoef,prefr,prefi,nlwbands) !specific extinction - real,save:: absplw(ncoef,prefr,prefi,nlwbands) !specific absorption - real,save:: ascatplw(ncoef,prefr,prefi,nlwbands) !specific scattering - real,save:: asmplw(ncoef,prefr,prefi,nlwbands) !asymmetry factor - - real,save :: wavmidsw(nswbands) - data wavmidsw / 0.30e-4, 0.40e-4, 0.60e-4 ,0.999e-04 / - !now czhao use 0.45 instead of 0.40 becaues of incorrect AOD from 0.40 - !data wavmidsw / 0.30e-4, 0.45e-4, 0.60e-4 ,0.999e-04 / - real,save :: wavmidlw(nlwbands) - complex, save :: crefwsw(nswbands) ! complex refractive index fro water - complex, save :: crefwlw(nlwbands) - - - -END MODULE module_data_rrtmgaeropt diff --git a/src/fim/FIMsrc/fim/column_chem/module_data_sorgam.F90 b/src/fim/FIMsrc/fim/column_chem/module_data_sorgam.F90 deleted file mode 100644 index 364ce16..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_data_sorgam.F90 +++ /dev/null @@ -1,1222 +0,0 @@ - -MODULE module_data_sorgam -! USE module_data_radm2 -! -! param.inc start - IMPLICIT NONE - INTEGER NP !bs maximum expected value of N - PARAMETER (NP = 8) -! integer numaer -! parameter (numaer=50) - - INTEGER MAXITS !bs maximum number of iterations - PARAMETER (MAXITS = 100) - - REAL TOLF !bs convergence criterion on function values - PARAMETER (TOLF = 1.E-09) - - REAL TOLMIN !bs criterion whether superios convergence to - PARAMETER (TOLMIN = 1.E-12) !bs a minimum of fmin has occurred - - REAL TOLX !bs convergence criterion on delta_x - PARAMETER (TOLX = 1.E-10) - - REAL STPMX !bs scaled maximum step length allowed - PARAMETER (STPMX = 100.) - - - REAL c303, c302 - PARAMETER (c303=19.83,c302=5417.4) - - INTEGER lcva, lcvb, lspcv, ldesn - PARAMETER (lcva=4,lcvb=4,lspcv=lcva+lcvb) - PARAMETER (ldesn=13) -!mh ldesn is number of deposition species -!mh true number of deposited species may be larger since there -!mh are species which are deposited with the same rate - - INTEGER laerdvc, lnonaerdvc, l1ae, laero, imodes, aspec -! PARAMETER (laerdvc=34,lnonaerdvc=8+lspcv) - PARAMETER (laerdvc=39,lnonaerdvc=8+lspcv) - PARAMETER (l1ae=laerdvc+lnonaerdvc) - PARAMETER (laero=4,imodes=4,aspec=1) -! LAERDVC number of advected aerosol dynamic parameters for a given -! component species -!ia L1AE advected parameters+non-advected parameters -!ia LAERO number of aerosol component species -!ia imodes number of aerosol modes -!ia ASPEC number of gas phase comp. that are added dynamically -!ia currently only sulfate (=1) -!bs -!bs * BS ** BS ** BS ** BS ** BS ** BS ** BS ** BS ** BS ** BS ** BS ** -!bs - INTEGER aemiss - PARAMETER (aemiss=4) -!bs * AEMISS # of aerosol species with emissions link to gas phase -!bs currently ECI, ECJ, BCI, BCJ - INTEGER ldroga - PARAMETER (ldroga=11) - INTEGER ldrogb - PARAMETER (ldrogb=6) - INTEGER ldrog - PARAMETER (ldrog=ldroga+ldrogb) -!bs * LDROGA # of anthropogenic organic aerosol precursor gases (DR -!bs * LDROGB # of biogenic organic aerosol precursor gases (DROG) -!bs * LSPCV # of condensable organic vapor interacting between gas -!bs aerosol phase with SORGAM -!bs -! param.inc stop - -! ////////////////////////////////////////////////////////////////////// -! FSB include file - -! *** declare and set flag for organic aerosol production method -! *** Two method are available: - -! *** The method of Pandis,Harley, Cass, and Seinfeld, 1992, -! Secondary aerosol formation and transport, Atmos. Environ., 26A, -! pp 2453-2466 -! Bowman et al. Atmospheric Environment -! Vol 29, pp 579-589, 1995. -! *** and -! *** The method of Odum, Hoffmann, Bowman, Collins, Flagen and -! Seinfeld, 1996, Gas/particle partitioning and secondary organic ae -! yields, Environ. Sci, Technol, 30, pp 2580-2585. - - - ! 1 = Pandis et al. 1992 method is used - INTEGER orgaer - ! 2 = Pankow 1994/Odum et al. 1996 method is -! *** -! switch for organic aerosol method - PARAMETER (orgaer=2) - -! *** information about visibility variables -! number of visibility variables - INTEGER n_ae_vis_spc - PARAMETER (n_ae_vis_spc=2) - -! index for visual range in deciview - INTEGER idcvw - PARAMETER (idcvw=1) -! index for extinction [ 1/km ] - INTEGER ibext - PARAMETER (ibext=2) - - -! *** set up indices for array CBLK - -! index for Accumulation mode sulfate aerosol - INTEGER vso4aj - PARAMETER (vso4aj=1) - -! index for Aitken mode sulfate concentration - INTEGER vso4ai - PARAMETER (vso4ai=2) - -! index for Accumulation mode aerosol ammonium - INTEGER vnh4aj - PARAMETER (vnh4aj=3) - -! index for Aitken mode ammonium concentration - INTEGER vnh4ai - PARAMETER (vnh4ai=4) - -! index for Accumulation mode aerosol nitrate - INTEGER vno3aj - PARAMETER (vno3aj=5) - -! index for Aitken mode nitrate concentration - INTEGER vno3ai - PARAMETER (vno3ai=6) - -! index for Accumulation mode aerosol sodium - INTEGER vnaaj - PARAMETER (vnaaj=7) - -! index for Aitken mode sodium concentration - INTEGER vnaai - PARAMETER (vnaai=8) - -! index for Accumulation mode aerosol chloride - INTEGER vclaj - PARAMETER (vclaj=9) - -! index for Aitken mode chloride concentration - INTEGER vclai - PARAMETER (vclai=10) - -! index for Accumulation mode anthropogenic - INTEGER vorgaro1j - PARAMETER (vorgaro1j=11) - -! index for Aitken mode anthropogenic org - INTEGER vorgaro1i - PARAMETER (vorgaro1i=12) - -! index for Accumulation mode anthropogenic - INTEGER vorgaro2j - PARAMETER (vorgaro2j=13) - -! index for Aitken mode anthropogenic org - INTEGER vorgaro2i - PARAMETER (vorgaro2i=14) - -! index for Accumulation mode anthropogenic - INTEGER vorgalk1j - PARAMETER (vorgalk1j=15) - -! index for Aitken mode anthropogenic org - INTEGER vorgalk1i - PARAMETER (vorgalk1i=16) - -! index for Accumulation mode anthropogenic - INTEGER vorgole1j - PARAMETER (vorgole1j=17) - -! index for Aitken mode anthropogenic org - INTEGER vorgole1i - PARAMETER (vorgole1i=18) - -! index for Accumulation mode biogenic aerosol - INTEGER vorgba1j - PARAMETER (vorgba1j=19) - -! index for Aitken mode biogenic aerosol concentration - INTEGER vorgba1i - PARAMETER (vorgba1i=20) - -! index for Accumulation mode biogenic aerosol - INTEGER vorgba2j - PARAMETER (vorgba2j=21) - -! index for Aitken mode biogenic aerosol concentration - INTEGER vorgba2i - PARAMETER (vorgba2i=22) - -! index for Accumulation mode biogenic aerosol - INTEGER vorgba3j - PARAMETER (vorgba3j=23) - -! index for Aitken mode biogenic aerosol concentration - INTEGER vorgba3i - PARAMETER (vorgba3i=24) - -! index for Accumulation mode biogenic aerosol - INTEGER vorgba4j - PARAMETER (vorgba4j=25) - -! index for Aitken mode biogenic aerosol concentration - INTEGER vorgba4i - PARAMETER (vorgba4i=26) - -! index for Accumulation mode primary anthropogenic - INTEGER vorgpaj - PARAMETER (vorgpaj=27) - -! index for Aitken mode primary anthropogenic - INTEGER vorgpai - PARAMETER (vorgpai=28) - -! index for Accumulation mode aerosol elemen - INTEGER vecj - PARAMETER (vecj=29) - -! index for Aitken mode elemental carbon - INTEGER veci - PARAMETER (veci=30) - -! index for Accumulation mode primary PM2.5 - INTEGER vp25aj - PARAMETER (vp25aj=31) - -! index for Aitken mode primary PM2.5 concentration - INTEGER vp25ai - PARAMETER (vp25ai=32) - -! index for coarse mode anthropogenic aerososol - INTEGER vantha - PARAMETER (vantha=33) - -! index for coarse mode marine aerosol concentration - INTEGER vseas - PARAMETER (vseas=34) - -! index for coarse mode soil-derived aerosol - INTEGER vsoila - PARAMETER (vsoila=35) - -! index for Aitken mode number - INTEGER vnu0 - PARAMETER (vnu0=36) - -! index for accum mode number - INTEGER vac0 - PARAMETER (vac0=37) - -! index for coarse mode number - INTEGER vcorn - PARAMETER (vcorn=38) - -! index for Accumulation mode aerosol water - INTEGER vh2oaj - PARAMETER (vh2oaj=39) - -! index for Aitken mode aerosol water concentration - INTEGER vh2oai - PARAMETER (vh2oai=40) - -! index for Aitken mode 3'rd moment - INTEGER vnu3 - PARAMETER (vnu3=41) - -! index for Accumulation mode 3'rd moment - INTEGER vac3 - PARAMETER (vac3=42) - -! index for coarse mode 3rd moment - INTEGER vcor3 - PARAMETER (vcor3=43) - -! index for sulfuric acid vapor concentration - INTEGER vsulf - PARAMETER (vsulf=44) - -! index for nitric acid vapor concentration - INTEGER vhno3 - PARAMETER (vhno3=45) - -! index for ammonia gas concentration - INTEGER vnh3 - PARAMETER (vnh3=46) - -! index for HCL gas concentration - INTEGER vhcl - PARAMETER (vhcl=47) - -! index for cond. vapor from aromatics - INTEGER vcvaro1 - PARAMETER (vcvaro1=48) - -! index for cond. vapor from aromatics - INTEGER vcvaro2 - PARAMETER (vcvaro2=49) - -! index for cond. vapor from anth. alkane - INTEGER vcvalk1 - PARAMETER (vcvalk1=50) - -! index for cond. vapor from anth. olefin - INTEGER vcvole1 - PARAMETER (vcvole1=51) - -! index for cond. vapor from biogenics - INTEGER vcvapi1 - PARAMETER (vcvapi1=52) - -! index for cond. vapor from biogenics - INTEGER vcvapi2 - PARAMETER (vcvapi2=53) - -! index for cond. vapor from biogenics - INTEGER vcvlim1 - PARAMETER (vcvlim1=54) - -! index for cond. vapor from biogenics - INTEGER vcvlim2 - PARAMETER (vcvlim2=55) - -! COMMON /CBLKINDCS/ -! & VSO4AJ,VSO4AI,VNH4AJ,VNH4AI,VNO3AJ,VNO3AI, -! & VORGAJ,VORGAI, VORGPAJ,VORGPAI, -! & VORGBAJ,VORGBAI,VECJ,VECI, -! & VP25AJ,VP25AI,VANTHA,VSEAS,VSOILA, -! & VNU0,VAC0,VCORN, -! & VH2OAJ,VH2OAI, -! & VNU3,VAC3,VCOR3, -! & VSULF,VHNO3,VNH3 - -! *** set up species dimension and indices for sedimentation -! velocity array VSED - -! number of sedimentation velocities - INTEGER naspcssed - PARAMETER (naspcssed=6) - -! index for Aitken mode number - INTEGER vsnnuc - PARAMETER (vsnnuc=1) - -! index for Accumulation mode number - INTEGER vsnacc - PARAMETER (vsnacc=2) - -! index for coarse mode number - INTEGER vsncor - PARAMETER (vsncor=3) - -! index for Aitken mode mass - INTEGER vsmnuc - PARAMETER (vsmnuc=4) - -! index for accumulation mode mass - INTEGER vsmacc - PARAMETER (vsmacc=5) - -! index for coarse mass - INTEGER vsmcor - PARAMETER (vsmcor=6) - -! *** set up species dimension and indices for deposition -! velocity array VDEP - -! number of deposition velocities - INTEGER naspcsdep - PARAMETER (naspcsdep=7) - -! index for Aitken mode number - INTEGER vdnnuc - PARAMETER (vdnnuc=1) - -! index for accumulation mode number - INTEGER vdnacc - PARAMETER (vdnacc=2) - -! index for coarse mode number - INTEGER vdncor - PARAMETER (vdncor=3) - -! index for Aitken mode mass - INTEGER vdmnuc - PARAMETER (vdmnuc=4) - -! index for accumulation mode - INTEGER vdmacc - PARAMETER (vdmacc=5) - -! index for fine mode mass (Aitken + accumulatio - INTEGER vdmfine - PARAMETER (vdmfine=6) - -! index for coarse mode mass - INTEGER vdmcor - PARAMETER (vdmcor=7) - -! *** END AEROSTUFF.EXT -!bs -!BS * BS * BS * BS * BS * BS * BS * BS * BS * BS * BS * BS * BS * BS * ! -!BS * * ! -!BS * include file used in SORGAM routines * ! -!BS * * ! -!BS * BS * BS * BS * BS * BS * BS * BS * BS * BS * BS * BS * BS * BS * ! -!bs -!bs -!bs * species pointer for condensable vapor production -!bs -!bs XYL + OH - INTEGER pxyl - PARAMETER (pxyl=1) -!bs TOL + OH - INTEGER ptol - PARAMETER (ptol=2) -!bs CSL + OH - INTEGER pcsl1 - PARAMETER (pcsl1=3) -!bs CSL + NO - INTEGER pcsl2 - PARAMETER (pcsl2=4) -!bs HC8 + OH - INTEGER phc8 - PARAMETER (phc8=5) -!bs OLI + OH - INTEGER poli1 - PARAMETER (poli1=6) -!bs OLI + NO - INTEGER poli2 - PARAMETER (poli2=7) -!bs OLI + O3 - INTEGER poli3 - PARAMETER (poli3=8) -!bs OLT + OH - INTEGER polt1 - PARAMETER (polt1=9) -!bs OLT + NO - INTEGER polt2 - PARAMETER (polt2=10) -!bs OLT + O3 - INTEGER polt3 - PARAMETER (polt3=11) -!bs API + OH - INTEGER papi1 - PARAMETER (papi1=12) -!bs API + NO - INTEGER papi2 - PARAMETER (papi2=13) -!bs API + O3 - INTEGER papi3 - PARAMETER (papi3=14) -!bs LIM + OH - INTEGER plim1 - PARAMETER (plim1=15) -!bs LIM + NO - INTEGER plim2 - PARAMETER (plim2=16) -!bs LIM + O3 - INTEGER plim3 - PARAMETER (plim3=17) -!bs -!bs * Number of lumped condensable vapors in SORGAM -!bs -!bs INTEGER NACV !bs # of anth. cond. vapors -!bs PARAMETER (NACV = 2) -!bs INTEGER NBCV !bs # of bio. cond. vapors -!bs PARAMETER (NBCV = 1) -!bs INTEGER NCV !bs total # of cond. vapor -!bs PARAMETER (NCV = NACV + NBCV) -!bs -!bs * species pointer for SOA species -!bs - INTEGER psoaaro1 - PARAMETER (psoaaro1=1) - INTEGER psoaaro2 - PARAMETER (psoaaro2=2) - INTEGER psoaalk1 - PARAMETER (psoaalk1=3) - INTEGER psoaole1 - PARAMETER (psoaole1=4) - INTEGER psoaapi1 - PARAMETER (psoaapi1=5) - INTEGER psoaapi2 - PARAMETER (psoaapi2=6) - INTEGER psoalim1 - PARAMETER (psoalim1=7) - INTEGER psoalim2 - PARAMETER (psoalim2=8) -!bs -!bs * end of AERO_SOA.EXT * -!bs - -! *** include file for aerosol routines - - -!.................................................................... - -! CONTAINS: Fundamental constants for air quality modeling - -! DEPENDENT UPON: none - -! REVISION HISTORY: - -! Adapted 6/92 by CJC from ROM's PI.EXT. - -! Revised 3/1/93 John McHenry to include constants needed by -! LCM aqueous chemistry -! Revised 9/93 by John McHenry to include additional constants -! needed for FMEM clouds and aqueous chemistry - -! Revised 3/4/96 by Dr. Francis S. Binkowski to reflect current -! Models3 view that MKS units should be used wherever possible, -! and that sources be documentated. Some variables have been added -! names changed, and values revised. - -! Revised 3/7/96 to have universal gas constant input and compute -! gas constant is chemical form. TWOPI is now calculated rather than - -! Revised 3/13/96 to group declarations and parameter statements. - -! Revised 9/13/96 to include more physical constants. -! Revised 12/24/96 eliminate silly EPSILON, AMISS - -! Revised 1/06/97 to eliminate most derived constants - -! FSB REFERENCES: - -! CRC76, CRC Handbook of Chemistry and Physics (76th Ed), -! CRC Press, 1995 -! Hobbs, P.V. Basic Physical Chemistry for the Atmospheric Scien -! Cambridge Univ. Press, 206 pp, 1995. -! Snyder, J.P., Map Projections-A Working Manual, U.S. Geological -! Paper 1395 U.S.GPO, Washington, DC, 1987. -! Stull, R. B., An Introduction to Bounday Layer Meteorology, Klu -! Dordrecht, 1988 - -! Geometric Constants: - - REAL*8 & ! PI (single precision 3.141593) - pirs - PARAMETER (pirs=3.14159265358979324) -! REAL PIRS ! PI (single precision 3.141593) -! PARAMETER ( PIRS = 3.141593 ) -! Fundamental Constants: ( Source: CRC76, pp 1-1 to 1-6) - -! Avogadro's Constant [ 1/mol ] - REAL avo - PARAMETER (avo=6.0221367E23) - -! universal gas constant [ J/mol-K ] - REAL rgasuniv - PARAMETER (rgasuniv=8.314510) - -! standard atmosphere [ Pa ] - REAL stdatmpa - PARAMETER (stdatmpa=101325.0) - -! Standard Temperature [ K ] - REAL stdtemp - PARAMETER (stdtemp=273.15) - -! Stefan-Boltzmann [ W/(m**2 K**4) ] - REAL stfblz - PARAMETER (stfblz=5.67051E-8) - - -! mean gravitational acceleration [ m/sec**2 ] - REAL grav - PARAMETER (grav=9.80622) -! FSB Non MKS qualtities: - -! Molar volume at STP [ L/mol ] Non MKS units - REAL molvol - PARAMETER (molvol=22.41410) - - -! Atmospheric Constants: - -! FSB 78.06% N2, 21% O2 and 0.943% A on a mole - REAL mwair - ! fraction basis. ( Source : Hobbs, 1995) pp 69- -! mean molecular weight for dry air [ g/mol ] - PARAMETER (mwair=28.9628) - -! dry-air gas constant [ J / kg-K ] - REAL rdgas - PARAMETER (rdgas=1.0E3*rgasuniv/mwair) - -! 3*PI - REAL threepi - PARAMETER (threepi=3.0*pirs) - -! 6/PI - REAL f6dpi - PARAMETER (f6dpi=6.0/pirs) - -! 1.0e9 * 6/PIRS - REAL f6dpi9 - PARAMETER (f6dpi9=1.0E9*f6dpi) - -! 1.0e-9 * 6/PIRS - REAL f6dpim9 - PARAMETER (f6dpim9=1.0E-9*f6dpi) - -! SQRT( PI ) - REAL sqrtpi - PARAMETER (sqrtpi=1.7724539) - -! SQRT( 2 ) - REAL sqrt2 - PARAMETER (sqrt2=1.4142135623731) - -! ln( sqrt( 2 ) ) - REAL lgsqt2 - PARAMETER (lgsqt2=0.34657359027997) - -! 1/ln( sqrt( 2 ) ) - REAL dlgsqt2 - PARAMETER (dlgsqt2=1.0/lgsqt2) - -! 1/3 - REAL one3 - PARAMETER (one3=1.0/3.0) - -! 2/3 - REAL two3 - PARAMETER (two3=2.0/3.0) - - -! *** physical constants: - -! Boltzmann's Constant [ J / K ] - REAL boltz - PARAMETER (boltz=rgasuniv/avo) - - -! *** component densities [ kg/m**3 ] : - - -! bulk density of aerosol sulfate - REAL rhoso4 - PARAMETER (rhoso4=1.8E3) - -! bulk density of aerosol ammonium - REAL rhonh4 - PARAMETER (rhonh4=1.8E3) - -! bulk density of aerosol nitrate - REAL rhono3 - PARAMETER (rhono3=1.8E3) - -! bulk density of aerosol water - REAL rhoh2o - PARAMETER (rhoh2o=1.0E3) - -! bulk density for aerosol organics - REAL rhoorg - PARAMETER (rhoorg=1.0E3) - -! bulk density for aerosol soil dust - REAL rhosoil - PARAMETER (rhosoil=2.6E3) - -! bulk density for marine aerosol - REAL rhoseas - PARAMETER (rhoseas=2.2E3) - -! bulk density for anthropogenic aerosol - REAL rhoanth - PARAMETER (rhoanth=2.2E3) - -! bulk density of aerosol sodium - REAL rhona - PARAMETER (rhona=2.2E3) - -! bulk density of aerosol chloride - REAL rhocl - PARAMETER (rhocl=2.2E3) - -! *** Factors for converting aerosol mass concentration [ ug m**-3] to -! to 3rd moment concentration [ m**3 m^-3] - - REAL so4fac - PARAMETER (so4fac=f6dpim9/rhoso4) - - REAL nh4fac - PARAMETER (nh4fac=f6dpim9/rhonh4) - - REAL h2ofac - PARAMETER (h2ofac=f6dpim9/rhoh2o) - - REAL no3fac - PARAMETER (no3fac=f6dpim9/rhono3) - - REAL orgfac - PARAMETER (orgfac=f6dpim9/rhoorg) - - REAL soilfac - PARAMETER (soilfac=f6dpim9/rhosoil) - - REAL seasfac - PARAMETER (seasfac=f6dpim9/rhoseas) - - REAL anthfac - PARAMETER (anthfac=f6dpim9/rhoanth) - - REAL nafac - PARAMETER (nafac=f6dpim9/rhona) - - REAL clfac - PARAMETER (clfac=f6dpim9/rhocl) - -! starting standard surface pressure [ Pa ] - REAL pss0 - PARAMETER (pss0=101325.0) - -! starting standard surface temperature [ K ] - REAL tss0 - PARAMETER (tss0=288.15) - -! initial sigma-G for nucleimode - REAL sginin - PARAMETER (sginin=1.70) - -! initial sigma-G for accumulation mode - REAL sginia - PARAMETER (sginia=2.00) - -! initial sigma-G for coarse mode - REAL sginic - PARAMETER (sginic=2.5) - -! initial mean diameter for nuclei mode [ m ] - REAL dginin - PARAMETER (dginin=0.01E-6) - -! initial mean diameter for accumulation mode [ m ] - REAL dginia - PARAMETER (dginia=0.07E-6) - -! initial mean diameter for coarse mode [ m ] - REAL dginic - PARAMETER (dginic=1.0E-6) - - - -!................ end AERO3box.EXT ............................... -!/////////////////////////////////////////////////////////////////////// - - - - - -! LOGICAL diagnostics -! *** Scalar variables for fixed standard deviations. - -! Flag for writing diagnostics to file -! nuclei mode exp( log^2( sigmag )/8 ) - REAL en1 -! accumulation mode exp( log^2( sigmag ) - REAL ea1 - - REAL ec1 -! coarse mode exp( log^2( sigmag )/8 ) -! nuclei **4 - REAL esn04 -! accumulation - REAL esa04 - - REAL esc04 -! coarse -! nuclei **5 - REAL esn05 - - REAL esa05 -! accumulation -! nuclei **8 - REAL esn08 -! accumulation - REAL esa08 - - REAL esc08 -! coarse -! nuclei **9 - REAL esn09 - - REAL esa09 -! accumulation -! nuclei **12 - REAL esn12 -! accumulation - REAL esa12 - - REAL esc12 -! coarse mode -! nuclei **16 - REAL esn16 -! accumulation - REAL esa16 - - REAL esc16 -! coarse -! nuclei **20 - REAL esn20 -! accumulation - REAL esa20 - - REAL esc20 -! coarse -! nuclei **25 - REAL esn25 - - REAL esa25 -! accumulation -! nuclei **24 - REAL esn24 -! accumulation - REAL esa24 - - REAL esc24 -! coarse -! nuclei **28 - REAL esn28 -! accumulation - REAL esa28 - - REAL esc28 -! coarse -! nuclei **32 - REAL esn32 -! accumulation - REAL esa32 - - REAL esc32 -! coarese -! nuclei **36 - REAL esn36 -! accumulation - REAL esa36 - - REAL esc36 -! coarse -! nuclei **49 - REAL esn49 - - REAL esa49 -! accumulation -! nuclei **52 - REAL esn52 - - REAL esa52 -! accumulation -! nuclei **64 - REAL esn64 -! accumulation - REAL esa64 - - REAL esc64 -! coarse - - REAL esn100 -! nuclei **100 -! nuclei **(-20) - REAL esnm20 -! accumulation - REAL esam20 - - REAL escm20 -! coarse -! nuclei **(-32) - REAL esnm32 -! accumulation - REAL esam32 - - REAL escm32 -! coarse -! log(sginin) - REAL xxlsgn -! log(sginia) - REAL xxlsga - - REAL xxlsgc -! log(sginic ) -! log(sginin ) ** 2 - REAL l2sginin -! log(sginia ) ** 2 - REAL l2sginia - - REAL l2sginic - - -! *** set up COMMON blocks for esg's: - - - -! log(sginic ) ** 2 - -! *** SET NUCLEATION FLAG: - - ! INUCL = 0, Kerminen & Wexler Mechanism - INTEGER inucl - ! INUCL = 1, Youngblood and Kreidenweis mech - ! INUCL = 2, Kulmala et al. mechanism -! Flag for Choice of nucleation Mechanism - PARAMETER (inucl=2) - -! *** Set flag for sedimentation velocities: - - LOGICAL icoarse - PARAMETER (icoarse=.FALSE.) ! *** END AERO_INTERNAL.EXT -! *** Diameters and standard deviations for emissions -! the diameters are the volume (mass) geometric mean diameters - -! *** Aitken mode: -! special factor to compute mass transfer - REAL dgvem_i - PARAMETER (dgvem_i=0.03E-6) ! [ m ] - REAL sgem_i - PARAMETER (sgem_i=1.7) - -! *** Accumulation mode: - REAL dgvem_j - PARAMETER (dgvem_j=0.3E-6) ! [ m ] - REAL sgem_j - PARAMETER (sgem_j=2.0) - -! *** Coarse mode - REAL dgvem_c - PARAMETER (dgvem_c=6.0E-6) ! [ m ] <<< Corrected 11/19/97 - REAL sgem_c - PARAMETER (sgem_c=2.2) - -! *** factors for getting number emissions rate from mass emissions rate -! Aitken mode - REAL factnumn -! accumulation mode - REAL factnuma - - REAL factnumc -! coarse mode - REAL facatkn_min, facacc_min - PARAMETER (facatkn_min=0.04,facacc_min=1.0-facatkn_min) - REAL conmin,xxm3 - PARAMETER (conmin=1.e-30) -! [ ug/m**3 ] ! changed 1/6/98 - REAL*8 & ! factor to set minimum for Aitken mode number - nummin_i - REAL*8 & ! factor to set minimum for accumulation mode nu - nummin_j - REAL*8 & - nummin_c -! factor to set minimum for coarse mode number -!bs -!bs REAL ALPHSULF ! Accommodation coefficient for sulfuric acid -!bs PARAMETER ( ALPHSULF = 0.05 ) ! my be set to one in future -!bs -!bs REAL DIFFSULF ! molecular diffusivity for sulfuric acid [ m**2 -!bs PARAMETER( DIFFSULF = 0.08E-4 ) ! may be changed in future -!bs -!bs * 23/03/99 updates of ALPHSULF and DIFFSULF adopted fro new code fro -!bs * DIFFSULF is calculated from Reid, Prausnitz, and Poling, The prope -!bs * of gases and liquids, 4th edition, McGraw-Hill, 1987, pp 587-588. -!bs * Equation (11-4.4) was used. -!bs * The value is at T = 273.16 K and P = 1.01325E05 Pa -!bs * Temperature dependence is included for DIFFSULF via DIFFCORR (see -!bs -! Accommodation coefficient for sulfuric - REAL alphsulf - PARAMETER (alphsulf=1.0) -!bs updated from code of FSB -! molecular weight for sulfuric acid [ kg/mole ] MKS - REAL mwh2so4 - PARAMETER (mwh2so4=98.07354E-3) -!cia corrected error 24/11/97 -! molecular diffusivity for sulfuric acid [ m**2 /se - REAL diffsulf - PARAMETER (diffsulf=9.362223E-06) -!bs updated from code of FSB -!bs Accomodation coefficient for organic - REAL alphaorg - PARAMETER (alphaorg=1.0) !bs Kleeman et al. '99 propose alpha -!bs Bowman et al. '97 uses alpha = 1. -!bs mean molecular weight of organics [k - REAL mworg - PARAMETER (mworg=175.0E-03) -!bs -!bs * DIFFORG is calculated from the same formula as DIFFSULF. -!bs * An average elemental composition of C=8, O=3, N=1, H=17 is asuumed -!bs * to calculate DIFFORG at T = 273.16K and P = 1.01325E05 Pa. -!bs * Temepratur dependence is included below. -!bs molecular diffusivity for organics [ - REAL difforg - PARAMETER (difforg=5.151174E-06) -! *** CCONC is the factor for near-continuum condensation. -! ccofm * sqrt( ta ) - REAL cconc - PARAMETER (cconc=2.0*pirs*diffsulf) -!bs * factor for NC condensation for organics -! [ m**2 / sec ] - REAL cconc_org - PARAMETER (cconc_org=2.0*pirs*difforg) -! [ m**2 / sec ] -!bs analogue to CCOFM but for organics - REAL ccofm_org -! FSB CCOFM is the accommodation coefficient -! times the mean molecular velocity for h2so4 without the temperatu -! after some algebra - -!bs CCOFM_ORG * sqrt(TA) -! set to a value below - REAL ccofm -! minimum aerosol sulfate concentration - REAL aeroconcmin - PARAMETER (aeroconcmin=0.0001) - - - -!******************************************************************* -!* * -!* start parameters and variables for aerosol-cloud interactions * -!* * -!******************************************************************* -! -! maxd_atype = maximum allowable number of aerosol types -! maxd_asize = maximum allowable number of aerosol size bins -! maxd_acomp = maximum allowable number of chemical components -! in each aerosol size bin -! maxd_aphase = maximum allowable number of aerosol phases (gas, cloud, ice, rain, ...) -! -! ntype_aer = number of aerosol types -! nsize_aer(t) = number of aerosol size bins for aerosol type t. each bin w/ same set of components -! nphase_aer = number of aerosol phases -! -! msectional - if positive, moving-center sectional code is utilized, -! and each mode is actually a section. -! maerosolincw - if positive, both unactivated/interstitial and activated -! aerosol species are simulated. if zero/negative, only the -! unactivated are simulated. -! -! ncomp_aer(t) = number of chemical components for aerosol type t -! ncomp_aer_nontracer(t) = number of "non-tracer" chemical components while in gchm code -! mastercompptr_aer(c,t) = mastercomp type/i.d. for chemical component c -! (1=sulfate, others to be defined) and aerosol type t. -! massptr_aer(c,s,t,p) = gchm r-array index for the mixing ratio -! (moles-x/mole-air) for chemical component c in size bin s for type t and phase p -! -! waterptr_aer(s,t) = mixing ratio (moles-water/mole-air) for water -! associated with aerosol size bin s and type t -! hygroptr_aer(s,t) = gchm r-array index for the bulk hygroscopicity of the size bin and type -! numptr_aer(s,t,p) = gchm r-array index for the number mixing ratio -! (particles/mole-air) for aerosol size bin s, type t, and phase p -! If zero or negative, then number is not being simulated. -! -! mprognum_aer(s,t,p) - if positive, number mixing-ratio for size s, type t, -! and phase p will be prognosed. Otherwise, no. -! -! ntot_mastercomp_aer = number of aerosol chemical components defined -! dens_mastercomp_aer(mc) = dry density (g/cm^3) of aerosol master chemical component type c -! mw_mastercomp_aer(mc) = molecular weight of aerosol master chemical component type mc -! name_mastercomp_aer(mc) = name of aerosol master chemical component type mc -! mc=mastercompptr_aer(c,t) -! dens_aer(c,t) = dry density (g/cm^3) of aerosol chemical component type c and type t -! mw_aer(c,t) = molecular weight of aerosol chemical component type c and type t -! name_aer(c,t) = name of aerosol chemical component type c and type t -! -! lptr_so4_aer(s,t,p) = gchm r-array index for the -! mixing ratio for sulfate associated with aerosol size bin s, type t, and phase p -! (similar for msa, oc, bc, nacl, dust) -! -!----------------------------------------------------------------------- -! -! volumcen_sect(s,t)= volume (cm^3) at center of section m -! volumlo_sect(s,t) = volume (cm^3) at lower boundary of section m -! volumhi_sect(s,t) = volume (cm^3) at upper boundary of section m -! -! dlo_sect(s,t) = diameter (cm) at lower boundary of section m -! dhi_sect(s,t) = diameter (cm) at upper boundary of section m -! dcen_sect(s,t) = volume arithmetic-mean diameter (cm) of section m -! (corresponds to volumcen_sect == 0.5*(volumlo_sect + volumhi_sect) -! -!----------------------------------------------------------------------- -! nov-04 sg ! replaced amode with aer and expanded aerosol dimension to include type and phase - - integer, parameter :: maxd_atype = 2 - integer, parameter :: maxd_asize = 2 - integer, parameter :: maxd_acomp = 19 - integer, parameter :: maxd_aphase = 2 - integer, save :: ai_phase ! interstitial phase of aerosol - integer, save :: cw_phase ! cloud water phase of aerosol - integer, save :: ci_phase ! cloud ice phase of aerosol - integer, save :: cr_phase ! rain phase of aerosol - integer, save :: cs_phase ! snow phase of aerosol - integer, save :: cg_phase ! graupel phase of aerosol - - integer, save :: ntype_aer = 0 ! number of types - integer, save :: ntot_mastercomp_aer = 0 ! number of master components - integer, save :: nphase_aer = 0 ! number of phases - - integer, save :: & - msectional, maerosolincw, & - nsize_aer( maxd_atype ), & ! number of size bins - ncomp_aer( maxd_atype ), & ! number of chemical components - ncomp_aer_nontracer( maxd_atype ), & - mastercompptr_aer(maxd_acomp, maxd_atype), & ! mastercomp index - massptr_aer( maxd_acomp, maxd_asize, maxd_atype, maxd_aphase ), & ! index for mixing ratio - waterptr_aer( maxd_asize, maxd_atype ), & ! index for aerosol water - hygroptr_aer( maxd_asize, maxd_atype ), & ! index for aerosol hygroscopicity - numptr_aer( maxd_asize, maxd_atype, maxd_aphase ), & ! index for the number mixing ratio - mprognum_aer(maxd_asize,maxd_atype,maxd_aphase) - - real, save :: & - dens_aer( maxd_acomp, maxd_atype ), & - dens_mastercomp_aer( maxd_acomp ), & - mw_mastercomp_aer( maxd_acomp ), & - mw_aer( maxd_acomp, maxd_atype ), & - hygro_mastercomp_aer( maxd_acomp ), & - hygro_aer( maxd_acomp, maxd_atype ) - character*10, save :: & - name_mastercomp_aer( maxd_acomp ), & - name_aer( maxd_acomp, maxd_atype ) - - real, save :: & - volumcen_sect( maxd_asize, maxd_atype ), & - volumlo_sect( maxd_asize, maxd_atype ), & - volumhi_sect( maxd_asize, maxd_atype ), & - dcen_sect( maxd_asize, maxd_atype ), & - dlo_sect( maxd_asize, maxd_atype ), & - dhi_sect( maxd_asize, maxd_atype ), & - sigmag_aer(maxd_asize, maxd_atype) - - integer, save :: & - lptr_so4_aer(maxd_asize,maxd_atype,maxd_aphase), & - lptr_nh4_aer(maxd_asize,maxd_atype,maxd_aphase), & - lptr_no3_aer(maxd_asize,maxd_atype,maxd_aphase), & - lptr_orgaro1_aer(maxd_asize,maxd_atype,maxd_aphase), & - lptr_orgaro2_aer(maxd_asize,maxd_atype,maxd_aphase), & - lptr_orgalk_aer(maxd_asize,maxd_atype,maxd_aphase), & - lptr_orgole_aer(maxd_asize,maxd_atype,maxd_aphase), & - lptr_orgba1_aer(maxd_asize,maxd_atype,maxd_aphase), & - lptr_orgba2_aer(maxd_asize,maxd_atype,maxd_aphase), & - lptr_orgba3_aer(maxd_asize,maxd_atype,maxd_aphase), & - lptr_orgba4_aer(maxd_asize,maxd_atype,maxd_aphase), & - lptr_orgpa_aer(maxd_asize,maxd_atype,maxd_aphase), & - lptr_ec_aer(maxd_asize,maxd_atype,maxd_aphase), & - lptr_p25_aer(maxd_asize,maxd_atype,maxd_aphase), & - lptr_anth_aer(maxd_asize,maxd_atype,maxd_aphase), & - lptr_cl_aer(maxd_asize,maxd_atype,maxd_aphase), & - lptr_na_aer(maxd_asize,maxd_atype,maxd_aphase), & - lptr_seas_aer(maxd_asize,maxd_atype,maxd_aphase), & - lptr_soil_aer(maxd_asize,maxd_atype,maxd_aphase) - - logical, save :: & - do_cloudchem_aer(maxd_asize,maxd_atype) - - -! molecular weights (g/mol) - real, parameter :: mw_so4_aer = 96.066 - real, parameter :: mw_no3_aer = 62.007 - real, parameter :: mw_nh4_aer = 18.042 - real, parameter :: mw_oc_aer = 1.0 - real, parameter :: mw_ec_aer = 1.0 - real, parameter :: mw_oin_aer = 1.0 - real, parameter :: mw_dust_aer = 100.087 - real, parameter :: mw_seas_aer = 58.440 - real, parameter :: mw_cl_aer = 35.450 - real, parameter :: mw_na_aer = 22.990 - real, parameter :: mw_water_aer = 18.016 - -! dry densities (g/cm3) - real, parameter :: dens_so4_aer = 1.80 ! = rhoso4 - real, parameter :: dens_no3_aer = 1.80 ! = rhono3 - real, parameter :: dens_nh4_aer = 1.80 ! = rhonh4 - real, parameter :: dens_oc_aer = 1.00 ! = rhoorg - real, parameter :: dens_ec_aer = 1.70 - real, parameter :: dens_dust_aer = 2.60 ! = rhosoil - real, parameter :: dens_oin_aer = 2.20 ! = rhoanth - real, parameter :: dens_seas_aer = 2.20 ! = rhoseas - real, parameter :: dens_cl_aer = 2.20 - real, parameter :: dens_na_aer = 2.20 - -! water density (g/cm3) - real, parameter :: dens_water_aer = 1.0 - -! hygroscopicity (dimensionless) - real, parameter :: hygro_so4_aer = 0.5 - real, parameter :: hygro_no3_aer = 0.5 - real, parameter :: hygro_nh4_aer = 0.5 - real, parameter :: hygro_oc_aer = 0.14 - real, parameter :: hygro_ec_aer = 1.e-6 - real, parameter :: hygro_oin_aer = 0.14 - real, parameter :: hygro_dust_aer = 0.1 - real, parameter :: hygro_seas_aer = 1.16 - real, parameter :: hygro_cl_aer = 1.16 - real, parameter :: hygro_na_aer = 1.16 - -! table lookup of aerosol impaction/interception scavenging rates - real dlndg_nimptblgrow - integer nimptblgrow_mind, nimptblgrow_maxd - parameter (nimptblgrow_mind=-14, nimptblgrow_maxd=24) - real scavimptblnum(4, nimptblgrow_mind:nimptblgrow_maxd, maxd_asize, maxd_atype), & - scavimptblvol(4, nimptblgrow_mind:nimptblgrow_maxd, maxd_asize, maxd_atype) - - -!SAM 10/08 Gaussian quadrature constants for SORGAM deposition numerical integration - INTEGER NGAUSdv - PARAMETER( NGAUSdv = 7 ) ! Number of Gaussian Quadrature Points - constants defined in aerosols_sorgam_init - REAL Y_GQ(NGAUSdv), WGAUS(NGAUSdv) - -!***************************************************************** -!* * -!* end parameters and variables for aerosol-cloud interactions * -!* * -!***************************************************************** - - -END Module module_data_sorgam diff --git a/src/fim/FIMsrc/fim/column_chem/module_dry_dep_driver.F90 b/src/fim/FIMsrc/fim/column_chem/module_dry_dep_driver.F90 deleted file mode 100644 index 11ff71f..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_dry_dep_driver.F90 +++ /dev/null @@ -1,320 +0,0 @@ -!WRF:MODEL_LAYER:CHEMICS -! -MODULE module_dry_dep_driver - IMPLICIT NONE - -CONTAINS - - subroutine dry_dep_driver(ktau,dtstep, & - moist,p8w,alt, & - chem,rho_phy,dz8w,exch_h,hfx, & - ivgtyp,tsk,pbl,ust,znt,z,z_at_w, & - xland,dep_vel_o3,g, & - e_co,kemit,numgas, & - num_chem,num_moist, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) -!---------------------------------------------------------------------- -! USE module_model_constants -! USE module_configure -! USE module_state_description -! USE module_dep_simple - USE module_initial_chem_namelists,only:p_o3,p_dust_1,p_vash_1,p_vash_4,p_vash_10,p_dms - USE module_vertmx_wrf - USE module_chemvars,only:epsilc - USE module_initial_chem_namelists,only: chem_opt,drydep_opt,wesely, & - chem_tracer,gocart_simple,GOCARTRACM_KPP,RADM2SORG,RADM2SORG, & - RADM2SORG_AQ,RADM2SORG_KPP,RACMSORG_AQ,RACMSORG_KPP, & - CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, & - CBMZ_MOSAIC_8BIN_AQ -! USE module_data_sorgam -! USE module_aerosols_sorgam -! USE module_gocart_settling - USE module_gocart_drydep,only: gocart_drydep_driver -! USE module_mosaic_drydep, only: mosaic_drydep_driver -! USE module_mixactivate_wrappers, only: mosaic_mixactivate, sorgam_mixactivate - IMPLICIT NONE - - INTEGER, INTENT(IN ) :: numgas, & - num_chem,num_moist, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - INTEGER, INTENT(IN ) :: & - ktau - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & - INTENT(IN ) :: moist - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & - INTENT(INOUT ) :: chem - - INTEGER, INTENT(IN ) :: kemit - REAL, DIMENSION( ims:ime, kms:kemit, jms:jme ), & - INTENT(IN ) :: & - e_co - - - - - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & - INTENT(IN ) :: & - alt, & - dz8w, & - p8w,z_at_w , & - exch_h,rho_phy,z - INTEGER,DIMENSION( ims:ime , jms:jme ) , & - INTENT(IN ) :: & - ivgtyp - REAL, DIMENSION( ims:ime , jms:jme ) , & - INTENT(INOUT) :: & - tsk, & - pbl, & - ust, & - hfx, & - xland,znt - REAL, DIMENSION( ims:ime , jms:jme ) , & - INTENT(OUT) :: & - dep_vel_o3 - - REAL, INTENT(IN ) :: & - dtstep,g - -!--- deposition and emissions stuff -! .. Parameters .. -! .. -! .. Local Scalars .. - REAL :: clwchem, dvfog, dvpart, & - rad, rhchem, ta, ustar, z1,zntt - - INTEGER :: iland, iprt, iseason, jce, jcs, & - n, nr, ipr, jpr, nvr, & - idrydep_onoff - - LOGICAL :: highnh3, rainflag, vegflag, wetflag -! CHARACTER (4) :: luse_typ,mminlu_loc -! .. -! .. Local Arrays .. - REAL :: p(kts:kte) - REAL, DIMENSION( its:ite, jts:jte, num_chem ) :: ddvel - -! REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) :: dryrho_phy - REAL, DIMENSION( kms:kme ) :: dryrho_1d - -! turbulent transport - real :: pblst(kts:kte),ekmfull(kts:kte+1),zzfull(kts:kte+1),zz(kts:kte) - integer :: ii,jj,kk,i,j,k,nv -! -! necessary for aerosols (module dependent) -! -! REAL, DIMENSION( its:ite, jts:jte ) :: aer_res - -! .. -! .. Intrinsic Functions .. - INTRINSIC max, min - -! -! compute dry deposition velocities = ddvel -! -! 28-jun-2005 rce - initialize ddvel=0; call aerosol drydep routine -! only when drydep_opt == WESELY -! the wesely_driver routine computes aer_res, and currently -! you cannot compute aerosol drydep without it !! -! 08-jul-2005 rce - pass idrydep_onoff to mixactivate routines -! -! write(6,*)'call dry dep driver' - dep_vel_o3(:,:)=0. - ddvel(:,:,:) = 0.0 - idrydep_onoff = 0 - -! drydep_select: SELECT CASE(drydep_opt) - -! CASE ( WESELY ) -! -! drydep_opt == WESELY means -! wesely for gases -! other (appropriate) routine for aerosols -! -! CALL wrf_debug(15,'DOING DRY DEP VELOCITIES WITH WESELY METHOD') - -! IF( chem_opt /= CHEM_TRACER .and. chem_opt /= GOCART_SIMPLE ) THEN -! call wesely_driver(id,ktau,dtstep, & -! config_flags, & -! gmt,julday,t_phy,moist,p8w,t8w, & -! p_phy,chem,rho_phy,dz8w,ddvel,aer_res, & -! ivgtyp,tsk,gsw,vegfra,pbl,rmol,ust,znt,xlat,xlong,z,z_at_w,& -! numgas, & -! ids,ide, jds,jde, kds,kde, & -! ims,ime, jms,jme, kms,kme, & -! its,ite, jts,jte, kts,kte ) - IF (( chem_opt == GOCART_SIMPLE ) .or. & - ( chem_opt == GOCARTRACM_KPP) .or. & - ( chem_opt == 316) .or. & - ( chem_opt == 317) .or. & -! ( chem_opt == 502) .or. & - (chem_opt == 304 )) then -! -! this does aerosol species (dust,seas, bc,oc) for gocart only -!, - call gocart_drydep_driver(0, & - moist,p8w,chem,rho_phy,dz8w,ddvel,xland,hfx, & - ivgtyp,tsk,pbl,ust,znt,g, & - num_moist,num_chem, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) -! ddvel(:,:,p_vash_1:num_chem) = 0. - ddvel(:,:,p_dms) = 0. - ELSE if (chem_opt == 501 ) then -! for caesium .1cm/s -! - ddvel(:,:,:)=.001 - ELSE - !Set dry deposition velocity to zero when using the - !chemistry tracer mode. - ddvel(:,:,:) = 0. -! write(6,*)'no dry deposition ' - END IF - - idrydep_onoff = 1 - - - - - -! This will be called later from subgrd_transport_driver.F !!!!!!!! -! -! - do 100 j=jts,jte - do 100 i=its,ite - if(p_dust_1.gt.1)dep_vel_o3(i,j)=ddvel(i,j,p_dust_1) - pblst=0. -! -! -!-- start with vertical mixing -! - do k=kts,kte+1 - zzfull(k)=z_at_w(i,k,j)-z_at_w(i,kts,j) - enddo - do k=kts,kte - ekmfull(k)=max(1.e-6,exch_h(i,k,j)) - enddo - ekmfull(kts)=0. - ekmfull(kte+1)=0. - -!!$! UNCOMMENT THIS AND FINE TUNE LEVELS TO YOUR DOMAIN IF YOU WANT TO -!!$! FORCE MIXING TO A CERTAIN DEPTH: -!!$! -!!$! --- Mix the emissions up several layers -!!$! if e_co > 0., the grid cell should not be over water -!!$! if e_co > 200, the grid cell should be over a large urban region -!!$! -! if (e_co(i,kts,j) .gt. 0) then -! ekmfull(kts:kts+10) = max(ekmfull(kts:kts+10),1.) -! endif -! if (e_co(i,kts,j) .gt. 200) then -! ekmfull(kts:kte/2) = max(ekmfull(kts:kte/2),2.) -! endif -! -! - do k=kts,kte - zz(k)=z(i,k,j)-z_at_w(i,kts,j) - enddo -! -! vertical mixing routine (including deposition) -! need to be careful here with that dumm tracer in spot 1 -! do not need lho,lho2 -! (03-may-2006 rce - calc dryrho_1d and pass it to vertmx) -! -! if(j.eq.681)write(6,*)ddvel(1,681,1:num_chem) -! if(p_o3.gt.1)dep_vel_o3(i,j)=ddvel(i,j,p_o3) - do nv=1,num_chem-0 - do k=kts,kte - pblst(k)=max(epsilc,chem(i,k,j,nv)) - dryrho_1d(k) = 1./alt(i,k,j) -! if(j.eq.681.and.nv.eq.10)then -! write(6,*)k,chem(i,k,j,nv),exch_h(i,k,j),ddvel(i,j,nv) -! write(6,*)dryrho_1d(k),zz(k),zzfull(k) -! endif - enddo - - mix_select: SELECT CASE(chem_opt) - CASE (RADM2SORG_AQ, RACMSORG_AQ, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ) -! if(.not.is_aerosol(nv))then ! mix gases not aerosol - call vertmx(dtstep,pblst,ekmfull,dryrho_1d, & - zzfull,zz,ddvel(i,j,nv),kts,kte) - -! endif - - CASE DEFAULT - call vertmx(dtstep,pblst,ekmfull,dryrho_1d, & - zzfull,zz,ddvel(i,j,nv),kts,kte) - - END SELECT mix_select - - do k=kts,kte-1 -! if(j.eq.681.and.nv.eq.10)then -! write(6,*)pblst(k) -! endif - chem(i,k,j,nv)=max(epsilc,pblst(k)) -! if(j.eq.681.and.nv.eq.10)then -! write(6,*)dtstep,pblst(k),chem(i,k,j,nv) -! endif -! if(j.eq.75.and.nv.eq.16)write(6,*)zzfull(k),chem(i,k,j,nv),alt(i,k,j) - enddo - enddo -100 continue -! -! vertical mixing and activation of aerosol -! -! where( alt(its:ite,kts:kte,jts:jte) /= 0. ) !get dry density to conserve mass in mixactivate, wig, 24-apr-2006 -! dryrho_phy(its:ite,kts:kte,jts:jte) = 1./alt(its:ite,kts:kte,jts:jte) -! elsewhere -! dryrho_phy(its:ite,kts:kte,jts:jte) = 0. -! end where -! dryrho_phy(its:ite,kte+1,jts:jte) = 0. !wig: testing, should never need this - -! mixactivate_select: SELECT CASE(config_flags%chem_opt) - -! CASE (RADM2SORG_AQ, RACMSORG_AQ) -! call sorgam_mixactivate ( & -! id, ktau, dtstep, config_flags, idrydep_onoff, & -! dryrho_phy, t_phy, w, cldfra, cldfra_old, & -! ddvel, z, dz8w, p8w, t8w, exch_h, & -! moist(ims,kms,jms,P_QV), moist(ims,kms,jms,P_QC), moist(ims,kms,jms,P_QI), & -! scalar(ims,kms,jms,P_QNDROP), f_qc, f_qi, chem, & -! ccn1, ccn2, ccn3, ccn4, ccn5, ccn6, nsource, & -! ids,ide, jds,jde, kds,kde, & -! ims,ime, jms,jme, kms,kme, & -! its,ite, jts,jte, kts,kte ) -! CASE (CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ) -! CALL wrf_debug(15,'call mixactive for mosaic aerosol') -! call mosaic_mixactivate ( & -! id, ktau, dtstep, config_flags, idrydep_onoff, & -! dryrho_phy, t_phy, w, cldfra, cldfra_old, & -! ddvel, z, dz8w, p8w, t8w, exch_h, & -! moist(ims,kms,jms,P_QV), moist(ims,kms,jms,P_QC), moist(ims,kms,jms,P_QI), & -! scalar(ims,kms,jms,P_QNDROP), f_qc, f_qi, chem, & -! ccn1, ccn2, ccn3, ccn4, ccn5, ccn6, nsource, & -! ids,ide, jds,jde, kds,kde, & -! ims,ime, jms,jme, kms,kme, & -! its,ite, jts,jte, kts,kte ) -! CASE DEFAULT -! END SELECT mixactivate_select -! settling_select: SELECT CASE(config_flags%chem_opt) -! CASE (GOCART_SIMPLE,GOCARTRACM_KPP) -! CALL wrf_debug(15,'call gocart settling routine') -! call gocart_settling_driver(dtstep,config_flags,t_phy,moist, & -! chem,rho_phy,dz8w,p8w,p_phy, & -! dx,g, & -! ids,ide, jds,jde, kds,kde, & -! ims,ime, jms,jme, kms,kme, & -! its,ite, jts,jte, kts,kte ) -! CASE DEFAULT -! CALL wrf_debug(15,'no settling routine') -! END SELECT settling_select - -! CALL wrf_debug(15,'end of dry_dep_driver') - -END SUBROUTINE dry_dep_driver - -END MODULE module_dry_dep_driver diff --git a/src/fim/FIMsrc/fim/column_chem/module_gocart_aerosols.F90 b/src/fim/FIMsrc/fim/column_chem/module_gocart_aerosols.F90 deleted file mode 100644 index d2bf439..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_gocart_aerosols.F90 +++ /dev/null @@ -1,307 +0,0 @@ -MODULE module_gocart_aerosols - - USE module_initial_chem_namelists,only: p_bc1,p_bc2,p_oc1,p_oc2, & - p_dust_1,p_dust_2,p_dust_3,p_dust_4,p_dust_5,p_vash_1, & - p_seas_1,p_seas_2,p_seas_3,p_seas_4,p_sulf,p_p25,p_so2 - USE module_data_gocart_chem,only:airmw -!odule_species_decs -! USE module_model_constants, only: mwdry - INTEGER, PARAMETER ::NBC1=1, NOC1=2, NBC2=3, NOC2=4 - -CONTAINS - subroutine gocart_aerosols_driver(ktau,dt,t_phy,moist, & - chem,rho_phy,dz8w,p8w,area,g, & - chem_opt,num_chem,num_moist, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) -! USE module_configure -! USE module_state_description - IMPLICIT NONE -! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - - INTEGER, INTENT(IN ) :: ktau, & - chem_opt,num_chem,num_moist, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & - INTENT(IN ) :: moist - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & - INTENT(INOUT ) :: chem - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: t_phy, & - dz8w,p8w, & - rho_phy - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(IN ) :: area - - REAL, INTENT(IN ) :: dt,g - integer :: ndt1,nmx,i,j,k,imx,jmx,lmx - real*8, DIMENSION (1,1,1) :: tmp,airden,airmas - REAL*8 :: chmlos(1,1,1,4) - REAL*8 :: bchmlos(1,1,4) - REAL*8 :: pc2(1,1,1,2) - REAL*8 :: tc(4) - real, parameter :: mw_c = 12. - real mwdry,tt1,tt2 - mwdry=airmw - imx=1 - jmx=1 - lmx=1 - nmx=4 - ndt1=ifix(dt) -! -! - chmlos = 0. - bchmlos = 0. - do j=jts,jte - do k=kts,kte-1 - do i=its,ite - airmas(1,1,1)=-(p8w(i,k+1,j)-p8w(i,k,j))*area(i,j)/g - pc2(1,1,1,1)=0. - pc2(1,1,1,2)=0. - tc(1)=chem(i,k,j,p_bc1)/mw_c*mwdry*1.d-9 - tc(2)=chem(i,k,j,p_oc1)/mw_c*mwdry*1.d-9 - tc(3)=chem(i,k,j,p_bc2)/mw_c*mwdry*1.d-9 - tc(4)=chem(i,k,j,p_oc2)/mw_c*mwdry*1.d-9 - tt1=tc(3) - - CALL chem_1(imx,jmx,lmx, nmx, ndt1, airmas, tc, & - chmlos, bchmlos, pc2) - CALL chem_2(imx,jmx,lmx, nmx, ndt1, airmas, tc, pc2) - tt2 = tc(3) -tt1 - chem(i,k,j,p_bc1)=tc(1)/mwdry*mw_c*1.e9 - chem(i,k,j,p_oc1)=tc(2)/mwdry*mw_c*1.e9 - chem(i,k,j,p_bc2)=tc(3)/mwdry*mw_c*1.e9 - chem(i,k,j,p_oc2)=(tc(4)+8.*tt2)/mwdry*mw_c*1.e9 - - enddo - enddo - enddo -end subroutine gocart_aerosols_driver - subroutine sum_pm_gocart ( & - alt, chem,pm2_5_dry, pm2_5_dry_ec, pm10, & - num_chem,chem_opt,ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) -! USE module_configure -! USE module_state_description - IMPLICIT NONE - REAL, PARAMETER :: mwso4 = 96.066 - INTEGER, INTENT(IN ) :: chem_opt,ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte,num_chem - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & - INTENT(INOUT ) :: pm2_5_dry, pm2_5_dry_ec, pm10 - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & - INTENT(IN ) :: alt - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & - INTENT(IN ) :: chem - real minv,maxv,d_2_5,s_2_5,d_10,sulfate,mwdry - integer i,j,k,ii,jj,n,maxp,maxs,maxd - mwdry=airmw - d_2_5=0.3125 - s_2_5=0.75 - d_10=0.67 - -! -! sum up pm2_5 and pm10 output -! -! maxv=maxval(chem(its:ite, kts:kte, jts:jte, :)) -! minv=minval(chem(its:ite, kts:kte, jts:jte, :)) -!TBH commented out for now -- will not work in parallel without reduce -!TBH write(6,*)'in sumpm ',minv,maxv - pm2_5_dry(its:ite, kts:kte, jts:jte) = 0. - pm10(its:ite, kts:kte, jts:jte) = 0. - pm2_5_dry_ec(its:ite, kts:kte, jts:jte) = 0. -!TBH commented out for now while debugging -!TBH write(6,*)'p_p25 = ',p_p25,p_dust_1 -!TBH write(6,*)kts,kte,kms,kme,jts,jte,jms,jme -! do n=p_so2,p_dust_1 -! do j=jts,jte -! do k=kts,kte -! do i=its,ite -! pm10(i,k,j)=chem(i,k,j,n) -! if(n.eq.p_dust_1 .and. chem(i,k,j,n).lt.0.)write(6,*)'ERROR:',i,j,k,chem(i,k,j,n) -! enddo -! enddo -! enddo -! maxv=maxval(pm10(its:ite, kts:kte, jts:jte)) -! minv=minval(pm10(its:ite, kts:kte, jts:jte)) -! write(6,*)'in sumpm0 ',n,minv,maxv -! enddo -! minv=minval(alt(its:ite, kts:kte, jts:jte)) -! write(6,*)'alt',minv - do j=jts,jte - do k=kts,kte - do i=its,ite - sulfate=chem(i,k,j,p_sulf)*mwso4/mwdry*1.e3 - do n=p_p25,p_dust_1 - pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j)+chem(i,k,j,n) - enddo - if(chem_opt.eq.300)then - pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j)+chem(i,k,j,p_dust_2)*d_2_5 & - +chem(i,k,j,p_seas_1) & - +chem(i,k,j,p_seas_2)*s_2_5 & - +sulfate - else if(chem_opt .eq. 317) then - pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j)+chem(i,k,j,p_dust_2)*d_2_5 & - +chem(i,k,j,p_seas_1) & - +chem(i,k,j,p_seas_2)*s_2_5 & - +chem(i,k,j,p_vash_1) & - +sulfate - else - pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j)+chem(i,k,j,p_seas_1) & - +sulfate - endif - - !Convert the units from mixing ratio to concentration (ug m^-3) - pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j) / alt(i,k,j) - enddo - enddo - enddo - maxd=max(p_dust_2,p_dust_3) - maxp=max(p_dust_2,p_dust_4) - maxs=max(p_seas_2,p_seas_3) -! print *,'maxd,maxp,maxs = ',maxd,maxp,maxs - do j=jts,jte - do k=kts,kte - do i=its,ite - sulfate=chem(i,k,j,p_sulf)*mwso4/mwdry*1.e3 - do n=p_p25,maxd - pm10(i,k,j) = pm10(i,k,j)+chem(i,k,j,n) - enddo - do n=p_seas_1,maxs - pm10(i,k,j) = pm10(i,k,j)+chem(i,k,j,n) - enddo - pm10(i,k,j) = pm10(i,k,j) + sulfate & - +chem(i,k,j,maxp)*d_10 - pm10(i,k,j) = pm10(i,k,j)/ alt(i,k,j) -! if(pm10(i,k,j).gt.10000)write(6,*)j,k,sulfate,pm10(i,k,j) - enddo - enddo - enddo -! maxv=maxval(pm10(its:ite, kts:kte, jts:jte)) -! minv=minval(pm10(its:ite, kts:kte, jts:jte)) -! write(6,*)'in sumpm2 ',maxv,minv - -end subroutine sum_pm_gocart - -SUBROUTINE chem_1(imx,jmx,lmx, nmx, & - ndt1, airm, tc, chmlos, bchmlos, pc2) -! **************************************************************************** -! ** ** -! ** For tracers with dry deposition, the loss rate of dry dep is combined ** -! ** in chem loss term. Assuming a conversion time of 2.5 days (1-4 days, ** -! ** Lynn Russell) of conversion time from hydrophobic to hydrophilic. ** -! ** BC1 --> BC2 k = 4.63e-6 ** -! ** OC1 --> OC2 k = 4.63e-6 ** -! ** BC1 --> drydep kd = DRYDf (sec-1) ** -! ** OC1 --> drydep kd = DRYDf (sec-1) ** -! ** ** -! **************************************************************************** - - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: lmx, nmx,imx,jmx, ndt1 - REAL*8, INTENT(IN) :: airm(imx,jmx,lmx) - REAL*8, INTENT(INOUT) :: tc(imx,jmx,lmx,nmx) - REAL*8, INTENT(INOUT) :: chmlos(imx,jmx,lmx,nmx) - REAL*8, INTENT(INOUT) :: bchmlos(imx,jmx,nmx) - REAL*8, INTENT(OUT) :: pc2(imx,jmx,lmx,2) - - REAL*8 :: r1, c0, r2, rkt, c1 - INTEGER :: np, n, i, j, l - - ! executable statements - - r1 = 4.63E-6 - - DO n = 1,nmx - IF (n == NBC1 .OR. n == NOC1) THEN - IF (n == NBC1) np = 1 - IF (n == NOC1) np = 2 - DO l = 1,lmx - DO j = 1,jmx - DO i = 1,imx - - c0 = tc(i,j,l,n) - r2 = 0.0 ! used to be loss due to dry dep - rkt = (r1 + r2) * REAL(ndt1) - - c1 = c0 * EXP(-rkt) - c1 = MAX(c1, 1.0D-32) - tc(i,j,l,n) = c1 - - pc2(i,j,l,np) = (c0 - c1) * r1/(r1 + r2) - - ! Diagnostics: -! chmlos(i,j,l,np) = chmlos(i,j,l,np) + pc2(i,j,l,n)*airm(i,j,l) - chmlos(i,j,l,n) = chmlos(i,j,l,n) + pc2(i,j,l,np)*airm(i,j,l) - - END DO - END DO - END DO - - DO j = 1,jmx - DO i = 1,imx - bchmlos(i,j,n) = bchmlos(i,j,n) + SUM(chmlos(i,j,:,n)) - END DO - END DO - - END IF - END DO - -END SUBROUTINE chem_1 - -SUBROUTINE chem_2(imx,jmx,lmx, nmx, & - ndt1, airm, tc, pc2) -! **************************************************************************** -! * * -! * C2 = C2_0 * exp(-kt) + PC2/kt * (1.-exp(-kt)) * -! * where k = dry deposition, C2 = BC2 or OC2. * -! * * -! **************************************************************************** - - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: lmx,imx,jmx, nmx, ndt1 - REAL*8, INTENT(IN) :: airm(imx,jmx,lmx) - REAL*8, INTENT(INOUT) :: tc(imx,jmx,lmx,nmx) - REAL*8, INTENT(IN) :: pc2(imx,jmx,lmx,2) - - INTEGER :: np, n, i, j, l - REAL*8 :: c0, pp, rkt, c1 - - ! executable statements - - DO n = 1,nmx - IF (n == NBC2 .OR. n == NOC2) THEN - IF (n == NBC2) np = 1 - IF (n == NOC2) np = 2 -!CMIC$ doall autoscope - DO l = 1,lmx - DO j = 1,jmx - DO i = 1,imx - - c0 = tc(i,j,l,n) -! pp = pc2(i,j,l,n) - pp = pc2(i,j,l,np) - c1 = c0 + pp - - c1 = MAX(c1, 1.0D-32) - tc(i,j,l,n) = c1 - - - END DO - END DO - END DO - END IF - END DO - -END SUBROUTINE chem_2 - -END MODULE module_gocart_aerosols diff --git a/src/fim/FIMsrc/fim/column_chem/module_gocart_chem.F90 b/src/fim/FIMsrc/fim/column_chem/module_gocart_chem.F90 deleted file mode 100644 index c218142..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_gocart_chem.F90 +++ /dev/null @@ -1,820 +0,0 @@ -MODULE MODULE_GOCART_CHEM - USE module_initial_chem_namelists,only: p_o3,p_qi,p_qc,p_qv,p_dms,p_so2, & - p_sulf,p_msa,p_ho,p_h2o2,p_no3 -! USE module_constants,only: pi,rd,g -CONTAINS - - subroutine gocart_chem_driver(ktau,dt,gmt,julday,t_phy,moist, & - chem,rho_phy,dz8w,p8w,backg_oh,backg_h2o2,backg_no3, & - area,g,xlat,xlong,ttday,tcosz, & - chem_opt,num_chem,num_moist, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) -! USE module_configure -! USE module_state_description - USE module_phot_mad, only : calc_zenith - IMPLICIT NONE -! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - - INTEGER, INTENT(IN ) :: julday, ktau, & - chem_opt,num_chem,num_moist, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & - INTENT(IN ) :: moist - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & - INTENT(INOUT ) :: chem - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(IN ) :: & - area,xlat,xlong,ttday,tcosz - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: t_phy, & - backg_oh,backg_h2o2,backg_no3,dz8w,p8w, & - rho_phy - - REAL, INTENT(IN ) :: dt,g,gmt - integer :: nmx,i,j,k,imx,jmx,lmx - real*8, DIMENSION (1,1,1) :: tmp,airden,airmas,oh,xno3,h2o2,chldms_oh, & - chldms_no3,chldms_x,chpso2,chpmsa,chpso4, & - chlso2_oh,chlso2_aq,cldf - real*8, DIMENSION (1,1,4) :: tdry - real*8, DIMENSION (1,1) :: cossza - real, DIMENSION (1,1) :: sza,cosszax - real*8, DIMENSION (1,1,1,4) :: tc,bems - real*8, dimension (1) :: dxy - real:: rlat,xlonn - real :: xtime,zenith,zenita,azimuth,xhour,xmin,xtimin,gmtp - INTEGER :: ixhour - imx=1 - jmx=1 - lmx=1 - nmx=4 - tdry=0.d0 - xtime=ktau*dt/60. - ixhour=ifix(gmt+.01)+ifix(xtime/60.) - xhour=float(ixhour) - xmin=60.*gmt+(xtime-xhour*60.) - gmtp=mod(xhour,24.) - gmtp=gmtp+xmin/60. - -! -! following arrays for busget stuff only -! -! -! -! chem_select: SELECT CASE(config_flags%chem_opt) -! CASE (GOCART_SIMPLE) -! CALL wrf_debug(15,'calling gocart chemistry ') - if(chem_opt == 300 .or. chem_opt==316 .or. chem_opt==317)then -!TBH write(6,*)'in gocart_chem, julday = ',julday - do j=jts,jte - do i=its,ite - dxy(1)=area(i,j) - zenith=0. - zenita=0. - azimuth=0. - rlat=xlat(i,j)*3.1415926535590/180. - xlonn=xlong(i,j) - CALL szangle(1, 1, julday, gmtp, sza, cosszax,xlonn,rlat) - cossza(1,1)=cosszax(1,1) -! - do k=kts,kte-1 - chldms_oh=0. - chldms_no3=0. - chldms_x=0. - chpso2=0. - chpmsa=0. - chpso4=0. - chlso2_oh=0. - chlso2_aq=0. - cldf(1,1,1)=0. - if(p_qc.gt.1)then - if(moist(i,k,j,p_qc).gt.0.)cldf(1,1,1)=1. - endif - if(p_qi.gt.1)then - if(moist(i,k,j,p_qi).gt.0.)cldf(1,1,1)=1. - endif - tc(1,1,1,1)=chem(i,k,j,p_dms)*1.d-6 - tc(1,1,1,2)=chem(i,k,j,p_so2)*1.d-6 - tc(1,1,1,3)=chem(i,k,j,p_sulf)*1.d-6 - tc(1,1,1,4)=chem(i,k,j,p_msa)*1.d-6 - airmas(1,1,1)=-(p8w(i,k+1,j)-p8w(i,k,j))*area(i,j)/g - airden(1,1,1)=rho_phy(i,k,j) - tmp(1,1,1)=t_phy(i,k,j) -if (tcosz(i,j)/=0.0) then - oh(1,1,1)=86400./dt*cossza(1,1)*backg_oh(i,k,j)/tcosz(i,j) -else - oh(1,1,1)=1.0E-20 -endif -! TBH: END HACK - h2o2(1,1,1)=backg_h2o2(i,k,j) - IF (COSSZA(1,1) > 0.0) THEN - XNO3(1,1,1) = 0.0 - ELSE - ! -- Fraction of night - ! fnight = 1.0 - TTDAY(i,j)/86400.0 - ! The original xno3 values have been averaged over daytime - ! as well => divide by fnight to get the appropriate night-time - ! fraction from the monthly average - ! fnight/=0.0 (for fnight=0: all cosszax (including current - ! cossza) > 0.0) - xno3(1,1,1) = backg_no3(i,k,j) / (1.0 - TTDAY(i,j)/86400.) - END IF -! if(i.eq.19.and.j.eq.19.and.k.eq.kts)then -! write(0,*)backg_oh(i,k,j),backg_no3(i,k,j),ttday(i,j),tcosz(i,j) -! endif - - call chmdrv_su( imx,jmx,lmx,& - nmx, dt, tmp, airden, airmas, & - oh, xno3, h2o2, cldf, tc, tdry,cossza, & - chldms_oh, chldms_no3, chldms_x, chpso2, chpmsa, chpso4, & - chlso2_oh, chlso2_aq) - chem(i,k,j,p_dms)=tc(1,1,1,1)*1.e6 - chem(i,k,j,p_so2)=tc(1,1,1,2)*1.e6 - chem(i,k,j,p_sulf)=tc(1,1,1,3)*1.e6 - chem(i,k,j,p_msa)=tc(1,1,1,4)*1.e6 - enddo - enddo - enddo - else if(chem_opt.eq.301)then -!TBH write(0,*)'calling gocart chemistry in addition to racm_kpp' - do j=jts,jte - do i=its,ite - zenith=0. - zenita=0. - azimuth=0. - rlat=xlat(i,j)*3.1415926535590/180. - xlonn=xlong(i,j) - CALL szangle(1, 1, julday, gmtp, sza, cosszax,xlonn,rlat) - cossza(1,1)=cosszax(1,1) - do k=kts,kte-1 - chldms_oh=0. - chldms_no3=0. - chldms_x=0. - chpso2=0. - chpmsa=0. - chpso4=0. - chlso2_oh=0. - chlso2_aq=0. - cldf(1,1,1)=0. - if(p_qc.gt.1)then - if(moist(i,k,j,p_qc).gt.0.)cldf(1,1,1)=1. - endif - if(p_qi.gt.1)then - if(moist(i,k,j,p_qi).gt.0.)cldf(1,1,1)=1. - endif - tc(1,1,1,1)=chem(i,k,j,p_dms)*1.d-6 - tc(1,1,1,2)=chem(i,k,j,p_so2)*1.d-6 - tc(1,1,1,3)=chem(i,k,j,p_sulf)*1.d-6 - tc(1,1,1,4)=chem(i,k,j,p_msa)*1.d-6 - airmas(1,1,1)=-(p8w(i,k+1,j)-p8w(i,k,j))*area(i,j)/g - airden(1,1,1)=rho_phy(i,k,j) - tmp(1,1,1)=t_phy(i,k,j) - oh(1,1,1)=chem(i,k,j,p_ho)*1.d-6 - h2o2(1,1,1)=chem(i,k,j,p_h2o2)*1.d-6 - xno3(1,1,1) = chem(i,k,j,p_no3)*1.d-6 - IF (COSSZA(1,1) > 0.0)xno3(1,1,1) = 0. -! if(i.eq.19.and.j.eq.19.and.k.eq.kts)then -! write(0,*)backg_oh(i,k,j),backg_no3(i,k,j),ttday(i,j),tcosz(i,j) -! endif - - call chmdrv_su( imx,jmx,lmx,& - nmx, dt, tmp, airden, airmas, & - oh, xno3, h2o2, cldf, tc, tdry,cossza, & - chldms_oh, chldms_no3, chldms_x, chpso2, chpmsa, chpso4, & - chlso2_oh, chlso2_aq) - chem(i,k,j,p_dms)=tc(1,1,1,1)*1.e6 - chem(i,k,j,p_so2)=tc(1,1,1,2)*1.e6 - chem(i,k,j,p_sulf)=tc(1,1,1,3)*1.e6 - chem(i,k,j,p_msa)=tc(1,1,1,4)*1.e6 - enddo - enddo - enddo - endif -! END SELECT chem_select -end subroutine gocart_chem_driver - -!SUBROUTINE chmdrv_su( & -! imx, jmx, lmx, nmx, ndt1, tmp, drydf, airden, airmas, & -! oh, xno3, h2o2, cldf, tc, tdry, depso2, depso4, depmsa, & -! chldms_oh, chldms_no3, chldms_x, chpso2, chpmsa, chpso4, & -! chlso2_oh, chlso2_aq) - -!We don't apply losses due to dry deposition here, this is done in vertical mixing -SUBROUTINE chmdrv_su( imx,jmx,lmx,& - nmx, dt1, tmp, airden, airmas, & - oh, xno3, h2o2, cldf, tc, tdry,cossza, & - chldms_oh, chldms_no3, chldms_x, chpso2, chpmsa, chpso4, & - chlso2_oh, chlso2_aq) - -! **************************************************************************** -! ** ** -! ** Chemistry subroutine. For tracers with dry deposition, the loss ** -! ** rate of dry dep is combined in chem loss term. ** -! ** ** -! **************************************************************************** - -! USE module_data_gocart - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: nmx,imx,jmx,lmx - integer :: ndt1 - real, intent(in) :: dt1 - REAL*8, DIMENSION(imx,jmx,lmx), INTENT(IN) :: tmp, airden, airmas - REAL*8, DIMENSION(imx,jmx,lmx), INTENT(IN) :: oh, xno3, cldf - REAL*8, DIMENSION(imx,jmx,lmx), INTENT(INOUT) :: h2o2 -! REAL*8, INTENT(IN) :: drydf(imx,jmx,nmx) - REAL*8, INTENT(INOUT) :: tc(imx,jmx,lmx,nmx) - REAL*8, INTENT(INOUT) :: tdry(imx,jmx,nmx) - real*8, DIMENSION (imx,jmx),INTENT(IN) :: cossza -! REAL*8, DIMENSION(imx,jmx), INTENT(INOUT) :: depso2, depso4, depmsa - REAL*8, DIMENSION(imx,jmx,lmx), INTENT(INOUT) :: chldms_oh, chldms_no3 - REAL*8, DIMENSION(imx,jmx,lmx), INTENT(INOUT) :: chldms_x, chpso2, chpmsa - REAL*8, DIMENSION(imx,jmx,lmx), INTENT(INOUT) :: chpso4, chlso2_oh, chlso2_aq - - REAL*8, DIMENSION(imx,jmx,lmx) :: pso2_dms, pmsa_dms, pso4_so2 - - ! executable statements - ndt1=ifix(dt1) - if(ndt1.le.0)stop - - CALL chem_dms(imx,jmx,lmx,nmx, ndt1, tmp, airden, airmas, oh, xno3, & - tc, chldms_oh, chldms_no3, chldms_x, chpso2, chpmsa,cossza, & - pso2_dms, pmsa_dms) -! WRITE(*,*) 'after CHEM_DMS' - CALL chem_so2(imx,jmx,lmx,nmx, ndt1, tmp, airden, airmas, & - cldf, oh, h2o2, tc, tdry, cossza,& - chpso4, chlso2_oh, chlso2_aq, pso2_dms, pso4_so2) -! depso2, chpso4, chlso2_oh, chlso2_aq, pso2_dms, pso4_so2) -! WRITE(*,*) 'after CHEM_SO2' - CALL chem_so4(imx,jmx,lmx,nmx, ndt1, airmas, tc, tdry,cossza, & - pso4_so2) -! depso4, pso4_so2) -! WRITE(*,*) 'after CHEM_SO4' - CALL chem_msa(imx,jmx,lmx,nmx, ndt1, airmas, tc, tdry, cossza,& - pmsa_dms) -! depmsa, pmsa_dms) -! WRITE(*,*) 'after CHEM_MSA' - -END SUBROUTINE chmdrv_su - -!============================================================================= -SUBROUTINE chem_dms( imx,jmx,lmx,& - nmx, ndt1, tmp, airden, airmas, oh, xno3, & - tc, chldms_oh, chldms_no3, chldms_x, chpso2, chpmsa,cossza, & - pso2_dms, pmsa_dms) - -! **************************************************************************** -! * * -! * This is DMS chemistry subroutine. * -! * * -! * R1: DMS + OH -> a*SO2 + b*MSA OH addition channel * -! * k1 = { 1.7e-42*exp(7810/T)*[O2] / (1+5.5e-31*exp(7460/T)*[O2] } * -! * a = 0.75, b = 0.25 * -! * * -! * R2: DMS + OH -> SO2 + ... OH abstraction channel * -! * k2 = 1.2e-11*exp(-260/T) * -! * * -! * DMS_OH = DMS0 * exp(-(r1+r2)*NDT1) * -! * where DMS0 is the DMS concentration at the beginning, * -! * r1 = k1*[OH], r2 = k2*[OH]. * -! * * -! * R3: DMS + NO3 -> SO2 + ... * -! * k3 = 1.9e-13*exp(500/T) * -! * * -! * DMS = DMS_OH * exp(-r3*NDT1) * -! * where r3 = k3*[NO3]. * -! * * -! * R4: DMS + X -> SO2 + ... * -! * assume to be at the rate of DMS+OH and DMS+NO3 combined. * -! * * -! * The production of SO2 and MSA here, PSO2_DMS and PMSA_DMS, are saved * -! * for use in CHEM_SO2 and CHEM_MSA subroutines as a source term. They * -! * are in unit of MixingRatio/timestep. * -! * * -! **************************************************************************** - - USE module_data_gocart_chem - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: nmx, ndt1,imx,jmx,lmx - REAL*8, DIMENSION(imx,jmx,lmx), INTENT(IN) :: tmp, airden, airmas - REAL*8, DIMENSION(imx,jmx,lmx), INTENT(IN) :: oh, xno3 - REAL*8, INTENT(INOUT) :: tc(imx,jmx,lmx,nmx) - REAL*8, DIMENSION(imx,jmx,lmx), INTENT(INOUT) :: chldms_oh, chldms_no3 - REAL*8, DIMENSION(imx,jmx,lmx), INTENT(INOUT) :: chldms_x, chpso2, chpmsa - REAL*8, DIMENSION(imx,jmx,lmx), INTENT(OUT) :: pso2_dms, pmsa_dms - real*8, DIMENSION (imx,jmx),INTENT(IN) :: cossza - - REAL*8, PARAMETER :: fx = 1.0 - REAL*8, PARAMETER :: a = 0.75 - REAL*8, PARAMETER :: b = 0.25 - - ! From D4: only 0.8 efficiency, also some goes to DMSO and lost. - ! So we assume 0.75 efficiency for DMS addtion channel to form - ! products. - - REAL*8, PARAMETER :: eff = 1.0 - ! -- Factor to convert AIRDEN from kgair/m3 to molecules/cm3: - REAL*8, PARAMETER :: f = 1000.0 / airmw * 6.022D23 * 1.0D-6 - INTEGER :: i, j, l - REAL(KIND=8) :: tk, o2, dms0, rk1, rk2, rk3, dms_oh, dms, xoh, xn3, xx - - ! executable statements - - DO l = 1,lmx -!CMIC$ doall autoscope - DO j = 1,jmx - DO i = 1,imx - - tk = tmp(i,j,l) - o2 = airden(i,j,l) * f * 0.21 - dms0 = tc(i,j,l,NDMS) - -! **************************************************************************** -! * (1) DMS + OH: RK1 - addition channel; RK2 - abstraction channel. * -! **************************************************************************** - - rk1 = 0.0d0 - rk2 = 0.0d0 - rk3 = 0.0d0 - - IF (oh(i,j,l) > 0.0) THEN -! IF (TRIM(oh_units) == 'mol/mol') THEN - ! mozech: oh is in mol/mol - ! convert to molecules/cm3 - rk1 = (1.7D-42 * EXP(7810.0/tk) * o2) / & - (1.0 + 5.5D-31 * EXP(7460.0/tk) * o2 ) * oh(i,j,l) * & - airden(i,j,l)*f - rk2 = 1.2D-11*EXP(-260.0/tk) * oh(i,j,l)*airden(i,j,l)*f -! ELSE -! rk1 = (1.7D-42 * EXP(7810.0/tk) * o2) / & -! (1.0 + 5.5D-31 * EXP(7460.0/tk) * o2 ) * oh(i,j,l) -! rk2 = 1.2D-11*EXP(-260.0/tk) * oh(i,j,l) -! END IF - END IF - -! **************************************************************************** -! * (2) DMS + NO3 (only happens at night): * -! **************************************************************************** - - IF (cossza(i,j) <= 0.0) THEN - -! IF (TRIM(no3_units) == 'cm-3') THEN -! ! IMAGES: XNO3 is in molecules/cm3. -! rk3 = 1.9D-13 * EXP(500.0/tk) * xno3(i,j,l) - -! ELSE - ! GEOSCHEM (mergechem) and mozech: XNO3 is in mol/mol (v/v) - ! convert xno3 from volume mixing ratio to molecules/cm3 - rk3 = 1.9D-13 * EXP(500.0/tk) * xno3(i,j,l) * & - airden(i,j,l) * f -! END IF - - END IF - -! **************************************************************************** -! * Update DMS concentrations after reaction with OH and NO3, and also * -! * account for DMS + X assuming at a rate as (DMS+OH)*Fx in the day and * -! * (DMS+NO3)*Fx at night: * -! * DMS_OH : DMS concentration after reaction with OH * -! * DMS : DMS concentration after reaction with NO3 * -! * (min(DMS) = 1.0E-32) * -! **************************************************************************** - - dms_oh = dms0 * EXP( -(rk1 + rk2) * fx * REAL(ndt1) ) - dms = dms_oh * EXP( -(rk3) * fx * REAL(ndt1) ) - dms = MAX(dms, 1.0D-16) - - tc(i,j,l,NDMS) = dms - -! **************************************************************************** -! * Save SO2 and MSA production from DMS oxidation * -! * (in MixingRatio/timestep): * -! * * -! * SO2 is formed in DMS + OH addition (0.85) and abstraction (1.0) * -! * channels as well as DMS + NO3 reaction. We also assume that * -! * SO2 yield from DMS + X is 1.0. * -! * MSA is formed in DMS + OH addition (0.15) channel. * -! **************************************************************************** - - IF ((rk1 + rk2) == 0.0) THEN - pmsa_dms(i,j,l) = 0.0 - ELSE -! pmsa_dms(i,j,l) = (dms0 - dms_oh) * b*rk1/((rk1+rk2)*fx) - pmsa_dms(i,j,l) = (dms0 - dms_oh) * b*rk1/((rk1+rk2) * fx) * eff - END IF - pso2_dms(i,j,l) = dms0 - dms - pmsa_dms(i,j,l) -! pso2_dms(i,j,l) = (dms0 - dms - pmsa_dms(i,j,l)/eff) * eff - - ! ------------------------------------------------------------ - ! DIAGNOSTICS: DMS loss (kgS/timstep) - ! SO2 production (kgS/timestep) - ! MSA production (kgS/timestep) - ! ------------------------------------------------------------ - xoh = (dms0 - dms_oh) / fx * airmas(i,j,l)/airmw*smw - xn3 = (dms_oh - dms) / fx * airmas(i,j,l)/airmw*smw - xx = (dms0 - dms) * airmas(i,j,l)/airmw*smw - xoh - xn3 - - chldms_oh (i,j,l) = chldms_oh (i,j,l) + xoh - chldms_no3(i,j,l) = chldms_no3(i,j,l) + xn3 - chldms_x (i,j,l) = chldms_x (i,j,l) + xx - - chpso2(i,j,l) = chpso2(i,j,l) + pso2_dms(i,j,l) & - * airmas(i,j,l) / airmw * smw - chpmsa(i,j,l) = chpmsa(i,j,l) + pmsa_dms(i,j,l) & - * airmas(i,j,l) / airmw * smw - - END DO - END DO - END DO - -END SUBROUTINE chem_dms - -!============================================================================= - -SUBROUTINE chem_so2( imx,jmx,lmx,& - nmx, ndt1, tmp, airden, airmas, & - cldf, oh, h2o2, tc, tdry, cossza,& - chpso4, chlso2_oh, chlso2_aq, pso2_dms, pso4_so2) -! depso2, chpso4, chlso2_oh, chlso2_aq, pso2_dms, pso4_so2) - -! **************************************************************************** -! * * -! * This is SO2 chemistry subroutine. * -! * * -! * SO2 production: * -! * DMS + OH, DMS + NO3 (saved in CHEM_DMS) * -! * * -! * SO2 loss: * -! * SO2 + OH -> SO4 * -! * SO2 -> drydep (NOT USED IN WRF/CHEM * -! * SO2 + H2O2 or O3 (aq) -> SO4 * -! * * -! * SO2 = SO2_0 * exp(-bt) * -! * + PSO2_DMS/bt * [1-exp(-bt)] * -! * where b is the sum of the reaction rate of SO2 + OH and the dry * -! * deposition rate of SO2, PSO2_DMS is SO2 production from DMS in * -! * MixingRatio/timestep. * -! * * -! * If there is cloud in the gridbox (fraction = fc), then the aqueous * -! * phase chemistry also takes place in cloud. The amount of SO2 oxidized * -! * by H2O2 in cloud is limited by the available H2O2; the rest may be * -! * oxidized due to additional chemistry, e.g, reaction with O3 or O2 * -! * (catalyzed by trace metal). * -! * * -! **************************************************************************** - USE module_data_gocart_chem - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: nmx, ndt1,imx,jmx,lmx - REAL*8, DIMENSION(imx,jmx,lmx), INTENT(IN) :: tmp, airden, airmas - REAL*8, DIMENSION(imx,jmx,lmx), INTENT(IN) :: cldf, oh - REAL*8, DIMENSION(imx,jmx,lmx), INTENT(INOUT) :: h2o2 - real*8, DIMENSION (imx,jmx),INTENT(IN) :: cossza -! REAL*8, INTENT(IN) :: drydf(imx,jmx,nmx) - REAL*8, INTENT(INOUT) :: tc(imx,jmx,lmx,nmx) - REAL*8, INTENT(INOUT) :: tdry(imx,jmx,nmx) - -! REAL*8, DIMENSION(imx,jmx), INTENT(INOUT) :: depso2 - REAL*8, DIMENSION(imx,jmx,lmx), INTENT(INOUT) :: chpso4, chlso2_oh, chlso2_aq - REAL*8, INTENT(IN) :: pso2_dms(imx,jmx,lmx) - REAL*8, INTENT(OUT) :: pso4_so2(imx,jmx,lmx) - - REAL*8 :: k0, kk, m, l1, l2, ld - ! Factor to convert AIRDEN from kgair/m3 to molecules/cm3: - REAL*8, PARAMETER :: f = 1000. / airmw * 6.022D23 * 1.0D-6 - REAL*8, PARAMETER :: ki = 1.5D-12 - INTEGER :: i, j, l - REAL*8 :: so20, tk, f1, rk1, rk2, rk, rkt, so2_cd, fc, so2 - - ! executable statements - - DO l = 1,lmx - DO j = 1,jmx - DO i = 1,imx - - so20 = tc(i,j,l,NSO2) - - ! RK1: SO2 + OH(g), in s-1 - tk = tmp(i,j,l) - k0 = 3.0D-31 * (300.0/tk)**3.3 - m = airden(i,j,l) * f - kk = k0 * m / ki - f1 = ( 1.0+ ( LOG10(kk) )**2 )**(-1) -! IF (TRIM(oh_units) == 'mol/mol') THEN - ! mozech: oh is in mol/mol - ! convert to molecules/cm3 - rk1 = ( k0 * m / (1.0 + kk) ) * 0.6**f1 * & - oh(i,j,l)*airden(i,j,l)*f -! ELSE -! rk1 = ( k0 * m / (1.0 + kk) ) * 0.6**f1 * oh(i,j,l) -! END IF - - ! RK2: SO2 drydep frequency, s-1 -! IF (l == 1) THEN ! at the surface -! rk2 = drydf(i,j,NSO2) -! ELSE - rk2 = 0.0 -! END IF - - rk = (rk1 + rk2) - rkt = rk * REAL(ndt1) - -! **************************************************************************** -! * Update SO2 concentration after gas phase chemistry and deposition. * -! **************************************************************************** - - IF (rk > 0.0) THEN - so2_cd = so20 * EXP(-rkt) & - + pso2_dms(i,j,l) * (1.0 - EXP(-rkt)) / rkt - l1 = (so20 - so2_cd + pso2_dms(i,j,l)) * rk1/rk - IF (l == 1) THEN - ld = (so20 - so2_cd + pso2_dms(i,j,l)) * rk2/rk - ELSE - ld = 0.0 - END IF - ELSE - so2_cd = so20 - l1 = 0.0 - END IF - -! **************************************************************************** -! * Update SO2 concentration after cloud chemistry. * -! * SO2 chemical loss rate = SO4 production rate (MixingRatio/timestep). * -! **************************************************************************** - - ! Cloud chemistry (above 258K): - fc = cldf(i,j,l) - IF (fc > 0.0 .AND. so2_cd > 0.0 .AND. tk > 258.0) THEN - - IF (so2_cd > h2o2(i,j,l)) THEN - fc = fc * (h2o2(i,j,l)/so2_cd) - h2o2(i,j,l) = h2o2(i,j,l) * (1.0 - cldf(i,j,l)) - ELSE - h2o2(i,j,l) = h2o2(i,j,l) * & - (1.0 - cldf(i,j,l)*so2_cd/h2o2(i,j,l)) - END IF - so2 = so2_cd * (1.0 - fc) - ! Aqueous phase SO2 loss rate (MixingRatio/timestep): - l2 = so2_cd * fc - ELSE - so2 = so2_cd - l2 = 0.0 - END IF - - so2 = MAX(so2, 1.0D-16) - tc(i,j,l,NSO2) = so2 - -! **************************************************************************** -! * SO2 chemical loss rate = SO4 production rate (MixingRatio/timestep). * -! **************************************************************************** - - pso4_so2(i,j,l) = l1 + l2 - - ! --------------------------------------------------------------- - ! DIAGNOSTICS: SO2 gas-phase loss (kgS/timestep) - ! SO2 aqueous-phase loss (kgS/timestep) - ! SO2 dry deposition loss (kgS/timestep) - ! SO4 production (kgS/timestep) - ! --------------------------------------------------------------- - chlso2_oh(i,j,l) = chlso2_oh(i,j,l) & - + l1 * airmas(i,j,l) / airmw * smw - chlso2_aq(i,j,l) = chlso2_aq(i,j,l) & - + l2 * airmas(i,j,l) / airmw * smw - IF (l == 1) & -! depso2(i,j) = depso2(i,j) + ld * airmas(i,j,l) / airmw * smw - - chpso4(i,j,l) = chpso4(i,j,l) + pso4_so2(i,j,l) & - * airmas(i,j,l) / airmw * smw - - END DO - END DO - END DO - -! tdry(:,:,NSO2) = depso2(:,:)*tcmw(NSO2)/smw ! kg of SO2 - -END SUBROUTINE chem_so2 - -!============================================================================= - -SUBROUTINE chem_so4( imx,jmx,lmx,& - nmx, ndt1, airmas, tc, tdry, cossza,& - pso4_so2) -! depso4, pso4_so2) - -! **************************************************************************** -! * * -! * This is SO4 chemistry subroutine. * -! * * -! * The Only production is from SO2 oxidation (save in CHEM_SO2), and the * -! * only loss is dry depsition here. Wet deposition will be treated in * -! * WETDEP subroutine. * -! * * -! * SO4 = SO4_0 * exp(-kt) + PSO4_SO2/kt * (1.-exp(-kt)) * -! * where k = dry deposition. * -! * * -! **************************************************************************** - USE module_data_gocart_chem - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: nmx, ndt1,imx,jmx,lmx - REAL*8, DIMENSION(imx,jmx,lmx), INTENT(IN) :: airmas -! REAL*8, INTENT(IN) :: drydf(imx,jmx,nmx) - REAL*8, INTENT(INOUT) :: tc(imx,jmx,lmx,nmx) - REAL*8, INTENT(INOUT) :: tdry(imx,jmx,nmx) - -! REAL*8, DIMENSION(imx,jmx), INTENT(INOUT) :: depso4 - REAL*8, INTENT(IN) :: pso4_so2(imx,jmx,lmx) - real*8, DIMENSION (imx,jmx),INTENT(IN) :: cossza - - INTEGER :: i, j, l - REAL*8 :: so40, rk, rkt, so4 - - ! executable statements - - DO l = 1,lmx - DO j = 1,jmx - DO i = 1,imx - - so40 = tc(i,j,l,NSO4) - - ! RK: SO4 drydep frequency, s-1 -! IF (l == 1) THEN -! rk = drydf(i,j,NSO4) -! rkt = rk * REAL(ndt1) -! -! so4 = so40 * EXP(-rkt) + pso4_so2(i,j,l)/rkt * (1.0 - EXP(-rkt)) -! ELSE - so4 = so40 + pso4_so2(i,j,l) -! END IF - - so4 = MAX(so4, 1.0D-16) - tc(i,j,l,NSO4) = so4 - - ! -------------------------------------------------------------- - ! DIAGNOSTICS: SO4 dry deposition (kgS/timestep) - ! -------------------------------------------------------------- -! IF (l == 1) & -! depso4(i,j) = depso4(i,j) + (so40 - so4 + pso4_so2(i,j,l)) & -! * airmas(i,j,l) / airmw * smw - - END DO - END DO - END DO - - ! tdry(:,:,NSO4) = depso4(:,:)*tcmw(NSO4)/smw ! kg of SO4 - -END SUBROUTINE chem_so4 - -!============================================================================= - -SUBROUTINE chem_msa( imx,jmx,lmx,& - nmx, ndt1, airmas, tc, tdry, cossza,& - pmsa_dms) -! depmsa, pmsa_dms) - -! **************************************************************************** -! * * -! * This is MSA chemistry subroutine. * -! * * -! * The Only production is from DMS oxidation (save in CHEM_DMS), and the * -! * only loss is dry depsition here. Wet deposition will be treated in * -! * WETDEP subroutine. * -! * * -! * MSA = MSA_0 * exp(-dt) + PMSA_DMS/kt * (1.-exp(-kt)) * -! * where k = dry deposition. * -! * * -! **************************************************************************** - USE module_data_gocart_chem - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: nmx, ndt1,imx,jmx,lmx - REAL*8, DIMENSION(imx,jmx,lmx), INTENT(IN) :: airmas - REAL*8, DIMENSION(imx,jmx), INTENT(IN) :: cossza -! REAL, INTENT(IN) :: drydf(imx,jmx,nmx) - REAL*8, INTENT(INOUT) :: tc(imx,jmx,lmx,nmx) - REAL*8, INTENT(INOUT) :: tdry(imx,jmx,nmx) -! REAL, DIMENSION(imx,jmx), INTENT(INOUT) :: depmsa - REAL*8, INTENT(IN) :: pmsa_dms(imx,jmx,lmx) - - REAL*8 :: msa0, msa, rk, rkt - INTEGER :: i, j, l - - ! executable statements - - DO l = 1,lmx - DO j = 1,jmx - DO i = 1,imx - - msa0 = tc(i,j,l,NMSA) - - ! RK: MSA drydep frequency, s-1 -! IF (l == 1) THEN -! rk = drydf(i,j,NMSA) -! rkt = rk * REAL(ndt1) -! -! msa = msa0 * EXP(-rkt) & -! + pmsa_dms(i,j,l)/rkt * (1.0 - EXP(-rkt)) -! -! ELSE - msa = msa0 + pmsa_dms(i,j,l) -! END IF - - msa = MAX(msa, 1.0D-16) - tc(i,j,l,NMSA) = msa - - ! -------------------------------------------------------------- - ! DIAGNOSTICS: MSA dry deposition (kgS/timestep) - ! -------------------------------------------------------------- -! IF (l == 1) & -! depmsa(i,j) = depmsa(i,j) + (msa0 - msa + pmsa_dms(i,j,l)) & -! * airmas(i,j,l) / airmw * smw - - END DO - END DO - END DO - -! tdry(:,:,NMSA) = depmsa(:,:)*tcmw(NMSA)/smw ! kg of MSA - -END SUBROUTINE chem_msa -SUBROUTINE szangle(imx, jmx, doy, xhour, sza, cossza,xlon,rlat) - -! -! **************************************************************************** -! ** ** -! ** This subroutine computes solar zenith angle (SZA): ** -! ** ** -! ** cos(SZA) = sin(LAT)*sin(DEC) + cos(LAT)*cos(DEC)*cos(AHR) ** -! ** ** -! ** where LAT is the latitude angle, DEC is the solar declination angle, ** -! ** and AHR is the hour angle, all in radius. ** -! ** ** -! ** DOY = day-of-year, XHOUR = UT time (hrs). ** -! ** XLON = longitude in degree, RLAT = latitude in radian. ** -! **************************************************************************** -! - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: imx, jmx - INTEGER, INTENT(IN) :: doy - REAL, INTENT(IN) :: xhour - REAL, INTENT(OUT) :: sza(imx,jmx), cossza(imx,jmx) - - REAL :: a0, a1, a2, a3, b1, b2, b3, r, dec, timloc, ahr,xlon,rlat - real, parameter :: pi=3.14 - INTEGER :: i, j - - ! executable statements - - ! *************************************************************************** - ! * Solar declination angle: * - ! *************************************************************************** - a0 = 0.006918 - a1 = 0.399912 - a2 = 0.006758 - a3 = 0.002697 - b1 = 0.070257 - b2 = 0.000907 - b3 = 0.000148 - r = 2.0* pi * REAL(doy-1)/365.0 - ! - dec = a0 - a1*COS( r) + b1*SIN( r) & - - a2*COS(2.0*r) + b2*SIN(2.0*r) & - - a3*COS(3.0*r) + b3*SIN(3.0*r) - ! - DO i = 1,imx - ! ************************************************************************ - ! * Hour angle (AHR) is a function of longitude. AHR is zero at * - ! * solar noon, and increases by 15 deg for every hour before or * - ! * after solar noon. * - ! ************************************************************************ - ! -- Local time in hours - timloc = xhour + xlon/15.0 - ! IF (timloc < 0.0) timloc = 24.0 + timloc - IF (timloc > 24.0) timloc = timloc - 24.0 - ! - ! -- Hour angle - ahr = ABS(timloc - 12.0) * 15.0 * pi/180.0 - ! - DO j = 1,jmx - ! -- Solar zenith angle - cossza(i,j) = SIN(rlat) * SIN(dec) + & - COS(rlat) * COS(dec) * COS(ahr) - sza(i,j) = ACOS(cossza(i,j)) * 180.0/pi - IF (cossza(i,j) < 0.0) cossza(i,j) = 0.0 - ! - END do - END DO - -END subroutine szangle - -END MODULE MODULE_GOCART_CHEM diff --git a/src/fim/FIMsrc/fim/column_chem/module_gocart_dmsemis.F90 b/src/fim/FIMsrc/fim/column_chem/module_gocart_dmsemis.F90 deleted file mode 100644 index ac9e8d1..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_gocart_dmsemis.F90 +++ /dev/null @@ -1,222 +0,0 @@ -module module_dms_emis - USE module_data_gocart_chem -contains - - subroutine gocart_dmsemis(dt,alt,t_phy,u_phy, & - v_phy,chem,rho_phy,dz8w,u10,v10,p8w,dms_0,tsk, & - ivgtyp,isltyp,xland,area,g,mwdry, & - num_chem,p_dms,ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) -! USE module_configure -! USE module_state_description -! USE module_model_constants, only : mwdry - IMPLICIT NONE -! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - - INTEGER, INTENT(IN ) :: p_dms,ids,ide, jds,jde, kds,kde, & - num_chem,ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & - INTENT(INOUT ) :: chem - REAL, DIMENSION( ims:ime, jms:jme), & - INTENT(IN ) :: dms_0,tsk - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & - INTENT(IN ) :: alt, & - t_phy, & - dz8w, & - p8w,u_phy,v_phy,rho_phy - INTEGER,DIMENSION( ims:ime , jms:jme ) , & - INTENT(IN ) :: & - ivgtyp, & - isltyp - REAL, DIMENSION( ims:ime , jms:jme ) , & - INTENT(IN ) :: & - u10, & - v10, & - area,xland - real, intent(in) :: g,dt,mwdry - -! -! local variables -! - integer :: i,j,k,ndt,imx,jmx,lmx,nmx - integer,dimension (1,1) :: ilwi - real*8, DIMENSION (1,1,1,1) :: tc - real*8, DIMENSION (1,1,1) :: bems,airmas - real*8, DIMENSION (1,1) :: emsdms - real*8, dimension (1,1) :: w10m,gwet,airden,tskin,dmso - real*8, dimension (1) :: dxy - real*8,parameter::max_default=1.e-30 -! -! number of dust bins -! - imx=1 - jmx=1 - lmx=1 - nmx=1 - k=kts - ndt=ifix(dt) - do j=jts,jte - do i=its,ite -! -! donṫ do this over land -! - if(xland(i,j).gt.1.5 .and. tsk(i,j).gt.273.)then - ilwi(1,1)=0 - - tc(1,1,1,1)=chem(i,kts,j,p_dms)*1.d-6 - dmso(1,1)=dms_0(i,j) -! w10m(1,1)=sqrt(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j)) - airmas(1,1,1)=-1.*(p8w(i,kts+1,j)-p8w(i,kts,j))*area(i,j)/g - dxy(1)=area(i,j) - tskin(1,1)=tsk(i,j) - emsdms(1,1)=0. -! -! we donṫ trust the u10,v10 values, is model layers are very thin near surface -! -! if(dz8w(i,kts,j).lt.12.)w10m=sqrt(u_phy(i,kts,j)*u_phy(i,kts,j)+v_phy(i,kts,j)*v_phy(i,kts,j)) - w10m=sqrt(u_phy(i,kts,j)*u_phy(i,kts,j)+v_phy(i,kts,j)*v_phy(i,kts,j)) - - call srcdms(imx, jmx, lmx, nmx, ndt, tc, mwdry,& - tskin, ilwi, dmso, w10m, airmas, dxy, emsdms, bems) -! chem(i,kts,j,p_dms)=max(1.e-30,tc(1,1,1,1)*1.e6) - chem(i,kts,j,p_dms)=max(max_default,tc(1,1,1,1)*1.e6) - endif - enddo - enddo -! -end subroutine gocart_dmsemis - -SUBROUTINE srcdms(imx, jmx, lmx, nmx, ndt1, tc,airmw, & - tskin, ilwi, dmso, w10m, airmas, dxy, emsdms, bems) - - ! ************************************************************************** - ! ** ** - ! ** This subroutine calculates DMS emissions from the ocean. ** - ! ** ** - ! ************************************************************************** - - - IMPLICIT NONE - REAL, PARAMETER :: dms_mw = 62.00 - REAL, PARAMETER :: tcmw(1)=dms_mw - INTEGER, INTENT(IN) :: imx, jmx, lmx, nmx, ndt1 - REAL*8, INTENT(IN) :: tskin(imx,jmx), dmso(imx,jmx) - INTEGER, INTENT(IN) :: ilwi(imx,jmx) - REAL*8, INTENT(IN) :: dxy(jmx), w10m(imx,jmx) - REAL, INTENT(IN) :: airmw - REAL*8, INTENT(IN) :: airmas(imx,jmx,lmx) - REAL*8, INTENT(INOUT) :: tc(imx,jmx,lmx,nmx) - REAL*8, INTENT(INOUT) :: emsdms(imx,jmx) - REAL*8, INTENT(OUT) :: bems(imx,jmx,nmx) - - INTEGER :: i,j - REAL*8 :: sst, sc, conc, w10, scco2, akw, erate, dmssrc, c - - ! ************************************************************************** - ! * ilwi = 0: water ** - ! * If ilwi = 0: DMSEMS = seawaterDMS * transfer velocity. ** - ! * Otherwise, DMSEMS = 0.0 ** - ! ************************************************************************** - - ! executable statements -! tcmw(NDMS) = dms_mw - lat_loop: DO j = 1,jmx - lon_loop: DO i = 1,imx - ! convert tskin (=sst over water) from K to degC - sst = tskin(i,j) - 273.15 -! if_water: IF (ilwi(i,j) == 0) THEN - - ! -- Schmidt number for DMS (Saltzman et al., 1993) - sc = 2674.0 - 147.12*sst + 3.726*(sst**2) - 0.038*(sst**3) - -! **************************************************************************** -! * Calculate transfer velocity in cm/hr (AKw) * -! * * -! * Tans et al. transfer velocity (1990) for CO2 at 25oC (Erickson, 1993) * -! * * -! * Tans et al. assumed AKW=0 when W10<=3. I modified it to let * -! * DMS emit at low windseeds too. Chose 3.6m/s as the threshold. * -! * * -! * Schmidt number for CO2: Sc = 600 (20oC, fresh water) * -! * Sc = 660 (20oC, seawater) * -! * Sc = 428 (25oC, Erickson 93) * -! **************************************************************************** - - conc = dmso(i,j) - - w10 = w10m(i,j) -! ! --- GEOS-1 or GEOS-STRAT: using SSMI winds -! IF (lmx <= 26) w10 = wssmi(i,j) - -! --- Tans et al. (1990) ----------------- -! ScCO2 = 428. -! if (W10 .le. 3.6) then -! AKw = 1.0667 * W10 -! else -! AKw = 6.4 * (W10 - 3.) -! end if - -! --- Wanninkhof (1992) ------------------ -! ScCO2 = 660. -! AKw = 0.31 * W10**2 - - ! --- Liss and Merlivat (1986) ----------- - scco2 = 600.0 - IF (w10 <= 3.6) THEN - akw = 0.17 * w10 - ELSE IF (w10 <= 13.0) THEN - akw = 2.85 * w10 - 9.65 - ELSE - akw = 5.90 * w10 - 49.3 - END IF - ! ------------------------------------------ - - IF (w10 <= 3.6) THEN - akw = akw * ((scco2/sc) ** 0.667) - ELSE - akw = akw * SQRT(scco2/sc) - END IF - -! **************************************************************************** -! * Calculate emission flux in kg/box/timestep * -! * * -! * AKw is in cm/hr: AKw/100/3600 -> m/sec * -! * CONC is in nmol/L (nmol/dm3): CONC*1E-12*1000 -> kmol/m3 * -! * TCMW(NDMS) : kgDMS/kmol * -! * ERATE : kgDMS/m2/timestep * -! * DMSSRC : kgDMS/box/timestep * -! **************************************************************************** - - erate = akw/100.0/3600.0*conc*1.0E-12*1000.0*REAL(ndt1)*tcmw(NDMS) - dmssrc = erate * dxy(j) - -! ELSE ! ilwi /= 0 (water) - -! dmssrc = 0.0 - -! END IF if_water - -! **************************************************************************** -! * Update DMS concentration in level 1 (where emission occurs) * -! **************************************************************************** - - ! -- Convert emission from kg/box/timestep to mixing ratio/timestep: - c = dmssrc / airmas(i,j,1) * airmw / tcmw(NDMS) - tc(i,j,1,NDMS) = tc(i,j,1,NDMS) + c - - ! --------------------------------------------------------------- - ! Diagnostics: DMS surface emission in kgS/timestep - ! --------------------------------------------------------------- - emsdms(i,j) = emsdms(i,j) + dmssrc * smw / tcmw(NDMS) ! kgS -! bems(i,j,NDMS) = c * airmas(i,j,1) / airmw * smw ! kgS - bems(i,j,NDMS) = dmssrc ! kgDMS - - END DO lon_loop - END DO lat_loop - -END SUBROUTINE srcdms - -END module module_dms_emis diff --git a/src/fim/FIMsrc/fim/column_chem/module_gocart_drydep.F90 b/src/fim/FIMsrc/fim/column_chem/module_gocart_drydep.F90 deleted file mode 100644 index 726dc90..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_gocart_drydep.F90 +++ /dev/null @@ -1,301 +0,0 @@ -MODULE module_gocart_drydep -CONTAINS - subroutine gocart_drydep_driver(numgas, & - moist,p8w,chem,rho_phy,dz8w,ddvel,xland,hfx, & - ivgtyp,tsk,pbl,ust,znt,g, & - num_moist,num_chem, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) -! USE module_model_constants -! USE module_configure -! USE module_state_description - IMPLICIT NONE - - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - num_moist,num_chem, & - its,ite, jts,jte, kts,kte,numgas - REAL, INTENT(IN ) :: g - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & - INTENT(IN ) :: moist - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & - INTENT(INOUT ) :: chem - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & - INTENT(IN ) :: & - dz8w, & - p8w,rho_phy - INTEGER,DIMENSION( ims:ime , jms:jme ) , & - INTENT(IN ) :: & - ivgtyp - REAL, DIMENSION( ims:ime , jms:jme ) , & - INTENT(INOUT) :: & - tsk, & - pbl, & - ust, & - xland,znt,hfx - -!! .. Local Scalars .. - - INTEGER :: iland, iprt, iseason, jce, jcs, & - n, nr, ipr, jpr, nvr, & - idrydep_onoff,imx,jmx,lmx - - REAL, DIMENSION( its:ite, jts:jte, num_chem ) :: ddvel - integer :: ii,jj,kk,i,j,k,nv - integer,dimension (1,1) :: ilwi - real*8, DIMENSION (5) :: tc,bems - real*8, dimension (1,1) :: z0,w10m,gwet,airden,airmas,delz_sfc,hflux,ts,pblz,ustar,ps - REAL*8 :: dvel(1,1), drydf(1,1) - - do j=jts,jte - do i=its,ite - do nv=numgas+1,num_chem - ddvel(i,j,nv)=0. - enddo - enddo - enddo - imx=1 - jmx=1 - lmx=1 - do j=jts,jte - do i=its,ite - dvel(1,1)=0. - ilwi(1,1)=0 - if(xland(i,j).gt.1.5)ilwi=1 -! for aerosols, ii=1 or ii=2 - ii=1 - if(ivgtyp(i,j).eq.19.or.ivgtyp(i,j).eq.23)ii=1 - airden(1,1)=rho_phy(i,kts,j) - delz_sfc(1,1)=dz8w(i,kts,j) - ustar(1,1)=ust(i,j) - hflux(1,1)=hfx(i,j) - pblz(1,1)=pbl(i,j) - ps(1,1)=p8w(i,kts,j)*.01 - z0(1,1)=znt(i,j) - ts(1,1)=tsk(i,j) - -! if(j.eq.681)then -! write(6,*)'in drydepdriver_gocart',ust(i,j),hfx(i,j),znt(i,j),ivgtyp(i,j) -! endif - call depvel_gocart(ii,imx,jmx,lmx,& - airden, delz_sfc, pblz, ts, ustar, hflux, ilwi, & - ps, z0, dvel, drydf,g) -! if(j.eq.681)write(6,*)numgas,num_chem,dvel(1,1) - do nv=numgas+1,num_chem - ddvel(i,j,nv)=dvel(1,1) - enddo - enddo - enddo -end subroutine gocart_drydep_driver - - - -SUBROUTINE depvel_gocart( & - ii,imx,jmx,lmx,& - airden, delz_sfc, pblz, ts, ustar, hflux, ilwi, & - ps, z0, dvel, drydf,g0) - -! **************************************************************************** -! * * -! * Calculate dry deposition velocity. * -! * * -! * Input variables: * -! * AEROSOL(k) - Logical, T = aerosol species, F = gas species * -! * IREG(i,j) - # of landtypes in grid square * -! * ILAND(i,j,ldt) - Land type ID for element ldt =1,IREG(i,j) * -! * IUSE(i,j,ldt) - Fraction of gridbox area occupied by land type * -! * element ldt * -! * USTAR(i,j) - Friction velocity (m s-1) * -! * DELZ_SFC(i,j) - Thickness of layer above surface * -! * PBLZ(i,j) - Mixing depth (m) * -! * Z0(i,j) - Roughness height (m) * -! * * -! * Determined in this subroutine (local): * -! * OBK - Monin-Obukhov length (m): set to 1.E5 m under * -! * neutral conditions * -! * Rs(ldt) - Bulk surface resistance(s m-1) for species k to * -! * surface ldt * -! * Ra - Aerodynamic resistance. * -! * Rb - Sublayer resistance. * -! * Rs - Surface resistance. * -! * Rttl - Total deposition resistance (s m-1) for species k * -! * Rttl(k) = Ra + Rb + Rs. * -! * * -! * Returned: * -! * DVEL(i,j,k) - Deposition velocity (m s-1) of species k * -! * DRYDf(i,j,k) - Deposition frequency (s-1) of species k, * -! * = DVEL / DELZ_SFC * -! * * -! **************************************************************************** - - - IMPLICIT NONE - - REAL*8, INTENT(IN) :: airden(imx,jmx), delz_sfc(imx,jmx) - REAL*8, INTENT(IN) :: hflux(imx,jmx), ts(imx,jmx) - REAL*8, INTENT(IN) :: ustar(imx,jmx), pblz(imx,jmx) - REAL*8, INTENT(IN) :: ps(imx,jmx) - INTEGER, INTENT(IN) :: ilwi(imx,jmx) - INTEGER, INTENT(IN) :: imx,jmx,lmx - REAL*8, INTENT(IN) :: z0(imx,jmx) - REAL, INTENT(IN) :: g0 - REAL*8, INTENT(OUT) :: dvel(imx,jmx), drydf(imx,jmx) - - REAL*8 :: obk, vds, czh, rttl, frac, logmfrac, psi_h, cz, eps - REAL*8 :: vd, ra, rb, rs - INTEGER :: i, j, k, ldt, iolson, ii - CHARACTER(LEN=50) :: msg - REAL*8 :: prss, tempk, tempc, xnu, ckustr, reyno, aird, diam, xm, z - REAL*8 :: frpath, speed, dg, dw, rt - REAL*8 :: rad0, rix, gfact, gfaci, rdc, rixx, rluxx, rgsx, rclx - REAL*8 :: dtmp1, dtmp2, dtmp3, dtmp4 - REAL*8 :: biofit,vk - - ! executable statements - j_loop: DO j = 1,jmx - i_loop: DO i = 1,imx - vk=.4 - vd = 0.0 - ra = 0.0 - rb = 0.0 ! only required for gases (SO2) - rs = 0.0 - -! **************************************************************************** -! * Compute the the Monin-Obhukov length. * -! * The direct computation of the Monin-Obhukov length is: * -! * * -! * - Air density * Cp * T(surface air) * Ustar^3 * -! * OBK = ---------------------------------------------- * -! * vK * g * Sensible Heat flux * -! * * -! * Cp = 1000 J/kg/K = specific heat at constant pressure * -! * vK = 0.4 = von Karman's constant * -! **************************************************************************** - - IF (hflux(i,j) == 0.0) THEN - obk = 1.0E5 - ELSE - ! MINVAL(hflux), MINVAL(airden), MINVAL(ustar) =?? - obk = -airden(i,j) * 1000.0 * ts(i,j) * (ustar(i,j))**3 & - / (vk * g0 * hflux(i,j)) -! -- debug: - IF ( obk == 0.0 ) WRITE(*,211) obk, i, j -211 FORMAT(1X,'OBK=', E11.2, 1X,' i,j = ', 2I4) - - END IF - - cz = delz_sfc(i,j) / 2.0 ! center of the grid box above surface - -! **************************************************************************** -! * (1) Aerosodynamic resistance Ra and sublayer resistance Rb. * -! * * -! * The Reynolds number REYNO diagnoses whether a surface is * -! * aerodynamically rough (REYNO > 10) or smooth. Surface is * -! * rough in all cases except over water with low wind speeds. * -! * * -! * For gas species over land and ice (REYNO >= 10) and for aerosol * -! * species for all surfaces: * -! * * -! * Ra = 1./VT (VT from GEOS Kzz at L=1, m/s). * -! * * -! * The following equations are from Walcek et al, 1986: * -! * * -! * For gas species when REYNO < 10 (smooth), Ra and Rb are combined * -! * as Ra: * -! * * -! * Ra = { ln(ku* z1/Dg) - Sh } / ku* eq.(13) * -! * * -! * where z1 is the altitude at the center of the lowest model layer * -! * (CZ); * -! * Sh is a stability correction function; * -! * k is the von Karman constant (0.4, vK); * -! * u* is the friction velocity (USTAR). * -! * * -! * Sh is computed as a function of z1 and L eq ( 4) and (5)): * -! * * -! * 0 < z1/L <= 1: Sh = -5 * z1/L * -! * z1/L < 0: Sh = exp{ 0.598 + 0.39*ln(E) - 0.09(ln(E))^2 } * -! * where E = min(1,-z1/L) (Balkanski, thesis). * -! * * -! * For gas species when REYNO >= 10, * -! * * -! * Rb = 2/ku* (Dair/Dg)**(2/3) eq.(12) * -! * where Dg is the gas diffusivity, and * -! * Dair is the air diffusivity. * -! * * -! * For aerosol species, Rb is combined with surface resistance as Rs. * -! * * -! **************************************************************************** - - frac = cz / obk - IF (frac > 1.0) frac = 1.0 - IF (frac > 0.0 .AND. frac <= 1.0) THEN - psi_h = -5.0*frac - ELSE IF (frac < 0.0) THEN - eps = MIN(1.0D0, -frac) - logmfrac = LOG(eps) - psi_h = EXP( 0.598 + 0.39 * logmfrac - 0.09 * (logmfrac)**2 ) - END IF - !-------------------------------------------------------------- - ! Aerosol species, Rs here is the combination of Rb and Rs. - - ra = (LOG(cz/z0(i,j)) - psi_h) / (vk*ustar(i,j)) - - - vds = 0.002*ustar(i,j) - IF (obk < 0.0) & - vds = vds * (1.0+(-300.0/obk)**0.6667) - - czh = pblz(i,j)/obk - IF (czh < -30.0) vds = 0.0009*ustar(i,j)*(-czh)**0.6667 - - ! --Set Vds to be less than VDSMAX (entry in input file divided -- - ! by 1.E4). VDSMAX is taken from Table 2 of Walcek et al. [1986]. - ! Invert to get corresponding R - if(ii.eq.1)then - rs=1.0/MIN(vds,2.0D-2) - else - rs=1.0/MIN(vds,2.0D-3) - endif - - - ! ------ Set max and min values for bulk surface resistances ------ - - rs= MAX(1.0D0, MIN(rs, 9.9990D+3)) - -! **************************************************************************** -! * * -! * Compute dry deposition velocity. * -! * * -! * IUSE is the fraction of the grid square occupied by surface ldt in * -! * units of per mil (IUSE=500 -> 50% of the grid square). Add the * -! * contribution of surface type ldt to the deposition velocity; this is * -! * a loop over all surface types in the gridbox. * -! * * -! * Total resistance = Ra + Rb + Rs. -! * * -! **************************************************************************** - - rttl = ra + rb + rs - vd = vd + 1./rttl - - ! ------ Load array DVEL ------ - dvel(i,j) = vd * 1.2 - - ! -- Set a minimum value for DVEL - ! MIN(VdSO2) = 2.0e-3 m/s over ice - ! = 3.0e-3 m/s over land - ! MIN(vd_aerosol) = 1.0e-4 m/s - - IF (dvel(i,j) < 1.0E-4) dvel(i,j) = 1.0E-4 - drydf(i,j) = dvel(i,j) / delz_sfc(i,j) - - END DO i_loop - END DO j_loop - -END SUBROUTINE depvel_gocart - - - -END MODULE module_gocart_drydep diff --git a/src/fim/FIMsrc/fim/column_chem/module_gocart_dust.F90 b/src/fim/FIMsrc/fim/column_chem/module_gocart_dust.F90 deleted file mode 100644 index 81c3cb6..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_gocart_dust.F90 +++ /dev/null @@ -1,388 +0,0 @@ -MODULE GOCART_DUST - - - USE module_data_gocart_dust - USE namelist_soilveg - USE module_initial_chem_namelists -! USE module_initial_chem_namelist_defaults !, only: set_species - -CONTAINS - subroutine gocart_dust_driver(ktau,dt,alt,t_phy,moist,u_phy, & - v_phy,chem,rho_phy,dz8w,smois,u10,v10,p8w,erod, & - ivgtyp,isltyp,vegfra,xland,xlat,xlong,gsw,area,g,emis_dust, & - dusthelp,num_emis_dust,num_moist,num_chem,num_soil_layers, & - start_month, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) -! USE module_configure -! USE module_state_description - IMPLICIT NONE -! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - - INTEGER, INTENT(IN ) :: ktau,start_month, & - num_emis_dust,num_moist,num_chem,num_soil_layers, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - INTEGER,DIMENSION( ims:ime , jms:jme ) , & - INTENT(IN ) :: & - ivgtyp, & - isltyp - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & - INTENT(IN ) :: moist - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & - INTENT(INOUT ) :: chem - REAL, DIMENSION( ims:ime, 1, jms:jme,num_emis_dust),OPTIONAL,& - INTENT(INOUT ) :: & - emis_dust - REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ) , & - INTENT(INOUT) :: smois - REAL, DIMENSION( ims:ime , jms:jme, 3 ) , & - INTENT(IN ) :: erod - REAL, DIMENSION( ims:ime , jms:jme ) , & - INTENT(IN ) :: & - u10, & - v10, & - gsw, & - vegfra, & - xland, & - xlat, & - xlong,area - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(OUT ) :: dusthelp - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: & - alt, & - t_phy, & - dz8w,p8w, & - u_phy,v_phy,rho_phy - - REAL, INTENT(IN ) :: dt,g -! -! local variables -! - integer :: nmx,i,j,k,imx,jmx,lmx,ipr - integer,dimension (1,1) :: ilwi - real*8, DIMENSION (1,1,3,1) :: erodin - real*8, DIMENSION (5) :: tc,bems - real*8, dimension (1,1) :: w10m,gwet,airden,airmas - real*8, dimension (1) :: dxy - real*8 tcs,conver,converi - real dttt - real*8,parameter::max_default=0. -! write(6,*)'in dust driver ',ktau,dt,start_month -! conver=1.e-9*mwdry -! converi=1.e9/mwdry - conver=1.e-9 - converi=1.e9 -! -! number of dust bins -! - imx=1 - jmx=1 - lmx=1 - nmx=5 - k=kts - if(chem_opt == 304 .or. chem_opt == 316 .or. chem_opt == 317) Then -! print *,'chem_opt = ',chem_opt,'in gocart_dust',p_dust_1,p_dust_2 - dusthelp(:,:)=0. - do j=jts,jte - do i=its,ite -! -! -! - if(xland(i,j).lt.1.5 .and. xland(i,j).gt.0.5)then - ilwi(1,1)=1 - tc(1)=chem(i,kts,j,p_dust_1)*conver - tcs=tc(1) - tc(2)=1.d-30 - tc(3)=chem(i,kts,j,p_dust_2)*conver - tc(4)=1.d-30 - tc(5)=1.d-30 - w10m(1,1)=sqrt(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j)) - airmas(1,1)=-(p8w(i,kts+1,j)-p8w(i,kts,j))*area(i,j)/g -! if(j.eq.681)then -! write(6,*)chem(i,kts,j,p_dust_1),chem(i,kts,j,p_dust_2) -! write(6,*)tc(1),tc(3) -! write(6,*)smois(i,1,j),maxsmc(isltyp(i,j)) -! write(6,*)p8w(i,kts+1,j),p8w(i,kts,j),area(i,j),u_phy(i,kts,j) -! write(6,*)erod(i,j,1),u10(i,j),g,rho_phy(i,kts,j) -! endif -! -! we donṫ trust the u10,v10 values, is model layers are very thin near surface -! - if(dz8w(i,kts,j).lt.12.)w10m=sqrt(u_phy(i,kts,j)*u_phy(i,kts,j)+v_phy(i,kts,j)*v_phy(i,kts,j)) - erodin(1,1,1,1)=erod(i,j,1)!/area(i,j) - erodin(1,1,2,1)=erod(i,j,2)!/area(i,j) - erodin(1,1,3,1)=erod(i,j,3)!/area(i,j) -! -! volumetric soil moisture over porosity -! - if(isltyp(i,j).eq.0)then - ilwi(1,1)=0 - gwet(1,1)=1. - else - gwet(1,1)=smois(i,1,j)/maxsmc(isltyp(i,j)) - - endif -! gwet(1,1)=.1 - airden(1,1)=rho_phy(i,kts,j) - dxy(1)=area(i,j) - ipr=0 -! if(j.eq.681)ipr=1 - call source_du( imx,jmx,lmx,nmx, dt, tc, & - erodin, ilwi, dxy, w10m, gwet, airden, airmas, & - bems,start_month,g,ipr) -! if(tc(1).gt.tcs)then -! print *,k,j,tc(1),tc(2) -! print *,p_dust_1,p_dust_2,tc(3) -! endif - chem(i,kts,j,p_dust_1)=max(max_default,(tc(1)+.3125*tc(2))*converi) - chem(i,kts,j,p_dust_2)=max(max_default,(.67*tc(2)+tc(3))*converi) - dusthelp(i,j)=max(max_default,tc(2)*converi) -! if(j.eq.681)then -! write(6,*)chem(i,kts,j,p_dust_1),chem(i,kts,j,p_dust_2),dusthelp(i,j) -! write(6,*)dt,airmas(1,1),dusthelp(i,j) -! write(6,*)tc(1),tc(2),tc(3) -! endif -! for output diagnostics - emis_dust(i,1,j,p_edust1)=bems(1) - emis_dust(i,1,j,p_edust2)=bems(2) - emis_dust(i,1,j,p_edust3)=bems(3) - endif - enddo - enddo - else -! print *,'chem_opt = ',chem_opt,'in gocart_dust2',p_dust_1,p_dust_2 - do j=jts,jte - do i=its,ite -! -! -! -! write(6,*)i,j,xland(i,j) - if(xland(i,j).lt.1.5 .and. xland(i,j).gt.0.5)then - ilwi(1,1)=1 - tc(1)=chem(i,kts,j,p_dust_1)*conver - tc(2)=chem(i,kts,j,p_dust_2)*conver - tc(3)=chem(i,kts,j,p_dust_3)*conver - tc(4)=chem(i,kts,j,p_dust_4)*conver - tc(5)=chem(i,kts,j,p_dust_5)*conver - w10m(1,1)=sqrt(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j)) - airmas(1,1)=-(p8w(i,kts+1,j)-p8w(i,kts,j))*area(i,j)/g -! -! we donṫ trust the u10,v10 values, is model layers are very thin near surface -! - if(dz8w(i,kts,j).lt.12.)w10m=sqrt(u_phy(i,kts,j)*u_phy(i,kts,j)+v_phy(i,kts,j)*v_phy(i,kts,j)) - erodin(1,1,1,1)=erod(i,j,1)!/area(i,j) - erodin(1,1,2,1)=erod(i,j,2)!/area(i,j) - erodin(1,1,3,1)=erod(i,j,3)!/area(i,j) -! -! volumetric soil moisture over porosity -! - if(isltyp(i,j).eq.0)then - ilwi(1,1)=0 - gwet(1,1)=1. - else - gwet(1,1)=smois(i,1,j)/maxsmc(isltyp(i,j)) - - endif -! gwet(1,1)=.1 - airden(1,1)=rho_phy(i,kts,j) - dxy(1)=area(i,j) - ipr=0 -! if(erod(i,j,1).gt.0. .and. gwet(1,1).lt.0.2 .and.j.lt.100)then -! ipr=1 -! write(6,*)j,smois(i,1,j),maxsmc(isltyp(i,j)),erod(i,j,1),area(i,j) -! write(6,*)w10m(1,1),airmas(1,1),airden(1,1),gwet(1,1) -! write(6,*)g,dxy(1) -! endif -! dttt=3600. -! if(erod(i,j,1).gt.0. .and. gwet(1,1).lt.0.2 .and.j.eq.9222 )then -! ipr=1 -! endif - call source_du( imx,jmx,lmx,nmx, dt, tc, & - erodin, ilwi, dxy, w10m, gwet, airden, airmas, & - bems,start_month,g,ipr) -! write(0,*)tc(1) -! write(0,*)tc(2) -! write(0,*)tc(3) -! write(0,*)tc(4) -! write(0,*)tc(5) -! if(erod(i,j,1).gt.0. .and. gwet(1,1).lt.0.2 .and.j.eq.9222)then -! write(6,*)j,bems(1),bems(2),chem(i,kts,j,p_dust_1),tc(1)*converi -! endif - chem(i,kts,j,p_dust_1)=max(max_default,tc(1)*converi) - chem(i,kts,j,p_dust_2)=max(max_default,tc(2)*converi) - chem(i,kts,j,p_dust_3)=max(max_default,tc(3)*converi) - chem(i,kts,j,p_dust_4)=max(max_default,tc(4)*converi) - chem(i,kts,j,p_dust_5)=max(max_default,tc(5)*converi) -! for output diagnostics - emis_dust(i,1,j,p_edust1)=bems(1) - emis_dust(i,1,j,p_edust2)=bems(2) - emis_dust(i,1,j,p_edust3)=bems(3) - emis_dust(i,1,j,p_edust4)=bems(4) - emis_dust(i,1,j,p_edust5)=bems(5) - endif - enddo - enddo - endif -! - -end subroutine gocart_dust_driver - - - SUBROUTINE source_du( imx,jmx,lmx,nmx, dt1, tc, & - erod, ilwi, dxy, w10m, gwet, airden, airmas, & - bems,month,g0,ipr) - -! **************************************************************************** -! * Evaluate the source of each dust particles size classes (kg/m3) -! * by soil emission. -! * Input: -! * EROD Fraction of erodible grid cell (-) -! * for 1: Sand, 2: Silt, 3: Clay -! * DUSTDEN Dust density (kg/m3) -! * DXY Surface of each grid cell (m2) -! * AIRVOL Volume occupy by each grid boxes (m3) -! * NDT1 Time step (s) -! * W10m Velocity at the anemometer level (10meters) (m/s) -! * u_tresh Threshold velocity for particule uplifting (m/s) -! * CH_dust Constant to fudge the total emission of dust (s2/m2) -! * -! * Output: -! * DSRC Source of each dust type (kg/timestep/cell) -! * -! * Working: -! * SRC Potential source (kg/m/timestep/cell) -! * -! **************************************************************************** - -! USE module_data_gocart -! USE module_data_gocart_dust - - - - INTEGER, INTENT(IN) :: nmx,imx,jmx,lmx - REAL*8, INTENT(IN) :: erod(imx,jmx,ndcls,ndsrc) - INTEGER, INTENT(IN) :: ilwi(imx,jmx),month - - REAL*8, INTENT(IN) :: w10m(imx,jmx), gwet(imx,jmx) - REAL*8, INTENT(IN) :: dxy(jmx) - REAL*8, INTENT(IN) :: airden(imx,jmx,lmx), airmas(imx,jmx,lmx) - REAL*8, INTENT(INOUT) :: tc(imx,jmx,lmx,nmx) - REAL*8, INTENT(OUT) :: bems(imx,jmx,nmx) - - REAL*8 :: den(nmx), diam(nmx) - REAL*8 :: tsrc, u_ts0, cw, u_ts, dsrc, srce - REAL, intent(in) :: g0 - REAL :: rhoa, g,dt1 - INTEGER :: i, j, n, m, k, ipr - - - REAL*8 :: tcmw(nmx), ar(nmx), tcvv(nmx) - REAL*8 :: ar_wetdep(nmx), kc(nmx) - CHARACTER(LEN=20) :: tcname(nmx), tcunits(nmx) - LOGICAL :: aerosol(nmx) - - -! REAL*8 :: tc1(imx,jmx,lmx,nmx) -! REAL*8, TARGET :: tcms(imx,jmx,lmx,nmx) ! tracer mass (kg; kgS for sulfur case) -! REAL*8, TARGET :: tcgm(imx,jmx,lmx,nmx) ! g/m3 - - !----------------------------------------------------------------------- - ! sea salt specific - !----------------------------------------------------------------------- -! REAL*8, DIMENSION(nmx) :: ssaltden, ssaltreff, ra, rb -! REAL*8 :: ch_ss(nmx,12) - - !----------------------------------------------------------------------- - ! emissions (input) - !----------------------------------------------------------------------- -! REAL*8 :: e_an(imx,jmx,2,nmx), e_bb(imx,jmx,nmx), & -! e_ac(imx,jmx,lmx,nmx) - - !----------------------------------------------------------------------- - ! diagnostics (budget) - !----------------------------------------------------------------------- -! ! tendencies per time step and process -! REAL, TARGET :: bems(imx,jmx,nmx), bdry(imx,jmx,nmx), bstl(imx,jmx,nmx) -! REAL, TARGET :: bwet(imx,jmx,nmx), bcnv(imx,jmx,nmx) -! -! ! integrated tendencies per process -! REAL, TARGET :: tems(imx,jmx,nmx), tstl(imx,jmx,nmx) -! REAL, TARGET :: tdry(imx,jmx,nmx), twet(imx,jmx,nmx), tcnv(imx,jmx,nmx) - - ! global mass balance per time step - REAL*8 :: tmas0(nmx), tmas1(nmx) - REAL*8 :: dtems(nmx), dttrp(nmx), dtdif(nmx), dtcnv(nmx) - REAL*8 :: dtwet(nmx), dtdry(nmx), dtstl(nmx) - REAL*8 :: dtems2(nmx), dttrp2(nmx), dtdif2(nmx), dtcnv2(nmx) - REAL*8 :: dtwet2(nmx), dtdry2(nmx), dtstl2(nmx) - real :: gthresh - - - - - ! executable statemenst - gthresh=.5 - - DO n = 1, nmx - ! Threshold velocity as a function of the dust density and the diameter - ! from Bagnold (1941) - den(n) = den_dust(n)*1.0D-3 - diam(n) = 2.0*reff_dust(n)*1.0D2 - g = g0*1.0E2 - ! Pointer to the 3 classes considered in the source data files - m = ipoint(n) - tsrc = 0.0 - DO k = 1, ndsrc - ! No flux if wet soil - DO i = 1,imx - DO j = 1,jmx - rhoa = airden(i,j,1)*1.0D-3 - u_ts0 = 0.13*1.0D-2*SQRT(den(n)*g*diam(n)/rhoa)* & - SQRT(1.0+0.006/den(n)/g/(diam(n))**2.5)/ & - SQRT(1.928*(1331.0*(diam(n))**1.56+0.38)**0.092-1.0) -! write(0,*)u_ts0,den(n),diam(n),rhoa,g - ! Fraction of emerged surfaces (subtract lakes, coastal ocean,..) -! cw = 1.0 - water(i,j) - - ! Case of surface dry enough to erode - IF (gwet(i,j) < gthresh) THEN -! IF (gwet(i,j) < 0.5) THEN ! Pete's modified value - u_ts = MAX(0.0D+0,u_ts0*(1.2D+0+2.0D-1*LOG10(MAX(1.0D-3, gwet(i,j))))) - ELSE - ! Case of wet surface, no erosion - u_ts = 100.0 - END IF - srce = frac_s(n)*erod(i,j,m,k)*dxy(j) ! (m2) - IF (ilwi(i,j) == 1 ) THEN - dsrc = ch_dust(n,month)*srce*w10m(i,j)**2 & - * (w10m(i,j) - u_ts)*dt1 ! (kg) -! IF (gwet(i,j) < 0.2 .and. ipr.eq.1)write(6,*)n,month,m,ch_dust(n,month),srce,w10m(i,j),u_ts,gwet(i,j) -! IF (gwet(i,j) < 0.2 .and. ipr.eq.1)write(6,*)ipoint(m),den_dust(n),erod(i,j,m,k),dxy(j) -! IF (gwet(i,j) < 0.2 .and. ipr.eq.1)write(6,*)srce,dsrc,frac_s(n) -! IF (gwet(i,j) < 0.2 .and. ipr.eq.1)write(6,*)airmas(i,j,1),dt1 - ELSE - dsrc = 0.0 - END IF -! dsrc = cw*ch_dust(k)*srce*w10m(i,j)**2 & -! * (w10m(i,j) - u_ts)*dt1 ! (kg) -! dsrc = cw*ch_dust(n,dt(1)%mn)*srce*w10m(i,j)**2 & -! * (w10m(i,j) - u_ts)*dt1 ! (kg) - IF (dsrc < 0.0) dsrc = 0.0 - - ! Update dust mixing ratio at first model level. -! scale down dust by .6 - tc(i,j,1,n) = tc(i,j,1,n) + .7*dsrc / airmas(i,j,1) - bems(i,j,n) = .7*dsrc - END DO - END DO - END DO - END DO - -END SUBROUTINE source_du - - -END MODULE GOCART_DUST diff --git a/src/fim/FIMsrc/fim/column_chem/module_gocart_dust_afwa.F90 b/src/fim/FIMsrc/fim/column_chem/module_gocart_dust_afwa.F90 deleted file mode 100755 index 7a415d8..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_gocart_dust_afwa.F90 +++ /dev/null @@ -1,464 +0,0 @@ -MODULE GOCART_DUST_AFWA -! -! this module developed by Sandra Jones (AFWA and AER) and Glenn Creighton (AFWA) -! for serious questions:q - -! -! this module developed by Sandra Jones (AFWA and AER) -! and Glenn Creighton (AFWA). For serious questions contact -! - - - USE module_data_gocart_dust - USE namelist_soilveg - USE module_initial_chem_namelists - -CONTAINS - subroutine gocart_dust_afwa_driver(ktau,dt,alt,t_phy,moist,u_phy, & - v_phy,chem,rho_phy,dz8w,smois,u10,v10,p8w,erod, & - ivgtyp,isltyp,vegfra,xland,xlat,xlong,gsw,area,g,emis_dust, & - dustin,ust,znt,clay,sand,alpha,gamma, & - num_emis_dust,num_moist,num_chem,num_soil_layers, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - IMPLICIT NONE - - INTEGER, INTENT(IN ) :: ktau, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - num_emis_dust,num_moist,num_chem,num_soil_layers - INTEGER,DIMENSION( ims:ime , jms:jme ) , & - INTENT(IN ) :: & - ivgtyp, & - isltyp - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & - INTENT(IN ) :: moist - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & - INTENT(INOUT ) :: chem - REAL, DIMENSION( ims:ime, 1, jms:jme,num_emis_dust),OPTIONAL, & - INTENT(INOUT ) :: & - emis_dust - REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ) , & - INTENT(INOUT) :: smois - REAL, DIMENSION( ims:ime , jms:jme, ndcls ) , & - INTENT(IN ) :: erod -! REAL, DIMENSION( ims:ime , jms:jme, 5 ) , & -! INTENT(INout ) :: dustin - REAL, DIMENSION( ims:ime , jms:jme ) , & - INTENT(IN ) :: & - u10, & - v10, & - gsw, & - vegfra, & - xland, & - xlat, & - xlong,area, & - ust, & - znt, & - clay, & - sand,dustin - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: & - alt, & - t_phy, & - dz8w,p8w, & - u_phy,v_phy,rho_phy - REAL, INTENT(IN ) :: dt,g - -! Local variables - - integer :: nmx,smx,i,j,k,imx,jmx,lmx - integer,dimension (1,1) :: ilwi - real*8, DIMENSION (1,1) :: erodtot - REAL*8, DIMENSION (1,1) :: gravsm - REAL*8, DIMENSION (1,1) :: drylimit - real*8, DIMENSION (5) :: tc,bems -! real*8, dimension (1,1) :: w10m - real*8, dimension (1,1) :: airden,airmas,ustar - real*8, dimension (1) :: dxy - real*8, dimension (3) :: massfrac - real*8 :: conver,converi - real, INTENT(IN ) :: alpha, gamma - - conver=1.e-9 - converi=1.e9 - -! Number of dust bins - - imx=1 - jmx=1 - lmx=1 - nmx=ndust - smx=nsalt - - k=kts - do j=jts,jte - do i=its,ite - -! Don't do dust over water!!! - - ilwi(1,1)=0 - if(xland(i,j).lt.1.5)then - ilwi(1,1)=1 - -! Total concentration at lowest model level. This is still hardcoded for 5 bins. - -! if(config_flags%chem_opt == 2 .or. config_flags%chem_opt == 11 ) then -! tc(:)=1.e-16*conver -! else - tc(1)=chem(i,kts,j,p_dust_1)*conver - tc(2)=chem(i,kts,j,p_dust_2)*conver - tc(3)=chem(i,kts,j,p_dust_3)*conver - tc(4)=chem(i,kts,j,p_dust_4)*conver - tc(5)=chem(i,kts,j,p_dust_5)*conver -! endif - -! tc(1)=chem(i,kts,j,p_dust_1)*conver -! tc(2)=chem(i,kts,j,p_dust_2)*conver -! tc(3)=chem(i,kts,j,p_dust_3)*conver -! tc(4)=chem(i,kts,j,p_dust_4)*conver -! tc(5)=chem(i,kts,j,p_dust_5)*conver - -! Air mass and density at lowest model level. - - airmas(1,1)=-(p8w(i,kts+1,j)-p8w(i,kts,j))*area(i,j)/g - airden(1,1)=rho_phy(i,kts,j) - ustar(1,1)=ust(i,j) - dxy(1)=area(i,j) - -! Total erodibility. - - erodtot(1,1)=SUM(erod(i,j,:)) - -! Mass fractions of clay, silt, and sand. - - massfrac(1)=clay(i,j) - massfrac(2)=1-(clay(i,j)+sand(i,j)) - massfrac(3)=sand(i,j) - -! Don't allow roughness lengths greater than 20 cm to be lofted. -! This kludge accounts for land use types like urban areas and -! forests which would otherwise show up as high dust emitters. -! This is a placeholder for a more widely accepted kludge -! factor in the literature, which reduces lofting for rough areas. -! Forthcoming... - - IF (znt(i,j) .gt. 0.2) then - ilwi(1,1)=0 - ENDIF - -! Do not allow areas with bedrock, lava, or land-ice to loft - - IF (isltyp(i,j) .eq. 15 .or. isltyp(i,j) .eq. 16. .or. & - isltyp(i,j) .eq. 18) then - ilwi(1,1)=0 - ENDIF - IF (isltyp(i,j) .eq. 0)then - ilwi(1,1)=0 - endif - if(ilwi(1,1) == 0 ) cycle - -! Calculate gravimetric soil moisture and drylimit. - -! gravsm(1,1)=100*smois(i,1,j)/((1.-maxsmc(isltyp(i,j)))*(2.65*(1-clay(i,j))+2.50*clay(i,j))) - gravsm(1,1)=100.*smois(i,1,j)/((1.-maxsmc(isltyp(i,j)))*(2.65*(1.-clay(i,j))+2.50*clay(i,j))) - drylimit(1,1)=14.0*clay(i,j)*clay(i,j)+17.0*clay(i,j) -! write(0,*) "gravsm(",i,",",j,")=",gravsm(1,1)," drylimit=",drylimit(1) - -! Call dust emission routine. -! print *, "i,j=",i,j -! print *, "ustar before call=",ustar(1,1) - call source_dust(imx, jmx, lmx, nmx, smx, dt, tc, ustar, massfrac, & - erodtot, ilwi, dxy, gravsm, airden, airmas, & - bems, g, drylimit, alpha, gamma) - -! write(0,*)tc(1) -! write(0,*)tc(2) -! write(0,*)tc(3) -! write(0,*)tc(4) -! write(0,*)tc(5) -! if(config_flags%chem_opt == 2 .or. config_flags%chem_opt == 11 ) then -! dustin(i,j,1:5)=tc(1:5)*converi -! else - chem(i,kts,j,p_dust_1)=tc(1)*converi - chem(i,kts,j,p_dust_2)=tc(2)*converi - chem(i,kts,j,p_dust_3)=tc(3)*converi - chem(i,kts,j,p_dust_4)=tc(4)*converi - chem(i,kts,j,p_dust_5)=tc(5)*converi -! endif - -! chem(i,kts,j,p_dust_1)=tc(1)*converi -! chem(i,kts,j,p_dust_2)=tc(2)*converi -! chem(i,kts,j,p_dust_3)=tc(3)*converi -! chem(i,kts,j,p_dust_4)=tc(4)*converi -! chem(i,kts,j,p_dust_5)=tc(5)*converi - -! For output diagnostics - - emis_dust(i,1,j,p_edust1)=bems(1) - emis_dust(i,1,j,p_edust2)=bems(2) - emis_dust(i,1,j,p_edust3)=bems(3) - emis_dust(i,1,j,p_edust4)=bems(4) - emis_dust(i,1,j,p_edust5)=bems(5) - endif - enddo - enddo -! - -end subroutine gocart_dust_afwa_driver - - - SUBROUTINE source_dust(imx, jmx, lmx, nmx, smx, dt1, tc, ustar, massfrac,& - erod, ilwi, dxy, gravsm, airden, airmas, & - bems, g0, drylimit, alpha, gamma) - -! **************************************************************************** -! * Evaluate the source of each dust particles size bin by soil emission -! * -! * Input: -! * EROD Fraction of erodible grid cell (-) -! * ILWI Land/water flag (-) -! * GRAVSM Gravimetric soil moisture (g/g) -! * DRYLIMIT Upper GRAVSM limit for air-dry soil (g/g) -! * ALPHA Constant to fudge the total emission of dust (1/m) -! * DXY Surface of each grid cell (m2) -! * AIRMAS Mass of air for each grid box (kg) -! * AIRDEN Density of air for each grid box (kg/m3) -! * USTAR Friction velocity (m/s) -! * DT1 Time step (s) -! * NMX Number of dust bins (-) -! * SMX Number of saltation bins (-) -! * IMX Number of I points (-) -! * JMX Number of J points (-) -! * LMX Number of L points (-) -! * -! * Data: -! * MASSFRAC Fraction of mass in each of 3 soil classes (-) -! * SPOINT Pointer to 3 soil classes (-) -! * DEN_DUST Dust density (kg/m3) -! * DEN_SALT Saltation particle density (kg/m3) -! * REFF_SALT Reference saltation particle diameter (m) -! * REFF_DUST Reference dust particle diameter (m) -! * LO_DUST Lower diameter limits for dust bins (m) -! * UP_DUST Upper diameter limits for dust bins (m) -! * FRAC_SALT Soil class mass fraction for saltation bins (-) -! * -! * Parameters: -! * CMB Constant of proportionality (-) -! * MMD_DUST Mass median diameter of dust (m) -! * GSD_DUST Geometric standard deviation of dust (-) -! * LAMBDA Side crack propogation length (m) -! * CV Normalization constant (-) -! * G0 Gravitational acceleration (m/s2) -! * G Gravitational acceleration in cgs (cm/s2) -! * -! * Working: -! * U_TS0 "Dry" threshold friction velocity (m/s) -! * U_TS Moisture-adjusted threshold friction velocity (m/s) -! * RHOA Density of air in cgs (g/cm3) -! * DEN Dust density in cgs (g/cm3) -! * DIAM Dust diameter in cgs (cm) -! * DMASS Saltation mass distribution (-) -! * DSURFACE Saltation surface area per unit mass (m2/kg) -! * DS_REL Saltation surface area distribution (-) -! * SALT Saltation flux (kg/m/s) -! * DLNDP Dust bin width (-) -! * EMIT Total vertical mass flux (kg/m2/s) -! * EMIT_VOL Total vertical volume flux (m/s) -! * DSRC Mass of emitted dust (kg/timestep/cell) -! * -! * Output: -! * TC Total concentration of dust (kg/kg/timestep/cell) -! * BEMS Source of each dust type (kg/timestep/cell) -! * -! **************************************************************************** - - INTEGER, INTENT(IN) :: nmx,imx,jmx,lmx,smx - INTEGER, INTENT(IN) :: ilwi(imx,jmx) - REAL*8, INTENT(IN) :: erod(imx,jmx) - REAL*8, INTENT(IN) :: ustar(imx,jmx) - REAL*8, INTENT(IN) :: gravsm(imx,jmx) - REAL*8, INTENT(IN) :: drylimit(imx,jmx) - REAL*8, INTENT(IN) :: dxy(jmx) - REAL*8, INTENT(IN) :: airden(imx,jmx,lmx), airmas(imx,jmx,lmx) - REAL*8, INTENT(INOUT) :: tc(imx,jmx,lmx,nmx) - REAL*8, INTENT(OUT) :: bems(imx,jmx,nmx) - REAL, INTENT(IN) :: g0,dt1 - - REAL*8 :: den(smx), diam(smx) - REAL*8 :: dvol(nmx), distr_dust(nmx), dlndp(nmx) - REAL*8 :: dsurface(smx), ds_rel(smx) - REAL*8 :: massfrac(3) - REAL*8 :: u_ts0, u_ts, dsrc, srce, dmass, dvol_tot - REAL*8 :: emit, emit_vol - REAL :: rhoa, g - INTEGER :: i, j, m, s - -!! Sandblasting mass efficiency, aka "fudge factor" (based on Tegen et al, -!! 2006 and Hemold et al, 2007) -! -! REAL, PARAMETER :: alpha=1.8E-8 ! (m^-1) - -! Global tuning constant, alpha. Sandblasting mass efficiency, beta. -! Beta maxes out for clay fractions above 0.2 = betamax. - - REAL, INTENT(IN) :: alpha - REAL, PARAMETER :: betamax=5.25E-4 - REAL*8 :: beta - -! Experimental optional exponential tuning constant for erodibility. -! 0 < gamma < 1 -> more relative impact by low erodibility regions. - - REAL, INTENT(IN) :: gamma - -! Constant of proportionality from Marticorena et al, 1997 (unitless) -! Arguably more ~consistent~ fudge than alpha, which has many walnuts -! sprinkled throughout the literature. - GC - - REAL, PARAMETER :: cmb=1.0 -! REAL, PARAMETER :: cmb=2.61 ! from White,1979 - -! Parameters used in Kok distribution function. Advise not to play with -! these without the expressed written consent of someone who knows what -! they're doing. - GC - - REAL, PARAMETER :: mmd_dust=3.4D-6 ! median mass diameter (m) - REAL, PARAMETER :: gsd_dust=3.0 ! geom. std deviation - REAL, PARAMETER :: lambda=12.0D-6 ! crack propogation length (m) - REAL, PARAMETER :: cv=12.62D-6 ! normalization constant - -! Calculate saltation surface area distribution from sand, silt, and clay -! mass fractions and saltation bin fraction. This will later become a -! modifier to the total saltation flux. The reasoning here is that the -! size and availability of saltators affects saltation efficiency. Based -! on Eqn. (32) in Marticorena & Bergametti, 1995 (hereon, MB95). - - DO n=1,smx - dmass=massfrac(spoint(n))*frac_salt(n) - dsurface(n)=0.75*dmass/(den_salt(n)*reff_salt(n)) - ENDDO - -! The following equation yields relative surface area fraction. It will only -! work if you are representing the "full range" of all three soil classes. -! For this reason alone, we have incorporated particle sizes that encompass -! the clay class, to account for the its relative area over the basal -! surface, even though these smaller bins would be unlikely to play any large -! role in the actual saltation process. - GC - - stotal=SUM(dsurface(:)) - DO n=1,smx - ds_rel(n)=dsurface(n)/stotal - ENDDO - -! Calculate total dust emission due to saltation of sand sized particles. -! Begin by calculating DRY threshold friction velocity (u_ts0). Next adjust -! u_ts0 for moisture to get threshold friction velocity (u_ts). Then -! calculate saltation flux (salt) where ustar has exceeded u_ts. Finally, -! calculate total dust emission (tot_emit), taking into account erodibility. - - g = g0*1.0E2 - emit=0.0 - - DO n = 1, smx - den(n) = den_salt(n)*1.0D-3 ! (g cm^-3) - diam(n) = 2.0*reff_salt(n)*1.0D2 ! (cm) - DO i = 1,imx - DO j = 1,jmx - rhoa = airden(i,j,1)*1.0D-3 ! (g cm^-3) - - ! Threshold friction velocity as a function of the dust density and - ! diameter from Bagnold (1941) (m s^-1). - - u_ts0 = 0.13*1.0D-2*SQRT(den(n)*g*diam(n)/rhoa)* & - SQRT(1.0+0.006/den(n)/g/(diam(n))**2.5)/ & - SQRT(1.928*(1331.0*(diam(n))**1.56+0.38)**0.092-1.0) - - ! Friction velocity threshold correction function based on physical - ! properties related to moisture tension. Soil moisture greater than - ! dry limit serves to increase threshold friction velocity (making - ! it more difficult to loft dust). When soil moisture has not reached - ! dry limit, treat as dry (no correction to threshold friction - ! velocity). GC - - IF (gravsm(i,j) > drylimit(i,j)) THEN - u_ts = MAX(0.0D+0,u_ts0*(sqrt(1.0+1.21*(gravsm(i,j)-drylimit(i,j))**0.68))) - ELSE - u_ts = u_ts0 - END IF - - ! Saltation flux from Marticorena & Bergametti 1995 (MB95). ds_rel is - ! the relative surface area distribution - - IF (ustar(i,j) .gt. u_ts .and. erod(i,j) .gt. 0.0 .and. ilwi(i,j) == 1) THEN - salt = cmb*ds_rel(n)*(airden(i,j,1)/g0)*(ustar(i,j)**3)* & - (1. + u_ts/ustar(i,j))*(1. - (u_ts**2)/(ustar(i,j)**2)) ! (kg m^-1 s^-1) - ELSE - salt = 0.0 - ENDIF - - ! Calculate total vertical mass flux (note beta has units of m^-1) - ! Beta acts to tone down dust in areas with so few dust-sized particles that the - ! lofting efficiency decreases. Otherwise, super sandy zones would be huge dust - ! producers, which is generally not the case. Equation derived from wind-tunnel - ! experiments (see MB95). - - beta=10**(13.6*massfrac(1)-6.0) ! (unitless) - if (beta .gt. betamax) then - beta=betamax - endif - ! emit=emit+salt*erod(i,j)*alpha*beta ! (kg m^-2 s^-1) - emit=emit+salt*(erod(i,j)**gamma)*alpha*beta ! (kg m^-2 s^-1) - END DO - END DO - END DO - -! Now that we have the total dust emission, distribute into dust bins using -! lognormal distribution (Dr. Jasper Kok, in press), and -! calculate total mass emitted over the grid box over the timestep. -! -! In calculating the Kok distribution, we assume upper and lower limits to each bin. -! For reff_dust=(/0.73D-6,1.4D-6,2.4D-6,4.5D-6,8.0D-6/) (default), -! lower limits were ASSUMED at lo_dust=(/0.1D-6,1.0D-6,1.8D-6,3.0D-6,6.0D-6/) -! upper limits were ASSUMED at up_dust=(/1.0D-6,1.8D-6,3.0D-6,6.0D-6,10.0D-6/) -! These may be changed within module_data_gocart_dust.F, but make sure it is -! consistent with reff_dust values. These values were taken from the original -! GOCART bin configuration. We use them here to calculate dust bin width, dlndp. -! dVol is the volume distribution. You know...if you were wondering. GC - - dvol_tot=0. - DO n=1,nmx - dlndp(n)=LOG(up_dust(n)/lo_dust(n)) - dvol(n)=(2.0*reff_dust(n)/cv)*(1.+ERF(LOG(2.0*reff_dust(n)/mmd_dust)/(SQRT(2.)*LOG(gsd_dust))))*& - EXP(-(2.0*reff_dust(n)/lambda)**3.0)*dlndp(n) - dvol_tot=dvol_tot+dvol(n) - ! Convert mass flux to volume flux - emit_vol=emit/den_dust(n) ! (m s^-1) - END DO - DO n=1,nmx - distr_dust(n)=dvol(n)/dvol_tot - !print *,"distr_dust(",n,")=",distr_dust(n) - END DO - -! Now distribute total vertical emission into dust bins and update concentration. - - DO n=1,nmx - DO i=1,imx - DO j=1,jmx - ! Calculate total mass emitted - dsrc = emit_vol*den_dust(n)*distr_dust(n)*dxy(j)*dt1 ! (kg) - IF (dsrc < 0.0) dsrc = 0.0 - - ! Update dust mixing ratio at first model level. - tc(i,j,1,n) = tc(i,j,1,n) + dsrc / airmas(i,j,1) ! (kg/kg) - ! bems(i,j,n) = dsrc ! diagnostic - bems(i,j,n) = 1000.*dsrc/(dxy(j)*dt1) ! diagnostic (g/m2/s) - END DO - END DO - END DO - -END SUBROUTINE source_dust - - -END MODULE GOCART_DUST_AFWA diff --git a/src/fim/FIMsrc/fim/column_chem/module_gocart_opt.F90 b/src/fim/FIMsrc/fim/column_chem/module_gocart_opt.F90 deleted file mode 100644 index 7afb854..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_gocart_opt.F90 +++ /dev/null @@ -1,8712 +0,0 @@ -!GODDARD GODDARD GODDARD GODDARD GODDARD -!GODDARD GODDARD GODDARD GODDARD GODDARD - module module_gocart_opt - implicit none - -!--------------------------------------------------------------------- - -! Module; module_gocart_opt -! use; This module compute optical properties of GOCART aerosols for -! radiation. -!---------------------------------------------------------------------- - - - integer :: i,j,k,n,t,h !local looping variables - -! -! Mie table parameters -! - integer :: nh !RH loop index - integer :: ai !aerosol index - integer,parameter :: nwl = 11 !# of band in SW radiative transfer - integer,parameter :: nwl_lw = 10 !# of band in LW radiative transfer - integer,parameter,public :: tgmx = 14 !maximum # for aerosol type - integer,parameter :: nrmx = 99 !maximu RH -! integer,parameter :: waven(nwl_lw) = (/250, 340, 540, 800, 980, 1100, & -! 1215, 1380, 1900, 3000/) ! Wavenumber intervals for goddard LW scheme - ! It actually starts from 0 but adjusted for smallest value - ! in mie table (wn=250). - - real, dimension(11) :: midbands - data midbands/.2,.235,.27,.2875,.3025,.305,.3625,.55,1.92,1.745,6.135/ - real,parameter :: frac(4)=(/ 0.01053,0.08421,0.25263,0.65263 /) !fraction for fine dust - real,save :: Bex(tgmx,nwl,0:nrmx) ! SW Mass extinction coefficient [m2/g] - real,save :: w0(tgmx,nwl,0:nrmx) ! SW single scattering albedo [-] - real,save :: g(tgmx,nwl,0:nrmx) ! SW asymetry factor [-] - - - real,save :: Bex_lw(tgmx,nwl_lw,0:nrmx) ! LW Mass extinction coefficient [m2/g] - real,save :: w0_lw(tgmx,nwl_lw,0:nrmx) ! LW single scattering albedo [-] - real,save :: g_lw(tgmx,nwl_lw,0:nrmx) ! LW asymetry factor [-] - - -! -! Aerosol Optiocal Properties -! ai-> aerosol type index -! 1 = SO4 !sulfur and its precure -! 2 = BC1+BC2 !black carbon (soot) -! 3 = OC1 !non hygroscopic OC -! 4 = OC2 !hygroscopic OC -! 5 = SS1 !sea-salt accumulation mode -! 6 = SS2+SS3+SS4 !sea-salt coarse mode -! 7 = DU1 ! dust mode 1 -! 8 = DU1 ! dust mode 2 -! 9 = DU1 ! dust mode 3 -! 10 = DU1 ! dust mode 4 -! 11 = DU2 ! dust mode 5 -! 12 = DU3 ! dust mode 6 -! 13 = DU4 ! dust mode 7 -! 14 = DU5 ! dust mode 8 -! - data (((Bex(ai,k,nh),ai= 1, 1),k=1,11),nh=0,99)/ & - .5144E+01,.5144E+01,.5144E+01,.5081E+01,.4901E+01,.4655E+01,.4549E+01,.3187E+01,.1517E+01,.4026E+00,.2845E+00,& - .5227E+01,.5227E+01,.5227E+01,.5165E+01,.4988E+01,.4739E+01,.4632E+01,.3251E+01,.1552E+01,.4136E+00,.2877E+00,& - .5310E+01,.5310E+01,.5310E+01,.5249E+01,.5074E+01,.4823E+01,.4715E+01,.3315E+01,.1587E+01,.4246E+00,.2909E+00,& - .5393E+01,.5393E+01,.5393E+01,.5332E+01,.5161E+01,.4906E+01,.4797E+01,.3379E+01,.1622E+01,.4357E+00,.2940E+00,& - .5476E+01,.5476E+01,.5476E+01,.5416E+01,.5247E+01,.4990E+01,.4880E+01,.3443E+01,.1657E+01,.4467E+00,.2972E+00,& - .5559E+01,.5559E+01,.5559E+01,.5500E+01,.5334E+01,.5074E+01,.4963E+01,.3507E+01,.1692E+01,.4577E+00,.3004E+00,& - .5657E+01,.5657E+01,.5657E+01,.5595E+01,.5418E+01,.5157E+01,.5045E+01,.3577E+01,.1730E+01,.4700E+00,.3038E+00,& - .5755E+01,.5755E+01,.5755E+01,.5689E+01,.5502E+01,.5239E+01,.5127E+01,.3647E+01,.1769E+01,.4824E+00,.3072E+00,& - .5854E+01,.5854E+01,.5854E+01,.5784E+01,.5587E+01,.5322E+01,.5208E+01,.3716E+01,.1807E+01,.4947E+00,.3106E+00,& - .5952E+01,.5952E+01,.5952E+01,.5878E+01,.5671E+01,.5404E+01,.5290E+01,.3786E+01,.1846E+01,.5071E+00,.3140E+00,& - .6050E+01,.6050E+01,.6050E+01,.5973E+01,.5755E+01,.5487E+01,.5372E+01,.3856E+01,.1884E+01,.5194E+00,.3174E+00,& - .6137E+01,.6137E+01,.6137E+01,.6063E+01,.5855E+01,.5584E+01,.5468E+01,.3926E+01,.1924E+01,.5326E+00,.3209E+00,& - .6224E+01,.6224E+01,.6224E+01,.6154E+01,.5955E+01,.5681E+01,.5564E+01,.3996E+01,.1964E+01,.5458E+00,.3244E+00,& - .6311E+01,.6311E+01,.6311E+01,.6244E+01,.6056E+01,.5778E+01,.5659E+01,.4067E+01,.2005E+01,.5590E+00,.3278E+00,& - .6398E+01,.6398E+01,.6398E+01,.6335E+01,.6156E+01,.5875E+01,.5755E+01,.4137E+01,.2045E+01,.5722E+00,.3313E+00,& - .6485E+01,.6485E+01,.6485E+01,.6425E+01,.6256E+01,.5972E+01,.5851E+01,.4207E+01,.2085E+01,.5854E+00,.3348E+00,& - .6572E+01,.6572E+01,.6572E+01,.6512E+01,.6345E+01,.6060E+01,.5939E+01,.4286E+01,.2130E+01,.6005E+00,.3387E+00,& - .6659E+01,.6659E+01,.6659E+01,.6600E+01,.6433E+01,.6148E+01,.6027E+01,.4366E+01,.2176E+01,.6156E+00,.3426E+00,& - .6745E+01,.6745E+01,.6745E+01,.6687E+01,.6522E+01,.6237E+01,.6114E+01,.4445E+01,.2221E+01,.6307E+00,.3464E+00,& - .6832E+01,.6832E+01,.6832E+01,.6775E+01,.6610E+01,.6325E+01,.6202E+01,.4525E+01,.2267E+01,.6458E+00,.3503E+00,& - .6919E+01,.6919E+01,.6919E+01,.6862E+01,.6699E+01,.6413E+01,.6290E+01,.4604E+01,.2312E+01,.6609E+00,.3542E+00,& - .7036E+01,.7036E+01,.7036E+01,.6974E+01,.6796E+01,.6512E+01,.6391E+01,.4687E+01,.2361E+01,.6776E+00,.3584E+00,& - .7153E+01,.7153E+01,.7153E+01,.7085E+01,.6893E+01,.6612E+01,.6491E+01,.4771E+01,.2410E+01,.6943E+00,.3625E+00,& - .7269E+01,.7269E+01,.7269E+01,.7197E+01,.6989E+01,.6711E+01,.6592E+01,.4854E+01,.2459E+01,.7110E+00,.3667E+00,& - .7386E+01,.7386E+01,.7386E+01,.7308E+01,.7086E+01,.6811E+01,.6692E+01,.4938E+01,.2508E+01,.7277E+00,.3708E+00,& - .7503E+01,.7503E+01,.7503E+01,.7420E+01,.7183E+01,.6910E+01,.6793E+01,.5021E+01,.2557E+01,.7444E+00,.3750E+00,& - .7593E+01,.7593E+01,.7593E+01,.7518E+01,.7301E+01,.7023E+01,.6904E+01,.5109E+01,.2610E+01,.7627E+00,.3795E+00,& - .7684E+01,.7684E+01,.7684E+01,.7615E+01,.7419E+01,.7136E+01,.7015E+01,.5196E+01,.2663E+01,.7810E+00,.3840E+00,& - .7774E+01,.7774E+01,.7774E+01,.7713E+01,.7537E+01,.7250E+01,.7126E+01,.5284E+01,.2715E+01,.7994E+00,.3885E+00,& - .7865E+01,.7865E+01,.7865E+01,.7810E+01,.7655E+01,.7363E+01,.7237E+01,.5371E+01,.2768E+01,.8177E+00,.3930E+00,& - .7955E+01,.7955E+01,.7955E+01,.7908E+01,.7773E+01,.7476E+01,.7348E+01,.5459E+01,.2821E+01,.8360E+00,.3975E+00,& - .8057E+01,.8057E+01,.8057E+01,.8008E+01,.7868E+01,.7573E+01,.7447E+01,.5555E+01,.2878E+01,.8560E+00,.4023E+00,& - .8159E+01,.8159E+01,.8159E+01,.8108E+01,.7963E+01,.7671E+01,.7545E+01,.5650E+01,.2935E+01,.8761E+00,.4072E+00,& - .8260E+01,.8260E+01,.8260E+01,.8208E+01,.8058E+01,.7768E+01,.7644E+01,.5746E+01,.2992E+01,.8961E+00,.4120E+00,& - .8362E+01,.8362E+01,.8362E+01,.8308E+01,.8153E+01,.7866E+01,.7742E+01,.5841E+01,.3049E+01,.9162E+00,.4169E+00,& - .8464E+01,.8464E+01,.8464E+01,.8408E+01,.8248E+01,.7963E+01,.7841E+01,.5937E+01,.3106E+01,.9362E+00,.4217E+00,& - .8591E+01,.8591E+01,.8591E+01,.8531E+01,.8360E+01,.8079E+01,.7958E+01,.6030E+01,.3165E+01,.9574E+00,.4267E+00,& - .8718E+01,.8718E+01,.8718E+01,.8654E+01,.8473E+01,.8195E+01,.8076E+01,.6123E+01,.3224E+01,.9785E+00,.4318E+00,& - .8845E+01,.8845E+01,.8845E+01,.8778E+01,.8585E+01,.8311E+01,.8193E+01,.6217E+01,.3282E+01,.9997E+00,.4368E+00,& - .8972E+01,.8972E+01,.8972E+01,.8901E+01,.8698E+01,.8427E+01,.8311E+01,.6310E+01,.3341E+01,.1021E+01,.4419E+00,& - .9099E+01,.9099E+01,.9099E+01,.9024E+01,.8810E+01,.8543E+01,.8428E+01,.6403E+01,.3400E+01,.1042E+01,.4469E+00,& - .9194E+01,.9194E+01,.9194E+01,.9128E+01,.8939E+01,.8665E+01,.8547E+01,.6506E+01,.3465E+01,.1066E+01,.4525E+00,& - .9289E+01,.9289E+01,.9289E+01,.9232E+01,.9068E+01,.8787E+01,.8667E+01,.6609E+01,.3530E+01,.1089E+01,.4581E+00,& - .9385E+01,.9385E+01,.9385E+01,.9336E+01,.9196E+01,.8910E+01,.8786E+01,.6712E+01,.3595E+01,.1113E+01,.4637E+00,& - .9480E+01,.9480E+01,.9480E+01,.9440E+01,.9325E+01,.9032E+01,.8906E+01,.6815E+01,.3660E+01,.1136E+01,.4693E+00,& - .9575E+01,.9575E+01,.9575E+01,.9544E+01,.9454E+01,.9154E+01,.9025E+01,.6918E+01,.3725E+01,.1160E+01,.4749E+00,& - .9688E+01,.9688E+01,.9688E+01,.9655E+01,.9557E+01,.9261E+01,.9134E+01,.7029E+01,.3795E+01,.1186E+01,.4809E+00,& - .9801E+01,.9801E+01,.9801E+01,.9766E+01,.9659E+01,.9368E+01,.9242E+01,.7140E+01,.3864E+01,.1212E+01,.4870E+00,& - .9914E+01,.9914E+01,.9914E+01,.9878E+01,.9762E+01,.9474E+01,.9351E+01,.7251E+01,.3934E+01,.1237E+01,.4930E+00,& - .1003E+02,.1003E+02,.1003E+02,.9989E+01,.9864E+01,.9581E+01,.9459E+01,.7362E+01,.4003E+01,.1263E+01,.4991E+00,& - .1014E+02,.1014E+02,.1014E+02,.1010E+02,.9967E+01,.9688E+01,.9568E+01,.7473E+01,.4073E+01,.1289E+01,.5051E+00,& - .1028E+02,.1028E+02,.1028E+02,.1023E+02,.1008E+02,.9812E+01,.9694E+01,.7576E+01,.4141E+01,.1315E+01,.5111E+00,& - .1042E+02,.1042E+02,.1042E+02,.1036E+02,.1020E+02,.9937E+01,.9821E+01,.7679E+01,.4209E+01,.1341E+01,.5172E+00,& - .1056E+02,.1056E+02,.1056E+02,.1050E+02,.1032E+02,.1006E+02,.9947E+01,.7781E+01,.4278E+01,.1366E+01,.5232E+00,& - .1070E+02,.1070E+02,.1070E+02,.1063E+02,.1043E+02,.1019E+02,.1007E+02,.7884E+01,.4346E+01,.1392E+01,.5293E+00,& - .1084E+02,.1084E+02,.1084E+02,.1076E+02,.1055E+02,.1031E+02,.1020E+02,.7987E+01,.4414E+01,.1418E+01,.5353E+00,& - .1093E+02,.1093E+02,.1093E+02,.1086E+02,.1069E+02,.1044E+02,.1032E+02,.8091E+01,.4484E+01,.1445E+01,.5415E+00,& - .1102E+02,.1102E+02,.1102E+02,.1097E+02,.1083E+02,.1057E+02,.1045E+02,.8196E+01,.4553E+01,.1472E+01,.5477E+00,& - .1111E+02,.1111E+02,.1111E+02,.1107E+02,.1096E+02,.1069E+02,.1057E+02,.8300E+01,.4623E+01,.1498E+01,.5539E+00,& - .1120E+02,.1120E+02,.1120E+02,.1118E+02,.1110E+02,.1082E+02,.1070E+02,.8405E+01,.4692E+01,.1525E+01,.5601E+00,& - .1129E+02,.1129E+02,.1129E+02,.1128E+02,.1124E+02,.1095E+02,.1082E+02,.8509E+01,.4762E+01,.1552E+01,.5663E+00,& - .1140E+02,.1140E+02,.1140E+02,.1139E+02,.1134E+02,.1105E+02,.1093E+02,.8625E+01,.4838E+01,.1582E+01,.5732E+00,& - .1151E+02,.1151E+02,.1151E+02,.1149E+02,.1144E+02,.1116E+02,.1103E+02,.8741E+01,.4915E+01,.1612E+01,.5801E+00,& - .1161E+02,.1161E+02,.1161E+02,.1160E+02,.1154E+02,.1126E+02,.1114E+02,.8858E+01,.4991E+01,.1641E+01,.5869E+00,& - .1172E+02,.1172E+02,.1172E+02,.1170E+02,.1164E+02,.1137E+02,.1124E+02,.8974E+01,.5068E+01,.1671E+01,.5938E+00,& - .1183E+02,.1183E+02,.1183E+02,.1181E+02,.1174E+02,.1147E+02,.1135E+02,.9090E+01,.5144E+01,.1701E+01,.6007E+00,& - .1198E+02,.1198E+02,.1198E+02,.1195E+02,.1186E+02,.1159E+02,.1147E+02,.9208E+01,.5224E+01,.1733E+01,.6080E+00,& - .1213E+02,.1213E+02,.1213E+02,.1209E+02,.1198E+02,.1171E+02,.1160E+02,.9327E+01,.5304E+01,.1764E+01,.6153E+00,& - .1229E+02,.1229E+02,.1229E+02,.1224E+02,.1209E+02,.1184E+02,.1172E+02,.9445E+01,.5384E+01,.1796E+01,.6227E+00,& - .1244E+02,.1244E+02,.1244E+02,.1238E+02,.1221E+02,.1196E+02,.1185E+02,.9564E+01,.5464E+01,.1827E+01,.6300E+00,& - .1259E+02,.1259E+02,.1259E+02,.1252E+02,.1233E+02,.1208E+02,.1197E+02,.9682E+01,.5544E+01,.1859E+01,.6373E+00,& - .1277E+02,.1277E+02,.1277E+02,.1271E+02,.1257E+02,.1232E+02,.1221E+02,.9884E+01,.5686E+01,.1916E+01,.6506E+00,& - .1294E+02,.1294E+02,.1294E+02,.1291E+02,.1281E+02,.1256E+02,.1245E+02,.1009E+02,.5829E+01,.1974E+01,.6639E+00,& - .1312E+02,.1312E+02,.1312E+02,.1310E+02,.1306E+02,.1279E+02,.1268E+02,.1029E+02,.5971E+01,.2031E+01,.6772E+00,& - .1329E+02,.1329E+02,.1329E+02,.1330E+02,.1330E+02,.1303E+02,.1292E+02,.1049E+02,.6114E+01,.2089E+01,.6905E+00,& - .1347E+02,.1347E+02,.1347E+02,.1349E+02,.1354E+02,.1327E+02,.1316E+02,.1069E+02,.6256E+01,.2146E+01,.7038E+00,& - .1369E+02,.1369E+02,.1369E+02,.1370E+02,.1372E+02,.1347E+02,.1336E+02,.1091E+02,.6410E+01,.2210E+01,.7185E+00,& - .1390E+02,.1390E+02,.1390E+02,.1391E+02,.1391E+02,.1367E+02,.1357E+02,.1114E+02,.6564E+01,.2274E+01,.7333E+00,& - .1412E+02,.1412E+02,.1412E+02,.1411E+02,.1409E+02,.1386E+02,.1377E+02,.1136E+02,.6719E+01,.2337E+01,.7480E+00,& - .1433E+02,.1433E+02,.1433E+02,.1432E+02,.1428E+02,.1406E+02,.1398E+02,.1159E+02,.6873E+01,.2401E+01,.7628E+00,& - .1455E+02,.1455E+02,.1455E+02,.1453E+02,.1446E+02,.1426E+02,.1418E+02,.1181E+02,.7027E+01,.2465E+01,.7775E+00,& - .1493E+02,.1493E+02,.1493E+02,.1488E+02,.1473E+02,.1452E+02,.1443E+02,.1205E+02,.7206E+01,.2540E+01,.7949E+00,& - .1516E+02,.1516E+02,.1516E+02,.1511E+02,.1496E+02,.1480E+02,.1473E+02,.1228E+02,.7386E+01,.2617E+01,.8126E+00,& - .1537E+02,.1537E+02,.1537E+02,.1535E+02,.1530E+02,.1515E+02,.1508E+02,.1253E+02,.7570E+01,.2695E+01,.8308E+00,& - .1568E+02,.1568E+02,.1568E+02,.1571E+02,.1580E+02,.1560E+02,.1552E+02,.1291E+02,.7852E+01,.2815E+01,.8588E+00,& - .1597E+02,.1597E+02,.1597E+02,.1602E+02,.1618E+02,.1596E+02,.1587E+02,.1331E+02,.8141E+01,.2939E+01,.8876E+00,& - .1626E+02,.1626E+02,.1626E+02,.1632E+02,.1650E+02,.1628E+02,.1619E+02,.1372E+02,.8437E+01,.3068E+01,.9174E+00,& - .1675E+02,.1675E+02,.1675E+02,.1680E+02,.1693E+02,.1675E+02,.1667E+02,.1428E+02,.8843E+01,.3245E+01,.9586E+00,& - .1751E+02,.1751E+02,.1751E+02,.1749E+02,.1744E+02,.1730E+02,.1724E+02,.1483E+02,.9259E+01,.3430E+01,.1002E+01,& - .1815E+02,.1815E+02,.1815E+02,.1817E+02,.1821E+02,.1814E+02,.1811E+02,.1550E+02,.9791E+01,.3668E+01,.1058E+01,& - .1877E+02,.1877E+02,.1877E+02,.1888E+02,.1918E+02,.1902E+02,.1895E+02,.1636E+02,.1046E+02,.3971E+01,.1129E+01,& - .1953E+02,.1953E+02,.1953E+02,.1960E+02,.1980E+02,.1972E+02,.1968E+02,.1729E+02,.1116E+02,.4291E+01,.1204E+01,& - .2088E+02,.2088E+02,.2088E+02,.2089E+02,.2090E+02,.2086E+02,.2085E+02,.1850E+02,.1212E+02,.4746E+01,.1311E+01,& - .2176E+02,.2176E+02,.2176E+02,.2191E+02,.2235E+02,.2232E+02,.2231E+02,.1972E+02,.1314E+02,.5228E+01,.1427E+01,& - .2305E+02,.2305E+02,.2305E+02,.2320E+02,.2361E+02,.2360E+02,.2360E+02,.2143E+02,.1448E+02,.5881E+01,.1583E+01,& - .2530E+02,.2530E+02,.2530E+02,.2549E+02,.2604E+02,.2612E+02,.2616E+02,.2372E+02,.1646E+02,.6878E+01,.1825E+01,& - .2764E+02,.2764E+02,.2764E+02,.2777E+02,.2815E+02,.2840E+02,.2851E+02,.2667E+02,.1893E+02,.8158E+01,.2138E+01,& - .3096E+02,.3096E+02,.3096E+02,.3124E+02,.3203E+02,.3225E+02,.3235E+02,.3079E+02,.2262E+02,.1014E+02,.2637E+01,& - .3690E+02,.3690E+02,.3690E+02,.3726E+02,.3828E+02,.3867E+02,.3883E+02,.3821E+02,.2943E+02,.1403E+02,.3640E+01,& - .5038E+02,.5038E+02,.5038E+02,.5089E+02,.5234E+02,.5310E+02,.5343E+02,.5475E+02,.4573E+02,.2429E+02,.6466E+01/ - data (((Bex(ai,k,nh),ai= 2, 2),k=1,11),nh=0,99)/ & - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2268E+02,.2268E+02,.2268E+02,.2205E+02,.2027E+02,.1800E+02,.1702E+02,.9712E+01,.4476E+01,.2143E+01,.6938E+00,& - .2273E+02,.2273E+02,.2273E+02,.2210E+02,.2031E+02,.1804E+02,.1706E+02,.9732E+01,.4485E+01,.2148E+01,.6964E+00,& - .2278E+02,.2278E+02,.2278E+02,.2215E+02,.2036E+02,.1808E+02,.1709E+02,.9752E+01,.4494E+01,.2153E+01,.6989E+00,& - .2282E+02,.2282E+02,.2282E+02,.2219E+02,.2040E+02,.1811E+02,.1713E+02,.9772E+01,.4504E+01,.2158E+01,.7015E+00,& - .2287E+02,.2287E+02,.2287E+02,.2224E+02,.2045E+02,.1815E+02,.1716E+02,.9792E+01,.4513E+01,.2163E+01,.7040E+00,& - .2292E+02,.2292E+02,.2292E+02,.2229E+02,.2049E+02,.1819E+02,.1720E+02,.9812E+01,.4522E+01,.2168E+01,.7066E+00,& - .2292E+02,.2292E+02,.2292E+02,.2229E+02,.2049E+02,.1819E+02,.1720E+02,.9812E+01,.4522E+01,.2168E+01,.7066E+00,& - .2292E+02,.2292E+02,.2292E+02,.2229E+02,.2049E+02,.1819E+02,.1720E+02,.9812E+01,.4522E+01,.2168E+01,.7066E+00,& - .2292E+02,.2292E+02,.2292E+02,.2229E+02,.2049E+02,.1819E+02,.1720E+02,.9812E+01,.4522E+01,.2168E+01,.7066E+00,& - .2292E+02,.2292E+02,.2292E+02,.2229E+02,.2049E+02,.1819E+02,.1720E+02,.9812E+01,.4522E+01,.2168E+01,.7066E+00,& - .2292E+02,.2292E+02,.2292E+02,.2229E+02,.2049E+02,.1819E+02,.1720E+02,.9812E+01,.4522E+01,.2168E+01,.7066E+00,& - .2307E+02,.2307E+02,.2307E+02,.2243E+02,.2062E+02,.1831E+02,.1731E+02,.9870E+01,.4548E+01,.2182E+01,.7140E+00,& - .2321E+02,.2321E+02,.2321E+02,.2257E+02,.2076E+02,.1842E+02,.1742E+02,.9927E+01,.4574E+01,.2196E+01,.7215E+00,& - .2336E+02,.2336E+02,.2336E+02,.2272E+02,.2089E+02,.1854E+02,.1752E+02,.9985E+01,.4601E+01,.2209E+01,.7289E+00,& - .2350E+02,.2350E+02,.2350E+02,.2286E+02,.2103E+02,.1865E+02,.1763E+02,.1004E+02,.4627E+01,.2223E+01,.7364E+00,& - .2365E+02,.2365E+02,.2365E+02,.2300E+02,.2116E+02,.1877E+02,.1774E+02,.1010E+02,.4653E+01,.2237E+01,.7438E+00,& - .2406E+02,.2406E+02,.2406E+02,.2340E+02,.2152E+02,.1908E+02,.1803E+02,.1025E+02,.4717E+01,.2270E+01,.7623E+00,& - .2447E+02,.2447E+02,.2447E+02,.2379E+02,.2188E+02,.1939E+02,.1832E+02,.1040E+02,.4782E+01,.2302E+01,.7808E+00,& - .2487E+02,.2487E+02,.2487E+02,.2419E+02,.2224E+02,.1970E+02,.1861E+02,.1056E+02,.4846E+01,.2335E+01,.7993E+00,& - .2528E+02,.2528E+02,.2528E+02,.2458E+02,.2260E+02,.2001E+02,.1890E+02,.1071E+02,.4911E+01,.2367E+01,.8178E+00,& - .2569E+02,.2569E+02,.2569E+02,.2498E+02,.2296E+02,.2032E+02,.1919E+02,.1086E+02,.4975E+01,.2400E+01,.8363E+00,& - .2626E+02,.2626E+02,.2626E+02,.2552E+02,.2343E+02,.2073E+02,.1957E+02,.1105E+02,.5047E+01,.2433E+01,.8570E+00,& - .2683E+02,.2683E+02,.2683E+02,.2607E+02,.2391E+02,.2113E+02,.1994E+02,.1124E+02,.5119E+01,.2466E+01,.8778E+00,& - .2739E+02,.2739E+02,.2739E+02,.2661E+02,.2438E+02,.2154E+02,.2032E+02,.1142E+02,.5192E+01,.2499E+01,.8985E+00,& - .2796E+02,.2796E+02,.2796E+02,.2716E+02,.2486E+02,.2194E+02,.2069E+02,.1161E+02,.5264E+01,.2532E+01,.9193E+00,& - .2853E+02,.2853E+02,.2853E+02,.2770E+02,.2533E+02,.2235E+02,.2107E+02,.1180E+02,.5336E+01,.2565E+01,.9400E+00,& - .2946E+02,.2946E+02,.2946E+02,.2858E+02,.2609E+02,.2299E+02,.2166E+02,.1208E+02,.5439E+01,.2608E+01,.9691E+00,& - .3009E+02,.3009E+02,.3009E+02,.2918E+02,.2660E+02,.2342E+02,.2206E+02,.1227E+02,.5507E+01,.2636E+01,.9881E+00,& - .3109E+02,.3109E+02,.3109E+02,.3013E+02,.2740E+02,.2410E+02,.2268E+02,.1257E+02,.5609E+01,.2676E+01,.1016E+01,& - .3177E+02,.3177E+02,.3177E+02,.3077E+02,.2794E+02,.2455E+02,.2310E+02,.1276E+02,.5676E+01,.2702E+01,.1034E+01,& - .3283E+02,.3283E+02,.3283E+02,.3178E+02,.2879E+02,.2526E+02,.2375E+02,.1307E+02,.5778E+01,.2739E+01,.1061E+01,& - .3394E+02,.3394E+02,.3394E+02,.3283E+02,.2966E+02,.2600E+02,.2443E+02,.1338E+02,.5880E+01,.2774E+01,.1088E+01,& - .3471E+02,.3471E+02,.3471E+02,.3355E+02,.3026E+02,.2650E+02,.2489E+02,.1359E+02,.5948E+01,.2797E+01,.1105E+01,& - .3590E+02,.3590E+02,.3590E+02,.3467E+02,.3118E+02,.2727E+02,.2560E+02,.1392E+02,.6051E+01,.2831E+01,.1131E+01,& - .3672E+02,.3672E+02,.3672E+02,.3545E+02,.3182E+02,.2781E+02,.2609E+02,.1415E+02,.6121E+01,.2853E+01,.1148E+01,& - .3799E+02,.3799E+02,.3799E+02,.3664E+02,.3280E+02,.2863E+02,.2685E+02,.1449E+02,.6228E+01,.2885E+01,.1174E+01,& - .3932E+02,.3932E+02,.3932E+02,.3789E+02,.3383E+02,.2950E+02,.2764E+02,.1485E+02,.6337E+01,.2918E+01,.1199E+01,& - .4071E+02,.4071E+02,.4071E+02,.3920E+02,.3489E+02,.3038E+02,.2845E+02,.1522E+02,.6448E+01,.2949E+01,.1225E+01,& - .4215E+02,.4215E+02,.4215E+02,.4055E+02,.3600E+02,.3131E+02,.2930E+02,.1561E+02,.6562E+01,.2980E+01,.1250E+01,& - .4417E+02,.4417E+02,.4417E+02,.4245E+02,.3754E+02,.3260E+02,.3049E+02,.1615E+02,.6720E+01,.3021E+01,.1285E+01,& - .4629E+02,.4629E+02,.4629E+02,.4444E+02,.3916E+02,.3396E+02,.3173E+02,.1671E+02,.6884E+01,.3062E+01,.1319E+01,& - .4911E+02,.4911E+02,.4911E+02,.4708E+02,.4131E+02,.3576E+02,.3338E+02,.1745E+02,.7099E+01,.3114E+01,.1363E+01,& - .5337E+02,.5337E+02,.5337E+02,.5107E+02,.4454E+02,.3847E+02,.3587E+02,.1858E+02,.7422E+01,.3188E+01,.1426E+01,& - .5871E+02,.5871E+02,.5871E+02,.5608E+02,.4860E+02,.4188E+02,.3900E+02,.2001E+02,.7827E+01,.3276E+01,.1500E+01,& - .7441E+02,.7441E+02,.7441E+02,.7081E+02,.6056E+02,.5196E+02,.4827E+02,.2427E+02,.9036E+01,.3523E+01,.1703E+01/ - data (((Bex(ai,k,nh),ai= 3, 3),k=1,11),nh=0,99)/ & - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01/ - data (((Bex(ai,k,nh),ai= 4, 4),k=1,11),nh=0,99)/ & - .7325E+01,.7325E+01,.7325E+01,.7033E+01,.6201E+01,.5528E+01,.5240E+01,.2922E+01,.1058E+01,.2350E+00,.5156E-01,& - .7397E+01,.7397E+01,.7397E+01,.7102E+01,.6263E+01,.5582E+01,.5291E+01,.2952E+01,.1069E+01,.2376E+00,.5267E-01,& - .7469E+01,.7469E+01,.7469E+01,.7172E+01,.6325E+01,.5636E+01,.5342E+01,.2982E+01,.1080E+01,.2402E+00,.5378E-01,& - .7542E+01,.7542E+01,.7542E+01,.7241E+01,.6386E+01,.5691E+01,.5392E+01,.3011E+01,.1092E+01,.2427E+00,.5489E-01,& - .7614E+01,.7614E+01,.7614E+01,.7311E+01,.6448E+01,.5745E+01,.5443E+01,.3041E+01,.1103E+01,.2453E+00,.5600E-01,& - .7686E+01,.7686E+01,.7686E+01,.7380E+01,.6510E+01,.5799E+01,.5494E+01,.3071E+01,.1114E+01,.2479E+00,.5711E-01,& - .7763E+01,.7763E+01,.7763E+01,.7453E+01,.6573E+01,.5856E+01,.5548E+01,.3102E+01,.1126E+01,.2507E+00,.5827E-01,& - .7840E+01,.7840E+01,.7840E+01,.7526E+01,.6635E+01,.5913E+01,.5603E+01,.3133E+01,.1138E+01,.2534E+00,.5943E-01,& - .7916E+01,.7916E+01,.7916E+01,.7600E+01,.6698E+01,.5969E+01,.5657E+01,.3165E+01,.1150E+01,.2562E+00,.6058E-01,& - .7993E+01,.7993E+01,.7993E+01,.7673E+01,.6760E+01,.6026E+01,.5712E+01,.3196E+01,.1162E+01,.2589E+00,.6174E-01,& - .8070E+01,.8070E+01,.8070E+01,.7746E+01,.6823E+01,.6083E+01,.5766E+01,.3227E+01,.1174E+01,.2617E+00,.6290E-01,& - .8150E+01,.8150E+01,.8150E+01,.7823E+01,.6891E+01,.6145E+01,.5825E+01,.3260E+01,.1186E+01,.2646E+00,.6411E-01,& - .8230E+01,.8230E+01,.8230E+01,.7900E+01,.6959E+01,.6206E+01,.5884E+01,.3293E+01,.1199E+01,.2675E+00,.6532E-01,& - .8311E+01,.8311E+01,.8311E+01,.7977E+01,.7027E+01,.6268E+01,.5942E+01,.3325E+01,.1211E+01,.2705E+00,.6654E-01,& - .8391E+01,.8391E+01,.8391E+01,.8054E+01,.7095E+01,.6329E+01,.6001E+01,.3358E+01,.1224E+01,.2734E+00,.6775E-01,& - .8471E+01,.8471E+01,.8471E+01,.8131E+01,.7163E+01,.6391E+01,.6060E+01,.3391E+01,.1236E+01,.2763E+00,.6896E-01,& - .8553E+01,.8553E+01,.8553E+01,.8210E+01,.7235E+01,.6454E+01,.6119E+01,.3425E+01,.1249E+01,.2794E+00,.7023E-01,& - .8635E+01,.8635E+01,.8635E+01,.8290E+01,.7307E+01,.6517E+01,.6178E+01,.3460E+01,.1263E+01,.2825E+00,.7149E-01,& - .8718E+01,.8718E+01,.8718E+01,.8369E+01,.7378E+01,.6579E+01,.6237E+01,.3494E+01,.1276E+01,.2857E+00,.7276E-01,& - .8800E+01,.8800E+01,.8800E+01,.8449E+01,.7450E+01,.6642E+01,.6296E+01,.3529E+01,.1290E+01,.2888E+00,.7402E-01,& - .8882E+01,.8882E+01,.8882E+01,.8528E+01,.7522E+01,.6705E+01,.6355E+01,.3563E+01,.1303E+01,.2919E+00,.7529E-01,& - .8966E+01,.8966E+01,.8966E+01,.8609E+01,.7594E+01,.6770E+01,.6417E+01,.3599E+01,.1317E+01,.2952E+00,.7661E-01,& - .9050E+01,.9050E+01,.9050E+01,.8690E+01,.7666E+01,.6835E+01,.6479E+01,.3636E+01,.1331E+01,.2985E+00,.7793E-01,& - .9134E+01,.9134E+01,.9134E+01,.8771E+01,.7738E+01,.6899E+01,.6540E+01,.3672E+01,.1345E+01,.3018E+00,.7926E-01,& - .9218E+01,.9218E+01,.9218E+01,.8852E+01,.7810E+01,.6964E+01,.6602E+01,.3709E+01,.1359E+01,.3051E+00,.8058E-01,& - .9302E+01,.9302E+01,.9302E+01,.8933E+01,.7882E+01,.7029E+01,.6664E+01,.3745E+01,.1373E+01,.3084E+00,.8190E-01,& - .9389E+01,.9389E+01,.9389E+01,.9017E+01,.7957E+01,.7096E+01,.6728E+01,.3783E+01,.1388E+01,.3119E+00,.8328E-01,& - .9477E+01,.9477E+01,.9477E+01,.9101E+01,.8031E+01,.7163E+01,.6791E+01,.3821E+01,.1403E+01,.3154E+00,.8466E-01,& - .9564E+01,.9564E+01,.9564E+01,.9185E+01,.8106E+01,.7230E+01,.6855E+01,.3859E+01,.1417E+01,.3189E+00,.8603E-01,& - .9652E+01,.9652E+01,.9652E+01,.9269E+01,.8180E+01,.7297E+01,.6918E+01,.3897E+01,.1432E+01,.3224E+00,.8741E-01,& - .9739E+01,.9739E+01,.9739E+01,.9353E+01,.8255E+01,.7364E+01,.6982E+01,.3935E+01,.1447E+01,.3259E+00,.8879E-01,& - .9833E+01,.9833E+01,.9833E+01,.9443E+01,.8332E+01,.7434E+01,.7049E+01,.3975E+01,.1463E+01,.3296E+00,.9023E-01,& - .9927E+01,.9927E+01,.9927E+01,.9533E+01,.8409E+01,.7504E+01,.7116E+01,.4014E+01,.1478E+01,.3333E+00,.9166E-01,& - .1002E+02,.1002E+02,.1002E+02,.9622E+01,.8487E+01,.7575E+01,.7184E+01,.4054E+01,.1494E+01,.3371E+00,.9310E-01,& - .1012E+02,.1012E+02,.1012E+02,.9712E+01,.8564E+01,.7645E+01,.7251E+01,.4093E+01,.1509E+01,.3408E+00,.9453E-01,& - .1021E+02,.1021E+02,.1021E+02,.9802E+01,.8641E+01,.7715E+01,.7318E+01,.4133E+01,.1525E+01,.3445E+00,.9597E-01,& - .1031E+02,.1031E+02,.1031E+02,.9896E+01,.8724E+01,.7791E+01,.7391E+01,.4175E+01,.1541E+01,.3484E+00,.9748E-01,& - .1040E+02,.1040E+02,.1040E+02,.9989E+01,.8807E+01,.7867E+01,.7464E+01,.4216E+01,.1558E+01,.3524E+00,.9898E-01,& - .1050E+02,.1050E+02,.1050E+02,.1008E+02,.8891E+01,.7943E+01,.7537E+01,.4258E+01,.1574E+01,.3563E+00,.1005E+00,& - .1059E+02,.1059E+02,.1059E+02,.1018E+02,.8974E+01,.8019E+01,.7610E+01,.4299E+01,.1591E+01,.3603E+00,.1020E+00,& - .1069E+02,.1069E+02,.1069E+02,.1027E+02,.9057E+01,.8095E+01,.7683E+01,.4341E+01,.1607E+01,.3642E+00,.1035E+00,& - .1079E+02,.1079E+02,.1079E+02,.1036E+02,.9145E+01,.8172E+01,.7755E+01,.4384E+01,.1624E+01,.3684E+00,.1051E+00,& - .1088E+02,.1088E+02,.1088E+02,.1045E+02,.9232E+01,.8249E+01,.7827E+01,.4428E+01,.1642E+01,.3725E+00,.1066E+00,& - .1098E+02,.1098E+02,.1098E+02,.1055E+02,.9320E+01,.8325E+01,.7900E+01,.4471E+01,.1659E+01,.3767E+00,.1082E+00,& - .1107E+02,.1107E+02,.1107E+02,.1064E+02,.9407E+01,.8402E+01,.7972E+01,.4515E+01,.1677E+01,.3808E+00,.1097E+00,& - .1117E+02,.1117E+02,.1117E+02,.1073E+02,.9495E+01,.8479E+01,.8044E+01,.4558E+01,.1694E+01,.3850E+00,.1113E+00,& - .1127E+02,.1127E+02,.1127E+02,.1083E+02,.9581E+01,.8557E+01,.8119E+01,.4604E+01,.1712E+01,.3894E+00,.1129E+00,& - .1137E+02,.1137E+02,.1137E+02,.1093E+02,.9667E+01,.8636E+01,.8194E+01,.4650E+01,.1730E+01,.3939E+00,.1145E+00,& - .1147E+02,.1147E+02,.1147E+02,.1102E+02,.9754E+01,.8714E+01,.8269E+01,.4695E+01,.1749E+01,.3983E+00,.1162E+00,& - .1157E+02,.1157E+02,.1157E+02,.1112E+02,.9840E+01,.8793E+01,.8344E+01,.4741E+01,.1767E+01,.4028E+00,.1178E+00,& - .1167E+02,.1167E+02,.1167E+02,.1122E+02,.9926E+01,.8871E+01,.8419E+01,.4787E+01,.1785E+01,.4072E+00,.1194E+00,& - .1179E+02,.1179E+02,.1179E+02,.1134E+02,.1003E+02,.8966E+01,.8510E+01,.4843E+01,.1808E+01,.4128E+00,.1214E+00,& - .1191E+02,.1191E+02,.1191E+02,.1145E+02,.1014E+02,.9062E+01,.8602E+01,.4900E+01,.1831E+01,.4183E+00,.1234E+00,& - .1204E+02,.1204E+02,.1204E+02,.1157E+02,.1024E+02,.9157E+01,.8693E+01,.4956E+01,.1853E+01,.4239E+00,.1255E+00,& - .1216E+02,.1216E+02,.1216E+02,.1168E+02,.1035E+02,.9253E+01,.8785E+01,.5013E+01,.1876E+01,.4294E+00,.1275E+00,& - .1228E+02,.1228E+02,.1228E+02,.1180E+02,.1045E+02,.9348E+01,.8876E+01,.5069E+01,.1899E+01,.4350E+00,.1295E+00,& - .1241E+02,.1241E+02,.1241E+02,.1193E+02,.1056E+02,.9450E+01,.8974E+01,.5128E+01,.1923E+01,.4410E+00,.1316E+00,& - .1255E+02,.1255E+02,.1255E+02,.1206E+02,.1067E+02,.9552E+01,.9072E+01,.5187E+01,.1947E+01,.4470E+00,.1337E+00,& - .1268E+02,.1268E+02,.1268E+02,.1218E+02,.1078E+02,.9653E+01,.9171E+01,.5246E+01,.1971E+01,.4529E+00,.1359E+00,& - .1282E+02,.1282E+02,.1282E+02,.1231E+02,.1089E+02,.9755E+01,.9269E+01,.5305E+01,.1995E+01,.4589E+00,.1380E+00,& - .1295E+02,.1295E+02,.1295E+02,.1244E+02,.1100E+02,.9857E+01,.9367E+01,.5364E+01,.2019E+01,.4649E+00,.1401E+00,& - .1307E+02,.1307E+02,.1307E+02,.1256E+02,.1111E+02,.9956E+01,.9461E+01,.5419E+01,.2041E+01,.4704E+00,.1420E+00,& - .1319E+02,.1319E+02,.1319E+02,.1268E+02,.1122E+02,.1005E+02,.9555E+01,.5473E+01,.2064E+01,.4759E+00,.1439E+00,& - .1331E+02,.1331E+02,.1331E+02,.1279E+02,.1132E+02,.1015E+02,.9648E+01,.5528E+01,.2086E+01,.4815E+00,.1459E+00,& - .1343E+02,.1343E+02,.1343E+02,.1291E+02,.1143E+02,.1025E+02,.9742E+01,.5582E+01,.2109E+01,.4870E+00,.1478E+00,& - .1355E+02,.1355E+02,.1355E+02,.1303E+02,.1154E+02,.1035E+02,.9836E+01,.5637E+01,.2131E+01,.4925E+00,.1497E+00,& - .1368E+02,.1368E+02,.1368E+02,.1316E+02,.1166E+02,.1046E+02,.9939E+01,.5702E+01,.2158E+01,.4992E+00,.1520E+00,& - .1382E+02,.1382E+02,.1382E+02,.1329E+02,.1179E+02,.1057E+02,.1004E+02,.5767E+01,.2185E+01,.5059E+00,.1543E+00,& - .1395E+02,.1395E+02,.1395E+02,.1342E+02,.1191E+02,.1067E+02,.1014E+02,.5831E+01,.2211E+01,.5126E+00,.1567E+00,& - .1409E+02,.1409E+02,.1409E+02,.1355E+02,.1204E+02,.1078E+02,.1025E+02,.5896E+01,.2238E+01,.5193E+00,.1590E+00,& - .1422E+02,.1422E+02,.1422E+02,.1368E+02,.1216E+02,.1089E+02,.1035E+02,.5961E+01,.2265E+01,.5260E+00,.1613E+00,& - .1443E+02,.1443E+02,.1443E+02,.1389E+02,.1235E+02,.1106E+02,.1052E+02,.6066E+01,.2308E+01,.5370E+00,.1650E+00,& - .1465E+02,.1465E+02,.1465E+02,.1410E+02,.1253E+02,.1123E+02,.1068E+02,.6171E+01,.2352E+01,.5480E+00,.1687E+00,& - .1486E+02,.1486E+02,.1486E+02,.1430E+02,.1272E+02,.1141E+02,.1085E+02,.6276E+01,.2395E+01,.5590E+00,.1724E+00,& - .1508E+02,.1508E+02,.1508E+02,.1451E+02,.1290E+02,.1158E+02,.1101E+02,.6381E+01,.2439E+01,.5700E+00,.1761E+00,& - .1529E+02,.1529E+02,.1529E+02,.1472E+02,.1309E+02,.1175E+02,.1118E+02,.6486E+01,.2482E+01,.5810E+00,.1798E+00,& - .1561E+02,.1561E+02,.1561E+02,.1503E+02,.1337E+02,.1201E+02,.1143E+02,.6636E+01,.2546E+01,.5973E+00,.1852E+00,& - .1593E+02,.1593E+02,.1593E+02,.1533E+02,.1364E+02,.1226E+02,.1167E+02,.6786E+01,.2609E+01,.6137E+00,.1906E+00,& - .1624E+02,.1624E+02,.1624E+02,.1564E+02,.1392E+02,.1252E+02,.1192E+02,.6935E+01,.2673E+01,.6300E+00,.1959E+00,& - .1656E+02,.1656E+02,.1656E+02,.1594E+02,.1419E+02,.1277E+02,.1216E+02,.7085E+01,.2736E+01,.6464E+00,.2013E+00,& - .1688E+02,.1688E+02,.1688E+02,.1625E+02,.1447E+02,.1303E+02,.1241E+02,.7235E+01,.2800E+01,.6627E+00,.2067E+00,& - .1727E+02,.1727E+02,.1727E+02,.1664E+02,.1485E+02,.1336E+02,.1272E+02,.7433E+01,.2885E+01,.6846E+00,.2138E+00,& - .1766E+02,.1766E+02,.1766E+02,.1702E+02,.1521E+02,.1369E+02,.1304E+02,.7636E+01,.2972E+01,.7072E+00,.2210E+00,& - .1805E+02,.1805E+02,.1805E+02,.1741E+02,.1557E+02,.1402E+02,.1336E+02,.7844E+01,.3061E+01,.7305E+00,.2284E+00,& - .1845E+02,.1845E+02,.1845E+02,.1779E+02,.1593E+02,.1435E+02,.1367E+02,.8057E+01,.3153E+01,.7545E+00,.2361E+00,& - .1902E+02,.1902E+02,.1902E+02,.1834E+02,.1641E+02,.1480E+02,.1411E+02,.8348E+01,.3278E+01,.7874E+00,.2464E+00,& - .1962E+02,.1962E+02,.1962E+02,.1892E+02,.1692E+02,.1527E+02,.1457E+02,.8644E+01,.3407E+01,.8218E+00,.2571E+00,& - .2041E+02,.2041E+02,.2041E+02,.1967E+02,.1758E+02,.1589E+02,.1517E+02,.9022E+01,.3574E+01,.8664E+00,.2709E+00,& - .2116E+02,.2116E+02,.2116E+02,.2042E+02,.1830E+02,.1656E+02,.1582E+02,.9415E+01,.3749E+01,.9129E+00,.2852E+00,& - .2204E+02,.2204E+02,.2204E+02,.2129E+02,.1917E+02,.1734E+02,.1656E+02,.9903E+01,.3966E+01,.9718E+00,.3031E+00,& - .2295E+02,.2295E+02,.2295E+02,.2218E+02,.2000E+02,.1811E+02,.1730E+02,.1042E+02,.4194E+01,.1034E+01,.3217E+00,& - .2409E+02,.2409E+02,.2409E+02,.2328E+02,.2098E+02,.1904E+02,.1821E+02,.1104E+02,.4473E+01,.1110E+01,.3444E+00,& - .2554E+02,.2554E+02,.2554E+02,.2467E+02,.2220E+02,.2020E+02,.1934E+02,.1177E+02,.4809E+01,.1204E+01,.3718E+00,& - .2721E+02,.2721E+02,.2721E+02,.2635E+02,.2390E+02,.2174E+02,.2082E+02,.1273E+02,.5257E+01,.1329E+01,.4081E+00,& - .2912E+02,.2912E+02,.2912E+02,.2821E+02,.2563E+02,.2338E+02,.2241E+02,.1387E+02,.5786E+01,.1480E+01,.4510E+00,& - .3212E+02,.3212E+02,.3212E+02,.3112E+02,.2826E+02,.2589E+02,.2487E+02,.1551E+02,.6569E+01,.1706E+01,.5144E+00,& - .3570E+02,.3570E+02,.3570E+02,.3468E+02,.3179E+02,.2917E+02,.2804E+02,.1780E+02,.7673E+01,.2031E+01,.6039E+00,& - .4053E+02,.4053E+02,.4053E+02,.3943E+02,.3630E+02,.3346E+02,.3224E+02,.2068E+02,.9112E+01,.2467E+01,.7211E+00,& - .4887E+02,.4887E+02,.4887E+02,.4762E+02,.4407E+02,.4094E+02,.3960E+02,.2605E+02,.1187E+02,.3330E+01,.9477E+00,& - .6332E+02,.6332E+02,.6332E+02,.6207E+02,.5852E+02,.5476E+02,.5315E+02,.3643E+02,.1748E+02,.5174E+01,.1417E+01/ - data (((Bex(ai,k,nh),ai= 5, 5),k=1,11),nh=0,99)/ & - .1033E+01,.1033E+01,.1033E+01,.1038E+01,.1054E+01,.1075E+01,.1084E+01,.1151E+01,.1115E+01,.7503E+00,.1815E+00,& - .1056E+01,.1056E+01,.1056E+01,.1061E+01,.1078E+01,.1099E+01,.1108E+01,.1179E+01,.1142E+01,.7701E+00,.1880E+00,& - .1079E+01,.1079E+01,.1079E+01,.1084E+01,.1101E+01,.1123E+01,.1132E+01,.1207E+01,.1170E+01,.7899E+00,.1945E+00,& - .1101E+01,.1101E+01,.1101E+01,.1108E+01,.1125E+01,.1146E+01,.1156E+01,.1234E+01,.1197E+01,.8097E+00,.2010E+00,& - .1124E+01,.1124E+01,.1124E+01,.1131E+01,.1148E+01,.1170E+01,.1180E+01,.1262E+01,.1225E+01,.8295E+00,.2075E+00,& - .1147E+01,.1147E+01,.1147E+01,.1154E+01,.1172E+01,.1194E+01,.1204E+01,.1290E+01,.1252E+01,.8493E+00,.2140E+00,& - .1172E+01,.1172E+01,.1172E+01,.1179E+01,.1198E+01,.1223E+01,.1234E+01,.1318E+01,.1281E+01,.8707E+00,.2214E+00,& - .1197E+01,.1197E+01,.1197E+01,.1204E+01,.1225E+01,.1252E+01,.1264E+01,.1346E+01,.1310E+01,.8921E+00,.2288E+00,& - .1221E+01,.1221E+01,.1221E+01,.1230E+01,.1251E+01,.1281E+01,.1294E+01,.1375E+01,.1339E+01,.9136E+00,.2362E+00,& - .1246E+01,.1246E+01,.1246E+01,.1255E+01,.1278E+01,.1310E+01,.1324E+01,.1403E+01,.1368E+01,.9350E+00,.2436E+00,& - .1271E+01,.1271E+01,.1271E+01,.1280E+01,.1304E+01,.1339E+01,.1354E+01,.1431E+01,.1397E+01,.9564E+00,.2510E+00,& - .1301E+01,.1301E+01,.1301E+01,.1308E+01,.1329E+01,.1364E+01,.1380E+01,.1461E+01,.1429E+01,.9805E+00,.2594E+00,& - .1331E+01,.1331E+01,.1331E+01,.1337E+01,.1354E+01,.1390E+01,.1405E+01,.1492E+01,.1461E+01,.1005E+01,.2677E+00,& - .1360E+01,.1360E+01,.1360E+01,.1365E+01,.1379E+01,.1415E+01,.1431E+01,.1522E+01,.1493E+01,.1029E+01,.2761E+00,& - .1390E+01,.1390E+01,.1390E+01,.1394E+01,.1404E+01,.1441E+01,.1456E+01,.1553E+01,.1525E+01,.1053E+01,.2844E+00,& - .1420E+01,.1420E+01,.1420E+01,.1422E+01,.1429E+01,.1466E+01,.1482E+01,.1583E+01,.1557E+01,.1077E+01,.2928E+00,& - .1443E+01,.1443E+01,.1443E+01,.1447E+01,.1459E+01,.1497E+01,.1513E+01,.1614E+01,.1589E+01,.1103E+01,.3022E+00,& - .1467E+01,.1467E+01,.1467E+01,.1472E+01,.1490E+01,.1528E+01,.1544E+01,.1646E+01,.1621E+01,.1128E+01,.3115E+00,& - .1490E+01,.1490E+01,.1490E+01,.1498E+01,.1520E+01,.1559E+01,.1576E+01,.1677E+01,.1654E+01,.1154E+01,.3209E+00,& - .1514E+01,.1514E+01,.1514E+01,.1523E+01,.1551E+01,.1590E+01,.1607E+01,.1709E+01,.1686E+01,.1179E+01,.3302E+00,& - .1537E+01,.1537E+01,.1537E+01,.1548E+01,.1581E+01,.1621E+01,.1638E+01,.1740E+01,.1718E+01,.1205E+01,.3396E+00,& - .1571E+01,.1571E+01,.1571E+01,.1581E+01,.1609E+01,.1649E+01,.1666E+01,.1773E+01,.1754E+01,.1234E+01,.3500E+00,& - .1605E+01,.1605E+01,.1605E+01,.1613E+01,.1637E+01,.1677E+01,.1694E+01,.1806E+01,.1790E+01,.1263E+01,.3604E+00,& - .1639E+01,.1639E+01,.1639E+01,.1646E+01,.1665E+01,.1704E+01,.1721E+01,.1838E+01,.1826E+01,.1292E+01,.3709E+00,& - .1673E+01,.1673E+01,.1673E+01,.1678E+01,.1693E+01,.1732E+01,.1749E+01,.1871E+01,.1862E+01,.1321E+01,.3813E+00,& - .1707E+01,.1707E+01,.1707E+01,.1711E+01,.1721E+01,.1760E+01,.1777E+01,.1904E+01,.1898E+01,.1350E+01,.3917E+00,& - .1734E+01,.1734E+01,.1734E+01,.1740E+01,.1756E+01,.1793E+01,.1810E+01,.1938E+01,.1934E+01,.1380E+01,.4032E+00,& - .1761E+01,.1761E+01,.1761E+01,.1769E+01,.1790E+01,.1826E+01,.1842E+01,.1972E+01,.1970E+01,.1410E+01,.4147E+00,& - .1787E+01,.1787E+01,.1787E+01,.1797E+01,.1825E+01,.1860E+01,.1875E+01,.2007E+01,.2006E+01,.1439E+01,.4262E+00,& - .1814E+01,.1814E+01,.1814E+01,.1826E+01,.1859E+01,.1893E+01,.1907E+01,.2041E+01,.2042E+01,.1469E+01,.4377E+00,& - .1841E+01,.1841E+01,.1841E+01,.1855E+01,.1894E+01,.1926E+01,.1940E+01,.2075E+01,.2078E+01,.1499E+01,.4492E+00,& - .1878E+01,.1878E+01,.1878E+01,.1891E+01,.1926E+01,.1956E+01,.1969E+01,.2112E+01,.2118E+01,.1533E+01,.4619E+00,& - .1915E+01,.1915E+01,.1915E+01,.1926E+01,.1957E+01,.1985E+01,.1998E+01,.2149E+01,.2158E+01,.1566E+01,.4746E+00,& - .1953E+01,.1953E+01,.1953E+01,.1962E+01,.1989E+01,.2015E+01,.2026E+01,.2186E+01,.2198E+01,.1600E+01,.4872E+00,& - .1990E+01,.1990E+01,.1990E+01,.1997E+01,.2020E+01,.2044E+01,.2055E+01,.2223E+01,.2238E+01,.1633E+01,.4999E+00,& - .2027E+01,.2027E+01,.2027E+01,.2033E+01,.2052E+01,.2074E+01,.2084E+01,.2260E+01,.2278E+01,.1667E+01,.5126E+00,& - .2058E+01,.2058E+01,.2058E+01,.2065E+01,.2088E+01,.2111E+01,.2121E+01,.2295E+01,.2317E+01,.1701E+01,.5264E+00,& - .2089E+01,.2089E+01,.2089E+01,.2097E+01,.2123E+01,.2147E+01,.2158E+01,.2330E+01,.2356E+01,.1735E+01,.5403E+00,& - .2119E+01,.2119E+01,.2119E+01,.2130E+01,.2159E+01,.2184E+01,.2195E+01,.2365E+01,.2395E+01,.1770E+01,.5541E+00,& - .2150E+01,.2150E+01,.2150E+01,.2162E+01,.2194E+01,.2220E+01,.2232E+01,.2400E+01,.2434E+01,.1804E+01,.5680E+00,& - .2181E+01,.2181E+01,.2181E+01,.2194E+01,.2230E+01,.2257E+01,.2269E+01,.2435E+01,.2473E+01,.1838E+01,.5818E+00,& - .2212E+01,.2212E+01,.2212E+01,.2225E+01,.2259E+01,.2291E+01,.2305E+01,.2476E+01,.2516E+01,.1876E+01,.5970E+00,& - .2243E+01,.2243E+01,.2243E+01,.2255E+01,.2288E+01,.2325E+01,.2341E+01,.2517E+01,.2560E+01,.1915E+01,.6121E+00,& - .2275E+01,.2275E+01,.2275E+01,.2286E+01,.2317E+01,.2360E+01,.2378E+01,.2559E+01,.2603E+01,.1953E+01,.6273E+00,& - .2306E+01,.2306E+01,.2306E+01,.2316E+01,.2346E+01,.2394E+01,.2414E+01,.2600E+01,.2647E+01,.1992E+01,.6424E+00,& - .2337E+01,.2337E+01,.2337E+01,.2347E+01,.2375E+01,.2428E+01,.2450E+01,.2641E+01,.2690E+01,.2030E+01,.6576E+00,& - .2372E+01,.2372E+01,.2372E+01,.2384E+01,.2418E+01,.2470E+01,.2492E+01,.2676E+01,.2732E+01,.2068E+01,.6740E+00,& - .2407E+01,.2407E+01,.2407E+01,.2421E+01,.2461E+01,.2512E+01,.2534E+01,.2710E+01,.2775E+01,.2107E+01,.6903E+00,& - .2441E+01,.2441E+01,.2441E+01,.2458E+01,.2505E+01,.2555E+01,.2575E+01,.2745E+01,.2817E+01,.2145E+01,.7067E+00,& - .2476E+01,.2476E+01,.2476E+01,.2495E+01,.2548E+01,.2597E+01,.2617E+01,.2779E+01,.2860E+01,.2184E+01,.7230E+00,& - .2511E+01,.2511E+01,.2511E+01,.2532E+01,.2591E+01,.2639E+01,.2659E+01,.2814E+01,.2902E+01,.2222E+01,.7394E+00,& - .2543E+01,.2543E+01,.2543E+01,.2562E+01,.2616E+01,.2665E+01,.2686E+01,.2852E+01,.2941E+01,.2257E+01,.7540E+00,& - .2575E+01,.2575E+01,.2575E+01,.2592E+01,.2641E+01,.2692E+01,.2713E+01,.2890E+01,.2980E+01,.2292E+01,.7687E+00,& - .2606E+01,.2606E+01,.2606E+01,.2622E+01,.2667E+01,.2718E+01,.2740E+01,.2927E+01,.3018E+01,.2328E+01,.7833E+00,& - .2638E+01,.2638E+01,.2638E+01,.2652E+01,.2692E+01,.2745E+01,.2767E+01,.2965E+01,.3057E+01,.2363E+01,.7980E+00,& - .2670E+01,.2670E+01,.2670E+01,.2682E+01,.2717E+01,.2771E+01,.2794E+01,.3003E+01,.3096E+01,.2398E+01,.8126E+00,& - .2706E+01,.2706E+01,.2706E+01,.2718E+01,.2753E+01,.2800E+01,.2821E+01,.3037E+01,.3135E+01,.2435E+01,.8281E+00,& - .2743E+01,.2743E+01,.2743E+01,.2754E+01,.2788E+01,.2829E+01,.2847E+01,.3070E+01,.3174E+01,.2471E+01,.8436E+00,& - .2779E+01,.2779E+01,.2779E+01,.2791E+01,.2824E+01,.2859E+01,.2874E+01,.3104E+01,.3214E+01,.2508E+01,.8592E+00,& - .2816E+01,.2816E+01,.2816E+01,.2827E+01,.2859E+01,.2888E+01,.2900E+01,.3137E+01,.3253E+01,.2544E+01,.8747E+00,& - .2852E+01,.2852E+01,.2852E+01,.2863E+01,.2895E+01,.2917E+01,.2927E+01,.3171E+01,.3292E+01,.2581E+01,.8902E+00,& - .2877E+01,.2877E+01,.2877E+01,.2890E+01,.2929E+01,.2960E+01,.2973E+01,.3202E+01,.3329E+01,.2617E+01,.9066E+00,& - .2901E+01,.2901E+01,.2901E+01,.2917E+01,.2963E+01,.3002E+01,.3019E+01,.3233E+01,.3367E+01,.2653E+01,.9230E+00,& - .2926E+01,.2926E+01,.2926E+01,.2945E+01,.2998E+01,.3045E+01,.3066E+01,.3264E+01,.3404E+01,.2688E+01,.9394E+00,& - .2950E+01,.2950E+01,.2950E+01,.2972E+01,.3032E+01,.3087E+01,.3112E+01,.3295E+01,.3442E+01,.2724E+01,.9558E+00,& - .2975E+01,.2975E+01,.2975E+01,.2999E+01,.3066E+01,.3130E+01,.3158E+01,.3326E+01,.3479E+01,.2760E+01,.9722E+00,& - .3010E+01,.3010E+01,.3010E+01,.3031E+01,.3092E+01,.3157E+01,.3186E+01,.3367E+01,.3521E+01,.2800E+01,.9898E+00,& - .3044E+01,.3044E+01,.3044E+01,.3063E+01,.3118E+01,.3185E+01,.3214E+01,.3408E+01,.3563E+01,.2840E+01,.1007E+01,& - .3079E+01,.3079E+01,.3079E+01,.3096E+01,.3144E+01,.3212E+01,.3241E+01,.3448E+01,.3606E+01,.2881E+01,.1025E+01,& - .3113E+01,.3113E+01,.3113E+01,.3128E+01,.3170E+01,.3240E+01,.3269E+01,.3489E+01,.3648E+01,.2921E+01,.1042E+01,& - .3148E+01,.3148E+01,.3148E+01,.3160E+01,.3196E+01,.3267E+01,.3297E+01,.3530E+01,.3690E+01,.2961E+01,.1060E+01,& - .3209E+01,.3209E+01,.3209E+01,.3221E+01,.3255E+01,.3327E+01,.3358E+01,.3585E+01,.3758E+01,.3027E+01,.1090E+01,& - .3270E+01,.3270E+01,.3270E+01,.3281E+01,.3315E+01,.3388E+01,.3419E+01,.3641E+01,.3825E+01,.3093E+01,.1120E+01,& - .3331E+01,.3331E+01,.3331E+01,.3342E+01,.3374E+01,.3448E+01,.3480E+01,.3696E+01,.3893E+01,.3158E+01,.1151E+01,& - .3392E+01,.3392E+01,.3392E+01,.3402E+01,.3434E+01,.3509E+01,.3541E+01,.3752E+01,.3960E+01,.3224E+01,.1181E+01,& - .3453E+01,.3453E+01,.3453E+01,.3463E+01,.3493E+01,.3569E+01,.3602E+01,.3807E+01,.4028E+01,.3290E+01,.1211E+01,& - .3519E+01,.3519E+01,.3519E+01,.3532E+01,.3572E+01,.3635E+01,.3662E+01,.3892E+01,.4116E+01,.3378E+01,.1252E+01,& - .3585E+01,.3585E+01,.3585E+01,.3601E+01,.3650E+01,.3701E+01,.3723E+01,.3978E+01,.4203E+01,.3466E+01,.1294E+01,& - .3650E+01,.3650E+01,.3650E+01,.3671E+01,.3729E+01,.3767E+01,.3783E+01,.4063E+01,.4291E+01,.3554E+01,.1335E+01,& - .3716E+01,.3716E+01,.3716E+01,.3740E+01,.3807E+01,.3833E+01,.3844E+01,.4149E+01,.4378E+01,.3642E+01,.1377E+01,& - .3782E+01,.3782E+01,.3782E+01,.3809E+01,.3886E+01,.3899E+01,.3904E+01,.4234E+01,.4466E+01,.3730E+01,.1418E+01,& - .3887E+01,.3887E+01,.3887E+01,.3893E+01,.3911E+01,.3989E+01,.4022E+01,.4318E+01,.4576E+01,.3843E+01,.1470E+01,& - .4014E+01,.4014E+01,.4014E+01,.4022E+01,.4044E+01,.4121E+01,.4154E+01,.4424E+01,.4717E+01,.3990E+01,.1545E+01,& - .4110E+01,.4110E+01,.4110E+01,.4135E+01,.4208E+01,.4251E+01,.4270E+01,.4550E+01,.4846E+01,.4118E+01,.1612E+01,& - .4230E+01,.4230E+01,.4230E+01,.4253E+01,.4317E+01,.4367E+01,.4389E+01,.4657E+01,.4974E+01,.4254E+01,.1680E+01,& - .4365E+01,.4365E+01,.4365E+01,.4381E+01,.4428E+01,.4529E+01,.4572E+01,.4851E+01,.5188E+01,.4470E+01,.1786E+01,& - .4504E+01,.4504E+01,.4504E+01,.4530E+01,.4604E+01,.4649E+01,.4669E+01,.5015E+01,.5349E+01,.4645E+01,.1871E+01,& - .4700E+01,.4700E+01,.4700E+01,.4709E+01,.4733E+01,.4806E+01,.4838E+01,.5165E+01,.5549E+01,.4857E+01,.1983E+01,& - .4850E+01,.4850E+01,.4850E+01,.4881E+01,.4971E+01,.5034E+01,.5061E+01,.5355E+01,.5749E+01,.5067E+01,.2101E+01,& - .5072E+01,.5072E+01,.5072E+01,.5094E+01,.5156E+01,.5204E+01,.5224E+01,.5561E+01,.5983E+01,.5325E+01,.2237E+01,& - .5331E+01,.5331E+01,.5331E+01,.5348E+01,.5398E+01,.5469E+01,.5500E+01,.5874E+01,.6317E+01,.5681E+01,.2420E+01,& - .5667E+01,.5667E+01,.5667E+01,.5669E+01,.5674E+01,.5758E+01,.5794E+01,.6108E+01,.6640E+01,.6015E+01,.2612E+01,& - .5964E+01,.5964E+01,.5964E+01,.5991E+01,.6068E+01,.6104E+01,.6120E+01,.6533E+01,.7073E+01,.6511E+01,.2896E+01,& - .6438E+01,.6438E+01,.6438E+01,.6458E+01,.6515E+01,.6548E+01,.6562E+01,.7003E+01,.7599E+01,.7071E+01,.3211E+01,& - .7017E+01,.7017E+01,.7017E+01,.7041E+01,.7109E+01,.7145E+01,.7161E+01,.7586E+01,.8233E+01,.7799E+01,.3661E+01,& - .7828E+01,.7828E+01,.7828E+01,.7845E+01,.7895E+01,.8007E+01,.8055E+01,.8414E+01,.9188E+01,.8838E+01,.4305E+01,& - .8792E+01,.8792E+01,.8792E+01,.8832E+01,.8944E+01,.9022E+01,.9056E+01,.9506E+01,.1034E+02,.1016E+02,.5150E+01,& - .1065E+02,.1065E+02,.1065E+02,.1067E+02,.1073E+02,.1086E+02,.1091E+02,.1136E+02,.1235E+02,.1250E+02,.6784E+01,& - .1355E+02,.1355E+02,.1355E+02,.1357E+02,.1361E+02,.1368E+02,.1371E+02,.1427E+02,.1541E+02,.1607E+02,.9475E+01,& - .2060E+02,.2060E+02,.2060E+02,.2068E+02,.2089E+02,.2093E+02,.2095E+02,.2152E+02,.2316E+02,.2485E+02,.1687E+02/ - data (((Bex(ai,k,nh),ai= 6, 6),k=1,11),nh=0,99)/ & - .1250E+00,.1250E+00,.1250E+00,.1254E+00,.1264E+00,.1254E+00,.1250E+00,.1282E+00,.1335E+00,.1444E+00,.1543E+00,& - .1282E+00,.1282E+00,.1282E+00,.1286E+00,.1296E+00,.1285E+00,.1281E+00,.1313E+00,.1368E+00,.1478E+00,.1578E+00,& - .1313E+00,.1313E+00,.1313E+00,.1317E+00,.1328E+00,.1317E+00,.1312E+00,.1344E+00,.1400E+00,.1512E+00,.1612E+00,& - .1345E+00,.1345E+00,.1345E+00,.1349E+00,.1359E+00,.1348E+00,.1344E+00,.1375E+00,.1433E+00,.1547E+00,.1647E+00,& - .1376E+00,.1376E+00,.1376E+00,.1380E+00,.1391E+00,.1380E+00,.1375E+00,.1406E+00,.1465E+00,.1581E+00,.1681E+00,& - .1408E+00,.1408E+00,.1408E+00,.1412E+00,.1423E+00,.1411E+00,.1406E+00,.1437E+00,.1498E+00,.1615E+00,.1716E+00,& - .1440E+00,.1440E+00,.1440E+00,.1444E+00,.1454E+00,.1443E+00,.1438E+00,.1471E+00,.1533E+00,.1653E+00,.1754E+00,& - .1472E+00,.1472E+00,.1472E+00,.1476E+00,.1485E+00,.1474E+00,.1470E+00,.1505E+00,.1568E+00,.1690E+00,.1792E+00,& - .1505E+00,.1505E+00,.1505E+00,.1507E+00,.1516E+00,.1506E+00,.1501E+00,.1540E+00,.1603E+00,.1728E+00,.1831E+00,& - .1537E+00,.1537E+00,.1537E+00,.1539E+00,.1547E+00,.1537E+00,.1533E+00,.1574E+00,.1638E+00,.1765E+00,.1869E+00,& - .1569E+00,.1569E+00,.1569E+00,.1571E+00,.1578E+00,.1569E+00,.1565E+00,.1608E+00,.1673E+00,.1803E+00,.1907E+00,& - .1600E+00,.1600E+00,.1600E+00,.1602E+00,.1608E+00,.1604E+00,.1601E+00,.1643E+00,.1707E+00,.1839E+00,.1946E+00,& - .1631E+00,.1631E+00,.1631E+00,.1633E+00,.1638E+00,.1638E+00,.1638E+00,.1678E+00,.1741E+00,.1875E+00,.1986E+00,& - .1661E+00,.1661E+00,.1661E+00,.1663E+00,.1669E+00,.1673E+00,.1674E+00,.1712E+00,.1776E+00,.1912E+00,.2025E+00,& - .1692E+00,.1692E+00,.1692E+00,.1694E+00,.1699E+00,.1707E+00,.1711E+00,.1747E+00,.1810E+00,.1948E+00,.2065E+00,& - .1723E+00,.1723E+00,.1723E+00,.1725E+00,.1729E+00,.1742E+00,.1747E+00,.1782E+00,.1844E+00,.1984E+00,.2104E+00,& - .1761E+00,.1761E+00,.1761E+00,.1764E+00,.1769E+00,.1779E+00,.1782E+00,.1820E+00,.1883E+00,.2024E+00,.2147E+00,& - .1800E+00,.1800E+00,.1800E+00,.1802E+00,.1809E+00,.1815E+00,.1817E+00,.1857E+00,.1922E+00,.2065E+00,.2190E+00,& - .1838E+00,.1838E+00,.1838E+00,.1841E+00,.1848E+00,.1852E+00,.1853E+00,.1895E+00,.1961E+00,.2105E+00,.2233E+00,& - .1877E+00,.1877E+00,.1877E+00,.1879E+00,.1888E+00,.1888E+00,.1888E+00,.1932E+00,.2000E+00,.2146E+00,.2276E+00,& - .1915E+00,.1915E+00,.1915E+00,.1918E+00,.1928E+00,.1925E+00,.1923E+00,.1970E+00,.2039E+00,.2186E+00,.2319E+00,& - .1953E+00,.1953E+00,.1953E+00,.1956E+00,.1964E+00,.1966E+00,.1966E+00,.2012E+00,.2079E+00,.2228E+00,.2363E+00,& - .1991E+00,.1991E+00,.1991E+00,.1993E+00,.2001E+00,.2007E+00,.2010E+00,.2054E+00,.2119E+00,.2270E+00,.2407E+00,& - .2028E+00,.2028E+00,.2028E+00,.2031E+00,.2037E+00,.2049E+00,.2053E+00,.2095E+00,.2159E+00,.2313E+00,.2450E+00,& - .2066E+00,.2066E+00,.2066E+00,.2068E+00,.2074E+00,.2090E+00,.2097E+00,.2137E+00,.2199E+00,.2355E+00,.2494E+00,& - .2104E+00,.2104E+00,.2104E+00,.2106E+00,.2110E+00,.2131E+00,.2140E+00,.2179E+00,.2239E+00,.2397E+00,.2538E+00,& - .2146E+00,.2146E+00,.2146E+00,.2149E+00,.2154E+00,.2170E+00,.2176E+00,.2216E+00,.2280E+00,.2441E+00,.2586E+00,& - .2188E+00,.2188E+00,.2188E+00,.2191E+00,.2199E+00,.2209E+00,.2213E+00,.2252E+00,.2321E+00,.2485E+00,.2634E+00,& - .2230E+00,.2230E+00,.2230E+00,.2234E+00,.2243E+00,.2247E+00,.2249E+00,.2289E+00,.2362E+00,.2530E+00,.2681E+00,& - .2272E+00,.2272E+00,.2272E+00,.2276E+00,.2288E+00,.2286E+00,.2286E+00,.2325E+00,.2403E+00,.2574E+00,.2729E+00,& - .2314E+00,.2314E+00,.2314E+00,.2319E+00,.2332E+00,.2325E+00,.2322E+00,.2362E+00,.2444E+00,.2618E+00,.2777E+00,& - .2351E+00,.2351E+00,.2351E+00,.2356E+00,.2370E+00,.2364E+00,.2362E+00,.2405E+00,.2487E+00,.2662E+00,.2825E+00,& - .2389E+00,.2389E+00,.2389E+00,.2394E+00,.2408E+00,.2403E+00,.2401E+00,.2448E+00,.2530E+00,.2706E+00,.2873E+00,& - .2426E+00,.2426E+00,.2426E+00,.2431E+00,.2445E+00,.2442E+00,.2441E+00,.2491E+00,.2573E+00,.2750E+00,.2922E+00,& - .2464E+00,.2464E+00,.2464E+00,.2469E+00,.2483E+00,.2481E+00,.2480E+00,.2534E+00,.2616E+00,.2794E+00,.2970E+00,& - .2501E+00,.2501E+00,.2501E+00,.2506E+00,.2521E+00,.2520E+00,.2520E+00,.2577E+00,.2659E+00,.2838E+00,.3018E+00,& - .2545E+00,.2545E+00,.2545E+00,.2550E+00,.2564E+00,.2564E+00,.2565E+00,.2623E+00,.2705E+00,.2882E+00,.3070E+00,& - .2589E+00,.2589E+00,.2589E+00,.2594E+00,.2607E+00,.2608E+00,.2610E+00,.2669E+00,.2750E+00,.2926E+00,.3122E+00,& - .2634E+00,.2634E+00,.2634E+00,.2637E+00,.2649E+00,.2653E+00,.2654E+00,.2715E+00,.2796E+00,.2971E+00,.3175E+00,& - .2678E+00,.2678E+00,.2678E+00,.2681E+00,.2692E+00,.2697E+00,.2699E+00,.2761E+00,.2841E+00,.3015E+00,.3227E+00,& - .2722E+00,.2722E+00,.2722E+00,.2725E+00,.2735E+00,.2741E+00,.2744E+00,.2807E+00,.2887E+00,.3059E+00,.3279E+00,& - .2774E+00,.2774E+00,.2774E+00,.2776E+00,.2785E+00,.2792E+00,.2796E+00,.2854E+00,.2932E+00,.3110E+00,.3333E+00,& - .2826E+00,.2826E+00,.2826E+00,.2828E+00,.2834E+00,.2843E+00,.2848E+00,.2901E+00,.2977E+00,.3162E+00,.3386E+00,& - .2877E+00,.2877E+00,.2877E+00,.2879E+00,.2884E+00,.2895E+00,.2899E+00,.2948E+00,.3023E+00,.3213E+00,.3440E+00,& - .2929E+00,.2929E+00,.2929E+00,.2931E+00,.2933E+00,.2946E+00,.2951E+00,.2995E+00,.3068E+00,.3265E+00,.3493E+00,& - .2981E+00,.2981E+00,.2981E+00,.2982E+00,.2983E+00,.2997E+00,.3003E+00,.3042E+00,.3113E+00,.3316E+00,.3547E+00,& - .3021E+00,.3021E+00,.3021E+00,.3024E+00,.3029E+00,.3039E+00,.3043E+00,.3086E+00,.3164E+00,.3368E+00,.3602E+00,& - .3061E+00,.3061E+00,.3061E+00,.3065E+00,.3075E+00,.3081E+00,.3083E+00,.3130E+00,.3215E+00,.3419E+00,.3658E+00,& - .3102E+00,.3102E+00,.3102E+00,.3107E+00,.3121E+00,.3122E+00,.3123E+00,.3175E+00,.3265E+00,.3471E+00,.3713E+00,& - .3142E+00,.3142E+00,.3142E+00,.3148E+00,.3167E+00,.3164E+00,.3163E+00,.3219E+00,.3316E+00,.3522E+00,.3769E+00,& - .3182E+00,.3182E+00,.3182E+00,.3190E+00,.3213E+00,.3206E+00,.3203E+00,.3263E+00,.3367E+00,.3574E+00,.3824E+00,& - .3225E+00,.3225E+00,.3225E+00,.3232E+00,.3250E+00,.3248E+00,.3247E+00,.3302E+00,.3409E+00,.3614E+00,.3872E+00,& - .3268E+00,.3268E+00,.3268E+00,.3273E+00,.3287E+00,.3289E+00,.3290E+00,.3340E+00,.3452E+00,.3654E+00,.3920E+00,& - .3312E+00,.3312E+00,.3312E+00,.3315E+00,.3324E+00,.3331E+00,.3334E+00,.3379E+00,.3494E+00,.3695E+00,.3968E+00,& - .3355E+00,.3355E+00,.3355E+00,.3356E+00,.3361E+00,.3372E+00,.3377E+00,.3417E+00,.3537E+00,.3735E+00,.4016E+00,& - .3398E+00,.3398E+00,.3398E+00,.3398E+00,.3398E+00,.3414E+00,.3421E+00,.3456E+00,.3579E+00,.3775E+00,.4064E+00,& - .3438E+00,.3438E+00,.3438E+00,.3438E+00,.3440E+00,.3454E+00,.3460E+00,.3501E+00,.3619E+00,.3819E+00,.4113E+00,& - .3477E+00,.3477E+00,.3477E+00,.3478E+00,.3482E+00,.3494E+00,.3499E+00,.3546E+00,.3659E+00,.3863E+00,.4162E+00,& - .3517E+00,.3517E+00,.3517E+00,.3519E+00,.3524E+00,.3533E+00,.3537E+00,.3591E+00,.3700E+00,.3907E+00,.4210E+00,& - .3556E+00,.3556E+00,.3556E+00,.3559E+00,.3566E+00,.3573E+00,.3576E+00,.3636E+00,.3740E+00,.3951E+00,.4259E+00,& - .3596E+00,.3596E+00,.3596E+00,.3599E+00,.3608E+00,.3613E+00,.3615E+00,.3681E+00,.3780E+00,.3995E+00,.4308E+00,& - .3642E+00,.3642E+00,.3642E+00,.3645E+00,.3652E+00,.3663E+00,.3668E+00,.3727E+00,.3823E+00,.4042E+00,.4357E+00,& - .3689E+00,.3689E+00,.3689E+00,.3691E+00,.3697E+00,.3713E+00,.3720E+00,.3774E+00,.3866E+00,.4090E+00,.4407E+00,& - .3735E+00,.3735E+00,.3735E+00,.3737E+00,.3741E+00,.3764E+00,.3773E+00,.3820E+00,.3910E+00,.4137E+00,.4456E+00,& - .3782E+00,.3782E+00,.3782E+00,.3783E+00,.3786E+00,.3814E+00,.3825E+00,.3867E+00,.3953E+00,.4185E+00,.4506E+00,& - .3828E+00,.3828E+00,.3828E+00,.3829E+00,.3830E+00,.3864E+00,.3878E+00,.3913E+00,.3996E+00,.4232E+00,.4555E+00,& - .3867E+00,.3867E+00,.3867E+00,.3870E+00,.3877E+00,.3903E+00,.3914E+00,.3952E+00,.4041E+00,.4276E+00,.4607E+00,& - .3906E+00,.3906E+00,.3906E+00,.3911E+00,.3924E+00,.3942E+00,.3950E+00,.3991E+00,.4087E+00,.4319E+00,.4660E+00,& - .3944E+00,.3944E+00,.3944E+00,.3951E+00,.3972E+00,.3982E+00,.3986E+00,.4031E+00,.4132E+00,.4363E+00,.4712E+00,& - .3983E+00,.3983E+00,.3983E+00,.3992E+00,.4019E+00,.4021E+00,.4022E+00,.4070E+00,.4178E+00,.4406E+00,.4765E+00,& - .4022E+00,.4022E+00,.4022E+00,.4033E+00,.4066E+00,.4060E+00,.4058E+00,.4109E+00,.4223E+00,.4450E+00,.4817E+00,& - .4090E+00,.4090E+00,.4090E+00,.4098E+00,.4123E+00,.4125E+00,.4126E+00,.4174E+00,.4292E+00,.4520E+00,.4896E+00,& - .4158E+00,.4158E+00,.4158E+00,.4164E+00,.4181E+00,.4189E+00,.4193E+00,.4239E+00,.4361E+00,.4591E+00,.4976E+00,& - .4227E+00,.4227E+00,.4227E+00,.4229E+00,.4238E+00,.4254E+00,.4261E+00,.4305E+00,.4430E+00,.4661E+00,.5055E+00,& - .4295E+00,.4295E+00,.4295E+00,.4295E+00,.4296E+00,.4318E+00,.4328E+00,.4370E+00,.4499E+00,.4732E+00,.5135E+00,& - .4363E+00,.4363E+00,.4363E+00,.4360E+00,.4353E+00,.4383E+00,.4396E+00,.4435E+00,.4568E+00,.4802E+00,.5214E+00,& - .4464E+00,.4464E+00,.4464E+00,.4463E+00,.4462E+00,.4493E+00,.4506E+00,.4546E+00,.4671E+00,.4911E+00,.5335E+00,& - .4564E+00,.4564E+00,.4564E+00,.4566E+00,.4571E+00,.4603E+00,.4617E+00,.4658E+00,.4774E+00,.5020E+00,.5457E+00,& - .4665E+00,.4665E+00,.4665E+00,.4668E+00,.4679E+00,.4713E+00,.4727E+00,.4769E+00,.4878E+00,.5129E+00,.5578E+00,& - .4765E+00,.4765E+00,.4765E+00,.4771E+00,.4788E+00,.4823E+00,.4838E+00,.4881E+00,.4981E+00,.5238E+00,.5700E+00,& - .4866E+00,.4866E+00,.4866E+00,.4874E+00,.4897E+00,.4933E+00,.4948E+00,.4992E+00,.5084E+00,.5347E+00,.5821E+00,& - .5001E+00,.5001E+00,.5001E+00,.5006E+00,.5020E+00,.5028E+00,.5032E+00,.5097E+00,.5201E+00,.5463E+00,.5952E+00,& - .5118E+00,.5118E+00,.5118E+00,.5134E+00,.5179E+00,.5172E+00,.5169E+00,.5240E+00,.5383E+00,.5651E+00,.6156E+00,& - .5327E+00,.5327E+00,.5327E+00,.5327E+00,.5328E+00,.5327E+00,.5327E+00,.5405E+00,.5558E+00,.5826E+00,.6358E+00,& - .5484E+00,.5484E+00,.5484E+00,.5485E+00,.5489E+00,.5523E+00,.5537E+00,.5590E+00,.5738E+00,.6008E+00,.6560E+00,& - .5711E+00,.5711E+00,.5711E+00,.5717E+00,.5734E+00,.5745E+00,.5749E+00,.5823E+00,.5960E+00,.6240E+00,.6806E+00,& - .5949E+00,.5949E+00,.5949E+00,.5941E+00,.5920E+00,.5977E+00,.6002E+00,.6055E+00,.6164E+00,.6447E+00,.7059E+00,& - .6140E+00,.6140E+00,.6140E+00,.6149E+00,.6176E+00,.6184E+00,.6188E+00,.6275E+00,.6377E+00,.6695E+00,.7314E+00,& - .6340E+00,.6340E+00,.6340E+00,.6354E+00,.6393E+00,.6387E+00,.6385E+00,.6474E+00,.6617E+00,.6926E+00,.7589E+00,& - .6647E+00,.6647E+00,.6647E+00,.6646E+00,.6642E+00,.6646E+00,.6648E+00,.6732E+00,.6910E+00,.7195E+00,.7902E+00,& - .6957E+00,.6957E+00,.6957E+00,.6965E+00,.6986E+00,.6992E+00,.6995E+00,.7092E+00,.7245E+00,.7540E+00,.8286E+00,& - .7368E+00,.7368E+00,.7368E+00,.7375E+00,.7396E+00,.7441E+00,.7460E+00,.7526E+00,.7662E+00,.7986E+00,.8761E+00,& - .7789E+00,.7789E+00,.7789E+00,.7803E+00,.7844E+00,.7839E+00,.7837E+00,.7936E+00,.8110E+00,.8456E+00,.9284E+00,& - .8471E+00,.8471E+00,.8471E+00,.8487E+00,.8533E+00,.8532E+00,.8532E+00,.8632E+00,.8805E+00,.9144E+00,.1007E+01,& - .9305E+00,.9305E+00,.9305E+00,.9328E+00,.9393E+00,.9387E+00,.9384E+00,.9495E+00,.9626E+00,.1002E+01,.1103E+01,& - .1036E+01,.1036E+01,.1036E+01,.1038E+01,.1043E+01,.1042E+01,.1041E+01,.1053E+01,.1076E+01,.1110E+01,.1225E+01,& - .1203E+01,.1203E+01,.1203E+01,.1203E+01,.1203E+01,.1203E+01,.1203E+01,.1214E+01,.1241E+01,.1280E+01,.1410E+01,& - .1427E+01,.1427E+01,.1427E+01,.1428E+01,.1432E+01,.1431E+01,.1431E+01,.1444E+01,.1470E+01,.1518E+01,.1667E+01,& - .1851E+01,.1851E+01,.1851E+01,.1853E+01,.1858E+01,.1857E+01,.1857E+01,.1874E+01,.1906E+01,.1951E+01,.2142E+01,& - .2917E+01,.2917E+01,.2917E+01,.2918E+01,.2919E+01,.2926E+01,.2929E+01,.2953E+01,.2977E+01,.3058E+01,.3309E+01/ - data (((Bex(ai,k,nh),ai= 7, 7),k=1,11),nh=0,99)/ & - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01,& - .5168E+01,.5168E+01,.5168E+01,.5028E+01,.4631E+01,.4257E+01,.4097E+01,.2503E+01,.9626E+00,.2219E+00,.2345E-01/ - data (((Bex(ai,k,nh),ai= 8, 8),k=1,11),nh=0,99)/ & - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01,& - .3468E+01,.3468E+01,.3468E+01,.3455E+01,.3419E+01,.3331E+01,.3294E+01,.2580E+01,.1402E+01,.4594E+00,.4618E-01/ - data (((Bex(ai,k,nh),ai= 9, 9),k=1,11),nh=0,99)/ & - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00,& - .1745E+01,.1745E+01,.1745E+01,.1758E+01,.1796E+01,.1823E+01,.1835E+01,.1819E+01,.1434E+01,.7302E+00,.1065E+00/ - data (((Bex(ai,k,nh),ai=10,10),k=1,11),nh=0,99)/ & - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00,& - .8926E+00,.8926E+00,.8926E+00,.8984E+00,.9149E+00,.9305E+00,.9372E+00,.1013E+01,.1022E+01,.7607E+00,.1857E+00/ - data (((Bex(ai,k,nh),ai=11,11),k=1,11),nh=0,99)/ & - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00,& - .4546E+00,.4546E+00,.4546E+00,.4563E+00,.4613E+00,.4670E+00,.4695E+00,.4994E+00,.5457E+00,.5381E+00,.2239E+00/ - data (((Bex(ai,k,nh),ai=12,12),k=1,11),nh=0,99)/ & - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00,& - .2560E+00,.2560E+00,.2560E+00,.2566E+00,.2584E+00,.2601E+00,.2609E+00,.2714E+00,.2913E+00,.3227E+00,.2124E+00/ - data (((Bex(ai,k,nh),ai=13,13),k=1,11),nh=0,99)/ & - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00,& - .1329E+00,.1329E+00,.1329E+00,.1331E+00,.1335E+00,.1340E+00,.1342E+00,.1374E+00,.1435E+00,.1567E+00,.1466E+00/ - data (((Bex(ai,k,nh),ai=14,14),k=1,11),nh=0,99)/ & - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01,& - .7336E-01,.7336E-01,.7336E-01,.7346E-01,.7376E-01,.7401E-01,.7412E-01,.7527E-01,.7740E-01,.8163E-01,.8616E-01/ - data (((w0(ai,k,nh),ai= 1, 1),k=1,11),nh=0,99)/ & - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9766E+00,.1023E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9768E+00,.1038E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9771E+00,.1053E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9773E+00,.1069E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9776E+00,.1084E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9778E+00,.1099E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9780E+00,.1116E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9782E+00,.1133E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9785E+00,.1151E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9787E+00,.1168E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9789E+00,.1185E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9791E+00,.1203E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9793E+00,.1221E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9794E+00,.1239E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9796E+00,.1257E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9798E+00,.1275E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9800E+00,.1295E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9802E+00,.1315E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9804E+00,.1334E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9806E+00,.1354E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9808E+00,.1374E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9810E+00,.1395E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9811E+00,.1416E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9813E+00,.1437E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9814E+00,.1458E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9816E+00,.1479E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9818E+00,.1501E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9819E+00,.1523E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9821E+00,.1544E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9822E+00,.1566E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9824E+00,.1588E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9825E+00,.1611E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9827E+00,.1633E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9828E+00,.1656E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9830E+00,.1678E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9831E+00,.1701E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9832E+00,.1723E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9833E+00,.1745E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9835E+00,.1768E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9836E+00,.1790E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9837E+00,.1812E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9838E+00,.1835E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9839E+00,.1859E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9841E+00,.1882E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9842E+00,.1906E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9843E+00,.1929E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9844E+00,.1953E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9845E+00,.1976E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9846E+00,.2000E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9847E+00,.2023E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9848E+00,.2047E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9849E+00,.2069E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9850E+00,.2091E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9851E+00,.2113E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9852E+00,.2135E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9853E+00,.2157E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9854E+00,.2178E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9855E+00,.2199E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9855E+00,.2220E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9856E+00,.2241E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9857E+00,.2262E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9858E+00,.2284E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9859E+00,.2306E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9859E+00,.2327E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9860E+00,.2349E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9861E+00,.2371E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9862E+00,.2393E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9863E+00,.2414E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9863E+00,.2436E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9864E+00,.2457E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9865E+00,.2479E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9866E+00,.2514E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9867E+00,.2550E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9869E+00,.2585E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9870E+00,.2621E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9871E+00,.2656E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9872E+00,.2691E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9873E+00,.2725E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9874E+00,.2760E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9875E+00,.2794E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9876E+00,.2829E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9877E+00,.2866E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9878E+00,.2903E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9879E+00,.2940E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9881E+00,.2995E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9882E+00,.3050E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9883E+00,.3103E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9886E+00,.3174E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9887E+00,.3243E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9889E+00,.3328E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9891E+00,.3427E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9893E+00,.3524E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9896E+00,.3648E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9898E+00,.3768E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9901E+00,.3911E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9904E+00,.4101E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9908E+00,.4302E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9912E+00,.4555E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9917E+00,.4916E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9923E+00,.5487E+00/ - data (((w0(ai,k,nh),ai= 2, 2),k=1,11),nh=0,99)/ & - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3081E+00,.3081E+00,.3081E+00,.3093E+00,.3128E+00,.2973E+00,.2906E+00,.2103E+00,.1049E+00,.3129E-01,.2656E-02,& - .3085E+00,.3085E+00,.3085E+00,.3097E+00,.3131E+00,.2976E+00,.2909E+00,.2106E+00,.1051E+00,.3133E-01,.2660E-02,& - .3089E+00,.3089E+00,.3089E+00,.3100E+00,.3134E+00,.2979E+00,.2912E+00,.2108E+00,.1052E+00,.3138E-01,.2663E-02,& - .3092E+00,.3092E+00,.3092E+00,.3104E+00,.3137E+00,.2981E+00,.2914E+00,.2111E+00,.1054E+00,.3142E-01,.2667E-02,& - .3096E+00,.3096E+00,.3096E+00,.3107E+00,.3140E+00,.2984E+00,.2917E+00,.2113E+00,.1055E+00,.3147E-01,.2670E-02,& - .3100E+00,.3100E+00,.3100E+00,.3111E+00,.3143E+00,.2987E+00,.2920E+00,.2116E+00,.1057E+00,.3151E-01,.2674E-02,& - .3100E+00,.3100E+00,.3100E+00,.3111E+00,.3143E+00,.2987E+00,.2920E+00,.2116E+00,.1057E+00,.3151E-01,.2674E-02,& - .3100E+00,.3100E+00,.3100E+00,.3111E+00,.3143E+00,.2987E+00,.2920E+00,.2116E+00,.1057E+00,.3151E-01,.2674E-02,& - .3100E+00,.3100E+00,.3100E+00,.3111E+00,.3143E+00,.2987E+00,.2920E+00,.2116E+00,.1057E+00,.3151E-01,.2674E-02,& - .3100E+00,.3100E+00,.3100E+00,.3111E+00,.3143E+00,.2987E+00,.2920E+00,.2116E+00,.1057E+00,.3151E-01,.2674E-02,& - .3100E+00,.3100E+00,.3100E+00,.3111E+00,.3143E+00,.2987E+00,.2920E+00,.2116E+00,.1057E+00,.3151E-01,.2674E-02,& - .3112E+00,.3112E+00,.3112E+00,.3123E+00,.3153E+00,.2996E+00,.2929E+00,.2124E+00,.1062E+00,.3166E-01,.2686E-02,& - .3124E+00,.3124E+00,.3124E+00,.3134E+00,.3163E+00,.3006E+00,.2939E+00,.2132E+00,.1067E+00,.3181E-01,.2698E-02,& - .3137E+00,.3137E+00,.3137E+00,.3146E+00,.3172E+00,.3015E+00,.2948E+00,.2139E+00,.1071E+00,.3196E-01,.2711E-02,& - .3149E+00,.3149E+00,.3149E+00,.3157E+00,.3182E+00,.3025E+00,.2958E+00,.2147E+00,.1076E+00,.3211E-01,.2723E-02,& - .3161E+00,.3161E+00,.3161E+00,.3169E+00,.3192E+00,.3034E+00,.2967E+00,.2155E+00,.1081E+00,.3226E-01,.2735E-02,& - .3200E+00,.3200E+00,.3200E+00,.3206E+00,.3224E+00,.3065E+00,.2998E+00,.2181E+00,.1097E+00,.3276E-01,.2775E-02,& - .3238E+00,.3238E+00,.3238E+00,.3243E+00,.3256E+00,.3096E+00,.3028E+00,.2207E+00,.1113E+00,.3326E-01,.2815E-02,& - .3277E+00,.3277E+00,.3277E+00,.3279E+00,.3288E+00,.3128E+00,.3059E+00,.2234E+00,.1129E+00,.3376E-01,.2856E-02,& - .3315E+00,.3315E+00,.3315E+00,.3316E+00,.3320E+00,.3159E+00,.3089E+00,.2260E+00,.1145E+00,.3426E-01,.2896E-02,& - .3354E+00,.3354E+00,.3354E+00,.3353E+00,.3352E+00,.3190E+00,.3120E+00,.2286E+00,.1161E+00,.3476E-01,.2936E-02,& - .3413E+00,.3413E+00,.3413E+00,.3410E+00,.3402E+00,.3238E+00,.3168E+00,.2328E+00,.1187E+00,.3561E-01,.3003E-02,& - .3472E+00,.3472E+00,.3472E+00,.3466E+00,.3452E+00,.3287E+00,.3216E+00,.2370E+00,.1214E+00,.3646E-01,.3070E-02,& - .3530E+00,.3530E+00,.3530E+00,.3523E+00,.3501E+00,.3335E+00,.3264E+00,.2411E+00,.1240E+00,.3731E-01,.3138E-02,& - .3589E+00,.3589E+00,.3589E+00,.3579E+00,.3551E+00,.3384E+00,.3312E+00,.2453E+00,.1267E+00,.3816E-01,.3205E-02,& - .3648E+00,.3648E+00,.3648E+00,.3636E+00,.3601E+00,.3432E+00,.3360E+00,.2495E+00,.1293E+00,.3901E-01,.3272E-02,& - .3746E+00,.3746E+00,.3746E+00,.3730E+00,.3685E+00,.3514E+00,.3441E+00,.2567E+00,.1339E+00,.4053E-01,.3392E-02,& - .3813E+00,.3813E+00,.3813E+00,.3795E+00,.3743E+00,.3571E+00,.3497E+00,.2617E+00,.1372E+00,.4161E-01,.3477E-02,& - .3916E+00,.3916E+00,.3916E+00,.3894E+00,.3833E+00,.3659E+00,.3585E+00,.2695E+00,.1423E+00,.4333E-01,.3612E-02,& - .3987E+00,.3987E+00,.3987E+00,.3963E+00,.3895E+00,.3720E+00,.3645E+00,.2750E+00,.1459E+00,.4455E-01,.3708E-02,& - .4095E+00,.4095E+00,.4095E+00,.4068E+00,.3990E+00,.3814E+00,.3738E+00,.2834E+00,.1516E+00,.4649E-01,.3860E-02,& - .4205E+00,.4205E+00,.4205E+00,.4175E+00,.4088E+00,.3910E+00,.3834E+00,.2922E+00,.1575E+00,.4856E-01,.4023E-02,& - .4280E+00,.4280E+00,.4280E+00,.4247E+00,.4154E+00,.3975E+00,.3899E+00,.2982E+00,.1617E+00,.5001E-01,.4137E-02,& - .4393E+00,.4393E+00,.4393E+00,.4357E+00,.4256E+00,.4077E+00,.4000E+00,.3075E+00,.1681E+00,.5231E-01,.4318E-02,& - .4470E+00,.4470E+00,.4470E+00,.4432E+00,.4325E+00,.4145E+00,.4068E+00,.3139E+00,.1726E+00,.5392E-01,.4444E-02,& - .4585E+00,.4585E+00,.4585E+00,.4544E+00,.4429E+00,.4248E+00,.4171E+00,.3237E+00,.1796E+00,.5646E-01,.4644E-02,& - .4701E+00,.4701E+00,.4701E+00,.4658E+00,.4535E+00,.4354E+00,.4277E+00,.3338E+00,.1869E+00,.5915E-01,.4856E-02,& - .4818E+00,.4818E+00,.4818E+00,.4772E+00,.4642E+00,.4461E+00,.4383E+00,.3440E+00,.1944E+00,.6198E-01,.5080E-02,& - .4935E+00,.4935E+00,.4935E+00,.4887E+00,.4750E+00,.4569E+00,.4491E+00,.3545E+00,.2023E+00,.6498E-01,.5317E-02,& - .5091E+00,.5091E+00,.5091E+00,.5040E+00,.4894E+00,.4714E+00,.4637E+00,.3689E+00,.2133E+00,.6923E-01,.5655E-02,& - .5245E+00,.5245E+00,.5245E+00,.5192E+00,.5040E+00,.4861E+00,.4784E+00,.3835E+00,.2247E+00,.7377E-01,.6017E-02,& - .5437E+00,.5437E+00,.5437E+00,.5381E+00,.5221E+00,.5044E+00,.4968E+00,.4021E+00,.2396E+00,.7989E-01,.6507E-02,& - .5699E+00,.5699E+00,.5699E+00,.5640E+00,.5472E+00,.5298E+00,.5224E+00,.4287E+00,.2616E+00,.8925E-01,.7266E-02,& - .5987E+00,.5987E+00,.5987E+00,.5926E+00,.5754E+00,.5586E+00,.5514E+00,.4595E+00,.2883E+00,.1012E+00,.8247E-02,& - .6646E+00,.6646E+00,.6646E+00,.6585E+00,.6413E+00,.6265E+00,.6202E+00,.5355E+00,.3600E+00,.1368E+00,.1128E-01/ - data (((w0(ai,k,nh),ai= 3, 3),k=1,11),nh=0,99)/ & - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00/ - data (((w0(ai,k,nh),ai= 4, 4),k=1,11),nh=0,99)/ & - .8395E+00,.8395E+00,.8395E+00,.8684E+00,.9505E+00,.9634E+00,.9689E+00,.9616E+00,.8776E+00,.7338E+00,.2193E+00,& - .8409E+00,.8409E+00,.8409E+00,.8696E+00,.9510E+00,.9638E+00,.9692E+00,.9620E+00,.8787E+00,.7359E+00,.2176E+00,& - .8423E+00,.8423E+00,.8423E+00,.8707E+00,.9516E+00,.9642E+00,.9695E+00,.9624E+00,.8798E+00,.7381E+00,.2158E+00,& - .8436E+00,.8436E+00,.8436E+00,.8719E+00,.9521E+00,.9645E+00,.9699E+00,.9627E+00,.8810E+00,.7402E+00,.2141E+00,& - .8450E+00,.8450E+00,.8450E+00,.8730E+00,.9527E+00,.9649E+00,.9702E+00,.9631E+00,.8821E+00,.7424E+00,.2123E+00,& - .8464E+00,.8464E+00,.8464E+00,.8742E+00,.9532E+00,.9653E+00,.9705E+00,.9635E+00,.8832E+00,.7445E+00,.2106E+00,& - .8476E+00,.8476E+00,.8476E+00,.8752E+00,.9537E+00,.9656E+00,.9708E+00,.9639E+00,.8843E+00,.7466E+00,.2098E+00,& - .8489E+00,.8489E+00,.8489E+00,.8763E+00,.9541E+00,.9660E+00,.9711E+00,.9642E+00,.8853E+00,.7487E+00,.2091E+00,& - .8501E+00,.8501E+00,.8501E+00,.8773E+00,.9546E+00,.9663E+00,.9713E+00,.9646E+00,.8864E+00,.7508E+00,.2083E+00,& - .8514E+00,.8514E+00,.8514E+00,.8784E+00,.9550E+00,.9667E+00,.9716E+00,.9649E+00,.8874E+00,.7529E+00,.2076E+00,& - .8526E+00,.8526E+00,.8526E+00,.8794E+00,.9555E+00,.9670E+00,.9719E+00,.9653E+00,.8885E+00,.7550E+00,.2068E+00,& - .8538E+00,.8538E+00,.8538E+00,.8804E+00,.9559E+00,.9673E+00,.9721E+00,.9656E+00,.8895E+00,.7570E+00,.2065E+00,& - .8550E+00,.8550E+00,.8550E+00,.8814E+00,.9563E+00,.9676E+00,.9724E+00,.9660E+00,.8905E+00,.7591E+00,.2062E+00,& - .8563E+00,.8563E+00,.8563E+00,.8824E+00,.9566E+00,.9678E+00,.9726E+00,.9663E+00,.8916E+00,.7611E+00,.2059E+00,& - .8575E+00,.8575E+00,.8575E+00,.8834E+00,.9570E+00,.9681E+00,.9729E+00,.9667E+00,.8926E+00,.7632E+00,.2056E+00,& - .8587E+00,.8587E+00,.8587E+00,.8844E+00,.9574E+00,.9684E+00,.9731E+00,.9670E+00,.8936E+00,.7652E+00,.2053E+00,& - .8599E+00,.8599E+00,.8599E+00,.8854E+00,.9578E+00,.9687E+00,.9734E+00,.9673E+00,.8946E+00,.7672E+00,.2052E+00,& - .8612E+00,.8612E+00,.8612E+00,.8864E+00,.9582E+00,.9690E+00,.9737E+00,.9676E+00,.8956E+00,.7691E+00,.2052E+00,& - .8624E+00,.8624E+00,.8624E+00,.8875E+00,.9586E+00,.9694E+00,.9740E+00,.9680E+00,.8965E+00,.7711E+00,.2051E+00,& - .8637E+00,.8637E+00,.8637E+00,.8885E+00,.9590E+00,.9697E+00,.9743E+00,.9683E+00,.8975E+00,.7730E+00,.2051E+00,& - .8649E+00,.8649E+00,.8649E+00,.8895E+00,.9594E+00,.9700E+00,.9746E+00,.9686E+00,.8985E+00,.7750E+00,.2050E+00,& - .8661E+00,.8661E+00,.8661E+00,.8905E+00,.9598E+00,.9703E+00,.9749E+00,.9689E+00,.8995E+00,.7769E+00,.2051E+00,& - .8673E+00,.8673E+00,.8673E+00,.8915E+00,.9602E+00,.9706E+00,.9751E+00,.9692E+00,.9004E+00,.7788E+00,.2052E+00,& - .8684E+00,.8684E+00,.8684E+00,.8924E+00,.9607E+00,.9710E+00,.9754E+00,.9695E+00,.9014E+00,.7807E+00,.2052E+00,& - .8696E+00,.8696E+00,.8696E+00,.8934E+00,.9611E+00,.9713E+00,.9756E+00,.9698E+00,.9023E+00,.7826E+00,.2053E+00,& - .8708E+00,.8708E+00,.8708E+00,.8944E+00,.9615E+00,.9716E+00,.9759E+00,.9701E+00,.9033E+00,.7845E+00,.2054E+00,& - .8719E+00,.8719E+00,.8719E+00,.8953E+00,.9619E+00,.9719E+00,.9761E+00,.9704E+00,.9042E+00,.7864E+00,.2056E+00,& - .8729E+00,.8729E+00,.8729E+00,.8962E+00,.9623E+00,.9722E+00,.9764E+00,.9707E+00,.9051E+00,.7882E+00,.2058E+00,& - .8740E+00,.8740E+00,.8740E+00,.8970E+00,.9627E+00,.9724E+00,.9766E+00,.9710E+00,.9060E+00,.7901E+00,.2060E+00,& - .8750E+00,.8750E+00,.8750E+00,.8979E+00,.9631E+00,.9727E+00,.9769E+00,.9713E+00,.9069E+00,.7919E+00,.2062E+00,& - .8761E+00,.8761E+00,.8761E+00,.8988E+00,.9635E+00,.9730E+00,.9771E+00,.9716E+00,.9078E+00,.7938E+00,.2064E+00,& - .8770E+00,.8770E+00,.8770E+00,.8996E+00,.9638E+00,.9732E+00,.9773E+00,.9719E+00,.9087E+00,.7956E+00,.2067E+00,& - .8780E+00,.8780E+00,.8780E+00,.9004E+00,.9641E+00,.9735E+00,.9775E+00,.9722E+00,.9096E+00,.7973E+00,.2069E+00,& - .8789E+00,.8789E+00,.8789E+00,.9011E+00,.9645E+00,.9737E+00,.9777E+00,.9724E+00,.9104E+00,.7991E+00,.2072E+00,& - .8799E+00,.8799E+00,.8799E+00,.9019E+00,.9648E+00,.9740E+00,.9779E+00,.9727E+00,.9113E+00,.8008E+00,.2074E+00,& - .8808E+00,.8808E+00,.8808E+00,.9027E+00,.9651E+00,.9742E+00,.9781E+00,.9730E+00,.9122E+00,.8026E+00,.2077E+00,& - .8818E+00,.8818E+00,.8818E+00,.9035E+00,.9654E+00,.9744E+00,.9783E+00,.9733E+00,.9130E+00,.8043E+00,.2080E+00,& - .8827E+00,.8827E+00,.8827E+00,.9043E+00,.9657E+00,.9746E+00,.9785E+00,.9735E+00,.9138E+00,.8060E+00,.2083E+00,& - .8837E+00,.8837E+00,.8837E+00,.9051E+00,.9660E+00,.9749E+00,.9786E+00,.9738E+00,.9147E+00,.8077E+00,.2087E+00,& - .8846E+00,.8846E+00,.8846E+00,.9059E+00,.9663E+00,.9751E+00,.9788E+00,.9740E+00,.9155E+00,.8094E+00,.2090E+00,& - .8856E+00,.8856E+00,.8856E+00,.9067E+00,.9666E+00,.9753E+00,.9790E+00,.9743E+00,.9163E+00,.8111E+00,.2093E+00,& - .8866E+00,.8866E+00,.8866E+00,.9075E+00,.9669E+00,.9755E+00,.9792E+00,.9745E+00,.9171E+00,.8127E+00,.2097E+00,& - .8875E+00,.8875E+00,.8875E+00,.9083E+00,.9672E+00,.9758E+00,.9794E+00,.9747E+00,.9179E+00,.8144E+00,.2101E+00,& - .8885E+00,.8885E+00,.8885E+00,.9090E+00,.9674E+00,.9760E+00,.9797E+00,.9750E+00,.9187E+00,.8160E+00,.2104E+00,& - .8894E+00,.8894E+00,.8894E+00,.9098E+00,.9677E+00,.9763E+00,.9799E+00,.9752E+00,.9195E+00,.8177E+00,.2108E+00,& - .8904E+00,.8904E+00,.8904E+00,.9106E+00,.9680E+00,.9765E+00,.9801E+00,.9754E+00,.9203E+00,.8193E+00,.2112E+00,& - .8913E+00,.8913E+00,.8913E+00,.9114E+00,.9683E+00,.9767E+00,.9803E+00,.9756E+00,.9210E+00,.8209E+00,.2116E+00,& - .8923E+00,.8923E+00,.8923E+00,.9122E+00,.9686E+00,.9770E+00,.9805E+00,.9759E+00,.9218E+00,.8224E+00,.2120E+00,& - .8932E+00,.8932E+00,.8932E+00,.9129E+00,.9690E+00,.9772E+00,.9807E+00,.9761E+00,.9225E+00,.8240E+00,.2124E+00,& - .8942E+00,.8942E+00,.8942E+00,.9137E+00,.9693E+00,.9775E+00,.9809E+00,.9764E+00,.9233E+00,.8255E+00,.2128E+00,& - .8951E+00,.8951E+00,.8951E+00,.9145E+00,.9696E+00,.9777E+00,.9811E+00,.9766E+00,.9240E+00,.8271E+00,.2132E+00,& - .8961E+00,.8961E+00,.8961E+00,.9153E+00,.9700E+00,.9779E+00,.9813E+00,.9769E+00,.9249E+00,.8289E+00,.2137E+00,& - .8970E+00,.8970E+00,.8970E+00,.9161E+00,.9703E+00,.9782E+00,.9815E+00,.9771E+00,.9258E+00,.8307E+00,.2142E+00,& - .8980E+00,.8980E+00,.8980E+00,.9169E+00,.9707E+00,.9784E+00,.9817E+00,.9774E+00,.9266E+00,.8325E+00,.2147E+00,& - .8989E+00,.8989E+00,.8989E+00,.9177E+00,.9710E+00,.9787E+00,.9819E+00,.9776E+00,.9275E+00,.8343E+00,.2152E+00,& - .8999E+00,.8999E+00,.8999E+00,.9185E+00,.9714E+00,.9789E+00,.9821E+00,.9779E+00,.9284E+00,.8361E+00,.2157E+00,& - .9007E+00,.9007E+00,.9007E+00,.9192E+00,.9717E+00,.9791E+00,.9823E+00,.9782E+00,.9292E+00,.8378E+00,.2162E+00,& - .9015E+00,.9015E+00,.9015E+00,.9199E+00,.9719E+00,.9793E+00,.9825E+00,.9784E+00,.9300E+00,.8395E+00,.2168E+00,& - .9024E+00,.9024E+00,.9024E+00,.9205E+00,.9722E+00,.9795E+00,.9826E+00,.9787E+00,.9308E+00,.8411E+00,.2173E+00,& - .9032E+00,.9032E+00,.9032E+00,.9212E+00,.9724E+00,.9797E+00,.9828E+00,.9789E+00,.9316E+00,.8428E+00,.2179E+00,& - .9040E+00,.9040E+00,.9040E+00,.9219E+00,.9727E+00,.9799E+00,.9830E+00,.9792E+00,.9324E+00,.8445E+00,.2184E+00,& - .9048E+00,.9048E+00,.9048E+00,.9225E+00,.9729E+00,.9801E+00,.9831E+00,.9794E+00,.9331E+00,.8458E+00,.2189E+00,& - .9056E+00,.9056E+00,.9056E+00,.9231E+00,.9731E+00,.9802E+00,.9833E+00,.9796E+00,.9337E+00,.8472E+00,.2194E+00,& - .9063E+00,.9063E+00,.9063E+00,.9238E+00,.9733E+00,.9804E+00,.9834E+00,.9797E+00,.9344E+00,.8485E+00,.2198E+00,& - .9071E+00,.9071E+00,.9071E+00,.9244E+00,.9735E+00,.9805E+00,.9836E+00,.9799E+00,.9350E+00,.8499E+00,.2203E+00,& - .9079E+00,.9079E+00,.9079E+00,.9250E+00,.9737E+00,.9807E+00,.9837E+00,.9801E+00,.9357E+00,.8512E+00,.2208E+00,& - .9088E+00,.9088E+00,.9088E+00,.9257E+00,.9740E+00,.9809E+00,.9839E+00,.9803E+00,.9364E+00,.8527E+00,.2214E+00,& - .9097E+00,.9097E+00,.9097E+00,.9265E+00,.9743E+00,.9811E+00,.9841E+00,.9805E+00,.9371E+00,.8542E+00,.2220E+00,& - .9106E+00,.9106E+00,.9106E+00,.9272E+00,.9745E+00,.9814E+00,.9842E+00,.9808E+00,.9379E+00,.8558E+00,.2225E+00,& - .9115E+00,.9115E+00,.9115E+00,.9280E+00,.9748E+00,.9816E+00,.9844E+00,.9810E+00,.9386E+00,.8573E+00,.2231E+00,& - .9124E+00,.9124E+00,.9124E+00,.9287E+00,.9751E+00,.9818E+00,.9846E+00,.9812E+00,.9393E+00,.8588E+00,.2237E+00,& - .9136E+00,.9136E+00,.9136E+00,.9297E+00,.9755E+00,.9821E+00,.9848E+00,.9815E+00,.9403E+00,.8609E+00,.2246E+00,& - .9147E+00,.9147E+00,.9147E+00,.9306E+00,.9759E+00,.9824E+00,.9851E+00,.9818E+00,.9413E+00,.8630E+00,.2255E+00,& - .9159E+00,.9159E+00,.9159E+00,.9316E+00,.9763E+00,.9826E+00,.9853E+00,.9821E+00,.9423E+00,.8652E+00,.2264E+00,& - .9170E+00,.9170E+00,.9170E+00,.9325E+00,.9767E+00,.9829E+00,.9856E+00,.9824E+00,.9433E+00,.8673E+00,.2273E+00,& - .9182E+00,.9182E+00,.9182E+00,.9335E+00,.9771E+00,.9832E+00,.9858E+00,.9827E+00,.9443E+00,.8694E+00,.2282E+00,& - .9195E+00,.9195E+00,.9195E+00,.9346E+00,.9775E+00,.9835E+00,.9861E+00,.9831E+00,.9455E+00,.8719E+00,.2294E+00,& - .9208E+00,.9208E+00,.9208E+00,.9357E+00,.9779E+00,.9838E+00,.9863E+00,.9834E+00,.9467E+00,.8745E+00,.2307E+00,& - .9222E+00,.9222E+00,.9222E+00,.9367E+00,.9783E+00,.9841E+00,.9866E+00,.9838E+00,.9479E+00,.8770E+00,.2319E+00,& - .9235E+00,.9235E+00,.9235E+00,.9378E+00,.9787E+00,.9844E+00,.9868E+00,.9841E+00,.9491E+00,.8796E+00,.2332E+00,& - .9248E+00,.9248E+00,.9248E+00,.9389E+00,.9791E+00,.9847E+00,.9871E+00,.9845E+00,.9503E+00,.8821E+00,.2344E+00,& - .9266E+00,.9266E+00,.9266E+00,.9404E+00,.9795E+00,.9850E+00,.9874E+00,.9849E+00,.9517E+00,.8851E+00,.2360E+00,& - .9283E+00,.9283E+00,.9283E+00,.9418E+00,.9801E+00,.9855E+00,.9878E+00,.9852E+00,.9530E+00,.8879E+00,.2376E+00,& - .9300E+00,.9300E+00,.9300E+00,.9432E+00,.9806E+00,.9858E+00,.9881E+00,.9856E+00,.9543E+00,.8907E+00,.2391E+00,& - .9315E+00,.9315E+00,.9315E+00,.9444E+00,.9811E+00,.9862E+00,.9884E+00,.9860E+00,.9556E+00,.8934E+00,.2408E+00,& - .9332E+00,.9332E+00,.9332E+00,.9458E+00,.9817E+00,.9867E+00,.9888E+00,.9864E+00,.9572E+00,.8969E+00,.2429E+00,& - .9348E+00,.9348E+00,.9348E+00,.9471E+00,.9823E+00,.9871E+00,.9891E+00,.9869E+00,.9588E+00,.9001E+00,.2450E+00,& - .9367E+00,.9367E+00,.9367E+00,.9487E+00,.9829E+00,.9875E+00,.9895E+00,.9875E+00,.9606E+00,.9041E+00,.2477E+00,& - .9391E+00,.9391E+00,.9391E+00,.9506E+00,.9834E+00,.9879E+00,.9898E+00,.9880E+00,.9623E+00,.9078E+00,.2504E+00,& - .9417E+00,.9417E+00,.9417E+00,.9527E+00,.9841E+00,.9885E+00,.9904E+00,.9886E+00,.9643E+00,.9121E+00,.2536E+00,& - .9441E+00,.9441E+00,.9441E+00,.9547E+00,.9849E+00,.9890E+00,.9908E+00,.9891E+00,.9662E+00,.9160E+00,.2568E+00,& - .9464E+00,.9464E+00,.9464E+00,.9566E+00,.9857E+00,.9896E+00,.9913E+00,.9897E+00,.9682E+00,.9204E+00,.2606E+00,& - .9487E+00,.9487E+00,.9487E+00,.9585E+00,.9864E+00,.9901E+00,.9917E+00,.9903E+00,.9703E+00,.9250E+00,.2648E+00,& - .9521E+00,.9521E+00,.9521E+00,.9612E+00,.9872E+00,.9908E+00,.9923E+00,.9911E+00,.9728E+00,.9302E+00,.2701E+00,& - .9551E+00,.9551E+00,.9551E+00,.9637E+00,.9882E+00,.9915E+00,.9929E+00,.9918E+00,.9751E+00,.9354E+00,.2760E+00,& - .9587E+00,.9587E+00,.9587E+00,.9667E+00,.9893E+00,.9922E+00,.9935E+00,.9926E+00,.9780E+00,.9416E+00,.2838E+00,& - .9630E+00,.9630E+00,.9630E+00,.9701E+00,.9905E+00,.9932E+00,.9943E+00,.9935E+00,.9811E+00,.9482E+00,.2936E+00,& - .9670E+00,.9670E+00,.9670E+00,.9733E+00,.9914E+00,.9939E+00,.9950E+00,.9944E+00,.9840E+00,.9546E+00,.3047E+00,& - .9723E+00,.9723E+00,.9723E+00,.9777E+00,.9930E+00,.9950E+00,.9958E+00,.9956E+00,.9876E+00,.9625E+00,.3222E+00,& - .9786E+00,.9786E+00,.9786E+00,.9828E+00,.9947E+00,.9962E+00,.9969E+00,.9968E+00,.9914E+00,.9712E+00,.3489E+00/ - data (((w0(ai,k,nh),ai= 5, 5),k=1,11),nh=0,99)/ & - .9998E+00,.9998E+00,.9998E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9988E+00,.9902E+00,.9046E+00,& - .9998E+00,.9998E+00,.9998E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9988E+00,.9903E+00,.8962E+00,& - .9998E+00,.9998E+00,.9998E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9989E+00,.9903E+00,.8877E+00,& - .9998E+00,.9998E+00,.9998E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9989E+00,.9904E+00,.8793E+00,& - .9998E+00,.9998E+00,.9998E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9990E+00,.9904E+00,.8708E+00,& - .9998E+00,.9998E+00,.9998E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9990E+00,.9905E+00,.8624E+00,& - .9998E+00,.9998E+00,.9998E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9990E+00,.9906E+00,.8564E+00,& - .9998E+00,.9998E+00,.9998E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9990E+00,.9906E+00,.8504E+00,& - .9998E+00,.9998E+00,.9998E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9991E+00,.9907E+00,.8444E+00,& - .9998E+00,.9998E+00,.9998E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9991E+00,.9907E+00,.8384E+00,& - .9998E+00,.9998E+00,.9998E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9991E+00,.9908E+00,.8324E+00,& - .9998E+00,.9998E+00,.9998E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9991E+00,.9909E+00,.8279E+00,& - .9998E+00,.9998E+00,.9998E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9991E+00,.9909E+00,.8234E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9992E+00,.9910E+00,.8190E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9992E+00,.9910E+00,.8145E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9992E+00,.9911E+00,.8100E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9992E+00,.9911E+00,.8066E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9992E+00,.9912E+00,.8033E+00,& - .9998E+00,.9998E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9993E+00,.9912E+00,.7999E+00,& - .9998E+00,.9998E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9993E+00,.9913E+00,.7966E+00,& - .9998E+00,.9998E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9993E+00,.9913E+00,.7932E+00,& - .9998E+00,.9998E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9993E+00,.9913E+00,.7906E+00,& - .9998E+00,.9998E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9993E+00,.9914E+00,.7881E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9993E+00,.9914E+00,.7855E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9993E+00,.9915E+00,.7830E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9993E+00,.9915E+00,.7804E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9993E+00,.9915E+00,.7784E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9993E+00,.9915E+00,.7765E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9994E+00,.9916E+00,.7745E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9994E+00,.9916E+00,.7726E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9994E+00,.9916E+00,.7706E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9994E+00,.9916E+00,.7691E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9994E+00,.9916E+00,.7676E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9994E+00,.9917E+00,.7661E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9994E+00,.9917E+00,.7646E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9994E+00,.9917E+00,.7631E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9994E+00,.9917E+00,.7620E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9994E+00,.9917E+00,.7608E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9995E+00,.9918E+00,.7597E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9995E+00,.9918E+00,.7585E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9995E+00,.9918E+00,.7574E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9995E+00,.9918E+00,.7565E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9995E+00,.9918E+00,.7557E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9995E+00,.9919E+00,.7548E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9995E+00,.9919E+00,.7540E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9995E+00,.9919E+00,.7531E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9995E+00,.9919E+00,.7525E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9995E+00,.9919E+00,.7518E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9996E+00,.9920E+00,.7512E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9996E+00,.9920E+00,.7505E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9996E+00,.9920E+00,.7499E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9996E+00,.9920E+00,.7495E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9996E+00,.9920E+00,.7491E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9996E+00,.9920E+00,.7487E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9996E+00,.9920E+00,.7483E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9996E+00,.9920E+00,.7479E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9996E+00,.9920E+00,.7476E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9996E+00,.9920E+00,.7473E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9996E+00,.9920E+00,.7471E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9996E+00,.9920E+00,.7468E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9996E+00,.9920E+00,.7465E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9996E+00,.9920E+00,.7463E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9996E+00,.9920E+00,.7461E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9996E+00,.9920E+00,.7458E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9996E+00,.9920E+00,.7456E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9996E+00,.9920E+00,.7454E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9996E+00,.9920E+00,.7452E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9996E+00,.9920E+00,.7451E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9996E+00,.9920E+00,.7449E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9996E+00,.9920E+00,.7448E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9996E+00,.9920E+00,.7446E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9996E+00,.9920E+00,.7445E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9996E+00,.9920E+00,.7444E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9997E+00,.9920E+00,.7442E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9997E+00,.9920E+00,.7441E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9997E+00,.9920E+00,.7440E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9997E+00,.9920E+00,.7440E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9997E+00,.9920E+00,.7440E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9997E+00,.9920E+00,.7440E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9997E+00,.9920E+00,.7440E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9997E+00,.9920E+00,.7440E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9997E+00,.9920E+00,.7440E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9997E+00,.9919E+00,.7442E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9997E+00,.9919E+00,.7444E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9997E+00,.9919E+00,.7446E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9997E+00,.9918E+00,.7449E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9997E+00,.9918E+00,.7452E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9997E+00,.9918E+00,.7457E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9997E+00,.9918E+00,.7462E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9997E+00,.9917E+00,.7468E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9997E+00,.9916E+00,.7476E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9998E+00,.9916E+00,.7484E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9998E+00,.9915E+00,.7496E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9998E+00,.9913E+00,.7508E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9998E+00,.9911E+00,.7524E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9998E+00,.9909E+00,.7545E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9998E+00,.9906E+00,.7569E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9998E+00,.9901E+00,.7602E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9998E+00,.9891E+00,.7637E+00,& - .1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9998E+00,.9871E+00,.7676E+00/ - data (((w0(ai,k,nh),ai= 6, 6),k=1,11),nh=0,99)/ & - .9986E+00,.9986E+00,.9986E+00,.9988E+00,.9995E+00,.9998E+00,.9999E+00,.1000E+01,.9918E+00,.9603E+00,.9159E+00,& - .9986E+00,.9986E+00,.9986E+00,.9988E+00,.9995E+00,.9998E+00,.9999E+00,.1000E+01,.9919E+00,.9604E+00,.9077E+00,& - .9987E+00,.9987E+00,.9987E+00,.9989E+00,.9995E+00,.9998E+00,.9999E+00,.1000E+01,.9921E+00,.9606E+00,.8995E+00,& - .9987E+00,.9987E+00,.9987E+00,.9989E+00,.9996E+00,.9998E+00,.9999E+00,.1000E+01,.9922E+00,.9607E+00,.8913E+00,& - .9988E+00,.9988E+00,.9988E+00,.9990E+00,.9996E+00,.9998E+00,.9999E+00,.1000E+01,.9924E+00,.9609E+00,.8831E+00,& - .9988E+00,.9988E+00,.9988E+00,.9990E+00,.9996E+00,.9998E+00,.9999E+00,.1000E+01,.9925E+00,.9610E+00,.8749E+00,& - .9988E+00,.9988E+00,.9988E+00,.9990E+00,.9996E+00,.9998E+00,.9999E+00,.1000E+01,.9927E+00,.9613E+00,.8701E+00,& - .9988E+00,.9988E+00,.9988E+00,.9990E+00,.9996E+00,.9998E+00,.9999E+00,.1000E+01,.9928E+00,.9615E+00,.8652E+00,& - .9989E+00,.9989E+00,.9989E+00,.9991E+00,.9996E+00,.9999E+00,.1000E+01,.1000E+01,.9930E+00,.9618E+00,.8604E+00,& - .9989E+00,.9989E+00,.9989E+00,.9991E+00,.9996E+00,.9999E+00,.1000E+01,.1000E+01,.9931E+00,.9620E+00,.8555E+00,& - .9989E+00,.9989E+00,.9989E+00,.9991E+00,.9996E+00,.9999E+00,.1000E+01,.1000E+01,.9933E+00,.9623E+00,.8507E+00,& - .9989E+00,.9989E+00,.9989E+00,.9991E+00,.9996E+00,.9999E+00,.1000E+01,.1000E+01,.9935E+00,.9625E+00,.8471E+00,& - .9989E+00,.9989E+00,.9989E+00,.9991E+00,.9996E+00,.9999E+00,.1000E+01,.1000E+01,.9937E+00,.9627E+00,.8434E+00,& - .9990E+00,.9990E+00,.9990E+00,.9992E+00,.9997E+00,.9999E+00,.1000E+01,.1000E+01,.9939E+00,.9628E+00,.8398E+00,& - .9990E+00,.9990E+00,.9990E+00,.9992E+00,.9997E+00,.9999E+00,.1000E+01,.1000E+01,.9941E+00,.9630E+00,.8361E+00,& - .9990E+00,.9990E+00,.9990E+00,.9992E+00,.9997E+00,.9999E+00,.1000E+01,.1000E+01,.9943E+00,.9632E+00,.8325E+00,& - .9990E+00,.9990E+00,.9990E+00,.9992E+00,.9997E+00,.9999E+00,.1000E+01,.1000E+01,.9944E+00,.9632E+00,.8296E+00,& - .9990E+00,.9990E+00,.9990E+00,.9992E+00,.9997E+00,.9999E+00,.1000E+01,.1000E+01,.9945E+00,.9631E+00,.8268E+00,& - .9991E+00,.9991E+00,.9991E+00,.9993E+00,.9997E+00,.9999E+00,.1000E+01,.1000E+01,.9946E+00,.9631E+00,.8239E+00,& - .9991E+00,.9991E+00,.9991E+00,.9993E+00,.9997E+00,.9999E+00,.1000E+01,.1000E+01,.9947E+00,.9630E+00,.8211E+00,& - .9991E+00,.9991E+00,.9991E+00,.9993E+00,.9997E+00,.9999E+00,.1000E+01,.1000E+01,.9948E+00,.9630E+00,.8182E+00,& - .9991E+00,.9991E+00,.9991E+00,.9993E+00,.9997E+00,.9999E+00,.1000E+01,.1000E+01,.9949E+00,.9631E+00,.8158E+00,& - .9991E+00,.9991E+00,.9991E+00,.9993E+00,.9997E+00,.9999E+00,.1000E+01,.1000E+01,.9949E+00,.9631E+00,.8134E+00,& - .9992E+00,.9992E+00,.9992E+00,.9993E+00,.9997E+00,.9999E+00,.1000E+01,.1000E+01,.9950E+00,.9632E+00,.8111E+00,& - .9992E+00,.9992E+00,.9992E+00,.9993E+00,.9997E+00,.9999E+00,.1000E+01,.1000E+01,.9950E+00,.9632E+00,.8087E+00,& - .9992E+00,.9992E+00,.9992E+00,.9993E+00,.9997E+00,.9999E+00,.1000E+01,.1000E+01,.9951E+00,.9633E+00,.8063E+00,& - .9992E+00,.9992E+00,.9992E+00,.9993E+00,.9997E+00,.9999E+00,.1000E+01,.1000E+01,.9952E+00,.9633E+00,.8042E+00,& - .9992E+00,.9992E+00,.9992E+00,.9993E+00,.9997E+00,.9999E+00,.1000E+01,.1000E+01,.9953E+00,.9633E+00,.8022E+00,& - .9993E+00,.9993E+00,.9993E+00,.9994E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9954E+00,.9632E+00,.8001E+00,& - .9993E+00,.9993E+00,.9993E+00,.9994E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9955E+00,.9632E+00,.7981E+00,& - .9993E+00,.9993E+00,.9993E+00,.9994E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9956E+00,.9632E+00,.7960E+00,& - .9993E+00,.9993E+00,.9993E+00,.9994E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9956E+00,.9631E+00,.7943E+00,& - .9993E+00,.9993E+00,.9993E+00,.9994E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9957E+00,.9630E+00,.7926E+00,& - .9993E+00,.9993E+00,.9993E+00,.9994E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9957E+00,.9629E+00,.7908E+00,& - .9993E+00,.9993E+00,.9993E+00,.9994E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9958E+00,.9628E+00,.7891E+00,& - .9993E+00,.9993E+00,.9993E+00,.9994E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9958E+00,.9627E+00,.7874E+00,& - .9993E+00,.9993E+00,.9993E+00,.9994E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9959E+00,.9628E+00,.7858E+00,& - .9993E+00,.9993E+00,.9993E+00,.9994E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9960E+00,.9629E+00,.7842E+00,& - .9994E+00,.9994E+00,.9994E+00,.9995E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9960E+00,.9629E+00,.7825E+00,& - .9994E+00,.9994E+00,.9994E+00,.9995E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9961E+00,.9630E+00,.7809E+00,& - .9994E+00,.9994E+00,.9994E+00,.9995E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9962E+00,.9631E+00,.7793E+00,& - .9994E+00,.9994E+00,.9994E+00,.9995E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9963E+00,.9629E+00,.7779E+00,& - .9994E+00,.9994E+00,.9994E+00,.9995E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9963E+00,.9628E+00,.7765E+00,& - .9995E+00,.9995E+00,.9995E+00,.9996E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9964E+00,.9626E+00,.7751E+00,& - .9995E+00,.9995E+00,.9995E+00,.9996E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9964E+00,.9625E+00,.7737E+00,& - .9995E+00,.9995E+00,.9995E+00,.9996E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9965E+00,.9623E+00,.7723E+00,& - .9995E+00,.9995E+00,.9995E+00,.9996E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9965E+00,.9622E+00,.7710E+00,& - .9995E+00,.9995E+00,.9995E+00,.9996E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9966E+00,.9621E+00,.7697E+00,& - .9995E+00,.9995E+00,.9995E+00,.9996E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9966E+00,.9619E+00,.7684E+00,& - .9995E+00,.9995E+00,.9995E+00,.9996E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9967E+00,.9618E+00,.7671E+00,& - .9995E+00,.9995E+00,.9995E+00,.9996E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9967E+00,.9617E+00,.7658E+00,& - .9995E+00,.9995E+00,.9995E+00,.9996E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9967E+00,.9616E+00,.7648E+00,& - .9995E+00,.9995E+00,.9995E+00,.9996E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9968E+00,.9615E+00,.7639E+00,& - .9995E+00,.9995E+00,.9995E+00,.9996E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9968E+00,.9613E+00,.7629E+00,& - .9995E+00,.9995E+00,.9995E+00,.9996E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9969E+00,.9612E+00,.7620E+00,& - .9995E+00,.9995E+00,.9995E+00,.9996E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9969E+00,.9611E+00,.7610E+00,& - .9995E+00,.9995E+00,.9995E+00,.9996E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9969E+00,.9611E+00,.7601E+00,& - .9995E+00,.9995E+00,.9995E+00,.9996E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9969E+00,.9611E+00,.7592E+00,& - .9995E+00,.9995E+00,.9995E+00,.9996E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9970E+00,.9611E+00,.7584E+00,& - .9995E+00,.9995E+00,.9995E+00,.9996E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9970E+00,.9611E+00,.7575E+00,& - .9995E+00,.9995E+00,.9995E+00,.9996E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9970E+00,.9611E+00,.7566E+00,& - .9995E+00,.9995E+00,.9995E+00,.9996E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9971E+00,.9610E+00,.7557E+00,& - .9995E+00,.9995E+00,.9995E+00,.9996E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9971E+00,.9610E+00,.7549E+00,& - .9996E+00,.9996E+00,.9996E+00,.9997E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9972E+00,.9609E+00,.7540E+00,& - .9996E+00,.9996E+00,.9996E+00,.9997E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9972E+00,.9609E+00,.7532E+00,& - .9996E+00,.9996E+00,.9996E+00,.9997E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9973E+00,.9608E+00,.7523E+00,& - .9996E+00,.9996E+00,.9996E+00,.9997E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9973E+00,.9606E+00,.7515E+00,& - .9996E+00,.9996E+00,.9996E+00,.9997E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.9973E+00,.9605E+00,.7507E+00,& - .9996E+00,.9996E+00,.9996E+00,.9997E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9973E+00,.9603E+00,.7498E+00,& - .9996E+00,.9996E+00,.9996E+00,.9997E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9973E+00,.9602E+00,.7490E+00,& - .9996E+00,.9996E+00,.9996E+00,.9997E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9973E+00,.9600E+00,.7482E+00,& - .9996E+00,.9996E+00,.9996E+00,.9997E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9974E+00,.9599E+00,.7471E+00,& - .9996E+00,.9996E+00,.9996E+00,.9997E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9974E+00,.9598E+00,.7460E+00,& - .9996E+00,.9996E+00,.9996E+00,.9997E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9975E+00,.9597E+00,.7449E+00,& - .9996E+00,.9996E+00,.9996E+00,.9997E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9975E+00,.9596E+00,.7438E+00,& - .9996E+00,.9996E+00,.9996E+00,.9997E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9976E+00,.9595E+00,.7427E+00,& - .9996E+00,.9996E+00,.9996E+00,.9997E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9976E+00,.9591E+00,.7412E+00,& - .9996E+00,.9996E+00,.9996E+00,.9997E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9976E+00,.9588E+00,.7396E+00,& - .9997E+00,.9997E+00,.9997E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9976E+00,.9584E+00,.7381E+00,& - .9997E+00,.9997E+00,.9997E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9976E+00,.9581E+00,.7365E+00,& - .9997E+00,.9997E+00,.9997E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9976E+00,.9577E+00,.7350E+00,& - .9997E+00,.9997E+00,.9997E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9976E+00,.9574E+00,.7336E+00,& - .9997E+00,.9997E+00,.9997E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9979E+00,.9570E+00,.7313E+00,& - .9997E+00,.9997E+00,.9997E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9979E+00,.9564E+00,.7292E+00,& - .9997E+00,.9997E+00,.9997E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9979E+00,.9557E+00,.7272E+00,& - .9997E+00,.9997E+00,.9997E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9979E+00,.9554E+00,.7246E+00,& - .9997E+00,.9997E+00,.9997E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9980E+00,.9551E+00,.7223E+00,& - .9997E+00,.9997E+00,.9997E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9980E+00,.9544E+00,.7200E+00,& - .9997E+00,.9997E+00,.9997E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9981E+00,.9541E+00,.7178E+00,& - .9997E+00,.9997E+00,.9997E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9983E+00,.9531E+00,.7152E+00,& - .9998E+00,.9998E+00,.9998E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9983E+00,.9530E+00,.7121E+00,& - .9998E+00,.9998E+00,.9998E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9982E+00,.9514E+00,.7086E+00,& - .9998E+00,.9998E+00,.9998E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9984E+00,.9505E+00,.7050E+00,& - .9998E+00,.9998E+00,.9998E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9985E+00,.9493E+00,.6998E+00,& - .9998E+00,.9998E+00,.9998E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9985E+00,.9475E+00,.6943E+00,& - .9998E+00,.9998E+00,.9998E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9986E+00,.9454E+00,.6877E+00,& - .9998E+00,.9998E+00,.9998E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.9987E+00,.9425E+00,.6790E+00,& - .9998E+00,.9998E+00,.9998E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9988E+00,.9382E+00,.6688E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9988E+00,.9321E+00,.6536E+00,& - .9999E+00,.9999E+00,.9999E+00,.9999E+00,.1000E+01,.1000E+01,.1000E+01,.1000E+01,.9988E+00,.9191E+00,.6286E+00/ - data (((w0(ai,k,nh),ai= 7, 7),k=1,11),nh=0,99)/ & - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00,& - .9486E+00,.9486E+00,.9486E+00,.9515E+00,.9599E+00,.9695E+00,.9736E+00,.9900E+00,.9919E+00,.9666E+00,.3748E+00/ - data (((w0(ai,k,nh),ai= 8, 8),k=1,11),nh=0,99)/ & - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00,& - .9265E+00,.9265E+00,.9265E+00,.9314E+00,.9452E+00,.9594E+00,.9655E+00,.9888E+00,.9934E+00,.9823E+00,.5308E+00/ - data (((w0(ai,k,nh),ai= 9, 9),k=1,11),nh=0,99)/ & - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00,& - .8742E+00,.8742E+00,.8742E+00,.8831E+00,.9086E+00,.9327E+00,.9430E+00,.9827E+00,.9927E+00,.9874E+00,.6754E+00/ - data (((w0(ai,k,nh),ai=10,10),k=1,11),nh=0,99)/ & - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00,& - .8106E+00,.8106E+00,.8106E+00,.8216E+00,.8530E+00,.8887E+00,.9040E+00,.9707E+00,.9893E+00,.9869E+00,.7531E+00/ - data (((w0(ai,k,nh),ai=11,11),k=1,11),nh=0,99)/ & - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00,& - .7368E+00,.7368E+00,.7368E+00,.7498E+00,.7869E+00,.8322E+00,.8516E+00,.9507E+00,.9818E+00,.9823E+00,.7944E+00/ - data (((w0(ai,k,nh),ai=12,12),k=1,11),nh=0,99)/ & - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00,& - .6696E+00,.6696E+00,.6696E+00,.6818E+00,.7165E+00,.7670E+00,.7886E+00,.9227E+00,.9689E+00,.9717E+00,.8124E+00/ - data (((w0(ai,k,nh),ai=13,13),k=1,11),nh=0,99)/ & - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00,& - .6056E+00,.6056E+00,.6056E+00,.6148E+00,.6411E+00,.6883E+00,.7085E+00,.8768E+00,.9458E+00,.9475E+00,.8099E+00/ - data (((w0(ai,k,nh),ai=14,14),k=1,11),nh=0,99)/ & - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00,& - .5693E+00,.5693E+00,.5693E+00,.5748E+00,.5906E+00,.6253E+00,.6402E+00,.8208E+00,.9129E+00,.9156E+00,.7860E+00/ - data (((g(ai,k,nh),ai= 1, 1),k=1,11),nh=0,99)/ & - .7011E+00,.7011E+00,.7011E+00,.7029E+00,.7082E+00,.7144E+00,.7171E+00,.7149E+00,.6665E+00,.5632E+00,.2436E+00,& - .7031E+00,.7031E+00,.7031E+00,.7049E+00,.7103E+00,.7165E+00,.7192E+00,.7165E+00,.6684E+00,.5654E+00,.2458E+00,& - .7051E+00,.7051E+00,.7051E+00,.7069E+00,.7124E+00,.7186E+00,.7213E+00,.7182E+00,.6704E+00,.5675E+00,.2479E+00,& - .7070E+00,.7070E+00,.7070E+00,.7090E+00,.7144E+00,.7206E+00,.7233E+00,.7198E+00,.6723E+00,.5697E+00,.2501E+00,& - .7090E+00,.7090E+00,.7090E+00,.7110E+00,.7165E+00,.7227E+00,.7254E+00,.7215E+00,.6743E+00,.5718E+00,.2522E+00,& - .7110E+00,.7110E+00,.7110E+00,.7130E+00,.7186E+00,.7248E+00,.7275E+00,.7231E+00,.6762E+00,.5740E+00,.2544E+00,& - .7112E+00,.7112E+00,.7112E+00,.7136E+00,.7202E+00,.7263E+00,.7290E+00,.7246E+00,.6780E+00,.5760E+00,.2565E+00,& - .7114E+00,.7114E+00,.7114E+00,.7142E+00,.7219E+00,.7279E+00,.7305E+00,.7261E+00,.6798E+00,.5780E+00,.2586E+00,& - .7117E+00,.7117E+00,.7117E+00,.7147E+00,.7235E+00,.7294E+00,.7319E+00,.7277E+00,.6815E+00,.5801E+00,.2607E+00,& - .7119E+00,.7119E+00,.7119E+00,.7153E+00,.7252E+00,.7310E+00,.7334E+00,.7292E+00,.6833E+00,.5821E+00,.2628E+00,& - .7121E+00,.7121E+00,.7121E+00,.7159E+00,.7268E+00,.7325E+00,.7349E+00,.7307E+00,.6851E+00,.5841E+00,.2649E+00,& - .7143E+00,.7143E+00,.7143E+00,.7177E+00,.7274E+00,.7333E+00,.7358E+00,.7321E+00,.6867E+00,.5860E+00,.2669E+00,& - .7166E+00,.7166E+00,.7166E+00,.7195E+00,.7280E+00,.7342E+00,.7368E+00,.7335E+00,.6883E+00,.5879E+00,.2688E+00,& - .7188E+00,.7188E+00,.7188E+00,.7214E+00,.7286E+00,.7350E+00,.7377E+00,.7348E+00,.6898E+00,.5897E+00,.2708E+00,& - .7211E+00,.7211E+00,.7211E+00,.7232E+00,.7292E+00,.7359E+00,.7387E+00,.7362E+00,.6914E+00,.5916E+00,.2727E+00,& - .7233E+00,.7233E+00,.7233E+00,.7250E+00,.7298E+00,.7367E+00,.7396E+00,.7376E+00,.6930E+00,.5935E+00,.2747E+00,& - .7245E+00,.7245E+00,.7245E+00,.7265E+00,.7320E+00,.7386E+00,.7414E+00,.7387E+00,.6945E+00,.5953E+00,.2767E+00,& - .7258E+00,.7258E+00,.7258E+00,.7280E+00,.7342E+00,.7405E+00,.7432E+00,.7397E+00,.6959E+00,.5971E+00,.2786E+00,& - .7270E+00,.7270E+00,.7270E+00,.7294E+00,.7363E+00,.7424E+00,.7450E+00,.7408E+00,.6974E+00,.5990E+00,.2806E+00,& - .7283E+00,.7283E+00,.7283E+00,.7309E+00,.7385E+00,.7443E+00,.7468E+00,.7418E+00,.6988E+00,.6008E+00,.2825E+00,& - .7295E+00,.7295E+00,.7295E+00,.7324E+00,.7407E+00,.7462E+00,.7486E+00,.7429E+00,.7003E+00,.6026E+00,.2845E+00,& - .7300E+00,.7300E+00,.7300E+00,.7329E+00,.7412E+00,.7465E+00,.7489E+00,.7441E+00,.7017E+00,.6043E+00,.2864E+00,& - .7305E+00,.7305E+00,.7305E+00,.7334E+00,.7416E+00,.7469E+00,.7492E+00,.7454E+00,.7031E+00,.6061E+00,.2883E+00,& - .7310E+00,.7310E+00,.7310E+00,.7339E+00,.7421E+00,.7472E+00,.7494E+00,.7466E+00,.7045E+00,.6078E+00,.2903E+00,& - .7315E+00,.7315E+00,.7315E+00,.7344E+00,.7425E+00,.7476E+00,.7497E+00,.7479E+00,.7059E+00,.6096E+00,.2922E+00,& - .7320E+00,.7320E+00,.7320E+00,.7349E+00,.7430E+00,.7479E+00,.7500E+00,.7491E+00,.7073E+00,.6113E+00,.2941E+00,& - .7340E+00,.7340E+00,.7340E+00,.7366E+00,.7439E+00,.7490E+00,.7512E+00,.7500E+00,.7085E+00,.6129E+00,.2960E+00,& - .7359E+00,.7359E+00,.7359E+00,.7383E+00,.7449E+00,.7501E+00,.7524E+00,.7509E+00,.7098E+00,.6146E+00,.2978E+00,& - .7379E+00,.7379E+00,.7379E+00,.7399E+00,.7458E+00,.7513E+00,.7536E+00,.7517E+00,.7110E+00,.6162E+00,.2997E+00,& - .7398E+00,.7398E+00,.7398E+00,.7416E+00,.7468E+00,.7524E+00,.7548E+00,.7526E+00,.7123E+00,.6179E+00,.3015E+00,& - .7418E+00,.7418E+00,.7418E+00,.7433E+00,.7477E+00,.7535E+00,.7560E+00,.7535E+00,.7135E+00,.6195E+00,.3034E+00,& - .7417E+00,.7417E+00,.7417E+00,.7436E+00,.7491E+00,.7546E+00,.7569E+00,.7543E+00,.7147E+00,.6210E+00,.3052E+00,& - .7416E+00,.7416E+00,.7416E+00,.7439E+00,.7505E+00,.7557E+00,.7579E+00,.7550E+00,.7158E+00,.6226E+00,.3070E+00,& - .7416E+00,.7416E+00,.7416E+00,.7442E+00,.7518E+00,.7567E+00,.7588E+00,.7558E+00,.7170E+00,.6241E+00,.3088E+00,& - .7415E+00,.7415E+00,.7415E+00,.7445E+00,.7532E+00,.7578E+00,.7598E+00,.7565E+00,.7181E+00,.6257E+00,.3106E+00,& - .7414E+00,.7414E+00,.7414E+00,.7448E+00,.7546E+00,.7589E+00,.7607E+00,.7573E+00,.7193E+00,.6272E+00,.3124E+00,& - .7420E+00,.7420E+00,.7420E+00,.7452E+00,.7543E+00,.7587E+00,.7605E+00,.7582E+00,.7204E+00,.6286E+00,.3141E+00,& - .7427E+00,.7427E+00,.7427E+00,.7456E+00,.7540E+00,.7584E+00,.7603E+00,.7592E+00,.7214E+00,.6301E+00,.3158E+00,& - .7433E+00,.7433E+00,.7433E+00,.7460E+00,.7536E+00,.7582E+00,.7601E+00,.7601E+00,.7225E+00,.6315E+00,.3175E+00,& - .7440E+00,.7440E+00,.7440E+00,.7464E+00,.7533E+00,.7579E+00,.7599E+00,.7611E+00,.7235E+00,.6330E+00,.3192E+00,& - .7446E+00,.7446E+00,.7446E+00,.7468E+00,.7530E+00,.7577E+00,.7597E+00,.7620E+00,.7246E+00,.6344E+00,.3209E+00,& - .7460E+00,.7460E+00,.7460E+00,.7481E+00,.7541E+00,.7590E+00,.7610E+00,.7626E+00,.7256E+00,.6358E+00,.3226E+00,& - .7474E+00,.7474E+00,.7474E+00,.7494E+00,.7551E+00,.7602E+00,.7624E+00,.7631E+00,.7266E+00,.6372E+00,.3243E+00,& - .7489E+00,.7489E+00,.7489E+00,.7508E+00,.7562E+00,.7615E+00,.7637E+00,.7637E+00,.7275E+00,.6386E+00,.3261E+00,& - .7503E+00,.7503E+00,.7503E+00,.7521E+00,.7572E+00,.7627E+00,.7651E+00,.7642E+00,.7285E+00,.6400E+00,.3278E+00,& - .7517E+00,.7517E+00,.7517E+00,.7534E+00,.7583E+00,.7640E+00,.7664E+00,.7648E+00,.7295E+00,.6414E+00,.3295E+00,& - .7513E+00,.7513E+00,.7513E+00,.7533E+00,.7593E+00,.7647E+00,.7670E+00,.7654E+00,.7304E+00,.6427E+00,.3312E+00,& - .7509E+00,.7509E+00,.7509E+00,.7533E+00,.7603E+00,.7654E+00,.7675E+00,.7660E+00,.7313E+00,.6440E+00,.3328E+00,& - .7504E+00,.7504E+00,.7504E+00,.7532E+00,.7612E+00,.7660E+00,.7681E+00,.7665E+00,.7323E+00,.6454E+00,.3345E+00,& - .7500E+00,.7500E+00,.7500E+00,.7532E+00,.7622E+00,.7667E+00,.7686E+00,.7671E+00,.7332E+00,.6467E+00,.3361E+00,& - .7496E+00,.7496E+00,.7496E+00,.7531E+00,.7632E+00,.7674E+00,.7692E+00,.7677E+00,.7341E+00,.6480E+00,.3378E+00,& - .7499E+00,.7499E+00,.7499E+00,.7532E+00,.7628E+00,.7670E+00,.7688E+00,.7684E+00,.7349E+00,.6492E+00,.3393E+00,& - .7502E+00,.7502E+00,.7502E+00,.7533E+00,.7624E+00,.7666E+00,.7684E+00,.7691E+00,.7357E+00,.6504E+00,.3408E+00,& - .7504E+00,.7504E+00,.7504E+00,.7535E+00,.7621E+00,.7663E+00,.7681E+00,.7699E+00,.7366E+00,.6516E+00,.3423E+00,& - .7507E+00,.7507E+00,.7507E+00,.7536E+00,.7617E+00,.7659E+00,.7677E+00,.7706E+00,.7374E+00,.6528E+00,.3438E+00,& - .7510E+00,.7510E+00,.7510E+00,.7537E+00,.7613E+00,.7655E+00,.7673E+00,.7713E+00,.7382E+00,.6540E+00,.3453E+00,& - .7524E+00,.7524E+00,.7524E+00,.7548E+00,.7616E+00,.7663E+00,.7683E+00,.7717E+00,.7389E+00,.6551E+00,.3467E+00,& - .7538E+00,.7538E+00,.7538E+00,.7560E+00,.7620E+00,.7671E+00,.7693E+00,.7720E+00,.7396E+00,.6562E+00,.3481E+00,& - .7553E+00,.7553E+00,.7553E+00,.7571E+00,.7623E+00,.7679E+00,.7703E+00,.7724E+00,.7403E+00,.6572E+00,.3496E+00,& - .7567E+00,.7567E+00,.7567E+00,.7583E+00,.7627E+00,.7687E+00,.7713E+00,.7727E+00,.7410E+00,.6583E+00,.3510E+00,& - .7581E+00,.7581E+00,.7581E+00,.7594E+00,.7630E+00,.7695E+00,.7723E+00,.7731E+00,.7417E+00,.6594E+00,.3524E+00,& - .7575E+00,.7575E+00,.7575E+00,.7592E+00,.7642E+00,.7703E+00,.7729E+00,.7734E+00,.7424E+00,.6605E+00,.3538E+00,& - .7568E+00,.7568E+00,.7568E+00,.7591E+00,.7655E+00,.7711E+00,.7736E+00,.7738E+00,.7431E+00,.6616E+00,.3553E+00,& - .7562E+00,.7562E+00,.7562E+00,.7589E+00,.7667E+00,.7720E+00,.7742E+00,.7741E+00,.7437E+00,.6626E+00,.3567E+00,& - .7555E+00,.7555E+00,.7555E+00,.7588E+00,.7680E+00,.7728E+00,.7749E+00,.7745E+00,.7444E+00,.6637E+00,.3582E+00,& - .7549E+00,.7549E+00,.7549E+00,.7586E+00,.7692E+00,.7736E+00,.7755E+00,.7748E+00,.7451E+00,.6648E+00,.3596E+00,& - .7541E+00,.7541E+00,.7541E+00,.7579E+00,.7687E+00,.7733E+00,.7752E+00,.7754E+00,.7458E+00,.6658E+00,.3610E+00,& - .7533E+00,.7533E+00,.7533E+00,.7572E+00,.7682E+00,.7730E+00,.7750E+00,.7760E+00,.7465E+00,.6669E+00,.3624E+00,& - .7526E+00,.7526E+00,.7526E+00,.7565E+00,.7677E+00,.7726E+00,.7747E+00,.7765E+00,.7471E+00,.6679E+00,.3638E+00,& - .7518E+00,.7518E+00,.7518E+00,.7558E+00,.7672E+00,.7723E+00,.7745E+00,.7771E+00,.7478E+00,.6690E+00,.3652E+00,& - .7510E+00,.7510E+00,.7510E+00,.7551E+00,.7667E+00,.7720E+00,.7742E+00,.7777E+00,.7485E+00,.6700E+00,.3666E+00,& - .7534E+00,.7534E+00,.7534E+00,.7570E+00,.7672E+00,.7727E+00,.7750E+00,.7782E+00,.7495E+00,.6716E+00,.3688E+00,& - .7559E+00,.7559E+00,.7559E+00,.7590E+00,.7678E+00,.7734E+00,.7757E+00,.7787E+00,.7505E+00,.6732E+00,.3711E+00,& - .7583E+00,.7583E+00,.7583E+00,.7609E+00,.7683E+00,.7740E+00,.7765E+00,.7792E+00,.7515E+00,.6749E+00,.3733E+00,& - .7608E+00,.7608E+00,.7608E+00,.7629E+00,.7689E+00,.7747E+00,.7772E+00,.7797E+00,.7525E+00,.6765E+00,.3756E+00,& - .7632E+00,.7632E+00,.7632E+00,.7648E+00,.7694E+00,.7754E+00,.7780E+00,.7802E+00,.7535E+00,.6781E+00,.3778E+00,& - .7620E+00,.7620E+00,.7620E+00,.7641E+00,.7702E+00,.7757E+00,.7781E+00,.7807E+00,.7544E+00,.6796E+00,.3800E+00,& - .7608E+00,.7608E+00,.7608E+00,.7634E+00,.7710E+00,.7760E+00,.7781E+00,.7813E+00,.7553E+00,.6811E+00,.3822E+00,& - .7596E+00,.7596E+00,.7596E+00,.7628E+00,.7717E+00,.7762E+00,.7782E+00,.7818E+00,.7563E+00,.6827E+00,.3843E+00,& - .7584E+00,.7584E+00,.7584E+00,.7621E+00,.7725E+00,.7765E+00,.7782E+00,.7824E+00,.7572E+00,.6842E+00,.3865E+00,& - .7572E+00,.7572E+00,.7572E+00,.7614E+00,.7733E+00,.7768E+00,.7783E+00,.7829E+00,.7581E+00,.6857E+00,.3887E+00,& - .7552E+00,.7552E+00,.7552E+00,.7592E+00,.7706E+00,.7761E+00,.7784E+00,.7838E+00,.7591E+00,.6874E+00,.3911E+00,& - .7606E+00,.7606E+00,.7606E+00,.7634E+00,.7715E+00,.7757E+00,.7775E+00,.7845E+00,.7601E+00,.6890E+00,.3934E+00,& - .7636E+00,.7636E+00,.7636E+00,.7650E+00,.7691E+00,.7743E+00,.7765E+00,.7851E+00,.7610E+00,.6906E+00,.3957E+00,& - .7645E+00,.7645E+00,.7645E+00,.7659E+00,.7699E+00,.7765E+00,.7793E+00,.7852E+00,.7622E+00,.6928E+00,.3992E+00,& - .7663E+00,.7663E+00,.7663E+00,.7683E+00,.7739E+00,.7798E+00,.7823E+00,.7855E+00,.7635E+00,.6951E+00,.4025E+00,& - .7665E+00,.7665E+00,.7665E+00,.7688E+00,.7755E+00,.7815E+00,.7841E+00,.7858E+00,.7647E+00,.6972E+00,.4059E+00,& - .7644E+00,.7644E+00,.7644E+00,.7676E+00,.7768E+00,.7815E+00,.7835E+00,.7867E+00,.7663E+00,.7001E+00,.4103E+00,& - .7592E+00,.7592E+00,.7592E+00,.7629E+00,.7736E+00,.7788E+00,.7810E+00,.7884E+00,.7680E+00,.7029E+00,.4146E+00,& - .7668E+00,.7668E+00,.7668E+00,.7680E+00,.7713E+00,.7766E+00,.7789E+00,.7895E+00,.7698E+00,.7063E+00,.4199E+00,& - .7693E+00,.7693E+00,.7693E+00,.7709E+00,.7755E+00,.7820E+00,.7848E+00,.7896E+00,.7718E+00,.7102E+00,.4262E+00,& - .7647E+00,.7647E+00,.7647E+00,.7687E+00,.7799E+00,.7838E+00,.7855E+00,.7901E+00,.7736E+00,.7138E+00,.4323E+00,& - .7652E+00,.7652E+00,.7652E+00,.7679E+00,.7755E+00,.7807E+00,.7829E+00,.7924E+00,.7763E+00,.7186E+00,.4401E+00,& - .7724E+00,.7724E+00,.7724E+00,.7734E+00,.7764E+00,.7821E+00,.7846E+00,.7927E+00,.7784E+00,.7231E+00,.4478E+00,& - .7688E+00,.7688E+00,.7688E+00,.7717E+00,.7798E+00,.7846E+00,.7867E+00,.7929E+00,.7808E+00,.7283E+00,.4570E+00,& - .7733E+00,.7733E+00,.7733E+00,.7736E+00,.7745E+00,.7816E+00,.7847E+00,.7948E+00,.7842E+00,.7352E+00,.4693E+00,& - .7681E+00,.7681E+00,.7681E+00,.7717E+00,.7821E+00,.7839E+00,.7846E+00,.7960E+00,.7873E+00,.7421E+00,.4827E+00,& - .7732E+00,.7732E+00,.7732E+00,.7757E+00,.7829E+00,.7870E+00,.7888E+00,.7958E+00,.7906E+00,.7507E+00,.4999E+00,& - .7765E+00,.7765E+00,.7765E+00,.7782E+00,.7832E+00,.7873E+00,.7890E+00,.7969E+00,.7954E+00,.7626E+00,.5253E+00,& - .7815E+00,.7815E+00,.7815E+00,.7826E+00,.7857E+00,.7877E+00,.7886E+00,.7974E+00,.8010E+00,.7804E+00,.5681E+00/ - data (((g(ai,k,nh),ai= 2, 2),k=1,11),nh=0,99)/ & - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5026E+00,.5026E+00,.5026E+00,.4899E+00,.4537E+00,.4320E+00,.4227E+00,.3389E+00,.2333E+00,.1307E+00,.3326E-01,& - .5035E+00,.5035E+00,.5035E+00,.4908E+00,.4546E+00,.4329E+00,.4235E+00,.3396E+00,.2338E+00,.1310E+00,.3332E-01,& - .5044E+00,.5044E+00,.5044E+00,.4917E+00,.4555E+00,.4337E+00,.4244E+00,.3403E+00,.2343E+00,.1312E+00,.3338E-01,& - .5053E+00,.5053E+00,.5053E+00,.4926E+00,.4563E+00,.4346E+00,.4252E+00,.3410E+00,.2347E+00,.1315E+00,.3343E-01,& - .5062E+00,.5062E+00,.5062E+00,.4935E+00,.4572E+00,.4354E+00,.4261E+00,.3417E+00,.2352E+00,.1317E+00,.3349E-01,& - .5071E+00,.5071E+00,.5071E+00,.4944E+00,.4581E+00,.4363E+00,.4269E+00,.3424E+00,.2357E+00,.1320E+00,.3355E-01,& - .5071E+00,.5071E+00,.5071E+00,.4944E+00,.4581E+00,.4363E+00,.4269E+00,.3424E+00,.2357E+00,.1320E+00,.3355E-01,& - .5071E+00,.5071E+00,.5071E+00,.4944E+00,.4581E+00,.4363E+00,.4269E+00,.3424E+00,.2357E+00,.1320E+00,.3355E-01,& - .5071E+00,.5071E+00,.5071E+00,.4944E+00,.4581E+00,.4363E+00,.4269E+00,.3424E+00,.2357E+00,.1320E+00,.3355E-01,& - .5071E+00,.5071E+00,.5071E+00,.4944E+00,.4581E+00,.4363E+00,.4269E+00,.3424E+00,.2357E+00,.1320E+00,.3355E-01,& - .5071E+00,.5071E+00,.5071E+00,.4944E+00,.4581E+00,.4363E+00,.4269E+00,.3424E+00,.2357E+00,.1320E+00,.3355E-01,& - .5097E+00,.5097E+00,.5097E+00,.4970E+00,.4607E+00,.4388E+00,.4294E+00,.3445E+00,.2371E+00,.1328E+00,.3373E-01,& - .5123E+00,.5123E+00,.5123E+00,.4996E+00,.4633E+00,.4413E+00,.4319E+00,.3465E+00,.2385E+00,.1336E+00,.3390E-01,& - .5149E+00,.5149E+00,.5149E+00,.5021E+00,.4658E+00,.4438E+00,.4343E+00,.3486E+00,.2400E+00,.1343E+00,.3408E-01,& - .5175E+00,.5175E+00,.5175E+00,.5047E+00,.4684E+00,.4463E+00,.4368E+00,.3506E+00,.2414E+00,.1351E+00,.3425E-01,& - .5201E+00,.5201E+00,.5201E+00,.5073E+00,.4710E+00,.4488E+00,.4393E+00,.3527E+00,.2428E+00,.1359E+00,.3443E-01,& - .5263E+00,.5263E+00,.5263E+00,.5136E+00,.4773E+00,.4550E+00,.4454E+00,.3579E+00,.2465E+00,.1379E+00,.3492E-01,& - .5326E+00,.5326E+00,.5326E+00,.5198E+00,.4836E+00,.4611E+00,.4515E+00,.3631E+00,.2502E+00,.1400E+00,.3540E-01,& - .5388E+00,.5388E+00,.5388E+00,.5261E+00,.4898E+00,.4673E+00,.4576E+00,.3682E+00,.2538E+00,.1420E+00,.3589E-01,& - .5451E+00,.5451E+00,.5451E+00,.5323E+00,.4961E+00,.4734E+00,.4637E+00,.3734E+00,.2575E+00,.1441E+00,.3637E-01,& - .5513E+00,.5513E+00,.5513E+00,.5386E+00,.5024E+00,.4796E+00,.4698E+00,.3786E+00,.2612E+00,.1461E+00,.3686E-01,& - .5579E+00,.5579E+00,.5579E+00,.5453E+00,.5092E+00,.4863E+00,.4765E+00,.3845E+00,.2656E+00,.1487E+00,.3751E-01,& - .5645E+00,.5645E+00,.5645E+00,.5519E+00,.5160E+00,.4930E+00,.4832E+00,.3904E+00,.2699E+00,.1513E+00,.3815E-01,& - .5712E+00,.5712E+00,.5712E+00,.5586E+00,.5227E+00,.4998E+00,.4899E+00,.3962E+00,.2743E+00,.1538E+00,.3880E-01,& - .5778E+00,.5778E+00,.5778E+00,.5652E+00,.5295E+00,.5065E+00,.4966E+00,.4021E+00,.2786E+00,.1564E+00,.3944E-01,& - .5844E+00,.5844E+00,.5844E+00,.5719E+00,.5363E+00,.5132E+00,.5033E+00,.4080E+00,.2830E+00,.1590E+00,.4009E-01,& - .5932E+00,.5932E+00,.5932E+00,.5808E+00,.5455E+00,.5224E+00,.5125E+00,.4162E+00,.2893E+00,.1628E+00,.4109E-01,& - .5988E+00,.5988E+00,.5988E+00,.5865E+00,.5514E+00,.5282E+00,.5183E+00,.4216E+00,.2935E+00,.1653E+00,.4178E-01,& - .6069E+00,.6069E+00,.6069E+00,.5947E+00,.5599E+00,.5368E+00,.5269E+00,.4294E+00,.2997E+00,.1691E+00,.4281E-01,& - .6120E+00,.6120E+00,.6120E+00,.5999E+00,.5653E+00,.5423E+00,.5324E+00,.4346E+00,.3037E+00,.1717E+00,.4352E-01,& - .6193E+00,.6193E+00,.6193E+00,.6073E+00,.5732E+00,.5502E+00,.5403E+00,.4421E+00,.3097E+00,.1755E+00,.4458E-01,& - .6262E+00,.6262E+00,.6262E+00,.6144E+00,.5807E+00,.5577E+00,.5479E+00,.4493E+00,.3156E+00,.1793E+00,.4565E-01,& - .6307E+00,.6307E+00,.6307E+00,.6189E+00,.5855E+00,.5627E+00,.5529E+00,.4540E+00,.3195E+00,.1818E+00,.4638E-01,& - .6370E+00,.6370E+00,.6370E+00,.6254E+00,.5924E+00,.5697E+00,.5600E+00,.4610E+00,.3253E+00,.1856E+00,.4749E-01,& - .6411E+00,.6411E+00,.6411E+00,.6296E+00,.5969E+00,.5743E+00,.5646E+00,.4655E+00,.3290E+00,.1881E+00,.4823E-01,& - .6469E+00,.6469E+00,.6469E+00,.6356E+00,.6034E+00,.5809E+00,.5713E+00,.4720E+00,.3347E+00,.1919E+00,.4935E-01,& - .6524E+00,.6524E+00,.6524E+00,.6412E+00,.6095E+00,.5872E+00,.5777E+00,.4785E+00,.3402E+00,.1956E+00,.5049E-01,& - .6577E+00,.6577E+00,.6577E+00,.6467E+00,.6154E+00,.5933E+00,.5838E+00,.4847E+00,.3456E+00,.1994E+00,.5163E-01,& - .6627E+00,.6627E+00,.6627E+00,.6519E+00,.6211E+00,.5991E+00,.5897E+00,.4907E+00,.3510E+00,.2031E+00,.5279E-01,& - .6689E+00,.6689E+00,.6689E+00,.6583E+00,.6282E+00,.6066E+00,.5973E+00,.4986E+00,.3580E+00,.2080E+00,.5434E-01,& - .6748E+00,.6748E+00,.6748E+00,.6645E+00,.6350E+00,.6136E+00,.6045E+00,.5061E+00,.3648E+00,.2129E+00,.5592E-01,& - .6816E+00,.6816E+00,.6816E+00,.6716E+00,.6430E+00,.6219E+00,.6129E+00,.5151E+00,.3732E+00,.2190E+00,.5791E-01,& - .6903E+00,.6903E+00,.6903E+00,.6807E+00,.6532E+00,.6327E+00,.6239E+00,.5271E+00,.3845E+00,.2273E+00,.6073E-01,& - .6991E+00,.6991E+00,.6991E+00,.6899E+00,.6638E+00,.6439E+00,.6354E+00,.5399E+00,.3969E+00,.2368E+00,.6400E-01,& - .7171E+00,.7171E+00,.7171E+00,.7090E+00,.6860E+00,.6677E+00,.6599E+00,.5683E+00,.4258E+00,.2598E+00,.7234E-01/ - data (((g(ai,k,nh),ai= 3, 3),k=1,11),nh=0,99)/ & - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00/ - data (((g(ai,k,nh),ai= 4, 4),k=1,11),nh=0,99)/ & - .6863E+00,.6863E+00,.6863E+00,.6784E+00,.6558E+00,.6469E+00,.6431E+00,.6051E+00,.5364E+00,.4244E+00,.1937E+00,& - .6873E+00,.6873E+00,.6873E+00,.6795E+00,.6572E+00,.6484E+00,.6446E+00,.6066E+00,.5377E+00,.4255E+00,.1943E+00,& - .6884E+00,.6884E+00,.6884E+00,.6806E+00,.6586E+00,.6498E+00,.6461E+00,.6081E+00,.5390E+00,.4266E+00,.1949E+00,& - .6894E+00,.6894E+00,.6894E+00,.6818E+00,.6599E+00,.6513E+00,.6475E+00,.6095E+00,.5404E+00,.4278E+00,.1955E+00,& - .6905E+00,.6905E+00,.6905E+00,.6829E+00,.6613E+00,.6527E+00,.6490E+00,.6110E+00,.5417E+00,.4289E+00,.1961E+00,& - .6915E+00,.6915E+00,.6915E+00,.6840E+00,.6627E+00,.6542E+00,.6505E+00,.6125E+00,.5430E+00,.4300E+00,.1967E+00,& - .6925E+00,.6925E+00,.6925E+00,.6850E+00,.6640E+00,.6555E+00,.6518E+00,.6139E+00,.5443E+00,.4311E+00,.1973E+00,& - .6934E+00,.6934E+00,.6934E+00,.6861E+00,.6652E+00,.6567E+00,.6530E+00,.6153E+00,.5456E+00,.4322E+00,.1979E+00,& - .6944E+00,.6944E+00,.6944E+00,.6871E+00,.6665E+00,.6580E+00,.6543E+00,.6166E+00,.5468E+00,.4334E+00,.1986E+00,& - .6953E+00,.6953E+00,.6953E+00,.6882E+00,.6677E+00,.6592E+00,.6555E+00,.6180E+00,.5481E+00,.4345E+00,.1992E+00,& - .6963E+00,.6963E+00,.6963E+00,.6892E+00,.6690E+00,.6605E+00,.6568E+00,.6194E+00,.5494E+00,.4356E+00,.1998E+00,& - .6973E+00,.6973E+00,.6973E+00,.6902E+00,.6701E+00,.6617E+00,.6580E+00,.6207E+00,.5506E+00,.4367E+00,.2004E+00,& - .6982E+00,.6982E+00,.6982E+00,.6912E+00,.6712E+00,.6628E+00,.6592E+00,.6220E+00,.5518E+00,.4378E+00,.2010E+00,& - .6992E+00,.6992E+00,.6992E+00,.6922E+00,.6722E+00,.6640E+00,.6605E+00,.6233E+00,.5531E+00,.4388E+00,.2016E+00,& - .7001E+00,.7001E+00,.7001E+00,.6932E+00,.6733E+00,.6651E+00,.6617E+00,.6246E+00,.5543E+00,.4399E+00,.2022E+00,& - .7011E+00,.7011E+00,.7011E+00,.6942E+00,.6744E+00,.6663E+00,.6629E+00,.6259E+00,.5555E+00,.4410E+00,.2028E+00,& - .7020E+00,.7020E+00,.7020E+00,.6952E+00,.6756E+00,.6676E+00,.6642E+00,.6271E+00,.5567E+00,.4421E+00,.2034E+00,& - .7029E+00,.7029E+00,.7029E+00,.6961E+00,.6767E+00,.6689E+00,.6655E+00,.6283E+00,.5578E+00,.4431E+00,.2040E+00,& - .7038E+00,.7038E+00,.7038E+00,.6971E+00,.6779E+00,.6701E+00,.6669E+00,.6296E+00,.5590E+00,.4442E+00,.2047E+00,& - .7047E+00,.7047E+00,.7047E+00,.6980E+00,.6790E+00,.6714E+00,.6682E+00,.6308E+00,.5601E+00,.4452E+00,.2053E+00,& - .7056E+00,.7056E+00,.7056E+00,.6990E+00,.6802E+00,.6727E+00,.6695E+00,.6320E+00,.5613E+00,.4463E+00,.2059E+00,& - .7064E+00,.7064E+00,.7064E+00,.6999E+00,.6813E+00,.6739E+00,.6707E+00,.6332E+00,.5624E+00,.4473E+00,.2065E+00,& - .7072E+00,.7072E+00,.7072E+00,.7008E+00,.6825E+00,.6750E+00,.6718E+00,.6343E+00,.5636E+00,.4484E+00,.2071E+00,& - .7081E+00,.7081E+00,.7081E+00,.7017E+00,.6836E+00,.6762E+00,.6730E+00,.6355E+00,.5647E+00,.4494E+00,.2077E+00,& - .7089E+00,.7089E+00,.7089E+00,.7026E+00,.6848E+00,.6773E+00,.6741E+00,.6366E+00,.5659E+00,.4505E+00,.2083E+00,& - .7097E+00,.7097E+00,.7097E+00,.7035E+00,.6859E+00,.6785E+00,.6753E+00,.6378E+00,.5670E+00,.4515E+00,.2089E+00,& - .7104E+00,.7104E+00,.7104E+00,.7043E+00,.6869E+00,.6795E+00,.6764E+00,.6389E+00,.5681E+00,.4525E+00,.2095E+00,& - .7111E+00,.7111E+00,.7111E+00,.7051E+00,.6880E+00,.6806E+00,.6774E+00,.6401E+00,.5692E+00,.4535E+00,.2101E+00,& - .7119E+00,.7119E+00,.7119E+00,.7059E+00,.6890E+00,.6816E+00,.6785E+00,.6412E+00,.5703E+00,.4546E+00,.2108E+00,& - .7126E+00,.7126E+00,.7126E+00,.7067E+00,.6901E+00,.6827E+00,.6795E+00,.6424E+00,.5714E+00,.4556E+00,.2114E+00,& - .7133E+00,.7133E+00,.7133E+00,.7075E+00,.6911E+00,.6837E+00,.6806E+00,.6435E+00,.5725E+00,.4566E+00,.2120E+00,& - .7140E+00,.7140E+00,.7140E+00,.7082E+00,.6920E+00,.6846E+00,.6815E+00,.6446E+00,.5736E+00,.4576E+00,.2126E+00,& - .7147E+00,.7147E+00,.7147E+00,.7090E+00,.6929E+00,.6855E+00,.6824E+00,.6457E+00,.5746E+00,.4586E+00,.2132E+00,& - .7153E+00,.7153E+00,.7153E+00,.7097E+00,.6937E+00,.6864E+00,.6833E+00,.6468E+00,.5757E+00,.4597E+00,.2139E+00,& - .7160E+00,.7160E+00,.7160E+00,.7105E+00,.6946E+00,.6873E+00,.6842E+00,.6479E+00,.5767E+00,.4607E+00,.2145E+00,& - .7167E+00,.7167E+00,.7167E+00,.7112E+00,.6955E+00,.6882E+00,.6851E+00,.6490E+00,.5778E+00,.4617E+00,.2151E+00,& - .7174E+00,.7174E+00,.7174E+00,.7119E+00,.6962E+00,.6890E+00,.6860E+00,.6500E+00,.5788E+00,.4627E+00,.2157E+00,& - .7181E+00,.7181E+00,.7181E+00,.7126E+00,.6970E+00,.6898E+00,.6868E+00,.6510E+00,.5798E+00,.4637E+00,.2163E+00,& - .7189E+00,.7189E+00,.7189E+00,.7134E+00,.6977E+00,.6907E+00,.6877E+00,.6520E+00,.5809E+00,.4646E+00,.2170E+00,& - .7196E+00,.7196E+00,.7196E+00,.7141E+00,.6985E+00,.6915E+00,.6885E+00,.6530E+00,.5819E+00,.4656E+00,.2176E+00,& - .7203E+00,.7203E+00,.7203E+00,.7148E+00,.6992E+00,.6923E+00,.6894E+00,.6540E+00,.5829E+00,.4666E+00,.2182E+00,& - .7210E+00,.7210E+00,.7210E+00,.7155E+00,.7000E+00,.6933E+00,.6904E+00,.6549E+00,.5839E+00,.4676E+00,.2188E+00,& - .7217E+00,.7217E+00,.7217E+00,.7162E+00,.7009E+00,.6943E+00,.6915E+00,.6559E+00,.5849E+00,.4685E+00,.2194E+00,& - .7223E+00,.7223E+00,.7223E+00,.7170E+00,.7017E+00,.6952E+00,.6925E+00,.6568E+00,.5858E+00,.4695E+00,.2200E+00,& - .7230E+00,.7230E+00,.7230E+00,.7177E+00,.7026E+00,.6962E+00,.6936E+00,.6578E+00,.5868E+00,.4704E+00,.2206E+00,& - .7237E+00,.7237E+00,.7237E+00,.7184E+00,.7034E+00,.6972E+00,.6946E+00,.6587E+00,.5878E+00,.4714E+00,.2212E+00,& - .7243E+00,.7243E+00,.7243E+00,.7191E+00,.7043E+00,.6981E+00,.6955E+00,.6596E+00,.5888E+00,.4723E+00,.2218E+00,& - .7249E+00,.7249E+00,.7249E+00,.7198E+00,.7052E+00,.6990E+00,.6964E+00,.6605E+00,.5897E+00,.4733E+00,.2224E+00,& - .7255E+00,.7255E+00,.7255E+00,.7204E+00,.7062E+00,.7000E+00,.6973E+00,.6614E+00,.5907E+00,.4742E+00,.2231E+00,& - .7261E+00,.7261E+00,.7261E+00,.7211E+00,.7071E+00,.7009E+00,.6982E+00,.6623E+00,.5916E+00,.4752E+00,.2237E+00,& - .7267E+00,.7267E+00,.7267E+00,.7218E+00,.7080E+00,.7018E+00,.6991E+00,.6632E+00,.5926E+00,.4761E+00,.2243E+00,& - .7273E+00,.7273E+00,.7273E+00,.7225E+00,.7089E+00,.7027E+00,.7000E+00,.6643E+00,.5937E+00,.4772E+00,.2250E+00,& - .7279E+00,.7279E+00,.7279E+00,.7232E+00,.7099E+00,.7036E+00,.7009E+00,.6654E+00,.5948E+00,.4783E+00,.2258E+00,& - .7284E+00,.7284E+00,.7284E+00,.7238E+00,.7108E+00,.7046E+00,.7019E+00,.6664E+00,.5960E+00,.4795E+00,.2265E+00,& - .7290E+00,.7290E+00,.7290E+00,.7245E+00,.7118E+00,.7055E+00,.7028E+00,.6675E+00,.5971E+00,.4806E+00,.2273E+00,& - .7296E+00,.7296E+00,.7296E+00,.7252E+00,.7127E+00,.7064E+00,.7037E+00,.6686E+00,.5982E+00,.4817E+00,.2280E+00,& - .7302E+00,.7302E+00,.7302E+00,.7258E+00,.7134E+00,.7071E+00,.7045E+00,.6696E+00,.5993E+00,.4828E+00,.2287E+00,& - .7307E+00,.7307E+00,.7307E+00,.7264E+00,.7141E+00,.7079E+00,.7052E+00,.6706E+00,.6003E+00,.4839E+00,.2295E+00,& - .7313E+00,.7313E+00,.7313E+00,.7270E+00,.7148E+00,.7086E+00,.7060E+00,.6717E+00,.6014E+00,.4849E+00,.2302E+00,& - .7318E+00,.7318E+00,.7318E+00,.7276E+00,.7155E+00,.7094E+00,.7067E+00,.6727E+00,.6024E+00,.4860E+00,.2310E+00,& - .7324E+00,.7324E+00,.7324E+00,.7282E+00,.7162E+00,.7101E+00,.7075E+00,.6737E+00,.6035E+00,.4871E+00,.2317E+00,& - .7330E+00,.7330E+00,.7330E+00,.7287E+00,.7167E+00,.7107E+00,.7081E+00,.6745E+00,.6043E+00,.4880E+00,.2323E+00,& - .7336E+00,.7336E+00,.7336E+00,.7293E+00,.7171E+00,.7113E+00,.7088E+00,.6753E+00,.6052E+00,.4889E+00,.2329E+00,& - .7341E+00,.7341E+00,.7341E+00,.7298E+00,.7176E+00,.7118E+00,.7094E+00,.6760E+00,.6060E+00,.4897E+00,.2335E+00,& - .7347E+00,.7347E+00,.7347E+00,.7304E+00,.7180E+00,.7124E+00,.7101E+00,.6768E+00,.6069E+00,.4906E+00,.2341E+00,& - .7353E+00,.7353E+00,.7353E+00,.7309E+00,.7185E+00,.7130E+00,.7107E+00,.6776E+00,.6077E+00,.4915E+00,.2347E+00,& - .7359E+00,.7359E+00,.7359E+00,.7316E+00,.7194E+00,.7140E+00,.7117E+00,.6785E+00,.6087E+00,.4925E+00,.2354E+00,& - .7366E+00,.7366E+00,.7366E+00,.7323E+00,.7202E+00,.7149E+00,.7127E+00,.6793E+00,.6097E+00,.4936E+00,.2362E+00,& - .7372E+00,.7372E+00,.7372E+00,.7330E+00,.7211E+00,.7159E+00,.7136E+00,.6802E+00,.6106E+00,.4946E+00,.2369E+00,& - .7379E+00,.7379E+00,.7379E+00,.7337E+00,.7219E+00,.7168E+00,.7146E+00,.6810E+00,.6116E+00,.4957E+00,.2377E+00,& - .7385E+00,.7385E+00,.7385E+00,.7344E+00,.7228E+00,.7178E+00,.7156E+00,.6819E+00,.6126E+00,.4967E+00,.2384E+00,& - .7391E+00,.7391E+00,.7391E+00,.7352E+00,.7240E+00,.7189E+00,.7167E+00,.6832E+00,.6140E+00,.4982E+00,.2395E+00,& - .7397E+00,.7397E+00,.7397E+00,.7360E+00,.7252E+00,.7201E+00,.7178E+00,.6845E+00,.6154E+00,.4997E+00,.2406E+00,& - .7404E+00,.7404E+00,.7404E+00,.7367E+00,.7264E+00,.7212E+00,.7190E+00,.6857E+00,.6169E+00,.5012E+00,.2416E+00,& - .7410E+00,.7410E+00,.7410E+00,.7375E+00,.7276E+00,.7224E+00,.7201E+00,.6870E+00,.6183E+00,.5027E+00,.2427E+00,& - .7416E+00,.7416E+00,.7416E+00,.7383E+00,.7288E+00,.7235E+00,.7212E+00,.6883E+00,.6197E+00,.5042E+00,.2438E+00,& - .7425E+00,.7425E+00,.7425E+00,.7392E+00,.7296E+00,.7245E+00,.7223E+00,.6899E+00,.6215E+00,.5061E+00,.2452E+00,& - .7434E+00,.7434E+00,.7434E+00,.7401E+00,.7305E+00,.7255E+00,.7234E+00,.6915E+00,.6232E+00,.5080E+00,.2467E+00,& - .7443E+00,.7443E+00,.7443E+00,.7409E+00,.7313E+00,.7265E+00,.7244E+00,.6930E+00,.6250E+00,.5100E+00,.2481E+00,& - .7452E+00,.7452E+00,.7452E+00,.7418E+00,.7322E+00,.7275E+00,.7255E+00,.6946E+00,.6267E+00,.5119E+00,.2496E+00,& - .7461E+00,.7461E+00,.7461E+00,.7427E+00,.7330E+00,.7285E+00,.7266E+00,.6962E+00,.6285E+00,.5138E+00,.2510E+00,& - .7475E+00,.7475E+00,.7475E+00,.7440E+00,.7342E+00,.7304E+00,.7287E+00,.6979E+00,.6306E+00,.5161E+00,.2528E+00,& - .7487E+00,.7487E+00,.7487E+00,.7455E+00,.7362E+00,.7323E+00,.7307E+00,.6996E+00,.6327E+00,.5185E+00,.2546E+00,& - .7498E+00,.7498E+00,.7498E+00,.7468E+00,.7381E+00,.7340E+00,.7323E+00,.7013E+00,.6347E+00,.5208E+00,.2563E+00,& - .7504E+00,.7504E+00,.7504E+00,.7476E+00,.7396E+00,.7358E+00,.7341E+00,.7029E+00,.6367E+00,.5230E+00,.2581E+00,& - .7511E+00,.7511E+00,.7511E+00,.7487E+00,.7417E+00,.7374E+00,.7356E+00,.7052E+00,.6393E+00,.5260E+00,.2604E+00,& - .7516E+00,.7516E+00,.7516E+00,.7493E+00,.7428E+00,.7386E+00,.7368E+00,.7074E+00,.6419E+00,.5289E+00,.2627E+00,& - .7528E+00,.7528E+00,.7528E+00,.7505E+00,.7439E+00,.7399E+00,.7382E+00,.7101E+00,.6450E+00,.5325E+00,.2656E+00,& - .7550E+00,.7550E+00,.7550E+00,.7523E+00,.7447E+00,.7414E+00,.7400E+00,.7125E+00,.6480E+00,.5360E+00,.2685E+00,& - .7572E+00,.7572E+00,.7572E+00,.7547E+00,.7476E+00,.7447E+00,.7434E+00,.7152E+00,.6515E+00,.5401E+00,.2719E+00,& - .7582E+00,.7582E+00,.7582E+00,.7562E+00,.7504E+00,.7475E+00,.7462E+00,.7178E+00,.6548E+00,.5442E+00,.2753E+00,& - .7585E+00,.7585E+00,.7585E+00,.7570E+00,.7528E+00,.7494E+00,.7479E+00,.7210E+00,.6587E+00,.5488E+00,.2792E+00,& - .7599E+00,.7599E+00,.7599E+00,.7583E+00,.7537E+00,.7505E+00,.7492E+00,.7245E+00,.6629E+00,.5540E+00,.2837E+00,& - .7634E+00,.7634E+00,.7634E+00,.7615E+00,.7561E+00,.7542E+00,.7534E+00,.7280E+00,.6678E+00,.5601E+00,.2891E+00,& - .7641E+00,.7641E+00,.7641E+00,.7632E+00,.7605E+00,.7580E+00,.7569E+00,.7319E+00,.6731E+00,.5667E+00,.2950E+00,& - .7661E+00,.7661E+00,.7661E+00,.7648E+00,.7612E+00,.7593E+00,.7585E+00,.7372E+00,.6797E+00,.5753E+00,.3029E+00,& - .7685E+00,.7685E+00,.7685E+00,.7681E+00,.7671E+00,.7653E+00,.7646E+00,.7424E+00,.6874E+00,.5854E+00,.3127E+00,& - .7715E+00,.7715E+00,.7715E+00,.7704E+00,.7673E+00,.7672E+00,.7672E+00,.7483E+00,.6956E+00,.5964E+00,.3236E+00,& - .7737E+00,.7737E+00,.7737E+00,.7731E+00,.7715E+00,.7715E+00,.7715E+00,.7564E+00,.7073E+00,.6128E+00,.3406E+00,& - .7776E+00,.7776E+00,.7776E+00,.7780E+00,.7792E+00,.7799E+00,.7802E+00,.7657E+00,.7227E+00,.6356E+00,.3661E+00/ - data (((g(ai,k,nh),ai= 5, 5),k=1,11),nh=0,99)/ & - .7187E+00,.7187E+00,.7187E+00,.7166E+00,.7105E+00,.7031E+00,.6999E+00,.6976E+00,.7051E+00,.7042E+00,.5544E+00,& - .7215E+00,.7215E+00,.7215E+00,.7195E+00,.7137E+00,.7062E+00,.7030E+00,.7007E+00,.7082E+00,.7074E+00,.5579E+00,& - .7243E+00,.7243E+00,.7243E+00,.7224E+00,.7169E+00,.7094E+00,.7062E+00,.7038E+00,.7112E+00,.7106E+00,.5615E+00,& - .7270E+00,.7270E+00,.7270E+00,.7252E+00,.7200E+00,.7125E+00,.7093E+00,.7070E+00,.7143E+00,.7137E+00,.5650E+00,& - .7298E+00,.7298E+00,.7298E+00,.7281E+00,.7232E+00,.7157E+00,.7125E+00,.7101E+00,.7173E+00,.7169E+00,.5686E+00,& - .7326E+00,.7326E+00,.7326E+00,.7310E+00,.7264E+00,.7188E+00,.7156E+00,.7132E+00,.7204E+00,.7201E+00,.5721E+00,& - .7360E+00,.7360E+00,.7360E+00,.7340E+00,.7283E+00,.7209E+00,.7177E+00,.7153E+00,.7230E+00,.7229E+00,.5752E+00,& - .7393E+00,.7393E+00,.7393E+00,.7370E+00,.7302E+00,.7229E+00,.7198E+00,.7174E+00,.7256E+00,.7257E+00,.5782E+00,& - .7427E+00,.7427E+00,.7427E+00,.7399E+00,.7322E+00,.7250E+00,.7219E+00,.7194E+00,.7283E+00,.7284E+00,.5813E+00,& - .7460E+00,.7460E+00,.7460E+00,.7429E+00,.7341E+00,.7270E+00,.7240E+00,.7215E+00,.7309E+00,.7312E+00,.5843E+00,& - .7494E+00,.7494E+00,.7494E+00,.7459E+00,.7360E+00,.7291E+00,.7261E+00,.7236E+00,.7335E+00,.7340E+00,.5874E+00,& - .7493E+00,.7493E+00,.7493E+00,.7465E+00,.7385E+00,.7310E+00,.7277E+00,.7262E+00,.7354E+00,.7363E+00,.5902E+00,& - .7492E+00,.7492E+00,.7492E+00,.7470E+00,.7410E+00,.7328E+00,.7293E+00,.7289E+00,.7372E+00,.7386E+00,.5929E+00,& - .7490E+00,.7490E+00,.7490E+00,.7476E+00,.7436E+00,.7347E+00,.7308E+00,.7315E+00,.7391E+00,.7408E+00,.5957E+00,& - .7489E+00,.7489E+00,.7489E+00,.7481E+00,.7461E+00,.7365E+00,.7324E+00,.7342E+00,.7409E+00,.7431E+00,.5984E+00,& - .7488E+00,.7488E+00,.7488E+00,.7487E+00,.7486E+00,.7384E+00,.7340E+00,.7368E+00,.7428E+00,.7454E+00,.6012E+00,& - .7525E+00,.7525E+00,.7525E+00,.7518E+00,.7497E+00,.7405E+00,.7366E+00,.7377E+00,.7446E+00,.7473E+00,.6037E+00,& - .7563E+00,.7563E+00,.7563E+00,.7548E+00,.7507E+00,.7427E+00,.7392E+00,.7387E+00,.7464E+00,.7492E+00,.6062E+00,& - .7600E+00,.7600E+00,.7600E+00,.7579E+00,.7518E+00,.7448E+00,.7419E+00,.7396E+00,.7483E+00,.7511E+00,.6087E+00,& - .7638E+00,.7638E+00,.7638E+00,.7609E+00,.7528E+00,.7470E+00,.7445E+00,.7406E+00,.7501E+00,.7530E+00,.6112E+00,& - .7675E+00,.7675E+00,.7675E+00,.7640E+00,.7539E+00,.7491E+00,.7471E+00,.7415E+00,.7519E+00,.7549E+00,.6137E+00,& - .7670E+00,.7670E+00,.7670E+00,.7640E+00,.7554E+00,.7500E+00,.7477E+00,.7437E+00,.7532E+00,.7566E+00,.6160E+00,& - .7664E+00,.7664E+00,.7664E+00,.7640E+00,.7569E+00,.7508E+00,.7483E+00,.7459E+00,.7545E+00,.7583E+00,.6183E+00,& - .7659E+00,.7659E+00,.7659E+00,.7639E+00,.7583E+00,.7517E+00,.7488E+00,.7481E+00,.7559E+00,.7601E+00,.6207E+00,& - .7653E+00,.7653E+00,.7653E+00,.7639E+00,.7598E+00,.7525E+00,.7494E+00,.7503E+00,.7572E+00,.7618E+00,.6230E+00,& - .7648E+00,.7648E+00,.7648E+00,.7639E+00,.7613E+00,.7534E+00,.7500E+00,.7525E+00,.7585E+00,.7635E+00,.6253E+00,& - .7672E+00,.7672E+00,.7672E+00,.7659E+00,.7623E+00,.7552E+00,.7521E+00,.7528E+00,.7597E+00,.7649E+00,.6274E+00,& - .7696E+00,.7696E+00,.7696E+00,.7679E+00,.7633E+00,.7570E+00,.7543E+00,.7531E+00,.7609E+00,.7662E+00,.6295E+00,& - .7719E+00,.7719E+00,.7719E+00,.7700E+00,.7642E+00,.7588E+00,.7564E+00,.7535E+00,.7621E+00,.7676E+00,.6316E+00,& - .7743E+00,.7743E+00,.7743E+00,.7720E+00,.7652E+00,.7606E+00,.7586E+00,.7538E+00,.7633E+00,.7689E+00,.6337E+00,& - .7767E+00,.7767E+00,.7767E+00,.7740E+00,.7662E+00,.7624E+00,.7607E+00,.7541E+00,.7645E+00,.7703E+00,.6358E+00,& - .7752E+00,.7752E+00,.7752E+00,.7730E+00,.7665E+00,.7633E+00,.7618E+00,.7557E+00,.7654E+00,.7716E+00,.6378E+00,& - .7738E+00,.7738E+00,.7738E+00,.7720E+00,.7669E+00,.7642E+00,.7630E+00,.7573E+00,.7662E+00,.7728E+00,.6398E+00,& - .7723E+00,.7723E+00,.7723E+00,.7710E+00,.7672E+00,.7650E+00,.7641E+00,.7590E+00,.7671E+00,.7741E+00,.6418E+00,& - .7709E+00,.7709E+00,.7709E+00,.7700E+00,.7676E+00,.7659E+00,.7653E+00,.7606E+00,.7679E+00,.7753E+00,.6438E+00,& - .7694E+00,.7694E+00,.7694E+00,.7690E+00,.7679E+00,.7668E+00,.7664E+00,.7622E+00,.7688E+00,.7766E+00,.6458E+00,& - .7724E+00,.7724E+00,.7724E+00,.7717E+00,.7699E+00,.7683E+00,.7677E+00,.7625E+00,.7697E+00,.7776E+00,.6476E+00,& - .7754E+00,.7754E+00,.7754E+00,.7745E+00,.7718E+00,.7698E+00,.7690E+00,.7629E+00,.7706E+00,.7787E+00,.6494E+00,& - .7785E+00,.7785E+00,.7785E+00,.7772E+00,.7738E+00,.7713E+00,.7703E+00,.7632E+00,.7714E+00,.7797E+00,.6513E+00,& - .7815E+00,.7815E+00,.7815E+00,.7800E+00,.7757E+00,.7728E+00,.7716E+00,.7636E+00,.7723E+00,.7808E+00,.6531E+00,& - .7845E+00,.7845E+00,.7845E+00,.7827E+00,.7777E+00,.7743E+00,.7729E+00,.7639E+00,.7732E+00,.7818E+00,.6549E+00,& - .7844E+00,.7844E+00,.7844E+00,.7829E+00,.7788E+00,.7744E+00,.7725E+00,.7651E+00,.7739E+00,.7827E+00,.6566E+00,& - .7843E+00,.7843E+00,.7843E+00,.7831E+00,.7799E+00,.7745E+00,.7721E+00,.7663E+00,.7746E+00,.7836E+00,.6584E+00,& - .7842E+00,.7842E+00,.7842E+00,.7834E+00,.7811E+00,.7745E+00,.7718E+00,.7675E+00,.7752E+00,.7844E+00,.6601E+00,& - .7841E+00,.7841E+00,.7841E+00,.7836E+00,.7822E+00,.7746E+00,.7714E+00,.7687E+00,.7759E+00,.7853E+00,.6619E+00,& - .7840E+00,.7840E+00,.7840E+00,.7838E+00,.7833E+00,.7747E+00,.7710E+00,.7699E+00,.7766E+00,.7862E+00,.6636E+00,& - .7850E+00,.7850E+00,.7850E+00,.7845E+00,.7832E+00,.7755E+00,.7722E+00,.7707E+00,.7773E+00,.7871E+00,.6652E+00,& - .7859E+00,.7859E+00,.7859E+00,.7852E+00,.7831E+00,.7763E+00,.7734E+00,.7715E+00,.7780E+00,.7880E+00,.6668E+00,& - .7869E+00,.7869E+00,.7869E+00,.7859E+00,.7831E+00,.7772E+00,.7747E+00,.7723E+00,.7786E+00,.7890E+00,.6683E+00,& - .7878E+00,.7878E+00,.7878E+00,.7866E+00,.7830E+00,.7780E+00,.7759E+00,.7731E+00,.7793E+00,.7899E+00,.6699E+00,& - .7888E+00,.7888E+00,.7888E+00,.7873E+00,.7829E+00,.7788E+00,.7771E+00,.7739E+00,.7800E+00,.7908E+00,.6715E+00,& - .7892E+00,.7892E+00,.7892E+00,.7878E+00,.7838E+00,.7799E+00,.7783E+00,.7736E+00,.7801E+00,.7912E+00,.6728E+00,& - .7895E+00,.7895E+00,.7895E+00,.7883E+00,.7847E+00,.7810E+00,.7795E+00,.7733E+00,.7801E+00,.7916E+00,.6740E+00,& - .7899E+00,.7899E+00,.7899E+00,.7888E+00,.7856E+00,.7822E+00,.7807E+00,.7731E+00,.7802E+00,.7921E+00,.6753E+00,& - .7902E+00,.7902E+00,.7902E+00,.7893E+00,.7865E+00,.7833E+00,.7819E+00,.7728E+00,.7802E+00,.7925E+00,.6765E+00,& - .7906E+00,.7906E+00,.7906E+00,.7898E+00,.7874E+00,.7844E+00,.7831E+00,.7725E+00,.7803E+00,.7929E+00,.6778E+00,& - .7902E+00,.7902E+00,.7902E+00,.7894E+00,.7868E+00,.7844E+00,.7834E+00,.7737E+00,.7809E+00,.7936E+00,.6790E+00,& - .7898E+00,.7898E+00,.7898E+00,.7889E+00,.7862E+00,.7845E+00,.7837E+00,.7749E+00,.7815E+00,.7943E+00,.6802E+00,& - .7895E+00,.7895E+00,.7895E+00,.7885E+00,.7856E+00,.7845E+00,.7841E+00,.7761E+00,.7820E+00,.7949E+00,.6814E+00,& - .7891E+00,.7891E+00,.7891E+00,.7880E+00,.7850E+00,.7846E+00,.7844E+00,.7773E+00,.7826E+00,.7956E+00,.6826E+00,& - .7887E+00,.7887E+00,.7887E+00,.7876E+00,.7844E+00,.7846E+00,.7847E+00,.7785E+00,.7832E+00,.7963E+00,.6838E+00,& - .7903E+00,.7903E+00,.7903E+00,.7891E+00,.7858E+00,.7846E+00,.7841E+00,.7789E+00,.7836E+00,.7968E+00,.6849E+00,& - .7918E+00,.7918E+00,.7918E+00,.7906E+00,.7873E+00,.7847E+00,.7836E+00,.7793E+00,.7840E+00,.7973E+00,.6860E+00,& - .7934E+00,.7934E+00,.7934E+00,.7922E+00,.7887E+00,.7847E+00,.7830E+00,.7798E+00,.7844E+00,.7977E+00,.6872E+00,& - .7949E+00,.7949E+00,.7949E+00,.7937E+00,.7902E+00,.7848E+00,.7825E+00,.7802E+00,.7848E+00,.7982E+00,.6883E+00,& - .7965E+00,.7965E+00,.7965E+00,.7952E+00,.7916E+00,.7848E+00,.7819E+00,.7806E+00,.7852E+00,.7987E+00,.6894E+00,& - .7966E+00,.7966E+00,.7966E+00,.7955E+00,.7924E+00,.7860E+00,.7832E+00,.7802E+00,.7852E+00,.7990E+00,.6905E+00,& - .7968E+00,.7968E+00,.7968E+00,.7958E+00,.7933E+00,.7871E+00,.7845E+00,.7798E+00,.7851E+00,.7993E+00,.6916E+00,& - .7969E+00,.7969E+00,.7969E+00,.7962E+00,.7941E+00,.7883E+00,.7858E+00,.7793E+00,.7851E+00,.7995E+00,.6926E+00,& - .7971E+00,.7971E+00,.7971E+00,.7965E+00,.7950E+00,.7894E+00,.7871E+00,.7789E+00,.7850E+00,.7998E+00,.6937E+00,& - .7972E+00,.7972E+00,.7972E+00,.7968E+00,.7958E+00,.7906E+00,.7884E+00,.7785E+00,.7850E+00,.8001E+00,.6948E+00,& - .7978E+00,.7978E+00,.7978E+00,.7973E+00,.7958E+00,.7899E+00,.7874E+00,.7798E+00,.7856E+00,.8009E+00,.6964E+00,& - .7984E+00,.7984E+00,.7984E+00,.7977E+00,.7958E+00,.7892E+00,.7864E+00,.7811E+00,.7862E+00,.8017E+00,.6981E+00,& - .7991E+00,.7991E+00,.7991E+00,.7982E+00,.7957E+00,.7884E+00,.7853E+00,.7825E+00,.7869E+00,.8025E+00,.6997E+00,& - .7997E+00,.7997E+00,.7997E+00,.7986E+00,.7957E+00,.7877E+00,.7843E+00,.7838E+00,.7875E+00,.8033E+00,.7014E+00,& - .8003E+00,.8003E+00,.8003E+00,.7991E+00,.7957E+00,.7870E+00,.7833E+00,.7851E+00,.7881E+00,.8041E+00,.7030E+00,& - .8014E+00,.8014E+00,.8014E+00,.8000E+00,.7963E+00,.7896E+00,.7868E+00,.7850E+00,.7884E+00,.8046E+00,.7049E+00,& - .8024E+00,.8024E+00,.8024E+00,.8010E+00,.7969E+00,.7923E+00,.7903E+00,.7848E+00,.7887E+00,.8050E+00,.7067E+00,& - .8035E+00,.8035E+00,.8035E+00,.8019E+00,.7974E+00,.7949E+00,.7939E+00,.7847E+00,.7889E+00,.8055E+00,.7086E+00,& - .8045E+00,.8045E+00,.8045E+00,.8029E+00,.7980E+00,.7976E+00,.7974E+00,.7845E+00,.7892E+00,.8059E+00,.7104E+00,& - .8056E+00,.8056E+00,.8056E+00,.8038E+00,.7986E+00,.8002E+00,.8009E+00,.7844E+00,.7895E+00,.8064E+00,.7123E+00,& - .8054E+00,.8054E+00,.8054E+00,.8052E+00,.8047E+00,.7964E+00,.7928E+00,.7879E+00,.7901E+00,.8073E+00,.7144E+00,& - .8082E+00,.8082E+00,.8082E+00,.8068E+00,.8028E+00,.7968E+00,.7943E+00,.7902E+00,.7920E+00,.8089E+00,.7172E+00,& - .8115E+00,.8115E+00,.8115E+00,.8077E+00,.7968E+00,.7989E+00,.7998E+00,.7874E+00,.7920E+00,.8095E+00,.7196E+00,& - .8037E+00,.8037E+00,.8037E+00,.8036E+00,.8035E+00,.8021E+00,.8015E+00,.7885E+00,.7914E+00,.8094E+00,.7219E+00,& - .8088E+00,.8088E+00,.8088E+00,.8089E+00,.8091E+00,.8006E+00,.7970E+00,.7886E+00,.7905E+00,.8100E+00,.7253E+00,& - .8108E+00,.8108E+00,.8108E+00,.8100E+00,.8079E+00,.8016E+00,.7989E+00,.7911E+00,.7927E+00,.8108E+00,.7279E+00,& - .8149E+00,.8149E+00,.8149E+00,.8139E+00,.8109E+00,.8047E+00,.8021E+00,.7944E+00,.7943E+00,.8127E+00,.7310E+00,& - .8175E+00,.8175E+00,.8175E+00,.8140E+00,.8042E+00,.8027E+00,.8021E+00,.7922E+00,.7944E+00,.8133E+00,.7340E+00,& - .8158E+00,.8158E+00,.8158E+00,.8153E+00,.8140E+00,.8079E+00,.8053E+00,.7930E+00,.7942E+00,.8131E+00,.7373E+00,& - .8139E+00,.8139E+00,.8139E+00,.8147E+00,.8171E+00,.8079E+00,.8040E+00,.7960E+00,.7948E+00,.8140E+00,.7414E+00,& - .8127E+00,.8127E+00,.8127E+00,.8128E+00,.8132E+00,.8073E+00,.8048E+00,.7986E+00,.7946E+00,.8159E+00,.7453E+00,& - .8233E+00,.8233E+00,.8233E+00,.8223E+00,.8196E+00,.8158E+00,.8142E+00,.7974E+00,.7954E+00,.8155E+00,.7503E+00,& - .8162E+00,.8162E+00,.8162E+00,.8158E+00,.8148E+00,.8160E+00,.8165E+00,.8004E+00,.7956E+00,.8173E+00,.7554E+00,& - .8250E+00,.8250E+00,.8250E+00,.8239E+00,.8209E+00,.8182E+00,.8170E+00,.8006E+00,.7969E+00,.8173E+00,.7614E+00,& - .8261E+00,.8261E+00,.8261E+00,.8251E+00,.8222E+00,.8148E+00,.8117E+00,.8035E+00,.7967E+00,.8193E+00,.7688E+00,& - .8290E+00,.8290E+00,.8290E+00,.8269E+00,.8208E+00,.8184E+00,.8173E+00,.8068E+00,.7975E+00,.8194E+00,.7766E+00,& - .8321E+00,.8321E+00,.8321E+00,.8319E+00,.8315E+00,.8273E+00,.8255E+00,.8128E+00,.8012E+00,.8211E+00,.7877E+00,& - .8365E+00,.8365E+00,.8365E+00,.8361E+00,.8350E+00,.8308E+00,.8290E+00,.8160E+00,.8033E+00,.8199E+00,.7998E+00,& - .8394E+00,.8394E+00,.8394E+00,.8392E+00,.8388E+00,.8404E+00,.8411E+00,.8269E+00,.8056E+00,.8214E+00,.8187E+00/ - data (((g(ai,k,nh),ai= 6, 6),k=1,11),nh=0,99)/ & - .8058E+00,.8058E+00,.8058E+00,.8052E+00,.8034E+00,.8012E+00,.8003E+00,.7904E+00,.7734E+00,.7542E+00,.7236E+00,& - .8078E+00,.8078E+00,.8078E+00,.8072E+00,.8055E+00,.8030E+00,.8019E+00,.7924E+00,.7752E+00,.7568E+00,.7293E+00,& - .8098E+00,.8098E+00,.8098E+00,.8093E+00,.8077E+00,.8047E+00,.8035E+00,.7944E+00,.7770E+00,.7594E+00,.7349E+00,& - .8119E+00,.8119E+00,.8119E+00,.8113E+00,.8098E+00,.8065E+00,.8050E+00,.7964E+00,.7787E+00,.7621E+00,.7406E+00,& - .8139E+00,.8139E+00,.8139E+00,.8134E+00,.8120E+00,.8082E+00,.8066E+00,.7984E+00,.7805E+00,.7647E+00,.7462E+00,& - .8159E+00,.8159E+00,.8159E+00,.8154E+00,.8141E+00,.8100E+00,.8082E+00,.8004E+00,.7823E+00,.7673E+00,.7519E+00,& - .8170E+00,.8170E+00,.8170E+00,.8164E+00,.8149E+00,.8114E+00,.8099E+00,.8015E+00,.7840E+00,.7688E+00,.7560E+00,& - .8180E+00,.8180E+00,.8180E+00,.8174E+00,.8157E+00,.8128E+00,.8115E+00,.8026E+00,.7858E+00,.7704E+00,.7601E+00,& - .8191E+00,.8191E+00,.8191E+00,.8184E+00,.8164E+00,.8141E+00,.8132E+00,.8036E+00,.7875E+00,.7719E+00,.7643E+00,& - .8201E+00,.8201E+00,.8201E+00,.8194E+00,.8172E+00,.8155E+00,.8148E+00,.8047E+00,.7893E+00,.7735E+00,.7684E+00,& - .8212E+00,.8212E+00,.8212E+00,.8204E+00,.8180E+00,.8169E+00,.8165E+00,.8058E+00,.7910E+00,.7750E+00,.7725E+00,& - .8222E+00,.8222E+00,.8222E+00,.8215E+00,.8192E+00,.8182E+00,.8179E+00,.8076E+00,.7928E+00,.7774E+00,.7754E+00,& - .8233E+00,.8233E+00,.8233E+00,.8226E+00,.8205E+00,.8196E+00,.8192E+00,.8093E+00,.7946E+00,.7798E+00,.7784E+00,& - .8243E+00,.8243E+00,.8243E+00,.8236E+00,.8217E+00,.8209E+00,.8206E+00,.8111E+00,.7963E+00,.7822E+00,.7813E+00,& - .8254E+00,.8254E+00,.8254E+00,.8247E+00,.8230E+00,.8223E+00,.8219E+00,.8128E+00,.7981E+00,.7846E+00,.7843E+00,& - .8264E+00,.8264E+00,.8264E+00,.8258E+00,.8242E+00,.8236E+00,.8233E+00,.8146E+00,.7999E+00,.7870E+00,.7872E+00,& - .8272E+00,.8272E+00,.8272E+00,.8267E+00,.8254E+00,.8248E+00,.8245E+00,.8158E+00,.8010E+00,.7881E+00,.7898E+00,& - .8280E+00,.8280E+00,.8280E+00,.8276E+00,.8265E+00,.8260E+00,.8257E+00,.8171E+00,.8020E+00,.7892E+00,.7924E+00,& - .8288E+00,.8288E+00,.8288E+00,.8285E+00,.8277E+00,.8271E+00,.8269E+00,.8183E+00,.8031E+00,.7902E+00,.7949E+00,& - .8296E+00,.8296E+00,.8296E+00,.8294E+00,.8288E+00,.8283E+00,.8281E+00,.8196E+00,.8041E+00,.7913E+00,.7975E+00,& - .8304E+00,.8304E+00,.8304E+00,.8303E+00,.8300E+00,.8295E+00,.8293E+00,.8208E+00,.8052E+00,.7924E+00,.8001E+00,& - .8316E+00,.8316E+00,.8316E+00,.8314E+00,.8307E+00,.8306E+00,.8305E+00,.8219E+00,.8062E+00,.7939E+00,.8020E+00,& - .8328E+00,.8328E+00,.8328E+00,.8325E+00,.8315E+00,.8316E+00,.8317E+00,.8230E+00,.8071E+00,.7955E+00,.8039E+00,& - .8340E+00,.8340E+00,.8340E+00,.8335E+00,.8322E+00,.8327E+00,.8329E+00,.8242E+00,.8081E+00,.7970E+00,.8058E+00,& - .8352E+00,.8352E+00,.8352E+00,.8346E+00,.8330E+00,.8337E+00,.8341E+00,.8253E+00,.8090E+00,.7986E+00,.8077E+00,& - .8364E+00,.8364E+00,.8364E+00,.8357E+00,.8337E+00,.8348E+00,.8353E+00,.8264E+00,.8100E+00,.8001E+00,.8096E+00,& - .8369E+00,.8369E+00,.8369E+00,.8365E+00,.8352E+00,.8357E+00,.8359E+00,.8273E+00,.8108E+00,.8008E+00,.8113E+00,& - .8374E+00,.8374E+00,.8374E+00,.8372E+00,.8367E+00,.8365E+00,.8365E+00,.8282E+00,.8116E+00,.8016E+00,.8130E+00,& - .8379E+00,.8379E+00,.8379E+00,.8380E+00,.8381E+00,.8374E+00,.8370E+00,.8291E+00,.8124E+00,.8023E+00,.8147E+00,& - .8384E+00,.8384E+00,.8384E+00,.8387E+00,.8396E+00,.8382E+00,.8376E+00,.8300E+00,.8132E+00,.8031E+00,.8164E+00,& - .8389E+00,.8389E+00,.8389E+00,.8395E+00,.8411E+00,.8391E+00,.8382E+00,.8309E+00,.8140E+00,.8038E+00,.8181E+00,& - .8393E+00,.8393E+00,.8393E+00,.8397E+00,.8410E+00,.8390E+00,.8381E+00,.8313E+00,.8149E+00,.8047E+00,.8196E+00,& - .8396E+00,.8396E+00,.8396E+00,.8399E+00,.8408E+00,.8388E+00,.8380E+00,.8318E+00,.8159E+00,.8056E+00,.8212E+00,& - .8400E+00,.8400E+00,.8400E+00,.8402E+00,.8407E+00,.8387E+00,.8378E+00,.8322E+00,.8168E+00,.8064E+00,.8227E+00,& - .8403E+00,.8403E+00,.8403E+00,.8404E+00,.8405E+00,.8385E+00,.8377E+00,.8327E+00,.8178E+00,.8073E+00,.8243E+00,& - .8407E+00,.8407E+00,.8407E+00,.8406E+00,.8404E+00,.8384E+00,.8376E+00,.8331E+00,.8187E+00,.8082E+00,.8258E+00,& - .8411E+00,.8411E+00,.8411E+00,.8411E+00,.8410E+00,.8396E+00,.8390E+00,.8337E+00,.8196E+00,.8094E+00,.8269E+00,& - .8415E+00,.8415E+00,.8415E+00,.8416E+00,.8416E+00,.8407E+00,.8404E+00,.8343E+00,.8204E+00,.8106E+00,.8280E+00,& - .8420E+00,.8420E+00,.8420E+00,.8420E+00,.8423E+00,.8419E+00,.8417E+00,.8348E+00,.8213E+00,.8119E+00,.8290E+00,& - .8424E+00,.8424E+00,.8424E+00,.8425E+00,.8429E+00,.8430E+00,.8431E+00,.8354E+00,.8221E+00,.8131E+00,.8301E+00,& - .8428E+00,.8428E+00,.8428E+00,.8430E+00,.8435E+00,.8442E+00,.8445E+00,.8360E+00,.8230E+00,.8143E+00,.8312E+00,& - .8437E+00,.8437E+00,.8437E+00,.8438E+00,.8440E+00,.8446E+00,.8448E+00,.8368E+00,.8237E+00,.8149E+00,.8324E+00,& - .8446E+00,.8446E+00,.8446E+00,.8446E+00,.8446E+00,.8449E+00,.8451E+00,.8377E+00,.8244E+00,.8155E+00,.8335E+00,& - .8455E+00,.8455E+00,.8455E+00,.8454E+00,.8451E+00,.8453E+00,.8453E+00,.8385E+00,.8252E+00,.8160E+00,.8347E+00,& - .8464E+00,.8464E+00,.8464E+00,.8462E+00,.8457E+00,.8456E+00,.8456E+00,.8394E+00,.8259E+00,.8166E+00,.8358E+00,& - .8473E+00,.8473E+00,.8473E+00,.8470E+00,.8462E+00,.8460E+00,.8459E+00,.8402E+00,.8266E+00,.8172E+00,.8370E+00,& - .8475E+00,.8475E+00,.8475E+00,.8473E+00,.8470E+00,.8468E+00,.8468E+00,.8404E+00,.8271E+00,.8178E+00,.8378E+00,& - .8477E+00,.8477E+00,.8477E+00,.8477E+00,.8477E+00,.8477E+00,.8477E+00,.8407E+00,.8276E+00,.8185E+00,.8386E+00,& - .8479E+00,.8479E+00,.8479E+00,.8480E+00,.8485E+00,.8485E+00,.8485E+00,.8409E+00,.8282E+00,.8191E+00,.8395E+00,& - .8481E+00,.8481E+00,.8481E+00,.8484E+00,.8492E+00,.8494E+00,.8494E+00,.8412E+00,.8287E+00,.8198E+00,.8403E+00,& - .8483E+00,.8483E+00,.8483E+00,.8487E+00,.8500E+00,.8502E+00,.8503E+00,.8414E+00,.8292E+00,.8204E+00,.8411E+00,& - .8488E+00,.8488E+00,.8488E+00,.8491E+00,.8500E+00,.8498E+00,.8497E+00,.8420E+00,.8294E+00,.8207E+00,.8418E+00,& - .8493E+00,.8493E+00,.8493E+00,.8494E+00,.8499E+00,.8493E+00,.8491E+00,.8426E+00,.8297E+00,.8211E+00,.8426E+00,& - .8497E+00,.8497E+00,.8497E+00,.8498E+00,.8499E+00,.8489E+00,.8484E+00,.8433E+00,.8299E+00,.8214E+00,.8433E+00,& - .8502E+00,.8502E+00,.8502E+00,.8501E+00,.8498E+00,.8484E+00,.8478E+00,.8439E+00,.8302E+00,.8218E+00,.8441E+00,& - .8507E+00,.8507E+00,.8507E+00,.8505E+00,.8498E+00,.8480E+00,.8472E+00,.8445E+00,.8304E+00,.8221E+00,.8448E+00,& - .8503E+00,.8503E+00,.8503E+00,.8504E+00,.8504E+00,.8489E+00,.8482E+00,.8445E+00,.8310E+00,.8228E+00,.8455E+00,& - .8499E+00,.8499E+00,.8499E+00,.8502E+00,.8510E+00,.8498E+00,.8492E+00,.8446E+00,.8316E+00,.8235E+00,.8461E+00,& - .8495E+00,.8495E+00,.8495E+00,.8501E+00,.8517E+00,.8506E+00,.8502E+00,.8446E+00,.8323E+00,.8242E+00,.8468E+00,& - .8491E+00,.8491E+00,.8491E+00,.8499E+00,.8523E+00,.8515E+00,.8512E+00,.8447E+00,.8329E+00,.8249E+00,.8474E+00,& - .8487E+00,.8487E+00,.8487E+00,.8498E+00,.8529E+00,.8524E+00,.8522E+00,.8447E+00,.8335E+00,.8256E+00,.8481E+00,& - .8498E+00,.8498E+00,.8498E+00,.8506E+00,.8530E+00,.8525E+00,.8524E+00,.8455E+00,.8338E+00,.8257E+00,.8486E+00,& - .8508E+00,.8508E+00,.8508E+00,.8514E+00,.8530E+00,.8527E+00,.8525E+00,.8463E+00,.8340E+00,.8258E+00,.8491E+00,& - .8519E+00,.8519E+00,.8519E+00,.8522E+00,.8531E+00,.8528E+00,.8527E+00,.8470E+00,.8343E+00,.8260E+00,.8496E+00,& - .8529E+00,.8529E+00,.8529E+00,.8530E+00,.8531E+00,.8530E+00,.8528E+00,.8478E+00,.8345E+00,.8261E+00,.8501E+00,& - .8540E+00,.8540E+00,.8540E+00,.8538E+00,.8532E+00,.8531E+00,.8530E+00,.8486E+00,.8348E+00,.8262E+00,.8506E+00,& - .8532E+00,.8532E+00,.8532E+00,.8532E+00,.8533E+00,.8535E+00,.8535E+00,.8487E+00,.8350E+00,.8269E+00,.8511E+00,& - .8523E+00,.8523E+00,.8523E+00,.8526E+00,.8534E+00,.8538E+00,.8540E+00,.8488E+00,.8352E+00,.8275E+00,.8516E+00,& - .8515E+00,.8515E+00,.8515E+00,.8520E+00,.8534E+00,.8542E+00,.8544E+00,.8488E+00,.8355E+00,.8282E+00,.8522E+00,& - .8506E+00,.8506E+00,.8506E+00,.8514E+00,.8535E+00,.8545E+00,.8549E+00,.8489E+00,.8357E+00,.8288E+00,.8527E+00,& - .8498E+00,.8498E+00,.8498E+00,.8508E+00,.8536E+00,.8549E+00,.8554E+00,.8490E+00,.8359E+00,.8295E+00,.8532E+00,& - .8510E+00,.8510E+00,.8510E+00,.8515E+00,.8531E+00,.8547E+00,.8554E+00,.8494E+00,.8366E+00,.8301E+00,.8540E+00,& - .8521E+00,.8521E+00,.8521E+00,.8522E+00,.8526E+00,.8546E+00,.8554E+00,.8498E+00,.8372E+00,.8307E+00,.8548E+00,& - .8533E+00,.8533E+00,.8533E+00,.8530E+00,.8520E+00,.8544E+00,.8554E+00,.8501E+00,.8379E+00,.8313E+00,.8555E+00,& - .8544E+00,.8544E+00,.8544E+00,.8537E+00,.8515E+00,.8543E+00,.8554E+00,.8505E+00,.8385E+00,.8319E+00,.8563E+00,& - .8556E+00,.8556E+00,.8556E+00,.8544E+00,.8510E+00,.8541E+00,.8554E+00,.8509E+00,.8392E+00,.8325E+00,.8571E+00,& - .8560E+00,.8560E+00,.8560E+00,.8551E+00,.8524E+00,.8543E+00,.8551E+00,.8515E+00,.8395E+00,.8331E+00,.8579E+00,& - .8565E+00,.8565E+00,.8565E+00,.8558E+00,.8538E+00,.8546E+00,.8549E+00,.8521E+00,.8398E+00,.8337E+00,.8588E+00,& - .8569E+00,.8569E+00,.8569E+00,.8565E+00,.8552E+00,.8548E+00,.8546E+00,.8527E+00,.8401E+00,.8344E+00,.8596E+00,& - .8574E+00,.8574E+00,.8574E+00,.8572E+00,.8566E+00,.8551E+00,.8544E+00,.8533E+00,.8404E+00,.8350E+00,.8605E+00,& - .8578E+00,.8578E+00,.8578E+00,.8579E+00,.8580E+00,.8553E+00,.8541E+00,.8539E+00,.8407E+00,.8356E+00,.8613E+00,& - .8505E+00,.8505E+00,.8505E+00,.8530E+00,.8600E+00,.8570E+00,.8557E+00,.8537E+00,.8415E+00,.8363E+00,.8624E+00,& - .8563E+00,.8563E+00,.8563E+00,.8571E+00,.8592E+00,.8577E+00,.8571E+00,.8538E+00,.8423E+00,.8370E+00,.8636E+00,& - .8561E+00,.8561E+00,.8561E+00,.8570E+00,.8597E+00,.8600E+00,.8601E+00,.8532E+00,.8447E+00,.8380E+00,.8650E+00,& - .8571E+00,.8571E+00,.8571E+00,.8579E+00,.8602E+00,.8576E+00,.8565E+00,.8549E+00,.8457E+00,.8377E+00,.8662E+00,& - .8596E+00,.8596E+00,.8596E+00,.8590E+00,.8574E+00,.8552E+00,.8542E+00,.8548E+00,.8448E+00,.8393E+00,.8670E+00,& - .8578E+00,.8578E+00,.8578E+00,.8587E+00,.8612E+00,.8587E+00,.8577E+00,.8569E+00,.8449E+00,.8413E+00,.8684E+00,& - .8598E+00,.8598E+00,.8598E+00,.8601E+00,.8608E+00,.8619E+00,.8623E+00,.8568E+00,.8478E+00,.8405E+00,.8698E+00,& - .8596E+00,.8596E+00,.8596E+00,.8598E+00,.8603E+00,.8618E+00,.8625E+00,.8574E+00,.8495E+00,.8444E+00,.8712E+00,& - .8590E+00,.8590E+00,.8590E+00,.8593E+00,.8601E+00,.8627E+00,.8638E+00,.8579E+00,.8501E+00,.8445E+00,.8726E+00,& - .8596E+00,.8596E+00,.8596E+00,.8606E+00,.8634E+00,.8633E+00,.8633E+00,.8585E+00,.8510E+00,.8465E+00,.8737E+00,& - .8616E+00,.8616E+00,.8616E+00,.8621E+00,.8637E+00,.8642E+00,.8644E+00,.8607E+00,.8489E+00,.8452E+00,.8757E+00,& - .8604E+00,.8604E+00,.8604E+00,.8613E+00,.8640E+00,.8646E+00,.8649E+00,.8598E+00,.8523E+00,.8481E+00,.8776E+00,& - .8635E+00,.8635E+00,.8635E+00,.8635E+00,.8634E+00,.8635E+00,.8635E+00,.8614E+00,.8541E+00,.8509E+00,.8798E+00,& - .8641E+00,.8641E+00,.8641E+00,.8642E+00,.8644E+00,.8657E+00,.8662E+00,.8633E+00,.8555E+00,.8543E+00,.8828E+00,& - .8640E+00,.8640E+00,.8640E+00,.8641E+00,.8644E+00,.8655E+00,.8659E+00,.8638E+00,.8554E+00,.8557E+00,.8856E+00,& - .8650E+00,.8650E+00,.8650E+00,.8653E+00,.8663E+00,.8658E+00,.8656E+00,.8655E+00,.8586E+00,.8593E+00,.8897E+00,& - .8634E+00,.8634E+00,.8634E+00,.8644E+00,.8674E+00,.8673E+00,.8672E+00,.8665E+00,.8606E+00,.8616E+00,.8945E+00,& - .8667E+00,.8667E+00,.8667E+00,.8672E+00,.8688E+00,.8705E+00,.8712E+00,.8693E+00,.8631E+00,.8689E+00,.9015E+00,& - .8681E+00,.8681E+00,.8681E+00,.8689E+00,.8712E+00,.8727E+00,.8733E+00,.8724E+00,.8678E+00,.8764E+00,.9133E+00/ - data (((g(ai,k,nh),ai= 7, 7),k=1,11),nh=0,99)/ & - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00,& - .6825E+00,.6825E+00,.6825E+00,.6800E+00,.6730E+00,.6662E+00,.6633E+00,.6279E+00,.5549E+00,.4291E+00,.1782E+00/ - data (((g(ai,k,nh),ai= 8, 8),k=1,11),nh=0,99)/ & - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00,& - .6953E+00,.6953E+00,.6953E+00,.6932E+00,.6872E+00,.6824E+00,.6803E+00,.6639E+00,.6242E+00,.5365E+00,.2860E+00/ - data (((g(ai,k,nh),ai= 9, 9),k=1,11),nh=0,99)/ & - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00,& - .7212E+00,.7212E+00,.7212E+00,.7176E+00,.7075E+00,.6986E+00,.6948E+00,.6772E+00,.6651E+00,.6228E+00,.4221E+00/ - data (((g(ai,k,nh),ai=10,10),k=1,11),nh=0,99)/ & - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00,& - .7755E+00,.7755E+00,.7755E+00,.7689E+00,.7501E+00,.7333E+00,.7261E+00,.6877E+00,.6751E+00,.6633E+00,.5350E+00/ - data (((g(ai,k,nh),ai=11,11),k=1,11),nh=0,99)/ & - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00,& - .8317E+00,.8317E+00,.8317E+00,.8253E+00,.8070E+00,.7861E+00,.7772E+00,.7191E+00,.6857E+00,.6780E+00,.6206E+00/ - data (((g(ai,k,nh),ai=12,12),k=1,11),nh=0,99)/ & - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00,& - .8782E+00,.8782E+00,.8782E+00,.8721E+00,.8548E+00,.8341E+00,.8252E+00,.7619E+00,.7130E+00,.6868E+00,.6776E+00/ - data (((g(ai,k,nh),ai=13,13),k=1,11),nh=0,99)/ & - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00,& - .9167E+00,.9167E+00,.9167E+00,.9122E+00,.8994E+00,.8806E+00,.8725E+00,.8078E+00,.7602E+00,.7160E+00,.7239E+00/ - data (((g(ai,k,nh),ai=14,14),k=1,11),nh=0,99)/ & - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00,& - .9366E+00,.9366E+00,.9366E+00,.9340E+00,.9266E+00,.9120E+00,.9058E+00,.8411E+00,.7960E+00,.7643E+00,.7644E+00/ - - data (((Bex_lw(ai,k,nh),ai= 1, 1),k=1,nwl_lw),nh=0,99)/ & - .2252E-01,.2261E-01,.8372E-01,.1441E+00,.2880E+00,.4679E+00,.3723E+00,.1729E+00,.2097E+00,.9603E-01,& - .2373E-01,.2456E-01,.8750E-01,.1471E+00,.2917E+00,.4703E+00,.3718E+00,.1742E+00,.2103E+00,.9952E-01,& - .2495E-01,.2652E-01,.9128E-01,.1502E+00,.2954E+00,.4726E+00,.3714E+00,.1755E+00,.2108E+00,.1030E+00,& - .2617E-01,.2847E-01,.9506E-01,.1532E+00,.2991E+00,.4749E+00,.3709E+00,.1768E+00,.2114E+00,.1065E+00,& - .2738E-01,.3042E-01,.9884E-01,.1563E+00,.3028E+00,.4772E+00,.3704E+00,.1781E+00,.2120E+00,.1100E+00,& - .2860E-01,.3238E-01,.1026E+00,.1594E+00,.3065E+00,.4796E+00,.3700E+00,.1794E+00,.2125E+00,.1135E+00,& - .2994E-01,.3456E-01,.1068E+00,.1625E+00,.3098E+00,.4815E+00,.3697E+00,.1808E+00,.2132E+00,.1173E+00,& - .3129E-01,.3674E-01,.1109E+00,.1655E+00,.3132E+00,.4834E+00,.3695E+00,.1822E+00,.2138E+00,.1212E+00,& - .3263E-01,.3892E-01,.1151E+00,.1686E+00,.3165E+00,.4853E+00,.3692E+00,.1835E+00,.2144E+00,.1250E+00,& - .3397E-01,.4110E-01,.1193E+00,.1717E+00,.3198E+00,.4872E+00,.3690E+00,.1849E+00,.2150E+00,.1288E+00,& - .3531E-01,.4328E-01,.1234E+00,.1748E+00,.3231E+00,.4892E+00,.3687E+00,.1863E+00,.2157E+00,.1326E+00,& - .3674E-01,.4561E-01,.1278E+00,.1779E+00,.3260E+00,.4909E+00,.3688E+00,.1878E+00,.2164E+00,.1367E+00,& - .3817E-01,.4795E-01,.1322E+00,.1810E+00,.3290E+00,.4926E+00,.3688E+00,.1893E+00,.2171E+00,.1407E+00,& - .3959E-01,.5028E-01,.1366E+00,.1840E+00,.3320E+00,.4944E+00,.3689E+00,.1908E+00,.2179E+00,.1447E+00,& - .4102E-01,.5261E-01,.1410E+00,.1871E+00,.3349E+00,.4961E+00,.3689E+00,.1923E+00,.2186E+00,.1488E+00,& - .4245E-01,.5494E-01,.1454E+00,.1902E+00,.3379E+00,.4979E+00,.3690E+00,.1938E+00,.2193E+00,.1528E+00,& - .4404E-01,.5757E-01,.1503E+00,.1934E+00,.3406E+00,.4994E+00,.3691E+00,.1954E+00,.2201E+00,.1573E+00,& - .4563E-01,.6019E-01,.1552E+00,.1966E+00,.3433E+00,.5009E+00,.3692E+00,.1969E+00,.2209E+00,.1617E+00,& - .4723E-01,.6282E-01,.1601E+00,.1998E+00,.3460E+00,.5023E+00,.3693E+00,.1985E+00,.2217E+00,.1662E+00,& - .4882E-01,.6545E-01,.1650E+00,.2030E+00,.3487E+00,.5038E+00,.3694E+00,.2001E+00,.2225E+00,.1707E+00,& - .5041E-01,.6807E-01,.1699E+00,.2062E+00,.3515E+00,.5053E+00,.3695E+00,.2017E+00,.2232E+00,.1751E+00,& - .5213E-01,.7092E-01,.1752E+00,.2094E+00,.3540E+00,.5067E+00,.3698E+00,.2034E+00,.2241E+00,.1800E+00,& - .5385E-01,.7376E-01,.1805E+00,.2127E+00,.3565E+00,.5081E+00,.3701E+00,.2051E+00,.2250E+00,.1848E+00,& - .5556E-01,.7661E-01,.1858E+00,.2160E+00,.3590E+00,.5095E+00,.3703E+00,.2069E+00,.2259E+00,.1896E+00,& - .5728E-01,.7946E-01,.1910E+00,.2192E+00,.3615E+00,.5109E+00,.3706E+00,.2086E+00,.2268E+00,.1944E+00,& - .5900E-01,.8230E-01,.1963E+00,.2225E+00,.3640E+00,.5123E+00,.3709E+00,.2103E+00,.2277E+00,.1992E+00,& - .6085E-01,.8537E-01,.2020E+00,.2259E+00,.3663E+00,.5136E+00,.3713E+00,.2121E+00,.2287E+00,.2044E+00,& - .6270E-01,.8845E-01,.2077E+00,.2292E+00,.3686E+00,.5149E+00,.3717E+00,.2140E+00,.2296E+00,.2095E+00,& - .6455E-01,.9152E-01,.2133E+00,.2326E+00,.3710E+00,.5162E+00,.3721E+00,.2158E+00,.2306E+00,.2147E+00,& - .6639E-01,.9459E-01,.2190E+00,.2359E+00,.3733E+00,.5175E+00,.3725E+00,.2176E+00,.2316E+00,.2198E+00,& - .6824E-01,.9766E-01,.2246E+00,.2393E+00,.3757E+00,.5188E+00,.3729E+00,.2194E+00,.2326E+00,.2250E+00,& - .7022E-01,.1010E+00,.2307E+00,.2428E+00,.3779E+00,.5201E+00,.3734E+00,.2214E+00,.2337E+00,.2305E+00,& - .7220E-01,.1043E+00,.2367E+00,.2462E+00,.3801E+00,.5214E+00,.3739E+00,.2234E+00,.2347E+00,.2360E+00,& - .7417E-01,.1076E+00,.2428E+00,.2497E+00,.3823E+00,.5226E+00,.3745E+00,.2254E+00,.2358E+00,.2415E+00,& - .7615E-01,.1108E+00,.2489E+00,.2532E+00,.3845E+00,.5239E+00,.3750E+00,.2273E+00,.2369E+00,.2470E+00,& - .7813E-01,.1141E+00,.2549E+00,.2566E+00,.3867E+00,.5252E+00,.3755E+00,.2293E+00,.2380E+00,.2525E+00,& - .8019E-01,.1176E+00,.2612E+00,.2602E+00,.3889E+00,.5266E+00,.3763E+00,.2314E+00,.2393E+00,.2582E+00,& - .8225E-01,.1210E+00,.2675E+00,.2637E+00,.3911E+00,.5280E+00,.3770E+00,.2335E+00,.2405E+00,.2640E+00,& - .8430E-01,.1245E+00,.2738E+00,.2673E+00,.3932E+00,.5293E+00,.3778E+00,.2356E+00,.2418E+00,.2697E+00,& - .8636E-01,.1279E+00,.2801E+00,.2708E+00,.3954E+00,.5307E+00,.3785E+00,.2376E+00,.2430E+00,.2754E+00,& - .8842E-01,.1313E+00,.2864E+00,.2744E+00,.3976E+00,.5321E+00,.3792E+00,.2397E+00,.2443E+00,.2812E+00,& - .9066E-01,.1351E+00,.2933E+00,.2781E+00,.3996E+00,.5334E+00,.3800E+00,.2420E+00,.2456E+00,.2874E+00,& - .9291E-01,.1389E+00,.3001E+00,.2818E+00,.4017E+00,.5347E+00,.3808E+00,.2442E+00,.2470E+00,.2936E+00,& - .9515E-01,.1426E+00,.3070E+00,.2856E+00,.4038E+00,.5360E+00,.3815E+00,.2464E+00,.2483E+00,.2999E+00,& - .9739E-01,.1464E+00,.3139E+00,.2893E+00,.4059E+00,.5373E+00,.3823E+00,.2487E+00,.2497E+00,.3061E+00,& - .9964E-01,.1501E+00,.3207E+00,.2930E+00,.4079E+00,.5386E+00,.3831E+00,.2509E+00,.2510E+00,.3123E+00,& - .1020E+00,.1541E+00,.3280E+00,.2969E+00,.4100E+00,.5399E+00,.3840E+00,.2533E+00,.2525E+00,.3189E+00,& - .1044E+00,.1581E+00,.3353E+00,.3008E+00,.4120E+00,.5412E+00,.3848E+00,.2557E+00,.2540E+00,.3255E+00,& - .1068E+00,.1621E+00,.3425E+00,.3046E+00,.4141E+00,.5425E+00,.3857E+00,.2580E+00,.2555E+00,.3321E+00,& - .1091E+00,.1661E+00,.3498E+00,.3085E+00,.4161E+00,.5438E+00,.3866E+00,.2604E+00,.2570E+00,.3387E+00,& - .1115E+00,.1701E+00,.3571E+00,.3124E+00,.4182E+00,.5452E+00,.3875E+00,.2628E+00,.2585E+00,.3453E+00,& - .1139E+00,.1741E+00,.3644E+00,.3163E+00,.4203E+00,.5467E+00,.3886E+00,.2653E+00,.2602E+00,.3520E+00,& - .1164E+00,.1782E+00,.3718E+00,.3202E+00,.4224E+00,.5483E+00,.3898E+00,.2678E+00,.2619E+00,.3587E+00,& - .1188E+00,.1822E+00,.3791E+00,.3242E+00,.4245E+00,.5498E+00,.3909E+00,.2703E+00,.2636E+00,.3654E+00,& - .1212E+00,.1862E+00,.3865E+00,.3281E+00,.4266E+00,.5514E+00,.3920E+00,.2728E+00,.2653E+00,.3721E+00,& - .1236E+00,.1903E+00,.3938E+00,.3320E+00,.4288E+00,.5530E+00,.3932E+00,.2753E+00,.2670E+00,.3788E+00,& - .1261E+00,.1944E+00,.4014E+00,.3361E+00,.4309E+00,.5547E+00,.3945E+00,.2779E+00,.2689E+00,.3857E+00,& - .1285E+00,.1986E+00,.4090E+00,.3401E+00,.4331E+00,.5564E+00,.3957E+00,.2806E+00,.2708E+00,.3926E+00,& - .1310E+00,.2028E+00,.4166E+00,.3442E+00,.4353E+00,.5581E+00,.3970E+00,.2832E+00,.2727E+00,.3995E+00,& - .1335E+00,.2069E+00,.4242E+00,.3482E+00,.4374E+00,.5598E+00,.3983E+00,.2858E+00,.2746E+00,.4064E+00,& - .1360E+00,.2111E+00,.4318E+00,.3523E+00,.4396E+00,.5615E+00,.3996E+00,.2885E+00,.2765E+00,.4133E+00,& - .1387E+00,.2156E+00,.4400E+00,.3565E+00,.4418E+00,.5632E+00,.4010E+00,.2913E+00,.2785E+00,.4208E+00,& - .1413E+00,.2201E+00,.4481E+00,.3608E+00,.4439E+00,.5648E+00,.4023E+00,.2941E+00,.2806E+00,.4282E+00,& - .1440E+00,.2246E+00,.4563E+00,.3651E+00,.4460E+00,.5665E+00,.4036E+00,.2969E+00,.2826E+00,.4357E+00,& - .1467E+00,.2291E+00,.4645E+00,.3693E+00,.4482E+00,.5681E+00,.4049E+00,.2997E+00,.2846E+00,.4431E+00,& - .1493E+00,.2336E+00,.4727E+00,.3736E+00,.4503E+00,.5698E+00,.4063E+00,.3025E+00,.2867E+00,.4505E+00,& - .1522E+00,.2383E+00,.4813E+00,.3781E+00,.4525E+00,.5715E+00,.4077E+00,.3055E+00,.2889E+00,.4584E+00,& - .1550E+00,.2431E+00,.4899E+00,.3825E+00,.4547E+00,.5732E+00,.4091E+00,.3085E+00,.2911E+00,.4662E+00,& - .1578E+00,.2478E+00,.4985E+00,.3870E+00,.4569E+00,.5749E+00,.4105E+00,.3114E+00,.2933E+00,.4740E+00,& - .1607E+00,.2525E+00,.5071E+00,.3914E+00,.4591E+00,.5766E+00,.4119E+00,.3144E+00,.2956E+00,.4819E+00,& - .1635E+00,.2573E+00,.5157E+00,.3958E+00,.4613E+00,.5784E+00,.4133E+00,.3173E+00,.2978E+00,.4897E+00,& - .1676E+00,.2644E+00,.5283E+00,.4017E+00,.4627E+00,.5786E+00,.4139E+00,.3210E+00,.3000E+00,.5010E+00,& - .1718E+00,.2714E+00,.5409E+00,.4075E+00,.4642E+00,.5788E+00,.4145E+00,.3246E+00,.3023E+00,.5124E+00,& - .1759E+00,.2785E+00,.5535E+00,.4133E+00,.4657E+00,.5790E+00,.4151E+00,.3282E+00,.3045E+00,.5238E+00,& - .1801E+00,.2856E+00,.5661E+00,.4192E+00,.4672E+00,.5793E+00,.4157E+00,.3318E+00,.3067E+00,.5351E+00,& - .1843E+00,.2926E+00,.5787E+00,.4250E+00,.4687E+00,.5795E+00,.4163E+00,.3355E+00,.3090E+00,.5465E+00,& - .1886E+00,.3001E+00,.5920E+00,.4311E+00,.4703E+00,.5799E+00,.4171E+00,.3394E+00,.3115E+00,.5584E+00,& - .1930E+00,.3075E+00,.6052E+00,.4372E+00,.4718E+00,.5803E+00,.4179E+00,.3433E+00,.3141E+00,.5704E+00,& - .1973E+00,.3149E+00,.6184E+00,.4433E+00,.4734E+00,.5807E+00,.4187E+00,.3472E+00,.3167E+00,.5823E+00,& - .2017E+00,.3224E+00,.6317E+00,.4494E+00,.4749E+00,.5811E+00,.4195E+00,.3511E+00,.3193E+00,.5943E+00,& - .2061E+00,.3298E+00,.6449E+00,.4555E+00,.4765E+00,.5815E+00,.4203E+00,.3550E+00,.3219E+00,.6062E+00,& - .2109E+00,.3380E+00,.6595E+00,.4622E+00,.4779E+00,.5816E+00,.4211E+00,.3592E+00,.3247E+00,.6194E+00,& - .2158E+00,.3464E+00,.6743E+00,.4688E+00,.4793E+00,.5818E+00,.4219E+00,.3635E+00,.3275E+00,.6327E+00,& - .2207E+00,.3547E+00,.6892E+00,.4756E+00,.4809E+00,.5820E+00,.4227E+00,.3678E+00,.3305E+00,.6462E+00,& - .2274E+00,.3662E+00,.7093E+00,.4841E+00,.4814E+00,.5803E+00,.4225E+00,.3731E+00,.3335E+00,.6643E+00,& - .2341E+00,.3777E+00,.7295E+00,.4927E+00,.4819E+00,.5787E+00,.4224E+00,.3784E+00,.3366E+00,.6825E+00,& - .2409E+00,.3893E+00,.7500E+00,.5014E+00,.4826E+00,.5773E+00,.4225E+00,.3838E+00,.3399E+00,.7008E+00,& - .2494E+00,.4039E+00,.7756E+00,.5119E+00,.4824E+00,.5741E+00,.4217E+00,.3902E+00,.3433E+00,.7238E+00,& - .2580E+00,.4187E+00,.8014E+00,.5224E+00,.4823E+00,.5711E+00,.4210E+00,.3967E+00,.3470E+00,.7470E+00,& - .2682E+00,.4364E+00,.8323E+00,.5348E+00,.4814E+00,.5666E+00,.4197E+00,.4042E+00,.3509E+00,.7746E+00,& - .2802E+00,.4571E+00,.8683E+00,.5490E+00,.4799E+00,.5608E+00,.4179E+00,.4128E+00,.3553E+00,.8069E+00,& - .2922E+00,.4777E+00,.9044E+00,.5633E+00,.4787E+00,.5555E+00,.4164E+00,.4215E+00,.3601E+00,.8392E+00,& - .3074E+00,.5040E+00,.9500E+00,.5810E+00,.4762E+00,.5476E+00,.4138E+00,.4323E+00,.3656E+00,.8800E+00,& - .3225E+00,.5301E+00,.9955E+00,.5988E+00,.4743E+00,.5406E+00,.4119E+00,.4433E+00,.3717E+00,.9208E+00,& - .3407E+00,.5615E+00,.1050E+01,.6200E+00,.4715E+00,.5318E+00,.4095E+00,.4565E+00,.3790E+00,.9696E+00,& - .3647E+00,.6029E+00,.1122E+01,.6478E+00,.4673E+00,.5196E+00,.4061E+00,.4737E+00,.3885E+00,.1034E+01,& - .3910E+00,.6484E+00,.1201E+01,.6785E+00,.4635E+00,.5077E+00,.4032E+00,.4931E+00,.3999E+00,.1105E+01,& - .4247E+00,.7066E+00,.1303E+01,.7180E+00,.4593E+00,.4934E+00,.4006E+00,.5185E+00,.4155E+00,.1196E+01,& - .4744E+00,.7923E+00,.1452E+01,.7771E+00,.4550E+00,.4755E+00,.3989E+00,.5567E+00,.4407E+00,.1330E+01,& - .5577E+00,.9357E+00,.1703E+01,.8795E+00,.4557E+00,.4561E+00,.4035E+00,.6251E+00,.4905E+00,.1556E+01/ - data (((Bex_lw(ai,k,nh),ai= 2, 2),k=1,nwl_lw),nh=0,99)/ & - .9514E-01,.1469E+00,.2331E+00,.3161E+00,.3718E+00,.4177E+00,.4740E+00,.6076E+00,.9329E+00,.1995E+00,& - .9518E-01,.1469E+00,.2332E+00,.3162E+00,.3719E+00,.4178E+00,.4741E+00,.6078E+00,.9333E+00,.1995E+00,& - .9521E-01,.1470E+00,.2333E+00,.3163E+00,.3721E+00,.4180E+00,.4743E+00,.6081E+00,.9336E+00,.1996E+00,& - .9525E-01,.1470E+00,.2334E+00,.3164E+00,.3722E+00,.4181E+00,.4745E+00,.6083E+00,.9340E+00,.1997E+00,& - .9528E-01,.1471E+00,.2335E+00,.3165E+00,.3724E+00,.4183E+00,.4747E+00,.6085E+00,.9344E+00,.1998E+00,& - .9532E-01,.1471E+00,.2335E+00,.3167E+00,.3725E+00,.4184E+00,.4748E+00,.6088E+00,.9347E+00,.1999E+00,& - .9535E-01,.1472E+00,.2336E+00,.3168E+00,.3726E+00,.4186E+00,.4750E+00,.6090E+00,.9350E+00,.1999E+00,& - .9538E-01,.1472E+00,.2337E+00,.3169E+00,.3727E+00,.4187E+00,.4751E+00,.6092E+00,.9354E+00,.2000E+00,& - .9541E-01,.1473E+00,.2337E+00,.3170E+00,.3728E+00,.4188E+00,.4753E+00,.6094E+00,.9357E+00,.2000E+00,& - .9544E-01,.1473E+00,.2338E+00,.3170E+00,.3730E+00,.4190E+00,.4754E+00,.6096E+00,.9360E+00,.2001E+00,& - .9547E-01,.1473E+00,.2339E+00,.3171E+00,.3731E+00,.4191E+00,.4756E+00,.6098E+00,.9364E+00,.2001E+00,& - .9550E-01,.1474E+00,.2339E+00,.3172E+00,.3732E+00,.4192E+00,.4757E+00,.6099E+00,.9367E+00,.2002E+00,& - .9552E-01,.1474E+00,.2340E+00,.3173E+00,.3733E+00,.4193E+00,.4758E+00,.6101E+00,.9370E+00,.2002E+00,& - .9554E-01,.1475E+00,.2341E+00,.3174E+00,.3734E+00,.4194E+00,.4760E+00,.6103E+00,.9373E+00,.2003E+00,& - .9556E-01,.1475E+00,.2341E+00,.3175E+00,.3735E+00,.4195E+00,.4761E+00,.6104E+00,.9376E+00,.2003E+00,& - .9558E-01,.1476E+00,.2342E+00,.3175E+00,.3736E+00,.4197E+00,.4762E+00,.6106E+00,.9379E+00,.2004E+00,& - .9561E-01,.1476E+00,.2342E+00,.3176E+00,.3737E+00,.4198E+00,.4764E+00,.6107E+00,.9381E+00,.2004E+00,& - .9564E-01,.1476E+00,.2343E+00,.3177E+00,.3738E+00,.4199E+00,.4765E+00,.6109E+00,.9383E+00,.2005E+00,& - .9566E-01,.1477E+00,.2344E+00,.3178E+00,.3739E+00,.4199E+00,.4766E+00,.6110E+00,.9385E+00,.2005E+00,& - .9569E-01,.1477E+00,.2344E+00,.3179E+00,.3739E+00,.4200E+00,.4767E+00,.6112E+00,.9387E+00,.2006E+00,& - .9571E-01,.1477E+00,.2345E+00,.3179E+00,.3740E+00,.4201E+00,.4768E+00,.6113E+00,.9389E+00,.2006E+00,& - .9573E-01,.1477E+00,.2345E+00,.3180E+00,.3741E+00,.4202E+00,.4769E+00,.6114E+00,.9392E+00,.2007E+00,& - .9575E-01,.1478E+00,.2346E+00,.3181E+00,.3742E+00,.4203E+00,.4770E+00,.6116E+00,.9394E+00,.2007E+00,& - .9577E-01,.1478E+00,.2346E+00,.3181E+00,.3742E+00,.4204E+00,.4770E+00,.6117E+00,.9396E+00,.2007E+00,& - .9578E-01,.1478E+00,.2346E+00,.3182E+00,.3743E+00,.4205E+00,.4771E+00,.6118E+00,.9399E+00,.2008E+00,& - .9580E-01,.1478E+00,.2347E+00,.3182E+00,.3744E+00,.4205E+00,.4772E+00,.6119E+00,.9401E+00,.2008E+00,& - .9582E-01,.1479E+00,.2347E+00,.3183E+00,.3744E+00,.4206E+00,.4773E+00,.6120E+00,.9403E+00,.2008E+00,& - .9583E-01,.1479E+00,.2348E+00,.3183E+00,.3745E+00,.4207E+00,.4774E+00,.6121E+00,.9404E+00,.2009E+00,& - .9585E-01,.1479E+00,.2348E+00,.3184E+00,.3746E+00,.4207E+00,.4775E+00,.6122E+00,.9406E+00,.2009E+00,& - .9587E-01,.1479E+00,.2348E+00,.3184E+00,.3746E+00,.4208E+00,.4775E+00,.6124E+00,.9408E+00,.2009E+00,& - .9588E-01,.1480E+00,.2349E+00,.3185E+00,.3747E+00,.4209E+00,.4776E+00,.6125E+00,.9410E+00,.2010E+00,& - .9589E-01,.1480E+00,.2349E+00,.3185E+00,.3747E+00,.4209E+00,.4777E+00,.6125E+00,.9411E+00,.2010E+00,& - .9590E-01,.1480E+00,.2349E+00,.3186E+00,.3748E+00,.4210E+00,.4778E+00,.6126E+00,.9413E+00,.2010E+00,& - .9591E-01,.1480E+00,.2350E+00,.3186E+00,.3748E+00,.4211E+00,.4778E+00,.6127E+00,.9414E+00,.2011E+00,& - .9592E-01,.1480E+00,.2350E+00,.3187E+00,.3749E+00,.4211E+00,.4779E+00,.6128E+00,.9416E+00,.2011E+00,& - .9592E-01,.1481E+00,.2351E+00,.3187E+00,.3750E+00,.4212E+00,.4780E+00,.6129E+00,.9418E+00,.2011E+00,& - .9594E-01,.1481E+00,.2351E+00,.3188E+00,.3750E+00,.4212E+00,.4780E+00,.6130E+00,.9419E+00,.2011E+00,& - .9595E-01,.1481E+00,.2351E+00,.3188E+00,.3750E+00,.4213E+00,.4781E+00,.6131E+00,.9420E+00,.2012E+00,& - .9597E-01,.1481E+00,.2351E+00,.3188E+00,.3751E+00,.4213E+00,.4781E+00,.6132E+00,.9421E+00,.2012E+00,& - .9598E-01,.1482E+00,.2352E+00,.3189E+00,.3751E+00,.4214E+00,.4782E+00,.6133E+00,.9423E+00,.2012E+00,& - .9599E-01,.1482E+00,.2352E+00,.3189E+00,.3752E+00,.4214E+00,.4782E+00,.6133E+00,.9424E+00,.2012E+00,& - .9600E-01,.1482E+00,.2352E+00,.3189E+00,.3752E+00,.4215E+00,.4783E+00,.6134E+00,.9425E+00,.2013E+00,& - .9601E-01,.1482E+00,.2352E+00,.3190E+00,.3752E+00,.4215E+00,.4784E+00,.6135E+00,.9426E+00,.2013E+00,& - .9601E-01,.1482E+00,.2353E+00,.3190E+00,.3753E+00,.4216E+00,.4784E+00,.6135E+00,.9427E+00,.2013E+00,& - .9602E-01,.1482E+00,.2353E+00,.3190E+00,.3753E+00,.4216E+00,.4785E+00,.6136E+00,.9427E+00,.2013E+00,& - .9603E-01,.1482E+00,.2353E+00,.3190E+00,.3754E+00,.4216E+00,.4785E+00,.6137E+00,.9428E+00,.2013E+00,& - .9604E-01,.1482E+00,.2353E+00,.3191E+00,.3754E+00,.4217E+00,.4786E+00,.6137E+00,.9430E+00,.2014E+00,& - .9605E-01,.1483E+00,.2354E+00,.3191E+00,.3754E+00,.4217E+00,.4786E+00,.6138E+00,.9431E+00,.2014E+00,& - .9606E-01,.1483E+00,.2354E+00,.3192E+00,.3755E+00,.4218E+00,.4787E+00,.6138E+00,.9432E+00,.2014E+00,& - .9607E-01,.1483E+00,.2354E+00,.3192E+00,.3755E+00,.4218E+00,.4787E+00,.6139E+00,.9434E+00,.2014E+00,& - .9608E-01,.1483E+00,.2354E+00,.3192E+00,.3755E+00,.4219E+00,.4788E+00,.6140E+00,.9435E+00,.2014E+00,& - .9609E-01,.1483E+00,.2354E+00,.3193E+00,.3756E+00,.4219E+00,.4788E+00,.6140E+00,.9436E+00,.2015E+00,& - .9609E-01,.1483E+00,.2354E+00,.3193E+00,.3756E+00,.4219E+00,.4788E+00,.6141E+00,.9437E+00,.2015E+00,& - .9610E-01,.1483E+00,.2355E+00,.3193E+00,.3757E+00,.4220E+00,.4789E+00,.6141E+00,.9438E+00,.2015E+00,& - .9610E-01,.1483E+00,.2355E+00,.3193E+00,.3757E+00,.4220E+00,.4789E+00,.6142E+00,.9439E+00,.2015E+00,& - .9610E-01,.1484E+00,.2355E+00,.3193E+00,.3757E+00,.4220E+00,.4790E+00,.6142E+00,.9440E+00,.2015E+00,& - .9677E-01,.1494E+00,.2373E+00,.3213E+00,.3776E+00,.4240E+00,.4810E+00,.6167E+00,.9467E+00,.2030E+00,& - .9744E-01,.1504E+00,.2390E+00,.3233E+00,.3796E+00,.4260E+00,.4831E+00,.6191E+00,.9495E+00,.2045E+00,& - .9812E-01,.1514E+00,.2408E+00,.3253E+00,.3815E+00,.4280E+00,.4851E+00,.6215E+00,.9523E+00,.2059E+00,& - .9879E-01,.1524E+00,.2425E+00,.3272E+00,.3834E+00,.4300E+00,.4872E+00,.6239E+00,.9551E+00,.2074E+00,& - .9946E-01,.1534E+00,.2443E+00,.3292E+00,.3853E+00,.4319E+00,.4892E+00,.6264E+00,.9579E+00,.2089E+00,& - .9947E-01,.1535E+00,.2443E+00,.3292E+00,.3853E+00,.4320E+00,.4893E+00,.6264E+00,.9579E+00,.2089E+00,& - .9948E-01,.1535E+00,.2443E+00,.3292E+00,.3853E+00,.4320E+00,.4893E+00,.6265E+00,.9580E+00,.2089E+00,& - .9949E-01,.1535E+00,.2443E+00,.3293E+00,.3854E+00,.4320E+00,.4894E+00,.6265E+00,.9580E+00,.2089E+00,& - .9950E-01,.1535E+00,.2443E+00,.3293E+00,.3854E+00,.4321E+00,.4894E+00,.6265E+00,.9581E+00,.2089E+00,& - .9951E-01,.1535E+00,.2443E+00,.3293E+00,.3854E+00,.4321E+00,.4894E+00,.6266E+00,.9581E+00,.2089E+00,& - .1016E+00,.1566E+00,.2498E+00,.3352E+00,.3910E+00,.4379E+00,.4954E+00,.6336E+00,.9659E+00,.2135E+00,& - .1036E+00,.1598E+00,.2552E+00,.3411E+00,.3966E+00,.4436E+00,.5013E+00,.6406E+00,.9737E+00,.2181E+00,& - .1056E+00,.1629E+00,.2606E+00,.3470E+00,.4022E+00,.4494E+00,.5073E+00,.6476E+00,.9815E+00,.2226E+00,& - .1077E+00,.1660E+00,.2660E+00,.3528E+00,.4078E+00,.4552E+00,.5132E+00,.6547E+00,.9893E+00,.2272E+00,& - .1097E+00,.1691E+00,.2714E+00,.3587E+00,.4134E+00,.4609E+00,.5192E+00,.6617E+00,.9971E+00,.2318E+00,& - .1156E+00,.1780E+00,.2871E+00,.3745E+00,.4276E+00,.4753E+00,.5338E+00,.6790E+00,.1015E+01,.2450E+00,& - .1214E+00,.1870E+00,.3027E+00,.3902E+00,.4418E+00,.4896E+00,.5484E+00,.6963E+00,.1033E+01,.2583E+00,& - .1272E+00,.1959E+00,.3183E+00,.4060E+00,.4560E+00,.5040E+00,.5630E+00,.7136E+00,.1052E+01,.2715E+00,& - .1330E+00,.2048E+00,.3340E+00,.4217E+00,.4702E+00,.5183E+00,.5776E+00,.7309E+00,.1070E+01,.2848E+00,& - .1389E+00,.2137E+00,.3496E+00,.4375E+00,.4843E+00,.5327E+00,.5922E+00,.7482E+00,.1088E+01,.2980E+00,& - .1469E+00,.2261E+00,.3716E+00,.4570E+00,.5003E+00,.5485E+00,.6081E+00,.7674E+00,.1106E+01,.3168E+00,& - .1549E+00,.2385E+00,.3936E+00,.4766E+00,.5163E+00,.5643E+00,.6240E+00,.7865E+00,.1125E+01,.3356E+00,& - .1628E+00,.2508E+00,.4155E+00,.4961E+00,.5322E+00,.5802E+00,.6399E+00,.8057E+00,.1143E+01,.3544E+00,& - .1708E+00,.2632E+00,.4375E+00,.5156E+00,.5482E+00,.5960E+00,.6558E+00,.8249E+00,.1162E+01,.3732E+00,& - .1788E+00,.2756E+00,.4595E+00,.5351E+00,.5642E+00,.6118E+00,.6717E+00,.8441E+00,.1180E+01,.3920E+00,& - .1915E+00,.2955E+00,.4950E+00,.5642E+00,.5863E+00,.6335E+00,.6933E+00,.8707E+00,.1204E+01,.4226E+00,& - .2002E+00,.3090E+00,.5193E+00,.5834E+00,.6006E+00,.6474E+00,.7072E+00,.8879E+00,.1219E+01,.4436E+00,& - .2134E+00,.3299E+00,.5568E+00,.6122E+00,.6214E+00,.6677E+00,.7273E+00,.9132E+00,.1241E+01,.4760E+00,& - .2225E+00,.3443E+00,.5824E+00,.6313E+00,.6350E+00,.6808E+00,.7402E+00,.9296E+00,.1255E+01,.4984E+00,& - .2364E+00,.3662E+00,.6219E+00,.6600E+00,.6547E+00,.6998E+00,.7590E+00,.9537E+00,.1274E+01,.5328E+00,& - .2506E+00,.3888E+00,.6626E+00,.6887E+00,.6738E+00,.7181E+00,.7771E+00,.9775E+00,.1293E+01,.5683E+00,& - .2603E+00,.4043E+00,.6904E+00,.7078E+00,.6863E+00,.7300E+00,.7889E+00,.9929E+00,.1305E+01,.5927E+00,& - .2751E+00,.4280E+00,.7332E+00,.7365E+00,.7045E+00,.7474E+00,.8060E+00,.1016E+01,.1322E+01,.6302E+00,& - .2852E+00,.4443E+00,.7625E+00,.7557E+00,.7165E+00,.7588E+00,.8172E+00,.1031E+01,.1333E+01,.6560E+00,& - .3007E+00,.4692E+00,.8074E+00,.7846E+00,.7340E+00,.7754E+00,.8335E+00,.1053E+01,.1349E+01,.6956E+00,& - .3165E+00,.4949E+00,.8536E+00,.8137E+00,.7512E+00,.7916E+00,.8495E+00,.1076E+01,.1364E+01,.7365E+00,& - .3328E+00,.5213E+00,.9012E+00,.8429E+00,.7681E+00,.8075E+00,.8651E+00,.1098E+01,.1379E+01,.7786E+00,& - .3495E+00,.5484E+00,.9503E+00,.8724E+00,.7847E+00,.8231E+00,.8805E+00,.1120E+01,.1393E+01,.8221E+00,& - .3725E+00,.5858E+00,.1018E+01,.9123E+00,.8065E+00,.8434E+00,.9004E+00,.1149E+01,.1412E+01,.8821E+00,& - .3962E+00,.6246E+00,.1088E+01,.9527E+00,.8280E+00,.8634E+00,.9201E+00,.1178E+01,.1429E+01,.9445E+00,& - .4270E+00,.6751E+00,.1179E+01,.1004E+01,.8546E+00,.8880E+00,.9443E+00,.1215E+01,.1451E+01,.1026E+01,& - .4722E+00,.7496E+00,.1313E+01,.1078E+01,.8915E+00,.9219E+00,.9776E+00,.1267E+01,.1479E+01,.1146E+01,& - .5273E+00,.8407E+00,.1477E+01,.1167E+01,.9337E+00,.9605E+00,.1016E+01,.1327E+01,.1511E+01,.1294E+01,& - .6812E+00,.1097E+01,.1939E+01,.1406E+01,.1042E+01,.1058E+01,.1111E+01,.1488E+01,.1588E+01,.1710E+01/ - data (((Bex_lw(ai,k,nh),ai= 3, 3),k=1,nwl_lw),nh=0,99)/ & - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01/ - data (((Bex_lw(ai,k,nh),ai= 4, 4),k=1,nwl_lw),nh=0,99)/ & - .4255E-01,.3839E-01,.3750E-01,.2284E-01,.6699E-01,.1081E+00,.5913E-01,.2771E-01,.1284E-01,.4138E-01,& - .4334E-01,.3951E-01,.3943E-01,.2379E-01,.6799E-01,.1091E+00,.5958E-01,.2844E-01,.1315E-01,.4306E-01,& - .4413E-01,.4063E-01,.4135E-01,.2474E-01,.6898E-01,.1102E+00,.6002E-01,.2916E-01,.1346E-01,.4475E-01,& - .4492E-01,.4174E-01,.4327E-01,.2569E-01,.6998E-01,.1113E+00,.6046E-01,.2989E-01,.1377E-01,.4644E-01,& - .4572E-01,.4286E-01,.4520E-01,.2664E-01,.7098E-01,.1124E+00,.6091E-01,.3061E-01,.1407E-01,.4813E-01,& - .4651E-01,.4398E-01,.4712E-01,.2759E-01,.7198E-01,.1134E+00,.6135E-01,.3133E-01,.1438E-01,.4982E-01,& - .4734E-01,.4518E-01,.4920E-01,.2861E-01,.7299E-01,.1145E+00,.6182E-01,.3210E-01,.1471E-01,.5165E-01,& - .4818E-01,.4639E-01,.5128E-01,.2964E-01,.7400E-01,.1156E+00,.6229E-01,.3287E-01,.1505E-01,.5348E-01,& - .4901E-01,.4759E-01,.5336E-01,.3067E-01,.7502E-01,.1167E+00,.6275E-01,.3364E-01,.1538E-01,.5532E-01,& - .4985E-01,.4879E-01,.5545E-01,.3170E-01,.7603E-01,.1178E+00,.6322E-01,.3441E-01,.1571E-01,.5715E-01,& - .5069E-01,.4999E-01,.5753E-01,.3273E-01,.7705E-01,.1189E+00,.6369E-01,.3518E-01,.1604E-01,.5899E-01,& - .5157E-01,.5128E-01,.5977E-01,.3384E-01,.7807E-01,.1200E+00,.6418E-01,.3599E-01,.1640E-01,.6096E-01,& - .5245E-01,.5257E-01,.6201E-01,.3495E-01,.7910E-01,.1211E+00,.6467E-01,.3680E-01,.1675E-01,.6294E-01,& - .5333E-01,.5386E-01,.6425E-01,.3606E-01,.8012E-01,.1223E+00,.6516E-01,.3762E-01,.1711E-01,.6492E-01,& - .5421E-01,.5514E-01,.6649E-01,.3717E-01,.8115E-01,.1234E+00,.6565E-01,.3843E-01,.1746E-01,.6690E-01,& - .5509E-01,.5643E-01,.6873E-01,.3828E-01,.8217E-01,.1245E+00,.6614E-01,.3924E-01,.1782E-01,.6888E-01,& - .5602E-01,.5781E-01,.7113E-01,.3947E-01,.8321E-01,.1256E+00,.6666E-01,.4010E-01,.1820E-01,.7101E-01,& - .5695E-01,.5918E-01,.7353E-01,.4066E-01,.8425E-01,.1267E+00,.6717E-01,.4097E-01,.1858E-01,.7314E-01,& - .5787E-01,.6056E-01,.7593E-01,.4185E-01,.8528E-01,.1279E+00,.6769E-01,.4183E-01,.1897E-01,.7526E-01,& - .5880E-01,.6193E-01,.7834E-01,.4304E-01,.8632E-01,.1290E+00,.6820E-01,.4269E-01,.1935E-01,.7739E-01,& - .5973E-01,.6331E-01,.8074E-01,.4424E-01,.8736E-01,.1301E+00,.6872E-01,.4355E-01,.1973E-01,.7952E-01,& - .6070E-01,.6477E-01,.8330E-01,.4551E-01,.8841E-01,.1313E+00,.6926E-01,.4446E-01,.2014E-01,.8180E-01,& - .6168E-01,.6623E-01,.8586E-01,.4678E-01,.8947E-01,.1324E+00,.6980E-01,.4537E-01,.2055E-01,.8407E-01,& - .6265E-01,.6769E-01,.8843E-01,.4805E-01,.9052E-01,.1336E+00,.7034E-01,.4628E-01,.2096E-01,.8635E-01,& - .6362E-01,.6916E-01,.9099E-01,.4932E-01,.9157E-01,.1347E+00,.7088E-01,.4719E-01,.2137E-01,.8863E-01,& - .6460E-01,.7062E-01,.9355E-01,.5059E-01,.9262E-01,.1358E+00,.7142E-01,.4809E-01,.2178E-01,.9091E-01,& - .6562E-01,.7217E-01,.9628E-01,.5195E-01,.9369E-01,.1370E+00,.7198E-01,.4905E-01,.2222E-01,.9334E-01,& - .6664E-01,.7372E-01,.9901E-01,.5331E-01,.9475E-01,.1382E+00,.7255E-01,.5001E-01,.2266E-01,.9577E-01,& - .6766E-01,.7528E-01,.1017E+00,.5466E-01,.9581E-01,.1393E+00,.7311E-01,.5097E-01,.2310E-01,.9820E-01,& - .6869E-01,.7683E-01,.1045E+00,.5602E-01,.9687E-01,.1405E+00,.7368E-01,.5193E-01,.2354E-01,.1006E+00,& - .6971E-01,.7838E-01,.1072E+00,.5737E-01,.9793E-01,.1416E+00,.7424E-01,.5289E-01,.2398E-01,.1031E+00,& - .7078E-01,.8002E-01,.1101E+00,.5881E-01,.9901E-01,.1428E+00,.7483E-01,.5390E-01,.2445E-01,.1057E+00,& - .7185E-01,.8167E-01,.1130E+00,.6025E-01,.1001E+00,.1440E+00,.7543E-01,.5491E-01,.2492E-01,.1082E+00,& - .7292E-01,.8331E-01,.1159E+00,.6169E-01,.1012E+00,.1451E+00,.7602E-01,.5592E-01,.2539E-01,.1108E+00,& - .7399E-01,.8496E-01,.1188E+00,.6313E-01,.1022E+00,.1463E+00,.7661E-01,.5693E-01,.2586E-01,.1134E+00,& - .7507E-01,.8660E-01,.1217E+00,.6456E-01,.1033E+00,.1475E+00,.7721E-01,.5794E-01,.2633E-01,.1160E+00,& - .7619E-01,.8833E-01,.1248E+00,.6608E-01,.1044E+00,.1486E+00,.7782E-01,.5900E-01,.2683E-01,.1187E+00,& - .7731E-01,.9007E-01,.1278E+00,.6761E-01,.1055E+00,.1498E+00,.7844E-01,.6006E-01,.2734E-01,.1215E+00,& - .7843E-01,.9180E-01,.1309E+00,.6913E-01,.1066E+00,.1510E+00,.7906E-01,.6112E-01,.2784E-01,.1242E+00,& - .7955E-01,.9353E-01,.1340E+00,.7065E-01,.1077E+00,.1522E+00,.7968E-01,.6218E-01,.2834E-01,.1269E+00,& - .8067E-01,.9527E-01,.1370E+00,.7217E-01,.1088E+00,.1534E+00,.8030E-01,.6324E-01,.2885E-01,.1297E+00,& - .8185E-01,.9710E-01,.1402E+00,.7378E-01,.1099E+00,.1546E+00,.8095E-01,.6435E-01,.2939E-01,.1326E+00,& - .8302E-01,.9893E-01,.1435E+00,.7538E-01,.1110E+00,.1558E+00,.8159E-01,.6547E-01,.2992E-01,.1355E+00,& - .8419E-01,.1008E+00,.1467E+00,.7699E-01,.1121E+00,.1569E+00,.8223E-01,.6658E-01,.3046E-01,.1384E+00,& - .8537E-01,.1026E+00,.1500E+00,.7860E-01,.1132E+00,.1581E+00,.8288E-01,.6770E-01,.3100E-01,.1412E+00,& - .8654E-01,.1044E+00,.1532E+00,.8020E-01,.1143E+00,.1593E+00,.8352E-01,.6881E-01,.3154E-01,.1441E+00,& - .8777E-01,.1063E+00,.1566E+00,.8190E-01,.1154E+00,.1605E+00,.8420E-01,.6998E-01,.3211E-01,.1472E+00,& - .8899E-01,.1083E+00,.1600E+00,.8359E-01,.1165E+00,.1617E+00,.8487E-01,.7116E-01,.3269E-01,.1503E+00,& - .9022E-01,.1102E+00,.1634E+00,.8528E-01,.1176E+00,.1629E+00,.8554E-01,.7233E-01,.3326E-01,.1533E+00,& - .9145E-01,.1121E+00,.1668E+00,.8698E-01,.1188E+00,.1641E+00,.8621E-01,.7350E-01,.3384E-01,.1564E+00,& - .9267E-01,.1140E+00,.1703E+00,.8867E-01,.1199E+00,.1653E+00,.8689E-01,.7467E-01,.3441E-01,.1595E+00,& - .9415E-01,.1164E+00,.1745E+00,.9075E-01,.1212E+00,.1667E+00,.8767E-01,.7609E-01,.3511E-01,.1633E+00,& - .9563E-01,.1188E+00,.1787E+00,.9283E-01,.1224E+00,.1680E+00,.8846E-01,.7751E-01,.3581E-01,.1670E+00,& - .9710E-01,.1211E+00,.1829E+00,.9491E-01,.1237E+00,.1694E+00,.8925E-01,.7892E-01,.3650E-01,.1708E+00,& - .9858E-01,.1235E+00,.1871E+00,.9699E-01,.1250E+00,.1707E+00,.9004E-01,.8034E-01,.3720E-01,.1745E+00,& - .1001E+00,.1258E+00,.1913E+00,.9907E-01,.1263E+00,.1721E+00,.9082E-01,.8176E-01,.3789E-01,.1783E+00,& - .1016E+00,.1283E+00,.1957E+00,.1013E+00,.1276E+00,.1734E+00,.9165E-01,.8325E-01,.3864E-01,.1823E+00,& - .1031E+00,.1308E+00,.2001E+00,.1035E+00,.1289E+00,.1748E+00,.9247E-01,.8474E-01,.3939E-01,.1863E+00,& - .1047E+00,.1333E+00,.2046E+00,.1057E+00,.1302E+00,.1761E+00,.9329E-01,.8623E-01,.4014E-01,.1903E+00,& - .1062E+00,.1357E+00,.2090E+00,.1079E+00,.1315E+00,.1775E+00,.9412E-01,.8773E-01,.4089E-01,.1943E+00,& - .1078E+00,.1382E+00,.2134E+00,.1101E+00,.1327E+00,.1788E+00,.9494E-01,.8922E-01,.4164E-01,.1982E+00,& - .1092E+00,.1405E+00,.2175E+00,.1121E+00,.1340E+00,.1801E+00,.9575E-01,.9062E-01,.4237E-01,.2019E+00,& - .1107E+00,.1428E+00,.2216E+00,.1141E+00,.1352E+00,.1815E+00,.9657E-01,.9201E-01,.4309E-01,.2056E+00,& - .1121E+00,.1452E+00,.2258E+00,.1162E+00,.1365E+00,.1828E+00,.9738E-01,.9341E-01,.4382E-01,.2093E+00,& - .1136E+00,.1475E+00,.2299E+00,.1182E+00,.1377E+00,.1841E+00,.9819E-01,.9481E-01,.4455E-01,.2130E+00,& - .1150E+00,.1498E+00,.2340E+00,.1202E+00,.1389E+00,.1854E+00,.9901E-01,.9621E-01,.4528E-01,.2167E+00,& - .1167E+00,.1525E+00,.2388E+00,.1226E+00,.1403E+00,.1868E+00,.9991E-01,.9785E-01,.4614E-01,.2211E+00,& - .1184E+00,.1552E+00,.2437E+00,.1251E+00,.1416E+00,.1882E+00,.1008E+00,.9949E-01,.4699E-01,.2255E+00,& - .1201E+00,.1580E+00,.2486E+00,.1275E+00,.1430E+00,.1896E+00,.1017E+00,.1011E+00,.4785E-01,.2299E+00,& - .1218E+00,.1607E+00,.2535E+00,.1299E+00,.1443E+00,.1910E+00,.1026E+00,.1028E+00,.4870E-01,.2343E+00,& - .1235E+00,.1634E+00,.2584E+00,.1323E+00,.1457E+00,.1923E+00,.1035E+00,.1044E+00,.4956E-01,.2387E+00,& - .1260E+00,.1676E+00,.2659E+00,.1360E+00,.1476E+00,.1942E+00,.1048E+00,.1069E+00,.5083E-01,.2455E+00,& - .1285E+00,.1717E+00,.2734E+00,.1397E+00,.1495E+00,.1961E+00,.1061E+00,.1094E+00,.5210E-01,.2522E+00,& - .1311E+00,.1759E+00,.2809E+00,.1434E+00,.1514E+00,.1980E+00,.1074E+00,.1118E+00,.5337E-01,.2590E+00,& - .1336E+00,.1801E+00,.2884E+00,.1471E+00,.1533E+00,.1999E+00,.1088E+00,.1143E+00,.5464E-01,.2657E+00,& - .1361E+00,.1843E+00,.2959E+00,.1508E+00,.1552E+00,.2018E+00,.1101E+00,.1168E+00,.5591E-01,.2725E+00,& - .1396E+00,.1900E+00,.3063E+00,.1559E+00,.1577E+00,.2042E+00,.1118E+00,.1202E+00,.5767E-01,.2819E+00,& - .1431E+00,.1958E+00,.3168E+00,.1611E+00,.1601E+00,.2066E+00,.1136E+00,.1236E+00,.5943E-01,.2913E+00,& - .1466E+00,.2016E+00,.3272E+00,.1662E+00,.1626E+00,.2089E+00,.1154E+00,.1271E+00,.6119E-01,.3007E+00,& - .1501E+00,.2074E+00,.3376E+00,.1714E+00,.1650E+00,.2113E+00,.1172E+00,.1305E+00,.6296E-01,.3102E+00,& - .1535E+00,.2132E+00,.3481E+00,.1765E+00,.1675E+00,.2137E+00,.1189E+00,.1339E+00,.6472E-01,.3196E+00,& - .1580E+00,.2206E+00,.3615E+00,.1831E+00,.1705E+00,.2165E+00,.1212E+00,.1383E+00,.6697E-01,.3317E+00,& - .1624E+00,.2281E+00,.3751E+00,.1898E+00,.1736E+00,.2193E+00,.1235E+00,.1427E+00,.6928E-01,.3440E+00,& - .1670E+00,.2358E+00,.3890E+00,.1966E+00,.1766E+00,.2222E+00,.1258E+00,.1472E+00,.7165E-01,.3566E+00,& - .1717E+00,.2436E+00,.4032E+00,.2036E+00,.1797E+00,.2251E+00,.1281E+00,.1518E+00,.7407E-01,.3693E+00,& - .1778E+00,.2539E+00,.4219E+00,.2128E+00,.1837E+00,.2287E+00,.1312E+00,.1579E+00,.7725E-01,.3863E+00,& - .1841E+00,.2645E+00,.4410E+00,.2221E+00,.1877E+00,.2324E+00,.1343E+00,.1641E+00,.8051E-01,.4036E+00,& - .1919E+00,.2777E+00,.4651E+00,.2339E+00,.1926E+00,.2368E+00,.1382E+00,.1718E+00,.8457E-01,.4253E+00,& - .1999E+00,.2913E+00,.4897E+00,.2460E+00,.1976E+00,.2412E+00,.1422E+00,.1798E+00,.8879E-01,.4476E+00,& - .2096E+00,.3077E+00,.5195E+00,.2606E+00,.2035E+00,.2464E+00,.1470E+00,.1894E+00,.9389E-01,.4746E+00,& - .2194E+00,.3245E+00,.5501E+00,.2756E+00,.2095E+00,.2516E+00,.1520E+00,.1993E+00,.9917E-01,.5022E+00,& - .2311E+00,.3445E+00,.5862E+00,.2933E+00,.2164E+00,.2576E+00,.1577E+00,.2109E+00,.1054E+00,.5350E+00,& - .2446E+00,.3676E+00,.6284E+00,.3139E+00,.2244E+00,.2644E+00,.1646E+00,.2245E+00,.1128E+00,.5732E+00,& - .2619E+00,.3971E+00,.6820E+00,.3401E+00,.2343E+00,.2727E+00,.1731E+00,.2417E+00,.1222E+00,.6218E+00,& - .2813E+00,.4303E+00,.7424E+00,.3696E+00,.2454E+00,.2819E+00,.1828E+00,.2611E+00,.1329E+00,.6766E+00,& - .3081E+00,.4765E+00,.8264E+00,.4106E+00,.2604E+00,.2943E+00,.1962E+00,.2881E+00,.1480E+00,.7528E+00,& - .3431E+00,.5366E+00,.9357E+00,.4639E+00,.2797E+00,.3101E+00,.2137E+00,.3233E+00,.1679E+00,.8521E+00,& - .3848E+00,.6084E+00,.1066E+01,.5275E+00,.3026E+00,.3286E+00,.2347E+00,.3654E+00,.1922E+00,.9706E+00,& - .4548E+00,.7287E+00,.1285E+01,.6341E+00,.3407E+00,.3592E+00,.2700E+00,.4362E+00,.2340E+00,.1170E+01,& - .5711E+00,.9289E+00,.1649E+01,.8114E+00,.4040E+00,.4102E+00,.3293E+00,.5544E+00,.3062E+00,.1500E+01/ - data (((Bex_lw(ai,k,nh),ai= 5, 5),k=1,nwl_lw),nh=0,99)/ & - .5506E-01,.3918E-01,.2796E-01,.3351E-01,.6595E-01,.8195E-01,.6205E-01,.1181E+00,.2768E+00,.4168E-01,& - .5707E-01,.4229E-01,.3309E-01,.3612E-01,.6796E-01,.8445E-01,.6504E-01,.1233E+00,.2868E+00,.4650E-01,& - .5908E-01,.4539E-01,.3821E-01,.3872E-01,.6998E-01,.8695E-01,.6803E-01,.1285E+00,.2968E+00,.5133E-01,& - .6109E-01,.4849E-01,.4334E-01,.4133E-01,.7199E-01,.8944E-01,.7102E-01,.1336E+00,.3068E+00,.5616E-01,& - .6311E-01,.5160E-01,.4847E-01,.4393E-01,.7400E-01,.9194E-01,.7401E-01,.1388E+00,.3167E+00,.6099E-01,& - .6512E-01,.5470E-01,.5360E-01,.4654E-01,.7601E-01,.9444E-01,.7700E-01,.1440E+00,.3267E+00,.6582E-01,& - .6733E-01,.5826E-01,.5943E-01,.4954E-01,.7832E-01,.9730E-01,.8045E-01,.1499E+00,.3380E+00,.7138E-01,& - .6954E-01,.6183E-01,.6527E-01,.5253E-01,.8062E-01,.1002E+00,.8391E-01,.1559E+00,.3493E+00,.7693E-01,& - .7176E-01,.6540E-01,.7111E-01,.5553E-01,.8292E-01,.1030E+00,.8736E-01,.1618E+00,.3606E+00,.8249E-01,& - .7397E-01,.6896E-01,.7695E-01,.5852E-01,.8522E-01,.1059E+00,.9081E-01,.1677E+00,.3719E+00,.8805E-01,& - .7618E-01,.7253E-01,.8279E-01,.6152E-01,.8753E-01,.1087E+00,.9426E-01,.1737E+00,.3833E+00,.9361E-01,& - .7864E-01,.7662E-01,.8941E-01,.6493E-01,.9016E-01,.1120E+00,.9826E-01,.1805E+00,.3962E+00,.9996E-01,& - .8109E-01,.8070E-01,.9604E-01,.6835E-01,.9278E-01,.1153E+00,.1023E+00,.1873E+00,.4090E+00,.1063E+00,& - .8354E-01,.8479E-01,.1027E+00,.7177E-01,.9541E-01,.1185E+00,.1062E+00,.1941E+00,.4219E+00,.1127E+00,& - .8600E-01,.8888E-01,.1093E+00,.7518E-01,.9804E-01,.1218E+00,.1102E+00,.2009E+00,.4348E+00,.1190E+00,& - .8845E-01,.9296E-01,.1159E+00,.7860E-01,.1007E+00,.1250E+00,.1142E+00,.2076E+00,.4477E+00,.1254E+00,& - .9115E-01,.9755E-01,.1233E+00,.8241E-01,.1036E+00,.1287E+00,.1188E+00,.2153E+00,.4621E+00,.1325E+00,& - .9386E-01,.1021E+00,.1306E+00,.8622E-01,.1066E+00,.1324E+00,.1233E+00,.2229E+00,.4765E+00,.1396E+00,& - .9656E-01,.1067E+00,.1380E+00,.9003E-01,.1095E+00,.1361E+00,.1279E+00,.2306E+00,.4909E+00,.1467E+00,& - .9926E-01,.1113E+00,.1453E+00,.9383E-01,.1125E+00,.1397E+00,.1324E+00,.2382E+00,.5052E+00,.1539E+00,& - .1020E+00,.1159E+00,.1527E+00,.9764E-01,.1155E+00,.1434E+00,.1369E+00,.2459E+00,.5196E+00,.1610E+00,& - .1050E+00,.1211E+00,.1609E+00,.1019E+00,.1188E+00,.1476E+00,.1421E+00,.2545E+00,.5358E+00,.1689E+00,& - .1079E+00,.1262E+00,.1691E+00,.1061E+00,.1221E+00,.1517E+00,.1473E+00,.2631E+00,.5519E+00,.1769E+00,& - .1109E+00,.1314E+00,.1772E+00,.1104E+00,.1255E+00,.1559E+00,.1525E+00,.2717E+00,.5680E+00,.1849E+00,& - .1139E+00,.1365E+00,.1854E+00,.1146E+00,.1288E+00,.1600E+00,.1576E+00,.2804E+00,.5842E+00,.1928E+00,& - .1169E+00,.1417E+00,.1936E+00,.1189E+00,.1321E+00,.1642E+00,.1628E+00,.2890E+00,.6003E+00,.2008E+00,& - .1202E+00,.1474E+00,.2025E+00,.1236E+00,.1358E+00,.1688E+00,.1686E+00,.2986E+00,.6181E+00,.2096E+00,& - .1235E+00,.1531E+00,.2115E+00,.1282E+00,.1395E+00,.1735E+00,.1744E+00,.3081E+00,.6359E+00,.2183E+00,& - .1267E+00,.1588E+00,.2204E+00,.1329E+00,.1432E+00,.1781E+00,.1803E+00,.3177E+00,.6537E+00,.2271E+00,& - .1300E+00,.1645E+00,.2294E+00,.1375E+00,.1469E+00,.1827E+00,.1861E+00,.3273E+00,.6714E+00,.2358E+00,& - .1333E+00,.1702E+00,.2383E+00,.1422E+00,.1506E+00,.1874E+00,.1919E+00,.3369E+00,.6892E+00,.2446E+00,& - .1369E+00,.1766E+00,.2481E+00,.1473E+00,.1548E+00,.1926E+00,.1984E+00,.3476E+00,.7089E+00,.2542E+00,& - .1405E+00,.1829E+00,.2579E+00,.1524E+00,.1589E+00,.1978E+00,.2050E+00,.3583E+00,.7287E+00,.2639E+00,& - .1441E+00,.1892E+00,.2678E+00,.1576E+00,.1631E+00,.2030E+00,.2115E+00,.3690E+00,.7484E+00,.2736E+00,& - .1478E+00,.1956E+00,.2776E+00,.1627E+00,.1672E+00,.2082E+00,.2181E+00,.3797E+00,.7681E+00,.2832E+00,& - .1514E+00,.2019E+00,.2874E+00,.1678E+00,.1713E+00,.2134E+00,.2246E+00,.3904E+00,.7878E+00,.2929E+00,& - .1553E+00,.2088E+00,.2980E+00,.1734E+00,.1759E+00,.2191E+00,.2319E+00,.4021E+00,.8092E+00,.3034E+00,& - .1593E+00,.2158E+00,.3086E+00,.1790E+00,.1804E+00,.2249E+00,.2391E+00,.4139E+00,.8306E+00,.3139E+00,& - .1632E+00,.2227E+00,.3192E+00,.1845E+00,.1850E+00,.2306E+00,.2464E+00,.4256E+00,.8521E+00,.3244E+00,& - .1672E+00,.2296E+00,.3298E+00,.1901E+00,.1895E+00,.2364E+00,.2537E+00,.4374E+00,.8735E+00,.3349E+00,& - .1711E+00,.2366E+00,.3405E+00,.1957E+00,.1941E+00,.2421E+00,.2609E+00,.4491E+00,.8949E+00,.3454E+00,& - .1755E+00,.2442E+00,.3520E+00,.2017E+00,.1991E+00,.2485E+00,.2690E+00,.4621E+00,.9185E+00,.3568E+00,& - .1798E+00,.2518E+00,.3636E+00,.2078E+00,.2042E+00,.2549E+00,.2771E+00,.4751E+00,.9421E+00,.3683E+00,& - .1841E+00,.2594E+00,.3751E+00,.2139E+00,.2092E+00,.2613E+00,.2853E+00,.4881E+00,.9657E+00,.3798E+00,& - .1885E+00,.2671E+00,.3867E+00,.2199E+00,.2142E+00,.2677E+00,.2934E+00,.5011E+00,.9893E+00,.3913E+00,& - .1928E+00,.2747E+00,.3983E+00,.2260E+00,.2193E+00,.2741E+00,.3015E+00,.5141E+00,.1013E+01,.4028E+00,& - .1975E+00,.2830E+00,.4106E+00,.2325E+00,.2248E+00,.2811E+00,.3104E+00,.5282E+00,.1038E+01,.4151E+00,& - .2022E+00,.2912E+00,.4230E+00,.2391E+00,.2303E+00,.2881E+00,.3193E+00,.5424E+00,.1064E+01,.4275E+00,& - .2069E+00,.2995E+00,.4354E+00,.2456E+00,.2358E+00,.2951E+00,.3282E+00,.5565E+00,.1089E+01,.4398E+00,& - .2116E+00,.3078E+00,.4478E+00,.2521E+00,.2413E+00,.3021E+00,.3372E+00,.5706E+00,.1114E+01,.4522E+00,& - .2163E+00,.3161E+00,.4602E+00,.2587E+00,.2468E+00,.3091E+00,.3461E+00,.5848E+00,.1140E+01,.4645E+00,& - .2205E+00,.3235E+00,.4712E+00,.2645E+00,.2518E+00,.3154E+00,.3542E+00,.5975E+00,.1162E+01,.4756E+00,& - .2247E+00,.3309E+00,.4822E+00,.2703E+00,.2567E+00,.3217E+00,.3623E+00,.6103E+00,.1185E+01,.4866E+00,& - .2290E+00,.3383E+00,.4932E+00,.2761E+00,.2617E+00,.3281E+00,.3704E+00,.6230E+00,.1208E+01,.4976E+00,& - .2332E+00,.3458E+00,.5043E+00,.2819E+00,.2667E+00,.3344E+00,.3784E+00,.6357E+00,.1231E+01,.5086E+00,& - .2374E+00,.3532E+00,.5153E+00,.2877E+00,.2716E+00,.3408E+00,.3865E+00,.6485E+00,.1254E+01,.5197E+00,& - .2419E+00,.3611E+00,.5269E+00,.2939E+00,.2770E+00,.3476E+00,.3953E+00,.6621E+00,.1278E+01,.5314E+00,& - .2464E+00,.3690E+00,.5386E+00,.3001E+00,.2823E+00,.3544E+00,.4040E+00,.6758E+00,.1302E+01,.5431E+00,& - .2509E+00,.3770E+00,.5503E+00,.3063E+00,.2876E+00,.3612E+00,.4128E+00,.6894E+00,.1326E+01,.5548E+00,& - .2554E+00,.3849E+00,.5619E+00,.3125E+00,.2930E+00,.3681E+00,.4215E+00,.7031E+00,.1350E+01,.5665E+00,& - .2599E+00,.3928E+00,.5736E+00,.3186E+00,.2983E+00,.3749E+00,.4303E+00,.7167E+00,.1374E+01,.5782E+00,& - .2647E+00,.4012E+00,.5858E+00,.3252E+00,.3040E+00,.3822E+00,.4396E+00,.7312E+00,.1399E+01,.5905E+00,& - .2695E+00,.4096E+00,.5981E+00,.3317E+00,.3097E+00,.3895E+00,.4490E+00,.7456E+00,.1424E+01,.6028E+00,& - .2743E+00,.4180E+00,.6103E+00,.3382E+00,.3154E+00,.3968E+00,.4583E+00,.7601E+00,.1450E+01,.6151E+00,& - .2791E+00,.4264E+00,.6226E+00,.3447E+00,.3211E+00,.4041E+00,.4677E+00,.7746E+00,.1475E+01,.6274E+00,& - .2839E+00,.4348E+00,.6348E+00,.3512E+00,.3268E+00,.4114E+00,.4770E+00,.7891E+00,.1500E+01,.6398E+00,& - .2890E+00,.4438E+00,.6478E+00,.3581E+00,.3329E+00,.4193E+00,.4871E+00,.8046E+00,.1528E+01,.6529E+00,& - .2941E+00,.4528E+00,.6608E+00,.3651E+00,.3390E+00,.4272E+00,.4973E+00,.8202E+00,.1555E+01,.6660E+00,& - .2992E+00,.4618E+00,.6738E+00,.3720E+00,.3452E+00,.4351E+00,.5074E+00,.8358E+00,.1582E+01,.6792E+00,& - .3044E+00,.4708E+00,.6868E+00,.3789E+00,.3513E+00,.4430E+00,.5175E+00,.8513E+00,.1609E+01,.6923E+00,& - .3095E+00,.4798E+00,.6998E+00,.3859E+00,.3574E+00,.4509E+00,.5276E+00,.8669E+00,.1636E+01,.7055E+00,& - .3185E+00,.4955E+00,.7222E+00,.3979E+00,.3682E+00,.4648E+00,.5454E+00,.8941E+00,.1683E+01,.7281E+00,& - .3274E+00,.5111E+00,.7446E+00,.4098E+00,.3789E+00,.4786E+00,.5632E+00,.9213E+00,.1729E+01,.7508E+00,& - .3364E+00,.5268E+00,.7670E+00,.4218E+00,.3897E+00,.4925E+00,.5810E+00,.9484E+00,.1776E+01,.7735E+00,& - .3453E+00,.5425E+00,.7894E+00,.4338E+00,.4004E+00,.5064E+00,.5989E+00,.9756E+00,.1822E+01,.7962E+00,& - .3543E+00,.5581E+00,.8118E+00,.4458E+00,.4112E+00,.5202E+00,.6167E+00,.1003E+01,.1869E+01,.8188E+00,& - .3667E+00,.5796E+00,.8421E+00,.4621E+00,.4261E+00,.5396E+00,.6415E+00,.1040E+01,.1932E+01,.8497E+00,& - .3790E+00,.6011E+00,.8725E+00,.4784E+00,.4410E+00,.5589E+00,.6663E+00,.1078E+01,.1996E+01,.8805E+00,& - .3914E+00,.6226E+00,.9028E+00,.4947E+00,.4560E+00,.5782E+00,.6911E+00,.1115E+01,.2059E+01,.9113E+00,& - .4037E+00,.6441E+00,.9331E+00,.5110E+00,.4709E+00,.5975E+00,.7159E+00,.1152E+01,.2123E+01,.9422E+00,& - .4161E+00,.6656E+00,.9634E+00,.5274E+00,.4858E+00,.6168E+00,.7407E+00,.1190E+01,.2187E+01,.9730E+00,& - .4320E+00,.6933E+00,.1002E+01,.5481E+00,.5051E+00,.6419E+00,.7730E+00,.1238E+01,.2267E+01,.1012E+01,& - .4547E+00,.7327E+00,.1057E+01,.5778E+00,.5328E+00,.6778E+00,.8190E+00,.1306E+01,.2380E+01,.1068E+01,& - .4751E+00,.7679E+00,.1105E+01,.6043E+00,.5576E+00,.7101E+00,.8605E+00,.1368E+01,.2482E+01,.1118E+01,& - .4959E+00,.8038E+00,.1155E+01,.6311E+00,.5829E+00,.7430E+00,.9028E+00,.1430E+01,.2585E+01,.1169E+01,& - .5284E+00,.8597E+00,.1231E+01,.6728E+00,.6227E+00,.7947E+00,.9690E+00,.1527E+01,.2748E+01,.1247E+01,& - .5549E+00,.9054E+00,.1294E+01,.7069E+00,.6552E+00,.8370E+00,.1024E+01,.1607E+01,.2877E+01,.1311E+01,& - .5901E+00,.9658E+00,.1375E+01,.7517E+00,.6983E+00,.8933E+00,.1096E+01,.1712E+01,.3046E+01,.1395E+01,& - .6269E+00,.1028E+01,.1460E+01,.7982E+00,.7436E+00,.9522E+00,.1171E+01,.1821E+01,.3222E+01,.1482E+01,& - .6697E+00,.1101E+01,.1558E+01,.8521E+00,.7963E+00,.1021E+01,.1259E+01,.1949E+01,.3428E+01,.1583E+01,& - .7285E+00,.1201E+01,.1690E+01,.9254E+00,.8690E+00,.1116E+01,.1381E+01,.2122E+01,.3703E+01,.1720E+01,& - .7908E+00,.1307E+01,.1829E+01,.1003E+01,.9462E+00,.1217E+01,.1510E+01,.2305E+01,.3988E+01,.1864E+01,& - .8831E+00,.1462E+01,.2031E+01,.1116E+01,.1061E+01,.1367E+01,.1701E+01,.2575E+01,.4410E+01,.2074E+01,& - .9884E+00,.1638E+01,.2259E+01,.1244E+01,.1192E+01,.1538E+01,.1920E+01,.2880E+01,.4873E+01,.2311E+01,& - .1140E+01,.1890E+01,.2580E+01,.1426E+01,.1382E+01,.1787E+01,.2235E+01,.3315E+01,.5532E+01,.2646E+01,& - .1365E+01,.2259E+01,.3043E+01,.1691E+01,.1664E+01,.2155E+01,.2701E+01,.3947E+01,.6458E+01,.3131E+01,& - .1667E+01,.2750E+01,.3647E+01,.2042E+01,.2044E+01,.2652E+01,.3326E+01,.4784E+01,.7665E+01,.3767E+01,& - .2281E+01,.3727E+01,.4821E+01,.2736E+01,.2819E+01,.3660E+01,.4583E+01,.6425E+01,.9939E+01,.5007E+01,& - .3357E+01,.5397E+01,.6758E+01,.3914E+01,.4181E+01,.5420E+01,.6748E+01,.9167E+01,.1359E+02,.7068E+01,& - .6683E+01,.1032E+02,.1219E+02,.7377E+01,.8380E+01,.1077E+02,.1317E+02,.1689E+02,.2304E+02,.1290E+02/ - data (((Bex_lw(ai,k,nh),ai= 6, 6),k=1,nwl_lw),nh=0,99)/ & - .8507E-01,.1012E+00,.1020E+00,.1242E+00,.1501E+00,.1512E+00,.1408E+00,.1564E+00,.1616E+00,.1167E+00,& - .8754E-01,.1042E+00,.1045E+00,.1260E+00,.1530E+00,.1546E+00,.1443E+00,.1600E+00,.1653E+00,.1196E+00,& - .9001E-01,.1072E+00,.1070E+00,.1278E+00,.1559E+00,.1579E+00,.1478E+00,.1636E+00,.1690E+00,.1225E+00,& - .9247E-01,.1102E+00,.1095E+00,.1295E+00,.1588E+00,.1613E+00,.1513E+00,.1672E+00,.1727E+00,.1254E+00,& - .9494E-01,.1132E+00,.1120E+00,.1313E+00,.1617E+00,.1647E+00,.1547E+00,.1708E+00,.1765E+00,.1283E+00,& - .9741E-01,.1162E+00,.1145E+00,.1331E+00,.1646E+00,.1680E+00,.1582E+00,.1744E+00,.1802E+00,.1312E+00,& - .1001E+00,.1195E+00,.1174E+00,.1352E+00,.1677E+00,.1715E+00,.1621E+00,.1784E+00,.1842E+00,.1344E+00,& - .1028E+00,.1228E+00,.1203E+00,.1372E+00,.1708E+00,.1750E+00,.1660E+00,.1823E+00,.1883E+00,.1377E+00,& - .1055E+00,.1261E+00,.1233E+00,.1392E+00,.1740E+00,.1784E+00,.1699E+00,.1863E+00,.1924E+00,.1409E+00,& - .1082E+00,.1294E+00,.1262E+00,.1413E+00,.1771E+00,.1819E+00,.1738E+00,.1902E+00,.1964E+00,.1442E+00,& - .1109E+00,.1327E+00,.1291E+00,.1433E+00,.1802E+00,.1854E+00,.1777E+00,.1942E+00,.2005E+00,.1474E+00,& - .1138E+00,.1363E+00,.1324E+00,.1456E+00,.1835E+00,.1892E+00,.1818E+00,.1983E+00,.2046E+00,.1510E+00,& - .1168E+00,.1399E+00,.1357E+00,.1479E+00,.1868E+00,.1931E+00,.1858E+00,.2024E+00,.2088E+00,.1545E+00,& - .1197E+00,.1435E+00,.1389E+00,.1501E+00,.1901E+00,.1970E+00,.1899E+00,.2064E+00,.2129E+00,.1581E+00,& - .1226E+00,.1471E+00,.1422E+00,.1524E+00,.1934E+00,.2008E+00,.1939E+00,.2105E+00,.2171E+00,.1616E+00,& - .1256E+00,.1507E+00,.1455E+00,.1546E+00,.1968E+00,.2047E+00,.1980E+00,.2146E+00,.2213E+00,.1652E+00,& - .1287E+00,.1546E+00,.1491E+00,.1571E+00,.2003E+00,.2087E+00,.2024E+00,.2191E+00,.2258E+00,.1691E+00,& - .1319E+00,.1585E+00,.1527E+00,.1596E+00,.2038E+00,.2127E+00,.2069E+00,.2235E+00,.2303E+00,.1729E+00,& - .1351E+00,.1623E+00,.1563E+00,.1621E+00,.2073E+00,.2167E+00,.2114E+00,.2280E+00,.2349E+00,.1768E+00,& - .1383E+00,.1662E+00,.1599E+00,.1647E+00,.2109E+00,.2207E+00,.2158E+00,.2325E+00,.2394E+00,.1807E+00,& - .1415E+00,.1701E+00,.1635E+00,.1672E+00,.2144E+00,.2247E+00,.2203E+00,.2369E+00,.2439E+00,.1845E+00,& - .1449E+00,.1742E+00,.1674E+00,.1699E+00,.2182E+00,.2290E+00,.2249E+00,.2415E+00,.2483E+00,.1887E+00,& - .1484E+00,.1784E+00,.1712E+00,.1727E+00,.2220E+00,.2333E+00,.2295E+00,.2461E+00,.2528E+00,.1928E+00,& - .1518E+00,.1825E+00,.1751E+00,.1755E+00,.2257E+00,.2375E+00,.2342E+00,.2508E+00,.2572E+00,.1970E+00,& - .1553E+00,.1867E+00,.1790E+00,.1783E+00,.2295E+00,.2418E+00,.2388E+00,.2554E+00,.2616E+00,.2011E+00,& - .1587E+00,.1908E+00,.1829E+00,.1811E+00,.2333E+00,.2461E+00,.2434E+00,.2600E+00,.2660E+00,.2052E+00,& - .1624E+00,.1953E+00,.1870E+00,.1841E+00,.2373E+00,.2507E+00,.2484E+00,.2649E+00,.2711E+00,.2096E+00,& - .1661E+00,.1997E+00,.1912E+00,.1871E+00,.2413E+00,.2554E+00,.2534E+00,.2698E+00,.2762E+00,.2141E+00,& - .1698E+00,.2041E+00,.1953E+00,.1901E+00,.2454E+00,.2600E+00,.2584E+00,.2747E+00,.2812E+00,.2185E+00,& - .1735E+00,.2086E+00,.1995E+00,.1931E+00,.2494E+00,.2647E+00,.2634E+00,.2796E+00,.2863E+00,.2229E+00,& - .1772E+00,.2130E+00,.2036E+00,.1961E+00,.2534E+00,.2693E+00,.2684E+00,.2845E+00,.2914E+00,.2273E+00,& - .1812E+00,.2177E+00,.2080E+00,.1994E+00,.2577E+00,.2741E+00,.2736E+00,.2896E+00,.2960E+00,.2320E+00,& - .1852E+00,.2224E+00,.2124E+00,.2027E+00,.2620E+00,.2788E+00,.2789E+00,.2948E+00,.3005E+00,.2366E+00,& - .1892E+00,.2271E+00,.2168E+00,.2059E+00,.2663E+00,.2836E+00,.2842E+00,.3000E+00,.3051E+00,.2413E+00,& - .1932E+00,.2318E+00,.2212E+00,.2092E+00,.2706E+00,.2883E+00,.2894E+00,.3051E+00,.3097E+00,.2460E+00,& - .1972E+00,.2365E+00,.2256E+00,.2125E+00,.2749E+00,.2931E+00,.2947E+00,.3103E+00,.3142E+00,.2507E+00,& - .2014E+00,.2415E+00,.2302E+00,.2160E+00,.2795E+00,.2983E+00,.3001E+00,.3156E+00,.3198E+00,.2556E+00,& - .2057E+00,.2465E+00,.2349E+00,.2196E+00,.2840E+00,.3034E+00,.3055E+00,.3208E+00,.3253E+00,.2605E+00,& - .2099E+00,.2514E+00,.2395E+00,.2231E+00,.2886E+00,.3086E+00,.3109E+00,.3261E+00,.3309E+00,.2655E+00,& - .2142E+00,.2564E+00,.2441E+00,.2266E+00,.2932E+00,.3138E+00,.3163E+00,.3313E+00,.3364E+00,.2704E+00,& - .2184E+00,.2614E+00,.2488E+00,.2302E+00,.2978E+00,.3189E+00,.3217E+00,.3366E+00,.3420E+00,.2753E+00,& - .2230E+00,.2666E+00,.2536E+00,.2339E+00,.3026E+00,.3243E+00,.3276E+00,.3423E+00,.3470E+00,.2805E+00,& - .2275E+00,.2718E+00,.2585E+00,.2377E+00,.3074E+00,.3297E+00,.3335E+00,.3479E+00,.3521E+00,.2857E+00,& - .2320E+00,.2771E+00,.2634E+00,.2415E+00,.3122E+00,.3350E+00,.3394E+00,.3536E+00,.3571E+00,.2908E+00,& - .2366E+00,.2823E+00,.2683E+00,.2453E+00,.3170E+00,.3404E+00,.3453E+00,.3592E+00,.3622E+00,.2960E+00,& - .2411E+00,.2876E+00,.2732E+00,.2490E+00,.3218E+00,.3458E+00,.3512E+00,.3649E+00,.3672E+00,.3012E+00,& - .2459E+00,.2931E+00,.2783E+00,.2531E+00,.3269E+00,.3514E+00,.3570E+00,.3706E+00,.3728E+00,.3066E+00,& - .2507E+00,.2986E+00,.2834E+00,.2571E+00,.3321E+00,.3570E+00,.3629E+00,.3762E+00,.3784E+00,.3120E+00,& - .2555E+00,.3041E+00,.2885E+00,.2611E+00,.3372E+00,.3626E+00,.3687E+00,.3819E+00,.3840E+00,.3174E+00,& - .2603E+00,.3095E+00,.2936E+00,.2652E+00,.3423E+00,.3683E+00,.3745E+00,.3876E+00,.3896E+00,.3228E+00,& - .2651E+00,.3150E+00,.2987E+00,.2692E+00,.3474E+00,.3739E+00,.3804E+00,.3933E+00,.3952E+00,.3282E+00,& - .2692E+00,.3197E+00,.3030E+00,.2727E+00,.3518E+00,.3787E+00,.3855E+00,.3982E+00,.4000E+00,.3328E+00,& - .2734E+00,.3244E+00,.3073E+00,.2762E+00,.3562E+00,.3836E+00,.3907E+00,.4031E+00,.4048E+00,.3375E+00,& - .2775E+00,.3291E+00,.3117E+00,.2797E+00,.3606E+00,.3884E+00,.3958E+00,.4081E+00,.4097E+00,.3421E+00,& - .2817E+00,.3338E+00,.3160E+00,.2831E+00,.3650E+00,.3933E+00,.4009E+00,.4130E+00,.4145E+00,.3467E+00,& - .2858E+00,.3385E+00,.3204E+00,.2866E+00,.3693E+00,.3981E+00,.4061E+00,.4179E+00,.4193E+00,.3513E+00,& - .2902E+00,.3434E+00,.3248E+00,.2902E+00,.3739E+00,.4031E+00,.4114E+00,.4230E+00,.4238E+00,.3561E+00,& - .2945E+00,.3483E+00,.3293E+00,.2939E+00,.3784E+00,.4081E+00,.4168E+00,.4281E+00,.4283E+00,.3608E+00,& - .2988E+00,.3531E+00,.3338E+00,.2975E+00,.3830E+00,.4131E+00,.4222E+00,.4332E+00,.4328E+00,.3656E+00,& - .3031E+00,.3580E+00,.3383E+00,.3012E+00,.3875E+00,.4181E+00,.4275E+00,.4383E+00,.4373E+00,.3704E+00,& - .3075E+00,.3628E+00,.3428E+00,.3048E+00,.3921E+00,.4231E+00,.4329E+00,.4434E+00,.4418E+00,.3751E+00,& - .3120E+00,.3679E+00,.3475E+00,.3086E+00,.3968E+00,.4283E+00,.4382E+00,.4485E+00,.4467E+00,.3801E+00,& - .3165E+00,.3729E+00,.3521E+00,.3124E+00,.4016E+00,.4334E+00,.4434E+00,.4536E+00,.4516E+00,.3850E+00,& - .3210E+00,.3780E+00,.3567E+00,.3162E+00,.4063E+00,.4385E+00,.4487E+00,.4587E+00,.4564E+00,.3899E+00,& - .3255E+00,.3830E+00,.3614E+00,.3200E+00,.4111E+00,.4437E+00,.4539E+00,.4638E+00,.4613E+00,.3948E+00,& - .3301E+00,.3880E+00,.3660E+00,.3238E+00,.4158E+00,.4488E+00,.4592E+00,.4689E+00,.4662E+00,.3997E+00,& - .3348E+00,.3932E+00,.3708E+00,.3278E+00,.4208E+00,.4542E+00,.4647E+00,.4742E+00,.4715E+00,.4048E+00,& - .3395E+00,.3985E+00,.3756E+00,.3318E+00,.4257E+00,.4595E+00,.4703E+00,.4794E+00,.4769E+00,.4099E+00,& - .3442E+00,.4037E+00,.3804E+00,.3358E+00,.4307E+00,.4649E+00,.4758E+00,.4847E+00,.4822E+00,.4149E+00,& - .3489E+00,.4089E+00,.3852E+00,.3397E+00,.4356E+00,.4702E+00,.4813E+00,.4899E+00,.4876E+00,.4200E+00,& - .3536E+00,.4141E+00,.3900E+00,.3437E+00,.4405E+00,.4756E+00,.4869E+00,.4952E+00,.4929E+00,.4251E+00,& - .3609E+00,.4221E+00,.3974E+00,.3499E+00,.4482E+00,.4838E+00,.4956E+00,.5034E+00,.5002E+00,.4329E+00,& - .3683E+00,.4302E+00,.4047E+00,.3561E+00,.4558E+00,.4921E+00,.5043E+00,.5116E+00,.5075E+00,.4407E+00,& - .3756E+00,.4382E+00,.4121E+00,.3623E+00,.4635E+00,.5004E+00,.5130E+00,.5198E+00,.5148E+00,.4485E+00,& - .3830E+00,.4463E+00,.4195E+00,.3685E+00,.4711E+00,.5086E+00,.5217E+00,.5280E+00,.5221E+00,.4563E+00,& - .3903E+00,.4543E+00,.4269E+00,.3747E+00,.4787E+00,.5169E+00,.5304E+00,.5362E+00,.5294E+00,.4641E+00,& - .4018E+00,.4668E+00,.4382E+00,.3844E+00,.4907E+00,.5296E+00,.5433E+00,.5485E+00,.5414E+00,.4762E+00,& - .4132E+00,.4792E+00,.4496E+00,.3941E+00,.5026E+00,.5423E+00,.5562E+00,.5608E+00,.5534E+00,.4882E+00,& - .4247E+00,.4916E+00,.4610E+00,.4038E+00,.5145E+00,.5550E+00,.5690E+00,.5730E+00,.5654E+00,.5002E+00,& - .4362E+00,.5041E+00,.4723E+00,.4135E+00,.5264E+00,.5677E+00,.5819E+00,.5853E+00,.5774E+00,.5123E+00,& - .4476E+00,.5165E+00,.4837E+00,.4232E+00,.5383E+00,.5804E+00,.5947E+00,.5976E+00,.5894E+00,.5243E+00,& - .4603E+00,.5301E+00,.4961E+00,.4339E+00,.5514E+00,.5943E+00,.6091E+00,.6111E+00,.6012E+00,.5374E+00,& - .4796E+00,.5508E+00,.5149E+00,.4503E+00,.5713E+00,.6154E+00,.6312E+00,.6316E+00,.6205E+00,.5573E+00,& - .4993E+00,.5719E+00,.5341E+00,.4670E+00,.5916E+00,.6369E+00,.6532E+00,.6526E+00,.6387E+00,.5776E+00,& - .5195E+00,.5934E+00,.5537E+00,.4841E+00,.6123E+00,.6587E+00,.6748E+00,.6735E+00,.6575E+00,.5984E+00,& - .5436E+00,.6188E+00,.5769E+00,.5045E+00,.6370E+00,.6846E+00,.7005E+00,.6975E+00,.6822E+00,.6228E+00,& - .5683E+00,.6449E+00,.6006E+00,.5254E+00,.6623E+00,.7111E+00,.7273E+00,.7229E+00,.7073E+00,.6478E+00,& - .5936E+00,.6714E+00,.6247E+00,.5468E+00,.6882E+00,.7381E+00,.7550E+00,.7487E+00,.7309E+00,.6732E+00,& - .6213E+00,.7004E+00,.6510E+00,.5703E+00,.7163E+00,.7675E+00,.7851E+00,.7767E+00,.7555E+00,.7010E+00,& - .6535E+00,.7340E+00,.6815E+00,.5976E+00,.7490E+00,.8013E+00,.8183E+00,.8090E+00,.7846E+00,.7332E+00,& - .6925E+00,.7745E+00,.7182E+00,.6307E+00,.7885E+00,.8422E+00,.8585E+00,.8463E+00,.8223E+00,.7719E+00,& - .7409E+00,.8244E+00,.7634E+00,.6718E+00,.8374E+00,.8925E+00,.9092E+00,.8942E+00,.8675E+00,.8195E+00,& - .7951E+00,.8801E+00,.8139E+00,.7178E+00,.8917E+00,.9484E+00,.9654E+00,.9471E+00,.9159E+00,.8725E+00,& - .8780E+00,.9646E+00,.8904E+00,.7883E+00,.9746E+00,.1033E+01,.1048E+01,.1025E+01,.9917E+00,.9530E+00,& - .9790E+00,.1067E+01,.9831E+00,.8742E+00,.1075E+01,.1135E+01,.1150E+01,.1121E+01,.1080E+01,.1050E+01,& - .1111E+01,.1199E+01,.1102E+01,.9862E+00,.1205E+01,.1265E+01,.1276E+01,.1241E+01,.1198E+01,.1175E+01,& - .1314E+01,.1401E+01,.1286E+01,.1160E+01,.1404E+01,.1464E+01,.1471E+01,.1426E+01,.1373E+01,.1367E+01,& - .1600E+01,.1682E+01,.1542E+01,.1404E+01,.1679E+01,.1738E+01,.1738E+01,.1681E+01,.1614E+01,.1634E+01,& - .2137E+01,.2204E+01,.2019E+01,.1866E+01,.2190E+01,.2241E+01,.2229E+01,.2151E+01,.2071E+01,.2130E+01,& - .3477E+01,.3490E+01,.3204E+01,.3029E+01,.3436E+01,.3461E+01,.3423E+01,.3306E+01,.3196E+01,.3354E+01/ - data (((Bex_lw(ai,k,nh),ai= 7, 7),k=1,nwl_lw),nh=0,99)/ & - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01,& - .8683E-02,.1551E-01,.1820E-01,.2197E-01,.2804E-01,.3277E-01,.1600E-01,.1249E-01,.1821E-01,.1971E-01/ - data (((Bex_lw(ai,k,nh),ai= 8, 8),k=1,nwl_lw),nh=0,99)/ & - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01,& - .8847E-02,.1629E-01,.1937E-01,.2635E-01,.4616E-01,.3551E-01,.1831E-01,.2085E-01,.5223E-01,.2029E-01/ - data (((Bex_lw(ai,k,nh),ai= 9, 9),k=1,nwl_lw),nh=0,99)/ & - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01,& - .9779E-02,.2069E-01,.2495E-01,.4592E-01,.1183E+00,.4591E-01,.2685E-01,.5005E-01,.1435E+00,.2304E-01/ - data (((Bex_lw(ai,k,nh),ai=10,10),k=1,nwl_lw),nh=0,99)/ & - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01,& - .1381E-01,.3649E-01,.4082E-01,.9216E-01,.2424E+00,.6645E-01,.4494E-01,.1051E+00,.2604E+00,.3155E-01/ - data (((Bex_lw(ai,k,nh),ai=11,11),k=1,nwl_lw),nh=0,99)/ & - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01,& - .2548E-01,.6926E-01,.6668E-01,.1474E+00,.3136E+00,.8431E-01,.6692E-01,.1596E+00,.3098E+00,.4753E-01/ - data (((Bex_lw(ai,k,nh),ai=12,12),k=1,nwl_lw),nh=0,99)/ & - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01,& - .5039E-01,.1121E+00,.9657E-01,.1828E+00,.2895E+00,.9190E-01,.8718E-01,.1880E+00,.2788E+00,.7151E-01/ - data (((Bex_lw(ai,k,nh),ai=13,13),k=1,nwl_lw),nh=0,99)/ & - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01,& - .8052E-01,.1282E+00,.1071E+00,.1571E+00,.1802E+00,.7780E-01,.8968E-01,.1550E+00,.1732E+00,.8845E-01/ - data (((Bex_lw(ai,k,nh),ai=14,14),k=1,nwl_lw),nh=0,99)/ & - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01,& - .8101E-01,.9702E-01,.8537E-01,.9934E-01,.9658E-01,.5640E-01,.7138E-01,.9553E-01,.9179E-01,.7815E-01/ - data (((w0_lw(ai,k,nh),ai= 1, 1),k=1,nwl_lw),nh=0,99)/ & - .1325E-03,.1713E-02,.1149E-02,.1635E-02,.2001E-02,.1756E-02,.1147E-02,.4354E-02,.1745E-01,.1744E-02,& - .1309E-03,.1522E-02,.1084E-02,.1627E-02,.2007E-02,.1761E-02,.1167E-02,.4478E-02,.1816E-01,.1573E-02,& - .1292E-03,.1332E-02,.1018E-02,.1618E-02,.2013E-02,.1767E-02,.1188E-02,.4603E-02,.1887E-01,.1402E-02,& - .1275E-03,.1141E-02,.9531E-03,.1610E-02,.2019E-02,.1772E-02,.1208E-02,.4728E-02,.1958E-01,.1231E-02,& - .1258E-03,.9507E-03,.8878E-03,.1602E-02,.2025E-02,.1778E-02,.1228E-02,.4852E-02,.2029E-01,.1060E-02,& - .1242E-03,.7601E-03,.8225E-03,.1594E-02,.2031E-02,.1784E-02,.1248E-02,.4977E-02,.2100E-01,.8890E-03,& - .1232E-03,.7190E-03,.8014E-03,.1589E-02,.2039E-02,.1793E-02,.1275E-02,.5120E-02,.2184E-01,.8469E-03,& - .1223E-03,.6779E-03,.7803E-03,.1584E-02,.2048E-02,.1802E-02,.1301E-02,.5263E-02,.2267E-01,.8049E-03,& - .1214E-03,.6367E-03,.7592E-03,.1578E-02,.2057E-02,.1811E-02,.1327E-02,.5405E-02,.2351E-01,.7628E-03,& - .1204E-03,.5956E-03,.7381E-03,.1573E-02,.2066E-02,.1820E-02,.1354E-02,.5548E-02,.2434E-01,.7207E-03,& - .1195E-03,.5545E-03,.7170E-03,.1568E-02,.2075E-02,.1829E-02,.1380E-02,.5691E-02,.2518E-01,.6787E-03,& - .1191E-03,.5381E-03,.7072E-03,.1567E-02,.2087E-02,.1842E-02,.1413E-02,.5851E-02,.2613E-01,.6622E-03,& - .1187E-03,.5217E-03,.6973E-03,.1565E-02,.2099E-02,.1855E-02,.1445E-02,.6012E-02,.2708E-01,.6458E-03,& - .1184E-03,.5053E-03,.6874E-03,.1563E-02,.2111E-02,.1867E-02,.1478E-02,.6172E-02,.2803E-01,.6294E-03,& - .1180E-03,.4889E-03,.6776E-03,.1561E-02,.2123E-02,.1880E-02,.1511E-02,.6332E-02,.2898E-01,.6130E-03,& - .1176E-03,.4726E-03,.6677E-03,.1560E-02,.2135E-02,.1893E-02,.1544E-02,.6493E-02,.2993E-01,.5966E-03,& - .1175E-03,.4638E-03,.6620E-03,.1559E-02,.2149E-02,.1908E-02,.1583E-02,.6676E-02,.3104E-01,.5887E-03,& - .1175E-03,.4551E-03,.6564E-03,.1558E-02,.2162E-02,.1924E-02,.1623E-02,.6860E-02,.3216E-01,.5807E-03,& - .1174E-03,.4464E-03,.6507E-03,.1558E-02,.2176E-02,.1940E-02,.1663E-02,.7044E-02,.3327E-01,.5727E-03,& - .1173E-03,.4377E-03,.6450E-03,.1557E-02,.2190E-02,.1955E-02,.1703E-02,.7227E-02,.3439E-01,.5647E-03,& - .1172E-03,.4290E-03,.6394E-03,.1556E-02,.2204E-02,.1971E-02,.1743E-02,.7411E-02,.3550E-01,.5567E-03,& - .1174E-03,.4246E-03,.6367E-03,.1557E-02,.2220E-02,.1989E-02,.1791E-02,.7618E-02,.3678E-01,.5535E-03,& - .1176E-03,.4201E-03,.6341E-03,.1558E-02,.2237E-02,.2008E-02,.1839E-02,.7824E-02,.3805E-01,.5502E-03,& - .1177E-03,.4156E-03,.6315E-03,.1559E-02,.2253E-02,.2027E-02,.1886E-02,.8031E-02,.3932E-01,.5469E-03,& - .1179E-03,.4111E-03,.6288E-03,.1561E-02,.2270E-02,.2045E-02,.1934E-02,.8238E-02,.4060E-01,.5437E-03,& - .1181E-03,.4067E-03,.6262E-03,.1562E-02,.2286E-02,.2064E-02,.1982E-02,.8445E-02,.4187E-01,.5404E-03,& - .1185E-03,.4046E-03,.6257E-03,.1564E-02,.2305E-02,.2087E-02,.2038E-02,.8676E-02,.4331E-01,.5399E-03,& - .1190E-03,.4026E-03,.6252E-03,.1567E-02,.2324E-02,.2109E-02,.2095E-02,.8908E-02,.4475E-01,.5394E-03,& - .1194E-03,.4005E-03,.6246E-03,.1570E-02,.2343E-02,.2131E-02,.2151E-02,.9139E-02,.4619E-01,.5389E-03,& - .1198E-03,.3985E-03,.6241E-03,.1572E-02,.2362E-02,.2153E-02,.2207E-02,.9371E-02,.4763E-01,.5384E-03,& - .1202E-03,.3964E-03,.6235E-03,.1575E-02,.2381E-02,.2176E-02,.2263E-02,.9603E-02,.4907E-01,.5379E-03,& - .1208E-03,.3960E-03,.6246E-03,.1579E-02,.2402E-02,.2202E-02,.2329E-02,.9859E-02,.5069E-01,.5392E-03,& - .1214E-03,.3955E-03,.6256E-03,.1583E-02,.2424E-02,.2228E-02,.2394E-02,.1012E-01,.5231E-01,.5406E-03,& - .1220E-03,.3950E-03,.6267E-03,.1587E-02,.2445E-02,.2254E-02,.2459E-02,.1037E-01,.5392E-01,.5419E-03,& - .1226E-03,.3945E-03,.6277E-03,.1591E-02,.2467E-02,.2280E-02,.2525E-02,.1063E-01,.5554E-01,.5432E-03,& - .1233E-03,.3940E-03,.6287E-03,.1595E-02,.2488E-02,.2306E-02,.2590E-02,.1089E-01,.5716E-01,.5446E-03,& - .1241E-03,.3948E-03,.6312E-03,.1601E-02,.2513E-02,.2336E-02,.2664E-02,.1117E-01,.5892E-01,.5473E-03,& - .1248E-03,.3956E-03,.6337E-03,.1607E-02,.2537E-02,.2366E-02,.2737E-02,.1145E-01,.6068E-01,.5501E-03,& - .1256E-03,.3964E-03,.6362E-03,.1613E-02,.2562E-02,.2396E-02,.2811E-02,.1173E-01,.6244E-01,.5529E-03,& - .1264E-03,.3971E-03,.6387E-03,.1619E-02,.2586E-02,.2425E-02,.2884E-02,.1201E-01,.6420E-01,.5557E-03,& - .1272E-03,.3979E-03,.6412E-03,.1625E-02,.2611E-02,.2455E-02,.2958E-02,.1229E-01,.6596E-01,.5585E-03,& - .1281E-03,.3994E-03,.6445E-03,.1631E-02,.2637E-02,.2489E-02,.3043E-02,.1260E-01,.6794E-01,.5622E-03,& - .1291E-03,.4008E-03,.6478E-03,.1638E-02,.2664E-02,.2523E-02,.3128E-02,.1292E-01,.6992E-01,.5658E-03,& - .1300E-03,.4022E-03,.6511E-03,.1644E-02,.2691E-02,.2557E-02,.3213E-02,.1323E-01,.7190E-01,.5694E-03,& - .1309E-03,.4037E-03,.6544E-03,.1651E-02,.2718E-02,.2591E-02,.3298E-02,.1354E-01,.7388E-01,.5731E-03,& - .1318E-03,.4051E-03,.6577E-03,.1657E-02,.2745E-02,.2625E-02,.3384E-02,.1385E-01,.7586E-01,.5767E-03,& - .1329E-03,.4072E-03,.6619E-03,.1665E-02,.2774E-02,.2663E-02,.3480E-02,.1420E-01,.7804E-01,.5812E-03,& - .1339E-03,.4094E-03,.6661E-03,.1672E-02,.2804E-02,.2701E-02,.3576E-02,.1454E-01,.8021E-01,.5857E-03,& - .1350E-03,.4115E-03,.6703E-03,.1680E-02,.2833E-02,.2739E-02,.3672E-02,.1489E-01,.8238E-01,.5902E-03,& - .1360E-03,.4136E-03,.6745E-03,.1688E-02,.2863E-02,.2778E-02,.3768E-02,.1523E-01,.8455E-01,.5947E-03,& - .1371E-03,.4157E-03,.6787E-03,.1695E-02,.2893E-02,.2816E-02,.3864E-02,.1558E-01,.8672E-01,.5992E-03,& - .1383E-03,.4186E-03,.6839E-03,.1705E-02,.2925E-02,.2858E-02,.3968E-02,.1594E-01,.8898E-01,.6046E-03,& - .1395E-03,.4214E-03,.6892E-03,.1715E-02,.2958E-02,.2901E-02,.4072E-02,.1630E-01,.9124E-01,.6100E-03,& - .1407E-03,.4243E-03,.6944E-03,.1724E-02,.2991E-02,.2943E-02,.4176E-02,.1667E-01,.9350E-01,.6154E-03,& - .1420E-03,.4271E-03,.6997E-03,.1734E-02,.3024E-02,.2986E-02,.4280E-02,.1703E-01,.9576E-01,.6208E-03,& - .1432E-03,.4300E-03,.7050E-03,.1744E-02,.3056E-02,.3028E-02,.4383E-02,.1739E-01,.9802E-01,.6262E-03,& - .1445E-03,.4333E-03,.7110E-03,.1754E-02,.3092E-02,.3075E-02,.4496E-02,.1778E-01,.1004E+00,.6322E-03,& - .1458E-03,.4367E-03,.7170E-03,.1765E-02,.3128E-02,.3121E-02,.4609E-02,.1817E-01,.1028E+00,.6383E-03,& - .1472E-03,.4401E-03,.7230E-03,.1776E-02,.3163E-02,.3168E-02,.4722E-02,.1855E-01,.1051E+00,.6443E-03,& - .1485E-03,.4435E-03,.7290E-03,.1787E-02,.3199E-02,.3214E-02,.4834E-02,.1894E-01,.1075E+00,.6504E-03,& - .1498E-03,.4468E-03,.7351E-03,.1798E-02,.3234E-02,.3261E-02,.4947E-02,.1933E-01,.1099E+00,.6564E-03,& - .1513E-03,.4505E-03,.7416E-03,.1809E-02,.3273E-02,.3313E-02,.5074E-02,.1975E-01,.1125E+00,.6630E-03,& - .1527E-03,.4542E-03,.7481E-03,.1821E-02,.3311E-02,.3365E-02,.5201E-02,.2018E-01,.1151E+00,.6695E-03,& - .1541E-03,.4579E-03,.7546E-03,.1832E-02,.3349E-02,.3416E-02,.5328E-02,.2060E-01,.1177E+00,.6760E-03,& - .1556E-03,.4616E-03,.7612E-03,.1844E-02,.3388E-02,.3468E-02,.5454E-02,.2103E-01,.1203E+00,.6826E-03,& - .1570E-03,.4653E-03,.7677E-03,.1855E-02,.3426E-02,.3520E-02,.5581E-02,.2145E-01,.1229E+00,.6891E-03,& - .1585E-03,.4694E-03,.7748E-03,.1867E-02,.3467E-02,.3577E-02,.5720E-02,.2191E-01,.1256E+00,.6962E-03,& - .1601E-03,.4734E-03,.7819E-03,.1880E-02,.3509E-02,.3634E-02,.5859E-02,.2237E-01,.1284E+00,.7032E-03,& - .1616E-03,.4775E-03,.7890E-03,.1892E-02,.3550E-02,.3691E-02,.5998E-02,.2283E-01,.1311E+00,.7103E-03,& - .1631E-03,.4816E-03,.7961E-03,.1904E-02,.3591E-02,.3748E-02,.6137E-02,.2329E-01,.1339E+00,.7173E-03,& - .1647E-03,.4856E-03,.8033E-03,.1916E-02,.3633E-02,.3804E-02,.6276E-02,.2374E-01,.1366E+00,.7244E-03,& - .1661E-03,.4893E-03,.8100E-03,.1924E-02,.3679E-02,.3880E-02,.6482E-02,.2439E-01,.1406E+00,.7314E-03,& - .1676E-03,.4929E-03,.8167E-03,.1932E-02,.3725E-02,.3955E-02,.6689E-02,.2503E-01,.1446E+00,.7385E-03,& - .1690E-03,.4966E-03,.8234E-03,.1939E-02,.3772E-02,.4030E-02,.6895E-02,.2568E-01,.1486E+00,.7455E-03,& - .1705E-03,.5003E-03,.8301E-03,.1947E-02,.3818E-02,.4106E-02,.7102E-02,.2632E-01,.1527E+00,.7526E-03,& - .1719E-03,.5039E-03,.8368E-03,.1955E-02,.3864E-02,.4181E-02,.7308E-02,.2696E-01,.1567E+00,.7596E-03,& - .1735E-03,.5083E-03,.8446E-03,.1964E-02,.3917E-02,.4267E-02,.7537E-02,.2766E-01,.1609E+00,.7676E-03,& - .1752E-03,.5126E-03,.8524E-03,.1974E-02,.3969E-02,.4354E-02,.7765E-02,.2836E-01,.1651E+00,.7755E-03,& - .1768E-03,.5170E-03,.8602E-03,.1984E-02,.4022E-02,.4440E-02,.7994E-02,.2906E-01,.1694E+00,.7835E-03,& - .1785E-03,.5214E-03,.8680E-03,.1993E-02,.4074E-02,.4526E-02,.8222E-02,.2976E-01,.1736E+00,.7914E-03,& - .1801E-03,.5257E-03,.8757E-03,.2003E-02,.4127E-02,.4613E-02,.8451E-02,.3045E-01,.1779E+00,.7994E-03,& - .1818E-03,.5303E-03,.8840E-03,.2013E-02,.4184E-02,.4710E-02,.8710E-02,.3123E-01,.1825E+00,.8078E-03,& - .1836E-03,.5350E-03,.8925E-03,.2023E-02,.4242E-02,.4811E-02,.8976E-02,.3202E-01,.1873E+00,.8164E-03,& - .1854E-03,.5399E-03,.9012E-03,.2034E-02,.4302E-02,.4914E-02,.9245E-02,.3282E-01,.1920E+00,.8251E-03,& - .1871E-03,.5444E-03,.9096E-03,.2039E-02,.4371E-02,.5046E-02,.9608E-02,.3387E-01,.1984E+00,.8340E-03,& - .1889E-03,.5492E-03,.9185E-03,.2045E-02,.4442E-02,.5183E-02,.9980E-02,.3494E-01,.2049E+00,.8431E-03,& - .1907E-03,.5542E-03,.9276E-03,.2053E-02,.4516E-02,.5325E-02,.1036E-01,.3603E-01,.2114E+00,.8525E-03,& - .1926E-03,.5591E-03,.9369E-03,.2056E-02,.4601E-02,.5502E-02,.1084E-01,.3738E-01,.2196E+00,.8624E-03,& - .1945E-03,.5644E-03,.9469E-03,.2062E-02,.4690E-02,.5685E-02,.1133E-01,.3874E-01,.2278E+00,.8726E-03,& - .1966E-03,.5699E-03,.9572E-03,.2064E-02,.4792E-02,.5909E-02,.1192E-01,.4039E-01,.2376E+00,.8836E-03,& - .1987E-03,.5757E-03,.9685E-03,.2066E-02,.4912E-02,.6177E-02,.1263E-01,.4230E-01,.2490E+00,.8954E-03,& - .2010E-03,.5820E-03,.9804E-03,.2070E-02,.5037E-02,.6457E-02,.1334E-01,.4423E-01,.2604E+00,.9077E-03,& - .2035E-03,.5890E-03,.9939E-03,.2072E-02,.5194E-02,.6825E-02,.1427E-01,.4669E-01,.2747E+00,.9217E-03,& - .2062E-03,.5966E-03,.1008E-02,.2077E-02,.5359E-02,.7209E-02,.1521E-01,.4917E-01,.2888E+00,.9363E-03,& - .2093E-03,.6053E-03,.1025E-02,.2083E-02,.5560E-02,.7692E-02,.1635E-01,.5215E-01,.3055E+00,.9529E-03,& - .2129E-03,.6157E-03,.1045E-02,.2089E-02,.5831E-02,.8365E-02,.1789E-01,.5609E-01,.3271E+00,.9730E-03,& - .2171E-03,.6277E-03,.1068E-02,.2101E-02,.6145E-02,.9153E-02,.1962E-01,.6045E-01,.3500E+00,.9955E-03,& - .2223E-03,.6429E-03,.1096E-02,.2118E-02,.6564E-02,.1023E-01,.2186E-01,.6598E-01,.3780E+00,.1023E-02,& - .2297E-03,.6647E-03,.1137E-02,.2149E-02,.7207E-02,.1193E-01,.2518E-01,.7402E-01,.4161E+00,.1063E-02,& - .2423E-03,.7019E-03,.1206E-02,.2220E-02,.8325E-02,.1498E-01,.3063E-01,.8678E-01,.4703E+00,.1128E-02/ - data (((w0_lw(ai,k,nh),ai= 2, 2),k=1,nwl_lw),nh=0,99)/ & - .1078E-04,.3249E-04,.9802E-04,.2051E-03,.3114E-03,.4109E-03,.5443E-03,.1016E-02,.3002E-02,.6508E-04,& - .1083E-04,.3265E-04,.9852E-04,.2062E-03,.3130E-03,.4130E-03,.5471E-03,.1021E-02,.3018E-02,.6541E-04,& - .1089E-04,.3282E-04,.9902E-04,.2072E-03,.3146E-03,.4151E-03,.5499E-03,.1026E-02,.3034E-02,.6574E-04,& - .1094E-04,.3299E-04,.9951E-04,.2083E-03,.3162E-03,.4172E-03,.5527E-03,.1032E-02,.3049E-02,.6608E-04,& - .1099E-04,.3315E-04,.1000E-03,.2093E-03,.3178E-03,.4193E-03,.5555E-03,.1037E-02,.3065E-02,.6641E-04,& - .1105E-04,.3332E-04,.1005E-03,.2104E-03,.3194E-03,.4215E-03,.5583E-03,.1042E-02,.3080E-02,.6674E-04,& - .1110E-04,.3347E-04,.1010E-03,.2114E-03,.3209E-03,.4235E-03,.5609E-03,.1047E-02,.3095E-02,.6705E-04,& - .1115E-04,.3363E-04,.1015E-03,.2124E-03,.3224E-03,.4254E-03,.5636E-03,.1052E-02,.3110E-02,.6736E-04,& - .1120E-04,.3378E-04,.1019E-03,.2133E-03,.3239E-03,.4274E-03,.5663E-03,.1057E-02,.3124E-02,.6767E-04,& - .1126E-04,.3394E-04,.1024E-03,.2143E-03,.3254E-03,.4294E-03,.5689E-03,.1062E-02,.3139E-02,.6799E-04,& - .1131E-04,.3409E-04,.1029E-03,.2153E-03,.3269E-03,.4314E-03,.5716E-03,.1067E-02,.3154E-02,.6830E-04,& - .1136E-04,.3424E-04,.1033E-03,.2162E-03,.3283E-03,.4333E-03,.5740E-03,.1071E-02,.3168E-02,.6859E-04,& - .1140E-04,.3439E-04,.1038E-03,.2172E-03,.3298E-03,.4352E-03,.5765E-03,.1076E-02,.3181E-02,.6888E-04,& - .1145E-04,.3453E-04,.1042E-03,.2181E-03,.3312E-03,.4370E-03,.5790E-03,.1081E-02,.3195E-02,.6918E-04,& - .1150E-04,.3468E-04,.1046E-03,.2190E-03,.3326E-03,.4389E-03,.5815E-03,.1085E-02,.3209E-02,.6947E-04,& - .1155E-04,.3482E-04,.1051E-03,.2199E-03,.3340E-03,.4408E-03,.5839E-03,.1090E-02,.3222E-02,.6977E-04,& - .1159E-04,.3496E-04,.1055E-03,.2208E-03,.3353E-03,.4425E-03,.5863E-03,.1094E-02,.3235E-02,.7004E-04,& - .1164E-04,.3510E-04,.1059E-03,.2217E-03,.3367E-03,.4443E-03,.5886E-03,.1099E-02,.3248E-02,.7032E-04,& - .1168E-04,.3524E-04,.1063E-03,.2226E-03,.3380E-03,.4461E-03,.5910E-03,.1103E-02,.3261E-02,.7059E-04,& - .1173E-04,.3537E-04,.1067E-03,.2235E-03,.3393E-03,.4478E-03,.5933E-03,.1108E-02,.3274E-02,.7087E-04,& - .1178E-04,.3551E-04,.1072E-03,.2243E-03,.3407E-03,.4496E-03,.5956E-03,.1112E-02,.3287E-02,.7114E-04,& - .1182E-04,.3564E-04,.1075E-03,.2252E-03,.3419E-03,.4512E-03,.5978E-03,.1116E-02,.3299E-02,.7140E-04,& - .1186E-04,.3577E-04,.1079E-03,.2260E-03,.3432E-03,.4529E-03,.6000E-03,.1120E-02,.3311E-02,.7166E-04,& - .1190E-04,.3590E-04,.1083E-03,.2268E-03,.3444E-03,.4545E-03,.6022E-03,.1124E-02,.3323E-02,.7191E-04,& - .1195E-04,.3603E-04,.1087E-03,.2276E-03,.3456E-03,.4562E-03,.6044E-03,.1129E-02,.3335E-02,.7217E-04,& - .1199E-04,.3615E-04,.1091E-03,.2284E-03,.3469E-03,.4578E-03,.6066E-03,.1133E-02,.3347E-02,.7243E-04,& - .1203E-04,.3627E-04,.1095E-03,.2292E-03,.3481E-03,.4594E-03,.6087E-03,.1137E-02,.3358E-02,.7267E-04,& - .1207E-04,.3639E-04,.1098E-03,.2300E-03,.3492E-03,.4610E-03,.6108E-03,.1140E-02,.3370E-02,.7292E-04,& - .1211E-04,.3651E-04,.1102E-03,.2307E-03,.3504E-03,.4625E-03,.6128E-03,.1144E-02,.3381E-02,.7316E-04,& - .1215E-04,.3663E-04,.1106E-03,.2315E-03,.3516E-03,.4641E-03,.6149E-03,.1148E-02,.3392E-02,.7340E-04,& - .1219E-04,.3675E-04,.1109E-03,.2323E-03,.3528E-03,.4656E-03,.6170E-03,.1152E-02,.3404E-02,.7365E-04,& - .1223E-04,.3687E-04,.1113E-03,.2330E-03,.3539E-03,.4671E-03,.6189E-03,.1156E-02,.3414E-02,.7387E-04,& - .1226E-04,.3698E-04,.1116E-03,.2337E-03,.3550E-03,.4686E-03,.6208E-03,.1159E-02,.3425E-02,.7410E-04,& - .1230E-04,.3709E-04,.1120E-03,.2345E-03,.3561E-03,.4700E-03,.6228E-03,.1163E-02,.3436E-02,.7433E-04,& - .1234E-04,.3721E-04,.1123E-03,.2352E-03,.3572E-03,.4715E-03,.6247E-03,.1167E-02,.3446E-02,.7455E-04,& - .1237E-04,.3732E-04,.1127E-03,.2359E-03,.3583E-03,.4729E-03,.6266E-03,.1170E-02,.3457E-02,.7478E-04,& - .1241E-04,.3743E-04,.1130E-03,.2366E-03,.3593E-03,.4743E-03,.6285E-03,.1174E-02,.3467E-02,.7499E-04,& - .1244E-04,.3753E-04,.1133E-03,.2373E-03,.3604E-03,.4757E-03,.6303E-03,.1177E-02,.3477E-02,.7521E-04,& - .1248E-04,.3764E-04,.1136E-03,.2379E-03,.3614E-03,.4770E-03,.6321E-03,.1181E-02,.3487E-02,.7542E-04,& - .1251E-04,.3775E-04,.1139E-03,.2386E-03,.3624E-03,.4784E-03,.6339E-03,.1184E-02,.3497E-02,.7563E-04,& - .1255E-04,.3785E-04,.1142E-03,.2393E-03,.3635E-03,.4798E-03,.6357E-03,.1187E-02,.3507E-02,.7585E-04,& - .1258E-04,.3795E-04,.1146E-03,.2399E-03,.3644E-03,.4811E-03,.6375E-03,.1191E-02,.3516E-02,.7605E-04,& - .1262E-04,.3805E-04,.1149E-03,.2406E-03,.3654E-03,.4823E-03,.6392E-03,.1194E-02,.3525E-02,.7625E-04,& - .1265E-04,.3815E-04,.1152E-03,.2412E-03,.3664E-03,.4836E-03,.6409E-03,.1197E-02,.3534E-02,.7645E-04,& - .1268E-04,.3825E-04,.1155E-03,.2418E-03,.3674E-03,.4849E-03,.6426E-03,.1200E-02,.3544E-02,.7665E-04,& - .1272E-04,.3835E-04,.1158E-03,.2425E-03,.3683E-03,.4862E-03,.6444E-03,.1203E-02,.3553E-02,.7685E-04,& - .1275E-04,.3845E-04,.1161E-03,.2431E-03,.3693E-03,.4874E-03,.6460E-03,.1207E-02,.3562E-02,.7704E-04,& - .1278E-04,.3854E-04,.1163E-03,.2437E-03,.3702E-03,.4886E-03,.6476E-03,.1210E-02,.3570E-02,.7723E-04,& - .1281E-04,.3863E-04,.1166E-03,.2443E-03,.3711E-03,.4898E-03,.6492E-03,.1213E-02,.3579E-02,.7741E-04,& - .1284E-04,.3873E-04,.1169E-03,.2449E-03,.3720E-03,.4911E-03,.6508E-03,.1216E-02,.3588E-02,.7760E-04,& - .1287E-04,.3882E-04,.1172E-03,.2454E-03,.3729E-03,.4923E-03,.6524E-03,.1219E-02,.3596E-02,.7779E-04,& - .1290E-04,.3891E-04,.1175E-03,.2460E-03,.3738E-03,.4934E-03,.6539E-03,.1222E-02,.3604E-02,.7797E-04,& - .1293E-04,.3900E-04,.1177E-03,.2466E-03,.3746E-03,.4946E-03,.6554E-03,.1224E-02,.3613E-02,.7814E-04,& - .1296E-04,.3908E-04,.1180E-03,.2471E-03,.3755E-03,.4957E-03,.6569E-03,.1227E-02,.3621E-02,.7832E-04,& - .1299E-04,.3917E-04,.1183E-03,.2477E-03,.3763E-03,.4968E-03,.6584E-03,.1230E-02,.3629E-02,.7850E-04,& - .1302E-04,.3926E-04,.1185E-03,.2483E-03,.3772E-03,.4980E-03,.6600E-03,.1233E-02,.3637E-02,.7867E-04,& - .1304E-04,.3933E-04,.1186E-03,.2485E-03,.3778E-03,.4990E-03,.6615E-03,.1236E-02,.3649E-02,.7878E-04,& - .1307E-04,.3941E-04,.1187E-03,.2487E-03,.3785E-03,.5000E-03,.6631E-03,.1239E-02,.3662E-02,.7888E-04,& - .1309E-04,.3948E-04,.1188E-03,.2489E-03,.3791E-03,.5010E-03,.6647E-03,.1243E-02,.3674E-02,.7898E-04,& - .1312E-04,.3956E-04,.1188E-03,.2491E-03,.3797E-03,.5021E-03,.6663E-03,.1246E-02,.3687E-02,.7909E-04,& - .1314E-04,.3963E-04,.1189E-03,.2493E-03,.3804E-03,.5031E-03,.6679E-03,.1249E-02,.3699E-02,.7919E-04,& - .1317E-04,.3971E-04,.1191E-03,.2498E-03,.3811E-03,.5041E-03,.6692E-03,.1252E-02,.3707E-02,.7935E-04,& - .1319E-04,.3979E-04,.1194E-03,.2503E-03,.3819E-03,.5051E-03,.6706E-03,.1254E-02,.3714E-02,.7950E-04,& - .1322E-04,.3987E-04,.1196E-03,.2508E-03,.3827E-03,.5061E-03,.6719E-03,.1257E-02,.3721E-02,.7966E-04,& - .1325E-04,.3995E-04,.1199E-03,.2513E-03,.3834E-03,.5072E-03,.6733E-03,.1260E-02,.3728E-02,.7982E-04,& - .1327E-04,.4003E-04,.1201E-03,.2518E-03,.3842E-03,.5082E-03,.6746E-03,.1262E-02,.3735E-02,.7997E-04,& - .1330E-04,.4009E-04,.1199E-03,.2514E-03,.3846E-03,.5092E-03,.6767E-03,.1267E-02,.3760E-02,.7997E-04,& - .1332E-04,.4016E-04,.1196E-03,.2510E-03,.3849E-03,.5103E-03,.6788E-03,.1272E-02,.3784E-02,.7996E-04,& - .1335E-04,.4023E-04,.1193E-03,.2506E-03,.3853E-03,.5113E-03,.6809E-03,.1276E-02,.3808E-02,.7996E-04,& - .1337E-04,.4029E-04,.1191E-03,.2502E-03,.3857E-03,.5124E-03,.6830E-03,.1281E-02,.3832E-02,.7995E-04,& - .1340E-04,.4036E-04,.1188E-03,.2498E-03,.3860E-03,.5134E-03,.6851E-03,.1286E-02,.3856E-02,.7995E-04,& - .1345E-04,.4049E-04,.1181E-03,.2484E-03,.3866E-03,.5158E-03,.6902E-03,.1298E-02,.3922E-02,.7985E-04,& - .1350E-04,.4062E-04,.1173E-03,.2470E-03,.3872E-03,.5182E-03,.6953E-03,.1310E-02,.3989E-02,.7976E-04,& - .1355E-04,.4075E-04,.1165E-03,.2457E-03,.3878E-03,.5206E-03,.7004E-03,.1322E-02,.4055E-02,.7967E-04,& - .1360E-04,.4088E-04,.1158E-03,.2443E-03,.3884E-03,.5229E-03,.7055E-03,.1334E-02,.4121E-02,.7957E-04,& - .1365E-04,.4102E-04,.1150E-03,.2429E-03,.3890E-03,.5253E-03,.7106E-03,.1346E-02,.4188E-02,.7948E-04,& - .1375E-04,.4130E-04,.1145E-03,.2420E-03,.3910E-03,.5302E-03,.7199E-03,.1366E-02,.4297E-02,.7962E-04,& - .1386E-04,.4158E-04,.1139E-03,.2410E-03,.3930E-03,.5351E-03,.7292E-03,.1387E-02,.4407E-02,.7976E-04,& - .1396E-04,.4186E-04,.1134E-03,.2400E-03,.3951E-03,.5400E-03,.7384E-03,.1407E-02,.4516E-02,.7990E-04,& - .1406E-04,.4214E-04,.1129E-03,.2390E-03,.3971E-03,.5449E-03,.7477E-03,.1428E-02,.4626E-02,.8004E-04,& - .1417E-04,.4242E-04,.1123E-03,.2380E-03,.3991E-03,.5498E-03,.7569E-03,.1448E-02,.4735E-02,.8018E-04,& - .1435E-04,.4293E-04,.1118E-03,.2370E-03,.4032E-03,.5588E-03,.7733E-03,.1484E-02,.4928E-02,.8058E-04,& - .1450E-04,.4332E-04,.1116E-03,.2367E-03,.4065E-03,.5658E-03,.7857E-03,.1511E-02,.5069E-02,.8096E-04,& - .1471E-04,.4392E-04,.1114E-03,.2362E-03,.4116E-03,.5763E-03,.8047E-03,.1552E-02,.5288E-02,.8155E-04,& - .1487E-04,.4437E-04,.1115E-03,.2362E-03,.4156E-03,.5843E-03,.8188E-03,.1582E-02,.5447E-02,.8205E-04,& - .1512E-04,.4505E-04,.1115E-03,.2362E-03,.4215E-03,.5965E-03,.8403E-03,.1628E-02,.5695E-02,.8281E-04,& - .1537E-04,.4577E-04,.1117E-03,.2363E-03,.4281E-03,.6096E-03,.8632E-03,.1677E-02,.5961E-02,.8366E-04,& - .1556E-04,.4632E-04,.1120E-03,.2368E-03,.4331E-03,.6193E-03,.8803E-03,.1713E-02,.6152E-02,.8435E-04,& - .1585E-04,.4712E-04,.1124E-03,.2373E-03,.4406E-03,.6340E-03,.9057E-03,.1768E-02,.6449E-02,.8535E-04,& - .1606E-04,.4771E-04,.1129E-03,.2380E-03,.4462E-03,.6448E-03,.9246E-03,.1808E-02,.6664E-02,.8614E-04,& - .1637E-04,.4859E-04,.1135E-03,.2389E-03,.4546E-03,.6611E-03,.9529E-03,.1868E-02,.6994E-02,.8729E-04,& - .1669E-04,.4950E-04,.1142E-03,.2400E-03,.4634E-03,.6783E-03,.9830E-03,.1932E-02,.7347E-02,.8853E-04,& - .1703E-04,.5046E-04,.1151E-03,.2412E-03,.4728E-03,.6965E-03,.1015E-02,.1999E-02,.7721E-02,.8985E-04,& - .1738E-04,.5146E-04,.1161E-03,.2427E-03,.4828E-03,.7157E-03,.1048E-02,.2070E-02,.8118E-02,.9125E-04,& - .1785E-04,.5281E-04,.1174E-03,.2447E-03,.4964E-03,.7422E-03,.1094E-02,.2168E-02,.8679E-02,.9315E-04,& - .1835E-04,.5422E-04,.1190E-03,.2470E-03,.5109E-03,.7704E-03,.1143E-02,.2273E-02,.9281E-02,.9517E-04,& - .1898E-04,.5604E-04,.1211E-03,.2500E-03,.5300E-03,.8076E-03,.1208E-02,.2412E-02,.1009E-01,.9782E-04,& - .1990E-04,.5868E-04,.1242E-03,.2547E-03,.5583E-03,.8632E-03,.1307E-02,.2622E-02,.1134E-01,.1017E-03,& - .2102E-04,.6187E-04,.1283E-03,.2608E-03,.5936E-03,.9326E-03,.1429E-02,.2886E-02,.1295E-01,.1064E-03,& - .2396E-04,.7035E-04,.1400E-03,.2783E-03,.6926E-03,.1131E-02,.1783E-02,.3655E-02,.1784E-01,.1193E-03/ - data (((w0_lw(ai,k,nh),ai= 3, 3),k=1,nwl_lw),nh=0,99)/ & - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03/ - data (((w0_lw(ai,k,nh),ai= 4, 4),k=1,nwl_lw),nh=0,99)/ & - .3446E-04,.2170E-03,.7401E-03,.3198E-02,.3693E-02,.3257E-02,.1315E-02,.1798E-01,.1881E+00,.4705E-03,& - .3481E-04,.2162E-03,.7142E-03,.3142E-02,.3712E-02,.3279E-02,.1349E-02,.1804E-01,.1893E+00,.4652E-03,& - .3517E-04,.2153E-03,.6883E-03,.3086E-02,.3731E-02,.3300E-02,.1382E-02,.1809E-01,.1905E+00,.4599E-03,& - .3552E-04,.2145E-03,.6624E-03,.3031E-02,.3749E-02,.3322E-02,.1416E-02,.1814E-01,.1917E+00,.4546E-03,& - .3587E-04,.2136E-03,.6365E-03,.2975E-02,.3768E-02,.3343E-02,.1450E-02,.1819E-01,.1929E+00,.4493E-03,& - .3623E-04,.2128E-03,.6106E-03,.2919E-02,.3787E-02,.3365E-02,.1484E-02,.1825E-01,.1941E+00,.4440E-03,& - .3660E-04,.2123E-03,.5955E-03,.2880E-02,.3806E-02,.3388E-02,.1521E-02,.1836E-01,.1954E+00,.4402E-03,& - .3697E-04,.2119E-03,.5803E-03,.2841E-02,.3825E-02,.3411E-02,.1558E-02,.1847E-01,.1968E+00,.4365E-03,& - .3734E-04,.2114E-03,.5652E-03,.2801E-02,.3844E-02,.3433E-02,.1595E-02,.1858E-01,.1982E+00,.4328E-03,& - .3772E-04,.2110E-03,.5501E-03,.2762E-02,.3863E-02,.3456E-02,.1632E-02,.1869E-01,.1995E+00,.4290E-03,& - .3809E-04,.2105E-03,.5350E-03,.2722E-02,.3882E-02,.3479E-02,.1669E-02,.1880E-01,.2009E+00,.4253E-03,& - .3848E-04,.2104E-03,.5254E-03,.2693E-02,.3902E-02,.3503E-02,.1709E-02,.1894E-01,.2024E+00,.4227E-03,& - .3887E-04,.2103E-03,.5158E-03,.2663E-02,.3922E-02,.3527E-02,.1750E-02,.1909E-01,.2039E+00,.4202E-03,& - .3927E-04,.2101E-03,.5061E-03,.2634E-02,.3941E-02,.3551E-02,.1790E-02,.1924E-01,.2054E+00,.4176E-03,& - .3966E-04,.2100E-03,.4965E-03,.2605E-02,.3961E-02,.3575E-02,.1831E-02,.1938E-01,.2068E+00,.4150E-03,& - .4005E-04,.2098E-03,.4869E-03,.2575E-02,.3981E-02,.3599E-02,.1871E-02,.1953E-01,.2083E+00,.4124E-03,& - .4046E-04,.2099E-03,.4805E-03,.2553E-02,.4001E-02,.3624E-02,.1915E-02,.1970E-01,.2099E+00,.4107E-03,& - .4087E-04,.2101E-03,.4741E-03,.2530E-02,.4021E-02,.3650E-02,.1960E-02,.1987E-01,.2114E+00,.4090E-03,& - .4129E-04,.2102E-03,.4677E-03,.2507E-02,.4041E-02,.3675E-02,.2004E-02,.2004E-01,.2130E+00,.4073E-03,& - .4170E-04,.2103E-03,.4613E-03,.2484E-02,.4061E-02,.3701E-02,.2048E-02,.2022E-01,.2146E+00,.4056E-03,& - .4211E-04,.2104E-03,.4549E-03,.2462E-02,.4082E-02,.3726E-02,.2092E-02,.2039E-01,.2161E+00,.4039E-03,& - .4254E-04,.2107E-03,.4506E-03,.2444E-02,.4102E-02,.3753E-02,.2140E-02,.2058E-01,.2177E+00,.4028E-03,& - .4298E-04,.2111E-03,.4463E-03,.2426E-02,.4123E-02,.3780E-02,.2188E-02,.2077E-01,.2194E+00,.4018E-03,& - .4341E-04,.2114E-03,.4420E-03,.2408E-02,.4144E-02,.3807E-02,.2235E-02,.2096E-01,.2210E+00,.4008E-03,& - .4384E-04,.2117E-03,.4377E-03,.2390E-02,.4165E-02,.3834E-02,.2283E-02,.2116E-01,.2226E+00,.3998E-03,& - .4428E-04,.2120E-03,.4334E-03,.2373E-02,.4186E-02,.3860E-02,.2331E-02,.2135E-01,.2242E+00,.3988E-03,& - .4473E-04,.2126E-03,.4305E-03,.2358E-02,.4207E-02,.3889E-02,.2383E-02,.2156E-01,.2259E+00,.3983E-03,& - .4519E-04,.2131E-03,.4276E-03,.2344E-02,.4228E-02,.3917E-02,.2435E-02,.2177E-01,.2276E+00,.3978E-03,& - .4564E-04,.2136E-03,.4248E-03,.2330E-02,.4250E-02,.3946E-02,.2487E-02,.2198E-01,.2292E+00,.3974E-03,& - .4610E-04,.2141E-03,.4219E-03,.2316E-02,.4271E-02,.3974E-02,.2538E-02,.2219E-01,.2309E+00,.3969E-03,& - .4655E-04,.2146E-03,.4190E-03,.2302E-02,.4293E-02,.4003E-02,.2590E-02,.2240E-01,.2326E+00,.3964E-03,& - .4703E-04,.2153E-03,.4172E-03,.2290E-02,.4315E-02,.4033E-02,.2646E-02,.2262E-01,.2343E+00,.3964E-03,& - .4751E-04,.2160E-03,.4154E-03,.2279E-02,.4337E-02,.4063E-02,.2702E-02,.2284E-01,.2360E+00,.3964E-03,& - .4798E-04,.2167E-03,.4136E-03,.2268E-02,.4359E-02,.4093E-02,.2758E-02,.2307E-01,.2377E+00,.3964E-03,& - .4846E-04,.2173E-03,.4118E-03,.2256E-02,.4381E-02,.4123E-02,.2813E-02,.2329E-01,.2394E+00,.3964E-03,& - .4894E-04,.2180E-03,.4100E-03,.2245E-02,.4404E-02,.4153E-02,.2869E-02,.2352E-01,.2411E+00,.3964E-03,& - .4943E-04,.2189E-03,.4090E-03,.2236E-02,.4426E-02,.4185E-02,.2929E-02,.2375E-01,.2428E+00,.3968E-03,& - .4993E-04,.2197E-03,.4081E-03,.2227E-02,.4449E-02,.4217E-02,.2989E-02,.2399E-01,.2446E+00,.3972E-03,& - .5043E-04,.2205E-03,.4071E-03,.2217E-02,.4472E-02,.4249E-02,.3049E-02,.2423E-01,.2463E+00,.3976E-03,& - .5093E-04,.2214E-03,.4061E-03,.2208E-02,.4495E-02,.4280E-02,.3109E-02,.2447E-01,.2481E+00,.3980E-03,& - .5143E-04,.2222E-03,.4051E-03,.2199E-02,.4518E-02,.4312E-02,.3169E-02,.2471E-01,.2498E+00,.3984E-03,& - .5196E-04,.2232E-03,.4048E-03,.2192E-02,.4542E-02,.4346E-02,.3233E-02,.2496E-01,.2516E+00,.3991E-03,& - .5248E-04,.2241E-03,.4045E-03,.2185E-02,.4565E-02,.4379E-02,.3297E-02,.2521E-01,.2533E+00,.3999E-03,& - .5300E-04,.2251E-03,.4041E-03,.2178E-02,.4589E-02,.4413E-02,.3362E-02,.2546E-01,.2551E+00,.4006E-03,& - .5353E-04,.2261E-03,.4038E-03,.2170E-02,.4613E-02,.4447E-02,.3426E-02,.2571E-01,.2568E+00,.4014E-03,& - .5405E-04,.2271E-03,.4035E-03,.2163E-02,.4636E-02,.4480E-02,.3490E-02,.2596E-01,.2586E+00,.4021E-03,& - .5460E-04,.2282E-03,.4037E-03,.2158E-02,.4661E-02,.4516E-02,.3559E-02,.2623E-01,.2604E+00,.4032E-03,& - .5514E-04,.2293E-03,.4039E-03,.2152E-02,.4685E-02,.4551E-02,.3627E-02,.2649E-01,.2622E+00,.4043E-03,& - .5569E-04,.2304E-03,.4041E-03,.2146E-02,.4709E-02,.4587E-02,.3696E-02,.2675E-01,.2639E+00,.4053E-03,& - .5623E-04,.2315E-03,.4043E-03,.2141E-02,.4734E-02,.4622E-02,.3765E-02,.2702E-01,.2657E+00,.4064E-03,& - .5678E-04,.2326E-03,.4046E-03,.2135E-02,.4758E-02,.4658E-02,.3833E-02,.2728E-01,.2675E+00,.4075E-03,& - .5735E-04,.2336E-03,.4046E-03,.2126E-02,.4779E-02,.4693E-02,.3913E-02,.2756E-01,.2693E+00,.4083E-03,& - .5792E-04,.2346E-03,.4047E-03,.2117E-02,.4800E-02,.4729E-02,.3993E-02,.2784E-01,.2711E+00,.4091E-03,& - .5849E-04,.2356E-03,.4047E-03,.2108E-02,.4821E-02,.4765E-02,.4074E-02,.2812E-01,.2729E+00,.4099E-03,& - .5906E-04,.2366E-03,.4048E-03,.2099E-02,.4842E-02,.4800E-02,.4154E-02,.2840E-01,.2747E+00,.4107E-03,& - .5963E-04,.2377E-03,.4048E-03,.2090E-02,.4863E-02,.4836E-02,.4234E-02,.2868E-01,.2765E+00,.4115E-03,& - .6023E-04,.2388E-03,.4055E-03,.2083E-02,.4885E-02,.4875E-02,.4319E-02,.2897E-01,.2784E+00,.4128E-03,& - .6084E-04,.2400E-03,.4061E-03,.2076E-02,.4907E-02,.4913E-02,.4405E-02,.2927E-01,.2802E+00,.4140E-03,& - .6144E-04,.2412E-03,.4068E-03,.2069E-02,.4929E-02,.4951E-02,.4490E-02,.2956E-01,.2821E+00,.4152E-03,& - .6204E-04,.2424E-03,.4074E-03,.2062E-02,.4952E-02,.4990E-02,.4576E-02,.2985E-01,.2839E+00,.4164E-03,& - .6264E-04,.2435E-03,.4080E-03,.2055E-02,.4974E-02,.5028E-02,.4662E-02,.3015E-01,.2857E+00,.4176E-03,& - .6326E-04,.2450E-03,.4096E-03,.2053E-02,.5001E-02,.5071E-02,.4745E-02,.3045E-01,.2876E+00,.4196E-03,& - .6389E-04,.2465E-03,.4112E-03,.2052E-02,.5028E-02,.5113E-02,.4828E-02,.3075E-01,.2894E+00,.4215E-03,& - .6452E-04,.2480E-03,.4127E-03,.2051E-02,.5056E-02,.5155E-02,.4911E-02,.3105E-01,.2912E+00,.4235E-03,& - .6514E-04,.2495E-03,.4143E-03,.2049E-02,.5083E-02,.5197E-02,.4994E-02,.3135E-01,.2930E+00,.4254E-03,& - .6577E-04,.2510E-03,.4159E-03,.2048E-02,.5111E-02,.5239E-02,.5077E-02,.3165E-01,.2948E+00,.4274E-03,& - .6643E-04,.2525E-03,.4174E-03,.2044E-02,.5135E-02,.5283E-02,.5174E-02,.3197E-01,.2967E+00,.4292E-03,& - .6709E-04,.2539E-03,.4189E-03,.2040E-02,.5160E-02,.5326E-02,.5270E-02,.3229E-01,.2985E+00,.4310E-03,& - .6775E-04,.2554E-03,.4203E-03,.2035E-02,.5185E-02,.5370E-02,.5366E-02,.3262E-01,.3004E+00,.4328E-03,& - .6841E-04,.2569E-03,.4218E-03,.2031E-02,.5210E-02,.5414E-02,.5463E-02,.3294E-01,.3023E+00,.4347E-03,& - .6907E-04,.2583E-03,.4233E-03,.2027E-02,.5234E-02,.5457E-02,.5559E-02,.3326E-01,.3041E+00,.4365E-03,& - .6980E-04,.2596E-03,.4244E-03,.2015E-02,.5250E-02,.5503E-02,.5687E-02,.3362E-01,.3061E+00,.4378E-03,& - .7053E-04,.2609E-03,.4255E-03,.2002E-02,.5266E-02,.5549E-02,.5815E-02,.3399E-01,.3082E+00,.4391E-03,& - .7126E-04,.2622E-03,.4265E-03,.1990E-02,.5283E-02,.5595E-02,.5943E-02,.3435E-01,.3102E+00,.4404E-03,& - .7199E-04,.2635E-03,.4276E-03,.1977E-02,.5299E-02,.5641E-02,.6072E-02,.3472E-01,.3122E+00,.4418E-03,& - .7272E-04,.2647E-03,.4287E-03,.1965E-02,.5315E-02,.5687E-02,.6200E-02,.3508E-01,.3142E+00,.4431E-03,& - .7355E-04,.2661E-03,.4300E-03,.1948E-02,.5326E-02,.5740E-02,.6364E-02,.3550E-01,.3164E+00,.4445E-03,& - .7438E-04,.2675E-03,.4314E-03,.1931E-02,.5337E-02,.5793E-02,.6528E-02,.3593E-01,.3187E+00,.4458E-03,& - .7521E-04,.2688E-03,.4327E-03,.1914E-02,.5348E-02,.5846E-02,.6693E-02,.3635E-01,.3209E+00,.4472E-03,& - .7604E-04,.2702E-03,.4340E-03,.1897E-02,.5359E-02,.5898E-02,.6857E-02,.3677E-01,.3231E+00,.4486E-03,& - .7687E-04,.2715E-03,.4354E-03,.1880E-02,.5370E-02,.5951E-02,.7021E-02,.3719E-01,.3254E+00,.4499E-03,& - .7777E-04,.2730E-03,.4369E-03,.1859E-02,.5377E-02,.6011E-02,.7221E-02,.3767E-01,.3278E+00,.4514E-03,& - .7872E-04,.2745E-03,.4388E-03,.1840E-02,.5386E-02,.6073E-02,.7419E-02,.3815E-01,.3303E+00,.4531E-03,& - .7968E-04,.2762E-03,.4410E-03,.1822E-02,.5396E-02,.6138E-02,.7626E-02,.3864E-01,.3327E+00,.4550E-03,& - .8068E-04,.2780E-03,.4435E-03,.1805E-02,.5407E-02,.6205E-02,.7830E-02,.3914E-01,.3352E+00,.4572E-03,& - .8178E-04,.2797E-03,.4458E-03,.1780E-02,.5410E-02,.6281E-02,.8088E-02,.3971E-01,.3380E+00,.4591E-03,& - .8291E-04,.2816E-03,.4486E-03,.1757E-02,.5415E-02,.6359E-02,.8348E-02,.4030E-01,.3409E+00,.4614E-03,& - .8419E-04,.2836E-03,.4516E-03,.1728E-02,.5414E-02,.6450E-02,.8656E-02,.4096E-01,.3440E+00,.4636E-03,& - .8548E-04,.2858E-03,.4552E-03,.1702E-02,.5417E-02,.6545E-02,.8972E-02,.4163E-01,.3472E+00,.4664E-03,& - .8695E-04,.2883E-03,.4593E-03,.1672E-02,.5416E-02,.6653E-02,.9337E-02,.4239E-01,.3507E+00,.4695E-03,& - .8844E-04,.2910E-03,.4640E-03,.1646E-02,.5419E-02,.6770E-02,.9703E-02,.4317E-01,.3543E+00,.4731E-03,& - .9012E-04,.2940E-03,.4694E-03,.1617E-02,.5422E-02,.6902E-02,.1012E-01,.4403E-01,.3582E+00,.4773E-03,& - .9195E-04,.2975E-03,.4758E-03,.1587E-02,.5426E-02,.7053E-02,.1060E-01,.4498E-01,.3624E+00,.4822E-03,& - .9415E-04,.3017E-03,.4838E-03,.1553E-02,.5429E-02,.7238E-02,.1116E-01,.4611E-01,.3673E+00,.4882E-03,& - .9652E-04,.3065E-03,.4931E-03,.1523E-02,.5439E-02,.7449E-02,.1178E-01,.4731E-01,.3725E+00,.4954E-03,& - .9959E-04,.3128E-03,.5056E-03,.1486E-02,.5453E-02,.7729E-02,.1257E-01,.4885E-01,.3790E+00,.5049E-03,& - .1033E-03,.3210E-03,.5217E-03,.1451E-02,.5481E-02,.8087E-02,.1354E-01,.5074E-01,.3866E+00,.5176E-03,& - .1076E-03,.3308E-03,.5412E-03,.1424E-02,.5533E-02,.8509E-02,.1462E-01,.5284E-01,.3949E+00,.5331E-03,& - .1141E-03,.3463E-03,.5719E-03,.1398E-02,.5634E-02,.9179E-02,.1622E-01,.5596E-01,.4068E+00,.5581E-03,& - .1239E-03,.3710E-03,.6199E-03,.1390E-02,.5842E-02,.1022E-01,.1853E-01,.6051E-01,.4234E+00,.5982E-03/ - data (((w0_lw(ai,k,nh),ai= 5, 5),k=1,nwl_lw),nh=0,99)/ & - .4211E-01,.1689E+00,.4530E+00,.7769E+00,.8276E+00,.7723E+00,.8409E+00,.9260E+00,.9872E+00,.3073E+00,& - .4250E-01,.1642E+00,.4101E+00,.7363E+00,.8168E+00,.7672E+00,.8331E+00,.9147E+00,.9851E+00,.2904E+00,& - .4289E-01,.1595E+00,.3671E+00,.6958E+00,.8060E+00,.7620E+00,.8254E+00,.9033E+00,.9829E+00,.2736E+00,& - .4328E-01,.1548E+00,.3242E+00,.6553E+00,.7953E+00,.7569E+00,.8176E+00,.8920E+00,.9808E+00,.2568E+00,& - .4367E-01,.1501E+00,.2813E+00,.6148E+00,.7845E+00,.7518E+00,.8098E+00,.8806E+00,.9787E+00,.2399E+00,& - .4406E-01,.1454E+00,.2383E+00,.5743E+00,.7738E+00,.7466E+00,.8021E+00,.8693E+00,.9766E+00,.2231E+00,& - .4453E-01,.1429E+00,.2255E+00,.5525E+00,.7649E+00,.7424E+00,.7966E+00,.8614E+00,.9749E+00,.2153E+00,& - .4500E-01,.1405E+00,.2127E+00,.5308E+00,.7560E+00,.7382E+00,.7910E+00,.8535E+00,.9732E+00,.2075E+00,& - .4546E-01,.1381E+00,.1999E+00,.5090E+00,.7470E+00,.7340E+00,.7855E+00,.8456E+00,.9715E+00,.1997E+00,& - .4593E-01,.1357E+00,.1870E+00,.4873E+00,.7381E+00,.7298E+00,.7800E+00,.8377E+00,.9698E+00,.1919E+00,& - .4640E-01,.1333E+00,.1742E+00,.4655E+00,.7292E+00,.7256E+00,.7745E+00,.8298E+00,.9682E+00,.1842E+00,& - .4693E-01,.1320E+00,.1685E+00,.4516E+00,.7218E+00,.7221E+00,.7704E+00,.8240E+00,.9668E+00,.1800E+00,& - .4747E-01,.1308E+00,.1628E+00,.4377E+00,.7144E+00,.7187E+00,.7664E+00,.8183E+00,.9655E+00,.1758E+00,& - .4801E-01,.1295E+00,.1571E+00,.4238E+00,.7070E+00,.7152E+00,.7624E+00,.8126E+00,.9641E+00,.1716E+00,& - .4854E-01,.1283E+00,.1514E+00,.4099E+00,.6996E+00,.7118E+00,.7584E+00,.8068E+00,.9627E+00,.1674E+00,& - .4908E-01,.1270E+00,.1457E+00,.3960E+00,.6922E+00,.7083E+00,.7544E+00,.8011E+00,.9614E+00,.1632E+00,& - .4967E-01,.1264E+00,.1428E+00,.3866E+00,.6861E+00,.7056E+00,.7515E+00,.7969E+00,.9603E+00,.1609E+00,& - .5025E-01,.1259E+00,.1400E+00,.3773E+00,.6801E+00,.7028E+00,.7486E+00,.7927E+00,.9592E+00,.1586E+00,& - .5084E-01,.1253E+00,.1371E+00,.3679E+00,.6741E+00,.7001E+00,.7457E+00,.7885E+00,.9581E+00,.1562E+00,& - .5142E-01,.1247E+00,.1343E+00,.3585E+00,.6681E+00,.6973E+00,.7429E+00,.7843E+00,.9570E+00,.1539E+00,& - .5201E-01,.1241E+00,.1314E+00,.3491E+00,.6621E+00,.6946E+00,.7400E+00,.7801E+00,.9560E+00,.1516E+00,& - .5264E-01,.1240E+00,.1299E+00,.3425E+00,.6571E+00,.6924E+00,.7379E+00,.7770E+00,.9551E+00,.1502E+00,& - .5328E-01,.1238E+00,.1284E+00,.3358E+00,.6522E+00,.6902E+00,.7359E+00,.7739E+00,.9542E+00,.1489E+00,& - .5391E-01,.1237E+00,.1270E+00,.3291E+00,.6473E+00,.6880E+00,.7338E+00,.7708E+00,.9533E+00,.1476E+00,& - .5455E-01,.1235E+00,.1255E+00,.3224E+00,.6424E+00,.6858E+00,.7317E+00,.7677E+00,.9524E+00,.1463E+00,& - .5518E-01,.1234E+00,.1240E+00,.3157E+00,.6374E+00,.6836E+00,.7297E+00,.7645E+00,.9516E+00,.1450E+00,& - .5585E-01,.1235E+00,.1233E+00,.3109E+00,.6335E+00,.6819E+00,.7282E+00,.7622E+00,.9508E+00,.1443E+00,& - .5652E-01,.1236E+00,.1226E+00,.3061E+00,.6295E+00,.6802E+00,.7268E+00,.7599E+00,.9501E+00,.1436E+00,& - .5718E-01,.1238E+00,.1219E+00,.3013E+00,.6255E+00,.6785E+00,.7254E+00,.7576E+00,.9494E+00,.1429E+00,& - .5785E-01,.1239E+00,.1212E+00,.2964E+00,.6216E+00,.6768E+00,.7240E+00,.7552E+00,.9487E+00,.1422E+00,& - .5852E-01,.1240E+00,.1204E+00,.2916E+00,.6176E+00,.6751E+00,.7225E+00,.7529E+00,.9480E+00,.1415E+00,& - .5923E-01,.1244E+00,.1202E+00,.2880E+00,.6144E+00,.6738E+00,.7216E+00,.7512E+00,.9474E+00,.1413E+00,& - .5993E-01,.1247E+00,.1200E+00,.2845E+00,.6112E+00,.6724E+00,.7206E+00,.7494E+00,.9468E+00,.1410E+00,& - .6064E-01,.1250E+00,.1197E+00,.2809E+00,.6080E+00,.6711E+00,.7196E+00,.7477E+00,.9462E+00,.1407E+00,& - .6134E-01,.1253E+00,.1195E+00,.2773E+00,.6048E+00,.6698E+00,.7186E+00,.7459E+00,.9456E+00,.1405E+00,& - .6205E-01,.1257E+00,.1192E+00,.2738E+00,.6016E+00,.6685E+00,.7176E+00,.7442E+00,.9450E+00,.1402E+00,& - .6277E-01,.1261E+00,.1193E+00,.2711E+00,.5990E+00,.6675E+00,.7170E+00,.7429E+00,.9445E+00,.1402E+00,& - .6350E-01,.1266E+00,.1193E+00,.2685E+00,.5965E+00,.6666E+00,.7164E+00,.7416E+00,.9440E+00,.1402E+00,& - .6423E-01,.1270E+00,.1193E+00,.2658E+00,.5939E+00,.6656E+00,.7158E+00,.7403E+00,.9435E+00,.1402E+00,& - .6495E-01,.1275E+00,.1194E+00,.2632E+00,.5914E+00,.6646E+00,.7152E+00,.7390E+00,.9431E+00,.1402E+00,& - .6568E-01,.1279E+00,.1194E+00,.2606E+00,.5889E+00,.6637E+00,.7145E+00,.7377E+00,.9426E+00,.1403E+00,& - .6643E-01,.1285E+00,.1197E+00,.2586E+00,.5868E+00,.6630E+00,.7142E+00,.7367E+00,.9422E+00,.1405E+00,& - .6719E-01,.1291E+00,.1199E+00,.2566E+00,.5848E+00,.6623E+00,.7138E+00,.7358E+00,.9418E+00,.1407E+00,& - .6794E-01,.1297E+00,.1202E+00,.2546E+00,.5828E+00,.6616E+00,.7135E+00,.7348E+00,.9413E+00,.1409E+00,& - .6869E-01,.1302E+00,.1204E+00,.2527E+00,.5808E+00,.6608E+00,.7131E+00,.7338E+00,.9409E+00,.1411E+00,& - .6945E-01,.1308E+00,.1207E+00,.2507E+00,.5787E+00,.6601E+00,.7127E+00,.7329E+00,.9405E+00,.1413E+00,& - .7022E-01,.1314E+00,.1211E+00,.2492E+00,.5772E+00,.6597E+00,.7126E+00,.7322E+00,.9402E+00,.1416E+00,& - .7098E-01,.1321E+00,.1214E+00,.2478E+00,.5756E+00,.6592E+00,.7124E+00,.7314E+00,.9399E+00,.1420E+00,& - .7175E-01,.1327E+00,.1218E+00,.2463E+00,.5740E+00,.6587E+00,.7123E+00,.7307E+00,.9395E+00,.1423E+00,& - .7252E-01,.1333E+00,.1222E+00,.2449E+00,.5724E+00,.6583E+00,.7121E+00,.7300E+00,.9392E+00,.1426E+00,& - .7328E-01,.1340E+00,.1226E+00,.2434E+00,.5709E+00,.6578E+00,.7120E+00,.7293E+00,.9388E+00,.1430E+00,& - .7394E-01,.1345E+00,.1230E+00,.2425E+00,.5698E+00,.6576E+00,.7119E+00,.7289E+00,.9386E+00,.1434E+00,& - .7459E-01,.1351E+00,.1234E+00,.2416E+00,.5688E+00,.6573E+00,.7119E+00,.7284E+00,.9384E+00,.1437E+00,& - .7525E-01,.1357E+00,.1238E+00,.2407E+00,.5678E+00,.6571E+00,.7119E+00,.7280E+00,.9381E+00,.1441E+00,& - .7590E-01,.1362E+00,.1242E+00,.2398E+00,.5668E+00,.6568E+00,.7119E+00,.7276E+00,.9379E+00,.1445E+00,& - .7655E-01,.1368E+00,.1245E+00,.2389E+00,.5657E+00,.6566E+00,.7119E+00,.7272E+00,.9376E+00,.1448E+00,& - .7721E-01,.1374E+00,.1250E+00,.2382E+00,.5649E+00,.6564E+00,.7119E+00,.7268E+00,.9374E+00,.1452E+00,& - .7787E-01,.1380E+00,.1254E+00,.2375E+00,.5641E+00,.6563E+00,.7120E+00,.7265E+00,.9372E+00,.1456E+00,& - .7852E-01,.1386E+00,.1258E+00,.2368E+00,.5633E+00,.6562E+00,.7121E+00,.7262E+00,.9370E+00,.1460E+00,& - .7918E-01,.1392E+00,.1263E+00,.2361E+00,.5625E+00,.6560E+00,.7122E+00,.7259E+00,.9368E+00,.1464E+00,& - .7983E-01,.1398E+00,.1267E+00,.2354E+00,.5617E+00,.6559E+00,.7122E+00,.7256E+00,.9366E+00,.1468E+00,& - .8050E-01,.1404E+00,.1272E+00,.2349E+00,.5611E+00,.6558E+00,.7124E+00,.7253E+00,.9364E+00,.1473E+00,& - .8116E-01,.1411E+00,.1276E+00,.2344E+00,.5604E+00,.6558E+00,.7125E+00,.7251E+00,.9362E+00,.1477E+00,& - .8183E-01,.1417E+00,.1281E+00,.2339E+00,.5598E+00,.6558E+00,.7126E+00,.7248E+00,.9360E+00,.1482E+00,& - .8249E-01,.1423E+00,.1286E+00,.2334E+00,.5592E+00,.6557E+00,.7128E+00,.7246E+00,.9358E+00,.1486E+00,& - .8316E-01,.1429E+00,.1290E+00,.2329E+00,.5585E+00,.6557E+00,.7129E+00,.7244E+00,.9357E+00,.1491E+00,& - .8383E-01,.1435E+00,.1296E+00,.2325E+00,.5581E+00,.6557E+00,.7131E+00,.7242E+00,.9355E+00,.1496E+00,& - .8450E-01,.1442E+00,.1301E+00,.2322E+00,.5576E+00,.6557E+00,.7133E+00,.7240E+00,.9353E+00,.1501E+00,& - .8517E-01,.1448E+00,.1306E+00,.2318E+00,.5571E+00,.6557E+00,.7135E+00,.7239E+00,.9352E+00,.1506E+00,& - .8584E-01,.1455E+00,.1311E+00,.2314E+00,.5566E+00,.6558E+00,.7136E+00,.7237E+00,.9350E+00,.1511E+00,& - .8651E-01,.1461E+00,.1316E+00,.2311E+00,.5562E+00,.6558E+00,.7138E+00,.7235E+00,.9348E+00,.1516E+00,& - .8761E-01,.1472E+00,.1324E+00,.2307E+00,.5557E+00,.6560E+00,.7142E+00,.7234E+00,.9346E+00,.1524E+00,& - .8870E-01,.1482E+00,.1332E+00,.2304E+00,.5552E+00,.6562E+00,.7146E+00,.7233E+00,.9344E+00,.1532E+00,& - .8980E-01,.1493E+00,.1341E+00,.2301E+00,.5547E+00,.6563E+00,.7150E+00,.7232E+00,.9341E+00,.1541E+00,& - .9089E-01,.1503E+00,.1349E+00,.2297E+00,.5542E+00,.6565E+00,.7154E+00,.7231E+00,.9339E+00,.1549E+00,& - .9198E-01,.1514E+00,.1358E+00,.2294E+00,.5538E+00,.6567E+00,.7157E+00,.7229E+00,.9337E+00,.1557E+00,& - .9334E-01,.1527E+00,.1369E+00,.2293E+00,.5535E+00,.6571E+00,.7163E+00,.7229E+00,.9334E+00,.1568E+00,& - .9470E-01,.1541E+00,.1380E+00,.2292E+00,.5533E+00,.6575E+00,.7169E+00,.7229E+00,.9332E+00,.1579E+00,& - .9606E-01,.1554E+00,.1390E+00,.2292E+00,.5531E+00,.6579E+00,.7174E+00,.7229E+00,.9330E+00,.1590E+00,& - .9741E-01,.1568E+00,.1401E+00,.2291E+00,.5529E+00,.6583E+00,.7180E+00,.7229E+00,.9327E+00,.1600E+00,& - .9877E-01,.1581E+00,.1412E+00,.2290E+00,.5526E+00,.6587E+00,.7185E+00,.7228E+00,.9325E+00,.1611E+00,& - .1004E+00,.1597E+00,.1426E+00,.2291E+00,.5526E+00,.6593E+00,.7193E+00,.7229E+00,.9322E+00,.1625E+00,& - .1027E+00,.1619E+00,.1444E+00,.2294E+00,.5527E+00,.6601E+00,.7203E+00,.7231E+00,.9319E+00,.1643E+00,& - .1046E+00,.1639E+00,.1460E+00,.2297E+00,.5529E+00,.6609E+00,.7212E+00,.7233E+00,.9316E+00,.1660E+00,& - .1066E+00,.1658E+00,.1476E+00,.2301E+00,.5532E+00,.6617E+00,.7221E+00,.7235E+00,.9313E+00,.1676E+00,& - .1095E+00,.1686E+00,.1500E+00,.2308E+00,.5538E+00,.6630E+00,.7235E+00,.7238E+00,.9309E+00,.1700E+00,& - .1118E+00,.1709E+00,.1519E+00,.2316E+00,.5543E+00,.6641E+00,.7246E+00,.7241E+00,.9306E+00,.1719E+00,& - .1147E+00,.1738E+00,.1543E+00,.2326E+00,.5552E+00,.6655E+00,.7259E+00,.7246E+00,.9303E+00,.1743E+00,& - .1175E+00,.1766E+00,.1567E+00,.2337E+00,.5562E+00,.6669E+00,.7273E+00,.7251E+00,.9299E+00,.1767E+00,& - .1208E+00,.1798E+00,.1594E+00,.2350E+00,.5575E+00,.6685E+00,.7289E+00,.7256E+00,.9295E+00,.1795E+00,& - .1249E+00,.1839E+00,.1628E+00,.2369E+00,.5593E+00,.6707E+00,.7308E+00,.7264E+00,.9291E+00,.1830E+00,& - .1290E+00,.1879E+00,.1662E+00,.2390E+00,.5613E+00,.6728E+00,.7328E+00,.7272E+00,.9287E+00,.1865E+00,& - .1346E+00,.1933E+00,.1708E+00,.2420E+00,.5642E+00,.6758E+00,.7354E+00,.7284E+00,.9280E+00,.1912E+00,& - .1405E+00,.1990E+00,.1756E+00,.2454E+00,.5675E+00,.6790E+00,.7380E+00,.7296E+00,.9274E+00,.1961E+00,& - .1481E+00,.2063E+00,.1818E+00,.2501E+00,.5720E+00,.6831E+00,.7414E+00,.7311E+00,.9265E+00,.2025E+00,& - .1578E+00,.2156E+00,.1898E+00,.2565E+00,.5781E+00,.6883E+00,.7454E+00,.7331E+00,.9255E+00,.2106E+00,& - .1690E+00,.2261E+00,.1988E+00,.2641E+00,.5853E+00,.6941E+00,.7496E+00,.7352E+00,.9242E+00,.2198E+00,& - .1868E+00,.2426E+00,.2131E+00,.2771E+00,.5969E+00,.7028E+00,.7557E+00,.7383E+00,.9218E+00,.2345E+00,& - .2092E+00,.2629E+00,.2311E+00,.2941E+00,.6113E+00,.7127E+00,.7621E+00,.7413E+00,.9183E+00,.2527E+00,& - .2497E+00,.2985E+00,.2634E+00,.3260E+00,.6351E+00,.7271E+00,.7697E+00,.7440E+00,.9103E+00,.2851E+00/ - data (((w0_lw(ai,k,nh),ai= 6, 6),k=1,nwl_lw),nh=0,99)/ & - .3712E+00,.5599E+00,.7804E+00,.9078E+00,.8815E+00,.8358E+00,.9067E+00,.9278E+00,.9736E+00,.6545E+00,& - .3711E+00,.5523E+00,.7479E+00,.8880E+00,.8761E+00,.8331E+00,.9016E+00,.9184E+00,.9693E+00,.6377E+00,& - .3710E+00,.5448E+00,.7154E+00,.8682E+00,.8707E+00,.8305E+00,.8964E+00,.9089E+00,.9651E+00,.6209E+00,& - .3708E+00,.5372E+00,.6829E+00,.8484E+00,.8654E+00,.8279E+00,.8912E+00,.8994E+00,.9608E+00,.6040E+00,& - .3707E+00,.5296E+00,.6504E+00,.8286E+00,.8600E+00,.8253E+00,.8860E+00,.8900E+00,.9566E+00,.5872E+00,& - .3706E+00,.5221E+00,.6180E+00,.8088E+00,.8546E+00,.8226E+00,.8809E+00,.8805E+00,.9523E+00,.5704E+00,& - .3707E+00,.5170E+00,.6009E+00,.7953E+00,.8501E+00,.8204E+00,.8765E+00,.8739E+00,.9491E+00,.5603E+00,& - .3708E+00,.5119E+00,.5838E+00,.7818E+00,.8457E+00,.8182E+00,.8722E+00,.8674E+00,.9458E+00,.5502E+00,& - .3709E+00,.5068E+00,.5668E+00,.7682E+00,.8412E+00,.8160E+00,.8679E+00,.8608E+00,.9425E+00,.5401E+00,& - .3711E+00,.5017E+00,.5497E+00,.7547E+00,.8367E+00,.8138E+00,.8636E+00,.8542E+00,.9392E+00,.5300E+00,& - .3712E+00,.4966E+00,.5327E+00,.7412E+00,.8323E+00,.8116E+00,.8593E+00,.8477E+00,.9359E+00,.5199E+00,& - .3715E+00,.4931E+00,.5227E+00,.7312E+00,.8285E+00,.8094E+00,.8559E+00,.8428E+00,.9331E+00,.5134E+00,& - .3719E+00,.4895E+00,.5127E+00,.7213E+00,.8248E+00,.8072E+00,.8525E+00,.8379E+00,.9303E+00,.5070E+00,& - .3722E+00,.4860E+00,.5027E+00,.7113E+00,.8210E+00,.8049E+00,.8492E+00,.8330E+00,.9274E+00,.5005E+00,& - .3725E+00,.4825E+00,.4928E+00,.7013E+00,.8173E+00,.8027E+00,.8458E+00,.8281E+00,.9246E+00,.4940E+00,& - .3729E+00,.4789E+00,.4828E+00,.6913E+00,.8136E+00,.8005E+00,.8424E+00,.8232E+00,.9218E+00,.4875E+00,& - .3733E+00,.4764E+00,.4767E+00,.6836E+00,.8103E+00,.7988E+00,.8395E+00,.8193E+00,.9194E+00,.4832E+00,& - .3738E+00,.4739E+00,.4705E+00,.6759E+00,.8071E+00,.7971E+00,.8365E+00,.8154E+00,.9171E+00,.4789E+00,& - .3742E+00,.4715E+00,.4644E+00,.6682E+00,.8038E+00,.7954E+00,.8335E+00,.8115E+00,.9148E+00,.4746E+00,& - .3747E+00,.4690E+00,.4583E+00,.6605E+00,.8006E+00,.7937E+00,.8305E+00,.8076E+00,.9125E+00,.4703E+00,& - .3751E+00,.4665E+00,.4522E+00,.6528E+00,.7973E+00,.7920E+00,.8275E+00,.8037E+00,.9102E+00,.4660E+00,& - .3757E+00,.4647E+00,.4483E+00,.6468E+00,.7945E+00,.7903E+00,.8251E+00,.8006E+00,.9082E+00,.4631E+00,& - .3762E+00,.4630E+00,.4445E+00,.6407E+00,.7917E+00,.7886E+00,.8228E+00,.7975E+00,.9061E+00,.4602E+00,& - .3767E+00,.4612E+00,.4407E+00,.6347E+00,.7889E+00,.7869E+00,.8204E+00,.7944E+00,.9040E+00,.4573E+00,& - .3773E+00,.4595E+00,.4368E+00,.6286E+00,.7861E+00,.7851E+00,.8180E+00,.7913E+00,.9020E+00,.4544E+00,& - .3778E+00,.4577E+00,.4330E+00,.6226E+00,.7833E+00,.7834E+00,.8156E+00,.7882E+00,.8999E+00,.4515E+00,& - .3784E+00,.4565E+00,.4306E+00,.6177E+00,.7808E+00,.7819E+00,.8134E+00,.7855E+00,.8981E+00,.4496E+00,& - .3790E+00,.4552E+00,.4281E+00,.6129E+00,.7784E+00,.7804E+00,.8112E+00,.7828E+00,.8963E+00,.4476E+00,& - .3796E+00,.4540E+00,.4257E+00,.6081E+00,.7759E+00,.7789E+00,.8089E+00,.7802E+00,.8945E+00,.4456E+00,& - .3802E+00,.4528E+00,.4233E+00,.6033E+00,.7734E+00,.7774E+00,.8067E+00,.7775E+00,.8927E+00,.4437E+00,& - .3808E+00,.4515E+00,.4209E+00,.5985E+00,.7710E+00,.7759E+00,.8045E+00,.7748E+00,.8909E+00,.4417E+00,& - .3815E+00,.4507E+00,.4194E+00,.5946E+00,.7688E+00,.7745E+00,.8027E+00,.7726E+00,.8892E+00,.4404E+00,& - .3821E+00,.4498E+00,.4179E+00,.5907E+00,.7666E+00,.7732E+00,.8008E+00,.7705E+00,.8876E+00,.4390E+00,& - .3827E+00,.4489E+00,.4163E+00,.5868E+00,.7644E+00,.7719E+00,.7990E+00,.7683E+00,.8860E+00,.4377E+00,& - .3834E+00,.4481E+00,.4148E+00,.5829E+00,.7622E+00,.7705E+00,.7972E+00,.7661E+00,.8844E+00,.4364E+00,& - .3840E+00,.4472E+00,.4133E+00,.5790E+00,.7600E+00,.7692E+00,.7953E+00,.7639E+00,.8828E+00,.4351E+00,& - .3847E+00,.4466E+00,.4124E+00,.5759E+00,.7581E+00,.7679E+00,.7936E+00,.7619E+00,.8812E+00,.4342E+00,& - .3853E+00,.4460E+00,.4115E+00,.5728E+00,.7561E+00,.7666E+00,.7919E+00,.7599E+00,.8796E+00,.4333E+00,& - .3859E+00,.4454E+00,.4106E+00,.5696E+00,.7542E+00,.7653E+00,.7901E+00,.7579E+00,.8781E+00,.4324E+00,& - .3866E+00,.4448E+00,.4097E+00,.5665E+00,.7523E+00,.7640E+00,.7884E+00,.7559E+00,.8765E+00,.4316E+00,& - .3872E+00,.4443E+00,.4088E+00,.5634E+00,.7504E+00,.7627E+00,.7867E+00,.7539E+00,.8750E+00,.4307E+00,& - .3879E+00,.4439E+00,.4083E+00,.5608E+00,.7487E+00,.7616E+00,.7851E+00,.7523E+00,.8736E+00,.4301E+00,& - .3885E+00,.4435E+00,.4078E+00,.5583E+00,.7469E+00,.7605E+00,.7836E+00,.7506E+00,.8723E+00,.4296E+00,& - .3892E+00,.4431E+00,.4073E+00,.5557E+00,.7452E+00,.7593E+00,.7820E+00,.7489E+00,.8709E+00,.4290E+00,& - .3899E+00,.4427E+00,.4068E+00,.5532E+00,.7435E+00,.7582E+00,.7805E+00,.7473E+00,.8696E+00,.4284E+00,& - .3905E+00,.4424E+00,.4063E+00,.5506E+00,.7418E+00,.7571E+00,.7790E+00,.7456E+00,.8683E+00,.4279E+00,& - .3912E+00,.4421E+00,.4060E+00,.5485E+00,.7402E+00,.7560E+00,.7776E+00,.7441E+00,.8669E+00,.4275E+00,& - .3918E+00,.4419E+00,.4058E+00,.5464E+00,.7387E+00,.7549E+00,.7763E+00,.7426E+00,.8655E+00,.4272E+00,& - .3925E+00,.4416E+00,.4056E+00,.5443E+00,.7371E+00,.7538E+00,.7749E+00,.7411E+00,.8642E+00,.4269E+00,& - .3931E+00,.4414E+00,.4054E+00,.5422E+00,.7355E+00,.7527E+00,.7736E+00,.7396E+00,.8628E+00,.4266E+00,& - .3938E+00,.4411E+00,.4051E+00,.5402E+00,.7340E+00,.7516E+00,.7722E+00,.7380E+00,.8614E+00,.4262E+00,& - .3943E+00,.4410E+00,.4051E+00,.5387E+00,.7329E+00,.7508E+00,.7711E+00,.7369E+00,.8605E+00,.4261E+00,& - .3948E+00,.4409E+00,.4051E+00,.5373E+00,.7317E+00,.7500E+00,.7700E+00,.7357E+00,.8596E+00,.4260E+00,& - .3953E+00,.4408E+00,.4050E+00,.5359E+00,.7306E+00,.7491E+00,.7689E+00,.7345E+00,.8587E+00,.4258E+00,& - .3958E+00,.4407E+00,.4050E+00,.5345E+00,.7294E+00,.7483E+00,.7678E+00,.7333E+00,.8578E+00,.4257E+00,& - .3963E+00,.4406E+00,.4050E+00,.5331E+00,.7283E+00,.7475E+00,.7667E+00,.7321E+00,.8568E+00,.4255E+00,& - .3968E+00,.4406E+00,.4050E+00,.5319E+00,.7273E+00,.7467E+00,.7657E+00,.7311E+00,.8559E+00,.4255E+00,& - .3974E+00,.4405E+00,.4051E+00,.5307E+00,.7262E+00,.7459E+00,.7647E+00,.7301E+00,.8549E+00,.4254E+00,& - .3979E+00,.4405E+00,.4052E+00,.5295E+00,.7251E+00,.7451E+00,.7638E+00,.7291E+00,.8539E+00,.4254E+00,& - .3984E+00,.4404E+00,.4052E+00,.5283E+00,.7241E+00,.7444E+00,.7628E+00,.7281E+00,.8529E+00,.4253E+00,& - .3989E+00,.4404E+00,.4053E+00,.5271E+00,.7230E+00,.7436E+00,.7618E+00,.7271E+00,.8519E+00,.4253E+00,& - .3994E+00,.4404E+00,.4054E+00,.5260E+00,.7220E+00,.7428E+00,.7609E+00,.7261E+00,.8509E+00,.4253E+00,& - .3999E+00,.4404E+00,.4056E+00,.5250E+00,.7211E+00,.7421E+00,.7600E+00,.7252E+00,.8500E+00,.4253E+00,& - .4004E+00,.4404E+00,.4057E+00,.5240E+00,.7201E+00,.7414E+00,.7591E+00,.7242E+00,.8490E+00,.4254E+00,& - .4009E+00,.4404E+00,.4058E+00,.5229E+00,.7191E+00,.7406E+00,.7582E+00,.7232E+00,.8480E+00,.4254E+00,& - .4014E+00,.4404E+00,.4060E+00,.5219E+00,.7181E+00,.7399E+00,.7573E+00,.7223E+00,.8471E+00,.4254E+00,& - .4019E+00,.4405E+00,.4062E+00,.5210E+00,.7172E+00,.7392E+00,.7564E+00,.7213E+00,.8462E+00,.4255E+00,& - .4024E+00,.4405E+00,.4063E+00,.5202E+00,.7163E+00,.7384E+00,.7554E+00,.7203E+00,.8454E+00,.4256E+00,& - .4028E+00,.4406E+00,.4065E+00,.5193E+00,.7154E+00,.7377E+00,.7545E+00,.7193E+00,.8445E+00,.4256E+00,& - .4033E+00,.4406E+00,.4067E+00,.5185E+00,.7145E+00,.7370E+00,.7535E+00,.7183E+00,.8437E+00,.4257E+00,& - .4038E+00,.4406E+00,.4069E+00,.5176E+00,.7136E+00,.7363E+00,.7525E+00,.7173E+00,.8428E+00,.4258E+00,& - .4045E+00,.4408E+00,.4072E+00,.5165E+00,.7124E+00,.7352E+00,.7513E+00,.7161E+00,.8416E+00,.4259E+00,& - .4052E+00,.4409E+00,.4076E+00,.5155E+00,.7112E+00,.7342E+00,.7500E+00,.7149E+00,.8403E+00,.4261E+00,& - .4059E+00,.4410E+00,.4079E+00,.5144E+00,.7099E+00,.7332E+00,.7488E+00,.7137E+00,.8391E+00,.4263E+00,& - .4066E+00,.4411E+00,.4083E+00,.5134E+00,.7087E+00,.7322E+00,.7475E+00,.7124E+00,.8379E+00,.4265E+00,& - .4073E+00,.4412E+00,.4086E+00,.5123E+00,.7075E+00,.7312E+00,.7463E+00,.7112E+00,.8367E+00,.4266E+00,& - .4083E+00,.4415E+00,.4092E+00,.5112E+00,.7059E+00,.7298E+00,.7445E+00,.7095E+00,.8350E+00,.4270E+00,& - .4092E+00,.4417E+00,.4098E+00,.5100E+00,.7043E+00,.7285E+00,.7428E+00,.7077E+00,.8332E+00,.4274E+00,& - .4102E+00,.4420E+00,.4104E+00,.5088E+00,.7027E+00,.7271E+00,.7411E+00,.7060E+00,.8315E+00,.4277E+00,& - .4111E+00,.4422E+00,.4110E+00,.5077E+00,.7011E+00,.7257E+00,.7394E+00,.7042E+00,.8298E+00,.4281E+00,& - .4121E+00,.4424E+00,.4116E+00,.5065E+00,.6995E+00,.7243E+00,.7377E+00,.7025E+00,.8281E+00,.4285E+00,& - .4131E+00,.4428E+00,.4123E+00,.5055E+00,.6979E+00,.7229E+00,.7359E+00,.7009E+00,.8266E+00,.4289E+00,& - .4145E+00,.4433E+00,.4134E+00,.5042E+00,.6957E+00,.7209E+00,.7334E+00,.6986E+00,.8237E+00,.4296E+00,& - .4159E+00,.4438E+00,.4144E+00,.5030E+00,.6936E+00,.7189E+00,.7310E+00,.6962E+00,.8213E+00,.4304E+00,& - .4173E+00,.4443E+00,.4155E+00,.5020E+00,.6915E+00,.7169E+00,.7288E+00,.6940E+00,.8188E+00,.4311E+00,& - .4188E+00,.4449E+00,.4168E+00,.5009E+00,.6891E+00,.7146E+00,.7258E+00,.6914E+00,.8159E+00,.4320E+00,& - .4203E+00,.4456E+00,.4180E+00,.4999E+00,.6868E+00,.7124E+00,.7230E+00,.6885E+00,.8134E+00,.4329E+00,& - .4217E+00,.4462E+00,.4193E+00,.4991E+00,.6847E+00,.7102E+00,.7203E+00,.6862E+00,.8106E+00,.4339E+00,& - .4232E+00,.4469E+00,.4206E+00,.4984E+00,.6825E+00,.7080E+00,.7176E+00,.6837E+00,.8080E+00,.4349E+00,& - .4249E+00,.4477E+00,.4222E+00,.4977E+00,.6800E+00,.7055E+00,.7148E+00,.6810E+00,.8048E+00,.4360E+00,& - .4268E+00,.4487E+00,.4239E+00,.4970E+00,.6772E+00,.7025E+00,.7110E+00,.6777E+00,.8012E+00,.4374E+00,& - .4290E+00,.4498E+00,.4260E+00,.4964E+00,.6740E+00,.6991E+00,.7068E+00,.6738E+00,.7973E+00,.4390E+00,& - .4312E+00,.4511E+00,.4283E+00,.4959E+00,.6708E+00,.6955E+00,.7026E+00,.6700E+00,.7928E+00,.4407E+00,& - .4342E+00,.4528E+00,.4314E+00,.4955E+00,.6662E+00,.6903E+00,.6962E+00,.6646E+00,.7866E+00,.4432E+00,& - .4375E+00,.4548E+00,.4349E+00,.4954E+00,.6613E+00,.6845E+00,.6895E+00,.6588E+00,.7800E+00,.4460E+00,& - .4411E+00,.4572E+00,.4390E+00,.4955E+00,.6556E+00,.6778E+00,.6813E+00,.6518E+00,.7724E+00,.4493E+00,& - .4458E+00,.4604E+00,.4444E+00,.4960E+00,.6479E+00,.6685E+00,.6707E+00,.6432E+00,.7615E+00,.4538E+00,& - .4508E+00,.4640E+00,.4506E+00,.4970E+00,.6388E+00,.6572E+00,.6580E+00,.6330E+00,.7496E+00,.4590E+00,& - .4576E+00,.4694E+00,.4595E+00,.4987E+00,.6249E+00,.6401E+00,.6388E+00,.6181E+00,.7317E+00,.4667E+00,& - .4676E+00,.4782E+00,.4737E+00,.5013E+00,.6004E+00,.6105E+00,.6078E+00,.5954E+00,.7018E+00,.4792E+00/ - data (((w0_lw(ai,k,nh),ai= 7, 7),k=1,nwl_lw),nh=0,99)/ & - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02,& - .2197E-02,.6746E-02,.1180E-01,.4600E-01,.1326E+00,.1585E-01,.3566E-01,.2440E+00,.8000E+00,.4246E-02/ - data (((w0_lw(ai,k,nh),ai= 8, 8),k=1,nwl_lw),nh=0,99)/ & - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01,& - .1124E-01,.3363E-01,.5143E-01,.1676E+00,.3616E+00,.5619E-01,.1188E+00,.5075E+00,.9197E+00,.2001E-01/ - data (((w0_lw(ai,k,nh),ai= 9, 9),k=1,nwl_lw),nh=0,99)/ & - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01,& - .6895E-01,.1656E+00,.1932E+00,.4259E+00,.5864E+00,.1452E+00,.3025E+00,.7524E+00,.9651E+00,.9678E-01/ - data (((w0_lw(ai,k,nh),ai=10,10),k=1,nwl_lw),nh=0,99)/ & - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00,& - .2483E+00,.3891E+00,.3981E+00,.6198E+00,.6636E+00,.2352E+00,.4878E+00,.8585E+00,.9770E+00,.2650E+00/ - data (((w0_lw(ai,k,nh),ai=11,11),k=1,nwl_lw),nh=0,99)/ & - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00,& - .4797E+00,.5432E+00,.5688E+00,.7105E+00,.6756E+00,.3210E+00,.6267E+00,.8988E+00,.9792E+00,.4551E+00/ - data (((w0_lw(ai,k,nh),ai=12,12),k=1,nwl_lw),nh=0,99)/ & - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00,& - .6075E+00,.6016E+00,.6631E+00,.7363E+00,.6573E+00,.3976E+00,.7115E+00,.9084E+00,.9753E+00,.5818E+00/ - data (((w0_lw(ai,k,nh),ai=13,13),k=1,nwl_lw),nh=0,99)/ & - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00,& - .6516E+00,.6090E+00,.7009E+00,.7181E+00,.6159E+00,.4675E+00,.7582E+00,.8931E+00,.9612E+00,.6491E+00/ - data (((w0_lw(ai,k,nh),ai=14,14),k=1,nwl_lw),nh=0,99)/ & - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00,& - .6415E+00,.5860E+00,.6866E+00,.6671E+00,.5811E+00,.5067E+00,.7567E+00,.8505E+00,.9340E+00,.6543E+00/ - data (((g_lw(ai,k,nh),ai= 1, 1),k=1,nwl_lw),nh=0,99)/ & - .4974E-03,.1097E-02,.2259E-02,.4134E-02,.5324E-02,.5525E-02,.6496E-02,.1171E-01,.2654E-01,.1705E-02,& - .5026E-03,.1108E-02,.2281E-02,.4167E-02,.5384E-02,.5621E-02,.6616E-02,.1188E-01,.2695E-01,.1724E-02,& - .5078E-03,.1120E-02,.2303E-02,.4201E-02,.5445E-02,.5717E-02,.6735E-02,.1205E-01,.2735E-01,.1743E-02,& - .5129E-03,.1131E-02,.2326E-02,.4234E-02,.5505E-02,.5813E-02,.6854E-02,.1223E-01,.2775E-01,.1761E-02,& - .5181E-03,.1142E-02,.2348E-02,.4268E-02,.5566E-02,.5909E-02,.6974E-02,.1240E-01,.2815E-01,.1780E-02,& - .5233E-03,.1154E-02,.2371E-02,.4302E-02,.5626E-02,.6006E-02,.7093E-02,.1257E-01,.2856E-01,.1799E-02,& - .5288E-03,.1166E-02,.2395E-02,.4339E-02,.5689E-02,.6102E-02,.7215E-02,.1275E-01,.2897E-01,.1818E-02,& - .5343E-03,.1178E-02,.2419E-02,.4376E-02,.5753E-02,.6199E-02,.7336E-02,.1293E-01,.2939E-01,.1838E-02,& - .5398E-03,.1190E-02,.2443E-02,.4414E-02,.5816E-02,.6296E-02,.7458E-02,.1311E-01,.2980E-01,.1858E-02,& - .5453E-03,.1202E-02,.2467E-02,.4451E-02,.5880E-02,.6393E-02,.7580E-02,.1329E-01,.3022E-01,.1878E-02,& - .5508E-03,.1214E-02,.2492E-02,.4489E-02,.5943E-02,.6490E-02,.7701E-02,.1347E-01,.3064E-01,.1898E-02,& - .5567E-03,.1227E-02,.2517E-02,.4530E-02,.6010E-02,.6587E-02,.7825E-02,.1366E-01,.3106E-01,.1919E-02,& - .5626E-03,.1240E-02,.2543E-02,.4571E-02,.6077E-02,.6685E-02,.7948E-02,.1384E-01,.3149E-01,.1940E-02,& - .5685E-03,.1253E-02,.2569E-02,.4612E-02,.6143E-02,.6783E-02,.8072E-02,.1403E-01,.3192E-01,.1961E-02,& - .5743E-03,.1266E-02,.2595E-02,.4653E-02,.6210E-02,.6881E-02,.8195E-02,.1422E-01,.3235E-01,.1982E-02,& - .5802E-03,.1279E-02,.2621E-02,.4695E-02,.6277E-02,.6978E-02,.8319E-02,.1440E-01,.3278E-01,.2003E-02,& - .5863E-03,.1292E-02,.2648E-02,.4738E-02,.6346E-02,.7078E-02,.8446E-02,.1459E-01,.3323E-01,.2025E-02,& - .5925E-03,.1306E-02,.2675E-02,.4782E-02,.6415E-02,.7178E-02,.8573E-02,.1479E-01,.3367E-01,.2047E-02,& - .5986E-03,.1319E-02,.2703E-02,.4826E-02,.6484E-02,.7278E-02,.8700E-02,.1498E-01,.3412E-01,.2068E-02,& - .6048E-03,.1333E-02,.2730E-02,.4869E-02,.6554E-02,.7377E-02,.8827E-02,.1517E-01,.3456E-01,.2090E-02,& - .6109E-03,.1346E-02,.2757E-02,.4913E-02,.6623E-02,.7477E-02,.8954E-02,.1536E-01,.3501E-01,.2112E-02,& - .6174E-03,.1360E-02,.2786E-02,.4960E-02,.6695E-02,.7579E-02,.9084E-02,.1556E-01,.3546E-01,.2135E-02,& - .6238E-03,.1374E-02,.2814E-02,.5006E-02,.6767E-02,.7681E-02,.9215E-02,.1576E-01,.3592E-01,.2158E-02,& - .6303E-03,.1388E-02,.2843E-02,.5053E-02,.6839E-02,.7783E-02,.9345E-02,.1596E-01,.3638E-01,.2181E-02,& - .6367E-03,.1402E-02,.2871E-02,.5099E-02,.6911E-02,.7885E-02,.9475E-02,.1616E-01,.3684E-01,.2204E-02,& - .6432E-03,.1417E-02,.2900E-02,.5146E-02,.6983E-02,.7986E-02,.9606E-02,.1636E-01,.3730E-01,.2227E-02,& - .6499E-03,.1431E-02,.2930E-02,.5195E-02,.7058E-02,.8090E-02,.9739E-02,.1656E-01,.3777E-01,.2251E-02,& - .6566E-03,.1446E-02,.2960E-02,.5244E-02,.7133E-02,.8194E-02,.9873E-02,.1677E-01,.3824E-01,.2275E-02,& - .6633E-03,.1461E-02,.2990E-02,.5294E-02,.7208E-02,.8298E-02,.1001E-01,.1698E-01,.3872E-01,.2299E-02,& - .6701E-03,.1475E-02,.3020E-02,.5343E-02,.7283E-02,.8402E-02,.1014E-01,.1718E-01,.3919E-01,.2323E-02,& - .6768E-03,.1490E-02,.3050E-02,.5392E-02,.7358E-02,.8506E-02,.1027E-01,.1739E-01,.3966E-01,.2346E-02,& - .6838E-03,.1505E-02,.3081E-02,.5444E-02,.7436E-02,.8613E-02,.1041E-01,.1760E-01,.4015E-01,.2371E-02,& - .6908E-03,.1521E-02,.3112E-02,.5496E-02,.7514E-02,.8719E-02,.1055E-01,.1781E-01,.4064E-01,.2396E-02,& - .6978E-03,.1536E-02,.3143E-02,.5547E-02,.7592E-02,.8826E-02,.1068E-01,.1802E-01,.4113E-01,.2421E-02,& - .7049E-03,.1551E-02,.3175E-02,.5599E-02,.7669E-02,.8932E-02,.1082E-01,.1823E-01,.4161E-01,.2446E-02,& - .7119E-03,.1567E-02,.3206E-02,.5651E-02,.7747E-02,.9038E-02,.1096E-01,.1844E-01,.4210E-01,.2471E-02,& - .7192E-03,.1583E-02,.3239E-02,.5705E-02,.7828E-02,.9147E-02,.1110E-01,.1866E-01,.4260E-01,.2497E-02,& - .7265E-03,.1599E-02,.3271E-02,.5760E-02,.7908E-02,.9256E-02,.1124E-01,.1888E-01,.4310E-01,.2522E-02,& - .7338E-03,.1615E-02,.3304E-02,.5814E-02,.7989E-02,.9364E-02,.1137E-01,.1910E-01,.4360E-01,.2548E-02,& - .7411E-03,.1631E-02,.3336E-02,.5868E-02,.8070E-02,.9473E-02,.1151E-01,.1931E-01,.4410E-01,.2574E-02,& - .7484E-03,.1647E-02,.3369E-02,.5923E-02,.8151E-02,.9581E-02,.1165E-01,.1953E-01,.4460E-01,.2600E-02,& - .7559E-03,.1663E-02,.3403E-02,.5979E-02,.8234E-02,.9693E-02,.1180E-01,.1976E-01,.4512E-01,.2627E-02,& - .7635E-03,.1680E-02,.3436E-02,.6036E-02,.8317E-02,.9804E-02,.1194E-01,.1998E-01,.4564E-01,.2653E-02,& - .7710E-03,.1696E-02,.3470E-02,.6092E-02,.8400E-02,.9916E-02,.1208E-01,.2021E-01,.4615E-01,.2680E-02,& - .7786E-03,.1713E-02,.3504E-02,.6149E-02,.8484E-02,.1003E-01,.1223E-01,.2043E-01,.4667E-01,.2707E-02,& - .7861E-03,.1729E-02,.3538E-02,.6205E-02,.8567E-02,.1014E-01,.1237E-01,.2065E-01,.4718E-01,.2734E-02,& - .7940E-03,.1746E-02,.3573E-02,.6264E-02,.8653E-02,.1025E-01,.1252E-01,.2088E-01,.4771E-01,.2761E-02,& - .8018E-03,.1763E-02,.3608E-02,.6322E-02,.8739E-02,.1037E-01,.1267E-01,.2111E-01,.4824E-01,.2789E-02,& - .8096E-03,.1780E-02,.3643E-02,.6381E-02,.8825E-02,.1048E-01,.1281E-01,.2135E-01,.4878E-01,.2816E-02,& - .8175E-03,.1797E-02,.3678E-02,.6440E-02,.8911E-02,.1060E-01,.1296E-01,.2158E-01,.4931E-01,.2844E-02,& - .8253E-03,.1814E-02,.3712E-02,.6498E-02,.8997E-02,.1071E-01,.1311E-01,.2181E-01,.4984E-01,.2871E-02,& - .8334E-03,.1832E-02,.3749E-02,.6559E-02,.9086E-02,.1083E-01,.1326E-01,.2204E-01,.5038E-01,.2900E-02,& - .8414E-03,.1850E-02,.3785E-02,.6621E-02,.9174E-02,.1094E-01,.1341E-01,.2228E-01,.5092E-01,.2929E-02,& - .8495E-03,.1867E-02,.3821E-02,.6682E-02,.9263E-02,.1106E-01,.1356E-01,.2252E-01,.5146E-01,.2957E-02,& - .8576E-03,.1885E-02,.3858E-02,.6743E-02,.9352E-02,.1118E-01,.1370E-01,.2275E-01,.5200E-01,.2986E-02,& - .8656E-03,.1903E-02,.3894E-02,.6805E-02,.9441E-02,.1129E-01,.1385E-01,.2299E-01,.5255E-01,.3014E-02,& - .8740E-03,.1921E-02,.3931E-02,.6868E-02,.9533E-02,.1141E-01,.1401E-01,.2323E-01,.5310E-01,.3044E-02,& - .8823E-03,.1939E-02,.3969E-02,.6931E-02,.9624E-02,.1153E-01,.1416E-01,.2347E-01,.5366E-01,.3073E-02,& - .8907E-03,.1957E-02,.4006E-02,.6995E-02,.9715E-02,.1165E-01,.1431E-01,.2371E-01,.5421E-01,.3102E-02,& - .8990E-03,.1976E-02,.4044E-02,.7058E-02,.9807E-02,.1177E-01,.1447E-01,.2395E-01,.5476E-01,.3132E-02,& - .9073E-03,.1994E-02,.4081E-02,.7121E-02,.9898E-02,.1189E-01,.1462E-01,.2419E-01,.5532E-01,.3161E-02,& - .9159E-03,.2013E-02,.4119E-02,.7186E-02,.9992E-02,.1201E-01,.1478E-01,.2444E-01,.5589E-01,.3191E-02,& - .9245E-03,.2031E-02,.4158E-02,.7252E-02,.1009E-01,.1213E-01,.1493E-01,.2469E-01,.5646E-01,.3221E-02,& - .9331E-03,.2050E-02,.4196E-02,.7317E-02,.1018E-01,.1226E-01,.1509E-01,.2494E-01,.5703E-01,.3252E-02,& - .9417E-03,.2069E-02,.4235E-02,.7382E-02,.1027E-01,.1238E-01,.1525E-01,.2519E-01,.5760E-01,.3282E-02,& - .9503E-03,.2087E-02,.4273E-02,.7447E-02,.1037E-01,.1250E-01,.1541E-01,.2544E-01,.5817E-01,.3312E-02,& - .9592E-03,.2107E-02,.4313E-02,.7514E-02,.1046E-01,.1263E-01,.1557E-01,.2569E-01,.5876E-01,.3343E-02,& - .9680E-03,.2126E-02,.4352E-02,.7581E-02,.1056E-01,.1275E-01,.1573E-01,.2595E-01,.5934E-01,.3374E-02,& - .9768E-03,.2145E-02,.4392E-02,.7648E-02,.1066E-01,.1288E-01,.1589E-01,.2620E-01,.5993E-01,.3405E-02,& - .9856E-03,.2165E-02,.4431E-02,.7715E-02,.1075E-01,.1300E-01,.1605E-01,.2646E-01,.6051E-01,.3436E-02,& - .9944E-03,.2184E-02,.4471E-02,.7783E-02,.1085E-01,.1313E-01,.1621E-01,.2671E-01,.6110E-01,.3467E-02,& - .1004E-02,.2204E-02,.4512E-02,.7851E-02,.1095E-01,.1326E-01,.1638E-01,.2698E-01,.6173E-01,.3500E-02,& - .1013E-02,.2223E-02,.4552E-02,.7919E-02,.1105E-01,.1339E-01,.1656E-01,.2726E-01,.6236E-01,.3532E-02,& - .1022E-02,.2243E-02,.4593E-02,.7987E-02,.1115E-01,.1353E-01,.1673E-01,.2753E-01,.6299E-01,.3564E-02,& - .1031E-02,.2263E-02,.4634E-02,.8056E-02,.1125E-01,.1366E-01,.1691E-01,.2780E-01,.6362E-01,.3596E-02,& - .1040E-02,.2283E-02,.4674E-02,.8124E-02,.1135E-01,.1380E-01,.1708E-01,.2808E-01,.6424E-01,.3628E-02,& - .1049E-02,.2303E-02,.4717E-02,.8195E-02,.1145E-01,.1393E-01,.1726E-01,.2836E-01,.6489E-01,.3661E-02,& - .1059E-02,.2324E-02,.4759E-02,.8266E-02,.1155E-01,.1407E-01,.1744E-01,.2864E-01,.6553E-01,.3695E-02,& - .1068E-02,.2344E-02,.4801E-02,.8337E-02,.1166E-01,.1421E-01,.1762E-01,.2892E-01,.6618E-01,.3728E-02,& - .1077E-02,.2365E-02,.4843E-02,.8407E-02,.1176E-01,.1434E-01,.1780E-01,.2920E-01,.6682E-01,.3761E-02,& - .1087E-02,.2385E-02,.4885E-02,.8478E-02,.1186E-01,.1448E-01,.1798E-01,.2948E-01,.6746E-01,.3794E-02,& - .1096E-02,.2406E-02,.4928E-02,.8551E-02,.1197E-01,.1462E-01,.1816E-01,.2976E-01,.6813E-01,.3828E-02,& - .1106E-02,.2427E-02,.4972E-02,.8624E-02,.1207E-01,.1476E-01,.1835E-01,.3005E-01,.6879E-01,.3863E-02,& - .1116E-02,.2448E-02,.5016E-02,.8697E-02,.1218E-01,.1490E-01,.1853E-01,.3034E-01,.6946E-01,.3897E-02,& - .1126E-02,.2470E-02,.5060E-02,.8772E-02,.1229E-01,.1505E-01,.1873E-01,.3065E-01,.7017E-01,.3932E-02,& - .1136E-02,.2492E-02,.5105E-02,.8847E-02,.1240E-01,.1520E-01,.1893E-01,.3096E-01,.7088E-01,.3968E-02,& - .1146E-02,.2513E-02,.5151E-02,.8923E-02,.1251E-01,.1535E-01,.1913E-01,.3127E-01,.7160E-01,.4004E-02,& - .1156E-02,.2536E-02,.5198E-02,.9001E-02,.1263E-01,.1551E-01,.1934E-01,.3160E-01,.7236E-01,.4041E-02,& - .1167E-02,.2559E-02,.5245E-02,.9079E-02,.1274E-01,.1567E-01,.1956E-01,.3193E-01,.7312E-01,.4078E-02,& - .1178E-02,.2582E-02,.5294E-02,.9159E-02,.1286E-01,.1584E-01,.1978E-01,.3227E-01,.7393E-01,.4118E-02,& - .1189E-02,.2607E-02,.5344E-02,.9242E-02,.1298E-01,.1601E-01,.2002E-01,.3264E-01,.7476E-01,.4158E-02,& - .1201E-02,.2631E-02,.5395E-02,.9327E-02,.1311E-01,.1619E-01,.2026E-01,.3300E-01,.7560E-01,.4198E-02,& - .1212E-02,.2657E-02,.5449E-02,.9415E-02,.1324E-01,.1637E-01,.2052E-01,.3339E-01,.7651E-01,.4241E-02,& - .1225E-02,.2683E-02,.5504E-02,.9507E-02,.1337E-01,.1656E-01,.2078E-01,.3379E-01,.7742E-01,.4285E-02,& - .1237E-02,.2711E-02,.5563E-02,.9602E-02,.1351E-01,.1676E-01,.2105E-01,.3421E-01,.7840E-01,.4331E-02,& - .1252E-02,.2742E-02,.5627E-02,.9706E-02,.1367E-01,.1699E-01,.2136E-01,.3468E-01,.7950E-01,.4383E-02,& - .1267E-02,.2775E-02,.5695E-02,.9819E-02,.1383E-01,.1722E-01,.2169E-01,.3517E-01,.8063E-01,.4437E-02,& - .1284E-02,.2811E-02,.5771E-02,.9945E-02,.1402E-01,.1748E-01,.2205E-01,.3573E-01,.8192E-01,.4498E-02,& - .1305E-02,.2856E-02,.5866E-02,.1010E-01,.1425E-01,.1780E-01,.2250E-01,.3641E-01,.8352E-01,.4573E-02,& - .1335E-02,.2921E-02,.6002E-02,.1033E-01,.1458E-01,.1826E-01,.2312E-01,.3738E-01,.8575E-01,.4680E-02/ - data (((g_lw(ai,k,nh),ai= 2, 2),k=1,nwl_lw),nh=0,99)/ & - .3489E-03,.7384E-03,.1593E-02,.2679E-02,.3583E-02,.4361E-02,.5349E-02,.8297E-02,.1781E-01,.1209E-02,& - .3523E-03,.7457E-03,.1609E-02,.2705E-02,.3619E-02,.4404E-02,.5402E-02,.8380E-02,.1799E-01,.1221E-02,& - .3558E-03,.7529E-03,.1625E-02,.2732E-02,.3654E-02,.4447E-02,.5455E-02,.8462E-02,.1817E-01,.1233E-02,& - .3592E-03,.7602E-03,.1640E-02,.2758E-02,.3690E-02,.4490E-02,.5508E-02,.8544E-02,.1835E-01,.1245E-02,& - .3627E-03,.7675E-03,.1656E-02,.2785E-02,.3725E-02,.4533E-02,.5561E-02,.8627E-02,.1852E-01,.1257E-02,& - .3661E-03,.7747E-03,.1672E-02,.2811E-02,.3761E-02,.4576E-02,.5614E-02,.8709E-02,.1870E-01,.1269E-02,& - .3695E-03,.7820E-03,.1687E-02,.2837E-02,.3796E-02,.4619E-02,.5666E-02,.8791E-02,.1888E-01,.1281E-02,& - .3730E-03,.7892E-03,.1703E-02,.2864E-02,.3831E-02,.4662E-02,.5719E-02,.8873E-02,.1906E-01,.1293E-02,& - .3764E-03,.7965E-03,.1719E-02,.2890E-02,.3866E-02,.4705E-02,.5772E-02,.8954E-02,.1923E-01,.1305E-02,& - .3798E-03,.8037E-03,.1734E-02,.2916E-02,.3901E-02,.4748E-02,.5824E-02,.9036E-02,.1941E-01,.1317E-02,& - .3832E-03,.8110E-03,.1750E-02,.2943E-02,.3937E-02,.4791E-02,.5877E-02,.9118E-02,.1959E-01,.1328E-02,& - .3866E-03,.8182E-03,.1766E-02,.2969E-02,.3972E-02,.4834E-02,.5930E-02,.9199E-02,.1976E-01,.1340E-02,& - .3900E-03,.8254E-03,.1781E-02,.2995E-02,.4007E-02,.4876E-02,.5982E-02,.9281E-02,.1994E-01,.1352E-02,& - .3934E-03,.8326E-03,.1797E-02,.3021E-02,.4042E-02,.4919E-02,.6034E-02,.9362E-02,.2011E-01,.1364E-02,& - .3968E-03,.8398E-03,.1812E-02,.3048E-02,.4077E-02,.4962E-02,.6087E-02,.9444E-02,.2029E-01,.1376E-02,& - .4002E-03,.8469E-03,.1828E-02,.3074E-02,.4112E-02,.5004E-02,.6139E-02,.9526E-02,.2047E-01,.1387E-02,& - .4036E-03,.8541E-03,.1843E-02,.3100E-02,.4147E-02,.5047E-02,.6191E-02,.9607E-02,.2064E-01,.1399E-02,& - .4070E-03,.8613E-03,.1859E-02,.3126E-02,.4182E-02,.5090E-02,.6243E-02,.9688E-02,.2082E-01,.1411E-02,& - .4103E-03,.8684E-03,.1874E-02,.3152E-02,.4216E-02,.5132E-02,.6296E-02,.9769E-02,.2099E-01,.1423E-02,& - .4137E-03,.8756E-03,.1890E-02,.3177E-02,.4251E-02,.5175E-02,.6348E-02,.9851E-02,.2117E-01,.1434E-02,& - .4171E-03,.8828E-03,.1905E-02,.3203E-02,.4286E-02,.5217E-02,.6400E-02,.9932E-02,.2134E-01,.1446E-02,& - .4205E-03,.8898E-03,.1920E-02,.3229E-02,.4321E-02,.5259E-02,.6452E-02,.1001E-01,.2152E-01,.1458E-02,& - .4238E-03,.8969E-03,.1936E-02,.3255E-02,.4355E-02,.5301E-02,.6503E-02,.1009E-01,.2169E-01,.1469E-02,& - .4271E-03,.9039E-03,.1951E-02,.3281E-02,.4390E-02,.5343E-02,.6555E-02,.1017E-01,.2187E-01,.1481E-02,& - .4305E-03,.9110E-03,.1966E-02,.3307E-02,.4424E-02,.5385E-02,.6607E-02,.1025E-01,.2204E-01,.1492E-02,& - .4338E-03,.9181E-03,.1981E-02,.3333E-02,.4459E-02,.5427E-02,.6658E-02,.1034E-01,.2221E-01,.1504E-02,& - .4372E-03,.9251E-03,.1997E-02,.3358E-02,.4493E-02,.5469E-02,.6710E-02,.1042E-01,.2239E-01,.1516E-02,& - .4405E-03,.9321E-03,.2012E-02,.3384E-02,.4527E-02,.5511E-02,.6761E-02,.1050E-01,.2256E-01,.1527E-02,& - .4438E-03,.9391E-03,.2027E-02,.3409E-02,.4562E-02,.5553E-02,.6812E-02,.1058E-01,.2273E-01,.1539E-02,& - .4471E-03,.9461E-03,.2042E-02,.3435E-02,.4596E-02,.5595E-02,.6864E-02,.1066E-01,.2290E-01,.1550E-02,& - .4504E-03,.9531E-03,.2057E-02,.3461E-02,.4630E-02,.5636E-02,.6915E-02,.1074E-01,.2308E-01,.1562E-02,& - .4537E-03,.9601E-03,.2072E-02,.3486E-02,.4664E-02,.5678E-02,.6966E-02,.1081E-01,.2325E-01,.1573E-02,& - .4570E-03,.9671E-03,.2087E-02,.3511E-02,.4698E-02,.5719E-02,.7017E-02,.1089E-01,.2342E-01,.1584E-02,& - .4603E-03,.9741E-03,.2103E-02,.3537E-02,.4732E-02,.5761E-02,.7067E-02,.1097E-01,.2359E-01,.1596E-02,& - .4636E-03,.9811E-03,.2118E-02,.3562E-02,.4766E-02,.5802E-02,.7118E-02,.1105E-01,.2376E-01,.1607E-02,& - .4669E-03,.9881E-03,.2133E-02,.3588E-02,.4800E-02,.5844E-02,.7169E-02,.1113E-01,.2393E-01,.1619E-02,& - .4701E-03,.9950E-03,.2148E-02,.3613E-02,.4834E-02,.5885E-02,.7220E-02,.1121E-01,.2410E-01,.1630E-02,& - .4734E-03,.1002E-02,.2162E-02,.3638E-02,.4867E-02,.5926E-02,.7270E-02,.1129E-01,.2427E-01,.1641E-02,& - .4766E-03,.1009E-02,.2177E-02,.3663E-02,.4901E-02,.5967E-02,.7320E-02,.1137E-01,.2444E-01,.1653E-02,& - .4799E-03,.1016E-02,.2192E-02,.3688E-02,.4935E-02,.6008E-02,.7371E-02,.1145E-01,.2461E-01,.1664E-02,& - .4831E-03,.1022E-02,.2207E-02,.3713E-02,.4968E-02,.6049E-02,.7421E-02,.1152E-01,.2478E-01,.1675E-02,& - .4863E-03,.1029E-02,.2222E-02,.3738E-02,.5002E-02,.6089E-02,.7471E-02,.1160E-01,.2495E-01,.1686E-02,& - .4896E-03,.1036E-02,.2237E-02,.3762E-02,.5035E-02,.6129E-02,.7521E-02,.1168E-01,.2512E-01,.1698E-02,& - .4928E-03,.1043E-02,.2251E-02,.3787E-02,.5068E-02,.6170E-02,.7570E-02,.1176E-01,.2528E-01,.1709E-02,& - .4960E-03,.1050E-02,.2266E-02,.3812E-02,.5101E-02,.6210E-02,.7620E-02,.1183E-01,.2545E-01,.1720E-02,& - .4992E-03,.1057E-02,.2281E-02,.3837E-02,.5134E-02,.6251E-02,.7670E-02,.1191E-01,.2562E-01,.1731E-02,& - .5023E-03,.1063E-02,.2295E-02,.3861E-02,.5167E-02,.6291E-02,.7719E-02,.1199E-01,.2578E-01,.1742E-02,& - .5055E-03,.1070E-02,.2310E-02,.3886E-02,.5200E-02,.6331E-02,.7769E-02,.1206E-01,.2595E-01,.1753E-02,& - .5087E-03,.1077E-02,.2324E-02,.3911E-02,.5233E-02,.6371E-02,.7818E-02,.1214E-01,.2611E-01,.1764E-02,& - .5119E-03,.1083E-02,.2339E-02,.3935E-02,.5266E-02,.6411E-02,.7867E-02,.1222E-01,.2628E-01,.1775E-02,& - .5151E-03,.1090E-02,.2353E-02,.3960E-02,.5299E-02,.6452E-02,.7916E-02,.1230E-01,.2645E-01,.1786E-02,& - .5182E-03,.1097E-02,.2368E-02,.3984E-02,.5331E-02,.6491E-02,.7965E-02,.1237E-01,.2661E-01,.1797E-02,& - .5213E-03,.1103E-02,.2382E-02,.4008E-02,.5364E-02,.6531E-02,.8014E-02,.1245E-01,.2677E-01,.1808E-02,& - .5244E-03,.1110E-02,.2396E-02,.4032E-02,.5396E-02,.6570E-02,.8062E-02,.1252E-01,.2694E-01,.1819E-02,& - .5276E-03,.1117E-02,.2411E-02,.4056E-02,.5429E-02,.6610E-02,.8111E-02,.1260E-01,.2710E-01,.1830E-02,& - .5307E-03,.1123E-02,.2425E-02,.4080E-02,.5461E-02,.6649E-02,.8160E-02,.1268E-01,.2726E-01,.1841E-02,& - .5334E-03,.1129E-02,.2437E-02,.4101E-02,.5491E-02,.6686E-02,.8207E-02,.1275E-01,.2744E-01,.1850E-02,& - .5360E-03,.1135E-02,.2448E-02,.4121E-02,.5520E-02,.6723E-02,.8254E-02,.1283E-01,.2761E-01,.1859E-02,& - .5387E-03,.1141E-02,.2460E-02,.4141E-02,.5549E-02,.6760E-02,.8301E-02,.1290E-01,.2778E-01,.1868E-02,& - .5413E-03,.1146E-02,.2471E-02,.4161E-02,.5578E-02,.6797E-02,.8348E-02,.1298E-01,.2796E-01,.1877E-02,& - .5440E-03,.1152E-02,.2483E-02,.4181E-02,.5608E-02,.6834E-02,.8395E-02,.1306E-01,.2813E-01,.1886E-02,& - .5470E-03,.1159E-02,.2497E-02,.4205E-02,.5639E-02,.6873E-02,.8443E-02,.1313E-01,.2829E-01,.1897E-02,& - .5501E-03,.1165E-02,.2511E-02,.4229E-02,.5671E-02,.6912E-02,.8491E-02,.1321E-01,.2845E-01,.1907E-02,& - .5531E-03,.1172E-02,.2525E-02,.4252E-02,.5703E-02,.6951E-02,.8538E-02,.1328E-01,.2861E-01,.1918E-02,& - .5562E-03,.1178E-02,.2539E-02,.4276E-02,.5735E-02,.6989E-02,.8586E-02,.1335E-01,.2877E-01,.1929E-02,& - .5592E-03,.1184E-02,.2553E-02,.4300E-02,.5766E-02,.7028E-02,.8634E-02,.1343E-01,.2893E-01,.1939E-02,& - .5612E-03,.1189E-02,.2560E-02,.4313E-02,.5791E-02,.7062E-02,.8681E-02,.1351E-01,.2914E-01,.1946E-02,& - .5631E-03,.1193E-02,.2567E-02,.4327E-02,.5816E-02,.7096E-02,.8727E-02,.1359E-01,.2934E-01,.1952E-02,& - .5650E-03,.1198E-02,.2574E-02,.4341E-02,.5841E-02,.7130E-02,.8774E-02,.1367E-01,.2954E-01,.1959E-02,& - .5669E-03,.1202E-02,.2581E-02,.4354E-02,.5865E-02,.7164E-02,.8821E-02,.1375E-01,.2975E-01,.1965E-02,& - .5689E-03,.1207E-02,.2588E-02,.4368E-02,.5890E-02,.7198E-02,.8867E-02,.1383E-01,.2995E-01,.1972E-02,& - .5700E-03,.1210E-02,.2590E-02,.4375E-02,.5913E-02,.7235E-02,.8923E-02,.1393E-01,.3025E-01,.1975E-02,& - .5712E-03,.1214E-02,.2591E-02,.4382E-02,.5936E-02,.7272E-02,.8980E-02,.1403E-01,.3054E-01,.1979E-02,& - .5724E-03,.1217E-02,.2593E-02,.4389E-02,.5960E-02,.7310E-02,.9036E-02,.1414E-01,.3084E-01,.1983E-02,& - .5736E-03,.1221E-02,.2595E-02,.4396E-02,.5983E-02,.7347E-02,.9092E-02,.1424E-01,.3113E-01,.1987E-02,& - .5748E-03,.1224E-02,.2597E-02,.4403E-02,.6006E-02,.7384E-02,.9149E-02,.1435E-01,.3143E-01,.1990E-02,& - .5772E-03,.1231E-02,.2605E-02,.4420E-02,.6042E-02,.7436E-02,.9224E-02,.1448E-01,.3179E-01,.1999E-02,& - .5796E-03,.1237E-02,.2613E-02,.4437E-02,.6078E-02,.7488E-02,.9300E-02,.1461E-01,.3215E-01,.2007E-02,& - .5821E-03,.1243E-02,.2621E-02,.4454E-02,.6113E-02,.7540E-02,.9375E-02,.1474E-01,.3251E-01,.2016E-02,& - .5845E-03,.1250E-02,.2629E-02,.4471E-02,.6149E-02,.7592E-02,.9451E-02,.1488E-01,.3287E-01,.2024E-02,& - .5869E-03,.1256E-02,.2637E-02,.4488E-02,.6185E-02,.7644E-02,.9526E-02,.1501E-01,.3322E-01,.2032E-02,& - .5903E-03,.1265E-02,.2649E-02,.4513E-02,.6234E-02,.7715E-02,.9626E-02,.1519E-01,.3370E-01,.2045E-02,& - .5940E-03,.1273E-02,.2664E-02,.4540E-02,.6281E-02,.7779E-02,.9715E-02,.1534E-01,.3409E-01,.2058E-02,& - .5983E-03,.1284E-02,.2681E-02,.4572E-02,.6337E-02,.7858E-02,.9824E-02,.1553E-01,.3458E-01,.2073E-02,& - .6025E-03,.1294E-02,.2698E-02,.4604E-02,.6389E-02,.7927E-02,.9917E-02,.1569E-01,.3498E-01,.2088E-02,& - .6074E-03,.1306E-02,.2719E-02,.4641E-02,.6452E-02,.8012E-02,.1003E-01,.1589E-01,.3548E-01,.2106E-02,& - .6128E-03,.1318E-02,.2741E-02,.4682E-02,.6518E-02,.8102E-02,.1016E-01,.1610E-01,.3599E-01,.2125E-02,& - .6176E-03,.1330E-02,.2762E-02,.4719E-02,.6576E-02,.8177E-02,.1026E-01,.1626E-01,.3641E-01,.2142E-02,& - .6235E-03,.1343E-02,.2787E-02,.4765E-02,.6646E-02,.8272E-02,.1038E-01,.1648E-01,.3693E-01,.2163E-02,& - .6287E-03,.1355E-02,.2810E-02,.4805E-02,.6707E-02,.8351E-02,.1049E-01,.1665E-01,.3735E-01,.2182E-02,& - .6351E-03,.1370E-02,.2838E-02,.4854E-02,.6782E-02,.8450E-02,.1062E-01,.1687E-01,.3789E-01,.2204E-02,& - .6417E-03,.1385E-02,.2866E-02,.4904E-02,.6860E-02,.8552E-02,.1075E-01,.1709E-01,.3843E-01,.2228E-02,& - .6484E-03,.1401E-02,.2896E-02,.4957E-02,.6939E-02,.8655E-02,.1089E-01,.1732E-01,.3898E-01,.2252E-02,& - .6555E-03,.1416E-02,.2928E-02,.5011E-02,.7021E-02,.8761E-02,.1103E-01,.1755E-01,.3954E-01,.2277E-02,& - .6639E-03,.1436E-02,.2965E-02,.5077E-02,.7119E-02,.8888E-02,.1120E-01,.1783E-01,.4020E-01,.2307E-02,& - .6725E-03,.1456E-02,.3004E-02,.5144E-02,.7219E-02,.9019E-02,.1137E-01,.1812E-01,.4088E-01,.2338E-02,& - .6828E-03,.1479E-02,.3049E-02,.5224E-02,.7337E-02,.9171E-02,.1157E-01,.1845E-01,.4168E-01,.2375E-02,& - .6960E-03,.1509E-02,.3108E-02,.5327E-02,.7489E-02,.9367E-02,.1183E-01,.1888E-01,.4270E-01,.2422E-02,& - .7109E-03,.1542E-02,.3176E-02,.5444E-02,.7660E-02,.9588E-02,.1212E-01,.1936E-01,.4383E-01,.2476E-02,& - .7427E-03,.1615E-02,.3320E-02,.5694E-02,.8024E-02,.1006E-01,.1272E-01,.2037E-01,.4624E-01,.2591E-02/ - data (((g_lw(ai,k,nh),ai= 3, 3),k=1,nwl_lw),nh=0,99)/ & - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02/ - data (((g_lw(ai,k,nh),ai= 4, 4),k=1,nwl_lw),nh=0,99)/ & - .4115E-03,.9877E-03,.1945E-02,.3501E-02,.5463E-02,.6679E-02,.5981E-02,.1042E-01,.2355E-01,.1645E-02,& - .4165E-03,.9984E-03,.1967E-02,.3538E-02,.5512E-02,.6739E-02,.6069E-02,.1056E-01,.2387E-01,.1662E-02,& - .4214E-03,.1009E-02,.1989E-02,.3574E-02,.5561E-02,.6799E-02,.6157E-02,.1070E-01,.2419E-01,.1679E-02,& - .4264E-03,.1020E-02,.2011E-02,.3611E-02,.5611E-02,.6859E-02,.6245E-02,.1085E-01,.2452E-01,.1696E-02,& - .4313E-03,.1030E-02,.2034E-02,.3648E-02,.5660E-02,.6920E-02,.6333E-02,.1099E-01,.2484E-01,.1713E-02,& - .4363E-03,.1041E-02,.2056E-02,.3684E-02,.5709E-02,.6980E-02,.6420E-02,.1113E-01,.2517E-01,.1730E-02,& - .4414E-03,.1052E-02,.2079E-02,.3722E-02,.5761E-02,.7043E-02,.6511E-02,.1128E-01,.2550E-01,.1747E-02,& - .4466E-03,.1063E-02,.2102E-02,.3760E-02,.5812E-02,.7106E-02,.6602E-02,.1142E-01,.2584E-01,.1765E-02,& - .4517E-03,.1074E-02,.2125E-02,.3798E-02,.5863E-02,.7169E-02,.6693E-02,.1157E-01,.2617E-01,.1783E-02,& - .4569E-03,.1085E-02,.2148E-02,.3836E-02,.5915E-02,.7232E-02,.6784E-02,.1172E-01,.2651E-01,.1800E-02,& - .4620E-03,.1096E-02,.2171E-02,.3874E-02,.5966E-02,.7295E-02,.6875E-02,.1186E-01,.2685E-01,.1818E-02,& - .4673E-03,.1107E-02,.2194E-02,.3914E-02,.6020E-02,.7361E-02,.6969E-02,.1201E-01,.2719E-01,.1836E-02,& - .4726E-03,.1119E-02,.2218E-02,.3953E-02,.6073E-02,.7427E-02,.7063E-02,.1216E-01,.2754E-01,.1854E-02,& - .4779E-03,.1130E-02,.2242E-02,.3992E-02,.6127E-02,.7493E-02,.7157E-02,.1232E-01,.2788E-01,.1872E-02,& - .4832E-03,.1142E-02,.2266E-02,.4032E-02,.6180E-02,.7558E-02,.7251E-02,.1247E-01,.2823E-01,.1890E-02,& - .4885E-03,.1153E-02,.2289E-02,.4071E-02,.6234E-02,.7624E-02,.7345E-02,.1262E-01,.2857E-01,.1909E-02,& - .4940E-03,.1165E-02,.2314E-02,.4112E-02,.6289E-02,.7693E-02,.7442E-02,.1277E-01,.2893E-01,.1927E-02,& - .4995E-03,.1177E-02,.2338E-02,.4153E-02,.6345E-02,.7762E-02,.7539E-02,.1293E-01,.2929E-01,.1946E-02,& - .5049E-03,.1188E-02,.2363E-02,.4194E-02,.6401E-02,.7830E-02,.7636E-02,.1309E-01,.2965E-01,.1965E-02,& - .5104E-03,.1200E-02,.2387E-02,.4235E-02,.6456E-02,.7899E-02,.7733E-02,.1324E-01,.3000E-01,.1984E-02,& - .5159E-03,.1212E-02,.2412E-02,.4275E-02,.6512E-02,.7968E-02,.7830E-02,.1340E-01,.3036E-01,.2002E-02,& - .5215E-03,.1224E-02,.2437E-02,.4318E-02,.6569E-02,.8039E-02,.7930E-02,.1356E-01,.3073E-01,.2022E-02,& - .5272E-03,.1236E-02,.2462E-02,.4360E-02,.6627E-02,.8110E-02,.8030E-02,.1372E-01,.3109E-01,.2041E-02,& - .5328E-03,.1248E-02,.2488E-02,.4402E-02,.6685E-02,.8182E-02,.8130E-02,.1388E-01,.3146E-01,.2060E-02,& - .5385E-03,.1261E-02,.2513E-02,.4444E-02,.6742E-02,.8253E-02,.8230E-02,.1404E-01,.3183E-01,.2080E-02,& - .5441E-03,.1273E-02,.2538E-02,.4486E-02,.6800E-02,.8324E-02,.8330E-02,.1420E-01,.3219E-01,.2099E-02,& - .5499E-03,.1285E-02,.2564E-02,.4530E-02,.6860E-02,.8399E-02,.8434E-02,.1437E-01,.3257E-01,.2119E-02,& - .5558E-03,.1298E-02,.2590E-02,.4574E-02,.6920E-02,.8473E-02,.8537E-02,.1453E-01,.3295E-01,.2139E-02,& - .5616E-03,.1310E-02,.2616E-02,.4617E-02,.6979E-02,.8547E-02,.8640E-02,.1470E-01,.3333E-01,.2159E-02,& - .5674E-03,.1323E-02,.2642E-02,.4661E-02,.7039E-02,.8622E-02,.8743E-02,.1486E-01,.3371E-01,.2179E-02,& - .5732E-03,.1335E-02,.2668E-02,.4704E-02,.7099E-02,.8696E-02,.8847E-02,.1503E-01,.3409E-01,.2199E-02,& - .5792E-03,.1348E-02,.2695E-02,.4749E-02,.7161E-02,.8772E-02,.8952E-02,.1520E-01,.3447E-01,.2219E-02,& - .5852E-03,.1361E-02,.2721E-02,.4794E-02,.7222E-02,.8849E-02,.9058E-02,.1537E-01,.3486E-01,.2240E-02,& - .5912E-03,.1374E-02,.2748E-02,.4839E-02,.7284E-02,.8925E-02,.9163E-02,.1554E-01,.3525E-01,.2261E-02,& - .5971E-03,.1387E-02,.2775E-02,.4884E-02,.7346E-02,.9001E-02,.9269E-02,.1570E-01,.3564E-01,.2281E-02,& - .6031E-03,.1400E-02,.2801E-02,.4929E-02,.7408E-02,.9078E-02,.9374E-02,.1587E-01,.3603E-01,.2302E-02,& - .6093E-03,.1413E-02,.2829E-02,.4975E-02,.7471E-02,.9158E-02,.9483E-02,.1605E-01,.3643E-01,.2323E-02,& - .6154E-03,.1427E-02,.2857E-02,.5022E-02,.7535E-02,.9237E-02,.9593E-02,.1622E-01,.3683E-01,.2344E-02,& - .6216E-03,.1440E-02,.2884E-02,.5068E-02,.7599E-02,.9317E-02,.9702E-02,.1640E-01,.3723E-01,.2365E-02,& - .6278E-03,.1453E-02,.2912E-02,.5114E-02,.7663E-02,.9397E-02,.9811E-02,.1658E-01,.3763E-01,.2387E-02,& - .6339E-03,.1467E-02,.2939E-02,.5161E-02,.7726E-02,.9477E-02,.9920E-02,.1675E-01,.3802E-01,.2408E-02,& - .6403E-03,.1480E-02,.2968E-02,.5209E-02,.7792E-02,.9559E-02,.1003E-01,.1693E-01,.3844E-01,.2430E-02,& - .6466E-03,.1494E-02,.2996E-02,.5256E-02,.7858E-02,.9641E-02,.1014E-01,.1711E-01,.3885E-01,.2451E-02,& - .6529E-03,.1507E-02,.3024E-02,.5304E-02,.7924E-02,.9723E-02,.1026E-01,.1729E-01,.3926E-01,.2473E-02,& - .6593E-03,.1521E-02,.3053E-02,.5352E-02,.7989E-02,.9805E-02,.1037E-01,.1747E-01,.3967E-01,.2495E-02,& - .6656E-03,.1535E-02,.3081E-02,.5400E-02,.8055E-02,.9887E-02,.1048E-01,.1765E-01,.4008E-01,.2517E-02,& - .6721E-03,.1549E-02,.3110E-02,.5449E-02,.8123E-02,.9971E-02,.1059E-01,.1783E-01,.4050E-01,.2539E-02,& - .6786E-03,.1563E-02,.3139E-02,.5498E-02,.8191E-02,.1006E-01,.1071E-01,.1802E-01,.4092E-01,.2562E-02,& - .6851E-03,.1577E-02,.3168E-02,.5547E-02,.8259E-02,.1014E-01,.1082E-01,.1820E-01,.4133E-01,.2584E-02,& - .6916E-03,.1591E-02,.3197E-02,.5596E-02,.8327E-02,.1023E-01,.1094E-01,.1838E-01,.4175E-01,.2607E-02,& - .6981E-03,.1605E-02,.3226E-02,.5645E-02,.8394E-02,.1031E-01,.1105E-01,.1857E-01,.4217E-01,.2629E-02,& - .7048E-03,.1619E-02,.3256E-02,.5695E-02,.8462E-02,.1040E-01,.1117E-01,.1876E-01,.4261E-01,.2652E-02,& - .7114E-03,.1634E-02,.3286E-02,.5744E-02,.8530E-02,.1048E-01,.1129E-01,.1895E-01,.4305E-01,.2674E-02,& - .7181E-03,.1648E-02,.3315E-02,.5794E-02,.8597E-02,.1056E-01,.1141E-01,.1914E-01,.4349E-01,.2697E-02,& - .7248E-03,.1662E-02,.3345E-02,.5844E-02,.8665E-02,.1065E-01,.1153E-01,.1933E-01,.4392E-01,.2719E-02,& - .7314E-03,.1676E-02,.3374E-02,.5894E-02,.8732E-02,.1073E-01,.1165E-01,.1952E-01,.4436E-01,.2742E-02,& - .7383E-03,.1691E-02,.3405E-02,.5945E-02,.8803E-02,.1082E-01,.1178E-01,.1972E-01,.4481E-01,.2765E-02,& - .7452E-03,.1706E-02,.3435E-02,.5996E-02,.8873E-02,.1091E-01,.1190E-01,.1991E-01,.4526E-01,.2789E-02,& - .7520E-03,.1720E-02,.3466E-02,.6047E-02,.8944E-02,.1100E-01,.1202E-01,.2011E-01,.4571E-01,.2812E-02,& - .7589E-03,.1735E-02,.3496E-02,.6099E-02,.9014E-02,.1109E-01,.1215E-01,.2031E-01,.4615E-01,.2835E-02,& - .7657E-03,.1750E-02,.3527E-02,.6150E-02,.9085E-02,.1117E-01,.1227E-01,.2050E-01,.4660E-01,.2858E-02,& - .7728E-03,.1765E-02,.3558E-02,.6203E-02,.9159E-02,.1127E-01,.1239E-01,.2070E-01,.4705E-01,.2883E-02,& - .7799E-03,.1780E-02,.3590E-02,.6257E-02,.9233E-02,.1136E-01,.1252E-01,.2090E-01,.4751E-01,.2907E-02,& - .7870E-03,.1795E-02,.3621E-02,.6310E-02,.9307E-02,.1145E-01,.1264E-01,.2110E-01,.4796E-01,.2931E-02,& - .7940E-03,.1810E-02,.3652E-02,.6364E-02,.9381E-02,.1155E-01,.1277E-01,.2129E-01,.4841E-01,.2956E-02,& - .8011E-03,.1825E-02,.3684E-02,.6417E-02,.9455E-02,.1164E-01,.1289E-01,.2149E-01,.4886E-01,.2980E-02,& - .8083E-03,.1841E-02,.3716E-02,.6471E-02,.9529E-02,.1173E-01,.1302E-01,.2170E-01,.4933E-01,.3005E-02,& - .8155E-03,.1857E-02,.3748E-02,.6526E-02,.9604E-02,.1183E-01,.1315E-01,.2190E-01,.4981E-01,.3029E-02,& - .8227E-03,.1872E-02,.3780E-02,.6580E-02,.9678E-02,.1192E-01,.1328E-01,.2211E-01,.5028E-01,.3054E-02,& - .8299E-03,.1888E-02,.3812E-02,.6634E-02,.9753E-02,.1202E-01,.1341E-01,.2232E-01,.5075E-01,.3078E-02,& - .8371E-03,.1903E-02,.3845E-02,.6688E-02,.9828E-02,.1211E-01,.1354E-01,.2252E-01,.5122E-01,.3103E-02,& - .8446E-03,.1919E-02,.3878E-02,.6744E-02,.9900E-02,.1220E-01,.1368E-01,.2274E-01,.5172E-01,.3128E-02,& - .8521E-03,.1935E-02,.3910E-02,.6799E-02,.9973E-02,.1229E-01,.1382E-01,.2296E-01,.5222E-01,.3152E-02,& - .8596E-03,.1950E-02,.3943E-02,.6854E-02,.1005E-01,.1239E-01,.1396E-01,.2318E-01,.5273E-01,.3177E-02,& - .8671E-03,.1966E-02,.3976E-02,.6909E-02,.1012E-01,.1248E-01,.1410E-01,.2340E-01,.5323E-01,.3202E-02,& - .8746E-03,.1982E-02,.4009E-02,.6964E-02,.1019E-01,.1257E-01,.1423E-01,.2362E-01,.5373E-01,.3226E-02,& - .8825E-03,.1998E-02,.4043E-02,.7021E-02,.1027E-01,.1267E-01,.1439E-01,.2385E-01,.5427E-01,.3251E-02,& - .8903E-03,.2014E-02,.4077E-02,.7077E-02,.1034E-01,.1277E-01,.1454E-01,.2408E-01,.5481E-01,.3277E-02,& - .8982E-03,.2030E-02,.4112E-02,.7134E-02,.1042E-01,.1286E-01,.1469E-01,.2432E-01,.5534E-01,.3302E-02,& - .9061E-03,.2046E-02,.4146E-02,.7191E-02,.1049E-01,.1296E-01,.1484E-01,.2455E-01,.5588E-01,.3327E-02,& - .9140E-03,.2063E-02,.4180E-02,.7248E-02,.1056E-01,.1305E-01,.1499E-01,.2479E-01,.5642E-01,.3352E-02,& - .9219E-03,.2079E-02,.4215E-02,.7306E-02,.1064E-01,.1315E-01,.1515E-01,.2503E-01,.5699E-01,.3378E-02,& - .9303E-03,.2096E-02,.4251E-02,.7365E-02,.1072E-01,.1325E-01,.1531E-01,.2528E-01,.5756E-01,.3404E-02,& - .9387E-03,.2113E-02,.4287E-02,.7425E-02,.1079E-01,.1335E-01,.1548E-01,.2553E-01,.5813E-01,.3430E-02,& - .9471E-03,.2130E-02,.4323E-02,.7485E-02,.1087E-01,.1345E-01,.1563E-01,.2578E-01,.5871E-01,.3457E-02,& - .9557E-03,.2147E-02,.4360E-02,.7546E-02,.1095E-01,.1355E-01,.1581E-01,.2604E-01,.5932E-01,.3484E-02,& - .9644E-03,.2165E-02,.4398E-02,.7609E-02,.1103E-01,.1366E-01,.1599E-01,.2631E-01,.5994E-01,.3511E-02,& - .9735E-03,.2183E-02,.4437E-02,.7673E-02,.1111E-01,.1376E-01,.1618E-01,.2659E-01,.6060E-01,.3538E-02,& - .9828E-03,.2201E-02,.4477E-02,.7738E-02,.1119E-01,.1387E-01,.1636E-01,.2688E-01,.6126E-01,.3567E-02,& - .9926E-03,.2220E-02,.4518E-02,.7805E-02,.1127E-01,.1398E-01,.1656E-01,.2718E-01,.6196E-01,.3595E-02,& - .1002E-02,.2240E-02,.4559E-02,.7874E-02,.1136E-01,.1409E-01,.1676E-01,.2749E-01,.6266E-01,.3625E-02,& - .1013E-02,.2260E-02,.4603E-02,.7945E-02,.1145E-01,.1421E-01,.1697E-01,.2780E-01,.6340E-01,.3655E-02,& - .1023E-02,.2280E-02,.4647E-02,.8019E-02,.1154E-01,.1434E-01,.1719E-01,.2814E-01,.6417E-01,.3687E-02,& - .1035E-02,.2303E-02,.4696E-02,.8099E-02,.1164E-01,.1447E-01,.1744E-01,.2850E-01,.6502E-01,.3721E-02,& - .1047E-02,.2326E-02,.4746E-02,.8182E-02,.1173E-01,.1461E-01,.1769E-01,.2887E-01,.6589E-01,.3756E-02,& - .1060E-02,.2352E-02,.4802E-02,.8275E-02,.1185E-01,.1476E-01,.1797E-01,.2930E-01,.6689E-01,.3794E-02,& - .1075E-02,.2380E-02,.4865E-02,.8379E-02,.1198E-01,.1494E-01,.1829E-01,.2978E-01,.6800E-01,.3838E-02,& - .1091E-02,.2412E-02,.4933E-02,.8492E-02,.1212E-01,.1513E-01,.1863E-01,.3028E-01,.6919E-01,.3886E-02,& - .1112E-02,.2452E-02,.5021E-02,.8639E-02,.1230E-01,.1538E-01,.1907E-01,.3094E-01,.7072E-01,.3947E-02,& - .1139E-02,.2506E-02,.5137E-02,.8835E-02,.1255E-01,.1572E-01,.1963E-01,.3179E-01,.7270E-01,.4030E-02/ - data (((g_lw(ai,k,nh),ai= 5, 5),k=1,nwl_lw),nh=0,99)/ & - .1481E+00,.2519E+00,.3517E+00,.4244E+00,.4530E+00,.4774E+00,.5189E+00,.5612E+00,.6172E+00,.3172E+00,& - .1497E+00,.2526E+00,.3520E+00,.4269E+00,.4564E+00,.4808E+00,.5221E+00,.5645E+00,.6203E+00,.3173E+00,& - .1513E+00,.2533E+00,.3523E+00,.4293E+00,.4598E+00,.4842E+00,.5252E+00,.5678E+00,.6234E+00,.3175E+00,& - .1529E+00,.2541E+00,.3526E+00,.4317E+00,.4632E+00,.4877E+00,.5283E+00,.5711E+00,.6265E+00,.3176E+00,& - .1545E+00,.2548E+00,.3529E+00,.4342E+00,.4666E+00,.4911E+00,.5315E+00,.5744E+00,.6296E+00,.3177E+00,& - .1561E+00,.2556E+00,.3532E+00,.4366E+00,.4700E+00,.4946E+00,.5346E+00,.5777E+00,.6326E+00,.3178E+00,& - .1577E+00,.2565E+00,.3537E+00,.4389E+00,.4732E+00,.4978E+00,.5375E+00,.5807E+00,.6354E+00,.3182E+00,& - .1593E+00,.2574E+00,.3542E+00,.4412E+00,.4763E+00,.5010E+00,.5404E+00,.5836E+00,.6381E+00,.3186E+00,& - .1609E+00,.2583E+00,.3547E+00,.4435E+00,.4795E+00,.5042E+00,.5433E+00,.5866E+00,.6408E+00,.3190E+00,& - .1625E+00,.2593E+00,.3552E+00,.4458E+00,.4827E+00,.5074E+00,.5462E+00,.5895E+00,.6436E+00,.3194E+00,& - .1641E+00,.2602E+00,.3557E+00,.4481E+00,.4859E+00,.5106E+00,.5491E+00,.5925E+00,.6463E+00,.3198E+00,& - .1657E+00,.2613E+00,.3564E+00,.4503E+00,.4889E+00,.5136E+00,.5519E+00,.5952E+00,.6487E+00,.3205E+00,& - .1673E+00,.2623E+00,.3572E+00,.4525E+00,.4919E+00,.5166E+00,.5546E+00,.5979E+00,.6512E+00,.3211E+00,& - .1689E+00,.2634E+00,.3579E+00,.4547E+00,.4949E+00,.5197E+00,.5574E+00,.6006E+00,.6536E+00,.3218E+00,& - .1705E+00,.2645E+00,.3586E+00,.4570E+00,.4979E+00,.5227E+00,.5601E+00,.6033E+00,.6560E+00,.3225E+00,& - .1721E+00,.2656E+00,.3594E+00,.4592E+00,.5010E+00,.5257E+00,.5628E+00,.6060E+00,.6585E+00,.3231E+00,& - .1737E+00,.2667E+00,.3603E+00,.4613E+00,.5038E+00,.5285E+00,.5654E+00,.6085E+00,.6606E+00,.3240E+00,& - .1752E+00,.2679E+00,.3613E+00,.4635E+00,.5066E+00,.5314E+00,.5679E+00,.6109E+00,.6628E+00,.3248E+00,& - .1768E+00,.2690E+00,.3622E+00,.4657E+00,.5095E+00,.5342E+00,.5705E+00,.6134E+00,.6649E+00,.3256E+00,& - .1784E+00,.2702E+00,.3631E+00,.4678E+00,.5123E+00,.5370E+00,.5730E+00,.6159E+00,.6670E+00,.3265E+00,& - .1800E+00,.2714E+00,.3641E+00,.4700E+00,.5151E+00,.5398E+00,.5756E+00,.6184E+00,.6692E+00,.3273E+00,& - .1815E+00,.2726E+00,.3652E+00,.4722E+00,.5178E+00,.5425E+00,.5780E+00,.6207E+00,.6712E+00,.3283E+00,& - .1831E+00,.2739E+00,.3662E+00,.4743E+00,.5205E+00,.5452E+00,.5804E+00,.6230E+00,.6731E+00,.3293E+00,& - .1846E+00,.2751E+00,.3673E+00,.4764E+00,.5232E+00,.5479E+00,.5828E+00,.6253E+00,.6751E+00,.3303E+00,& - .1862E+00,.2763E+00,.3684E+00,.4786E+00,.5259E+00,.5506E+00,.5853E+00,.6276E+00,.6770E+00,.3313E+00,& - .1877E+00,.2776E+00,.3695E+00,.4807E+00,.5286E+00,.5533E+00,.5877E+00,.6299E+00,.6790E+00,.3323E+00,& - .1893E+00,.2789E+00,.3707E+00,.4828E+00,.5312E+00,.5558E+00,.5899E+00,.6320E+00,.6807E+00,.3334E+00,& - .1908E+00,.2801E+00,.3719E+00,.4849E+00,.5338E+00,.5583E+00,.5922E+00,.6341E+00,.6825E+00,.3345E+00,& - .1923E+00,.2814E+00,.3731E+00,.4870E+00,.5363E+00,.5608E+00,.5944E+00,.6362E+00,.6842E+00,.3356E+00,& - .1939E+00,.2827E+00,.3743E+00,.4891E+00,.5389E+00,.5633E+00,.5967E+00,.6383E+00,.6860E+00,.3367E+00,& - .1954E+00,.2840E+00,.3755E+00,.4912E+00,.5414E+00,.5659E+00,.5990E+00,.6405E+00,.6877E+00,.3378E+00,& - .1969E+00,.2853E+00,.3767E+00,.4933E+00,.5439E+00,.5682E+00,.6011E+00,.6425E+00,.6893E+00,.3389E+00,& - .1984E+00,.2866E+00,.3780E+00,.4953E+00,.5463E+00,.5706E+00,.6032E+00,.6445E+00,.6909E+00,.3401E+00,& - .1999E+00,.2879E+00,.3793E+00,.4974E+00,.5487E+00,.5730E+00,.6054E+00,.6464E+00,.6925E+00,.3413E+00,& - .2014E+00,.2892E+00,.3806E+00,.4995E+00,.5512E+00,.5754E+00,.6075E+00,.6484E+00,.6941E+00,.3425E+00,& - .2029E+00,.2905E+00,.3819E+00,.5015E+00,.5536E+00,.5778E+00,.6096E+00,.6504E+00,.6957E+00,.3436E+00,& - .2044E+00,.2918E+00,.3832E+00,.5035E+00,.5559E+00,.5800E+00,.6116E+00,.6523E+00,.6971E+00,.3449E+00,& - .2058E+00,.2931E+00,.3845E+00,.5055E+00,.5582E+00,.5823E+00,.6136E+00,.6541E+00,.6986E+00,.3461E+00,& - .2073E+00,.2945E+00,.3858E+00,.5075E+00,.5605E+00,.5845E+00,.6156E+00,.6559E+00,.7000E+00,.3473E+00,& - .2088E+00,.2958E+00,.3871E+00,.5095E+00,.5628E+00,.5868E+00,.6176E+00,.6578E+00,.7014E+00,.3485E+00,& - .2103E+00,.2971E+00,.3884E+00,.5115E+00,.5652E+00,.5890E+00,.6196E+00,.6596E+00,.7028E+00,.3497E+00,& - .2117E+00,.2984E+00,.3898E+00,.5135E+00,.5674E+00,.5912E+00,.6215E+00,.6614E+00,.7042E+00,.3510E+00,& - .2132E+00,.2998E+00,.3912E+00,.5155E+00,.5696E+00,.5933E+00,.6234E+00,.6631E+00,.7055E+00,.3523E+00,& - .2146E+00,.3011E+00,.3925E+00,.5174E+00,.5718E+00,.5954E+00,.6253E+00,.6648E+00,.7069E+00,.3535E+00,& - .2161E+00,.3024E+00,.3939E+00,.5194E+00,.5740E+00,.5976E+00,.6272E+00,.6666E+00,.7082E+00,.3548E+00,& - .2175E+00,.3038E+00,.3953E+00,.5214E+00,.5763E+00,.5997E+00,.6291E+00,.6683E+00,.7095E+00,.3561E+00,& - .2189E+00,.3051E+00,.3967E+00,.5233E+00,.5783E+00,.6017E+00,.6309E+00,.6699E+00,.7107E+00,.3573E+00,& - .2204E+00,.3064E+00,.3980E+00,.5252E+00,.5804E+00,.6038E+00,.6327E+00,.6715E+00,.7119E+00,.3586E+00,& - .2218E+00,.3077E+00,.3994E+00,.5271E+00,.5825E+00,.6058E+00,.6345E+00,.6731E+00,.7131E+00,.3599E+00,& - .2232E+00,.3091E+00,.4008E+00,.5290E+00,.5846E+00,.6078E+00,.6363E+00,.6748E+00,.7143E+00,.3612E+00,& - .2246E+00,.3104E+00,.4022E+00,.5310E+00,.5867E+00,.6098E+00,.6381E+00,.6764E+00,.7155E+00,.3624E+00,& - .2257E+00,.3115E+00,.4033E+00,.5325E+00,.5884E+00,.6114E+00,.6395E+00,.6776E+00,.7164E+00,.3635E+00,& - .2269E+00,.3126E+00,.4045E+00,.5341E+00,.5900E+00,.6130E+00,.6409E+00,.6789E+00,.7173E+00,.3646E+00,& - .2281E+00,.3137E+00,.4056E+00,.5356E+00,.5917E+00,.6146E+00,.6423E+00,.6802E+00,.7182E+00,.3656E+00,& - .2292E+00,.3148E+00,.4068E+00,.5372E+00,.5934E+00,.6162E+00,.6437E+00,.6815E+00,.7191E+00,.3667E+00,& - .2304E+00,.3159E+00,.4079E+00,.5387E+00,.5951E+00,.6178E+00,.6451E+00,.6827E+00,.7201E+00,.3678E+00,& - .2315E+00,.3169E+00,.4091E+00,.5403E+00,.5967E+00,.6193E+00,.6464E+00,.6839E+00,.7210E+00,.3689E+00,& - .2327E+00,.3180E+00,.4102E+00,.5418E+00,.5983E+00,.6208E+00,.6478E+00,.6851E+00,.7219E+00,.3699E+00,& - .2338E+00,.3191E+00,.4114E+00,.5433E+00,.5999E+00,.6223E+00,.6491E+00,.6864E+00,.7228E+00,.3710E+00,& - .2349E+00,.3202E+00,.4126E+00,.5448E+00,.6015E+00,.6239E+00,.6505E+00,.6876E+00,.7237E+00,.3721E+00,& - .2361E+00,.3213E+00,.4137E+00,.5463E+00,.6031E+00,.6254E+00,.6518E+00,.6888E+00,.7246E+00,.3732E+00,& - .2372E+00,.3224E+00,.4149E+00,.5478E+00,.6046E+00,.6268E+00,.6531E+00,.6899E+00,.7253E+00,.3742E+00,& - .2383E+00,.3235E+00,.4160E+00,.5493E+00,.6062E+00,.6283E+00,.6544E+00,.6911E+00,.7261E+00,.3753E+00,& - .2394E+00,.3245E+00,.4172E+00,.5508E+00,.6077E+00,.6297E+00,.6557E+00,.6922E+00,.7269E+00,.3764E+00,& - .2405E+00,.3256E+00,.4183E+00,.5522E+00,.6092E+00,.6312E+00,.6569E+00,.6933E+00,.7277E+00,.3775E+00,& - .2416E+00,.3267E+00,.4195E+00,.5537E+00,.6108E+00,.6326E+00,.6582E+00,.6945E+00,.7284E+00,.3785E+00,& - .2427E+00,.3277E+00,.4206E+00,.5552E+00,.6123E+00,.6340E+00,.6594E+00,.6956E+00,.7292E+00,.3796E+00,& - .2438E+00,.3288E+00,.4217E+00,.5566E+00,.6137E+00,.6354E+00,.6607E+00,.6967E+00,.7299E+00,.3807E+00,& - .2449E+00,.3299E+00,.4229E+00,.5581E+00,.6152E+00,.6368E+00,.6619E+00,.6977E+00,.7307E+00,.3817E+00,& - .2460E+00,.3309E+00,.4240E+00,.5595E+00,.6167E+00,.6382E+00,.6631E+00,.6988E+00,.7314E+00,.3828E+00,& - .2471E+00,.3320E+00,.4252E+00,.5609E+00,.6182E+00,.6396E+00,.6643E+00,.6999E+00,.7322E+00,.3839E+00,& - .2488E+00,.3337E+00,.4270E+00,.5632E+00,.6205E+00,.6417E+00,.6662E+00,.7016E+00,.7333E+00,.3856E+00,& - .2506E+00,.3354E+00,.4289E+00,.5655E+00,.6228E+00,.6439E+00,.6681E+00,.7032E+00,.7345E+00,.3873E+00,& - .2523E+00,.3371E+00,.4307E+00,.5677E+00,.6250E+00,.6460E+00,.6700E+00,.7049E+00,.7356E+00,.3890E+00,& - .2540E+00,.3388E+00,.4325E+00,.5700E+00,.6273E+00,.6481E+00,.6718E+00,.7066E+00,.7368E+00,.3908E+00,& - .2558E+00,.3405E+00,.4343E+00,.5722E+00,.6296E+00,.6503E+00,.6737E+00,.7082E+00,.7379E+00,.3925E+00,& - .2578E+00,.3426E+00,.4366E+00,.5749E+00,.6322E+00,.6527E+00,.6759E+00,.7101E+00,.7392E+00,.3946E+00,& - .2599E+00,.3446E+00,.4388E+00,.5776E+00,.6349E+00,.6551E+00,.6780E+00,.7120E+00,.7404E+00,.3967E+00,& - .2620E+00,.3467E+00,.4411E+00,.5803E+00,.6375E+00,.6576E+00,.6801E+00,.7139E+00,.7416E+00,.3988E+00,& - .2640E+00,.3487E+00,.4433E+00,.5829E+00,.6401E+00,.6600E+00,.6823E+00,.7157E+00,.7429E+00,.4008E+00,& - .2661E+00,.3508E+00,.4455E+00,.5856E+00,.6428E+00,.6625E+00,.6844E+00,.7176E+00,.7441E+00,.4029E+00,& - .2686E+00,.3532E+00,.4482E+00,.5887E+00,.6458E+00,.6653E+00,.6869E+00,.7198E+00,.7456E+00,.4054E+00,& - .2719E+00,.3566E+00,.4518E+00,.5930E+00,.6499E+00,.6691E+00,.6902E+00,.7226E+00,.7474E+00,.4088E+00,& - .2748E+00,.3594E+00,.4549E+00,.5966E+00,.6534E+00,.6723E+00,.6930E+00,.7250E+00,.7488E+00,.4118E+00,& - .2776E+00,.3622E+00,.4580E+00,.6001E+00,.6568E+00,.6754E+00,.6956E+00,.7274E+00,.7502E+00,.4147E+00,& - .2817E+00,.3664E+00,.4626E+00,.6053E+00,.6617E+00,.6799E+00,.6996E+00,.7308E+00,.7524E+00,.4190E+00,& - .2850E+00,.3696E+00,.4661E+00,.6093E+00,.6655E+00,.6833E+00,.7026E+00,.7334E+00,.7542E+00,.4223E+00,& - .2890E+00,.3737E+00,.4706E+00,.6143E+00,.6702E+00,.6876E+00,.7063E+00,.7366E+00,.7562E+00,.4266E+00,& - .2930E+00,.3778E+00,.4750E+00,.6192E+00,.6748E+00,.6917E+00,.7099E+00,.7397E+00,.7578E+00,.4308E+00,& - .2974E+00,.3822E+00,.4798E+00,.6246E+00,.6797E+00,.6962E+00,.7137E+00,.7430E+00,.7597E+00,.4353E+00,& - .3030E+00,.3879E+00,.4860E+00,.6313E+00,.6858E+00,.7017E+00,.7185E+00,.7471E+00,.7624E+00,.4412E+00,& - .3085E+00,.3934E+00,.4921E+00,.6378E+00,.6918E+00,.7070E+00,.7231E+00,.7511E+00,.7647E+00,.4470E+00,& - .3159E+00,.4009E+00,.5003E+00,.6465E+00,.6995E+00,.7140E+00,.7291E+00,.7562E+00,.7673E+00,.4548E+00,& - .3235E+00,.4086E+00,.5088E+00,.6553E+00,.7073E+00,.7210E+00,.7351E+00,.7613E+00,.7706E+00,.4629E+00,& - .3332E+00,.4185E+00,.5195E+00,.6663E+00,.7169E+00,.7295E+00,.7424E+00,.7674E+00,.7734E+00,.4732E+00,& - .3455E+00,.4310E+00,.5330E+00,.6799E+00,.7286E+00,.7398E+00,.7513E+00,.7749E+00,.7778E+00,.4862E+00,& - .3593E+00,.4449E+00,.5481E+00,.6947E+00,.7410E+00,.7507E+00,.7606E+00,.7828E+00,.7820E+00,.5008E+00,& - .3811E+00,.4669E+00,.5716E+00,.7169E+00,.7593E+00,.7666E+00,.7742E+00,.7941E+00,.7874E+00,.5236E+00,& - .4082E+00,.4942E+00,.6004E+00,.7430E+00,.7800E+00,.7845E+00,.7893E+00,.8066E+00,.7923E+00,.5520E+00,& - .4573E+00,.5429E+00,.6504E+00,.7853E+00,.8124E+00,.8121E+00,.8126E+00,.8257E+00,.8006E+00,.6021E+00/ - data (((g_lw(ai,k,nh),ai= 6, 6),k=1,nwl_lw),nh=0,99)/ & - .4938E+00,.6006E+00,.7052E+00,.7149E+00,.6782E+00,.7073E+00,.7647E+00,.7410E+00,.7147E+00,.6475E+00,& - .4978E+00,.6046E+00,.7123E+00,.7238E+00,.6855E+00,.7127E+00,.7685E+00,.7465E+00,.7177E+00,.6538E+00,& - .5019E+00,.6086E+00,.7194E+00,.7328E+00,.6927E+00,.7182E+00,.7723E+00,.7519E+00,.7207E+00,.6601E+00,& - .5059E+00,.6127E+00,.7265E+00,.7418E+00,.7000E+00,.7236E+00,.7761E+00,.7573E+00,.7238E+00,.6664E+00,& - .5099E+00,.6167E+00,.7336E+00,.7507E+00,.7073E+00,.7290E+00,.7799E+00,.7627E+00,.7268E+00,.6728E+00,& - .5140E+00,.6207E+00,.7407E+00,.7597E+00,.7146E+00,.7344E+00,.7837E+00,.7681E+00,.7298E+00,.6791E+00,& - .5176E+00,.6239E+00,.7446E+00,.7658E+00,.7204E+00,.7389E+00,.7862E+00,.7717E+00,.7333E+00,.6832E+00,& - .5212E+00,.6271E+00,.7485E+00,.7720E+00,.7263E+00,.7433E+00,.7887E+00,.7752E+00,.7367E+00,.6874E+00,& - .5248E+00,.6303E+00,.7524E+00,.7782E+00,.7321E+00,.7477E+00,.7912E+00,.7788E+00,.7402E+00,.6916E+00,& - .5285E+00,.6336E+00,.7563E+00,.7843E+00,.7380E+00,.7522E+00,.7937E+00,.7824E+00,.7436E+00,.6957E+00,& - .5321E+00,.6368E+00,.7602E+00,.7905E+00,.7438E+00,.7566E+00,.7962E+00,.7859E+00,.7471E+00,.6999E+00,& - .5354E+00,.6395E+00,.7628E+00,.7950E+00,.7486E+00,.7602E+00,.7987E+00,.7890E+00,.7487E+00,.7030E+00,& - .5387E+00,.6422E+00,.7654E+00,.7995E+00,.7534E+00,.7638E+00,.8011E+00,.7921E+00,.7502E+00,.7061E+00,& - .5420E+00,.6450E+00,.7680E+00,.8040E+00,.7582E+00,.7674E+00,.8035E+00,.7952E+00,.7518E+00,.7092E+00,& - .5453E+00,.6477E+00,.7706E+00,.8085E+00,.7630E+00,.7710E+00,.8059E+00,.7982E+00,.7534E+00,.7123E+00,& - .5486E+00,.6504E+00,.7732E+00,.8131E+00,.7677E+00,.7747E+00,.8083E+00,.8013E+00,.7549E+00,.7154E+00,& - .5516E+00,.6528E+00,.7752E+00,.8165E+00,.7716E+00,.7778E+00,.8100E+00,.8035E+00,.7574E+00,.7178E+00,& - .5546E+00,.6552E+00,.7772E+00,.8199E+00,.7755E+00,.7810E+00,.8117E+00,.8057E+00,.7599E+00,.7203E+00,& - .5576E+00,.6576E+00,.7791E+00,.8233E+00,.7794E+00,.7842E+00,.8134E+00,.8078E+00,.7625E+00,.7228E+00,& - .5606E+00,.6600E+00,.7811E+00,.8267E+00,.7833E+00,.7874E+00,.8151E+00,.8100E+00,.7650E+00,.7252E+00,& - .5636E+00,.6624E+00,.7830E+00,.8301E+00,.7871E+00,.7906E+00,.8168E+00,.8122E+00,.7675E+00,.7277E+00,& - .5663E+00,.6645E+00,.7846E+00,.8328E+00,.7904E+00,.7931E+00,.8184E+00,.8142E+00,.7685E+00,.7298E+00,& - .5691E+00,.6667E+00,.7862E+00,.8355E+00,.7936E+00,.7955E+00,.8201E+00,.8162E+00,.7696E+00,.7319E+00,& - .5718E+00,.6688E+00,.7878E+00,.8383E+00,.7969E+00,.7980E+00,.8218E+00,.8182E+00,.7707E+00,.7339E+00,& - .5746E+00,.6709E+00,.7894E+00,.8410E+00,.8002E+00,.8004E+00,.8235E+00,.8202E+00,.7718E+00,.7360E+00,& - .5773E+00,.6731E+00,.7910E+00,.8437E+00,.8034E+00,.8029E+00,.8251E+00,.8222E+00,.7728E+00,.7381E+00,& - .5798E+00,.6750E+00,.7924E+00,.8459E+00,.8061E+00,.8052E+00,.8263E+00,.8237E+00,.7744E+00,.7399E+00,& - .5823E+00,.6770E+00,.7938E+00,.8481E+00,.8088E+00,.8074E+00,.8275E+00,.8251E+00,.7760E+00,.7417E+00,& - .5849E+00,.6789E+00,.7952E+00,.8503E+00,.8115E+00,.8097E+00,.8287E+00,.8266E+00,.7776E+00,.7435E+00,& - .5874E+00,.6809E+00,.7965E+00,.8525E+00,.8142E+00,.8120E+00,.8298E+00,.8280E+00,.7792E+00,.7453E+00,& - .5899E+00,.6828E+00,.7979E+00,.8547E+00,.8169E+00,.8142E+00,.8310E+00,.8295E+00,.7808E+00,.7471E+00,& - .5922E+00,.6846E+00,.7991E+00,.8565E+00,.8192E+00,.8161E+00,.8323E+00,.8309E+00,.7821E+00,.7487E+00,& - .5946E+00,.6864E+00,.8003E+00,.8583E+00,.8214E+00,.8179E+00,.8335E+00,.8323E+00,.7834E+00,.7503E+00,& - .5969E+00,.6882E+00,.8016E+00,.8601E+00,.8237E+00,.8197E+00,.8348E+00,.8337E+00,.7847E+00,.7519E+00,& - .5992E+00,.6900E+00,.8028E+00,.8619E+00,.8260E+00,.8216E+00,.8361E+00,.8351E+00,.7860E+00,.7535E+00,& - .6016E+00,.6917E+00,.8040E+00,.8638E+00,.8282E+00,.8234E+00,.8373E+00,.8365E+00,.7874E+00,.7551E+00,& - .6037E+00,.6934E+00,.8051E+00,.8653E+00,.8302E+00,.8250E+00,.8382E+00,.8376E+00,.7880E+00,.7566E+00,& - .6059E+00,.6951E+00,.8062E+00,.8668E+00,.8322E+00,.8266E+00,.8390E+00,.8386E+00,.7887E+00,.7580E+00,& - .6080E+00,.6967E+00,.8073E+00,.8684E+00,.8341E+00,.8282E+00,.8399E+00,.8397E+00,.7893E+00,.7595E+00,& - .6102E+00,.6984E+00,.8084E+00,.8699E+00,.8361E+00,.8298E+00,.8407E+00,.8407E+00,.7900E+00,.7609E+00,& - .6124E+00,.7001E+00,.8095E+00,.8714E+00,.8381E+00,.8314E+00,.8416E+00,.8418E+00,.7906E+00,.7624E+00,& - .6144E+00,.7016E+00,.8105E+00,.8728E+00,.8397E+00,.8328E+00,.8425E+00,.8428E+00,.7919E+00,.7637E+00,& - .6164E+00,.7031E+00,.8116E+00,.8741E+00,.8414E+00,.8342E+00,.8435E+00,.8438E+00,.7932E+00,.7651E+00,& - .6184E+00,.7047E+00,.8126E+00,.8754E+00,.8430E+00,.8357E+00,.8444E+00,.8448E+00,.7945E+00,.7664E+00,& - .6204E+00,.7062E+00,.8136E+00,.8767E+00,.8447E+00,.8371E+00,.8453E+00,.8458E+00,.7958E+00,.7677E+00,& - .6224E+00,.7078E+00,.8146E+00,.8780E+00,.8463E+00,.8385E+00,.8463E+00,.8468E+00,.7971E+00,.7691E+00,& - .6243E+00,.7092E+00,.8156E+00,.8792E+00,.8478E+00,.8397E+00,.8470E+00,.8477E+00,.7975E+00,.7703E+00,& - .6262E+00,.7107E+00,.8165E+00,.8803E+00,.8492E+00,.8409E+00,.8477E+00,.8486E+00,.7978E+00,.7715E+00,& - .6280E+00,.7121E+00,.8174E+00,.8815E+00,.8507E+00,.8421E+00,.8484E+00,.8495E+00,.7982E+00,.7727E+00,& - .6299E+00,.7136E+00,.8184E+00,.8826E+00,.8521E+00,.8433E+00,.8492E+00,.8504E+00,.7985E+00,.7740E+00,& - .6318E+00,.7150E+00,.8193E+00,.8838E+00,.8536E+00,.8444E+00,.8499E+00,.8513E+00,.7989E+00,.7752E+00,& - .6332E+00,.7161E+00,.8201E+00,.8846E+00,.8546E+00,.8453E+00,.8504E+00,.8519E+00,.7998E+00,.7761E+00,& - .6346E+00,.7172E+00,.8208E+00,.8854E+00,.8557E+00,.8462E+00,.8509E+00,.8524E+00,.8007E+00,.7771E+00,& - .6361E+00,.7184E+00,.8215E+00,.8863E+00,.8568E+00,.8471E+00,.8515E+00,.8530E+00,.8015E+00,.7780E+00,& - .6375E+00,.7195E+00,.8222E+00,.8871E+00,.8578E+00,.8480E+00,.8520E+00,.8535E+00,.8024E+00,.7790E+00,& - .6390E+00,.7206E+00,.8230E+00,.8879E+00,.8589E+00,.8489E+00,.8525E+00,.8540E+00,.8033E+00,.7799E+00,& - .6403E+00,.7217E+00,.8237E+00,.8887E+00,.8598E+00,.8497E+00,.8531E+00,.8546E+00,.8040E+00,.7808E+00,& - .6417E+00,.7227E+00,.8244E+00,.8894E+00,.8607E+00,.8505E+00,.8536E+00,.8552E+00,.8048E+00,.7817E+00,& - .6431E+00,.7238E+00,.8251E+00,.8902E+00,.8617E+00,.8513E+00,.8542E+00,.8558E+00,.8055E+00,.7826E+00,& - .6444E+00,.7248E+00,.8258E+00,.8910E+00,.8626E+00,.8521E+00,.8548E+00,.8564E+00,.8062E+00,.7835E+00,& - .6458E+00,.7259E+00,.8265E+00,.8917E+00,.8635E+00,.8529E+00,.8553E+00,.8570E+00,.8070E+00,.7844E+00,& - .6471E+00,.7269E+00,.8271E+00,.8924E+00,.8644E+00,.8536E+00,.8558E+00,.8576E+00,.8071E+00,.7853E+00,& - .6484E+00,.7279E+00,.8278E+00,.8931E+00,.8652E+00,.8544E+00,.8563E+00,.8582E+00,.8073E+00,.7861E+00,& - .6497E+00,.7289E+00,.8284E+00,.8938E+00,.8661E+00,.8551E+00,.8568E+00,.8587E+00,.8075E+00,.7870E+00,& - .6510E+00,.7299E+00,.8291E+00,.8945E+00,.8669E+00,.8558E+00,.8572E+00,.8593E+00,.8076E+00,.7878E+00,& - .6523E+00,.7310E+00,.8298E+00,.8951E+00,.8678E+00,.8565E+00,.8577E+00,.8599E+00,.8078E+00,.7887E+00,& - .6535E+00,.7319E+00,.8304E+00,.8958E+00,.8685E+00,.8571E+00,.8581E+00,.8603E+00,.8083E+00,.7895E+00,& - .6548E+00,.7329E+00,.8310E+00,.8964E+00,.8693E+00,.8578E+00,.8584E+00,.8607E+00,.8088E+00,.7903E+00,& - .6560E+00,.7338E+00,.8316E+00,.8970E+00,.8701E+00,.8585E+00,.8588E+00,.8611E+00,.8094E+00,.7911E+00,& - .6572E+00,.7348E+00,.8323E+00,.8977E+00,.8709E+00,.8591E+00,.8592E+00,.8615E+00,.8099E+00,.7919E+00,& - .6585E+00,.7358E+00,.8329E+00,.8983E+00,.8717E+00,.8598E+00,.8595E+00,.8619E+00,.8104E+00,.7927E+00,& - .6602E+00,.7371E+00,.8338E+00,.8992E+00,.8727E+00,.8607E+00,.8602E+00,.8626E+00,.8114E+00,.7938E+00,& - .6620E+00,.7385E+00,.8347E+00,.9000E+00,.8737E+00,.8616E+00,.8608E+00,.8633E+00,.8125E+00,.7949E+00,& - .6637E+00,.7399E+00,.8356E+00,.9008E+00,.8747E+00,.8625E+00,.8615E+00,.8639E+00,.8135E+00,.7961E+00,& - .6654E+00,.7412E+00,.8364E+00,.9017E+00,.8757E+00,.8633E+00,.8621E+00,.8646E+00,.8145E+00,.7972E+00,& - .6672E+00,.7426E+00,.8373E+00,.9025E+00,.8768E+00,.8642E+00,.8628E+00,.8653E+00,.8155E+00,.7983E+00,& - .6695E+00,.7444E+00,.8385E+00,.9036E+00,.8780E+00,.8653E+00,.8635E+00,.8661E+00,.8161E+00,.7998E+00,& - .6719E+00,.7463E+00,.8397E+00,.9047E+00,.8793E+00,.8664E+00,.8642E+00,.8669E+00,.8167E+00,.8014E+00,& - .6742E+00,.7481E+00,.8409E+00,.9058E+00,.8806E+00,.8675E+00,.8648E+00,.8677E+00,.8173E+00,.8029E+00,& - .6765E+00,.7500E+00,.8421E+00,.9068E+00,.8819E+00,.8686E+00,.8655E+00,.8685E+00,.8179E+00,.8044E+00,& - .6789E+00,.7518E+00,.8433E+00,.9079E+00,.8831E+00,.8697E+00,.8662E+00,.8693E+00,.8186E+00,.8059E+00,& - .6812E+00,.7537E+00,.8445E+00,.9090E+00,.8843E+00,.8708E+00,.8670E+00,.8701E+00,.8204E+00,.8075E+00,& - .6846E+00,.7563E+00,.8463E+00,.9104E+00,.8861E+00,.8723E+00,.8682E+00,.8715E+00,.8223E+00,.8096E+00,& - .6879E+00,.7590E+00,.8480E+00,.9119E+00,.8877E+00,.8738E+00,.8694E+00,.8725E+00,.8232E+00,.8118E+00,& - .6912E+00,.7615E+00,.8496E+00,.9132E+00,.8892E+00,.8750E+00,.8704E+00,.8738E+00,.8243E+00,.8139E+00,& - .6948E+00,.7644E+00,.8515E+00,.9147E+00,.8910E+00,.8765E+00,.8712E+00,.8751E+00,.8246E+00,.8162E+00,& - .6983E+00,.7672E+00,.8533E+00,.9162E+00,.8926E+00,.8780E+00,.8721E+00,.8759E+00,.8265E+00,.8185E+00,& - .7018E+00,.7700E+00,.8551E+00,.9176E+00,.8941E+00,.8794E+00,.8733E+00,.8771E+00,.8285E+00,.8207E+00,& - .7053E+00,.7728E+00,.8569E+00,.9189E+00,.8957E+00,.8808E+00,.8745E+00,.8783E+00,.8305E+00,.8230E+00,& - .7092E+00,.7759E+00,.8589E+00,.9205E+00,.8973E+00,.8822E+00,.8757E+00,.8797E+00,.8317E+00,.8255E+00,& - .7137E+00,.7794E+00,.8612E+00,.9222E+00,.8992E+00,.8839E+00,.8767E+00,.8812E+00,.8326E+00,.8283E+00,& - .7188E+00,.7835E+00,.8638E+00,.9241E+00,.9012E+00,.8857E+00,.8781E+00,.8827E+00,.8354E+00,.8316E+00,& - .7240E+00,.7877E+00,.8665E+00,.9260E+00,.9033E+00,.8876E+00,.8800E+00,.8843E+00,.8378E+00,.8349E+00,& - .7313E+00,.7934E+00,.8701E+00,.9286E+00,.9059E+00,.8900E+00,.8817E+00,.8867E+00,.8401E+00,.8394E+00,& - .7391E+00,.7997E+00,.8740E+00,.9313E+00,.9088E+00,.8927E+00,.8843E+00,.8893E+00,.8446E+00,.8443E+00,& - .7480E+00,.8067E+00,.8784E+00,.9342E+00,.9118E+00,.8955E+00,.8866E+00,.8921E+00,.8478E+00,.8498E+00,& - .7596E+00,.8157E+00,.8841E+00,.9379E+00,.9155E+00,.8992E+00,.8902E+00,.8964E+00,.8530E+00,.8568E+00,& - .7726E+00,.8259E+00,.8903E+00,.9418E+00,.9195E+00,.9032E+00,.8945E+00,.9009E+00,.8600E+00,.8645E+00,& - .7910E+00,.8400E+00,.8986E+00,.9471E+00,.9250E+00,.9091E+00,.9007E+00,.9076E+00,.8704E+00,.8749E+00,& - .8196E+00,.8613E+00,.9108E+00,.9546E+00,.9335E+00,.9192E+00,.9128E+00,.9197E+00,.8867E+00,.8901E+00/ - data (((g_lw(ai,k,nh),ai= 7, 7),k=1,nwl_lw),nh=0,99)/ & - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01,& - .1764E-01,.4051E-01,.4930E-01,.8817E-01,.1561E+00,.8955E-01,.1028E+00,.1524E+00,.2399E+00,.3638E-01/ - data (((g_lw(ai,k,nh),ai= 8, 8),k=1,nwl_lw),nh=0,99)/ & - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01,& - .4977E-01,.9713E-01,.1083E+00,.1703E+00,.2366E+00,.1724E+00,.1964E+00,.2661E+00,.3673E+00,.8486E-01/ - data (((g_lw(ai,k,nh),ai= 9, 9),k=1,nwl_lw),nh=0,99)/ & - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00,& - .1276E+00,.1922E+00,.2158E+00,.2880E+00,.3066E+00,.3104E+00,.3506E+00,.4227E+00,.5097E+00,.1828E+00/ - data (((g_lw(ai,k,nh),ai=10,10),k=1,nwl_lw),nh=0,99)/ & - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00,& - .2216E+00,.2753E+00,.3362E+00,.3917E+00,.3482E+00,.4622E+00,.5122E+00,.5561E+00,.6083E+00,.3031E+00/ - data (((g_lw(ai,k,nh),ai=11,11),k=1,nwl_lw),nh=0,99)/ & - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00,& - .3038E+00,.3371E+00,.4529E+00,.4747E+00,.3811E+00,.6079E+00,.6554E+00,.6541E+00,.6672E+00,.4285E+00/ - data (((g_lw(ai,k,nh),ai=12,12),k=1,nwl_lw),nh=0,99)/ & - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00,& - .3628E+00,.3826E+00,.5498E+00,.5366E+00,.4239E+00,.7224E+00,.7580E+00,.7138E+00,.6936E+00,.5385E+00/ - data (((g_lw(ai,k,nh),ai=13,13),k=1,nwl_lw),nh=0,99)/ & - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00,& - .4133E+00,.4348E+00,.6366E+00,.5964E+00,.5163E+00,.8142E+00,.8304E+00,.7488E+00,.7046E+00,.6401E+00/ - data (((g_lw(ai,k,nh),ai=14,14),k=1,nwl_lw),nh=0,99)/ & - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00,& - .4592E+00,.5048E+00,.6980E+00,.6575E+00,.6399E+00,.8711E+00,.8660E+00,.7663E+00,.7222E+00,.7096E+00/ - - contains - - - subroutine aero_opt(sw_or_lw,dz8w,chem & - ,alt,relhum,aod,tau,ssa,asy & - ,num_chem,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte ) - USE module_initial_chem_namelists - USE module_data_gocart_chem, only: oc_mfac,nh4_mfac - implicit none - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte,num_chem -! -! array that holds all advected chemical species -! - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & - INTENT(INOUT ) :: chem -! - REAL, DIMENSION( ims:ime, jms:jme ) :: aod - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & - INTENT(IN ) :: relhum,dz8w, alt - integer, dimension( its:ite, jts:jte ) :: iprt - - - -!------------------------------------------------------------------------ -! Subroutine aero_opt compute the optical properties from the model input. -! All the dimension here is model (WRF) dimension. Not GOCART dimension. -! Note that tgmx = 14 : aerosol type (see below), and aero must be in the following order. -! # -! 1 = SO4 ! sulfur and its precure -! 2 = BC1+BC2 ! black carbon (soot) -! 3 = OC1 ! non hygroscopic OC -! 4 = OC2 ! hygroscopic OC -! 5 = SS1 ! sea-salt accumulation mode -! 6 = SS2+SS3+SS4 !sea-salt coarse mode -! 7 = DU1 ! dust mode 1 -! 8 = DU1 ! dust mode 2 -! 9 = DU1 ! dust mode 3 -! 10 = DU1 ! dust mode 4 -! 11 = DU2 ! dust mode 5 -! 12 = DU3 ! dust mode 6 -! 13 = DU4 ! dust mode 7 -! 14 = DU5 ! dust mode 8 -! -!------------------------------------------------------------------------ - -!-----IO variables - character(len=2), intent(in) :: sw_or_lw ! character index that determines sw or lw radiation - integer, parameter :: nband = 11 !# of radiation bands - real :: aero(kts:kte,tgmx) !aerosol mass conc [g/m3] - real :: dz(kts:kte) !layer thickness [m] - real, intent(out) :: tau(its:ite, kts:kte,jts:jte,nband) !total aerosol optical depth - real, intent(out) :: ssa(its:ite, kts:kte,jts:jte,nband) !total aerosol single scattering albedo - real, intent(out) :: asy(its:ite, kts:kte,jts:jte,nband) !total aerosol asymetry factor - -!-----Local variables - integer :: rhi !RH index - real :: rh(kts:kte) !relative humidity [-] - real :: ext !mass extinction coef [m2/g] - real :: tau_typ(tgmx) !optical depth for each aerosol type [-] - real :: ssa_typ(tgmx) !single scattering albedo for each aerosol type [-] - real :: asy_typ(tgmx) !asymetery factor for each aerosol type [-] - real :: w1, w2 !weight for pressure interpolation - real :: conv1a - - do i = its,ite - do j = jts,jte - iprt(i,j)=0 -! if(j.eq.18072)iprt(i,j)=1 - aero=0. -! -! compute relative humidity -! - do k = kts,kte - rh(k) = relhum(i,k,j) - dz(k) = dz8w(i,k,j) - enddo - do k = kts,kte - conv1a=(1./alt(i,k,j))*1.e-6 - aero(k,1)=chem(i,k,j,p_sulf)*conv1a*1.e3*nh4_mfac - aero(k,2)=(chem(i,k,j,p_bc1)+chem(i,k,j,p_bc2))*conv1a - aero(k,3)=(chem(i,k,j,p_oc1))*conv1a*oc_mfac - aero(k,4)=(chem(i,k,j,p_oc2))*conv1a*oc_mfac - aero(k,5)=(chem(i,k,j,p_seas_1))*conv1a - aero(k,6)=(chem(i,k,j,p_seas_2))*conv1a - aero(k,7)=(chem(i,k,j,p_dust_1))*conv1a*frac(1) - aero(k,8)=(chem(i,k,j,p_dust_1))*conv1a*frac(2) - aero(k,9)=(chem(i,k,j,p_dust_1))*conv1a*frac(3) - aero(k,10)=(chem(i,k,j,p_dust_1))*conv1a*frac(4) - aero(k,11)=(chem(i,k,j,p_dust_2))*conv1a - enddo - -! -! Compute total aerosol tau, ssa, & asy -! Algorithm: Total optical properties is computed as -! TAU = (tau1 + tau2 + tau3 +.... ) -! SSA = (tau1*w1 + tau2*w2 + tau3*w2 + .... ) / TAU -! ASY = (tau1*w1*g1 + tau2*w2*g1 + tau3*w2*g1 + .... ) / (TAU*SSA) -! - do k = kts,kte !vertical loop - - rhi = int(rh(k)*100.) !RH index - w2 = (rh(k) - real(rhi)/100.) / 0.01 !weight - w1 = max(min( 1.-w2,1. ),0.) !weight - - do n = 1,nband !wavelengh loop - - tau_typ = 0. ; ssa_typ = 0. ; asy_typ = 0. !initialization - - rad_select: select case(sw_or_lw) - case ('sw') !shortwave radiation - do t = 1,tgmx !aerosol type loop - if(rhi == 99) then - ext = Bex(t,n,rhi) - tau_typ(t) = ext * aero(k,t) * dz(k) - ssa_typ(t) = w0(t,n,rhi) - asy_typ(t) = g(t,n,rhi) - else - ext = w1*Bex(t,n,rhi) + w2*Bex(t,n,rhi+1) - tau_typ(t) = ext * aero(k,t) * dz(k) - ssa_typ(t) = w1*w0(t,n,rhi) + w2*w0(t,n,rhi+1) - asy_typ(t) = w1*g(t,n,rhi) + w2*g(t,n,rhi+1) - endif - - enddo !t - case ('lw') !longwave radiation - do t = 1,tgmx !aerosol type loop - if(rhi == 99) then - ext = Bex_lw(t,n,rhi) - tau_typ(t) = ext * aero(k,t) * dz(k) - ssa_typ(t) = w0_lw(t,n,rhi) - asy_typ(t) = g_lw(t,n,rhi) - else - ext = w1*Bex_lw(t,n,rhi) + w2*Bex_lw(t,n,rhi+1) - tau_typ(t) = ext * aero(k,t) * dz(k) - ssa_typ(t) = w1*w0_lw(t,n,rhi) + w2*w0_lw(t,n,rhi+1) - asy_typ(t) = w1*g_lw(t,n,rhi) + w2*g_lw(t,n,rhi+1) - endif - enddo !t - case default - stop 'MSG aero_opt: the option does not exist: sw_or_lw ' - end select rad_select - - !compute total optical depth single scatterling albedo, asymetry parameters - tau(i,k,j,n) = sum( tau_typ(1:tgmx) ) - ssa(i,k,j,n) = sum( tau_typ(1:tgmx)*ssa_typ(1:tgmx) ) / max(tau(i,k,j,n),1e-08) - asy(i,k,j,n) = sum( tau_typ(1:tgmx)*ssa_typ(1:tgmx)*asy_typ(1:tgmx) ) & - / max(tau(i,k,j,n)*ssa(i,k,j,n),1e-08) - - enddo !n - -! if(iprt(i,j).eq.1)then -! write(6,111)'8tau,ssa,asy=',k,tau(i,k,j,8),ssa(i,k,j,8),asy(i,k,j,8),chem(i,k,j,p_bc1),chem(i,k,j,p_oc1),chem(i,k,j,p_sulf),chem(i,k,j,p_dust_1) -!11 format(A,1x,i4,3(2x,f6.4),2x,4e12.3) -! endif - enddo ! vertical loop - aod(i,j)=sum(tau(i,kts:kte,j,8)) -! if(iprt(i,j).eq.1)write(6,*)'aod = ',aod(i,j) - enddo - enddo - - end subroutine aero_opt - end module module_gocart_opt diff --git a/src/fim/FIMsrc/fim/column_chem/module_gocart_seasalt.F90 b/src/fim/FIMsrc/fim/column_chem/module_gocart_seasalt.F90 deleted file mode 100644 index 16d5317..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_gocart_seasalt.F90 +++ /dev/null @@ -1,315 +0,0 @@ -MODULE MODULE_GOCART_SEASALT - -CONTAINS - subroutine gocart_seasalt_driver(ktau,dt,alt,t_phy,moist,u_phy, & - v_phy,chem,rho_phy,dz8w,u10,v10,p8w, & - xland,xlat,xlong,area,g,emis_seas, & - seashelp,num_emis_seas,num_moist,num_chem, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - USE module_initial_chem_namelists -! USE module_configure -! USE module_state_description -! USE module_model_constants, ONLY: mwdry -! IMPLICIT NONE -! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - - INTEGER, INTENT(IN ) :: ktau,num_emis_seas,num_moist,num_chem, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & - INTENT(IN ) :: moist - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & - INTENT(INOUT ) :: chem - REAL, DIMENSION( ims:ime, 1, jms:jme,num_emis_seas),OPTIONAL,& - INTENT(INOUT ) :: & - emis_seas - REAL, DIMENSION( ims:ime , jms:jme ) , & - INTENT(IN ) :: & - u10, & - v10, & - xland, & - xlat, & - xlong,area - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(OUT ) :: seashelp - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: & - alt, & - t_phy, & - dz8w,p8w, & - u_phy,v_phy,rho_phy - - REAL, INTENT(IN ) :: dt,g -! -! local variables -! - integer :: ipr,nmx,i,j,k,ndt,imx,jmx,lmx - integer,dimension (1,1) :: ilwi - real*8, DIMENSION (4) :: tc,bems - real*8, dimension (1,1) :: w10m,gwet,airden,airmas - real*8, dimension (1) :: dxy - real*8 conver,converi - conver=1.d-9 - converi=1.d9 -! -! number of dust bins -! - imx=1 - jmx=1 - lmx=1 - nmx=4 - k=kts -! p_seas_1=1 -! p_seas_2=2 -! p_seas_3=3 -! p_seas_4=4 -! write(6,*)'call seasalt' - if(chem_opt == 304 .or. chem_opt == 316 .or. chem_opt == 317) then - seashelp(:,:)=0. - do j=jts,jte - do i=its,ite -! -! donṫ do dust over water!!! -! - if(xland(i,j).lt.0.5)then - ilwi(1,1)=0 - tc(1)=chem(i,kts,j,p_seas_1)*conver - tc(2)=1.d-30 - tc(3)=chem(i,kts,j,p_seas_2)*conver - tc(4)=1.d-30 - w10m(1,1)=sqrt(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j)) - airmas(1,1)=-(p8w(i,kts+1,j)-p8w(i,kts,j))*area(i,j)/g -! -! we donṫ trust the u10,v10 values, is model layers are very thin near surface -! - if(dz8w(i,kts,j).lt.12.)w10m=sqrt(u_phy(i,kts,j)*u_phy(i,kts,j)+v_phy(i,kts,j)*v_phy(i,kts,j)) -! - dxy(1)=area(i,j) - ipr=0 - -! if(j.eq.2478)write(6,*)'call seasalt ',w10m(1,1),airmas(1,1),tc(1),tc(2) - call source_ss( imx,jmx,lmx,nmx, dt, tc,ilwi, dxy, w10m, airmas, bems,ipr) -! if(j.eq.2558)write(6,*)'call seasalt after',tc(1),tc(2),bems(1) -! write(6,*)'call seasalt after',tc(1),tc(2),bems(1) - chem(i,kts,j,p_seas_1)=(tc(1)+.75*tc(2))*converi - chem(i,kts,j,p_seas_2)=(tc(3)+.25*tc(2))*converi - seashelp(i,j)=tc(2)*converi -! for output diagnostics -! emis_seas(i,1,j,p_seas_1)=bems(1) -! emis_seas(i,1,j,p_seas_2)=bems(2) -! emis_seas(i,1,j,p_seas_3)=bems(3) - endif - enddo - enddo - else - do j=jts,jte - do i=its,ite -! -! donṫ do dust over water!!! -! - if(xland(i,j).lt.0.5)then - ilwi(1,1)=0 - tc(1)=chem(i,kts,j,p_seas_1)*conver - tc(2)=chem(i,kts,j,p_seas_2)*conver - tc(3)=chem(i,kts,j,p_seas_3)*conver - tc(4)=chem(i,kts,j,p_seas_4)*conver - w10m(1,1)=sqrt(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j)) - airmas(1,1)=-(p8w(i,kts+1,j)-p8w(i,kts,j))*area(i,j)/g -! -! we donṫ trust the u10,v10 values, is model layers are very thin near surface -! - if(dz8w(i,kts,j).lt.12.)w10m=sqrt(u_phy(i,kts,j)*u_phy(i,kts,j)+v_phy(i,kts,j)*v_phy(i,kts,j)) -! - dxy(1)=area(i,j) - ipr=0 - -! if(j.eq.2478)write(6,*)'call seasalt ',w10m(1,1),airmas(1,1),tc(1),tc(2) - call source_ss( imx,jmx,lmx,nmx, dt, tc,ilwi, dxy, w10m, airmas, bems,ipr) -! if(j.eq.2558)write(6,*)'call seasalt after',tc(1),tc(2),bems(1) -! write(6,*)'call seasalt after',tc(1),tc(2),bems(1) - chem(i,kts,j,p_seas_1)=tc(1)*converi - chem(i,kts,j,p_seas_2)=tc(2)*converi - chem(i,kts,j,p_seas_3)=tc(3)*converi - chem(i,kts,j,p_seas_4)=tc(4)*converi -! for output diagnostics -! emis_seas(i,1,j,p_edust1)=bems(1) -! emis_seas(i,1,j,p_edust2)=bems(2) -! emis_seas(i,1,j,p_edust3)=bems(3) -! emis_seas(i,1,j,p_edust4)=bems(4) - endif - enddo - enddo - endif -! - -end subroutine gocart_seasalt_driver -! -SUBROUTINE source_ss(imx,jmx,lmx,nmx, dt1, tc, & - ilwi, dxy, w10m, airmas, & - bems,ipr) - -! **************************************************************************** -! * Evaluate the source of each seasalt particles size classes (kg/m3) -! * by soil emission. -! * Input: -! * SSALTDEN Sea salt density (kg/m3) -! * DXY Surface of each grid cell (m2) -! * NDT1 Time step (s) -! * W10m Velocity at the anemometer level (10meters) (m/s) -! * -! * Output: -! * DSRC Source of each sea salt bins (kg/timestep/cell) -! * -! * -! * Number flux density: Original formula by Monahan et al. (1986) adapted -! * by Sunling Gong (JGR 1997 (old) and GBC 2003 (new)). The new version is -! * to better represent emission of sub-micron sea salt particles. -! -! * dFn/dr = c1*u10**c2/(r**A) * (1+c3*r**c4)*10**(c5*exp(-B**2)) -! * where B = (b1 -log(r))/b2 -! * see c_old, c_new, b_old, b_new below for the constants. -! * number fluxes are at 80% RH. -! * -! * To calculate the flux: -! * 1) Calculate dFn based on Monahan et al. (1986) and Gong (2003) -! * 2) Assume that wet radius r at 80% RH = dry radius r_d *frh -! * 3) Convert particles flux to mass flux : -! * dFM/dr_d = 4/3*pi*rho_d*r_d^3 *(dr/dr_d) * dFn/dr -! * = 4/3*pi*rho_d*r_d^3 * frh * dFn/dr -! * where rho_p is particle density [kg/m3] -! * The factor 1.e-18 is to convert in micro-meter r_d^3 -! **************************************************************************** - - - USE module_data_gocart_seas - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: nmx,imx,jmx,lmx,ipr - INTEGER, INTENT(IN) :: ilwi(imx,jmx) - REAL*8, INTENT(IN) :: dxy(jmx), w10m(imx,jmx) - REAL*8, INTENT(IN) :: airmas(imx,jmx,lmx) - REAL*8, INTENT(INOUT) :: tc(imx,jmx,lmx,nmx) - REAL*8, INTENT(OUT) :: bems(imx,jmx,nmx) - - REAL*8 :: c0(5), b0(2) -! REAL*8, PARAMETER :: c_old(5)=(/1.373, 3.41, 0.057, 1.05, 1.190/) -! REAL*8, PARAMETER :: c_new(5)=(/1.373, 3.41, 0.057, 3.45, 1.607/) - ! Change suggested by MC - REAL*8, PARAMETER :: c_old(5)=(/1.373, 3.2, 0.057, 1.05, 1.190/) - REAL*8, PARAMETER :: c_new(5)=(/1.373, 3.2, 0.057, 3.45, 1.607/) - REAL*8, PARAMETER :: b_old(2)=(/0.380, 0.650/) - REAL*8, PARAMETER :: b_new(2)=(/0.433, 0.433/) - REAL*8, PARAMETER :: dr=5.0D-2 ! um - REAL*8, PARAMETER :: theta=30.0 - ! Swelling coefficient frh (d rwet / d rd) -!!! REAL*8, PARAMETER :: frh = 1.65 - REAL*8, PARAMETER :: frh = 2.d0 - LOGICAL, PARAMETER :: old=.TRUE., new=.FALSE. - REAL*8 :: rho_d, r0, r1, r, r_w, a, b, dfn, r_d, dfm, src - INTEGER :: i, j, n, nr, ir - REAL :: dt1,fudge_fac - - - REAL*8 :: tcmw(nmx), ar(nmx), tcvv(nmx) - REAL*8 :: ar_wetdep(nmx), kc(nmx) - CHARACTER(LEN=20) :: tcname(nmx), tcunits(nmx) - LOGICAL :: aerosol(nmx) - - - REAL*8 :: tc1(imx,jmx,lmx,nmx) - REAL*8, TARGET :: tcms(imx,jmx,lmx,nmx) ! tracer mass (kg; kgS for sulfur case) - REAL*8, TARGET :: tcgm(imx,jmx,lmx,nmx) ! g/m3 - - !----------------------------------------------------------------------- - ! sea salt specific - !----------------------------------------------------------------------- -! REAL*8, DIMENSION(nmx) :: ra, rb -! REAL*8 :: ch_ss(nmx,12) - - !----------------------------------------------------------------------- - ! emissions (input) - !----------------------------------------------------------------------- - REAL*8 :: e_an(imx,jmx,2,nmx), e_bb(imx,jmx,nmx), & - e_ac(imx,jmx,lmx,nmx) - - !----------------------------------------------------------------------- - ! diagnostics (budget) - !----------------------------------------------------------------------- -! ! tendencies per time step and process -! REAL*8, TARGET :: bems(imx,jmx,nmx), bdry(imx,jmx,nmx), bstl(imx,jmx,nmx) -! REAL*8, TARGET :: bwet(imx,jmx,nmx), bcnv(imx,jmx,nmx)! - -! ! integrated tendencies per process -! REAL*8, TARGET :: tems(imx,jmx,nmx), tstl(imx,jmx,nmx) -! REAL*8, TARGET :: tdry(imx,jmx,nmx), twet(imx,jmx,nmx), tcnv(imx,jmx,nmx) - - ! global mass balance per time step - REAL*8 :: tmas0(nmx), tmas1(nmx) - REAL*8 :: dtems(nmx), dttrp(nmx), dtdif(nmx), dtcnv(nmx) - REAL*8 :: dtwet(nmx), dtdry(nmx), dtstl(nmx) - REAL*8 :: dtems2(nmx), dttrp2(nmx), dtdif2(nmx), dtcnv2(nmx) - REAL*8 :: dtwet2(nmx), dtdry2(nmx), dtstl2(nmx) - - ! detailed integrated budgets for individual emissions - REAL*8, TARGET :: ems_an(imx,jmx,nmx), ems_bb(imx,jmx,nmx), ems_tp(imx,jmx) - REAL*8, TARGET :: ems_ac(imx,jmx,lmx,nmx) - REAL*8, TARGET :: ems_co(imx,jmx,nmx) - - - ! executable statements -! decrease seasalt emissions (Colarco et al. 2010) -! - fudge_fac= 1. !.5 -! - DO n = 1,nmx -! if(ipr.eq.1)write(0,*)'in seasalt',n,ipr,ilwi - bems(:,:,n) = 0.0 - rho_d = den_seas(n) - r0 = ra(n)*frh - r1 = rb(n)*frh - r = r0 - nr = INT((r1-r0)/dr+.001) -! if(ipr.eq.1.and.n.eq.1)write(0,*)'in seasalt',nr,r1,r0,dr,rho_d - DO ir = 1,nr - r_w = r + dr*0.5 - r = r + dr - IF (new) THEN - a = 4.7*(1.0 + theta*r_w)**(-0.017*r_w**(-1.44)) - c0 = c_new - b0 = b_new - ELSE - a = 3.0 - c0 = c_old - b0 = b_old - END IF - ! - b = (b0(1) - LOG10(r_w))/b0(2) - dfn = (c0(1)/r_w**a)*(1.0 + c0(3)*r_w**c0(4))* & - 10**(c0(5)*EXP(-(b**2))) - - r_d = r_w/frh*1.0D-6 ! um -> m - dfm = 4.0/3.0*pi*r_d**3*rho_d*frh*dfn*dr*dt1 ! 3600 !dt1 - DO i = 1,imx - DO j = 1,jmx -! IF (water(i,j) > 0.0) THEN - IF (ilwi(i,j) == 0) THEN -! src = dfm*dxy(j)*water(i,j)*w10m(i,j)**c0(2) - src = dfm*dxy(j)*w10m(i,j)**c0(2) -! src = ch_ss(n,dt(1)%mn)*dfm*dxy(j)*w10m(i,j)**c0(2) - tc(i,j,1,n) = tc(i,j,1,n) + fudge_fac*src/airmas(i,j,1) -! if(ipr.eq.1)write(0,*)n,dfm,c0(2),dxy(j),w10m(i,j),src,airmas(i,j,1) - ELSE - src = 0.0 - END IF - bems(i,j,n) = bems(i,j,n) + src*fudge_fac - END DO ! i - END DO ! j - END DO ! ir - END DO ! n - -END SUBROUTINE source_ss -END MODULE MODULE_GOCART_SEASALT diff --git a/src/fim/FIMsrc/fim/column_chem/module_gocart_settling.F90 b/src/fim/FIMsrc/fim/column_chem/module_gocart_settling.F90 deleted file mode 100644 index f392a1e..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_gocart_settling.F90 +++ /dev/null @@ -1,502 +0,0 @@ -MODULE MODULE_GOCART_SETTLING - -CONTAINS - -SUBROUTINE gocart_settling_driver(dt,t_phy,moist, & - chem,rho_phy,dz8w,p8w,p_phy, & - dusthelp,seashelp,area,g, & - num_moist,num_chem, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) -! USE module_configure -! USE module_state_description - USE module_initial_chem_namelists - USE module_data_gocart_dust - USE module_data_gocart_seas -! USE module_model_constants, ONLY: mwdry - IMPLICIT NONE -! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - - INTEGER, INTENT(IN ) :: & - num_moist,num_chem, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & - INTENT(IN ) :: moist - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & - INTENT(INOUT ) :: chem - REAL, DIMENSION( ims:ime, jms:jme ), & - INTENT(IN ) :: dusthelp,seashelp - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: t_phy,p_phy,dz8w,p8w,rho_phy - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(IN ) :: area - - REAL, INTENT(IN ) :: dt,g - integer :: nv,nmx,i,j,k,kk,lmx,iseas,idust - real*8, DIMENSION (1,1,kte-kts+0) :: tmp,airden,airmas,p_mid,delz,rh - real*8, DIMENSION (1,1,kte-kts+0,5) :: dust - real*8, DIMENSION (1,1,kte-kts+0,4) :: sea_salt - real, dimension (1:5) :: maxdust,maxseas -! -! bstl is for budgets -! -! real*8, DIMENSION (5), PARAMETER :: den_dust(5)=(/2500.,2650.,2650.,2650.,2650./) -! real*8, DIMENSION (5), PARAMETER :: reff_dust(5)=(/0.73D-6,1.4D-6,2.4D-6,4.5D-6,8.0D-6/) -! real*8, DIMENSION (4), PARAMETER :: den_seas(4)=(/2200.,2200.,2200.,2290./) -! real*8, DIMENSION (4), PARAMETER :: reff_seas(4)=(/0.30D-6,1.00D-6,3.25D-6,7.50D-6/) - real*8, DIMENSION (5) :: bstl_dust - real*8, DIMENSION (4) :: bstl_seas - real*8 conver,converi - real*8,parameter::max_default=0. -! conver=1.e-9*mwdry -! converi=1.e9/mwdry - conver=1.e-9 - converi=1.e9 - lmx=kte-kts+1 - lmx=kte-kts -! write(6,*)'in settle' - if(chem_opt == 304 .or. chem_opt == 316 .or. chem_opt == 317) then -! -! GOCART "very" light -! - do j=jts,jte - do i=its,ite - bstl_dust(:)=0. - bstl_seas(:)=0. -! -! initialize met stuff -! - kk=0 - do k=kts,kte-1 - kk=kk+1 - p_mid(1,1,kk)=.01*p_phy(i,kte-k+kts-1,j) - delz(1,1,kk)=dz8w(i,kte-k+kts-1,j) - airmas(1,1,kk)=-(p8w(i,k+1,j)-p8w(i,k,j))*area(i,j)/g - airden(1,1,kk)=rho_phy(i,k,j) - tmp(1,1,kk)=t_phy(i,k,j) - rh(1,1,kk) = .95 - rh(1,1,kk) = MIN( .95, moist(i,k,j,p_qv) / & - (3.80*exp(17.27*(t_phy(i,k,j)-273.)/ & - (t_phy(i,k,j)-36.))/(.01*p_phy(i,k,j)))) - rh(1,1,kk)=max(1.0D-1,rh(1,1,kk)) - enddo -! -! dust first -! - if(dust_opt == 1 .or. dust_opt == 3)then - iseas=0 - idust=1 - maxdust(:)=0. - kk=0 - do nv = p_dust_1,p_dust_2 - kk=kk+1 - do k=kts,kte - if(chem(i,k,j,nv).gt.maxdust(kk)) maxdust(kk)=chem(i,k,j,nv) - enddo - enddo - kk=0 - do k=kts,kte-1 - kk=kk+1 - if(k.eq.kts)then - dust(1,1,kk,1)=(chem(i,k,j,p_dust_1)-.31*dusthelp(i,j))*conver - dust(1,1,kk,2)=dusthelp(i,j)*conver - dust(1,1,kk,3)=(-.67*dusthelp(i,j)+chem(i,k,j,p_dust_2))*conver - else - dust(1,1,kk,1)=chem(i,k,j,p_dust_1)*conver - dust(1,1,kk,2)=1.d-30 - dust(1,1,kk,3)=chem(i,k,j,p_dust_2)*conver - endif - dust(1,1,kk,4)=1.d-30 - dust(1,1,kk,5)=1.d-30 - enddo - call settling(1, 1, lmx, 5,g,dyn_visc, & - dust, tmp, p_mid, delz, airmas, & - den_dust, reff_dust, dt, bstl_dust, rh, idust, iseas) - kk=0 - do k=kts,kte-5 - kk=kk+1 - if(k.eq.kts)then - chem(i,k,j,p_dust_1)=max(max_default,(dust(1,1,kk,1)+.31*dust(1,1,kk,2))*converi) - chem(i,k,j,p_dust_2)=max(max_default,(.67*dust(1,1,kk,2)+dust(1,1,kk,3))*converi) - else - chem(i,k,j,p_dust_1)=max(max_default,dust(1,1,kk,1)*converi) - chem(i,k,j,p_dust_2)=max(max_default,dust(1,1,kk,3)*converi) - endif - chem(i,k,j,p_dust_1)=min(maxdust(1),chem(i,k,j,p_dust_1)) - chem(i,k,j,p_dust_2)=min(maxdust(2),chem(i,k,j,p_dust_2)) - enddo - do k=kte-4,kte - chem(i,k,j,p_dust_1)=0. - chem(i,k,j,p_dust_2)=0. - enddo - endif ! dust_opt -! -! -! - if(seas_opt == 1 ) then - iseas=1 - idust=0 - maxseas(:)=0. - kk=0 - do nv = p_seas_1,p_seas_2 - kk=kk+1 - do k=kts,kte - if(chem(i,k,j,nv).gt.maxseas(kk)) maxseas(kk)=chem(i,k,j,nv) - enddo - enddo - kk=0 - do k=kts,kte-1 - kk=kk+1 - if(k.eq.kts)then - sea_salt(1,1,kk,1)=(chem(i,k,j,p_seas_1)-.75*seashelp(i,j))*conver - sea_salt(1,1,kk,2)=seashelp(i,j)*conver - sea_salt(1,1,kk,3)=(chem(i,k,j,p_seas_2)-.25*seashelp(i,j))*conver - else - sea_salt(1,1,kk,1)=chem(i,k,j,p_seas_1)*conver - sea_salt(1,1,kk,2)=1.d-30 - sea_salt(1,1,kk,3)=chem(i,k,j,p_seas_2)*conver - endif - sea_salt(1,1,kk,4)=1.d-30 - enddo - call settling(1, 1, lmx, 4, g,dyn_visc,& - sea_salt, tmp, p_mid, delz, airmas, & - den_seas, reff_seas, dt, bstl_seas, rh, idust, iseas) - kk=0 - do k=kts,kte-5 - kk=kk+1 - if(k.eq.kts)then - chem(i,k,j,p_seas_1)=(sea_salt(1,1,kk,1)+.75*sea_salt(1,1,kk,2))*converi - chem(i,k,j,p_seas_2)=(.25*sea_salt(1,1,kk,2)+sea_salt(1,1,kk,3))*converi - else - chem(i,k,j,p_seas_1)=sea_salt(1,1,kk,1)*converi - chem(i,k,j,p_seas_2)=sea_salt(1,1,kk,3)*converi - endif - chem(i,k,j,p_seas_1)=min(maxseas(1),chem(i,k,j,p_seas_1)) - chem(i,k,j,p_seas_2)=min(maxseas(2),chem(i,k,j,p_seas_2)) - enddo - do k=kte-4,kte - chem(i,k,j,p_seas_1)=0. - chem(i,k,j,p_seas_2)=0. - enddo - endif ! seas_opt == 1 -! -! -! - enddo !enddo's for i,j - enddo ! -! -! else run with all GOCART variables, GOCART sort of HEAVY! -! - else ! chem_opt=300 -! - do j=jts,jte - do i=its,ite -! -! initialize some met stuff -! - kk=0 - bstl_dust(:)=0. - bstl_seas(:)=0. - do k=kts,kte-1 - kk=kk+1 - p_mid(1,1,kk)=.01*p_phy(i,kte-k+kts-1,j) - delz(1,1,kk)=dz8w(i,kte-k+kts-1,j) - airmas(1,1,kk)=-(p8w(i,k+1,j)-p8w(i,k,j))*area(i,j)/g - airden(1,1,kk)=rho_phy(i,k,j) - tmp(1,1,kk)=t_phy(i,k,j) - rh(1,1,kk) = .95 - rh(1,1,kk) = MIN( .95, moist(i,k,j,p_qv) / & - (3.80*exp(17.27*(t_phy(i,k,j)-273.)/ & - (t_phy(i,k,j)-36.))/(.01*p_phy(i,k,j)))) - rh(1,1,kk)=max(1.0D-1,rh(1,1,kk)) - enddo -! -! max dust in column -! - if(dust_opt == 1 .or. dust_opt == 3) then - iseas=0 - idust=1 - maxdust(:)=0. - kk=0 - do nv = p_dust_1,p_dust_5 - kk=kk+1 - do k=kts,kte - if(chem(i,k,j,nv).gt.maxdust(kk)) maxdust(kk)=chem(i,k,j,nv) - enddo - enddo - kk=0 - do k=kts,kte-1 - kk=kk+1 - dust(1,1,kk,1)=chem(i,k,j,p_dust_1)*conver - dust(1,1,kk,2)=chem(i,k,j,p_dust_2)*conver - dust(1,1,kk,3)=chem(i,k,j,p_dust_3)*conver - dust(1,1,kk,4)=chem(i,k,j,p_dust_4)*conver - dust(1,1,kk,5)=chem(i,k,j,p_dust_5)*conver - enddo - - - call settling(1, 1, lmx, 5,g,dyn_visc, & - dust, tmp, p_mid, delz, airmas, & - den_dust, reff_dust, dt, bstl_dust, rh, idust, iseas) - kk=0 - do k=kts,kte-4 - kk=kk+1 - chem(i,k,j,p_dust_1)=dust(1,1,kk,1)*converi - chem(i,k,j,p_dust_2)=dust(1,1,kk,2)*converi - chem(i,k,j,p_dust_3)=dust(1,1,kk,3)*converi - chem(i,k,j,p_dust_4)=dust(1,1,kk,4)*converi - chem(i,k,j,p_dust_5)=dust(1,1,kk,5)*converi - chem(i,k,j,p_dust_1)=min(maxdust(1),chem(i,k,j,p_dust_1)) - chem(i,k,j,p_dust_2)=min(maxdust(2),chem(i,k,j,p_dust_2)) - chem(i,k,j,p_dust_3)=min(maxdust(3),chem(i,k,j,p_dust_3)) - chem(i,k,j,p_dust_4)=min(maxdust(4),chem(i,k,j,p_dust_4)) - chem(i,k,j,p_dust_5)=min(maxdust(5),chem(i,k,j,p_dust_5)) - enddo - do k=kte-3,kte - chem(i,k,j,p_dust_1)=1.e-16 - chem(i,k,j,p_dust_2)=1.e-16 - chem(i,k,j,p_dust_3)=1.e-16 - chem(i,k,j,p_dust_4)=1.e-16 - chem(i,k,j,p_dust_5)=1.e-16 - enddo - endif ! dust_opt -! -! -! - if(seas_opt == 1 ) then - iseas=1 - idust=0 - kk=0 - do k=kts,kte-1 - kk=kk+1 - sea_salt(1,1,kk,1)=chem(i,k,j,p_seas_1)*conver - sea_salt(1,1,kk,2)=chem(i,k,j,p_seas_2)*conver - sea_salt(1,1,kk,3)=chem(i,k,j,p_seas_3)*conver - sea_salt(1,1,kk,4)=chem(i,k,j,p_seas_4)*conver - enddo -! -! max seasalt in column -! - maxseas(:)=0. - kk=0 - do nv = p_seas_1,p_seas_4 - kk=kk+1 - do k=kts,kte - if(chem(i,k,j,nv).gt.maxseas(kk)) maxseas(kk)=chem(i,k,j,nv) - enddo - enddo -! write(0,*)i,j,bstl_dust(3),bstl_dust(4),chem(i,1,j,p_dust_4) - call settling(1, 1, lmx, 4, g,dyn_visc,& - sea_salt, tmp, p_mid, delz, airmas, & - den_seas, reff_seas, dt, bstl_seas, rh, idust, iseas) - kk=0 - do k=kts,kte-4 - kk=kk+1 - chem(i,k,j,p_seas_1)=sea_salt(1,1,kk,1)*converi - chem(i,k,j,p_seas_2)=sea_salt(1,1,kk,2)*converi - chem(i,k,j,p_seas_3)=sea_salt(1,1,kk,3)*converi - chem(i,k,j,p_seas_4)=sea_salt(1,1,kk,4)*converi - chem(i,k,j,p_seas_1)=min(maxseas(1),chem(i,k,j,p_seas_1)) - chem(i,k,j,p_seas_2)=min(maxseas(2),chem(i,k,j,p_seas_2)) - chem(i,k,j,p_seas_3)=min(maxseas(3),chem(i,k,j,p_seas_3)) - chem(i,k,j,p_seas_4)=min(maxseas(4),chem(i,k,j,p_seas_4)) - enddo - do k=kte-3,kte - chem(i,k,j,p_seas_1)=0. - chem(i,k,j,p_seas_2)=0. - chem(i,k,j,p_seas_3)=0. - chem(i,k,j,p_seas_4)=0. - enddo - endif ! end seasopt==1 -! -! -! - enddo - enddo -! -! -! - endif ! end chem_opt -! -END SUBROUTINE gocart_settling_driver - - - subroutine settling(imx,jmx, lmx, nmx,g0,dyn_visc, & - tc, tmp, p_mid, delz, airmas, & - den, reff, dt, bstl, rh, idust, iseas) -! **************************************************************************** -! * * -! * Calculate the loss by settling, using an implicit method * -! * * -! * Input variables: * -! * SIGE(k) - sigma coordinate of the vertical edges * -! * PS(i,j) - Surface pressure (mb) * -! * TMP(i,j,k) - Air temperature (K) * -! * CT(i,j) - Surface exchange coeff for moisture -! * * -! **************************************************************************** - - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: imx, jmx, lmx, nmx,iseas,idust - INTEGER :: ntdt - REAL, INTENT(IN) :: dt,g0,dyn_visc - REAL*8, INTENT(IN) :: tmp(imx,jmx,lmx), delz(imx,jmx,lmx), & - airmas(imx,jmx,lmx), rh(imx,jmx,lmx), & - den(nmx), reff(nmx), p_mid(imx,jmx,lmx) - REAL*8, INTENT(INOUT) :: tc(imx,jmx,lmx,nmx) - REAL*8, INTENT(OUT) :: bstl(imx,jmx,nmx) - - REAL*8 :: tc1(imx,jmx,lmx,nmx), dt_settl(nmx), rcm(nmx), rho(nmx) - INTEGER :: ndt_settl(nmx) - REAL*8 :: dzmin, vsettl, dtmax, pres, rhb, rwet(nmx), ratio_r(nmx) - REAL*8 :: c_stokes, free_path, c_cun, viscosity, vd_cor, growth_fac - INTEGER :: k, n, i, j, l, l2 - ! for sea-salt: - REAL*8, PARAMETER :: c1=0.7674, c2=3.079, c3=2.573E-11, c4=-1.424 - - ! for OMP: - REAL*8 :: rwet_priv(nmx), rho_priv(nmx) - - ! executable statements - -! IF (type) /= 'dust' .AND. TRIM(aero_type) /= 'sea_salt') RETURN - if(idust.ne.1.and.iseas.ne.1)return - -!!! WHERE (tc(:,:,:,:) < 0.0) tc(:,:,:,:) = 1.0E-32 - - dzmin = MINVAL(delz(:,:,:)) - IF (idust == 1) growth_fac = 1.0 - IF (iseas == 1) growth_fac = 3.0 - - DO k = 1,nmx - - ! Settling velocity (m/s) for each tracer (Stokes Law) - ! DEN density (kg/m3) - ! REFF effective radius (m) - ! dyn_visc dynamic viscosity (kg/m/s) - ! g0 gravity (m/s2) - ! 3.0 corresponds to a growth of a factor 3 of radius with 100% RH - ! 0.5 upper limit with temp correction - - tc1(:,:,:,k) = tc(:,:,:,k) - vsettl = 2.0/9.0 * g0 * den(k) * (growth_fac*reff(k))**2 / & - (0.5*dyn_visc) - - ! Determine the maximum time-step satisying the CFL condition: - ! dt <= (dz)_min / v_settl - ntdt=INT(dt) - dtmax = dzmin / vsettl - ndt_settl(k) = MAX( 1, INT( ntdt /dtmax) ) - ! limit maximum number of iterations - IF (ndt_settl(k) > 12) ndt_settl(k) = 12 - dt_settl(k) = REAL(ntdt) / REAL(ndt_settl(k)) - - ! Particles radius in centimeters - IF (iseas.eq.1)rcm(k) = reff(k)*100.0 - IF (idust.eq.1)then - rwet(k) = reff(k) - ratio_r(k) = 1.0 - rho(k) = den(k) - endif - END DO - - ! Solve the bidiagonal matrix (l,l) - -!$OMP PARALLEL DO & -!$OMP DEFAULT( SHARED ) & -!$OMP PRIVATE( i, j, l, l2, n, k, rhb, rwet_priv, ratio_r, c_stokes)& -!$OMP PRIVATE( free_path, c_cun, viscosity, rho_priv, vd_cor ) - - ! Loop over latitudes - DO j = 1,jmx - - DO k = 1,nmx - IF (idust.eq.1) THEN - rwet_priv(k) = rwet(k) - rho_priv(k) = rho(k) - END IF - - DO n = 1,ndt_settl(k) - - ! Solve each vertical layer successively (layer l) - - DO l = lmx,1,-1 - l2 = lmx - l + 1 - -! DO j = 1,jmx - DO i = 1,imx - - IF (iseas.eq.1) THEN - rhb = MIN(9.9D-1, rh(i,j,l)) - ! Aerosol growth with relative humidity (Gerber, 1985) -! td -! changed to LOG10 - rwet_priv(k) = 0.01*(c1*rcm(k)**c2/(c3*rcm(k)**c4 - & - LOG10(rhb)) + rcm(k)**3)**0.33 - ratio_r(k) = (reff(k)/rwet_priv(k))**3.0 - END IF - - ! Dynamic viscosity - c_stokes = 1.458E-6 * tmp(i,j,l)**1.5/(tmp(i,j,l) + 110.4) - - ! Mean free path as a function of pressure (mb) and - ! temperature (K) - ! order of p_mid is top->sfc - free_path = 1.1E-3/p_mid(i,j,l2)/SQRT(tmp(i,j,l)) -!!! free_path = 1.1E-3/p_edge(i,j,l2)/SQRT(tmp(i,j,l)) - - ! Slip Correction Factor - c_cun = 1.0+ free_path/rwet_priv(k)* & - (1.257 + 0.4*EXP(-1.1*rwet_priv(k)/free_path)) - - ! Corrected dynamic viscosity (kg/m/s) - viscosity = c_stokes / c_cun - - ! Settling velocity - IF (iseas.eq.1) THEN - rho_priv(k) = ratio_r(k)*den(k) + (1.0 - ratio_r(k))*1000.0 - END IF - - vd_cor = 2.0/9.0*g0*rho_priv(k)*rwet_priv(k)**2/viscosity - - ! Update mixing ratio - ! Order of delz is top->sfc - IF (l == lmx) THEN - tc(i,j,l,k) = tc(i,j,l,k) / & - (1.0 + dt_settl(k)*vd_cor/delz(i,j,l2)) - ELSE - tc(i,j,l,k) = 1.0/(1.0+dt_settl(k)*vd_cor/delz(i,j,l2))& - *(tc(i,j,l,k) + dt_settl(k)*vd_cor /delz(i,j,l2-1) & - * tc(i,j,l+1,k)) - END IF - END DO !i -! END DO !j - END DO !l - - END DO !n - END DO !k - - END DO !j -!$OMP END PARALLEL DO - - DO n = 1,nmx - DO i = 1,imx - DO j = 1,jmx - bstl(i,j,n) = 0.0 - DO l = 1,lmx - IF (tc(i,j,l,n) < 0.0) tc(i,j,l,n) = 1.0D-32 - bstl(i,j,n) = bstl(i,j,n) + & - (tc(i,j,l,n) - tc1(i,j,l,n)) * airmas(i,j,l) - END DO - END DO - END DO - END DO - -END SUBROUTINE settling - -END MODULE MODULE_GOCART_SETTLING diff --git a/src/fim/FIMsrc/fim/column_chem/module_initial_chem_namelist_defaults.F90 b/src/fim/FIMsrc/fim/column_chem/module_initial_chem_namelist_defaults.F90 deleted file mode 100644 index 75ae62b..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_initial_chem_namelist_defaults.F90 +++ /dev/null @@ -1,406 +0,0 @@ -Module module_chem_namelist_defaults -CONTAINS - subroutine set_chem_namelist_defaults -USE module_initial_chem_namelists -!STARTOFREGISTRYGENERATEDINCLUDE 'inc/namelist_defaults.inc' -! -! THIS does not need to be recopied. Defaults are simple to set! -! -emi_inname = "fimemi" -fireemi_inname = "fimfireemi" -input_chem_inname = "fim_chem_input" -emi_outname =" " -fireemi_outname = " " -input_chem_outname = " " -frames_per_emissfile = 1 -frames_per_fireemissfile = 1 -bioemdt = 0 -photdt = 0 -chemdt = 0 -ne_area = 41 -kemit = 1 -nmegan = 138 -kfuture = 1 -errosion_dim = 3 -chem_conv_tr = 1 -chem_opt = 0 -gaschem_onoff = 1 -aerchem_onoff = 1 -wetscav_onoff = 0 -cldchem_onoff = 0 -vertmix_onoff = 1 -chem_in_opt = 0 -phot_opt = 0 -drydep_opt = 0 -emiss_opt = 4 -dust_opt = 0 -dmsemis_opt = 0 -seas_opt = 0 -bio_emiss_opt = 0 -biomass_burn_opt = 0 -plumerisefire_frq = 180 -emiss_inpt_opt = 1 -gas_bc_opt = 1 -gas_ic_opt = 1 -aer_bc_opt = 1 -aer_ic_opt = 1 -have_bcs_chem = .false. -aer_ra_feedback = 0 -aer_op_opt = 1 -END SUBROUTINE set_chem_namelist_defaults - -SUBROUTINE set_species -USE module_chemvars -! TBH: Ignore these so PPP doesn't have to translate them -!SMS$IGNORE BEGIN -USE module_initial_chem_namelists -USE module_data_gocart_dust -USE module_data_gocart_seas -!SMS$IGNORE END -USE module_wrf_control, only: num_chem,num_emis_ant,num_emis_vol -! -if(aer_ra_feedback == 1)then - P_extcof3 = 1 - P_extcof55 = 2 - P_extcof106 = 3 - P_extcof3_5 = 4 - P_extcof8_12 = 5 - P_bscof3 = 1 - P_bscof55 = 2 - P_bscof106 = 3 - P_asympar3 = 1 - P_asympar55 = 2 - P_asympar106 = 3 -endif -! gocart fim light -if(chem_opt.eq.304)then -if(num_chem.ne.13)then - write(6,*) ' num_chem is not equal 13 for gocart fimlight ' - stop -endif -if(num_emis_ant.lt.4)then - write(6,*) ' num_emis_ant smaller than 4 ' - stop - if(num_emis_ant.lt.6 .and. biomass_burn_opt.eq.1)then - write(6,*) ' num_emis_ant smaller than 6 ' - stop - endif -endif -p_qv=1 -p_qc=2 -p_qi=3 -ch_dust(:,:)=0.8D-9 -ch_ss(:,:)=1. -p_so2=1 -numgas=4 -p_sulf=2 -p_dms=3 -p_msa=4 -p_p25=5 -p_bc1=6 -p_bc2=7 -p_oc1=8 -p_oc2=9 -p_dust_1=10 -p_dust_2=11 -p_seas_1=12 -p_seas_2=13 -p_e_bc =1 -p_e_oc =2 -p_e_sulf=3 -p_e_pm_25=4 -p_e_so2=5 -p_e_pm_10=6 -! diagnostic dust and seasale stuff -p_edust1=1 -p_edust2=2 -p_edust3=3 -p_edust4=4 -p_edust5=5 -p_eseas1=1 -p_eseas2=2 -p_eseas3=3 -p_eseas4=4 -endif -! -! 2 tracers -! -if(chem_opt.eq.500)then -if(num_chem.ne.2)then - write(6,*) ' num_chem is not equal 2 ' - stop -endif -if(num_emis_ant.lt.2)then - write(6,*) ' num_emis_ant smaller than 2 ' - stop -endif -p_qv=1 -p_qc=2 -p_qi=3 -p_tr1=1 -p_tr2=2 -p_e_tr1=1 -p_e_tr2=2 -endif - -! -! volcanic ash -! -if(chem_opt.eq.16)then -if(num_chem.ne.10)then - write(6,*) ' num_chem is not equal 10 for Volcano run' - stop -endif -if(num_emis_vol.lt.10)then - write(6,*) ' num_emis_ant smaller than 10 ' - stop -endif -p_qv=1 -p_qc=2 -p_qi=3 -emiss_opt=7 -p_vash_1 = 1 -p_vash_2 = 2 -p_vash_3 = 3 -p_vash_4 = 4 -p_vash_5 = 5 -p_vash_6 = 6 -p_vash_7 = 7 -p_vash_8 = 8 -p_vash_9 = 9 -p_vash_10 = 10 -p_e_vash1 = 1 -p_e_vash2 = 2 -p_e_vash3 = 3 -p_e_vash4 = 4 -p_e_vash5 = 5 -p_e_vash6 = 6 -p_e_vash7 = 7 -p_e_vash8 = 8 -p_e_vash9 = 9 -p_e_vash10 = 10 -numgas=0 -endif -! volcanoc ash (4 bins) only -! -if(chem_opt.eq.502)then -print *,'INITIALIZE FOR CHEM_OPT=502' -if(num_emis_vol.lt.4)then - write(6,*) ' num_emis_vol smaller than 4 ' - stop -endif -if(num_chem.ne.4)then - write(6,*) ' num_chem is not equal 4 ' - stop -endif -ch_dust(:,:)=0.8D-9 -ch_ss(:,:)=1. -p_qv=1 -p_qc=2 -p_qi=3 -numgas=0 -p_vash_1 = 1 -p_vash_2 = 2 -p_vash_3 = 3 -p_vash_4 = 4 -p_e_vash1 = 1 -p_e_vash2 = 2 -p_e_vash3 = 3 -p_e_vash4 = 4 -endif ! chem_opt=502 -! gocart simple +volcanic ash simple -if(chem_opt.eq.317)then -print *,'INITIALIZE FOR CHEM_OPT=317' -if(num_emis_vol.lt.4)then - write(6,*) ' num_emis_vol smaller than 4 ' - stop -endif -if(num_chem.ne.17)then - write(6,*) ' num_chem is not equal 17 ' - stop -endif -if(num_emis_ant.lt.4)then - write(6,*) ' num_emis_ant smaller than 4 ' - stop - if(num_emis_ant.lt.6 .and. biomass_burn_opt.eq.1)then - write(6,*) ' num_emis_ant smaller than 6 ' - stop - endif -endif -ch_dust(:,:)=0.8D-9 -ch_ss(:,:)=1. -p_qv=1 -p_qc=2 -p_qi=3 -p_so2=1 -numgas=4 -p_sulf=2 -p_dms=3 -p_msa=4 -p_p25=5 -p_bc1=6 -p_bc2=7 -p_oc1=8 -p_oc2=9 -p_dust_1=10 -p_dust_2=11 -p_seas_1=12 -p_seas_2=13 -p_e_bc =1 -p_e_oc =2 -p_e_sulf=3 -p_e_pm_25=4 -p_e_so2=5 -p_e_pm_10=6 -! diagnostic dust and seasale stuff -p_edust1=1 -p_edust2=2 -p_edust3=3 -p_edust4=4 -p_edust5=5 -p_eseas1=1 -p_eseas2=2 -p_eseas3=3 -p_eseas4=4 -p_vash_1 = 14 -p_vash_2 = 15 -p_vash_3 = 16 -p_vash_4 = 17 -p_e_vash1 = 1 -p_e_vash2 = 2 -p_e_vash3 = 3 -p_e_vash4 = 4 -endif -! gocart simple +volcanic ash -if(chem_opt.eq.316)then -print *,'INITIALIZE FOR CHEM_OPT=316' -if(num_emis_vol.lt.10)then - write(6,*) ' num_emis_vol smaller than 10 ' - stop -endif -if(num_chem.ne.23)then - write(6,*) ' num_chem is not equal 18 ' - stop -endif -if(num_emis_ant.lt.4)then - write(6,*) ' num_emis_ant smaller than 4 ' - stop - if(num_emis_ant.lt.6 .and. biomass_burn_opt.eq.1)then - write(6,*) ' num_emis_ant smaller than 6 ' - stop - endif -endif -ch_dust(:,:)=0.8D-9 -ch_ss(:,:)=1. -p_qv=1 -p_qc=2 -p_qi=3 -p_so2=1 -numgas=4 -p_sulf=2 -p_dms=3 -p_msa=4 -p_p25=5 -p_bc1=6 -p_bc2=7 -p_oc1=8 -p_oc2=9 -p_dust_1=10 -p_dust_2=11 -p_seas_1=12 -p_seas_2=13 -p_e_bc =1 -p_e_oc =2 -p_e_sulf=3 -p_e_pm_25=4 -p_e_so2=5 -p_e_pm_10=6 -! diagnostic dust and seasale stuff -p_edust1=1 -p_edust2=2 -p_edust3=3 -p_edust4=4 -p_edust5=5 -p_eseas1=1 -p_eseas2=2 -p_eseas3=3 -p_eseas4=4 -p_vash_1 = 14 -p_vash_2 = 15 -p_vash_3 = 16 -p_vash_4 = 17 -p_vash_5 = 18 -p_vash_6 = 19 -p_vash_7 = 20 -p_vash_8 = 21 -p_vash_9 = 22 -p_vash_10 =23 -p_e_vash1 = 1 -p_e_vash2 = 2 -p_e_vash3 = 3 -p_e_vash4 = 4 -p_e_vash5 = 5 -p_e_vash6 = 6 -p_e_vash7 = 7 -p_e_vash8 = 8 -p_e_vash9 = 9 -p_e_vash10 = 10 -endif -! gocart simple -if(chem_opt.eq.300)then -if(num_chem.ne.19)then - write(6,*) ' num_chem is not equal 19 ' - stop -endif -if(num_emis_ant.lt.4)then - write(6,*) ' num_emis_ant smaller than 4 ' - stop - if(num_emis_ant.lt.6 .and. biomass_burn_opt.eq.1)then - write(6,*) ' num_emis_ant smaller than 6 ' - stop - endif -endif -ch_dust(:,:)=0.8D-9 -ch_ss(:,:)=1. -p_qv=1 -p_qc=2 -p_qi=3 -p_so2=1 -numgas=4 -p_sulf=2 -p_dms=3 -p_msa=4 -p_p25=5 -p_bc1=6 -p_bc2=7 -p_oc1=8 -p_oc2=9 -p_dust_1=10 -p_dust_2=11 -p_dust_3=12 -p_dust_4=13 -p_dust_5=14 -p_seas_1=15 -p_seas_2=16 -p_seas_3=17 -p_seas_4=18 -p_p10 =19 -p_e_bc =1 -p_e_oc =2 -p_e_sulf=3 -p_e_pm_25=4 -p_e_so2=5 -p_e_pm_10=6 -! diagnostic dust and seasale stuff -p_edust1=1 -p_edust2=2 -p_edust3=3 -p_edust4=4 -p_edust5=5 -p_eseas1=1 -p_eseas2=2 -p_eseas3=3 -p_eseas4=4 -endif -END SUBROUTINE set_species -END MODULE module_chem_namelist_defaults diff --git a/src/fim/FIMsrc/fim/column_chem/module_optical_averaging.F90 b/src/fim/FIMsrc/fim/column_chem/module_optical_averaging.F90 deleted file mode 100644 index e4a0132..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_optical_averaging.F90 +++ /dev/null @@ -1,5577 +0,0 @@ -!************************************************************************ -! This computer software was prepared by Battelle Memorial Institute, -! hereinafter the Contractor, under Contract No. DE-AC05-76RL0 1830 with -! the Department of Energy (DOE). NEITHER THE GOVERNMENT NOR THE -! CONTRACTOR MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR ASSUMES ANY -! LIABILITY FOR THE USE OF THIS SOFTWARE. -! -! Module to Compute Aerosol Optical Properties -! * Author: Jerome D. Fast -! * Originators of parts of code: -! Rahul A. Zaveri, Jim Barnard, Richard C. Easter, William I. -! Gustafson Jr. -! Last update: February 2009 -! -! Contact: -! Jerome D. Fast, PhD -! Staff Scientist -! Pacific Northwest National Laboratory -! P.O. Box 999, MSIN K9-30 -! Richland, WA, 99352 -! Phone: (509) 372-6116 -! Email: Jerome.Fast@pnl.gov -! -! Please report any bugs or problems to Georg Grell -! -! Users preparing publications resulting from the usage of this code -! are requested to cite one or more of the references below -! (depending on the application) for proper acknowledgement. -! -! References: -! * Fast, J.D., W.I. Gustafson Jr., R.C. Easter, R.A. Zaveri, J.C. -! Barnard, E.G. Chapman, G.A. Grell, and S.E. Peckham (2005), Evolution -! of ozone, particulates, and aerosol direct radiative forcing in the -! vicinity of Houston using a fully-coupled meteorology-chemistry- -! aerosol model. JGR, 111, doi:10.1029/2005JD006721. -! * Barnard, J.C., J.D. Fast, G. Paredes-Miranda, W.P. Arnott, et al. -! (2009), Closure on the single scattering albedo in the WRF-Chem -! framework using data from the MILAGRO campaign, Atmos. Chem. Phys., -! submitted. -! -! -! Additional information: -! * www.pnl.gov/atmospheric/research/wrf-chem -! -! Support: -! Funding for this code development was provided by the U.S. Department -! of Energy under the auspices of Atmospheric Science Program of the -! Office of Biological and Environmental Research the PNNL Laboratory -! Research and Directed Research and Development program. -!************************************************************************ - module module_optical_averaging - - USE module_initial_chem_namelists,only: p_bc1,p_bc2,p_oc1,p_oc2, & - p_msa,p_dust_1,p_dust_2,p_dust_3,p_dust_4,p_dust_5, & - p_seas_1,p_seas_2,p_seas_3,p_seas_4,p_sulf,p_p25,p_so2, & - p_vash_1,p_vash_2,p_vash_3,p_vash_4,p_vash_5,p_vash_6, & - p_vash_7,p_vash_8,p_vash_9,p_vash_10,p_p10 - USE module_data_rrtmgaeropt - implicit none - integer, parameter, private :: lunerr = -1 - real, parameter :: hygro_msa_aer = 0.58 - integer nspint - parameter ( nspint = 4 ) ! number of spectral interval bands - integer, parameter :: kmaxd = 100 -! nbin_a_maxd = maximum num of aerosol bins and is used to dimension arrays - integer, parameter :: nbin_a_maxd = 8 - - - - contains - -!---------------------------------------------------------------------------------- -! Aerosol optical properties computed using three methods (option_method): -! 1) volume averaging mixing rule: method that assumes internal-mixing of aerosol -! composition that averages the refractive indices for each size bin -! 2) Maxwell-Garnett mixing rule: method that randomly distributes black carbon -! within a particle -! 3) shell-core: method that assumes a "core" composed of black carbon surrounded -! by a "shell" composed of all other compositions -! -! There are two Mie routines included (option_mie): -! 1) subroutine mieaer: Employs a Chebyshev economization (Fast et al. 2006, Ghan -! et al. (2001) so that full Mie computations are called only once and then -! expansion coeffiecients are used for subsequent times to save CPU. This -! method is somewhat less accurate than full Mie calculation. -! 2) subroutine mieaer_sc: Full Mie calculation at each time step that also -! permits computation of shell-core method. -! -! Sectional and modal size distributions are treated similary, but there is -! separate code currrently to handle differences between MOSAIC and MADE/SORGAM. -! -! Methodology for sectional: -! * 3-D arrays for refractive index, wet radius, and aerosol number produced by -! optical_prep_sectional are then passed into mieaer_sectional -! * subroutine mieaer produces vertical profiles of aerosol optical properties for -! 4 wavelengths that are put into 3-D arrays and passed back up to chem_driver.F -! * tauaer*, waer*, gaer* passed to module_ra_gsfcsw.F -! * tauaer*, waer*, gaer*, l2-l7 passed to module_phot_fastj.F -! Methodology for modal: -! * similar to sectional, except divide modal mass into discrete size bins first -! * currently assume same 8 size bins as MOSAIC, but other bins are possible -! -! THIS CODE IS STILL BEING TESTED. USERS ARE ENCOURAGED TO USE ONLY -! AER_OP_OPT=1 -! - subroutine optical_averaging(curr_secs,dtstep, & - nbin_o,option_method,option_mie,chem,dz8w,alt, & - relhum, & - tauaersw,gaersw,waersw,bscoefsw,tauaerlw, & - l2aer,l3aer,l4aer,l5aer,l6aer,l7aer, & - num_chem,chem_opt,ids,ide,jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) -!---------------------------------------------------------------------------------- -! USE module_configure -! USE module_state_description -! USE module_model_constants -! USE module_data_mosaic_therm, only: nbin_a, nbin_a_maxd -! - INTEGER, INTENT(IN ) :: chem_opt,ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - INTEGER, INTENT(IN ) :: nbin_o,num_chem - REAL(KIND=8), INTENT(IN ) :: curr_secs - REAL, INTENT(IN ) :: dtstep -! -! array that holds all advected chemical species -! - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & - INTENT(INOUT ) :: chem -! - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & - INTENT(IN ) :: relhum,dz8w, alt -! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & -! OPTIONAL, INTENT(IN ) :: h2oai, h2oaj -! -! arrays that hold the aerosol optical properties -! - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, 4 ), & - INTENT(INOUT ) :: & - tauaersw,gaersw,waersw,bscoefsw - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, 16 ), & - INTENT(INOUT ) :: & - tauaerlw - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, 1:4 ), & - INTENT(INOUT ) :: & - l2aer, l3aer, l4aer, l5aer, l6aer, l7aer -! -! -! local variables -! - real, dimension( its:ite, kts:kte, jts:jte, 1:nbin_o ) :: & - radius_wet, number_bin, radius_core - real, dimension( 1:nbin_o, kts:kte) :: & - radius_wet_col, number_bin_col, radius_core_col - complex, dimension( its:ite, kts:kte, jts:jte, 1:nbin_o ) :: & !for gocart - refindx0, refindx_core0, refindx_shell0 -! complex, dimension( 1:nbin_o, kts:kte) :: & -! refindx_col, refindx_core_col, refindx_shell_col - - complex, dimension( its:ite, kts:kte, jts:jte, 1:nbin_o,1:nspint) :: & - swrefindx, swrefindx_core, swrefindx_shell - complex, dimension( 1:nbin_o, kts:kte,1:nspint) :: & - swrefindx_col, swrefindx_core_col, swrefindx_shell_col - complex, dimension( 1:nbin_o, kts:kte) :: & - swrefindx_col1, swrefindx_core_col1, swrefindx_shell_col1 - complex, dimension( its:ite, kts:kte, jts:jte, 1:nbin_o,1:nlwbands) :: & - lwrefindx, lwrefindx_core, lwrefindx_shell - complex, dimension( 1:nbin_o, kts:kte,1:nlwbands) :: & - lwrefindx_col, lwrefindx_core_col, lwrefindx_shell_col - -! complex, dimension( its:ite, kts:kte, jts:jte, 1:nbin_o ) :: & -! refindx, refindx_core, refindx_shell -! complex, dimension( 1:nbin_o, kts:kte) :: & -! refindx_col, refindx_core_col, refindx_shell_col - real, dimension( kts:kte ) :: dz -! - integer ns,i,j,iclm, jclm, k, isize - integer option_method, option_mie - real, dimension( nspint, kts:kte ) :: & - swsizeaer,swextaer,swwaer,swgaer,swtauaer,swbscoef -! sizeaer,extaer,waer,gaer,tauaer,bscoef - real, dimension( 16 , kts:kte ) :: & - lwtauaer,lwextaer - real, dimension( nspint, kts:kte ) :: & - l2, l3, l4, l5, l6, l7 - real refr - real fv,vsum - integer, dimension( its:ite, jts:jte ) :: iprt - complex aa, bb -! save :: sizeaer,extaer,waer,gaer,tauaer,bscoef -! save :: l2,l3,l4,l5,l6,l7 -!---------------------------------------------------------------------------------- -! -! chem_select: SELECT CASE(config_flags%chem_opt) -! -! CASE (RADM2SORG, RADM2SORG_AQ, RADM2SORG_KPP, & -! RACMSORG_AQ, RACMSORG_KPP) -! call optical_prep_modal(nbin_o, chem, alt, & -! h2oai, h2oaj, refindx, radius_wet, number_bin, & -! radius_core, refindx_core, refindx_shell, & -! ids,ide, jds,jde, kds,kde, & -! ims,ime, jms,jme, kms,kme, & -! its,ite, jts,jte, kts,kte ) -! CASE (CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, & -! CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ) -! call optical_prep_sectional(nbin_o, chem, alt, & -! refindx, radius_wet, number_bin, & -! radius_core, refindx_core, refindx_shell, & -! ids,ide, jds,jde, kds,kde, & -! ims,ime, jms,jme, kms,kme, & -! its,ite, jts,jte, kts,kte ) -! CASE (GOCART_SIMPLE) - iprt=0 -! iprt(1,8487)=1 -! print *,'in optical',p_vash_4 - do j = jts, jte - do i = its, ite -! vsum = 0. -! do k = kts, kte -! vsum=vsum+chem(i,k,j,p_vash_4) -! enddo -! if(vsum.gt.50.)then -! iprt(i,j)=1 -! print *,'1',i,j,vsum -! endif -! vsum = 0. -! do k = kts, kte -! vsum=vsum+chem(i,k,j,p_oc1) -! enddo -! if(vsum.gt.10.)then -! iprt(i,j)=3 -! print *,'3',i,j,vsum -! endif -! if(j.eq.18050)then -! iprt(i,j)=1 -! do k = kts, 40 -! chem(i,k,j,p_oc1)=10. -! enddo -! endif -! vsum = 0. -! do k = kts, kte -! vsum=vsum+chem(i,k,j,p_sulf)*4.e3 -! enddo -! if(vsum.gt.10.)then -! iprt(i,j)=2 -! print *,'2',i,j,vsum -! endif - enddo - enddo -! call optical_prep_gocart(iprt,nbin_o, chem, alt,relhum, & -! refindx, radius_wet, number_bin, & -! radius_core, refindx_core, refindx_shell, & -! chem_opt,num_chem,ids,ide, jds,jde, kds,kde, & -! ims,ime, jms,jme, kms,kme, & -! its,ite, jts,jte, kts,kte ) - call optical_prep_gocart(iprt,nbin_o, chem, alt,relhum, & - radius_core,radius_wet, number_bin, & - swrefindx,swrefindx_core, swrefindx_shell, & - lwrefindx,lwrefindx_core, lwrefindx_shell, & - chem_opt,num_chem,ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - -! END SELECT chem_select - do jclm = jts, jte - do iclm = its, ite - do k = kts, kte - dz(k) = dz8w(iclm, k, jclm) ! cell depth (m) - if(jclm.eq.10)write(0,*)k,dz(k),dz8w(iclm, k, jclm) - end do - do k = kts, kte - do isize = 1, nbin_o - number_bin_col(isize,k) = number_bin(iclm,k,jclm,isize) - radius_wet_col(isize,k) = radius_wet(iclm,k,jclm,isize) -! refindx_col(isize,k) = refindx(iclm,k,jclm,isize) -! refr=real(refindx_col(isize,k)) - swrefindx_col(isize,k,:) = swrefindx(iclm,k,jclm,isize,:) - swrefindx_col1(isize,k) = swrefindx(iclm,k,jclm,isize,3) ! at 600 nm - lwrefindx_col(isize,k,:) = lwrefindx(iclm,k,jclm,isize,:) - radius_core_col(isize,k) = radius_core(iclm,k,jclm,isize) - -! refindx_core_col(isize,k) = refindx_core(iclm,k,jclm,isize) -! refindx_shell_col(isize,k) = refindx_shell(iclm,k,jclm,isize) - swrefindx_core_col(isize,k,:) = swrefindx_core(iclm,k,jclm,isize,:) - swrefindx_shell_col(isize,k,:) = swrefindx_shell(iclm,k,jclm,isize,:) - swrefindx_core_col1(isize,k) = swrefindx_core(iclm,k,jclm,isize,3) - swrefindx_shell_col1(isize,k) = swrefindx_shell(iclm,k,jclm,isize,3) - lwrefindx_core_col(isize,k,:) = lwrefindx_core(iclm,k,jclm,isize,:) - lwrefindx_shell_col(isize,k,:) = lwrefindx_shell(iclm,k,jclm,isize,:) - - -! JCB, Feb. 20, 2008: in the case of shell/core and the use of the Mie -! routine, set the refractive index of the shell used in the printout -! equal to the actual refractive index of the shell - if(option_method.eq.3.and.option_mie.eq.2) & -! refindx_col(isize,k) = refindx_shell(iclm,k,jclm,isize) ! JCB - swrefindx_col(isize,k,:) = swrefindx_shell(iclm,k,jclm,isize,:) ! JCB - swrefindx_col1(isize,k) = swrefindx_shell(iclm,k,jclm,isize,3) - -! JCB, Feb. 20, 2008: set core radius = 0 for very small cores; this -! prevents problems with full-blown Mie calculations that do not deal -! well with very small cores. For very small cores, the amount of -! absorption is negligible, and therefore setting the core radius to zero -! has virtually no effect on calculated optical properties - if(radius_wet_col(isize,k) < 1e-20) then - radius_core_col(isize,k)=0.0 - else if(radius_core_col(isize,k)/radius_wet_col(isize,k)**3.le.0.0001) then - radius_core_col(isize,k)=0.0 ! JCB - end if - enddo - enddo - - if (option_method .eq. 2) then - do k = kts, kte - do isize = 1, nbin_o - do ns=1,nspint - fv = (radius_core_col(isize,k)/radius_wet_col(isize,k))**3 ! volume fraction -! aa=(refindx_core_col(isize,k)**2+2.0*refindx_shell(iclm,k,jclm,isize)**2) -! bb=fv*(refindx_core_col(isize,k)**2-refindx_shell(iclm,k,jclm,isize)**2) -! refindx_col(isize,k)= refindx_shell(iclm,k,jclm,isize)*sqrt((aa+2.0*bb)/(aa-bb)) -! refr=real(refindx_col(isize,k)) - aa=(swrefindx_core_col(isize,k,ns)**2+2.0*swrefindx_shell(iclm,k,jclm,isize,ns)**2) - bb=fv*(swrefindx_core_col(isize,k,ns)**2-swrefindx_shell(iclm,k,jclm,isize,ns)**2) - swrefindx_col(isize,k,ns)= swrefindx_shell(iclm,k,jclm,isize,ns)*sqrt((aa+2.0*bb)/(aa-bb)) - if (ns==3) then - swrefindx_col1(isize,k)= swrefindx_shell(iclm,k,jclm,isize,ns)*sqrt((aa+2.0*bb)/(aa-bb)) - endif - enddo - enddo - enddo - endif - - if (option_method .le. 2) then - do k = kts, kte - do isize = 1, nbin_o - radius_core_col(isize,k) = 0.0 -! refindx_core_col(isize,k) = cmplx(0.0,0.0) - swrefindx_core_col(isize,k,:) = cmplx(0.0,0.0) - swrefindx_core_col1(isize,k) = cmplx(0.0,0.0) - enddo - enddo - endif -! -!!$ if(id.eq.1.and.iclm.eq.84.and.jclm.eq.52) then -!!$ print*,'jdf printout 1' -!!$ do isize = 1, nbin_o -!!$ write(*,888) isize,number_bin_col(isize,1), & -!!$ radius_wet_col(isize,1),radius_core_col(isize,1), & -!!$ real(refindx_col(isize,1)), & -!!$ imag(refindx_col(isize,1)), & -!!$ real(refindx_core_col(isize,1)), & -!!$ imag(refindx_core_col(isize,1)),dz(1) -!!$ enddo -!!$ endif -!!$ if(id.eq.2.and.iclm.eq.59.and.jclm.eq.63) then -!!$ print*,'jdf printout 2' -!!$ do isize = 1, nbin_o -!!$ write(*,888) isize,number_bin_col(isize,1), & -!!$ radius_wet_col(isize,1),radius_core_col(isize,1), & -!!$ real(refindx_col(isize,1)), & -!!$ imag(refindx_col(isize,1)), & -!!$ real(refindx_core_col(isize,1)), & -!!$ imag(refindx_core_col(isize,1)),dz(1) -!!$ enddo -!!$ endif -!!$ 888 format(i3,9e12.5) -! -! - if (option_mie .eq. 1) then - call mieaer(1, iclm, jclm, nbin_o, & -! number_bin_col, radius_wet_col, refindx_col, & - number_bin_col, radius_wet_col,swrefindx_col, & - lwrefindx_col, & - dz, curr_secs, kts, kte, & -! sizeaer, extaer, waer, gaer, tauaer, & - swsizeaer,swextaer,swwaer,swgaer,swtauaer, & - lwextaer,lwtauaer, & - l2, l3, l4, l5, l6, l7,swbscoef ) - endif - if (option_mie .ge. 2 .and. option_method .le. 2) then - call mieaer_sc(1, iclm, jclm, nbin_o, & -! number_bin_col, radius_wet_col, refindx_col, & -! radius_core_col, refindx_core_col, & - number_bin_col, radius_wet_col, swrefindx_col1, & - radius_core_col, swrefindx_core_col1, & - dz, curr_secs, kte, & -! sizeaer, extaer, waer, gaer, tauaer, & -! l2, l3, l4, l5, l6, l7, bscoef ) - swsizeaer, swextaer, swwaer, swgaer, swtauaer, & - l2, l3, l4, l5, l6, l7, swbscoef ) - endif - if (option_mie .ge. 2 .and. option_method .eq. 3) then - call mieaer_sc(1, iclm, jclm, nbin_o, & -! number_bin_col, radius_wet_col, refindx_shell_col, & -! radius_core_col, refindx_core_col, & -! dz, curr_secs, kte, & -! sizeaer, extaer, waer, gaer, tauaer, & -! l2, l3, l4, l5, l6, l7, bscoef ) - number_bin_col, radius_wet_col, swrefindx_shell_col1, & - radius_core_col, swrefindx_core_col1, & - dz, curr_secs, kte, & - swsizeaer, swextaer, swwaer, swgaer, swtauaer, & - l2, l3, l4, l5, l6, l7, swbscoef ) - endif -! - do k=kts,kte -! if(iprt(iclm,jclm).eq.1)then -! print *,'k,tauae1-3 = ',k,tauaer(1,k),tauaer(2,k),tauaer(3,k) -! endif - tauaersw(iclm,k,jclm,:) = swtauaer(:,k) - gaersw(iclm,k,jclm,:) = swgaer(:,k) - waersw(iclm,k,jclm,:) = swwaer(:,k) - bscoefsw(iclm,k,jclm,:) = swbscoef(:,k) - l2aer(iclm,k,jclm,:) = l2(:,k) - l3aer(iclm,k,jclm,:) = l3(:,k) - l4aer(iclm,k,jclm,:) = l4(:,k) - l5aer(iclm,k,jclm,:) = l5(:,k) - l6aer(iclm,k,jclm,:) = l6(:,k) - l7aer(iclm,k,jclm,:) = l7(:,k) - tauaerlw(iclm,k,jclm,1:nlwbands) = lwtauaer(1:nlwbands,k) - enddo -!!$ if(id.eq.1.and.iclm.eq.84.and.jclm.eq.52) then -!!$ write(*,889) sizeaer(1,1),sizeaer(2,1),sizeaer(3,1),sizeaer(4,1) -!!$ write(*,889) extaer(1,1),extaer(2,1),extaer(3,1),extaer(4,1) -!!$ write(*,889) waer(1,1),waer(2,1),waer(3,1),waer(4,1) -!!$ write(*,889) gaer(1,1),gaer(2,1),gaer(3,1),gaer(4,1) -!!$ write(*,889) tauaer(1,1),tauaer(2,1),tauaer(3,1),tauaer(4,1) -!!$ write(*,889) bscoef(1,1),bscoef(2,1),bscoef(3,1),bscoef(4,1) -!!$ write(*,889) l2(1,1),l2(2,1),l2(3,1),l2(4,1) -!!$ write(*,889) l3(1,1),l3(2,1),l3(3,1),l3(4,1) -!!$ write(*,889) l4(1,1),l4(2,1),l4(3,1),l4(4,1) -!!$ write(*,889) l5(1,1),l5(2,1),l5(3,1),l5(4,1) -!!$ write(*,889) l6(1,1),l6(2,1),l6(3,1),l6(4,1) -!!$ write(*,889) l7(1,1),l7(2,1),l7(3,1),l7(4,1) -!!$ endif -!!$ if(id.eq.2.and.iclm.eq.59.and.jclm.eq.63) then -!!$ write(*,889) sizeaer(1,1),sizeaer(2,1),sizeaer(3,1),sizeaer(4,1) -!!$ write(*,889) extaer(1,1),extaer(2,1),extaer(3,1),extaer(4,1) -!!$ write(*,889) waer(1,1),waer(2,1),waer(3,1),waer(4,1) -!!$ write(*,889) gaer(1,1),gaer(2,1),gaer(3,1),gaer(4,1) -!!$ write(*,889) tauaer(1,1),tauaer(2,1),tauaer(3,1),tauaer(4,1) -!!$ write(*,889) bscoef(1,1),bscoef(2,1),bscoef(3,1),bscoef(4,1) -!!$ write(*,889) l2(1,1),l2(2,1),l2(3,1),l2(4,1) -!!$ write(*,889) l3(1,1),l3(2,1),l3(3,1),l3(4,1) -!!$ write(*,889) l4(1,1),l4(2,1),l4(3,1),l4(4,1) -!!$ write(*,889) l5(1,1),l5(2,1),l5(3,1),l5(4,1) -!!$ write(*,889) l6(1,1),l6(2,1),l6(3,1),l6(4,1) -!!$ write(*,889) l7(1,1),l7(2,1),l7(3,1),l7(4,1) -!!$ endif -!!$ 889 format(4e12.5) - enddo - enddo -! - return -! - end subroutine optical_averaging -! -!---------------------------------------------------------------------------------- -! 9/21/09, SAM a modification of optical_prep_modal subroutine for GOCART aerosol model - -! SAM 7/18/09 - Modal parameters for OC1 (hydrophobic) OC2 (hydrophylic), BC1,BC2, -! and sulfate - just use dginia (meters) and sginia from module_data_sorgam. -! Not using accumulation mode from d'Almedia 1991 Table 7.1 and 7.2 global model -! -! This subroutine computes volume-averaged refractive index and wet radius needed -! by the mie calculations. Aerosol number is also passed into the mie calculations -! in terms of other units. -! -! - - subroutine optical_prep_gocart(iprt,nbin_o, chem, alt,relhum, & - radius_core,radius_wet, number_bin, & - swrefindx,swrefindx_core, swrefindx_shell, & - lwrefindx,lwrefindx_core, lwrefindx_shell, & - chem_opt,num_chem,ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) -! -! USE module_configure -! USE module_model_constants - USE module_data_sorgam - USE module_data_gocart_seas - USE module_data_gocart_chem, only: oc_mfac,nh4_mfac -! USE module_data_mosaic_asect, only: hygro_msa_aer -! real*8, DIMENSION (4), PARAMETER :: ra(4)=(/1.d-1,5.d-1,1.5d0,5.0d0/) -! real*8, DIMENSION (4), PARAMETER :: rb(4)=(/5.d-1,1.5d0,5.d0,1.d1/) -! real*8, DIMENSION (4), PARAMETER :: den_seas(4)=(/2.2d3,2.2d3,2.2d3,2.2d3/) -! real*8, DIMENSION (4), PARAMETER :: reff_seas(4)=(/0.30D-6,1.00D-6,3.25D-6,7.50D-6/) - USE module_data_gocart_dust, only: ndust, reff_dust, den_dust -! real*8, DIMENSION (5), PARAMETER :: den_dust(5)=(/2500.,2650.,2650.,2650.,2650./) -! real*8, DIMENSION (5), PARAMETER :: reff_dust(5)=(/0.73D-6,1.4D-6,2.4D-6,4.5D-6,8.0D-6/) - real*8, DIMENSION (4), PARAMETER :: den_ash(4)=(/2500.,2500.,2500.,2500. /) - real*8, DIMENSION (4), PARAMETER :: reff_ash(4)=(/ 11.719D-6,&! - 05.859D-6,&! - 02.930D-6,&! - 00.975D-6 /)! 3.9 um -! - INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte, nbin_o - INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme,num_chem - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde,chem_opt - integer, dimension( its:ite, jts:jte ) :: iprt - - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & - INTENT(IN ) :: chem - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & - INTENT(IN ) :: alt,relhum - REAL, DIMENSION( its:ite, kts:kte, jts:jte, 1:nbin_o), & - INTENT(OUT ) :: & - radius_wet, number_bin, radius_core -! COMPLEX, DIMENSION( its:ite, kts:kte, jts:jte, 1:nbin_o), & -! INTENT(OUT ) :: & -! refindx, refindx_core, refindx_shell - COMPLEX, DIMENSION( its:ite, kts:kte, jts:jte,1:nbin_o,nswbands), & - INTENT(OUT ) :: swrefindx, swrefindx_core, swrefindx_shell - COMPLEX, DIMENSION( its:ite, kts:kte, jts:jte,1:nbin_o,nlwbands), & - INTENT(OUT ) :: lwrefindx, lwrefindx_core, lwrefindx_shell -! -! local variables -! - integer i, j, k, l, m, n, isize, itype, iphase - complex ref_index_lvcite , ref_index_nh4hso4, & - ref_index_nh4msa , ref_index_nh4no3 , ref_index_nh4cl , & - ref_index_nano3 , ref_index_na2so4, & - ref_index_na3hso4, ref_index_nahso4 , ref_index_namsa, & - ref_index_caso4 , ref_index_camsa2 , ref_index_cano3, & - ref_index_cacl2 , ref_index_caco3 , ref_index_h2so4, & - ref_index_hhso4 , ref_index_hno3 , ref_index_hcl, & - ref_index_msa , ref_index_bc, & - ref_index_oin , ref_index_aro1 , ref_index_aro2, & - ref_index_alk1 , ref_index_ole1 , ref_index_api1, & - ref_index_api2 , ref_index_lim1 , ref_index_lim2, & - ri_dum , ri_ave_a - COMPLEX, DIMENSION(nswbands) :: & ! now only 5 aerosols have wave-dependent refr - swref_index_oc , swref_index_dust , swref_index_nh4so4, swref_index_nacl,swref_index_h2o - COMPLEX, DIMENSION(nlwbands) :: & ! now only 5 aerosols have wave-dependent refr - lwref_index_oc , lwref_index_dust , lwref_index_nh4so4, lwref_index_nacl,lwref_index_h2o - real dens_so4 , dens_no3 , dens_cl , dens_msa , dens_co3 , & - dens_nh4 , dens_na , dens_ca , dens_oin , dens_oc , & - dens_bc , dens_aro1 , dens_aro2 , dens_alk1 , dens_ole1, & - dens_api1 , dens_api2 , dens_lim1 , dens_lim2 , dens_h2o , & - dens_dust - real mass_so4 , mass_no3 , mass_cl , mass_msa , mass_co3 , & - mass_nh4 , mass_na , mass_ca , mass_oin , mass_oc , & - mass_bc , mass_aro1 , mass_aro2 , mass_alk1 , mass_ole1, & - mass_api1 , mass_api2 , mass_lim1 , mass_lim2 , mass_h2o, & - mass_dust - real mass_so4i , mass_no3i , mass_cli , mass_msai , mass_co3i, & - mass_nh4i , mass_nai , mass_cai , mass_oini , mass_oci , & - mass_bci , mass_aro1i, mass_aro2i, mass_alk1i, mass_ole1i, & - mass_ba1i , mass_ba2i, mass_ba3i , mass_ba4i , mass_pai, & - mass_h2oi , mass_dusti - real mass_so4j , mass_no3j , mass_clj , mass_msaj , mass_co3j, & - mass_nh4j , mass_naj , mass_caj , mass_oinj , mass_ocj , & - mass_bcj , mass_aro1j, mass_aro2j, mass_alk1j, mass_ole1j, & - mass_ba1j , mass_ba2j, mass_ba3j , mass_ba4j , mass_paj, & - mass_h2oj , mass_dustj - real mass_antha, mass_seas, mass_soil - real vol_so4 , vol_no3 , vol_cl , vol_msa , vol_co3 , & - vol_nh4 , vol_na , vol_ca , vol_oin , vol_oc , & - vol_bc , vol_aro1 , vol_aro2 , vol_alk1 , vol_ole1 , & - vol_api1 , vol_api2 , vol_lim1 , vol_lim2 , vol_h2o , & - vol_dust - real conv1a, conv1b, conv1sulf - real mass_dry_a, mass_wet_a, vol_dry_a , vol_wet_a , vol_shell, & - dp_dry_a , dp_wet_a , num_a , dp_bc_a - real ifac, jfac, cfac - integer ns - real dgnum_um,drydens,duma,dlo_um,dhi_um,dgmin,sixpi,ss1,ss2,ss3,dtemp - integer iflag - real, dimension(1:nbin_o) :: xnum_secti,xnum_sectj,xnum_sectc - real, dimension(1:nbin_o) :: xmas_secti,xmas_sectj,xmas_sectc - real, dimension(1:nbin_o) :: xdia_um, xdia_cm - REAL, PARAMETER :: FRAC2Aitken=0.25 ! Fraction of modal mass in Aitken mode - applied globally to each species - -! 7/21/09 SAM variables needed to convert GOCART sectional dust and seasalt to MOZAIC sections - real dgnum, dhi, dlo, xlo, xhi, dxbin, relh_frc - real dlo_sectm(nbin_o), dhi_sectm(nbin_o) - integer, parameter :: nbin_omoz=8 - real, save :: seasfrc_goc8bin(4,nbin_omoz) ! GOCART seasalt size distibution - mass fracs in MOSAIC 8-bins - real, save :: dustfrc_goc8bin(ndust,nbin_omoz) ! GOCART dust size distibution - mass fracs in MOSAIC 8-bins - real, save :: ashfrc_goc8bin(4,nbin_omoz) ! ash size distibution - real mass_bc1 , mass_bc2 , vol_bc2 , mass_bc1j , mass_bc2j, & - mass_bc1i , mass_bc2i , vol_soil - real*8 dlogoc, dhigoc - integer istop,pdust - integer, save :: kcall - data kcall / 0 / - -! -! real sginin,sginia,sginic from module_data_sorgam.F -! -! Mass from modal distribution is divided into individual sections before -! being passed back into the Mie routine. -! * currently use the same size bins as 8 default MOSAIC size bins -! * dlo_um and dhi_um define the lower and upper bounds of individual sections -! used to compute optical properties -! * sigmas for 3 modes taken from module_sorgam_data.F -! * these parameters are needed by sect02 that is called later -! * sginin=1.7, sginia=2.0, sginic=2.5 -! - sixpi=6.0/3.14159265359 - dlo_um=0.0390625 - dhi_um=10.0 - drydens=1.8 - iflag=2 - duma=1.0 - dgmin=1.0e-07 ! in (cm) - dtemp=dlo_um - do isize=1,nbin_o - xdia_um(isize)=(dtemp+dtemp*2.0)/2.0 - dtemp=dtemp*2.0 - enddo - if (kcall .eq. 0) then -! 7/21/09 SAM calculate sectional contributions from GOCART seasalt and dust - dlo = dlo_um*1.0e-6 - dhi = dhi_um*1.0e-6 - xlo = log( dlo ) - xhi = log( dhi ) - dxbin = (xhi - xlo)/nbin_o - do n = 1, nbin_o - dlo_sectm(n) = exp( xlo + dxbin*(n-1) ) - dhi_sectm(n) = exp( xlo + dxbin*n ) - end do -! real, save :: seasfrc_goc8bin(4,nbin_o) ! GOCART seasalt size distibution - mass fracs in MOSAIC 8-bins -! real, save :: dustfrc_goc8bin(ndust,nbin_o) ! GOCART dust size distibution - mass fracs in MOSAIC 8-bins -! USE module_data_gocart_seas -! real*8, DIMENSION (4), PARAMETER :: ra(4)=(/1.d-1,5.d-1,1.5d0,5.0d0/) -! real*8, DIMENSION (4), PARAMETER :: rb(4)=(/5.d-1,1.5d0,5.d0,1.d1/) -! real*8, DIMENSION (4), PARAMETER :: den_seas(4)=(/2.2d3,2.2d3,2.2d3,2.2d3/) -! real*8, DIMENSION (4), PARAMETER :: reff_seas(4)=(/0.30D-6,1.00D-6,3.25D-6,7.50D-6/) -! USE module_data_gocart_dust, only: ndust, reff_dust, den_dust -! real*8, DIMENSION (5), PARAMETER :: den_dust(5)=(/2500.,2650.,2650.,2650.,2650./) -! real*8, DIMENSION (5), PARAMETER :: reff_dust(5)=(/0.73D-6,1.4D-6,2.4D-6,4.5D-6,8.0D-6/) -! Seasalt bin mass fractions - seasfrc_goc8bin=0. -! WRITE(*,*)'Seasalt mass fractions' -! WRITE(*,*)' ',' ',(dlo_sectm(n),n=1,nbin_o) -! WRITE(*,*)' ',' ',(dhi_sectm(n),n=1,nbin_o) - do m =1, 4 ! loop over seasalt size bins - dlogoc = ra(m)*2.E-6 ! low diameter limit (m) - dhigoc = rb(m)*2.E-6 ! hi diameter limit (m) - do n = 1, nbin_o - seasfrc_goc8bin(m,n)=max(DBLE(0.),min(DBLE(dhi_sectm(n)),dhigoc)- & - max(dlogoc,DBLE(dlo_sectm(n))) )/(dhigoc-dlogoc) - end do -! WRITE(*,*)m,dlogoc,dhigoc,(seasfrc_goc8bin(m,n),n=1,nbin_o) - end do -! Dust bin mass fractions -! WRITE(*,*)'Dust mass fractions' -! WRITE(*,*)' ',' ',(dlo_sectm(n),n=1,nbin_o) -! WRITE(*,*)' ',' ',(dhi_sectm(n),n=1,nbin_o) - dustfrc_goc8bin=0. - dlogoc=0.46*2.E-6 ! Begin lower dust bin, makes upper limit diam 20 micron diameter - do m =1, ndust ! loop over dust size bins - dhigoc = 2.*2.*reff_dust(m)-dlogoc ! hi diameter limit (m) - do n = 1, nbin_o - dustfrc_goc8bin(m,n)=max(DBLE(0.),min(DBLE(dhi_sectm(n)),dhigoc)- & - max(dlogoc,DBLE(dlo_sectm(n))) )/(dhigoc-dlogoc) -! 7/25/11 Add in missing GOCART mass according to SAMUM 2006 Saharan experiment, Wienzierl et al., Tellus, 2008 -! Mass fraction for mass below 0.92 um diam (.135)is average of high and low envelope of size distributions -! relative to 0.92 - 3.6 micron GOCART mass bins (bin_1 + bin_2). Binning fractions for MOZAIC bins are -! average of high and low envelope size distribution data fractions. - if(m.le.2.and.n.eq.2)dustfrc_goc8bin(m,n)=dustfrc_goc8bin(m,n)+.135*.059 - if(m.le.2.and.n.eq.3)dustfrc_goc8bin(m,n)=dustfrc_goc8bin(m,n)+.135*.167 - if(m.le.2.and.n.eq.4)dustfrc_goc8bin(m,n)=dustfrc_goc8bin(m,n)+.135*.315 - if(m.le.2.and.n.eq.5)dustfrc_goc8bin(m,n)=dustfrc_goc8bin(m,n)+.135*.458 - - end do -! WRITE(*,*)m,dlogoc,dhigoc,(dustfrc_goc8bin(m,n),n=1,nbin_o) - dlogoc=dhigoc - end do - kcall=kcall+1 -! ISTOP=1 -! IF(ISTOP.EQ.1)THEN -! STOP -! ENDIF - endif -! -! Define refractive indicies -! * assume na and cl are the same as nacl -! * assume so4, no3, and nh4 are the same as nh4no3 -! * assume ca and co3 are the same as caco3 -! * assume msa is just msa -! Further work: -! * to be more precise, need to compute electrolytes to apportion -! so4, no3, nh4, na, cl, msa, ca, co3 among various componds -! as was done previously in module_mosaic_therm.F -! - do ns = 1, nswbands - swref_index_nh4so4(ns) = cmplx(refrsw_sulf(ns),refisw_sulf(ns)) - swref_index_oc(ns) = cmplx(refrsw_oc(ns),refisw_oc(ns)) - swref_index_dust(ns) = cmplx(refrsw_dust(ns),refisw_dust(ns)) - swref_index_nacl(ns) = cmplx(refrsw_seas(ns),refisw_seas(ns)) - swref_index_h2o(ns) = cmplx(refrwsw(ns),refiwsw(ns)) - enddo - do ns = 1, nlwbands - lwref_index_nh4so4(ns) = cmplx(refrlw_sulf(ns),refilw_sulf(ns)) - lwref_index_oc(ns) = cmplx(refrlw_oc(ns),refilw_oc(ns)) - lwref_index_dust(ns) = cmplx(refrlw_dust(ns),refilw_dust(ns)) - lwref_index_nacl(ns) = cmplx(refrlw_seas(ns),refilw_seas(ns)) - lwref_index_h2o(ns) = cmplx(refrwlw(ns),refiwlw(ns)) - enddo -! ref_index_nh4so4 = cmplx(1.52,0.) - ref_index_lvcite = cmplx(1.50,0.) - ref_index_nh4hso4= cmplx(1.47,0.) - ref_index_nh4msa = cmplx(1.50,0.) ! assumed - ref_index_nh4no3 = cmplx(1.50,0.) - ref_index_nh4cl = cmplx(1.50,0.) -! ref_index_nacl = cmplx(1.45,0.) - ref_index_nano3 = cmplx(1.50,0.) - ref_index_na2so4 = cmplx(1.50,0.) - ref_index_na3hso4= cmplx(1.50,0.) - ref_index_nahso4 = cmplx(1.50,0.) - ref_index_namsa = cmplx(1.50,0.) ! assumed - ref_index_caso4 = cmplx(1.56,0.006) - ref_index_camsa2 = cmplx(1.56,0.006) ! assumed - ref_index_cano3 = cmplx(1.56,0.006) - ref_index_cacl2 = cmplx(1.52,0.006) - ref_index_caco3 = cmplx(1.68,0.006) - ref_index_h2so4 = cmplx(1.43,0.) - ref_index_hhso4 = cmplx(1.43,0.) - ref_index_hno3 = cmplx(1.50,0.) - ref_index_hcl = cmplx(1.50,0.) - ref_index_msa = cmplx(1.43,0.) ! assumed -! ref_index_oc = cmplx(1.45,0.) ! JCB, Feb. 20, 2008: no complex part? -! JCB, Feb. 20, 2008: set the refractive index of BC equal to the -! midpoint of ranges given in Bond and Bergstrom, Light absorption by -! carboneceous particles: an investigative review 2006, Aerosol Sci. -! and Tech., 40:27-67. -! ref_index_bc = cmplx(1.82,0.74) old value - ref_index_bc = cmplx(1.85,0.71) - ref_index_oin = cmplx(1.55,0.006) ! JCB, Feb. 20, 2008: "other inorganics" - ref_index_aro1 = cmplx(1.45,0.) - ref_index_aro2 = cmplx(1.45,0.) - ref_index_alk1 = cmplx(1.45,0.) - ref_index_ole1 = cmplx(1.45,0.) - ref_index_api1 = cmplx(1.45,0.) - ref_index_api2 = cmplx(1.45,0.) - ref_index_lim1 = cmplx(1.45,0.) - ref_index_lim2 = cmplx(1.45,0.) -! ref_index_h2o = cmplx(1.33,0.) -! -! densities in g/cc -! - dens_so4 = 1.8 ! used - dens_no3 = 1.8 ! used - dens_cl = 2.2 ! used - dens_msa = 1.8 ! used - dens_co3 = 2.6 ! used - dens_nh4 = 1.8 ! used - dens_na = 2.2 ! used - dens_ca = 2.6 ! used - dens_oin = 2.6 ! used - dens_dust = 2.6 ! used - dens_oc = 1.0 ! used -! JCB, Feb. 20, 2008: the density of BC is updated to reflect values -! published by Bond and Bergstrom, Light absorption by carboneceous -! particles: an investigative review 2006, Aerosol Sci. and Tech., 40:27-67. -! dens_bc = 1.7 ! used, old value - dens_bc = 1.8 ! midpoint of Bond and Bergstrom value - dens_aro1 = 1.0 - dens_aro2 = 1.0 - dens_alk1 = 1.0 - dens_ole1 = 1.0 - dens_api1 = 1.0 - dens_api2 = 1.0 - dens_lim1 = 1.0 - dens_lim2 = 1.0 - dens_h2o = 1.0 -! - swrefindx=0.0 - lwrefindx=0.0 - radius_wet=0.0 - number_bin=0.0 - radius_core=0.0 - swrefindx_core=0.0 - swrefindx_shell=0.0 - lwrefindx_core=0.0 - lwrefindx_shell=0.0 -! -! units: -! * mass - g/cc(air) -! * number - #/cc(air) -! * volume - cc(air)/cc(air) -! * diameter - cm -! - do j = jts, jte - do k = kts, kte - do i = its, ite - mass_so4i = 0.0 - mass_so4j = 0.0 - mass_no3i = 0.0 - mass_no3j = 0.0 - mass_nh4i = 0.0 - mass_nh4j = 0.0 - mass_oini = 0.0 - mass_oinj = 0.0 - mass_dusti = 0.0 - mass_dustj = 0.0 - mass_aro1i = 0.0 - mass_aro1j = 0.0 - mass_aro2i = 0.0 - mass_aro2j = 0.0 - mass_alk1i = 0.0 - mass_alk1j = 0.0 - mass_ole1i = 0.0 - mass_ole1j = 0.0 - mass_ba1i = 0.0 - mass_ba1j = 0.0 - mass_ba2i = 0.0 - mass_ba2j = 0.0 - mass_ba3i = 0.0 - mass_ba3j = 0.0 - mass_ba4i = 0.0 - mass_ba4j = 0.0 - mass_pai = 0.0 - mass_paj = 0.0 - mass_oci = 0.0 - mass_ocj = 0.0 - mass_bci = 0.0 - mass_bcj = 0.0 - mass_bc1i = 0.0 - mass_bc1j = 0.0 - mass_bc2i = 0.0 - mass_bc2j = 0.0 - mass_cai = 0.0 - mass_caj = 0.0 - mass_co3i = 0.0 - mass_co3j = 0.0 - mass_nai = 0.0 - mass_naj = 0.0 - mass_cli = 0.0 - mass_clj = 0.0 - mass_msai = 0.0 - mass_msaj = 0.0 - mass_nai = 0.0 - mass_naj = 0.0 - mass_cli = 0.0 - mass_clj = 0.0 - mass_h2oi = 0.0 - mass_h2oj = 0.0 - mass_antha = 0.0 - mass_seas = 0.0 - mass_soil = 0.0 - mass_cl = 0.0 - mass_na = 0.0 - mass_msa = 0.0 - -! convert ug / kg dry air to g / cc air - conv1a = (1.0/alt(i,k,j)) * 1.0e-12 -! convert # / kg dry air to # / cc air - conv1b = (1.0/alt(i,k,j)) * 1.0e-6 -! convert ppmv sulfate (and coincidentally MSA) to g / cc air - conv1sulf = (1.0/alt(i,k,j)) * 1.0e-9 * 96./28.97 - -! Accumulation mode... -! SAM 7/18/09 - Put fraction of GOCART sulfate, organic, black carbon masses into modal accumulation mode - mass_oinj = (1.-FRAC2Aitken)*chem(i,k,j,p_p25)*conv1a - mass_so4j= (1.-FRAC2Aitken)*chem(i,k,j,p_sulf)*conv1sulf - mass_nh4j= (1.-FRAC2Aitken)*chem(i,k,j,p_sulf)*conv1sulf*(nh4_mfac-1.) - mass_aro1j= (1.-FRAC2Aitken)*chem(i,k,j,p_oc1)*conv1a*oc_mfac - mass_aro2j= (1.-FRAC2Aitken)*chem(i,k,j,p_oc2)*conv1a*oc_mfac - mass_bc1j= (1.-FRAC2Aitken)*chem(i,k,j,p_bc1)*conv1a - mass_bc2j= (1.-FRAC2Aitken)*chem(i,k,j,p_bc2)*conv1a - mass_bcj= mass_bc1j + mass_bc2j - mass_msaj= (1.-FRAC2Aitken)*chem(i,k,j,p_msa)*conv1sulf - mass_antha= chem(i,k,j,p_p10)*conv1a - -! Aitken mode... -! SAM 7/18/09 - Put fraction of GOCART sulfate, organic, black carbon masses into modal Aitken mode - mass_oini = FRAC2Aitken*chem(i,k,j,p_p25)*conv1a - mass_so4i= FRAC2Aitken*chem(i,k,j,p_sulf)*conv1sulf - mass_nh4i= FRAC2Aitken*chem(i,k,j,p_sulf)*conv1sulf*(nh4_mfac-1.) - mass_aro1i= FRAC2Aitken*chem(i,k,j,p_oc1)*conv1a*oc_mfac - mass_aro2i= FRAC2Aitken*chem(i,k,j,p_oc2)*conv1a*oc_mfac - mass_bc1i= FRAC2Aitken*chem(i,k,j,p_bc1)*conv1a - mass_bc2i= FRAC2Aitken*chem(i,k,j,p_bc2)*conv1a - mass_bci= mass_bc1i + mass_bc2i - mass_msai= FRAC2Aitken*chem(i,k,j,p_msa)*conv1sulf - -! -! Now divide mass into sections which is done by sect02: -! * xmas_secti is for aiken mode -! * xmas_sectj is for accumulation mode -! * xmas_sectc is for coarse mode -! * sect02 expects input in um -! * pass in generic mass of 1.0 just to get a percentage distribution of mass among bins -! -!! ss1=alog(sginin) -!! ss2=exp(ss1*ss1*36.0/8.0) -!! ss3=(sixpi*vol_ai/(num_ai*ss2))**0.3333333 -!! dgnum_um=amax1(dgmin,ss3)*1.0e+04 - dgnum_um=dginin*1.E6 - call sect02(dgnum_um,sginin,drydens,iflag,duma,nbin_o,dlo_um,dhi_um, & - xnum_secti,xmas_secti) -!! ss1=alog(sginia) -!! ss2=exp(ss1*ss1*36.0/8.0) -!! ss3=(sixpi*vol_aj/(num_aj*ss2))**0.3333333 -!! dgnum_um=amax1(dgmin,ss3)*1.0e+04 - dgnum_um=dginia*1.E6 - call sect02(dgnum_um,sginia,drydens,iflag,duma,nbin_o,dlo_um,dhi_um, & - xnum_sectj,xmas_sectj) -!! ss1=alog(sginic) -!! ss2=exp(ss1*ss1*36.0/8.0) -!! ss3=(sixpi*vol_ac/(num_ac*ss2))**0.3333333 - dgnum_um=dginic*1.E6 - call sect02(dgnum_um,sginic,drydens,iflag,duma,nbin_o,dlo_um,dhi_um, & - xnum_sectc,xmas_sectc) - - do isize = 1, nbin_o - xdia_cm(isize)=xdia_um(isize)*1.0e-04 - mass_so4 = mass_so4i*xmas_secti(isize) + mass_so4j*xmas_sectj(isize) - mass_no3 = mass_no3i*xmas_secti(isize) + mass_no3j*xmas_sectj(isize) - mass_nh4 = mass_nh4i*xmas_secti(isize) + mass_nh4j*xmas_sectj(isize) - mass_oin = mass_oini*xmas_secti(isize) + mass_oinj*xmas_sectj(isize) + & - mass_soil*xmas_sectc(isize) + mass_antha*xmas_sectc(isize) -! GOCART OC mass_aero1 is hydrophobic, mass_aero2 is hydrophylic - mass_aro1 = mass_aro1j*xmas_sectj(isize) + mass_aro1i*xmas_secti(isize) - mass_aro2 = mass_aro2j*xmas_sectj(isize) + mass_aro2i*xmas_secti(isize) - mass_oc = mass_aro1 + mass_aro2 -! GOCART BC mass_bc1 is hydrophobic, mass_bc2 is hydrophylic - mass_bc1 = mass_bc1i*xmas_secti(isize) + mass_bc1j*xmas_sectj(isize) - mass_bc2 = mass_bc2i*xmas_secti(isize) + mass_bc2j*xmas_sectj(isize) - mass_bc = mass_bc1 + mass_bc2 -! Add in seasalt and dust from GOCART sectional distributions - n = 0 - mass_seas = 0.0 - do m =p_seas_1, max(p_seas_1,p_seas_3) ! loop over seasalt size bins less than 10 um diam - n = n+1 - mass_seas=mass_seas+seasfrc_goc8bin(n,isize)*chem(i,k,j,m) - end do - n = 0 - mass_soil = 0.0 - pdust=p_dust_1+ndust-2 -! -! for gocart very light, the dust bins have beenn changed. dust1 is old dust1 + -! some of old dust2, while new dust2 is old dust3.....change this later -! - if(chem_opt == 304 .or. chem_opt == 316 .or. chem_opt == 317) pdust=p_dust_2 - do m =p_dust_1, pdust ! loop over dust size bins less than 10 um diam - n = n+1 - mass_soil=mass_soil+dustfrc_goc8bin(n,isize)*chem(i,k,j,m) - end do -! volcanic ash - if(chem_opt == 317) then - n = 0 - do m =p_vash_4, p_vash_1,-1 - n = n+1 - mass_soil=mass_soil+ashfrc_goc8bin(n,isize)*chem(i,k,j,m) -! if(iprt(i,j).eq.1)then -! write(6,*)'k,isize,p_vash_4,m = ',k,isize,p_vash_4,m -! write(6,*)'p_dust_1,pdust,n', p_dust_1,pdust,n -! write(6,*) chem(i,k,j,m),mass_soil,ashfrc_goc8bin(n,isize) -! endif - end do - endif - - mass_cl=mass_seas*conv1a*22.9897/58.4428 - mass_na=mass_seas*conv1a*35.4270/58.4428 - mass_soil=mass_soil*conv1a -! mass_h2o = 0.0 ! testing purposes only - vol_so4 = mass_so4 / dens_so4 - vol_no3 = mass_no3 / dens_no3 - vol_nh4 = mass_nh4 / dens_nh4 - vol_oin = mass_oin / dens_oin - vol_oc = mass_oc / dens_oc - vol_aro2 = mass_aro2 / dens_oc - vol_bc = mass_bc / dens_bc - vol_bc2 = mass_bc2 / dens_bc - vol_na = mass_na / dens_na - vol_cl = mass_cl / dens_cl - vol_soil = mass_soil / dens_dust - vol_msa = 0. -! vol_h2o = mass_h2o / dens_h2o -! 7/23/09 SAM calculate vol_h2o from kappas in Petters and Kreidenweis ACP, 2007, vol. 7, 1961-1971. -! Their kappas are the hygroscopicities used in Abdul-Razzak and Ghan, 2004, JGR, V105, p. 6837-6844. -! These kappas are defined in module_data_sorgam and module_data_mosaic_asect. -! Note that hygroscopicities are at 298K and specific surface tension - further refinement could -! include temperature dependence in Petters and Kreidenweis -! Also, for hygroscopic BC part, assume kappa of OC (how can BC be hydrophylic?) - relh_frc=amin1(.9,relhum(i,k,j)) !0.8 ! Put in fractional relative humidity, max of .9, here - vol_h2o = vol_so4*hygro_so4_aer + vol_aro2*hygro_oc_aer + & - vol_nh4*hygro_nh4_aer + & - vol_cl*hygro_cl_aer + vol_na*hygro_na_aer + vol_msa*hygro_msa_aer + & - vol_oin*hygro_oin_aer + vol_bc2*hygro_oc_aer + vol_soil*hygro_dust_aer - vol_h2o = relh_frc*vol_h2o/(1.-relh_frc) - mass_h2o = vol_h2o*dens_h2o - mass_dry_a = mass_so4 + mass_no3 + mass_nh4 + mass_oin + & - mass_oc + mass_bc + mass_na + mass_cl + & - mass_soil - mass_wet_a = mass_dry_a + mass_h2o - vol_dry_a = vol_so4 + vol_no3 + vol_nh4 + vol_oin + & - vol_oc + vol_bc + vol_na + vol_cl + & - vol_soil - vol_wet_a = vol_dry_a + vol_h2o - vol_shell = vol_wet_a - vol_bc - num_a = vol_wet_a / (0.52359877*xdia_cm(isize)*xdia_cm(isize)*xdia_cm(isize)) - - !shortwave - do ns=1,nswbands - ri_dum = (0.0,0.0) - ri_dum = (swref_index_nh4so4(ns) * mass_so4 / dens_so4) + & - (ref_index_nh4no3 * mass_no3 / dens_no3) + & - (ref_index_nh4no3 * mass_nh4 / dens_nh4) + & - (ref_index_oin * mass_oin / dens_oin) + & - (swref_index_dust(ns) * mass_soil / dens_dust) + & - (swref_index_oc(ns) * mass_oc / dens_oc) + & - (ref_index_bc * mass_bc / dens_bc) + & - (swref_index_nacl(ns) * mass_na / dens_na) + & - (swref_index_nacl(ns) * mass_cl / dens_cl) + & - (ref_index_msa * mass_msa / dens_msa) + & - (swref_index_h2o(ns) * mass_h2o / dens_h2o) -! -! for some reason MADE/SORGAM occasionally produces zero aerosols so -! need to add a check here to avoid divide by zero -! - IF(num_a .lt. 1.0e-20 .or. vol_wet_a .lt. 1.0e-20) then - dp_dry_a = xdia_cm(isize) - dp_wet_a = xdia_cm(isize) - dp_bc_a = xdia_cm(isize) - ri_ave_a = 0.0 - ri_dum = 0.0 - else - dp_dry_a = (1.90985*vol_dry_a/num_a)**0.3333333 - dp_wet_a = (1.90985*vol_wet_a/num_a)**0.3333333 - dp_bc_a = (1.90985*vol_bc/num_a)**0.3333333 - ri_ave_a = ri_dum/vol_wet_a - ri_dum = (swref_index_nh4so4(ns) * mass_so4 / dens_so4) + & - (ref_index_nh4no3 * mass_no3 / dens_no3) + & - (ref_index_nh4no3 * mass_nh4 / dens_nh4) + & - (ref_index_msa * mass_msa / dens_msa) + & - (ref_index_oin * mass_oin / dens_oin) + & - (swref_index_dust(ns) * mass_soil / dens_dust) + & - (swref_index_oc(ns) * mass_oc / dens_oc) + & - (swref_index_nacl(ns) * mass_na / dens_na) + & - (swref_index_nacl(ns) * mass_cl / dens_cl) + & - (swref_index_h2o(ns) * mass_h2o / dens_h2o) - endif - if(dp_wet_a/2.0 .lt. dlo_um*1.0e-4/2.0) then - swrefindx(i,k,j,isize,ns) = (1.5,0.0) - radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0 - number_bin(i,k,j,isize) =num_a - radius_core(i,k,j,isize) =0.0 - swrefindx_core(i,k,j,isize,ns) = ref_index_bc - swrefindx_shell(i,k,j,isize,ns) = ref_index_oin - elseif(vol_shell .lt. 1.0e-20) then - swrefindx(i,k,j,isize,ns) = (1.5,0.0) - radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0 - number_bin(i,k,j,isize) =num_a - radius_core(i,k,j,isize) =0.0 - swrefindx_core(i,k,j,isize,ns) = ref_index_bc - swrefindx_shell(i,k,j,isize,ns) = ref_index_oin - else - swrefindx(i,k,j,isize,ns) =ri_ave_a - radius_wet(i,k,j,isize) =dp_wet_a/2.0 - number_bin(i,k,j,isize) =num_a - radius_core(i,k,j,isize) =dp_bc_a/2.0 - swrefindx_core(i,k,j,isize,ns) =ref_index_bc - swrefindx_shell(i,k,j,isize,ns) =ri_dum/vol_shell - endif - enddo ! ns shortwave - - !longwave - do ns=1,nlwbands - ri_dum = (0.0,0.0) - ri_dum = (lwref_index_nh4so4(ns) * mass_so4 / dens_so4) + & - (ref_index_nh4no3 * mass_no3 / dens_no3) + & - (ref_index_nh4no3 * mass_nh4 / dens_nh4) + & - (ref_index_oin * mass_oin / dens_oin) + & - (lwref_index_dust(ns) * mass_soil / dens_dust) + & - (lwref_index_oc(ns) * mass_oc / dens_oc) + & - (ref_index_bc * mass_bc / dens_bc) + & - (lwref_index_nacl(ns) * mass_na / dens_na) + & - (lwref_index_nacl(ns) * mass_cl / dens_cl) + & - (ref_index_msa * mass_msa / dens_msa) + & - (lwref_index_h2o(ns) * mass_h2o / dens_h2o) -! -! for some reason MADE/SORGAM occasionally produces zero aerosols so -! need to add a check here to avoid divide by zero -! - IF(num_a .lt. 1.0e-20 .or. vol_wet_a .lt. 1.0e-20) then - dp_dry_a = xdia_cm(isize) - dp_wet_a = xdia_cm(isize) - dp_bc_a = xdia_cm(isize) - ri_ave_a = 0.0 - ri_dum = 0.0 - else - dp_dry_a = (1.90985*vol_dry_a/num_a)**0.3333333 - dp_wet_a = (1.90985*vol_wet_a/num_a)**0.3333333 - dp_bc_a = (1.90985*vol_bc/num_a)**0.3333333 - ri_ave_a = ri_dum/vol_wet_a - ri_dum = (lwref_index_nh4so4(ns) * mass_so4 / dens_so4) + & - (ref_index_nh4no3 * mass_no3 / dens_no3) + & - (ref_index_nh4no3 * mass_nh4 / dens_nh4) + & - (ref_index_oin * mass_oin / dens_oin) + & - (lwref_index_dust(ns) * mass_oin / dens_dust) + & - (lwref_index_oc(ns) * mass_oc / dens_oc) + & - (lwref_index_nacl(ns) * mass_na / dens_na) + & - (lwref_index_nacl(ns) * mass_cl / dens_cl) + & - (lwref_index_h2o(ns) * mass_h2o / dens_h2o) - endif - if(dp_wet_a/2.0 .lt. dlo_um*1.0e-4/2.0) then - lwrefindx(i,k,j,isize,ns) = (1.5,0.0) - radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0 - number_bin(i,k,j,isize) =num_a - radius_core(i,k,j,isize) =0.0 - lwrefindx_core(i,k,j,isize,ns) = ref_index_bc - lwrefindx_shell(i,k,j,isize,ns) = ref_index_oin - elseif(vol_shell .lt. 1.0e-20) then - lwrefindx(i,k,j,isize,ns) = (1.5,0.0) - radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0 - number_bin(i,k,j,isize) =num_a - radius_core(i,k,j,isize) =0.0 - lwrefindx_core(i,k,j,isize,ns) = ref_index_bc - lwrefindx_shell(i,k,j,isize,ns) = ref_index_oin - else - lwrefindx(i,k,j,isize,ns) =ri_ave_a - radius_wet(i,k,j,isize) =dp_wet_a/2.0 - number_bin(i,k,j,isize) =num_a - radius_core(i,k,j,isize) =dp_bc_a/2.0 - lwrefindx_core(i,k,j,isize,ns) =ref_index_bc - lwrefindx_shell(i,k,j,isize,ns) =ri_dum/vol_shell - endif - enddo ! ns longwave -! refr=real(refindx(i,k,j,isize)) - enddo !isize - enddo !i - enddo !j - enddo !k - - return - - end subroutine optical_prep_gocart - -!below is the detail calculation for MIE code -!czhao - -! -!*********************************************************************** -! <1.> subr mieaer -!czhao made changes for doing both shortwave and longwave optical properties -! Purpose: calculate aerosol optical depth, single scattering albedo, -! asymmetry factor, extinction, Legendre coefficients, and average aerosol -! size. parameterizes aerosol coefficients using chebychev polynomials -! requires double precision on 32-bit machines -! uses Wiscombe's (1979) mie scattering code -! INPUT -! id -- grid id number -! iclm, jclm -- i,j of grid column being processed -! nbin_a -- number of bins -! number_bin(nbin_a,kmaxd) -- number density in layer, #/cm^3 -! radius_wet(nbin_a,kmaxd) -- wet radius, cm -! refindx(nbin_a,kmaxd) --volume averaged complex index of refraction -! dz -- depth of individual cells in column, m -! curr_secs -- time from start of run, sec -! lpar -- number of grid cells in vertical (via module_fastj_cmnh) -! kmaxd -- predefined maximum allowed levels from module_data_mosaic_other -! passed here via module_fastj_cmnh -! OUTPUT: saved in module_fastj_cmnmie -! real tauaer ! aerosol optical depth -! waer ! aerosol single scattering albedo -! gaer ! aerosol asymmetery factor -! extaer ! aerosol extinction -! l2,l3,l4,l5,l6,l7 ! Legendre coefficients, numbered 0,1,2,...... -! sizeaer ! average wet radius -! bscoef ! aerosol backscatter coefficient with units km-1 * steradian -1 JCB 2007/02/01 -!*********************************************************************** - subroutine mieaer( & - id, iclm, jclm, nbin_a, & - number_bin_col, radius_wet_col, swrefindx_col, & - lwrefindx_col, & - dz, curr_secs, kts,kte, & -! sizeaer,extaer,waer,gaer,tauaer,l2,l3,l4,l5,l6,l7,bscoef) ! added bscoef JCB 2007/02/01 - swsizeaer,swextaer,swwaer,swgaer,swtauaer,lwextaer,lwtauaer, & - l2,l3,l4,l5,l6,l7,swbscoef) ! added bscoef JCB 2007/02/01 - -! USE module_data_mosaic_other, only : kmaxd -! USE module_data_mosaic_therm, ONLY: nbin_a_maxd - USE module_peg_util, only: peg_error_fatal, peg_message - - IMPLICIT NONE - -! integer,parameter :: nspint = 4 ! Num of spectral for FAST-J - integer, intent(in) :: kts,kte - integer, intent(in) :: id, iclm, jclm, nbin_a - real(kind=8), intent(in) :: curr_secs - - real, dimension (1:nspint,kts:kte),intent(out) :: swsizeaer,swextaer,swwaer,swgaer,swtauaer - real, dimension (1:nlwbands,kts:kte),intent(out) :: lwextaer,lwtauaer - real, dimension (1:nspint,kts:kte),intent(out) :: l2,l3,l4,l5,l6,l7 - real, dimension (1:nspint,kts:kte),intent(out) :: swbscoef !JCB 2007/02/01 - real, intent(in), dimension(1:nbin_a, kts:kte) :: number_bin_col - real, intent(inout), dimension(1:nbin_a,kts:kte) :: radius_wet_col - complex, intent(in),dimension(1:nbin_a,kts:kte,nspint) :: swrefindx_col - complex, intent(in),dimension(1:nbin_a,kts:kte,nlwbands) :: lwrefindx_col - real, intent(in),dimension(kts:kte) :: dz - - !fitting variables - integer ltype ! total number of indicies of refraction - parameter (ltype = 1) ! bracket refractive indices based on information from Rahul, 2002/11/07 - integer nrefr,nrefi,nr,ni - save nrefr,nrefi - complex*16 sforw,sback,tforw(2),tback(2) - real*8 pmom(0:7,1) - logical, save :: ini_fit ! initial mie fit only for the first time step - data ini_fit/.true./ - ! nsiz = number of wet particle sizes - integer, parameter :: nsiz=200,nlog=30 !,ncoef=5 - real p2(nsiz),p3(nsiz),p4(nsiz),p5(nsiz) - real p6(nsiz),p7(nsiz) - logical perfct,anyang,prnt(2) - real*8 xmu(1) - data xmu/1./,anyang/.false./ - data prnt/.false.,.false./ - integer numang,nmom,ipolzn,momdim - data numang/0/ - complex*16 s1(1),s2(1) - real*8 mimcut - data perfct/.false./,mimcut/0.0/ - data nmom/7/,ipolzn/0/,momdim/7/ - integer n - real*8 thesize ! 2 pi radpart / waveleng = size parameter - real*8 qext(nsiz) ! array of extinction efficiencies - real*8 qsca(nsiz) ! array of scattering efficiencies - real*8 gqsc(nsiz) ! array of asymmetry factor * scattering efficiency - real qext4(nsiz) ! extinction, real*4 - real qsca4(nsiz) ! extinction, real*4 - real qabs4(nsiz) ! extinction, real*4 - real asymm(nsiz) ! array of asymmetry factor - real sb2(nsiz) ! JCB 2007/02/01 - 4*abs(sback)^2/(size parameter)^2 backscattering efficiency - complex*16 crefin,crefd,crefw - save crefw - real, save :: rmin,rmax ! min, max aerosol size bin - real bma,bpa - real refr ! real part of refractive index - real refi ! imaginary part of refractive index - real refrmin ! minimum of real part of refractive index - real refrmax ! maximum of real part of refractive index - real refimin ! minimum of imag part of refractive index - real refimax ! maximum of imag part of refractive index - real drefr ! increment in real part of refractive index - real drefi ! increment in imag part of refractive index - complex specrefndx(ltype) ! refractivr indices - integer, parameter :: naerosols=5 - - !parameterization variables - real weighte, weights,weighta - real x - real thesum ! for normalizing things - real sizem ! size in microns - integer m, j, nc, klevel - real pext ! parameterized specific extinction (cm2/g) - real pscat !scattering cross section - real pabs ! parameterized specific extinction (cm2/g) - real pasm ! parameterized asymmetry factor - real ppmom2 ! 2 Lengendre expansion coefficient (numbered 0,1,2,...) - real ppmom3 ! 3 ... - real ppmom4 ! 4 ... - real ppmom5 ! 5 ... - real ppmom6 ! 6 ... - real ppmom7 ! 7 ... - real sback2 ! JCB 2007/02/01 sback*conjg(sback) - real cext(ncoef),casm(ncoef),cpmom2(ncoef),cabs(ncoef) - real cscat(ncoef) ! JCB 2004/02/09 - real cpmom3(ncoef),cpmom4(ncoef),cpmom5(ncoef) - real cpmom6(ncoef),cpmom7(ncoef) - real cpsback2p(ncoef) ! JCB 2007/02/09 - backscatter - integer itab,jtab - real ttab,utab - real, save :: xrmin,xrmax,xr - real rs(nsiz) ! surface mode radius (cm) - real xrad ! normalized aerosol radius - real ch(ncoef) ! chebychev polynomial - - - !others - integer i,k,l,ns - real pie,third - integer ibin - character*150 msg - integer kcallmieaer,kcallmieaer2 - - -#if (defined(CHEM_DBG_I) && defined(CHEM_DBG_J) && defined(CHEM_DBG_K)) -!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!ec diagnostics -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!ec run_out.25 has aerosol physical parameter info for bins 1-8 -!ec and vertical cells 1 to kmaxd. - if (iclm .eq. CHEM_DBG_I) then - if (jclm .eq. CHEM_DBG_J) then -! initial entry - if (kcallmieaer2 .eq. 0) then - write(*,9099)iclm, jclm - 9099 format('for cell i = ', i3, 2x, 'j = ', i3) - write(*,9100) - 9100 format( & - 'curr_secs', 3x, 'i', 3x, 'j', 3x,'k', 3x, & - 'ibin', 3x, & - 'refindx_col(ibin,k)', 3x, & - 'radius_wet_col(ibin,k)', 3x, & - 'number_bin_col(ibin,k)' & - ) - end if -!ec output for run_out.25 - do k = 1,kte - do ibin = 1, nbin_a - write(*, 9120) & - curr_secs,iclm, jclm, k, ibin, & - swrefindx_col(ibin,k), & - radius_wet_col(ibin,k), & - number_bin_col(ibin,k) -9120 format( i7,3(2x,i4),2x,i4, 4x, 4(e14.6,2x)) - end do - end do - kcallmieaer2 = kcallmieaer2 + 1 - end if - end if -!ec end print of aerosol physical parameter diagnostics -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -#endif -! -! assign fast-J wavelength, these values are in cm -! wavmid(1)=0.30e-4 -! wavmid(2)=0.40e-4 -! wavmid(3)=0.60e-4 -! wavmid(4)=0.999e-04 -! - pie=4.*atan(1.) - third=1./3. - rmin=rmmin - rmax=rmmax - -!###################################################################### -!initial fitting to mie calculation based on Ghan et al. 2002 and 2007 -!##################################################################### - if(ini_fit)then - ini_fit=.false. - - !---------------------------------------------------------------------- - !shortwave - !--------------------------------------------------------------------- - ! wavelength loop - do 200 ns=1,nspint - ! parameterize aerosol radiative properties in terms of - ! relative humidity, surface mode wet radius, aerosol species, - ! and wavelength - ! first find min,max of real and imaginary parts of refractive index - ! real and imaginary parts of water refractive index - - !crefw=cmplx(1.33,0.0) - crefwsw(ns)=cmplx(refrwsw(ns),refiwsw(ns)) - refrmin=real(crefwsw(ns)) - refrmax=real(crefwsw(ns)) - !change imaginary part of the refractive index from positive to negative - refimin=-imag(crefwsw(ns)) - refimax=-imag(crefwsw(ns)) - !specrefndx(1)=cmplx(1.85,-0.71) ! max values from Bond and Bergstrom -! do i=1,ltype ! loop over all possible refractive indices -! refrmin=amin1(refrmin,real(specrefndx(ltype))) -! refrmax=amax1(refrmax,real(specrefndx(ltype))) -! refimin=amin1(refimin,aimag(specrefndx(ltype))) -! refimax=amax1(refimax,aimag(specrefndx(ltype))) -! enddo -! aerosol species loop (dust, BC, OC, Sea Salt, and Sulfate) - - do l=1,naerosols - if (l==1) refr=refrsw_dust(ns) - if (l==1) refi=-refisw_dust(ns) - if (l==2) refr=refrsw_bc(ns) - if (l==2) refi=-refisw_bc(ns) - if (l==3) refr=refrsw_oc(ns) - if (l==3) refi=-refisw_oc(ns) - if (l==4) refr=refrsw_seas(ns) - if (l==4) refi=-refisw_seas(ns) - if (l==5) refr=refrsw_sulf(ns) - if (l==5) refi=-refisw_sulf(ns) - refrmin=min(refrmin,refr) - refrmax=max(refrmax,refr) - refimin=min(refimin,refi) - refimax=max(refimax,refi) - enddo - - drefr=(refrmax-refrmin) - if(drefr.gt.1.e-4)then - nrefr=prefr - drefr=drefr/(nrefr-1) - else - nrefr=1 - endif - - drefi=(refimax-refimin) - if(drefi.gt.1.e-4)then - nrefi=prefi - drefi=drefi/(nrefi-1) - else - nrefi=1 - endif - - bma=0.5*alog(rmax/rmin) ! JCB - bpa=0.5*alog(rmax*rmin) ! JCB - - do 120 nr=1,nrefr - do 120 ni=1,nrefi - - refrtabsw(nr,ns)=refrmin+(nr-1)*drefr - refitabsw(ni,ns)=refimin/0.2*(0.2**real(ni)) !slightly different from Ghan and Zaveri - if(ni.eq.nrefi) refitabsw(ni,ns)=-1.0e-20 ! JCB change - crefd=cmplx(refrtabsw(nr,ns),refitabsw(ni,ns)) - -! mie calculations of optical efficiencies - do n=1,nsiz - xr=cos(pie*(float(n)-0.5)/float(nsiz)) - rs(n)=exp(xr*bma+bpa) - -! size parameter and weighted refractive index - thesize=2.*pie*rs(n)/wavmidsw(ns) - thesize=min(thesize,10000.d0) - - call miev0(thesize,crefd,perfct,mimcut,anyang, & - numang,xmu,nmom,ipolzn,momdim,prnt, & - qext(n),qsca(n),gqsc(n),pmom,sforw,sback,s1, & - s2,tforw,tback ) - qext4(n)=qext(n) - qsca4(n)=min(qsca(n),qext(n)) - qabs4(n)=qext4(n)-qsca4(n) - qabs4(n)=max(qabs4(n),1.e-20) ! avoid 0 - asymm(n)=gqsc(n)/qsca4(n) ! assume always greater than zero -! coefficients of phase function expansion; note modification by JCB of miev0 coefficients - p2(n)=pmom(2,1)/pmom(0,1)*5.0 - p3(n)=pmom(3,1)/pmom(0,1)*7.0 - p4(n)=pmom(4,1)/pmom(0,1)*9.0 - p5(n)=pmom(5,1)/pmom(0,1)*11.0 - p6(n)=pmom(6,1)/pmom(0,1)*13.0 - p7(n)=pmom(7,1)/pmom(0,1)*15.0 -! backscattering efficiency, Bohren and Huffman, page 122 -! as stated by Bohren and Huffman, this is 4*pie times what is should be -! may need to be smoothed - a very rough function - for the time being we won't apply smoothing -! and let the integration over the size distribution be the smoothing - sb2(n)=4.0*sback*dconjg(sback)/(thesize*thesize) ! JCB 2007/02/01 - enddo -! - call fitcurv(rs,qext4,extpsw(1,nr,ni,ns),ncoef,nsiz) - call fitcurv(rs,qabs4,abspsw(1,nr,ni,ns),ncoef,nsiz) - call fitcurv(rs,qsca4,ascatpsw(1,nr,ni,ns),ncoef,nsiz) ! scattering efficiency - call fitcurv(rs,asymm,asmpsw(1,nr,ni,ns),ncoef,nsiz) - call fitcurv(rs,sb2,sbackpsw(1,nr,ni,ns),ncoef,nsiz) ! backscattering efficiency - call fitcurv_nolog(rs,p2,pmom2psw(1,nr,ni,ns),ncoef,nsiz) - call fitcurv_nolog(rs,p3,pmom3psw(1,nr,ni,ns),ncoef,nsiz) - call fitcurv_nolog(rs,p4,pmom4psw(1,nr,ni,ns),ncoef,nsiz) - call fitcurv_nolog(rs,p5,pmom5psw(1,nr,ni,ns),ncoef,nsiz) - call fitcurv_nolog(rs,p6,pmom6psw(1,nr,ni,ns),ncoef,nsiz) - call fitcurv_nolog(rs,p7,pmom7psw(1,nr,ni,ns),ncoef,nsiz) - - 120 continue - 200 continue ! ns for shortwave - - - !---------------------------------------------------------------------- - !longwave - !--------------------------------------------------------------------- - ! wavelength loop - do 201 ns=1,nlwbands - !wavelength for longwave 1/cm --> cm - wavmidlw(ns) = 0.5*(1./wavenumber1_longwave(ns) + 1./wavenumber2_longwave(ns)) - - crefwlw(ns)=cmplx(refrwlw(ns),refiwlw(ns)) - refrmin=real(crefwlw(ns)) - refrmax=real(crefwlw(ns)) - refimin=-imag(crefwlw(ns)) - refimax=-imag(crefwlw(ns)) - - !aerosol species loop (dust, BC, OC, Sea Salt, and Sulfate) - do l=1,naerosols - if (l==1) refr=refrlw_dust(ns) - if (l==1) refi=-refilw_dust(ns) - if (l==2) refr=refrlw_bc(ns) - if (l==2) refi=-refilw_bc(ns) - if (l==3) refr=refrlw_oc(ns) - if (l==3) refi=-refilw_oc(ns) - if (l==4) refr=refrlw_seas(ns) - if (l==4) refi=-refilw_seas(ns) - if (l==5) refr=refrlw_sulf(ns) - if (l==5) refi=-refilw_sulf(ns) - refrmin=min(refrmin,refr) - refrmax=max(refrmax,refr) - refimin=min(refimin,refi) - refimax=max(refimax,refi) - enddo - - drefr=(refrmax-refrmin) - if(drefr.gt.1.e-4)then - nrefr=prefr - drefr=drefr/(nrefr-1) - else - nrefr=1 - endif - - drefi=(refimax-refimin) - if(drefi.gt.1.e-4)then - nrefi=prefi - drefi=drefi/(nrefi-1) - else - nrefi=1 - endif - - bma=0.5*alog(rmax/rmin) ! JCB - bpa=0.5*alog(rmax*rmin) ! JCB - - do 121 nr=1,nrefr - do 121 ni=1,nrefi - - refrtablw(nr,ns)=refrmin+(nr-1)*drefr - refitablw(ni,ns)=refimin/0.2*(0.2**real(ni)) !slightly different from Ghan and Zaveri - if(ni.eq.nrefi) refitablw(nrefi,ns)=-1.0e-21 ! JCB change - crefd=cmplx(refrtablw(nr,ns),refitablw(ni,ns)) - -! mie calculations of optical efficiencies - do n=1,nsiz - xr=cos(pie*(float(n)-0.5)/float(nsiz)) - rs(n)=exp(xr*bma+bpa) - -! size parameter and weighted refractive index - thesize=2.*pie*rs(n)/wavmidlw(ns) - thesize=min(thesize,10000.d0) - - call miev0(thesize,crefd,perfct,mimcut,anyang, & - numang,xmu,nmom,ipolzn,momdim,prnt, & - qext(n),qsca(n),gqsc(n),pmom,sforw,sback,s1, & - s2,tforw,tback ) - qext4(n)=qext(n) - qext4(n)=max(qext4(n),1.e-20) ! avoid 0 - qsca4(n)=min(qsca(n),qext(n)) - qsca4(n)=max(qsca4(n),1.e-20) ! avoid 0 - qabs4(n)=qext4(n)-qsca4(n) - qabs4(n)=max(qabs4(n),1.e-20) ! avoid 0 - asymm(n)=gqsc(n)/qsca4(n) ! assume always greater than zero - enddo -! - !if (nr==1.and.ni==1) then - !endif - call fitcurv(rs,qext4,extplw(1,nr,ni,ns),ncoef,nsiz) - call fitcurv(rs,qabs4,absplw(1,nr,ni,ns),ncoef,nsiz) - call fitcurv(rs,qsca4,ascatplw(1,nr,ni,ns),ncoef,nsiz) ! scattering efficiency - call fitcurv(rs,asymm,asmplw(1,nr,ni,ns),ncoef,nsiz) - 121 continue - 201 continue ! ns for longwave - - - endif !ini_fit - - - xrmin=alog(rmin) - xrmax=alog(rmax) - -!###################################################################### -!parameterization of mie calculation for shortwave -!##################################################################### - -! begin level loop - do 2000 klevel=1,kte -! sum densities for normalization - thesum=0.0 - do m=1,nbin_a - thesum=thesum+number_bin_col(m,klevel) - enddo -! Begin shortwave spectral loop - do 1000 ns=1,nswbands - -! aerosol optical properties - swtauaer(ns,klevel)=0. - swwaer(ns,klevel)=0. - swgaer(ns,klevel)=0. - swsizeaer(ns,klevel)=0.0 - swextaer(ns,klevel)=0.0 - l2(ns,klevel)=0.0 - l3(ns,klevel)=0.0 - l4(ns,klevel)=0.0 - l5(ns,klevel)=0.0 - l6(ns,klevel)=0.0 - l7(ns,klevel)=0.0 - swbscoef(ns,klevel)=0.0 ! JCB 2007/02/01 - backscattering coefficient - if(thesum.le.1e-21)goto 1000 ! set everything = 0 if no aerosol !wig changed 0.0 to 1e-21, 31-Oct-2005 - -! loop over the bins - do m=1,nbin_a ! nbin_a is number of bins -! here's the size - sizem=radius_wet_col(m,klevel) ! radius in cm - - !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - !ec diagnostics - !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - ! check limits of particle size - ! rce 2004-dec-07 - use klevel in write statements - if(radius_wet_col(m,klevel).le.rmin)then - radius_wet_col(m,klevel)=rmin - write( msg, '(a, 5i4,1x, e11.4)' ) & - 'mieaer: radius_wet set to rmin,' // & - 'id,i,j,k,m,rm(m,k)', id, iclm, jclm, klevel, m, radius_wet_col(m,klevel) - call peg_message( lunerr, msg ) - endif - if(radius_wet_col(m,klevel).gt.rmax)then - radius_wet_col(m,klevel)=rmax - !only print when the number is significant - if (number_bin_col(m,klevel).ge.1.e-10) then - write( msg, '(a, 5i4,1x, 2e11.4)' ) & - 'mieaer: radius_wet set to rmax,' // & - 'id,i,j,k,m,rm(m,k),number', & - id, iclm, jclm, klevel, m, radius_wet_col(m,klevel),number_bin_col(m,klevel) - call peg_message( lunerr, msg ) - endif - endif - !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - x=alog(radius_wet_col(m,klevel)) ! radius in cm - crefin=swrefindx_col(m,klevel,ns) - refr=real(crefin) - refi=-imag(crefin) - xrad=x - thesize=2.0*pie*exp(x)/wavmidsw(ns) - ! normalize size parameter - xrad=(2*xrad-xrmax-xrmin)/(xrmax-xrmin) - - !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - !ec diagnostics - !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - ! retain this diagnostic code - if(abs(refr).gt.10.0.or.abs(refr).le.0.001)then - write ( msg, '(a,1x, e14.5)' ) & - 'mieaer /refr/ outside range 1e-3 - 10 ' // & - 'refr= ', refr - call peg_error_fatal( lunerr, msg ) - endif - if(abs(refi).gt.10.)then - write ( msg, '(a,1x, e14.5)' ) & - 'mieaer /refi/ >10 ' // & - 'refi', refi - call peg_error_fatal( lunerr, msg ) - endif - !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - -! interpolate coefficients linear in refractive index -! first call calcs itab,jtab,ttab,utab - itab=0 - call binterp(extpsw(1,1,1,ns),ncoef,nrefr,nrefi, & - refr,refi,refrtabsw(1,ns),refitabsw(1,ns),itab,jtab, & - ttab,utab,cext) - -! JCB 2004/02/09 -- new code for scattering cross section - call binterp(ascatpsw(1,1,1,ns),ncoef,nrefr,nrefi, & - refr,refi,refrtabsw(1,ns),refitabsw(1,ns),itab,jtab, & - ttab,utab,cscat) - call binterp(asmpsw(1,1,1,ns),ncoef,nrefr,nrefi, & - refr,refi,refrtabsw(1,ns),refitabsw(1,ns),itab,jtab, & - ttab,utab,casm) - call binterp(pmom2psw(1,1,1,ns),ncoef,nrefr,nrefi, & - refr,refi,refrtabsw(1,ns),refitabsw(1,ns),itab,jtab, & - ttab,utab,cpmom2) - call binterp(pmom3psw(1,1,1,ns),ncoef,nrefr,nrefi, & - refr,refi,refrtabsw(1,ns),refitabsw(1,ns),itab,jtab, & - ttab,utab,cpmom3) - call binterp(pmom4psw(1,1,1,ns),ncoef,nrefr,nrefi, & - refr,refi,refrtabsw(1,ns),refitabsw(1,ns),itab,jtab, & - ttab,utab,cpmom4) - call binterp(pmom5psw(1,1,1,ns),ncoef,nrefr,nrefi, & - refr,refi,refrtabsw(1,ns),refitabsw(1,ns),itab,jtab, & - ttab,utab,cpmom5) - call binterp(pmom6psw(1,1,1,ns),ncoef,nrefr,nrefi, & - refr,refi,refrtabsw(1,ns),refitabsw(1,ns),itab,jtab, & - ttab,utab,cpmom6) - call binterp(pmom7psw(1,1,1,ns),ncoef,nrefr,nrefi, & - refr,refi,refrtabsw(1,ns),refitabsw(1,ns),itab,jtab, & - ttab,utab,cpmom7) - call binterp(sbackpsw(1,1,1,ns),ncoef,nrefr,nrefi, & - refr,refi,refrtabsw(1,ns),refitabsw(1,ns),itab,jtab, & - ttab,utab,cpsback2p) - -! chebyshev polynomials - ch(1)=1. - ch(2)=xrad - do nc=3,ncoef - ch(nc)=2.*xrad*ch(nc-1)-ch(nc-2) - enddo -! parameterized optical properties - - pext=0.5*cext(1) - do nc=2,ncoef - pext=pext+ch(nc)*cext(nc) - enddo - pext=exp(pext) - -! JCB 2004/02/09 -- for scattering efficiency - pscat=0.5*cscat(1) - do nc=2,ncoef - pscat=pscat+ch(nc)*cscat(nc) - enddo - pscat=exp(pscat) -! - pasm=0.5*casm(1) - do nc=2,ncoef - pasm=pasm+ch(nc)*casm(nc) - enddo - pasm=exp(pasm) -! - ppmom2=0.5*cpmom2(1) - do nc=2,ncoef - ppmom2=ppmom2+ch(nc)*cpmom2(nc) - enddo - if(ppmom2.le.0.0)ppmom2=0.0 -! - ppmom3=0.5*cpmom3(1) - do nc=2,ncoef - ppmom3=ppmom3+ch(nc)*cpmom3(nc) - enddo - if(ppmom3.le.0.0)ppmom3=0.0 -! - ppmom4=0.5*cpmom4(1) - do nc=2,ncoef - ppmom4=ppmom4+ch(nc)*cpmom4(nc) - enddo - if(ppmom4.le.0.0.or.sizem.le.0.03e-04)ppmom4=0.0 -! - ppmom5=0.5*cpmom5(1) - do nc=2,ncoef - ppmom5=ppmom5+ch(nc)*cpmom5(nc) - enddo - if(ppmom5.le.0.0.or.sizem.le.0.03e-04)ppmom5=0.0 -! - ppmom6=0.5*cpmom6(1) - do nc=2,ncoef - ppmom6=ppmom6+ch(nc)*cpmom6(nc) - enddo - if(ppmom6.le.0.0.or.sizem.le.0.03e-04)ppmom6=0.0 -! - ppmom7=0.5*cpmom7(1) - do nc=2,ncoef - ppmom7=ppmom7+ch(nc)*cpmom7(nc) - enddo - if(ppmom7.le.0.0.or.sizem.le.0.03e-04)ppmom7=0.0 -! - sback2=0.5*cpsback2p(1) ! JCB 2007/02/01 - backscattering efficiency - do nc=2,ncoef - sback2=sback2+ch(nc)*cpsback2p(nc) - enddo - sback2=exp(sback2) - if(sback2.le.0.0)sback2=0.0 -! -! -! weights: - pscat=min(pscat,pext) !czhao - weighte=pext*pie*exp(x)**2 ! JCB, extinction cross section - weights=pscat*pie*exp(x)**2 ! JCB, scattering cross section - swtauaer(ns,klevel)=swtauaer(ns,klevel)+weighte*number_bin_col(m,klevel) ! must be multiplied by deltaZ -! if (iclm==30.and.jclm==49.and.klevel==2.and.m==5) then -! write(0,*) 'czhao check swtauaer calculation in MIE',ns,m,weighte,number_bin_col(m,klevel),swtauaer(ns,klevel)*dz(klevel)*100 -! print*, 'czhao check swtauaer calculation in MIE',ns,m,weighte,number_bin_col(m,klevel),swtauaer(ns,klevel)*dz(klevel)*100 -! endif - swsizeaer(ns,klevel)=swsizeaer(ns,klevel)+exp(x)*10000.0* & - number_bin_col(m,klevel) - swwaer(ns,klevel)=swwaer(ns,klevel)+weights*number_bin_col(m,klevel) !JCB - swgaer(ns,klevel)=swgaer(ns,klevel)+pasm*weights*number_bin_col(m,klevel) !JCB -! need weighting by scattering cross section ? JCB 2004/02/09 - l2(ns,klevel)=l2(ns,klevel)+weights*ppmom2*number_bin_col(m,klevel) - l3(ns,klevel)=l3(ns,klevel)+weights*ppmom3*number_bin_col(m,klevel) - l4(ns,klevel)=l4(ns,klevel)+weights*ppmom4*number_bin_col(m,klevel) - l5(ns,klevel)=l5(ns,klevel)+weights*ppmom5*number_bin_col(m,klevel) - l6(ns,klevel)=l6(ns,klevel)+weights*ppmom6*number_bin_col(m,klevel) - l7(ns,klevel)=l7(ns,klevel)+weights*ppmom7*number_bin_col(m,klevel) -! convert backscattering efficiency to backscattering coefficient, units (cm)^-1 - swbscoef(ns,klevel)=swbscoef(ns,klevel)+pie*exp(x)**2*sback2*number_bin_col(m,klevel)! backscatter - - end do ! end of nbin_a loop - -! take averages - weighted by cross section - new code JCB 2004/02/09 - swsizeaer(ns,klevel)=swsizeaer(ns,klevel)/thesum - swgaer(ns,klevel)=swgaer(ns,klevel)/swwaer(ns,klevel) ! JCB removed *3 factor 2/9/2004 -! because factor is applied in subroutine opmie, file zz01fastj_mod.f - l2(ns,klevel)=l2(ns,klevel)/swwaer(ns,klevel) - l3(ns,klevel)=l3(ns,klevel)/swwaer(ns,klevel) - l4(ns,klevel)=l4(ns,klevel)/swwaer(ns,klevel) - l5(ns,klevel)=l5(ns,klevel)/swwaer(ns,klevel) - l6(ns,klevel)=l6(ns,klevel)/swwaer(ns,klevel) - l7(ns,klevel)=l7(ns,klevel)/swwaer(ns,klevel) -! backscatter coef, divide by 4*Pie to get units of (km*ster)^-1 JCB 2007/02/01 - swbscoef(ns,klevel)=swbscoef(ns,klevel)*1.0e5 ! units are now (km)^-1 - swextaer(ns,klevel)=swtauaer(ns,klevel)*1.0e5 ! now true extincion, units (km)^-1 -! this must be last!! - swwaer(ns,klevel)=swwaer(ns,klevel)/swtauaer(ns,klevel) ! JCB - -!70 continue ! bail out if no aerosol;go on to next wavelength bin - -1000 continue ! end of wavelength loop - -2000 continue ! end of klevel loop -! -! before returning, multiply tauaer by depth of individual cells. -! tauaer is in cm-1, dz in m; multiply dz by 100 to convert from m to cm. - do ns = 1, nswbands - do klevel = 1, kte - swtauaer(ns,klevel) = swtauaer(ns,klevel) * dz(klevel)* 100. - end do - end do - -#if (defined(CHEM_DBG_I) && defined(CHEM_DBG_J) && defined(CHEM_DBG_K)) -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!ec fastj diagnostics -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - if (iclm .eq. CHEM_DBG_I) then - if (jclm .eq. CHEM_DBG_J) then -! initial entry - if (kcallmieaer .eq. 0) then - write(*,909) CHEM_DBG_I, CHEM_DBG_J - 909 format( ' for cell i = ', i3, ' j = ', i3) - write(*,910) - 910 format( & - 'curr_secs', 3x, 'i', 3x, 'j', 3x,'k', 3x, & - 'dzmfastj', 8x, & - 'tauaer(1,k)',1x, 'tauaer(2,k)',1x,'tauaer(3,k)',3x, & - 'tauaer(4,k)',5x, & - 'waer(1,k)', 7x, 'waer(2,k)', 7x,'waer(3,k)', 7x, & - 'waer(4,k)', 7x, & - 'gaer(1,k)', 7x, 'gaer(2,k)', 7x,'gaer(3,k)', 7x, & - 'gaer(4,k)', 7x, & - 'extaer(1,k)',5x, 'extaer(2,k)',5x,'extaer(3,k)',5x, & - 'extaer(4,k)',5x, & - 'sizeaer(1,k)',4x, 'sizeaer(2,k)',4x,'sizeaer(3,k)',4x, & - 'sizeaer(4,k)' ) - end if -!ec output for run_out.30 - do k = 1,kte - write(*, 912) & - curr_secs,iclm, jclm, k, & - dz(k) , & - (swtauaer(n,k), n=1,4), & - (swwaer(n,k), n=1,4), & - (swgaer(n,k), n=1,4), & - (swextaer(n,k), n=1,4), & - (swsizeaer(n,k), n=1,4) - 912 format( i7,3(2x,i4),2x,21(e14.6,2x)) - end do - kcallmieaer = kcallmieaer + 1 - end if - end if -!ec end print of fastj diagnostics -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -#endif - - -!###################################################################### -!parameterization of mie calculation for longwave -!##################################################################### - -! begin level loop - do 2001 klevel=1,kte -! sum densities for normalization - thesum=0.0 - do m=1,nbin_a - thesum=thesum+number_bin_col(m,klevel) - enddo -! Begin longwave spectral loop - do 1001 ns=1,nlwbands - -! aerosol optical properties - lwtauaer(ns,klevel)=0. - lwextaer(ns,klevel)=0.0 - if(thesum.le.1e-21)goto 1001 ! set everything = 0 if no aerosol !wig changed 0.0 to 1e-21, 31-Oct-2005 - -! loop over the bins - do m=1,nbin_a ! nbin_a is number of bins -! here's the size - sizem=radius_wet_col(m,klevel) ! radius in cm - x=alog(radius_wet_col(m,klevel)) ! radius in cm - crefin=lwrefindx_col(m,klevel,ns) - refr=real(crefin) - refi=-imag(crefin) - xrad=x - thesize=2.0*pie*exp(x)/wavmidlw(ns) - ! normalize size parameter - xrad=(2*xrad-xrmax-xrmin)/(xrmax-xrmin) - - !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - !ec diagnostics - !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - ! retain this diagnostic code - if(abs(refr).gt.10.0.or.abs(refr).le.0.001)then - write ( msg, '(a,1x, e14.5)' ) & - 'mieaer /refr/ outside range 1e-3 - 10 ' // & - 'refr= ', refr - call peg_error_fatal( lunerr, msg ) - endif - if(abs(refi).gt.10.)then - write ( msg, '(a,1x, e14.5)' ) & - 'mieaer /refi/ >10 ' // & - 'refi', refi - call peg_error_fatal( lunerr, msg ) - endif - !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - -! interpolate coefficients linear in refractive index -! first call calcs itab,jtab,ttab,utab - itab=0 - call binterp(absplw(1,1,1,ns),ncoef,nrefr,nrefi, & - refr,refi,refrtablw(1,ns),refitablw(1,ns),itab,jtab, & - ttab,utab,cabs) - -! chebyshev polynomials - ch(1)=1. - ch(2)=xrad - do nc=3,ncoef - ch(nc)=2.*xrad*ch(nc-1)-ch(nc-2) - enddo -! parameterized optical properties - pabs=0.5*cabs(1) - do nc=2,ncoef - pabs=pabs+ch(nc)*cabs(nc) - enddo - pabs=exp(pabs) - -! -! weights: - weighta=pabs*pie*exp(x)**2 ! JCB, extinction cross section - !weighta: cm2 and number_bin_col #/cm3 -> /cm - lwtauaer(ns,klevel)=lwtauaer(ns,klevel)+weighta*number_bin_col(m,klevel) ! must be multiplied by deltaZ - - end do ! end of nbin_a loop - -! take averages - weighted by cross section - new code JCB 2004/02/09 - lwextaer(ns,klevel)=lwtauaer(ns,klevel)*1.0e5 ! now true extincion, units (km)^-1 - -1001 continue ! end of wavelength loop - -2001 continue ! end of klevel loop -! -! before returning, multiply tauaer by depth of individual cells. -! tauaer is in cm-1, dz in m; multiply dz by 100 to convert from m to cm. - do ns = 1, nlwbands - do klevel = 1, kte - lwtauaer(ns,klevel) = lwtauaer(ns,klevel) * dz(klevel)* 100. - end do - end do - - return - end subroutine mieaer -!**************************************************************** - -!**************************************************************** - - subroutine fitcurv(rs,yin,coef,ncoef,maxm) - -! fit y(x) using Chebychev polynomials -! wig 7-Sep-2004: Removed dependency on pre-determined maximum -! array size and replaced with f90 array info. - - USE module_peg_util, only: peg_message - - IMPLICIT NONE -! integer nmodes, nrows, maxm, ncoef -! parameter (nmodes=500,nrows=8) - integer, intent(in) :: maxm, ncoef - -! real rs(nmodes),yin(nmodes),coef(ncoef) -! real x(nmodes),y(nmodes) - real, dimension(ncoef) :: coef - real, dimension(:) :: rs, yin - real x(size(rs)),y(size(yin)) - - integer m - real xmin, xmax - character*80 msg - -!!$ if(maxm.gt.nmodes)then -!!$ write ( msg, '(a, 1x,i6)' ) & -!!$ 'FASTJ mie nmodes too small in fitcurv, ' // & -!!$ 'maxm ', maxm -!!$! write(*,*)'nmodes too small in fitcurv',maxm -!!$ call peg_error_fatal( lunerr, msg ) -!!$ endif - - do 100 m=1,maxm - x(m)=alog(rs(m)) - y(m)=alog(yin(m)) - 100 continue - - xmin=x(1) - xmax=x(maxm) - do 110 m=1,maxm - x(m)=(2*x(m)-xmax-xmin)/(xmax-xmin) - 110 continue - - call chebft(coef,ncoef,maxm,y) - - return - end subroutine fitcurv -!************************************************************** - subroutine fitcurv_nolog(rs,yin,coef,ncoef,maxm) - -! fit y(x) using Chebychev polynomials -! wig 7-Sep-2004: Removed dependency on pre-determined maximum -! array size and replaced with f90 array info. - - USE module_peg_util, only: peg_message - IMPLICIT NONE - -! integer nmodes, nrows, maxm, ncoef -! parameter (nmodes=500,nrows=8) - integer, intent(in) :: maxm, ncoef - -! real rs(nmodes),yin(nmodes),coef(ncoef) - real, dimension(:) :: rs, yin - real, dimension(ncoef) :: coef(ncoef) - real x(size(rs)),y(size(yin)) - - integer m - real xmin, xmax - character*80 msg - -!!$ if(maxm.gt.nmodes)then -!!$ write ( msg, '(a,1x, i6)' ) & -!!$ 'FASTJ mie nmodes too small in fitcurv ' // & -!!$ 'maxm ', maxm -!!$! write(*,*)'nmodes too small in fitcurv',maxm -!!$ call peg_error_fatal( lunerr, msg ) -!!$ endif - - do 100 m=1,maxm - x(m)=alog(rs(m)) - y(m)=yin(m) ! note, no "alog" here - 100 continue - - xmin=x(1) - xmax=x(maxm) - do 110 m=1,maxm - x(m)=(2*x(m)-xmax-xmin)/(xmax-xmin) - 110 continue - - call chebft(coef,ncoef,maxm,y) - - return - end subroutine fitcurv_nolog -!************************************************************************ - subroutine chebft(c,ncoef,n,f) -! given a function f with values at zeroes x_k of Chebychef polynomial -! T_n(x), calculate coefficients c_j such that -! f(x)=sum(k=1,n) c_k t_(k-1)(y) - 0.5*c_1 -! where y=(x-0.5*(xmax+xmin))/(0.5*(xmax-xmin)) -! See Numerical Recipes, pp. 148-150. - - IMPLICIT NONE - real pi - integer ncoef, n - parameter (pi=3.14159265) - real c(ncoef),f(n) - -! local variables - real fac, thesum - integer j, k - - fac=2./n - do j=1,ncoef - thesum=0 - do k=1,n - thesum=thesum+f(k)*cos((pi*(j-1))*((k-0.5)/n)) - enddo - c(j)=fac*thesum - enddo - return - end subroutine chebft -!************************************************************************* - subroutine binterp(table,km,im,jm,x,y,xtab,ytab,ix,jy,t,u,out) - -! bilinear interpolation of table -! - implicit none - integer im,jm,km - real table(km,im,jm),xtab(im),ytab(jm),out(km) - integer i,ix,ip1,j,jy,jp1,k - real x,dx,t,y,dy,u,tu, tuc,tcu,tcuc - - if(ix.gt.0)go to 30 - if(im.gt.1)then - do i=1,im - if(x.lt.xtab(i))go to 10 - enddo - 10 ix=max0(i-1,1) - ip1=min0(ix+1,im) - dx=(xtab(ip1)-xtab(ix)) - if(abs(dx).gt.1.e-20)then - t=(x-xtab(ix))/(xtab(ix+1)-xtab(ix)) - else - t=0 - endif - else - ix=1 - ip1=1 - t=0 - endif - if(jm.gt.1)then - do j=1,jm - if(y.lt.ytab(j))go to 20 - enddo - 20 jy=max0(j-1,1) - jp1=min0(jy+1,jm) - dy=(ytab(jp1)-ytab(jy)) - if(abs(dy).gt.1.e-20)then - u=(y-ytab(jy))/dy - else - u=0 - endif - else - jy=1 - jp1=1 - u=0 - endif - 30 continue - jp1=min(jy+1,jm) - ip1=min(ix+1,im) - tu=t*u - tuc=t-tu - tcuc=1-tuc-u - tcu=u-tu - do k=1,km - out(k)=tcuc*table(k,ix,jy)+tuc*table(k,ip1,jy) & - +tu*table(k,ip1,jp1)+tcu*table(k,ix,jp1) - enddo - return - end subroutine binterp -!*************************************************************** - subroutine miev0 ( xx, crefin, perfct, mimcut, anyang, & - numang, xmu, nmom, ipolzn, momdim, prnt, & - qext, qsca, gqsc, pmom, sforw, sback, s1, & - s2, tforw, tback ) -! -! computes mie scattering and extinction efficiencies; asymmetry -! factor; forward- and backscatter amplitude; scattering -! amplitudes for incident polarization parallel and perpendicular -! to the plane of scattering, as functions of scattering angle; -! coefficients in the legendre polynomial expansions of either the -! unpolarized phase function or the polarized phase matrix; -! and some quantities needed in polarized radiative transfer. -! -! calls : biga, ckinmi, small1, small2, testmi, miprnt, -! lpcoef, errmsg -! -! i n t e r n a l v a r i a b l e s -! ----------------------------------- -! -! an,bn mie coefficients little-a-sub-n, little-b-sub-n -! ( ref. 1, eq. 16 ) -! anm1,bnm1 mie coefficients little-a-sub-(n-1), -! little-b-sub-(n-1); used in -gqsc- sum -! anp coeffs. in s+ expansion ( ref. 2, p. 1507 ) -! bnp coeffs. in s- expansion ( ref. 2, p. 1507 ) -! anpm coeffs. in s+ expansion ( ref. 2, p. 1507 ) -! when mu is replaced by - mu -! bnpm coeffs. in s- expansion ( ref. 2, p. 1507 ) -! when mu is replaced by - mu -! calcmo(k) true, calculate moments for k-th phase quantity -! (derived from -ipolzn-; used only in 'lpcoef') -! cbiga(n) bessel function ratio capital-a-sub-n (ref. 2, eq. 2) -! ( complex version ) -! cior complex index of refraction with negative -! imaginary part (van de hulst convention) -! cioriv 1 / cior -! coeff ( 2n + 1 ) / ( n ( n + 1 ) ) -! fn floating point version of index in loop performing -! mie series summation -! lita,litb(n) mie coefficients -an-, -bn-, saved in arrays for -! use in calculating legendre moments *pmom* -! maxtrm max. possible no. of terms in mie series -! mm + 1 and - 1, alternately. -! mim magnitude of imaginary refractive index -! mre real part of refractive index -! maxang max. possible value of input variable -numang- -! nangd2 (numang+1)/2 ( no. of angles in 0-90 deg; anyang=f ) -! noabs true, sphere non-absorbing (determined by -mimcut-) -! np1dn ( n + 1 ) / n -! npquan highest-numbered phase quantity for which moments are -! to be calculated (the largest digit in -ipolzn- -! if ipolzn .ne. 0) -! ntrm no. of terms in mie series -! pass1 true on first entry, false thereafter; for self-test -! pin(j) angular function little-pi-sub-n ( ref. 2, eq. 3 ) -! at j-th angle -! pinm1(j) little-pi-sub-(n-1) ( see -pin- ) at j-th angle -! psinm1 ricatti-bessel function psi-sub-(n-1), argument -xx- -! psin ricatti-bessel function psi-sub-n of argument -xx- -! ( ref. 1, p. 11 ff. ) -! rbiga(n) bessel function ratio capital-a-sub-n (ref. 2, eq. 2) -! ( real version, for when imag refrac index = 0 ) -! rioriv 1 / mre -! rn 1 / n -! rtmp (real) temporary variable -! sp(j) s+ for j-th angle ( ref. 2, p. 1507 ) -! sm(j) s- for j-th angle ( ref. 2, p. 1507 ) -! sps(j) s+ for (numang+1-j)-th angle ( anyang=false ) -! sms(j) s- for (numang+1-j)-th angle ( anyang=false ) -! taun angular function little-tau-sub-n ( ref. 2, eq. 4 ) -! at j-th angle -! tcoef n ( n+1 ) ( 2n+1 ) (for summing tforw,tback series) -! twonp1 2n + 1 -! yesang true if scattering amplitudes are to be calculated -! zetnm1 ricatti-bessel function zeta-sub-(n-1) of argument -! -xx- ( ref. 2, eq. 17 ) -! zetn ricatti-bessel function zeta-sub-n of argument -xx- -! -! ---------------------------------------------------------------------- -! -------- i / o specifications for subroutine miev0 ----------------- -! ---------------------------------------------------------------------- - implicit none - logical anyang, perfct, prnt(*) - integer ipolzn, momdim, numang, nmom - real*8 gqsc, mimcut, pmom( 0:momdim, * ), qext, qsca, & - xmu(*), xx - complex*16 crefin, sforw, sback, s1(*), s2(*), tforw(*), & - tback(*) - integer maxang,mxang2,maxtrm - real*8 onethr -! ---------------------------------------------------------------------- -! - parameter ( maxang = 501, mxang2 = maxang/2 + 1 ) -! -! ** note -- maxtrm = 10100 is neces- -! ** sary to do some of the test probs, -! ** but 1100 is sufficient for most -! ** conceivable applications - parameter ( maxtrm = 1100 ) - parameter ( onethr = 1./3. ) -! - logical anysav, calcmo(4), noabs, ok, persav, yesang - integer npquan - integer i,j,n,nmosav,iposav,numsav,ntrm,nangd2 - real*8 mim, mimsav, mre, mm, np1dn - real*8 rioriv,xmusav,xxsav,sq,fn,rn,twonp1,tcoef, coeff - real*8 xinv,psinm1,chinm1,psin,chin,rtmp,taun - real*8 rbiga( maxtrm ), pin( maxang ), pinm1( maxang ) - complex*16 an, bn, anm1, bnm1, anp, bnp, anpm, bnpm, cresav, & - cior, cioriv, ctmp, zet, zetnm1, zetn - complex*16 cbiga( maxtrm ), lita( maxtrm ), litb( maxtrm ), & - sp( maxang ), sm( maxang ), sps( mxang2 ), sms( mxang2 ) - equivalence ( cbiga, rbiga ) - logical, save :: pass1 - data pass1 / .true. / - sq( ctmp ) = dble( ctmp )**2 + dimag( ctmp )**2 -! -! - if ( pass1 ) then -! ** save certain user input values - xxsav = xx - cresav = crefin - mimsav = mimcut - persav = perfct - anysav = anyang - nmosav = nmom - iposav = ipolzn - numsav = numang - xmusav = xmu( 1 ) -! ** reset input values for test case - xx = 10.0 - crefin = ( 1.5, - 0.1 ) - perfct = .false. - mimcut = 0.0 - anyang = .true. - numang = 1 - xmu( 1 )= - 0.7660444 - nmom = 1 - ipolzn = - 1 -! - end if -! ** check input and calculate -! ** certain variables from input -! - 10 call ckinmi( numang, maxang, xx, perfct, crefin, momdim, & - nmom, ipolzn, anyang, xmu, calcmo, npquan ) -! - if ( perfct .and. xx .le. 0.1 ) then -! ** use totally-reflecting -! ** small-particle limit -! - call small1 ( xx, numang, xmu, qext, qsca, gqsc, sforw, & - sback, s1, s2, tforw, tback, lita, litb ) - ntrm = 2 - go to 200 - end if -! - if ( .not.perfct ) then -! - cior = crefin - if ( dimag( cior ) .gt. 0.0 ) cior = dconjg( cior ) - mre = dble( cior ) - mim = - dimag( cior ) - noabs = mim .le. mimcut - cioriv = 1.0 / cior - rioriv = 1.0 / mre -! - if ( xx * dmax1( 1.d0, cdabs(cior) ) .le. 0.d1 ) then -! -! ** use general-refractive-index -! ** small-particle limit -! ** ( ref. 2, p. 1508 ) -! - call small2 ( xx, cior, .not.noabs, numang, xmu, qext, & - qsca, gqsc, sforw, sback, s1, s2, tforw, & - tback, lita, litb ) - ntrm = 2 - go to 200 - end if -! - end if -! - nangd2 = ( numang + 1 ) / 2 - yesang = numang .gt. 0 -! ** estimate number of terms in mie series -! ** ( ref. 2, p. 1508 ) - if ( xx.le.8.0 ) then - ntrm = xx + 4. * xx**onethr + 1. - else if ( xx.lt.4200. ) then - ntrm = xx + 4.05 * xx**onethr + 2. - else - ntrm = xx + 4. * xx**onethr + 2. - end if - if ( ntrm+1 .gt. maxtrm ) & - call errmsg( 'miev0--parameter maxtrm too small', .true. ) -! -! ** calculate logarithmic derivatives of -! ** j-bessel-fcn., big-a-sub-(1 to ntrm) - if ( .not.perfct ) & - call biga( cior, xx, ntrm, noabs, yesang, rbiga, cbiga ) -! -! ** initialize ricatti-bessel functions -! ** (psi,chi,zeta)-sub-(0,1) for upward -! ** recurrence ( ref. 1, eq. 19 ) - xinv = 1.0 / xx - psinm1 = dsin( xx ) - chinm1 = dcos( xx ) - psin = psinm1 * xinv - chinm1 - chin = chinm1 * xinv + psinm1 - zetnm1 = dcmplx( psinm1, chinm1 ) - zetn = dcmplx( psin, chin ) -! ** initialize previous coeffi- -! ** cients for -gqsc- series - anm1 = ( 0.0, 0.0 ) - bnm1 = ( 0.0, 0.0 ) -! ** initialize angular function little-pi -! ** and sums for s+, s- ( ref. 2, p. 1507 ) - if ( anyang ) then - do 60 j = 1, numang - pinm1( j ) = 0.0 - pin( j ) = 1.0 - sp ( j ) = ( 0.0, 0.0 ) - sm ( j ) = ( 0.0, 0.0 ) - 60 continue - else - do 70 j = 1, nangd2 - pinm1( j ) = 0.0 - pin( j ) = 1.0 - sp ( j ) = ( 0.0, 0.0 ) - sm ( j ) = ( 0.0, 0.0 ) - sps( j ) = ( 0.0, 0.0 ) - sms( j ) = ( 0.0, 0.0 ) - 70 continue - end if -! ** initialize mie sums for efficiencies, etc. - qsca = 0.0 - gqsc = 0.0 - sforw = ( 0., 0. ) - sback = ( 0., 0. ) - tforw( 1 ) = ( 0., 0. ) - tback( 1 ) = ( 0., 0. ) -! -! -! --------- loop to sum mie series ----------------------------------- -! - mm = + 1.0 - do 100 n = 1, ntrm -! ** compute various numerical coefficients - fn = n - rn = 1.0 / fn - np1dn = 1.0 + rn - twonp1 = 2 * n + 1 - coeff = twonp1 / ( fn * ( n + 1 ) ) - tcoef = twonp1 * ( fn * ( n + 1 ) ) -! -! ** calculate mie series coefficients - if ( perfct ) then -! ** totally-reflecting case -! - an = ( ( fn*xinv ) * psin - psinm1 ) / & - ( ( fn*xinv ) * zetn - zetnm1 ) - bn = psin / zetn -! - else if ( noabs ) then -! ** no-absorption case -! - an = ( ( rioriv*rbiga(n) + ( fn*xinv ) ) * psin - psinm1 ) & - / ( ( rioriv*rbiga(n) + ( fn*xinv ) ) * zetn - zetnm1 ) - bn = ( ( mre * rbiga(n) + ( fn*xinv ) ) * psin - psinm1 ) & - / ( ( mre * rbiga(n) + ( fn*xinv ) ) * zetn - zetnm1 ) - else -! ** absorptive case -! - an = ( ( cioriv * cbiga(n) + ( fn*xinv ) ) * psin - psinm1 ) & - /( ( cioriv * cbiga(n) + ( fn*xinv ) ) * zetn - zetnm1 ) - bn = ( ( cior * cbiga(n) + ( fn*xinv ) ) * psin - psinm1 ) & - /( ( cior * cbiga(n) + ( fn*xinv ) ) * zetn - zetnm1 ) - qsca = qsca + twonp1 * ( sq( an ) + sq( bn ) ) -! - end if -! ** save mie coefficients for *pmom* calculation - lita( n ) = an - litb( n ) = bn -! ** increment mie sums for non-angle- -! ** dependent quantities -! - sforw = sforw + twonp1 * ( an + bn ) - tforw( 1 ) = tforw( 1 ) + tcoef * ( an - bn ) - sback = sback + ( mm * twonp1 ) * ( an - bn ) - tback( 1 ) = tback( 1 ) + ( mm * tcoef ) * ( an + bn ) - gqsc = gqsc + ( fn - rn ) * dble( anm1 * dconjg( an ) & - + bnm1 * dconjg( bn ) ) & - + coeff * dble( an * dconjg( bn ) ) -! - if ( yesang ) then -! ** put mie coefficients in form -! ** needed for computing s+, s- -! ** ( ref. 2, p. 1507 ) - anp = coeff * ( an + bn ) - bnp = coeff * ( an - bn ) -! ** increment mie sums for s+, s- -! ** while upward recursing -! ** angular functions little pi -! ** and little tau - if ( anyang ) then -! ** arbitrary angles -! -! ** vectorizable loop - do 80 j = 1, numang - rtmp = ( xmu( j ) * pin( j ) ) - pinm1( j ) - taun = fn * rtmp - pinm1( j ) - sp( j ) = sp( j ) + anp * ( pin( j ) + taun ) - sm( j ) = sm( j ) + bnp * ( pin( j ) - taun ) - pinm1( j ) = pin( j ) - pin( j ) = ( xmu( j ) * pin( j ) ) + np1dn * rtmp - 80 continue -! - else -! ** angles symmetric about 90 degrees - anpm = mm * anp - bnpm = mm * bnp -! ** vectorizable loop - do 90 j = 1, nangd2 - rtmp = ( xmu( j ) * pin( j ) ) - pinm1( j ) - taun = fn * rtmp - pinm1( j ) - sp ( j ) = sp ( j ) + anp * ( pin( j ) + taun ) - sms( j ) = sms( j ) + bnpm * ( pin( j ) + taun ) - sm ( j ) = sm ( j ) + bnp * ( pin( j ) - taun ) - sps( j ) = sps( j ) + anpm * ( pin( j ) - taun ) - pinm1( j ) = pin( j ) - pin( j ) = ( xmu( j ) * pin( j ) ) + np1dn * rtmp - 90 continue -! - end if - end if -! ** update relevant quantities for next -! ** pass through loop - mm = - mm - anm1 = an - bnm1 = bn -! ** upward recurrence for ricatti-bessel -! ** functions ( ref. 1, eq. 17 ) -! - zet = ( twonp1 * xinv ) * zetn - zetnm1 - zetnm1 = zetn - zetn = zet - psinm1 = psin - psin = dble( zetn ) - 100 continue -! -! ---------- end loop to sum mie series -------------------------------- -! -! - qext = 2. / xx**2 * dble( sforw ) - if ( perfct .or. noabs ) then - qsca = qext - else - qsca = 2. / xx**2 * qsca - end if -! - gqsc = 4. / xx**2 * gqsc - sforw = 0.5 * sforw - sback = 0.5 * sback - tforw( 2 ) = 0.5 * ( sforw + 0.25 * tforw( 1 ) ) - tforw( 1 ) = 0.5 * ( sforw - 0.25 * tforw( 1 ) ) - tback( 2 ) = 0.5 * ( sback + 0.25 * tback( 1 ) ) - tback( 1 ) = 0.5 * ( - sback + 0.25 * tback( 1 ) ) -! - if ( yesang ) then -! ** recover scattering amplitudes -! ** from s+, s- ( ref. 1, eq. 11 ) - if ( anyang ) then -! ** vectorizable loop - do 110 j = 1, numang - s1( j ) = 0.5 * ( sp( j ) + sm( j ) ) - s2( j ) = 0.5 * ( sp( j ) - sm( j ) ) - 110 continue -! - else -! ** vectorizable loop - do 120 j = 1, nangd2 - s1( j ) = 0.5 * ( sp( j ) + sm( j ) ) - s2( j ) = 0.5 * ( sp( j ) - sm( j ) ) - 120 continue -! ** vectorizable loop - do 130 j = 1, nangd2 - s1( numang+1 - j ) = 0.5 * ( sps( j ) + sms( j ) ) - s2( numang+1 - j ) = 0.5 * ( sps( j ) - sms( j ) ) - 130 continue - end if -! - end if -! ** calculate legendre moments - 200 if ( nmom.gt.0 ) & - call lpcoef ( ntrm, nmom, ipolzn, momdim, calcmo, npquan, & - lita, litb, pmom ) -! - if ( dimag(crefin) .gt. 0.0 ) then -! ** take complex conjugates -! ** of scattering amplitudes - sforw = dconjg( sforw ) - sback = dconjg( sback ) - do 210 i = 1, 2 - tforw( i ) = dconjg( tforw(i) ) - tback( i ) = dconjg( tback(i) ) - 210 continue -! - do 220 j = 1, numang - s1( j ) = dconjg( s1(j) ) - s2( j ) = dconjg( s2(j) ) - 220 continue -! - end if -! - if ( pass1 ) then -! ** compare test case results with -! ** correct answers and abort if bad -! - call testmi ( qext, qsca, gqsc, sforw, sback, s1, s2, & - tforw, tback, pmom, momdim, ok ) - if ( .not. ok ) then - prnt(1) = .false. - prnt(2) = .false. - call miprnt( prnt, xx, perfct, crefin, numang, xmu, qext, & - qsca, gqsc, nmom, ipolzn, momdim, calcmo, & - pmom, sforw, sback, tforw, tback, s1, s2 ) - call errmsg( 'miev0 -- self-test failed', .true. ) - end if -! ** restore user input values - xx = xxsav - crefin = cresav - mimcut = mimsav - perfct = persav - anyang = anysav - nmom = nmosav - ipolzn = iposav - numang = numsav - xmu(1) = xmusav - pass1 = .false. - go to 10 -! - end if -! - if ( prnt(1) .or. prnt(2) ) & - call miprnt( prnt, xx, perfct, crefin, numang, xmu, qext, & - qsca, gqsc, nmom, ipolzn, momdim, calcmo, & - pmom, sforw, sback, tforw, tback, s1, s2 ) -! - return -! - end subroutine miev0 -!**************************************************************************** - subroutine ckinmi( numang, maxang, xx, perfct, crefin, momdim, & - nmom, ipolzn, anyang, xmu, calcmo, npquan ) -! -! check for bad input to 'miev0' and calculate -calcmo,npquan- -! - implicit none - logical perfct, anyang, calcmo(*) - integer numang, maxang, momdim, nmom, ipolzn, npquan - real*8 xx, xmu(*) - integer i,l,j,ip - complex*16 crefin -! - character*4 string - logical inperr -! - inperr = .false. -! - if ( numang.gt.maxang ) then - call errmsg( 'miev0--parameter maxang too small', .true. ) - inperr = .true. - end if - if ( numang.lt.0 ) call wrtbad( 'numang', inperr ) - if ( xx.lt.0. ) call wrtbad( 'xx', inperr ) - if ( .not.perfct .and. dble(crefin).le.0. ) & - call wrtbad( 'crefin', inperr ) - if ( momdim.lt.1 ) call wrtbad( 'momdim', inperr ) -! - if ( nmom.ne.0 ) then - if ( nmom.lt.0 .or. nmom.gt.momdim ) call wrtbad('nmom',inperr) - if ( iabs(ipolzn).gt.4444 ) call wrtbad( 'ipolzn', inperr ) - npquan = 0 - do 5 l = 1, 4 - calcmo( l ) = .false. - 5 continue - if ( ipolzn.ne.0 ) then -! ** parse out -ipolzn- into its digits -! ** to find which phase quantities are -! ** to have their moments calculated -! - write( string, '(i4)' ) iabs(ipolzn) - do 10 j = 1, 4 - ip = ichar( string(j:j) ) - ichar( '0' ) - if ( ip.ge.1 .and. ip.le.4 ) calcmo( ip ) = .true. - if ( ip.eq.0 .or. (ip.ge.5 .and. ip.le.9) ) & - call wrtbad( 'ipolzn', inperr ) - npquan = max0( npquan, ip ) - 10 continue - end if - end if -! - if ( anyang ) then -! ** allow for slight imperfections in -! ** computation of cosine - do 20 i = 1, numang - if ( xmu(i).lt.-1.00001 .or. xmu(i).gt.1.00001 ) & - call wrtbad( 'xmu', inperr ) - 20 continue - else - do 22 i = 1, ( numang + 1 ) / 2 - if ( xmu(i).lt.-0.00001 .or. xmu(i).gt.1.00001 ) & - call wrtbad( 'xmu', inperr ) - 22 continue - end if -! - if ( inperr ) & - call errmsg( 'miev0--input error(s). aborting...', .true. ) -! - if ( xx.gt.20000.0 .or. dble(crefin).gt.10.0 .or. & - dabs( dimag(crefin) ).gt.10.0 ) call errmsg( & - 'miev0--xx or crefin outside tested range', .false. ) -! - return - end subroutine ckinmi -!*********************************************************************** - subroutine lpcoef ( ntrm, nmom, ipolzn, momdim, calcmo, npquan, & - a, b, pmom ) -! -! calculate legendre polynomial expansion coefficients (also -! called moments) for phase quantities ( ref. 5 formulation ) -! -! input: ntrm number terms in mie series -! nmom, ipolzn, momdim 'miev0' arguments -! calcmo flags calculated from -ipolzn- -! npquan defined in 'miev0' -! a, b mie series coefficients -! -! output: pmom legendre moments ('miev0' argument) -! -! *** notes *** -! -! (1) eqs. 2-5 are in error in dave, appl. opt. 9, -! 1888 (1970). eq. 2 refers to m1, not m2; eq. 3 refers to -! m2, not m1. in eqs. 4 and 5, the subscripts on the second -! term in square brackets should be interchanged. -! -! (2) the general-case logic in this subroutine works correctly -! in the two-term mie series case, but subroutine 'lpco2t' -! is called instead, for speed. -! -! (3) subroutine 'lpco1t', to do the one-term case, is never -! called within the context of 'miev0', but is included for -! complete generality. -! -! (4) some improvement in speed is obtainable by combining the -! 310- and 410-loops, if moments for both the third and fourth -! phase quantities are desired, because the third phase quantity -! is the real part of a complex series, while the fourth phase -! quantity is the imaginary part of that very same series. but -! most users are not interested in the fourth phase quantity, -! which is related to circular polarization, so the present -! scheme is usually more efficient. -! - implicit none - logical calcmo(*) - integer ipolzn, momdim, nmom, ntrm, npquan - real*8 pmom( 0:momdim, * ) - complex*16 a(*), b(*) -! -! ** specification of local variables -! -! am(m) numerical coefficients a-sub-m-super-l -! in dave, eqs. 1-15, as simplified in ref. 5. -! -! bi(i) numerical coefficients b-sub-i-super-l -! in dave, eqs. 1-15, as simplified in ref. 5. -! -! bidel(i) 1/2 bi(i) times factor capital-del in dave -! -! cm,dm() arrays c and d in dave, eqs. 16-17 (mueller form), -! calculated using recurrence derived in ref. 5 -! -! cs,ds() arrays c and d in ref. 4, eqs. a5-a6 (sekera form), -! calculated using recurrence derived in ref. 5 -! -! c,d() either -cm,dm- or -cs,ds-, depending on -ipolzn- -! -! evenl true for even-numbered moments; false otherwise -! -! idel 1 + little-del in dave -! -! maxtrm max. no. of terms in mie series -! -! maxmom max. no. of non-zero moments -! -! nummom number of non-zero moments -! -! recip(k) 1 / k -! - integer maxtrm,maxmom,mxmom2,maxrcp - parameter ( maxtrm = 1102, maxmom = 2*maxtrm, mxmom2 = maxmom/2, & - maxrcp = 4*maxtrm + 2 ) - real*8 am( 0:maxtrm ), bi( 0:mxmom2 ), bidel( 0:mxmom2 ) - real*8, save :: recip( maxrcp ) - complex*16 cm( maxtrm ), dm( maxtrm ), cs( maxtrm ), ds( maxtrm ), & - c( maxtrm ), d( maxtrm ) - integer k,j,l,nummom,ld2,idel,m,i,mmax,imax - real*8 thesum - equivalence ( c, cm ), ( d, dm ) - logical evenl - logical, save :: pass1 - data pass1 / .true. / -! -! - if ( pass1 ) then -! - do 1 k = 1, maxrcp - recip( k ) = 1.0 / k - 1 continue - pass1 = .false. -! - end if -! - do 5 j = 1, max0( 1, npquan ) - do 5 l = 0, nmom - pmom( l, j ) = 0.0 - 5 continue -! - if ( ntrm.eq.1 ) then - call lpco1t ( nmom, ipolzn, momdim, calcmo, a, b, pmom ) - return - else if ( ntrm.eq.2 ) then - call lpco2t ( nmom, ipolzn, momdim, calcmo, a, b, pmom ) - return - end if -! - if ( ntrm+2 .gt. maxtrm ) & - call errmsg( 'lpcoef--parameter maxtrm too small', .true. ) -! -! ** calculate mueller c, d arrays - cm( ntrm+2 ) = ( 0., 0. ) - dm( ntrm+2 ) = ( 0., 0. ) - cm( ntrm+1 ) = ( 1. - recip( ntrm+1 ) ) * b( ntrm ) - dm( ntrm+1 ) = ( 1. - recip( ntrm+1 ) ) * a( ntrm ) - cm( ntrm ) = ( recip(ntrm) + recip(ntrm+1) ) * a( ntrm ) & - + ( 1. - recip(ntrm) ) * b( ntrm-1 ) - dm( ntrm ) = ( recip(ntrm) + recip(ntrm+1) ) * b( ntrm ) & - + ( 1. - recip(ntrm) ) * a( ntrm-1 ) -! - do 10 k = ntrm-1, 2, -1 - cm( k ) = cm( k+2 ) - ( 1. + recip(k+1) ) * b( k+1 ) & - + ( recip(k) + recip(k+1) ) * a( k ) & - + ( 1. - recip(k) ) * b( k-1 ) - dm( k ) = dm( k+2 ) - ( 1. + recip(k+1) ) * a( k+1 ) & - + ( recip(k) + recip(k+1) ) * b( k ) & - + ( 1. - recip(k) ) * a( k-1 ) - 10 continue - cm( 1 ) = cm( 3 ) + 1.5 * ( a( 1 ) - b( 2 ) ) - dm( 1 ) = dm( 3 ) + 1.5 * ( b( 1 ) - a( 2 ) ) -! - if ( ipolzn.ge.0 ) then -! - do 20 k = 1, ntrm + 2 - c( k ) = ( 2*k - 1 ) * cm( k ) - d( k ) = ( 2*k - 1 ) * dm( k ) - 20 continue -! - else -! ** compute sekera c and d arrays - cs( ntrm+2 ) = ( 0., 0. ) - ds( ntrm+2 ) = ( 0., 0. ) - cs( ntrm+1 ) = ( 0., 0. ) - ds( ntrm+1 ) = ( 0., 0. ) -! - do 30 k = ntrm, 1, -1 - cs( k ) = cs( k+2 ) + ( 2*k + 1 ) * ( cm( k+1 ) - b( k ) ) - ds( k ) = ds( k+2 ) + ( 2*k + 1 ) * ( dm( k+1 ) - a( k ) ) - 30 continue -! - do 40 k = 1, ntrm + 2 - c( k ) = ( 2*k - 1 ) * cs( k ) - d( k ) = ( 2*k - 1 ) * ds( k ) - 40 continue -! - end if -! -! - if( ipolzn.lt.0 ) nummom = min0( nmom, 2*ntrm - 2 ) - if( ipolzn.ge.0 ) nummom = min0( nmom, 2*ntrm ) - if ( nummom .gt. maxmom ) & - call errmsg( 'lpcoef--parameter maxtrm too small', .true. ) -! -! ** loop over moments - do 500 l = 0, nummom - ld2 = l / 2 - evenl = mod( l,2 ) .eq. 0 -! ** calculate numerical coefficients -! ** a-sub-m and b-sub-i in dave -! ** double-sums for moments - if( l.eq.0 ) then -! - idel = 1 - do 60 m = 0, ntrm - am( m ) = 2.0 * recip( 2*m + 1 ) - 60 continue - bi( 0 ) = 1.0 -! - else if( evenl ) then -! - idel = 1 - do 70 m = ld2, ntrm - am( m ) = ( 1. + recip( 2*m-l+1 ) ) * am( m ) - 70 continue - do 75 i = 0, ld2-1 - bi( i ) = ( 1. - recip( l-2*i ) ) * bi( i ) - 75 continue - bi( ld2 ) = ( 2. - recip( l ) ) * bi( ld2-1 ) -! - else -! - idel = 2 - do 80 m = ld2, ntrm - am( m ) = ( 1. - recip( 2*m+l+2 ) ) * am( m ) - 80 continue - do 85 i = 0, ld2 - bi( i ) = ( 1. - recip( l+2*i+1 ) ) * bi( i ) - 85 continue -! - end if -! ** establish upper limits for sums -! ** and incorporate factor capital- -! ** del into b-sub-i - mmax = ntrm - idel - if( ipolzn.ge.0 ) mmax = mmax + 1 - imax = min0( ld2, mmax - ld2 ) - if( imax.lt.0 ) go to 600 - do 90 i = 0, imax - bidel( i ) = bi( i ) - 90 continue - if( evenl ) bidel( 0 ) = 0.5 * bidel( 0 ) -! -! ** perform double sums just for -! ** phase quantities desired by user - if( ipolzn.eq.0 ) then -! - do 110 i = 0, imax -! ** vectorizable loop (cray) - thesum = 0.0 - do 100 m = ld2, mmax - i - thesum = thesum + am( m ) * & - ( dble( c(m-i+1) * dconjg( c(m+i+idel) ) ) & - + dble( d(m-i+1) * dconjg( d(m+i+idel) ) ) ) - 100 continue - pmom( l,1 ) = pmom( l,1 ) + bidel( i ) * thesum - 110 continue - pmom( l,1 ) = 0.5 * pmom( l,1 ) - go to 500 -! - end if -! - if ( calcmo(1) ) then - do 160 i = 0, imax -! ** vectorizable loop (cray) - thesum = 0.0 - do 150 m = ld2, mmax - i - thesum = thesum + am( m ) * & - dble( c(m-i+1) * dconjg( c(m+i+idel) ) ) - 150 continue - pmom( l,1 ) = pmom( l,1 ) + bidel( i ) * thesum - 160 continue - end if -! -! - if ( calcmo(2) ) then - do 210 i = 0, imax -! ** vectorizable loop (cray) - thesum = 0.0 - do 200 m = ld2, mmax - i - thesum = thesum + am( m ) * & - dble( d(m-i+1) * dconjg( d(m+i+idel) ) ) - 200 continue - pmom( l,2 ) = pmom( l,2 ) + bidel( i ) * thesum - 210 continue - end if -! -! - if ( calcmo(3) ) then - do 310 i = 0, imax -! ** vectorizable loop (cray) - thesum = 0.0 - do 300 m = ld2, mmax - i - thesum = thesum + am( m ) * & - ( dble( c(m-i+1) * dconjg( d(m+i+idel) ) ) & - + dble( c(m+i+idel) * dconjg( d(m-i+1) ) ) ) - 300 continue - pmom( l,3 ) = pmom( l,3 ) + bidel( i ) * thesum - 310 continue - pmom( l,3 ) = 0.5 * pmom( l,3 ) - end if -! -! - if ( calcmo(4) ) then - do 410 i = 0, imax -! ** vectorizable loop (cray) - thesum = 0.0 - do 400 m = ld2, mmax - i - thesum = thesum + am( m ) * & - ( dimag( c(m-i+1) * dconjg( d(m+i+idel) ) ) & - + dimag( c(m+i+idel) * dconjg( d(m-i+1) ) )) - 400 continue - pmom( l,4 ) = pmom( l,4 ) + bidel( i ) * thesum - 410 continue - pmom( l,4 ) = - 0.5 * pmom( l,4 ) - end if -! - 500 continue -! -! - 600 return - end subroutine lpcoef -!********************************************************************* - subroutine lpco1t ( nmom, ipolzn, momdim, calcmo, a, b, pmom ) -! -! calculate legendre polynomial expansion coefficients (also -! called moments) for phase quantities in special case where -! no. terms in mie series = 1 -! -! input: nmom, ipolzn, momdim 'miev0' arguments -! calcmo flags calculated from -ipolzn- -! a(1), b(1) mie series coefficients -! -! output: pmom legendre moments -! - implicit none - logical calcmo(*) - integer ipolzn, momdim, nmom,nummom,l - real*8 pmom( 0:momdim, * ),sq,a1sq,b1sq - complex*16 a(*), b(*), ctmp, a1b1c - sq( ctmp ) = dble( ctmp )**2 + dimag( ctmp )**2 -! -! - a1sq = sq( a(1) ) - b1sq = sq( b(1) ) - a1b1c = a(1) * dconjg( b(1) ) -! - if( ipolzn.lt.0 ) then -! - if( calcmo(1) ) pmom( 0,1 ) = 2.25 * b1sq - if( calcmo(2) ) pmom( 0,2 ) = 2.25 * a1sq - if( calcmo(3) ) pmom( 0,3 ) = 2.25 * dble( a1b1c ) - if( calcmo(4) ) pmom( 0,4 ) = 2.25 *dimag( a1b1c ) -! - else -! - nummom = min0( nmom, 2 ) -! ** loop over moments - do 100 l = 0, nummom -! - if( ipolzn.eq.0 ) then - if( l.eq.0 ) pmom( l,1 ) = 1.5 * ( a1sq + b1sq ) - if( l.eq.1 ) pmom( l,1 ) = 1.5 * dble( a1b1c ) - if( l.eq.2 ) pmom( l,1 ) = 0.15 * ( a1sq + b1sq ) - go to 100 - end if -! - if( calcmo(1) ) then - if( l.eq.0 ) pmom( l,1 ) = 2.25 * ( a1sq + b1sq / 3. ) - if( l.eq.1 ) pmom( l,1 ) = 1.5 * dble( a1b1c ) - if( l.eq.2 ) pmom( l,1 ) = 0.3 * b1sq - end if -! - if( calcmo(2) ) then - if( l.eq.0 ) pmom( l,2 ) = 2.25 * ( b1sq + a1sq / 3. ) - if( l.eq.1 ) pmom( l,2 ) = 1.5 * dble( a1b1c ) - if( l.eq.2 ) pmom( l,2 ) = 0.3 * a1sq - end if -! - if( calcmo(3) ) then - if( l.eq.0 ) pmom( l,3 ) = 3.0 * dble( a1b1c ) - if( l.eq.1 ) pmom( l,3 ) = 0.75 * ( a1sq + b1sq ) - if( l.eq.2 ) pmom( l,3 ) = 0.3 * dble( a1b1c ) - end if -! - if( calcmo(4) ) then - if( l.eq.0 ) pmom( l,4 ) = - 1.5 * dimag( a1b1c ) - if( l.eq.1 ) pmom( l,4 ) = 0.0 - if( l.eq.2 ) pmom( l,4 ) = 0.3 * dimag( a1b1c ) - end if -! - 100 continue -! - end if -! - return - end subroutine lpco1t -!******************************************************************** - subroutine lpco2t ( nmom, ipolzn, momdim, calcmo, a, b, pmom ) -! -! calculate legendre polynomial expansion coefficients (also -! called moments) for phase quantities in special case where -! no. terms in mie series = 2 -! -! input: nmom, ipolzn, momdim 'miev0' arguments -! calcmo flags calculated from -ipolzn- -! a(1-2), b(1-2) mie series coefficients -! -! output: pmom legendre moments -! - implicit none - logical calcmo(*) - integer ipolzn, momdim, nmom,l,nummom - real*8 pmom( 0:momdim, * ),sq,pm1,pm2,a2sq,b2sq - complex*16 a(*), b(*) - complex*16 a2c, b2c, ctmp, ca, cac, cat, cb, cbc, cbt, cg, ch - sq( ctmp ) = dble( ctmp )**2 + dimag( ctmp )**2 -! -! - ca = 3. * a(1) - 5. * b(2) - cat= 3. * b(1) - 5. * a(2) - cac = dconjg( ca ) - a2sq = sq( a(2) ) - b2sq = sq( b(2) ) - a2c = dconjg( a(2) ) - b2c = dconjg( b(2) ) -! - if( ipolzn.lt.0 ) then -! ** loop over sekera moments - nummom = min0( nmom, 2 ) - do 50 l = 0, nummom -! - if( calcmo(1) ) then - if( l.eq.0 ) pmom( l,1 ) = 0.25 * ( sq(cat) + & - (100./3.) * b2sq ) - if( l.eq.1 ) pmom( l,1 ) = (5./3.) * dble( cat * b2c ) - if( l.eq.2 ) pmom( l,1 ) = (10./3.) * b2sq - end if -! - if( calcmo(2) ) then - if( l.eq.0 ) pmom( l,2 ) = 0.25 * ( sq(ca) + & - (100./3.) * a2sq ) - if( l.eq.1 ) pmom( l,2 ) = (5./3.) * dble( ca * a2c ) - if( l.eq.2 ) pmom( l,2 ) = (10./3.) * a2sq - end if -! - if( calcmo(3) ) then - if( l.eq.0 ) pmom( l,3 ) = 0.25 * dble( cat*cac + & - (100./3.)*b(2)*a2c ) - if( l.eq.1 ) pmom( l,3 ) = 5./6. * dble( b(2)*cac + & - cat*a2c ) - if( l.eq.2 ) pmom( l,3 ) = 10./3. * dble( b(2) * a2c ) - end if -! - if( calcmo(4) ) then - if( l.eq.0 ) pmom( l,4 ) = -0.25 * dimag( cat*cac + & - (100./3.)*b(2)*a2c ) - if( l.eq.1 ) pmom( l,4 ) = -5./6. * dimag( b(2)*cac + & - cat*a2c ) - if( l.eq.2 ) pmom( l,4 ) = -10./3. * dimag( b(2) * a2c ) - end if -! - 50 continue -! - else -! - cb = 3. * b(1) + 5. * a(2) - cbt= 3. * a(1) + 5. * b(2) - cbc = dconjg( cb ) - cg = ( cbc*cbt + 10.*( cac*a(2) + b2c*cat) ) / 3. - ch = 2.*( cbc*a(2) + b2c*cbt ) -! -! ** loop over mueller moments - nummom = min0( nmom, 4 ) - do 100 l = 0, nummom -! - if( ipolzn.eq.0 .or. calcmo(1) ) then - if( l.eq.0 ) pm1 = 0.25 * sq(ca) + sq(cb) / 12. & - + (5./3.) * dble(ca*b2c) + 5.*b2sq - if( l.eq.1 ) pm1 = dble( cb * ( cac/6. + b2c ) ) - if( l.eq.2 ) pm1 = sq(cb)/30. + (20./7.) * b2sq & - + (2./3.) * dble( ca * b2c ) - if( l.eq.3 ) pm1 = (2./7.) * dble( cb * b2c ) - if( l.eq.4 ) pm1 = (40./63.) * b2sq - if ( calcmo(1) ) pmom( l,1 ) = pm1 - end if -! - if( ipolzn.eq.0 .or. calcmo(2) ) then - if( l.eq.0 ) pm2 = 0.25*sq(cat) + sq(cbt) / 12. & - + (5./3.) * dble(cat*a2c) + 5.*a2sq - if( l.eq.1 ) pm2 = dble( cbt * ( dconjg(cat)/6. + a2c) ) - if( l.eq.2 ) pm2 = sq(cbt)/30. + (20./7.) * a2sq & - + (2./3.) * dble( cat * a2c ) - if( l.eq.3 ) pm2 = (2./7.) * dble( cbt * a2c ) - if( l.eq.4 ) pm2 = (40./63.) * a2sq - if ( calcmo(2) ) pmom( l,2 ) = pm2 - end if -! - if( ipolzn.eq.0 ) then - pmom( l,1 ) = 0.5 * ( pm1 + pm2 ) - go to 100 - end if -! - if( calcmo(3) ) then - if( l.eq.0 ) pmom( l,3 ) = 0.25 * dble( cac*cat + cg + & - 20.*b2c*a(2) ) - if( l.eq.1 ) pmom( l,3 ) = dble( cac*cbt + cbc*cat + & - 3.*ch ) / 12. - if( l.eq.2 ) pmom( l,3 ) = 0.1 * dble( cg + (200./7.) * & - b2c * a(2) ) - if( l.eq.3 ) pmom( l,3 ) = dble( ch ) / 14. - if( l.eq.4 ) pmom( l,3 ) = 40./63. * dble( b2c * a(2) ) - end if -! - if( calcmo(4) ) then - if( l.eq.0 ) pmom( l,4 ) = 0.25 * dimag( cac*cat + cg + & - 20.*b2c*a(2) ) - if( l.eq.1 ) pmom( l,4 ) = dimag( cac*cbt + cbc*cat + & - 3.*ch ) / 12. - if( l.eq.2 ) pmom( l,4 ) = 0.1 * dimag( cg + (200./7.) * & - b2c * a(2) ) - if( l.eq.3 ) pmom( l,4 ) = dimag( ch ) / 14. - if( l.eq.4 ) pmom( l,4 ) = 40./63. * dimag( b2c * a(2) ) - end if -! - 100 continue -! - end if -! - return - end subroutine lpco2t -!********************************************************************* - subroutine biga( cior, xx, ntrm, noabs, yesang, rbiga, cbiga ) -! -! calculate logarithmic derivatives of j-bessel-function -! -! input : cior, xx, ntrm, noabs, yesang (defined in 'miev0') -! -! output : rbiga or cbiga (defined in 'miev0') -! -! internal variables : -! -! confra value of lentz continued fraction for -cbiga(ntrm)-, -! used to initialize downward recurrence. -! down = true, use down-recurrence. false, do not. -! f1,f2,f3 arithmetic statement functions used in determining -! whether to use up- or down-recurrence -! ( ref. 2, eqs. 6-8 ) -! mre real refractive index -! mim imaginary refractive index -! rezinv 1 / ( mre * xx ); temporary variable for recurrence -! zinv 1 / ( cior * xx ); temporary variable for recurrence -! - implicit none - logical down, noabs, yesang - integer ntrm,n - real*8 mre, mim, rbiga(*), xx, rezinv, rtmp, f1,f2,f3 -! complex*16 cior, ctmp, confra, cbiga(*), zinv - complex*16 cior, ctmp, cbiga(*), zinv - f1( mre ) = - 8.0 + mre**2 * ( 26.22 + mre * ( - 0.4474 & - + mre**3 * ( 0.00204 - 0.000175 * mre ) ) ) - f2( mre ) = 3.9 + mre * ( - 10.8 + 13.78 * mre ) - f3( mre ) = - 15.04 + mre * ( 8.42 + 16.35 * mre ) -! -! ** decide whether 'biga' can be -! ** calculated by up-recurrence - mre = dble( cior ) - mim = dabs( dimag( cior ) ) - if ( mre.lt.1.0 .or. mre.gt.10.0 .or. mim.gt.10.0 ) then - down = .true. - else if ( yesang ) then - down = .true. - if ( mim*xx .lt. f2( mre ) ) down = .false. - else - down = .true. - if ( mim*xx .lt. f1( mre ) ) down = .false. - end if -! - zinv = 1.0 / ( cior * xx ) - rezinv = 1.0 / ( mre * xx ) -! - if ( down ) then -! ** compute initial high-order 'biga' using -! ** lentz method ( ref. 1, pp. 17-20 ) -! - ctmp = confra( ntrm, zinv, xx ) -! -! *** downward recurrence for 'biga' -! *** ( ref. 1, eq. 22 ) - if ( noabs ) then -! ** no-absorption case - rbiga( ntrm ) = dble( ctmp ) - do 25 n = ntrm, 2, - 1 - rbiga( n-1 ) = (n*rezinv) & - - 1.0 / ( (n*rezinv) + rbiga( n ) ) - 25 continue -! - else -! ** absorptive case - cbiga( ntrm ) = ctmp - do 30 n = ntrm, 2, - 1 - cbiga( n-1 ) = (n*zinv) - 1.0 / ( (n*zinv) + cbiga( n ) ) - 30 continue -! - end if -! - else -! *** upward recurrence for 'biga' -! *** ( ref. 1, eqs. 20-21 ) - if ( noabs ) then -! ** no-absorption case - rtmp = dsin( mre*xx ) - rbiga( 1 ) = - rezinv & - + rtmp / ( rtmp*rezinv - dcos( mre*xx ) ) - do 40 n = 2, ntrm - rbiga( n ) = - ( n*rezinv ) & - + 1.0 / ( ( n*rezinv ) - rbiga( n-1 ) ) - 40 continue -! - else -! ** absorptive case - ctmp = cdexp( - dcmplx(0.d0,2.d0) * cior * xx ) - cbiga( 1 ) = - zinv + (1.-ctmp) / ( zinv * (1.-ctmp) - & - dcmplx(0.d0,1.d0)*(1.+ctmp) ) - do 50 n = 2, ntrm - cbiga( n ) = - (n*zinv) + 1.0 / ((n*zinv) - cbiga( n-1 )) - 50 continue - end if -! - end if -! - return - end subroutine biga -!********************************************************************** - complex*16 function confra( n, zinv, xx ) -! -! compute bessel function ratio capital-a-sub-n from its -! continued fraction using lentz method ( ref. 1, pp. 17-20 ) -! -! zinv = reciprocal of argument of capital-a -! -! i n t e r n a l v a r i a b l e s -! ------------------------------------ -! -! cak term in continued fraction expansion of capital-a -! ( ref. 1, eq. 25 ) -! capt factor used in lentz iteration for capital-a -! ( ref. 1, eq. 27 ) -! cdenom denominator in -capt- ( ref. 1, eq. 28b ) -! cnumer numerator in -capt- ( ref. 1, eq. 28a ) -! cdtd product of two successive denominators of -capt- -! factors ( ref. 1, eq. 34c ) -! cntn product of two successive numerators of -capt- -! factors ( ref. 1, eq. 34b ) -! eps1 ill-conditioning criterion -! eps2 convergence criterion -! kk subscript k of -cak- ( ref. 1, eq. 25b ) -! kount iteration counter ( used only to prevent runaway ) -! maxit max. allowed no. of iterations -! mm + 1 and - 1, alternately -! - implicit none - integer n,mm,kk,kount - integer, save :: maxit - data maxit / 10000 / - real*8 xx - real*8, save :: eps1,eps2 - data eps1 / 1.d-2 /, eps2 / 1.d-8 / - complex*16 zinv - complex*16 cak, capt, cdenom, cdtd, cnumer, cntn -! -! *** ref. 1, eqs. 25a, 27 - confra = ( n + 1 ) * zinv - mm = - 1 - kk = 2 * n + 3 - cak = ( mm * kk ) * zinv - cdenom = cak - cnumer = cdenom + 1.0 / confra - kount = 1 -! - 20 kount = kount + 1 - if ( kount.gt.maxit ) & - call errmsg( 'confra--iteration failed to converge$', .true.) -! -! *** ref. 2, eq. 25b - mm = - mm - kk = kk + 2 - cak = ( mm * kk ) * zinv -! *** ref. 2, eq. 32 - if ( cdabs( cnumer/cak ).le.eps1 & - .or. cdabs( cdenom/cak ).le.eps1 ) then -! -! ** ill-conditioned case -- stride -! ** two terms instead of one -! -! *** ref. 2, eqs. 34 - cntn = cak * cnumer + 1.0 - cdtd = cak * cdenom + 1.0 - confra = ( cntn / cdtd ) * confra -! *** ref. 2, eq. 25b - mm = - mm - kk = kk + 2 - cak = ( mm * kk ) * zinv -! *** ref. 2, eqs. 35 - cnumer = cak + cnumer / cntn - cdenom = cak + cdenom / cdtd - kount = kount + 1 - go to 20 -! - else -! ** well-conditioned case -! -! *** ref. 2, eqs. 26, 27 - capt = cnumer / cdenom - confra = capt * confra -! ** check for convergence -! ** ( ref. 2, eq. 31 ) -! - if ( dabs( dble(capt) - 1.0 ).ge.eps2 & - .or. dabs( dimag(capt) ) .ge.eps2 ) then -! -! *** ref. 2, eqs. 30a-b - cnumer = cak + 1.0 / cnumer - cdenom = cak + 1.0 / cdenom - go to 20 - end if - end if -! - return -! - end function confra -!******************************************************************** - subroutine miprnt( prnt, xx, perfct, crefin, numang, xmu, & - qext, qsca, gqsc, nmom, ipolzn, momdim, & - calcmo, pmom, sforw, sback, tforw, tback, & - s1, s2 ) -! -! print scattering quantities of a single particle -! - implicit none - logical perfct, prnt(*), calcmo(*) - integer ipolzn, momdim, nmom, numang,i,m,j - real*8 gqsc, pmom( 0:momdim, * ), qext, qsca, xx, xmu(*) - real*8 fi1,fi2,fnorm - complex*16 crefin, sforw, sback, tforw(*), tback(*), s1(*), s2(*) - character*22 fmt -! -! - if ( perfct ) write ( *, '(''1'',10x,a,1p,e11.4)' ) & - 'perfectly conducting case, size parameter =', xx - if ( .not.perfct ) write ( *, '(''1'',10x,3(a,1p,e11.4))' ) & - 'refractive index: real ', dble(crefin), & - ' imag ', dimag(crefin), ', size parameter =', xx -! - if ( prnt(1) .and. numang.gt.0 ) then -! - write ( *, '(/,a)' ) & - ' cos(angle) ------- s1 --------- ------- s2 ---------'// & - ' --- s1*conjg(s2) --- i1=s1**2 i2=s2**2 (i1+i2)/2'// & - ' deg polzn' - do 10 i = 1, numang - fi1 = dble( s1(i) ) **2 + dimag( s1(i) )**2 - fi2 = dble( s2(i) ) **2 + dimag( s2(i) )**2 - write( *, '( i4, f10.6, 1p,10e11.3 )' ) & - i, xmu(i), s1(i), s2(i), s1(i)*dconjg(s2(i)), & - fi1, fi2, 0.5*(fi1+fi2), (fi2-fi1)/(fi2+fi1) - 10 continue -! - end if -! -! - if ( prnt(2) ) then -! - write ( *, '(/,a,9x,a,17x,a,17x,a,/,(0p,f7.2, 1p,6e12.3) )' ) & - ' angle', 's-sub-1', 't-sub-1', 't-sub-2', & - 0.0, sforw, tforw(1), tforw(2), & - 180., sback, tback(1), tback(2) - write ( *, '(/,4(a,1p,e11.4))' ) & - ' efficiency factors, extinction:', qext, & - ' scattering:', qsca, & - ' absorption:', qext-qsca, & - ' rad. pressure:', qext-gqsc -! - if ( nmom.gt.0 ) then -! - write( *, '(/,a)' ) ' normalized moments of :' - if ( ipolzn.eq.0 ) write ( *, '(''+'',27x,a)' ) 'phase fcn' - if ( ipolzn.gt.0 ) write ( *, '(''+'',33x,a)' ) & - 'm1 m2 s21 d21' - if ( ipolzn.lt.0 ) write ( *, '(''+'',33x,a)' ) & - 'r1 r2 r3 r4' -! - fnorm = 4. / ( xx**2 * qsca ) - do 20 m = 0, nmom - write ( *, '(a,i4)' ) ' moment no.', m - do 20 j = 1, 4 - if( calcmo(j) ) then - write( fmt, 98 ) 24 + (j-1)*13 - write ( *,fmt ) fnorm * pmom(m,j) - end if - 20 continue - end if -! - end if -! - return -! - 98 format( '( ''+'', t', i2, ', 1p,e13.4 )' ) - end subroutine miprnt -!************************************************************************** - subroutine small1 ( xx, numang, xmu, qext, qsca, gqsc, sforw, & - sback, s1, s2, tforw, tback, a, b ) -! -! small-particle limit of mie quantities in totally reflecting -! limit ( mie series truncated after 2 terms ) -! -! a,b first two mie coefficients, with numerator and -! denominator expanded in powers of -xx- ( a factor -! of xx**3 is missing but is restored before return -! to calling program ) ( ref. 2, p. 1508 ) -! - implicit none - integer numang,j - real*8 gqsc, qext, qsca, xx, xmu(*) - real*8 twothr,fivthr,fivnin,sq,rtmp - complex*16 a( 2 ), b( 2 ), sforw, sback, s1(*), s2(*), & - tforw(*), tback(*) -! - parameter ( twothr = 2./3., fivthr = 5./3., fivnin = 5./9. ) - complex*16 ctmp - sq( ctmp ) = dble( ctmp )**2 + dimag( ctmp )**2 -! -! - a( 1 ) = dcmplx ( 0.d0, twothr * ( 1. - 0.2 * xx**2 ) ) & - / dcmplx ( 1.d0 - 0.5 * xx**2, twothr * xx**3 ) -! - b( 1 ) = dcmplx ( 0.d0, - ( 1. - 0.1 * xx**2 ) / 3. ) & - / dcmplx ( 1.d0 + 0.5 * xx**2, - xx**3 / 3. ) -! - a( 2 ) = dcmplx ( 0.d0, xx**2 / 30. ) - b( 2 ) = dcmplx ( 0.d0, - xx**2 / 45. ) -! - qsca = 6. * xx**4 * ( sq( a(1) ) + sq( b(1) ) & - + fivthr * ( sq( a(2) ) + sq( b(2) ) ) ) - qext = qsca - gqsc = 6. * xx**4 * dble( a(1) * dconjg( a(2) + b(1) ) & - + ( b(1) + fivnin * a(2) ) * dconjg( b(2) ) ) -! - rtmp = 1.5 * xx**3 - sforw = rtmp * ( a(1) + b(1) + fivthr * ( a(2) + b(2) ) ) - sback = rtmp * ( a(1) - b(1) - fivthr * ( a(2) - b(2) ) ) - tforw( 1 ) = rtmp * ( b(1) + fivthr * ( 2.*b(2) - a(2) ) ) - tforw( 2 ) = rtmp * ( a(1) + fivthr * ( 2.*a(2) - b(2) ) ) - tback( 1 ) = rtmp * ( b(1) - fivthr * ( 2.*b(2) + a(2) ) ) - tback( 2 ) = rtmp * ( a(1) - fivthr * ( 2.*a(2) + b(2) ) ) -! - do 10 j = 1, numang - s1( j ) = rtmp * ( a(1) + b(1) * xmu(j) + fivthr * & - ( a(2) * xmu(j) + b(2) * ( 2.*xmu(j)**2 - 1. )) ) - s2( j ) = rtmp * ( b(1) + a(1) * xmu(j) + fivthr * & - ( b(2) * xmu(j) + a(2) * ( 2.*xmu(j)**2 - 1. )) ) - 10 continue -! ** recover actual mie coefficients - a( 1 ) = xx**3 * a( 1 ) - a( 2 ) = xx**3 * a( 2 ) - b( 1 ) = xx**3 * b( 1 ) - b( 2 ) = xx**3 * b( 2 ) -! - return - end subroutine small1 -!************************************************************************* - subroutine small2 ( xx, cior, calcqe, numang, xmu, qext, qsca, & - gqsc, sforw, sback, s1, s2, tforw, tback, & - a, b ) -! -! small-particle limit of mie quantities for general refractive -! index ( mie series truncated after 2 terms ) -! -! a,b first two mie coefficients, with numerator and -! denominator expanded in powers of -xx- ( a factor -! of xx**3 is missing but is restored before return -! to calling program ) ( ref. 2, p. 1508 ) -! -! ciorsq square of refractive index -! - implicit none - logical calcqe - integer numang,j - real*8 gqsc, qext, qsca, xx, xmu(*) - real*8 twothr,fivthr,sq,rtmp - complex*16 a( 2 ), b( 2 ), cior, sforw, sback, s1(*), s2(*), & - tforw(*), tback(*) -! - parameter ( twothr = 2./3., fivthr = 5./3. ) - complex*16 ctmp, ciorsq - sq( ctmp ) = dble( ctmp )**2 + dimag( ctmp )**2 -! -! - ciorsq = cior**2 - ctmp = dcmplx( 0.d0, twothr ) * ( ciorsq - 1.0 ) - a(1) = ctmp * ( 1.0 - 0.1 * xx**2 + (ciorsq/350. + 1./280.)*xx**4) & - / ( ciorsq + 2.0 + ( 1.0 - 0.7 * ciorsq ) * xx**2 & - - ( ciorsq**2/175. - 0.275 * ciorsq + 0.25 ) * xx**4 & - + xx**3 * ctmp * ( 1.0 - 0.1 * xx**2 ) ) -! - b(1) = (xx**2/30.) * ctmp * ( 1.0 + (ciorsq/35. - 1./14.) *xx**2 ) & - / ( 1.0 - ( ciorsq/15. - 1./6. ) * xx**2 ) -! - a(2) = ( 0.1 * xx**2 ) * ctmp * ( 1.0 - xx**2 / 14. ) & - / ( 2. * ciorsq + 3. - ( ciorsq/7. - 0.5 ) * xx**2 ) -! - qsca = 6. * xx**4 * ( sq(a(1)) + sq(b(1)) + fivthr * sq(a(2)) ) - gqsc = 6. * xx**4 * dble( a(1) * dconjg( a(2) + b(1) ) ) - qext = qsca - if ( calcqe ) qext = 6. * xx * dble( a(1) + b(1) + fivthr * a(2) ) -! - rtmp = 1.5 * xx**3 - sforw = rtmp * ( a(1) + b(1) + fivthr * a(2) ) - sback = rtmp * ( a(1) - b(1) - fivthr * a(2) ) - tforw( 1 ) = rtmp * ( b(1) - fivthr * a(2) ) - tforw( 2 ) = rtmp * ( a(1) + 2. * fivthr * a(2) ) - tback( 1 ) = tforw( 1 ) - tback( 2 ) = rtmp * ( a(1) - 2. * fivthr * a(2) ) -! - do 10 j = 1, numang - s1( j ) = rtmp * ( a(1) + ( b(1) + fivthr * a(2) ) * xmu(j) ) - s2( j ) = rtmp * ( b(1) + a(1) * xmu(j) + fivthr * a(2) & - * ( 2. * xmu(j)**2 - 1. ) ) - 10 continue -! ** recover actual mie coefficients - a( 1 ) = xx**3 * a( 1 ) - a( 2 ) = xx**3 * a( 2 ) - b( 1 ) = xx**3 * b( 1 ) - b( 2 ) = ( 0., 0. ) -! - return - end subroutine small2 -!*********************************************************************** - subroutine testmi ( qext, qsca, gqsc, sforw, sback, s1, s2, & - tforw, tback, pmom, momdim, ok ) -! -! compare mie code test case results with correct answers -! and return ok=false if even one result is inaccurate. -! -! the test case is : mie size parameter = 10 -! refractive index = 1.5 - 0.1 i -! scattering angle = 140 degrees -! 1 sekera moment -! -! results for this case may be found among the test cases -! at the end of reference (1). -! -! *** note *** when running on some computers, esp. in single -! precision, the 'accur' criterion below may have to be relaxed. -! however, if 'accur' must be set larger than 10**-3 for some -! size parameters, your computer is probably not accurate -! enough to do mie computations for those size parameters. -! - implicit none - integer momdim,m,n - real*8 qext, qsca, gqsc, pmom( 0:momdim, * ) - complex*16 sforw, sback, s1(*), s2(*), tforw(*), tback(*) - logical ok, wrong -! - real*8 accur, testqe, testqs, testgq, testpm( 0:1 ) - complex*16 testsf, testsb,tests1,tests2,testtf(2), testtb(2) - data testqe / 2.459791 /, testqs / 1.235144 /, & - testgq / 1.139235 /, testsf / ( 61.49476, -3.177994 ) /, & - testsb / ( 1.493434, 0.2963657 ) /, & - tests1 / ( -0.1548380, -1.128972) /, & - tests2 / ( 0.05669755, 0.5425681) /, & - testtf / ( 12.95238, -136.6436 ), ( 48.54238, 133.4656 ) /, & - testtb / ( 41.88414, -15.57833 ), ( 43.37758, -15.28196 )/, & - testpm / 227.1975, 183.6898 / - real*8 calc,exact -! data accur / 1.e-5 / - data accur / 1.e-4 / - wrong( calc, exact ) = dabs( (calc - exact) / exact ) .gt. accur -! -! - ok = .true. - if ( wrong( qext,testqe ) ) & - call tstbad( 'qext', abs((qext - testqe) / testqe), ok ) - if ( wrong( qsca,testqs ) ) & - call tstbad( 'qsca', abs((qsca - testqs) / testqs), ok ) - if ( wrong( gqsc,testgq ) ) & - call tstbad( 'gqsc', abs((gqsc - testgq) / testgq), ok ) -! - if ( wrong( dble(sforw), dble(testsf) ) .or. & - wrong( dimag(sforw), dimag(testsf) ) ) & - call tstbad( 'sforw', cdabs((sforw - testsf) / testsf), ok ) -! - if ( wrong( dble(sback), dble(testsb) ) .or. & - wrong( dimag(sback), dimag(testsb) ) ) & - call tstbad( 'sback', cdabs((sback - testsb) / testsb), ok ) -! - if ( wrong( dble(s1(1)), dble(tests1) ) .or. & - wrong( dimag(s1(1)), dimag(tests1) ) ) & - call tstbad( 's1', cdabs((s1(1) - tests1) / tests1), ok ) -! - if ( wrong( dble(s2(1)), dble(tests2) ) .or. & - wrong( dimag(s2(1)), dimag(tests2) ) ) & - call tstbad( 's2', cdabs((s2(1) - tests2) / tests2), ok ) -! - do 20 n = 1, 2 - if ( wrong( dble(tforw(n)), dble(testtf(n)) ) .or. & - wrong( dimag(tforw(n)), dimag(testtf(n)) ) ) & - call tstbad( 'tforw', cdabs( (tforw(n) - testtf(n)) / & - testtf(n) ), ok ) - if ( wrong( dble(tback(n)), dble(testtb(n)) ) .or. & - wrong( dimag(tback(n)), dimag(testtb(n)) ) ) & - call tstbad( 'tback', cdabs( (tback(n) - testtb(n)) / & - testtb(n) ), ok ) - 20 continue -! - do 30 m = 0, 1 - if ( wrong( pmom(m,1), testpm(m) ) ) & - call tstbad( 'pmom', dabs( (pmom(m,1)-testpm(m)) / & - testpm(m) ), ok ) - 30 continue -! - return -! - end subroutine testmi -!************************************************************************** - subroutine errmsg( messag, fatal ) -! -! print out a warning or error message; abort if error -! - USE module_peg_util, only: peg_message, peg_error_fatal - - implicit none - logical fatal - logical, save :: once - data once / .false. / - character*80 msg - character*(*) messag - integer, save :: maxmsg, nummsg - data nummsg / 0 /, maxmsg / 100 / -! -! - if ( fatal ) then - write( msg, '(a)' ) & - 'optical averaging mie fatal error ' // & - messag - call peg_message( lunerr, msg ) - call peg_error_fatal( lunerr, msg ) - end if -! - nummsg = nummsg + 1 - if ( nummsg.gt.maxmsg ) then -! if ( .not.once ) write ( *,99 ) - if ( .not.once )then - write( msg, '(a)' ) & - 'optical averaging mie: too many warning messages -- no longer printing ' - call peg_message( lunerr, msg ) - end if - once = .true. - else - msg = 'optical averaging mie warning ' // messag - call peg_message( lunerr, msg ) -! write ( *, '(2a)' ) ' ******* warning >>>>>> ', messag - endif -! - return -! -! 99 format( ///,' >>>>>> too many warning messages -- ', & -! 'they will no longer be printed <<<<<<<', /// ) - end subroutine errmsg -!******************************************************************** - subroutine wrtbad ( varnam, erflag ) -! -! write names of erroneous variables -! -! input : varnam = name of erroneous variable to be written -! ( character, any length ) -! -! output : erflag = logical flag, set true by this routine -! ---------------------------------------------------------------------- - USE module_peg_util, only: peg_message - - implicit none - character*(*) varnam - logical erflag - character*80 msg - integer, save :: maxmsg, nummsg - data nummsg / 0 /, maxmsg / 50 / -! -! - nummsg = nummsg + 1 -! write ( *, '(3a)' ) ' **** input variable ', varnam, & -! ' in error ****' - msg = 'optical averaging mie input variable in error ' // varnam - call peg_message( lunerr, msg ) - erflag = .true. - if ( nummsg.eq.maxmsg ) & - call errmsg ( 'too many input variable errors. aborting...$', .true. ) - return -! - end subroutine wrtbad -!****************************************************************** - subroutine tstbad( varnam, relerr, ok ) -! -! write name (-varnam-) of variable failing self-test and its -! percent error from the correct value. return ok = false. -! - implicit none - character*(*) varnam - logical ok - real*8 relerr -! -! - ok = .false. - write( *, '(/,3a,1p,e11.2,a)' ) & - ' output variable ', varnam,' differed by', 100.*relerr, & - ' per cent from correct value. self-test failed.' - return -! - end subroutine tstbad -!****************************************************************** -! - subroutine sect02(dgnum_um,sigmag,drydens,iflag,duma,nbin,dlo_um,dhi_um, & - xnum_sect,xmas_sect) -! -! user specifies a single log-normal mode and a set of section boundaries -! prog calculates mass and number for each section -! - implicit none - REAL, DIMENSION(nbin), INTENT(OUT) :: xnum_sect, xmas_sect - integer iflag, n, nbin - real & - dgnum, dgnum_um, dhi, dhi_um, dlo, dlo_um, & - drydens, dstar, duma, dumfrac, dx, & - sigmag, sumnum, summas, & - sx, sxroot2, thi, tlo, vtot, & - x0, x3, xhi, xlo, xmtot, xntot, xvtot - real dlo_sect(nbin), dhi_sect(nbin) -! real erfc_num_recipes - real pi - parameter (pi = 3.1415926536) -! - if (iflag .le. 1) then - xntot = duma - else - xmtot = duma - xntot = duma !czhao - end if -! compute total volume and number for mode -! dgnum = dgnum_um*1.0e-4 -! sx = alog( sigmag ) -! x0 = alog( dgnum ) -! x3 = x0 + 3.*sx*sx -! dstar = dgnum * exp(1.5*sx*sx) -! if (iflag .le. 1) then -! xvtot = xntot*(pi/6.0)*dstar*dstar*dstar -! xmtot = xvtot*drydens*1.0e12 -! else -! xvtot = xmtot/(drydens*1.0e12) -! xntot = xvtot/((pi/6.0)*dstar*dstar*dstar) -! end if -! compute section boundaries - dlo = dlo_um*1.0e-4 - dhi = dhi_um*1.0e-4 - xlo = log( dlo ) - xhi = log( dhi ) - dx = (xhi - xlo)/nbin - do n = 1, nbin - dlo_sect(n) = exp( xlo + dx*(n-1) ) - dhi_sect(n) = exp( xlo + dx*n ) - end do -! compute modal "working" parameters including total num/vol/mass - dgnum = dgnum_um*1.0e-4 - sx = alog( sigmag ) - x0 = alog( dgnum ) - x3 = x0 + 3.*sx*sx - dstar = dgnum * exp(1.5*sx*sx) - if (iflag .le. 1) then - xvtot = xntot*(pi/6.0)*dstar*dstar*dstar - xmtot = xvtot*drydens*1.0e12 - else -!czhao xvtot = xmtot/(drydens*1.0e12) -!czhao xntot = xvtot/((pi/6.0)*dstar*dstar*dstar) - end if -! compute number and mass for each section - sxroot2 = sx * sqrt( 2.0 ) - sumnum = 0. - summas = 0. -! write(22,*) -! write(22,*) 'dgnum_um, sigmag = ', dgnum_um, sigmag -! write(22,*) 'drydens =', drydens -! write(22,*) 'ntot (#/cm3), mtot (ug/m3) = ', xntot, xmtot -! write(22,9220) -!9220 format( / & -! ' n dlo(um) dhi(um) number mass' / ) -!9225 format( i3, 2f10.6, 2(1pe13.4) ) -!9230 format( / 'sum over all sections ', 2(1pe13.4) ) -!9231 format( 'modal totals ', 2(1pe13.4) ) - do n = 1, nbin - xlo = alog( dlo_sect(n) ) - xhi = alog( dhi_sect(n) ) - tlo = (xlo - x0)/sxroot2 - thi = (xhi - x0)/sxroot2 - if (tlo .le. 0.) then - dumfrac = 0.5*( erfc_num_recipes(-thi) - erfc_num_recipes(-tlo) ) - else - dumfrac = 0.5*( erfc_num_recipes(tlo) - erfc_num_recipes(thi) ) - end if - xnum_sect(n) = xntot*dumfrac - tlo = (xlo - x3)/sxroot2 - thi = (xhi - x3)/sxroot2 - if (tlo .le. 0.) then - dumfrac = 0.5*( erfc_num_recipes(-thi) - erfc_num_recipes(-tlo) ) - else - dumfrac = 0.5*( erfc_num_recipes(tlo) - erfc_num_recipes(thi) ) - end if - xmas_sect(n) = xmtot*dumfrac - sumnum = sumnum + xnum_sect(n) - summas = summas + xmas_sect(n) -! write(22,9225) n, 1.e4*dlo_sect(n), 1.e4*dhi_sect(n), & -! xnum_sect(n), xmas_sect(n) - end do -! write(22,9230) sumnum, summas -! write(22,9231) xntot, xmtot - - end subroutine sect02 -!----------------------------------------------------------------------- - real function erfc_num_recipes( x ) -! -! from press et al, numerical recipes, 1990, page 164 -! - implicit none - real x - double precision erfc_dbl, dum, t, z - z = abs(x) - t = 1.0/(1.0 + 0.5*z) -! erfc_num_recipes = -! & t*exp( -z*z - 1.26551223 + t*(1.00002368 + t*(0.37409196 + -! & t*(0.09678418 + t*(-0.18628806 + t*(0.27886807 + -! & t*(-1.13520398 + -! & t*(1.48851587 + t*(-0.82215223 + t*0.17087277 ))))))))) - dum = ( -z*z - 1.26551223 + t*(1.00002368 + t*(0.37409196 + & - t*(0.09678418 + t*(-0.18628806 + t*(0.27886807 + & - t*(-1.13520398 + & - t*(1.48851587 + t*(-0.82215223 + t*0.17087277 ))))))))) - erfc_dbl = t * exp(dum) - if (x .lt. 0.0) erfc_dbl = 2.0d0 - erfc_dbl - erfc_num_recipes = erfc_dbl - return - - end function erfc_num_recipes -!----------------------------------------------------------------------- - -!**************************************************************************** -! <1.> subr mieaer_sc -! Purpose: calculate aerosol optical depth, single scattering albedo, -! asymmetry factor, extinction, Legendre coefficients, and average aerosol -! size. parameterizes aerosol coefficients using a full-blown Mie code -! Calculates these properties for either (1) an aerosol internally mixed in a -! shell/core configuration or (2) internally mixed aerosol represented by -! volume averaging of refractive indices -! Uses the ACKMIE code developed eons ago by Tom Ackerman (Ackerman and Toon, 1981: -! absorption of visible radiation in the atmosphere containing mixtures of absorbing and -! non-absorbing particles, Appl. Opt., 20, 3661-3668. -! -! INPUT -! id -- grid id number -! iclm, jclm -- i,j of grid column being processed -! nbin_a -- number of bins -! number_bin_col(nbin_a,kmaxd) -- number density in layer, #/cm^3 -! radius_wet_col(nbin_a,kmaxd) -- wet radius, shell, cm -! radius_core_col(nbin_a,kmaxd) -- core radius, cm; NOTE: -! if this is set to zero, the code will assumed a volume averaging -! of refractive indices -! refindx_col(nbin_a,kmaxd) -- volume complex index of refraction for shell, or -! volume averaged complex index of refraction for the whole aerosol -! in volume averaged mode -! refindx_core_col(nbin_a,kmaxd) -- complex index of refraction for core -! dz -- depth of individual cells in column, m -! curr_secs -- time from start of run, sec -! lpar -- number of grid cells in vertical (via module_fastj_cmnh) -! kmaxd -- predefined maximum allowed levels from module_data_mosaic_other -! passed here via module_fastj_cmnh -! OUTPUT: saved in module_fastj_cmnmie -! real tauaer ! aerosol optical depth -! waer ! aerosol single scattering albedo -! gaer ! aerosol asymmetery factor -! extaer ! aerosol extinction -! l2,l3,l4,l5,l6,l7 ! Legendre coefficients, numbered 0,1,2,...... -! sizeaer ! average wet radius -! bscoef ! aerosol backscatter coefficient with units km-1 * steradian -1 JCB 2007/02/01 -!*********************************************************************** - - - subroutine mieaer_sc( & - id, iclm, jclm, nbin_a, & - number_bin_col, radius_wet_col, refindx_col, & - radius_core_col, refindx_core_col, & ! jcb, 2007/07/25; for shell/core implementation, set radius_cor_col=0 for volume-average configuration - dz, curr_secs, lpar, & - sizeaer,extaer,waer,gaer,tauaer,l2,l3,l4,l5,l6,l7,bscoef) ! added bscoef JCB 2007/02/01 -! -!USE module_data_mosaic_other, only : kmaxd -!USE module_data_mosaic_therm, only : nbin_a_maxd - USE module_peg_util, only : peg_message - - - IMPLICIT NONE -! subr arguments -!jdf -! integer,parameter :: nspint = 4 ! Num of spectral intervals across - ! solar spectrum for FAST-J - integer, intent(in) :: lpar -!jdf real, dimension (nspint, kmaxd+1),intent(out) :: sizeaer,extaer,waer,gaer,tauaer -!jdf real, dimension (nspint, kmaxd+1),intent(out) :: l2,l3,l4,l5,l6,l7 -!jdf real, dimension (nspint, kmaxd+1),intent(out) :: bscoef !JCB 2007/02/01 - real, dimension (nspint, lpar+1),intent(out) :: sizeaer,extaer,waer,gaer,tauaer - real, dimension (nspint, lpar+1),intent(out) :: l2,l3,l4,l5,l6,l7 - real, dimension (nspint, lpar+1),intent(out) :: bscoef !JCB 2007/02/01 - real, dimension (nspint),save :: wavmid !cm - data wavmid & - / 0.30e-4, 0.40e-4, 0.60e-4 ,0.999e-04 / -!jdf - integer, intent(in) :: id, iclm, jclm, nbin_a - real(kind=8), intent(in) :: curr_secs -!jdf real, intent(in), dimension(nbin_a, kmaxd) :: number_bin_col -!jdf real, intent(inout), dimension(nbin_a, kmaxd) :: radius_wet_col -!jdf complex, intent(in) :: refindx_col(nbin_a, kmaxd) - real, intent(in), dimension(nbin_a, lpar+1) :: number_bin_col - real, intent(inout), dimension(nbin_a, lpar+1) :: radius_wet_col, radius_core_col ! jcb 2007/07/25 - complex, intent(in) :: refindx_col(nbin_a, lpar+1), refindx_core_col(nbin_a,lpar+1) ! jcb 2007/07/25, - real, intent(in) :: dz(lpar) - real thesum, sum ! for normalizing things and testing -! - integer m,l,j,nl,ll,nc,klevel - integer ns, & ! Spectral loop index - i, & ! Longitude loop index - k ! Level loop index - - real*8 dp_wet_a,dp_core_a - complex*16 ri_shell_a,ri_core_a - real*8 qextc,qscatc,qbackc,extc,scatc,backc,gscac - real*8 vlambc - integer n,kkk,jjj - integer, save :: kcallmieaer - data kcallmieaer / 0 / - real*8 pmom(0:7,1) - real weighte, weights, pscat - real pie,sizem - real ratio -! - real,save ::rmin,rmax ! min, max aerosol size bin -! data rmin /0.005e-04/ ! rmin in cm, 5e-3 microns min allowable size -! data rmax /50.0e-04/ ! rmax in cm. 50 microns, big particle, max allowable size - data rmin /0.010e-04/ ! rmin in cm, 5e-3 microns min allowable size - data rmax /7.0e-04/ ! rmax in cm. 50 microns, big particle, max allowable size -! diagnostic declarations - integer, save :: kcallmieaer2 - data kcallmieaer2 / 0 / - integer ibin - character*150 msg - -#if (defined(CHEM_DBG_I) && defined(CHEM_DBG_J) && defined(CHEM_DBG_K)) -!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!ec diagnostics -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!ec run_out.25 has aerosol physical parameter info for bins 1-8 -!ec and vertical cells 1 to kmaxd. -! ilaporte = 33 -! jlaporte = 34 - kcallmieaer2=0 - if (iclm .eq. CHEM_DBG_I) then - if (jclm .eq. CHEM_DBG_J) then -! initial entry - if (kcallmieaer2 .eq. 0) then - write(*,9099)iclm, jclm - 9099 format('for cell i = ', i3, 2x, 'j = ', i3) - write(*,9100) - 9100 format( & - 'curr_secs', 3x, 'i', 3x, 'j', 3x,'k', 3x, & - 'ibin', 3x, & - 'refindx_col(ibin,k)', 3x, & - 'radius_wet_col(ibin,k)', 3x, & - 'number_bin_col(ibin,k)' & - ) - end if -!ec output for run_out.25 - do k = 1, lpar - do ibin = 1, nbin_a - write(*, 9120) & - curr_secs,iclm, jclm, k, ibin, & - refindx_col(ibin,k), & - radius_wet_col(ibin,k), & - number_bin_col(ibin,k) -9120 format( i7,3(2x,i4),2x,i4, 4x, 4(e14.6,2x)) - end do - end do - kcallmieaer2 = kcallmieaer2 + 1 - end if - end if -!ec end print of aerosol physical parameter diagnostics -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -#endif -! -! loop over levels - do 2000 klevel=1,lpar - thesum=0.0 - do m=1,nbin_a - thesum=thesum+number_bin_col(m,klevel) - enddo - pie=4.*atan(1.) -! Begin spectral loop - do 1000 ns=1,nspint -! aerosol optical properties - tauaer(ns,klevel)=0. - waer(ns,klevel)=0. - gaer(ns,klevel)=0. - sizeaer(ns,klevel)=0.0 - extaer(ns,klevel)=0.0 - l2(ns,klevel)=0.0 - l3(ns,klevel)=0.0 - l4(ns,klevel)=0.0 - l5(ns,klevel)=0.0 - l6(ns,klevel)=0.0 - l7(ns,klevel)=0.0 - bscoef(ns,klevel)=0.0 - if(thesum.le.1.e-21)goto 1000 ! set everything = 0 if no aerosol ! wig changed 0.0 to 1e-21 - -! loop over the bins, nbin_a is the number of bins - do m=1,nbin_a -! check to see if there's any aerosol -!jdf if(number_bin_col(m,klevel).le.1e-21)goto 70 ! no aerosol wig changed 0.0 to 1e-21, 31-Oct-2005 -! here's the size - sizem=radius_wet_col(m,klevel) ! radius in cm - ratio=radius_core_col(m,klevel)/radius_wet_col(m,klevel) -! check limits of particle size -! rce 2004-dec-07 - use klevel in write statements - if(radius_wet_col(m,klevel).le.rmin)then - radius_wet_col(m,klevel)=rmin - radius_core_col(m,klevel)=rmin*ratio - write( msg, '(a, 5i4,1x, e11.4)' ) & - 'mieaer_sc: radius_wet set to rmin,' // & - 'id,i,j,k,m,rm(m,k)', id, iclm, jclm, klevel, m, radius_wet_col(m,klevel) - call peg_message( lunerr, msg ) -! write(6,'('' particle size too small '')') - endif -! - if(radius_wet_col(m,klevel).gt.rmax)then - write( msg, '(a, 5i4,1x, e11.4)' ) & - 'mieaer_sc: radius_wet set to rmax,' // & - 'id,i,j,k,m,rm(m,k)', & - id, iclm, jclm, klevel, m, radius_wet_col(m,klevel) - call peg_message( lunerr, msg ) - radius_wet_col(m,klevel)=rmax - radius_core_col(m,klevel)=rmax*ratio -! write(6,'('' particle size too large '')') - endif -! - ri_shell_a=dcmplx(real(refindx_col(m,klevel)),abs(aimag(refindx_col(m,klevel)))) ! need positive complex part of refractive index here - ri_core_a=dcmplx(real(refindx_core_col(m,klevel)),abs(aimag(refindx_core_col(m,klevel)))) ! need positive complex part of refractive index here -! - dp_wet_a= 2.0*radius_wet_col(m,klevel)*1.0e04 ! radius_wet is in cm,dp_wet_a should be in microns - dp_core_a=2.0*radius_core_col(m,klevel)*1.0e04 - vlambc=wavmid(ns)*1.0e04 -! -! write(6,*)dp_wet_a -! write(6,*)ri_shell_a -! write(6,*)vlambc - call miedriver(dp_wet_a,dp_core_a,ri_shell_a,ri_core_a, vlambc, & - qextc,qscatc,gscac,extc,scatc,qbackc,backc,pmom) -! check, note that pmom(1,1)/pmom(0,1) is indeed the asymmetry parameter as calculated by Tom's code, jcb, July 7, 2007 -! correct in the Rayleigh limit, July 3, 2007: jcb -! write(6,*) -! do ii=0,7 -! write(6,*)pmom(ii,1),pmom(ii,1)/pmom(0,1) -! enddo -! write(6,*)qextc,qscatc,gscac,extc,scatc -! write(6,*) -! - weighte=extc*1.0e-08 ! extinction cross section, converted to cm^2 - weights=scatc*1.0e-08 ! scattering cross section, converted to cm^2 - tauaer(ns,klevel)=tauaer(ns,klevel)+weighte* & - number_bin_col(m,klevel) ! must be multiplied by deltaZ - sizeaer(ns,klevel)=sizeaer(ns,klevel)+radius_wet_col(m,klevel)*10000.0* & - number_bin_col(m,klevel) - waer(ns,klevel)=waer(ns,klevel)+weights*number_bin_col(m,klevel) - gaer(ns,klevel)=gaer(ns,klevel)+gscac*weights* & - number_bin_col(m,klevel) - l2(ns,klevel)=l2(ns,klevel)+weights*pmom(2,1)/pmom(0,1)*5.0*number_bin_col(m,klevel) - l3(ns,klevel)=l3(ns,klevel)+weights*pmom(3,1)/pmom(0,1)*7.0*number_bin_col(m,klevel) - l4(ns,klevel)=l4(ns,klevel)+weights*pmom(4,1)/pmom(0,1)*9.0*number_bin_col(m,klevel) - l5(ns,klevel)=l5(ns,klevel)+weights*pmom(5,1)/pmom(0,1)*11.0*number_bin_col(m,klevel) - l6(ns,klevel)=l6(ns,klevel)+weights*pmom(6,1)/pmom(0,1)*13.0*number_bin_col(m,klevel) - l7(ns,klevel)=l7(ns,klevel)+weights*pmom(7,1)/pmom(0,1)*15.0*number_bin_col(m,klevel) -! the 4*pi gives the correct value in the Rayleigh limit compared with the old core, which we assume is correct - bscoef(ns,klevel)=bscoef(ns,klevel)+backc*1.0e-08*number_bin_col(m,klevel)*4.0*pie ! converting cross-section from microns ^2 to cm^2, 4*pie needed -2001 continue - end do ! end of nbin loop -! take averages - sizeaer(ns,klevel)=sizeaer(ns,klevel)/thesum - gaer(ns,klevel)=gaer(ns,klevel)/waer(ns,klevel) - l2(ns,klevel)=l2(ns,klevel)/waer(ns,klevel) - l3(ns,klevel)=l3(ns,klevel)/waer(ns,klevel) - l4(ns,klevel)=l4(ns,klevel)/waer(ns,klevel) - l5(ns,klevel)=l5(ns,klevel)/waer(ns,klevel) - l6(ns,klevel)=l6(ns,klevel)/waer(ns,klevel) - l7(ns,klevel)=l7(ns,klevel)/waer(ns,klevel) -! write(6,*)ns,klevel,l4(ns,klevel) -! this is beta, not beta/(4*pie) - bscoef(ns,klevel)=bscoef(ns,klevel)*1.0e5 ! unit (km)^-1 -! SSA checked by comparson with Travis and Hansen, get exact result - waer(ns,klevel)=waer(ns,klevel)/tauaer(ns,klevel) ! must be last - extaer(ns,klevel)=tauaer(ns,klevel)*1.0e5 ! unit (km)^-1 - 70 continue ! end of nbin_a loop - 1000 continue ! end of wavelength loop -2000 continue ! end of klevel loop -! before returning, multiply tauaer by depth of individual cells. -! tauaer is in cm-1, dz in m; multiply dz by 100 to convert from m to cm. - do ns = 1, nspint - do klevel = 1, lpar - tauaer(ns,klevel) = tauaer(ns,klevel) * dz(klevel)* 100. - end do - end do -! -#if (defined(CHEM_DBG_I) && defined(CHEM_DBG_J) && defined(CHEM_DBG_K)) -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!ec fastj diagnostics -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!ec run_out.30 has aerosol optical info for cells 1 to kmaxd. -! ilaporte = 33 -! jlaporte = 34 - if (iclm .eq. CHEM_DBG_I) then - if (jclm .eq. CHEM_DBG_J) then -! initial entry - if (kcallmieaer .eq. 0) then - write(*,909) CHEM_DBG_I, CHEM_DBG_J - 909 format( ' for cell i = ', i3, ' j = ', i3) - write(*,910) - 910 format( & - 'curr_secs', 3x, 'i', 3x, 'j', 3x,'k', 3x, & - 'dzmfastj', 8x, & - 'tauaer(1,k)',1x, 'tauaer(2,k)',1x,'tauaer(3,k)',3x, & - 'tauaer(4,k)',5x, & - 'waer(1,k)', 7x, 'waer(2,k)', 7x,'waer(3,k)', 7x, & - 'waer(4,k)', 7x, & - 'gaer(1,k)', 7x, 'gaer(2,k)', 7x,'gaer(3,k)', 7x, & - 'gaer(4,k)', 7x, & - 'extaer(1,k)',5x, 'extaer(2,k)',5x,'extaer(3,k)',5x, & - 'extaer(4,k)',5x, & - 'sizeaer(1,k)',4x, 'sizeaer(2,k)',4x,'sizeaer(3,k)',4x, & - 'sizeaer(4,k)' ) - end if -!ec output for run_out.30 - do k = 1, lpar - write(*, 912) & - curr_secs,iclm, jclm, k, & - dz(k) , & - (tauaer(n,k), n=1,4), & - (waer(n,k), n=1,4), & - (gaer(n,k), n=1,4), & - (extaer(n,k), n=1,4), & - (sizeaer(n,k), n=1,4) - 912 format( i7,3(2x,i4),2x,21(e14.6,2x)) - end do - kcallmieaer = kcallmieaer + 1 - end if - end if -!ec end print of fastj diagnostics -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -#endif -! - return - end subroutine mieaer_sc -! - subroutine miedriver(dp_wet_a,dp_core_a,ri_shell_a,ri_core_a, vlambc, & - qextc,qscatc,gscac,extc,scatc,qbackc,backc,pmom) -! MOSAIC INPUTS -! dp_wet_a = diameter (cm) of aerosol -! dp_core_a = diameter (cm) of the aerosol's core -! ri_shell_a = refractive index (complex) of shell -! ri_core_a = refractve index (complex ) of core (usually assumed to be LAC) -! vlambc = wavelength of calculation (um, convert to cm) -! MOSAIC outputs -! qextc = scattering efficiency -! qscac = scattering efficiency -! gscac = asymmetry parameter -! extc = extinction cross section (cm^2) -! scac = scattering cross section (cm^2) -! drives concentric sphere program -! /*---------------------------------------------------------------*/ -! /* INPUTS: */ -! /*---------------------------------------------------------------*/ - -! VLAMBc: Wavelength of the radiation -! NRGFLAGc: Flag to indicate a number density of volume radius -! RGc: Number (RGN = Rm) or volume (RGV) weighted mean radius of -! the particle size distribution -! SIGMAGc: Geometric standard deviation of the distribution -! SHELRc: Real part of the index of refraction for the shell -! SHELIc: Imaginary part of the index of refraction for the shell -! RINc: Inner core radius as a fraction of outer shell radius -! CORERc: Real part of the index of refraction for the core -! COREIc: Imaginary part of the index of refraction for the core -! NANG: Number of scattering angles between 0 and 90 degrees, -! inclusive - -! /*---------------------------------------------------------------*/ -! /* OUTPUTS: */ -! /*---------------------------------------------------------------*/ - -! QEXTc: Extinction efficiency of the particle -! QSCAc: Scattering efficiency of the particle -! QBACKc: Backscatter efficiency of the particle -! EXTc: Extinction cross section of the particle -! SCAc: Scattering cross section of the particle -! BACKc: Backscatter cross section of the particle -! GSCA: Asymmetry parameter of the particles phase function -! ANGLES(NAN): Scattering angles in degrees -! S1R(NAN): Real part of the amplitude scattering matrix -! S1C(NAN): Complex part of the amplitude scattering matrix -! S2R(NAN): Real part of the amplitude scattering matrix -! S2C(NAN): Complex part of the amplitude scattering matrix -! S11N: Normalization coefficient of the scattering matrix -! S11(NAN): S11 scattering coefficients -! S12(NAN): S12 scattering coefficients -! S33(NAN): S33 scattering coefficients -! S34(NAN): S34 scattering coefficients -! SPOL(NAN): Degree of polarization of unpolarized, incident light -! SP(NAN): Phase function -! -! NOTE: NAN=2*NANG-1 is the number of scattering angles between -! 0 and 180 degrees, inclusive. -! /*---------------------------------------------------------------*/ - REAL*8 VLAMBc,RGcmin,RGcmax,RGc,SIGMAGc,SHELRc,SHELIc - REAL*8 RINc,CORERc,COREIc - INTEGER*4 NRGFLAGc,NANG - REAL*8 QEXTc,QSCATc,QBACKc,EXTc,SCATc,BACKc,GSCAc - REAL*8 ANGLESc(200),S1R(200),S1C(200),S2R(200),S2C(200) - REAL*8 S11N,S11(200),S12(200),S33(200),S34(200),SPOL(200),SP(200) - real*8 pmom(0:7,1) - real*8 dp_wet_a,dp_core_a - complex*16 ri_shell_a,ri_core_a -! - nang=2 ! only one angle - nrgflagc=0 ! size distribution -! - rgc=dp_wet_a/2.0 ! radius of particle - rinc=dp_core_a/dp_wet_a ! fraction of radius that is the core - rgcmin=0.001 - rgcmax=5.0 - sigmagc=1.0 ! no particle size dispersion - shelrc=real(ri_shell_a) - shelic=aimag(ri_shell_a) - corerc=real(ri_core_a) - coreic=aimag(ri_core_a) - CALL ACKMIEPARTICLE( VLAMBc,NRGFLAGc,RGcmin,RGcmax, & - RGc,SIGMAGc,SHELRc, & - SHELIc, RINc,CORERc,COREIc,NANG,QEXTc,QSCATc, & - QBACKc, EXTc,SCATc,BACKc, GSCAc, & - ANGLESc,S1R,S1C,S2R,S2C,S11N,S11,S12,S33,S34,SPOL,SP,pmom) ! jcb -! write(6,1010)rgc,qextc,qscatc,qscatc/qextc,gscac -1010 format(5f20.12) -1020 format(2f12.6) - end subroutine miedriver -! -! /*--------------------------------------------------------*/ -! /* The Toon-Ackerman SUBROUTINE DMIESS for calculating the*/ -! /* scatter off of a coated sphere of some sort. */ -! /* Toon and Ackerman, Applied Optics, Vol. 20, Pg. 3657 */ -! /*--------------------------------------------------------*/ - -!********************************************** - - SUBROUTINE DMIESS( RO, RFR, RFI, THETD, JX, & - QEXT, QSCAT, CTBRQS, ELTRMX, PIE, & - TAU, CSTHT, SI2THT, ACAP, QBS, IT, & - LL, R, RE2, TMAG2, WVNO, an,bn, ntrm ) -! -! ********************************************************************** -! THIS SUBROUTINE COMPUTES MIE SCATTERING BY A STRATIFIED SPHERE, -! I.E. A PARTICLE CONSISTING OF A SPHERICAL CORE SURROUNDED BY A -! SPHERICAL SHELL. THE BASIC CODE USED WAS THAT DESCRIBED IN THE -! REPORT: SUBROUTINES FOR COMPUTING THE PARAMETERS OF THE -! ELECTROMAGNETIC RADIATION SCATTERED BY A SPHERE J.V. DAVE, -! I B M SCIENTIFIC CENTER, PALO ALTO , CALIFORNIA. -! REPORT NO. 320 - 3236 .. MAY 1968 . -! -! THE MODIFICATIONS FOR STRATIFIED SPHERES ARE DESCRIBED IN -! TOON AND ACKERMAN, APPL. OPTICS, IN PRESS, 1981 -! -! THE PARAMETERS IN THE CALLING STATEMENT ARE DEFINED AS FOLLOWS : -! RO IS THE OUTER (SHELL) RADIUS; -! R IS THE CORE RADIUS; -! RFR, RFI ARE THE REAL AND IMAGINARY PARTS OF THE SHELL INDEX -! OF REFRACTION IN THE FORM (RFR - I* RFI); -! RE2, TMAG2 ARE THE INDEX PARTS FOR THE CORE; -! ( WE ASSUME SPACE HAS UNIT INDEX. ) -! THETD(J): ANGLE IN DEGREES BETWEEN THE DIRECTIONS OF THE INCIDENT -! AND THE SCATTERED RADIATION. THETD(J) IS< OR= 90.0 -! IF THETD(J) SHOULD HAPPEN TO BE GREATER THAN 90.0, ENTER WITH -! SUPPLEMENTARY VALUE, SEE COMMENTS BELOW ON ELTRMX; -! JX: TOTAL NUMBER OF THETD FOR WHICH THE COMPUTATIONS ARE -! REQUIRED. JX SHOULD NOT EXCEED IT UNLESS THE DIMENSIONS -! STATEMENTS ARE APPROPRIATEDLY MODIFIED; -! -! THE DEFINITIONS FOR THE FOLLOWING SYMBOLS CAN BE FOUND IN LIGHT -! SCATTERING BY SMALL PARTICLES, H.C.VAN DE HULST, JOHN WILEY -! SONS, INC., NEW YORK, 1957. -! QEXT: EFFIECIENCY FACTOR FOR EXTINCTION,VAN DE HULST,P.14 127. -! QSCAT: EFFIECINCY FACTOR FOR SCATTERING,V.D. HULST,P.14 127. -! CTBRQS: AVERAGE(COSINE THETA) * QSCAT,VAN DE HULST,P.128 -! ELTRMX(I,J,K): ELEMENTS OF THE TRANSFORMATION MATRIX F,V.D.HULST -! ,P.34,45 125. I=1: ELEMENT M SUB 2..I=2: ELEMENT M SUB 1.. -! I = 3: ELEMENT S SUB 21.. I = 4: ELEMENT D SUB 21.. -! ELTRMX(I,J,1) REPRESENTS THE ITH ELEMENT OF THE MATRIX FOR -! THE ANGLE THETD(J).. ELTRMX(I,J,2) REPRESENTS THE ITH ELEMENT -! OF THE MATRIX FOR THE ANGLE 180.0 - THETD(J) .. -! QBS IS THE BACK SCATTER CROSS SECTION. -! -! IT: IS THE DIMENSION OF THETD, ELTRMX, CSTHT, PIE, TAU, SI2THT, -! IT MUST CORRESPOND EXACTLY TO THE SECOND DIMENSION OF ELTRMX. -! LL: IS THE DIMENSION OF ACAP -! IN THE ORIGINAL PROGRAM THE DIMENSION OF ACAP WAS 7000. -! FOR CONSERVING SPACE THIS SHOULD BE NOT MUCH HIGHER THAN -! THE VALUE, N=1.1*(NREAL**2 + NIMAG**2)**.5 * X + 1 -! WVNO: 2*PIE / WAVELENGTH -! -! ALSO THE SUBROUTINE COMPUTES THE CAPITAL A FUNCTION BY MAKING USE O -! DOWNWARD RECURRENCE RELATIONSHIP. -! -! TA(1): REAL PART OF WFN(1). TA(2): IMAGINARY PART OF WFN(1). -! TA(3): REAL PART OF WFN(2). TA(4): IMAGINARY PART OF WFN(2). -! TB(1): REAL PART OF FNA. TB(2): IMAGINARY PART OF FNA. -! TC(1): REAL PART OF FNB. TC(2): IMAGINARY PART OF FNB. -! TD(1): REAL PART OF FNAP. TD(2): IMAGINARY PART OF FNAP. -! TE(1): REAL PART OF FNBP. TE(2): IMAGINARY PART OF FNBP. -! FNAP, FNBP ARE THE PRECEDING VALUES OF FNA, FNB RESPECTIVELY. -! ********************************************************************** - -! /*--------------------------------------------------------------*/ -! /* Initially, make all types undefined. */ -! /*--------------------------------------------------------------*/ - -! IMPLICIT UNDEFINED(A-Z) - -! /*--------------------------------------------------------*/ -! /* Dimension statements. */ -! /*--------------------------------------------------------*/ - - INTEGER*4 JX, IT, LL - - REAL*8 RO, RFR, RFI, THETD(IT), QEXT, QSCAT, CTBRQS, & - ELTRMX(4,IT,2), PIE(3,IT), TAU(3,IT), CSTHT(IT), & - SI2THT(IT), QBS, R, RE2, TMAG2, WVNO - - COMPLEX*16 ACAP(LL) - -! /*--------------------------------------------------------*/ -! /* Variables used in the calculations below. */ -! /*--------------------------------------------------------*/ - - INTEGER*4 IFLAG, J, K, M, N, NN, NMX1, NMX2 - - REAL*8 T(5), TA(4), TB(2), TC(2), TD(2), TE(2), X, & - RX, X1, Y1, X4, Y4, SINX1, SINX4, COSX1, COSX4, & - EY1, E2Y1, EY4, EY1MY4, EY1PY4, AA, BB, & - CC, DD, DENOM, REALP, AMAGP, QBSR, QBSI, RMM, & - PIG, RXP4 -! - COMPLEX*16 FNAP, FNBP, W, & - FNA, FNB, RF, RRF, & - RRFX, WM1, FN1, FN2, & - TC1, TC2, WFN(2), Z(4), & - K1, K2, K3, & - RC, U(8), DH1, & - DH2, DH4, P24H24, P24H21, & - PSTORE, HSTORE, DUMMY, DUMSQ -! jcb - complex*16 an(500),bn(500) ! a,b Mie coefficients, jcb Hansen and Travis, eqn 2.44 - integer*4 ntrm -! -! /*--------------------------------------------------------*/ -! /* Define the common block. */ -! /*--------------------------------------------------------*/ - - COMMON / WARRAY / W(3,9000) - - - -! -! EQUIVALENCE (FNA,TB(1)),(FNB,TC(1)),(FNAP,TD(1)),(FNBP,TE(1)) -! -! IF THE CORE IS SMALL SCATTERING IS COMPUTED FOR THE SHELL ONLY -! - -! /*--------------------------------------------------------*/ -! /* Begin the Mie calculations. */ -! /*--------------------------------------------------------*/ - IFLAG = 1 - ntrm=0 ! jcb - IF ( R/RO .LT. 1.0D-06 ) IFLAG = 2 - IF ( JX .LE. IT ) GO TO 20 - WRITE( 6,7 ) - WRITE( 6,6 ) - call errmsg( 'DMIESS: 30', .true.) - 20 RF = CMPLX( RFR, -RFI ) - RC = CMPLX( RE2,-TMAG2 ) - X = RO * WVNO - K1 = RC * WVNO - K2 = RF * WVNO - K3 = CMPLX( WVNO, 0.0D0 ) - Z(1) = K2 * RO - Z(2) = K3 * RO - Z(3) = K1 * R - Z(4) = K2 * R - X1 = DREAL( Z(1) ) - Y1 = DIMAG( Z(1) ) - X4 = DREAL( Z(4) ) - Y4 = DIMAG( Z(4) ) - RRF = 1.0D0 / RF - RX = 1.0D0 / X - RRFX = RRF * RX - T(1) = ( X**2 ) * ( RFR**2 + RFI**2 ) - T(1) = DSQRT( T(1) ) - NMX1 = 1.30D0* T(1) -! - IF ( NMX1 .LE. LL-1 ) GO TO 21 - WRITE(6,8) - call errmsg( 'DMIESS: 32', .true.) - 21 NMX2 = T(1) * 1.2 - nmx1=min(nmx1+5,150) ! jcb - nmx2=min(nmx2+5,135) ! jcb -! write(6,*)x,nmx1,nmx2,ll ! jcb -! stop - IF ( NMX1 .GT. 150 ) GO TO 22 -! NMX1 = 150 -! NMX2 = 135 -! - 22 ACAP( NMX1+1 ) = ( 0.0D0,0.0D0 ) - IF ( IFLAG .EQ. 2 ) GO TO 26 - DO 29 N = 1,3 - 29 W( N,NMX1+1 ) = ( 0.0D0,0.0D0 ) - 26 CONTINUE - DO 23 N = 1,NMX1 - NN = NMX1 - N + 1 - ACAP(NN) = (NN+1)*RRFX - 1.0D0 / ((NN+1)*RRFX + ACAP(NN+1)) - IF ( IFLAG .EQ. 2 ) GO TO 23 - DO 31 M = 1,3 - 31 W( M,NN ) = (NN+1) / Z(M+1) - & - 1.0D0 / ((NN+1) / Z(M+1) + W( M,NN+1 )) - 23 CONTINUE -! - DO 30 J = 1,JX - IF ( THETD(J) .LT. 0.0D0 ) THETD(J) = DABS( THETD(J) ) - IF ( THETD(J) .GT. 0.0D0 ) GO TO 24 - CSTHT(J) = 1.0D0 - SI2THT(J) = 0.0D0 - GO TO 30 - 24 IF ( THETD(J) .GE. 90.0D0 ) GO TO 25 - T(1) = ( 3.14159265359 * THETD(J) ) / 180.0D0 - CSTHT(J) = DCOS( T(1) ) - SI2THT(J) = 1.0D0 - CSTHT(J)**2 - GO TO 30 - 25 IF ( THETD(J) .GT. 90.0 ) GO TO 28 - CSTHT(J) = 0.0D0 - SI2THT(J) = 1.0D0 - GO TO 30 - 28 WRITE( 6,5 ) THETD(J) - WRITE( 6,6 ) - call errmsg( 'DMIESS: 34', .true.) - 30 CONTINUE -! - DO 35 J = 1,JX - PIE(1,J) = 0.0D0 - PIE(2,J) = 1.0D0 - TAU(1,J) = 0.0D0 - TAU(2,J) = CSTHT(J) - 35 CONTINUE -! -! INITIALIZATION OF HOMOGENEOUS SPHERE -! - T(1) = DCOS(X) - T(2) = DSIN(X) - WM1 = CMPLX( T(1),-T(2) ) - WFN(1) = CMPLX( T(2), T(1) ) - TA(1) = T(2) - TA(2) = T(1) - WFN(2) = RX * WFN(1) - WM1 - TA(3) = DREAL(WFN(2)) - TA(4) = DIMAG(WFN(2)) -! - n=1 ! jcb, bug??? - IF ( IFLAG .EQ. 2 ) GO TO 560 - N = 1 -! -! INITIALIZATION PROCEDURE FOR STRATIFIED SPHERE BEGINS HERE -! - SINX1 = DSIN( X1 ) - SINX4 = DSIN( X4 ) - COSX1 = DCOS( X1 ) - COSX4 = DCOS( X4 ) - EY1 = DEXP( Y1 ) - E2Y1 = EY1 * EY1 - EY4 = DEXP( Y4 ) - EY1MY4 = DEXP( Y1 - Y4 ) - EY1PY4 = EY1 * EY4 - EY1MY4 = DEXP( Y1 - Y4 ) - AA = SINX4 * ( EY1PY4 + EY1MY4 ) - BB = COSX4 * ( EY1PY4 - EY1MY4 ) - CC = SINX1 * ( E2Y1 + 1.0D0 ) - DD = COSX1 * ( E2Y1 - 1.0D0 ) - DENOM = 1.0D0 + E2Y1 * (4.0D0*SINX1*SINX1 - 2.0D0 + E2Y1) - REALP = ( AA * CC + BB * DD ) / DENOM - AMAGP = ( BB * CC - AA * DD ) / DENOM - DUMMY = CMPLX( REALP, AMAGP ) - AA = SINX4 * SINX4 - 0.5D0 - BB = COSX4 * SINX4 - P24H24 = 0.5D0 + CMPLX( AA,BB ) * EY4 * EY4 - AA = SINX1 * SINX4 - COSX1 * COSX4 - BB = SINX1 * COSX4 + COSX1 * SINX4 - CC = SINX1 * SINX4 + COSX1 * COSX4 - DD = -SINX1 * COSX4 + COSX1 * SINX4 - P24H21 = 0.5D0 * CMPLX( AA,BB ) * EY1 * EY4 + & - 0.5D0 * CMPLX( CC,DD ) * EY1MY4 - DH4 = Z(4) / (1.0D0 + (0.0D0,1.0D0) * Z(4)) - 1.0D0 / Z(4) - DH1 = Z(1) / (1.0D0 + (0.0D0,1.0D0) * Z(1)) - 1.0D0 / Z(1) - DH2 = Z(2) / (1.0D0 + (0.0D0,1.0D0) * Z(2)) - 1.0D0 / Z(2) - PSTORE = ( DH4 + N / Z(4) ) * ( W(3,N) + N / Z(4) ) - P24H24 = P24H24 / PSTORE - HSTORE = ( DH1 + N / Z(1) ) * ( W(3,N) + N / Z(4) ) - P24H21 = P24H21 / HSTORE - PSTORE = ( ACAP(N) + N / Z(1) ) / ( W(3,N) + N / Z(4) ) - DUMMY = DUMMY * PSTORE - DUMSQ = DUMMY * DUMMY -! -! NOTE: THE DEFINITIONS OF U(I) IN THIS PROGRAM ARE NOT THE SAME AS -! THE USUBI DEFINED IN THE ARTICLE BY TOON AND ACKERMAN. THE -! CORRESPONDING TERMS ARE: -! USUB1 = U(1) USUB2 = U(5) -! USUB3 = U(7) USUB4 = DUMSQ -! USUB5 = U(2) USUB6 = U(3) -! USUB7 = U(6) USUB8 = U(4) -! RATIO OF SPHERICAL BESSEL FTN TO SPHERICAL HENKAL FTN = U(8) -! - U(1) = K3 * ACAP(N) - K2 * W(1,N) - U(2) = K3 * ACAP(N) - K2 * DH2 - U(3) = K2 * ACAP(N) - K3 * W(1,N) - U(4) = K2 * ACAP(N) - K3 * DH2 - U(5) = K1 * W(3,N) - K2 * W(2,N) - U(6) = K2 * W(3,N) - K1 * W(2,N) - U(7) = ( 0.0D0,-1.0D0 ) * ( DUMMY * P24H21 - P24H24 ) - U(8) = TA(3) / WFN(2) -! - FNA = U(8) * ( U(1)*U(5)*U(7) + K1*U(1) - DUMSQ*K3*U(5) ) / & - ( U(2)*U(5)*U(7) + K1*U(2) - DUMSQ*K3*U(5) ) - FNB = U(8) * ( U(3)*U(6)*U(7) + K2*U(3) - DUMSQ*K2*U(6) ) / & - ( U(4)*U(6)*U(7) + K2*U(4) - DUMSQ*K2*U(6) ) -! -! Explicit equivalences added by J. Francis - - TB(1) = DREAL(FNA) - TB(2) = DIMAG(FNA) - TC(1) = DREAL(FNB) - TC(2) = DIMAG(FNB) - GO TO 561 - 560 TC1 = ACAP(1) * RRF + RX - TC2 = ACAP(1) * RF + RX - FNA = ( TC1 * TA(3) - TA(1) ) / ( TC1 * WFN(2) - WFN(1) ) - FNB = ( TC2 * TA(3) - TA(1) ) / ( TC2 * WFN(2) - WFN(1) ) - TB(1) = DREAL(FNA) - TB(2) = DIMAG(FNA) - TC(1) = DREAL(FNB) - TC(2) = DIMAG(FNB) -! - 561 CONTINUE -! jcb - ntrm=ntrm+1 - an(n)=fna - bn(n)=fnb -! write(6,1010)ntrm,n,an(n),bn(n) -1010 format(2i5,4e15.6) -! jcb - FNAP = FNA - FNBP = FNB - TD(1) = DREAL(FNAP) - TD(2) = DIMAG(FNAP) - TE(1) = DREAL(FNBP) - TE(2) = DIMAG(FNBP) - T(1) = 1.50D0 -! -! FROM HERE TO THE STATMENT NUMBER 90, ELTRMX(I,J,K) HAS -! FOLLOWING MEANING: -! ELTRMX(1,J,K): REAL PART OF THE FIRST COMPLEX AMPLITUDE. -! ELTRMX(2,J,K): IMAGINARY PART OF THE FIRST COMPLEX AMPLITUDE. -! ELTRMX(3,J,K): REAL PART OF THE SECOND COMPLEX AMPLITUDE. -! ELTRMX(4,J,K): IMAGINARY PART OF THE SECOND COMPLEX AMPLITUDE. -! K = 1 : FOR THETD(J) AND K = 2 : FOR 180.0 - THETD(J) -! DEFINITION OF THE COMPLEX AMPLITUDE: VAN DE HULST,P.125. -! - TB(1) = T(1) * TB(1) - TB(2) = T(1) * TB(2) - TC(1) = T(1) * TC(1) - TC(2) = T(1) * TC(2) -! DO 60 J = 1,JX -! ELTRMX(1,J,1) = TB(1) * PIE(2,J) + TC(1) * TAU(2,J) -! ELTRMX(2,J,1) = TB(2) * PIE(2,J) + TC(2) * TAU(2,J) -! ELTRMX(3,J,1) = TC(1) * PIE(2,J) + TB(1) * TAU(2,J) -! ELTRMX(4,J,1) = TC(2) * PIE(2,J) + TB(2) * TAU(2,J) -! ELTRMX(1,J,2) = TB(1) * PIE(2,J) - TC(1) * TAU(2,J) -! ELTRMX(2,J,2) = TB(2) * PIE(2,J) - TC(2) * TAU(2,J) -! ELTRMX(3,J,2) = TC(1) * PIE(2,J) - TB(1) * TAU(2,J) -! ELTRMX(4,J,2) = TC(2) * PIE(2,J) - TB(2) * TAU(2,J) - 60 CONTINUE -! - QEXT = 2.0D0 * ( TB(1) + TC(1)) - QSCAT = ( TB(1)**2 + TB(2)**2 + TC(1)**2 + TC(2)**2 ) / 0.75D0 - CTBRQS = 0.0D0 - QBSR = -2.0D0*(TC(1) - TB(1)) - QBSI = -2.0D0*(TC(2) - TB(2)) - RMM = -1.0D0 - N = 2 - 65 T(1) = 2*N - 1 ! start of loop, JCB - T(2) = N - 1 - T(3) = 2*N + 1 - DO 70 J = 1,JX - PIE(3,J) = ( T(1)*PIE(2,J)*CSTHT(J) - N*PIE(1,J) ) / T(2) - TAU(3,J) = CSTHT(J) * ( PIE(3,J) - PIE(1,J) ) - & - T(1)*SI2THT(J)*PIE(2,J) + TAU(1,J) - 70 CONTINUE -! -! HERE SET UP HOMOGENEOUS SPHERE -! - WM1 = WFN(1) - WFN(1) = WFN(2) - TA(1) = DREAL(WFN(1)) - TA(2) = DIMAG(WFN(1)) - WFN(2) = T(1) * RX * WFN(1) - WM1 - TA(3) = DREAL(WFN(2)) - TA(4) = DIMAG(WFN(2)) -! - IF ( IFLAG .EQ. 2 ) GO TO 1000 -! -! HERE SET UP STRATIFIED SPHERE -! - DH2 = - N / Z(2) + 1.0D0 / ( N / Z(2) - DH2 ) - DH4 = - N / Z(4) + 1.0D0 / ( N / Z(4) - DH4 ) - DH1 = - N / Z(1) + 1.0D0 / ( N / Z(1) - DH1 ) - PSTORE = ( DH4 + N / Z(4) ) * ( W(3,N) + N / Z(4) ) - P24H24 = P24H24 / PSTORE - HSTORE = ( DH1 + N / Z(1) ) * ( W(3,N) + N / Z(4) ) - P24H21 = P24H21 / HSTORE - PSTORE = ( ACAP(N) + N / Z(1) ) / ( W(3,N) + N / Z(4) ) - DUMMY = DUMMY * PSTORE - DUMSQ = DUMMY * DUMMY -! - U(1) = K3 * ACAP(N) - K2 * W(1,N) - U(2) = K3 * ACAP(N) - K2 * DH2 - U(3) = K2 * ACAP(N) - K3 * W(1,N) - U(4) = K2 * ACAP(N) - K3 * DH2 - U(5) = K1 * W(3,N) - K2 * W(2,N) - U(6) = K2 * W(3,N) - K1 * W(2,N) - U(7) = ( 0.0D0,-1.0D0 ) * ( DUMMY * P24H21 - P24H24 ) - U(8) = TA(3) / WFN(2) -! - FNA = U(8) * ( U(1)*U(5)*U(7) + K1*U(1) - DUMSQ*K3*U(5) ) / & - ( U(2)*U(5)*U(7) + K1*U(2) - DUMSQ*K3*U(5) ) - FNB = U(8) * ( U(3)*U(6)*U(7) + K2*U(3) - DUMSQ*K2*U(6) ) / & - ( U(4)*U(6)*U(7) + K2*U(4) - DUMSQ*K2*U(6) ) - TB(1) = DREAL(FNA) - TB(2) = DIMAG(FNA) - TC(1) = DREAL(FNB) - TC(2) = DIMAG(FNB) -! - 1000 CONTINUE - TC1 = ACAP(N) * RRF + N * RX - TC2 = ACAP(N) * RF + N * RX - FN1 = ( TC1 * TA(3) - TA(1) ) / ( TC1 * WFN(2) - WFN(1) ) - FN2 = ( TC2 * TA(3) - TA(1) ) / ( TC2 * WFN(2) - WFN(1) ) - M = WVNO * R - IF ( N .LT. M ) GO TO 1002 - IF ( IFLAG .EQ. 2 ) GO TO 1001 - IF ( ABS( ( FN1-FNA ) / FN1 ) .LT. 1.0D-09 .AND. & - ABS( ( FN2-FNB ) / FN2 ) .LT. 1.0D-09 ) IFLAG = 2 - IF ( IFLAG .EQ. 1 ) GO TO 1002 - 1001 FNA = FN1 - FNB = FN2 - TB(1) = DREAL(FNA) - TB(2) = DIMAG(FNA) - TC(1) = DREAL(FNB) - TC(2) = DIMAG(FNB) -! - 1002 CONTINUE -! jcb - ntrm=ntrm+1 - an(n)=fna - bn(n)=fnb -! write(6,1010)ntrm,n,an(n),bn(n) -! jcb - T(5) = N - T(4) = T(1) / ( T(5) * T(2) ) - T(2) = ( T(2) * ( T(5) + 1.0D0 ) ) / T(5) -! - CTBRQS = CTBRQS + T(2) * ( TD(1) * TB(1) + TD(2) * TB(2) & - + TE(1) * TC(1) + TE(2) * TC(2) ) & - + T(4) * ( TD(1) * TE(1) + TD(2) * TE(2) ) - QEXT = QEXT + T(3) * ( TB(1) + TC(1) ) - T(4) = TB(1)**2 + TB(2)**2 + TC(1)**2 + TC(2)**2 - QSCAT = QSCAT + T(3) * T(4) - RMM = -RMM - QBSR = QBSR + T(3)*RMM*(TC(1) - TB(1)) - QBSI = QBSI + T(3)*RMM*(TC(2) - TB(2)) -! - T(2) = N * (N+1) - T(1) = T(3) / T(2) - K = (N/2)*2 -! DO 80 J = 1,JX -! ELTRMX(1,J,1)=ELTRMX(1,J,1)+T(1)*(TB(1)*PIE(3,J)+TC(1)*TAU(3,J)) -! ELTRMX(2,J,1)=ELTRMX(2,J,1)+T(1)*(TB(2)*PIE(3,J)+TC(2)*TAU(3,J)) -! ELTRMX(3,J,1)=ELTRMX(3,J,1)+T(1)*(TC(1)*PIE(3,J)+TB(1)*TAU(3,J)) -! ELTRMX(4,J,1)=ELTRMX(4,J,1)+T(1)*(TC(2)*PIE(3,J)+TB(2)*TAU(3,J)) -! IF ( K .EQ. N ) THEN -! ELTRMX(1,J,2)=ELTRMX(1,J,2)+T(1)*(-TB(1)*PIE(3,J)+TC(1)*TAU(3,J)) -! ELTRMX(2,J,2)=ELTRMX(2,J,2)+T(1)*(-TB(2)*PIE(3,J)+TC(2)*TAU(3,J)) -! ELTRMX(3,J,2)=ELTRMX(3,J,2)+T(1)*(-TC(1)*PIE(3,J)+TB(1)*TAU(3,J)) -! ELTRMX(4,J,2)=ELTRMX(4,J,2)+T(1)*(-TC(2)*PIE(3,J)+TB(2)*TAU(3,J)) -! ELSE -! ELTRMX(1,J,2)=ELTRMX(1,J,2)+T(1)*(TB(1)*PIE(3,J)-TC(1)*TAU(3,J)) -! ELTRMX(2,J,2)=ELTRMX(2,J,2)+T(1)*(TB(2)*PIE(3,J)-TC(2)*TAU(3,J)) -! ELTRMX(3,J,2)=ELTRMX(3,J,2)+T(1)*(TC(1)*PIE(3,J)-TB(1)*TAU(3,J)) -! ELTRMX(4,J,2)=ELTRMX(4,J,2)+T(1)*(TC(2)*PIE(3,J)-TB(2)*TAU(3,J)) -! END IF -! 80 CONTINUE -! -! IF ( T(4) .LT. 1.0D-14 ) GO TO 100 ! bail out of loop - IF ( T(4) .LT. 1.0D-10 .OR. N .GE. NMX2) GO TO 100 ! bail out of loop, JCB - N = N + 1 -! DO 90 J = 1,JX -! PIE(1,J) = PIE(2,J) -! PIE(2,J) = PIE(3,J) -! TAU(1,J) = TAU(2,J) -! TAU(2,J) = TAU(3,J) - 90 CONTINUE - FNAP = FNA - FNBP = FNB - TD(1) = DREAL(FNAP) - TD(2) = DIMAG(FNAP) - TE(1) = DREAL(FNBP) - TE(2) = DIMAG(FNBP) - IF ( N .LE. NMX2 ) GO TO 65 - WRITE( 6,8 ) - call errmsg( 'DMIESS: 36', .true.) - 100 CONTINUE -! DO 120 J = 1,JX -! DO 120 K = 1,2 -! DO 115 I= 1,4 -! T(I) = ELTRMX(I,J,K) -! 115 CONTINUE -! ELTRMX(2,J,K) = T(1)**2 + T(2)**2 -! ELTRMX(1,J,K) = T(3)**2 + T(4)**2 -! ELTRMX(3,J,K) = T(1) * T(3) + T(2) * T(4) -! ELTRMX(4,J,K) = T(2) * T(3) - T(4) * T(1) -! 120 CONTINUE - T(1) = 2.0D0 * RX**2 - QEXT = QEXT * T(1) - QSCAT = QSCAT * T(1) - CTBRQS = 2.0D0 * CTBRQS * T(1) -! -! QBS IS THE BACK SCATTER CROSS SECTION -! - PIG = DACOS(-1.0D0) - RXP4 = RX*RX/(4.0D0*PIG) - QBS = RXP4*(QBSR**2 + QBSI**2) -! - 5 FORMAT( 10X,' THE VALUE OF THE SCATTERING ANGLE IS GREATER THAN 90.0 DEGREES. IT IS ', E15.4 ) - 6 FORMAT( // 10X, 'PLEASE READ COMMENTS.' // ) - 7 FORMAT( // 10X, 'THE VALUE OF THE ARGUMENT JX IS GREATER THAN IT') - 8 FORMAT( // 10X, 'THE UPPER LIMIT FOR ACAP IS NOT ENOUGH. SUGGEST GET DETAILED OUTPUT AND MODIFY SUBROUTINE' // ) -! - RETURN - END SUBROUTINE DMIESS -! -! /*****************************************************************/ -! /* SUBROUTINE ACKMIEPARICLE */ -! /*****************************************************************/ - -! THIS PROGRAM COMPUTES SCATTERING PROPERTIES FOR DISTRIBUTIONS OF -! PARTICLES COMPOSED OF A CORE OF ONE MATERIAL AND A SHELL OF ANOTHER. - -! /*---------------------------------------------------------------*/ -! /* INPUTS: */ -! /*---------------------------------------------------------------*/ - -! VLAMBc: Wavelength of the radiation -! NRGFLAGc: Flag to indicate a number density of volume radius -! RGc: Geometric mean radius of the particle distribution -! SIGMAGc: Geometric standard deviation of the distribution -! SHELRc: Real part of the index of refraction for the shell -! SHELIc: Imaginary part of the index of refraction for the shell -! RINc: Inner core radius as a fraction of outer shell radius -! CORERc: Real part of the index of refraction for the core -! COREIc: Imaginary part of the index of refraction for the core -! NANG: Number of scattering angles between 0 and 90 degrees, -! inclusive - -! /*---------------------------------------------------------------*/ -! /* OUTPUTS: */ -! /*---------------------------------------------------------------*/ - -! QEXTc: Extinction efficiency of the particle -! QSCAc: Scattering efficiency of the particle -! QBACKc: Backscatter efficiency of the particle -! EXTc: Extinction cross section of the particle -! SCAc: Scattering cross section of the particle -! BACKc: Backscatter cross section of the particle -! GSCA: Asymmetry parameter of the particle's phase function -! ANGLES(NAN): Scattering angles in degrees -! S1R(NAN): Real part of the amplitude scattering matrix -! S1C(NAN): Complex part of the amplitude scattering matrix -! S2R(NAN): Real part of the amplitude scattering matrix -! S2C(NAN): Complex part of the amplitude scattering matrix -! S11N: Normalization coefficient of the scattering matrix -! S11(NAN): S11 scattering coefficients -! S12(NAN): S12 scattering coefficients -! S33(NAN): S33 scattering coefficients -! S34(NAN): S34 scattering coefficients -! SPOL(NAN): Degree of polarization of unpolarized, incident light -! SP(NAN): Phase function -! -! NOTE: NAN=2*NANG-1 is the number of scattering angles between -! 0 and 180 degrees, inclusive. -! /*---------------------------------------------------------------*/ - - SUBROUTINE ACKMIEPARTICLE( VLAMBc,NRGFLAGc,RGcmin,RGcmax, & - RGc,SIGMAGc,SHELRc, & - SHELIc, RINc,CORERc,COREIc,NANG,QEXTc,QSCATc, & - QBACKc, EXTc,SCATc,BACKc, GSCAc, & - ANGLESc,S1R,S1C,S2R,S2C,S11N,S11,S12,S33,S34,SPOL,SP,pmom) ! jcb - -! /*--------------------------------------------------------*/ -! /* Set reals to 8 bytes, i.e., double precision. */ -! /*--------------------------------------------------------*/ - - IMPLICIT REAL*8 (A-H, O-Z) - -! /*--------------------------------------------------------*/ -! /* Parameter statements. */ -! /*--------------------------------------------------------*/ - - integer*4 mxnang - - PARAMETER(MXNANG=501) - -! /*--------------------------------------------------------*/ -! /* Dimension statements. */ -! /*--------------------------------------------------------*/ - - REAL*8 VLAMBc,RGcmin,RGcmax,RGc,SIGMAGc,SHELRc,SHELIc - REAL*8 RINc,CORERc,COREIc - INTEGER*4 NANG,NRGFLAGc,NSCATH - REAL*8 QEXTc,QSCATc,QBACKc,EXTc,SCATc,BACKc,GSCAc - REAL*8 ANGLESc(*),S1R(*),S1C(*),S2R(*),S2C(*) - REAL*8 S11N,S11(*),S12(*),S33(*),S34(*),SPOL(*),SP(*) - -! /*--------------------------------------------------------*/ -! /* Define the types of the common block. */ -! /*--------------------------------------------------------*/ - - INTEGER*4 IPHASEmie - - REAL*8 ALAMB, RGmin, RGmax, RGV, SIGMAG, RGCFRAC, RFRS,RFIS, RFRC, RFIC - -! for calculating the Legendre coefficient, jcb - complex*16 an(500),bn(500) ! a,b Mie coefficients, jcb Hansen and Travis, eqn 2.44 - integer*4 ntrmj,ntrm,nmom,ipolzn,momdim - real*8 pmom(0:7,1) - -! /*--------------------------------------------------------*/ -! /* Set reals to 8 bytes, i.e., double precision. */ -! /*--------------------------------------------------------*/ - -! IMPLICIT REAL*8 (A-H, O-Z) - -! /*--------------------------------------------------------*/ -! /* Input common block for scattering calculations. */ -! /*--------------------------------------------------------*/ - -!jdf COMMON / PHASE / IPHASEmie - -!jdf COMMON / INPUTS / ALAMB, RGmin, RGmax, RGV, SIGMAG, & -!jdf RGCFRAC, RFRS, RFIS, RFRC, RFIC - -! /*--------------------------------------------------------*/ -! /* Output common block for scattering calculations. */ -! /*--------------------------------------------------------*/ - -!jdf COMMON / OUTPUTS / QEXT, QSCAT, QBS, EXT, SCAT, BSCAT, ASY - -! /*--------------------------------------------------------*/ -! /* Arrays to hold the results of the scattering and */ -! /* moment calculations. */ -! /*--------------------------------------------------------*/ - - REAL*8 COSPHI(2*MXNANG-1), SCTPHS(2*MXNANG-1) - - -! /*--------------------------------------------------------*/ -! /* Copy the input parameters into the common block INPUTS */ -! /*--------------------------------------------------------*/ - - NSCATH = NANG - - IPHASEmie = 0 - ALAMB = VLAMBc - RGmin = RGcmin - RGmax = RGcmax - RGV = RGc - SIGMAG = SIGMAGc - RGCFRAC = RINc - RFRS = SHELRc - RFIS = SHELIc - RFRC = CORERc - RFIC = COREIc - -! /*--------------------------------------------------------*/ -! /* Calculate the particle scattering properties for the */ -! /* given wavelength, particle distribution and indices of */ -! /* refraction of inner and outer material. */ -! /*--------------------------------------------------------*/ - - CALL PFCNPARTICLE(NSCATH, COSPHI, SCTPHS, & - ANGLESc,S1R,S1C,S2R,S2C,S11N,S11,S12,S33,S34,SPOL,SP, an, bn, ntrm, & ! jcb - ALAMB,RGmin,RGmax,RGV,SIGMAG,RGCFRAC,RFRS,RFIS,RFRC,RFIC, & ! jdf - QEXT,QSCAT,QBS,EXT,SCAT,BSCAT,ASY, & ! jdf - IPHASEmie) ! jdf - -! /*--------------------------------------------------------*/ -! /* If IPHASE = 1, then the full phase function was */ -! /* calculated; now, go calculate its moments. */ -! /*--------------------------------------------------------*/ - -! IF (IPHASE .gt. 0) CALL DISMOM (NSCATA,COSPHI,SCTPHS,RMOMS) - -! /*--------------------------------------------------------*/ -! /* Copy the variables in the common block OUTPUTS to the */ -! /* variable addresses passed into this routine. */ -! /*--------------------------------------------------------*/ - - QEXTc = QEXT - QSCATc = QSCAT - QBACKc = QBS - - EXTc = EXT - SCATc = SCAT - BACKc = BSCAT - - GSCAc = ASY -! jcb -! ntrmj = number of terms in Mie series, jcb - nmom= 7 ! largest Legendre coefficient to calculate 0:7 (8 total), jcb - ipolzn=0 ! unpolarized light, jcb - momdim=7 ! dimension of pmom, pmom(0:7), jcb -! a, b = Mie coefficients -! pmom = output of Legendre coefficients, pmom(0:7) -! write(6,*)ntrm -! do ii=1,ntrm -! write(6,1030)ii,an(ii),bn(ii) -1030 format(i5,4e15.6) -! enddo - - call lpcoefjcb(ntrm,nmom,ipolzn,momdim,an,bn,pmom) -! do ii=0,7 -! write(6,1040)ii,pmom(ii,1),pmom(ii,1)/pmom(0,1) -!1040 format(i5,2e15.6) -! enddo -! /*--------------------------------------------------------*/ -! /* FORMAT statements. */ -! /*--------------------------------------------------------*/ - - 107 FORMAT ( ///, 1X, I6, ' IS AN INVALID MEAN RADIUS FLAG') - -! /*--------------------------------------------------------*/ -! /* DONE with this subroutine so exit. */ -! /*--------------------------------------------------------*/ - - END SUBROUTINE ACKMIEPARTICLE - -! /*****************************************************************/ -! /* SUBROUTINE PFCNPARTICLE */ -! /*****************************************************************/ -! -! THIS SUBROUTINE COMPUTES THE PHASE FUNCTION SCTPHS(I) AT NSCATA -! ANGLES BETWEEN 0.0 AND 180.0 DEGREES SPECIFIED BY COSPHI(I) WHICH -! CONTAINS THE ANGLE COSINES. THESE VALUES ARE RETURNED TO FUNCTION -! PHASFN FOR AZIMUTHAL AVERAGING. -! INPUT DATA FOR THIS ROUTINE IS PASSED THROUGH COMMON /SIZDIS/ -! AND CONSISTS OF THE FOLLOWING PARAMETERS -! NEWSD = 1 IF SIZE DIS VALUES HAVE NOT PREVIOUSLY BEEN USED IN -! THIS ROUTINE, = 0 OTHERWISE. -! RGV = GEOMETRIC MEAN RADIUS FOR THE VOLUME DISTRIBUTION OF THE -! SPECIFIED PARTICLES -! SIGMAG = GEOMETRIC STANDARD DEVIATION -! RFR,I = REAL AND IMAGINARY INDEX OF REFRACTION OF PARTICLES -! ALAMB = WAVELENGTH AT WHICH CALCULATIONS ARE TO BE PERFORMED -! -! /*---------------------------------------------------------------*/ - - SUBROUTINE PFCNPARTICLE( NSCATH, COSPHI, SCTPHS, & - ANGLESc,S1R,S1C,S2R,S2C,S11N,S11,S12,S33,S34,SPOL,SP,an,bn,ntrm, & ! jcb - ALAMB,RGmin,RGmax,RGV,SIGMAG,RGCFRAC,RFRS,RFIS,RFRC,RFIC, & ! jdf - QEXT,QSCAT,QBS,EXT,SCAT,BSCAT,ASY, & ! jdf - IPHASEmie) ! jdf - -! /*--------------------------------------------------------*/ -! /* Set reals to 8 bytes, i.e., double precision. */ -! /*--------------------------------------------------------*/ - - IMPLICIT REAL*8 (A-H, O-Z) - -! /*--------------------------------------------------------*/ -! /* Parameter statements. */ -! /*--------------------------------------------------------*/ - - integer*4 MXNANG, MXNWORK, JX,LL,IT,IT2 - - PARAMETER(MXNANG=501, MXNWORK=500000) - -! /*--------------------------------------------------------*/ -! /* Dimension statements. */ -! /*--------------------------------------------------------*/ - - REAL*8 ANGLESc(*),S1R(*),S1C(*),S2R(*),S2C(*) - REAL*8 S11N,S11(*),S12(*),S33(*),S34(*),SPOL(*),SP(*) - -! /*--------------------------------------------------------*/ -! /* Define the types of the common block. */ -! /*--------------------------------------------------------*/ - - INTEGER*4 IPHASEmie,NSCATH - - REAL*8 ALAMB, RGmin, RGmax, RGV, SIGMAG, RGCFRAC, RFRS, & - RFIS, RFRC, RFIC - - complex*16 an(500),bn(500) - integer*4 ntrm - -! /*--------------------------------------------------------*/ -! /* Set reals to 8 bytes, i.e., double precision. */ -! /*--------------------------------------------------------*/ - -! IMPLICIT REAL*8 (A-H, O-Z) - -! /*--------------------------------------------------------*/ -! /* Input common block for scattering calculations. */ -! /*--------------------------------------------------------*/ - -!jdf COMMON / PHASE / IPHASEmie - -!jdf COMMON / INPUTS / ALAMB, RGmin, RGmax, RGV, SIGMAG, & -!jdf RGCFRAC, RFRS, RFIS, RFRC, RFIC - -! /*--------------------------------------------------------*/ -! /* Output common block for scattering calculations. */ -! /*--------------------------------------------------------*/ - -!jdf COMMON / OUTPUTS / QEXT, QSCAT, QBS, EXT, SCAT, BSCAT, ASY - -! /*--------------------------------------------------------*/ -! /* Arrays to perform the scattering calculations and to */ -! /* hold the subsequent results. */ -! /*--------------------------------------------------------*/ - - REAL*8 THETA(MXNANG), ELTRMX(4,MXNANG,2), PII(3,MXNANG), & - TAU(3,MXNANG), CSTHT(MXNANG), SI2THT(MXNANG) - - REAL*8 ROUT, RFRO, RFIO, DQEXT, DQSCAT, CTBRQS, DQBS, & - RIN, RFRI, RFII, WNUM - - COMPLEX*16 ACAP(MXNWORK) - - REAL*8 COSPHI(2*MXNANG-1), SCTPHS(2*MXNANG-1) - - INTEGER J, JJ, NINDEX, NSCATA - -! /*--------------------------------------------------------*/ -! /* Obvious variable initializations. */ -! /*--------------------------------------------------------*/ - - PIE = DACOS( -1.0D0 ) - -! /*--------------------------------------------------------*/ -! /* Maximum number of scattering angles between 0 and 90 */ -! /* degrees, inclusive. */ -! /*--------------------------------------------------------*/ - - IT = MXNANG - -! /*--------------------------------------------------------*/ -! /* Maximum number of scattering angles between 0 and 180 */ -! /* degrees, inclusive. */ -! /*--------------------------------------------------------*/ - - IT2 = 2 * IT - 1 - -! /*--------------------------------------------------------*/ -! /* Dimension of the work array ACAP. */ -! /*--------------------------------------------------------*/ - - LL = MXNWORK - -! /*--------------------------------------------------------*/ -! /* NSCATA is the actual user-requested number of */ -! /* scattering angles between 0 and 90 degrees, inclusive. */ -! /*--------------------------------------------------------*/ - - NSCATA = 2 * NSCATH - 1 - -! /*--------------------------------------------------------*/ -! /* If the user did not request a phase function, then we */ -! /* can set NSCATA and NSCATH to 0. */ -! /*--------------------------------------------------------*/ - - IF ( IPHASEmie .le. 0 ) then - NSCATH = 0 - NSCATA = 0 - ENDIF - -! /*--------------------------------------------------------*/ -! /* Check to make sure that the user-requested number of */ -! /* scattering angles does not excede the current maximum */ -! /* limit. */ -! /*--------------------------------------------------------*/ - - IF ( NSCATA .gt. IT2 .OR. NSCATH .gt. IT) then - WRITE( 6,105 ) NSCATA, NSCATH, IT2, IT - call errmsg( 'PFCNPARTICLE: 11', .true.) - ENDIF - -! /*--------------------------------------------------------*/ -! /* Subroutine SCATANGLES was added by EEC[0495] in order */ -! /* to facilitate changing the scattering angle locations */ -! /* output by the Ackerman and Toon Mie code. */ -! /*--------------------------------------------------------*/ - -! CALL SCATANGLES(NSCATH,THETA,COSPHI) - -! /*--------------------------------------------------------*/ -! /* COMPUTE SCATTERING PROPERTIES OF THE PARTICLE. */ -! /*--------------------------------------------------------*/ - -! /*--------------------------------------------------------*/ -! /* DMIESS expects a wavenumber. */ -! /*--------------------------------------------------------*/ - - WNUM = (2.D0*PIE) / ALAMB - -! /*--------------------------------------------------------*/ -! /* DMIESS assignments of the indices of refraction of the */ -! /* core and shell materials. */ -! /*--------------------------------------------------------*/ - - RFRO = RFRS - RFIO = RFIS - RFRI = RFRC - RFII = RFIC - -! /*--------------------------------------------------------*/ -! /* DMIESS core and shell radii. */ -! /*--------------------------------------------------------*/ - - ROUT = RGV - RIN = RGCFRAC * ROUT - -! /*--------------------------------------------------------*/ -! /* Scattering angles are symmetric about 90 degrees. */ -! /*--------------------------------------------------------*/ - - IF ( NSCATH .eq. 0.0 ) THEN - JX = 1 - ELSE - JX = NSCATH - ENDIF - -! /*--------------------------------------------------------*/ -! /* Compute the scattering properties for this particle. */ -! /*--------------------------------------------------------*/ - - CALL DMIESS( ROUT, RFRO, RFIO, THETA, JX, & - DQEXT, DQSCAT, CTBRQS, ELTRMX, PII, & - TAU, CSTHT, SI2THT, ACAP, DQBS, IT, & - LL, RIN, RFRI, RFII, WNUM, an, bn, ntrm ) ! jcb - -! /*--------------------------------------------------------*/ -! /* Compute total cross-sectional area of the particle. */ -! /*--------------------------------------------------------*/ - - X = PIE * RGV * RGV - -! /*--------------------------------------------------------*/ -! /* Assign the final extinction efficiency. */ -! /*--------------------------------------------------------*/ - - QEXT = DQEXT - -! /*--------------------------------------------------------*/ -! /* Compute total extinction cross-section due to particle.*/ -! /*--------------------------------------------------------*/ - - EXT = DQEXT * X - -! /*--------------------------------------------------------*/ -! /* Assign the final scattering efficiency. */ -! /*--------------------------------------------------------*/ - - QSCAT = DQSCAT - -! /*--------------------------------------------------------*/ -! /* Compute total scattering cross-section due to particle.*/ -! /*--------------------------------------------------------*/ - - SCAT = DQSCAT * X - -! /*--------------------------------------------------------*/ -! /* Assign the final backscatter efficiency. */ -! /*--------------------------------------------------------*/ - - QBS = DQBS - -! /*--------------------------------------------------------*/ -! /* Compute backscatter due to particle. */ -! /*--------------------------------------------------------*/ - - BSCAT = DQBS * X - -! /*--------------------------------------------------------*/ -! /* Compute asymmetry parameter due to particle. */ -! /*--------------------------------------------------------*/ - - ASY = (CTBRQS * X) / SCAT - -! /*--------------------------------------------------------*/ -! /* If IPHASE is 1, compute the phase function. */ -! /* S33 and S34 matrix elements are normalized by S11. S11 */ -! /* is normalized to 1.0 in the forward direction. The */ -! /* variable SPOL is the degree of polarization for */ -! /* incident unpolarized light. */ -! /*--------------------------------------------------------*/ - - IF ( IPHASEmie .gt. 0 ) THEN - - DO 355 J=1,NSCATA - - IF (J .LE. JX) THEN - JJ = J - NINDEX = 1 - ELSE - JJ = NSCATA - J + 1 - NINDEX = 2 - ENDIF - - ANGLESc(J) = COSPHI(J) - - S1R(J) = ELTRMX(1,JJ,NINDEX) - S1C(J) = ELTRMX(2,JJ,NINDEX) - S2R(J) = ELTRMX(3,JJ,NINDEX) - S2C(J) = ELTRMX(4,JJ,NINDEX) - - S11(J) = 0.5D0*(S1R(J)**2+S1C(J)**2+S2R(J)**2+S2C(J)**2) - S12(J) = 0.5D0*(S2R(J)**2+S2C(J)**2-S1R(J)**2-S1C(J)**2) - S33(J) = S2R(J)*S1R(J) + S2C(J)*S1C(J) - S34(J) = S2R(J)*S1C(J) - S1R(J)*S2C(J) - - SPOL(J) = -S12(J) / S11(J) - - SP(J) = (4.D0*PIE)*(S11(J) / (SCAT*WNUM**2)) - - 355 CONTINUE - -! /*-----------------------------------------------------*/ -! /* DONE with the phase function so exit the IF. */ -! /*-----------------------------------------------------*/ - - ENDIF - -! /*--------------------------------------------------------*/ -! /* END of the computations so exit the routine. */ -! /*--------------------------------------------------------*/ - - - RETURN - -! /*--------------------------------------------------------*/ -! /* FORMAT statements. */ -! /*--------------------------------------------------------*/ - - 100 FORMAT ( 7X, I3 ) - 105 FORMAT ( ///, 1X,'NUMBER OF ANGLES SPECIFIED =',2I6, / & - 10X,'EXCEEDS ARRAY DIMENSIONS =',2I6 ) - - 120 FORMAT (/10X,'INTEGRATED VOLUME', T40,'=',1PE14.5,/ & - 15X,'PERCENT VOLUME IN CORE', T40,'=',0PF10.5,/ & - 15X,'PERCENT VOLUME IN SHELL', T40,'=',0PF10.5,/ & - 10X,'INTEGRATED SURFACE AREA', T40,'=',1PE14.5,/ & - 10X,'INTEGRATED NUMBER DENSITY', T40,'=',1PE14.5 ) - 125 FORMAT ( 10X,'CORE RADIUS COMPUTED FROM :', /, 20X, 9A8, / ) - - 150 FORMAT ( ///,1X,'* * * WARNING * * *', / & - 10X,'PHASE FUNCTION CALCULATION MAY NOT HAVE CONVERGED'/ & - 10X,'VALUES OF S1 AT NSDI-1 AND NSDI ARE :', 2E14.6, / & - 10X,'VALUE OF X AT NSDI =', E14.6 ) - -! /*--------------------------------------------------------*/ -! /* DONE with this subroutine so exit. */ -! /*--------------------------------------------------------*/ - - END SUBROUTINE PFCNPARTICLE - -! /*****************************************************************/ -! /*****************************************************************/ - subroutine lpcoefjcb ( ntrm, nmom, ipolzn, momdim,a, b, pmom ) -! -! calculate legendre polynomial expansion coefficients (also -! called moments) for phase quantities ( ref. 5 formulation ) -! -! input: ntrm number terms in mie series -! nmom, ipolzn, momdim 'miev0' arguments -! a, b mie series coefficients -! -! output: pmom legendre moments ('miev0' argument) -! -! *** notes *** -! -! (1) eqs. 2-5 are in error in dave, appl. opt. 9, -! 1888 (1970). eq. 2 refers to m1, not m2; eq. 3 refers to -! m2, not m1. in eqs. 4 and 5, the subscripts on the second -! term in square brackets should be interchanged. -! -! (2) the general-case logic in this subroutine works correctly -! in the two-term mie series case, but subroutine 'lpco2t' -! is called instead, for speed. -! -! (3) subroutine 'lpco1t', to do the one-term case, is never -! called within the context of 'miev0', but is included for -! complete generality. -! -! (4) some improvement in speed is obtainable by combining the -! 310- and 410-loops, if moments for both the third and fourth -! phase quantities are desired, because the third phase quantity -! is the real part of a complex series, while the fourth phase -! quantity is the imaginary part of that very same series. but -! most users are not interested in the fourth phase quantity, -! which is related to circular polarization, so the present -! scheme is usually more efficient. -! - implicit none - integer ipolzn, momdim, nmom, ntrm - real*8 pmom( 0:momdim,1 ) ! the ",1" dimension is for historical reasons - complex*16 a(500), b(500) -! -! ** specification of local variables -! -! am(m) numerical coefficients a-sub-m-super-l -! in dave, eqs. 1-15, as simplified in ref. 5. -! -! bi(i) numerical coefficients b-sub-i-super-l -! in dave, eqs. 1-15, as simplified in ref. 5. -! -! bidel(i) 1/2 bi(i) times factor capital-del in dave -! -! cm,dm() arrays c and d in dave, eqs. 16-17 (mueller form), -! calculated using recurrence derived in ref. 5 -! -! cs,ds() arrays c and d in ref. 4, eqs. a5-a6 (sekera form), -! calculated using recurrence derived in ref. 5 -! -! c,d() either -cm,dm- or -cs,ds-, depending on -ipolzn- -! -! evenl true for even-numbered moments; false otherwise -! -! idel 1 + little-del in dave -! -! maxtrm max. no. of terms in mie series -! -! maxmom max. no. of non-zero moments -! -! nummom number of non-zero moments -! -! recip(k) 1 / k -! - integer maxtrm,maxmom,mxmom2,maxrcp - parameter ( maxtrm = 1102, maxmom = 2*maxtrm, mxmom2 = maxmom/2, maxrcp = 4*maxtrm + 2 ) - real*8 am( 0:maxtrm ), bi( 0:mxmom2 ), bidel( 0:mxmom2 ), recip( maxrcp ) - complex*16 cm( maxtrm ), dm( maxtrm ), cs( maxtrm ), ds( maxtrm ) - integer k,j,l,nummom,ld2,idel,m,i,mmax,imax - real*8 sum - logical pass1, evenl - save pass1, recip - data pass1 / .true. / -! -! - if ( pass1 ) then -! - do 1 k = 1, maxrcp - recip( k ) = 1.0 / k - 1 continue - pass1 = .false. -! - end if -! - do l = 0, nmom - pmom( l, 1 ) = 0.0 - enddo -! these will never be called -! if ( ntrm.eq.1 ) then -! call lpco1t ( nmom, ipolzn, momdim, calcmo, a, b, pmom ) -! return -! else if ( ntrm.eq.2 ) then -! call lpco2t ( nmom, ipolzn, momdim, calcmo, a, b, pmom ) -! return -! end if -! - if ( ntrm+2 .gt. maxtrm ) & - write(6,1010) -1010 format( ' lpcoef--parameter maxtrm too small' ) -! -! ** calculate mueller c, d arrays - cm( ntrm+2 ) = ( 0., 0. ) - dm( ntrm+2 ) = ( 0., 0. ) - cm( ntrm+1 ) = ( 1. - recip( ntrm+1 ) ) * b( ntrm ) - dm( ntrm+1 ) = ( 1. - recip( ntrm+1 ) ) * a( ntrm ) - cm( ntrm ) = ( recip(ntrm) + recip(ntrm+1) ) * a( ntrm ) & - + ( 1. - recip(ntrm) ) * b( ntrm-1 ) - dm( ntrm ) = ( recip(ntrm) + recip(ntrm+1) ) * b( ntrm ) & - + ( 1. - recip(ntrm) ) * a( ntrm-1 ) -! - do 10 k = ntrm-1, 2, -1 - cm( k ) = cm( k+2 ) - ( 1. + recip(k+1) ) * b( k+1 ) & - + ( recip(k) + recip(k+1) ) * a( k ) & - + ( 1. - recip(k) ) * b( k-1 ) - dm( k ) = dm( k+2 ) - ( 1. + recip(k+1) ) * a( k+1 ) & - + ( recip(k) + recip(k+1) ) * b( k ) & - + ( 1. - recip(k) ) * a( k-1 ) - 10 continue - cm( 1 ) = cm( 3 ) + 1.5 * ( a( 1 ) - b( 2 ) ) - dm( 1 ) = dm( 3 ) + 1.5 * ( b( 1 ) - a( 2 ) ) -! - if ( ipolzn.ge.0 ) then -! - do 20 k = 1, ntrm + 2 - cm( k ) = ( 2*k - 1 ) * cm( k ) - dm( k ) = ( 2*k - 1 ) * dm( k ) - 20 continue -! - else -! ** compute sekera c and d arrays - cs( ntrm+2 ) = ( 0., 0. ) - ds( ntrm+2 ) = ( 0., 0. ) - cs( ntrm+1 ) = ( 0., 0. ) - ds( ntrm+1 ) = ( 0., 0. ) -! - do 30 k = ntrm, 1, -1 - cs( k ) = cs( k+2 ) + ( 2*k + 1 ) * ( cm( k+1 ) - b( k ) ) - ds( k ) = ds( k+2 ) + ( 2*k + 1 ) * ( dm( k+1 ) - a( k ) ) - 30 continue -! - do 40 k = 1, ntrm + 2 - cm( k ) = ( 2*k - 1 ) * cs( k ) - dm( k ) = ( 2*k - 1 ) * ds( k ) - 40 continue -! - end if -! -! - if( ipolzn.lt.0 ) nummom = min0( nmom, 2*ntrm - 2 ) - if( ipolzn.ge.0 ) nummom = min0( nmom, 2*ntrm ) - if ( nummom .gt. maxmom ) & - write(6,1020) -1020 format( ' lpcoef--parameter maxtrm too small') -! -! ** loop over moments - do 500 l = 0, nummom - ld2 = l / 2 - evenl = mod( l,2 ) .eq. 0 -! ** calculate numerical coefficients -! ** a-sub-m and b-sub-i in dave -! ** double-sums for moments - if( l.eq.0 ) then -! - idel = 1 - do 60 m = 0, ntrm - am( m ) = 2.0 * recip( 2*m + 1 ) - 60 continue - bi( 0 ) = 1.0 -! - else if( evenl ) then -! - idel = 1 - do 70 m = ld2, ntrm - am( m ) = ( 1. + recip( 2*m-l+1 ) ) * am( m ) - 70 continue - do 75 i = 0, ld2-1 - bi( i ) = ( 1. - recip( l-2*i ) ) * bi( i ) - 75 continue - bi( ld2 ) = ( 2. - recip( l ) ) * bi( ld2-1 ) -! - else -! - idel = 2 - do 80 m = ld2, ntrm - am( m ) = ( 1. - recip( 2*m+l+2 ) ) * am( m ) - 80 continue - do 85 i = 0, ld2 - bi( i ) = ( 1. - recip( l+2*i+1 ) ) * bi( i ) - 85 continue -! - end if -! ** establish upper limits for sums -! ** and incorporate factor capital- -! ** del into b-sub-i - mmax = ntrm - idel - if( ipolzn.ge.0 ) mmax = mmax + 1 - imax = min0( ld2, mmax - ld2 ) - if( imax.lt.0 ) go to 600 - do 90 i = 0, imax - bidel( i ) = bi( i ) - 90 continue - if( evenl ) bidel( 0 ) = 0.5 * bidel( 0 ) -! -! ** perform double sums just for -! ** phase quantities desired by user - if( ipolzn.eq.0 ) then -! - do 110 i = 0, imax -! ** vectorizable loop (cray) - sum = 0.0 - do 100 m = ld2, mmax - i - sum = sum + am( m ) * & - ( dble( cm(m-i+1) * dconjg( cm(m+i+idel) ) ) & - + dble( dm(m-i+1) * dconjg( dm(m+i+idel) ) ) ) - 100 continue - pmom( l,1 ) = pmom( l,1 ) + bidel( i ) * sum - 110 continue - pmom( l,1 ) = 0.5 * pmom( l,1 ) - go to 500 -! - end if -! - 500 continue -! -! - 600 return - end subroutine lpcoefjcb -! - end module module_optical_averaging diff --git a/src/fim/FIMsrc/fim/column_chem/module_optical_driver.F90 b/src/fim/FIMsrc/fim/column_chem/module_optical_driver.F90 deleted file mode 100644 index 117f30a..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_optical_driver.F90 +++ /dev/null @@ -1,146 +0,0 @@ -MODULE module_optical_driver -!********************************************************************************** -! This computer software was prepared by Battelle Memorial Institute, hereinafter -! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of -! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, -! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. -! -!********************************************************************************** -! -! WRF-chem V3.0 : Original version of optical_driver written by Jerome Fast (PNNL) -! and James Barnard (PNNL) -! -!WRF:MODEL_LAYER:CHEMISTRY -! -CONTAINS - SUBROUTINE optical_driver(curr_secs,dtstep,& - chem,dz8w,alt,relhum, & -! h2oai,h2oaj, & - tauaersw,gaersw,waersw,bscoefsw,tauaerlw, & - l2aer,l3aer,l4aer,l5aer,l6aer,l7aer, & - num_chem,chem_opt,ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - -!------------------------------------------------------------------------ -! USE module_configure -! USE module_state_description -! USE module_model_constants - USE module_optical_averaging -! USE module_data_mosaic_therm, only: nbin_a - INTEGER, INTENT(IN ) :: chem_opt,num_chem,ids,ide, & - jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - REAL(KIND=8), INTENT(IN ) :: curr_secs - REAL, INTENT(IN ) :: dtstep -! -! array that holds all advected chemical species -! - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & - INTENT(INOUT ) :: chem -! - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & - INTENT(IN ) :: relhum, dz8w, alt !, h2oai, h2oaj -! -! arrays that hold the aerosol optical properties -! - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, 1:4 ), & - INTENT(INOUT ) :: & - tauaersw,gaersw,waersw,bscoefsw - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, 1:16), & - INTENT(INOUT ) :: & - tauaerlw - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, 1:4 ), & - INTENT(INOUT ) :: & - l2aer, l3aer, l4aer, l5aer, l6aer, l7aer -! - -! -! local variables -! - logical processingAerosols - integer nbin_o - integer option_method, option_mie - -!----------------------------------------------------------------- -! compute only if simulating aerosols and aer_ra_feedback=1 - -! IF (config_flags%aer_ra_feedback .eq. 0) THEN -! call wrf_debug(15,'no feedback, return from optical driver') -! return -! ENDIF -! select case (config_flags%chem_opt) -! case ( RADM2SORG, RADM2SORG_KPP, RADM2SORG_AQ, & -! GOCART_SIMPLE, RACMSORG_KPP, RACMSORG_AQ, & -! CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, & -! CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ ) - processingAerosols = .true. -! call wrf_debug(15,'optical driver: process aerosols true') -! case default -! processingAerosols = .false. -! call wrf_debug(15,'optical driver: process aerosols false') -! end select - - if( processingAerosols ) then -! -! select aerosol optical property option -! VOLUME: volume averaging of refractive indicies -! * for MADE/SORGAM, assume same 8 size bins as MOSAIC by default -! SHELL: shell-core approach, placeholder -! -! select case (config_flags%chem_opt) -! case ( RADM2SORG, RADM2SORG_KPP, RADM2SORG_AQ, & -! GOCART_SIMPLE, RACMSORG_KPP, RACMSORG_AQ ) - nbin_o = 8 -! case (CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, & -! CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ ) -! nbin_o = nbin_a -! end select -! -! call wrf_debug(15,'optical averaging') -! aer_op_opt_select: SELECT CASE(config_flags%aer_op_opt) -! CASE (VOLUME_APPROX) - option_method=1 - option_mie=1 -! CASE (MAXWELL_APPROX) -! option_method=2 -! option_mie=1 -! CASE (VOLUME_EXACT) -! option_method=1 -! option_mie=2 -! CASE (MAXWELL_EXACT) -! option_method=2 -! option_mie=2 -! CASE (SHELL_EXACT) -! option_method=3 -! option_mie=2 -! CASE DEFAULT -! if( config_flags%aer_op_opt > 0 ) then -! call wrf_message('WARNING: Invalid aer_op_opt. Defaulting to VOLUME_APPROX.') -! option_method=1 -! option_mie=1 -! end if -! END SELECT aer_op_opt_select - -! if( config_flags%aer_op_opt > 0 ) then -! call wrf_debug(15,'optical driver: call optical averaging') - call optical_averaging(curr_secs,dtstep, & - nbin_o,option_method,option_mie,chem,dz8w,alt, & - relhum, & - tauaersw,gaersw,waersw,bscoefsw,tauaerlw, & - l2aer,l3aer,l4aer,l5aer,l6aer,l7aer, & - num_chem,chem_opt,ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) -! else - !If aer_op_opt==0 then the optical arrays are already set to - !zero in chemics_init so there will not be a problem if the - !user has selected aer_ra_feedback=1. -! end if -! - endif - return - -END SUBROUTINE optical_driver -END MODULE module_optical_driver diff --git a/src/fim/FIMsrc/fim/column_chem/module_peg_util.F90 b/src/fim/FIMsrc/fim/column_chem/module_peg_util.F90 deleted file mode 100644 index 780e128..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_peg_util.F90 +++ /dev/null @@ -1,84 +0,0 @@ -!#********************************************************************************** -! This computer software was prepared by Battelle Memorial Institute, hereinafter -! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of -! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, -! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. -! -! miscellaneous debuging routines for CBMZ and MOSAIC -!********************************************************************************** - module module_peg_util - - - contains - - -!----------------------------------------------------------------------- - subroutine peg_debugmsg( lun, level, str ) -! -! when lun > 0, writes "str" to unit "lun" -! when lun <= 0, passes "str" on to wrf_debug -! - implicit none -! subr arguments - integer, intent(in) :: lun, level - character(len=*), intent(in) :: str -! local variables - integer n - - n = max( 1, len_trim(str) ) - if (lun .gt. 0) then - write(lun,'(a)') str(1:n) - else -! call wrf_debug( level, str(1:n) ) - write(6,*)level,str(1:n) - end if - return - end subroutine peg_debugmsg - - -!----------------------------------------------------------------------- - subroutine peg_message( lun, str ) -! -! when lun > 0, writes "str" to unit "lun" -! when lun <= 0, passes "str" on to wrf_message -! - implicit none -! subr arguments - integer, intent(in) :: lun - character(len=*), intent(in) :: str -! local variables - integer n - - n = max( 1, len_trim(str) ) - if (lun .gt. 0) then - write(lun,'(a)') str(1:n) - else -! call wrf_message( str(1:n) ) - write(6,*)str(1:n) - end if - return - end subroutine peg_message - - -!----------------------------------------------------------------------- - subroutine peg_error_fatal( lun, str ) -! -! when lun > 0, writes "str" to unit "lun" -! then (always) passes "str" on to wrf_error_fatal -! - implicit none -! subr arguments - integer, intent(in) :: lun - character(len=*), intent(in) :: str -! local variables - integer n - - n = max( 1, len_trim(str) ) - if (lun .gt. 0) write(lun,'(a)') str(1:n) - call wrf_error_fatal( str(1:n) ) - return - end subroutine peg_error_fatal - - -!----------------------------------------------------------------------- - end module module_peg_util diff --git a/src/fim/FIMsrc/fim/column_chem/module_phot_mad.F90 b/src/fim/FIMsrc/fim/column_chem/module_phot_mad.F90 deleted file mode 100644 index 091b08f..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_phot_mad.F90 +++ /dev/null @@ -1,3237 +0,0 @@ - - MODULE module_phot_mad - USE module_initial_chem_namelists,only: p_o3,p_qi,p_qc,p_qv - USE module_constants,only: pi,rd,g=>grvity - ! preliminary fixed values for T, p, O3 and caer - ! use values in correct units!! - ! so3t(kl,i) - ozone cross sect. temperature dependence coefficients - ! wl(kl) - array of nominal center wavelengths of spectral intervals - ! f(kl) - extraterrestrial solar irradiance - ! xs(kl,nr) - cross sections for nr species. - ! xqy(kl,nr) - quantum yields. some are read, others are computed. - ! schumann-runge - part a - ! schumann-runge parameters - part b - ! ozone temperature coefficients for xsection - ! ----------------------------------------------------------------------- - ! read stand profiles - ! aerosol - ! close (incvol) - ! wavelengths and extraterrestrial irradiance - ! ----------------------------------------------------- - ! wave_length - ! WAVE LENGTHS USED BY PHOTOLYSIS PROGRAMS - ! FILE CREATED AUGUST 19, 1994 - ! FROM MADRONICH 1989 DATA FILE - ! et_flux - ! EXTRA-TERRESTIAL IRRADIANCE - ! FILE CREATED AUGUST 19, 1994 - ! FROM MADRONICH 1989 DATA FILE - ! ----------------------------------------------------------------------- - ! current jindex assignments - if calculation order changes - ! these change - subroutine yield must be changed! - ! process jindex notes - ! wavelength none center values, modified wmo grid - ! e.t.irradian none photons per bin, not per nm - ! absorption cross sections: - ! o2 absorp 1 schumman-runge corrected in srband - ! o3 -> 1d 2 at 275 k. correct t-dep in subgrid - ! o3 -> 3p 3 at 275 k. correct t-dep in subgrid - ! no2 4 - ! no3 -> no+o2 5 - ! no3 -> no2+o 6 - ! hno2 7 - ! hno3 8 - ! hno4 9 - ! h2o2 10 - ! ch2o -> rad 11 - ! ch2o -> mol 12 - ! ch3cho 13 - ! ch3coch3 14 - ! ch3coc2h5 15 - ! hcocho proc a 16 - ! ch3cocho 17 - ! hcoch=chcho 18 estimate, no reliable measurement - ! ch3o2h 19 - ! ch3coo2h 20 actually use 0.28*(h2o2 value) - ! ch3ono2 21 - ! hcocho proc b 22 - ! quantum yields: - ! no2 4 - ! ch2o -> rad 11 - ! ch2o -> mol 12 - ! ch3cho 13 - ! hcoch=chcho 18 (energetic threshold) - ! cross section and quantum yield data. this section assigns - ! yields for ntp air. yields are read from data file - ! some yields are temperature and/or pressure dependent:ch3cho, ch2o_b, - ! o3. - ! for ch2o_b and ch3cho, the data read above are stp values. these will - ! be - ! corrected in subgrid for t & ad dependence, after the altitude - ! dependent - ! values of t and ad are computed at each layer or level as appropriate. - ! the o3->o(1d) yield is also calculated later, in subgrid. - ! ----------------------------------------------------- - ! o2 cross section - ! ----------------------------------------------------- - ! o3 -> o1d cross section - ! ----------------------------------------------------- - ! o3 -> o3p cross section - ! ----------------------------------------------------- - ! no2 cross section - ! no2 quantum yield - ! ----------------------------------------------------- - ! no3 -> no + o2 cross section - ! no3 -> no + o2 quantum yield - ! ----------------------------------------------------- - ! no3 -> no2 + o cross section - ! no3 -> no2 + o quantum yield - ! ----------------------------------------------------- - ! hono cross section - ! hono cross quantum yield - ! ----------------------------------------------------- - ! hno3 cross section - ! hno3 cross quantum yield - ! HNO3 CROSS SECTION TEMPERATURE DEPENDENCE - ! ----------------------------------------------------- - ! hno4 cross section - ! hno4 cross quantum yield - ! ----------------------------------------------------- - ! h2o2 cross section - ! h2o2 cross quantum yield - ! ----------------------------------------------------- - ! hcho -> ho2 cross section - ! hcho -> ho2 quantum yield - ! ----------------------------------------------------- - ! hcho -> h2 cross section - ! hcho -> h2 quantum yield - ! ----------------------------------------------------- - ! ch3cho cross section - ! ch3cho (ntp) quantum yield - ! ----------------------------------------------------- - ! ch3coch3 cross section - ! ch3coch3 quantum yield - ! ----------------------------------------------------- - ! ch3coc2h5 cross section - ! ch3coc2h5 quantum yield - ! ----------------------------------------------------- - ! hcocho proc a cross section - ! hcocho a quantum yield - ! ----------------------------------------------------- - ! ch3cocho cross section - ! ch3cocho quantum yield - ! ----------------------------------------------------- - ! dcb cross section - ! dcb quantum yield - ! ----------------------------------------------------- - ! ch3o2h cross section - ! ch3o2h cross quantum yield - ! ----------------------------------------------------- - ! ch3coo2h cross section - ! ch3coo2h cross quantum yield - ! ----------------------------------------------------- - ! ch3ono2 cross section - ! ch3ono2 cross quantum yield - ! ----------------------------------------------------- - ! hcocho proc b cross section - ! hcocho b quantum yield - ! macr cross section - ! macr quantum yield - ! .. Parameters .. - INTEGER, PARAMETER :: kl0 = 30, kl1 = 130 - INTEGER, PARAMETER :: kldif = (kl1-kl0+1)*3 - INTEGER, PARAMETER :: nabv = 10, nj = 200, nreakj = 23 - INTEGER, PARAMETER :: mj = 2*nj - 2 - ! .. Local Scalars .. - INTEGER :: ip, kl - ! .. Local Arrays .. - REAL :: aerstd(51), airstd(51), albedoph(130), caabv(nabv), fext(130), & - o3abv(nabv), o3std(51), pabv(nabv), so3tx(70,3), sra(11,9), srb(11,5), & - tabv(nabv), tstd(51), txs(130,nreakj), wl(130), xqy(130,23), & - xs(130,nreakj), zabv(nabv), zstd(51) - ! .. Data Statements .. - DATA zabv/21., 22., 23., 24., 25., 30., 35., 40., 45., 50./ - DATA tabv/215.19, 215.19, 215.19, 215.19, 215.19, 217.39, 227.80, & - 243.19, 258.50, 265.70/ - DATA pabv/1.57E18, 1.34E18, 1.14E18, 9.76E17, 8.33E17, 3.83E17, 1.76E17, & - 8.31E16, 4.09E16, 2.14E16/ - DATA o3abv/4.88E12, 4.86E12, 4.73E12, 4.54E12, 4.32E12, 2.52E12, & - 1.40E12, 6.07E11, 2.03E11, 6.61E10/ - DATA caabv/1.64E-3, 1.23E-3, 9.45E-4, 7.49E-4, 6.30E-4, 1.90E-4, & - 5.00E-5, 1.32E-5, 3.46E-6, 9.14E-7/ - DATA zstd/0., 1., 2., 3., 4., 5., 6., 7., 8., 9., 10., 11., 12., 13., & - 14., 15., 16., 17., 18., 19., 20., 21., 22., 23., 24., 25., 26., 27., & - 28., 29., 30., 31., 32., 33., 34., 35., 36., 37., 38., 39., 40., 41., & - 42., 43., 44., 45., 46., 47., 48., 49., 50./ - DATA ((sra(kl,ip),ip=1,9),kl=1,11)/ -2.158311E+01, -4.164652E-01, & - 5.266362E-02, 1.655877E-02, 0., 0., 0., 0., 0., -2.184813E+01, & - -4.753880E-01, 4.519945E-02, 3.228313E-02, 3.079373E-03, 0., 0., 0., & - 0., -2.200507E+01, -4.628729E-01, -5.022541E-02, 2.545036E-02, & - 5.791406E-02, 1.179966E-02, -8.296876E-03, -3.238368E-03, & - -3.069686E-04, -2.205527E+01, -4.400848E-01, -5.687308E-03, & - 3.712279E-02, 6.025527E-03, 0., 0., 0., 0., -2.205261E+01, & - -5.707936E-01, -3.330207E-02, 5.959032E-02, 1.510540E-02, & - 1.000376E-03, 0., 0., 0., -2.228000E+01, -3.960759E-01, -2.995798E-02, & - 4.918104E-02, 9.269080E-03, -1.173411E-03, -2.599386E-04, 0., 0., & - -2.275796E+01, -2.054719E-01, -1.094205E-02, 2.079595E-02, & - 3.769638E-03, 0., 0., 0., 0., -2.297610E+01, -5.823677E-02, & - -1.007612E-01, 2.404666E-02, 4.761876E-02, 4.169606E-03, & - -7.126663E-03, -2.263652E-03, -1.971653E-04, -2.506084E+01, & - 3.442774E-02, -2.212047E-04, 6.186041E-07, -6.284394E-10, 0., 0., 0., & - 0., -2.313436E+01, 1.177283E-04, 0., 0., 0., 0., 0., 0., 0., & - -2.312205E+01, 0., 0., 0., 0., 0., 0., 0., 0./ - DATA ((srb(kl,ip),ip=1,5),kl=1,11)/ -2.431640E+03, 4.729722E+02, & - -3.452121E+01, 1.120677E+00, -1.365618E-02, -3.701955E+01, & - 3.623290E+00, -8.929223E-02, 0., 0., -1.086239E+03, 1.981847E+02, & - -1.359057E+01, 4.155845E-01, -4.788462E-03, -1.213108E+03, & - 2.277459E+02, -1.612207E+01, 5.101389E-01, -6.090518E-03, & - -8.334575E+01, 7.944254E+00, -1.898894E-01, 0., 0., -2.139117E+02, & - 2.612729E+01, -1.036749E+00, 1.317695E-02, 0., -3.281301E+02, & - 4.307004E+01, -1.870019E+00, 2.674331E-02, 0., 3.033416E+03, & - -5.978911E+02, 4.370384E+01, -1.406715E+00, 1.683967E-02, & - -2.535815E+00, 0., 0., 0., 0., -4.474937E+00, 0., 0., 0., 0., & - -2.996639E+00, 0., 0., 0., 0./ - DATA ((so3tx(kl,ip),kl=33,61),ip=1,3)/9.630E+00, 8.320E+00, 6.880E+00, & - 5.370E+00, 3.960E+00, 2.710E+00, 1.750E+00, 1.060E+00, 5.960E-01, & - 3.330E-01, 2.400E-01, 2.100E-01, 1.800E-01, 1.600E-01, 1.400E-01, & - 1.200E-01, 1.050E-01, 9.000E-02, 8.000E-02, 7.000E-02, 6.000E-02, & - 5.500E-02, 4.000E-02, 2.190E-02, 1.010E-02, 5.080E-03, 2.120E-03, & - 8.290E-04, 2.940E-04, 1.190E-03, 3.640E-04, 2.460E-04, 1.030E-03, & - 1.690E-03, 1.450E-03, 8.940E-04, 7.830E-04, 4.940E-04, 3.550E-04, & - 2.950E-04, 2.750E-04, 2.500E-04, 2.300E-04, 2.080E-04, 1.860E-04, & - 1.640E-04, 1.450E-04, 1.280E-04, 1.121E-04, 1.000E-04, 9.200E-05, & - 7.500E-05, 4.830E-05, 3.430E-05, 1.820E-05, 8.850E-06, 4.270E-06, & - 5.300E-06, -1.740E-05, 2.470E-06, 1.170E-05, 1.260E-06, -6.860E-06, & - -2.890E-06, 3.590E-06, 2.000E-06, 3.660E-06, 2.600E-06, 2.170E-06, & - 1.950E-06, 1.380E-06, 1.650E-06, 1.550E-06, 1.460E-06, 1.340E-06, & - 1.210E-06, 1.130E-06, 1.060E-06, 9.400E-07, 8.700E-07, 7.500E-07, & - 5.200E-07, 2.660E-07, 1.630E-07, 1.260E-07, 8.710E-08, 3.500E-08/ - DATA aerstd/2.40E-1, 1.06E-1, 4.56E-2, 1.91E-2, 1.01E-2, 7.63E-3, & - 5.38E-3, 5.00E-3, 5.15E-3, 4.94E-3, 4.82E-3, 4.51E-3, 4.74E-3, & - 4.37E-3, 4.28E-3, 4.03E-3, 3.83E-3, 3.78E-3, 3.88E-3, 3.08E-3, & - 2.26E-3, 1.64E-3, 1.23E-3, 9.45E-4, 7.49E-4, 6.30E-4, 5.50E-4, & - 4.21E-4, 3.22E-4, 2.48E-4, 1.90E-4, 1.45E-4, 1.11E-4, 8.51E-5, & - 6.52E-5, 5.00E-5, 3.83E-5, 2.93E-5, 2.25E-5, 1.72E-5, 1.32E-5, & - 1.01E-5, 7.72E-6, 5.91E-6, 4.53E-6, 3.46E-6, 2.66E-6, 2.04E-6, & - 1.56E-6, 1.19E-6, 9.14E-7/ - DATA (wl(kl),kl=1,130)/1.861E+02, 1.878E+02, 1.896E+02, 1.914E+02, & - 1.933E+02, 1.952E+02, 1.971E+02, 1.990E+02, 2.010E+02, 2.031E+02, & - 2.052E+02, 2.073E+02, 2.094E+02, 2.117E+02, 2.139E+02, 2.162E+02, & - 2.186E+02, 2.210E+02, 2.235E+02, 2.260E+02, 2.286E+02, 2.313E+02, & - 2.340E+02, 2.367E+02, 2.396E+02, 2.425E+02, 2.454E+02, 2.485E+02, & - 2.516E+02, 2.548E+02, 2.582E+02, 2.615E+02, 2.650E+02, 2.685E+02, & - 2.722E+02, 2.759E+02, 2.798E+02, 2.837E+02, 2.878E+02, 2.920E+02, & - 2.963E+02, 3.005E+02, 3.030E+02, 3.040E+02, 3.050E+02, 3.060E+02, & - 3.070E+02, 3.080E+02, 3.090E+02, 3.100E+02, 3.110E+02, 3.120E+02, & - 3.130E+02, 3.140E+02, 3.160E+02, 3.200E+02, 3.250E+02, 3.300E+02, & - 3.350E+02, 3.400E+02, 3.450E+02, 3.500E+02, 3.550E+02, 3.600E+02, & - 3.650E+02, 3.700E+02, 3.750E+02, 3.800E+02, 3.850E+02, 3.900E+02, & - 3.950E+02, 4.000E+02, 4.050E+02, 4.100E+02, 4.150E+02, 4.200E+02, & - 4.250E+02, 4.300E+02, 4.350E+02, 4.400E+02, 4.450E+02, 4.500E+02, & - 4.550E+02, 4.600E+02, 4.650E+02, 4.700E+02, 4.750E+02, 4.800E+02, & - 4.850E+02, 4.900E+02, 4.950E+02, 5.000E+02, 5.050E+02, 5.100E+02, & - 5.150E+02, 5.200E+02, 5.250E+02, 5.300E+02, 5.350E+02, 5.400E+02, & - 5.450E+02, 5.500E+02, 5.550E+02, 5.600E+02, 5.650E+02, 5.700E+02, & - 5.750E+02, 5.800E+02, 5.850E+02, 5.900E+02, 5.950E+02, 6.000E+02, & - 6.050E+02, 6.100E+02, 6.150E+02, 6.200E+02, 6.250E+02, 6.300E+02, & - 6.350E+02, 6.400E+02, 6.448E+02, 6.510E+02, 6.600E+02, 6.700E+02, & - 6.800E+02, 6.900E+02, 7.000E+02, 7.100E+02, 7.200E+02, 7.300E+02/ - DATA (fext(kl),kl=1,130)/3.620E+11, 4.730E+11, 5.610E+11, 6.630E+11, & - 6.900E+11, 9.560E+11, 1.150E+12, 1.270E+12, 1.520E+12, 1.780E+12, & - 2.200E+12, 2.690E+12, 4.540E+12, 7.140E+12, 8.350E+12, 8.390E+12, & - 1.080E+13, 1.180E+13, 1.600E+13, 1.340E+13, 1.410E+13, 1.570E+13, & - 1.380E+13, 1.600E+13, 1.450E+13, 2.200E+13, 1.990E+13, 1.970E+13, & - 1.940E+13, 2.910E+13, 4.950E+13, 4.530E+13, 1.070E+14, 1.200E+14, & - 1.100E+14, 1.040E+14, 8.240E+13, 1.520E+14, 2.150E+14, 3.480E+14, & - 3.396E+14, 2.730E+14, 9.109E+13, 8.745E+13, 9.577E+13, 8.507E+13, & - 9.383E+13, 1.030E+14, 9.722E+13, 7.751E+13, 1.277E+14, 1.087E+14, & - 1.102E+14, 1.184E+14, 3.153E+14, 5.930E+14, 6.950E+14, 8.150E+14, & - 7.810E+14, 8.350E+14, 8.140E+14, 8.530E+14, 9.170E+14, 8.380E+14, & - 1.040E+15, 1.100E+15, 9.790E+14, 1.130E+15, 8.890E+14, 1.140E+15, & - 9.170E+14, 1.690E+15, 1.700E+15, 1.840E+15, 1.870E+15, 1.950E+15, & - 1.810E+15, 1.670E+15, 1.980E+15, 2.020E+15, 2.180E+15, 2.360E+15, & - 2.310E+15, 2.390E+15, 2.380E+15, 2.390E+15, 2.440E+15, 2.510E+15, & - 2.300E+15, 2.390E+15, 2.480E+15, 2.400E+15, 2.460E+15, 2.490E+15, & - 2.320E+15, 2.390E+15, 2.420E+15, 2.550E+15, 2.510E+15, 2.490E+15, & - 2.550E+15, 2.530E+15, 2.540E+15, 2.500E+15, 2.570E+15, 2.580E+15, & - 2.670E+15, 2.670E+15, 2.700E+15, 2.620E+15, 2.690E+15, 2.630E+15, & - 2.680E+15, 2.660E+15, 2.590E+15, 2.690E+15, 2.610E+15, 2.620E+15, & - 2.620E+15, 2.630E+15, 2.392E+15, 3.998E+15, 5.115E+15, 5.225E+15, & - 5.215E+15, 5.105E+15, 5.140E+15, 5.010E+15, 4.930E+15, 4.895E+15/ - DATA (xs(kl,1),kl=1,130)/7.040E-24, 7.360E-24, 7.640E-24, 7.870E-24, & - 8.040E-24, 8.140E-24, 8.170E-24, 8.130E-24, 8.010E-24, 7.840E-24, & - 7.630E-24, 7.330E-24, 6.990E-24, 6.450E-24, 5.810E-24, 5.230E-24, & - 4.710E-24, 4.260E-24, 3.800E-24, 3.350E-24, 2.900E-24, 2.450E-24, & - 2.050E-24, 1.690E-24, 1.300E-24, 9.300E-25, 0., 0., 0., 0., 0., 0., & - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., & - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., & - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., & - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., & - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., & - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./ - DATA (xs(kl,2),kl=1,130)/0.622E-18, 0.576E-18, 0.526E-18, 0.476E-18, & - 0.428E-18, 0.383E-18, 0.347E-18, 0.323E-18, 0.314E-18, 0.326E-18, & - 0.364E-18, 0.434E-18, 0.542E-18, 0.699E-18, 0.921E-18, 0.119E-17, & - 0.155E-17, 0.199E-17, 0.256E-17, 0.323E-17, 0.400E-17, 0.483E-17, & - 0.579E-17, 0.686E-17, 0.797E-17, 0.900E-17, 0.100E-16, 0.108E-16, & - 0.113E-16, 0.115E-16, 0.112E-16, 0.106E-16, 0.963E-17, 0.836E-17, & - 0.695E-17, 0.545E-17, 0.404E-17, 0.280E-17, 0.183E-17, 0.112E-17, & - 0.647E-18, 0.369E-18, 0.270E-18, 0.238E-18, 0.203E-18, 0.183E-18, & - 0.161E-18, 0.139E-18, 0.122E-18, 0.105E-18, 0.939E-19, 0.825E-19, & - 0.711E-19, 0.653E-19, 0.486E-19, 0.276E-19, 0.137E-19, 0.707E-20, & - 0.330E-20, 0.152E-20, 0.816E-21, 0.266E-21, 0.109E-21, 0.549E-22, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.291E-22, 0.314E-22, 0.399E-22, & - 0.654E-22, 0.683E-22, 0.866E-22, 0.125E-21, 0.149E-21, 0.171E-21, & - 0.212E-21, 0.357E-21, 0.368E-21, 0.406E-21, 0.489E-21, 0.711E-21, & - 0.843E-21, 0.828E-21, 0.909E-21, 0.122E-20, 0.162E-20, 0.158E-20, & - 0.160E-20, 0.178E-20, 0.207E-20, 0.255E-20, 0.274E-20, 0.288E-20, & - 0.307E-20, 0.317E-20, 0.336E-20, 0.388E-20, 0.431E-20, 0.467E-20, & - 0.475E-20, 0.455E-20, 0.435E-20, 0.442E-20, 0.461E-20, 0.489E-20, & - 0.484E-20, 0.454E-20, 0.424E-20, 0.390E-20, 0.360E-20, 0.343E-20, & - 0.317E-20, 0.274E-20, 0.261E-20, 0.240E-20, 0.207E-20, 0.172E-20, & - 0.137E-20, 0.111E-20, 0.913E-21, 0.793E-21, 0.640E-21, 0.514E-21/ - DATA (xs(kl,3),kl=1,130)/0.622E-18, 0.576E-18, 0.526E-18, 0.476E-18, & - 0.428E-18, 0.383E-18, 0.347E-18, 0.323E-18, 0.314E-18, 0.326E-18, & - 0.364E-18, 0.434E-18, 0.542E-18, 0.699E-18, 0.921E-18, 0.119E-17, & - 0.155E-17, 0.199E-17, 0.256E-17, 0.323E-17, 0.400E-17, 0.483E-17, & - 0.579E-17, 0.686E-17, 0.797E-17, 0.900E-17, 0.100E-16, 0.108E-16, & - 0.113E-16, 0.115E-16, 0.112E-16, 0.106E-16, 0.963E-17, 0.836E-17, & - 0.695E-17, 0.545E-17, 0.404E-17, 0.280E-17, 0.183E-17, 0.112E-17, & - 0.647E-18, 0.369E-18, 0.270E-18, 0.238E-18, 0.203E-18, 0.183E-18, & - 0.161E-18, 0.139E-18, 0.122E-18, 0.105E-18, 0.939E-19, 0.825E-19, & - 0.711E-19, 0.653E-19, 0.486E-19, 0.276E-19, 0.137E-19, 0.707E-20, & - 0.330E-20, 0.152E-20, 0.816E-21, 0.266E-21, 0.109E-21, 0.549E-22, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.291E-22, 0.314E-22, 0.399E-22, & - 0.654E-22, 0.683E-22, 0.866E-22, 0.125E-21, 0.149E-21, 0.171E-21, & - 0.212E-21, 0.357E-21, 0.368E-21, 0.406E-21, 0.489E-21, 0.711E-21, & - 0.843E-21, 0.828E-21, 0.909E-21, 0.122E-20, 0.162E-20, 0.158E-20, & - 0.160E-20, 0.178E-20, 0.207E-20, 0.255E-20, 0.274E-20, 0.288E-20, & - 0.307E-20, 0.317E-20, 0.336E-20, 0.388E-20, 0.431E-20, 0.467E-20, & - 0.475E-20, 0.455E-20, 0.435E-20, 0.442E-20, 0.461E-20, 0.489E-20, & - 0.484E-20, 0.454E-20, 0.424E-20, 0.390E-20, 0.360E-20, 0.343E-20, & - 0.317E-20, 0.274E-20, 0.261E-20, 0.240E-20, 0.207E-20, 0.172E-20, & - 0.137E-20, 0.111E-20, 0.913E-21, 0.793E-21, 0.640E-21, 0.514E-21/ - DATA (xs(kl,4),kl=1,130)/0.259E-18, 0.272E-18, 0.286E-18, 0.273E-18, & - 0.251E-18, 0.244E-18, 0.246E-18, 0.246E-18, 0.282E-18, 0.415E-18, & - 0.448E-18, 0.445E-18, 0.464E-18, 0.487E-18, 0.482E-18, 0.502E-18, & - 0.444E-18, 0.471E-18, 0.377E-18, 0.393E-18, 0.274E-18, 0.278E-18, & - 0.169E-18, 0.162E-18, 0.882E-19, 0.747E-19, 0.391E-19, 0.275E-19, & - 0.201E-19, 0.197E-19, 0.211E-19, 0.236E-19, 0.270E-19, 0.325E-19, & - 0.379E-19, 0.503E-19, 0.588E-19, 0.700E-19, 0.815E-19, 0.972E-19, & - 0.115E-18, 0.128E-18, 0.154E-18, 0.159E-18, 0.158E-18, 0.156E-18, & - 0.164E-18, 0.166E-18, 0.182E-18, 0.184E-18, 0.192E-18, 0.204E-18, & - 0.204E-18, 0.202E-18, 0.224E-18, 0.248E-18, 0.281E-18, 0.313E-18, & - 0.343E-18, 0.380E-18, 0.407E-18, 0.431E-18, 0.472E-18, 0.483E-18, & - 0.517E-18, 0.532E-18, 0.551E-18, 0.564E-18, 0.576E-18, 0.593E-18, & - 0.585E-18, 0.602E-18, 0.578E-18, 0.600E-18, 0.565E-18, 0.581E-18, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ - DATA ((xqy(kl,ip),kl=kl0,kl1),ip=1,3)/kldif*1./ - DATA (xqy(kl,4),kl=1,130)/1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 0.999000, 0.998000, 0.997000, 0.996500, 0.996000, 0.996000, 0.996000, & - 0.996000, 0.995000, 0.995000, 0.995000, 0.995000, 0.995000, 0.994000, & - 0.994000, 0.994000, 0.993000, 0.992000, 0.991000, 0.990000, 0.989000, & - 0.988000, 0.987000, 0.986000, 0.984000, 0.983000, 0.981000, 0.979000, & - 0.975000, 0.969000, 0.960000, 0.927000, 0.694000, 0.355000, 0.134000, & - 0.060000, 0.018000, 0.000900, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000/ - DATA (xs(kl,5),kl=1,130)/0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.160E-19, 0.240E-19, 0.520E-19, 0.760E-19, & - 0.110E-18, 0.136E-18, 0.170E-18, 0.198E-18, 0.220E-18, 0.288E-18, & - 0.358E-18, 0.396E-18, 0.502E-18, 0.598E-18, 0.694E-18, 0.716E-18, & - 0.828E-18, 0.984E-18, 0.110E-17, 0.114E-17, 0.125E-17, 0.153E-17, & - 0.156E-17, 0.168E-17, 0.169E-17, 0.217E-17, 0.229E-17, 0.208E-17, & - 0.213E-17, 0.261E-17, 0.299E-17, 0.329E-17, 0.278E-17, 0.281E-17, & - 0.307E-17, 0.334E-17, 0.322E-17, 0.554E-17, 0.441E-17, 0.314E-17, & - 0.365E-17, 0.188E-17, 0.233E-17, 0.473E-17, 0.100E-16, 0.584E-17, & - 0.180E-17, 0.135E-17, 0.822E-18, 0.640E-18, 0.777E-17, 0.134E-17, & - 0.337E-18, 0.175E-19, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ - DATA (xqy(kl,5),kl=1,130)/0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.038000, & - 0.191000, 0.326000, 0.311000, 0.272000, 0.233000, 0.194000, 0.156000, & - 0.117000, 0.078000, 0.039000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000/ - DATA (xs(kl,6),kl=1,130)/0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.160E-19, 0.240E-19, 0.520E-19, 0.760E-19, & - 0.110E-18, 0.136E-18, 0.170E-18, 0.198E-18, 0.220E-18, 0.288E-18, & - 0.358E-18, 0.396E-18, 0.502E-18, 0.598E-18, 0.694E-18, 0.716E-18, & - 0.828E-18, 0.984E-18, 0.110E-17, 0.114E-17, 0.125E-17, 0.153E-17, & - 0.156E-17, 0.168E-17, 0.169E-17, 0.217E-17, 0.229E-17, 0.208E-17, & - 0.213E-17, 0.261E-17, 0.299E-17, 0.329E-17, 0.278E-17, 0.281E-17, & - 0.307E-17, 0.334E-17, 0.322E-17, 0.554E-17, 0.441E-17, 0.314E-17, & - 0.365E-17, 0.188E-17, 0.233E-17, 0.473E-17, 0.100E-16, 0.584E-17, & - 0.180E-17, 0.135E-17, 0.822E-18, 0.640E-18, 0.777E-17, 0.134E-17, & - 0.337E-18, 0.175E-19, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ - DATA (xqy(kl,6),kl=1,130)/1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 0.962000, & - 0.809000, 0.661000, 0.578000, 0.506000, 0.433000, 0.361000, 0.289000, & - 0.217000, 0.144000, 0.072000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000/ - DATA (xs(kl,7),kl=1,130)/0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.130E-19, 0.190E-19, 0.280E-19, & - 0.220E-19, 0.360E-19, 0.340E-19, 0.536E-19, 0.534E-19, 0.111E-18, & - 0.786E-19, 0.189E-18, 0.116E-18, 0.130E-18, 0.279E-18, 0.954E-19, & - 0.179E-18, 0.260E-18, 0.590E-19, 0.101E-18, 0.176E-18, 0.304E-19, & - 0.775E-20, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ - DATA (xqy(kl,7),kl=1,130)/1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000/ - DATA (xs(kl,8),kl=1,130)/0.000E+00, 0.000E+00, 0.000E+00, 0.127E-16, & - 0.114E-16, 0.100E-16, 0.847E-17, 0.679E-17, 0.518E-17, 0.382E-17, & - 0.270E-17, 0.182E-17, 0.120E-17, 0.730E-18, 0.451E-18, 0.283E-18, & - 0.195E-18, 0.134E-18, 0.102E-18, 0.802E-19, 0.650E-19, 0.518E-19, & - 0.414E-19, 0.321E-19, 0.265E-19, 0.230E-19, 0.209E-19, 0.199E-19, & - 0.196E-19, 0.195E-19, 0.193E-19, 0.188E-19, 0.180E-19, 0.170E-19, & - 0.152E-19, 0.134E-19, 0.113E-19, 0.924E-20, 0.719E-20, 0.532E-20, & - 0.371E-20, 0.249E-20, 0.188E-20, 0.167E-20, 0.150E-20, 0.133E-20, & - 0.119E-20, 0.105E-20, 0.932E-21, 0.814E-21, 0.721E-21, 0.628E-21, & - 0.547E-21, 0.465E-21, 0.362E-21, 0.197E-21, 0.975E-22, 0.452E-22, & - 0.222E-22, 0.110E-22, 0.604E-23, 0.420E-23, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ - DATA (xqy(kl,8),kl=1,130)/1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000/ - DATA (txs(kl,8),kl=1,130)/0.000000, 0.000000, 0.000000, 1.700000, & - 1.650000, 1.660000, 1.690000, 1.740000, 1.770000, 1.850000, 1.970000, & - 2.080000, 2.170000, 2.170000, 2.210000, 2.150000, 2.060000, 1.960000, & - 1.840000, 1.780000, 1.800000, 1.860000, 1.900000, 1.970000, 1.970000, & - 1.970000, 1.880000, 1.750000, 1.610000, 1.440000, 1.340000, 1.230000, & - 1.180000, 1.140000, 1.120000, 1.140000, 1.140000, 1.180000, 1.220000, & - 1.250000, 1.450000, 1.490000, 1.560000, 1.640000, 1.690000, 1.780000, & - 1.870000, 1.940000, 2.040000, 2.150000, 2.270000, 2.380000, 2.620000, & - 2.700000, 2.920000, 3.100000, 3.240000, 3.520000, 3.770000, 3.910000, & - 4.230000, 4.700000, 5.150000, 5.250000, 5.740000, 6.450000, 6.700000, & - 7.160000, 7.550000, 8.160000, 9.750000, 9.930000, 9.600000, 10.50000, & - 10.80000, 11.80000, 11.80000, 9.300000, 12.10000, 11.90000, 9.300000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000/ - DATA (xs(kl,9),kl=1,130)/0.000E+00, 0.000E+00, 0.100E-16, 0.980E-17, & - 0.918E-17, 0.828E-17, 0.723E-17, 0.618E-17, 0.517E-17, 0.426E-17, & - 0.352E-17, 0.292E-17, 0.245E-17, 0.205E-17, 0.175E-17, 0.151E-17, & - 0.131E-17, 0.115E-17, 0.102E-17, 0.916E-18, 0.827E-18, 0.752E-18, & - 0.687E-18, 0.631E-18, 0.578E-18, 0.529E-18, 0.484E-18, 0.439E-18, & - 0.396E-18, 0.353E-18, 0.311E-18, 0.271E-18, 0.231E-18, 0.194E-18, & - 0.158E-18, 0.125E-18, 0.946E-19, 0.694E-19, 0.485E-19, 0.325E-19, & - 0.210E-19, 0.135E-19, 0.104E-19, 0.938E-20, 0.846E-20, 0.763E-20, & - 0.689E-20, 0.623E-20, 0.564E-20, 0.511E-20, 0.463E-20, 0.420E-20, & - 0.382E-20, 0.347E-20, 0.287E-20, 0.191E-20, 0.101E-20, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ - DATA (xqy(kl,9),kl=1,130)/1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000/ - DATA (xs(kl,10),kl=1,130)/0.000E+00, 0.000E+00, 0.695E-18, 0.635E-18, & - 0.586E-18, 0.547E-18, 0.515E-18, 0.488E-18, 0.462E-18, 0.436E-18, & - 0.412E-18, 0.388E-18, 0.365E-18, 0.341E-18, 0.318E-18, 0.295E-18, & - 0.272E-18, 0.250E-18, 0.229E-18, 0.209E-18, 0.190E-18, 0.172E-18, & - 0.155E-18, 0.140E-18, 0.126E-18, 0.112E-18, 0.999E-19, 0.881E-19, & - 0.774E-19, 0.675E-19, 0.582E-19, 0.500E-19, 0.425E-19, 0.358E-19, & - 0.298E-19, 0.247E-19, 0.201E-19, 0.164E-19, 0.131E-19, 0.105E-19, & - 0.828E-20, 0.658E-20, 0.573E-20, 0.543E-20, 0.514E-20, 0.486E-20, & - 0.460E-20, 0.435E-20, 0.412E-20, 0.390E-20, 0.369E-20, 0.349E-20, & - 0.330E-20, 0.312E-20, 0.279E-20, 0.220E-20, 0.160E-20, 0.130E-20, & - 0.100E-20, 0.700E-21, 0.500E-21, 0.400E-21, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ - DATA (xqy(kl,10),kl=1,130)/1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000/ - DATA (xs(kl,11),kl=1,130)/0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.293E-21, 0.342E-21, 0.102E-20, 0.456E-21, 0.527E-21, 0.537E-21, & - 0.347E-21, 0.759E-21, 0.628E-21, 0.974E-21, 0.104E-20, 0.219E-20, & - 0.228E-20, 0.357E-20, 0.374E-20, 0.584E-20, 0.651E-20, 0.102E-19, & - 0.114E-19, 0.176E-19, 0.180E-19, 0.259E-19, 0.227E-19, 0.275E-19, & - 0.318E-19, 0.160E-19, 0.245E-19, 0.637E-19, 0.426E-19, 0.399E-19, & - 0.186E-19, 0.131E-19, 0.310E-19, 0.182E-19, 0.596E-20, 0.111E-19, & - 0.911E-20, 0.457E-19, 0.423E-19, 0.142E-19, 0.243E-19, 0.178E-19, & - 0.129E-20, 0.213E-19, 0.661E-20, 0.139E-20, 0.827E-20, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ - DATA (xqy(kl,11),kl=1,130)/0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.264091, & - 0.288940, 0.297038, 0.295059, 0.289384, 0.285483, 0.288087, 0.301000, & - 0.326819, 0.366764, 0.420506, 0.485961, 0.559106, 0.633887, 0.702103, & - 0.733457, 0.740762, 0.747845, 0.753000, 0.754000, 0.754800, 0.754000, & - 0.753000, 0.752000, 0.751000, 0.749500, 0.745000, 0.739600, 0.731700, & - 0.723300, 0.690300, 0.593100, 0.458100, 0.305000, 0.122300, 0.003429, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000/ - DATA (xs(kl,12),kl=1,130)/0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.293E-21, 0.342E-21, 0.102E-20, 0.456E-21, 0.527E-21, 0.537E-21, & - 0.347E-21, 0.759E-21, 0.628E-21, 0.974E-21, 0.104E-20, 0.219E-20, & - 0.228E-20, 0.357E-20, 0.374E-20, 0.584E-20, 0.651E-20, 0.102E-19, & - 0.114E-19, 0.176E-19, 0.180E-19, 0.259E-19, 0.227E-19, 0.275E-19, & - 0.318E-19, 0.160E-19, 0.245E-19, 0.637E-19, 0.426E-19, 0.399E-19, & - 0.186E-19, 0.131E-19, 0.310E-19, 0.182E-19, 0.596E-20, 0.111E-19, & - 0.911E-20, 0.457E-19, 0.423E-19, 0.142E-19, 0.243E-19, 0.178E-19, & - 0.129E-20, 0.213E-19, 0.661E-20, 0.139E-20, 0.827E-20, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ - DATA (xqy(kl,12),kl=1,130)/0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.492085, & - 0.483681, 0.483325, 0.487471, 0.492514, 0.495532, 0.493893, 0.485473, & - 0.468839, 0.443373, 0.409405, 0.368400, 0.323132, 0.307820, 0.294564, & - 0.280920, 0.266885, 0.253277, 0.249000, 0.247000, 0.245600, 0.248000, & - 0.251000, 0.254000, 0.257000, 0.260200, 0.264500, 0.269000, 0.273500, & - 0.278900, 0.310300, 0.394100, 0.508100, 0.676100, 0.759300, 0.636100, & - 0.501500, 0.373400, 0.229000, 0.103600, 0.005906, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000/ - DATA (xs(kl,13),kl=1,130)/0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.593E-21, 0.548E-21, & - 0.552E-21, 0.513E-21, 0.480E-21, 0.482E-21, 0.482E-21, 0.482E-21, & - 0.536E-21, 0.593E-21, 0.734E-21, 0.948E-21, 0.125E-20, 0.171E-20, & - 0.234E-20, 0.321E-20, 0.434E-20, 0.582E-20, 0.770E-20, 0.991E-20, & - 0.127E-19, 0.159E-19, 0.200E-19, 0.237E-19, 0.287E-19, 0.326E-19, & - 0.376E-19, 0.408E-19, 0.444E-19, 0.463E-19, 0.466E-19, 0.465E-19, & - 0.432E-19, 0.406E-19, 0.372E-19, 0.348E-19, 0.342E-19, 0.342E-19, & - 0.336E-19, 0.333E-19, 0.314E-19, 0.293E-19, 0.276E-19, 0.253E-19, & - 0.247E-19, 0.243E-19, 0.210E-19, 0.169E-19, 0.108E-19, 0.651E-20, & - 0.314E-20, 0.138E-20, 0.224E-21, 0.947E-22, 0.425E-22, 0.229E-22, & - 0.275E-23, 0.192E-23, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ - DATA (xqy(kl,13),kl=1,130)/0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.310000, & - 0.349300, 0.377900, 0.430300, 0.501600, 0.566200, 0.561500, 0.541100, & - 0.512100, 0.473200, 0.430000, 0.392000, 0.376000, 0.360000, 0.344000, & - 0.328000, 0.312000, 0.296000, 0.279800, 0.262500, 0.245000, 0.227500, & - 0.210000, 0.175000, 0.109300, 0.051880, 0.006266, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000/ - DATA (xs(kl,14),kl=1,130)/0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 1.003E-20, 1.873E-21, & - 1.408E-21, 1.084E-21, 1.030E-21, 1.071E-21, 1.176E-21, 1.371E-21, & - 1.690E-21, 2.153E-21, 2.779E-21, 3.561E-21, 4.575E-21, 5.906E-21, & - 7.585E-21, 9.622E-21, 1.212E-20, 1.516E-20, 1.863E-20, 2.252E-20, & - 2.676E-20, 3.143E-20, 3.616E-20, 4.058E-20, 4.475E-20, 4.774E-20, & - 5.029E-20, 5.065E-20, 5.049E-20, 4.790E-20, 4.415E-20, 3.940E-20, & - 3.308E-20, 2.717E-20, 2.371E-20, 2.244E-20, 2.106E-20, 1.953E-20, & - 1.801E-20, 1.663E-20, 1.538E-20, 1.408E-20, 1.277E-20, 1.173E-20, & - 1.081E-20, 9.675E-21, 7.783E-21, 4.712E-21, 2.078E-21, 7.065E-22, & - 1.973E-22, 5.745E-23, 2.137E-23, 8.235E-24, 5.686E-24, 2.157E-24, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ - DATA (xqy(kl,14),kl=1,130)/0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.766400, 0.779200, 0.792800, 0.776000, & - 0.720000, 0.672000, 0.620200, 0.586900, 0.551800, 0.457500, 0.355000, & - 0.270000, 0.205500, 0.145000, 0.120000, 0.110000, 0.100000, 0.090000, & - 0.080000, 0.070000, 0.060000, 0.050000, 0.047800, 0.045600, 0.043400, & - 0.041200, 0.036800, 0.028000, 0.030500, 0.033000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000/ - DATA (xs(kl,15),kl=1,130)/0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.234E-19, 0.685E-20, & - 0.215E-20, 0.168E-20, 0.159E-20, 0.164E-20, 0.181E-20, 0.203E-20, & - 0.230E-20, 0.268E-20, 0.320E-20, 0.387E-20, 0.471E-20, 0.582E-20, & - 0.728E-20, 0.913E-20, 0.115E-19, 0.145E-19, 0.180E-19, 0.222E-19, & - 0.267E-19, 0.321E-19, 0.374E-19, 0.430E-19, 0.479E-19, 0.525E-19, & - 0.555E-19, 0.576E-19, 0.575E-19, 0.555E-19, 0.518E-19, 0.460E-19, & - 0.388E-19, 0.319E-19, 0.269E-19, 0.251E-19, 0.233E-19, 0.217E-19, & - 0.202E-19, 0.188E-19, 0.173E-19, 0.158E-19, 0.142E-19, 0.128E-19, & - 0.114E-19, 0.101E-19, 0.796E-20, 0.463E-20, 0.196E-20, 0.705E-21, & - 0.207E-21, 0.545E-22, 0.145E-22, 0.431E-23, 0.471E-23, 0.157E-23, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ - DATA (xqy(kl,15),kl=1,130)/0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.766400, 0.779200, 0.792800, 0.776000, & - 0.720000, 0.672000, 0.620200, 0.586900, 0.551800, 0.457500, 0.355000, & - 0.270000, 0.205500, 0.145000, 0.120000, 0.110000, 0.100000, 0.090000, & - 0.080000, 0.070000, 0.060000, 0.050000, 0.047800, 0.045600, 0.043400, & - 0.041200, 0.036800, 0.028000, 0.030500, 0.033000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000/ - DATA (xs(kl,16),kl=1,130)/0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.340E-20, 0.401E-20, 0.486E-20, 0.573E-20, 0.662E-20, 0.754E-20, & - 0.906E-20, 0.112E-19, 0.133E-19, 0.162E-19, 0.202E-19, 0.224E-19, & - 0.248E-19, 0.276E-19, 0.289E-19, 0.318E-19, 0.322E-19, 0.321E-19, & - 0.338E-19, 0.343E-19, 0.307E-19, 0.290E-19, 0.275E-19, 0.272E-19, & - 0.272E-19, 0.272E-19, 0.272E-19, 0.273E-19, 0.280E-19, 0.283E-19, & - 0.268E-19, 0.249E-19, 0.212E-19, 0.151E-19, 0.127E-19, 0.142E-19, & - 0.229E-19, 0.358E-20, 0.000E+00, 0.000E+00, 0.286E-21, 0.208E-20, & - 0.344E-20, 0.764E-20, 0.107E-19, 0.159E-19, 0.166E-19, 0.303E-19, & - 0.263E-19, 0.336E-19, 0.366E-19, 0.456E-19, 0.643E-19, 0.546E-19, & - 0.922E-19, 0.677E-19, 0.599E-19, 0.117E-18, 0.715E-19, 0.730E-19, & - 0.201E-18, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ - DATA (xqy(kl,16),kl=1,130)/0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, & - 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, & - 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, & - 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, & - 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, & - 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, & - 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, & - 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, & - 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, & - 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000/ - DATA (xs(kl,17),kl=1,130)/0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.131E-19, 0.142E-19, 0.156E-19, & - 0.174E-19, 0.189E-19, 0.205E-19, 0.219E-19, 0.233E-19, 0.252E-19, & - 0.269E-19, 0.285E-19, 0.313E-19, 0.338E-19, 0.362E-19, 0.394E-19, & - 0.427E-19, 0.450E-19, 0.486E-19, 0.476E-19, 0.479E-19, 0.465E-19, & - 0.420E-19, 0.371E-19, 0.352E-19, 0.344E-19, 0.336E-19, 0.316E-19, & - 0.296E-19, 0.276E-19, 0.256E-19, 0.237E-19, 0.227E-19, 0.218E-19, & - 0.208E-19, 0.199E-19, 0.182E-19, 0.151E-19, 0.938E-20, 0.652E-20, & - 0.482E-20, 0.323E-20, 0.300E-20, 0.394E-20, 0.560E-20, 0.695E-20, & - 0.108E-19, 0.148E-19, 0.191E-19, 0.243E-19, 0.322E-19, 0.403E-19, & - 0.473E-19, 0.566E-19, 0.692E-19, 0.846E-19, 0.968E-19, 0.103E-18, & - 0.102E-18, 0.101E-18, 0.106E-18, 0.104E-18, 0.994E-19, 0.813E-19, & - 0.395E-19, 0.109E-19, 0.327E-20, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ - DATA (xqy(kl,17),kl=1,130)/1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 0.990000, 0.990000, 0.990000, & - 0.980000, 0.980000, 0.980000, 0.980000, 0.970000, 0.970000, 0.970000, & - 0.960000, 0.960000, 0.940000, 0.920000, 0.880000, 0.825000, 0.750000, & - 0.660000, 0.560000, 0.480000, 0.400000, 0.320000, 0.250000, 0.200000, & - 0.150000, 0.120000, 0.100000, 0.080000, 0.060000, 0.050000, 0.040000, & - 0.030000, 0.020000, 0.005000, 0.005000, 0.005000, 0.005000, 0.005000, & - 0.005000, 0.005000, 0.005000, 0.005000, 0.005000, 0.005000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000/ - DATA (xs(kl,18),kl=1,130)/0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, & - 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, & - 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, & - 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, & - 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, & - 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, & - 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, & - 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, & - 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, & - 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, & - 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ - DATA (xqy(kl,18),kl=1,130)/1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 0.500000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000/ - DATA (xs(kl,19),kl=1,130)/0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.320E-18, 0.268E-18, 0.226E-18, 0.193E-18, & - 0.167E-18, 0.147E-18, 0.129E-18, 0.115E-18, 0.102E-18, 0.899E-19, & - 0.797E-19, 0.708E-19, 0.623E-19, 0.548E-19, 0.483E-19, 0.422E-19, & - 0.369E-19, 0.321E-19, 0.278E-19, 0.242E-19, 0.209E-19, 0.180E-19, & - 0.154E-19, 0.131E-19, 0.111E-19, 0.925E-20, 0.763E-20, 0.622E-20, & - 0.501E-20, 0.402E-20, 0.352E-20, 0.333E-20, 0.316E-20, 0.299E-20, & - 0.283E-20, 0.268E-20, 0.254E-20, 0.240E-20, 0.227E-20, 0.215E-20, & - 0.204E-20, 0.193E-20, 0.172E-20, 0.138E-20, 0.105E-20, 0.801E-21, & - 0.612E-21, 0.467E-21, 0.356E-21, 0.270E-21, 0.206E-21, 0.160E-21, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ - DATA (xqy(kl,19),kl=1,130)/1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000/ - DATA (xs(kl,20),kl=1,130)/0.000E+00, 0.000E+00, 0.000E+00, 0.898E-19, & - 0.841E-19, 0.784E-19, 0.148E-18, 0.138E-18, 0.129E-18, 0.122E-18, & - 0.114E-18, 0.107E-18, 0.998E-19, 0.932E-19, 0.868E-19, 0.807E-19, & - 0.748E-19, 0.690E-19, 0.633E-19, 0.579E-19, 0.529E-19, 0.480E-19, & - 0.433E-19, 0.390E-19, 0.349E-19, 0.313E-19, 0.278E-19, 0.247E-19, & - 0.217E-19, 0.190E-19, 0.162E-19, 0.138E-19, 0.118E-19, 0.991E-20, & - 0.829E-20, 0.690E-20, 0.566E-20, 0.452E-20, 0.361E-20, 0.288E-20, & - 0.229E-20, 0.181E-20, 0.157E-20, 0.147E-20, 0.138E-20, 0.131E-20, & - 0.125E-20, 0.118E-20, 0.112E-20, 0.106E-20, 0.100E-20, 0.947E-21, & - 0.893E-21, 0.838E-21, 0.743E-21, 0.581E-21, 0.428E-21, 0.332E-21, & - 0.262E-21, 0.192E-21, 0.141E-21, 0.910E-22, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ - DATA (xqy(kl,20),kl=1,130)/1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000/ - DATA (xs(kl,21),kl=1,130)/0.180E-16, 0.181E-16, 0.179E-16, 0.174E-16, & - 0.167E-16, 0.159E-16, 0.146E-16, 0.133E-16, 0.118E-16, 0.101E-16, & - 0.850E-17, 0.695E-17, 0.540E-17, 0.411E-17, 0.301E-17, 0.215E-17, & - 0.163E-17, 0.105E-17, 0.754E-18, 0.524E-18, 0.382E-18, 0.272E-18, & - 0.202E-18, 0.152E-18, 0.112E-18, 0.876E-19, 0.677E-19, 0.596E-19, & - 0.541E-19, 0.510E-19, 0.489E-19, 0.469E-19, 0.448E-19, 0.419E-19, & - 0.377E-19, 0.336E-19, 0.285E-19, 0.238E-19, 0.190E-19, 0.145E-19, & - 0.106E-19, 0.752E-20, 0.610E-20, 0.553E-20, 0.496E-20, 0.457E-20, & - 0.418E-20, 0.380E-20, 0.341E-20, 0.302E-20, 0.279E-20, 0.256E-20, & - 0.232E-20, 0.209E-20, 0.171E-20, 0.110E-20, 0.644E-21, 0.416E-21, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ - DATA (xqy(kl,21),kl=1,130)/1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & - 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000/ - DATA (xs(kl,22),kl=1,130)/0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.340E-20, 0.401E-20, 0.486E-20, 0.573E-20, 0.662E-20, 0.754E-20, & - 0.906E-20, 0.112E-19, 0.133E-19, 0.162E-19, 0.202E-19, 0.224E-19, & - 0.248E-19, 0.276E-19, 0.289E-19, 0.318E-19, 0.322E-19, 0.321E-19, & - 0.338E-19, 0.343E-19, 0.307E-19, 0.290E-19, 0.275E-19, 0.272E-19, & - 0.272E-19, 0.272E-19, 0.272E-19, 0.273E-19, 0.280E-19, 0.283E-19, & - 0.268E-19, 0.249E-19, 0.212E-19, 0.151E-19, 0.127E-19, 0.142E-19, & - 0.229E-19, 0.358E-20, 0.000E+00, 0.000E+00, 0.286E-21, 0.208E-20, & - 0.344E-20, 0.764E-20, 0.107E-19, 0.159E-19, 0.166E-19, 0.303E-19, & - 0.263E-19, 0.336E-19, 0.366E-19, 0.456E-19, 0.643E-19, 0.546E-19, & - 0.922E-19, 0.677E-19, 0.599E-19, 0.117E-18, 0.715E-19, 0.730E-19, & - 0.201E-18, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ - DATA (xqy(kl,22),kl=1,130)/0.400000, 0.400000, 0.400000, 0.400000, & - 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, & - 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, & - 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, & - 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, & - 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, & - 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, & - 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, & - 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000/ - DATA (xs(kl,23),kl=1,130)/0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.164E-20, & - 0.211E-20, 0.227E-20, 0.264E-20, 0.340E-20, 0.465E-20, 0.598E-20, & - 0.803E-20, 0.986E-20, 0.118E-19, 0.137E-19, 0.160E-19, 0.189E-19, & - 0.228E-19, 0.275E-19, 0.307E-19, 0.321E-19, 0.335E-19, 0.349E-19, & - 0.363E-19, 0.378E-19, 0.393E-19, 0.407E-19, 0.421E-19, 0.435E-19, & - 0.449E-19, 0.462E-19, 0.487E-19, 0.527E-19, 0.564E-19, 0.589E-19, & - 0.616E-19, 0.556E-19, 0.553E-19, 0.543E-19, 0.365E-19, 0.318E-19, & - 0.316E-19, 0.156E-19, 0.428E-20, 0.113E-20, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & - 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ - DATA (xqy(kl,23),kl=1,130)/0.019894, 0.019716, 0.019528, 0.019339, & - 0.019140, 0.018941, 0.018742, 0.018543, 0.018333, 0.018113, 0.017893, & - 0.017673, 0.017453, 0.017212, 0.016982, 0.016741, 0.016531, 0.016238, & - 0.015976, 0.015714, 0.015442, 0.015159, 0.014876, 0.014593, 0.014290, & - 0.013986, 0.013682, 0.013357, 0.013032, 0.012697, 0.012341, 0.011995, & - 0.011629, 0.011314, 0.010874, 0.010487, 0.010078, 0.009670, 0.009240, & - 0.008800, 0.008350, 0.007910, 0.007648, 0.007543, 0.007438, 0.007333, & - 0.007229, 0.007124, 0.007019, 0.006914, 0.006810, 0.006705, 0.006600, & - 0.006495, 0.006286, 0.005867, 0.005343, 0.004819, 0.004295, 0.003772, & - 0.003248, 0.002724, 0.002200, 0.001676, 0.001153, 0.000629, 0.000105, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & - 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000/ - ! END MODULE module_data_photmad -! - CONTAINS - subroutine madronich1_driver(id,ktau,dtstep,haveaer, & - gmt,julday,t_phy,moist,aerwrf,p8w,t8w,p_phy, & - chem,rho_phy,dz8w, & - xlat,xlong,z_at_w,gd_cloud,gd_cloud2, & - ph_macr,ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2, & - ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho, & - ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho, & - ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob, & - pm2_5_dry,pm2_5_water,uvrad, & - chem_opt,num_chem,num_moist, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) -! USE module_configure -! USE module_state_description -! USE module_model_constants -! USE module_data_radm2 - implicit none - INTEGER, INTENT(IN ) :: id,julday, & - chem_opt,num_chem,num_moist, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - INTEGER, INTENT(IN ) :: & - ktau - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & - INTENT(IN ) :: moist - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & - INTENT(INOUT ) :: & - pm2_5_dry,pm2_5_water,gd_cloud,gd_cloud2 - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & - INTENT(INOUT ) :: & - ph_macr,ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2,& - ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho, & - ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho, & - ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & - INTENT(IN ) :: chem - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & - INTENT(IN ) :: & - t_phy, & - p_phy, & - dz8w, & - t8w,p8w,z_at_w , & - aerwrf , & - rho_phy - REAL, DIMENSION( ims:ime , jms:jme ) , & - INTENT(IN ) :: & - xlat, & - xlong - REAL, DIMENSION( ims:ime , jms:jme ) , & - INTENT(INOUT ) :: uvrad - REAL, INTENT(IN ) :: & - dtstep,gmt - -! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - - LOGICAL, INTENT(IN) :: haveaer -! -! -! LOCAL VAR - - INTEGER :: ki,i,j,k,ixhour,n,iprt -! photolysis input -! - real tt(kts:kte+1),o33(kts:kte+1),rhoa(kts:kte+1),aerext(kts:kte+1),qll(kts:kte+1), & - phizz(kts:kte+1),phot1(nreakj-1,kts:kte+1) - real :: xtime,xhour,xmin,gmtp,r_d,uvb_dd1,uvb_du1,uvb_dir1 - real :: zenith,zenita,azimuth,dobsi - real :: bext340,bexth2o,ctr - integer :: naerspec -! print *,'gmt,julday in madronich1= ',gmt,julday - r_d=rd - xtime=ktau*dtstep/60. - ixhour=ifix(gmt+.01)+ifix(xtime/60.) - xhour=float(ixhour) - xmin=60.*gmt+(xtime-xhour*60.) - gmtp=mod(xhour,24.) - gmtp=gmtp+xmin/60. -! print *,'gmtp = ',gmtp,xhour,xmin - do 100 j=jts,jte - do 100 i=its,ite -! write(0,*)i,j - do k=kts,kte+1 - do n=1,nreakj-1 - phot1(n,k)=0. - END DO - END DO - iprt = 0 - zenith=0. - zenita=0. - azimuth=0. - call calc_zenith(xlat(i,j),-xlong(i,j),julday,gmtp,azimuth,zenith) -! if nighttime, skip radiative transfer calculation - if(zenith.eq.90.) zenith = 89.9 - if(zenith.ge.90.) go to 199 - zenita = cos(zenith*pi/180.) - if(zenith.gt.75.) zenita=1./chap(zenith) -! photmad berechnet photolysefrequenzen nach Madronich in folgender Reihenfolge - -! o2 absorp 1 schumman-runge corrected in srband -! o3 -> 1d 2 at 275 k. correct t-dep in subgrid -! o3 -> 3p 3 at 275 k. correct t-dep in subgrid -! no2 4 -! no3 -> no+o2 5 -! no3 -> no2+o 6 -! hno2 7 -! hno3 8 -! hno4 9 -! h2o2 10 -! ch2o -> rad 11 -! ch2o -> mol 12 -! ch3cho 13 -! ch3coch3 14 -! ch3coc2h5 15 -! hcocho proc a 16 -! ch3cocho 17 -! hcoch=chcho 18 estimate, no reliable measurement -! ch3o2h 19 -! ch3coo2h 20 actually use 0.28*(h2o2 value) -! ch3ono2 21 -! hcocho proc b 22 - do k=kts,kte - aerext(k+1)=aerwrf(i,k+1,j) -! -!--- if you have aerosols -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - bext340=5.E-6 - bexth2o=5.E-6 - if(haveaer.and.ktau.gt.1)then - -! dry aerosol mass -!rf check ki (or ki+1 or ki-1 ?) - aerext(k)=pm2_5_dry(i,k,j)*bext340+ & - pm2_5_water(i,k,j)*bexth2o - aerext(k)=aerext(k)*1.E3 -! if(i.eq.70.and.j.eq.70) write(06,*) 'aerext',k,aerext(k) - - endif -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - qll(k+1)=0. - tt(k+1) = t_phy(i,k,j) - rhoa(k+1) = rho_phy(i,k,j) - o33(k+1) = max(1.e-3,chem(i,k,j,p_o3)) - qll(k+1) = 1.e3*(moist(i,k,j,p_qc)+moist(i,k,j,p_qi)+ & - gd_cloud(i,k,j)+gd_cloud2(i,k,j)) & - *rho_phy(i,k,j) - if(qll(k+1).lt.1.e-5)qll(k+1) = 0. - phizz(k+1) = z_at_w(i,k+1,j)*.001-z_at_w(i,1,j)*.001 -! if((i.eq.1.and.j.eq.17))then -! write(0,*)k+1,phizz(k+1),qll(k+1),moist(i,k,j,p_qc),moist(i,k,j,p_qi),rqccuten(i,k,j),rqicuten(i,k,j),rho_phy(i,k,j) -! write(0,*)k+1,z_at_w(i,k+1,j),z_at_w(i,1,j),tt(k+1),o33(k+1),qll(k+1),rhoa(k+1) -! endif - END DO - tt(1)=t8w(i,kts,j) - o33(1)=max(1.e-3,chem(i,kts,j,p_o3)) - qll(1)=0. - phizz(1)=0. - aerext(1)=aerwrf(i,1,j) - k=0 -! write(0,*)k+1,z_at_w(i,k+1,j),z_at_w(i,1,j),tt(k+1),o33(k+1),qll(k+1),rhoa(k+1) -! -! if you have aerosols.... -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! - if(haveaer.and.ktau.gt.1)then - aerext(1)=pm2_5_dry(i,1,j)*bext340+ & - pm2_5_water(i,1,j)*bexth2o - aerext(1)=aerext(1)*1.e3 - endif -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - rhoa(1)=p8w(i,kts,j)/t8w(i,kts,j)/r_d - dobsi=350. -! if((i.eq.87.and.j.eq.66).or.(i.eq.105.and.j.eq.70))then -! print *,'before photmad, i,j = ',i,j,pm2_5_dry(i,1,j),pm2_5_water(i,1,j) -! print *,k,rhoa(1),phizz(1),qll(1),aerext(1),o33(1),tt(1),zenita -! endif -!write(0,*)'calling photolysis_mad --------',i,j - call photolysis_mad(kte,zenita,phizz,tt,rhoa,o33,aerext,qll,dobsi,phot1, & - iprt,uvb_dd1,uvb_du1,uvb_dir1) -!write(0,*)'back from photolysis_mad ---------------------------- ' -! print *,'after photmad, i,j = ',i,j - uvrad(i,j)=uvb_dd1+uvb_dir1-uvb_du1 - do k=kts,kte - do n=1,nreakj-1 - phot1(n,k)=60.*phot1(n,k) - END DO - END DO - 199 continue - do k=kts,kte -! -! - ph_o31d(i,k,j) = phot1(1,k) - ph_o33p(i,k,j) = phot1(2,k) - ph_no2(i,k,j) = phot1(3,k) - ph_no3o2(i,k,j) = phot1(4,k) - ph_no3o(i,k,j) = phot1(5,k) - ph_hno2(i,k,j) = phot1(6,k) - ph_hno3(i,k,j) = phot1(7,k) - ph_hno4(i,k,j) = phot1(8,k) - ph_h2o2(i,k,j) = phot1(9,k) - ph_ch2or(i,k,j) = phot1(10,k) - ph_ch2om(i,k,j) = phot1(11,k) - ph_ch3cho(i,k,j) = phot1(12,k) - ph_ch3coch3(i,k,j) = phot1(13,k) - ph_ch3coc2h5(i,k,j) = phot1(14,k) - ph_hcocho(i,k,j) = phot1(15,k) - ph_ch3cocho(i,k,j) = phot1(16,k) - ph_hcochest(i,k,j) = phot1(17,k) - ph_ch3o2h(i,k,j) = phot1(18,k) - ph_ch3coo2h(i,k,j) = phot1(19,k) - ph_ch3ono2(i,k,j) = phot1(20,k) - ph_hcochob(i,k,j) = phot1(21,k) - ph_macr(i,k,j) = phot1(22,k) -! if(i.eq.5.and.j.eq.5)print *,i,j,k,phot1(3,k),phot1(4,k),phot1(17,k) - END DO - 100 continue - -END SUBROUTINE madronich1_driver - - SUBROUTINE photolysis_mad(mkxcc,a,zmm5,tmm5,pmm5,o3mm5,aerext,wlmm5, & - dobsnew,phot1,iprt,uvb_dd1,uvb_du1,uvb_dir1) - ! ----- INPUT ------------------------------------------------ - ! Input from MM5 - ! ------ OUTPUT ---------------------------------------------- - ! ----------------------------------------------------------------------- - ! This program calculates J-values for selected atmospheric molecules - ! the program and subroutine structure is as follows - ! runph -main program and menu. - ! calc_zenith -zenith angle calc. - ! in addition, the chapman function ch(zenith) is used between - ! readd -reads spectra and standard profiles - ! photmat -main subroutine (calls the routines below) - ! o3scal -rescales ozone profile to user-selected new dobson - ! subgrid -regrids the altitude profiles ( - ! srband -computes effective ozone cross sections in the - ! schumamkxcc+1+nabv-runge region (if necessary) - ! trapez -interpolation subroutine - ! optics -computes optical parameters and calls delta-eddington - ! delted -delta-eddington code of wiscombe - ! nlayde(ib) -multylayer calc - ! leqt1b(a,n,ncl,nuc,ia,b,m,ib,ijob,kl) -solves - ! pentadiag.system - ! Original program written by S. Madronich, NCAR. The code was - ! last modified by him on 18 Aug. 1987. - ! The driver for the chemistry has been heavily modified by - ! W. R. Stockwell at IFU Germany. (The modifications allow - ! the simulation conditions to be directly modified - ! without recompiling the program [this does not hold for the present - ! version here any more]). The extremely large data base - ! has bee replaced with separate files to allow cross sections and - ! photolysis rates to be more easily updated. However, the order - ! of the input files should be modified with extreme caution. - ! The present version is made for the use of computed - ! fields of T, P, O3, wl, and aerosol (if available) - ! Modifications were made by Renate Forkel in Aug./Sept 1995 - ! The following modifications were made: - ! - No climatological input any more - ! - Arbitrary vertical grid - ! - Several seperate cloud layers are possible. Number of additional - ! layers within the clouds depends on the optical depth - ! - Vertically inhogeneous clouds are possible now - ! - No variable values in commons any more - ! ----------------------------------------------------------------------- - ! xnkg: Molecules per kg air - ! .. Scalar Arguments .. - REAL :: a, dobsnew,uvb_dd1,uvb_du1,uvb_dir1 - INTEGER :: iprt, mkxcc - ! .. Local Scalars .. - REAL :: aeru, airu, bextn, df, dj, dz, ff, gaer, gcld, gray, haer, & - hair, ho3, o3u, omaer, omcld, omray, reff, tu, wmicron, xnkg, xx, & - znorm, zu - INTEGER :: i, j, k, kk, kl, lev, nlayer, nlevel, nn, nr, nsurf - ! .. Array Arguments .. - REAL :: aerext(mkxcc+1), o3mm5(mkxcc+1), phot1(nreakj-1,mkxcc+1), & - pmm5(mkxcc+1), tmm5(mkxcc+1), wlmm5(mkxcc+1), zmm5(mkxcc+1) - ! .. Local Arrays .. - REAL :: aaer(130), aer(mkxcc+1+nabv), air(mkxcc+1+nabv), ao2(nj,130), & - ao3(nj,130), arayl(130), cloud(mkxcc+1+nabv), cvo2(nj), & - d(nreakj,nj), endir(nj,130), endn(nj,130), enup(nj,130), & - hilf1(mkxcc+1), hilfd(nj), o3(mkxcc+1+nabv), qy(nj,130,nreakj), & - s(nj,130,nreakj), t(mkxcc+1+nabv), vaer(nj), vair(nj), vcld(nj), & - vo3(nj), vt(nj), z(nj), zkm(mkxcc+1), zmid(nj), zz(mkxcc+1+nabv) - ! .. Data Statements .. - DATA xnkg/2.143E25/ - ! EXTERNAL o3scal, optics, srband, subgrid, trapez - ! wave length range !!! If photolysis is also desired for levels above - ! 2 - ! kl0 should be set equal to 1 again!!!!!!!!!!!!!! - i = 1 - j = 1 - ! albedoph ************************ specify ground albedoph - ! use best estimate albedoph of demerjian et al., - ! adv.env.sci.tech.,v.10,p.369, (1980) - DO kl = kl0, kl1 - - IF (wl(kl)<400.) albedoph(kl) = 0.05 - - IF ((wl(kl)>=400.) .AND. (wl(kl)<450.)) albedoph(kl) = 0.06 - - IF ((wl(kl)>=450.) .AND. (wl(kl)<500.)) albedoph(kl) = 0.08 - - IF ((wl(kl)>=500.) .AND. (wl(kl)<550.)) albedoph(kl) = 0.10 - - IF ((wl(kl)>=550.) .AND. (wl(kl)<600.)) albedoph(kl) = 0.11 - - IF ((wl(kl)>=600.) .AND. (wl(kl)<640.)) albedoph(kl) = 0.12 - - IF ((wl(kl)>=640.) .AND. (wl(kl)<660.)) albedoph(kl) = 0.135 - - IF (wl(kl)>=660.) albedoph(kl) = 0.15 - END DO - - - - nn = mkxcc + 1 + nabv - - ! omray = single scattering albedoph, rayleigh. use 1.00 - ! gray = asymetry factor for rayleigh scattering. use 0.0 - ! arayl(kl) = rayleigh scattering cross section, from - ! frohlich and shaw, appl.opt. v.11, p.1773 (1980). - ! overrides tabulation of jdata.base - hair = 8.05 - omray = 1.0 - gray = 0.0 - - DO 10 kl = kl0, kl1 - wmicron = wl(kl)/1.E3 - xx = 3.916 + 0.074*wmicron + 0.050/wmicron - arayl(kl) = 3.90E-28/(wmicron)**xx -10 CONTINUE - - ! aerosol*********************** specify aerosols - ! aaer(kl) = aerosol total vertical optical depth variation with - ! wavelength. estimated from elterman (1968) - ! aer(i) = attenuation (per km) profile from elterman (1968). - ! given in data statement in beginning of code, for 340 nm (kl=6 - ! same vertical shape at all wavelengths. - ! normalized later (in subroutine subgrid) to total vertical dep - ! this wavelength. - ! omaer = aerosol single scattering albedoph. use 0.99 for now. - ! gaer = aerosol asymetry factor. use 0.61 (hansen and travis 197 - ! (these are assuming particles of about 0.1 micron radius - ! index of refraction of about 1.65 + 0.002i. - ! haer = the aerosol scale height at top of atmosphere - ! use equal to air (8.05 km) - - DO 20 kl = kl0, kl1 - aaer(kl) = 0.379*(340./wl(kl)) -20 CONTINUE - omaer = 0.990 - gaer = 0.610 - haer = 8.05 - - - omcld = 1.000 - gcld = 0.860 - - ho3 = 4.50 - - nsurf = 1 - - ! Vertikales Gitter ohne Wolken: Niveaus zz(i), i=1,mkxcc+1+nabv - - - ! Transformation of MM5-values - ! bextn: cloud extinction coeff per g/m**3 [1/km] - DO k = 1, mkxcc + 1 - zz(k) = zmm5(k) -!write(0,*)' here7a zz = zmm5 ',k,zmm5(k) - t(k) = tmm5(k) - air(k) = xnkg*pmm5(k)*1.E-6 - - ! falls o3mm5 in ppm - - o3(k) = o3mm5(k)*1.E-6*air(k) - aer(k) = aerext(k) - - ! bextn: cloud extinction coeff per g/m**3 [1/km] - ! **** warning: parameterization for bextn only good - ! for continental clouds - - IF (wlmm5(k)>0.) THEN - - ! vereinfachte Version, falls kein - ! Sulfat uebergeben wird. - - reff = 9.6*wlmm5(k)**0.333 - bextn = (0.0275+1.3/reff)*1000. - cloud(k) = wlmm5(k)*bextn - ELSE - cloud(k) = 0. - END IF - ! if(iprt.eq.1)write(6,'(i3,e12.4)')k,cloud(k) - END DO - - znorm = (50.-zz(mkxcc+1))/(50.-20.) - - DO k = 1, nabv - zz(mkxcc+1+k) = 50. - znorm*(50.-zabv(k)) -!write(0,*)' here8a ',k,' zz(',mkxcc+1+k,') ',zz(mkxcc+1+k),znorm,zabv(k) - END DO - - zu = zz(mkxcc+1) - tu = t(mkxcc+1) - o3u = o3(mkxcc+1) - airu = air(mkxcc+1) - aeru = aer(mkxcc+1) - kk = 1 - - ! Zufuegen von Werten oberhalb von MM5 - - ! Die 'abv'-Werte sind bereits in den richtigen Einheiten - DO k = mkxcc + 1 + 1, mkxcc + 1 + nabv -! write(0,'(2i3,5e12.3)') k,kk,zz(k),zabv(kk) -30 IF (zz(k)<=zabv(kk)) THEN - dz = zz(k) - zu - ff = dz/(zabv(kk)-zu) - t(k) = tu + ff*(tabv(kk)-tu) - o3(k) = o3u + ff*(o3abv(kk)-o3u) - air(k) = airu + ff*(pabv(kk)-airu) - aer(k) = aeru + ff*(caabv(kk)-aeru) - cloud(k) = 0. - ! if(iprt.eq.1)then -! write(0,'(2i3,5e12.3)') k,kk,zz(k),zabv(kk),ff,tabv(kk),air(k) - ! endif - ELSE -40 zu = zabv(kk) - tu = tabv(kk) - o3u = o3abv(kk) - airu = pabv(kk) - aeru = caabv(kk) - kk = kk + 1 - - IF (zabv(kk)20.) THEN - n20 = lay - GO TO 30 - END IF - -20 CONTINUE -30 CONTINUE - - e10 = alog(10.) - - DO 60 kl = kl0, kl1 - - IF (wl(kl)>205.) RETURN - - DO 40 lay = n20, nlayer - x1 = alog(4.696E-23*cvo2(lay)/0.2095)/e10 - - IF (wl(kl)>=200.) x1 = vt(lay) - x2 = x1*x1 - x3 = x2*x1 - x4 = x3*x1 - x5 = x4*x1 - x6 = x5*x1 - x7 = x6*x1 - x8 = x7*x1 - ao20lg = sra(kl,1) + sra(kl,2)*x1 + sra(kl,3)*x2 + sra(kl,4)*x3 + & - sra(kl,5)*x4 + sra(kl,6)*x5 + sra(kl,7)*x6 + sra(kl,8)*x7 + & - sra(kl,9)*x8 - ao20 = 10.**ao20lg - - y1 = alog(cvo2(lay))/e10 - y2 = y1*y1 - y3 = y2*y1 - y4 = y3*y1 - clog = srb(kl,1) + srb(kl,2)*y1 + srb(kl,3)*y2 + srb(kl,4)*y3 + & - srb(kl,5)*y4 - c = 10.**clog - zendep = a**c - - ao2(lay,kl) = ao20*zendep -40 CONTINUE - ! assign values below 20 km - DO 50 lay = 1, n20 - 1 - ao2(lay,kl) = ao2(n20,kl) -50 CONTINUE -60 CONTINUE - - RETURN - - END SUBROUTINE srband - - ! ###################################################################### - - SUBROUTINE o3scal(dobsnew,ho3,zz,o3,nn) - ! adjustment of o3 profiles to a user-selected dobson value. - ! select value of dobnew in main program - ! if don't want to use, don't call this subroutine - ! .. Scalar Arguments .. - REAL :: dobsnew, ho3 - INTEGER :: nn - ! .. Local Scalars .. - REAL :: dobsref - INTEGER :: i - ! .. Intrinsic Functions .. - INTRINSIC max, min - ! .. Array Arguments .. - REAL :: o3(nn), zz(nn) - ! write(6,*) o3 - dobsref = o3(nn)*1.E5*ho3 - ! write(06,'('nn: dobsref,dobsnew',2e12.4)') - ! & dobsref/2.687e16,dobsnew - DO 10 i = 1, nn -10 dobsref = dobsref + o3(i)*0.5*(zz(min(i+1,nn))-zz(max(i-1,1)))*1.E5 - dobsref = dobsref/2.687E16 - ! write(06,'('dobsref,dobsnew',2e12.4)') dobsref,dobsnew - DO 20 i = 1, nn - o3(i) = o3(i)*dobsnew/dobsref -20 CONTINUE - ! write(06,*) o3 - - RETURN - - END SUBROUTINE o3scal - - ! ####################################################################### - - SUBROUTINE leqt1b(a,n,nlc,nuc,ia,b,m,ib,ijob,xl) - ! -leqt1b--------s-------library - ! 3--------------------------------------- - ! function - matrix decomposition, linear equation - ! solution - space economizer solution - - ! band storage mode - ! usage - call leqt1b (a,n,nlc,nuc,ia,b,m,ib,ijob,xl, - ! ier) - ! parameters a - input/output matrix of dimension n by - ! (nuc+nlc+1). see parameter ijob. - ! n - order of matrix a and the number of rows in - ! b. (input) - ! nlc - number of lower codiagonals in matrix a. - ! (input) - ! nuc - number of upper codiagonals in matrix a. - ! (input) - ! ia - row dimension of a as specified in the - ! calling program. (input) - ! b - input/output matrix of dimension n by m. - ! on input, b contains the m right-hand sides - ! of the equation ax = b. on output, the - ! solution matrix x replaces b. if ijob = 1, - ! b is not used. - ! m - number of right hand sides (columns in b). - ! (input) - ! ib - row dimension of b as specified in the - ! calling program. (input) - ! ijob - input option parameter. ijob = i implies when - ! i = 0, factor the matrix a and solve the - ! equation ax = b. on input, a contains the - ! coefficient matrix of the equation ax = b, - ! where a is assumed to be an n by n band - ! matrix. a is stored in band storage mode - ! and therefore has dimension n by - ! (nlc+nuc+1). on output, a is replaced - ! by the u matrix of the l-u decomposition - ! of a rowwise permutation of matrix a. u is - ! stored in band storage mode. - ! i = 1, factor the matrix a. a contains the - ! same input/output information as if - ! ijob = 0. - ! i = 2, solve the equation ax = b. this - ! option implies that leqt1b has already - ! been called using ijob = 0 or 1 so that - ! the matrix a has already been factored. - ! in this case, output matrices a and xl - ! must have been saved for reuse in the - ! call to leqt1b. - ! xl - work area of dimension n*(nlc+1). the first - ! nlc*n locations of xl contain components of - ! the l matrix of the l-u decomposition of a - ! rowwise permutation of a. the last n - ! locations contain the pivot indices. - ! ----------------------------------------------------------------------- - ! latest revision - november 27,1973 - ! dimension a(ia,1),xl(n,1),b(ib,1) ! Urspr. Zustand, fun - ! .. Scalar Arguments .. - INTEGER :: ia, ib, ijob, m, n, nlc, nuc - ! .. Array Arguments .. - REAL :: a(ia,5), b(ib,5), xl(n,5) - ! .. Local Scalars .. - REAL :: one, p, q, rn, zero - INTEGER :: i, ik, j, jbeg, jend, k, k1, kk, l, nc, nlc1, nn - ! .. Intrinsic Functions .. - INTRINSIC abs - ! .. Data Statements .. - DATA zero/0./, one/1.0/ - - p = 0 - jbeg = nlc + 1 - nlc1 = jbeg - - IF (ijob==2) GO TO 170 - rn = n - ! restructure the matrix - ! find reciprocal of the largest - ! absolute value in row i - i = 1 - nc = jbeg + nuc - nn = nc - jend = nc - - IF (n==1 .OR. nlc==0) GO TO 50 -10 k = 1 - p = zero - - DO 20 j = jbeg, jend - a(i,k) = a(i,j) - q = abs(a(i,k)) - - IF (q>p) p = q - k = k + 1 -20 CONTINUE - - IF (p==zero) GO TO 280 - xl(i,nlc1) = one/p - - IF (k>nc) GO TO 40 - - DO 30 j = k, nc - a(i,j) = zero -30 CONTINUE -40 i = i + 1 - jbeg = jbeg - 1 - - IF (jend-jbeg==n) jend = jend - 1 - - IF (i<=nlc) GO TO 10 - jbeg = i - nn = jend -50 jend = n - nuc - - DO 90 i = jbeg, n - p = zero - - DO 60 j = 1, nn - q = abs(a(i,j)) - - IF (q>p) p = q -60 CONTINUE - - IF (p==zero) GO TO 280 - xl(i,nlc1) = one/p - - IF (i==jend) GO TO 80 - - IF (il) GO TO 110 - - DO 100 j = k1, l - q = abs(a(j,1))*xl(j,nlc1) - - IF (q<=p) GO TO 100 - p = q - i = j -100 CONTINUE -110 xl(i,nlc1) = xl(k,nlc1) - xl(k,nlc1) = i - ! singularity found - IF ((rn+p)==rn) GO TO 280 - ! interchange rows i and k - IF (k==i) GO TO 130 - - DO 120 j = 1, nc - p = a(k,j) - a(k,j) = a(i,j) - a(i,j) = p -120 CONTINUE - -130 IF (k1>l) GO TO 160 - - DO 150 i = k1, l - p = a(i,1)/a(k,1) - ik = i - k - xl(k1,ik) = p - - DO 140 j = 2, nc - a(i,j-1) = a(i,j) - p*a(k,j) -140 CONTINUE - a(i,nc) = zero -150 CONTINUE -160 CONTINUE - - IF (ijob==1) GO TO 270 - ! forward substitution -170 l = nlc - - DO 220 k = 1, n - i = xl(k,nlc1) - - IF (i==k) GO TO 190 - - DO 180 j = 1, m - p = b(k,j) - b(k,j) = b(i,j) - b(i,j) = p -180 CONTINUE - -190 IF (ll) GO TO 220 - - DO 210 i = k1, l - ik = i - k - p = xl(k1,ik) - - DO 200 j = 1, m - b(i,j) = b(i,j) - p*b(k,j) -200 CONTINUE -210 CONTINUE -220 CONTINUE - ! backward substitution - jbeg = nuc + nlc - - DO 260 j = 1, m - l = 1 - k1 = n + 1 - - DO 250 i = 1, n - k = k1 - i - p = b(k,j) - - IF (l==1) GO TO 240 - - DO 230 kk = 2, l - ik = kk + k - p = p - a(k,kk)*b(ik-1,j) -230 CONTINUE -240 b(k,j) = p/a(k,1) - - IF (l<=jbeg) l = l + 1 -250 CONTINUE -260 CONTINUE - -270 RETURN - -280 CONTINUE - CALL wrf_error_fatal ( ' leqt1b error--matrix algorithmically singular') - END SUBROUTINE leqt1b - - ! ####################################################################### - - FUNCTION chap(zeta) - ! chapman function is used when the solar zenith angle exceeds - ! 75 deg. - ! interpolates between values given in, e.g., mccartney (1976). - ! .. Scalar Arguments .. - REAL :: zeta - ! .. Local Scalars .. - REAL :: rm - INTEGER :: i - ! .. Local Arrays .. - REAL :: y(22) - ! .. Function Return Value .. - REAL :: chap - ! .. Data Statements .. - DATA (y(i),i=1,22)/3.800, 4.055, 4.348, 4.687, 5.083, 5.551, 6.113, & - 6.799, 7.650, 8.732, 10.144, 12.051, 14.730, 18.686, 24.905, 35.466, & - 55.211, 96.753, 197., 485., 1476., 9999./ - - DO 10 i = 75, 96 - rm = i - - IF (zetanj) THEN - CALL wrf_error_fatal ( 'LEV > NJ, NJ GROESSER WAEHLEN') - END IF - - z(lev) = z(lev-1) + dzu - zt(lev) = t(i-1) + (z(lev)-zz(i-1))/(zz(i)-zz(i-1))*(t(i)-t(i-1) & - ) - - if(abs(air(i)-air(i-1)).lt.air(i-1)/1.e5)then - zair(lev) = air(i-1) - else - hlocal = 1./alog(air(i-1)/air(i)) - x0 = (z(lev)-zz(i-1))/(zz(i)+zz(i-1)) - zair(lev) = air(i-1)*exp(-x0/hlocal) - endif - vcld(lev) = cloud(i) - ! write(06,'('u:z,t,air ',i3,3e12.4)') - ! lev,z(lev),zt(lev),zair(lev) - END DO - -10 CONTINUE - - IF (i==nn) GO TO 20 - ! if(lev.ne.1) vcld(lev)=cloud(i) - dzt = (zz(i+1)-zz(i))*.5 - ! number of layers depents on optical depth - idt = max(ifix(cloud(i)*dzt*fnum),1) - dzo = dzt/float(idt) - - DO il = 1, idt - lev = lev + 1 - - IF (lev>nj) THEN - CALL wrf_error_fatal ( 'LEV > NJ, NJ GROESSER WAEHLEN') - END IF - - z(lev) = z(lev-1) + dzo - zt(lev) = t(i) + (z(lev)-zz(i))/(zz(i+1)-zz(i))*(t(i+1)-t(i)) - if(abs(air(i)-air(i+1)).lt.air(i)/1.e5)then - zair(lev) = air(i) - else - hlocal = 1./alog(air(i)/air(i+1)) - x0 = (z(lev)-zz(i))/(zz(i+1)+zz(i)) - zair(lev) = air(i)*exp(-x0/hlocal) - endif - vcld(lev-1) = cloud(i) - ! write(06,'('o:z,t,air ',i3,3e12.4)') - ! lev,z(lev),zt(lev),zair(lev) - END DO - -20 CONTINUE - END IF - ! write(06,'('o:z,t,air ',i3,3e12.4)') lev,z(lev),zt(lev),zair(lev) -30 CONTINUE - - ! number of levels including additional cloud levels - - nlevel = lev - - IF (nlevel>nj) print *, ' NLEVEL > NJ, NJ GROESSER WAEHLEN ', & - nlevel - - ! write(06,'(' nlevel',i3)') nlevel - - - ! assign default yields - DO 40 nr = 1, nreakj - - DO 40 kl = kl0, kl1 - - DO 40 lev = 1, nlevel -40 qy(lev,kl,nr) = xqy(kl,nr) - ! assign default absorption cross sections - DO 50 kl = kl0, kl1 - - DO 50 lev = 1, nlevel - - DO 50 nr = 1, nreakj -50 s(lev,kl,nr) = xs(kl,nr) - ! -------------------------------------------------------------------- - ! re-calculate altitude dependent quantum yields. this currently - ! applies to - ! 2=o3->o(1d) - ! 12=ch2o->h2+co - ! 13=ch3cho->ch3+cho - ! 14=ch3coch3 - ! 15=ch3coch2ch3 - ! 16=hcocho -> 0.13 hcho + 1.87 co process a - ! 17=ch3cocho - ! 22=hcocho -> 0.45 hcho + 1.55 co + 0.80 ho2 process b - - ! o3 and ketones yield is calculated from fit equations, - ! while for ch3cho and the dicarbonyls yields are calculated - ! from the ntp yield by linear adjustment to 1/yield. the ch2o yield - ! recalculated only for wavelengths longer than 329 nm. the yields for - ! 1=o3->o(3p) are calculated as (1.- singlet d yield). - - DO 60 lev = 1, nlevel - ! o3 ozone: - tau = zt(lev) - 230. - a = 0.9*(0.369+2.85E-4*tau+1.28E-5*tau*tau+2.57E-8*tau*tau*tau) - b = -0.575 + 5.59E-3*tau - 1.439E-5*tau*tau - 3.27E-8*tau*tau*tau - c = 0.9*(0.518+9.87E-4*tau-3.94E-5*tau*tau+3.91E-7*tau*tau*tau) - xl0 = 308.20 + 4.4871E-2*tau + 6.9380E-5*tau*tau - & - 2.5452E-6*tau*tau*tau - - DO 60 kl = kl0, kl1 - xl = wl(kl) - qy(lev,kl,2) = a*atan(b*(xl-xl0)) + c - - IF (qy(lev,kl,2)<0.) qy(lev,kl,2) = 0.0 - - IF (qy(lev,kl,2)>0.9) qy(lev,kl,2) = 0.9 - qy(lev,kl,3) = 1.0 - qy(lev,kl,2) - ! ch2o formaldehyde: - IF ((xl>=330.) .AND. qy(lev,kl,12)>0.) THEN - phi1 = qy(lev,kl,11) - phi2 = qy(lev,kl,12) - phi20 = 1. - phi1 - ak300 = ((1./phi2)-(1./phi20))/2.54E+19 - akt = ak300*(1.+61.69*(1.-zt(lev)/300.)*(xl/329.-1.)) - qy(lev,kl,12) = 1./((1./phi20)+zair(lev)*akt) - END IF - - IF (qy(lev,kl,12)>1.) qy(lev,kl,12) = 1.0 - - IF (qy(lev,kl,12)<0.) qy(lev,kl,12) = 0.0 - ! ch3cho acetaldehyde: - IF (xqy(kl,13)/=0.) THEN - qy(lev,kl,13) = 1./(1.+(1./xqy(kl,13)-1.)*zair(lev)/2.465E19) - END IF - ! ch3coch3 acetone: - qy(lev,kl,14) = 0.0766 + 0.09415*exp(-zair(lev)/3.222E18) - ! ch3coch2ch3 methyl ethyl ketone: - qy(lev,kl,15) = qy(lev,kl,14) - ! hcocho glyoxal process a: - IF (xqy(kl,16)/=0.) THEN - qy(lev,kl,16) = 1./(1.+(1./xqy(kl,16)-1.)*zair(lev)/2.465E19) - END IF - ! ch3cocho methylglyoxal: - IF (xqy(kl,17)/=0.) THEN - qy(lev,kl,17) = 1./(1.+(1./xqy(kl,17)-1.)*zair(lev)/2.465E19) - END IF - ! hcocho glyoxal process b: - IF (xqy(kl,22)/=0.) THEN - qy(lev,kl,22) = 1./(1.+(1./xqy(kl,22)-1.)*zair(lev)/2.465E19) - END IF - -60 CONTINUE - ! _______________________________________________________________________ - ! correct absorption cross sections for t and p dep. for now, do - ! 2=ozone - DO 90 kl = kl0, kl1 - - DO 80 lev = 1, nlevel - - IF (kl<33 .OR. kl>61) GO TO 70 - tdiffx = zt(lev) - 230. - s(lev,kl,2) = (so3tx(kl,1)+so3tx(kl,2)*tdiffx+so3tx(kl,3)*tdiffx* & - tdiffx)*1.0E-18 - s(lev,kl,3) = s(lev,kl,2) -70 CONTINUE -80 CONTINUE -90 CONTINUE - - ! ----------------------------------------------* layers - nlayer = nlevel - 1 - ! write(06,'(' Layers ',i3)') nlayer - lay = 0 - - DO 100 i = 1, nlayer - lay = lay + 1 - dz = z(i+1) - z(i) - zmid(lay) = z(i) + 0.5*dz - vt(lay) = (zt(lay+1)+zt(lay))/2. - vair(lay) = dz*1.E5*(zair(i+1)+zair(i))/2. -100 CONTINUE - - ! vo3(lay) = dz*1.e5*(o3(i+1) + o3(i))/2. ! umr. dz in cm - ! vcld(lay) = 0. *dz - ! vaer(lay) = (aer(i+1)-aer(i))/alog(aer(i+1)/aer(i)) *dz ! bei - - CALL trapez(zz,o3,1,nn,zmid,vo3,1,nlayer,nn,nn,nj,nj) - - - CALL trapez(zz,aer,1,nn,zmid,vaer,1,nlayer,nn,nn,nj,nj) - - DO 110 i = 1, nlayer - lay = i - dz = z(i+1) - z(i) - ! write(06,'('layer ',i3,6e12.4)') lay,zmid(lay),vt(lay), - ! & vair(lay)/dz,vo3(lay),vaer(lay),vcld(lay) - dz = z(i+1) - z(i) - - ! umr. dz in cm - - vo3(i) = dz*1.E5*vo3(i) - vcld(i) = vcld(i)*dz -110 vaer(i) = vaer(i)*dz - - - ! normalize aerosol optical depth to unity sum - sum = 0. - - DO 120 lay = 1, nlayer - sum = sum + vaer(lay) -120 CONTINUE - - DO 130 lay = 1, nlayer - vaer(lay) = vaer(lay)/sum -130 CONTINUE - - ! calculated vertical column of o2 above the midpoint of each layer: - ! want to use this for computing the average schumann-runge cross - ! secti - ! in each layer. - ! so use half of current layer and half of previous higher layer - - - cvo2(nlayer) = 0.2095*vair(nlayer)/2. - - DO 140 ii = 2, nlayer - lay = nlayer - ii + 1 - cvo2(lay) = cvo2(lay+1) + 0.2095*(vair(lay)+vair(lay+1))/2. -140 CONTINUE - - ! correct attenuation coefficients for pressure and/or temperature - ! dep. - ! for now do only ozone absorption. - DO 160 kl = kl0, kl1 - - DO 150 lay = 1, nlayer - tdiffx = vt(lay) - 230. - ao3(lay,kl) = xs(kl,2) - - IF (kl>=33 .AND. kl<=61) ao3(lay,kl) = (so3tx(kl,1)+so3tx(kl,2)* & - tdiffx+so3tx(kl,3)*tdiffx*tdiffx)*1.0E-18 - -150 CONTINUE -160 CONTINUE - - ! write(06,'(' z ')') - ! write(06,'(5e12.4 )') z - ! write(06,'(' zmid ')') - ! write(06,'(5e12.4 )') zmid - ! write(06,'(' zt ')') - ! write(06,'(5e12.4 )') zt - ! write(06,'(' vt ')') - ! write(06,'(5e12.4 )') vt - ! write(06,'(' vo3 ')') - ! write(06,'(5e12.4 )') vo3 - ! write(06,'(' vair ')') - ! write(06,'(5e12.4 )') vair - ! write(06,'(' vaer ')') - ! write(06,'(5e12.4 )') vaer - - - RETURN - - END SUBROUTINE subgrid - - SUBROUTINE optics(iprt,a,vair,arayl,gray,omray,ao2,vo3,ao3,vcld,gcld, & - omcld,vaer,aaer,gaer,omaer,nlayer,nlevel,nsurf,endir,endn,enup) - ! sm this subroutine prepares the data needed for the flux - ! calculation, - ! t - ! sm calls the scattering subroutine delted. it returns values of - ! the - ! sm flux flux(lev,kl) for altitude lev-1, wavelength kl. - ! sm it calculates the optical depths (vertical) - ! sm for each layer, from the vertical profiles of o2, o3, - ! sm air, cloud, and aerosol, and from the associated 'cross - ! sections - ! implicit real*4 (a-h,o-z) - ! .. Scalar Arguments .. - REAL :: a, gaer, gcld, gray, omaer, omcld, omray - INTEGER :: iprt, nlayer, nlevel, nsurf - ! .. Local Scalars .. - REAL :: dtabs, dtaer, dtair, dtcld, dto2, dto3, dtscat, fdinc, fuinc, & - solflx, sumtau - INTEGER :: ii, lay, lev, nlev, nz, nzm1 - LOGICAL :: mudept - ! .. Intrinsic Functions .. - ! EXTERNAL delted - INTRINSIC amin1 - ! .. Parameters .. - INTEGER, PARAMETER :: nsol = 1 - ! .. Array Arguments .. - REAL :: aaer(130), ao2(nj,130), ao3(nj,130), arayl(130), & - endir(nj,130), endn(nj,130), enup(nj,130), vaer(nj), vair(nj), & - vcld(nj), vo3(nj) - ! .. Local Arrays .. - REAL :: alb(nsol), dir(nj,nsol), dtau(nj), flxd(nj,nsol), & - flxu(nj,nsol), g(nj), musun(nsol), om(nj) - ! if(iprt.eq.1)then - ! write(06,*) a,kl0,kl1,gray,omray,gcld,omcld,gaer,omaer, - ! &nlayer,nlevel,nsurf - ! do kl=1,nlevel - ! write(06,'(5e12.4)') vair(kl),vo3(kl),vcld(kl),vaer(kl) - ! write(06,*) ao2 - ! enddo - ! endif - ! stop - ! loop over wavelengths - DO 30 kl = kl0, kl1 - - ! calculate optical depths for all layers (including cloud - ! sublayers) - - sumtau = 0. - - DO 10 lay = nsurf, nlayer - ii = nlayer + 1 - lay - dtair = vair(lay)*arayl(kl) - dto2 = 0.2095*vair(lay)*ao2(lay,kl) - dto3 = vo3(lay)*ao3(lay,kl) - dtcld = vcld(lay) - dtaer = vaer(lay)*aaer(kl) - - dtscat = dtair + dtcld + dtaer - dtabs = dto2 + dto3 - - dtau(ii) = dtabs + dtscat - om(ii) = (omray*dtair+omcld*dtcld+omaer*dtaer)/dtau(ii) - g(ii) = (gray*dtair+gcld*dtcld+gaer*dtaer)/dtscat - sumtau = sumtau + dtau(ii) - ! if(kl.eq.103.and.iprt.eq.1) ! 55um - ! & write(06,'(' Ope',i4,3e12.4)') - ! 2 ii,arayl(kl),dtcld,dtau(ii) -10 CONTINUE - - ! if(kl.eq.103.and.iprt.eq.1) ! 55um - ! &write(06,'(' Opt. Dicke',i4,2e12.4)') kl,sumtau - - ! initialize fluxes and other delted parameters - solflx = 1. - fdinc = 0. - fuinc = 0. - alb(1) = albedoph(kl) - musun(1) = amin1(a,0.999) - mudept = .FALSE. - nz = nlevel - nsurf + 1 - nzm1 = nz - 1 - nlev = nj - ! if(iprt.eq.1)print *,'nz = ',nz - ! --------------------------------------------------------------------- - CALL delted(dtau,om,g,musun,alb,solflx,fdinc,fuinc,mudept,nz,dir, & - flxu,flxd) - ! if(iprt.eq.1)print *,'nz = ',nz - ! --------------------------------------------------------------------- - ! return to upright grid - DO 20 ii = 1, nlevel - nsurf + 1 - lev = nlevel + 1 - ii - endir(lev,kl) = dir(ii,nsol) - endn(lev,kl) = flxd(ii,nsol) - enup(lev,kl) = flxu(ii,nsol) -20 CONTINUE - -30 CONTINUE - - RETURN - - END SUBROUTINE optics - - ! ####################################################################### - - SUBROUTINE nlayde(ib,musun,alb,fdinc,fuinc,mudept,dir,flxu,flxd,tau,lm, & - pp,ex,tx,ty,tz,isav,flxsun,nl2) - ! multi-layer delta-eddington - ! ib = number of levels - ! the top and bottom boundary conditions plus the flux continuity - ! conditions at each interior level form a penta-diagonal system - ! of 2*ib-2 equations for the unknown constants (2 for each layer). - ! the columns of the -ss- array contain the diagonals of the coeffi - ! cient matrix, the lowermost diagonal in column 1, etc. (this is t - ! so-called band storage mode required by imsl routine leqt2b). - ! ueberflussig, falls man nur eine Sonnenhoehe vorsieht. - ! .. Scalar Arguments .. - REAL :: fdinc, fuinc - INTEGER :: ib, nl2 - LOGICAL :: mudept - ! .. Local Scalars .. - REAL :: albdo, rmu0, t1 - INTEGER :: i, ibm1, ic, ijob, ip1, ir, j, ktr, last, lastm2, np - ! .. Intrinsic Functions .. - ! EXTERNAL leqt1b - INTRINSIC exp - ! .. Parameters .. - INTEGER, PARAMETER :: nsol = 1 - ! .. Array Arguments .. - REAL :: alb(1), dir(nj,1), ex(nj), flxd(nj,1), flxsun(1), flxu(nj,1), & - isav(nj), lm(nj), musun(1), pp(nj), tau(nj), tx(nj), ty(nj), tz(nj) - ! .. Local Arrays .. - REAL :: alph(nj), beta(nj), cc(mj,5), exsun(nj), ss(mj,5), work(mj,3), & - x(mj) - - ibm1 = ib - 1 - last = 2*ib - 2 - ss(1,5) = 0. - ss(1,1) = ss(1,5) - ss(1,2) = ss(1,5) - ss(1,3) = (1.-pp(1))/ex(1) - ss(1,4) = (1.+pp(1))*ex(1) - lastm2 = last - 2 - - DO 10 j = 2, lastm2, 2 - i = j/2 - ip1 = i + 1 - ss(j,1) = 0. - ss(j,2) = 1.0 - ss(j,3) = 1.0 - ss(j,4) = -1.0/ex(ip1) - ss(j,5) = -ex(ip1) - ss(j+1,1) = -pp(i) - ss(j+1,2) = pp(i) - ss(j+1,3) = pp(ip1)/ex(ip1) - ss(j+1,4) = -pp(ip1)*ex(ip1) - ss(j+1,5) = 0. -10 CONTINUE - ss(last,5) = 0. - ss(last,1) = ss(last,5) - ss(last,4) = ss(last,5) - - IF (mudept) GO TO 30 - ss(last,2) = 1. + pp(ibm1) - alb(1)*(1.-pp(ibm1)) - ss(last,3) = 1. - pp(ibm1) - alb(1)*(1.+pp(ibm1)) - - ! calculate the l-u decomposition of penta-diagonal matrix -ss- - - ! leqt2b call for testing purposes - ! call leqt2b(ss,last,2,2,nl2,x,1,nl2, 1 ,work,nl2,work(1,8)) - - ! leqt1b destroys the input coeff matrix, so since we must - ! preserve -ss-, we must let it destroy -cc- instead. - DO 20 ic = 1, 5 - - DO 20 ir = 1, last -20 cc(ir,ic) = ss(ir,ic) - ! --------------------------------------------------------------------- - CALL leqt1b(cc,last,2,2,nl2,x,1,nl2,1,work) - ! --------------------------------------------------------------------- - - ! for each sun angle, calculate the r.h.s. of the banded system, - ! solve, and use the solution to construct the fluxes at each level - -30 DO 90 np = 1, nsol - rmu0 = 1./musun(np) - t1 = rmu0**2 - lm(1)**2 - - IF (t1==0.) THEN - t1 = 1.E-7 - PRINT *, 'ACHTUNG t1=0 fuer lm(1)' - END IF - - alph(1) = tx(1)/t1 - beta(1) = ty(1)*(musun(np)*tz(1)+rmu0)/t1 - x(1) = alph(1) + beta(1) + fdinc - - DO 40 j = 2, lastm2, 2 - i = j/2 - ip1 = i + 1 - t1 = rmu0**2 - lm(ip1)**2 - - IF (t1==0.) THEN - t1 = 1.E-7 - PRINT *, 'ACHTUNG t1=0 fuer lm(', ip1, ')' - END IF - - alph(ip1) = tx(ip1)/t1 - beta(ip1) = ty(ip1)*(musun(np)*tz(ip1)+rmu0)/t1 - exsun(ip1) = exp(-rmu0*tau(ip1)) - x(j) = (alph(i)-alph(ip1))*exsun(ip1) - x(j+1) = (beta(i)-beta(ip1))*exsun(ip1) -40 CONTINUE - exsun(ib) = exp(-rmu0*tau(ib)) - - IF (mudept) GO TO 50 - albdo = alb(1) - ijob = 2 - GO TO 70 -50 albdo = alb(np) - ijob = 0 - ss(last,2) = 1. + pp(ibm1) - alb(np)*(1.-pp(ibm1)) - ss(last,3) = 1. - pp(ibm1) - alb(np)*(1.+pp(ibm1)) - - DO 60 ic = 1, 5 - - DO 60 ir = 1, last -60 cc(ir,ic) = ss(ir,ic) - -70 x(last) = (alph(ibm1)-beta(ibm1)+albdo*(flxsun(np)-alph(ibm1)-beta( & - ibm1)))*exsun(ib) + fuinc - - ! solve penta-diagonal system with r.h.s. -x-. soln goes into -x- - - ! call leqt2b(ss,last,2,2,nl2,x,1,nl2,ijob,work,nl2,work(1,8)) - - ! --------------------------------------------------------------------- - CALL leqt1b(cc,last,2,2,nl2,x,1,nl2,ijob,work) - ! --------------------------------------------------------------------- - - dir(1,np) = flxsun(np) - flxd(1,np) = fdinc - flxu(1,np) = (1.+pp(1))/ex(1)*x(1) + (1.-pp(1))*ex(1)*x(2) - & - alph(1) + beta(1) - ktr = 2 - - DO 80 i = 1, ibm1 - - IF (i+1/=isav(ktr)) GO TO 80 - dir(ktr,np) = flxsun(np)*exsun(i+1) - flxd(ktr,np) = (1.-pp(i))*x(2*i-1) + (1.+pp(i))*x(2*i) - & - (alph(i)+beta(i))*exsun(i+1) - flxu(ktr,np) = (1.+pp(i))*x(2*i-1) + (1.-pp(i))*x(2*i) - & - (alph(i)-beta(i))*exsun(i+1) - ktr = ktr + 1 -80 CONTINUE -90 CONTINUE - - RETURN - - END SUBROUTINE nlayde - - ! ####################################################################### - - SUBROUTINE delted(dtau,om,g,musun,alb,solflx,fdinc,fuinc,mudept,nz,dir, & - flxu,flxd) - ! calculate up- and down-fluxes of radiation in a vertically inhomo- - ! geneous atmosphere using the delta-eddington approximation - ! author-- w.j. wiscombe - ! national center for atmospheric research - ! p.o. box 3000 - ! boulder, colorado 80303 - ! input variables - ! nz = number of levels (level 1 is the top of the atmosphere, - ! level nz is the surface) - ! dtau(i), i=1,...,nz-1 = optical depth of layer between levels i an - ! om(i), i=1,...,nz-1 = single-scattering albedoph of layer between - ! levels i and i+1 - ! g(i), i=1,...,nz-1 = asymmetry factor for layer between levels i a - ! nsol = number of incident-beam zenith angles - ! musun(i),i=1,...,nsol = cosine(s) of incident-beam zenith angle(s) - ! alb(i), i=1,...,nsol = surface albedoph - ! mudept = true, alb(i) corresponds to musun(i). false, alb(1) is - ! used for all values of musun(i). - ! solflx = incident-beam flux (normal to beam) at level 1 - ! the beam) at the top of the atmosphere - ! fdinc = incident diffuse down-flux at level 1 - ! fuinc = incident diffuse up-flux at level nz - ! nlev = level dimension (of arrays dtau, etc.) - ! output variables (in same units as solflx, fdinc, and fuinc) - ! dir(i,np) direct flux at level -i- for sun angle -np- - ! (note--in the delta-eddington approxn, because of t - ! truncation of the forward scattering peak, this - ! quantity includes scattered radiation travelling in - ! very nearly the same direction as the actual direct - ! flux. e.g., it includes the aureole around the sun - ! flxd(i,np) diffuse down-flux at level -i- for sun angle -np- - ! (note--this will be less than the actual diffuse - ! down-flux by the same amount that the direct flux - ! -dir- is augmented.) - ! flxu(i,np) diffuse up-flux at level -i- for sun angle -np- - ! internal - ! code variable description (or name in write-up) - ! gp g-prime (transformed asymmetry parameter) - ! omp omega-prime (transformed single scattering albedoph) - ! dtaup delta-tau-prime (transformed layer optical depth) - ! tau(i) cumulative optical depth from top (i=1) to level i - ! lm(i) lambda-sub-i - ! pp(i) p-sub-i - ! lmdtau lm(i)*dtaup - ! ex(i) exp(lmdtau) - ! exsun(i) exp(-tau(i)/musun(np)) - ! alph(i) alpha-sub-i - ! beta(i) beta-sub-i - ! tx(i) 0.75*solflx*omp*(1.+gp *(1.-omp)) - ! ty(i) 0.5*solflx*omp - ! tz(i) 3.*gp*(1.-omp) - ! (tx,ty,tz are merely intermediate quantities for computing alph, - ! isav array of level indices. fluxes are calculated only - ! at these levels. - ! flxsun(np) incident flux musun(np)*solflx at level 1 - ! prec a number somewhat larger than the computer precisio - ! subtracted from any single-scattering albedophs which - ! are exactly equal to one. - ! cutpt any layer for which lmdtau.gt.cutpt is subdivided - ! into equal sublayers, all of which have lmdtau.lt.c - ! nsub number of sublayers into which an offending layer - ! is divided (the whole process being transparent - ! to the user) - ! nl2 2*nlev-2 (input to banded matrix subroutine) - ! ss(nl2,5) the penta-diagonal matrix c, in band storage mode - ! cc(nl2,5) same as -ss- array. used to submit -ss- to leqt1b. - ! work(nl2,3) a temporary storage array used by subroutine leqt1 - ! x(nl2) the vector (x-hat). also temporarily stores - ! r.h.s. d in linear system c*(x-hat) = d. - ! --note-- this code is not perfectly optimized, either in terms of - ! core storage or execution speed, but it should be noted t - ! in general, the lions share of computing time is occupied - ! the exponentials and the penta-diagonal solution routines - ! so eliminating a few operations here or there has almost - ! no impact on running time. - ! ******************* 10 x computer precision ********************** - ! *********** cut-off point for lm(i)*dtaup ************ - ! .. Scalar Arguments .. - REAL :: fdinc, fuinc, solflx - INTEGER :: nz - LOGICAL :: mudept - ! .. Local Scalars .. - REAL :: aux, aux2, c1, cutpt, dtaup, ff, gp, lmdtau, omp, prec, scale, & - t1 - INTEGER :: i, ii, ip1, iup, iupm1, ktr, layers, nl2, nlev, np, nsub, & - nzm1 - ! .. Intrinsic Functions .. - ! EXTERNAL nlayde - INTRINSIC exp, float, sqrt - ! .. Parameters .. - INTEGER, PARAMETER :: nsol = 1 - ! .. Array Arguments .. - REAL :: alb(1), dir(nj,1), dtau(nj), flxd(nj,1), flxu(nj,1), g(nj), & - musun(1), om(nj) - ! .. Local Arrays .. - REAL :: ex(nj), flxsun(1), isav(nj), lm(nj), pp(nj), tau(nj), tx(nj), & - ty(nj), tz(nj) - ! .. Data Statements .. - DATA c1/0.66666666666667/ - DATA prec/1.E-7/ - DATA cutpt/7./ - ! set incident flux at top of atmosphere - DO 10 np = 1, nsol -10 flxsun(np) = musun(np)*solflx - - nzm1 = nz - 1 - nlev = nj - nl2 = 2*nlev - 2 - - ! scale optical depth, sing-scat albedoph, and asymmetry factor - ! and calculate various fcns of these variables - - nzm1 = nz - 1 - tau(1) = 0. - - DO 20 i = 1, nzm1 - ff = g(i)**2 - gp = g(i)/(1.+g(i)) - scale = 1. - ff*om(i) - omp = (1.-ff)*om(i)/scale - - IF (om(i)==1.0) omp = 1. - prec - t1 = 1. - omp*gp - aux = 3.*(1.-omp)*t1 - - IF (om(i)==1.0) aux = 3.*prec*t1 - aux2 = 1. - om(i) - lm(i) = sqrt(aux) - pp(i) = c1*lm(i)/t1 - t1 = gp*(1.-omp) - tx(i) = 0.75*solflx*omp*(1.+t1) - ty(i) = 0.5*solflx*omp - tz(i) = 3.*t1 - isav(i) = i - dtaup = scale*dtau(i) - lmdtau = lm(i)*dtaup - ! test for a layer which is so highly absorbing that it would - ! cause ill-conditioning in the penta-diagonal matrix. if one - ! is found, subdivide it appropriately. - IF (lmdtau>cutpt) GO TO 30 - ex(i) = exp(lmdtau) - tau(i+1) = tau(i) + dtaup -20 CONTINUE - isav(nz) = nz - - - ! normal calculation - - ! --------------------------------------------------------------------- - ! Nur noch nz > 2 moeglich - CALL nlayde(nz,musun,alb,fdinc,fuinc,mudept,dir,flxu,flxd,tau,lm,pp, & - ex,tx,ty,tz,isav,flxsun,nl2) - ! --------------------------------------------------------------------- - GO TO 80 - - ! sidestep potential ill-conditioning by subdividing offending - ! layer, and any others like it. - -30 layers = nzm1 - ktr = i - -40 nsub = lmdtau/cutpt + 1. - dtaup = dtaup/float(nsub) - ex(i) = exp(lm(i)*dtaup) - tau(i+1) = tau(i) + dtaup - ip1 = i + 1 - iup = i + nsub - iupm1 = iup - 1 - - DO 50 ii = ip1, iupm1 - lm(ii) = lm(i) - pp(ii) = pp(i) - tx(ii) = tx(i) - ty(ii) = ty(i) - tz(ii) = tz(i) - ex(ii) = ex(i) -50 tau(ii+1) = tau(ii) + dtaup - ktr = ktr + 1 - isav(ktr) = isav(ktr-1) + nsub - layers = layers + nsub - 1 - - IF (layers>nlev) then - CALL wrf_error_fatal ( 'layers>nlev') - endif - - IF (iup>layers) GO TO 70 - - DO 60 i = iup, layers - ff = g(ktr)**2 - gp = g(ktr)/(1.+g(ktr)) - scale = 1. - ff*om(ktr) - omp = (1.-ff)*om(ktr)/scale - - IF (om(ktr)==1.0) omp = 1. - prec - t1 = 1. - omp*gp - lm(i) = sqrt(3.*(1.-omp)*t1) - pp(i) = c1*lm(i)/t1 - t1 = gp*(1.-omp) - tx(i) = 0.75*solflx*omp*(1.+t1) - ty(i) = 0.5*solflx*omp - tz(i) = 3.*t1 - dtaup = scale*dtau(ktr) - lmdtau = lm(i)*dtaup - ! test for a layer which is so highly absorbing that it would - ! cause ill-conditioning in the penta-diagonal matrix. if one - ! is found, subdivide it appropriately. - IF (lmdtau>cutpt) GO TO 40 - ex(i) = exp(lmdtau) - tau(i+1) = tau(i) + dtaup - ktr = ktr + 1 - isav(ktr) = isav(ktr-1) + 1 -60 CONTINUE - - ! --------------------------------------------------------------------- -70 CALL nlayde(layers+1,musun,alb,fdinc,fuinc,mudept,dir,flxu,flxd,tau, & - lm,pp,ex,tx,ty,tz,isav,flxsun,nl2) - ! --------------------------------------------------------------------- - -80 CONTINUE - RETURN - - END SUBROUTINE delted - - ! ####################################################################### - - SUBROUTINE calc_zenith(lat,long,ijd,gmt,azimuth,zenith) - ! this subroutine calculates solar zenith and azimuth angles for a - ! part - ! time and location. must specify: - ! input: - ! lat - latitude in decimal degrees - ! long - longitude in decimal degrees - ! gmt - greenwich mean time - decimal military eg. - ! 22.75 = 45 min after ten pm gmt - ! output - ! zenith - ! azimuth - ! .. Scalar Arguments .. - REAL :: azimuth, gmt, lat, long, zenith - INTEGER :: ijd - ! .. Local Scalars .. - REAL :: caz, csz, cw, d, decl, dr, ec, epsi, eqt, eyt, feqt, feqt1, & - feqt2, feqt3, feqt4, feqt5, feqt6, feqt7, lbgmt, lzgmt, ml, pepsi, & - pi, ra, raz, rdecl, reqt, rlt, rml, rphi, rra, ssw, sw, tab, w, wr, & - yt, zpt, zr - INTEGER :: jd - ! .. Intrinsic Functions .. - INTRINSIC acos, atan, cos, min, sin, tan - ! convert to radians - pi = 3.1415926535590 - dr = pi/180. - rlt = lat*dr - rphi = long*dr - - ! print julian days current 'ijd' - - ! ???? + (yr - yref) - - jd = ijd - - - - d = jd + gmt/24.0 - ! calc geom mean longitude - ml = 279.2801988 + .9856473354*d + 2.267E-13*d*d - rml = ml*dr - - ! calc equation of time in sec - ! w = mean long of perigee - ! e = eccentricity - ! epsi = mean obliquity of ecliptic - w = 282.4932328 + 4.70684E-5*d + 3.39E-13*d*d - wr = w*dr - ec = 1.6720041E-2 - 1.1444E-9*d - 9.4E-17*d*d - epsi = 23.44266511 - 3.5626E-7*d - 1.23E-15*d*d - pepsi = epsi*dr - yt = (tan(pepsi/2.0))**2 - cw = cos(wr) - sw = sin(wr) - ssw = sin(2.0*wr) - eyt = 2.*ec*yt - feqt1 = sin(rml)*(-eyt*cw-2.*ec*cw) - feqt2 = cos(rml)*(2.*ec*sw-eyt*sw) - feqt3 = sin(2.*rml)*(yt-(5.*ec**2/4.)*(cw**2-sw**2)) - feqt4 = cos(2.*rml)*(5.*ec**2*ssw/4.) - feqt5 = sin(3.*rml)*(eyt*cw) - feqt6 = cos(3.*rml)*(-eyt*sw) - feqt7 = -sin(4.*rml)*(.5*yt**2) - feqt = feqt1 + feqt2 + feqt3 + feqt4 + feqt5 + feqt6 + feqt7 - eqt = feqt*13751.0 - - ! convert eq of time from sec to deg - reqt = eqt/240. - ! calc right ascension in rads - ra = ml - reqt - rra = ra*dr - ! calc declination in rads, deg - tab = 0.43360*sin(rra) - rdecl = atan(tab) - decl = rdecl/dr - ! calc local hour angle - lbgmt = 12.0 - eqt/3600. + long*24./360. - lzgmt = 15.0*(gmt-lbgmt) - zpt = lzgmt*dr - csz = sin(rlt)*sin(rdecl) + cos(rlt)*cos(rdecl)*cos(zpt) - if(csz.gt.1)print *,'calczen,csz ',csz - csz = min(1.,csz) -! zr = acos(csz) -! zenith = zr/dr - zr = acos(csz) - zenith = zr/dr - ! calc local solar azimuth - caz = (sin(rdecl)-sin(rlt)*cos(zr))/(cos(rlt)*sin(zr)) - if(caz.lt.-0.999999)then - azimuth=180. - elseif(caz.gt.0.999999)then - azimuth=0. - else - raz = acos(caz) - azimuth = raz/dr - endif -! caz = min(1.,(sin(rdecl)-sin(rlt)*cos(zr))/(cos(rlt)*sin(zr))) -! if(caz.lt.-1)print *,'calczen ',caz -! caz = max(-1.,caz) -! raz = acos(caz) -! azimuth = raz/dr - - IF (lzgmt>0) azimuth = azimuth + (2*(180.-azimuth)) - ! 200 format(' ',f7.2,2(12x,f7.2)) - RETURN - - END SUBROUTINE calc_zenith - - SUBROUTINE trapez(x,y,ianfa,ienda,u,v,ianfn,iendn,ix,iy,iu,iv) - ! * implemented 1992 by ansgar ruggaber, university of munich, frg - ! * funded by the german minister of research and technology (bmft) - ! * under contract no. 521-4007-07eu-738 8 - ! lineare interpolation of referencefield (x(i),y(i)) - ! to (u(i),v(i)) - ! save - ! .. Scalar Arguments .. - INTEGER :: ianfa, ianfn, ienda, iendn, iu, iv, ix, iy - ! .. Array Arguments .. - REAL :: u(iu), v(iv), x(ix), y(iy) - ! .. Local Scalars .. - REAL :: uumord, vumord, xumord, yumord - INTEGER :: i, ianf, ianfnn, idrehu, idrehx, iendnn, iordu, iordx, j - - idrehx = 0 - - IF (x(ianfa)>=x(ienda)) THEN - ! das x-feld wird ansteigend geordnet, das y-feld entsprechend - iordx = (ienda-ianfa+1)/2 - - DO i = ianfa, iordx - xumord = x(i) - x(i) = x(ienda+1-i) - x(ienda+1-i) = xumord - yumord = y(i) - y(i) = y(ienda+1-i) - y(ienda+1-i) = yumord - END DO - - idrehx = 1 - END IF - - idrehu = 0 - - IF (u(ianfn)>=u(iendn)) THEN - ! u-field increasing - iordu = (iendn-ianfn+1)/2 - - DO i = ianfn, iordu - uumord = u(i) - u(i) = u(iendn+1-i) - u(iendn+1-i) = uumord - END DO - - idrehu = 1 - END IF - - ianfnn = ianfn -10 CONTINUE - - IF (u(ianfnn)x(ienda)) THEN - ! no extrapolation at x(ienda) - v(iendnn) = 1.0E-12 - iendnn = iendnn - 1 - GO TO 20 - END IF - - ianf = ianfa - - DO j = ianfnn, iendnn - - DO i = ianf, ienda - - IF (x(i)-u(j)) 30, 50, 40 -30 END DO - - GO TO 70 -40 v(j) = y(i-1) + (y(i)-y(i-1))/(x(i)-x(i-1))*(u(j)-x(i-1)) - GO TO 60 -50 v(j) = y(i) -60 ianf = i -70 END DO - - IF (idrehx/=0) THEN - ! x- und y-field in starting position - DO i = ianfa, iordx - xumord = x(i) - x(i) = x(ienda+1-i) - x(ienda+1-i) = xumord - yumord = y(i) - y(i) = y(ienda+1-i) - y(ienda+1-i) = yumord - END DO - - END IF - - IF (idrehu/=0) THEN - - DO i = ianfn, iordu - uumord = u(i) - u(i) = u(iendn+1-i) - u(iendn+1-i) = uumord - vumord = v(i) - v(i) = v(iendn+1-i) - v(iendn+1-i) = vumord - END DO - - END IF - - END SUBROUTINE trapez - - SUBROUTINE photmad_init(z_at_w,aerwrf,g,ids,ide,jds,jde,kds,kde,ims,ime, & - jms,jme,kms,kme,its,ite,jts,jte,kts,kte) - ! local stuff - ! .. Scalar Arguments .. - REAL, INTENT (IN) :: g - INTEGER, INTENT (IN) :: ide, ids, ime, ims, ite, its, jde, jds, jme, & - jms, jte, jts, kde, kds, kme, kms, kte, kts - ! .. Array Arguments .. - REAL, INTENT (INOUT) :: aerwrf(ims:ime,kms:kme,jms:jme) - REAL, INTENT (IN) :: z_at_w(ims:ime,kms:kme,jms:jme) - ! .. Local Scalars .. - REAL :: z1 - INTEGER :: i, j, k - ! .. Local Arrays .. - REAL :: aerext(kts:kte), phizz(kts:kte), z(kts:kte) - - DO j = jts, jte - - IF (j>jde-1) GO TO 20 - - DO i = its, ite - - IF (i>ide-1) GO TO 10 - - ! z at w points - - z1 = z_at_w(i,kts,j) - z(kts)=0. - - DO k = kts+1, kte - z(k) = z_at_w(i,k,j) - z1 - END DO - - DO k = kts, kte - phizz(k) = .001*z(k) - aerext(k) = 0. -! if(i.eq.its.and.j.eq.jts)print *,phizz(k),aerstd(k),kts,kte -! print *,phizz(k),kts,kte,ite,jte - END DO - -! IF (phizz(kte-1)>20.) THEN -! CALL wrf_error_fatal ( 'phizz(kte-1)>20., set kl0 to 1') -! END IF - - CALL trapez(zstd,aerstd,1,51,phizz,aerext,kts,kte,51,51,kte,kte) - - DO k = kts, kte - aerwrf(i,k,j) = aerext(k) -! if(i.eq.its)print *,k,i,j,aerext(k),phizz(k) -! print *,k,i,j,aerext(k),phizz(k) - END DO - -10 CONTINUE - END DO - -20 CONTINUE - END DO - - END SUBROUTINE photmad_init - - END MODULE module_phot_mad diff --git a/src/fim/FIMsrc/fim/column_chem/module_plumerise1.F90 b/src/fim/FIMsrc/fim/column_chem/module_plumerise1.F90 deleted file mode 100644 index 1f8a20f..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_plumerise1.F90 +++ /dev/null @@ -1,302 +0,0 @@ -Module module_plumerise1 - USE module_constants,only: g=>grvity,cp,r_d=>rd,r_v=>rv,p1000mb=>p1000 -USE module_initial_chem_namelists,only: p_qv -! use module_zero_plumegen_coms - integer, parameter :: nveg_agreg = 4 -! integer, parameter :: tropical_forest = 1 -! integer, parameter :: boreal_forest = 2 -! integer, parameter :: savannah = 3 - -! integer, parameter :: grassland = 4 - real, dimension(nveg_agreg) :: firesize,mean_fct -! character(len=20), parameter :: veg_name(nveg_agreg) = (/ & -! 'Tropical-Forest', & -! 'Boreal-Forest ', & -! 'Savanna ', & -! 'Grassland ' /) -! character(len=20), parameter :: spc_suf(nveg_agreg) = (/ & -! 'agtf' , & ! trop forest -! 'agef' , & ! extratrop forest -! 'agsv' , & ! savanna -! 'aggr' /) ! grassland - - -CONTAINS -subroutine plumerise_driver (ktau,dtstep,num_chem,num_moist, & - ebu_no,ebu_co,ebu_co2,ebu_eth,ebu_hc3,ebu_hc5,ebu_hc8, & - ebu_ete,ebu_olt,ebu_oli,ebu_pm25,ebu_pm10,ebu_dien,ebu_iso, & - ebu_api,ebu_lim,ebu_tol,ebu_xyl,ebu_csl,ebu_hcho,ebu_ald, & - ebu_ket,ebu_macr,ebu_ora1,ebu_ora2,ebu_bc,ebu_oc,ebu_so2, & - ebu_sulf, & - ebu_in_no,ebu_in_co,ebu_in_co2,ebu_in_eth,ebu_in_hc3,ebu_in_hc5, & - ebu_in_hc8,ebu_in_ete,ebu_in_olt,ebu_in_oli,ebu_in_pm25,ebu_in_pm10, & - ebu_in_dien,ebu_in_iso,ebu_in_api,ebu_in_lim,ebu_in_tol,ebu_in_xyl, & - ebu_in_csl,ebu_in_hcho,ebu_in_ald,ebu_in_ket,ebu_in_macr,ebu_in_ora1, & - ebu_in_ora2,ebu_in_bc,ebu_in_oc,ebu_in_so2,ebu_in_sulf, & - mean_fct_agtf,mean_fct_agef,mean_fct_agsv,mean_fct_aggr, & - firesize_agtf,firesize_agef,firesize_agsv,firesize_aggr, & - t_phy,moist, & - chem,rho_phy,vvel,u_phy,v_phy,p_phy, & - z_at_w,z, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - -! USE module_configure -! USE module_model_constants -! USE module_state_description - USE module_zero_plumegen_coms - USE module_chem_plumerise_scalar - IMPLICIT NONE -! integer, parameter :: nveg_agreg = 4 -! integer, parameter :: nveg_agreg = 4 -! integer, parameter :: tropical_forest = 1 -! integer, parameter :: boreal_forest = 2 -! integer, parameter :: savannah = 3 - - - INTEGER, INTENT(IN ) :: ktau,num_chem,num_moist, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & - INTENT(IN ) :: moist - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & - INTENT(INOUT ) :: chem - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & - INTENT(INOUT ) :: & - ebu_no,ebu_co,ebu_co2,ebu_eth,ebu_hc3,ebu_hc5,ebu_hc8, & - ebu_ete,ebu_olt,ebu_oli,ebu_pm25,ebu_pm10,ebu_dien,ebu_iso, & - ebu_api,ebu_lim,ebu_tol,ebu_xyl,ebu_csl,ebu_hcho,ebu_ald, & - ebu_ket,ebu_macr,ebu_ora1,ebu_ora2,ebu_bc,ebu_oc,ebu_so2, & - ebu_sulf - - REAL, DIMENSION( ims:ime, jms:jme ), & - OPTIONAL, & - INTENT(IN ) :: & - ebu_in_no,ebu_in_co,ebu_in_co2,ebu_in_eth,ebu_in_hc3,ebu_in_hc5, & - ebu_in_hc8,ebu_in_ete,ebu_in_olt,ebu_in_oli,ebu_in_pm25,ebu_in_pm10, & - ebu_in_dien,ebu_in_iso,ebu_in_api,ebu_in_lim,ebu_in_tol,ebu_in_xyl, & - ebu_in_csl,ebu_in_hcho,ebu_in_ald,ebu_in_ket,ebu_in_macr,ebu_in_ora1, & - ebu_in_ora2,ebu_in_bc,ebu_in_oc,ebu_in_so2,ebu_in_sulf - - REAL, DIMENSION( ims:ime, jms:jme ), & - INTENT(IN ) :: & - mean_fct_agtf,mean_fct_agef,& - mean_fct_agsv,mean_fct_aggr,firesize_agtf,firesize_agef, & - firesize_agsv,firesize_aggr - -! -! -! - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & - INTENT(IN ) :: & - t_phy, & - z,z_at_w,vvel,u_phy,v_phy,rho_phy,p_phy - REAL, INTENT(IN ) :: & - dtstep -! -! Local variables... -! - INTEGER :: i, j, k, ksub - - - integer, parameter :: nspecies=30 - real, dimension (nspecies) :: eburn_in - real, dimension (kte,nspecies) :: eburn_out - real, dimension (kte) :: u_in ,v_in ,w_in ,theta_in ,pi_in & - ,rho_phyin ,qv_in ,zmid & - ,z_lev -! real, dimension(nveg_agreg) :: firesize,mean_fct - real :: sum, ffirs,rcp - rcp=r_d/cp - ffirs=0. - do j=jts,jte - do i=its,ite - ebu_no(i,kts,j)=ebu_in_no(i,j) - ebu_co(i,kts,j)=ebu_in_co(i,j) - ebu_co2(i,kts,j)=ebu_in_co2(i,j) - ebu_eth(i,kts,j)=ebu_in_eth(i,j) - ebu_hc3(i,kts,j)=ebu_in_hc3(i,j) - ebu_hc5(i,kts,j)=ebu_in_hc5(i,j) - ebu_hc8(i,kts,j)=ebu_in_hc8(i,j) - ebu_ete(i,kts,j)=ebu_in_ete(i,j) - ebu_olt(i,kts,j)=ebu_in_olt(i,j) - ebu_oli(i,kts,j)=ebu_in_oli(i,j) - ebu_pm25(i,kts,j)=ebu_in_pm25(i,j) - ebu_pm10(i,kts,j)=ebu_in_pm10(i,j) - ebu_dien(i,kts,j)=ebu_in_dien(i,j) - ebu_iso(i,kts,j)=ebu_in_iso(i,j) - ebu_api(i,kts,j)=ebu_in_api(i,j) - ebu_lim(i,kts,j)=ebu_in_lim(i,j) - ebu_tol(i,kts,j)=ebu_in_tol(i,j) - ebu_xyl(i,kts,j)=ebu_in_xyl(i,j) - ebu_csl(i,kts,j)=ebu_in_csl(i,j) - ebu_hcho(i,kts,j)=ebu_in_hcho(i,j) - ebu_ald(i,kts,j)=ebu_in_ald(i,j) - ebu_ket(i,kts,j)=ebu_in_ket(i,j) - ebu_macr(i,kts,j)=ebu_in_macr(i,j) - ebu_ora1(i,kts,j)=ebu_in_ora1(i,j) - ebu_ora2(i,kts,j)=ebu_in_ora2(i,j) - ebu_sulf(i,kts,j)=0. ! gg - ebu_bc(i,kts,j)=ebu_in_bc(i,j) - ebu_oc(i,kts,j)=ebu_in_oc(i,j) - ebu_so2(i,kts,j)=ebu_in_so2(i,j) -! ebu_dms(i,kts,j)=ebu_in_dms(i,j) - do k=kts+1,kte - ebu_co(i,k,j)=0. - ebu_co2(i,k,j)=0. - ebu_eth(i,k,j)=0. - ebu_hc3(i,k,j)=0. - ebu_hc5(i,k,j)=0. - ebu_hc8(i,k,j)=0. - ebu_ete(i,k,j)=0. - ebu_olt(i,k,j)=0. - ebu_oli(i,k,j)=0. - ebu_pm25(i,k,j)=0. - ebu_pm10(i,k,j)=0. - ebu_dien(i,k,j)=0. - ebu_iso(i,k,j)=0. - ebu_api(i,k,j)=0. - ebu_lim(i,k,j)=0. - ebu_tol(i,k,j)=0. - ebu_xyl(i,k,j)=0. - ebu_csl(i,k,j)=0. - ebu_hcho(i,k,j)=0. - ebu_ald(i,k,j)=0. - ebu_ket(i,k,j)=0. - ebu_macr(i,k,j)=0. - ebu_ora1(i,k,j)=0. - ebu_ora2(i,k,j)=0. - ebu_sulf(i,k,j)=0. - ebu_bc(i,k,j)=0. - ebu_oc(i,k,j)=0. - ebu_so2(i,k,j)=0. - enddo - enddo - enddo - do j=jts,jte - do i=its,ite - sum=mean_fct_agtf(i,j)+mean_fct_agef(i,j)+mean_fct_agsv(i,j) & - +mean_fct_aggr(i,j) - if(sum.lt.1.e-6)Cycle - ffirs=ffirs+1 - eburn_out=0. - mean_fct(1)=mean_fct_agtf(i,j) - mean_fct(2)=mean_fct_agef(i,j) - mean_fct(3)=mean_fct_agsv(i,j) - mean_fct(4)=mean_fct_aggr(i,j) - firesize(1)=firesize_agtf(i,j) - firesize(2)=firesize_agef(i,j) - firesize(3)=firesize_agsv(i,j) - firesize(4)=firesize_aggr(i,j) - eburn_in(1)=ebu_no(i,kts,j) - eburn_in(2)=ebu_co(i,kts,j) - eburn_in(3)=ebu_co2(i,kts,j) - eburn_in(4)=ebu_eth(i,kts,j) - eburn_in(5)=ebu_hc3(i,kts,j) - eburn_in(6)=ebu_hc5(i,kts,j) - eburn_in(7)=ebu_hc8(i,kts,j) - eburn_in(8)=ebu_ete(i,kts,j) - eburn_in(9)=ebu_olt(i,kts,j) - eburn_in(10)=ebu_oli(i,kts,j) - eburn_in(11)=ebu_pm25(i,kts,j) - eburn_in(12)=ebu_pm10(i,kts,j) - eburn_in(13)=ebu_dien(i,kts,j) - eburn_in(14)=ebu_iso(i,kts,j) - eburn_in(15)=ebu_api(i,kts,j) - eburn_in(16)=ebu_lim(i,kts,j) - eburn_in(17)=ebu_tol(i,kts,j) - eburn_in(18)=ebu_xyl(i,kts,j) - eburn_in(19)=ebu_csl(i,kts,j) - eburn_in(20)=ebu_hcho(i,kts,j) - eburn_in(21)=ebu_ald(i,kts,j) - eburn_in(22)=ebu_ket(i,kts,j) - eburn_in(23)=ebu_macr(i,kts,j) - eburn_in(24)=ebu_ora1(i,kts,j) - eburn_in(25)=ebu_ora2(i,kts,j) - eburn_in(26)=ebu_sulf(i,kts,j) - eburn_in(27)=ebu_oc(i,kts,j) - eburn_in(28)=ebu_bc(i,kts,j) - eburn_in(29)=ebu_so2(i,kts,j) - eburn_in(30)=ebu_so2(i,kts,j) ! junk -! if(i.eq.1.and.j.eq.17)write(0,*)'before',i,j,cp,p1000mb,rcp - do k=kts,kte-1 - u_in(k)=u_phy(i,k,j) - v_in(k)=v_phy(i,k,j) - w_in(k)=vvel(i,k,j) - qv_in(k)=moist(i,k,j,p_qv) - pi_in(k)=cp*(p_phy(i,k,j)/p1000mb)**rcp - zmid(k)=z(i,k,j)-z_at_w(i,kts,j) - z_lev(k)=z_at_w(i,k,j)-z_at_w(i,kts,j) - rho_phyin(k)=rho_phy(i,k,j) - theta_in(k)=t_phy(i,k,j)/pi_in(k)*cp -! if(i.eq.1.and.j.eq.17)then -! write(0,*)k,p_phy(i,k,j),t_phy(i,k,j),pi_in(k),theta_in(k) -! endif - enddo - pi_in(kte)=pi_in(kte-1) !wig: These are no longer needed after changing definition - u_in(kte)=u_in(kte-1) ! of kte in chem_driver (12-Oct-2007) - v_in(kte)=v_in(kte-1) - w_in(kte)=w_in(kte-1) - qv_in(kte)=qv_in(kte-1) - zmid(kte)=z(i,kte,j)-z_at_w(i,kts,j) - z_lev(kte)=z_at_w(i,kte,j)-z_at_w(i,kts,j) - rho_phyin(kte)=rho_phyin(kte-1) - theta_in(kte)=theta_in(kte-1) -! if(ffirs.le.5)then -! do k=kts,kte -! write(0,*)k,z_lev(k),zmid(k),rho_phyin(k),theta_in(k) -! enddo -! write(0,*)'eburn',eburn_in(27),mean_fct,firesize -! endif - - call plumerise(kte,1,1,1,1,1,1,firesize,mean_fct & - ,nspecies,eburn_in,eburn_out & - ,u_in ,v_in ,w_in ,theta_in ,pi_in & - ,rho_phyin ,qv_in ,zmid & - ,z_lev ) -! if(ffirs.le.5)then -! do k=kts,kte -! write(0,*)'eburn_out ',k,i,j,eburn_out(k,27) -! enddo -! endif - do k=kts+1,kte-2 - ebu_no(i,k,j)=eburn_out(k,1)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_co(i,k,j)=eburn_out(k,2)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) -! write(0,*)'after',k,ebu_co(i,k,j) - ebu_co2(i,k,j)=eburn_out(k,3)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_eth(i,k,j)=eburn_out(k,4)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_hc3(i,k,j)=eburn_out(k,5)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_hc5(i,k,j)=eburn_out(k,6)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_hc8(i,k,j)=eburn_out(k,7)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_ete(i,k,j)=eburn_out(k,8)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_olt(i,k,j)=eburn_out(k,9)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_oli(i,k,j)=eburn_out(k,10)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_pm25(i,k,j)=eburn_out(k,11)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_pm10(i,k,j)=eburn_out(k,12)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_dien(i,k,j)=eburn_out(k,13)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_iso(i,k,j)=eburn_out(k,14)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_api(i,k,j)=eburn_out(k,15)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_lim(i,k,j)=eburn_out(k,16)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_tol(i,k,j)=eburn_out(k,17)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_xyl(i,k,j)=eburn_out(k,18)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_csl(i,k,j)=eburn_out(k,19)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_hcho(i,k,j)=eburn_out(k,20)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_ald(i,k,j)=eburn_out(k,21)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_ket(i,k,j)=eburn_out(k,22)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_macr(i,k,j)=eburn_out(k,23)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_ora1(i,k,j)=eburn_out(k,24)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_ora2(i,k,j)=eburn_out(k,25)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) -! ebu_sulf(i,k,j)=eburn_out(k,26)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_oc(i,k,j)=eburn_out(k,27)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_bc(i,k,j)=eburn_out(k,28)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_so2(i,k,j)=eburn_out(k,29)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) -! ebu_dms(i,k,j)=eburn_out(k,30)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - enddo - - enddo - enddo -end subroutine plumerise_driver - -END Module module_plumerise1 diff --git a/src/fim/FIMsrc/fim/column_chem/module_species_decs.F90 b/src/fim/FIMsrc/fim/column_chem/module_species_decs.F90 deleted file mode 100644 index 2eb0866..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_species_decs.F90 +++ /dev/null @@ -1,8 +0,0 @@ -MODULE module_species_decs -! -! this is straight from state_description.F out of wrf/frame. The NUM_ decs are commented for fim, -! since they have to be defined in module_control -! -! SAVE -! INTEGER :: NUM_chem = 1 -end module module_species_decs diff --git a/src/fim/FIMsrc/fim/column_chem/module_vash_settling.F90 b/src/fim/FIMsrc/fim/column_chem/module_vash_settling.F90 deleted file mode 100644 index 3d01700..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_vash_settling.F90 +++ /dev/null @@ -1,550 +0,0 @@ -MODULE MODULE_VASH_SETTLING - -CONTAINS - -SUBROUTINE vash_settling_driver(dt,t_phy,moist, & - chem,rho_phy,dz8w,p8w,p_phy,area, & - ash_fall,g,num_moist,num_chem, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) -! USE module_data_gocart_dust -! USE module_data_gocart_seas - USE module_initial_chem_namelists - IMPLICIT NONE - INTEGER, INTENT(IN ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - num_chem,num_moist - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & - INTENT(IN ) :: moist - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & - INTENT(INOUT ) :: chem - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: t_phy,p_phy,dz8w,p8w,rho_phy - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(INOUT ) :: ash_fall - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(IN ) :: area - - REAL, INTENT(IN ) :: dt,g - integer :: nmx,i,j,k,kk,lmx,iseas,idust - real*8, DIMENSION (1,1,kte-kts+0) :: tmp,airden,airmas,p_mid,delz,rh - real*8, DIMENSION (1,1,kte-kts+0,5) :: dust - real*8, DIMENSION (1,1,kte-kts+0,4) :: sea_salt -!srf - real*8, DIMENSION (1,1,kte-kts+0,10) :: ash - real*8, DIMENSION (10), PARAMETER :: den_ash(10)=(/2500.,2500.,2500.,2500.,2500., & - 2500.,2500.,2500.,2500.,2500. /) - real*8, DIMENSION (10), PARAMETER :: reff_ash(10)=(/0.5000D-3,&! 1.00 mm diameter - 0.3750D-3,&! 0.75 mm - 0.1875D-3,&! - 93.750D-6,&! - 46.875D-6,&! - 23.437D-6,&! - 11.719D-6,&! - 05.859D-6,&! - 02.930D-6,&! - 00.975D-6 /)! 3.9 um - real*8, DIMENSION (10) :: bstl_ash - real*8 :: maxash(10) - real :: are - integer nv,iprt,iash -!srf - -! -! bstl is for budgets -! - - real*8 conver,converi - conver=1.e-9 - converi=1.e9 - lmx=kte-kts+1 - lmx=kte-kts - do j=jts,jte - do i=its,ite - kk=0 - are=area(i,j) - bstl_ash(:)=0. - do k=kts,kte-1 - kk=kk+1 - p_mid(1,1,kk)=.01*p_phy(i,kte-k+kts-1,j) - delz(1,1,kk)=dz8w(i,kte-k+kts-1,j) - airmas(1,1,kk)=-(p8w(i,k+1,j)-p8w(i,k,j))/g - airden(1,1,kk)=rho_phy(i,k,j) - tmp(1,1,kk)=t_phy(i,k,j) - rh(1,1,kk) = .95 - rh(1,1,kk) = MIN( .95, moist(i,k,j,p_qv) / & - (3.80*exp(17.27*(t_phy(i,k,j)-273.)/ & - (t_phy(i,k,j)-36.))/(.01*p_phy(i,k,j)))) - rh(1,1,kk)=max(1.0D-1,rh(1,1,kk)) -! if(j.eq.803)then -! write(6,*)'0++',p_mid(1,1,kk),delz(1,1,kk),airmas(1,1,kk) -! endif - enddo - -!ash settling - maxash(:)=0. - kk=0 - do nv=p_vash_1,p_vash_10 - kk=kk+1 - do k=kts,kte - if(chem(i,k,j,nv).gt.maxash(kk)) maxash(kk)=chem(i,k,j,nv) - enddo - enddo - - iseas=0 - idust=0 - iash =1 - - kk=0 -! write(0,*)'1',chem(i,1,j,p_dust_4) - do k=kts,kte-1 - kk=kk+1 - if(chem(i,k,j,p_vash_1).le.1.e-10)chem(i,k,j,p_vash_1)=0. - if(chem(i,k,j,p_vash_2).le.1.e-10)chem(i,k,j,p_vash_2)=0. - if(chem(i,k,j,p_vash_3).le.1.e-10)chem(i,k,j,p_vash_3)=0. - if(chem(i,k,j,p_vash_4).le.1.e-10)chem(i,k,j,p_vash_4)=0. - if(chem(i,k,j,p_vash_5).le.1.e-10)chem(i,k,j,p_vash_5)=0. - if(chem(i,k,j,p_vash_6).le.1.e-10)chem(i,k,j,p_vash_6)=0. - if(chem(i,k,j,p_vash_7).le.1.e-10)chem(i,k,j,p_vash_7)=0. - if(chem(i,k,j,p_vash_8).le.1.e-10)chem(i,k,j,p_vash_8)=0. - if(chem(i,k,j,p_vash_9).le.1.e-10)chem(i,k,j,p_vash_9)=0. - if(chem(i,k,j,p_vash_10).le.1.e-10)chem(i,k,j,p_vash_10)=0. - ash(1,1,kk,1)=chem(i,k,j,p_vash_1)*conver - ash(1,1,kk,2)=chem(i,k,j,p_vash_2)*conver - ash(1,1,kk,3)=chem(i,k,j,p_vash_3)*conver - ash(1,1,kk,4)=chem(i,k,j,p_vash_4)*conver - ash(1,1,kk,5)=chem(i,k,j,p_vash_5)*conver - ash(1,1,kk,6)=chem(i,k,j,p_vash_6)*conver - ash(1,1,kk,7)=chem(i,k,j,p_vash_7)*conver - ash(1,1,kk,8)=chem(i,k,j,p_vash_8)*conver - ash(1,1,kk,9)=chem(i,k,j,p_vash_9)*conver - ash(1,1,kk,10)=chem(i,k,j,p_vash_10)*conver -! if(j.eq.803)then -! write(6,*)'1++',kk,ash(1,1,kk,7) -! endif -! if(j.eq.8487)print *,chem(i,k,j,p_vash_10) - enddo - iprt=0 -! if(j.eq.803)iprt=1 - call vsettling(iprt,1, 1, lmx, 10, g,are,& - ash, tmp, p_mid, delz, airmas, & - den_ash, reff_ash, dt, bstl_ash, rh, idust, iseas,iash) - kk=0 - ash_fall(i,j)=ash_fall(i,j)+sum(bstl_ash(1:10)) - do k=kts,kte-2 - kk=kk+1 - chem(i,k,j,p_vash_1)=min(maxash(1),ash(1,1,kk,1)*converi) - chem(i,k,j,p_vash_2)=min(maxash(2),ash(1,1,kk,2)*converi) - chem(i,k,j,p_vash_3)=min(maxash(3),ash(1,1,kk,3)*converi) - chem(i,k,j,p_vash_4)=min(maxash(4),ash(1,1,kk,4)*converi) - chem(i,k,j,p_vash_5)=min(maxash(5),ash(1,1,kk,5)*converi) - chem(i,k,j,p_vash_6)=min(maxash(6),ash(1,1,kk,6)*converi) - chem(i,k,j,p_vash_7)=min(maxash(7),ash(1,1,kk,7)*converi) - chem(i,k,j,p_vash_8)=min(maxash(8),ash(1,1,kk,8)*converi) - chem(i,k,j,p_vash_9)=min(maxash(9),ash(1,1,kk,9)*converi) - chem(i,k,j,p_vash_10)=min(maxash(10),ash(1,1,kk,10)*converi) - if(chem(i,k,j,p_vash_1).le.1.e-10)chem(i,k,j,p_vash_1)=0. - if(chem(i,k,j,p_vash_2).le.1.e-10)chem(i,k,j,p_vash_2)=0. - if(chem(i,k,j,p_vash_3).le.1.e-10)chem(i,k,j,p_vash_3)=0. - if(chem(i,k,j,p_vash_4).le.1.e-10)chem(i,k,j,p_vash_4)=0. - if(chem(i,k,j,p_vash_5).le.1.e-10)chem(i,k,j,p_vash_5)=0. - if(chem(i,k,j,p_vash_6).le.1.e-10)chem(i,k,j,p_vash_6)=0. - if(chem(i,k,j,p_vash_7).le.1.e-10)chem(i,k,j,p_vash_7)=0. - if(chem(i,k,j,p_vash_8).le.1.e-10)chem(i,k,j,p_vash_8)=0. - if(chem(i,k,j,p_vash_9).le.1.e-10)chem(i,k,j,p_vash_9)=0. - if(chem(i,k,j,p_vash_10).le.1.e-10)chem(i,k,j,p_vash_10)=0. -! if(j.eq.803)then -! write(6,*)'2++',kk,ash(1,1,kk,7) -! endif -! if(j.eq.8487)print *,chem(i,k,j,p_vash_10),ash_fall(i,j) - enddo - -!ash settling end - - - - - enddo - enddo -END SUBROUTINE vash_settling_driver -SUBROUTINE vashshort_settling_driver(dt,t_phy,moist, & - chem,rho_phy,dz8w,p8w,p_phy,area, & - ash_fall,g,num_moist,num_chem, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) -! USE module_data_gocart_dust -! USE module_data_gocart_seas - USE module_initial_chem_namelists - IMPLICIT NONE - INTEGER, INTENT(IN ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - num_chem,num_moist - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & - INTENT(IN ) :: moist - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & - INTENT(INOUT ) :: chem - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: t_phy,p_phy,dz8w,p8w,rho_phy - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(INOUT ) :: ash_fall - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(IN ) :: area - - REAL, INTENT(IN ) :: dt,g - integer :: nmx,i,j,k,kk,lmx,iseas,idust - real*8, DIMENSION (1,1,kte-kts+0) :: tmp,airden,airmas,p_mid,delz,rh - real*8, DIMENSION (1,1,kte-kts+0,5) :: dust - real*8, DIMENSION (1,1,kte-kts+0,4) :: sea_salt -!srf - real*8, DIMENSION (1,1,kte-kts+0,10) :: ash - real*8, DIMENSION (4), PARAMETER :: den_ash(4)=(/2500.,2500.,2500.,2500. /) - real*8, DIMENSION (4), PARAMETER :: reff_ash(4)=(/ 11.719D-6,&! - 05.859D-6,&! - 02.930D-6,&! - 00.975D-6 /)! 3.9 um - real*8, DIMENSION (4) :: bstl_ash - real*8 :: maxash(4) - real :: are - integer nv,iprt,iash -!srf - -! -! bstl is for budgets -! - - real*8 conver,converi - conver=1.e-9 - converi=1.e9 - lmx=kte-kts+1 - lmx=kte-kts - do j=jts,jte - do i=its,ite - kk=0 - are=area(i,j) - bstl_ash(:)=0. - do k=kts,kte-1 - kk=kk+1 - p_mid(1,1,kk)=.01*p_phy(i,kte-k+kts-1,j) - delz(1,1,kk)=dz8w(i,kte-k+kts-1,j) - airmas(1,1,kk)=-(p8w(i,k+1,j)-p8w(i,k,j))/g - airden(1,1,kk)=rho_phy(i,k,j) - tmp(1,1,kk)=t_phy(i,k,j) - rh(1,1,kk) = .95 - rh(1,1,kk) = MIN( .95, moist(i,k,j,p_qv) / & - (3.80*exp(17.27*(t_phy(i,k,j)-273.)/ & - (t_phy(i,k,j)-36.))/(.01*p_phy(i,k,j)))) - rh(1,1,kk)=max(1.0D-1,rh(1,1,kk)) -! if(j.eq.803)then -! write(6,*)'0++',p_mid(1,1,kk),delz(1,1,kk),airmas(1,1,kk) -! endif - enddo - -!ash settling - kk=0 - maxash(:)=0. - if(p_vash_4.gt.1)then - do nv=p_vash_1,p_vash_4 - kk=kk+1 - do k=kts,kte - if(chem(i,k,j,nv).gt.maxash(kk)) maxash(kk)=chem(i,k,j,nv) - enddo - enddo -! GOCART - else if(p_bc2.gt.1)then - nv=p_p25 - kk=kk+1 - do k=kts,kte - if(chem(i,k,j,nv).gt.maxash(kk)) maxash(kk)=chem(i,k,j,nv) - enddo - nv=p_p10 - kk=kk+1 - do k=kts,kte - if(chem(i,k,j,nv).gt.maxash(kk)) maxash(kk)=chem(i,k,j,nv) - enddo - endif - - - iseas=0 - idust=0 - iash =1 - - if(p_vash_4.gt.1)then - kk=0 -! write(0,*)'1',chem(i,1,j,p_dust_4) - do k=kts,kte-1 - kk=kk+1 - if(chem(i,k,j,p_vash_1).le.1.e-10)chem(i,k,j,p_vash_1)=0. - if(chem(i,k,j,p_vash_2).le.1.e-10)chem(i,k,j,p_vash_2)=0. - if(chem(i,k,j,p_vash_3).le.1.e-10)chem(i,k,j,p_vash_3)=0. - if(chem(i,k,j,p_vash_4).le.1.e-10)chem(i,k,j,p_vash_4)=0. - ash(1,1,kk,1)=chem(i,k,j,p_vash_1)*conver - ash(1,1,kk,2)=chem(i,k,j,p_vash_2)*conver - ash(1,1,kk,3)=chem(i,k,j,p_vash_3)*conver - ash(1,1,kk,4)=chem(i,k,j,p_vash_4)*conver -! if(j.eq.803)then -! write(6,*)'1++',kk,ash(1,1,kk,7) -! endif -! if(j.eq.8487)print *,chem(i,k,j,p_vash_10) - enddo -! -! volc ash for gocart, this is crude -! - else if(p_bc2.gt.1)then - kk=0 - do k=kts,kte-1 - kk=kk+1 - ash(1,1,kk,1)=0. -! ash(1,1,kk,4)=chem(i,k,j,p_p25)*conver - ash(1,1,kk,3)=.67*chem(i,k,j,p_p10)*conver - ash(1,1,kk,2)=(1.-.67)*chem(i,k,j,p_p10)*conver - if(ash(1,1,kk,2).le.1.e-10)ash(1,1,kk,2)=0. - if(ash(1,1,kk,3).le.1.e-10)ash(1,1,kk,3)=0. - if(ash(1,1,kk,4).le.1.e-10)ash(1,1,kk,4)=0. - enddo - endif - iprt=0 -! if(j.eq.803)iprt=1 - call vsettling(iprt,1, 1, lmx, 4, g,are,& - ash, tmp, p_mid, delz, airmas, & - den_ash, reff_ash, dt, bstl_ash, rh, idust, iseas,iash) - ash_fall(i,j)=ash_fall(i,j)+sum(bstl_ash(1:4)) - if(p_vash_4.gt.1)then - kk=0 - do k=kts,kte-2 - kk=kk+1 - chem(i,k,j,p_vash_1)=min(maxash(1),ash(1,1,kk,1)*converi) - chem(i,k,j,p_vash_2)=min(maxash(2),ash(1,1,kk,2)*converi) - chem(i,k,j,p_vash_3)=min(maxash(3),ash(1,1,kk,3)*converi) - chem(i,k,j,p_vash_4)=min(maxash(4),ash(1,1,kk,4)*converi) - if(chem(i,k,j,p_vash_1).le.1.e-10)chem(i,k,j,p_vash_1)=0. - if(chem(i,k,j,p_vash_2).le.1.e-10)chem(i,k,j,p_vash_2)=0. - if(chem(i,k,j,p_vash_3).le.1.e-10)chem(i,k,j,p_vash_3)=0. - if(chem(i,k,j,p_vash_4).le.1.e-10)chem(i,k,j,p_vash_4)=0. - enddo - else if(p_bc2.gt.1)then - kk=0 - do k=kts,kte-2 - kk=kk+1 -! chem(i,k,j,p_p25)=min(maxash(1),ash(1,1,kk,4)*converi) - chem(i,k,j,p_p10)=min(maxash(2),(ash(1,1,kk,2)+ash(1,1,kk,3))*converi) -! if(chem(i,k,j,p_p25).le.1.e-16)chem(i,k,j,p_p25)=1.e-16 - if(chem(i,k,j,p_p10).le.1.e-16)chem(i,k,j,p_p10)=1.e-16 - enddo - endif - -!ash settling end - - - - - enddo - enddo -END SUBROUTINE vashshort_settling_driver - - - subroutine vsettling(iprt,imx,jmx, lmx, nmx,g0,are, & - tc, tmp, p_mid, delz, airmas, & - den, reff, dt, bstl, rh, idust, iseas,iash) -! **************************************************************************** -! * * -! * Calculate the loss by settling, using an implicit method * -! * * -! * Input variables: * -! * SIGE(k) - sigma coordinate of the vertical edges * -! * PS(i,j) - Surface pressure (mb) * -! * TMP(i,j,k) - Air temperature (K) * -! * CT(i,j) - Surface exchange coeff for moisture -! * * -! **************************************************************************** - - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: imx, jmx, lmx, nmx,iseas,idust,iash - INTEGER :: ntdt - REAL, INTENT(IN) :: dt,g0,are ! ,dyn_visc - REAL*8, INTENT(IN) :: tmp(imx,jmx,lmx), delz(imx,jmx,lmx), & - airmas(imx,jmx,lmx), rh(imx,jmx,lmx), & - den(nmx), reff(nmx), p_mid(imx,jmx,lmx) - REAL*8, INTENT(INOUT) :: tc(imx,jmx,lmx,nmx) - REAL*8, INTENT(OUT) :: bstl(imx,jmx,nmx) - - REAL*8 :: tc1(imx,jmx,lmx,nmx), dt_settl(nmx), rcm(nmx), rho(nmx),addmass(lmx,nmx) - INTEGER :: ndt_settl(nmx) - REAL*8 :: dzmin, vsettl, dtmax, pres, rhb, rwet(nmx), ratio_r(nmx) - REAL*8 :: addmassf,c_stokes, free_path, c_cun, viscosity, vd_cor, growth_fac,mass_above - REAL, PARAMETER :: dyn_visc = 1.5E-5 - INTEGER :: iprt,k, n, i, j, l, l2 - ! for sea-salt: - REAL*8, PARAMETER :: c1=0.7674, c2=3.079, c3=2.573E-11, c4=-1.424 - - ! for OMP: - REAL*8 :: rwet_priv(nmx), rho_priv(nmx),vsettl_max(nmx) - - ! executable statements - -! IF (type) /= 'dust' .AND. TRIM(aero_type) /= 'sea_salt') RETURN - if(idust.ne.1.and.iseas.ne.1.and.iash.ne.1)return - - WHERE (tc(:,:,:,:) < 0.0) tc(:,:,:,:) = 1.0d-32 - - dzmin = MINVAL(delz(:,:,:)) - IF (idust == 1) growth_fac = 1.0 - IF (iseas == 1) growth_fac = 3.0 - IF (iash == 1) growth_fac = 1.0 - - DO k = 1,nmx - - ! Settling velocity (m/s) for each tracer (Stokes Law) - ! DEN density (kg/m3) - ! REFF effective radius (m) - ! dyn_visc dynamic viscosity (kg/m/s) - ! g0 gravity (m/s2) - ! 3.0 corresponds to a growth of a factor 3 of radius with 100% RH - ! 0.5 upper limit with temp correction - - tc1(:,:,:,k) = tc(:,:,:,k) - vsettl = 2.0/9.0 * g0 * den(k) * (growth_fac*reff(k))**2 / & - (0.5*dyn_visc) - vsettl_max(k)=vsettl - ! Determine the maximum time-step satisying the CFL condition: - ! dt <= (dz)_min / v_settl - ntdt=INT(dt) - dtmax = dzmin / vsettl - ndt_settl(k) = MAX( 1, INT( ntdt /dtmax) ) - ! limit maximum number of iterations -! IF (ndt_settl(k) > 12) ndt_settl(k) = 12 - IF (ndt_settl(k) > 12) then -! print *,g0,den(k),reff(k),growth_fac,dyn_visc - ndt_settl(k) = 12 - vsettl_max(k)=dzmin*ndt_settl(k)/dt -! print *,'k,vsettl,vs_max= ',k,vsettl,vsettl_max - endif - dt_settl(k) = REAL(ntdt) / REAL(ndt_settl(k)) - - ! Particles radius in centimeters - IF (iseas.eq.1)rcm(k) = reff(k)*100.0 -!srf IF (idust.eq.1)then - IF (idust.eq.1 .or. iash==1)then - rwet(k) = reff(k) - ratio_r(k) = 1.0 - rho(k) = den(k) - endif -! if(k.eq.7 .and. iprt.eq.1)then -! print *,vsettl,vsettl_max,ndt_settl(k) -! endif - END DO - - ! Solve the bidiagonal matrix (l,l) - -!$OMP PARALLEL DO & -!$OMP DEFAULT( SHARED ) & -!$OMP PRIVATE( i, j, l, l2, n, k, rhb, rwet_priv, ratio_r, c_stokes)& -!$OMP PRIVATE( free_path, c_cun, viscosity, rho_priv, vd_cor ) - - ! Loop over latitudes - DO j = 1,jmx - - DO k = 1,nmx - IF (idust.eq.1 .or. iash==1) THEN - rwet_priv(k) = rwet(k) - rho_priv(k) = rho(k) - END IF - - DO n = 1,ndt_settl(k) - - ! Solve each vertical layer successively (layer l) - - DO l = lmx,1,-1 - l2 = lmx - l + 1 - -! DO j = 1,jmx - DO i = 1,imx - - ! Dynamic viscosity - c_stokes = 1.458E-6 * tmp(i,j,l)**1.5/(tmp(i,j,l) + 110.4) - - ! Mean free path as a function of pressure (mb) and - ! temperature (K) - ! order of p_mid is top->sfc - free_path = 1.1E-3/p_mid(i,j,l2)/SQRT(tmp(i,j,l)) -!!! free_path = 1.1E-3/p_edge(i,j,l2)/SQRT(tmp(i,j,l)) - - ! Slip Correction Factor - c_cun = 1.0+ free_path/rwet_priv(k)* & - (1.257 + 0.4*EXP(-1.1*rwet_priv(k)/free_path)) - - ! Corrected dynamic viscosity (kg/m/s) - viscosity = c_stokes / c_cun - - ! Settling velocity -! IF (iseas.eq.1) THEN -! rho_priv(k) = ratio_r(k)*den(k) + (1.0 - ratio_r(k))*1000.0 -! END IF - - vd_cor = min(vsettl_max(k),2.0/9.0*g0*rho_priv(k)*rwet_priv(k)**2/viscosity) - - ! Update mixing ratio - ! Order of delz is top->sfc - IF (l == lmx) THEN - tc(i,j,l,k) = tc(i,j,l,k) / & - (1.0 + dt_settl(k)*vd_cor/delz(i,j,l2)) - ELSE - tc(i,j,l,k) = 1.0/(1.0+dt_settl(k)*vd_cor/delz(i,j,l2))& - *(tc(i,j,l,k) + dt_settl(k)*vd_cor /delz(i,j,l2-1) & - * tc(i,j,l+1,k)) - END IF - END DO !i -! END DO !j - END DO !l - - END DO !n - END DO !k - - END DO !j -!$OMP END PARALLEL DO - - DO n = 1,nmx - DO i = 1,imx - DO j = 1,jmx - DO l = 1,lmx - IF (tc(i,j,l,n) < 0.0) tc(i,j,l,n) = 1.0D-32 - addmass(l,n)=(tc(i,j,l,n) - tc1(i,j,l,n)) * airmas(i,j,l) - END DO -! make sure this is not more mass then what there was in the layer above - DO l = lmx-1,1 - mass_above=tc1(i,j,l+1,n)*airmas(i,j,l+1) - IF (addmass(l,n).gt.mass_above)then - tc(i,j,l,n)=mass_above/airmas(i,j,l) + tc1(i,j,l,n) - IF (tc(i,j,l,n) < 0.0) tc(i,j,l,n) = 1.0D-32 -! print *,'addmass',addmass(l,n),mass_above,tc(i,j,l,n),tc1(i,j,l,n) - addmass(l,n)=mass_above - endif - END DO - END DO - END DO - END DO - DO n = 1,nmx - DO i = 1,imx - DO j = 1,jmx - bstl(i,j,n) = 0.0 - addmassf=0. - DO l = 1,lmx - addmassf=addmassf+(tc(i,j,l,n) - tc1(i,j,l,n)) * airmas(i,j,l) -! IF (tc(i,j,l,n) < 0.0) tc(i,j,l,n) = 1.0D-32 - END DO - if(addmassf.gt.0.)addmassf=0 - bstl(i,j,n) = bstl(i,j,n) - addmassf - END DO - END DO - END DO - -END SUBROUTINE vsettling - -END MODULE MODULE_VASH_SETTLING diff --git a/src/fim/FIMsrc/fim/column_chem/module_vertmx_wrf.F90 b/src/fim/FIMsrc/fim/column_chem/module_vertmx_wrf.F90 deleted file mode 100644 index adb9569..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_vertmx_wrf.F90 +++ /dev/null @@ -1,201 +0,0 @@ -MODULE module_vertmx_wrf - -CONTAINS - -!----------------------------------------------------------------------- - SUBROUTINE vertmx( dt, phi, kt_turb, dryrho, & - zsigma, zsigma_half, vd, kts, ktem1 ) -! !! purpose - calculate change in time of phi due to vertical mixing -! !! and dry deposition (for 1 species, 1 vertical column, 1 time step) -! !! Mariusz Pagowski, March 2001 -! !! conventions used: -! !! input is lower case -! !! output is upper case -! -! !! modifications by R Easter, May 2006 -! !! added dryrho so this routine conserves column mass burde -! !! when dry deposition velocity is zero -! !! changed "kte" to "ktem1" for consistency with the kte in WRF -! -! ARGUMENTS -! -! dt = time step (s) -! phi = initial/final (at input/output) species mixing ratios at "T" points -! kt_turb = turbulent exchange coefficients (m^2/s) at "W" points -! dryrho = dry air density (kg/m^3) at "T" points -! zsigma = heights (m) at "W" points -! zsigma_half = heights (m) at "T" points -! vd = dry deposition velocity (m/s) -! kts, ktem1 = vertical indices of bottom and top "T" points -! - IMPLICIT NONE - -! .. Scalar Arguments .. - INTEGER, INTENT(IN) :: kts,ktem1 - REAL, INTENT(IN) :: dt, vd -! .. -! .. Array Arguments .. - REAL, INTENT(IN), DIMENSION (kts:ktem1+1) :: kt_turb, zsigma - REAL, INTENT(IN), DIMENSION (kts:ktem1) :: dryrho, zsigma_half - REAL, INTENT(INOUT), DIMENSION (kts:ktem1) :: phi -! .. -! .. Local Scalars .. - INTEGER :: k -! .. -! .. Local Arrays .. - REAL, DIMENSION (kts+1:ktem1) :: a_coeff - REAL, DIMENSION (kts:ktem1) :: b_coeff, lhs1, lhs2, lhs3, rhs -! .. -! .. External Subroutines .. -! EXTERNAL coeffs, rlhside, tridiag -! .. - CALL coeffs( kts, ktem1, dryrho, zsigma, zsigma_half, a_coeff, b_coeff ) - - CALL rlhside( kts, ktem1, kt_turb, dryrho, a_coeff, b_coeff, & - phi, dt, vd, rhs, lhs1, lhs2, lhs3 ) - - CALL tridiag( kts, ktem1, lhs1, lhs2, lhs3, rhs ) - - DO k = kts,ktem1 - phi(k) = rhs(k) - END DO - - END SUBROUTINE vertmx - - -!----------------------------------------------------------------------- - SUBROUTINE rlhside( kts, ktem1, k_turb, dryrho, a_coeff, b_coeff, & - phi, dt, vd, rhs, lhs1, lhs2, lhs3 ) - !! to calculate right and left hand sides in diffusion equation - !! for the tridiagonal solver - !! Mariusz Pagowski, March 2001 - !! conventions used: - !! input is lower case - !! output is upper case - IMPLICIT NONE - -! .. Scalar Arguments .. - INTEGER, INTENT(IN) :: kts,ktem1 - REAL, INTENT(IN) :: dt, vd -! .. -! .. Array Arguments .. - REAL, INTENT(IN), DIMENSION (kts:ktem1+1) :: k_turb - REAL, INTENT(IN), DIMENSION (kts+1:ktem1) :: a_coeff - REAL, INTENT(IN), DIMENSION (kts:ktem1) :: b_coeff, dryrho - REAL, INTENT(INOUT), DIMENSION (kts:ktem1) :: lhs1, lhs2, lhs3, phi, rhs -! .. -! .. Local Scalars .. - REAL :: a1, a2, alfa_explicit = .25, beta_implicit = .75 - INTEGER :: i - -! .. - i = kts - a2 = a_coeff(i+1)*k_turb(i+1) - rhs(i) = (1./(dt*b_coeff(i)) - alfa_explicit*(vd*dryrho(i)+a2))*phi(i) + & - alfa_explicit*(a2*phi(i+1)) - lhs1(i) = 0. - lhs2(i) = 1./(dt*b_coeff(i)) + beta_implicit*(vd*dryrho(i)+a2) - lhs3(i) = -beta_implicit*a2 - - DO i = kts+1, ktem1-1 - a1 = a_coeff(i)*k_turb(i) - a2 = a_coeff(i+1)*k_turb(i+1) - - rhs(i) = (1./(dt*b_coeff(i)) - alfa_explicit*(a1+a2))*phi(i) + & - alfa_explicit*(a1*phi(i-1) + a2*phi(i+1)) - - lhs1(i) = -beta_implicit*a1 - lhs2(i) = 1./(dt*b_coeff(i)) + beta_implicit*(a1+a2) - lhs3(i) = -beta_implicit*a2 - END DO - - i = ktem1 - a1 = a_coeff(i)*k_turb(i) - rhs(i) = (1./(dt*b_coeff(i)) - alfa_explicit*(a1 ))*phi(i) + & - alfa_explicit*(a1*phi(i-1)) - lhs1(i) = -beta_implicit*a1 - lhs2(i) = 1./(dt*b_coeff(i)) + beta_implicit*(a1 ) - lhs3(i) = 0. - - END SUBROUTINE rlhside - - -!----------------------------------------------------------------------- - SUBROUTINE tridiag( kts, ktem1, a, b, c, f ) - !! to solve system of linear eqs on tridiagonal matrix n times n - !! after Peaceman and Rachford, 1955 - !! a,b,c,F - are vectors of order n - !! a,b,c - are coefficients on the LHS - !! F - is initially RHS on the output becomes a solution vector - !! Mariusz Pagowski, March 2001 - !! conventions used: - !! input is lower case - !! output is upper case - IMPLICIT NONE - -! .. Scalar Arguments .. - INTEGER, INTENT(IN) :: kts,ktem1 -! .. -! .. Array Arguments .. - REAL, INTENT(IN), DIMENSION (kts:ktem1) :: a, b, c - REAL, INTENT(INOUT), DIMENSION (kts:ktem1) :: f -! .. -! .. Local Scalars .. - REAL :: p - INTEGER :: i -! .. -! .. Local Arrays .. - REAL, DIMENSION (kts:ktem1) :: q -! .. - q(kts) = -c(kts)/b(kts) - f(kts) = f(kts)/b(kts) - - DO i = kts+1, ktem1 - p = 1./(b(i)+a(i)*q(i-1)) - q(i) = -c(i)*p - f(i) = (f(i)-a(i)*f(i-1))*p - END DO - - DO i = ktem1 - 1, kts, -1 - f(i) = f(i) + q(i)*f(i+1) - END DO - - END SUBROUTINE tridiag - - -!----------------------------------------------------------------------- - SUBROUTINE coeffs( kts, ktem1, dryrho, & - z_sigma, z_sigma_half, a_coeff, b_coeff ) -! !! to calculate coefficients in diffusion equation -! !! Mariusz Pagowski, March 2001 -! !! conventions used: -! !! input is lower case -! !! output is upper case -! .. Scalar Arguments .. - IMPLICIT NONE - - INTEGER, INTENT(IN) :: kts,ktem1 -! .. -! .. Array Arguments .. - REAL, INTENT(IN), DIMENSION (kts:ktem1+1) :: z_sigma - REAL, INTENT(IN), DIMENSION (kts:ktem1) :: z_sigma_half, dryrho - REAL, INTENT(OUT), DIMENSION (kts+1:ktem1) :: a_coeff - REAL, INTENT(OUT), DIMENSION (kts:ktem1) :: b_coeff -! .. -! .. Local Scalars .. - INTEGER :: i - REAL :: dryrho_at_w -! .. - DO i = kts, ktem1 - b_coeff(i) = 1./(dryrho(i)*(z_sigma(i+1)-z_sigma(i))) - END DO - - DO i = kts+1, ktem1 - dryrho_at_w = 0.5*(dryrho(i)+dryrho(i-1)) - a_coeff(i) = dryrho_at_w/(z_sigma_half(i)-z_sigma_half(i-1)) - END DO - - END SUBROUTINE coeffs - -!----------------------------------------------------------------------- -END MODULE module_vertmx_wrf diff --git a/src/fim/FIMsrc/fim/column_chem/module_wetdep_ls.F90 b/src/fim/FIMsrc/fim/column_chem/module_wetdep_ls.F90 deleted file mode 100644 index cbce54c..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_wetdep_ls.F90 +++ /dev/null @@ -1,104 +0,0 @@ -MODULE module_wetdep_ls - USE module_initial_chem_namelists -CONTAINS -subroutine wetdep_ls(dt,var,rain,moist,rho,var_rmv,num_moist, & - num_chem,numgas,p_qc,dz8w,vvel,chem_opt, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - IMPLICIT NONE - - INTEGER, INTENT(IN ) :: num_chem,numgas,num_moist,p_qc, & - chem_opt,ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - real, INTENT(IN ) :: dt - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & - INTENT(IN ) :: moist - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: rho,dz8w,vvel - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ,1:num_chem), & - INTENT(INOUT) :: var - REAL, DIMENSION( jms:jme ), & - INTENT(IN ) :: rain - REAL, DIMENSION( ims:ime , jms:jme,num_chem ), & - INTENT(INOUT ) :: var_rmv - REAL, DIMENSION( its:ite , jts:jte ) :: var_sum - REAL, DIMENSION( its:ite , kts:kte, jts:jte ) :: var_rmvl - REAL, DIMENSION( its:ite , jts:jte ) :: frc,var_sum_clw,rain_clw - real :: dvar,factor,clsum,alpha,rho_water - integer :: nv,i,j,k,km,kb,kbeg - rho_water = 1000. - var_rmv (:,:,:)=0. -! write(6,*) 'in wetdepls, p_qc = ',p_qc -! nv=p_bc1 - do nv=1,num_chem - alpha = .5 ! scavenging factor - if(chem_opt >= 300 .and. chem_opt < 500)then - if(nv.le. numgas .and. nv.ne.p_sulf)cycle - if(nv.eq.p_bc1 .or. nv.eq.p_oc1 .or. nv.eq.p_dms)cycle - if(nv.eq.p_sulf .or. nv.eq.p_seas_1 .or. nv.eq.p_seas_2 .or. & - nv.eq.p_seas_3 .or. nv.eq.p_seas_4)alpha=1. - if(nv.eq.p_bc2 .or. nv.eq.p_oc2)alpha=0.8 - endif - do i=its,ite - do j=jts,jte - var_sum_clw(i,j)=0. - var_sum(i,j)=0. - var_rmvl(i,:,j)=0. - frc(i,j)=0. - rain_clw(i,j)=0. - if(rain(j).gt.1.e-6)then -! convert rain back to rate -! - rain_clw(i,j)=rain(j)/dt -! total cloud water -! - do k=1,kte-1 - dvar=max(0.,moist(i,k,j,p_qc)*rho(i,k,j)*vvel(i,k,j)*dz8w(i,k,j)) - var_sum_clw(i,j)=var_sum_clw(i,j)+dvar - var_sum(i,j)=var_sum(i,j)+var(i,k,j,nv)*rho(i,k,j) - enddo - if(var_sum(i,j).gt.1.e-8 .and. var_sum_clw(i,j).gt.1.e-6 ) then -! assuming that frc is onstant, it is my conversion factor -! (just like in convec. parameterization - frc(i,j)=rain_clw(i,j)/var_sum_clw(i,j) -! print *,'frc ', frc(i,j),var_sum_clw(i,j),var_sum(i,j) - frc(i,j)=max(1.e-6,min(frc(i,j),.5)) - endif - endif - enddo - enddo -! -! get rid of it -! - do i=its,ite - do j=jts,jte - if(rain(j).gt.1.e-6 .and. var_sum(i,j).gt.1.e-8 .and. var_sum_clw(i,j).gt.1.e-6)then - do k=kts,kte-2 - if(var(i,k,j,nv).gt.1.e-10 .and. moist(i,k,j,p_qc).gt.0.)then - factor = max(0.,frc(i,j)*rho(i,k,j)*dz8w(i,k,j)*vvel(i,k,j)) -! print *,'var before ',k,km,var(i,k,j,nv),factor -! dvar=.05*alpha*factor/(1+factor)*var(i,k,j,nv) - dvar=max(0.,.05*alpha*factor/(1+factor)*var(i,k,j,nv)) - dvar=min(dvar,var(i,k,j,nv)) - var_rmvl(i,k,j)=dvar - if((var(i,k,j,nv)-dvar).lt.1.e-12)then - dvar=var(i,k,j,nv)-1.e-12 - var(i,k,j,nv)=var(i,k,j,nv)-dvar - else - var(i,k,j,nv)=var(i,k,j,nv)-dvar - endif - var_rmv(i,j,nv)=var_rmv(i,j,nv)+var_rmvl(i,k,j) -! print *,'var after ',km,var(i,k,j,nv),dvar - endif - enddo -! var_rmv(i,j)=var_rmv(i,j)+var_rmvl(i,j) - endif - enddo - enddo - enddo -END SUBROUTINE WETDEP_LS -END MODULE module_wetdep_ls - - diff --git a/src/fim/FIMsrc/fim/column_chem/module_zero_plumegen_coms.F90 b/src/fim/FIMsrc/fim/column_chem/module_zero_plumegen_coms.F90 deleted file mode 100644 index 7399a35..0000000 --- a/src/fim/FIMsrc/fim/column_chem/module_zero_plumegen_coms.F90 +++ /dev/null @@ -1,60 +0,0 @@ -! -Module module_zero_plumegen_coms -implicit none -integer, parameter :: nkp = 200, ntime = 200 -! -real,dimension(nkp) :: w,t,qv,qc,qh,qi,sc, & ! blob - vth,vti,rho,txs, & - est,qsat,qpas,qtotal - -real,dimension(nkp) :: wc,wt,tt,qvt,qct,qht,qit,sct -real,dimension(nkp) :: dzm,dzt,zm,zt,vctr1,vctr2 & - ,vt3dc,vt3df,vt3dk,vt3dg,scr1 - -! -real,dimension(nkp) :: pke,the,thve,thee,pe,te,qvenv,rhe,dne,sce ! environment at plume grid -real,dimension(nkp) :: ucon,vcon,wcon,thtcon ,rvcon,picon,tmpcon,dncon,prcon & - ,zcon,zzcon,scon ! environment at RAMS grid - -! -real :: DZ,DQSDZ,VISC(nkp),VISCOSITY,TSTPF -integer :: N,NM1,L -! -real :: ADVW,ADVT,ADVV,ADVC,ADVH,ADVI,CVH(nkp),CVI(nkp),ADIABAT,& - WBAR,ALAST(10),VHREL,VIREL ! advection -! -real :: ZSURF,ZBASE,ZTOP -integer :: LBASE -! -real :: AREA,RSURF,ALPHA,RADIUS(nkp) ! entrain -! -real :: HEATING(ntime),FMOIST,BLOAD ! heating -! -real :: DT,TIME,TDUR -integer :: MINTIME,MDUR,MAXTIME -! - -real :: ztop_(ntime) - -contains -subroutine zero_plumegen_coms - -w=0.0;t=0.0;qv=0.0;qc=0.0;qh=0.0;qi=0.0;sc=0.0 -vth=0.0;vti=0.0;rho=0.0;txs=0.0 -est=0.0;qsat=0.0;qpas=0.0;qtotal=0.0 -wc=0.0;wt=0.0;tt=0.0;qvt=0.0;qct=0.0;qht=0.0;qit=0.0;sct=0.0 -dzm=0.0;dzt=0.0;zm=0.0;zt=0.0;vctr1=0.0;vctr2=0.0 -vt3dc=0.0;vt3df=0.0;vt3dk=0.0;vt3dg=0.0;scr1=0.0 -pke=0.0;the=0.0;thve=0.0;thee=0.0;pe=0.0;te=0.0;qvenv=0.0;rhe=0.0;dne=0.0;sce=0.0 -ucon=0.0;vcon=0.0;wcon=0.0;thtcon =0.0;rvcon=0.0;picon=0.0;tmpcon=0.0;dncon=0.0;prcon=0.0 -zcon=0.0;zzcon=0.0;scon=0.0 -dz=0.0;dqsdz=0.0;visc=0.0;viscosity=0.0;tstpf=0.0 -advw=0.0;advt=0.0;advv=0.0;advc=0.0;advh=0.0;advi=0.0;cvh=0.0;cvi=0.0;adiabat=0.0 -wbar=0.0;alast=0.0;vhrel=0.0;virel=0.0 -zsurf=0.0;zbase=0.0;ztop=0.0;area=0.0;rsurf=0.0;alpha=0.0;radius=0.0;heating=0.0 -fmoist=0.0;bload=0.0;dt=0.0;time=0.0;tdur=0.0 -ztop_=0.0 - -n=0;nm1=0;l=0;lbase=0;mintime=0;mdur=0;maxtime=0 -end subroutine zero_plumegen_coms -End Module diff --git a/src/fim/FIMsrc/fim/framework/README b/src/fim/FIMsrc/fim/framework/README deleted file mode 100644 index c627438..0000000 --- a/src/fim/FIMsrc/fim/framework/README +++ /dev/null @@ -1,17 +0,0 @@ - -Subdirectories for ESMF componentization: - -ncep_share NCEP NEMS ATM component and top-level bits of DYN and PHYS - components. FIM components re-use much of this code. For now, - include entire code. Later, use svn "externals definitions" to - replace this directory with a link to the NCEP repository. That - is provided we can solve security policy issues and drill a "safe" - hole in the firewall protecting the NCEP repository. John - Schneider is not completely pessimistic about an eventual - policy solution... - -components FIM-specific component code. This re-uses as much of ncep_share - as is practical. - -doc Related documents. - diff --git a/src/fim/FIMsrc/fim/framework/doc/FIM_DYN_PHY_States.txt b/src/fim/FIMsrc/fim/framework/doc/FIM_DYN_PHY_States.txt deleted file mode 100644 index 054edb0..0000000 --- a/src/fim/FIMsrc/fim/framework/doc/FIM_DYN_PHY_States.txt +++ /dev/null @@ -1,77 +0,0 @@ - -List of Fields to be Exchanged Between FIM "DYN" and "PHY" Components - - :PHYSICS: :PHYSICS: -ACTUAL : DUMMY : OWNER :INTENT : TYPE : NAME ---------------+-------+-------+-------+-------------------+------------------------------------------------- -its : : ATM : IN : INTEGER : Time step -ndpv : : ATM? : INOUT : INTEGER : diagnostics -us3d : : DYN : INOUT : REAL(nvl,nip) : west wind (m/s), layer -vs3d : : DYN : INOUT : REAL(nvl,nip) : south wind (m/s), layer -ws3d : : DYN : IN : REAL(nvl,nip) : vertical wind (m/s), layer -dp3d : : DYN : IN : REAL(nvl,nip) : del p between coord levels (pascals) -pr3d : : DYN : IN : REAL(nvlp1,nip) : pressure (pascals), level -mp3d : : DYN :NOTUSED: REAL(nvl,nip) : Montgomery Potential (m**2/s**2) -tr3d : tr : DYN : INOUT : REAL(nvl,nip,ntr) : tracers, 1=theta, 2=qv, 3=qw, 4=O3 -ex3d : : DYN :NOTUSED: REAL(nvlp1,nip) : exner funciton, level -qs3d : : PHY :NOTUSED: REAL(nvl,nip) : saturated humidity -rh3d : : DYN :NOTUSED: REAL(nvl,nip) : relative humidity from 0 to 1 -ph3d : : DYN : IN : REAL(nvlp1,nip) : phi (=gz), m**2/s**2 -trdp : : DYN : OUT : REAL(nvl,nip,ntr) : (tracer times dp3d ) for tracer transport eq. -st3d : : PHY : INOUT : REAL(4,nip) : soil temperature -sm3d : : PHY : INOUT : REAL(4,nip) : soil moisture -ts2d : : PHY : INOUT : REAL(nip) : skin temperature -us2d : : PHY : INOUT : REAL(nip) : friction velocity/equivalent momentum flux -hf2d : : PHY : INOUT : REAL(nip) : sensible heat flux -qf2d : : PHY : INOUT : REAL(nip) : water vapor/equivalent latent heat flux -ssus : : PHY : OUT : REAL(nvl,nip) : source/sink for u eqn -ssvs : : PHY : OUT : REAL(nvl,nip) : source/sink for v eqn -ssdp : : PHY : OUT : REAL(nvl,nip) : source/sink for dp eqn -ssth : : PHY : OUT : REAL(nvl,nip) : source/sink for theta eqn -ssqv : : PHY : OUT : REAL(nvl,nip) : source/sink for qv eqn -ssqw : : PHY : OUT : REAL(nvl,nip) : source/sink for qw eqn (UNUSED) -rn2d : : PHY : OUT : REAL(nip) : accumulated total precipitation/rainfall -rc2d : : PHY : OUT : REAL(nip) : accumulated convective precipitation/rainfall -pw2d : : DYN : OUT : REAL(nip) : precipitable water -sw2d : : PHY : OUT : REAL(nip) : downward short-wave radiation flux -lw2d : : PHY : OUT : REAL(nip) : downward long-wave radiation flux -CallPhysics : : ATM? : IN : INTEGER : physics time-step interval -CallRadiation : : ATM? : IN : INTEGER : radiation time-step interval -qmstr : : PHY : INOUT : REAL(14*24*numphr): diagnostics -qmstd : : PHY : INOUT : REAL(14*24*numphr): diagnostics - - - -List of a few Fields *PRIVATE* to "DYN" Component - -ACTUAL : DUMMY : OWNER :INTENT : TYPE : NAME ---------------+-------+-------+-------+-------------------+------------------------------------------------- -vor : : DYN : : REAL(nvl,nip) : relative vorticity (s^-1) - - -List of a few Fields *PRIVATE* to "PHY" Component - -ACTUAL : DUMMY : OWNER :INTENT : TYPE : NAME ---------------+-------+-------+-------+-------------------+------------------------------------------------- - - -NOTES: - -rh3d: Passed in to physics() but not accessed. -mp3d: Passed in to physics() but not accessed. -tk3d: Not used anywhere *yet*! Set only in output(). -qs3d: Not used anywhere *yet*! Not set anywhere either! -ph3d: Only ph3d(1,:) are communicated between components. All levels are -read in init(), levels ph3d(2:nvl,:) are overwritten. These levels are -overwritten again in diag(). -init.F90 - ph3d(ivl,ipn)=ph3d(ivl-1,ipn)-tr(ivl,ipn,1)*(ex3d(ivl,ipn)& - -ex3d(ivl-1,ipn)) -diag.F90 - ph3d(ivl,ipn)=ph3d(ivl-1,ipn)-tr(ivl,ipn,1)*(ex3d(ivl,ipn)& - -ex3d(ivl-1,ipn)) - -tr3d: Jin says this belongs to DYN. -trdp: Jin says this belongs to DYN. - - diff --git a/src/fim/FIMsrc/fim/framework/doc/FIM_Plans.txt b/src/fim/FIMsrc/fim/framework/doc/FIM_Plans.txt deleted file mode 100644 index da03f3c..0000000 --- a/src/fim/FIMsrc/fim/framework/doc/FIM_Plans.txt +++ /dev/null @@ -1,100 +0,0 @@ - -Plans for FIM-related Work - - -ESMF - Separate output from computation - Remove computation of rh3d and tk3d from output() - Define DYN and PHY components - INIT - Trivial at present - RUN - Figure out how best to adapt to NCEP event loop - NCEP event loop: - WRT (first time only) - DYN - CPL DYN->PHY - PHY - CPL PHY->DYN - WRT - Current FIM event loop: - WRT (first time only) - DYN - CPL DYN->PHY - PHY - CPL PHY->DYN - WRT - One-phase DYN is required - Decide how to re-arrange FIM event loop to match NCEP event loop - Decide how to use ESMF Time Manager, Alarms, etc. - FINAL - Trivial at present - Define Import and Export states - DYN -> PHY - Import - Export - PHY -> DYN - Import - Export - Design, code, and test DYN and PHY components without ESMF - Design, code, and test DYN and PHY components with ESMF - - -I/O - Support additional file formats - NetCDF - Parallel NetCDF - HDF5 - PHDF5 - grib1 - grib2 - Support output cache tasks ("quilt" output in NCEP parlance) - Investigate re-use of other ESMF I/O components - Other possible features - Support additional file modes - One file per MPI task on write - Requires automatic re-assembler like AM2 - Flexible run-time specification (like CAM) - - -CF - Add metadata to support CF conventions - Add to Import and Export states for use by I/O components - Test using Rosalyn Hatcher's CF checker - Support short and long names and XLAT-XLONG a la WRF - Full support may require use of Balaji's grid description ideas in CF - - -Unit Testing - Use Fruit? - Use AutoTest? - Make it work more reliably - Extend test-oracle definition (use yaml?) - - -Tools? - Subversion? - GForge? - Wiki? - Bug Tracker? - - -Performance - Characterize imbalance - Measure current imbalance - Predict future imbalance - Predict benefits of various load balancing schemes - Candidate schemes include - Load balancing via multiple regions per MPI task - Pairs of regions on opposite sides of globe (as in CWB GFS) - Pairs of regions in temperate vs. tropical/polar regions (as in - CWB GFS) - - -Minor fixes - Update comment in physics in dp3d declaration - Remove literal constants from calls - Get rid of array sections of 4D arrays passed into profout() - - - diff --git a/src/fim/FIMsrc/fim/framework/doc/FIM_Questions.txt b/src/fim/FIMsrc/fim/framework/doc/FIM_Questions.txt deleted file mode 100644 index a158867..0000000 --- a/src/fim/FIMsrc/fim/framework/doc/FIM_Questions.txt +++ /dev/null @@ -1,11 +0,0 @@ - -FIM Questions - - Why use real*4 and real*8 instead of real(sp) and real(dp)? - - Why are hybgen and pi2dp caled twice each time-step? - Answer: Disagreement between Jin and Rainer. The first set of calls - has been removed in the latest version. - - - diff --git a/src/fim/FIMsrc/fim/framework/nems/ENS_CplComp_ESMFMod_STUB.f90 b/src/fim/FIMsrc/fim/framework/nems/ENS_CplComp_ESMFMod_STUB.f90 deleted file mode 100644 index aa16c41..0000000 --- a/src/fim/FIMsrc/fim/framework/nems/ENS_CplComp_ESMFMod_STUB.f90 +++ /dev/null @@ -1,222 +0,0 @@ -!TBH: Matches r14147 of https://svnemc.ncep.noaa.gov/projects/nems/trunk/ -!TBH: except for change in the path to ESMFVersionDefine.h. - -#include "./ESMFVersionDefine.h" - -!---------------------------------------------------------------------- -! !MODULE: ENS_CplComp_ESMFMod -! --- ESMF coupler gridded component of the EARTH Ensemble -! Forecast Operational system. -! -! !DESCRIPTION: EARTH coupler gridded component main module. -! -! !REVISION HISTORY: -! -! April 2006 Weiyu Yang Initial code. -! -! -! March 2007 Dingchen Hou added Stochatic Perturbation Combination Coefficient array. -! January to November 2007 Dingchen and Weiyu Yang -! Added Broadcasting procedure and Global variables/arrays -! November 2007 Dingchen, added minimum documentation, mainly for the arrays added during 2007 -! March 2009 Weiyu yang, modified for the NEMS model. -! May 2011 Weiyu Yang modified for using the ESMF 5.2.0r_beta_snapshot_07. - -! !INTERFACE: -! - MODULE ENS_CplComp_ESMFMod - -!!USES: -!------ - -! Define the ESMF internal state and all routines related to run -! the EARTH ensemble coupler grid component. -!--------------------------------------------------------------- -!dusan USE ENS_Cpl_ESMFMod - USE ESMF_MOD - - IMPLICIT none - - PRIVATE ! By default data is private to this module -! -! !PUBLIC TYPES: -!--------------- - - PUBLIC ENS_CplCompSetServices - -!EOP -!------------------------------------------------------------------------- - - - CONTAINS - - -!---------------------------------------------------------------------- -!BOP -! -! !ROUTINE: ENS_CplCompSetServices --- Set services for EARTH Ensemble -! Coupler Gridded Component. -! -! !INTERFACE: -! - SUBROUTINE ENS_CplCompSetServices(CplENS, rc) - -! !ARGUMENTS: -!------------ - - TYPE(ESMF_CplComp) :: CplENS ! gridded component - INTEGER, INTENT(out) :: rc ! return code - -! !DESCRIPTION: Set services (register) for the EARTH Ensemble Coupler -! Grid Component. -! -!EOP -!---------------------------------------------------------------------- - - INTEGER :: rc1 = ESMF_SUCCESS - rc = ESMF_SUCCESS - -! REGISTER SERVICES FOR THIS COMPONENT -! ------------------------------------ - -#ifdef ESMF_3 - CALL ESMF_CplCompSetEntryPoint (CplENS, ESMF_SETINIT, Cpl_Initialize, & - ESMF_SINGLEPHASE, rc1) - - CALL ESMF_CplCompSetEntryPoint (CplENS, ESMF_SETRUN, Cpl_Run, & - ESMF_SINGLEPHASE, rc1) - - CALL ESMF_CplCompSetEntryPoint (CplENS, ESMF_SETFINAL, Cpl_Finalize, & - ESMF_SINGLEPHASE, rc1) -#else - CALL ESMF_CplCompSetEntryPoint (CplENS, ESMF_SETINIT, Cpl_Initialize, & - phase=ESMF_SINGLEPHASE, rc=rc1) - - CALL ESMF_CplCompSetEntryPoint (CplENS, ESMF_SETRUN, Cpl_Run, & - phase=ESMF_SINGLEPHASE, rc=rc1) - - CALL ESMF_CplCompSetEntryPoint (CplENS, ESMF_SETFINAL, Cpl_Finalize, & - phase=ESMF_SINGLEPHASE, rc=rc1) -#endif - - END SUBROUTINE ENS_CplCompSetServices - - - - - -!---------------------------------------------------------------------- -!BOP -! !ROUTINE: Cpl_Initialize --- initialize routine to initialize -! and set up the EARTH ensemble coupler. -! -! !DESCRIPTION: This subroutine initializes the EARTH ensemble coupler -! before the main running routine. -! -! -! !REVISION HISTORY: -! -! April 2006 Weiyu Yang Initial code. -! -! !INTERFACE: -! - - SUBROUTINE Cpl_Initialize(CplENS, impENS, expENS, clock, rcfinal) - -! -! !INPUT/OUTPUT VARIABLES AND PARAMETERS: -!---------------------------------------- - - TYPE(ESMF_CplComp) :: CplENS - TYPE(ESMF_State) :: impENS - TYPE(ESMF_State) :: expENS - TYPE(ESMF_Clock) :: clock - -! -! !OUTPUT VARIABLES AND PARAMETERS: -!---------------------------------- - - INTEGER, INTENT(out) :: rcfinal - -! !EOP -!------------------------------------------------------------------------- - - END SUBROUTINE Cpl_Initialize - - - - - -!---------------------------------------------------------------------- -!BOP -! -! !ROUTINE: Cpl_Run --- Main grid component routine to run the EARTH -! ensemble coupler. -! -! !DESCRIPTION: This subroutine will run the most part computations -! of the EARTH ensemble coupler. -! -! !REVISION HISTORY: -! -! April 2006 Weiyu Yang Initial code. -! -! !INTERFACE: -! - - SUBROUTINE Cpl_Run(CplENS, impENS, expENS, clock, rcfinal) - -! -! !INPUT VARIABLES AND PARAMETERS: -!--------------------------------- - TYPE(ESMF_CplComp) :: CplENS - TYPE(ESMF_State) :: impENS - -! !OUTPUT VARIABLES AND PARAMETERS: -!---------------------------------- - TYPE(ESMF_Clock) :: clock - TYPE(ESMF_State) :: expENS - INTEGER, INTENT(out) :: rcfinal -! -!EOP -!------------------------------------------------------------------------- - -! - END SUBROUTINE Cpl_Run - - - - - -!---------------------------------------------------------------------- -!BOP -! -! !ROUTINE: Cpl_Finalize --- finalizing routine to finish the -! EARTH ensemble coupler. -! -! !DESCRIPTION: This subroutine will finish the EARTH ensemble coupler -! ! and will release the memory space. -! -! !REVISION HISTORY: -! -! April 2006 Weiyu Yang Initial code. -! -! !INTERFACE: - - SUBROUTINE Cpl_Finalize(CplENS, impENS, expENS, clock, rcfinal) - -! -! !INPUT VARIABLES AND PARAMETERS: -!--------------------------------- - TYPE(ESMF_CplComp) :: CplENS - TYPE(ESMF_State) :: impENS - TYPE(ESMF_State) :: expENS - TYPE(ESMF_Clock) :: clock - -! !OUTPUT VARIABLES AND PARAMETERS: -!---------------------------------- - INTEGER, INTENT(out) :: rcfinal - - - END SUBROUTINE Cpl_Finalize - - END MODULE ENS_CplComp_ESMFMod diff --git a/src/fim/FIMsrc/fim/framework/nems/ESMFVersionDefine.h b/src/fim/FIMsrc/fim/framework/nems/ESMFVersionDefine.h deleted file mode 100644 index 1f392f9..0000000 --- a/src/fim/FIMsrc/fim/framework/nems/ESMFVersionDefine.h +++ /dev/null @@ -1,17 +0,0 @@ -#if 0 ->> ->> Make this header file available as ESMFVersionDefine.h in order to build ->> NEMS against an ESMF 3 installation. ->> -#endif - -#define ESMF_3 - -#ifndef ESMF_MAJOR_VERSION -#define ESMF_MAJOR_VERSION 3 -#define ESMF_MINOR_VERSION 1 -#define ESMF_REVISION 0 -#define ESMF_PATCHLEVEL 4 -#endif - -#include "./ESMFVersionLogic.h" diff --git a/src/fim/FIMsrc/fim/framework/nems/ESMFVersionDefine_ESMF_3.h b/src/fim/FIMsrc/fim/framework/nems/ESMFVersionDefine_ESMF_3.h deleted file mode 100644 index 1f392f9..0000000 --- a/src/fim/FIMsrc/fim/framework/nems/ESMFVersionDefine_ESMF_3.h +++ /dev/null @@ -1,17 +0,0 @@ -#if 0 ->> ->> Make this header file available as ESMFVersionDefine.h in order to build ->> NEMS against an ESMF 3 installation. ->> -#endif - -#define ESMF_3 - -#ifndef ESMF_MAJOR_VERSION -#define ESMF_MAJOR_VERSION 3 -#define ESMF_MINOR_VERSION 1 -#define ESMF_REVISION 0 -#define ESMF_PATCHLEVEL 4 -#endif - -#include "./ESMFVersionLogic.h" diff --git a/src/fim/FIMsrc/fim/framework/nems/ESMFVersionDefine_ESMF_4.h b/src/fim/FIMsrc/fim/framework/nems/ESMFVersionDefine_ESMF_4.h deleted file mode 100644 index 3d4ae56..0000000 --- a/src/fim/FIMsrc/fim/framework/nems/ESMFVersionDefine_ESMF_4.h +++ /dev/null @@ -1,17 +0,0 @@ -#if 0 ->> ->> Make this header file available as ESMFVersionDefine.h in order to build ->> NEMS against an ESMF 4_0_0rp2 installation. ->> -#endif - -#undef ESMF_3 - -#ifndef ESMF_MAJOR_VERSION -#define ESMF_MAJOR_VERSION 4 -#define ESMF_MINOR_VERSION 0 -#define ESMF_REVISION 0 -#define ESMF_PATCHLEVEL 2 -#endif - -#include "./ESMFVersionLogic.h" diff --git a/src/fim/FIMsrc/fim/framework/nems/ESMFVersionDefine_ESMF_5.h b/src/fim/FIMsrc/fim/framework/nems/ESMFVersionDefine_ESMF_5.h deleted file mode 100644 index 84ad9a7..0000000 --- a/src/fim/FIMsrc/fim/framework/nems/ESMFVersionDefine_ESMF_5.h +++ /dev/null @@ -1,17 +0,0 @@ -#if 0 ->> ->> Make this header file available as ESMFVersionDefine.h in order to build ->> NEMS against an ESMF 5_1_0 installation. ->> -#endif - -#undef ESMF_3 - -#ifndef ESMF_MAJOR_VERSION -#define ESMF_MAJOR_VERSION 5 -#define ESMF_MINOR_VERSION 1 -#define ESMF_REVISION 0 -#define ESMF_PATCHLEVEL 0 -#endif - -#include "./ESMFVersionLogic.h" diff --git a/src/fim/FIMsrc/fim/framework/nems/ESMFVersionDefine_ESMF_520rbs.h b/src/fim/FIMsrc/fim/framework/nems/ESMFVersionDefine_ESMF_520rbs.h deleted file mode 100644 index 28f54d0..0000000 --- a/src/fim/FIMsrc/fim/framework/nems/ESMFVersionDefine_ESMF_520rbs.h +++ /dev/null @@ -1,17 +0,0 @@ -#if 0 ->> ->> Make this header file available as ESMFVersionDefine.h in order to build ->> NEMS against an ESMF 5_2_0r_beta_snapshot installation. ->> -#endif - -#undef ESMF_3 - -#ifndef ESMF_MAJOR_VERSION -#define ESMF_MAJOR_VERSION 5 -#define ESMF_MINOR_VERSION 2 -#define ESMF_REVISION 0 -#define ESMF_PATCHLEVEL 0 -#endif - -#include "./ESMFVersionLogic.h" diff --git a/src/fim/FIMsrc/fim/framework/nems/ESMFVersionLogic.h b/src/fim/FIMsrc/fim/framework/nems/ESMFVersionLogic.h deleted file mode 100644 index 0770310..0000000 --- a/src/fim/FIMsrc/fim/framework/nems/ESMFVersionLogic.h +++ /dev/null @@ -1,25 +0,0 @@ -#if (ESMF_MAJOR_VERSION < 5 || ESMF_MINOR_VERSION < 2) - -#define esmf_logfounderror esmf_logmsgfounderror -#define ESMF_LogFoundError ESMF_LogMsgFoundError -#define ESMF_LogFoundAllocError ESMF_LogMsgFoundAllocError - -#define STATENAME stateName -#define FIELDNAME name -#define FIELDNAMELIST nameList -#define FIELDCOUNT nameCount -#define DSTPET dst -#define SRCPET src -#define FARRAYPTR fptr - -#else - -#define STATENAME name -#define FIELDNAME fieldName -#define FIELDNAMELIST fieldNameList -#define FIELDCOUNT fieldCount -#define DSTPET dstPet -#define SRCPET srcPet -#define FARRAYPTR farrayPtr - -#endif diff --git a/src/fim/FIMsrc/fim/framework/nems/MAIN_NEMS.F90 b/src/fim/FIMsrc/fim/framework/nems/MAIN_NEMS.F90 deleted file mode 100644 index c095b90..0000000 --- a/src/fim/FIMsrc/fim/framework/nems/MAIN_NEMS.F90 +++ /dev/null @@ -1,678 +0,0 @@ -!TBH: Matches r14147 of https://svnemc.ncep.noaa.gov/projects/nems/trunk/. - -#include "./ESMFVersionDefine.h" - -#if (ESMF_MAJOR_VERSION < 5 || ESMF_MINOR_VERSION < 2) -#undef ESMF_520rbs -#else -#define ESMF_520rbs -#endif - -!----------------------------------------------------------------------- -! - PROGRAM MAIN_NEMS -! -!----------------------------------------------------------------------- -!*** Main Program for NEMS. -!*** Define ESMF data types and procedures. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! -! PROGRAM HISTORY LOG: -! 2007- Black - Modified from Wei-yu's version -! 2007-09 Black - Create the Clock here. -! 2009-08 Colon - Unified NEM-NMM & NEMS-GFS -! 2009-06-29 Black - Modified for addition of NMM nesting; -! added new ATM Driver Component. -! 2009-09 Lu - Add w3tage calls for resource statistics -! 2009-08 W. Yang - Ensemble GEFS Concurrency Code. -! 2010-03 Jovic/Black - Revised to create NEMS gridded component -! for new structure. -! 2010-04 Yang - Add GEFS and GFS for the revised NEMS. -! 2010-11 Yang - Add the "Generic Core" in the NEMS. -! 2011-02 Yang - Updated to use both the ESMF 4.0.0rp2 library, -! ESMF 5 series library and the the -! ESMF 3.1.0rp2 library. -! 2011-05 Theurich & Yang - Modified for using the ESMF 5.2.0r_beta_snapshot_07. -! -!----------------------------------------------------------------------- -! - USE ESMF_Mod -! -!----------------------------------------------------------------------- -!*** USE the NEMS gridded component module. Although it -!*** contains the calls to Register and the top level Initialize, -!*** Run, and Finalize, only the Register routine is public. -!----------------------------------------------------------------------- -! - USE module_NEMS_GRID_COMP, ONLY: NEMS_REGISTER -! -!----------------------------------------------------------------------- -!*** The following module contains error-checking. -!----------------------------------------------------------------------- -! - USE module_ERR_MSG,ONLY: ERR_MSG,MESSAGE_CHECK -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -!*** Local Variables. -!----------------------------------------------------------------------- -! - INTEGER :: MYPE & !<-- The MPI task ID - ,NHOURS_FCST & !<-- Length of forecast in hours - ,NSECONDS_FCST & !<-- Length of forecast in seconds - ,TIMESTEP_SEC_WHOLE & !<-- Integer part of timestep - ,TIMESTEP_SEC_NUMERATOR & !<-- Numerator of fractional part - ,TIMESTEP_SEC_DENOMINATOR & !<-- Denominator of fractional part - ,YY,MM,DD & !<-- Time variables for date - ,HH,MNS,SEC !<-- Time variables for time of day -! - TYPE(ESMF_TimeInterval) :: RUNDURATION & !<-- The ESMF time. The total forecast hours. - ,TIMESTEP !<-- The ESMF timestep length (we only need a dummy here) -! - TYPE(ESMF_Time) :: CURRTIME & !<-- The ESMF current time. - ,STARTTIME !<-- The ESMF start time. -! - TYPE(ESMF_VM) :: VM !<-- The ESMF virtual machine, - ! which contains and manages - ! the computer CPU resource - ! for the ESMF grid components. -! - TYPE(ESMF_GridComp) :: NEMS_GRID_COMP !<-- The NEMS gridded component. -! - TYPE(ESMF_State) :: NEMS_EXP_STATE & !<-- The NEMS export state - ,NEMS_IMP_STATE !<-- The NEMS import state -! - TYPE(ESMF_Clock) :: CLOCK_MAIN !<-- The ESMF time management clock -! - TYPE(ESMF_Config) :: CF_MAIN !<-- The Configure object -! - LOGICAL :: RUN_CONTINUE !<-- Flag for more than one NEMS run. -! - INTEGER :: HH_START & - ,HH_FINAL -! - INTEGER :: RC=ESMF_SUCCESS & !<-- The running error signal - ,RC_MAIN !<-- The final value of the Main error code -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -#ifdef IBM - include 'fexcp.h' - call signal(11, xl__trce) -#endif -! -!----------------------------------------------------------------------- -!! -!----------------------------------------------------------------------- -!*** Initialize the final error signal. -!----------------------------------------------------------------------- -! - RC_MAIN=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** Initialize the ESMF framework. -!----------------------------------------------------------------------- -! - CALL ESMF_Initialize(VM =VM & !<-- The ESMF Virtual Machine - ,defaultCalendar=ESMF_CAL_GREGORIAN & !<-- Set up the default calendar. - ,defaultlogtype =ESMF_LOG_MULTI & !<-- Define multiple log error output file; - ! each task has its own log error output file. - ,rc =RC) -! -!----------------------------------------------------------------------- -!*** Extract the MPI task ID. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="MAIN: Obtain the local task ID" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_VmGet(vm =VM & !<-- The ESMF Virtual Machine - ,localpet=MYPE & !<-- The local MPI task ID - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_MAIN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -#if defined (SVN_INFO) && defined (CMP_YEAR) && defined (CMP_JD) - if (mype==0) call w3tagb('NEMS '//SVN_INFO & - ,CMP_YEAR, CMP_JD, 0000, 'NEMS') -#else - if (mype==0) call w3tagb('nems ',0000,0000,0000,'np23 ') -#endif -! -!----------------------------------------------------------------------- -!*** Set up the default log. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Up ESMF Log" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -#ifdef ESMF_3 - CALL ESMF_LogSet(verbose =ESMF_TRUE & - ,flush =ESMF_TRUE & - ,rootOnly =ESMF_FALSE & - ,halt =ESMF_LOG_HALTNEVER & !<-- The job will not stop automatically - ! when an ESMF error occurs. - ,maxElements=1 & !<-- Maximum number of elements in the log - ! before printing them to the log file. - ,rc =RC) -#else - CALL ESMF_LogSet(verbose =.true. & - ,flush =.true. & - ,rootOnly =.false. & - ,halt =ESMF_LOG_HALTNEVER & !<-- The job will not stop automatically - ! when an ESMF error occurs. - ,maxElements=1 & !<-- Maximum number of elements in the log - ! before printing them to the log file. - ,rc =RC) -#endif - -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_MAIN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Create and load the Configure object which will hold the contents -!*** of the Main configure file. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create/Load the Main Configure Object" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CF_MAIN=ESMF_ConfigCreate(rc=RC) -! - CALL ESMF_ConfigLoadFile(config =CF_MAIN & !<-- The Configure object - ,filename='model_configure' & !<-- The name of the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_MAIN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Create the NEMS gridded component which will create and -!*** control the ATM (atmosphere), OCN (ocean), ICE (sea ice), etc. -!*** gridded components. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create the NEMS Gridded Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NEMS_GRID_COMP=ESMF_GridCompCreate(name ='NEMS Grid Comp' & !<-- NEMS component name - ,configFile ='model_configure' & !<-- Link the user-created configure file. - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_MAIN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Register the NEMS gridded component's Initialize, Run and -!*** Finalize routines. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Register NEMS Gridded Component Init, Run, Finalize" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -#ifdef ESMF_3 - CALL ESMF_GridCompSetServices(NEMS_GRID_COMP & !<-- The NEMS component - ,NEMS_REGISTER & !<-- User's subroutineName - ,RC) -#else - CALL ESMF_GridCompSetServices(NEMS_GRID_COMP & !<-- The NEMS component - ,NEMS_REGISTER & !<-- User's subroutineName - ,rc=RC) -#endif -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_MAIN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Create the main ESMF Clock. -!*** The Clock is needed for all calls to Init, Run, and Finalize. -! -!*** A timestep is needed to create the Clock but actual timesteps -!*** are handled by the individual subcomponents therefore a dummy -!*** value is used here. -!----------------------------------------------------------------------- -! - TIMESTEP_SEC_WHOLE =1 !<-- Dummy timestep values - TIMESTEP_SEC_NUMERATOR =0 ! - TIMESTEP_SEC_DENOMINATOR=1 !<-- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set up Time Step Interval in Main Clock" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeIntervalSet(timeinterval=TIMESTEP & !<-- Main Clock's timestep - ,s =TIMESTEP_SEC_WHOLE & !<-- Whole part of timestep - ,sn =TIMESTEP_SEC_NUMERATOR & !<-- Numerator of fractional part - ,sd =TIMESTEP_SEC_DENOMINATOR & !<-- Denominator of fractional part - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_MAIN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Set the start time in the Main Clock. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="MAIN: Extract Starting Year from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF_MAIN & - ,value =YY & - ,label ='start_year:' & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_MAIN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="MAIN: Extract Starting Month from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF_MAIN & - ,value =MM & - ,label ='start_month:' & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_MAIN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="MAIN: Extract Starting Day from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF_MAIN & - ,value =DD & - ,label ='start_day:' & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_MAIN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="MAIN: Extract Starting Hour from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF_MAIN & - ,value =HH & - ,label ='start_hour:' & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_MAIN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="MAIN: Extract Starting Minute from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF_MAIN & - ,value =MNS & - ,label ='start_minute:' & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_MAIN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="MAIN: Extract Starting Second from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF_MAIN & - ,value =SEC & - ,label ='start_second:' & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_MAIN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="MAIN: Set the Forecast Start Time" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeSet(time=STARTTIME & !<-- The start time of the forecast (ESMF) - ,yy =YY & !<-- Year from config file - ,mm =MM & !<-- Month from config file - ,dd =DD & !<-- Day from config file - ,h =HH & !<-- Hour from config file - ,m =MNS & !<-- Minute from config file - ,s =SEC & !<-- Second from config file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_MAIN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Set the run duration in the Main Clock. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="MAIN: Extract Forecast Length from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF_MAIN & - ,value =NHOURS_FCST & - ,label ='nhours_fcst:' & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_MAIN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NSECONDS_FCST=NHOURS_FCST*3600 !<-- The forecast length (sec) (REAL) -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="MAIN: Set the Forecast Length" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeIntervalSet(timeinterval=RUNDURATION & !<-- The forecast length (s) (ESMF) - ,s =NSECONDS_FCST & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_MAIN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Now the Main Clock can be created. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create the Main Clock" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CLOCK_MAIN=ESMF_ClockCreate(name ='CLOCK_MAIN' & !<-- The top-level ESMF Clock - ,timeStep =TIMESTEP & !<-- Timestep needed by the Clock (ESMF) - ,startTime =STARTTIME & !<-- The integration start time (ESMF) - ,runDuration=RUNDURATION & !<-- The integration duration (ESMF) - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_MAIN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Create the NEMS component's import/export states. -!*** Currently they are not required to perform an actual function. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create the NEMS Import/Export States" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -#ifdef ESMF_520rbs - NEMS_IMP_STATE=ESMF_StateCreate( NAME='NEMS Import State' & - ,rc =RC) -! - NEMS_EXP_STATE=ESMF_StateCreate( NAME='NEMS Export State' & - ,rc =RC) -#else - NEMS_IMP_STATE=ESMF_StateCreate(STATENAME='NEMS Import State' & - ,rc =RC) -! - NEMS_EXP_STATE=ESMF_StateCreate(STATENAME='NEMS Export State' & - ,rc =RC) -#endif -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_MAIN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Execute the INITIALIZE step for the NEMS component. -!*** The Initialize routine that is called here as well as the -!*** Run and Finalize routines invoked below are those specified -!*** in the Register routine called in ESMF_GridCompSetServices above. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Execute the NEMS Component Initialize Step" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompInitialize(gridcomp =NEMS_GRID_COMP & !<-- The NEMS component - ,importState=NEMS_IMP_STATE & !<-- The NEMS component import state - ,exportState=NEMS_EXP_STATE & !<-- The NEMS component export state - ,clock =CLOCK_MAIN & !<-- The ESMF clock - ,phase =ESMF_SINGLEPHASE & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_MAIN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Execute the RUN step for the NEMS component. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Execute the NEMS Component Run Step" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompRun(gridcomp =NEMS_GRID_COMP & !<-- The NEMS component - ,importState=NEMS_IMP_STATE & !<-- The NEMS component import state - ,exportState=NEMS_EXP_STATE & !<-- The NEMS component export state - ,clock =CLOCK_MAIN & !<-- The ESMF clock - ,phase =ESMF_SINGLEPHASE & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_MAIN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** The RUN_CONTINUE flag tells us if the RUN step of the -!*** NEMS component must be called multiple times for ensembles. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract the RUN_CONTINUE flag from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config = CF_MAIN & - ,value = RUN_CONTINUE & - ,label = 'RUN_CONTINUE:' & - ,rc = RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_MAIN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Update the Main clock. This is for calling the RUN step -!*** of the NEMS component multiple times. -!----------------------------------------------------------------------- -! - IF(RUN_CONTINUE) THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract the Ensemble Clock Parameters from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config = CF_MAIN & - ,value = hh_start & - ,label = 'HH_START:' & - ,rc = RC) -! - CALL ESMF_ConfigGetAttribute(config = CF_MAIN & - ,value = hh_final & - ,label = 'HH_FINAL:' & - ,rc = RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_MAIN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NHOURS_FCST = HH_FINAL - HH_START -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="MAIN: Re-set the clock after the ensemble run cycles." -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeIntervalSet(timeInterval = RUNDURATION & - ,h = NHOURS_FCST & - ,rc = RC) -! - CALL ESMF_ClockGet(clock = CLOCK_MAIN & - ,currTime = CURRTIME & - ,rc = rc) -! - CURRTIME = CURRTIME + RUNDURATION -! - CALL ESMF_ClockSet(clock = CLOCK_MAIN & - ,RunDuration = RUNDURATION & - ,currTime = CURRTIME & - ,rc = RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_MAIN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - END IF -! -!----------------------------------------------------------------------- -!*** Execute the FINALIZE step for the NEMS component. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Execute the NEMS Component Finalize Step" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompFinalize(gridcomp =NEMS_GRID_COMP & !<-- The NEMS component - ,importState=NEMS_IMP_STATE & !<-- The NEMS component import state - ,exportState=NEMS_EXP_STATE & !<-- The NEMS component export state - ,clock =CLOCK_MAIN & !<-- The Main ESMF clock - ,phase =ESMF_SINGLEPHASE & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_MAIN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Destroy the Main Clock. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Destroy the Main Clock" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockDestroy(clock=CLOCK_MAIN & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_MAIN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Destroy the Main Configure object. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Destroy the Main Configure Object" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigDestroy(config=CF_MAIN & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_MAIN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK = "Destroy the ESMF states" -! CALL ESMF_LogWrite(MESSAGE_CHECK, ESMF_LOG_INFO, rc = RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_StateDestroy(state=NEMS_IMP_STATE & - ,rc =RC) - CALL ESMF_StateDestroy(state=NEMS_EXP_STATE & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC, MESSAGE_CHECK, RC_MAIN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK = "Destroy ESMF Grid Comp and Cpl Comp" -! CALL ESMF_LogWrite(MESSAGE_CHECK, ESMF_LOG_INFO, rc = RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompDestroy(gridcomp=NEMS_GRID_COMP & - ,rc =RC) - - CALL ERR_MSG(RC, MESSAGE_CHECK, RC_MAIN) -! -!----------------------------------------------------------------------- -!*** Shut down the ESMF system. -!----------------------------------------------------------------------- -! - CALL ESMF_Finalize() -! - IF(RC_MAIN==ESMF_SUCCESS)THEN -! WRITE(0,*)'MODEL FORECAST RUN SUCCEEDED' - ELSE - WRITE(0,*)'MODEL FORECAST RUN FAILED RC_MAIN=',RC_MAIN - ENDIF -! -!----------------------------------------------------------------------- -! - if(mype==0)call w3tage('nems ') -! -!----------------------------------------------------------------------- -! - END PROGRAM MAIN_NEMS -! -!----------------------------------------------------------------------- diff --git a/src/fim/FIMsrc/fim/framework/nems/fim_grid_comp.F90 b/src/fim/FIMsrc/fim/framework/nems/fim_grid_comp.F90 deleted file mode 100644 index 6cd3852..0000000 --- a/src/fim/FIMsrc/fim/framework/nems/fim_grid_comp.F90 +++ /dev/null @@ -1,664 +0,0 @@ - MODULE module_FIM_GRID_COMP - - USE ESMF_MOD - USE MODULE_FIM_INTERNAL_STATE ,ONLY: FIM_INTERNAL_STATE & - ,WRAP_FIM_INTERNAL_STATE - USE MODULE_FIM_INTEGRATE ,ONLY: FIM_INTEGRATE -!TBH: USE MODULE_ERR_MSG ,ONLY: ERR_MSG,SET_IPRINT - USE MODULE_ERR_MSG ,ONLY: ERR_MSG - USE MODULE_DYNAMICS_GRID_COMP ,ONLY: DYN_REGISTER - USE MODULE_PHYSICS_GRID_COMP ,ONLY: PHY_REGISTER - USE MODULE_DYN_PHY_CPL_COMP ,ONLY: DYN_PHY_CPL_REGISTER - - IMPLICIT NONE - - PRIVATE - PUBLIC :: FIM_REGISTER - - TYPE(FIM_INTERNAL_STATE),POINTER,SAVE :: FIM_INT_STATE - TYPE(WRAP_FIM_INTERNAL_STATE) ,SAVE :: WRAP - - - CONTAINS - - SUBROUTINE FIM_REGISTER(FIM_GRID_COMP,RC_REG) - TYPE(ESMF_GridComp),INTENT(INOUT) :: FIM_GRID_COMP - INTEGER ,INTENT(OUT) :: RC_REG - - INTEGER :: RC - -! write(0,*) " FIM_REGISTER" - -!----------------------------------------------------------------------- -!*** Register the fim initialize subroutine. Since it is just one -!*** subroutine, use esmf_singlephase. The second argument is -!*** a pre-defined subroutine type, such as ESMF_SETINIT, ESMF_SETRUN, -!*** or ESMF_SETFINAL. -!----------------------------------------------------------------------- - - CALL ESMF_GridCompSetEntryPoint(FIM_GRID_COMP ,ESMF_SETINIT ,FIM_INITIALIZE ,ESMF_SINGLEPHASE ,RC) - CALL ERR_MSG (RC, 'set fim initialize entry point', RC_REG) - -!----------------------------------------------------------------------- -!*** Register the Run step of the FIM component. -!----------------------------------------------------------------------- - - CALL ESMF_GridCompSetEntryPoint(FIM_GRID_COMP ,ESMF_SETRUN ,FIM_RUN ,ESMF_SINGLEPHASE ,RC) - CALL ERR_MSG (RC, 'set fim run entry point', RC_REG) - -!----------------------------------------------------------------------- -!*** Register the FIM FINALIZE subroutine. -!----------------------------------------------------------------------- - - CALL ESMF_GridCompSetEntryPoint(FIM_GRID_COMP ,ESMF_SETFINAL ,FIM_FINALIZE ,ESMF_SINGLEPHASE ,RC) - CALL ERR_MSG (RC, 'set fim finalize entry point', RC_REG) - -! write(0,*) " END OF FIM_REGISTER" - - END SUBROUTINE FIM_REGISTER - - - SUBROUTINE FIM_INITIALIZE(FIM_GRID_COMP ,IMP_STATE ,EXP_STATE ,CLOCK_ATM ,RC_INIT) - - ! TODO: move logical flags to internal state - use module_core_setup,only: core_setup_fim,iam_fim_task,iam_write_task - use module_fim_dyn_init,only:dyn_init - - TYPE(ESMF_GridComp),INTENT(INOUT) :: FIM_GRID_COMP - TYPE(ESMF_State) ,INTENT(INOUT) :: IMP_STATE - TYPE(ESMF_State) ,INTENT(INOUT) :: EXP_STATE - TYPE(ESMF_Clock) ,INTENT(INOUT) :: CLOCK_ATM - INTEGER ,INTENT(OUT) :: RC_INIT - - INTEGER :: RC - TYPE(ESMF_Config) :: CF - - type(esmf_vm),save :: vm_global, vm_local ! the esmf virtual machine. - type(esmf_time) :: currtime ! the esmf current time. - type(esmf_time) :: starttime ! the esmf start time. - type(esmf_timeinterval) :: timestep - - ! note that this is just a reference so no "save" is needed - type(esmf_grid) :: grid_fim ! FIM grid, created by DYN, used by PHY and - ! FIM components - - integer :: total_tasks - integer :: mype_global - integer :: timestep_sec_whole - integer :: timestep_sec_numerator - integer :: timestep_sec_denominator - - integer :: nfhout, nfmout, nfsout, nsout - real :: deltim - integer :: MPI_COMM_FIM ! MPI communicator for this FIM component - integer :: ppp__status - logical :: iprint_lcl - character(128) :: comp_name - - -! write(0,*) " FIM_INITIALIZE" - RC_INIT = ESMF_SUCCESS - -! Start SMS. Every build of NEMS.x with FIM must use SMS. -! Normally this code is created via SMS directive, but PPP is -! not run on this file. - CALL sms_start(ppp__status) - IF (ppp__status.NE.0) THEN - ! Follow NMM template from Tom Black for non-ESMF error-abort - write(0,*) "ERROR IN FIM_INITIALIZE: sms_start FAILED" - CALL ESMF_Finalize(RC=RC,terminationflag=ESMF_ABORT) - ENDIF -! -!----------------------------------------------------------------------- -!*** Allocate the FIM component's internal state, point at it, -!*** and attach it to the FIM component. -!----------------------------------------------------------------------- -! - ALLOCATE(FIM_INT_STATE,stat=RC) - WRAP%FIM_INT_STATE=>FIM_INT_STATE - -!JR This call stuffs "wrap" into "fim_grid_comp" for later retrieval - CALL ESMF_GridCompSetInternalState(FIM_GRID_COMP ,WRAP ,RC) - CALL ERR_MSG (RC, 'ESMF_GridCompSetInternalState', RC_INIT) - -! -!----------------------------------------------------------------------- -!*** For the moment, use a direct copy of the ATM Clock. -!----------------------------------------------------------------------- -! -!JR This should probably use ESMF's copy constructor method instead - fim_int_state%clock_fim = clock_atm - -!TBH: This bit is useful for debugging - call esmf_gridcompget (gridcomp=fim_grid_comp, name=comp_name, rc=rc) - call err_msg (rc, 'get name of fim_grid_comp', rc_init) -!JR print *,'DEBUG: name of fim_grid_comp is [',TRIM(comp_name),']' - -!----------------------------------------------------------------------- -!*** Attach the configure file to the FIM component. -!----------------------------------------------------------------------- - CF=ESMF_ConfigCreate(rc=RC) -!TODO: hard-coded 'fim.configure' is not DRY, work with NCEP to fix this - CALL ESMF_ConfigLoadFile(config=CF ,filename='fim.configure' ,rc=RC) - CALL ERR_MSG (rc, 'load configure file fim.configure into configure object', rc_init) - CALL ESMF_GridCompSet(gridcomp=FIM_GRID_COMP, config=CF, rc=RC) - CALL ERR_MSG (rc, 'attach configure object to fim component', rc_init) - -! -!----------------------------------------------------------------------- -!*** Set verbostiy of err_msg prints -!TODO: move this setting up into MAIN_NEMS.F90, work with NCEP -!TBH: Temporarily removed this until we can merge set_iprint() into -!TBH: nems repository. -!----------------------------------------------------------------------- -! -!TBH call esmf_configgetattribute (config=cf, value=iprint_lcl, label='iprint:', rc=rc) -!TBH call err_msg (rc, "extract iprint information from fim config file", rc_init) -!TBH call set_iprint(iprint_lcl) -! -!----------------------------------------------------------------------- -!*** Retrieve the VM from the FIM component. -!----------------------------------------------------------------------- -! - call esmf_gridcompget (gridcomp=fim_grid_comp, vm=vm_local, rc=rc) - call err_msg (rc, "retrieve the cf and vm from fim component", rc_init) -!----------------------------------------------------------------------- -!*** Retrieve global VM then the total number of tasks for -!*** then entire system. -!----------------------------------------------------------------------- - call esmf_vmgetglobal (vm=vm_global, rc=rc) - call err_msg (rc, "retrieve global vm_global for fim", rc_init) - - call esmf_vmget (vm=vm_global, pecount=total_tasks, localpet=mype_global, rc=rc) - call err_msg (rc, "fim_initialize: obtain global mpi task id from vm_global", rc_init) -!JR print *,'DEBUG: mype_global = ',mype_global - call esmf_vmget (vm=vm_local, localpet=fim_int_state%mype, rc=rc) - call err_msg (rc, "fim_initialize: obtain local mpi task id from vm_local", rc_init) -!JR print *,'DEBUG: fim_int_state%mype = ',fim_int_state%mype -!----------------------------------------------------------------------- -!*** Extract fundamental timestep information from the config file. -!----------------------------------------------------------------------- - call esmf_configgetattribute (config=cf, value=timestep_sec_whole, label ='dt_int:', rc=rc) - call esmf_configgetattribute (config=cf, value=timestep_sec_numerator, label ='dt_num:', rc=rc) - call esmf_configgetattribute (config=cf, value =timestep_sec_denominator, label ='dt_den:', rc=rc) - call err_msg (rc, "extract timestep information from fim config file", rc_init) -!----------------------------------------------------------------------- -!*** Establish the timestep for the FIM Clock. -!----------------------------------------------------------------------- - call esmf_timeintervalset (timeinterval=timestep, s=timestep_sec_whole, sn=timestep_sec_numerator, & - sd=timestep_sec_denominator, rc=rc) - call esmf_clockset (clock=fim_int_state%clock_fim, timestep = timestep, rc=rc) - call err_msg (rc, "set time step interval in fim clock", rc_init) - -!TBH: Note that DYN, PHY, and CPL must currently live on the same -!TBH: MPI tasks via the use of "petlist=fim_int_state%petlist_fcst" -!TBH: during ESMF_*CompCreate() calls. - -! -!----------------------------------------------------------------------- -!*** SEGREGATE THE FORECAST TASKS FROM THE QUILT/WRITE TASKS. -!*** VIA CALL TO core_setup_fim WHICH RETURNS PETLISTS. -!----------------------------------------------------------------------- -! - CALL ESMF_VMGet(vm=vm_local,mpiCommunicator=MPI_COMM_FIM,rc=RC) - call err_msg (rc, "extract mpiCommunicator from vm_local", rc_init) - -#ifdef MANUALGPTL - ret = gptlstart ('core_setup_fim') -#endif - -! Split VM between compute and write tasks via petlists. -! core_setup_fim() allocates and initializes the petlists. -! NOTE: Executable SMS directives must not be placed before -! NOTE: this call! - CALL core_setup_fim(MPI_COMM_FIM,fim_int_state%petlist_fcst, & - fim_int_state%petlist_write) -#ifdef MANUALGPTL - ret = gptlstop ('core_setup_fim') -#endif - -!----------------------------------------------------------------------- -!*** Will the Write components with asynchronous quilting be used? -!----------------------------------------------------------------------- -!TBH call esmf_configgetattribute (config=cf, & ! the fim config object -!TBH value =fim_int_state%quilting, & ! the quilting flag -!TBH label ='quilting:', & ! give label's value to the previous variable -!TBH rc =rc) -!TBH call err_msg (rc, "extract quilting flag from fim config file", rc_init) - -! Note: At the moment, the 'quilting' field in the config file is ignored in -! Note: favor of FIMnamelist settings read by core_setup_fim. -!TODO: Reconcile 'quilting' field and FIM write task settings. - if (size(fim_int_state%petlist_write) > 0) then - fim_int_state%quilting = .true. - else - fim_int_state%quilting = .false. - endif - -!TODO: Connect fim_int_state%quilting to creation of NEMS write components. -!TODO: FIM write tasks are not yet ESMF components. Per UMIG discussion -!TODO: with Mark Iredell during UMIG meeting on 1/14/2011, it is more -!TODO: important to get write tasks working with NEMSIO before encapsulating -!TODO: them as components. - -!----------------------------------------------------------------------- -!*** Establish the frequency of forecast output. -!TODO: Reconcile FIMnamelist and config file here -!----------------------------------------------------------------------- - call esmf_configgetattribute (config=cf, value=nfhout, label ='nfhout:', rc=rc) - call err_msg (rc, "extract nfhout from fim config file", rc_init) - call esmf_configgetattribute (config=cf, value=nsout, label ='nsout:', rc=rc) - call err_msg (rc, "extract nsout from fim config file", rc_init) - call esmf_configgetattribute (config=cf, value =deltim, label ='deltim:', rc=rc) - call err_msg (rc, "extract history output interval from fim config file", rc_init) - call esmf_timeintervalset (fim_int_state%timeinterval_fim_output, h=nfhout, m=nfmout, & - s=nfsout, rc=rc) - call err_msg (rc, "set fim history output interval", rc_init) -!----------------------------------------------------------------------- -!*** Extract the start time from the clock. -!----------------------------------------------------------------------- - call esmf_clockget (clock=fim_int_state%clock_fim, starttime=starttime, rc=rc) - call err_msg (rc, "fim_atm_init: start time from fim clock", rc_init) - currtime = starttime -!----------------------------------------------------------------------- -!*** No need to extract the RESTART flag from the configure file: FIM currently has no restart capability -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** Create the Dynamics gridded subcomponent. -! all tasks must participate in component creation even if they do -! not participate in a component -!----------------------------------------------------------------------- - fim_int_state%gc_fim_dyn = esmf_gridcompcreate (name="dynamics component", & - configfile='fim.configure', & - petlist=fim_int_state%petlist_fcst, & - rc=rc) - call err_msg (rc, "create the fim dynamics component", rc_init) - -!----------------------------------------------------------------------- -!*** Always create the Physics gridded subcomponent. -!----------------------------------------------------------------------- - fim_int_state%gc_fim_phy = esmf_gridcompcreate (name ="physics component", & - configfile='fim.configure', & - petlist =fim_int_state%petlist_fcst, & - rc =rc) - call err_msg (rc, "create the fim physics component", rc_init) -!----------------------------------------------------------------------- -!*** Create the Dynamics-Physics coupler subcomponent. -!----------------------------------------------------------------------- - fim_int_state%gc_fim_cpl = esmf_cplcompcreate (name="coupler component", & - petlist=fim_int_state%petlist_fcst, & - rc =rc) - call err_msg (rc, "create the fim dynamics-physics coupler component", rc_init) - -! all tasks must participate in setservices calls even if they do -! not participate in a component (ESMF refdoc 15.3.8) -!*** Register the Initialize, Run, and Finalize steps for created components - call esmf_gridcompsetservices (fim_int_state%gc_fim_dyn, dyn_register, rc) - call err_msg (rc, "register fim dynamics init, run, finalize", rc_init) - call esmf_gridcompsetservices (fim_int_state%gc_fim_phy, phy_register, rc) - call err_msg (rc, "register physics init, run, finalize", rc_init) - call esmf_cplcompsetservices (fim_int_state%gc_fim_cpl, dyn_phy_cpl_register, rc) - call err_msg (rc, "register the dyn-phy coupler's init, run, finalize", rc_init) - -!----------------------------------------------------------------------- -!*** Create empty Import and Export states for the Dynamics component -!----------------------------------------------------------------------- - fim_int_state%IMP_fim_DYN = ESMF_StateCreate (statename="FIM dynamics import", & - statetype=esmf_state_import, & - rc =RC) - call err_msg (rc, "create empty import state for fim dynamics", rc_init) - fim_int_state%exp_fim_DYN = ESMF_StateCreate (statename="FIM dynamics export", & - statetype=esmf_state_export, & - rc =RC) - call err_msg (rc, "create empty export state for fim dynamics", rc_init) -!---------------------------------------------------------------------------------- -! Add the FIM dynamics states as the nested states into the FIM parent states. -!---------------------------------------------------------------------------------- - call esmf_stateadd (imp_state, fim_int_state%imp_fim_dyn, rc) - call esmf_stateadd (exp_state, fim_int_state%exp_fim_dyn, rc) -!JR I don't know what cpl_flag does, so copy from GFS for now - fim_int_state%cpl_flag = esmf_false - call esmf_attributeset (fim_int_state%imp_fim_dyn, 'cpl_flag', fim_int_state%cpl_flag, rc) - call err_msg (rc, "fim set cpl_flag", rc_init) -!------------------------------------------------------------------------ -!*** Create empty Import and Export states for the Physics subcomponent. -! Note that statenames are used by CPL_RUN() to determine direction of -! coupling (DYN->PHY or PHY->DYN). Any changes must be matched by -! equivalent changes in CPL_RUN(). -!------------------------------------------------------------------------ - fim_int_state%imp_fim_phy = esmf_statecreate (statename="FIM physics import", & - statetype=esmf_state_import, & - rc =rc) - call err_msg (rc, "create empty import state for fim physics", rc_init) - fim_int_state%exp_fim_phy = esmf_statecreate (statename="FIM physics export", & - statetype=esmf_state_export, & - rc =rc) - call err_msg (rc, "create empty export state for fim physics", rc_init) - -!----------------------------------------------------------------------- -!*** Setup the Write component(s) (which may run without quilting). -!JR Keep this: FIM will require mods vs GFS -!----------------------------------------------------------------------- -! -!JR write(0,*)'before write_setup_fim, allocate,write_groups=', fim_int_state%write_groups -! allocate (fim_int_state%wrt_comps(fim_int_state%write_groups)) -!JR Comment out for now -!JR call write_setup_fim (fim_grid_comp, fim_int_state%wrt_comps, fim_int_state%exp_fim_dyn, & -!JR fim_int_state%exp_fim_phy, fim_int_state%imp_fim_wrt, fim_int_state%exp_fim_wrt) - -!----------------------------------------------------------------------- -!*** Execute the Initialize steps for the gridded subcomponents. -!*** These are the Initialize subroutines specified in the -!*** Register routines called in ESMF_GridCompSetServices above. -! Note: Only tasks listed in the petlist during component creation -! Note: participate in the esmf_gridcompinitialize (etc.) calls. -! Note: For example, the write tasks return immediately from the calls -! Note: to esmf_gridcompinitialize for fim_int_state%gc_fim_??? below. -!----------------------------------------------------------------------- - -! TODO: Make sure that parent does *not* set an ESMF_Grid in the FIM component! -! TODO: Per Gerhard we will need to call esmf_gridcompget() to grab the attached -! TODO: ESMF_Grid and then call ESMF_GridValidate() on it. Unfortunately at the -! TODO: moment, ESMF regards calling of ESMF_GridValidate() on an un-initialized -! TODO: ESMF_Grid as an error! Straighten this out later. - -! TODO: Make DYN set lat & lon values in the ESMF_Grid and make PHY extract -! TODO: them, then eliminate passing of lat/lon arrays during CPL INIT. -! TODO: Ultimately we'll want to modify the NEMS GFS PHY component to accept -! TODO: and ESMF_Grid from its parent, at least optionally, and extract lat/lon -! TODO: from it. Tom Black agrees with this approach. -! TODO: See module_DYN_PHY_CPL_COMP.F90::CPL_INITIALIZE() for a long-winded -! TODO: explanation. - -!-------------- -!*** DYNAMICS -!-------------- - ! DYN initialize creates the FIM ESMF_Grid and attaches it to - ! fim_int_state%gc_fim_dyn. This delegation is appropriate since - ! the design and implementation of DYN is intimately related to - ! the grid. The PHY and FIM components just use this grid. Note - ! that because of this dependence, DYN initialize must be called - ! before PHY initialize. - ! Note also that DYN is responsible for destroying the grid. -!TBH: This is what the ESMF_GridCompInitialize() call does, but do *not* -!TBH: call it directly because ESMF_GridCompInitialize() has needed -!TBH: side-effects. -!TBH call dyn_initialize (fim_int_state%gc_fim_dyn, & -!TBH fim_int_state%imp_fim_dyn, & -!TBH fim_int_state%exp_fim_dyn, & -!TBH fim_int_state%clock_fim, & -!TBH rc) - call esmf_gridcompinitialize (fim_int_state%gc_fim_dyn, & - importstate=fim_int_state%imp_fim_dyn, & - exportstate=fim_int_state%exp_fim_dyn, & - clock =fim_int_state%clock_fim, & - phase =esmf_singlephase, & - rc =rc) - call err_msg (rc, "initialize fim dynamics component", rc_init) - - ! extract ESMF_Grid from fim_int_state%gc_fim_dyn and set in - ! fim_int_state%gc_fim_phy and fim_grid_comp - ! it is only safe to do this on the FIM compute tasks - if (iam_fim_task) then - ! grab FIM grid from DYN - call esmf_gridcompget(fim_int_state%gc_fim_dyn, grid=grid_fim, rc=rc) - CALL err_msg(rc, "extract FIM grid from DYN component", rc_init) - ! is this a good grid? - call esmf_gridvalidate(grid=grid_fim, rc=rc) - CALL err_msg(RC,"validate FIM grid",rc_init) - ! attach grid to FIM component - call esmf_gridcompset(fim_grid_comp, grid=grid_fim, rc=rc) - call err_msg (rc, "attach FIM grid to FIM component", rc_init) - ! attach grid to PHY component - call esmf_gridcompset(fim_int_state%gc_fim_phy, grid=grid_fim, rc=rc) - call err_msg (rc, "attach grid to fim physics component", rc_init) - endif - -!------------- -!*** PHYSICS -!------------- -!TBH: This is what the ESMF_GridCompInitialize() call does, but do *not* -!TBH: call it directly because ESMF_GridCompInitialize() has needed -!TBH: side-effects. -!TBH call phy_initialize (fim_int_state%gc_fim_phy, fim_int_state%imp_fim_phy, & -!TBH fim_int_state%exp_fim_phy, fim_int_state%clock_fim, rc) - call esmf_gridcompinitialize (fim_int_state%gc_fim_phy, & - importstate=fim_int_state%imp_fim_phy, & - exportstate=fim_int_state%exp_fim_phy, & - clock =fim_int_state%clock_fim, & - phase =esmf_singlephase, & - rc =rc) - call err_msg (rc, "initialize fim physics component", rc_init) - -!-------------- -!*** DYN-PHY COUPLER COMPONENT -!-------------- -!TBH: This is what the ESMF_CplCompInitialize() call does, but do *not* -!TBH: call it directly because ESMF_CplCompInitialize() has needed -!TBH: side-effects. -!TBH call cpl_initialize (fim_int_state%gc_fim_cpl, fim_int_state%exp_fim_dyn, & -!TBH fim_int_state%imp_fim_phy, fim_int_state%clock_fim, rc) - call esmf_cplcompinitialize (cplcomp =fim_int_state%gc_fim_cpl, & - importstate=fim_int_state%exp_fim_dyn, & - exportstate=fim_int_state%imp_fim_phy, & - clock =fim_int_state%clock_fim, & - rc =rc) - call err_msg (rc, "initialize dyn-phy coupler", rc_init) - - !TBH: Recall that the above call to - !TBH: esmf_gridcompinitialize (fim_int_state%gc_fim_dyn ... ) is a NOOP - !TBH: on write tasks because gc_fim_dyn was created with a "petlist" - !TBH: optional argument that excluded the write tasks from participation - !TBH: in this DYN components method calls. See for example the above - !TBH: call to: - !TBH: fim_int_state%gc_fim_dyn = esmf_gridcompcreate (...) - ! TODO: move this into FIM write component - if (iam_write_task) then - call dyn_init(.false.) - endif - -! write(0,*) " END OF FIM_INITIALIZE" - END SUBROUTINE FIM_INITIALIZE - - - SUBROUTINE FIM_RUN(FIM_GRID_COMP ,IMP_STATE ,EXP_STATE ,CLOCK_ATM ,RC_RUN) - - ! TODO: move these to internal state - use module_core_setup,only: iam_fim_task,iam_write_task - ! TODO: move this into FIM write component - use icosio,only:icosio_run - - TYPE(ESMF_GridComp),INTENT(INOUT) :: FIM_GRID_COMP - TYPE(ESMF_State) ,INTENT(INOUT) :: IMP_STATE - TYPE(ESMF_State) ,INTENT(INOUT) :: EXP_STATE - TYPE(ESMF_Clock) ,INTENT(INOUT) :: CLOCK_ATM - INTEGER ,INTENT(OUT) :: RC_RUN - -!--------------------- -!*** Local variables -!--------------------- -! - type(esmf_config) :: cf - integer :: rc ! error signal variables. - type(esmf_timeinterval) :: runduration ! the forecast length - type(esmf_timeinterval) :: timestep ! the fundamental timestep - type(esmf_time) :: currtime ! the esmf current time. - type(esmf_time) :: starttime ! the esmf start time. - -! write(0,*) " FIM_RUN" - RC_RUN=ESMF_SUCCESS - - if (iam_fim_task) then - ! compute tasks execute this branch - -!----------------------------------------------------------------------- -!*** For the moment, use a direct copy of the ATM Clock. -!JR This isn't good -!----------------------------------------------------------------------- -! - fim_int_state%clock_fim = clock_atm -!----------------------------------------------------------------------- -!*** Extract the fundamental time information from the Clock. -!----------------------------------------------------------------------- - call esmf_clockget (clock =fim_int_state%clock_fim, & ! the esmf clock - timestep =timestep, & ! the model's timestep length - starttime =starttime, & ! the forecast start time - currtime =currtime, & ! the clock's current time - runduration =runduration, & ! the length of the forecast - rc =rc) - call err_msg (rc, "retrieve fim timestep from the atm clock", rc_run) -!----------------------------------------------------------------------- -!*** Extract the configure file from the ATM component. -!*** GFS needed DFI info here but FIM doesn't -!----------------------------------------------------------------------- - call esmf_gridcompget (gridcomp=fim_grid_comp, config=cf, rc=rc) -!----------------------------------------------------------------------- -!*** Execute the FIM forecast runstream. -!----------------------------------------------------------------------- - call fim_integrate (fim_int_state%gc_fim_dyn, & - fim_int_state%gc_fim_phy, & - fim_int_state%gc_fim_cpl, & - fim_int_state%imp_fim_dyn, & - fim_int_state%exp_fim_dyn, & - fim_int_state%imp_fim_phy, & - fim_int_state%exp_fim_phy, & - fim_int_state%clock_fim, & - rc_run) - - else if (iam_write_task) then - ! TODO: move this into FIM write component - ! write tasks execute this branch, if present -! -!----------------------------------------------------------------------- -!*** Call the run method for the optional write tasks. -!----------------------------------------------------------------------- -! - call icosio_run - - endif - - ! do-nothing tasks just print along with the others -! write(0,*) " END OF FIM_RUN" - END SUBROUTINE FIM_RUN - - - SUBROUTINE FIM_FINALIZE(FIM_GRID_COMP ,IMP_STATE ,EXP_STATE ,CLOCK_ATM ,RC_FINALIZE) - - ! TODO: move to internal state - use module_core_setup,only: iam_fim_task - - TYPE(ESMF_GridComp),INTENT(INOUT) :: FIM_GRID_COMP - TYPE(ESMF_State) ,INTENT(INOUT) :: IMP_STATE - TYPE(ESMF_State) ,INTENT(INOUT) :: EXP_STATE - TYPE(ESMF_Clock) ,INTENT(INOUT) :: CLOCK_ATM - INTEGER ,INTENT(OUT) :: RC_FINALIZE - -!----------------------------------------------------------------------- -!*** LOCAL VARIABLES -!----------------------------------------------------------------------- -! - type(esmf_config) :: cf ! config object - integer :: i,j - integer :: rc,rc_final ! the final error signal variables. - TYPE(ESMF_VM) :: VM - -! write(0,*) " FIM_FINALIZE" - RC_FINALIZE=ESMF_SUCCESS - - rc = esmf_success - rc_final = esmf_success - -!----------------------------------------------------------------------- -!*** For the moment, use a direct copy of the ATM Clock. -!JR Fix this -!----------------------------------------------------------------------- -! - fim_int_state%clock_fim = clock_atm - - call esmf_gridcompget (gridcomp=fim_grid_comp, config=cf, rc=rc) - call err_msg (rc, "Retrieve Config Object from FIM Component", rc_final) - -!----------------------------------------------------------------------- -!*** Finalize each of the subcomponents. -!----------------------------------------------------------------------- -! -if (iam_fim_task) then -!----------------------------- -!*** DYNAMICS-PHYSICS COUPLER -!----------------------------- - call esmf_cplcompfinalize (fim_int_state%gc_fim_cpl, & - importstate=fim_int_state%exp_fim_dyn, & - exportstate=fim_int_state%imp_fim_phy, & - clock =fim_int_state%clock_fim, & - rc =rc) - call err_msg (rc, "finalize dynamics-physics coupler", rc_final) -!-------------- -!*** Dynamics -!-------------- - call esmf_gridcompfinalize (fim_int_state%gc_fim_dyn, & - importstate=fim_int_state%imp_fim_dyn, & - exportstate=fim_int_state%exp_fim_dyn, & - clock =fim_int_state%clock_fim, & - rc =rc) - call err_msg (rc, "finalize dynamics component", rc_final) -!-------------- -!*** Physics -!-------------- - call esmf_gridcompfinalize (fim_int_state%gc_fim_phy, & - importstate=fim_int_state%imp_fim_phy, & - exportstate=fim_int_state%exp_fim_phy, & - clock =fim_int_state%clock_fim, & - rc =rc) - call err_msg (rc, "finalize physics component", rc_final) -endif - - ! ensure that "write" and "do-nothing" tasks do not race ahead and - ! destroy components before other tasks are ready - CALL ESMF_VMGetCurrent(vm=VM,rc=RC) - call err_msg (rc, "FIM_FINALIZE: get current vm", rc_final) - CALL ESMF_VMBarrier(vm=VM,rc=RC) - call err_msg (rc, "FIM_FINALIZE: barrier on current vm", rc_final) - -!----------------------------------------------------------------------- -!*** DESTROY ALL STATES. -!----------------------------------------------------------------------- - call esmf_statedestroy (fim_int_state%imp_fim_dyn, rc=rc) - call esmf_statedestroy (fim_int_state%exp_fim_dyn, rc=rc) - call esmf_statedestroy (state=fim_int_state%imp_fim_phy, rc=rc) - call esmf_statedestroy (state=fim_int_state%exp_fim_phy, rc=rc) -!----------------------------------------------------------------------- -!*** IF QUILTING WAS SELECTED FOR THE GENERATION OF OUTPUT, -!*** FINALIZE AND DESTROY OBJECTS RELATED TO THE WRITE COMPONENTS. -!----------------------------------------------------------------------- - if (fim_int_state%quilting) then -!JR turn this off until quilting is implemented -!JR call write_destroy_fim (fim_grid_comp, fim_int_state%wrt_comps, fim_int_state%imp_fim_wrt, & -!JR fim_int_state%exp_fim_wrt, fim_int_state%clock_fim) - end if - -!----------------------------------------------------------------------- -!*** DESTROY ALL SUBCOMPONENTS. -!----------------------------------------------------------------------- - call esmf_gridcompdestroy (fim_int_state%gc_fim_dyn, rc=rc) - call err_msg (rc, "Destroy Dynamics Component", rc_final) -!------------- -!*** PHYSICS -!------------- - call esmf_gridcompdestroy (fim_int_state%gc_fim_phy, rc=rc) - call err_msg (rc, "destroy physics component", rc_final) -!------------------------------ -!*** DYNAMICS-PHYSICS COUPLER -!------------------------------ - call esmf_cplcompdestroy (fim_int_state%gc_fim_cpl, rc=rc) - call err_msg (rc, "destroy dynamics-physics coupler", rc_final) - -!TODO: make sure all allocated bits of fim_int_state are deallocated -! deallocate other components of fim_int_state - deallocate(fim_int_state%petlist_fcst) - deallocate(fim_int_state%petlist_write) - - rc_finalize = rc_final -! write(0,*) " END OF FIM_FINALIZE" - END SUBROUTINE FIM_FINALIZE - - END MODULE module_FIM_GRID_COMP diff --git a/src/fim/FIMsrc/fim/framework/nems/fim_internal_state.F90 b/src/fim/FIMsrc/fim/framework/nems/fim_internal_state.F90 deleted file mode 100644 index ed0d5f6..0000000 --- a/src/fim/FIMsrc/fim/framework/nems/fim_internal_state.F90 +++ /dev/null @@ -1,45 +0,0 @@ - MODULE module_FIM_INTERNAL_STATE - - USE ESMF_MOD - - IMPLICIT NONE - - PRIVATE - PUBLIC :: FIM_INTERNAL_STATE,WRAP_FIM_INTERNAL_STATE - - TYPE FIM_INTERNAL_STATE - - type(esmf_gridcomp) :: gc_fim_dyn - type(esmf_gridcomp) :: gc_fim_phy - type(esmf_state ) :: imp_fim_dyn - type(esmf_state ) :: exp_fim_dyn !<-- import/export states for fim dynamics - type(esmf_state ) :: imp_fim_phy - type(esmf_state ) :: exp_fim_phy !<-- import/export states for fim physics -! type(esmf_state ) :: imp_fim_wrt -! type(esmf_state ) :: exp_fim_wrt !<-- import/export states for fim write - type(esmf_clock ) :: clock_fim - type(esmf_logical) :: cpl_flag -! type(esmf_logical) :: chemistry_on !<-- is chemistry active? - type(esmf_cplcomp) :: gc_fim_cpl - integer :: mype !<-- each mpi task id -! integer :: write_group_ready_to_go !<-- the write group to use - logical :: quilting !<-- is asynchronous quilting specified? - type(esmf_logical) :: physics_on !<-- is physics active? -! type(esmf_gridcomp), pointer :: wrt_comps(:) - type(esmf_timeinterval) :: timeinterval_fim_output !<-- time interval between fim history output - - ! Task ID list of fcst tasks (for Dyn, Phy, and Cpl components) - ! Task IDs are based on FIM component local VM - integer, pointer :: petlist_fcst(:) - ! Task ID list of all write tasks - ! Task IDs are based on FIM component local VM - integer, pointer :: petlist_write(:) - - END TYPE FIM_INTERNAL_STATE - - TYPE WRAP_FIM_INTERNAL_STATE - TYPE(FIM_INTERNAL_STATE),POINTER :: FIM_INT_STATE - END TYPE WRAP_FIM_INTERNAL_STATE - - END MODULE module_FIM_INTERNAL_STATE - diff --git a/src/fim/FIMsrc/fim/framework/nems/kind.inc b/src/fim/FIMsrc/fim/framework/nems/kind.inc deleted file mode 100644 index 9f7d32e..0000000 --- a/src/fim/FIMsrc/fim/framework/nems/kind.inc +++ /dev/null @@ -1,19 +0,0 @@ -!JR Rev. 11555 of NEMS repo. -integer,parameter :: isingle=selected_int_kind(r=9) -integer,parameter :: idouble=selected_int_kind(r=18) -integer,parameter :: single=selected_real_kind(p=6,r=37) -integer,parameter :: double=selected_real_kind(p=13,r=200) - -integer,parameter:: & - klog=4 & -,kint=isingle & -,kdin=idouble & -,kfpt=single & -,kdbl=double - -!JR PPP doesn't like the hex constants so remove them -#if 0 -real (kind=kfpt),parameter :: r4_in=x'ffbfffff' -real (kind=kdbl),parameter :: r8_in=x'fff7ffffffffffff' -#endif -integer(kind=kint),parameter :: i4_in=-999 ! -huge(1) diff --git a/src/fim/FIMsrc/fim/framework/nems/module_ATM_GRID_COMP.F90 b/src/fim/FIMsrc/fim/framework/nems/module_ATM_GRID_COMP.F90 deleted file mode 100644 index 68a7749..0000000 --- a/src/fim/FIMsrc/fim/framework/nems/module_ATM_GRID_COMP.F90 +++ /dev/null @@ -1,697 +0,0 @@ -!TBH: Matches r14147 of https://svnemc.ncep.noaa.gov/projects/nems/trunk/ -!TBH: except for comments, hacks to avoid stubs noted below and change in -!TBH: the path to ESMFVersionDefine.h. - -!JR Added ifdef to avoid having to compile stubs. -!JR Comments about what is actually being called by ESMF - -#include "./ESMFVersionDefine.h" - -#if (ESMF_MAJOR_VERSION < 5 || ESMF_MINOR_VERSION < 2) -#undef ESMF_520rbs -#else -#define ESMF_520rbs -#endif - -!----------------------------------------------------------------------- -! - MODULE module_ATM_GRID_COMP -! -!----------------------------------------------------------------------- -!*** This module contains codes directly related to the ATM component. -!----------------------------------------------------------------------- -! -!*** The ATM component lies in the heirarchy seen here: -! -! Main program -! | -! | -! NEMS component -! | |________________________. -! | | -! EARTH component Ensemble Coupler component -! | -! | -! ATM/OCEAN/ICE components -! | -! | -! CORE component (GFS, NMM, FIM, GEN, etc.) -! -!----------------------------------------------------------------------- -! 2011-05-11 Theurich & Yang - Modified for using the ESMF 5.2.0r_beta_snapshot_07. -!----------------------------------------------------------------------- -! - USE ESMF_MOD -! - USE module_ATM_INTERNAL_STATE,ONLY: ATM_INTERNAL_STATE & - ,WRAP_ATM_INTERNAL_STATE -!JR Hack to avoid having to use stubs -#if 0 - USE module_NMM_GRID_COMP,ONLY: NMM_REGISTER - USE module_GFS_GRID_COMP,ONLY: GFS_REGISTER - USE module_GEN_GRID_COMP,ONLY: GEN_REGISTER ! For the "Generic Core" gridded component. -#endif - USE module_FIM_GRID_COMP,ONLY: FIM_REGISTER -! - USE module_ERR_MSG,ONLY: ERR_MSG,MESSAGE_CHECK -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: ATM_REGISTER -! -!----------------------------------------------------------------------- -! - TYPE(ATM_INTERNAL_STATE),POINTER,SAVE :: ATM_INT_STATE - TYPE(WRAP_ATM_INTERNAL_STATE) ,SAVE :: WRAP -! - TYPE(ESMF_Clock),SAVE :: CLOCK_ATM !<-- The Clock of the ATM component -! -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE ATM_REGISTER(ATM_GRID_COMP,RC_REG) -! -!----------------------------------------------------------------------- -!*** Register the Init, Run, and Finalize routines of -!*** the ATM component. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_GridComp) :: ATM_GRID_COMP !<-- The ATM component - INTEGER ,INTENT(OUT) :: RC_REG !<-- Error return code -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER :: RC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for ATM Initialize" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -#ifdef ESMF_3 - CALL ESMF_GridCompSetEntryPoint(ATM_GRID_COMP & !<-- The ATM component - ,ESMF_SETINIT & !<-- Subroutine type (Initialize) - ,ATM_INITIALIZE & !<-- User's subroutine name - ,ESMF_SINGLEPHASE & - ,RC) -#else - CALL ESMF_GridCompSetEntryPoint(ATM_GRID_COMP & !<-- The ATM component - ,ESMF_SETINIT & !<-- Subroutine type (Initialize) - ,ATM_INITIALIZE & !<-- User's subroutine name - ,phase=ESMF_SINGLEPHASE & - ,rc=RC) -#endif -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for ATM Run" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -#ifdef ESMF_3 - CALL ESMF_GridCompSetEntryPoint(ATM_GRID_COMP & !<-- The ATM component - ,ESMF_SETRUN & !<-- Subroutine type (Run) - ,ATM_RUN & !<-- User's subroutine name - ,ESMF_SINGLEPHASE & - ,RC) -#else - CALL ESMF_GridCompSetEntryPoint(ATM_GRID_COMP & !<-- The ATM component - ,ESMF_SETRUN & !<-- Subroutine type (Run) - ,ATM_RUN & !<-- User's subroutine name - ,phase=ESMF_SINGLEPHASE & - ,rc=RC) -#endif -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for ATM Finalize" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -#ifdef ESMF_3 - CALL ESMF_GridCompSetEntryPoint(ATM_GRID_COMP & !<-- The ATM component - ,ESMF_SETFINAL & !<-- Subroutine type (Finalize) - ,ATM_FINALIZE & !<-- User's subroutine name - ,ESMF_SINGLEPHASE & - ,RC) -#else - CALL ESMF_GridCompSetEntryPoint(ATM_GRID_COMP & !<-- The ATM component - ,ESMF_SETFINAL & !<-- Subroutine type (Finalize) - ,ATM_FINALIZE & !<-- User's subroutine name - ,phase=ESMF_SINGLEPHASE & - ,rc=RC) -#endif -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - IF(RC_REG==ESMF_SUCCESS)THEN -! WRITE(0,*)' ATM_REGISTER succeeded' - ELSE - WRITE(0,*)' ATM_REGISTER failed RC_REG=',RC_REG - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE ATM_REGISTER -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE ATM_INITIALIZE(ATM_GRID_COMP & - ,IMP_STATE & - ,EXP_STATE & - ,CLOCK_EARTH & - ,RC_INIT) -! -!----------------------------------------------------------------------- -!*** The Initialize step of the ATM component. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_GridComp) :: ATM_GRID_COMP !<-- The ATM component - TYPE(ESMF_State) :: IMP_STATE !<-- The ATM import state - TYPE(ESMF_State) :: EXP_STATE !<-- The ATM export state - TYPE(ESMF_Clock) :: CLOCK_EARTH !<-- The Clock of the EARTH component - INTEGER ,INTENT(OUT) :: RC_INIT !<-- Error return code -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER :: RC -! - TYPE(ESMF_Config) :: CF -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC_INIT = ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** Allocate the ATM component's internal state, point at it, -!*** and attach it to the ATM component. -!----------------------------------------------------------------------- -! - ALLOCATE(ATM_INT_STATE,stat=RC) - wrap%ATM_INT_STATE=>ATM_INT_STATE -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set the ATM Internal State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSetInternalState(ATM_GRID_COMP & - ,WRAP & - ,RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** For the moment, use a direct copy of the EARTH Clock within -!*** the ATM component. -!----------------------------------------------------------------------- -! - atm_int_state%CLOCK_ATM=CLOCK_EARTH -! -!----------------------------------------------------------------------- -!*** Create the configure object for the ATM configure file which -!*** specifies the dynamic core. -!----------------------------------------------------------------------- -! - CF=ESMF_ConfigCreate(rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load the ATM configure file" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigLoadFile(config=CF ,filename='atmos.configure' ,rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Attach the configure object to the ATM component. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Attach the configure file to the ATM component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSet(gridcomp=ATM_GRID_COMP & !<-- The ATM component - ,config =CF & !<-- The associated configure object - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Extract the dynamic core name from the configure file. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract dynamic core from the ATM configure file" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The ATM configure object - ,value =atm_int_state%CORE & !<-- The dynamic core name - ,label ='core:' & !<-- The label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Create the ATM subcomponent and its associated import/export -!*** states for the core name that was extracted. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create the CORE component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - atm_int_state%CORE_GRID_COMP=ESMF_GridCompCreate(name=TRIM(atm_int_state%CORE)//' component' & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Attach the configure object to the CORE component. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! MESSAGE_CHECK="Attach the configure file to the CORE component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! CALL ESMF_GridCompSet(gridcomp=atm_int_state%CORE_GRID_COMP & !<-- The ATM component -! ,config =CF & !<-- The associated configure object -! ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Register the subcomponent's Init, Run, and Finalize subroutines. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Register the CORE component's Init, Run, and Finalize steps" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - SELECT CASE(atm_int_state%CORE) -! -#ifdef ESMF_3 -!JR Hack to avoid having to use stubs -#if 0 - CASE('nmm') - CALL ESMF_GridCompSetServices (atm_int_state%CORE_GRID_COMP & - ,NMM_REGISTER & - ,RC) -! - CASE('gfs') - CALL ESMF_GridCompSetServices (atm_int_state%CORE_GRID_COMP & - ,GFS_REGISTER & - ,RC) -#endif -! - CASE('fim') - CALL ESMF_GridCompSetServices (atm_int_state%CORE_GRID_COMP & - ,FIM_REGISTER & - ,RC) - -!JR Hack to avoid having to use stubs -#if 0 - CASE('gen') - CALL ESMF_GridCompSetServices (atm_int_state%CORE_GRID_COMP & - ,GEN_REGISTER & - ,RC) -#endif - -#else -!JR Hack to avoid having to use stubs -#if 0 - CASE('nmm') - CALL ESMF_GridCompSetServices (atm_int_state%CORE_GRID_COMP & - ,NMM_REGISTER & - ,rc=RC) -! - CASE('gfs') - CALL ESMF_GridCompSetServices (atm_int_state%CORE_GRID_COMP & - ,GFS_REGISTER & - ,rc=RC) -#endif -! - CASE('fim') - CALL ESMF_GridCompSetServices (atm_int_state%CORE_GRID_COMP & - ,FIM_REGISTER & - ,rc=RC) - -!JR Hack to avoid having to use stubs -#if 0 - CASE('gen') - CALL ESMF_GridCompSetServices (atm_int_state%CORE_GRID_COMP & - ,GEN_REGISTER & - ,rc=RC) -#endif -#endif - CASE DEFAULT - write(0,*)' ATM_INITIALIZE requires unknown core: ',TRIM(atm_int_state%CORE) -! - END SELECT -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Create the Core component's import/export states. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create the CORE import state" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -#ifdef ESMF_520rbs - atm_int_state%CORE_IMP_STATE=ESMF_StateCreate( NAME="CORE Import" & - ,statetype=ESMF_STATE_IMPORT & - ,rc =RC) -#else - atm_int_state%CORE_IMP_STATE=ESMF_StateCreate(STATENAME="CORE Import" & - ,statetype=ESMF_STATE_IMPORT & - ,rc =RC) -#endif -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create the CORE export state" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -#ifdef ESMF_520rbs - atm_int_state%CORE_EXP_STATE=ESMF_StateCreate( NAME="CORE Export" & - ,statetype=ESMF_STATE_EXPORT & - ,rc =RC) -#else - atm_int_state%CORE_EXP_STATE=ESMF_StateCreate(STATENAME="CORE Export" & - ,statetype=ESMF_STATE_EXPORT & - ,rc =RC) -#endif -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Nest the import/export states of the CORE component into the -!*** analgous states of the ATM component. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK= "Add the CORE states into the ATMOS states" -! CALL ESMF_LogWrite(MESSAGE_CHECK, ESMF_LOG_INFO, rc = RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateAdd(state =IMP_STATE & - ,nestedState=atm_int_state%CORE_IMP_STATE & - ,rc =RC) -! - CALL ESMF_StateAdd(state =EXP_STATE & - ,nestedState=atm_int_state%CORE_EXP_STATE & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Initialize the CORE component. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Initialize the CORE component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!JR WRITE(0,*)'DEBUG: ATM_INITIALIZE calling fim_initialize...' -!TBH: This is what the ESMF_GridCompInitialize() call does, but do *not* -!TBH: call it directly because ESMF_GridCompInitialize() has needed -!TBH: side-effects. -!TBH call fim_initialize (atm_int_state%core_grid_comp, atm_int_state%core_imp_state, & -!TBH atm_int_state%core_exp_state, atm_int_state%clock_atm, rc) - CALL ESMF_GridCompInitialize(gridcomp =atm_int_state%CORE_GRID_COMP & - ,importState=atm_int_state%CORE_IMP_STATE & - ,exportState=atm_int_state%CORE_EXP_STATE & - ,clock =atm_int_state%CLOCK_ATM & - ,phase =ESMF_SINGLEPHASE & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - IF(RC_INIT==ESMF_SUCCESS)THEN -! WRITE(0,*)' ATM_INITIALIZE succeeded' - ELSE - WRITE(0,*)' ATM_INITIALIZE failed RC_INIT=',RC_INIT - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE ATM_INITIALIZE -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE ATM_RUN(ATM_GRID_COMP & - ,IMP_STATE & - ,EXP_STATE & - ,CLOCK_EARTH & - ,RC_RUN) -! -!----------------------------------------------------------------------- -!*** The Run step of the ATM component. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_GridComp) :: ATM_GRID_COMP !<-- The ATM component - TYPE(ESMF_State) :: IMP_STATE !<-- The ATM import state - TYPE(ESMF_State) :: EXP_STATE !<-- The ATM export state - TYPE(ESMF_Clock) :: CLOCK_EARTH !<-- The Clock of the EARTH component - INTEGER ,INTENT(OUT) :: RC_RUN !<-- Error return code -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER :: RC -! - TYPE(ESMF_Time) :: CURRTIME & - ,STARTTIME -! - TYPE(ESMF_TimeInterval) :: RUNDURATION -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** For the moment, use a direct copy of the EARTH Clock within -!*** the ATM component. -!----------------------------------------------------------------------- -! - atm_int_state%CLOCK_ATM=CLOCK_EARTH -! -!----------------------------------------------------------------------- -!*** Execute the Run step of the selected dynamic core. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Execute the Run step of the CORE component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!JR WRITE(0,*)'DEBUG: ATM_RUN calling fim_run...' -!TBH: This is what the ESMF_GridCompRun() call does, but do *not* -!TBH: call it directly because ESMF_GridCompRun() has needed -!TBH: side-effects. -!TBH call fim_run (atm_int_state%core_grid_comp, atm_int_state%core_imp_state, & -!TBH atm_int_state%core_exp_state, atm_int_state%clock_atm, rc) - CALL ESMF_GridCompRun(gridcomp =atm_int_state%CORE_GRID_COMP & - ,importState=atm_int_state%CORE_IMP_STATE & - ,exportState=atm_int_state%CORE_EXP_STATE & - ,clock =atm_int_state%CLOCK_ATM & - ,phase =ESMF_SINGLEPHASE & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Update the ATMOS clock. -!----------------------------------------------------------------------- - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK = "Update the current time of the ATMOS clock" -! CALL ESMF_LogWrite(MESSAGE_CHECK, ESMF_LOG_INFO, rc = RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock =atm_int_state%CLOCK_ATM & - ,startTime =STARTTIME & - ,runDuration=RUNDURATION & - ,rc =RC) -! - CURRTIME=STARTTIME+RUNDURATION -! - CALL ESMF_ClockSet(clock =atm_int_state%CLOCK_ATM & - ,currTime=CURRTIME & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - IF(RC_RUN==ESMF_SUCCESS)THEN -! WRITE(0,*)' ATM_RUN succeeded' - ELSE - WRITE(0,*)' ATM_RUN failed RC_RUN=',RC_RUN - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE ATM_RUN -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE ATM_FINALIZE(ATM_GRID_COMP & - ,IMP_STATE & - ,EXP_STATE & - ,CLOCK_EARTH & - ,RC_FINALIZE) -! -!----------------------------------------------------------------------- -!*** Finalize the ATM component. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_GridComp) :: ATM_GRID_COMP !<-- The ATM component - TYPE(ESMF_State) :: IMP_STATE !<-- The ATM import state - TYPE(ESMF_State) :: EXP_STATE !<-- The ATM import state - TYPE(ESMF_Clock) :: CLOCK_EARTH !<-- The Clock of the EARTH component - INTEGER ,INTENT(OUT) :: RC_FINALIZE !<-- Error return code -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER :: RC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Execute the Finalize step of the CORE component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompFinalize(gridcomp =atm_int_state%CORE_GRID_COMP & - ,importState=atm_int_state%CORE_IMP_STATE & - ,exportState=atm_int_state%CORE_EXP_STATE & - ,clock =atm_int_state%CLOCK_ATM & - ,phase =ESMF_SINGLEPHASE & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINALIZE) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - IF(RC_FINALIZE==ESMF_SUCCESS)THEN -! WRITE(0,*)' ATM_FINALIZE succeeded' - ELSE - WRITE(0,*)' ATM_FINALIZE failed RC_FINALIZE=',RC_FINALIZE - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE ATM_FINALIZE -! -!----------------------------------------------------------------------- -! - END MODULE module_ATM_GRID_COMP -! -!----------------------------------------------------------------------- diff --git a/src/fim/FIMsrc/fim/framework/nems/module_ATM_INTERNAL_STATE.F90 b/src/fim/FIMsrc/fim/framework/nems/module_ATM_INTERNAL_STATE.F90 deleted file mode 100644 index 14a2d22..0000000 --- a/src/fim/FIMsrc/fim/framework/nems/module_ATM_INTERNAL_STATE.F90 +++ /dev/null @@ -1,47 +0,0 @@ -!TBH: Matches r14147 of https://svnemc.ncep.noaa.gov/projects/nems/trunk/. -!----------------------------------------------------------------------- -! - MODULE module_ATM_INTERNAL_STATE -! -!----------------------------------------------------------------------- -! - USE ESMF_MOD -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: ATM_INTERNAL_STATE & - ,WRAP_ATM_INTERNAL_STATE -! -!----------------------------------------------------------------------- -! - TYPE ATM_INTERNAL_STATE -! - CHARACTER(16) :: CORE -! - TYPE(ESMF_Clock ) :: CLOCK_ATM - TYPE(ESMF_GridComp) :: CORE_GRID_COMP - TYPE(ESMF_State ) :: CORE_IMP_STATE - TYPE(ESMF_State ) :: CORE_EXP_STATE -! - END TYPE ATM_INTERNAL_STATE -! -!----------------------------------------------------------------------- -! - TYPE WRAP_ATM_INTERNAL_STATE -! - TYPE(ATM_INTERNAL_STATE),POINTER :: ATM_INT_STATE -! - END TYPE WRAP_ATM_INTERNAL_STATE -! -!----------------------------------------------------------------------- -! - END MODULE module_ATM_INTERNAL_STATE -! -!----------------------------------------------------------------------- - diff --git a/src/fim/FIMsrc/fim/framework/nems/module_DYNAMICS_GRID_COMP.F90 b/src/fim/FIMsrc/fim/framework/nems/module_DYNAMICS_GRID_COMP.F90 deleted file mode 100644 index 90495f8..0000000 --- a/src/fim/FIMsrc/fim/framework/nems/module_DYNAMICS_GRID_COMP.F90 +++ /dev/null @@ -1,1302 +0,0 @@ -!TODO: DRY out all of this code. Follow NMM "array object" approach -!TODO: developed by Tom Black and I (TBH - we called it the "ownership" -!TODO: proposal) and implemented within NEMS-NMMB by Dusan Jovic. -!----------------------------------------------------------------------- -! - MODULE MODULE_DYNAMICS_GRID_COMP -! -!----------------------------------------------------------------------- -! -!*** THIS MODULE HOLDS THE DYNAMICS REGISTER, INIT, RUN, AND FINALIZE -!*** ROUTINES. THEY ARE CALLED FROM THE FIM GRIDDED COMPONENT -!*** (FIM INITIALIZE CALLS DYNAMICS INITIALIZE, ETC.). -! -!----------------------------------------------------------------------- -! - USE ESMF_MOD -! - USE MODULE_ERR_MSG,ONLY: ERR_MSG,MESSAGE_CHECK -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -#ifdef MANUALGPTL -#include - integer :: ret -#endif - -! TODO: put this in "dyn_internal_state" - TYPE(ESMF_Grid), SAVE :: GRID_FIM_DYN !<-- The ESMF GRID for FIM "nip" dimension - -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: DYN_REGISTER -! -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE DYN_REGISTER(DYN_GRID_COMP,RC_REG) -! -!----------------------------------------------------------------------- -!*** REGISTER THE DYNAMICS COMPONENT'S INITIALIZE, RUN, AND FINALIZE -!*** SUBROUTINE NAMES. -!----------------------------------------------------------------------- -! - TYPE(ESMF_GridComp),INTENT(INOUT) :: DYN_GRID_COMP !<-- The Dynamics gridded component -! - INTEGER,INTENT(OUT) :: RC_REG !<-- Return code for Dyn register -! -!----------------------------------------------------------------------- -!*** LOCAL VARIABLES -!----------------------------------------------------------------------- -! - INTEGER :: RC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC_REG=ESMF_SUCCESS !<-- Initialize error signal variable - -!----------------------------------------------------------------------- -!*** REGISTER THE DYNAMICS INITIALIZE SUBROUTINE. SINCE IT IS JUST ONE -!*** SUBROUTINE, USE ESMF_SINGLEPHASE. THE SECOND ARGUMENT IS -!*** A PRE-DEFINED SUBROUTINE TYPE, SUCH AS ESMF_SETINIT, ESMF_SETRUN, -!*** OR ESMF_SETFINAL. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for Dynamics Initialize" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -#ifdef MANUALGPTL - ret = gptlstart ('ESMF_GridCompSetEntryPoint:dyn_initialize') -#endif - CALL ESMF_GridCompSetEntryPoint(DYN_GRID_COMP & !<-- The gridded component - ,ESMF_SETINIT & !<-- Predefined subroutine type - ,DYN_INITIALIZE & !<-- User's subroutineName - ,ESMF_SINGLEPHASE & !<-- phase - ,RC) -#ifdef MANUALGPTL - ret = gptlstop ('ESMF_GridCompSetEntryPoint:dyn_initialize') -#endif -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** REGISTER THE DYNAMICS RUN SUBROUTINE. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for Dynamics Run" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -#ifdef MANUALGPTL - ret = gptlstart ('ESMF_GridCompSetEntryPoint:dyn_run') -#endif - CALL ESMF_GridCompSetEntryPoint(DYN_GRID_COMP & !<-- gridcomp - ,ESMF_SETRUN & !<-- subroutineType - ,DYN_RUN & !<-- user's subroutineName - ,ESMF_SINGLEPHASE & !<-- phase - ,RC) -#ifdef MANUALGPTL - ret = gptlstop ('ESMF_GridCompSetEntryPoint:dyn_run') -#endif -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** REGISTER THE DYNAMICS FINALIZE SUBROUTINE. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for Dynamics Finalize" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSetEntryPoint(DYN_GRID_COMP & !<-- gridcomp - ,ESMF_SETFINAL & !<-- subroutineType - ,DYN_FINALIZE & !<-- user's subroutineName - ,ESMF_SINGLEPHASE & !<-- phase - ,RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** CHECK THE ERROR SIGNAL VARIABLE. -!----------------------------------------------------------------------- -! - IF(RC_REG==ESMF_SUCCESS)THEN -! WRITE(0,*)" DYN_REGISTER SUCCEEDED" - ELSE - WRITE(0,*)" DYN_REGISTER FAILED" - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE DYN_REGISTER -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE DYN_INITIALIZE(DYN_GRID_COMP & - ,IMP_STATE,EXP_STATE & - ,CLOCK_FIM & - ,RC_INIT) -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** CARRY OUT ALL NECESSARY SETUPS FOR THE MODEL DYNAMICS. -! This includes creating the FIM ESMF_Grid and attaching it to dyn_grid_comp. -!----------------------------------------------------------------------- -! - use module_control,only: nip,nvl - USE module_fim_dyn_init ,only: DYN_INITIALIZE_FIM => dyn_init - use module_variables,only: us3d,vs3d,pr3d,tr3d,ws3d - use module_sfc_variables,only: rn2d,rc2d,ts2d,us2d,hf2d,qf2d, & - sheleg2d, canopy2d, hice2d, fice2d, & - st3d, sm3d, sw2d, lw2d, t2m2d, q2m2d, & - slmsk2d, hprm2d, flxlwtoa2d -! -!----------------------------------------------------------------------- -!*** ARGUMENT VARIABLES. -!----------------------------------------------------------------------- -! - TYPE(ESMF_GridComp),INTENT(INOUT) :: DYN_GRID_COMP !<-- The Dynamics gridded component - TYPE(ESMF_State), INTENT(INOUT) :: IMP_STATE !<-- The Dynamics Initialize step's import state - TYPE(ESMF_State), INTENT(INOUT) :: EXP_STATE !<-- The Dynamics Initialize step's export state - TYPE(ESMF_Clock), INTENT(IN) :: CLOCK_FIM !<-- The FIM's ESMF Clock -! - INTEGER, INTENT(OUT) :: RC_INIT -! -!----------------------------------------------------------------------- -!*** LOCAL VARIABLES -!----------------------------------------------------------------------- -! - ! temporary field object -! TYPE(ESMF_Field) :: TMP_FIELD - TYPE(ESMF_DistGrid) :: DISTGRID - TYPE(ESMF_Array) :: TMP_ARRAY - type(esmf_vm),save :: vm_local ! TODO: is SAVE needed? - INTEGER :: NUM_PES_FCST,mype - INTEGER :: RC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** INITIALIZE THE ERROR SIGNAL VARIABLES. -!----------------------------------------------------------------------- -! -#ifdef MANUALGPTL - ret = gptlstart ('dyn_initialize') -#endif - - RC =ESMF_SUCCESS - RC_INIT=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** PRIMARY INITIALIZATION OF SCALARS/ARRAYS. -!*** Also sets up SMS decomposition. -!----------------------------------------------------------------------- -! -#ifdef MANUALGPTL - ret = gptlstart ('dyn_init') -#endif - CALL DYN_INITIALIZE_FIM(.false.) -#ifdef MANUALGPTL - ret = gptlstop ('dyn_init') -#endif -! -!----------------------------------------------------------------------- -!*** CREATE THE ESMF GRID. -!----------------------------------------------------------------------- -! Create ESMF_Grid and attach it to dyn_grid_comp. -!TBH: For FIM grid creation the ESMF_Grid is currently a dummy. This -!TBH: routine creates a bogus grid and distributes it across the -!TBH: correct number of FIM compute tasks. It then attaches it to -!TBH: dyn_grid_comp. -! TODO: Match decomposition to SMS. -! TODO: Load lat-lon into this grid for later extraction by PHY, -! TODO: may have to defer this to newer ESMF version! -!----------------------------------------------------------------------- -! -#ifdef MANUALGPTL - ret = gptlstart ('ESMF_gridcreate') -#endif -!TODO: Match decomposition to SMS via new args passed out of -!TODO: DYN_INITIALIZE_FIM. -!TODO: Replace with a real icos constructor once we switch to a version -!TODO: of ESMF that supports it. -!TODO: Load lat-lon into this grid for later extraction by PHY, -!TODO: may have to defer this to newer ESMF version! - - call esmf_gridcompget(gridcomp=dyn_grid_comp, vm=vm_local, rc=rc) - CALL err_msg(RC,"DYN_INITIALIZE: get local vm",rc_init) - call esmf_vmget(vm=vm_local, pecount=NUM_PES_FCST, localpet=mype,& - rc=rc) - CALL err_msg(RC,"DYN_INITIALIZE: get NUM_PES_FCST",rc_init) - -!TODO: Add deBlockList to specify start and end indicies for each MPI task, -!TODO: need NUM_PES_FCST for deBlockList(0:NUM_PES_FCST-1) ... - ! Create "1D" ESMF_DistGrid per ESMF Reference Manual section 26.2.1 - DISTGRID=ESMF_DistGridCreate(minIndex=(/1/),maxIndex=(/nip/), & - rc=rc_init) - CALL err_msg(RC,"DYN_INITIALIZE: create DISTGRID",rc_init) - - ! Create "1D" ESMF_Grid from ESMF_DistGrid - GRID_FIM_DYN=ESMF_GridCreate(name="FIM_GRID",distgrid=DISTGRID, & - rc=rc_init) - CALL err_msg(RC,"DYN_INITIALIZE: create GRID from DISTGRID", & - rc_init) -#ifdef MANUALGPTL - ret = gptlstop ('ESMF_gridcreate') -#endif - - call esmf_gridvalidate(grid=GRID_FIM_DYN, rc=RC) - CALL ERR_MSG(RC,"DYN_INITIALIZE: Validate new GRID",RC_INIT) - -!TODO: Add guard to prevent memory leak if parent has already attached -!TODO: an ESMF_Grid to dyn_grid_comp. - ! attach ESMF_Grid to ESMF_GridComp - call esmf_gridcompset(dyn_grid_comp, grid=grid_fim_dyn, & - rc=rc) - CALL err_msg(rc, "attach FIM grid to DYN component", & - rc_init) -! -!----------------------------------------------------------------------- -!*** Attach FIM fields in the internal state -!*** to the esmf import and export states. -!TBH: I use GFS naming conventions, *not* NMMB conventions. As -!TBH: of NEMS r3038 they do indeed differ, by case at least! -!TBH: Creation of unique ESMF_Field objects for import and export -!TBH: states should require little additional memory since the pointers -!TBH: to Fortran arrays are shared. This approach makes object deletion -!TBH: easier. -!------------------------------------------------------- - -!TODO: Implement esmf_sta_list to allow config control of coupling once -!TODO: this settles down between NMMB and GFS in NEMS. - -!TODO: Need to add gridToFieldMap to ESMF_FieldCreate() to address -!TODO: differences between 2D and 3D arrays. At present this is -!TODO: irrelevant since we do not use ESMF to do any re-grid or -!TODO: re-dist operations. This must be fixed before we use these -!TODO: ESMF features. - -! -! pr3d -! - MESSAGE_CHECK="Create pr3d array for import state" - ! create the ESMF_Field -!TBH: Note that the following call to ESMF_FieldCreate() yields the -!TBH: stunningly informative error code 540 which maps to string -!TBH: "Not valid" in ESMC_ErrMsgs.C. Backed off to ESMF_ArrayCreate(). -!TODO: Switch back to ESMF_FieldCreate() since future NEMS will use -!TODO: ESMF_Fields. -! TMP_FIELD=ESMF_FieldCreate(grid =grid_fim_dyn & -! ,farray =pr3d & -! ,distgridToArrayMap=(/2/) & -! ,name ='pr3d' & -! ,rc =RC) -#ifdef MANUALGPTL - ret = gptlstart ('esmf_arraycreate') -#endif - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =pr3d & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='pr3d' & - ,rc =RC) -#ifdef MANUALGPTL - ret = gptlstop ('esmf_arraycreate') -#endif - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add pr3d array to import state" -#ifdef MANUALGPTL - ret = gptlstart ('esmf_stateadd') -#endif - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) -#ifdef MANUALGPTL - ret = gptlstop ('esmf_stateadd') -#endif - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create pr3d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =pr3d & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='pr3d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add pr3d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! us3d -! - MESSAGE_CHECK="Create us3d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =us3d & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='us3d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add us3d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create us3d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =us3d & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='us3d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add us3d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! vs3d -! - MESSAGE_CHECK="Create vs3d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =vs3d & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='vs3d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add vs3d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create vs3d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =vs3d & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='vs3d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add vs3d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! ws3d -! - MESSAGE_CHECK="Create ws3d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =ws3d & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='ws3d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add ws3d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create ws3d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =ws3d & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='ws3d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add ws3d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! tr3d -! - MESSAGE_CHECK="Create tr3d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =tr3d & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='tr3d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add tr3d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create tr3d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =tr3d & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='tr3d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add tr3d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! rn2d -! - MESSAGE_CHECK="Create rn2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =rn2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='rn2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add rn2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create rn2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =rn2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='rn2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add rn2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! rc2d -! - MESSAGE_CHECK="Create rc2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =rc2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='rc2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add rc2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create rc2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =rc2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='rc2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add rc2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! ts2d -! - MESSAGE_CHECK="Create ts2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =ts2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='ts2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add ts2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create ts2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =ts2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='ts2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add ts2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! us2d -! - MESSAGE_CHECK="Create us2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =us2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='us2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add us2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create us2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =us2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='us2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add us2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! hf2d -! - MESSAGE_CHECK="Create hf2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =hf2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='hf2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add hf2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create hf2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =hf2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='hf2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add hf2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! qf2d -! - MESSAGE_CHECK="Create qf2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =qf2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='qf2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add qf2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create qf2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =qf2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='qf2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add qf2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! sheleg2d -! - MESSAGE_CHECK="Create sheleg2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =sheleg2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='sheleg2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add sheleg2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create sheleg2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =sheleg2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='sheleg2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add sheleg2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! canopy2d -! - MESSAGE_CHECK="Create canopy2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =canopy2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='canopy2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add canopy2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create canopy2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =canopy2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='canopy2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add canopy2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! hice2d -! - MESSAGE_CHECK="Create hice2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =hice2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='hice2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add hice2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create hice2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =hice2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='hice2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add hice2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! fice2d -! - MESSAGE_CHECK="Create fice2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =fice2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='fice2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add fice2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create fice2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =fice2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='fice2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add fice2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! st3d -! - MESSAGE_CHECK="Create st3d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =st3d & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='st3d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add st3d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create st3d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =st3d & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='st3d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add st3d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! sm3d -! - MESSAGE_CHECK="Create sm3d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =sm3d & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='sm3d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add sm3d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create sm3d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =sm3d & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='sm3d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add sm3d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! sw2d -! - MESSAGE_CHECK="Create sw2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =sw2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='sw2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add sw2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create sw2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =sw2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='sw2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add sw2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! lw2d -! - MESSAGE_CHECK="Create lw2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =lw2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='lw2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add lw2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create lw2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =lw2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='lw2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add lw2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! t2m2d -! - MESSAGE_CHECK="Create t2m2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =t2m2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='t2m2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add t2m2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create t2m2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =t2m2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='t2m2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add t2m2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! q2m2d -! - MESSAGE_CHECK="Create q2m2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =q2m2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='q2m2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add q2m2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create q2m2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =q2m2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='q2m2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add q2m2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! slmsk2d -! - MESSAGE_CHECK="Create slmsk2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =slmsk2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='slmsk2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add slmsk2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create slmsk2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =slmsk2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='slmsk2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add slmsk2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! hprm2d -! - MESSAGE_CHECK="Create hprm2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =hprm2d & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='hprm2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add hprm2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create hprm2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =hprm2d & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='hprm2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add hprm2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - -! -! flxlwtoa2d -! - MESSAGE_CHECK="Create flxlwtoa2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =flxlwtoa2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='flxlwtoa2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add flxlwtoa2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create flxlwtoa2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =flxlwtoa2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='flxlwtoa2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add flxlwtoa2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - -!TBH: validate states - MESSAGE_CHECK="DYN_INITIALIZE: Validate import state" - call ESMF_StateValidate(state=IMP_STATE,rc=rc) - IF(RC==ESMF_SUCCESS)THEN -!JR WRITE(0,*)'DYN INITIALIZE import state valid' - ENDIF - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="DYN_INITIALIZE: Validate export state" - call ESMF_StateValidate(state=EXP_STATE,rc=rc) - IF(RC==ESMF_SUCCESS)THEN -!JR WRITE(0,*)'DYN INITIALIZE export state valid' - ENDIF - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - -! - IF(RC_INIT==ESMF_SUCCESS)THEN -! WRITE(0,*)'DYN INITIALIZE STEP SUCCEEDED' - ELSE - WRITE(0,*)'DYN INITIALIZE STEP FAILED RC_INIT=',RC_INIT - ENDIF -! -!----------------------------------------------------------------------- -! -#ifdef MANUALGPTL - ret = gptlstop ('dyn_initialize') -#endif - END SUBROUTINE DYN_INITIALIZE -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE DYN_RUN(DYN_GRID_COMP & - ,IMP_STATE,EXP_STATE & - ,CLOCK_FIM & - ,RC_RUN) -! -!----------------------------------------------------------------------- -!*** THE INTEGRATION OF THE MODEL DYNAMICS IS DONE -!*** THROUGH THIS ROUTINE. -!----------------------------------------------------------------------- -! - USE module_fim_dyn_run ,only: DYN_RUN_FIM => dyn_run -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -!*** ARGUMENT VARIABLES -!----------------------------------------------------------------------- -! - TYPE(ESMF_GridComp),INTENT(INOUT) :: DYN_GRID_COMP !<-- The Dynamics gridded component - TYPE(ESMF_State) ,INTENT(INOUT) :: IMP_STATE !<-- The Dynamics import state - TYPE(ESMF_State) ,INTENT(INOUT) :: EXP_STATE !<-- The Dynamics export state - TYPE(ESMF_Clock) ,INTENT(IN) :: CLOCK_FIM !<-- The FIM's ESMF Clock -! - INTEGER ,INTENT(OUT) :: RC_RUN -! -!----------------------------------------------------------------------- -!*** LOCAL VARIABLES -!----------------------------------------------------------------------- -! - INTEGER :: NTIMESTEP,RC -! - INTEGER(KIND=ESMF_KIND_I8) :: NTIMESTEP_ESMF -! - INTEGER :: its -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -#ifdef MANUALGPTL - ret = gptlstart ('dyn_run') -#endif - RC_RUN=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** EXTRACT THE TIMESTEP COUNT FROM THE CLOCK. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Retrieve Timestep from FIM Clock in Dynamics Run" - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock =CLOCK_FIM & !<-- The ESMF clock - ,advanceCount=NTIMESTEP_ESMF & !<-- The number of times the clock has been advanced - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NTIMESTEP=NTIMESTEP_ESMF -! -! NOTE: Pointers in import and export states point to internal state as -! NOTE: set up in the init phase, consistent with future plans for NEMS. -! NOTE: So wrap%int_state is not needed here at present, nor are explicit -! NOTE: transfers between internal and import/export states. -!TODO: adjust as plans evolve - -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** THE MAIN DYNAMICS INTEGRATION LOOP. -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - its = NTIMESTEP + 1 - CALL DYN_RUN_FIM (its) -! -!----------------------------------------------------------------------- -! - RC=0 -! - IF(RC_RUN==ESMF_SUCCESS)THEN -! WRITE(0,*)'DYN RUN STEP SUCCEEDED' - ELSE - WRITE(0,*)'DYN RUN STEP FAILED RC_RUN=',RC_RUN - ENDIF -! -!----------------------------------------------------------------------- -! -#ifdef MANUALGPTL - ret = gptlstop ('dyn_run') -#endif - END SUBROUTINE DYN_RUN -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE DYN_FINALIZE(DYN_GRID_COMP & - ,IMP_STATE_WRITE & - ,EXP_STATE_WRITE & - ,CLOCK_FIM & - ,RCFINAL) -! -!----------------------------------------------------------------------- -!*** FINALIZE THE DYNAMICS COMPONENT. -!----------------------------------------------------------------------- -! - USE module_fim_dyn_finalize ,only: DYN_FINALIZE_FIM => dyn_finalize -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -!*** ARGUMENT VARIABLES -!----------------------------------------------------------------------- -! - TYPE(ESMF_GridComp),INTENT(INOUT) :: DYN_GRID_COMP !<-- The Dynamics gridded component - TYPE(ESMF_State) ,INTENT(INOUT) :: IMP_STATE_WRITE !<-- The Dynamics import state - TYPE(ESMF_State), INTENT(INOUT) :: EXP_STATE_WRITE !<-- The Dynamics export state - TYPE(ESMF_Clock) ,INTENT(INOUT) :: CLOCK_FIM !<-- The FIM component's ESMF Clock. -! - INTEGER ,INTENT(OUT) :: RCFINAL -! -!----------------------------------------------------------------------- -!*** LOCAL VARIABLES -!----------------------------------------------------------------------- -! - INTEGER :: RC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RCFINAL=ESMF_SUCCESS -! - CALL DYN_FINALIZE_FIM -! - ! destroy the grid created during DYN_INITIALIZE - call ESMF_GridDestroy(GRID_FIM_DYN,rc=rc) - CALL ERR_MSG(RC,"DYN_FINALIZE: destroy GRID_FIM_DYN",RCFINAL) -! -!----------------------------------------------------------------------- -! - END SUBROUTINE DYN_FINALIZE - - - END MODULE MODULE_DYNAMICS_GRID_COMP - diff --git a/src/fim/FIMsrc/fim/framework/nems/module_DYN_PHY_CPL_COMP.F90 b/src/fim/FIMsrc/fim/framework/nems/module_DYN_PHY_CPL_COMP.F90 deleted file mode 100644 index f33bf06..0000000 --- a/src/fim/FIMsrc/fim/framework/nems/module_DYN_PHY_CPL_COMP.F90 +++ /dev/null @@ -1,1224 +0,0 @@ -!JR Copied from fimlatest -!TODO: DRY out all of this code. Initial NEMS was not DRY. We can be. -!----------------------------------------------------------------------- -! - MODULE MODULE_DYN_PHY_CPL_COMP -! -!----------------------------------------------------------------------- -! -!*** THIS MODULE HOLDS THE COUPLER'S REGISTER, INIT, RUN, AND FINALIZE -!*** ROUTINES. THEY ARE CALLED FROM THE FIM GRIDDED COMPONENT -!*** IN module_FIM_GRID_COMP.F90. -! -!*** THE COUPLER PROVIDES 2-WAY COUPLING BETWEEN THE DYNAMICS AND -!*** PHYSICS GRIDDED COMPONENTS BY TRANSFERING THEIR EXPORT AND -!*** IMPORT STATES BETWEEN THE TWO. -! -!----------------------------------------------------------------------- -! - USE ESMF_MOD -! - USE MODULE_ERR_MSG,ONLY: ERR_MSG,MESSAGE_CHECK -!JR module_nems_share doesn't seem to exist anymore. Comment out since we may go to GPTL anyway -!JR USE MODULE_NEMS_SHARE,ONLY : TIMEF - USE MACHINE ,only: kind_evod,kind_phys,kind_rad -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: DYN_PHY_CPL_REGISTER - public :: cpl_initialize !JR Make this public so can call directly -! -!----------------------------------------------------------------------- -! - REAL*8 :: btim0 - REAL*8, PUBLIC :: cpl_dyn_phy_tim -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- - -! Pointers to arrays to be coupled. These pointers are set to point to -! fields in corresponding states prior to use. - -!----------------------------------------------------------------------- -! FIM import state -!----------------------------------------------------------------------- -real,pointer :: fim_imp_us3d(:,:) ! FIM zonal wind (m/s), layer -real,pointer :: fim_imp_vs3d(:,:) ! FIM meridional wind (m/s), layer -real,pointer :: fim_imp_tr3d(:,:,:) ! FIM tracers -real,pointer :: fim_imp_rn2d(:) ! FIM accumulated total precipitation/rainfall -real,pointer :: fim_imp_rc2d(:) ! FIM accumulated convective precipitation/rainfall -real,pointer :: fim_imp_ts2d(:) ! FIM skin temperature -real,pointer :: fim_imp_us2d(:) ! FIM friction velocity/equivalent momentum flux -real,pointer :: fim_imp_hf2d(:) ! FIM sensible heat flux -real,pointer :: fim_imp_qf2d(:) ! FIM water vapor/equivalent latent heat flux -real,pointer :: fim_imp_sheleg2d(:) -real,pointer :: fim_imp_canopy2d(:) -real,pointer :: fim_imp_hice2d(:) -real,pointer :: fim_imp_fice2d(:) -real,pointer :: fim_imp_st3d(:,:) ! FIM soil temperature -real,pointer :: fim_imp_sm3d(:,:) ! FIM soil moisture -real,pointer :: fim_imp_sw2d(:) ! FIM downward short-wave radiation flux -real,pointer :: fim_imp_lw2d(:) ! FIM downward long-wave radiation flux -real,pointer :: fim_imp_t2m2d(:) ! FIM 2-meter temp. -real,pointer :: fim_imp_q2m2d(:) ! FIM 2-meter spfh -real,pointer :: fim_imp_slmsk2d(:) -real,pointer :: fim_imp_hprm2d(:,:) ! FIM soil temperature -real,pointer :: fim_imp_flxlwtoa2d(:) -!----------------------------------------------------------------------- -! FIM export state -!----------------------------------------------------------------------- -real,pointer :: fim_exp_pr3d(:,:) ! FIM pressure (pascal) -real,pointer :: fim_exp_us3d(:,:) ! FIM zonal wind (m/s), layer -real,pointer :: fim_exp_vs3d(:,:) ! FIM meridional wind (m/s), layer -real,pointer :: fim_exp_ws3d(:,:) ! FIM vertical wind (m/s), layer -real,pointer :: fim_exp_tr3d(:,:,:) ! FIM tracers -!----------------------------------------------------------------------- -! GFS import state -!----------------------------------------------------------------------- -real(kind=kind_evod) ,pointer :: gfs_imp_ps(:) -real(kind=kind_evod) ,pointer :: gfs_imp_dp(:,:) -real(kind=kind_evod) ,pointer :: gfs_imp_p(:,:) -real(kind=kind_evod) ,pointer :: gfs_imp_u(:,:) -real(kind=kind_evod) ,pointer :: gfs_imp_v(:,:) -real(kind=kind_evod) ,pointer :: gfs_imp_dpdt(:,:) -real(kind=kind_evod) ,pointer :: gfs_imp_q(:,:) -real(kind=kind_evod) ,pointer :: gfs_imp_oz(:,:) -real(kind=kind_evod) ,pointer :: gfs_imp_cld(:,:) -real(kind=kind_evod) ,pointer :: gfs_imp_t(:,:) -!----------------------------------------------------------------------- -! GFS export state -!----------------------------------------------------------------------- -real(kind=kind_evod) ,pointer :: gfs_exp_p(:,:) -real(kind=kind_evod) ,pointer :: gfs_exp_u(:,:) -real(kind=kind_evod) ,pointer :: gfs_exp_v(:,:) -real(kind=kind_evod) ,pointer :: gfs_exp_q(:,:) -real(kind=kind_evod) ,pointer :: gfs_exp_cld(:,:) -real(kind=kind_evod) ,pointer :: gfs_exp_t(:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_geshem(:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_rainc(:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_tsea(:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_uustar(:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_hflx(:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_evap(:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_sheleg(:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_canopy(:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_hice(:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_fice(:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_stc(:,:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_smc(:,:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_sfcdsw(:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_sfcdlw(:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_t2m(:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_q2m(:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_slmsk(:,:) -real(kind=kind_rad) ,pointer :: gfs_exp_hprime(:,:,:) -real(kind=kind_rad) ,pointer :: gfs_exp_fluxr(:,:,:) - -!----------------------------------------------------------------------- - - CONTAINS -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE DYN_PHY_CPL_REGISTER(CPL_COMP,IRC_REG) -! -!----------------------------------------------------------------------- -!*** REGISTER THE COUPLER COMPONENT'S INITIALIZE, RUN, AND FINALIZE -!*** ROUTINES. -!----------------------------------------------------------------------- -! - TYPE(ESMF_CplComp),INTENT(INOUT) :: CPL_COMP ! Coupler component -! - INTEGER,INTENT(OUT) :: IRC_REG ! Return code for register -! -!----------------------------------------------------------------------- -!*** LOCAL VARIABLES -!----------------------------------------------------------------------- -! - INTEGER :: IRC=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - IRC_REG=ESMF_SUCCESS ! The error signal variable - -!----------------------------------------------------------------------- -!*** REGISTER THE COUPLER INITIALIZE SUBROUTINE. SINCE IT IS JUST ONE -!*** SUBROUTINE, USE ESMF_SINGLEPHASE. THE SECOND ARGUMENT IS -!*** A PRE-DEFINED SUBROUTINE TYPE, SUCH AS ESMF_SETINIT, ESMF_SETRUN, -!*** OR ESMF_SETFINAL. -!----------------------------------------------------------------------- -! - CALL ESMF_LogWrite("Set Entry Point for Coupler Initialize" & - ,ESMF_LOG_INFO,RC=IRC) -! - CALL ESMF_CplCompSetEntryPoint(CPL_COMP & !<-- cplcomp - ,ESMF_SETINIT & !<-- subroutineType - ,CPL_INITIALIZE & !<-- user's subroutineName - ,ESMF_SINGLEPHASE & !<-- phase - ,IRC) -! - IF(ESMF_LogMsgFoundError(IRC,"Set Entry Point for Coupler Initialize"))THEN - IRC_REG=ESMF_FAILURE - WRITE(0,*)'Error Setting the Entry Point for Coupler Initialize, RC =',IRC - IRC=ESMF_SUCCESS - ENDIF -! -!----------------------------------------------------------------------- -!*** REGISTER THE COUPLER RUN SUBROUTINE. -!----------------------------------------------------------------------- -! - CALL ESMF_LogWrite("Set Entry Point for Coupler Run" & - ,ESMF_LOG_INFO,RC=IRC) -! - CALL ESMF_CplCompSetEntryPoint(CPL_COMP & !<-- cplcomp - ,ESMF_SETRUN & !<-- subroutineType - ,CPL_RUN & !<-- user's subroutineName - ,ESMF_SINGLEPHASE & !<-- phase - ,IRC) -! - IF(ESMF_LogMsgFoundError(IRC,"Set Entry Point for Coupler Run"))THEN - IRC_REG=ESMF_FAILURE - WRITE(0,*)'Error Setting the Entry Point for Coupler Run, RC =',IRC - IRC=ESMF_SUCCESS - ENDIF -! -!----------------------------------------------------------------------- -!*** REGISTER THE COUPLER FINALIZE SUBROUTINE. -!----------------------------------------------------------------------- -! - CALL ESMF_LogWrite("Set Entry Point for Coupler Finalize" & - ,ESMF_LOG_INFO,RC=IRC) -! - CALL ESMF_CplCompSetEntryPoint(CPL_COMP & !<-- cplcomp - ,ESMF_SETFINAL & !<-- subroutineType - ,CPL_FINALIZE & !<-- user's subroutineName - ,ESMF_SINGLEPHASE & !<-- phase - ,IRC) -! - IF(ESMF_LogMsgFoundError(IRC,"Set Entry Point for Coupler Finalize"))THEN - IRC_REG=ESMF_FAILURE - WRITE(0,*)'Error Setting the Entry Point for Coupler Finalize, RC =',IRC - ENDIF -! -!----------------------------------------------------------------------- -!*** CHECK THE ERROR SIGNAL VARIABLE. -!----------------------------------------------------------------------- -! - IF(IRC_REG==ESMF_SUCCESS)THEN -! WRITE(0,*)" COUPLER_REGISTER SUCCEEDED" - ELSE - WRITE(0,*)" COUPLER_REGISTER FAILED" - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE DYN_PHY_CPL_REGISTER -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE CPL_INITIALIZE(CPL_COMP,IMP_STATE,EXP_STATE,CLOCK & - ,IRC_CPL) -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** SET UP THE COUPLER. -!----------------------------------------------------------------------- -! - ! FIM dynamics + GFS physics - USE module_fim_cpl_init ,only: CPL_INITIALIZE_FIM_GFS => cpl_init -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -!*** ARGUMENT VARIABLES. -!----------------------------------------------------------------------- -! - TYPE(ESMF_CplComp),INTENT(INOUT) :: CPL_COMP - TYPE(ESMF_State), INTENT(INOUT) :: IMP_STATE - TYPE(ESMF_State), INTENT(INOUT) :: EXP_STATE - TYPE(ESMF_Clock), INTENT(IN) :: CLOCK -! - INTEGER, INTENT(OUT) :: IRC_CPL -! -!----------------------------------------------------------------------- -!*** LOCAL VARIABLES -!----------------------------------------------------------------------- -! - INTEGER :: IRCFINAL -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - cpl_dyn_phy_tim=0. -!----------------------------------------------------------------------- -!*** INITIALIZE THE ERROR SIGNAL VARIABLES. -!----------------------------------------------------------------------- -! - IRCFINAL=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** INITIALIZE THE PHYSICS SCHEMES. -!----------------------------------------------------------------------- -! -!TODO: Note that the latest FIM does delegate creation of the ESMF_Grid to -!TODO: the DYN component. This grid is then used by the FIM and PHY -!TODO: components. However, coordinates are not set in the ESMF_Grid so -!TODO: we still need a better approach for handling lat/lon. -!TODO: -!TODO: We appear to have three cases of interest for handling lat,lon during -!TODO: component initialization: -!TODO: A) PHY runs on the same lat,lon grid as DYN and FIM. ATM also uses -!TODO: this grid (i.e. for coupling with OCN, etc.). -!TODO: B) PHY and DYN run on independent grids. ATM/FIM and DYN share -!TODO: the same grid. -!TODO: C) PHY and DYN run on independent grids. ATM/FIM and PHY share -!TODO: the same grid. -!TODO: NMMB and FIM use case "A". GFS also uses "A" for the physical-space -!TODO: grid. Spectral grids appear to be handled internally to GFS DYN. -!TODO: "B" and "C" are impractical due to the excessive cost of re-gridding -!TODO: full 3D arrays every time step. -!TODO: -!TODO: For FIM, we'd like to have the option of using case "A" with the NCEP -!TODO: GFS physics component. That way we could grab the latest GFS PHY -!TODO: component and hook it up without going into -!TODO: gfs_phy_initialize()->gfs_physics_initialize()->fix_fields()-> -!TODO: LONLAT_PARA() and inserting our own lat,lon computation (or performing -!TODO: some other ugly hackery.) It would make it easier to swap GFS PHY -!TODO: between GFS DYN and FIM DYN. -!TODO: -!TODO: Logic of ESMF_Grid creation in the FIM component now proceeds as -!TODO: follows: -!TODO: 1) The ATM component does not attach an ESMF_Grid to the FIM -!TODO: component. -!TODO: 2) The FIM component does not attach an ESMF_Grid to the DYN -!TODO: component. -!TODO: 3) The DYN component creates an ESMF_Grid and attaches it to -!TODO: itself. DYN does *not* yet fill in lat,lon coordinates. -!TODO: 4) The FIM extracts the ESMF_Grid from the DYN component after -!TODO: dyn_initialize() and attaches it to itself and to the PHY -!TODO: component. -!TODO: 5) The ATM component does not yet use the ESMF_Grid available -!TODO: via the FIM component. -!TODO: -!TODO: Since this pattern is not yet implemented in NEMS, we pass lat,lon -!TODO: from FIM DYN to PHY in cpl_init.F90 via cpl_init_dyn_to_phy(). We -!TODO: need to extend step #3 to include initialization of ESMF_Grid -!TODO: coordinates to pass lat/lon via the ESMF_Grid instead of via -!TODO: ESMF_State objects. Also, step #5 needs to be addressed in the -!TODO: NCEP code to allow ATM to use the ESMF_Grid attached to the -!TODO: FIM/NMMB/GFS component. -!TODO: -!TODO: Also there is a desire to write some of the PHY variables to the FIM -!TODO: history output stream during the first (0h) write. This is currently -!TODO: handled by passing these fields from PHY to DYN via a call to -!TODO: cpl_init_phy_to_dyn(). Future NEMS I/O component(s) may allow this -!TODO: to be handled in another way. -!TODO: - CALL CPL_INITIALIZE_FIM_GFS -! -!----------------------------------------------------------------------- -! - IF(IRCFINAL==ESMF_SUCCESS)THEN -! WRITE(0,*)"CPL INITIALIZE STEP SUCCEEDED" - ELSE - WRITE(0,*)"CPL INITIALIZE STEP FAILED" - ENDIF -! - IRC_CPL=IRCFINAL -! -!----------------------------------------------------------------------- -! - END SUBROUTINE CPL_INITIALIZE -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE CPL_RUN(CPL_COMP,IMP_STATE,EXP_STATE,CLOCK,IRC_CPL) -! -!----------------------------------------------------------------------- -!*** RUN THE COUPLER TO TRANSFER DATA BETWEEN THE GRIDDED COMPONENTS. -!----------------------------------------------------------------------- -! - ! FIM dynamics + GFS physics - USE module_fim_cpl_run ,only: CPL_DYN_TO_PHY, CPL_PHY_TO_DYN - -!TODO: REMOVE THIS use-association! Refactor or replace with ESMF_Alarms - use module_control ,only: nts,CallPhysics - -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -!*** ARGUMENT VARIABLES -!----------------------------------------------------------------------- -! - TYPE(ESMF_CplComp),INTENT(INOUT) :: CPL_COMP - TYPE(ESMF_State), INTENT(INOUT) :: IMP_STATE - TYPE(ESMF_State), INTENT(INOUT) :: EXP_STATE - TYPE(ESMF_Clock), INTENT(IN) :: CLOCK -! - INTEGER, INTENT(OUT) :: IRC_CPL -! -!----------------------------------------------------------------------- -!*** LOCAL VARIABLES -!----------------------------------------------------------------------- -! - INTEGER :: IRCFINAL - INTEGER :: NTIMESTEP,RC - INTEGER(KIND=ESMF_KIND_I8) :: NTIMESTEP_ESMF - INTEGER :: its - character(esmf_maxstr) :: import_statename - character(esmf_maxstr) :: export_statename - ! temporary field object -! TYPE(ESMF_Field) :: TMP_FIELD - TYPE(ESMF_Array) :: TMP_ARRAY -! -! TYPE(ESMF_RouteHandle) :: ROUTEHANDLE -! -!----------------------------------------------------------------------- -!*********************************************************************** -! -!JR btim0=timef() -!----------------------------------------------------------------------- -!*** INITIALIZE THE ERROR SIGNAL VARIABLES. -!----------------------------------------------------------------------- -! - IRCFINAL=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** EXTRACT THE TIMESTEP COUNT FROM THE CLOCK. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Retrieve Timestep from FIM Clock in Physics Run" - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock =CLOCK & !<-- The ESMF clock - ,advanceCount=NTIMESTEP_ESMF & !<-- The number of times the clock has been advanced - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NTIMESTEP=NTIMESTEP_ESMF -! -!----------------------------------------------------------------------- -!*** COUPLE from DYN->PHY or PHY->DYN -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** determine the direction of the transfer by extracting -!*** the statename from the import state. -!----------------------------------------------------------------------- -! - call esmf_logwrite("retrieve state name in coupler" & - ,esmf_log_info,rc=rc) -! - call esmf_stateget(imp_state & - ,name =import_statename & - ,rc =rc) - call esmf_stateget(exp_state & - ,name =export_statename & - ,rc =rc) -! -! print *,'CPL_RUN: move data from(',trim(import_statename), ') to (', & -! trim(export_statename), ')' -! - its = NTIMESTEP + 1 -!TODO: Replace all of this "its" stuff with ESMF_Alarms. -!TODO: Then eliminate dependence on nts and CallPhysics. -!TODO: Note that GFS has no concept of not calling physics every time step! -!TODO: OR, shove "if" statements down into CPL_DYN_TO_PHY and CPL_PHY_TO_DYN - if (its <= nts ) then - !TODO: Eliminate duplication by encapsulating this logic - if(mod(its,CallPhysics)==0.or.its==1) then ! Do physics - ! Note that state names are set in fim_initialize() - if ( (trim(import_statename).eq.'FIM dynamics export') .and. & - (trim(export_statename).eq.'FIM physics import') ) then -! -! extract pointers from ESMF_States and stuff in fim_* and gfs_* pointers -! - MESSAGE_CHECK="Get pr3d array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='pr3d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get pr3d pointer from imported array" -!TBH: Note that the following calls with named parameters causes ifort to -!TBH: complain whine that "There is no matching specific subroutine for -!TBH: this generic subroutine call." Removing the first three dummy -!TBH: argument named makes ifort happy. -! CALL ESMF_FieldGet(field =TMP_FIELD & -! ,localDe=0 & -! ,farrayPtr=fim_exp_pr3d & -! ,rc =RC) -!TBH: Futher note that ESMF_Field did not work for reasons not yet known. -!TBH: (See comments in module_DYNAMICS_GRID_COMP.F90 and -!TBH: module_PHYSICS_GRID_COMP.F90). Switched to ESMF_Array until this -!TBH: problem is resolved. -! CALL ESMF_FieldGet(TMP_FIELD,0,fim_exp_pr3d,rc=RC) -!TODO: Switch back to ESMF_Field since future NEMS will use ESMF_Fields. - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_exp_pr3d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get us3d array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='us3d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get us3d pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_exp_us3d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get vs3d array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='vs3d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get vs3d pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_exp_vs3d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get ws3d array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='ws3d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get ws3d pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_exp_ws3d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get tr3d array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='tr3d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get tr3d pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_exp_tr3d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get ps array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='ps' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get ps pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_imp_ps,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get t array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='t' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get t pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_imp_t,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get u array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='u' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get u pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_imp_u,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get v array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='v' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get v pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_imp_v,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get q array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='shum' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get q pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_imp_q,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get oz array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='oz' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get oz pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_imp_oz,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get cld array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='cld' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get cld pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_imp_cld,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get p array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='p' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get p pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_imp_p,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get dp array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='dp' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get dp pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_imp_dp,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get dpdt array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='dpdt' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get dpdt pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_imp_dpdt,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - ! couple from dynamics to physics - CALL CPL_DYN_TO_PHY(its, & - ! IN args - fim_exp_pr3d, fim_exp_us3d, fim_exp_vs3d, fim_exp_ws3d, & - fim_exp_tr3d, & - ! OUT args - gfs_imp_ps, gfs_imp_dp, gfs_imp_p, gfs_imp_u, gfs_imp_v, & - gfs_imp_dpdt, gfs_imp_q, gfs_imp_oz, gfs_imp_cld, & - gfs_imp_t) - else if ( (trim(import_statename).eq.'FIM physics export') .and. & - (trim(export_statename).eq.'FIM dynamics import') ) then -! -! extract pointers from ESMF_States and stuff in fim_* and gfs_* pointers -! - MESSAGE_CHECK="Get p array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='p' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get p pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_p,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get u array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='u' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get u pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_u,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get v array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='v' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get v pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_v,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get q array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='shum' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get q pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_q,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get cld array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='cld' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get cld pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_cld,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get t array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='t' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get t pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_t,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get geshem array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='geshem' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get geshem pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_geshem,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get rainc array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='rainc' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get rainc pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_rainc,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get tsea array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='tsea' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get tsea pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_tsea,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get uustar array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='uustar' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get uustar pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_uustar,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get hflx array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='hflx' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get hflx pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_hflx,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get evap array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='evap' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get evap pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_evap,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get sheleg array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='sheleg' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get sheleg pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_sheleg,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get canopy array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='canopy' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get canopy pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_canopy,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get hice array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='hice' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get hice pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_hice,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get fice array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='fice' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get fice pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_fice,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get stc array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='stc' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get stc pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_stc,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get smc array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='smc' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get smc pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_smc,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get sfcdsw array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='sfcdsw' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get sfcdsw pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_sfcdsw,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get sfcdlw array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='sfcdlw' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get sfcdlw pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_sfcdlw,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get t2m array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='t2m' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get t2m pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_t2m,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get q2m array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='q2m' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get q2m pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_q2m,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get slmsk array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='slmsk' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get slmsk pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_slmsk,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get hprime array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='hprime' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get hprime pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_hprime,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get fluxr array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='fluxr' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get fluxr pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_fluxr,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - - MESSAGE_CHECK="Get us3d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='us3d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get us3d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_us3d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get vs3d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='vs3d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get vs3d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_vs3d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get tr3d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='tr3d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get tr3d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_tr3d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get rn2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='rn2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get rn2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_rn2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get rc2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='rc2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get rc2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_rc2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get ts2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='ts2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get ts2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_ts2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get us2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='us2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get us2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_us2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get hf2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='hf2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get hf2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_hf2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get qf2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='qf2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get qf2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_qf2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get sheleg2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='sheleg2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get sheleg2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_sheleg2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get canopy2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='canopy2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get canopy2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_canopy2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get hice2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='hice2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get hice2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_hice2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get fice2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='fice2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get fice2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_fice2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get st3d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='st3d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get st3d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_st3d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get sm3d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='sm3d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get sm3d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_sm3d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get sw2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='sw2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get sw2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_sw2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get lw2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='lw2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get lw2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_lw2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get t2m2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='t2m2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get t2m2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_t2m2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get q2m2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='q2m2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get q2m2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_q2m2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get slmsk2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='slmsk2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get slmsk2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_slmsk2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get hprm2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='hprm2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get hprm2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_hprm2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get flxlwtoa2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='flxlwtoa2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get flxlwtoa2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_flxlwtoa2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - ! couple from physics to dynamics - CALL CPL_PHY_TO_DYN(its, & - ! IN args - gfs_exp_p, gfs_exp_u , gfs_exp_v, & - gfs_exp_q, gfs_exp_cld, gfs_exp_t, & - ! these GFS PHY fields are passed to FIM DYN for - ! output and diagnostics only. - gfs_exp_geshem, gfs_exp_rainc, & - gfs_exp_tsea, gfs_exp_uustar, & - gfs_exp_hflx, gfs_exp_evap, & - gfs_exp_sheleg, gfs_exp_canopy, & - gfs_exp_hice, gfs_exp_fice, & - gfs_exp_stc, gfs_exp_smc, & - gfs_exp_sfcdsw, gfs_exp_sfcdlw, & - gfs_exp_t2m, gfs_exp_q2m, & - gfs_exp_slmsk, gfs_exp_hprime, & - gfs_exp_fluxr, & - ! OUT args - fim_imp_us3d, fim_imp_vs3d, & - fim_imp_tr3d, & - fim_imp_rn2d, fim_imp_rc2d, & - fim_imp_ts2d, fim_imp_us2d, & - fim_imp_hf2d, fim_imp_qf2d, & - fim_imp_sheleg2d, fim_imp_canopy2d, & - fim_imp_hice2d, fim_imp_fice2d, & - fim_imp_st3d, fim_imp_sm3d, & - fim_imp_sw2d, fim_imp_lw2d, & - fim_imp_t2m2d, fim_imp_q2m2d, & - fim_imp_slmsk2d, fim_imp_hprm2d, & - fim_imp_flxlwtoa2d ) - else - WRITE(0,*)"ERROR: UNEXPECTED STATE NAME IN CPL_RUN" - IRCFINAL = esmf_failure - endif - - endif ! CallPhysics - - endif -! - IF(IRCFINAL==ESMF_SUCCESS)THEN -! WRITE(0,*)"CPL RUN STEP SUCCEEDED" - ELSE - WRITE(0,*)"CPL RUN STEP FAILED" - ENDIF -! - IRC_CPL=IRCFINAL -! -!JR cpl_dyn_phy_tim=cpl_dyn_phy_tim+timef()-btim0 -! -!----------------------------------------------------------------------- -! - END SUBROUTINE CPL_RUN -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE CPL_FINALIZE(CPL_COMP,IMP_STATE,EXP_STATE,CLOCK,IRC_CPL) -! -!----------------------------------------------------------------------- -!*** FINALIZE THE COUPLER. -!----------------------------------------------------------------------- -! - ! FIM dynamics + GFS physics - USE module_fim_cpl_finalize ,only: CPL_FINALIZE_FIM_GFS => cpl_finalize -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -!*** ARGUMENT VARIABLES. -!----------------------------------------------------------------------- -! - TYPE(ESMF_CplComp),INTENT(INOUT) :: CPL_COMP - TYPE(ESMF_State), INTENT(INOUT) :: IMP_STATE - TYPE(ESMF_State), INTENT(INOUT) :: EXP_STATE - TYPE(ESMF_Clock), INTENT(IN) :: CLOCK -! - INTEGER, INTENT(OUT) :: IRC_CPL -! -!----------------------------------------------------------------------- -!*** LOCAL VARIABLES -!----------------------------------------------------------------------- -! - INTEGER :: IRCFINAL -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - IRCFINAL=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** FINALIZE THE PHYSICS COMPONENT. -!----------------------------------------------------------------------- -! - CALL CPL_FINALIZE_FIM_GFS -! -!----------------------------------------------------------------------- -! - IF(IRCFINAL==ESMF_SUCCESS)THEN -! WRITE(0,*)"CPL FINALIZE STEP SUCCEEDED" - ELSE - WRITE(0,*)"CPL FINALIZE STEP FAILED" - ENDIF -! - IRC_CPL=IRCFINAL -! -!----------------------------------------------------------------------- -! - END SUBROUTINE CPL_FINALIZE -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! - END MODULE MODULE_DYN_PHY_CPL_COMP -! -!----------------------------------------------------------------------- diff --git a/src/fim/FIMsrc/fim/framework/nems/module_EARTH_GRID_COMP.F90 b/src/fim/FIMsrc/fim/framework/nems/module_EARTH_GRID_COMP.F90 deleted file mode 100644 index 535a513..0000000 --- a/src/fim/FIMsrc/fim/framework/nems/module_EARTH_GRID_COMP.F90 +++ /dev/null @@ -1,537 +0,0 @@ -!TBH: Matches r14147 of https://svnemc.ncep.noaa.gov/projects/nems/trunk/. - -#include "./ESMFVersionDefine.h" - -#if (ESMF_MAJOR_VERSION < 5 || ESMF_MINOR_VERSION < 2) -#undef ESMF_520rbs -#else -#define ESMF_520rbs -#endif - -!----------------------------------------------------------------------- -! - MODULE module_EARTH_GRID_COMP -! -!----------------------------------------------------------------------- -!*** This module contains codes directly related to the EARTH component. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! 2010-03-24 Black - Created Earth component module. -! 2010-04 Yang - Added Ensemble capability. -! 2011-05-11 Theurich & Yang - Modified for using the ESMF 5.2.0r_beta_snapshot_07. -!----------------------------------------------------------------------- -! -!*** The EARTH component lies in the heirarchy seen here: -! -! Main program -! | -! | -! NEMS component -! | |________________________. -! | | -! EARTH component Ensemble Coupler component -! | -! | -! ATM/OCEAN/ICE components -! | -! | -! CORE component (GFS, NMM, FIM, GEN, etc.) -! -!----------------------------------------------------------------------- -! - USE ESMF_MOD -! - USE module_EARTH_INTERNAL_STATE,ONLY: EARTH_INTERNAL_STATE & - ,WRAP_EARTH_INTERNAL_STATE -! - USE module_ATM_GRID_COMP -! - USE module_ERR_MSG,ONLY: ERR_MSG,MESSAGE_CHECK -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: EARTH_REGISTER -! -!----------------------------------------------------------------------- -! - TYPE(EARTH_INTERNAL_STATE),POINTER,SAVE :: EARTH_INT_STATE !<-- Internal state of the EARTH component - TYPE(WRAP_EARTH_INTERNAL_STATE) ,SAVE :: WRAP !<-- F90 pointer to the EARTH internal state -! -!----------------------------------------------------------------------- -! - CONTAINS - -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE EARTH_REGISTER(EARTH_GRID_COMP,RC_REG) -! -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_GridComp) :: EARTH_GRID_COMP !<-- The EARTH component - INTEGER ,INTENT(OUT) :: RC_REG !<-- Error return code -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER :: RC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Register the EARTH Initialize, Run, and Finalize routines. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for EARTH Initialize" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -#ifdef ESMF_3 - CALL ESMF_GridCompSetEntryPoint(EARTH_GRID_COMP & !<-- The EARTH component - ,ESMF_SETINIT & !<-- Subroutine type (Initialize) - ,EARTH_INITIALIZE & !<-- User's subroutine name - ,ESMF_SINGLEPHASE & - ,RC) -#else - CALL ESMF_GridCompSetEntryPoint(EARTH_GRID_COMP & !<-- The EARTH component - ,ESMF_SETINIT & !<-- Subroutine type (Initialize) - ,EARTH_INITIALIZE & !<-- User's subroutine name - ,phase=ESMF_SINGLEPHASE & - ,rc=RC) -#endif - -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for EARTH Run" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -#ifdef ESMF_3 - CALL ESMF_GridCompSetEntryPoint(EARTH_GRID_COMP & !<-- The EARTH component - ,ESMF_SETRUN & !<-- Subroutine type (Run) - ,EARTH_RUN & !<-- User's subroutine name - ,ESMF_SINGLEPHASE & - ,RC) -#else - CALL ESMF_GridCompSetEntryPoint(EARTH_GRID_COMP & !<-- The EARTH component - ,ESMF_SETRUN & !<-- Subroutine type (Run) - ,EARTH_RUN & !<-- User's subroutine name - ,phase=ESMF_SINGLEPHASE & - ,rc=RC) -#endif -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for EARTH Finalize" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -#ifdef ESMF_3 - CALL ESMF_GridCompSetEntryPoint(EARTH_GRID_COMP & !<-- The EARTH component - ,ESMF_SETFINAL & !<-- Subroutine type (Finalize) - ,EARTH_FINALIZE & !<-- User's subroutine name - ,ESMF_SINGLEPHASE & - ,RC) -#else - CALL ESMF_GridCompSetEntryPoint(EARTH_GRID_COMP & !<-- The EARTH component - ,ESMF_SETFINAL & !<-- Subroutine type (Finalize) - ,EARTH_FINALIZE & !<-- User's subroutine name - ,phase=ESMF_SINGLEPHASE & - ,rc=RC) -#endif -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - IF(RC_REG==ESMF_SUCCESS)THEN -! WRITE(0,*)' EARTH_REGISTER succeeded' - ELSE - WRITE(0,*)' EARTH_REGISTER failed RC_REG=',RC_REG - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE EARTH_REGISTER -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE EARTH_INITIALIZE(EARTH_GRID_COMP & - ,IMP_STATE & - ,EXP_STATE & - ,CLOCK_NEMS & - ,RC_INIT) -! -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_GridComp) :: EARTH_GRID_COMP !<-- The EARTH component - TYPE(ESMF_State) :: IMP_STATE !<-- The EARTH import state - TYPE(ESMF_State) :: EXP_STATE !<-- The EARTH export state - TYPE(ESMF_Clock) :: CLOCK_NEMS !<-- The Clock of the NEMS component - INTEGER ,INTENT(OUT) :: RC_INIT !<-- Error return code -! -!----------------------------------------------------------------------- -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER :: RC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Allocate the EARTH component's internal state, point at it, -!*** and attach it to the EARTH component. -!----------------------------------------------------------------------- -! - ALLOCATE(EARTH_INT_STATE,stat=RC) - wrap%EARTH_INT_STATE=>EARTH_INT_STATE -! - CALL ESMF_GridCompSetInternalState(EARTH_GRID_COMP & !<--The EARTH component - ,WRAP & !<-- Pointer to the EARTH internal state - ,RC) -! -!----------------------------------------------------------------------- -!*** For the moment, use a direct copy of the NEMS Clock within -!*** the EARTH component. -!----------------------------------------------------------------------- -! - earth_int_state%CLOCK_EARTH=CLOCK_NEMS -! -!----------------------------------------------------------------------- -!*** The ATM (atmosphere) gridded component resides inside of -!*** the EARTH internal state. -!----------------------------------------------------------------------- -! - earth_int_state%ATM_GRID_COMP=ESMF_GridCompCreate(name ="ATM component" & - ,rc =RC) -! -!----------------------------------------------------------------------- -!*** Register the Initialize, Run, and Finalize routines of -!*** the ATM component. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Register ATM Init, Run, Finalize" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -#ifdef ESMF_3 - CALL ESMF_GridCompSetServices(earth_int_state%ATM_GRID_COMP & - ,ATM_REGISTER & !<-- The user's subroutine name - ,RC) -#else - CALL ESMF_GridCompSetServices(earth_int_state%ATM_GRID_COMP & - ,ATM_REGISTER & !<-- The user's subroutine name - ,rc=RC) -#endif -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Create the ATM import and export states. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create the ATM import state" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -#ifdef ESMF_520rbs - earth_int_state%ATM_IMP_STATE=ESMF_StateCreate( NAME="ATM Import" & - ,statetype=ESMF_STATE_IMPORT & - ,rc =RC) -#else - earth_int_state%ATM_IMP_STATE=ESMF_StateCreate(STATENAME="ATM Import" & - ,statetype=ESMF_STATE_IMPORT & - ,rc =RC) -#endif -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create the ATM export state" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -#ifdef ESMF_520rbs - earth_int_state%ATM_EXP_STATE=ESMF_StateCreate( NAME="ATM Export" & - ,statetype=ESMF_STATE_EXPORT & - ,rc =RC) -#else - earth_int_state%ATM_EXP_STATE=ESMF_StateCreate(STATENAME="ATM Export" & - ,statetype=ESMF_STATE_EXPORT & - ,rc =RC) -#endif -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Insert the import/export states of the ATMOS component into the -!*** import/export states of the EARTH component. This simplifies -!*** the passing of information between lower and higher component -!*** levels seen in the diagram above. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK= "Add the ATMOS states into the EARTH states" -! CALL ESMF_LogWrite(MESSAGE_CHECK, ESMF_LOG_INFO, rc = RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateAdd(state = IMP_STATE & - ,nestedState = earth_int_state%ATM_IMP_STATE & - ,rc = RC) -! - CALL ESMF_StateAdd(state = EXP_STATE & - ,nestedState = earth_int_state%ATM_EXP_STATE & - ,rc = RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Execute the Initialize step of the ATM component. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Execute the Initialize step of the ATM component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompInitialize(gridcomp =earth_int_state%ATM_GRID_COMP & - ,importState=earth_int_state%ATM_IMP_STATE & - ,exportState=earth_int_state%ATM_EXP_STATE & - ,clock =earth_int_state%CLOCK_EARTH & - ,phase =ESMF_SINGLEPHASE & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - IF(RC_INIT==ESMF_SUCCESS)THEN -! WRITE(0,*)' EARTH_INITIALIZE succeeded' - ELSE - WRITE(0,*)' EARTH_INITIALIZE failed RC_INIT=',RC_INIT - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE EARTH_INITIALIZE -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE EARTH_RUN(EARTH_GRID_COMP & - ,IMP_STATE & - ,EXP_STATE & - ,CLOCK_NEMS & - ,RC_RUN) -! -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_GridComp) :: EARTH_GRID_COMP !<-- The EARTH component - TYPE(ESMF_State) :: IMP_STATE !<-- The EARTH import state - TYPE(ESMF_State) :: EXP_STATE !<-- The EARTH export state - TYPE(ESMF_Clock) :: CLOCK_NEMS !<-- The Clock of the NEMS component - INTEGER ,INTENT(OUT) :: RC_RUN !<-- Error return code -! -!--------------------- -!*** Local Variables -!--------------------- -! - TYPE(ESMF_Time) :: CURRTIME & - ,STARTTIME -! - TYPE(ESMF_TimeInterval) :: RUNDURATION -! - INTEGER :: RC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RC_RUN=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** Execute the Run step of the ATM component. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Execute the Run step of the ATM component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompRun(gridcomp =earth_int_state%ATM_GRID_COMP & - ,importState=earth_int_state%ATM_IMP_STATE & - ,exportState=earth_int_state%ATM_EXP_STATE & - ,clock =earth_int_state%CLOCK_EARTH & - ,phase =ESMF_SINGLEPHASE & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Update the EARTH clock. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK = "Update the current time of the EARTH clock" -! CALL ESMF_LogWrite(MESSAGE_CHECK, ESMF_LOG_INFO, rc = RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock = earth_int_state%CLOCK_EARTH & - ,startTime = startTime & - ,runDuration = runDuration & - ,rc = RC) -! - CURRTIME = STARTTIME + RUNDURATION -! - CALL ESMF_ClockSet(clock = earth_int_state%CLOCK_EARTH & - ,currTime = CURRTIME & - ,rc = RC) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - IF(RC_RUN==ESMF_SUCCESS)THEN -! WRITE(0,*)' EARTH_RUN succeeded' - ELSE - WRITE(0,*)' EARTH_RUN failed RC_RUN=',RC_RUN - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE EARTH_RUN -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE EARTH_FINALIZE(EARTH_GRID_COMP & - ,IMP_STATE & - ,EXP_STATE & - ,CLOCK_NEMS & - ,RC_FINALIZE) -! -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_GridComp) :: EARTH_GRID_COMP !<-- The EARTH component - TYPE(ESMF_State) :: IMP_STATE !<-- The EARTH import state - TYPE(ESMF_State) :: EXP_STATE !<-- The EARTH export state - TYPE(ESMF_Clock) :: CLOCK_NEMS !<-- The Clock of the NEMS component - INTEGER ,INTENT(OUT) :: RC_FINALIZE !<-- Error return code -! -!--------------------- -!*** Local Variables -!--------------------- -! -!----------------------------------------------------------------------- -! - INTEGER :: RC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Execute the Finalize step of the ATM ccomponent. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Execute the Finalize step of the ATM component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompFinalize(gridcomp =earth_int_state%ATM_GRID_COMP & - ,importState=earth_int_state%ATM_IMP_STATE & - ,exportState=earth_int_state%ATM_EXP_STATE & - ,clock =earth_int_state%CLOCK_EARTH & - ,phase =ESMF_SINGLEPHASE & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINALIZE) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - IF(RC_FINALIZE==ESMF_SUCCESS)THEN -! WRITE(0,*)' EARTH_FINALIZE succeeded' - ELSE - WRITE(0,*)' EARTH_FINALIZE failed RC_FINALIZE=',RC_FINALIZE - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE EARTH_FINALIZE -! -!----------------------------------------------------------------------- -! - END MODULE module_EARTH_GRID_COMP -! -!----------------------------------------------------------------------- diff --git a/src/fim/FIMsrc/fim/framework/nems/module_EARTH_INTERNAL_STATE.F90 b/src/fim/FIMsrc/fim/framework/nems/module_EARTH_INTERNAL_STATE.F90 deleted file mode 100644 index 3b584a2..0000000 --- a/src/fim/FIMsrc/fim/framework/nems/module_EARTH_INTERNAL_STATE.F90 +++ /dev/null @@ -1,55 +0,0 @@ -!TBH: Matches r14147 of https://svnemc.ncep.noaa.gov/projects/nems/trunk/. -!----------------------------------------------------------------------- -! - MODULE module_EARTH_INTERNAL_STATE -! -!----------------------------------------------------------------------- -!*** Contents of the ESMF internal state of the EARTH component. -!----------------------------------------------------------------------- -! - USE ESMF_MOD -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: EARTH_INTERNAL_STATE & - ,WRAP_EARTH_INTERNAL_STATE -! -!----------------------------------------------------------------------- -! - TYPE EARTH_INTERNAL_STATE -! - TYPE(ESMF_Clock ) :: CLOCK_EARTH -! - TYPE(ESMF_GridComp) :: ATM_GRID_COMP - TYPE(ESMF_State ) :: ATM_IMP_STATE - TYPE(ESMF_State ) :: ATM_EXP_STATE -! - TYPE(ESMF_GridComp) :: OCEAN_GRID_COMP - TYPE(ESMF_State ) :: OCEAN_IMP_STATE - TYPE(ESMF_State ) :: OCEAN_EXP_STATE -! - TYPE(ESMF_GridComp) :: ICE_GRID_COMP - TYPE(ESMF_State ) :: ICE_IMP_STATE - TYPE(ESMF_State ) :: ICE_EXP_STATE -! - END TYPE EARTH_INTERNAL_STATE -! -!----------------------------------------------------------------------- -! - TYPE WRAP_EARTH_INTERNAL_STATE -! - TYPE(EARTH_INTERNAL_STATE),POINTER :: EARTH_INT_STATE -! - END TYPE WRAP_EARTH_INTERNAL_STATE -! -!----------------------------------------------------------------------- -! - END MODULE module_EARTH_INTERNAL_STATE -! -!----------------------------------------------------------------------- diff --git a/src/fim/FIMsrc/fim/framework/nems/module_ERR_MSG.F90 b/src/fim/FIMsrc/fim/framework/nems/module_ERR_MSG.F90 deleted file mode 100644 index ce07c30..0000000 --- a/src/fim/FIMsrc/fim/framework/nems/module_ERR_MSG.F90 +++ /dev/null @@ -1,151 +0,0 @@ -!JR Rev. 11555 of NEMS repo. -! -! !description: error messages -! -! !revision history: -! -! january 2007 hann-ming henry juang -! -! -! !interface: -! - module module_err_msg - -! -!!uses: -! - use esmf_mod - - implicit none - - private - public :: err_msg,message_check,set_iprint - -!TODO: Talk with NCEP about new "iprint:" field in config file and -!TODO: setting module_ERR_MSG::iprint at run-time from MAIN_NEMS.F90. -!TODO: Note that GFS has its own version of this module that differs -!TODO: slightly (as of nems r12470). - - logical :: iprint = .false. - character(esmf_maxstr) :: message_check - - contains - - ! allow verbosity to be adjusted at run-time - subroutine set_iprint(val) - logical, intent(in) :: val - iprint = val - end subroutine set_iprint - - subroutine err_msg_int(rc1,msg,val,rcfinal) -! - integer, intent(inout) :: rc1 - integer, intent(out) :: rcfinal - character (len=*), intent(in) :: msg - integer, intent(in) :: val - if(esmf_logmsgfounderror(rc1, msg)) then - rcfinal = esmf_failure - print*, 'error happened for ',msg,' ',val,' rc = ', rc1 - write(0,*)' ERROR: ',msg,' ',val,' rc = ', rc1 - rc1 = esmf_success - else - if(iprint) print*, 'pass ',msg,' ',val - end if - return - end subroutine err_msg_int - - subroutine err_msg_val(rc1,msg,val,rcfinal) -! - integer, intent(inout) :: rc1 - integer, intent(out) :: rcfinal - character (len=*), intent(in) :: msg - real, intent(in) :: val - if(esmf_logmsgfounderror(rc1, msg)) then - rcfinal = esmf_failure - print*, 'error happened for ',msg,' ',val,' rc = ', rc1 - write(0,*)' ERROR: ',msg,' ',val,' rc = ', rc1 - rc1 = esmf_success - else - if(iprint) print*, 'pass ',msg,' ',val - end if - return - end subroutine err_msg_val - - subroutine err_msg_var(rc1,msg,chr,rcfinal) -! - integer, intent(inout) :: rc1 - integer, intent(out) :: rcfinal - character (len=*), intent(in) :: msg - character (len=*), intent(in) :: chr - if(esmf_logmsgfounderror(rc1, msg)) then - rcfinal = esmf_failure - print*, 'error happened for ',msg,' ',chr,' rc = ', rc1 - write(0,*)' ERROR: ',msg,' ',chr,' rc = ', rc1 - rc1 = esmf_success - else - if(iprint) print*, 'pass ',msg,' ',chr - end if - return - end subroutine err_msg_var - - subroutine err_msg(rc1,msg,rc) - ! use-association to make prints more informative - use module_core_setup,only:core_setup_done,iam_fim_task, & - iam_write_task,world_rank - integer, intent(inout) :: rc1 - integer, intent(out) :: rc - character (len=*), intent(in) :: msg - character (len=10) :: task_type - if (iam_fim_task) then - task_type="compute" - else if (iam_write_task) then - task_type="write" - else - task_type="do-nothing" - endif - if(esmf_logmsgfounderror(rc1, msg)) then - rc = esmf_failure - if (core_setup_done) then - write(6,'(3a,i0,3a,i0)') & - 'ERROR [',trim(task_type),' task:',world_rank, & - '] ',trim(msg),' rc = ',rc1 - write(0,'(3a,i0,3a,i0)') & - 'ERROR [',trim(task_type),' task:',world_rank, & - '] ',trim(msg),' rc = ',rc1 - else - write(6,'(3a,i0)') 'ERROR ',trim(msg),' rc = ',rc1 - write(0,'(3a,i0)') 'ERROR ',trim(msg),' rc = ',rc1 - endif - rc1 = esmf_success - else - rc = esmf_success - if (iprint) then - if (core_setup_done) then - write(6,'(3a,i0,2a)') & - 'pass [',trim(task_type),' task:',world_rank, & - '] ',trim(msg) - else - write(6,'(2a)') 'pass ',trim(msg) - endif - endif - end if - return - end subroutine err_msg - - subroutine err_msg_final(rcfinal,msg,rc) - integer, intent(inout) :: rcfinal - integer, intent(inout) :: rc - character (len=*), intent(in) :: msg - if(rcfinal == esmf_success) then - if(iprint) print*, "final pass: ",msg - else - print*, "final fail: ",msg - write(0,*)' FINAL ERROR: ',msg - end if -! if(present(rc)) then - rc = rcfinal -! end if - return - end subroutine err_msg_final - - end module module_err_msg diff --git a/src/fim/FIMsrc/fim/framework/nems/module_FIM_INTEGRATE.F90 b/src/fim/FIMsrc/fim/framework/nems/module_FIM_INTEGRATE.F90 deleted file mode 100644 index bb6db76..0000000 --- a/src/fim/FIMsrc/fim/framework/nems/module_FIM_INTEGRATE.F90 +++ /dev/null @@ -1,157 +0,0 @@ -module module_FIM_INTEGRATE - use esmf_mod - use module_err_msg - - ! TODO: move this to internal state - use module_core_setup ,only: use_write_tasks - ! TODO: not sure if this needs to move - use icosio,only:icosio_end_frame - - implicit none - private - - public :: fim_integrate - -CONTAINS - -! only FIM compute tasks execute this routine - subroutine fim_integrate (gc_fim_dyn, & - gc_fim_phy, & - gc_fim_cpl, & - imp_fim_dyn, & - exp_fim_dyn, & - imp_fim_phy, & - exp_fim_phy, & - clock_fim, & - rc_integrate) - - type(esmf_gridcomp), intent(inout) :: gc_fim_dyn - type(esmf_gridcomp), intent(inout) :: gc_fim_phy - type(esmf_cplcomp), intent(inout) :: gc_fim_cpl - type(esmf_state), intent(inout) :: imp_fim_dyn - type(esmf_state), intent(inout) :: exp_fim_dyn - type(esmf_state), intent(inout) :: imp_fim_phy - type(esmf_state), intent(inout) :: exp_fim_phy - type(esmf_clock), intent(inout) :: clock_fim - integer, intent( out) :: rc_integrate -! -! Local variables -! - integer :: rc - integer(esmf_kind_i8) :: ntimestep_esmf - integer :: ntimestep - type(esmf_timeinterval) :: timestep - type(esmf_time) :: stoptime, newstoptime - - ! Run the clock one more time step (i.e. stop after its=nts+1), then - ! back up one step to mimic run.F90. - ! * set stoptime = stoptime+dt - ! * run "integrate" loop - ! * set ESMF_MODE_REVERSE - ! * advance backwards one time step - ! * set ESMF_MODE_FORWARD - ! * reset stoptime to its original value - !NOTE: This hackery works around the fact that the original - !NOTE: FIM run.F90 executes one extra time step in which the - !NOTE: dynamics component finishes its final computations. This - !NOTE: was required by early versions of NEMS which did not - !NOTE: allow multiple run phases. See run.F90 for a very - !NOTE: detailed discussion of this issue. - !NOTE: This complexity could be avoided if we allowed a 2-phase - !NOTE: run method for the DYN component -- and run.F90 would - !NOTE: also be simplified. However, interoperability with other - !NOTE: components would be more difficult due to potential - !NOTE: mismatches in numbers of phases. - - call esmf_clockget (clock=clock_fim, stoptime=stoptime, rc=rc) - call err_msg (rc,'esmf_clockget(stoptime)', rc_integrate) - call esmf_clockget (clock=clock_fim, timestep=timestep, rc=rc) - call err_msg (rc,'esmf_clockget(timestep)', rc_integrate) - newstoptime = stoptime + timestep - call esmf_clockset(clock=clock_fim, stoptime=newstoptime, rc=rc) - call err_msg (rc,'esmf_clockset(newstoptime)', rc_integrate) - - integrate: do while (.not. esmf_clockisstoptime (clock_fim, rc=rc)) - call err_msg (rc,'esmf_clockisstoptime', rc_integrate) -! -!----------------------------------------------------------------------- -!*** Execute the Run step of the Dynamics component. -!----------------------------------------------------------------------- -! - call esmf_logwrite("execute fim dynamics", esmf_log_info, rc=rc) - call esmf_gridcomprun (gridcomp =gc_fim_dyn, & - importstate=imp_fim_dyn, & - exportstate=exp_fim_dyn, & - clock =clock_fim, & - rc =rc) - call err_msg (rc,'execute fim dynamics', rc_integrate) -! -!----------------------------------------------------------------------- -!*** Bring export data from the Dynamics into the coupler -!*** and export it to the Physics. -!----------------------------------------------------------------------- -! - call esmf_logwrite ("couple dyn_exp-to-phy_imp", esmf_log_info, rc=rc) - call esmf_cplcomprun (cplcomp =gc_fim_cpl, & - importstate=exp_fim_dyn, & - exportstate=imp_fim_phy, & - clock =clock_fim, & - rc =rc) - call err_msg (rc,'couple dyn_exp-to-phy_imp', rc_integrate) -! -!----------------------------------------------------------------------- -!*** Execute the Run step of the Physics Component. -!----------------------------------------------------------------------- -! - call esmf_logwrite ("execute physics", esmf_log_info, rc=rc) - call esmf_gridcomprun (gridcomp =gc_fim_phy, & - importstate=imp_fim_phy, & - exportstate=exp_fim_phy, & - clock =clock_fim, & - rc =rc) - call err_msg (rc, 'execute physics', rc_integrate) -! -!----------------------------------------------------------------------- -!*** Bring export data from the Physics into the coupler -!*** and export it to the Dynamics. -!----------------------------------------------------------------------- -! - call esmf_logwrite ("couple phy_exp-to-dyn_imp", esmf_log_info, rc=rc) - call esmf_cplcomprun (cplcomp =gc_fim_cpl, & - importstate=exp_fim_phy, & - exportstate=imp_fim_dyn, & - clock =clock_fim, & - rc =rc) - call err_msg (rc, 'couple phy_exp-to-dyn_imp', rc_integrate) -! -!----------------------------------------------------------------------- -!*** Flush buffered output to write tasks and/or clear list of files -!*** written to during this output frame. -!----------------------------------------------------------------------- -! - call esmf_clockget (clock=clock_fim,advancecount=ntimestep_esmf,rc=rc) - call err_msg (rc, 'get time step from clock', rc_integrate) - ntimestep = ntimestep_esmf - call icosio_end_frame(ntimestep) -! -!----------------------------------------------------------------------- -!*** Advance clock to next time step. -!----------------------------------------------------------------------- -! - call esmf_clockadvance (clock=clock_fim, rc=rc) - call err_msg (rc, 'advance clock', rc_integrate) - - end do integrate ! time step loop - - ! reset clock to state expected by caller upon return - call esmf_clockset(clock=clock_fim, direction=ESMF_MODE_REVERSE, rc=rc) - call err_msg (rc,'esmf_clockset(ESMF_MODE_REVERSE)', rc_integrate) - call esmf_clockadvance(clock=clock_fim, rc=rc) - call err_msg (rc,'esmf_clockadvance(one step backwards)', rc_integrate) - call esmf_clockset(clock=clock_fim, direction=ESMF_MODE_FORWARD, rc=rc) - call err_msg (rc,'esmf_clockset(ESMF_MODE_FORWARD)', rc_integrate) - call esmf_clockset(clock=clock_fim, stoptime=stoptime, rc=rc) - call err_msg (rc,'esmf_clockset(restore original stoptime)', rc_integrate) - - end subroutine fim_integrate -end module module_FIM_INTEGRATE diff --git a/src/fim/FIMsrc/fim/framework/nems/module_NEMS_GRID_COMP.F90 b/src/fim/FIMsrc/fim/framework/nems/module_NEMS_GRID_COMP.F90 deleted file mode 100644 index 101372e..0000000 --- a/src/fim/FIMsrc/fim/framework/nems/module_NEMS_GRID_COMP.F90 +++ /dev/null @@ -1,1098 +0,0 @@ -!TBH: Matches r14147 of https://svnemc.ncep.noaa.gov/projects/nems/trunk/ -!TBH: except for pe_member issues noted below. -!JR commenting out the setting of pe_member so ESMF can stop on failure, - -#include "./ESMFVersionDefine.h" - -#if (ESMF_MAJOR_VERSION < 5 || ESMF_MINOR_VERSION < 2) -#undef ESMF_520rbs -#else -#define ESMF_520rbs -#endif - -!----------------------------------------------------------------------- -! - MODULE module_NEMS_GRID_COMP -! -!----------------------------------------------------------------------- -!*** This module contains codes directly related to the NEMS component. -!----------------------------------------------------------------------- -! -!*** The NEMS component lies in the heirarchy seen here: -! -! Main program -! | -! | -! NEMS component -! | |________________________. -! | | -! EARTH component Ensemble Coupler component -! | -! | -! ATM/OCEAN/ICE components -! | -! | -! CORE component (GFS, NMM, FIM, GEN, etc.) -! -!----------------------------------------------------------------------- -! 2011-05-11 Theurich & Yang - Modified for using the ESMF 5.2.0r_beta_snapshot_07. -!----------------------------------------------------------------------- -! - USE ESMF_MOD -! - USE module_NEMS_INTERNAL_STATE,ONLY: NEMS_INTERNAL_STATE & - ,WRAP_NEMS_INTERNAL_STATE -! - USE ENS_CplComp_ESMFMod,ONLY: ENS_CplCompSetServices -! - USE module_EARTH_GRID_COMP -! - USE module_ERR_MSG,ONLY: ERR_MSG,MESSAGE_CHECK -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: NEMS_REGISTER -! -!----------------------------------------------------------------------- -! - INTEGER :: MEMBER_ID & - ,TOTAL_MEMBER -! - INTEGER :: HH_INCREASE & - ,HH_START & - ,HH_FINAL -! - INTEGER :: NUMBER_START & - ,NUMBER_FINAL -! - INTEGER,DIMENSION(:), ALLOCATABLE :: PE_MEMBER !<-- Tasks for each member - INTEGER,DIMENSION(:, :),ALLOCATABLE :: PETLIST !<-- Task list for each member -! - LOGICAL :: ENS_SPS !<-- Control of Stochastic Perturbation Scheme (SPS) -! - CHARACTER(ESMF_MAXSTR),DIMENSION(:),ALLOCATABLE :: IMP_EARTH_NAME !<-- Import state name of the EARTH components - CHARACTER(ESMF_MAXSTR),DIMENSION(:),ALLOCATABLE :: EXP_EARTH_NAME !<-- Export state name of the EARTH components - CHARACTER(ESMF_MAXSTR),DIMENSION(:),ALLOCATABLE :: GC_EARTH_NAME !<-- Name of the EARTH component -! - TYPE(NEMS_INTERNAL_STATE),POINTER,SAVE :: NEMS_INT_STATE - TYPE(WRAP_NEMS_INTERNAL_STATE) ,SAVE :: WRAP -! - TYPE(ESMF_Clock), SAVE :: CLOCK_NEMS !<-- The ESMF Clock of the NEMS component - TYPE(ESMF_Config),SAVE :: CF_NEMS !<-- The configure object of the NEMS component - TYPE(ESMF_VM), SAVE :: VM_GLOBAL - TYPE(ESMF_TIME), SAVE :: STARTTIME -! - TYPE(ESMF_CplComp),SAVE :: ENS_CPL_COMP !<-- Ensemble Coupler components - TYPE(ESMF_State), SAVE :: ENS_CPL_IMP_STATE !<-- Import state of the Ensemble Coupler component - TYPE(ESMF_State), SAVE :: ENS_CPL_EXP_STATE !<-- Export state of the Ensemble Coupler component -! - TYPE(ESMF_GridComp),DIMENSION(:),ALLOCATABLE,SAVE :: EARTH_GRID_COMP !<-- EARTH components for each member - TYPE(ESMF_State), DIMENSION(:),ALLOCATABLE,SAVE :: EARTH_IMP_STATE !<-- Import state of the EARTH component - TYPE(ESMF_State), DIMENSION(:),ALLOCATABLE,SAVE :: EARTH_EXP_STATE !<-- Export state of the EARTH component -! -!----------------------------------------------------------------------- -! - CONTAINS - -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE NEMS_REGISTER(NEMS_GRID_COMP,RC_REG) -! -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_GridComp) :: NEMS_GRID_COMP !<-- The NEMS gridded component - INTEGER ,INTENT(OUT) :: RC_REG !<-- Error return code -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER :: RC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Register the NEMS Initialize, Run, and Finalize routines. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for NEMS Initialize" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -#ifdef ESMF_3 - CALL ESMF_GridCompSetEntryPoint(NEMS_GRID_COMP & !<-- The NEMS component - ,ESMF_SETINIT & !<-- Subroutine type (Initialize) - ,NEMS_INITIALIZE & !<-- User's subroutine name - ,ESMF_SINGLEPHASE & - ,RC) -#else - CALL ESMF_GridCompSetEntryPoint(NEMS_GRID_COMP & !<-- The NEMS component - ,ESMF_SETINIT & !<-- Subroutine type (Initialize) - ,NEMS_INITIALIZE & !<-- User's subroutine name - ,phase=ESMF_SINGLEPHASE & - ,rc=RC) -#endif -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for NEMS Run" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -#ifdef ESMF_3 - CALL ESMF_GridCompSetEntryPoint(NEMS_GRID_COMP & !<-- The NEMS component - ,ESMF_SETRUN & !<-- Subroutine type (Run) - ,NEMS_RUN & !<-- User's subroutine name - ,ESMF_SINGLEPHASE & - ,RC) -#else - CALL ESMF_GridCompSetEntryPoint(NEMS_GRID_COMP & !<-- The NEMS component - ,ESMF_SETRUN & !<-- Subroutine type (Run) - ,NEMS_RUN & !<-- User's subroutine name - ,phase=ESMF_SINGLEPHASE & - ,rc=RC) -#endif -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for NEMS Finalize" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -#ifdef ESMF_3 - CALL ESMF_GridCompSetEntryPoint(NEMS_GRID_COMP & !<-- The NEMS component - ,ESMF_SETFINAL & !<-- Subroutine type (Finalize) - ,NEMS_FINALIZE & !<-- User's subroutine name - ,ESMF_SINGLEPHASE & - ,RC) -#else - CALL ESMF_GridCompSetEntryPoint(NEMS_GRID_COMP & !<-- The NEMS component - ,ESMF_SETFINAL & !<-- Subroutine type (Finalize) - ,NEMS_FINALIZE & !<-- User's subroutine name - ,phase=ESMF_SINGLEPHASE & - ,rc=RC) -#endif -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - IF(RC_REG==ESMF_SUCCESS)THEN -! WRITE(0,*)' NEMS_REGISTER succeeded' - ELSE - WRITE(0,*)' NEMS_REGISTER failed RC_REG=',RC_REG - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE NEMS_REGISTER -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE NEMS_INITIALIZE(NEMS_GRID_COMP & - ,IMP_STATE & - ,EXP_STATE & - ,CLOCK_MAIN & - ,RC_INIT) -! -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_GridComp) :: NEMS_GRID_COMP !<-- The NEMS component - TYPE(ESMF_State) :: IMP_STATE !<-- The NEMS import state - TYPE(ESMF_State) :: EXP_STATE !<-- The NEMS export state - TYPE(ESMF_Clock) :: CLOCK_MAIN !<-- The main Clock - INTEGER ,INTENT(OUT) :: RC_INIT !<-- Error return code -! -!----------------------------------------------------------------------- -! -!--------------------- -!*** Local Variables -!--------------------- -! - TYPE(ESMF_TimeInterval) :: RUNDURATION -! - CHARACTER(20) :: PELAB -! - CHARACTER(ESMF_MAXSTR),DIMENSION(:),ALLOCATABLE :: EARTH_COMP_NAME & !<-- Names of each member's EARTH component - ,IMP_EARTH_NAME & !<-- Import state name of the EARTH components - ,EXP_EARTH_NAME !<-- Export state name of the EARTH components -! - INTEGER :: I,IJ,J,RC -! - INTEGER :: MYPE_GLOBAL & - ,NHOURS_FCST & - ,NSECONDS_FCST & - ,PE_MAX & - ,TASKS -! - INTEGER,DIMENSION(:,:),ALLOCATABLE :: PETLIST !<-- Task list for each ensemble member -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RC_INIT=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** For the moment, use a direct copy of the main Clock within -!*** the NEMS component. -!----------------------------------------------------------------------- -! - CLOCK_NEMS=CLOCK_MAIN -! -!----------------------------------------------------------------------- -!*** What is the start time on the NEMS clock? -!----------------------------------------------------------------------- - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK = "Extract the start time of the NEMS clock" -! CALL ESMF_LogWrite(MESSAGE_CHECK, ESMF_LOG_INFO, rc = RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_ClockGet(clock = CLOCK_NEMS & - ,startTime = STARTTIME & - ,rc = RC) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Allocate the NEMS component's internal state, point at it, -!*** and attach it to the NEMS component. -!----------------------------------------------------------------------- -! - ALLOCATE(NEMS_INT_STATE,stat=RC) - wrap%NEMS_INT_STATE=>NEMS_INT_STATE -! - CALL ESMF_GridCompSetInternalState(NEMS_GRID_COMP & !<--The NEMS component - ,WRAP & !<-- Pointer to the NEMS internal state - ,RC) -! -!----------------------------------------------------------------------- -!*** Get the global VM (Virtual Machine). -!*** Obtain the total task count and the local task ID. -!----------------------------------------------------------------------- -! - CALL ESMF_VMGetGlobal(vm = VM_GLOBAL & !<-- The ESMF global Virtual Machine - ,rc = RC) -! - CALL ESMF_VmGet(vm = VM_GLOBAL & !<-- The ESMF global Virtual Machine - ,pecount = TASKS & !<-- Total # of MPI tasks - ,localpet = MYPE_GLOBAL & !<-- This task's global rank - ,rc = RC) -! -!----------------------------------------------------------------------- -!*** Create and load the Configure object which will hold the contents -!*** of the NEMS configure file. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create/Load the NEMS Configure Object" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CF_NEMS=ESMF_ConfigCreate(rc=RC) -! - CALL ESMF_ConfigLoadFile(config = CF_NEMS & !<-- The configure object - ,filename = 'model_configure' & !<-- The name of the configure file - ,rc = RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - -!----------------------------------------------------------------------- -!*** Get the ensemble stochastic coupling flag from the config file. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract the Ensemble Stochastic Coupling Flag from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config = CF_NEMS & !<-- The NEMS configure object - ,value = ENS_SPS & !<-- Value of control flag for - ! stochastic perturbation scheme - ,label = 'ENS_SPS:' & !<-- Flag's label in configure file - ,rc = RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Reset the run duration in the NEMS Clock for the ensemble -!*** stochastic perturbation case. -!----------------------------------------------------------------------- -! - IF(ENS_SPS) THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NEMS: Extract Forecast Length from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF_NEMS & - ,value =NHOURS_FCST & - ,label ='nhours_fcst1:' & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NSECONDS_FCST=NHOURS_FCST*3600 !<-- The forecast length (sec) (Integer) -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NEMS: Set the Forecast Length" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeIntervalSet(timeinterval=RUNDURATION & !<-- The forecast length (s) (ESMF) - ,s =NSECONDS_FCST & !<-- The forecast length (s) (Integer) - ,rc =RC) -! - CALL ESMF_ClockSet(clock = CLOCK_NEMS & !<-- The NEMS Clock - ,runDuration = RUNDURATION & !<-- The forecast length (s) (ESMF) - ,rc = RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - END IF -! -!----------------------------------------------------------------------- -!*** Extract the total number of EARTH ensemble members. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract the Total Number of the EARTH Members from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config = CF_NEMS & !<-- The NEMS configure object - ,value = TOTAL_MEMBER & !<-- Total # of ensemble members - ,label = 'total_member:' & !<-- Flag in configure file - ,rc = RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Allocate a standard set of arrays for each ensemble member. -!----------------------------------------------------------------------- -! - ALLOCATE(EARTH_GRID_COMP (TOTAL_MEMBER)) - ALLOCATE(EARTH_IMP_STATE (TOTAL_MEMBER)) - ALLOCATE(EARTH_EXP_STATE (TOTAL_MEMBER)) - ALLOCATE(EARTH_COMP_NAME (TOTAL_MEMBER)) - ALLOCATE(IMP_EARTH_NAME (TOTAL_MEMBER)) - ALLOCATE(EXP_EARTH_NAME (TOTAL_MEMBER)) - ALLOCATE(PE_MEMBER (TOTAL_MEMBER)) -! -!----------------------------------------------------------------------- -!*** For each member create the names of the EARTH components and -!*** ESMF states then fill in the task information. -!----------------------------------------------------------------------- -! - PE_MEMBER = 0 -! -!JR Talked with Tom Black about this: all the models have no entries for PE_MEMBER in their -!JR config file. And, there's no check on the return code. - DO I = 1, TOTAL_MEMBER -! - WRITE(EARTH_COMP_NAME(I), '("EARTH grid component", I2.2)') I - WRITE(IMP_EARTH_NAME (I), '("EARTH import state", I2.2)') I - WRITE(EXP_EARTH_NAME (I), '("EARTH export state", I2.2)') I -! - WRITE(PELAB, '("PE_MEMBER", I2.2, ":")') I -! -!JR Comment out the call so that we can get esmf to halt on the first error. Apparently -!JR all the NEMS models fail on this call. -!JR CALL ESMF_ConfigGetAttribute(config = CF_NEMS & -!JR ,value = PE_MEMBER(I) & -!JR ,label = PELAB & -!JR ,rc = RC) -! -!JR IF(PE_MEMBER(I) == 0) PE_MEMBER(i) = TASKS / TOTAL_MEMBER -! - END DO -!JR Just set PE_MEMBER(1) manually - pe_member(1) = tasks / total_member -! - PE_MAX = 1 -! - DO I = 1, TOTAL_MEMBER - PE_MAX = MAX(PE_MAX, PE_MEMBER(I)) - END DO -! -!----------------------------------------------------------------------- -!*** Set up the PE list. -!----------------------------------------------------------------------- -! - ALLOCATE(PETLIST(1:PE_MAX, 1:TOTAL_MEMBER)) -! - IJ = 0 -! - DO J = 1, TOTAL_MEMBER -! - DO I = 1, PE_MEMBER(J) - PETLIST(I, J) = IJ -! - IF(MYPE_GLOBAL == IJ) THEN - MEMBER_ID = J - END IF -! - IJ = IJ + 1 - END DO -! - END DO -! -!----------------------------------------------------------------------- -!*** Get the clock parameters for the ensemble stochastic perturbation -!*** cycles from the config file. -!----------------------------------------------------------------------- -! - IF(ENS_SPS) THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract the Ensemble Clock Parameters from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config = CF_NEMS & - ,value = hh_increase & - ,label = 'HH_INCREASE:' & - ,rc = RC) -! - CALL ESMF_ConfigGetAttribute(config = CF_NEMS & - ,value = hh_start & - ,label = 'HH_START:' & - ,rc = RC) -! - CALL ESMF_ConfigGetAttribute(config = CF_NEMS & - ,value = hh_final & - ,label = 'HH_FINAL:' & - ,rc = RC) -! - NUMBER_START = HH_START / HH_INCREASE + 1 - NUMBER_FINAL = HH_FINAL / HH_INCREASE - 1 -! - PRINT *, 'ENS Coup ', NUMBER_START, NUMBER_FINAL & - , HH_START, HH_FINAL, HH_INCREASE -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - END IF -! -!----------------------------------------------------------------------- -!*** Create the EARTH grid components. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create EARTH grid Components" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DO I = 1, TOTAL_MEMBER - EARTH_GRID_COMP(i) = ESMF_GridCompCreate ( & - name = EARTH_COMP_NAME(I) & !<-- Name of element I of the EARTH component array - ,petlist = PETLIST(1:PE_MEMBER(I), I) & !<-- Element I's PE list - ,config = CF_NEMS & !<-- Associate the NEMS config object with this element - ,rc = RC) - END DO -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Create the Ensemble Coupler component inside of -!*** the NEMS internal state. -!----------------------------------------------------------------------- -! - IF(ENS_SPS) THEN - ENS_CPL_COMP=ESMF_CplCompCreate(name = "ENS Cpl component" & - ,rc = RC) - END IF -! -!----------------------------------------------------------------------- -!*** Register the Initialize, Run, and Finalize routines of -!*** each element in the EARTH component array. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Register EARTH Init, Run, Finalize" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DO I = 1, TOTAL_MEMBER -#ifdef ESMF_3 - CALL ESMF_GridCompSetServices(EARTH_GRID_COMP(I) & !<-- The EARTH gridded components - ,EARTH_REGISTER & !<-- User's name for the Register routine - ,RC) -#else - CALL ESMF_GridCompSetServices(EARTH_GRID_COMP(I) & !<-- The EARTH gridded components - ,EARTH_REGISTER & !<-- User's name for the Register routine - ,rc=RC) -#endif - END DO -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Register the Initialize, Run, and Finalize routines of -!*** the Ensemble Coupler component. -!----------------------------------------------------------------------- -! - IF(ENS_SPS) THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Register Ensemble Coupler Init, Run, Finalize" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -#ifdef ESMF_3 - CALL ESMF_CplCompSetServices(ENS_CPL_COMP & - ,ENS_CplCompSetServices & !<-- The user's name for the Register routine - ,RC) -#else - CALL ESMF_CplCompSetServices(ENS_CPL_COMP & - ,ENS_CplCompSetServices & !<-- The user's name for the Register routine - ,rc=RC) -#endif -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - END IF -! -!----------------------------------------------------------------------- -!*** Create the EARTH import and export states. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create the EARTH import states" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DO I = 1,TOTAL_MEMBER -#ifdef ESMF_520rbs - EARTH_IMP_STATE(I) = ESMF_StateCreate( & - NAME = IMP_EARTH_NAME(I) & - ,statetype = ESMF_STATE_IMPORT & - ,rc = RC) -#else - EARTH_IMP_STATE(I) = ESMF_StateCreate( & - STATENAME = IMP_EARTH_NAME(I) & - ,statetype = ESMF_STATE_IMPORT & - ,rc = RC) -#endif - END DO -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create the EARTH export states" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DO I = 1,TOTAL_MEMBER -#ifdef ESMF_520rbs - EARTH_EXP_STATE(I) = ESMF_StateCreate( & - NAME = EXP_EARTH_NAME(I) & - ,statetype = ESMF_STATE_EXPORT & - ,rc = RC) -#else - EARTH_EXP_STATE(I) = ESMF_StateCreate( & - STATENAME = EXP_EARTH_NAME(I) & - ,statetype = ESMF_STATE_EXPORT & - ,rc = RC) -#endif - END DO -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Create the Ensemble Coupler import and export states. -!----------------------------------------------------------------------- -! - IF(ENS_SPS) THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create the Ensemble Coupler import state" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -#ifdef ESMF_520rbs - ENS_CPL_IMP_STATE=ESMF_StateCreate( NAME = "ENS_CPL_Import" & - ,statetype = ESMF_STATE_IMPORT & - ,rc = RC) -#else - ENS_CPL_IMP_STATE=ESMF_StateCreate(STATENAME = "ENS_CPL_Import" & - ,statetype = ESMF_STATE_IMPORT & - ,rc = RC) -#endif -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create the Ensemble Coupler export state" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -#ifdef ESMF_520rbs - ENS_CPL_EXP_STATE=ESMF_StateCreate( NAME = "ENS_CPL_Export" & - ,statetype = ESMF_STATE_EXPORT & - ,rc = RC) -#else - ENS_CPL_EXP_STATE=ESMF_StateCreate(STATENAME = "ENS_CPL_Export" & - ,statetype = ESMF_STATE_EXPORT & - ,rc = RC) -#endif -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Nest the EARTH export/import states into the import/export states -!*** of the ensemble coupler. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK= "Add the EARTH states into the ENS_CPL states" -! CALL ESMF_LogWrite(MESSAGE_CHECK, ESMF_LOG_INFO, rc = RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DO I = 1, TOTAL_MEMBER - IF(MEMBER_ID == I) THEN - CALL ESMF_StateAdd(state = ENS_CPL_IMP_STATE & - ,nestedState = EARTH_EXP_STATE(I) & - ,rc = RC) -! - CALL ESMF_StateAdd(state = ENS_CPL_EXP_STATE & - ,nestedState = EARTH_IMP_STATE(I) & - ,rc = RC) - END IF - END DO -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - END IF -! -!----------------------------------------------------------------------- -!*** Execute the Initialize step of each element of the EARTH -!*** component array. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Execute the Initialize step of the EARTH component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DO I = 1, TOTAL_MEMBER -! - IF(MEMBER_ID == I) THEN - CALL ESMF_GridCompInitialize(gridcomp = EARTH_GRID_COMP(I) & - ,importState = EARTH_IMP_STATE(I) & - ,exportState = EARTH_EXP_STATE(I) & - ,clock = CLOCK_NEMS & - ,phase = ESMF_SINGLEPHASE & - ,rc = RC) - END IF -! - END DO -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Execute the Initialize step of the Ensemble Coupler component. -!----------------------------------------------------------------------- -! - IF(ENS_SPS) THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Execute the Initialize step of the Ensemble Coupler component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_CplCompInitialize(cplcomp =ENS_CPL_COMP & - ,importState=ENS_CPL_IMP_STATE & - ,exportState=ENS_CPL_EXP_STATE & - ,clock =CLOCK_NEMS & - ,phase =ESMF_SINGLEPHASE & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - END IF -! -!----------------------------------------------------------------------- -! - IF(RC_INIT==ESMF_SUCCESS)THEN -! WRITE(0,*)' NEMS_INITIALIZE succeeded' - ELSE - WRITE(0,*)' NEMS_INITIALIZE failed RC_INIT=',RC_INIT - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE NEMS_INITIALIZE -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE NEMS_RUN(NEMS_GRID_COMP & - ,IMP_STATE & - ,EXP_STATE & - ,CLOCK_MAIN & - ,RC_RUN) -! -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_GridComp) :: NEMS_GRID_COMP !<-- The NEMS component - TYPE(ESMF_State) :: IMP_STATE !<-- The NEMS import state - TYPE(ESMF_State) :: EXP_STATE !<-- The NEMS export state - TYPE(ESMF_Clock) :: CLOCK_MAIN !<-- The main Clock - INTEGER ,INTENT(OUT) :: RC_RUN !<-- Error return code -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER :: HH,I,J,RC -! - TYPE(ESMF_Time) :: CURRTIME -! - TYPE(ESMF_TimeInterval) :: RUNDURATION -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** For the moment, use a direct copy of the main Clock within -!*** the NEMS component. -!----------------------------------------------------------------------- -! - CLOCK_NEMS=CLOCK_MAIN -! -!----------------------------------------------------------------------- -!*** Execute the Run step of each element in the EARTH component -!*** array. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Execute the Run step of the EARTH component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DO I = 1, TOTAL_MEMBER -! - IF(MEMBER_ID == I) THEN - CALL ESMF_GridCompRun(gridcomp = EARTH_GRID_COMP(I) & - ,importState = EARTH_IMP_STATE(I) & - ,exportState = EARTH_EXP_STATE(I) & - ,clock = CLOCK_NEMS & - ,phase = ESMF_SINGLEPHASE & - ,rc = RC) - END IF -! - END DO -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Execute the Run step of the Ensemble Coupler component. -!----------------------------------------------------------------------- -! - sps: IF(ENS_SPS) THEN -! -!----------------------------------------------------------------------- -! - DO I = NUMBER_START, NUMBER_FINAL -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Execute the Run step of the Ensemble Coupler component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_CplCompRun(cplcomp =ENS_CPL_COMP & - ,importState=ENS_CPL_IMP_STATE & - ,exportState=ENS_CPL_EXP_STATE & - ,clock =CLOCK_NEMS & - ,phase =ESMF_SINGLEPHASE & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_VMBarrier(vm = VM_GLOBAL, rc = RC) -! -!----------------------------------------------------------------------- -!*** Adjust the ESMF clock for the next run cycle. -!----------------------------------------------------------------------- - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK = "Update the current time of the NEMS clock" -! CALL ESMF_LogWrite(MESSAGE_CHECK, ESMF_LOG_INFO, rc = RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock = CLOCK_NEMS & - ,runDuration = RUNDURATION & - ,rc = RC) -! - CURRTIME = STARTTIME + RUNDURATION -! - CALL ESMF_ClockSet(clock = CLOCK_NEMS & - ,currTime = CURRTIME & - ,rc = RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC, MESSAGE_CHECK, RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK = "Adjust clock - add one more cycle run duration" -! CALL ESMF_LogWrite(MESSAGE_CHECK, ESMF_LOG_INFO, rc = RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeIntervalGet(timeInterval = RUNDURATION & - ,h = HH & - ,rc = RC) -! - HH = HH + HH_INCREASE -! - CALL ESMF_TimeIntervalSet(timeInterval = RUNDURATION & - ,h = hh & - ,rc = RC) -! - CALL ESMF_ClockSet(clock = CLOCK_NEMS & - ,runDuration = RUNDURATION & - ,rc = RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC, MESSAGE_CHECK, RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Execute the Run step of each element in the EARTH component -!*** array. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Execute the Run step of the EARTH components" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DO J = 1, TOTAL_MEMBER -! - IF(MEMBER_ID == J) THEN - CALL ESMF_GridCompRun(gridcomp = EARTH_GRID_COMP(J) & - ,importState = EARTH_IMP_STATE(J) & - ,exportState = EARTH_EXP_STATE(J) & - ,clock = CLOCK_NEMS & - ,phase = ESMF_SINGLEPHASE & - ,rc = RC) - END IF -! - END DO -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - PRINT*, 'Complete EARTH Run Cycle ', I + 1 - END DO -! -!----------------------------------------------------------------------- -! - ELSE sps -! - CALL ESMF_ClockGet(clock = CLOCK_NEMS & - ,runDuration = RUNDURATION & - ,rc = RC) -! -!----------------------------------------------------------------------- -! - END IF sps -! -!----------------------------------------------------------------------- -! - IF(RC_RUN==ESMF_SUCCESS)THEN -! WRITE(0,*)' NEMS_RUN succeeded' - ELSE - WRITE(0,*)' NEMS_RUN failed RC_RUN=',RC_RUN - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE NEMS_RUN -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE NEMS_FINALIZE(NEMS_GRID_COMP & - ,IMP_STATE & - ,EXP_STATE & - ,CLOCK_MAIN & - ,RC_FINALIZE) -! -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_GridComp) :: NEMS_GRID_COMP !<-- The NEMS component - TYPE(ESMF_State) :: IMP_STATE !<-- The NEMS import state - TYPE(ESMF_State) :: EXP_STATE !<-- The NEMS export state - TYPE(ESMF_Clock) :: CLOCK_MAIN !<-- The main Clock - INTEGER ,INTENT(OUT) :: RC_FINALIZE !<-- Error return code -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER :: I,RC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Execute the Finalize step of each element of the -!*** EARTH component array. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Execute the Finalize step of the EARTH component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DO I = 1, TOTAL_MEMBER -! - IF(MEMBER_ID == I) THEN - CALL ESMF_GridCompFinalize(gridcomp = EARTH_GRID_COMP(I) & - ,importState = EARTH_IMP_STATE(I) & - ,exportState = EARTH_EXP_STATE(I) & - ,clock = CLOCK_NEMS & - ,phase = ESMF_SINGLEPHASE & - ,rc = RC) - END IF -! - END DO -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINALIZE) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - IF(ENS_SPS) THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Execute the Finalize step of the Ensemble Coupler component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_CplCompFinalize(cplcomp =ENS_CPL_COMP & - ,importState=ENS_CPL_IMP_STATE & - ,exportState=ENS_CPL_EXP_STATE & - ,clock =CLOCK_NEMS & - ,phase =ESMF_SINGLEPHASE & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINALIZE) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - END IF -! -!----------------------------------------------------------------------- -! - IF(RC_FINALIZE==ESMF_SUCCESS)THEN -! WRITE(0,*)' NEMS_FINALIZE succeeded' - ELSE - WRITE(0,*)' NEMS_FINALIZE failed RC_FINALIZE=',RC_FINALIZE - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE NEMS_FINALIZE -! -!----------------------------------------------------------------------- -! - END MODULE module_NEMS_GRID_COMP -! -!----------------------------------------------------------------------- diff --git a/src/fim/FIMsrc/fim/framework/nems/module_NEMS_INTERNAL_STATE.F90 b/src/fim/FIMsrc/fim/framework/nems/module_NEMS_INTERNAL_STATE.F90 deleted file mode 100644 index 960d031..0000000 --- a/src/fim/FIMsrc/fim/framework/nems/module_NEMS_INTERNAL_STATE.F90 +++ /dev/null @@ -1,45 +0,0 @@ -!TBH: Matches r14147 of https://svnemc.ncep.noaa.gov/projects/nems/trunk/. -!----------------------------------------------------------------------- -! - MODULE module_NEMS_INTERNAL_STATE -! -!----------------------------------------------------------------------- -!*** Contents of the ESMF internal state of the NEMS component. -!----------------------------------------------------------------------- -! - USE ESMF_MOD -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: NEMS_INTERNAL_STATE & - ,WRAP_NEMS_INTERNAL_STATE -! -!----------------------------------------------------------------------- -! - TYPE NEMS_INTERNAL_STATE -! - REAL :: DUMMY1 -! - END TYPE NEMS_INTERNAL_STATE -! -!----------------------------------------------------------------------- -! - TYPE WRAP_NEMS_INTERNAL_STATE -! - REAL :: DUMMY2 -! - TYPE(NEMS_INTERNAL_STATE),POINTER :: NEMS_INT_STATE -! - END TYPE WRAP_NEMS_INTERNAL_STATE -! -!----------------------------------------------------------------------- -! - END MODULE module_NEMS_INTERNAL_STATE -! -!----------------------------------------------------------------------- diff --git a/src/fim/FIMsrc/fim/framework/nems/module_PHYSICS_GRID_COMP.F90 b/src/fim/FIMsrc/fim/framework/nems/module_PHYSICS_GRID_COMP.F90 deleted file mode 100644 index df2986f..0000000 --- a/src/fim/FIMsrc/fim/framework/nems/module_PHYSICS_GRID_COMP.F90 +++ /dev/null @@ -1,1544 +0,0 @@ -!JR copied from fimlatest -!TODO: DRY out all of this code. Initial NEMS was not DRY. We can be. -!----------------------------------------------------------------------- -! - MODULE MODULE_PHYSICS_GRID_COMP -! -!----------------------------------------------------------------------- -! -!*** THIS MODULE HOLDS THE PHYSICS REGISTER, INIT, RUN, AND FINALIZE -!*** ROUTINES. THEY ARE CALLED FROM THE MAIN GRIDDED COMPONENT -!*** (ATM INITIALIZE CALLS PHYSICS INITIALIZE, ETC.) -!*** IN MODULE_ATM_GRID_COMP.F. -! -!----------------------------------------------------------------------- -! - USE ESMF_MOD -! - USE MODULE_ERR_MSG,ONLY: ERR_MSG,MESSAGE_CHECK -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: PHY_REGISTER -! -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE PHY_REGISTER(GRID_COMP,RC_REG) -! -!----------------------------------------------------------------------- -!*** REGISTER THE PHYSICS COMPONENT'S INITIALIZE, RUN, AND FINALIZE -!*** ROUTINES. -!----------------------------------------------------------------------- -! - TYPE(ESMF_GridComp),INTENT(INOUT) :: GRID_COMP !<-- The Physics Gridded Component -! - INTEGER,INTENT(OUT) :: RC_REG !<-- Return code for Register -! -!----------------------------------------------------------------------- -!*** LOCAL VARIABLES -!----------------------------------------------------------------------- -! - INTEGER :: RC=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC_REG=ESMF_SUCCESS !<-- Initialize error signal variable - -!----------------------------------------------------------------------- -!*** REGISTER THE PHYSICS INITIALIZE SUBROUTINE. SINCE IT IS JUST ONE -!*** SUBROUTINE, USE ESMF_SINGLEPHASE. THE SECOND ARGUMENT IS -!*** A PRE-DEFINED SUBROUTINE TYPE, SUCH AS ESMF_SETINIT, ESMF_SETRUN, -!*** OR ESMF_SETFINAL. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for Physics Initialize" - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSetEntryPoint(GRID_COMP & !<-- Physics gridcomp - ,ESMF_SETINIT & !<-- Subroutine type - ,PHY_INITIALIZE & !<-- User's subroutine name - ,ESMF_SINGLEPHASE & !<-- Phase - ,RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** REGISTER THE PHYSICS RUN SUBROUTINE. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for Physics Run" - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSetEntryPoint(GRID_COMP & !<-- Physics gridcomp - ,ESMF_SETRUN & !<-- Subroutine type - ,PHY_RUN & !<-- User's subroutine name - ,ESMF_SINGLEPHASE & !<-- Phase - ,RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** REGISTER THE PHYSICS FINALIZE SUBROUTINE. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for Physics Finalize" - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSetEntryPoint(GRID_COMP & !<-- Physics gridcomp - ,ESMF_SETFINAL & !<-- Subroutine type - ,PHY_FINALIZE & !<-- User's subroutine name - ,ESMF_SINGLEPHASE & !<-- Phase - ,RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** CHECK THE ERROR SIGNAL VARIABLE. -!----------------------------------------------------------------------- -! - IF(RC_REG==ESMF_SUCCESS)THEN -! WRITE(0,*)' PHY_REGISTER SUCCEEDED' - ELSE - WRITE(0,*)' PHY_REGISTER FAILED RC_REG=',RC_REG - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PHY_REGISTER -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE PHY_INITIALIZE(GRID_COMP & - ,IMP_STATE,EXP_STATE & - ,CLOCK_ATM & - ,RC_INIT) -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** SET UP THE MODEL PHYSICS. -!----------------------------------------------------------------------- -! - USE module_fim_phy_init ,only: PHY_INITIALIZE_FIM => phy_init - USE gfs_physics_internal_state_mod, only: & - gfs_physics_internal_state, & - gis_phy, & - WRAP_INTERNAL_STATE => gfs_phy_wrap -! -!----------------------------------------------------------------------- -!*** ARGUMENT VARIABLES. -!----------------------------------------------------------------------- -! - TYPE(ESMF_GridComp),INTENT(INOUT) :: GRID_COMP !<-- The Physics gridded component - TYPE(ESMF_State), INTENT(INOUT) :: IMP_STATE !<-- The Physics Initialize step's import state - TYPE(ESMF_State), INTENT(INOUT) :: EXP_STATE !<-- The Physics Initialize step's export state - TYPE(ESMF_Clock), INTENT(IN) :: CLOCK_ATM !<-- The ATM's ESMF Clock -! - INTEGER, INTENT(OUT) :: RC_INIT -! -!----------------------------------------------------------------------- -!*** LOCAL VARIABLES -!----------------------------------------------------------------------- -!*** WRAP_INTERNAL_STATE IS DEFINED IN THE INTERNAL STATE MODULE. -!----------------------------------------------------------------------- -! - TYPE(WRAP_INTERNAL_STATE) :: WRAP !<-- This wrap is a derived type which contains - ! only a pointer to the internal state. It is needed - ! for using different architectures or compilers. -! -! TYPE(ESMF_Field) :: TMP_FIELD - TYPE(ESMF_Grid) :: GRID - TYPE(ESMF_DistGrid) :: DISTGRID - TYPE(ESMF_Array) :: TMP_ARRAY - INTEGER :: RC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** INITIALIZE THE ERROR SIGNAL VARIABLES. -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RC_INIT=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** INITIALIZE THE PHYSICS SCHEMES. -!----------------------------------------------------------------------- -! -! Allocate internal state and set up initial values for some fields. -! - CALL PHY_INITIALIZE_FIM -! -!----------------------------------------------------------------------- -!*** ATTACH THE INTERNAL STATE TO THE PHYSICS GRIDDED COMPONENT. -!----------------------------------------------------------------------- -! - WRAP%INT_STATE=>gis_phy -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK= & - "Attach Physics Internal State to the Gridded Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSetInternalState(GRID_COMP & !<-- Physics gridcomp - ,WRAP & !<-- Data pointer to internal state - ,RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - - MESSAGE_CHECK="PHY: Extract GRID from GRID_COMP" - call esmf_gridcompget(GRID_COMP, grid = GRID, rc = RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - - call esmf_gridvalidate(grid=GRID, rc=rc) - CALL ERR_MSG(RC,'PHY: validate GRID',RC_INIT) - - MESSAGE_CHECK="PHY: Extract DISTGRID from GRID" - CALL ESMF_GridGet(grid=GRID, distgrid=DISTGRID, rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - - call esmf_distgridvalidate(distgrid=DISTGRID, rc=rc) - CALL ERR_MSG(RC,'PHY: validate DISTGRID',RC_INIT) - -! Set flags to enable import/export of each field, hard-coded for the moment -!TODO: Read these from a config file as in GFS, adapting -!TODO: gfs_physics_getcf_mod.f - gis_phy%esmf_sta_list%idate1_import = 0 - gis_phy%esmf_sta_list%idate1_export = 0 - gis_phy%esmf_sta_list%z_import = 0 - gis_phy%esmf_sta_list%z_export = 0 - gis_phy%esmf_sta_list%ps_import = 1 - gis_phy%esmf_sta_list%ps_export = 1 - gis_phy%esmf_sta_list%temp_import = 1 - gis_phy%esmf_sta_list%temp_export = 1 - gis_phy%esmf_sta_list%u_import = 1 - gis_phy%esmf_sta_list%u_export = 1 - gis_phy%esmf_sta_list%v_import = 1 - gis_phy%esmf_sta_list%v_export = 1 - gis_phy%esmf_sta_list%q_import = 1 - gis_phy%esmf_sta_list%q_export = 1 - gis_phy%esmf_sta_list%oz_import = 1 - gis_phy%esmf_sta_list%oz_export = 1 - gis_phy%esmf_sta_list%cld_import = 1 - gis_phy%esmf_sta_list%cld_export = 1 - gis_phy%esmf_sta_list%p_import = 1 - gis_phy%esmf_sta_list%p_export = 1 - gis_phy%esmf_sta_list%dp_import = 1 - gis_phy%esmf_sta_list%dp_export = 1 - gis_phy%esmf_sta_list%dpdt_import = 1 - gis_phy%esmf_sta_list%dpdt_export = 1 - -!----------------------------------------------------------------------- -!*** Attach gfs fields in the internal state -!*** to the esmf import and export states. -!TBH: I use GFS naming conventions, *not* NMMB conventions. As -!TBH: of NEMS r3038 they do indeed differ, by case at least! -!TBH: Creation of unique ESMF_Field objects for import and export -!TBH: states should require little additional memory since the pointers -!TBH: to Fortran arrays are shared. This approach makes object deletion -!TBH: easier. -!------------------------------------------------------- - - MESSAGE_CHECK= & - "initial internal state to esmf import and export states" - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) - - IF (gis_phy%esmf_sta_list%idate1_import == 1) THEN - WRITE(0,*)' PHY_INITIALIZE import of idate1 not supported' - RC_INIT = ESMF_FAILURE - RETURN - ENDIF - IF (gis_phy%esmf_sta_list%idate1_export == 1) THEN - WRITE(0,*)' PHY_INITIALIZE export of idate1 not supported' - RC_INIT = ESMF_FAILURE - RETURN - ENDIF - IF (gis_phy%esmf_sta_list%z_import == 1) THEN - WRITE(0,*)' PHY_INITIALIZE import of z not supported' - RC_INIT = ESMF_FAILURE - RETURN - ENDIF - IF (gis_phy%esmf_sta_list%z_export == 1) THEN - WRITE(0,*)' PHY_INITIALIZE export of z not supported' - RC_INIT = ESMF_FAILURE - RETURN - ENDIF - -!TODO: Need to add gridToFieldMap to ESMF_FieldCreate() to address -!TODO: differences between 2D and 3D arrays. At present this is -!TODO: irrelevant since we do not use ESMF to do any re-grid or -!TODO: re-dist operations. This must be fixed before we use these -!TODO: ESMF features. - - IF (gis_phy%esmf_sta_list%ps_import == 1) THEN - MESSAGE_CHECK="Create ps array for import state" -!TBH: Note that the following call to ESMF_FieldCreate() yields the -!TBH: stunningly informative error code 540 which maps to string -!TBH: "Not valid" in ESMC_ErrMsgs.C. Backed off to ESMF_ArrayCreate(). -!TODO: Switch back to ESMF_FieldCreate() since future NEMS will use -!TODO: ESMF_Fields. -! TMP_FIELD=ESMF_FieldCreate(grid =GRID & -! ,farray =gis_phy%ps & -! ,distgridToArrayMap=(/1/) & -! ,name ='ps' & -! ,rc =RC) - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%ps & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='ps' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add ps array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - IF (gis_phy%esmf_sta_list%ps_export == 1) THEN - MESSAGE_CHECK="Create ps array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%ps & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='ps' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add ps array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - - IF (gis_phy%esmf_sta_list%temp_import == 1) THEN - MESSAGE_CHECK="Create t array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%t & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='t' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add t array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - IF (gis_phy%esmf_sta_list%temp_export == 1) THEN - MESSAGE_CHECK="Create t array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%t & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='t' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add t array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - - IF (gis_phy%esmf_sta_list%u_import == 1) THEN - MESSAGE_CHECK="Create u array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%u & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='u' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add u array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - IF (gis_phy%esmf_sta_list%u_export == 1) THEN - MESSAGE_CHECK="Create u array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%u & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='u' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add u array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - - IF (gis_phy%esmf_sta_list%v_import == 1) THEN - MESSAGE_CHECK="Create v array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%v & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='v' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add v array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - IF (gis_phy%esmf_sta_list%v_export == 1) THEN - MESSAGE_CHECK="Create v array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%v & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='v' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add v array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - - IF (gis_phy%esmf_sta_list%q_import == 1) THEN - MESSAGE_CHECK="Create q array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%q & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='shum' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add q array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - IF (gis_phy%esmf_sta_list%q_export == 1) THEN - MESSAGE_CHECK="Create q array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%q & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='shum' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add q array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - - IF (gis_phy%esmf_sta_list%oz_import == 1) THEN - MESSAGE_CHECK="Create oz array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%oz & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='oz' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add oz array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - IF (gis_phy%esmf_sta_list%oz_export == 1) THEN - MESSAGE_CHECK="Create oz array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%oz & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='oz' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add oz array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - - IF (gis_phy%esmf_sta_list%cld_import == 1) THEN - MESSAGE_CHECK="Create cld array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%cld & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='cld' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add cld array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - IF (gis_phy%esmf_sta_list%cld_export == 1) THEN - MESSAGE_CHECK="Create cld array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%cld & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='cld' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add cld array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - - IF (gis_phy%esmf_sta_list%p_import == 1) THEN - MESSAGE_CHECK="Create p array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%p & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='p' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add p array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - IF (gis_phy%esmf_sta_list%p_export == 1) THEN - MESSAGE_CHECK="Create p array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%p & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='p' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add p array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - - IF (gis_phy%esmf_sta_list%dp_import == 1) THEN - MESSAGE_CHECK="Create dp array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%dp & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='dp' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add dp array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - IF (gis_phy%esmf_sta_list%dp_export == 1) THEN - MESSAGE_CHECK="Create dp array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%dp & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='dp' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add dp array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - - IF (gis_phy%esmf_sta_list%dpdt_import == 1) THEN - MESSAGE_CHECK="Create dpdt array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%dpdt & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='dpdt' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add dpdt array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - IF (gis_phy%esmf_sta_list%dpdt_export == 1) THEN - MESSAGE_CHECK="Create dpdt array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%dpdt & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='dpdt' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add dpdt array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -!TBH: New arrays needed by FIM DYN component. -!TODO: Need to reach agreement with NCEP about exporting these arrays from -!TODO: GFS PHY component for use by FIM diagnostics. -! IF (gis_phy%esmf_sta_list%geshem_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create geshem array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%flx_fld%GESHEM & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='geshem' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add geshem array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%geshem_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create geshem array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%flx_fld%GESHEM & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='geshem' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add geshem array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%rainc_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create rainc array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%flx_fld%RAINC & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='rainc' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add rainc array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%rainc_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create rainc array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%flx_fld%RAINC & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='rainc' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add rainc array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%tsea_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create tsea array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%TSEA & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='tsea' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add tsea array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%tsea_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create tsea array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%TSEA & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='tsea' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add tsea array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%uustar_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create uustar array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%UUSTAR & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='uustar' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add uustar array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%uustar_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create uustar array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%UUSTAR & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='uustar' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add uustar array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%hflx_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create hflx array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%flx_fld%HFLX & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='hflx' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add hflx array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%hflx_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create hflx array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%flx_fld%HFLX & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='hflx' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add hflx array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%evap_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create evap array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%flx_fld%EVAP & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='evap' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add evap array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%evap_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create evap array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%flx_fld%EVAP & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='evap' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add evap array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%sheleg_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create sheleg array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%SHELEG & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='sheleg' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add sheleg array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%sheleg_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create sheleg array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%SHELEG & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='sheleg' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add sheleg array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%canopy_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create canopy array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%CANOPY & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='canopy' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add canopy array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%canopy_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create canopy array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%CANOPY & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='canopy' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add canopy array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%hice_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create hice array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%HICE & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='hice' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add hice array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%hice_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create hice array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%HICE & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='hice' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add hice array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%fice_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create fice array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%FICE & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='fice' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add fice array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%fice_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create fice array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%FICE & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='fice' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add fice array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%stc_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create stc array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%STC & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='stc' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add stc array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%stc_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create stc array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%STC & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='stc' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add stc array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%smc_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create smc array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%SMC & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='smc' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add smc array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%smc_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create smc array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%SMC & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='smc' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add smc array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%sfcdsw_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create sfcdsw array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%flx_fld%SFCDSW & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='sfcdsw' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add sfcdsw array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%sfcdsw_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create sfcdsw array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%flx_fld%SFCDSW & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='sfcdsw' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add sfcdsw array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%sfcdlw_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create sfcdlw array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%flx_fld%SFCDLW & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='sfcdlw' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add sfcdlw array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%sfcdlw_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create sfcdlw array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%flx_fld%SFCDLW & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='sfcdlw' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add sfcdlw array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%t2m_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create t2m array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%T2M & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='t2m' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add t2m array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%t2m_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create t2m array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%T2M & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='t2m' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add t2m array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%q2m_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create q2m array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%Q2M & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='q2m' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add q2m array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%q2m_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create q2m array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%Q2M & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='q2m' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add q2m array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%slmsk_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create slmsk array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%SLMSK & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='slmsk' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add slmsk array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%slmsk_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create slmsk array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%SLMSK & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='slmsk' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add slmsk array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%hprime_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create hprime array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%hprime & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='hprime' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add hprime array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%hprime_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create hprime array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%hprime & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='hprime' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add hprime array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%fluxr_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create fluxr array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%fluxr & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='fluxr' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add fluxr array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%fluxr_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create fluxr array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%fluxr & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='fluxr' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add fluxr array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -!TBH: validate states - MESSAGE_CHECK="PHY_INITIALIZE: Validate import state" - call ESMF_StateValidate(state=IMP_STATE,rc=rc) - IF(RC==ESMF_SUCCESS)THEN -!JR WRITE(0,*)'PHY INITIALIZE import state valid' - ENDIF - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="PHY_INITIALIZE: Validate export state" - call ESMF_StateValidate(state=EXP_STATE,rc=rc) - IF(RC==ESMF_SUCCESS)THEN -!JR WRITE(0,*)'PHY INITIALIZE export state valid' - ENDIF - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - -! -!----------------------------------------------------------------------- -! - RC_INIT = RC - IF(RC_INIT==ESMF_SUCCESS)THEN -! WRITE(0,*)'PHY INITIALIZE STEP SUCCEEDED' - ELSE - WRITE(0,*)'PHY INITIALIZE STEP FAILED RC_INIT=',RC_INIT - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PHY_INITIALIZE -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE PHY_RUN(GRID_COMP & - ,IMP_STATE,EXP_STATE & - ,CLOCK_ATM & - ,RC_RUN) -! -!----------------------------------------------------------------------- -!*** THE INTEGRATION OF THE MODEL PHYSICS IS DONE -!*** THROUGH THIS ROUTINE. -!----------------------------------------------------------------------- -! - USE module_fim_phy_run ,only: PHY_RUN_FIM => phy_run -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -!*** ARGUMENT VARIABLES -!----------------------------------------------------------------------- -! - TYPE(ESMF_GridComp),INTENT(INOUT) :: GRID_COMP !<-- The Physics gridded component - TYPE(ESMF_State) ,INTENT(INOUT) :: IMP_STATE !<-- The Physics import state - TYPE(ESMF_State) ,INTENT(INOUT) :: EXP_STATE !<-- The Physics export state - TYPE(ESMF_Clock) ,INTENT(IN) :: CLOCK_ATM !<-- The ATM's ESMF Clock -! - INTEGER ,INTENT(OUT) :: RC_RUN -! -!----------------------------------------------------------------------- -!*** LOCAL VARIABLES -!----------------------------------------------------------------------- -! - INTEGER :: NTIMESTEP,RC -! - INTEGER(KIND=ESMF_KIND_I8) :: NTIMESTEP_ESMF -! - INTEGER :: its -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC_RUN=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** EXTRACT THE TIMESTEP COUNT FROM THE CLOCK. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Retrieve Timestep from ATM Clock in Physics Run" - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock =CLOCK_ATM & !<-- The ESMF clock - ,advanceCount=NTIMESTEP_ESMF & !<-- The number of times the clock has been advanced - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NTIMESTEP=NTIMESTEP_ESMF -! -! NOTE: Pointers in import and export states point to internal state as -! NOTE: set up in the init phase, consistent with future plans for NEMS. -! NOTE: So wrap%int_state is not needed here at present, nor are explicit -! NOTE: transfers between internal and import/export states. -!TODO: adjust as plans evolve - -!----------------------------------------------------------------------- -!*** CALL THE INDIVIDUAL PHYSICAL PROCESSES -!----------------------------------------------------------------------- -! - its = NTIMESTEP + 1 - CALL PHY_RUN_FIM (its) -! - RC_RUN=RC -! -!----------------------------------------------------------------------- -! - IF(RC_RUN==ESMF_SUCCESS)THEN -! WRITE(0,*)'PHY RUN STEP SUCCEEDED' - ELSE - WRITE(0,*)'PHY RUN STEP FAILED RC_RUN=',RC_RUN - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PHY_RUN -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE PHY_FINALIZE(GRID_COMP & - ,IMP_STATE,EXP_STATE & - ,CLOCK_ATM & - ,RC_FINAL) -! -!----------------------------------------------------------------------- -!*** FINALIZE THE PHYSICS COMPONENT. -!----------------------------------------------------------------------- -! - USE module_fim_phy_finalize ,only: PHY_FINALIZE_FIM => phy_finalize -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -!*** ARGUMENT VARIABLES -!----------------------------------------------------------------------- -! - TYPE(ESMF_GridComp),INTENT(INOUT) :: GRID_COMP !<-- The Physics gridded component - TYPE(ESMF_State) ,INTENT(INOUT) :: IMP_STATE !<-- The Physics import state - TYPE(ESMF_State) ,INTENT(INOUT) :: EXP_STATE !<-- The Physics export state - TYPE(ESMF_Clock) ,INTENT(IN) :: CLOCK_ATM !<-- The ATM's ESMF Clock -! - INTEGER ,INTENT(OUT) :: RC_FINAL -! -!----------------------------------------------------------------------- -!*** LOCAL VARIABLES -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC_FINAL=ESMF_SUCCESS -! - CALL PHY_FINALIZE_FIM -! -! WRITE(0,*)' Physics Completed Normally.' -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PHY_FINALIZE -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - END MODULE MODULE_PHYSICS_GRID_COMP -! -!----------------------------------------------------------------------- diff --git a/src/fim/FIMsrc/fim/horizontal/FIM_HORIZONTAL_OBJS b/src/fim/FIMsrc/fim/horizontal/FIM_HORIZONTAL_OBJS deleted file mode 100644 index a8f8e7a..0000000 --- a/src/fim/FIMsrc/fim/horizontal/FIM_HORIZONTAL_OBJS +++ /dev/null @@ -1,106 +0,0 @@ -# horizontal objects - -OBJS_BASE = \ - abstart.o \ - chem_alloc.o \ - chem_finalize.o \ - chem_init.o \ - chem_output.o \ - wrf_output.o \ - cnuity.o \ - cpl_finalize.o \ - cpl_init.o \ - cpl_run.o \ - datetime.o \ - dffusn.o \ - diag.o \ - diagnoise.o \ - digifilt.o \ - dissip.o \ - do_physics_one_step.o \ - do_physics_one_step_chem.o \ - dyn_alloc.o \ - dyn_finalize.o \ - dyn_init.o \ - dyn_run.o \ - edgvar.o \ - fct3d.o \ - filename.o \ - fimcore.o \ - fimini.o \ - findmxmn.o \ - GetIpnGlobal.o \ - gfs_physics_internal_state_mod.o \ - gfs_physics_namelist_mod.o \ - gfs_physics_sfc_flx_mod.o \ - gfs_physics_sfc_flx_set_mod.o \ - globsum.o \ - hybgen.o \ - hystat.o \ - IncrementTimer.o \ - its2string.o \ - its2time.o \ - lay2lay.o \ - lin2stp.o \ - mktopo.o \ - module_chem_constants.o \ - module_chem_driver.o \ - module_chem_variables.o \ - module_constants.o \ - module_control.o \ - module_decomp.o \ - module_header.o \ - module_initial_chem_namelist_defaults.o \ - module_initial_chem_namelists.o \ - module_outvar_enkf.o \ - module_savesfc.o \ - module_sfc_variables.o \ - module_variables.o \ - module_wrf_control.o \ - module_wrf_variables.o \ - momtum.o \ - op_diag.o \ - out4d_mn.o \ - outDiags.o \ - outFMTed.o \ - output.o \ - outqv.o \ - outqv_mn.o \ - outqv_mn_lat.o \ - outqv_mn_lat_abs.o \ - outqv_mn_lat_land.o \ - outqv_wsp.o \ - OutTime.o \ - phy_finalize.o \ - phy_init.o \ - phy_run.o \ - physics.o \ - PhysicsGetIpnItsMype.o \ - postdata.o \ - printMAXMIN.o \ - profout.o \ - readarr32.o \ - readarr64.o \ - readenkfanal.o \ - read_restart_dyn.o \ - read_restart_phy.o \ - restart.o \ - ss2icos.o \ - StartTimer.o \ - stencilprint.o \ - stenedgprint.o \ - transp3d.o \ - trcadv.o \ - units.o \ - wrf_error_fatal.o \ - wrf_phy_finalize.o \ - wrf_phy_init.o \ - wrf_phy_run.o \ - wrf_share.o \ - wrfphys_alloc.o \ - wrfphysics.o \ - write_restart_dyn.o \ - write_restart_phy.o \ - writearr32.o \ - writearr64.o \ - wtinfo.o diff --git a/src/fim/FIMsrc/fim/horizontal/FIM_HORIZONTAL_OBJS_TOP b/src/fim/FIMsrc/fim/horizontal/FIM_HORIZONTAL_OBJS_TOP deleted file mode 100644 index c4824b2..0000000 --- a/src/fim/FIMsrc/fim/horizontal/FIM_HORIZONTAL_OBJS_TOP +++ /dev/null @@ -1,2 +0,0 @@ -# please keep the following on a single line so copy.ksh can easily read it -OBJS_TOP = init.o run.o finalize.o fim.o diff --git a/src/fim/FIMsrc/fim/horizontal/GetGrid.F90 b/src/fim/FIMsrc/fim/horizontal/GetGrid.F90 deleted file mode 100644 index 0c6bb93..0000000 --- a/src/fim/FIMsrc/fim/horizontal/GetGrid.F90 +++ /dev/null @@ -1,176 +0,0 @@ -module module_GetGrid -contains -! -subroutine GetGrid(npp,nd,glvl,curve,lat,lon,prox,nprox,conr_ll,area,cs,sn,sidevec_c,sidevec_e,sideln,rprox_ln) -! Loads the initial variables and constants to start sgm -! Alexander E. MacDonald 11/27/05 -!********************************************************************* -use module_control,only: nip -implicit none -!real*8 t0 -real, parameter :: pi = 3.1415926535897 -real, parameter :: ae = 6371220. !earth radius - -INTEGER,intent (IN) :: npp,nd,glvl,curve -!SMS$DISTRIBUTE(dh,NIP) BEGIN -real ,intent (IN) :: lat(nip) -real ,intent (INOUT) :: lon(nip) -integer,intent (IN) :: prox(npp,nip),nprox(nip) -real ,intent (INOUT) :: conr_ll(npp,2,nip,2) -real ,intent (OUT) :: area(nip) -real ,intent (OUT) :: cs(4,npp,nip),sn(4,npp,nip) -real ,intent (OUT) :: sidevec_c(nd, npp, nip),sidevec_e(nd, npp, nip) -real ,intent (OUT) :: sideln(npp, nip),rprox_ln(npp, nip) - -real*4 :: lle(npp,2,nip) -!SMS$DISTRIBUTE END - -real*4 map -real*4 conr_xy(npp,2,2) -real*4 prox_xy(npp,2) ! holds x and y locs for prox pts (m) - -real*4 eltp(4),elnp(4) ! 4 lat/lon surrounding a particular edge -real*4 conr_tmp(1:6,1:2) - - -integer :: ipn, isn, ism, ixy, ipt, ip1, im1, j -real :: xlat, xlon, xxp, yyp, xxm, yym, xx, yy, xltc, xlnc, rf - -!call StartTimer(t0) -!SMS$PARALLEL(dh, ipn) BEGIN -!SMS$EXCHANGE(prox) -do ipn=1,nip - if(lon(ipn).lt.0.) lon(ipn)=lon(ipn)+2.*pi -end do - -do ipn=1,nip - do isn=1,nprox(ipn) - conr_tmp(isn,1)=conr_ll(isn,1,ipn,1) - conr_tmp(isn,2)=conr_ll(isn,1,ipn,2) - end do - - do isn=1,nprox(ipn) - ism=isn-1 - if(isn.eq.1) ism=nprox(ipn) - do ixy=1,2 - conr_ll(isn,1,ipn,ixy)=conr_tmp(ism,ixy) - conr_ll(isn,2,ipn,ixy)=conr_tmp(isn,ixy) - end do - end do -end do - -do ipn=1,nip - do isn=1,nprox(ipn) - do ixy=1,nd - lle(isn,ixy,ipn)=.5*(conr_ll(isn,1,ipn,ixy)+conr_ll(isn,2,ipn,ixy)) - end do - if ( abs( conr_ll(isn,1,ipn,2)-conr_ll(isn,2,ipn,2)).gt.pi) lle(isn,2,ipn)=lle(isn,2,ipn)-pi - end do -end do - -!Caculate sidevec and lat/lon at edges - -!SMS$EXCHANGE(lat,lon) -do ipn=1,nip - do isn=1,nprox(ipn) - xlon=lon(prox(isn,ipn)) - xlat=lat(prox(isn,ipn)) - call ll2xy(lon(ipn),lat(ipn),xlon,xlat,prox_xy(isn,1),prox_xy(isn,2)) - rprox_ln(isn,ipn)=1./(ae*sqrt(prox_xy(isn,1)**2+prox_xy(isn,2)**2)) - do ipt=1,2 - xlon=conr_ll(isn,ipt,ipn,2) - xlat=conr_ll(isn,ipt,ipn,1) - call ll2xy(lon(ipn),lat(ipn),xlon,xlat,conr_xy(isn,ipt,1),conr_xy(isn,ipt,2)) - end do - map=2./(1.+sin(lle(isn,1,ipn))*sin(lat(ipn))+cos(lle(isn,1,ipn))*cos(lat(ipn)) & - *cos(lle(isn,2,ipn)-lon(ipn))) - do ixy=1,nd - sidevec_c(ixy,isn,ipn)=ae*( conr_xy(isn,2,ixy)-conr_xy(isn,1,ixy)) *map - end do - call ll2xy(lle(isn,2,ipn),lle(isn,1,ipn),conr_ll(isn,2,ipn,2),conr_ll(isn,2,ipn,1),xxp,yyp) - call ll2xy(lle(isn,2,ipn),lle(isn,1,ipn),conr_ll(isn,1,ipn,2),conr_ll(isn,1,ipn,1),xxm,yym) - sidevec_e(1,isn,ipn)= ae*(xxp-xxm) - sidevec_e(2,isn,ipn)= ae*(yyp-yym) - sideln(isn,ipn)=sqrt(sidevec_e(1,isn,ipn)**2+sidevec_e(2,isn,ipn)**2) - end do ! isn loop - area(ipn)=0. - do isn=1,nprox(ipn) - xx=ae*.5*(conr_xy(isn,2,1)+conr_xy(isn,1,1)) - yy=ae*.5*(conr_xy(isn,2,2)+conr_xy(isn,1,2)) - area(ipn)=area(ipn)+.5*(xx*sidevec_c(2,isn,ipn)-yy*sidevec_c(1,isn,ipn)) - end do -end do ! ipn loop - -do ipn=1,nip - do isn=1,nprox(ipn) - xltc=lle(isn,1,ipn) - xlnc=lle(isn,2,ipn) - ip1=mod(isn,nprox(ipn))+1 - im1=isn-1 - if(im1.eq.0) im1=nprox(ipn) - eltp(1)=lat(ipn) - elnp(1)=lon(ipn) - eltp(2)=lat(prox(isn,ipn)) - elnp(2)=lon(prox(isn,ipn)) - eltp(3)=lat(prox(im1,ipn)) - elnp(3)=lon(prox(im1,ipn)) - eltp(4)=lat(prox(ip1,ipn)) - elnp(4)=lon(prox(ip1,ipn)) - do ipt=1,4 - rf=1.0/(1.0+sin(xltc)*sin(eltp(ipt))+cos(xltc)*cos(eltp(ipt))*cos(elnp(ipt)-xlnc)) - cs(ipt,isn,ipn)=rf*( cos(xltc)*cos(eltp(ipt))+(1.0+sin(xltc)*sin(eltp(ipt)))*cos(elnp(ipt)-xlnc)) - sn(ipt,isn,ipn)=-rf*sin(elnp(ipt)-xlnc)*(sin(xltc)+sin(eltp(ipt))) - end do - enddo -enddo -!SMS$PARALLEL END -!call IncrementTimer(t0,t1) -!print*,'GetGrid time =',t1 - -return -end subroutine GetGrid - -!############################################################# -! ll2xy.f -! Convert lat/lon to (x,y) on General Stereographic Coordinate (GSTC). -! Original program: J.Lee - 2004 -! Program testing: J.Lee - 2004 -! Modified for Non-Structure Grid: J.Lee - 2004 -!############################################################ - -! Purpose: Given latitude and longitude on Spherical coordinate, -! this subroutine computes X and Y coordinates on GSTC. -! Reference: J.Lee, G. Browning, and Y. Xie: -! TELLUS (1995), p.892-910. -! -! Input Variables : Angles are assumed in unit of "radian" -! -! (latc,lonc) : the GSTC projected point. -! ( lat, lon) : Input lat/lon in radians. -! -! OUTPUT Variables: -! -! xm : X-Coordinate values on GSTC. -! positive to East of central longitude -! ym : Y-Coordinate values on GSTC. -! positive to North of central latitude. -! Note: Output variables of xm and ym are -! nondimensionalized with "ae", the radius of earth. -! -subroutine ll2xy(lonc,latc,lon,lat,xm,ym) -! -implicit none -integer i -real*4 lonc,latc,lon,lat,mf -real*4 xm,ym - -mf=2.0/(1.0+sin(lat)*sin(latc)+cos(lat)*cos(latc) & - *cos(lon-lonc)) -xm=mf*(cos(lat)*sin(lon-lonc)) -ym=mf*((sin(lat)*cos(latc)-cos(lat) & - *sin(latc)*cos(lon-lonc)) ) -! -return -end subroutine ll2xy -end module module_GetGrid - diff --git a/src/fim/FIMsrc/fim/horizontal/GetIpnGlobal.F90 b/src/fim/FIMsrc/fim/horizontal/GetIpnGlobal.F90 deleted file mode 100644 index d2d3d61..0000000 --- a/src/fim/FIMsrc/fim/horizontal/GetIpnGlobal.F90 +++ /dev/null @@ -1,18 +0,0 @@ -subroutine GetIpnGlobalMype(ipn,ipnGlobal,mype,DiagPrint) -!For an input ipn this routine returns the global ipn (ipnGLobal), the processor number (mype) and DiagPrint. -!DiagPrint=T means that the input ipn matches PrintIpnDiag from the namelist. - -use module_control,only: PrintIpnDiag -!SMS$insert use module_decomp -implicit none -integer,intent(IN) :: ipn -integer,intent(out):: ipnGlobal,mype -logical,intent(out):: DiagPrint - -ipnGlobal = ipn -!Not needed for dynamic memory!SMS$insert call nnt_UnsToGlobal(dh,ipn,ipnGlobal) -DiagPrint = ipnGlobal==PrintIpnDiag -mype=0 -!SMS$insert call nnt_me(mype) -return -end subroutine GetIpnGlobalMype diff --git a/src/fim/FIMsrc/fim/horizontal/IncrementTimer.F90 b/src/fim/FIMsrc/fim/horizontal/IncrementTimer.F90 deleted file mode 100644 index 2db1716..0000000 --- a/src/fim/FIMsrc/fim/horizontal/IncrementTimer.F90 +++ /dev/null @@ -1,7 +0,0 @@ -subroutine IncrementTimer(t0,t1) -INCLUDE "mpif.h" -real*8,intent(in ) :: t0 -real*8,intent(inout) :: t1 -t1 = t1 + mpi_wtime()-t0 -return -end subroutine IncrementTimer diff --git a/src/fim/FIMsrc/fim/horizontal/Makefile b/src/fim/FIMsrc/fim/horizontal/Makefile deleted file mode 100644 index 783c23c..0000000 --- a/src/fim/FIMsrc/fim/horizontal/Makefile +++ /dev/null @@ -1,114 +0,0 @@ -# horizontal Makefile - -include ../../macros.make -include FIM_HORIZONTAL_OBJS -include FIM_HORIZONTAL_OBJS_TOP - -AR = ar # TODO: move into top-level makefile or macros.make -ARFLAGS = ruv # TODO: move into top-level makefile or macros.make -COLMOBJS = $(shell ls ../column/*.o) -COLUMN_CHEM_OBJS= $(wildcard ../column_chem/*.o) -DEPLIBS = $(LIBDIR)/libbacio_4.a $(LIBDIR)/libsfcio_4.a \ - $(LIBDIR)/libsigio_4.a $(LIBDIR)/libslint.a \ - $(LIBDIR)/libsp_4.a $(LIBDIR)/libsysshare.a \ - $(LIBDIR)/libw3_4.a -ICOSIO = ../../icosio/icosio.o -LIBS = -l$(FIMLIBBASE) -L$(LIBDIR) -lbacio_4 -lgribio -lsfcio_4 \ - -lsigio_4 -lslint -lsp_4 -lsysshare -lw3_4 -lwrfio -LOCFLAGS = $(FFLAGS) $(FREEFLAG) -I$(SMS)/include -I$(UTILSDIR) \ - -I../../icosio -I../../post/pop -I../../prep/sfcio \ - -I../../prep/sigio -I../../prep/incmod -OBJS = $(OBJS_BASE) $(OBJS_TOP) -POSTOBJS = $(foreach x,fimnc post smooth postdata,../../post/pop/$(x).o) -UTILS = $(UTILSDIR)/read_queue_namelist.o $(UTILSDIR)/headers.o -UTILSDIR = ../../utils -WRFPHYS_OBJS = $(shell ls ../wrfphys/*.o | grep -v module_cu_g3.o) - -# Add -g for debugging. - -ifeq ($(DEBUG),yes) - LOCFLAGS += -g -endif - -# For serial, use no-op 'true' (instead of 'ppp') and no extension. - -ifeq ($(P),S) - SMSEXTENSION = - PPP = true -else - SMSEXTENSION = _sms - PPP = $(SMS)/bin/ppp - # HaloSize=2000 is a guess at what will be large enough for all combinations - # of NIP, nPEs, and decomp. GlobalSize=2621442 is for G9 and below. Higher G - # levels will require increasing GlobalSize. GlobalSize=6000000 is for G9.5. - # Higher G levels will require increasing GlobalSize. --Fmodule=module_decomp - # tells SMS to insert "use module_decomp" in every file it processes. This is - # needed to 1) not require the user to add it everywhere; 2) it is not needed - # in serial code; 3) module decomp contains all the decomp info that SMS needs - # in the routines it processes. - PPP_FLAGS1 = --comment --FreeFormat --HaloSize=2000 --GlobalSize=2621442 - PPP_FLAGS = $(PPP_FLAGS1) --Fmodule=module_decomp - PPP_HEADER_FLAGS = --header --comment -endif - -# If degree-based trig intrinsics don't exist, set ifdef to define them as stmt -# functions. - -ifeq ($(NEED_SINDCOSD),yes) - CPP_FLAGS += -DNEED_SINDCOSD -endif - -# Are we going to attach gdb or ddd to a running process? - -ifeq ($(ATTACH_DEBUGGER),yes) - LOCFLAGS += -DATTACH_DEBUGGER -endif - -%.o: %.f90 - $(CPP) $(GPTL_CPPFLAGS) $(CPP_FLAGS) $< > $*.f - $(FC) -c $(GPTL_FFLAGS) $(LOCFLAGS) $(OPTFLAGS) $*.f - -%.o: %.F90 - $(CPP) $(GPTL_CPPFLAGS) $(CPP_FLAGS) $< > $*_cpp.f - $(PPP) $(PPP_FLAGS) $*_cpp.f # use --debug for added PPP debugging - $(FC) -c $(GPTL_FFLAGS) $(LOCFLAGS) $(OPTFLAGS) $*_cpp$(SMSEXTENSION).f -o $*.o - -%.o: %.c - $(CC) -c -g $(CFLAGS) $(FORTRAN_UNDERSCORING) $< - -all: $(FIMEXE) - -physics.o: $(DEPLIBS) - --include FIM_HORIZONTAL_DEPENDENCIES - -$(FIMEXE): $(FIMLIB) $(OBJS_TOP) $(DEPLIBS) - $(FC) -o $(FIMEXE) $(FFLAGS) -L$(SMS)/lib $(LINKFLAGS) $(OBJS_TOP) \ - $(LIBS) -lsms $(LINKLIBS) $(GPTL_LDFLAGS) $(LDFLAGS) $(LIBNETCDF) - -# Build a library of all FIM object files except $(OBJS_TOP). This is needed -# when building FIM from within the NEMS repository but would not be needed by -# other builds. However, always building $(FIMLIB) significantly simplifies -# build automation (for example, no additional $(FTNMPI) values need to be -# supported by makefim, special logic is not needed in fim/horizontal/copy.ksh -# to avoid building $(OBJS_TOP) files, additional logic is not needed in the -# top-level Makefile, etc.). And, since we will always build it, we should -# use it to build $(FIMEXE) to avoid using a separate but equivalent approach -# when building from within NEMS. - -$(FIMLIB): $(OBJS_BASE) $(COLMOBJS) $(POSTOBJS) $(COLUMN_CHEM_OBJS) \ - $(WRFPHYS_OBJS) $(UTILS) $(ICOSIO) - $(AR) $(ARFLAGS) $@ $? - -module_control.o module_decomp.o module_wrf_control.o: - $(CPP) $(GPTL_CPPFLAGS) $(CPP_FLAGS) $< > $*_cpp.f - $(PPP) $(PPP_FLAGS1) $*_cpp.f - $(FC) -c $(GPTL_FFLAGS) $(LOCFLAGS) $(OPTFLAGS) $*_cpp$(SMSEXTENSION).f -o $*.o - -# The following -O0 rule ensures bitwise-exact output between serial & parallel -# runs built using ifort 9.1. - -module_chem_driver.o: - $(CPP) $(GPTL_CPPFLAGS) $(CPP_FLAGS) $< > $*_cpp.f - $(PPP) $(PPP_FLAGS) $*_cpp.f - $(FC) -c $(GPTL_FFLAGS) $(LOCFLAGS) $(OPTFLAGS) -O0 $*_cpp$(SMSEXTENSION).f -o $*.o diff --git a/src/fim/FIMsrc/fim/horizontal/Makefile.sms-r8 b/src/fim/FIMsrc/fim/horizontal/Makefile.sms-r8 deleted file mode 100644 index 3e087ec..0000000 --- a/src/fim/FIMsrc/fim/horizontal/Makefile.sms-r8 +++ /dev/null @@ -1,67 +0,0 @@ -SHELL = /bin/sh -# Makefile for parallel (SMS) horizontal FIM -SMS=/whome/jacquesm/sms-2.9.1.20 -#FLAGS = $(FFLAGS) $(FREEFLAG) -I $(SMS)/include -DVERBOSE -FLAGS = $(FFLAGS) $(FREEFLAG) -I $(SMS)/include - -include FIM_HORIZONTAL_OBJS -include FIM_HORIZONTAL_OBJS_TOP -OBJS = $(OBJS_BASE) $(OBJS_TOP) - -PINCLUDES = $(INCLUDES:.inc=.inc.SMS ) -LIBSMS = -L$(SMS)/lib -lsms -LIBS = $(LIBSMS) - -#HALOSIZE will be passed to SMS and to both init.F90 and module_decomp.F90 -NGRIDPTS := $(shell echo "10*(2^$(G))^2+2 "|bc ) -HALOSIZE := $(shell echo "6*sqrt($(NGRIDPTS)/$(P))+45"|bc ) -# -NIP := $(shell echo "$(NGRIDPTS)+2*$(HALOSIZE)+1 "|bc ) -PPP = $(SMS)/bin/ppp -PPP_FLAGS = --r8 --Fmodule=module_decomp --comment --FreeFormat --HaloSize=$(HALOSIZE) --GlobalSize=$(NIP) $*_cpp.f -PPP_FLAGS1 = --r8 --comment --FreeFormat --HaloSize=$(HALOSIZE) --GlobalSize=$(NIP) $*_cpp.f -PPP_HEADER_FLAGS = --header --comment - -CPP=/lib/cpp -#CPP_FLAGS=-traditional -P -C -D HALO_SIZE=$(HALOSIZE) -DVERBOSE -CPP_FLAGS=-traditional -P -C -D HALO_SIZE=$(HALOSIZE) - -# --------------------------------------------------------------------------- - -.SUFFIXES: -.SUFFIXES: .o .F90 .f .f90 - -.F90.o : - $(CPP) $(CPP_FLAGS) $*.F90 > $*_cpp.f - $(PPP) $(PPP_FLAGS) - $(FC) -c $(FLAGS) $*_cpp_sms.f - mv $*_cpp_sms.o $*.o - - -.f90.o : - $(FC) -c $(FLAGS) $*.f90 - -all: $(FIMEXE) - -include FIM_HORIZONTAL_DEPENDENCIES - -machine.o: machine.f - $(FC) -c $(COLFFLAGS) $< -physcons_v.o : physcons_v.F90 machine.o - $(FC) -c $(COLFFLAGS) $< -funcphys_v.o : funcphys_v.F90 machine.o physcons_v.o - $(FC) -c $(COLFFLAGS) $< -module_control.o: module_control.F90 - $(CPP) $(CPP_FLAGS) $*.F90 > $*_cpp.f - $(PPP) $(PPP_FLAGS1) - $(FC) -c $(FLAGS) $*_cpp_sms.f - mv $*_cpp_sms.o $*.o -module_decomp.o: module_decomp.F90 module_control.o - $(CPP) $(CPP_FLAGS) $*.F90 > $*_cpp.f - $(PPP) $(PPP_FLAGS1) - $(FC) -c $(FLAGS) $*_cpp_sms.f - mv $*_cpp_sms.o $*.o - -$(FIMEXE): $(OBJS) - $(FC) -o $(FIMEXE) $(FLAGS) $(OBJS) -L$(SMS)/lib -lsms - diff --git a/src/fim/FIMsrc/fim/horizontal/OutTime.F90 b/src/fim/FIMsrc/fim/horizontal/OutTime.F90 deleted file mode 100644 index b231dc7..0000000 --- a/src/fim/FIMsrc/fim/horizontal/OutTime.F90 +++ /dev/null @@ -1,488 +0,0 @@ - -!********************************************************************* - module module_outtime_main -! This module stores and prints elapsed wall-clock times for -! various parts of FIM. -! J. Middlecoff April, 2008 -!********************************************************************* - -implicit none - -real*8, save :: MainLoopTime=0.0d0 - -contains - -subroutine OutTime(maxmin_times) - -! iff .TRUE., print only max and min times -! otherwise, print times for many tasks -logical, optional, intent(in) :: maxmin_times - -! local variables -logical :: maxmin_times_lcl -real :: MainLoopTimeMIN -real :: MainLoopTimeMAX - -integer :: mype=0 -!SMS$insert call nnt_me(mype) - -maxmin_times_lcl = .false. -if (present(maxmin_times)) maxmin_times_lcl = maxmin_times - -MainLoopTimeMIN = MainLoopTime -!SMS$reduce(MainLoopTimeMIN,MIN) -MainLoopTimeMAX = MainLoopTime -!SMS$reduce(MainLoopTimeMAX,MAX) - -if (maxmin_times_lcl) then - print"(' Main loop ',2f15.3)",MainLoopTimeMIN,MainLoopTimeMAX -else -!SMS$ignore begin - print"(' Main loop ',f15.3,i10)",MainLoopTime,mype -!SMS$ignore end -endif - -return -end subroutine OutTime - -end module module_outtime_main - -!********************************************************************* - module module_outtime_dyn -! This module stores and prints elapsed wall-clock times for -! various parts of FIM dynamics. -! J. Middlecoff April, 2008 -!********************************************************************* - -implicit none - -real*8, save :: tdyn=0.0d0 -real*8, save :: tout=0.0d0 -real*8, save :: toutputBa=0.0d0 -real*8, save :: thystat=0.0d0 -real*8, save :: tedgvar=0.0d0 -real*8, save :: tmomtum=0.0d0 -real*8, save :: thybgen=0.0d0 -real*8, save :: tprofout=0.0d0 -real*8, save :: tabstart=0.0d0 -real*8, save :: tcnuity=0.0d0 -real*8, save :: ttrcadv=0.0d0 -real*8, save :: ttransp=0.0d0 -real*8, save :: tedgvarEx=0.0d0 -real*8, save :: tedgvarBa=0.0d0 -real*8, save :: tcnuityEx=0.0d0 -real*8, save :: tcnuityBa=0.0d0 -real*8, save :: ttrcadvEx=0.0d0 -real*8, save :: ttrcadvBa=0.0d0 -real*8, save :: ttranspEx=0.0d0 -real*8, save :: ttranspBa=0.0d0 -real*8, save :: tread_restart=0.0d0 -real*8, save :: twrite_restart=0.0d0 - -contains - -subroutine OutTime(maxmin_times,TimingBarriers,print_header) - -! iff .TRUE., print only max and min times -! otherwise, print times for many tasks -logical, optional, intent(in) :: maxmin_times - -! iff .TRUE., print barrier times -logical, optional, intent(in) :: TimingBarriers - -! iff .TRUE., print header -logical, optional, intent(in) :: print_header - -! local variables -logical :: maxmin_times_lcl -logical :: TimingBarriers_lcl -logical :: print_header_lcl - -real :: tedgvarE,tcnuityE,ttrcadvE,ExchangeTime -real :: tedgvarB,tcnuityB,ttrcadvB,ExchBarrierTime -real :: tedgvarBMIN,tcnuityBMIN,ttrcadvBMIN,ExchBarrierTimeMIN -real :: tedgvarBMAX,tcnuityBMAX,ttrcadvBMAX,ExchBarrierTimeMAX - -real :: tdynMIN,toutMIN,thybgenMIN,thystatMIN,tprofoutMIN -real :: tabstartMIN,tedgvarMIN,tcnuityMIN,ttrcadvMIN,tmomtumMIN -real :: tedgvarEMIN,ttrcadvEMIN,ExchangeTimeMIN -real :: tcnuityEMIN,toutputBMIN,tread_restartMIN,twrite_restartMIN - -real :: tdynMAX,toutMAX,thybgenMAX,thystatMAX,tprofoutMAX -real :: tabstartMAX,tedgvarMAX,tcnuityMAX,ttrcadvMAX,tmomtumMAX -real :: tedgvarEMAX,ttrcadvEMAX,ExchangeTimeMAX -real :: tcnuityEMAX,toutputBMAX,tread_restartMAX,twrite_restartMAX - -integer :: mype=0 -!SMS$insert call nnt_me(mype) - -maxmin_times_lcl = .false. -if (present(maxmin_times)) maxmin_times_lcl = maxmin_times -TimingBarriers_lcl = .false. -if (present(TimingBarriers)) TimingBarriers_lcl = TimingBarriers -print_header_lcl = .false. -if (present(print_header)) print_header_lcl = print_header - -tedgvarE = tedgvarEx -tcnuityE = tcnuityEx -ttrcadvE = ttrcadvEx -ExchangeTime = tedgvarE+tcnuityE+ttrcadvE - -tedgvarB = tedgvarBa -tcnuityB = tcnuityBa -ttrcadvB = ttrcadvBa -ExchBarrierTime = tedgvarB+tcnuityB+ttrcadvB - -tdynMIN = tdyn -toutMIN = tout -toutputBMIN = toutputBa -thybgenMIN = thybgen -thystatMIN = thystat -tprofoutMIN = tprofout -tabstartMIN = tabstart -tedgvarMIN = tedgvar -tcnuityMIN = tcnuity -ttrcadvMIN = ttrcadv -tmomtumMIN = tmomtum -tedgvarEMIN = tedgvarE -tcnuityEMIN = tcnuityE -ttrcadvEMIN = ttrcadvE -ExchangeTimeMIN = ExchangeTime -tedgvarBMIN = tedgvarB -tcnuityBMIN = tcnuityB -ttrcadvBMIN = ttrcadvB -ExchBarrierTimeMIN = ExchBarrierTime -tread_restartMIN = tread_restart -twrite_restartMIN = twrite_restart - -!SMS$reduce(tdynMIN,toutMIN,thybgenMIN,thystatMIN,toutputBMIN, -!SMS$> tprofoutMIN,tabstartMIN,tedgvarMIN,tcnuityMIN,ttrcadvMIN, -!SMS$> tmomtumMIN,tedgvarEMIN,tcnuityEMIN, -!SMS$> ttrcadvEMIN,ExchangeTimeMIN, -!SMS$> tedgvarBMIN,tcnuityBMIN,ttrcadvBMIN,ExchBarrierTimeMIN, -!SMS$> tread_restartMIN,twrite_restartMIN, -!SMS$> MIN) - -tdynMAX = tdyn -toutMAX = tout -toutputBMAX = toutputBa -thybgenMAX = thybgen -thystatMAX = thystat -tprofoutMAX = tprofout -tabstartMAX = tabstart -tedgvarMAX = tedgvar -tcnuityMAX = tcnuity -ttrcadvMAX = ttrcadv -tmomtumMAX = tmomtum -tedgvarEMAX = tedgvarE -tcnuityEMAX = tcnuityE -ttrcadvEMAX = ttrcadvE -ExchangeTimeMAX = ExchangeTime -tedgvarBMAX = tedgvarB -tcnuityBMAX = tcnuityB -ttrcadvBMAX = ttrcadvB -ExchBarrierTimeMAX = ExchBarrierTime -tread_restartMAX = tread_restart -twrite_restartMAX = twrite_restart - -!SMS$reduce(tdynMAX,toutMAX,thybgenMAX,thystatMAX,toutputBMAX, -!SMS$> tprofoutMAX,tabstartMAX,tedgvarMAX,tcnuityMAX,ttrcadvMAX, -!SMS$> tmomtumMAX,tedgvarEMAX,tcnuityEMAX, -!SMS$> ttrcadvEMAX,ExchangeTimeMAX, -!SMS$> tedgvarBMAX,tcnuityBMAX,ttrcadvBMAX,ExchBarrierTimeMAX, -!SMS$> tread_restartMAX,twrite_restartMAX, -!SMS$> MAX) - -if (maxmin_times_lcl) then - -if (print_header_lcl) then - if (TimingBarriers_lcl) then - print"(' MODULE TIME (sec) EXCHANGE TIME (sec) EXCH BARRIER TIME (sec)')" - print"(' Module MIN MAX MIN MAX MIN MAX')" - else - print"(' MODULE TIME (sec) EXCHANGE TIME (sec)')" - print"(' Module MIN MAX MIN MAX')" - endif -endif - print"(' Dynamics ',2f15.3)",tdynMIN,tdynMAX - print"(' Output ',2f15.3)",toutMIN,toutMAX - if (TimingBarriers_lcl) then - print"(' Output Wait ',2f15.3)",toutputBMIN,toutputBMAX - endif - print"(' hybgen ',2f15.3)",thybgenMIN,thybgenMAX - print"(' hystat ',2f15.3)",thystatMIN,thystatMAX - print"(' profout ',2f15.3)",tprofoutMIN,tprofoutMAX - print"(' abstart ',2f15.3)",tabstartMIN,tabstartMAX - if (TimingBarriers_lcl) then - print"(' edgvar ',6f15.3)",tedgvarMIN,tedgvarMAX,tedgvarEMIN,tedgvarEMAX,tedgvarBMIN,tedgvarBMAX - print"(' cnuity ',6f15.3)",tcnuityMIN,tcnuityMAX,tcnuityEMIN,tcnuityEMAX,tcnuityBMIN,tcnuityBMAX - print"(' trcadv ',6f15.3)",ttrcadvMIN,ttrcadvMAX,ttrcadvEMIN,ttrcadvEMAX,ttrcadvBMIN,ttrcadvBMAX - else - print"(' edgvar ',4f15.3)",tedgvarMIN,tedgvarMAX,tedgvarEMIN,tedgvarEMAX - print"(' cnuity ',4f15.3)",tcnuityMIN,tcnuityMAX,tcnuityEMIN,tcnuityEMAX - print"(' trcadv ',4f15.3)",ttrcadvMIN,ttrcadvMAX,ttrcadvEMIN,ttrcadvEMAX - endif - print"(' momtum ',2f15.3)",tmomtumMIN,tmomtumMAX - print"(' Exchange ',2f15.3)",ExchangeTimeMIN,ExchangeTimeMAX - if (TimingBarriers_lcl) then - print"(' ExchBarrier ',2f15.3)",ExchBarrierTimeMIN,ExchBarrierTimeMAX - endif - print"(' read_restart ',2f15.3)",tread_restartMIN,tread_restartMAX - print"(' write_restart ',2f15.3)",twrite_restartMIN,twrite_restartMAX - -else - -!SMS$ignore begin - print"(' Dynamics ',f15.3,i10)",tdyn,mype - print"(' Output ',f15.3,i10)",tout,mype - if (TimingBarriers_lcl) then - print"(' Output_Wait ',f15.3,i10)",toutputBa,mype - endif - print"(' hybgen ',f15.3,i10)",thybgen,mype - print"(' hystat ',f15.3,i10)",thystat,mype - print"(' profout ',f15.3,i10)",tprofout,mype - print"(' abstart ',f15.3,i10)",tabstart,mype - print"(' edgvar ',f15.3,i10)",tedgvar,mype - print"(' edgvarE ',f15.3,i10)",tedgvarE,mype - if (TimingBarriers_lcl) then - print"(' edgvarB ',f15.3,i10)",tedgvarB,mype - endif - print"(' cnuity ',f15.3,i10)",tcnuity,mype - print"(' cnuityE ',f15.3,i10)",tcnuityE,mype - if (TimingBarriers_lcl) then - print"(' cnuityB ',f15.3,i10)",tcnuityB,mype - endif - print"(' trcadv ',f15.3,i10)",ttrcadv,mype - print"(' trcadvE ',f15.3,i10)",ttrcadvE,mype - if (TimingBarriers_lcl) then - print"(' trcadvB ',f15.3,i10)",ttrcadvB,mype - endif - print"(' momtum ',f15.3,i10)",tmomtum,mype - print"(' Exchange ',f15.3,i10)",ExchangeTime,mype - if (TimingBarriers_lcl) then - print"(' ExchBarrier ',f15.3,i10)",ExchBarrierTime,mype - endif - print"(' read_restart ',2f15.3)",tread_restart,mype - print"(' write_restart ',2f15.3)",twrite_restart,mype -!SMS$ignore end - -endif - -return -end subroutine OutTime - -end module module_outtime_dyn - - - -!********************************************************************* - module module_outtime_phy -! This module stores and prints elapsed wall-clock times for -! various parts of FIM physics. -! J. Middlecoff April, 2008 -!********************************************************************* - -implicit none - -real*8, save :: tphy=0.0d0 - -contains - -subroutine OutTime(maxmin_times) - -! iff .TRUE., print only max and min times -! otherwise, print times for many tasks -logical, optional, intent(in) :: maxmin_times - -! local variables -logical :: maxmin_times_lcl -real :: tphyMIN -real :: tphyMAX - -integer :: mype=0 -!SMS$insert call nnt_me(mype) - -maxmin_times_lcl = .false. -if (present(maxmin_times)) maxmin_times_lcl = maxmin_times - -tphyMIN = tphy -!SMS$reduce(tphyMIN,MIN) -tphyMAX = tphy -!SMS$reduce(tphyMAX,MAX) - -if (maxmin_times_lcl) then - print"(' Physics ',2f15.3)",tphyMIN,tphyMAX -else -!SMS$ignore begin - print"(' Physics ',f15.3,i10)",tphy,mype -!SMS$ignore end -endif - -return -end subroutine OutTime - -end module module_outtime_phy - - - - -!********************************************************************* - module module_outtime_chem -! This module stores and prints elapsed wall-clock times for -! various parts of FIM chemistry. -! J. Middlecoff April, 2008 -!********************************************************************* - -implicit none - -real*8, save :: tchem=0.0d0 - -contains - -subroutine OutTime(maxmin_times) - -! iff .TRUE., print only max and min times -! otherwise, print times for many tasks -logical, optional, intent(in) :: maxmin_times - -! local variables -logical :: maxmin_times_lcl -real :: tchemMIN -real :: tchemMAX - -!SMS$insert integer :: mype -!SMS$insert call nnt_me(mype) - -maxmin_times_lcl = .false. -if (present(maxmin_times)) maxmin_times_lcl = maxmin_times - -tchemMIN = tchem -!SMS$reduce(tchemMIN,MIN) -tchemMAX = tchem -!SMS$reduce(tchemMAX,MAX) - -if (maxmin_times_lcl) then -!SMS$insert print"(' Chemistry ',2f15.3)",tchemMIN,tchemMAX -else -!SMS$ignore begin -!SMS$insert print"(' Chemistry ',f15.3,i10)",tchem,mype -!SMS$ignore end -endif - -return -end subroutine OutTime - -end module module_outtime_chem - - -!TODO: DRY this out! *Way* too much overlap with module_outtime_phy -!TODO: and others! -!********************************************************************* - module module_outtime_wrf_phy -! This module stores and prints elapsed wall-clock times for -! various parts of WRF physics. -!********************************************************************* - -implicit none - -real*8, save :: tphy=0.0d0 - -contains - -subroutine OutTime(maxmin_times) - -! iff .TRUE., print only max and min times -! otherwise, print times for many tasks -logical, optional, intent(in) :: maxmin_times - -! local variables -logical :: maxmin_times_lcl -real :: tphyMIN -real :: tphyMAX - -integer :: mype=0 -!SMS$insert call nnt_me(mype) - -maxmin_times_lcl = .false. -if (present(maxmin_times)) maxmin_times_lcl = maxmin_times - -tphyMIN = tphy -!SMS$reduce(tphyMIN,MIN) -tphyMAX = tphy -!SMS$reduce(tphyMAX,MAX) - -if (maxmin_times_lcl) then - print"(' WRF Physics ',2f15.3)",tphyMIN,tphyMAX -else -!SMS$ignore begin - print"(' WRF Physics ',f15.3,i10)",tphy,mype -!SMS$ignore end -endif - -return -end subroutine OutTime - -end module module_outtime_wrf_phy - - - - -!********************************************************************* - module module_outtime_cpl -! This module stores and prints elapsed wall-clock times for -! various parts of FIM coupler. -! T. Henderson March, 2009 -!********************************************************************* - -implicit none - -real*8, save :: tcpl=0.0d0 - -contains - -subroutine OutTime(maxmin_times,print_header) - -! iff .TRUE., print only max and min times -! otherwise, print times for many tasks -logical, optional, intent(in) :: maxmin_times - -! iff .TRUE., print header -logical, optional, intent(in) :: print_header - -! local variables -logical :: maxmin_times_lcl -logical :: print_header_lcl -real :: tcplMIN -real :: tcplMAX - -integer :: mype=0 -!SMS$insert call nnt_me(mype) - -maxmin_times_lcl = .false. -if (present(maxmin_times)) maxmin_times_lcl = maxmin_times - -print_header_lcl = .false. -if (present(print_header)) print_header_lcl = print_header - -tcplMIN = tcpl -!SMS$reduce(tcplMIN,MIN) -tcplMAX = tcpl -!SMS$reduce(tcplMAX,MAX) - -if (maxmin_times_lcl) then - if (print_header_lcl) then - print"(' MODULE TIME (sec)')" - print"(' Module MIN MAX')" - endif - print"(' Coupler ',2f15.3)",tcplMIN,tcplMAX -else -!SMS$ignore begin - print"(' Coupler ',f15.3,i10)",tcpl,mype -!SMS$ignore end -endif - -return - -end subroutine OutTime - -end module module_outtime_cpl diff --git a/src/fim/FIMsrc/fim/horizontal/PhysicsGetIpnItsMype.F90 b/src/fim/FIMsrc/fim/horizontal/PhysicsGetIpnItsMype.F90 deleted file mode 100644 index b0adc74..0000000 --- a/src/fim/FIMsrc/fim/horizontal/PhysicsGetIpnItsMype.F90 +++ /dev/null @@ -1,21 +0,0 @@ -subroutine PhysicsGetIpnItsMype(ipnGlobal,itsOut,mype,DiagPrint) -!This routine returns the global ipn (ipnGLobal), its (itsOut),the processor number (mype) and DiagPrint. -!DiagPrint=T means that the current ipn in physics.F90 matches PrintIpnDiag from the namelist. -!This routine only works for routines that are in the calling tree whose base is in a -!parallel DO IPN=1,NIP loop in physics.F90. - -use module_control,only: PrintIpnDiag -use module_physics,only: ipn,itsP -!SMS$insert use module_physics,only: dh -implicit none -integer,intent(out):: ipnGlobal,itsOut,mype -logical,intent(out):: DiagPrint - -ipnGlobal = ipn -!Not needed for dynamic memory!SMS$insert call nnt_UnsToGlobal(dh,ipn,ipnGlobal) -DiagPrint = ipnGlobal==PrintIpnDiag -itsOut = itsP -mype=0 -!SMS$insert call nnt_me(mype) -return -end subroutine PhysicsGetIpnItsMype diff --git a/src/fim/FIMsrc/fim/horizontal/SMS_Module_Lookup.txt b/src/fim/FIMsrc/fim/horizontal/SMS_Module_Lookup.txt deleted file mode 100644 index 98613e7..0000000 --- a/src/fim/FIMsrc/fim/horizontal/SMS_Module_Lookup.txt +++ /dev/null @@ -1,53 +0,0 @@ -funcphys ../column/funcphys_v.F90 -machine ../column/machine.f -module_abstart ./abstart_cpp_sms.f.tmp -module_chem_alloc ./chem_alloc_cpp_sms.f.tmp -module_chem_driver ./module_chem_driver_cpp_sms.f.tmp -module_chem_namelist_defaults ./module_initial_chem_namelist_defaults_cpp_sms.f.tmp -module_chem_output ./chem_output_cpp_sms.f.tmp -module_chemvars ./module_chemvars_cpp_sms.f.tmp -module_constants ./module_constants_cpp_sms.f.tmp -module_control ./module_control_cpp_sms.f.tmp -module_decomp ./module_decomp_cpp_sms.f.tmp -module_diag ./diag_cpp_sms.f.tmp -module_diagnoise ./diagnoise_cpp_sms.f.tmp -module_diagnoses ./diagnoses_cpp_sms.f.tmp -module_do_physics_one_step ./do_physics_one_step_cpp_sms.f.tmp -module_do_physics_one_step_chem ./do_physics_one_step_chem_cpp_sms.f.tmp -module_dp2pi ./dp2pi_cpp_sms.f.tmp -module_dyn_alloc ./dyn_alloc_cpp_sms.f.tmp -module_fctprs ./fctprs_cpp_sms.f.tmp -module_fctq ./fctq_cpp_sms.f.tmp -module_fim_chem_init ./chem_init_cpp_sms.f.tmp -module_force ./force_cpp_sms.f.tmp -module_getgrid ./GetGrid_cpp_sms.f.tmp -module_getq ./getq_cpp_sms.f.tmp -module_getscl ./getscl_cpp_sms.f.tmp -module_hybgen ./hybgen_cpp_sms.f.tmp -module_load_ls ./load_ls_cpp_sms.f.tmp -module_op_diag ./op_diag_cpp_sms.f.tmp -module_out4d_mn ./out4d_mn_cpp_sms.f.tmp -module_outDiags ./outDiags_cpp_sms.f.tmp -module_outFMTed ./outFMTed_cpp_sms.f.tmp -module_output ./output_cpp_sms.f.tmp -module_outqv ./outqv_cpp_sms.f.tmp -module_outqv_mn ./outqv_mn_cpp_sms.f.tmp -module_physics ./physics_cpp_sms.f.tmp -module_pi2dp ./pi2dp_cpp_sms.f.tmp -module_printMAXMIN ./printMAXMIN_cpp_sms.f.tmp -module_profout ./profout_cpp_sms.f.tmp -module_qv2rh ./qv2rh_cpp_sms.f.tmp -module_qvini ./qvini_cpp_sms.f.tmp -restart ./restart_cpp_sms.f.tmp -module_rh2qv ./rh2qv_cpp_sms.f.tmp -module_sfc_variables ./module_sfc_variables_cpp_sms.f.tmp -module_timedif ./timedif_cpp_sms.f.tmp -module_variables ./module_variables_cpp_sms.f.tmp -module_wrf_control ../../cntl/module_wrf_control.F90 -module_wrf_phy_init ./wrf_phy_init_cpp_sms.f.tmp -module_wrfphys_alloc ./wrfphys_alloc_cpp_sms.f.tmp -module_wrfphysics ./wrfphysics_cpp_sms.f.tmp -physcons ../column/physcons_v.F90 -resol_def ../column/resol_def.F90 -post ../../post/pop/post.F90 -units ./units_cpp_sms.f.tmp diff --git a/src/fim/FIMsrc/fim/horizontal/StartTimer.F90 b/src/fim/FIMsrc/fim/horizontal/StartTimer.F90 deleted file mode 100644 index a5da520..0000000 --- a/src/fim/FIMsrc/fim/horizontal/StartTimer.F90 +++ /dev/null @@ -1,6 +0,0 @@ -subroutine StartTimer(t0) -INCLUDE "mpif.h" -real*8,intent(out) :: t0 -t0 = mpi_wtime() -return -end subroutine StartTimer diff --git a/src/fim/FIMsrc/fim/horizontal/abstart.F90 b/src/fim/FIMsrc/fim/horizontal/abstart.F90 deleted file mode 100644 index 97a4fdf..0000000 --- a/src/fim/FIMsrc/fim/horizontal/abstart.F90 +++ /dev/null @@ -1,68 +0,0 @@ -module module_abstart -contains -!############################################################# -! abstart.f90 -! "Adams-Bashforth start" -! Original program: A. E. MacDonald - August 1991 -! J. Lee - September, 2005 -! Purpose: This subroutine taken from QNH model initiates -! the third order Adams-Bashforth time differencing. -! Note that although it is the third order scheme of A-B, -! its accuracy is fourth order in time. -!############################################################# - -subroutine abstart (its,itsStart, & - nf,of,vof, & ! Adams Bash time dif indices - adbash1,adbash2,adbash3) ! constants for Adams Bashforth - -use module_control, only: dt - -implicit none - -integer,intent (IN) :: its ! model time step -integer,intent (IN) :: itsStart ! first model time step -integer,intent (INOUT) :: nf,of,vof -real ,intent (INOUT) :: adbash1,adbash2,adbash3 - -!............................................................. -! Sec 1. Adams-Bashforth Load -!............................................................. - -! Adams-Bashforth indexes -nf = nf + 1 -if (nf == 4) nf = 1 -of = of + 1 -if (of == 4) of = 1 -vof = vof + 1 -if (vof == 4) vof = 1 - -!JR Should be able to do it this way, but be CAREFUL that it also works for digifilt=.t. in run.F90 -! vof = of -! of = nf -! nf = nf + 1 -! if (nf == 4) nf = 1 - -! Third order Adams-Bashforth must use Forward differencing -! on the first time step, and Second Order AB on the second - -if (its == 1)then - adbash1 = dt - adbash2 = 0. - adbash3 = 0. -endif - -if (its == 2)then - adbash1 = dt*1.5 - adbash2 = -dt*.5 - adbash3 = 0. -endif - -if (its == 3)then - adbash1 = dt*23./12. - adbash2 = -dt*16./12. - adbash3 = dt*5./12. -endif - -return -end subroutine abstart -end module module_abstart diff --git a/src/fim/FIMsrc/fim/horizontal/chem_alloc.F90 b/src/fim/FIMsrc/fim/horizontal/chem_alloc.F90 deleted file mode 100644 index c92d480..0000000 --- a/src/fim/FIMsrc/fim/horizontal/chem_alloc.F90 +++ /dev/null @@ -1,308 +0,0 @@ -!********************************************************************* -module module_chem_alloc -! This module allocates variables used in chem -! Henderson November 2008 -!********************************************************************* -contains - - -subroutine chem_alloc(chem_opt,aer_ra_feedback) - -use module_control,only: nvl,nip -use module_wrf_control,only: num_emis_ant,num_emis_vol,nvl_gocart,num_chem -use module_chem_variables,only: emiss_ab,pm25,p10,rcav,ero1,ero2,ero3,dm0, & - emiss_oc,emiss_bc,emiss_sulf,oh_backgd,h2o2_backgd, & - no3_backgd,emiss_abu,plumestuff,aod2d,emiss_ash_mass,& - emiss_ash_height,emiss_ash_dt,ashfall,rnav,tr1_tavg, & - emiss_tr_height,emiss_tr_mass,emiss_tr_dt,trfall, & - clayfrac,sandfrac,emiss_co2 - -implicit none - -integer, intent(IN) :: chem_opt,aer_ra_feedback - -! always allocate these because they are passed -! through an arglist -!TODO: Create chem_internal_state and avoid all this complication. -!TODO: Avoid allocating *any* arrays that are not used! -print *,'DEBUG chem_alloc(): allocating...' - allocate(pm25(nvl,nip)) - pm25=0. - allocate(p10(nvl,nip)) - p10=0. - allocate(tr1_tavg(nvl,nip)) - tr1_tavg=0. - allocate(oh_backgd(nvl_gocart,nip)) - oh_backgd=0. - allocate( h2o2_backgd(nvl_gocart,nip) ) - allocate( no3_backgd(nvl_gocart,nip) ) - allocate( rcav(nip) ) - rcav = 0. - allocate( rnav(nip) ) - rnav = 0. - allocate( ero1(nip) ) - allocate( ero2(nip) ) - allocate( ero3(nip) ) - allocate( clayfrac(nip) ) - allocate( sandfrac(nip) ) - allocate( ashfall(nip) ) - allocate( aod2d(nip) ) - aod2d = 0. - allocate( plumestuff(nip,8) ) - plumestuff = 0. - allocate( emiss_ab(nip,num_emis_ant) ) - emiss_ab = 0. - allocate( emiss_abu(nip,num_emis_ant) ) - emiss_abu = 0. - allocate( emiss_ash_mass(nip) ) - emiss_ash_mass = 0. - allocate( emiss_ash_height(nip) ) - emiss_ash_height = 0. - allocate( emiss_ash_dt(nip) ) - emiss_ash_dt = 0. - allocate( emiss_co2(nip) ) - emiss_co2 = 0. - -!if(chem_opt == 500)then - allocate( emiss_tr_mass(nip) ) - emiss_tr_mass = 0. - allocate( emiss_tr_height(nip) ) - emiss_tr_height = 0. - allocate( emiss_tr_dt(nip) ) - emiss_tr_dt = 0. - ALLOCATE( trfall( nip, num_chem ) ) - trfall = 0. -! endif - - allocate( emiss_oc(nip) ) - emiss_oc = 0. - allocate( emiss_bc(nip) ) - emiss_bc = 0. - allocate( emiss_sulf(nip) ) - emiss_sulf = 0. - allocate( dm0(nip) ) - dm0 = 0. - -return -end subroutine chem_alloc - - -!TODO: combine with chem_alloc if practical -subroutine chem_alloc2(chem_opt,aer_ra_feedback,bio_emiss_opt,biomass_burn_opt,kemit) - - USE module_wrf_control, only: ims,ime,jms,jme,kms,kme,nbands, & - num_emis_vol,num_moist,num_chem,num_emis_ant, & - num_ext_coef,num_bscat_coef,num_asym_par - ! yes, use ALL of it - use module_chemvars - - implicit none - - integer, intent(IN) :: chem_opt,aer_ra_feedback,kemit, & - bio_emiss_opt,biomass_burn_opt - ALLOCATE( chem( ims:ime, kms:kme, jms:jme, num_chem ) ) - ALLOCATE( e_bio( ims:ime, jms:jme, ne_area ) ) - ALLOCATE( emis_ant( ims:ime, 1:kemit, jms:jme,num_emis_ant) ) -emis_ant = 0. - ALLOCATE( emis_vol( ims:ime, kms:kme, jms:jme,num_emis_vol) ) -emis_vol=0. - ALLOCATE( relhum( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( dms_0( ims:ime, jms:jme) ) - ALLOCATE( erod( ims:ime, jms:jme,3) ) - ALLOCATE( emis_dust( ims:ime, 1, jms:jme,num_emis_dust) ) -emis_dust = 0. - ALLOCATE( emis_seas( ims:ime, 1, jms:jme,num_emis_seas) ) -emis_seas = 0. - ALLOCATE( backg_oh( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( backg_h2o2( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( backg_no3( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( ebu_in_no( ims:ime, jms:jme ) ) - ebu_in_no=0. - ALLOCATE( ebu_in_co( ims:ime, jms:jme ) ) - ebu_in_co=0. - ALLOCATE( ebu_in_co2( ims:ime, jms:jme ) ) - ebu_in_co2=0. - ALLOCATE( ebu_in_eth( ims:ime, jms:jme ) ) - ebu_in_eth=0. - ALLOCATE( ebu_in_hc3( ims:ime, jms:jme ) ) - ebu_in_hc3=0. - ALLOCATE( ebu_in_hc5( ims:ime, jms:jme ) ) - ebu_in_hc5=0. - ALLOCATE( ebu_in_hc8( ims:ime, jms:jme ) ) - ebu_in_hc8=0. - ALLOCATE( ebu_in_ete( ims:ime, jms:jme ) ) - ebu_in_ete=0. - ALLOCATE( ebu_in_olt( ims:ime, jms:jme ) ) - ebu_in_olt=0. - ALLOCATE( ebu_in_oli( ims:ime, jms:jme ) ) - ebu_in_oli=0. - ALLOCATE( ebu_in_pm25( ims:ime, jms:jme ) ) - ebu_in_pm25=0. - ALLOCATE( ebu_in_pm10( ims:ime, jms:jme ) ) - ebu_in_pm10=0. - ALLOCATE( ebu_in_oc( ims:ime, jms:jme ) ) - ebu_in_oc=0. - ALLOCATE( ebu_in_bc( ims:ime, jms:jme ) ) - ebu_in_bc=0. - ALLOCATE( ebu_in_so2( ims:ime, jms:jme ) ) - ebu_in_so2=0. - ALLOCATE( ebu_in_sulf( ims:ime, jms:jme ) ) - ebu_in_sulf=0. - ALLOCATE( ebu_in_dien( ims:ime, jms:jme ) ) - ebu_in_dien=0. - ALLOCATE( ebu_in_iso( ims:ime, jms:jme ) ) - ebu_in_iso=0. - ALLOCATE( ebu_in_api( ims:ime, jms:jme ) ) - ebu_in_api=0. - ALLOCATE( ebu_in_lim( ims:ime, jms:jme ) ) - ebu_in_lim=0. - ALLOCATE( ebu_in_tol( ims:ime, jms:jme ) ) - ebu_in_tol=0. - ALLOCATE( ebu_in_xyl( ims:ime, jms:jme ) ) - ebu_in_xyl=0. - ALLOCATE( ebu_in_csl( ims:ime, jms:jme ) ) - ebu_in_csl=0. - ALLOCATE( ebu_in_hcho( ims:ime, jms:jme ) ) - ebu_in_hcho=0. - ALLOCATE( ebu_in_ald( ims:ime, jms:jme ) ) - ebu_in_ald=0. - ALLOCATE( ebu_in_ket( ims:ime, jms:jme ) ) - ebu_in_ket=0. - ALLOCATE( ebu_in_macr( ims:ime, jms:jme ) ) - ebu_in_macr=0. - ALLOCATE( ebu_in_ora1( ims:ime, jms:jme ) ) - ebu_in_ora1=0. - ALLOCATE( ebu_in_ora2( ims:ime, jms:jme ) ) - ebu_in_ora2=0. - ALLOCATE( ebu_no( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( ebu_co( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( ebu_co2( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( ebu_eth( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( ebu_hc3( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( ebu_hc5( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( ebu_hc8( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( ebu_ete( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( ebu_olt( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( ebu_oli( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( ebu_pm25( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( ebu_pm10( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( ebu_oc( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( ebu_bc( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( ebu_so2( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( ebu_sulf( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( ebu_dien( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( ebu_iso( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( ebu_api( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( ebu_lim( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( ebu_tol( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( ebu_xyl( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( ebu_csl( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( ebu_hcho( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( ebu_ald( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( ebu_ket( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( ebu_macr( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( ebu_ora1( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( ebu_ora2( ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( mean_fct_agtf( ims:ime, jms:jme ) ) - ALLOCATE( mean_fct_agef( ims:ime, jms:jme ) ) - ALLOCATE( mean_fct_agsv( ims:ime, jms:jme ) ) - ALLOCATE( mean_fct_aggr( ims:ime, jms:jme ) ) - ALLOCATE( firesize_agtf( ims:ime, jms:jme ) ) - ALLOCATE( firesize_agef( ims:ime, jms:jme ) ) - ALLOCATE( firesize_agsv( ims:ime, jms:jme ) ) - ALLOCATE( firesize_aggr( ims:ime, jms:jme ) ) - ALLOCATE( ash_fall( ims:ime, jms:jme ) ) - ash_fall=0. - ALLOCATE( dust_fall( ims:ime, jms:jme ) ) - ALLOCATE( pm2_5_dry( ims:ime , kms:kme , jms:jme ) ) - ALLOCATE( pm2_5_dry_ec( ims:ime , kms:kme , jms:jme ) ) - ALLOCATE( pm10( ims:ime , kms:kme , jms:jme ) ) - ALLOCATE( tcosz( ims:ime , jms:jme ) ) - ALLOCATE( ttday( ims:ime , jms:jme ) ) - - ALLOCATE( sebio_iso( ims:ime , jms:jme ) ) - ALLOCATE( sebio_oli( ims:ime , jms:jme ) ) - ALLOCATE( sebio_api( ims:ime , jms:jme ) ) - ALLOCATE( sebio_lim( ims:ime , jms:jme ) ) - ALLOCATE( sebio_xyl( ims:ime , jms:jme ) ) - ALLOCATE( sebio_hc3( ims:ime , jms:jme ) ) - ALLOCATE( sebio_ete( ims:ime , jms:jme ) ) - ALLOCATE( sebio_olt( ims:ime , jms:jme ) ) - ALLOCATE( sebio_ket( ims:ime , jms:jme ) ) - ALLOCATE( sebio_ald( ims:ime , jms:jme ) ) - ALLOCATE( sebio_hcho( ims:ime , jms:jme ) ) - ALLOCATE( sebio_eth( ims:ime , jms:jme ) ) - ALLOCATE( sebio_ora2( ims:ime , jms:jme ) ) - ALLOCATE( sebio_co( ims:ime , jms:jme ) ) - ALLOCATE( sebio_nr( ims:ime , jms:jme ) ) - ALLOCATE( noag_grow( ims:ime , jms:jme ) ) - ALLOCATE( noag_nongrow( ims:ime , jms:jme ) ) - ALLOCATE( nononag( ims:ime , jms:jme ) ) - ALLOCATE( slai( ims:ime , jms:jme ) ) - ALLOCATE( ebio_iso( ims:ime , jms:jme ) ) - ALLOCATE( ebio_oli( ims:ime , jms:jme ) ) - ALLOCATE( ebio_api( ims:ime , jms:jme ) ) - ALLOCATE( ebio_lim( ims:ime , jms:jme ) ) - ALLOCATE( ebio_xyl( ims:ime , jms:jme ) ) - ALLOCATE( ebio_hc3( ims:ime , jms:jme ) ) - ALLOCATE( ebio_ete( ims:ime , jms:jme ) ) - ALLOCATE( ebio_olt( ims:ime , jms:jme ) ) - ALLOCATE( ebio_ket( ims:ime , jms:jme ) ) - ALLOCATE( ebio_ald( ims:ime , jms:jme ) ) - ALLOCATE( ebio_hcho( ims:ime , jms:jme ) ) - ALLOCATE( ebio_eth( ims:ime , jms:jme ) ) - ALLOCATE( ebio_ora2( ims:ime , jms:jme ) ) - ALLOCATE( ebio_co( ims:ime , jms:jme ) ) - ALLOCATE( ebio_nr( ims:ime , jms:jme ) ) - ALLOCATE( ebio_no( ims:ime , jms:jme ) ) - if(bio_emiss_opt == 3)then - ALLOCATE( EFmegan(ims:ime, jms:jme , nmegan) ) - - ALLOCATE( msebio_isop(ims:ime, jms:jme ) ) - ALLOCATE( pftp_bt(ims:ime, jms:jme ) ) - ALLOCATE( pftp_nt(ims:ime, jms:jme ) ) - ALLOCATE( pftp_sb(ims:ime, jms:jme ) ) - ALLOCATE( pftp_hb(ims:ime, jms:jme ) ) - - ALLOCATE( mlai(ims:ime, jms:jme, 12 ) ) - ALLOCATE( mtsa(ims:ime, jms:jme, 12 ) ) - ALLOCATE( mswdown(ims:ime, jms:jme, 12 ) ) - - ALLOCATE( mebio_isop(ims:ime, jms:jme ) ) - ALLOCATE( mebio_apin(ims:ime, jms:jme ) ) - ALLOCATE( mebio_bpin(ims:ime, jms:jme ) ) - ALLOCATE( mebio_bcar(ims:ime, jms:jme ) ) - ALLOCATE( mebio_acet(ims:ime, jms:jme ) ) - ALLOCATE( mebio_mbo(ims:ime, jms:jme ) ) - ALLOCATE( mebio_no(ims:ime, jms:jme ) ) - endif - - if(chem_opt == 2)then - ALLOCATE( h2oai(ims:ime, kms:kme, jms:jme ) ) - ALLOCATE( h2oaj(ims:ime, kms:kme, jms:jme ) ) - endif - if(aer_ra_feedback == 1)then - ALLOCATE( extt(ims:ime, kms:kme, jms:jme,nbands) ) - ALLOCATE( ssca(ims:ime, kms:kme, jms:jme,nbands) ) - ALLOCATE( asympar(ims:ime, kms:kme, jms:jme,nbands) ) - ALLOCATE( aod(ims:ime, jms:jme ) ) - ALLOCATE( ext_coeff(ims:ime, kms:kme, jms:jme,1:num_ext_coef ) ) - ALLOCATE( bscat_coeff(ims:ime, kms:kme, jms:jme,1:num_bscat_coef ) ) - ALLOCATE( asym_par(ims:ime, kms:kme, jms:jme,1:num_asym_par ) ) - ALLOCATE( tauaerlw(ims:ime, kms:kme, jms:jme,1:16 ) ) - ALLOCATE( tauaersw(ims:ime, kms:kme, jms:jme,1:4 ) ) - ALLOCATE( gaersw(ims:ime, kms:kme, jms:jme, 1:4 ) ) - ALLOCATE( waersw(ims:ime, kms:kme, jms:jme, 1:4 ) ) - ALLOCATE( bscoefsw(ims:ime, kms:kme, jms:jme, 1:4 ) ) - ALLOCATE( l2aer(ims:ime, kms:kme, jms:jme, 1:4 ) ) - ALLOCATE( l3aer(ims:ime, kms:kme, jms:jme, 1:4 ) ) - ALLOCATE( l4aer(ims:ime, kms:kme, jms:jme, 1:4 ) ) - ALLOCATE( l5aer(ims:ime, kms:kme, jms:jme, 1:4 ) ) - ALLOCATE( l6aer(ims:ime, kms:kme, jms:jme, 1:4 ) ) - ALLOCATE( l7aer(ims:ime, kms:kme, jms:jme, 1:4 ) ) - endif - -return -end subroutine chem_alloc2 - -end module module_chem_alloc diff --git a/src/fim/FIMsrc/fim/horizontal/chem_finalize.F90 b/src/fim/FIMsrc/fim/horizontal/chem_finalize.F90 deleted file mode 100644 index d515338..0000000 --- a/src/fim/FIMsrc/fim/horizontal/chem_finalize.F90 +++ /dev/null @@ -1,22 +0,0 @@ -module module_fim_chem_finalize -contains -!********************************************************************* -subroutine chem_finalize -! Finish the atmospheric chemistry component. -! T. Henderson April, 2008 -!********************************************************************* - - use module_outtime_chem,only: OutTime - use module_control ,only: PrintMAXMINtimes - use module_initial_chem_namelists, only: chem_opt - - implicit none - - ! print elapsed times for atmospheric chemistry - if (chem_opt >= 300 ) then - call OutTime(PrintMAXMINtimes) - endif - - return -end subroutine chem_finalize -end module module_fim_chem_finalize diff --git a/src/fim/FIMsrc/fim/horizontal/chem_init.F90 b/src/fim/FIMsrc/fim/horizontal/chem_init.F90 deleted file mode 100644 index 3f419cb..0000000 --- a/src/fim/FIMsrc/fim/horizontal/chem_init.F90 +++ /dev/null @@ -1,1052 +0,0 @@ -module module_fim_chem_init - -contains - - subroutine chem_init -!********************************************************************* -! Loads the initial variables and constants for the chemsitry -! component. -! Tom Henderson November, 2008 -!********************************************************************* - -!TODO: move CallChemistry to a chem module - use module_control ,only: nvl,nip,numphr,glvl,curve,ntra,ntrb, readrestart - use module_wrf_control,only: ids,ide,jds,jde,kds,kde, & - ims,ime,jms,jme,kms,kme, & - its,ite,jts,jte,kts,kte, & - num_moist,CallChemistry, & - CallBiom,num_chem - use module_chem_constants,only: p_gocart - use module_chem_variables,only: ero1,ero2,ero3,rcav,dm0,pm25,p10,emiss_ab, & - emiss_oc,emiss_bc,emiss_sulf,oh_backgd,sandfrac,clayfrac, & - emiss_ash_mass,emiss_ash_height,emiss_ash_dt,& - emiss_tr_height,emiss_tr_mass,emiss_tr_dt, & - aod2d,h2o2_backgd,no3_backgd,emiss_abu,plumestuff - use module_variables,only: tr3d,trdp,dp3d - use module_chem_alloc,only: chem_alloc,chem_alloc2 - use module_wrf_share ,only: wrf_set_array_bounds - - !TODO: clean up duplication in these modules and add "only" - ! for chemistry and WRF physics namelists: - use module_chem_namelist_defaults - ! contains config_flags - use module_initial_chem_namelists - ! TBH: Ignore these so PPP doesn't have to translate them -!SMS$ignore begin - use module_species_decs - use module_set_wrfphys - use units, only: getunit, returnunit -!SMS$ignore end - - implicit none - - ! Local variables - integer :: ipn ! Index for icos point number - integer :: ivl ! Index for vertical level - integer :: nv,k,idx,nv_g,ierr,ibegin - logical :: debug ! control debug prints - character(64) :: filename - character(20) :: dum - character(12) :: dum2 - character(80) :: header(10) - real :: maxv -!SMS$DISTRIBUTE (dh,2) BEGIN - real, allocatable :: dummy(:,:) -!SMS$DISTRIBUTE END - real*8 :: t0,t1=0.0d0 - integer :: unitno -!SMS$insert integer :: mype -!SMS$insert call nnt_me(mype) - - call StartTimer(t0) - -!SMS$PARALLEL(dh, ipn) BEGIN - -!TODO: Remove implicit dependence on ReadRestart being initilialized in -!TODO: dyn_init(). - - debug=.false. - ibegin=ntra - - if (readrestart .and. chem_opt /= 0) then - write(6,*) 'chem_init: restarting with chemistry enabled not yet supported. Stopping' - call flush(6) - stop - end if - - if (debug) print *,'DEBUG chem_init: begin, ntra,num_moist,num_chem = ',ntra,num_moist,num_chem - - filename='./FIMnamelist' - if (debug) print *,'set chem namelists' - ash_height =-999. - ash_mass = -999. - if (debug) then - write(0,*)'set chem namelists' - call flush(0) - endif - call set_chem_namelist_defaults - if (debug) print *,'start reading chem namelists' - unitno = getunit () - if (unitno < 0) then - print*,'chem_init: getunit failed: stopping' - stop - end if - - open (unitno, file=filename, form='formatted', action='read', err=70) - if (debug) print *,'read chemwrf' - read (unitno,chemwrf,iostat=ierr) - if (ierr.eq.0.and.debug) then - print *,'write chemwrf' - write(6,chemwrf) - call flush(6) - endif - close(unitno) - - if (chem_opt.eq.0) return - - call wrf_set_array_bounds(nvl,nip, & - ids,ide,jds,jde,kds,kde, & - ims,ime,jms,jme,kms,kme, & - its,ite,jts,jte,kts,kte) - - config_flags%chem_opt = chem_opt - config_flags%chem_in_opt = chem_in_opt - config_flags%dust_opt = dust_opt - config_flags%dmsemis_opt = dmsemis_opt - config_flags%seas_opt = seas_opt - config_flags%biomass_burn_opt = biomass_burn_opt - - ! Always allocate arrays that are passed through argument lists... - print *,'DEBUG: chem_init(): calling chem_alloc(',chem_opt,')' - call chem_alloc(chem_opt,aer_ra_feedback) - print *,'DEBUG: chem_init(): back from chem_alloc()' - - if(chem_opt > 0) then - aod2d(:) = 0. - call set_species - - ! read chem data - if(chem_opt >= 300 .and. chem_opt < 500) then - write(6,*)'reading gocart background fields' - call flush(6) - filename = "oh.dat" -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file=filename, form="unformatted", action='read', err=70) - read (unitno, err=90) p_gocart - read (unitno, err=90) oh_backgd - write(6,*)'minimum oh-value ',minval(oh_backgd(:,15)),maxval(oh_backgd(:,15)) - call flush(6) - close (unitno) -!SMS$SERIAL END - filename = "h2o2.dat" -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file=filename, form="unformatted", action='read', err=70) - read (unitno, err=90) p_gocart - read (unitno, err=90) h2o2_backgd - write(6,*)'minimum h2o2-value ',minval(h2o2_backgd(:,15)),maxval(h2o2_backgd(:,15)) - call flush(6) - close(unitno) -!SMS$SERIAL END - filename = "no3.dat" -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file=filename, form="unformatted", action='read', err=70) - read (unitno, err=90) p_gocart - read (unitno, err=90) no3_backgd - write(6,*)'p_gocart',p_gocart - write(6,*)'minimum no3-value ',minval(no3_backgd(:,15)),maxval(no3_backgd(:,15)) - call flush(6) - close(unitno) -!SMS$SERIAL END - write(6,*)'reading chemistry emissions files for gocart' - call flush(6) - filename = "e_bc.dat" -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file=filename, form="unformatted", action='read', err=70) - read (unitno, err=90) emiss_bc - close (unitno) - maxv=maxval(emiss_bc) -!SMS$SERIAL END - write(6,*)'maxv on input for bc_ant = ',maxv - call flush(6) - filename = "e_oc.dat" -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file=filename, form="unformatted", action='read', err=70) - read (unitno) emiss_oc - close (unitno) - maxv=maxval(emiss_oc) -!SMS$SERIAL END - write(6,*)'maxv on input for oc_ant = ',maxv - call flush(6) - filename = "e_sulf.dat" -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file=filename, form="unformatted", action='read', err=70) - read (unitno, err=90) emiss_sulf - close(unitno) - maxv=maxval(emiss_sulf) -!SMS$SERIAL END - write(6,*)'maxv on input for sulf_ant = ',maxv - call flush(6) - - filename = "dm0.dat" -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file=filename, form='unformatted', action='read', err=70) - read (unitno, err=90) dm0 - close (unitno) -!SMS$SERIAL END - filename = "erod1.dat" -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file=filename, form='unformatted', action='read', err=70) - read (unitno, err=90) ero1 - close (unitno) -!SMS$SERIAL END - filename = "erod2.dat" -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file=filename, form='unformatted', action='read', err=70) - read (unitno, err=90) ero2 - close (unitno) -!SMS$SERIAL END - filename = "erod3.dat" -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file=filename, form='unformatted', action='read', err=70) - read (unitno, err=90) ero3 - close (unitno) -!SMS$SERIAL END -! -! AFWA dust option -! - if(dust_opt == 3) then - filename = "sand.dat" -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file=filename, form='unformatted', action='read', err=70) - read (unitno, err=90) sandfrac - close (unitno) -!SMS$SERIAL END - filename = "clay.dat" -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file=filename, form='unformatted', action='read', err=70) - read (unitno, err=90) clayfrac - close (unitno) -!SMS$SERIAL END - endif - - do ipn=1,nip - emiss_ab(ipn,p_e_bc)=emiss_bc(ipn) - emiss_ab(ipn,p_e_oc)=emiss_oc(ipn) - emiss_ab(ipn,p_e_sulf)=emiss_sulf(ipn) - enddo - filename = "e_so2.dat" -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file=filename, form='unformatted', action='read', err=70) - read (unitno, err=90) emiss_sulf - close (unitno) - maxv=maxval(emiss_sulf) -!SMS$SERIAL END - write(6,*)'maxv on input for so2_ant = ',maxv - call flush(6) - - do ipn=1,nip - emiss_ab(ipn,p_e_so2)=emiss_sulf(ipn) - enddo - endif ! chem_opt >= 300 and chem_opt < 500 -! -!!!!!!! biomassburning next, lots of arrays! -! - if(biomass_burn_opt > 0 ) then - filename = "ebu_oc.dat" -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file=filename, form='unformatted', action='read', err=70) - read (unitno, err=90) emiss_bc - close (unitno) - maxv=maxval(emiss_bc(:)) - write(6,*)'maxv on input2 for oc_biom = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - emiss_abu(ipn,p_e_oc)=emiss_bc(ipn) - enddo - filename = "ebu_bc.dat" -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file=filename, form='unformatted', action='read', err=70) - read (unitno, err=90) emiss_bc - close (unitno) - maxv=maxval(emiss_bc(:)) - write(6,*)'maxv on input2 for bc_bion = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - emiss_abu(ipn,p_e_bc)=emiss_bc(ipn) - enddo - filename = "ebu_so2.dat" -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file=filename, form='unformatted', action='read', err=70) - read (unitno, err=90) emiss_bc - close (unitno) - maxv=maxval(emiss_bc(:)) - write(6,*)'maxv on input2 for bso2 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - emiss_abu(ipn,p_e_so2)=emiss_bc(ipn) - enddo - filename = "ebu_sulf.dat" -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file=filename, form='unformatted', action='read', err=70) - read (unitno, err=90) emiss_bc - close (unitno) - maxv=maxval(emiss_bc(:)) - write(6,*)'maxv on input2 for bsulf = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - emiss_abu(ipn,p_e_sulf)=emiss_bc(ipn) - enddo - filename = "ebu_pm25.dat" -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file=filename, form='unformatted', action='read', err=70) - read (unitno, err=90) emiss_bc - close (unitno) - maxv=maxval(emiss_bc(:)) - write(6,*)'maxv on input2 for bpm25 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - emiss_abu(ipn,p_e_pm_25)=emiss_bc(ipn) - enddo - filename = "ebu_pm10.dat" -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file=filename, form='unformatted', action='read', err=70) - read (unitno, err=90) emiss_bc - close (unitno) - maxv=maxval(emiss_bc(:)) - write(6,*)'maxv on input2 for bpm10 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - emiss_abu(ipn,p_e_pm_10)=emiss_bc(ipn) - enddo - filename = "plumestuff.dat" -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file=filename, form='unformatted', action='read', err=70) - do k=1,8 - read (unitno, err=90) emiss_bc - do ipn=1,nip - plumestuff(ipn,k)=emiss_bc(ipn) - enddo - maxv=maxval(plumestuff(:,k)) - write(6,*)'maxv on input2 for plumestuff(k) = ',k,maxv - call flush(6) - enddo - close (unitno) -!SMS$SERIAL END - endif ! biomass_burn -! -! read volcanic stuff if necessary -! - if((chem_opt == 316 .or. chem_opt == 317 .or. chem_opt == 502 .or. chem_opt == 300)) then - if(ash_mass >= -900. )then - filename = "volcanic.dat" -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file=filename, form='unformatted', action='read', err=70) - read (unitno, err=90) nv_g - print *,nv_g - read (unitno, err=90) dum - print *,dum - read (unitno, err=90) dum2 - print *,dum2 -! read (unitno, err=90) emiss_bc - read (unitno, err=90) emiss_ash_mass - read (unitno, err=90) emiss_ash_height - read (unitno, err=90) emiss_ash_dt - close (unitno) - maxv=maxval(emiss_ash_mass(:)) - write(6,*)'maxv on emissions input for ashmass = ',maxv - maxv=maxval(emiss_ash_height(:)) - write(6,*)'maxv on emissions input for ashheight = ',maxv - maxv=maxval(emiss_ash_dt(:)) - write(6,*)'maxv on emissions input for ashdt = ',maxv -!SMS$SERIAL END - endif - if(ash_mass.gt.-100)then - write(0,*)'using namelist value for ash_mass' - do ipn=1,nip - if(emiss_ash_mass(ipn).le.0.)cycle -! -! overwrite ash_mass if nameist value exists -! - emiss_ash_mass(ipn)=ash_mass - enddo - endif -! maxv=maxval(emiss_ash_mass(:)) -! write(6,*)'maxv on emissions input for ashmass = ',maxv -! call flush(6) -! read (unitno, err=90) emiss_bc -! emiss_ash_height(ipn)=emiss_bc(ipn) -! -! overwrite ash_height if nameist value exists -! - if(ash_height .gt. 0.) then - write(0,*)'using namelist value for ash_height' - do ipn=1,nip - if(emiss_ash_mass(ipn).le.0.)cycle - emiss_ash_height(ipn)=ash_height - if(emiss_ash_height(ipn) .lt. 1.) emiss_ash_dt(ipn)=0. - enddo - endif - if(ash_height .lt. -990.) then - write(0,*)'resetting all ash variables to zero' - do ipn=1,nip - emiss_ash_height(ipn)=0. - emiss_ash_mass(ipn)=0. - emiss_ash_dt(ipn)=-10. - enddo - endif -! if(ash_height .lt. -1.) emiss_ash_height(ipn)=0. -! call flush(6) -! read (unitno, err=90) emiss_bc -! do ipn=1,nip -! emiss_ash_dt(ipn)=emiss_bc(ipn) -! enddo -! maxv=maxval(emiss_ash_dt(:)) -! write(6,*)'maxv on emissions input for duration = ',maxv -! maxv=maxval(emiss_ash_mass(:)) -! write(6,*)'maxv on emissions input for ashmass = ',maxv -! maxv=maxval(emiss_ash_height(:)) -! write(6,*)'maxv on emissions input for ashheight = ',maxv -! maxv=maxval(emiss_ash_dt(:)) -! write(6,*)'maxv on emissions input for ashdt = ',maxv -! call flush(6) - endif ! (chem_opt.eq.316.or.chem_opt.eq.317) -! do k=1,8 -! do ipn=1,nip -! plumestuff(ipn,p_e_oc)=plumes(ipn,8) -! enddo -! enddo - -! Initialize chem arrays - do nv=ntra+1,ntra+ntrb - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,nv) = 1.e-16 - if(chem_opt == 501 .or. chem_opt == 502) tr3d(ivl,ipn,nv) = 0 - if(chem_opt == 500 ) tr3d(ivl,ipn,nv) = 390. - enddo - enddo - enddo -! -! cloud water done twice ???? -! -! do ipn=1,nip -! do ivl=1,nvl -! tr3d(ivl,ipn,5) = tr3d(ivl,ipn,3) -! trdp(ivl,ipn,5) = tr3d(ivl,ipn,3)*dp3d(ivl,ipn) -! enddo -! enddo - do ipn=1,nip - do ivl=1,nvl - pm25(ivl,ipn) = 0. - p10(ivl,ipn) = 0. - enddo - enddo - do ipn=1,nip - rcav(ipn) = 0. - enddo - - call chem_alloc2(chem_opt,aer_ra_feedback,bio_emiss_opt,biomass_burn_opt,kemit) - - CallChemistry = max(1,numphr*(int(Chemdt+.01)*60)/3600) - Callbiom = max(1,numphr*(int(PLUMERISEFIRE_FRQ+.01)*60)/3600) - - if(chem_in_opt == 1 ) then - call flush(6) - allocate( dummy(nvl,nip)) ! if chem_in_opt=1, read old chem - call flush(6) -! -! read previous volcanic ash forecast -! - if(chem_opt == 502 ) then -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='vash1.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for vash1 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_vash_1) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_vash_1) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='vash2.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for vash2 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_vash_2) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_vash_2) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='vash3.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for vash3 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_vash_3) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_vash_3) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='vash4.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for vash4 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_vash_4) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_vash_4) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo - endif ! chem_opt=502 - ! - ! this shpould just be a loop that automatically reads the stuff - ! next is for volcanic ash (4 or 10 bins) + gocart - if((chem_opt == 316 .or. chem_opt == 317) .and. ash_mass .ne. 0.) then -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='vash1.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for vash1 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_vash_1) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_vash_1) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='vash2.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for vash2 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_vash_2) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_vash_2) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='vash3.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for vash3 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_vash_3) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_vash_3) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='vash4.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for vash4 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_vash_4) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_vash_4) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo - endif - - if(chem_opt == 316 ) then -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='vash5.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for vash5 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_vash_5) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_vash_5) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='vash6.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for vash6 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_vash_6) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_vash_6) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='vash7.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for vash7 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_vash_7) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_vash_7) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='vash8.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for vash8 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_vash_8) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_vash_8) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='vash9.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for vash9 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_vash_9) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_vash_9) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='vash10.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for vash10 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_vash_10) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_vash_10) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo - endif ! volcanoes -! -! GOCART options -! - if(chem_opt >= 300 .and. chem_opt < 500)then -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='so2.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for so2 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_so2) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_so2) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='sulf.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for sulf = ',maxv - write(6,*)'p_so2,p_sulf = ',p_so2,p_sulf - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_sulf) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_sulf) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='dms.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for dms = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_dms) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_dms) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='msa.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for msa = ',maxv -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_msa) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_msa) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='p10.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for p10 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_p10) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_p10) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='p25.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for p25 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_p25) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_p25) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='bc1.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for bc1 = ',p_bc1,p_bc2,p_p25,maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_bc1) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_bc1) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='bc2.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for bc2 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_bc2) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_bc2) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='oc1.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for oc1 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_oc1) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_oc1) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='oc2.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for oc2 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_oc2) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_oc2) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='dust1.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for dust1 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_dust_1) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_dust_1) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo -! -! extra arrays for pure GOCART -! - if(chem_opt == 300 ) then -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='dust2.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for dust2 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_dust_2) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_dust_2) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='dust3.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for dust3 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_dust_3) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_dust_3) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='dust4.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for dust4 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_dust_4) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_dust_4) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='dust5.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for dust5 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_dust_5) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_dust_5) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo - endif ! chem_opt = 300, dust2 - - if( seas_opt == 1 )then -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='seas1.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for seas1 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_seas_1) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_seas_1) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='seas2.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for seas2 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_seas_2) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_seas_2) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='seas3.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for seas3 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_seas_3) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_seas_3) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='seas4.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for seas4 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_seas_4) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_seas_4) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo - endif - endif ! chem_opt >= 300 .and. chem_opt < 500 -! -! tracer dispersion -! - if( chem_opt == 500 ) then -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='tr1.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for tr1 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_tr1) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_tr1) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo -!SMS$SERIAL ( : default=ignore) BEGIN - open (unit=unitno, file='tr2.in', form="unformatted", action='read', err=70) - read (unitno, err=90) header - read (unitno, err=90) dummy - close (unitno) - maxv=maxval(dummy(:,:)) - write(6,*)'maxv on input2 for tr2 = ',maxv - call flush(6) -!SMS$SERIAL END - do ipn=1,nip - do ivl=1,nvl - tr3d(ivl,ipn,ibegin+p_tr2) = dummy(ivl,ipn) - trdp(ivl,ipn,ibegin+p_tr2) = dummy(ivl,ipn)*dp3d(ivl,ipn) - enddo - enddo - endif ! chem_opt=500 - deallocate( dummy) ! if chem_in_opt=1 - endif ! if (chem_in_opt == 1) - endif ! if (chem_opt > 0) -! -! just like for volcanoes, later be used in chem_prep_fim -! - if(chem_opt == 501 ) then - write(6,*)'chem_opt = 500, itry to print emissions ',tr_mass,tr_height,nip - do ipn=1,nip - if(ipn .eq. 143724 ) then - write(6,*)'emissions for point ',ipn - emiss_tr_mass(ipn) = tr_mass - emiss_tr_height(ipn) = tr_height - emiss_tr_dt(ipn) = 120000000 - endif - enddo - endif ! if (chem_opt == 501) - - call returnunit (unitno) - -!SMS$PARALLEL END - - call IncrementTimer(t0,t1) - print"(' CHEMISTRY INIT time:',F10.0)",t1 - - return - -70 write(6,*)'chem_init: error opening unit=', unitno, '. Stopping' - stop -90 write(6,*)'chem_init: error reading from unit=', unitno, '. Stopping' - stop - end subroutine chem_init -end module module_fim_chem_init - diff --git a/src/fim/FIMsrc/fim/horizontal/chem_output.F90 b/src/fim/FIMsrc/fim/horizontal/chem_output.F90 deleted file mode 100644 index 54266cb..0000000 --- a/src/fim/FIMsrc/fim/horizontal/chem_output.F90 +++ /dev/null @@ -1,317 +0,0 @@ -module module_chem_output - -contains - - subroutine chem_output(its,nts,aod2d,exch,p10,pm25,pr3d,tk3d,tr,trfall,& - phys2dwrf,tr1_tavg) - - use module_constants,only:rd - use module_control,only:ArchvStep,ArchvTimeUnit,dt,filename_len,nip,ntra,& - ntrb,nvl,nvlp1 -!sms$ignore begin - use icosio,only:icosio_out - use module_initial_chem_namelists -!sms$ignore end - use module_wrf_control,only:num_chem,num_moist,nvl_gocart,nvl_gocart - use module_header,only:header - - integer,intent(in)::its,nts -!sms$distribute (dh,nip) begin - real,intent(inout):: tr1_tavg(nvl,nip) - real,intent(in)::aod2d(nip),exch(nvl,nip),& - p10(nvl,nip),pm25(nvl,nip),pr3d(nvlp1,nip),& - tk3d(nvl,nip),tr(nvl,nip,ntra+ntrb),trfall(nip,num_chem) - real::d1st(nvl,nip),d2st(nvl,nip),d3st(nvl,nip),d4st(nvl,nip),d5st(nvl,nip),& - dms1(nvl,nip),intaer(nip),intash(nip),intbc(nip),intdust(nip),intoc(nip),& - intsulf(nip),qcct(nvl,nip),qict(nvl,nip),qrct(nvl,nip),qsct(nvl,nip),& - rho_phys(nvl,nip),sea1(nvl,nip),sea2(nvl,nip),sea3(nvl,nip),sea4(nvl,nip),& - trco(nvl,nip) -!sms$distribute end -!sms$distribute(dh,1) begin - real,intent(in)::phys2dwrf(:,:) ! (nip,:) -!sms$distribute end - integer::ichem_start,imoist_start,j,k - real::dpsum - character(len=filename_len)::filename - integer::its2time - integer::time - - if (mod(its,ArchvStep)==0.or.(its==nts.and.ArchvTimeUnit.eq.'ts')) then - - time=its2time(its) - - ichem_start=ntra -! imoist_start=4-1 - -!SMS$IGNORE BEGIN -!TBH: Added this IGNORE to work around a PPP core dump between here and -!TBH: "SMS$IGNORE END". Mark Govett is investigating... - - if ((.not.mp_physics==0).or.(.not.cu_physics==0)) then - trco(:,:) = tr(:,:,5) - trco(1,:) = phys2dwrf(:,1) - trco(2,:) = phys2dwrf(:,2) - trco(3,:) = phys2dwrf(:,3) - trco(4,:) = phys2dwrf(:,4) - trco(5,:) = phys2dwrf(:,5) - trco(6,:) = phys2dwrf(:,6) - endif - if (chem_opt == 300) then - d3st(:,:) = tr(:,:,ichem_start+p_dust_3) - d4st(:,:) = tr(:,:,ichem_start+p_dust_4) - d5st(:,:) = tr(:,:,ichem_start+p_dust_5) - sea3(:,:) = tr(:,:,ichem_start+p_seas_3) - sea4(:,:) = tr(:,:,ichem_start+p_seas_4) - endif - if (chem_opt == 500) then - d1st(:,:) = tr(:,:,ichem_start+p_tr1) - d2st(:,:) = tr(:,:,ichem_start+p_tr2) - endif - if (chem_opt >= 300 .and. chem_opt < 500) then - dms1(:,:) = tr(:,:,ichem_start+p_dms) - d1st(:,:) = tr(:,:,ichem_start+p_dust_1) - d2st(:,:) = tr(:,:,ichem_start+p_dust_2) - sea1(:,:) = tr(:,:,ichem_start+p_seas_1) - sea2(:,:) = tr(:,:,ichem_start+p_seas_2) - endif -! if (mp_physics == 2) then -! qcct(:,:) = tr(:,:,imoist_start+p_qc) -! qrct(:,:) = tr(:,:,imoist_start+p_qr) -! qict(:,:) = tr(:,:,imoist_start+p_qi) -! qsct(:,:) = tr(:,:,imoist_start+p_qs) -! endif -!SMS$IGNORE END - if (chem_opt >= 300 .and. chem_opt < 500) then -!SMS$PARALLEL(dh, j) BEGIN - do j=1,nip - dpsum=0. - intash(j)=0. - intaer(j)=0. - intbc(j)=0. - intoc(j)=0. - intsulf(j)=0. - intdust(j)=0. - do k=1,nvl - dpsum=dpsum+(pr3d(k,j)-pr3d(k+1,j)) - rho_phys(k,j)=.5*(pr3d(k,j)+pr3d(k+1,j))& - /(RD*tk3d(k,j)) !*(1.+.608*qv3d(k,j)) - intaer(j)=intaer(j)+pm25(k,j)*(pr3d(k,j)-pr3d(k+1,j))*rho_phys(k,j) - intbc(j)=intbc(j)+(tr(k,j,ichem_start+p_bc1)& - +tr(k,j,ichem_start+p_bc2))*(pr3d(k,j)-pr3d(k+1,j))*rho_phys(k,j) - intoc(j)=intoc(j)+(tr(k,j,ichem_start+p_oc1)& - +tr(k,j,ichem_start+p_oc2))*(pr3d(k,j)-pr3d(k+1,j))*rho_phys(k,j) - intsulf(j)=intsulf(j)+tr(k,j,ichem_start+p_sulf)*(pr3d(k,j)& - -pr3d(k+1,j))*rho_phys(k,j) - if (chem_opt == 300)intdust(j)=intdust(j)+(d1st(k,j)& - +.286*d2st(k,j))*(pr3d(k,j)-pr3d(k+1,j))*rho_phys(k,j) - if (chem_opt==304.or.chem_opt==316.or.chem_opt==317) then - intdust(j)=intdust(j)+d1st(k,j)*(pr3d(k,j)-pr3d(k+1,j))& - *rho_phys(k,j) - endif - if (chem_opt == 316) then - intash(j)=intash(j)+(tr(k,j,ichem_start+p_vash_1) & - + tr(k,j,ichem_start+p_vash_2) & - + tr(k,j,ichem_start+p_vash_3) & - + tr(k,j,ichem_start+p_vash_4) & - + tr(k,j,ichem_start+p_vash_5) & - + tr(k,j,ichem_start+p_vash_6) & - + tr(k,j,ichem_start+p_vash_7) & - + tr(k,j,ichem_start+p_vash_8) & - + tr(k,j,ichem_start+p_vash_9) & - + tr(k,j,ichem_start+p_vash_10)) & - *(pr3d(k,j)-pr3d(k+1,j))*rho_phys(k,j) - endif - if (chem_opt == 317 ) then - intash(j)=intash(j)+(tr(k,j,ichem_start+p_vash_1) & - + tr(k,j,ichem_start+p_vash_2) & - + tr(k,j,ichem_start+p_vash_3) & - + tr(k,j,ichem_start+p_vash_4)) & - *(pr3d(k,j)-pr3d(k+1,j))*rho_phys(k,j) - endif - enddo - if (chem_opt == 316 .or. chem_opt == 317 ) intash(j)=intash(j)/dpsum - intaer(j)=intaer(j)/dpsum - intbc(j)=intbc(j)/dpsum - intoc(j)=intoc(j)/dpsum - intsulf(j)=intsulf(j)/dpsum - intdust(j)=intdust(j)/dpsum - enddo -!SMS$PARALLEL END - endif ! chem_opt >= 300 .and. chem_opt < 500 - if (chem_opt == 502) then -!SMS$PARALLEL(dh, j) BEGIN - do j=1,nip - dpsum=0. - intash(j)=0. - do k=1,nvl - dpsum=dpsum+(pr3d(k,j)-pr3d(k+1,j)) - rho_phys(k,j)=.5*(pr3d(k,j)+pr3d(k+1,j))& - /(RD*tk3d(k,j)) !*(1.+.608*qv3d(k,j)) - intash(j)=intash(j)+(tr(k,j,ichem_start+p_vash_1) & - + tr(k,j,ichem_start+p_vash_2) & - + tr(k,j,ichem_start+p_vash_3) & - + tr(k,j,ichem_start+p_vash_4)) & - *(pr3d(k,j)-pr3d(k+1,j))*rho_phys(k,j) - enddo - intash(j)=intash(j)/dpsum - enddo -!SMS$PARALLEL END - endif ! chem_opt = 502 - -! if (mp_physics.eq.2) then -! call icosio_out(its,time,'qcct',qcct,nvl, filename('qcct',its), header('qcct',nvl,its)) -! call icosio_out(its,time,'qrct',qrct,nvl, filename('qrct',its), header('qrct',nvl,its)) -! call icosio_out(its,time,'qict',qict,nvl, filename('qict',its), header('qict',nvl,its)) -! call icosio_out(its,time,'qsct',qsct,nvl, filename('qsct',its), header('qsct',nvl,its)) -! endif - if ((mp_physics.ne.0).or.(cu_physics.ne.0)) then - call icosio_out(its,time,'trco',trco,nvl, filename('trco',its), header('trco',nvl,its)) - endif - if (chem_opt == 500) then -!SMS$PARALLEL(dh, j) BEGIN - if(its.gt.1)tr1_tavg(:,:) = tr1_tavg(:,:)/float(ArchvStep-1) -!SMS$PARALLEL END - call icosio_out(its,time,'c13D',d1st,nvl,filename('c13D',its), header('c13D',nvl,its)) - call icosio_out(its,time,'c23D',tr1_tavg,nvl,filename('c23D',its), header('c23D',nvl,its)) - tr1_tavg(:,:) = 0. - endif - if (chem_opt.ge.300 .and. chem_opt.lt.500) then - call icosio_out(its,time,'ex3D',exch,nvl, filename('ex3D',its), header('ex3D',nvl,its)) - call icosio_out(its,time,'pm25',pm25,nvl, filename('pm25',its), header('pm25',nvl,its)) - call icosio_out(its,time,'pm10',p10,nvl, filename('pm10',its), header('pm10',nvl,its)) - call icosio_out(its,time,'dms1',dms1,nvl, filename('dms1',its), header('dms1',nvl,its)) - call icosio_out(its,time,'d1st',d1st,nvl, filename('d1st',its), header('d1st',nvl,its)) - call icosio_out(its,time,'d2st',d2st,nvl, filename('d2st',its), header('d2st',nvl,its)) - call icosio_out(its,time,'s1ea',sea1,nvl, filename('s1ea',its), header('s1ea',nvl,its)) - call icosio_out(its,time,'s2ea',sea2,nvl, filename('s2ea',its), header('s2ea',nvl,its)) - if (chem_opt.eq.300) then - call icosio_out(its,time,'s3ea',sea3,nvl, filename('s3ea',its), header('s3ea',nvl,its)) - call icosio_out(its,time,'s4ea',sea4,nvl, filename('s4ea',its), header('s4ea',nvl,its)) - call icosio_out(its,time,'d3st',d3st,nvl, filename('d3st',its), header('d3st',nvl,its)) - call icosio_out(its,time,'d4st',d4st,nvl, filename('d4st',its), header('d4st',nvl,its)) - call icosio_out(its,time,'d5st',d5st,nvl, filename('d5st',its), header('d5st',nvl,its)) - endif -!TBH: Added these IGNOREs to work around a PPP core dump. Mark Govett is -!TBH: investigating... -!SMS$IGNORE BEGIN - dms1(:,:) = tr(:,:,ichem_start+p_bc1) -!SMS$IGNORE END - call icosio_out(its,time,'pbc1',dms1,nvl, filename('pbc1',its), header('pbc1',nvl,its)) -!SMS$IGNORE BEGIN - dms1(:,:) = tr(:,:,ichem_start+p_bc2) -!SMS$IGNORE END - call icosio_out(its,time,'pbc2',dms1,nvl, filename('pbc2',its), header('pbc2',nvl,its)) -!SMS$IGNORE BEGIN - dms1(:,:) = tr(:,:,ichem_start+p_oc1) -!SMS$IGNORE END - call icosio_out(its,time,'obc1',dms1,nvl, filename('obc1',its), header('obc1',nvl,its)) -!SMS$IGNORE BEGIN - dms1(:,:) = tr(:,:,ichem_start+p_oc2) -!SMS$IGNORE END - call icosio_out(its,time,'obc2',dms1,nvl, filename('obc2',its), header('obc2',nvl,its)) -!SMS$IGNORE BEGIN - dms1(:,:) = tr(:,:,ichem_start+p_sulf) -!SMS$IGNORE END - call icosio_out(its,time,'sulf',dms1,nvl, filename('sulf',its), header('sulf',nvl,its)) -!SMS$IGNORE BEGIN - dms1(:,:) = tr(:,:,ichem_start+p_so2) -!SMS$IGNORE END - call icosio_out(its,time,'pso2',dms1,nvl, filename('pso2',its), header('pso2',nvl,its)) -!SMS$IGNORE BEGIN - dms1(:,:) = tr(:,:,ichem_start+p_msa) -!SMS$IGNORE END - call icosio_out(its,time,'pmsa',dms1,nvl, filename('pmsa',its), header('pmsa',nvl,its)) -!SMS$IGNORE BEGIN - dms1(:,:) = tr(:,:,ichem_start+p_p25) -!SMS$IGNORE END - call icosio_out(its,time,'pp25',dms1,nvl, filename('pp25',its), header('pp25',nvl,its)) -!SMS$IGNORE BEGIN - dms1(:,:) = tr(:,:,ichem_start+p_p10) -!SMS$IGNORE END - call icosio_out(its,time,'pp10',dms1,nvl, filename('pp10',its), header('pp10',nvl,its)) - if (chem_opt.eq.316.or.chem_opt.eq.317) then - print *,'p_vash_1,p_vash_4 = ',p_vash_1,p_vash_4 -!SMS$IGNORE BEGIN - dms1(:,:) = tr(:,:,ichem_start+p_vash_1) -!SMS$IGNORE END - call icosio_out(its,time,'ash1',dms1,nvl, filename('ash1',its), header('ash1',nvl,its)) -!SMS$IGNORE BEGIN - dms1(:,:) = tr(:,:,ichem_start+p_vash_2) -!SMS$IGNORE END - call icosio_out(its,time,'ash2',dms1,nvl, filename('ash2',its), header('ash2',nvl,its)) -!SMS$IGNORE BEGIN - dms1(:,:) = tr(:,:,ichem_start+p_vash_3) -!SMS$IGNORE END - call icosio_out(its,time,'ash3',dms1,nvl, filename('ash3',its), header('ash3',nvl,its)) -!SMS$IGNORE BEGIN - dms1(:,:) = tr(:,:,ichem_start+p_vash_4) -!SMS$IGNORE END - call icosio_out(its,time,'ash4',dms1,nvl, filename('ash4',its), header('ash4',nvl,its)) - if (chem_opt.eq.316) then -!SMS$IGNORE BEGIN - dms1(:,:) = tr(:,:,ichem_start+p_vash_5) -!SMS$IGNORE END - call icosio_out(its,time,'ash5',dms1,nvl, filename('ash5',its), header('ash5',nvl,its)) -!SMS$IGNORE BEGIN - dms1(:,:) = tr(:,:,ichem_start+p_vash_6) -!SMS$IGNORE END - call icosio_out(its,time,'ash6',dms1,nvl, filename('ash6',its), header('ash6',nvl,its)) -!SMS$IGNORE BEGIN - dms1(:,:) = tr(:,:,ichem_start+p_vash_7) -!SMS$IGNORE END - call icosio_out(its,time,'ash7',dms1,nvl, filename('ash7',its), header('ash7',nvl,its)) -!SMS$IGNORE BEGIN - dms1(:,:) = tr(:,:,ichem_start+p_vash_8) -!SMS$IGNORE END - call icosio_out(its,time,'ash8',dms1,nvl, filename('ash8',its), header('ash8',nvl,its)) -!SMS$IGNORE BEGIN - dms1(:,:) = tr(:,:,ichem_start+p_vash_9) -!SMS$IGNORE END - call icosio_out(its,time,'ash9',dms1,nvl, filename('ash9',its), header('ash9',nvl,its)) -!SMS$IGNORE BEGIN - dms1(:,:) = tr(:,:,ichem_start+p_vash_10) -!SMS$IGNORE END - call icosio_out(its,time,'ash0',dms1,nvl, filename('ash0',its), header('ash0',nvl,its)) - endif !chem_opt=316 - endif !chem_opt=316 or chem_opt=317 - endif !chem_opt.ge.300 .and. chem_opt.lt.500 - if (chem_opt == 500) then - call icosio_out(its,time,'fl2D',intaer,1,filename('2D__',its), header('fl2D',1,its)) - endif -! output for volcanic ash only - if (chem_opt.eq.502) then - call icosio_out(its,time,'iash',intash,1, filename('2D__',its), header('iash',1,its)) - print *,'p_vash_1,p_vash_4 = ',p_vash_1,p_vash_4 -!SMS$IGNORE BEGIN - dms1(:,:) = tr(:,:,ichem_start+p_vash_1) -!SMS$IGNORE END - call icosio_out(its,time,'ash1',dms1,nvl, filename('ash1',its), header('ash1',nvl,its)) -!SMS$IGNORE BEGIN - dms1(:,:) = tr(:,:,ichem_start+p_vash_2) -!SMS$IGNORE END - call icosio_out(its,time,'ash2',dms1,nvl, filename('ash2',its), header('ash2',nvl,its)) -!SMS$IGNORE BEGIN - dms1(:,:) = tr(:,:,ichem_start+p_vash_3) -!SMS$IGNORE END - call icosio_out(its,time,'ash3',dms1,nvl, filename('ash3',its), header('ash3',nvl,its)) -!SMS$IGNORE BEGIN - dms1(:,:) = tr(:,:,ichem_start+p_vash_4) -!SMS$IGNORE END - call icosio_out(its,time,'ash4',dms1,nvl, filename('ash4',its), header('ash4',nvl,its)) - endif - if (chem_opt.ge.300 .and. chem_opt.lt.500) then - call icosio_out(its,time,'ia2D',intaer,1, filename('2D__',its), header('ia2D',1,its)) - call icosio_out(its,time,'ib2D',intbc,1, filename('2D__',its), header('ib2D',1,its)) - call icosio_out(its,time,'io2D',intoc,1, filename('2D__',its), header('io2D',1,its)) - call icosio_out(its,time,'is2D',intsulf,1, filename('2D__',its), header('is2D',1,its)) - call icosio_out(its,time,'id2D',intdust,1, filename('2D__',its), header('id2D',1,its)) - call icosio_out(its,time,'ao2D',aod2d,1, filename('2D__',its), header('ao2D',1,its)) - if (chem_opt.eq.316.or.chem_opt.eq.317) then - call icosio_out(its,time,'iash',intash,1, filename('2D__',its), header('iash',1,its)) - endif - endif !chem_opt.ge.300 .and. chem_opt.lt.500 - endif - - end subroutine chem_output - -end module module_chem_output diff --git a/src/fim/FIMsrc/fim/horizontal/cnuity.F90 b/src/fim/FIMsrc/fim/horizontal/cnuity.F90 deleted file mode 100644 index a871252..0000000 --- a/src/fim/FIMsrc/fim/horizontal/cnuity.F90 +++ /dev/null @@ -1,507 +0,0 @@ -module module_cnuity -use stencilprint -use stenedgprint -use findmaxmin2 -contains -!********************************************************************* -! cnuity -! based on fct = flux corrected transport -! J. Lee Author September, 2005 -! A. E. MacDonald Documentor November, 2005 -! R. Bleck major rewrite April 2008 -! R. Bleck revised omega diagnostics August 2009 -! R. Bleck discarded-flux recovery November 2009 -! -! This routine is based on Zalesak, JOURNAL OF COMPUTATIONAL -! PHYSICS, 31, 335-362, 1979. Dale Durran provides an -! excellent discussion of flux corrected transport in his book -! NUMERICAL METHODS FOR WAVE EQUATIONS IN GEOPHYSICAL FLUID DYNAMICS. -!********************************************************************* - - subroutine cnuity(its, & - nf,of,vof, & - adbash1,adbash2,adbash3, & - u_velo,v_velo, & - u_edg,v_edg, & - dp_edg,lp_edg, & - delp,pres,exner, & - dp_tndcy,dplo_tndcy, & - massfx,omega, & - tcnuity,tcnuityEx,tcnuityBa, & - TimingBarriers ) - -use module_control ,only: nvl,nvlp1,npp,nip,nabl,dt,nd,PrintIpnDiag -use module_constants,only: nprox,prox,proxs,sidevec_c, & - sidevec_e,rarea,area,p1000,rd,cp, & - nedge,permedge -implicit none - -!.............................................................. -! Sec. 0 Dimension and Type -!.............................................................. - -! External variables: - integer,intent (IN) :: its ! model time step - integer,intent (IN) :: nf,of,vof ! time slots: new,old,very old - real ,intent (IN) :: adbash1,adbash2,adbash3 - real*8 ,intent (INOUT) :: tcnuity ! computation timer - real*8 ,intent (INOUT) :: tcnuityEx ! halo update communication timer - real*8 ,intent (INOUT) :: tcnuityBa ! barrier timer for task skew - logical,intent (IN) :: TimingBarriers ! measure task skew when .true. -!SMS$DISTRIBUTE (dh,nip) BEGIN - real ,intent (IN) :: u_velo (nvl,nip) ! west wind, m/sec - real ,intent (IN) :: v_velo (nvl,nip) ! south wind,m/sec - real ,intent (IN) :: u_edg (nvl,npp,nip) ! u on edges, m/sec - real ,intent (IN) :: v_edg (nvl,npp,nip) ! v on edges, m/sec - real ,intent (IN) :: dp_edg (nvl,npp,nip) ! dp on edges, Pa - real ,intent (IN) :: lp_edg (nvl,npp,nip) ! midlyr p on edges, Pa - real ,intent (INOUT) :: delp (nvl,nip) ! lyr thknss, Pa - real ,intent (INOUT) :: pres (nvlp1,nip) ! prs on intfc, Pa - real ,intent (INOUT) :: exner (nvlp1,nip) ! Exner fct - real ,intent (INOUT) :: dp_tndcy (nvl,nip,nabl) ! Pa/sec - real ,intent (INOUT) :: dplo_tndcy(nvl,nip,nabl) ! Pa/sec - real ,intent (INOUT) :: massfx (nvl,npp,nip,3) ! N/sec - real ,intent (OUT) :: omega (nvl,nip) ! N/sec - -! Local variables: - real :: p_plus(nvl,nip) ! Zalesak's p_plus, N/sec - real :: p_mnus(nvl,nip) ! Zalesak's p_minus, N/sec - real :: r_plus(nvl,nip) ! Zalesak's r_plus, dimensionless - real :: r_mnus(nvl,nip) ! Zalesak's r_minus, dimensionless - real :: vnorm(nvl,npp,nip) ! outward-directed velocity on edge x edge lngth - real :: antifx(nvl,npp,nip) ! N/sec - real :: delp_lo(nvl,nip) ! Pa - real :: anti_tndcy(nvl,nip) ! Pa/sec - real :: psurf(nip) ! surface pressure - real :: recovr(npp,nip) ! fluxes discarded in clipping process -!SMS$DISTRIBUTE END - - integer :: k ! layer index - integer :: ipn ! Index for icos cell number - integer :: edg ! Index for icos edge number - real :: flxhi ! thickness flux, high-order - real :: dpmax,dpmin ! Zalesak's phi_max,phi_min - real :: q_plus,q_mnus ! Zalesak's q_plus,q_mnus (N/sec) - real :: dpdx,dpdy ! pressure gradient in x,y direction - real :: coltend,lyrtend ! column & layer pressure tendency - real :: old,clip - integer :: ipx ! neighbor across joint edge - integer :: edx ! joint edge index as seen by neighbor - character :: string*32 - real, parameter :: thshld = 1.e-11 - logical,parameter :: low_ord = .false. ! if true, skip antidiffusive part - integer :: edgcount ! count of icos edges - real*8 :: t1 - -!............................................................. -! Sec. 1 Calculate Anti Diffusive Flux, Low order forcing -!............................................................. - -! Calculates the FCT low and high order fluxes, and defines -! the antidiffusive flux as the difference between the high and -! low-order fluxes. The low order flux is computed based on -! the assumption of piecewise continuity, with a constant value -! in each cell. The higher order uses the "gazebo" with a -! sloped line used for the flux integral. - -!! do k=1,nvl,7 -!! write (string,'(a,i2)') 'cnuity: old dp k=',k -!! call findmxmn2(delp,nvl,nip,k,string) -!! end do - -!SMS$PARALLEL (dh,ipn) BEGIN - -!sms$compare_var(sidevec_e, "cnuity.F90 - sidevec_e6 ") -!sms$compare_var(u_edg , "cnuity.F90 - u_edg6 ") -!sms$compare_var(v_edg , "cnuity.F90 - v_edg6 ") - - call StartTimer(t1) - - ! Initialize these local and INTENT(OUT) arrays so COMPARE_VAR does not get - ! confused by uninitialized edg = 6 edges of pentagonal grid cells. This - ! code could be safely omitted if COMPARE_VAR were not used. - -!SMS$HALO_COMP(<1,1>) BEGIN - do ipn = 1,nip ! horizontal loop - vnorm (:,npp,ipn) = 0. - antifx (:,npp,ipn) = 0. - massfx (:,npp,ipn,nf) = 0. - - do edgcount = 1,nedge(ipn) ! loop through edges - edg = permedge(edgcount,ipn) - do k = 1,nvl ! loop through layers - vnorm(k,edg,ipn) = sidevec_e(2,edg,ipn)*u_edg(k,edg,ipn) & - - sidevec_e(1,edg,ipn)*v_edg(k,edg,ipn) - end do ! loop through layer - end do ! loop through edges - end do ! horizontal loop -!SMS$HALO_COMP END - -! Avoid exchange via HALO_COMP in previous loop and in edgvar.F90 -!!!SMS$EXCHANGE(vnorm,dp_edg) - -!sms$compare_var(vnorm , "cnuity.F90 - vnorm7 ") -!sms$compare_var(dp_edg , "cnuity.F90 - dp_edg7 ") -!sms$compare_var(delp , "cnuity.F90 - delp7 ") - -!SMS$HALO_COMP(<1,1>) BEGIN - do ipn = 1,nip ! horizontal loop - do edgcount = 1,nedge(ipn) ! loop through edges - edg = permedge(edgcount,ipn) - ipx = prox(edg,ipn) ! neighbor across shared edge - edx = proxs(edg,ipn) ! neighbor's index of shared edge - - do k = 1,nvl ! loop through layers - - ! high-order mass flux (2nd order centered, out-of cell > 0) - flxhi = vnorm(k,edg,ipn)*dp_edg(k,edg,ipn) - - ! low-order mass flux (donor-cell, out-of cell > 0) - massfx(k,edg,ipn,nf) = 0.5*( & - (vnorm(k,edg,ipn)+abs(vnorm(k,edg,ipn)))*delp(k,ipn) & - - (vnorm(k,edx,ipx)+abs(vnorm(k,edx,ipx)))*delp(k,ipx) ) - - ! anti-diffusive flux = difference between high order flux (flxhi) - ! and low-order flux (massfx), from Zalesek, p336, Eqn (3): - - antifx(k,edg,ipn) = flxhi-massfx(k,edg,ipn,nf) ! N/sec - - end do ! loop through layers - end do ! loop through edges - end do ! horizontal loop -!SMS$HALO_COMP END - - write (string,'(a,i6,2x)') 'step',its - call stencl(delp,nvl,.01,string(1:12)//'(cnuity) old dp') -! call stenedg(delp,massfx(1,1,1,nf),nvl, & -! string(1:12)//'(cnuity) old dp, low-ord flx') - - do ipn = 1,nip ! horizontal loop - dplo_tndcy(:,ipn,nf) = 0. - do edg = 1,nprox(ipn) ! loop through edges - do k = 1,nvl ! loop through layers - - ! sum up edge fluxes to get low-order tendency term - dplo_tndcy(k,ipn,nf) = dplo_tndcy(k,ipn,nf)+massfx(k,edg,ipn,nf) - - end do ! loop through layers - end do ! loop through edges - -!............................................................. -! Sec. 2. Calculate new low-order dp using full Adams Bashforth -!............................................................. - - do k = 1,nvl ! loop through layers - - ! divide tendency by cell area to convert to Pa/sec - dplo_tndcy(k,ipn,nf) = -dplo_tndcy(k,ipn,nf)*rarea(ipn) - - ! get new value for the low-order delp field using Adams Bashforth - ! 3 time levels, the one just calculated (nf), and the two prev ones, - ! marked of (old field) and vof (very old field): - - delp_lo(k,ipn) = delp(k,ipn) & - +adbash1*dplo_tndcy(k,ipn, nf) & - +adbash2*dplo_tndcy(k,ipn, of) & - +adbash3*dplo_tndcy(k,ipn,vof) - - end do ! loop through layers - end do ! horizontal loop - - if (low_ord) then ! use low-order mass fluxes only - - do ipn = 1,nip ! horizontal loop - do k = 1,nvl ! loop through layers - delp(k,ipn) = delp_lo(k,ipn) - dp_tndcy(k,ipn,nf) = dplo_tndcy(k,ipn,nf) - end do - end do - - else ! evaluate and apply antidiffusive fluxes - -! Dale Durrans book indicates that condition Zal (14) should be -! satisfied, although Zalesak says its cosmetic. We believe Dale: -! Also calculate p_plus Zalesak (7) and p_minus Zalesak (10) -! (aggregate of incoming and outgoing fluxes, N/sec) - - call IncrementTimer(t1,tcnuity) - - if (TimingBarriers) then - call StartTimer(t1) -!SMS$BARRIER - call IncrementTimer(t1,tcnuityBa) - endif - - call StartTimer(t1) -!SMS$EXCHANGE(delp_lo) -!!!SMS$EXCHANGE(delp) exchanged in edgvar - call IncrementTimer(t1,tcnuityEx) - -!sms$compare_var(antifx, "cnuity.F90 - antifx8 ") -!sms$compare_var(delp_lo,"cnuity.F90 - delp_lo8 ") - - call StartTimer(t1) - - do ipn = 1,nip ! horizontal loop - p_plus(:,ipn) = 0. - p_mnus(:,ipn) = 0. - do edg = 1,nprox(ipn) ! loop through edges - do k = 1,nvl ! loop through layers - if(antifx(k,edg,ipn).le.0.) then ! flux into cell - p_plus(k,ipn) = p_plus(k,ipn)-antifx(k,edg,ipn) - else ! flux out-off cell - p_mnus(k,ipn) = p_mnus(k,ipn)+antifx(k,edg,ipn) - endif - end do ! loop through layers - end do ! loop through edges - -! At this stage we have calculated the low-order delp_lo, and the -! unclipped antidiffusive flux for the entire icos global grid. - -!............................................................ -! Sec 3. Monotonicity Limit on Fluxes -!............................................................ - -! Determine the amount of antidiffusive fluxes that can be -! added to the low-order solution without violating monotonicity. - - do k = 1,nvl ! loop through layers - - ! According to Zal (17), we must limit according to max of - ! dp from any gazebo direction, in either current or prev time - ! step. Likewise for the minimum. - ! For the pentagons prox(6,ipn) is set to prox(5,ipn) in init.F90. - - dpmax = max(delp_lo(k,ipn),delp(k,ipn), & - delp_lo(k,prox(1,ipn)),delp_lo(k,prox(2,ipn)), & - delp_lo(k,prox(3,ipn)),delp_lo(k,prox(4,ipn)), & - delp_lo(k,prox(5,ipn)),delp_lo(k,prox(6,ipn)), & - delp(k,prox(1,ipn)),delp(k,prox(2,ipn)), & - delp(k,prox(3,ipn)),delp(k,prox(4,ipn)), & - delp(k,prox(5,ipn)),delp(k,prox(6,ipn)) ) - - dpmin = min(delp_lo(k,ipn),delp(k,ipn), & - delp_lo(k,prox(1,ipn)),delp_lo(k,prox(2,ipn)), & - delp_lo(k,prox(3,ipn)),delp_lo(k,prox(4,ipn)), & - delp_lo(k,prox(5,ipn)),delp_lo(k,prox(6,ipn)), & - delp(k,prox(1,ipn)),delp(k,prox(2,ipn)), & - delp(k,prox(3,ipn)),delp(k,prox(4,ipn)), & - delp(k,prox(5,ipn)),delp(k,prox(6,ipn)) ) - - dpmax = max(0.,dpmax) ! cannot allow negative dpmax - dpmin = max(0.,dpmin) ! cannot allow negative dpmin - - ! q_plus/q_mnus are the upper/lower limits on antidiffusive dp tendencies - ! q_plus is Zalesak (8): - q_plus = (dpmax-delp_lo(k,ipn) & ! N/sec - -(adbash2*min(0.,dp_tndcy(k,ipn, of)) & - + adbash3*max(0.,dp_tndcy(k,ipn,vof)))) & - /adbash1*area(ipn) - - ! q_mnus is Zalesak (11): - q_mnus = (delp_lo(k,ipn)-dpmin & ! N/sec - +(adbash2*max(0.,dp_tndcy(k,ipn, of)) & - + adbash3*min(0.,dp_tndcy(k,ipn,vof)))) & - /adbash1*area(ipn) - - ! Having p_plus(k,ipn) and q_plus, we can calc r_plus, Zal (9): - - ! reduce fluxes to stay within limits posed by q_plus,q_mnus. - ! r_plus,r_mnus are dimensionless - - r_plus(k,ipn) = max(0.,min(1.,q_plus/max(p_plus(k,ipn),thshld))) - r_mnus(k,ipn) = max(0.,min(1.,q_mnus/max(p_mnus(k,ipn),thshld))) - - end do ! loop through layers - end do ! horizontal loop -! -! Now we have chosen flux limiters that will assure monotonicity. -! Next, we do the clipping. - -!....................................................... -! Sec. 4. Flux Clipping -!....................................................... - -! As explained by Durran, once you have the r_plus and -! r_mnus over the whole grid, you can assure that the clipping -! can be done so that it does not cause a problem in the center -! cell, NOR IN ANY OF THE NEIGHBORING CELLS. The clipping -! is from Zalesek (13): - - call IncrementTimer(t1,tcnuity) - -if (TimingBarriers) then - call StartTimer(t1) -!SMS$BARRIER - call IncrementTimer(t1,tcnuityBa) -endif - - call StartTimer(t1) -!SMS$EXCHANGE(r_plus,r_mnus) -!sms$compare_var(antifx , "cnuity.F90 - antifx9 ") - call IncrementTimer(t1,tcnuityEx) - - call StartTimer(t1) - -!SMS$HALO_COMP(<1,1>) BEGIN -!DIR$ vector always - do ipn = 1,nip ! horizontal loop - - psurf(ipn) = 0. - do k = nvl,1,-1 ! loop through layers (top-down for psurf) - psurf(ipn) = psurf(ipn)+delp (k,ipn) -! psurf(ipn) = psurf(ipn)+delp_lo(k,ipn) - end do - - do edgcount = 1,nedge(ipn) ! loop through edges - edg = permedge(edgcount,ipn) - recovr(edg,ipn) = 0. - - do k = 1,nvl ! loop through layers - if (antifx(k,edg,ipn).ge.0.) then ! outgoing - clip = min(r_mnus(k,ipn),r_plus(k,prox(edg,ipn))) - else ! incoming - clip = min(r_plus(k,ipn),r_mnus(k,prox(edg,ipn))) - end if - - ! limit antidiffusive fluxes - ! set aside vertical integral of discarded fluxes for later recovery - recovr(edg,ipn) = recovr(edg,ipn)+antifx(k,edg,ipn)*(1.-clip) - antifx(k,edg,ipn) = antifx(k,edg,ipn)*clip - - ! add clipped antidiff to low-order flux to obtain total mass flux - - massfx(k,edg,ipn,nf) = massfx(k,edg,ipn,nf)+antifx(k,edg,ipn) - end do ! loop through layers - end do ! loop through edges - end do ! horizontal loop - -!ss ! include fluxes discarded during clipping process as barotropic -!ss ! corrections to antidiffusive fluxes -!ss -!ss do ipn = 1,nip ! horizontal loop -!ss do edgcount = 1,nedge(ipn) ! loop through edges -!ss edg = permedge(edgcount,ipn) -!ss if (recovr(edg,ipn).ge.0.) then ! outgoing -!ss do k = 1,nvl -!ss antifx(k,edg,ipn) = antifx(k,edg,ipn) & -!ss +recovr(edg,ipn)*delp (k,ipn )/psurf(ipn ) -!ss! +recovr(edg,ipn)*delp_lo(k,ipn )/psurf(ipn ) -!ss end do -!ss else ! incoming -!ss ipx = prox(edg,ipn) -!ss do k = 1,nvl -!ss antifx(k,edg,ipn) = antifx(k,edg,ipn) & -!ss +recovr(edg,ipn)*delp (k,ipx)/psurf(ipx) -!ss! +recovr(edg,ipn)*delp_lo(k,ipx)/psurf(ipx) -!ss end do -!ss end if ! recovr > or < 0 -!ss end do ! loop through edges -!ss end do ! horizontal loop - -!SMS$HALO_COMP END - -!DIR$ vector always - do ipn = 1,nip ! horizontal loop - do k = 1,nvl ! loop through layers - anti_tndcy(k,ipn) = 0. - - ! sum up edge fluxes to get antidiffusive tendency term - do edg = 1,nprox(ipn) ! loop through edges - anti_tndcy(k,ipn) = anti_tndcy(k,ipn)+antifx(k,edg,ipn) - end do ! loop through edges - - ! divide antidiff tendency by cell area to convert to Pa/sec - anti_tndcy(k,ipn) = -anti_tndcy(k,ipn)*rarea(ipn) - - ! combine low-order with clipped antidiffusive tendency - dp_tndcy(k,ipn,nf) = dplo_tndcy(k,ipn,nf)+anti_tndcy(k,ipn) - - ! advance delp to new time step - - delp(k,ipn) = delp(k,ipn) & - +adbash1*dp_tndcy(k,ipn, nf) & - +adbash2*dp_tndcy(k,ipn, of) & - +adbash3*dp_tndcy(k,ipn,vof) - end do ! loop through layers - end do ! horizontal loop - - end if ! low_ord = true or false - -!! anti_tndcy(:,:)=dp_tndcy(:,:,nf) -!! do k=1,nvl,7 -!! write (string,'(a,i2)') 'dp_tndcy (nf), k=',k -!! call findmxmn2(anti_tndcy,nvl,nip,k,string) -!! write (string,'(a,i2)') 'cnuity: new dp k=',k -!! call findmxmn2(delp,nvl,nip,k,string) -!! end do - - write (string,'(a,i6,2x)') 'step',its - call stenedg(delp_lo,antifx,nvl, & - string(1:12)//'(cnuity) low-ord dp, antidiff flx') - call stencl(delp,nvl,.01,string(1:12)//'(cnuity) new dp') - - do ipn = 1,nip ! horizontal loop - coltend = 0. ! integrated mass flux convergence - do k = nvl,1,-1 ! loop through layers (top-down for p,omega) - - ! update pressure and Exner fct by vertically summing up thickness values - pres(k,ipn) = pres(k+1,ipn)+delp(k,ipn) - exner(k,ipn) = cp*(pres(k,ipn)/p1000)**(rd/cp) - - ! evaluate omega = dp/dt as - ! (partial_p/partial_t) + (v_dot_grad_p) + (s_dot partial_p/ partial_s) - - lyrtend = (adbash1*dp_tndcy(k,ipn, nf) & - +adbash2*dp_tndcy(k,ipn, of) & - +adbash3*dp_tndcy(k,ipn,vof))/dt - omega(k,ipn) = coltend+.5*lyrtend ! evaluate at mid depth - coltend = coltend+lyrtend ! flux conv. intgral - - ! pressure gradient - dpdx = 0. - dpdy = 0. - do edgcount = 1,nedge(ipn) ! loop through edges - edg = permedge(edgcount,ipn) - dpdx = dpdx+lp_edg(k,edg,ipn)*sidevec_c(2,edg,ipn) - dpdy = dpdy-lp_edg(k,edg,ipn)*sidevec_c(1,edg,ipn) - end do - - old = omega(k,ipn) - omega(k,ipn) = omega(k,ipn) & - +(u_velo(k,ipn)*dpdx & - +v_velo(k,ipn)*dpdy)*rarea(ipn) - - if (ipn.eq.PrintIpnDiag .and. mod(k,7).eq.1) then -!SMS$IGNORE BEGIN - print '(a,i8,i4,a,3f9.3)','ipn,k = ',ipn,k, & - ' omega terms 1+3,term 2,total:',old,(u_velo(k,ipn)*dpdx & - + v_velo(k,ipn)*dpdy)*rarea(ipn),omega(k,ipn) -!SMS$IGNORE END - end if - - end do ! loop through layers - end do ! horizontal loop - -! do k = 1,nvl,7 -! write (string,'(a,i3,a)') 'k',k,' cnuity:omega' -! call findmxmn2(omega,nvl,nip,k,string) -! end do -! print * - - call IncrementTimer(t1,tcnuity) - -if (.not.low_ord) then - !sms$compare_var(r_plus , "cnuity.F90 - r_plus10 ") - !sms$compare_var(r_mnus , "cnuity.F90 - r_mnus10 ") - !sms$compare_var(antifx , "cnuity.F90 - antifx10 ") -end if -!sms$compare_var(massfx , "cnuity.F90 - massfx10") -!sms$compare_var(dplo_tndcy, "cnuity.F90 - dplo_tndcy10") -!sms$compare_var(delp_lo , "cnuity.F90 - delp_lo10") - -!SMS$PARALLEL END - - return - end subroutine cnuity - end module module_cnuity diff --git a/src/fim/FIMsrc/fim/horizontal/copy.ksh b/src/fim/FIMsrc/fim/horizontal/copy.ksh deleted file mode 100755 index 226c09f..0000000 --- a/src/fim/FIMsrc/fim/horizontal/copy.ksh +++ /dev/null @@ -1,95 +0,0 @@ -#!/bin/ksh - -# copy script for horizontal - -#JR "queue" is initially empty, so "queuefile" just appends its arg to "queue" -function queuefile { queue="$queue $1 "; } # note trailing space in string -#TODO: DRY with FIMrun/functions.ksh -function fail { test -n "$1" && print "ERROR: $@"; exit 1 ; } -#TBH Hack since IBM does not include rsync in default path -#TBH function update { rsync -ut $1 . || fail ; } -function update { cp -f $1 . || fail ; } - - -toplevel_objs_file="FIM_HORIZONTAL_OBJS_TOP" -tmpfile=$0.$$.tmp - -# Everything that goes through "queuefile" and only those files will be copied to Horizontal/ and -# actually get compiled. - -queue="" # reset queue -queuefile ../../post/pop/postdata.F90 -queuefile ../../prep/ss2icos/mktopo.F90 -queuefile ../../utils/module_initial_chem_namelists.F90 -queuefile ../../utils/wtinfo.F90 -queuefile ../column_chem/module_chemvars.F90 -queuefile ../column_chem/module_initial_chem_namelist_defaults.F90 -queuefile ../horizontal/$toplevel_objs_file -queuefile ../horizontal/FIM_HORIZONTAL_OBJS -queuefile ../horizontal/Makefile -queuefile ../horizontal/SMS_Module_Lookup.txt -for file in $(ls -1 ../../cntl/*.F90) ; do queuefile $file; done -for file in $(ls -1 ../../prep/ss2icos/*.F90) ; do queuefile $file; done -for file in $(ls -1 ../horizontal/*.F90) ; do queuefile $file; done -for file in $(ls -1 ../horizontal/*.c) ; do queuefile $file; done - -# Update the queued files. - -for file in $queue; do update $file; done - -# Copy file(s) that need new names - -cp -pf ../wrfphys/module_wrfphysvars.F module_wrfphysvars.F90 || fail - -# Handle NEMS build if necessary. - -if [[ -n "$NEMS" ]]; then - - print "$PWD/$0: NEMS BUILD" - - fimdriver=$toplevel_objs_file.fim - ncep_root="../framework/nems" - - # Remove standard FIM driver .F90 source files. - - test -f $fimdriver || cp -pf $toplevel_objs_file $fimdriver || fail - for file in $(grep OBJS_TOP $fimdriver | cut -d= -f2) - do - rm -f ${file%.*}.F90 || fail - done - - # Update these now to avoid adding them to OBJS_TOP in the loop below. - - update $ncep_root/kind.inc - for file in $(ls -1 $ncep_root/*.h); do update $file; done - - # Grab FIM component code. - - # update *.f90 files without name change - for file in $(ls -1 $ncep_root/*.f90); do update $file; done - - # rename *.F90 to *.f90 to avoid running PPP on NEMS files - # (Makefile rule for *.f90 avoids PPP.) - for file in $(ls -1 $ncep_root/*.F90) - do - dstfile=$(basename $file) - cp -pf $file ${dstfile%.*}.f90 || fail - done - - # Replace toplevel objects file. - objs="OBJS_TOP = " # append .o names to this initial string - for file in $(ls -1 $ncep_root/*.F90 $ncep_root/*.f90) - do - file=$(basename $file) - objs="$objs ${file%.*}.o" # replace .F90 and .f90 extensions with .o (ksh feature) - done - print $objs > $toplevel_objs_file - -fi # NEMS handler - -# Deduce dependencies. - -rm -f Filepath Srcfiles || fail -echo "." > Filepath -ls *.[fF]90 > Srcfiles -$MKDEPENDS -m -d module_decomp.o Filepath Srcfiles > FIM_HORIZONTAL_DEPENDENCIES || fail diff --git a/src/fim/FIMsrc/fim/horizontal/cpl_finalize.F90 b/src/fim/FIMsrc/fim/horizontal/cpl_finalize.F90 deleted file mode 100644 index 0cdbd14..0000000 --- a/src/fim/FIMsrc/fim/horizontal/cpl_finalize.F90 +++ /dev/null @@ -1,19 +0,0 @@ -module module_fim_cpl_finalize -contains -!********************************************************************* - subroutine cpl_finalize -! Finish the FIM DYN-PHY coupler component. -! T. Henderson February, 2009 -!********************************************************************* - - use module_outtime_cpl,only: OutTime - use module_control ,only: PrintMAXMINtimes - - implicit none - - ! print elapsed times for coupler parts of FIM - call OutTime(maxmin_times=PrintMAXMINtimes,print_header=.true.) - - return -end subroutine cpl_finalize -end module module_fim_cpl_finalize diff --git a/src/fim/FIMsrc/fim/horizontal/cpl_init.F90 b/src/fim/FIMsrc/fim/horizontal/cpl_init.F90 deleted file mode 100644 index 25ac08d..0000000 --- a/src/fim/FIMsrc/fim/horizontal/cpl_init.F90 +++ /dev/null @@ -1,205 +0,0 @@ -module module_fim_cpl_init - -implicit none - -contains - -!********************************************************************* -! Initialize the FIM DYN-PHY coupler component. -! T. Henderson February, 2009 -!********************************************************************* -subroutine cpl_init - -use module_constants,only: lat, lon -use module_control ,only: nip -use module_sfc_variables,only: ts2d,us2d,hf2d,qf2d, & - sheleg2d, canopy2d, hice2d, fice2d, & - st3d, sm3d, sw2d, lw2d, t2m2d, q2m2d, & - slmsk2d -!SMS$IGNORE BEGIN -USE gfs_physics_internal_state_mod, only: gfs_physics_internal_state, gis_phy -!SMS$IGNORE END - - implicit none - - ! Local variables - real*8 :: t0,t1=0.0d0 - - call StartTimer(t0) - -!TODO: For the moment, pass lon,lat from DYN to PHY here. Later we will -!TODO: hopefully change to passing these via the ESMF_Grid and -!TODO: cpl_init_dyn_to_phy() can be eliminated, improving interoperability. -!TODO: Separate into two-phase CPL init as is done in run.F90? See -!TODO: module_DYN_PHY_CPL_COMP.F90 for details. - - call cpl_init_dyn_to_phy(nip, & -! IN args - lon, lat, & -! OUT args - gis_phy%xlon, gis_phy%xlat) - -!TODO: At the moment, NEMS does not pass anything between DYN and PHY -!TODO: during INIT. We would like to write initial values of PHY variables -!TODO: to disk in our 0-hour history output. For now pass from PHY to DYN -!TODO: here. If NEMS comes up with a solution (maybe via the new NEMS I/O) -!TODO: that allows PHY to write directly via the I/O component(s), then -!TODO: replace cpl_init_phy_to_dyn() with the new method. If not then it may -!TODO: be necessary to extend NEMS to allow transfer of fields from DYN to PHY -!TODO: in CPL_INIT after both DYN and PHY have finished their init phases. - - call cpl_init_phy_to_dyn(nip, & -! IN args - ! these GFS PHY fields are passed to FIM DYN for - ! output and diagnostics only. - gis_phy%sfc_fld%TSEA, gis_phy%sfc_fld%UUSTAR, & - gis_phy%flx_fld%HFLX, gis_phy%flx_fld%EVAP, & - gis_phy%sfc_fld%SHELEG, gis_phy%sfc_fld%CANOPY, & - gis_phy%sfc_fld%HICE, gis_phy%sfc_fld%FICE, & - gis_phy%sfc_fld%STC, gis_phy%sfc_fld%SMC, & - gis_phy%flx_fld%SFCDSW, gis_phy%flx_fld%SFCDLW, & - gis_phy%sfc_fld%T2M, gis_phy%sfc_fld%Q2M, & - gis_phy%sfc_fld%SLMSK, & -! OUT args - ts2d, us2d, hf2d, qf2d, & - sheleg2d, canopy2d, hice2d, fice2d, st3d, sm3d, & - sw2d, lw2d, t2m2d, q2m2d, slmsk2d ) - - call IncrementTimer(t0,t1) - - print"(' COUPLER INIT time:',F10.0)",t1 - - return -end subroutine cpl_init - - -!********************************************************************* -! Couple from DYN->PHY during INIT phase. -!********************************************************************* -subroutine cpl_init_dyn_to_phy(nip,lon,lat,gfs_lon,gfs_lat) - -USE MACHINE ,only: kind_rad - - implicit none - - ! Arguments - integer, intent(in) :: nip -!SMS$DISTRIBUTE (dh,1) BEGIN - real , intent(in) :: lon(:) - real , intent(in) :: lat(:) - real(kind=kind_rad) , intent(out) :: gfs_lon(:,:) - real(kind=kind_rad) , intent(out) :: gfs_lat(:,:) -!SMS$DISTRIBUTE END - - ! Local variables - integer :: ipn - -!SMS$PARALLEL (dh,ipn) BEGIN - do ipn=1,nip - gfs_lon(ipn,1) = lon(ipn) - gfs_lat(ipn,1) = lat(ipn) - enddo -!SMS$PARALLEL END - - return -end subroutine cpl_init_dyn_to_phy - - -!********************************************************************* -! Couple from PHY->DYN during INIT phase. -!********************************************************************* -subroutine cpl_init_phy_to_dyn(nip, & - ! these GFS PHY fields are passed to FIM DYN for - ! output and diagnostics only. - gfs_tsea, gfs_uustar, & - gfs_hflx, gfs_evap, & - gfs_sheleg, gfs_canopy, & - gfs_hice, gfs_fice, & - gfs_stc, gfs_smc, & - gfs_sfcdsw, gfs_sfcdlw, & - gfs_t2m, gfs_q2m, & - gfs_slmsk, & -! OUT args - ts2d, us2d, hf2d, qf2d, & - sheleg2d, canopy2d, hice2d, fice2d, & - st3d, sm3d, sw2d, lw2d, t2m2d, q2m2d, & - slmsk2d ) - -USE MACHINE ,only: kind_phys - - implicit none - - ! Arguments - integer, intent(in) :: nip -!SMS$DISTRIBUTE (dh,1) BEGIN - real(kind=kind_phys) , intent(in ) :: gfs_tsea(:,:) - real(kind=kind_phys) , intent(in ) :: gfs_uustar(:,:) - real(kind=kind_phys) , intent(in ) :: gfs_hflx(:,:) - real(kind=kind_phys) , intent(in ) :: gfs_evap(:,:) - real(kind=kind_phys) , intent(in ) :: gfs_sheleg(:,:) - real(kind=kind_phys) , intent(in ) :: gfs_canopy(:,:) - real(kind=kind_phys) , intent(in ) :: gfs_hice (:,:) - real(kind=kind_phys) , intent(in ) :: gfs_fice (:,:) - real(kind=kind_phys) , intent(in ) :: gfs_sfcdsw(:,:) - real(kind=kind_phys) , intent(in ) :: gfs_sfcdlw(:,:) - real(kind=kind_phys) , intent(in ) :: gfs_t2m (:,:) - real(kind=kind_phys) , intent(in ) :: gfs_q2m (:,:) - real(kind=kind_phys) , intent(in ) :: gfs_slmsk (:,:) -!SMS$DISTRIBUTE END -!SMS$DISTRIBUTE (dh,2) BEGIN - real(kind=kind_phys) , intent(in ) :: gfs_stc (:,:,:) - real(kind=kind_phys) , intent(in ) :: gfs_smc (:,:,:) -!SMS$DISTRIBUTE END -!SMS$DISTRIBUTE (dh,1) BEGIN - real , intent( out) :: ts2d(:) - real , intent( out) :: us2d(:) - real , intent( out) :: hf2d(:) - real , intent( out) :: qf2d(:) - real , intent( out) :: sheleg2d(:) - real , intent( out) :: canopy2d(:) - real , intent( out) :: hice2d(:) - real , intent( out) :: fice2d(:) - real , intent( out) :: sw2d(:) - real , intent( out) :: lw2d(:) - real , intent( out) :: t2m2d(:) - real , intent( out) :: q2m2d(:) - real , intent( out) :: slmsk2d(:) -!SMS$DISTRIBUTE END -!SMS$DISTRIBUTE (dh,2) BEGIN - real , intent( out) :: st3d(:,:) - real , intent( out) :: sm3d(:,:) -!SMS$DISTRIBUTE END - - ! Local variables - integer :: ipn - -!SMS$PARALLEL (dh,ipn) BEGIN - -!---------------------------------------------------------------------- -! Move all output into correct FIM arrays for 00h output -!---------------------------------------------------------------------- -!TODO: remove duplication with cpl_phy_to_dyn() if practical - do ipn=1,nip - ts2d (ipn) = gfs_TSEA (ipn,1) - us2d (ipn) = gfs_UUSTAR(ipn,1) - hf2d (ipn) = gfs_HFLX (ipn,1) - qf2d (ipn) = gfs_EVAP (ipn,1) - sheleg2d(ipn) = gfs_SHELEG(ipn,1) - canopy2d(ipn) = gfs_CANOPY(ipn,1) - hice2d (ipn) = gfs_HICE (ipn,1) - fice2d (ipn) = gfs_FICE (ipn,1) - st3d (:,ipn) = gfs_STC (:,ipn,1) - sm3d (:,ipn) = gfs_SMC (:,ipn,1) - sw2d (ipn) = gfs_SFCDSW(ipn,1) - lw2d (ipn) = gfs_SFCDLW(ipn,1) - t2m2d (ipn) = gfs_T2M (ipn,1) - q2m2d (ipn) = gfs_Q2M (ipn,1) - slmsk2d (ipn) = gfs_SLMSK (ipn,1) - enddo !ipn - -!SMS$PARALLEL END - - return -end subroutine cpl_init_phy_to_dyn - -end module module_fim_cpl_init diff --git a/src/fim/FIMsrc/fim/horizontal/cpl_run.F90 b/src/fim/FIMsrc/fim/horizontal/cpl_run.F90 deleted file mode 100644 index dd7cab1..0000000 --- a/src/fim/FIMsrc/fim/horizontal/cpl_run.F90 +++ /dev/null @@ -1,375 +0,0 @@ -module module_fim_cpl_run - -IMPLICIT NONE - -contains - -!********************************************************************* - subroutine cpl_run(its, dyn_to_phy) -! "Run" method for the FIM DYN-PHY coupler component. -! Argument its is time step count. -! Argument dyn_to_phy controls the direction of coupling: -! dyn_to_phy == .true. Couple from DYN to PHY -! dyn_to_phy == .false. Couple from PHY to DYN -! T. Henderson February, 2009 - Moved code here from physics() -! R. Bleck July, 2010 - fixed layer pressure formula -!********************************************************************* - -!SMS$IGNORE BEGIN -!TBH: NOTE removal of "only" clause. This was forced upon us by *bug* in the -!TBH: ifort 11.1 compiler on njet. Restore the "only" clause when the broken -!TBH: compiler is fixed! -USE gfs_physics_internal_state_mod, only: gfs_physics_internal_state, gis_phy -!SMS$IGNORE END - -use module_control ,only: nts,CallPhysics,itsStart -use module_variables,only: us3d,vs3d,pr3d,tr3d,ws3d -use module_sfc_variables - -use module_outtime_cpl,only: telapsed=>tcpl - -implicit none - -! Declare dummy arguments -integer, intent(in) :: its -logical, intent(in) :: dyn_to_phy - -! Declare local variables: - -real*8 :: t0 - -call StartTimer(t0) - - !........................................................... - ! Couple components unless this is the last (nts+1) - ! iteration (in which DYN just finishes). - ! This complexity is required for the NCEP ESMF approach - ! in which single-phase DYN and PHY components alternate - ! execution during each time step. - ! -if (its < itsStart+nts ) then - - !TODO: Eliminate duplication by encapsulating this logic - if(mod(its,CallPhysics)==0.or.its==1) then ! Do physics - -!sms$compare_var(st3d , 'begin cpl_run') -!sms$compare_var(sm3d , 'begin cpl_run') -!sms$compare_var(rn2d , 'begin cpl_run') -!sms$compare_var(rc2d , 'begin cpl_run') -!sms$compare_var(ts2d , 'begin cpl_run') -!sms$compare_var(us2d , 'begin cpl_run') -!sms$compare_var(hf2d , 'begin cpl_run') -!sms$compare_var(sw2d , 'begin cpl_run') -!sms$compare_var(slmsk2d, 'begin cpl_run') - - if (dyn_to_phy) then - ! Subroutine cpl_dyn_to_phy() converts FIM values to GFS - ! values. - ! All arrays passed via the ESMF coupler are passed as - ! arguments, allowing this subroutine to be called from - ! the ESMF coupler too. - call cpl_dyn_to_phy(its, & -! IN args - pr3d, us3d, vs3d, ws3d, tr3d, & -! OUT args - gis_phy%ps, gis_phy%dp, gis_phy%p, & - gis_phy%u , gis_phy%v , gis_phy%dpdt, & - gis_phy%q , gis_phy%oz, gis_phy%cld, & - gis_phy%t ) - else - ! Subroutine cpl_phy_to_dyn() converts GFS values to FIM - ! values. - ! All arrays passed via the ESMF coupler are passed as - ! arguments, allowing this subroutine to be called from - ! the ESMF coupler too. - call cpl_phy_to_dyn(its, & -! IN args - gis_phy%p, gis_phy%u , gis_phy%v, & - gis_phy%q, gis_phy%cld, gis_phy%t, & - ! these GFS PHY fields are passed to FIM DYN for - ! output and diagnostics only. - gis_phy%flx_fld%GESHEM, gis_phy%flx_fld%RAINC, & - gis_phy%sfc_fld%TSEA, gis_phy%sfc_fld%UUSTAR, & - gis_phy%flx_fld%HFLX, gis_phy%flx_fld%EVAP, & - gis_phy%sfc_fld%SHELEG, gis_phy%sfc_fld%CANOPY, & - gis_phy%sfc_fld%HICE, gis_phy%sfc_fld%FICE, & - gis_phy%sfc_fld%STC, gis_phy%sfc_fld%SMC, & - gis_phy%flx_fld%SFCDSW, gis_phy%flx_fld%SFCDLW, & - gis_phy%sfc_fld%T2M, gis_phy%sfc_fld%Q2M, & - gis_phy%sfc_fld%SLMSK, gis_phy%HPRIME, & - gis_phy%FLUXR, & -! OUT args - us3d, vs3d, tr3d, rn2d, rc2d, ts2d, us2d, hf2d, qf2d,& - sheleg2d, canopy2d, hice2d, fice2d, st3d, sm3d, & - sw2d, lw2d, t2m2d, q2m2d, slmsk2d, hprm2d, flxlwtoa2d ) - endif - -!sms$compare_var(st3d , 'end cpl_run') -!sms$compare_var(sm3d , 'end cpl_run') -!sms$compare_var(rn2d , 'end cpl_run') -!sms$compare_var(rc2d , 'end cpl_run') -!sms$compare_var(ts2d , 'end cpl_run') -!sms$compare_var(us2d , 'end cpl_run') -!sms$compare_var(hf2d , 'end cpl_run') -!sms$compare_var(sw2d , 'end cpl_run') -!sms$compare_var(slmsk2d, 'end cpl_run') - - endif ! CallPhysics - -endif - -call IncrementTimer(t0,telapsed) - -return -end subroutine cpl_run - - - -! Couple from DYN->PHY. -subroutine cpl_dyn_to_phy(its, & - pr3d,us3d,vs3d,ws3d,tr3d, & - gfs_ps, gfs_dp, gfs_p, & - gfs_u , gfs_v , gfs_dpdt, & - gfs_q , gfs_oz, gfs_cld, & - gfs_t ) - -!SMS$IGNORE BEGIN -! TODO: Pass elements of gfs_physics_internal_state_mod via argument -! TODO: list and remove use of gfs_physics_internal_state_mod. -!TBH: NOTE removal of "only" clause. This was forced upon us by *bug* in the -!TBH: ifort 11.1 compiler on njet. Restore the "only" clause when the broken -!TBH: compiler is fixed! -!USE gfs_physics_internal_state_mod, only: gfs_physics_internal_state, gis_phy -USE gfs_physics_internal_state_mod -!SMS$IGNORE END - -use module_constants,only: cp, rd, p1000, lat, lon, qvmin -use module_control ,only: nvl,nip,CallRadiation,itsStart -use module_sfc_variables, only: zorl2d,srflag2d -USE MACHINE ,only: kind_evod - -implicit none - - integer, intent(in) :: its -!SMS$DISTRIBUTE (dh,2) BEGIN - real , intent(in ) :: pr3d(:,:) - real , intent(in ) :: us3d(:,:) - real , intent(in ) :: vs3d(:,:) - real , intent(in ) :: ws3d(:,:) - real , intent(in ) :: tr3d(:,:,:) -!SMS$DISTRIBUTE END -!SMS$DISTRIBUTE (dh,1) BEGIN - real(kind=kind_evod) , intent(out) :: gfs_ps(:) - real(kind=kind_evod) , intent(out) :: gfs_dp(:,:) - real(kind=kind_evod) , intent(out) :: gfs_p(:,:) - real(kind=kind_evod) , intent(out) :: gfs_u(:,:) - real(kind=kind_evod) , intent(out) :: gfs_v(:,:) - real(kind=kind_evod) , intent(out) :: gfs_dpdt(:,:) - real(kind=kind_evod) , intent(out) :: gfs_q(:,:) - real(kind=kind_evod) , intent(out) :: gfs_oz(:,:) - real(kind=kind_evod) , intent(out) :: gfs_cld(:,:) - real(kind=kind_evod) , intent(out) :: gfs_t(:,:) -!SMS$DISTRIBUTE END - -! Declare local variables: -integer :: ipn,ivl -real :: rocp1,rocpr -!SMS$DISTRIBUTE (dh,nip) BEGIN -real :: tr_2(nvl,nip) -real :: theta_nv(nvl,nip) -!SMS$DISTRIBUTE END - - rocp1=rd/cp+1. - rocpr=cp/rd - -!SMS$PARALLEL (dh,ipn) BEGIN - do ipn=1,nip - - do ivl=1,nvl - tr_2(ivl,ipn) = max(qvmin, tr3d(ivl,ipn,2)) - enddo - -!NOTE: ZORL is held constant in FIM-GFS coupling. Bao confirms that this -!NOTE: is what we want. - gis_phy%sfc_fld%ZORL(ipn,1) = zorl2d(ipn) - !NOTE: This logic replicates Bao's original logic in which - !NOTE: initial values of TRPCP was read from a file in phy_init() but - !NOTE: overwritten from GESHEM after the first call to phy_run(). - !NOTE: Bao has checked the original logic and verified that it - !NOTE: behaved as he intended. - if (its > 1) then - gis_phy%sfc_fld%TPRCP(ipn,1) = max(0.0d0, gis_phy%flx_fld%GESHEM(ipn,1)) - endif -!NOTE: SRFLAG is held constant in FIM-GFS coupling. Bao says "OK". - gis_phy%sfc_fld%SRFLAG(ipn,1) = srflag2d(ipn) - ! Bao confirms that overwrite with TG3 is intentional here. - gis_phy%flx_fld%TMPMIN(ipn,1) = gis_phy%sfc_fld%TG3(ipn,1) - gis_phy%flx_fld%TMPMAX(ipn,1) = gis_phy%sfc_fld%TG3(ipn,1) - - gfs_ps(ipn) = 0.001*pr3d(1,ipn) - do ivl=1,nvl - gfs_dp(ipn,ivl) = (0.001*pr3d(ivl,ipn))-(0.001*pr3d(ivl+1,ipn)) -!!! gfs_p(ipn,ivl) = 0.5*(pr3d(ivl,ipn)+pr3d(ivl+1,ipn)) -! get energetically consistent mid-lyr prs from partial[p^(kap+1)]/partial[p] - gfs_p(ipn,ivl) = & - ((pr3d(ivl,ipn)**rocp1-pr3d(ivl+1,ipn)**rocp1)/ & - ((pr3d(ivl,ipn) -pr3d(ivl+1,ipn) )*rocp1))**rocpr - gfs_u(ipn,ivl) = us3d(ivl,ipn) - gfs_v(ipn,ivl) = vs3d(ivl,ipn) - gfs_dpdt(ipn,ivl) = 0.001*ws3d(ivl,ipn) - gfs_q(ipn,ivl) = tr_2(ivl,ipn) - gfs_oz(ipn,ivl) = tr3d(ivl,ipn,4) - gfs_cld(ipn,ivl ) = tr3d(ivl,ipn,3) - theta_nv(ivl,ipn) = tr3d(ivl,ipn,1) & - /(1.+0.6078*max(qvmin,tr_2(ivl,ipn))) - gfs_t(ipn,ivl) = theta_nv(ivl,ipn)*(gfs_p(ipn,ivl)/p1000)**(rd/cp) - enddo - enddo - -!SMS$PARALLEL END - - return -end subroutine cpl_dyn_to_phy - - - -! Couple from PHY->DYN. -subroutine cpl_phy_to_dyn(its, & -! IN args - gfs_p, gfs_u , gfs_v, & - gfs_q, gfs_cld, gfs_t, & - ! these GFS PHY fields are passed to FIM DYN for - ! output and diagnostics only. - gfs_geshem, gfs_rainc, & - gfs_tsea, gfs_uustar, & - gfs_hflx, gfs_evap, & - gfs_sheleg, gfs_canopy, & - gfs_hice, gfs_fice, & - gfs_stc, gfs_smc, & - gfs_sfcdsw, gfs_sfcdlw, & - gfs_t2m, gfs_q2m, & - gfs_slmsk, gfs_hprime, & - gfs_fluxr, & -! OUT args - us3d, vs3d, tr3d, & - rn2d, rc2d, ts2d, us2d, hf2d, qf2d, & - sheleg2d, canopy2d, hice2d, fice2d, & - st3d, sm3d, sw2d, lw2d, t2m2d, q2m2d, & - slmsk2d, hprm2d, flxlwtoa2d ) - -use module_constants,only: cp, rd, p1000, qvmin, qwmin -use module_control ,only: nts,nvl,nip -USE MACHINE ,only: kind_evod,kind_phys,kind_rad - -implicit none - - integer, intent(in) :: its -!SMS$DISTRIBUTE (dh,1) BEGIN - real(kind=kind_evod) , intent(in ) :: gfs_p(:,:) - real(kind=kind_evod) , intent(in ) :: gfs_u(:,:) - real(kind=kind_evod) , intent(in ) :: gfs_v(:,:) - real(kind=kind_evod) , intent(in ) :: gfs_q(:,:) - real(kind=kind_evod) , intent(in ) :: gfs_cld(:,:) - real(kind=kind_evod) , intent(in ) :: gfs_t(:,:) - real(kind=kind_phys) , intent(in ) :: gfs_geshem(:,:) - real(kind=kind_phys) , intent(in ) :: gfs_rainc(:,:) - real(kind=kind_phys) , intent(in ) :: gfs_tsea(:,:) - real(kind=kind_phys) , intent(in ) :: gfs_uustar(:,:) - real(kind=kind_phys) , intent(in ) :: gfs_hflx(:,:) - real(kind=kind_phys) , intent(in ) :: gfs_evap(:,:) - real(kind=kind_phys) , intent(in ) :: gfs_sheleg(:,:) - real(kind=kind_phys) , intent(in ) :: gfs_canopy(:,:) - real(kind=kind_phys) , intent(in ) :: gfs_hice (:,:) - real(kind=kind_phys) , intent(in ) :: gfs_fice (:,:) - real(kind=kind_phys) , intent(in ) :: gfs_sfcdsw(:,:) - real(kind=kind_phys) , intent(in ) :: gfs_sfcdlw(:,:) - real(kind=kind_phys) , intent(in ) :: gfs_t2m (:,:) - real(kind=kind_phys) , intent(in ) :: gfs_q2m (:,:) - real(kind=kind_phys) , intent(in ) :: gfs_slmsk (:,:) -!SMS$DISTRIBUTE END -!SMS$DISTRIBUTE (dh,2) BEGIN - real(kind=kind_phys) , intent(in ) :: gfs_stc (:,:,:) - real(kind=kind_phys) , intent(in ) :: gfs_smc (:,:,:) - real(kind=kind_rad) , intent(in ) :: gfs_hprime(:,:,:) - real(kind=kind_rad) , intent(in ) :: gfs_fluxr(:,:,:) -!SMS$DISTRIBUTE END -!SMS$DISTRIBUTE (dh,2) BEGIN - real , intent( out) :: us3d(:,:) - real , intent( out) :: vs3d(:,:) - ! TBH: tr3d must be inout instead of out because tr3d(:,:,4) is - ! TBH: never set. - real , intent(inout) :: tr3d(:,:,:) -!SMS$DISTRIBUTE END -!SMS$DISTRIBUTE (dh,1) BEGIN - real , intent(inout) :: rn2d(:) - real , intent(inout) :: rc2d(:) - real , intent( out) :: ts2d(:) - real , intent( out) :: us2d(:) - real , intent( out) :: hf2d(:) - real , intent( out) :: qf2d(:) - real , intent( out) :: sheleg2d(:) - real , intent( out) :: canopy2d(:) - real , intent( out) :: hice2d(:) - real , intent( out) :: fice2d(:) - real , intent( out) :: sw2d(:) - real , intent( out) :: lw2d(:) - real , intent( out) :: t2m2d(:) - real , intent( out) :: q2m2d(:) - real , intent( out) :: slmsk2d(:) - real , intent( out) :: flxlwtoa2d(:) -!SMS$DISTRIBUTE END -!SMS$DISTRIBUTE (dh,2) BEGIN - real , intent( out) :: st3d(:,:) - real , intent( out) :: sm3d(:,:) - real , intent( out) :: hprm2d(:,:) -!SMS$DISTRIBUTE END - -! Declare local variables: -integer :: ipn,ivl -real (kind=kind_phys) :: rn2dten,rc2dten - -!SMS$PARALLEL (dh,ipn) BEGIN - -!---------------------------------------------------------------------- -! Move all output into correct FIM arrays -!---------------------------------------------------------------------- - do ipn=1,nip - do ivl=1,nvl - us3d(ivl,ipn) = gfs_u(ipn,ivl) - vs3d(ivl,ipn) = gfs_v(ipn,ivl) - ! Replace values for prognostic variables - tr3d(ivl,ipn,1) = gfs_t(ipn,ivl)*(p1000/gfs_p(ipn,ivl))**(rd/cp)*(1.+0.6078*max(REAL(qvmin,kind_evod),gfs_q(ipn,ivl))) - tr3d(ivl,ipn,2) = max(REAL(qvmin,kind_evod),gfs_q(ipn,ivl)) - tr3d(ivl,ipn,3) = max(REAL(qwmin,kind_evod),gfs_cld(ipn,ivl)) - enddo -!TBH: Remaining fields are needed only for FIM diagnostics. - rn2dten = max(0.0_kind_phys, gfs_GESHEM(ipn,1)) - rc2dten = max(0.0_kind_phys, gfs_RAINC(ipn,1)) -!TBH: I assume here that NEMS allows the modified state to be either -!TBH: intent(out) *or* intent(inout) ... - rn2d (ipn) = rn2d(ipn) + rn2dten*1000. - rc2d (ipn) = rc2d(ipn) + rc2dten*1000. - ts2d (ipn) = gfs_TSEA (ipn,1) - us2d (ipn) = gfs_UUSTAR(ipn,1) - hf2d (ipn) = gfs_HFLX (ipn,1) - qf2d (ipn) = gfs_EVAP (ipn,1) - sheleg2d(ipn) = gfs_SHELEG(ipn,1) - canopy2d(ipn) = gfs_CANOPY(ipn,1) - hice2d (ipn) = gfs_HICE (ipn,1) - fice2d (ipn) = gfs_FICE (ipn,1) - st3d (:,ipn) = gfs_STC (:,ipn,1) - sm3d (:,ipn) = gfs_SMC (:,ipn,1) - sw2d (ipn) = gfs_SFCDSW(ipn,1) - lw2d (ipn) = gfs_SFCDLW(ipn,1) - t2m2d (ipn) = gfs_T2M (ipn,1) - q2m2d (ipn) = gfs_Q2M (ipn,1) - slmsk2d (ipn) = gfs_SLMSK (ipn,1) - hprm2d(:,ipn) = gfs_HPRIME(:,ipn,1) - flxlwtoa2d(ipn) = gfs_FLUXR(1,ipn,1) - enddo !ipn - -!SMS$PARALLEL END - -end subroutine cpl_phy_to_dyn - -end module module_fim_cpl_run diff --git a/src/fim/FIMsrc/fim/horizontal/datetime.F90 b/src/fim/FIMsrc/fim/horizontal/datetime.F90 deleted file mode 100644 index 9923d55..0000000 --- a/src/fim/FIMsrc/fim/horizontal/datetime.F90 +++ /dev/null @@ -1,17 +0,0 @@ -subroutine datetime -character (24) :: DateT -character ( 8) :: date -character (10) :: time -character ( 5) :: zone -character ( 3) :: month(12) -character (80) :: FMT -integer :: values(8) -data month /'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec'/ - -call date_and_time(date,time,zone,values) -FMT = "(a3,i3,',',i5,i3,':',i2.2,':',i2.2)" -write(DateT,FMT) month(values(2)),values(3),values(1),values(5),values(6),values(7) -print "(' DATE-TIME: ',A)",DateT - -end subroutine datetime - diff --git a/src/fim/FIMsrc/fim/horizontal/dffusn.F90 b/src/fim/FIMsrc/fim/horizontal/dffusn.F90 deleted file mode 100644 index 2e4850b..0000000 --- a/src/fim/FIMsrc/fim/horizontal/dffusn.F90 +++ /dev/null @@ -1,156 +0,0 @@ -module module_dffusn_lev -contains -!********************************************************************* -! dffusn_lev -! Diffuse level variable (no thickness weighting) -! S. Sun September 2009 -!********************************************************************* - - subroutine dffusn_lev (fld, dfflen, kdim, k1, k2) - use module_control ,only: npp,nip,PrintIpnDiag - use module_constants,only: nprox,prox,rarea,sideln - - implicit none -! External type and dimension: - - integer,intent (IN) :: kdim ! vert.dim. of fld and dfflen - integer,intent (IN) :: k1,k2 ! operate on levels k1 ... k2 - real ,intent (IN) :: dfflen (kdim) ! diffusion length scale (m) -!SMS$DISTRIBUTE (dh,nip) BEGIN - real ,intent (INOUT) :: fld (kdim,nip) ! field(s) to be diffused - -! Local variables: - real :: flxdv(kdim,nip) ! line integral of dffus.flux across the edge -!SMS$DISTRIBUTE END - -! Local variables - integer :: k ! layer index - integer :: ipn ! icos point index - integer :: ipx ! neighbor across joint edge - integer :: edg ! icos edge index - real :: factor - -!SMS$PARALLEL (dh,ipn) BEGIN -!SMS$EXCHANGE(fld) - - do ipn = 1,nip ! horizontal loop - flxdv(:,ipn) = 0. - do edg = 1,nprox(ipn) - ipx = prox(edg,ipn) ! neighbor across shared edge - do k = k1,k2 ! loop through levels - flxdv(k,ipn) = flxdv(k,ipn)+(fld(k,ipn)-fld(k,ipx)) & - *sideln(edg,ipn) - - if (ipn.eq.PrintIpnDiag .and. mod(k,7).eq.k1) then -!SMS$IGNORE BEGIN - write (*,'(a,i8,i4,a,2f12.1,a,es11.2)') 'ipn,k=',ipn,k, & - ' (dffusn_lev) fld=',fld(k,ipn),fld(k,prox(edg,ipn)),' flx=', & - fld(k,ipn)-fld(k,prox(edg,ipn)) -!SMS$IGNORE END - end if - - end do ! loop through levels - end do ! loop through edges - end do ! horizontal loop - - do ipn = 1,nip ! horizontal loop - do k = k1,k2 ! loop through levels - factor = -dfflen(k)*rarea(ipn) - fld(k,ipn) = fld(k,ipn) + flxdv(k,ipn)*factor - - if (ipn.eq.PrintIpnDiag .and. mod(k,7).eq.k1) then -!SMS$IGNORE BEGIN - write (*,'(i8,i4,a,2es11.2,f12.1)') ipn,k, & - ' (dffusn_lev) flxdv,fac,fld=',flxdv(k,ipn),factor,fld(k,ipn) -!SMS$IGNORE END - end if - - end do ! loop through levels - end do ! horizontal loop - -!!!SMS$EXCHANGE(fld) -!SMS$PARALLEL END - - return - end subroutine dffusn_lev -end module module_dffusn_lev ! SMS doesn't like multiple routines in module - - -module module_dffusn_lyr -contains -!********************************************************************* -! dffusn_lyr -! Diffuse layer variable (thickness-weighted for conservation) -! S. Sun September 2009 -!********************************************************************* - - subroutine dffusn_lyr (fld, delp, dfflen) - use module_control ,only: npp,nip,nvl,PrintIpnDiag - use module_constants,only: nprox,prox,rarea,sideln - - implicit none -! External type and dimension: - real ,intent (IN) :: dfflen ! diffusion length scale (m) -!SMS$DISTRIBUTE (dh,nip) BEGIN - real ,intent (INOUT) :: fld (nvl,nip) ! field to be diffused - real ,intent (IN) :: delp (nvl,nip) ! lyr thknss, Pa - -! Local variables: - real :: flxdv(nvl,nip) ! line integral of dffus.flux across the edge -!SMS$DISTRIBUTE END - -! Local variables - integer :: k ! layer index - integer :: ipn ! icos point index - integer :: ipx ! neighbor across joint edge - integer :: edg ! icos edge index - real :: factor - real,parameter :: thshld = 1.e-11 - real :: hfharm,a,b - hfharm(a,b) = a*b/(a+b) ! harmonic average x 0.5 - -!SMS$PARALLEL (dh,ipn) BEGIN -!SMS$EXCHANGE(delp,fld) - - do ipn = 1,nip ! horizontal loop - flxdv(:,ipn) = 0. - do edg = 1,nprox(ipn) - ipx = prox(edg,ipn) ! neighbor across shared edge - do k = 1,nvl ! loop through layers - flxdv(k,ipn) = flxdv(k,ipn)+(fld(k,ipn)-fld(k,ipx)) & - *sideln(edg,ipn)*2.*hfharm(max(delp(k,ipn),thshld) & - ,max(delp(k,ipx),thshld)) - - if (ipn.eq.PrintIpnDiag .and. mod(k,7).eq.1) then -!SMS$IGNORE BEGIN - write (*,'(a,i8,i4,a,2f12.1,a,es11.2)') 'ipn,k=',ipn,k, & - ' (dffusn_lyr) fld=',fld(k,ipn),fld(k,prox(edg,ipn)),' flx=', & - fld(k,ipn)-fld(k,prox(edg,ipn)) -!SMS$IGNORE END - end if - - end do ! loop through layers - end do ! loop through edges - end do ! horizontal loop - - do ipn = 1,nip ! horizontal loop - do k = 1,nvl ! loop through layers - factor = -dfflen*rarea(ipn)/max(delp(k,ipn),thshld) - fld(k,ipn) = fld(k,ipn) + flxdv(k,ipn)*factor - - if (ipn.eq.PrintIpnDiag .and. mod(k,7).eq.1) then -!SMS$IGNORE BEGIN - write (*,'(i8,i4,a,2es11.2,f12.1)')ipn,k, & - ' (dffusn_lyr) flxdv,fac,fld=',flxdv(k,ipn),factor,fld(k,ipn) -!SMS$IGNORE END - end if - - end do ! loop through layers - end do ! horizontal loop - -!!!SMS$EXCHANGE(fld) -!SMS$PARALLEL END - - return - end subroutine dffusn_lyr -end module module_dffusn_lyr ! SMS doesn't like multiple routines in module diff --git a/src/fim/FIMsrc/fim/horizontal/diag.F90 b/src/fim/FIMsrc/fim/horizontal/diag.F90 deleted file mode 100644 index 25ce9a3..0000000 --- a/src/fim/FIMsrc/fim/horizontal/diag.F90 +++ /dev/null @@ -1,87 +0,0 @@ -module module_diag -contains -!********************************************************************* -! diag -! Diagnostic program after prognostic variables are calculated -! Alexander E. MacDonald 11/14/2005 -! J.Lee 01/04/2006 -!********************************************************************* - -subroutine diag(its, & - ph3d,us3d,vs3d, & ! phi (=g*z), west wind and south wind on s - ex3d,mp3d,dp3d, & ! pres,exner,mont pot,kin energy - tr,trdp ) ! specific humidity -use module_control ,only: nvl,nvlp1,nip,ptop,ntra,ntrb -use module_constants,only: p1000,cp,rd,qvmin,qwmin -implicit none - -! Dimension and type external varialbles: -integer,intent (IN) :: its -!SMS$DISTRIBUTE (dh,nip) BEGIN -real,intent (IN) :: us3d(nvl,nip) ! west wind -real,intent (IN) :: vs3d(nvl,nip) ! south wind -real,intent (INOUT) :: ph3d(nvlp1,nip) ! phi (=gz) -real,intent (IN) :: ex3d(nvlp1,nip) ! exner -real,intent (OUT) :: mp3d(nvl,nip) ! montgomery potential -real,intent (IN) :: dp3d(nvl,nip) ! specific humidity -real,intent (INOUT) :: tr (nvl,nip,ntra+ntrb) ! specific humidity -real,intent (INOUT) :: trdp(nvl,nip,ntra+ntrb) ! specific humidity -!SMS$DISTRIBUTE END - -! Declare local variables: -integer :: ipn ! Index for icos point number -integer :: ivl ! Index vertical level -real :: totp ! Total pressure summation variable -real :: temp1(nvl),temp2(nvl) - -! Note that tr (tracers), velocity, us3d,vs3d and montgomery potential, mp3d -! are all constant through the layers. Phi (ph3d) and pressure (dp3d) -! vary through the layer. - -! Layer variables: us3d,vs3d,tr (tracers),mp3d -! Level variables: ex3d,ph3d - -!SMS$PARALLEL (dh,ipn) BEGIN -!sms$compare_var(ex3d, "diag.F90 - ex3d5 ") -!sms$compare_var(ph3d, "diag.F90 - ph3d5 ") -do ipn=1,nip ! global icos loop - -!......................................................... -! Determine bottom layer values -!......................................................... - - mp3d(1,ipn)=ex3d(1,ipn)*tr(1,ipn,1) + ph3d(1,ipn) ! mp at surface - - do ivl=2,nvl ! vertical loop - - ! Hydrostatic eqn: d mp/d theta = exner - temp1(ivl)=ex3d(ivl,ipn)*(tr(ivl,ipn,1)-tr(ivl-1,ipn,1)) - - ! Hydrostatic eqn: d phi/d exner = - theta - temp2(ivl)=tr(ivl,ipn,1)*(ex3d(ivl,ipn)-ex3d(ivl-1,ipn)) - - enddo ! vertical loop - do ivl=2,nvl ! vertical loop - - ! Hydrostatic eqn: d mp/d theta = exner - mp3d(ivl,ipn)=mp3d(ivl-1,ipn)+temp1(ivl) - - ! Hydrostatic eqn: d phi/d exner = - theta - ph3d(ivl,ipn)=ph3d(ivl-1,ipn)-temp2(ivl) - - enddo ! vertical loop - - do ivl=1,nvl - tr(ivl,ipn,2)=max(qvmin,tr(ivl,ipn,2)) - trdp(ivl,ipn,2)=tr(ivl,ipn,2)*dp3d(ivl,ipn) - tr(ivl,ipn,3)=max(qwmin,tr(ivl,ipn,3)) - trdp(ivl,ipn,3)=tr(ivl,ipn,3)*dp3d(ivl,ipn) - end do - -enddo ! horizontal loop - -!SMS$PARALLEL END - -return -end subroutine diag -end module module_diag diff --git a/src/fim/FIMsrc/fim/horizontal/diagnoise.F90 b/src/fim/FIMsrc/fim/horizontal/diagnoise.F90 deleted file mode 100644 index 8307833..0000000 --- a/src/fim/FIMsrc/fim/horizontal/diagnoise.F90 +++ /dev/null @@ -1,108 +0,0 @@ -module module_diagnoise -use findmaxmin1 -contains -!********************************************************************* -! diagnoise -! A routine to diagnose external gravity wave noise in FIM -! (expressed as rms of 2nd time derivative of surface pressure) -! R. Bleck July 2006 -!********************************************************************* - -subroutine diagnoise & -(its, & ! model time step -ptdcy ) ! sfc.pres. tendency at 2 consec. time levels - -use module_control,only: nvl,nip -implicit none - -! Dimension and type external variables: -integer,intent (IN) :: its ! model time step -!SMS$DISTRIBUTE(dh,NIP) BEGIN -real, intent (IN) :: ptdcy (nip,2) ! d(surf.prs.)/dt - -! Local variables: -real :: work(nip) -!SMS$DISTRIBUTE END -real :: deriv2 ! rms of 2nd derivative of surface pressure -real :: derivma ! mean abs of 2nd derivative of surface pressure -real :: scale = 5. ! arbitrary scale for plotting noise parameter -integer :: ivl ! layer index -integer :: ipn ! index for icosahedral grid -real :: valmin,valmax - -if (its.lt.2) return - -deriv2=0. -derivma=0. - -!SMS$PARALLEL (dh,ipn) BEGIN - -do ipn=1,nip - deriv2=deriv2+(ptdcy(ipn,1)-ptdcy(ipn,2))**2 - derivma=derivma+abs(ptdcy(ipn,1)-ptdcy(ipn,2)) -end do -!sms$reduce(deriv2,derivma,SUM) - -!SMS$PARALLEL END - -! --- plot time series of noise index in stdout -! --- (type 'grep =+= stdout' to display the time series) -deriv2=sqrt(deriv2/nip) -derivma=(derivma/nip) -call linout(scale * deriv2,'x',its) -write (6,*)'rms-d(psfc)**2/d**2t) =',its,deriv2 -write (6,*)'deriv-mean abs =',its,derivma - -!! valmin=minval(ptdcy(:,1)) -!! valmax=maxval(ptdcy(:,1)) -!! !SMS$REDUCE(valmin,min) -!! !SMS$REDUCE(valmax,max) -!! print *,'min/max of ptdcy(:,1):',valmin,valmax -!! -!! valmin=minval(ptdcy(:,2)) -!! valmax=maxval(ptdcy(:,2)) -!! !SMS$REDUCE(valmin,min) -!! !SMS$REDUCE(valmax,max) -!! print *,'min/max of ptdcy(:,2):',valmin,valmax - -work(:)=ptdcy(:,1) -call findmxmn1(work,nip,'ptdcy(:,1)') -work(:)=ptdcy(:,2) -call findmxmn1(work,nip,'ptdcy(:,2)') - -return -end subroutine diagnoise - - -subroutine linout(value,char,labl) -! -! --- print single characters in a manner mimicking a curve plot in x,y space -! --- abscissa: down the page; ordinate: across the page -! -implicit none -real,intent(IN) :: value -character*1,intent(IN) :: char -integer,intent(IN) :: labl - -integer,parameter :: length=72 -character*1 line(length) -integer l,n - -! --- replace n-th element of array 'line' by character 'char', where -! --- n = 'value' modulo 'length' -! --- initialize 'line' by blanks before adding 'char' -! --- output 'line' after adding 'char' -! --- labl -- abscissa value (integer), added to output line -! -do l=1,length - line(l)=' ' -end do -if (value.gt.0.) then - n=int(mod(value+float(length-1),float(length)))+1 - line(n)=char -end if -write (*,'(''=+='',i6,80a1)') labl,(line(l),l=1,length) -return -end subroutine linout - -end module module_diagnoise diff --git a/src/fim/FIMsrc/fim/horizontal/digifilt.F90 b/src/fim/FIMsrc/fim/horizontal/digifilt.F90 deleted file mode 100644 index 48e2c51..0000000 --- a/src/fim/FIMsrc/fim/horizontal/digifilt.F90 +++ /dev/null @@ -1,248 +0,0 @@ -module module_digifilt -implicit none -contains - -subroutine digifilt_wts(wts,nwts) -! compute wts for digital filter. -! the type of window is controlled by the -! wts_type namelist parameter. -! if wts_type=1, use Lanczos window. -! if wts_type=2, use Hamming window. -! if wts_type=3, use Dolph window. -! the half-width of the filter window is controlled by the -! tfiltwin namelist parameter (units are seconds). -! on input, wts is an unallocated allocatable array. -! on return, wts(nwts) contains the filter weights -! (normalized so the sum=1). -use module_constants, only : pi -use module_control, only : & -dt,numphr,PhysicsInterval,RadiationInterval,tfiltwin,wts_type - -implicit none -real, intent(out), allocatable, dimension(:) :: wts -real, allocatable, dimension(:) :: wttmp -integer, intent(out) :: nwts -integer k,kk,CallPhysics,mm -real sx,hk,sumwts - -nwts = numphr*tfiltwin/3600 ! truncated to nearest model time step. -mm = nwts+1 ! index of filter midpoint. -nwts = 2*nwts+1 ! total number of weights - -CallPhysics = max(1,numphr*PhysicsInterval/3600) -! check to see that middle of filter window is on physics time step. -!SMS$SERIAL BEGIN -print *,nwts,'digital filter weights' -print *,'middle of filter window at t = ',mm*dt/3600.,' hours' -if (mod(mm,CallPhysics) .ne. 0) then - print *,'warning: middle of digital filter window not on a physics time step' -end if -!SMS$SERIAL END - -! setup up digital filter weights -allocate(wts(nwts)) -allocate(wttmp(0:mm-1)) -if (wts_type .eq. 1) then -!SMS$SERIAL BEGIN - print *,'Lanczos window for digital filter' -!SMS$SERIAL END - call lanczos(mm-1,wttmp) -else if (wts_type .eq. 2) then -!SMS$SERIAL BEGIN - print *,'Hamming window for digital filter' -!SMS$SERIAL END - call hamming(mm-1,wttmp) -else if (wts_type .eq. 3) then -!SMS$SERIAL BEGIN - print *,'Dolph window for digital filter' -!SMS$SERIAL END - call dolphwin(mm-1,wttmp) -else -!SMS$SERIAL BEGIN - print *,'Fatal error: illegal wts_type in digifilt_wts' -!SMS$SERIAL END - stop -end if -wttmp(mm-1)=0. - -sumwts = 0. -do k=1,nwts - kk = k-mm - sx = pi*real(kk)/real(mm-1) - if (kk .ne. 0) then - hk = sin(sx)/(pi*real(kk)) ! hk --> 1./(mm-1) as sx --> 0 - else - hk = 1./real(mm-1) - end if - if (k .le. mm) then - wts(k) = wttmp(mm-k)*hk - else - wts(k) = wts(2*mm-k) - end if - sumwts = sumwts + wts(k) -end do -deallocate(wttmp) -wts = wts/sumwts ! normalize weights so sum=1 - -!SMS$SERIAL BEGIN -do k=1,nwts - print *,'filter wt',k,wts(k) -end do -!SMS$SERIAL END - -end subroutine digifilt_wts - - SUBROUTINE dolphwin(m, window) - -! calculation of dolph-chebyshev window or, for short, -! dolph window, using the expression in the reference: -! -! antoniou, andreas, 1993: digital filters: analysis, -! design and applications. mcgraw-hill, inc., 689pp. -! -! the dolph window is optimal in the following sense: -! for a given main-lobe width, the stop-band attenuation -! is minimal; for a given stop-band level, the main-lobe -! width is minimal. -! -! it is possible to specify either the ripple-ratio r -! or the stop-band edge thetas. - - IMPLICIT NONE - - ! Arguments - INTEGER, INTENT(IN) :: m - REAL, DIMENSION(0:M), INTENT(OUT) :: window - - ! local data - REAL, DIMENSION(0:2*M) :: t - REAL, DIMENSION(0:M) :: w, time - REAL :: pi, thetas, x0, term1, term2, rr, r, db, sum, arg - INTEGER :: n, nm1, nt, i - - PI = 4*ATAN(1.D0) - THETAS = 2*PI/M - - N = 2*M+1 - NM1 = N-1 - X0 = 1/COS(THETAS/2) - - TERM1 = (X0 + SQRT(X0**2-1))**(FLOAT(N-1)) - TERM2 = (X0 - SQRT(X0**2-1))**(FLOAT(N-1)) - RR = 0.5*(TERM1+TERM2) - R = 1/RR - DB = 20*LOG10(R) - WRITE(*,'(1X,''DOLPH: M,N='',2I8)')M,N - WRITE(*,'(1X,''DOLPH: THETAS (STOP-BAND EDGE)='',F10.3)')THETAS - WRITE(*,'(1X,''DOLPH: R,DB='',2F10.3)')R, DB - - DO NT=0,M - SUM = RR - DO I=1,M - ARG = X0*COS(I*PI/N) - CALL CHEBY(T,NM1,ARG) - TERM1 = T(NM1) - TERM2 = COS(2*NT*PI*I/N) - SUM = SUM + 2*TERM1*TERM2 - ENDDO - W(NT) = SUM/N - TIME(NT) = NT - ENDDO - -! fill up the array for return - DO NT=0,M - WINDOW(NT) = W(NT) - ENDDO - - RETURN - - END SUBROUTINE dolphwin - - SUBROUTINE cheby(t, n, x) - -! calculate all chebyshev polynomials up to order n -! for the argument value x. - -! reference: numerical recipes, page 184, recurrence -! t_n(x) = 2xt_{n-1}(x) - t_{n-2}(x) , n>=2. - - IMPLICIT NONE - - ! Arguments - INTEGER, INTENT(IN) :: n - REAL, INTENT(IN) :: x - REAL, DIMENSION(0:N) :: t - - integer :: nn - - T(0) = 1 - T(1) = X - IF(N.LT.2) RETURN - DO NN=2,N - T(NN) = 2*X*T(NN-1) - T(NN-2) - ENDDO - - RETURN - - END SUBROUTINE cheby - - SUBROUTINE LANCZOS(NSTEPS,WW) - - ! define (genaralised) lanczos window function. - - implicit none - - integer, parameter :: nmax = 1000 - integer, intent(in) :: nsteps - real , dimension(0:nmax), intent(out) :: ww - integer :: n - real :: power, pi, w - - ! (for the usual lanczos window, power = 1 ) - POWER = 1 - - PI=4*ATAN(1.) - DO N=0,NSTEPS - IF ( N .EQ. 0 ) THEN - W = 1.0 - ELSE - W = SIN(N*PI/(NSTEPS+1)) / ( N*PI/(NSTEPS+1)) - ENDIF - WW(N) = W**POWER - ENDDO - - RETURN - - END SUBROUTINE lanczos - - - SUBROUTINE HAMMING(NSTEPS,WW) - - ! define (genaralised) hamming window function. - - implicit none - - integer, intent(in) :: nsteps - real, dimension(0:nsteps) :: ww - integer :: n - real :: alpha, pi, w - - ! (for the usual hamming window, alpha=0.54, - ! for the hann window, alpha=0.50). - ALPHA=0.54 - - PI=4*ATAN(1.) - DO N=0,NSTEPS - IF ( N .EQ. 0 ) THEN - W = 1.0 - ELSE - W = ALPHA + (1-ALPHA)*COS(N*PI/(NSTEPS)) - ENDIF - WW(N) = W - ENDDO - - RETURN - - END SUBROUTINE hamming - -end module module_digifilt diff --git a/src/fim/FIMsrc/fim/horizontal/dissip.F90 b/src/fim/FIMsrc/fim/horizontal/dissip.F90 deleted file mode 100644 index 2c820bd..0000000 --- a/src/fim/FIMsrc/fim/horizontal/dissip.F90 +++ /dev/null @@ -1,153 +0,0 @@ -module module_dissip -use findmaxmin2 -use stencilprint -contains - -!********************************************************************* -! dissip -! Lateral momentum dissipation -! R.Bleck September 2011 -!********************************************************************* - - subroutine dissip (u_vel, v_vel, delp, dfflen, biharm) - use module_control ,only: npp,nip,nvl,nvlp1,PrintIpnDiag - use module_constants,only: nprox,prox,rarea,sideln,rprox_ln, & - deg_lat,cs,sn,actual,nedge,permedge - implicit none -! External type and dimension: - -! --- 'diffusion length' dfflen = (diffusivity) * (time step) / (mesh size) -! --- = (diffusion velocity) x (time step) - - real ,intent (IN) :: dfflen(nvl) ! diffusion length scale (m) - logical,intent (IN), optional :: biharm ! if yes, do biharmonic smoothg -!SMS$DISTRIBUTE (dh,nip) BEGIN - real ,intent (INOUT) :: u_vel (nvl,nip) ! field to be diffused - real ,intent (INOUT) :: v_vel (nvl,nip) ! field to be diffused - real ,intent (IN) :: delp (nvl,nip) ! lyr thknss, Pa - -! Local variables: - real :: ufxrot(nvl,npp,nip) ! u momentum flux across edges - real :: vfxrot(nvl,npp,nip) ! v momentum flux across edges -!SMS$DISTRIBUTE END - -! Local variables - integer :: k ! layer index - integer :: ipn ! icos point index - integer :: ipx ! neighbor across joint edge - integer :: edg,edgcount ! icos edge index - real :: factor - real :: uxy1,uxy2,vxy1,vxy2 - real :: uflux,vflux,uold,vold - character :: string*5 - logical :: vrbos - real,parameter :: thshld = 1.e-11 - real :: hfharm,a,b ! 0.5 * harmonic average - hfharm(a,b) = a*b/(a+b) ! (see Appx.D, 1992 MICOM paper) - -! print '(a/(10f8.1))','entering subr.dissip with dfflen =',dfflen - - if (maxval(dfflen).eq.0.) return - - call stencl(u_vel,nvl,1.,'(dissip) -u- input') - call stencl(v_vel,nvl,1.,'(dissip) -v- input') - -! do k=1,nvl,7 -! write (string,'(a,i3)') 'k=',k -! call findmxmn2(u_vel,nvl,nip,k,'(dissip) u-in '//string) -! call findmxmn2(v_vel,nvl,nip,k,'(dissip) v-in '//string) -! end do - -!SMS$PARALLEL (dh,ipn) BEGIN -!SMS$EXCHANGE(delp,u_vel,v_vel) - -!SMS$HALO_COMP(<1,1>) BEGIN - do ipn = 1,nip ! horizontal loop - vrbos=ipn.eq.PrintIpnDiag - do edgcount = 1,nedge(ipn) ! loop through edges - edg = permedge(edgcount,ipn) - ipx = prox(edg,ipn) ! neighbor across shared edge - do k = 1,nvl ! loop through layers - if (dfflen(k).gt.0.) then - -! --- Transform u,v at neighboring icos pt to local coord.system. -! --- cs and sn are coordinate transformation constants. -! --- uxy,vxy are values of u and v rotated into local system. - - uxy1= cs(1,edg,ipn)*u_vel(k,ipn)+sn(1,edg,ipn)*v_vel(k,ipn) - vxy1=-sn(1,edg,ipn)*u_vel(k,ipn)+cs(1,edg,ipn)*v_vel(k,ipn) - uxy2= cs(2,edg,ipn)*u_vel(k,ipx)+sn(2,edg,ipn)*v_vel(k,ipx) - vxy2=-sn(2,edg,ipn)*u_vel(k,ipx)+cs(2,edg,ipn)*v_vel(k,ipx) - -! --- momentum fluxes (pos.inward) in local (rotated) coord.system: - ufxrot(k,edg,ipn) = (uxy2-uxy1)*dfflen(k ) & - *sideln(edg,ipn)*2.*hfharm(max(delp(k,ipn),thshld) & - ,max(delp(k,ipx),thshld)) - vfxrot(k,edg,ipn) = (vxy2-vxy1)*dfflen(k) & - *sideln(edg,ipn)*2.*hfharm(max(delp(k,ipn),thshld) & - ,max(delp(k,ipx),thshld)) - - if (vrbos .and. mod(k,7).eq.1) then -!SMS$IGNORE BEGIN - print 101,'orig u,v at',ipn,actual(ipx),k,edg, & - u_vel(k,ipn),v_vel(k,ipn),u_vel(k,ipx),v_vel(k,ipx) - print 101,' rot u,v at',ipn,actual(ipx),k,edg, & - uxy1,vxy1,uxy2,vxy2 - 101 format ('(dissip) ',a,2i7,2i3,3(f10.2,f8.2)) - factor=rarea(ipn)/max(delp(k,ipn),thshld) - print 102,' u/vflx in rotated system',ipn, & - actual(ipx),k,edg,ufxrot(k,edg,ipn)*factor, & - vfxrot(k,edg,ipn)*factor - 102 format ('(dissip) ',a,2i7,2i3,2f7.2) -!SMS$IGNORE END - end if - - end if ! dfflen > 0 - end do ! loop through layers - end do ! loop through edges - end do ! horizontal loop -!SMS$HALO_COMP END - - do ipn = 1,nip ! horizontal loop - vrbos=ipn.eq.PrintIpnDiag - do edg = 1,nprox(ipn) - ipx = prox(edg,ipn) ! neighbor across shared edge - do k = 1,nvl ! loop through layers - if (dfflen(k).gt.0.) then - factor=rarea(ipn)/max(delp(k,ipn),thshld) -! --- rotate momentum fluxes back to lat/lon coord.system - uflux= cs(1,edg,ipn)*ufxrot(k,edg,ipn)-sn(1,edg,ipn)*vfxrot(k,edg,ipn) - vflux= sn(1,edg,ipn)*ufxrot(k,edg,ipn)+cs(1,edg,ipn)*vfxrot(k,edg,ipn) - uold=u_vel(k,ipn) - vold=v_vel(k,ipn) - u_vel(k,ipn)=u_vel(k,ipn)+uflux*factor - v_vel(k,ipn)=v_vel(k,ipn)+vflux*factor - - if (vrbos .and. mod(k,7).eq.1) then -!SMS$IGNORE BEGIN - print 102,'u/vflx in lat/lon system',ipn, & - actual(ipx),k,edg,uflux*factor,vflux*factor - print 101,'old/new u,v',ipn,actual(ipx),k,edg, & - uold,vold,u_vel(k,ipn),v_vel(k,ipn) -!SMS$IGNORE END - end if - - end if ! dfflen > 0 - end do ! loop through layers - end do ! loop through edges - end do ! horizontal loop - -!SMS$PARALLEL END - - call stencl(u_vel,nvl,1.,'(dissip) -u- output') - call stencl(v_vel,nvl,1.,'(dissip) -v- output') - -! do k=1,nvl,7 -! write (string,'(a,i3)') 'k=',k -! call findmxmn2(u_vel,nvl,nip,k,'(dissip) u-out '//string) -! call findmxmn2(v_vel,nvl,nip,k,'(dissip) v-out '//string) -! end do - - return - end subroutine dissip -end module module_dissip diff --git a/src/fim/FIMsrc/fim/horizontal/do_physics_one_step.F90 b/src/fim/FIMsrc/fim/horizontal/do_physics_one_step.F90 deleted file mode 100644 index c992f5b..0000000 --- a/src/fim/FIMsrc/fim/horizontal/do_physics_one_step.F90 +++ /dev/null @@ -1,757 +0,0 @@ -module module_do_physics_one_step - -!********************************************************************* -! do_physics_one_step -! Calculates column forcing for global fim -! 12/21/2005 - Alexander E. MacDonald - original version -! 05/01/2006 - Jian-Wen Bao - modified for GFS physics -! 04/14/2008 - Stan Benjamin, John Brown - modifications -! for introduction of virtual pot temp for temp prog -! variable instead of previous non-virtual pot temp -! 02/26/2009 - Tom Henderson - moved here from physics.F90 to more -! closely match new GFS r3038 -! 07/21/2009 - Jian-wen Bao - change to random number generator -! for xkt2 (cloud-top height) instead of previous 0.6 constant -! This follows NCEP's use of this random number generator -! (Mersenne twister) and appears to qualitatively improve -! forecasts in tropics. -!********************************************************************* - -contains - -subroutine do_physics_one_step(dtp, kdt, phour, & - gfs_ps, gfs_dp, gfs_dpdt, gfs_p, gfs_u, gfs_v, & - gfs_t, gfs_q, gfs_oz, gfs_cld, & - sfc_fld, flx_fld, & - XLON,XLAT,COSZDG, & - HPRIME, SWH, HLW, FLUXR, SFALB, SLAG, SDEC, CDEC, & - phy_f3d, phy_f2d, NBLCK, & - CLDCOV, & - nvl, LATS_NODE_R, NMTVR, num_p3d, num_p2d, NFXR, & - nip, lsoil, GravityWaveDrag, CallRadiation, & - yyyymmddhhmm,inv_perm,skip_cu_physics, & - skip_mp_physics,skip_chem,ipn,sscal,ext_cof,asymp, & - extlw_cof) - -!SMS$IGNORE BEGIN -USE gfs_physics_sfc_flx_mod, ONLY: Sfc_Var_Data, Flx_Var_Data -use module_initial_chem_namelists,only:chem_opt -use layout1, only: me -!SMS$IGNORE END - -USE MACHINE , ONLY : kind_phys,kind_rad,kind_evod -USE resol_def , ONLY : levs,levp1 -USE module_variables, ONLY:diaga,diagb,u_tdcy_phy,v_tdcy_phy,trc_tdcy_phy -USE module_wrf_variables, ONLY:phys3dwrf,phys2dwrf -!SMS$IGNORE BEGIN -USE mersenne_twister -!SMS$IGNORE END -use module_do_physics_one_step_chem,only:do_physics_one_step_chem - -implicit none - -! Dimension and type external variables: - -real (kind=kind_phys), intent(in ) :: dtp -integer , intent(in ) :: kdt -real (kind=kind_rad) , intent(in ) :: phour -!SMS$DISTRIBUTE (dh,nip) BEGIN -real (kind=kind_evod), intent(in ) :: gfs_ps(nip) -real (kind=kind_evod), intent(in ) :: gfs_dp(nip,nvl) -real (kind=kind_evod), intent(in ) :: gfs_dpdt(nip,nvl) -real (kind=kind_evod), intent(in ) :: gfs_p(nip,nvl) -real (kind=kind_evod), intent(inout) :: gfs_u(nip,nvl) -real (kind=kind_evod), intent(inout) :: gfs_v(nip,nvl) -real (kind=kind_evod), intent(inout) :: gfs_t(nip,nvl) -real (kind=kind_evod), intent(inout) :: gfs_q(nip,nvl) -real (kind=kind_evod), intent(inout) :: gfs_oz(nip,nvl) -real (kind=kind_evod), intent(inout) :: gfs_cld(nip,nvl) - -real*8 temp_ps(nip) -real*8 temp_dp(nip,nvl) -real*8 temp_dpdt(nip,nvl) -real*8 temp_p(nip,nvl) -real*8 temp_u(nip,nvl) -real*8 temp_v(nip,nvl) -real*8 temp_t(nip,nvl) -real*8 temp_q(nip,nvl) -real*8 temp_oz(nip,nvl) -real*8 temp_cld(nip,nvl) -!SMS$DISTRIBUTE END -TYPE(Sfc_Var_Data) , intent(inout) :: sfc_fld -TYPE(Flx_Var_Data) , intent(inout) :: flx_fld -!SMS$DISTRIBUTE (dh,nip) BEGIN -real (kind=kind_rad) , intent(in ) :: XLON(nip,LATS_NODE_R) -real (kind=kind_rad) , intent(in ) :: XLAT(nip,LATS_NODE_R) -!TODO: check intents between here and phy_f2d -real (kind=kind_rad) , intent(inout) :: COSZDG(nip,LATS_NODE_R) -real (kind=kind_rad) , intent(inout) :: HPRIME(NMTVR,nip,LATS_NODE_R) -real (kind=kind_rad) , intent(inout) :: SWH(nip,nvl,NBLCK,LATS_NODE_R) -real (kind=kind_rad) , intent(inout) :: HLW(nip,nvl,NBLCK,LATS_NODE_R) -real (kind=kind_rad) , intent(inout) :: FLUXR(NFXR,nip,LATS_NODE_R) -real (kind=kind_rad) , intent(inout) :: SFALB(nip,LATS_NODE_R) -real (kind=kind_evod), intent(inout) :: SLAG(nip,LATS_NODE_R) -real (kind=kind_evod), intent(inout) :: SDEC(nip,LATS_NODE_R) -real (kind=kind_evod), intent(inout) :: CDEC(nip,LATS_NODE_R) -real (kind=kind_rad) , intent(inout) :: phy_f3d(nip,nvl,NBLCK,LATS_NODE_R,num_p3d) -real (kind=kind_rad) , intent(inout) :: phy_f2d(nip,LATS_NODE_R,num_p2d) -integer , intent(in ) :: NBLCK -real (kind=kind_rad) , intent(inout) :: CLDCOV(nvl,nip,LATS_NODE_R) -!SMS$DISTRIBUTE END -integer , intent(in ) :: nvl -integer , intent(in ) :: LATS_NODE_R -integer , intent(in ) :: NMTVR -integer , intent(in ) :: num_p3d -integer , intent(in ) :: num_p2d -integer , intent(in ) :: NFXR -integer , intent(in ) :: nip -integer , intent(in ) :: lsoil -logical , intent(in ) :: GravityWaveDrag -integer , intent(in ) :: CallRadiation -CHARACTER(len=12) , intent(in ) :: yyyymmddhhmm -logical , intent(in ) :: skip_cu_physics,skip_mp_physics,skip_chem -integer , intent(inout) :: ipn -!sms$distribute (dh,2) begin -real,intent(inout)::sscal(:,:,:),ext_cof(:,:,:),asymp(:,:,:),extlw_cof(:,:,:) -!sms$distribute end - -! Local variables -!---------------------------------------------------------------------- -! - -!Parameters and arrays used in the GFS physics -!---------------------------------------------------------------------- -! TODO: move ntrac and nrcm to module resol_def -integer IM, IX, ntrac, nrcm -parameter (IM = 1, IX = 1) -parameter (ntrac = 3, nrcm = 1) -integer ncld,ntoz,ntcw,lonf,latg, jcap,nlons(im) -parameter (ntcw = 3) - -integer levshc(im), levshcm ! Needed for pry version -LOGICAL lssav,lsfwd - -real(kind=kind_phys) dtf,FHOUR,solhr, prsshc,cubot,cutop - -real(kind=kind_phys) UG (IX,NVL) , VG (IX,NVL) , & - TG (IX,NVL) , qg (IX,nvl,ntrac), & - qg1 (IX,nvl,2) , & - GT0 (IX,NVL) , GU0 (IX,NVL) , & - GV0 (IX,NVL) , gq0 (IX,nvl,ntrac), & - DEL (IX,NVL) , PRSI (IX,NVL+1) , & - PRSL (IX,NVL) , PRSLK(IX,NVL) , & - PRSIK(IX,NVL+1), PHII (IX,NVL+1) , & - PHIL (IX,NVL) , dkt (im,NVL-1) , & - PGR(IM) , XKT2(IM,nrcm) - -! TBH: These arrays are used to avoid recomputation of values -! TBH: between calls to GLOOPR and GBPHYS. -real(kind=kind_phys) PRSL_S(IX,NVL), PRSI_S(IX,NVL+1) - -! Constants -real(kind=kind_phys) RCS2(IM),clstp - -! Local variables -real(kind=kind_phys) SINLAT(IM), COSLAT(IM) - -real(kind=kind_phys) acv(IM), acvb(IM), acvt(IM) - -!TODO: Move these to new module d3d_def and (maybe) use d3d_zero to set -real(kind=kind_rad) dt3dt(IX,nvl,6), dq3dt(IX,nvl,7), & - du3dt(IX,nvl,4), dv3dt(IX,nvl,4) - -logical, save :: nsst_active=.false. -logical, save :: lggfs3d=.false. -logical old_monin, cnvgwd -logical sashal,newsas,mom4ice,mstrat,trans_trac,cal_pre -integer KO3,pl_coeff,ncw(2),lsm,lat -logical, save :: lssav_cc_dummy=.false. -PARAMETER (KO3=46,pl_coeff=2) !ozone levels in climatology -real(kind=kind_phys) sdiaga(im,nvl),sdiagb(im,nvl) -real(kind=kind_phys) poz(KO3), prdout(IX,ko3,pl_coeff), disout(IX,ko3) -real(kind=kind_phys) flgmin(2), ccwf, ctei_rm,suntim(im),SNCOVR(IM) & - ,SPFHMIN(IM),SPFHMAX(IM) -real(kind=kind_phys) ifd(im),time_old(im),time_ins(im),I_Sw(im), & - I_Q(im),I_Qrain(im),I_M(im),I_Tau(im), & - I_Sw_Zw(im),I_Q_Ts(im),I_M_Ts(im),Tref(im), & - dt_cool(im),z_c(im),dt_warm(im),z_w(im), & - c_0(im),c_d(im),w_0(im),w_d(im), dpshc(IM), crtrh(3), & - CHH(IM),CMM(IM),PI(IM),DLWSFCI(IM),ULWSFCI(IM),USWSFCI(IM), & - DSWSFCI(IM),DTSFCI(IM),DQSFCI(IM),GFLUXI(IM),SRUNOFF(IM),T1(IM), & - Q1(IM),U1(IM),V1(IM),ZLVL(IM), TISFC(IM), & - EVBSA(IM),EVCWA(IM),TRANSA(IM),SBSNOA(IM),SNOWCA(IM),SOILM(IM), & -! jbao new gfs phys - SNOHFA(IM),SMCWLT2(IM),SMCREF2(IM), & - gsoil(im), gtmp2m(im), gustar(im), gpblh(im), gu10m(im), & - gv10m(im), gzorl(im), goro(im), dkh(IX,nvl), rnp(ix,nvl), & - upd_mf(ix,nvl), dwn_mf(ix,nvl), det_mf(ix,nvl), oro(im) - real(kind=kind_phys),dimension(IM):: DLWSFC_cc_dummy,ULWSFC_cc_dummy,SWSFC_cc_dummy,XMU_cc_dummy, & - DLW_cc_dummy,DSW_cc_dummy,SNW_cc_dummy,LPREC_cc_dummy, & - DUSFC_cc_dummy,DVSFC_cc_dummy,DTSFC_cc_dummy,DQSFC_cc_dummy, & - PRECR_cc_dummy - -logical RAS,LDIAG3D,pre_rad -logical flipv - -integer :: ivl ! Index for vertical level -integer :: global_lats_r(1),lonsperlar(1) !JFM -INTEGER hour -logical :: CallRadiationNow -real(kind=kind_phys), parameter :: cons_1p0d9=1.0E9 -integer iseed -real :: wrk(1) -type(random_stat), allocatable, save :: rstat(:) -!SMS$DISTRIBUTE (dh,nip) BEGIN -integer :: inv_perm(nip) -integer :: seed0 (nip) -real(kind=kind_phys) :: rannum (nip) -!SMS$DISTRIBUTE END -INTEGER year,month,day -logical, save :: first_rand=.TRUE. - - integer ipnGlobal,its,mype - logical DiagPrint - -real(kind=kind_rad),allocatable::sscal_rad(:,:) -real(kind=kind_rad),allocatable::asymp_rad(:,:) -real(kind=kind_rad),allocatable::ext_cof_rad(:,:) -real(kind=kind_rad),allocatable::extlw_cof_rad(:,:) - -!print *,'DEBUG do_physics_one_step(): SIZE(pb2d) = ',SIZE(pb2d) -LEVS = nvl !JFM -levp1 = levs+1 !JFM -global_lats_r(1) = 1 !JFM -lonsperlar (1) = 1 !JFM - -CallRadiationNow = (mod(kdt,CallRadiation) == 0 .or. kdt == 1) - -READ(UNIT=yyyymmddhhmm(9:10), FMT='(I2)') hour - -me = 0 -!SMS$insert call nnt_me(me) -dtf = dtp -if (first_rand) then - ! set up seeds for each column, first time only - ALLOCATE( rstat(LBOUND(rannum,1):UBOUND(rannum,1)) ) - READ(UNIT=yyyymmddhhmm(1:4), FMT='(I4)') year - READ(UNIT=yyyymmddhhmm(5:6), FMT='(I2)') month - READ(UNIT=yyyymmddhhmm(7:8), FMT='(I2)') day -!NOTE: For large G-levels this serial could be a memory problem. -! The serial is used to match the random number to the lat-lon for different curves. -!SMS$SERIAL (, : default=ignore) BEGIN - do ipn=1,nip - seed0(inv_perm(ipn)) = year+month+day+hour+ipn - enddo -!SMS$SERIAL END -!SMS$PARALLEL (dh,ipn) BEGIN - do ipn=1,nip - call random_setseed(seed0(ipn),rstat(ipn)) - enddo - first_rand = .false. -endif -do ipn=1,nip - call random_number(wrk,rstat(ipn)) - rannum(ipn) = wrk(1) -enddo - -call flush(6) -!SMS$PARALLEL END - -allocate(sscal_rad(size(sscal,1),size(sscal,3))) -allocate(asymp_rad(size(asymp,1),size(asymp,3))) -allocate(ext_cof_rad(size(ext_cof,1),size(ext_cof,3))) -allocate(extlw_cof_rad(size(extlw_cof,1),size(extlw_cof,3))) - -!---------------------------------------------------------------------- -! Loop begins over all horizontal grid points -!---------------------------------------------------------------------- - -!SMS$PARALLEL (dh,ipn) BEGIN -do ivl=1,nvl - do ipn=1,nip - temp_ps(ipn) = gfs_ps(ipn) - temp_dp(ipn,ivl) = gfs_dp(ipn,ivl) - temp_dpdt(ipn,ivl) = gfs_dpdt(ipn,ivl) - temp_p(ipn,ivl) = gfs_p(ipn,ivl) - temp_u(ipn,ivl) = gfs_u(ipn,ivl) - temp_v(ipn,ivl) = gfs_v(ipn,ivl) - temp_t(ipn,ivl) = gfs_t(ipn,ivl) - temp_q(ipn,ivl) = gfs_q(ipn,ivl) - temp_oz(ipn,ivl) = gfs_oz(ipn,ivl) - temp_cld(ipn,ivl) = gfs_cld(ipn,ivl) - enddo -enddo - -!sms$compare_var(temp_ps, "do_physics.F90 - gfs_ps0 ") -!sms$compare_var(temp_dp, "do_physics.F90 - gfs_dp0 ") -!sms$compare_var(temp_dpdt, "do_physics.F90 - gfs_dpdt0 ") -!sms$compare_var(temp_p, "do_physics.F90 - gfs_p0 ") -!sms$compare_var(temp_oz, "do_physics.F90 - gfs_oz0 ") -!sms$compare_var(temp_cld, "do_physics.F90 - gfs_cld0 ") -!sms$compare_var(temp_u, "do_physics.F90 - gfs_u0 ") -!sms$compare_var(temp_v, "do_physics.F90 - gfs_v0 ") -!sms$compare_var(temp_t, "do_physics.F90 - gfs_t0 ") -!sms$compare_var(temp_q, "do_physics.F90 - gfs_q0 ") - -if(CallRadiationNow) then ! Call radiation - FLUXR=0.0 -endif - -do ipn=1,nip - PRSI_S(1,1) = gfs_ps(ipn) - do ivl=1,nvl - PRSI_S(1,ivl+1) = PRSI_S(1,ivl) - gfs_dp(ipn,ivl) - enddo - do ivl=1,nvl - PRSL_S (1,ivl) = 0.5*(PRSI_S(1,ivl)+PRSI_S(1,ivl+1)) - enddo - - do ivl=1,nvl - !TODO: can this copy be avoided, eliminating tg? - tg (1,ivl) = gfs_t(ipn,ivl) -!jbao PRSLK (1,ivl) = theta_nv(ipn,ivl) /tg(1,ivl) -!jbao PRSLK (1,ivl) = 1./PRSLK(1,ivl) - !TODO: can these copies be avoided, eliminating qg? - qg (1,ivl,1) = gfs_q(ipn,ivl) - qg (1,ivl,2) = gfs_oz(ipn,ivl) - qg (1,ivl,3) = gfs_cld(ipn,ivl) - enddo - - ! - ! Copy data from FIM arrays to set up for GBPHYS call (below) - ! - do ivl=1,nvl - !TODO: can this copy be avoided, eliminating ug and vg? - ug(1,ivl) = gfs_u(ipn,ivl) - vg(1,ivl) = gfs_v(ipn,ivl) - enddo - ncld = 1 - -!---------------------------------------------------------------------- - if(CallRadiationNow) then ! Call radiation -!---------------------------------------------------------------------- - do ivl=1,nvl - !TODO: can these copies be avoided, eliminating qg1? - qg1 (1,ivl,1) = gfs_oz(ipn,ivl) - qg1 (1,ivl,2) = gfs_cld(ipn,ivl) - PRSL (1,ivl) = PRSL_S(1,ivl) - enddo - do ivl=1,nvl+1 - PRSI (1,ivl) = PRSI_S(1,ivl) - enddo - TISFC = sfc_fld%TSEA(ipn,1) -! write(6,*)'before gloopr ipn ',ipn -! if (ipn.eq.8570) then -! write(6,*)'land point before gloopr' -! write(6,*)'flx_fld%SFCDLW(ipn,1),flx_fld%TSFLW(ipn,1)' -! write(6,*)flx_fld%SFCDLW(ipn,1),flx_fld%TSFLW(ipn,1) -! write(6,*)'flx_fld%SFCNSW(ipn,1),flx_fld%SFCDSW(ipn,1)' -! write(6,*)flx_fld%SFCNSW(ipn,1),flx_fld%SFCDSW(ipn,1) -! write(6,*)'SWH(ipn,:,1,1)' -! write(6,*)SWH(ipn,:,1,1) -! write(6,*)'HLW(ipn,:,1,1)' -! write(6,*)HLW(ipn,:,1,1) -! write(6,*)'qg(1,1,1),qg1(1,1,1)' -! write(6,*)qg(1,1,1),qg1(1,1,1) -! endif - - if (chem_opt.gt.0) then - sscal_rad=sscal(:,ipn,:) - asymp_rad=asymp(:,ipn,:) - ext_cof_rad=ext_cof(:,ipn,:) - extlw_cof_rad=extlw_cof(:,ipn,:) - else - sscal_rad=999. - endif - -!---------------------------------------------------------------------- -! Call GFS radiation (longwave and shortwave) -!---------------------------------------------------------------------- - CALL GLOOPR & - (ncld, & ! jbao ncld needs to passed into gloopr, add to new gloopr and declare - 1,global_lats_r, & - lonsperlar, & -!jbao not needed by fim 1.0D0,1.0D0,1.0D0,1.0D0, & -!jbao not needed by fim 1.0D0,1.0D0, & ! jbao new gfs, ndexev, ndexod not used now in new gfs -!jbao old gfs 1.0D0,1.0D0,1,1, ! jbao new gfs, ndexev, ndexod not used now in new gfs & -!jbao old gfs 1.0D0,1.0D0,1.0D0,1.0D0,1.0D0,1.0D0, & ! jbao newgfs doesn't need plnew_r, plnow_r -!jbao not needed by fim 1.0D0,1.0D0,1.0D0,1.0D0, & - phour, & ! jbao fcst hour - XLON(ipn,1),XLAT(ipn,1),COSZDG(ipn,1), & - flx_fld%COSZEN(ipn,1), & ! COSZEN is output and used in gbphys - sfc_fld%SLMSK(ipn,1), & - sfc_fld%SHELEG(ipn,1), & - sfc_fld%SNCOVR(ipn,1), & ! jbao new gfs needs sncovr - sfc_fld%SNOALB(ipn,1), & ! jbao new gfs nees snoalb - sfc_fld%ZORL(ipn,1), & - sfc_fld%TSEA(ipn,1), & -! jbao old gfs needs stc sfc_fld%STC(1,ipn,1),HPRIME(1,ipn,1), & - HPRIME(1,ipn,1), & - SFALB(ipn,1), & ! SFALB is set in gloopr but then set to 0 before call gbphys - sfc_fld%ALVSF(ipn,1), & - sfc_fld%ALNSF(ipn,1), & - sfc_fld%ALVWF(ipn,1), & - sfc_fld%ALNWF(ipn,1), & - sfc_fld%FACSF(ipn,1), & - sfc_fld%FACWF(ipn,1),sfc_fld%CV(ipn,1), & - sfc_fld%CVT(ipn,1), & - sfc_fld%CVB(ipn,1),SWH(ipn,:,1,1), & - HLW(ipn,:,1,1), & - flx_fld%SFCNSW(ipn,1), & - flx_fld%SFCDLW(ipn,1), & ! SWH,HLW,SFCNSW,SFCDLW output and used in gbphys - sfc_fld%FICE(ipn,1) , & - TISFC, & ! jbao new gfs needs tisfc - flx_fld%SFCDSW(ipn,1), & ! FOR SEA-ICE - XW Nov04, SFCDSW output and used in gbphys - flx_fld%TSFLW(ipn,1),FLUXR(:,ipn,1), & ! jbao new gfs does not need cldcov - phy_f3d(ipn,:,1,1,:),SLAG(ipn,1) ,SDEC(ipn,1), & ! jbao new gfs needs phy_f3d - CDEC(ipn,1),1,KDT, & - 0.0D0, prsl(1,1),prsi(1,1),prslk(1,1),tg(1,1), & - qg(1,1,1),qg1(1,1,1),sscal_rad, & - asymp_rad,ext_cof_rad,extlw_cof_rad,yyyymmddhhmm) - -! sscal(:,ipn,:)=sscal_rad -! asymp(:,ipn,:)=asymp_rad -! ext_cof(:,ipn,:)=ext_cof_rad - - endif - - if (ipn.eq.8570) then -! write(6,*)'land point after gloopr' -! write(6,*)'flx_fld%SFCDLW(ipn,1),flx_fld%TSFLW(ipn,1)' -! write(6,*)flx_fld%SFCDLW(ipn,1),flx_fld%TSFLW(ipn,1) -! write(6,*)'flx_fld%SFCNSW(ipn,1),flx_fld%SFCDSW(ipn,1)' -! write(6,*)flx_fld%SFCNSW(ipn,1),flx_fld%SFCDSW(ipn,1) -! write(6,*)'SWH(ipn,:,1,1)' -! write(6,*)SWH(ipn,:,1,1) -! write(6,*)'HLW(ipn,:,1,1)' -! write(6,*)HLW(ipn,:,1,1) -! write(6,*)'qg(1,1,1),qg1(1,1,1)' -! write(6,*)qg(1,1,1),qg1(1,1,1) - endif - - ! - ! Local set up for GBPHYS - ! - do ivl=1,nvl - PRSL(1,ivl) = PRSL_S(1,ivl) - enddo - do ivl=1,nvl+1 - PRSI(1,ivl) = PRSI_S(1,ivl) - enddo - PGR = PRSI_S(1,1) -!jbao prsik (1,1) = PRSLK(1,1) -!jbao prsik (1,nvl+1) = PRSLK(1,nvl) -!jbao do ivl=2,nvl -!jbao prsik (1,ivl) = 0.5*(PRSLK(1,ivl)+PRSLK(1,ivl-1)) -!jbao enddo - - ntoz = 2 - lonf = 200 - latg = 94 - jcap = 126 - ras = .false. - sashal = .true. ! jbao from gfs namelist - newsas = .true. ! jbao from gfs namelist - lsm = 1 - old_monin = .false. - mstrat = .false. - mom4ice = .false. - trans_trac = .false. - cal_pre = .false. - suntim = 0.0 - phil = 0.0 - phii = 0.0 - prsik = 0.0 - dpshc(1) = 0.3 * prsi(1,1) ! jbao new GFS physics as of Feb 2010 - crtrh(:) = 0.85 - cnvgwd = .false. - TISFC = sfc_fld%TSEA(ipn,1) - lat = 1 - nlons = 200 - xkt2 = 0.6 ! rannum(ipn) ! 0.6 - pre_rad = .false. - sinlat = sin(xlat(ipn,1)) - coslat = cos(xlat(ipn,1)) - rcs2 = 1.0 - prsshc = PRSI_S(1,1) - fhour = phour - lssav = .true. - solhr = REAL(mod(REAL(fhour+hour),24.0),kind_phys) - lsfwd = .true. - clstp = 1110.0 - poz = 0.0 - prdout = 0.0 - disout = 0.0 - flx_fld%PSMEAN(ipn,1) = prsshc - flx_fld%PSURF(ipn,1) = prsshc -!TODO: call flx_init() instead as in GFS r3038 do_physics_one_step.f and -!TODO: remove some of these statements... - flx_fld%GESHEM(ipn,1) = 0.0 - flx_fld%RAINC(ipn,1) = 0.0 - cubot = 0.0 - cutop = 0.0 - if(skip_cu_physics) then - flx_fld%RAINC(ipn,1) = phys2dwrf (ipn,6) - cubot = phys2dwrf (ipn,7) - cutop = phys2dwrf (ipn,8) -! if(flx_fld%RAINC(ipn,1).gt.0)write(6,*)'do_phys',flx_fld%RAINC(ipn,1), & -! cubot,cutop - endif - flx_fld%DUSFC(ipn,1) = 10.0 - flx_fld%DVSFC(ipn,1) = 10.0 - flx_fld%DTSFC(ipn,1) = 1.0 - flx_fld%DQSFC(ipn,1) = 0.0 - flx_fld%GFLUX(ipn,1) = 0.0 - flx_fld%RUNOFF(ipn,1) = 0.0 - flx_fld%EP(ipn,1) = 0.0 - flx_fld%CLDWRK(ipn,1) = 0.0 - flx_fld%DUGWD(ipn,1) = 0.0 - flx_fld%DVGWD(ipn,1) = 0.0 - flx_fld%BENGSH(ipn,1) = 0.0 - flx_fld%U10M(ipn,1) = 1.0 - flx_fld%V10M(ipn,1) = 1.0 - sfc_fld%T2M(ipn,1) = 300.0 - sfc_fld%Q2M(ipn,1) = 0.001 - DT3DT = 0.0 - DQ3DT = 0.0 - DU3DT = 0.0 - DV3DT = 0.0 - LDIAG3D = .true. - flipv = .true. - EVBSA(:) = 0.0 - EVCWA(:) = 0.0 - TRANSA(:) = 0.0 - SBSNOA(:) = 0.0 - SNOWCA(:) = 0.0 - SNOHFA(:) = 0.0 - SPFHMAX(:) = 0.0 - SPFHMIN(:) = 1.e10 - gsoil(:) = 0.0 - gtmp2m(:) = 0.0 - gu10m(:) = 0.0 - gv10m(:) = 0.0 - gustar(:) = 0.0 - gzorl(:) = 0.0 - goro(:) = 0.0 - oro(:) = 0.0 - gpblh(:) = 0.0 - upd_mf(:,:) = 0.0 - dwn_mf(:,:) = 0.0 - det_mf(:,:) = 0.0 - sdiaga(:,:) = 0.0 - sdiagb(:,:) = 0.0 - SRUNOFF(:) = 0.0 - -!---------------------------------------------------------------------- -! Call all other (non-radiation) GFS physics parameterizations -!---------------------------------------------------------------------- - if (ipn.eq.8867) then -! write(6,*)'water point before call to gbphys' -! write(6,*)'flx_fld%DLWSFC(ipn,1),flx_fld%ULWSFC(ipn,1)' -! write(6,*)flx_fld%DLWSFC(ipn,1),flx_fld%ULWSFC(ipn,1) -! write(6,*)'flx_fld%SFCDLW(ipn,1),flx_fld%TSFLW(ipn,1)' -! write(6,*)flx_fld%SFCDLW(ipn,1),flx_fld%TSFLW(ipn,1) - endif - - if (ipn.eq.8570) then -! write(6,*)'land point before call to gbphys' -! write(6,*)' flx_fld%HFLX(ipn,1)', flx_fld%HFLX(ipn,1) -! write(6,*)' flx_fld%EVAP(ipn,1)', flx_fld%EVAP(ipn,1) -! write(6,*)'flx_fld%DLWSFC(ipn,1),flx_fld%ULWSFC(ipn,1)' -! write(6,*)flx_fld%DLWSFC(ipn,1),flx_fld%ULWSFC(ipn,1) -! write(6,*)'flx_fld%SFCDLW(ipn,1),flx_fld%TSFLW(ipn,1)' -! write(6,*)flx_fld%SFCDLW(ipn,1),flx_fld%TSFLW(ipn,1) - endif - - call GBPHYS(IM,IX,nvl,lsoil,lsm,ntrac,ncld, & - ntoz,ntcw,nmtvr,lonf,latg,jcap,ras,nlons,xkt2,nrcm,pre_rad, & - UG,VG,PGR,TG,QG,gfs_dpdt(ipn,:), & - GT0,GQ0,GU0,GV0,sinlat,coslat,rcs2,sdiaga,sdiagb, & - prsi,prsl,prslk,prsik,phii,phil,dpshc,fhour,lssav,solhr, & - lsfwd,clstp,dtp,dtf,poz,prdout,ko3,pl_coeff, & - nsst_active,ifd,time_old,time_ins,I_Sw,I_Q,I_Qrain, & - I_M,I_Tau,I_Sw_Zw,I_Q_Ts,I_M_Ts, & - Tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d, & - sfc_fld%HICE(ipn,1),sfc_fld%FICE(ipn,1),TISFC,flx_fld%SFCDSW(ipn,1), & - sfc_fld%TPRCP(ipn,1), sfc_fld%SRFLAG(ipn,1), & - sfc_fld%SLC(:,ipn,1),sfc_fld%SNWDPH(ipn,1),sfc_fld%SLOPE(ipn,1),sfc_fld%SHDMIN(ipn,1),sfc_fld%SHDMAX(ipn,1),sfc_fld%SNOALB(ipn,1),SFALB(ipn,1), & - CHH,CMM,flx_fld%EPI(ipn,1),DLWSFCI,ULWSFCI,USWSFCI,DSWSFCI,DTSFCI, & - DQSFCI,GFLUXI,SRUNOFF,T1,Q1,U1,V1,ZLVL,EVBSA,EVCWA, & - TRANSA,SBSNOA,SNOWCA,SOILM,SNOHFA,SMCWLT2,SMCREF2, & - gsoil,gtmp2m,gustar,gpblh,gu10m,gv10m,gzorl,goro, & - sfc_fld%TSEA(ipn,1) ,sfc_fld%SHELEG(ipn,1),sfc_fld%SNCOVR(ipn,1), sfc_fld%TG3(ipn,1), & - sfc_fld%ZORL(ipn,1) ,sfc_fld%CV(ipn,1) ,sfc_fld%CVB(ipn,1) ,sfc_fld%CVT(ipn,1) , & - sfc_fld%SLMSK(ipn,1) ,sfc_fld%VFRAC(ipn,1) ,sfc_fld%CANOPY(ipn,1),sfc_fld%F10M(ipn,1) , & - sfc_fld%VTYPE(ipn,1) ,sfc_fld%STYPE(ipn,1) ,sfc_fld%UUSTAR(ipn,1),sfc_fld%FFMM(ipn,1) ,sfc_fld%FFHH(ipn,1) , & - flx_fld%TMPMIN(ipn,1),flx_fld%TMPMAX(ipn,1), SPFHMIN,SPFHMAX, & - flx_fld%GESHEM(ipn,1),flx_fld%DUSFC(ipn,1) ,flx_fld%DVSFC(ipn,1) ,flx_fld%DTSFC(ipn,1) , & - flx_fld%DQSFC(ipn,1) ,flx_fld%DLWSFC(ipn,1),flx_fld%ULWSFC(ipn,1), suntim, & - flx_fld%GFLUX(ipn,1) ,flx_fld%RUNOFF(ipn,1),flx_fld%EP(ipn,1) ,flx_fld%CLDWRK(ipn,1), & - flx_fld%DUGWD(ipn,1) ,flx_fld%DVGWD(ipn,1) ,flx_fld%PSMEAN(ipn,1),flx_fld%RAINC(ipn,1),XLON(ipn,1) , & - flx_fld%COSZEN(ipn,1),flx_fld%SFCNSW(ipn,1),XLAT(ipn,1) , & - flx_fld%SFCDLW(ipn,1),flx_fld%TSFLW(ipn,1) ,flx_fld%PSURF(ipn,1) ,flx_fld%U10M(ipn,1) , & - flx_fld%V10M(ipn,1) ,sfc_fld%T2M(ipn,1) ,sfc_fld%Q2M(ipn,1) , & - flx_fld%HPBL(ipn,1) ,flx_fld%PWAT(ipn,1) ,SWH(ipn,:,1,1),HLW(ipn,:,1,1), & - sfc_fld%SMC(:,ipn,1),sfc_fld%STC(:,ipn,1),HPRIME(:,ipn,1),slag(ipn,1),sdec(ipn,1),cdec(ipn,1), & - acv(1),acvb(1),acvt(1), & - phy_f3d(ipn,:,1,1,:), phy_f2d(ipn,1,:), num_p3d, num_p2d, flgmin, & - DT3DT, DQ3DT, DU3DT, DV3DT, upd_mf, dwn_mf, det_mf, & - dkt,dkh, rnp, LDIAG3D, lggfs3d, & - flipv, me,kdt,lat,oro, crtrh, ncw, old_monin,cnvgwd,ccwf,ctei_rm, & - sashal,newsas,mom4ice,mstrat,trans_trac,cal_pre, & - flx_fld%HFLX(ipn,1), flx_fld%EVAP(ipn,1), & - lssav_cc_dummy,DLWSFC_cc_dummy,ULWSFC_cc_dummy,SWSFC_cc_dummy, & - XMU_cc_dummy, & - DLW_cc_dummy,DSW_cc_dummy,SNW_cc_dummy,LPREC_cc_dummy, & - DUSFC_cc_dummy,DVSFC_cc_dummy,DTSFC_cc_dummy,DQSFC_cc_dummy, & - PRECR_cc_dummy,skip_cu_physics,skip_mp_physics,cubot,cutop) - - if (ipn.eq.8867) then -! write(6,*)'water point after call to gbphys' -! write(6,*)'flx_fld%DLWSFC(ipn,1),flx_fld%ULWSFC(ipn,1)' -! write(6,*)flx_fld%DLWSFC(ipn,1),flx_fld%ULWSFC(ipn,1) -! write(6,*)'flx_fld%SFCDLW(ipn,1),flx_fld%TSFLW(ipn,1)' -! write(6,*)flx_fld%SFCDLW(ipn,1),flx_fld%TSFLW(ipn,1) - endif - - if (ipn.eq.8570) then -! write(6,*)'land point after call to gbphys' -! write(6,*)' flx_fld%HFLX(ipn,1)', flx_fld%HFLX(ipn,1) -! write(6,*)' flx_fld%EVAP(ipn,1)', flx_fld%EVAP(ipn,1) -! write(6,*)'land point after call to gbphys' -! write(6,*)'flx_fld%DLWSFC(ipn,1),flx_fld%ULWSFC(ipn,1)' -! write(6,*)flx_fld%DLWSFC(ipn,1),flx_fld%ULWSFC(ipn,1) -! write(6,*)'flx_fld%SFCDLW(ipn,1),flx_fld%TSFLW(ipn,1)' -! write(6,*)flx_fld%SFCDLW(ipn,1),flx_fld%TSFLW(ipn,1) - endif - -!jbao old call before Feb 2010 -!bao call GBPHYS(IM,IX,nvl,lsoil,ntrac,ncld,ntoz,ntcw, & -!bao nmtvr,lonf,latg,jcap,ras,nlons,xkt2,nrcm,pre_rad,UG,VG, & -!bao PGR,TG,QG,gfs_dpdt(ipn,:),GT0,GQ0,GU0,GV0,sinlat,coslat, & -!bao rcs2,prsi,prsl,prslk,prsik,phii,phil,prsshc,fhour,lssav,solhr, & -!bao lsfwd,clstp,dtp,dtf,poz,prdout,disout, & -!bao sfc_fld%HICE(ipn,1),sfc_fld%FICE(ipn,1), & -!bao flx_fld%SFCDSW(ipn,1),sfc_fld%TPRCP(ipn,1), & -!bao sfc_fld%SRFLAG(ipn,1),sfc_fld%SLC(:,ipn,1), & -!bao sfc_fld%SNWDPH(ipn,1),sfc_fld%SLOPE(ipn,1) , & -!bao sfc_fld%SHDMIN(ipn,1),sfc_fld%SHDMAX(ipn,1), & -!bao sfc_fld%SNOALB(ipn,1),SFALB(ipn,1), & -!bao sfc_fld%TSEA(ipn,1) ,sfc_fld%SHELEG(ipn,1), & -!bao sfc_fld%TG3(ipn,1) ,sfc_fld%ZORL(ipn,1) , & -!bao sfc_fld%CV(ipn,1) ,sfc_fld%CVB(ipn,1) ,sfc_fld%CVT(ipn,1), & -!bao sfc_fld%SLMSK(ipn,1) ,sfc_fld%VFRAC(ipn,1),sfc_fld%CANOPY(ipn,1),& -!bao sfc_fld%F10M(ipn,1) ,sfc_fld%VTYPE(ipn,1) , & -!bao sfc_fld%STYPE(ipn,1) ,sfc_fld%UUSTAR(ipn,1), & -!bao sfc_fld%FFMM(ipn,1) ,sfc_fld%FFHH(ipn,1) , & -!bao flx_fld%TMPMIN(ipn,1),flx_fld%TMPMAX(ipn,1), & -!bao flx_fld%GESHEM(ipn,1),flx_fld%DUSFC(ipn,1) , & -!bao flx_fld%DVSFC(ipn,1) ,flx_fld%DTSFC(ipn,1) , & -!bao flx_fld%DQSFC(ipn,1) ,flx_fld%DLWSFC(ipn,1), & -!bao flx_fld%ULWSFC(ipn,1),flx_fld%GFLUX(ipn,1) , & -!bao flx_fld%RUNOFF(ipn,1),flx_fld%EP(ipn,1) , & -!bao flx_fld%CLDWRK(ipn,1),flx_fld%DUGWD(ipn,1) , & -!bao flx_fld%DVGWD(ipn,1) ,flx_fld%PSMEAN(ipn,1), & -!bao flx_fld%BENGSH(ipn,1),XLON(ipn,1),flx_fld%COSZEN(ipn,1), & -!bao flx_fld%SFCNSW(ipn,1),XLAT(ipn,1),flx_fld%SFCDLW(ipn,1), & -!bao flx_fld%TSFLW(ipn,1),flx_fld%PSURF(ipn,1), & -!bao flx_fld%U10M(ipn,1) ,flx_fld%V10M(ipn,1) , & -!bao sfc_fld%T2M(ipn,1) ,sfc_fld%Q2M(ipn,1) , & -!bao flx_fld%HPBL(ipn,1) ,flx_fld%PWAT(ipn,1) , & -!bao SWH(ipn,:,1,1),HLW(ipn,:,1,1),sfc_fld%SMC(:,ipn,1), & -!bao sfc_fld%STC(:,ipn,1),HPRIME(:,ipn,1),slag(ipn,1), & -!bao sdec(ipn,1),cdec(ipn,1),acv(1), & -!bao acvb(1),acvt(1),phy_f3d(ipn,:,1,1,:),phy_f2d(ipn,1,:), & -!bao num_p3d,num_p2d,DT3DT, DQ3DT, DU3DT, DV3DT, LDIAG3D,flipv, & -!bao me,kdt,1,flx_fld%HFLX(ipn,1), flx_fld%EVAP(ipn,1), & -!bao flx_fld%RAINC(ipn,1),GravityWaveDrag ) - if (ipn.eq.8570) then -! write(6,*)'land point before gbphys t and moist' -! write(6,*)'u',gfs_u(ipn,:) -! write(6,*)'v',gfs_v(ipn,:) -! write(6,*)'t',gfs_t(ipn,:) -! write(6,*)'q',gfs_q(ipn,:) -! write(6,*)'cld',gfs_cld(ipn,:) - endif - - if ( .not. skip_cu_physics .or. .not. skip_mp_physics) then -! if(ipn.eq.3071)then -! do ivl=1,nvl-1 -! write(6,*)'gq0 = ',gq0(1,ivl,1) -! enddo -! endif - do ivl=1,nvl-1 -! diaga(ivl,ipn) = sdiaga(1,ivl) -! diaga(ivl,ipn) = dkt(1,ivl) - diagb(ivl,ipn) = sdiagb(1,ivl) - enddo - endif - -! Set tendency arrays from physics - - do ivl=1,nvl - u_tdcy_phy(ivl,ipn) = (gu0(1,ivl)-gfs_u(ipn,ivl))/dtp - v_tdcy_phy(ivl,ipn) = (gv0(1,ivl)-gfs_u(ipn,ivl))/dtp - trc_tdcy_phy(ivl,ipn,1) = (gt0(1,ivl)-gfs_t(ipn,ivl))/dtp - trc_tdcy_phy(ivl,ipn,2) = (gq0(1,ivl,1)-gfs_q(ipn,ivl))/dtp - trc_tdcy_phy(ivl,ipn,3) = (gq0(1,ivl,3)-gfs_cld(ipn,ivl))/dtp - trc_tdcy_phy(ivl,ipn,4) = (gq0(1,ivl,2)-gfs_oz(ipn,ivl))/dtp - gfs_u(ipn,ivl) = gu0(1,ivl) - gfs_v(ipn,ivl) = gv0(1,ivl) - gfs_t(ipn,ivl) = gt0(1,ivl) - gfs_q(ipn,ivl) = gq0(1,ivl,1) - gfs_oz(ipn,ivl) = gq0(1,ivl,2) - gfs_cld(ipn,ivl) = gq0(1,ivl,3) - enddo - if (ipn.eq.8570) then -! write(6,*)'land point after gbphys t and moist' -! write(6,*)'u',gfs_u(ipn,:) -! write(6,*)'v',gfs_v(ipn,:) -! write(6,*)'t',gfs_t(ipn,:) -! write(6,*)'q',gfs_q(ipn,:) -! write(6,*)'cld',gfs_cld(ipn,:) - endif - - if (chem_opt.gt.0 .or. skip_cu_physics .or. skip_mp_physics) then - call do_physics_one_step_chem(ipn,skip_chem,skip_cu_physics,skip_mp_physics,dkt,dq3dt,dt3dt) - endif -enddo !ipn -!jbao stop - -! In the next loop, set temp arrays to new values output from physics - -do ivl=1,nvl - do ipn=1,nip - temp_ps(ipn) = gfs_ps(ipn) - temp_dp(ipn,ivl) = gfs_dp(ipn,ivl) - temp_dpdt(ipn,ivl) = gfs_dpdt(ipn,ivl) - temp_p(ipn,ivl) = gfs_p(ipn,ivl) - temp_u(ipn,ivl) = gfs_u(ipn,ivl) - temp_v(ipn,ivl) = gfs_v(ipn,ivl) - temp_t(ipn,ivl) = gfs_t(ipn,ivl) - temp_q(ipn,ivl) = gfs_q(ipn,ivl) - temp_oz(ipn,ivl) = gfs_oz(ipn,ivl) - temp_cld(ipn,ivl) = gfs_cld(ipn,ivl) - if(ivl.eq.1.and.ipn.eq.1) then - call PhysicsGetIpnItsMype(ipnGlobal,its,mype,DiagPrint) -! print"('do_physics',i5,i9,i5)",mype,ipnGlobal,ivl - endif - enddo -enddo -!sms$compare_var(temp_ps, "do_physics.F90 - gfs_ps1 ") -!sms$compare_var(temp_dp, "do_physics.F90 - gfs_dp1 ") -!sms$compare_var(temp_dpdt, "do_physics.F90 - gfs_dpdt1 ") -!sms$compare_var(temp_p, "do_physics.F90 - gfs_p1 ") -!sms$compare_var(temp_oz, "do_physics.F90 - gfs_oz1 ") -!sms$compare_var(temp_cld, "do_physics.F90 - gfs_cld1 ") -!sms$compare_var(temp_u, "do_physics.F90 - gfs_u1 ") -!sms$compare_var(temp_v, "do_physics.F90 - gfs_v1 ") -!sms$compare_var(temp_t, "do_physics.F90 - gfs_t1 ") -!sms$compare_var(temp_q, "do_physics.F90 - gfs_q1 ") -!call PhysicsGetIpnItsMype(ipnGlobal,its,mype,DiagPrint) -!SMS$PARALLEL END - -return -end subroutine do_physics_one_step - -end module module_do_physics_one_step diff --git a/src/fim/FIMsrc/fim/horizontal/do_physics_one_step_chem.F90 b/src/fim/FIMsrc/fim/horizontal/do_physics_one_step_chem.F90 deleted file mode 100644 index 27b3463..0000000 --- a/src/fim/FIMsrc/fim/horizontal/do_physics_one_step_chem.F90 +++ /dev/null @@ -1,41 +0,0 @@ -module module_do_physics_one_step_chem - -contains - - subroutine do_physics_one_step_chem(ipn,skip_chem,skip_cu_physics,& - skip_mp_physics,dkt,dq3dt,dt3dt) - - use gfs_physics_internal_state_mod,only:gis_phy - use gfs_physics_sfc_flx_mod,only:flx_var_data - use machine,only:kind_phys,kind_rad - use module_control,only:nip - use module_wrf_variables,only:phys3dwrf,exch,pb2d - - integer,intent(in)::ipn - logical,intent(in)::skip_cu_physics,skip_mp_physics,skip_chem - real(kind=kind_phys),intent(in)::dkt(:,:) - real(kind=kind_rad),intent(in)::dq3dt(:,:,:),dt3dt(:,:,:) - integer::ivl - - ! chem radiation stuff, for different midbands, just change this data - ! statement in routine colum_chem/module_ar_ra - ! - ! data midbands/.2,.235,.27,.2875,.3025,.305,.3625,.55,1.92,1.745,6.135/ - - if (skip_cu_physics.or.skip_mp_physics) then - pb2d(ipn)=gis_phy%flx_fld%hpbl(ipn,1) - do ivl=1,gis_phy%levs-1 - phys3dwrf(ivl,ipn,5)=dt3dt(1,ivl,3)/gis_phy%deltim ! bl - t - phys3dwrf(ivl,ipn,6)=(dt3dt(1,ivl,1)+dt3dt(1,ivl,2))/gis_phy%deltim ! ra ? - t - phys3dwrf(ivl,ipn,2)= dq3dt(1,ivl,1)/gis_phy%deltim ! bl - qv - enddo - endif - if (skip_chem) then - pb2d(ipn)=gis_phy%flx_fld%hpbl(ipn,1) - do ivl=1,gis_phy%levs-1 - exch(ivl,ipn)=dkt(1,ivl) - enddo - endif - end subroutine do_physics_one_step_chem - -end module module_do_physics_one_step_chem diff --git a/src/fim/FIMsrc/fim/horizontal/dyn_alloc.F90 b/src/fim/FIMsrc/fim/horizontal/dyn_alloc.F90 deleted file mode 100644 index f49c20c..0000000 --- a/src/fim/FIMsrc/fim/horizontal/dyn_alloc.F90 +++ /dev/null @@ -1,376 +0,0 @@ -!********************************************************************* - module module_dyn_alloc -! This module allocates variables used in dynamics -! Middlecoff October 2008 -!********************************************************************* -contains -subroutine dyn_alloc -use module_control,only: nvl,nvlp1,npp,nip,nabl,ntra,ntrb,nd -use module_wrf_control,only: nbands -use module_constants -use module_variables -use module_sfc_variables -use module_chem_variables,only: sscal,ext_cof,asymp,extlw_cof -use infnan, only: inf, negint - -implicit none - -! Allocate variables from module_constants - -!.................................................................. -! Sec. 1 Math and Physics Constants -!.................................................................. - -!.................................................................. -! Sec. 2. Grid Descriptive Variables -!.................................................................. - -allocate(dpsig (nvl)) ! list of minimum layer thickness (Pa) -allocate(thetac(nvl)) ! target theta for hybgen - -! velocity transform constants for projection from cell edges -allocate(cs(4,npp,nip),sn(4,npp,nip)) -#ifndef LAHEY -dpsig(:) = inf -thetac(:) = inf -cs(:,:,:) = inf -sn(:,:,:) = inf -#endif - -! Variables to describe the icos grid in xy (local stereographic) -allocate(sidevec_c(nd,npp,nip)) ! side vectors projected from center -allocate(sidevec_e(nd,npp,nip)) ! side vectors projected from edge -allocate(sideln ( npp,nip)) ! the length of side vectors (m) -allocate(rsideln ( npp,nip)) ! reciprocal of "sideln" (m**-1) -allocate(rprox_ln ( npp,nip)) ! reciprocal of distance cell cent to prox pts -allocate(area ( nip)) ! the area of cell polygon (m**2) -allocate(rarea ( nip)) ! reciprocal of the "area" - -#ifndef LAHEY -sidevec_c(:,:,:) = inf -sidevec_e(:,:,:) = inf -sideln(:,:) = inf -rsideln(:,:) = inf -rprox_ln(:,:) = inf -area(:) = inf -rarea(:) = inf -#endif - -!................................................................. -! Sec. 3. Neighbor Lookup Tables etc. -!................................................................. - -allocate(prox (npp,nip)) ! Holds index of proximity points -allocate(proxs (npp,nip)) ! Holds index of proximity sides -allocate(nprox ( nip)) ! Holds number of proximity points -allocate(inv_perm ( nip)) ! inverse permutation of grid indices - -#ifndef LAHEY -prox(:,:) = negint -proxs(:,:) = negint -nprox(:) = negint -inv_perm(:) = negint -#endif - -! nedge holds the number of edges valid at each grid cell on this task. -! For a serial ! case, nedge == nprox. -! For a parallel case, nedge == nprox on "interior" cells -! and, nedge < nprox on "halo" cells. -allocate(nedge ( nip)) - -! permedge stores a look-up table for edge indexes. -! For a serial case, permedge does nothing: -! permedge(:,ipn) = 1, 2, 3, ... nprox(ipn) -! For a parallel case, permedge does nothing on "interior" cells. -! For a parallel case, permedge skips "missing" edges on "halo" cells. -allocate(permedge (npp,nip)) -allocate(actual ( nip)) ! actual ipn of halo points (others too) - -#ifndef LAHEY -nedge(:) = negint -permedge(:,:) = negint -actual(:) = negint -#endif - -!..................................................................... -! Sec. 4. Geo Variables: -!..................................................................... - -allocate(corio(nip)) ! Coriolis acceleration -allocate(lat(nip),lon(nip)) ! lat and lon in radians -allocate(deg_lat(nip),deg_lon(nip)) ! lat and lon in degrees - -#ifndef LAHEY -corio(:) = inf -lat(:) = inf -lon(:) = inf -deg_lat(:) = inf -deg_lon(:) = inf -#endif - -! Allocate variables from module_variables - -!..................................................................... -! Sec. 1. 3D Primary Variables -!..................................................................... -! State variables at center point of cell for 3D grid: - -! Layer variables are defined in the middle of the layer - -allocate( us3d(nvl,nip)) ! zonal wind (m/s) -allocate( vs3d(nvl,nip)) ! meridional wind (m/s) -allocate( ws3d(nvl,nip)) ! vertical wind (Pa/s) -allocate( dp3d(nvl,nip)) ! press.diff. between coord levels (Pa) -allocate( dpinit(nvl,nip)) ! lyr thknss for class B tracer transport -allocate( mp3d(nvl,nip)) ! Montgomery Potential (m^2/s^2) -allocate( tk3d(nvl,nip)) ! temperature, kelvin -allocate( vor (nvl,nip)) ! absolute vorticity (s^-1) -allocate( tr3d(nvl,nip,ntra+ntrb)) ! 1=pot.temp, 2=water vapor, 3=cloud water, 4=ozone -allocate( trdp(nvl,nip,ntra+ntrb)) ! (tracer times dp3d ) for tracer transport eq. -allocate( rh3d(nvl,nip)) ! relative humidity from 0 to 1 -allocate( qs3d(nvl,nip)) ! saturation specific humidity -allocate( pw2d(nip)) ! precipitable water - -#ifndef LAHEY -us3d(:,:) = inf -vs3d(:,:) = inf -ws3d(:,:) = inf -dp3d(:,:) = inf -dpinit(:,:) = inf -mp3d(:,:) = inf -tk3d(:,:) = inf -vor(:,:) = inf -tr3d(:,:,:) = inf -trdp(:,:,:) = inf -rh3d(:,:) = inf -qs3d(:,:) = inf -pw2d(:) = inf -#endif - -! Level variables defined at layer interfaces -allocate( pr3d(nvlp1,nip)) ! pressure (pascal) -allocate( ex3d(nvlp1,nip)) ! exner function -allocate( ph3d(nvlp1,nip)) ! geopotential (=gz), m^2/s^2 -allocate( sdot(nvlp1,nip)) ! mass flux across interfaces, sdot*(dp/ds) - -#ifndef LAHEY -pr3d(:,:) = inf -ex3d(:,:) = inf -ph3d(:,:) = inf -sdot(:,:) = inf -#endif - -!.................................................................. -! Sec. 2. Edge Variables -!.................................................................. -! Variables carried at the midpoints of the 6(5) sides of each cell -allocate( u_edg (nvl,npp,nip)) ! u on edge -allocate( v_edg (nvl,npp,nip)) ! v on edge -allocate( dp_edg (nvl,npp,nip)) ! dp on edge -allocate( trc_edg (nvl,npp,nip,ntra+ntrb))! tracers on edge -allocate( lp_edg (nvl,npp,nip)) ! mid-layer pressure on edge -allocate( bnll_edg(nvl,npp,nip)) ! bernoulli fct (montg + kin energy) on edge -allocate( massfx (nvl,npp,nip,3)) ! mass fluxes on edge -allocate( cumufx (nvl,npp,nip)) ! time-integrated mass flx on edge - -#ifndef LAHEY -u_edg(:,:,:) = inf -v_edg(:,:,:) = inf -dp_edg(:,:,:) = inf -trc_edg(:,:,:,:) = inf -lp_edg(:,:,:) = inf -bnll_edg(:,:,:) = inf -massfx(:,:,:,:) = inf -cumufx(:,:,:) = inf -#endif - -!..................................................................... -! Sec. 3. Forcing (tendency) Variables -!..................................................................... -allocate( u_tdcy (nvl,nip,nabl)) ! forcing of u -allocate( v_tdcy (nvl,nip,nabl)) ! forcing of v -allocate( dp_tdcy (nvl,nip,nabl)) ! forcing of dp -allocate( dpl_tdcy(nvl,nip,nabl)) ! forcing dp, low order -allocate( trc_tdcy(nvl,nip,nabl,ntra+ntrb))! forcing of tracers -allocate( trl_tdcy(nvl,nip,nabl,ntra+ntrb))! forcing of tracers, low order -allocate( u_tdcy_phy (nvl,nip)) ! physics forcing of u -allocate( v_tdcy_phy (nvl,nip)) ! physics forcing of v -allocate( trc_tdcy_phy(nvl,nip,ntra+ntrb))! physics forcing of tracers - -#ifndef LAHEY -u_tdcy(:,:,:) = inf -v_tdcy(:,:,:) = inf -dp_tdcy(:,:,:) = inf -dpl_tdcy(:,:,:) = inf -trc_tdcy(:,:,:,:) = inf -trl_tdcy(:,:,:,:) = inf -u_tdcy_phy(:,:) = inf -v_tdcy_phy(:,:) = inf -trc_tdcy_phy(:,:,:) = inf -#endif - -!.................................................................... -! Sec. 4. Misc. arrays -!.................................................................... -allocate( work2d(nip )) -allocate( iwork2d(nip )) -allocate( psrf (nip )) ! surface pressure -allocate( ptdcy (nip,2)) ! sfc.pres.tdcy at 2 consec. time levels -allocate( worka (nvl,nip)) ! 3d work array -allocate( workb (nvl,nip)) ! 3d work array -allocate( diaga(nvl,nip)) ! diagnostic, for output, fill with anything -allocate( diagb(nvl,nip)) ! diagnostic, for output, fill with anything - -!TODO Initialize diag* arrays to inf instead of zero. Init to zero currently required or -!TODO da and db fields will be wrong on history files. -diaga(:,:) = 0. -diagb(:,:) = 0. - -#ifndef LAHEY -work2d(:) = inf -iwork2d(:) = negint -psrf(:) = inf -#endif - -! Allocate variants of physics variables from module module_sfc_variables -! These are single-precision copies of physics variables passed from physics -! to dynamics via the coupler. -!JR These 5 things were moved from output.F90 so they can be written to the restart file. -allocate (rn2d0(nip)) -allocate (rc2d0(nip)) -allocate (rg2d0(nip)) -allocate (flxswavg2d(nip)) -allocate (flxlwavg2d(nip)) - -allocate(rn2d(nip)) ! accumulated total precipitation/rainfall -allocate(rc2d(nip)) ! accumulated convective precipitation/rainfall -allocate(ts2d(nip)) ! skin temperature -allocate(sst_prev(nip)) ! skin temperature -allocate(sst_next(nip)) ! skin temperature -allocate(us2d(nip)) ! friction velocity/equivalent momentum flux -allocate(hf2d(nip)) ! sensible heat flux -allocate(qf2d(nip)) ! water vapor/equivalent latent heat flux -allocate(sheleg2d(nip)) -allocate(tg32d(nip)) -allocate(zorl2d(nip)) -allocate(vfrac2d(nip)) -allocate(vtype2d(nip)) -allocate(stype2d(nip)) -allocate(cv2d(nip)) -allocate(cvb2d(nip)) -allocate(cvt2d(nip)) -allocate(alvsf2d(nip)) -allocate(alvwf2d(nip)) -allocate(alnsf2d(nip)) -allocate(alnwf2d(nip)) -allocate(f10m2d(nip)) -allocate(facsf2d(nip)) -allocate(facwf2d(nip)) -allocate(uustar2d(nip)) -allocate(ffmm2d(nip)) -allocate(ffhh2d(nip)) -allocate(srflag2d(nip)) -allocate(snwdph2d(nip)) -allocate(shdmin2d(nip)) -allocate(shdmax2d(nip)) -allocate(slope2d(nip)) -allocate(snoalb2d(nip)) -allocate(canopy2d(nip)) -allocate(hice2d(nip)) -allocate(fice2d(nip)) -allocate(fice2d_prev(nip)) -allocate(fice2d_next(nip)) -allocate(sw2d(nip)) ! downward short-wave radiation flux -allocate(lw2d(nip)) ! downward long-wave radiation flux -allocate(slc2d(nip)) -allocate(t2m2d(nip)) -allocate(q2m2d(nip)) -allocate(slmsk2d(nip)) -allocate(tprcp2d(nip)) ! precip rate (1000*kg/m**2) -allocate(st3d(4,nip)) ! soil temperature -allocate(sm3d(4,nip)) ! total soil moisture -allocate(slc3d(4,nip)) ! soil liquid content -allocate(hprm2d(14,nip)) -allocate(flxlwtoa2d(nip)) - -#ifndef LAHEY -rn2d0(:) = inf -rc2d0(:) = inf -rg2d0(:) = inf -flxswavg2d(:) = inf -flxlwavg2d(:) = inf - -rn2d(:) = inf -rc2d(:) = inf -ts2d(:) = inf -sst_prev(:) = inf -sst_next(:) = inf -us2d(:) = inf -hf2d(:) = inf -qf2d(:) = inf -sheleg2d(:) = inf -tg32d(:) = inf -zorl2d(:) = inf -vfrac2d(:) = inf -vtype2d(:) = inf -stype2d(:) = inf -cv2d(:) = inf -cvb2d(:) = inf -cvt2d(:) = inf -alvsf2d(:) = inf -alvwf2d(:) = inf -alnsf2d(:) = inf -alnwf2d(:) = inf -f10m2d(:) = inf -facsf2d(:) = inf -facwf2d(:) = inf -uustar2d(:) = inf -ffmm2d(:) = inf -ffhh2d(:) = inf -srflag2d(:) = inf -snwdph2d(:) = inf -shdmin2d(:) = inf -shdmax2d(:) = inf -slope2d(:) = inf -snoalb2d(:) = inf -canopy2d(:) = inf -hice2d(:) = inf -fice2d(:) = inf -fice2d_prev(:) = inf -fice2d_next(:) = inf -sw2d(:) = inf -lw2d(:) = inf -slc2d(:) = inf -t2m2d(:) = inf -q2m2d(:) = inf -slmsk2d(:) = inf -tprcp2d(:) = inf -st3d(:,:) = inf -sm3d(:,:) = inf -slc3d(:,:) = inf -hprm2d(:,:) = inf -#endif - -! chem arrays - -! TODO We'd rather not allocate these arrays if chem is off. But Lahey does not -! TODO allow passing unallocated arrays as subroutine parameters. So, work needs -! TODO to be done to (maybe) have these arrays as optional parameters and wrap -! TODO accesses in "if (present())" conditionals -- or some other approach. For -! TODO now, we have to allocate these. - -!if(aer_ra_feedback == 1 ) then - allocate(sscal(nvl,nip,nbands)) - sscal=1. - allocate(ext_cof(nvl,nip,nbands)) - ext_cof=0. - allocate(asymp(nvl,nip,nbands)) - asymp=0. - allocate(extlw_cof(nvl,nip,16)) - extlw_cof=0. -!endif - -return -end subroutine dyn_alloc - -end module module_dyn_alloc diff --git a/src/fim/FIMsrc/fim/horizontal/dyn_finalize.F90 b/src/fim/FIMsrc/fim/horizontal/dyn_finalize.F90 deleted file mode 100644 index c09ac12..0000000 --- a/src/fim/FIMsrc/fim/horizontal/dyn_finalize.F90 +++ /dev/null @@ -1,25 +0,0 @@ -module module_fim_dyn_finalize - -contains - -!********************************************************************* - subroutine dyn_finalize -! Finish the dynamics component. -! T. Henderson April, 2008 -!********************************************************************* - - use module_control, only: PrintMAXMINtimes,TimingBarriers,nts - use module_outtime_dyn, only: OutTime - use module_core_setup, only: use_write_tasks - - implicit none - - ! print elapsed times for dynamics parts of FIM - call OutTime(maxmin_times=PrintMAXMINtimes,TimingBarriers=TimingBarriers, & - print_header=.true.) - - return - - end subroutine dyn_finalize - -end module module_fim_dyn_finalize diff --git a/src/fim/FIMsrc/fim/horizontal/dyn_init.F90 b/src/fim/FIMsrc/fim/horizontal/dyn_init.F90 deleted file mode 100644 index 0bc544f..0000000 --- a/src/fim/FIMsrc/fim/horizontal/dyn_init.F90 +++ /dev/null @@ -1,938 +0,0 @@ -module module_fim_dyn_init - use findmaxmin2 - use stencilprint - use stenedgprint - use module_control ,only: nvl,nvlp1,nip,nts,dt,numphr,TotalTime,ArchvIntvl, & - ArchvTimeUnit,ArchvStep,itsStart, & - readrestart,ntra, & - npp,nd,glvl,PrintDiags,curve,ntrb, & - PrintIpnDiag,PrintMAXMINtimes,FixedGridOrder, & - NumCacheBlocksPerPE,ipnDiagLocal,ipnDiagPE, & - yyyymmddhhmm,PrintDiagProgVars,TestDiagProgVars, & - PrintDiagNoise,TestDiagNoise,control, & - TimingBarriers,gfsltln_file,dt_reducer_numerator, & - dt_reducer_denominator,EnKFAnl,EnKFFileName, & - FGFileName,FGFileNameSig,filename_len,varnamelen - use module_constants,only: lat,lon,nprox,proxs,prox,area,cs,sn,sidevec_c, & - sidevec_e,sideln,rprox_ln,deg_lat,deg_lon,rarea, & - omegx2,raddeg,rsideln,corio,thetac, & - dpsig,p1000,cp,rd,qvmin,qwmin,inv_perm,nedge, & - permedge, actual - use module_variables,only: u_tdcy,v_tdcy,dp_tdcy,trc_tdcy,trl_tdcy, & - u_tdcy_phy,v_tdcy_phy,trc_tdcy_phy, & - massfx,nf,of,vof,us3d,vs3d,ws3d,dp3d,tk3d, & - pr3d,ex3d,tr3d,mp3d,ph3d,rh3d,trdp,vor, & - sdot,dpl_tdcy,work2d,iwork2d,pw2d,psrf,ptdcy, & - dpinit,cumufx - use module_sfc_variables,only: rn2d,rc2d,qf2d,flxlwtoa2d - use module_core_setup ,only: iam_compute_root,iam_fim_task,iam_write_task, & - my_comm,nct,nwt,output_intercomm,use_write_tasks - use module_dyn_alloc ,only: dyn_alloc - use module_hybgen ,only: hybgen - use module_hystat ,only: hystat - use module_transp3d ,only: transp0 - use module_header ,only: header_size - use module_wtinfo ,only: wtinfo -!SMS$IGNORE BEGIN - use icosio, only: icosio_prep,icosio_set_inv_perm,icosio_setup - use post, only: post_init_readnl, post_init_slint, post_init_readnl_called, post_init_slint_called - use postdata, only: fimout,gribout - use sigio_module - use units, only: getunit, returnunit -!SMS$IGNORE END - - implicit none - -contains - - subroutine dyn_init (client_server_io_in) -!********************************************************************* -! Loads the initial variables and constants for the dynamics -! component. -! Alexander E. MacDonald 11/27/04 -! J. Lee September, 2005 -!********************************************************************* - - logical, intent(in), optional :: client_server_io_in - -! Local variables - -!SMS$DISTRIBUTE(dh,1) BEGIN - logical,allocatable :: in_halo(:) - integer,allocatable :: itmp(:) ! For bounds-finding: See TODO below. -!SMS$DISTRIBUTE END - -!SMS$DISTRIBUTE(dh,3) BEGIN - real,allocatable :: work_edg(:,:,:) ! work array for printing sidevec stencils -!SMS$DISTRIBUTE END - - character*16 :: string - integer :: ipn ! Index for icos point number - integer :: isn ! Index for icos edge number - integer :: ivl ! Index for vertical level - integer :: i,its,idx - integer :: mype=-1 ! Set invalid default value - integer :: ipnGlobal - logical :: DiagPrint - - integer :: lusig - integer(sigio_intkind) :: iret - integer :: nvp - type(sigio_head) :: head - type(sigio_data) :: data - CHARACTER(len=9 ) :: jdate - CHARACTER(len=2 ) :: hh - CHARACTER(len=80) :: sanlFile - -! IBM follows the Fortran standard precisely here requiring all -! literal constants to have the same number of characters. So -! whitespace is significant. - character(11),dimension(0:3) :: CurveType = (/'IJ ', & - 'Hilbert ', & - 'IJ block ', & - 'SquareBlock'/) - integer :: ipnx,isnx,ip1,im1,np1,nm1 - integer :: isncount - integer :: nprocs = 1 - integer :: ios -!SMS$insert integer :: HaloSize -!SMS$insert integer,allocatable :: RegionSize(:) -!SMS$insert CHARACTER(len=80) :: DecompInfoFile - - real*8 :: t0,t1=0.0D0 - - integer :: ims,ips,ipe,ime ! bounds: lower outer & inner, upper outer & inner - integer :: icosio_comm ! an MPI communicator to pass to icosio - integer :: idum1, idum2 ! dummies - logical :: client_server_io ! run icosio in client-server mode? - logical :: debugmsg_on ! write-task debug message control - logical :: ldum1, ldum2 ! dummies - integer :: unitno ! Unit number for I/O - - print *,'entering dyn_init ...' - -!SMS$insert call nnt_me(mype) -!SMS$insert call NNT_NPROCS(nprocs) - if (iam_write_task) nprocs = nct - - call control () - call wtinfo(idum1,nwt,idum2,ldum1,ldum2,debugmsg_on,my_comm) - -! Initialize post. If gribout is enabled, ensure there is a max of 1 write task. - - call post_init_readnl(iret) - if (iret /= 0) then - write(6,*)'dyn_init: bad return from post_init: stopping' - stop - end if - - if (.not. post_init_readnl_called) then - write(6,*)'dyn_init: logic error: cannot test gribout until post_init has been called' - stop - end if - - if (gribout .and. nwt > 1) then - write(6,*)'dyn_init: Cannot have more than 1 write task when gribout enabled' - stop - end if - -if (iam_write_task) then - call post_init_slint (iret) - if (iret /= 0) then - write(6,*)'dyn_init: bad return from post_init_slint: stopping' - stop - endif - if (.not. post_init_slint_called) then - write(6,*)'dyn_init: logic error: cannot test gribout until post_init_slint has been called' - stop - endif -endif - -!TODO: remove dependence of serial prep code on ComputeTasks! -!SMS$insert ios = 0 ! avoid Lahey complaint on non-root tasks -!SMS$insert allocate(RegionSize(nprocs)) -!SMS$insert write(DecompInfoFile,"('DecompInfo_',i0,'.dat')") nprocs -!SMS$insert unitno = getunit () -!SMS$insert if (unitno < 0) then -!SMS$insert print*,'dyn_init: getunit failed for file=', trim(DecompInfoFile),'. Stopping' -!SMS$insert stop -!SMS$insert end if -!SMS$insert open (unitno,file=TRIM(DecompInfoFile),status='old',iostat=ios) -!SMS$insert if (ios /= 0) then -!SMS$insert print*,'ERROR: Cannot find ',TRIM(DecompInfoFile),', prep and fim must be run with the same setting for ComputeTasks in FIMnamelist.' -!SMS$insert stop -!SMS$insert endif -!SMS$insert read (unitno,*) HaloSize -!SMS$insert read (unitno,*) RegionSize -!SMS$insert close(unitno) -!SMS$insert call returnunit (unitno) -!SMS$CREATE_DECOMP(dh,,:regionsize=RegionSize) - -! Set icosio values. - - client_server_io = .true. - if (present(client_server_io_in)) client_server_io = client_server_io_in - - icosio_comm = my_comm - if (use_write_tasks) icosio_comm = output_intercomm - -! TODO Similar bounds-finding logic involving a distributed itmp array already -! TODO exists in wrf_set_array_bounds(). Generalize that routine to allow finding -! TODO arbitrary -- memory, domain, patch or tile -- sets of bounds, and call it -! TODO here to find im[s|e] and ip[s|e]. - - allocate(itmp(nip)) - ims = lbound(itmp,1) - ime = ubound(itmp,1) -!sms$to_local(dh:<1,ips:lbound>,<1,nip:ubound>) begin - ips = 1 - ipe = nip -!sms$to_local end - -!JR Tell icosio to use unit 50. Since getunit() with no arguments may return -!JR different numbers for different MPI tasks, want to be safe. - unitno = getunit (50) - if (unitno < 0) then - print*,'dyn_init: getunit failed for icosio_setup. Stopping' - stop - end if - -! Send icosio required values. If client/server io is enabled, write tasks will -! not return from the icosio_setup() call. - - call icosio_setup (binout_in=fimout, & - client_server_io_in=client_server_io,& - comm_in=icosio_comm, & - debugmsg_on_in=debugmsg_on, & - dt_in=dt, & - filename_len_in=filename_len, & - glvl_in=glvl, & - gribout_in=gribout, & - header_size_in=header_size, & - i_am_write_task_in=iam_write_task, & - ims_in=ims, & - ime_in=ime, & - ips_in=ips, & - ipe_in=ipe, & - lunout_in=unitno, & - nip_in=nip, & - nts_in=itsStart+nts-1, & ! terminal time step - nvl_in=nvl, & - print_diags_in=printdiags, & - using_write_tasks_in=use_write_tasks,& - varname_len_in=varnamelen, & - yyyymmddhhmm_in=yyyymmddhhmm) - -! If client/server IO is disabled, write tasks return from the icosio_setup() -! call when they receive a shutdown command from the compute root after the last -! output frame has been processed, and return from the present subroutine at -! the following statement. FIM uses client/server IO by default, and disables it -! only for NEMS-enabled runs. - - if (iam_write_task) return - - call dyn_alloc () - allocate(in_halo(nip)) - -! Changes in this block may require changes in output.F90 as well - ArchvIntvl = min (ArchvIntvl, TotalTime) - - print"('FIM Global Model')" - print *, " " - call datetime () - print *, " " - print"(' Curve: ' ,A44 )",CurveType(curve) - print"(' Number of cache blocks per processor:',I8,' blocks' )",NumCacheBlocksPerPE - print"(' Grid Level' ,I35 )",glvl - print"(' Number of Processors:' ,I24,' processors')",nprocs - print"(' Global size: ' ,I28,' points' )",nip -!SMS$insert print"(' Halo size: ' ,I28,' points' )",HaloSize - print"(' Forecast duration (',a2,'):' ,I23)",ArchvTimeUnit,TotalTime - print"(' Vertical resolution:' ,I25,' levels' )",nvl - - if (glvl >=7 ) then - print"(' Default time step:' ,I27,' seconds' )",nint(dt*dt_reducer_denominator/dt_reducer_numerator) - print"(' Time step reduced to ' ,I24,' seconds' )",nint(dt) - else - print"(' Length of Time step: ' ,I24,' seconds' )",nint(dt) - end if - - print"(' Number of time steps:' ,I24,' timesteps' )",nts - print "(' Output every',I33,' timesteps')",ArchvStep - print "(' Print MAX,MIN routine times',L18)",PrintMAXMINtimes - print "(' Add timed barriers to measure task skew',L6)",TimingBarriers - print "(' Output in fixed (IJ) grid ordering',L11)",FixedGridOrder - - if (curve == 0) then !The grid order is already IJ for curve=0. - FixedGridOrder = .false. - end if - - if (PrintDiagProgVars == 0) then - TestDiagProgVars = 1 - else if (PrintDiagProgVars < 0) then - TestDiagProgVars = 2*nts - else - TestDiagProgVars = PrintDiagProgVars*numphr - end if - - if (PrintDiagNoise == 0) then - TestDiagNoise = 1 - elseif(PrintDiagNoise < 0) then - TestDiagNoise = 2*nts - else - TestDiagNoise = PrintDiagNoise*numphr - end if - - print "(' Forecast initial time ',A16,' YYYYMMDDHHMM')",yyyymmddhhmm - print "(' Diagnostic prints at ipn ',I10)",PrintIpnDiag - print "(' Print diagnostic messages ',L10)",PrintDiags - print "(' Print diagnostic prognosis vars ',I10)",PrintDiagProgVars - print "(' Print diagnostic gravity wave noise',I10)",PrintDiagNoise - print *,' ' -! TODO: Remove the print of CompilerMPIstring ASAP. It is no longer used by -! TODO: FIMrun or FIMwfm scripts. (Should be OK to remove if no one has -! TODO: complained within a few weeks after this commit!) - print*,' CompilerMPIstring=UPDATE_SCRIPTS_TO_READ_BUILD_CONFIG_FROM_SRCDIR=' - print *,' ' - - if (PrintIpnDiag > nip) then - print*,'Fatal error: PrintIpnDiag must be <= nip',PrintIpnDiag,nip - stop - end if - -! .................................................................. -! Sec. 1. Calculate icosahedral grid description data -! .................................................................. -! The variables to be read in are: - -! lat(nip),lon(nip) - lat and lon of icos pts -! nprox(nip) = number of proximity points (6 or 5) -! proxs(npp,nip) = array holding icos side number (1 to 6) -! prox(npp,nip) = array holding index of icos cell across side -! area(nip) = area of cell -! sidevec_c(nd,npp,nip)= side vector projected from cell center -! sidevec_e(nd,npp,nip)= side vector projected from cell edge -! sideln(npp,nip) = length of side (edge)- local projection invarient -! rprox_ln(npp,nip) = reciprical of length between icos pts -! inv_perm = inverse permutation of the grid -!SMS$PARALLEL(dh, ipn) BEGIN -!SMS$SERIAL BEGIN - unitno = getunit () - if (unitno < 0) then - print*,'dyn_init: getunit failed for file=glvl.dat. Stopping' - stop - end if - - open (unitno, file='glvl.dat', form='unformatted', action='read', iostat=ios) - if (ios /= 0) then - print*,'dyn_init: cannot open glvl.dat for reading. Stopping' - stop - end if - - call TestGlvlHeader (unitno, 'glvl.dat', 'dyn_init', glvl) - call TestCurveHeader(unitno, 'glvl.dat', 'dyn_init', curve) - -!SMS$SERIAL END -!SMS$SERIAL BEGIN - read (unitno,err=90) lat -!SMS$SERIAL END -!SMS$SERIAL BEGIN - read (unitno, err=90) lon -!SMS$SERIAL END -!SMS$SERIAL BEGIN - read (unitno, err=90) nprox -!SMS$SERIAL END - do isn=1,size(proxs,1) -!SMS$SERIAL BEGIN - read (unitno, err=90) iwork2d -!SMS$SERIAL END - do ipn=1,nip - proxs(isn,ipn) = iwork2d(ipn) - end do - end do - - do isn=1,size(prox,1) -!SMS$SERIAL BEGIN - read (unitno, err=90) iwork2d -!SMS$SERIAL END - do ipn=1,nip - prox(isn,ipn) = iwork2d(ipn) - end do - end do -!SMS$SERIAL BEGIN - read (unitno, err=90) area -!SMS$SERIAL END - do isn=1,size(cs,2) - do idx=1,size(cs,1) -!SMS$SERIAL BEGIN - read (unitno, err=90) work2d -!SMS$SERIAL END - do ipn=1,nip - cs(idx,isn,ipn) = work2d(ipn) - end do - end do - end do - - do isn=1,size(sn,2) - do idx=1,size(sn,1) -!SMS$SERIAL BEGIN - read (unitno, err=90) work2d -!SMS$SERIAL END - do ipn=1,nip - sn(idx,isn,ipn) = work2d(ipn) - end do - end do - end do - - do isn=1,size(sidevec_c,2) - do idx=1,size(sidevec_c,1) -!SMS$SERIAL BEGIN - read (unitno, err=90) work2d -!SMS$SERIAL END - do ipn=1,nip - sidevec_c(idx,isn,ipn) = work2d(ipn) - end do - end do - end do - - do isn=1,size(sidevec_e,2) - do idx=1,size(sidevec_e,1) -!SMS$SERIAL BEGIN - read (unitno, err=90) work2d -!SMS$SERIAL END - do ipn=1,nip - sidevec_e(idx,isn,ipn) = work2d(ipn) - end do - end do - end do - - do isn=1,size(sideln,1) -!SMS$SERIAL BEGIN - read (unitno, err=90) work2d -!SMS$SERIAL END - do ipn=1,nip - sideln(isn,ipn) = work2d(ipn) - end do - end do - - do isn=1,size(rprox_ln,1) -!SMS$SERIAL BEGIN - read (unitno, err=90) work2d -!SMS$SERIAL END - do ipn=1,nip - rprox_ln(isn,ipn) = work2d(ipn) - end do - end do -!SMS$SERIAL BEGIN - read (unitno, err=90) inv_perm - close(unitno) - call returnunit (unitno) -!SMS$SERIAL END - do ipn=1,nip - if(nprox(ipn)==5)then - prox(6,ipn) = prox(5,ipn) - end if - end do - -!SMS$PARALLEL END -!SMS$UNSTRUCTURED_GRID(PROX) - -! Update halos of constant arrays. Cannot rely on automatic halo update from -! file read due to prox not yet being set up prior to !SMS$UNSTRUCTURED_GRID. -!SMS$EXCHANGE(lat,lon,nprox,proxs,area,cs,sn,sidevec_c,sidevec_e,sideln,rprox_ln) - - ! set up nedge and permedge for computations in the halo (HALO_COMP) -!SMS$IGNORE BEGIN - in_halo(:) = .true. - nedge(:) = 0 -!SMS$IGNORE END -!SMS$PARALLEL(dh, ipn) BEGIN -! set up nedge and permedge for interior cells - do ipn=1,nip - in_halo(ipn) = .false. - nedge(ipn) = nprox(ipn) ! NOOP for interior cells - do isn=1,nprox(ipn) - permedge(isn,ipn) = isn ! NOOP for interior cells - end do - end do -! now set up nedge and permedge for halo cells -! NOTE: *not* owner-computes! - do ipn=1,nip - do isn=1,nprox(ipn) - ipnx = prox(isn,ipn) - if (in_halo(ipnx)) then - nedge(ipnx) = nedge(ipnx) + 1 - permedge(nedge(ipnx),ipnx) = proxs(isn,ipn) - end if - end do - end do -!SMS$PARALLEL END - -#define DEBUG_HALO_COMP -!TBH: lots of error checks for debugging -#ifdef DEBUG_HALO_COMP -!SMS$PARALLEL(dh, ipn) BEGIN -! verify that in_halo is not screwed up in the interior - do ipn=1,nip - if (in_halo(ipn)) then -!SMS$IGNORE BEGIN - print *,'ERROR C: in_halo(',ipn,') = ',in_halo(ipn),' but ipn is an interior cell!' -!SMS$IGNORE END - stop - end if - end do -! verify that prox(isnx,ipnx) == ipn in the interior - do ipn=1,nip - do isn=1,nprox(ipn) - ipnx = prox(isn,ipn) - isnx = proxs(isn,ipn) - if (.not.in_halo(ipnx)) then ! avoid halo points which have not yet been set up - if (prox(isnx,ipnx) /= ipn) then -!SMS$IGNORE BEGIN - print *,'ERROR C: prox(',isnx,',',ipnx,') /= ',ipn,' me = ',mype,prox(isnx,ipnx) -!SMS$IGNORE END - stop - end if - end if - end do - end do -! verify that nedge is OK in the interior - do ipn=1,nip - if (nedge(ipn) /= nprox(ipn)) then -!SMS$IGNORE BEGIN - print *,'ERROR C: nedge(',ipn,') /= nprox(',ipn,') [',nedge(ipn),' /= ',nprox(ipn),'] me = ',mype -!SMS$IGNORE END - stop - end if - end do -! verify that permedge is OK in the interior - do ipn=1,nip - do isn=1,nedge(ipn) - if (permedge(isn,ipn) /= isn) then -!SMS$IGNORE BEGIN - print *,'ERROR C: permedge(',isn,',',ipn,') /= ',isn,') [',permedge(isn,ipn),' /= ',isn,'] me = ',mype -!SMS$IGNORE END - stop - end if - end do - end do -!SMS$PARALLEL END -#endif -#undef DEBUG_HALO_COMP - -!SMS$PARALLEL(dh, ipn) BEGIN -! fix prox for halo cells -! NOTE: *not* owner-computes! -! TODO: Move this loop into SMS_UnstructuredGrid along with the exchange of proxs above ?? -! TODO: Would need to pass proxs into !SMS$UNSTRUCTURED_GRID too of course... - do ipn=1,nip - do isn=1,nprox(ipn) - ipnx = prox(isn,ipn) - isnx = proxs(isn,ipn) - if (in_halo(ipnx)) then - ! ipnx is a halo cell - ! point prox for halo cell at ipnx back to me (ipn) - prox(isnx,ipnx) = ipn - ! handle pointing prox for halo cell at ipnx to any halo cells that - ! are adjacent to itself (ipnx) and I (ipn) - ! im1 and ip1 are my edges adjacent to cells that are also adjacent - ! to the halo cell at ipnx - im1 = mod(isn-2+nprox(ipn),nprox(ipn)) + 1 - ip1 = mod(isn ,nprox(ipn)) + 1 - ! nm1 and np1 are edges of halo cell at ipnx that are also adjacent - ! to me (ipn) - nm1 = mod(isnx-2+nprox(ipnx),nprox(ipnx)) + 1 - np1 = mod(isnx ,nprox(ipnx)) + 1 - ! note that nm1 and ip1 adjoin the same cell - prox(nm1,ipnx) = prox(ip1,ipn) - ! note that np1 and im1 adjoin the same cell - prox(np1,ipnx) = prox(im1,ipn) - ! note that prox(nm1,ipnx) and prox(np1,ipnx) are computed redundantly - end if - end do - end do -!SMS$PARALLEL END - -!SMS$IGNORE BEGIN -!print *,'DEBUG: setting halo_comp values in first layer of dh__S1 and dh__E1 by brute force' -!print *,'DEBUG: collapsed_halo_size = ',collapsed_halo_size -!print *,'DEBUG: dh__NestLevel = ',dh__NestLevel -!print *,'DEBUG: dh__S1( 1,0,1) = ',dh__S1( 1,0,1) -!print *,'DEBUG: dh__S1( 1,1,1) = ',dh__S1( 1,1,1) -!print *,'DEBUG: dh__E1(nip,0,1) = ',dh__E1(nip,0,1) -!print *,'DEBUG: dh__E1(nip,1,1) = ',dh__E1(nip,1,1) -!SMS$IGNORE END - -#define DEBUG_HALO_COMP -!TBH: lots of error checks for debugging -#ifdef DEBUG_HALO_COMP -!SMS$PARALLEL(dh, ipn) BEGIN -! verify that in_halo is not screwed up in the interior - do ipn=1,nip - if (in_halo(ipn)) then -!SMS$IGNORE BEGIN - print *,'ERROR X: in_halo(',ipn,') = ',in_halo(ipn),' but ipn is an interior cell!' -!SMS$IGNORE END - stop - end if - end do -! verify that prox(isnx,ipnx) == ipn is still true in the interior - do ipn=1,nip - do isn=1,nprox(ipn) - ipnx = prox(isn,ipn) - isnx = proxs(isn,ipn) - if (.not.in_halo(ipnx)) then ! avoid halo points - if (prox(isnx,ipnx) /= ipn) then -!SMS$IGNORE BEGIN - print *,'ERROR X: prox(',isnx,',',ipnx,') /= ',ipn,' me = ',mype -!SMS$IGNORE END - stop - end if - end if - end do - end do -!SMS$HALO_COMP(<1,1>) BEGIN -! verify that prox(isnx,ipnx) == ipn everywhere that we care - do ipn=1,nip - do isncount=1,nedge(ipn) - isn = permedge(isncount,ipn) - ipnx = prox(isn,ipn) - isnx = proxs(isn,ipn) - if (prox(isnx,ipnx) /= ipn) then -!SMS$IGNORE BEGIN - print *,'ERROR X: prox(',isnx,',',ipnx,') /= ',ipn,' me = ',mype,' in_halo(',ipn,') = ', & - in_halo(ipn),' in_halo(',ipnx,') = ',in_halo(ipnx) -!SMS$IGNORE END - stop - end if - end do - end do -!SMS$HALO_COMP END -!SMS$PARALLEL END -#endif -#undef DEBUG_HALO_COMP - -!SMS$PARALLEL(dh, ipn) BEGIN - do ipn=1,nip - corio(ipn) = omegx2*sin(lat(ipn)) ! coriolis acceleration - deg_lat(ipn) = raddeg*lat(ipn) ! latitude in degrees - deg_lon(ipn) = raddeg*lon(ipn) ! longitude in degrees - rarea(ipn) = 1./area(ipn) ! reciprical of area - call GetIpnGlobalMype (ipn, ipnGlobal, mype, DiagPrint) - if(DiagPrint) then - ipnDiagLocal = ipn - ipnDiagPE = mype - end if - actual(ipn) = ipn - end do - - do ipn=1,nip - do isn=1,nprox(ipn) - rsideln(isn,ipn) = 1./sideln(isn,ipn) - end do - end do - -!SMS$EXCHANGE(corio,deg_lat,deg_lon,rarea,rsideln,actual) - -! ............................................................... -! Sec. 2. Load initial state -! ............................................................... - - call StartTimer(t0) -!SMS$SERIAL ( : default=ignore) BEGIN - unitno = getunit () - if (unitno < 0) then - print*,'dyn_init: getunit failed for file=theta_coor.txt. Stopping' - stop - end if - - open (unitno, file='theta_coor.txt', form='formatted', action='read', iostat=ios) - if (ios /= 0) then - print*,'dyn_init: cannot open theta_coor.txt for reading. Stopping' - stop - end if - - read (unitno, *, iostat=ios) thetac - if (ios /= 0) then - print*,'dyn_init: error reading theta_coor.txt. Stopping' - stop - end if - -!do ivl = 1, nvl -! read (26,*) thetac(ivl) -!end do - close (unitno) -!SMS$SERIAL END - print '(a/(10f8.1))','thetac (deg K):', thetac -!SMS$SERIAL ( : default=ignore) BEGIN -! Re-use the same unit number that was just closed - open (unitno, file='dpsig.txt', form='formatted', action='read', iostat=ios) - if (ios /= 0) then - print*,'dyn_init: cannot open dpsig.txt for reading. Stopping' - stop - end if - - read (unitno, *, iostat=ios) dpsig - if (ios /= 0) then - print*,'dyn_init: error reading dpsig.txt. Stopping' - stop - end if - -!do ivl = 1, nvl -! read(unitno,*) dpsig(ivl) -!end do - close (unitno) - call returnunit (unitno) -!SMS$SERIAL END - print '(a/(10f8.1))','dpsig (Pa):',dpsig - - call GetJdate(yyyymmddhhmm,jdate) ! Julian date conversion - hh = yyyymmddhhmm(9:10) - - if (EnKFAnl) then -! read from EnKF analysis - call readenkfanal(nvl,FGFileName,EnKFFileName,FGFileNAmeSig,us3d,vs3d,dp3d,mp3d,pr3d,ex3d,ph3d,tr3d) -! print*,'retured from readenkf' -! DO i=1,nvl,6 -! print*,i,pr3d(i,400),ph3d(i,400),ex3d(i,400),tr3d(i,400,1) -! END DO - else if (.not. readrestart) then - sanlFile = jdate // ".gfs.t" // hh // "z.sanl" - print *,' get initial state from ',sanlFile - -! get control info on input data -! "82" is a magic unit that might have to be byte-swapped - -!SMS$SERIAL ( : default=ignore) BEGIN - lusig = getunit(82) - if (lusig < 0) then - print*,'dyn_init: getunit failed for unit=82. Stopping' - stop - end if - - call sigio_srohdc(lusig,sanlFile,head,data,iret) - if (iret .ne. 0) then - print '(a)','dyn_init: error reading '//sanlFile - STOP -!TBH: this code hangs because errexit does not call MPI_ABORT -! call errmsg('dyn_init: error reading '//sanlFile) -! call errexit(2) - end if - call returnunit (lusig) - nvp = head%levs ! # of layers in input grid -!SMS$SERIAL END - - call ss2icos (nvp, sanlFile, us3d, vs3d, dp3d, mp3d, pr3d, ex3d, ph3d, tr3d, gfsltln_file) - end if ! enkfanl -!TBH: ss2icos only sets tr3d(:,:,1:4) -!TBH: so set remaining values to zero here -!TODO: This may not be the correct approach. Need to get -!TODO: Georg and Rainer together to discuss. At the moment Georg -!TODO: believes that tr3d(:,:,5:ntra) are all zero anyway... - - if (.not. readrestart) then -!SMS$IGNORE BEGIN -! put initialization inside SMS "ignore" so all values are set to -! zero (including halo) - if (ntra+ntrb > 4) then - tr3d(:,:,5:ntra+ntrb) = 0.0 - end if -!SMS$IGNORE END - -! Initialize post. If gribout is enabled, ensure there is a max of 1 write task. - -!SMS$SERIAL BEGIN - call post_init_slint (iret) - if (iret /= 0) then - write(6,*)'dyn_init: bad return from post_init_slint: stopping' - stop - endif - if (.not. post_init_slint_called) then - write(6,*)'dyn_init: logic error: cannot test gribout until post_init_slint has been called' - stop - endif -!SMS$SERIAL END - - call findmxmn2(ph3d,nvlp1,nip,1,'surf.geopot.') - call IncrementTimer(t0,t1) - print"(' DYNAMICS INPUT time:',F10.0)",t1 - - do ipn=1,nip - do ivl=1,nvl ! vertical loop - do i=1,ntra+ntrb - trdp(ivl,ipn,i) = tr3d(ivl,ipn,i)*dp3d(ivl,ipn) - end do - end do - end do - - its = itsStart - 1 - - print *,'dyn_init calling hybgen ...' - - call hybgen(its, & - thetac, & ! target pot.temperature - us3d,vs3d,tr3d, & ! zonal, meridional wind, mass field tracers - sdot,ex3d,dp3d,pr3d ) ! intfc displ., exner, lyr thknss, pressure -! print*,'retured from hybgen' -! DO i=1,nvl,6 -! print*,i,pr3d(i,400),ph3d(i,400),ex3d(i,400),tr3d(i,400,1) -! END DO - - do ipn=1,nip - pr3d(1,ipn) = p1000*(ex3d(1,ipn)/cp)**(cp/rd) - do ivl=1,nvl ! vertical loop - pr3d(ivl+1,ipn) = p1000*(ex3d(ivl+1,ipn)/cp)**(cp/rd) - dp3d(ivl ,ipn) = pr3d(ivl,ipn) - pr3d(ivl+1,ipn) - end do - end do ! horizontal loop - - psrf = 0. - ptdcy = 0. - - print *,'dyn_init calling hystat ...' - call hystat(its, & - ph3d,ex3d,mp3d, & ! geopotential, exner fct., montg.pot. - dp3d,tr3d,trdp, & ! layer thknss, tracer, tracer x thknss - psrf,ptdcy ) ! srf.pressure, srf.prs. tendency - -! ............................................................... -! Sec. 3. Initialize misc. variables -! ............................................................... - -! Initialize tendency arrays - u_tdcy = 0. ! u tendency - v_tdcy = 0. ! v tendency - dp_tdcy = 0. ! dp tendency - dpl_tdcy = 0. ! dp tendency, low order - trc_tdcy = 0. ! tracer tendency - trl_tdcy = 0. ! tracer tendency, low order - massfx = 0. ! mass flux (3 time levels) - u_tdcy_phy = 0. ! physics u tendency - v_tdcy_phy = 0. ! physics v tendency - trc_tdcy_phy = 0. ! physics tracer tendency -!SMS$PARALLEL END - -! initial Adams-Bashforth indices - nf = 0 ! "new field" index - of = 2 ! "old field" index - vof = 1 ! "very old field" index - - ws3d = 0. - tk3d = 0.0 - pw2d = 0. ! precipitable water - rn2d = 0. ! accumulated precipitation/rainfall - rc2d = 0.0 - flxlwtoa2d = 0.0 - - if (ntrb > 0) then - call transp0(its,cumufx,dp3d,dpinit) ! initialize class B tracer transport - end if - end if ! .not. readrestart - - if (readrestart) then -!SMS$SERIAL BEGIN - call post_init_slint (iret) - if (iret /= 0) then - write(6,*)'dyn_init: bad return from post_init_slint: stopping' - stop - endif - if (.not. post_init_slint_called) then - write(6,*)'dyn_init: logic error: cannot test gribout until post_init_slint has been called' - stop - endif -!SMS$SERIAL END - end if ! readrestart: initialize slint - - vor = 0. - rh3d = 0. - - deallocate(in_halo) - - if (fixedgridorder) call icosio_set_inv_perm(inv_perm) - if (use_write_tasks) call icosio_prep - -! --- exercising stencl routine - call stencl(deg_lat,1,1.,'latitude') - call stencl(deg_lon,1,1.,'longitude') - -! All the work_edg stuff need only be done in the initial run - if (readrestart) then - return - end if -!-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ -! --- special diagnostics to figure out what goes on at the poles - -! if (PrintIpnDiag == 1 .or. PrintIpnDiag == nip) then - allocate (work_edg(1,npp,nip)) - do idx=1,2 -!SMS$PARALLEL(dh, ipn) BEGIN - do ipn=1,nip - do isn=1,nprox(ipn) - work_edg(1,isn,ipn) = sidevec_e(idx,isn,ipn) -!!SMS$ignore begin -! if (ipn==PrintIpnDiag) write (*,'(2i7,a,f8.1))') & -! ipn,prox(isn,ipn),string,work_edg(1,isn,ipn) -!!SMS$ignore end - end do - end do -!SMS$EXCHANGE(work_edg) -!SMS$PARALLEL END - write (string,'(a,i1,a)') ' sidevec_e(',idx,')' - call stenedg(deg_lat,work_edg,1,string) -!SMS$PARALLEL(dh, ipn) BEGIN - do ipn=1,nip - do isn=1,nprox(ipn) - work_edg(1,isn,ipn) = sidevec_c(idx,isn,ipn) -!!SMS$ignore begin -! if (ipn==PrintIpnDiag) write (*,'(2i7,a,f8.1))') & -! ipn,prox(isn,ipn),string,work_edg(1,isn,ipn) -!!SMS$ignore end - end do - end do -!SMS$EXCHANGE(work_edg) -!SMS$PARALLEL END - write (string,'(a,i1,a)') ' sidevec_c(',idx,')' - call stenedg(deg_lat,work_edg,1,string) - end do - - do idx=1,4 -!SMS$PARALLEL(dh, ipn) BEGIN - do ipn=1,nip - do isn=1,nprox(ipn) - work_edg(1,isn,ipn) = sn(idx,isn,ipn) - end do -!!SMS$ignore begin -! if (ipn==PrintIpnDiag) write (*,'(2i7,a,f8.1))') & -! ipn,prox(isn,ipn),string,work_edg(1,isn,ipn) -!!SMS$ignore end - end do -!SMS$EXCHANGE(work_edg) -!SMS$PARALLEL END - write (string,'(a,i1,a)') ' sn(',idx,')' - call stenedg(deg_lat,work_edg,1,string) -!SMS$PARALLEL(dh, ipn) BEGIN - do ipn=1,nip - do isn=1,nprox(ipn) - work_edg(1,isn,ipn) = cs(idx,isn,ipn) - end do -!!SMS$ignore begin -! if (ipn==PrintIpnDiag) write (*,'(2i7,a,f8.1))') & -! ipn,prox(isn,ipn),string,work_edg(1,isn,ipn) -!!SMS$ignore end - end do -!SMS$EXCHANGE(work_edg) -!SMS$PARALLEL END - write (string,'(a,i1,a)') ' cs(',idx,')' - call stenedg(deg_lat,work_edg,1,string) - end do - deallocate (work_edg) -!-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ - - print *,'... exiting dyn_init' - return - -90 write(6,*)'dyn_init: error reading a file' - call flush(6) - stop - end subroutine dyn_init -end module module_fim_dyn_init diff --git a/src/fim/FIMsrc/fim/horizontal/dyn_run.F90 b/src/fim/FIMsrc/fim/horizontal/dyn_run.F90 deleted file mode 100644 index cf0874a..0000000 --- a/src/fim/FIMsrc/fim/horizontal/dyn_run.F90 +++ /dev/null @@ -1,439 +0,0 @@ -module module_fim_dyn_run - -contains - -subroutine dyn_run(its) -!********************************************************************* -! "Run" method for fim global model dynamics -! Alexander E. MacDonald 12/24/2005 -! J. LEE 12/28/2005 -!********************************************************************* - -use module_constants -use module_control ,only: nts,nvl,nvlp1,nip,ntra,ntrb,itsStart,nabl, & - PrintIpnDiag,TestDiagProgVars,TestDiagNoise, & - PrintDiagProgVars,TimingBarriers,dt,dtratio, & - ArchvTimeUnit,ArchvStep - -use module_variables,only: u_tdcy,v_tdcy,dp_tdcy,dpl_tdcy, & - massfx,cumufx,dpinit,nf,of,vof, & - us3d,vs3d,dp3d,pr3d,ph3d,ex3d,mp3d, & - tk3d,u_edg,v_edg,dp_edg,diaga,diagb, & - lp_edg,bnll_edg,adbash1,adbash2,adbash3, & - tr3d,trc_edg,trdp,trl_tdcy,trc_tdcy, & - ws3d,sdot,rh3d,pw2d,vor,psrf,ptdcy,worka, & - curr_write_time - -!SMS$IGNORE BEGIN -use module_initial_chem_namelists, only: chem_opt,cu_physics,mp_physics -use postdata ,only: gribout -USE gfs_physics_internal_state_mod, only:gis_phy - - -!SMS$IGNORE END -use module_wrf_variables,only: phys3dwrf,phys2dwrf,exch -use module_sfc_variables ,only: rn2d,rc2d,ts2d,us2d,hf2d,qf2d, & - sw2d,lw2d,flxlwtoa2d,st3d,sm3d,t2m2d,q2m2d, & - canopy2d, fice2d, hice2d, sheleg2d, slmsk2d, & - rn2d0, rc2d0, rg2d0, flxswavg2d, flxlwavg2d -use module_abstart ,only: abstart -use module_chem_output ,only: chem_output -use module_wrf_output ,only: wrf_output -use module_output ,only: output -use module_edgvar ,only: edgvar -use module_cnuity ,only: cnuity -use module_trcadv ,only: trcadv -use module_transp3d ,only: transp0,transp1,transp2 -use module_momtum ,only: momtum -use module_hystat ,only: hystat -use module_hybgen ,only: hybgen -use module_diagnoise ,only: diagnoise -use module_globsum ,only: globsum, qmass, qmsqv, qmsqw, qmste, qmstr, qmstrn, qmstrc, & - qdtr, qdtrn, qdtrc -use module_profout ,only: profout -use module_outDiags ,only: outDiags -use module_outtime_dyn ,only: tdyn,tout,thystat,tedgvar,tcnuity, & - ttrcadv,thybgen,tprofout,tabstart, & - tmomtum,ttransp,tedgvarEx,tcnuityEx, & - ttrcadvEx,ttranspEx,tedgvarBa, & - tcnuityBa,ttrcadvBa,toutputBa, & - ttranspBa -use module_chem_variables ,only: aod2d,p10,pm25,trfall,tr1_tavg -use findmaxmin3 -use module_core_setup ,only: iam_compute_root,use_write_tasks - -implicit none - -! Declare dummy arguments -integer, intent(in ) :: its - -! Declare local variables: -integer :: itsm1 ! its - 1 -integer :: ivl,ipn,type -real*8 :: t0,t1 -! diagnostic sums -real :: qtrcr(ntra+ntrb) -logical, save :: qdtr_print=.false. - -real :: time -integer::ret -integer, external :: its2time -logical::post_init_file_called=.false. - -!SMS$DISTRIBUTE(dh,1) BEGIN -real :: gu10m(nip),gv10m(nip) -!SMS$DISTRIBUTE END - -call StartTimer(t0) -itsm1 = its - 1 - - !........................................................... - ! Finish up previous dynamics time step unless this is the - ! first time step. - ! This complexity is required for the NCEP ESMF approach - ! in which single-phase DYN and PHY components alternate - ! execution during each time step. - ! -!TBH: Restore if statement label once Mark fixes PPP -!TBH skip_first_time1: if (its > itsStart ) then -if (its > 1 ) then - -!sms$compare_var(st3d , "dyn_run begin second half of iteration ") -!sms$compare_var(sm3d , "dyn_run begin second half of iteration ") -!sms$compare_var(rn2d , "dyn_run begin second half of iteration ") -!sms$compare_var(rc2d , "dyn_run begin second half of iteration ") -!sms$compare_var(ts2d , "dyn_run begin second half of iteration ") -!sms$compare_var(us2d , "dyn_run begin second half of iteration ") -!sms$compare_var(hf2d , "dyn_run begin second half of iteration ") -!sms$compare_var(sw2d , "dyn_run begin second half of iteration ") - - !........................................................... - ! Hybrid sigma-theta grid maintenance - ! - call StartTimer(t1) - call hybgen (itsm1, & - thetac, & ! target pot.temp. - us3d,vs3d,tr3d, & ! zonal & merid wind, mass field tracers - sdot,ex3d,dp3d,pr3d ) ! interface displ, exner, layer thknss, prs - - call IncrementTimer(t1,thybgen) - - !........................................................... - ! Hydrostatic calculations - call StartTimer(t1) - call hystat (itsm1, & - ph3d, & ! geopotential - ex3d,mp3d,dp3d, & ! exner fct, montg.pot., layer thickness - tr3d,trdp, & ! mass field tracers, tracer x thickness - psrf,ptdcy ) ! surface pressure, srf.pres.tndcy - call IncrementTimer(t1,thystat) - - !........................................................... - ! Evaluate noise parameter - ! - if( mod(itsm1,TestDiagNoise)==0.or.itsm1==itsStart ) then - call diagnoise (itsm1, & - ptdcy ) ! sfc.pres.tendency at 2 consec. time levels - endif - if (mod (itsm1,TestDiagProgVars) == 0 .or. itsm1 == itsStart .or. its == itsStart+nts) then - call globsum (itsm1, dp3d, tr3d, rn2d, rc2d, pr3d, ex3d, qf2d, qtrcr) - endif - - if (mod(itsm1,TestDiagProgVars) == 0 .or. (itsm1 == itsStart .and. PrintDiagProgVars /= -2)) then - call outDiags (itsm1, nvl, nvlp1, nip, ntra+ntrb, pr3d, ph3d, tr3d, rn2d, & - rc2d, sdot, dp3d, us3d, vs3d, rh3d, lw2d, sw2d, hf2d, qf2d) - endif -!sms$compare_var(mp3d, "dyn_run.F90 - mp3d10 ") - -!sms$compare_var(st3d , "dyn_run end iteration ") -!sms$compare_var(sm3d , "dyn_run end iteration ") -!sms$compare_var(rn2d , "dyn_run end iteration ") -!sms$compare_var(rc2d , "dyn_run end iteration ") -!sms$compare_var(ts2d , "dyn_run end iteration ") -!sms$compare_var(us2d , "dyn_run end iteration ") -!sms$compare_var(hf2d , "dyn_run end iteration ") -!sms$compare_var(sw2d , "dyn_run end iteration ") - -endif ! its > 1 - -!TBH: Restore if statement label once Mark fixes PPP -!TBH endif skip_first_time1 - -call IncrementTimer(t0,tdyn) -call StartTimer(t0) -! Always call output routine, even for its-1 == 0 -!............................................................ - -! If gribout is enabled and I am the compute root, prepare the grib output file -! for writing. The unsupported case where gribout is enabled and more than one -! write task is specified has already been handled in dyn_init. Note that it is -! assumed here that all routines calling icosio_out are doing so on the same -! time step. If any routine needs to write history to disk on a different -! schedule, the first "if" conditional below will need to change. - -if (mod(itsm1,ArchvStep) == 0) then - if (gribout.and..not.use_write_tasks.and.iam_compute_root()) then - call post_init_file(its2time(itsm1),ret) - if (ret /= 0) then - write(6,*) 'output: bad return from post_init_file: stopping' - call flush(6) - stop - endif - post_init_file_called = .true. - endif -endif - -!SMS$PARALLEL(dh, ipn) BEGIN -if (itsm1==0) then - ! physics has not yet been called - do ipn=1,nip - gu10m(ipn) = us3d(1,ipn) - gv10m(ipn) = vs3d(1,ipn) - end do -else - do ipn=1,nip - gu10m(ipn) = gis_phy%flx_fld%u10m(ipn,1) - gv10m(ipn) = gis_phy%flx_fld%v10m(ipn,1) - end do -endif -!SMS$PARALLEL END - -! Generate the output field of main variables: -call output (itsm1, nts, & - us3d, vs3d, dp3d, & ! west & south wind, layer thickness - pr3d, ex3d, mp3d, & ! pressure, exner fct, montg.pot., - tr3d, rh3d, vor, ws3d, & ! mass field tracers, relative humidity - chem_opt,diaga, diagb, & ! diagnostic arrays - ph3d, tk3d, rn2d, rc2d, pw2d, & - ts2d, us2d, hf2d, qf2d, sw2d, & - lw2d, st3d, sm3d, t2m2d, q2m2d, & - canopy2d, fice2d, hice2d, & - sheleg2d, slmsk2d, & - gu10m, gv10m, flxlwtoa2d, & - rn2d0, rc2d0, rg2d0, flxswavg2d, flxlwavg2d, & ! accumulated things - toutputBa, TimingBarriers, curr_write_time) - -! if done like this it should be separated into wrfphys and chem -if (chem_opt.gt.0) then ! output chem variables - call chem_output(itsm1,nts,aod2d,exch,p10,pm25,pr3d,tk3d,tr3d,trfall,phys2dwrf,tr1_tavg) -endif -! if done like this it should be separated into wrfphys and chem -if ( mp_physics .gt. 0 .or. cu_physics .gt. 0) then ! output wrfphys variables - call wrf_output(itsm1,nts,pr3d,tk3d,tr3d,phys2dwrf) -endif - -! See the comment accompanying the post_init_file() call. - -if (post_init_file_called) then - call post_finalize_file(ret) - if (ret.ne.0) then - write(6,*) 'output: bad return from post_finalize_file: stopping' - stop - endif - post_init_file_called = .false. -endif - -call IncrementTimer(t0,tout) -call StartTimer(t0) - -!TBH: Restore if statement label once Mark fixes PPP -!TBH skip_first_time2: if (its > itsStart ) then -if (its > 1) then - call StartTimer(t1) - call profout( & - itsm1,PrintIpnDiag, & ! index time step - us3d,vs3d,dp3d, & ! west & south wind, layer thickness - pr3d,tr3d(:,:,1),mp3d,tk3d, & ! pressure, pot.temp., montg.pot, temp (k) - tr3d(:,:,2),rh3d, & ! specific and relative humidity - ph3d, & ! geopot. - ts2d,us2d,hf2d,qf2d ) ! skin temp., ustar, snsbl heatflx, vapor flx - call IncrementTimer(t1,tprofout) - - if (mod (itsm1,TestDiagProgVars) == 0 .or. itsm1 == 1 .or. its == itsStart+nts) then - time=its2time(itsm1) - write (6,*)'precip - total/nonconv/conv=',qdtr,qdtrn,qdtrc - write (6,80)'Global 3D mass =',qmass,' at ',time,ArchvTimeUnit,', time step=',itsm1 - write (6,80)'Global 3D water vapor =',qmsqv,' at ',time,ArchvTimeUnit,', time step=',itsm1 - write (6,80)'Global 3D cloud water =',qmsqw,' at ',time,ArchvTimeUnit,', time step=',itsm1 - write (6,80)'Global integ acc precip =',qmstr,' at ',time,ArchvTimeUnit,', time step=',itsm1 - - if(qdtr_print) then - write (6,100) PrintDiagProgVars,qdtr,time,ArchvTimeUnit,itsm1 -100 format ('Global precip, last',i3,'h =',es14.7,' at ',f5.1,1x,a,', time step=',i8) - else - qdtr_print = .true. - endif - write (6,*)'Global integ evaporation=',qmste,' at time step=',itsm1 - do type=1,ntrb - write (6,'(a,i2.2,a,es15.7,a,i12)') 'Tracer B',type, & - ' global amount =',qtrcr(ntra+type),' at time step=',itsm1 - end do - endif -80 format (a,es14.7,a,f5.1,1x,2a,i8) - -!TODO: move this down into a subroutine... - if (mp_physics /= 0 .or. cu_physics /= 0) then -! -! store this time level t,qv -! -!SMS$PARALLEL(dh, ipn) BEGIN - do ipn=1,nip - do ivl=1,nvl - phys3dwrf(ivl,ipn,3) = tr3d(ivl,ipn,2) - phys3dwrf(ivl,ipn,7) = tr3d(ivl,ipn,1)*ex3d(ivl,ipn)/(1.+.6078*tr3d(ivl,ipn,2))/cp -! if(ipn.eq.5000)then -! write(6,*)'dyn0',ivl,phys3dwrf(ivl,ipn,7),ex3d(ivl,ipn) -! endif - enddo - enddo -!SMS$PARALLEL END - endif -endif -!TBH: Restore if statement label once Mark fixes PPP -!TBH endif skip_first_time2 - - !........................................................... - ! Begin current dynamics time step unless this is the last - ! (itsStart+nts+1) iteration. - ! This complexity is required for the NCEP ESMF approach - ! in which single-phase DYN and PHY components alternate - ! execution during each time step. - ! -!TBH: Restore if statement label once Mark fixes PPP -!TBH skip_last_iteration: if (its <= nts ) then -if (its < itsStart+nts) then - print "('its=',i7)",its - -!sms$compare_var(st3d , "dyn_run begin iteration ") -!sms$compare_var(sm3d , "dyn_run begin iteration ") -!sms$compare_var(rn2d , "dyn_run begin iteration ") -!sms$compare_var(rc2d , "dyn_run begin iteration ") -!sms$compare_var(ts2d , "dyn_run begin iteration ") -!sms$compare_var(us2d , "dyn_run begin iteration ") -!sms$compare_var(hf2d , "dyn_run begin iteration ") -!sms$compare_var(sw2d , "dyn_run begin iteration ") - - !............................................................. - ! Start the Adams Bashforth 3rd order time diff: - call StartTimer(t1) - call abstart (its,itsStart, & - nf,of,vof, & ! time slots for Adams Bashforth - adbash1,adbash2,adbash3 ) ! Adams Bashforth time dif. weights - call IncrementTimer(t1,tabstart) - - !......................................................... - ! interpolate variables to cell edges - call edgvar (its, & - us3d,vs3d, & ! west & south wind - dp3d,pr3d, & ! layer thknss, pressure - mp3d,tr3d, & ! montg.pot, tracer - u_edg,v_edg,dp_edg,lp_edg, & ! edge variables: u,v,thknss,midlyr-prs - bnll_edg,trc_edg, & ! edge variables: bernoulli-fct, tracer - tedgvar,tedgvarEx,tedgvarBa,& ! timers - TimingBarriers ) ! turn on timing barriers when .true. - - !........................................................ - ! Solve continuity equation - call cnuity (its, & - nf,of,vof, & ! time slots for Adams Bashforth - adbash1,adbash2,adbash3, & ! Adams Bashforth time dif. weights - us3d,vs3d, & ! west & south wind - u_edg,v_edg, & ! west & south wind on edges - dp_edg,lp_edg, & ! lyr thknss & mid-lyr pressure on edges - dp3d,pr3d,ex3d, & ! layer thickness, pressure, Exner fct. - dp_tdcy,dpl_tdcy, & ! forcing for dp and for low ord dp - massfx,ws3d, & ! mass flux across edges, omega=dp/dt - tcnuity,tcnuityEx,tcnuityBa,& ! timers - TimingBarriers ) ! turn on timing barriers when .true. - - !........................................................ - ! Build up time integral of mass fluxes - if (ntrb > 0) then - call transp1(its, & - nf,of,vof, & ! time slots for Adams Bashforth - adbash1,adbash2,adbash3, & ! Adams Bashforth time dif. weights - cumufx,massfx) ! time-integrated and instant. massfx - - !........................................................ - ! Solve transport equation for class B tracers - if (mod(its,dtratio) == 0) then - call transp2(its, & - tr3d,cumufx, & ! tracer, time-integrated mass flux - dpinit,dp3d, & ! initial & final thickness - ttransp,ttranspEx,ttranspBa,TimingBarriers ) - - ! re-initialize time integrals - call transp0(its,cumufx,dp3d,dpinit) - end if - end if - - !........................................................ - ! Solve tracer transport equation for class A tracers - call trcadv (its, & - nf,of,vof, & ! time slots for Adams Bashforth - adbash1,adbash2,adbash3, & ! Adams Bashforth time dif. weights - trc_edg, & ! tracer on edges - tr3d,trdp, & ! trcr, trcr*dp, trcr*dp low ord - trc_tdcy,trl_tdcy, & ! forcing, low ord forcing for trcr - massfx,dp3d, & ! mass flux across edges, layer thickness - ttrcadv,ttrcadvEx,ttrcadvBa,& ! timers - TimingBarriers ) ! turn on timing barriers when .true. - - !......................................................... - ! Solve momentum equation - call StartTimer(t1) - call momtum (its, & - nf,of,vof, & ! time slots for Adams Bashforth - adbash1,adbash2,adbash3, & ! Adams Bashforth time dif. weights - us3d,vs3d,ex3d,vor, & ! west & south wind, exner fct, vorticity - u_edg,v_edg,trc_edg, & ! u,v,trcr on edges - bnll_edg, & ! bernoulli fct on edges - u_tdcy,v_tdcy,dp3d ) ! forcing for u,v; layer thknss - call IncrementTimer(t1,tmomtum) - -!!!sms$compare_var(u_tdcy, "dyn_run.F90 - u_tdcy5 ") -!sms$compare_var(us3d, "dyn_run.F90 - us3d5 ") -!sms$compare_var(trdp, "dyn_run.F90 - trdp5 ") -!sms$compare_var(trc_tdcy, "dyn_run.F90 - trc_tdcy5 ") - - !......................................................... - ! Save theta at end of dyn_run but before physics_run - worka(:,:)=tr3d(:,:,1) - -!sms$compare_var(st3d , "dyn_run end first half of iteration ") -!sms$compare_var(sm3d , "dyn_run end first half of iteration ") -!sms$compare_var(rn2d , "dyn_run end first half of iteration ") -!sms$compare_var(rc2d , "dyn_run end first half of iteration ") -!sms$compare_var(ts2d , "dyn_run end first half of iteration ") -!sms$compare_var(us2d , "dyn_run end first half of iteration ") -!sms$compare_var(hf2d , "dyn_run end first half of iteration ") -!sms$compare_var(sw2d , "dyn_run end first half of iteration ") - -endif -!TBH: Restore if statement label once Mark fixes PPP -!TBH endif skip_last_iteration - -!TODO: move this down into a subroutine... -if (mp_physics /=0 .or. cu_physics /= 0) then -! -! get dynamic tendencies for th and qv -!SMS$PARALLEL(dh, ipn) BEGIN - do ipn=1,nip - do ivl=1,nvl -! if(ipn.eq.5000)then -! write(6,*)'dyn',dt,tr3d(ivl,ipn,1)* (ex3d(ivl,ipn)/(1.+.6078*tr3d(ivl,ipn,2))/cp),phys3dwrf(ivl,ipn,7) -! write(6,*)'dyn2',ivl,tr3d(ivl,ipn,2),phys3dwrf(ivl,ipn,3),ex3d(ivl,ipn) -! endif - phys3dwrf(ivl,ipn,3) = (tr3d(ivl,ipn,2) - phys3dwrf(ivl,ipn,3))/dt - phys3dwrf(ivl,ipn,7) = (tr3d(ivl,ipn,1)*(ex3d(ivl,ipn)/(1. + .6078*tr3d(ivl,ipn,2)))/cp - & - phys3dwrf(ivl,ipn,7))/dt - enddo - enddo -!SMS$PARALLEL END -endif - -call IncrementTimer(t0,tdyn) - -return -end subroutine dyn_run -end module module_fim_dyn_run diff --git a/src/fim/FIMsrc/fim/horizontal/edgvar.F90 b/src/fim/FIMsrc/fim/horizontal/edgvar.F90 deleted file mode 100644 index 8b10df6..0000000 --- a/src/fim/FIMsrc/fim/horizontal/edgvar.F90 +++ /dev/null @@ -1,226 +0,0 @@ -module module_edgvar -use stenedgprint -contains -!********************************************************************* -! edgvar -! Interpolates data to cell edges in the local stereographic grid -! J. Lee Sep 2005 -! A. E. MacDonald Nov 2005 fim conversion -! R. Bleck Apr 2008 cosmetic changes -!********************************************************************* - - subroutine edgvar (its, & - u_vel,v_vel, & ! west, south wind on s level - delp,pres, & ! thickness, intfc pressure - montg,tracr, & ! montg.pot., mass field tracers - u_edg,v_edg,dp_edg,lp_edg, & ! u v dp and layer-prs edge variables - bnll_edg,trc_edg, & ! bernoulli fct, trcr edge variables - tedgvar,tedgvarEx,tedgvarBa, & ! timers - TimingBarriers ) - - use module_control ,only: nvl,nvlp1,npp,nip,ntra,PrintIpnDiag - use module_constants,only: nprox,proxs,prox,cs,sn,nedge,permedge,actual - - implicit none - -! Type and dimension external variables: - - integer,intent(IN) :: its ! model time step -!SMS$DISTRIBUTE (dh,nip) BEGIN -!TBH: Note that u_vel, v_vel, delp, pres, montg, and tracr are INTENT(IN) -!TBH: *except* for the SMS EXCHANGE directive which modifies their halos. -!TBH: Lahey is smart enough to catch this so we must specify INTENT(INOUT) -!TBH: for these dummy arguments. - real ,intent(INOUT) :: u_vel (nvl,nip) ! west wind - real ,intent(INOUT) :: v_vel (nvl,nip) ! south wind - real ,intent(INOUT) :: delp (nvl,nip) ! layer thickness - real ,intent(INOUT) :: pres (nvlp1,nip) ! pres on interfaces - real ,intent(INOUT) :: montg (nvl,nip) ! montgomery potential - real ,intent(INOUT) :: tracr (nvl,nip,ntra) ! mass field tracers - real ,intent(OUT) :: u_edg (nvl,npp,nip) ! west wind on edges - real ,intent(OUT) :: v_edg (nvl,npp,nip) ! south wind on edges - real ,intent(OUT) :: dp_edg (nvl,npp,nip) ! layer thknss on edges - real ,intent(OUT) :: lp_edg (nvl,npp,nip) ! midlyr prs on edges - real ,intent(OUT) :: trc_edg (nvl,npp,nip,ntra) ! tracers on edges - real ,intent(OUT) :: bnll_edg(nvl,npp,nip) ! bernoulli fct on edges - - real work1d(nip),work2d(npp,nip) -!SMS$DISTRIBUTE END - real*8 ,intent(INOUT) :: tedgvar ! computation timer - real*8 ,intent(INOUT) :: tedgvarEx ! halo update communication timer - real*8 ,intent(INOUT) :: tedgvarBa ! barrier timer for task skew - logical,intent(IN) :: TimingBarriers ! measure task skew when .true. - -! Type and dimension local variables: - - integer :: edg ! icos edge index - integer :: ipx ! neighbor across edge with index 'edg' - integer :: im1,ip1 ! neighbors across edg-1 and edg+1 - integer :: ipn ! icos index - integer :: k ! layer Index - integer :: type ! tracer index: 1=theta, 2=qv, .... - integer :: edgcount ! count of icos edges -! These are u and v at neighboring icos points, NOT on edge - real :: u_xy1,u_xy2,u_xy3,u_xy4 ! u on the xy local grid (m/s), at prox pt - real :: v_xy1,v_xy2,v_xy3,v_xy4 ! v on the xy local grid (m/s), at prox pt - real :: mpe ! montg.pot. on edges - real :: kee ! kinetic energy on edges - real*8 :: t1 - logical :: vrbos - character :: string*32 -! real,parameter :: divby6=1./6. ! use in trapezoidal rule - real,parameter :: divby18=1./18. ! use in simpson's rule - - if (TimingBarriers) then - call StartTimer(t1) -!SMS$BARRIER - call IncrementTimer(t1,tedgvarBa) - endif - -!SMS$PARALLEL (dh,ipn) BEGIN - call StartTimer(t1) -!SMS$EXCHANGE(u_vel,v_vel,delp,tracr,montg,pres) - call IncrementTimer(t1,tedgvarEx) -! sms$compare_var(u_vel, "load_ls.F90 - u_vel5 ") -! sms$compare_var(v_vel, "load_ls.F90 - v_vel5 ") -! sms$compare_var(montg, "load_ls.F90 - montg5 ") -! sms$compare_var(cs , "load_ls.F90 - cs5 ") -! sms$compare_var(sn , "load_ls.F90 - sn5 ") - - call StartTimer(t1) -!SMS$HALO_COMP(<1,1>) BEGIN - do ipn=1,nip ! horizontal loop - vrbos=ipn.eq.PrintIpnDiag - do edgcount=1,nedge(ipn) ! loop through edges - -! --- edge quantities are interpolated from 4 icos cells -- the cells on -! --- either side of the edge plus the 2 immediate neighbors of this pair. - - edg = permedge(edgcount,ipn) - ipx = prox(edg,ipn) - im1=mod(edg-2+nprox(ipn),nprox(ipn))+1 - ip1=mod(edg ,nprox(ipn))+1 - im1 = prox(im1,ipn) - ip1 = prox(ip1,ipn) - - if (vrbos) then -!SMS$IGNORE BEGIN - print 100,ipn,edg,ipn,actual(ipx),actual(im1),actual(ip1) - 100 format (i8,' (edgvar) edge',i2,' intpol based on icos cells' & - 2i8,' (lrg wgt),'/51x,2i8,' (sml wgt)') -!SMS$IGNORE END - end if - -!DIR$ vector always - do k=1,nvl ! Loop over layers - - ! Transform u,v at neighboring icos pt to local coord.system. - ! cs and sn are coordinate transformation constants. - ! u_xy,v_xy are values of u and v rotated into local system. - ! (Unrolled to allow vectorization of the k loop) - - u_xy1 = cs(1,edg,ipn)*u_vel(k,ipn)+sn(1,edg,ipn)*v_vel(k,ipn) - v_xy1 = -sn(1,edg,ipn)*u_vel(k,ipn)+cs(1,edg,ipn)*v_vel(k,ipn) - u_xy2 = cs(2,edg,ipn)*u_vel(k,ipx)+sn(2,edg,ipn)*v_vel(k,ipx) - v_xy2 = -sn(2,edg,ipn)*u_vel(k,ipx)+cs(2,edg,ipn)*v_vel(k,ipx) - u_xy3 = cs(3,edg,ipn)*u_vel(k,im1)+sn(3,edg,ipn)*v_vel(k,im1) - v_xy3 = -sn(3,edg,ipn)*u_vel(k,im1)+cs(3,edg,ipn)*v_vel(k,im1) - u_xy4 = cs(4,edg,ipn)*u_vel(k,ip1)+sn(4,edg,ipn)*v_vel(k,ip1) - v_xy4 = -sn(4,edg,ipn)*u_vel(k,ip1)+cs(4,edg,ipn)*v_vel(k,ip1) - - ! interpolate rotated wind components to edges - -! u_edg(k,edg,ipn) = (2.*(u_xy1+u_xy2)+u_xy3+u_xy4)*divby6 -! v_edg(k,edg,ipn) = (2.*(v_xy1+v_xy2)+v_xy3+v_xy4)*divby6 - u_edg(k,edg,ipn) = (8.*(u_xy1+u_xy2)+u_xy3+u_xy4)*divby18 - v_edg(k,edg,ipn) = (8.*(v_xy1+v_xy2)+v_xy3+v_xy4)*divby18 - - end do ! loop over layers - - ! interpolate layer thickness to edges - - do k=1,nvl ! Loop over layers -! dp_edg (k,edg,ipn) = (2.*(delp(k,ipn)+delp(k,ipx)) & -! + delp(k,im1)+delp(k,ip1))*divby6 - dp_edg (k,edg,ipn) = (8.*(delp(k,ipn)+delp(k,ipx)) & - + delp(k,im1)+delp(k,ip1))*divby18 - end do ! loop over layers - - ! interpolate mid-layer pressure to edges - - do k=1,nvl ! Loop over layers - lp_edg (k,edg,ipn) = & -! ( (pres(k ,ipn)+pres(k ,ipx) & -! +pres(k+1,ipn)+pres(k+1,ipx)) & -! + .5* (pres(k ,im1)+pres(k ,ip1) & -! +pres(k+1,im1)+pres(k+1,ip1)) )*divby6 - (4.*(pres(k ,ipn)+pres(k ,ipx) & - + pres(k+1,ipn)+pres(k+1,ipx)) & - + .5* (pres(k ,im1)+pres(k ,ip1) & - +pres(k+1,im1)+pres(k+1,ip1)) )*divby18 - end do ! loop over layers - - do k=1,nvl ! Loop over layers - - ! interpolate montg.pot. to edges - -! mpe = (2.*(montg(k,ipn)+montg(k,ipx)) & -! + montg(k,im1)+montg(k,ip1))*divby6 - mpe = (8.*(montg(k,ipn)+montg(k,ipx)) & - + montg(k,im1)+montg(k,ip1))*divby18 - - ! interpolate kinetic energy to edges - - kee = .5*(u_edg(k,edg,ipn)**2+v_edg(k,edg,ipn)**2) - - ! bernoulli function = mont.pot. (mp) + kinetic energy (ke): - bnll_edg(k,edg,ipn) = mpe + kee - end do ! loop over layers - end do ! loop over edges - end do ! horizontal loop -!SMS$HALO_COMP END - - ! interpolate tracer to edges - - do type=1,ntra ! loop through tracers -!SMS$HALO_COMP(<1,1>) BEGIN - do ipn=1,nip ! horizontal loop - trc_edg(:,npp,ipn,type)=0. - do edgcount=1,nedge(ipn) ! loop through edges - - edg = permedge(edgcount,ipn) - ipx = prox(edg,ipn) - im1=mod(edg-2+nprox(ipn),nprox(ipn))+1 - ip1=mod(edg ,nprox(ipn))+1 - im1 = prox(im1,ipn) - ip1 = prox(ip1,ipn) - - do k=1,nvl ! Loop over layers - trc_edg (k,edg,ipn,type) = & -! (2.*(tracr(k,ipn,type)+tracr(k,ipx,type)) & -! + tracr(k,im1,type)+tracr(k,ip1,type))*divby6 - (8.*(tracr(k,ipn,type)+tracr(k,ipx,type)) & - + tracr(k,im1,type)+tracr(k,ip1,type))*divby18 - end do ! loop over layers - end do ! loop over edges - end do ! horizontal loop -!SMS$HALO_COMP END - -! if (type.eq.1) then -! write (string,'(a,i2)') '(atm edgvar) tracer',type -! do k=1,nvl,7 -! work1d(:)=tracr(k,:,type) -! work2d(:,:)=trc_edg(k,:,:,type) -! call stenedg(work1d,work2d,1,trim(string)//', cell & edge') -! end do -! end if - - end do ! loop through tracers - -! sms$compare_var(u_edg, "load_ls.F90 - u_edg ") -!SMS$PARALLEL END - call IncrementTimer(t1,tedgvar) - - return - end subroutine edgvar -end module module_edgvar diff --git a/src/fim/FIMsrc/fim/horizontal/fct3d.F90 b/src/fim/FIMsrc/fim/horizontal/fct3d.F90 deleted file mode 100644 index c1b383c..0000000 --- a/src/fim/FIMsrc/fim/horizontal/fct3d.F90 +++ /dev/null @@ -1,463 +0,0 @@ -module module_fct3d -contains - - subroutine fct3d(fields,numfld,frst,last,u,w,area,rarea,thko,thkn,diagno) - -! --- 3-d transport routine adapted from HYCOM - -! --- fld - field to be transported -! --- u,w - mass fluxes (x time step) satisfying continuity equation -! --- (w(k) > 0 means mass flows from layer k to layer k+1) -! --- area - grid cell size -! --- rarea - inverse of area -! --- thko,thkn - layer thickness at previous and new time step - - use module_control ,only: npp,nip,nvl,PrintIpnDiag,ntra,ntrb - use module_constants,only: nprox,prox,proxs - use findmaxmin2 - use findmaxmin3 - - implicit none - integer,intent(IN) :: numfld ! total number of fields in 'fields' - integer,intent(IN) :: frst,last ! range of fields to be advected - logical,intent(IN) :: diagno ! activate diagnostic calculations -!SMS$DISTRIBUTE (dh,nip) BEGIN - real,intent(INOUT) :: fields(nvl,nip,numfld) - real ,intent(IN) :: u(nvl,npp,nip),w(nvl,nip), & - thko(nvl,nip),thkn(nvl,nip), & - area(nip),rarea(nip) -! Local variables: - real fld(nvl,nip),vertfx(nvl,nip),vertdv(nvl,nip), & - fmx(nvl,nip),fmn(nvl,nip),flp(nvl,nip),fln(nvl,nip), & - flx(nvl,npp,nip),uan(nvl,npp,nip),hordiv(nvl,nip) -!SMS$DISTRIBUTE END - real a(nvl),b(nvl),c(nvl),dx,fcdx,yl,yr,totin,totou - real q,clip,vlume(nvl),drift(nvl),bfore,after,slab,dslab, & - thkchg,dxlft,dxmid,dxrgt,bforek(nvl),afterk(nvl), & - amount,var1,var2 - integer i,edg,ix,edx,k,kp,n - character string*24 - logical vrbos - logical,parameter :: recovr=.false. - real ,parameter :: athird=1./3.,epsil=1.e-11,onemu=1.e-6 - -! print *,'entering fct3d...' - -!SMS$PARALLEL (dh,i) BEGIN - do i=1,nip - vrbos=i.eq.PrintIpnDiag - - if (vrbos) then -! --- check mass conservation in test column -!SMS$IGNORE BEGIN - write (*,'(i8,a/a)') i, & - ' fct3d -- time-integrated continuity eqn diagnostics:', & - ' thknss_tndcy horiz.flxdiv vert.flxdiv residuum' - do k=1,nvl ! vertical loop - thkchg=thkn(k,i)-thko(k,i) - hordiv(k,i)=0. - do edg=1,nprox(i) - hordiv(k,i)=hordiv(k,i)+u(k,edg,i) - end do - hordiv(k,i)=hordiv(k,i)*rarea(i) - if (k.eq.1) then - write (*,103) k,thkchg,hordiv(k,i),w(k,i), & - thkchg+hordiv(k,i)+w(k,i) - else - write (*,103) k,thkchg,hordiv(k,i),w(k,i)-w(k-1,i), & - thkchg+hordiv(k,i)+w(k,i)-w(k-1,i) - end if - end do ! vertical loop -103 format (i3,4es14.4) -!SMS$IGNORE END - end if ! vrbos - end do ! horiz. loop -!SMS$PARALLEL END - -! --- optional: check mass conservation globally in select layers - if (diagno) then - -!SMS$PARALLEL (dh,i) BEGIN - do i=1,nip ! horiz. loop - do k=1,nvl,7 ! vertical loop - hordiv(k,i)=0. - do edg=1,nprox(i) - hordiv(k,i)=hordiv(k,i)+u(k,edg,i) - end do - hordiv(k,i)=hordiv(k,i)*rarea(i) - if (k.eq.1) then - hordiv(k,i)=hordiv(k,i) & - +w(k,i) +thkn(k,i)-thko(k,i) - else - hordiv(k,i)=hordiv(k,i) & - +w(k,i)-w(k-1,i)+thkn(k,i)-thko(k,i) - end if - end do ! vertical loop - end do ! horiz. loop -!SMS$PARALLEL END - - do k=1,nvl,7 - write (string,'(a,i3)') 'fct3d hordiv lyr',k - call findmxmn2(hordiv,nvl,nip,k,string) - end do ! vertical loop - end if ! diagno - -!SMS$EXCHANGE(fields,thko,thkn) - - do 1 n=frst,last ! loop over fields to be transported - - if (diagno) then - do k=1,nvl,7 - write (string,'(a,i2.2,a,i3)') 'fct3d in: fld',n,' lyr',k - call findmxmn3(fields,nvl,nip,numfld,k,n,trim(string)) - end do - end if - -! --- get vertical flux by summing -fld- over upstream slab of thickness -w- - -!SMS$PARALLEL (dh,i) BEGIN -!SMS$HALO_COMP(<1,1>) BEGIN - do i=1,nip ! horiz. loop - fld(:,i)=fields(:,i,n) - -! --- fill massless cells with data from layer above or below - do k=nvl-1,1,-1 - fld(k,i)=(fld(k,i)*thko(k,i)+fld(k+1,i)*onemu) & - /( thko(k,i)+ onemu) - end do - do k=2,nvl - fld(k,i)=(fld(k,i)*thko(k,i)+fld(k-1,i)*onemu) & - /( thko(k,i)+ onemu) - end do - end do ! horiz. loop -!SMS$HALO_COMP END -!SMS$PARALLEL END - -!SMS$PARALLEL (dh,i) BEGIN - do i=1,nip ! horiz. loop -! --- fit 0th, 1st, or 2nd deg. polynomial to tracer in each cell - a(1 )=fld(1 ,i) - b(1 )=0. - c(1 )=0. - a(nvl)=fld(nvl,i) - b(nvl)=0. - c(nvl)=0. - do k=2,nvl-1 ! vertical loop -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! --- piecewise constant method: -! a(k)=fld(k,i) -! b(k)=0. -! c(k)=0. -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! --- piecewise linear method: -! --- fit linear function a+bx to tracer in each cell (-.5 < x < +.5) -! a(k)=fld(k,i) -! b(k)=0. -! if (fld(k,i).le.min(fld(k-1,i),fld(k+1,i)) .or. & -! fld(k,i).ge.max(fld(k-1,i),fld(k+1,i))) then -! b(k)=0. -! else if ((fld(k+1,i)-fld(k-1,i))*(fld(k-1,i)+fld(k+1,i) & -! -2.*fld(k,i)).gt.0.) then -! b(k)=fld(k,i)-fld(k-1,i) -! else -! b(k)=fld(k+1,i)-fld(k,i) -! end if -! c(k)=0. -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! --- piecewise parabolic method: -! --- construct parabola a+bx+cx^2 whose integral over [-.5,+.5] equals -! --- fld(k) and which passes though points yl,yr at [-.5,+.5] resp. - dxlft=max(epsil,thko(k-1,i)) - dxmid=max(epsil,thko(k ,i)) - dxrgt=max(epsil,thko(k+1,i)) - yl=(dxlft*fld(k,i)+dxmid*fld(k-1,i))/(dxlft+dxmid) - yr=(dxrgt*fld(k,i)+dxmid*fld(k+1,i))/(dxrgt+dxmid) - - a(k)=1.5*fld(k,i)-.25*(yl+yr) - b(k)=yr-yl - c(k)=6.*(.5*(yl+yr)-fld(k,i)) - if (abs(yr-yl) .lt. 6.*abs(.5*(yl+yr)-fld(k,i))) then -! --- apex of parabola o !urs inside interval [-.5,+.5], implying an over- -! --- or undershoot situation. change curve to prevent over/undershoots. - if (abs(yr-yl) .gt. 2.*abs(.5*(yl+yr)-fld(k,i))) then -! --- put apex of parabola on edge of interval [-.5,+.5] - if ((yr-yl)*(.5*(yl+yr)-fld(k,i)) .gt. 0.) then -! --- apex at x=-.5 - a(k)=.25*(3.*fld(k,i)+yl) - c(k)=3.*(fld(k,i)-yl) - b(k)=c(k) - else -! --- apex at x=+.5 - a(k)=.25*(3.*fld(k,i)+yr) - c(k)=3.*(fld(k,i)-yr) - b(k)=-c(k) - end if - else ! -1/6 < x < +1/6 -! --- moving apex won't help. replace parabola by constant. - a(k)=fld(k,i) - b(k)=0. - c(k)=0. - end if - end if -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end do ! vertical loop - - do k=1,nvl-1 ! vertical loop - slab=onemu - if (w(k,i).lt.0.) then ! interface moves up in atm. - amount=slab*fld(k+1,i) - kp=k - 24 kp=kp+1 - if (slab.ge.-w(k,i)) goto 23 - if (thko(kp,i).gt.0.) then - dslab=min(slab+thko(kp,i),-w(k,i)) & - -min(slab ,-w(k,i)) - dx=dslab/thko(kp,i) - fcdx=a(kp) & - +b(kp)*.5*(dx-1.) & ! not needed in pcm - +c(kp)*(.25-dx*(.5-dx*athird)) ! not needed in pcm,plm - amount=amount+fcdx*dslab - slab=slab+dslab - end if - if (kp.lt.nvl) go to 24 - else if (w(k,i).gt.0.) then ! interface moves down in atm. - amount=slab*fld(k,i) - kp=k+1 - 25 kp=kp-1 - if (slab.ge.w(k,i)) goto 23 - if (thko(kp,i).gt.0.) then - dslab=min(slab+thko(kp,i), w(k,i)) & - -min(slab , w(k,i)) - dx=dslab/thko(kp,i) - fcdx=a(kp) & - +b(kp)*.5*(1.-dx) & ! not needed in pcm - +c(kp)*(.25-dx*(.5-dx*athird)) ! not needed in pcm,plm - amount=amount+fcdx*dslab - slab=slab+dslab - end if - if (kp.gt.2) go to 25 - end if - 23 vertfx(k,i)=w(k,i)*amount/slab - end do ! vertical loop - - vertfx(nvl,i)=0. ! don't allow flux thru top - vertdv(1,i)=vertfx(1,i) - do k=2,nvl - vertdv(k,i)=vertfx(k,i)-vertfx(k-1,i) - end do - end do ! horiz. loop -!SMS$PARALLEL END - - bfore=0. - after=0. - bforek(:)=0. - afterk(:)=0. - - if (diagno) then -!SMS$PARALLEL (dh,i) BEGIN - do i=1,nip - do k=1,nvl - bforek(k)=bforek(k)+fld(k,i)*thko(k,i)*area(i) - end do - end do -!SMS$PARALLEL END - end if ! diagno - -! --- compute low-order & antidiffusive (high- minus low-order) fluxes - - vlume(:)=0. - drift(:)=0. - -!SMS$PARALLEL (dh,i) BEGIN - do i=1,nip ! horiz. loop - do k=1,nvl ! vertical loop - fmx(k,i)=fld(k,i) - fmn(k,i)=fld(k,i) - - do edg=1,nprox(i) - ix=prox(edg,i) -! +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ -!! if (u(k,edg,i).ge.0.) then ! out-of cell > 0 -!! q=fld(k,i ) -!! else -!! q=fld(k,ix) -!! end if -!! flx(k,edg,i)=u(k,edg,i)*q ! low order -! +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ - edx=proxs(edg,i) ! index of joint edge as seen by neighbr - flx(k,edg,i)=0.5*( & ! low-order (out-of cell > 0) - (u(k,edg,i )+abs(u(k,edg,i )))*fld(k,i ) & - - (u(k,edx,ix)+abs(u(k,edx,ix)))*fld(k,ix)) -! +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ +-+ - q=.5*(fld(k,i)+fld(k,ix)) ! high (2nd) order - uan(k,edg,i)=q*u(k,edg,i)-flx(k,edg,i) ! antidiffusive - - fmx(k,i)=max(fmx(k,i),fld(k,ix)) - fmn(k,i)=min(fmn(k,i),fld(k,ix)) - end do ! loop over edges - if (k.lt.nvl) then - if (w(k ,i).lt.0.) then - fmx(k,i)=max(fmx(k,i),vertfx(k,i)/w(k,i)) - fmn(k,i)=min(fmn(k,i),vertfx(k,i)/w(k,i)) - end if - end if - if (k.gt.1) then - if (w(k-1,i).gt.0.) then - fmx(k,i)=max(fmx(k,i),vertfx(k-1,i)/w(k-1,i)) - fmn(k,i)=min(fmn(k,i),vertfx(k-1,i)/w(k-1,i)) - end if - end if - end do ! vertical loop - end do ! horiz. loop -!SMS$PARALLEL END - -!SMS$PARALLEL (dh,i) BEGIN - do i=1,nip ! horiz. loop - do k=1,nvl ! vertical loop - hordiv(k,i)=0. - do edg=1,nprox(i) - hordiv(k,i)=hordiv(k,i)+flx(k,edg,i) - end do - hordiv(k,i)=hordiv(k,i)*rarea(i) - - q=fld(k,i)*thko(k,i)-hordiv(k,i)-vertdv(k,i) - amount=max(0.,fmn(k,i)*thkn(k,i),min(q,fmx(k,i)*thkn(k,i))) - if (recovr) then - vlume(k)=vlume(k)+area(i)*thkn(k,i) - drift(k)=drift(k)+(q-amount)*area(i) - end if - fld(k,i)=(fld(k,i)*onemu+amount)/(onemu+thkn(k,i)) - end do ! vertical loop - end do ! horiz. loop - -! --- at each grid point, determine the ratio of the largest permissible -! --- pos. (neg.) change in -fld- to the sum of all incoming (outgoing) fluxes - - do i=1,nip ! horiz. loop - do k=1,nvl ! vertical loop - totin=0. - totou=0. - do edg=1,nprox(i) - totin=totin-min(0.,uan(k,edg,i)) - totou=totou+max(0.,uan(k,edg,i)) - end do - flp(k,i)=(fmx(k,i)-fld(k,i))*thkn(k,i)/(totin+epsil)*rarea(i) - fln(k,i)=(fld(k,i)-fmn(k,i))*thkn(k,i)/(totou+epsil)*rarea(i) - end do ! vertical loop - end do ! horiz. loop -!SMS$PARALLEL END - -! --- limit antidiffusive fluxes - -!SMS$EXCHANGE(flp,fln) - -!SMS$PARALLEL (dh,i) BEGIN - do i=1,nip ! horiz. loop - do k=1,nvl ! vertical loop - do edg=1,nprox(i) - ix=prox(edg,i) - clip=1. - if (uan(k,edg,i).ge.0.) then ! out-of cell > 0 - clip=min(1.,fln(k,i),flp(k,ix)) - else - clip=min(1.,flp(k,i),fln(k,ix)) - end if - flx(k,edg,i)=uan(k,edg,i)*clip - end do - - hordiv(k,i)=0. - do edg=1,nprox(i) - hordiv(k,i)=hordiv(k,i)+flx(k,edg,i) - end do - hordiv(k,i)=hordiv(k,i)*rarea(i) - q=fld(k,i)*thkn(k,i)-hordiv(k,i) - amount=max(0.,fmn(k,i)*thkn(k,i),min(q,fmx(k,i)*thkn(k,i))) - if (recovr) drift(k)=drift(k)+(q-amount)*area(i) - fld(k,i)=(fld(k,i)*onemu+amount)/(onemu+thkn(k,i)) - end do ! vertical loop - end do ! horiz. loop -!SMS$PARALLEL END - - if (recovr) then - -! --- recover 'clipped' amount and return to field layer by layer - do k=1,nvl ! vertical loop - var1=vlume(k) - var2=drift(k) -!SMS$REDUCE(var1,var2,SUM) - vlume(k)=var1 - drift(k)=var2 - - if (vlume(k).ne.0.) then - drift(k)=drift(k)/vlume(k) - write (*,'(i2,a,es11.3)') k,' tracer drift in fct3d',-drift(k) - end if - end do ! vertical loop - -!SMS$PARALLEL (dh,i) BEGIN - do i=1,nip - do k=1,nvl - fld(k,i)=fld(k,i)+drift(k) - end do - end do -!SMS$PARALLEL END - end if ! recovr - - if (diagno) then -!SMS$PARALLEL (dh,i) BEGIN - do i=1,nip - do k=1,nvl - afterk(k)=afterk(k)+fld(k,i)*thkn(k,i)*area(i) - end do - end do -!SMS$PARALLEL END - - var1=bforek(k) - var2=afterk(k) -!SMS$REDUCE(var1,var2,SUM) - bforek(k)=var1 - afterk(k)=var2 - - do k=1,nvl - bfore=bfore+bforek(k) - after=after+afterk(k) - print *,'bforek(k),afterk(k) in lyr',k,bforek(k),afterk(k) - end do ! vertical loop - end if ! diagno - - if (diagno) then - if (bfore.ne.0.) & - write (*,'(a,1p,3e14.6,e11.1)') 'fct3d conservation:', & - bfore,after,after-bfore,(after-bfore)/bfore - end if ! diagno - - if (recovr) then - q=1. - if (after.ne.0.) q=bfore/after - write (*,'(a,f11.6)') 'fct3d: multiply tracer field by',q - if (q.gt.1.1 .or. q.lt..9) stop '(excessive nonconservation)' - -!SMS$PARALLEL (dh,i) BEGIN - do i=1,nip - do k=1,nvl - fld(k,i)=fld(k,i)*q - end do - end do -!SMS$PARALLEL END - end if ! recovr - - fields(:,:,n)=fld(:,:) - - if (diagno) then - do k=1,nvl,7 - write (string,'(a,i2.2,a,i3)') 'fct3d out: fld',n,' lyr',k - call findmxmn3(fields,nvl,nip,numfld,k,n,trim(string)) - end do - end if - -1 continue ! loop over fields -! print *,'exiting fct3d...' - - return - end subroutine fct3d -end module module_fct3d diff --git a/src/fim/FIMsrc/fim/horizontal/filename.F90 b/src/fim/FIMsrc/fim/horizontal/filename.F90 deleted file mode 100644 index c492ed4..0000000 --- a/src/fim/FIMsrc/fim/horizontal/filename.F90 +++ /dev/null @@ -1,27 +0,0 @@ -character(len=*) function filename(tag,its) -!sms$ignore begin - use module_control,only:ArchvTimeUnit - implicit none - character(len=*),intent(in)::tag - integer,intent(in)::its - character(len=6)::timestr - integer::its2time - write (timestr,'(i6.6)') its2time(its) - filename='fim_out_'//trim(tag)//timestr//ArchvTimeUnit -!sms$ignore end -end function filename - -character(len=*) function flexflnm(tag,its) -! --- same as subr.filename but without the hardwired 'fim_out_' part. -! --- file name returned by flexflnm starts with string 'tag'. -!sms$ignore begin - use module_control,only:ArchvTimeUnit - implicit none - character(len=*),intent(in)::tag - integer,intent(in)::its - character(len=6)::timestr - integer::its2time - write (timestr,'(i6.6)') its2time(its) - flexflnm=trim(tag)//timestr//ArchvTimeUnit -!sms$ignore end -end function flexflnm diff --git a/src/fim/FIMsrc/fim/horizontal/fim.F90 b/src/fim/FIMsrc/fim/horizontal/fim.F90 deleted file mode 100644 index 9229e8f..0000000 --- a/src/fim/FIMsrc/fim/horizontal/fim.F90 +++ /dev/null @@ -1,52 +0,0 @@ -!********************************************************************* - program fim -! icosahedral flow-following model -! Authors: Alexander E. MacDonald & Jin-Luen Lee 11/12/05 -! Lead Developer: J. L. Lee -! Design Team: J.L. Lee, R. Bleck, A. E. MacDonald, S. Benjamin -! Computational design: A. E. MacDonald, J. Middlecoff, D. Schaffer -!********************************************************************* - -implicit none - -real*8 :: t0,t1=0.0d0 - -!TODO: Strictly speaking, the MPI timers called from StartTimer should not -!TODO: be called prior to MPI_INIT. For a serial build, MPI_INIT is never -!TODO: called. In practice this has not been a problem. If it becomes -!TODO: a problem fix it by using a different timer inside StartTimer and -!TODO: IncrementTimer for a serial build. - -#ifdef MANUALGPTL -!JR GPTL timers enabled, without iargc/getarg support. Therefore need -!JR to invoke initialize/start/stop/print functions manually -#include -integer :: ret, mype -call gptlprocess_namelist ('FIMnamelist', 77, ret) -ret = gptlinitialize () -ret = gptlstart ('main') -#endif - -call StartTimer(t0) - -! NOTE: Executable SMS directives must not be placed before this call! -! NOTE: This includes writes or prints without !SMS$ignore because they -! generate SMS code. - -call init -call run - -#ifdef MANUALGPTL -!JR GPTL timers enabled, without iargc/getarg support. Therefore need -!JR to invoke stop/print functions manually -!SMS$insert call nnt_me(mype) -ret = gptlstop ('main') -ret = gptlpr (mype) -#endif - -call finalize -call IncrementTimer(t0,t1) - -print*,'Total time =', t1 - -end program fim diff --git a/src/fim/FIMsrc/fim/horizontal/fimcore.F90 b/src/fim/FIMsrc/fim/horizontal/fimcore.F90 deleted file mode 100644 index cd7c266..0000000 --- a/src/fim/FIMsrc/fim/horizontal/fimcore.F90 +++ /dev/null @@ -1,758 +0,0 @@ -module module_core_setup - -!JR Left undesirable name "module_core_setup" as is because svn external -!JR icosio/ files "use" this module, and changing the name would require -!JR separate commits to FIM, icosio, and NIM repositories. -!JR Prefer "use mpi" to "include 'mpif.h'" for argument checking, but that -!JR implementation needs to wait till SMS can provide a declaration that says -!JR it doesn't need to look at the module file. -!JR Moved mpi use/include to top of module instead of inside included routines -!JR so can easily swap between "use" and "include" as desired. - -! use mpi - use module_wtinfo,only:wtinfo - - implicit none - save - private - - include 'mpif.h' - - integer, parameter :: badret = 1 ! Return code for MPI_Abort to pass to environment - -! Public stuff - - public :: core_setup_fim, iam_compute_root, iam_write_root - integer, public :: my_comm=MPI_COMM_NULL ! MPI intra-communicator for FIM compute or write tasks. - integer, public :: output_intercomm=MPI_COMM_NULL ! MPI inter-communicator between FIM compute and write tasks. - integer, public :: total_comm=MPI_COMM_NULL ! MPI intra-communicator for all available MPI tasks. - integer, public :: world_rank ! rank of this task in mpi_comm_in or mpi_comm_world, public for debugging only - integer, public :: nct=-1 ! number of compute tasks - integer, public :: nwt=-1 ! number of write tasks - -! TODO Ensure use_write_tasks, iam_fim_task, iam_write task dont get used before -! core_setup_fim is called - logical, public :: use_write_tasks = .false. ! .true. iff write tasks are enabled (init to false) - logical, public :: iam_fim_task = .true. ! .true. iff I am a FIM compute task (init to true) - logical, public :: iam_write_task = .false. ! .true. iff i am a FIM write task (init to false) - logical, public :: core_setup_done = .false. ! .true. iff core_setup_fim has finished without error - -CONTAINS - - -! public interfaces - - -!********************************************************************* - subroutine core_setup_fim (mpi_comm_in,tasklist_compute,tasklist_write) -! -! SUMMARY: -! When MPI is used, set up communicators for FIM compute tasks and -! optional write tasks. -! When MPI is not used, return immediately. -! NOTE: Executable SMS directives must not be placed before -! NOTE: this routine is called! -! NOTE: This includes writes or prints without !SMS$ignore because they -! NOTE: cause SMS to generate code. -! -! ARGUMENTS: -! Optional argument mpi_comm_in is an MPI communicator that may be -! passed in to restrict FIM to a subset of MPI_COMM_WORLD. -! -! If present, optional argument tasklist_compute must be an -! unassociated pointer to a rank-1 integer array. It will be -! allocated and filled with ranks of compute tasks in MPI_COMM_WORLD -! or, if present, mpi_comm_in. It is the responsibility of the -! caller to deallocate tasklist_compute. -! -! If present, optional argument tasklist_write must be an -! unassociated pointer to a rank-1 integer array. It will be -! allocated and filled with ranks of write tasks in MPI_COMM_WORLD -! or, if present, mpi_comm_in. If the number of write tasks requested -! is 0, tasklist_write will be allocated with size 0. It is the -! responsibility of the caller to deallocate tasklist_write. -! -! DETAILS: -! Split the MPI communicator and create intercommunicators. -! MPI tasks may be split into two or three groups depending upon -! settings in FIMnamelist. The first group will contain the -! "compute" tasks responsible for model computations. The -! optional second group will contain "write" tasks responsible -! for writing output to disk allowing overlap of computation with -! output. If needed, a third group will contain "do-nothing" tasks -! that are neither compute tasks nor write tasks. The use of -! "do-nothing" tasks allows the compute root to optionally live -! on its own node (if more memory is needed). The "do-nothing" -! tasks also allow write tasks to be mapped to nodes optionally -! leaving some cores unused (if more memory is needed or to allow -! concurrent writes of output files from multiple nodes which is -! very fast on some machines). Use of "do-nothing" tasks avoids -! dependence upon site-specific features of batch queuing systems -! to map MPI tasks onto nodes (e.g. mpich $MACHINE_FILE). -! Some run time options and their associated FIMnamelist settings -! are listed below. When specified in FIMnamelist, "cpn" is the -! number of cores per node. -! ------------------------------------------------------------- -! Case 1: ComputeTasks = N -! root_own_node = .false. -! num_write_tasks = 0 -! 0 compute "root" -! 1..N-1 compute tasks -! ------------------------------------------------------------- -! Case 2: ComputeTasks = N -! root_own_node = .true. -! cpn = cn -! num_write_tasks = 0 -! 0 compute "root" -! 1..cn-1 do-nothing tasks -! cn..cn-1+N-1 compute tasks -! ------------------------------------------------------------- -! Case 3: ComputeTasks = N -! root_own_node = .false. -! cpn = cn -! num_write_tasks = 1 -! 0 compute "root" -! 1..cn-1 compute tasks -! cn write task -! cn+1..(2*cn)-1 do-nothing tasks -! (2*cn)..cn+N-1 compute tasks -! ------------------------------------------------------------- -! Case 4: ComputeTasks = N -! root_own_node = .true. -! cpn = cn -! num_write_tasks = 1 -! 0 compute "root" -! 1..cn-1 do-nothing tasks -! cn write task -! cn+1..(2*cn)-1 do-nothing tasks -! (2*cn)..(2*cn)-1+N-1 compute tasks -! ------------------------------------------------------------- -! Case 5: ComputeTasks = N -! root_own_node = .true. -! cpn = cn -! num_write_tasks = 21 -! max_write_tasks_per_node = 3 -! 0 compute "root" -! 1..cn-1 do-nothing tasks -! cn write "root" -! cn+1..cn+(3-1) write tasks -! cn+3..(2*cn)-1 do-nothing tasks -! 2*cn..(2*cn)+(3-1) write tasks -! (2*cn)+3..(3*cn)-1 do-nothing tasks -! 3*cn..(3*cn)+(3-1) write tasks -! (3*cn)+3..(4*cn)-1 do-nothing tasks -! 4*cn..(4*cn)+(3-1) write tasks -! (4*cn)+3..(5*cn)-1 do-nothing tasks -! 5*cn..(5*cn)+(3-1) write tasks -! (5*cn)+3..(6*cn)-1 do-nothing tasks -! 6*cn..(6*cn)+(3-1) write tasks -! (6*cn)+3..(7*cn)-1 do-nothing tasks -! 7*cn..(7*cn)+(3-1) write tasks -! (7*cn)+3..(8*cn)-1 do-nothing tasks -! (8*cn)..(8*cn)-1+N-1 compute tasks -! ------------------------------------------------------------- -! -!TODO: We put compute root on the first node to avoid problems with file -!TODO: system sync on some machines. For example, if compute root is not -!TODO: on node zero, then file system changes made by prep, which does run -!TODO: on node zero, may not be up to date by the time the compute root runs -!TODO: on another node. This approach may need fine-tuning as it may cause -!TODO: the "node affinity" features on other machines to go haywire. -! -!********************************************************************* - -!TODO: At present, this routine ignores serial vs. parallel build and -!TODO: always calls MPI routines. In practice this is not a problem -!TODO: because MPI is always linked in even for serial builds due to use of -!TODO: the MPI timers. If this becomes a problem, wrap this code in cpp -!TODO: directives. - -!TODO: MPI communicators created here are never freed. Fix. - - IMPLICIT NONE - -! Arguments - INTEGER, OPTIONAL, INTENT(IN) :: mpi_comm_in - INTEGER, OPTIONAL, POINTER :: tasklist_compute(:) - INTEGER, OPTIONAL, POINTER :: tasklist_write(:) - -! Local declarations - logical, parameter :: debugon=.false. ! set to .true. to turn on debug prints - integer, parameter :: tag = 998 ! tag for MPI_Recv - integer, parameter :: intercomm_tag = 15 ! tag for intercommnicator creation - - REAL*8 :: t0,t1=0.0d0 ! local timers - LOGICAL :: initialized ! whether mpi_init has been called - INTEGER :: my_rank ! rank of this task in total_comm - INTEGER :: num_tasks ! total number of MPI tasks available - INTEGER :: num_tasks_world ! total number of MPI tasks in mpi_comm_in or mpi_comm_world - INTEGER :: mwtpn ! max write tasks per node - INTEGER :: color ! input arg to mpi_comm_split()--must be non-negative - - integer :: cpn ! cores per node - integer :: status(mpi_status_size) ! returned from mpi_recv - integer :: ignore ! return code from mpi routines (ignored) - integer :: ierr ! return code from mpi routines (not ignored) - integer :: coresleft ! number of cores to be allocated after root, write_tasks - integer :: i ! loop index over ranks in input communicator - integer :: ii ! loop index over ranks in fimcomm_tweaked - integer :: i2 ! another loop index - integer :: inc ! increment - integer :: looplim ! ending loop index - integer :: begwriterank = 999999 ! rank of first write task in fimcomm_tweaked - integer :: endwriterank = -999999 ! rank of last write task in fimcomm_tweaked - integer :: n ! index over write tasks - integer :: iamnew ! Rank in new communicator - - logical :: root_own_node ! whether root has a node to himself -! abort_on_bad_task_distrib controls whether to abort the FIM run if something fishy is -! encountered w.r.t. node names associated with MPI tasks - logical :: abort_on_bad_task_distrib ! whether to die if cpn is wrong - - character(len=mpi_max_processor_name) :: mynode ! node name - character(len=mpi_max_error_string) :: string ! error string - integer :: resultlen ! length return from MPI routines - integer :: tmp_comm_in ! input communicator (MPI_COMM_WORLD or derivative) - integer :: tmp_comm ! dup of tmp_comm_in - integer :: fimcomm_tweaked ! tmp_comm modified to contain only MPI ranks which map to -! compute tasks or write tasks, i.e. what "tweak_hostfile" -! used to do--leave out cores which will not participate - -! Dynamic arrays - -! proclist will contain the list of MPI ranks from the input communicator which will -! define a new communicator (fimcomm_tweaked). This new communicator eliminates "holes" -! to allow for such things as the root MPI task having a node to himself, and write tasks -! starting on a node boundary. - integer, allocatable :: proclist(:) - integer :: lastproclist ! last valid index of proclist - integer :: numcomputetasks ! number of compute tasks - logical :: debugmsg_on ! write-task debug message control - character(len=mpi_max_processor_name), allocatable :: nodes(:) ! node names - -! Return immediately iff this is a serial run (i.e. MPI_INIT has not been called) - - call mpi_initialized (initialized, ierr) - if (.not.initialized) then -! this is a serial run - nct = 1 -! TODO: remove duplication - iam_fim_task = .true. - iam_write_task = .false. - core_setup_done = .true. - return - end if - - CALL StartTimer(t0) - -!TODO: For NEMS, read from config file instead of namelist. Keep details -!TODO: inside get_write_task_info(). - - call wtinfo(cpn,nwt,mwtpn,root_own_node,abort_on_bad_task_distrib,debugmsg_on) - if (nwt > 0 .and. mwtpn > cpn) then -!SMS$IGNORE BEGIN - print *,'ERROR in core_setup_fim: wtinfo returned max write tasks per node=', & - mwtpn, ' > cores per node=', cpn - call mpi_abort (mpi_comm_world, badret, ignore) - stop -!SMS$IGNORE END - end if - - if (cpn < 1) then -!SMS$IGNORE BEGIN - print *,'ERROR in core_setup_fim: wtinfo returned non-positive cpn=', cpn - print *,'This MUST be set in /writetasknamelist/' - call mpi_abort (mpi_comm_world, badret, ignore) - stop -!SMS$IGNORE END - end if - - IF (nwt < 0) THEN -!SMS$IGNORE BEGIN - PRINT *,'ERROR in core_setup_fim: wtinfo returned negative num_write_tasks' - CALL MPI_ABORT (MPI_COMM_WORLD, badret, ignore) - STOP -!SMS$IGNORE END - ENDIF - -! use passed-in communicator if present, otherwise use MPI_COMM_WORLD - tmp_comm_in = MPI_COMM_WORLD - IF ( PRESENT( mpi_comm_in ) ) THEN - tmp_comm_in = mpi_comm_in - ENDIF -! dup is needed to make sends and receives below safe - CALL MPI_COMM_DUP (tmp_comm_in, tmp_comm, ierr) - IF (ierr /= 0) THEN -!SMS$IGNORE BEGIN - PRINT *,'ERROR in core_setup_fim: MPI_COMM_DUP(tmp_comm_in) returned ',ierr - CALL MPI_ABORT (MPI_COMM_WORLD, badret, ignore) - STOP -!SMS$IGNORE END - ENDIF - -!JR Define a new communicator which places root and write tasks appropriately -!JR i.e. maybe root on a node by himself, and likewise write tasks on their -!JR own node(s). -!JR Check that cpn is consistent with the return from MPI_GET_PROCESSOR_NAME -!JR The checking code ASSUMES that tweak_hostfile or equivalent is NOT in effect - - mynode = ' ' - call mpi_get_processor_name (mynode, resultlen, ierr) - if (ierr /= 0) then -!SMS$IGNORE BEGIN - call mpi_error_string (ierr, string, resultlen, ignore) - write(6,*)'Error from mpi_get_processor_name:', string(1:resultlen) - call mpi_abort (mpi_comm_world, badret, ignore) - stop -!SMS$IGNORE END - end if - - call mpi_comm_size (tmp_comm, num_tasks_world, ignore) - call mpi_comm_rank (tmp_comm, world_rank, ignore) - - allocate (nodes(0:2*cpn-1)) ! Check 1st 2 nodes - allocate (proclist(0:num_tasks_world-1)) ! Ranks start at 0 - proclist(:)=-1 - nodes(:) = ' ' - -! Gather node name info for 1st 2 nodes to check conformance with -! expected node allocation - - looplim = min (num_tasks_world-1, 2*cpn-1) - if (world_rank == 0) then ! get node name info from other tasks - nodes(0) = mynode - do i=1,looplim - call mpi_recv (nodes(i), mpi_max_processor_name, mpi_character, & - i, tag, tmp_comm, status, ignore) - end do - else if (world_rank <= looplim) then ! send my info to root - call mpi_send (mynode, mpi_max_processor_name, mpi_character, & - 0, tag, tmp_comm, ignore) - end if - -! Root task ensures that node name changes for second node - - if (world_rank == 0 .and. num_tasks_world > cpn) then - if (nodes(0) == nodes(cpn)) then -!SMS$IGNORE BEGIN - write(6,*)'core_setup_fim: MPI task 0 name=', trim (nodes(0)), & - ' matches task ',cpn, ' name=', trim (nodes(cpn)),' cpn=', cpn - write(6,*)'Perhaps namelist value for cpn=', cpn, ' is incorrect?' - if (abort_on_bad_task_distrib) then - write(6,*)'abort_on_bad_task_distrib is true so model is aborting...' - call mpi_abort (mpi_comm_world, badret, ignore) - stop - end if -!SMS$IGNORE END - end if - end if - -! When task distribution leaves "holes" (for example when -! root_own_task is set on systems with more than one CPU per -! node) some MPI tasks will not be used. These relaxed and -! unmotivated tasks are known as "do-nothing" tasks. - -! First: Set proclist for first node. Contents depend on whether root -! has a node to himself - -! I am a "do-nothing" task unless modified below - iam_fim_task=.false. - iam_write_task=.false. - proclist(0) = 0 ! Root task always same in both communictors - if (world_rank==0) iam_fim_task = .true. ! compute task - if (root_own_node) then - i = cpn ! Move pointer to 1st core of next node - ii = 1 ! Set proclist index for next entry - else ! Fill remainder of node 0 with compute tasks -! TODO: Fix this for pathological case where root_own_node=.false. and nct < cpn -! TODO: Currently utils/get_num_cores guards against this case. -! TODO: Could be done here by calling GetNprocs, but that routine is INSANELY expensive because -! TODO: it opens 2 files and reads namelists from them in order to get the value. - looplim = min (num_tasks_world-1, cpn-1) - ii = 1 ! Set proclist index for next entry - do i=1,looplim - proclist(ii) = i - if (world_rank==i) iam_fim_task = .true. ! compute task - if (world_rank == 0 .and. nodes(i-1) /= nodes(i)) then -!SMS$IGNORE BEGIN - write(6,*)'core_setup_fim: MPI task ',i-1,' name=',trim(nodes(i-1)), & - ' does not match task ',i,' name=',trim(nodes(i)),' cpn=',cpn - if (abort_on_bad_task_distrib) then - write(6,*)'abort_on_bad_task_distrib is true so model is aborting...' - call mpi_abort (mpi_comm_world, badret, ignore) - stop - end if -!SMS$IGNORE END - end if - ii = ii + 1 - end do - i = cpn - end if - -! Add write tasks to proclist. "i" currently points to 1st core of 2nd node - - if (nwt > 0) then - begwriterank = ii - end if - - do n=1,nwt - if (i >= num_tasks_world) then -!SMS$IGNORE BEGIN - if (world_rank == 0) then - write(6,*)'Ran out of MPI tasks assigning write task=',n,'. i=',i - end if - call mpi_abort (mpi_comm_world, badret, ignore) - stop -!SMS$IGNORE END - end if - proclist(ii) = i - if (world_rank==i) iam_write_task = .true. ! write task - endwriterank = ii - if (mod (n, mwtpn) == 0) then ! Move pointer to start of next node - inc = cpn - mwtpn + 1 - else ! Haven't filled up the node with write tasks yet - inc = 1 - end if - i = i + inc - ii = ii + 1 - end do - -! Compute tasks after write tasks start at next empty node - - if (mod (i, cpn) /= 0) then - coresleft = cpn - mod (i, cpn) - i = i + coresleft - end if - -! Remainder of proclist is compute tasks - - do while (i < num_tasks_world) - proclist(ii) = i - if (world_rank==i) iam_fim_task = .true. ! compute task - i = i + 1 - ii = ii + 1 - end do - lastproclist = ii - 1 - - if (nwt == 0) then - use_write_tasks = .false. - else - use_write_tasks = .true. - end if - -! Split "do-nothing" tasks from other tasks. -! Yes, two splits are needed so intercommunicators can be correctly -! constructed. -! Define the new communicator fimcomm_tweaked. -! tasks with color==1 will be in the "do-nothing" group - color = 1 - if (iam_fim_task.or.iam_write_task) color = 0 - CALL MPI_COMM_SPLIT (tmp_comm, color, world_rank, fimcomm_tweaked, ierr) - if (ierr /= 0) then -!SMS$IGNORE BEGIN - call mpi_error_string (ierr, string, resultlen, ignore) - write(6,*)'Error in mpi_comm_split:', string(1:resultlen) - call flush (6) - call mpi_abort (mpi_comm_world, badret, ignore) -!SMS$IGNORE END - endif - - if (iam_fim_task.or.iam_write_task) then - - call mpi_comm_rank (fimcomm_tweaked, iamnew, ignore) -!SMS$IGNORE BEGIN - if (iamnew == 0) then - write(6,'(a,a)') 'Compute task: WORLD rank 0 = fimcomm_tweaked rank 0 is running on ', & - trim(mynode) - else if (iamnew < begwriterank .or. iamnew > endwriterank) then - write(6,'(a,i0,a,i0,a,a)') 'Compute task: WORLD rank ',world_rank, & - ' = fimcomm_tweaked rank ', iamnew, ' is running on ', trim(mynode) - else - write(6,'(a,i0,a,i0,a,a)') 'Write task: WORLD rank ',world_rank, & - ' = fimcomm_tweaked rank ', iamnew, ' is running on ', trim(mynode) - end if -!SMS$IGNORE END - - else ! we are a "do-nothing" task - - my_comm = fimcomm_tweaked ! used later in !SMS$SET_COMMUNICATOR -!SMS$IGNORE BEGIN - write(6,'(a,i0,a,a)') 'Do-nothing task: WORLD rank ',world_rank, & - ' is running on ', trim(mynode) -!SMS$IGNORE END -! NOTE: The do-nothing tasks must return from this routine for NEMS runs -! NOTE: due to the ESMF requirement that all tasks in a VM participate -! NOTE: in component creation, even tasks that are not used. - - end if - -! TODO: This is the opposite of DRY! -! TODO: The ordering of compute and write tasks is implicit in THREE -! TODO: PLACES. DRY this out!!! - -! build task list(s) using world_rank ranks if argument(s) are present -! NOTE: do-nothing tasks actually do do this, but calling them -! NOTE: "do-almost-nothing tasks" is not really all that illuminating - if (present(tasklist_compute)) then - numcomputetasks = lastproclist + 1 - nwt - allocate(tasklist_compute(numcomputetasks)) - if (nwt > 0) then - i2 = 1 - do i = 0,begwriterank-1 - tasklist_compute(i2) = proclist(i) - i2 = i2 + 1 - enddo - do i = endwriterank+1,lastproclist - tasklist_compute(i2) = proclist(i) - i2 = i2 + 1 - enddo - else - do i = 0,numcomputetasks-1 - tasklist_compute(i+1) = proclist(i) - enddo - endif -!SMS$IGNORE BEGIN - if (debugon) then - do i=0,num_tasks_world-1 - if (i == world_rank) then - write (6,'(a,i0,a,i0)') 'DEBUG0c: ',world_rank,' numcomputetasks = ',numcomputetasks - do n=1,numcomputetasks - write (6,'(a,i0,a,i0,a,i0)') 'DEBUG0c: ',world_rank,' tasklist_compute(',n,') = ',tasklist_compute(n) - enddo - endif - call flush(6) - CALL MPI_BARRIER (tmp_comm, ierr) - IF (ierr /= 0) THEN - PRINT *,'ERROR in DEBUG0c: MPI_BARRIER returned ',ierr - call flush(6) - CALL MPI_ABORT (MPI_COMM_WORLD, badret, ignore) - STOP - ENDIF - enddo - endif -!SMS$IGNORE END - endif - if (present(tasklist_write)) then -! allocate size=0 if nwt==0 - allocate(tasklist_write(nwt)) - if (nwt > 1) then - i2 = 1 - do i = begwriterank,endwriterank - tasklist_write(i2) = proclist(i) - i2 = i2 + 1 - enddo - endif -!SMS$IGNORE BEGIN - if (debugon) then - do i=0,num_tasks_world-1 - if (i == world_rank) then - write (6,'(a,i0,a,i0)') 'DEBUG0w: ',world_rank,' nwt = ',nwt - do n=1,nwt - write (6,'(a,i0,a,i0,a,i0)') 'DEBUG0w: ',world_rank,' tasklist_write(',n,') = ',tasklist_write(n) - enddo - endif - call flush(6) - CALL MPI_BARRIER (tmp_comm, ierr) - IF (ierr /= 0) THEN - PRINT *,'ERROR in DEBUG0w: MPI_BARRIER returned ',ierr - call flush(6) - CALL MPI_ABORT (MPI_COMM_WORLD, badret, ignore) - STOP - ENDIF - enddo - endif -!SMS$IGNORE END - endif - - deallocate(proclist) - deallocate(nodes) - -! Split the remaining MPI communicator into "compute" and "write" -! sections and create intercommunicators. -! Not surprisingly, do-nothing tasks skip this. - finish_core_setup: if (iam_fim_task.or.iam_write_task) then - - CALL MPI_COMM_DUP (fimcomm_tweaked, total_comm, ierr) - IF (ierr /= 0) THEN -!SMS$IGNORE BEGIN - PRINT *,'ERROR in core_setup_fim: MPI_COMM_DUP returned ',ierr - CALL MPI_ABORT (MPI_COMM_WORLD, badret, ignore) - STOP -!SMS$IGNORE END - ENDIF - - CALL MPI_COMM_SIZE (total_comm, num_tasks, ierr) - IF (ierr /= 0) THEN -!SMS$IGNORE BEGIN - PRINT *,'ERROR in core_setup_fim: MPI_COMM_SIZE returned ',ierr - CALL MPI_ABORT (MPI_COMM_WORLD, badret, ignore) - STOP -!SMS$IGNORE END - ENDIF - - CALL MPI_COMM_RANK (total_comm, my_rank, ierr) - IF (ierr /= 0) THEN -!SMS$IGNORE BEGIN - PRINT *,'ERROR in core_setup_fim: MPI_COMM_RANK returned ',ierr - CALL MPI_ABORT (MPI_COMM_WORLD, badret, ignore) - STOP -!SMS$IGNORE END - ENDIF - -! set up MPI communicators for FIM compute and optional write tasks - IF (nwt == 0) THEN - nct = num_tasks -! my_comm = total_comm - CALL MPI_COMM_DUP (total_comm, my_comm, ierr) - IF (ierr /= 0) THEN -!SMS$IGNORE BEGIN - PRINT *,'ERROR in core_setup_fim: MPI_COMM_DUP returned ',ierr - CALL MPI_ABORT (MPI_COMM_WORLD, badret, ignore) - STOP -!SMS$IGNORE END - ENDIF - ELSE ! nwt > 0: nwt < 0 already checked above - nct = num_tasks - nwt - IF (nct <= 0) THEN -!SMS$IGNORE BEGIN - PRINT *,'ERROR in core_setup_fim: number of MPI tasks (',num_tasks, & - ') <= num_write_tasks (',nwt,')' - CALL MPI_ABORT (MPI_COMM_WORLD, badret, ignore) - STOP -!SMS$IGNORE END - ENDIF -! Split the MPI communicator and create intercommunicators for -! FIM compute and write tasks. -! See comments above for details. - IF (iam_fim_task) THEN - color = 0 - ELSE - color = 1 - ENDIF - - CALL MPI_COMM_SPLIT (total_comm, color, my_rank, my_comm, ierr) - IF (ierr /= 0) THEN -!SMS$IGNORE BEGIN - PRINT *,'ERROR in core_setup_fim: MPI_COMM_SPLIT returned ',ierr - CALL MPI_ABORT (MPI_COMM_WORLD, badret, ignore) - STOP -!SMS$IGNORE END - ENDIF - IF (iam_fim_task) THEN -! call from FIM compute tasks: "remote leader" is begwriterank - CALL MPI_INTERCOMM_CREATE (my_comm, 0, total_comm, begwriterank, intercomm_tag, & - output_intercomm, ierr) - ELSE IF (iam_write_task) THEN -! call from write tasks: "remote leader" is root (0) -!TODO: extend to multiple groups of write tasks - CALL MPI_INTERCOMM_CREATE (my_comm, 0, total_comm, 0, intercomm_tag, & - output_intercomm, ierr) - ELSE -!SMS$IGNORE BEGIN - PRINT *,'ERROR in core_setup_fim: entered no-mans land where I am neither ', & - 'fim task nor write task nor do-nothing task' - CALL MPI_ABORT (MPI_COMM_WORLD, badret, ignore) - STOP -!SMS$IGNORE END - ENDIF - - IF (ierr /= 0) THEN -!SMS$IGNORE BEGIN - PRINT *,'ERROR in core_setup_fim: MPI_INTERCOMM_CREATE returned ',ierr - CALL MPI_ABORT (MPI_COMM_WORLD, badret, ignore) - STOP -!SMS$IGNORE END - ENDIF - ENDIF - - endif finish_core_setup - -! Execution of directive on all tasks ensures that SMS_INIT is called -! properly on the write tasks and on the do-nothing tasks. This allows -! these tasks to call NNT_STOP->NNT_EXIT without assertion errors. As -! a side-effect, duplicate messages are printed by the roots of the -! write and do-nothing groups during NNT_EXIT(). -! Finally, tell SMS what communicator to use. -! All tasks do this passing in their respective intra-communicators. -! NOTE: Executable SMS directives must not be placed before -! NOTE: this directive! -! NOTE: This includes writes or prints without !SMS$ignore because they -! NOTE: cause SMS to generate code. -!SMS$SET_COMMUNICATOR( my_comm ) - -!JR Print rank and node name. Useful for debugging assignment of tasks -!JR SMS$IGNORE keeps SMS from wrapping iam_root around the prints. - -!SMS$IGNORE BEGIN - if (iam_fim_task) then - write(6,'(a,i0,a,a)')'FIM Compute task rank ', my_rank, ' is running on node ', trim(mynode) - else if (iam_write_task) then - write(6,'(a,i0,a,a)')'FIM Write task rank ', my_rank, ' is running on node ', trim(mynode) - end if -!SMS$IGNORE END - - CALL IncrementTimer(t0,t1) -! print time only from FIM compute root - IF (iam_fim_task) THEN - PRINT *,'core_setup_fim time =',t1 - PRINT"(' Number of Write Tasks:' ,I24,' processors')",nwt - ENDIF - - core_setup_done = .true. - - end subroutine core_setup_fim - - logical function iam_compute_root() - logical, save :: first_call = .true. - logical, save :: save_result - logical::initialized - integer :: my_rank, ierr, ignore - if (first_call) then - save_result = .false. - call mpi_initialized(initialized,ierr) - if (.not.initialized) then ! serial run - save_result=.true. - else - if (iam_fim_task) then -! figure out who is the "root" of the compute tasks - CALL MPI_COMM_RANK (my_comm, my_rank, ierr) - IF (ierr /= 0) THEN -!SMS$IGNORE BEGIN - PRINT *,'ERROR in iam_compute_root: MPI_COMM_RANK returned ',ierr - CALL MPI_ABORT (MPI_COMM_WORLD, badret, ignore) - STOP -!SMS$IGNORE END - ENDIF - save_result = (my_rank == 0) - endif - endif - first_call = .false. - endif - iam_compute_root = save_result - end function iam_compute_root - -!TODO: remove duplication with iam_compute_root - logical function iam_write_root() - logical, save :: first_call = .true. - logical, save :: save_result - integer :: my_rank, ierr, ignore - if (first_call) then - save_result = .false. - if (.NOT.iam_fim_task) then -! figure out who is the "root" of the write tasks - CALL MPI_COMM_RANK (my_comm, my_rank, ierr) - IF (ierr /= 0) THEN -!SMS$IGNORE BEGIN - PRINT *,'ERROR in iam_write_root: MPI_COMM_RANK returned ',ierr - CALL MPI_ABORT (MPI_COMM_WORLD, badret, ignore) - STOP -!SMS$IGNORE END - ENDIF - save_result = (my_rank == 0) - endif - first_call = .false. - endif - iam_write_root = save_result - end function iam_write_root - -end module module_core_setup diff --git a/src/fim/FIMsrc/fim/horizontal/finalize.F90 b/src/fim/FIMsrc/fim/horizontal/finalize.F90 deleted file mode 100644 index a6c40b1..0000000 --- a/src/fim/FIMsrc/fim/horizontal/finalize.F90 +++ /dev/null @@ -1,38 +0,0 @@ -!********************************************************************* - subroutine finalize -! Stop program for icosahedral flow-following global model -! Alexander E. MacDonald 12/27/2004 -!********************************************************************* - -use module_control ,only: PrintMAXMINtimes -use module_core_setup ,only: iam_fim_task,iam_write_task -use module_fim_chem_finalize ,only: chem_finalize -use module_fim_cpl_finalize ,only: cpl_finalize -use module_fim_dyn_finalize ,only: dyn_finalize -use module_fim_phy_finalize ,only: phy_finalize -use module_fim_wrf_phy_finalize ,only: wrf_phy_finalize -use module_initial_chem_namelists,only: chem_opt -use module_outtime_main ,only: OutTime - -implicit none - -IF (iam_fim_task) THEN - print*,' ' - call cpl_finalize - call dyn_finalize - call phy_finalize - if (chem_opt.gt.0) then - call wrf_phy_finalize - call chem_finalize - endif - ! print elapsed times for main loop of FIM - call OutTime(PrintMAXMINtimes) - print*,' ' - ! call UnstructuredPrintTimers - call datetime - print*,'Program exited normally' -ENDIF - -return - -end subroutine finalize diff --git a/src/fim/FIMsrc/fim/horizontal/findmxmn.F90 b/src/fim/FIMsrc/fim/horizontal/findmxmn.F90 deleted file mode 100644 index 716bf89..0000000 --- a/src/fim/FIMsrc/fim/horizontal/findmxmn.F90 +++ /dev/null @@ -1,511 +0,0 @@ -! +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ -! this package contains routines for finding maxima/minima in -! distributed multidimensional arrays. in all cases the search extends -! over the s e c o n d array index associated with the distributed -! dimension. (obvious exception: 1-D arrays). -! additionally, there are routines for computing the mean value in the -! distributed dimension. -! if 'mask' is supplied, only points where mask=true will be searched. -! +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ - - -module findmaxmin1 -contains - subroutine findmxmn1(array,dim,what,mask) - -! --- find location of maximum and minimum in 1-D distributed array - - implicit none - integer,intent(IN) :: dim ! array dimension - character,intent(IN) :: what*(*) -!SMS$DISTRIBUTE (dh,dim) BEGIN - real,intent(IN) :: array(dim) - logical,intent(IN),optional :: mask(dim) -!SMS$DISTRIBUTE END - integer n,mini,maxi,mype,i - real locmin,locmax,globmn,globmx - logical scrutn,foundmax,foundmin - - -!SMS$PARALLEL (dh,n) BEGIN - mini=-999 - maxi=-999 - locmin= 1.e33 - locmax=-1.e33 - do n=1,dim - scrutn=.true. - if (present(mask)) scrutn=mask(n) - if (scrutn) then - if (array(n).lt.locmin) then - locmin=array(n) - mini=n - end if - if (array(n).gt.locmax) then - locmax=array(n) - maxi=n - end if - end if - end do - - globmn=locmin -!SMS$REDUCE(globmn,MIN) - if (locmin.eq.globmn) then - i=mini - call GetIpnGlobalMype(i,mini,mype,foundmin) - else - mini=-1 - end if - - globmx=locmax -!SMS$REDUCE(globmx,MAX) - if (locmax.eq.globmx) then - i=maxi - call GetIpnGlobalMype(i,maxi,mype,foundmax) - else - maxi=-1 - end if -!SMS$REDUCE(mini,maxi,MAX) -!SMS$PARALLEL END - - write (*,'(a,2(a,es13.6,a,i6))') trim(what), & - ': min=',globmn,' at ',mini, & - ' max=',globmx,' at ',maxi - - return - end subroutine findmxmn1 -end module findmaxmin1 - - -module findmaxmin2 -contains - subroutine findmxmn2(array,dim1,dim2,n1,what,mask) - -! --- find location of max and min in 2nd dimension of 2-D distributed array - - implicit none - integer,intent(IN) :: dim1,dim2 ! array dimensions - integer,intent(IN) :: n1 ! array index assoc. with dim1 - character,intent(IN) :: what*(*) -!SMS$DISTRIBUTE (dh,dim2) BEGIN - real,intent(IN) :: array(dim1,dim2) - logical,intent(IN),optional :: mask(dim2) -!SMS$DISTRIBUTE END - integer n2,mini,maxi,mype,i - real locmin,locmax,globmn,globmx - logical scrutn,foundmax,foundmin - -!SMS$PARALLEL (dh,n2) BEGIN - mini=-999 - maxi=-999 - locmin= 1.e33 - locmax=-1.e33 - do n2=1,dim2 - scrutn=.true. - if (present(mask)) scrutn=mask(n2) - if (scrutn) then - if (array(n1,n2).lt.locmin) then - locmin=array(n1,n2) - mini=n2 - end if - if (array(n1,n2).gt.locmax) then - locmax=array(n1,n2) - maxi=n2 - end if - end if - end do - - globmn=locmin -!SMS$REDUCE(globmn,MIN) - if (locmin.eq.globmn) then - i=mini - call GetIpnGlobalMype(i,mini,mype,foundmin) - else - mini=-1 - end if - - globmx=locmax -!SMS$REDUCE(globmx,MAX) - if (locmax.eq.globmx) then - i=maxi - call GetIpnGlobalMype(i,maxi,mype,foundmax) - else - maxi=-1 - end if -!SMS$REDUCE(mini,maxi,MAX) -!SMS$PARALLEL END - - write (*,'(a,2(a,es13.6,a,i6))') trim(what), & - ': min=',globmn,' at ',mini, & - ' max=',globmx,' at ',maxi - - return - end subroutine findmxmn2 -end module findmaxmin2 - - -module findmaxmin3 -contains - subroutine findmxmn3(array,dim1,dim2,dim3,n1,n3,what,mask) - -! --- find location of max and min in 2nd dimension of 3-D distributed array - - implicit none - integer,intent(IN) :: dim1,dim2,dim3 ! array dimensions - integer,intent(IN) :: n1,n3 ! indices assoc. with dim1/3 - character,intent(IN) :: what*(*) -!SMS$DISTRIBUTE (dh,dim2) BEGIN - real,intent(IN) :: array(dim1,dim2,dim3) - logical,intent(IN),optional :: mask(dim2) -!SMS$DISTRIBUTE END - integer n2,mini,maxi,mype - real locmin,locmax,globmn,globmx - logical scrutn,foundmax,foundmin - -!SMS$PARALLEL (dh,n2) BEGIN - mini=-999 - maxi=-999 - locmin= 1.e33 - locmax=-1.e33 - do n2=1,dim2 - scrutn=.true. - if (present(mask)) scrutn=mask(n2) - if (scrutn) then - if (array(n1,n2,n3).lt.locmin) then - locmin=array(n1,n2,n3) - mini=n2 - end if - if (array(n1,n2,n3).gt.locmax) then - locmax=array(n1,n2,n3) - maxi=n2 - end if - end if - end do - - globmn=locmin -!SMS$REDUCE(globmn,MIN) - if (locmin.eq.globmn) then - call GetIpnGlobalMype(mini,mini,mype,foundmin) - else - mini=-1 - end if - - globmx=locmax -!SMS$REDUCE(globmx,MAX) - if (locmax.eq.globmx) then - call GetIpnGlobalMype(maxi,maxi,mype,foundmax) - else - maxi=-1 - end if -!SMS$REDUCE(mini,maxi,MAX) -!SMS$PARALLEL END - - write (*,'(a,2(a,es13.6,a,i6))') trim(what), & - ': min=',globmn,' at ',mini, & - ' max=',globmx,' at ',maxi - - return - end subroutine findmxmn3 -end module findmaxmin3 - - -module findmaxmin4 -contains - subroutine findmxmn4(array,dim1,dim2,dim3,dim4,n1,n3,n4,what,mask) - -! --- find location of max and min in 2nd dimension of 4-D distributed array - - implicit none - integer,intent(IN) :: dim1,dim2,dim3,dim4 ! array dimensions - integer,intent(IN) :: n1,n3,n4 ! indices assoc.with dim1/3/4 - character,intent(IN) :: what*(*) -!SMS$DISTRIBUTE (dh,dim2) BEGIN - real,intent(IN) :: array(dim1,dim2,dim3,dim4) - logical,intent(IN),optional :: mask(dim2) -!SMS$DISTRIBUTE END - integer n2,mini,maxi,mype - real locmin,locmax,globmn,globmx - logical scrutn,foundmax,foundmin - -!SMS$PARALLEL (dh,n2) BEGIN - mini=-999 - maxi=-999 - locmin= 1.e33 - locmax=-1.e33 - do n2=1,dim2 - scrutn=.true. - if (present(mask)) scrutn=mask(n2) - if (scrutn) then - if (array(n1,n2,n3,n4).lt.locmin) then - locmin=array(n1,n2,n3,n4) - mini=n2 - end if - if (array(n1,n2,n3,n4).gt.locmax) then - locmax=array(n1,n2,n3,n4) - maxi=n2 - end if - end if - end do - - globmn=locmin -!SMS$REDUCE(globmn,MIN) - if (locmin.eq.globmn) then - call GetIpnGlobalMype(mini,mini,mype,foundmin) - else - mini=-1 - end if - - globmx=locmax -!SMS$REDUCE(globmx,MAX) - if (locmax.eq.globmx) then - call GetIpnGlobalMype(maxi,maxi,mype,foundmax) - else - maxi=-1 - end if -!SMS$REDUCE(mini,maxi,MAX) -!SMS$PARALLEL END - - write (*,'(a,2(a,es13.6,a,i6))') trim(what), & - ': min=',globmn,' at ',mini, & - ' max=',globmx,' at ',maxi - - return - end subroutine findmxmn4 -end module findmaxmin4 - - - subroutine findmean1(array,dim,what,mask) - -! --- find mean value in 1-D distributed array - - implicit none - integer,intent(IN) :: dim ! array dimensions - character,intent(IN) :: what*(*) -!SMS$DISTRIBUTE (dh,dim) BEGIN - real,intent(IN) :: array(dim) - logical,intent(IN),optional :: mask(dim) -!SMS$DISTRIBUTE END - integer n - logical scrutn - real globsum,count - real*8 locsum - -!SMS$PARALLEL (dh,n) BEGIN - locsum=0. - count=0. - do n=1,dim - scrutn=.true. - if (present(mask)) scrutn=mask(n) - if (scrutn) then - locsum=locsum+array(n) - count=count+1. - end if - end do - globsum=locsum/count -!SMS$REDUCE(globsum,SUM) -!SMS$PARALLEL END - - write (*,'(2a,es15.7)') trim(what),' mean value:',globsum - return - end subroutine findmean1 - - - subroutine findmean2(array,dim1,dim2,n1,what,mask) - -! --- find mean value in 2nd (distributed) dimension of 2-D array - - implicit none - integer,intent(IN) :: dim1,dim2 ! array dimensions - integer,intent(IN) :: n1 ! array index assoc. with dim1 - character,intent(IN) :: what*(*) -!SMS$DISTRIBUTE (dh,dim2) BEGIN - real,intent(IN) :: array(dim1,dim2) - logical,intent(IN),optional :: mask(dim2) -!SMS$DISTRIBUTE END - integer n2 - logical scrutn - real globsum,count - real*8 locsum - -!SMS$PARALLEL (dh,n2) BEGIN - locsum=0. - count=0. - do n2=1,dim2 - scrutn=.true. - if (present(mask)) scrutn=mask(n2) - if (scrutn) then - locsum=locsum+array(n1,n2) - count=count+1 - end if - end do - globsum=locsum/count -!SMS$REDUCE(globsum,SUM) -!SMS$PARALLEL END - - write (*,'(2a,es15.7)') trim(what),' mean value:',globsum - return - end subroutine findmean2 - - - subroutine findmean3(array,dim1,dim2,dim3,n1,n3,what,mask) - -! --- find mean value in 2nd (distributed) dimension of 3-D array - - implicit none - integer,intent(IN) :: dim1,dim2,dim3 ! array dimensions - integer,intent(IN) :: n1,n3 ! indices assoc. with dim1/3 - character,intent(IN) :: what*(*) -!SMS$DISTRIBUTE (dh,dim2) BEGIN - real,intent(IN) :: array(dim1,dim2,dim3) - logical,intent(IN),optional :: mask(dim2) -!SMS$DISTRIBUTE END - integer n2 - logical scrutn - real globsum,count - real*8 locsum - -!SMS$PARALLEL (dh,n2) BEGIN - locsum=0. - count=0. - do n2=1,dim2 - scrutn=.true. - if (present(mask)) scrutn=mask(n2) - if (scrutn) then - locsum=locsum+array(n1,n2,n3) - count=count+1. - end if - end do - globsum=locsum/count -!SMS$REDUCE(globsum,SUM) -!SMS$PARALLEL END - - write (*,'(2a,es15.7)') trim(what),' mean value:',globsum - return - end subroutine findmean3 - - - subroutine findmean4(array,dim1,dim2,dim3,dim4,n1,n3,n4,what,mask) - -! --- find mean value in 2nd (distributed) dimension of 4-D array - - implicit none - integer,intent(IN) :: dim1,dim2,dim3,dim4 ! array dimensions - integer,intent(IN) :: n1,n3,n4 ! indices assoc.with dim1/3/4 - character,intent(IN) :: what*(*) -!SMS$DISTRIBUTE (dh,dim2) BEGIN - real,intent(IN) :: array(dim1,dim2,dim3,dim4) - logical,intent(IN),optional :: mask(dim2) -!SMS$DISTRIBUTE END - integer n2 - logical scrutn - real globsum,count - real*8 locsum - -!SMS$PARALLEL (dh,n2) BEGIN - locsum=0. - count=0. - do n2=1,dim2 - scrutn=.true. - if (present(mask)) scrutn=mask(n2) - if (scrutn) then - locsum=locsum+array(n1,n2,n3,n4) - count=count+1. - end if - end do - globsum=locsum/count -!SMS$REDUCE(globsum,SUM) -!SMS$PARALLEL END - - write (*,'(2a,es15.7)') trim(what),' mean value:',globsum - return - end subroutine findmean4 - - -module edgmaxmin -contains - subroutine edgmxmn(array,kdm,what,mask) - -! --- find min/max in an edge array, i.e. an array dimensioned (kdm,npp,nip) - - use module_constants,only: nedge,permedge - use module_control ,only: nip,npp - implicit none - integer ,intent(IN) :: kdm -!SMS$DISTRIBUTE (dh,nip) BEGIN - real ,intent(IN) :: array(kdm,npp,nip) - logical,intent(IN),optional :: mask(nip) -!SMS$DISTRIBUTE END - character,intent(IN) :: what*(*) - integer ipn,edgcount,edg,k,minedg,maxedg,mink,maxk,minipn,maxipn, & - edgmin,edgmax,kmin,kmax,ipnmin,ipnmax - logical scrutn - real locmin,locmax,globmin,globmax,valmin,valmax - character*20 :: empt = ' ' - -! !SMS$PARALLEL (dh,ipn) BEGIN -! valmin=minval(array) -! valmax=maxval(array) -! !SMS$REDUCE(valmin,MIN) -! !SMS$REDUCE(valmax,MAX) -! !SMS$PARALLEL END -! print '(2a,2es15.7)',what,' min,max:',valmin,valmax - -!SMS$PARALLEL (dh,ipn) BEGIN -! !SMS$HALO_COMP(<1,1>) BEGIN - locmin= 1.e33 - locmax=-1.e33 - do ipn = 1,nip ! horizontal loop - scrutn=.true. - if (present(mask)) scrutn=mask(ipn) - if (scrutn) then - do edgcount = 1,nedge(ipn) ! loop through edges - edg = permedge(edgcount,ipn) - do k=1,kdm - if (array(k,edg,ipn).gt.locmax) then - locmax=array(k,edg,ipn) - maxedg=edg - maxk=k - maxipn=ipn - end if - if (array(k,edg,ipn).lt.locmin) then - locmin=array(k,edg,ipn) - minedg=edg - mink=k - minipn=ipn - end if - end do - end do - end if - end do - globmin=locmin - globmax=locmax -!SMS$REDUCE(globmin,MIN) -!SMS$REDUCE(globmax,MAX) - if (globmax.eq.locmax) then - ipnmax=maxipn - kmax=maxk - edgmax=maxedg - else - ipnmax=-1 - kmax=-1 - edgmax=-1 - end if - if (globmin.eq.locmin) then - ipnmin=minipn - kmin=mink - edgmin=minedg - else - ipnmin=-1 - kmin=-1 - edgmin=-1 - end if -!SMS$REDUCE(ipnmin,ipnmax,kmin,kmax,edgmin,edgmax,MAX) -! !SMS$HALO_COMP END -!SMS$PARALLEL END - - k=len_trim(what) - print 100,what(1:k),' min',globmin,' is at ipn,edg,k=',ipnmin,edgmin,kmin - print 100,empt(1:k),' max',globmax,' is at ipn,edg,k=',ipnmax,edgmax,kmax -100 format (2a,es15.7,a,i7,2i3) - return - end subroutine edgmxmn -end module edgmaxmin diff --git a/src/fim/FIMsrc/fim/horizontal/gfs_physics_internal_state_mod.F90 b/src/fim/FIMsrc/fim/horizontal/gfs_physics_internal_state_mod.F90 deleted file mode 100644 index 8ca2041..0000000 --- a/src/fim/FIMsrc/fim/horizontal/gfs_physics_internal_state_mod.F90 +++ /dev/null @@ -1,176 +0,0 @@ -! -! !module: gfs_physics_internal_state_mod -! --- internal state definition of the -! esmf gridded component of the gfs physics. -! -! !description: define the gfs physics internal state used to -! create the esmf internal state. -!--------------------------------------------------------------------------- -! !revision history: -! -! november 2004 weiyu yang initial code. -! may 2005 weiyu yang for the updated gfs version. -! february 2006 shrinivas moorthi updated for the new version of gfs -! january 2007 hann-ming henry juang for gfs dynamics only -! july 2007 shrinivas moorthi for gfs physics only -! november 2007 hann-ming henry juang continue for gfs physics -! february 2009 tom henderson adapt for FIM from nems r3038 -! -! !interface: -! - module gfs_physics_internal_state_mod -!SMS$IGNORE BEGIN - -!!uses: -!------ -!TBH remove nam_gfs_phy_namelist for now -!TBH use gfs_physics_namelist_mod, ONLY: nam_gfs_phy_namelist, gfs_phy_state_namelist - use gfs_physics_namelist_mod, ONLY: gfs_phy_state_namelist - use gfs_physics_sfc_flx_mod, ONLY: Sfc_Var_Data, Flx_Var_Data - - use machine, only: kind_phys, kind_rad, kind_evod - implicit none - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -!TBH: many fields removed for now, restoring them as I go... - -! ----------------------------------------------- - type gfs_physics_internal_state ! start type define -! ----------------------------------------------- - -!TBH type(nam_gfs_phy_namelist) :: nam_gfs_phy - type(gfs_phy_state_namelist) :: esmf_sta_list - - TYPE(Sfc_Var_Data) :: sfc_fld - TYPE(Flx_Var_Data) :: flx_fld - - integer :: me, nodes - INTEGER :: llgg_s, lonr_s, latr_s -! integer :: grib_inp - -! - integer ntrac,nxpt,nypt,jintmx,jcap,levs,lonr,latr,lats_node_r_max - integer ntoz, ntcw, ncld, lsoil, nmtvr, num_p2d,levr - integer :: num_p3d = 4 - logical :: ras=.false. - integer lats_node_r - integer thermodyn_id, sfcpress_id - - !TODO: move to module resol_def - integer nfxr - - character(16) :: cfhour1 - - integer :: nblck, kdt - real(kind=kind_phys) :: deltim - - integer ,allocatable :: lonsperlar (:) - integer ,allocatable :: lats_nodes_r (:) - integer ,allocatable :: global_lats_r (:) - integer ,allocatable :: lats_nodes_ext (:) - integer ,allocatable :: global_lats_ext(:) - - integer lotgr - real(kind=kind_evod) ,pointer :: ps(:) - real(kind=kind_evod) ,pointer :: dp(:,:) - real(kind=kind_evod) ,pointer :: dpdt(:,:) - real(kind=kind_evod) ,pointer :: p(:,:) - real(kind=kind_evod) ,pointer :: u(:,:) - real(kind=kind_evod) ,pointer :: v(:,:) - real(kind=kind_evod) ,pointer :: t(:,:) - real(kind=kind_evod) ,pointer :: q(:,:) - real(kind=kind_evod) ,pointer :: oz(:,:) - real(kind=kind_evod) ,pointer :: cld(:,:) - - REAL(KIND=KIND_RAD) ,ALLOCATABLE :: XLON(:,:),XLAT(:,:) - REAL(KIND=KIND_RAD) ,ALLOCATABLE :: COSZDG(:,:) - REAL(KIND=KIND_RAD) ,ALLOCATABLE :: sfalb(:,:) - REAL(KIND=KIND_RAD) ,ALLOCATABLE :: CLDCOV(:,:,:) - REAL(KIND=KIND_RAD) ,ALLOCATABLE :: HPRIME(:,:,:) - REAL(KIND=KIND_RAD) ,ALLOCATABLE :: SWH(:,:,:,:),HLW(:,:,:,:) - REAL(KIND=KIND_RAD) ,ALLOCATABLE :: FLUXR(:,:,:) -!! - - REAL(KIND=KIND_RAD) ,ALLOCATABLE :: phy_f3d(:,:,:,:,:) - REAL(KIND=KIND_RAD) ,ALLOCATABLE :: phy_f2d(:,:,:) -! -! carry fhour and initial date, may not be necessary later - real(kind=kind_evod) ,allocatable :: fhour_idate(:,:) - real(kind=kind_rad) :: phour - INTEGER :: KFHOUR - real, allocatable :: poz(:),ozplin(:,:,:,:) -! FOR OZON INTERPOLATION: - INTEGER,ALLOCATABLE:: JINDX1(:),JINDX2(:) -! - REAL,ALLOCATABLE:: DDY(:) - !TBH: promoted to arrays for FIM - !TODO: Is this really needed? - REAL(KIND=KIND_RAD) ,ALLOCATABLE :: SLAG(:,:),SDEC(:,:),CDEC(:,:) - - !TBH: added for FIM to avoid SAVE - REAL(KIND=KIND_PHYS) ,ALLOCATABLE :: acv(:,:),acvb(:,:),acvt(:,:) - - !TBH: added for FIM to mimic NMMB - !TBH: memory bounds - INTEGER :: ims,ime - !TBH: patch (distributed-memory loop) bounds - INTEGER :: ips,ipe - -!! -! for nasa ozon production and distruction rates:(input throu fixio_r) - integer lev,levmax -! - integer init,jcount,jpt,node - integer ibmsign - integer lon_dim,ilat - - real(kind=kind_evod) colat1 -!! -! real(kind=kind_evod) rone -! real(kind=kind_evod) rlons_lat -! real(kind=kind_evod) scale_ibm - - -! integer ibrad,ifges,ihour,ini,j,jdt,ksout,maxstp -! integer mdt,idt,timetot,timer,time0 -! integer mods,n1,n2,n3,n4,ndgf,ndgi,nfiles,nflps -! integer nges,ngpken,niter,nnmod,nradf,nradr -! integer nsfcf,nsfci,nsfcs,nsigi,nsigs,nstep -! integer nznlf,nznli,nznls,id,iret,nsout - - integer iret, n3, n4 - - integer ierr,iprint,k,l,locl,n - integer lan,lat - - real(kind=kind_phys) chour - real(kind=kind_phys) zhour - -! logical start_step -! logical end_step - logical lsout - - integer ikey,nrank_all,kcolor - - real(kind=kind_phys) cons0p5,cons1200,cons3600 !constant - real(kind=kind_phys) cons0 !constant - -! -! ----------------------------------------------------- - end type gfs_physics_internal_state ! end type define -! ----------------------------------------------------- - -! this state is supported by c pointer not f90 pointer, thus -! need this wrap. -!----------------------------------------------------------- - type gfs_phy_wrap ! begin type define - type (gfs_physics_internal_state), pointer :: int_state - end type gfs_phy_wrap ! end type define - -!TBH: temporary delcaration of int_state here -!TODO: move this elsewhere... - TYPE(gfs_physics_internal_state), pointer :: gis_phy - -!SMS$IGNORE END - end module gfs_physics_internal_state_mod diff --git a/src/fim/FIMsrc/fim/horizontal/gfs_physics_namelist_mod.F90 b/src/fim/FIMsrc/fim/horizontal/gfs_physics_namelist_mod.F90 deleted file mode 100644 index 4cf8d26..0000000 --- a/src/fim/FIMsrc/fim/horizontal/gfs_physics_namelist_mod.F90 +++ /dev/null @@ -1,136 +0,0 @@ -! -! !module: gfs_physics_namelist_mod --- definition of the name list -! in the esmf internal state. -! -! !description: define the name list variables -! in the esmf internal state. -!--------------------------------------------------------------------------- -! !revision history: -! -! november 2004 weiyu yang initial code. -! february 2006 took out model namelists -! january 2007 hann-ming henry juang for gfs dynamics only -! july 2007 shrinivas moorthi for gfs physics only -! november 2007 hann-ming henry juang for gfs physics -! -! !interface: -! - module gfs_physics_namelist_mod - - - implicit none - - type nam_gfs_phy_namelist - integer :: nlunit, total_member, member_id - real :: deltim - character(80) :: gfs_phy_namelist - character(20) :: sfc_ini - end type nam_gfs_phy_namelist -! - type gfs_phy_state_namelist -! -!For couple between dynamics and physics -!--------------------------------------- - integer :: idate1_import - integer :: z_import - integer :: ps_import - integer :: u_import - integer :: v_import - integer :: temp_import - integer :: q_import - integer :: oz_import - integer :: cld_import - integer :: p_import - integer :: dp_import - integer :: dpdt_import - - integer :: idate1_export - integer :: z_export - integer :: ps_export - integer :: u_export - integer :: v_export - integer :: temp_export - integer :: q_export - integer :: oz_export - integer :: cld_export - integer :: p_export - integer :: dp_export - integer :: dpdt_export - - -!For the surface file to couple with others or io -!---------------------------------------------------- - INTEGER :: orography_import - INTEGER :: t_skin_import - INTEGER :: soil_mois_import - INTEGER :: snow_depth_import - INTEGER :: soil_t_import - INTEGER :: deep_soil_t_import - INTEGER :: roughness_import - INTEGER :: conv_cloud_cover_import - INTEGER :: conv_cloud_base_import - INTEGER :: conv_cloud_top_import - INTEGER :: albedo_visible_scattered_import - INTEGER :: albedo_visible_beam_import - INTEGER :: albedo_nearIR_scattered_import - INTEGER :: albedo_nearIR_beam_import - INTEGER :: sea_level_ice_mask_import - INTEGER :: vegetation_cover_import - INTEGER :: canopy_water_import - INTEGER :: m10_wind_fraction_import - INTEGER :: vegetation_type_import - INTEGER :: soil_type_import - INTEGER :: zeneith_angle_facsf_import - INTEGER :: zeneith_angle_facwf_import - INTEGER :: uustar_import - INTEGER :: ffmm_import - INTEGER :: ffhh_import - INTEGER :: sea_ice_thickness_import - INTEGER :: sea_ice_concentration_import - INTEGER :: tprcp_import - INTEGER :: srflag_import - INTEGER :: actual_snow_depth_import - INTEGER :: liquid_soil_moisture_import - INTEGER :: vegetation_cover_min_import - INTEGER :: vegetation_cover_max_import - INTEGER :: slope_type_import - INTEGER :: snow_albedo_max_import - - INTEGER :: orography_export - INTEGER :: t_skin_export - INTEGER :: soil_mois_export - INTEGER :: snow_depth_export - INTEGER :: soil_t_export - INTEGER :: deep_soil_t_export - INTEGER :: roughness_export - INTEGER :: conv_cloud_cover_export - INTEGER :: conv_cloud_base_export - INTEGER :: conv_cloud_top_export - INTEGER :: albedo_visible_scattered_export - INTEGER :: albedo_visible_beam_export - INTEGER :: albedo_nearIR_scattered_export - INTEGER :: albedo_nearIR_beam_export - INTEGER :: sea_level_ice_mask_export - INTEGER :: vegetation_cover_export - INTEGER :: canopy_water_export - INTEGER :: m10_wind_fraction_export - INTEGER :: vegetation_type_export - INTEGER :: soil_type_export - INTEGER :: zeneith_angle_facsf_export - INTEGER :: zeneith_angle_facwf_export - INTEGER :: uustar_export - INTEGER :: ffmm_export - INTEGER :: ffhh_export - INTEGER :: sea_ice_thickness_export - INTEGER :: sea_ice_concentration_export - INTEGER :: tprcp_export - INTEGER :: srflag_export - INTEGER :: actual_snow_depth_export - INTEGER :: liquid_soil_moisture_export - INTEGER :: vegetation_cover_min_export - INTEGER :: vegetation_cover_max_export - INTEGER :: slope_type_export - INTEGER :: snow_albedo_max_export - end type gfs_phy_state_namelist - - end module gfs_physics_namelist_mod diff --git a/src/fim/FIMsrc/fim/horizontal/gfs_physics_sfc_flx_mod.F90 b/src/fim/FIMsrc/fim/horizontal/gfs_physics_sfc_flx_mod.F90 deleted file mode 100644 index db314dd..0000000 --- a/src/fim/FIMsrc/fim/horizontal/gfs_physics_sfc_flx_mod.F90 +++ /dev/null @@ -1,127 +0,0 @@ -! -! !MODULE: gfs_physics_sfc_flx_mod --- Definition of the surface -! fields in the ESMF internal state. -! -! !DESCRIPTION: gfs_physics_sfc_flx_mod --- Define the surfacee variables -! in the ESMF internal state. -!--------------------------------------------------------------------------- -! !REVISION HISTORY: -! -! March 2007 Shrinivas Moorthi Initial code. -! February 2009 Tom Henderson Adapted for FIM from nems r3038. -! -! !INTERFACE: -! - MODULE gfs_physics_sfc_flx_mod -!SMS$IGNORE BEGIN - - use machine , only : kind_phys - - IMPLICIT none - - TYPE Sfc_Var_Data - real(kind=kind_phys),pointer:: tsea(:,:)=>null() - real(kind=kind_phys),pointer:: smc(:,:,:)=>null() - real(kind=kind_phys),pointer:: sheleg(:,:)=>null() -!TBH: not used by FIM yet -! jbao new gfs phys - real(kind=kind_phys),pointer:: sncovr(:,:)=>null() - real(kind=kind_phys),pointer:: stc(:,:,:)=>null() - real(kind=kind_phys),pointer:: tg3(:,:)=>null() - real(kind=kind_phys),pointer:: zorl(:,:)=>null() - real(kind=kind_phys),pointer:: cv(:,:)=>null() - real(kind=kind_phys),pointer:: cvb(:,:)=>null() - real(kind=kind_phys),pointer:: cvt(:,:)=>null() - real(kind=kind_phys),pointer:: alvsf(:,:)=>null() - real(kind=kind_phys),pointer:: alvwf(:,:)=>null() - real(kind=kind_phys),pointer:: alnsf(:,:)=>null() - real(kind=kind_phys),pointer:: alnwf(:,:)=>null() - real(kind=kind_phys),pointer:: slmsk(:,:)=>null() - real(kind=kind_phys),pointer:: vfrac(:,:)=>null() - real(kind=kind_phys),pointer:: canopy(:,:)=>null() - real(kind=kind_phys),pointer:: f10m(:,:)=>null() - real(kind=kind_phys),pointer:: t2m(:,:)=>null() - real(kind=kind_phys),pointer:: q2m(:,:)=>null() - real(kind=kind_phys),pointer:: vtype(:,:)=>null() - real(kind=kind_phys),pointer:: stype(:,:)=>null() - real(kind=kind_phys),pointer:: facsf(:,:)=>null() - real(kind=kind_phys),pointer:: facwf(:,:)=>null() - real(kind=kind_phys),pointer:: uustar(:,:)=>null() - real(kind=kind_phys),pointer:: ffmm(:,:)=>null() - real(kind=kind_phys),pointer:: ffhh(:,:)=>null() - real(kind=kind_phys),pointer:: hice(:,:)=>null() - real(kind=kind_phys),pointer:: fice(:,:)=>null() -!TBH: not used by FIM yet -! jbao new gfs phys - real(kind=kind_phys),pointer:: tisfc(:,:)=>null() - real(kind=kind_phys),pointer:: tprcp(:,:)=>null() - real(kind=kind_phys),pointer:: srflag(:,:)=>null() - real(kind=kind_phys),pointer:: snwdph(:,:)=>null() - real(kind=kind_phys),pointer:: slc(:,:,:)=>null() - real(kind=kind_phys),pointer:: shdmin(:,:)=>null() - real(kind=kind_phys),pointer:: shdmax(:,:)=>null() - real(kind=kind_phys),pointer:: slope(:,:)=>null() - real(kind=kind_phys),pointer:: snoalb(:,:)=>null() -!TBH: not used by FIM yet -! real(kind=kind_phys),pointer:: oro(:,:)=>null() - end type Sfc_Var_Data -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - TYPE Flx_Var_Data - real(kind=kind_phys),pointer:: SFCDSW(:,:)=>null() - real(kind=kind_phys),pointer:: COSZEN(:,:)=>null() - real(kind=kind_phys),pointer:: TMPMIN(:,:)=>null() - real(kind=kind_phys),pointer:: TMPMAX(:,:)=>null() - real(kind=kind_phys),pointer:: DUSFC(:,:)=>null() - real(kind=kind_phys),pointer:: DVSFC(:,:)=>null() - real(kind=kind_phys),pointer:: DTSFC(:,:)=>null() - real(kind=kind_phys),pointer:: DQSFC(:,:)=>null() - real(kind=kind_phys),pointer:: DLWSFC(:,:)=>null() - real(kind=kind_phys),pointer:: ULWSFC(:,:)=>null() - real(kind=kind_phys),pointer:: GFLUX(:,:)=>null() - real(kind=kind_phys),pointer:: RUNOFF(:,:)=>null() - real(kind=kind_phys),pointer:: EP(:,:)=>null() - real(kind=kind_phys),pointer:: CLDWRK(:,:)=>null() - real(kind=kind_phys),pointer:: DUGWD(:,:)=>null() - real(kind=kind_phys),pointer:: DVGWD(:,:)=>null() - real(kind=kind_phys),pointer:: PSMEAN(:,:)=>null() - real(kind=kind_phys),pointer:: GESHEM(:,:)=>null() - !TBH: added RAINC, EVAP, HFLX for FIM - real(kind=kind_phys),pointer:: RAINC(:,:)=>null() - real(kind=kind_phys),pointer:: EVAP(:,:)=>null() - real(kind=kind_phys),pointer:: HFLX(:,:)=>null() - real(kind=kind_phys),pointer:: BENGSH(:,:)=>null() - real(kind=kind_phys),pointer:: SFCNSW(:,:)=>null() - real(kind=kind_phys),pointer:: SFCDLW(:,:)=>null() - real(kind=kind_phys),pointer:: TSFLW(:,:)=>null() - real(kind=kind_phys),pointer:: PSURF(:,:)=>null() - real(kind=kind_phys),pointer:: U10M(:,:)=>null() - real(kind=kind_phys),pointer:: V10M(:,:)=>null() - real(kind=kind_phys),pointer:: HPBL(:,:)=>null() - real(kind=kind_phys),pointer:: PWAT(:,:)=>null() -!TBH: not used by FIM yet -! real(kind=kind_phys),pointer:: CHH(:,:)=>null() -! real(kind=kind_phys),pointer:: CMM(:,:)=>null() -! jbao new gfs phys - real(kind=kind_phys),pointer:: EPI(:,:)=>null() -! real(kind=kind_phys),pointer:: DLWSFCI(:,:)=>null() -! real(kind=kind_phys),pointer:: ULWSFCI(:,:)=>null() -! real(kind=kind_phys),pointer:: USWSFCI(:,:)=>null() -! real(kind=kind_phys),pointer:: DSWSFCI(:,:)=>null() -! real(kind=kind_phys),pointer:: DTSFCI(:,:)=>null() -! real(kind=kind_phys),pointer:: DQSFCI(:,:)=>null() -! real(kind=kind_phys),pointer:: GFLUXI(:,:)=>null() -! real(kind=kind_phys),pointer:: SRUNOFF(:,:)=>null() -! real(kind=kind_phys),pointer:: T1(:,:)=>null() -! real(kind=kind_phys),pointer:: Q1(:,:)=>null() -! real(kind=kind_phys),pointer:: U1(:,:)=>null() -! real(kind=kind_phys),pointer:: V1(:,:)=>null() -! real(kind=kind_phys),pointer:: ZLVL(:,:)=>null() -! real(kind=kind_phys),pointer:: EVBSA(:,:)=>null() -! real(kind=kind_phys),pointer:: EVCWA(:,:)=>null() -! real(kind=kind_phys),pointer:: TRANSA(:,:)=>null() -! real(kind=kind_phys),pointer:: SBSNOA(:,:)=>null() -! real(kind=kind_phys),pointer:: SNOWCA(:,:)=>null() -! real(kind=kind_phys),pointer:: SOILM(:,:)=>null() - end type Flx_Var_Data -!SMS$IGNORE END - END MODULE gfs_physics_sfc_flx_mod diff --git a/src/fim/FIMsrc/fim/horizontal/gfs_physics_sfc_flx_set_mod.F90 b/src/fim/FIMsrc/fim/horizontal/gfs_physics_sfc_flx_set_mod.F90 deleted file mode 100644 index dde1ba0..0000000 --- a/src/fim/FIMsrc/fim/horizontal/gfs_physics_sfc_flx_set_mod.F90 +++ /dev/null @@ -1,225 +0,0 @@ -! -! !MODULE: gfs_physics_sfc_flx_mod --- Definition of the surface -! fields in the ESMF internal state. -! -! !DESCRIPTION: gfs_physics_sfc_flx_mod --- Define the surfacee variables -! in the ESMF internal state. -!--------------------------------------------------------------------------- -! !REVISION HISTORY: -! -! March 2007 Shrinivas Moorthi Initial code. -! February 2009 Tom Henderson Adapted for FIM from nems r3038. -! -! !INTERFACE: -! - MODULE gfs_physics_sfc_flx_set_mod -!SMS$IGNORE BEGIN - - use infnan , only: inf - - IMPLICIT none - - contains - subroutine sfcvar_aldata(dim1s, dim1e, dim2, dim3, sfc_fld, iret) - - USE gfs_physics_sfc_flx_mod, ONLY: Sfc_Var_Data - - implicit none - TYPE(Sfc_Var_Data), INTENT(inout) :: sfc_fld - integer, intent(in) :: dim1s, dim1e, dim2, dim3 - - integer, intent(out) :: iret -! -allocate( & - sfc_fld%tsea (dim1s:dim1e,dim2), & - sfc_fld%smc (dim3,dim1s:dim1e,dim2),& - sfc_fld%sheleg (dim1s:dim1e,dim2), & -!TBH: not used by FIM yet -! jbao new gfs phys - sfc_fld%sncovr (dim1s:dim1e,dim2), & - sfc_fld%stc (dim3,dim1s:dim1e,dim2),& - sfc_fld%tg3 (dim1s:dim1e,dim2), & - sfc_fld%zorl (dim1s:dim1e,dim2), & - sfc_fld%cv (dim1s:dim1e,dim2), & - sfc_fld%cvb (dim1s:dim1e,dim2), & - sfc_fld%cvt (dim1s:dim1e,dim2), & - sfc_fld%alvsf (dim1s:dim1e,dim2), & - sfc_fld%alvwf (dim1s:dim1e,dim2), & - sfc_fld%alnsf (dim1s:dim1e,dim2), & - sfc_fld%alnwf (dim1s:dim1e,dim2), & - sfc_fld%slmsk (dim1s:dim1e,dim2), & - sfc_fld%vfrac (dim1s:dim1e,dim2), & - sfc_fld%canopy (dim1s:dim1e,dim2), & - sfc_fld%f10m (dim1s:dim1e,dim2), & - sfc_fld%t2m (dim1s:dim1e,dim2), & - sfc_fld%q2m (dim1s:dim1e,dim2), & - sfc_fld%vtype (dim1s:dim1e,dim2), & - sfc_fld%stype (dim1s:dim1e,dim2), & - sfc_fld%facsf (dim1s:dim1e,dim2), & - sfc_fld%facwf (dim1s:dim1e,dim2), & - sfc_fld%uustar (dim1s:dim1e,dim2), & - sfc_fld%ffmm (dim1s:dim1e,dim2), & - sfc_fld%ffhh (dim1s:dim1e,dim2), & - sfc_fld%hice (dim1s:dim1e,dim2), & - sfc_fld%fice (dim1s:dim1e,dim2), & -!TBH: not used by FIM yet -! jbao new gfs phys - sfc_fld%tisfc (dim1s:dim1e,dim2), & - sfc_fld%tprcp (dim1s:dim1e,dim2), & - sfc_fld%srflag (dim1s:dim1e,dim2), & - sfc_fld%snwdph (dim1s:dim1e,dim2), & - sfc_fld%slc (dim3,dim1s:dim1e,dim2),& - sfc_fld%shdmin (dim1s:dim1e,dim2), & - sfc_fld%shdmax (dim1s:dim1e,dim2), & - sfc_fld%slope (dim1s:dim1e,dim2), & - sfc_fld%snoalb (dim1s:dim1e,dim2), & -!TBH: not used by FIM yet -! sfc_fld%oro (dim1s:dim1e,dim2), & - stat=iret) - if(iret.ne.0) iret=-3 -#ifndef LAHEY - sfc_fld%tsea(:,:) = inf - sfc_fld%smc(:,:,:) = inf - sfc_fld%sheleg(:,:) = inf - sfc_fld%sncovr(:,:) = inf - sfc_fld%stc(:,:,:) = inf - sfc_fld%tg3(:,:) = inf - sfc_fld%zorl(:,:) = inf - sfc_fld%cv(:,:) = inf - sfc_fld%cvb(:,:) = inf - sfc_fld%cvt(:,:) = inf - sfc_fld%alvsf(:,:) = inf - sfc_fld%alvwf(:,:) = inf - sfc_fld%alnsf(:,:) = inf - sfc_fld%alnwf(:,:) = inf - sfc_fld%slmsk(:,:) = inf - sfc_fld%vfrac(:,:) = inf - sfc_fld%canopy(:,:) = inf - sfc_fld%f10m(:,:) = inf - sfc_fld%t2m(:,:) = inf - sfc_fld%q2m(:,:) = inf - sfc_fld%vtype(:,:) = inf - sfc_fld%stype(:,:) = inf - sfc_fld%facsf(:,:) = inf - sfc_fld%facwf(:,:) = inf - sfc_fld%uustar(:,:) = inf - sfc_fld%ffmm(:,:) = inf - sfc_fld%ffhh(:,:) = inf - sfc_fld%hice(:,:) = inf - sfc_fld%fice(:,:) = inf -#endif - - return - end subroutine - subroutine flxvar_aldata(dim1s, dim1e, dim2, flx_fld, iret) - - USE gfs_physics_sfc_flx_mod, ONLY: Flx_Var_Data - implicit none - TYPE(Flx_Var_Data), INTENT(inout) :: flx_fld - integer, intent(in) :: dim1s, dim1e, dim2 - - integer, intent(out) :: iret -! - allocate( & - flx_fld%SFCDSW (dim1s:dim1e,dim2), & - flx_fld%COSZEN (dim1s:dim1e,dim2), & - flx_fld%TMPMIN (dim1s:dim1e,dim2), & - flx_fld%TMPMAX (dim1s:dim1e,dim2), & - flx_fld%DUSFC (dim1s:dim1e,dim2), & - flx_fld%DVSFC (dim1s:dim1e,dim2), & - flx_fld%DTSFC (dim1s:dim1e,dim2), & - flx_fld%DQSFC (dim1s:dim1e,dim2), & - flx_fld%DLWSFC (dim1s:dim1e,dim2), & - flx_fld%ULWSFC (dim1s:dim1e,dim2), & - flx_fld%GFLUX (dim1s:dim1e,dim2), & - flx_fld%RUNOFF (dim1s:dim1e,dim2), & - flx_fld%EP (dim1s:dim1e,dim2), & - flx_fld%CLDWRK (dim1s:dim1e,dim2), & - flx_fld%DUGWD (dim1s:dim1e,dim2), & - flx_fld%DVGWD (dim1s:dim1e,dim2), & - flx_fld%PSMEAN (dim1s:dim1e,dim2), & - flx_fld%GESHEM (dim1s:dim1e,dim2), & - !TBH: added RAINC, EVAP, HFLX for FIM - flx_fld%RAINC (dim1s:dim1e,dim2), & - flx_fld%EVAP (dim1s:dim1e,dim2), & - flx_fld%HFLX (dim1s:dim1e,dim2), & - flx_fld%BENGSH (dim1s:dim1e,dim2), & - flx_fld%SFCNSW (dim1s:dim1e,dim2), & - flx_fld%SFCDLW (dim1s:dim1e,dim2), & - flx_fld%TSFLW (dim1s:dim1e,dim2), & - flx_fld%PSURF (dim1s:dim1e,dim2), & - flx_fld%U10M (dim1s:dim1e,dim2), & - flx_fld%V10M (dim1s:dim1e,dim2), & - flx_fld%HPBL (dim1s:dim1e,dim2), & - flx_fld%PWAT (dim1s:dim1e,dim2), & -!TBH: not used by FIM yet -! flx_fld%CHH (dim1s:dim1e,dim2), & -! flx_fld%CMM (dim1s:dim1e,dim2), & -! jbao new gfs phys - flx_fld%EPI (dim1s:dim1e,dim2), & -! flx_fld%DLWSFCI (dim1s:dim1e,dim2), & -! flx_fld%ULWSFCI (dim1s:dim1e,dim2), & -! flx_fld%USWSFCI (dim1s:dim1e,dim2), & -! flx_fld%DSWSFCI (dim1s:dim1e,dim2), & -! flx_fld%DTSFCI (dim1s:dim1e,dim2), & -! flx_fld%DQSFCI (dim1s:dim1e,dim2), & -! flx_fld%GFLUXI (dim1s:dim1e,dim2), & -! flx_fld%SRUNOFF (dim1s:dim1e,dim2), & -! flx_fld%T1 (dim1s:dim1e,dim2), & -! flx_fld%Q1 (dim1s:dim1e,dim2), & -! flx_fld%U1 (dim1s:dim1e,dim2), & -! flx_fld%V1 (dim1s:dim1e,dim2), & -! flx_fld%ZLVL (dim1s:dim1e,dim2), & -! flx_fld%EVBSA (dim1s:dim1e,dim2), & -! flx_fld%EVCWA (dim1s:dim1e,dim2), & -! flx_fld%TRANSA (dim1s:dim1e,dim2), & -! flx_fld%SBSNOA (dim1s:dim1e,dim2), & -! flx_fld%SNOWCA (dim1s:dim1e,dim2), & -! flx_fld%SOILM (dim1s:dim1e,dim2), & - stat=iret) - - if(iret.ne.0) iret=-4 - return - end subroutine - - subroutine flx_init(flx_fld, iret) - - USE gfs_physics_sfc_flx_mod, ONLY: Flx_Var_Data - implicit none - TYPE(Flx_Var_Data), INTENT(inout) :: flx_fld - - integer, intent(out) :: iret -! - flx_fld%TMPMIN = 1.e4 - flx_fld%TMPMAX = 0. - flx_fld%GESHEM = 0. - !TBH: added RAINC for FIM - flx_fld%RAINC = 0. - flx_fld%BENGSH = 0. - flx_fld%DUSFC = 0. - flx_fld%DVSFC = 0. - flx_fld%DTSFC = 0. - flx_fld%DQSFC = 0. - flx_fld%DLWSFC = 0. - flx_fld%ULWSFC = 0. - flx_fld%GFLUX = 0. -! - flx_fld%RUNOFF = 0. - flx_fld%EP = 0. - flx_fld%CLDWRK = 0. - flx_fld%DUGWD = 0. - flx_fld%DVGWD = 0. - flx_fld%PSMEAN = 0. -! -!TBH: not used by FIM yet -! flx_fld%EVBSA = 0. -! flx_fld%EVCWA = 0. -! flx_fld%TRANSA = 0. -! flx_fld%SBSNOA = 0. -! flx_fld%SNOWCA = 0. -! flx_fld%SRUNOFF = 0. - - return - end subroutine -!SMS$IGNORE END - END MODULE gfs_physics_sfc_flx_set_mod diff --git a/src/fim/FIMsrc/fim/horizontal/globsum.F90 b/src/fim/FIMsrc/fim/horizontal/globsum.F90 deleted file mode 100644 index 8f0ce33..0000000 --- a/src/fim/FIMsrc/fim/horizontal/globsum.F90 +++ /dev/null @@ -1,118 +0,0 @@ -module module_globsum - use module_control, only: nvl, nvlp1, nip, dt, ntra, ntrb - use module_constants, only: grvity, area, cp, rd - - implicit none - - real :: qmstrold ! save previous value - real :: qmstrcold ! save previous value - real :: qmstrnold ! save previous value - logical :: qdtr_set = .false. - -!JR These things were moved from dyn_run to here for restart capability. - - real :: qmass - real :: qmsqv - real :: qmsqw - real :: qmste - real :: qmstr = 0. - real :: qmstrn = 0. - real :: qmstrc = 0. - real :: qdtr - real :: qdtrn - real :: qdtrc - -contains - -!********************************************************************* -! globsum -! Calculate global sums of various useful quantities -! Alexander E. MacDonald 11/14/2005 -! J. Lee 01/04/2006 -! J. Rosinski 10/03/2011 -! Modified for restart capability -!********************************************************************* - - subroutine globsum (its, dp3d, tr, rn2d, rc2d, pr3d, ex3d, qf2d, qtrcr) - integer, intent(in) :: its -!SMS$DISTRIBUTE (dh,nip) BEGIN - real, intent(in) :: dp3d(nvl,nip) - real, intent(in) :: tr(nvl,nip,ntra+ntrb) - real, intent(in) :: rn2d(nip) ! from PHY via CPL - real, intent(in) :: rc2d(nip) ! from PHY via CPL - real, intent(in) :: pr3d(nvlp1,nip) - real, intent(in) :: ex3d(nvlp1,nip) - real, intent(in) :: qf2d(nip) ! from PHY via CPL -!SMS$DISTRIBUTE END - real, intent(out) :: qtrcr(ntra+ntrb) - -! Local variables - integer :: ipn ! Index for icos point number - integer :: k ! Index vertical level - integer :: t ! Index for tracer type - real :: den - real*8 :: summ,smqv,smqw,sumr,sume,sumrc,sumrn,sumtr(ntra+ntrb) - - summ = 0. - smqv = 0. - smqw = 0. - sumr = 0. - sume = 0. - sumrc = 0. - sumrn = 0. - sumtr(:) = 0. -!SMS$PARALLEL (dh,ipn) BEGIN - do ipn=1,nip - do k=1,nvl - summ = summ + area(ipn)*dp3d(k,ipn) ! integrated mass - smqv = smqv + area(ipn)*dp3d(k,ipn)*tr(k,ipn,2) ! integrated water vapor - smqw = smqw + area(ipn)*dp3d(k,ipn)*tr(k,ipn,3) ! integrated condensate - end do - - sumr = sumr + area(ipn)*rn2d(ipn) ! integrated precipitation - sumrc = sumrc + area(ipn)*rc2d(ipn) ! integrated sub-gridscale (conv) precip - sumrn = sumrn + area(ipn)*(rn2d(ipn)-rc2d(ipn)) ! integrated resolved precip - den = pr3d(1,ipn)/((rd/cp)*ex3d(1,ipn)*tr(1,ipn,1)) - sume = sume+area(ipn)*den*qf2d(ipn)*dt ! integrated evaporation - - do t=1,ntra+ntrb - do k=1,nvl - sumtr(t) = sumtr(t) + area(ipn)*dp3d(k,ipn)*tr(k,ipn,t) ! tracer - end do - end do - end do ! horizontal loop - - summ = summ/grvity - smqv = smqv/grvity - smqw = smqw/grvity -!sms$reduce(summ,smqv,smqw,sumr,sume,sumrc,sumrn,SUM) -!SMS$PARALLEL END - - qmass = summ - qmsqv = smqv - qmsqw = smqw - qmste = sume - qtrcr(:) = sumtr(:) -! save previous values - qmstrold = qmstr - qmstrcold = qmstrc - qmstrnold = qmstrn -! store new values - qmstr = sumr - qmstrc = sumrc - qmstrn = sumrn - - if (qdtr_set) then - qdtr = qmstr - qmstrold - qdtrn = qmstrn - qmstrnold - qdtrc = qmstrc - qmstrcold - else - qdtr = 0. - qdtrn = 0. - qdtrc = 0. - qdtr_set = .true. - end if - - return - end subroutine globsum -end module module_globsum diff --git a/src/fim/FIMsrc/fim/horizontal/hybgen.F90 b/src/fim/FIMsrc/fim/horizontal/hybgen.F90 deleted file mode 100644 index c35c195..0000000 --- a/src/fim/FIMsrc/fim/horizontal/hybgen.F90 +++ /dev/null @@ -1,1847 +0,0 @@ -module module_hybgen -use findmaxmin2 -contains -!*********************************************************************** -! hybgen -! Adapted from 2nd generation restep-based grid generator in HYCOM -! R. Bleck Mar 2006 -! R. Bleck Mar 2008 arbitrary number of tracers -! R. Bleck Jul 2009 inflation of top layers -! R. Bleck Nov 2009 merged with hybgen_sig -! S. Sun Nov 2009 added option to smooth th-dot -! S. Sun Nov 2009 added lateral intfc smoothing option -!*********************************************************************** - - subroutine hybgen (its, & - targt, & ! target potential temperature (1-D) - us3d,vs3d, & ! horiz.velocity (3-D) - tr3d, & ! mass field tracers (ntra 3-D fields) - sdot, & ! intfc displacement sdot*(dp/ds)*dt (3-D) - ex3d,dp3d,pr3d ) ! Exner function, layer thknss, pressure (3-D) - - use module_control ,only: nvl,nvlp1,ntra,kbl,nip,dt, & - PrintIpnDiag,PrintDiags, & - intfc_smooth,pure_sig - use module_constants,only: p1000,rd,cp,sigak,sigbk - use module_variables,only: worka,workb - use module_dffusn_lev - use module_dffusn_lyr - implicit none - -! Type and dimension external variables: - - integer,intent(IN) :: its ! model time step - real ,intent(IN) :: targt(nvl) ! target pot.temp. -!SMS$DISTRIBUTE (dh,nip) BEGIN - real ,intent(INOUT) :: tr3d(nvl,nip,ntra) ! mass field tracers - real ,intent(INOUT) :: ex3d(nvlp1,nip) ! Exner function - real ,intent(INOUT) :: dp3d(nvl ,nip) ! layer thickness - real ,intent(INOUT) :: pr3d(nvlp1,nip) ! pressure - real ,intent(OUT) :: sdot(nvlp1,nip) ! sdot*(dp/ds) - real ,intent(INOUT) :: us3d(nvl ,nip) ! u velocity - real ,intent(INOUT) :: vs3d(nvl ,nip) ! v velocity - -! Type and dimension of local variables: - - real :: exsmo3d(nvlp1,nip) ! 3d array for smoothing - real :: exdif3d(nvl,nip) -!SMS$DISTRIBUTE END - integer :: ipn,k,k1,k2 - logical :: vrbos ! switch for 'verbose' mode - real :: ucol(nvl),vcol(nvl) ! velocity column vectors - real :: dpcol(nvl),prcol(nvlp1) ! thknss, pres column vectors - real :: excol(nvlp1) ! Exner fcn column vector - real :: exsmo(nvlp1) ! smoothed Exner fcn col.vector - real :: trcol(nvl,ntra) ! tracer column vectors - real :: thcol(nvl) ! theta col.vector for remap - real :: valmin - logical :: thsmoo = .false. ! use smoothed thdot in thcol - character :: string*20 - real :: smoo_coeff(nvlp1),taper - -! taper(k1,k2)=float(k2-k1)**2/(19.+float(k2-k1)**2) ! range: 0.05...1 - taper(k1,k2)=float(k2-k1)**2/( 9.+float(k2-k1)**2) ! range: 0.1....1 -! taper(k1,k2)=float(k2-k1)**2/( 4.+float(k2-k1)**2) ! range: 0.2....1 -! taper(k1,k2)=float(k2-k1)**4/(19.+float(k2-k1)**4) ! range: 0.05...1 -! taper(k1,k2)=float(k2-k1)**4/( 9.+float(k2-k1)**4) ! range: 0.1....1 -! taper(k1,k2)=float(k2-k1)**4/( 4.+float(k2-k1)**4) ! range: 0.2....1 - -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! --- if thsmoo=true, smooth diabatic theta increment (thdot) laterally. -! --- the smoothed field is used o n l y to determine coordinate movement -! --- (regridding). the regular theta field (tracer 1) is not smoothed. - - if (pure_sig) then - thsmoo =.false. - intfc_smooth=0. - end if - - if (thsmoo .and. its.gt.0) then -!SMS$PARALLEL(dh, ipn) BEGIN - workb(:,:)=tr3d(:,:,1)-worka(:,:) ! worka = theta before physics call -!SMS$PARALLEL END - - call dffusn_lyr(workb,dp3d,dt*20.) ! lateral thdot smoothing - -!SMS$PARALLEL(dh, ipn) BEGIN - worka(:,:)=worka(:,:)+workb(:,:) -!SMS$PARALLEL END - else ! thsmoo = false -!SMS$PARALLEL(dh, ipn) BEGIN - worka(:,:)=tr3d(:,:,1) -!SMS$PARALLEL END - end if ! thsmoo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!SMS$PARALLEL(dh, ipn) BEGIN -!sms$compare_var(ex3d, "hybgen.F90 - ex3d7 ") - - do ipn=1,nip ! loop over icos grid - vrbos=ipn.eq.PrintIpnDiag - -! if (vrbos .and. pure_sig) then -!!SMS$IGNORE BEGIN -! write (6,'(a/(5f14.6))') '(hybgen) sigak array:',sigak -! write (6,'(a/(5f14.6))') '(hybgen) sigbk array:',sigbk -!!SMS$IGNORE END -! end if - -! --- call single-column version of hybgen - -! --- interface smoothing requires separation of regridding and remappping. -! --- step 1: subr. regrid_1d does the regridding -! --- step 2: subr. dffusn_lev does the (optional) interface smoothing -! --- step 3: subr. remap_1d does the remapping, i.e., it vertically advects -! --- all prognostic variables (after re-inflating layers that may -! --- have become too thin during smoothing) - - thcol(:) = worka(:,ipn) - excol(:) = ex3d(:,ipn) - prcol(:) = pr3d(:,ipn) - - call regrid_1d(its,targt,thcol,excol,prcol,vrbos,ipn,PrintDiags) - - exsmo3d(:,ipn) = excol(:) - enddo ! loop over icos grid -!SMS$PARALLEL END - -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if (intfc_smooth.gt.0.) then -! --- make smoothing coefficient a function of layer index - smoo_coeff(1:kbl+1)=0. ! don't modify lowest -kbl- layers - do k=kbl+2,nvl - smoo_coeff(k)=dt*intfc_smooth*taper(k,kbl+1)*taper(k,nvlp1) - end do - - if (intfc_smooth.gt.0.) call dffusn_lev(exsmo3d,smoo_coeff,nvlp1,kbl+2,nvl) - -! --- check occasionally whether smoothing is generating neg.lyr.thknss - if (mod(its,100).eq.0) then - do k=nvl/3,2*nvl/3 -!SMS$PARALLEL(dh, ipn) BEGIN - do ipn=1,nip - exdif3d(k,ipn)=exsmo3d(k,ipn)-exsmo3d(k+1,ipn) - end do - valmin=minval(exdif3d(k,:)) -!SMS$REDUCE(valmin,MIN) -!SMS$PARALLEL END - if (valmin.lt.0.) then - write (string,'(a,i2)') 'exdif aftr smoo k=',k - call findmxmn2(exdif3d,nvl,nip,k,string) - end if - end do ! k loop - end if - end if ! intfc_smooth -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!SMS$PARALLEL(dh, ipn) BEGIN - do ipn=1,nip ! loop over icos grid - vrbos=ipn.eq.PrintIpnDiag - - trcol(:,:) = tr3d(:,ipn,:) - excol(:) = ex3d(:,ipn) - dpcol(:) = dp3d(:,ipn) - prcol(:) = pr3d(:,ipn) - ucol (:) = us3d(:,ipn) - vcol (:) = vs3d(:,ipn) - exsmo(:) = exsmo3d(:,ipn) - - call remap_1d(its,targt,ntra,trcol,ucol,vcol,excol,exsmo, & - dpcol,prcol,vrbos,ipn,PrintDiags) - - tr3d(:,ipn,:) = trcol(:,:) - sdot(:,ipn) = excol(:)-ex3d(:,ipn) - ex3d(:,ipn) = excol(:) - dp3d(:,ipn) = dpcol(:) - pr3d(:,ipn) = prcol(:) - us3d(:,ipn) = ucol (:) - vs3d(:,ipn) = vcol (:) - - end do ! loop over icos grid - -!!sms$compare_var(ex3d, "hybgen.F90 - ex3d8 ") -!SMS$PARALLEL END - - return - end subroutine hybgen - - - subroutine regrid_1d(its,targt,thcol,excol,prcol,vrbos,ipn,PrintDiags) - - use module_control ,only: nvl,nvlp1,kbl,nip,dt,thktop,pure_sig,ptop - use module_constants,only: p1000,rd,cp,dpsig,grvity,deg_lat,deg_lon, & - sigak,sigbk - implicit none - - real,intent(IN) :: prcol(nvlp1) ! must be consistent with excol - real,intent(INOUT) :: excol(nvlp1) ! must be consistent with prcol - real,intent(IN) :: targt(nvl) ! target pot.temp. - real,intent(INOUT) :: thcol(nvl) ! actual pot.temp. - integer,intent(IN) :: its,ipn - logical,intent(IN) :: vrbos,PrintDiags - -! Type and dimension of local variables: - - integer :: k,k1,k2,iter ! layer/level indices - real :: thnew(nvl) ! new pot.temp. - real :: exnew(nvlp1) ! new Exner function - real :: exwrk(nvlp1) ! intermediate column values - real :: heatfx(nvl) ! turbulent vertical heat flux - real :: arg,wgt1,wgt2,try,coeff,cnv - real :: ex2p,dex2dp,p2ex,dp2dex - real :: eqlb_slak - logical :: event - real,parameter :: dffudt=.1 ! therm.diffu.coeff x time step [m^2] - real,parameter :: thin=rd/p1000 ! approx. 1 Pa in Exner fcn units - real,parameter :: tolrnce=0.001 ! in degrees - - ex2p(arg)=p1000*(arg/cp)**(cp/rd) ! convert Pi => p - p2ex(arg)=cp*(arg/p1000)**(rd/cp) ! convert p => Pi - - eqlb_slak=.1*float(its)/(10.+float(its)) - -!SMS$IGNORE BEGIN - if (vrbos) then - write (6,99) its,ipn,deg_lat(ipn),deg_lon(ipn),'i n p u t profile:' - do k2=1,nvl,10 - write (6,100) (prcol(k1),k1=k2,min(nvlp1,k2+10) ) - write (6,102) (excol(k1),k1=k2,min(nvlp1,k2+10) ) - write (6,101) (thcol(k1),k1=k2,min(nvl ,k2+9 ) ) - write (6,101) (targt(k1),k1=k2,min(nvl ,k2+9 ) ) - write (6,101) - end do - end if - 99 format ('its,ipn=',i6,i8,' lat/lon=',2f7.1,' hybgen ',a/ & - '(4-line groups: pressure, exn.fcn, theta, target)') - 100 format (-2p,11f7.1) - 102 format ( 11f7.1) - 101 format (5x,10f7.2) -!SMS$IGNORE END - - do k=1,nvl - if (excol(k).lt.excol(k+1)-thin) then -!SMS$IGNORE BEGIN - write (6,99) its,ipn,deg_lat(ipn),deg_lon(ipn),'i n p u t profile:' - do k2=1,nvl,10 - write (6,100) (prcol(k1),k1=k2,min(nvlp1,k2+10) ) - write (6,102) (excol(k1),k1=k2,min(nvlp1,k2+10) ) - write (6,101) (thcol(k1),k1=k2,min(nvl ,k2+9 ) ) - write (6,101) (targt(k1),k1=k2,min(nvl ,k2+9 ) ) - write (6,101) - end do - write (6,103) 'nonmonotonic Exner function on input at ipn,k =', & - ipn,k,excol(k),excol(k+1) - 103 format (a,i8,i4,2f9.2) -!SMS$IGNORE END -! stop '(error: non-monotonic Exner fcn)' - excol(k+1)=excol(k) - end if - end do - - if (pure_sig) then - -! if (vrbos) then -! write (6,'(a/(5f14.6))') '(regrid_1d) sigak array:',sigak -! write (6,'(a/(5f14.6))') '(regrid_1d) sigbk array:',sigbk -! end if - -! --- ><><><><><><><><><><><><><><><><><><> -! --- restore to sigma coordinate grid -! --- ><><><><><><><><><><><><><><><><><><> - - exnew( 1)=excol( 1) - exnew(nvlp1)=excol(nvlp1) - do k=2,nvl -! --- sigak,sigbk define the sigma-p levels used in the GFS model. - exnew(k)=p2ex(sigak(k)+sigbk(k)*prcol(1)) - end do - - if (vrbos) then -!SMS$IGNORE BEGIN - write (6,98) its,ipn,'o u t p u t p r e s s u r e' - 98 format ('time step',i6,' ipn=',i8,' hybgen ',a) - do k2=1,nvl,10 - write (6,100) (ex2p(exnew(k1)),k1=k2,min(nvlp1,k2+10) ) - end do -!SMS$IGNORE END - end if - else - -! --- ><><><><><><><><><><><><><><><><><><> -! --- restore to hybrid-isentropic grid -! --- ><><><><><><><><><><><><><><><><><><> - - ! --- eliminate static instabilities - - do k=nvl-1,1,-1 - thcol(k)=min(thcol(k),thcol(k+1)) - end do - exwrk(:)=excol(:) - -! --- 'thcol' profile is now stably (or neutrally) stratified. - -! --- check whether theta values exceed 'targt' range at bottom of column. -! --- if so, homogenize layers to eliminate this condition - -!? do k=1,nvl-1 -!? if (thcol(k).ge.targt(1)-tolrnce) then -!? exit ! no action required -!? else -!? ! --- average of layers 1...k colder than lowest target -!? -!? !SMS$IGNORE BEGIN -!? if (vrbos) then -!? write (*,107) ipn,'lyrs',1,k+1,' bfore range limiting:', & -!? (exwrk(k2),thcol(k2),k2=1,k+1),exwrk(k+2) -!? end if -!? !SMS$IGNORE END -!? -!? ! --- compute pot.temp. obtained by homogenizing layers 1,...,k+1 -!? wgt1=max(thin,exwrk(k )-exwrk(k+1)) -!? wgt2=max( 0.,exwrk(k+1)-exwrk(k+2)) -!? try=(thcol(k)*wgt1+thcol(k+1)*wgt2)/(wgt1+wgt2) -!? if (try.lt.targt(1)+tolrnce) then -!? ! --- average of layers 1,...,k+1 still too cold. continue adding layers -!? exwrk(k+1)=exwrk(1) -!? do k1=1,k+1 -!? thcol(k1)=try -!? end do -!? -!? !SMS$IGNORE BEGIN -!? if (vrbos) then -!? write (*,107) ipn,'lyrs',1,k+1,' after range limiting:', & -!? (exwrk(k2),thcol(k2),k2=1,k+1),exwrk(k+2) -!? end if -!? !SMS$IGNORE END -!? -!? else -!? ! --- adding all of layer k+1 is overkill; entrain only part of lyr k+1 -!? exwrk(k+1)=min(exwrk(k ),max(exwrk(k+2), & -!? (exwrk(k )*(thcol(k )-targt(1)) & -!? + exwrk(k+1)*(thcol(k+1)-thcol(k))) & -!? / (thcol(k+1)-targt(1)))) -!? do k1=1,k -!? thcol(k1)=targt(1) -!? end do -!? -!? !SMS$IGNORE BEGIN -!? if (vrbos) then -!? write (*,107) ipn,'lyrs',1,k+1,' after range limiting:', & -!? (exwrk(k2),thcol(k2),k2=1,k+1),exwrk(k+2) -!? end if -!? !SMS$IGNORE END -!? -!? exit ! range limiting completed -!? end if -!? end if -!? end do - -! --- check whether theta values exceed 'targt' range at top of column. -! --- if so, homogenize layers to eliminate this condition - - do k=nvl,2,-1 - if (thcol(k).le.targt(nvl)+tolrnce) then - exit ! no action required - else -! --- average of layers k...nvl warmer than highest target - - if (vrbos) then -!SMS$IGNORE BEGIN - write (*,107) ipn,'lyrs',k-1,nvl,' bfore range limiting:', & - (exwrk(k2),thcol(k2),k2=k-1,nvl),exwrk(nvlp1) -!SMS$IGNORE END - end if - -! --- compute pot.temp. obtained by homogenizing layers k-1,...,nvl - wgt1=max( 0.,exwrk(k-1)-exwrk(k )) - wgt2=max(thin,exwrk(k )-exwrk(k+1)) - try=(thcol(k-1)*wgt1+thcol(k)*wgt2)/(wgt1+wgt2) - if (try.gt.targt(nvl)-tolrnce) then -!---average of layers k-1,...,nvl still too warm. continue adding layers - exwrk(k)=exwrk(nvlp1) - do k1=k-1,nvl - thcol(k1)=try - end do - - if (vrbos) then -!SMS$IGNORE BEGIN - write (*,107) ipn,'lyrs',k-1,nvl,' after range limiting:',& - (exwrk(k2),thcol(k2),k2=k-1,nvl),exwrk(nvlp1) -!SMS$IGNORE END - end if - - else -! --- adding all of layer k-1 is overkill; entrain only part of lyr k-1 - exwrk(k)=min(exwrk(k-1),max(exwrk(k+1), & - (exwrk(k )*(thcol(k )-thcol(k-1)) & - + exwrk(k+1)*(targt(nvl)-thcol(k ))) & - / (targt(nvl)-thcol(k-1)))) - do k1=k,nvl - thcol(k1)=targt(nvl) - end do - - if (vrbos) then -!SMS$IGNORE BEGIN - write (*,107) ipn,'lyrs',k-1,nvl,' after range limiting:', & - (exwrk(k2),thcol(k2),k2=k-1,nvl),exwrk(nvlp1) -!SMS$IGNORE END - end if - - exit ! range limiting completed - end if - end if - end do - 107 format (i8,2x,a,i3,'-',i2,a,20(f7.1,f8.3)) - -! --- now convert column to purely isentropic coordinates, i.e., -! --- find pressure levels where all pot.temps are on target - - call restp_1d(thcol,exwrk,nvl,thnew,exnew,targt,nvl,vrbos,ipn) - -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! --- invoke heat diffusion (McDougall-Dewar) to inflate thin layers - - heatfx(nvl)=0. - heatfx( 1)=0. - do iter=1,3 ! apply the scheme repeatedly - exwrk(:)=exnew(:) - do k=2,nvl-1 - heatfx(k)=0. - if (exwrk(k ).lt.exwrk( 1)-.01 .and. & - exwrk(k+1).gt.exwrk(nvlp1)+.01) then - cnv=grvity/targt(k) ! Exner fcn units/meter - heatfx(k)=dffudt*cnv*cnv*.5*(targt(k+1)-targt(k-1)) & - /max(.03*cnv,exwrk(k)-exwrk(k+1)) - end if - end do - do k=1,nvl-1 - if (exwrk(k+1).lt.exwrk( 1)-.01 .and. & - exwrk(k+1).gt.exwrk(nvlp1)+.01) & - exnew(k+1)=max(exwrk(k+2),min(exwrk(k), & - exwrk(k+1)+(heatfx(k+1)-heatfx(k))/(targt(k+1)-targt(k)))) - end do - event=.false. - do k=2,nvlp1 - if (exnew(k).gt.exnew(k-1)+thin) then - event=.true. -!SMS$IGNORE BEGIN - print '(a,i8,i4,a,2F8.1)','dp<0 due to heat diffusion at ipn,k=', & - ipn,k,' lat/lon =',deg_lat(ipn),deg_lon(ipn) -!SMS$IGNORE END - end if - end do ! iter - - if (vrbos .or. event) then -!SMS$IGNORE BEGIN - print '(i8,a,i2,a)',ipn,' heat diffusion, iter',iter, & - ' Ex.fcn (3-line groups: old,new,dif x 10^4)' - do k2=1,nvl,10 - write (6,108) (exwrk(k1),k1=k2,min(nvlp1,k2+9) ) - write (6,108) (exnew(k1),k1=k2,min(nvlp1,k2+9) ) - write (6,109) (int(1.e4*(exnew(k1)-exwrk(k1))),k1=k2,min(nvlp1,k2+9) ) - write (6,108) - end do - 108 format (10f8.2) - 109 format (10i8) -!SMS$IGNORE END - end if - - if (.not.event) exit - end do ! iter -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! --- suppress comput.mode causing gradual depletion of alternate layers - - call equilb(thnew,exnew,nvl,eqlb_slak,vrbos,ipn,PrintDiags) - -! --- inflate massless layers - - call inflate(ipn,prcol(1),exnew) - - end if ! pure sigma or hybrid-isentropic option - - if (vrbos) then -!SMS$IGNORE BEGIN - write (6,104) ipn,' hybgen: old Exner fcn (excol)',excol - write (6,104) ipn,' hybgen: new Exner fcn (exnew)',exnew - write (6,104) ipn,' hybgen: Exner fcn tndcy (displ)',exnew-excol - 104 format (i8,a/(8f9.2)) -!SMS$IGNORE END - end if - - excol(:)=exnew(:) - return - end subroutine regrid_1d -end module module_hybgen ! SMS doesn't like multiple routines in module - - - subroutine remap_1d(its,targt,ntra,trcol,ucol,vcol,excol,exsmo, & - dpcol,prcol,vrbos,ipn,PrintDiags) - - use module_control ,only: nvl,nvlp1,kbl,nip,dt,thktop,pure_sig, & - intfc_smooth,slak - use module_constants,only: p1000,rd,cp,dpsig,deg_lat,deg_lon - implicit none - - integer,intent(IN) :: ntra ! number of tracer fields - real,intent(INOUT) :: trcol(nvl,ntra),ucol(nvl),vcol(nvl), & - excol(nvlp1),dpcol(nvl),prcol(nvlp1) - real,intent(IN) :: targt(nvl) ! target pot.temp. - real,intent(IN) :: exsmo(nvlp1) ! Exner fcn after regridding & smoothing - integer,intent(IN) :: its,ipn - logical,intent(IN) :: vrbos,PrintDiags - -! Type and dimension of local variables: - - integer :: k,k1,k2,n ! layer/level indices - real :: trnew(nvl,ntra) ! new tracers (1=pot.temp.) - real :: prnew(nvlp1) ! new pres & lyr thickness - real :: exnew(nvlp1) ! new Exner fcn - real :: unew(nvl),vnew(nvl) ! new velocities - real :: exwrk(nvlp1) ! intermediate column values - real :: thwrk(nvlp1) ! intermediate column values - real :: pk1col(nvlp1) ! vert.coord. used for theta remap - real :: pk1new(nvlp1) ! vert.coord. used for theta remap - - real :: arg,colin,clout,qq - real :: ex2p - real :: dplo,dpup,devilo,deviup,tha,thb - real :: kappa(nvl),avgkap(nvl) ! variables used in kappa diagno - real :: exdif(nvlp1),rmsdsp ! variables used in kappa diagno - real :: exsav(nvlp1) ! variables used in kappa diagno - - logical,parameter :: kappa_diag=.FALSE. ! vertical diffusivity diagno - real ,parameter :: small=1.e-6 - real ,parameter :: acurcy=1.3e-6 ! for 32-bit word length - - integer,parameter :: cnsv=1 ! cnsv=1: conserve pot+intern.energy -! integer,parameter :: cnsv=2 ! cnsv=2: conserve column height - - ex2p(arg)=p1000*(arg/cp)**(cp/rd) ! convert Pi => p - - if (cnsv.eq.1) pk1col=excol*prcol ! pk1 = p^{kappa+1) - if (cnsv.eq.2) pk1col=excol ! pk1 = p^k (Exner fcn) - - exnew(:)=exsmo(:) - - if (.not.pure_sig) then - if (intfc_smooth.gt.0.) call inflate(ipn,prcol(1),exnew) - do k=1,nvlp1 -! --- (optional:) retard restoration to reduce overshooting - if (its.gt.0) exnew(k)=slak*exnew(k)+(1.-slak)*excol(k) - end do - end if - -! --- update pressure, layer thickness, pressure^(kappa+1) - - do k=nvlp1,1,-1 - prnew(k)=ex2p(exnew(k)) - if (k.le.nvl) dpcol(k)=prnew(k)-prnew(k+1) - end do - - if (cnsv.eq.1) pk1new=exnew*prnew ! pk1 = p^(kappa+1) - if (cnsv.eq.2) pk1new=exnew ! pk1 = p^k (Exner fcn) - - prnew (nvlp1)=prcol (nvlp1) ! safeguard against roundoff error - pk1new(nvlp1)=pk1col(nvlp1) ! safeguard against roundoff error - prnew (1)=prcol (1) ! safeguard against roundoff error - pk1new(1)=pk1col(1) ! safeguard against roundoff error - -! --- interface movement spawns vertical advection of dependent variables. -! --- we have 3 advection choices: PCM,PLM,PPM. use in any combination by -! --- selectively activating lines below. (one subr. call per variable!) - -!!call pcmadv(prcol, ucol,nvl,prnew, unew,nvl,.false.,ipn) ! u vel. - call plmadv(prcol, ucol,nvl,prnew, unew,nvl,.false.,ipn) ! u vel. -!!call ppmadv(prcol, ucol, prnew, unew,nvl,.false.,ipn) ! u vel. - -!!call pcmadv(prcol, vcol,nvl,prnew, vnew,nvl,.false.,ipn) ! v vel. - call plmadv(prcol, vcol,nvl,prnew, vnew,nvl,.false.,ipn) ! v vel. -!!call ppmadv(prcol, vcol, prnew, vnew,nvl,.false.,ipn) ! v vel. - - do n=2,ntra ! all tracers except pot.temp -!! call pcmadv(prcol,trcol(1,n),nvl,prnew,trnew(1,n),nvl,.false.,ipn) - call plmadv(prcol,trcol(1,n),nvl,prnew,trnew(1,n),nvl,.false.,ipn) -!! call ppmadv(prcol,qvcol(1,n), prnew,trnew(1,n),nvl,.false.,ipn) - end do - -! --- now advect pot.temp (k=1) -!!call pcmadv(pk1col,trcol,nvl,pk1new,trnew,nvl,vrbos,ipn) ! theta - call plmadv(pk1col,trcol,nvl,pk1new,trnew,nvl,vrbos,ipn) ! theta -!!call ppmadv(pk1col,trcol, pk1new,trnew,nvl,vrbos,ipn) ! theta - - if (.not.pure_sig) then -! --- redistribute theta among neighboring layers to help them stay on target. -! --- this is to counteract a comput.mode associated with vertical advection - - do k=nvl,3,-1 - dplo=max(pk1new(k-1)-pk1new(k ),pk1new(1)*small) - dpup=max(pk1new(k )-pk1new(k+1),pk1new(1)*small) - tha=trnew(k-1,1) - thb=trnew(k ,1) - devilo=(tha-targt(k-1))*dplo - deviup=(thb-targt(k ))*dpup - if (deviup.gt.0. .and. devilo.lt.0.) then - trnew(k-1,1)=tha+min(deviup,-devilo)/dplo - trnew(k ,1)=thb-min(deviup,-devilo)/dpup - else & - if (deviup.lt.0. .and. devilo.gt.0.) then - trnew(k-1,1)=tha-min(devilo,-deviup)/dplo - trnew(k ,1)=thb+min(devilo,-deviup)/dpup - end if - - if (vrbos .and. deviup*devilo.lt.0.) then -!SMS$IGNORE BEGIN - write (6,'(a,i8,i4,2(3x,a,2f9.4))') 'ipn,k =',ipn,k, & - 'targ dev''n',tha-targt(k-1),thb-targt(k),'cut to', & - trnew(k-1,1)-targt(k-1),trnew(k,1)-targt(k) -!SMS$IGNORE END - end if - end do - -! --- fill massless cells with data from mass-containing layer below - - if (thktop.eq.0.) then - do k=3,nvl - qq=1./(dpcol(k)+small) - ucol(k)=(ucol(k)*dpcol(k)+ucol(k-1)*small)*qq - vcol(k)=(vcol(k)*dpcol(k)+vcol(k-1)*small)*qq - trnew(k,2:ntra)=(trnew(k,2:ntra)*dpcol(k)+trnew(k-1,2:ntra)*small)*qq - end do - end if - - end if ! hybrid-isentropic option - -! --- column integrals (colin/clout) are for diagnostic purposes only - colin=0. - clout=0. - do k=1,nvl - colin=colin+trcol(k,1)*(pk1col(k)-pk1col(k+1)) - clout=clout+trnew(k,1)*(pk1new(k)-pk1new(k+1)) - end do - - if (abs(clout-colin).gt.acurcy*abs(colin)) then -!SMS$IGNORE BEGIN - write (6,106) ipn,'hybgen - column intgl.error', & - colin,clout,(clout-colin)/colin - 106 format (i8,3x,a,2es14.6,es9.1) - end if -!SMS$IGNORE END - - !-------------------------------------------------------------------- - ! --- vertical diffusivity diagnostics (optional) - - rmsdsp=0. - do k=1,nvl - rmsdsp=rmsdsp+(exnew(k+1)-excol(k+1))**2 - end do - rmsdsp=sqrt(rmsdsp/float(nvl)) - - if (kappa_diag .and. rmsdsp.gt..01) then - thwrk(:)=trnew(:,1) - exwrk(:)=exnew(:) - call restp_1d(thwrk,exwrk,nvl,trnew,exnew,targt,nvl,vrbos,ipn) - exdif( 1)=0. - exdif(nvlp1)=0. - do k=2,nvl - exdif(k)=(exnew(k)-exsav(k))/dt - end do - - call diagkp(nvl,exsav,exdif,targt,kappa,.false.,ipn) -!!! call diagkp(nvl,exsav,exdif,targt,kappa,.false.,ipn) - if (minval(kappa).lt.-1.e-2) then -!!! if (maxval(kappa).gt. 1.e-2) then - call diagkp(nvl,exsav,exdif,targt,kappa,.true.,ipn) - -!SMS$IGNORE BEGIN - write (6,'(a,2i5,5x,a/12(f6.1))') 'its,ipn =',its,ipn, & - 'vert.diffusivity (cm^2/s):',(1.e4*kappa(k),k=2,nvl-1) -!!! print *,'maxval:',maxval(kappa) - print *,'minval:',minval(kappa) -!SMS$IGNORE END - - end if - avgkap(:)=avgkap(:)+kappa(:) - end if ! diffusivity diagnostics - -!SMS$IGNORE BEGIN - if (kappa_diag .and. mod(its,15).eq.0) & - write (6,'(a,i5,5x,a/12(f6.1))') 'its =',its, & - 'avg.vert.diffusivity (cm^2/s):',(1.e4*avgkap(k)/nip,k=2,nvl-1) -!SMS$IGNORE END - !-------------------------------------------------------------------- - - ucol(:)=unew(:) - vcol(:)=vnew(:) - trcol(:,:)=trnew(:,:) - excol(:)=exnew(:) - prcol(:)=prnew(:) - - do k=1,nvl - if (excol(k).lt.excol(k+1)) then -!SMS$IGNORE BEGIN - write (6,99) its,ipn,deg_lat(ipn),deg_lon(ipn),'o u t p u t profile:' - do k2=1,nvl,10 - write (6,100) (prcol(k1) ,k1=k2,min(nvlp1,k2+10) ) - write (6,102) (excol(k1) ,k1=k2,min(nvlp1,k2+10) ) - write (6,101) (trcol(k1,1),k1=k2,min(nvl ,k2+9 ) ) - write (6,101) (targt(k1) ,k1=k2,min(nvl ,k2+9 ) ) - write (6,101) - end do - write (6,103) 'nonmonotonic Exner function on return at ipn,k =', & - ipn,k,excol(k),excol(k+1) - 103 format (a,i8,i4,2f9.2) -!SMS$IGNORE END -! stop '(error: non-monotonic Exner fcn)' - excol(k+1)=excol(k) - end if - end do - - if (vrbos) then -!SMS$IGNORE BEGIN - write (6,99) its,ipn,deg_lat(ipn),deg_lon(ipn),'o u t p u t profile:' - do k2=1,nvl,10 - write (6,100) (prcol(k1) ,k1=k2,min(nvlp1,k2+10) ) - write (6,102) (excol(k1) ,k1=k2,min(nvlp1,k2+10) ) - write (6,101) (trcol(k1,1),k1=k2,min(nvl ,k2+9 ) ) - write (6,101) (targt(k1) ,k1=k2,min(nvl ,k2+9 ) ) - write (6,101) - end do - 99 format ('its,ipn=',i6,i8,' lat/lon=',2f7.1,' hybgen ',a/ & - '(4-line groups: pressure, exn.fcn, theta, target)') - 100 format (-2p,11f7.1) - 102 format ( 11f7.1) - 101 format (5x,10f7.2) -!SMS$IGNORE END - end if - - return - end subroutine remap_1d - - - subroutine restp_1d(thold,pkold,kold,thnew,pknew,targt,knew,vrbos,ipn) - -! --- convert a stairstep (i.e., piecewise constant) theta profile into a -! --- stairstep profile constrained to have prescribed theta ('targt') steps. - -! --- input variables: thold,pkold,targt,kold,knew,vrbos -! --- output variables: thnew,pknew - - use module_constants, only: cp,rd,p1000 - - implicit none - integer,intent(IN) :: kold,knew,ipn - real,intent(IN) :: thold(kold),pkold(kold+1),targt(knew) - real,intent(OUT) :: thnew(knew),pknew(knew+1) - logical,intent(IN) :: vrbos - - integer k,ko - real oldth(kold) - real cloutt,colint,pinteg,tha,thb,ex2p,arg - real, parameter :: acurcy=1.e-6 - - ex2p(arg)=p1000*(arg/cp)**(cp/rd) ! convert Pi => p (mb) - - if (vrbos) then -!SMS$IGNORE BEGIN - write (6,101) ipn, & - 'restp1 -- input profile: theta thknss press p^kap', & - ex2p(pkold(1)),pkold(1), & - (k,thold(k),ex2p(pkold(k))-ex2p(pkold(k+1)),ex2p(pkold(k+1)), & - pkold(k+1),k=1,kold) - 101 format (i8,4x,a/54x,f9.1,f11.3/(33x,i3,f9.3,2f9.1,f11.3)) -!SMS$IGNORE END - end if - -! --- remove theta inversions from input profile - oldth(kold)=thold(kold) - do k=kold,2,-1 - oldth(k-1)=min(oldth(k),thold(k-1)) - end do - - thnew(:)=targt(:) - thnew( 1)=min(oldth(1),oldth(kold),targt( 1)) - thnew(knew)=max(oldth(1),oldth(kold),targt(knew)) - pknew( 1)=pkold( 1) - pknew(knew+1)=pkold(kold+1) - -! --- column integrals (colin/clout) are computed for diagnostic purposes only - - cloutt=0. - colint=0. - do k=1,kold - colint=colint+oldth(k)*(pkold(k+1)-pkold(k)) - end do - -! --- find interface pknew(k+1) separating layers k and k+1 by requiring -! --- that integral over pk*d(theta) from thnew(k) to thnew(k+1) be preserved. - - ko=1 - do k=1,knew-1 - pinteg=0. - thb=thnew(k) - 5 tha=thb - thb=min(thnew(k+1),max(thnew(k),oldth(ko))) - pinteg=pinteg+pkold(ko)*(thb-tha) - if (oldth(ko) < thnew(k+1)) then - if (ko.lt.kold) then - ko=ko+1 - go to 5 - end if - tha=thb - thb=thnew(k+1) - pinteg=pinteg+pkold(kold+1)*(thb-tha) - end if - pknew(k+1)=pknew(k) - if (thnew(k+1) > thnew(k)) pknew(k+1)=pinteg/(thnew(k+1)-thnew(k)) - cloutt=cloutt+thnew(k)*(pknew(k+1)-pknew(k)) - enddo - - cloutt=cloutt+thnew(knew)*(pknew(knew+1)-pknew(knew)) - if (abs(cloutt-colint).gt.acurcy*abs(colint)) then -!SMS$IGNORE BEGIN - write (6,100) ipn,'restp1 - column intgl.error', & - colint,cloutt,(cloutt-colint)/colint - 100 format (i8,3x,a,2es14.6,es9.1) -!SMS$IGNORE END - end if - - if (vrbos) then -!SMS$IGNORE BEGIN - write (6,101) ipn, & - 'restp1 -- outpt profile: theta thknss press p^kap', & - ex2p(pknew(1)),pknew(1), & - (k,thnew(k),ex2p(pknew(k))-ex2p(pknew(k+1)),ex2p(pknew(k+1)), & - pknew(k+1),k=1,knew) -!SMS$IGNORE END - end if - - return - end subroutine restp_1d - - - subroutine inflate(ipn,psurf,exner) - -! --- <><><><><><<><><><><><><><><><><><><><><><><> -! --- hybridization (inflation of massless layers) -! --- <><><><><><<><><><><><><><><><><><><><><><><> - - use module_constants, only: cp,rd,p1000,dpsig - use module_control ,only: nvl,nvlp1,kbl,PrintIpnDiag,thktop,ptop - - implicit none - integer, intent(IN) :: ipn ! icos index - real , intent(IN) :: psurf ! surface pressure - real , intent(INOUT) :: exner(nvlp1) ! Exner function - - real :: dp0,dp1,dpsum,arg,arg1,exold,q,extop - real :: dex2dp,dp2dex,shrink,top,cushn,taper - integer :: last,k,k1,k2 - logical :: vrbos ! switch for 'verbose' mode - real,parameter :: thin=rd/p1000 ! approx. 1 Pa in Exner fcn units - -! taper(k1,k2)=1./float(k2-k1) - taper(k1,k2)=1./(1.+(.25*(k2-k1))**2) -! taper(k1,k2)=1./(1.+(.5*(k2-k1))**2) -! dex2dp(arg)=p1000*arg/rd ! convert d Pi => dp (for p ~ p1000) - dp2dex(arg)=rd*arg/p1000 ! convert dp => d Pi (for p ~ p1000) - -! --- simplified cushion function suitable for nonnegative first argument - cushn(arg,arg1)=.25*min(arg,2.*arg1)**2/arg1+max(arg,2.*arg1)-arg1 -! cushn(arg,arg1)=arg1 ! no cushn - - vrbos=ipn.eq.PrintIpnDiag - - dpsum=0. - extop=cp*(ptop/p1000)**(rd/cp) - top=.2 ! sigma layers are shrunk in proportion to (psurf-top) - shrink=min(1.,(psurf/p1000-top)/(1.-top)) - last=1 - -! --- step 1: inflate layers from bottom up - - do k=1,nvl-1 - -! --- set lower limits for layer thknss (dp0) -! --- and upper limits for upper intfc pressure (dpsum) - - dp0=dp2dex(dpsig(k))*shrink ! convert to Exner fcn, shrink abv mountains - dpsum=dpsum+dp0 ! minimum cumulative distance to ground - exold=exner(k+1) -! if (exner(k)-dp0.lt.extop) then -!!SMS$IGNORE BEGIN -! print '(2a,i8,i4,a,f9.2)','warning: stack of min.thknss layers', & -! ' extends past top of atmosphere at ipn,k=',ipn,k,' extop=',extop -!!SMS$IGNORE END -! end if - - if (k.le.kbl) then -! --- maintain -kbl- fixed-depth layers near surface - dp1=dp0 - last=k+1 - exner(k+1)=exner(k)-dp1 - - else ! k > kbl - if (k.gt.last) then ! out of sigma domain -> reduce dp0 - dp0=dp0/min(20.,1.25*2.**(k-last)) -!! dp0=dp0/min(100.,12.5*2.**(k-last)) -!! dp0=dp0/min(100.,12.5*float(k-last)**2) -!! dp0=dp0/min(10. ,1.25*float(k-last)**2) -! next line sets 1 hPa as minimum thickness in isentropically resolved layers -! 26 Oct 2010 - Rainer, Stan - dp0 = max(dp0,dp2dex(100.)) - end if - dp1=cushn(max(0.,exner(k)-min(exold,exner(1)-dpsum)),dp0) - if (exner(k)-dp1.lt.exold-thin) then ! inflation required - if (k.eq.last) last=k+1 ! still in sigma domain - exner(k+1)=max(extop,exner(k)-dp1) - end if - end if ! k < or > kbl - - if (vrbos .and. exold.ne.exner(k+1)) then -!SMS$IGNORE BEGIN - write (6,105) ipn,k+1,exold,exner(k+1), & - max(0.,exner(k)-min(exold,exner(1)-dpsum)),dp0,dp1 - 105 format (i8,' k=',i3,' exn.',f8.2,' =>',f8.2, & - ' arg1/2,cush =',3f8.2) -!SMS$IGNORE END - end if - - end do ! k loop - -! --- step 2: inflate layers from top down - - if (thktop.gt.0.) then - do k=nvl,2,-1 - q=exner(k)/cp - q=q*q*sqrt(q) ! (p/p0)**(5/7) = (Exn/cp)**(5/2) - dp0=dp2dex(thktop)*taper(k,nvl)/q - exold=exner(k) - dp1=cushn(max(0.,exold-exner(k+1)),dp0) - if (exner(k+1)+dp1.gt.exold+thin) then - exner(k)=exner(k+1)+dp1 - - if (vrbos) then -!SMS$IGNORE BEGIN - write (6,105) ipn,k,exold,exner(k),max(0.,exold-exner(k+1)),dp0,dp1 -!SMS$IGNORE END - end if - - end if - if (exner(k).lt.exner(k-1)-dp0) exit - end do ! k loop - end if ! thktop > 0 - - return - end subroutine inflate - - - subroutine ppmadv(xold,fldold,xnew,fldnew,kk,vrbos,ipn) - -!-- PPM-based 1-dim transport routine, extracted from HYCOM's fct3d.f. -!-- Note: |xold-xnew| can exceed cell width (i.e., no CFL constraints) - -!-- xold/new - old/new cell boundaries -!-- fldold/new - mixing ratio of dep.variable before and after transport -!-- kk - number of layers -!-- vrbos - if .true., print diagnostic messages for grid point -ipn- - - implicit none - integer, intent(IN) :: kk,ipn - real, intent(IN) :: xold(kk+1),xnew(kk+1),fldold(kk) - real, intent(OUT) :: fldnew(kk) - logical, intent(IN) :: vrbos ! switch for 'verbose' mode - - real zold(kk+1),znew(kk+1),delx(kk+1),delz(kk+1),fco(kk),fcn(kk), & - vertfx(kk+1),vertdv(kk) - real a(kk),b(kk),c(kk),dx,fcdx,yl,yr - real amount,bfore,after,dpth,scale,slab,dslab - integer k,lyr - real, parameter :: athird=1./3. - real, parameter :: small=1.e-9 - real, parameter :: acurcy=1.e-5 - - delx=xnew-xold -!-- make sure -x- increases with -k-. change sign of -xold/new- if necessary - if (xold(1).lt.xold(kk+1)) then - zold=xold - znew=xnew - else - zold=-xold - znew=-xnew - end if - delz=znew-zold - -!SMS$IGNORE BEGIN - if (vrbos) & - write (*,100) ipn,'entering ppmadv: old_p^kap d(p^kap) variable', & - (k,xold(k),delx(k),fldold(k),k=1,kk),kk+1,xold(kk+1),delx(kk+1) - 100 format (i8,3x,a/(23x,i3,2f10.3,es11.3)) -!SMS$IGNORE END - -!-- deduce old and new cell width from -zold,znew- - do 15 k=1,kk - fco(k)=max(0.,zold(k+1)-zold(k)) -15 fcn(k)=max(0.,znew(k+1)-znew(k)) - - bfore=0. - scale=0. - dpth=0. - do k=1,kk - bfore=bfore+fldold(k)*fco(k) - dpth=dpth+fco(k) - scale=scale+abs(fldold(k)) - end do - fldnew=fldold - -!-- start by filling zero-width cells with data from neighboring cells - - do 17 k=kk-1,1,-1 -17 fldnew(k)=(fldnew(k)*fco(k)+fldnew(k+1)*small) & - /( fco(k)+ small) - do 18 k=2,kk -18 fldnew(k)=(fldnew(k)*fco(k)+fldnew(k-1)*small) & - /( fco(k)+ small) - -!-- fit 0th, 1st, or 2nd deg. polynomial to -fldnew- in each cell - a(1 )=fldnew(1 ) - b(1 )=0. - c(1 )=0. - a(kk)=fldnew(kk) - b(kk)=0. - c(kk)=0. - - do 16 k=2,kk-1 -!-- uncomment one of the following 3 options to activate pcm,plm,ppm resp. -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!-- piecewise constant method: -!cc a(k)=fldnew(k) -!cc b(k)=0. -!cc c(k)=0. -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!-- piecewise linear method: -!-- fit linear function a+bx to tracer in each cell (-.5 < x < +.5) -!cc a(k)=fldnew(k) -!cc b(k)=0. -!cc if (fldnew(k).le.min(fldnew(k-1),fldnew(k+1)) .or. & -!cc fldnew(k).ge.max(fldnew(k-1),fldnew(k+1))) then -!cc b(k)=0. -!cc else if ((fldnew(k+1)-fldnew(k-1))*(fldnew(k-1)+fldnew(k+1) & -!cc -2.*fldnew(k)).gt.0.) then -!cc b(k)=fldnew(k)-fldnew(k-1) -!cc else -!cc b(k)=fldnew(k+1)-fldnew(k) -!cc end if -!cc c(k)=0. -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!-- piecewise parabolic method: -!-- construct parabola a+bx+cx^2 whose integral over [-.5,+.5] equals -!-- fldnew(k) and which passes though points yl,yr at [-.5,+.5] resp. -!! yl=.5*(fldnew(k-1)+fldnew(k)) -!! yr=.5*(fldnew(k+1)+fldnew(k)) - yl=(max(small,fco(k-1))*fldnew(k)+max(small,fco(k))*fldnew(k-1))/ & - (max(small,fco(k-1)) +max(small,fco(k))) - yr=(max(small,fco(k+1))*fldnew(k)+max(small,fco(k))*fldnew(k+1))/ & - (max(small,fco(k+1)) +max(small,fco(k))) - a(k)=1.5*fldnew(k)-.25*(yl+yr) - b(k)=yr-yl - c(k)=6.*(.5*(yl+yr)-fldnew(k)) - if (abs(yr-yl) .lt. 6.*abs(.5*(yl+yr)-fldnew(k))) then -!-- apex of parabola lies inside interval [-.5,+.5], implying an over- -!-- or undershoot situation. change curve to prevent over/undershoots. - if (abs(yr-yl) .gt. 2.*abs(.5*(yl+yr)-fldnew(k))) then -!-- put apex of parabola on edge of interval [-.5,+.5] - if ((yr-yl)*(.5*(yl+yr)-fldnew(k)) .gt. 0.) then -!-- apex at x=-.5 - a(k)=.25*(3.*fldnew(k)+yl) - c(k)=3.*(fldnew(k)-yl) - b(k)=c(k) - else -!-- apex at x=+.5 - a(k)=.25*(3.*fldnew(k)+yr) - c(k)=3.*(fldnew(k)-yr) - b(k)=-c(k) - end if - else ! -1/6 < x < +1/6 -!-- moving apex won't help. replace parabola by constant. - a(k)=fldnew(k) - b(k)=0. - c(k)=0. - end if - end if -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -16 continue - -!-- get flux by summing -fldnew- over upstream slab of thickness -delz- - - do 22 k=2,kk - slab=0. - amount=0. - vertfx(k)=0. - if (delz(k).gt.0.) then ! interface moves in +k dir. - lyr=k-1 -24 lyr=lyr+1 - if (slab.ge.delz(k)) goto 23 - if (fco(lyr).gt.0.) then - dslab=min(slab+fco(lyr), delz(k)) & - -min(slab , delz(k)) - dx=dslab/fco(lyr) - fcdx=a(lyr) & - +b(lyr)*.5*(dx-1.) & ! not needed in pcm - +c(lyr)*(.25-dx*(.5-dx*athird)) ! not needed in pcm,plm - amount=amount+fcdx*dslab - slab=slab+dslab - end if - if (lyr.lt.kk) go to 24 - else if (delz(k).lt.0.) then ! interface moves in -k dir. - lyr=k -25 lyr=lyr-1 - if (slab.ge.-delz(k)) goto 23 - if (fco(lyr).gt.0.) then - dslab=min(slab+fco(lyr),-delz(k)) & - -min(slab ,-delz(k)) - dx=dslab/fco(lyr) - fcdx=a(lyr) & - +b(lyr)*.5*(1.-dx) & ! not needed in pcm - +c(lyr)*(.25-dx*(.5-dx*athird)) ! not needed in pcm,plm - amount=amount+fcdx*dslab - slab=slab+dslab - end if - if (lyr.gt.2) go to 25 - end if -23 if (slab.ne.0.) vertfx(k)=-delz(k)*amount/slab -22 continue - - vertfx( 1)=0. ! don't allow flux through lower bdry - vertfx(kk+1)=0. ! don't allow flux through upper bdry - do 26 k=1,kk -26 vertdv(k)=vertfx(k+1)-vertfx(k) - -!SMS$IGNORE BEGIN - if (vrbos) write (*,'(a/(i3,4es12.3))') & - 'ppmadv: flux flx.div/thk old_thk new_thk', & - (k,vertfx(k),vertdv(k)/max(small,fcn(k)),fco(k),fcn(k),k=1,kk), & - kk+1,vertfx(kk+1) -!SMS$IGNORE END - - do 4 k=1,kk - amount=fldnew(k)*fco(k)-vertdv(k) -4 fldnew(k)=(fldnew(k)*small+amount)/(small+fcn(k)) - - after=0. - do k=1,kk - after=after+fldnew(k)*fcn(k) - end do - -!SMS$IGNORE BEGIN - if (abs(bfore-after)*kk.gt.acurcy*scale*dpth) then - write (*,104) ipn,'ppmadv - bad column intgl.:',bfore,after - end if - 104 format (i8,3x,a,2es15.7) - - if (vrbos) & - write (*,100) ipn,'exiting ppmadv: d(p^kap) new_p^kap variable', & - (k,delx(k),xnew(k),fldnew(k),k=1,kk),kk+1,delx(kk+1),xnew(kk+1) -!SMS$IGNORE END - - return - end subroutine ppmadv - - - subroutine plmadv(xold_r4,yold_r4,kold,xnew_r4,ynew_r4,knew,vrbos,ipn) -! -! --- this version performs all calculations in double precision (real*8). -! --- data are passed in and out as 'real'. -! -! --- consider two stepwise constant functions -yold,ynew- whose -! --- discontinuities are at abscissa values -xold,xnew- respectively. -! --- treat -ynew- as unknown. solve for -ynew- under the condition that -! --- the integral over y*dx is preserved (integration based on PLM). -! - implicit none - integer,intent(IN) :: kold,knew - integer,intent(IN) :: ipn ! current location in horiz.grid - real,intent(IN) :: yold_r4(kold),xold_r4(kold+1),xnew_r4(knew+1) - real,intent(OUT) :: ynew_r4(knew) - logical,intent(IN) :: vrbos ! if true, print diagnostics - integer k,ko,n,kstart - real*8 yold(kold),xold(kold+1),xnew(knew+1),ynew(knew), & - zold(kold+1),znew(knew+1),colin,clout,slope,wgta,wgtb,wgtc, & - yinteg,ylft(kold),yrgt(kold),xlo,xhi,ra,rb,ya,yb,q,scale, & - yrka,ylk,yrk,ylkb - real*8 plmslp - external plmslp - logical at_top - real,parameter :: onemu=1.e-6, acurcy=1.e-11, flag=-999. - integer,parameter :: iter=1 -! - xold=xold_r4 - yold=yold_r4 - xnew=xnew_r4 - -!SMS$IGNORE BEGIN - if (vrbos) & - write (*,101) ipn,'old',(k,xold(k),yold(k),k=1,kold), & - kold+1,xold(kold+1) - 101 format (i8,' plmadv -- ',a,' profile:',5x,'x',11x,'y'/ & - (i27,f14.1,es12.4)) -!SMS$IGNORE END - - if (xold_r4( 1).ne.xnew_r4( 1)) write (*,102) ipn, & - ' plmadv warning: bottom xold,xnew differ:', & - xold_r4( 1),xnew_r4( 1) - if (xold_r4(kold+1).ne.xnew_r4(knew+1)) write (*,102) ipn, & - ' plmadv warning: top xold,xnew differ:', & - xold_r4(kold+1),xnew_r4(knew+1) - 102 format (i8,a,2f10.2) - xold(1)=max(xold(1),xnew(1)) - xnew(1)=max(xold(1),xnew(1)) - -!-- make sure -x- increases with -k-. change sign of -xold/new- if necessary - if (xold(1).lt.xold(kold+1)) then - zold=xold - znew=xnew - else - zold=-xold - znew=-xnew - end if -! -! --- column integrals (colin/clout) are computed for diagnostic purposes only - scale=0. - colin=0. - clout=0. - do 3 k=1,kold - scale=scale+abs(yold(k)) - 3 colin=colin+yold(k)*(zold(k+1)-zold(k)) -! -! --- replace each flat segment of stairstep curve by -! --- a slanting segment, using PLM-type limiters. -! - ylft( 1)=yold( 1) - yrgt( 1)=yold( 1) - ylft(kold)=yold(kold) - yrgt(kold)=yold(kold) - do 6 n=1,iter ! iterate to optimize limiters - do 2 k=2,kold-1 - if (n.eq.1) then - yrka=yold(k-1) - if (zold(k ).eq.zold( 1)) yrka=yold(k) - ylk=yold(k) - yrk=yold(k) - ylkb=yold(k+1) - if (zold(k+1).eq.zold(kold+1)) ylkb=yold(k) - else - yrka=yrgt(k-1) - if (zold(k ).eq.zold( 1)) yrka=yold(k) - ylk=ylft(k) - yrk=yrgt(k) - ylkb=ylft(k+1) - if (zold(k+1).eq.zold(kold+1)) ylkb=yold(k) - end if - wgta=max(DBLE(onemu),zold(k )-zold(k-1)) - wgtb=max(DBLE(onemu),zold(k+1)-zold(k )) - wgtc=max(DBLE(onemu),zold(k+2)-zold(k+1)) - if (k.eq. 1) wgta=onemu - if (k.eq.kold-1) wgtc=onemu - slope=plmslp((wgtb*yrka+wgta*ylk)/(wgtb+wgta), & - yold(k),(wgtb*ylkb+wgtc*yrk)/(wgtb+wgtc)) - ylft(k)=yold(k)-slope - 2 yrgt(k)=yold(k)+slope - -!!SMS$IGNORE BEGIN -! if (vrbos) print '(a,i2,5x,a,14x,a,8x,a/(i3,es12.4,5x,2es12.4))', & -! 'iter',n,'y','ylft','yrgt',(ko,yold(ko),ylft(ko),yrgt(ko), & -! ko=1,kold) -!!SMS$IGNORE END - 6 continue -! -! --- y in k-th interval now varies from ylft at zold(k) to yrgt at zold(k+1). -! --- find ynew(k) by requiring -! --- that the integral over y*dx from znew(k) to znew(k+1) be preserved. -! - at_top=.true. - kstart=1 - do 4 k=1,knew - yinteg=0. - xlo=znew(k ) - xhi=znew(k+1) -!cc if (vrbos) print '(a,2f9.3)','xlo,xhi =',xlo,xhi - if (xhi.gt.xlo) then - at_top=.false. - do 5 ko=kstart,kold - if (zold(ko+1).le.xlo) then - kstart=ko+1 - go to 5 - end if - if (zold(ko ).ge.xhi) go to 1 -! --- integrate over sloping portions of y(x) curve: - ra=max(xlo,min(xhi,zold(ko ))) - rb=max(xlo,min(xhi,zold(ko+1))) - ya=ylft(k) - yb=yrgt(k) - wgta=flag - wgtb=flag - if (zold(ko+1).ne.zold(ko)) then - if (ra.ge.zold(ko).and.ra.le.zold(ko+1)) then - wgta=(zold(ko+1)-ra)/(zold(ko+1)-zold(ko)) - ya=ylft(ko)*wgta+yrgt(ko)*(1.-wgta) - end if - if (rb.ge.zold(ko).and.rb.le.zold(ko+1)) then - wgtb=(zold(ko+1)-rb)/(zold(ko+1)-zold(ko)) - yb=ylft(ko)*wgtb+yrgt(ko)*(1.-wgtb) - end if - end if - yinteg=yinteg+.5*(ya+yb)*(rb-ra) -!cc if (vrbos) print '(2i4,4f9.3,3f11.1)', & -!cc k,ko,ra,rb,wgta,wgtb,ya,yb,yinteg - 5 continue - yinteg=yinteg+yb*(xhi-rb) -!cc if (vrbos) print '(2i4,4f9.3,3f11.1)', & -!cc k,0,rb,xhi,wgta,wgtb,yb,yb,yinteg - 1 ynew(k)=yinteg/(xhi-xlo) - else if (at_top) then - ynew(k)=yold( 1) - else ! at end - ynew(k)=yold(kold) - end if -!cc if (vrbos) print '(a,f11.1)','ynew =',ynew(k) - clout=clout+ynew(k)*(znew(k+1)-znew(k)) - 4 continue -! -!SMS$IGNORE BEGIN - if (abs(clout-colin).gt.acurcy*scale*(zold(kold+1)-zold(1))) & - write (*,100) ipn,' plmadv - column intgl.error', & - colin,clout,(clout-colin)/colin - 100 format (i8,a,2es14.6,es9.1) - if (vrbos) & - write (*,101) ipn,'new',(k,xnew(k),ynew(k),k=1,knew), & - knew+1,xnew(knew+1) -!SMS$IGNORE END - ynew_r4=ynew - return - end subroutine plmadv - - - real*8 function plmslp(ylft,ymid,yrgt) -! -! --- get slope at point 'ymid' for piecewise linear interpolation - implicit none - real*8,intent(IN) :: ylft,ymid,yrgt -! - if (ymid.le.min(ylft,yrgt) .or. & - ymid.ge.max(ylft,yrgt)) then - plmslp=0. - else if ((yrgt-ylft)*(ylft+yrgt-2.*ymid).gt.0.) then - plmslp=ymid-ylft - else - plmslp=yrgt-ymid - end if - return - end function plmslp - - - subroutine pcmadv(xold_r4,yold_r4,kold,xnew_r4,ynew_r4,knew,vrbos,ipn) -! -! --- this version performs all calculations in double precision (real*8). -! --- data are passed in and out as 'real'. -! -! --- consider two stepwise constant functions -yold,ynew- whose -! --- discontinuities are at abscissa values -xold,xnew- respectively. -! --- treat -ynew- as unknown. solve for -ynew- under the condition that -! --- the integral over y*dx is preserved (integration based on PCM). -! - implicit none - integer,intent(IN) :: kold,knew - integer,intent(IN) :: ipn ! current location in horiz.grid - real,intent(IN) :: yold_r4(kold),xold_r4(kold+1),xnew_r4(knew+1) - real,intent(OUT) :: ynew_r4(knew) - logical,intent(IN) :: vrbos ! if true, print diagnostics - integer k,ko,n,kstart - real*8 yold(kold),xold(kold+1),xnew(knew+1),ynew(knew), & - zold(kold+1),znew(knew+1),colin,clout,yinteg,xlo,xhi,ra,rb, & - scale - logical at_top - real,parameter :: acurcy=1.e-6 -! - xold=xold_r4 - yold=yold_r4 - xnew=xnew_r4 - -!SMS$IGNORE BEGIN - if (vrbos) & - write (*,101) ipn,'old',(k,xold(k),yold(k),k=1,kold), & - kold+1,xold(kold+1) - 101 format (i8,' pcmadv -- ',a,' profile:',5x,'x',11x,'y'/ & - (i27,f14.1,es12.4)) -!SMS$IGNORE END -! -! if (xold_r4(1).ne.xnew_r4(1)) write (*,*) ipn, & -! ' plmadv warning: bottom xold,xnew differ:', & -! xold_r4(1),xnew_r4(1) -! if (xold_r4(kold+1).ne.xnew_r4(knew+1)) write (*,*) ipn, & -! ' plmadv warning: top xold,xnew differ:', & -! xold_r4(kold+1),xnew_r4(knew+1) -! -!-- make sure -x- increases with -k-. change sign of -xold/new- if necessary - if (xold(1).lt.xold(kold+1)) then - zold=xold - znew=xnew - else - zold=-xold - znew=-xnew - end if -! -! --- column integrals (colin/clout) are computed for diagnostic purposes only - scale=0. - colin=0. - clout=0. - do 3 k=1,kold - scale=scale+abs(yold(k)) - 3 colin=colin+yold(k)*(zold(k+1)-zold(k)) -! -! --- find ynew(k) by requiring -! --- that the integral over y*dx from znew(k) to znew(k+1) be preserved. -! - at_top=.true. - kstart=1 - do 4 k=1,knew - yinteg=0. - xlo=znew(k ) - xhi=znew(k+1) -!cc if (vrbos) print '(a,2f9.3)','xlo,xhi =',xlo,xhi - if (xhi.gt.xlo) then - at_top=.false. - do 5 ko=kstart,kold - if (zold(ko+1).le.xlo) then - kstart=ko+1 - go to 5 - end if - if (zold(ko ).ge.xhi) go to 1 - ra=max(xlo,min(xhi,zold(ko ))) - rb=max(xlo,min(xhi,zold(ko+1))) - yinteg=yinteg+yold(ko)*(rb-ra) - 5 continue - 1 ynew(k)=yinteg/(xhi-xlo) - else if (at_top) then - ynew(k)=yold( 1) - else ! at end - ynew(k)=yold(kold) - end if -!cc if (vrbos) print '(a,f11.1)','ynew =',ynew(k) - clout=clout+ynew(k)*(znew(k+1)-znew(k)) - 4 continue -! -!SMS$IGNORE BEGIN - if (abs(clout-colin).gt.acurcy*scale*(zold(kold+1)-zold(1))) & - write (*,100) ipn,' pcmadv - column intgl.error', & - colin,clout,(clout-colin)/colin - 100 format (i8,a,2es14.6,es9.1) - if (vrbos) & - write (*,101) ipn,'new',(k,xnew(k),ynew(k),k=1,knew), & - knew+1,xnew(knew+1) -!SMS$IGNORE END - ynew_r4=ynew - return - end subroutine pcmadv - - - subroutine equilb(thet,pres,kk,slak,vrbos,ipn,PrintDiags) - -! --- expand thin layers at the expense of thick layers above and below. -! --- do this without changing theta - - use module_constants,only: rd,p1000 - - implicit none - integer,intent(IN) :: kk,ipn ! no. of layers, test point location - logical,intent(IN) :: vrbos ! if true, print results at test point - real,intent(IN) :: thet(kk) ! pot.temp. in layers - real,intent(INOUT) :: pres(kk+1) ! Exner fcn on interfaces - real,intent(IN) :: slak ! retardation coefficient - logical,intent(IN) :: PrintDiags - integer k,k1,k2,ncount - real dp1,dp2,dp3,dp4,dp5,th1,th2,th3,th4,th5,dis3,dis4, & - ratio,goal,pnew(kk+1) - logical event - real,parameter :: thin=rd/p1000 ! approx. 1 Pa in Exner fcn units - - if (vrbos) then -!SMS$IGNORE BEGIN - write (6,99) ipn,' equilb input profile:' - do k2=1,kk,10 - write (6,100) (pres(k1),k1=k2,min(kk+1,k2+10) ) - write (6,101) (thet(k1),k1=k2,min(kk ,k2+9 ) ) - write (6,100) - end do - 99 format ('ipn=',i8,a,i9,a) - 100 format (11f7.1) - 102 format (11i7) - 101 format (5x,10f7.2) -!SMS$IGNORE END - end if - -! --- scenario 1: sequence of 5 thin-thick-thin-thick-thin layers - - pnew(:)=pres(:) - ncount=0 - do 1 k=3,kk-2 - if (pnew(k-2).gt.pnew(1)-thin) go to 1 - dp1=pnew(k-2)-pnew(k-1) - dp2=pnew(k-1)-pnew(k ) - dp3=pnew(k )-pnew(k+1) - dp4=pnew(k+1)-pnew(k+2) - dp5=pnew(k+2)-pnew(k+3) - th1=thet(k-2) - th2=thet(k-1) - th3=thet(k ) - th4=thet(k+1) - th5=thet(k+2) -! --- look for small dp1,dp3,dp5 in combination with large dp2,dp4 - if (dp2.gt.dp1 .and. dp4.gt.dp5) then - goal=.5*(dp3+min(dp2,dp4)) ! desired thknss of lyr 3 - if (dp2.gt.goal .and. dp4.gt.goal) then -! --- thin-thick-thin-thick-thin combination found -> inflate lyr 3 - dis3=min(dp2-goal,goal-dp3) * slak - dis4=min(dp4-goal,goal-dp3) * slak - if (th3.gt.th2 .and. th4.gt.th3) then -! --- theta conservation requires dis3*(th3-th2)+dis4*(th4-th3)=0 - ratio=(th4-th3)/(th3-th2) - if (ratio.gt.1.) then - dis4=dis3/ratio - else - dis3=dis4*ratio - end if - end if -! --- ready to expand middle layer - pnew(k )=pnew(k )+dis3 - pnew(k+1)=pnew(k+1)-dis4 - - if (vrbos) then -!SMS$IGNORE BEGIN - write (6,'(a,5f8.2)') 'thknss quintuplet',dp1,dp2, & - dp3,dp4,dp5, ' becomes',dp1,pnew(k-1)-pnew(k), & - pnew(k)-pnew(k+1),pnew(k+1)-pnew(k+2),dp5, & - 'orig dis3,dis4, mod dis3,dis4,ratio =', & - min(dp2-goal,goal-dp3),min(dp4-goal,goal-dp3), & - dis3,dis4,ratio -!SMS$IGNORE END - end if - ncount=ncount+1 - end if - end if - 1 continue - -! --- scenario 2: sequence of 3 thin-thick-thin layers - -! do 2 k=2,kk-1 -! if (pnew(k).gt.pnew(1)-thin) go to 2 -! dp2=pnew(k-1)-pnew(k ) -! dp3=pnew(k )-pnew(k+1) -! dp4=pnew(k+1)-pnew(k+2) -! th2=thet(k-1) -! th3=thet(k ) -! th4=thet(k+1) -! --- look for small dp2,dp4 in combination with large dp3 -! if (dp3.gt.dp2 .and. dp3.gt.dp4) then -! goal=.5*(dp3+max(dp2,dp4)) ! desired thknss of lyr 3 -! if (dp2.lt.goal .and. dp4.lt.goal) then -! --- thin-thick-thin combination found -> deflate lyr 3 -! dis3=min(goal-dp2,dp3-goal) * slak -! dis4=min(goal-dp4,dp3-goal) * slak -! if (th3.gt.th2 .and. th4.gt.th3) then -! --- theta conservation requires dis3*(th3-th2)+dis4*(th4-th3)=0 -! ratio=(th4-th3)/(th3-th2) -! if (ratio.gt.1.) then -! dis4=dis3/ratio -! else -! dis3=dis4*ratio -! end if -! end if -! --- ready to shrink middle layer -! pnew(k )=pnew(k )-dis3 -! pnew(k+1)=pnew(k+1)+dis4 - -!!SMS$IGNORE BEGIN -! if (vrbos) then -! write (6,'(a,i3,a,3f9.3/a,3f9.3)') 'k=',k,' thknss triple', & -! dp2,dp3,dp4,' becomes',pnew(k-1)-pnew(k), & -! pnew(k)-pnew(k+1),pnew(k+1)-pnew(k+2) -! write (6,'(a,3es11.3)') 'pres.chgs.,ratio=',-dis3,dis4,ratio -! end if -!!SMS$IGNORE END - -! ncount=ncount+1 -! end if -! end if -!2 continue - - event = ncount>15 ! find interesting cases - - do k=1,kk - if (pnew(k+1).gt.pnew(k)+thin) then - event=.true. -!SMS$IGNORE BEGIN - write (*,'(a,i3)') & - 'error: nonmonotonic pressure on return from equilb, k=',k -!SMS$IGNORE END - end if - end do - - if (event .and. PrintDiags) then -!SMS$IGNORE BEGIN - write (6,99) ipn,' equilb input profile:' - do k2=1,kk,10 - write (6,100) (pres(k1),k1=k2,min(kk+1,k2+10) ) - write (6,101) (thet(k1),k1=k2,min(kk ,k2+9 ) ) - write (6,100) - end do -!SMS$IGNORE END - end if - if ((event .and. PrintDiags) .or. vrbos) then -!SMS$IGNORE BEGIN - write (6,99) ipn,' equilb output profile:',ncount,' inflations' - do k2=1,kk,10 - write (6,100) (pnew(k1),k1=k2,min(kk+1,k2+10) ) - write (6,102) (int(1000.*(pnew(k1)-pres(k1))),k1=k2,min(kk+1,k2+10) ) - write (6,101) (thet(k1),k1=k2,min(kk ,k2+9 ) ) - write (6,100) - end do -!SMS$IGNORE END - end if - - pres(:)=pnew(:) - return -end subroutine equilb - - -subroutine diagkp(kk,z,zdot,theta,kappa,vrbos,ipn) - -! --- diagnose vertical mixing coefficient resulting from manipulation -! --- of the air column (such as vertical advection, regridding,...) - -! --- approach: transform diffusion eqn for theta -! --- (d theta/dt)_z = (d/dz) [kappa d theta/dz] -! --- into -! --- (dz/dt)_theta = -(d/d theta) [kappa d theta/dz] -! --- ('d' = 'partial'). represent kappa in layers as averages of kappa -! --- on interfaces. solve tridiagonal system for interface kappas. -! --- kappa values returned are l a y e r averages. -! --- kappa is assumed zero in first and last layer (ref. McDougall & Dewar). - -! --- input variables: -! --- z(kk+1) - interface depths (meters, massless layers allowed) -! --- zdot(kk+1) - rate of interface movement (m/s) -! --- theta(kk) - buoyancy (independent variable!) - -! --- output: kappa (m^2/s) in layers whose thickness exceeds 'thresh' - - implicit none - integer i,j,k,kk,kp - real z(kk+1),theta(kk),zdot(kk+1),kappa(kk),zmid(kk), & - thmid(kk),zdotm(kk),a(kk+1,kk+1),a1(kk+1,kk+1), & - b(kk+1),b1(kk+1),d,dpidz - integer indx(kk+1),klist(kk),ipn - logical vrbos - real,parameter :: thresh=1.e-3 - -! --- weed out massless layers - kp=0 - do 5 k=1,kk - klist(k)=0 - if (z(k+1).lt.z(k)-thresh) then ! atmospheric case: z = Exn.fcn, decreasing with k - kp=kp+1 - klist(k)=kp - zmid(kp)=.5*(z(k)+z(k+1)) ! mid layer depth - thmid(kp)=theta(k) - zdotm(kp)=zdot(k) - end if -5 continue - - if (vrbos) then -!SMS$IGNORE BEGIN - write (*,'(a,i8,a/(5(f9.1,f6.1)))') 'ipn =',ipn, & - ' input profile:',(z(k),theta(k),k=1,kk),z(kk+1) - write (*,'(2(i5,a))') kp,' non-massless layers =>',kp-3,' unknowns' -!SMS$IGNORE END - end if - - a=0. - do 10 k=3,kp-1 - a(k,k+1)= (thmid(k+1)-thmid(k-1))/(zmid(k+1)-zmid(k-1)) - a(k,k-1)=-(thmid(k )-thmid(k-2))/(zmid(k )-zmid(k-2)) - a(k,k )=a(k,k+1)+a(k,k-1) -10 continue - - do 11 k=3,kp-1 -11 b(k)=2.*zdotm(k)*(thmid(k-1)-thmid(k)) - - if (vrbos) then -!SMS$IGNORE BEGIN - write(*,*) 'ipn =',ipn,' input matrix * 10^3' - do k=3,kp-1 - write(*,'(3p,20f8.2)') (a(k,j),j=3,kp-1) - end do -!SMS$IGNORE END - end if - - a1=a - b1=b - -!SMS$IGNORE BEGIN - if (vrbos) write(*,*) 'ipn =',ipn,' input rhs * 10^3' - if (vrbos) write(*,'(3p,20f8.2)') (b(j),j=3,kp-1) -!SMS$IGNORE END - - call ludcmp(a(3,3),kp-3,kk+1,indx,d) - call lubksb(a(3,3),kp-3,kk+1,indx,b(3)) - - if (vrbos) then -!SMS$IGNORE BEGIN -! --- did the equation solver return a credible solution? - do 22 k=3,kp-1 - b1(k)=0. - do 22 i=3,kp-1 -22 b1(k)=b1(k)+a1(k,i)*b(i) - write(*,*) 'ipn =',ipn,' matrix * kappa * 10^3' - write(*,'(3p,20f8.2)') (b1(j),j=3,kp-1) - - do k=2,kk-1 - j=klist(k) - if (j.gt.1 .and. j.lt.kp) then - dpidz=9.806/thmid(j) ! exn.fcn => z conversion - write(*,'(a,i4,6(a,f8.2))') & -!! write(*,'(a,i4,2(a,f8.1),a,es11.2,3(a,f8.1))') & - 'k=',k,' z_uppr=',z(k),' zmid=',zmid(j), & - ' zdot(x10^3)=',1.e3*zdot(k), & - ' k_uppr(cm^2/s)=',1.e4*b(j)*dpidz**2, & - ' k_mid=',.5e4*(b(j)+b(j+1))*dpidz**2 - end if - end do -!SMS$IGNORE END - end if - -! --- set diffusivity=0 in 1st and last layer - b( 1)=0. - b( 2)=0. - b(kp )=0. - b(kp+1)=0. - kappa=0. - do k=2,kk-1 - dpidz=9.806/theta(k) ! atmosphere - j=klist(k) - if (j.gt.1 .and. j.lt.kp) kappa(k)=.5*(b(j)+b(j+1))*dpidz**2 - end do - return -end subroutine diagkp - - -!! SUBROUTINE ludcmp(a,n,np,indx,d) -!! INTEGER n,np,indx(n),NMAX -!! REAL d,a(np,np),TINY -!! PARAMETER (NMAX=500,TINY=1.0e-20) -!! INTEGER i,imax,j,k -!! REAL aamax,dum,sum,vv(NMAX) -!! d=1. -!! -!! do 12 i=1,n -!! aamax=0. -!! do 11 j=1,n -!! if (abs(a(i,j)).gt.aamax) aamax=abs(a(i,j)) -!! 11 continue -!! if (aamax.eq.0.) pause 'singular matrix in ludcmp' -!! vv(i)=1./aamax -!! 12 continue -!! do 19 j=1,n -!! do 14 i=1,j-1 -!! sum=a(i,j) -!! do 13 k=1,i-1 -!! sum=sum-a(i,k)*a(k,j) -!! 13 continue -!! a(i,j)=sum -!! 14 continue -!! aamax=0. -!! do 16 i=j,n -!! sum=a(i,j) -!! do 15 k=1,j-1 -!! sum=sum-a(i,k)*a(k,j) -!! 15 continue -!! a(i,j)=sum -!! dum=vv(i)*abs(sum) -!! if (dum.ge.aamax) then -!! imax=i -!! aamax=dum -!! endif -!! 16 continue -!! if (j.ne.imax)then -!! do 17 k=1,n -!! dum=a(imax,k) -!! a(imax,k)=a(j,k) -!! a(j,k)=dum -!! 17 continue -!! d=-d -!! vv(imax)=vv(j) -!! endif -!! indx(j)=imax -!! if(a(j,j).eq.0.)a(j,j)=TINY -!! if(j.ne.n)then -!! dum=1./a(j,j) -!! do 18 i=j+1,n -!! a(i,j)=a(i,j)*dum -!! 18 continue -!! endif -!! 19 continue -!! return -!! end subroutine ludcmp -!! ! (C) Copr. 1986-92 Numerical Recipes Software 'W3. -!! -!! -!! SUBROUTINE lubksb(a,n,np,indx,b) -!! INTEGER n,np,indx(n) -!! REAL a(np,np),b(n) -!! INTEGER i,ii,j,ll -!! REAL sum -!! ii=0 -!! do 12 i=1,n -!! ll=indx(i) -!! sum=b(ll) -!! b(ll)=b(i) -!! if (ii.ne.0)then -!! do 11 j=ii,i-1 -!! sum=sum-a(i,j)*b(j) -!! 11 continue -!! else if (sum.ne.0.) then -!! ii=i -!! endif -!! b(i)=sum -!! 12 continue -!! do 14 i=n,1,-1 -!! sum=b(i) -!! do 13 j=i+1,n -!! sum=sum-a(i,j)*b(j) -!! 13 continue -!! b(i)=sum/a(i,i) -!! 14 continue -!! return -!! end subroutine lubksb -! (C) Copr. 1986-92 Numerical Recipes Software 'W3. -!end module module_hybgen ! SMS doesn't like multiple routines in module diff --git a/src/fim/FIMsrc/fim/horizontal/hystat.F90 b/src/fim/FIMsrc/fim/horizontal/hystat.F90 deleted file mode 100644 index 5e4d389..0000000 --- a/src/fim/FIMsrc/fim/horizontal/hystat.F90 +++ /dev/null @@ -1,122 +0,0 @@ -module module_hystat -use findmaxmin1 -contains -!********************************************************************* -! hystat -! Hydrostatic equation -! Alexander E. MacDonald 11/14/2005 -! J.Lee 01/04/2006 -! R.Bleck 12/06/2007 -!********************************************************************* - - subroutine hystat (its, & - ph3d, & ! geopotential (=g*z) - ex3d,mp3d,dp3d, & ! ,exner fct, mont pot, layer thickness - tr3d,trdp,psrf,ptdcy ) ! tracer, tracer x thickness, srf.prs tndcy - - use module_control ,only: nvl,nvlp1,nip,ptop,ntra,PrintIpnDiag - use module_constants,only: p1000,cp,rd,qvmin,qwmin - implicit none - -! Dimension and type external variables: - integer,intent (IN) :: its ! model time step -!SMS$DISTRIBUTE (dh,nip) BEGIN - real,intent (INOUT) :: ph3d(nvlp1,nip) ! geopotential - real,intent (IN) :: ex3d(nvlp1,nip) ! exner fct - real,intent (OUT) :: mp3d(nvl,nip) ! montgomery potential - real,intent (IN) :: dp3d(nvl,nip) ! layer thickness - real,intent (INOUT) :: tr3d(nvl,nip,ntra) ! mass field tracers - real,intent (OUT) :: trdp(nvl,nip,ntra) ! tracer x thickness - real,intent (INOUT) :: psrf(nip) ! surface pressure -!JR Cannot have intent(out) for ptdcy because this routine only sets half of the array, and Lahey -!JR assigns a "bad sequence of bits" to all intent(out) variables. - real,intent (INOUT) :: ptdcy(nip,2) ! srf.pres.tdcy, 2 time lvls - -! Declare local variables: - real :: work(nip) -!SMS$DISTRIBUTE END - integer :: ipn ! icos index - integer :: k ! layer index - integer :: ns ! tracer index - logical :: vrbos ! switch for 'verbose' mode - -! Note that tracers, velocity, and montgomery potential, mp3d -! are all constant through the layers. Phi (ph3d) and pressure (dp3d) -! vary through the layer. - -! Layer variables: tr3d,mp3d -! Level variables: ex3d,ph3d - -!SMS$PARALLEL (dh,ipn) BEGIN -!sms$compare_var(ex3d, "diag.F90 - ex3d5 ") -!sms$compare_var(ph3d, "diag.F90 - ph3d5 ") - - do ipn=1,nip ! global icos loop - vrbos=ipn.eq.PrintIpnDiag - -! --- srf.prs tendency is needed to evaluate model noise (diagnoise.F90) - work(ipn)=psrf(ipn) - psrf(ipn)=dp3d(nvl,ipn) - do k=nvl-1,1,-1 - psrf(ipn)=psrf(ipn)+dp3d(k,ipn) - end do - ns=mod(its,2)+1 - if (its.gt.0) ptdcy(ipn,ns)=psrf(ipn)-work(ipn) - -!......................................................... -! Determine bottom layer values -!......................................................... - - mp3d(1,ipn)=ex3d(1,ipn)*tr3d(1,ipn,1)+ph3d(1,ipn) ! mont pot, layer 1 - ph3d(2,ipn)=mp3d(1,ipn)-tr3d(1,ipn,1)*ex3d(2,ipn) ! geopot, level 2 - - do k=2,nvl ! vertical loop - -! Hydrostatic eqn: d mp/d theta = exner fct, tr3d(.,.,1) = theta - mp3d(k,ipn)=mp3d(k-1,ipn)+ex3d(k,ipn) & - *(tr3d(k,ipn,1)-tr3d(k-1,ipn,1)) - -! get geopotential from identity montg pot = geopot + theta*exner - ph3d(k+1,ipn)=mp3d(k,ipn)-tr3d(k,ipn,1)*ex3d(k+1,ipn) - - enddo ! vertical loop - -! keep vapor mixing ratio and water content above prescribed lower limits - do k=1,nvl - tr3d(k,ipn,2)=max(qvmin,tr3d(k,ipn,2)) - tr3d(k,ipn,3)=max(qwmin,tr3d(k,ipn,3)) - end do - -! compute tracer amount per unit area (tracer concentration x layer thickness) - do ns=1,ntra - do k=1,nvl - trdp(k,ipn,ns)=tr3d(k,ipn,ns)*dp3d(k,ipn) - end do - end do - - if (vrbos) then -!SMS$IGNORE BEGIN - write (6,100) its,ipn,(k,1000.*(ex3d(k,ipn)/cp)**(cp/rd), & - ex3d(k,ipn),ph3d(k,ipn),mp3d(k,ipn),k=1,nvl), & - nvlp1,1000.*(ex3d(nvlp1,ipn)/cp)**(cp/rd),ex3d(nvlp1,ipn), & - ph3d(nvlp1,ipn) - 100 format ('its,ipn=',i6,i8, & - ' HYSTAT pres exn.fct geopot montg'/(i28,4f10.1)) -!SMS$IGNORE END - end if - - enddo ! horizontal loop -!SMS$PARALLEL END - -!! call findmxmn1(work,nip,'old srf.pres.') -!! call findmxmn1(psrf,nip,'new srf.pres.') -!! ns=mod(its+1,2)+1 -!! work(:)=ptdcy(:,ns) -!! call findmxmn1(work,nip,'old srf.pres.tdcy') -!! ns=mod(its ,2)+1 -!! work(:)=ptdcy(:,ns) -!! call findmxmn1(work,nip,'new srf.pres.tdcy') - - return - end subroutine hystat -end module module_hystat diff --git a/src/fim/FIMsrc/fim/horizontal/infnan.F90 b/src/fim/FIMsrc/fim/horizontal/infnan.F90 deleted file mode 100644 index 12f98d7..0000000 --- a/src/fim/FIMsrc/fim/horizontal/infnan.F90 +++ /dev/null @@ -1,15 +0,0 @@ -module infnan -!SMS$IGNORE BEGIN - implicit none - - private - public :: inf, nan, negint - -! TODO: add big endian ifdef for e.g. IBM -! TODO: Should NaN be signaling or non-signaling? - - real, parameter :: inf = z'7f800000' ! Infinity - real, parameter :: nan = z'ffc00000' ! NaN - integer, parameter :: negint = -999 ! Bad integer value -!SMS$IGNORE END -end module infnan diff --git a/src/fim/FIMsrc/fim/horizontal/init.F90 b/src/fim/FIMsrc/fim/horizontal/init.F90 deleted file mode 100644 index ef9a619..0000000 --- a/src/fim/FIMsrc/fim/horizontal/init.F90 +++ /dev/null @@ -1,57 +0,0 @@ -!********************************************************************* -! Loads the initial variables and constants to start fim -! Alexander E. MacDonald 11/27/04 -! J. Lee September, 2005 -!********************************************************************* - -subroutine init - use module_core_setup ,only: core_setup_fim, iam_fim_task, iam_write_task - use module_fim_chem_init ,only: chem_init - use module_fim_cpl_init ,only: cpl_init - use module_fim_dyn_init ,only: dyn_init - use module_fim_phy_init ,only: phy_init - use module_wrf_phy_init ,only: wrf_phy_init - use module_control ,only: readrestart - use restart ,only: read_restart - - implicit none - -! Local variables - -!JR: Sit in a spin-wait loop so a debugger can attach, halt the process, -!JR reset the variable spinwait, and then continue. -!JR: Placed here because MPI is now active (if enabled), but the model is -!JR still in the startup phase. - -#ifdef ATTACH_DEBUGGER - integer :: spinwait = 1 - - do while (spinwait == 1) - end do -#endif - -! When MPI is used, set up communicators for compute tasks and -! optional write tasks. Mirrors NEMS approach. -! NOTE: Executable SMS directives must not be placed before -! NOTE: this call! -! NOTE: This includes writes or prints without !SMS$ignore because they -! NOTE: cause SMS to generate code. - - call core_setup_fim () - - if (iam_fim_task .or. iam_write_task) then - call dyn_init () - end if - - if (iam_fim_task) then - call phy_init () - call chem_init () - call wrf_phy_init () - call cpl_init () - if (readrestart) then - call read_restart () ! read dynamics and physics data from restart file - end if - end if - - return -end subroutine init diff --git a/src/fim/FIMsrc/fim/horizontal/its2string.F90 b/src/fim/FIMsrc/fim/horizontal/its2string.F90 deleted file mode 100644 index e88b53e..0000000 --- a/src/fim/FIMsrc/fim/horizontal/its2string.F90 +++ /dev/null @@ -1,35 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Used by restart.F90 to create restart file name from current time -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -character(len=8) function its2string (its) - use module_control, only: ArchvTimeUnit, dt, hrs_in_month - - implicit none - - integer, intent(in) :: its - integer :: time - -! Changes in this block may require changes in dyn_init.F90 as well - if (ArchvTimeUnit == 'ts') then - time = its - write (its2string,'(i6.6,a2)') time, 'ts' - else if (ArchvTimeUnit == 'mi') then - time = its*dt/60. - write (its2string,'(i6.6,a2)') time, 'mi' - else if (ArchvTimeUnit == 'hr') then - time = its*dt/3600. - write (its2string,'(i6.6,a2)') time, 'hr' - else if (ArchvTimeUnit == 'dy') then - time = its*dt/86400. - write (its2string,'(i6.6,a2)') time, 'dy' - else if (ArchvTimeUnit == 'mo') then - time = its*dt/(hrs_in_month*3600.) - write (its2string,'(i6.6,a2)') time, 'mo' - else - write (*,'(a,a)') 'ERROR in its2string: unrecognized output time unit: ',ArchvTimeUnit - stop - endif - - return -end function its2string diff --git a/src/fim/FIMsrc/fim/horizontal/its2time.F90 b/src/fim/FIMsrc/fim/horizontal/its2time.F90 deleted file mode 100644 index b59ea2a..0000000 --- a/src/fim/FIMsrc/fim/horizontal/its2time.F90 +++ /dev/null @@ -1,21 +0,0 @@ -integer function its2time(its) - use module_control,only:ArchvTimeUnit,dt,hrs_in_month - implicit none - integer,intent(in)::its -! Changes in this block may require changes in dyn_init.F90 as well - if (ArchvTimeUnit.eq.'ts') then - its2time=its - else if (ArchvTimeUnit.eq.'mi') then - its2time=its*dt/60. - else if (ArchvTimeUnit.eq.'hr') then - its2time=its*dt/3600. - else if (ArchvTimeUnit.eq.'dy') then - its2time=its*dt/86400. - else if (ArchvTimeUnit.eq.'mo') then - its2time=its*dt/(hrs_in_month*3600.) - else - write (*,'(a,a)') 'ERROR in its2time: unrecognized output time unit: ',ArchvTimeUnit - stop - endif -end function its2time - diff --git a/src/fim/FIMsrc/fim/horizontal/linebuf_stdout.c b/src/fim/FIMsrc/fim/horizontal/linebuf_stdout.c deleted file mode 100644 index d442292..0000000 --- a/src/fim/FIMsrc/fim/horizontal/linebuf_stdout.c +++ /dev/null @@ -1,12 +0,0 @@ -#if ( defined FORTRANUNDERSCORE ) -#define linebuf_stdout linebuf_stdout_ -#elif ( defined FORTRANDOUBLEUNDERSCORE ) -#define linebuf_stdout linebuf_stdout__ -#endif - -#include -void linebuf_stdout () -{ - setlinebuf (stdout); - printf ("linebuf_stdout: output will be line buffered from now on\n"); -} diff --git a/src/fim/FIMsrc/fim/horizontal/module_chem_constants.F90 b/src/fim/FIMsrc/fim/horizontal/module_chem_constants.F90 deleted file mode 100644 index 44116b9..0000000 --- a/src/fim/FIMsrc/fim/horizontal/module_chem_constants.F90 +++ /dev/null @@ -1,9 +0,0 @@ -MODULE module_chem_constants -!******************************************************************** -! This module specifies model constants for WRF chem -!******************************************************************** -implicit none - -real :: p_gocart (56) ! list of gocart pressure levels - -END MODULE module_chem_constants diff --git a/src/fim/FIMsrc/fim/horizontal/module_chem_driver.F90 b/src/fim/FIMsrc/fim/horizontal/module_chem_driver.F90 deleted file mode 100644 index 510fd45..0000000 --- a/src/fim/FIMsrc/fim/horizontal/module_chem_driver.F90 +++ /dev/null @@ -1,525 +0,0 @@ -MODULE MODULE_CHEM_DRIVER - IMPLICIT NONE -CONTAINS - subroutine chem_driver(ktau) -! -! FIM version variables -! - USE module_control, only: dt, yyyymmddhhmm, nvl, nvlp1,ntra,ntrb - USE module_wrf_control, only: ims,ime,jms,jme,kms,kme, & - ids,ide,jds,jde,kds,kde, & - its,ite,jts,jte,kts,kte, & - nvl_gocart,num_emis_ant,num_moist, & - num_ext_coef,num_bscat_coef,num_asym_par,& - num_chem,num_soil_layers,numgas,nbands, & - num_emis_vol,CallChemistry,CallBiom -!TODO: replace use-association of FIM dynamics variables with coupler - USE module_variables - USE module_chem_variables - USE module_wrf_variables,only:exch,pb2d - USE module_constants - USE module_chem_constants ,only: p_gocart - USE module_sfc_variables -! TBH: Ignore these so PPP doesn't have to translate them -!SMS$IGNORE BEGIN - USE module_plumerise1, only: plumerise_driver - USE module_chem_prep_fim,only: chem_prep_fim - USE module_gocart_seasalt,only: gocart_seasalt_driver - USE gocart_dust,only: gocart_dust_driver - USE gocart_dust_afwa,only: gocart_dust_afwa_driver - USE module_gocart_settling,only: gocart_settling_driver - USE module_gocart_opt,only: aero_opt - USE module_vash_settling,only: vash_settling_driver,vashshort_settling_driver - USE module_wetdep_ls,only: wetdep_ls - USE module_dms_emis,only: gocart_dmsemis - USE module_ctrans_grell,only:grelldrvct - USE module_initial_chem_namelists,only:p_qc,p_dms,p_seas_1,chem_opt,biomass_burn_opt,p_oc1, & - p_bc1,p_p25,p_p10,p_sulf,p_so2,seas_opt,dust_opt, & - dmsemis_opt,chem_in_opt,aer_ra_feedback,kemit,p_tr1,p_tr2 - USE module_dry_dep_driver,only:dry_dep_driver - USE module_gocart_aerosols,only:sum_pm_gocart,gocart_aerosols_driver - USE module_gocart_chem,only:gocart_chem_driver - USE module_data_gocart_chem,only:airmw,mw_so4_aer - USE module_optical_driver, only: optical_driver - USE module_aer_opt_out, only: aer_opt_out - USE module_aer_ra, only: aer_ra -!SMS$IGNORE END - USE module_chemvars - USE module_wrfphysvars - USE module_outtime_chem,only: telapsed=>tchem - - IMPLICIT NONE - - INTEGER, INTENT (IN) :: KTAU - - real :: var_rmv(ims:ime, jms:jme ,num_chem) - real :: swdown(ims:ime, jms:jme ) - real :: dep_vel_o3(ims:ime, jms:jme ) - real :: e_co(ims:ime, jms:jme ) - real :: raincv_b(ims:ime, jms:jme ) - real :: cu_co_ten(ims:ime, kms:kme,jms:jme ) - REAL :: dusthelp(ims:ime, jms:jme ),seashelp(ims:ime,jms:jme ) - real :: tr_fall(ims:ime, jms:jme,num_chem ) - - integer,save :: current_month - - !shc end stuff for MEGAN v2.04 - - REAL :: dtstep_plume,dtstep, dx, gmt - REAL :: dust_alpha,dust_gamma - REAL (kind=8) :: curr_secs -! -! Local variables... -! - INTEGER :: ib,i, j, k, nv,nvv,ksub, dust_emiss_active, seasalt_emiss_active - INTEGER :: call_plume,call_gocart,julday,current_gmt,curr_mins,current_day,current_year - REAL :: factor,factor2,conv,mwdry,xlv,maxv,minv - CHARACTER (LEN=80) :: message,filename - CHARACTER(len=9 ) :: jdate - real*8 :: t0 -! .. -! .. -! .. Intrinsic Functions .. - INTRINSIC max, min - call StartTimer(t0) - dust_alpha=1.0 - dust_gamma=1.6 - call_plume=0 - if(biomass_burn_opt > 0 ) then - if ((mod(ktau,CallBiom)==0).or.(ktau==1)) then - call_plume=1 - dtstep_plume=dt*CallBiom - endif - endif - if(chem_opt == 0) then - write(6,*)'Shouldnt be here with chem_opt = 0 ' - endif - dusthelp(:,:)=0. - seashelp(:,:)=0. - - -!sms$compare_var(st3d , "begin chem_driver ") -!sms$compare_var(sm3d , "begin chem_driver ") -!sms$compare_var(ts2d , "begin chem_driver ") -!sms$compare_var(us2d , "begin chem_driver ") -!sms$compare_var(sw2d , "begin chem_driver ") - - call_gocart=0 - - if(chem_opt >= 300 .and. chem_opt < 500 ) then - if ((mod(ktau,CallChemistry)==0).or.(ktau==1)) then - call_gocart=1 - endif - endif - xlv=2.5e6 - dtstep=dt*CallChemistry - curr_secs=ktau*dt - curr_mins=curr_secs/60. - if(ktau.le.1)then - dtstep=dt - READ(UNIT=yyyymmddhhmm(5:6), FMT='(I2)') current_month -!sms$ignore begin - rcav(jts:jte)=rc2d(jts:jte) - rnav(jts:jte)=rn2d(jts:jte)-rc2d(jts:jte) -!sms$ignore end - else -!sms$ignore begin - rcav(jts:jte)=rc2d(jts:jte)-rcav(jts:jte) - rcav(jts:jte)=max(0.,rcav(jts:jte)) - rnav(jts:jte)=rn2d(jts:jte)-rc2d(jts:jte)-rnav(jts:jte) - rnav(jts:jte)=max(0.,rnav(jts:jte)) -!sms$ignore end - endif -! make the fim varialbles conform with the chem_driver -! if(ktau.le.1)then - READ(UNIT=yyyymmddhhmm(1:4), FMT='(I4)') current_year - READ(UNIT=yyyymmddhhmm(5:6), FMT='(I2)') current_month -! endif - READ(UNIT=yyyymmddhhmm(7:8), FMT='(I2)') current_day - READ(UNIT=yyyymmddhhmm(9:10), FMT='(I2)') current_gmt - call GetJdate(yyyymmddhhmm,jdate) ! Julian date conversion - READ(UNIT=jdate(3:5), FMT='(I3)')julday -! -! we have to read co2 emissions every few hours -! - if(chem_opt == 500 ) then - if(ktau.le.1 .or. mod(curr_mins,180).eq.0)then - write(filename,'("co2_flux.",I4,I2.2,I2.2,I2.2,".bin")')current_year,current_month,current_day,current_gmt - write(6,*)filename -!SMS$SERIAL ( : default=ignore) BEGIN - open(unit=28,file=filename, form="unformatted") - read(28)emiss_co2 - close(28) -! maxv=maxval(emiss_co2) -!SMS$SERIAL END -! write(6,*)'maxv,p_tr1,p_tr2 on input for co2_ant = ',maxv,p_tr1,p_tr2 - call flush(6) - do j=jts,jte - emiss_ab(j,p_tr1)=emiss_co2(j) - emiss_ab(j,p_tr2)=emiss_co2(j) - enddo - endif ! every 3 hours - endif ! chem_opt = 500 - - - gmt=current_gmt - call chem_prep_fim(ktau,dt,rh3d,tr3d,tk3d,st3d,sm3d,dp3d,mp3d, & - ts2d,us2d,sw2d,pr3d,emiss_ash_mass,emiss_ash_height, & - emiss_ash_dt,dm0,emiss_tr_mass,emiss_tr_height, & - emiss_tr_dt, VFRAC2d,VTYPE2d,STYPE2d,us3d,vs3d,ws3d, & - slmsk2d,zorl2d,exch,pb2d,hf2d,oh_backgd,h2o2_backgd, & - no3_backgd,backg_oh,backg_h2o2,backg_no3,p_gocart, & - nvl_gocart,ttday,tcosz,gmt,julday,dtstep,ph3d,area,ero1,& - ero2,ero3,rcav,raincv_b,deg_lat,deg_lon,nvl,nvlp1,ntra, & - relhum,rri,t_phy,moist,u_phy,v_phy,p_phy,chem,tsk,ntrb, & - grvity,rd,p1000,cp,erod,emis_ant,emis_vol,e_co,dms_0, & - u10,v10,ivgtyp,isltyp,gsw,vegfra,rmol,ust,znt,xland,dxy,& - t8w,p8w,exch_h,pbl,hfx,xlat,xlong,z_at_w,zmid,dz8w,vvel,& - rho_phy,smois,num_soil_layers,num_chem,num_moist, & - emiss_abu,ebu_in_oc,ebu_in_bc,ebu_in_pm25,ebu_in_pm10, & - ebu_in_so2,ebu_in_sulf,emiss_ab,num_emis_ant, & - num_emis_vol,kemit,call_gocart,ids,ide, jds,jde, kds, & - kde,plumestuff,mean_fct_agtf,mean_fct_agef, & - mean_fct_agsv,mean_fct_aggr,firesize_agtf,firesize_agef,& - firesize_agsv,firesize_aggr,chem_in_opt, & - ims,ime, jms,jme, kms,kme, & - its,ite,jts,jte,kts,kte) - mwdry=28. -!if(mod(ktau,CallChemistry)==0.or.ktau==1) then -! write(6,*)'in chem_driver, now do chemistry = ',ktau,dtstep,CallChemistry,kemit - if(seas_opt == 1 )then -! print *,'get seasalt emissions' - call gocart_seasalt_driver(ktau,dt,rri,t_phy,moist,u_phy, & - v_phy,chem,rho_phy,dz8w,u10,v10,p8w, & - xland,xlat,xlong,area,grvity,emis_seas, & - seashelp,num_emis_seas,num_moist,num_chem, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - endif - if(dust_opt == 1 )then - call gocart_dust_driver(ktau,dt,rri,t_phy,moist,u_phy, & - v_phy,chem,rho_phy,dz8w,smois,u10,v10,p8w,erod,ivgtyp,isltyp,& - vegfra,xland,xlat,xlong,gsw,area,grvity,emis_dust,dusthelp, & - num_emis_dust,num_moist,num_chem,num_soil_layers, & - current_month, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - endif - if(dust_opt == 3 )then - call gocart_dust_afwa_driver(ktau,dt,rri,t_phy,moist,u_phy, & - v_phy,chem,rho_phy,dz8w,smois,u10,v10,p8w,erod,ivgtyp,isltyp,& - vegfra,xland,xlat,xlong,gsw,area,grvity,emis_dust,dusthelp, & - ust,znt,clayfrac,sandfrac,dust_alpha,dust_gamma, & - num_emis_dust,num_moist,num_chem,num_soil_layers, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - endif -!endif -if(call_plume == 1 ) then - call plumerise_driver (ktau,dtstep_plume,num_chem,num_moist, & - ebu_no,ebu_co,ebu_co2,ebu_eth,ebu_hc3,ebu_hc5,ebu_hc8, & - ebu_ete,ebu_olt,ebu_oli,ebu_pm25,ebu_pm10,ebu_dien,ebu_iso, & - ebu_api,ebu_lim,ebu_tol,ebu_xyl,ebu_csl,ebu_hcho,ebu_ald, & - ebu_ket,ebu_macr,ebu_ora1,ebu_ora2,ebu_bc,ebu_oc,ebu_so2, & - ebu_sulf, & - ebu_in_no,ebu_in_co,ebu_in_co2,ebu_in_eth,ebu_in_hc3,ebu_in_hc5, & - ebu_in_hc8,ebu_in_ete,ebu_in_olt,ebu_in_oli,ebu_in_pm25,ebu_in_pm10, & - ebu_in_dien,ebu_in_iso,ebu_in_api,ebu_in_lim,ebu_in_tol,ebu_in_xyl, & - ebu_in_csl,ebu_in_hcho,ebu_in_ald,ebu_in_ket,ebu_in_macr,ebu_in_ora1, & - ebu_in_ora2,ebu_in_bc,ebu_in_oc,ebu_in_so2,ebu_in_sulf, & - mean_fct_agtf,mean_fct_agef,mean_fct_agsv,mean_fct_aggr, & - firesize_agtf,firesize_agef,firesize_agsv,firesize_aggr, & - t_phy,moist,chem,rho_phy,vvel,u_phy,v_phy,p_phy,z_at_w,zmid, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) -endif -!if(call_gocart == 1 ) then -if(dmsemis_opt == 1 ) then - do j=jts,jte - do i=its,ite - diaga(5,j)=emis_dust(i,1,j,1) - diaga(6,j)=chem(i,1,j,p_dms) - enddo - enddo - call gocart_dmsemis(dt,rri,t_phy,u_phy, & - v_phy,chem,rho_phy,dz8w,u10,v10,p8w,dms_0,tsk, & - ivgtyp,isltyp,xland,area,grvity,mwdry, & - num_chem,p_dms,ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - do j=jts,jte - do i=its,ite - diaga(6,j)=-(diaga(6,j)-chem(i,1,j,p_dms))/dt - enddo - enddo -endif -if(chem_opt == 300 .and. (dust_opt == 1 .or. seas_opt == 1 .or. dust_opt == 3))then - - call gocart_settling_driver(dt,t_phy,moist, & - chem,rho_phy,dz8w,p8w,p_phy, & - dusthelp,seashelp,area,grvity, & - num_moist,num_chem, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) -endif -! -! 10 volcanic size bins -! -if(CHEM_OPT == 316 ) then - call vash_settling_driver(dt,t_phy,moist, & - chem,rho_phy,dz8w,p8w,p_phy,area, & - ash_fall,grvity,num_moist,num_chem , & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - do j=jts,jte - do i=its,ite - ashfall(j)=ash_fall(i,j) - enddo - enddo -endif -! -! 4 volcanic size bins -! -if(CHEM_OPT == 317 .or. CHEM_OPT == 502 .or. CHEM_OPT == 300) then - do j=jts,jte - do i=its,ite - diaga(2,j)=chem(i,1,j,p_p25) - enddo - enddo - call vashshort_settling_driver(dt,t_phy,moist, & - chem,rho_phy,dz8w,p8w,p_phy,area, & - ash_fall,grvity,num_moist,num_chem , & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - do j=jts,jte - do i=its,ite - diaga(2,j)=(chem(i,1,j,p_p25)-diaga(2,j))/dt - enddo - enddo - do j=jts,jte - do i=its,ite - ashfall(j)=ash_fall(i,j) - enddo - enddo -endif -! -! add biomass burning emissions at every timestep -! -if(BIOMASS_BURN_OPT == 1 ) then - do i=its,ite - do k=kts,kte-2 - do j=jts,jte -!factro for pm emissions, factor2 for burn emissions - factor=dt*rri(i,k,j)/dz8w(i,k,j) - factor2=4.828e-4*dt*rri(i,k,j)/(60.*dz8w(i,k,j)) - chem(i,k,j,p_oc1)=chem(i,k,j,p_oc1)+(ebu_oc(i,k,j))*factor - chem(i,k,j,p_bc1)=chem(i,k,j,p_bc1)+(ebu_bc(i,k,j))*factor - chem(i,k,j,p_p25)=chem(i,k,j,p_p25)+(ebu_pm25(i,k,j))*factor -! chem(i,k,j,p_p10)=chem(i,k,j,p_p10)+(ebu_pm10(i,k,j))*factor - - chem(i,k,j,p_so2)=chem(i,k,j,p_so2)+ebu_so2(i,k,j)*factor2 - enddo - enddo - enddo -endif - -! -! subgrid convective transport -! - call grelldrvct(DT,ktau, & - rho_phy,RAINCV_b,chem,tr_fall, & - U_phy,V_phy,t_phy,moist,dz8w,p_phy, & - XLV,CP,grvity,rv,z_at_w,cu_co_ten, & - numgas,chem_opt, & - num_chem,num_moist, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - do j=jts,jte - do i=its,ite - diaga(3,j)=chem(i,1,j,p_p25) - enddo - enddo - call dry_dep_driver(ktau,dt, & - moist,p8w,rri, & - chem,rho_phy,dz8w,exch_h,hfx, & - ivgtyp,tsk,pbl,ust,znt,zmid,z_at_w, & - xland,dep_vel_o3,grvity, & - e_co,kemit,numgas, & - num_chem,num_moist, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - do j=jts,jte - do i=its,ite - diaga(3,j)=(chem(i,1,j,p_p25)-diaga(3,j))/dt - diaga(4,j)=dep_vel_o3(i,j) - enddo - enddo -! -! ls wet deposition -! - if(chem_opt .ne. 500) then - call wetdep_ls(dt,chem,rnav,moist,rho_phy,var_rmv,num_moist, & - num_chem,numgas,p_qc,dz8w,vvel,chem_opt, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - endif - -!if(mod(ktau,CallChemistry)==0.or.ktau==1) then -if(call_gocart == 1)then -! write(6,*)'in chem_driver, now do gocart chemistry and aod ' - call gocart_chem_driver(ktau,dtstep, gmt,julday,t_phy,moist, & - chem,rho_phy,dz8w,p8w,backg_oh,backg_h2o2,backg_no3, & - area,grvity,xlat,xlong,ttday,tcosz, & - chem_opt,num_chem,num_moist, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - call gocart_aerosols_driver(ktau,dtstep,t_phy,moist, & - chem,rho_phy,dz8w,p8w,area,grvity, & - chem_opt,num_chem,num_moist, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - if(aer_ra_feedback == 2 )then - call aero_opt('sw',dz8w,chem & - ,rri,relhum,aod & - ,extt,ssca,asympar,num_chem & - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte ) - - endif - if(aer_ra_feedback == 1 )then - call optical_driver(curr_secs,dtstep, & - chem,dz8w,rri,relhum, & -! h2oai,h2oaj, & - tauaersw,gaersw,waersw,bscoefsw,tauaerlw, & - l2aer,l3aer,l4aer,l5aer,l6aer,l7aer, & - num_chem,chem_opt,ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - call aer_opt_out(aod,dz8w, & - ext_coeff,bscat_coeff,asym_par, & - tauaersw,gaersw,waersw,tauaerlw, & - num_ext_coef,num_bscat_coef,num_asym_par, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - call aer_ra(dz8w & - ,extt,ssca,asympar,nbands & - ,tauaersw,gaersw,waersw,tauaerlw & - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte ) - - - endif -endif -! vcsulf_old(its:ite,kts:kte,jts:jte) = & -! max(chem(its:ite,kts:kte,jts:jte,p_sulf),epsilc) -! vcso2_old(its:ite,kts:kte,jts:jte) = & -! max(chem(its:ite,kts:kte,jts:jte,p_so2),epsilc) -! vch2o2_old(its:ite,kts:kte,jts:jte) = & -! max(chem(its:ite,kts:kte,jts:jte,p_h2o2),epsilc) - - if(chem_opt < 500 ) then - call sum_pm_gocart ( & - rri, chem,pm2_5_dry, pm2_5_dry_ec, pm10, & - num_chem,chem_opt,ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - - endif -! -! store aerosol optical variables for feedback in radiation -! - if(aer_ra_feedback >= 1 )then - do ib=1,nbands - do j=jts,jte - do k=kts,kte - do i=its,ite - ext_cof(k,j,ib)=extt(i,k,j,ib) - sscal(k,j,ib)=ssca(i,k,j,ib) - asymp(k,j,ib)=asympar(i,k,j,ib) - enddo - enddo - enddo - enddo -! print *,'in chem_driver ',nbands,maxval(extt),maxval(ext_cof) -! aod only output - do j=jts,jte - do i=its,ite - aod2d(j)=aod(i,j) -! aod2d(j)=dep_vel_o3(i,j) - enddo - enddo -! print *,maxval(aod2d) - endif ! feedback to radiation -! -! pm25 and pm10 for output , not for tracer options -! - if(chem_opt < 500) then - do j=jts,jte - do k=kts,kte - do i=its,ite - pm25(k,j)=pm2_5_dry(i,k,j) - p10(k,j)=pm10(i,k,j) - enddo - enddo - enddo - endif -! -! put chem stuff back into tracer array -! - do nv=1,num_chem - nvv=ntra+nv - do j=jts,jte - do k=kts,kte - do i=its,ite - tr3d(k,j,nvv)=max(epsilc,chem(i,k,j,nv)) - trdp(k,j,nvv)=tr3d(k,j,nvv)*dp3d(k,j) - enddo - enddo - enddo - if(chem_opt == 501 ) then - do j=jts,jte - do i=its,ite - trfall(j,nv)=trfall(j,nv)+tr_fall(i,j,nv)+var_rmv(i,j,nv) - enddo - enddo - endif - enddo - if(chem_opt == 500 ) then - do j=jts,jte - do k=kts,kte - do i=its,ite - tr1_tavg(k,j)=tr1_tavg(k,j)+chem(i,k,j,p_tr1) - enddo - enddo - enddo - endif - -!sms$compare_var(st3d , "end chem_driver ") -!sms$compare_var(sm3d , "end chem_driver ") -!sms$compare_var(ts2d , "end chem_driver ") -!sms$compare_var(us2d , "end chem_driver ") -!sms$compare_var(sw2d , "end chem_driver ") - - call IncrementTimer(t0,telapsed) - -!endif ! if(chem_opt >= 0) then - - END subroutine chem_driver - -END MODULE MODULE_CHEM_DRIVER - diff --git a/src/fim/FIMsrc/fim/horizontal/module_header.F90 b/src/fim/FIMsrc/fim/horizontal/module_header.F90 deleted file mode 100644 index 9c1dc8f..0000000 --- a/src/fim/FIMsrc/fim/horizontal/module_header.F90 +++ /dev/null @@ -1,68 +0,0 @@ -module module_header - - use module_control,only:ArchvTimeUnit,glvl,nip,yyyymmddhhmm - - implicit none - public header,header_size - private - -! Parameters - - integer,parameter::header_cols=80 - integer,parameter::header_rows=10 - integer,parameter::header_size=header_cols*header_rows - -! Module variables - - character(len=header_cols)::line - character::h(header_size) - integer::pos - -contains - - function header(varname,levels,its) - implicit none - character*(*),intent(in)::varname - character::header(header_size) - integer,intent(in)::its,levels - integer::its2time - pos=1 - h=' ' - write (line,'(a,a,a,a)') 'FIM ',varname,' Forecast initial time YYYYMMDDHHMM: ',yyyymmddhhmm - call append - write (line,'(a,i0,a,i0,a,i0,a,i0,a,a)') 'Level ',levels,', GLVL= ',glvl,', Step ',its,', ',its2time(its),' ',ArchvTimeUnit - call append - write (line,'(a,i0,a,i0)') 'dim1=',levels,', nip=',nip - call append - write (line,'(i0)') 4 - call append - write (line,'(i0)') 5 - call append - write (line,'(i0)') 6 - call append - write (line,'(i0)') 7 - call append - write (line,'(i0)') 8 - call append - write (line,'(i0)') 9 - call append - write (line,'(i0)') 10 - call append - header=h - end function header - - subroutine append - implicit none - integer::i,j - if (pos.ge.header_size) then - write (*,'(a)') 'ERROR: Attempt to write past end of header.' - stop - endif - do i=1,len(line) - j=pos+i-1 - h(j)=line(i:i) - enddo - pos=(int((pos+header_cols)/header_cols)*header_cols)+1 - end subroutine append - -end module module_header diff --git a/src/fim/FIMsrc/fim/horizontal/module_outvar_enkf.F90 b/src/fim/FIMsrc/fim/horizontal/module_outvar_enkf.F90 deleted file mode 100644 index b49ae5a..0000000 --- a/src/fim/FIMsrc/fim/horizontal/module_outvar_enkf.F90 +++ /dev/null @@ -1,96 +0,0 @@ -module module_outvar_enkf - -contains - -subroutine outvar_enkf(time,pr3d,ex3d,us3d,vs3d,tr3d,ph3d) - use module_constants ,only: lat,lon,rd,cp,p1000,grvity - use module_control ,only: & - nip,nvl,nvlp1,ntra,FixedGridOrder,dt,ptop,glvl,curve - use module_savesfc, only : savesfc - implicit none - ! External variable declarations: -!SMS$DISTRIBUTE (dh,nip) BEGIN - real ,intent(IN) :: us3d(nvl ,nip),vs3d(nvl,nip) - real ,intent(IN) :: pr3d(nvlp1,nip) - real ,intent(IN) :: ph3d(nvlp1,nip), ex3d(nvlp1,nip) - real ,intent(IN) :: tr3d(nvl,nip,ntra) -!SMS$DISTRIBUTE END - real :: tv3d(nvl ,nip),td3d(nvl,nip) ! local vars - character(len=6)::timestr - ! local vars - real exn - integer ivl,ipn, time, idx,lunout - - ! compute virtual temperature, layer pressure. -!SMS$SERIAL (, : default=ignore) BEGIN - do ipn=1,nip - do ivl=1,nvl - if (pr3d(ivl,ipn).gt.pr3d(ivl+1,ipn)+0.1) then - exn = (ex3d(ivl ,ipn)*pr3d(ivl ,ipn) & - -ex3d(ivl+1,ipn)*pr3d(ivl+1,ipn))/ & - ((cp+rd)*(pr3d(ivl,ipn)-pr3d(ivl+1,ipn))) - else - exn = .5*(ex3d(ivl,ipn)+ex3d(ivl+1,ipn))/cp - end if - !exn = .5*(ex3d(ivl,ipn)+ex3d(ivl+1,ipn))/cp - td3d(ivl,ipn)=p1000*(exn)**(cp/rd) ! layer pressure - tv3d(ivl,ipn) = tr3d(ivl,ipn,1) * exn ! virtual temp - !tv3d(ivl,ipn)=tv3d(ivl,ipn)/ (1.+0.6078*tr3d(ivl,ipn,1)) ! temperature - enddo - enddo -!SMS$SERIAL END - - ! write only fields for EnKF DA cycle to a single file. - lunout = 77 - -!SMS$SERIAL BEGIN - print *,'writing out EnKFIO file' - ! save model state. - write (timestr,'(i6.6)') time - open (lunout,file='fim_out_'//timestr,form="unformatted") - write(lunout) nip,nvl,3,0.01*ptop - write(lunout) lon - write(lunout) lat - ! orography. - write(lunout) ph3d(1,:)/grvity - ! pressure (hPa) on model layer midpoints. - do ivl=1,nvl - write(lunout) 0.01*td3d(ivl,:) - enddo - ! pressure (hPa) on model layer interaces (including - ! surface pressure (k=1) but not model top (k=nlevs+1)). - ! Model top pressure is assumed constant = ptop. - ! pressure (hPa) on model layer midpoints. - do ivl=1,nvl - write(lunout) 0.01*pr3d(ivl,:) - enddo - ! virtual temperature. - do ivl=1,nvl - write(lunout) tv3d(ivl,:) - enddo - ! u and v winds. - do ivl=1,nvl - write(lunout) us3d(ivl,:) - enddo - do ivl=1,nvl - write(lunout) vs3d(ivl,:) - enddo - ! "tracers" (vapor, ozone, cloud condensate) - ! note: order is different in GFS/FIM (ozone comes before clw in GFS) - do ivl=1,nvl - write(lunout) tr3d(ivl,:,2) - enddo - do ivl=1,nvl - write(lunout) tr3d(ivl,:,4) - enddo - do ivl=1,nvl - write(lunout) tr3d(ivl,:,3) - enddo - close(lunout) -!SMS$SERIAL END - ! save surface data. - call savesfc('fimsfc_out_'//timestr) - return -end subroutine outvar_enkf - -end module module_outvar_enkf diff --git a/src/fim/FIMsrc/fim/horizontal/module_savesfc.F90 b/src/fim/FIMsrc/fim/horizontal/module_savesfc.F90 deleted file mode 100644 index b96ca42..0000000 --- a/src/fim/FIMsrc/fim/horizontal/module_savesfc.F90 +++ /dev/null @@ -1,66 +0,0 @@ -module module_savesfc -contains -subroutine savesfc(filename) - use module_control ,only: & - nts,nvl,nip,glvl,curve - use module_sfc_variables - implicit none - character(len=17) filename - integer lunout,idx,ipn - ! save sfc variables at center of filter window. - print*,'in savesfc',filename -!SMS$SERIAL BEGIN - lunout = 77 - open (lunout,file=filename,form="unformatted",status="replace") - call WriteGlvlHeader (lunout,glvl ) - call WriteCurveHeader(lunout,curve) - do idx = 1,size(st3d,1) - write(lunout) st3d(idx,:) - enddo - do idx = 1,size(sm3d,1) - write(lunout) sm3d(idx,:) - enddo - do idx = 1,size(slc3d,1) - write(lunout) slc3d(idx,:) - enddo - write(lunout) ts2d - write(lunout) sheleg2d - write(lunout) tg32d - write(lunout) zorl2d - write(lunout) cv2d - write(lunout) cvb2d - write(lunout) cvt2d - write(lunout) alvsf2d - write(lunout) alvwf2d - write(lunout) alnsf2d - write(lunout) alnwf2d - write(lunout) slmsk2d - write(lunout) vfrac2d - write(lunout) canopy2d - write(lunout) f10m2d - write(lunout) t2m2d - write(lunout) q2m2d - write(lunout) vtype2d - write(lunout) stype2d - write(lunout) facsf2d - write(lunout) facwf2d - write(lunout) uustar2d - write(lunout) ffmm2d - write(lunout) ffhh2d - write(lunout) hice2d - write(lunout) fice2d - write(lunout) tprcp2d - write(lunout) srflag2d - write(lunout) snwdph2d - write(lunout) slc2d - write(lunout) shdmin2d - write(lunout) shdmax2d - write(lunout) slope2d - write(lunout) snoalb2d - do idx = 1,size(hprm2d,1) - write(lunout) hprm2d(idx,:) - enddo - close(lunout) -!SMS$SERIAL END -end subroutine savesfc -end module module_savesfc diff --git a/src/fim/FIMsrc/fim/horizontal/momtum.F90 b/src/fim/FIMsrc/fim/horizontal/momtum.F90 deleted file mode 100644 index 12a434e..0000000 --- a/src/fim/FIMsrc/fim/horizontal/momtum.F90 +++ /dev/null @@ -1,214 +0,0 @@ -module module_momtum -use stencilprint -use findmaxmin2 -use findmaxmin3 -contains -!********************************************************************* -! momtum -! Solves momentum equations -! Alexander E. MacDonald 12/22/2004 -! J. Lee September 2005 -! R. Bleck major rewrite April 2008 -! R. Bleck removed omega diagnostics August 2009 -!********************************************************************* - - subroutine momtum (its,nf,of,vof,adbash1,adbash2,adbash3, & - u_velo,v_velo,exner,relvort, & - u_edg,v_edg,trcr_edg,bnll_edg,u_tndcy,v_tndcy,dp3d) - - use module_control ,only: nvl,nvlp1,npp,nip,nabl,dt,ntra, & - rleigh_light,rleigh_heavy, & - PrintIpnDiag,veldff_bkgnd,veldff_boost - use module_constants,only: nprox,rarea,sidevec_c,sidevec_e,corio - use module_dissip - - implicit none - -! External type and dimension: - integer,intent (IN) :: its ! model time step - integer,intent (IN) :: nf,of,vof ! time slots: new,old,very old - real ,intent (IN) :: adbash1,adbash2,adbash3 -!SMS$DISTRIBUTE (dh,nip) BEGIN - real ,intent (IN) :: u_edg (nvl,npp,nip) - real ,intent (IN) :: v_edg (nvl,npp,nip) - real ,intent (INOUT) :: u_velo (nvl,nip) - real ,intent (INOUT) :: v_velo (nvl,nip) - real ,intent (IN) :: exner (nvlp1,nip) - real ,intent (IN) :: trcr_edg (nvl,npp,nip,ntra) - real ,intent (IN) :: bnll_edg (nvl,npp,nip) - real ,intent (INOUT) :: u_tndcy (nvl,nip,nabl) - real ,intent (INOUT) :: v_tndcy (nvl,nip,nabl) - real ,intent (OUT) :: relvort (nvl,nip) - real ,intent (IN) :: dp3d (nvl,nip) ! layer thickness - -! Local variables - real pgfx(nvl,nip),pgfy(nvl,nip) -!SMS$DISTRIBUTE END - - integer :: k ! layer index - integer :: ipn ! icos point index - integer :: edg ! icos edge index - integer :: ndamp ! number of layer subjected to dissipation - character :: string*24 - logical :: vrbos - real :: factor,wgt - real :: uzeta,vzeta,uold,vold - real :: dfflen(nvl) - -!! do k=1,nvl,7 -!! write (string,'(a,i3,a)') 'k=',k,' u_velo' -!! call findmxmn2(u_velo,nvl,nip,k,string) -!! -!! write (string,'(a,i3,a)') 'k=',k,' v_velo' -!! call findmxmn2(v_velo,nvl,nip,k,string) -!! end do -!! print * - -! --- dampen gravity waves near model top by mixing momentum laterally - -! --- 'diffusion length' dfflen = (diffusivity) * (time step) / (mesh size) -! --- = (diffusion velocity) x (time step) - - ndamp=0.1*nvl ! number of layers subjected to dissipation - do k=1,nvl - wgt=max(0.,float(k-nvl+ndamp)/float(ndamp)) - dfflen(k)=dt*(veldff_bkgnd*(1.-wgt)+veldff_boost*wgt) - end do - - call dissip(u_velo,v_velo,dp3d,dfflen,.false.) - -!SMS$PARALLEL (dh,ipn) BEGIN -! Initialize line integrals: - pgfx (:,:)=0. - pgfy (:,:)=0. - relvort(:,:)=0. - -!sms$compare_var(u_tndcy , "momtum.F90 - u_tndcy5 ") -!sms$compare_var(v_tndcy , "momtum.F90 - v_tndcy5 ") -!sms$compare_var(exner , "momtum.F90 - exner5 ") -!sms$compare_var(bnll_edg, "momtum.F90 - bnll_edg5 ") - - do ipn=1,nip ! horizontal loop - vrbos=ipn.eq.PrintIpnDiag - - ! loop through edges and compute line integrals of bernoulli function, - ! potential temperature, and pressure gradient - - do edg=1,nprox(ipn) ! loop through edges - do k=1,nvl ! loop through layers - - pgfx(k,ipn) = pgfx(k,ipn) & - -bnll_edg(k,edg,ipn)*sidevec_c(2,edg,ipn) & - +.5*(exner(k,ipn)+exner(k+1,ipn)) & - *trcr_edg(k,edg,ipn,1)*sidevec_c(2,edg,ipn) - pgfy(k,ipn) = pgfy(k,ipn) & - +bnll_edg(k,edg,ipn)*sidevec_c(1,edg,ipn) & - -.5*(exner(k,ipn)+exner(k+1,ipn)) & - *trcr_edg(k,edg,ipn,1)*sidevec_c(1,edg,ipn) - - ! Vorticity is calculated as a line integral of the tangential wind - ! component given by the dot product of the wind vector with sidevec. - ! Sidevec is a vectorial representation of the edge. - - relvort(k,ipn) = relvort(k,ipn) & - + ((sidevec_e(1,edg,ipn)*u_edg(k,edg,ipn) & - + sidevec_e(2,edg,ipn)*v_edg(k,edg,ipn))) - - enddo ! loop through layers - enddo ! loop through edges - -!SMS$ignore begin - if (vrbos) write (*,100) its,ipn - 100 format ('m o m t u m time step',i6,' ipn =',i8/ & - 4x,' uold unew utdcy gradp corio', & - 4x,' vold vnew vtdcy gradp corio') -!SMS$ignore end - - do k=1,nvl ! loop through layers - pgfx (k,ipn) = pgfx (k,ipn)*rarea(ipn) - pgfy (k,ipn) = pgfy (k,ipn)*rarea(ipn) - relvort(k,ipn) = relvort(k,ipn)*rarea(ipn) - - uzeta=(corio(ipn)+relvort(k,ipn))*u_velo(k,ipn) - vzeta=(corio(ipn)+relvort(k,ipn))*v_velo(k,ipn) - - ! u/v tendcy is the sum of bernoulli fct. gradient and coriolis term - u_tndcy (k,ipn,nf) = pgfx(k,ipn) + vzeta - v_tndcy (k,ipn,nf) = pgfy(k,ipn) - uzeta - - ! advance velocity field in time - uold=u_velo(k,ipn) - vold=v_velo(k,ipn) - - u_velo(k,ipn) = u_velo(k,ipn) & - +adbash1*u_tndcy(k,ipn, nf) & - +adbash2*u_tndcy(k,ipn, of) & - +adbash3*u_tndcy(k,ipn,vof) - v_velo(k,ipn) = v_velo(k,ipn) & - +adbash1*v_tndcy(k,ipn, nf) & - +adbash2*v_tndcy(k,ipn, of) & - +adbash3*v_tndcy(k,ipn,vof) - -!SMS$ignore begin - if (vrbos .and. mod(k,7).eq.1) write (*,101) k, & - uold,u_velo(k,ipn),u_tndcy(k,ipn,nf)*dt,pgfx(k,ipn)*dt, vzeta*dt, & - vold,v_velo(k,ipn),v_tndcy(k,ipn,nf)*dt,pgfy(k,ipn)*dt,-uzeta*dt - 101 format (i4,2f7.1,3f7.2,4x,2f7.1,3f7.2) -!SMS$ignore end - enddo ! loop through layers - - ! Rayleigh damping of u,v near model top - - ndamp=0.25*nvl - -!SMS$ignore begin - if (vrbos) write (*,107) ipn,'u,v bfore Rayleigh damping:', & - (k,u_velo(k,ipn),v_velo(k,ipn),k=nvl-ndamp,nvl) - 107 format ('ipn=',i8,3x,a/(i15,2f9.2)) -!SMS$ignore end - - if (u_velo(nvl,ipn)**2+v_velo(nvl,ipn)**2 .gt. 1.e4) then - do k=nvl-ndamp,nvl - factor=1.-(dt/86400.)*rleigh_heavy*2.**(30.*(k-nvl)/nvl) - u_velo(k,ipn)=u_velo(k,ipn)*factor - v_velo(k,ipn)=v_velo(k,ipn)*factor - end do - else - do k=nvl-ndamp,nvl - factor=1.-(dt/86400.)*rleigh_light*2.**(30.*(k-nvl)/nvl) - u_velo(k,ipn)=u_velo(k,ipn)*factor - v_velo(k,ipn)=v_velo(k,ipn)*factor - end do - end if - -!SMS$ignore begin - if (vrbos) write (*,107) ipn,'u,v after Rayleigh damping:', & - (k,u_velo(k,ipn),v_velo(k,ipn),k=nvl-ndamp,nvl) -!SMS$ignore end - - end do ! horizontal loop -!SMS$PARALLEL END - - write (string,'(a,i6,2x)') 'step',its - call stencl(u_velo,nvl,1.,string(1:12)//'(atm momtum) new u') - call stencl(v_velo,nvl,1.,string(1:12)//'(atm momtum) new v') -! call stencl(pgfx,nvl,1.e3,string(1:12)//'(atm momtum) pgfx x 1000') -! call stencl(pgfy,nvl,1.e3,string(1:12)//'(atm momtum) pgfy x 1000') - -!sms$compare_var(u_tndcy, "momtum.F90 - u_tndcy6 ") -!sms$compare_var(v_tndcy, "momtum.F90 - v_tndcy6 ") -!sms$compare_var(u_velo , "momtum.F90 - u_velo6 ") -!sms$compare_var(v_velo , "momtum.F90 - v_velo6 ") - -!! do k=1,nvl,7 -!! write (string,'(a,i3,a)') 'k=',k,' u_tndcy' -!! call findmxmn3(u_tndcy,nvl,nip,3,k,nf,string) -!! -!! write (string,'(a,i3,a)') 'k=',k,' v_tndcy' -!! call findmxmn3(v_tndcy,nvl,nip,3,k,nf,string) -!! end do -!! print * - - return - end subroutine momtum - end module module_momtum diff --git a/src/fim/FIMsrc/fim/horizontal/op_diag.F90 b/src/fim/FIMsrc/fim/horizontal/op_diag.F90 deleted file mode 100644 index a180c48..0000000 --- a/src/fim/FIMsrc/fim/horizontal/op_diag.F90 +++ /dev/null @@ -1,484 +0,0 @@ -module module_op_diag -contains -!********************************************************************* -! op_diag -! Calculate derived variables for output from FIM global model -! S. Benjamin Feb 2008 -! S. Benjamin - Apr 2008 -! - mods for use of theta-v in th3d prog variable -! instead of previous non-virt theta in th3d -! S. Benjamin - May 2008 -! - calculation of isobaric 25-mb fields -! on native icosahedral horizontal grid -! added in array g3p -! Will allow improved isobaric fields to be -! output from FIMpost, with improved reduction -! from full multivariate calculations using -! all fields (which are available in FIM but not FIMpost) -!********************************************************************* - -subroutine op_diag( & - its,nts, & ! index time step, final timestep - us3d,vs3d,dp3d, & ! west wind, south wind, delta pres - pr3d,ex3d,mp3d, & ! pressure, Exner, mont pot, - tr, vor,ws3d, & ! tracers - ph3d,rn2d,rc2d, & ! geopotential,accumulated precipitation/rainfall - ts2d,us2d,hf2d,qf2d,sw2d,lw2d,st3d,sm3d & -! Below are output variables from op_diag & - ,tk3d, rh3d, td3d, pw2d, mslp, g3p, g2d,time & - ) - - -use module_constants -use module_control,only: nvl,nvlp1,nip,ntra,ntrb,nvlp,nvarp,nvar2d, & - dt,glvl,curve,yyyymmddhhmm,ArchvTimeUnit,pres_pa -use restart, only: write_restart - -USE MACHINE , ONLY : kind_rad -USE FUNCPHYS , ONLY : fpvs, fpvsl -use module_outqv ,only: outqv -use module_outqv_mn ,only: outqv_mn -use module_outqv_mn_lat ,only: outqv_mn_lat -use module_outqv_mn_lat_abs,only: outqv_mn_lat_abs -use module_out4d_mn ,only: out4d_mn - -!USE FUNCPHYS , ONLY : fpvs, ftdp -implicit none - -! External variable declarations: -integer,intent(IN) :: its,nts -!SMS$DISTRIBUTE (dh,nip) BEGIN -real ,intent(IN) :: us3d(nvl ,nip),vs3d(nvl,nip),dp3d(nvl,nip) -real ,intent(IN) :: pr3d(nvlp1,nip) -real ,intent(IN) :: mp3d(nvl ,nip) -real ,intent(IN) :: vor (nvl ,nip) !not used -real ,intent(IN) :: ws3d(nvl ,nip) -real ,intent(IN) :: ph3d(nvlp1,nip) -real ,intent(IN) :: ex3d(nvlp1,nip) -real ,intent(IN) :: tr(nvl ,nip,ntra+ntrb) -real ,intent(OUT) :: rh3d(nvl ,nip) -real ,intent(OUT) :: tk3d(nvl ,nip) -real ,intent(OUT) :: g3p (nvlp ,nip, nvarp) -real ,intent(OUT) :: g2d (nip ,nvar2d) - -! nvar2d indices -! 1 - height cloud base (in meters above sea level (ASL)) -! 2 - pressure cloud base (Pa) -! 3 - height cloud top (m ASL) -! 4 - pressure cloud top (Pa) -! 5 - column relative humidity with respect to saturated column precipitable water (0-1) - -real :: cloudbase(nip) -real ,intent(INOUT) :: td3d(nvl,nip) -real ,intent(INOUT) :: pw2d(nip) -real ,intent(INOUT) :: mslp(nip) - -real ,intent(IN) :: rn2d(nip),rc2d(nip) -real ,intent(IN) :: ts2d(nip),us2d(nip),hf2d(nip),qf2d(nip),sw2d(nip),lw2d(nip),st3d(4,nip),sm3d(4,nip) -real :: th3d(nvl,nip),qv3d(nvl,nip),qw3d(nvl,nip) -real :: dummy(nvl,nip) -! pkap = (p/p0)**(R/Cp) i.e., p(in bars) to the kappa (Rd/Cp) power -! pkap = Exner / Cp -real :: pkap (nvl), hgt(nvl), pres(nvl), tvirt(nvl), thv(nvl), thnv(nvl) -real :: pklv (nvlp1) -real :: pkapp (nvlp), prsp(nvlp),tsfc -integer :: nsmooth, isn, ism -!real :: oz3d(nvl,nip) -real :: rhpw(nip), satpw(nip) -!SMS$DISTRIBUTE END - -integer,intent(in) :: time -integer, parameter :: lunout=40,lun3d=50,lun2d=60 ! Logical units for output -character(80) :: filename -character(80) :: header(10) -character(4) :: var(5) -integer :: ivl,ipn,nop=0,nrs=0 -integer :: nv,ivlp, ivar -real :: drh, du, dv, rh, fact -real :: maxqv3d,minqv3d,aveqv3d,maxdp3d,mindp3d,avedp3d -real :: esw,qsw,es,esln -real :: thet,dthet,dpkap,dhgt -real :: gam, gamd, gams, ex1, ex1s, ex1sinv,tt1,t6 -real :: tsfcnew, thbar -real :: cloud_def_p, zcldbase, pcldbase, zcldtop, pcldtop, watericemax - -integer :: LB - -real (kind=kind_rad) :: tk - -! 6.5 K/km - Standard lapse rate - DATA GAMs /0.0065/ -! 10 K/km - Dry adiabatic lapse rate - DATA GAMD /0.0100/ - DATA cloud_def_p /0.00001/ -! DATA cloud_def_p /0.000001/ - -! Variable names for outqv* printout - DATA var /'Hgt ','Temp','RH ','Uwnd','Vwnd' / - -nsmooth = 1 - -!there is an SMS problem writing tr(:,:,1) - th3d(:,:)=tr(:,:,1) - qv3d(:,:)=tr(:,:,2) - qw3d(:,:)=tr(:,:,3) -! oz3d(:,:)=tr(:,:,4) - header(1:10) = ' ' -! Calculate isobaric levels every 25 hPa - do ivlp = 1,nvlp - ! prsp(ivlp) = p1000 -(float(ivlp-1) * 2500.) ! in Pa - prsp(ivlp) = float(pres_pa(ivlp)) ! in Pa -! pkapp(ivlp) = (1.- float(ivlp-1)* 0.025)**(rd/cp) - pkapp(ivlp) = (prsp(ivlp)/100000.)**(rd/cp) - print *, "in op_diag calc levels: prsp(",ivlp,"): ",prsp(ivlp)," pkapp(",ivlp,"): ", pkapp(ivlp) - end do - - ex1s = rd*gams/grvity - ex1sinv= 1./ex1s - -!SMS$PARALLEL (dh,ipn) BEGIN - -!............................................................ -! Beginning of horizontal loop -!............................................................ - do ipn=1,nip - pw2d(ipn) = 0. - satpw (ipn) = 0. - -! Initialize isobaric fields as -999999. = -spval_p - g3p(:,ipn,:) = -spval_p - g2d(ipn,:) = -spval_p - - do ivl=1,nvl -! PW calculation here uses water vapor and condensate. - pw2d(ipn) = pw2d(ipn)+dp3d(ivl,ipn)*(tr(ivl,ipn,2)+tr(ivl,ipn,3))/grvity -! pw2d(ipn) = pw2d(ipn)+dp3d(ivl,ipn)*(tr(ivl,ipn,2))/grvity - -!rb pres(ivl) = 0.5*(pr3d(ivl,ipn)+pr3d(ivl+1,ipn)) -!rb hgt1(ivl) = 0.5*(ph3d(ivl,ipn)+ph3d(ivl+1,ipn)) / 9.8 -!rb pkap(ivl) = (pres(ivl)/p1000)**(rd/cp) - - if (pr3d(ivl,ipn).gt.pr3d(ivl+1,ipn)+0.1) then - pkap(ivl) = (ex3d(ivl ,ipn)*pr3d(ivl ,ipn) & - -ex3d(ivl+1,ipn)*pr3d(ivl+1,ipn))/ & - ((cp+rd)*(pr3d(ivl,ipn)-pr3d(ivl+1,ipn))) - else - pkap(ivl)=0.5*(ex3d(ivl,ipn)+ex3d(ivl+1,ipn))/cp - end if - pres(ivl)=p1000*pkap(ivl)**(cp/rd) - hgt(ivl)=(ph3d(ivl,ipn) & - +(ex3d(ivl,ipn)-cp*pkap(ivl))*th3d(ivl,ipn)) / 9.8 - - tvirt(ivl) = th3d(ivl,ipn) * pkap(ivl) ! virtual temp -! temperature - tk3d(ivl,ipn)=tvirt(ivl) / (1.+0.6078*qv3d(ivl,ipn)) ! temperature - thv (ivl) = th3d(ivl,ipn) ! virtual pot temp - thnv (ivl) = th3d(ivl,ipn)/(1.+0.6078*qv3d(ivl,ipn)) ! non-virt pot temp - tk = tk3d(ivl,ipn) -! sat vapor pressure w.r.t. water/ice combination -! esw=fpvs(tk) -! sat vapor pressure w.r.t. water (liquid) only - esw=fpvsl(tk) - esw=min (real(fpvsl(tk)) , pres(ivl)) ! qsw <= 1, as it has to be - - qsw=0.62197*esw / (pres(ivl)-0.37803*esw) - qsw = max(1.e-8,min(qsw,0.1)) - dummy(ivl,ipn) = qsw - rh3d(ivl,ipn)=100.*max(0., min(1., tr(ivl,ipn,2)/qsw)) - ! rh for 0-100, as done in GRIB for other models -! PW in saturated column - satpw(ipn) = satpw(ipn)+(dp3d(ivl,ipn)*qsw/grvity) - - es = pres(ivl)*(tr(ivl,ipn,2)+1.e-8)/(0.62197+(tr(ivl,ipn,2)+1.e-8)) - esln = log(es) - td3d(ivl,ipn)= (35.86*esln-4947.2325)/(esln-23.6837) - end do - - rhpw(ipn) = pw2d(ipn) / satpw(ipn) - -! Exner-like variables -! =================== -! pkap = (p/p0)**(R/Cp) i.e., p(in bars) to the kappa (Rd/Cp) power -! pkap = Exner / Cp -! =================== -! pklv - Exner fn / Cp (0-1) on nvl+1 LEVELS (not layer midpoints) -! pkap - " " " nvl LAYER midpoints -! pkapp - " " " on nvlp ISOBARIC levels - -! temperature variables -! =================== -! th3d, thv - virtual potential temperature on nvl LAYER midpoints -! thnv - NON-virt " " " " " " -! tvirt - virtual temperature on nvl LAYER midpoint -! tk3d - nonvirtual " " " " " -! - - do ivl=1,nvlp1 - pklv(ivl)= ex3d(ivl,ipn)/cp - end do - -! Calculate isobaric values - -! -- Step 1 -! Calculate lapse rate (in virtual temp!) near surface: -! Level 6 should be about 60 hPa above surface. -! To avoid excessive effect (warm or cold) from lowest level, -! use theta(ivl=3) with pres(ivl=1) to obtain -! estimated temp at level 1 (also used in RUC post - hb2p.f) - - tt1=thnv (3 )*pkap(1) - t6 =thnv (6 )*pkap(6) - gam = (tt1-t6)/(hgt(6)-hgt(1)) - gam = min (gamd, max(gam,gams)) - ex1 = rd*gam/grvity - tsfc=thnv(3 )*(pr3d(1,ipn)/p1000)**(rd/cp) ! tsfc only for reduction here - -! tsfc - virtual temp at lowest LEVEL -! tt1 - virtual temp at lowest LAYER midpoint - -! Step 2 - obtain isobaric variables (except height) IF terrain elevation allows - do ivlp = 1,nvlp - do ivl=2,nvl - dthet = thnv (ivl) - thnv (ivl-1) - dpkap = pkap(ivl) - pkap(ivl-1) - drh = rh3d(ivl,ipn) - rh3d(ivl-1,ipn) - du = us3d(ivl,ipn) - us3d(ivl-1,ipn) - dv = vs3d(ivl,ipn) - vs3d(ivl-1,ipn) - if (pkap(ivl) .lt. pkapp(ivlp) .and.pkap(ivl-1).ge.pkapp(ivlp) ) then - thet = thnv (ivl-1) & - + (pkapp(ivlp)-pkap(ivl-1)) * dthet/dpkap - rh = rh3d(ivl-1,ipn) & - + (pkapp(ivlp)-pkap(ivl-1)) * drh /dpkap - g3p(ivlp,ipn,4) = us3d(ivl-1,ipn) & - + (pkapp(ivlp)-pkap(ivl-1)) * du /dpkap - g3p(ivlp,ipn,5) = vs3d(ivl-1,ipn) & - + (pkapp(ivlp)-pkap(ivl-1)) * dv /dpkap - g3p(ivlp,ipn,2) = thet*pkapp(ivlp) - g3p(ivlp,ipn,3) = rh - if(ntrb.gt.0)then - do nv=ntra+1,ntra+ntrb - dv = tr(ivl,ipn,nv) - tr(ivl-1,ipn,nv) - g3p(ivlp,ipn,5+nv-ntra-1) = tr(ivl-1,ipn,nv) & - + (pkapp(ivlp)-pkap(ivl-1)) * dv /dpkap - enddo - endif - end if - end do ! ivl - - end do ! ivlp - -! Step 3 - Now, obtain isobaric heights IF terrain elevation allows - do 10 ivlp = 1,nvlp - do ivl=2,nvlp1 - if (pklv(ivl) .le. pkapp(ivlp) .and.pklv(ivl-1).gt.pkapp(ivlp) ) then - dpkap = pklv(ivl) - pklv(ivl-1) - dhgt = (ph3d(ivl,ipn) - ph3d(ivl-1,ipn))/9.8 - g3p(ivlp,ipn,1) = ph3d(ivl-1,ipn)/9.8 + (pkapp(ivlp)-pklv(ivl-1)) * dhgt/dpkap - go to 10 - end if - end do -10 continue - - -! Step 4 - REDUCE from atmosphere above to obtain heights/temps below terrain surface -! Set other isobaric variables also below terrain surface - do ivlp = nvlp-1,1,-1 - if (pkap(1) < pkapp(ivlp)) then - g3p(ivlp,ipn,2) = tt1*(prsp(ivlp)/pres(1))**ex1s - g3p(ivlp,ipn,1) = ph3d(1,ipn)/9.8 - (g3p(ivlp,ipn,2)-tsfc)/gams - g3p(ivlp,ipn,3) = g3p(ivlp+1,ipn,3) - g3p(ivlp,ipn,4) = g3p(ivlp+1,ipn,4) - g3p(ivlp,ipn,5) = g3p(ivlp+1,ipn,5) - if(ntrb.gt.0)then - do nv=ntra+1,ntra+ntrb - g3p(ivlp,ipn,nv) = g3p(ivlp+1,ipn,nv) - enddo - endif - end if - end do - -! do ivlp = nvlp-3, nvlp -! Step 5 - EXTRAPOLATE to obtain height/temp above top native level -! Set other isobaric variables also above top native level -! if (g3p(ivlp,ipn,2) < 10.) then -! g3p(ivlp,ipn,2) = tk3d(nvl,ipn) ! isothermal lapse rate -! g3p(ivlp,ipn,1) = hgt(nvl) + rd*tk3d(nvl,ipn)/grvity & -! * alog(pres(nvl)/prsp(ivlp)) -! g3p(ivlp,ipn,3) = g3p(ivlp-1,ipn,3) -! g3p(ivlp,ipn,4) = g3p(ivlp-1,ipn,4) -! g3p(ivlp,ipn,5) = g3p(ivlp-1,ipn,5) -! if(ntrb.gt.0)then -! do nv=ntra+2,ntra+ntrb -! g3p(ivlp,ipn,nv) = g3p(ivlp-1,ipn,nv) -! enddo -! endif -! end if -! end do - -! calculate mean pot temp from surface (actually, theta at level 2) down to sea level -! using 0.8e-3 lapse rate - thbar = th3d(2,ipn) - ph3d(1,ipn)* 0.5 * 0.8e-3 / grvity -! Calculate sea-level pressure reduction - mslp(ipn) = p1000 * ((pr3d(1,ipn)/p1000)**(rd/cp) + ph3d(1,ipn)/(cp*thbar))**(cp/rd) - -!=============================================================== -! Cloud base/top diagnosis -!=============================================================== - -! g2d(ipn,1) = -spval_p - watericemax = 0. - zcldbase = -spval_p - zcldtop = -spval_p - pcldbase = 0. - pcldtop = 0. - - do ivl = 1,nvl - watericemax = max(watericemax, tr(ivl,ipn,3) ) - end do - - if (watericemax < cloud_def_p) go to 500 - -! At surface? - if (tr(1,ipn,3) > cloud_def_p) then - zcldbase = hgt (1) - pcldbase = pres(1) - go to 400 - end if - -! Cloud aloft? - do ivl = 3,nvl - if (tr(ivl,ipn,3) > cloud_def_p) then - zcldbase = hgt(ivl-1) + (tr(ivl,ipn,3)-cloud_def_p) & - *(hgt(ivl ) - hgt(ivl-1)) & - / max(cloud_def_p,(tr (ivl, ipn,3)-tr(ivl-1,ipn,3))) -! zcldbase = hgt(ivl) - - pcldbase = pres(ivl-1) + (tr(ivl,ipn,3)-cloud_def_p) & - *(pres(ivl ) - pres(ivl-1)) & - / max(cloud_def_p,(tr (ivl, ipn,3)-tr(ivl-1,ipn,3))) -! pcldbase = pres(ivl) - go to 400 - end if - end do - -400 continue - - do ivl = nvl-2, 2, -1 - if (tr(ivl,ipn,3) .gt. cloud_def_p) then - zcldtop = hgt(ivl) + (tr(ivl,ipn,3)-cloud_def_p) & - *(hgt(ivl+1) - hgt(ivl)) & - / max(cloud_def_p,(tr (ivl, ipn,3)-tr(ivl+1,ipn,3))) -! zcldtop = hgt(ivl) - pcldtop = pres(ivl) + (tr(ivl,ipn,3)-cloud_def_p) & - *(pres(ivl+1) - pres(ivl )) & - / max(cloud_def_p,(tr (ivl, ipn,3)-tr(ivl+1,ipn,3))) -! pcldtop = pres(ivl) - go to 500 - end if - end do - -500 continue - - cloudbase(ipn) = zcldbase - g2d(ipn,1) = zcldbase - g2d(ipn,2) = pcldbase - g2d(ipn,3) = zcldtop - g2d(ipn,4) = pcldtop - g2d(ipn,5) = rhpw(ipn) - g2d(ipn,6) = satpw(ipn) - - -!............................................................ - end do ! ipn loop - primary horizontal loop -!............................................................ - -!SMS$PARALLEL END - - - LB = LBOUND(g2d,1) - write (6,'(a,i9,1x,2a,i8)') ' MAPS SLP at ',time,ArchvTimeUnit,', time step=',its - call outqv_mn ( mslp ,1,nip,its ,0.01) - write (6,'(a,i9,1x,2a,i8)') ' MAPS SLP - max/min at ',time,ArchvTimeUnit,', time step=',its - call outqv ( mslp ,deg_lat,deg_lon,nip,1,0.01) - write (6,'(a,i9,1x,2a,i8)') ' Precipitable water at ',time,ArchvTimeUnit,', time step=',its - call outqv_mn ( pw2d ,1,nip,its ,1.) - write (6,'(a,i9,1x,2a,i8)') ' Precipitable water - max/min at ',time,ArchvTimeUnit,', time step=',its - call outqv ( pw2d ,deg_lat,deg_lon,nip,1 ,1.) - - write (6,'(a,i9,1x,2a,i8)') ' SatPW at ',time,ArchvTimeUnit,', time step=',its - call outqv_mn ( g2d(LB,6) ,1,nip,its ,1.) - write (6,'(a,i9,1x,2a,i8)') ' SatPW - max/min at ',time,ArchvTimeUnit,', time step=',its - call outqv ( g2d(LB,6) ,deg_lat,deg_lon,nip,1,1.) - - write (6,'(a,i9,1x,2a,i8)') ' RH w.r.t. PW at ',time,ArchvTimeUnit,', time step=',its - call outqv_mn ( g2d(LB,5) ,1,nip,its ,1.) - write (6,'(a,i9,1x,2a,i8)') ' RH w.r.t. PW - max/min at ',time,ArchvTimeUnit,', time step=',its - call outqv ( g2d(LB,5) ,deg_lat,deg_lon,nip,1,1.) - - write (6,'(a,i9,1x,2a,i8)') ' Temperature at ',time,ArchvTimeUnit,', time step=',its - call outqv_mn ( tk3d ,nvl,nip,its ,1.) - write (6,'(a,i9,1x,2a,i8)') ' Temperature -max/min at ',time,ArchvTimeUnit,', time step=',its - call outqv ( tk3d ,deg_lat,deg_lon,nip,nvl,1.) - write (6,'(a,i9,1x,2a,i8)') ' RH at ',time,ArchvTimeUnit,', time step=',its - call outqv_mn ( rh3d ,nvl,nip,its ,1.) - write (6,'(a,i9,1x,2a,i8)') ' RH - max/min at ',time,ArchvTimeUnit,', time step=',its - call outqv ( rh3d ,deg_lat,deg_lon,nip,nvl,1.) - - write (6,'(a,i9,1x,2a,i8)') ' qsw at ',time,ArchvTimeUnit,', time step=',its - call outqv_mn ( dummy ,nvl,nip,its ,1.) - write (6,'(a,i9,1x,2a,i8)') ' qsw - max/min at ',time,ArchvTimeUnit,', time step=',its - call outqv ( dummy ,deg_lat,deg_lon,nip,nvl,1.) - - write (6,'(a,i9,1x,2a,i8)') ' Cloudbase - max/min at ',time,ArchvTimeUnit,', time step=',its - call outqv ( cloudbase ,deg_lat,deg_lon,nip,1,1.) - write (6,'(a,i9,1x,2a,i8)') ' Cloud base height - max/min at ',time,ArchvTimeUnit,', time step=',its - call outqv ( g2d(LB,1) ,deg_lat,deg_lon,nip,1,1.) - write (6,'(a,i9,1x,2a,i8)') ' Cloud base pressure - max/min at ',time,ArchvTimeUnit,', time step=',its - call outqv ( g2d(LB,2) ,deg_lat,deg_lon,nip,1,1.) - write (6,'(a,i9,1x,2a,i8)') ' Cloud top height - max/min at ',time,ArchvTimeUnit,', time step=',its - call outqv ( g2d(LB,3) ,deg_lat,deg_lon,nip,1,1.) - write (6,'(a,i9,1x,2a,i8)') ' Cloud top pressure - max/min at ',time,ArchvTimeUnit,', time step=',its - call outqv ( g2d(LB,4) ,deg_lat,deg_lon,nip,1,1.) - - write (6,'(a,i9,1x,2a,i8)') ' Soil moisture at ',time,ArchvTimeUnit,', time step=',its - call outqv_mn ( sm3d ,4,nip,its ,1.) - write (6,'(a,i9,1x,2a,i8)') ' Soil moisture - max/min at ',time,ArchvTimeUnit,', time step=',its - call outqv ( sm3d ,deg_lat,deg_lon,nip,4,1.) - - fact = 1000. - write (6,'(a,i9,1x,2a,i8)') ' Sensible heat flux at ',time,ArchvTimeUnit,', time step=',its - call outqv_mn (hf2d,1,nip,its,1.) - write (6,'(a,i9,1x,2a,i8)') ' Sensible heat flux at ',time,ArchvTimeUnit,', time step=',its - call outqv_mn_lat (hf2d,deg_lat,deg_lon,30.,1,nip,its,fact) - write (6,'(a,i9,1x,2a,i8)') ' Latent heat flux at ',time,ArchvTimeUnit,', time step=',its - call outqv_mn (qf2d,1,nip,its,1.) - write (6,'(a,i9,1x,2a,i8)') ' Latent heat flux at ',time,ArchvTimeUnit,', time step=',its - call outqv_mn_lat (qf2d,deg_lat,deg_lon,30.,1,nip,its,fact) - - LB = LBOUND(g3p,2) - do ivar=1,5 - - write (6,'(2a,i9,1x,2a,i8)') var(ivar),'-isobaric at ',time,ArchvTimeUnit,', time step=',its - call outqv_mn ( g3p(1,LB,ivar),nvlp,nip,its,1.) - write (6,'(2a,i9,1x,2a,i8)') var(ivar),'-isobaric - max/min at ',time,ArchvTimeUnit,', time step=',its - call outqv ( g3p(1,LB,ivar) ,deg_lat,deg_lon,nip,nvlp,1.) - end do - - -!SMS$PARALLEL (dh,ipn) BEGIN - do ipn = 1,nip - do ivl=1,nvl - dummy (ivl,ipn) = tk3d(ivl,ipn) - td3d(ivl,ipn) - end do - end do -!SMS$PARALLEL END - write (6,'(a,i9,1x,2a,i8)') ' T-Td at ',time,ArchvTimeUnit,', time step=',its - call outqv_mn ( dummy ,nvl,nip,its ,1.) - write (6,'(a,i9,1x,2a,i8)') ' T-Td - max/min at ',time,ArchvTimeUnit,', time step=',its - call outqv ( dummy ,deg_lat,deg_lon,nip,nvl,1.) - - - -return -end subroutine op_diag -end module module_op_diag diff --git a/src/fim/FIMsrc/fim/horizontal/out2D.F90 b/src/fim/FIMsrc/fim/horizontal/out2D.F90 deleted file mode 100644 index 20489ec..0000000 --- a/src/fim/FIMsrc/fim/horizontal/out2D.F90 +++ /dev/null @@ -1,28 +0,0 @@ -module module_out2D -contains -subroutine out2D(its,VarName,var,lun2d,time) -use module_control,only: nvl,nvlp1,nip,dt,glvl,curve,yyyymmddhhmm - -integer ,intent(IN) :: its -character*(*),intent(IN) :: VarName -real ,intent(IN) :: var(size(var)) -integer ,intent(IN) :: lun2d -integer ,intent(IN) :: time - -write(header,100) VarName,yyyymmddhhmm,nvl,glvl,curve,its,time -write(lun2d) header -write(lun2d) var - -100 format('FIM ',A,' Forecast initial time YYYYMMDDHHMM: ',A12,/,& - 'Level ',I0,', GLVL= ',I0,', Memory Layout ',I0,', Step ',I0,', ',I0,' hours',/,& - '3',/,& - '4',/,& - '5',/,& - '6',/,& - '7',/,& - '8',/,& - '9',/,& - '10') -return -end subroutine out2D -end module module_out2D diff --git a/src/fim/FIMsrc/fim/horizontal/out4d_mn.F90 b/src/fim/FIMsrc/fim/horizontal/out4d_mn.F90 deleted file mode 100644 index 9cdef75..0000000 --- a/src/fim/FIMsrc/fim/horizontal/out4d_mn.F90 +++ /dev/null @@ -1,53 +0,0 @@ -module module_out4d_mn -contains -! -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . . -! SUBPROGRAM: OUTQV_MN PRINT MEAN VALUE FOR EACH LAYER FROM ICOS-ARRAY -! PRGMMR: JIN, ADAPTED FROM OUTQV ORIGINALLY BY S.BENJAMIN DATE: 07-06-20 -! -! ABSTRACT: PRINT MEAN LAYER VALUE OF 2-D ARRAY -! -! PROGRAM HISTORY LOG: -! 2007/06 J. Lee adapted codes from outqv.F90 -! -! USAGE: CALL OUTQV_MN(QVA,NVL,NIP,ITS) -! -! INPUT ARGUMENT LIST: -! QVA - REAL 2-D ICOSAHEDRAL TRACER ARRAY -! NVL - INTEGER NO. OF POINTS IN VERTICAL DIRECTION -! NIP - INTEGER NO. OF ICOS POINTS -! ITS - INTEGER NO. OF TIME STEP -! -! OUTPUT ARGUMENT LIST: none -! -! REMARKS: NONE -! - -SUBROUTINE OUT4D_MN(QVA,NVL,NIP,NTR,ITS,factor,n) -implicit none -INTEGER,intent(IN) :: NIP,NVL,NTR,n,ITS -!SMS$DISTRIBUTE (dh,nip) BEGIN -REAL ,intent(IN) :: QVA(Nvl,Nip,Ntr) -!SMS$DISTRIBUTE END -REAL*8 sum -REAL qvamn, factor -INTEGER IPN,IVL - -!SMS$PARALLEL (dh,ipn) BEGIN -DO IVL=1,NVL - sum=0.d0 - DO IPN=1,NIP - sum = sum + QVA(ivl,ipn,n) - ENDDO - qvamn=sum/float(nip) -!SMS$reduce(qvamn,SUM) -! -write (6,120)ITS,IVL,qvamn*factor -120 format ('ITS=',i6,' K=',i3,' MeanVal=',f12.4 ) -ENDDO - -!SMS$PARALLEL END -RETURN -end subroutine out4d_mn -end module module_out4d_mn diff --git a/src/fim/FIMsrc/fim/horizontal/outDiags.F90 b/src/fim/FIMsrc/fim/horizontal/outDiags.F90 deleted file mode 100644 index 430bad6..0000000 --- a/src/fim/FIMsrc/fim/horizontal/outDiags.F90 +++ /dev/null @@ -1,118 +0,0 @@ -module module_outDiags -contains -subroutine outDiags(its,nvl,nvlp1,nip,ntra,pr3d,ph3d,tr3d,rn2d,rc2d,sdot,dp3d,us3d,vs3d,rh3d,lw2d,sw2d,hf2d,qf2d) -use module_constants ,only: deg_lat,deg_lon -USE module_sfc_variables ,only : slmsk2d -use module_outqv ,only: outqv -use module_outqv_wsp ,only: outqv_wsp -use module_outqv_mn ,only: outqv_mn -use module_outqv_mn_lat ,only: outqv_mn_lat -use module_outqv_mn_lat_abs,only: outqv_mn_lat_abs -use module_outqv_mn_lat_land,only: outqv_mn_lat_land -use module_out4d_mn ,only: out4d_mn -use module_control ,only: dt,ArchvTimeUnit - -implicit none - -! External variable declarations: -integer,intent(IN) :: its,nvl,nvlp1,nip,ntra -!SMS$DISTRIBUTE (dh,nip) BEGIN -real ,intent(IN) :: us3d(nvl ,nip),vs3d(nvl,nip),dp3d(nvl,nip) -real ,intent(IN) :: pr3d(nvlp1,nip) -real ,intent(IN) :: ph3d(nvlp1,nip) -real ,intent(IN) :: tr3d(nvl ,nip,ntra) -real ,intent(IN) :: rh3d(nvl ,nip) -real ,intent(IN) :: sw2d(nip),lw2d(nip) -real ,intent(IN) :: rn2d(nip),rc2d(nip) -real ,intent(IN) :: sdot(nvlp1,nip) ! mass flux across interfaces, sdot*(dp/ds) -real ,intent(IN) :: hf2d(nip),qf2d(nip) -!SMS$DISTRIBUTE END - -!factors for changing units for outqv range, max/min -!water vapor - g/g to g/kg -real :: fact_qv = 1.e3 -real :: fact_qc = 1.e5 -!pressure - Pa to hPa -real :: fact_pres = 1.e-2 -real :: fact = 1. -real :: time - -integer :: LB -integer, external :: its2time - -time=its2time(its) -write (6,'(a,f9.2,1x,2a,i8)') ' Pressure at ',time,ArchvTimeUnit,', time step=',its -call outqv_mn (pr3d,nvlp1,nip,its,fact_pres) -write (6,'(a,f9.2,1x,2a,i8)') ' Geopotential height at ',time,ArchvTimeUnit,', time step=',its -call outqv_mn (ph3d,nvlp1,nip,its,1.) -call outqv (ph3d ,deg_lat,deg_lon,nip,nvlp1 ,fact) -write (6,'(a,f9.2,1x,2a,i8)') ' THETA at ',time,ArchvTimeUnit,', time step=',its -call out4d_mn (tr3d,nvl,nip,ntra,its,1.,1) -write (6,'(a,f9.2,1x,2a,i8)') ' Precip at ',time,ArchvTimeUnit,', time step=',its -call out4d_mn (rn2d,1,nip,1,its,1.,1) -write (6,'(a,f9.2,1x,2a,i8)') ' Precip at ',time,ArchvTimeUnit,', time step=',its -call outqv_mn_lat (rn2d,deg_lat,deg_lon,30.,1,nip,its,fact) -write (6,'(a,f9.2,1x,2a,i8)') ' Precip at ',time,ArchvTimeUnit,', time step=',its -call outqv (rn2d ,deg_lat,deg_lon,nip,1 ,fact) -write (6,'(a,f9.2,1x,2a,i8)') ' Precip-conv at ',time,ArchvTimeUnit,', time step=',its -call out4d_mn (rc2d,1,nip,1,its,1.,1) -call outqv_mn_lat (rc2d,deg_lat,deg_lon,30.,1,nip,its,fact) -write (6,'(a,f9.2,1x,2a,i8)') ' Precip-conv at ',time,ArchvTimeUnit,', time step=',its -call outqv (rc2d ,deg_lat,deg_lon,nip,1 ,fact) -write (6,'(a,f9.2,1x,2a,i8)') ' Vertical velocity at ',time,ArchvTimeUnit,', time step=',its -call out4d_mn (sdot,nvlp1,nip,1,its,1.,1) -write (6,'(a,f9.2,1x,2a,i8)') ' Vertical velocity at ',time,ArchvTimeUnit,', time step=',its -call outqv_mn_lat (sdot,deg_lat,deg_lon,30.,nvlp1,nip,its,fact) - -write (6,'(a,f9.2,1x,2a,i8)') ' Vertical velocity at ',time,ArchvTimeUnit,', time step=',its -call outqv ( sdot ,deg_lat,deg_lon,nip,nvlp1 ,fact) -write (6,'(a,f9.2,1x,2a,i8)') ' Abs Vertical velocity at ',time,ArchvTimeUnit,', time step=',its -call outqv_mn_lat_abs (sdot,deg_lat,deg_lon,30.,nvlp1,nip,its,fact) - -LB = LBOUND(tr3d,2) -write (6,'(a,f8.1,a,f9.2,1x,2a,i8)') ' Water vapor - tr(2), fact=',fact_qv,' at ',time,ArchvTimeUnit,', time step=',its -call outqv ( tr3d(1,LB,2) ,deg_lat,deg_lon,nip,nvl,fact_qv ) -write (6,'(a,f8.1,a,f9.2,1x,2a,i8)') ' Cloud water - tr(3), fact=',fact_qc,' at ',time,ArchvTimeUnit,', time step=',its -call outqv ( tr3d(1,LB,3) ,deg_lat,deg_lon,nip,nvl,fact_qc ) -write (6,'(a,f9.2,1x,2a,i8)') ' DP3d at ',time,ArchvTimeUnit,', time step=',its -call outqv ( dp3d ,deg_lat,deg_lon,nip,nvl ,fact_pres) -write (6,'(a,f9.2,1x,2a,i8)') ' pot temp at ',time,ArchvTimeUnit,', time step=',its -call outqv ( tr3d(1,LB,1) ,deg_lat,deg_lon,nip,nvl ,fact) -write (6,'(a,f9.2,1x,2a,i8)') ' Water vapor - tr(2) at ',time,ArchvTimeUnit,', time step=',its -call outqv_mn (tr3d(1,LB,2),nvl,nip,its,fact_qv) -write (6,'(a,f8.1,a,f9.2,1x,2a,i8)') ' Cloud water - tr(3), fact=',fact_qc,' at ',time,ArchvTimeUnit,', time step=',its -call outqv_mn (tr3d(1,LB,3),nvl,nip,its,fact_qc) -write (6,'(a,f8.1,a,f9.2,1x,2a,i8)') ' Cloud water - tr(3), fact=',fact_qc,' at ',time,ArchvTimeUnit,', time step=',its -call outqv_mn_lat (tr3d(1,LB,3),deg_lat,deg_lon,30.,nvl,nip,its,fact_qc) -write (6,'(a,f9.2,1x,2a,i8)') ' Pot temp at ',time,ArchvTimeUnit,', time step=',its -call outqv_mn (tr3d(1,LB,1),nvl,nip,its,fact) -write (6,'(a,f9.2,1x,2a,i8)') ' Zonal wind at ',time,ArchvTimeUnit,', time step=',its -call outqv_mn (us3d,nvl,nip,its,1.) -write (6,'(a,f9.2,1x,2a,i8)') ' Zonal wind at ',time,ArchvTimeUnit,', time step=',its -call outqv (us3d ,deg_lat,deg_lon,nip,nvl ,fact) -write (6,'(a,f9.2,1x,2a,i8)') ' Meridional wind at ',time,ArchvTimeUnit,', time step=',its -call outqv_mn (vs3d,nvl,nip,its,1.) -write (6,'(a,f9.2,1x,2a,i8)') ' Meridional wind at ',time,ArchvTimeUnit,', time step=',its -call outqv (vs3d ,deg_lat,deg_lon,nip,nvl ,fact) - -! Call for wind speed -write (6,'(a,f9.2,1x,2a,i8)') ' Wind speed at ',time,ArchvTimeUnit,', time step=',its -call outqv_wsp (us3d, vs3d ,deg_lat,deg_lon,nip,nvl ,fact) - -write (6,'(a,f9.2,1x,2a,i8)') ' Relative humidity at ',time,ArchvTimeUnit,', time step=',its -call outqv_mn (rh3d,nvl,nip,its,1.) -write (6,'(a,f9.2,1x,2a,i8)') ' Longwave at ',time,ArchvTimeUnit,', time step=',its -call outqv_mn (lw2d,1,nip,its,1.) -write (6,'(a,f9.2,1x,2a,i8)') ' Shortwave at ',time,ArchvTimeUnit,', time step=',its -call outqv_mn (sw2d,1,nip,its,1.) -write (6,'(a,f9.2,1x,2a,i8)') ' Sensible heat flux at ',time,ArchvTimeUnit,', time step=',its -call outqv_mn (hf2d,1,nip,its,1.) -call outqv (hf2d ,deg_lat,deg_lon,nip,1,1.) -call outqv_mn_lat_land (hf2d ,deg_lat,deg_lon,30.,slmsk2d,1,1,nip,its,1.) -write (6,'(a,f9.2,1x,2a,i8)') ' Latent heat flux at ',time,ArchvTimeUnit,', time step=',its -call outqv_mn (qf2d,1,nip,its,1.) -call outqv (qf2d ,deg_lat,deg_lon,nip,1,1.) -call outqv_mn_lat_land (qf2d ,deg_lat,deg_lon,30.,slmsk2d,1,1,nip,its,1.) - -end subroutine outDiags -end module module_outDiags diff --git a/src/fim/FIMsrc/fim/horizontal/outFMTed.F90 b/src/fim/FIMsrc/fim/horizontal/outFMTed.F90 deleted file mode 100644 index 5213519..0000000 --- a/src/fim/FIMsrc/fim/horizontal/outFMTed.F90 +++ /dev/null @@ -1,59 +0,0 @@ -module module_outFMTed -contains -subroutine outFMTed(its,pr3d,ph3d,us3d,vs3d,dp3d,mp3d,vor,tr,rh3d,tk3d,ws3d,st3d,sm3d,rn2d,pw2d,ts2d,us2d,hf2d,qf2d,sw2d,lw2d,time) -use module_control,only: nvl,nvlp1,nip,ntra,dt - -implicit none -! External variable declarations: -integer,intent(IN) :: its -!SMS$DISTRIBUTE (dh,nip) BEGIN -real ,intent(IN) :: us3d(nvl ,nip),vs3d(nvl,nip),dp3d(nvl,nip) -real ,intent(IN) :: pr3d(nvlp1,nip) -real ,intent(IN) :: mp3d(nvl ,nip) -real ,intent(IN) :: vor (nvl ,nip) -real ,intent(IN) :: ws3d(nvl ,nip) -real ,intent(IN) :: ph3d(nvlp1,nip) -real ,intent(IN) :: tr(nvl ,nip,ntra) -real ,intent(INOUT) :: rh3d(nvl ,nip) -real ,intent(INOUT) :: tk3d(nvl ,nip) -real ,intent(IN) :: rn2d(nip) -real ,intent(INOUT) :: pw2d(nip) -real ,intent(IN) :: ts2d(nip),us2d(nip),hf2d(nip),qf2d(nip),sw2d(nip),lw2d(nip),st3d(4,nip),sm3d(4,nip) -!SMS$DISTRIBUTE END -integer,intent(in) :: time -integer :: ivl,ipn,lunout=40 -character(80) :: filename - -write(filename,"('fim_out_',i6.6)") time -open (lunout,file=filename,form="formatted") -write(lunout,*) 'its =',its -!SMS$SERIAL ( : default=ignore) BEGIN -write(lunout,100) 'pr3d',((ivl,ipn,pr3d(ivl,ipn),ipn=1,nip),ivl=1,nvlp1) -write(lunout,100) 'ph3d',((ivl,ipn,ph3d(ivl,ipn),ipn=1,nip),ivl=1,nvlp1) -write(lunout,100) 'us3d',((ivl,ipn,us3d(ivl,ipn),ipn=1,nip),ivl=1,nvl) -write(lunout,100) 'vs3d',((ivl,ipn,vs3d(ivl,ipn),ipn=1,nip),ivl=1,nvl) -write(lunout,100) 'dp3d',((ivl,ipn,dp3d(ivl,ipn),ipn=1,nip),ivl=1,nvl) -write(lunout,100) 'mp3d',((ivl,ipn,mp3d(ivl,ipn),ipn=1,nip),ivl=1,nvl) -write(lunout,100) 'vor ',((ivl,ipn,vor (ivl,ipn),ipn=1,nip),ivl=1,nvl) -write(lunout,100) 'th3d',((ivl,ipn,tr(ivl,ipn,1),ipn=1,nip),ivl=1,nvl) -write(lunout,100) 'qv3d',((ivl,ipn,tr(ivl,ipn,2),ipn=1,nip),ivl=1,nvl) -write(lunout,100) 'qw3d',((ivl,ipn,tr(ivl,ipn,3),ipn=1,nip),ivl=1,nvl) -write(lunout,100) 'rh3d',((ivl,ipn,rh3d(ivl,ipn),ipn=1,nip),ivl=1,nvl) -write(lunout,100) 'tk3d',((ivl,ipn,rh3d(ivl,ipn),ipn=1,nip),ivl=1,nvl) -write(lunout,100) 'ws3d',((ivl,ipn,ws3d(ivl,ipn),ipn=1,nip),ivl=1,nvl) -write(lunout,100) 'st3d',((ivl,ipn,st3d(ivl,ipn),ipn=1,nip),ivl=1,4 ) -write(lunout,100) 'sm3d',((ivl,ipn,sm3d(ivl,ipn),ipn=1,nip),ivl=1,4 ) -write(lunout,101) 'rn2d',( ipn,rn2d( ipn),ipn=1,nip) -write(lunout,101) 'pw2d',( ipn,pw2d( ipn),ipn=1,nip) -write(lunout,101) 'ts2d',( ipn,ts2d( ipn),ipn=1,nip) -write(lunout,101) 'us2d',( ipn,us2d( ipn),ipn=1,nip) -write(lunout,101) 'hf2d',( ipn,hf2d( ipn) * 1.25 * 1004.0,ipn=1,nip) -write(lunout,101) 'qf2d',( ipn,qf2d( ipn) * 1.25 * 2.5e6 ,ipn=1,nip) -write(lunout,101) 'sw2d',( ipn,sw2d( ipn),ipn=1,nip) -write(lunout,101) 'lw2d',( ipn,lw2d( ipn),ipn=1,nip) -close(lunout) -!SMS$SERIAL END -100 format(' Variable ',a5/(2i10,1pe20.7)) -101 format(' Variable ',a5/( i20,1pe20.7)) -end subroutine outFMTed -end module module_outFMTed diff --git a/src/fim/FIMsrc/fim/horizontal/output.F90 b/src/fim/FIMsrc/fim/horizontal/output.F90 deleted file mode 100644 index e2f0a5f..0000000 --- a/src/fim/FIMsrc/fim/horizontal/output.F90 +++ /dev/null @@ -1,332 +0,0 @@ -module module_output - implicit none -!********************************************************************* -! output -! Output program for fim global model -! Alexander E. MacDonald 12/27/2004 -! J. Lee September, 2005 -!********************************************************************* - -contains - -subroutine output (its, nts, & ! index time step, final timestep - us3d, vs3d, dp3d, & ! west wind, south wind, delta pres - pr3d, ex3d, mp3d, & ! pressure, Exner, mont pot, - tr, rh3d, vor, ws3d, & ! tracers, specific and relative humidity, etc. - chem_opt,diaga, diagb, & ! diagnostic arrays - ph3d, tk3d, rn2d, rc2d, pw2d, & - ts2d, us2d, hf2d, qf2d, sw2d, & - lw2d, st3d, sm3d, t2m2d, q2m2d, & ! geopotential, accumulated precip/rainfall - canopy2d, fice2d, hice2d, & - sheleg2d, slmsk2d, & - u10m, v10m, flxlwtoa2d, & - rn2d0, rc2d0, rg2d0, flxswavg2d, flxlwavg2d, & ! accumulated things - toutputBa, TimingBarriers, curr_write_time) - use module_constants - use module_control, only: dt,filename_len,FixedGridOrder,nip,ntra,ntrb,& - nvar2d,nvarp,nvl,nvlp,nvlp1,ArchvStep,ArchvTimeUnit,PrintDiags, restart_freq,& - yyyymmddhhmm, hrs_in_month,EnKFIO, readrestart, itsstart - use module_core_setup, only: use_write_tasks - use module_op_diag, only: op_diag - use module_outFMTed, only: outFMTed - use module_outqv, only: outqv - use module_outqv_mn_lat, only: outqv_mn_lat - use module_outqv_mn_lat_land, only: outqv_mn_lat_land - use module_outvar_enkf, only: outvar_enkf - use module_printMAXMIN, only: printMAXMIN - use restart, only: write_restart -!SMS$IGNORE BEGIN - use icosio, only: icosio_out -!SMS$IGNORE END - use findmaxmin2 - use module_header, only: header - - implicit none - - ! External variable declarations: - integer, intent(in) :: its ! current time step - integer, intent(in) :: nts ! final time step - integer, intent(in) :: chem_opt ! for chem pressure level files we need to know chem_opt -!SMS$DISTRIBUTE (dh,nip) BEGIN - real ,intent(IN) :: us3d(nvl ,nip),vs3d(nvl,nip),dp3d(nvl,nip) - real ,intent(IN) :: pr3d(nvlp1,nip) - real ,intent(IN) :: mp3d(nvl ,nip) - real ,intent(IN) :: diaga(nvl ,nip),diagb(nvl,nip) - real ,intent(IN) :: vor (nvl ,nip) - real ,intent(IN) :: ws3d(nvl ,nip) - real ,intent(IN) :: ph3d(nvlp1,nip), ex3d(nvlp1,nip) - real ,intent(IN) :: tr(nvl ,nip,ntra+ntrb) - real ,intent(INOUT) :: rh3d(nvl ,nip) - real ,intent(INOUT) :: tk3d(nvl ,nip) - real ,intent(IN) :: rn2d(nip),rc2d(nip) - real ,intent(IN) :: u10m(nip),v10m(nip) -!JR Moved these 5 things to arg list so they can be written to the restart file. - real ,intent(inout) :: rn2d0(nip),rc2d0(nip),rg2d0(nip),flxswavg2d(nip),flxlwavg2d(nip) - real ,intent(INOUT) :: pw2d(nip) - real ,intent(IN) :: ts2d(nip),us2d(nip),hf2d(nip),qf2d(nip),sw2d(nip),& - lw2d(nip),st3d(4,nip),sm3d(4,nip) - real ,intent(IN) :: flxlwtoa2d(nip) - real ,intent(IN) :: t2m2d(nip),q2m2d(nip) -!JR Added items from module_sfc_variables so everything comes from input arg list -!JR rather than some used from module - real, intent(in) :: canopy2d(nip) - real, intent(in) :: fice2d(nip) - real, intent(in) :: hice2d(nip) - real, intent(in) :: sheleg2d(nip) - real, intent(in) :: slmsk2d(nip) - - real*8 ,intent(INOUT) :: toutputBa - logical,intent(IN) :: TimingBarriers - integer, intent(inout) :: curr_write_time ! most recent time vars. were written - - real :: th3d(nvl,nip), qv3d(nvl,nip), qw3d(nvl,nip), hfop(nip), qfop(nip) - real :: oz3d(nvl,nip) - real :: td3d(nvl,nip),mslp(nip),rg2d(nip) - real :: rn_xh(nip),rc_xh(nip),rg_xh(nip) - real :: g3p (nvlp,nip,nvarp) - ! (nvarp=5) - ! 1=height,2=temp,3=RH (w.r.t. water),4=u wind,5=v wind - real :: g2d (nip,nvar2d) - ! ! additional diagnostic 2d variables from op_diag.F90 - real :: spd10m_dif(nip) -!SMS$DISTRIBUTE END - - integer :: LB, time, ipn - integer :: accum_start ! value of "time" from previous output call - real*8 :: t0, t1=0.0d0, t2=0.0d0, t3=0.0d0 - character(len=filename_len), external :: filename - - integer, external :: its2time - - time = its2time(its) - - if (its == 0) then - flxswavg2d(:) = 0. - flxlwavg2d(:) = 0. - rn2d0(:) = 0.0 - rc2d0(:) = 0.0 - rg2d0(:) = 0.0 - end if - -! --- accumulate fields averaged over "ArchvIntvl" -!SMS$PARALLEL (dh,ipn) BEGIN - do ipn=1,nip - flxswavg2d(ipn) = flxswavg2d(ipn) + sw2d(ipn) - flxlwavg2d(ipn) = flxlwavg2d(ipn) + lw2d(ipn) - end do -!SMS$PARALLEL END - -!JR Write history info every so often (mod(its,archvstep) == 0) - if (mod(its,ArchvStep) == 0) then - accum_start = curr_write_time - curr_write_time = time - if (TimingBarriers) then - call StartTimer(t0) -!SMS$BARRIER - call IncrementTimer(t0,toutputBa) - endif - - call StartTimer(t0) - !there is an SMS problem writing tr(:,:,1) - - th3d(:,:) = tr(:,:,1) - qv3d(:,:) = tr(:,:,2) - qw3d(:,:) = tr(:,:,3) - oz3d(:,:) = tr(:,:,4) - rg2d(:) = rn2d(:) - rc2d(:) - hfop(:) = hf2d(:) * 1.25 * 1004.0 - qfop(:) = qf2d(:) * 1.25 * 2.5e6 - ! Calculate x-hour interval precip (difference from total precip at the last - ! output time) - rn_xh(:) = rn2d(:) - rn2d0(:) - rc_xh(:) = rc2d(:) - rc2d0(:) - rg_xh(:) = rg2d(:) - rg2d0(:) - rn2d0(:) = rn2d(:) - rc2d0(:) = rc2d(:) - rg2d0(:) = rg2d(:) - spd10m_dif(:) = sqrt(u10m(:)**2+v10m(:)**2) - sqrt(us3d(1,:)**2 + vs3d(1,:)**2) - flxswavg2d(:) = flxswavg2d(:) / ArchvStep - flxlwavg2d(:) = flxlwavg2d(:) / ArchvStep - - ! Calculate various 3-d and 2-d diagnostic variables for outputting below. - ! These are generally multivariate diagnostics, thus not do-able by the - ! scalar FIMpost, which can only do horizontal interpolation (icos to - ! lat/lon) one variable at a time. - call op_diag( & - its,nts, & ! index time step, final timestep - us3d,vs3d,dp3d, & ! west wind, south wind, delta pres - pr3d,ex3d,mp3d, & ! pressure, Exner, mont pot, - tr,vor,ws3d, & ! tracers, etc. - ph3d,rn2d,rc2d, & ! geopotential, accumulated precip/rainfall - ts2d,us2d,hf2d,qf2d,sw2d,lw2d,st3d,sm3d,& - ! Below are output variables from op_diag - tk3d,rh3d,td3d,pw2d,mslp,g3p,g2d,time& - ) - - write (6,*) ' U wind comp at k=1 - max/min' - call outqv(us3d ,deg_lat,deg_lon,nip,1,1.) - call outqv_mn_lat(us3d,deg_lat,deg_lon,50.,1,nip,its,1.) - write (6,*) ' U10M - max/min' - call outqv(u10m ,deg_lat,deg_lon,nip,1,1.) - call outqv_mn_lat(u10m,deg_lat,deg_lon,50.,1,nip,its,1.) - write (6,*) ' V wind comp at k=1 - max/min' - call outqv(vs3d ,deg_lat,deg_lon,nip,1,1.) - call outqv_mn_lat(vs3d,deg_lat,deg_lon,50.,1,nip,its,1.) - write (6,*) ' V10M - max/min' - call outqv(v10m ,deg_lat,deg_lon,nip,1,1.) - call outqv_mn_lat(v10m,deg_lat,deg_lon,50.,1,nip,its,1.) - write (6,*) ' spd_dif(wind-10M- wind(k=1)) - max/min' - call outqv(spd10m_dif ,deg_lat,deg_lon,nip,1,1.) - call outqv_mn_lat(spd10m_dif,deg_lat,deg_lon,50.,1,nip,its,1.) - - write (6,*) ' Snow water equivalent - max/min' - call outqv(sheleg2d ,deg_lat,deg_lon,nip,1,1.) - call outqv_mn_lat(sheleg2d,deg_lat,deg_lon,50.,1,nip,its,1.) - write (6,*) ' Canopy water - max/min' - call outqv(canopy2d ,deg_lat,deg_lon,nip,1,1.) - call outqv_mn_lat(canopy2d,deg_lat,deg_lon,30.,1,nip,its,1.) - write (6,*) ' Canopy water - mean - land only' - call outqv_mn_lat_land(canopy2d,deg_lat,deg_lon,30.,slmsk2d,1,1,nip,its,1.) - write (6,*) ' Rain - since last output - max/min' - call outqv(rn_xh,deg_lat,deg_lon,nip,1,1.) - write (6,*) ' Rain-conv - since last output - max/min' - call outqv(rc_xh,deg_lat,deg_lon,nip,1,1.) - write (6,*) ' Rain-grid-scale - since last output - max/min' - call outqv(rg_xh,deg_lat,deg_lon,nip,1,1.) - ! write (6,*)' Rain0- - max/min' - ! call outqv ( rn2d0 ,deg_lat,deg_lon,nip,1,1.) - ! write (6,*)' Rain0-conv - max/min' - ! call outqv ( rc2d0 ,deg_lat,deg_lon,nip,1,1.) - if (its == itsStart-1) then - write (6,*) ' Sea ice-hice - max/min' - call outqv(hice2d,deg_lat,deg_lon,nip,1,1.) - call outqv_mn_lat(hice2d,deg_lat,deg_lon,50.,1,nip,its,1.) - write (6,*) ' Sea ice-fice - max/min' - call outqv(fice2d,deg_lat,deg_lon,nip,1,1.) - call outqv_mn_lat(fice2d,deg_lat,deg_lon,50.,1,nip,its,1.) - end if - write (6,*) ' Outgoing longwave radiation - max/min' - call outqv(flxlwtoa2d,deg_lat,deg_lon,nip,1,1.) - - if (PrintDiags) then - call outFMTed (its,pr3d,ph3d,us3d,vs3d,dp3d,mp3d,vor,tr,rh3d,tk3d,ws3d,& - st3d,sm3d,rn2d,pw2d,ts2d,us2d,hf2d,qf2d,sw2d,lw2d,time) - else - if (EnKFIO .and. .not. use_write_tasks .and. .not. FixedGridOrder) then - ! write only fields needed for EnKF DA cycle to two files. - ! 3d dynamical and surface fields. Only supported if no write task, and FixedGridOrder - ! = .false. - call outvar_enkf(time,pr3d,ex3d,us3d,vs3d,tr,ph3d) - - else - -!JR Redo order for testing convenience to match specification in FIMnamelist ("wgrib" will give -!JR same order). Optional argument "scalefactor" is scaling factor to be applied when GRIB file -!JR is written. Optional argument "accum_start" specifies an accumulation start time different -!JR from default when GRIB file is written. - - LB = LBOUND(g3p,2) - call icosio_out (its, time, 'hgtP', g3p(1,LB,1), nvlp, filename('hgtP',its), header('hgtP',nvlp,its)) - call icosio_out (its, time, 'tmpP', g3p(1,LB,2), nvlp, filename('tmpP',its), header('tmpP',nvlp,its)) - call icosio_out (its, time, 'rp3P', g3p(1,LB,3), nvlp, filename('rp3P',its), header('rp3P',nvlp,its)) - call icosio_out (its, time, 'up3P', g3p(1,LB,4), nvlp, filename('up3P',its), header('up3P',nvlp,its)) - call icosio_out (its, time, 'vp3P', g3p(1,LB,5), nvlp, filename('vp3P',its), header('vp3P',nvlp,its)) - - LB=LBOUND(g2d,1) - call icosio_out (its, time, 'pr3D', pr3d, nvlp1, filename('pr3D',its), header('pr3D',nvlp1,its)) - call icosio_out (its, time, 'ph3D', ph3d, nvlp1, filename('ph3D',its), header('ph3D',nvlp1,its), scalefactor=1./9.8) - call icosio_out (its, time, 'tk3D', tk3d, nvl, filename('tk3D',its), header('tk3D',nvl,its)) - call icosio_out (its, time, 'td3D', td3d, nvl, filename('td3D',its), header('td3D',nvl,its)) - call icosio_out (its, time, 'ws3D', ws3d, nvl, filename('ws3D',its), header('ws3D',nvl,its)) - call icosio_out (its, time, 'rh3D', rh3d, nvl, filename('rh3D',its), header('rh3D',nvl,its)) - call icosio_out (its, time, 'us3D', us3d, nvl, filename('us3D',its), header('us3D',nvl,its)) - call icosio_out (its, time, 'vs3D', vs3d, nvl, filename('vs3D',its), header('vs3D',nvl,its)) - call icosio_out (its, time, 'rn2D', rn2d, 1, filename('2D__',its), header('rn2D',1,its), accum_start=accum_start) - call icosio_out (its, time, 'rc2D', rc2d, 1, filename('2D__',its), header('rc2D',1,its), accum_start=accum_start) - call icosio_out (its, time, 'r12D', rn_xh,1, filename('2D__',its), header('r12D',1,its)) - call icosio_out (its, time, 'r22D', rc_xh,1, filename('2D__',its), header('r22D',1,its)) - call icosio_out (its, time, 'rg2D', rg2d, 1, filename('2D__',its), header('rg2D',1,its), accum_start=accum_start) - call icosio_out (its, time, 'pw2D', pw2d, 1, filename('2D__',its), header('pw2D',1,its)) - call icosio_out (its, time, 'ts2D', ts2d, 1, filename('2D__',its), header('ts2D',1,its)) - call icosio_out (its, time, 'us2D', us2d, 1, filename('2D__',its), header('us2D',1,its)) - call icosio_out (its, time, 'hf2D', hfop, 1, filename('2D__',its), header('hf2D',1,its)) - call icosio_out (its, time, 'qf2D', qfop, 1, filename('2D__',its), header('qf2D',1,its)) - call icosio_out (its, time, 'sw2D', sw2d, 1, filename('2D__',its), header('sw2D',1,its)) - call icosio_out (its, time, 'lw2D', lw2d, 1, filename('2D__',its), header('lw2D',1,its)) - call icosio_out (its, time, 'ms2D', mslp, 1, filename('2D__',its), header('ms2D',1,its)) - call icosio_out (its, time, 'sn2D', sheleg2d, 1, filename('2D__',its), header('sn2D',1,its)) - call icosio_out (its, time, 'cb2D', g2d(LB,1), 1, filename('2D__',its), header('cb2D',1,its)) - call icosio_out (its, time, 'ct2D', g2d(LB,3), 1, filename('2D__',its), header('ct2D',1,its)) - call icosio_out (its, time, 'u12D', u10m, 1, filename('2D__',its), header('u12D',1,its)) - call icosio_out (its, time, 'v12D', v10m, 1, filename('2D__',its), header('v12D',1,its)) - call icosio_out (its, time, 'rp2D', g2d(LB,5), 1, filename('2D__',its), header('rp2D',1,its)) - - -!JR These aren't specified in default FIMnamelist - - call icosio_out (its, time, 'dp3D', dp3d, nvl, filename('dp3D',its), header('dp3D',nvl,its)) - call icosio_out (its, time, 'mp3D', mp3d, nvl, filename('mp3D',its), header('mp3D',nvl,its)) - call icosio_out (its, time, 'th3D', th3d, nvl, filename('th3D',its), header('th3D',nvl,its)) - call icosio_out (its, time, 'qv3D', qv3d, nvl, filename('qv3D',its), header('qv3D',nvl,its), scalefactor=1000.) - call icosio_out (its, time, 'qw3D', qw3d, nvl, filename('qw3D',its), header('qw3D',nvl,its), scalefactor=1000.) - call icosio_out (its, time, 'oz3D', oz3d, nvl, filename('oz3D',its), header('oz3D',nvl,its), scalefactor=1000.) - call icosio_out (its, time, 'vo3D', vor, nvl, filename('vo3D',its), header('vo3D',nvl,its)) - - call icosio_out (its, time, 'da3D', diaga, nvl, filename('da3D',its), header('da3D',nvl,its)) - call icosio_out (its, time, 'db3D', diagb, nvl, filename('db3D',its), header('db3D',nvl,its)) - call icosio_out (its, time, 'cn2D', canopy2d,1, filename('2D__',its), header('cn2D',1,its)) - call icosio_out (its, time, 'st3D', st3d, 4, filename('2D__',its), header('st3D',4,its)) - call icosio_out (its, time, 'sm3D', sm3d, 4, filename('2D__',its), header('sm3D',4,its)) - call icosio_out (its, time, 't22D', t2m2d, 1, filename('2D__',its), header('t22D',1,its)) - call icosio_out (its, time, 'q22D', q2m2d, 1, filename('2D__',its), header('q22D',1,its)) - call icosio_out (its, time, 'r32D', rg_xh, 1, filename('2D__',its), header('r32D',1,its)) - call icosio_out (its, time, 'sa2d', flxswavg2d, 1,filename('2D__',its), header('sa2d',1,its)) - call icosio_out (its, time, 'la2d', flxlwavg2d, 1,filename('2D__',its), header('la2d',1,its)) - call icosio_out (its, time, 'ol2d', flxlwtoa2d, 1,filename('2D__',its), header('ol2d',1,its)) - flxswavg2d(:) = 0. - flxlwavg2d(:) = 0. - - if(ntrb.gt.0 .and. chem_opt == 300)then - LB=LBOUND(g3p,2) - call icosio_out (its, time, 'so2P', g3p(1,LB,6), nvlp, filename('so2P',its), header('so2P',nvlp,its)) - call icosio_out (its, time, 'slfP', g3p(1,LB,7), nvlp, filename('slfP',its), header('slfP',nvlp,its)) - call icosio_out (its, time, 'dmsP', g3p(1,LB,8), nvlp, filename('dmsP',its), header('dmsP',nvlp,its)) - call icosio_out (its, time, 'msaP', g3p(1,LB,9), nvlp, filename('msaP',its), header('msaP',nvlp,its)) - call icosio_out (its, time, 'p25P', g3p(1,LB,10), nvlp, filename('p25P',its), header('p25P',nvlp,its)) - call icosio_out (its, time, 'bc1P', g3p(1,LB,11), nvlp, filename('bc1P',its), header('bc1P',nvlp,its)) - call icosio_out (its, time, 'bc2P', g3p(1,LB,12), nvlp, filename('bc2P',its), header('bc2P',nvlp,its)) - call icosio_out (its, time, 'oc1P', g3p(1,LB,13), nvlp, filename('oc1P',its), header('oc1P',nvlp,its)) - call icosio_out (its, time, 'oc2P', g3p(1,LB,14), nvlp, filename('oc2P',its), header('oc2P',nvlp,its)) - call icosio_out (its, time, 'd1sP', g3p(1,LB,15), nvlp, filename('d1sP',its), header('d1sP',nvlp,its)) - call icosio_out (its, time, 'd2sP', g3p(1,LB,16), nvlp, filename('d2sP',its), header('d2sP',nvlp,its)) - call icosio_out (its, time, 'd3sP', g3p(1,LB,17), nvlp, filename('d3sP',its), header('d3sP',nvlp,its)) - call icosio_out (its, time, 'd4sP', g3p(1,LB,18), nvlp, filename('d4sP',its), header('d4sP',nvlp,its)) - call icosio_out (its, time, 'd5sP', g3p(1,LB,19), nvlp, filename('d5sP',its), header('d5sP',nvlp,its)) - call icosio_out (its, time, 's1sP', g3p(1,LB,20), nvlp, filename('s1sP',its), header('s1sP',nvlp,its)) - call icosio_out (its, time, 's2sP', g3p(1,LB,21), nvlp, filename('s2sP',its), header('s2sP',nvlp,its)) - call icosio_out (its, time, 's3sP', g3p(1,LB,22), nvlp, filename('s3sP',its), header('s3sP',nvlp,its)) - call icosio_out (its, time, 's4sP', g3p(1,LB,23), nvlp, filename('s4sP',its), header('s4sP',nvlp,its)) - call icosio_out (its, time, 'p10P', g3p(1,LB,24), nvlp, filename('p10P',its), header('p10P',nvlp,its)) - endif - endif - endif - - call IncrementTimer(t0,t1) - call StartTimer(t0) - call printMAXMIN(its,nvl,nip,ntra+ntrb,tr,dp3d) - call IncrementTimer(t0,t2) - - if (TimingBarriers) then - call StartTimer(t0) -!SMS$BARRIER - call IncrementTimer(t0,toutputBa) - endif - endif - - if (its == itsStart+nts-1) then - print "(' OUTPUT time, maxmin time, restart time:',2F10.1)", t1, t2 - endif - - return -end subroutine output -end module module_output diff --git a/src/fim/FIMsrc/fim/horizontal/outqv.F90 b/src/fim/FIMsrc/fim/horizontal/outqv.F90 deleted file mode 100644 index 809adf2..0000000 --- a/src/fim/FIMsrc/fim/horizontal/outqv.F90 +++ /dev/null @@ -1,116 +0,0 @@ -module module_outqv -contains -! -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . . -! SUBPROGRAM: OUTQV PRINT MAX VALUE OF ARRAY -! PRGMMR: BENJAMIN, STAN ORG: ERL/PROFS DATE: 93-01-18 -! -! ABSTRACT: PRINT MAX VALUE AND IPN,IVL OF 2-D ARRAY -! -! PROGRAM HISTORY LOG: -! 88/05/31 S. BENJAMIN ORIGINAL VERSION -! 2006/02 J. Lee convert from F77 to F90 -! 2006/02 J. Middlecoff converted to icos notation and parallelized -! -! USAGE: CALL OUTQV(QVA,lat,lon,NIP,NVL) -! -! INPUT ARGUMENT LIST: -! QVA - REAL 2-D ARRAY -! lat - REAL 1-D array -! lon - REAL 1-D array -! NIP - INTEGER NO. OF ICOS POINTS -! NVL - INTEGER NO. OF POINTS IN VERTICAL DIRECTION -! -! OUTPUT ARGUMENT LIST: none -! -! REMARKS: NONE -! - -SUBROUTINE OUTQV(QVA,lat,lon,NIP,NVL,factor) -implicit none -INTEGER,intent(IN) :: NIP,NVL -!SMS$DISTRIBUTE (dh,nip) BEGIN -REAL ,intent(IN) :: QVA(Nvl,Nip) -real ,intent(IN) :: lat(nip),lon(nip) -!SMS$DISTRIBUTE END -REAL QVAMAX,qvamin,latIMAX,latIMIN,lonIMAX,lonIMIN,MyQvamax,MyQvamin -REAL factor -INTEGER imax,imin,IPN,IVL,mype,im,MyStartG,MyEndG -logical DiagPrint - - imin = 0 - imax = 0 -!SMS$PARALLEL (dh,ipn) BEGIN -print"(' IVL IPN LAT LON MAX VALUE IPN LAT LON MIN VALUE')" -DO IVL=1,NVL - QVAMAX=-1.E30 - QVAMin= 1.E30 - DO IPN=1,NIP - IF(QVA(ivl,IPN).GE.QVAMAX)THEN - QVAMAX=QVA(ivl,IPN) - IMAX=IPN - ENDIF - IF(QVA(IVL,ipn).LE.QVAMin)THEN - QVAMIN=QVA(ivl,IPN) - IMIN=IPN - ENDIF - ENDDO - MyQvamax = qvamax - MyQvamin = qvamin -!SMS$reduce(qvamax,max) -!SMS$reduce(qvamin,min) - if(MyQvamax == qvamax) then - im = imax - call GetIpnGlobalMype(im,imax,mype,DiagPrint) - else - imax = 0 - endif - if(MyQvamin == qvamin) then - im = imin - call GetIpnGlobalMype(im,imin,mype,DiagPrint) - else - imin = 0 - endif -!SMS$reduce(imax,imin,max) - ! exit if data is totally hosed - IF (imin == 0) THEN - PRINT *,'ERROR OUTQV: imin==0 at ivl = ',ivl - STOP - ENDIF - IF (imax == 0) THEN - PRINT *,'ERROR OUTQV: imax==0 at ivl = ',ivl - STOP - ENDIF - latIMAX = -9999. - lonIMAX = -9999. - latIMIN = -9999. - lonIMIN = -9999. - DO IPN=1,nip - MyStartG = ipn - exit - enddo - DO IPN=1,nip - MyEndG = ipn - enddo - if(imin >= MyStartG .and. imin <= MyEndG) then - latIMIN = lat(imin) - lonIMIN = lon(imin) - endif - if(imax >= MyStartG .and. imax <= MyEndG) then - latIMAX = lat(imax) - lonIMAX = lon(imax) - endif - if (lonIMAX .gt. 180.) lonimax = lonimax-360. - if (lonIMin .gt. 180.) lonimin = lonimin-360. -!SMS$reduce(latIMAX,lonIMAX,latIMIN,lonIMIN,max) - Qvamax = qvamax *factor - Qvamin = qvamin *factor - - print"(i6,i8,2f8.1,1pe12.3,i10,0p2f8.1,1pe12.3)",IVL,IMAX,latIMAX,lonIMAX,QVAMAX, & - IMIN,latIMIN,lonIMIN,QVAMIN -ENDDO -!SMS$PARALLEL END -RETURN -end subroutine outqv -end module module_outqv diff --git a/src/fim/FIMsrc/fim/horizontal/outqv_mn.F90 b/src/fim/FIMsrc/fim/horizontal/outqv_mn.F90 deleted file mode 100644 index f8e174d..0000000 --- a/src/fim/FIMsrc/fim/horizontal/outqv_mn.F90 +++ /dev/null @@ -1,53 +0,0 @@ -module module_outqv_mn -contains -! -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . . -! SUBPROGRAM: OUTQV_MN PRINT MEAN VALUE FOR EACH LAYER FROM ICOS-ARRAY -! PRGMMR: JIN, ADAPTED FROM OUTQV ORIGINALLY BY S.BENJAMIN DATE: 07-06-20 -! -! ABSTRACT: PRINT MEAN LAYER VALUE OF 2-D ARRAY -! -! PROGRAM HISTORY LOG: -! 2007/06 J. Lee adapted codes from outqv.F90 -! -! USAGE: CALL OUTQV_MN(QVA,NVL,NIP,ITS) -! -! INPUT ARGUMENT LIST: -! QVA - REAL 2-D ICOSAHEDRAL TRACER ARRAY -! NVL - INTEGER NO. OF POINTS IN VERTICAL DIRECTION -! NIP - INTEGER NO. OF ICOS POINTS -! ITS - INTEGER NO. OF TIME STEP -! -! OUTPUT ARGUMENT LIST: none -! -! REMARKS: NONE -! - -SUBROUTINE OUTQV_MN(QVA,NVL,NIP,ITS,factor) -implicit none -INTEGER,intent(IN) :: NIP,NVL,ITS -!SMS$DISTRIBUTE (dh,nip) BEGIN -REAL ,intent(IN) :: QVA(Nvl,Nip) -!SMS$DISTRIBUTE END -REAL*8 sum -REAL qvamn, factor -INTEGER IPN,IVL - -!SMS$PARALLEL (dh,ipn) BEGIN -DO IVL=1,NVL - sum=0.d0 - DO IPN=1,NIP - sum = sum + QVA(ivl,ipn) - ENDDO - qvamn=sum/float(nip) -!SMS$reduce(qvamn,SUM) -! -write (6,120)ITS,IVL,qvamn*factor -120 format ('ITS=',i6,' K=',i3,' MeanVal=',f12.4 ) -ENDDO - -!SMS$PARALLEL END -RETURN -end subroutine outqv_mn -end module module_outqv_mn diff --git a/src/fim/FIMsrc/fim/horizontal/outqv_mn_lat.F90 b/src/fim/FIMsrc/fim/horizontal/outqv_mn_lat.F90 deleted file mode 100644 index cee1f59..0000000 --- a/src/fim/FIMsrc/fim/horizontal/outqv_mn_lat.F90 +++ /dev/null @@ -1,72 +0,0 @@ -module module_outqv_mn_lat -contains -! -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . . -! SUBPROGRAM: OUTQV_MN PRINT MEAN VALUE FOR EACH LAYER FROM ICOS-ARRAY -! PRGMMR: JIN, ADAPTED FROM OUTQV ORIGINALLY BY S.BENJAMIN DATE: 07-06-20 -! -! ABSTRACT: PRINT MEAN LAYER VALUE OF 2-D ARRAY -! -! PROGRAM HISTORY LOG: -! 2007/06 J. Lee adapted codes from outqv.F90 -! -! USAGE: CALL OUTQV_MN(QVA,NVL,NIP,ITS) -! -! INPUT ARGUMENT LIST: -! QVA - REAL 2-D ICOSAHEDRAL TRACER ARRAY -! NVL - INTEGER NO. OF POINTS IN VERTICAL DIRECTION -! NIP - INTEGER NO. OF ICOS POINTS -! ITS - INTEGER NO. OF TIME STEP -! -! OUTPUT ARGUMENT LIST: none -! -! REMARKS: NONE -! - -SUBROUTINE OUTQV_MN_lat(QVA,lat,lon,xlim_lat,NVL,NIP,ITS,factor) -implicit none -INTEGER,intent(IN) :: NIP,NVL,ITS -!SMS$DISTRIBUTE (dh,nip) BEGIN -REAL ,intent(IN) :: QVA(Nvl,Nip) -real ,intent(IN) :: lat(nip),lon(nip) - -!SMS$DISTRIBUTE END -REAL*8 sum, sum1 -REAL qvamn, qvamn1, factor, xlim_lat -INTEGER IPN,IVL, isum, isum1 - -write (6,118)ITS,xlim_lat,factor -118 format ('ITS=',i6,' Latitude-limit=',f6.1, & - ' Scaling-factor=',G10.2 ) - -!SMS$PARALLEL (dh,ipn) BEGIN -DO IVL=1,NVL - sum=0.d0 - sum1=0.d0 - isum = 0 - isum1 = 0 - DO IPN=1,NIP - if (abs(lat(ipn)).gt.xlim_lat) then - sum = sum + QVA(ivl,ipn) - isum = isum + 1 - else - sum1 = sum1 + QVA(ivl,ipn) - isum1= isum1+ 1 - end if - ENDDO -!SMS$reduce(isum,isum1,sum,sum1,SUM) - qvamn=sum /float(isum) - qvamn1=sum1/float(isum1) -! -write (6,120)ITS,IVL,xlim_lat,isum & - ,qvamn*factor,isum1,qvamn1*factor -120 format ('ITS=',i6,' K=',i3, & - ' lat GT/LE ',f6.2, 2(' npts=',i8, & - ' MeanVal=',f12.4 ) ) -ENDDO - -!SMS$PARALLEL END -RETURN -end subroutine outqv_mn_lat -end module module_outqv_mn_lat diff --git a/src/fim/FIMsrc/fim/horizontal/outqv_mn_lat_abs.F90 b/src/fim/FIMsrc/fim/horizontal/outqv_mn_lat_abs.F90 deleted file mode 100644 index 41ecf07..0000000 --- a/src/fim/FIMsrc/fim/horizontal/outqv_mn_lat_abs.F90 +++ /dev/null @@ -1,73 +0,0 @@ -module module_outqv_mn_lat_abs -contains -! -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . . -! SUBPROGRAM: OUTQV_MN_lat_abs PRINT MEAN abs VALUE FOR EACH LAYER FROM ICOS-ARRAY -! for two latitude belts -! PRGMMR: JIN, ADAPTED FROM OUTQV ORIGINALLY BY S.BENJAMIN DATE: 07-06-20 -! -! ABSTRACT: PRINT MEAN LAYER VALUE OF 2-D ARRAY -! -! PROGRAM HISTORY LOG: -! 2007/06 J. Lee adapted codes from outqv.F90 -! -! USAGE: CALL OUTQV_MN(QVA,NVL,NIP,ITS) -! -! INPUT ARGUMENT LIST: -! QVA - REAL 2-D ICOSAHEDRAL TRACER ARRAY -! NVL - INTEGER NO. OF POINTS IN VERTICAL DIRECTION -! NIP - INTEGER NO. OF ICOS POINTS -! ITS - INTEGER NO. OF TIME STEP -! -! OUTPUT ARGUMENT LIST: none -! -! REMARKS: NONE -! - -SUBROUTINE OUTQV_MN_lat_abs (QVA,lat,lon,xlim_lat,NVL,NIP,ITS,factor) -implicit none -INTEGER,intent(IN) :: NIP,NVL,ITS -!SMS$DISTRIBUTE (dh,nip) BEGIN -REAL ,intent(IN) :: QVA(Nvl,Nip) -real ,intent(IN) :: lat(nip),lon(nip) - -!SMS$DISTRIBUTE END -REAL*8 sum, sum1 -REAL qvamn, qvamn1, factor, xlim_lat -INTEGER IPN,IVL, isum, isum1 - -write (6,118)ITS,xlim_lat,factor -118 format ('ITS=',i6,' Latitude-limit=',f6.1, & - ' Scaling-factor=',G10.2 ) - -!SMS$PARALLEL (dh,ipn) BEGIN -DO IVL=1,NVL - sum=0.d0 - sum1=0.d0 - isum = 0 - isum1 = 0 - DO IPN=1,NIP - if (abs(lat(ipn)).gt.xlim_lat) then - sum = sum + abs(QVA(ivl,ipn) ) - isum = isum + 1 - else - sum1 = sum1 + abs( QVA(ivl,ipn) ) - isum1= isum1+ 1 - end if - ENDDO -!SMS$reduce(isum,isum1,sum,sum1,SUM) - qvamn=sum /float(isum) - qvamn1=sum1/float(isum1) -! -write (6,120)ITS,IVL,xlim_lat,isum & - ,qvamn*factor,isum1,qvamn1*factor -120 format ('ITS=',i6,' K=',i3, & - ' lat GT/LE ',f6.2, 2(' npts=',i8, & - ' MeanVal=',f12.4 ) ) -ENDDO - -!SMS$PARALLEL END -RETURN -end subroutine outqv_mn_lat_abs -end module module_outqv_mn_lat_abs diff --git a/src/fim/FIMsrc/fim/horizontal/outqv_mn_lat_land.F90 b/src/fim/FIMsrc/fim/horizontal/outqv_mn_lat_land.F90 deleted file mode 100644 index 914cc28..0000000 --- a/src/fim/FIMsrc/fim/horizontal/outqv_mn_lat_land.F90 +++ /dev/null @@ -1,73 +0,0 @@ -module module_outqv_mn_lat_land -contains -! -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . . -! SUBPROGRAM: OUTQV_MN PRINT MEAN VALUE FOR EACH LAYER FROM ICOS-ARRAY -! PRGMMR: JIN, ADAPTED FROM OUTQV ORIGINALLY BY S.BENJAMIN DATE: 07-06-20 -! -! ABSTRACT: PRINT MEAN LAYER VALUE OF 2-D ARRAY -! -! PROGRAM HISTORY LOG: -! 2007/06 J. Lee adapted codes from outqv.F90 -! -! USAGE: CALL OUTQV_MN(QVA,NVL,NIP,ITS) -! -! INPUT ARGUMENT LIST: -! QVA - REAL 2-D ICOSAHEDRAL TRACER ARRAY -! NVL - INTEGER NO. OF POINTS IN VERTICAL DIRECTION -! NIP - INTEGER NO. OF ICOS POINTS -! ITS - INTEGER NO. OF TIME STEP -! -! OUTPUT ARGUMENT LIST: none -! -! REMARKS: NONE -! - -SUBROUTINE OUTQV_MN_lat_land(QVA,lat,lon,xlim_lat,slmsk2d,iland,NVL,NIP,ITS,factor) -implicit none -INTEGER,intent(IN) :: NIP,NVL,ITS -!SMS$DISTRIBUTE (dh,nip) BEGIN -REAL ,intent(IN) :: QVA(Nvl,Nip) -real ,intent(IN) :: lat(nip),lon(nip) -real ,intent(IN) :: slmsk2d(nip) - -!SMS$DISTRIBUTE END -REAL*8 sum, sum1 -REAL qvamn, qvamn1, factor, xlim_lat -INTEGER IPN,IVL, isum, isum1, iland - -write (6,118)ITS,xlim_lat,factor -118 format ('ITS=',i6,' Latitude-limit=',f6.1, & - ' Scaling-factor=',G10.2 ) - -!SMS$PARALLEL (dh,ipn) BEGIN -DO IVL=1,NVL - sum=0.d0 - sum1=0.d0 - isum = 0 - isum1 = 0 - DO IPN=1,NIP - if (abs(lat(ipn)).gt.xlim_lat.and.iland.eq.int(slmsk2d(ipn)+0.5)) then - sum = sum + QVA(ivl,ipn) - isum = isum + 1 - else if (abs(lat(ipn)).le.xlim_lat.and.iland.eq.int(slmsk2d(ipn)+0.5)) then - sum1 = sum1 + QVA(ivl,ipn) - isum1= isum1+ 1 - end if - ENDDO -!SMS$reduce(isum,isum1,sum,sum1,SUM) - qvamn=sum /float(isum) - qvamn1=sum1/float(isum1) -! -write (6,120)ITS,IVL,xlim_lat,isum & - ,qvamn*factor,isum1,qvamn1*factor -120 format ('ITS=',i6,' K=',i3, & - ' lat GT/LE ',f6.2, 2(' npts=',i8, & - ' MeanVal=',f12.4 ) ) -ENDDO - -!SMS$PARALLEL END -RETURN -end subroutine outqv_mn_lat_land -end module module_outqv_mn_lat_land diff --git a/src/fim/FIMsrc/fim/horizontal/outqv_wsp.F90 b/src/fim/FIMsrc/fim/horizontal/outqv_wsp.F90 deleted file mode 100644 index 9ba09be..0000000 --- a/src/fim/FIMsrc/fim/horizontal/outqv_wsp.F90 +++ /dev/null @@ -1,107 +0,0 @@ -module module_outqv_wsp -contains -! -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . . -! SUBPROGRAM: OUTQV_wsp PRINT MAX VALUE OF wind speed -! PRGMMR: BENJAMIN, STAN ORG: ERL/PROFS DATE: 93-01-18 -! -! ABSTRACT: PRINT MAX VALUE AND IPN,IVL OF 2-D ARRAY -! -! PROGRAM HISTORY LOG: -! 88/05/31 S. BENJAMIN ORIGINAL VERSION -! 2006/02 J. Lee convert from F77 to F90 -! 2006/02 J. Middlecoff converted to icos notation and parallelized -! -! USAGE: CALL OUTQV(QVA,lat,lon,NIP,NVL) -! -! INPUT ARGUMENT LIST: -! QVA - REAL 2-D ARRAY -! lat - REAL 1-D array -! lon - REAL 1-D array -! NIP - INTEGER NO. OF ICOS POINTS -! NVL - INTEGER NO. OF POINTS IN VERTICAL DIRECTION -! -! OUTPUT ARGUMENT LIST: none -! -! REMARKS: NONE -! - -SUBROUTINE OUTQV_wsp(u,v,lat,lon,NIP,NVL,factor) -implicit none -INTEGER,intent(IN) :: NIP,NVL -!SMS$DISTRIBUTE (dh,nip) BEGIN -REAL ,intent(IN) :: u(Nvl,Nip) -REAL ,intent(IN) :: v(Nvl,Nip) -real ,intent(IN) :: lat(nip),lon(nip) -!SMS$DISTRIBUTE END -REAL QVAMAX,qvamin,latIMAX,latIMIN,lonIMAX,lonIMIN,MyQvamax,MyQvamin -REAL factor, wsp -INTEGER imax,imin,IPN,IVL,mype,im,MyStartG,MyEndG -logical DiagPrint - -!SMS$PARALLEL (dh,ipn) BEGIN -print"(' IVL IPN LAT LON MAX VALUE IPN LAT LON MIN VALUE')" -DO IVL=1,NVL - QVAMAX=-1.E30 - QVAMin= 1.E30 - DO IPN=1,NIP - wsp = sqrt (u(ivl,ipn)**2 + v(ivl,ipn)**2) - IF(wsp.GE.QVAMAX)THEN - QVAMAX=wsp - IMAX=IPN - ENDIF - IF(wsp.LE.QVAMin)THEN - QVAMIN=wsp - IMIN=IPN - ENDIF - ENDDO - MyQvamax = qvamax - MyQvamin = qvamin -!SMS$reduce(qvamax,max) -!SMS$reduce(qvamin,min) - if(MyQvamax == qvamax) then - im = imax - call GetIpnGlobalMype(im,imax,mype,DiagPrint) - else - imax = 0 - endif - if(MyQvamin == qvamin) then - im = imin - call GetIpnGlobalMype(im,imin,mype,DiagPrint) - else - imin = 0 - endif -!SMS$reduce(imax,imin,max) - latIMAX = -9999. - lonIMAX = -9999. - latIMIN = -9999. - lonIMIN = -9999. - DO IPN=1,nip - MyStartG = ipn - exit - enddo - DO IPN=1,nip - MyEndG = ipn - enddo - if(imin >= MyStartG .and. imin <= MyEndG) then - latIMIN = lat(imin) - lonIMIN = lon(imin) - endif - if(imax >= MyStartG .and. imax <= MyEndG) then - latIMAX = lat(imax) - lonIMAX = lon(imax) - endif - if (lonIMAX .gt. 180.) lonimax = lonimax-360. - if (lonIMin .gt. 180.) lonimin = lonimin-360. -!SMS$reduce(latIMAX,lonIMAX,latIMIN,lonIMIN,max) - Qvamax = qvamax *factor - Qvamin = qvamin *factor - - print"(i6,i8,2f8.1,1pe12.3,i10,0p2f8.1,1pe12.3)",IVL,IMAX,latIMAX,lonIMAX,QVAMAX, & - IMIN,latIMIN,lonIMIN,QVAMIN -ENDDO -!SMS$PARALLEL END -RETURN -end subroutine outqv_wsp -end module module_outqv_wsp diff --git a/src/fim/FIMsrc/fim/horizontal/phy_finalize.F90 b/src/fim/FIMsrc/fim/horizontal/phy_finalize.F90 deleted file mode 100644 index 0801bca..0000000 --- a/src/fim/FIMsrc/fim/horizontal/phy_finalize.F90 +++ /dev/null @@ -1,19 +0,0 @@ -module module_fim_phy_finalize -contains -!********************************************************************* -subroutine phy_finalize -! Finish the physics component. -! T. Henderson April, 2008 -!********************************************************************* - - use module_outtime_phy,only: OutTime - use module_control ,only: PrintMAXMINtimes - - implicit none - - ! print elapsed times for physics parts of FIM - call OutTime(PrintMAXMINtimes) - - return -end subroutine phy_finalize -end module module_fim_phy_finalize diff --git a/src/fim/FIMsrc/fim/horizontal/phy_init.F90 b/src/fim/FIMsrc/fim/horizontal/phy_init.F90 deleted file mode 100644 index 6995dd5..0000000 --- a/src/fim/FIMsrc/fim/horizontal/phy_init.F90 +++ /dev/null @@ -1,692 +0,0 @@ -module module_fim_phy_init - -private -public :: phy_init, sst_init, sstunit - -integer, save :: sstunit = -1 - -contains - -subroutine phy_init -!********************************************************************* -! Loads the initial variables and constants for the physics -! component. -! Alexander E. MacDonald 11/27/04 -! J. Lee September, 2005 -!********************************************************************* - -use module_control ,only: nvl,nip,dt,numphr, & - readrestart,alt_topo, & - glvl,curve,NumCacheBlocksPerPE, & - PhysicsInterval,RadiationInterval, & - CallPhysics,CallRadiation,GravityWaveDrag, & - ras,num_p3d,gfsltln_file,mtnvar_file,aerosol_file,& - co2_2008_file,co2_glb_file,SSTInterval,UpdateSST -use funcphys ! GFS physics -use module_sfc_variables -!SMS$IGNORE BEGIN -USE gfs_physics_internal_state_mod, only: gfs_physics_internal_state, gis_phy -USE gfs_physics_sfc_flx_set_mod, only: sfcvar_aldata, flxvar_aldata, flx_init -use units, only: getunit, returnunit -!SMS$IGNORE END - -implicit none - -! Local variables - -integer :: mype,idx,ipn,ierr,mylb,myub -integer :: unitno -real*8 :: t0,t1=0.0d0 -logical :: first_loop -!real :: cv2d(nip),cvt2d(nip),cvb2d(nip),slmsk2d(nip),ts2d(nip) -!real :: st3d(4,nip),sheleg2d(nip),snoalb2d(nip) -!real :: hprm2d(14,nip),fice2d(nip),tprcp2d(nip) -!real :: slc3d(4,nip),sm3d(4,nip),snwdph2d(nip),slope2d(nip),shdmin2d(nip) -!real :: shdmax2d(nip),tg32d(nip),canopy2d(nip) -!real :: alvsf2d(nip),alnsf2d(nip),alvwf2d(nip),alnwf2d(nip) -!real :: facsf2d(nip),facwf2d(nip),t2m2d(nip),q2m2d(nip),uustar2d(nip) -!real :: work2d(nip),slc2d(nip) -!real :: ffmm2d(nip),ffhh2d(nip),f10m2d(nip) -!SMS$DISTRIBUTE (dh,nip) BEGIN -real :: work2d(nip) -!SMS$DISTRIBUTE END - -namelist /PREPnamelist/ curve,NumCacheBlocksPerPE,alt_topo,gfsltln_file,mtnvar_file & - ,aerosol_file,co2_2008_file,co2_glb_file - -namelist /PHYSICSnamelist/ PhysicsInterval,RadiationInterval,SSTInterval,GravityWaveDrag,ras,num_p3d - -! TODO: Create new decomp "dhp" and use it for all physics declarations -! TODO: and loops. Split modules that contain variables used by both too! -!!SMS$CREATE_DECOMP(dh,,) - -!!allocate( hice2d(nip) ) -!!allocate( srflag2d(nip) ) -!!allocate( zorl2d(nip) ) -!!allocate( vfrac2d(nip) ) -!!allocate( vtype2d(nip) ) -!!allocate( stype2d(nip) ) - -!SMS$insert call nnt_me(mype) -call StartTimer(t0) - -! TBH: BEGIN DUPLICATION with dyn_init(). REFACTOR TO REMOVE DUPLICATION -!TODO: call control() here before reading PHYSICSnamelist... -! Note: REWIND required by IBM! -! TODO: Using open-read-close in place of REWIND until SMS is updated -unitno = getunit () -if (unitno < 0) then - print*,'phy_init: getunit failed: stopping' - stop -end if - -open (unitno, file='./FIMnamelist', form='formatted', action='read', err=70) -read (unitno, PREPnamelist, err=90) -close (unitno) -open (unitno, file='./FIMnamelist', form='formatted', action='read', err=70) -read (unitno, PHYSICSnamelist, err=90) -close (unitno) - -call returnunit (unitno) -! TBH: END DUPLICATION with dyn_init(). - -call IncrementTimer(t0,t1) - -CallPhysics = max(1,numphr*PhysicsInterval/3600) -CallRadiation = max(1,(max(1,numphr*RadiationInterval/3600)/CallPhysics) & - *CallPhysics) -print "(' Calculate gravity wave drag ',L10)",GravityWaveDrag -print "(' Call physics every' ,I27,' timesteps (',I0,' seconds)')", & - CallPhysics,nint(CallPhysics*dt) -print "(' Call radiation every',I25,' timesteps (',I0,' seconds)')", & - CallRadiation,nint(CallRadiation*dt) -print "(' ras =',L10)",ras -print "(' num_p3d =',I10)",num_p3d - -write(6,PHYSICSnamelist) - -! On a restart run, these variables will be read in from the restart file so this part can be skipped. - -if (.not.readrestart) then -!SMS$PARALLEL(dh, ipn) BEGIN - call StartTimer(t0) -!SMS$SERIAL BEGIN - unitno = getunit () - if (unitno < 0) then - print*,'phy_init: getunit failed: stopping' - stop - end if - - open (unitno, file="gfsfc.dat", form="unformatted", action='read', err=70) - call TestGlvlHeader (unitno, "gfsfc.dat",'phy_init',glvl ) - call TestCurveHeader(unitno, "gfsfc.dat",'phy_init',curve) -!SMS$SERIAL END - do idx = 1,SIZE(st3d,1) -!SMS$SERIAL BEGIN - read(unitno, err=90) work2d -!SMS$SERIAL END - do ipn=1,nip - st3d(idx,ipn) = work2d(ipn) - enddo - enddo -! soil moisture - do idx = 1,SIZE(sm3d,1) -!SMS$SERIAL BEGIN - read(unitno, err=90) work2d -!SMS$SERIAL END - do ipn=1,nip - sm3d(idx,ipn) = work2d(ipn) - enddo - enddo - do idx = 1,SIZE(slc3d,1) -!SMS$SERIAL BEGIN - read(unitno, err=90) work2d -!SMS$SERIAL END - do ipn=1,nip - slc3d(idx,ipn) = work2d(ipn) - enddo - enddo -! -! skin temperature -! -!SMS$SERIAL BEGIN - read(unitno, err=90) ts2d -!SMS$SERIAL END -! -! snow water equivalent -! -!SMS$SERIAL BEGIN - read(unitno, err=90) sheleg2d -!SMS$SERIAL END -!SMS$SERIAL BEGIN - read(unitno, err=90) tg32d -!SMS$SERIAL END -! -! surface roughness -! -!SMS$SERIAL BEGIN - read(unitno, err=90) zorl2d -!SMS$SERIAL END -! -! maybe conv cloud fraction? -! -!SMS$SERIAL BEGIN - read(unitno, err=90) cv2d -!SMS$SERIAL END -! -! maybe conv cloud bottom pressure? -! -!SMS$SERIAL BEGIN - read(unitno, err=90) cvb2d -!SMS$SERIAL END -! -! maybe conv cloud top pressure? -! -!SMS$SERIAL BEGIN - read(unitno, err=90) cvt2d -!SMS$SERIAL END -! -! mean visible albedo with strong cosz dependence...???... -! -!SMS$SERIAL BEGIN - read(unitno, err=90) alvsf2d -!SMS$SERIAL END -! -! mean vis albedo with weak cosz dependence...???... -! -!SMS$SERIAL BEGIN - read(unitno, err=90) alvwf2d -!SMS$SERIAL END -! -! mean nir albedo with strong cosz dependence...???... -! -!SMS$SERIAL BEGIN - read(unitno, err=90) alnsf2d -!SMS$SERIAL END -! -! mean nir albedo with weak cosz dependence...???... -! -!SMS$SERIAL BEGIN - read(unitno, err=90) alnwf2d -!SMS$SERIAL END -! -! land/sea/ice mask (0:SEA.1:LAND,2:ICE) -!SMS$SERIAL BEGIN - read(unitno, err=90) slmsk2d -!SMS$SERIAL END -! -! assuming veg fraction -! -!SMS$SERIAL BEGIN - read(unitno, err=90) vfrac2d -!SMS$SERIAL END -! -! canopy moisture content in mm -! -!SMS$SERIAL BEGIN - read(unitno, err=90) canopy2d -!SMS$SERIAL END -!SMS$SERIAL BEGIN - read(unitno, err=90) f10m2d -!SMS$SERIAL END -!SMS$SERIAL BEGIN - read(unitno, err=90) t2m2d -!SMS$SERIAL END -!SMS$SERIAL BEGIN - read(unitno, err=90) q2m2d -!SMS$SERIAL END -! -! vegtype or landuse? -! -!SMS$SERIAL BEGIN - read(unitno, err=90) vtype2d -!SMS$SERIAL END -! -! soilcategory -! -!SMS$SERIAL BEGIN - read(unitno, err=90) stype2d -!SMS$SERIAL END -! -! fractional coverage with strong (facsf) and weak (facwf) cosz dependence -! -!SMS$SERIAL BEGIN - read(unitno, err=90) facsf2d -!SMS$SERIAL END -!SMS$SERIAL BEGIN - read(unitno, err=90) facwf2d -!SMS$SERIAL END -! -! ustar -! -!SMS$SERIAL BEGIN - read(unitno, err=90) uustar2d -!SMS$SERIAL END -! -! looks like surface exchange coeffs for m and h -!SMS$SERIAL BEGIN - read(unitno, err=90) ffmm2d -!SMS$SERIAL END -!SMS$SERIAL BEGIN - read(unitno, err=90) ffhh2d -!SMS$SERIAL END -! -! ice fractions! fice is also used as something different (cloud ice fraction!!) -! -!SMS$SERIAL BEGIN - read(unitno, err=90) hice2d -!SMS$SERIAL END -!SMS$SERIAL BEGIN - read(unitno, err=90) fice2d -!SMS$SERIAL END -!SMS$SERIAL BEGIN - read(unitno, err=90) tprcp2d -!SMS$SERIAL END -!SMS$SERIAL BEGIN - read(unitno, err=90) srflag2d -!SMS$SERIAL END -!SMS$SERIAL BEGIN - read(unitno, err=90) snwdph2d -!SMS$SERIAL END -!SMS$SERIAL BEGIN - read(unitno, err=90) slc2d -!SMS$SERIAL END -!SMS$SERIAL BEGIN - read(unitno, err=90) shdmin2d -!SMS$SERIAL END -!SMS$SERIAL BEGIN - read(unitno, err=90) shdmax2d -!SMS$SERIAL END -!SMS$SERIAL BEGIN - read(unitno, err=90) slope2d -!SMS$SERIAL END -!SMS$SERIAL BEGIN - read(unitno, err=90) snoalb2d -!SMS$SERIAL END -! -! this thing contains such things as origraphuc stand deviation, convexity, asymetry,...for grav wave drag calc -! - do idx = 1,SIZE(hprm2d,1) -!SMS$SERIAL BEGIN - read(unitno, err=90) work2d -!SMS$SERIAL END - do ipn=1,nip - hprm2d(idx,ipn) = work2d(ipn) - enddo - enddo -!SMS$SERIAL BEGIN - close(unitno) - call returnunit (unitno) -!SMS$SERIAL END - call IncrementTimer(t0,t1) -!SMS$PARALLEL END - print"(' PHYSICS INPUT time:',F10.0)",t1 -end if ! .not. readrestart - -call gfuncphys () ! GFS physics - -!TODO: encapsulate this in a new subroutine -! Allocate GFS internal state -! (only on first call, after digital filter it is -! already allocated) -if (.not. associated(gis_phy)) then -allocate( gis_phy ) -! set memory bounds from SMS distribution (decomposition) -mylb = LBOUND(work2d,1) -myub = UBOUND(work2d,1) -gis_phy%ims = mylb -gis_phy%ime = myub -! set patch (distributed-memory loop) bounds from SMS distribution -!SMS$PARALLEL(dh, ipn) BEGIN -first_loop = .true. -do ipn=1,nip - if (first_loop) then - gis_phy%ips = ipn - first_loop = .false. - endif - gis_phy%ipe = ipn -enddo -!SMS$PARALLEL END -gis_phy%lsoil = 4 -!TODO: fill this in... -! This will declare surface and flux arrays as (mylb:myub,1), etc. -! Note: GFS ignores ierr... -call sfcvar_aldata(mylb, myub, 1, gis_phy%lsoil, gis_phy%sfc_fld, ierr) -call flxvar_aldata(mylb, myub, 1, gis_phy%flx_fld, ierr) -gis_phy%NBLCK = 1 -gis_phy%LEVS = nvl -gis_phy%num_p2d = 3 -gis_phy%num_p3d = num_p3d -gis_phy%ras = ras -gis_phy%NMTVR = 14 -gis_phy%lats_node_r = 1 -!TODO: move nfxr to module resol_def -gis_phy%nfxr = 14 -allocate( gis_phy%SLAG(mylb:myub,gis_phy%LATS_NODE_R), & - gis_phy%SDEC(mylb:myub,gis_phy%LATS_NODE_R), & - gis_phy%CDEC(mylb:myub,gis_phy%LATS_NODE_R), & - gis_phy%SWH(mylb:myub,gis_phy%LEVS,gis_phy%NBLCK, & - gis_phy%LATS_NODE_R), & - gis_phy%HLW(mylb:myub,gis_phy%LEVS,gis_phy%NBLCK, & - gis_phy%LATS_NODE_R), & - gis_phy%SFALB(mylb:myub,gis_phy%LATS_NODE_R), & - gis_phy%ACV(mylb:myub,gis_phy%LATS_NODE_R), & - gis_phy%ACVT(mylb:myub,gis_phy%LATS_NODE_R), & - gis_phy%ACVB(mylb:myub,gis_phy%LATS_NODE_R), & - gis_phy%phy_f2d(mylb:myub,gis_phy%LATS_NODE_R, & - gis_phy%num_p2d), & - gis_phy%XLON(mylb:myub,gis_phy%LATS_NODE_R), & - gis_phy%XLAT(mylb:myub,gis_phy%LATS_NODE_R), & - gis_phy%HPRIME(gis_phy%NMTVR,mylb:myub,gis_phy%LATS_NODE_R), & - gis_phy%phy_f3d(mylb:myub,gis_phy%LEVS,gis_phy%NBLCK, & - gis_phy%LATS_NODE_R,gis_phy%num_p3d), & - gis_phy%COSZDG(mylb:myub,gis_phy%LATS_NODE_R), & - gis_phy%CLDCOV(gis_phy%LEVS,mylb:myub,gis_phy%LATS_NODE_R), & - gis_phy%FLUXR(gis_phy%nfxr,mylb:myub,gis_phy%LATS_NODE_R) ) - -allocate( gis_phy%ps(mylb:myub), & - gis_phy%dp(mylb:myub,gis_phy%LEVS), & - gis_phy%dpdt(mylb:myub,gis_phy%LEVS),& - gis_phy%p(mylb:myub,gis_phy%LEVS), & - gis_phy%u(mylb:myub,gis_phy%LEVS), & - gis_phy%v(mylb:myub,gis_phy%LEVS), & - gis_phy%t(mylb:myub,gis_phy%LEVS), & - gis_phy%q(mylb:myub,gis_phy%LEVS), & - gis_phy%oz(mylb:myub,gis_phy%LEVS), & - gis_phy%cld(mylb:myub,gis_phy%LEVS) ) - -endif -!TODO: Connect this properly, at present values set here are overwritten -!TODO: in physics(). -call flx_init(gis_phy%flx_fld, ierr) - -!SMS$PARALLEL(dh, ipn) BEGIN - do ipn=1,nip - gis_phy%sfc_fld%CV (ipn,1) = cv2d (ipn) - gis_phy%sfc_fld%CVT (ipn,1) = cvt2d (ipn) - gis_phy%sfc_fld%CVB (ipn,1) = cvb2d (ipn) - gis_phy%sfc_fld%SLMSK (ipn,1) = slmsk2d (ipn) - gis_phy%flx_fld%SFCDSW(ipn,1) = 0.0 - gis_phy%flx_fld%SFCDLW(ipn,1) = 0.0 - gis_phy%sfc_fld%TSEA (ipn,1) = ts2d (ipn) - gis_phy%sfc_fld%STC (:,ipn,1) = st3d (:,ipn) - gis_phy%sfc_fld%SHELEG(ipn,1) = sheleg2d(ipn) - gis_phy%sfc_fld%ZORL (ipn,1) = zorl2d (ipn) - gis_phy%sfc_fld%snoalb(ipn,1) = snoalb2d(ipn) - gis_phy%HPRIME (:,ipn,1) = hprm2d(:,ipn) - gis_phy%sfc_fld%HICE (ipn,1) = hice2d (ipn) - gis_phy%sfc_fld%FICE (ipn,1) = fice2d (ipn) - gis_phy%sfc_fld%TPRCP (ipn,1) = tprcp2d (ipn) - gis_phy%sfc_fld%SRFLAG(ipn,1) = srflag2d(ipn) - gis_phy%sfc_fld%SLC (:,ipn,1) = slc3d (:,ipn) - gis_phy%sfc_fld%SMC (:,ipn,1) = sm3d (:,ipn) - gis_phy%sfc_fld%SNWDPH(ipn,1) = snwdph2d(ipn) - gis_phy%sfc_fld%SLOPE (ipn,1) = slope2d (ipn) - gis_phy%sfc_fld%SHDMIN(ipn,1) = shdmin2d(ipn) - gis_phy%sfc_fld%SHDMAX(ipn,1) = shdmax2d(ipn) - gis_phy%sfc_fld%TG3 (ipn,1) = tg32d (ipn) - gis_phy%sfc_fld%VFRAC (ipn,1) = vfrac2d (ipn) - gis_phy%sfc_fld%CANOPY(ipn,1) = canopy2d(ipn) - gis_phy%sfc_fld%VTYPE (ipn,1) = vtype2d (ipn) - gis_phy%sfc_fld%STYPE (ipn,1) = stype2d (ipn) - gis_phy%sfc_fld%F10M (ipn,1) = f10m2d (ipn) - gis_phy%sfc_fld%FFMM (ipn,1) = ffmm2d (ipn) - gis_phy%sfc_fld%FFHH (ipn,1) = ffhh2d (ipn) - gis_phy%sfc_fld%ALVSF (ipn,1) = alvsf2d (ipn) - gis_phy%sfc_fld%ALNSF (ipn,1) = alnsf2d (ipn) - gis_phy%sfc_fld%ALVWF (ipn,1) = alvwf2d (ipn) - gis_phy%sfc_fld%ALNWF (ipn,1) = alnwf2d (ipn) - gis_phy%sfc_fld%FACSF (ipn,1) = facsf2d (ipn) - gis_phy%sfc_fld%FACWF (ipn,1) = facwf2d (ipn) - ! Note that T2M and Q2M are overwritten before use in do_physics_one_step() - gis_phy%sfc_fld%T2M (ipn,1) = t2m2d (ipn) - gis_phy%sfc_fld%Q2M (ipn,1) = q2m2d (ipn) - gis_phy%phy_f3d(ipn,:,1,1,:) = 0.0 - gis_phy%phy_f2d(ipn,1,:) = 0.0 - gis_phy%CLDCOV(:,ipn,1) = 0.0 - gis_phy%flx_fld%HFLX(ipn,1) = 0.0 - gis_phy%flx_fld%EVAP(ipn,1) = 0.0 - ! Note that UUSTAR is overwritten before use here. uustar2d is not used. - gis_phy%sfc_fld%UUSTAR(ipn,1) = 0.01 - enddo -!SMS$PARALLEL END - if ( UpdateSST) then - call sst_init - endif -print *,'... exiting phy_init' - -return -70 write(6,*)'phy_init: error opening a file' - stop -90 write(6,*)'phy_init: error reading a file' - stop -end subroutine phy_init - -subroutine sst_init -!********************************************************************* -! Loads the initial variables and constants for the ocean -! component. -! Alexander E. MacDonald 11/27/04 -! J. Lee September, 2005 -!********************************************************************* - -use module_control ,only: nip,dt,numphr, & - glvl,curve,NumCacheBlocksPerPE,CallSST,PhysicsInterval, & - RadiationInterval,GravityWaveDrag,SSTInterval -use units, only: getunit, returnunit - -implicit none - -! Local variables - -integer :: mype,idx,ierr,mylb,myub -real*8 :: t0,t1=0.0d0 - -!namelist /PHYSICSnamelist/ PhysicsInterval,RadiationInterval,GravityWaveDrag,ras,num_p3d,SSTInterval - -! TODO: Create new decomp "dhp" and use it for all physics declarations -! TODO: and loops. Split modules that contain variables used by both too! - -!SMS$insert call nnt_me(mype) -call StartTimer(t0) - -! TBH: BEGIN DUPLICATION with dyn_init(). REFACTOR TO REMOVE DUPLICATION -!open (11,file='./FIMnamelist') -!read (11,PHYSICSnamelist) -!close(11) - - -! TODO: Create new decomp "dhp" and use it for all physics declarations -! TODO: and loops. Split modules that contain variables used by both too! - -!SMS$insert call nnt_me(mype) -call StartTimer(t0) -call IncrementTimer(t0,t1) - -CallSST = max(1,numphr*SSTInterval/3600) -print "(' Call SST every' ,I27,' timesteps (',I0,' seconds)')", & - CallSST,nint(CallSST*dt) -call InitSST -return -end subroutine sst_init - -subroutine InitSST - -use module_control ,only: nip, yyyymmddhhmm,prev_date,next_date,glvl,curve,nvl,ptop -use module_constants, only : lat,lon -use module_sfc_variables, only : ts2d,sst_prev,sst_next,fice2d,fice2d_prev,fice2d_next,slmsk2d,hice2d -use gfs_physics_internal_state_mod, only: gfs_physics_internal_state, gis_phy -use units, only: getunit, returnunit -!SMS$ignore begin - USE slint, ONLY: bilinear_init, bl_int -!SMS$ignore end - -implicit none - -! locals - real , allocatable :: sst_prev_ll(:,:) - real , allocatable :: fice2d_prev_ll(:,:) - real , allocatable :: sst_next_ll(:,:) - real , allocatable :: fice2d_next_ll(:,:) - integer :: YEAR,MONTH,DAY - integer :: IM_OC - integer :: JM_OC,ipn - - integer :: MIDMON - integer :: ID - integer :: M1 - integer :: M2 - integer :: MIDM - integer :: MIDP - integer :: N - integer :: I - integer :: NRECS - - integer :: THIS_YEAR,MDATE - integer :: THIS_MONTH - integer :: time_header(4),SDATE1,SDATE2,DAYS(12) - real :: REAL_VAR - real :: DX - real :: DY,FAC - data DAYS /31,28,31,30,31,30,31,31,30,31,30,31/ - logical :: skip - integer :: unitno -! BEGIN - READ(UNIT=yyyymmddhhmm(1:4), FMT='(I4)') YEAR - READ(UNIT=yyyymmddhhmm(5:6), FMT='(I2)') MONTH - READ(UNIT=yyyymmddhhmm(7:8), FMT='(I2)') DAY - -IF ( mod(YEAR,4).EQ.0) THEN - DAYS(2)=29.0 -ENDIF -IF ( YEAR.EQ.1900) THEN - DAYS(2)=28.0 -ENDIF -!SMS$SERIAL ( : default=ignore) BEGIN - IM_OC=360.0 - JM_OC=180.0 - allocate(sst_prev_ll(IM_OC,JM_OC)) - allocate(fice2d_prev_ll(IM_OC,JM_OC)) - allocate(sst_next_ll(IM_OC,JM_OC)) - allocate(fice2d_next_ll(IM_OC,JM_OC)) - print*,'calling bilinear_init for SST' - - unitno = getunit () - if (unitno < 0) then - print*,'initsst: getunit failed: stopping' - stop - end if - - open (unitno, file='glvl.dat', form='unformatted', err=70) - call TestGlvlHeader (unitno, 'glvl.dat', 'sst_init', glvl) - call TestCurveHeader(unitno, 'glvl.dat', 'sst_init', curve) - CALL bilinear_init('ocean_bcs_ltln', IM_OC*JM_OC, unitno, nip) - close(unitno) - call returnunit (unitno) - - MDATE=YEAR*100+MONTH - MIDMON = DAYS(MONTH)/2 + 1 - - sstunit = getunit () - if (sstunit < 0) then - print*,'initsst: getunit failed for sstunit: stopping' - stop - else - print*,'initsst: sst unit is ', sstunit - end if - - open (sstunit, file='sst_dat', form='unformatted', err=70) - skip=.TRUE. - do while (skip) - read (sstunit, err=90) time_header - print*,MDATE,time_header - read(sstunit, err=90) sst_prev_ll - read(sstunit, err=90) fice2d_prev_ll - SDATE1=time_header(1)*100+time_header(2) - SDATE2=time_header(3)*100+time_header(4) -! IF (DAY .LT.MIDMON.AND.MDATE.LE.SDATE2) THEN - IF (MDATE.LE.SDATE2) THEN -! SDATE2 needs to equal MDATE for sst_prev_ll - skip=.FALSE. - ENDIF - end do - IF (DAY .GE.MIDMON) THEN - read(sstunit, err=90) time_header - read(sstunit, err=90) sst_prev_ll - read(sstunit, err=90) fice2d_prev_ll - ENDIF - prev_date=time_header - read(sstunit, err=90) time_header - read(sstunit, err=90) sst_next_ll - read(sstunit, err=90) fice2d_next_ll - next_date=time_header - - print*,'FOUND SSTs, calling bl_int',prev_date,next_date - - CALL bl_int (sst_prev_ll(:,:), sst_prev) - CALL bl_int (sst_next_ll(:,:), sst_next) - CALL bl_int (fice2d_prev_ll(:,:), fice2d_prev) - CALL bl_int (fice2d_next_ll(:,:), fice2d_next) - - IF (DAY < MIDMON) THEN - - M1 = MOD(MONTH+10,12) + 1 - M2 = MONTH - MIDM = DAYS(M1)/2 + 1 - MIDP = DAYS(M1) + MIDMON - ID = DAY + DAYS(M1) - - ELSE - - M2 = MOD(MONTH,12) + 1 - M1 = MONTH - MIDM = MIDMON - MIDP = DAYS(M2)/2 + 1 + DAYS(M1) - ID = DAY - - ENDIF -!SMS$SERIAL END -!SMS$SERIAL ( : default=ignore) BEGIN - FAC = (real(ID - MIDM)*86400)/ & - (real(MIDP - MIDM)*86400 ) -!SMS$SERIAL END -! replace ts2d over ocean points -!SMS$PARALLEL(dh, ipn) BEGIN - DO ipn=1,nip - ! need logic to keep ice's temperature the same, only update sst and ice fraction - ! update ice fraction 1st - ! if there is new ice, set it to -1.8 and hice=0.0 - ! if ice melts, then set ts2d to sst and hice=0.0 - IF (slmsk2d(ipn).NE.1) THEN - fice2d(ipn)=fice2d_next(ipn)*(FAC)+fice2d_prev(ipn)*(1.0 - FAC) - if (fice2d(ipn) .GT. 1) fice2d(ipn)=1.0 - if (fice2d(ipn) .LT. 0) fice2d(ipn)=0.0 - ENDIF - IF (fice2d(ipn) .GE. 0.5 .AND. slmsk2d(ipn) .EQ. 0) THEN ! freeze open ocean - slmsk2d(ipn)=2.0 - ts2d(ipn)=271.35 - hice2d(ipn)=0.0 - ENDIF - IF (fice2d(ipn) .LT. 0.5 .AND. slmsk2d(ipn) .EQ. 2) THEN ! melt sea-ice - slmsk2d(ipn)=0.0 - hice2d(ipn)=0.0 - ENDIF - IF (slmsk2d(ipn).EQ.0) THEN - ts2d(ipn)=sst_next(ipn)*(FAC)+sst_prev(ipn)*(1.0 - FAC) - ENDIF - - gis_phy%sfc_fld%TSEA (ipn,1) = ts2d (ipn) - gis_phy%sfc_fld%HICE (ipn,1) = hice2d (ipn) - gis_phy%sfc_fld%FICE (ipn,1) = fice2d (ipn) - gis_phy%sfc_fld%SLMSK (ipn,1) = slmsk2d (ipn) - ENDDO -!SMS$PARALLEL END - - RETURN - -70 write(6,*) 'initsst: error opening file for reading' - stop -90 write(6,*) 'initsst: error reading file' - stop -end subroutine InitSST -end module module_fim_phy_init diff --git a/src/fim/FIMsrc/fim/horizontal/phy_run.F90 b/src/fim/FIMsrc/fim/horizontal/phy_run.F90 deleted file mode 100644 index addd1a1..0000000 --- a/src/fim/FIMsrc/fim/horizontal/phy_run.F90 +++ /dev/null @@ -1,249 +0,0 @@ -module module_fim_phy_run - -contains - -subroutine phy_run(its) -!********************************************************************* -! "Run" method for fim global model physics -! Alexander E. MacDonald 12/24/2005 -! J. LEE 12/28/2005 -!********************************************************************* - -use module_constants -use module_control , only: nts, CallPhysics, CallRadiation, UpdateSST, itsStart -use module_physics , only: physics -use module_outtime_phy, only: telapsed=>tphy - -implicit none - -! Declare dummy arguments -integer, intent(in) :: its - -! Declare local variables: -real*8 :: t0 - -call StartTimer(t0) - - !........................................................... - ! Advance the physics component by one time step unless this - ! is the last (nts+1) iteration. - ! This complexity is required for the NCEP ESMF approach - ! in which single-phase DYN and PHY components alternate - ! execution during each time step. - ! -!TBH: Restore if statement label once Mark fixes PPP -!TBH skip_last_iteration: if (its <= nts ) then -if (its < itsStart+nts) then - - !........................................................... - ! Do column calculations: - !........................................................... - ! Condensational heating parameterizations - ! - if (UpdateSST) then - call sst_run(its) - endif - call physics (its, & - CallPhysics,CallRadiation ) ! Timestep interval to call physics,radiation -endif -!TBH: Restore if statement label once Mark fixes PPP -!TBH endif skip_last_iteration - -call IncrementTimer(t0,telapsed) - -return -end subroutine phy_run - -subroutine sst_run(its) -!********************************************************************* -! "Run" method for fim global model physics -! Alexander E. MacDonald 12/24/2005 -! J. LEE 12/28/2005 -!********************************************************************* - -use module_constants -use module_control, only: nts, CallSST, itsStart - -implicit none - -! Declare dummy arguments -integer, intent(in) :: its -integer :: mype - !........................................................... - ! Advance the physics component by one time step unless this - ! is the last (nts+1) iteration. - ! This complexity is required for the NCEP ESMF approach - ! in which single-phase DYN and PHY components alternate - ! execution during each time step. - ! -!TBH: Restore if statement label once Mark fixes PPP -!TBH skip_last_iteration: if (its <= nts ) then -!SMS$insert call nnt_me(mype) -if (its < itsStart+nts ) then - - !........................................................... - ! Do sst update: - !........................................................... - ! Condensational heating parameterizations - ! - if (mod(its,CallSST) == 0) call update_sst (its) ! Timestep interval to call update sst (set at once 1 day) - -end if -!TBH: Restore if statement label once Mark fixes PPP -!TBH endif skip_last_iteration -return -end subroutine sst_run - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -subroutine update_sst (its) - use module_control, only: yyyymmddhhmm,prev_date,next_date,numphr,nip,have_next_sst - use module_sfc_variables, only: ts2d,sst_prev,sst_next,fice2d,fice2d_prev,fice2d_next,slmsk2d,hice2d - use gfs_physics_internal_state_mod, only: gfs_physics_internal_state, gis_phy - use module_fim_phy_init, only: sstunit -!SMS$ignore begin - USE slint, ONLY: bl_int -!SMS$ignore end - - implicit none - - integer, intent(in) :: its -! Local variables - integer,parameter :: im_oc=360,jm_oc=180 - integer :: mype,ipn - integer :: YEARi,YEARm - integer :: MONTHi,MONTHm - integer :: DAYi,DAYm,HH,MM,SS - integer :: MIDMON - - integer :: ID - integer :: M1 - integer :: M2 - integer :: MIDM - integer :: MIDP - - integer :: idat(8),mdat(8),DAYS(12),time_header(4) - real*8 :: rinc(5) - real :: FAC - real, allocatable :: sst_next_ll(:,:) - real, allocatable :: fice2d_next_ll(:,:) - - - data DAYS /31,28,31,30,31,30,31,31,30,31,30,31/ -!SMS$insert call nnt_me(mype) - READ(yyyymmddhhmm(1:4), FMT='(I4)') YEARi - READ(yyyymmddhhmm(5:6), FMT='(I2)') MONTHi - READ(yyyymmddhhmm(7:8), FMT='(I2)') DAYi - idat = 0 - idat(1) = YEARi - idat(2) = MONTHi - idat(3) = DAYi - - rinc(:) = 0 - rinc(2) = (float(its))/float(numphr) - print*,'In update_sst yeari,monthi,dayi, fhour ',YEARi,MONTHi,DAYi,rinc(2) - call w3movdat (rinc, idat, mdat) - - YEARm =mdat(1) - MONTHm=mdat(2) - DAYm =mdat(3) - HH = mdat(5) - MM = mdat(6) - SS = mdat(7) - - IF (mod(YEARm,4) == 0) THEN - DAYS(2) = 29.0 - ENDIF - IF (YEARm == 1900) THEN - DAYS(2)=28.0 - ENDIF - - MIDMON = DAYS(MONTHm)/2 + 1 - - IF (DAYm < MIDMON) THEN - - M1 = MOD(MONTHm+10,12) + 1 - M2 = MONTHm - MIDM = DAYS(M1)/2 + 1 - MIDP = DAYS(M1) + MIDMON - ID = DAYm + DAYS(M1) - have_next_sst=.false. - - ELSE - - M2 = MOD(MONTHm,12) + 1 - M1 = MONTHm - MIDM = MIDMON - MIDP = DAYS(M2)/2 + 1 + DAYS(M1) - ID = DAYm - - ENDIF - - if (DAYm == MIDMON .AND. .not. have_next_sst) then - sst_prev = sst_next - fice2d_prev = fice2d_next - prev_date=next_date - have_next_sst=.true. -!SMS$SERIAL ( : default=ignore) BEGIN - allocate(sst_next_ll(im_oc,jm_oc)) - allocate(fice2d_next_ll(im_oc,jm_oc)) - - read(sstunit, err=90) time_header - read(sstunit, err=90) sst_next_ll - read(sstunit, err=90) fice2d_next_ll - CALL bl_int (sst_next_ll(:,:), sst_next) - CALL bl_int (fice2d_next_ll(:,:), fice2d_next) - next_date=time_header - print*,'New sst records read',time_header - deallocate(sst_next_ll) - deallocate(fice2d_next_ll) -! check to see if we have corrects dates - IF (M1 /= prev_date(2).AND.M2 /= next_date(2)) THEN - print*,'Error reading SSTs',prev_date,next_date,M1,M2,MONTHm - call MPI_ABORT() - ENDIF -!SMS$SERIAL END - end if -!SMS$SERIAL ( : default=ignore) BEGIN - FAC = (real(ID - MIDM)*86400 + HH*3600 + MM*60 + SS)/ & - (real(MIDP - MIDM)*86400 ) - print*,'In update_sst year,month,day ',YEARm,MONTHm,DAYm,FAC,time_header(1:2),have_next_sst -!SMS$SERIAL END -! replace ts2d over ocean points -!SMS$PARALLEL(dh, ipn) BEGIN - DO ipn=1,nip - ! need logic to keep ice's temperature the same, only update sst and ice fraction - ! update ice fraction 1st - ! if there is new ice, set it to -1.8 and hice=0.0 - ! if ice melts, then set ts2d to sst and hice=0.0 - IF (slmsk2d(ipn) /= 1) THEN - fice2d(ipn) = fice2d_next(ipn)*(FAC) + fice2d_prev(ipn)*(1.0 - FAC) - if (fice2d(ipn) > 1) fice2d(ipn)=1.0 - if (fice2d(ipn) < 0) fice2d(ipn)=0.0 - ENDIF - IF (fice2d(ipn) >= 0.5 .AND. slmsk2d(ipn) == 0) THEN ! freeze open ocean - slmsk2d(ipn)=2.0 - ts2d(ipn)=271.35 - hice2d(ipn)=0.0 - ENDIF - IF (fice2d(ipn) < 0.5 .AND. slmsk2d(ipn) == 2) THEN ! melt sea-ice - slmsk2d(ipn)=0.0 - hice2d(ipn)=0.0 - ENDIF - IF (slmsk2d(ipn) == 0) THEN - ts2d(ipn)=sst_next(ipn)*(FAC)+sst_prev(ipn)*(1.0 - FAC) - ENDIF - - gis_phy%sfc_fld%TSEA (ipn,1) = ts2d (ipn) - gis_phy%sfc_fld%HICE (ipn,1) = hice2d (ipn) - gis_phy%sfc_fld%FICE (ipn,1) = fice2d (ipn) - gis_phy%sfc_fld%SLMSK (ipn,1) = slmsk2d (ipn) - ENDDO -!SMS$PARALLEL END - RETURN - -90 write(6,*)'update_sst: error reading a file' - call flush (6) - stop -end subroutine update_sst -end module module_fim_phy_run diff --git a/src/fim/FIMsrc/fim/horizontal/physics.F90 b/src/fim/FIMsrc/fim/horizontal/physics.F90 deleted file mode 100644 index eb4de09..0000000 --- a/src/fim/FIMsrc/fim/horizontal/physics.F90 +++ /dev/null @@ -1,119 +0,0 @@ -module module_physics -integer :: ipn ! Index for icos point number -integer :: itsP ! Public version of its - -contains -!********************************************************************* -! physics -! Calculates column forcing for global fim -! 12/21/2005 - Alexander E. MacDonald - original version -! 05/01/2006 - Jian-Wen Bao - modified for GFS physics -! 04/14/2008 - Stan Benjamin, John Brown - modifications -! for introduction of virtual pot temp for temp prog variable -! instead of previous non-virtual pot temp -! 03/03/2009 - Tom Henderson - split into do_physics_one_step and cpl_run -!********************************************************************* - -subroutine physics (its, & -CallPhysics,CallRadiation ) ! Timestep interval to call physics,radiation - -!SMS$IGNORE BEGIN -USE gfs_physics_internal_state_mod, only:gis_phy -!SMS$IGNORE END - -use module_control,only:nip,dt,numphr,yyyymmddhhmm,GravityWaveDrag -use module_constants,only: inv_perm - -!GG: added arrays for wrf physics and chemistry -!TODO: send these via internal state and coupler instead of via use-association -use module_chem_variables, only: sscal, ext_cof, asymp, extlw_cof -use module_wrf_variables, only: phys3dwrf,exch,pb2d -!SMS$IGNORE BEGIN -use module_initial_chem_namelists, only: cu_physics, mp_physics, chem_opt -!SMS$IGNORE END -use module_do_physics_one_step,only:do_physics_one_step - -implicit none - -integer,intent (IN ) :: its ! model time step count -integer,intent (IN ) :: CallPhysics,CallRadiation - -! Local variables -!---------------------------------------------------------------------- -! -!GG: added switches for cumulus convection and microphysics -logical :: skip_cu_physics, skip_mp_physics, skip_chem - -!print *,'DEBUG physics(): SIZE(pb2d) = ',SIZE(pb2d) -!---------------------------------------------------------------------- -!TODO: Eliminate duplication by encapsulating this logic -if (mod (its, CallPhysics) == 0 .or. its == 1) then ! Do physics -!---------------------------------------------------------------------- - -if (chem_opt.gt.0) then -!sms$compare_var(pb2d,'begin physics') -!sms$compare_var(exch,'begin physics') -!sms$compare_var(phys3dwrf,'begin physics') -endif - - gis_phy%kdt = its -!TODO: set gis_phy%deltim in phy_init? - gis_phy%deltim = dt - if(CallPhysics>1) then !Adjust the timestep to be the call physics interval - if(its==CallPhysics) then - gis_phy%deltim = (CallPhysics-1)*dt - elseif(its>CallPhysics) then - gis_phy%deltim = CallPhysics*dt - endif - endif - gis_phy%phour = float(its-1)/float(numphr) - -!GG: added switches for cumulus convection and microphysics - skip_cu_physics = (cu_physics /= 0) - skip_mp_physics = (mp_physics /= 0) - skip_chem = (chem_opt /= 0) - - call do_physics_one_step( & - gis_phy%deltim, gis_phy%kdt, gis_phy%phour, & - gis_phy%ps, gis_phy%dp, gis_phy%dpdt, & - gis_phy%p, gis_phy%u, gis_phy%v, & - gis_phy%t, & - gis_phy%q, & - gis_phy%oz, & - gis_phy%cld, & - gis_phy%sfc_fld, gis_phy%flx_fld, & -! These are hard-coded in do_physics_one_step() for the moment -! gis_phy%lats_nodes_r, gis_phy%global_lats_r, & -! gis_phy%lonsperlar, & - gis_phy%XLON, gis_phy%XLAT, gis_phy%COSZDG, & - gis_phy%HPRIME, gis_phy%SWH, gis_phy%HLW, & - gis_phy%FLUXR, gis_phy%SFALB, & - gis_phy%SLAG, gis_phy%SDEC, gis_phy%CDEC, & -! Not used yet by FIM -! gis_phy%OZPLIN, gis_phy%JINDX1, gis_phy%JINDX2, & -! gis_phy%DDY, & - gis_phy%phy_f3d, gis_phy%phy_f2d, gis_phy%NBLCK, & -! Not used yet by FIM -! gis_phy%ZHOUR, gis_phy%N3, gis_phy%N4, & -! gis_phy%LSOUT, gis_phy%COLAT1, gis_phy%CFHOUR1, & -! FIM-specific arguments -! TODO: refactor to remove these - gis_phy%CLDCOV, & - gis_phy%LEVS, gis_phy%LATS_NODE_R, gis_phy%NMTVR, & - gis_phy%num_p3d, gis_phy%num_p2d, gis_phy%NFXR, & - nip, gis_phy%lsoil, GravityWaveDrag, CallRadiation, & - yyyymmddhhmm,inv_perm, & - skip_cu_physics, skip_mp_physics,skip_chem, ipn,sscal, & - ext_cof,asymp,extlw_cof) - -if (chem_opt.gt.0) then -!sms$compare_var(pb2d,'end physics') -!sms$compare_var(exch,'end physics') -!sms$compare_var(phys3dwrf,'end physics') -endif - -endif ! CallPhysics - -return -end subroutine physics -end module module_physics diff --git a/src/fim/FIMsrc/fim/horizontal/printMAXMIN.F90 b/src/fim/FIMsrc/fim/horizontal/printMAXMIN.F90 deleted file mode 100644 index 7f8667c..0000000 --- a/src/fim/FIMsrc/fim/horizontal/printMAXMIN.F90 +++ /dev/null @@ -1,27 +0,0 @@ -module module_printMAXMIN -contains -subroutine printMAXMIN(its,nvl,nip,ntr,tr,dp3d) -implicit none -integer,intent(IN) :: its, nvl,nip,ntr -!SMS$DISTRIBUTE (dh,nip) BEGIN -real ,intent(IN) :: tr (nvl,nip,ntr) -real ,intent(IN) :: dp3d(nvl,nip) -!SMS$DISTRIBUTE END -real :: maxqv3d,minqv3d,aveqv3d,maxdp3d,mindp3d,avedp3d - -maxqv3d = maxval(tr(:,1:nip,2)) -minqv3d = minval(tr(:,1:nip,2)) -aveqv3d = sum (tr(:,1:nip,2)) -maxdp3d = maxval(dp3d(:,1:nip)) -mindp3d = minval(dp3d(:,1:nip)) -avedp3d = sum (dp3d(:,1:nip)) -!SMS$REDUCE(maxqv3d,maxdp3d,max) -!SMS$REDUCE(minqv3d,mindp3d,min) -!SMS$REDUCE(aveqv3d,avedp3d,sum) -aveqv3d = aveqv3d/(nvl*nip) -avedp3d = avedp3d/(nvl*nip) -print"('MAXMIN - ITS, qv(ivl=2)- max/ave/min, dp(all levels)- max/ave/min')" -print"('MAXMIN',i10,1p6e10.3)",its,maxqv3d,aveqv3d,minqv3d,maxdp3d,avedp3d,mindp3d !All should be > 0 -return -end subroutine printMAXMIN -end module module_printMAXMIN diff --git a/src/fim/FIMsrc/fim/horizontal/profout.F90 b/src/fim/FIMsrc/fim/horizontal/profout.F90 deleted file mode 100644 index 680bcf1..0000000 --- a/src/fim/FIMsrc/fim/horizontal/profout.F90 +++ /dev/null @@ -1,48 +0,0 @@ -module module_profout -contains -!********************************************************************* -! profout -! Profile output program for fim global model -! Jacques Middlecoff April 2007 -!********************************************************************* - -subroutine profout( & - its,PrintIpnDiag, & ! index time step - us3d,vs3d,dp3d, & ! west wind, south wind, delta pres - pr3d,th3d,mp3d,tk3d, & ! pressure, theta, mont pot, temp (k) - qv3d,rh3d, & ! specific and relative humidity - ph3d, & - ts2d,us2d,hf2d,qf2d ) ! skin temperature, ustar, sensible heat hlux, water vapor flux - -use module_control ,only: nvl,nvlp1,nip,ArchvStep -use module_constants,only: rd,cp -implicit none - -! External variable declarations: -!SMS$DISTRIBUTE (dh,nip) BEGIN -integer,intent(IN) :: its,PrintIpnDiag -real ,intent(IN) :: us3d(nvl,nip),vs3d(nvl,nip),dp3d(nvl,nip) -real ,intent(IN) :: pr3d(nvlp1,nip),th3d(nvl,nip) -real ,intent(IN) :: mp3d(nvl,nip),tk3d(nvl,nip) -real ,intent(IN) :: ph3d(nvlp1,nip) -real ,intent(IN) :: qv3d(nvl,nip),rh3d(nvl,nip) -real ,intent(IN) :: ts2d(nip),us2d(nip),hf2d(nip),qf2d(nip) -!SMS$DISTRIBUTE END -integer :: k - -if(PrintIpnDiag>0.and.(its==0.or.mod(its,ArchvStep).eq.0)) then -!SMS$SERIAL ( : default=ignore) BEGIN - write (6,101) its-1, & - ' theta t specific humidity press', & -! ' theta t thknss press', & - us2d(PrintIpnDiag),ts2d(PrintIpnDiag),hf2d(PrintIpnDiag),qf2d(PrintIpnDiag), & - (k,th3d(k,PrintIpnDiag),th3d(k,PrintIpnDiag)*(5.e-6*(pr3d(k,PrintIpnDiag)+pr3d(k,PrintIpnDiag)))**(rd/cp),qv3d(k,PrintIpnDiag), & - pr3d(k,PrintIpnDiag),k=1,nvl) -101 format (/' '/i7,x,a/' '/'(ustar, T-skin, shflx & lhflx:',f9.2,2x,f11.6,2x,f11.6,2x,f11.6,')'/ & - ' '/(2x,i3,2x,f9.3,2x,f9.2,2x,f12.5,2x,f11.3)) -!SMS$SERIAL END -endif - -return -end subroutine profout -end module module_profout diff --git a/src/fim/FIMsrc/fim/horizontal/readGLVL.F90 b/src/fim/FIMsrc/fim/horizontal/readGLVL.F90 deleted file mode 100644 index 6d4c719..0000000 --- a/src/fim/FIMsrc/fim/horizontal/readGLVL.F90 +++ /dev/null @@ -1,26 +0,0 @@ -program readGLVL - implicit none - integer,parameter :: npp=6 - integer,parameter :: nd=2 ! number of directions (x,y) - integer,parameter :: glvl=6 - integer,parameter :: nip=10*(2**glvl)**2+2 - real lat(nip),lon(nip) ! lat and lon in radians - integer nprox (nip) ! Holds number of proximity points - integer proxs (npp,nip) ! Holds index of proximity sides - integer prox (npp,nip) ! Holds index of proximity points - real area(nip) ! the area of cell polygon (m**2) - real cs(4,npp,nip),sn(4,npp,nip) - real sidevec_c(nd,npp,nip) ! side vectors projected from center - real sidevec_e(nd,npp,nip) ! side vectors projected from edge - real sideln (npp,nip) ! the length of side vectors (m) - real rprox_ln (npp,nip) ! reciprocal of distance cell cent to prox pts - integer isn,ipn - - open(unit=28,file="glvl.dat",form="unformatted") - read(28)lat,lon,nprox,proxs,prox,area,cs,sn, & - sidevec_c,sidevec_e,sideln,rprox_ln - close(28) - write(76,100) (ipn,(prox(isn,ipn),isn=1,npp),ipn=1,nip) -100 format(7i10) - -end program readGLVL diff --git a/src/fim/FIMsrc/fim/horizontal/readINI.F90 b/src/fim/FIMsrc/fim/horizontal/readINI.F90 deleted file mode 100644 index 9fcd917..0000000 --- a/src/fim/FIMsrc/fim/horizontal/readINI.F90 +++ /dev/null @@ -1,36 +0,0 @@ -program readINI - implicit none - integer,parameter :: npp=6 - integer,parameter :: nd=2 ! number of directions (x,y) - integer,parameter :: glvl=5 - integer,parameter :: nip=10*(2**glvl)**2+2 - integer , parameter :: nvl=25 ! number of vertical levels - integer , parameter :: nvlp1=nvl+1 ! number of vertical levels plus one - real us3d(nvl,nip) ! zonal wind (m/s), layer - real vs3d(nvl,nip) ! meridional wind (m/s), layer - real dp3d(nvl,nip) ! del p between coord levels (pascals) - real mp3d(nvl,nip) ! Montgomery Potential (m**2/s**2) - real th3d(nvl,nip) ! theta (k), layer - real pr3d(nvlp1,nip) ! pressure (pascals), level - real ex3d(nvlp1,nip) ! exner funciton, level - real ph3d(nvlp1,nip) ! phi (=gz), m**2/s**2 - real phse(npp,nip) ! phi bottom interpolated to the edges - real pref(nvlp1,nip) - integer isn,ipn,ivl - - open(unit=28,file="fim_ini.dat",form="unformatted") - read (28) us3d,vs3d,dp3d,pr3d,ex3d,mp3d,th3d,ph3d,phse,pref - close(28) - write(100,100) ((ivl,ipn,us3d(ivl,ipn),ivl=1,nvl),ipn=1,nip) - write(101,100) ((ivl,ipn,vs3d(ivl,ipn),ivl=1,nvl),ipn=1,nip) - write(102,100) ((ivl,ipn,dp3d(ivl,ipn),ivl=1,nvl),ipn=1,nip) - write(103,100) ((ivl,ipn,pr3d(ivl,ipn),ivl=1,nvlp1),ipn=1,nip) - write(104,100) ((ivl,ipn,ex3d(ivl,ipn),ivl=1,nvlp1),ipn=1,nip) - write(105,100) ((ivl,ipn,mp3d(ivl,ipn),ivl=1,nvl),ipn=1,nip) - write(106,100) ((ivl,ipn,th3d(ivl,ipn),ivl=1,nvl),ipn=1,nip) - write(107,100) ((ivl,ipn,ph3d(ivl,ipn),ivl=1,nvlp1),ipn=1,nip) - write(108,100) ((isn,ipn,phse(ivl,ipn),isn=1,npp),ipn=1,nip) - write(109,100) ((ivl,ipn,pref(ivl,ipn),ivl=1,nvlp1),ipn=1,nip) -100 format(2i10,1pe15.7) - -end program readINI diff --git a/src/fim/FIMsrc/fim/horizontal/read_restart_dyn.F90 b/src/fim/FIMsrc/fim/horizontal/read_restart_dyn.F90 deleted file mode 100644 index 33fa3b7..0000000 --- a/src/fim/FIMsrc/fim/horizontal/read_restart_dyn.F90 +++ /dev/null @@ -1,97 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Read required dynamics fields from the restart file. SMS will modify the code to do the -! appropriate single-task reading of the restart file, and subsequent scattering of the -! data to other MPI tasks. -! -! CRITICAL: If you modify this file, you MUST also modify write_restart_dyn.F90 in the -! same way. Otherwise restart will be broken. -! -! read_restart_dyn and write_restart_dyn belong in a module, but SMS doesn't like multiple -! subroutines in a file. -! -! readarr32 assumes 32-bit data. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -subroutine read_restart_dyn (unitno) - use module_sfc_variables, only: rn2d, rc2d, rn2d0, rc2d0, rg2d0, flxswavg2d, flxlwavg2d, flxlwtoa2d - use module_variables, only: curr_write_time, nf, of, vof, adbash1, adbash2, adbash3, psrf, & - ptdcy, pw2d, u_tdcy, v_tdcy, dp_tdcy, dpl_tdcy, tr3d, trdp, & - trc_tdcy, trl_tdcy, us3d, vs3d, ws3d, mp3d, tk3d, dp3d, rh3d, & - vor, dpinit, pr3d, ex3d, ph3d, sdot, massfx, cumufx - use module_constants, only: dpsig, thetac, lat, lon, nprox, proxs, area, cs, sn, sidevec_c, & - sidevec_e, sideln, rsideln, rprox_ln, area, rarea, corio, & - deg_lat, deg_lon - use module_control, only: dt, nabl, ntra, ntrb, npp, nvl, nvlp1 - use module_globsum, only: qmstr, qmstrc, qmstrn, qdtr_set - - implicit none - - integer, intent(in) :: unitno ! unit number to read from - - integer :: n, t ! indices - -!SMS$SERIAL BEGIN - read (unitno, err=90) curr_write_time, nf, of, vof, adbash1, adbash2, adbash3, thetac, dpsig - read (unitno, err=90) lat, lon, nprox, proxs, area, cs, sn, psrf, ptdcy -!SMS$SERIAL END -!SMS$SERIAL BEGIN - read (unitno, err=90) qmstr, qmstrc, qmstrn, qdtr_set -!SMS$SERIAL END -!SMS$SERIAL BEGIN - read (unitno, err=90) sidevec_c, sidevec_e, sideln, rprox_ln -!SMS$SERIAL END -!SMS$SERIAL BEGIN - read (unitno, err=90) rn2d0, rc2d0, rg2d0, flxswavg2d, flxlwavg2d, flxlwtoa2d -!SMS$SERIAL END -!SMS$SERIAL BEGIN - read (unitno, err=90) rarea, rsideln, corio, deg_lat, deg_lon, rn2d, pw2d, rc2d -!SMS$SERIAL END - -! These arrays are dimensioned (nvl,nip[,other dimensions]): - do n=1,nabl - call readarr32 (u_tdcy(:,:,n), nvl, unitno) - call readarr32 (v_tdcy(:,:,n), nvl, unitno) - call readarr32 (dp_tdcy(:,:,n), nvl, unitno) - call readarr32 (dpl_tdcy(:,:,n), nvl, unitno) - end do - - do t=1,ntra+ntrb - call readarr32 (tr3d(:,:,t), nvl, unitno) - call readarr32 (trdp(:,:,t), nvl, unitno) - do n=1,nabl - call readarr32 (trc_tdcy(:,:,n,t), nvl, unitno) - call readarr32 (trl_tdcy(:,:,n,t), nvl, unitno) - end do - end do - - call readarr32 (us3d, nvl, unitno) - call readarr32 (vs3d, nvl, unitno) - call readarr32 (ws3d, nvl, unitno) - call readarr32 (mp3d, nvl, unitno) - call readarr32 (tk3d, nvl, unitno) - call readarr32 (dp3d, nvl, unitno) - call readarr32 (rh3d, nvl, unitno) - call readarr32 (vor, nvl, unitno) - call readarr32 (dpinit, nvl, unitno) - -! These arrays are dimensioned (nvlp1,nip): - call readarr32 (pr3d, nvlp1, unitno) - call readarr32 (ex3d, nvlp1, unitno) - call readarr32 (ph3d, nvlp1, unitno) - call readarr32 (sdot, nvlp1, unitno) - -! These arrays are dimensioned (nvl,npp,nip[,other dimensions]): -! Simplest coding folds nvl*npp into a single dimension. Will need to rewrite massfx -! and cumufx to a transpose if root process can't hold npp 3-d fields in memory - do n=1,nabl - call readarr32 (massfx(:,:,:,n), nvl*npp, unitno) - end do - call readarr32 (cumufx(:,:,:), nvl*npp, unitno) - - write(6,*) 'read_restart_dyn: successfully read dynamics fields from restart file' - - return - -90 write(6,*)'read_restart_dyn: Error reading from unit ', unitno, '. Stopping' - stop -end subroutine read_restart_dyn diff --git a/src/fim/FIMsrc/fim/horizontal/read_restart_phy.F90 b/src/fim/FIMsrc/fim/horizontal/read_restart_phy.F90 deleted file mode 100644 index e3a04a0..0000000 --- a/src/fim/FIMsrc/fim/horizontal/read_restart_phy.F90 +++ /dev/null @@ -1,246 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! read_restart_phy: read physics fields from the restart file -! SMS doesn't yet properly handle Fortran derived types, so those fields -! need to go through an interface routine (readarr64). -! -! !!!!!CRITICAL!!!!! Any changes to fields read in here MUST be made in exactly the same way -! in write_restart_phy.F90 -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -subroutine read_restart_phy (unitno) - use module_control, only: nip - use module_sfc_variables - use module_wrf_control, only: nbands -!SMS$IGNORE BEGIN - use gfs_physics_internal_state_mod, only: gis_phy -!SMS$IGNORE END - use module_chem_variables, only: ext_cof, asymp, extlw_cof - - implicit none - -! Input arguments - integer, intent(in) :: unitno ! Unit number to read from - -! Local workspace - integer :: ipn, i, j, n, k ! Loop indices - integer :: ims, ime ! memory bounds - integer :: ips, ipe ! owned memory bounds -! Transposed versions of arrays so readarr64 can tell SMS to do the right thing. - real*8, allocatable :: smc_loc(:,:) - real*8, allocatable :: stc_loc(:,:) - real*8, allocatable :: slc_loc(:,:) - real*8, allocatable :: hprime_loc(:,:) - real*8, allocatable :: fluxr_loc(:,:) -!SMS$DISTRIBUTE(dh,1) BEGIN - real*8, allocatable :: ext_cof_loc(:,:) - real*8, allocatable :: extlw_cof_loc(:,:) - real*8, allocatable :: asymp_loc(:,:) - real*8, allocatable :: arr(:) -!SMS$DISTRIBUTE END - - ims = gis_phy%ims - ime = gis_phy%ime - ips = gis_phy%ips - ipe = gis_phy%ipe - -!SMS$SERIAL BEGIN - read (unitno, err=90) cv2d, cvt2d, cvb2d, slmsk2d, ts2d, st3d, sheleg2d, zorl2d, snoalb2d - read (unitno, err=90) hprm2d, hice2d, fice2d, tprcp2d, srflag2d, slc3d, sm3d, snwdph2d - read (unitno, err=90) slope2d, shdmin2d, shdmax2d, tg32d, vfrac2d, canopy2d, vtype2d, stype2d - read (unitno, err=90) f10m2d, ffmm2d, ffhh2d, alvsf2d, alnsf2d, alvwf2d, alnwf2d, facsf2d - read (unitno, err=90) facwf2d, t2m2d, q2m2d - read (unitno, err=90) ts2d, us2d, hf2d, qf2d, sw2d, lw2d - write(6,*)'read_restart_phy: ts2d, us2d, hf2d, qf2d, sw2d, lw2d=', & - ts2d(1), us2d(1), hf2d(1), qf2d(1), sw2d(1), lw2d(1) -!SMS$SERIAL END - -! Allocate space for arrays which need to be transposed - - allocate (smc_loc(ims:ime,gis_phy%lsoil)) - allocate (stc_loc(ims:ime,gis_phy%lsoil)) - allocate (slc_loc(ims:ime,gis_phy%lsoil)) - allocate (hprime_loc(ims:ime,gis_phy%nmtvr)) - allocate (fluxr_loc(ims:ime,gis_phy%nfxr)) - - allocate (ext_cof_loc(nip,nbands)) - allocate (extlw_cof_loc(nip,16)) - allocate (asymp_loc(nip,nbands)) - -! Read in ALL sfc_fld items. Some are definitely needed, but the list is huge -! Must call an interface routine (readarr64) until SMS can handle derived types -! 2nd arg to readarr64 is size of dimensions after ipn -! Need to transpose some fields to ipn as 1st index so readarr64 can use SMS -! to do the right thing. - - call readarr64 (smc_loc, gis_phy%lsoil, unitno) - call readarr64 (stc_loc, gis_phy%lsoil, unitno) - call readarr64 (slc_loc, gis_phy%lsoil, unitno) - - do j=1,gis_phy%lsoil - do ipn=ips,ipe - gis_phy%sfc_fld%smc(j,ipn,1) = smc_loc(ipn,j) - gis_phy%sfc_fld%stc(j,ipn,1) = stc_loc(ipn,j) - gis_phy%sfc_fld%slc(j,ipn,1) = slc_loc(ipn,j) - end do - end do - - call readarr64 (gis_phy%sfc_fld%tsea, 1, unitno) - call readarr64 (gis_phy%sfc_fld%sheleg, 1, unitno) - call readarr64 (gis_phy%sfc_fld%sncovr, 1, unitno) - call readarr64 (gis_phy%sfc_fld%tg3, 1, unitno) - call readarr64 (gis_phy%sfc_fld%zorl, 1, unitno) - call readarr64 (gis_phy%sfc_fld%cv, 1, unitno) - call readarr64 (gis_phy%sfc_fld%cvb, 1, unitno) - call readarr64 (gis_phy%sfc_fld%cvt, 1, unitno) - write(6,*)'read_restart_phy: reading alvsf' - call readarr64 (gis_phy%sfc_fld%alvsf, 1, unitno) - call readarr64 (gis_phy%sfc_fld%alvwf, 1, unitno) - call readarr64 (gis_phy%sfc_fld%alnsf, 1, unitno) - call readarr64 (gis_phy%sfc_fld%alnwf, 1, unitno) - call readarr64 (gis_phy%sfc_fld%slmsk, 1, unitno) - call readarr64 (gis_phy%sfc_fld%vfrac, 1, unitno) - call readarr64 (gis_phy%sfc_fld%canopy, 1, unitno) - call readarr64 (gis_phy%sfc_fld%f10m, 1, unitno) - call readarr64 (gis_phy%sfc_fld%t2m, 1, unitno) - call readarr64 (gis_phy%sfc_fld%q2m, 1, unitno) - call readarr64 (gis_phy%sfc_fld%vtype, 1, unitno) - call readarr64 (gis_phy%sfc_fld%stype, 1, unitno) - call readarr64 (gis_phy%sfc_fld%facsf, 1, unitno) - call readarr64 (gis_phy%sfc_fld%facwf, 1, unitno) - call readarr64 (gis_phy%sfc_fld%uustar, 1, unitno) - call readarr64 (gis_phy%sfc_fld%ffmm, 1, unitno) - call readarr64 (gis_phy%sfc_fld%ffhh, 1, unitno) - call readarr64 (gis_phy%sfc_fld%hice, 1, unitno) - call readarr64 (gis_phy%sfc_fld%fice, 1, unitno) - call readarr64 (gis_phy%sfc_fld%uustar, 1, unitno) - call readarr64 (gis_phy%sfc_fld%tprcp, 1, unitno) - call readarr64 (gis_phy%sfc_fld%srflag, 1, unitno) - call readarr64 (gis_phy%sfc_fld%snwdph, 1, unitno) - call readarr64 (gis_phy%sfc_fld%shdmin, 1, unitno) - call readarr64 (gis_phy%sfc_fld%shdmax, 1, unitno) - call readarr64 (gis_phy%sfc_fld%slope, 1, unitno) - call readarr64 (gis_phy%sfc_fld%snoalb, 1, unitno) - -! Read in ALL flx_fld items. Are all actually needed? - call readarr64 (gis_phy%flx_fld%sfcdsw, 1, unitno) - call readarr64 (gis_phy%flx_fld%coszen, 1, unitno) - call readarr64 (gis_phy%flx_fld%tmpmin, 1, unitno) - call readarr64 (gis_phy%flx_fld%tmpmax, 1, unitno) - call readarr64 (gis_phy%flx_fld%dusfc, 1, unitno) - call readarr64 (gis_phy%flx_fld%dvsfc, 1, unitno) - call readarr64 (gis_phy%flx_fld%dtsfc, 1, unitno) - call readarr64 (gis_phy%flx_fld%dqsfc, 1, unitno) - call readarr64 (gis_phy%flx_fld%dlwsfc, 1, unitno) - call readarr64 (gis_phy%flx_fld%ulwsfc, 1, unitno) - call readarr64 (gis_phy%flx_fld%gflux, 1, unitno) - call readarr64 (gis_phy%flx_fld%runoff, 1, unitno) - call readarr64 (gis_phy%flx_fld%ep, 1, unitno) - call readarr64 (gis_phy%flx_fld%cldwrk, 1, unitno) - call readarr64 (gis_phy%flx_fld%dugwd, 1, unitno) - call readarr64 (gis_phy%flx_fld%dvgwd, 1, unitno) - call readarr64 (gis_phy%flx_fld%psmean, 1, unitno) - call readarr64 (gis_phy%flx_fld%geshem, 1, unitno) - call readarr64 (gis_phy%flx_fld%rainc, 1, unitno) - call readarr64 (gis_phy%flx_fld%evap, 1, unitno) - call readarr64 (gis_phy%flx_fld%hflx, 1, unitno) - call readarr64 (gis_phy%flx_fld%bengsh, 1, unitno) - call readarr64 (gis_phy%flx_fld%sfcnsw, 1, unitno) - call readarr64 (gis_phy%flx_fld%sfcdlw, 1, unitno) - call readarr64 (gis_phy%flx_fld%tsflw, 1, unitno) - call readarr64 (gis_phy%flx_fld%psurf, 1, unitno) - call readarr64 (gis_phy%flx_fld%u10m, 1, unitno) - call readarr64 (gis_phy%flx_fld%v10m, 1, unitno) - call readarr64 (gis_phy%flx_fld%hpbl, 1, unitno) - call readarr64 (gis_phy%flx_fld%pwat, 1, unitno) - -! These things are from cpl_dyn_to_phy. Not sure which are necessary - call readarr64 (gis_phy%ps, 1, unitno) - call readarr64 (gis_phy%dp, gis_phy%levs, unitno) - call readarr64 (gis_phy%p, gis_phy%levs, unitno) - call readarr64 (gis_phy%u, gis_phy%levs, unitno) - call readarr64 (gis_phy%v, gis_phy%levs, unitno) - call readarr64 (gis_phy%dpdt, gis_phy%levs, unitno) - call readarr64 (gis_phy%q, gis_phy%levs, unitno) - call readarr64 (gis_phy%oz, gis_phy%levs, unitno) - call readarr64 (gis_phy%cld, gis_phy%levs, unitno) - call readarr64 (gis_phy%t, gis_phy%levs, unitno) - - do n=1,gis_phy%num_p3d - do j=1,gis_phy%lats_node_r - do i=1,gis_phy%nblck - call readarr64 (gis_phy%phy_f3d(:,:,i,j,n), gis_phy%levs, unitno) - end do - end do - end do - - do n=1,gis_phy%num_p2d - do j=1,gis_phy%lats_node_r - call readarr64 (gis_phy%phy_f2d(:,j,n), 1, unitno) - end do - end do - -! These things are in gis_phy proper, not in substructures sfc_fld or flx_fld - do j=1,gis_phy%lats_node_r - call readarr64 (hprime_loc, gis_phy%nmtvr, unitno) - do ipn=ips,ipe - do n=1,gis_phy%nmtvr - gis_phy%hprime(n,ipn,j) = hprime_loc(ipn,n) - end do - end do - call readarr64 (gis_phy%coszdg(:,j), 1, unitno) - call readarr64 (gis_phy%sfalb(:,j), 1, unitno) - call readarr64 (gis_phy%slag(:,j), 1, unitno) - call readarr64 (gis_phy%sdec(:,j), 1, unitno) - call readarr64 (gis_phy%cdec(:,j), 1, unitno) - do n=1,gis_phy%nblck - call readarr64 (gis_phy%swh(:,:,n,j), gis_phy%levs, unitno) - call readarr64 (gis_phy%hlw(:,:,n,j), gis_phy%levs, unitno) - end do - call readarr64 (fluxr_loc, gis_phy%nfxr, unitno) - - do ipn=ips,ipe - do n=1,gis_phy%nfxr - gis_phy%fluxr(n,ipn,j) = fluxr_loc(ipn,n) - end do - end do - end do - -!SMS$PARALLEL(dh, ipn) BEGIN -! These things are from chemistry, but are used in grrad. Need to transpose so -! readarr64 tells SMS to do the right thing. - do k=1,gis_phy%levs - call readarr64 (ext_cof_loc, nbands, unitno) - call readarr64 (asymp_loc, nbands, unitno) - do n=1,nbands - do ipn=1,nip - ext_cof(k,ipn,n) = ext_cof_loc(ipn,n) - asymp(k,ipn,n) = asymp_loc(ipn,n) - end do - end do - -! The "16" is hard-wired in the allocation done in dyn_alloc - call readarr64 (extlw_cof_loc, 16, unitno) - do n=1,16 - do ipn=1,nip - extlw_cof(k,ipn,n) = extlw_cof_loc(ipn,n) - end do - end do - end do - - write (6,*) 'read_restart_phy: successfully read physics fields from restart file' -!SMS$PARALLEL END - - deallocate (smc_loc) - deallocate (stc_loc) - deallocate (slc_loc) - deallocate (ext_cof_loc) - deallocate (extlw_cof_loc) - deallocate (asymp_loc) - deallocate (hprime_loc) - deallocate (fluxr_loc) - - return - -90 write(6,*)'read_restart_phy: Error reading from unit ', unitno, '. Stopping' - stop -end subroutine read_restart_phy diff --git a/src/fim/FIMsrc/fim/horizontal/readarr32.F90 b/src/fim/FIMsrc/fim/horizontal/readarr32.F90 deleted file mode 100644 index b2d8afb..0000000 --- a/src/fim/FIMsrc/fim/horizontal/readarr32.F90 +++ /dev/null @@ -1,27 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Read 32-bit array and distribute to other MPI tasks. -! Used by read_restart_dyn and phy_init. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -subroutine readarr32 (arr, dim1siz, unitno) - use module_control, only: nip - - implicit none - - integer, intent(in) :: dim1siz ! size of 1st dimension of arr - integer, intent(in) :: unitno ! unit number to read from - -!SMS$DISTRIBUTE(dh,2) BEGIN - real*4, intent(inout) :: arr(dim1siz,nip) -!SMS$DISTRIBUTE END - -! The keeps SMS from generating a needless gather before the read -!SMS$SERIAL ( : DEFAULT=IGNORE) BEGIN - read (unitno, err=90) arr -!SMS$SERIAL END - - return - -90 write(6,*) 'readarr32: error reading from unit ', unitno, ' Stopping' - stop -end subroutine readarr32 diff --git a/src/fim/FIMsrc/fim/horizontal/readarr64.F90 b/src/fim/FIMsrc/fim/horizontal/readarr64.F90 deleted file mode 100644 index 7b96c52..0000000 --- a/src/fim/FIMsrc/fim/horizontal/readarr64.F90 +++ /dev/null @@ -1,27 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Read 64-bit array from the restart file and distribute to other MPI tasks. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -subroutine readarr64 (arr, dim2siz, unitno) - use module_control, only: nip - - implicit none - - integer, intent(in) :: dim2siz ! size of 2nd dimension of arr - integer, intent(in) :: unitno ! unit number to read from - - integer :: n, ipn ! loop indices - -!SMS$DISTRIBUTE(dh,1) BEGIN - real*8, intent(inout) :: arr(nip,dim2siz) ! array to be read from restart file -!SMS$DISTRIBUTE END - -! The keeps SMS from generating a needless gather before the read -!SMS$SERIAL ( : DEFAULT=IGNORE) BEGIN - read (unitno, err=90) arr -!SMS$SERIAL END - return - -90 write(6,*) 'readarr64: error reading from unit ', unitno, ' Stopping' - stop -end subroutine readarr64 diff --git a/src/fim/FIMsrc/fim/horizontal/readcase.F90 b/src/fim/FIMsrc/fim/horizontal/readcase.F90 deleted file mode 100644 index e0667fa..0000000 --- a/src/fim/FIMsrc/fim/horizontal/readcase.F90 +++ /dev/null @@ -1,33 +0,0 @@ -program readcase -implicit none -integer , parameter :: glvl=5 ! the grid level -integer , parameter :: nip=10*(2**glvl)**2+2 ! # of icosahedral points -integer , parameter :: nvl=25 ! number of vertical levels -integer , parameter :: nvlp1=nvl+1 ! number of vertical levels -real :: us1(nvl ,nip),vs1 (nvl,nip),dp1(nvl,nip) -real :: pr1(nvlp1,nip),th1 (nvl,nip) -real :: mp1(nvl ,nip),tk1 (nvl,nip) -real :: ph1(nvlp1,nip),vor1(nvl,nip),div1(nvl,nip) -real :: qv1(nvl ,nip),rh1 (nvl,nip),rn2d1(nip),pw2d1(nip) - -real :: us2(nvl ,nip),vs2 (nvl,nip),dp2(nvl,nip) -real :: pr2(nvlp1,nip),th2 (nvl,nip) -real :: mp2(nvl ,nip),tk2 (nvl,nip) -real :: ph2(nvlp1,nip),vor2(nvl,nip),div2(nvl,nip) -real :: qv2(nvl ,nip),rh2 (nvl,nip),rn2d2(nip),pw2d2(nip) - -integer :: lunin1=13 -integer :: lunin2=14 - -read(lunin1)its1,us1,vs1,dp1,pr1,mp1,th1,vor1,ph1,qv1,rh1,rn2d1,pw2d1 -read(lunin2)its2,us2,vs2,dp2,pr2,mp2,th2,vor2,ph2,qv2,rh2,rn2d2,pw2d2 - -print*,its1,its2 -do ipn=1,nip - do ivl=1,nvl - if(us1(ivl,ipn) /= us2(ivl,ipn)) then - print"(i8,2i5,1p2e20.7)",its1,ivl,ipn,us1(ivl,ipn),us2(ivl,ipn) - endif - enddo -enddo - diff --git a/src/fim/FIMsrc/fim/horizontal/restart.F90 b/src/fim/FIMsrc/fim/horizontal/restart.F90 deleted file mode 100644 index 340ba01..0000000 --- a/src/fim/FIMsrc/fim/horizontal/restart.F90 +++ /dev/null @@ -1,139 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! module restart contains these public entities: -! write_restart: writes a restart file -! read_restart: reads a restart file -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -module restart - use module_control, only: itsstart - use units, only: getunit, returnunit - use module_outtime_dyn, only: twrite_restart, tread_restart - - implicit none - - private - public :: write_restart, read_restart - -contains - -! write_restart: open the output restart file, then call write_restart_dyn and write_restart_phy - subroutine write_restart (itsm1) - integer, intent(in) :: itsm1 ! current time step to write to restart file - - integer :: ivl ! Index for vertical levels - character(len=16) :: rfilename ! Restart file name - integer :: unitno ! Fortran unit number to write to - integer :: ret ! function return - real*8 :: t0 ! for timing - character(len=8) :: funcval ! for Lahey - - character(len=8), external :: its2string ! Converts an integer to a string - -#ifdef MANUALGPTL -#include -#endif - - write (6,*) 'Entered write_restart itsm1=', itsm1 -!JR The following causes Lahey to fail! Looks like a compiler bug, so code around it: -! write (rfilename, "('restart_',a8)") its2string (itsm1) - funcval = its2string (itsm1) - write (rfilename, "(a8,a8)") 'restart_', funcval - - unitno = getunit () - if (unitno < 0) then - write(6,*)'write_restart: Bad return from getunit' - stop - end if - - call starttimer(t0) -!SMS$SERIAL BEGIN - open (unitno, file=rfilename, form='unformatted', action='write', err=70) - write (unitno, err=90) itsm1 -!SMS$SERIAL END - -#ifdef MANUALGPTL - ret = gptlprint_memusage ('before write_restart') -#endif - call write_restart_dyn (unitno) - call write_restart_phy (unitno) -#ifdef MANUALGPTL - ret = gptlprint_memusage ('after write_restart') -#endif - call incrementtimer (t0, twrite_restart) - - close (unitno) - call returnunit (unitno) - -#ifdef MANUALGPTL - ret = gptlprint_memusage ('before system()') -#endif - -!SMS$SERIAL (DEFAULT=IGNORE) BEGIN - call system ('/bin/rm rpointer; ln -s ' // trim(rfilename) // ' rpointer') - write(6,*)'restart: created link file rpointer -> ', trim(rfilename) - call system ('/bin/ls -l rpointer ' // trim(rfilename)) -!SMS$SERIAL END - -#ifdef MANUALGPTL - ret = gptlprint_memusage ('after system()') -#endif - return - -70 write(6,*)'write_restart: Error opening unit ', unitno, '. Stopping' - stop - -90 write(6,*)'write_restart: Error writing restart file. Stopping' - stop - end subroutine write_restart - -! read_restart: open the input restart file, then call read_restart_dyn and read_restart_phy - subroutine read_restart () - integer :: itsm1 ! time step read from restart file - integer :: unitno ! unit number for restart file - integer :: ret ! function return - real*8 :: t0 ! for timing - -#ifdef MANUALGPTL -#include -#endif - - unitno = getunit () - if (unitno < 0) then - write(6,*)'read_restart: Bad return from getunit' - stop - end if - - call starttimer (t0) -!SMS$SERIAL BEGIN - open (unitno, file='rpointer', form='unformatted', action='read', err=70) - write(6,*)'read_restart: successfully opened restart file rpointer on unit ', unitno - read (unitno, err=90) itsm1 -!SMS$SERIAL END - - write (6,*) 'read_restart: starting up from itsm1=', itsm1 - -#ifdef MANUALGPTL - ret = gptlprint_memusage ('before read_restart') -#endif - call read_restart_dyn (unitno) - call read_restart_phy (unitno) -#ifdef MANUALGPTL - ret = gptlprint_memusage ('after read_restart') -#endif - call incrementtimer (t0, tread_restart) - - close (unitno) - call returnunit (unitno) - write(6,*)'read_restart: returned unit ', unitno, ' to the list of available units' - - itsstart = itsm1 + 1 ! Set starting iteration counter for the restart run - - return - -70 write(6,*)'read_restart: Error opening rpointer. Stopping' - stop - -90 write(6,*)'read_restart: Error reading restart file. Stopping' - stop - end subroutine read_restart -end module restart diff --git a/src/fim/FIMsrc/fim/horizontal/run.F90 b/src/fim/FIMsrc/fim/horizontal/run.F90 deleted file mode 100644 index f5f29b7..0000000 --- a/src/fim/FIMsrc/fim/horizontal/run.F90 +++ /dev/null @@ -1,289 +0,0 @@ -!********************************************************************* -! "Run" program for fim global model -! Alexander E. MacDonald 12/24/2005 -! J. LEE 12/28/2005 -!********************************************************************* - -subroutine run () - use module_chem_driver ,only: chem_run=>chem_driver - use module_constants - use module_control ,only: itsStart,nts,nvl,nip,PrintIpnDiag,& - ntra,ntrb,digifilt,wts_type,readrestart, restart_freq - use module_core_setup ,only: iam_fim_task,iam_write_task,use_write_tasks - use module_fim_cpl_run ,only: cpl_run - use module_fim_dyn_run ,only: dyn_run - use module_fim_phy_run ,only: phy_run - use module_initial_chem_namelists,only: chem_opt,mp_physics,cu_physics - use module_outtime_main ,only: MainLoopTime - use module_wrf_phy_run ,only: wrf_phy_run - use module_digifilt ,only: digifilt_wts - use module_variables,only: u_tdcy,v_tdcy,dp_tdcy,dpl_tdcy,massflx, & - nf,of,vof,us3d,vs3d,dp3d,pr3d,ph3d,ex3d,mp3d, & - tk3d,u_edg,v_edg,dp_edg, & - lp_edg,bnll_edg,adbash1,adbash2,adbash3, & - tr3d,trc_edg,trdp,trl_tdcy,trc_tdcy, & - ws3d,sdot,rh3d,pw2d,vor,ptdcy - use module_savesfc, only: savesfc - use module_hybgen ,only: hybgen - use module_fim_phy_init ,only: phy_init - use restart, only: write_restart -!sms$ignore begin - use icosio,only:icosio_end_frame -!sms$ignore end - - implicit none - - !SMS$DISTRIBUTE(dh,nip) BEGIN - real, allocatable, dimension(:,:) :: us3d_f,vs3d_f,dp3d_f - real, allocatable, dimension(:,:,:) :: tr3d_f - real, allocatable, dimension(:,:) :: us3d_s,vs3d_s,dp3d_s - real, allocatable, dimension(:,:,:) :: tr3d_s - !SMS$DISTRIBUTE END - real, allocatable, dimension(:) :: wts - character(len=80) filename - real*8 :: t0 - - ! Declare local variables: - integer :: its ! time step index - integer :: itsm1 - integer :: ipn,ivl,nwts,i,k - - call StartTimer(t0) - - !........................................................... - ! Note that the time-stepping loop has been "phase-shifted" - ! to conform to the NCEP ESMF approach in which - ! single-phase DYN and PHY run components alternate - ! execution during each time step. Previously, the time - ! step loop looked like this: - ! - ! do its=itsStart,nts - ! DYN_1 - ! PHY - ! DYN_2 - ! enddo - ! - ! "DYN_1" comprised all calls from the start of the loop - ! up to but not including the call to physics(). - ! - ! "PHY" included only the call to physics(). - ! - ! "DYN_2" comprised all calls after physics() through the - ! end of the loop. - ! - ! This loop was then "phase-shifted" to look like this: - ! - ! do its=itsStart,nts+1 - ! if (its > itsStart) then - ! DYN_2(its-1) - ! endif - ! if (its <= nts) then - ! DYN_1 - ! PHY - ! endif - ! enddo - ! - ! Here, DYN_2 is run for the previous time-step (its-1) - ! while DYN_1 and PHY are run for the current time step - ! (its) as before. - ! - ! DYN_1 and DYN_2 were then combined into new routine - ! dyn_run() and PHY was encapsulated in new routine - ! phy_run(). With the "if" statements pushed inside, - ! the final result looks like the NCEP approach: - ! - ! do its=itsStart,nts+1 - ! call dyn_run(its) - ! call phy_run(its) - ! enddo - ! - ! In all ways the model behaves as it did before these - ! changes were made. The model still iterates through - ! nts actual time steps, despite modification of the - ! loop uppper bound. - - ! Checks on things that have not yet been verified to work in restart mode: - if (readrestart) then - if (mp_physics > 0 .or. cu_physics > 0) then - write(6,*)'run: readrestart and wrf_physics (mp_physics or cu_physics) both true does not work. Stopping.' - call flush(6) - stop - end if - end if - - if (digifilt) then - print *,'should not be in here' - call digifilt_wts(wts,nwts) - ! for debugging - ! wts=0.; wts((nwts/2)+1)=1. - allocate(us3d_f(nvl,nip),vs3d_f(nvl,nip)) - allocate(dp3d_f(nvl,nip)) - allocate(tr3d_f(nvl,nip,ntra+ntrb)) ! 1=pot.temp, 2=water vapor, 3=cloud water, 4=ozone - allocate(us3d_s(nvl,nip),vs3d_s(nvl,nip)) - allocate(dp3d_s(nvl,nip)) - allocate(tr3d_s(nvl,nip,ntra+ntrb)) ! 1=pot.temp, 2=water vapor, 3=cloud water, 4=ozone -!SMS$PARALLEL (dh,ipn) BEGIN - do ipn=1,nip - us3d_f(:,ipn) = 0. - vs3d_f(:,ipn) = 0. - dp3d_f(:,ipn) = 0. - tr3d_f(:,ipn,:) = 0. - end do -!SMS$PARALLEL END - if (iam_fim_task) then - do its=itsStart,nwts ! digital filter part - itsm1 = its - 1 -! --- to start diagnostics in the middle of a run, define PrintIpnDiag here -! if (its.gt.____) PrintIpnDiag=____ - call dyn_run (its) ! Dynamics run method. - call cpl_run (its, dyn_to_phy=.true.) ! Coupler run method: dyn->phy - call phy_run (its) ! physics run method. - call cpl_run (its, dyn_to_phy=.false.) ! Coupler run method: phy->dyn - ! accumulate filtered values -!SMS$PARALLEL (dh,ipn) BEGIN - do ipn=1,nip - us3d_f(:,ipn) = us3d_f(:,ipn) + wts(its-itsStart+1)*us3d(:,ipn) - vs3d_f(:,ipn) = vs3d_f(:,ipn) + wts(its-itsStart+1)*vs3d(:,ipn) - dp3d_f(:,ipn) = dp3d_f(:,ipn) + wts(its-itsStart+1)*dp3d(:,ipn) - tr3d_f(:,ipn,:) = tr3d_f(:,ipn,:) + wts(its-itsStart+1)*tr3d(:,ipn,:) - end do -!SMS$PARALLEL END - if (its-itsStart+1 == (nwts/2)+1) then ! center of filter window -!SMS$PARALLEL (dh,ipn) BEGIN - do ipn=1,nip - us3d_s(:,ipn) = us3d(:,ipn) - vs3d_s(:,ipn) = vs3d(:,ipn) - dp3d_s(:,ipn) = dp3d(:,ipn) - tr3d_s(:,ipn,:) = tr3d(:,ipn,:) - end do -!SMS$PARALLEL END - ! save sfc variables at center of filter window. - filename = 'gfsfc.dat' - print*,'calling savesfc',trim(filename) - call savesfc(filename) -!SMS$SERIAL BEGIN - print *,'before digital filter: wt = ',its-itsStart+1,wts(its-itsStart+1) - print *,'min/max us3d',minval(us3d),maxval(us3d) - print *,'min/max vs3d',minval(vs3d),maxval(vs3d) - print *,'min/max dp3d',minval(dp3d),maxval(dp3d) - print *,'min/max tr3d(1)',minval(tr3d(:,:,1)),maxval(tr3d(:,:,1)) -!SMS$SERIAL END - end if ! end save state at middle of digital filter window - - if (chem_opt > 0) then - call wrf_phy_run (its) ! physics run method - call chem_run (its) ! chemistry run method. - end if - call icosio_end_frame(itsm1) - end do ! time step loop - -! replace variables with filter variables, reset time setup counter -! to center of filter window. - itsStart = itsStart + (nwts/2) + 1 ! nwts must be odd integer. -!SMS$PARALLEL (dh,ipn) BEGIN - do ipn=1,nip - us3d(:,ipn) = us3d_f(:,ipn) - vs3d(:,ipn) = vs3d_f(:,ipn) - dp3d(:,ipn) = dp3d_f(:,ipn) - tr3d(:,ipn,:) = tr3d_f(:,ipn,:) - us3d_s(:,ipn) = us3d_s(:,ipn) - us3d(:,ipn) - vs3d_s(:,ipn) = vs3d_s(:,ipn) - vs3d(:,ipn) - dp3d_s(:,ipn) = dp3d_s(:,ipn) - dp3d(:,ipn) - tr3d_s(:,ipn,:) = tr3d_s(:,ipn,:) - tr3d(:,ipn,:) - do ivl=1,nvl - tr3d(ivl ,ipn,2) = max(qvmin,tr3d(ivl,ipn,2)) - tr3d(ivl ,ipn,3) = max(0. ,tr3d(ivl,ipn,3)) - tr3d(ivl ,ipn,4) = max(0. ,tr3d(ivl,ipn,4)) - end do - end do -! diagnose pressure, exner, mont. pot and geopot. - do ipn=1,nip ! global icos loop - do ivl=nvl,1,-1 ! loop through layers (top-down for p,ex,omega) - pr3d(ivl,ipn) = pr3d(ivl+1,ipn) + dp3d(ivl,ipn) - ex3d(ivl,ipn) = cp*(pr3d(ivl,ipn)/p1000)**(rd/cp) - do i=1,ntra+ntrb - trdp(ivl,ipn,i) = tr3d(ivl,ipn,i)*dp3d(ivl,ipn) - end do - end do - end do -!SMS$PARALLEL END -!SMS$SERIAL BEGIN - print *,'after digital filter: reset its to',itsStart - print *,'min/max us3d',minval(us3d),maxval(us3d) - print *,'min/max vs3d',minval(vs3d),maxval(vs3d) - print *,'min/max pr3d',minval(pr3d),maxval(pr3d) - print *,'min/max ph3d',minval(ph3d),maxval(ph3d) - print *,'min/max tr3d(1)',minval(tr3d(:,:,1)),maxval(tr3d(:,:,1)) - print *,'min/max us3d diff',minval(us3d_s),maxval(us3d_s) - print *,'min/max vs3d diff',minval(vs3d_s),maxval(vs3d_s) - print *,'min/max dp3d diff',minval(dp3d_s),maxval(dp3d_s) - print *,'min/max tr3d(1) diff',minval(tr3d_s(:,:,1)),maxval(tr3d_s(:,:,1)) -!SMS$SERIAL END - call hybgen(itsStart-1, & - thetac, & ! target pot.temperature - us3d,vs3d,tr3d, & ! zonal, meridional wind, mass field tracers - sdot,ex3d,dp3d,pr3d ) ! intfc displ., exner, lyr thknss, pressure -!SMS$PARALLEL (dh,ipn) BEGIN - do ipn=1,nip ! global icos loop - mp3d(1,ipn) = ex3d(1,ipn)*tr3d(1,ipn,1) + ph3d(1,ipn) ! mont pot, layer 1 - ph3d(2,ipn) = mp3d(1,ipn) - tr3d(1,ipn,1)*ex3d(2,ipn) ! geopot, level 2 - do k=2,nvl ! vertical loop - mp3d(k,ipn) = mp3d(k-1,ipn) + ex3d(k,ipn)*(tr3d(k,ipn,1)-tr3d(k-1,ipn,1)) - ph3d(k+1,ipn) = mp3d(k,ipn) - tr3d(k,ipn,1)*ex3d(k+1,ipn) - end do - end do -! re-initialize forcing arrays - do ipn=1,nip - u_tdcy(:,ipn,:) = 0. ! u forcing - v_tdcy(:,ipn,:) = 0. ! v forcing - dp_tdcy(:,ipn,:) = 0. ! dp forcing - dpl_tdcy(:,ipn,:) = 0. ! low order forcing - trc_tdcy(:,ipn,:,:) = 0. ! tracer forcing - trl_tdcy(:,ipn,:,:) = 0. ! tracer forcing low order - end do -!SMS$PARALLEL END -! initial Adams-Bashforth indexes - nf = 0 ! "new field" index - of = 2 ! "old field" index - vof = 1 ! "very old field" index -! re-initialize physics (re-read surface file to get values at center of filter -! window) - call phy_init () -! clean up. - deallocate(wts,us3d_f,vs3d_f,dp3d_f,tr3d_f) - deallocate(us3d_s,vs3d_s,dp3d_s,tr3d_s) - end if - end if ! digifilt=.true. - - if (iam_fim_task) then - do its=itsStart,itsStart+nts ! its=index time step, nts = num time steps - itsm1 = its - 1 - -! Write a restart file if it's time - if (its /= itsStart .and. mod (itsm1, restart_freq) == 0) then - call write_restart (itsm1) - end if - -! --- to start diagnostics in the middle of a run, define PrintIpnDiag here -! if (its.gt.____) PrintIpnDiag=____ - - call dyn_run (its) ! Dynamics run method. - call cpl_run (its, dyn_to_phy=.true.) ! Coupler run method: dyn->phy - call phy_run (its) ! Physics run method. - call cpl_run (its, dyn_to_phy=.false.) ! Coupler run method: phy->dyn - - if (mp_physics > 0 .or. cu_physics > 0) then - call wrf_phy_run (its) ! physics run method. - end if - - if (chem_opt > 0) then - call chem_run (its) ! chemistry run method. - end if - call icosio_end_frame(itsm1) - end do ! time step loop - end if - - call IncrementTimer(t0,MainLoopTime) - - return -end subroutine run diff --git a/src/fim/FIMsrc/fim/horizontal/stencilprint.F90 b/src/fim/FIMsrc/fim/horizontal/stencilprint.F90 deleted file mode 100644 index 2680db6..0000000 --- a/src/fim/FIMsrc/fim/horizontal/stencilprint.F90 +++ /dev/null @@ -1,299 +0,0 @@ -module stencilprint -contains -! -+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ -! This routine displays a cluster of icos values centered on grid cell -! 'PrintIpnDiag' (specified in FIMnamelist). The user-selectable -! parameter 'num_rings' specifies the number of concentric rings of -! data points displayed around the center point. Values are printed in -! their approximate geographic location relative to the center point, -! scaled to an 80-col screen with south pointing down. -! -! If 'field' has a vertical dimension (i.e. kdm > 1), data are printed -! for levels kfrst ... klast in steps of kstep. -! -! If 'field' has no vertical dimension, call stencl with kdm=1. -! -! R.Bleck October 2009 -! -+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ - - subroutine stencl(field,kdm,sclfac,what) - - use module_control, only: nip, PrintIpnDiag, & - stencl_frst,stencl_last,stencl_step - use module_constants,only: deg_lat, deg_lon, nprox, prox, pi - - implicit none - real ,intent(IN) :: sclfac ! scale factor for F format printing - integer ,intent(IN) :: kdm - character,intent(IN) :: what*(*) -!SMS$DISTRIBUTE (dh,nip) BEGIN - real, intent(IN) :: field(kdm,nip) -!SMS$DISTRIBUTE END - - integer,parameter :: num_rings=2 ! number of concentric rings -! integer,parameter :: num_rings=3 ! number of concentric rings - - integer,parameter :: maxpts=1+6*(2**num_rings-1) - integer,parameter :: idm=75*num_rings/max(num_rings,3),jdm=idm/3 - character map(idm,jdm)*1,string*7 - integer edg,i,j,k,m,n,ntot,ipn,ipx,nxtring,nr,nold,nnew,cumutot - logical newcell - real*8 xmin,xmax,ymin,ymax,diflon,arg - real*8 x(maxpts),y(maxpts),dist(maxpts),angl(maxpts), & - valu(kdm,maxpts),alat(maxpts),alon(maxpts), & - cumulat(maxpts),cumulon(maxpts),cumuval(kdm,maxpts) - integer cell(maxpts),iloc(maxpts),jloc(maxpts),cumucell(maxpts), & - cell1(maxpts) - integer :: kfrst,kstep,klast - -#if ( defined NEED_SINDCOSD ) -!JR Define required statement functions for situations where -!JR compiler doesn't support them (e.g. gfortran) - real*8 :: val, sind, cosd, asind, acosd - sind(val) = sin(val*pi/180.) - cosd(val) = cos(val*pi/180.) - - asind(val) = (180./pi)*asin(val) - acosd(val) = (180./pi)*acos(val) -#endif - - if (PrintIpnDiag.le.0) return -! print '(3a,i8)','entering stencl to print ',what,' at ipn =', & -! PrintIpnDiag -!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+- -! --- layers printed are: kfrst, kfrst+kstep, kfrst+2*kstep, ..., klast -!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+- - if (kdm.eq.1) then - kfrst=1 - klast=1 - kstep=1 - else - if (stencl_step.eq.0) return - kfrst=stencl_frst - klast=stencl_last - kstep=stencl_step - end if - -! --- build up inventory of cell indices, starting with center cell - -!SMS$PARALLEL (dh,ipn) BEGIN - alat(:)=-999. - alon(:)=-999. - valu(:,:)=-1.e33 - do ipn=1,nip -!SMS$IGNORE BEGIN - if (ipn.eq.PrintIpnDiag) then - alat(1)=deg_lat(ipn) - alon(1)=deg_lon(ipn) - valu(kfrst:klast,1)=field(kfrst:klast,ipn) -! print '(a,i3,2f9.2)','lat/lon/ipn of cell',0,alat(1),alon(1) - end if -!SMS$IGNORE END - end do -!SMS$REDUCE (ntot,alat,alon,valu,MAX) -!SMS$PARALLEL END - - cumucell(1)=PrintIpnDiag - cumulat(1)=alat(1) - cumulon(1)=alon(1) - cumuval(kfrst:klast,1)=valu(kfrst:klast,1) - cumutot=1 - nold=0 - -! --- expand cluster. each new ring is union of neighbors of previous ring - - do nxtring=1,num_rings - -! --- neighbors of cells 1...nold have already been located. -! --- new ring consists of neighbors of cells (nold+1)...cumutot - - nnew=cumutot - do nr=nold+1,nnew -! print '(3(a,i3))','starting ring',nxtring, & -! '. looking for neighbors of cells',nold+1,' -',nnew - -! --- find lat/lon of cells in ring 'nxtring' - -!SMS$PARALLEL (dh,ipn) BEGIN -!SMS$EXCHANGE(field) - ntot=-99 - alat(:)=-999. - alon(:)=-999. - valu(:,:)=-1.e33 - do ipn=1,nip -!SMS$IGNORE BEGIN - if (ipn.eq.cumucell(nr)) then - ntot=0 - do edg=1,nprox(ipn) - ipx=prox(edg,ipn) - ntot=ntot+1 - alat(ntot)=deg_lat(ipx) - alon(ntot)=deg_lon(ipx) - valu(kfrst:klast,ntot)=field(kfrst:klast,ipx) -! print '(a,i9,2f9.2)','lat/lon/ipn of neighbor',ipx, & -! alat(ntot),alon(ntot) - end do - end if -!SMS$IGNORE END - end do -!SMS$REDUCE (ntot,alat,alon,valu,MAX) -!SMS$PARALLEL END - -! --- knowing lat/lon of cells in ring 'nxtring', find their indices - - do n=1,ntot -! print '(a,i3,a,2f9.2)','n =',n,' looking for cell at lat/lon', & -! alat(n),alon(n) - -!SMS$PARALLEL (dh,ipn) BEGIN - cell1(:)=-99 - do ipn=1,nip -!SMS$IGNORE BEGIN - if (deg_lat(ipn).eq.alat(n) .and. deg_lon(ipn).eq.alon(n)) then -! print '(a,i9,a,2f9.2)','cell',ipn,' has desired lat/lon', & -! alat(n),alon(n) - cell1(n)=ipn - end if -!SMS$IGNORE END - end do -!SMS$REDUCE (cell1,MAX) -!SMS$PARALLEL END - cell(n)=cell1(n) - end do - -! print '(a,i4,a/(i9,2f9.2,f9.1))','considering',ntot,' cells', & -! (cell(n),alat(n),alon(n),valu(kfrst,n),n=1,ntot) - -! --- eliminate duplicates - - do n=1,ntot - newcell=.true. - do m=1,cumutot -! print *,'comparing',n,cell(n),m,cumucell(m) - if (cell(n).eq.cumucell(m)) then - newcell=.false. -! print *,'rejecting',cell(n) - exit - end if - end do - if (newcell) then -! print *,'accepting',cell(n) - cumutot=cumutot+1 - if (cumutot.gt.maxpts) stop '(number of cells > maxpts)' - cumucell(cumutot)=cell(n) - cumulat(cumutot)=alat(n) - cumulon(cumutot)=alon(n) - cumuval(kfrst:klast,cumutot)=valu(kfrst:klast,n) - end if - end do -! print '(3(a,i4)/(i9,2f9.2,f9.1))','total cell count is',cumutot, & -! ' after locating neighbors of ',nr,' cells in ring',nxtring-1, & -! (cumucell(n),cumulat(n),cumulon(n),cumuval(kfrst,n),n=1,cumutot) - end do ! nr loop -! print *,'ring',nxtring,' completed' - nold=nnew - end do ! nxtring - - ntot=cumutot - do n=1,ntot - cell(n)=cumucell(n) - alat(n)=cumulat(n) - alon(n)=cumulon(n) - valu(kfrst:klast,n)=cumuval(kfrst:klast,n) - end do - -! print '(a/(i4,i9,2f9.2,f9.1))', & -! 'all cluster points have now been identified:', & -! (n,cell(n),alat(n),alon(n),valu(kfrst,n),n=1,ntot) - - xmin= 1.e33 - xmax=-1.e33 - ymin= 1.e33 - ymax=-1.e33 - - map(:,:)=' ' - -! --- dist = distance (deg) between cell 'PrintIpnDiag' and cell 'n'. -! --- angl = compass heading from cell 'PrintIpnDiag' to cell 'n'. - - x(1)=0. - y(1)=0. - alat(1) = max(-89.999_8, min(alat(1),89.999_8)) ! avoid centering on poles - alat(:) = 90. - alat(:) ! convert to colatitude -! print 100 -100 format (' cell lat lon dist angl x y') -! print 101,cell(1),alat(1),alon(1),0.,0.,x(1),y(1) -101 format (i8,2f8.2,f8.3,f8.2,2f8.3) - do n=2,ntot - diflon=alon(n)-alon(1) - dist(n)=acosd(cosd(alat(1))*cosd(alat(n)) & - +sind(alat(1))*sind(alat(n))*cosd(diflon)) - arg = max(-1._8, min(1._8, sind(alat(n))*sind(diflon)/sind(dist(n)))) - angl(n)=asind(arg) -! --- determine quadrant by plugging angl=90 into law of cosines - if (cosd(alat(1))*cosd(dist(n)).gt.cosd(alat(n))) then - angl(n)= 180.-angl(n) - end if - x(n)=dist(n)*cosd(angl(n)) - y(n)=dist(n)*sind(angl(n)) -! print 101,cell(n),alat(n),alon(n),dist(n),angl(n),x(n),y(n) - xmin=min(xmin,x(n)) - ymin=min(ymin,y(n)) - xmax=max(xmax,x(n)) - ymax=max(ymax,y(n)) - end do - -! print *,'lat/lon limits:',xmin,xmax,ymin,ymax - -! --- print cluster of icos cell identifiers - - do n=1,ntot - i=1.5+(idm-8.)*(y(n)-ymin)/(ymax-ymin) - j=1.5+(jdm-1.)*(x(n)-xmin)/(xmax-xmin) - iloc(n)=i - jloc(n)=j - write (string,'(i7)') cell(n) - if (cell(n).lt.100000) write (string,'(i6,1x)') cell(n) - if (cell(n).lt.1000 ) write (string,'(i5,2x)') cell(n) - if (cell(n).lt.10 ) write (string,'(i4,3x)') cell(n) - do m=1,7 - map(i+m,j)=string(m:m) - end do - end do - print *, & - '- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -' - print *,'shown below: grid indices' - do j=jdm,1,-1 - print '(2x,75a1)',(map(i,j),i=1,idm) - end do - print *, & - '- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -' - -! --- print cluster of icos cell values - - do k=kfrst,klast,kstep - do n=1,ntot - i=iloc(n) - j=jloc(n) - write (string,'(f7.1)') valu(k,n)*sclfac - do m=1,7 - map(i+m,j)=string(m:m) - end do - end do - if (kdm.eq.1) then - print '(2a)','shown below: ',trim(what) - else - print '(3a,i4)','shown below: ',trim(what),', k =',k - end if - do j=jdm,1,-1 - print '(2x,75a1)',(map(i,j),i=1,idm) - end do - print *, & - '- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -' - end do ! vertical loop - -! print *,'exiting stencl, PrintIpnDiag =',PrintIpnDiag -!!SMS$BARRIER - return - end subroutine stencl -end module stencilprint diff --git a/src/fim/FIMsrc/fim/horizontal/stenedgprint.F90 b/src/fim/FIMsrc/fim/horizontal/stenedgprint.F90 deleted file mode 100644 index 5baf686..0000000 --- a/src/fim/FIMsrc/fim/horizontal/stenedgprint.F90 +++ /dev/null @@ -1,265 +0,0 @@ -module stenedgprint -contains -! -+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ -! stenedg is an offshoot of subroutine stencl. besides displaying grid -! point values associated with cell centers, it displays a second field -! of variables defined on cell edges. Specifically, stenedg displays -! -! (a) 'fld' at the center point (ipn=PrintIpnDiag), -! (b) 'fld' at the 5 or 6 icos points surrounding PrintIpnDiag, -! (c) 'fld_edg' on the 5 or 6 edges of cell PrintIpnDiag. -! -! data are printed at their approximate geographic location relative -! to the center point, with south pointing down. -! -! R.Bleck October 2009 -! -+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ - - subroutine stenedg(fld,fld_edg,kdm,what) - - use module_control, only: nip,npp,PrintIpnDiag, & - stencl_frst,stencl_last,stencl_step - use module_constants,only: deg_lat, deg_lon, nprox, prox, pi - implicit none -! real ,intent(IN) :: sclfac,scl_edg ! scale factors for F fmt printg - integer ,intent(IN) :: kdm - character,intent(IN) :: what*(*) -!SMS$DISTRIBUTE (dh,nip) BEGIN - real, intent(IN) :: fld (kdm ,nip) ! values in cell centers - real, intent(IN) :: fld_edg(kdm,npp,nip) ! values along cell edges -!SMS$DISTRIBUTE END - - integer,parameter :: maxpts=6 -! integer,parameter :: idm=50,jdm=idm/3 ! F format option - integer,parameter :: idm=60,jdm=idm/3 ! E format option - character map(idm,jdm)*1,string*9 - integer edg,i,j,k,m,n,ntot,ipn,ipx,jmin,jmax - real*8 xmin,xmax,ymin,ymax,diflon,arg - real*8 alat(0:maxpts),alon(0:maxpts), & - dist(maxpts),angl(maxpts),x(0:maxpts),y(0:maxpts), & - valu(kdm,0:maxpts),valu_edg(kdm,maxpts) - integer cell(0:maxpts),iloc(0:maxpts),jloc(0:maxpts),cell1(0:maxpts) - integer :: kfrst,kstep,klast - -#if ( defined NEED_SINDCOSD ) -!JR Define required statement functions for situations where -!JR compiler doesn't support them (e.g. gfortran) - real*8 :: val, sind, cosd, asind, acosd - sind(val) = sin(val*pi/180.) - cosd(val) = cos(val*pi/180.) - - asind(val) = (180./pi)*asin(val) - acosd(val) = (180./pi)*acos(val) -#endif - - if (PrintIpnDiag.le.0) return -! print '(3a,i8)','entering stenedg to print ',what,' at ipn =', & -! PrintIpnDiag -!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+- -! --- layers printed are: kfrst, kfrst+kstep, kfrst+2*kstep, ..., klast -!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+- - if (kdm.eq.1) then - kfrst=1 - klast=1 - kstep=1 - else - if (stencl_step.eq.0) return - kfrst=stencl_frst - klast=stencl_last - kstep=stencl_step - end if - -! --- build up inventory of cell indices, starting with center cell - -!SMS$PARALLEL (dh,ipn) BEGIN - alat(:)=-999. - alon(:)=-999. - valu(:,:)=-1.e33 - do ipn=1,nip -!SMS$IGNORE BEGIN - if (ipn.eq.PrintIpnDiag) then - alat(0)=deg_lat(ipn) - alon(0)=deg_lon(ipn) - valu(kfrst:klast,0)=fld(kfrst:klast,ipn) -! print '(a,i3,2f9.2,i9)','lat/lon/ipn of cell',0,alat(0),alon(0),ipn - end if -!SMS$IGNORE END - end do -!SMS$REDUCE (alat,alon,valu,MAX) -!SMS$PARALLEL END - -! --- find lat/lon of first (and only) ring of cells - -!SMS$PARALLEL (dh,ipn) BEGIN -!SMS$EXCHANGE(fld) - ntot=-99 - alat (1:maxpts)=-999. - alon (1:maxpts)=-999. - valu (:,1:maxpts)=-1.e33 - valu_edg(:,1:maxpts)=-1.e33 - do ipn=1,nip -!SMS$IGNORE BEGIN - if (ipn.eq.PrintIpnDiag) then - ntot=0 - do edg=1,nprox(ipn) - ipx=prox(edg,ipn) - ntot=ntot+1 - alat(ntot)=deg_lat(ipx) - alon(ntot)=deg_lon(ipx) - valu(kfrst:klast,ntot)=fld(kfrst:klast,ipx) -! print '(a,i3,2f9.2)','lat/lon of cell',ntot,alat(ntot),alon(ntot) - valu_edg(kfrst:klast,edg)=fld_edg(kfrst:klast,edg,ipn) - end do -! print '(a,i5,es11.2,2f8.2/(i25,es11.2,2f8.2))', & -! 'edge values,lat/lon:',(edg,valu_edg(kfrst,edg),alat(edg), & -! alon(edg),edg=1,nprox(ipn)) - end if -!SMS$IGNORE END - end do -!SMS$REDUCE (ntot,alat,alon,valu,valu_edg,MAX) -!SMS$PARALLEL END - -! --- knowing lat/lon of cells, find their indices - - do n=0,ntot -! print '(a,i3,a,2f9.2)','n =',n,' looking for cell at lat/lon', & -! alat(n),alon(n) - -!SMS$PARALLEL (dh,ipn) BEGIN - cell1(:)=-99 - do ipn=1,nip -!SMS$IGNORE BEGIN - if (deg_lat(ipn).eq.alat(n) .and. deg_lon(ipn).eq.alon(n)) then -! print *,'cell',ipn,' has desired lat/lon' - cell1(n)=ipn - end if -!SMS$IGNORE END - end do -!SMS$REDUCE (cell1,MAX) -!SMS$PARALLEL END - cell(n)=cell1(n) - end do - -! print '(a,i9,a/(i9,2f9.2,f9.1))','adding',ntot,' cells', & -! (cell(n),alat(n),alon(n),valu(kfrst,n),n=1,ntot) - -! --- all cluster points have now been identified - - xmin= 1.e33 - xmax=-1.e33 - ymin= 1.e33 - ymax=-1.e33 - - map(:,:)=' ' -! --- dist = distance (deg) between cell 'PrintIpnDiag' and cell 'n'. -! --- angl = compass heading from cell 'PrintIpnDiag' to cell 'n'. - - x(0)=0. - y(0)=0. - alat(0) = max(-89.999_8, min(alat(0), 89.999_8)) ! avoid centering on poles - alat(:) = 90. - alat(:) ! convert to colatitude -! print 100 -100 format (' cell lat lon dist angl x y') -! print 101,cell(0),alat(0),alon(0),0.,0.,x(0),y(0) -101 format (i8,2f8.2,f8.3,f8.2,2f8.3) - do n=1,ntot - diflon=alon(n)-alon(0) - dist(n)=acosd(cosd(alat(0))*cosd(alat(n)) & - +sind(alat(0))*sind(alat(n))*cosd(diflon)) - arg = max(-1._8, min(1._8, sind(alat(n))*sind(diflon)/sind(dist(n)))) - angl(n)=asind(arg) -! --- determine quadrant by plugging angl=90 into law of cosines - if (cosd(alat(0))*cosd(dist(n)).gt.cosd(alat(n))) then - angl(n)= 180.-angl(n) - end if - x(n)=dist(n)*cosd(angl(n)) - y(n)=dist(n)*sind(angl(n)) -! print 101,cell(n),alat(n),alon(n),dist(n),angl(n),x(n),y(n) - xmin=min(xmin,x(n)) - ymin=min(ymin,y(n)) - xmax=max(xmax,x(n)) - ymax=max(ymax,y(n)) - end do - -! print *,'lat/lon limits:',xmin,xmax,ymin,ymax - -! --- print cluster of icos cell identifiers - - jmin= 999 - jmax=-999 - do n=0,ntot -! i=1.5+(idm-8.)*(y(n)-ymin)/(ymax-ymin) ! F format option - i=1.5+(idm-10.)*(y(n)-ymin)/(ymax-ymin) ! E format option - j=1.5+(jdm-1.)*(x(n)-xmin)/(xmax-xmin) - iloc(n)=i - jloc(n)=j - -! --- to save space, crowd entries around mid point -! i=1.5+(idm-8.)*(.54*y(n)-ymin)/(ymax-ymin) ! F format option - i=1.5+(idm-10.)*(.54*y(n)-ymin)/(ymax-ymin) ! E format option - j=1.5+(jdm-1.)*(.54*x(n)-xmin)/(xmax-xmin) - jmin=min(jmin,j) - jmax=max(jmax,j) - - write (string,'(i7)') cell(n) - if (cell(n).lt.100000) write (string,'(i6,1x)') cell(n) - if (cell(n).lt.1000 ) write (string,'(i5,2x)') cell(n) - if (cell(n).lt.10 ) write (string,'(i4,3x)') cell(n) - do m=1,7 - map(i+m,j)=string(m:m) - end do - end do - print *, & - '- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -' - print *,'shown below: grid indices (compressed stencil)' - do j=jmax,jmin,-1 - print '(2x,75a1)',(map(i,j),i=1,idm) - end do - print *, & - '- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -' - -! --- print cluster of icos cell values - - do k=kfrst,klast,kstep - do n=0,ntot - i=iloc(n) - j=jloc(n) -! write (string,'(f7.1)') valu(k,n)*sclfac ! F format option - write (string,'(es9.2)') valu(k,n) ! E format option -! do m=1,7 ! F format option - do m=1,9 ! E format option - map(i+m,j)=string(m:m) - end do - end do - -! --- print values on icos cell edges - - do n=1,ntot -! i=1.5+(idm-8.)*(.54*y(n)-ymin)/(ymax-ymin) ! F format option - i=1.5+(idm-10.)*(.54*y(n)-ymin)/(ymax-ymin) ! E format option - j=1.5+(jdm-1.)*(.54*x(n)-xmin)/(xmax-xmin) -! write (string,'(f7.1)') valu_edg(k,n)*scl_edg ! F format option - write (string,'(es9.2)') valu_edg(k,n) ! E format option -! do m=1,7 ! F format option - do m=1,9 ! E format option - map(i+m,j)=string(m:m) - end do - end do - - if (kdm.eq.1) then - print '(2a)','shown below: ',trim(what) - else - print '(3a,i4)','shown below: ',trim(what),', k =',k - end if - do j=jdm,1,-1 - print '(2x,75a1)',(map(i,j),i=1,idm) - end do - print *, & - '- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -' - end do ! vertical loop - -! print *,'exiting stenedg, PrintIpnDiag =',PrintIpnDiag -!!SMS$BARRIER - return - end subroutine stenedg -end module stenedgprint diff --git a/src/fim/FIMsrc/fim/horizontal/transp3d.F90 b/src/fim/FIMsrc/fim/horizontal/transp3d.F90 deleted file mode 100644 index 454a05f..0000000 --- a/src/fim/FIMsrc/fim/horizontal/transp3d.F90 +++ /dev/null @@ -1,220 +0,0 @@ -module module_transp3d -!********************************************************************* -! 3-dimensional tracer transport module designed for intermittent -! (i.e., long time step) execution. there are 3 entries: -! -! transp0 - initializes mass flux arrays and saves initial -dp- -! transp1 - builds up time integral of horizontal mass fluxes -! transp2 - performs the actual transport operation - -! R. Bleck March 2009 -!********************************************************************* - use findmaxmin1 - use findmaxmin2 - use stencilprint - -contains - subroutine transp0(its,cumufx,dp3d,dpinit) - use module_control ,only: nvl,npp,nip - - implicit none - integer,intent(IN) :: its ! model time step -!SMS$DISTRIBUTE (dh,nip) BEGIN - real,intent(IN) :: dp3d (nvl, nip) ! layer thickness - real,intent(OUT) :: cumufx(nvl,npp,nip) ! time-integrated mass flux - real,intent(OUT) :: dpinit(nvl, nip) ! dp at start of time integr. -!SMS$DISTRIBUTE END - - -!SMS$PARALLEL (dh,ico) BEGIN - cumufx(:,:,:)=0. - dpinit(:,:)=dp3d(:,:) -!SMS$PARALLEL END - - print *,'tracer transport arrays initialized, time step',its - return - end subroutine transp0 - - - subroutine transp1(its,nf,of,vof,adbash1,adbash2,adbash3, & - cumufx,massfx) - use module_control ,only: nvl,npp,nip - use module_constants,only: nprox,rarea - - implicit none - integer,intent(IN) :: its ! model time step - integer,intent(IN) :: nf,of,vof ! time slots: new,old,very old - real ,intent(IN) :: adbash1,adbash2,adbash3 - -!SMS$DISTRIBUTE (dh,nip) BEGIN - real,intent(IN) :: massfx(nvl,npp,nip,3) - real,intent(INOUT) :: cumufx(nvl,npp,nip) -!SMS$DISTRIBUTE END - integer :: ico ! Index for icos point number - integer :: edg,k - logical :: vrbos - -!SMS$PARALLEL (dh,ico) BEGIN - do ico=1,nip ! horizontal loop - do edg=1,nprox(ico) - do k=1,nvl - cumufx(k,edg,ico)=cumufx(k,edg,ico) & - +adbash1*massfx(k,edg,ico, nf) & - +adbash2*massfx(k,edg,ico, of) & - +adbash3*massfx(k,edg,ico,vof) - end do - end do - end do -!SMS$PARALLEL END - -! print *,'mass fluxes added to time integral, time step',its - return - end subroutine transp1 - - - subroutine transp2 (its, & - tracr,cumufx,dpinit,dpfinl, & - ttransp3d,ttransp3dEx,ttransp3dBa,TimingBarriers ) - - use module_control ,only: nvl,nvlp1,npp,nip,dt,ntra,ntrb,PrintIpnDiag - use module_constants,only: nprox,prox,area,rarea - use module_fct3d - - implicit none -! External variables: - integer,intent (IN) :: its ! model time step -! integer,intent (IN) :: ntr ! number of tracer fields - real*8 ,intent (INOUT) :: ttransp3d ! computation timer - real*8 ,intent (INOUT) :: ttransp3dEx ! halo communication timer - real*8 ,intent (INOUT) :: ttransp3dBa ! barrier timer for task skew - logical,intent (IN) :: TimingBarriers ! measure task skew when .true. -!SMS$DISTRIBUTE (dh,nip) BEGIN - real ,intent (INOUT) :: tracr (nvl,nip,ntra+ntrb) ! tracer - real ,intent (IN) :: cumufx(nvl,npp,nip) ! time-integr. mass flx - real ,intent (IN) :: dpinit(nvl,nip) ! init'l lyr thknss - real ,intent (IN) :: dpfinl(nvl,nip) ! final lyr thknss -! Local variables: - real :: vertfx(nvl,nip),col_xpand(nip) - real :: field(nvl,nip) -!SMS$DISTRIBUTE END - integer :: k ! layer index - integer :: ico ! Index for icos point number - integer :: edg ! icos edge number index - integer :: type ! tracer index - logical :: vrbos - character :: string*32 - real :: hordiv(nvl),vertdv(nvl) - real*8 :: t1,tstart,tstop,valmin,valmax - -!sms$compare_var(tracr , "transp3d.F90 - tracr1 ") -!sms$compare_var(cumufx , "transp3d.F90 - cumufx1 ") - - call StartTimer(t1) - -! --- compute the various terms in the continuity equation integrated -! --- over time interval since last call to -transp0- -! --- the continuity eqn is split into horiz. and vert. terms as follows: -! --- (dpfinl-dpinit) + hordiv + verdiv = 0 - -!SMS$EXCHANGE(cumufx,dpinit,dpfinl) - -!SMS$PARALLEL (dh,ico) BEGIN -!SMS$HALO_COMP(<1,1>) BEGIN - do ico=1,nip ! horizontal loop - vrbos=ico.eq.PrintIpnDiag - hordiv (: )=0. - col_xpand( ico)=0. - vertfx (:,ico)=0. - - do edg=1,nprox(ico) ! loop through edges - do k=1,nvl ! loop through layers - hordiv(k)=hordiv(k)+cumufx(k,edg,ico) - end do - end do - - do k=1,nvl ! loop through layers - col_xpand(ico)=col_xpand(ico)+hordiv(k) - vertdv(k)=(dpinit(k,ico)-dpfinl(k,ico))-hordiv(k)*rarea(ico) - if (k.eq.1) then - vertfx(k,ico)= vertdv(k) - else - vertfx(k,ico)=vertfx(k-1,ico)+vertdv(k) - end if - - if (vrbos) then -!SMS$ignore begin - write (*,'(i7,i3,a,3es12.4)') ico,k, & - ' transp2 hordiv,col_xpand,vertfx:',hordiv(k)*rarea(ico), & - col_xpand(ico)*rarea(ico),vertfx(k,ico) - call flush(6) -!SMS$ignore end - end if - - end do - end do ! horizontal loop -!SMS$HALO_COMP END -!SMS$PARALLEL END - -! call findmxmn1(col_xpand,nip,'col_xpand') -! do k=1,nvl,7 -! write (string,'(a,i3,a)') 'lyr',k,' vertfx' -! call findmxmn2(vertfx,nvl,nip,k,string) -! end do -! print * -! call flush(6) - -! --- having determined the vertical flux term in the time-integrated -! --- continuity eqn, we can now perform the actual tracer transport - - if (ntrb.gt.0) then - - do type=1,ntrb ! loop over class B tracers -!SMS$PARALLEL (dh,ico) BEGIN - do ico=1,nip - do k=1,nvl - field(k,ico)=tracr(k,ico,ntra+type) - end do - end do -!SMS$PARALLEL END - - write (string,'(a,i6,a,i2,a)') '(transp2) step',its,' trcr',type,' in' - call stencl(field,nvl,1.,trim(string)) - end do ! loop over tracers - - call StartTimer(tstart) - - call fct3d(tracr,ntra+ntrb,ntra+1,ntra+ntrb,cumufx,vertfx, & - area,rarea,dpinit,dpfinl,.false.) - - tstop=0 - call IncrementTimer(tstart,tstop) - valmin=tstop*1.e3 - valmax=valmin -!SMS$REDUCE(valmin,MIN) -!SMS$REDUCE(valmax,MAX) - print '(a,i2,a,2(i7,a))','time spent in subr fct3d (',ntrb, & - ' tracers)',nint(valmin),' -',nint(valmax),' msec' - - do type=1,ntrb ! loop over class B tracers -!SMS$PARALLEL (dh,ico) BEGIN - do ico=1,nip - do k=1,nvl - field(k,ico)=tracr(k,ico,ntra+type) - end do - end do -!SMS$PARALLEL END - - write (string,'(a,i6,a,i2,a)') '(transp2) step',its,' trcr',type,' out' - call stencl(field,nvl,1.,trim(string)) - end do ! loop over tracers - - end if ! ntrb > 0 - -!sms$compare_var(tracr , "transp3d.F90 - tracr2 ") -!sms$compare_var(cumufx , "transp3d.F90 - cumufx2 ") - - call IncrementTimer(t1,ttransp3d) - - return - end subroutine transp2 -end module module_transp3d diff --git a/src/fim/FIMsrc/fim/horizontal/trcadv.F90 b/src/fim/FIMsrc/fim/horizontal/trcadv.F90 deleted file mode 100644 index 8c9fa08..0000000 --- a/src/fim/FIMsrc/fim/horizontal/trcadv.F90 +++ /dev/null @@ -1,406 +0,0 @@ -module module_trcadv -use stencilprint -use findmaxmin2 -use findmaxmin1 -contains -!********************************************************************* -! trcadv -! trcadv = flux corrected transport for mass field tracers -! J. Lee Author September 2005 -! A. E. MacDonald Documentor November 2005 -! R. Bleck major rewrite April 2008 -! R. Bleck fixed bug in high-order flux April 2011 -! -! This routine is based on Zalesak, JOURNAL OF COMPUTATIONAL -! PHYSICS, 31, 335-362, 1979. Dale Durran provides an -! excellent discussion of flux corrected transport in his book -! NUMERICAL METHODS FOR WAVE EQUATIONS IN GEOPHYSICAL FLUID DYNAMICS. -!********************************************************************* - - subroutine trcadv (its,nf,of,vof,adbash1,adbash2,adbash3, & - trcr_edg,tracr,trcdp,trc_tdcy,trclo_tdcy,massfx,delp, & - ttrcadv,ttrcadvEx,ttrcadvBa,TimingBarriers ) - -use module_control ,only: nvl,npp,nip,nabl,dt,ntra,nd,PrintIpnDiag -use module_constants,only: nprox,prox,proxs,rarea,area, & - nedge,permedge -implicit none - -!.............................................................. -! Sec. 0 Dimension and Type -!.............................................................. - -! External variables: - integer,intent (IN) :: its ! model time step - integer,intent (IN) :: nf,of,vof ! time slots: new,old,very old - real ,intent (IN) :: adbash1,adbash2,adbash3 - real*8 ,intent (INOUT) :: ttrcadv ! computation timer - real*8 ,intent (INOUT) :: ttrcadvEx ! halo update communication timer - real*8 ,intent (INOUT) :: ttrcadvBa ! barrier timer for task skew - logical,intent (IN) :: TimingBarriers ! measure task skew when .true. -!SMS$DISTRIBUTE (dh,nip) BEGIN - real ,intent (IN) :: trcr_edg (nvl,npp,nip,ntra) - real ,intent (INOUT) :: tracr (nvl,nip,ntra) - real ,intent (INOUT) :: trcdp (nvl,nip,ntra) - real ,intent (INOUT) :: trc_tdcy (nvl,nip,nabl,ntra) - real ,intent (INOUT) :: trclo_tdcy (nvl,nip,nabl,ntra) - real ,intent (IN) :: massfx (nvl,npp,nip,3) - real ,intent (IN) :: delp (nvl,nip) -! Local variables: - real :: s_plus(nvl,nip) ! Zalesak's p_plus - real :: s_mnus(nvl,nip) ! Zalesak's p_minus - real :: r_plus(nvl,nip) ! Zalesak's r_plus - real :: r_mnus(nvl,nip) ! Zalesak's r_minus - real :: trcr_lo(nvl,nip) ! tracer after low-order transport - real :: antiflx(nvl,npp,nip) ! antidiffusive tracer flux - real :: trcdp_lo(nvl,nip) ! tracer*dp after low-order transport - real :: trmax(nvl,nip) ! regional tracer max for flux clipping - real :: trmin(nvl,nip) ! regional tracer min for flux clipping - real :: anti_tdcy(nvl,nip,ntra)! antidiff trcr tendency - real :: flxlo(nvl,npp,nip) ! tracer flux, low order - real :: q_plus(nip) ! Zalesak's q_plus - real :: q_mnus(nip) ! Zalesak's q_minus -!SMS$DISTRIBUTE END - - integer :: k ! layer index - integer :: ipn ! icos point number index - integer :: edg ! icos edge number index - integer :: type ! tracer index (1=theta; 2=specif.hum., ...) - real :: del_dp ! delta_p used for upstream integral of flux - real :: flxhi ! tracer flux, high order - integer :: ipx ! neighbor across joint edge - integer :: edx ! neighbor's index of joint edge - integer :: edgcount ! count of icos edges - character :: string*32 - real,parameter :: thshld = 1.e-11 - logical,parameter :: low_ord = .false. ! if true, skip antidiffusive part - real*8 :: t1 - -!............................................................. -! Sec. 1 Calculate Low and Antidiffusive Flux -!............................................................. - -! Calculates the FCT low and high order fluxes, and defines -! the antidiffusive flux as the difference between the high and -! low order fluxes. The low order flux is computed based on -! the assumption of piecewise continuity, with a constant value -! in each cell. The higher order uses the "gazebo" with a -! sloped line used for the flux integral. - -! Avoid exchange via HALO_COMP in cnuity.F90 and edgvar.F90 -!!!SMS$EXCHANGE(massfx,trcr_edg) -!!SMS$EXCHANGE(tracr) exchanged in edgvar - -!sms$compare_var(tracr , "trcadv.F90 - tracr1 ") -!sms$compare_var(massfx , "trcadv.F90 - massfx1 ") -!sms$compare_var(trc_tdcy, "trcadv.F90 - trc_tdcy1 ") -!sms$compare_var(trcr_edg, "trcadv.F90 - trcr_edg1 ") - - call StartTimer(t1) - -!! do k=1,nvl,7 -!! write (string,'(a,i3,a)') 'k',k,' trcadv:theta' -!! call findmxmn3(tracr,nvl,nip,ntra,k,1,string) -!! end do -!! print * - - write (string,'(a,i7)') '(atm trcadv) step',its - call stencl(tracr,nvl,1.,trim(string)//', old theta') - - trclo_tdcy(:,:,nf,:)=0. - trc_tdcy (:,:,nf,:)=0. - anti_tdcy (:,:, :)=0. - - ! Initialize these local arrays so COMPARE_VAR does not get - ! confused by uninitialized edg=6 edges of pentagonal grid cells. This - ! code could be safely omitted if COMPARE_VAR were not used. - antiflx(:,npp,:) = 0. - - do type=1,ntra ! loop through tracers - -!SMS$PARALLEL (dh,ipn) BEGIN -!SMS$HALO_COMP(<1,1>) BEGIN - do ipn=1,nip ! horizontal loop - do edgcount=1,nedge(ipn) ! loop through edges - edg = permedge(edgcount,ipn) - ipx=prox(edg,ipn) ! neighbor across edge - edx=proxs(edg,ipn) ! index of joint edge as seen by neighbor - - do k=1,nvl ! loop through layers - -! --- high-order tracer flux (2nd order centered, out of cell > 0): - flxhi=massfx(k,edg,ipn,nf)*trcr_edg(k,edg,ipn,type) ! trcdim x N/s - -! --- low-order tracer flux (donor-cell, out of cell > 0): - flxlo(k,edg,ipn)=0.5*( & - (massfx(k,edg,ipn,nf)+abs(massfx(k,edg,ipn,nf))) & - *tracr (k,ipn,type) & - - (massfx(k,edx,ipx,nf)+abs(massfx(k,edx,ipx,nf))) & - *tracr (k,ipx,type) ) - - ! get anti-diffusive flux as the difference between high order - ! (flxhi) and low order flux (flxlo), from Zalesak, p336, Eqn (3): - - antiflx(k,edg,ipn)=flxhi-flxlo(k,edg,ipn) ! trcdim x N/sec - - end do ! loop through layers - end do ! loop through edges - end do ! horizontal loop -!SMS$HALO_COMP END - - do ipn=1,nip ! horizontal loop - do edg=1,nprox(ipn) ! loop through edges - do k=1,nvl ! loop through layers - - ! sum up edge fluxes to get low-order tracer tendency - trclo_tdcy(k,ipn,nf,type)=trclo_tdcy(k,ipn,nf,type)+flxlo(k,edg,ipn) - - end do ! loop through layers - end do ! loop through edges - - !..................................................................... - ! Sec. 2. Calculate new low order trcr*dp using full Adams Bashforth - !..................................................................... - - do k=1,nvl ! loop through layers - - ! divide tendency by cell area to convert to (trcdim x Pa/sec) - trclo_tdcy(k,ipn,nf,type)=-trclo_tdcy(k,ipn,nf,type)*rarea(ipn) - - ! get new value for the low order tracer*dp field using Adams Bashforth - ! 3 time levels, the one just calculated (nf), and the two prev ones, - ! marked of (old field) and vof (very old field): - - trcdp_lo(k,ipn) = trcdp(k,ipn,type) & - +adbash1*trclo_tdcy(k,ipn, nf,type) & - +adbash2*trclo_tdcy(k,ipn, of,type) & - +adbash3*trclo_tdcy(k,ipn,vof,type) - - ! set upper/lower bounds for ratio of trcdp_lo and delp - trmax(k,ipn)=max(tracr(k,ipn,type), & - tracr(k,prox(1,ipn),type),tracr(k,prox(2,ipn),type), & - tracr(k,prox(3,ipn),type),tracr(k,prox(4,ipn),type), & - tracr(k,prox(5,ipn),type),tracr(k,prox(6,ipn),type) ) - - trmin(k,ipn)=min(tracr(k,ipn,type), & - tracr(k,prox(1,ipn),type),tracr(k,prox(2,ipn),type), & - tracr(k,prox(3,ipn),type),tracr(k,prox(4,ipn),type), & - tracr(k,prox(5,ipn),type),tracr(k,prox(6,ipn),type) ) - - trmax(k,ipn)=max(0.,trmax(k,ipn)) ! cannot allow negative trmax - trmin(k,ipn)=max(0.,trmin(k,ipn)) ! cannot allow negative trmin - - ! now divide trcdp_lo by delp to get new low order tracer field - trcr_lo(k,ipn)=max(trmin(k,ipn),min(trmax(k,ipn), & - trcdp_lo(k,ipn)/max(thshld,delp(k,ipn)) )) - - end do ! loop through layers - end do ! horizontal loop - - if (low_ord) then - - tracr(:,:,type) = trcr_lo(:,:) - - else ! evaluate and apply antidiffusive fluxes - - ! Dale Durran's book indicates that condition Zal (14) should be - ! satisfied, although Zalesak says it's cosmetic. We believe Dale: - ! Also Calculate s_plus Zalesak (7) and s_minus Zalesak (10). - ! (aggregate of incoming and outgoing fluxes, trcdim x N/sec) - - s_plus=0. - s_mnus=0. - - call IncrementTimer(t1,ttrcadv) - - if (TimingBarriers) then - call StartTimer(t1) -!SMS$BARRIER - call IncrementTimer(t1,ttrcadvBa) - endif - - call StartTimer(t1) -!SMS$EXCHANGE(trcr_lo) - call IncrementTimer(t1,ttrcadvEx) - - call StartTimer(t1) - - do ipn=1,nip ! horizontal loop - do edg=1,nprox(ipn) ! loop through edges - do k=1,nvl ! loop through layers - if(antiflx(k,edg,ipn).le.0.) then ! flux into cell - s_plus(k,ipn)=s_plus(k,ipn)-antiflx(k,edg,ipn) - else ! flux out-of cell - s_mnus(k,ipn)=s_mnus(k,ipn)+antiflx(k,edg,ipn) - endif - end do ! loop through layers - end do ! loop through edges - - !............................................................ - ! Sec 3. Monotonicity Limit on Fluxes - !............................................................ - - ! Determine the amount of antidiffusive fluxes that can be - ! added to the low order solution without violating monotonicity. - - do k=1,nvl ! loop through layers - - ! According to Zal (17), we must limit according to max of - ! tracer from any gazebo direction, in either current or prev time - ! step. Likewise for the minimum. - ! For the pentagons prox(6,ipn) is set to prox(5,ipn) in init.F90. - - ! relax upper/lower bounds by incorporating new low-order field - trmax(k,ipn)=max(trmax(k,ipn),trcr_lo(k,ipn), & - trcr_lo(k,prox(1,ipn)),trcr_lo(k,prox(2,ipn)), & - trcr_lo(k,prox(3,ipn)),trcr_lo(k,prox(4,ipn)), & - trcr_lo(k,prox(5,ipn)),trcr_lo(k,prox(6,ipn)) ) - - trmin(k,ipn)=min(trmin(k,ipn),trcr_lo(k,ipn), & - trcr_lo(k,prox(1,ipn)),trcr_lo(k,prox(2,ipn)), & - trcr_lo(k,prox(3,ipn)),trcr_lo(k,prox(4,ipn)), & - trcr_lo(k,prox(5,ipn)),trcr_lo(k,prox(6,ipn)) ) - - trmax(k,ipn)=max(0.,trmax(k,ipn)) ! cannot allow negative trmax - trmin(k,ipn)=max(0.,trmin(k,ipn)) ! cannot allow negative trmin - - ! q_plus/q_mnus are the upper/lower limits on antidiff trcr tendencies, - ! dimensioned trdim x N/sec - - ! q_plus is Zalesak (8): - q_plus(ipn) = ((trmax(k,ipn)-trcr_lo(k,ipn))*delp(k,ipn) & - -(adbash2*min(0.,trc_tdcy(k,ipn, of,type)) & - + adbash3*max(0.,trc_tdcy(k,ipn,vof,type)))) & - /adbash1*(area(ipn)) - - ! q_mnus is Zalesak (11): - q_mnus(ipn) = ((trcr_lo(k,ipn)-trmin(k,ipn))*delp(k,ipn) & - +(adbash2*max(0.,trc_tdcy(k,ipn, of,type)) & - + adbash3*min(0.,trc_tdcy(k,ipn,vof,type)))) & - /adbash1*(area(ipn)) - - ! Having s_plus(k,ipn) and q_plus, we can calc r_plus, Zal (9): - - ! reduce fluxes to stay within limits posed by q_plus/q_mnus - ! r_plus/r_mnus are dimensionless - - r_plus(k,ipn)=max(0.,min(1.,q_plus(ipn)/max(s_plus(k,ipn),thshld))) - r_mnus(k,ipn)=max(0.,min(1.,q_mnus(ipn)/max(s_mnus(k,ipn),thshld))) - -!! if (ipn.eq.PrintIpnDiag) then -!!!SMS$IGNORE BEGIN -!! print '(2i7,2i3,a/7es11.3)',its,ipn,k,type,' q_plus etc:', & -!! q_plus(ipn),trmax(k,ipn),trcr_lo(k,ipn),delp(k,ipn), & -!! - adbash2*min(0.,trc_tdcy(k,ipn, of,type)), & -!! - adbash3*max(0.,trc_tdcy(k,ipn,vof,type)), & -!! adbash1 -!! print '(2i7,2i3,a/7es11.3)',its,ipn,k,type,' q_mnus etc:', & -!! q_mnus(ipn),trcr_lo(k,ipn),trmin(k,ipn),delp(k,ipn), & -!! + adbash2*max(0.,trc_tdcy(k,ipn, of,type)), & -!! + adbash3*min(0.,trc_tdcy(k,ipn,vof,type)), & -!! adbash1 -!!!SMS$IGNORE END -!! end if - - end do ! loop through layers - end do ! horizontal loop - -! do k=1,nvl,7 -! write (string,'(a3,i3)') ' k=',k -! call findmxmn2(r_plus,nvl,nip,k,'(trcadv) r_plus'//string(1:6)) -! call findmxmn2(r_mnus,nvl,nip,k,'(trcadv) r_mnus'//string(1:6)) -! end do -! call stencl(r_plus,nvl,1000.,'(trcadv) r_plus x 1000') -! call stencl(r_mnus,nvl,1000.,'(trcadv) r_mnus x 1000') - - ! Now we have a flux limiter that will assure monotonicity. - ! Next, we do the clipping. - - !....................................................... - ! Sec. 4. Flux Clipping - !....................................................... - - ! As explained by Durran, once you have the r_plus and - ! r_mnus over the whole grid, you can assure that the clipping - ! can be done so that it does not cause a problem in the center - ! cell, NOR IN ANY OF THE NEIGHBORING CELLS. The clipping - ! is from Zalesak (13): - - call IncrementTimer(t1,ttrcadv) - - if (TimingBarriers) then - call StartTimer(t1) -!SMS$BARRIER - call IncrementTimer(t1,ttrcadvBa) - endif - - call StartTimer(t1) -!SMS$EXCHANGE(r_plus,r_mnus) - call IncrementTimer(t1,ttrcadvEx) - -!sms$compare_var(s_plus , "trcadv.F90 - s_plus4 ") -!sms$compare_var(s_mnus , "trcadv.F90 - s_mnus4 ") -!sms$compare_var(r_plus , "trcadv.F90 - r_plus4 ") -!sms$compare_var(r_mnus , "trcadv.F90 - r_mnus4 ") -!sms$compare_var(antiflx , "trcadv.F90 - antiflx4 ") -!sms$compare_var(trcr_lo , "trcadv.F90 - trcr_lo3 ") - - call StartTimer(t1) - - do ipn=1,nip ! horizontal loop - do edg=1,nprox(ipn) ! loop through edges - do k=1,nvl ! loop through layers - - if (antiflx(k,edg,ipn).ge.0.) then ! outgoing - antiflx(k,edg,ipn) = antiflx(k,edg,ipn) & - * min(r_mnus(k,ipn),r_plus(k,prox(edg,ipn))) - else ! incoming - antiflx(k,edg,ipn) = antiflx(k,edg,ipn) & - * min(r_plus(k,ipn),r_mnus(k,prox(edg,ipn))) - end if - - ! sum up edge fluxes to get antidiff tracer tendency - anti_tdcy(k,ipn,type)=anti_tdcy(k,ipn,type)+antiflx(k,edg,ipn) - - end do ! loop through layers - end do ! loop through edges - - do k=1,nvl ! loop through layers - - ! divide tendency by cell area to convert to trcdim x Pa/sec - anti_tdcy(k,ipn, type)=-anti_tdcy(k,ipn, type)*rarea(ipn) - - ! combine low order with clipped antidiff tendency - trc_tdcy(k,ipn,nf,type)=trclo_tdcy(k,ipn,nf,type) & - + anti_tdcy(k,ipn, type) - - ! advance (tracer x thickness) field in time - trcdp(k,ipn,type) = trcdp(k,ipn,type) & - +adbash1*trc_tdcy(k,ipn, nf,type) & - +adbash2*trc_tdcy(k,ipn, of,type) & - +adbash3*trc_tdcy(k,ipn,vof,type) - - ! finally divide new trcr*dp by new delp to get new tracer field - tracr(k,ipn,type)=max(trmin(k,ipn),min(trmax(k,ipn), & - trcdp(k,ipn,type)/max(thshld,delp(k,ipn)) )) - - end do ! loop through layers - end do ! horizontal loop - - end if ! low_ord = true or false -!SMS$PARALLEL END - end do ! loop through tracers - - write (string,'(a,i7)') '(atm trcadv) step',its - call stencl(tracr,nvl,1.,trim(string)//', new theta') - - call IncrementTimer(t1,ttrcadv) - -!sms$compare_var(antiflx , "trcadv.F90 - antiflx5 ") -!sms$compare_var(trcdp_lo , "trcadv.F90 - trcdp_lo5") -!sms$compare_var(trcdp , "trcadv.F90 - trcdp5 ") -!sms$compare_var(trclo_tdcy, "trcadv.F90 - trclo_tdcy5 ") - - return -end subroutine trcadv -end module module_trcadv diff --git a/src/fim/FIMsrc/fim/horizontal/wrf_error_fatal.F90 b/src/fim/FIMsrc/fim/horizontal/wrf_error_fatal.F90 deleted file mode 100644 index 8bccf27..0000000 --- a/src/fim/FIMsrc/fim/horizontal/wrf_error_fatal.F90 +++ /dev/null @@ -1,10 +0,0 @@ - -!TODO: move this into a wrf-specific directory - - subroutine wrf_error_fatal(msg) - implicit none - character,intent(IN) :: msg*(*) - write(0,*) 'Fatal error: ',TRIM(msg) - stop - end subroutine wrf_error_fatal - diff --git a/src/fim/FIMsrc/fim/horizontal/wrf_output.F90 b/src/fim/FIMsrc/fim/horizontal/wrf_output.F90 deleted file mode 100644 index b6fde18..0000000 --- a/src/fim/FIMsrc/fim/horizontal/wrf_output.F90 +++ /dev/null @@ -1,77 +0,0 @@ -module module_wrf_output - -contains - - subroutine wrf_output(its,nts,pr3d,tk3d,tr,phys2dwrf) - - use module_constants,only:rd - use module_control,only:ArchvStep,ArchvTimeUnit,dt,filename_len,nip,ntra,& - ntrb,nvl,nvlp1 -!sms$ignore begin - use icosio,only:icosio_out - use module_initial_chem_namelists -!sms$ignore end - use module_wrf_control,only:num_chem,num_moist,nvl_gocart,nvl_gocart - use module_header,only:header - - integer,intent(in)::its,nts -!sms$distribute (dh,nip) begin - real,intent(in)::& - pr3d(nvlp1,nip),& - tk3d(nvl,nip),tr(nvl,nip,ntra+ntrb) - real:: qcct(nvl,nip),qict(nvl,nip),qrct(nvl,nip),qsct(nvl,nip),& - rho_phys(nvl,nip),sea1(nvl,nip),sea2(nvl,nip),sea3(nvl,nip),sea4(nvl,nip),& - trco(nvl,nip) -!sms$distribute end -!sms$distribute(dh,1) begin - real,intent(in)::phys2dwrf(:,:) ! (nip,:) -!sms$distribute end - integer::ichem_start,imoist_start,j,k - real::dpsum - character(len=filename_len)::filename - integer::its2time - integer::time - - if (mod(its,ArchvStep)==0.or.(its==nts.and.ArchvTimeUnit.eq.'ts')) then - - time=its2time(its) - - ichem_start=ntra+1 - imoist_start=ntra - -!SMS$IGNORE BEGIN -!TBH: Added this IGNORE to work around a PPP core dump between here and -!TBH: "SMS$IGNORE END". Mark Govett is investigating... - - if ((.not.mp_physics==0).or.(.not.cu_physics==0)) then - trco(:,:) = 0. -! trco(:,:) = tr(:,:,5) - trco(1,:) = phys2dwrf(:,1) - trco(2,:) = phys2dwrf(:,2) - trco(3,:) = phys2dwrf(:,3) - trco(4,:) = phys2dwrf(:,4) - trco(5,:) = phys2dwrf(:,5) - trco(6,:) = phys2dwrf(:,6) - endif - if (mp_physics == 2) then - qcct(:,:) = tr(:,:,imoist_start+p_qc) - qrct(:,:) = tr(:,:,imoist_start+p_qr) - qict(:,:) = tr(:,:,imoist_start+p_qi) - qsct(:,:) = tr(:,:,imoist_start+p_qs) - endif -!SMS$IGNORE END - - if (mp_physics.eq.2) then - call icosio_out(its,time,'qcct',qcct,nvl,filename('qcct',its),header('qcct',nvl,its)) - call icosio_out(its,time,'qrct',qrct,nvl,filename('qrct',its),header('qrct',nvl,its)) - call icosio_out(its,time,'qict',qict,nvl,filename('qict',its),header('qict',nvl,its)) - call icosio_out(its,time,'qsct',qsct,nvl,filename('qsct',its),header('qsct',nvl,its)) - endif - if ((mp_physics.ne.0).or.(cu_physics.ne.0)) then - call icosio_out(its,time,'trco',trco,nvl,filename('trco',its),header('trco',nvl,its)) - endif - endif - - end subroutine wrf_output - -end module module_wrf_output diff --git a/src/fim/FIMsrc/fim/horizontal/wrf_phy_finalize.F90 b/src/fim/FIMsrc/fim/horizontal/wrf_phy_finalize.F90 deleted file mode 100644 index a764b0c..0000000 --- a/src/fim/FIMsrc/fim/horizontal/wrf_phy_finalize.F90 +++ /dev/null @@ -1,22 +0,0 @@ -module module_fim_wrf_phy_finalize -contains -!********************************************************************* -subroutine wrf_phy_finalize -! Finish the WRF physics component. -! T. Henderson April, 2008 -!********************************************************************* - - use module_outtime_wrf_phy,only: OutTime - use module_control ,only: PrintMAXMINtimes - use module_initial_chem_namelists, only: cu_physics, mp_physics - - implicit none - - ! print elapsed times for WRF physics - if ((.not.mp_physics==0).or.(.not.cu_physics==0)) then - call OutTime(PrintMAXMINtimes) - endif - - return -end subroutine wrf_phy_finalize -end module module_fim_wrf_phy_finalize diff --git a/src/fim/FIMsrc/fim/horizontal/wrf_phy_init.F90 b/src/fim/FIMsrc/fim/horizontal/wrf_phy_init.F90 deleted file mode 100644 index 397c47f..0000000 --- a/src/fim/FIMsrc/fim/horizontal/wrf_phy_init.F90 +++ /dev/null @@ -1,134 +0,0 @@ -module module_wrf_phy_init - -contains - - subroutine wrf_phy_init -!********************************************************************* -! Loads the initial variables and constants for the WRF physics -! component. -!********************************************************************* - - use module_control ,only: nvl,nip - use module_wrf_control,only: ids,ide,jds,jde,kds,kde, & - ims,ime,jms,jme,kms,kme, & - its,ite,jts,jte,kts,kte - use module_wrfphysvars - use module_wrfphys_alloc,only: wrfphys_alloc - use module_wrf_share ,only: wrf_set_array_bounds - use module_wrf_variables,only: phys3dwrf,phys2dwrf,exch,pb2d - -!TODO: clean up duplication in these modules and add "only" -! for chemistry and WRF physics namelists: - use module_chem_namelist_defaults -! contains config_flags - use module_initial_chem_namelists !, only: cu_physics, mp_physics -! TBH: Ignore these so PPP doesn't have to translate them -!SMS$ignore begin - use module_cu_gd ,only: gdinit - use module_species_decs - use module_set_wrfphys - use units, only: getunit, returnunit -!SMS$ignore end - - implicit none - -! Local variables - character(64) :: filename - real*8 :: t0,t1=0.0d0 - integer :: unitno ! Unit number for I/O - -!SMS$insert integer :: mype - -!SMS$insert call nnt_me(mype) - - call StartTimer(t0) - - call wrf_set_array_bounds(nvl,nip, & - ids,ide,jds,jde,kds,kde, & - ims,ime,jms,jme,kms,kme, & - its,ite,jts,jte,kts,kte) - print *,'start reading WRF physics namelists' - filename='./FIMnamelist' - print *,'set wrfphys namelists' - call set_wrfphys_namelist_defaults - unitno = getunit () - if (unitno < 0) then - print*,'wrf_phy_init: getunit failed. Stopping' - stop - end if - - open (unitno, file=filename, form='formatted', action='read', err=70) - read (unitno, wrfphysics, err=90) - print *,'read wrfphys, cu_phys, mp_physics = ',cu_physics,mp_physics - close(unitno) - - open (unitno, file=filename, form='formatted', action='read', err=70) - read (unitno, chemwrf, err=90) - print *,'read chem, chem_opt = ',chem_opt - close(unitno) - call returnunit (unitno) - - if (chem_opt == 0 .and. mp_physics == 0 .and. cu_physics == 0) return - config_flags%mp_physics = mp_physics - config_flags%cu_physics = cu_physics - call set_wrfphys (mp_physics) -! -! we need the wrfphys variables for wrfchem -! - if ((.not.mp_physics==0).or.(.not.cu_physics==0).or.(.not.chem_opt==0)) then - write(0,*)'allocatewrfphys variables' - call wrfphys_alloc - end if ! if ((.not.mp_physics==0).or.(.not.cu_physics==0)) then -!TODO: move to wrfphys_alloc() ?? -!TODO: avoid allocation when these variables are not used - allocate( exch(nvl,nip)) ! - exch = 0. - allocate( pb2d(nip)) ! - pb2d = 0. - allocate( phys3dwrf(nvl,nip,11)) ! WRF Physics diagnostic variable to store tendencies for microphys and cu - ! 1 = rqvcu - ! 2 = rqvbl - ! 3 = rqvf - ! 4 = rthcu - ! 5 = rthbl - ! 6 = rthra - ! 7 = rthf - ! 8 = rqccu - ! 9 = rqrcu - ! 10 = rqscu - ! 11 = rqicu - allocate( phys2dwrf(nip,8)) ! Physics diagnostic variable - - phys3dwrf = 0. - phys2dwrf = 0. - - if (.not.cu_physics==0) then -!TODO: this really only applies to GD cumulus scheme -- improve "if" -!TOD: logic and generalize call - CALL gdinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN, & - MASS_FLUX,1004.6855,.false., & - 0,0,0, & - RTHFTEN, RQVFTEN, & - APR_GR,APR_W,APR_MC,APR_ST,APR_AS, & - APR_CAPMA,APR_CAPME,APR_CAPMI, & - .false., & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte ) - endif - - call IncrementTimer(t0,t1) - print"(' WRF PHYSICS INIT time:',F10.0)",t1 - - return - -70 write(6,*)'wrf_phy_init: error opening unit=', unitno, '. Stopping' - call flush(6) - stop - -90 write(6,*)'wrf_phy_init: error reading from unit=', unitno, '. Stopping' - call flush(6) - stop - - end subroutine wrf_phy_init -end module module_wrf_phy_init diff --git a/src/fim/FIMsrc/fim/horizontal/wrf_phy_run.F90 b/src/fim/FIMsrc/fim/horizontal/wrf_phy_run.F90 deleted file mode 100644 index abeee38..0000000 --- a/src/fim/FIMsrc/fim/horizontal/wrf_phy_run.F90 +++ /dev/null @@ -1,46 +0,0 @@ -module module_wrf_phy_run -contains -!********************************************************************* - subroutine wrf_phy_run(its) -! "Run" method for WRF physics -!********************************************************************* - -use module_control ,only: nts, itsStart -use module_wrfphysics ,only: wrf_physics -use module_outtime_wrf_phy ,only: telapsed=>tphy -use module_initial_chem_namelists, only: cu_physics, mp_physics - -implicit none - -! Declare dummy arguments -integer, intent(in) :: its - -! Declare local variables: -real*8 :: t0 - -call StartTimer(t0) - - !........................................................... - ! Advance the physics component by one time step unless this - ! is the last (nts+1) iteration. - ! This complexity is required for the NCEP ESMF approach - ! in which single-phase DYN and PHY components alternate - ! execution during each time step. - ! -if (its < itsStart+nts) then - - !........................................................... - ! call WRF phyics - !........................................................... - if ((.not.mp_physics==0).or.(.not.cu_physics==0)) then -! write(6,*)'call wrfphysics ',mp_physics,cu_physics - call wrf_physics(its) - endif - -endif - -call IncrementTimer(t0,telapsed) - -return -end subroutine wrf_phy_run -end module module_wrf_phy_run diff --git a/src/fim/FIMsrc/fim/horizontal/wrf_share.F90 b/src/fim/FIMsrc/fim/horizontal/wrf_share.F90 deleted file mode 100644 index 4ebc97f..0000000 --- a/src/fim/FIMsrc/fim/horizontal/wrf_share.F90 +++ /dev/null @@ -1,62 +0,0 @@ -! Routines shared between WRF physics and chemistry. - -module module_wrf_share - -contains - - -!********************************************************************* -subroutine wrf_set_array_bounds(nvl,nip, & - ids,ide,jds,jde,kds,kde, & - ims,ime,jms,jme,kms,kme, & - its,ite,jts,jte,kts,kte) -! Sets up WRF domain, memory, and tile bounds. -! Tom Henderson July, 2009 -!********************************************************************* - - implicit none - - ! Dummy arguments - integer, intent(in ) :: nvl,nip - integer, intent( out) :: ids,ide,jds,jde,kds,kde - integer, intent( out) :: ims,ime,jms,jme,kms,kme - integer, intent( out) :: its,ite,jts,jte,kts,kte - - ! locals -!SMS$DISTRIBUTE (dh,nip) BEGIN - integer :: itmp(nip) -!SMS$DISTRIBUTE END - - ! set up trivial indices - ims = 1 - ime = 1 - ids = 1 - ide = 1 - its = 1 - ite = 1 - jds = 1 - kms = 1 - kds = 1 - kts = 1 - - ! set up non-parameter indices - jde = nip ! domain end in decomposed dimension -!SMS$PARALLEL (dh,j) BEGIN -!SMS$TO_LOCAL (<1,jds:lbound>, <1,jde:ubound>) BEGIN - jts = jds - jte = jde -!SMS$TO_LOCAL END -!SMS$PARALLEL END - jms = LBOUND(itmp,1) - jme = UBOUND(itmp,1) - kme = nvl+1 - kde = nvl+1 - kte = nvl - - return - -end subroutine wrf_set_array_bounds - - -end module module_wrf_share - diff --git a/src/fim/FIMsrc/fim/horizontal/wrfphys_alloc.F90 b/src/fim/FIMsrc/fim/horizontal/wrfphys_alloc.F90 deleted file mode 100644 index 16f1639..0000000 --- a/src/fim/FIMsrc/fim/horizontal/wrfphys_alloc.F90 +++ /dev/null @@ -1,103 +0,0 @@ -!********************************************************************* -module module_wrfphys_alloc -! This module allocates variables used in wrfphys, used chem_alloc2 from -! T Henderson as example... -! GG April 2009 -!********************************************************************* -contains - - - - -subroutine wrfphys_alloc - - USE module_wrf_control, only: ims,ime,jms,jme,kms,kme, & - num_moist,num_soil_layers,num_scalar - ! yes, use ALL of it - use module_wrfphysvars - - implicit none - - ALLOCATE( moist( ims:ime, kms:kme, jms:jme, num_moist ) ) - moist=0. - ALLOCATE( scalar( ims:ime, kms:kme, jms:jme, num_scalar ) ) - scalar=0. - ALLOCATE( tsk( ims:ime, jms:jme) ) - ALLOCATE( rri( ims:ime , kms:kme , jms:jme ) ) - ALLOCATE( t_phy( ims:ime , kms:kme , jms:jme ) ) - ALLOCATE( th_phy( ims:ime , kms:kme , jms:jme ) ) - ALLOCATE( p_phy( ims:ime , kms:kme , jms:jme ) ) - ALLOCATE( pi_phy( ims:ime , kms:kme , jms:jme ) ) - ALLOCATE( dz8w( ims:ime , kms:kme , jms:jme ) ) - ALLOCATE( t8w( ims:ime , kms:kme , jms:jme ) ) - ALLOCATE( p8w( ims:ime , kms:kme , jms:jme ) ) - ALLOCATE( z_at_w ( ims:ime , kms:kme , jms:jme ) ) - ALLOCATE( zmid ( ims:ime , kms:kme , jms:jme ) ) - ALLOCATE( u_phy( ims:ime , kms:kme , jms:jme ) ) - ALLOCATE( v_phy( ims:ime , kms:kme , jms:jme ) ) - ALLOCATE( vvel( ims:ime , kms:kme , jms:jme ) ) - ALLOCATE( rho_phy( ims:ime , kms:kme , jms:jme ) ) - ALLOCATE( exch_h( ims:ime , kms:kme , jms:jme ) ) - ALLOCATE( cldfra( ims:ime , kms:kme , jms:jme ) ) - ALLOCATE( rqvcuten( ims:ime , kms:kme , jms:jme ) ) - ALLOCATE( rqvblten( ims:ime , kms:kme , jms:jme ) ) - ALLOCATE( rqvften( ims:ime , kms:kme , jms:jme ) ) - ALLOCATE( rthcuten( ims:ime , kms:kme , jms:jme ) ) - ALLOCATE( rthblten( ims:ime , kms:kme , jms:jme ) ) - ALLOCATE( rthraten( ims:ime , kms:kme , jms:jme ) ) - ALLOCATE( rthften( ims:ime , kms:kme , jms:jme ) ) - ALLOCATE( rqccuten( ims:ime , kms:kme , jms:jme ) ) - ALLOCATE( rqrcuten( ims:ime , kms:kme , jms:jme ) ) - ALLOCATE( rqscuten( ims:ime , kms:kme , jms:jme ) ) - ALLOCATE( rqicuten( ims:ime , kms:kme , jms:jme ) ) - ALLOCATE( rqgcuten( ims:ime , kms:kme , jms:jme ) ) - - ALLOCATE( ivgtyp( ims:ime , jms:jme ) ) - ALLOCATE( isltyp( ims:ime , jms:jme ) ) - ALLOCATE( u10( ims:ime , jms:jme ) ) - ALLOCATE( v10( ims:ime , jms:jme ) ) - ALLOCATE( gsw( ims:ime , jms:jme ) ) - ALLOCATE( sr( ims:ime , jms:jme ) ) - ALLOCATE( pbl( ims:ime , jms:jme ) ) - ALLOCATE( hfx( ims:ime , jms:jme ) ) - ALLOCATE( vegfra( ims:ime , jms:jme ) ) - ALLOCATE( rmol( ims:ime , jms:jme ) ) - ALLOCATE( ust( ims:ime , jms:jme ) ) - ALLOCATE( xland( ims:ime , jms:jme ) ) - ALLOCATE( xlat( ims:ime , jms:jme ) ) - ALLOCATE( xlong( ims:ime , jms:jme ) ) - ALLOCATE( znt( ims:ime , jms:jme ) ) - ALLOCATE( ht( ims:ime , jms:jme ) ) -! for convective schemes - ALLOCATE( rainc( ims:ime , jms:jme )) - ALLOCATE( apr_gr( ims:ime , jms:jme )) - ALLOCATE( apr_w( ims:ime , jms:jme )) - ALLOCATE( apr_mc( ims:ime , jms:jme )) - ALLOCATE( apr_as( ims:ime , jms:jme )) - ALLOCATE( apr_st( ims:ime , jms:jme )) - ALLOCATE( apr_capma( ims:ime , jms:jme )) - ALLOCATE( apr_capme( ims:ime , jms:jme )) - ALLOCATE( apr_capmi( ims:ime , jms:jme )) - ALLOCATE( mass_flux( ims:ime , jms:jme )) - ALLOCATE( cugd_tten( ims:ime , kms:kme , jms:jme )) - ALLOCATE( cugd_ttens( ims:ime , kms:kme , jms:jme )) - ALLOCATE( cugd_qvten( ims:ime , kms:kme , jms:jme )) - ALLOCATE( cugd_qcten( ims:ime , kms:kme , jms:jme )) - ALLOCATE( cugd_qvtens( ims:ime , kms:kme , jms:jme )) - ALLOCATE( gd_cloud( ims:ime , kms:kme , jms:jme )) - ALLOCATE( gd_cloud2( ims:ime , kms:kme , jms:jme )) - ALLOCATE( raincv( ims:ime , jms:jme )) - - ALLOCATE ( rainnc( ims:ime , jms:jme )) - ALLOCATE ( rainncv( ims:ime , jms:jme )) - ALLOCATE ( snownc( ims:ime , jms:jme )) - ALLOCATE ( snowncv( ims:ime , jms:jme )) - ALLOCATE ( graupelnc( ims:ime , jms:jme )) - ALLOCATE ( graupelncv( ims:ime , jms:jme )) - - ALLOCATE( dxy( ims:ime , jms:jme ) ) - ALLOCATE( smois( ims:ime, num_soil_layers, jms:jme ) ) -return -end subroutine wrfphys_alloc - -end module module_wrfphys_alloc diff --git a/src/fim/FIMsrc/fim/horizontal/wrfphysics.F90 b/src/fim/FIMsrc/fim/horizontal/wrfphysics.F90 deleted file mode 100644 index 4986edb..0000000 --- a/src/fim/FIMsrc/fim/horizontal/wrfphysics.F90 +++ /dev/null @@ -1,320 +0,0 @@ - -!NOTE: For the moment, WRF physics is tightly coupled to FIM dynamics -!NOTE: via use-association with modules that declare dynamics variables. - -module module_wrfphysics - -implicit none - -integer :: ipn ! Index for icos point number -integer :: itsP ! Public version of its - -contains -!********************************************************************* -! wrf_physics -! Calculates column forcing for global fim using physics routines from WRF -! 04/30/2009 - Georg Grell - original version -!********************************************************************* - -subroutine wrf_physics (ktau) - -use module_control ,only: nvl,nip,nvlp1,dt,ntra,ntrb,yyyymmddhhmm -use module_wrf_control, only: num_soil_layers, num_moist, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte -use module_constants ,only: cp, rd, grvity, qvmin, deg_lat, deg_lon -! move to module_sfc_variables -!USE module_fim_phy_init,only : zorl2d,vfrac2d,vtype2d,stype2d -! BEGIN dynamics variables... -USE module_sfc_variables ,only : rn2d,rc2d,ts2d,us2d,hf2d,sw2d, & - slmsk2d,st3d,sm3d,zorl2d,vfrac2d,vtype2d,stype2d -use module_variables,only: us3d,vs3d,dp3d,pr3d,ph3d,ex3d,mp3d,diaga,diagb, & - tr=>tr3d,trdp,ws3d,tk3d -! END dynamics variables -use module_wrf_variables,only: phys3dwrf,phys2dwrf,exch,pb2d - -! TBH: Ignore these so PPP doesn't have to translate them -!SMS$IGNORE BEGIN -USE module_initial_chem_namelists -USE module_wrfphysvars -USE module_microphysics_driver, only:microphysics_driver -USE module_cumulus_driver, only: cumulus_driver -USE module_wrfphys_prep_fim, only:wrfphys_prep_fim -!USE module_chemvars, only: chem -!SMS$IGNORE END - -implicit none - -! Dimension and type external variables: -integer,intent (IN) :: ktau ! model time step - -integer :: ivl,current_month,current_gmt,julday,i,j,k,nv,nvv,stepcu,kpbl(ims:ime,jms:jme) -real :: dx,dy,gmt -real :: mu(ims:ime,jms:jme),edt_out(ims:ime,jms:jme),cutop(ims:ime,jms:jme),cubot(ims:ime,jms:jme) -real :: pr_ens(ims:ime,jms:jme,ensdim),xf_ens(ims:ime,jms:jme,ensdim) - LOGICAL, DIMENSION( ims:ime , jms:jme ) :: CU_ACT_FLAG -real :: maxtmp - -CHARACTER(len=9 ) :: jdate - -!TODO: Need better initial values for these? - cutop = 0.0 - cubot = 1000. - -!sms$compare_var(st3d , "begin wrf_physics ") -!sms$compare_var(sm3d , "begin wrf_physics ") -!sms$compare_var(rn2d , "begin wrf_physics ") -!sms$compare_var(rc2d , "begin wrf_physics ") -!sms$compare_var(ts2d , "begin wrf_physics ") -!sms$compare_var(us2d , "begin wrf_physics ") -!sms$compare_var(hf2d , "begin wrf_physics ") -!sms$compare_var(sw2d , "begin wrf_physics ") -!sms$compare_var(slmsk2d, "begin wrf_physics ") - -! dx,dy not needed as of now (used to be needed for microphys/etampnew) - dx=0. - dy=0. - stepcu=1 - mu(:,:)=1. - if(ktau.le.1)then - READ(UNIT=yyyymmddhhmm(5:6), FMT='(I2)') current_month - endif - READ(UNIT=yyyymmddhhmm(9:10), FMT='(I2)') current_gmt - call GetJdate(yyyymmddhhmm,jdate) ! Julian date conversion - READ(UNIT=jdate(3:5), FMT='(I3)')julday - - gmt=current_gmt - -!---------------------------------------------------------------------- -! Loop begins over all horizontal grid points -!---------------------------------------------------------------------- - -!SMS$PARALLEL (dh,ipn) BEGIN - do ipn=1,nip - do ivl=1,nvl - tr(ivl,ipn,2) = max(qvmin, tr(ivl,ipn,2)) - enddo - enddo -!SMS$PARALLEL END -! print *,'call wrfphys_prep' - call wrfphys_prep_fim(ktau,dt,tr,tk3d,st3d,sm3d,dp3d,mp3d,ts2d,us2d,sw2d,pr3d, & - VFRAC2d,VTYPE2d,STYPE2d,us3d,vs3d,ws3d,slmsk2d,zorl2d,exch,pb2d,hf2d,& - ex3d,pi_phy,gmt,julday,ph3d,deg_lat,deg_lon,nvl,nvlp1,ntra,ntrb, & - th_phy,rri,t_phy,moist,u_phy,v_phy,p_phy,tsk,grvity,rd,cp,& - u10,v10,ivgtyp,isltyp,gsw,vegfra,rmol,ust,znt,xland,t8w,p8w,exch_h,pbl,hfx,ht, & - phys3dwrf,rqvblten,rqvften,rthraten,rthblten,rthften, & - xlat,xlong,z_at_w,zmid,dz8w,vvel,rho_phy,smois,num_soil_layers,num_moist,& - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite,jts,jte,kts,kte) -! -! some of the optional stuff related to chem have for now been commented out -! -! print *,'call cumulus driver' - if(cu_physics.gt.0)then - raincv(:,:)=0. - rainc(:,:)=0. - CALL cumulus_driver(U=u_phy,V=v_phy,TH=th_phy,T=t_phy,W=vvel,P=p_phy,PI=pi_phy,RHO=rho_phy,ITIMESTEP=ktau,DT=dt,& - DX=dx,RAINC=rainc,RAINCV=raincv,HTOP=cutop,HBOT=cubot,KPBL=kpbl,DZ8W=dz8w,P8W=p8w,STEPCU=stepcu,& - XLAND=xland,APR_GR=apr_gr,APR_W=apr_w,APR_MC=apr_mc,APR_ST=apr_st,APR_AS=apr_as,APR_CAPMA=apr_capma, & - APR_CAPME=apr_capme,APR_CAPMI=apr_capmi,MASS_FLUX=mass_flux,XF_ENS=xf_ens,PR_ENS=pr_ens,HT=ht,EDT_OUT=edt_out,& - imomentum=imomentum,clos_choice=clos_choice,cugd_tten=cugd_tten,cugd_qvten=cugd_qvten,cugd_qcten=cugd_qcten, & - cugd_ttens=cugd_ttens,cugd_qvtens=cugd_qvtens,ENSDIM=ensdim,MAXIENS=maxiens,MAXENS=maxens,MAXENS2=maxens2, & - MAXENS3=maxens3,CU_ACT_FLAG=cu_act_flag,GSW=gsw,cugd_avedx=cugd_avedx,CU_PHYSICS=cu_physics, & - IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde,& - IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme, & - ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte,RQVCUTEN=rqvcuten,RQCCUTEN=rqccuten,RQICUTEN=rqicuten,RQVBLTEN=rqvblten,& - RQVFTEN=rqvften,RTHRATEN=rthraten,RTHBLTEN=rthblten,RTHCUTEN=rthcuten,RTHFTEN=rthften, & - QV_CURR=moist(ims,kms,jms,P_QV),F_QV=F_QV,QC_CURR=moist(ims,kms,jms,P_QC),F_QC=F_QC, & - QR_CURR=moist(ims,kms,jms,P_QR),F_QR=F_QR,QI_CURR=moist(ims,kms,jms,P_QI),F_QI=F_QI, & - QS_CURR=moist(ims,kms,jms,P_QS),F_QS=F_QS,QG_CURR=moist(ims,kms,jms,P_QG),F_QG=F_QG,GD_CLOUD=GD_CLOUD,GD_CLOUD2=GD_CLOUD2) - - do j=jts,jte - do k=kts,kte - do i=its,ite - tr(k,j,2)=tr(k,j,2)+rqvcuten(i,k,j)*dt - diagb(k,j)=rqvcuten(i,k,j) - diaga(k,j)=rthcuten(i,k,j)*pi_phy(i,k,j) - tr(k,j,1)=tr(k,j,1)+rthcuten(i,k,j)*dt*(1.+.6078*tr(k,j,2)) - if(mp_physics.gt.0)then - tr(k,j,3)=tr(k,j,3)+rqccuten(i,k,j)*dt - else - tr(k,j,3)=tr(k,j,3)+(rqicuten(i,k,j)+rqccuten(i,k,j))*dt - endif - enddo - enddo - enddo - endif - if(mp_physics.gt.0)then - print *,'call microphys driver' - maxtmp = maxval(moist(its:ite,kts:kte,jts:jte,p_qv)) -!SMS$REDUCE(maxtmp,MAX) - write(6,*)'1max qv = ',maxtmp - maxtmp = maxval(moist(its:ite,kts:kte,jts:jte,p_qc)) -!SMS$REDUCE(maxtmp,MAX) - write(6,*)'1max qc = ',maxtmp - maxtmp = maxval(moist(its:ite,kts:kte,jts:jte,p_qr)) -!SMS$REDUCE(maxtmp,MAX) - write(6,*)'1max qr = ',maxtmp - maxtmp = maxval(moist(its:ite,kts:kte,jts:jte,p_qi)) -!SMS$REDUCE(maxtmp,MAX) - write(6,*)'1max qi = ',maxtmp - maxtmp = maxval(moist(its:ite,kts:kte,jts:jte,p_qs)) -!SMS$REDUCE(maxtmp,MAX) - write(6,*)'1max qs = ',maxtmp - maxtmp = minval(moist(its:ite,kts:kte,jts:jte,p_qs)) -!SMS$REDUCE(maxtmp,MIN) - write(6,*)'1min qs = ',maxtmp - rainnc(:,:)=0. - rainncv(:,:)=0. - snownc(:,:)=0. - snowncv(:,:)=0. - graupelnc(:,:)=0. - graupelncv(:,:)=0. - CALL microphysics_driver( & - & DT=dt ,DX=dx ,DY=dy & - & ,DZ8W=dz8w & - & ,ITIMESTEP=ktau & - & ,P8W=p8w ,P=p_phy ,PI_PHY=pi_phy & - & ,RHO=rho_phy & - & ,SR=sr ,TH=th_phy & - & ,T8W=t8w & - & ,CLDFRA=cldfra, EXCH_H=exch_h & -!#ifdef WRF_CHEM -! & ,QLSINK=qlsink,CLDFRA_OLD=cldfra_old & -! & ,PRECR=precr, PRECI=preci, PRECS=precs, PRECG=grid -!%precg & -! & ,CHEM_OPT=config_flags%chem_opt, PROGN=config_flags%progn & -!#endif - & ,XLAND=xland & - & ,MP_PHYSICS=config_flags%mp_physics & - & ,ID=1 & - & ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & - & ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & - & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & - ! Optional - & , RAINNC=rainnc, RAINNCV=rainncv & - & , SNOWNC=snownc, SNOWNCV=snowncv & - & , GRAUPELNC=graupelnc, GRAUPELNCV=graupelncv & - & , W=vvel, Z=zmid, HT=ht & - & , QV_CURR=moist(ims,kms,jms,P_QV), F_QV=F_QV & - & , QC_CURR=moist(ims,kms,jms,P_QC), F_QC=F_QC & - & , QR_CURR=moist(ims,kms,jms,P_QR), F_QR=F_QR & - & , QI_CURR=moist(ims,kms,jms,P_QI), F_QI=F_QI & - & , QS_CURR=moist(ims,kms,jms,P_QS), F_QS=F_QS & - & , QG_CURR=moist(ims,kms,jms,P_QG), F_QG=F_QG & - & , QNDROP_CURR=scalar(ims,kms,jms,P_QNDROP), F_QNDROP=F_QNDROP & - & , QNI_CURR=scalar(ims,kms,jms,P_QNI), F_QNI=F_QNI & - & , QT_CURR=scalar(ims,kms,jms,P_QT), F_QT=F_QT & - & , QNS_CURR=scalar(ims,kms,jms,P_QNS), F_QNS=F_QNS & - & , QNR_CURR=scalar(ims,kms,jms,P_QNR), F_QNR=F_QNR & - & , QNG_CURR=scalar(ims,kms,jms,P_QNG), F_QNG=F_QNG & - & , QNN_CURR=scalar(ims,kms,jms,P_QNN), F_QNN=F_QNN & - & , QNC_CURR=scalar(ims,kms,jms,P_QNC), F_QNC=F_QNC & - & , qrcuten=rqrcuten, qscuten=rqscuten & - & , qicuten=rqicuten,mu=mu & - & , HAIL=config_flags%gsfcgce_hail & ! for gsfcgce - & , ICE2=config_flags%gsfcgce_2ice & ! for gsfcgce - ) - - do nv=1,num_moist-1 - nvv=4+nv - do j=jts,jte - do k=kts,kte - do i=its,ite - if(moist(i,k,j,nv+1).lt.1.e-15)moist(i,k,j,nv+1)=0. - tr(k,j,nvv)=moist(i,k,j,nv+1) - enddo - enddo - enddo - enddo - - do j=jts,jte - do k=kts,kte - do i=its,ite - tr(k,j,2)=max(1.e-15,moist(i,k,j,1)) - tr(k,j,3)=moist(i,k,j,p_qc)+moist(i,k,j,p_qr)+moist(i,k,j,p_qs)+moist(i,k,j,p_qi) - tr(k,j,1)=th_phy(i,k,j)*(1.+0.6078*tr(k,j,2)) - enddo - enddo - enddo - do nv=1,ntra+ntrb - do j=jts,jte - do k=kts,kte - do i=its,ite - trdp(k,j,nv)=tr(k,j,nv)*dp3d(k,j) - enddo - enddo - enddo - enddo - maxtmp = maxval(moist(its:ite,kts:kte,jts:jte,p_qv)) -!SMS$REDUCE(maxtmp,MAX) - write(6,*)'max qv = ',maxtmp - maxtmp = maxval(moist(its:ite,kts:kte,jts:jte,p_qc)) -!SMS$REDUCE(maxtmp,MAX) - write(6,*)'max qc = ',maxtmp - maxtmp = maxval(moist(its:ite,kts:kte,jts:jte,p_qr)) -!SMS$REDUCE(maxtmp,MAX) - write(6,*)'max qr = ',maxtmp - maxtmp = maxval(moist(its:ite,kts:kte,jts:jte,p_qi)) -!SMS$REDUCE(maxtmp,MAX) - write(6,*)'max qi = ',maxtmp - maxtmp = maxval(moist(its:ite,kts:kte,jts:jte,p_qs)) -!SMS$REDUCE(maxtmp,MAX) - write(6,*)'max qs = ',maxtmp - maxtmp = minval(moist(its:ite,kts:kte,jts:jte,p_qs)) -!SMS$REDUCE(maxtmp,MIN) - write(6,*)'min qs = ',maxtmp - maxtmp = maxval(rainncv(its:ite,jts:jte)) -!SMS$REDUCE(maxtmp,MAX) - write(6,*)'max rainnc = ',maxtmp - endif ! mp_physics -! maxtmp = maxval(raincv(its:ite,jts:jte)) -!!SMS$REDUCE(maxtmp,MAX) -! write(6,*)'max rainc = ',maxtmp -! -! phys2dwrf (6:8) for feedback to gbphys -! - if(cu_physics .ne. 0) then - do j=jts,jte - do i=its,ite - phys2dwrf(j,5)=phys2dwrf(j,5)+raincv(i,j) - phys2dwrf(j,6)=raincv(i,j)*.001 - phys2dwrf(j,7)=cubot(i,j) - phys2dwrf(j,8)=cutop(i,j) -! rc2d(j)=rc2d(j)+raincv(i,j) ! phys2dwrf(j,5) -! if(raincv(i,j).gt.0)write(6,*)'in wrfphys', phys2dwrf(j,6),cubot(i,j),cutop(i,j) - enddo - enddo - endif - if(mp_physics .ne. 0) then - do j=jts,jte - do i=its,ite - phys2dwrf(j,1)=rainncv(i,j)+phys2dwrf(j,1) - phys2dwrf(j,2)=rainncv(i,j) -! if(rainncv(i,j).gt.0.)write(6,*)i,j,rainncv(i,j),moist(i,1,j,p_qr) - phys2dwrf(j,3)=snowncv(i,j)+phys2dwrf(j,3) - phys2dwrf(j,4)=snowncv(i,j) -! rn2d(j)=phys2dwrf(j,5)+phys2dwrf(j,1)+phys2dwrf(j,3) -! if(mp_physis .ne. 0) if(raincv(i,j).gt.0.)write(6,*)i,j,raincv(i,j) - enddo - enddo - endif -! maxtmp = maxval(phys2dwrf(jts:jte,5)) -!!SMS$REDUCE(maxtmp,MAX) -! write(6,*)'max rainct = ',maxtmp - -!sms$compare_var(st3d , "end wrf_physics ") -!sms$compare_var(sm3d , "end wrf_physics ") -!sms$compare_var(rn2d , "end wrf_physics ") -!sms$compare_var(rc2d , "end wrf_physics ") -!sms$compare_var(ts2d , "end wrf_physics ") -!sms$compare_var(us2d , "end wrf_physics ") -!sms$compare_var(hf2d , "end wrf_physics ") -!sms$compare_var(sw2d , "end wrf_physics ") -!sms$compare_var(slmsk2d, "end wrf_physics ") - -return -end subroutine wrf_physics -end module module_wrfphysics diff --git a/src/fim/FIMsrc/fim/horizontal/write_restart_dyn.F90 b/src/fim/FIMsrc/fim/horizontal/write_restart_dyn.F90 deleted file mode 100644 index 15370ee..0000000 --- a/src/fim/FIMsrc/fim/horizontal/write_restart_dyn.F90 +++ /dev/null @@ -1,97 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Write required dynamics fields to the restart file. SMS will modify the code to do the -! appropriate single-task writing of the restart file, after gathering the -! data from other MPI tasks. -! -! CRITICAL: If you modify this file, you MUST also modify read_restart_dyn.F90 in the -! same way. Otherwise restart will be broken. -! -! read_restart_dyn and write_restart_dyn belong in a module, but SMS doesn't like multiple -! subroutines in a file. -! -! writearr32 assumes 32-bit data. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -subroutine write_restart_dyn (unitno) - use module_sfc_variables, only: rn2d, rc2d, rn2d0, rc2d0, rg2d0, flxswavg2d, flxlwavg2d, flxlwtoa2d - use module_variables, only: curr_write_time, nf, of, vof, adbash1, adbash2, adbash3, psrf, & - ptdcy, pw2d, u_tdcy, v_tdcy, dp_tdcy, dpl_tdcy, tr3d, trdp, & - trc_tdcy, trl_tdcy, us3d, vs3d, ws3d, mp3d, tk3d, dp3d, rh3d, & - vor, dpinit, pr3d, ex3d, ph3d, sdot, massfx, cumufx - use module_constants, only: dpsig, thetac, lat, lon, nprox, proxs, area, cs, sn, sidevec_c, & - sidevec_e, sideln, rsideln, rprox_ln, area, rarea, corio, & - deg_lat, deg_lon - use module_control, only: dt, nabl, ntra, ntrb, npp, nvl, nvlp1 - use module_globsum, only: qmstr, qmstrc, qmstrn, qdtr_set - - implicit none - - integer, intent(in) :: unitno ! unit number to write to - - integer :: n, t ! indices - -!SMS$SERIAL BEGIN - write (unitno, err=90) curr_write_time, nf, of, vof, adbash1, adbash2, adbash3, thetac, dpsig - write (unitno, err=90) lat, lon, nprox, proxs, area, cs, sn, psrf, ptdcy -!SMS$SERIAL END -!SMS$SERIAL BEGIN - write (unitno, err=90) qmstr, qmstrc, qmstrn, qdtr_set -!SMS$SERIAL END -!SMS$SERIAL BEGIN - write (unitno, err=90) sidevec_c, sidevec_e, sideln, rprox_ln -!SMS$SERIAL END -!SMS$SERIAL BEGIN - write (unitno, err=90) rn2d0, rc2d0, rg2d0, flxswavg2d, flxlwavg2d, flxlwtoa2d -!SMS$SERIAL END -!SMS$SERIAL BEGIN - write (unitno, err=90) rarea, rsideln, corio, deg_lat, deg_lon, rn2d, pw2d, rc2d -!SMS$SERIAL END - -! These arrays are dimensioned (nvl,nip[,other dimensions]): - do n=1,nabl - call writearr32 (u_tdcy(:,:,n), nvl, unitno) - call writearr32 (v_tdcy(:,:,n), nvl, unitno) - call writearr32 (dp_tdcy(:,:,n), nvl, unitno) - call writearr32 (dpl_tdcy(:,:,n), nvl, unitno) - end do - - do t=1,ntra+ntrb - call writearr32 (tr3d(:,:,t), nvl, unitno) - call writearr32 (trdp(:,:,t), nvl, unitno) - do n=1,nabl - call writearr32 (trc_tdcy(:,:,n,t), nvl, unitno) - call writearr32 (trl_tdcy(:,:,n,t), nvl, unitno) - end do - end do - - call writearr32 (us3d, nvl, unitno) - call writearr32 (vs3d, nvl, unitno) - call writearr32 (ws3d, nvl, unitno) - call writearr32 (mp3d, nvl, unitno) - call writearr32 (tk3d, nvl, unitno) - call writearr32 (dp3d, nvl, unitno) - call writearr32 (rh3d, nvl, unitno) - call writearr32 (vor, nvl, unitno) - call writearr32 (dpinit, nvl, unitno) - -! These arrays are dimensioned (nvlp1,nip): - call writearr32 (pr3d, nvlp1, unitno) - call writearr32 (ex3d, nvlp1, unitno) - call writearr32 (ph3d, nvlp1, unitno) - call writearr32 (sdot, nvlp1, unitno) - -! These arrays are dimensioned (nvl,npp,nip[,other dimensions]): -! Simplest coding folds nvl*npp into a single dimension. Will need to rewrite massfx -! and cumufx to a transpose if root process can't hold npp 3-d fields in memory - do n=1,nabl - call writearr32 (massfx(:,:,:,n), nvl*npp, unitno) - end do - call writearr32 (cumufx(:,:,:), nvl*npp, unitno) - - write(6,*) 'write_restart_dyn: successfully wrote dynamics fields to restart file' - - return - -90 write(6,*)'write_restart_dyn: Error writing to unit ', unitno, '. Stopping' - stop -end subroutine write_restart_dyn diff --git a/src/fim/FIMsrc/fim/horizontal/write_restart_phy.F90 b/src/fim/FIMsrc/fim/horizontal/write_restart_phy.F90 deleted file mode 100644 index 1b77bdc..0000000 --- a/src/fim/FIMsrc/fim/horizontal/write_restart_phy.F90 +++ /dev/null @@ -1,246 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! write_restart_phy: write physics fields to the restart file -! SMS doesn't yet properly handle Fortran derived types, so those fields -! need to go through an interface routine (writearr64). -! -! !!!!!CRITICAL!!!!! Any changes to fields read in here MUST be made in exactly the same way -! in read_restart_phy.F90 -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -subroutine write_restart_phy (unitno) - use module_control, only: nip - use module_sfc_variables - use module_wrf_control, only: nbands -!SMS$IGNORE BEGIN - use gfs_physics_internal_state_mod, only: gis_phy -!SMS$IGNORE END - use module_chem_variables, only: ext_cof, asymp, extlw_cof - - implicit none - -! Input arguments - integer, intent(in) :: unitno ! Unit number to write to - -! Local workspace - integer :: ipn, i, j, n, k ! Loop indices - integer :: ims, ime ! memory bounds - integer :: ips, ipe ! owned memory bounds -! Transposed versions of arrays so writearr64 can tell SMS to do the right thing. - real*8, allocatable :: smc_loc(:,:) - real*8, allocatable :: stc_loc(:,:) - real*8, allocatable :: slc_loc(:,:) - real*8, allocatable :: hprime_loc(:,:) - real*8, allocatable :: fluxr_loc(:,:) -!SMS$DISTRIBUTE(dh,1) BEGIN - real*8, allocatable :: ext_cof_loc(:,:) - real*8, allocatable :: extlw_cof_loc(:,:) - real*8, allocatable :: asymp_loc(:,:) - real*8, allocatable :: arr(:) -!SMS$DISTRIBUTE END - - ims = gis_phy%ims - ime = gis_phy%ime - ips = gis_phy%ips - ipe = gis_phy%ipe - -!SMS$SERIAL BEGIN - write (unitno, err=90) cv2d, cvt2d, cvb2d, slmsk2d, ts2d, st3d, sheleg2d, zorl2d, snoalb2d - write (unitno, err=90) hprm2d, hice2d, fice2d, tprcp2d, srflag2d, slc3d, sm3d, snwdph2d - write (unitno, err=90) slope2d, shdmin2d, shdmax2d, tg32d, vfrac2d, canopy2d, vtype2d, stype2d - write (unitno, err=90) f10m2d, ffmm2d, ffhh2d, alvsf2d, alnsf2d, alvwf2d, alnwf2d, facsf2d - write (unitno, err=90) facwf2d, t2m2d, q2m2d - write(6,*)'write_restart_phy: ts2d, us2d, hf2d, qf2d, sw2d, lw2d=', & - ts2d(1), us2d(1), hf2d(1), qf2d(1), sw2d(1), lw2d(1) - write (unitno, err=90) ts2d, us2d, hf2d, qf2d, sw2d, lw2d -!SMS$SERIAL END - -! Allocate space for arrays which need to be transposed - - allocate (smc_loc(ims:ime,gis_phy%lsoil)) - allocate (stc_loc(ims:ime,gis_phy%lsoil)) - allocate (slc_loc(ims:ime,gis_phy%lsoil)) - allocate (hprime_loc(ims:ime,gis_phy%nmtvr)) - allocate (fluxr_loc(ims:ime,gis_phy%nfxr)) - - allocate (ext_cof_loc(nip,nbands)) - allocate (extlw_cof_loc(nip,16)) - allocate (asymp_loc(nip,nbands)) - -! Write out ALL sfc_fld items. Some are definitely needed, but the list is huge -! Must call an interface routine (writearr64) until SMS can handle derived types -! 2nd arg to writearr64 is size of dimensions after ipn -! Need to transpose some fields to ipn as 1st index so writearr64 can use SMS -! to do the right thing. - - do j=1,gis_phy%lsoil - do ipn=ips,ipe - smc_loc(ipn,j) = gis_phy%sfc_fld%smc(j,ipn,1) - stc_loc(ipn,j) = gis_phy%sfc_fld%stc(j,ipn,1) - slc_loc(ipn,j) = gis_phy%sfc_fld%slc(j,ipn,1) - end do - end do - - call writearr64 (smc_loc, gis_phy%lsoil, unitno) - call writearr64 (stc_loc, gis_phy%lsoil, unitno) - call writearr64 (slc_loc, gis_phy%lsoil, unitno) - - call writearr64 (gis_phy%sfc_fld%tsea, 1, unitno) - call writearr64 (gis_phy%sfc_fld%sheleg, 1, unitno) - call writearr64 (gis_phy%sfc_fld%sncovr, 1, unitno) - call writearr64 (gis_phy%sfc_fld%tg3, 1, unitno) - call writearr64 (gis_phy%sfc_fld%zorl, 1, unitno) - call writearr64 (gis_phy%sfc_fld%cv, 1, unitno) - call writearr64 (gis_phy%sfc_fld%cvb, 1, unitno) - call writearr64 (gis_phy%sfc_fld%cvt, 1, unitno) - write(6,*)'write_restart_phy: writing alvsf' - call writearr64 (gis_phy%sfc_fld%alvsf, 1, unitno) - call writearr64 (gis_phy%sfc_fld%alvwf, 1, unitno) - call writearr64 (gis_phy%sfc_fld%alnsf, 1, unitno) - call writearr64 (gis_phy%sfc_fld%alnwf, 1, unitno) - call writearr64 (gis_phy%sfc_fld%slmsk, 1, unitno) - call writearr64 (gis_phy%sfc_fld%vfrac, 1, unitno) - call writearr64 (gis_phy%sfc_fld%canopy, 1, unitno) - call writearr64 (gis_phy%sfc_fld%f10m, 1, unitno) - call writearr64 (gis_phy%sfc_fld%t2m, 1, unitno) - call writearr64 (gis_phy%sfc_fld%q2m, 1, unitno) - call writearr64 (gis_phy%sfc_fld%vtype, 1, unitno) - call writearr64 (gis_phy%sfc_fld%stype, 1, unitno) - call writearr64 (gis_phy%sfc_fld%facsf, 1, unitno) - call writearr64 (gis_phy%sfc_fld%facwf, 1, unitno) - call writearr64 (gis_phy%sfc_fld%uustar, 1, unitno) - call writearr64 (gis_phy%sfc_fld%ffmm, 1, unitno) - call writearr64 (gis_phy%sfc_fld%ffhh, 1, unitno) - call writearr64 (gis_phy%sfc_fld%hice, 1, unitno) - call writearr64 (gis_phy%sfc_fld%fice, 1, unitno) - call writearr64 (gis_phy%sfc_fld%uustar, 1, unitno) - call writearr64 (gis_phy%sfc_fld%tprcp, 1, unitno) - call writearr64 (gis_phy%sfc_fld%srflag, 1, unitno) - call writearr64 (gis_phy%sfc_fld%snwdph, 1, unitno) - call writearr64 (gis_phy%sfc_fld%shdmin, 1, unitno) - call writearr64 (gis_phy%sfc_fld%shdmax, 1, unitno) - call writearr64 (gis_phy%sfc_fld%slope, 1, unitno) - call writearr64 (gis_phy%sfc_fld%snoalb, 1, unitno) - -! Write out ALL flx_fld items. Are all actually needed? - call writearr64 (gis_phy%flx_fld%sfcdsw, 1, unitno) - call writearr64 (gis_phy%flx_fld%coszen, 1, unitno) - call writearr64 (gis_phy%flx_fld%tmpmin, 1, unitno) - call writearr64 (gis_phy%flx_fld%tmpmax, 1, unitno) - call writearr64 (gis_phy%flx_fld%dusfc, 1, unitno) - call writearr64 (gis_phy%flx_fld%dvsfc, 1, unitno) - call writearr64 (gis_phy%flx_fld%dtsfc, 1, unitno) - call writearr64 (gis_phy%flx_fld%dqsfc, 1, unitno) - call writearr64 (gis_phy%flx_fld%dlwsfc, 1, unitno) - call writearr64 (gis_phy%flx_fld%ulwsfc, 1, unitno) - call writearr64 (gis_phy%flx_fld%gflux, 1, unitno) - call writearr64 (gis_phy%flx_fld%runoff, 1, unitno) - call writearr64 (gis_phy%flx_fld%ep, 1, unitno) - call writearr64 (gis_phy%flx_fld%cldwrk, 1, unitno) - call writearr64 (gis_phy%flx_fld%dugwd, 1, unitno) - call writearr64 (gis_phy%flx_fld%dvgwd, 1, unitno) - call writearr64 (gis_phy%flx_fld%psmean, 1, unitno) - call writearr64 (gis_phy%flx_fld%geshem, 1, unitno) - call writearr64 (gis_phy%flx_fld%rainc, 1, unitno) - call writearr64 (gis_phy%flx_fld%evap, 1, unitno) - call writearr64 (gis_phy%flx_fld%hflx, 1, unitno) - call writearr64 (gis_phy%flx_fld%bengsh, 1, unitno) - call writearr64 (gis_phy%flx_fld%sfcnsw, 1, unitno) - call writearr64 (gis_phy%flx_fld%sfcdlw, 1, unitno) - call writearr64 (gis_phy%flx_fld%tsflw, 1, unitno) - call writearr64 (gis_phy%flx_fld%psurf, 1, unitno) - call writearr64 (gis_phy%flx_fld%u10m, 1, unitno) - call writearr64 (gis_phy%flx_fld%v10m, 1, unitno) - call writearr64 (gis_phy%flx_fld%hpbl, 1, unitno) - call writearr64 (gis_phy%flx_fld%pwat, 1, unitno) - -! These things are from cpl_dyn_to_phy. Not sure which are necessary - call writearr64 (gis_phy%ps, 1, unitno) - call writearr64 (gis_phy%dp, gis_phy%levs, unitno) - call writearr64 (gis_phy%p, gis_phy%levs, unitno) - call writearr64 (gis_phy%u, gis_phy%levs, unitno) - call writearr64 (gis_phy%v, gis_phy%levs, unitno) - call writearr64 (gis_phy%dpdt, gis_phy%levs, unitno) - call writearr64 (gis_phy%q, gis_phy%levs, unitno) - call writearr64 (gis_phy%oz, gis_phy%levs, unitno) - call writearr64 (gis_phy%cld, gis_phy%levs, unitno) - call writearr64 (gis_phy%t, gis_phy%levs, unitno) - - do n=1,gis_phy%num_p3d - do j=1,gis_phy%lats_node_r - do i=1,gis_phy%nblck - call writearr64 (gis_phy%phy_f3d(:,:,i,j,n), gis_phy%levs, unitno) - end do - end do - end do - - do n=1,gis_phy%num_p2d - do j=1,gis_phy%lats_node_r - call writearr64 (gis_phy%phy_f2d(:,j,n), 1, unitno) - end do - end do - -! These things are in gis_phy proper, not in substructures sfc_fld or flx_fld - do j=1,gis_phy%lats_node_r - do ipn=ips,ipe - do n=1,gis_phy%nmtvr - hprime_loc(ipn,n) = gis_phy%hprime(n,ipn,j) - end do - end do - call writearr64 (hprime_loc, gis_phy%nmtvr, unitno) - call writearr64 (gis_phy%coszdg(:,j), 1, unitno) - call writearr64 (gis_phy%sfalb(:,j), 1, unitno) - call writearr64 (gis_phy%slag(:,j), 1, unitno) - call writearr64 (gis_phy%sdec(:,j), 1, unitno) - call writearr64 (gis_phy%cdec(:,j), 1, unitno) - do n=1,gis_phy%nblck - call writearr64 (gis_phy%swh(:,:,n,j), gis_phy%levs, unitno) - call writearr64 (gis_phy%hlw(:,:,n,j), gis_phy%levs, unitno) - end do - do ipn=ips,ipe - do n=1,gis_phy%nfxr - fluxr_loc(ipn,n) = gis_phy%fluxr(n,ipn,j) - end do - end do - call writearr64 (fluxr_loc, gis_phy%nfxr, unitno) - end do - -!SMS$PARALLEL(dh, ipn) BEGIN -! These things are from chemistry, but are used in grrad. Need to transpose so -! writearr64 tells SMS to do the right thing. - do k=1,gis_phy%levs - do n=1,nbands - do ipn=1,nip - ext_cof_loc(ipn,n) = ext_cof(k,ipn,n) - asymp_loc(ipn,n) = asymp(k,ipn,n) - end do - end do - - call writearr64 (ext_cof_loc, nbands, unitno) - call writearr64 (asymp_loc, nbands, unitno) - -! The "16" is hard-wired in the allocation done in dyn_alloc - do n=1,16 - do ipn=1,nip - extlw_cof_loc(ipn,n) = extlw_cof(k,ipn,n) - end do - end do - call writearr64 (extlw_cof_loc, 16, unitno) - end do - - write (6,*) 'write_restart_phy: successfully wrote physics fields to restart file' -!SMS$PARALLEL END - - deallocate (smc_loc) - deallocate (stc_loc) - deallocate (slc_loc) - deallocate (ext_cof_loc) - deallocate (extlw_cof_loc) - deallocate (asymp_loc) - deallocate (hprime_loc) - deallocate (fluxr_loc) - - return - -90 write(6,*)'write_restart_phy: Error writing to unit ', unitno, '. Stopping' - stop -end subroutine write_restart_phy diff --git a/src/fim/FIMsrc/fim/horizontal/writearr32.F90 b/src/fim/FIMsrc/fim/horizontal/writearr32.F90 deleted file mode 100644 index ee05308..0000000 --- a/src/fim/FIMsrc/fim/horizontal/writearr32.F90 +++ /dev/null @@ -1,28 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Write 32-bit array to the restart file after gathering from other MPI tasks. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -subroutine writearr32 (arr, dim1siz, unitno) - use module_control, only: nip - - implicit none - - integer, intent(in) :: dim1siz ! size of 1st dimension of arr - integer, intent(in) :: unitno ! unit number to write to - -!SMS$DISTRIBUTE(dh,2) BEGIN - real*4, intent(in) :: arr(dim1siz,nip) -!SMS$DISTRIBUTE END - -! The keeps SMS from generating a needless scatter after the write -!SMS$SERIAL ( : DEFAULT=IGNORE) BEGIN - write (unitno, err=90) arr -! write(6,*)'writearr32: arr(1,1)=',arr(1,1),' arr(dim1siz,nip)=',arr(dim1siz,nip) -!SMS$SERIAL END - - return - -90 write(6,*) 'writearr32: error writing to unit ', unitno, ' Stopping' - call flush(6) - stop -end subroutine writearr32 diff --git a/src/fim/FIMsrc/fim/horizontal/writearr64.F90 b/src/fim/FIMsrc/fim/horizontal/writearr64.F90 deleted file mode 100644 index dfe7056..0000000 --- a/src/fim/FIMsrc/fim/horizontal/writearr64.F90 +++ /dev/null @@ -1,25 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Write 64-bit array to the restart file after gathering from other MPI tasks. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -subroutine writearr64 (arr, dim2siz, unitno) - use module_control, only: nip - - implicit none - - integer, intent(in) :: dim2siz ! size of 2nd dimension of arr - integer, intent(in) :: unitno ! unit number to write to - -!SMS$DISTRIBUTE(dh,1) BEGIN - real*8, intent(in) :: arr(nip,dim2siz) -!SMS$DISTRIBUTE END - -! The keeps SMS from generating a needless scatter after the write -!SMS$SERIAL ( : DEFAULT=IGNORE) BEGIN - write (unitno, err=90) arr -!SMS$SERIAL END - return - -90 write(6,*) 'writearr64: error writing to unit ', unitno, ' Stopping' - stop -end subroutine writearr64 diff --git a/src/fim/FIMsrc/fim/wrfphys/FIM_WRFP_OBJECTS b/src/fim/FIMsrc/fim/wrfphys/FIM_WRFP_OBJECTS deleted file mode 100644 index 8501166..0000000 --- a/src/fim/FIMsrc/fim/wrfphys/FIM_WRFP_OBJECTS +++ /dev/null @@ -1,22 +0,0 @@ -# wrfphys objects - -OBJS = \ - libmassv.o \ - module_cu_g3.o \ - module_cu_gd.o \ - module_cumulus_driver.o \ - module_microphysics_driver.o \ - module_mp_gsfcgce.o \ - module_mp_kessler.o \ - module_mp_lin.o \ - module_mp_morr_two_moment.o \ - module_mp_thompson.o \ - module_mp_thompson07.o \ - module_mp_wdm5.o \ - module_mp_wdm6.o \ - module_mp_wsm3.o \ - module_mp_wsm5.o \ - module_mp_wsm6.o \ - module_set_wrfphys.o \ - module_wrfphys_prep_fim.o \ - module_wrfphysvars.o diff --git a/src/fim/FIMsrc/fim/wrfphys/Makefile b/src/fim/FIMsrc/fim/wrfphys/Makefile deleted file mode 100644 index 9d82516..0000000 --- a/src/fim/FIMsrc/fim/wrfphys/Makefile +++ /dev/null @@ -1,31 +0,0 @@ -# wrfphys Makefile - -SHELL = /bin/sh - -include ../../macros.make -include FIM_WRFP_OBJECTS - -.SUFFIXES: -.SUFFIXES: .o .f .F .a - -.f.o .F.o: - $(FC) -c $(FLAGS) -I../../cntl -I../../utils $(FREEFLAG) $< - -all: DEPENDENCIES $(OBJS) - -DEPENDENCIES: - $(RM) -f Filepath Srcfiles - echo "." > Filepath - ls -1 *.F > Srcfiles - $(MKDEPENDS) -m Filepath Srcfiles > $@ - -# The following -O0 rule ensures bitwise-exact output between serial & parallel -# runs built using ifort 9.1. - -module_cu_g3.o: - $(FC) -c $(FLAGS) $(FREEFLAG) -O0 module_cu_g3.F - --include DEPENDENCIES - -clean: - $(RM) -f *.o *.mod *.a DEPENDENCIES diff --git a/src/fim/FIMsrc/fim/wrfphys/libmassv.F b/src/fim/FIMsrc/fim/wrfphys/libmassv.F deleted file mode 100644 index 21add71..0000000 --- a/src/fim/FIMsrc/fim/wrfphys/libmassv.F +++ /dev/null @@ -1,385 +0,0 @@ -! IBM libmassv compatibility library -! - -#ifndef NATIVE_MASSV - subroutine vdiv(z,x,y,n) - real*8 x(*),y(*),z(*) - do 10 j=1,n - z(j)=x(j)/y(j) - 10 continue - return - end - - subroutine vsdiv(z,x,y,n) - real*4 x(*),y(*),z(*) - do 10 j=1,n - z(j)=x(j)/y(j) - 10 continue - return - end - - subroutine vexp(y,x,n) - real*8 x(*),y(*) - do 10 j=1,n - y(j)=exp(x(j)) - 10 continue - return - end - - subroutine vsexp(y,x,n) - real*4 x(*),y(*) - do 10 j=1,n - y(j)=exp(x(j)) - 10 continue - return - end - - subroutine vlog(y,x,n) - real*8 x(*),y(*) - do 10 j=1,n - y(j)=log(x(j)) - 10 continue - return - end - - subroutine vslog(y,x,n) - real*4 x(*),y(*) - do 10 j=1,n - y(j)=log(x(j)) - 10 continue - return - end - - subroutine vrec(y,x,n) - real*8 x(*),y(*) - do 10 j=1,n - y(j)=1.d0/x(j) - 10 continue - return - end - - subroutine vsrec(y,x,n) - real*4 x(*),y(*) - do 10 j=1,n - y(j)=1.e0/x(j) - 10 continue - return - end - - subroutine vrsqrt(y,x,n) - real*8 x(*),y(*) - do 10 j=1,n - y(j)=1.d0/sqrt(x(j)) - 10 continue - return - end - - subroutine vsrsqrt(y,x,n) - real*4 x(*),y(*) - do 10 j=1,n - y(j)=1.e0/sqrt(x(j)) - 10 continue - return - end - - subroutine vsincos(x,y,z,n) - real*8 x(*),y(*),z(*) - do 10 j=1,n - x(j)=sin(z(j)) - y(j)=cos(z(j)) - 10 continue - return - end - - subroutine vssincos(x,y,z,n) - real*4 x(*),y(*),z(*) - do 10 j=1,n - x(j)=sin(z(j)) - y(j)=cos(z(j)) - 10 continue - return - end - - subroutine vsqrt(y,x,n) - real*8 x(*),y(*) - do 10 j=1,n - y(j)=sqrt(x(j)) - 10 continue - return - end - - subroutine vssqrt(y,x,n) - real*4 x(*),y(*) - do 10 j=1,n - y(j)=sqrt(x(j)) - 10 continue - return - end - - subroutine vtan(y,x,n) - real*8 x(*),y(*) - do 10 j=1,n - y(j)=tan(x(j)) - 10 continue - return - end - - subroutine vstan(y,x,n) - real*4 x(*),y(*) - do 10 j=1,n - y(j)=tan(x(j)) - 10 continue - return - end - - subroutine vatan2(z,y,x,n) - real*8 x(*),y(*),z(*) - do 10 j=1,n - z(j)=atan2(y(j),x(j)) - 10 continue - return - end - - subroutine vsatan2(z,y,x,n) - real*4 x(*),y(*),z(*) - do 10 j=1,n - z(j)=atan2(y(j),x(j)) - 10 continue - return - end - - subroutine vasin(y,x,n) - real*8 x(*),y(*) - do 10 j=1,n - y(j)=asin(x(j)) - 10 continue - return - end - - subroutine vsin(y,x,n) - real*8 x(*),y(*) - do 10 j=1,n - y(j)=sin(x(j)) - 10 continue - return - end - - subroutine vssin(y,x,n) - real*4 x(*),y(*) - do 10 j=1,n - y(j)=sin(x(j)) - 10 continue - return - end - - subroutine vacos(y,x,n) - real*8 x(*),y(*) - do 10 j=1,n - y(j)=acos(x(j)) - 10 continue - return - end - - subroutine vcos(y,x,n) - real*8 x(*),y(*) - do 10 j=1,n - y(j)=cos(x(j)) - 10 continue - return - end - - subroutine vscos(y,x,n) - real*4 x(*),y(*) - do 10 j=1,n - y(j)=cos(x(j)) - 10 continue - return - end - - subroutine vcosisin(y,x,n) - complex*16 y(*) - real*8 x(*) - do 10 j=1,n - y(j)=dcmplx(cos(x(j)),sin(x(j))) - 10 continue - return - end - - subroutine vscosisin(y,x,n) - complex*8 y(*) - real*4 x(*) - do 10 j=1,n - y(j)= cmplx(cos(x(j)),sin(x(j))) - 10 continue - return - end - - subroutine vdint(y,x,n) - real*8 x(*),y(*) - do 10 j=1,n -! y(j)=dint(x(j)) - y(j)=int(x(j)) - 10 continue - return - end - - subroutine vdnint(y,x,n) - real*8 x(*),y(*) - do 10 j=1,n -! y(j)=dnint(x(j)) - y(j)=nint(x(j)) - 10 continue - return - end - - subroutine vlog10(y,x,n) - real*8 x(*),y(*) - do 10 j=1,n - y(j)=log10(x(j)) - 10 continue - return - end - -! subroutine vlog1p(y,x,n) -! real*8 x(*),y(*) -! interface -! real*8 function log1p(%val(x)) -! real*8 x -! end function log1p -! end interface -! do 10 j=1,n -! y(j)=log1p(x(j)) -! 10 continue -! return -! end - - subroutine vcosh(y,x,n) - real*8 x(*),y(*) - do 10 j=1,n - y(j)=cosh(x(j)) - 10 continue - return - end - - subroutine vsinh(y,x,n) - real*8 x(*),y(*) - do 10 j=1,n - y(j)=sinh(x(j)) - 10 continue - return - end - - subroutine vtanh(y,x,n) - real*8 x(*),y(*) - do 10 j=1,n - y(j)=tanh(x(j)) - 10 continue - return - end - -! subroutine vexpm1(y,x,n) -! real*8 x(*),y(*) -! interface -! real*8 function expm1(%val(x)) -! real*8 x -! end function expm1 -! end interface -! do 10 j=1,n -! y(j)=expm1(x(j)) -! 10 continue -! return -! end - - - subroutine vsasin(y,x,n) - real*4 x(*),y(*) - do 10 j=1,n - y(j)=asin(x(j)) - 10 continue - return - end - - subroutine vsacos(y,x,n) - real*4 x(*),y(*) - do 10 j=1,n - y(j)=acos(x(j)) - 10 continue - return - end - - subroutine vscosh(y,x,n) - real*4 x(*),y(*) - do 10 j=1,n - y(j)=cosh(x(j)) - 10 continue - return - end - -! subroutine vsexpm1(y,x,n) -! real*4 x(*),y(*) -! interface -! real*8 function expm1(%val(x)) -! real*8 x -! end function expm1 -! end interface -! do 10 j=1,n -! y(j)=expm1(real(x(j),8)) -! 10 continue -! return -! end - - subroutine vslog10(y,x,n) - real*4 x(*),y(*) - do 10 j=1,n - y(j)=log10(x(j)) - 10 continue - return - end - -! subroutine vslog1p(y,x,n) -! real*4 x(*),y(*) -! interface -! real*8 function log1p(%val(x)) -! real*8 x -! end function log1p -! end interface -! do 10 j=1,n -! y(j)=log1p(real(x(j),8)) -! 10 continue -! return -! end - - - subroutine vssinh(y,x,n) - real*4 x(*),y(*) - do 10 j=1,n - y(j)=sinh(x(j)) - 10 continue - return - end - - subroutine vstanh(y,x,n) - real*4 x(*),y(*) - do 10 j=1,n - y(j)=tanh(x(j)) - 10 continue - return - end -#endif - - subroutine vspow(z,y,x,n) - real*4 x(*),y(*),z(*) - do 10 j=1,n - z(j)=y(j)**x(j) - 10 continue - return - end - - subroutine vpow(z,y,x,n) - real*8 x(*),y(*),z(*) - do 10 j=1,n - z(j)=y(j)**x(j) - 10 continue - return - end - diff --git a/src/fim/FIMsrc/fim/wrfphys/module_cu_bmj.F b/src/fim/FIMsrc/fim/wrfphys/module_cu_bmj.F deleted file mode 100644 index 9fdd7d4..0000000 --- a/src/fim/FIMsrc/fim/wrfphys/module_cu_bmj.F +++ /dev/null @@ -1,2104 +0,0 @@ -!----------------------------------------------------------------------- -! -!WRF:MODEL_LAYER:PHYSICS -! -!----------------------------------------------------------------------- -! - MODULE MODULE_CU_BMJ -! -!----------------------------------------------------------------------- - USE MODULE_MODEL_CONSTANTS -!----------------------------------------------------------------------- -! - REAL,PARAMETER :: & - & DSPC=-3000. & - & ,DTTOP=0.,EFIFC=5.0,EFIMN=0.20,EFMNT=0.70 & - & ,ELIWV=2.683E6,ENPLO=20000.,ENPUP=15000. & - & ,EPSDN=1.05,EPSDT=0. & - & ,EPSNTP=.0001,EPSNTT=.0001,EPSPR=1.E-7 & - & ,EPSUP=1.00 & - & ,FR=1.00,FSL=0.85,FSS=0.85 & - & ,FUP=0. & - & ,PBM=13000.,PFRZ=15000.,PNO=1000. & - & ,PONE=2500.,PQM=20000. & - & ,PSH=20000.,PSHU=45000. & - & ,RENDP=1./(ENPLO-ENPUP) & - & ,RHLSC=0.00,RHHSC=1.10 & - & ,ROW=1.E3 & - & ,STABDF=0.90,STABDS=0.90 & - & ,STABS=1.0,STRESH=1.10 & - & ,DTSHAL=-1.0,TREL=2400. -! - REAL,PARAMETER :: DTtrigr=-0.0 & - ,DTPtrigr=DTtrigr*PONE !<-- Average parcel virtual temperature deficit over depth PONE. - !<-- NOTE: CAPEtrigr is scaled by the cloud base temperature (see below) -! - REAL,PARAMETER :: DSPBFL=-3875.*FR & - & ,DSP0FL=-5875.*FR & - & ,DSPTFL=-1875.*FR & - & ,DSPBFS=-3875. & - & ,DSP0FS=-5875. & - & ,DSPTFS=-1875. -! - REAL,PARAMETER :: PL=2500.,PLQ=70000.,PH=105000. & - & ,THL=210.,THH=365.,THHQ=325. -! - INTEGER,PARAMETER :: ITB=76,JTB=134,ITBQ=152,JTBQ=440 -! - INTEGER,PARAMETER :: ITREFI_MAX=3 -! -!*** ARRAYS FOR LOOKUP TABLES -! - REAL,DIMENSION(ITB),PRIVATE,SAVE :: STHE,THE0 - REAL,DIMENSION(JTB),PRIVATE,SAVE :: QS0,SQS - REAL,DIMENSION(ITBQ),PRIVATE,SAVE :: STHEQ,THE0Q - REAL,DIMENSION(ITB,JTB),PRIVATE,SAVE :: PTBL - REAL,DIMENSION(JTB,ITB),PRIVATE,SAVE :: TTBL - REAL,DIMENSION(JTBQ,ITBQ),PRIVATE,SAVE :: TTBLQ - -!*** SHARE COPIES FOR MODULE_BL_MYJPBL -! - REAL,DIMENSION(JTB) :: QS0_EXP,SQS_EXP - REAL,DIMENSION(ITB,JTB) :: PTBL_EXP -! - REAL,PARAMETER :: RDP=(ITB-1.)/(PH-PL),RDPQ=(ITBQ-1.)/(PH-PLQ) & - & ,RDQ=ITB-1,RDTH=(JTB-1.)/(THH-THL) & - & ,RDTHE=JTB-1.,RDTHEQ=JTBQ-1. & - & ,RSFCP=1./101300. -! - REAL,PARAMETER :: AVGEFI=(EFIMN+1.)*0.5 -! -!----------------------------------------------------------------------- -! -CONTAINS -! -!----------------------------------------------------------------------- - SUBROUTINE BMJDRV( & - & IDS,IDE,JDS,JDE,KDS,KDE & - & ,IMS,IME,JMS,JME,KMS,KME & - & ,ITS,ITE,JTS,JTE,KTS,KTE & - & ,DT,ITIMESTEP,STEPCU & - & ,CUDT, CURR_SECS, ADAPT_STEP_FLAG & - & ,RAINCV,PRATEC,CUTOP,CUBOT,KPBL & - & ,TH,T,QV & - & ,PINT,PMID,PI,RHO,DZ8W & - & ,CP,R,ELWV,ELIV,G,TFRZ,D608 & - & ,CLDEFI,LOWLYR,XLAND,CU_ACT_FLAG & - ! optional - & ,RTHCUTEN, RQVCUTEN & - & ) -!----------------------------------------------------------------------- - IMPLICIT NONE -!----------------------------------------------------------------------- - INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & - & ,IMS,IME,JMS,JME,KMS,KME & - & ,ITS,ITE,JTS,JTE,KTS,KTE -! - INTEGER,INTENT(IN) :: ITIMESTEP,STEPCU -! - INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: KPBL,LOWLYR -! - REAL,INTENT(IN) :: CP,DT,ELIV,ELWV,G,R,TFRZ,D608 -! - REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: XLAND -! - REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: DZ8W & - & ,PI,PINT & - & ,PMID,QV & - & ,RHO,T,TH -! - REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) & - & ,OPTIONAL & - & ,INTENT(INOUT) :: RQVCUTEN,RTHCUTEN -! - REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: CLDEFI,RAINCV, & - PRATEC -! - REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: CUBOT,CUTOP -! - LOGICAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: CU_ACT_FLAG - -! Adaptive time-step variables - REAL, INTENT(IN ) :: CUDT - REAL, INTENT(IN ) :: CURR_SECS - LOGICAL,INTENT(IN ) :: ADAPT_STEP_FLAG -! -!----------------------------------------------------------------------- -!*** -!*** LOCAL VARIABLES -!*** -!----------------------------------------------------------------------- - INTEGER :: LBOT,LPBL,LTOP -! - REAL :: DTCNVC,LANDMASK,PCPCOL,PSFC,PTOP -! - REAL,DIMENSION(KTS:KTE) :: DPCOL,DQDT,DTDT,PCOL,QCOL,TCOL -! - INTEGER :: I,J,K,KFLIP,LMH - - LOGICAL :: run_param -! -!*** Begin debugging convection - REAL :: DELQ,DELT,PLYR - INTEGER :: IMD,JMD - LOGICAL :: PRINT_DIAG -!*** End debugging convection -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!*** PREPARE TO CALL BMJ CONVECTION SCHEME -! -!----------------------------------------------------------------------- -! -!*** CHECK TO SEE IF THIS IS A CONVECTION TIMESTEP -! - if (adapt_step_flag) then - if ( (ITIMESTEP .eq. 0) .or. (cudt .eq. 0) .or. & - ( CURR_SECS + dt >= ( int( CURR_SECS / ( cudt * 60 ) ) + 1 ) * cudt * 60 ) ) then - run_param = .TRUE. - else - run_param = .FALSE. - endif - - else - if (MOD(ITIMESTEP,STEPCU) .EQ. 0 .or. ITIMESTEP .eq. 0) then - run_param = .TRUE. - else - run_param = .FALSE. - endif - endif - -!----------------------------------------------------------------------- -! -!*** COMPUTE CONVECTION EVERY STEPCU*DT/60.0 MINUTES -! -!*** Begin debugging convection - IMD=(IMS+IME)/2 - JMD=(JMS+JME)/2 - PRINT_DIAG=.FALSE. -!*** End debugging convection - - IF(run_param)THEN -! - DO J=JTS,JTE - DO I=ITS,ITE - CU_ACT_FLAG(I,J)=.TRUE. - ENDDO - ENDDO - -! - DTCNVC=DT*STEPCU -! - DO J=JTS,JTE - DO I=ITS,ITE -! - DO K=KTS,KTE - DQDT(K)=0. - DTDT(K)=0. - ENDDO -! - RAINCV(I,J)=0. - PRATEC(I,J)=0. - PCPCOL=0. - PSFC=PINT(I,LOWLYR(I,J),J) - PTOP=PINT(I,KTE+1,J) ! KTE+1=KME -! -!*** CONVERT TO BMJ LAND MASK (1.0 FOR SEA; 0.0 FOR LAND) -! - LANDMASK=XLAND(I,J)-1. -! -!*** FILL 1-D VERTICAL ARRAYS -!*** AND FLIP DIRECTION SINCE BMJ SCHEME -!*** COUNTS DOWNWARD FROM THE DOMAIN'S TOP -! - DO K=KTS,KTE - KFLIP=KTE+1-K -! -!*** CONVERT FROM MIXING RATIO TO SPECIFIC HUMIDITY -! - QCOL(K)=MAX(EPSQ,QV(I,KFLIP,J)/(1.+QV(I,KFLIP,J))) - TCOL(K)=T(I,KFLIP,J) - PCOL(K)=PMID(I,KFLIP,J) -! DPCOL(K)=PINT(I,KFLIP,J)-PINT(I,KFLIP+1,J) - DPCOL(K)=RHO(I,KFLIP,J)*G*DZ8W(I,KFLIP,J) - ENDDO -! -!*** LOWEST LAYER ABOVE GROUND MUST ALSO BE FLIPPED -! - LMH=KTE+1-LOWLYR(I,J) - LPBL=KTE+1-KPBL(I,J) -!----------------------------------------------------------------------- -!*** -!*** CALL CONVECTION -!*** -!----------------------------------------------------------------------- -!*** Begin debugging convection -! PRINT_DIAG=.FALSE. -! IF(I==IMD.AND.J==JMD)PRINT_DIAG=.TRUE. -!*** End debugging convection -!----------------------------------------------------------------------- - CALL BMJ(ITIMESTEP,I,J,DTCNVC,LMH,LANDMASK,CLDEFI(I,J) & - & ,DPCOL,PCOL,QCOL,TCOL,PSFC,PTOP & - & ,DQDT,DTDT,PCPCOL,LBOT,LTOP,LPBL & - & ,CP,R,ELWV,ELIV,G,TFRZ,D608 & - & ,PRINT_DIAG & - & ,IDS,IDE,JDS,JDE,KDS,KDE & - & ,IMS,IME,JMS,JME,KMS,KME & - & ,ITS,ITE,JTS,JTE,KTS,KTE) -!----------------------------------------------------------------------- -! -!*** COMPUTE HEATING AND MOISTENING TENDENCIES -! - IF ( PRESENT( RTHCUTEN ) .AND. PRESENT( RQVCUTEN )) THEN - DO K=KTS,KTE - KFLIP=KTE+1-K - RTHCUTEN(I,K,J)=DTDT(KFLIP)/PI(I,K,J) -! -!*** CONVERT FROM SPECIFIC HUMIDTY BACK TO MIXING RATIO -! - RQVCUTEN(I,K,J)=DQDT(KFLIP)/(1.-QCOL(KFLIP))**2 - ENDDO - ENDIF -! -!*** ALL UNITS IN BMJ SCHEME ARE MKS, THUS CONVERT PRECIP FROM METERS -!*** TO MILLIMETERS PER STEP FOR OUTPUT. -! - RAINCV(I,J)=PCPCOL*1.E3/STEPCU - PRATEC(I,J)=PCPCOL*1.E3/(STEPCU * DT) -! -!*** CONVECTIVE CLOUD TOP AND BOTTOM FROM THIS CALL -! - CUTOP(I,J)=REAL(KTE+1-LTOP) - CUBOT(I,J)=REAL(KTE+1-LBOT) -! -!----------------------------------------------------------------------- -!*** Begin debugging convection - IF(PRINT_DIAG)THEN - DELT=0. - DELQ=0. - PLYR=0. - IF(LBOT>0.AND.LTOPHTOP follow physics leveling convention - - LOGICAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(INOUT) :: CU_ACT_FLAG - -! -! Optionals -! - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - OPTIONAL, & - INTENT(INOUT) :: RTHFTEN, & - RQVFTEN - - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - OPTIONAL, & - INTENT(IN ) :: & - RTHRATEN, & - RTHBLTEN, & - RQVBLTEN - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - OPTIONAL, & - INTENT(INOUT) :: & - RTHCUTEN, & - RQVCUTEN, & - RQCCUTEN, & - RQICUTEN -! -! Flags relating to the optional tendency arrays declared above -! Models that carry the optional tendencies will provdide the -! optional arguments at compile time; these flags all the model -! to determine at run-time whether a particular tracer is in -! use or not. -! - LOGICAL, OPTIONAL :: & - F_QV & - ,F_QC & - ,F_QR & - ,F_QI & - ,F_QS - - - -! LOCAL VARS - real, dimension ( ims:ime , jms:jme , 1:ensdim) :: & - massfln,xf_ens,pr_ens - real, dimension (its:ite,kts:kte+1) :: & - OUTT,OUTQ,OUTQC,phh,cupclw - real, dimension (its:ite,kts:kte+1) :: phf - real, dimension (its:ite) :: & - pret, ter11, aa0, fp -!+lxz - integer, dimension (its:ite) :: & - kbcon, ktop, ierr -!.lxz - integer, dimension (its:ite,jts:jte) :: & - iact_old_gr - integer :: ichoice,iens,ibeg,iend,jbeg,jend,isum - -! -! basic environmental input includes moisture convergence (mconv) -! omega (omeg), windspeed (us,vs), and a flag (aaeq) to turn off -! convection for this call only and at that particular gridpoint -! - real, dimension (its:ite,kts:kte+1) :: & - T2d,TN,q2d,qo,PO,P2d,US,VS,omeg,pdot - real, dimension (its:ite) :: & - Z1,PSUR,AAEQ,direction,mconv,cuten,umean,vmean,pmean - - INTEGER :: i,j,k,ICLDCK,ipr,jpr - REAL :: tcrit,dp,dq,dpm1,dpm0,dpp1,dpall - INTEGER :: itf,jtf,ktf - REAL :: rkbcon,rktop !-lxz - - ichoice=0 - iens=1 - ipr=1 - jpr=0 -! jpr=3077 -! ipr=0 - - ibeg=its - iend=ite - jbeg=jts - jend=jte - - tcrit=258. - - itf=ite - ktf=kte - jtf=jte -! write(6,*)'ibeg,iend,jts,jtf,dt= ',ibeg,iend,jts,jtf,dt -! - isum=0 - DO 100 J = jts,jtf - DO I= its,itf - ierr(i)=0. - cuten(i)=0. - iact_old_gr(i,j)=0 - mass_flux(i,j)=0. - pratec(i,j) = 0. - raincv(i,j)=0. - CU_ACT_FLAG(i,j) = .true. - ENDDO - DO k=1,ensdim - DO I= its,itf - massfln(i,j,k)=0. - ENDDO - ENDDO -!j#if ( EM_CORE == 1 ) -! DO k= kts,ktf -! DO I= its,itf -! RTHFTEN(i,k,j)=(RTHFTEN(i,k,j)+RTHRATEN(i,k,j)+RTHBLTEN(i,k,j))*pi(i,k,j) -! RQVFTEN(i,k,j)=RQVFTEN(i,k,j)+RQVBLTEN(i,k,j) -! ENDDO -! ENDDO -! ! hydrostatic pressure, first on full levels -! DO I=ITS,ITF -! phf(i,1) = p8w(i,1,j) -! ENDDO -! ! integrate up, dp = -rho * g * dz -! DO K=kts+1,ktf+1 -! DO I=ITS,ITF -! phf(i,k) = phf(i,k-1) - rho(i,k-1,j) * g * dz8w(i,k-1,j) -! ENDDO -! ENDDO -! ! scale factor so that pressure is not zero after integration -! DO I=ITS,ITF -! fp(i) = (p8w(i,kts,j)-p8w(i,kte,j))/(phf(i,kts)-phf(i,kte)) -! ENDDO -! ! re-integrate up, dp = -rho * g * dz * scale_factor -! DO K=kts+1,ktf+1 -! DO I=ITS,ITF -! phf(i,k) = phf(i,k-1) - rho(i,k-1,j) * g * dz8w(i,k-1,j) * fp(i) -! ENDDO -! ENDDO -! ! put hydrostatic pressure on half levels -! DO K=kts,ktf -! DO I=ITS,ITF -! phh(i,k) = (phf(i,k) + phf(i,k+1))*0.5 -! ENDDO -! ENDDO -!#endif - DO I=ITS,ITF -!#if ( EM_CORE == 1 ) - PSUR(I)=p8w(I,1,J)*.01 -!#endif -!#if ( NMM_CORE == 1 ) -! PSUR(I)=p(I,1,J)*.01 -!#endif - TER11(I)=HT(i,j) - mconv(i)=0. - aaeq(i)=0. - direction(i)=0. - pret(i)=0. - umean(i)=0. - vmean(i)=0. - pmean(i)=0. - ktop(i) = 0 - kbcon(i) = 1000 - htop(i,j)= 0. - hbot(i,j)=1000. - ENDDO - DO K=kts,ktf - DO I=ITS,ITF - omeg(i,k)=0. - cupclw(i,k)=0. -!#if ( EM_CORE == 1 ) -! po(i,k)=phh(i,k)*.01 -!#endif - -!#if ( NMM_CORE == 1 ) - po(i,k)=p(i,k,j)*.01 -!#endif - P2d(I,K)=PO(i,k) - US(I,K) =u(i,k,j) - VS(I,K) =v(i,k,j) - T2d(I,K)=t(i,k,j) - q2d(I,K)=q(i,k,j) - omeg(I,K)= -g*rho(i,k,j)*w(i,k,j) - pdot(i,k)=.01*omeg(i,k) - TN(I,K)=t2d(i,k)+RTHFTEN(i,k,j)*dt - IF(TN(I,K).LT.150.)TN(I,K)=T2d(I,K) - QO(I,K)=q2d(i,k)+RQVFTEN(i,k,j)*dt - IF(Q2d(I,K).LT.1.E-08)Q2d(I,K)=1.E-08 - IF(QO(I,K).LT.1.E-08)QO(I,K)=1.E-08 - OUTT(I,K)=0. - OUTQ(I,K)=0. - OUTQC(I,K)=0. - if(j.eq.jpr)then - write(6,*)k,p2d(i,k),t2d(i,k),tn(i,k),ht(i,j) - write(6,*)'2',rqvften(i,k,j),q2d(i,k),QO(i,k) - write(6,*)'3',rthblten(i,k,j),rthraten(i,k,j),RQVBLTEN(i,k,j) - endif -! RTHFTEN(i,k,j)=0. -! RQVFTEN(i,k,j)=0. - ENDDO - ENDDO - do k= kts+1,ktf-1 - DO I = its,itf - if((p2d(i,1)-p2d(i,k)).gt.150.and.p2d(i,k).gt.300)then - dp=-.5*(p2d(i,k+1)-p2d(i,k-1)) - umean(i)=umean(i)+us(i,k)*dp - vmean(i)=vmean(i)+vs(i,k)*dp - pmean(i)=pmean(i)+dp - endif - enddo - enddo - DO I = its,itf - umean(i)=umean(i)/pmean(i) - vmean(i)=vmean(i)/pmean(i) - direction(i)=(atan2(umean(i),vmean(i))+3.1415926)*57.29578 - if(direction(i).gt.360.)direction(i)=direction(i)-360. - ENDDO - DO K=kts,ktf-1 - DO I = its,itf - dq=(q2d(i,k+1)-q2d(i,k)) - mconv(i)=mconv(i)+omeg(i,k)*dq/g - if(j.eq.jpr)then - write(6,*)'4',k,p2d(i,k),mconv(i),omeg(i,k) - endif - ENDDO - ENDDO - DO I = its,itf - if(mconv(i).lt.0.)mconv(i)=0. - ENDDO -! -!---- CALL CUMULUS PARAMETERIZATION -! - CALL CUP_enss(pdot,outqc,j,AAEQ,T2d,Q2d,TER11,TN,QO,PO,PRET, & - P2d,OUTT,OUTQ,DT,PSUR,US,VS,tcrit,iens, & - mconv,massfln,iact_old_gr,omeg,direction,MASS_FLUX, & - maxiens,maxens,maxens2,maxens3,ensdim, & - APR_GR,APR_W,APR_MC,APR_ST,APR_AS, & - APR_CAPMA,APR_CAPME,APR_CAPMI,kbcon,ktop, & - ierr,xf_ens,pr_ens,XLAND,gsw,cupclw, & - xlv,r_v,cp,g,ichoice,ipr,jpr, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - - CALL neg_check(dt,q2d,outq,outt,outqc,pret,its,ite,kts,kte,itf,ktf) - if(j.ge.jbeg.and.j.le.jend)then - DO I=its,itf -! cuten(i)=0. - if(i.ge.ibeg.and.i.le.iend)then -! write(6,*)'final pret ',ierr(i),j,pret(i),ht(i,j) - if(pret(i).gt.0.)then - isum=isum+1 -! if(j.eq.jpr)write(6,*)'final pret ',i,j,pret(i) - pratec(i,j)=pret(i) - raincv(i,j)=pret(i)! *dt - cuten(i)=1. - rkbcon = kte+kts - kbcon(i) - rktop = kte+kts - ktop(i) -! if (ktop(i) > HTOP(i,j)) HTOP(i,j) = ktop(i)+.001 -! if (kbcon(i) < HBOT(i,j)) HBOT(i,j) = kbcon(i)+.001 - HTOP(i,j) = ktop(i)+.001 - HBOT(i,j) = kbcon(i)+.001 - endif - else - pret(i)=0. - endif - ENDDO - K=kts - DO K=kts,ktf-2 - DO I=its,itf - RTHCUTEN(I,K,J)=outt(i,k)*cuten(i)/pi(i,k,j) - RQVCUTEN(I,K,J)=outq(i,k)*cuten(i) - ENDDO - ENDDO - DO K=kts+1,ktf-2 - DO I=its,itf - dpm1=p8w(i,k-1,j)-p8w(i,k,j) - dpm0=p8w(i,k,j)-p8w(i,k+1,j) - dpp1=p8w(i,k+1,j)-p8w(i,k+2,j) - dpall=.25*(p8w(i,k-1,j)-p8w(i,k+2,j)) -! RTHCUTEN(I,K,J)=(.25*dpm1*outt(i,k-1)/pi(i,k-1,j) & -! +.5*dpm0*outt(i,k)/pi(i,k,j) & -! +.25*dpp1*outt(i,k+1)/pi(i,k+1,j))*cuten(i)/dpall -! RQVCUTEN(I,K,J)=.25*(dpm1*outq(i,k-1)+2.*dpm0*outq(i,k) & -! +dpp1*outq(i,k+1))*cuten(i)/dpall - RTHCUTEN(I,K,J)=(.25*dpm1*outt(i,k-1)+.5*dpm0*outt(i,k) & - +.25*dpp1*outt(i,k+1))*cuten(i)/dpall/pi(i,k,j) - RQVCUTEN(I,K,J)=.25*(dpm1*outq(i,k-1)+2.*dpm0*outq(i,k) & - +dpp1*outq(i,k+1))*cuten(i)/dpall -! RTHCUTEN(I,K,J)=(.25*outt(i,k-1)+.5*outt(i,k) & -! +.25*outt(i,k+1))*cuten(i)/pi(i,k,j) -! RQVCUTEN(I,K,J)=.25*(outq(i,k-1)+2.*outq(i,k) & -! +outq(i,k+1))*cuten(i) -! if(j.eq.jpr)then -! write(6,*)'dthdt,dqdt,dtdt = ',k,RTHCUTEN(I,K,J),RQVCUTEN(I,K,J),outt(i,k) -! endif - ENDDO - ENDDO -! if(j.eq.3077 .and. itimestep.eq.2)then -! DO K=kts,ktf-1 -! DO I=its,itf -! write(12,*)p2d(i,k),RTHCUTEN(I,K,J)*pi(i,k,j) -! write(13,*)p2d(i,k),RQVCUTEN(I,K,J) -! ENDDO -! ENDDO -! endif - - IF(PRESENT(RQCCUTEN)) THEN - IF ( F_QC ) THEN - DO K=kts,ktf - DO I=its,itf - RQCCUTEN(I,K,J)=outqc(I,K)*cuten(i) - IF ( PRESENT( GDC ) ) GDC(I,K,J)=CUPCLW(I,K)*cuten(i) - IF ( PRESENT( GDC2 ) ) GDC2(I,K,J)=0. - ENDDO - ENDDO - ENDIF - ENDIF - -!...... QSTEN STORES GRAUPEL TENDENCY IF IT EXISTS, OTHERISE SNOW (V2) - - IF(PRESENT(RQICUTEN).AND.PRESENT(RQCCUTEN))THEN - IF (F_QI) THEN - DO K=kts,ktf - DO I=its,itf - if(t2d(i,k).lt.258.)then - RQICUTEN(I,K,J)=outqc(I,K)*cuten(i) - RQCCUTEN(I,K,J)=0. - IF ( PRESENT( GDC2 ) ) GDC2(I,K,J)=CUPCLW(I,K)*cuten(i) - else - RQICUTEN(I,K,J)=0. - RQCCUTEN(I,K,J)=outqc(I,K)*cuten(i) - IF ( PRESENT( GDC ) ) GDC(I,K,J)=CUPCLW(I,K)*cuten(i) - endif - ENDDO - ENDDO - ENDIF - ENDIF - endif !jbeg,jend - - 100 continue -! write(6,*)'!!!!!!!!! isum = ',isum - - END SUBROUTINE GRELLDRV - - - SUBROUTINE CUP_enss(pdot,OUTQC,J,AAEQ,T,Q,Z1, & - TN,QO,PO,PRE,P,OUTT,OUTQ,DTIME,PSUR,US,VS, & - TCRIT,iens,mconv,massfln,iact, & - omeg,direction,massflx,maxiens, & - maxens,maxens2,maxens3,ensdim, & - APR_GR,APR_W,APR_MC,APR_ST,APR_AS, & - APR_CAPMA,APR_CAPME,APR_CAPMI,kbcon,ktop, & !-lxz - ierr,xf_ens,pr_ens,xland,gsw,cupclw, & - xl,rv,cp,g,ichoice,ipr,jpr, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE - - real :: cthk,cincrmax,cincrmin,dthk,val1,val2 - parameter(cthk=150.,cincrmax=180.,cincrmin=120.,dthk=25.) - - integer & - ,intent (in ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte,ipr,jpr - integer, intent (in ) :: & - j,ensdim,maxiens,maxens,maxens2,maxens3,ichoice,iens - ! - ! - ! - real, dimension (ims:ime,jms:jme,1:ensdim) & - ,intent (inout) :: & - massfln,xf_ens,pr_ens - real, dimension (ims:ime,jms:jme) & - ,intent (inout ) :: & - APR_GR,APR_W,APR_MC,APR_ST,APR_AS,APR_CAPMA, & - APR_CAPME,APR_CAPMI,massflx - real, dimension (ims:ime,jms:jme) & - ,intent (in ) :: & - xland,gsw - integer, dimension (its:ite,jts:jte) & - ,intent (in ) :: & - iact - ! outtem = output temp tendency (per s) - ! outq = output q tendency (per s) - ! outqc = output qc tendency (per s) - ! pre = output precip - real, dimension (its:ite,kts:kte) & - ,intent (out ) :: & - OUTT,OUTQ,OUTQC,CUPCLW - real, dimension (its:ite) & - ,intent (out ) :: & - pre -!+lxz - integer, dimension (its:ite) & - ,intent (out ) :: & - kbcon,ktop -!.lxz - ! - ! basic environmental input includes moisture convergence (mconv) - ! omega (omeg), windspeed (us,vs), and a flag (aaeq) to turn off - ! convection for this call only and at that particular gridpoint - ! - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - T,TN,PO,P,US,VS,omeg,pdot - real, dimension (its:ite,kts:kte) & - ,intent (inout) :: & - Q,QO - real, dimension (its:ite) & - ,intent (in ) :: & - Z1,PSUR,AAEQ,direction,mconv - - - real & - ,intent (in ) :: & - dtime,tcrit,xl,cp,rv,g - - -! -! local ensemble dependent variables in this routine -! - real, dimension (its:ite,1:maxens) :: & - xaa0_ens - real, dimension (1:maxens) :: & - mbdt_ens - real, dimension (1:maxens2) :: & - edt_ens - real, dimension (its:ite,1:maxens2) :: & - edtc - real, dimension (its:ite,kts:kte,1:maxens2) :: & - dellat_ens,dellaqc_ens,dellaq_ens,pwo_ens -! -! -! -!***************** the following are your basic environmental -! variables. They carry a "_cup" if they are -! on model cloud levels (staggered). They carry -! an "o"-ending (z becomes zo), if they are the forced -! variables. They are preceded by x (z becomes xz) -! to indicate modification by some typ of cloud -! - ! z = heights of model levels - ! q = environmental mixing ratio - ! qes = environmental saturation mixing ratio - ! t = environmental temp - ! p = environmental pressure - ! he = environmental moist static energy - ! hes = environmental saturation moist static energy - ! z_cup = heights of model cloud levels - ! q_cup = environmental q on model cloud levels - ! qes_cup = saturation q on model cloud levels - ! t_cup = temperature (Kelvin) on model cloud levels - ! p_cup = environmental pressure - ! he_cup = moist static energy on model cloud levels - ! hes_cup = saturation moist static energy on model cloud levels - ! gamma_cup = gamma on model cloud levels -! -! - ! hcd = moist static energy in downdraft - ! zd normalized downdraft mass flux - ! dby = buoancy term - ! entr = entrainment rate - ! zd = downdraft normalized mass flux - ! entr= entrainment rate - ! hcd = h in model cloud - ! bu = buoancy term - ! zd = normalized downdraft mass flux - ! gamma_cup = gamma on model cloud levels - ! mentr_rate = entrainment rate - ! qcd = cloud q (including liquid water) after entrainment - ! qrch = saturation q in cloud - ! pwd = evaporate at that level - ! pwev = total normalized integrated evaoprate (I2) - ! entr= entrainment rate - ! z1 = terrain elevation - ! entr = downdraft entrainment rate - ! jmin = downdraft originating level - ! kdet = level above ground where downdraft start detraining - ! psur = surface pressure - ! z1 = terrain elevation - ! pr_ens = precipitation ensemble - ! xf_ens = mass flux ensembles - ! massfln = downdraft mass flux ensembles used in next timestep - ! omeg = omega from large scale model - ! mconv = moisture convergence from large scale model - ! zd = downdraft normalized mass flux - ! zu = updraft normalized mass flux - ! dir = "storm motion" - ! mbdt = arbitrary numerical parameter - ! dtime = dt over which forcing is applied - ! iact_gr_old = flag to tell where convection was active - ! kbcon = LFC of parcel from k22 - ! k22 = updraft originating level - ! icoic = flag if only want one closure (usually set to zero!) - ! dby = buoancy term - ! ktop = cloud top (output) - ! xmb = total base mass flux - ! hc = cloud moist static energy - ! hkb = moist static energy at originating level - ! mentr_rate = entrainment rate - - real, dimension (its:ite,kts:kte) :: & - he,hes,qes,z, & - heo,heso,qeso,zo, & - xhe,xhes,xqes,xz,xt,xq, & - - qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup, & - qeso_cup,qo_cup,heo_cup,heso_cup,zo_cup,po_cup,gammao_cup, & - tn_cup, & - xqes_cup,xq_cup,xhe_cup,xhes_cup,xz_cup,xp_cup,xgamma_cup, & - xt_cup, & - - dby,qc,qrcd,pwd,pw,hcd,qcd,dbyd,hc,qrc,zu,zd,clw_all, & - dbyo,qco,qrcdo,pwdo,pwo,hcdo,qcdo,dbydo,hco,qrco,zuo,zdo, & - xdby,xqc,xqrcd,xpwd,xpw,xhcd,xqcd,xhc,xqrc,xzu,xzd, & - - ! cd = detrainment function for updraft - ! cdd = detrainment function for downdraft - ! dellat = change of temperature per unit mass flux of cloud ensemble - ! dellaq = change of q per unit mass flux of cloud ensemble - ! dellaqc = change of qc per unit mass flux of cloud ensemble - - cd,cdd,scr1,DELLAH,DELLAQ,DELLAT,DELLAQC - - ! aa0 cloud work function for downdraft - ! edt = epsilon - ! aa0 = cloud work function without forcing effects - ! aa1 = cloud work function with forcing effects - ! xaa0 = cloud work function with cloud effects (ensemble dependent) - ! edt = epsilon - real, dimension (its:ite) :: & - edt,edto,edtx,AA1,AA0,XAA0,HKB,HKBO,aad,XHKB,QKB,QKBO, & - XMB,XPWAV,XPWEV,PWAV,PWEV,PWAVO,PWEVO,BU,BUO,cap_max,xland1, & - cap_max_increment,closure_n,xmbmax,pbcdif - integer, dimension (its:ite) :: & - kzdown,KDET,K22,KB,JMIN,kstabi,kstabm,K22x, & !-lxz - KBCONx,KBx,KTOPx,ierr,ierr2,ierr3,KBMAX - - integer :: & - nall,iedt,nens,nens3,ki,I,K,KK,iresult - real :: & - day,dz,mbdt,entr_rate,radius,entrd_rate,mentr_rate,mentrd_rate, & - zcutdown,edtmax,edtmin,depth_min,zkbmax,z_detr,zktop, & - massfld,dh,cap_maxs -! thorpex 20110506 - mods to implement SAS downdraft detrainment - real :: & - xlamdd,xlamde,beta,dp -! thorpex 20110511 - mods to implement SAS updraft (en/de)trainment - real :: & - clam,clam2,clam3,cxlamu,cxlamu2,cxlamu3, & - fent1,fent2,pgcon,tem,tem1,frh,w1,w1l,w1s,w2,w2l,& - w2s,w3,w3l,w3s,w4,w4l,w4s,dzmax - real, dimension (its:ite,kts:kte) :: & - xlamue,xlamue_sflx,xlamue3 - real, dimension (its:ite) :: & - cincr,xlamud,xlamud_sflx,xlamud3 - - - integer :: itf,jtf,ktf,jprt - integer :: jmini - logical :: keep_going - logical, dimension (its:ite) :: flg - w1l = -8.e-3 - w2l = -4.e-2 - w3l = -5.e-3 - w4l = -5.e-4 - w1s = -2.e-4 - w2s = -2.e-3 - w3s = -1.e-3 - w4s = -2.e-5 - w1=w1l - w2=w2l - w3=w3l - w4=w4l - pbcdif(:) = 0. - cincr(:) = 0. - - - itf=ite - ktf=kte - jtf=jte - -!sms$distribute end - day=86400. -!TBH if(j.eq.jpr)write(6,*)'in cup_enss' - do i=its,itf - closure_n(i)=16. - xland1(i)=1. - if(xland(i,j).gt.1.5)xland1(i)=0. - cap_max_increment(i)=25. - enddo -! -!--- specify entrainmentrate and detrainmentrate -! - if(iens.le.4)then - radius=14000.-float(iens)*2000. - else - radius=12000. - endif -! -!--- gross entrainment rate (these may be changed later on in the -!--- program, depending what your detrainment is!!) -! - entr_rate=.2/radius - -! -!--- entrainment of mass -! -! thorpex 20110506 - adopted from SAS -! entrainment coefficients - cxlamu = 1.0e-4 - cxlamu2 = 1.0e-4 - clam = .1 - clam2 = .1 - clam3 = .1 - pgcon = 0.55 ! Zhang & Wu (2003,JAS) -! detrainment coefficients - xlamde = 1.0e-4 - xlamdd = 1.0e-4 - beta = .05 - mentrd_rate=xlamde - mentr_rate=entr_rate - xlamue(:,:) = 0. - xlamud(:) = 0. - -! -!--- initial detrainmentrates -! - do k=kts,ktf - do i=its,itf - cupclw(i,k)=0. - cd(i,k)=0.1*entr_rate - cdd(i,k)=0. - enddo - enddo -! -!--- max/min allowed value for epsilon (ratio downdraft base mass flux/updraft -! base mass flux -! - edtmax=.3 - edtmin=.0 -! -!--- minimum depth (m), clouds must have -! - depth_min=500. -! -!--- maximum depth (mb) of capping -!--- inversion (larger cap = no convection) -! - cap_maxs=100. -!sms$to_local(grid_dh: <1, mix :size>, <2, mjx :size>) begin - DO 7 i=its,itf - kbmax(i)=1 - aa0(i)=0. - aa1(i)=0. - aad(i)=0. - edt(i)=0. - kstabm(i)=ktf-1 - IERR(i)=0 - IERR2(i)=0 - IERR3(i)=0 - if(aaeq(i).lt.-1.)then - ierr(i)=20 - endif - 7 CONTINUE -! -!--- first check for upstream convection -! - do i=its,itf - cap_max(i)=cap_maxs -! if(tkmax(i,j).lt.2.)cap_max(i)=25. -! if(gsw(i,j).lt.1.)cap_max(i)=25. - - iresult=0 -! massfld=0. -! call cup_direction2(i,j,direction,iact, & -! cu_mfx,iresult,0,massfld, & -! ids,ide, jds,jde, kds,kde, & -! ims,ime, jms,jme, kms,kme, & -! its,ite, jts,jte, kts,kte) -! cap_max(i)=cap_maxs - if(iresult.eq.1)then - cap_max(i)=cap_maxs+20. - endif -! endif - enddo -! -!--- max height(m) above ground where updraft air can originate -! - zkbmax=4000. -! -!--- height(m) above which no downdrafts are allowed to originate -! - zcutdown=3000. -! -!--- depth(m) over which downdraft detrains all its mass -! - z_detr=1250. -! - do nens=1,maxens - mbdt_ens(nens)=(float(nens)-3.)*dtime*1.e-3+dtime*5.E-03 - enddo - do nens=1,maxens2 - edt_ens(nens)=.95-float(nens)*.01 - enddo -! if(j.eq.jpr)then -! print *,'radius ensemble ',iens,radius -! print *,mbdt_ens -! print *,edt_ens -! endif -! -!--- environmental conditions, FIRST HEIGHTS -! - do i=its,itf - if(ierr(i).ne.20)then - do k=1,maxens*maxens2*maxens3 - xf_ens(i,j,(iens-1)*maxens*maxens2*maxens3+k)=0. - pr_ens(i,j,(iens-1)*maxens*maxens2*maxens3+k)=0. - enddo - endif - enddo -! -!--- calculate moist static energy, heights, qes -! - call cup_env(z,qes,he,hes,t,q,p,z1, & - psur,ierr,tcrit,0,xl,cp, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - call cup_env(zo,qeso,heo,heso,tn,qo,po,z1, & - psur,ierr,tcrit,0,xl,cp, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) -! -!--- environmental values on cloud levels -! - call cup_env_clev(t,qes,q,he,hes,z,p,qes_cup,q_cup,he_cup, & - hes_cup,z_cup,p_cup,gamma_cup,t_cup,psur, & - ierr,z1,xl,rv,cp, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - call cup_env_clev(tn,qeso,qo,heo,heso,zo,po,qeso_cup,qo_cup, & - heo_cup,heso_cup,zo_cup,po_cup,gammao_cup,tn_cup,psur, & - ierr,z1,xl,rv,cp, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - do i=its,itf - if(ierr(i).eq.0)then -! - do k=kts,ktf-2 - if(zo_cup(i,k).gt.zkbmax+z1(i))then - kbmax(i)=k - go to 25 - endif - enddo - 25 continue -! -! -!--- level where detrainment for downdraft starts -! - do k=kts,ktf - if(zo_cup(i,k).gt.z_detr+z1(i))then - kdet(i)=k - go to 26 - endif - enddo - 26 continue -! - endif - enddo -! -! -! -!------- DETERMINE LEVEL WITH HIGHEST MOIST STATIC ENERGY CONTENT - K22 -!-------- start with level2, first cup level is ground -! - CALL cup_MAXIMI(HEO_CUP,2,KBMAX,K22,ierr, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - DO 36 i=its,itf - IF(ierr(I).eq.0.)THEN - IF(K22(I).GE.KBMAX(i))ierr(i)=2 - endif - 36 CONTINUE -! -! look for the level of free convection as cloud base -from SAS option -! - do i=its,itf - kbcon(i) = ktf - flg(i)=.true. - enddo - do k = 2, ktf-1 - do i=its,itf - if (flg(i) .and. ierr(i).eq.0 .and. k.le.kbmax(i)) then - if(k.gt.k22(i).and.heo_cup(i,k22(i)).gt.heso_cup(i,k)) then - kbcon(i) = k - flg(i) = .false. - endif - endif - enddo - enddo - do i=its,itf - if(ierr(i).eq.0)then - if(kbcon(i).eq.ktf) ierr(i) = 3 - endif - enddo - -! -!--- DETERMINE THE LEVEL OF CONVECTIVE CLOUD BASE - KBCON -! - -! determine critical convective inhibition -! as a function of vertical velocity at cloud base. -! - do i=its,itf - if(ierr(i).eq.0) then - if(xland1(i).eq.0)then - w1=w1s - w2=w2s - w3=w3s - w4=w4s - endif - if(pdot(i,kbcon(i)).le.w4) then - tem = (pdot(i,kbcon(i)) - w4) / (w3 - w4) - elseif(pdot(i,kbcon(i)).ge.-w4) then - tem = - (pdot(i,kbcon(i)) + w4) / (w4 - w3) - else - tem = 0. - endif - val1 = -1. - tem = max(tem,val1) - val2 = 1. - tem = min(tem,val2) - tem = 1. - tem - tem1= .5*(cincrmax-cincrmin) - cincr(i) = cincrmax - tem * tem1 - pbcdif(i) = p_cup(i,k22(i)) - p_cup(i,kbcon(i)) - if(pbcdif(i).gt.cincr(i)) then - ierr(i) = 7 - endif -! if(pbcdif(i).gt.cincr(i)-25.) then -! ierr2(i) = 7 -! endif -! if(pbcdif(i).gt.cincr(i)-50.) then -! ierr3(i) = 7 -! endif - endif - enddo - -! call cup_kbcon(cap_max_increment,1,k22,kbcon,heo_cup,heso_cup, & -! ierr,kbmax,po_cup,cap_max, & -! ids,ide, jds,jde, kds,kde, & -! ims,ime, jms,jme, kms,kme, & -! its,ite, jts,jte, kts,kte) -! call cup_kbcon_cin(1,k22,kbcon,heo_cup,heso_cup,z,tn_cup, & -! qeso_cup,ierr,kbmax,po_cup,cap_max,xl,cp,& -! ids,ide, jds,jde, kds,kde, & -! ims,ime, jms,jme, kms,kme, & -! its,ite, jts,jte, kts,kte) -! -!--- increase detrainment in stable layers -! -! CALL cup_minimi(HEso_cup,Kbcon,kstabm,kstabi,ierr, & -! ids,ide, jds,jde, kds,kde, & -! ims,ime, jms,jme, kms,kme, & -! its,ite, jts,jte, kts,kte) -! thorpex2 (SASRQ?) - Adaptation of SAS updraft entrainment -! Updraft entrainment rate is initially set to an inverse function of height - do i=its,itf - do k=kts,ktf-1 - xlamue(i,k) = clam / z_cup(i,k) - enddo - enddo -! Assume updraft entrainment rate above cloud base is same as that -! at cloud base. -! Assume updraft detrainment rate equals updraft entrainment rate -! at cloud base. - do i=its,itf - if (ierr(i).eq.0) then - xlamud(i) = xlamue(i,kbcon(i)) - do k=kbcon(i)+1,ktf-1 - xlamue(i,k) = xlamue(i,kbcon(i)) - enddo - endif - enddo -! -! final entrainment rate as the sum of turbulent part and organized entrainment -! depending on the environmental relative humidity -! functions rapidly decreasing with height, mimicking a cloud ensemble -! (Bechtold et al., 2008) - - do i=its,itf - if (ierr(i).eq.0) then - dzmax=0. - do k=kbcon(i),ktf-1 - dz=zo_cup(i,k)-zo_cup(i,k-1) - dzmax=max(dzmax,dz) - tem = qeso_cup(i,k)/qeso_cup(i,kbcon(i)) - frh = 1.-min(qo_cup(i,k)/qeso_cup(i,k),1.) - fent1 = tem**2 - fent2 = tem**3 - xlamue(i,k) = xlamue(i,k)*fent1 + cxlamu*frh*fent2 - if(j.eq.jpr)print *,'k',k,fent1,fent2,xlamue(i,k),cxlamu*frh*fent2 - enddo - tem = xlamud(i)-1./dzmax - do k=kts,ktf-1 - xlamue(i,k)=max(xlamue(i,k),tem) - enddo - endif - enddo - - do i=its,itf - if (ierr(i).eq.0) then - do k=kts+1,ktf-1 - cd(i,k)=xlamud(i) - enddo - cd(i,1)=xlamud(i) - endif - enddo - -! do i=its,itf -! IF(ierr(I).eq.0.)THEN -! if(kstabm(i)-1.gt.kstabi(i))then -! do k=kstabi(i),kstabm(i)-1 -! cd(i,k)=cd(i,k-1)+1.5*entr_rate -! if(cd(i,k).gt.10.0*entr_rate)cd(i,k)=10.0*entr_rate -! enddo -! ENDIF -! ENDIF -! ENDDO -! -!--- calculate incloud moist static energy -! - call cup_up_he(k22,hkb,z_cup,cd,mentr_rate,he_cup,hc, & - kbcon,ierr,dby,he,hes_cup, & - xlamue,xlamud, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - call cup_up_he(k22,hkbo,zo_cup,cd,mentr_rate,heo_cup,hco, & - kbcon,ierr,dbyo,heo,heso_cup, & - xlamue,xlamud, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - -!--- DETERMINE CLOUD TOP - KTOP -! - call cup_ktop(1,dbyo,kbcon,ktop,ierr, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - DO 37 i=its,itf - kzdown(i)=0 - if(ierr(i).eq.0)then - zktop=(zo_cup(i,ktop(i))-z1(i))*.6 - zktop=min(zktop+z1(i),zcutdown+z1(i)) - do k=kts,kte - if(zo_cup(i,k).gt.zktop)then - kzdown(i)=k - go to 37 - endif - enddo - endif - 37 CONTINUE -! -!--- DOWNDRAFT ORIGINATING LEVEL - JMIN -! - call cup_minimi(HEo_cup,Kbcon,kbmax,JMIN,ierr, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - DO 100 i=its,ite - IF(ierr(I).eq.0.)THEN -! -!--- check whether it would have buoyancy, if there where -!--- no entrainment/detrainment -! -!jm begin 20061212: the following code replaces code that -! was too complex and causing problem for optimization. -! Done in consultation with G. Grell. - jmini = jmin(i) - keep_going = .TRUE. - DO WHILE ( keep_going ) - keep_going = .FALSE. -! if ( jmini - 1 .lt. kdet(i) ) kdet(i) = jmini-1 - if ( jmini .ge. ktop(i)-1 ) jmini = ktop(i) - 2 - ki = jmini - hcdo(i,ki)=heso_cup(i,ki) - DZ=Zo_cup(i,Ki+1)-Zo_cup(i,Ki) - dh=0. - DO k=ki-1,1,-1 - hcdo(i,k)=heso_cup(i,jmini) - DZ=Zo_cup(i,K+1)-Zo_cup(i,K) - dh=dh+dz*(HCDo(i,K)-heso_cup(i,k)) - IF(dh.gt.0.)THEN - jmini=jmini-1 - IF ( jmini .gt. kbcon(i) ) THEN - keep_going = .TRUE. - ELSE - ierr(i) = 9 - EXIT - ENDIF - ENDIF - ENDDO - ENDDO - jmin(i) = jmini - IF ( jmini .le. kbcon(i) ) THEN - ierr(i)=4 - ENDIF -!jm end 20061212 - ENDIF -100 CONTINUE -! -! - Must have at least depth_min m between cloud convective base -! and cloud top. -! - do i=its,itf - IF(ierr(I).eq.0.)THEN - IF(-zo_cup(I,KBCON(I))+zo_cup(I,KTOP(I)).LT.depth_min)then - ierr(i)=6 - endif - endif - enddo - -! -!c--- normalized updraft mass flux profile -! - call cup_up_nms(zu,z_cup,mentr_rate,cd,kbcon,ktop,ierr,k22, & - xlamue, xlamud, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - call cup_up_nms(zuo,zo_cup,mentr_rate,cd,kbcon,ktop,ierr,k22, & - xlamue, xlamud, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) -! -!c--- normalized downdraft mass flux profile,also work on bottom detrainment -!--- in this routine - jprt=0 -! if(j.eq.3077)jprt=1 -! - call cup_dd_nms(zd,z_cup,cdd,mentrd_rate,jmin,ierr, & - 0,kdet,z1, & - kbcon,beta,xlamdd,xlamde, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte,jprt) - call cup_dd_nms(zdo,zo_cup,cdd,mentrd_rate,jmin,ierr, & - 1,kdet,z1, & - kbcon,beta,xlamdd,xlamde, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ,0) -! -!--- downdraft moist static energy -! - call cup_dd_he(hes_cup,zd,hcd,z_cup,cdd,mentrd_rate, & - jmin,ierr,he,dbyd,he_cup, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - call cup_dd_he(heso_cup,zdo,hcdo,zo_cup,cdd,mentrd_rate, & - jmin,ierr,heo,dbydo,he_cup,& - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) -! -!--- calculate moisture properties of downdraft -! - call cup_dd_moisture(zd,hcd,hes_cup,qcd,qes_cup, & - pwd,q_cup,z_cup,cdd,mentrd_rate,jmin,ierr,gamma_cup, & - pwev,bu,qrcd,q,he,t_cup,2,xl, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - call cup_dd_moisture(zdo,hcdo,heso_cup,qcdo,qeso_cup, & - pwdo,qo_cup,zo_cup,cdd,mentrd_rate,jmin,ierr,gammao_cup, & - pwevo,bu,qrcdo,qo,heo,tn_cup,1,xl, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) -! -!--- calculate moisture properties of updraft -! - call cup_up_moisture(ierr,z_cup,qc,qrc,pw,pwav, & - kbcon,ktop,cd,dby,mentr_rate,clw_all, & - q,GAMMA_cup,zu,qes_cup,k22,q_cup,xl, & - xlamue, xlamud, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - do k=kts,ktf - do i=its,itf - cupclw(i,k)=qrc(i,k) - enddo - enddo - call cup_up_moisture(ierr,zo_cup,qco,qrco,pwo,pwavo, & - kbcon,ktop,cd,dbyo,mentr_rate,clw_all, & - qo,GAMMAo_cup,zuo,qeso_cup,k22,qo_cup,xl,& - xlamue, xlamud, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) -! -!--- calculate workfunctions for updrafts -! - call cup_up_aa0(aa0,z,zu,dby,GAMMA_CUP,t_cup, & - kbcon,ktop,ierr, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - call cup_up_aa0(aa1,zo,zuo,dbyo,GAMMAo_CUP,tn_cup, & - kbcon,ktop,ierr, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - do i=its,itf - if(ierr(i).eq.0)then - if(aa1(i).eq.0.)then - ierr(i)=17 - endif - endif - enddo -! -!--- DETERMINE DOWNDRAFT STRENGTH IN TERMS OF WINDSHEAR -! - call cup_dd_edt(ierr,us,vs,zo,ktop,kbcon,edt,po,pwavo, & - pwevo,edtmax,edtmin,maxens2,edtc, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - do 250 iedt=1,maxens2 - do i=its,itf - if(j.eq.jpr.and.iedt.eq.1)then -! i=ipr - write(0,*)'250',k22(I),kbcon(i),ktop(i),jmin(i) - write(0,*)'250',cincr(i),pbcdif(i),pdot(i,kbcon(i)) - write(0,*)edt(i),aa0(i),aa1(i) - do k=kts,ktf - write(0,*)k,z(i,k),he(i,k),hes(i,k) - enddo - write(0,*)'end 250 loop ',iedt,edt(ipr),ierr(ipr) - do k=1,ktop(i)+1 - write(0,*)zu(i,k),zd(i,k),pw(i,k),pwd(i,k) - enddo - endif - - if(ierr(i).eq.0)then - edt(i)=edtc(i,iedt) - edto(i)=edtc(i,iedt) - edtx(i)=edtc(i,iedt) - endif - enddo - do k=kts,ktf - do i=its,itf - dellat_ens(i,k,iedt)=0. - dellaq_ens(i,k,iedt)=0. - dellaqc_ens(i,k,iedt)=0. - pwo_ens(i,k,iedt)=0. - enddo - enddo -! - do i=its,itf - aad(i)=0. - enddo -! do i=its,itf -! if(ierr(i).eq.0)then -! eddt(i,j)=edt(i) -! EDTX(I)=EDT(I) -! BU(I)=0. -! BUO(I)=0. -! endif -! enddo -! -!---downdraft workfunctions -! -! call cup_dd_aa0(edt,ierr,aa0,jmin,gamma_cup,t_cup, & -! hcd,hes_cup,z,zd, & -! ids,ide, jds,jde, kds,kde, & -! ims,ime, jms,jme, kms,kme, & -! its,ite, jts,jte, kts,kte) -! call cup_dd_aa0(edto,ierr,aad,jmin,gammao_cup,tn_cup, & -! hcdo,heso_cup,zo,zdo, & -! ids,ide, jds,jde, kds,kde, & -! ims,ime, jms,jme, kms,kme, & -! its,ite, jts,jte, kts,kte) -! -!--- change per unit mass that a model cloud would modify the environment -! -!--- 1. in bottom layer -! - call cup_dellabot(ipr,jpr,heo_cup,ierr,zo_cup,po,hcdo,edto, & - zdo,cdd,heo,dellah,j,mentrd_rate,zo,g, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - call cup_dellabot(ipr,jpr,qo_cup,ierr,zo_cup,po,qrcdo,edto, & - zdo,cdd,qo,dellaq,j,mentrd_rate,zo,g,& - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) -! -!--- 2. everywhere else -! - call cup_dellas(ierr,zo_cup,po_cup,hcdo,edto,zdo,cdd, & - heo,dellah,j,mentrd_rate,zuo,g, & - cd,hco,ktop,k22,kbcon,mentr_rate,jmin,heo_cup,kdet, & - k22,ipr,jpr,'deep',xlamue,xlamud, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) -! -!-- take out cloud liquid water for detrainment -! -!?? do k=kts,ktf - do k=kts,ktf-1 - do i=its,itf - scr1(i,k)=0. - dellaqc(i,k)=0. - if(ierr(i).eq.0)then -! print *,'in vupnewg, after della ',ierr(i),aa0(i),i,j - scr1(i,k)=qco(i,k)-qrco(i,k) - if(k.eq.ktop(i)-0)dellaqc(i,k)= & - .01*zuo(i,ktop(i))*qrco(i,ktop(i))* & - 9.81/(po_cup(i,k)-po_cup(i,k+1)) - if(k.lt.ktop(i).and.k.gt.kbcon(i))then - dz=zo_cup(i,k+1)-zo_cup(i,k) - dellaqc(i,k)=.01*9.81*cd(i,k)*dz*zuo(i,k) & - *.5*(qrco(i,k)+qrco(i,k+1))/ & - (po_cup(i,k)-po_cup(i,k+1)) - endif - endif - enddo - enddo - do i=its,itf - dellaqc(i,ktf)=0. - enddo - call cup_dellas(ierr,zo_cup,po_cup,qrcdo,edto,zdo,cdd, & - qo,dellaq,j,mentrd_rate,zuo,g, & - cd,scr1,ktop,k22,kbcon,mentr_rate,jmin,qo_cup,kdet, & - k22,ipr,jpr,'deep', xlamue, xlamud, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) -! -!--- using dellas, calculate changed environmental profiles -! -! do 200 nens=1,maxens - mbdt=mbdt_ens(2) - do i=its,itf - xaa0_ens(i,1)=0. - xaa0_ens(i,2)=0. - xaa0_ens(i,3)=0. - enddo - -! mbdt=mbdt_ens(nens) -! do i=its,itf -! xaa0_ens(i,nens)=0. -! enddo - do k=kts,ktf - do i=its,itf - dellat(i,k)=0. - if(ierr(i).eq.0)then - XHE(I,K)=DELLAH(I,K)*MBDT+HEO(I,K) - XQ(I,K)=DELLAQ(I,K)*MBDT+QO(I,K) - DELLAT(I,K)=(1./cp)*(DELLAH(I,K)-xl*DELLAQ(I,K)) - XT(I,K)= DELLAT(I,K)*MBDT+TN(I,K) - IF(XQ(I,K).LE.0.)XQ(I,K)=1.E-08 -! if(i.eq.ipr.and.j.eq.jpr)then -! print *,'dellas',k,DELLAH(I,K),DELLAQ(I,K),DELLAT(I,K) -! endif - ENDIF - enddo - enddo - do i=its,itf - if(ierr(i).eq.0)then - XHE(I,ktf)=HEO(I,ktf) - XQ(I,ktf)=QO(I,ktf) - XT(I,ktf)=TN(I,ktf) - IF(XQ(I,ktf).LE.0.)XQ(I,ktf)=1.E-08 - endif - enddo -! -!--- calculate moist static energy, heights, qes -! - call cup_env(xz,xqes,xhe,xhes,xt,xq,po,z1, & - psur,ierr,tcrit,2,xl,cp, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) -! -!--- environmental values on cloud levels -! - call cup_env_clev(xt,xqes,xq,xhe,xhes,xz,po,xqes_cup,xq_cup, & - xhe_cup,xhes_cup,xz_cup,po_cup,gamma_cup,xt_cup,psur, & - ierr,z1,xl,rv,cp, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) -! -! -!**************************** static control -! -!--- moist static energy inside cloud -! - do i=its,itf - if(ierr(i).eq.0)then - xhkb(i)=xhe(i,k22(i)) - endif - enddo - call cup_up_he(k22,xhkb,xz_cup,cd,mentr_rate,xhe_cup,xhc, & - kbcon,ierr,xdby,xhe,xhes_cup, & - xlamue, xlamud, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) -! -!c--- normalized mass flux profile -! - call cup_up_nms(xzu,xz_cup,mentr_rate,cd,kbcon,ktop,ierr,k22, & - xlamue, xlamud, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) -! -!--- moisture downdraft -! - call cup_dd_nms(xzd,xz_cup,cdd,mentrd_rate,jmin,ierr, & - 1,kdet,z1, & - kbcon,beta,xlamdd,xlamde, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte,0) - call cup_dd_he(xhes_cup,xzd,xhcd,xz_cup,cdd,mentrd_rate, & - jmin,ierr,xhe,dbyd,xhe_cup,& - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - call cup_dd_moisture(xzd,xhcd,xhes_cup,xqcd,xqes_cup, & - xpwd,xq_cup,xz_cup,cdd,mentrd_rate,jmin,ierr,gamma_cup, & - xpwev,bu,xqrcd,xq,xhe,xt_cup,3,xl, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - -! -!------- MOISTURE updraft -! - call cup_up_moisture(ierr,xz_cup,xqc,xqrc,xpw,xpwav, & - kbcon,ktop,cd,xdby,mentr_rate,clw_all, & - xq,GAMMA_cup,xzu,xqes_cup,k22,xq_cup,xl, & - xlamue, xlamud, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) -! -!--- workfunctions for updraft -! - call cup_up_aa0(xaa0,xz,xzu,xdby,GAMMA_CUP,xt_cup, & - kbcon,ktop,ierr, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) -! -!--- workfunctions for downdraft -! -! -! call cup_dd_aa0(edtx,ierr,xaa0,jmin,gamma_cup,xt_cup, & -! xhcd,xhes_cup,xz,xzd, & -! ids,ide, jds,jde, kds,kde, & -! ims,ime, jms,jme, kms,kme, & -! its,ite, jts,jte, kts,kte) - do 200 nens=1,maxens - do i=its,itf - if(ierr(i).eq.0)then - xaa0_ens(i,nens)=xaa0(i) - nall=(iens-1)*maxens3*maxens*maxens2 & - +(iedt-1)*maxens*maxens3 & - +(nens-1)*maxens3 - do k=kts,ktf - if(k.le.ktop(i))then - do nens3=1,maxens3 - if(nens3.eq.7)then -!--- b=0 - pr_ens(i,j,nall+nens3)=pr_ens(i,j,nall+nens3)+ & - pwo(i,k) -! +edto(i)*pwdo(i,k) -!--- b=beta - else if(nens3.eq.8)then - pr_ens(i,j,nall+nens3)=pr_ens(i,j,nall+nens3)+ & - pwo(i,k) -!--- b=beta/2 - else if(nens3.eq.9)then - pr_ens(i,j,nall+nens3)=pr_ens(i,j,nall+nens3)+ & - pwo(i,k) -! +.5*edto(i)*pwdo(i,k) - else - pr_ens(i,j,nall+nens3)=pr_ens(i,j,nall+nens3)+ & - pwo(i,k)+edto(i)*pwdo(i,k) - endif - enddo - endif - enddo - if(pr_ens(i,j,nall+7).lt.1.e-6)then - ierr(i)=18 - do nens3=1,maxens3 - pr_ens(i,j,nall+nens3)=0. - enddo - endif - do nens3=1,maxens3 - if(pr_ens(i,j,nall+nens3).lt.1.e-4)then - pr_ens(i,j,nall+nens3)=0. - endif - enddo - endif - enddo - 200 continue -! -!--- LARGE SCALE FORCING -! -! -!------- CHECK wether aa0 should have been zero -! -! -! CALL cup_MAXIMI(HEO_CUP,3,KBMAX,K22x,ierr, & -! ids,ide, jds,jde, kds,kde, & -! ims,ime, jms,jme, kms,kme, & -! its,ite, jts,jte, kts,kte) - do i=its,itf - ierr2(i)=ierr(i) - ierr3(i)=ierr(i) - enddo -! call cup_kbcon(cap_max_increment,2,k22x,kbconx,heo_cup, & -! heso_cup,ierr2,kbmax,po_cup,cap_max, & -! ids,ide, jds,jde, kds,kde, & -! ims,ime, jms,jme, kms,kme, & -! its,ite, jts,jte, kts,kte) -! call cup_kbcon(cap_max_increment,3,k22x,kbconx,heo_cup, & -! heso_cup,ierr3,kbmax,po_cup,cap_max, & -! ids,ide, jds,jde, kds,kde, & -! ims,ime, jms,jme, kms,kme, & -! its,ite, jts,jte, kts,kte) -! -!--- DETERMINE THE LEVEL OF CONVECTIVE CLOUD BASE - KBCON -! - call cup_forcing_ens(closure_n,xland1,aa0,aa1,xaa0_ens,mbdt_ens,dtime, & - ierr,ierr2,ierr3,xf_ens,j,'deeps', & - maxens,iens,iedt,maxens2,maxens3,mconv, & - po_cup,ktop,omeg,zdo,k22,zuo,pr_ens,edto,kbcon, & - massflx,iact,direction,ensdim,massfln,ichoice, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) -! - do k=kts,ktf - do i=its,itf - if(ierr(i).eq.0)then - dellat_ens(i,k,iedt)=dellat(i,k) - dellaq_ens(i,k,iedt)=dellaq(i,k) - dellaqc_ens(i,k,iedt)=dellaqc(i,k) - pwo_ens(i,k,iedt)=pwo(i,k)+edt(i)*pwdo(i,k) - else - dellat_ens(i,k,iedt)=0. - dellaq_ens(i,k,iedt)=0. - dellaqc_ens(i,k,iedt)=0. - pwo_ens(i,k,iedt)=0. - endif -! if(i.eq.ipr.and.j.eq.jpr)then -! print *,iens,iedt,dellat(i,k),dellat_ens(i,k,iedt), & -! dellaq(i,k), dellaqc(i,k) -! endif - enddo - enddo - 250 continue -! -!--- FEEDBACK -! - do i=its,itf - if (ierr(i).eq.0)then - k=kbcon(i) - dp = 100.* (p_cup(i,k) - p_cup(i,k+1)) - xmbmax(i) = dp / (g * dtime) -! if (j.eq.3077) print *,'xmbmax=',xmbmax(i),dp,g,dtime - endif - enddo - - call cup_output_ens(xf_ens,ierr,dellat_ens,dellaq_ens, & - dellaqc_ens,outt,outq,outqc,pre,pwo_ens,xmb,ktop, & - j,'deep',maxens2,maxens,iens,ierr2,ierr3, & - pr_ens,maxens3,ensdim,massfln,xmbmax, & - APR_GR,APR_W,APR_MC,APR_ST,APR_AS, & - APR_CAPMA,APR_CAPME,APR_CAPMI,closure_n,xland1, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - do i=its,itf - PRE(I)=MAX(PRE(I),0.) - if(i.eq.ipr.and.j.eq.jpr)then - write(0,*)'j,pre(i),aa0(i),aa1(i)' - write(0,*)j,pre(i),aa0(i),aa1(i) - endif - - enddo -! -!---------------------------done------------------------------ -! - - END SUBROUTINE CUP_enss - - - SUBROUTINE cup_dd_aa0(edt,ierr,aa0,jmin,gamma_cup,t_cup, & - hcd,hes_cup,z,zd, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE -! -! on input -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - ! aa0 cloud work function for downdraft - ! gamma_cup = gamma on model cloud levels - ! t_cup = temperature (Kelvin) on model cloud levels - ! hes_cup = saturation moist static energy on model cloud levels - ! hcd = moist static energy in downdraft - ! edt = epsilon - ! zd normalized downdraft mass flux - ! z = heights of model levels - ! ierr error value, maybe modified in this routine - ! - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - z,zd,gamma_cup,t_cup,hes_cup,hcd - real, dimension (its:ite) & - ,intent (in ) :: & - edt - integer, dimension (its:ite) & - ,intent (in ) :: & - jmin -! -! input and output -! - - - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr - real, dimension (its:ite) & - ,intent (out ) :: & - aa0 -! -! local variables in this routine -! - - integer :: & - i,k,kk - real :: & - dz -! - integer :: itf, ktf -! - itf=ite - ktf=kte -! -!?? DO k=kts,kte-1 - DO k=kts,ktf-1 - do i=its,itf - IF(ierr(I).eq.0.and.k.lt.jmin(i))then - KK=JMIN(I)-K -! -!--- ORIGINAL -! - DZ=(Z(I,KK)-Z(I,KK+1)) - AA0(I)=AA0(I)+zd(i,kk)*EDT(I)*DZ*(9.81/(1004.*T_cup(I,KK))) & - *((hcd(i,kk)-hes_cup(i,kk))/(1.+GAMMA_cup(i,kk))) - endif - enddo - enddo - - END SUBROUTINE CUP_dd_aa0 - - - SUBROUTINE cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & - pwev,edtmax,edtmin,maxens2,edtc, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE - - integer & - ,intent (in ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - integer, intent (in ) :: & - maxens2 - ! - ! ierr error value, maybe modified in this routine - ! - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - us,vs,z,p - real, dimension (its:ite,1:maxens2) & - ,intent (out ) :: & - edtc - real, dimension (its:ite) & - ,intent (out ) :: & - edt - real, dimension (its:ite) & - ,intent (in ) :: & - pwav,pwev - real & - ,intent (in ) :: & - edtmax,edtmin - integer, dimension (its:ite) & - ,intent (in ) :: & - ktop,kbcon - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr -! -! local variables in this routine -! - - integer i,k,kk - real einc,pef,pefb,prezk,zkbc - real, dimension (its:ite) :: & - vshear,sdp,vws - - integer :: itf, ktf - - itf=ite - ktf=kte -! -!--- DETERMINE DOWNDRAFT STRENGTH IN TERMS OF WINDSHEAR -! -! */ calculate an average wind shear over the depth of the cloud -! - do i=its,itf - edt(i)=0. - vws(i)=0. - sdp(i)=0. - vshear(i)=0. - enddo - do kk = kts,ktf-1 - do 62 i=its,itf - IF(ierr(i).ne.0)GO TO 62 - if (kk .le. min0(ktop(i),ktf-1) .and. kk .ge. kbcon(i)) then - vws(i) = vws(i)+ & - (abs((us(i,kk+1)-us(i,kk))/(z(i,kk+1)-z(i,kk))) & - + abs((vs(i,kk+1)-vs(i,kk))/(z(i,kk+1)-z(i,kk)))) * & - (p(i,kk) - p(i,kk+1)) - sdp(i) = sdp(i) + p(i,kk) - p(i,kk+1) - endif - if (kk .eq. ktf-1)vshear(i) = 1.e3 * vws(i) / sdp(i) - 62 continue - end do - do i=its,itf - IF(ierr(i).eq.0)then - pef=(1.591-.639*VSHEAR(I)+.0953*(VSHEAR(I)**2) & - -.00496*(VSHEAR(I)**3)) - if(pef.gt.edtmax)pef=edtmax - if(pef.lt.edtmin)pef=edtmin -! -!--- cloud base precip efficiency -! - zkbc=z(i,kbcon(i))*3.281e-3 - prezk=.02 - if(zkbc.gt.3.)then - prezk=.96729352+zkbc*(-.70034167+zkbc*(.162179896+zkbc & - *(- 1.2569798E-2+zkbc*(4.2772E-4-zkbc*5.44E-6)))) - endif - if(zkbc.gt.25)then - prezk=2.4 - endif - pefb=1./(1.+prezk) - if(pefb.gt.edtmax)pefb=edtmax - if(pefb.lt.edtmin)pefb=edtmin - EDT(I)=1.-.5*(pefb+pef) -!--- edt here is 1-precipeff! -! einc=(1.-edt(i))/float(maxens2) -! einc=edt(i)/float(maxens2+1) -!--- 20 percent - einc=.2*edt(i) - do k=1,maxens2 - edtc(i,k)=edt(i)+float(k-2)*einc - enddo - endif - enddo - do i=its,itf - IF(ierr(i).eq.0)then - do k=1,maxens2 - EDTC(I,K)=-EDTC(I,K)*PWAV(I)/PWEV(I) - IF(EDTC(I,K).GT.edtmax)EDTC(I,K)=edtmax - IF(EDTC(I,K).LT.edtmin)EDTC(I,K)=edtmin - enddo - endif - enddo - - END SUBROUTINE cup_dd_edt - - - SUBROUTINE cup_dd_he(hes_cup,zd,hcd,z_cup,cdd,entr, & - jmin,ierr,he,dby,he_cup, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE -! -! on input -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - ! hcd = downdraft moist static energy - ! he = moist static energy on model levels - ! he_cup = moist static energy on model cloud levels - ! hes_cup = saturation moist static energy on model cloud levels - ! dby = buoancy term - ! cdd= detrainment function - ! z_cup = heights of model cloud levels - ! entr = entrainment rate - ! zd = downdraft normalized mass flux - ! - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - he,he_cup,hes_cup,z_cup,cdd,zd - ! entr= entrainment rate - real & - ,intent (in ) :: & - entr - integer, dimension (its:ite) & - ,intent (in ) :: & - jmin -! -! input and output -! - - ! ierr error value, maybe modified in this routine - - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr - - real, dimension (its:ite,kts:kte) & - ,intent (out ) :: & - hcd,dby -! -! local variables in this routine -! - - integer :: & - i,k,ki - real :: & - dz - - integer :: itf, ktf - - itf=ite - ktf=kte - - do k=kts+1,ktf - do i=its,itf - dby(i,k)=0. - IF(ierr(I).eq.0)then - hcd(i,k)=hes_cup(i,k) - endif - enddo - enddo -! - do 100 i=its,itf - IF(ierr(I).eq.0)then - k=jmin(i) - hcd(i,k)=hes_cup(i,k) - dby(i,k)=hcd(i,jmin(i))-hes_cup(i,k) -! - do ki=jmin(i)-1,1,-1 - DZ=Z_cup(i,Ki+1)-Z_cup(i,Ki) - HCD(i,Ki)=(HCD(i,Ki+1)*(1.-.5*CDD(i,Ki)*DZ) & - +entr*DZ*HE(i,Ki) & - )/(1.+entr*DZ-.5*CDD(i,Ki)*DZ) - dby(i,ki)=HCD(i,Ki)-hes_cup(i,ki) - enddo -! - endif -!--- end loop over i -100 continue - - - END SUBROUTINE cup_dd_he - - - SUBROUTINE cup_dd_moisture(zd,hcd,hes_cup,qcd,qes_cup, & - pwd,q_cup,z_cup,cdd,entr,jmin,ierr, & - gamma_cup,pwev,bu,qrcd, & - q,he,t_cup,iloop,xl, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE - - integer & - ,intent (in ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - ! cdd= detrainment function - ! q = environmental q on model levels - ! q_cup = environmental q on model cloud levels - ! qes_cup = saturation q on model cloud levels - ! hes_cup = saturation h on model cloud levels - ! hcd = h in model cloud - ! bu = buoancy term - ! zd = normalized downdraft mass flux - ! gamma_cup = gamma on model cloud levels - ! mentr_rate = entrainment rate - ! qcd = cloud q (including liquid water) after entrainment - ! qrch = saturation q in cloud - ! pwd = evaporate at that level - ! pwev = total normalized integrated evaoprate (I2) - ! entr= entrainment rate - ! - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - zd,t_cup,hes_cup,hcd,qes_cup,q_cup,z_cup,cdd,gamma_cup,q,he - real & - ,intent (in ) :: & - entr,xl - integer & - ,intent (in ) :: & - iloop - integer, dimension (its:ite) & - ,intent (in ) :: & - jmin - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr - real, dimension (its:ite,kts:kte) & - ,intent (out ) :: & - qcd,qrcd,pwd - real, dimension (its:ite) & - ,intent (out ) :: & - pwev,bu -! -! local variables in this routine -! - - integer :: & - i,k,ki - real :: & - dh,dz,dqeva - - integer :: itf, ktf - - itf=ite - ktf=kte - - do i=its,itf - bu(i)=0. - pwev(i)=0. - enddo - do k=kts,ktf - do i=its,itf - qcd(i,k)=0. - qrcd(i,k)=0. - pwd(i,k)=0. - enddo - enddo -! -! -! - do 100 i=its,itf - IF(ierr(I).eq.0)then - k=jmin(i) - DZ=Z_cup(i,K+1)-Z_cup(i,K) - qcd(i,k)=q_cup(i,k) -! qcd(i,k)=.5*(qes_cup(i,k)+q_cup(i,k)) - qrcd(i,k)=qes_cup(i,k) - pwd(i,jmin(i))=min(0.,qcd(i,k)-qrcd(i,k)) - pwev(i)=pwev(i)+pwd(i,jmin(i)) - qcd(i,k)=qes_cup(i,k) -! - DH=HCD(I,k)-HES_cup(I,K) - bu(i)=dz*dh - do ki=jmin(i)-1,1,-1 - DZ=Z_cup(i,Ki+1)-Z_cup(i,Ki) - QCD(i,Ki)=(qCD(i,Ki+1)*(1.-.5*CDD(i,Ki)*DZ) & - +entr*DZ*q(i,Ki) & - )/(1.+entr*DZ-.5*CDD(i,Ki)*DZ) -! -!--- to be negatively buoyant, hcd should be smaller than hes! -! - DH=HCD(I,ki)-HES_cup(I,Ki) - bu(i)=bu(i)+dz*dh - QRCD(I,Ki)=qes_cup(i,ki)+(1./XL)*(GAMMA_cup(i,ki) & - /(1.+GAMMA_cup(i,ki)))*DH - dqeva=qcd(i,ki)-qrcd(i,ki) - if(dqeva.gt.0.)dqeva=0. - pwd(i,ki)=zd(i,ki)*dqeva - qcd(i,ki)=qrcd(i,ki) - pwev(i)=pwev(i)+pwd(i,ki) -! if(iloop.eq.1.and.i.eq.102.and.j.eq.62)then -! print *,'in cup_dd_moi ', hcd(i,ki),HES_cup(I,Ki),dh,dqeva -! endif - enddo -! -!--- end loop over i - if(pwev(I).eq.0.and.iloop.eq.1)then -! print *,'problem with buoy in cup_dd_moisture',i - ierr(i)=7 - endif - if(BU(I).GE.0.and.iloop.eq.1)then -! print *,'problem with buoy in cup_dd_moisture',i - ierr(i)=7 - endif - endif -100 continue - - END SUBROUTINE cup_dd_moisture - - - SUBROUTINE cup_dd_nms(zd,z_cup,cdd,entr,jmin,ierr, & - itest,kdet,z1, & - kbcon,beta,xlamdd,xlamde, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte,jpr ) - - IMPLICIT NONE -! -! on input -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte,jpr - ! z_cup = height of cloud model level - ! z1 = terrain elevation - ! entr = downdraft entrainment rate - ! jmin = downdraft originating level - ! kdet = level above ground where downdraft start detraining - ! itest = flag to whether to calculate cdd - - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - z_cup - real, dimension (its:ite) & - ,intent (in ) :: & - z1 - real & - ,intent (in ) :: & - entr,xlamdd,xlamde,beta - integer, dimension (its:ite) & - ,intent (in ) :: & - jmin,kdet,kbcon - integer & - ,intent (in ) :: & - itest -! -! input and output -! - - ! ierr error value, maybe modified in this routine - - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr - ! zd is the normalized downdraft mass flux - ! cdd is the downdraft detrainmen function - - real, dimension (its:ite,kts:kte) & - ,intent (out ) :: & - zd - real, dimension (its:ite,kts:kte) & - ,intent (inout) :: & - cdd -! -! local variables in this routine -! - - integer :: & - i,k,ki - real :: & - a,perc,dz,ptem,tem - real, dimension (its:ite) :: xlamd - - integer :: itf, ktf - - itf=ite - ktf=kte -! -!--- perc is the percentage of mass left when hitting the ground -! - perc=.03 - - do k=kts,ktf - do i=its,itf - zd(i,k)=0. - enddo - enddo - a=1.-perc -! only define this entrain/detrain nonsense once - if (itest.eq.0) then - -! if(jpr.eq.1)write(6,*)'itest = 0 here ' - do k=kts,ktf - do i=its,itf - cdd(i,k)=0. - enddo - enddo - - do i=its,itf - IF(ierr(I).eq.0)then - dz = z_cup(i,kbcon(i))/float(kbcon(i)) - tem = 1./float(kbcon(i)) - xlamd(i) = (1.-beta**tem)/dz - if(jpr.eq.1)write(6,*)'b',beta**tem,tem,beta,xlamd(i) - - do ki=jmin(i)-1,1,-1 - if (ki.ge.kbcon(i)) then - cdd(i,ki) = xlamdd - else - cdd(i,ki) = xlamdd + xlamd(i) - endif -! if(jpr.eq.1)write(6,*)ki,cdd(i,ki),xlamdd,xlamd(i) - end do - - ENDIF - enddo - endif ! itest=0 -! -! -! - do 100 i=its,itf - IF(ierr(I).eq.0)then - zd(i,jmin(i))=1. -! -!--- integrate downward, specify detrainment(cdd)! -! - do ki=jmin(i)-1,1,-1 - DZ=Z_cup(i,Ki+1)-Z_cup(i,Ki) -! Thorpex 20110506 (SASRQ3) - ptem = cdd(i,ki) - xlamde - zd(i,ki) = zd(i,ki+1)*(1. - ptem * dz) -! if(jpr.eq.1)write(6,*)ki,cdd(i,ki),zd(i,ki),xlamde - -! if(ki.le.kdet(i).and.itest.eq.0)then -! cdd(i,ki)=entr+(1.- (a*(z_cup(i,ki)-z1(i)) & -! +perc*(z_cup(i,kdet(i))-z1(i)) ) & -! /(a*(z_cup(i,ki+1)-z1(i)) & -! +perc*(z_cup(i,kdet(i))-z1(i))))/dz -! endif -! zd(i,ki)=zd(i,ki+1)*(1.+(entr-cdd(i,ki))*dz) - enddo -! - endif -!--- end loop over i -100 continue - - END SUBROUTINE cup_dd_nms - - - SUBROUTINE cup_dellabot(ipr,jpr,he_cup,ierr,z_cup,p_cup, & - hcd,edt,zd,cdd,he,della,j,mentrd_rate,z,g, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE - - integer & - ,intent (in ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - integer, intent (in ) :: & - j,ipr,jpr - ! - ! ierr error value, maybe modified in this routine - ! - real, dimension (its:ite,kts:kte) & - ,intent (out ) :: & - della - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - z_cup,p_cup,hcd,zd,cdd,he,z,he_cup - real, dimension (its:ite) & - ,intent (in ) :: & - edt - real & - ,intent (in ) :: & - g,mentrd_rate - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr -! -! local variables in this routine -! - - integer i - real detdo,detdo1,detdo2,entdo,dp,dz,subin, & - totmas -! - integer :: itf, ktf - - itf=ite - ktf=kte -! -! -! if(j.eq.jpr)print *,'in cup dellabot ' - do 100 i=its,itf - della(i,1)=0. - if(ierr(i).ne.0)go to 100 - dz=z_cup(i,2)-z_cup(i,1) - DP=100.*(p_cup(i,1)-P_cup(i,2)) - detdo1=edt(i)*zd(i,2)*CDD(i,1)*DZ - detdo2=edt(i)*zd(i,1) - entdo=edt(i)*zd(i,2)*mentrd_rate*dz - subin=-EDT(I)*zd(i,2) - detdo=detdo1+detdo2-entdo+subin - if(detdo.gt.1.e-6)then - write(6,*)'totmas = ',detdo - write(6,*)detdo1,detdo2,entdo,subin - endif -! DELLA(I,1)=(detdo1*.5*(HCD(i,1)+HCD(i,2)) & -! +detdo2*hcd(i,1) & -! +subin*he_cup(i,2) & -! -entdo*he(i,1))*g/dp - DELLA(I,1)=detdo2*(hcd(i,2) -he_cup(i,2))*g/dp - 100 CONTINUE - - END SUBROUTINE cup_dellabot - - - SUBROUTINE cup_dellas(ierr,z_cup,p_cup,hcd,edt,zd,cdd, & - he,della,j,mentrd_rate,zu,g, & - cd,hc,ktop,k22,kbcon,mentr_rate,jmin,he_cup,kdet,kpbl, & - ipr,jpr,name, xlamue, xlamud, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE - - integer & - ,intent (in ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - integer, intent (in ) :: & - j,ipr,jpr - ! - ! ierr error value, maybe modified in this routine - ! - real, dimension (its:ite,kts:kte) & - ,intent (out ) :: & - della - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - z_cup,p_cup,hcd,zd,cdd,he,hc,cd,zu,he_cup,xlamue - real, dimension (its:ite) & - ,intent (in ) :: & - edt,xlamud - real & - ,intent (in ) :: & - g,mentrd_rate,mentr_rate - integer, dimension (its:ite) & - ,intent (in ) :: & - kbcon,ktop,k22,jmin,kdet,kpbl - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr - character *(*), intent (in) :: & - name -! -! local variables in this routine -! - - integer i,k - real detdo1,detdo2,entdo,dp,dz,subin,detdo,entup, & - detup,subdown,entdoj,entupk,detupk,totmas -! - integer :: itf, ktf - - itf=ite - ktf=kte -! -! - i=ipr -! if(j.eq.jpr)then -! print *,'in dellas kpbl(i),k22(i),kbcon(i),ktop(i),jmin(i)' -! print *,kpbl(i),k22(i),kbcon(i),ktop(i),jmin(i) -! endif - DO K=kts+1,ktf - do i=its,itf - della(i,k)=0. - enddo - enddo -! -! if k22=2, there is also a term due to updrafts at level1 ! -! this will overwrite dellabot in this case -! - DO i=its,ite - IF(ierr(i).eq.0 .and. k22(i).eq.2)then - detdo2=edt(i)*zd(i,1) - entupk=zu(i,k22(i)) - dp=100.*(p_cup(i,1)-p_cup(i,2)) - DELLA(I,1)=(detdo2*(hcd(i,2) -he_cup(i,2)) & - -entupk*(he_cup(i,k22(i))-he_cup(i,2)) & - )*g/dp - endif - enddo - DO 100 k=kts+1,ktf-1 - DO 100 i=its,ite - IF(ierr(i).ne.0)GO TO 100 - IF(K.Gt.KTOP(I))GO TO 100 -! -!--- SPECIFY DETRAINMENT OF DOWNDRAFT, HAS TO BE CONSISTENT -!--- WITH ZD CALCULATIONS IN SOUNDD. -! -! updraft starts at k22 (>1). thi will effect della(k22-1). At that level (k22-1) -! resulting subin is active ... updraft entr/detr start going from kbcon -! to kbcon+1, which would effect kbcon for dellas - DZ=Z_cup(I,K+1)-Z_cup(I,K) - detdo=edt(i)*CDD(i,K)*DZ*ZD(i,k+1) - entdo=edt(i)*mentrd_rate*dz*zd(i,k+1) - subin=zu(i,k+1)-zd(i,k+1)*edt(i) - subdown=(zu(i,k)-zd(i,k)*edt(i)) - entup=0. - detup=0. - entdoj=0. - entupk=0. - detupk=0. - if(k.ge.kbcon(i).and.k.lt.ktop(i))then - entup=xlamue(i,k+1)*dz*zu(i,k+0) - detup=xlamud(i)*DZ*ZU(i,k+0) - endif -! - if(k.eq.jmin(i))then - entdoj=edt(i)*zd(i,k) - endif -! k is at least kts+1, if k22 happens to be 2, this is handled above loop 100 - if(k.eq.k22(i)-1)then - entupk=zu(i,k22(i)) - dp=100.*(p_cup(i,k)-p_cup(i,k+1)) - della(i,k)=(subin*he_cup(i,k+1) & - -subdown*he_cup(i,k) & - +detdo*.5*(HCD(i,K+1)+HCD(i,K)) & - -entdo*he(i,k) & - -entupk*he_cup(i,k22(i)) & - -entdoj*he_cup(i,jmin(i)) & - )*g/dp - endif - -! if(k.gt.kdet(i))then -! detdo=0. -! endif - - if(k.eq.ktop(i)-0)then - detupk=zu(i,ktop(i)) - subin=0. - endif - if(k.le.k22(i))then - detup=0. - endif -!C -!C--- CHANGED DUE TO SUBSIDENCE AND ENTRAINMENT -!C - totmas=subin-subdown+detup-entup-entdo+ & - detdo-entupk-entdoj+detupk -! if(j.eq.jpr.and.i.eq.ipr)print *,'k,totmas,sui,sud = ',k, -! 1 totmas,subin,subdown -! if(j.eq.jpr.and.i.eq.ipr)print *,'updr stuff = ',detup, -! 1 entup,entupk,detupk -! if(j.eq.jpr.and.i.eq.ipr)print *,'dddr stuff = ',entdo, -! 1 detdo,entdoj - if(abs(totmas).gt.1.e-6)then -! if(j.eq.jpr)then - print *,'*********************',i,j,k,totmas,name - print *,'k22,kbcon,ktop,jmin= ',k22(i),kbcon(i),ktop(i),jmin(i) - print *,'updr stuff = ',subin,subdown,detup,entup,entupk,detupk - print *,'dddr stuff = ',entdo,detdo,entdoj -! call wrf_error_fatal ( 'totmas .gt.1.e-6' ) - endif -! dp=100.*(p_cup(i,k-1)-p_cup(i,k)) - dp=100.*(p_cup(i,k)-p_cup(i,k+1)) - della(i,k)=(subin*he_cup(i,k+1) & - -subdown*he_cup(i,k) & - +detup*.5*(HC(i,K+1)+HC(i,K)) & - +detdo*.5*(HCD(i,K+1)+HCD(i,K)) & - -entup*he(i,k) & - -entdo*he(i,k) & - -entupk*he_cup(i,k22(i)+1) & - -entdoj*he_cup(i,jmin(i)) & - +detupk*hc(i,ktop(i)) & - )*g/dp -! if(i.eq.ipr.and.j.eq.jpr)then -! print *,k,della(i,k),subin*he_cup(i,k+1),subdown*he_cup(i,k), -! 1 detdo*.5*(HCD(i,K+1)+HCD(i,K)) -! print *,k,detup*.5*(HC(i,K+1)+HC(i,K)),detupk*hc(i,ktop(i)), -! 1 entup*he(i,k),entdo*he(i,k) -! print *,k,he_cup(i,k+1),he_cup(i,k),entupk*he_cup(i,k) -! endif - - 100 CONTINUE - - END SUBROUTINE cup_dellas - - - SUBROUTINE cup_direction2(i,j,dir,id,massflx, & - iresult,imass,massfld, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE - - integer & - ,intent (in ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - integer, intent (in ) :: & - i,j,imass - integer, intent (out ) :: & - iresult - ! - ! ierr error value, maybe modified in this routine - ! - integer, dimension (ims:ime,jms:jme) & - ,intent (in ) :: & - id - real, dimension (ims:ime,jms:jme) & - ,intent (in ) :: & - massflx - real, dimension (its:ite) & - ,intent (inout) :: & - dir - real & - ,intent (out ) :: & - massfld -! -! local variables in this routine -! - - integer k,ia,ja,ib,jb - real diff -! -! -! - if(imass.eq.1)then - massfld=massflx(i,j) - endif - iresult=0 -! return - diff=22.5 - if(dir(i).lt.22.5)dir(i)=360.+dir(i) - if(id(i,j).eq.1)iresult=1 -! ja=max(2,j-1) -! ia=max(2,i-1) -! jb=min(mjx-1,j+1) -! ib=min(mix-1,i+1) - ja=j-1 - ia=i-1 - jb=j+1 - ib=i+1 - if(dir(i).gt.90.-diff.and.dir(i).le.90.+diff)then -!--- steering flow from the east - if(id(ib,j).eq.1)then - iresult=1 - if(imass.eq.1)then - massfld=max(massflx(ib,j),massflx(i,j)) - endif - return - endif - else if(dir(i).gt.135.-diff.and.dir(i).le.135.+diff)then -!--- steering flow from the south-east - if(id(ib,ja).eq.1)then - iresult=1 - if(imass.eq.1)then - massfld=max(massflx(ib,ja),massflx(i,j)) - endif - return - endif -!--- steering flow from the south - else if(dir(i).gt.180.-diff.and.dir(i).le.180.+diff)then - if(id(i,ja).eq.1)then - iresult=1 - if(imass.eq.1)then - massfld=max(massflx(i,ja),massflx(i,j)) - endif - return - endif -!--- steering flow from the south west - else if(dir(i).gt.225.-diff.and.dir(i).le.225.+diff)then - if(id(ia,ja).eq.1)then - iresult=1 - if(imass.eq.1)then - massfld=max(massflx(ia,ja),massflx(i,j)) - endif - return - endif -!--- steering flow from the west - else if(dir(i).gt.270.-diff.and.dir(i).le.270.+diff)then - if(id(ia,j).eq.1)then - iresult=1 - if(imass.eq.1)then - massfld=max(massflx(ia,j),massflx(i,j)) - endif - return - endif -!--- steering flow from the north-west - else if(dir(i).gt.305.-diff.and.dir(i).le.305.+diff)then - if(id(ia,jb).eq.1)then - iresult=1 - if(imass.eq.1)then - massfld=max(massflx(ia,jb),massflx(i,j)) - endif - return - endif -!--- steering flow from the north - else if(dir(i).gt.360.-diff.and.dir(i).le.360.+diff)then - if(id(i,jb).eq.1)then - iresult=1 - if(imass.eq.1)then - massfld=max(massflx(i,jb),massflx(i,j)) - endif - return - endif -!--- steering flow from the north-east - else if(dir(i).gt.45.-diff.and.dir(i).le.45.+diff)then - if(id(ib,jb).eq.1)then - iresult=1 - if(imass.eq.1)then - massfld=max(massflx(ib,jb),massflx(i,j)) - endif - return - endif - endif - - END SUBROUTINE cup_direction2 - - - SUBROUTINE cup_env(z,qes,he,hes,t,q,p,z1, & - psur,ierr,tcrit,itest,xl,cp, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE - - integer & - ,intent (in ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - ! - ! ierr error value, maybe modified in this routine - ! q = environmental mixing ratio - ! qes = environmental saturation mixing ratio - ! t = environmental temp - ! tv = environmental virtual temp - ! p = environmental pressure - ! z = environmental heights - ! he = environmental moist static energy - ! hes = environmental saturation moist static energy - ! psur = surface pressure - ! z1 = terrain elevation - ! - ! - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - p,t - real, dimension (its:ite,kts:kte) & - ,intent (out ) :: & - he,hes,qes - real, dimension (its:ite,kts:kte) & - ,intent (inout) :: & - z,q - real, dimension (its:ite) & - ,intent (in ) :: & - psur,z1 - real & - ,intent (in ) :: & - xl,cp - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr - integer & - ,intent (in ) :: & - itest -! -! local variables in this routine -! - - integer :: & - i,k,iph - real, dimension (1:2) :: AE,BE,HT - real, dimension (its:ite,kts:kte) :: tv - real :: tcrit,e,tvbar - - integer :: itf, ktf - - itf=ite - ktf=kte - - HT(1)=XL/CP - HT(2)=2.834E6/CP - BE(1)=.622*HT(1)/.286 - AE(1)=BE(1)/273.+ALOG(610.71) - BE(2)=.622*HT(2)/.286 - AE(2)=BE(2)/273.+ALOG(610.71) -! print *, 'TCRIT = ', tcrit,its,ite - DO k=kts,ktf - do i=its,itf - if(ierr(i).eq.0)then -!Csgb - IPH is for phase, dependent on TCRIT (water or ice) - IPH=1 - IF(T(I,K).LE.TCRIT)IPH=2 -! print *, 'AE(IPH),BE(IPH) = ',AE(IPH),BE(IPH),AE(IPH)-BE(IPH),T(i,k),i,k - E=EXP(AE(IPH)-BE(IPH)/T(I,K)) -! print *, 'P, E = ', P(I,K), E - QES(I,K)=.622*E/(100.*P(I,K)-E) - IF(QES(I,K).LE.1.E-08)QES(I,K)=1.E-08 - IF(Q(I,K).GT.QES(I,K))Q(I,K)=QES(I,K) - TV(I,K)=T(I,K)+.608*Q(I,K)*T(I,K) - endif - enddo - enddo -! -!--- z's are calculated with changed h's and q's and t's -!--- if itest=2 -! - if(itest.ne.2)then - do i=its,itf - if(ierr(i).eq.0)then - Z(I,1)=max(0.,Z1(I))-(ALOG(P(I,1))- & - ALOG(PSUR(I)))*287.*TV(I,1)/9.81 - endif - enddo - -! --- calculate heights - DO K=kts+1,ktf - do i=its,itf - if(ierr(i).eq.0)then - TVBAR=.5*TV(I,K)+.5*TV(I,K-1) - Z(I,K)=Z(I,K-1)-(ALOG(P(I,K))- & - ALOG(P(I,K-1)))*287.*TVBAR/9.81 - endif - enddo - enddo - else - do k=kts,ktf - do i=its,itf - if(ierr(i).eq.0)then - z(i,k)=(he(i,k)-1004.*t(i,k)-2.5e6*q(i,k))/9.81 - z(i,k)=max(1.e-3,z(i,k)) - endif - enddo - enddo - endif -! -!--- calculate moist static energy - HE -! saturated moist static energy - HES -! - DO k=kts,ktf - do i=its,itf - if(ierr(i).eq.0)then - if(itest.eq.0)HE(I,K)=9.81*Z(I,K)+1004.*T(I,K)+2.5E06*Q(I,K) - HES(I,K)=9.81*Z(I,K)+1004.*T(I,K)+2.5E06*QES(I,K) - IF(HE(I,K).GE.HES(I,K))HE(I,K)=HES(I,K) -! if(i.eq.2)then -! print *,k,z(i,k),t(i,k),p(i,k),he(i,k),hes(i,k) -! endif - endif - enddo - enddo - - END SUBROUTINE cup_env - - - SUBROUTINE cup_env_clev(t,qes,q,he,hes,z,p,qes_cup,q_cup, & - he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup,psur, & - ierr,z1,xl,rv,cp, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE - - integer & - ,intent (in ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - ! - ! ierr error value, maybe modified in this routine - ! q = environmental mixing ratio - ! q_cup = environmental mixing ratio on cloud levels - ! qes = environmental saturation mixing ratio - ! qes_cup = environmental saturation mixing ratio on cloud levels - ! t = environmental temp - ! t_cup = environmental temp on cloud levels - ! p = environmental pressure - ! p_cup = environmental pressure on cloud levels - ! z = environmental heights - ! z_cup = environmental heights on cloud levels - ! he = environmental moist static energy - ! he_cup = environmental moist static energy on cloud levels - ! hes = environmental saturation moist static energy - ! hes_cup = environmental saturation moist static energy on cloud levels - ! gamma_cup = gamma on cloud levels - ! psur = surface pressure - ! z1 = terrain elevation - ! - ! - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - qes,q,he,hes,z,p,t - real, dimension (its:ite,kts:kte) & - ,intent (out ) :: & - qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup - real, dimension (its:ite) & - ,intent (in ) :: & - psur,z1 - real & - ,intent (in ) :: & - xl,rv,cp - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr -! -! local variables in this routine -! - - integer :: & - i,k - - integer :: itf, ktf - - itf=ite - ktf=kte - - do k=kts+1,ktf - do i=its,itf - if(ierr(i).eq.0)then - qes_cup(i,k)=.5*(qes(i,k-1)+qes(i,k)) - q_cup(i,k)=.5*(q(i,k-1)+q(i,k)) - hes_cup(i,k)=.5*(hes(i,k-1)+hes(i,k)) - he_cup(i,k)=.5*(he(i,k-1)+he(i,k)) - if(he_cup(i,k).gt.hes_cup(i,k))he_cup(i,k)=hes_cup(i,k) - z_cup(i,k)=.5*(z(i,k-1)+z(i,k)) - p_cup(i,k)=.5*(p(i,k-1)+p(i,k)) - t_cup(i,k)=.5*(t(i,k-1)+t(i,k)) - gamma_cup(i,k)=(xl/cp)*(xl/(rv*t_cup(i,k) & - *t_cup(i,k)))*qes_cup(i,k) - endif - enddo - enddo - do i=its,itf - if(ierr(i).eq.0)then - qes_cup(i,1)=qes(i,1) - q_cup(i,1)=q(i,1) - hes_cup(i,1)=hes(i,1) - he_cup(i,1)=he(i,1) - z_cup(i,1)=.5*(z(i,1)+z1(i)) - p_cup(i,1)=.5*(p(i,1)+psur(i)) - t_cup(i,1)=t(i,1) - gamma_cup(i,1)=xl/cp*(xl/(rv*t_cup(i,1) & - *t_cup(i,1)))*qes_cup(i,1) - endif - enddo - - END SUBROUTINE cup_env_clev - - - SUBROUTINE cup_forcing_ens(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2,ierr3,& - xf_ens,j,name,maxens,iens,iedt,maxens2,maxens3,mconv, & - p_cup,ktop,omeg,zd,k22,zu,pr_ens,edt,kbcon,massflx, & - iact_old_gr,dir,ensdim,massfln,icoic, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE - - integer & - ,intent (in ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - integer, intent (in ) :: & - j,ensdim,maxens,iens,iedt,maxens2,maxens3 - ! - ! ierr error value, maybe modified in this routine - ! pr_ens = precipitation ensemble - ! xf_ens = mass flux ensembles - ! massfln = downdraft mass flux ensembles used in next timestep - ! omeg = omega from large scale model - ! mconv = moisture convergence from large scale model - ! zd = downdraft normalized mass flux - ! zu = updraft normalized mass flux - ! aa0 = cloud work function without forcing effects - ! aa1 = cloud work function with forcing effects - ! xaa0 = cloud work function with cloud effects (ensemble dependent) - ! edt = epsilon - ! dir = "storm motion" - ! mbdt = arbitrary numerical parameter - ! dtime = dt over which forcing is applied - ! iact_gr_old = flag to tell where convection was active - ! kbcon = LFC of parcel from k22 - ! k22 = updraft originating level - ! icoic = flag if only want one closure (usually set to zero!) - ! name = deep or shallow convection flag - ! - real, dimension (ims:ime,jms:jme,1:ensdim) & - ,intent (inout) :: & - pr_ens - real, dimension (ims:ime,jms:jme,1:ensdim) & - ,intent (out ) :: & - xf_ens,massfln - real, dimension (ims:ime,jms:jme) & - ,intent (in ) :: & - massflx - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - omeg,zd,zu,p_cup - real, dimension (its:ite,1:maxens) & - ,intent (in ) :: & - xaa0 - real, dimension (its:ite) & - ,intent (in ) :: & - aa1,edt,dir,mconv,xland - real, dimension (its:ite) & - ,intent (inout) :: & - aa0,closure_n - real, dimension (1:maxens) & - ,intent (in ) :: & - mbdt - real & - ,intent (in ) :: & - dtime - integer, dimension (its:ite,jts:jte) & - ,intent (in ) :: & - iact_old_gr - integer, dimension (its:ite) & - ,intent (in ) :: & - k22,kbcon,ktop - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr,ierr2,ierr3 - integer & - ,intent (in ) :: & - icoic - character *(*), intent (in) :: & - name -! -! local variables in this routine -! - - real, dimension (1:maxens3) :: & - xff_ens3 - real, dimension (1:maxens) :: & - xk - integer :: & - i,k,nall,n,ne,nens,nens3,iresult,iresultd,iresulte,mkxcrt,kclim - parameter (mkxcrt=15) - real :: & - a1,massfld,xff0,xomg,aclim1,aclim2,aclim3,aclim4 - real, dimension(1:mkxcrt) :: & - pcrit,acrit,acritt - - integer :: itf,nall2 - - itf=ite - - DATA PCRIT/850.,800.,750.,700.,650.,600.,550.,500.,450.,400., & - 350.,300.,250.,200.,150./ - DATA ACRIT/.0633,.0445,.0553,.0664,.075,.1082,.1521,.2216, & - .3151,.3677,.41,.5255,.7663,1.1686,1.6851/ -! GDAS DERIVED ACRIT - DATA ACRITT/.203,.515,.521,.566,.625,.665,.659,.688, & - .743,.813,.886,.947,1.138,1.377,1.896/ -! - nens=0 - -!--- LARGE SCALE FORCING -! - DO 100 i=its,itf -! if(i.eq.ipr.and.j.eq.jpr)print *,'ierr = ',ierr(i) - if(name.eq.'deeps'.and.ierr(i).gt.995)then -! print *,i,j,ierr(i),aa0(i) - aa0(i)=0. - ierr(i)=0 - endif - IF(ierr(i).eq.0)then -! kclim=0 - do k=mkxcrt,1,-1 - if(p_cup(i,ktop(i)).lt.pcrit(k))then - kclim=k - go to 9 - endif - enddo - if(p_cup(i,ktop(i)).ge.pcrit(1))kclim=1 - 9 continue - kclim=max(kclim,1) - k=max(kclim-1,1) - aclim1=acrit(kclim)*1.e3 - aclim2=acrit(k)*1.e3 - aclim3=acritt(kclim)*1.e3 - aclim4=acritt(k)*1.e3 -! print *,'p_cup(ktop(i)),kclim,pcrit(kclim)' -! print *,p_cup(i,ktop(i)),kclim,pcrit(kclim) -! print *,'aclim1,aclim2,aclim3,aclim4' -! print *,aclim1,aclim2,aclim3,aclim4 -! print *,dtime,name,ierr(i),aa1(i),aa0(i) -! print *,dtime,name,ierr(i),aa1(i),aa0(i) -! -!--- treatment different for this closure -! - if(name.eq.'deeps')then -! - xff0= (AA1(I)-AA0(I))/DTIME - xff_ens3(1)=(AA1(I)-AA0(I))/dtime - xff_ens3(2)=.9*xff_ens3(1) - xff_ens3(3)=1.1*xff_ens3(1) -! -!--- more original Arakawa-Schubert (climatologic value of aa0) -! -! -!--- omeg is in bar/s, mconv done with omeg in Pa/s -! more like Brown (1979), or Frank-Cohen (199?) -! - xff_ens3(4)=-omeg(i,k22(i))/9.81 - xff_ens3(5)=-omeg(i,kbcon(i))/9.81 - xff_ens3(6)=-omeg(i,1)/9.81 - do k=2,kbcon(i)-1 - xomg=-omeg(i,k)/9.81 - if(xomg.gt.xff_ens3(6))xff_ens3(6)=xomg - enddo -! -!--- more like Krishnamurti et al. -! - xff_ens3(7)=mconv(i) - xff_ens3(8)=mconv(i) - xff_ens3(9)=mconv(i) -! -!--- more like Fritsch Chappel or Kain Fritsch (plus triggers) -! - xff_ens3(10)=AA1(I)/(60.*20.) - xff_ens3(11)=AA1(I)/(60.*30.) - xff_ens3(12)=AA1(I)/(60.*40.) -! -!--- more original Arakawa-Schubert (climatologic value of aa0) -! - xff_ens3(13)=max(0.,(AA1(I)-aclim1)/dtime) - xff_ens3(14)=max(0.,(AA1(I)-aclim2)/dtime) - xff_ens3(15)=max(0.,(AA1(I)-aclim3)/dtime) - xff_ens3(16)=max(0.,(AA1(I)-aclim4)/dtime) -! if(ierr2(i).gt.0.or.ierr3(i).gt.0)then -! xff_ens3(10)=0. -! xff_ens3(11)=0. -! xff_ens3(12)=0. -! xff_ens3(13)=0. -! xff_ens3(14)=0. -! xff_ens3(15)=0. -! xff_ens3(16)=0. -! endif - - do nens=1,maxens - XK(nens)=(XAA0(I,nens)-AA1(I))/MBDT(2) - if(xk(nens).le.0.and.xk(nens).gt.-1.e-6) & - xk(nens)=-1.e-6 - if(xk(nens).gt.0.and.xk(nens).lt.1.e-6) & - xk(nens)=1.e-6 - enddo -! -!--- add up all ensembles -! - do 350 ne=1,maxens -! -!--- for every xk, we have maxens3 xffs -!--- iens is from outermost ensemble (most expensive! -! -!--- iedt (maxens2 belongs to it) -!--- is from second, next outermost, not so expensive -! -!--- so, for every outermost loop, we have maxens*maxens2*3 -!--- ensembles!!! nall would be 0, if everything is on first -!--- loop index, then ne would start counting, then iedt, then iens.... -! - iresult=0 - iresultd=0 - iresulte=0 - nall=(iens-1)*maxens3*maxens*maxens2 & - +(iedt-1)*maxens*maxens3 & - +(ne-1)*maxens3 -! -! over water, enfor!e small cap for some of the closures -! - if(xland(i).lt.-0.1)then - if(ierr2(i).gt.0.or.ierr3(i).gt.0)then -! - ierr2 - 75 mb cap thickness, ierr3 - 125 cap thickness - -! - for larger cap, set Grell closure to zero - xff_ens3(1) =0. - massfln(i,j,nall+1)=0. - xff_ens3(2) =0. - massfln(i,j,nall+2)=0. - xff_ens3(3) =0. - massfln(i,j,nall+3)=0. - closure_n(i)=closure_n(i)-1. - - xff_ens3(7) =0. - massfln(i,j,nall+7)=0. - xff_ens3(8) =0. - massfln(i,j,nall+8)=0. - xff_ens3(9) =0. -! massfln(i,j,nall+9)=0. - closure_n(i)=closure_n(i)-1. - endif -! -! also take out some closures in general -! - xff_ens3(4) =0. - massfln(i,j,nall+4)=0. - xff_ens3(5) =0. - massfln(i,j,nall+5)=0. - xff_ens3(6) =0. - massfln(i,j,nall+6)=0. - closure_n(i)=closure_n(i)-3. - - xff_ens3(10)=0. - massfln(i,j,nall+10)=0. - xff_ens3(11)=0. - massfln(i,j,nall+11)=0. - xff_ens3(12)=0. - massfln(i,j,nall+12)=0. - if(ne.eq.1)closure_n(i)=closure_n(i)-3 - xff_ens3(13)=0. - massfln(i,j,nall+13)=0. - xff_ens3(14)=0. - massfln(i,j,nall+14)=0. - xff_ens3(15)=0. - massfln(i,j,nall+15)=0. - massfln(i,j,nall+16)=0. - if(ne.eq.1)closure_n(i)=closure_n(i)-4 - - endif -! -! end water treatment -! -!--- check for upwind convection -! iresult=0 - massfld=0. - -! call cup_direction2(i,j,dir,iact_old_gr, & -! massflx,iresult,1, & -! massfld, & -! ids,ide, jds,jde, kds,kde, & -! ims,ime, jms,jme, kms,kme, & -! its,ite, jts,jte, kts,kte ) -! if(i.eq.ipr.and.j.eq.jpr.and.iedt.eq.1.and.ne.eq.1)then -! if(iedt.eq.1.and.ne.eq.1)then -! print *,massfld,ne,iedt,iens -! print *,xk(ne),xff_ens3(1),xff_ens3(2),xff_ens3(3) -! endif -! print *,i,j,massfld,aa0(i),aa1(i) - IF(XK(ne).lt.0.and.xff0.gt.0.)iresultd=1 - iresulte=max(iresult,iresultd) - iresulte=1 - if(iresulte.eq.1)then -! -!--- special treatment for stability closures -! - - if(xff0.gt.0.)then - xf_ens(i,j,nall+1)=max(0.,-xff_ens3(1)/xk(ne)) & - +massfld - xf_ens(i,j,nall+2)=max(0.,-xff_ens3(2)/xk(ne)) & - +massfld - xf_ens(i,j,nall+3)=max(0.,-xff_ens3(3)/xk(ne)) & - +massfld - xf_ens(i,j,nall+13)=max(0.,-xff_ens3(13)/xk(ne)) & - +massfld - xf_ens(i,j,nall+14)=max(0.,-xff_ens3(14)/xk(ne)) & - +massfld - xf_ens(i,j,nall+15)=max(0.,-xff_ens3(15)/xk(ne)) & - +massfld - xf_ens(i,j,nall+16)=max(0.,-xff_ens3(16)/xk(ne)) & - +massfld - else - xf_ens(i,j,nall+1)=massfld - xf_ens(i,j,nall+2)=massfld - xf_ens(i,j,nall+3)=massfld - xf_ens(i,j,nall+13)=massfld - xf_ens(i,j,nall+14)=massfld - xf_ens(i,j,nall+15)=massfld - xf_ens(i,j,nall+16)=massfld - endif -! -!--- if iresult.eq.1, following independent of xff0 -! - xf_ens(i,j,nall+4)=max(0.,xff_ens3(4) & - +massfld) - xf_ens(i,j,nall+5)=max(0.,xff_ens3(5) & - +massfld) - xf_ens(i,j,nall+6)=max(0.,xff_ens3(6) & - +massfld) - a1=max(1.e-3,pr_ens(i,j,nall+7)) - xf_ens(i,j,nall+7)=max(0.,xff_ens3(7) & - /a1) - a1=max(1.e-3,pr_ens(i,j,nall+8)) - xf_ens(i,j,nall+8)=max(0.,xff_ens3(8) & - /a1) - a1=max(1.e-3,pr_ens(i,j,nall+9)) - xf_ens(i,j,nall+9)=max(0.,xff_ens3(9) & - /a1) - if(XK(ne).lt.0.)then - xf_ens(i,j,nall+10)=max(0., & - -xff_ens3(10)/xk(ne)) & - +massfld - xf_ens(i,j,nall+11)=max(0., & - -xff_ens3(11)/xk(ne)) & - +massfld - xf_ens(i,j,nall+12)=max(0., & - -xff_ens3(12)/xk(ne)) & - +massfld - else - xf_ens(i,j,nall+10)=massfld - xf_ens(i,j,nall+11)=massfld - xf_ens(i,j,nall+12)=massfld - endif - if(icoic.ge.1)then - closure_n(i)=0. - xf_ens(i,j,nall+1)=xf_ens(i,j,nall+icoic) - xf_ens(i,j,nall+2)=xf_ens(i,j,nall+icoic) - xf_ens(i,j,nall+3)=xf_ens(i,j,nall+icoic) - xf_ens(i,j,nall+4)=xf_ens(i,j,nall+icoic) - xf_ens(i,j,nall+5)=xf_ens(i,j,nall+icoic) - xf_ens(i,j,nall+6)=xf_ens(i,j,nall+icoic) - xf_ens(i,j,nall+7)=xf_ens(i,j,nall+icoic) - xf_ens(i,j,nall+8)=xf_ens(i,j,nall+icoic) - xf_ens(i,j,nall+9)=xf_ens(i,j,nall+icoic) - xf_ens(i,j,nall+10)=xf_ens(i,j,nall+icoic) - xf_ens(i,j,nall+11)=xf_ens(i,j,nall+icoic) - xf_ens(i,j,nall+12)=xf_ens(i,j,nall+icoic) - xf_ens(i,j,nall+13)=xf_ens(i,j,nall+icoic) - xf_ens(i,j,nall+14)=xf_ens(i,j,nall+icoic) - xf_ens(i,j,nall+15)=xf_ens(i,j,nall+icoic) - xf_ens(i,j,nall+16)=xf_ens(i,j,nall+icoic) - endif -! -! replace 13-16 for now with other stab closures -! (13 gave problems for mass model) -! -! xf_ens(i,j,nall+13)=xf_ens(i,j,nall+1) - if(icoic.eq.0)xf_ens(i,j,nall+14)=xf_ens(i,j,nall+13) -! xf_ens(i,j,nall+15)=xf_ens(i,j,nall+11) -! xf_ens(i,j,nall+16)=xf_ens(i,j,nall+11) -! xf_ens(i,j,nall+7)=xf_ens(i,j,nall+4) -! xf_ens(i,j,nall+8)=xf_ens(i,j,nall+5) -! xf_ens(i,j,nall+9)=xf_ens(i,j,nall+6) -! -!--- store new for next time step -! - do nens3=1,maxens3 - massfln(i,j,nall+nens3)=edt(i) & - *xf_ens(i,j,nall+nens3) - massfln(i,j,nall+nens3)=max(0., & - massfln(i,j,nall+nens3)) - enddo -! -! -!--- do some more on the caps!!! ne=1 for 175, ne=2 for 100,.... -! -! do not care for caps here for closure groups 1 and 5, -! they are fine, do not turn them off here -! -! - if(ne.eq.2.and.ierr2(i).gt.0)then - xf_ens(i,j,nall+1) =0. - xf_ens(i,j,nall+2) =0. - xf_ens(i,j,nall+3) =0. - xf_ens(i,j,nall+4) =0. - xf_ens(i,j,nall+5) =0. - xf_ens(i,j,nall+6) =0. - xf_ens(i,j,nall+7) =0. - xf_ens(i,j,nall+8) =0. - xf_ens(i,j,nall+9) =0. - xf_ens(i,j,nall+10)=0. - xf_ens(i,j,nall+11)=0. - xf_ens(i,j,nall+12)=0. - xf_ens(i,j,nall+13)=0. - xf_ens(i,j,nall+14)=0. - xf_ens(i,j,nall+15)=0. - xf_ens(i,j,nall+16)=0. - massfln(i,j,nall+1)=0. - massfln(i,j,nall+2)=0. - massfln(i,j,nall+3)=0. - massfln(i,j,nall+4)=0. - massfln(i,j,nall+5)=0. - massfln(i,j,nall+6)=0. - massfln(i,j,nall+7)=0. - massfln(i,j,nall+8)=0. - massfln(i,j,nall+9)=0. - massfln(i,j,nall+10)=0. - massfln(i,j,nall+11)=0. - massfln(i,j,nall+12)=0. - massfln(i,j,nall+13)=0. - massfln(i,j,nall+14)=0. - massfln(i,j,nall+15)=0. - massfln(i,j,nall+16)=0. - endif - if(ne.eq.3.and.ierr3(i).gt.0)then - xf_ens(i,j,nall+1) =0. - xf_ens(i,j,nall+2) =0. - xf_ens(i,j,nall+3) =0. - xf_ens(i,j,nall+4) =0. - xf_ens(i,j,nall+5) =0. - xf_ens(i,j,nall+6) =0. - xf_ens(i,j,nall+7) =0. - xf_ens(i,j,nall+8) =0. - xf_ens(i,j,nall+9) =0. - xf_ens(i,j,nall+10)=0. - xf_ens(i,j,nall+11)=0. - xf_ens(i,j,nall+12)=0. - xf_ens(i,j,nall+13)=0. - xf_ens(i,j,nall+14)=0. - xf_ens(i,j,nall+15)=0. - xf_ens(i,j,nall+16)=0. - massfln(i,j,nall+1)=0. - massfln(i,j,nall+2)=0. - massfln(i,j,nall+3)=0. - massfln(i,j,nall+4)=0. - massfln(i,j,nall+5)=0. - massfln(i,j,nall+6)=0. - massfln(i,j,nall+7)=0. - massfln(i,j,nall+8)=0. - massfln(i,j,nall+9)=0. - massfln(i,j,nall+10)=0. - massfln(i,j,nall+11)=0. - massfln(i,j,nall+12)=0. - massfln(i,j,nall+13)=0. - massfln(i,j,nall+14)=0. - massfln(i,j,nall+15)=0. - massfln(i,j,nall+16)=0. - endif - - endif - 350 continue -! ne=1, cap=175 -! - nall=(iens-1)*maxens3*maxens*maxens2 & - +(iedt-1)*maxens*maxens3 -! ne=2, cap=100 -! - nall2=(iens-1)*maxens3*maxens*maxens2 & - +(iedt-1)*maxens*maxens3 & - +(2-1)*maxens3 - xf_ens(i,j,nall+4) = xf_ens(i,j,nall2+4) - xf_ens(i,j,nall+5) =xf_ens(i,j,nall2+5) - xf_ens(i,j,nall+6) =xf_ens(i,j,nall2+6) - xf_ens(i,j,nall+7) =xf_ens(i,j,nall2+7) - xf_ens(i,j,nall+8) =xf_ens(i,j,nall2+8) - xf_ens(i,j,nall+9) =xf_ens(i,j,nall2+9) - xf_ens(i,j,nall+10)=xf_ens(i,j,nall2+10) - xf_ens(i,j,nall+11)=xf_ens(i,j,nall2+11) - xf_ens(i,j,nall+12)=xf_ens(i,j,nall2+12) - go to 100 - endif - elseif(ierr(i).ne.20.and.ierr(i).ne.0)then - do n=1,ensdim - xf_ens(i,j,n)=0. - massfln(i,j,n)=0. - enddo - endif - 100 continue - - END SUBROUTINE cup_forcing_ens - - - SUBROUTINE cup_kbcon(cap_inc,iloop,k22,kbcon,he_cup,hes_cup, & - ierr,kbmax,p_cup,cap_max, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - ! - ! - ! - ! ierr error value, maybe modified in this routine - ! - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - he_cup,hes_cup,p_cup - real, dimension (its:ite) & - ,intent (in ) :: & - cap_max,cap_inc - integer, dimension (its:ite) & - ,intent (in ) :: & - kbmax - integer, dimension (its:ite) & - ,intent (inout) :: & - kbcon,k22,ierr - integer & - ,intent (in ) :: & - iloop -! -! local variables in this routine -! - - integer :: & - i - real :: & - pbcdif,plus - integer :: itf - - itf=ite -! -!--- DETERMINE THE LEVEL OF CONVECTIVE CLOUD BASE - KBCON -! - DO 27 i=its,itf - kbcon(i)=1 - IF(ierr(I).ne.0)GO TO 27 - KBCON(I)=K22(I) - GO TO 32 - 31 CONTINUE - KBCON(I)=KBCON(I)+1 - IF(KBCON(I).GT.KBMAX(i)+4)THEN - if(iloop.lt.4)ierr(i)=3 -! if(iloop.lt.4)ierr(i)=997 - GO TO 27 - ENDIF - 32 CONTINUE - IF(HE_cup(I,K22(I)).LT.HES_cup(I,KBCON(I)))GO TO 31 - -! cloud base pressure and max moist static energy pressure -! i.e., the depth (in mb) of the layer of negative buoyancy - if(KBCON(I)-K22(I).eq.1)go to 27 - PBCDIF=-P_cup(I,KBCON(I))+P_cup(I,K22(I)) - plus=max(25.,cap_max(i)-float(iloop-1)*cap_inc(i)) - if(iloop.eq.4)plus=cap_max(i) - IF(PBCDIF.GT.plus)THEN - K22(I)=K22(I)+1 - KBCON(I)=K22(I) - GO TO 32 - ENDIF - 27 CONTINUE - - END SUBROUTINE cup_kbcon - - - SUBROUTINE cup_kbcon_cin(iloop,k22,kbcon,he_cup,hes_cup, & - z,tmean,qes,ierr,kbmax,p_cup,cap_max,xl,cp, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - ! - ! - ! - ! ierr error value, maybe modified in this routine - ! - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - he_cup,hes_cup,p_cup,z,tmean,qes - real, dimension (its:ite) & - ,intent (in ) :: & - cap_max - real & - ,intent (in ) :: & - xl,cp - integer, dimension (its:ite) & - ,intent (in ) :: & - kbmax - integer, dimension (its:ite) & - ,intent (inout) :: & - kbcon,k22,ierr - integer & - ,intent (in ) :: & - iloop -! -! local variables in this routine -! - - integer :: & - i,k - real :: & - cin,cin_max,dh,tprim,gamma -! - integer :: itf - - itf=ite -! -! - -! -!--- DETERMINE THE LEVEL OF CONVECTIVE CLOUD BASE - KBCON -! - DO 27 i=its,itf - cin_max=-cap_max(i) - kbcon(i)=1 - cin = 0. - IF(ierr(I).ne.0)GO TO 27 - KBCON(I)=K22(I) - GO TO 32 - 31 CONTINUE - KBCON(I)=KBCON(I)+1 - IF(KBCON(I).GT.KBMAX(i)+2)THEN - if(iloop.eq.1)ierr(i)=3 -! if(iloop.eq.2)ierr(i)=997 - GO TO 27 - ENDIF - 32 CONTINUE - dh = HE_cup(I,K22(I)) - HES_cup(I,KBCON(I)) - if (dh.lt. 0.) then - GAMMA=(xl/cp)*(xl/(461.525*(Tmean(I,K22(i))**2)))*QES(I,K22(i)) - tprim = dh/(cp*(1.+gamma)) - - cin = cin + 9.8066 * tprim & - *(z(i,k22(i))-z(i,k22(i)-1)) / tmean(i,k22(i)) - go to 31 - end if - - -! If negative energy in negatively buoyant layer -! exceeds convective inhibition (CIN) threshold, -! then set K22 level one level up and see if that -! will work. - - IF(cin.lT.cin_max)THEN -! print *,i,cin,cin_max,k22(i),kbcon(i) - K22(I)=K22(I)+1 - KBCON(I)=K22(I) - GO TO 32 - ENDIF - 27 CONTINUE - - END SUBROUTINE cup_kbcon_cin - - - SUBROUTINE cup_ktop(ilo,dby,kbcon,ktop,ierr, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE -! -! on input -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - ! dby = buoancy term - ! ktop = cloud top (output) - ! ilo = flag - ! ierr error value, maybe modified in this routine - ! - real, dimension (its:ite,kts:kte) & - ,intent (inout) :: & - dby - integer, dimension (its:ite) & - ,intent (in ) :: & - kbcon - integer & - ,intent (in ) :: & - ilo - integer, dimension (its:ite) & - ,intent (out ) :: & - ktop - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr -! -! local variables in this routine -! - - integer :: & - i,k -! - integer :: itf, ktf - - itf=ite - ktf=kte -! -! - DO 42 i=its,itf - ktop(i)=1 - IF(ierr(I).EQ.0)then - DO 40 K=KBCON(I)+1,ktf-1 - IF(DBY(I,K).LE.0.)THEN - KTOP(I)=K-1 - GO TO 41 - ENDIF - 40 CONTINUE - if(ilo.eq.1)ierr(i)=5 -! if(ilo.eq.2)ierr(i)=998 - GO TO 42 - 41 CONTINUE - do k=ktop(i)+1,ktf - dby(i,k)=0. - enddo - endif - 42 CONTINUE - - END SUBROUTINE cup_ktop - - - SUBROUTINE cup_MAXIMI(ARRAY,KS,KE,MAXX,ierr, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE -! -! on input -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - ! array input array - ! x output array with return values - ! kt output array of levels - ! ks,kend check-range - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - array - integer, dimension (its:ite) & - ,intent (in ) :: & - ierr,ke - integer & - ,intent (in ) :: & - ks - integer, dimension (its:ite) & - ,intent (out ) :: & - maxx - real, dimension (its:ite) :: & - x - real :: & - xar - integer :: & - i,k - integer :: itf - - itf=ite - - DO 200 i=its,itf - MAXX(I)=KS - if(ierr(i).eq.0)then - X(I)=ARRAY(I,KS) -! - DO 100 K=KS,KE(i) - XAR=ARRAY(I,K) - IF(XAR.GE.X(I)) THEN - X(I)=XAR - MAXX(I)=K - ENDIF - 100 CONTINUE - endif - 200 CONTINUE - - END SUBROUTINE cup_MAXIMI - - - SUBROUTINE cup_minimi(ARRAY,KS,KEND,KT,ierr, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE -! -! on input -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - ! array input array - ! x output array with return values - ! kt output array of levels - ! ks,kend check-range - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - array - integer, dimension (its:ite) & - ,intent (in ) :: & - ierr,ks,kend - integer, dimension (its:ite) & - ,intent (out ) :: & - kt - real, dimension (its:ite) :: & - x - integer :: & - i,k,kstop - - integer :: itf - - itf=ite - - DO 200 i=its,itf - KT(I)=KS(I) - if(ierr(i).eq.0)then - X(I)=ARRAY(I,KS(I)) - KSTOP=MAX(KS(I)+1,KEND(I)) -! - DO 100 K=KS(I)+1,KSTOP - IF(ARRAY(I,K).LT.X(I)) THEN - X(I)=ARRAY(I,K) - KT(I)=K - ENDIF - 100 CONTINUE - endif - 200 CONTINUE - - END SUBROUTINE cup_MINIMI - - - SUBROUTINE cup_output_ens(xf_ens,ierr,dellat,dellaq,dellaqc, & - outtem,outq,outqc,pre,pw,xmb,ktop, & - j,name,nx,nx2,iens,ierr2,ierr3,pr_ens, & - maxens3,ensdim,massfln,xmbmax, & - APR_GR,APR_W,APR_MC,APR_ST,APR_AS, & - APR_CAPMA,APR_CAPME,APR_CAPMI,closure_n,xland1, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - - IMPLICIT NONE -! -! on input -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - integer, intent (in ) :: & - j,ensdim,nx,nx2,iens,maxens3 - ! xf_ens = ensemble mass fluxes - ! pr_ens = precipitation ensembles - ! dellat = change of temperature per unit mass flux of cloud ensemble - ! dellaq = change of q per unit mass flux of cloud ensemble - ! dellaqc = change of qc per unit mass flux of cloud ensemble - ! outtem = output temp tendency (per s) - ! outq = output q tendency (per s) - ! outqc = output qc tendency (per s) - ! pre = output precip - ! xmb = total base mass flux - ! xfac1 = correction factor - ! pw = pw -epsilon*pd (ensemble dependent) - ! ierr error value, maybe modified in this routine - ! - real, dimension (ims:ime,jms:jme,1:ensdim) & - ,intent (inout) :: & - xf_ens,pr_ens,massfln - real, dimension (ims:ime,jms:jme) & - ,intent (inout) :: & - APR_GR,APR_W,APR_MC,APR_ST,APR_AS,APR_CAPMA, & - APR_CAPME,APR_CAPMI - - real, dimension (its:ite,kts:kte) & - ,intent (out ) :: & - outtem,outq,outqc - real, dimension (its:ite) & - ,intent (out ) :: & - pre,xmb - real, dimension (its:ite) & - ,intent (inout ) :: & - closure_n,xland1 - real, dimension (its:ite) & - ,intent (in ) :: & - xmbmax - real, dimension (its:ite,kts:kte,1:nx) & - ,intent (in ) :: & - dellat,dellaqc,dellaq,pw - integer, dimension (its:ite) & - ,intent (in ) :: & - ktop - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr,ierr2,ierr3 -! -! local variables in this routine -! - - integer :: & - i,k,n,ncount - real :: & - outtes,ddtes,dtt,dtq,dtqc,dtpw,tuning,prerate,clos_wei - real, dimension (its:ite) :: & - xfac1 - real, dimension (its:ite):: & - xmb_ske,xmb_ave,xmb_std,xmb_cur,xmbweight - real, dimension (its:ite):: & - pr_ske,pr_ave,pr_std,pr_cur - real, dimension (its:ite,jts:jte):: & - pr_gr,pr_w,pr_mc,pr_st,pr_as,pr_capma, & - pr_capme,pr_capmi - -! - character *(*), intent (in) :: & - name -! - integer :: itf, ktf - - itf=ite - ktf=kte - tuning=0.2 -! -! - DO k=kts,ktf - do i=its,itf - outtem(i,k)=0. - outq(i,k)=0. - outqc(i,k)=0. - enddo - enddo - do i=its,itf - pre(i)=0. - xmb(i)=0. - xfac1(i)=1. - xmbweight(i)=1. - enddo - do i=its,itf - IF(ierr(i).eq.0)then - do n=(iens-1)*nx*nx2*maxens3+1,iens*nx*nx2*maxens3 - if(pr_ens(i,j,n).le.0.)then - xf_ens(i,j,n)=0. - endif - enddo - endif - enddo -! -!--- calculate ensemble average mass fluxes -! - call massflx_stats(xf_ens,ensdim,nx2,nx,maxens3, & - xmb_ave,xmb_std,xmb_cur,xmb_ske,j,ierr,1, & - APR_GR,APR_W,APR_MC,APR_ST,APR_AS, & - APR_CAPMA,APR_CAPME,APR_CAPMI, & - pr_gr,pr_w,pr_mc,pr_st,pr_as, & - pr_capma,pr_capme,pr_capmi, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - call massflx_stats(pr_ens,ensdim,nx2,nx,maxens3, & - pr_ave,pr_std,pr_cur,pr_ske,j,ierr,2, & - APR_GR,APR_W,APR_MC,APR_ST,APR_AS, & - APR_CAPMA,APR_CAPME,APR_CAPMI, & - pr_gr,pr_w,pr_mc,pr_st,pr_as, & - pr_capma,pr_capme,pr_capmi, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) -! -!-- now do feedback -! - ddtes=200. -! if(name.eq.'shal')ddtes=200. - do i=its,itf - if(ierr(i).eq.0)then - if(xmb_ave(i).le.0.)then - ierr(i)=13 - xmb_ave(i)=0. - endif -! xmb(i)=max(0.,xmb_ave(i)) - xmb(i)=max(.1*xmb_ave(i),xmb_ave(i)-tuning*xmb_std(i)) -! xmb(i)=max(.1*xmb_ave(i),(1.+tuning)*xmb_ave(i)) -! --- Now use proper count of how many closures were actually -! used in cup_forcing_ens (including screening of some -! closures over water) to properly normalize xmb - clos_wei=16./max(1.,closure_n(i)) - if (xland1(i).lt.0.5)xmb(i)=xmb(i)*clos_wei -! make sure you take out more mass than what is there - xmb(i)=min(xmb(i),xmbmax(i)) - if(xmb(i).eq.0.)then - ierr(i)=19 - endif - if(xmb(i).gt.100.)then - ierr(i)=19 - endif - xfac1(i)=xmb(i) - - endif - xfac1(i)=xmb_ave(i) - ENDDO - DO k=kts,ktf - do i=its,itf - dtt=0. - dtq=0. - dtqc=0. - dtpw=0. - IF(ierr(i).eq.0.and.k.le.ktop(i))then - do n=1,nx - dtt=dtt+dellat(i,k,n) - dtq=dtq+dellaq(i,k,n) - dtqc=dtqc+dellaqc(i,k,n) - dtpw=dtpw+pw(i,k,n) - enddo - outtes=dtt*XMB(I)*86400./float(nx) - IF((OUTTES.GT.2.*ddtes.and.k.gt.2))THEN - XMB(I)= 2.*ddtes/outtes * xmb(i) - outtes=1.*ddtes - endif - if (outtes .lt. -ddtes) then - XMB(I)= -ddtes/outtes * xmb(i) - outtes=-ddtes - endif - if (outtes .gt. .5*ddtes.and.k.le.2) then - XMB(I)= ddtes/outtes * xmb(i) - outtes=.5*ddtes - endif - OUTTEM(I,K)=XMB(I)*dtt/float(nx) - OUTQ(I,K)=XMB(I)*dtq/float(nx) - OUTQC(I,K)=XMB(I)*dtqc/float(nx) - PRE(I)=PRE(I)+XMB(I)*dtpw/float(nx) - endif - enddo - enddo -! do i=its,itf -! if(ierr(i).eq.0)then -! prerate=pre(i)*3600. -! if(prerate.lt.0.1)then -! if(ierr2(i).gt.0.or.ierr3(i).gt.0)then -! pre(i)=0. -! ierr(i)=221 -! do k=kts,ktf -! outtem(i,k)=0. -! outq(i,k)=0. -! outqc(i,k)=0. -! enddo -! do k=(iens-1)*nx*nx2*maxens3+1,iens*nx*nx2*maxens3 -! massfln(i,j,k)=0. -! xf_ens(i,j,k)=0. -! enddo -! endif -! endif - -! endif -! ENDDO - - do i=its,itf - if(ierr(i).eq.0)then - xfac1(i)=xmb(i)/xfac1(i) - do k=(iens-1)*nx*nx2*maxens3+1,iens*nx*nx2*maxens3 - massfln(i,j,k)=massfln(i,j,k)*xfac1(i) - xf_ens(i,j,k)=xf_ens(i,j,k)*xfac1(i) - enddo - endif - ENDDO - - END SUBROUTINE cup_output_ens - - - SUBROUTINE cup_up_aa0(aa0,z,zu,dby,GAMMA_CUP,t_cup, & - kbcon,ktop,ierr, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE -! -! on input -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - ! aa0 cloud work function - ! gamma_cup = gamma on model cloud levels - ! t_cup = temperature (Kelvin) on model cloud levels - ! dby = buoancy term - ! zu= normalized updraft mass flux - ! z = heights of model levels - ! ierr error value, maybe modified in this routine - ! - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - z,zu,gamma_cup,t_cup,dby - integer, dimension (its:ite) & - ,intent (in ) :: & - kbcon,ktop -! -! input and output -! - - - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr - real, dimension (its:ite) & - ,intent (out ) :: & - aa0 -! -! local variables in this routine -! - - integer :: & - i,k - real :: & - dz,da -! - integer :: itf, ktf - - itf = ite - ktf = kte - - do i=its,itf - aa0(i)=0. - enddo - DO 100 k=kts+1,ktf - DO 100 i=its,itf - IF(ierr(i).ne.0)GO TO 100 - IF(K.LE.KBCON(I))GO TO 100 - IF(K.Gt.KTOP(I))GO TO 100 - DZ=Z(I,K)-Z(I,K-1) - da=zu(i,k)*DZ*(9.81/(1004.*( & - (T_cup(I,K)))))*DBY(I,K-1)/ & - (1.+GAMMA_CUP(I,K)) - IF(K.eq.KTOP(I).and.da.le.0.)go to 100 - AA0(I)=AA0(I)+da - if(aa0(i).lt.0.)aa0(i)=0. -100 continue - - END SUBROUTINE cup_up_aa0 - - - SUBROUTINE cup_up_he(k22,hkb,z_cup,cd,entr,he_cup,hc, & - kbcon,ierr,dby,he,hes_cup, & - xlamue, xlamud, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE -! -! on input -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - ! hc = cloud moist static energy - ! hkb = moist static energy at originating level - ! he = moist static energy on model levels - ! he_cup = moist static energy on model cloud levels - ! hes_cup = saturation moist static energy on model cloud levels - ! dby = buoancy term - ! cd= detrainment function - ! z_cup = heights of model cloud levels - ! entr = entrainment rate - ! - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - he,he_cup,hes_cup,z_cup,cd - ! entr= entrainment rate - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - xlamue - real, dimension (its:ite) & - ,intent (in ) :: & - xlamud - - real & - ,intent (in ) :: & - entr - integer, dimension (its:ite) & - ,intent (in ) :: & - kbcon,k22 -! -! input and output -! - - ! ierr error value, maybe modified in this routine - - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr - - real, dimension (its:ite,kts:kte) & - ,intent (out ) :: & - hc,dby - real, dimension (its:ite) & - ,intent (out ) :: & - hkb -! -! local variables in this routine -! - - integer :: & - i,k - real :: & - dz,upentr,updetr -! - integer :: itf, ktf - - itf = ite - ktf = kte -! -!--- moist static energy inside cloud -! - do i=its,itf - if(ierr(i).eq.0.)then - hkb(i)=he_cup(i,k22(i)) - do k=1,k22(i) - hc(i,k)=he_cup(i,k) - DBY(I,K)=0. - enddo - do k=k22(i),kbcon(i)-1 - hc(i,k)=hkb(i) - DBY(I,K)=0. - enddo - k=kbcon(i) - hc(i,k)=hkb(i) - DBY(I,Kbcon(i))=Hkb(I)-HES_cup(I,K) - endif - enddo - do k=kts+1,ktf - do i=its,itf - if(k.gt.kbcon(i).and.ierr(i).eq.0.)then - DZ=Z_cup(i,K)-Z_cup(i,K-1) -! upentr = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz - upentr = xlamue(i,k) * dz - updetr = 0.5 * xlamud(i) * dz -! updetr = xlamud(i) * dz -! HC(i,K)=(HC(i,K-1)*(1.-updetr)+ & -! upentr*0.5*(he(i,k)+HE(i,K-1)))/ & -! (1. + upentr - updetr) - - HC(i,K)=(HC(i,K-1)*(1.-updetr)+upentr* & - HE(i,K-1))/(1.+upentr-updetr) -! HC(i,K)=(HC(i,K-1)*(1.-.5*CD(i,K)*DZ)+entr* & -! DZ*HE(i,K-1))/(1.+entr*DZ-.5*cd(i,k)*dz) - DBY(I,K)=HC(I,K)-HES_cup(I,K) - endif - enddo - - enddo - - END SUBROUTINE cup_up_he - - - SUBROUTINE cup_up_moisture(ierr,z_cup,qc,qrc,pw,pwav, & - kbcon,ktop,cd,dby,mentr_rate,clw_all, & - q,GAMMA_cup,zu,qes_cup,k22,qe_cup,xl, & - xlamue, xlamud, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE -! -! on input -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - ! cd= detrainment function - ! q = environmental q on model levels - ! qe_cup = environmental q on model cloud levels - ! qes_cup = saturation q on model cloud levels - ! dby = buoancy term - ! cd= detrainment function - ! zu = normalized updraft mass flux - ! gamma_cup = gamma on model cloud levels - ! mentr_rate = entrainment rate - ! - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - q,zu,gamma_cup,qe_cup,dby,qes_cup,z_cup,cd,xlamue - ! entr= entrainment rate - real & - ,intent (in ) :: & - mentr_rate,xl - integer, dimension (its:ite) & - ,intent (in ) :: & - kbcon,ktop,k22 - real, dimension (its:ite) & - ,intent (in ) :: & - xlamud - -! -! input and output -! - - ! ierr error value, maybe modified in this routine - - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr - ! qc = cloud q (including liquid water) after entrainment - ! qrch = saturation q in cloud - ! qrc = liquid water content in cloud after rainout - ! pw = condensate that will fall out at that level - ! pwav = totan normalized integrated condensate (I1) - ! c0 = conversion rate (cloud to rain) - - real, dimension (its:ite,kts:kte) & - ,intent (out ) :: & - qc,qrc,pw,clw_all - real, dimension (its:ite) & - ,intent (out ) :: & - pwav -! -! local variables in this routine -! - - integer :: & - iall,i,k - real :: & - dh,qrch,c0,dz,radius,tem,tem1,factor -! - integer :: itf, ktf - - itf = ite - ktf = kte - - iall=0 - c0=.002 -! -!--- no precip for small clouds -! - if(mentr_rate.gt.0.)then - radius=.2/mentr_rate - if(radius.lt.900.)c0=0. -! if(radius.lt.900.)iall=0 - endif - do i=its,itf - pwav(i)=0. - enddo - do k=kts,ktf - do i=its,itf - pw(i,k)=0. - if(ierr(i).eq.0)qc(i,k)=qes_cup(i,k) - clw_all(i,k)=0. - qrc(i,k)=0. - enddo - enddo - do i=its,itf - if(ierr(i).eq.0.)then - do k=k22(i),kbcon(i) - qc(i,k)=qe_cup(i,k22(i)) - enddo - endif - enddo - - DO 100 k=kts+1,ktf - DO 100 i=its,itf - IF(ierr(i).ne.0)GO TO 100 - IF(K.Le.KBCON(I))GO TO 100 - IF(K.Gt.KTOP(I))GO TO 100 - DZ=Z_cup(i,K)-Z_cup(i,K-1) -! tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz - tem = xlamue(i,k) * dz - tem1 = 0.5 * xlamud(i) * dz -! tem1 = xlamud(i) * dz - factor = 1. + tem - tem1 - -! -!------ 1. steady state plume equation, for what could -!------ be in cloud without condensation -! -! -! QC(i,K)=(QC(i,K-1)*(1.-.5*CD(i,K)*DZ)+mentr_rate* & -! DZ*Q(i,K-1))/(1.+mentr_rate*DZ-.5*cd(i,k)*dz) -! QC(i,K)=(QC(i,K-1)*(1.-tem1)+tem & -! *Q(i,K-1))/factor -! q without condensation - qc(i,k) = ((1.-tem1)*qc(i,k-1) + & - tem*q(i,k-1)) & - /factor - -! -!--- saturation in cloud, this is what is allowed to be in it -! - QRCH=QES_cup(I,K)+(1./XL)*(GAMMA_cup(i,k) & - /(1.+GAMMA_cup(i,k)))*DBY(I,K) -! -!------- LIQUID WATER CONTENT IN cloud after rainout -! - clw_all(i,k)=QC(I,K)-QRCH - QRC(I,K)=(QC(I,K)-QRCH)/(1.+C0*DZ*zu(i,k)) - if(qrc(i,k).lt.0.)then - qrc(i,k)=0. - endif -! -!------- 3.Condensation -! - PW(i,k)=c0*dz*QRC(I,K)*zu(i,k) - if(iall.eq.1)then - qrc(i,k)=0. - pw(i,k)=(QC(I,K)-QRCH)*zu(i,k) - if(pw(i,k).lt.0.)pw(i,k)=0. - endif -! -!----- set next level -! - QC(I,K)=QRC(I,K)+qrch -! -!--- integrated normalized ondensate -! - PWAV(I)=PWAV(I)+PW(I,K) - 100 CONTINUE - - END SUBROUTINE cup_up_moisture - - - SUBROUTINE cup_up_nms(zu,z_cup,entr,cd,kbcon,ktop,ierr,k22, & - xlamue, xlamud, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - - IMPLICIT NONE - -! -! on input -! - - ! only local wrf dimensions are need as of now in this routine - - integer & - ,intent (in ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - ! cd= detrainment function - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - z_cup,cd - ! entr= entrainment rate - real & - ,intent (in ) :: & - entr - integer, dimension (its:ite) & - ,intent (in ) :: & - kbcon,ktop,k22 - real, dimension (its:ite,kts:kte) & - ,intent (in ) :: & - xlamue - real, dimension (its:ite) & - ,intent (in ) :: & - xlamud - -! -! input and output -! - - ! ierr error value, maybe modified in this routine - - integer, dimension (its:ite) & - ,intent (inout) :: & - ierr - ! zu is the normalized mass flux - - real, dimension (its:ite,kts:kte) & - ,intent (out ) :: & - zu -! -! local variables in this routine -! - - integer :: & - i,k - real :: & - dz,ptem - integer :: itf, ktf - - itf = ite - ktf = kte -! -! initialize for this go around -! - do k=kts,ktf - do i=its,itf - zu(i,k)=0. - enddo - enddo -! -! do normalized mass budget -! - do i=its,itf - IF(ierr(I).eq.0)then -! subcloud levels: work downward from cloudbase -! zu(i,kbcon(i))=1. -! do k = kbcon(i)-1,k22(i),-1 -! DZ = Z_cup(i,K+1) - Z_cup(i,K) -! ptem = 0.5*(xlamue(i,k)+xlamue(i,k+1)) - xlamud(i) -! ptem = xlamue(i,k) - xlamud(i) -! ZU(i,K) = ZU(i,K+1) / (1. + ptem*DZ) -! zu(i,k)=1. -! enddo - do k=k22(i),kbcon(i) - zu(i,k)=1. - enddo -! levels above cloud base: work upward from cloudbase -! DO K=KBcon(i)+1,KTOP(i) - DO K = KBcon(i)+1,ktf-1 - DZ = Z_cup(i,K)-Z_cup(i,K-1) -! ptem = 0.5*(xlamue(i,k)+xlamue(i,k-1)) - xlamud(i) - ptem = xlamue(i,k) - xlamud(i) - ZU(i,K) = ZU(i,K-1)*(1. + ptem*DZ) - enddo - -! DO K=KBcon(i)+1,KTOP(i) -! DZ=Z_cup(i,K)-Z_cup(i,K-1) -! ZU(i,K)=ZU(i,K-1)*(1.+(entr-cd(i,k))*DZ) -! enddo - endif - enddo - - END SUBROUTINE cup_up_nms - -!==================================================================== - SUBROUTINE gdinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN, & - MASS_FLUX,cp,restart, & - P_QC,P_QI,P_FIRST_SCALAR, & - RTHFTEN, RQVFTEN, & - APR_GR,APR_W,APR_MC,APR_ST,APR_AS, & - APR_CAPMA,APR_CAPME,APR_CAPMI, & - allowed_to_read, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte ) -!-------------------------------------------------------------------- - IMPLICIT NONE -!-------------------------------------------------------------------- - LOGICAL , INTENT(IN) :: restart,allowed_to_read - INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte - INTEGER , INTENT(IN) :: P_FIRST_SCALAR, P_QI, P_QC - REAL, INTENT(IN) :: cp - - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: & - RTHCUTEN, & - RQVCUTEN, & - RQCCUTEN, & - RQICUTEN - - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: & - RTHFTEN, & - RQVFTEN - - REAL, DIMENSION( ims:ime , jms:jme ) , INTENT(OUT) :: & - APR_GR,APR_W,APR_MC,APR_ST,APR_AS, & - APR_CAPMA,APR_CAPME,APR_CAPMI, & - MASS_FLUX - - IF(.not.restart)THEN - RTHCUTEN=0. - RQVCUTEN=0. - RTHFTEN=0. - RQVFTEN=0. - - IF (P_QC .ge. P_FIRST_SCALAR) THEN - RQCCUTEN=0. - ENDIF - - IF (P_QI .ge. P_FIRST_SCALAR) THEN - RQICUTEN=0. - ENDIF - - mass_flux=0. - - ENDIF - APR_GR=0. - APR_ST=0. - APR_W=0. - APR_MC=0. - APR_AS=0. - APR_CAPMA=0. - APR_CAPME=0. - APR_CAPMI=0. - - END SUBROUTINE gdinit - - - SUBROUTINE massflx_stats(xf_ens,ensdim,maxens,maxens2,maxens3, & - xt_ave,xt_std,xt_cur,xt_ske,j,ierr,itest, & - APR_GR,APR_W,APR_MC,APR_ST,APR_AS, & - APR_CAPMA,APR_CAPME,APR_CAPMI, & - pr_gr,pr_w,pr_mc,pr_st,pr_as, & - pr_capma,pr_capme,pr_capmi, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - - IMPLICIT NONE - - integer, intent (in ) :: & - j,ensdim,maxens3,maxens,maxens2,itest - INTEGER, INTENT(IN ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - - - real, dimension (its:ite) & - , intent(inout) :: & - xt_ave,xt_cur,xt_std,xt_ske - integer, dimension (its:ite), intent (in) :: & - ierr - real, dimension (ims:ime,jms:jme,1:ensdim) & - , intent(in ) :: & - xf_ens - real, dimension (ims:ime,jms:jme) & - , intent(inout) :: & - APR_GR,APR_W,APR_MC,APR_ST,APR_AS, & - APR_CAPMA,APR_CAPME,APR_CAPMI - real, dimension (its:ite,jts:jte) & - , intent(inout) :: & - pr_gr,pr_w,pr_mc,pr_st,pr_as, & - pr_capma,pr_capme,pr_capmi - -! -! local stuff -! - real, dimension (its:ite , 1:maxens3 ) :: & - x_ave,x_cur,x_std,x_ske - real, dimension (its:ite , 1:maxens ) :: & - x_ave_cap - - - integer, dimension (1:maxens3) :: nc1 - integer :: i,k - integer :: num,kk,num2,iedt - real :: a3,a4 - - num=ensdim/maxens3 - num2=ensdim/maxens - if(itest.eq.1)then - do i=its,ite - pr_gr(i,j) = 0. - pr_w(i,j) = 0. - pr_mc(i,j) = 0. - pr_st(i,j) = 0. - pr_as(i,j) = 0. - pr_capma(i,j) = 0. - pr_capme(i,j) = 0. - pr_capmi(i,j) = 0. - enddo - endif - - do k=1,maxens - do i=its,ite - x_ave_cap(i,k)=0. - enddo - enddo - do k=1,maxens3 - do i=its,ite - x_ave(i,k)=0. - x_std(i,k)=0. - x_ske(i,k)=0. - x_cur(i,k)=0. - enddo - enddo - do i=its,ite - xt_ave(i)=0. - xt_std(i)=0. - xt_ske(i)=0. - xt_cur(i)=0. - enddo - do kk=1,num - do k=1,maxens3 - do i=its,ite - if(ierr(i).eq.0)then - x_ave(i,k)=x_ave(i,k)+xf_ens(i,j,maxens3*(kk-1)+k) - endif - enddo - enddo - enddo - do iedt=1,maxens2 - do k=1,maxens - do kk=1,maxens3 - do i=its,ite - if(ierr(i).eq.0)then - x_ave_cap(i,k)=x_ave_cap(i,k) & - +xf_ens(i,j,maxens3*(k-1)+(iedt-1)*maxens*maxens3+kk) - endif - enddo - enddo - enddo - enddo - do k=1,maxens - do i=its,ite - if(ierr(i).eq.0)then - x_ave_cap(i,k)=x_ave_cap(i,k)/float(num2) - endif - enddo - enddo - - do k=1,maxens3 - do i=its,ite - if(ierr(i).eq.0)then - x_ave(i,k)=x_ave(i,k)/float(num) - endif - enddo - enddo - do k=1,maxens3 - do i=its,ite - if(ierr(i).eq.0)then - xt_ave(i)=xt_ave(i)+x_ave(i,k) - endif - enddo - enddo - do i=its,ite - if(ierr(i).eq.0)then - xt_ave(i)=xt_ave(i)/float(maxens3) - endif - enddo -! -!--- now do std, skewness,curtosis -! - do kk=1,num - do k=1,maxens3 - do i=its,ite - if(ierr(i).eq.0.and.x_ave(i,k).gt.0.)then -! print *,i,j,k,kk,x_std(i,k),xf_ens(i,j,maxens3*(kk-1)+k),x_ave(i,k) - x_std(i,k)=x_std(i,k)+(xf_ens(i,j,maxens3*(kk-1)+k)-x_ave(i,k))**2 - x_ske(i,k)=x_ske(i,k)+(xf_ens(i,j,maxens3*(kk-1)+k)-x_ave(i,k))**3 - x_cur(i,k)=x_cur(i,k)+(xf_ens(i,j,maxens3*(kk-1)+k)-x_ave(i,k))**4 - endif - enddo - enddo - enddo - do k=1,maxens3 - do i=its,ite - if(ierr(i).eq.0.and.xt_ave(i).gt.0.)then - xt_std(i)=xt_std(i)+(x_ave(i,k)-xt_ave(i))**2 - xt_ske(i)=xt_ske(i)+(x_ave(i,k)-xt_ave(i))**3 - xt_cur(i)=xt_cur(i)+(x_ave(i,k)-xt_ave(i))**4 - endif - enddo - enddo - do k=1,maxens3 - do i=its,ite - if(ierr(i).eq.0.and.x_std(i,k).gt.0.)then - x_std(i,k)=x_std(i,k)/float(num) - a3=max(1.e-6,x_std(i,k)) - x_std(i,k)=sqrt(a3) - a3=max(1.e-6,x_std(i,k)**3) - a4=max(1.e-6,x_std(i,k)**4) - x_ske(i,k)=x_ske(i,k)/float(num)/a3 - x_cur(i,k)=x_cur(i,k)/float(num)/a4 - endif -! print*,' ' -! print*,'Some statistics at gridpoint i,j, ierr',i,j,ierr(i) -! print*,'statistics for closure number ',k -! print*,'Average= ',x_ave(i,k),' Std= ',x_std(i,k) -! print*,'Skewness= ',x_ske(i,k),' Curtosis= ',x_cur(i,k) -! print*,' ' - - enddo - enddo - do i=its,ite - if(ierr(i).eq.0.and.xt_std(i).gt.0.)then - xt_std(i)=xt_std(i)/float(maxens3) - a3=max(1.e-6,xt_std(i)) - xt_std(i)=sqrt(a3) - a3=max(1.e-6,xt_std(i)**3) - a4=max(1.e-6,xt_std(i)**4) - xt_ske(i)=xt_ske(i)/float(maxens3)/a3 - xt_cur(i)=xt_cur(i)/float(maxens3)/a4 -! print*,' ' -! print*,'Total ensemble independent statistics at i =',i -! print*,'Average= ',xt_ave(i),' Std= ',xt_std(i) -! print*,'Skewness= ',xt_ske(i),' Curtosis= ',xt_cur(i) -! print*,' ' -! -! first go around: store massflx for different closures/caps -! - if(itest.eq.1)then - pr_gr(i,j) = .333*(x_ave(i,1)+x_ave(i,2)+x_ave(i,3)) - pr_w(i,j) = .333*(x_ave(i,4)+x_ave(i,5)+x_ave(i,6)) - pr_mc(i,j) = .333*(x_ave(i,7)+x_ave(i,8)+x_ave(i,9)) - pr_st(i,j) = .333*(x_ave(i,10)+x_ave(i,11)+x_ave(i,12)) - pr_as(i,j) = .25*(x_ave(i,13)+x_ave(i,14)+x_ave(i,15) & - + x_ave(i,16)) - pr_capma(i,j) = x_ave_cap(i,1) - pr_capme(i,j) = x_ave_cap(i,2) - pr_capmi(i,j) = x_ave_cap(i,3) -! -! second go around: store preciprates (mm/hour) for different closures/caps -! - else if (itest.eq.2)then - APR_GR(i,j)=.333*(x_ave(i,1)+x_ave(i,2)+x_ave(i,3))* & - 3600.*pr_gr(i,j) +APR_GR(i,j) - APR_W(i,j)=.333*(x_ave(i,4)+x_ave(i,5)+x_ave(i,6))* & - 3600.*pr_w(i,j) +APR_W(i,j) - APR_MC(i,j)=.333*(x_ave(i,7)+x_ave(i,8)+x_ave(i,9))* & - 3600.*pr_mc(i,j) +APR_MC(i,j) - APR_ST(i,j)=.333*(x_ave(i,10)+x_ave(i,11)+x_ave(i,12))* & - 3600.*pr_st(i,j) +APR_ST(i,j) - APR_AS(i,j)=.25*(x_ave(i,13)+x_ave(i,14)+x_ave(i,15) & - + x_ave(i,16))* & - 3600.*pr_as(i,j) +APR_AS(i,j) - APR_CAPMA(i,j) = x_ave_cap(i,1)* & - 3600.*pr_capma(i,j) +APR_CAPMA(i,j) - APR_CAPME(i,j) = x_ave_cap(i,2)* & - 3600.*pr_capme(i,j) +APR_CAPME(i,j) - APR_CAPMI(i,j) = x_ave_cap(i,3)* & - 3600.*pr_capmi(i,j) +APR_CAPMI(i,j) - endif - endif - enddo - - END SUBROUTINE massflx_stats - - - SUBROUTINE neg_check(dt,q,outq,outt,outqc,pret,its,ite,kts,kte,itf,ktf) - - INTEGER, INTENT(IN ) :: its,ite,kts,kte,itf,ktf - - real, dimension (its:ite,kts:kte ) , & - intent(inout ) :: & - q,outq,outt,outqc - real, dimension (its:ite ) , & - intent(inout ) :: & - pret - real & - ,intent (in ) :: & - dt - real :: thresh,qmem,qmemf,qmem2,qtest,qmem1 -! -! first do check on vertical heating rate -! - thresh=200.01 - do i=its,itf - qmemf=1. - qmem=0. - do k=kts,ktf - qmem=outt(i,k)*86400. - if(qmem.gt.2.*thresh)then - qmem2=2.*thresh/qmem - qmemf=min(qmemf,qmem2) -! -! -! print *,'1',' adjusted massflux by factor ',i,k,qmem,qmem2,qmemf - endif - if(qmem.lt.-thresh)then - qmem2=-thresh/qmem - qmemf=min(qmemf,qmem2) -! -! -! print *,'2',' adjusted massflux by factor ',i,k,qmem,qmem2,qmemf - endif - enddo - do k=kts,ktf - outq(i,k)=outq(i,k)*qmemf - outt(i,k)=outt(i,k)*qmemf - outqc(i,k)=outqc(i,k)*qmemf - enddo - pret(i)=pret(i)*qmemf - enddo -! -! check whether routine produces negative q's. This can happen, since -! tendencies are calculated based on forced q's. This should have no -! influence on conservation properties, it scales linear through all -! tendencies -! - thresh=1.e-10 - do i=its,itf - qmemf=1. - do k=kts,ktf - qmem=outq(i,k) - if(abs(qmem).gt.0.)then - qtest=q(i,k)+outq(i,k)*dt - if(qtest.lt.thresh)then -! -! qmem2 would be the maximum allowable tendency -! - qmem1=outq(i,k) - qmem2=(thresh-q(i,k))/dt - qmemf=min(qmemf,qmem2/qmem1) -! qmemf=max(0.,qmemf) -! print *,'4 adjusted tendencies ',i,k,qmem,qmem2,qmemf - endif - endif - enddo - do k=kts,ktf - outq(i,k)=outq(i,k)*qmemf - outt(i,k)=outt(i,k)*qmemf - outqc(i,k)=outqc(i,k)*qmemf - enddo - pret(i)=pret(i)*qmemf - enddo - - END SUBROUTINE neg_check - - -!------------------------------------------------------- -END MODULE module_cu_gd diff --git a/src/fim/FIMsrc/fim/wrfphys/module_cu_kf.F b/src/fim/FIMsrc/fim/wrfphys/module_cu_kf.F deleted file mode 100644 index c7b2952..0000000 --- a/src/fim/FIMsrc/fim/wrfphys/module_cu_kf.F +++ /dev/null @@ -1,2631 +0,0 @@ -!WRF:MODEL_LAYER:PHYSICS -! - -MODULE module_cu_kf - - USE module_wrf_error - - REAL , PARAMETER :: RAD = 1500. - -CONTAINS - -!------------------------------------------------------------- - SUBROUTINE KFCPS( & - ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte & - ,DT,KTAU,DX,CUDT,CURR_SECS,ADAPT_STEP_FLAG & - ,rho & - ,RAINCV,PRATEC,NCA & - ,U,V,TH,T,W,QV,dz8w,Pcps,pi & - ,W0AVG,XLV0,XLV1,XLS0,XLS1,CP,R,G,EP1 & - ,EP2,SVP1,SVP2,SVP3,SVPT0 & - ,STEPCU,CU_ACT_FLAG,warm_rain & - ! optional arguments - ,F_QV ,F_QC ,F_QR ,F_QI ,F_QS & - ,RQVCUTEN,RQCCUTEN,RQRCUTEN,RQICUTEN,RQSCUTEN & - ,RTHCUTEN & - ) -!------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------- - INTEGER, INTENT(IN ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - - INTEGER, INTENT(IN ) :: STEPCU - LOGICAL, INTENT(IN ) :: warm_rain - - REAL, INTENT(IN ) :: XLV0,XLV1,XLS0,XLS1 - REAL, INTENT(IN ) :: CP,R,G,EP1,EP2 - REAL, INTENT(IN ) :: SVP1,SVP2,SVP3,SVPT0 - - INTEGER, INTENT(IN ) :: KTAU - - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & - INTENT(IN ) :: & - U, & - V, & - W, & - TH, & - QV, & - T, & - dz8w, & - Pcps, & - rho, & - pi -! - REAL, INTENT(IN ) :: DT, DX - REAL, INTENT(IN ) :: CUDT - REAL, INTENT(IN ) :: CURR_SECS - LOGICAL,INTENT(IN ) :: ADAPT_STEP_FLAG - - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(INOUT) :: & - RAINCV & - ,PRATEC & - , NCA - - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(INOUT) :: & - W0AVG - - LOGICAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(INOUT) :: CU_ACT_FLAG - -! -! Optional arguments -! - - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - OPTIONAL, & - INTENT(INOUT) :: & - RTHCUTEN & - ,RQVCUTEN & - ,RQCCUTEN & - ,RQRCUTEN & - ,RQICUTEN & - ,RQSCUTEN - -! -! Flags relating to the optional tendency arrays declared above -! Models that carry the optional tendencies will provdide the -! optional arguments at compile time; these flags all the model -! to determine at run-time whether a particular tracer is in -! use or not. -! - - LOGICAL, OPTIONAL :: & - F_QV & - ,F_QC & - ,F_QR & - ,F_QI & - ,F_QS - - - -! LOCAL VARS - - REAL, DIMENSION( kts:kte ) :: & - U1D, & - V1D, & - T1D, & - DZ1D, & - QV1D, & - P1D, & - RHO1D, & - W0AVG1D - - REAL, DIMENSION( kts:kte ):: & - DQDT, & - DQIDT, & - DQCDT, & - DQRDT, & - DQSDT, & - DTDT - - REAL :: TST,tv,PRS,RHOE,W0,SCR1,DXSQ,tmp - - INTEGER :: i,j,k,NTST,ICLDCK - - LOGICAL :: qi_flag , qs_flag -! adjustable time step changes - REAL :: lastdt = -1.0 - REAL :: W0AVGfctr, W0fctr, W0den - LOGICAL :: run_param - -!---------------------------------------------------------------------- - -!--- CALL CUMULUS PARAMETERIZATION -! -!...TST IS THE NUMBER OF TIME STEPS IN 10 MINUTES...W0AVG IS CLOSE TO A -!...RUNNING MEAN VERTICAL VELOCITY...NOTE THAT IF YOU CHANGE TST, IT WIL -!...CHANGE THE FREQUENCY OF THE CONVECTIVE INTITIATION CHECK (SEE BELOW) -!...NOTE THAT THE ORDERING OF VERTICAL LAYERS MUST BE REVERSED FOR W0AVG -!...BECAUSE THE ORDERING IS REVERSED IN KFPARA... -! - DXSQ=DX*DX - qi_flag = .FALSE. - qs_flag = .FALSE. - IF ( PRESENT( F_QI ) ) qi_flag = f_qi - IF ( PRESENT( F_QS ) ) qs_flag = f_qs - -!---------------------- - NTST=STEPCU - TST=float(NTST*2) -!---------------------- -! NTST=NINT(1200./(DT*2.)) -! TST=float(NTST) -! NTST=NINT(0.5*TST) -! NTST=MAX0(NTST,1) -!---------------------- -! ICLDCK=MOD(KTAU,NTST) -!---------------------- -! write(0,*) 'DT = ',DT,' KTAU = ',KTAU,' DX = ',DX -! write(0,*) 'CUDT = ',CUDT,' CURR_SECS = ',CURR_SECS -! write(0,*) 'ADAPT_STEP_FLAG = ',ADAPT_STEP_FLAG,' IDS = ',IDS -! write(0,*) 'STEPCU = ',STEPCU,' warm_rain = ',warm_rain -! write(0,*) 'F_QV = ',F_QV,' F_QC = ',F_QV -! write(0,*) 'F_QI = ',F_QI,' F_QS = ',F_QS -! write(0,*) 'F_QR = ',F_QR -! stop - if (lastdt < 0) then - lastdt = dt - endif - - if (ADAPT_STEP_FLAG) then - W0AVGfctr = 2 * MAX(CUDT*60,dt) - dt - W0fctr = dt - W0den = 2 * MAX(CUDT*60,dt) - else - W0AVGfctr = (TST-1.) - W0fctr = 1. - W0den = TST - endif - - DO J = jts,jte - DO K=kts,kte - DO I= its,ite -! SCR1=-5.0E-4*G*rho(I,K,J)*(w(I,K,J)+w(I,K+1,J)) -! TV=T(I,K,J)*(1.+EP1*QV(I,K,J)) -! RHOE=Pcps(I,K,J)/(R*TV) -! W0=-101.9368*SCR1/RHOE - W0=0.5*(w(I,K,J)+w(I,K+1,J)) - -! Old: -! -! W0AVG(I,K,J)=(W0AVG(I,K,J)*(TST-1.)+W0)/TST -! New, to support adaptive time step: -! - W0AVG(I,K,J) = ( W0AVG(I,K,J) * W0AVGfctr + W0 * W0fctr ) / W0den - - ENDDO - ENDDO - ENDDO - lastdt = dt -! -!...CHECK FOR CONVECTIVE INITIATION EVERY 5 MINUTES (OR NTST/2)... -! - -! -! Modified for adaptive time step -! - if (ADAPT_STEP_FLAG) then - if ( (KTAU .eq. 1) .or. (cudt .eq. 0) .or. & - ( CURR_SECS + dt >= & - ( int( CURR_SECS / ( cudt * 60 ) ) + 1 ) * cudt * 60 ) ) then - run_param = .TRUE. - else - run_param = .FALSE. - endif - - else - if (MOD(KTAU,NTST) .EQ. 0 .or. KTAU .eq. 1) then - run_param = .TRUE. - else - run_param = .FALSE. - endif - endif - - IF (run_param) then - DO J = jts,jte - DO I= its,ite - CU_ACT_FLAG(i,j) = .true. - ENDDO - ENDDO - - DO J = jts,jte - DO I=its,ite -! if (i.eq. 110 .and. j .eq. 59 ) then -! write(0,*) 'nca = ',nca(i,j),' CU_ACT_FLAG = ',CU_ACT_FLAG(i,j) -! write(0,*) 'dt = ',dt,' ADAPT_STEP_FLAG = ',ADAPT_STEP_FLAG -! endif -! IF ( NINT(NCA(I,J)) .gt. 0 ) then - IF ( NCA(I,J) .gt. 0.5*DT ) then - CU_ACT_FLAG(i,j) = .false. - ELSE - - DO k=kts,kte - DQDT(k)=0. - DQIDT(k)=0. - DQCDT(k)=0. - DQRDT(k)=0. - DQSDT(k)=0. - DTDT(k)=0. - ENDDO - RAINCV(I,J)=0. - PRATEC(I,J)=0. -! -! assign vars from 3D to 1D - - DO K=kts,kte - U1D(K) =U(I,K,J) - V1D(K) =V(I,K,J) - T1D(K) =T(I,K,J) - RHO1D(K) =rho(I,K,J) - QV1D(K)=QV(I,K,J) - P1D(K) =Pcps(I,K,J) - W0AVG1D(K) =W0AVG(I,K,J) - DZ1D(k)=dz8w(I,K,J) - ENDDO - -! - CALL KFPARA(I, J, & - U1D,V1D,T1D,QV1D,P1D,DZ1D, & - W0AVG1D,DT,DX,DXSQ,RHO1D, & - XLV0,XLV1,XLS0,XLS1,CP,R,G, & - EP2,SVP1,SVP2,SVP3,SVPT0, & - DQDT,DQIDT,DQCDT,DQRDT,DQSDT,DTDT, & - RAINCV,PRATEC,NCA, & - warm_rain,qi_flag,qs_flag, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - - IF ( PRESENT( RTHCUTEN ) .AND. PRESENT( RQVCUTEN ) ) THEN - DO K=kts,kte - RTHCUTEN(I,K,J)=DTDT(K)/pi(I,K,J) - RQVCUTEN(I,K,J)=DQDT(K) - ENDDO - ENDIF - - IF( PRESENT(RQRCUTEN) .AND. PRESENT(RQCCUTEN) .AND. & - PRESENT(F_QR) ) THEN - IF ( F_QR ) THEN - DO K=kts,kte - RQRCUTEN(I,K,J)=DQRDT(K) - RQCCUTEN(I,K,J)=DQCDT(K) - ENDDO - ELSE -! This is the case for Eta microphysics without 3d rain field - DO K=kts,kte - RQRCUTEN(I,K,J)=0. - RQCCUTEN(I,K,J)=DQRDT(K)+DQCDT(K) - ENDDO - ENDIF - ENDIF - -!...... QSTEN STORES GRAUPEL TENDENCY IF IT EXISTS, OTHERISE SNOW (V2) - - IF( PRESENT( RQICUTEN ) .AND. qi_flag )THEN - DO K=kts,kte - RQICUTEN(I,K,J)=DQIDT(K) - ENDDO - ENDIF - - IF( PRESENT ( RQSCUTEN ) .AND. qs_flag )THEN - DO K=kts,kte - RQSCUTEN(I,K,J)=DQSDT(K) - ENDDO - ENDIF -! - ENDIF - ENDDO - ENDDO - - ENDIF - - END SUBROUTINE KFCPS - -!----------------------------------------------------------- - SUBROUTINE KFPARA (I, J, & - U0,V0,T0,QV0,P0,DZQ,W0AVG1D, & - DT,DX,DXSQ,rho, & - XLV0,XLV1,XLS0,XLS1,CP,R,G, & - EP2,SVP1,SVP2,SVP3,SVPT0, & - DQDT,DQIDT,DQCDT,DQRDT,DQSDT,DTDT, & - RAINCV,PRATEC,NCA, & - warm_rain,qi_flag,qs_flag, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) -!----------------------------------------------------------- - IMPLICIT NONE -!----------------------------------------------------------- - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - I,J - LOGICAL, INTENT(IN ) :: warm_rain - LOGICAL :: qi_flag, qs_flag - -! - REAL, DIMENSION( kts:kte ), & - INTENT(IN ) :: U0, & - V0, & - T0, & - QV0, & - P0, & - rho, & - DZQ, & - W0AVG1D -! - REAL, INTENT(IN ) :: DT,DX,DXSQ -! - - REAL, INTENT(IN ) :: XLV0,XLV1,XLS0,XLS1,CP,R,G - REAL, INTENT(IN ) :: EP2,SVP1,SVP2,SVP3,SVPT0 -! - REAL, DIMENSION( kts:kte ), INTENT(INOUT) :: & - DQDT, & - DQIDT, & - DQCDT, & - DQRDT, & - DQSDT, & - DTDT - - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(INOUT) :: RAINCV, & - PRATEC, & - NCA -! -!...DEFINE LOCAL VARIABLES... -! - REAL, DIMENSION( kts:kte ) :: & - Q0,Z0,TV0,TU,TVU,QU,TZ,TVD, & - QD,QES,THTES,TG,TVG,QG,WU,WD,W0,EMS,EMSD, & - UMF,UER,UDR,DMF,DER,DDR,UMF2,UER2, & - UDR2,DMF2,DER2,DDR2,DZA,THTA0,THETEE, & - THTAU,THETEU,THTAD,THETED,QLIQ,QICE, & - QLQOUT,QICOUT,PPTLIQ,PPTICE,DETLQ,DETIC, & - DETLQ2,DETIC2,RATIO,RATIO2 - - REAL, DIMENSION( kts:kte ) :: & - DOMGDP,EXN,RHOE,TVQU,DP,RH,EQFRC,WSPD, & - QDT,FXM,THTAG,THTESG,THPA,THFXTOP, & - THFXBOT,QPA,QFXTOP,QFXBOT,QLPA,QLFXIN, & - QLFXOUT,QIPA,QIFXIN,QIFXOUT,QRPA, & - QRFXIN,QRFXOUT,QSPA,QSFXIN,QSFXOUT, & - QL0,QLG,QI0,QIG,QR0,QRG,QS0,QSG - - REAL, DIMENSION( kts:kte+1 ) :: OMG - REAL, DIMENSION( kts:kte ) :: RAINFB,SNOWFB - -! LOCAL VARS - - REAL :: P00,T00,CV,B61,RLF,RHIC,RHBC,PIE, & - TTFRZ,TBFRZ,C5,RATE - REAL :: GDRY,ROCP,ALIQ,BLIQ, & - CLIQ,DLIQ,AICE,BICE,CICE,DICE - REAL :: FBFRC,P300,DPTHMX,THMIX,QMIX,ZMIX,PMIX, & - ROCPQ,TMIX,EMIX,TLOG,TDPT,TLCL,TVLCL, & - CPORQ,PLCL,ES,DLP,TENV,QENV,TVEN,TVBAR, & - ZLCL,WKL,WABS,TRPPT,WSIGNE,DTLCL,GDT,WLCL,& - TVAVG,QESE,WTW,RHOLCL,AU0,VMFLCL,UPOLD, & - UPNEW,ABE,WKLCL,THTUDL,TUDL,TTEMP,FRC1, & - QNEWIC,RL,R1,QNWFRZ,EFFQ,BE,BOTERM,ENTERM,& - DZZ,WSQ,UDLBE,REI,EE2,UD2,TTMP,F1,F2, & - THTTMP,QTMP,TMPLIQ,TMPICE,TU95,TU10,EE1, & - UD1,CLDHGT,DPTT,QNEWLQ,DUMFDP,EE,TSAT, & - THTA,P150,USR,VCONV,TIMEC,SHSIGN,VWS,PEF, & - CBH,RCBH,PEFCBH,PEFF,PEFF2,TDER,THTMIN, & - DTMLTD,QS,TADVEC,DPDD,FRC,DPT,RDD,A1, & - DSSDT,DTMP,T1RH,QSRH,PPTFLX,CPR,CNDTNF, & - UPDINC,AINCM2,DEVDMF,PPR,RCED,DPPTDF, & - DMFLFS,DMFLFS2,RCED2,DDINC,AINCMX,AINCM1, & - AINC,TDER2,PPTFL2,FABE,STAB,DTT,DTT1, & - DTIME,TMA,TMB,TMM,BCOEFF,ACOEFF,QVDIFF, & - TOPOMG,CPM,DQ,ABEG,DABE,DFDA,FRC2,DR, & - UDFRC,TUC,QGS,RH0,RHG,QINIT,QFNL,ERR2, & - RELERR,RLC,RLS,RNC,FABEOLD,AINCOLD,UEFRC, & - DDFRC,TDC,DEFRC - - INTEGER :: KX,K,KL -! - INTEGER :: ISTOP,ML,L5,L4,KMIX,LOW, & - LC,MXLAYR,LLFC,NLAYRS,NK, & - KPBL,KLCL,LCL,LET,IFLAG, & - KFRZ,NK1,LTOP,NJ,LTOP1, & - LTOPM1,LVF,KSTART,KMIN,LFS, & - ND,NIC,LDB,LDT,ND1,NDK, & - NM,LMAX,NCOUNT,NOITR, & - NSTEP,NTC -! - DATA P00,T00/1.E5,273.16/ - DATA CV,B61,RLF/717.,0.608,3.339E5/ - DATA RHIC,RHBC/1.,0.90/ - DATA PIE,TTFRZ,TBFRZ,C5/3.141592654,268.16,248.16,1.0723E-3/ - DATA RATE/0.01/ -!----------------------------------------------------------- - GDRY=-G/CP - ROCP=R/CP - KL=kte - KX=kte -! -! ALIQ = 613.3 -! BLIQ = 17.502 -! CLIQ = 4780.8 -! DLIQ = 32.19 - ALIQ = SVP1*1000. - BLIQ = SVP2 - CLIQ = SVP2*SVPT0 - DLIQ = SVP3 - AICE = 613.2 - BICE = 22.452 - CICE = 6133.0 - DICE = 0.61 -! - -!...OPTION TO FEED CONVECTIVELY GENERATED RAINWATER -!...INTO GRID-RESOLVED RAINWATER (OR SNOW/GRAUPEL) -!...FIELD. 'FBFRC' IS THE FRACTION OF AVAILABLE -!...PRECIPITATION TO BE FED BACK (0.0 - 1.0)... -! - FBFRC=0.0 -! -!...SCHEME IS CALLED ONCE ON EACH NORTH-SOUTH SLICE, THE LOOP BELOW -!...CHECKS FOR THE POSSIBILITY OF INITIATING PARAMETERIZED -!...CONVECTION AT EACH POINT WITHIN THE SLICE -! -!...SEE IF IT IS NECESSARY TO CHECK FOR CONVECTIVE TRIGGERING AT THIS -!...GRID POINT. IF NCA>0, CONVECTION IS ALREADY ACTIVE AT THIS POINT, -!...JUST FEED BACK THE TENDENCIES SAVED FROM THE TIME WHEN CONVECTION -!...WAS INITIATED. IF NCA<0, CONVECTION IS NOT ACTIVE -!...AND YOU MAY WANT TO CHECK TO SEE IF IT CAN BE ACTIVATED FOR THE -!...CURRENT CONDITIONS. IN PREVIOUS APLICATIONS OF THIS SCHEME, -!...THE VARIABLE ICLDCK WAS USED BELOW TO SAVE TIME BY ONLY CHECKING -!...FOR THE POSSIBILITY OF CONVECTIVE INITIATION EVERY 5 OR 10 -!...MINUTES... -! - -! 10 CONTINUE -!SUE P300=1000.*(PSB(I,J)*A(KL)+PTOP-30.)+PP3D(I,J,KL) - - P300=P0(1)-30000. -! -!...PRESSURE PERTURBATION TERM IS ONLY DEFINED AT MID-POINT OF -!...VERTICAL LAYERS...SINCE TOTAL PRESSURE IS NEEDED AT THE TOP AND -!...BOTTOM OF LAYERS BELOW, DO AN INTERPOLATION... -! -!...INPUT A VERTICAL SOUNDING ... NOTE THAT MODEL LAYERS ARE NUMBERED -!...FROM BOTTOM-UP IN THE KF SCHEME... -! - ML=0 -!SUE tmprpsb=1./PSB(I,J) -!SUE CELL=PTOP*tmprpsb - - DO 15 K=1,KX -!SUE P0(K)=1.E3*(A(NK)*PSB(I,J)+PTOP)+PP3D(I,J,NK) -! -!...IF Q0 IS ABOVE SATURATION VALUE, REDUCE IT TO SATURATION LEVEL... -! - ES=ALIQ*EXP((BLIQ*T0(K)-CLIQ)/(T0(K)-DLIQ)) - QES(K)=EP2*ES/(P0(K)-ES) - Q0(K)=AMIN1(QES(K),QV0(K)) - Q0(K)=AMAX1(0.000001,Q0(K)) - QL0(K)=0. - QI0(K)=0. - QR0(K)=0. - QS0(K)=0. - - TV0(K)=T0(K)*(1.+B61*Q0(K)) - RHOE(K)=P0(K)/(R*TV0(K)) - - DP(K)=rho(k)*g*DZQ(k) -! -!...DZQ IS DZ BETWEEN SIGMA SURFACES, DZA IS DZ BETWEEN MODEL HALF LEVEL -! DP IS THE PRESSURE INTERVAL BETWEEN FULL SIGMA LEVELS... -! - IF(P0(K).GE.500E2)L5=K - IF(P0(K).GE.400E2)L4=K - IF(P0(K).GE.P300)LLFC=K - IF(T0(K).GT.T00)ML=K - 15 CONTINUE - - Z0(1)=.5*DZQ(1) - DO 20 K=2,KL - Z0(K)=Z0(K-1)+.5*(DZQ(K)+DZQ(K-1)) - DZA(K-1)=Z0(K)-Z0(K-1) - 20 CONTINUE - DZA(KL)=0. - KMIX=1 - 25 LOW=KMIX - - IF(LOW.GT.LLFC)GOTO 325 - - LC=LOW - MXLAYR=0 -! -!...ASSUME THAT IN ORDER TO SUPPORT A DEEP UPDRAFT YOU NEED A LAYER OF -!...UNSTABLE AIR 50 TO 100 mb DEEP...TO APPROXIMATE THIS, ISOLATE A -!...GROUP OF ADJACENT INDIVIDUAL MODEL LAYERS, WITH THE BASE AT LEVEL -!...LC, SUCH THAT THE COMBINED DEPTH OF THESE LAYERS IS AT LEAST 60 mb.. -! - NLAYRS=0 - DPTHMX=0. - DO 63 NK=LC,KX - DPTHMX=DPTHMX+DP(NK) - NLAYRS=NLAYRS+1 - 63 IF(DPTHMX.GT.6.E3)GOTO 64 - GOTO 325 - 64 KPBL=LC+NLAYRS-1 - KMIX=LC+1 - 18 THMIX=0. - QMIX=0. - ZMIX=0. - PMIX=0. - DPTHMX=0. -! -!...FIND THE THERMODYNAMIC CHARACTERISTICS OF THE LAYER BY -!...MASS-WEIGHTING THE CHARACTERISTICS OF THE INDIVIDUAL MODEL -!...LAYERS... -! - DO 17 NK=LC,KPBL - DPTHMX=DPTHMX+DP(NK) - ROCPQ=0.2854*(1.-0.28*Q0(NK)) - THMIX=THMIX+DP(NK)*T0(NK)*(P00/P0(NK))**ROCPQ - QMIX=QMIX+DP(NK)*Q0(NK) - ZMIX=ZMIX+DP(NK)*Z0(NK) - 17 PMIX=PMIX+DP(NK)*P0(NK) - THMIX=THMIX/DPTHMX - QMIX=QMIX/DPTHMX - ZMIX=ZMIX/DPTHMX - PMIX=PMIX/DPTHMX - ROCPQ=0.2854*(1.-0.28*QMIX) - TMIX=THMIX*(PMIX/P00)**ROCPQ - EMIX=QMIX*PMIX/(EP2+QMIX) -! -!...FIND THE TEMPERATURE OF THE MIXTURE AT ITS LCL, PRESSURE -!...LEVEL OF LCL... -! - TLOG=ALOG(EMIX/ALIQ) - TDPT=(CLIQ-DLIQ*TLOG)/(BLIQ-TLOG) - TLCL=TDPT-(.212+1.571E-3*(TDPT-T00)-4.36E-4*(TMIX-T00))*(TMIX- & - TDPT) - TLCL=AMIN1(TLCL,TMIX) - TVLCL=TLCL*(1.+0.608*QMIX) - CPORQ=1./ROCPQ - PLCL=P00*(TLCL/THMIX)**CPORQ - DO 29 NK=LC,KL - KLCL=NK - IF(PLCL.GE.P0(NK))GOTO 35 - 29 CONTINUE - GOTO 325 - 35 K=KLCL-1 - DLP=ALOG(PLCL/P0(K))/ALOG(P0(KLCL)/P0(K)) -! -!...ESTIMATE ENVIRONMENTAL TEMPERATURE AND MIXING RATIO AT THE LCL... -! - TENV=T0(K)+(T0(KLCL)-T0(K))*DLP - QENV=Q0(K)+(Q0(KLCL)-Q0(K))*DLP - TVEN=TENV*(1.+0.608*QENV) - TVBAR=0.5*(TV0(K)+TVEN) -! ZLCL=Z0(K)+R*TVBAR*ALOG(P0(K)/PLCL)/G - ZLCL=Z0(K)+(Z0(KLCL)-Z0(K))*DLP -! -!...CHECK TO SEE IF CLOUD IS BUOYANT USING FRITSCH-CHAPPELL TRIGGER -!...FUNCTION DESCRIBED IN KAIN AND FRITSCH (1992)...W0AVG IS AN -!...APROXIMATE VALUE FOR THE RUNNING-MEAN GRID-SCALE VERTICAL -!...VELOCITY, WHICH GIVES SMOOTHER FIELDS OF CONVECTIVE INITIATION -!...THAN THE INSTANTANEOUS VALUE...FORMULA RELATING TEMPERATURE -!...PERTURBATION TO VERTICAL VELOCITY HAS BEEN USED WITH THE MOST -!...SUCCESS AT GRID LENGTHS NEAR 25 km. FOR DIFFERENT GRID-LENGTHS, -!...ADJUST VERTICAL VELOCITY TO EQUIVALENT VALUE FOR 25 KM GRID -!...LENGTH, ASSUMING LINEAR DEPENDENCE OF W ON GRID LENGTH... -! - WKLCL=0.02*ZLCL/2.5E3 - WKL=(W0AVG1D(K)+(W0AVG1D(KLCL)-W0AVG1D(K))*DLP)*DX/25.E3- & - WKLCL - WABS=ABS(WKL)+1.E-10 - WSIGNE=WKL/WABS - DTLCL=4.64*WSIGNE*WABS**0.33 - GDT=G*DTLCL*(ZLCL-Z0(LC))/(TV0(LC)+TVEN) - WLCL=1.+.5*WSIGNE*SQRT(ABS(GDT)+1.E-10) - IF(TLCL+DTLCL.GT.TENV)GOTO 45 - IF(KPBL.GE.LLFC)GOTO 325 - GOTO 25 -! -!...CONVECTIVE TRIGGERING CRITERIA HAS BEEN SATISFIED...COMPUTE -!...EQUIVALENT POTENTIAL TEMPERATURE -!...(THETEU) AND VERTICAL VELOCITY OF THE RISING PARCEL AT THE LCL... -! - 45 THETEU(K)=TMIX*(1.E5/PMIX)**(0.2854*(1.-0.28*QMIX))* & - EXP((3374.6525/TLCL-2.5403)*QMIX*(1.+0.81*QMIX)) - ES=ALIQ*EXP((TENV*BLIQ-CLIQ)/(TENV-DLIQ)) - TVAVG=0.5*(TV0(KLCL)+TENV*(1.+0.608*QENV)) - PLCL=P0(KLCL)*EXP(G/(R*TVAVG)*(Z0(KLCL)-ZLCL)) - QESE=EP2*ES/(PLCL-ES) - GDT=G*DTLCL*(ZLCL-Z0(LC))/(TV0(LC)+TVEN) - WLCL=1.+.5*WSIGNE*SQRT(ABS(GDT)+1.E-10) - THTES(K)=TENV*(1.E5/PLCL)**(0.2854*(1.-0.28*QESE))* & - EXP((3374.6525/TENV-2.5403)*QESE*(1.+0.81*QESE)) - WTW=WLCL*WLCL - IF(WLCL.LT.0.)GOTO 25 - TVLCL=TLCL*(1.+0.608*QMIX) - RHOLCL=PLCL/(R*TVLCL) -! - LCL=KLCL - LET=LCL -! -!******************************************************************* -! * -! COMPUTE UPDRAFT PROPERTIES * -! * -!******************************************************************* -! -! -!...ESTIMATE INITIAL UPDRAFT MASS FLUX (UMF(K))... -! - WU(K)=WLCL - AU0=PIE*RAD*RAD - UMF(K)=RHOLCL*AU0 - VMFLCL=UMF(K) - UPOLD=VMFLCL - UPNEW=UPOLD -! -!...RATIO2 IS THE DEGREE OF GLACIATION IN THE CLOUD (0 TO 1), -!...UER IS THE ENVIR ENTRAINMENT RATE, ABE IS AVAILABLE BUOYANT ENERGY, -! TRPPT IS THE TOTAL RATE OF PRECIPITATION PRODUCTION... -! - RATIO2(K)=0. - UER(K)=0. - ABE=0. - TRPPT=0. - TU(K)=TLCL - TVU(K)=TVLCL - QU(K)=QMIX - EQFRC(K)=1. - QLIQ(K)=0. - QICE(K)=0. - QLQOUT(K)=0. - QICOUT(K)=0. - DETLQ(K)=0. - DETIC(K)=0. - PPTLIQ(K)=0. - PPTICE(K)=0. - IFLAG=0 - KFRZ=LC -! -!...THE AMOUNT OF CONV AVAIL POT ENERGY (CAPE) IS CALCULATED WITH -! RESPECT TO UNDILUTE PARCEL ASCENT; EQ POT TEMP OF UNDILUTE -! PARCEL IS THTUDL, UNDILUTE TEMPERATURE IS GIVEN BY TUDL... -! - THTUDL=THETEU(K) - TUDL=TLCL -! -!...TTEMP IS USED DURING CALCULATION OF THE LINEAR GLACIATION -! PROCESS; IT IS INITIALLY SET TO THE TEMPERATURE AT WHICH -! FREEZING IS SPECIFIED TO BEGIN. WITHIN THE GLACIATION -! INTERVAL, IT IS SET EQUAL TO THE UPDRAFT TEMP AT THE -! PREVIOUS MODEL LEVEL... -! - TTEMP=TTFRZ -! -!...ENTER THE LOOP FOR UPDRAFT CALCULATIONS...CALCULATE UPDRAFT TEMP, -! MIXING RATIO, VERTICAL MASS FLUX, LATERAL DETRAINMENT OF MASS AND -! MOISTURE, PRECIPITATION RATES AT EACH MODEL LEVEL... -! - DO 60 NK=K,KL-1 - NK1=NK+1 - RATIO2(NK1)=RATIO2(NK) -! -!...UPDATE UPDRAFT PROPERTIES AT THE NEXT MODEL LVL TO REFLECT -! ENTRAINMENT OF ENVIRONMENTAL AIR... -! - FRC1=0. - TU(NK1)=T0(NK1) - THETEU(NK1)=THETEU(NK) - QU(NK1)=QU(NK) - QLIQ(NK1)=QLIQ(NK) - QICE(NK1)=QICE(NK) - - CALL TPMIX(P0(NK1),THETEU(NK1),TU(NK1),QU(NK1),QLIQ(NK1), & - QICE(NK1),QNEWLQ,QNEWIC,RATIO2(NK1),RL,XLV0,XLV1,XLS0, & - XLS1,EP2,ALIQ,BLIQ,CLIQ,DLIQ,AICE,BICE,CICE,DICE) - TVU(NK1)=TU(NK1)*(1.+0.608*QU(NK1)) -! -!...CHECK TO SEE IF UPDRAFT TEMP IS WITHIN THE FREEZING INTERVAL, -! IF IT IS, CALCULATE THE FRACTIONAL CONVERSION TO GLACIATION -! AND ADJUST QNEWLQ TO REFLECT THE GRADUAL CHANGE IN THETAU -! SINCE THE LAST MODEL LEVEL...THE GLACIATION EFFECTS WILL BE -! DETERMINED AFTER THE AMOUNT OF CONDENSATE AVAILABLE AFTER -! PRECIP FALLOUT IS DETERMINED...TTFRZ IS THE TEMP AT WHICH -! GLACIATION BEGINS, TBFRZ THE TEMP AT WHICH IT ENDS... -! - IF(TU(NK1).LE.TTFRZ.AND.IFLAG.LT.1)THEN - IF(TU(NK1).GT.TBFRZ)THEN - IF(TTEMP.GT.TTFRZ)TTEMP=TTFRZ - FRC1=(TTEMP-TU(NK1))/(TTFRZ-TBFRZ) - R1=(TTEMP-TU(NK1))/(TTEMP-TBFRZ) - ELSE - FRC1=(TTEMP-TBFRZ)/(TTFRZ-TBFRZ) - R1=1. - IFLAG=1 - ENDIF - QNWFRZ=QNEWLQ - QNEWIC=QNEWIC+QNEWLQ*R1*0.5 - QNEWLQ=QNEWLQ-QNEWLQ*R1*0.5 - EFFQ=(TTFRZ-TBFRZ)/(TTEMP-TBFRZ) - TTEMP=TU(NK1) - ENDIF -! -! CALCULATE UPDRAFT VERTICAL VELOCITY AND PRECIPITATION FALLOUT... -! - IF(NK.EQ.K)THEN - BE=(TVLCL+TVU(NK1))/(TVEN+TV0(NK1))-1. - BOTERM=2.*(Z0(NK1)-ZLCL)*G*BE/1.5 - ENTERM=0. - DZZ=Z0(NK1)-ZLCL - ELSE - BE=(TVU(NK)+TVU(NK1))/(TV0(NK)+TV0(NK1))-1. - BOTERM=2.*DZA(NK)*G*BE/1.5 - ENTERM=2.*UER(NK)*WTW/UPOLD - DZZ=DZA(NK) - ENDIF - WSQ=WTW - CALL CONDLOAD(QLIQ(NK1),QICE(NK1),WTW,DZZ,BOTERM,ENTERM,RATE, & - QNEWLQ,QNEWIC,QLQOUT(NK1),QICOUT(NK1), G) - -!...IF VERT VELOCITY IS LESS THAN ZERO, EXIT THE UPDRAFT LOOP AND, -! IF CLOUD IS TALL ENOUGH, FINALIZE UPDRAFT CALCULATIONS... -! - IF(WTW.LE.0.)GOTO 65 - WABS=SQRT(ABS(WTW)) - WU(NK1)=WTW/WABS -! -! UPDATE THE ABE FOR UNDILUTE ASCENT... -! - THTES(NK1)=T0(NK1)*(1.E5/P0(NK1))**(0.2854*(1.-0.28*QES(NK1))) & - * & - EXP((3374.6525/T0(NK1)-2.5403)*QES(NK1)*(1.+0.81* & - QES(NK1))) - UDLBE=((2.*THTUDL)/(THTES(NK)+THTES(NK1))-1.)*DZZ - IF(UDLBE.GT.0.)ABE=ABE+UDLBE*G -! -! DETERMINE THE EFFECTS OF CLOUD GLACIATION IF WITHIN THE SPECIFIED -! TEMP INTERVAL... -! - IF(FRC1.GT.1.E-6)THEN - CALL DTFRZNEW(TU(NK1),P0(NK1),THETEU(NK1),QU(NK1),QLIQ(NK1), & - QICE(NK1),RATIO2(NK1),TTFRZ,TBFRZ,QNWFRZ,RL,FRC1,EFFQ, & - IFLAG,XLV0,XLV1,XLS0,XLS1,EP2,ALIQ,BLIQ,CLIQ,DLIQ,AICE,BICE & - ,CICE,DICE) - ENDIF -! -! CALL SUBROUTINE TO CALCULATE ENVIRONMENTAL EQUIVALENT POTENTIAL TEMP. -! WITHIN GLACIATION INTERVAL, THETAE MUST BE CALCULATED WITH RESPECT TO -! SAME DEGREE OF GLACIATION FOR ALL ENTRAINING AIR... -! - CALL ENVIRTHT(P0(NK1),T0(NK1),Q0(NK1),THETEE(NK1),RATIO2(NK1), & - RL,EP2,ALIQ,BLIQ,CLIQ,DLIQ,AICE,BICE,CICE,DICE) - -!...REI IS THE RATE OF ENVIRONMENTAL INFLOW... -! - REI=VMFLCL*DP(NK1)*0.03/RAD - TVQU(NK1)=TU(NK1)*(1.+0.608*QU(NK1)-QLIQ(NK1)-QICE(NK1)) -! -!...IF CLOUD PARCELS ARE VIRTUALLY COLDER THAN THE ENVIRONMENT, NO -! ENTRAINMENT IS ALLOWED AT THIS LEVEL... -! - IF(TVQU(NK1).LE.TV0(NK1))THEN - UER(NK1)=0.0 - UDR(NK1)=REI - EE2=0. - UD2=1. - EQFRC(NK1)=0. - GOTO 55 - ENDIF - LET=NK1 - TTMP=TVQU(NK1) -! -!...DETERMINE THE CRITICAL MIXED FRACTION OF UPDRAFT AND ENVIRONMENTAL -! AIR FOR ESTIMATION OF ENTRAINMENT AND DETRAINMENT RATES... -! - F1=0.95 - F2=1.-F1 - THTTMP=F1*THETEE(NK1)+F2*THETEU(NK1) - QTMP=F1*Q0(NK1)+F2*QU(NK1) - TMPLIQ=F2*QLIQ(NK1) - TMPICE=F2*QICE(NK1) - CALL TPMIX(P0(NK1),THTTMP,TTMP,QTMP,TMPLIQ,TMPICE,QNEWLQ, & - QNEWIC,RATIO2(NK1),RL,XLV0,XLV1,XLS0,XLS1,EP2,ALIQ,BLIQ,CLIQ, & - DLIQ,AICE,BICE,CICE,DICE) - TU95=TTMP*(1.+0.608*QTMP-TMPLIQ-TMPICE) - IF(TU95.GT.TV0(NK1))THEN - EE2=1. - UD2=0. - EQFRC(NK1)=1.0 - GOTO 50 - ENDIF - F1=0.10 - F2=1.-F1 - THTTMP=F1*THETEE(NK1)+F2*THETEU(NK1) - QTMP=F1*Q0(NK1)+F2*QU(NK1) - TMPLIQ=F2*QLIQ(NK1) - TMPICE=F2*QICE(NK1) - CALL TPMIX(P0(NK1),THTTMP,TTMP,QTMP,TMPLIQ,TMPICE,QNEWLQ, & - QNEWIC,RATIO2(NK1),RL,XLV0,XLV1,XLS0,XLS1,EP2,ALIQ,BLIQ,CLIQ, & - DLIQ,AICE,BICE,CICE,DICE) - TU10=TTMP*(1.+0.608*QTMP-TMPLIQ-TMPICE) - IF(TU10.EQ.TVQU(NK1))THEN - EE2=1. - UD2=0. - EQFRC(NK1)=1.0 - GOTO 50 - ENDIF - EQFRC(NK1)=(TV0(NK1)-TVQU(NK1))*F1/(TU10-TVQU(NK1)) - EQFRC(NK1)=AMAX1(0.0,EQFRC(NK1)) - EQFRC(NK1)=AMIN1(1.0,EQFRC(NK1)) - IF(EQFRC(NK1).EQ.1)THEN - EE2=1. - UD2=0. - GOTO 50 - ELSEIF(EQFRC(NK1).EQ.0.)THEN - EE2=0. - UD2=1. - GOTO 50 - ELSE -! -!...SUBROUTINE PROF5 INTEGRATES OVER THE GAUSSIAN DIST TO DETERMINE THE -! FRACTIONAL ENTRAINMENT AND DETRAINMENT RATES... -! - CALL PROF5(EQFRC(NK1),EE2,UD2) - ENDIF -! - 50 IF(NK.EQ.K)THEN - EE1=1. - UD1=0. - ENDIF -! -!...NET ENTRAINMENT AND DETRAINMENT RATES ARE GIVEN BY THE AVERAGE -! FRACTIONAL VALUES IN THE LAYER... -! - UER(NK1)=0.5*REI*(EE1+EE2) - UDR(NK1)=0.5*REI*(UD1+UD2) -! -!...IF THE CALCULATED UPDRAFT DETRAINMENT RATE IS GREATER THAN THE TOTAL -! UPDRAFT MASS FLUX, ALL CLOUD MASS DETRAINS, EXIT UPDRAFT CALCULATION -! - 55 IF(UMF(NK)-UDR(NK1).LT.10.)THEN -! -!...IF THE CALCULATED DETRAINED MASS FLUX IS GREATER THAN THE TOTAL -! UPDRAFT FLUX, IMPOSE TOTAL DETRAINMENT OF UPDRAFT MASS AT THE -! PREVIOUS MODEL -! - IF(UDLBE.GT.0.)ABE=ABE-UDLBE*G - LET=NK -! WRITE(98,1015)P0(NK1)/100. - GOTO 65 - ENDIF - EE1=EE2 - UD1=UD2 - UPOLD=UMF(NK)-UDR(NK1) - UPNEW=UPOLD+UER(NK1) - UMF(NK1)=UPNEW -! -!...DETLQ AND DETIC ARE THE RATES OF DETRAINMENT OF LIQUID AND ICE IN -! THE DETRAINING UPDRAFT MASS... -! - DETLQ(NK1)=QLIQ(NK1)*UDR(NK1) - DETIC(NK1)=QICE(NK1)*UDR(NK1) - QDT(NK1)=QU(NK1) - QU(NK1)=(UPOLD*QU(NK1)+UER(NK1)*Q0(NK1))/UPNEW - THETEU(NK1)=(THETEU(NK1)*UPOLD+THETEE(NK1)*UER(NK1))/UPNEW - QLIQ(NK1)=QLIQ(NK1)*UPOLD/UPNEW - QICE(NK1)=QICE(NK1)*UPOLD/UPNEW -! -!...KFRZ IS THE HIGHEST MODEL LEVEL AT WHICH LIQUID CONDENSATE IS -! GENERATING PPTLIQ IS THE RATE OF GENERATION (FALLOUT) OF LIQUID -! PRECIP AT A GIVING MODEL LVL, PPTICE THE SAME FOR ICE, TRPPT IS -! THE TOTAL RATE OF PRODUCTION OF PRECIP UP TO THE CURRENT MODEL LEVEL -! - IF(ABS(RATIO2(NK1)-1.).GT.1.E-6)KFRZ=NK1 - PPTLIQ(NK1)=QLQOUT(NK1)*(UMF(NK)-UDR(NK1)) - PPTICE(NK1)=QICOUT(NK1)*(UMF(NK)-UDR(NK1)) - TRPPT=TRPPT+PPTLIQ(NK1)+PPTICE(NK1) - IF(NK1.LE.KPBL)UER(NK1)=UER(NK1)+VMFLCL*DP(NK1)/DPTHMX - 60 CONTINUE -! -!...CHECK CLOUD DEPTH...IF CLOUD IS TALL ENOUGH, ESTIMATE THE EQUILIBRIU -! TEMPERATURE LEVEL (LET) AND ADJUST MASS FLUX PROFILE AT CLOUD TOP SO -! THAT MASS FLUX DECREASES TO ZERO AS A LINEAR FUNCTION OF PRESSURE -! BETWEEN THE LET AND CLOUD TOP... -! -!...LTOP IS THE MODEL LEVEL JUST BELOW THE LEVEL AT WHICH VERTICAL -! VELOCITY FIRST BECOMES NEGATIVE... -! - 65 LTOP=NK - CLDHGT=Z0(LTOP)-ZLCL -! -!...IF CLOUD TOP HGT IS LESS THAN SPECIFIED MINIMUM HEIGHT, GO BACK AND -! THE NEXT HIGHEST 60MB LAYER TO SEE IF A BIGGER CLOUD CAN BE OBTAINED -! THAT SOURCE AIR... -! -! IF(CLDHGT.LT.4.E3.OR.ABE.LT.1.)THEN - IF(CLDHGT.LT.3.E3.OR.ABE.LT.1.)THEN - DO 70 NK=K,LTOP - UMF(NK)=0. - UDR(NK)=0. - UER(NK)=0. - DETLQ(NK)=0. - DETIC(NK)=0. - PPTLIQ(NK)=0. - 70 PPTICE(NK)=0. - GOTO 25 - ENDIF -! -!...IF THE LET AND LTOP ARE THE SAME, DETRAIN ALL OF THE UPDRAFT MASS -! FLUX THIS LEVEL... -! - IF(LET.EQ.LTOP)THEN - UDR(LTOP)=UMF(LTOP)+UDR(LTOP)-UER(LTOP) - DETLQ(LTOP)=QLIQ(LTOP)*UDR(LTOP)*UPNEW/UPOLD - DETIC(LTOP)=QICE(LTOP)*UDR(LTOP)*UPNEW/UPOLD - TRPPT=TRPPT-(PPTLIQ(LTOP)+PPTICE(LTOP)) - UER(LTOP)=0. - UMF(LTOP)=0. - GOTO 85 - ENDIF -! -! BEGIN TOTAL DETRAINMENT AT THE LEVEL ABOVE THE LET... -! - DPTT=0. - DO 71 NJ=LET+1,LTOP - 71 DPTT=DPTT+DP(NJ) - DUMFDP=UMF(LET)/DPTT -! -!...ADJUST MASS FLUX PROFILES, DETRAINMENT RATES, AND PRECIPITATION FALL -! RATES TO REFLECT THE LINEAR DECREASE IN MASS FLX BETWEEN THE LET AND -! PTOP -! - DO 75 NK=LET+1,LTOP - UDR(NK)=DP(NK)*DUMFDP - UMF(NK)=UMF(NK-1)-UDR(NK) - DETLQ(NK)=QLIQ(NK)*UDR(NK) - DETIC(NK)=QICE(NK)*UDR(NK) - TRPPT=TRPPT-PPTLIQ(NK)-PPTICE(NK) - PPTLIQ(NK)=(UMF(NK-1)-UDR(NK))*QLQOUT(NK) - PPTICE(NK)=(UMF(NK-1)-UDR(NK))*QICOUT(NK) - TRPPT=TRPPT+PPTLIQ(NK)+PPTICE(NK) - 75 CONTINUE -! -!...SEND UPDRAFT CHARACTERISTICS TO OUTPUT FILES... -! - 85 CONTINUE -! -!...EXTEND THE UPDRAFT MASS FLUX PROFILE DOWN TO THE SOURCE LAYER FOR -! THE UPDRAFT AIR...ALSO, DEFINE THETAE FOR LEVELS BELOW THE LCL... -! - DO 90 NK=1,K - IF(NK.GE.LC)THEN - IF(NK.EQ.LC)THEN - UMF(NK)=VMFLCL*DP(NK)/DPTHMX - UER(NK)=VMFLCL*DP(NK)/DPTHMX - ELSEIF(NK.LE.KPBL)THEN - UER(NK)=VMFLCL*DP(NK)/DPTHMX - UMF(NK)=UMF(NK-1)+UER(NK) - ELSE - UMF(NK)=VMFLCL - UER(NK)=0. - ENDIF - TU(NK)=TMIX+(Z0(NK)-ZMIX)*GDRY - QU(NK)=QMIX - WU(NK)=WLCL - ELSE - TU(NK)=0. - QU(NK)=0. - UMF(NK)=0. - WU(NK)=0. - UER(NK)=0. - ENDIF - UDR(NK)=0. - QDT(NK)=0. - QLIQ(NK)=0. - QICE(NK)=0. - QLQOUT(NK)=0. - QICOUT(NK)=0. - PPTLIQ(NK)=0. - PPTICE(NK)=0. - DETLQ(NK)=0. - DETIC(NK)=0. - RATIO2(NK)=0. - EE=Q0(NK)*P0(NK)/(EP2+Q0(NK)) - TLOG=ALOG(EE/ALIQ) - TDPT=(CLIQ-DLIQ*TLOG)/(BLIQ-TLOG) - TSAT=TDPT-(.212+1.571E-3*(TDPT-T00)-4.36E-4*(T0(NK)-T00))*( & - T0(NK)-TDPT) - THTA=T0(NK)*(1.E5/P0(NK))**(0.2854*(1.-0.28*Q0(NK))) - THETEE(NK)=THTA* & - EXP((3374.6525/TSAT-2.5403)*Q0(NK)*(1.+0.81*Q0(NK)) & - ) - THTES(NK)=THTA* & - EXP((3374.6525/T0(NK)-2.5403)*QES(NK)*(1.+0.81* & - QES(NK))) - EQFRC(NK)=1.0 - 90 CONTINUE -! - LTOP1=LTOP+1 - LTOPM1=LTOP-1 -! -!...DEFINE VARIABLES ABOVE CLOUD TOP... -! - DO 95 NK=LTOP1,KX - UMF(NK)=0. - UDR(NK)=0. - UER(NK)=0. - QDT(NK)=0. - QLIQ(NK)=0. - QICE(NK)=0. - QLQOUT(NK)=0. - QICOUT(NK)=0. - DETLQ(NK)=0. - DETIC(NK)=0. - PPTLIQ(NK)=0. - PPTICE(NK)=0. - IF(NK.GT.LTOP1)THEN - TU(NK)=0. - QU(NK)=0. - WU(NK)=0. - ENDIF - THTA0(NK)=0. - THTAU(NK)=0. - EMS(NK)=DP(NK)*DXSQ/G - EMSD(NK)=1./EMS(NK) - TG(NK)=T0(NK) - QG(NK)=Q0(NK) - QLG(NK)=0. - QIG(NK)=0. - QRG(NK)=0. - QSG(NK)=0. - 95 OMG(NK)=0. - OMG(KL+1)=0. - P150=P0(KLCL)-1.50E4 - DO 100 NK=1,LTOP - THTAD(NK)=0. - EMS(NK)=DP(NK)*DXSQ/G - EMSD(NK)=1./EMS(NK) -! -!...INITIALIZE SOME VARIABLES TO BE USED LATER IN THE VERT ADVECTION -! SCHEME -! - EXN(NK)=(P00/P0(NK))**(0.2854*(1.-0.28*QDT(NK))) - THTAU(NK)=TU(NK)*EXN(NK) - EXN(NK)=(P00/P0(NK))**(0.2854*(1.-0.28*Q0(NK))) - THTA0(NK)=T0(NK)*EXN(NK) -! -!...LVF IS THE LEVEL AT WHICH MOISTURE FLUX IS ESTIMATED AS THE BASIS -!...FOR PRECIPITATION EFFICIENCY CALCULATIONS... -! - IF(P0(NK).GT.P150)LVF=NK - 100 OMG(NK)=0. - LVF=MIN0(LVF,LET) - USR=UMF(LVF+1)*(QU(LVF+1)+QLIQ(LVF+1)+QICE(LVF+1)) - USR=AMIN1(USR,TRPPT) - IF(USR.LT.1.E-8)USR=TRPPT -! -! WRITE(98,1025)KLCL,ZLCL,DTLCL,LTOP,P0(LTOP),IFLAG, -! * TMIX-T00,PMIX,QMIX,ABE -! WRITE(98,1030)P0(LET)/100.,P0(LTOP)/100.,VMFLCL,PLCL/100., -! * WLCL,CLDHGT -! -!...COMPUTE CONVECTIVE TIME SCALE(TIMEC). THE MEAN WIND AT THE LCL -!...AND MIDTROPOSPHERE IS USED. -! - WSPD(KLCL)=SQRT(U0(KLCL)*U0(KLCL)+V0(KLCL)*V0(KLCL)) - WSPD(L5)=SQRT(U0(L5)*U0(L5)+V0(L5)*V0(L5)) - WSPD(LTOP)=SQRT(U0(LTOP)*U0(LTOP)+V0(LTOP)*V0(LTOP)) - VCONV=.5*(WSPD(KLCL)+WSPD(L5)) - if (VCONV .gt. 0.) then - TIMEC=DX/VCONV - else - TIMEC=3600. - endif -! TIMEC=DX/VCONV - TADVEC=TIMEC - TIMEC=AMAX1(1800.,TIMEC) - TIMEC=AMIN1(3600.,TIMEC) - NIC=NINT(TIMEC/DT) - TIMEC=FLOAT(NIC)*DT -! -!...COMPUTE WIND SHEAR AND PRECIPITATION EFFICIENCY. -! -! SHSIGN = CVMGT(1.,-1.,WSPD(LTOP).GT.WSPD(KLCL)) - IF(WSPD(LTOP).GT.WSPD(KLCL))THEN - SHSIGN=1. - ELSE - SHSIGN=-1. - ENDIF - VWS=(U0(LTOP)-U0(KLCL))*(U0(LTOP)-U0(KLCL))+(V0(LTOP)-V0(KLCL))* & - (V0(LTOP)-V0(KLCL)) - VWS=1.E3*SHSIGN*SQRT(VWS)/(Z0(LTOP)-Z0(LCL)) - PEF=1.591+VWS*(-.639+VWS*(9.53E-2-VWS*4.96E-3)) - PEF=AMAX1(PEF,.2) - PEF=AMIN1(PEF,.9) -! -!...PRECIPITATION EFFICIENCY IS A FUNCTION OF THE HEIGHT OF CLOUD BASE. -! - CBH=(ZLCL-Z0(1))*3.281E-3 - IF(CBH.LT.3.)THEN - RCBH=.02 - ELSE - RCBH=.96729352+CBH*(-.70034167+CBH*(.162179896+CBH*(- & - 1.2569798E-2+CBH*(4.2772E-4-CBH*5.44E-6)))) - ENDIF - IF(CBH.GT.25)RCBH=2.4 - PEFCBH=1./(1.+RCBH) - PEFCBH=AMIN1(PEFCBH,.9) -! -!... MEAN PEF. IS USED TO COMPUTE RAINFALL. -! - PEFF=.5*(PEF+PEFCBH) - PEFF2=PEFF -! WRITE(98,1035)PEF,PEFCBH,LC,LET,WKL,VWS -! -!***************************************************************** -! * -! COMPUTE DOWNDRAFT PROPERTIES * -! * -!***************************************************************** -! -!...LET DOWNDRAFT ORIGINATE AT THE LEVEL OF MINIMUM SATURATION EQUIVALEN -!...POTENTIAL TEMPERATURE (SEQT) IN THE CLOUD LAYER, EXTEND DOWNWARD TO -!...SURFACE, OR TO THE LAYER BELOW CLOUD BASE AT WHICH ENVIR SEQT IS LES -!...THAN MIN SEQT IN THE CLOUD LAYER...LET DOWNDRAFT DETRAIN OVER A LAYE -!...OF SPECIFIED PRESSURE-DEPTH (DPDD)... -! - TDER=0. - KSTART=MAX0(KPBL,KLCL) - THTMIN=THTES(KSTART+1) - KMIN=KSTART+1 - DO 104 NK=KSTART+2,LTOP-1 - THTMIN=AMIN1(THTMIN,THTES(NK)) - IF(THTMIN.EQ.THTES(NK))KMIN=NK - 104 CONTINUE - LFS=KMIN - IF(RATIO2(LFS).GT.0.)CALL ENVIRTHT(P0(LFS),T0(LFS),Q0(LFS), & - THETEE(LFS),0.,RL,EP2,ALIQ,BLIQ,CLIQ,DLIQ,AICE,BICE,CICE,DICE) - EQFRC(LFS)=(THTES(LFS)-THETEU(LFS))/(THETEE(LFS)-THETEU(LFS)) - EQFRC(LFS)=AMAX1(EQFRC(LFS),0.) - EQFRC(LFS)=AMIN1(EQFRC(LFS),1.) - THETED(LFS)=THTES(LFS) -! -!...ESTIMATE THE EFFECT OF MELTING PRECIPITATION IN THE DOWNDRAFT... -! - IF(ML.GT.0)THEN - DTMLTD=0.5*(QU(KLCL)-QU(LTOP))*RLF/CP - ELSE - DTMLTD=0. - ENDIF - TZ(LFS)=T0(LFS)-DTMLTD - ES=ALIQ*EXP((TZ(LFS)*BLIQ-CLIQ)/(TZ(LFS)-DLIQ)) - QS=EP2*ES/(P0(LFS)-ES) - QD(LFS)=EQFRC(LFS)*Q0(LFS)+(1.-EQFRC(LFS))*QU(LFS) - THTAD(LFS)=TZ(LFS)*(P00/P0(LFS))**(0.2854*(1.-0.28*QD(LFS))) - IF(QD(LFS).GE.QS)THEN - THETED(LFS)=THTAD(LFS)* & - EXP((3374.6525/TZ(LFS)-2.5403)*QS*(1.+0.81*QS)) - ELSE - CALL ENVIRTHT(P0(LFS),TZ(LFS),QD(LFS),THETED(LFS),0.,RL,EP2,ALIQ, & - BLIQ,CLIQ,DLIQ,AICE,BICE,CICE,DICE) - ENDIF - DO 107 NK=1,LFS - ND=LFS-NK - IF(THETED(LFS).GT.THTES(ND).OR.ND.EQ.1)THEN - LDB=ND -! -!...IF DOWNDRAFT NEVER BECOMES NEGATIVELY BUOYANT OR IF IT -!...IS SHALLOWER 50 mb, DON'T ALLOW IT TO OCCUR AT ALL... -! - IF(NK.EQ.1.OR.(P0(LDB)-P0(LFS)).LT.50.E2)GOTO 141 -! testing ---- no downdraft -! GOTO 141 - GOTO 110 - ENDIF - 107 CONTINUE -! -!...ALLOW DOWNDRAFT TO DETRAIN IN A SINGLE LAYER, BUT WITH DOWNDRAFT AIR -!...TYPICALLY FLUSHED UP INTO HIGHER LAYERS AS ALLOWED IN THE TOTAL -!...VERTICAL ADVECTION CALCULATIONS FARTHER DOWN IN THE CODE... -! - 110 DPDD=DP(LDB) - LDT=LDB - FRC=1. - DPT=0. -! DO 115 NK=LDB,LFS -! DPT=DPT+DP(NK) -! IF(DPT.GT.DPDD)THEN -! LDT=NK -! FRC=(DPDD+DP(NK)-DPT)/DP(NK) -! GOTO 120 -! ENDIF -! IF(NK.EQ.LFS-1)THEN -! LDT=NK -! FRC=1. -! DPDD=DPT -! GOTO 120 -! ENDIF -!115 CONTINUE - 120 CONTINUE -! -!...TAKE A FIRST GUESS AT THE INITIAL DOWNDRAFT MASS FLUX.. -! - TVD(LFS)=T0(LFS)*(1.+0.608*QES(LFS)) - RDD=P0(LFS)/(R*TVD(LFS)) - A1=(1.-PEFF)*AU0 - DMF(LFS)=-A1*RDD - DER(LFS)=EQFRC(LFS)*DMF(LFS) - DDR(LFS)=0. - DO 140 ND=LFS-1,LDB,-1 - ND1=ND+1 - IF(ND.LE.LDT)THEN - DER(ND)=0. - DDR(ND)=-DMF(LDT+1)*DP(ND)*FRC/DPDD - DMF(ND)=DMF(ND1)+DDR(ND) - FRC=1. - THETED(ND)=THETED(ND1) - QD(ND)=QD(ND1) - ELSE - DER(ND)=DMF(LFS)*0.03*DP(ND)/RAD - DDR(ND)=0. - DMF(ND)=DMF(ND1)+DER(ND) - IF(RATIO2(ND).GT.0.)CALL ENVIRTHT(P0(ND),T0(ND),Q0(ND), & - THETEE(ND),0.,RL,EP2,ALIQ,BLIQ,CLIQ,DLIQ,AICE,BICE,CICE,DICE) - THETED(ND)=(THETED(ND1)*DMF(ND1)+THETEE(ND)*DER(ND))/DMF(ND) - QD(ND)=(QD(ND1)*DMF(ND1)+Q0(ND)*DER(ND))/DMF(ND) - ENDIF - 140 CONTINUE - TDER=0. -! -!...CALCULATION AN EVAPORATION RATE FOR GIVEN MASS FLUX... -! - DO 135 ND=LDB,LDT - TZ(ND)= & - TPDD(P0(ND),THETED(LDT),T0(ND),QS,QD(ND),1.0,XLV0,XLV1, & - EP2,ALIQ,BLIQ,CLIQ,DLIQ,AICE,BICE,CICE,DICE) - ES=ALIQ*EXP((TZ(ND)*BLIQ-CLIQ)/(TZ(ND)-DLIQ)) - QS=EP2*ES/(P0(ND)-ES) - DSSDT=(CLIQ-BLIQ*DLIQ)/((TZ(ND)-DLIQ)*(TZ(ND)-DLIQ)) - RL=XLV0-XLV1*TZ(ND) - DTMP=RL*QS*(1.-RHBC)/(CP+RL*RHBC*QS*DSSDT) - T1RH=TZ(ND)+DTMP - ES=RHBC*ALIQ*EXP((BLIQ*T1RH-CLIQ)/(T1RH-DLIQ)) - QSRH=EP2*ES/(P0(ND)-ES) -! -!...CHECK TO SEE IF MIXING RATIO AT SPECIFIED RH IS LESS THAN ACTUAL -!...MIXING RATIO...IF SO, ADJUST TO GIVE ZERO EVAPORATION... -! - IF(QSRH.LT.QD(ND))THEN - QSRH=QD(ND) -! T1RH=T1+(QS-QSRH)*RL/CP - T1RH=TZ(ND) - ENDIF - TZ(ND)=T1RH - QS=QSRH - TDER=TDER+(QS-QD(ND))*DDR(ND) - QD(ND)=QS - 135 THTAD(ND)=TZ(ND)*(P00/P0(ND))**(0.2854*(1.-0.28*QD(ND))) -! -!...IF DOWNDRAFT DOES NOT EVAPORATE ANY WATER FOR SPECIFIED RELATIVE -!...HUMIDITY, NO DOWNDRAFT IS ALLOWED... -! - 141 IF(TDER.LT.1.)THEN -! WRITE(98,3004)I,J - 3004 FORMAT(' ','I=',I3,2X,'J=',I3) - PPTFLX=TRPPT - CPR=TRPPT - TDER=0. - CNDTNF=0. - UPDINC=1. - LDB=LFS - DO 117 NDK=1,LTOP - DMF(NDK)=0. - DER(NDK)=0. - DDR(NDK)=0. - THTAD(NDK)=0. - WD(NDK)=0. - TZ(NDK)=0. - 117 QD(NDK)=0. - AINCM2=100. - GOTO 165 - ENDIF -! -!...ADJUST DOWNDRAFT MASS FLUX SO THAT EVAPORATION RATE IN DOWNDRAFT IS -!...CONSISTENT WITH PRECIPITATION EFFICIENCY RELATIONSHIP... -! - DEVDMF=TDER/DMF(LFS) - PPR=0. - PPTFLX=PEFF*USR - RCED=TRPPT-PPTFLX -! -!...PPR IS THE TOTAL AMOUNT OF PRECIPITATION THAT FALLS OUT OF THE -!...UPDRAFT FROM CLOUD BASE TO THE LFS...UPDRAFT MASS FLUX WILL BE -!...INCREASED UP TO THE LFS TO ACCOUNT FOR UPDRAFT AIR MIXING WITH -!...ENVIRONMENTAL AIR TO THE UPDRAFT, SO PPR WILL INCREASE -!...PROPORTIONATELY... -! - DO 132 NM=KLCL,LFS - 132 PPR=PPR+PPTLIQ(NM)+PPTICE(NM) - IF(LFS.GE.KLCL)THEN - DPPTDF=(1.-PEFF)*PPR*(1.-EQFRC(LFS))/UMF(LFS) - ELSE - DPPTDF=0. - ENDIF -! -!...CNDTNF IS THE AMOUNT OF CONDENSATE TRANSFERRED ALONG WITH UPDRAFT -!...MASS THE DOWNDRAFT AT THE LFS... -! - CNDTNF=(QLIQ(LFS)+QICE(LFS))*(1.-EQFRC(LFS)) - DMFLFS=RCED/(DEVDMF+DPPTDF+CNDTNF) - IF(DMFLFS.GT.0.)THEN - TDER=0. - GOTO 141 - ENDIF -! -!...DDINC IS THE FACTOR BY WHICH TO INCREASE THE FIRST-GUESS DOWNDRAFT -!...MASS FLUX TO SATISFY THE PRECIP EFFICIENCY RELATIONSHIP, UPDINC IS T -!...WHICH TO INCREASE THE UPDRAFT MASS FLUX BELOW THE LFS TO ACCOUNT FOR -!...TRANSFER OF MASS FROM UPDRAFT TO DOWNDRAFT... -! -! DDINC=DMFLFS/DMF(LFS) - IF(LFS.GE.KLCL)THEN - UPDINC=(UMF(LFS)-(1.-EQFRC(LFS))*DMFLFS)/UMF(LFS) -! -!...LIMIT UPDINC TO LESS THAN OR EQUAL TO 1.5... -! - IF(UPDINC.GT.1.5)THEN - UPDINC=1.5 - DMFLFS2=UMF(LFS)*(UPDINC-1.)/(EQFRC(LFS)-1.) - RCED2=DMFLFS2*(DEVDMF+DPPTDF+CNDTNF) - PPTFLX=PPTFLX+(RCED-RCED2) - PEFF2=PPTFLX/USR - RCED=RCED2 - DMFLFS=DMFLFS2 - ENDIF - ELSE - UPDINC=1. - ENDIF - DDINC=DMFLFS/DMF(LFS) - DO 149 NK=LDB,LFS - DMF(NK)=DMF(NK)*DDINC - DER(NK)=DER(NK)*DDINC - DDR(NK)=DDR(NK)*DDINC - 149 CONTINUE - CPR=TRPPT+PPR*(UPDINC-1.) - PPTFLX=PPTFLX+PEFF*PPR*(UPDINC-1.) - PEFF=PEFF2 - TDER=TDER*DDINC -! -!...ADJUST UPDRAFT MASS FLUX, MASS DETRAINMENT RATE, AND LIQUID WATER AN -! DETRAINMENT RATES TO BE CONSISTENT WITH THE TRANSFER OF THE ESTIMATE -! FROM THE UPDRAFT TO THE DOWNDRAFT AT THE LFS... -! - DO 155 NK=LC,LFS - UMF(NK)=UMF(NK)*UPDINC - UDR(NK)=UDR(NK)*UPDINC - UER(NK)=UER(NK)*UPDINC - PPTLIQ(NK)=PPTLIQ(NK)*UPDINC - PPTICE(NK)=PPTICE(NK)*UPDINC - DETLQ(NK)=DETLQ(NK)*UPDINC - 155 DETIC(NK)=DETIC(NK)*UPDINC -! -!...ZERO OUT THE ARRAYS FOR DOWNDRAFT DATA AT LEVELS ABOVE AND BELOW THE -!...DOWNDRAFT... -! - IF(LDB.GT.1)THEN - DO 156 NK=1,LDB-1 - DMF(NK)=0. - DER(NK)=0. - DDR(NK)=0. - WD(NK)=0. - TZ(NK)=0. - QD(NK)=0. - THTAD(NK)=0. - 156 CONTINUE - ENDIF - DO 157 NK=LFS+1,KX - DMF(NK)=0. - DER(NK)=0. - DDR(NK)=0. - WD(NK)=0. - TZ(NK)=0. - QD(NK)=0. - THTAD(NK)=0. - 157 CONTINUE - DO 158 NK=LDT+1,LFS-1 - TZ(NK)=0. - QD(NK)=0. - 158 CONTINUE -! -! -!...SET LIMITS ON THE UPDRAFT AND DOWNDRAFT MASS FLUXES SO THAT THE -! INFLOW INTO CONVECTIVE DRAFTS FROM A GIVEN LAYER IS NO MORE THAN -! IS AVAILABLE IN THAT LAYER INITIALLY... -! - 165 AINCMX=1000. - LMAX=MAX0(KLCL,LFS) - DO 166 NK=LC,LMAX - IF((UER(NK)-DER(NK)).GT.0.)AINCM1=EMS(NK)/((UER(NK)-DER(NK))* & - TIMEC) - AINCMX=AMIN1(AINCMX,AINCM1) - 166 CONTINUE - AINC=1. - IF(AINCMX.LT.AINC)AINC=AINCMX -! -!...SAVE THE RELEVENT VARIABLES FOR A UNIT UPDRFT AND DOWNDRFT...THEY -!...WILL ITERATIVELY ADJUSTED BY THE FACTOR AINC TO SATISFY THE -!...STABILIZATION CLOSURE... -! - NCOUNT=0 - TDER2=TDER - PPTFL2=PPTFLX - DO 170 NK=1,LTOP - DETLQ2(NK)=DETLQ(NK) - DETIC2(NK)=DETIC(NK) - UDR2(NK)=UDR(NK) - UER2(NK)=UER(NK) - DDR2(NK)=DDR(NK) - DER2(NK)=DER(NK) - UMF2(NK)=UMF(NK) - DMF2(NK)=DMF(NK) - 170 CONTINUE - FABE=1. - STAB=0.95 - NOITR=0 - IF(AINC/AINCMX.GT.0.999)THEN - NCOUNT=0 - GOTO 255 - ENDIF - ISTOP=0 - 175 NCOUNT=NCOUNT+1 -! -!***************************************************************** -! * -! COMPUTE PROPERTIES FOR COMPENSATIONAL SUBSIDENCE * -! * -!***************************************************************** -! -!...DETERMINE OMEGA VALUE NECESSARY AT TOP AND BOTTOM OF EACH LAYER TO -!...SATISFY MASS CONTINUITY... -! - 185 CONTINUE - DTT=TIMEC - DO 200 NK=1,LTOP - DOMGDP(NK)=-(UER(NK)-DER(NK)-UDR(NK)-DDR(NK))*EMSD(NK) - IF(NK.GT.1)THEN - OMG(NK)=OMG(NK-1)-DP(NK-1)*DOMGDP(NK-1) - DTT1=0.75*DP(NK-1)/(ABS(OMG(NK))+1.E-10) - DTT=AMIN1(DTT,DTT1) - ENDIF - 200 CONTINUE - DO 488 NK=1,LTOP - THPA(NK)=THTA0(NK) - QPA(NK)=Q0(NK) - NSTEP=NINT(TIMEC/DTT+1) - DTIME=TIMEC/FLOAT(NSTEP) - FXM(NK)=OMG(NK)*DXSQ/G - 488 CONTINUE -! -!...DO AN UPSTREAM/FORWARD-IN-TIME ADVECTION OF THETA, QV... -! - DO 495 NTC=1,NSTEP -! -!...ASSIGN THETA AND Q VALUES AT THE TOP AND BOTTOM OF EACH LAYER BASED -!...SIGN OF OMEGA... -! - DO 493 NK=1,LTOP - THFXTOP(NK)=0. - THFXBOT(NK)=0. - QFXTOP(NK)=0. - 493 QFXBOT(NK)=0. - DO 494 NK=2,LTOP - IF(OMG(NK).LE.0.)THEN - THFXBOT(NK)=-FXM(NK)*THPA(NK-1) - QFXBOT(NK)=-FXM(NK)*QPA(NK-1) - THFXTOP(NK-1)=THFXTOP(NK-1)-THFXBOT(NK) - QFXTOP(NK-1)=QFXTOP(NK-1)-QFXBOT(NK) - ELSE - THFXBOT(NK)=-FXM(NK)*THPA(NK) - QFXBOT(NK)=-FXM(NK)*QPA(NK) - THFXTOP(NK-1)=THFXTOP(NK-1)-THFXBOT(NK) - QFXTOP(NK-1)=QFXTOP(NK-1)-QFXBOT(NK) - ENDIF - 494 CONTINUE -! -!...UPDATE THE THETA AND QV VALUES AT EACH LEVEL.. -! - DO 492 NK=1,LTOP - THPA(NK)=THPA(NK)+(THFXBOT(NK)+UDR(NK)*THTAU(NK)+DDR(NK)* & - THTAD(NK)+THFXTOP(NK)-(UER(NK)-DER(NK))*THTA0(NK))* & - DTIME*EMSD(NK) - QPA(NK)=QPA(NK)+(QFXBOT(NK)+UDR(NK)*QDT(NK)+DDR(NK)*QD(NK)+ & - QFXTOP(NK)-(UER(NK)-DER(NK))*Q0(NK))*DTIME*EMSD(NK) - - 492 CONTINUE - 495 CONTINUE - DO 498 NK=1,LTOP - THTAG(NK)=THPA(NK) - QG(NK)=QPA(NK) - 498 CONTINUE -! -!...CHECK TO SEE IF MIXING RATIO DIPS BELOW ZERO ANYWHERE; IF SO, -!...BORROW MOISTURE FROM ADJACENT LAYERS TO BRING IT BACK UP ABOVE ZERO. -! - DO 499 NK=1,LTOP - IF(QG(NK).LT.0.)THEN - IF(NK.EQ.1)THEN - CALL wrf_error_fatal ( 'module_cu_kf.F: problem with kf scheme: qg = 0 at the surface' ) - ENDIF - NK1=NK+1 - IF(NK.EQ.LTOP)NK1=KLCL - TMA=QG(NK1)*EMS(NK1) - TMB=QG(NK-1)*EMS(NK-1) - TMM=(QG(NK)-1.E-9)*EMS(NK) - BCOEFF=-TMM/((TMA*TMA)/TMB+TMB) - ACOEFF=BCOEFF*TMA/TMB - TMB=TMB*(1.-BCOEFF) - TMA=TMA*(1.-ACOEFF) - IF(NK.EQ.LTOP)THEN - QVDIFF=(QG(NK1)-TMA*EMSD(NK1))*100./QG(NK1) - IF(ABS(QVDIFF).GT.1.)THEN - PRINT *,'--WARNING-- CLOUD BASE WATER VAPOR CHANGES BY ', & - QVDIFF, & - ' PERCENT WHEN MOISTURE IS BORROWED TO PREVENT NEG VALUES', & - ' IN KAIN-FRITSCH' - ENDIF - ENDIF - QG(NK)=1.E-9 - QG(NK1)=TMA*EMSD(NK1) - QG(NK-1)=TMB*EMSD(NK-1) - ENDIF - 499 CONTINUE - TOPOMG=(UDR(LTOP)-UER(LTOP))*DP(LTOP)*EMSD(LTOP) - IF(ABS(TOPOMG-OMG(LTOP)).GT.1.E-3)THEN -! WRITE(98,*)'ERROR: MASS DOES NOT BALANCE IN KF SCHEME;' -! * ,'TOPOMG, OMG =',TOPOMG,OMG(LTOP) - WRITE(6,*)'ERROR: MASS DOES NOT BALANCE IN KF SCHEME;' & - ,'TOPOMG, OMG =',TOPOMG,OMG(LTOP) - ISTOP=1 - GOTO 265 - ENDIF -! -!...CONVERT THETA TO T... -! -! PAY ATTENTION ... -! - DO 230 NK=1,LTOP - EXN(NK)=(P00/P0(NK))**(0.2854*(1.-0.28*QG(NK))) - TG(NK)=THTAG(NK)/EXN(NK) - TVG(NK)=TG(NK)*(1.+0.608*QG(NK)) - 230 CONTINUE -! -!******************************************************************* -! * -! COMPUTE NEW CLOUD AND CHANGE IN AVAILABLE BUOYANT ENERGY. * -! * -!******************************************************************* -! -!...THE FOLLOWING COMPUTATIONS ARE SIMILAR TO THAT FOR UPDRAFT -! - THMIX=0. - QMIX=0. - PMIX=0. - DO 217 NK=LC,KPBL - ROCPQ=0.2854*(1.-0.28*QG(NK)) - THMIX=THMIX+DP(NK)*TG(NK)*(P00/P0(NK))**ROCPQ - QMIX=QMIX+DP(NK)*QG(NK) - 217 PMIX=PMIX+DP(NK)*P0(NK) - THMIX=THMIX/DPTHMX - QMIX=QMIX/DPTHMX - PMIX=PMIX/DPTHMX - ROCPQ=0.2854*(1.-0.28*QMIX) - TMIX=THMIX*(PMIX/P00)**ROCPQ - ES=ALIQ*EXP((TMIX*BLIQ-CLIQ)/(TMIX-DLIQ)) - QS=EP2*ES/(PMIX-ES) -! -!...REMOVE SUPERSATURATION FOR DIAGNOSTIC PURPOSES, IF NECESSARY... -! - IF(QMIX.GT.QS)THEN - RL=XLV0-XLV1*TMIX - CPM=CP*(1.+0.887*QMIX) - DSSDT=QS*(CLIQ-BLIQ*DLIQ)/((TMIX-DLIQ)*(TMIX-DLIQ)) - DQ=(QMIX-QS)/(1.+RL*DSSDT/CPM) - TMIX=TMIX+RL/CP*DQ - QMIX=QMIX-DQ - ROCPQ=0.2854*(1.-0.28*QMIX) - THMIX=TMIX*(P00/PMIX)**ROCPQ - TLCL=TMIX - PLCL=PMIX - ELSE - QMIX=AMAX1(QMIX,0.) - EMIX=QMIX*PMIX/(EP2+QMIX) - TLOG=ALOG(EMIX/ALIQ) - TDPT=(CLIQ-DLIQ*TLOG)/(BLIQ-TLOG) - TLCL=TDPT-(.212+1.571E-3*(TDPT-T00)-4.36E-4*(TMIX-T00))*(TMIX- & - TDPT) - TLCL=AMIN1(TLCL,TMIX) - CPORQ=1./ROCPQ - PLCL=P00*(TLCL/THMIX)**CPORQ - ENDIF - TVLCL=TLCL*(1.+0.608*QMIX) - DO 235 NK=LC,KL - KLCL=NK - 235 IF(PLCL.GE.P0(NK))GOTO 240 - 240 K=KLCL-1 - DLP=ALOG(PLCL/P0(K))/ALOG(P0(KLCL)/P0(K)) -! -!...ESTIMATE ENVIRONMENTAL TEMPERATURE AND MIXING RATIO AT THE LCL... -! - TENV=TG(K)+(TG(KLCL)-TG(K))*DLP - QENV=QG(K)+(QG(KLCL)-QG(K))*DLP - TVEN=TENV*(1.+0.608*QENV) - TVBAR=0.5*(TVG(K)+TVEN) -! ZLCL=Z0(K)+R*TVBAR*ALOG(P0(K)/PLCL)/G - ZLCL=Z0(K)+(Z0(KLCL)-Z0(K))*DLP - TVAVG=0.5*(TVEN+TG(KLCL)*(1.+0.608*QG(KLCL))) - PLCL=P0(KLCL)*EXP(G/(R*TVAVG)*(Z0(KLCL)-ZLCL)) - THETEU(K)=TMIX*(1.E5/PMIX)**(0.2854*(1.-0.28*QMIX))* & - EXP((3374.6525/TLCL-2.5403)*QMIX*(1.+0.81*QMIX)) - ES=ALIQ*EXP((TENV*BLIQ-CLIQ)/(TENV-DLIQ)) - QESE=EP2*ES/(PLCL-ES) - THTESG(K)=TENV*(1.E5/PLCL)**(0.2854*(1.-0.28*QESE))* & - EXP((3374.6525/TENV-2.5403)*QESE*(1.+0.81*QESE)) -! -!...COMPUTE ADJUSTED ABE(ABEG). -! - ABEG=0. - THTUDL=THETEU(K) - DO 245 NK=K,LTOPM1 - NK1=NK+1 - ES=ALIQ*EXP((TG(NK1)*BLIQ-CLIQ)/(TG(NK1)-DLIQ)) - QESE=EP2*ES/(P0(NK1)-ES) - THTESG(NK1)=TG(NK1)*(1.E5/P0(NK1))**(0.2854*(1.-0.28*QESE))* & - EXP((3374.6525/TG(NK1)-2.5403)*QESE*(1.+0.81*QESE) & - ) -! DZZ=CVMGT(Z0(KLCL)-ZLCL,DZA(NK),NK.EQ.K) - IF(NK.EQ.K)THEN - DZZ=Z0(KLCL)-ZLCL - ELSE - DZZ=DZA(NK) - ENDIF - BE=((2.*THTUDL)/(THTESG(NK1)+THTESG(NK))-1.)*DZZ - 245 IF(BE.GT.0.)ABEG=ABEG+BE*G -! -!...ASSUME AT LEAST 90% OF CAPE (ABE) IS REMOVED BY CONVECTION DURING -!...THE PERIOD TIMEC... -! - IF(NOITR.EQ.1)THEN -! WRITE(98,1060)FABE - GOTO 265 - ENDIF - DABE=AMAX1(ABE-ABEG,0.1*ABE) - FABE=ABEG/(ABE+1.E-8) - IF(FABE.GT.1.)THEN -! WRITE(98,*)'UPDRAFT/DOWNDRAFT COUPLET INCREASES CAPE AT THIS ' -! *,'GRID POINT; NO CONVECTION ALLOWED!' - GOTO 325 - ENDIF - IF(NCOUNT.NE.1)THEN - DFDA=(FABE-FABEOLD)/(AINC-AINCOLD) - IF(DFDA.GT.0.)THEN - NOITR=1 - AINC=AINCOLD - GOTO 255 - ENDIF - ENDIF - AINCOLD=AINC - FABEOLD=FABE - IF(AINC/AINCMX.GT.0.999.AND.FABE.GT.1.05-STAB)THEN -! WRITE(98,1055)FABE - GOTO 265 - ENDIF - IF(FABE.LE.1.05-STAB.AND.FABE.GE.0.95-STAB)GOTO 265 - IF(NCOUNT.GT.10)THEN -! WRITE(98,1060)FABE - GOTO 265 - ENDIF -! -!...IF MORE THAN 10% OF THE ORIGINAL CAPE REMAINS, INCREASE THE -!...CONVECTIVE MASS FLUX BY THE FACTOR AINC: -! - IF(FABE.EQ.0.)THEN - AINC=AINC*0.5 - ELSE - AINC=AINC*STAB*ABE/(DABE+1.E-8) - ENDIF - 255 AINC=AMIN1(AINCMX,AINC) -!...IF AINC BECOMES VERY SMALL, EFFECTS OF CONVECTION -!...WILL BE MINIMAL SO JUST IGNORE IT... - IF(AINC.LT.0.05)GOTO 325 -! AINC=AMAX1(AINC,0.05) - TDER=TDER2*AINC - PPTFLX=PPTFL2*AINC -! WRITE(98,1080)LFS,LDB,LDT,TIMEC,NSTEP,NCOUNT,FABEOLD,AINCOLD - DO 260 NK=1,LTOP - UMF(NK)=UMF2(NK)*AINC - DMF(NK)=DMF2(NK)*AINC - DETLQ(NK)=DETLQ2(NK)*AINC - DETIC(NK)=DETIC2(NK)*AINC - UDR(NK)=UDR2(NK)*AINC - UER(NK)=UER2(NK)*AINC - DER(NK)=DER2(NK)*AINC - DDR(NK)=DDR2(NK)*AINC - 260 CONTINUE -! -!...GO BACK UP FOR ANOTHER ITERATION... -! - GOTO 175 - 265 CONTINUE -! -!...CLEAN THINGS UP, CALCULATE CONVECTIVE FEEDBACK TENDENCIES FOR THIS -!...GRID POINT... -! -!...COMPUTE HYDROMETEOR TENDENCIES AS IS DONE FOR T, QV... -! -!...FRC2 IS THE FRACTION OF TOTAL CONDENSATE -!...GENERATED THAT GOES INTO PRECIPITIATION - FRC2=PPTFLX/(CPR*AINC) - DO 270 NK=1,LTOP - QLPA(NK)=QL0(NK) - QIPA(NK)=QI0(NK) - QRPA(NK)=QR0(NK) - QSPA(NK)=QS0(NK) - RAINFB(NK)=PPTLIQ(NK)*AINC*FBFRC*FRC2 - SNOWFB(NK)=PPTICE(NK)*AINC*FBFRC*FRC2 - 270 CONTINUE - DO 290 NTC=1,NSTEP -! -!...ASSIGN HYDROMETEORS CONCENTRATIONS AT THE TOP AND BOTTOM OF EACH -!...LAYER BASED ON THE SIGN OF OMEGA... -! - DO 275 NK=1,LTOP - QLFXIN(NK)=0. - QLFXOUT(NK)=0. - QIFXIN(NK)=0. - QIFXOUT(NK)=0. - QRFXIN(NK)=0. - QRFXOUT(NK)=0. - QSFXIN(NK)=0. - QSFXOUT(NK)=0. - 275 CONTINUE - DO 280 NK=2,LTOP - IF(OMG(NK).LE.0.)THEN - QLFXIN(NK)=-FXM(NK)*QLPA(NK-1) - QIFXIN(NK)=-FXM(NK)*QIPA(NK-1) - QRFXIN(NK)=-FXM(NK)*QRPA(NK-1) - QSFXIN(NK)=-FXM(NK)*QSPA(NK-1) - QLFXOUT(NK-1)=QLFXOUT(NK-1)+QLFXIN(NK) - QIFXOUT(NK-1)=QIFXOUT(NK-1)+QIFXIN(NK) - QRFXOUT(NK-1)=QRFXOUT(NK-1)+QRFXIN(NK) - QSFXOUT(NK-1)=QSFXOUT(NK-1)+QSFXIN(NK) - ELSE - QLFXOUT(NK)=FXM(NK)*QLPA(NK) - QIFXOUT(NK)=FXM(NK)*QIPA(NK) - QRFXOUT(NK)=FXM(NK)*QRPA(NK) - QSFXOUT(NK)=FXM(NK)*QSPA(NK) - QLFXIN(NK-1)=QLFXIN(NK-1)+QLFXOUT(NK) - QIFXIN(NK-1)=QIFXIN(NK-1)+QIFXOUT(NK) - QRFXIN(NK-1)=QRFXIN(NK-1)+QRFXOUT(NK) - QSFXIN(NK-1)=QSFXIN(NK-1)+QSFXOUT(NK) - ENDIF - 280 CONTINUE -! -!...UPDATE THE HYDROMETEOR CONCENTRATION VALUES AT EACH LEVEL... -! - DO 285 NK=1,LTOP - QLPA(NK)=QLPA(NK)+(QLFXIN(NK)+DETLQ(NK)-QLFXOUT(NK))*DTIME* & - EMSD(NK) - QIPA(NK)=QIPA(NK)+(QIFXIN(NK)+DETIC(NK)-QIFXOUT(NK))*DTIME* & - EMSD(NK) - QRPA(NK)=QRPA(NK)+(QRFXIN(NK)+QLQOUT(NK)*UDR(NK)-QRFXOUT(NK) & - +RAINFB(NK))*DTIME*EMSD(NK) - QSPA(NK)=QSPA(NK)+(QSFXIN(NK)+QICOUT(NK)*UDR(NK)-QSFXOUT(NK) & - +SNOWFB(NK))*DTIME*EMSD(NK) - 285 CONTINUE - 290 CONTINUE - DO 295 NK=1,LTOP - QLG(NK)=QLPA(NK) - QIG(NK)=QIPA(NK) - QRG(NK)=QRPA(NK) - QSG(NK)=QSPA(NK) - 295 CONTINUE -! WRITE(98,1080)LFS,LDB,LDT,TIMEC,NSTEP,NCOUNT,FABE,AINC -! -!...SEND FINAL PARAMETERIZED VALUES TO OUTPUT FILES... -! - IF(ISTOP.EQ.1)THEN - WRITE(6,1070)' P ',' DP ',' DT K/D ',' DR K/D ',' OMG ', & - ' DOMGDP ',' UMF ',' UER ',' UDR ',' DMF ',' DER ' & - ,' DDR ',' EMS ',' W0 ',' DETLQ ',' DETIC ' - DO 300 K=LTOP,1,-1 - DTT=(TG(K)-T0(K))*86400./TIMEC - RL=XLV0-XLV1*TG(K) - DR=-(QG(K)-Q0(K))*RL*86400./(TIMEC*CP) - UDFRC=UDR(K)*TIMEC*EMSD(K) - UEFRC=UER(K)*TIMEC*EMSD(K) - DDFRC=DDR(K)*TIMEC*EMSD(K) - DEFRC=-DER(K)*TIMEC*EMSD(K) - WRITE (6,1075)P0(K)/100.,DP(K)/100.,DTT,DR,OMG(K),DOMGDP(K)* & - 1.E4,UMF(K)/1.E6,UEFRC,UDFRC,DMF(K)/1.E6,DEFRC & - ,DDFRC,EMS(K)/1.E11,W0AVG1D(K)*1.E2,DETLQ(K) & - *TIMEC*EMSD(K)*1.E3,DETIC(K)*TIMEC*EMSD(K)* & - 1.E3 - 300 CONTINUE - WRITE(6,1085)'K','P','Z','T0','TG','DT','TU','TD','Q0','QG', & - 'DQ','QU','QD','QLG','QIG','QRG','QSG','RH0','RHG' - DO 305 K=KX,1,-1 - DTT=TG(K)-T0(K) - TUC=TU(K)-T00 - IF(K.LT.LC.OR.K.GT.LTOP)TUC=0. - TDC=TZ(K)-T00 - IF((K.LT.LDB.OR.K.GT.LDT).AND.K.NE.LFS)TDC=0. - ES=ALIQ*EXP((BLIQ*TG(K)-CLIQ)/(TG(K)-DLIQ)) - QGS=ES*EP2/(P0(K)-ES) - RH0=Q0(K)/QES(K) - RHG=QG(K)/QGS - WRITE (6,1090)K,P0(K)/100.,Z0(K),T0(K)-T00,TG(K)-T00,DTT,TUC & - ,TDC,Q0(K)*1000.,QG(K)*1000.,(QG(K)-Q0(K))* & - 1000.,QU(K)*1000.,QD(K)*1000.,QLG(K)*1000., & - QIG(K)*1000.,QRG(K)*1000.,QSG(K)*1000.,RH0,RHG - 305 CONTINUE -! -!...IF CALCULATIONS ABOVE SHOW AN ERROR IN THE MASS BUDGET, PRINT OUT A -!...TO BE USED LATER FOR DIAGNOSTIC PURPOSES, THEN ABORT RUN... -! - IF(ISTOP.EQ.1)THEN - DO 310 K=1,KX - WRITE ( wrf_err_message , 1115 ) & - Z0(K),P0(K)/100.,T0(K)-273.16,Q0(K)*1000., & - U0(K),V0(K),DP(K)/100.,W0AVG1D(K) - CALL wrf_message ( TRIM( wrf_err_message ) ) - 310 CONTINUE - CALL wrf_error_fatal ( 'module_cu_kf.F: KAIN-FRITSCH' ) - ENDIF - ENDIF - CNDTNF=(1.-EQFRC(LFS))*(QLIQ(LFS)+QICE(LFS))*DMF(LFS) -! WRITE(98,1095)CPR*AINC,TDER+PPTFLX+CNDTNF -! -! EVALUATE MOISTURE BUDGET... -! - QINIT=0. - QFNL=0. - DPT=0. - DO 315 NK=1,LTOP - DPT=DPT+DP(NK) - QINIT=QINIT+Q0(NK)*EMS(NK) - QFNL=QFNL+QG(NK)*EMS(NK) - QFNL=QFNL+(QLG(NK)+QIG(NK)+QRG(NK)+QSG(NK))*EMS(NK) - 315 CONTINUE - QFNL=QFNL+PPTFLX*TIMEC*(1.-FBFRC) - ERR2=(QFNL-QINIT)*100./QINIT -! WRITE(98,1110)QINIT,QFNL,ERR2 -! IF(ABS(ERR2).GT.0.05)STOP 'QVERR' - IF(ABS(ERR2).GT.0.05)CALL wrf_error_fatal( 'module_cu_kf.F: QVERR' ) - RELERR=ERR2*QINIT/(PPTFLX*TIMEC+1.E-10) -! WRITE(98,1120)RELERR -! WRITE(98,*)'TDER, CPR, USR, TRPPT =', -! *TDER,CPR*AINC,USR*AINC,TRPPT*AINC -! -!...FEEDBACK TO RESOLVABLE SCALE TENDENCIES. -! -!...IF THE ADVECTIVE TIME PERIOD (TADVEC) IS LESS THAN SPECIFIED MINIMUM -!...TIMEC, ALLOW FEEDBACK TO OCCUR ONLY DURING TADVEC... -! - IF(TADVEC.LT.TIMEC)NIC=NINT(TADVEC/DT) - NCA(I,J)=FLOAT(NIC)*DT - DO 320 K=1,KX -! IF(IMOIST.NE.2)THEN -! -!...IF HYDROMETEORS ARE NOT ALLOWED, THEY MUST BE EVAPORATED OR SUBLIMAT -!...AND FED BACK AS VAPOR, ALONG WITH ASSOCIATED CHANGES IN TEMPERATURE. -!...NOTE: THIS WILL INTRODUCE CHANGES IN THE CONVECTIVE TEMPERATURE AND -!...WATER VAPOR FEEDBACK TENDENCIES AND MAY LEAD TO SUPERSATURATED VALUE -!...OF QG... -! -! RLC=XLV0-XLV1*TG(K) -! RLS=XLS0-XLS1*TG(K) -! CPM=CP*(1.+0.887*QG(K)) -! TG(K)=TG(K)-(RLC*(QLG(K)+QRG(K))+RLS*(QIG(K)+QSG(K)))/CPM -! QG(K)=QG(K)+(QLG(K)+QRG(K)+QIG(K)+QSG(K)) -! DQCDT(K)=0. -! DQIDT(K)=0. -! DQRDT(K)=0. -! DQSDT(K)=0. -! ELSE - IF(.NOT. qi_flag .and. warm_rain)THEN -! -!...IF ICE PHASE IS NOT ALLOWED, MELT ALL FROZEN HYDROMETEORS... -! - CPM=CP*(1.+0.887*QG(K)) - TG(K)=TG(K)-(QIG(K)+QSG(K))*RLF/CPM - DQCDT(K)=(QLG(K)+QIG(K)-QL0(K)-QI0(K))/TIMEC - DQIDT(K)=0. - DQRDT(K)=(QRG(K)+QSG(K)-QR0(K)-QS0(K))/TIMEC - DQSDT(K)=0. - ELSEIF(.NOT. qi_flag .and. .not. warm_rain)THEN -! -!...IF ICE PHASE IS ALLOWED, BUT MIXED PHASE IS NOT, MELT FROZEN HYDROME -!...BELOW THE MELTING LEVEL, FREEZE LIQUID WATER ABOVE THE MELTING LEVEL -! - CPM=CP*(1.+0.887*QG(K)) - IF(K.LE.ML)THEN - TG(K)=TG(K)-(QIG(K)+QSG(K))*RLF/CPM - ELSEIF(K.GT.ML)THEN - TG(K)=TG(K)+(QLG(K)+QRG(K))*RLF/CPM - ENDIF - DQCDT(K)=(QLG(K)+QIG(K)-QL0(K)-QI0(K))/TIMEC - DQIDT(K)=0. - DQRDT(K)=(QRG(K)+QSG(K)-QR0(K)-QS0(K))/TIMEC - DQSDT(K)=0. - ELSEIF(qi_flag) THEN -! -!...IF MIXED PHASE HYDROMETEORS ARE ALLOWED, FEED BACK CONVECTIVE -!...TENDENCY OF HYDROMETEORS DIRECTLY... -! - DQCDT(K)=(QLG(K)-QL0(K))/TIMEC - DQIDT(K)=(QIG(K)-QI0(K))/TIMEC - DQRDT(K)=(QRG(K)-QR0(K))/TIMEC - IF (qs_flag ) THEN - DQSDT(K)=(QSG(K)-QS0(K))/TIMEC - ELSE - DQIDT(K)=DQIDT(K)+(QSG(K)-QS0(K))/TIMEC - ENDIF - ELSE - CALL wrf_error_fatal ( 'module_cu_kf: THIS COMBINATION OF IMOIST, IICE NOT ALLOWED' ) - ENDIF -! ENDIF - DTDT(K)=(TG(K)-T0(K))/TIMEC - DQDT(K)=(QG(K)-Q0(K))/TIMEC - 320 CONTINUE - -! RAINCV is in the unit of mm - - PRATEC(I,J)=PPTFLX*(1.-FBFRC)/DXSQ - RAINCV(I,J)=DT*PRATEC(I,J) - RNC=RAINCV(I,J)*NIC -! WRITE(98,909)RNC - 909 FORMAT(' CONVECTIVE RAINFALL =',F8.4,' CM') - - 325 CONTINUE - -1000 FORMAT(' ',10A8) -1005 FORMAT(' ',F6.0,2X,F6.4,2X,F7.3,1X,F6.4,2X,4(F6.3,2X),2(F7.3,1X)) -1010 FORMAT(' ',' VERTICAL VELOCITY IS NEGATIVE AT ',F4.0,' MB') -1015 FORMAT(' ','ALL REMAINING MASS DETRAINS BELOW ',F4.0,' MB') -1025 FORMAT(5X,' KLCL=',I2,' ZLCL=',F7.1,'M', & - ' DTLCL=',F5.2,' LTOP=',I2,' P0(LTOP)=',-2PF5.1,'MB FRZ LV=', & - I2,' TMIX=',0PF4.1,1X,'PMIX=',-2PF6.1,' QMIX=',3PF5.1, & - ' CAPE=',0PF7.1) -1030 FORMAT(' ',' P0(LET) = ',F6.1,' P0(LTOP) = ',F6.1,' VMFLCL =', & - E12.3,' PLCL =',F6.1,' WLCL =',F6.3,' CLDHGT =', & - F8.1) -1035 FORMAT(1X,'PEF(WS)=',F4.2,'(CB)=',F4.2,'LC,LET=',2I3,'WKL=' & - ,F6.3,'VWS=',F5.2) -1040 FORMAT(' ','PRECIP EFF = 100%, ENVIR CANNOT SUPPORT DOWND' & - ,'RAFTS') -!1045 FORMAT('NUMBER OF DOWNDRAFT ITERATIONS EXCEEDS 10...PPTFLX' & -! ' IS DIFFERENT FROM THAT GIVEN BY PRECIP EFF RELATION') -! FLIC HAS TROUBLE WITH THIS ONE. -1045 FORMAT('NUMBER OF DOWNDRAFT ITERATIONS EXCEEDS 10') -1050 FORMAT(' ','LCOUNT= ',I3,' PPTFLX/CPR, PEFF= ',F5.3,1X,F5.3, & - 'DMF(LFS)/UMF(LCL)= ',F5.3) -1055 FORMAT(/'*** DEGREE OF STABILIZATION =',F5.3,', NO MORE MASS F' & - ,'LUX IS ALLOWED') -!1060 FORMAT(/' ITERATION DOES NOT CONVERGE TO GIVE THE SPECIFIED ' & -! 'DEGREE OF STABILIZATION! FABE= ',F6.4) -1060 FORMAT(/' ITERATION DOES NOT CONVERGE. FABE= ',F6.4) - 1070 FORMAT (16A8) - 1075 FORMAT (F8.2,3(F8.2),2(F8.3),F8.2,2F8.3,F8.2,6F8.3) -1080 FORMAT(2X,'LFS,LDB,LDT =',3I3,' TIMEC, NSTEP=',F5.0,I3, & - 'NCOUNT, FABE, AINC=',I2,1X,F5.3,F6.2) - 1085 FORMAT (A3,16A7,2A8) - 1090 FORMAT (I3,F7.2,F7.0,10F7.2,4F7.3,2F8.3) -1095 FORMAT(' ',' PPT PRODUCTION RATE= ',F10.0,' TOTAL EVAP+PPT= ', & - F10.0) -1105 FORMAT(' ','NET LATENT HEAT RELEASE =',E12.5,' ACTUAL HEATING =', & - E12.5,' J/KG-S, DIFFERENCE = ',F9.3,'PERCENT') -1110 FORMAT(' ','INITIAL WATER =',E12.5,' FINAL WATER =',E12.5, & - ' TOTAL WATER CHANGE =',F8.2,'PERCENT') - 1115 FORMAT (2X,F6.0,2X,F7.2,2X,F5.1,2X,F6.3,2(2X,F5.1),2X,F7.2,2X,F7.4 & - ) -1120 FORMAT(' ','MOISTURE ERROR AS FUNCTION OF TOTAL PPT =',F9.3, & - 'PERCENT') - - END SUBROUTINE KFPARA - -!----------------------------------------------------------------------- - SUBROUTINE CONDLOAD(QLIQ,QICE,WTW,DZ,BOTERM,ENTERM,RATE,QNEWLQ, & - QNEWIC,QLQOUT,QICOUT,G) -!----------------------------------------------------------------------- - IMPLICIT NONE -!----------------------------------------------------------------------- -! 9/18/88...THIS PRECIPITATION FALLOUT SCHEME IS BASED ON THE SCHEME US -! BY OGURA AND CHO (1973). LIQUID WATER FALLOUT FROM A PARCEL IS CAL- -! CULATED USING THE EQUATION DQ=-RATE*Q*DT, BUT TO SIMULATE A QUASI- -! CONTINUOUS PROCESS, AND TO ELIMINATE A DEPENDENCY ON VERTICAL -! RESOLUTION THIS IS EXPRESSED AS Q=Q*EXP(-RATE*DZ). - - REAL, INTENT(IN ) :: G - REAL, INTENT(IN ) :: DZ,BOTERM,ENTERM,RATE - REAL, INTENT(INOUT) :: QLQOUT,QICOUT,WTW,QLIQ,QICE,QNEWLQ,QNEWIC - - REAL :: QTOT,QNEW,QEST,G1,WAVG,CONV,RATIO3,OLDQ,RATIO4,DQ,PPTDRG - - QTOT=QLIQ+QICE - QNEW=QNEWLQ+QNEWIC -! -! ESTIMATE THE VERTICAL VELOCITY SO THAT AN AVERAGE VERTICAL VELOCITY C -! BE CALCULATED TO ESTIMATE THE TIME REQUIRED FOR ASCENT BETWEEN MODEL -! LEVELS... -! - QEST=0.5*(QTOT+QNEW) - G1=WTW+BOTERM-ENTERM-2.*G*DZ*QEST/1.5 - IF(G1.LT.0.0)G1=0. - WAVG=(SQRT(WTW)+SQRT(G1))/2. - CONV=RATE*DZ/WAVG -! -! RATIO3 IS THE FRACTION OF LIQUID WATER IN FRESH CONDENSATE, RATIO4 IS -! THE FRACTION OF LIQUID WATER IN THE TOTAL AMOUNT OF CONDENSATE INVOLV -! IN THE PRECIPITATION PROCESS - NOTE THAT ONLY 60% OF THE FRESH CONDEN -! SATE IS IS ALLOWED TO PARTICIPATE IN THE CONVERSION PROCESS... -! - RATIO3=QNEWLQ/(QNEW+1.E-10) -! OLDQ=QTOT - QTOT=QTOT+0.6*QNEW - OLDQ=QTOT - RATIO4=(0.6*QNEWLQ+QLIQ)/(QTOT+1.E-10) - QTOT=QTOT*EXP(-CONV) -! -! DETERMINE THE AMOUNT OF PRECIPITATION THAT FALLS OUT OF THE UPDRAFT -! PARCEL AT THIS LEVEL... -! - DQ=OLDQ-QTOT - QLQOUT=RATIO4*DQ - QICOUT=(1.-RATIO4)*DQ -! -! ESTIMATE THE MEAN LOAD OF CONDENSATE ON THE UPDRAFT IN THE LAYER, CAL -! LATE VERTICAL VELOCITY -! - PPTDRG=0.5*(OLDQ+QTOT-0.2*QNEW) - WTW=WTW+BOTERM-ENTERM-2.*G*DZ*PPTDRG/1.5 -! -! DETERMINE THE NEW LIQUID WATER AND ICE CONCENTRATIONS INCLUDING LOSSE -! DUE TO PRECIPITATION AND GAINS FROM CONDENSATION... -! - QLIQ=RATIO4*QTOT+RATIO3*0.4*QNEW - QICE=(1.-RATIO4)*QTOT+(1.-RATIO3)*0.4*QNEW - QNEWLQ=0. - QNEWIC=0. - - END SUBROUTINE CONDLOAD - -!----------------------------------------------------------------------- - SUBROUTINE DTFRZNEW(TU,P,THTEU,QVAP,QLIQ,QICE,RATIO2,TTFRZ,TBFRZ, & - QNWFRZ,RL,FRC1,EFFQ,IFLAG,XLV0,XLV1,XLS0,XLS1, & - EP2,ALIQ,BLIQ,CLIQ,DLIQ,AICE,BICE,CICE,DICE ) -!----------------------------------------------------------------------- - IMPLICIT NONE -!----------------------------------------------------------------------- - REAL, INTENT(IN ) :: XLV0,XLV1 - REAL, INTENT(IN ) :: P,TTFRZ,TBFRZ,EFFQ,XLS0,XLS1,EP2,ALIQ, & - BLIQ,CLIQ,DLIQ,AICE,BICE,CICE,DICE - REAL, INTENT(INOUT) :: TU,THTEU,QVAP,QLIQ,QICE,RATIO2, & - FRC1,RL,QNWFRZ - INTEGER, INTENT(INOUT) :: IFLAG - - REAL :: CCP,RV,C5,QLQFRZ,QNEW,ESLIQ,ESICE,RLC,RLS,PI,ES,RLF,A, & - B,C,DQVAP,DTFRZ,TU1,QVAP1 -!----------------------------------------------------------------------- -! -!...ALLOW GLACIATION OF THE UPDRAFT TO OCCUR AS AN APPROXIMATELY LINEAR -! FUNCTION OF TEMPERATURE IN THE TEMPERATURE RANGE TTFRZ TO TBFRZ... -! - - RV=461.5 - C5=1.0723E-3 -! -!...ADJUST THE LIQUID WATER CONCENTRATIONS FROM FRESH CONDENSATE AND THA -! BROUGHT UP FROM LOWER LEVELS TO AN AMOUNT THAT WOULD BE PRESENT IF N -! LIQUID WATER HAD FROZEN THUS FAR...THIS IS NECESSARY BECAUSE THE -! EXPRESSION FOR TEMP CHANGE IS MULTIPLIED BY THE FRACTION EQUAL TO TH -! PARCEL TEMP DECREASE SINCE THE LAST MODEL LEVEL DIVIDED BY THE TOTAL -! GLACIATION INTERVAL, SO THAT EFFECTIVELY THIS APPROXIMATELY ALLOWS A -! AMOUNT OF LIQUID WATER TO FREEZE WHICH IS EQUAL TO THIS SAME FRACTIO -! OF THE LIQUID WATER THAT WAS PRESENT BEFORE THE GLACIATION PROCESS W -! INITIATED...ALSO, TO ALLOW THETAU TO CONVERT APPROXIMATELY LINEARLY -! ITS VALUE WITH RESPECT TO ICE, WE NEED TO ALLOW A PORTION OF THE FRE -! CONDENSATE TO CONTRIBUTE TO THE GLACIATION PROCESS; THE FRACTIONAL -! AMOUNT THAT APPLIES TO THIS PORTION IS 1/2 OF THE FRACTIONAL AMOUNT -! FROZEN OF THE "OLD" CONDENSATE BECAUSE THIS FRESH CONDENSATE IS ONLY -! PRODUCED GRADUALLY OVER THE LAYER...NOTE THAT IN TERMS OF THE DYNAMI -! OF THE PRECIPITATION PROCESS, IE. PRECIPITATION FALLOUT, THIS FRACTI -! AMNT OF FRESH CONDENSATE HAS ALREADY BEEN INCLUDED IN THE ICE CATEGO -! - QLQFRZ=QLIQ*EFFQ - QNEW=QNWFRZ*EFFQ*0.5 - ESLIQ=ALIQ*EXP((BLIQ*TU-CLIQ)/(TU-DLIQ)) - ESICE=AICE*EXP((BICE*TU-CICE)/(TU-DICE)) - RLC=2.5E6-2369.276*(TU-273.16) - RLS=2833922.-259.532*(TU-273.16) - RLF=RLS-RLC - CCP=1005.7*(1.+0.89*QVAP) -! -! A = D(ES)/DT IS THAT CALCULATED FROM BUCK`S (1981) EMPIRICAL FORMULAS -! FOR SATURATION VAPOR PRESSURE... -! - A=(CICE-BICE*DICE)/((TU-DICE)*(TU-DICE)) - B=RLS*EP2/P - C=A*B*ESICE/CCP - DQVAP=B*(ESLIQ-ESICE)/(RLS+RLS*C)-RLF*(QLQFRZ+QNEW)/(RLS+RLS/C) - DTFRZ=(RLF*(QLQFRZ+QNEW)+B*(ESLIQ-ESICE))/(CCP+A*B*ESICE) - TU1=TU - QVAP1=QVAP - TU=TU+FRC1*DTFRZ - QVAP=QVAP-FRC1*DQVAP - ES=QVAP*P/(EP2+QVAP) - ESLIQ=ALIQ*EXP((BLIQ*TU-CLIQ)/(TU-DLIQ)) - ESICE=AICE*EXP((BICE*TU-CICE)/(TU-DICE)) - RATIO2=(ESLIQ-ES)/(ESLIQ-ESICE) -! -! TYPICALLY, RATIO2 IS VERY CLOSE TO (TTFRZ-TU)/(TTFRZ-TBFRZ), USUALLY -! WITHIN 1% (USING TU BEFORE GALCIATION EFFECTS ARE APPLIED); IF THE -! INITIAL UPDRAFT TEMP IS BELOW TBFRZ AND RATIO2 IS STILL LESS THAN 1, -! AN ADJUSTMENT TO FRC1 AND RATIO2 IS INTRODUCED SO THAT GLACIATION -! EFFECTS ARE NOT UNDERESTIMATED; CONVERSELY, IF RATIO2 IS GREATER THAN -! FRC1 IS ADJUSTED SO THAT GLACIATION EFFECTS ARE NOT OVERESTIMATED... -! - IF(IFLAG.GT.0.AND.RATIO2.LT.1)THEN - FRC1=FRC1+(1.-RATIO2) - TU=TU1+FRC1*DTFRZ - QVAP=QVAP1-FRC1*DQVAP - RATIO2=1. - IFLAG=1 - GOTO 20 - ENDIF - IF(RATIO2.GT.1.)THEN - FRC1=FRC1-(RATIO2-1.) - FRC1=AMAX1(0.0,FRC1) - TU=TU1+FRC1*DTFRZ - QVAP=QVAP1-FRC1*DQVAP - RATIO2=1. - IFLAG=1 - ENDIF -! -! CALCULATE A HYBRID VALUE OF THETAU, ASSUMING THAT THE LATENT HEAT OF -! VAPORIZATION/SUBLIMATION CAN BE ESTIMATED USING THE SAME WEIGHTING -! FUNCTION AS THAT USED TO CALCULATE SATURATION VAPOR PRESSURE, CALCU- -! LATE NEW LIQUID WATER AND ICE CONCENTRATIONS... -! - 20 RLC=XLV0-XLV1*TU - RLS=XLS0-XLS1*TU - RL=RATIO2*RLS+(1.-RATIO2)*RLC - PI=(1.E5/P)**(0.2854*(1.-0.28*QVAP)) - THTEU=TU*PI*EXP(RL*QVAP*C5/TU*(1.+0.81*QVAP)) - IF(IFLAG.EQ.1)THEN - QICE=QICE+FRC1*DQVAP+QLIQ - QLIQ=0. - ELSE - QICE=QICE+FRC1*(DQVAP+QLQFRZ) - QLIQ=QLIQ-FRC1*QLQFRZ - ENDIF - QNWFRZ=0. - - END SUBROUTINE DTFRZNEW - -!----------------------------------------------------------------------- -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! THIS SUBROUTINE INTEGRATES THE AREA UNDER THE CURVE IN THE GAUSSIAN -! DISTRIBUTION...THE NUMERICAL APPROXIMATION TO THE INTEGRAL IS TAKEN F -! HANDBOOK OF MATHEMATICAL FUNCTIONS WITH FORMULAS, GRAPHS AND MATHEMA -! TABLES ED. BY ABRAMOWITZ AND STEGUN, NAT L BUREAU OF STANDARDS APPLI -! MATHEMATICS SERIES. JUNE, 1964., MAY, 1968. -! JACK KAIN -! 7/6/89 -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -!*********************************************************************** -!***** GAUSSIAN TYPE MIXING PROFILE....****************************** - SUBROUTINE PROF5(EQ,EE,UD) -!----------------------------------------------------------------------- - IMPLICIT NONE -!----------------------------------------------------------------------- - REAL, INTENT(IN ) :: EQ - REAL, INTENT(INOUT) :: EE,UD - REAL :: SQRT2P,A1,A2,A3,P,SIGMA,FE,X,Y,EY,E45,T1,T2,C1,C2 - - DATA SQRT2P,A1,A2,A3,P,SIGMA,FE/2.506628,0.4361836,-0.1201676, & - 0.9372980,0.33267,0.166666667,0.202765151/ - X=(EQ-0.5)/SIGMA - Y=6.*EQ-3. - EY=EXP(Y*Y/(-2)) - E45=EXP(-4.5) - T2=1./(1.+P*ABS(Y)) - T1=0.500498 - C1=A1*T1+A2*T1*T1+A3*T1*T1*T1 - C2=A1*T2+A2*T2*T2+A3*T2*T2*T2 - IF(Y.GE.0.)THEN - EE=SIGMA*(0.5*(SQRT2P-E45*C1-EY*C2)+SIGMA*(E45-EY))-E45*EQ*EQ/2. - UD=SIGMA*(0.5*(EY*C2-E45*C1)+SIGMA*(E45-EY))-E45*(0.5+EQ*EQ/2.- & - EQ) - ELSE - EE=SIGMA*(0.5*(EY*C2-E45*C1)+SIGMA*(E45-EY))-E45*EQ*EQ/2. - UD=SIGMA*(0.5*(SQRT2P-E45*C1-EY*C2)+SIGMA*(E45-EY))-E45*(0.5+EQ* & - EQ/2.-EQ) - ENDIF - EE=EE/FE - UD=UD/FE - - END SUBROUTINE PROF5 - -!----------------------------------------------------------------------- - SUBROUTINE TPMIX(P,THTU,TU,QU,QLIQ,QICE,QNEWLQ,QNEWIC,RATIO2,RL, & - XLV0,XLV1,XLS0,XLS1, & - EP2,ALIQ,BLIQ,CLIQ,DLIQ,AICE,BICE,CICE,DICE ) -!----------------------------------------------------------------------- - IMPLICIT NONE -!----------------------------------------------------------------------- - REAL, INTENT(IN ) :: XLV0,XLV1 - REAL, INTENT(IN ) :: P,THTU,RATIO2,RL,XLS0, & - XLS1,EP2,ALIQ,BLIQ,CLIQ,DLIQ,AICE,BICE,& - CICE,DICE - REAL, INTENT(INOUT) :: QU,QLIQ,QICE,TU,QNEWLQ,QNEWIC - REAL :: ES,QS,PI,THTGS,F0,T1,T0,C5,RV,ESLIQ,ESICE,F1,DT,QNEW, & - DQ, QTOT,DQICE,DQLIQ,RLL,CCP - INTEGER :: ITCNT -!----------------------------------------------------------------------- -! -!...THIS SUBROUTINE ITERATIVELY EXTRACTS WET-BULB TEMPERATURE FROM EQUIV -! POTENTIAL TEMPERATURE, THEN CHECKS TO SEE IF SUFFICIENT MOISTURE IS -! AVAILABLE TO ACHIEVE SATURATION...IF NOT, TEMPERATURE IS ADJUSTED -! ACCORDINGLY, IF SO, THE RESIDUAL LIQUID WATER/ICE CONCENTRATION IS -! DETERMINED... -! - C5=1.0723E-3 - RV=461.5 -! -! ITERATE TO FIND WET BULB TEMPERATURE AS A FUNCTION OF EQUIVALENT POT -! TEMP AND PRS, ASSUMING SATURATION VAPOR PRESSURE...RATIO2 IS THE DEG -! OF GLACIATION... -! - IF(RATIO2.LT.1.E-6)THEN - ES=ALIQ*EXP((BLIQ*TU-CLIQ)/(TU-DLIQ)) - QS=EP2*ES/(P-ES) - PI=(1.E5/P)**(0.2854*(1.-0.28*QS)) - THTGS=TU*PI*EXP((3374.6525/TU-2.5403)*QS*(1.+0.81*QS)) - ELSEIF(ABS(RATIO2-1.).LT.1.E-6)THEN - ES=AICE*EXP((BICE*TU-CICE)/(TU-DICE)) - QS=EP2*ES/(P-ES) - PI=(1.E5/P)**(0.2854*(1.-0.28*QS)) - THTGS=TU*PI*EXP((3114.834/TU-0.278296)*QS*(1.+0.81*QS)) - ELSE - ESLIQ=ALIQ*EXP((BLIQ*TU-CLIQ)/(TU-DLIQ)) - ESICE=AICE*EXP((BICE*TU-CICE)/(TU-DICE)) - ES=(1.-RATIO2)*ESLIQ+RATIO2*ESICE - QS=EP2*ES/(P-ES) - PI=(1.E5/P)**(0.2854*(1.-0.28*QS)) - THTGS=TU*PI*EXP(RL*QS*C5/TU*(1.+0.81*QS)) - ENDIF - F0=THTGS-THTU - T1=TU-0.5*F0 - T0=TU - ITCNT=0 - 90 IF(RATIO2.LT.1.E-6)THEN - ES=ALIQ*EXP((BLIQ*T1-CLIQ)/(T1-DLIQ)) - QS=EP2*ES/(P-ES) - PI=(1.E5/P)**(0.2854*(1.-0.28*QS)) - THTGS=T1*PI*EXP((3374.6525/T1-2.5403)*QS*(1.+0.81*QS)) - ELSEIF(ABS(RATIO2-1.).LT.1.E-6)THEN - ES=AICE*EXP((BICE*T1-CICE)/(T1-DICE)) - QS=EP2*ES/(P-ES) - PI=(1.E5/P)**(0.2854*(1.-0.28*QS)) - THTGS=T1*PI*EXP((3114.834/T1-0.278296)*QS*(1.+0.81*QS)) - ELSE - ESLIQ=ALIQ*EXP((BLIQ*T1-CLIQ)/(T1-DLIQ)) - ESICE=AICE*EXP((BICE*T1-CICE)/(T1-DICE)) - ES=(1.-RATIO2)*ESLIQ+RATIO2*ESICE - QS=EP2*ES/(P-ES) - PI=(1.E5/P)**(0.2854*(1.-0.28*QS)) - THTGS=T1*PI*EXP(RL*QS*C5/T1*(1.+0.81*QS)) - ENDIF - F1=THTGS-THTU - IF(ABS(F1).LT.0.01)GOTO 50 - ITCNT=ITCNT+1 - IF(ITCNT.GT.10)GOTO 50 - DT=F1*(T1-T0)/(F1-F0) - T0=T1 - F0=F1 - T1=T1-DT - GOTO 90 -! -! IF THE PARCEL IS SUPERSATURATED, CALCULATE CONCENTRATION OF FRESH -! CONDENSATE... -! - 50 IF(QS.LE.QU)THEN - QNEW=QU-QS - QU=QS - GOTO 96 - ENDIF -! -! IF THE PARCEL IS SUBSATURATED, TEMPERATURE AND MIXING RATIO MUST BE -! ADJUSTED...IF LIQUID WATER OR ICE IS PRESENT, IT IS ALLOWED TO EVAPO -! SUBLIMATE. -! - QNEW=0. - DQ=QS-QU - QTOT=QLIQ+QICE -! -! IF THERE IS ENOUGH LIQUID OR ICE TO SATURATE THE PARCEL, TEMP STAYS -! WET BULB VALUE, VAPOR MIXING RATIO IS AT SATURATED LEVEL, AND THE MI -! RATIOS OF LIQUID AND ICE ARE ADJUSTED TO MAKE UP THE ORIGINAL SATURA -! DEFICIT... OTHERWISE, ANY AVAILABLE LIQ OR ICE VAPORIZES AND APPROPR -! ADJUSTMENTS TO PARCEL TEMP; VAPOR, LIQUID, AND ICE MIXING RATIOS ARE -! -!...NOTE THAT THE LIQ AND ICE MAY BE PRESENT IN PROPORTIONS SLIGHTLY DIF -! THAN SUGGESTED BY THE VALUE OF RATIO2...CHECK TO MAKE SURE THAT LIQ -! ICE CONCENTRATIONS ARE NOT REDUCED TO BELOW ZERO WHEN EVAPORATION/ -! SUBLIMATION OCCURS... -! - IF(QTOT.GE.DQ)THEN - DQICE=0.0 - DQLIQ=0.0 - QLIQ=QLIQ-(1.-RATIO2)*DQ - IF(QLIQ.LT.0.)THEN - DQICE=0.0-QLIQ - QLIQ=0.0 - ENDIF - QICE=QICE-RATIO2*DQ+DQICE - IF(QICE.LT.0.)THEN - DQLIQ=0.0-QICE - QICE=0.0 - ENDIF - QLIQ=QLIQ+DQLIQ - QU=QS - GOTO 96 - ELSE - IF(RATIO2.LT.1.E-6)THEN - RLL=XLV0-XLV1*T1 - ELSEIF(ABS(RATIO2-1.).LT.1.E-6)THEN - RLL=XLS0-XLS1*T1 - ELSE - RLL=RL - ENDIF - CCP=1005.7*(1.+0.89*QU) - IF(QTOT.LT.1.E-10)THEN -! -!...IF NO LIQUID WATER OR ICE IS AVAILABLE, TEMPERATURE IS GIVEN BY: - T1=T1+RLL*(DQ/(1.+DQ))/CCP - GOTO 96 - ELSE -! -!...IF SOME LIQ WATER/ICE IS AVAILABLE, BUT NOT ENOUGH TO ACHIEVE SATURA -! THE TEMPERATURE IS GIVEN BY: - T1=T1+RLL*((DQ-QTOT)/(1+DQ-QTOT))/CCP - QU=QU+QTOT - QTOT=0. - ENDIF - QLIQ=0 - QICE=0. - ENDIF - 96 TU=T1 - QNEWLQ=(1.-RATIO2)*QNEW - QNEWIC=RATIO2*QNEW - IF(ITCNT.GT.10)PRINT*,'***** NUMBER OF ITERATIONS IN TPMIX =', & - ITCNT - - END SUBROUTINE TPMIX -!----------------------------------------------------------------------- - SUBROUTINE ENVIRTHT(P1,T1,Q1,THT1,R1,RL, & - EP2,ALIQ,BLIQ,CLIQ,DLIQ,AICE,BICE,CICE,DICE ) -!----------------------------------------------------------------------- - IMPLICIT NONE -!----------------------------------------------------------------------- - REAL, INTENT(IN ) :: P1,T1,Q1,R1,RL,EP2,ALIQ,BLIQ,CLIQ,DLIQ,AICE,& - BICE,CICE,DICE - REAL, INTENT(INOUT) :: THT1 - REAL:: T00,P00,C1,C2,C3,C4,C5,EE,TLOG,TDPT,TSAT,THT,TFPT,TLOGIC, & - TSATLQ,TSATIC - - DATA T00,P00,C1,C2,C3,C4,C5/273.16,1.E5,3374.6525,2.5403,3114.834,& - 0.278296,1.0723E-3/ -! -! CALCULATE ENVIRONMENTAL EQUIVALENT POTENTIAL TEMPERATURE... -! - - IF(R1.LT.1.E-6)THEN - EE=Q1*P1/(EP2+Q1) - TLOG=ALOG(EE/ALIQ) - TDPT=(CLIQ-DLIQ*TLOG)/(BLIQ-TLOG) - TSAT=TDPT-(.212+1.571E-3*(TDPT-T00)-4.36E-4*(T1-T00))*(T1-TDPT) - THT=T1*(P00/P1)**(0.2854*(1.-0.28*Q1)) - THT1=THT*EXP((C1/TSAT-C2)*Q1*(1.+0.81*Q1)) - ELSEIF(ABS(R1-1.).LT.1.E-6)THEN - EE=Q1*P1/(EP2+Q1) - TLOG=ALOG(EE/AICE) - TFPT=(CICE-DICE*TLOG)/(BICE-TLOG) - THT=T1*(P00/P1)**(0.2854*(1.-0.28*Q1)) - TSAT=TFPT-(.182+1.13E-3*(TFPT-T00)-3.58E-4*(T1-T00))*(T1-TFPT) - THT1=THT*EXP((C3/TSAT-C4)*Q1*(1.+0.81*Q1)) - ELSE - EE=Q1*P1/(EP2+Q1) - TLOG=ALOG(EE/ALIQ) - TDPT=(CLIQ-DLIQ*TLOG)/(BLIQ-TLOG) - TLOGIC=ALOG(EE/AICE) - TFPT=(CICE-DICE*TLOGIC)/(BICE-TLOGIC) - THT=T1*(P00/P1)**(0.2854*(1.-0.28*Q1)) - TSATLQ=TDPT-(.212+1.571E-3*(TDPT-T00)-4.36E-4*(T1-T00))*(T1-TDPT) - TSATIC=TFPT-(.182+1.13E-3*(TFPT-T00)-3.58E-4*(T1-T00))*(T1-TFPT) - TSAT=R1*TSATIC+(1.-R1)*TSATLQ - THT1=THT*EXP(RL*Q1*C5/TSAT*(1.+0.81*Q1)) - ENDIF - - END SUBROUTINE ENVIRTHT - -!----------------------------------------------------------------------- -!************************* TPDD.FOR ************************************ -! THIS SUBROUTINE ITERATIVELY EXTRACTS TEMPERATURE FROM EQUIVALENT * -! POTENTIAL TEMP. IT IS DESIGNED FOR USE WITH DOWNDRAFT CALCULATIONS. -! IF RELATIVE HUMIDITY IS SPECIFIED TO BE LESS THAN 100%, PARCEL * -! TEMP, SPECIFIC HUMIDITY, AND LIQUID WATER CONTENT ARE ITERATIVELY * -! CALCULATED. * -!*********************************************************************** - FUNCTION TPDD(P,THTED,TGS,RS,RD,RH,XLV0,XLV1, & - EP2,ALIQ,BLIQ,CLIQ,DLIQ,AICE,BICE,CICE,DICE ) -!----------------------------------------------------------------------- - IMPLICIT NONE -!----------------------------------------------------------------------- - REAL, INTENT(IN ) :: XLV0,XLV1 - REAL, INTENT(IN ) :: P,THTED,TGS,RD,RH,EP2,ALIQ,BLIQ, & - CLIQ,DLIQ,AICE,BICE,CICE,DICE - REAL, INTENT(INOUT) :: RS - REAL :: TPDD,ES,PI,THTGS,F0,T1,T0,CCP,F1,DT,RL,DSSDT,T1RH,RSRH - INTEGER :: ITCNT -!----------------------------------------------------------------------- - ES=ALIQ*EXP((BLIQ*TGS-CLIQ)/(TGS-DLIQ)) - RS=EP2*ES/(P-ES) - PI=(1.E5/P)**(0.2854*(1.-0.28*RS)) - THTGS=TGS*PI*EXP((3374.6525/TGS-2.5403)*RS*(1.+0.81*RS)) - F0=THTGS-THTED - T1=TGS-0.5*F0 - T0=TGS - CCP=1005.7 -! -!...ITERATE TO FIND WET-BULB TEMPERATURE... -! - ITCNT=0 - 90 ES=ALIQ*EXP((BLIQ*T1-CLIQ)/(T1-DLIQ)) - RS=EP2*ES/(P-ES) - PI=(1.E5/P)**(0.2854*(1.-0.28*RS)) - THTGS=T1*PI*EXP((3374.6525/T1-2.5403)*RS*(1.+0.81*RS)) - F1=THTGS-THTED - IF(ABS(F1).LT.0.05)GOTO 50 - ITCNT=ITCNT+1 - IF(ITCNT.GT.10)GOTO 50 - DT=F1*(T1-T0)/(F1-F0) - T0=T1 - F0=F1 - T1=T1-DT - GOTO 90 - 50 RL=XLV0-XLV1*T1 -! -!...IF RELATIVE HUMIDITY IS SPECIFIED TO BE LESS THAN 100%, ESTIMATE THE -! TEMPERATURE AND MIXING RATIO WHICH WILL YIELD THE APPROPRIATE VALUE. -! - IF(RH.EQ.1.)GOTO 110 - DSSDT=(CLIQ-BLIQ*DLIQ)/((T1-DLIQ)*(T1-DLIQ)) - DT=RL*RS*(1.-RH)/(CCP+RL*RH*RS*DSSDT) - T1RH=T1+DT - ES=RH*ALIQ*EXP((BLIQ*T1RH-CLIQ)/(T1RH-DLIQ)) - RSRH=EP2*ES/(P-ES) -! -!...CHECK TO SEE IF MIXING RATIO AT SPECIFIED RH IS LESS THAN ACTUAL -!...MIXING RATIO...IF SO, ADJUST TO GIVE ZERO EVAPORATION... -! - IF(RSRH.LT.RD)THEN - RSRH=RD - T1RH=T1+(RS-RSRH)*RL/CCP - ENDIF - T1=T1RH - RS=RSRH - 110 TPDD=T1 - IF(ITCNT.GT.10)PRINT*,'***** NUMBER OF ITERATIONS IN TPDD = ', & - ITCNT - - END FUNCTION TPDD - -!==================================================================== - SUBROUTINE kfinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN, & - RQICUTEN,RQSCUTEN,NCA,W0AVG,P_QI,P_QS, & - P_FIRST_SCALAR,restart,allowed_to_read, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte ) -!-------------------------------------------------------------------- - IMPLICIT NONE -!-------------------------------------------------------------------- - LOGICAL , INTENT(IN) :: restart, allowed_to_read - INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte - INTEGER , INTENT(IN) :: P_QI,P_QS,P_FIRST_SCALAR - - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: & - RTHCUTEN, & - RQVCUTEN, & - RQCCUTEN, & - RQRCUTEN, & - RQICUTEN, & - RQSCUTEN - - REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: W0AVG - - REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT):: NCA - - INTEGER :: i, j, k, itf, jtf, ktf - - jtf=min0(jte,jde-1) - ktf=min0(kte,kde-1) - itf=min0(ite,ide-1) - - IF(.not.restart)THEN - DO j=jts,jtf - DO k=kts,ktf - DO i=its,itf - RTHCUTEN(i,k,j)=0. - RQVCUTEN(i,k,j)=0. - RQCCUTEN(i,k,j)=0. - RQRCUTEN(i,k,j)=0. - ENDDO - ENDDO - ENDDO - - IF (P_QI .ge. P_FIRST_SCALAR) THEN - DO j=jts,jtf - DO k=kts,ktf - DO i=its,itf - RQICUTEN(i,k,j)=0. - ENDDO - ENDDO - ENDDO - ENDIF - - IF (P_QS .ge. P_FIRST_SCALAR) THEN - DO j=jts,jtf - DO k=kts,ktf - DO i=its,itf - RQSCUTEN(i,k,j)=0. - ENDDO - ENDDO - ENDDO - ENDIF - - DO j=jts,jtf - DO i=its,itf - NCA(i,j)=-100. - ENDDO - ENDDO - - DO j=jts,jtf - DO k=kts,ktf - DO i=its,itf - W0AVG(i,k,j)=0. - ENDDO - ENDDO - ENDDO - - ENDIF - - END SUBROUTINE kfinit - -!------------------------------------------------------- - -END MODULE module_cu_kf - diff --git a/src/fim/FIMsrc/fim/wrfphys/module_cu_kfeta.F b/src/fim/FIMsrc/fim/wrfphys/module_cu_kfeta.F deleted file mode 100644 index d9a2622..0000000 --- a/src/fim/FIMsrc/fim/wrfphys/module_cu_kfeta.F +++ /dev/null @@ -1,2944 +0,0 @@ -MODULE module_cu_kfeta - - USE module_wrf_error - -!-------------------------------------------------------------------- -! Lookup table variables: - INTEGER, PARAMETER :: KFNT=250,KFNP=220 - REAL, DIMENSION(KFNT,KFNP),PRIVATE, SAVE :: TTAB,QSTAB - REAL, DIMENSION(KFNP),PRIVATE, SAVE :: THE0K - REAL, DIMENSION(200),PRIVATE, SAVE :: ALU - REAL, PRIVATE, SAVE :: RDPR,RDTHK,PLUTOP -! Note: KF Lookup table is used by subroutines KF_eta_PARA, TPMIX2, -! TPMIX2DD, ENVIRTHT -! End of Lookup table variables: - -CONTAINS - - SUBROUTINE KF_eta_CPS( & - ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte & - ,DT,KTAU,DX,CUDT,CURR_SECS,ADAPT_STEP_FLAG & - ,rho,RAINCV,PRATEC,NCA & - ,U,V,TH,T,W,dz8w,Pcps,pi & - ,W0AVG,XLV0,XLV1,XLS0,XLS1,CP,R,G,EP1 & - ,EP2,SVP1,SVP2,SVP3,SVPT0 & - ,STEPCU,CU_ACT_FLAG,warm_rain,CUTOP,CUBOT & - ,QV & - ! optionals - ,F_QV ,F_QC ,F_QR ,F_QI ,F_QS & - ,RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN & - ,RQICUTEN,RQSCUTEN & - ) -! -!------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------- - INTEGER, INTENT(IN ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - - INTEGER, INTENT(IN ) :: STEPCU - LOGICAL, INTENT(IN ) :: warm_rain - - REAL, INTENT(IN ) :: XLV0,XLV1,XLS0,XLS1 - REAL, INTENT(IN ) :: CP,R,G,EP1,EP2 - REAL, INTENT(IN ) :: SVP1,SVP2,SVP3,SVPT0 - - INTEGER, INTENT(IN ) :: KTAU - - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & - INTENT(IN ) :: & - U, & - V, & - W, & - TH, & - T, & - QV, & - dz8w, & - Pcps, & - rho, & - pi -! - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & - INTENT(INOUT) :: & - W0AVG - - REAL, INTENT(IN ) :: DT, DX - REAL, INTENT(IN ) :: CUDT - REAL, INTENT(IN ) :: CURR_SECS - LOGICAL,INTENT(IN ) :: ADAPT_STEP_FLAG -! - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(INOUT) :: RAINCV - - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(INOUT) :: PRATEC - - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(INOUT) :: NCA - - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(OUT) :: CUBOT, & - CUTOP - - LOGICAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(INOUT) :: CU_ACT_FLAG - -! -! Optional arguments -! - - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - OPTIONAL, & - INTENT(INOUT) :: & - RTHCUTEN, & - RQVCUTEN, & - RQCCUTEN, & - RQRCUTEN, & - RQICUTEN, & - RQSCUTEN - -! -! Flags relating to the optional tendency arrays declared above -! Models that carry the optional tendencies will provdide the -! optional arguments at compile time; these flags all the model -! to determine at run-time whether a particular tracer is in -! use or not. -! - LOGICAL, OPTIONAL :: & - F_QV & - ,F_QC & - ,F_QR & - ,F_QI & - ,F_QS - - -! LOCAL VARS - - LOGICAL :: flag_qr, flag_qi, flag_qs - - REAL, DIMENSION( kts:kte ) :: & - U1D, & - V1D, & - T1D, & - DZ1D, & - QV1D, & - P1D, & - RHO1D, & - W0AVG1D - - REAL, DIMENSION( kts:kte ):: & - DQDT, & - DQIDT, & - DQCDT, & - DQRDT, & - DQSDT, & - DTDT - - REAL :: TST,tv,PRS,RHOE,W0,SCR1,DXSQ,tmp - - INTEGER :: i,j,k,NTST - REAL :: lastdt = -1.0 - REAL :: W0AVGfctr, W0fctr, W0den - LOGICAL :: run_param - -! - DXSQ=DX*DX - -!---------------------- - NTST=STEPCU - TST=float(NTST*2) - flag_qr = .FALSE. - flag_qi = .FALSE. - flag_qs = .FALSE. - IF ( PRESENT(F_QR) ) flag_qr = F_QR - IF ( PRESENT(F_QI) ) flag_qi = F_QI - IF ( PRESENT(F_QS) ) flag_qs = F_QS -! - if (lastdt < 0) then - lastdt = dt - endif - - if (ADAPT_STEP_FLAG) then - W0AVGfctr = 2 * MAX(CUDT*60,dt) - dt - W0fctr = dt - W0den = 2 * MAX(CUDT*60,dt) - else - W0AVGfctr = (TST-1.) - W0fctr = 1. - W0den = TST - endif - - DO J = jts,jte - DO K=kts,kte - DO I= its,ite -! SCR1=-5.0E-4*G*rho(I,K,J)*(w(I,K,J)+w(I,K+1,J)) -! TV=T(I,K,J)*(1.+EP1*QV(I,K,J)) -! RHOE=Pcps(I,K,J)/(R*TV) -! W0=-101.9368*SCR1/RHOE - W0=0.5*(w(I,K,J)+w(I,K+1,J)) - -! Old: -! -! W0AVG(I,K,J)=(W0AVG(I,K,J)*(TST-1.)+W0)/TST -! -! New, to support adaptive time step: -! - W0AVG(I,K,J) = ( W0AVG(I,K,J) * W0AVGfctr + W0 * W0fctr ) / W0den - ENDDO - ENDDO - ENDDO - lastdt = dt - - -! -!...CHECK FOR CONVECTIVE INITIATION EVERY 5 MINUTES (OR NTST/2)... -! -!---------------------- - -! -! Modified for adaptive time step -! - if (ADAPT_STEP_FLAG) then - if ( (KTAU .eq. 1) .or. (cudt .eq. 0) .or. & - ( CURR_SECS + dt >= & - ( int( CURR_SECS / ( cudt * 60 ) ) + 1 ) * cudt * 60 ) ) then - run_param = .TRUE. - else - run_param = .FALSE. - endif - - else - if (MOD(KTAU,NTST) .EQ. 0 .or. KTAU .eq. 1) then - run_param = .TRUE. - else - run_param = .FALSE. - endif - endif - - if (run_param) then -! - DO J = jts,jte - DO I= its,ite - CU_ACT_FLAG(i,j) = .true. - ENDDO - ENDDO - - DO J = jts,jte - DO I=its,ite - - - IF ( NCA(I,J) .ge. 0.5*DT ) then - CU_ACT_FLAG(i,j) = .false. - ELSE - - DO k=kts,kte - DQDT(k)=0. - DQIDT(k)=0. - DQCDT(k)=0. - DQRDT(k)=0. - DQSDT(k)=0. - DTDT(k)=0. - ENDDO - RAINCV(I,J)=0. - CUTOP(I,J)=KTS - CUBOT(I,J)=KTE+1 - PRATEC(I,J)=0. -! -! assign vars from 3D to 1D - - DO K=kts,kte - U1D(K) =U(I,K,J) - V1D(K) =V(I,K,J) - T1D(K) =T(I,K,J) - RHO1D(K) =rho(I,K,J) - QV1D(K)=QV(I,K,J) - P1D(K) =Pcps(I,K,J) - W0AVG1D(K) =W0AVG(I,K,J) - DZ1D(k)=dz8w(I,K,J) - ENDDO - CALL KF_eta_PARA(I, J, & - U1D,V1D,T1D,QV1D,P1D,DZ1D, & - W0AVG1D,DT,DX,DXSQ,RHO1D, & - XLV0,XLV1,XLS0,XLS1,CP,R,G, & - EP2,SVP1,SVP2,SVP3,SVPT0, & - DQDT,DQIDT,DQCDT,DQRDT,DQSDT,DTDT, & - RAINCV,PRATEC,NCA, & - flag_QI,flag_QS,warm_rain, & - CUTOP,CUBOT,CUDT, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - IF(PRESENT(rthcuten).AND.PRESENT(rqvcuten)) THEN - DO K=kts,kte - RTHCUTEN(I,K,J)=DTDT(K)/pi(I,K,J) - RQVCUTEN(I,K,J)=DQDT(K) - ENDDO - ENDIF - - IF(PRESENT(rqrcuten).AND.PRESENT(rqccuten)) THEN - IF( F_QR )THEN - DO K=kts,kte - RQRCUTEN(I,K,J)=DQRDT(K) - RQCCUTEN(I,K,J)=DQCDT(K) - ENDDO - ELSE -! This is the case for Eta microphysics without 3d rain field - DO K=kts,kte - RQRCUTEN(I,K,J)=0. - RQCCUTEN(I,K,J)=DQRDT(K)+DQCDT(K) - ENDDO - ENDIF - ENDIF - -!...... QSTEN STORES GRAUPEL TENDENCY IF IT EXISTS, OTHERISE SNOW (V2) - - - IF(PRESENT( rqicuten )) THEN - IF ( F_QI ) THEN - DO K=kts,kte - RQICUTEN(I,K,J)=DQIDT(K) - ENDDO - ENDIF - ENDIF - - IF(PRESENT( rqscuten )) THEN - IF ( F_QS ) THEN - DO K=kts,kte - RQSCUTEN(I,K,J)=DQSDT(K) - ENDDO - ENDIF - ENDIF -! - ENDIF - ENDDO ! i-loop - ENDDO ! j-loop - ENDIF ! run_param -! - END SUBROUTINE KF_eta_CPS -! **************************************************************************** -!----------------------------------------------------------- - SUBROUTINE KF_eta_PARA (I, J, & - U0,V0,T0,QV0,P0,DZQ,W0AVG1D, & - DT,DX,DXSQ,rhoe, & - XLV0,XLV1,XLS0,XLS1,CP,R,G, & - EP2,SVP1,SVP2,SVP3,SVPT0, & - DQDT,DQIDT,DQCDT,DQRDT,DQSDT,DTDT, & - RAINCV,PRATEC,NCA, & - F_QI,F_QS,warm_rain, & - CUTOP,CUBOT,CUDT, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) -!----------------------------------------------------------- -!***** The KF scheme that is currently used in experimental runs of EMCs -!***** Eta model....jsk 8/00 -! - IMPLICIT NONE -!----------------------------------------------------------- - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - I,J - ! ,P_QI,P_QS,P_FIRST_SCALAR - - LOGICAL, INTENT(IN ) :: F_QI, F_QS - - LOGICAL, INTENT(IN ) :: warm_rain -! - REAL, DIMENSION( kts:kte ), & - INTENT(IN ) :: U0, & - V0, & - T0, & - QV0, & - P0, & - rhoe, & - DZQ, & - W0AVG1D -! - REAL, INTENT(IN ) :: DT,DX,DXSQ -! - - REAL, INTENT(IN ) :: XLV0,XLV1,XLS0,XLS1,CP,R,G - REAL, INTENT(IN ) :: EP2,SVP1,SVP2,SVP3,SVPT0 - -! - REAL, DIMENSION( kts:kte ), INTENT(INOUT) :: & - DQDT, & - DQIDT, & - DQCDT, & - DQRDT, & - DQSDT, & - DTDT - - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(INOUT) :: NCA - - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(INOUT) :: RAINCV - - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(INOUT) :: PRATEC - - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(OUT) :: CUBOT, & - CUTOP - REAL, INTENT(IN ) :: CUDT -! -!...DEFINE LOCAL VARIABLES... -! - REAL, DIMENSION( kts:kte ) :: & - Q0,Z0,TV0,TU,TVU,QU,TZ,TVD, & - QD,QES,THTES,TG,TVG,QG,WU,WD,W0,EMS,EMSD, & - UMF,UER,UDR,DMF,DER,DDR,UMF2,UER2, & - UDR2,DMF2,DER2,DDR2,DZA,THTA0,THETEE, & - THTAU,THETEU,THTAD,THETED,QLIQ,QICE, & - QLQOUT,QICOUT,PPTLIQ,PPTICE,DETLQ,DETIC, & - DETLQ2,DETIC2,RATIO,RATIO2 - - - REAL, DIMENSION( kts:kte ) :: & - DOMGDP,EXN,TVQU,DP,RH,EQFRC,WSPD, & - QDT,FXM,THTAG,THPA,THFXOUT, & - THFXIN,QPA,QFXOUT,QFXIN,QLPA,QLFXIN, & - QLFXOUT,QIPA,QIFXIN,QIFXOUT,QRPA, & - QRFXIN,QRFXOUT,QSPA,QSFXIN,QSFXOUT, & - QL0,QLG,QI0,QIG,QR0,QRG,QS0,QSG - - - REAL, DIMENSION( kts:kte+1 ) :: OMG - REAL, DIMENSION( kts:kte ) :: RAINFB,SNOWFB - REAL, DIMENSION( kts:kte ) :: & - CLDHGT,QSD,DILFRC,DDILFRC,TKE,TGU,QGU,THTEEG - -! LOCAL VARS - - REAL :: P00,T00,RLF,RHIC,RHBC,PIE, & - TTFRZ,TBFRZ,C5,RATE - REAL :: GDRY,ROCP,ALIQ,BLIQ, & - CLIQ,DLIQ - REAL :: FBFRC,P300,DPTHMX,THMIX,QMIX,ZMIX,PMIX, & - ROCPQ,TMIX,EMIX,TLOG,TDPT,TLCL,TVLCL, & - CPORQ,PLCL,ES,DLP,TENV,QENV,TVEN,TVBAR, & - ZLCL,WKL,WABS,TRPPT,WSIGNE,DTLCL,GDT,WLCL,& - TVAVG,QESE,WTW,RHOLCL,AU0,VMFLCL,UPOLD, & - UPNEW,ABE,WKLCL,TTEMP,FRC1, & - QNEWIC,RL,R1,QNWFRZ,EFFQ,BE,BOTERM,ENTERM,& - DZZ,UDLBE,REI,EE2,UD2,TTMP,F1,F2, & - THTTMP,QTMP,TMPLIQ,TMPICE,TU95,TU10,EE1, & - UD1,DPTT,QNEWLQ,DUMFDP,EE,TSAT, & - THTA,VCONV,TIMEC,SHSIGN,VWS,PEF, & - CBH,RCBH,PEFCBH,PEFF,PEFF2,TDER,THTMIN, & - DTMLTD,QS,TADVEC,DPDD,FRC,DPT,RDD,A1, & - DSSDT,DTMP,T1RH,QSRH,PPTFLX,CPR,CNDTNF, & - UPDINC,AINCM2,DEVDMF,PPR,RCED,DPPTDF, & - DMFLFS,DMFLFS2,RCED2,DDINC,AINCMX,AINCM1, & - AINC,TDER2,PPTFL2,FABE,STAB,DTT,DTT1, & - DTIME,TMA,TMB,TMM,BCOEFF,ACOEFF,QVDIFF, & - TOPOMG,CPM,DQ,ABEG,DABE,DFDA,FRC2,DR, & - UDFRC,TUC,QGS,RH0,RHG,QINIT,QFNL,ERR2, & - RELERR,RLC,RLS,RNC,FABEOLD,AINCOLD,UEFRC, & - DDFRC,TDC,DEFRC,RHBAR,DMFFRC,DPMIN,DILBE - REAL :: ASTRT,TP,VALUE,AINTRP,TKEMAX,QFRZ,& - QSS,PPTMLT,DTMELT,RHH,EVAC,BINC -! - INTEGER :: INDLU,NU,NUCHM,NNN,KLFS - REAL :: CHMIN,PM15,CHMAX,DTRH,RAD,DPPP - REAL :: TVDIFF,DTTOT,ABSOMG,ABSOMGTC,FRDP - - INTEGER :: KX,K,KL -! - INTEGER :: NCHECK - INTEGER, DIMENSION (kts:kte) :: KCHECK - - INTEGER :: ISTOP,ML,L5,KMIX,LOW, & - LC,MXLAYR,LLFC,NLAYRS,NK, & - KPBL,KLCL,LCL,LET,IFLAG, & - NK1,LTOP,NJ,LTOP1, & - LTOPM1,LVF,KSTART,KMIN,LFS, & - ND,NIC,LDB,LDT,ND1,NDK, & - NM,LMAX,NCOUNT,NOITR, & - NSTEP,NTC,NCHM,ISHALL,NSHALL - LOGICAL :: IPRNT - CHARACTER*1024 message -! - DATA P00,T00/1.E5,273.16/ - DATA RLF/3.339E5/ - DATA RHIC,RHBC/1.,0.90/ - DATA PIE,TTFRZ,TBFRZ,C5/3.141592654,268.16,248.16,1.0723E-3/ - DATA RATE/0.03/ -! DATA RATE/0.01/ ! value used in NRCM -!----------------------------------------------------------- - IPRNT=.FALSE. - GDRY=-G/CP - ROCP=R/CP - NSHALL = 0 - KL=kte - KX=kte -! -! ALIQ = 613.3 -! BLIQ = 17.502 -! CLIQ = 4780.8 -! DLIQ = 32.19 - ALIQ = SVP1*1000. - BLIQ = SVP2 - CLIQ = SVP2*SVPT0 - DLIQ = SVP3 -! -! -!**************************************************************************** -! ! PPT FB MODS -!...OPTION TO FEED CONVECTIVELY GENERATED RAINWATER ! PPT FB MODS -!...INTO GRID-RESOLVED RAINWATER (OR SNOW/GRAUPEL) ! PPT FB MODS -!...FIELD. "FBFRC" IS THE FRACTION OF AVAILABLE ! PPT FB MODS -!...PRECIPITATION TO BE FED BACK (0.0 - 1.0)... ! PPT FB MODS - FBFRC=0.0 ! PPT FB MODS -!...mods to allow shallow convection... - NCHM = 0 - ISHALL = 0 - DPMIN = 5.E3 -!... - P300=P0(1)-30000. -! -!...PRESSURE PERTURBATION TERM IS ONLY DEFINED AT MID-POINT OF -!...VERTICAL LAYERS...SINCE TOTAL PRESSURE IS NEEDED AT THE TOP AND -!...BOTTOM OF LAYERS BELOW, DO AN INTERPOLATION... -! -!...INPUT A VERTICAL SOUNDING ... NOTE THAT MODEL LAYERS ARE NUMBERED -!...FROM BOTTOM-UP IN THE KF SCHEME... -! - ML=0 -!SUE tmprpsb=1./PSB(I,J) -!SUE CELL=PTOP*tmprpsb -! - DO K=1,KX -! -!...IF Q0 IS ABOVE SATURATION VALUE, REDUCE IT TO SATURATION LEVEL... -! - ES=ALIQ*EXP((BLIQ*T0(K)-CLIQ)/(T0(K)-DLIQ)) - QES(K)=0.622*ES/(P0(K)-ES) - Q0(K)=AMIN1(QES(K),QV0(K)) - Q0(K)=AMAX1(0.000001,Q0(K)) - QL0(K)=0. - QI0(K)=0. - QR0(K)=0. - QS0(K)=0. - RH(K) = Q0(K)/QES(K) - DILFRC(K) = 1. - TV0(K)=T0(K)*(1.+0.608*Q0(K)) -! RHOE(K)=P0(K)/(R*TV0(K)) -! DP IS THE PRESSURE INTERVAL BETWEEN FULL SIGMA LEVELS... - DP(K)=rhoe(k)*g*DZQ(k) -! IF Turbulent Kinetic Energy (TKE) is available from turbulent mixing scheme -! use it for shallow convection...For now, assume it is not available.... -! TKE(K) = Q2(I,J,NK) - TKE(K) = 0. - CLDHGT(K) = 0. -! IF(P0(K).GE.500E2)L5=K - IF(P0(K).GE.0.5*P0(1))L5=K - IF(P0(K).GE.P300)LLFC=K - ENDDO -! -!...DZQ IS DZ BETWEEN SIGMA SURFACES, DZA IS DZ BETWEEN MODEL HALF LEVEL - Z0(1)=.5*DZQ(1) -!cdir novector - DO K=2,KL - Z0(K)=Z0(K-1)+.5*(DZQ(K)+DZQ(K-1)) - DZA(K-1)=Z0(K)-Z0(K-1) - ENDDO - DZA(KL)=0. -! -! -! To save time, specify a pressure interval to move up in sequential -! check of different ~50 mb deep groups of adjacent model layers in -! the process of identifying updraft source layer (USL). Note that -! this search is terminated as soon as a buoyant parcel is found and -! this parcel can produce a cloud greater than specifed minimum depth -! (CHMIN)...For now, set interval at 15 mb... -! - NCHECK = 1 - KCHECK(NCHECK)=1 - PM15 = P0(1)-15.E2 - DO K=2,LLFC - IF(P0(K).LT.PM15)THEN - NCHECK = NCHECK+1 - KCHECK(NCHECK) = K - PM15 = PM15-15.E2 - ENDIF - ENDDO -! - NU=0 - NUCHM=0 -usl: DO - NU = NU+1 - IF(NU.GT.NCHECK)THEN - IF(ISHALL.EQ.1)THEN - CHMAX = 0. - NCHM = 0 - DO NK = 1,NCHECK - NNN=KCHECK(NK) - IF(CLDHGT(NNN).GT.CHMAX)THEN - NCHM = NNN - NUCHM = NK - CHMAX = CLDHGT(NNN) - ENDIF - ENDDO - NU = NUCHM-1 - FBFRC=1. - CYCLE usl - ELSE - RETURN - ENDIF - ENDIF - KMIX = KCHECK(NU) - LOW=KMIX -!... - LC = LOW -! -!...ASSUME THAT IN ORDER TO SUPPORT A DEEP UPDRAFT YOU NEED A LAYER OF -!...UNSTABLE AIR AT LEAST 50 mb DEEP...TO APPROXIMATE THIS, ISOLATE A -!...GROUP OF ADJACENT INDIVIDUAL MODEL LAYERS, WITH THE BASE AT LEVEL -!...LC, SUCH THAT THE COMBINED DEPTH OF THESE LAYERS IS AT LEAST 50 mb.. -! - NLAYRS=0 - DPTHMX=0. - NK=LC-1 - IF ( NK+1 .LT. KTS ) THEN - WRITE(message,*)'WOULD GO OFF BOTTOM: KF_ETA_PARA I,J,NK',I,J,NK - CALL wrf_message (TRIM(message)) - ELSE - DO - NK=NK+1 - IF ( NK .GT. KTE ) THEN - WRITE(message,*)'WOULD GO OFF TOP: KF_ETA_PARA I,J,DPTHMX,DPMIN',I,J,DPTHMX,DPMIN - CALL wrf_message (TRIM(message)) - EXIT - ENDIF - DPTHMX=DPTHMX+DP(NK) - NLAYRS=NLAYRS+1 - IF(DPTHMX.GT.DPMIN)THEN - EXIT - ENDIF - END DO - ENDIF - IF(DPTHMX.LT.DPMIN)THEN - RETURN - ENDIF - KPBL=LC+NLAYRS-1 -! -!...******************************************************** -!...for computational simplicity without much loss in accuracy, -!...mix temperature instead of theta for evaluating convective -!...initiation (triggering) potential... -! THMIX=0. - TMIX=0. - QMIX=0. - ZMIX=0. - PMIX=0. -! -!...FIND THE THERMODYNAMIC CHARACTERISTICS OF THE LAYER BY -!...MASS-WEIGHTING THE CHARACTERISTICS OF THE INDIVIDUAL MODEL -!...LAYERS... -! -!cdir novector - DO NK=LC,KPBL - TMIX=TMIX+DP(NK)*T0(NK) - QMIX=QMIX+DP(NK)*Q0(NK) - ZMIX=ZMIX+DP(NK)*Z0(NK) - PMIX=PMIX+DP(NK)*P0(NK) - ENDDO -! THMIX=THMIX/DPTHMX - TMIX=TMIX/DPTHMX - QMIX=QMIX/DPTHMX - ZMIX=ZMIX/DPTHMX - PMIX=PMIX/DPTHMX - EMIX=QMIX*PMIX/(0.622+QMIX) -! -!...FIND THE TEMPERATURE OF THE MIXTURE AT ITS LCL... -! -! TLOG=ALOG(EMIX/ALIQ) -! ...calculate dewpoint using lookup table... -! - astrt=1.e-3 - ainc=0.075 - a1=emix/aliq - tp=(a1-astrt)/ainc - indlu=int(tp)+1 - value=(indlu-1)*ainc+astrt - aintrp=(a1-value)/ainc - tlog=aintrp*alu(indlu+1)+(1-aintrp)*alu(indlu) - TDPT=(CLIQ-DLIQ*TLOG)/(BLIQ-TLOG) - TLCL=TDPT-(.212+1.571E-3*(TDPT-T00)-4.36E-4*(TMIX-T00))*(TMIX-TDPT) - TLCL=AMIN1(TLCL,TMIX) - TVLCL=TLCL*(1.+0.608*QMIX) - ZLCL = ZMIX+(TLCL-TMIX)/GDRY - NK = LC-1 - DO - NK = NK+1 - KLCL=NK - IF(ZLCL.LE.Z0(NK) .or. NK.GT.KL)THEN - EXIT - ENDIF - ENDDO - IF(NK.GT.KL)THEN - RETURN - ENDIF - K=KLCL-1 - DLP=(ZLCL-Z0(K))/(Z0(KLCL)-Z0(K)) -! -!...ESTIMATE ENVIRONMENTAL TEMPERATURE AND MIXING RATIO AT THE LCL... -! - TENV=T0(K)+(T0(KLCL)-T0(K))*DLP - QENV=Q0(K)+(Q0(KLCL)-Q0(K))*DLP - TVEN=TENV*(1.+0.608*QENV) -! -!...CHECK TO SEE IF CLOUD IS BUOYANT USING FRITSCH-CHAPPELL TRIGGER -!...FUNCTION DESCRIBED IN KAIN AND FRITSCH (1992)...W0 IS AN -!...APROXIMATE VALUE FOR THE RUNNING-MEAN GRID-SCALE VERTICAL -!...VELOCITY, WHICH GIVES SMOOTHER FIELDS OF CONVECTIVE INITIATION -!...THAN THE INSTANTANEOUS VALUE...FORMULA RELATING TEMPERATURE -!...PERTURBATION TO VERTICAL VELOCITY HAS BEEN USED WITH THE MOST -!...SUCCESS AT GRID LENGTHS NEAR 25 km. FOR DIFFERENT GRID-LENGTHS, -!...ADJUST VERTICAL VELOCITY TO EQUIVALENT VALUE FOR 25 KM GRID -!...LENGTH, ASSUMING LINEAR DEPENDENCE OF W ON GRID LENGTH... -! - IF(ZLCL.LT.2.E3)THEN - WKLCL=0.02*ZLCL/2.E3 - ELSE - WKLCL=0.02 - ENDIF - WKL=(W0AVG1D(K)+(W0AVG1D(KLCL)-W0AVG1D(K))*DLP)*DX/25.E3-WKLCL - IF(WKL.LT.0.0001)THEN - DTLCL=0. - ELSE - DTLCL=4.64*WKL**0.33 - ENDIF -! -!...for ETA model, give parcel an extra temperature perturbation based -!...the threshold RH for condensation (U00)... -! -!...for now, just assume U00=0.75... -!...!!!!!! for MM5, SET DTRH = 0. !!!!!!!! -! U00 = 0.75 -! IF(U00.lt.1.)THEN -! QSLCL=QES(K)+(QES(KLCL)-QES(K))*DLP -! RHLCL = QENV/QSLCL -! DQSSDT = QMIX*(CLIQ-BLIQ*DLIQ)/((TLCL-DLIQ)*(TLCL-DLIQ)) -! IF(RHLCL.ge.0.75 .and. RHLCL.le.0.95)then -! DTRH = 0.25*(RHLCL-0.75)*QMIX/DQSSDT -! ELSEIF(RHLCL.GT.0.95)THEN -! DTRH = (1./RHLCL-1.)*QMIX/DQSSDT -! ELSE - DTRH = 0. -! ENDIF -! ENDIF -! IF(ISHALL.EQ.1)IPRNT=.TRUE. -! IPRNT=.TRUE. -! IF(TLCL+DTLCL.GT.TENV)GOTO 45 -! -trigger: IF(TLCL+DTLCL+DTRH.LT.TENV)THEN -! -! Parcel not buoyant, CYCLE back to start of trigger and evaluate next potential USL... -! - CYCLE usl -! - ELSE ! Parcel is buoyant, determine updraft -! -!...CONVECTIVE TRIGGERING CRITERIA HAS BEEN SATISFIED...COMPUTE -!...EQUIVALENT POTENTIAL TEMPERATURE -!...(THETEU) AND VERTICAL VELOCITY OF THE RISING PARCEL AT THE LCL... -! - CALL ENVIRTHT(PMIX,TMIX,QMIX,THETEU(K),ALIQ,BLIQ,CLIQ,DLIQ) -! -!...modify calculation of initial parcel vertical velocity...jsk 11/26/97 -! - DTTOT = DTLCL+DTRH - IF(DTTOT.GT.1.E-4)THEN - GDT=2.*G*DTTOT*500./TVEN - WLCL=1.+0.5*SQRT(GDT) - WLCL = AMIN1(WLCL,3.) - ELSE - WLCL=1. - ENDIF - PLCL=P0(K)+(P0(KLCL)-P0(K))*DLP - WTW=WLCL*WLCL -! - TVLCL=TLCL*(1.+0.608*QMIX) - RHOLCL=PLCL/(R*TVLCL) -! - LCL=KLCL - LET=LCL -! make RAD a function of background vertical velocity... - IF(WKL.LT.0.)THEN - RAD = 1000. - ELSEIF(WKL.GT.0.1)THEN - RAD = 2000. - ELSE - RAD = 1000.+1000*WKL/0.1 - ENDIF -! -!******************************************************************* -! * -! COMPUTE UPDRAFT PROPERTIES * -! * -!******************************************************************* -! -! -!... -!...ESTIMATE INITIAL UPDRAFT MASS FLUX (UMF(K))... -! - WU(K)=WLCL - AU0=0.01*DXSQ - UMF(K)=RHOLCL*AU0 - VMFLCL=UMF(K) - UPOLD=VMFLCL - UPNEW=UPOLD -! -!...RATIO2 IS THE DEGREE OF GLACIATION IN THE CLOUD (0 TO 1), -!...UER IS THE ENVIR ENTRAINMENT RATE, ABE IS AVAILABLE -!...BUOYANT ENERGY, TRPPT IS THE TOTAL RATE OF PRECIPITATION -!...PRODUCTION... -! - RATIO2(K)=0. - UER(K)=0. - ABE=0. - TRPPT=0. - TU(K)=TLCL - TVU(K)=TVLCL - QU(K)=QMIX - EQFRC(K)=1. - QLIQ(K)=0. - QICE(K)=0. - QLQOUT(K)=0. - QICOUT(K)=0. - DETLQ(K)=0. - DETIC(K)=0. - PPTLIQ(K)=0. - PPTICE(K)=0. - IFLAG=0 -! -!...TTEMP IS USED DURING CALCULATION OF THE LINEAR GLACIATION -!...PROCESS; IT IS INITIALLY SET TO THE TEMPERATURE AT WHICH -!...FREEZING IS SPECIFIED TO BEGIN. WITHIN THE GLACIATION -!...INTERVAL, IT IS SET EQUAL TO THE UPDRAFT TEMP AT THE -!...PREVIOUS MODEL LEVEL... -! - TTEMP=TTFRZ -! -!...ENTER THE LOOP FOR UPDRAFT CALCULATIONS...CALCULATE UPDRAFT TEMP, -!...MIXING RATIO, VERTICAL MASS FLUX, LATERAL DETRAINMENT OF MASS AND -!...MOISTURE, PRECIPITATION RATES AT EACH MODEL LEVEL... -! -! - EE1=1. - UD1=0. - REI = 0. - DILBE = 0. -updraft: DO NK=K,KL-1 - NK1=NK+1 - RATIO2(NK1)=RATIO2(NK) - FRC1=0. - TU(NK1)=T0(NK1) - THETEU(NK1)=THETEU(NK) - QU(NK1)=QU(NK) - QLIQ(NK1)=QLIQ(NK) - QICE(NK1)=QICE(NK) - call tpmix2(p0(nk1),theteu(nk1),tu(nk1),qu(nk1),qliq(nk1), & - qice(nk1),qnewlq,qnewic,XLV1,XLV0) -! -! -!...CHECK TO SEE IF UPDRAFT TEMP IS ABOVE THE TEMPERATURE AT WHICH -!...GLACIATION IS ASSUMED TO INITIATE; IF IT IS, CALCULATE THE -!...FRACTION OF REMAINING LIQUID WATER TO FREEZE...TTFRZ IS THE -!...TEMP AT WHICH FREEZING BEGINS, TBFRZ THE TEMP BELOW WHICH ALL -!...LIQUID WATER IS FROZEN AT EACH LEVEL... -! - IF(TU(NK1).LE.TTFRZ)THEN - IF(TU(NK1).GT.TBFRZ)THEN - IF(TTEMP.GT.TTFRZ)TTEMP=TTFRZ - FRC1=(TTEMP-TU(NK1))/(TTEMP-TBFRZ) - ELSE - FRC1=1. - IFLAG=1 - ENDIF - TTEMP=TU(NK1) -! -! DETERMINE THE EFFECTS OF LIQUID WATER FREEZING WHEN TEMPERATURE -!...IS BELOW TTFRZ... -! - QFRZ = (QLIQ(NK1)+QNEWLQ)*FRC1 - QNEWIC=QNEWIC+QNEWLQ*FRC1 - QNEWLQ=QNEWLQ-QNEWLQ*FRC1 - QICE(NK1) = QICE(NK1)+QLIQ(NK1)*FRC1 - QLIQ(NK1) = QLIQ(NK1)-QLIQ(NK1)*FRC1 - CALL DTFRZNEW(TU(NK1),P0(NK1),THETEU(NK1),QU(NK1),QFRZ, & - QICE(NK1),ALIQ,BLIQ,CLIQ,DLIQ) - ENDIF - TVU(NK1)=TU(NK1)*(1.+0.608*QU(NK1)) -! -! CALCULATE UPDRAFT VERTICAL VELOCITY AND PRECIPITATION FALLOUT... -! - IF(NK.EQ.K)THEN - BE=(TVLCL+TVU(NK1))/(TVEN+TV0(NK1))-1. - BOTERM=2.*(Z0(NK1)-ZLCL)*G*BE/1.5 - DZZ=Z0(NK1)-ZLCL - ELSE - BE=(TVU(NK)+TVU(NK1))/(TV0(NK)+TV0(NK1))-1. - BOTERM=2.*DZA(NK)*G*BE/1.5 - DZZ=DZA(NK) - ENDIF - ENTERM=2.*REI*WTW/UPOLD - - CALL CONDLOAD(QLIQ(NK1),QICE(NK1),WTW,DZZ,BOTERM,ENTERM, & - RATE,QNEWLQ,QNEWIC,QLQOUT(NK1),QICOUT(NK1),G) -! -!...IF VERT VELOCITY IS LESS THAN ZERO, EXIT THE UPDRAFT LOOP AND, -!...IF CLOUD IS TALL ENOUGH, FINALIZE UPDRAFT CALCULATIONS... -! - IF(WTW.LT.1.E-3)THEN - EXIT - ELSE - WU(NK1)=SQRT(WTW) - ENDIF -!...Calculate value of THETA-E in environment to entrain into updraft... -! - CALL ENVIRTHT(P0(NK1),T0(NK1),Q0(NK1),THETEE(NK1),ALIQ,BLIQ,CLIQ,DLIQ) -! -!...REI IS THE RATE OF ENVIRONMENTAL INFLOW... -! - REI=VMFLCL*DP(NK1)*0.03/RAD - TVQU(NK1)=TU(NK1)*(1.+0.608*QU(NK1)-QLIQ(NK1)-QICE(NK1)) - IF(NK.EQ.K)THEN - DILBE=((TVLCL+TVQU(NK1))/(TVEN+TV0(NK1))-1.)*DZZ - ELSE - DILBE=((TVQU(NK)+TVQU(NK1))/(TV0(NK)+TV0(NK1))-1.)*DZZ - ENDIF - IF(DILBE.GT.0.)ABE=ABE+DILBE*G -! -!...IF CLOUD PARCELS ARE VIRTUALLY COLDER THAN THE ENVIRONMENT, MINIMAL -!...ENTRAINMENT (0.5*REI) IS IMPOSED... -! - IF(TVQU(NK1).LE.TV0(NK1))THEN ! Entrain/Detrain IF BLOCK - EE2=0.5 - UD2=1. - EQFRC(NK1)=0. - ELSE - LET=NK1 - TTMP=TVQU(NK1) -! -!...DETERMINE THE CRITICAL MIXED FRACTION OF UPDRAFT AND ENVIRONMENTAL AIR... -! - F1=0.95 - F2=1.-F1 - THTTMP=F1*THETEE(NK1)+F2*THETEU(NK1) - QTMP=F1*Q0(NK1)+F2*QU(NK1) - TMPLIQ=F2*QLIQ(NK1) - TMPICE=F2*QICE(NK1) - call tpmix2(p0(nk1),thttmp,ttmp,qtmp,tmpliq,tmpice, & - qnewlq,qnewic,XLV1,XLV0) - TU95=TTMP*(1.+0.608*QTMP-TMPLIQ-TMPICE) - IF(TU95.GT.TV0(NK1))THEN - EE2=1. - UD2=0. - EQFRC(NK1)=1.0 - ELSE - F1=0.10 - F2=1.-F1 - THTTMP=F1*THETEE(NK1)+F2*THETEU(NK1) - QTMP=F1*Q0(NK1)+F2*QU(NK1) - TMPLIQ=F2*QLIQ(NK1) - TMPICE=F2*QICE(NK1) - call tpmix2(p0(nk1),thttmp,ttmp,qtmp,tmpliq,tmpice, & - qnewlq,qnewic,XLV1,XLV0) - TU10=TTMP*(1.+0.608*QTMP-TMPLIQ-TMPICE) - TVDIFF = ABS(TU10-TVQU(NK1)) - IF(TVDIFF.LT.1.e-3)THEN - EE2=1. - UD2=0. - EQFRC(NK1)=1.0 - ELSE - EQFRC(NK1)=(TV0(NK1)-TVQU(NK1))*F1/(TU10-TVQU(NK1)) - EQFRC(NK1)=AMAX1(0.0,EQFRC(NK1)) - EQFRC(NK1)=AMIN1(1.0,EQFRC(NK1)) - IF(EQFRC(NK1).EQ.1)THEN - EE2=1. - UD2=0. - ELSEIF(EQFRC(NK1).EQ.0.)THEN - EE2=0. - UD2=1. - ELSE -! -!...SUBROUTINE PROF5 INTEGRATES OVER THE GAUSSIAN DIST TO DETERMINE THE -! FRACTIONAL ENTRAINMENT AND DETRAINMENT RATES... -! - CALL PROF5(EQFRC(NK1),EE2,UD2) - ENDIF - ENDIF - ENDIF - ENDIF ! End of Entrain/Detrain IF BLOCK -! -! -!...NET ENTRAINMENT AND DETRAINMENT RATES ARE GIVEN BY THE AVERAGE FRACTIONAL -! VALUES IN THE LAYER... -! - EE2 = AMAX1(EE2,0.5) - UD2 = 1.5*UD2 - UER(NK1)=0.5*REI*(EE1+EE2) - UDR(NK1)=0.5*REI*(UD1+UD2) -! -!...IF THE CALCULATED UPDRAFT DETRAINMENT RATE IS GREATER THAN THE TOTAL -! UPDRAFT MASS FLUX, ALL CLOUD MASS DETRAINS, EXIT UPDRAFT CALCULATIONS... -! - IF(UMF(NK)-UDR(NK1).LT.10.)THEN -! -!...IF THE CALCULATED DETRAINED MASS FLUX IS GREATER THAN THE TOTAL UPD MASS -! FLUX, IMPOSE TOTAL DETRAINMENT OF UPDRAFT MASS AT THE PREVIOUS MODEL LVL.. -! First, correct ABE calculation if needed... -! - IF(DILBE.GT.0.)THEN - ABE=ABE-DILBE*G - ENDIF - LET=NK -! WRITE(98,1015)P0(NK1)/100. - EXIT - ELSE - EE1=EE2 - UD1=UD2 - UPOLD=UMF(NK)-UDR(NK1) - UPNEW=UPOLD+UER(NK1) - UMF(NK1)=UPNEW - DILFRC(NK1) = UPNEW/UPOLD -! -!...DETLQ AND DETIC ARE THE RATES OF DETRAINMENT OF LIQUID AND -!...ICE IN THE DETRAINING UPDRAFT MASS... -! - DETLQ(NK1)=QLIQ(NK1)*UDR(NK1) - DETIC(NK1)=QICE(NK1)*UDR(NK1) - QDT(NK1)=QU(NK1) - QU(NK1)=(UPOLD*QU(NK1)+UER(NK1)*Q0(NK1))/UPNEW - THETEU(NK1)=(THETEU(NK1)*UPOLD+THETEE(NK1)*UER(NK1))/UPNEW - QLIQ(NK1)=QLIQ(NK1)*UPOLD/UPNEW - QICE(NK1)=QICE(NK1)*UPOLD/UPNEW -! -!...PPTLIQ IS THE RATE OF GENERATION (FALLOUT) OF -!...LIQUID PRECIP AT A GIVEN MODEL LVL, PPTICE THE SAME FOR ICE, -!...TRPPT IS THE TOTAL RATE OF PRODUCTION OF PRECIP UP TO THE -!...CURRENT MODEL LEVEL... -! - PPTLIQ(NK1)=QLQOUT(NK1)*UMF(NK) - PPTICE(NK1)=QICOUT(NK1)*UMF(NK) -! - TRPPT=TRPPT+PPTLIQ(NK1)+PPTICE(NK1) - IF(NK1.LE.KPBL)UER(NK1)=UER(NK1)+VMFLCL*DP(NK1)/DPTHMX - ENDIF -! - END DO updraft -! -!...CHECK CLOUD DEPTH...IF CLOUD IS TALL ENOUGH, ESTIMATE THE EQUILIBRIU -! TEMPERATURE LEVEL (LET) AND ADJUST MASS FLUX PROFILE AT CLOUD TOP SO -! THAT MASS FLUX DECREASES TO ZERO AS A LINEAR FUNCTION OF PRESSURE BE -! THE LET AND CLOUD TOP... -! -!...LTOP IS THE MODEL LEVEL JUST BELOW THE LEVEL AT WHICH VERTICAL VELOC -! FIRST BECOMES NEGATIVE... -! - LTOP=NK - CLDHGT(LC)=Z0(LTOP)-ZLCL -! -!...Instead of using the same minimum cloud height (for deep convection) -!...everywhere, try specifying minimum cloud depth as a function of TLCL... -! -! -! - IF(TLCL.GT.293.)THEN - CHMIN = 4.E3 - ELSEIF(TLCL.LE.293. .and. TLCL.GE.273)THEN - CHMIN = 2.E3 + 100.*(TLCL-273.) - ELSEIF(TLCL.LT.273.)THEN - CHMIN = 2.E3 - ENDIF - -! -!...If cloud top height is less than the specified minimum for deep -!...convection, save value to consider this level as source for -!...shallow convection, go back up to check next level... -! -!...Try specifying minimum cloud depth as a function of TLCL... -! -! -!...DO NOT ALLOW ANY CLOUD FROM THIS LAYER IF: -! -!... 1.) if there is no CAPE, or -!... 2.) cloud top is at model level just above LCL, or -!... 3.) cloud top is within updraft source layer, or -!... 4.) cloud-top detrainment layer begins within -!... updraft source layer. -! - IF(LTOP.LE.KLCL .or. LTOP.LE.KPBL .or. LET+1.LE.KPBL)THEN ! No Convection Allowed - CLDHGT(LC)=0. - DO NK=K,LTOP - UMF(NK)=0. - UDR(NK)=0. - UER(NK)=0. - DETLQ(NK)=0. - DETIC(NK)=0. - PPTLIQ(NK)=0. - PPTICE(NK)=0. - ENDDO -! - ELSEIF(CLDHGT(LC).GT.CHMIN .and. ABE.GT.1)THEN ! Deep Convection allowed - ISHALL=0 - EXIT usl - ELSE -! -!...TO DISALLOW SHALLOW CONVECTION, COMMENT OUT NEXT LINE !!!!!!!! - ISHALL = 1 - IF(NU.EQ.NUCHM)THEN - EXIT usl ! Shallow Convection from this layer - ELSE -! Remember this layer (by virtue of non-zero CLDHGT) as potential shallow-cloud layer - DO NK=K,LTOP - UMF(NK)=0. - UDR(NK)=0. - UER(NK)=0. - DETLQ(NK)=0. - DETIC(NK)=0. - PPTLIQ(NK)=0. - PPTICE(NK)=0. - ENDDO - ENDIF - ENDIF - ENDIF trigger - END DO usl - IF(ISHALL.EQ.1)THEN - KSTART=MAX0(KPBL,KLCL) - LET=KSTART - endif -! -!...IF THE LET AND LTOP ARE THE SAME, DETRAIN ALL OF THE UPDRAFT MASS FL -! THIS LEVEL... -! - IF(LET.EQ.LTOP)THEN - UDR(LTOP)=UMF(LTOP)+UDR(LTOP)-UER(LTOP) - DETLQ(LTOP)=QLIQ(LTOP)*UDR(LTOP)*UPNEW/UPOLD - DETIC(LTOP)=QICE(LTOP)*UDR(LTOP)*UPNEW/UPOLD - UER(LTOP)=0. - UMF(LTOP)=0. - ELSE -! -! BEGIN TOTAL DETRAINMENT AT THE LEVEL ABOVE THE LET... -! - DPTT=0. - DO NJ=LET+1,LTOP - DPTT=DPTT+DP(NJ) - ENDDO - DUMFDP=UMF(LET)/DPTT -! -!...ADJUST MASS FLUX PROFILES, DETRAINMENT RATES, AND PRECIPITATION FALL -! RATES TO REFLECT THE LINEAR DECREASE IN MASS FLX BETWEEN THE LET AND -! - DO NK=LET+1,LTOP -! -!...entrainment is allowed at every level except for LTOP, so disallow -!...entrainment at LTOP and adjust entrainment rates between LET and LTOP -!...so the the dilution factor due to entyrianment is not changed but -!...the actual entrainment rate will change due due forced total -!...detrainment in this layer... -! - IF(NK.EQ.LTOP)THEN - UDR(NK) = UMF(NK-1) - UER(NK) = 0. - DETLQ(NK) = UDR(NK)*QLIQ(NK)*DILFRC(NK) - DETIC(NK) = UDR(NK)*QICE(NK)*DILFRC(NK) - ELSE - UMF(NK)=UMF(NK-1)-DP(NK)*DUMFDP - UER(NK)=UMF(NK)*(1.-1./DILFRC(NK)) - UDR(NK)=UMF(NK-1)-UMF(NK)+UER(NK) - DETLQ(NK)=UDR(NK)*QLIQ(NK)*DILFRC(NK) - DETIC(NK)=UDR(NK)*QICE(NK)*DILFRC(NK) - ENDIF - IF(NK.GE.LET+2)THEN - TRPPT=TRPPT-PPTLIQ(NK)-PPTICE(NK) - PPTLIQ(NK)=UMF(NK-1)*QLQOUT(NK) - PPTICE(NK)=UMF(NK-1)*QICOUT(NK) - TRPPT=TRPPT+PPTLIQ(NK)+PPTICE(NK) - ENDIF - ENDDO - ENDIF -! -! Initialize some arrays below cloud base and above cloud top... -! - DO NK=1,LTOP - IF(T0(NK).GT.T00)ML=NK - ENDDO - DO NK=1,K - IF(NK.GE.LC)THEN - IF(NK.EQ.LC)THEN - UMF(NK)=VMFLCL*DP(NK)/DPTHMX - UER(NK)=VMFLCL*DP(NK)/DPTHMX - ELSEIF(NK.LE.KPBL)THEN - UER(NK)=VMFLCL*DP(NK)/DPTHMX - UMF(NK)=UMF(NK-1)+UER(NK) - ELSE - UMF(NK)=VMFLCL - UER(NK)=0. - ENDIF - TU(NK)=TMIX+(Z0(NK)-ZMIX)*GDRY - QU(NK)=QMIX - WU(NK)=WLCL - ELSE - TU(NK)=0. - QU(NK)=0. - UMF(NK)=0. - WU(NK)=0. - UER(NK)=0. - ENDIF - UDR(NK)=0. - QDT(NK)=0. - QLIQ(NK)=0. - QICE(NK)=0. - QLQOUT(NK)=0. - QICOUT(NK)=0. - PPTLIQ(NK)=0. - PPTICE(NK)=0. - DETLQ(NK)=0. - DETIC(NK)=0. - RATIO2(NK)=0. - CALL ENVIRTHT(P0(NK),T0(NK),Q0(NK),THETEE(NK),ALIQ,BLIQ,CLIQ,DLIQ) - EQFRC(NK)=1.0 - ENDDO -! - LTOP1=LTOP+1 - LTOPM1=LTOP-1 -! -!...DEFINE VARIABLES ABOVE CLOUD TOP... -! - DO NK=LTOP1,KX - UMF(NK)=0. - UDR(NK)=0. - UER(NK)=0. - QDT(NK)=0. - QLIQ(NK)=0. - QICE(NK)=0. - QLQOUT(NK)=0. - QICOUT(NK)=0. - DETLQ(NK)=0. - DETIC(NK)=0. - PPTLIQ(NK)=0. - PPTICE(NK)=0. - IF(NK.GT.LTOP1)THEN - TU(NK)=0. - QU(NK)=0. - WU(NK)=0. - ENDIF - THTA0(NK)=0. - THTAU(NK)=0. - EMS(NK)=0. - EMSD(NK)=0. - TG(NK)=T0(NK) - QG(NK)=Q0(NK) - QLG(NK)=0. - QIG(NK)=0. - QRG(NK)=0. - QSG(NK)=0. - OMG(NK)=0. - ENDDO - OMG(KX+1)=0. - DO NK=1,LTOP - EMS(NK)=DP(NK)*DXSQ/G - EMSD(NK)=1./EMS(NK) -! -!...INITIALIZE SOME VARIABLES TO BE USED LATER IN THE VERT ADVECTION SCH -! - EXN(NK)=(P00/P0(NK))**(0.2854*(1.-0.28*QDT(NK))) - THTAU(NK)=TU(NK)*EXN(NK) - EXN(NK)=(P00/P0(NK))**(0.2854*(1.-0.28*Q0(NK))) - THTA0(NK)=T0(NK)*EXN(NK) - DDILFRC(NK) = 1./DILFRC(NK) - OMG(NK)=0. - ENDDO -! IF (XTIME.LT.10.)THEN -! WRITE(98,1025)KLCL,ZLCL,DTLCL,LTOP,P0(LTOP),IFLAG, -! * TMIX-T00,PMIX,QMIX,ABE -! WRITE(98,1030)P0(LET)/100.,P0(LTOP)/100.,VMFLCL,PLCL/100., -! * WLCL,CLDHGT -! ENDIF -! -!...COMPUTE CONVECTIVE TIME SCALE(TIMEC). THE MEAN WIND AT THE LCL -!...AND MIDTROPOSPHERE IS USED. -! - WSPD(KLCL)=SQRT(U0(KLCL)*U0(KLCL)+V0(KLCL)*V0(KLCL)) - WSPD(L5)=SQRT(U0(L5)*U0(L5)+V0(L5)*V0(L5)) - WSPD(LTOP)=SQRT(U0(LTOP)*U0(LTOP)+V0(LTOP)*V0(LTOP)) - VCONV=.5*(WSPD(KLCL)+WSPD(L5)) -!...for ETA model, DX is a function of location... -! TIMEC=DX(I,J)/VCONV - TIMEC=DX/VCONV - TADVEC=TIMEC - TIMEC=AMAX1(1800.,TIMEC) - TIMEC=AMIN1(3600.,TIMEC) - IF(ISHALL.EQ.1)TIMEC=2400. - NIC=NINT(TIMEC/DT) - TIMEC=FLOAT(NIC)*DT -! -!...COMPUTE WIND SHEAR AND PRECIPITATION EFFICIENCY. -! - IF(WSPD(LTOP).GT.WSPD(KLCL))THEN - SHSIGN=1. - ELSE - SHSIGN=-1. - ENDIF - VWS=(U0(LTOP)-U0(KLCL))*(U0(LTOP)-U0(KLCL))+(V0(LTOP)-V0(KLCL))* & - (V0(LTOP)-V0(KLCL)) - VWS=1.E3*SHSIGN*SQRT(VWS)/(Z0(LTOP)-Z0(LCL)) - PEF=1.591+VWS*(-.639+VWS*(9.53E-2-VWS*4.96E-3)) - PEF=AMAX1(PEF,.2) - PEF=AMIN1(PEF,.9) -! -!...PRECIPITATION EFFICIENCY IS A FUNCTION OF THE HEIGHT OF CLOUD BASE. -! - CBH=(ZLCL-Z0(1))*3.281E-3 - IF(CBH.LT.3.)THEN - RCBH=.02 - ELSE - RCBH=.96729352+CBH*(-.70034167+CBH*(.162179896+CBH*(- & - 1.2569798E-2+CBH*(4.2772E-4-CBH*5.44E-6)))) - ENDIF - IF(CBH.GT.25)RCBH=2.4 - PEFCBH=1./(1.+RCBH) - PEFCBH=AMIN1(PEFCBH,.9) -! -!... MEAN PEF. IS USED TO COMPUTE RAINFALL. -! - PEFF=.5*(PEF+PEFCBH) - PEFF2 = PEFF ! JSK MODS - IF(IPRNT)THEN -! WRITE(98,1035)PEF,PEFCBH,LC,LET,WKL,VWS - WRITE(message,1035)PEF,PEFCBH,LC,LET,WKL,VWS - CALL wrf_message( message ) -! call flush(98) - endif -! WRITE(98,1035)PEF,PEFCBH,LC,LET,WKL,VWS -!***************************************************************** -! * -! COMPUTE DOWNDRAFT PROPERTIES * -! * -!***************************************************************** -! -! - TDER=0. - devap:IF(ISHALL.EQ.1)THEN - LFS = 1 - ELSE -! -!...start downdraft about 150 mb above cloud base... -! -! KSTART=MAX0(KPBL,KLCL) -! KSTART=KPBL ! Changed 7/23/99 - KSTART=KPBL+1 ! Changed 7/23/99 - KLFS = LET-1 - DO NK = KSTART+1,KL - DPPP = P0(KSTART)-P0(NK) -! IF(DPPP.GT.200.E2)THEN - IF(DPPP.GT.150.E2)THEN - KLFS = NK - EXIT - ENDIF - ENDDO - KLFS = MIN0(KLFS,LET-1) - LFS = KLFS -! -!...if LFS is not at least 50 mb above cloud base (implying that the -!...level of equil temp, LET, is just above cloud base) do not allow a -!...downdraft... -! - IF((P0(KSTART)-P0(LFS)).GT.50.E2)THEN - THETED(LFS) = THETEE(LFS) - QD(LFS) = Q0(LFS) -! -!...call tpmix2dd to find wet-bulb temp, qv... -! - call tpmix2dd(p0(lfs),theted(lfs),tz(lfs),qss,i,j) - THTAD(LFS)=TZ(LFS)*(P00/P0(LFS))**(0.2854*(1.-0.28*QSS)) -! -!...TAKE A FIRST GUESS AT THE INITIAL DOWNDRAFT MASS FLUX... -! - TVD(LFS)=TZ(LFS)*(1.+0.608*QSS) - RDD=P0(LFS)/(R*TVD(LFS)) - A1=(1.-PEFF)*AU0 - DMF(LFS)=-A1*RDD - DER(LFS)=DMF(LFS) - DDR(LFS)=0. - RHBAR = RH(LFS)*DP(LFS) - DPTT = DP(LFS) - DO ND = LFS-1,KSTART,-1 - ND1 = ND+1 - DER(ND)=DER(LFS)*EMS(ND)/EMS(LFS) - DDR(ND)=0. - DMF(ND)=DMF(ND1)+DER(ND) - THETED(ND)=(THETED(ND1)*DMF(ND1)+THETEE(ND)*DER(ND))/DMF(ND) - QD(ND)=(QD(ND1)*DMF(ND1)+Q0(ND)*DER(ND))/DMF(ND) - DPTT = DPTT+DP(ND) - RHBAR = RHBAR+RH(ND)*DP(ND) - ENDDO - RHBAR = RHBAR/DPTT - DMFFRC = 2.*(1.-RHBAR) - DPDD = 0. -!...Calculate melting effect -!... first, compute total frozen precipitation generated... -! - pptmlt = 0. - DO NK = KLCL,LTOP - PPTMLT = PPTMLT+PPTICE(NK) - ENDDO - if(lc.lt.ml)then -!...For now, calculate melting effect as if DMF = -UMF at KLCL, i.e., as -!...if DMFFRC=1. Otherwise, for small DMFFRC, DTMELT gets too large! -!...12/14/98 jsk... - DTMELT = RLF*PPTMLT/(CP*UMF(KLCL)) - else - DTMELT = 0. - endif - LDT = MIN0(LFS-1,KSTART-1) -! - call tpmix2dd(p0(kstart),theted(kstart),tz(kstart),qss,i,j) -! - tz(kstart) = tz(kstart)-dtmelt - ES=ALIQ*EXP((BLIQ*TZ(KSTART)-CLIQ)/(TZ(KSTART)-DLIQ)) - QSS=0.622*ES/(P0(KSTART)-ES) - THETED(KSTART)=TZ(KSTART)*(1.E5/P0(KSTART))**(0.2854*(1.-0.28*QSS))* & - EXP((3374.6525/TZ(KSTART)-2.5403)*QSS*(1.+0.81*QSS)) -!.... - LDT = MIN0(LFS-1,KSTART-1) - DO ND = LDT,1,-1 - DPDD = DPDD+DP(ND) - THETED(ND) = THETED(KSTART) - QD(ND) = QD(KSTART) -! -!...call tpmix2dd to find wet bulb temp, saturation mixing ratio... -! - call tpmix2dd(p0(nd),theted(nd),tz(nd),qss,i,j) - qsd(nd) = qss -! -!...specify RH decrease of 20%/km in downdraft... -! - RHH = 1.-0.2/1000.*(Z0(KSTART)-Z0(ND)) -! -!...adjust downdraft TEMP, Q to specified RH: -! - IF(RHH.LT.1.)THEN - DSSDT=(CLIQ-BLIQ*DLIQ)/((TZ(ND)-DLIQ)*(TZ(ND)-DLIQ)) - RL=XLV0-XLV1*TZ(ND) - DTMP=RL*QSS*(1.-RHH)/(CP+RL*RHH*QSS*DSSDT) - T1RH=TZ(ND)+DTMP - ES=RHH*ALIQ*EXP((BLIQ*T1RH-CLIQ)/(T1RH-DLIQ)) - QSRH=0.622*ES/(P0(ND)-ES) -! -!...CHECK TO SEE IF MIXING RATIO AT SPECIFIED RH IS LESS THAN ACTUAL -!...MIXING RATIO...IF SO, ADJUST TO GIVE ZERO EVAPORATION... -! - IF(QSRH.LT.QD(ND))THEN - QSRH=QD(ND) - T1RH=TZ(ND)+(QSS-QSRH)*RL/CP - ENDIF - TZ(ND)=T1RH - QSS=QSRH - QSD(ND) = QSS - ENDIF - TVD(nd) = tz(nd)*(1.+0.608*qsd(nd)) - IF(TVD(ND).GT.TV0(ND).OR.ND.EQ.1)THEN - LDB=ND - EXIT - ENDIF - ENDDO - IF((P0(LDB)-P0(LFS)) .gt. 50.E2)THEN ! minimum Downdraft depth! - DO ND=LDT,LDB,-1 - ND1 = ND+1 - DDR(ND) = -DMF(KSTART)*DP(ND)/DPDD - DER(ND) = 0. - DMF(ND) = DMF(ND1)+DDR(ND) - TDER=TDER+(QSD(nd)-QD(ND))*DDR(ND) - QD(ND)=QSD(nd) - THTAD(ND)=TZ(ND)*(P00/P0(ND))**(0.2854*(1.-0.28*QD(ND))) - ENDDO - ENDIF - ENDIF - ENDIF devap -! -!...IF DOWNDRAFT DOES NOT EVAPORATE ANY WATER FOR SPECIFIED RELATIVE -!...HUMIDITY, NO DOWNDRAFT IS ALLOWED... -! -d_mf: IF(TDER.LT.1.)THEN -! WRITE(98,3004)I,J -!3004 FORMAT(' ','No Downdraft!; I=',I3,2X,'J=',I3,'ISHALL =',I2) - PPTFLX=TRPPT - CPR=TRPPT - TDER=0. - CNDTNF=0. - UPDINC=1. - LDB=LFS - DO NDK=1,LTOP - DMF(NDK)=0. - DER(NDK)=0. - DDR(NDK)=0. - THTAD(NDK)=0. - WD(NDK)=0. - TZ(NDK)=0. - QD(NDK)=0. - ENDDO - AINCM2=100. - ELSE - DDINC = -DMFFRC*UMF(KLCL)/DMF(KSTART) - UPDINC=1. - IF(TDER*DDINC.GT.TRPPT)THEN - DDINC = TRPPT/TDER - ENDIF - TDER = TDER*DDINC - DO NK=LDB,LFS - DMF(NK)=DMF(NK)*DDINC - DER(NK)=DER(NK)*DDINC - DDR(NK)=DDR(NK)*DDINC - ENDDO - CPR=TRPPT - PPTFLX = TRPPT-TDER - PEFF=PPTFLX/TRPPT - IF(IPRNT)THEN -! write(98,*)'PRECIP EFFICIENCY =',PEFF - write(message,*)'PRECIP EFFICIENCY =',PEFF - CALL wrf_message(message) -! call flush(98) - ENDIF -! -! -!...ADJUST UPDRAFT MASS FLUX, MASS DETRAINMENT RATE, AND LIQUID WATER AN -! DETRAINMENT RATES TO BE CONSISTENT WITH THE TRANSFER OF THE ESTIMATE -! FROM THE UPDRAFT TO THE DOWNDRAFT AT THE LFS... -! -! DO NK=LC,LFS -! UMF(NK)=UMF(NK)*UPDINC -! UDR(NK)=UDR(NK)*UPDINC -! UER(NK)=UER(NK)*UPDINC -! PPTLIQ(NK)=PPTLIQ(NK)*UPDINC -! PPTICE(NK)=PPTICE(NK)*UPDINC -! DETLQ(NK)=DETLQ(NK)*UPDINC -! DETIC(NK)=DETIC(NK)*UPDINC -! ENDDO -! -!...ZERO OUT THE ARRAYS FOR DOWNDRAFT DATA AT LEVELS ABOVE AND BELOW THE -!...DOWNDRAFT... -! - IF(LDB.GT.1)THEN - DO NK=1,LDB-1 - DMF(NK)=0. - DER(NK)=0. - DDR(NK)=0. - WD(NK)=0. - TZ(NK)=0. - QD(NK)=0. - THTAD(NK)=0. - ENDDO - ENDIF - DO NK=LFS+1,KX - DMF(NK)=0. - DER(NK)=0. - DDR(NK)=0. - WD(NK)=0. - TZ(NK)=0. - QD(NK)=0. - THTAD(NK)=0. - ENDDO - DO NK=LDT+1,LFS-1 - TZ(NK)=0. - QD(NK)=0. - THTAD(NK)=0. - ENDDO - ENDIF d_mf -! -!...SET LIMITS ON THE UPDRAFT AND DOWNDRAFT MASS FLUXES SO THAT THE INFL -! INTO CONVECTIVE DRAFTS FROM A GIVEN LAYER IS NO MORE THAN IS AVAILAB -! IN THAT LAYER INITIALLY... -! - AINCMX=1000. - LMAX=MAX0(KLCL,LFS) - DO NK=LC,LMAX - IF((UER(NK)-DER(NK)).GT.1.e-3)THEN - AINCM1=EMS(NK)/((UER(NK)-DER(NK))*TIMEC) - AINCMX=AMIN1(AINCMX,AINCM1) - ENDIF - ENDDO - AINC=1. - IF(AINCMX.LT.AINC)AINC=AINCMX -! -!...SAVE THE RELEVENT VARIABLES FOR A UNIT UPDRAFT AND DOWNDRAFT...THEY WILL -!...BE ITERATIVELY ADJUSTED BY THE FACTOR AINC TO SATISFY THE STABILIZATION -!...CLOSURE... -! - TDER2=TDER - PPTFL2=PPTFLX - DO NK=1,LTOP - DETLQ2(NK)=DETLQ(NK) - DETIC2(NK)=DETIC(NK) - UDR2(NK)=UDR(NK) - UER2(NK)=UER(NK) - DDR2(NK)=DDR(NK) - DER2(NK)=DER(NK) - UMF2(NK)=UMF(NK) - DMF2(NK)=DMF(NK) - ENDDO - FABE=1. - STAB=0.95 - NOITR=0 - ISTOP=0 -! - IF(ISHALL.EQ.1)THEN ! First for shallow convection -! -! No iteration for shallow convection; if turbulent kinetic energy (TKE) is available -! from a turbulence parameterization, scale cloud-base updraft mass flux as a function -! of TKE, but for now, just specify shallow-cloud mass flux using TKEMAX = 5... -! -!...find the maximum TKE value between LC and KLCL... -! TKEMAX = 0. - TKEMAX = 5. -! DO 173 K = LC,KLCL -! NK = KX-K+1 -! TKEMAX = AMAX1(TKEMAX,Q2(I,J,NK)) -! 173 CONTINUE -! TKEMAX = AMIN1(TKEMAX,10.) -! TKEMAX = AMAX1(TKEMAX,5.) -!c TKEMAX = 10. -!c...3_24_99...DPMIN was changed for shallow convection so that it is the -!c... the same as for deep convection (5.E3). Since this doubles -!c... (roughly) the value of DPTHMX, add a factor of 0.5 to calcu- -!c... lation of EVAC... -!c EVAC = TKEMAX*0.1 - EVAC = 0.5*TKEMAX*0.1 -! AINC = 0.1*DPTHMX*DXIJ*DXIJ/(VMFLCL*G*TIMEC) -! AINC = EVAC*DPTHMX*DX(I,J)*DX(I,J)/(VMFLCL*G*TIMEC) - AINC = EVAC*DPTHMX*DXSQ/(VMFLCL*G*TIMEC) - TDER=TDER2*AINC - PPTFLX=PPTFL2*AINC - DO NK=1,LTOP - UMF(NK)=UMF2(NK)*AINC - DMF(NK)=DMF2(NK)*AINC - DETLQ(NK)=DETLQ2(NK)*AINC - DETIC(NK)=DETIC2(NK)*AINC - UDR(NK)=UDR2(NK)*AINC - UER(NK)=UER2(NK)*AINC - DER(NK)=DER2(NK)*AINC - DDR(NK)=DDR2(NK)*AINC - ENDDO - ENDIF ! Otherwise for deep convection -! use iterative procedure to find mass fluxes... -iter: DO NCOUNT=1,10 -! -!***************************************************************** -! * -! COMPUTE PROPERTIES FOR COMPENSATIONAL SUBSIDENCE * -! * -!***************************************************************** -! -!...DETERMINE OMEGA VALUE NECESSARY AT TOP AND BOTTOM OF EACH LAYER TO -!...SATISFY MASS CONTINUITY... -! - DTT=TIMEC - DO NK=1,LTOP - DOMGDP(NK)=-(UER(NK)-DER(NK)-UDR(NK)-DDR(NK))*EMSD(NK) - IF(NK.GT.1)THEN - OMG(NK)=OMG(NK-1)-DP(NK-1)*DOMGDP(NK-1) - ABSOMG = ABS(OMG(NK)) - ABSOMGTC = ABSOMG*TIMEC - FRDP = 0.75*DP(NK-1) - IF(ABSOMGTC.GT.FRDP)THEN - DTT1 = FRDP/ABSOMG - DTT=AMIN1(DTT,DTT1) - ENDIF - ENDIF - ENDDO - DO NK=1,LTOP - THPA(NK)=THTA0(NK) - QPA(NK)=Q0(NK) - NSTEP=NINT(TIMEC/DTT+1) - DTIME=TIMEC/FLOAT(NSTEP) - FXM(NK)=OMG(NK)*DXSQ/G - ENDDO -! -!...DO AN UPSTREAM/FORWARD-IN-TIME ADVECTION OF THETA, QV... -! - DO NTC=1,NSTEP -! -!...ASSIGN THETA AND Q VALUES AT THE TOP AND BOTTOM OF EACH LAYER BASED -!...SIGN OF OMEGA... -! - DO NK=1,LTOP - THFXIN(NK)=0. - THFXOUT(NK)=0. - QFXIN(NK)=0. - QFXOUT(NK)=0. - ENDDO - DO NK=2,LTOP - IF(OMG(NK).LE.0.)THEN - THFXIN(NK)=-FXM(NK)*THPA(NK-1) - QFXIN(NK)=-FXM(NK)*QPA(NK-1) - THFXOUT(NK-1)=THFXOUT(NK-1)+THFXIN(NK) - QFXOUT(NK-1)=QFXOUT(NK-1)+QFXIN(NK) - ELSE - THFXOUT(NK)=FXM(NK)*THPA(NK) - QFXOUT(NK)=FXM(NK)*QPA(NK) - THFXIN(NK-1)=THFXIN(NK-1)+THFXOUT(NK) - QFXIN(NK-1)=QFXIN(NK-1)+QFXOUT(NK) - ENDIF - ENDDO -! -!...UPDATE THE THETA AND QV VALUES AT EACH LEVEL... -! - DO NK=1,LTOP - THPA(NK)=THPA(NK)+(THFXIN(NK)+UDR(NK)*THTAU(NK)+DDR(NK)* & - THTAD(NK)-THFXOUT(NK)-(UER(NK)-DER(NK))*THTA0(NK))* & - DTIME*EMSD(NK) - QPA(NK)=QPA(NK)+(QFXIN(NK)+UDR(NK)*QDT(NK)+DDR(NK)*QD(NK)- & - QFXOUT(NK)-(UER(NK)-DER(NK))*Q0(NK))*DTIME*EMSD(NK) - ENDDO - ENDDO - DO NK=1,LTOP - THTAG(NK)=THPA(NK) - QG(NK)=QPA(NK) - ENDDO -! -!...CHECK TO SEE IF MIXING RATIO DIPS BELOW ZERO ANYWHERE; IF SO, BORRO -!...MOISTURE FROM ADJACENT LAYERS TO BRING IT BACK UP ABOVE ZERO... -! - DO NK=1,LTOP - IF(QG(NK).LT.0.)THEN - IF(NK.EQ.1)THEN ! JSK MODS -! PRINT *,' PROBLEM WITH KF SCHEME: ' ! JSK MODS -! PRINT *,'QG = 0 AT THE SURFACE!!!!!!!' ! JSK MODS - CALL wrf_error_fatal ( 'QG, QG(NK).LT.0') ! JSK MODS - ENDIF ! JSK MODS - NK1=NK+1 - IF(NK.EQ.LTOP)THEN - NK1=KLCL - ENDIF - TMA=QG(NK1)*EMS(NK1) - TMB=QG(NK-1)*EMS(NK-1) - TMM=(QG(NK)-1.E-9)*EMS(NK ) - BCOEFF=-TMM/((TMA*TMA)/TMB+TMB) - ACOEFF=BCOEFF*TMA/TMB - TMB=TMB*(1.-BCOEFF) - TMA=TMA*(1.-ACOEFF) - IF(NK.EQ.LTOP)THEN - QVDIFF=(QG(NK1)-TMA*EMSD(NK1))*100./QG(NK1) -! IF(ABS(QVDIFF).GT.1.)THEN -! PRINT *,'!!!WARNING!!! CLOUD BASE WATER VAPOR CHANGES BY ', & -! QVDIFF, & -! '% WHEN MOISTURE IS BORROWED TO PREVENT NEGATIVE ', & -! 'VALUES IN KAIN-FRITSCH' -! ENDIF - ENDIF - QG(NK)=1.E-9 - QG(NK1)=TMA*EMSD(NK1) - QG(NK-1)=TMB*EMSD(NK-1) - ENDIF - ENDDO - TOPOMG=(UDR(LTOP)-UER(LTOP))*DP(LTOP)*EMSD(LTOP) - IF(ABS(TOPOMG-OMG(LTOP)).GT.1.E-3)THEN -! WRITE(99,*)'ERROR: MASS DOES NOT BALANCE IN KF SCHEME; & -! TOPOMG, OMG =',TOPOMG,OMG(LTOP) -! TOPOMG, OMG =',TOPOMG,OMG(LTOP) - ISTOP=1 - IPRNT=.TRUE. - EXIT iter - ENDIF -! -!...CONVERT THETA TO T... -! - DO NK=1,LTOP - EXN(NK)=(P00/P0(NK))**(0.2854*(1.-0.28*QG(NK))) - TG(NK)=THTAG(NK)/EXN(NK) - TVG(NK)=TG(NK)*(1.+0.608*QG(NK)) - ENDDO - IF(ISHALL.EQ.1)THEN - EXIT iter - ENDIF -! -!******************************************************************* -! * -! COMPUTE NEW CLOUD AND CHANGE IN AVAILABLE BUOYANT ENERGY. * -! * -!******************************************************************* -! -!...THE FOLLOWING COMPUTATIONS ARE SIMILAR TO THAT FOR UPDRAFT -! -! THMIX=0. - TMIX=0. - QMIX=0. -! -!...FIND THE THERMODYNAMIC CHARACTERISTICS OF THE LAYER BY -!...MASS-WEIGHTING THE CHARACTERISTICS OF THE INDIVIDUAL MODEL -!...LAYERS... -! - DO NK=LC,KPBL - TMIX=TMIX+DP(NK)*TG(NK) - QMIX=QMIX+DP(NK)*QG(NK) - ENDDO - TMIX=TMIX/DPTHMX - QMIX=QMIX/DPTHMX - ES=ALIQ*EXP((TMIX*BLIQ-CLIQ)/(TMIX-DLIQ)) - QSS=0.622*ES/(PMIX-ES) -! -!...REMOVE SUPERSATURATION FOR DIAGNOSTIC PURPOSES, IF NECESSARY... -! - IF(QMIX.GT.QSS)THEN - RL=XLV0-XLV1*TMIX - CPM=CP*(1.+0.887*QMIX) - DSSDT=QSS*(CLIQ-BLIQ*DLIQ)/((TMIX-DLIQ)*(TMIX-DLIQ)) - DQ=(QMIX-QSS)/(1.+RL*DSSDT/CPM) - TMIX=TMIX+RL/CP*DQ - QMIX=QMIX-DQ - TLCL=TMIX - ELSE - QMIX=AMAX1(QMIX,0.) - EMIX=QMIX*PMIX/(0.622+QMIX) - astrt=1.e-3 - binc=0.075 - a1=emix/aliq - tp=(a1-astrt)/binc - indlu=int(tp)+1 - value=(indlu-1)*binc+astrt - aintrp=(a1-value)/binc - tlog=aintrp*alu(indlu+1)+(1-aintrp)*alu(indlu) - TDPT=(CLIQ-DLIQ*TLOG)/(BLIQ-TLOG) - TLCL=TDPT-(.212+1.571E-3*(TDPT-T00)-4.36E-4*(TMIX-T00))*(TMIX-TDPT) - TLCL=AMIN1(TLCL,TMIX) - ENDIF - TVLCL=TLCL*(1.+0.608*QMIX) - ZLCL = ZMIX+(TLCL-TMIX)/GDRY - DO NK = LC,KL - KLCL=NK - IF(ZLCL.LE.Z0(NK))THEN - EXIT - ENDIF - ENDDO - K=KLCL-1 - DLP=(ZLCL-Z0(K))/(Z0(KLCL)-Z0(K)) -! -!...ESTIMATE ENVIRONMENTAL TEMPERATURE AND MIXING RATIO AT THE LCL... -! - TENV=TG(K)+(TG(KLCL)-TG(K))*DLP - QENV=QG(K)+(QG(KLCL)-QG(K))*DLP - TVEN=TENV*(1.+0.608*QENV) - PLCL=P0(K)+(P0(KLCL)-P0(K))*DLP - THETEU(K)=TMIX*(1.E5/PMIX)**(0.2854*(1.-0.28*QMIX))* & - EXP((3374.6525/TLCL-2.5403)*QMIX*(1.+0.81*QMIX)) -! -!...COMPUTE ADJUSTED ABE(ABEG). -! - ABEG=0. - DO NK=K,LTOPM1 - NK1=NK+1 - THETEU(NK1) = THETEU(NK) -! - call tpmix2dd(p0(nk1),theteu(nk1),tgu(nk1),qgu(nk1),i,j) -! - TVQU(NK1)=TGU(NK1)*(1.+0.608*QGU(NK1)-QLIQ(NK1)-QICE(NK1)) - IF(NK.EQ.K)THEN - DZZ=Z0(KLCL)-ZLCL - DILBE=((TVLCL+TVQU(NK1))/(TVEN+TVG(NK1))-1.)*DZZ - ELSE - DZZ=DZA(NK) - DILBE=((TVQU(NK)+TVQU(NK1))/(TVG(NK)+TVG(NK1))-1.)*DZZ - ENDIF - IF(DILBE.GT.0.)ABEG=ABEG+DILBE*G -! -!...DILUTE BY ENTRAINMENT BY THE RATE AS ORIGINAL UPDRAFT... -! - CALL ENVIRTHT(P0(NK1),TG(NK1),QG(NK1),THTEEG(NK1),ALIQ,BLIQ,CLIQ,DLIQ) - THETEU(NK1)=THETEU(NK1)*DDILFRC(NK1)+THTEEG(NK1)*(1.-DDILFRC(NK1)) - ENDDO -! -!...ASSUME AT LEAST 90% OF CAPE (ABE) IS REMOVED BY CONVECTION DURING -!...THE PERIOD TIMEC... -! - IF(NOITR.EQ.1)THEN -! write(98,*)' ' -! write(98,*)'TAU, I, J, =',NTSD,I,J -! WRITE(98,1060)FABE -! GOTO 265 - EXIT iter - ENDIF - DABE=AMAX1(ABE-ABEG,0.1*ABE) - FABE=ABEG/ABE - IF(FABE.GT.1. .and. ISHALL.EQ.0)THEN -! WRITE(98,*)'UPDRAFT/DOWNDRAFT COUPLET INCREASES CAPE AT THIS -! *GRID POINT; NO CONVECTION ALLOWED!' - RETURN - ENDIF - IF(NCOUNT.NE.1)THEN - IF(ABS(AINC-AINCOLD).LT.0.0001)THEN - NOITR=1 - AINC=AINCOLD - CYCLE iter - ENDIF - DFDA=(FABE-FABEOLD)/(AINC-AINCOLD) - IF(DFDA.GT.0.)THEN - NOITR=1 - AINC=AINCOLD - CYCLE iter - ENDIF - ENDIF - AINCOLD=AINC - FABEOLD=FABE - IF(AINC/AINCMX.GT.0.999.AND.FABE.GT.1.05-STAB)THEN -! write(98,*)' ' -! write(98,*)'TAU, I, J, =',NTSD,I,J -! WRITE(98,1055)FABE -! GOTO 265 - EXIT - ENDIF - IF((FABE.LE.1.05-STAB.AND.FABE.GE.0.95-STAB) .or. NCOUNT.EQ.10)THEN - EXIT iter - ELSE - IF(NCOUNT.GT.10)THEN -! write(98,*)' ' -! write(98,*)'TAU, I, J, =',NTSD,I,J -! WRITE(98,1060)FABE -! GOTO 265 - EXIT - ENDIF -! -!...IF MORE THAN 10% OF THE ORIGINAL CAPE REMAINS, INCREASE THE CONVECTI -!...MASS FLUX BY THE FACTOR AINC: -! - IF(FABE.EQ.0.)THEN - AINC=AINC*0.5 - ELSE - IF(DABE.LT.1.e-4)THEN - NOITR=1 - AINC=AINCOLD - CYCLE iter - ELSE - AINC=AINC*STAB*ABE/DABE - ENDIF - ENDIF -! AINC=AMIN1(AINCMX,AINC) - AINC=AMIN1(AINCMX,AINC) -!...IF AINC BECOMES VERY SMALL, EFFECTS OF CONVECTION ! JSK MODS -!...WILL BE MINIMAL SO JUST IGNORE IT... ! JSK MODS - IF(AINC.LT.0.05)then - RETURN ! JSK MODS - ENDIF -! AINC=AMAX1(AINC,0.05) ! JSK MODS - TDER=TDER2*AINC - PPTFLX=PPTFL2*AINC -! IF (XTIME.LT.10.)THEN -! WRITE(98,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT, -! * FABEOLD,AINCOLD -! ENDIF - DO NK=1,LTOP - UMF(NK)=UMF2(NK)*AINC - DMF(NK)=DMF2(NK)*AINC - DETLQ(NK)=DETLQ2(NK)*AINC - DETIC(NK)=DETIC2(NK)*AINC - UDR(NK)=UDR2(NK)*AINC - UER(NK)=UER2(NK)*AINC - DER(NK)=DER2(NK)*AINC - DDR(NK)=DDR2(NK)*AINC - ENDDO -! -!...GO BACK UP FOR ANOTHER ITERATION... -! - ENDIF - ENDDO iter -! -!...COMPUTE HYDROMETEOR TENDENCIES AS IS DONE FOR T, QV... -! -!...FRC2 IS THE FRACTION OF TOTAL CONDENSATE ! PPT FB MODS -!...GENERATED THAT GOES INTO PRECIPITIATION ! PPT FB MODS -! -! Redistribute hydormeteors according to the final mass-flux values: -! - IF(CPR.GT.0.)THEN - FRC2=PPTFLX/(CPR*AINC) ! PPT FB MODS - ELSE - FRC2=0. - ENDIF - DO NK=1,LTOP - QLPA(NK)=QL0(NK) - QIPA(NK)=QI0(NK) - QRPA(NK)=QR0(NK) - QSPA(NK)=QS0(NK) - RAINFB(NK)=PPTLIQ(NK)*AINC*FBFRC*FRC2 ! PPT FB MODS - SNOWFB(NK)=PPTICE(NK)*AINC*FBFRC*FRC2 ! PPT FB MODS - ENDDO - DO NTC=1,NSTEP -! -!...ASSIGN HYDROMETEORS CONCENTRATIONS AT THE TOP AND BOTTOM OF EACH LAY -!...BASED ON THE SIGN OF OMEGA... -! - DO NK=1,LTOP - QLFXIN(NK)=0. - QLFXOUT(NK)=0. - QIFXIN(NK)=0. - QIFXOUT(NK)=0. - QRFXIN(NK)=0. - QRFXOUT(NK)=0. - QSFXIN(NK)=0. - QSFXOUT(NK)=0. - ENDDO - DO NK=2,LTOP - IF(OMG(NK).LE.0.)THEN - QLFXIN(NK)=-FXM(NK)*QLPA(NK-1) - QIFXIN(NK)=-FXM(NK)*QIPA(NK-1) - QRFXIN(NK)=-FXM(NK)*QRPA(NK-1) - QSFXIN(NK)=-FXM(NK)*QSPA(NK-1) - QLFXOUT(NK-1)=QLFXOUT(NK-1)+QLFXIN(NK) - QIFXOUT(NK-1)=QIFXOUT(NK-1)+QIFXIN(NK) - QRFXOUT(NK-1)=QRFXOUT(NK-1)+QRFXIN(NK) - QSFXOUT(NK-1)=QSFXOUT(NK-1)+QSFXIN(NK) - ELSE - QLFXOUT(NK)=FXM(NK)*QLPA(NK) - QIFXOUT(NK)=FXM(NK)*QIPA(NK) - QRFXOUT(NK)=FXM(NK)*QRPA(NK) - QSFXOUT(NK)=FXM(NK)*QSPA(NK) - QLFXIN(NK-1)=QLFXIN(NK-1)+QLFXOUT(NK) - QIFXIN(NK-1)=QIFXIN(NK-1)+QIFXOUT(NK) - QRFXIN(NK-1)=QRFXIN(NK-1)+QRFXOUT(NK) - QSFXIN(NK-1)=QSFXIN(NK-1)+QSFXOUT(NK) - ENDIF - ENDDO -! -!...UPDATE THE HYDROMETEOR CONCENTRATION VALUES AT EACH LEVEL... -! - DO NK=1,LTOP - QLPA(NK)=QLPA(NK)+(QLFXIN(NK)+DETLQ(NK)-QLFXOUT(NK))*DTIME*EMSD(NK) - QIPA(NK)=QIPA(NK)+(QIFXIN(NK)+DETIC(NK)-QIFXOUT(NK))*DTIME*EMSD(NK) - QRPA(NK)=QRPA(NK)+(QRFXIN(NK)-QRFXOUT(NK)+RAINFB(NK))*DTIME*EMSD(NK) ! PPT FB MODS - QSPA(NK)=QSPA(NK)+(QSFXIN(NK)-QSFXOUT(NK)+SNOWFB(NK))*DTIME*EMSD(NK) ! PPT FB MODS - ENDDO - ENDDO - DO NK=1,LTOP - QLG(NK)=QLPA(NK) - QIG(NK)=QIPA(NK) - QRG(NK)=QRPA(NK) - QSG(NK)=QSPA(NK) - ENDDO -! -!...CLEAN THINGS UP, CALCULATE CONVECTIVE FEEDBACK TENDENCIES FOR THIS -!...GRID POINT... -! -! IF (XTIME.LT.10.)THEN -! WRITE(98,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT,FABE,AINC -! ENDIF - IF(IPRNT)THEN -! WRITE(98,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT,FABE,AINC - WRITE(message,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT,FABE,AINC - CALL wrf_message(message) -! call flush(98) - endif -! -!...SEND FINAL PARAMETERIZED VALUES TO OUTPUT FILES... -! -!297 IF(IPRNT)then - IF(IPRNT)then -! if(I.eq.16 .and. J.eq.41)then -! IF(ISTOP.EQ.1)THEN - write(98,*) -! write(98,*)'At t(h), I, J =',float(NTSD)*72./3600.,I,J - write(message,*)'P(LC), DTP, WKL, WKLCL =',p0(LC)/100., & - TLCL+DTLCL+dtrh-TENV,WKL,WKLCL - call wrf_message(message) - write(message,*)'TLCL, DTLCL, DTRH, TENV =',TLCL,DTLCL, & - DTRH,TENV - call wrf_message(message) - WRITE(message,1025)KLCL,ZLCL,DTLCL,LTOP,P0(LTOP),IFLAG, & - TMIX-T00,PMIX,QMIX,ABE - call wrf_message(message) - WRITE(message,1030)P0(LET)/100.,P0(LTOP)/100.,VMFLCL,PLCL/100., & - WLCL,CLDHGT(LC) - call wrf_message(message) - WRITE(message,1035)PEF,PEFCBH,LC,LET,WKL,VWS - call wrf_message(message) - write(message,*)'PRECIP EFFICIENCY =',PEFF - call wrf_message(message) - WRITE(message,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT,FABE,AINC - call wrf_message(message) -! ENDIF -!!!!! HERE !!!!!!! - WRITE(message,1070)' P ',' DP ',' DT K/D ',' DR K/D ',' OMG ', & - ' DOMGDP ',' UMF ',' UER ',' UDR ',' DMF ',' DER ' & - ,' DDR ',' EMS ',' W0 ',' DETLQ ',' DETIC ' - call wrf_message(message) - write(message,*)'just before DO 300...' - call wrf_message(message) -! call flush(98) - DO NK=1,LTOP - K=LTOP-NK+1 - DTT=(TG(K)-T0(K))*86400./TIMEC - RL=XLV0-XLV1*TG(K) - DR=-(QG(K)-Q0(K))*RL*86400./(TIMEC*CP) - UDFRC=UDR(K)*TIMEC*EMSD(K) - UEFRC=UER(K)*TIMEC*EMSD(K) - DDFRC=DDR(K)*TIMEC*EMSD(K) - DEFRC=-DER(K)*TIMEC*EMSD(K) - WRITE(message,1075)P0(K)/100.,DP(K)/100.,DTT,DR,OMG(K),DOMGDP(K)*1.E4, & - UMF(K)/1.E6,UEFRC,UDFRC,DMF(K)/1.E6,DEFRC,DDFRC,EMS(K)/1.E11, & - W0AVG1D(K)*1.E2,DETLQ(K)*TIMEC*EMSD(K)*1.E3,DETIC(K)* & - TIMEC*EMSD(K)*1.E3 - call wrf_message(message) - ENDDO - WRITE(message,1085)'K','P','Z','T0','TG','DT','TU','TD','Q0','QG', & - 'DQ','QU','QD','QLG','QIG','QRG','QSG','RH0','RHG' - call wrf_message(message) - DO NK=1,KL - K=KX-NK+1 - DTT=TG(K)-T0(K) - TUC=TU(K)-T00 - IF(K.LT.LC.OR.K.GT.LTOP)TUC=0. - TDC=TZ(K)-T00 - IF((K.LT.LDB.OR.K.GT.LDT).AND.K.NE.LFS)TDC=0. - IF(T0(K).LT.T00)THEN - ES=ALIQ*EXP((BLIQ*TG(K)-CLIQ)/(TG(K)-DLIQ)) - ELSE - ES=ALIQ*EXP((BLIQ*TG(K)-CLIQ)/(TG(K)-DLIQ)) - ENDIF - QGS=ES*0.622/(P0(K)-ES) - RH0=Q0(K)/QES(K) - RHG=QG(K)/QGS - WRITE(message,1090)K,P0(K)/100.,Z0(K),T0(K)-T00,TG(K)-T00,DTT,TUC, & - TDC,Q0(K)*1000.,QG(K)*1000.,(QG(K)-Q0(K))*1000.,QU(K)* & - 1000.,QD(K)*1000.,QLG(K)*1000.,QIG(K)*1000.,QRG(K)*1000., & - QSG(K)*1000.,RH0,RHG - call wrf_message(message) - ENDDO -! -!...IF CALCULATIONS ABOVE SHOW AN ERROR IN THE MASS BUDGET, PRINT OUT A -!...TO BE USED LATER FOR DIAGNOSTIC PURPOSES, THEN ABORT RUN... -! -! IF(ISTOP.EQ.1 .or. ISHALL.EQ.1)THEN - -! IF(ISHALL.NE.1)THEN -! write(98,4421)i,j,iyr,imo,idy,ihr,imn -! write(98)i,j,iyr,imo,idy,ihr,imn,kl -! 4421 format(7i4) -! write(98,4422)kl -! 4422 format(i6) - DO 310 NK = 1,KL - k = kl - nk + 1 - write(98,4455) p0(k)/100.,t0(k)-273.16,q0(k)*1000., & - u0(k),v0(k),W0AVG1D(K),dp(k),tke(k) -! write(98) p0,t0,q0,u0,v0,w0,dp,tke -! WRITE(98,1115)Z0(K),P0(K)/100.,T0(K)-273.16,Q0(K)*1000., -! * U0(K),V0(K),DP(K)/100.,W0AVG(I,J,K) - 310 CONTINUE - IF(ISTOP.EQ.1)THEN - CALL wrf_error_fatal ( 'KAIN-FRITSCH, istop=1, diags' ) - ENDIF -! ENDIF - 4455 format(8f11.3) - ENDIF - CNDTNF=(1.-EQFRC(LFS))*(QLIQ(LFS)+QICE(LFS))*DMF(LFS) - PRATEC(I,J)=PPTFLX*(1.-FBFRC)/DXSQ - RAINCV(I,J)=DT*PRATEC(I,J) ! PPT FB MODS -! RAINCV(I,J)=.1*.5*DT*PPTFLX/DXSQ ! PPT FB MODS -! RNC=0.1*TIMEC*PPTFLX/DXSQ - RNC=RAINCV(I,J)*NIC - IF(ISHALL.EQ.0.AND.IPRNT)write (98,909)I,J,RNC - -! WRITE(98,1095)CPR*AINC,TDER+PPTFLX+CNDTNF -! -! EVALUATE MOISTURE BUDGET... -! - - QINIT=0. - QFNL=0. - DPT=0. - DO 315 NK=1,LTOP - DPT=DPT+DP(NK) - QINIT=QINIT+Q0(NK)*EMS(NK) - QFNL=QFNL+QG(NK)*EMS(NK) - QFNL=QFNL+(QLG(NK)+QIG(NK)+QRG(NK)+QSG(NK))*EMS(NK) - 315 CONTINUE - QFNL=QFNL+PPTFLX*TIMEC*(1.-FBFRC) ! PPT FB MODS -! QFNL=QFNL+PPTFLX*TIMEC ! PPT FB MODS - ERR2=(QFNL-QINIT)*100./QINIT - IF(IPRNT)WRITE(98,1110)QINIT,QFNL,ERR2 - IF(ABS(ERR2).GT.0.05 .AND. ISTOP.EQ.0)THEN -! write(99,*)'!!!!!!!! MOISTURE BUDGET ERROR IN KFPARA !!!' -! WRITE(99,1110)QINIT,QFNL,ERR2 - IPRNT=.TRUE. - ISTOP=1 - write(98,4422)kl - 4422 format(i6) - DO 311 NK = 1,KL - k = kl - nk + 1 -! write(99,4455) p0(k)/100.,t0(k)-273.16,q0(k)*1000., & -! u0(k),v0(k),W0AVG1D(K),dp(k) -! write(98) p0,t0,q0,u0,v0,w0,dp,tke -! WRITE(98,1115)P0(K)/100.,T0(K)-273.16,Q0(K)*1000., & -! U0(K),V0(K),W0AVG1D(K),dp(k)/100.,tke(k) - WRITE(98,4456)P0(K)/100.,T0(K)-273.16,Q0(K)*1000., & - U0(K),V0(K),W0AVG1D(K),dp(k)/100.,tke(k) - 311 CONTINUE -! call flush(98) - -! GOTO 297 -! STOP 'QVERR' - ENDIF - 1115 FORMAT (2X,F7.2,2X,F5.1,2X,F6.3,2(2X,F5.1),2X,F7.2,2X,F7.4) - 4456 format(8f12.3) - IF(PPTFLX.GT.0.)THEN - RELERR=ERR2*QINIT/(PPTFLX*TIMEC) - ELSE - RELERR=0. - ENDIF - IF(IPRNT)THEN - WRITE(98,1120)RELERR - WRITE(98,*)'TDER, CPR, TRPPT =', & - TDER,CPR*AINC,TRPPT*AINC - ENDIF -! -!...FEEDBACK TO RESOLVABLE SCALE TENDENCIES. -! -!...IF THE ADVECTIVE TIME PERIOD (TADVEC) IS LESS THAN SPECIFIED MINIMUM -!...TIMEC, ALLOW FEEDBACK TO OCCUR ONLY DURING TADVEC... -! - IF(TADVEC.LT.TIMEC)NIC=NINT(TADVEC/DT) - NCA(I,J) = REAL(NIC)*DT - IF(ISHALL.EQ.1)THEN - TIMEC = 2400. - NCA(I,J) = CUDT*60. - NSHALL = NSHALL+1 - ENDIF - - DO K=1,KX -! IF(IMOIST(INEST).NE.2)THEN -! -!...IF HYDROMETEORS ARE NOT ALLOWED, THEY MUST BE EVAPORATED OR SUBLIMAT -!...AND FED BACK AS VAPOR, ALONG WITH ASSOCIATED CHANGES IN TEMPERATURE. -!...NOTE: THIS WILL INTRODUCE CHANGES IN THE CONVECTIVE TEMPERATURE AND -!...WATER VAPOR FEEDBACK TENDENCIES AND MAY LEAD TO SUPERSATURATED VALUE -!...OF QG... -! -! RLC=XLV0-XLV1*TG(K) -! RLS=XLS0-XLS1*TG(K) -! CPM=CP*(1.+0.887*QG(K)) -! TG(K)=TG(K)-(RLC*(QLG(K)+QRG(K))+RLS*(QIG(K)+QSG(K)))/CPM -! QG(K)=QG(K)+(QLG(K)+QRG(K)+QIG(K)+QSG(K)) -! DQLDT(I,J,NK)=0. -! DQIDT(I,J,NK)=0. -! DQRDT(I,J,NK)=0. -! DQSDT(I,J,NK)=0. -! ELSE -! -!...IF ICE PHASE IS NOT ALLOWED, MELT ALL FROZEN HYDROMETEORS... -! - IF(.NOT. F_QI .and. warm_rain)THEN - - CPM=CP*(1.+0.887*QG(K)) - TG(K)=TG(K)-(QIG(K)+QSG(K))*RLF/CPM - DQCDT(K)=(QLG(K)+QIG(K)-QL0(K)-QI0(K))/TIMEC - DQIDT(K)=0. - DQRDT(K)=(QRG(K)+QSG(K)-QR0(K)-QS0(K))/TIMEC - DQSDT(K)=0. - ELSEIF(.NOT. F_QI .and. .not. warm_rain)THEN -! -!...IF ICE PHASE IS ALLOWED, BUT MIXED PHASE IS NOT, MELT FROZEN HYDROME -!...BELOW THE MELTING LEVEL, FREEZE LIQUID WATER ABOVE THE MELTING LEVEL -! - CPM=CP*(1.+0.887*QG(K)) - IF(K.LE.ML)THEN - TG(K)=TG(K)-(QIG(K)+QSG(K))*RLF/CPM - ELSEIF(K.GT.ML)THEN - TG(K)=TG(K)+(QLG(K)+QRG(K))*RLF/CPM - ENDIF - DQCDT(K)=(QLG(K)+QIG(K)-QL0(K)-QI0(K))/TIMEC - DQIDT(K)=0. - DQRDT(K)=(QRG(K)+QSG(K)-QR0(K)-QS0(K))/TIMEC - DQSDT(K)=0. - ELSEIF(F_QI) THEN -! -!...IF MIXED PHASE HYDROMETEORS ARE ALLOWED, FEED BACK CONVECTIVE TENDEN -!...OF HYDROMETEORS DIRECTLY... -! - DQCDT(K)=(QLG(K)-QL0(K))/TIMEC - DQIDT(K)=(QIG(K)-QI0(K))/TIMEC - DQRDT(K)=(QRG(K)-QR0(K))/TIMEC - IF (F_QS) THEN - DQSDT(K)=(QSG(K)-QS0(K))/TIMEC - ELSE - DQIDT(K)=DQIDT(K)+(QSG(K)-QS0(K))/TIMEC - ENDIF - ELSE -! PRINT *,'THIS COMBINATION OF IMOIST, IEXICE, IICE NOT ALLOWED!' - CALL wrf_error_fatal ( 'KAIN-FRITSCH, THIS COMBINATION OF IMOIST, IEXICE, IICE NOT ALLOWED' ) - ENDIF - DTDT(K)=(TG(K)-T0(K))/TIMEC - DQDT(K)=(QG(K)-Q0(K))/TIMEC - ENDDO - PRATEC(I,J)=PPTFLX*(1.-FBFRC)/DXSQ - RAINCV(I,J)=DT*PRATEC(I,J) -! RAINCV(I,J)=.1*.5*DT*PPTFLX/DXSQ ! PPT FB MODS -! RNC=0.1*TIMEC*PPTFLX/DXSQ - RNC=RAINCV(I,J)*NIC - 909 FORMAT('AT I, J =',i3,1x,i3,' CONVECTIVE RAINFALL =',F8.4,' mm') -! write (98,909)I,J,RNC -! write (6,909)I,J,RNC -! WRITE(98,*)'at NTSD =',NTSD,',No. of KF points activated =', -! * NCCNT -! call flush(98) -1000 FORMAT(' ',10A8) -1005 FORMAT(' ',F6.0,2X,F6.4,2X,F7.3,1X,F6.4,2X,4(F6.3,2X),2(F7.3,1X)) -1010 FORMAT(' ',' VERTICAL VELOCITY IS NEGATIVE AT ',F4.0,' MB') -1015 FORMAT(' ','ALL REMAINING MASS DETRAINS BELOW ',F4.0,' MB') -1025 FORMAT(5X,' KLCL=',I2,' ZLCL=',F7.1,'M', & - ' DTLCL=',F5.2,' LTOP=',I2,' P0(LTOP)=',-2PF5.1,'MB FRZ LV=', & - I2,' TMIX=',0PF4.1,1X,'PMIX=',-2PF6.1,' QMIX=',3PF5.1, & - ' CAPE=',0PF7.1) -1030 FORMAT(' ',' P0(LET) = ',F6.1,' P0(LTOP) = ',F6.1,' VMFLCL =', & - E12.3,' PLCL =',F6.1,' WLCL =',F6.3,' CLDHGT =', & - F8.1) -1035 FORMAT(1X,'PEF(WS)=',F4.2,'(CB)=',F4.2,'LC,LET=',2I3,'WKL=' & - ,F6.3,'VWS=',F5.2) -!1055 FORMAT('*** DEGREE OF STABILIZATION =',F5.3, & -! ', NO MORE MASS FLUX IS ALLOWED!') -!1060 FORMAT(' ITERATION DOES NOT CONVERGE TO GIVE THE SPECIFIED & -! &DEGREE OF STABILIZATION! FABE= ',F6.4) - 1070 FORMAT (16A8) - 1075 FORMAT (F8.2,3(F8.2),2(F8.3),F8.2,2F8.3,F8.2,6F8.3) - 1080 FORMAT(2X,'LFS,LDB,LDT =',3I3,' TIMEC, TADVEC, NSTEP=', & - 2(1X,F5.0),I3,'NCOUNT, FABE, AINC=',I2,1X,F5.3,F6.2) - 1085 FORMAT (A3,16A7,2A8) - 1090 FORMAT (I3,F7.2,F7.0,10F7.2,4F7.3,2F8.3) - 1095 FORMAT(' ',' PPT PRODUCTION RATE= ',F10.0,' TOTAL EVAP+PPT= ',F10.0) -1105 FORMAT(' ','NET LATENT HEAT RELEASE =',E12.5,' ACTUAL HEATING =',& - E12.5,' J/KG-S, DIFFERENCE = ',F9.3,'%') -1110 FORMAT(' ','INITIAL WATER =',E12.5,' FINAL WATER =',E12.5, & - ' TOTAL WATER CHANGE =',F8.2,'%') -! 1115 FORMAT (2X,F6.0,2X,F7.2,2X,F5.1,2X,F6.3,2(2X,F5.1),2X,F7.2,2X,F7.4) -1120 FORMAT(' ','MOISTURE ERROR AS FUNCTION OF TOTAL PPT =',F9.3,'%') -! -!----------------------------------------------------------------------- -!--------------SAVE CLOUD TOP AND BOTTOM FOR RADIATION------------------ -!----------------------------------------------------------------------- -! - CUTOP(I,J)=REAL(LTOP) - CUBOT(I,J)=REAL(LCL) -! -!----------------------------------------------------------------------- - END SUBROUTINE KF_eta_PARA -!******************************************************************** -! *********************************************************************** - SUBROUTINE TPMIX2(p,thes,tu,qu,qliq,qice,qnewlq,qnewic,XLV1,XLV0) -! -! Lookup table variables: -! INTEGER, PARAMETER :: (KFNT=250,KFNP=220) -! REAL, SAVE, DIMENSION(1:KFNT,1:KFNP) :: TTAB,QSTAB -! REAL, SAVE, DIMENSION(1:KFNP) :: THE0K -! REAL, SAVE, DIMENSION(1:200) :: ALU -! REAL, SAVE :: RDPR,RDTHK,PLUTOP -! End of Lookup table variables: -!----------------------------------------------------------------------- - IMPLICIT NONE -!----------------------------------------------------------------------- - REAL, INTENT(IN ) :: P,THES,XLV1,XLV0 - REAL, INTENT(OUT ) :: QNEWLQ,QNEWIC - REAL, INTENT(INOUT) :: TU,QU,QLIQ,QICE - REAL :: TP,QQ,BTH,TTH,PP,T00,T10,T01,T11,Q00,Q10,Q01,Q11, & - TEMP,QS,QNEW,DQ,QTOT,RLL,CPP - INTEGER :: IPTB,ITHTB -!----------------------------------------------------------------------- - -!c******** LOOKUP TABLE VARIABLES... **************************** -! parameter(kfnt=250,kfnp=220) -!c -! COMMON/KFLUT/ ttab(kfnt,kfnp),qstab(kfnt,kfnp),the0k(kfnp), -! * alu(200),rdpr,rdthk,plutop -!C*************************************************************** -!c -!c*********************************************************************** -!c scaling pressure and tt table index -!c*********************************************************************** -!c - tp=(p-plutop)*rdpr - qq=tp-aint(tp) - iptb=int(tp)+1 - -! -!*********************************************************************** -! base and scaling factor for the -!*********************************************************************** -! -! scaling the and tt table index - bth=(the0k(iptb+1)-the0k(iptb))*qq+the0k(iptb) - tth=(thes-bth)*rdthk - pp =tth-aint(tth) - ithtb=int(tth)+1 - IF(IPTB.GE.220 .OR. IPTB.LE.1 .OR. ITHTB.GE.250 .OR. ITHTB.LE.1)THEN - write(98,*)'**** OUT OF BOUNDS *********' -! call flush(98) - ENDIF -! - t00=ttab(ithtb ,iptb ) - t10=ttab(ithtb+1,iptb ) - t01=ttab(ithtb ,iptb+1) - t11=ttab(ithtb+1,iptb+1) -! - q00=qstab(ithtb ,iptb ) - q10=qstab(ithtb+1,iptb ) - q01=qstab(ithtb ,iptb+1) - q11=qstab(ithtb+1,iptb+1) -! -!*********************************************************************** -! parcel temperature -!*********************************************************************** -! - temp=(t00+(t10-t00)*pp+(t01-t00)*qq+(t00-t10-t01+t11)*pp*qq) -! - qs=(q00+(q10-q00)*pp+(q01-q00)*qq+(q00-q10-q01+q11)*pp*qq) -! - DQ=QS-QU - IF(DQ.LE.0.)THEN - QNEW=QU-QS - QU=QS - ELSE -! -! IF THE PARCEL IS SUBSATURATED, TEMPERATURE AND MIXING RATIO MUST BE -! ADJUSTED...IF LIQUID WATER IS PRESENT, IT IS ALLOWED TO EVAPORATE -! - QNEW=0. - QTOT=QLIQ+QICE -! -! IF THERE IS ENOUGH LIQUID OR ICE TO SATURATE THE PARCEL, TEMP STAYS AT ITS -! WET BULB VALUE, VAPOR MIXING RATIO IS AT SATURATED LEVEL, AND THE MIXING -! RATIOS OF LIQUID AND ICE ARE ADJUSTED TO MAKE UP THE ORIGINAL SATURATION -! DEFICIT... OTHERWISE, ANY AVAILABLE LIQ OR ICE VAPORIZES AND APPROPRIATE -! ADJUSTMENTS TO PARCEL TEMP; VAPOR, LIQUID, AND ICE MIXING RATIOS ARE MADE. -! -!...subsaturated values only occur in calculations involving various mixtures of -!...updraft and environmental air for estimation of entrainment and detrainment. -!...For these purposes, assume that reasonable estimates can be given using -!...liquid water saturation calculations only - i.e., ignore the effect of the -!...ice phase in this process only...will not affect conservative properties... -! - IF(QTOT.GE.DQ)THEN - qliq=qliq-dq*qliq/(qtot+1.e-10) - qice=qice-dq*qice/(qtot+1.e-10) - QU=QS - ELSE - RLL=XLV0-XLV1*TEMP - CPP=1004.5*(1.+0.89*QU) - IF(QTOT.LT.1.E-10)THEN -! -!...IF NO LIQUID WATER OR ICE IS AVAILABLE, TEMPERATURE IS GIVEN BY: - TEMP=TEMP+RLL*(DQ/(1.+DQ))/CPP - ELSE -! -!...IF SOME LIQ WATER/ICE IS AVAILABLE, BUT NOT ENOUGH TO ACHIEVE SATURATION, -! THE TEMPERATURE IS GIVEN BY: -! - TEMP=TEMP+RLL*((DQ-QTOT)/(1+DQ-QTOT))/CPP - QU=QU+QTOT - QTOT=0. - QLIQ=0. - QICE=0. - ENDIF - ENDIF - ENDIF - TU=TEMP - qnewlq=qnew - qnewic=0. -! - END SUBROUTINE TPMIX2 -!****************************************************************************** - SUBROUTINE DTFRZNEW(TU,P,THTEU,QU,QFRZ,QICE,ALIQ,BLIQ,CLIQ,DLIQ) -!----------------------------------------------------------------------- - IMPLICIT NONE -!----------------------------------------------------------------------- - REAL, INTENT(IN ) :: P,QFRZ,ALIQ,BLIQ,CLIQ,DLIQ - REAL, INTENT(INOUT) :: TU,THTEU,QU,QICE - REAL :: RLC,RLS,RLF,CPP,A,DTFRZ,ES,QS,DQEVAP,PII -!----------------------------------------------------------------------- -! -!...ALLOW THE FREEZING OF LIQUID WATER IN THE UPDRAFT TO PROCEED AS AN -!...APPROXIMATELY LINEAR FUNCTION OF TEMPERATURE IN THE TEMPERATURE RANGE -!...TTFRZ TO TBFRZ... -!...FOR COLDER TERMPERATURES, FREEZE ALL LIQUID WATER... -!...THERMODYNAMIC PROPERTIES ARE STILL CALCULATED WITH RESPECT TO LIQUID WATER -!...TO ALLOW THE USE OF LOOKUP TABLE TO EXTRACT TMP FROM THETAE... -! - RLC=2.5E6-2369.276*(TU-273.16) - RLS=2833922.-259.532*(TU-273.16) - RLF=RLS-RLC - CPP=1004.5*(1.+0.89*QU) -! -! A = D(es)/DT IS THAT CALCULATED FROM BUCK (1981) EMPERICAL FORMULAS -! FOR SATURATION VAPOR PRESSURE... -! - A=(CLIQ-BLIQ*DLIQ)/((TU-DLIQ)*(TU-DLIQ)) - DTFRZ = RLF*QFRZ/(CPP+RLS*QU*A) - TU = TU+DTFRZ - - ES = ALIQ*EXP((BLIQ*TU-CLIQ)/(TU-DLIQ)) - QS = ES*0.622/(P-ES) -! -!...FREEZING WARMS THE AIR AND IT BECOMES UNSATURATED...ASSUME THAT SOME OF THE -!...LIQUID WATER THAT IS AVAILABLE FOR FREEZING EVAPORATES TO MAINTAIN SATURA- -!...TION...SINCE THIS WATER HAS ALREADY BEEN TRANSFERRED TO THE ICE CATEGORY, -!...SUBTRACT IT FROM ICE CONCENTRATION, THEN SET UPDRAFT MIXING RATIO AT THE NEW -!...TEMPERATURE TO THE SATURATION VALUE... -! - DQEVAP = QS-QU - QICE = QICE-DQEVAP - QU = QU+DQEVAP - PII=(1.E5/P)**(0.2854*(1.-0.28*QU)) - THTEU=TU*PII*EXP((3374.6525/TU-2.5403)*QU*(1.+0.81*QU)) -! - END SUBROUTINE DTFRZNEW -! -------------------------------------------------------------------------------- - - SUBROUTINE CONDLOAD(QLIQ,QICE,WTW,DZ,BOTERM,ENTERM,RATE,QNEWLQ, & - QNEWIC,QLQOUT,QICOUT,G) - -!----------------------------------------------------------------------- - IMPLICIT NONE -!----------------------------------------------------------------------- -! 9/18/88...THIS PRECIPITATION FALLOUT SCHEME IS BASED ON THE SCHEME US -! BY OGURA AND CHO (1973). LIQUID WATER FALLOUT FROM A PARCEL IS CAL- -! CULATED USING THE EQUATION DQ=-RATE*Q*DT, BUT TO SIMULATE A QUASI- -! CONTINUOUS PROCESS, AND TO ELIMINATE A DEPENDENCY ON VERTICAL -! RESOLUTION THIS IS EXPRESSED AS Q=Q*EXP(-RATE*DZ). - - REAL, INTENT(IN ) :: G - REAL, INTENT(IN ) :: DZ,BOTERM,ENTERM,RATE - REAL, INTENT(INOUT) :: QLQOUT,QICOUT,WTW,QLIQ,QICE,QNEWLQ,QNEWIC - REAL :: QTOT,QNEW,QEST,G1,WAVG,CONV,RATIO3,OLDQ,RATIO4,DQ,PPTDRG - -! -! 9/18/88...THIS PRECIPITATION FALLOUT SCHEME IS BASED ON THE SCHEME US -! BY OGURA AND CHO (1973). LIQUID WATER FALLOUT FROM A PARCEL IS CAL- -! CULATED USING THE EQUATION DQ=-RATE*Q*DT, BUT TO SIMULATE A QUASI- -! CONTINUOUS PROCESS, AND TO ELIMINATE A DEPENDENCY ON VERTICAL -! RESOLUTION THIS IS EXPRESSED AS Q=Q*EXP(-RATE*DZ). - QTOT=QLIQ+QICE - QNEW=QNEWLQ+QNEWIC -! -! ESTIMATE THE VERTICAL VELOCITY SO THAT AN AVERAGE VERTICAL VELOCITY -! BE CALCULATED TO ESTIMATE THE TIME REQUIRED FOR ASCENT BETWEEN MODEL -! LEVELS... -! - QEST=0.5*(QTOT+QNEW) - G1=WTW+BOTERM-ENTERM-2.*G*DZ*QEST/1.5 - IF(G1.LT.0.0)G1=0. - WAVG=0.5*(SQRT(WTW)+SQRT(G1)) - CONV=RATE*DZ/WAVG -! -! RATIO3 IS THE FRACTION OF LIQUID WATER IN FRESH CONDENSATE, RATIO4 IS -! THE FRACTION OF LIQUID WATER IN THE TOTAL AMOUNT OF CONDENSATE INVOLV -! IN THE PRECIPITATION PROCESS - NOTE THAT ONLY 60% OF THE FRESH CONDEN -! SATE IS IS ALLOWED TO PARTICIPATE IN THE CONVERSION PROCESS... -! - RATIO3=QNEWLQ/(QNEW+1.E-8) -! OLDQ=QTOT - QTOT=QTOT+0.6*QNEW - OLDQ=QTOT - RATIO4=(0.6*QNEWLQ+QLIQ)/(QTOT+1.E-8) - QTOT=QTOT*EXP(-CONV) -! -! DETERMINE THE AMOUNT OF PRECIPITATION THAT FALLS OUT OF THE UPDRAFT -! PARCEL AT THIS LEVEL... -! - DQ=OLDQ-QTOT - QLQOUT=RATIO4*DQ - QICOUT=(1.-RATIO4)*DQ -! -! ESTIMATE THE MEAN LOAD OF CONDENSATE ON THE UPDRAFT IN THE LAYER, CAL -! LATE VERTICAL VELOCITY -! - PPTDRG=0.5*(OLDQ+QTOT-0.2*QNEW) - WTW=WTW+BOTERM-ENTERM-2.*G*DZ*PPTDRG/1.5 - IF(ABS(WTW).LT.1.E-4)WTW=1.E-4 -! -! DETERMINE THE NEW LIQUID WATER AND ICE CONCENTRATIONS INCLUDING LOSSE -! DUE TO PRECIPITATION AND GAINS FROM CONDENSATION... -! - QLIQ=RATIO4*QTOT+RATIO3*0.4*QNEW - QICE=(1.-RATIO4)*QTOT+(1.-RATIO3)*0.4*QNEW - QNEWLQ=0. - QNEWIC=0. - - END SUBROUTINE CONDLOAD - -! ---------------------------------------------------------------------- - SUBROUTINE PROF5(EQ,EE,UD) -! -!*********************************************************************** -!***** GAUSSIAN TYPE MIXING PROFILE....****************************** -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! THIS SUBROUTINE INTEGRATES THE AREA UNDER THE CURVE IN THE GAUSSIAN -! DISTRIBUTION...THE NUMERICAL APPROXIMATION TO THE INTEGRAL IS TAKEN FROM -! "HANDBOOK OF MATHEMATICAL FUNCTIONS WITH FORMULAS, GRAPHS AND MATHEMATICS TABLES" -! ED. BY ABRAMOWITZ AND STEGUN, NATL BUREAU OF STANDARDS APPLIED -! MATHEMATICS SERIES. JUNE, 1964., MAY, 1968. -! JACK KAIN -! 7/6/89 -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -!----------------------------------------------------------------------- - IMPLICIT NONE -!----------------------------------------------------------------------- - REAL, INTENT(IN ) :: EQ - REAL, INTENT(INOUT) :: EE,UD - REAL :: SQRT2P,A1,A2,A3,P,SIGMA,FE,X,Y,EY,E45,T1,T2,C1,C2 - - DATA SQRT2P,A1,A2,A3,P,SIGMA,FE/2.506628,0.4361836,-0.1201676, & - 0.9372980,0.33267,0.166666667,0.202765151/ - X=(EQ-0.5)/SIGMA - Y=6.*EQ-3. - EY=EXP(Y*Y/(-2)) - E45=EXP(-4.5) - T2=1./(1.+P*ABS(Y)) - T1=0.500498 - C1=A1*T1+A2*T1*T1+A3*T1*T1*T1 - C2=A1*T2+A2*T2*T2+A3*T2*T2*T2 - IF(Y.GE.0.)THEN - EE=SIGMA*(0.5*(SQRT2P-E45*C1-EY*C2)+SIGMA*(E45-EY))-E45*EQ*EQ/2. - UD=SIGMA*(0.5*(EY*C2-E45*C1)+SIGMA*(E45-EY))-E45*(0.5+EQ*EQ/2.- & - EQ) - ELSE - EE=SIGMA*(0.5*(EY*C2-E45*C1)+SIGMA*(E45-EY))-E45*EQ*EQ/2. - UD=SIGMA*(0.5*(SQRT2P-E45*C1-EY*C2)+SIGMA*(E45-EY))-E45*(0.5+EQ* & - EQ/2.-EQ) - ENDIF - EE=EE/FE - UD=UD/FE - - END SUBROUTINE PROF5 - -! ------------------------------------------------------------------------ - SUBROUTINE TPMIX2DD(p,thes,ts,qs,i,j) -! -! Lookup table variables: -! INTEGER, PARAMETER :: (KFNT=250,KFNP=220) -! REAL, SAVE, DIMENSION(1:KFNT,1:KFNP) :: TTAB,QSTAB -! REAL, SAVE, DIMENSION(1:KFNP) :: THE0K -! REAL, SAVE, DIMENSION(1:200) :: ALU -! REAL, SAVE :: RDPR,RDTHK,PLUTOP -! End of Lookup table variables: -!----------------------------------------------------------------------- - IMPLICIT NONE -!----------------------------------------------------------------------- - REAL, INTENT(IN ) :: P,THES - REAL, INTENT(INOUT) :: TS,QS - INTEGER, INTENT(IN ) :: i,j ! avail for debugging - REAL :: TP,QQ,BTH,TTH,PP,T00,T10,T01,T11,Q00,Q10,Q01,Q11 - INTEGER :: IPTB,ITHTB - CHARACTER*256 :: MESS -!----------------------------------------------------------------------- - -! -!******** LOOKUP TABLE VARIABLES (F77 format)... **************************** -! parameter(kfnt=250,kfnp=220) -! -! COMMON/KFLUT/ ttab(kfnt,kfnp),qstab(kfnt,kfnp),the0k(kfnp), & -! alu(200),rdpr,rdthk,plutop -!*************************************************************** -! -!*********************************************************************** -! scaling pressure and tt table index -!*********************************************************************** -! - tp=(p-plutop)*rdpr - qq=tp-aint(tp) - iptb=int(tp)+1 -! -!*********************************************************************** -! base and scaling factor for the -!*********************************************************************** -! -! scaling the and tt table index - bth=(the0k(iptb+1)-the0k(iptb))*qq+the0k(iptb) - tth=(thes-bth)*rdthk - pp =tth-aint(tth) - ithtb=int(tth)+1 -! - t00=ttab(ithtb ,iptb ) - t10=ttab(ithtb+1,iptb ) - t01=ttab(ithtb ,iptb+1) - t11=ttab(ithtb+1,iptb+1) -! - q00=qstab(ithtb ,iptb ) - q10=qstab(ithtb+1,iptb ) - q01=qstab(ithtb ,iptb+1) - q11=qstab(ithtb+1,iptb+1) -! -!*********************************************************************** -! parcel temperature and saturation mixing ratio -!*********************************************************************** -! - ts=(t00+(t10-t00)*pp+(t01-t00)*qq+(t00-t10-t01+t11)*pp*qq) -! - qs=(q00+(q10-q00)*pp+(q01-q00)*qq+(q00-q10-q01+q11)*pp*qq) -! - END SUBROUTINE TPMIX2DD - -! ----------------------------------------------------------------------- - SUBROUTINE ENVIRTHT(P1,T1,Q1,THT1,ALIQ,BLIQ,CLIQ,DLIQ) -! -!----------------------------------------------------------------------- - IMPLICIT NONE -!----------------------------------------------------------------------- - REAL, INTENT(IN ) :: P1,T1,Q1,ALIQ,BLIQ,CLIQ,DLIQ - REAL, INTENT(INOUT) :: THT1 - REAL :: EE,TLOG,ASTRT,AINC,A1,TP,VALUE,AINTRP,TDPT,TSAT,THT, & - T00,P00,C1,C2,C3,C4,C5 - INTEGER :: INDLU -!----------------------------------------------------------------------- - DATA T00,P00,C1,C2,C3,C4,C5/273.16,1.E5,3374.6525,2.5403,3114.834, & - 0.278296,1.0723E-3/ -! -! CALCULATE ENVIRONMENTAL EQUIVALENT POTENTIAL TEMPERATURE... -! -! NOTE: Calculations for mixed/ice phase no longer used...jsk 8/00 -! - EE=Q1*P1/(0.622+Q1) -! TLOG=ALOG(EE/ALIQ) -! ...calculate LOG term using lookup table... -! - astrt=1.e-3 - ainc=0.075 - a1=ee/aliq - tp=(a1-astrt)/ainc - indlu=int(tp)+1 - value=(indlu-1)*ainc+astrt - aintrp=(a1-value)/ainc - tlog=aintrp*alu(indlu+1)+(1-aintrp)*alu(indlu) -! - TDPT=(CLIQ-DLIQ*TLOG)/(BLIQ-TLOG) - TSAT=TDPT-(.212+1.571E-3*(TDPT-T00)-4.36E-4*(T1-T00))*(T1-TDPT) - THT=T1*(P00/P1)**(0.2854*(1.-0.28*Q1)) - THT1=THT*EXP((C1/TSAT-C2)*Q1*(1.+0.81*Q1)) -! - END SUBROUTINE ENVIRTHT -! *********************************************************************** -!==================================================================== - SUBROUTINE kf_eta_init(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN, & - RQICUTEN,RQSCUTEN,NCA,W0AVG,P_QI,P_QS, & - SVP1,SVP2,SVP3,SVPT0, & - P_FIRST_SCALAR,restart,allowed_to_read, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte ) -!-------------------------------------------------------------------- - IMPLICIT NONE -!-------------------------------------------------------------------- - LOGICAL , INTENT(IN) :: restart,allowed_to_read - INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte - INTEGER , INTENT(IN) :: P_QI,P_QS,P_FIRST_SCALAR - - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: & - RTHCUTEN, & - RQVCUTEN, & - RQCCUTEN, & - RQRCUTEN, & - RQICUTEN, & - RQSCUTEN - - REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: W0AVG - - REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT):: NCA - - INTEGER :: i, j, k, itf, jtf, ktf - REAL, INTENT(IN) :: SVP1,SVP2,SVP3,SVPT0 - - jtf=min0(jte,jde-1) - ktf=min0(kte,kde-1) - itf=min0(ite,ide-1) - - IF(.not.restart)THEN - - DO j=jts,jtf - DO k=kts,ktf - DO i=its,itf - RTHCUTEN(i,k,j)=0. - RQVCUTEN(i,k,j)=0. - RQCCUTEN(i,k,j)=0. - RQRCUTEN(i,k,j)=0. - ENDDO - ENDDO - ENDDO - - IF (P_QI .ge. P_FIRST_SCALAR) THEN - DO j=jts,jtf - DO k=kts,ktf - DO i=its,itf - RQICUTEN(i,k,j)=0. - ENDDO - ENDDO - ENDDO - ENDIF - - IF (P_QS .ge. P_FIRST_SCALAR) THEN - DO j=jts,jtf - DO k=kts,ktf - DO i=its,itf - RQSCUTEN(i,k,j)=0. - ENDDO - ENDDO - ENDDO - ENDIF - - DO j=jts,jtf - DO i=its,itf - NCA(i,j)=-100. - ENDDO - ENDDO - - DO j=jts,jtf - DO k=kts,ktf - DO i=its,itf - W0AVG(i,k,j)=0. - ENDDO - ENDDO - ENDDO - - endif - - CALL KF_LUTAB(SVP1,SVP2,SVP3,SVPT0) - - END SUBROUTINE kf_eta_init - -!------------------------------------------------------- - - subroutine kf_lutab(SVP1,SVP2,SVP3,SVPT0) -! -! This subroutine is a lookup table. -! Given a series of series of saturation equivalent potential -! temperatures, the temperature is calculated. -! -!-------------------------------------------------------------------- - IMPLICIT NONE -!-------------------------------------------------------------------- -! Lookup table variables -! INTEGER, SAVE, PARAMETER :: KFNT=250,KFNP=220 -! REAL, SAVE, DIMENSION(1:KFNT,1:KFNP) :: TTAB,QSTAB -! REAL, SAVE, DIMENSION(1:KFNP) :: THE0K -! REAL, SAVE, DIMENSION(1:200) :: ALU -! REAL, SAVE :: RDPR,RDTHK,PLUTOP -! End of Lookup table variables - - INTEGER :: KP,IT,ITCNT,I - REAL :: DTH,TMIN,TOLER,PBOT,DPR, & - TEMP,P,ES,QS,PI,THES,TGUES,THGUES,F0,T1,T0,THGS,F1,DT, & - ASTRT,AINC,A1,THTGS -! REAL :: ALIQ,BLIQ,CLIQ,DLIQ,SVP1,SVP2,SVP3,SVPT0 - REAL :: ALIQ,BLIQ,CLIQ,DLIQ - REAL, INTENT(IN) :: SVP1,SVP2,SVP3,SVPT0 -! -! equivalent potential temperature increment - data dth/1./ -! minimum starting temp - data tmin/150./ -! tolerance for accuracy of temperature - data toler/0.001/ -! top pressure (pascals) - plutop=5000.0 -! bottom pressure (pascals) - pbot=110000.0 - - ALIQ = SVP1*1000. - BLIQ = SVP2 - CLIQ = SVP2*SVPT0 - DLIQ = SVP3 - -! -! compute parameters -! -! 1._over_(sat. equiv. theta increment) - rdthk=1./dth -! pressure increment -! - DPR=(PBOT-PLUTOP)/REAL(KFNP-1) -! dpr=(pbot-plutop)/REAL(kfnp-1) -! 1._over_(pressure increment) - rdpr=1./dpr -! compute the spread of thes -! thespd=dth*(kfnt-1) -! -! calculate the starting sat. equiv. theta -! - temp=tmin - p=plutop-dpr - do kp=1,kfnp - p=p+dpr - es=aliq*exp((bliq*temp-cliq)/(temp-dliq)) - qs=0.622*es/(p-es) - pi=(1.e5/p)**(0.2854*(1.-0.28*qs)) - the0k(kp)=temp*pi*exp((3374.6525/temp-2.5403)*qs* & - (1.+0.81*qs)) - enddo -! -! compute temperatures for each sat. equiv. potential temp. -! - p=plutop-dpr - do kp=1,kfnp - thes=the0k(kp)-dth - p=p+dpr - do it=1,kfnt -! define sat. equiv. pot. temp. - thes=thes+dth -! iterate to find temperature -! find initial guess - if(it.eq.1) then - tgues=tmin - else - tgues=ttab(it-1,kp) - endif - es=aliq*exp((bliq*tgues-cliq)/(tgues-dliq)) - qs=0.622*es/(p-es) - pi=(1.e5/p)**(0.2854*(1.-0.28*qs)) - thgues=tgues*pi*exp((3374.6525/tgues-2.5403)*qs* & - (1.+0.81*qs)) - f0=thgues-thes - t1=tgues-0.5*f0 - t0=tgues - itcnt=0 -! iteration loop - do itcnt=1,11 - es=aliq*exp((bliq*t1-cliq)/(t1-dliq)) - qs=0.622*es/(p-es) - pi=(1.e5/p)**(0.2854*(1.-0.28*qs)) - thtgs=t1*pi*exp((3374.6525/t1-2.5403)*qs*(1.+0.81*qs)) - f1=thtgs-thes - if(abs(f1).lt.toler)then - exit - endif -! itcnt=itcnt+1 - dt=f1*(t1-t0)/(f1-f0) - t0=t1 - f0=f1 - t1=t1-dt - enddo - ttab(it,kp)=t1 - qstab(it,kp)=qs - enddo - enddo -! -! lookup table for tlog(emix/aliq) -! -! set up intial values for lookup tables -! - astrt=1.e-3 - ainc=0.075 -! - a1=astrt-ainc - do i=1,200 - a1=a1+ainc - alu(i)=alog(a1) - enddo -! - END SUBROUTINE KF_LUTAB - -END MODULE module_cu_kfeta diff --git a/src/fim/FIMsrc/fim/wrfphys/module_cu_sas.F b/src/fim/FIMsrc/fim/wrfphys/module_cu_sas.F deleted file mode 100644 index 36415e5..0000000 --- a/src/fim/FIMsrc/fim/wrfphys/module_cu_sas.F +++ /dev/null @@ -1,2506 +0,0 @@ -! -MODULE module_cu_sas - -CONTAINS - -!----------------------------------------------------------------- - SUBROUTINE CU_SAS( & - DT,ITIMESTEP,STEPCU & - ,RAINCV,PRATEC,HTOP,HBOT & - ,U3D,V3D,W,T3D,QV3D,QC3D,QI3D,PI3D,RHO3D & - ,DZ8W,PCPS,P8W,XLAND,CU_ACT_FLAG & - ,CUDT, CURR_SECS, ADAPT_STEP_FLAG & - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte & - ,F_QV ,F_QC ,F_QR ,F_QI ,F_QS & - ,RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN & - ) - -!------------------------------------------------------------------- - USE MODULE_GFS_MACHINE , ONLY : kind_phys, kind_evod - USE MODULE_GFS_FUNCPHYS , ONLY : gfuncphys - USE MODULE_GFS_PHYSCONS, grav => con_g, CP => con_CP, HVAP => con_HVAP & - &, RV => con_RV, FV => con_fvirt, T0C => con_T0C & - &, CVAP => con_CVAP, CLIQ => con_CLIQ & - &, EPS => con_eps, EPSM1 => con_epsm1 & - &, ROVCP => con_rocp, RD => con_rd -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -!-- U3D 3D u-velocity interpolated to theta points (m/s) -!-- V3D 3D v-velocity interpolated to theta points (m/s) -!-- TH3D 3D potential temperature (K) -!-- T3D temperature (K) -!-- QV3D 3D water vapor mixing ratio (Kg/Kg) -!-- QC3D 3D cloud mixing ratio (Kg/Kg) -!-- QI3D 3D ice mixing ratio (Kg/Kg) -!-- P8w 3D pressure at full levels (Pa) -!-- Pcps 3D pressure (Pa) -!-- PI3D 3D exner function (dimensionless) -!-- rr3D 3D dry air density (kg/m^3) -!-- RUBLTEN U tendency due to -! PBL parameterization (m/s^2) -!-- RVBLTEN V tendency due to -! PBL parameterization (m/s^2) -!-- RTHBLTEN Theta tendency due to -! PBL parameterization (K/s) -!-- RQVBLTEN Qv tendency due to -! PBL parameterization (kg/kg/s) -!-- RQCBLTEN Qc tendency due to -! PBL parameterization (kg/kg/s) -!-- RQIBLTEN Qi tendency due to -! PBL parameterization (kg/kg/s) -!-- CP heat capacity at constant pressure for dry air (J/kg/K) -!-- GRAV acceleration due to gravity (m/s^2) -!-- ROVCP R/CP -!-- RD gas constant for dry air (J/kg/K) -!-- ROVG R/G -!-- P_QI species index for cloud ice -!-- dz8w dz between full levels (m) -!-- z height above sea level (m) -!-- PSFC pressure at the surface (Pa) -!-- UST u* in similarity theory (m/s) -!-- PBL PBL height (m) -!-- PSIM similarity stability function for momentum -!-- PSIH similarity stability function for heat -!-- HFX upward heat flux at the surface (W/m^2) -!-- QFX upward moisture flux at the surface (kg/m^2/s) -!-- TSK surface temperature (K) -!-- GZ1OZ0 log(z/z0) where z0 is roughness length -!-- WSPD wind speed at lowest model level (m/s) -!-- BR bulk Richardson number in surface layer -!-- DT time step (s) -!-- rvovrd R_v divided by R_d (dimensionless) -!-- EP1 constant for virtual temperature (R_v/R_d - 1) (dimensionless) -!-- KARMAN Von Karman constant -!-- ids start index for i in domain -!-- ide end index for i in domain -!-- jds start index for j in domain -!-- jde end index for j in domain -!-- kds start index for k in domain -!-- kde end index for k in domain -!-- ims start index for i in memory -!-- ime end index for i in memory -!-- jms start index for j in memory -!-- jme end index for j in memory -!-- kms start index for k in memory -!-- kme end index for k in memory -!-- its start index for i in tile -!-- ite end index for i in tile -!-- jts start index for j in tile -!-- jte end index for j in tile -!-- kts start index for k in tile -!-- kte end index for k in tile -!------------------------------------------------------------------- - - INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - ITIMESTEP, & - STEPCU - - REAL, INTENT(IN) :: & - DT - - - REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: & - XLAND - - REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: & - RAINCV, PRATEC - - REAL, DIMENSION(ims:ime, jms:jme), INTENT(OUT) :: & - HBOT, & - HTOP - - LOGICAL, DIMENSION(IMS:IME,JMS:JME), INTENT(INOUT) :: & - CU_ACT_FLAG - - - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: & - DZ8W, & - P8w, & - Pcps, & - PI3D, & - QC3D, & - QI3D, & - QV3D, & - RHO3D, & - T3D, & - U3D, & - V3D, & - W - -!--------------------------- OPTIONAL VARS ---------------------------- - - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), & - OPTIONAL, INTENT(INOUT) :: & - RQCCUTEN, & - RQICUTEN, & - RQVCUTEN, & - RTHCUTEN - -! -! Flags relating to the optional tendency arrays declared above -! Models that carry the optional tendencies will provdide the -! optional arguments at compile time; these flags all the model -! to determine at run-time whether a particular tracer is in -! use or not. -! - LOGICAL, OPTIONAL :: & - F_QV & - ,F_QC & - ,F_QR & - ,F_QI & - ,F_QS - -! Adaptive time-step variables - REAL, INTENT(IN ) :: CUDT - REAL, INTENT(IN ) :: CURR_SECS - LOGICAL,INTENT(IN ) :: ADAPT_STEP_FLAG - -!--------------------------- LOCAL VARS ------------------------------ - - REAL, DIMENSION(ims:ime, jms:jme) :: & - PSFC - - REAL (kind=kind_evod),save :: seed0 -! REAL (kind=kind_evod) :: seed0 - REAL (kind=kind_evod) :: wrk - - REAL (kind=kind_phys) :: & - DELT, & - DPSHC, & - RDELT, & - RSEED - - REAL (kind=kind_phys), DIMENSION(ids:ide,jds:jde) :: & - RANNUM - - REAL (kind=kind_phys), DIMENSION(its:ite) :: & - CLDWRK, & - PS, & - RCS, & - RN, & - SLIMSK, & - XKT2 - - REAL (kind=kind_phys), DIMENSION(its:ite, kts:kte+1) :: & - PRSI - - REAL (kind=kind_phys), DIMENSION(its:ite, kts:kte) :: & - DEL, & - DOT, & - PHIL, & - PRSL, & - PRSLK, & - Q1, & - T1, & - U1, & - V1, & - ZI, & - ZL - - REAL (kind=kind_phys), DIMENSION(its:ite, kts:kte, 2) :: & - QL - - INTEGER, DIMENSION(its:ite) :: & - KBOT, & - KTOP, & - KUO - - INTEGER :: & - I, & -! IGPVS, & - IM, & - J, & - JCAP, & - K, & - KM, & - KP, & - KX, & - NCLOUD - - INTEGER :: start_year,start_month,start_day,start_hour - - integer :: iseed -! integer, save :: krsize - integer :: krsize - integer, allocatable :: nrnd(:) - real :: fsec - - LOGICAL :: run_param - -! DATA IGPVS/0/ - -!----------------------------------------------------------------------- -! -!*** CHECK TO SEE IF THIS IS A CONVECTION TIMESTEP -! - if (adapt_step_flag) then - if ( (ITIMESTEP .eq. 0) .or. (cudt .eq. 0) .or. & - ( CURR_SECS + dt >= ( int( CURR_SECS / ( cudt * 60 ) ) + 1 ) * cudt * 60 ) ) then - run_param = .TRUE. - else - run_param = .FALSE. - endif - - else - if (MOD(ITIMESTEP,STEPCU) .EQ. 0 .or. ITIMESTEP .eq. 0) then - run_param = .TRUE. - else - run_param = .FALSE. - endif - endif - -!----------------------------------------------------------------------- - - - IF(run_param) THEN - - DO J=JTS,JTE - DO I=ITS,ITE - CU_ACT_FLAG(I,J)=.TRUE. - ENDDO - ENDDO - - IM=ITE-ITS+1 - KX=KTE-KTS+1 - JCAP=126 - DPSHC=30_kind_phys - DELT=DT*STEPCU - RDELT=1./DELT - NCLOUD=1 - - - DO J=jts,jte - DO I=its,ite - PSFC(i,j)=P8w(i,kms,j) - ENDDO - ENDDO - - if(itimestep.eq.0) then - CALL GFUNCPHYS - - CALL nl_get_start_year(1,start_year) - CALL nl_get_start_month(1,start_month) - CALL nl_get_start_day(1,start_day) - CALL nl_get_start_hour(1,start_hour) - - call random_seed(size=krsize) - if (.not. allocated (nrnd)) allocate (nrnd(krsize)) - - seed0 = start_year + start_month + start_day + start_hour - nrnd = start_hour + start_day*24 - call random_seed - call random_seed(put=nrnd) - call random_number(wrk) - seed0 = seed0 + nint(wrk*1000.0) - - endif - - if (adapt_step_flag) then - fsec = CURR_SECS - else - fsec = ITIMESTEP*DT - endif - iseed = mod(100.0*sqrt(fsec),1.0e9) + 1 + seed0 - call random_seed(size=krsize) - if (.not. allocated (nrnd)) allocate (nrnd(krsize)) - nrnd = iseed - call random_seed - call random_seed(put=nrnd) - call random_number(rannum) - -! igpvs=1 - -!------------- J LOOP (OUTER) -------------------------------------------------- - - DO J=jts,jte - -! --------------- compute zi and zl ----------------------------------------- - DO i=its,ite - ZI(I,KTS)=0.0 - ENDDO - - DO k=kts+1,kte - KM=K-1 - DO i=its,ite - ZI(I,K)=ZI(I,KM)+dz8w(i,km,j) - ENDDO - ENDDO - - DO k=kts+1,kte - KM=K-1 - DO i=its,ite - ZL(I,KM)=(ZI(I,K)+ZI(I,KM))*0.5 - ENDDO - ENDDO - - DO i=its,ite - ZL(I,KTE)=2.*ZI(I,KTE)-ZL(I,KTE-1) - ENDDO - -! --------------- end compute zi and zl ------------------------------------- - - -! call random_number(XKT2) - DO i=its,ite - xkt2(i)=rannum(i,j) - PS(i)=PSFC(i,j)*.001 - RCS(i)=1. - SLIMSK(i)=ABS(XLAND(i,j)-2.) - ENDDO - - DO i=its,ite - PRSI(i,kts)=PS(i) - ENDDO - - DO k=kts,kte - kp=k+1 - DO i=its,ite - PRSL(I,K)=Pcps(i,k,j)*.001 - PHIL(I,K)=ZL(I,K)*GRAV - DOT(i,k)=-5.0E-4*GRAV*rho3d(i,k,j)*(w(i,k,j)+w(i,kp,j)) - ENDDO - ENDDO - - DO k=kts,kte - DO i=its,ite - DEL(i,k)=PRSL(i,k)*GRAV/RD*dz8w(i,k,j)/T3D(i,k,j) - U1(i,k)=U3D(i,k,j) - V1(i,k)=V3D(i,k,j) - Q1(i,k)=QV3D(i,k,j)/(1.+QV3D(i,k,j)) - T1(i,k)=T3D(i,k,j) - QL(i,k,1)=QI3D(i,k,j)/(1.+QI3D(i,k,j)) - QL(i,k,2)=QC3D(i,k,j)/(1.+QC3D(i,k,j)) - PRSLK(I,K)=(PRSL(i,k)*.01)**ROVCP - ENDDO - ENDDO - - DO k=kts+1,kte+1 - km=k-1 - DO i=its,ite - PRSI(i,k)=PRSI(i,km)-del(i,km) - ENDDO - ENDDO - - - CALL SASCNV(IM,IM,KX,JCAP,DELT,DEL,PRSL,PS,PHIL, & - QL,Q1,T1,U1,V1,RCS,CLDWRK,RN,KBOT, & - KTOP,KUO,SLIMSK,DOT,XKT2,NCLOUD) - - CALL SHALCV(IM,IM,KX,DELT,DEL,PRSI,PRSL,PRSLK,KUO,Q1,T1,DPSHC) - - DO I=ITS,ITE - RAINCV(I,J)=RN(I)*1000./STEPCU - PRATEC(I,J)=RN(I)*1000./(STEPCU * DT) - HBOT(I,J)=KBOT(I) - HTOP(I,J)=KTOP(I) - ENDDO - - DO K=KTS,KTE - DO I=ITS,ITE - RTHCUTEN(I,K,J)=(T1(I,K)-T3D(I,K,J))/PI3D(I,K,J)*RDELT - RQVCUTEN(I,K,J)=(Q1(I,K)/(1.-q1(i,k))-QV3D(I,K,J))*RDELT - ENDDO - ENDDO - - IF(PRESENT(RQCCUTEN))THEN - IF ( F_QC ) THEN - DO K=KTS,KTE - DO I=ITS,ITE - RQCCUTEN(I,K,J)=(QL(I,K,2)/(1.-ql(i,k,2))-QC3D(I,K,J))*RDELT - ENDDO - ENDDO - ENDIF - ENDIF - - IF(PRESENT(RQICUTEN))THEN - IF ( F_QI ) THEN - DO K=KTS,KTE - DO I=ITS,ITE - RQICUTEN(I,K,J)=(QL(I,K,1)/(1.-ql(i,k,1))-QI3D(I,K,J))*RDELT - ENDDO - ENDDO - ENDIF - ENDIF - - - ENDDO - - ENDIF - - END SUBROUTINE CU_SAS - -!==================================================================== - SUBROUTINE sasinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN, & - RESTART,P_QC,P_QI,P_FIRST_SCALAR, & - allowed_to_read, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte) -!-------------------------------------------------------------------- - IMPLICIT NONE -!-------------------------------------------------------------------- - LOGICAL , INTENT(IN) :: allowed_to_read,restart - INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte - INTEGER , INTENT(IN) :: P_FIRST_SCALAR, P_QI, P_QC - - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: & - RTHCUTEN, & - RQVCUTEN, & - RQCCUTEN, & - RQICUTEN - - INTEGER :: i, j, k, itf, jtf, ktf - - jtf=min0(jte,jde-1) - ktf=min0(kte,kde-1) - itf=min0(ite,ide-1) - - IF(.not.restart)THEN - DO j=jts,jtf - DO k=kts,ktf - DO i=its,itf - RTHCUTEN(i,k,j)=0. - RQVCUTEN(i,k,j)=0. - ENDDO - ENDDO - ENDDO - - IF (P_QC .ge. P_FIRST_SCALAR) THEN - DO j=jts,jtf - DO k=kts,ktf - DO i=its,itf - RQCCUTEN(i,k,j)=0. - ENDDO - ENDDO - ENDDO - ENDIF - - IF (P_QI .ge. P_FIRST_SCALAR) THEN - DO j=jts,jtf - DO k=kts,ktf - DO i=its,itf - RQICUTEN(i,k,j)=0. - ENDDO - ENDDO - ENDDO - ENDIF - ENDIF - - END SUBROUTINE sasinit - -! ------------------------------------------------------------------------ - - SUBROUTINE SASCNV(IM,IX,KM,JCAP,DELT,DEL,PRSL,PS,PHIL,QL, & -! SUBROUTINE SASCNV(IM,IX,KM,JCAP,DLT,DEL,PRSL,PHIL,QL, & - & Q1,T1,U1,V1,RCS,CLDWRK,RN,KBOT,KTOP,KUO,SLIMSK, & - & DOT,XKT2,ncloud) -! for cloud water version -! parameter(ncloud=0) -! SUBROUTINE SASCNV(KM,JCAP,DELT,DEL,SL,SLK,PS,QL, -! & Q1,T1,U1,V1,RCS,CLDWRK,RN,KBOT,KTOP,KUO,SLIMSK, -! & DOT,xkt2,ncloud) -! - USE MODULE_GFS_MACHINE , ONLY : kind_phys,kind_evod - USE MODULE_GFS_FUNCPHYS ,ONLY : fpvs - USE MODULE_GFS_PHYSCONS, grav => con_g, CP => con_CP, HVAP => con_HVAP & - &, RV => con_RV, FV => con_fvirt, T0C => con_T0C & - &, CVAP => con_CVAP, CLIQ => con_CLIQ & - &, EPS => con_eps, EPSM1 => con_epsm1 - - implicit none -! -! include 'constant.h' -! - integer IM, IX, KM, JCAP, ncloud, & - & KBOT(IM), KTOP(IM), KUO(IM) - real(kind=kind_phys) DELT - real(kind=kind_phys) PS(IM), DEL(IX,KM), PRSL(IX,KM), & -! real(kind=kind_phys) DEL(IX,KM), PRSL(IX,KM), - & QL(IX,KM,2), Q1(IX,KM), T1(IX,KM), & - & U1(IX,KM), V1(IX,KM), RCS(IM), & - & CLDWRK(IM), RN(IM), SLIMSK(IM), & - & DOT(IX,KM), XKT2(IM), PHIL(IX,KM) -! - integer I, INDX, jmn, k, knumb, latd, lond, km1 -! - real(kind=kind_phys) adw, alpha, alphal, alphas, & - & aup, beta, betal, betas, & - & c0, cpoel, dellat, delta, & - & desdt, deta, detad, dg, & - & dh, dhh, dlnsig, dp, & - & dq, dqsdp, dqsdt, dt, & - & dt2, dtmax, dtmin, dv1, & - & dv1q, dv2, dv2q, dv1u, & - & dv1v, dv2u, dv2v, dv3u, & - & dv3v, dv3, dv3q, dvq1, & - & dz, dz1, e1, edtmax, & - & edtmaxl, edtmaxs, el2orc, elocp, & - & es, etah, & - & evef, evfact, evfactl, fact1, & - & fact2, factor, fjcap, fkm, & - & fuv, g, gamma, onemf, & - & onemfu, pdetrn, pdpdwn, pprime, & - & qc, qlk, qrch, qs, & - & rain, rfact, shear, tem1, & - & tem2, terr, val, val1, & - & val2, w1, w1l, w1s, & - & w2, w2l, w2s, w3, & - & w3l, w3s, w4, w4l, & - & w4s, xdby, xpw, xpwd, & - & xqc, xqrch, xlambu, mbdt, & - & tem -! -! - integer JMIN(IM), KB(IM), KBCON(IM), KBDTR(IM), & - & KT2(IM), KTCON(IM), LMIN(IM), & - & kbm(IM), kbmax(IM), kmax(IM) -! - real(kind=kind_phys) AA1(IM), ACRT(IM), ACRTFCT(IM), & - & DELHBAR(IM), DELQ(IM), DELQ2(IM), & - & DELQBAR(IM), DELQEV(IM), DELTBAR(IM), & - & DELTV(IM), DTCONV(IM), EDT(IM), & - & EDTO(IM), EDTX(IM), FLD(IM), & - & HCDO(IM), HKBO(IM), HMAX(IM), & - & HMIN(IM), HSBAR(IM), UCDO(IM), & - & UKBO(IM), VCDO(IM), VKBO(IM), & - & PBCDIF(IM), PDOT(IM), PO(IM,KM), & - & PWAVO(IM), PWEVO(IM), & -! & PSFC(IM), PWAVO(IM), PWEVO(IM), & - & QCDO(IM), QCOND(IM), QEVAP(IM), & - & QKBO(IM), RNTOT(IM), VSHEAR(IM), & - & XAA0(IM), XHCD(IM), XHKB(IM), & - & XK(IM), XLAMB(IM), XLAMD(IM), & - & XMB(IM), XMBMAX(IM), XPWAV(IM), & - & XPWEV(IM), XQCD(IM), XQKB(IM) -! -! PHYSICAL PARAMETERS - PARAMETER(G=grav) - PARAMETER(CPOEL=CP/HVAP,ELOCP=HVAP/CP, & - & EL2ORC=HVAP*HVAP/(RV*CP)) - PARAMETER(TERR=0.,C0=.002,DELTA=fv) - PARAMETER(FACT1=(CVAP-CLIQ)/RV,FACT2=HVAP/RV-FACT1*T0C) -! LOCAL VARIABLES AND ARRAYS - real(kind=kind_phys) PFLD(IM,KM), TO(IM,KM), QO(IM,KM), & - & UO(IM,KM), VO(IM,KM), QESO(IM,KM) -! cloud water - real(kind=kind_phys) QLKO_KTCON(IM), DELLAL(IM), TVO(IM,KM), & - & DBYO(IM,KM), ZO(IM,KM), SUMZ(IM,KM), & - & SUMH(IM,KM), HEO(IM,KM), HESO(IM,KM), & - & QRCD(IM,KM), DELLAH(IM,KM), DELLAQ(IM,KM),& - & DELLAU(IM,KM), DELLAV(IM,KM), HCKO(IM,KM), & - & UCKO(IM,KM), VCKO(IM,KM), QCKO(IM,KM), & - & ETA(IM,KM), ETAU(IM,KM), ETAD(IM,KM), & - & QRCDO(IM,KM), PWO(IM,KM), PWDO(IM,KM), & - & RHBAR(IM), TX1(IM) -! - LOGICAL TOTFLG, CNVFLG(IM), DWNFLG(IM), DWNFLG2(IM), FLG(IM) -! - real(kind=kind_phys) PCRIT(15), ACRITT(15), ACRIT(15) -! SAVE PCRIT, ACRITT - DATA PCRIT/850.,800.,750.,700.,650.,600.,550.,500.,450.,400., & - & 350.,300.,250.,200.,150./ - DATA ACRITT/.0633,.0445,.0553,.0664,.075,.1082,.1521,.2216, & - & .3151,.3677,.41,.5255,.7663,1.1686,1.6851/ -! GDAS DERIVED ACRIT -! DATA ACRITT/.203,.515,.521,.566,.625,.665,.659,.688, & -! & .743,.813,.886,.947,1.138,1.377,1.896/ -! - real(kind=kind_phys) TF, TCR, TCRF, RZERO, RONE - parameter (TF=233.16, TCR=263.16, TCRF=1.0/(TCR-TF)) - parameter (RZERO=0.0,RONE=1.0) -!----------------------------------------------------------------------- -! - km1 = km - 1 -! INITIALIZE ARRAYS -! - DO I=1,IM - RN(I)=0. - KBOT(I)=KM+1 - KTOP(I)=0 - KUO(I)=0 - CNVFLG(I) = .TRUE. - DTCONV(I) = 3600. - CLDWRK(I) = 0. - PDOT(I) = 0. - KT2(I) = 0 - QLKO_KTCON(I) = 0. - DELLAL(I) = 0. - ENDDO -!! - DO K = 1, 15 - ACRIT(K) = ACRITT(K) * (975. - PCRIT(K)) - ENDDO - DT2 = DELT -!cmr dtmin = max(dt2,1200.) - val = 1200. - dtmin = max(dt2, val ) -!cmr dtmax = max(dt2,3600.) - val = 3600. - dtmax = max(dt2, val ) -! MODEL TUNABLE PARAMETERS ARE ALL HERE - MBDT = 10. - EDTMAXl = .3 - EDTMAXs = .3 - ALPHAl = .5 - ALPHAs = .5 - BETAl = .15 - betas = .15 - BETAl = .05 - betas = .05 -! EVEF = 0.07 - evfact = 0.3 - evfactl = 0.3 - PDPDWN = 0. - PDETRN = 200. - xlambu = 1.e-4 - fjcap = (float(jcap) / 126.) ** 2 -!cmr fjcap = max(fjcap,1.) - val = 1. - fjcap = max(fjcap,val) - fkm = (float(km) / 28.) ** 2 -!cmr fkm = max(fkm,1.) - fkm = max(fkm,val) - W1l = -8.E-3 - W2l = -4.E-2 - W3l = -5.E-3 - W4l = -5.E-4 - W1s = -2.E-4 - W2s = -2.E-3 - W3s = -1.E-3 - W4s = -2.E-5 -!CCCC IF(IM.EQ.384) THEN - LATD = 92 - lond = 189 -!CCCC ELSEIF(IM.EQ.768) THEN -!CCCC LATD = 80 -!CCCC ELSE -!CCCC LATD = 0 -!CCCC ENDIF -! -! DEFINE TOP LAYER FOR SEARCH OF THE DOWNDRAFT ORIGINATING LAYER -! AND THE MAXIMUM THETAE FOR UPDRAFT -! - DO I=1,IM - KBMAX(I) = KM - KBM(I) = KM - KMAX(I) = KM - TX1(I) = 1.0 / PS(I) - ENDDO -! - DO K = 1, KM - DO I=1,IM - IF (prSL(I,K)*tx1(I) .GT. 0.45) KBMAX(I) = K + 1 - IF (prSL(I,K)*tx1(I) .GT. 0.70) KBM(I) = K + 1 - IF (prSL(I,K)*tx1(I) .GT. 0.04) KMAX(I) = MIN(KM,K + 1) - ENDDO - ENDDO - DO I=1,IM - KBMAX(I) = MIN(KBMAX(I),KMAX(I)) - KBM(I) = MIN(KBM(I),KMAX(I)) - ENDDO -! -! CONVERT SURFACE PRESSURE TO MB FROM CB -! -!! - DO K = 1, KM - DO I=1,IM - if (K .le. kmax(i)) then - PFLD(I,k) = PRSL(I,K) * 10.0 - PWO(I,k) = 0. - PWDO(I,k) = 0. - TO(I,k) = T1(I,k) - QO(I,k) = Q1(I,k) - UO(I,k) = U1(I,k) - VO(I,k) = V1(I,k) - DBYO(I,k) = 0. - SUMZ(I,k) = 0. - SUMH(I,k) = 0. - endif - ENDDO - ENDDO - -! -! COLUMN VARIABLES -! P IS PRESSURE OF THE LAYER (MB) -! T IS TEMPERATURE AT T-DT (K)..TN -! Q IS MIXING RATIO AT T-DT (KG/KG)..QN -! TO IS TEMPERATURE AT T+DT (K)... THIS IS AFTER ADVECTION AND TURBULAN -! QO IS MIXING RATIO AT T+DT (KG/KG)..Q1 -! - DO K = 1, KM - DO I=1,IM - if (k .le. kmax(i)) then - !jfe QESO(I,k) = 10. * FPVS(T1(I,k)) - ! - QESO(I,k) = 0.01 * fpvs(T1(I,K)) ! fpvs is in Pa - ! - QESO(I,k) = EPS * QESO(I,k) / (PFLD(I,k) + EPSM1*QESO(I,k)) - !cmr QESO(I,k) = MAX(QESO(I,k),1.E-8) - val1 = 1.E-8 - QESO(I,k) = MAX(QESO(I,k), val1) - !cmr QO(I,k) = max(QO(I,k),1.e-10) - val2 = 1.e-10 - QO(I,k) = max(QO(I,k), val2 ) - ! QO(I,k) = MIN(QO(I,k),QESO(I,k)) - TVO(I,k) = TO(I,k) + DELTA * TO(I,k) * QO(I,k) - endif - ENDDO - ENDDO - -! -! HYDROSTATIC HEIGHT ASSUME ZERO TERR -! - DO K = 1, KM - DO I=1,IM - ZO(I,k) = PHIL(I,k) / G - ENDDO - ENDDO -! COMPUTE MOIST STATIC ENERGY - DO K = 1, KM - DO I=1,IM - if (K .le. kmax(i)) then -! tem = G * ZO(I,k) + CP * TO(I,k) - tem = PHIL(I,k) + CP * TO(I,k) - HEO(I,k) = tem + HVAP * QO(I,k) - HESO(I,k) = tem + HVAP * QESO(I,k) -! HEO(I,k) = MIN(HEO(I,k),HESO(I,k)) - endif - ENDDO - ENDDO -! -! DETERMINE LEVEL WITH LARGEST MOIST STATIC ENERGY -! THIS IS THE LEVEL WHERE UPDRAFT STARTS -! - DO I=1,IM - HMAX(I) = HEO(I,1) - KB(I) = 1 - ENDDO -!! - DO K = 2, KM - DO I=1,IM - if (k .le. kbm(i)) then - IF(HEO(I,k).GT.HMAX(I).AND.CNVFLG(I)) THEN - KB(I) = K - HMAX(I) = HEO(I,k) - ENDIF - endif - ENDDO - ENDDO -! DO K = 1, KMAX - 1 -! TOL(k) = .5 * (TO(I,k) + TO(I,k+1)) -! QOL(k) = .5 * (QO(I,k) + QO(I,k+1)) -! QESOL(I,k) = .5 * (QESO(I,k) + QESO(I,k+1)) -! HEOL(I,k) = .5 * (HEO(I,k) + HEO(I,k+1)) -! HESOL(I,k) = .5 * (HESO(I,k) + HESO(I,k+1)) -! ENDDO - DO K = 1, KM1 - DO I=1,IM - if (k .le. kmax(i)-1) then - DZ = .5 * (ZO(I,k+1) - ZO(I,k)) - DP = .5 * (PFLD(I,k+1) - PFLD(I,k)) -!jfe ES = 10. * FPVS(TO(I,k+1)) -! - ES = 0.01 * fpvs(TO(I,K+1)) ! fpvs is in Pa -! - PPRIME = PFLD(I,k+1) + EPSM1 * ES - QS = EPS * ES / PPRIME - DQSDP = - QS / PPRIME - DESDT = ES * (FACT1 / TO(I,k+1) + FACT2 / (TO(I,k+1)**2)) - DQSDT = QS * PFLD(I,k+1) * DESDT / (ES * PPRIME) - GAMMA = EL2ORC * QESO(I,k+1) / (TO(I,k+1)**2) - DT = (G * DZ + HVAP * DQSDP * DP) / (CP * (1. + GAMMA)) - DQ = DQSDT * DT + DQSDP * DP - TO(I,k) = TO(I,k+1) + DT - QO(I,k) = QO(I,k+1) + DQ - PO(I,k) = .5 * (PFLD(I,k) + PFLD(I,k+1)) - endif - ENDDO - ENDDO -! - DO K = 1, KM1 - DO I=1,IM - if (k .le. kmax(I)-1) then -!jfe QESO(I,k) = 10. * FPVS(TO(I,k)) -! - QESO(I,k) = 0.01 * fpvs(TO(I,K)) ! fpvs is in Pa -! - QESO(I,k) = EPS * QESO(I,k) / (PO(I,k) + EPSM1*QESO(I,k)) -!cmr QESO(I,k) = MAX(QESO(I,k),1.E-8) - val1 = 1.E-8 - QESO(I,k) = MAX(QESO(I,k), val1) -!cmr QO(I,k) = max(QO(I,k),1.e-10) - val2 = 1.e-10 - QO(I,k) = max(QO(I,k), val2 ) -! QO(I,k) = MIN(QO(I,k),QESO(I,k)) - HEO(I,k) = .5 * G * (ZO(I,k) + ZO(I,k+1)) + & - & CP * TO(I,k) + HVAP * QO(I,k) - HESO(I,k) = .5 * G * (ZO(I,k) + ZO(I,k+1)) + & - & CP * TO(I,k) + HVAP * QESO(I,k) - UO(I,k) = .5 * (UO(I,k) + UO(I,k+1)) - VO(I,k) = .5 * (VO(I,k) + VO(I,k+1)) - endif - ENDDO - ENDDO -! k = kmax -! HEO(I,k) = HEO(I,k) -! hesol(k) = HESO(I,k) -! IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I)) THEN -! PRINT *, ' HEO =' -! PRINT 6001, (HEO(I,K),K=1,KMAX) -! PRINT *, ' HESO =' -! PRINT 6001, (HESO(I,K),K=1,KMAX) -! PRINT *, ' TO =' -! PRINT 6002, (TO(I,K)-273.16,K=1,KMAX) -! PRINT *, ' QO =' -! PRINT 6003, (QO(I,K),K=1,KMAX) -! PRINT *, ' QSO =' -! PRINT 6003, (QESO(I,K),K=1,KMAX) -! ENDIF -! -! LOOK FOR CONVECTIVE CLOUD BASE AS THE LEVEL OF FREE CONVECTION -! - DO I=1,IM - IF(CNVFLG(I)) THEN - INDX = KB(I) - HKBO(I) = HEO(I,INDX) - QKBO(I) = QO(I,INDX) - UKBO(I) = UO(I,INDX) - VKBO(I) = VO(I,INDX) - ENDIF - FLG(I) = CNVFLG(I) - KBCON(I) = KMAX(I) - ENDDO -!! - DO K = 1, KM - DO I=1,IM - if (k .le. kbmax(i)) then - IF(FLG(I).AND.K.GT.KB(I)) THEN - HSBAR(I) = HESO(I,k) - IF(HKBO(I).GT.HSBAR(I)) THEN - FLG(I) = .FALSE. - KBCON(I) = K - ENDIF - ENDIF - endif - ENDDO - ENDDO - DO I=1,IM - IF(CNVFLG(I)) THEN - PBCDIF(I) = -PFLD(I,KBCON(I)) + PFLD(I,KB(I)) - PDOT(I) = 10.* DOT(I,KBCON(I)) - IF(PBCDIF(I).GT.150.) CNVFLG(I) = .FALSE. - IF(KBCON(I).EQ.KMAX(I)) CNVFLG(I) = .FALSE. - ENDIF - ENDDO -!! - TOTFLG = .TRUE. - DO I=1,IM - TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I)) - ENDDO - IF(TOTFLG) RETURN -! FOUND LFC, CAN DEFINE REST OF VARIABLES - 6001 FORMAT(2X,-2P10F12.2) - 6002 FORMAT(2X,10F12.2) - 6003 FORMAT(2X,3P10F12.2) - -! -! DETERMINE ENTRAINMENT RATE BETWEEN KB AND KBCON -! - DO I = 1, IM - alpha = alphas - if(SLIMSK(I).eq.1.) alpha = alphal - IF(CNVFLG(I)) THEN - IF(KB(I).EQ.1) THEN - DZ = .5 * (ZO(I,KBCON(I)) + ZO(I,KBCON(I)-1)) - ZO(I,1) - ELSE - DZ = .5 * (ZO(I,KBCON(I)) + ZO(I,KBCON(I)-1)) & - & - .5 * (ZO(I,KB(I)) + ZO(I,KB(I)-1)) - ENDIF - IF(KBCON(I).NE.KB(I)) THEN -!cmr XLAMB(I) = -ALOG(ALPHA) / DZ - XLAMB(I) = - LOG(ALPHA) / DZ - ELSE - XLAMB(I) = 0. - ENDIF - ENDIF - ENDDO -! DETERMINE UPDRAFT MASS FLUX - DO K = 1, KM - DO I = 1, IM - if (k .le. kmax(i) .and. CNVFLG(I)) then - ETA(I,k) = 1. - ETAU(I,k) = 1. - ENDIF - ENDDO - ENDDO - DO K = KM1, 2, -1 - DO I = 1, IM - if (k .le. kbmax(i)) then - IF(CNVFLG(I).AND.K.LT.KBCON(I).AND.K.GE.KB(I)) THEN - DZ = .5 * (ZO(I,k+1) - ZO(I,k-1)) - ETA(I,k) = ETA(I,k+1) * EXP(-XLAMB(I) * DZ) - ETAU(I,k) = ETA(I,k) - ENDIF - endif - ENDDO - ENDDO - DO I = 1, IM - IF(CNVFLG(I).AND.KB(I).EQ.1.AND.KBCON(I).GT.1) THEN - DZ = .5 * (ZO(I,2) - ZO(I,1)) - ETA(I,1) = ETA(I,2) * EXP(-XLAMB(I) * DZ) - ETAU(I,1) = ETA(I,1) - ENDIF - ENDDO -! -! WORK UP UPDRAFT CLOUD PROPERTIES -! - DO I = 1, IM - IF(CNVFLG(I)) THEN - INDX = KB(I) - HCKO(I,INDX) = HKBO(I) - QCKO(I,INDX) = QKBO(I) - UCKO(I,INDX) = UKBO(I) - VCKO(I,INDX) = VKBO(I) - PWAVO(I) = 0. - ENDIF - ENDDO -! -! CLOUD PROPERTY BELOW CLOUD BASE IS MODIFIED BY THE ENTRAINMENT PROCES -! - DO K = 2, KM1 - DO I = 1, IM - if (k .le. kmax(i)-1) then - IF(CNVFLG(I).AND.K.GT.KB(I).AND.K.LE.KBCON(I)) THEN - FACTOR = ETA(I,k-1) / ETA(I,k) - ONEMF = 1. - FACTOR - HCKO(I,k) = FACTOR * HCKO(I,k-1) + ONEMF * & - & .5 * (HEO(I,k) + HEO(I,k+1)) - UCKO(I,k) = FACTOR * UCKO(I,k-1) + ONEMF * & - & .5 * (UO(I,k) + UO(I,k+1)) - VCKO(I,k) = FACTOR * VCKO(I,k-1) + ONEMF * & - & .5 * (VO(I,k) + VO(I,k+1)) - DBYO(I,k) = HCKO(I,k) - HESO(I,k) - ENDIF - IF(CNVFLG(I).AND.K.GT.KBCON(I)) THEN - HCKO(I,k) = HCKO(I,k-1) - UCKO(I,k) = UCKO(I,k-1) - VCKO(I,k) = VCKO(I,k-1) - DBYO(I,k) = HCKO(I,k) - HESO(I,k) - ENDIF - endif - ENDDO - ENDDO -! DETERMINE CLOUD TOP - DO I = 1, IM - FLG(I) = CNVFLG(I) - KTCON(I) = 1 - ENDDO -! DO K = 2, KMAX -! KK = KMAX - K + 1 -! IF(DBYO(I,kK).GE.0..AND.FLG(I).AND.KK.GT.KBCON(I)) THEN -! KTCON(I) = KK + 1 -! FLG(I) = .FALSE. -! ENDIF -! ENDDO - DO K = 2, KM - DO I = 1, IM - if (k .le. kmax(i)) then - IF(DBYO(I,k).LT.0..AND.FLG(I).AND.K.GT.KBCON(I)) THEN - KTCON(I) = K - FLG(I) = .FALSE. - ENDIF - endif - ENDDO - ENDDO - DO I = 1, IM - IF(CNVFLG(I).AND.(PFLD(I,KBCON(I)) - PFLD(I,KTCON(I))).LT.150.) & - & CNVFLG(I) = .FALSE. - ENDDO - TOTFLG = .TRUE. - DO I = 1, IM - TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I)) - ENDDO - IF(TOTFLG) RETURN -! -! SEARCH FOR DOWNDRAFT ORIGINATING LEVEL ABOVE THETA-E MINIMUM -! - DO I = 1, IM - HMIN(I) = HEO(I,KBCON(I)) - LMIN(I) = KBMAX(I) - JMIN(I) = KBMAX(I) - ENDDO - DO I = 1, IM - DO K = KBCON(I), KBMAX(I) - IF(HEO(I,k).LT.HMIN(I).AND.CNVFLG(I)) THEN - LMIN(I) = K + 1 - HMIN(I) = HEO(I,k) - ENDIF - ENDDO - ENDDO -! -! Make sure that JMIN(I) is within the cloud -! - DO I = 1, IM - IF(CNVFLG(I)) THEN - JMIN(I) = MIN(LMIN(I),KTCON(I)-1) - XMBMAX(I) = .1 - JMIN(I) = MAX(JMIN(I),KBCON(I)+1) - ENDIF - ENDDO -! -! ENTRAINING CLOUD -! - do k = 2, km1 - DO I = 1, IM - if (k .le. kmax(i)-1) then - if(CNVFLG(I).and.k.gt.JMIN(I).and.k.le.KTCON(I)) THEN - SUMZ(I,k) = SUMZ(I,k-1) + .5 * (ZO(I,k+1) - ZO(I,k-1)) - SUMH(I,k) = SUMH(I,k-1) + .5 * (ZO(I,k+1) - ZO(I,k-1)) & - & * HEO(I,k) - ENDIF - endif - enddo - enddo -!! - DO I = 1, IM - IF(CNVFLG(I)) THEN -! call random_number(XKT2) -! call srand(fhour) -! XKT2(I) = rand() - KT2(I) = nint(XKT2(I)*float(KTCON(I)-JMIN(I))-.5)+JMIN(I)+1 -! KT2(I) = nint(sqrt(XKT2(I))*float(KTCON(I)-JMIN(I))-.5) + JMIN(I) + 1 -! KT2(I) = nint(ranf() *float(KTCON(I)-JMIN(I))-.5) + JMIN(I) + 1 - tem1 = (HCKO(I,JMIN(I)) - HESO(I,KT2(I))) - tem2 = (SUMZ(I,KT2(I)) * HESO(I,KT2(I)) - SUMH(I,KT2(I))) - if (abs(tem2) .gt. 0.000001) THEN - XLAMB(I) = tem1 / tem2 - else - CNVFLG(I) = .false. - ENDIF -! XLAMB(I) = (HCKO(I,JMIN(I)) - HESO(I,KT2(I))) -! & / (SUMZ(I,KT2(I)) * HESO(I,KT2(I)) - SUMH(I,KT2(I))) - XLAMB(I) = max(XLAMB(I),RZERO) - XLAMB(I) = min(XLAMB(I),2.3/SUMZ(I,KT2(I))) - ENDIF - ENDDO -!! - DO I = 1, IM - DWNFLG(I) = CNVFLG(I) - DWNFLG2(I) = CNVFLG(I) - IF(CNVFLG(I)) THEN - if(KT2(I).ge.KTCON(I)) DWNFLG(I) = .false. - if(XLAMB(I).le.1.e-30.or.HCKO(I,JMIN(I))-HESO(I,KT2(I)).le.1.e-30)& - & DWNFLG(I) = .false. - do k = JMIN(I), KT2(I) - if(DWNFLG(I).and.HEO(I,k).gt.HESO(I,KT2(I))) DWNFLG(I)=.false. - enddo -! IF(CNVFLG(I).AND.(PFLD(KBCON(I))-PFLD(KTCON(I))).GT.PDETRN) -! & DWNFLG(I)=.FALSE. - IF(CNVFLG(I).AND.(PFLD(I,KBCON(I))-PFLD(I,KTCON(I))).LT.PDPDWN) & - & DWNFLG2(I)=.FALSE. - ENDIF - ENDDO -!! - DO K = 2, KM1 - DO I = 1, IM - if (k .le. kmax(i)-1) then - IF(DWNFLG(I).AND.K.GT.JMIN(I).AND.K.LE.KT2(I)) THEN - DZ = .5 * (ZO(I,k+1) - ZO(I,k-1)) -! ETA(I,k) = ETA(I,k-1) * EXP( XLAMB(I) * DZ) -! to simplify matter, we will take the linear approach here -! - ETA(I,k) = ETA(I,k-1) * (1. + XLAMB(I) * dz) - ETAU(I,k) = ETAU(I,k-1) * (1. + (XLAMB(I)+xlambu) * dz) - ENDIF - endif - ENDDO - ENDDO -!! - DO K = 2, KM1 - DO I = 1, IM - if (k .le. kmax(i)-1) then -! IF(.NOT.DWNFLG(I).AND.K.GT.JMIN(I).AND.K.LE.KT2(I)) THEN - IF(.NOT.DWNFLG(I).AND.K.GT.JMIN(I).AND.K.LE.KTCON(I)) THEN - DZ = .5 * (ZO(I,k+1) - ZO(I,k-1)) - ETAU(I,k) = ETAU(I,k-1) * (1. + xlambu * dz) - ENDIF - endif - ENDDO - ENDDO -! IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I)) THEN -! PRINT *, ' LMIN(I), KT2(I)=', LMIN(I), KT2(I) -! PRINT *, ' KBOT, KTOP, JMIN(I) =', KBCON(I), KTCON(I), JMIN(I) -! ENDIF -! IF(LAT.EQ.LATD.AND.lon.eq.lond) THEN -! print *, ' xlamb =', xlamb -! print *, ' eta =', (eta(k),k=1,KT2(I)) -! print *, ' ETAU =', (ETAU(I,k),k=1,KT2(I)) -! print *, ' HCKO =', (HCKO(I,k),k=1,KT2(I)) -! print *, ' SUMZ =', (SUMZ(I,k),k=1,KT2(I)) -! print *, ' SUMH =', (SUMH(I,k),k=1,KT2(I)) -! ENDIF - DO I = 1, IM - if(DWNFLG(I)) THEN - KTCON(I) = KT2(I) - ENDIF - ENDDO -! -! CLOUD PROPERTY ABOVE CLOUD Base IS MODIFIED BY THE DETRAINMENT PROCESS -! - DO K = 2, KM1 - DO I = 1, IM - if (k .le. kmax(i)-1) then -!jfe - IF(CNVFLG(I).AND.K.GT.KBCON(I).AND.K.LE.KTCON(I)) THEN -!jfe IF(K.GT.KBCON(I).AND.K.LE.KTCON(I)) THEN - FACTOR = ETA(I,k-1) / ETA(I,k) - ONEMF = 1. - FACTOR - fuv = ETAU(I,k-1) / ETAU(I,k) - onemfu = 1. - fuv - HCKO(I,k) = FACTOR * HCKO(I,k-1) + ONEMF * & - & .5 * (HEO(I,k) + HEO(I,k+1)) - UCKO(I,k) = fuv * UCKO(I,k-1) + ONEMFu * & - & .5 * (UO(I,k) + UO(I,k+1)) - VCKO(I,k) = fuv * VCKO(I,k-1) + ONEMFu * & - & .5 * (VO(I,k) + VO(I,k+1)) - DBYO(I,k) = HCKO(I,k) - HESO(I,k) - ENDIF - endif - ENDDO - ENDDO -! IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I)) THEN -! PRINT *, ' UCKO=', (UCKO(I,k),k=KBCON(I)+1,KTCON(I)) -! PRINT *, ' uenv=', (.5*(UO(I,k)+UO(I,k-1)),k=KBCON(I)+1,KTCON(I)) -! ENDIF - DO I = 1, IM - if(CNVFLG(I).and.DWNFLG2(I).and.JMIN(I).le.KBCON(I)) & - & THEN - CNVFLG(I) = .false. - DWNFLG(I) = .false. - DWNFLG2(I) = .false. - ENDIF - ENDDO -!! - TOTFLG = .TRUE. - DO I = 1, IM - TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I)) - ENDDO - IF(TOTFLG) RETURN -!! -! -! COMPUTE CLOUD MOISTURE PROPERTY AND PRECIPITATION -! - DO I = 1, IM - AA1(I) = 0. - RHBAR(I) = 0. - ENDDO - DO K = 1, KM - DO I = 1, IM - if (k .le. kmax(i)) then - IF(CNVFLG(I).AND.K.GT.KB(I).AND.K.LT.KTCON(I)) THEN - DZ = .5 * (ZO(I,k+1) - ZO(I,k-1)) - DZ1 = (ZO(I,k) - ZO(I,k-1)) - GAMMA = EL2ORC * QESO(I,k) / (TO(I,k)**2) - QRCH = QESO(I,k) & - & + GAMMA * DBYO(I,k) / (HVAP * (1. + GAMMA)) - FACTOR = ETA(I,k-1) / ETA(I,k) - ONEMF = 1. - FACTOR - QCKO(I,k) = FACTOR * QCKO(I,k-1) + ONEMF * & - & .5 * (QO(I,k) + QO(I,k+1)) - DQ = ETA(I,k) * QCKO(I,k) - ETA(I,k) * QRCH - RHBAR(I) = RHBAR(I) + QO(I,k) / QESO(I,k) -! -! BELOW LFC CHECK IF THERE IS EXCESS MOISTURE TO RELEASE LATENT HEAT -! - IF(DQ.GT.0.) THEN - ETAH = .5 * (ETA(I,k) + ETA(I,k-1)) - QLK = DQ / (ETA(I,k) + ETAH * C0 * DZ) - AA1(I) = AA1(I) - DZ1 * G * QLK - QC = QLK + QRCH - PWO(I,k) = ETAH * C0 * DZ * QLK - QCKO(I,k) = QC - PWAVO(I) = PWAVO(I) + PWO(I,k) - ENDIF - ENDIF - endif - ENDDO - ENDDO - DO I = 1, IM - RHBAR(I) = RHBAR(I) / float(KTCON(I) - KB(I) - 1) - ENDDO -! -! this section is ready for cloud water -! - if(ncloud.gt.0) THEN -! -! compute liquid and vapor separation at cloud top -! - DO I = 1, IM - k = KTCON(I) - IF(CNVFLG(I)) THEN - GAMMA = EL2ORC * QESO(I,K) / (TO(I,K)**2) - QRCH = QESO(I,K) & - & + GAMMA * DBYO(I,K) / (HVAP * (1. + GAMMA)) - DQ = QCKO(I,K-1) - QRCH -! -! CHECK IF THERE IS EXCESS MOISTURE TO RELEASE LATENT HEAT -! - IF(DQ.GT.0.) THEN - QLKO_KTCON(I) = dq - QCKO(I,K-1) = QRCH - ENDIF - ENDIF - ENDDO - ENDIF -! -! CALCULATE CLOUD WORK FUNCTION AT T+DT -! - DO K = 1, KM - DO I = 1, IM - if (k .le. kmax(i)) then - IF(CNVFLG(I).AND.K.GT.KBCON(I).AND.K.LE.KTCON(I)) THEN - DZ1 = ZO(I,k) - ZO(I,k-1) - GAMMA = EL2ORC * QESO(I,k-1) / (TO(I,k-1)**2) - RFACT = 1. + DELTA * CP * GAMMA & - & * TO(I,k-1) / HVAP - AA1(I) = AA1(I) + & - & DZ1 * (G / (CP * TO(I,k-1))) & - & * DBYO(I,k-1) / (1. + GAMMA) & - & * RFACT - val = 0. - AA1(I)=AA1(I)+ & - & DZ1 * G * DELTA * & -!cmr & MAX( 0.,(QESO(I,k-1) - QO(I,k-1))) & - & MAX(val,(QESO(I,k-1) - QO(I,k-1))) - ENDIF - endif - ENDDO - ENDDO - DO I = 1, IM - IF(CNVFLG(I).AND.AA1(I).LE.0.) DWNFLG(I) = .FALSE. - IF(CNVFLG(I).AND.AA1(I).LE.0.) DWNFLG2(I) = .FALSE. - IF(CNVFLG(I).AND.AA1(I).LE.0.) CNVFLG(I) = .FALSE. - ENDDO -!! - TOTFLG = .TRUE. - DO I = 1, IM - TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I)) - ENDDO - IF(TOTFLG) RETURN -!! -!cccc IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I)) THEN -!cccc PRINT *, ' AA1(I) BEFORE DWNDRFT =', AA1(I) -!cccc ENDIF -! -!------- DOWNDRAFT CALCULATIONS -! -! -!--- DETERMINE DOWNDRAFT STRENGTH IN TERMS OF WINDSHEAR -! - DO I = 1, IM - IF(CNVFLG(I)) THEN - VSHEAR(I) = 0. - ENDIF - ENDDO - DO K = 1, KM - DO I = 1, IM - if (k .le. kmax(i)) then - IF(K.GE.KB(I).AND.K.LE.KTCON(I).AND.CNVFLG(I)) THEN - shear=rcs(I) * sqrt((UO(I,k+1)-UO(I,k)) ** 2 & - & + (VO(I,k+1)-VO(I,k)) ** 2) - VSHEAR(I) = VSHEAR(I) + SHEAR - ENDIF - endif - ENDDO - ENDDO - DO I = 1, IM - EDT(I) = 0. - IF(CNVFLG(I)) THEN - KNUMB = KTCON(I) - KB(I) + 1 - KNUMB = MAX(KNUMB,1) - VSHEAR(I) = 1.E3 * VSHEAR(I) / (ZO(I,KTCON(I))-ZO(I,KB(I))) - E1=1.591-.639*VSHEAR(I) & - & +.0953*(VSHEAR(I)**2)-.00496*(VSHEAR(I)**3) - EDT(I)=1.-E1 -!cmr EDT(I) = MIN(EDT(I),.9) - val = .9 - EDT(I) = MIN(EDT(I),val) -!cmr EDT(I) = MAX(EDT(I),.0) - val = .0 - EDT(I) = MAX(EDT(I),val) - EDTO(I)=EDT(I) - EDTX(I)=EDT(I) - ENDIF - ENDDO -! DETERMINE DETRAINMENT RATE BETWEEN 1 AND KBDTR - DO I = 1, IM - KBDTR(I) = KBCON(I) - beta = betas - if(SLIMSK(I).eq.1.) beta = betal - IF(CNVFLG(I)) THEN - KBDTR(I) = KBCON(I) - KBDTR(I) = MAX(KBDTR(I),1) - XLAMD(I) = 0. - IF(KBDTR(I).GT.1) THEN - DZ = .5 * ZO(I,KBDTR(I)) + .5 * ZO(I,KBDTR(I)-1) & - & - ZO(I,1) - XLAMD(I) = LOG(BETA) / DZ - ENDIF - ENDIF - ENDDO -! DETERMINE DOWNDRAFT MASS FLUX - DO K = 1, KM - DO I = 1, IM - IF(k .le. kmax(i)) then - IF(CNVFLG(I)) THEN - ETAD(I,k) = 1. - ENDIF - QRCDO(I,k) = 0. - endif - ENDDO - ENDDO - DO K = KM1, 2, -1 - DO I = 1, IM - if (k .le. kbmax(i)) then - IF(CNVFLG(I).AND.K.LT.KBDTR(I)) THEN - DZ = .5 * (ZO(I,k+1) - ZO(I,k-1)) - ETAD(I,k) = ETAD(I,k+1) * EXP(XLAMD(I) * DZ) - ENDIF - endif - ENDDO - ENDDO - K = 1 - DO I = 1, IM - IF(CNVFLG(I).AND.KBDTR(I).GT.1) THEN - DZ = .5 * (ZO(I,2) - ZO(I,1)) - ETAD(I,k) = ETAD(I,k+1) * EXP(XLAMD(I) * DZ) - ENDIF - ENDDO -! -!--- DOWNDRAFT MOISTURE PROPERTIES -! - DO I = 1, IM - PWEVO(I) = 0. - FLG(I) = CNVFLG(I) - ENDDO - DO I = 1, IM - IF(CNVFLG(I)) THEN - JMN = JMIN(I) - HCDO(I) = HEO(I,JMN) - QCDO(I) = QO(I,JMN) - QRCDO(I,JMN) = QESO(I,JMN) - UCDO(I) = UO(I,JMN) - VCDO(I) = VO(I,JMN) - ENDIF - ENDDO - DO K = KM1, 1, -1 - DO I = 1, IM - if (k .le. kmax(i)-1) then - IF(CNVFLG(I).AND.K.LT.JMIN(I)) THEN - DQ = QESO(I,k) - DT = TO(I,k) - GAMMA = EL2ORC * DQ / DT**2 - DH = HCDO(I) - HESO(I,k) - QRCDO(I,k) = DQ+(1./HVAP)*(GAMMA/(1.+GAMMA))*DH - DETAD = ETAD(I,k+1) - ETAD(I,k) - PWDO(I,k) = ETAD(I,k+1) * QCDO(I) - & - & ETAD(I,k) * QRCDO(I,k) - PWDO(I,k) = PWDO(I,k) - DETAD * & - & .5 * (QRCDO(I,k) + QRCDO(I,k+1)) - QCDO(I) = QRCDO(I,k) - PWEVO(I) = PWEVO(I) + PWDO(I,k) - ENDIF - endif - ENDDO - ENDDO -! IF(LAT.EQ.LATD.AND.lon.eq.lond.and.DWNFLG(I)) THEN -! PRINT *, ' PWAVO(I), PWEVO(I) =', PWAVO(I), PWEVO(I) -! ENDIF -! -!--- FINAL DOWNDRAFT STRENGTH DEPENDENT ON PRECIP -!--- EFFICIENCY (EDT), NORMALIZED CONDENSATE (PWAV), AND -!--- EVAPORATE (PWEV) -! - DO I = 1, IM - edtmax = edtmaxl - if(SLIMSK(I).eq.0.) edtmax = edtmaxs - IF(DWNFLG2(I)) THEN - IF(PWEVO(I).LT.0.) THEN - EDTO(I) = -EDTO(I) * PWAVO(I) / PWEVO(I) - EDTO(I) = MIN(EDTO(I),EDTMAX) - ELSE - EDTO(I) = 0. - ENDIF - ELSE - EDTO(I) = 0. - ENDIF - ENDDO -! -! -!--- DOWNDRAFT CLOUDWORK FUNCTIONS -! -! - DO K = KM1, 1, -1 - DO I = 1, IM - if (k .le. kmax(i)-1) then - IF(DWNFLG2(I).AND.K.LT.JMIN(I)) THEN - GAMMA = EL2ORC * QESO(I,k+1) / TO(I,k+1)**2 - DHH=HCDO(I) - DT=TO(I,k+1) - DG=GAMMA - DH=HESO(I,k+1) - DZ=-1.*(ZO(I,k+1)-ZO(I,k)) - AA1(I)=AA1(I)+EDTO(I)*DZ*(G/(CP*DT))*((DHH-DH)/(1.+DG)) & - & *(1.+DELTA*CP*DG*DT/HVAP) - val=0. - AA1(I)=AA1(I)+EDTO(I)* & -!cmr & DZ*G*DELTA*MAX( 0.,(QESO(I,k+1)-QO(I,k+1))) & - & DZ*G*DELTA*MAX(val,(QESO(I,k+1)-QO(I,k+1))) - ENDIF - endif - ENDDO - ENDDO -!cccc IF(LAT.EQ.LATD.AND.lon.eq.lond.and.DWNFLG2(I)) THEN -!cccc PRINT *, ' AA1(I) AFTER DWNDRFT =', AA1(I) -!cccc ENDIF - DO I = 1, IM - IF(AA1(I).LE.0.) CNVFLG(I) = .FALSE. - IF(AA1(I).LE.0.) DWNFLG(I) = .FALSE. - IF(AA1(I).LE.0.) DWNFLG2(I) = .FALSE. - ENDDO -!! - TOTFLG = .TRUE. - DO I = 1, IM - TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I)) - ENDDO - IF(TOTFLG) RETURN -!! -! -! -!--- WHAT WOULD THE CHANGE BE, THAT A CLOUD WITH UNIT MASS -!--- WILL DO TO THE ENVIRONMENT? -! - DO K = 1, KM - DO I = 1, IM - IF(k .le. kmax(i) .and. CNVFLG(I)) THEN - DELLAH(I,k) = 0. - DELLAQ(I,k) = 0. - DELLAU(I,k) = 0. - DELLAV(I,k) = 0. - ENDIF - ENDDO - ENDDO - DO I = 1, IM - IF(CNVFLG(I)) THEN - DP = 1000. * DEL(I,1) - DELLAH(I,1) = EDTO(I) * ETAD(I,1) * (HCDO(I) & - & - HEO(I,1)) * G / DP - DELLAQ(I,1) = EDTO(I) * ETAD(I,1) * (QCDO(I) & - & - QO(I,1)) * G / DP - DELLAU(I,1) = EDTO(I) * ETAD(I,1) * (UCDO(I) & - & - UO(I,1)) * G / DP - DELLAV(I,1) = EDTO(I) * ETAD(I,1) * (VCDO(I) & - & - VO(I,1)) * G / DP - ENDIF - ENDDO -! -!--- CHANGED DUE TO SUBSIDENCE AND ENTRAINMENT -! - DO K = 2, KM1 - DO I = 1, IM - if (k .le. kmax(i)-1) then - IF(CNVFLG(I).AND.K.LT.KTCON(I)) THEN - AUP = 1. - IF(K.LE.KB(I)) AUP = 0. - ADW = 1. - IF(K.GT.JMIN(I)) ADW = 0. - DV1= HEO(I,k) - DV2 = .5 * (HEO(I,k) + HEO(I,k+1)) - DV3= HEO(I,k-1) - DV1Q= QO(I,k) - DV2Q = .5 * (QO(I,k) + QO(I,k+1)) - DV3Q= QO(I,k-1) - DV1U= UO(I,k) - DV2U = .5 * (UO(I,k) + UO(I,k+1)) - DV3U= UO(I,k-1) - DV1V= VO(I,k) - DV2V = .5 * (VO(I,k) + VO(I,k+1)) - DV3V= VO(I,k-1) - DP = 1000. * DEL(I,K) - DZ = .5 * (ZO(I,k+1) - ZO(I,k-1)) - DETA = ETA(I,k) - ETA(I,k-1) - DETAD = ETAD(I,k) - ETAD(I,k-1) - DELLAH(I,k) = DELLAH(I,k) + & - & ((AUP * ETA(I,k) - ADW * EDTO(I) * ETAD(I,k)) * DV1 & - & - (AUP * ETA(I,k-1) - ADW * EDTO(I) * ETAD(I,k-1))* DV3 & - & - AUP * DETA * DV2 & - & + ADW * EDTO(I) * DETAD * HCDO(I)) * G / DP - DELLAQ(I,k) = DELLAQ(I,k) + & - & ((AUP * ETA(I,k) - ADW * EDTO(I) * ETAD(I,k)) * DV1Q & - & - (AUP * ETA(I,k-1) - ADW * EDTO(I) * ETAD(I,k-1))* DV3Q & - & - AUP * DETA * DV2Q & - & +ADW*EDTO(I)*DETAD*.5*(QRCDO(I,k)+QRCDO(I,k-1))) * G / DP - DELLAU(I,k) = DELLAU(I,k) + & - & ((AUP * ETA(I,k) - ADW * EDTO(I) * ETAD(I,k)) * DV1U & - & - (AUP * ETA(I,k-1) - ADW * EDTO(I) * ETAD(I,k-1))* DV3U & - & - AUP * DETA * DV2U & - & + ADW * EDTO(I) * DETAD * UCDO(I) & - & ) * G / DP - DELLAV(I,k) = DELLAV(I,k) + & - & ((AUP * ETA(I,k) - ADW * EDTO(I) * ETAD(I,k)) * DV1V & - & - (AUP * ETA(I,k-1) - ADW * EDTO(I) * ETAD(I,k-1))* DV3V & - & - AUP * DETA * DV2V & - & + ADW * EDTO(I) * DETAD * VCDO(I) & - & ) * G / DP - ENDIF - endif - ENDDO - ENDDO -! -!------- CLOUD TOP -! - DO I = 1, IM - IF(CNVFLG(I)) THEN - INDX = KTCON(I) - DP = 1000. * DEL(I,INDX) - DV1 = HEO(I,INDX-1) - DELLAH(I,INDX) = ETA(I,INDX-1) * & - & (HCKO(I,INDX-1) - DV1) * G / DP - DVQ1 = QO(I,INDX-1) - DELLAQ(I,INDX) = ETA(I,INDX-1) * & - & (QCKO(I,INDX-1) - DVQ1) * G / DP - DV1U = UO(I,INDX-1) - DELLAU(I,INDX) = ETA(I,INDX-1) * & - & (UCKO(I,INDX-1) - DV1U) * G / DP - DV1V = VO(I,INDX-1) - DELLAV(I,INDX) = ETA(I,INDX-1) * & - & (VCKO(I,INDX-1) - DV1V) * G / DP -! -! cloud water -! - DELLAL(I) = ETA(I,INDX-1) * QLKO_KTCON(I) * g / dp - ENDIF - ENDDO -! -!------- FINAL CHANGED VARIABLE PER UNIT MASS FLUX -! - DO K = 1, KM - DO I = 1, IM - if (k .le. kmax(i)) then - IF(CNVFLG(I).and.k.gt.KTCON(I)) THEN - QO(I,k) = Q1(I,k) - TO(I,k) = T1(I,k) - UO(I,k) = U1(I,k) - VO(I,k) = V1(I,k) - ENDIF - IF(CNVFLG(I).AND.K.LE.KTCON(I)) THEN - QO(I,k) = DELLAQ(I,k) * MBDT + Q1(I,k) - DELLAT = (DELLAH(I,k) - HVAP * DELLAQ(I,k)) / CP - TO(I,k) = DELLAT * MBDT + T1(I,k) -!cmr QO(I,k) = max(QO(I,k),1.e-10) - val = 1.e-10 - QO(I,k) = max(QO(I,k), val ) - ENDIF - endif - ENDDO - ENDDO -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!--- THE ABOVE CHANGED ENVIRONMENT IS NOW USED TO CALULATE THE -!--- EFFECT THE ARBITRARY CLOUD (WITH UNIT MASS FLUX) -!--- WOULD HAVE ON THE STABILITY, -!--- WHICH THEN IS USED TO CALCULATE THE REAL MASS FLUX, -!--- NECESSARY TO KEEP THIS CHANGE IN BALANCE WITH THE LARGE-SCALE -!--- DESTABILIZATION. -! -!--- ENVIRONMENTAL CONDITIONS AGAIN, FIRST HEIGHTS -! - DO K = 1, KM - DO I = 1, IM - IF(k .le. kmax(i) .and. CNVFLG(I)) THEN -!jfe QESO(I,k) = 10. * FPVS(TO(I,k)) -! - QESO(I,k) = 0.01 * fpvs(TO(I,K)) ! fpvs is in Pa -! - QESO(I,k) = EPS * QESO(I,k) / (PFLD(I,k)+EPSM1*QESO(I,k)) -!cmr QESO(I,k) = MAX(QESO(I,k),1.E-8) - val = 1.E-8 - QESO(I,k) = MAX(QESO(I,k), val ) - TVO(I,k) = TO(I,k) + DELTA * TO(I,k) * QO(I,k) - ENDIF - ENDDO - ENDDO - DO I = 1, IM - IF(CNVFLG(I)) THEN - XAA0(I) = 0. - XPWAV(I) = 0. - ENDIF - ENDDO -! -! HYDROSTATIC HEIGHT ASSUME ZERO TERR -! -! DO I = 1, IM -! IF(CNVFLG(I)) THEN -! DLNSIG = LOG(PRSL(I,1)/PS(I)) -! ZO(I,1) = TERR - DLNSIG * RD / G * TVO(I,1) -! ENDIF -! ENDDO -! DO K = 2, KM -! DO I = 1, IM -! IF(k .le. kmax(i) .and. CNVFLG(I)) THEN -! DLNSIG = LOG(PRSL(I,K) / PRSL(I,K-1)) -! ZO(I,k) = ZO(I,k-1) - DLNSIG * RD / G -! & * .5 * (TVO(I,k) + TVO(I,k-1)) -! ENDIF -! ENDDO -! ENDDO -! -!--- MOIST STATIC ENERGY -! - DO K = 1, KM1 - DO I = 1, IM - IF(k .le. kmax(i)-1 .and. CNVFLG(I)) THEN - DZ = .5 * (ZO(I,k+1) - ZO(I,k)) - DP = .5 * (PFLD(I,k+1) - PFLD(I,k)) -!jfe ES = 10. * FPVS(TO(I,k+1)) -! - ES = 0.01 * fpvs(TO(I,K+1)) ! fpvs is in Pa -! - PPRIME = PFLD(I,k+1) + EPSM1 * ES - QS = EPS * ES / PPRIME - DQSDP = - QS / PPRIME - DESDT = ES * (FACT1 / TO(I,k+1) + FACT2 / (TO(I,k+1)**2)) - DQSDT = QS * PFLD(I,k+1) * DESDT / (ES * PPRIME) - GAMMA = EL2ORC * QESO(I,k+1) / (TO(I,k+1)**2) - DT = (G * DZ + HVAP * DQSDP * DP) / (CP * (1. + GAMMA)) - DQ = DQSDT * DT + DQSDP * DP - TO(I,k) = TO(I,k+1) + DT - QO(I,k) = QO(I,k+1) + DQ - PO(I,k) = .5 * (PFLD(I,k) + PFLD(I,k+1)) - ENDIF - ENDDO - ENDDO - DO K = 1, KM1 - DO I = 1, IM - IF(k .le. kmax(i)-1 .and. CNVFLG(I)) THEN -!jfe QESO(I,k) = 10. * FPVS(TO(I,k)) -! - QESO(I,k) = 0.01 * fpvs(TO(I,K)) ! fpvs is in Pa -! - QESO(I,k) = EPS * QESO(I,k) / (PO(I,k) + EPSM1 * QESO(I,k)) -!cmr QESO(I,k) = MAX(QESO(I,k),1.E-8) - val1 = 1.E-8 - QESO(I,k) = MAX(QESO(I,k), val1) -!cmr QO(I,k) = max(QO(I,k),1.e-10) - val2 = 1.e-10 - QO(I,k) = max(QO(I,k), val2 ) -! QO(I,k) = MIN(QO(I,k),QESO(I,k)) - HEO(I,k) = .5 * G * (ZO(I,k) + ZO(I,k+1)) + & - & CP * TO(I,k) + HVAP * QO(I,k) - HESO(I,k) = .5 * G * (ZO(I,k) + ZO(I,k+1)) + & - & CP * TO(I,k) + HVAP * QESO(I,k) - ENDIF - ENDDO - ENDDO - DO I = 1, IM - k = kmax(i) - IF(CNVFLG(I)) THEN - HEO(I,k) = G * ZO(I,k) + CP * TO(I,k) + HVAP * QO(I,k) - HESO(I,k) = G * ZO(I,k) + CP * TO(I,k) + HVAP * QESO(I,k) -! HEO(I,k) = MIN(HEO(I,k),HESO(I,k)) - ENDIF - ENDDO - DO I = 1, IM - IF(CNVFLG(I)) THEN - INDX = KB(I) - XHKB(I) = HEO(I,INDX) - XQKB(I) = QO(I,INDX) - HCKO(I,INDX) = XHKB(I) - QCKO(I,INDX) = XQKB(I) - ENDIF - ENDDO -! -! -!**************************** STATIC CONTROL -! -! -!------- MOISTURE AND CLOUD WORK FUNCTIONS -! - DO K = 2, KM1 - DO I = 1, IM - if (k .le. kmax(i)-1) then -! IF(CNVFLG(I).AND.K.GT.KB(I).AND.K.LE.KBCON(I)) THEN - IF(CNVFLG(I).AND.K.GT.KB(I).AND.K.LE.KTCON(I)) THEN - FACTOR = ETA(I,k-1) / ETA(I,k) - ONEMF = 1. - FACTOR - HCKO(I,k) = FACTOR * HCKO(I,k-1) + ONEMF * & - & .5 * (HEO(I,k) + HEO(I,k+1)) - ENDIF -! IF(CNVFLG(I).AND.K.GT.KBCON(I)) THEN -! HEO(I,k) = HEO(I,k-1) -! ENDIF - endif - ENDDO - ENDDO - DO K = 2, KM1 - DO I = 1, IM - if (k .le. kmax(i)-1) then - IF(CNVFLG(I).AND.K.GT.KB(I).AND.K.LT.KTCON(I)) THEN - DZ = .5 * (ZO(I,k+1) - ZO(I,k-1)) - GAMMA = EL2ORC * QESO(I,k) / (TO(I,k)**2) - XDBY = HCKO(I,k) - HESO(I,k) -!cmr XDBY = MAX(XDBY,0.) - val = 0. - XDBY = MAX(XDBY,val) - XQRCH = QESO(I,k) & - & + GAMMA * XDBY / (HVAP * (1. + GAMMA)) - FACTOR = ETA(I,k-1) / ETA(I,k) - ONEMF = 1. - FACTOR - QCKO(I,k) = FACTOR * QCKO(I,k-1) + ONEMF * & - & .5 * (QO(I,k) + QO(I,k+1)) - DQ = ETA(I,k) * QCKO(I,k) - ETA(I,k) * XQRCH - IF(DQ.GT.0.) THEN - ETAH = .5 * (ETA(I,k) + ETA(I,k-1)) - QLK = DQ / (ETA(I,k) + ETAH * C0 * DZ) - XAA0(I) = XAA0(I) - (ZO(I,k) - ZO(I,k-1)) * G * QLK - XQC = QLK + XQRCH - XPW = ETAH * C0 * DZ * QLK - QCKO(I,k) = XQC - XPWAV(I) = XPWAV(I) + XPW - ENDIF - ENDIF -! IF(CNVFLG(I).AND.K.GT.KBCON(I).AND.K.LT.KTCON(I)) THEN - IF(CNVFLG(I).AND.K.GT.KBCON(I).AND.K.LE.KTCON(I)) THEN - DZ1 = ZO(I,k) - ZO(I,k-1) - GAMMA = EL2ORC * QESO(I,k-1) / (TO(I,k-1)**2) - RFACT = 1. + DELTA * CP * GAMMA & - & * TO(I,k-1) / HVAP - XDBY = HCKO(I,k-1) - HESO(I,k-1) - XAA0(I) = XAA0(I) & - & + DZ1 * (G / (CP * TO(I,k-1))) & - & * XDBY / (1. + GAMMA) & - & * RFACT - val=0. - XAA0(I)=XAA0(I)+ & - & DZ1 * G * DELTA * & -!cmr & MAX( 0.,(QESO(I,k-1) - QO(I,k-1))) & - & MAX(val,(QESO(I,k-1) - QO(I,k-1))) - ENDIF - endif - ENDDO - ENDDO -!cccc IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I)) THEN -!cccc PRINT *, ' XAA BEFORE DWNDRFT =', XAA0(I) -!cccc ENDIF -! -!------- DOWNDRAFT CALCULATIONS -! -! -!--- DOWNDRAFT MOISTURE PROPERTIES -! - DO I = 1, IM - XPWEV(I) = 0. - ENDDO - DO I = 1, IM - IF(DWNFLG2(I)) THEN - JMN = JMIN(I) - XHCD(I) = HEO(I,JMN) - XQCD(I) = QO(I,JMN) - QRCD(I,JMN) = QESO(I,JMN) - ENDIF - ENDDO - DO K = KM1, 1, -1 - DO I = 1, IM - if (k .le. kmax(i)-1) then - IF(DWNFLG2(I).AND.K.LT.JMIN(I)) THEN - DQ = QESO(I,k) - DT = TO(I,k) - GAMMA = EL2ORC * DQ / DT**2 - DH = XHCD(I) - HESO(I,k) - QRCD(I,k)=DQ+(1./HVAP)*(GAMMA/(1.+GAMMA))*DH - DETAD = ETAD(I,k+1) - ETAD(I,k) - XPWD = ETAD(I,k+1) * QRCD(I,k+1) - & - & ETAD(I,k) * QRCD(I,k) - XPWD = XPWD - DETAD * & - & .5 * (QRCD(I,k) + QRCD(I,k+1)) - XPWEV(I) = XPWEV(I) + XPWD - ENDIF - endif - ENDDO - ENDDO -! - DO I = 1, IM - edtmax = edtmaxl - if(SLIMSK(I).eq.0.) edtmax = edtmaxs - IF(DWNFLG2(I)) THEN - IF(XPWEV(I).GE.0.) THEN - EDTX(I) = 0. - ELSE - EDTX(I) = -EDTX(I) * XPWAV(I) / XPWEV(I) - EDTX(I) = MIN(EDTX(I),EDTMAX) - ENDIF - ELSE - EDTX(I) = 0. - ENDIF - ENDDO -! -! -! -!--- DOWNDRAFT CLOUDWORK FUNCTIONS -! -! - DO K = KM1, 1, -1 - DO I = 1, IM - if (k .le. kmax(i)-1) then - IF(DWNFLG2(I).AND.K.LT.JMIN(I)) THEN - GAMMA = EL2ORC * QESO(I,k+1) / TO(I,k+1)**2 - DHH=XHCD(I) - DT= TO(I,k+1) - DG= GAMMA - DH= HESO(I,k+1) - DZ=-1.*(ZO(I,k+1)-ZO(I,k)) - XAA0(I)=XAA0(I)+EDTX(I)*DZ*(G/(CP*DT))*((DHH-DH)/(1.+DG)) & - & *(1.+DELTA*CP*DG*DT/HVAP) - val=0. - XAA0(I)=XAA0(I)+EDTX(I)* & -!cmr & DZ*G*DELTA*MAX( 0.,(QESO(I,k+1)-QO(I,k+1))) & - & DZ*G*DELTA*MAX(val,(QESO(I,k+1)-QO(I,k+1))) - ENDIF - endif - ENDDO - ENDDO -!cccc IF(LAT.EQ.LATD.AND.lon.eq.lond.and.DWNFLG2(I)) THEN -!cccc PRINT *, ' XAA AFTER DWNDRFT =', XAA0(I) -!cccc ENDIF -! -! CALCULATE CRITICAL CLOUD WORK FUNCTION -! - DO I = 1, IM - ACRT(I) = 0. - IF(CNVFLG(I)) THEN -! IF(CNVFLG(I).AND.SLIMSK(I).NE.1.) THEN - IF(PFLD(I,KTCON(I)).LT.PCRIT(15))THEN - ACRT(I)=ACRIT(15)*(975.-PFLD(I,KTCON(I))) & - & /(975.-PCRIT(15)) - ELSE IF(PFLD(I,KTCON(I)).GT.PCRIT(1))THEN - ACRT(I)=ACRIT(1) - ELSE -!cmr K = IFIX((850. - PFLD(I,KTCON(I)))/50.) + 2 - K = int((850. - PFLD(I,KTCON(I)))/50.) + 2 - K = MIN(K,15) - K = MAX(K,2) - ACRT(I)=ACRIT(K)+(ACRIT(K-1)-ACRIT(K))* & - & (PFLD(I,KTCON(I))-PCRIT(K))/(PCRIT(K-1)-PCRIT(K)) - ENDIF -! ELSE -! ACRT(I) = .5 * (PFLD(I,KBCON(I)) - PFLD(I,KTCON(I))) - ENDIF - ENDDO - DO I = 1, IM - ACRTFCT(I) = 1. - IF(CNVFLG(I)) THEN - if(SLIMSK(I).eq.1.) THEN - w1 = w1l - w2 = w2l - w3 = w3l - w4 = w4l - else - w1 = w1s - w2 = w2s - w3 = w3s - w4 = w4s - ENDIF -!C IF(CNVFLG(I).AND.SLIMSK(I).EQ.1.) THEN -! ACRTFCT(I) = PDOT(I) / W3 -! -! modify critical cloud workfunction by cloud base vertical velocity -! - IF(PDOT(I).LE.W4) THEN - ACRTFCT(I) = (PDOT(I) - W4) / (W3 - W4) - ELSEIF(PDOT(I).GE.-W4) THEN - ACRTFCT(I) = - (PDOT(I) + W4) / (W4 - W3) - ELSE - ACRTFCT(I) = 0. - ENDIF -!cmr ACRTFCT(I) = MAX(ACRTFCT(I),-1.) - val1 = -1. - ACRTFCT(I) = MAX(ACRTFCT(I),val1) -!cmr ACRTFCT(I) = MIN(ACRTFCT(I),1.) - val2 = 1. - ACRTFCT(I) = MIN(ACRTFCT(I),val2) - ACRTFCT(I) = 1. - ACRTFCT(I) -! -! modify ACRTFCT(I) by colume mean rh if RHBAR(I) is greater than 80 percent -! -! if(RHBAR(I).ge..8) THEN -! ACRTFCT(I) = ACRTFCT(I) * (.9 - min(RHBAR(I),.9)) * 10. -! ENDIF -! -! modify adjustment time scale by cloud base vertical velocity -! - DTCONV(I) = DT2 + max((1800. - DT2),RZERO) * & - & (PDOT(I) - W2) / (W1 - W2) -! DTCONV(I) = MAX(DTCONV(I), DT2) -! DTCONV(I) = 1800. * (PDOT(I) - w2) / (w1 - w2) - DTCONV(I) = max(DTCONV(I),dtmin) - DTCONV(I) = min(DTCONV(I),dtmax) - - ENDIF - ENDDO -! -!--- LARGE SCALE FORCING -! - DO I= 1, IM - FLG(I) = CNVFLG(I) - IF(CNVFLG(I)) THEN -! F = AA1(I) / DTCONV(I) - FLD(I) = (AA1(I) - ACRT(I) * ACRTFCT(I)) / DTCONV(I) - IF(FLD(I).LE.0.) FLG(I) = .FALSE. - ENDIF - CNVFLG(I) = FLG(I) - IF(CNVFLG(I)) THEN -! XAA0(I) = MAX(XAA0(I),0.) - XK(I) = (XAA0(I) - AA1(I)) / MBDT - IF(XK(I).GE.0.) FLG(I) = .FALSE. - ENDIF -! -!--- KERNEL, CLOUD BASE MASS FLUX -! - CNVFLG(I) = FLG(I) - IF(CNVFLG(I)) THEN - XMB(I) = -FLD(I) / XK(I) - XMB(I) = MIN(XMB(I),XMBMAX(I)) - ENDIF - ENDDO -! IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I)) THEN -! print *, ' RHBAR(I), ACRTFCT(I) =', RHBAR(I), ACRTFCT(I) -! PRINT *, ' A1, XA =', AA1(I), XAA0(I) -! PRINT *, ' XMB(I), ACRT =', XMB(I), ACRT -! ENDIF - TOTFLG = .TRUE. - DO I = 1, IM - TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I)) - ENDDO - IF(TOTFLG) RETURN -! -! restore t0 and QO to t1 and q1 in case convection stops -! - do k = 1, km - DO I = 1, IM - if (k .le. kmax(i)) then - TO(I,k) = T1(I,k) - QO(I,k) = Q1(I,k) -!jfe QESO(I,k) = 10. * FPVS(T1(I,k)) -! - QESO(I,k) = 0.01 * fpvs(T1(I,K)) ! fpvs is in Pa -! - QESO(I,k) = EPS * QESO(I,k) / (PFLD(I,k) + EPSM1*QESO(I,k)) -!cmr QESO(I,k) = MAX(QESO(I,k),1.E-8) - val = 1.E-8 - QESO(I,k) = MAX(QESO(I,k), val ) - endif - enddo - enddo -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!--- FEEDBACK: SIMPLY THE CHANGES FROM THE CLOUD WITH UNIT MASS FLUX -!--- MULTIPLIED BY THE MASS FLUX NECESSARY TO KEEP THE -!--- EQUILIBRIUM WITH THE LARGER-SCALE. -! - DO I = 1, IM - DELHBAR(I) = 0. - DELQBAR(I) = 0. - DELTBAR(I) = 0. - QCOND(I) = 0. - ENDDO - DO K = 1, KM - DO I = 1, IM - if (k .le. kmax(i)) then - IF(CNVFLG(I).AND.K.LE.KTCON(I)) THEN - AUP = 1. - IF(K.Le.KB(I)) AUP = 0. - ADW = 1. - IF(K.GT.JMIN(I)) ADW = 0. - DELLAT = (DELLAH(I,k) - HVAP * DELLAQ(I,k)) / CP - T1(I,k) = T1(I,k) + DELLAT * XMB(I) * DT2 - Q1(I,k) = Q1(I,k) + DELLAQ(I,k) * XMB(I) * DT2 - U1(I,k) = U1(I,k) + DELLAU(I,k) * XMB(I) * DT2 - V1(I,k) = V1(I,k) + DELLAV(I,k) * XMB(I) * DT2 - DP = 1000. * DEL(I,K) - DELHBAR(I) = DELHBAR(I) + DELLAH(I,k)*XMB(I)*DP/G - DELQBAR(I) = DELQBAR(I) + DELLAQ(I,k)*XMB(I)*DP/G - DELTBAR(I) = DELTBAR(I) + DELLAT*XMB(I)*DP/G - ENDIF - endif - ENDDO - ENDDO - DO K = 1, KM - DO I = 1, IM - if (k .le. kmax(i)) then - IF(CNVFLG(I).AND.K.LE.KTCON(I)) THEN -!jfe QESO(I,k) = 10. * FPVS(T1(I,k)) -! - QESO(I,k) = 0.01 * fpvs(T1(I,K)) ! fpvs is in Pa -! - QESO(I,k) = EPS * QESO(I,k)/(PFLD(I,k) + EPSM1*QESO(I,k)) -!cmr QESO(I,k) = MAX(QESO(I,k),1.E-8) - val = 1.E-8 - QESO(I,k) = MAX(QESO(I,k), val ) -! -! cloud water -! - if(ncloud.gt.0.and.CNVFLG(I).and.k.eq.KTCON(I)) THEN - tem = DELLAL(I) * XMB(I) * dt2 - tem1 = MAX(RZERO, MIN(RONE, (TCR-t1(I,K))*TCRF)) - if (QL(I,k,2) .gt. -999.0) then - QL(I,k,1) = QL(I,k,1) + tem * tem1 ! Ice - QL(I,k,2) = QL(I,k,2) + tem *(1.0-tem1) ! Water - else - tem2 = QL(I,k,1) + tem - QL(I,k,1) = tem2 * tem1 ! Ice - QL(I,k,2) = tem2 - QL(I,k,1) ! Water - endif -! QL(I,k) = QL(I,k) + DELLAL(I) * XMB(I) * dt2 - dp = 1000. * del(i,k) - DELLAL(I) = DELLAL(I) * XMB(I) * dp / g - ENDIF - ENDIF - endif - ENDDO - ENDDO -! IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I) ) THEN -! PRINT *, ' DELHBAR, DELQBAR, DELTBAR =' -! PRINT *, DELHBAR, HVAP*DELQBAR, CP*DELTBAR -! PRINT *, ' DELLBAR =' -! PRINT 6003, HVAP*DELLbar -! PRINT *, ' DELLAQ =' -! PRINT 6003, (HVAP*DELLAQ(I,k)*XMB(I),K=1,KMAX) -! PRINT *, ' DELLAT =' -! PRINT 6003, (DELLAH(i,k)*XMB(I)-HVAP*DELLAQ(I,k)*XMB(I), & -! & K=1,KMAX) -! ENDIF - DO I = 1, IM - RNTOT(I) = 0. - DELQEV(I) = 0. - DELQ2(I) = 0. - FLG(I) = CNVFLG(I) - ENDDO - DO K = KM, 1, -1 - DO I = 1, IM - if (k .le. kmax(i)) then - IF(CNVFLG(I).AND.K.LE.KTCON(I)) THEN - AUP = 1. - IF(K.Le.KB(I)) AUP = 0. - ADW = 1. - IF(K.GT.JMIN(I)) ADW = 0. - rain = AUP * PWO(I,k) + ADW * EDTO(I) * PWDO(I,k) - RNTOT(I) = RNTOT(I) + rain * XMB(I) * .001 * dt2 - ENDIF - endif - ENDDO - ENDDO - DO K = KM, 1, -1 - DO I = 1, IM - if (k .le. kmax(i)) then - DELTV(I) = 0. - DELQ(I) = 0. - QEVAP(I) = 0. - IF(CNVFLG(I).AND.K.LE.KTCON(I)) THEN - AUP = 1. - IF(K.Le.KB(I)) AUP = 0. - ADW = 1. - IF(K.GT.JMIN(I)) ADW = 0. - rain = AUP * PWO(I,k) + ADW * EDTO(I) * PWDO(I,k) - RN(I) = RN(I) + rain * XMB(I) * .001 * dt2 - ENDIF - IF(FLG(I).AND.K.LE.KTCON(I)) THEN - evef = EDT(I) * evfact - if(SLIMSK(I).eq.1.) evef=EDT(I) * evfactl -! if(SLIMSK(I).eq.1.) evef=.07 -! if(SLIMSK(I).ne.1.) evef = 0. - QCOND(I) = EVEF * (Q1(I,k) - QESO(I,k)) & - & / (1. + EL2ORC * QESO(I,k) / T1(I,k)**2) - DP = 1000. * DEL(I,K) - IF(RN(I).GT.0..AND.QCOND(I).LT.0.) THEN - QEVAP(I) = -QCOND(I) * (1.-EXP(-.32*SQRT(DT2*RN(I)))) - QEVAP(I) = MIN(QEVAP(I), RN(I)*1000.*G/DP) - DELQ2(I) = DELQEV(I) + .001 * QEVAP(I) * dp / g - ENDIF - if(RN(I).gt.0..and.QCOND(I).LT.0..and. & - & DELQ2(I).gt.RNTOT(I)) THEN - QEVAP(I) = 1000.* g * (RNTOT(I) - DELQEV(I)) / dp - FLG(I) = .false. - ENDIF - IF(RN(I).GT.0..AND.QEVAP(I).gt.0.) THEN - Q1(I,k) = Q1(I,k) + QEVAP(I) - T1(I,k) = T1(I,k) - ELOCP * QEVAP(I) - RN(I) = RN(I) - .001 * QEVAP(I) * DP / G - DELTV(I) = - ELOCP*QEVAP(I)/DT2 - DELQ(I) = + QEVAP(I)/DT2 - DELQEV(I) = DELQEV(I) + .001*dp*QEVAP(I)/g - ENDIF - DELLAQ(I,k) = DELLAQ(I,k) + DELQ(I) / XMB(I) - DELQBAR(I) = DELQBAR(I) + DELQ(I)*DP/G - DELTBAR(I) = DELTBAR(I) + DELTV(I)*DP/G - ENDIF - endif - ENDDO - ENDDO -! IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I) ) THEN -! PRINT *, ' DELLAH =' -! PRINT 6003, (DELLAH(k)*XMB(I),K=1,KMAX) -! PRINT *, ' DELLAQ =' -! PRINT 6003, (HVAP*DELLAQ(I,k)*XMB(I),K=1,KMAX) -! PRINT *, ' DELHBAR, DELQBAR, DELTBAR =' -! PRINT *, DELHBAR, HVAP*DELQBAR, CP*DELTBAR -! PRINT *, ' PRECIP =', HVAP*RN(I)*1000./DT2 -!CCCC PRINT *, ' DELLBAR =' -!CCCC PRINT *, HVAP*DELLbar -! ENDIF -! -! PRECIPITATION RATE CONVERTED TO ACTUAL PRECIP -! IN UNIT OF M INSTEAD OF KG -! - DO I = 1, IM - IF(CNVFLG(I)) THEN -! -! IN THE EVENT OF UPPER LEVEL RAIN EVAPORATION AND LOWER LEVEL DOWNDRAF -! MOISTENING, RN CAN BECOME NEGATIVE, IN THIS CASE, WE BACK OUT OF TH -! HEATING AND THE MOISTENING -! - if(RN(I).lt.0..and..not.FLG(I)) RN(I) = 0. - IF(RN(I).LE.0.) THEN - RN(I) = 0. - ELSE - KTOP(I) = KTCON(I) - KBOT(I) = KBCON(I) - KUO(I) = 1 - CLDWRK(I) = AA1(I) - ENDIF - ENDIF - ENDDO - DO K = 1, KM - DO I = 1, IM - if (k .le. kmax(i)) then - IF(CNVFLG(I).AND.RN(I).LE.0.) THEN - T1(I,k) = TO(I,k) - Q1(I,k) = QO(I,k) - ENDIF - endif - ENDDO - ENDDO -!! - RETURN - END SUBROUTINE SASCNV - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - SUBROUTINE SHALCV(IM,IX,KM,DT,DEL,PRSI,PRSL,PRSLK,KUO,Q,T,DPSHC) -! - USE MODULE_GFS_MACHINE , ONLY : kind_phys - USE MODULE_GFS_PHYSCONS, grav => con_g, CP => con_CP, HVAP => con_HVAP & - &, RD => con_RD - - implicit none -! -! include 'constant.h' -! - integer IM, IX, KM, KUO(IM) - real(kind=kind_phys) DEL(IX,KM), PRSI(IX,KM+1), PRSL(IX,KM), & - & PRSLK(IX,KM), & - & Q(IX,KM), T(IX,KM), DT, DPSHC -! -! Locals -! - real(kind=kind_phys) ck, cpdt, dmse, dsdz1, dsdz2, & - & dsig, dtodsl, dtodsu, eldq, g, & - & gocp, rtdls -! - integer k,k1,k2,kliftl,kliftu,kt,N2,I,iku,ik1,ik,ii - integer INDEX2(IM), KLCL(IM), KBOT(IM), KTOP(IM),kk & - &, KTOPM(IM) -!! -! PHYSICAL PARAMETERS - PARAMETER(G=GRAV, GOCP=G/CP) -! BOUNDS OF PARCEL ORIGIN - PARAMETER(KLIFTL=2,KLIFTU=2) - LOGICAL LSHC(IM) - real(kind=kind_phys) Q2(IM*KM), T2(IM*KM), & - & PRSL2(IM*KM), PRSLK2(IM*KM), & - & AL(IM*(KM-1)), AD(IM*KM), AU(IM*(KM-1)) -!----------------------------------------------------------------------- -! COMPRESS FIELDS TO POINTS WITH NO DEEP CONVECTION -! AND MOIST STATIC INSTABILITY. - DO I=1,IM - LSHC(I)=.FALSE. - ENDDO - DO K=1,KM-1 - DO I=1,IM - IF(KUO(I).EQ.0) THEN - ELDQ = HVAP*(Q(I,K)-Q(I,K+1)) - CPDT = CP*(T(I,K)-T(I,K+1)) - RTDLS = (PRSL(I,K)-PRSL(I,K+1)) / & - & PRSI(I,K+1)*RD*0.5*(T(I,K)+T(I,K+1)) - DMSE = ELDQ+CPDT-RTDLS - LSHC(I) = LSHC(I).OR.DMSE.GT.0. - ENDIF - ENDDO - ENDDO - N2 = 0 - DO I=1,IM - IF(LSHC(I)) THEN - N2 = N2 + 1 - INDEX2(N2) = I - ENDIF - ENDDO - IF(N2.EQ.0) RETURN - DO K=1,KM - KK = (K-1)*N2 - DO I=1,N2 - IK = KK + I - ii = index2(i) - Q2(IK) = Q(II,K) - T2(IK) = T(II,K) - PRSL2(IK) = PRSL(II,K) - PRSLK2(IK) = PRSLK(II,K) - ENDDO - ENDDO - do i=1,N2 - ktopm(i) = KM - enddo - do k=2,KM - do i=1,N2 - ii = index2(i) - if (prsi(ii,1)-prsi(ii,k) .le. dpshc) ktopm(i) = k - enddo - enddo - -!----------------------------------------------------------------------- -! COMPUTE MOIST ADIABAT AND DETERMINE LIMITS OF SHALLOW CONVECTION. -! CHECK FOR MOIST STATIC INSTABILITY AGAIN WITHIN CLOUD. - CALL MSTADBT3(N2,KM-1,KLIFTL,KLIFTU,PRSL2,PRSLK2,T2,Q2, & - & KLCL,KBOT,KTOP,AL,AU) - DO I=1,N2 - KBOT(I) = min(KLCL(I)-1, ktopm(i)-1) - KTOP(I) = min(KTOP(I)+1, ktopm(i)) - LSHC(I) = .FALSE. - ENDDO - DO K=1,KM-1 - KK = (K-1)*N2 - DO I=1,N2 - IF(K.GE.KBOT(I).AND.K.LT.KTOP(I)) THEN - IK = KK + I - IKU = IK + N2 - ELDQ = HVAP * (Q2(IK)-Q2(IKU)) - CPDT = CP * (T2(IK)-T2(IKU)) - RTDLS = (PRSL2(IK)-PRSL2(IKU)) / & - & PRSI(index2(i),K+1)*RD*0.5*(T2(IK)+T2(IKU)) - DMSE = ELDQ + CPDT - RTDLS - LSHC(I) = LSHC(I).OR.DMSE.GT.0. - AU(IK) = G/RTDLS - ENDIF - ENDDO - ENDDO - K1=KM+1 - K2=0 - DO I=1,N2 - IF(.NOT.LSHC(I)) THEN - KBOT(I) = KM+1 - KTOP(I) = 0 - ENDIF - K1 = MIN(K1,KBOT(I)) - K2 = MAX(K2,KTOP(I)) - ENDDO - KT = K2-K1+1 - IF(KT.LT.2) RETURN -!----------------------------------------------------------------------- -! SET EDDY VISCOSITY COEFFICIENT CKU AT SIGMA INTERFACES. -! COMPUTE DIAGONALS AND RHS FOR TRIDIAGONAL MATRIX SOLVER. -! EXPAND FINAL FIELDS. - KK = (K1-1) * N2 - DO I=1,N2 - IK = KK + I - AD(IK) = 1. - ENDDO -! -! DTODSU=DT/DEL(K1) - DO K=K1,K2-1 -! DTODSL=DTODSU -! DTODSU= DT/DEL(K+1) -! DSIG=SL(K)-SL(K+1) - KK = (K-1) * N2 - DO I=1,N2 - ii = index2(i) - DTODSL = DT/DEL(II,K) - DTODSU = DT/DEL(II,K+1) - DSIG = PRSL(II,K) - PRSL(II,K+1) - IK = KK + I - IKU = IK + N2 - IF(K.EQ.KBOT(I)) THEN - CK=1.5 - ELSEIF(K.EQ.KTOP(I)-1) THEN - CK=1. - ELSEIF(K.EQ.KTOP(I)-2) THEN - CK=3. - ELSEIF(K.GT.KBOT(I).AND.K.LT.KTOP(I)-2) THEN - CK=5. - ELSE - CK=0. - ENDIF - DSDZ1 = CK*DSIG*AU(IK)*GOCP - DSDZ2 = CK*DSIG*AU(IK)*AU(IK) - AU(IK) = -DTODSL*DSDZ2 - AL(IK) = -DTODSU*DSDZ2 - AD(IK) = AD(IK)-AU(IK) - AD(IKU) = 1.-AL(IK) - T2(IK) = T2(IK)+DTODSL*DSDZ1 - T2(IKU) = T2(IKU)-DTODSU*DSDZ1 - ENDDO - ENDDO - IK1=(K1-1)*N2+1 - CALL TRIDI2T3(N2,KT,AL(IK1),AD(IK1),AU(IK1),Q2(IK1),T2(IK1), & - & AU(IK1),Q2(IK1),T2(IK1)) - DO K=K1,K2 - KK = (K-1)*N2 - DO I=1,N2 - IK = KK + I - Q(INDEX2(I),K) = Q2(IK) - T(INDEX2(I),K) = T2(IK) - ENDDO - ENDDO -!----------------------------------------------------------------------- - RETURN - END SUBROUTINE SHALCV -!----------------------------------------------------------------------- - SUBROUTINE TRIDI2T3(L,N,CL,CM,CU,R1,R2,AU,A1,A2) -!yt INCLUDE DBTRIDI2; -!! - USE MODULE_GFS_MACHINE , ONLY : kind_phys - implicit none - integer k,n,l,i - real(kind=kind_phys) fk -!! - real(kind=kind_phys) & - & CL(L,2:N),CM(L,N),CU(L,N-1),R1(L,N),R2(L,N), & - & AU(L,N-1),A1(L,N),A2(L,N) -!----------------------------------------------------------------------- - DO I=1,L - FK=1./CM(I,1) - AU(I,1)=FK*CU(I,1) - A1(I,1)=FK*R1(I,1) - A2(I,1)=FK*R2(I,1) - ENDDO - DO K=2,N-1 - DO I=1,L - FK=1./(CM(I,K)-CL(I,K)*AU(I,K-1)) - AU(I,K)=FK*CU(I,K) - A1(I,K)=FK*(R1(I,K)-CL(I,K)*A1(I,K-1)) - A2(I,K)=FK*(R2(I,K)-CL(I,K)*A2(I,K-1)) - ENDDO - ENDDO - DO I=1,L - FK=1./(CM(I,N)-CL(I,N)*AU(I,N-1)) - A1(I,N)=FK*(R1(I,N)-CL(I,N)*A1(I,N-1)) - A2(I,N)=FK*(R2(I,N)-CL(I,N)*A2(I,N-1)) - ENDDO - DO K=N-1,1,-1 - DO I=1,L - A1(I,K)=A1(I,K)-AU(I,K)*A1(I,K+1) - A2(I,K)=A2(I,K)-AU(I,K)*A2(I,K+1) - ENDDO - ENDDO -!----------------------------------------------------------------------- - RETURN - END SUBROUTINE TRIDI2T3 -!----------------------------------------------------------------------- - - SUBROUTINE MSTADBT3(IM,KM,K1,K2,PRSL,PRSLK,TENV,QENV, & - & KLCL,KBOT,KTOP,TCLD,QCLD) -!yt INCLUDE DBMSTADB; -!! - USE MODULE_GFS_MACHINE, ONLY : kind_phys - USE MODULE_GFS_FUNCPHYS, ONLY : FTDP, FTHE, FTLCL, STMA - USE MODULE_GFS_PHYSCONS, EPS => con_eps, EPSM1 => con_epsm1, FV => con_FVirt - - implicit none -!! -! include 'constant.h' -!! - integer k,k1,k2,km,i,im - real(kind=kind_phys) pv,qma,slklcl,tdpd,thelcl,tlcl - real(kind=kind_phys) tma,tvcld,tvenv -!! - real(kind=kind_phys) PRSL(IM,KM), PRSLK(IM,KM), TENV(IM,KM), & - & QENV(IM,KM), TCLD(IM,KM), QCLD(IM,KM) - INTEGER KLCL(IM), KBOT(IM), KTOP(IM) -! LOCAL ARRAYS - real(kind=kind_phys) SLKMA(IM), THEMA(IM) -!----------------------------------------------------------------------- -! DETERMINE WARMEST POTENTIAL WET-BULB TEMPERATURE BETWEEN K1 AND K2. -! COMPUTE ITS LIFTING CONDENSATION LEVEL. -! - DO I=1,IM - SLKMA(I) = 0. - THEMA(I) = 0. - ENDDO - DO K=K1,K2 - DO I=1,IM - PV = 1000.0 * PRSL(I,K)*QENV(I,K)/(EPS-EPSM1*QENV(I,K)) - TDPD = TENV(I,K)-FTDP(PV) - IF(TDPD.GT.0.) THEN - TLCL = FTLCL(TENV(I,K),TDPD) - SLKLCL = PRSLK(I,K)*TLCL/TENV(I,K) - ELSE - TLCL = TENV(I,K) - SLKLCL = PRSLK(I,K) - ENDIF - THELCL=FTHE(TLCL,SLKLCL) - IF(THELCL.GT.THEMA(I)) THEN - SLKMA(I) = SLKLCL - THEMA(I) = THELCL - ENDIF - ENDDO - ENDDO -!----------------------------------------------------------------------- -! SET CLOUD TEMPERATURES AND HUMIDITIES WHEREVER THE PARCEL LIFTED UP -! THE MOIST ADIABAT IS BUOYANT WITH RESPECT TO THE ENVIRONMENT. - DO I=1,IM - KLCL(I)=KM+1 - KBOT(I)=KM+1 - KTOP(I)=0 - ENDDO - DO K=1,KM - DO I=1,IM - TCLD(I,K)=0. - QCLD(I,K)=0. - ENDDO - ENDDO - DO K=K1,KM - DO I=1,IM - IF(PRSLK(I,K).LE.SLKMA(I)) THEN - KLCL(I)=MIN(KLCL(I),K) - CALL STMA(THEMA(I),PRSLK(I,K),TMA,QMA) -! TMA=FTMA(THEMA(I),PRSLK(I,K),QMA) - TVCLD=TMA*(1.+FV*QMA) - TVENV=TENV(I,K)*(1.+FV*QENV(I,K)) - IF(TVCLD.GT.TVENV) THEN - KBOT(I)=MIN(KBOT(I),K) - KTOP(I)=MAX(KTOP(I),K) - TCLD(I,K)=TMA-TENV(I,K) - QCLD(I,K)=QMA-QENV(I,K) - ENDIF - ENDIF - ENDDO - ENDDO -!----------------------------------------------------------------------- - RETURN - END SUBROUTINE MSTADBT3 - - END MODULE module_cu_sas diff --git a/src/fim/FIMsrc/fim/wrfphys/module_cumulus_driver.F b/src/fim/FIMsrc/fim/wrfphys/module_cumulus_driver.F deleted file mode 100644 index 62af88a..0000000 --- a/src/fim/FIMsrc/fim/wrfphys/module_cumulus_driver.F +++ /dev/null @@ -1,515 +0,0 @@ -!WRF:MEDIATION_LAYER:PHYSICS -! - -MODULE module_cumulus_driver - USE module_constants,only: g=>grvity,cp,r_d=>rd,r_v=>rv - REAL , PARAMETER :: XLV0 = 3.15E6 - REAL , PARAMETER :: XLV1 = 2370. - REAL , PARAMETER :: XLS0 = 2.905E6 - REAL , PARAMETER :: XLS1 = 259.532 - - REAL , PARAMETER :: XLS = 2.85E6 - REAL , PARAMETER :: XLV = 2.5E6 - REAL , PARAMETER :: XLF = 3.50E5 - - REAL , PARAMETER :: SVP1=0.6112 - REAL , PARAMETER :: SVP2=17.67 - REAL , PARAMETER :: SVP3=29.65 - REAL , PARAMETER :: SVPT0=273.15 - REAL , PARAMETER :: EP_1=R_v/R_d-1. - REAL , PARAMETER :: EP_2=R_d/R_v -CONTAINS - SUBROUTINE cumulus_driver( & - ! Order dependent args for domain, mem, and tile dims - ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite,jts,jte,kts,kte & - ! Order independent args (use VAR= in call) - ! --Prognostic - ,u,v,th,t,w & - ,p,pi,rho & - ! --Other arguments - ,itimestep,dt,dx,cudt,curr_secs,adapt_step_flag & - ,rainc,raincv,pratec & - ,dz8w,p8w,forcet,forceq & - ,stepcu,gsw & - ,xland,cu_act_flag & - ,htop,hbot,kpbl,ht & - ,ensdim,maxiens,maxens,maxens2,maxens3 & - ! Package selection variable - ,cu_physics & - ! Optional moisture tracers - ,qv_curr, qc_curr, qr_curr & - ,qi_curr, qs_curr, qg_curr & - ,qv_prev, qc_prev, qr_prev & - ,qi_prev, qs_prev, qg_prev & - ! Optional arguments for GD scheme - ,apr_gr,apr_w,apr_mc,apr_st,apr_as,apr_capma & - ,apr_capme,apr_capmi,edt_out,clos_choice & - ,mass_flux,xf_ens,pr_ens,cugd_avedx,imomentum & - ,cugd_tten,cugd_qvten,cugd_qcten & - ,cugd_ttens,cugd_qvtens & - ,gd_cloud,gd_cloud2 & - ! Optional moisture and other tendencies - ,rqvcuten,rqccuten,rqrcuten & - ,rqicuten,rqscuten,rqgcuten & - ,rqvblten,rqvften & - ,rthcuten,rthraten,rthblten,rthften & - ! Optional moisture tracer flags - ,f_qv,f_qc,f_qr & - ,f_qi,f_qs,f_qg & - ) -!---------------------------------------------------------------------- - USE module_initial_chem_namelists , ONLY : & - KFSCHEME,BMJSCHEME & - ,KFETASCHEME,GDSCHEME & - ,G3SCHEME & - ,SASSCHEME - -! *** add new modules of schemes here - -! USE module_cu_kf -! USE module_cu_bmj -! USE module_dm -! USE module_domain, ONLY: domain -! USE module_cu_kfeta - USE module_cu_gd, ONLY : GRELLDRV - USE module_cu_g3, ONLY : G3DRV,CONV_GRELL_SPREAD3D -! USE module_cu_sas - - ! This driver calls subroutines for the cumulus parameterizations. - ! - ! 1. Kain & Fritsch (1993) - ! 2. Betts-Miller-Janjic (Janjic, 1994) - ! -!---------------------------------------------------------------------- - IMPLICIT NONE -!====================================================================== -! Grid structure in physics part of WRF -!---------------------------------------------------------------------- -! The horizontal velocities used in the physics are unstaggered -! relative to temperature/moisture variables. All predicted -! variables are carried at half levels except w, which is at full -! levels. Some arrays with names (*8w) are at w (full) levels. -! -!---------------------------------------------------------------------- -! In WRF, kms (smallest number) is the bottom level and kme (largest -! number) is the top level. In your scheme, if 1 is at the top level, -! then you have to reverse the order in the k direction. -! -! kme - half level (no data at this level) -! kme ----- full level -! kme-1 - half level -! kme-1 ----- full level -! . -! . -! . -! kms+2 - half level -! kms+2 ----- full level -! kms+1 - half level -! kms+1 ----- full level -! kms - half level -! kms ----- full level -! -!====================================================================== -! Definitions -!----------- -! Rho_d dry density (kg/m^3) -! Theta_m moist potential temperature (K) -! Qv water vapor mixing ratio (kg/kg) -! Qc cloud water mixing ratio (kg/kg) -! Qr rain water mixing ratio (kg/kg) -! Qi cloud ice mixing ratio (kg/kg) -! Qs snow mixing ratio (kg/kg) -!----------------------------------------------------------------- -!-- DT time step (second) -!-- CUDT cumulus time step (minute) -!-- curr_secs current forecast time (seconds) -!-- itimestep number of time step (integer) -!-- DX horizontal space interval (m) -!-- rr dry air density (kg/m^3) -! -!-- RTHCUTEN Theta tendency due to -! cumulus scheme precipitation (K/s) -!-- RQVCUTEN Qv tendency due to -! cumulus scheme precipitation (kg/kg/s) -!-- RQRCUTEN Qr tendency due to -! cumulus scheme precipitation (kg/kg/s) -!-- RQCCUTEN Qc tendency due to -! cumulus scheme precipitation (kg/kg/s) -!-- RQSCUTEN Qs tendency due to -! cumulus scheme precipitation (kg/kg/s) -!-- RQICUTEN Qi tendency due to -! cumulus scheme precipitation (kg/kg/s) -! -!-- RAINC accumulated total cumulus scheme precipitation (mm) -!-- RAINCV cumulus scheme precipitation (mm) -!-- PRATEC precipitiation rate from cumulus scheme (mm/s) -! time in KF cumulus scheme (integer) -!-- u_phy u-velocity interpolated to theta points (m/s) -!-- v_phy v-velocity interpolated to theta points (m/s) -!-- th_phy potential temperature (K) -!-- t_phy temperature (K) -!-- w vertical velocity (m/s) -!-- moist moisture array (4D - last index is species) (kg/kg) -!-- dz8w dz between full levels (m) -!-- p8w pressure at full levels (Pa) -!-- p_phy pressure (Pa) -!-- pi_phy exner function (dimensionless) -! points (dimensionless) -!-- RTHRATEN radiative temp forcing for Grell-Devenyi scheme -!-- RTHBLTEN PBL temp forcing for Grell-Devenyi scheme -!-- RQVBLTEN PBL moisture forcing for Grell-Devenyi scheme -!-- RTHFTEN -!-- RQVFTEN -!-- MASS_FLUX -!-- XF_ENS -!-- PR_ENS -!-- CU_ACT_FLAG -!-- rho density (kg/m^3) -!-- STEPCU # of fundamental timesteps between convection calls -!-- XLAND land-sea mask (1.0 for land; 2.0 for water) -!-- XLV0 latent heat of vaporization constant -! used in temperature dependent formula (J/kg) -!-- XLV1 latent heat of vaporization constant -! used in temperature dependent formula (J/kg/K) -!-- XLS0 latent heat of sublimation constant -! used in temperature dependent formula (J/kg) -!-- XLS1 latent heat of sublimation constant -! used in temperature dependent formula (J/kg/K) -!-- R_d gas constant for dry air ( 287. J/kg/K) -!-- R_v gas constant for water vapor (461 J/k/kg) -!-- Cp specific heat at constant pressure (1004 J/k/kg) -!-- rvovrd R_v divided by R_d (dimensionless) -!-- G acceleration due to gravity (m/s^2) -!-- EP_1 constant for virtual temperature -! (R_v/R_d - 1) (dimensionless) -!-- pi_phy the exner function, (p/p0)**(R/Cp) (none unit) -!-- ids start index for i in domain -!-- ide end index for i in domain -!-- jds start index for j in domain -!-- jde end index for j in domain -!-- kds start index for k in domain -!-- kde end index for k in domain -!-- ims start index for i in memory -!-- ime end index for i in memory -!-- jms start index for j in memory -!-- jme end index for j in memory -!-- kms start index for k in memory -!-- kme end index for k in memory -!-- i_start start indices for i in tile -!-- i_end end indices for i in tile -!-- j_start start indices for j in tile -!-- j_end end indices for j in tile -!-- kts start index for k in tile -!-- kte end index for k in tile -!-- num_tiles number of tiles -!-- HBOT index of lowest model layer with convection -!-- HTOP index of highest model layer with convection -!-- LBOT index of lowest model layer with convection -!-- LTOP index of highest model layer with convection -!-- KPBL layer index of the PBL -!-- periodic_x T/F this is using periodic lateral boundaries in the X direction -!-- periodic_y T/F this is using periodic lateral boundaries in the Y-direction -! -!====================================================================== - - INTEGER, INTENT(IN ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - itimestep - - INTEGER, INTENT(IN ) :: & - ensdim,maxiens,maxens,maxens2,maxens3 - - INTEGER, OPTIONAL, INTENT(IN ) :: & - cugd_avedx,clos_choice - - INTEGER, INTENT(IN ) :: cu_physics - INTEGER, INTENT(IN ) :: STEPCU - - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & - INTENT(IN ) :: & - dz8w & - , p8w & - , p & - , pi & - , u & - , v & - , th & - , t & - , rho & - , w - - - REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: & - GSW,HT,XLAND - - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(INOUT) :: RAINC & - , RAINCV & - , HTOP & - , HBOT - - - REAL, DIMENSION( ims:ime , jms:jme ),INTENT(INOUT),OPTIONAL :: & - PRATEC - REAL, DIMENSION( ims:ime , jms:jme ) :: tmppratec - - INTEGER, DIMENSION( ims:ime , jms:jme ), & - INTENT(IN) :: KPBL - - - LOGICAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(INOUT) :: CU_ACT_FLAG - - REAL, INTENT(IN ) :: DT, DX - INTEGER, INTENT(IN ),OPTIONAL :: & - imomentum - REAL, INTENT(IN ),OPTIONAL :: CUDT - REAL, INTENT(IN ),OPTIONAL :: CURR_SECS - LOGICAL,INTENT(IN ),OPTIONAL :: adapt_step_flag - REAL :: cudt_pass, curr_secs_pass - LOGICAL :: adapt_step_flag_pass,periodic_x,periodic_y - -! -! optional arguments -! - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & - OPTIONAL, INTENT(INOUT) :: & - ! optional moisture tracers - ! 2 time levels; if only one then use CURR - qv_curr, qc_curr, qr_curr & - ,qi_curr, qs_curr, qg_curr & - ,qv_prev, qc_prev, qr_prev & - ,qi_prev, qs_prev, qg_prev & - ! optional moisture and other tendencies - ,rqvcuten,rqccuten,rqrcuten & - ,rqicuten,rqscuten,rqgcuten & - ,rqvblten,rqvften & - ,rthraten,rthblten & - ,cugd_tten,cugd_qvten,cugd_qcten & - ,cugd_ttens,cugd_qvtens & - , forcet & - , forceq & - ,rthften,rthcuten - - REAL, DIMENSION( ims:ime , jms:jme ), & - OPTIONAL, & - INTENT(INOUT) :: & - apr_gr,apr_w,apr_mc,apr_st,apr_as,apr_capma & - ,apr_capme,apr_capmi,edt_out & - , MASS_FLUX - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & - OPTIONAL, INTENT(INOUT) :: & - GD_CLOUD,GD_CLOUD2 - REAL, DIMENSION( ims:ime , jms:jme , 1:ensdim ), & - OPTIONAL, & - INTENT(INOUT) :: XF_ENS, PR_ENS - -! -! Flags relating to the optional tendency arrays declared above -! Models that carry the optional tendencies will provdide the -! optional arguments at compile time; these flags all the model -! to determine at run-time whether a particular tracer is in -! use or not. -! - LOGICAL, INTENT(IN), OPTIONAL :: & - f_qv & - ,f_qc & - ,f_qr & - ,f_qi & - ,f_qs & - ,f_qg - - -! LOCAL VAR - - INTEGER :: i,j,k,ij - -!----------------------------------------------------------------- - - if (.not. PRESENT(CURR_SECS)) then - curr_secs_pass = -1 - else - curr_secs_pass = curr_secs - endif - - if (.not. PRESENT(CUDT)) then - cudt_pass = -1 - else - cudt_pass = cudt - endif - - if (.not. PRESENT(adapt_step_flag)) then - adapt_step_flag_pass = .false. - else - adapt_step_flag_pass = adapt_step_flag - endif - periodic_x=.true. - periodic_y=.true. - - ! Initialize tmppratec to pratec - - if ( PRESENT ( pratec ) ) then - tmppratec(:,:) = pratec(:,:) - else - tmppratec(:,:) = 0. - end if - - - IF (cu_physics .eq. 0) return - if(cu_physics .eq. 5 ) then - do j=jts,min(jte,jde-1) - do k=kts,kte - do i=its,min(ite,ide-1) - RTHFTEN(i,k,j)=(RTHFTEN(i,k,j)+RTHRATEN(i,k,j) & - +RTHBLTEN(i,k,j))*pi(i,k,j) - RQVFTEN(i,k,j)=RQVFTEN(i,k,j)+RQVBLTEN(i,k,j) - enddo - enddo - enddo -! else if(cu_physics .eq. 3 ) then -! do j=jts,min(jte,jde-1) -! do k=kts,kte -! do i=its,min(ite,ide-1) -! RTHFTEN(i,k,j)=(RTHFTEN(i,k,j)+RTHRATEN(i,k,j) & -! +RTHBLTEN(i,k,j)) -! RQVFTEN(i,k,j)=RQVFTEN(i,k,j)+RQVBLTEN(i,k,j) -! enddo -! enddo -! enddo - endif - -! DON'T JUDGE TIME STEP HERE, SINCE KF NEEDS ACCUMULATED W FIELD. -! DO IT INSIDE THE INDIVIDUAL CUMULUS SCHEME - - - - cps_select: SELECT CASE(cu_physics) - - CASE (GDSCHEME) -!TBH print *,'call grelldrv' -! CALL wrf_debug(100,'in grelldrv') - CALL GRELLDRV( & - DT=dt, ITIMESTEP=itimestep, DX=dx & - ,U=u,V=v,T=t,W=w ,RHO=rho & - ,P=p,PI=pi ,Q=qv_curr ,RAINCV=raincv & - ,DZ8W=dz8w,P8W=p8w,XLV=xlv,CP=cp,G=g,R_V=r_v & - ,PRATEC=tmppratec & - ,APR_GR=apr_gr,APR_W=apr_w,APR_MC=apr_mc & - ,APR_ST=apr_st,APR_AS=apr_as & - ,APR_CAPMA=apr_capma,APR_CAPME=apr_capme & - ,APR_CAPMI=apr_capmi,MASS_FLUX=mass_flux & - ,XF_ENS=xf_ens,PR_ENS=pr_ens,HT=ht & - ,xland=xland,gsw=gsw & - ,GDC=gd_cloud,GDC2=gd_cloud2 & - ,ENSDIM=ensdim,MAXIENS=maxiens,MAXENS=maxens & - ,MAXENS2=maxens2,MAXENS3=maxens3 & - ,STEPCU=STEPCU,htop=htop,hbot=hbot & - ,CU_ACT_FLAG=CU_ACT_FLAG & - ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde & - ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme & - ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte & - ,PERIODIC_X=periodic_x,PERIODIC_Y=periodic_y & - ! optionals - ,RTHCUTEN=RTHCUTEN ,RTHFTEN=RTHFTEN & - ,RQICUTEN=RQICUTEN ,RQVFTEN=RQVFTEN & - ,RTHRATEN=RTHRATEN,RTHBLTEN=RTHBLTEN & - ,RQVCUTEN=RQVCUTEN,RQCCUTEN=RQCCUTEN & - ,RQVBLTEN=RQVBLTEN & - ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr & - ,F_QI=f_qi,F_QS=f_qs & - ) -! CASE (SASSCHEME) - -! CALL wrf_debug(100,'in cu_sas') -! CALL CU_SAS( & -! DT=dt,ITIMESTEP=itimestep,STEPCU=STEPCU & -! ,RAINCV=RAINCV,PRATEC=tmpPRATEC,HTOP=HTOP,HBOT=HBOT & -! ,U3D=u,V3D=v,W=w,T3D=t,PI3D=pi,RHO3D=rho & -! ,QV3D=QV_CURR,QC3D=QC_CURR,QI3D=QI_CURR & -! ,DZ8W=dz8w,PCPS=p,P8W=p8w,XLAND=XLAND & -! ,CU_ACT_FLAG=CU_ACT_FLAG & -! ,CUDT=cudt_pass & -! ,CURR_SECS=curr_secs_pass & -! ,ADAPT_STEP_FLAG=adapt_step_flag_pass & -! ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde & -! ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme & -! ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte & - ! optionals -! ,RTHCUTEN=RTHCUTEN,RQVCUTEN=RQVCUTEN & -! ,RQCCUTEN=RQCCUTEN,RQICUTEN=RQICUTEN & -! ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr & -! ,F_QI=f_qi,F_QS=f_qs & -! ) - CASE (G3SCHEME) -! CALL wrf_debug(100,'in grelldrv') - CALL G3DRV( & - DT=dt, ITIMESTEP=itimestep, DX=dx & - ,U=u,V=v,T=t,W=w ,RHO=rho & - ,P=p,PI=pi,Q=qv_curr,RAINCV=raincv & - ,DZ8W=dz8w ,P8W=p8w,XLV=xlv,CP=cp,G=g,R_V=r_v & - ,APR_GR=apr_gr,APR_W=apr_w,APR_MC=apr_mc & - ,APR_ST=apr_st,APR_AS=apr_as,PRATEC=tmppratec & - ,APR_CAPMA=apr_capma,APR_CAPME=apr_capme & - ,APR_CAPMI=apr_capmi,MASS_FLUX=mass_flux & - ,XF_ENS=xf_ens,PR_ENS=pr_ens,HT=ht & - ,xland=xland,gsw=gsw,edt_out=edt_out & - ,GDC=gd_cloud,GDC2=gd_cloud2 & - ,cugd_tten=cugd_tten,cugd_qvten=cugd_qvten & - ,cugd_ttens=cugd_ttens,cugd_qvtens=cugd_qvtens & - ,cugd_qcten=cugd_qcten,cugd_avedx=cugd_avedx & - ,imomentum=imomentum & - ,ENSDIM=ensdim,MAXIENS=maxiens,MAXENS=maxens & - ,MAXENS2=maxens2,MAXENS3=maxens3,ichoice=clos_choice & - ,STEPCU=STEPCU,htop=htop,hbot=hbot & - ,CU_ACT_FLAG=CU_ACT_FLAG & - ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde & - ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme & - ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte & - ,PERIODIC_X=periodic_x,PERIODIC_Y=periodic_y & - ! optionals - ,RTHCUTEN=RTHCUTEN ,RTHFTEN=RTHFTEN & - ,RQICUTEN=RQICUTEN ,RQVFTEN=RQVFTEN & - ,RQVCUTEN=RQVCUTEN,RQCCUTEN=RQCCUTEN & - ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr & - ,F_QI=f_qi,F_QS=f_qs & - ) - - CASE DEFAULT - -! WRITE( wrf_err_message , * ) 'The cumulus option does not exist: cu_physics = ', cu_physics -! CALL wrf_error_fatal ( wrf_err_message ) - - END SELECT cps_select - -! IF(cu_physics .eq. 5 )then -!!#ifdef DM_PARALLEL -!!# include "HALO_CUP_G3_OUT.inc" -!!#endif -! call conv_grell_spread3d(rthcuten=rthcuten,rqvcuten=rqvcuten & -! & ,rqccuten=rqccuten,raincv=raincv,cugd_avedx=cugd_avedx & -! & ,cugd_tten=cugd_tten,cugd_qvten=cugd_qvten,rqicuten=rqicuten & -! & ,cugd_ttens=cugd_ttens,cugd_qvtens=cugd_qvtens & -! & ,cugd_qcten=cugd_qcten,pi_phy=pi,moist_qv=qv_curr & -! & ,PRATEC=tmppratec,dt=dt,num_tiles=num_tiles & -! & ,imomentum=imomentum & -! & ,F_QV=F_QV,F_QC=F_QC,F_QR=F_QR,F_QI=F_QI,F_QS=F_QS & -! & ,ids=IDS,ide=IDE, jds=JDS,jde=JDE, kds=KDS,kde=KDE & -! & ,ims=IMS,ime=IME, jms=JMS,jme=JME, kms=KMS,kme=KME & -! & ,i_start=i_start,i_end=i_end & -! & ,j_start=j_start,j_end=j_end & -! & ,kts=kts, kte=kte) -! endif - - ! - ! Copy pratec back to output array, if necessary. - ! - if (PRESENT(PRATEC)) then - pratec(:,:) = tmppratec(:,:) - endif - END SUBROUTINE cumulus_driver - -END MODULE module_cumulus_driver diff --git a/src/fim/FIMsrc/fim/wrfphys/module_microphysics_driver.F b/src/fim/FIMsrc/fim/wrfphys/module_microphysics_driver.F deleted file mode 100644 index d5548c7..0000000 --- a/src/fim/FIMsrc/fim/wrfphys/module_microphysics_driver.F +++ /dev/null @@ -1,812 +0,0 @@ -!WRF:MEDIATION_LAYER:PHYSICS -! *** add new modules of schemes here -! -MODULE module_microphysics_driver - USE module_constants,only: g=>grvity,cp,r_d=>rd,r_v=>rv - REAL , PARAMETER :: XLV0 = 3.15E6 - REAL , PARAMETER :: XLV1 = 2370. - REAL , PARAMETER :: XLS0 = 2.905E6 - REAL , PARAMETER :: XLS1 = 259.532 - - REAL , PARAMETER :: XLS = 2.85E6 - REAL , PARAMETER :: XLV = 2.5E6 - REAL , PARAMETER :: XLF = 3.50E5 - - REAL , PARAMETER :: rhowater = 1000. - REAL , PARAMETER :: rhosnow = 100. - REAL , PARAMETER :: rhoair0 = 1.28 -! - REAL , PARAMETER :: n_ccn0 = 1.0E8 -! - REAL , PARAMETER :: DEGRAD = 3.1415926/180. - REAL , PARAMETER :: DPD = 360./365. - - REAL , PARAMETER :: SVP1=0.6112 - REAL , PARAMETER :: SVP2=17.67 - REAL , PARAMETER :: SVP3=29.65 - REAL , PARAMETER :: SVPT0=273.15 - REAL , PARAMETER :: EP_1=R_v/R_d-1. - REAL , PARAMETER :: EP_2=R_d/R_v - REAL , PARAMETER :: cv = cp-r_d - REAL , PARAMETER :: cpv = 4.*r_v - REAL , PARAMETER :: cvv = cpv-r_v - REAL , PARAMETER :: cvpm = -cv/cp - REAL , PARAMETER :: cliq = 4190. - REAL , PARAMETER :: cice = 2106. - REAL , PARAMETER :: psat = 610.78 - REAL , PARAMETER :: rcv = r_d/cv - REAL , PARAMETER :: rcp = r_d/cp - REAL , PARAMETER :: rovg = r_d/g - REAL , PARAMETER :: c2 = cp * rcv - REAL , PARAMETER :: cpovcv = cp/(cp-r_d) - REAL , PARAMETER :: cvovcp = 1./cpovcv - REAL , PARAMETER :: rvovrd = r_v/r_d - REAL , PARAMETER :: epsilon = 1.E-15 - -CONTAINS - -SUBROUTINE microphysics_driver( & - th, rho, pi_phy, p & - ,ht, dz8w, p8w, dt,dx,dy & - ,mp_physics & - ,t8w & - ,chem_opt, progn & - ,cldfra, cldfra_old, exch_h, nsource & - ,qlsink, precr, preci, precs, precg & - ,xland,itimestep & -! ,f_ice_phy,f_rain_phy,f_rimef_phy & - ,lowlyr,sr, id & - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,ips,ipe, jps,jpe, kps,kpe & - ,its,ite,jts,jte,kts,kte & - , naer & - ,qv_curr,qc_curr,qr_curr,qi_curr,qs_curr,qg_curr & - ,qndrop_curr,qni_curr & - ,qns_curr,qnr_curr,qng_curr,qnn_curr,qnc_curr & - ,f_qv,f_qc,f_qr,f_qi,f_qs,f_qg,f_qndrop,f_qni & - ,f_qns,f_qnr,f_qng,f_qnc,f_qnn & - ,qrcuten, qscuten, qicuten, mu & - ,qt_curr,f_qt & - ,mp_restart_state,tbpvs_state,tbpvs0_state & ! for etampnew - ,hail,ice2 & ! for gsfcgce - ,w ,z & - ,rainnc, rainncv & - ,snownc, snowncv & - ,graupelnc, graupelncv & - ) -! Framework - USE module_initial_chem_namelists , ONLY : & - KESSLERSCHEME, LINSCHEME, WSM3SCHEME, WSM5SCHEME & - ,WSM6SCHEME, ETAMPNEW, THOMPSON, MORR_TWO_MOMENT & - ,GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, THOMPSON07 - -! Model Layer -! USE module_wrf_error - -! *** add new modules of schemes here - - USE module_mp_kessler - USE module_mp_lin - USE module_mp_wsm3 - USE module_mp_wsm5 - USE module_mp_wsm6 -! USE module_mp_etanew - USE module_mp_thompson - USE module_mp_thompson07 - USE module_mp_gsfcgce - USE module_mp_morr_two_moment - USE module_mp_wdm5 - USE module_mp_wdm6 - -! USE module_mixactivate, only: prescribe_aerosol_mixactivate - -!---------------------------------------------------------------------- - ! This driver calls subroutines for the microphys. - ! - ! Schemes - ! - ! Kessler scheme - ! Lin et al. (1983), Rutledge and Hobbs (1984) - ! WRF Single-Moment 3-class, Hong, Dudhia and Chen (2004) - ! WRF Single-Moment 5-class, Hong, Dudhia and Chen (2004) - ! WRF Single-Moment 6-class, Lim and Hong (2003 WRF workshop) - ! Eta Grid-scale Cloud and Precipitation scheme (EGCP01, Ferrier) - ! -!---------------------------------------------------------------------- - IMPLICIT NONE -!====================================================================== -! Grid structure in physics part of WRF -!---------------------------------------------------------------------- -! The horizontal velocities used in the physics are unstaggered -! relative to temperature/moisture variables. All predicted -! variables are carried at half levels except w, which is at full -! levels. Some arrays with names (*8w) are at w (full) levels. -! -!---------------------------------------------------------------------- -! In WRF, kms (smallest number) is the bottom level and kme (largest -! number) is the top level. In your scheme, if 1 is at the top level, -! then you have to reverse the order in the k direction. -! -! kme - half level (no data at this level) -! kme ----- full level -! kme-1 - half level -! kme-1 ----- full level -! . -! . -! . -! kms+2 - half level -! kms+2 ----- full level -! kms+1 - half level -! kms+1 ----- full level -! kms - half level -! kms ----- full level -! -!====================================================================== -! Definitions -!----------- -! Rho_d dry density (kg/m^3) -! Theta_m moist potential temperature (K) -! Qv water vapor mixing ratio (kg/kg) -! Qc cloud water mixing ratio (kg/kg) -! Qr rain water mixing ratio (kg/kg) -! Qi cloud ice mixing ratio (kg/kg) -! Qs snow mixing ratio (kg/kg) -! Qndrop droplet number mixing ratio (#/kg) -! Qni cloud ice number concentration (#/kg) -! Qns snow number concentration (#/kg), -! Qnr rain number concentration (#/kg), -! Qng graupel number concentration (#/kg), - -! -!---------------------------------------------------------------------- -!-- th potential temperature (K) -!-- moist_new updated moisture array (kg/kg) -!-- moist_old Old moisture array (kg/kg) -!-- rho density of air (kg/m^3) -!-- pi_phy exner function (dimensionless) -!-- p pressure (Pa) -!-- RAINNC grid scale precipitation (mm) -!-- RAINNCV one time step grid scale precipitation (mm/step) -!-- SNOWNC grid scale snow and ice (mm) -!-- SNOWNCV one time step grid scale snow and ice (mm/step) -!-- GRAUPELNC grid scale graupel (mm) -!-- GRAUPELNCV one time step grid scale graupel (mm/step) -!-- SR one time step mass ratio of snow to total precip -!-- z Height above sea level (m) -!-- dt Time step (s) -!-- G acceleration due to gravity (m/s^2) -!-- CP heat capacity at constant pressure for dry air (J/kg/K) -!-- R_d gas constant for dry air (J/kg/K) -!-- R_v gas constant for water vapor (J/kg/K) -!-- XLS latent heat of sublimation (J/kg) -!-- XLV latent heat of vaporization (J/kg) -!-- XLF latent heat of melting (J/kg) -!-- rhowater water density (kg/m^3) -!-- rhosnow snow density (kg/m^3) -!-- F_ICE_PHY Fraction of ice. -!-- F_RAIN_PHY Fraction of rain. -!-- F_RIMEF_PHY Mass ratio of rimed ice (rime factor) -!-- t8w temperature at layer interfaces -!-- cldfra, cldfra_old, current, previous cloud fraction -!-- exch_h vertical diffusivity (m2/s) -!-- qlsink Fractional cloud water sink (/s) -!-- precr rain precipitation rate at all levels (kg/m2/s) -!-- preci ice precipitation rate at all levels (kg/m2/s) -!-- precs snow precipitation rate at all levels (kg/m2/s) -!-- precg graupel precipitation rate at all levels (kg/m2/s) & -!-- P_QV species index for water vapor -!-- P_QC species index for cloud water -!-- P_QR species index for rain water -!-- P_QI species index for cloud ice -!-- P_QS species index for snow -!-- P_QG species index for graupel -!-- P_QNDROP species index for cloud drop mixing ratio -!-- P_QNI species index for cloud ice number concentration -!-- P_QNS species index for snow number concentration, -!-- P_QNR species index for rain number concentration, -!-- P_QNG species index for graupel number concentration, -!-- id grid id number -!-- ids start index for i in domain -!-- ide end index for i in domain -!-- jds start index for j in domain -!-- jde end index for j in domain -!-- kds start index for k in domain -!-- kde end index for k in domain -!-- ims start index for i in memory -!-- ime end index for i in memory -!-- jms start index for j in memory -!-- jme end index for j in memory -!-- kms start index for k in memory -!-- kme end index for k in memory -!-- i_start start indices for i in tile -!-- i_end end indices for i in tile -!-- j_start start indices for j in tile -!-- j_end end indices for j in tile -!-- its start index for i in tile -!-- ite end index for i in tile -!-- jts start index for j in tile -!-- jte end index for j in tile -!-- kts start index for k in tile -!-- kte end index for k in tile -! -!====================================================================== - - INTEGER, INTENT(IN ) :: mp_physics - INTEGER, OPTIONAL, INTENT(IN ) :: chem_opt, progn - INTEGER, OPTIONAL, INTENT(IN ) :: hail, ice2 -! - INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde - INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme - INTEGER, OPTIONAL, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe -! INTEGER, INTENT(IN ) :: kts,kte - INTEGER, INTENT(IN ) :: itimestep -! INTEGER, DIMENSION(num_tiles), INTENT(IN) :: & -! & i_start,i_end,j_start,j_end - -! - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(INOUT) :: th -! - -! - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: & - rho, & - dz8w, & - p8w, & - pi_phy, & - p - - -! REAL, INTENT(INOUT), DIMENSION(ims:ime, kms:kme, jms:jme ) :: & -! F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY -!!$#ifdef WRF_CHEM -! REAL, INTENT(OUT), DIMENSION(ims:ime, kms:kme, jms:jme ) :: & - REAL, OPTIONAL, INTENT(OUT), DIMENSION(ims:ime, kms:kme, jms:jme ) :: & -!!$#else -!!$ REAL, DIMENSION(ims:ime, kms:kme, jms:jme ) :: & -!!$#endif - qlsink, & ! cloud water sink (/s) - precr, & ! rain precipitation rate at all levels (kg/m2/s) - preci, & ! ice precipitation rate at all levels (kg/m2/s) - precs, & ! snow precipitation rate at all levels (kg/m2/s) - precg ! graupel precipitation rate at all levels (kg/m2/s) - -! - - REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN) :: XLAND - - REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(OUT) :: SR - - REAL, INTENT(IN ) :: dt,dx,dy - - INTEGER, DIMENSION( ims:ime , jms:jme ), OPTIONAL, INTENT(INOUT) :: LOWLYR - -! -! Optional -! - REAL, OPTIONAL, INTENT(INOUT ) :: naer ! aerosol number concentration (/kg) - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & - OPTIONAL, & - INTENT(INOUT ) :: & - w, z, t8w & - ,cldfra, cldfra_old, exch_h & - ,qv_curr,qc_curr,qr_curr,qi_curr,qs_curr,qg_curr & - ,qt_curr,qndrop_curr,qni_curr & - ,qns_curr,qnr_curr,qng_curr,qnn_curr,qnc_curr - - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & - OPTIONAL, & - INTENT(IN) :: qrcuten, qscuten, qicuten - REAL, DIMENSION( ims:ime, jms:jme ), & - OPTIONAL, & - INTENT(IN) :: mu - - - REAL, DIMENSION(ims:ime, kms:kme, jms:jme ), & - OPTIONAL, & - INTENT(OUT ) :: & - nsource - -! - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(INOUT), & - OPTIONAL :: & - RAINNC & - ,RAINNCV & - ,SNOWNC & - ,SNOWNCV & - ,GRAUPELNC & - ,GRAUPELNCV - INTEGER,OPTIONAL,INTENT(IN ) :: id - - REAL , DIMENSION( ims:ime , jms:jme ) , OPTIONAL , & - INTENT(IN) :: ht - - REAL, DIMENSION (:), OPTIONAL, INTENT(INOUT) :: mp_restart_state & - ,tbpvs_state,tbpvs0_state -! - - LOGICAL, OPTIONAL :: f_qv,f_qc,f_qr,f_qi,f_qs,f_qg,f_qndrop,f_qni,f_qt & - ,f_qns,f_qnr,f_qng,f_qnn,f_qnc - -! LOCAL VAR - - INTEGER :: i,j,k,ij,sz,n - LOGICAL :: channel - -!--------------------------------------------------------------------- -! check for microphysics type. We need a clean way to -! specify these things! -!--------------------------------------------------------------------- - - channel = .FALSE. - - if (mp_physics .eq. 0) return - - - - IF( PRESENT(qlsink) ) qlsink(its:ite,kts:kte,jts:jte) = 0. - -!----------- - IF( PRESENT(chem_opt) .AND. PRESENT(progn) ) THEN - IF( chem_opt==0 .AND. progn==1 .AND. mp_physics==LINSCHEME ) THEN - IF( PRESENT( QNDROP_CURR ) ) THEN -! CALL wrf_debug ( 100 , 'microphysics_driver: calling prescribe_aerosol_mixactivate' ) -! 06-nov-2005 rce - id & itimestep added to arg list -! call prescribe_aerosol_mixactivate ( & -! id, itimestep, dt, naer, & -! rho, th, pi_phy, w, cldfra, cldfra_old, & -! z, dz8w, p8w, t8w, exch_h, & -! qv_curr, qc_curr, qi_curr, qndrop_curr, & -! nsource, & -! ids,ide, jds,jde, kds,kde, & -! ims,ime, jms,jme, kms,kme, & -! its,ite, jts,jte, kts,kte, & -! F_QC=f_qc, F_QI=f_qi ) - END IF - ELSE IF( progn==1 .AND. mp_physics/=LINSCHEME ) THEN -! call wrf_error_fatal("SETTINGS ERROR: Prognostic cloud droplet number can only be used with the mp_physics=LINSCHEME.") - END IF - END IF -!TBH write(6,*)'mp_phys = ',mp_physics - micro_select: SELECT CASE(mp_physics) - - CASE (KESSLERSCHEME) -! CALL wrf_debug ( 100 , 'microphysics_driver: calling kessler' ) - IF ( PRESENT( QV_CURR ) .AND. PRESENT( QC_CURR ) .AND. & - PRESENT( QR_CURR ) .AND. & - PRESENT( RAINNC ) .AND. PRESENT ( RAINNCV ) .AND. & - PRESENT( Z )) THEN - CALL kessler( & - T=th & - ,QV=qv_curr & - ,QC=qc_curr & - ,QR=qr_curr & - ,RHO=rho, PII=pi_phy,DT_IN=dt, Z=z, XLV=xlv, CP=cp & - ,EP2=ep_2,SVP1=svp1,SVP2=svp2 & - ,SVP3=svp3,SVPT0=svpt0,RHOWATER=rhowater & - ,DZ8W=dz8w & - ,RAINNC=rainnc,RAINNCV=rainncv & - ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & - ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & - ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & - ) - ELSE -! CALL wrf_error_fatal ( 'arguments not present for calling kessler' ) - ENDIF - -! - CASE (THOMPSON) -! CALL wrf_debug ( 100 , 'microphysics_driver: calling thompson' ) - IF ( PRESENT( QV_CURR ) .AND. PRESENT ( QC_CURR ) .AND. & - PRESENT( QR_CURR ) .AND. PRESENT ( QI_CURR ) .AND. & - PRESENT( QS_CURR ) .AND. PRESENT ( QG_CURR ) .AND. & - PRESENT( QNR_CURR) .AND. PRESENT ( QNI_CURR) .AND. & - PRESENT( RAINNC ) .AND. PRESENT ( RAINNCV ) ) THEN - CALL mp_gt_driver( & - QV=qv_curr, & - QC=qc_curr, & - QR=qr_curr, & - QI=qi_curr, & - QS=qs_curr, & - QG=qg_curr, & - NI=qni_curr, & - NR=qnr_curr, & - TH=th, & - PII=pi_phy, & - P=p, & - DZ=dz8w, & - DT_IN=dt, & - ITIMESTEP=itimestep, & - RAINNC=RAINNC, & - RAINNCV=RAINNCV, & - SNOWNC=SNOWNC, & - SNOWNCV=SNOWNCV, & - GRAUPELNC=GRAUPELNC, & - GRAUPELNCV=GRAUPELNCV, & - SR=SR & -! refl_10cm, grid_clock, grid_alarms, & - ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & - ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & - ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte) - ELSE -! CALL wrf_error_fatal ( 'arguments not present for calling thompson_et_al' ) - ENDIF -! - - CASE (MORR_TWO_MOMENT) -! CALL wrf_debug(100, 'microphysics_driver: calling morrison two moment') - IF (PRESENT (QV_CURR) .AND. PRESENT (QC_CURR) .AND. & - PRESENT (QR_CURR) .AND. PRESENT (QI_CURR) .AND. & - PRESENT (QS_CURR) .AND. PRESENT (QG_CURR) .AND. & - PRESENT (QR_CURR) .AND. PRESENT (QI_CURR) .AND. & - PRESENT (QNS_CURR) .AND. PRESENT (QNI_CURR).AND. & - PRESENT (QNR_CURR) .AND. PRESENT (QNG_CURR).AND. & - PRESENT (MU) .AND. PRESENT (QSCUTEN).AND. & - PRESENT (QRCUTEN) .AND. PRESENT (QICUTEN).AND. & - PRESENT (RAINNC ) .AND. PRESENT (RAINNCV) .AND. & - PRESENT (Z ) .AND.PRESENT ( W ) ) THEN - CALL mp_morr_two_moment( & - ITIMESTEP=itimestep, & !* - TH=th, & !* - QV=qv_curr, & !* - QC=qc_curr, & !* - QR=qr_curr, & !* - QI=qi_curr, & !* - QS=qs_curr, & !* - QG=qg_curr, & !* - NI=qni_curr, & !* - NS=qns_curr, & !* ! VVT - NR=qnr_curr, & !* ! VVT - NG=qng_curr, & !* ! VVT - RHO=rho, & !* - PII=pi_phy, & !* - P=p, & !* - DT_IN=dt, & !* - DZ=dz8w, & !* !hm - HT=ht, & !* - W=w & !* - ,RAINNC=RAINNC & !* - ,RAINNCV=RAINNCV & !* - ,SR=SR & !* !hm - ,qrcuten=qrcuten & ! hm - ,qscuten=qscuten & ! hm - ,qicuten=qicuten & ! hm - ,mu=mu & ! hm - ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & - ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & - ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & - ) - ELSE -! Call wrf_error_fatal( 'arguments not present for calling morrison two moment') - ENDIF - -! - CASE (GSFCGCESCHEME) -! CALL wrf_debug ( 100 , 'microphysics_driver: calling GSFCGCE' ) - IF ( PRESENT( QV_CURR ) .AND. PRESENT ( QC_CURR ) .AND. & - PRESENT( QR_CURR ) .AND. PRESENT ( QI_CURR ) .AND. & - PRESENT( QS_CURR ) .AND. & - PRESENT( RAINNC ) .AND. PRESENT ( RAINNCV ) .AND. & - PRESENT( HAIL ) .AND. PRESENT ( ICE2 ) .AND. & - PRESENT( Z ) .AND. PRESENT ( W ) ) THEN - CALL gsfcgce( & - TH=th & - ,QV=qv_curr & - ,QL=qc_curr & - ,QR=qr_curr & - ,QI=qi_curr & - ,QS=qs_curr & - ,RHO=rho, PII=pi_phy, P=p, DT_IN=dt, Z=z & - ,HT=ht, DZ8W=dz8w, GRAV=G & - ,RHOWATER=rhowater, RHOSNOW=rhosnow & - ,ITIMESTEP=itimestep & - ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & - ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & - ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & - ,RAINNC=rainnc, RAINNCV=rainncv & - ,SNOWNC=snownc, SNOWNCV=snowncv ,SR=sr & - ,GRAUPELNC=graupelnc ,GRAUPELNCV=graupelncv & - ,F_QG=f_qg & - ,QG=qg_curr & - ,IHAIL=hail, ICE2=ice2 & - ) -! HAIL = 1, run gsfcgce with hail option -! 0, run gsfcgce with graupel option <---- default -! note: no effect if ice2 = 1 -! ICE2 = 1, run gsfcgce with only snow, ice -! 2, run gsfcgce with only graupel, ice -! 0, run gsfcgce with snow, ice and hail/graupel <---- default - - ELSE -! CALL wrf_error_fatal ( 'arguments not present for calling GSFCGCE' ) - ENDIF - - CASE (LINSCHEME) -! CALL wrf_debug ( 100 , 'microphysics_driver: calling lin_et_al' ) - IF ( PRESENT( QV_CURR ) .AND. PRESENT ( QC_CURR ) .AND. & - PRESENT( QR_CURR ) .AND. PRESENT ( QI_CURR ) .AND. & - PRESENT( QS_CURR ) .AND. & - PRESENT( RAINNC ) .AND. PRESENT ( RAINNCV ) .AND. & - PRESENT( Z ) ) THEN - CALL lin_et_al( & - TH=th & - ,QV=qv_curr & - ,QL=qc_curr & - ,QR=qr_curr & - ,QI=qi_curr & - ,QS=qs_curr & - ,QLSINK=qlsink & - ,RHO=rho, PII=pi_phy, P=p, DT_IN=dt, Z=z & - ,HT=ht, DZ8W=dz8w, GRAV=G, CP=cp & - ,RAIR=r_d, RVAPOR=R_v & - ,XLS=xls, XLV=xlv, XLF=xlf & - ,RHOWATER=rhowater, RHOSNOW=rhosnow & - ,EP2=ep_2,SVP1=svp1,SVP2=svp2 & - ,SVP3=svp3,SVPT0=svpt0 & - ,RAINNC=rainnc, RAINNCV=rainncv & - ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & - ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & - ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & - ,PRECR=precr,PRECI=preci,PRECS=precs,PRECG=precg & - ,F_QG=f_qg, F_QNDROP=f_qndrop & - ,QG=qg_curr & - ,QNDROP=qndrop_curr & - ) - ELSE -! CALL wrf_error_fatal ( 'arguments not present for calling lin_et_al' ) - ENDIF - - CASE (WSM3SCHEME) -! CALL wrf_debug ( 100 , 'microphysics_driver: calling wsm3' ) -!TBH write(6,*)'wsm3-1 ' - IF ( PRESENT( QV_CURR ) .AND. PRESENT ( QC_CURR ) .AND. & - PRESENT( QR_CURR ) .AND. & - PRESENT( RAINNC ) .AND. PRESENT ( RAINNCV ) .AND. & - PRESENT( W ) ) THEN -!TBH write(6,*)'wsm3-1 ' - CALL wsm3( & - TH=th & - ,Q=qv_curr & - ,QCI=qc_curr & - ,QRS=qr_curr & - ,W=w,DEN=rho,PII=pi_phy,P=p,DELZ=dz8w & - ,DELT=dt,G=g,CPD=cp,CPV=cpv & - ,RD=r_d,RV=r_v,T0C=svpt0 & - ,EP1=ep_1, EP2=ep_2, QMIN=epsilon & - ,XLS=xls, XLV0=xlv, XLF0=xlf & - ,DEN0=rhoair0, DENR=rhowater & - ,CLIQ=cliq,CICE=cice,PSAT=psat & - ,RAIN=rainnc ,RAINNCV=rainncv & - ,SNOW=snownc ,SNOWNCV=snowncv & - ,SR=sr & - ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & - ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & - ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & - ) - ELSE -! CALL wrf_error_fatal ( 'arguments not present for calling wsm3' ) - ENDIF - - CASE (WSM5SCHEME) -!TBH write(6,*)'wsm5-1 ' -! CALL wrf_debug ( 100 , 'microphysics_driver: calling wsm5' ) - IF ( PRESENT( QV_CURR ) .AND. PRESENT ( QC_CURR ) .AND. & - PRESENT( QR_CURR ) .AND. PRESENT ( QI_CURR ) .AND. & - PRESENT( QS_CURR ) .AND. & - PRESENT( RAINNC ) .AND. PRESENT ( RAINNCV ) ) THEN -!TBH write(6,*)'wsm5-1 ' - CALL wsm5( & - TH=th & - ,Q=qv_curr & - ,QC=qc_curr & - ,QR=qr_curr & - ,QI=qi_curr & - ,QS=qs_curr & - ,DEN=rho,PII=pi_phy,P=p,DELZ=dz8w & - ,DELT=dt,G=g,CPD=cp,CPV=cpv & - ,RD=r_d,RV=r_v,T0C=svpt0 & - ,EP1=ep_1, EP2=ep_2, QMIN=epsilon & - ,XLS=xls, XLV0=xlv, XLF0=xlf & - ,DEN0=rhoair0, DENR=rhowater & - ,CLIQ=cliq,CICE=cice,PSAT=psat & - ,RAIN=rainnc ,RAINNCV=rainncv & - ,SNOW=snownc ,SNOWNCV=snowncv & - ,SR=sr & - ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & - ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & - ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & - ) - ELSE -! CALL wrf_error_fatal ( 'arguments not present for calling wsm5' ) - ENDIF - - CASE (WSM6SCHEME) -! CALL wrf_debug ( 100 , 'microphysics_driver: calling wsm6' ) - IF ( PRESENT( QV_CURR ) .AND. PRESENT ( QC_CURR ) .AND. & - PRESENT( QR_CURR ) .AND. PRESENT ( QI_CURR ) .AND. & - PRESENT( QS_CURR ) .AND. PRESENT ( QG_CURR ) .AND. & - PRESENT( RAINNC ) .AND. PRESENT ( RAINNCV ) ) THEN - CALL wsm6( & - TH=th & - ,Q=qv_curr & - ,QC=qc_curr & - ,QR=qr_curr & - ,QI=qi_curr & - ,QS=qs_curr & - ,QG=qg_curr & - ,DEN=rho,PII=pi_phy,P=p,DELZ=dz8w & - ,DELT=dt,G=g,CPD=cp,CPV=cpv & - ,RD=r_d,RV=r_v,T0C=svpt0 & - ,EP1=ep_1, EP2=ep_2, QMIN=epsilon & - ,XLS=xls, XLV0=xlv, XLF0=xlf & - ,DEN0=rhoair0, DENR=rhowater & - ,CLIQ=cliq,CICE=cice,PSAT=psat & - ,RAIN=rainnc ,RAINNCV=rainncv & - ,SNOW=snownc ,SNOWNCV=snowncv & - ,SR=sr & - ,GRAUPEL=graupelnc ,GRAUPELNCV=graupelncv & - ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & - ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & - ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & - ) - ELSE -! CALL wrf_error_fatal ( 'arguments not present for calling wsm6' ) - ENDIF - - CASE (WDM5SCHEME) -! CALL wrf_debug ( 100 , 'microphysics_driver: calling wdm5' ) - IF ( PRESENT( QV_CURR ) .AND. PRESENT ( QC_CURR ) .AND. & - PRESENT( QR_CURR ) .AND. PRESENT ( QI_CURR ) .AND. & - PRESENT( QS_CURR ) .AND. PRESENT( QNN_CURR ) .AND. & - PRESENT ( QNC_CURR ) .AND. PRESENT( QNR_CURR ).AND. & - PRESENT( RAINNC ) .AND. PRESENT ( RAINNCV ) ) THEN - CALL wdm5( & - TH=th & - ,Q=qv_curr & - ,QC=qc_curr & - ,QR=qr_curr & - ,QI=qi_curr & - ,QS=qs_curr & - ,NN=qnn_curr & - ,NC=qnc_curr & - ,NR=qnr_curr & - ,DEN=rho,PII=pi_phy,P=p,DELZ=dz8w & - ,DELT=dt,G=g,CPD=cp,CPV=cpv,CCN0=n_ccn0 & - ,RD=r_d,RV=r_v,T0C=svpt0 & - ,EP1=ep_1, EP2=ep_2, QMIN=epsilon & - ,XLS=xls, XLV0=xlv, XLF0=xlf & - ,DEN0=rhoair0, DENR=rhowater & - ,CLIQ=cliq,CICE=cice,PSAT=psat & - ,RAIN=rainnc ,RAINNCV=rainncv & - ,SNOW=snownc ,SNOWNCV=snowncv & - ,SR=sr & - ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & - ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & - ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & - ) - ELSE -! CALL wrf_error_fatal ( 'arguments not present for calling wdm5') - ENDIF - - CASE (WDM6SCHEME) -! CALL wrf_debug ( 100 , 'microphysics_driver: calling wdm6' ) - IF ( PRESENT( QV_CURR ) .AND. PRESENT ( QC_CURR ) .AND. & - PRESENT( QR_CURR ) .AND. PRESENT ( QI_CURR ) .AND. & - PRESENT( QS_CURR ) .AND. PRESENT ( QG_CURR ) .AND. & - PRESENT( QNN_CURR ) .AND. PRESENT ( QNC_CURR ) .AND. & - PRESENT( QNR_CURR ).AND. & - PRESENT( RAINNC ) .AND. PRESENT ( RAINNCV ) ) THEN - CALL wdm6( & - TH=th & - ,Q=qv_curr & - ,QC=qc_curr & - ,QR=qr_curr & - ,QI=qi_curr & - ,QS=qs_curr & - ,QG=qg_curr & - ,NN=qnn_curr & - ,NC=qnc_curr & - ,NR=qnr_curr & - ,DEN=rho,PII=pi_phy,P=p,DELZ=dz8w & - ,DELT=dt,G=g,CPD=cp,CPV=cpv,CCN0=n_ccn0 & - ,RD=r_d,RV=r_v,T0C=svpt0 & - ,EP1=ep_1, EP2=ep_2, QMIN=epsilon & - ,XLS=xls, XLV0=xlv, XLF0=xlf & - ,DEN0=rhoair0, DENR=rhowater & - ,CLIQ=cliq,CICE=cice,PSAT=psat & - ,RAIN=rainnc ,RAINNCV=rainncv & - ,SNOW=snownc ,SNOWNCV=snowncv & - ,SR=sr & - ,GRAUPEL=graupelnc ,GRAUPELNCV=graupelncv & - ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & - ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & - ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & - ) - ELSE -! CALL wrf_error_fatal ( 'arguments not present for calling wdm6') - ENDIF - -! CASE (ETAMPNEW) -! CALL wrf_debug ( 100 , 'microphysics_driver: calling etampnew') - -! IF ( PRESENT( qv_curr ) .AND. PRESENT( qt_curr ) .AND. & -! PRESENT( RAINNC ) .AND. PRESENT ( RAINNCV ) .AND. & -! PRESENT( mp_restart_state ) .AND. & -! PRESENT( tbpvs_state ) .AND. & -! PRESENT( tbpvs0_state ) ) THEN -! CALL ETAMP_NEW( & -! ITIMESTEP=itimestep,DT=dt,DX=dx,DY=dy & -! ,DZ8W=dz8w,RHO_PHY=rho,P_PHY=p,PI_PHY=pi_phy,TH_PHY=th & -! ,QV=qv_curr & -! ,QC=qc_curr & -! ,QS=qs_curr & -! ,QR=qr_curr & -! ,QT=qt_curr & -! ,LOWLYR=LOWLYR,SR=SR & -! ,F_ICE_PHY=F_ICE_PHY,F_RAIN_PHY=F_RAIN_PHY & -! ,F_RIMEF_PHY=F_RIMEF_PHY & -! ,RAINNC=rainnc,RAINNCV=rainncv & -! ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & -! ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & -! ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & -! ,MP_RESTART_STATE=mp_restart_state & -! ,TBPVS_STATE=tbpvs_state,TBPVS0_STATE=tbpvs0_state & -! ) -! ELSE -! CALL wrf_error_fatal ( 'arguments not present for calling etampnew' ) -! ENDIF - - CASE (THOMPSON07) -! CALL wrf_debug ( 100 , 'microphysics_driver: calling thompson07 et al' ) - IF ( PRESENT( QV_CURR ) .AND. PRESENT ( QC_CURR ) .AND. & - PRESENT( QR_CURR ) .AND. PRESENT ( QI_CURR ) .AND. & - PRESENT( QS_CURR ) .AND. PRESENT ( QG_CURR ) .AND. & - PRESENT ( QNI_CURR ).AND. & - PRESENT( RAINNC ) .AND. PRESENT ( RAINNCV ) ) THEN - CALL mp_gt_driver07( & - QV=qv_curr, & - QC=qc_curr, & - QR=qr_curr, & - QI=qi_curr, & - QS=qs_curr, & - QG=qg_curr, & - NI=qni_curr, & - TH=th, & - PII=pi_phy, & - P=p, & - DZ=dz8w, & - DT_IN=dt, & - ITIMESTEP=itimestep, & - RAINNC=RAINNC, & - RAINNCV=RAINNCV, & - SR=SR & - ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & - ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & - ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte) - ELSE -! CALL wrf_error_fatal ( 'arguments not present for calling thompson07' ) - ENDIF - - CASE DEFAULT - -! WRITE( wrf_err_message , * ) 'The microphysics option does not exist: mp_physics = ', mp_physics -! CALL wrf_error_fatal ( wrf_err_message ) - - END SELECT micro_select - -! ENDDO -!#ifndef RUN_ON_GPU -! !$OMP END PARALLEL DO -!#endif - -! CALL wrf_debug ( 200 , 'microphysics_driver: returning from' ) - - RETURN - - END SUBROUTINE microphysics_driver - -END MODULE module_microphysics_driver diff --git a/src/fim/FIMsrc/fim/wrfphys/module_mixactivate.F b/src/fim/FIMsrc/fim/wrfphys/module_mixactivate.F deleted file mode 100644 index deb0964..0000000 --- a/src/fim/FIMsrc/fim/wrfphys/module_mixactivate.F +++ /dev/null @@ -1,2618 +0,0 @@ -!********************************************************************************** -! This computer software was prepared by Battelle Memorial Institute, hereinafter -! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of -! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, -! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. -! -! MOSAIC module: see chem/module_mosaic_driver.F for references and terms of use -!********************************************************************************** - -MODULE module_mixactivate -PRIVATE -PUBLIC prescribe_aerosol_mixactivate, mixactivate -CONTAINS - - -!---------------------------------------------------------------------- -!---------------------------------------------------------------------- -! 06-nov-2005 rce - grid_id & ktau added to arg list -! 25-apr-2006 rce - dens_aer is (g/cm3), NOT (kg/m3) - subroutine prescribe_aerosol_mixactivate ( & - grid_id, ktau, dtstep, naer, & - rho_phy, th_phy, pi_phy, w, cldfra, cldfra_old, & - z, dz8w, p_at_w, t_at_w, exch_h, & - qv, qc, qi, qndrop3d, & - nsource, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - f_qc, f_qi ) - -! USE module_configure - -! wrapper to call mixactivate for mosaic description of aerosol - - implicit none - -! subr arguments - integer, intent(in) :: & - grid_id, ktau, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte - - real, intent(in) :: dtstep - real, intent(inout) :: naer ! aerosol number (/kg) - - real, intent(in), & - dimension( ims:ime, kms:kme, jms:jme ) :: & - rho_phy, th_phy, pi_phy, w, & - z, dz8w, p_at_w, t_at_w, exch_h - - real, intent(inout), & - dimension( ims:ime, kms:kme, jms:jme ) :: cldfra, cldfra_old - - real, intent(in), & - dimension( ims:ime, kms:kme, jms:jme ) :: & - qv, qc, qi - - real, intent(inout), & - dimension( ims:ime, kms:kme, jms:jme ) :: & - qndrop3d - - real, intent(out), & - dimension( ims:ime, kms:kme, jms:jme) :: nsource - - LOGICAL, OPTIONAL :: f_qc, f_qi - -! local vars - integer maxd_aphase, maxd_atype, maxd_asize, maxd_acomp, max_chem - parameter (maxd_aphase=2,maxd_atype=1,maxd_asize=1,maxd_acomp=1, max_chem=10) - real ddvel(its:ite, jts:jte, max_chem) ! dry deposition velosity - real qsrflx(ims:ime, jms:jme, max_chem) ! dry deposition flux of aerosol - real chem(ims:ime, kms:kme, jms:jme, max_chem) ! chem array - integer i,j,k,l,m,n,p - real hygro( its:ite, kts:kte, jts:jte, maxd_asize, maxd_atype ) ! bulk - integer ntype_aer, nsize_aer(maxd_atype),ncomp_aer(maxd_atype), nphase_aer - integer massptr_aer( maxd_acomp, maxd_asize, maxd_atype, maxd_aphase ), & - waterptr_aer( maxd_asize, maxd_atype ), & - numptr_aer( maxd_asize, maxd_atype, maxd_aphase ), & - ai_phase, cw_phase - real dlo_sect( maxd_asize, maxd_atype ), & ! minimum size of section (cm) - dhi_sect( maxd_asize, maxd_atype ), & ! maximum size of section (cm) - sigmag_aer(maxd_asize, maxd_atype), & ! geometric standard deviation of aerosol size dist - dgnum_aer(maxd_asize, maxd_atype), & ! median diameter (cm) of number distrib of mode - dens_aer( maxd_acomp, maxd_atype), & ! density (g/cm3) of material - mw_aer( maxd_acomp, maxd_atype), & ! molecular weight (g/mole) - dpvolmean_aer(maxd_asize, maxd_atype) ! mean-volume diameter (cm) of mode -! terminology: (pi/6) * (mean-volume diameter)**3 == -! (volume mixing ratio of section/mode)/(number mixing ratio) - real, dimension(ims:ime,kms:kme,jms:jme) :: & - ccn1,ccn2,ccn3,ccn4,ccn5,ccn6 ! number conc of aerosols activated at supersat - integer idrydep_onoff - real, dimension(ims:ime,kms:kme,jms:jme) :: t_phy - integer msectional - - - integer ptr - real maer - - if(naer.lt.1.)then - naer=1000.e6 ! #/kg default value - endif - ai_phase=1 - cw_phase=2 - idrydep_onoff = 0 - msectional = 0 - - t_phy(its:ite,kts:kte,jts:jte)=th_phy(its:ite,kts:kte,jts:jte)*pi_phy(its:ite,kts:kte,jts:jte) - - ntype_aer=maxd_atype - do n=1,ntype_aer - nsize_aer(n)=maxd_asize - ncomp_aer(n)=maxd_acomp - end do - nphase_aer=maxd_aphase - -! set properties for each type and size - do n=1,ntype_aer - do m=1,nsize_aer(n) - dlo_sect( m,n )=0.01e-4 ! minimum size of section (cm) - dhi_sect( m,n )=0.5e-4 ! maximum size of section (cm) - sigmag_aer(m,n)=2. ! geometric standard deviation of aerosol size dist - dgnum_aer(m,n)=0.1e-4 ! median diameter (cm) of number distrib of mode - dpvolmean_aer(m,n) = dgnum_aer(m,n) * exp( 1.5 * (log(sigmag_aer(m,n)))**2 ) - end do - do l=1,ncomp_aer(n) - dens_aer( l, n)=1.0 ! density (g/cm3) of material - mw_aer( l, n)=132. ! molecular weight (g/mole) - end do - end do - ptr=0 - do p=1,nphase_aer - do n=1,ntype_aer - do m=1,nsize_aer(n) - ptr=ptr+1 - numptr_aer( m, n, p )=ptr - if(p.eq.ai_phase)then - chem(its:ite,kts:kte,jts:jte,ptr)=naer - else - chem(its:ite,kts:kte,jts:jte,ptr)=0. - endif - end do ! size - end do ! type - end do ! phase - do p=1,maxd_aphase - do n=1,ntype_aer - do m=1,nsize_aer(n) - do l=1,ncomp_aer(n) - ptr=ptr+1 - if(ptr.gt.max_chem)then - write(6,*)'ptr,max_chem=',ptr,max_chem,' in prescribe_aerosol_mixactivate' - call exit(1) - endif - massptr_aer(l, m, n, p)=ptr -! maer is ug/kg-air; naer is #/kg-air; dgnum is cm; dens_aer is g/cm3 -! 1.e6 factor converts g to ug - maer= 1.0e6 * naer * dens_aer(l,n) * ( (3.1416/6.) * & - (dgnum_aer(m,n)**3) * exp( 4.5*((log(sigmag_aer(m,n)))**2) ) ) - if(p.eq.ai_phase)then - chem(its:ite,kts:kte,jts:jte,ptr)=maer - else - chem(its:ite,kts:kte,jts:jte,ptr)=0. - endif - end do - end do ! size - end do ! type - end do ! phase - do n=1,ntype_aer - do m=1,nsize_aer(n) - ptr=ptr+1 - if(ptr.gt.max_chem)then - write(6,*)'ptr,max_chem=',ptr,max_chem,' in prescribe_aerosol_mixactivate' - call exit(1) - endif -!wig waterptr_aer(m, n)=ptr - waterptr_aer(m, n)=-1 - end do ! size - end do ! type - ddvel(its:ite,jts:jte,:)=0. - hygro(its:ite,kts:kte,jts:jte,:,:) = 0.5 - -! 06-nov-2005 rce - grid_id & ktau added to arg list - call mixactivate( msectional, & - chem,max_chem,qv,qc,qi,qndrop3d, & - t_phy, w, ddvel, idrydep_onoff, & - maxd_acomp, maxd_asize, maxd_atype, maxd_aphase, & - ncomp_aer, nsize_aer, ntype_aer, nphase_aer, & - numptr_aer, massptr_aer, dlo_sect, dhi_sect, sigmag_aer, dpvolmean_aer, & - dens_aer, mw_aer, & - waterptr_aer, hygro, ai_phase, cw_phase, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - rho_phy, z, dz8w, p_at_w, t_at_w, exch_h, & - cldfra, cldfra_old, qsrflx, & - ccn1, ccn2, ccn3, ccn4, ccn5, ccn6, nsource, & - grid_id, ktau, dtstep, & - F_QC=f_qc, F_QI=f_qi ) - - - end subroutine prescribe_aerosol_mixactivate - -!---------------------------------------------------------------------- -!---------------------------------------------------------------------- -! nov-04 sg ! replaced amode with aer and expanded aerosol dimension to include type and phase - -! 06-nov-2005 rce - grid_id & ktau added to arg list -! 25-apr-2006 rce - dens_aer is (g/cm3), NOT (kg/m3) -subroutine mixactivate( msectional, & - chem, num_chem, qv, qc, qi, qndrop3d, & - temp, w, ddvel, idrydep_onoff, & - maxd_acomp, maxd_asize, maxd_atype, maxd_aphase, & - ncomp_aer, nsize_aer, ntype_aer, nphase_aer, & - numptr_aer, massptr_aer, dlo_sect, dhi_sect, sigmag_aer, dpvolmean_aer, & - dens_aer, mw_aer, & - waterptr_aer, hygro, ai_phase, cw_phase, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - rho, zm, dz8w, p_at_w, t_at_w, kvh, & - cldfra, cldfra_old, qsrflx, & - ccn1, ccn2, ccn3, ccn4, ccn5, ccn6, nsource, & - grid_id, ktau, dtstep, & - f_qc, f_qi ) - - -! vertical diffusion and nucleation of cloud droplets -! assume cloud presence controlled by cloud fraction -! doesn't distinguish between warm, cold clouds - - USE module_model_constants, only: g, rhowater, xlv, cp, rvovrd, r_d, r_v, mwdry, ep_2 - USE module_radiation_driver, only: cal_cldfra - - implicit none - -! input - - INTEGER, intent(in) :: grid_id, ktau - INTEGER, intent(in) :: num_chem - integer, intent(in) :: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - - integer maxd_aphase, nphase_aer, maxd_atype, ntype_aer - integer maxd_asize, maxd_acomp, nsize_aer(maxd_atype) - integer, intent(in) :: & - ncomp_aer( maxd_atype ), & - massptr_aer( maxd_acomp, maxd_asize, maxd_atype, maxd_aphase ), & - waterptr_aer( maxd_asize, maxd_atype ), & - numptr_aer( maxd_asize, maxd_atype, maxd_aphase), & - ai_phase, cw_phase - integer, intent(in) :: msectional ! 1 for sectional, 0 for modal - integer, intent(in) :: idrydep_onoff - real, intent(in) :: & - dlo_sect( maxd_asize, maxd_atype ), & ! minimum size of section (cm) - dhi_sect( maxd_asize, maxd_atype ), & ! maximum size of section (cm) - sigmag_aer(maxd_asize, maxd_atype), & ! geometric standard deviation of aerosol size dist - dens_aer( maxd_acomp, maxd_atype), & ! density (g/cm3) of material - mw_aer( maxd_acomp, maxd_atype), & ! molecular weight (g/mole) - dpvolmean_aer(maxd_asize, maxd_atype) ! mean-volume diameter (cm) of mode -! terminology: (pi/6) * (mean-volume diameter)**3 == -! (volume mixing ratio of section/mode)/(number mixing ratio) - - - REAL, intent(inout), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ) :: & - chem ! aerosol molar mixing ratio (ug/kg or #/kg) - - REAL, intent(in), DIMENSION( ims:ime, kms:kme, jms:jme ) :: & - qv, qc, qi ! water species (vapor, cloud drops, cloud ice) mixing ratio (g/g) - - LOGICAL, OPTIONAL :: f_qc, f_qi - - REAL, intent(inout), DIMENSION( ims:ime, kms:kme, jms:jme ) :: & - qndrop3d ! water species mixing ratio (g/g) - - real, intent(in) :: dtstep ! time step for microphysics (s) - real, intent(in) :: temp(ims:ime, kms:kme, jms:jme) ! temperature (K) - real, intent(in) :: w(ims:ime, kms:kme, jms:jme) ! vertical velocity (m/s) - real, intent(in) :: rho(ims:ime, kms:kme, jms:jme) ! density at mid-level (kg/m3) - REAL, intent(in) :: ddvel( its:ite, jts:jte, num_chem ) ! deposition velocity (m/s) - real, intent(in) :: zm(ims:ime, kms:kme, jms:jme) ! geopotential height of level (m) - real, intent(in) :: dz8w(ims:ime, kms:kme, jms:jme) ! layer thickness (m) - real, intent(in) :: p_at_w(ims:ime, kms:kme, jms:jme) ! pressure at layer interface (Pa) - real, intent(in) :: t_at_w(ims:ime, kms:kme, jms:jme) ! temperature at layer interface (K) - real, intent(in) :: kvh(ims:ime, kms:kme, jms:jme) ! vertical diffusivity (m2/s) - real, intent(inout) :: cldfra_old(ims:ime, kms:kme, jms:jme)! cloud fraction on previous time step - real, intent(inout) :: cldfra(ims:ime, kms:kme, jms:jme) ! cloud fraction - real, intent(in) :: hygro( its:ite, kts:kte, jts:jte, maxd_asize, maxd_atype ) ! bulk hygroscopicity & - - REAL, intent(out), DIMENSION( ims:ime, jms:jme, num_chem ) :: qsrflx ! dry deposition rate for aerosol - real, intent(out), dimension(ims:ime,kms:kme,jms:jme) :: nsource, & ! droplet number source (#/kg/s) - ccn1,ccn2,ccn3,ccn4,ccn5,ccn6 ! number conc of aerosols activated at supersat - - -!--------------------Local storage------------------------------------- -! - real :: dgnum_aer(maxd_asize, maxd_atype) ! median diameter (cm) of number distrib of mode - real :: qndrop(kms:kme) ! cloud droplet number mixing ratio (#/kg) - real :: lcldfra(kms:kme) ! liquid cloud fraction - real :: lcldfra_old(kms:kme) ! liquid cloud fraction for previous timestep - real :: wtke(kms:kme) ! turbulent vertical velocity at base of layer k (m2/s) - real zn(kms:kme) ! g/pdel (m2/g) for layer - real zs(kms:kme) ! inverse of distance between levels (m) - real zkmin,zkmax - data zkmin/0.01/,zkmax/100./ - save zkmin,zkmax - real cs(kms:kme) ! air density (kg/m3) at layer center - real csbot(kms:kme) ! air density (kg/m3) at layer bottom - real csbot_cscen(kms:kme) ! csbot(k)/cs(k) - real dz(kms:kme) ! geometric thickness of layers (m) - - real wdiab ! diabatic vertical velocity -! real, parameter :: wmixmin = 0.1 ! minimum turbulence vertical velocity (m/s) - real, parameter :: wmixmin = 0.2 ! minimum turbulence vertical velocity (m/s) -! real, parameter :: wmixmin = 1.0 ! minimum turbulence vertical velocity (m/s) - real :: qndrop_new(kms:kme) ! droplet number nucleated on cloud boundaries - real :: ekd(kms:kme) ! diffusivity for droplets (m2/s) - real :: ekk(kms:kme) ! density*diffusivity for droplets (kg/m3 m2/s) - real :: srcn(kms:kme) ! droplet source rate (/s) - real, save :: sq2pi - data sq2pi/2.5066282746/ - real dtinv - - logical top ! true if cloud top, false if cloud base or new cloud - logical, save :: first - data first/.true./ - integer km1,kp1 - real wbar,wmix,wmin,wmax - real, save :: cmincld - data cmincld/1.e-12/ - real dum - real tmpa, tmpb, tmpc, tmpc1, tmpc2, tmpd, tmpe, tmpf - real tmpcourno - real dact - real fluxntot ! (#/cm2/s) - real fac_srflx - real depvel_drop, depvel_tmp - real, parameter :: depvel_uplimit = 1.0 ! upper limit for dep vels (m/s) - real :: surfrate(num_chem) ! surface exchange rate (/s) - real surfratemax ! max surfrate for all species treated here - real surfrate_drop ! surfade exchange rate for droplelts - real dtmin,tinv,dtt - integer nsubmix,nsubmix_bnd - integer i,j,k,m,n,nsub - real dtmix - real alogarg - real qcld - real pi - integer nnew,nsav,ntemp - real :: overlapp(kms:kme),overlapm(kms:kme) ! cloud overlap - real :: ekkp(kms:kme),ekkm(kms:kme) ! zn*zs*density*diffusivity - integer, save :: count_submix(100)=0 ! wig: Note that this is a no-no for tile threads with OMP - - integer lnum,lnumcw,l,lmass,lmasscw,lsfc,lsfccw,ltype,lsig,lwater - integer :: ntype(maxd_asize) - - real :: naerosol(maxd_asize, maxd_atype) ! interstitial aerosol number conc (/m3) - real :: naerosolcw(maxd_asize, maxd_atype) ! activated number conc (/m3) - real :: maerosol(maxd_acomp,maxd_asize, maxd_atype) ! interstit mass conc (kg/m3) - real :: maerosolcw(maxd_acomp,maxd_asize, maxd_atype) ! activated mass conc (kg/m3) - real :: maerosol_tot(maxd_asize, maxd_atype) ! species-total interstit mass conc (kg/m3) - real :: maerosol_totcw(maxd_asize, maxd_atype) ! species-total activated mass conc (kg/m3) - real :: vaerosol(maxd_asize, maxd_atype) ! interstit+activated aerosol volume conc (m3/m3) - real :: vaerosolcw(maxd_asize, maxd_atype) ! activated aerosol volume conc (m3/m3) - real :: raercol(kms:kme,num_chem,2) ! aerosol mass, number mixing ratios - real :: source(kms:kme) ! - - real :: fn(maxd_asize, maxd_atype) ! activation fraction for aerosol number - real :: fs(maxd_asize, maxd_atype) ! activation fraction for aerosol sfcarea - real :: fm(maxd_asize, maxd_atype) ! activation fraction for aerosol mass - integer :: ncomp(maxd_atype) - - real :: fluxn(maxd_asize, maxd_atype) ! number activation fraction flux (m/s) - real :: fluxs(maxd_asize, maxd_atype) ! sfcarea activation fraction flux (m/s) - real :: fluxm(maxd_asize, maxd_atype) ! mass activation fraction flux (m/s) - real :: flux_fullact(kms:kme) ! 100% activation fraction flux (m/s) -! note: activation fraction fluxes are defined as -! fluxn = [flux of activated aero. number into cloud (#/m2/s)] -! / [aero. number conc. in updraft, just below cloudbase (#/m3)] - - real :: nact(kms:kme,maxd_asize, maxd_atype) ! fractional aero. number activation rate (/s) - real :: mact(kms:kme,maxd_asize, maxd_atype) ! fractional aero. mass activation rate (/s) - real :: npv(maxd_asize, maxd_atype) ! number per volume concentration (/m3) - real scale - - real :: hygro_aer(maxd_asize, maxd_atype) ! hygroscopicity of aerosol mode - real :: exp45logsig ! exp(4.5*alogsig**2) - real :: alogsig(maxd_asize, maxd_atype) ! natl log of geometric standard dev of aerosol - integer, parameter :: psat=6 ! number of supersaturations to calc ccn concentration - real ccn(kts:kte,psat) ! number conc of aerosols activated at supersat - real, parameter :: supersat(psat)= &! supersaturation (%) to determine ccn concentration - (/0.02,0.05,0.1,0.2,0.5,1.0/) - real super(psat) ! supersaturation - real,save :: surften ! surface tension of water w/respect to air (N/m) - data surften/0.076/ - real :: ccnfact(psat,maxd_asize, maxd_atype) - real :: amcube(maxd_asize, maxd_atype) ! cube of dry mode radius (m) - real :: argfactor(maxd_asize, maxd_atype) - real aten ! surface tension parameter - real t0 ! reference temperature - real sm ! critical supersaturation - real arg - -!!$#if (defined AIX) -!!$#define ERF erf -!!$#define ERFC erfc -!!$#else -!!$#define ERF erf -!!$ real erf -!!$#define ERFC erfc -!!$ real erfc -!!$#endif - - character*8, parameter :: ccn_name(psat)=(/'CCN1','CCN2','CCN3','CCN4','CCN5','CCN6'/) - - - arg = 1.0 - if (abs(0.8427-ERF_ALT(arg))/0.8427>0.001) then - write (6,*) 'erf_alt(1.0) = ',ERF_ALT(arg) - write (6,*) 'dropmixnuc: Error function error' - call exit - endif - arg = 0.0 - if (ERF_ALT(arg) /= 0.0) then - write (6,*) 'erf_alt(0.0) = ',ERF_ALT(arg) - write (6,*) 'dropmixnuc: Error function error' - call exit - endif - - pi = 4.*atan(1.0) - dtinv=1./dtstep - - depvel_drop = 0.1 ! prescribed here rather than getting it from dry_dep_driver - if (idrydep_onoff .le. 0) depvel_drop = 0.0 - depvel_drop = min(depvel_drop,depvel_uplimit) - - do n=1,ntype_aer - do m=1,nsize_aer(n) - ncomp(n)=ncomp_aer(n) - alogsig(m,n)=alog(sigmag_aer(m,n)) - dgnum_aer(m,n) = dpvolmean_aer(m,n) * exp( -1.5*alogsig(m,n)*alogsig(m,n) ) -! print *,'sigmag_aer,dgnum_aer=',sigmag_aer(m,n),dgnum_aer(m,n) - ! npv is used only if number is diagnosed from volume - npv(m,n)=6./(pi*(0.01*dgnum_aer(m,n))**3*exp(4.5*alogsig(m,n)*alogsig(m,n))) - end do - end do - t0=273. - aten=2.*surften/(r_v*t0*rhowater) - super(:)=0.01*supersat(:) - do n=1,ntype_aer - do m=1,nsize_aer(n) - exp45logsig=exp(4.5*alogsig(m,n)*alogsig(m,n)) - argfactor(m,n)=2./(3.*sqrt(2.)*alogsig(m,n)) - amcube(m,n)=3./(4.*pi*exp45logsig*npv(m,n)) - enddo - enddo - - IF( PRESENT(F_QC) .AND. PRESENT ( F_QI ) ) THEN - CALL cal_cldfra(CLDFRA,qc,qi,f_qc,f_qi, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - END IF - - qsrflx(its:ite,jts:jte,:) = 0. - -! start loop over columns - -OVERALL_MAIN_J_LOOP: do j=jts,jte -OVERALL_MAIN_I_LOOP: do i=its,ite - -! load number nucleated into qndrop on cloud boundaries - -! initialization for current i ......................................... - - do k=kts+1,kte - zs(k)=1./(zm(i,k,j)-zm(i,k-1,j)) - enddo - zs(kts)=zs(kts+1) - zs(kte+1)=0. - - do k=kts,kte -!!$ if(qndrop3d(i,k,j).lt.-10.e6.or.qndrop3d(i,k,j).gt.1.E20)then -!!$! call exit(1) -!!$ endif - if(f_qi)then - qcld=qc(i,k,j)+qi(i,k,j) - else - qcld=qc(i,k,j) - endif - if(qcld.lt.-1..or.qcld.gt.1.)then - write(6,'(a,g12.2,a,3i5)')'qcld=',qcld,' for i,k,j=',i,k,j - call exit(1) - endif - if(qcld.gt.1.e-20)then - lcldfra(k)=cldfra(i,k,j)*qc(i,k,j)/qcld - lcldfra_old(k)=cldfra_old(i,k,j)*qc(i,k,j)/qcld - else - lcldfra(k)=0. - lcldfra_old(k)=0. - endif - qndrop(k)=qndrop3d(i,k,j) -! qndrop(k)=1.e5 - cs(k)=rho(i,k,j) ! air density (kg/m3) - dz(k)=dz8w(i,k,j) - do n=1,ntype_aer - do m=1,nsize_aer(n) - nact(k,m,n)=0. - mact(k,m,n)=0. - enddo - enddo - zn(k)=1./(cs(k)*dz(k)) - if(k>kts)then - ekd(k)=kvh(i,k,j) - ekd(k)=max(ekd(k),zkmin) - ekd(k)=min(ekd(k),zkmax) - else - ekd(k)=0 - endif -! diagnose subgrid vertical velocity from diffusivity - if(k.eq.kts)then - wtke(k)=sq2pi*depvel_drop -! wtke(k)=sq2pi*kvh(i,k,j) -! wtke(k)=max(wtke(k),wmixmin) - else - wtke(k)=sq2pi*ekd(k)/dz(k) - endif - wtke(k)=max(wtke(k),wmixmin) - nsource(i,k,j)=0. - enddo - nsource(i,kte+1,j) = 0. - qndrop(kte+1) = 0. - zn(kte+1) = 0. - - do k = kts+1, kte - tmpa = dz(k-1) ; tmpb = dz(k) - tmpc = tmpa/(tmpa + tmpb) - csbot(k) = cs(k-1)*(1.0-tmpc) + cs(k)*tmpc - csbot_cscen(k) = csbot(k)/cs(k) - end do - csbot(kts) = cs(kts) - csbot_cscen(kts) = 1.0 - csbot(kte+1) = cs(kte) - csbot_cscen(kte+1) = 1.0 - - ! calculate surface rate and mass mixing ratio for aerosol - - surfratemax = 0.0 - nsav=1 - nnew=2 - surfrate_drop=depvel_drop/dz(kts) - surfratemax = max( surfratemax, surfrate_drop ) - do n=1,ntype_aer - do m=1,nsize_aer(n) - lnum=numptr_aer(m,n,ai_phase) - lnumcw=numptr_aer(m,n,cw_phase) - if(lnum>0)then - depvel_tmp = max( 0.0, min( ddvel(i,j,lnum), depvel_uplimit ) ) - surfrate(lnum)=depvel_tmp/dz(kts) - surfrate(lnumcw)=surfrate_drop - surfratemax = max( surfratemax, surfrate(lnum) ) -! scale = 1000./mwdry ! moles/kg - scale = 1. - raercol(kts:kte,lnumcw,nsav)=chem(i,kts:kte,j,lnumcw)*scale ! #/kg - raercol(kts:kte,lnum,nsav)=chem(i,kts:kte,j,lnum)*scale - endif - do l=1,ncomp(n) - lmass=massptr_aer(l,m,n,ai_phase) - lmasscw=massptr_aer(l,m,n,cw_phase) -! scale = mw_aer(l,n)/mwdry - scale = 1.e-9 ! kg/ug - depvel_tmp = max( 0.0, min( ddvel(i,j,lmass), depvel_uplimit ) ) - surfrate(lmass)=depvel_tmp/dz(kts) - surfrate(lmasscw)=surfrate_drop - surfratemax = max( surfratemax, surfrate(lmass) ) - raercol(kts:kte,lmasscw,nsav)=chem(i,kts:kte,j,lmasscw)*scale ! kg/kg - raercol(kts:kte,lmass,nsav)=chem(i,kts:kte,j,lmass)*scale ! kg/kg - enddo - lwater=waterptr_aer(m,n) - if(lwater>0)then - depvel_tmp = max( 0.0, min( ddvel(i,j,lwater), depvel_uplimit ) ) - surfrate(lwater)=depvel_tmp/dz(kts) - surfratemax = max( surfratemax, surfrate(lwater) ) - raercol(kts:kte,lwater,nsav)=chem(i,kts:kte,j,lwater) ! don't bother to convert units, - ! because it doesn't contribute to aerosol mass - endif - enddo ! size - enddo ! type - - -! droplet nucleation/aerosol activation - -! k-loop for growing/shrinking cloud calcs ............................. -GROW_SHRINK_MAIN_K_LOOP: do k=kts,kte - km1=max0(k-1,1) - kp1=min0(k+1,kde-1) - - -! if(lcldfra(k)-lcldfra_old(k).gt.0.01)then ! this line is the "old" criterion -! go to 10 - -! growing cloud PLUS -! upwards vertical advection when lcldfra(k-1) < lcldfra(k) -! -! tmpc1 = cloud fraction increase from previous time step - tmpc1 = max( (lcldfra(k)-lcldfra_old(k)), 0.0 ) - if (k > kts) then -! tmpc2 = fraction of layer for which vertical advection from below -! (over dtstep) displaces cloudy air with clear air -! = (courant number using upwards w at layer bottom)*(difference in cloud fraction) - tmpcourno = dtstep*max(w(i,k,j),0.0)/dz(k) - tmpc2 = max( (lcldfra(k)-lcldfra(km1)), 0.0 ) * tmpcourno - tmpc2 = min( tmpc2, 1.0 ) -! tmpc2 = 0.0 ! this turns off the vertical advect part - else - tmpc2 = 0.0 - endif - - if ((tmpc1 > 0.001) .or. (tmpc2 > 0.001)) then - -! wmix=wtke(k) - wbar=w(i,k,j)+wtke(k) - wmix=0. - wmin=0. -! 06-nov-2005 rce - increase wmax from 10 to 50 (deep convective clouds) - wmax=50. - wdiab=0 - -! load aerosol properties, assuming external mixtures - do n=1,ntype_aer - do m=1,nsize_aer(n) - call loadaer(raercol(1,1,nsav),k,kms,kme,num_chem, & - cs(k), npv(m,n), dlo_sect(m,n),dhi_sect(m,n), & - maxd_acomp, ncomp(n), & - grid_id, ktau, i, j, m, n, & - numptr_aer(m,n,ai_phase),numptr_aer(m,n,cw_phase), & - dens_aer(1,n), & - massptr_aer(1,m,n,ai_phase), massptr_aer(1,m,n,cw_phase), & - maerosol(1,m,n), maerosolcw(1,m,n), & - maerosol_tot(m,n), maerosol_totcw(m,n), & - naerosol(m,n), naerosolcw(m,n), & - vaerosol(m,n), vaerosolcw(m,n) ) - - hygro_aer(m,n)=hygro(i,k,j,m,n) - enddo - enddo - -! 06-nov-2005 rce - grid_id & ktau added to arg list - call activate(wbar,wmix,wdiab,wmin,wmax,temp(i,k,j),cs(k), & - msectional, maxd_atype, ntype_aer, maxd_asize, nsize_aer, & - naerosol, vaerosol, & - dlo_sect,dhi_sect,sigmag_aer,hygro_aer, & - fn,fs,fm,fluxn,fluxs,fluxm,flux_fullact(k), grid_id, ktau, i, j, k ) - - do n = 1,ntype_aer - do m = 1,nsize_aer(n) - lnum = numptr_aer(m,n,ai_phase) - lnumcw = numptr_aer(m,n,cw_phase) - if (tmpc1 > 0.0) then - dact = tmpc1*fn(m,n)*raercol(k,lnum,nsav) ! interstitial only - else - dact = 0.0 - endif - if (tmpc2 > 0.0) then - dact = dact + tmpc2*fn(m,n)*raercol(km1,lnum,nsav) ! interstitial only - endif - dact = min( dact, 0.99*raercol(k,lnum,nsav) ) - raercol(k,lnumcw,nsav) = raercol(k,lnumcw,nsav)+dact - raercol(k,lnum, nsav) = raercol(k,lnum, nsav)-dact - qndrop(k) = qndrop(k)+dact - nsource(i,k,j) = nsource(i,k,j)+dact*dtinv - do l = 1,ncomp(n) - lmass = massptr_aer(l,m,n,ai_phase) - lmasscw = massptr_aer(l,m,n,cw_phase) - if (tmpc1 > 0.0) then - dact = tmpc1*fm(m,n)*raercol(k,lmass,nsav) ! interstitial only - else - dact = 0.0 - endif - if (tmpc2 > 0.0) then - dact = dact + tmpc2*fm(m,n)*raercol(km1,lmass,nsav) ! interstitial only - endif - dact = min( dact, 0.99*raercol(k,lmass,nsav) ) - raercol(k,lmasscw,nsav) = raercol(k,lmasscw,nsav)+dact - raercol(k,lmass, nsav) = raercol(k,lmass, nsav)-dact - enddo - enddo - enddo -! 10 continue - endif ! ((tmpc1 > 0.001) .or. (tmpc2 > 0.001)) - - - if(lcldfra(k) < lcldfra_old(k) .and. lcldfra_old(k) > 1.e-20)then ! this line is the "old" criterion -! go to 20 - -! shrinking cloud ...................................................... - -! droplet loss in decaying cloud - nsource(i,k,j)=nsource(i,k,j)+qndrop(k)*(lcldfra(k)-lcldfra_old(k))*dtinv - qndrop(k)=qndrop(k)*(1.+lcldfra(k)-lcldfra_old(k)) -! convert activated aerosol to interstitial in decaying cloud - - tmpc = (lcldfra_old(k)-lcldfra(k))/lcldfra_old(k) - do n=1,ntype_aer - do m=1,nsize_aer(n) - lnum=numptr_aer(m,n,ai_phase) - lnumcw=numptr_aer(m,n,cw_phase) - if(lnum.gt.0)then - dact=raercol(k,lnumcw,nsav)*tmpc - raercol(k,lnumcw,nsav)=raercol(k,lnumcw,nsav)+dact - raercol(k,lnum,nsav)=raercol(k,lnum,nsav)-dact - endif - do l=1,ncomp(n) - lmass=massptr_aer(l,m,n,ai_phase) - lmasscw=massptr_aer(l,m,n,cw_phase) - dact=raercol(k,lmasscw,nsav)*tmpc - raercol(k,lmasscw,nsav)=raercol(k,lmasscw,nsav)+dact - raercol(k,lmass,nsav)=raercol(k,lmass,nsav)-dact - enddo - enddo - enddo -! 20 continue - endif - - enddo GROW_SHRINK_MAIN_K_LOOP -! end of k-loop for growing/shrinking cloud calcs ...................... - - - -! ...................................................................... -! start of main k-loop for calc of old cloud activation tendencies .......... -! this loop does "set up" for the nsubmix loop -! -! rce-comment -! changed this part of code to use current cloud fraction (lcldfra) exclusively - -OLD_CLOUD_MAIN_K_LOOP: do k=kts,kte - km1=max0(k-1,kts) - kp1=min0(k+1,kde-1) - flux_fullact(k) = 0.0 - if(lcldfra(k).gt.0.01)then -! go to 30 - -! old cloud - if(lcldfra(k)-lcldfra(km1).gt.0.01.or.k.eq.kts)then - -! interior cloud -! cloud base - - wdiab=0 - wmix=wtke(k) ! spectrum of updrafts - wbar=w(i,k,j) ! spectrum of updrafts -! wmix=0. ! single updraft -! wbar=wtke(k) ! single updraft -! 06-nov-2005 rce - increase wmax from 10 to 50 (deep convective clouds) - wmax=50. - top=.false. - ekd(k)=wtke(k)*dz(k)/sq2pi - alogarg=max(1.e-20,1/lcldfra(k)-1.) - wmin=wbar+wmix*0.25*sq2pi*alog(alogarg) - - do n=1,ntype_aer - do m=1,nsize_aer(n) - call loadaer(raercol(1,1,nsav),km1,kms,kme,num_chem, & - cs(k), npv(m,n),dlo_sect(m,n),dhi_sect(m,n), & - maxd_acomp, ncomp(n), & - grid_id, ktau, i, j, m, n, & - numptr_aer(m,n,ai_phase),numptr_aer(m,n,cw_phase), & - dens_aer(1,n), & - massptr_aer(1,m,n,ai_phase), massptr_aer(1,m,n,cw_phase), & - maerosol(1,m,n), maerosolcw(1,m,n), & - maerosol_tot(m,n), maerosol_totcw(m,n), & - naerosol(m,n), naerosolcw(m,n), & - vaerosol(m,n), vaerosolcw(m,n) ) - - hygro_aer(m,n)=hygro(i,k,j,m,n) - - enddo - enddo -! print *,'old cloud wbar,wmix=',wbar,wmix - - call activate(wbar,wmix,wdiab,wmin,wmax,temp(i,k,j),cs(k), & - msectional, maxd_atype, ntype_aer, maxd_asize, nsize_aer, & - naerosol, vaerosol, & - dlo_sect,dhi_sect, sigmag_aer,hygro_aer, & - fn,fs,fm,fluxn,fluxs,fluxm,flux_fullact(k), grid_id, ktau, i, j, k ) - -! rce-comment -! the activation-fraction fluxes (fluxn, fluxm) from subr activate assume that -! wbar << wmix, which is valid for global-model scale but not mesoscale -! for wrf-chem application, divide these by flux_fullact to get a -! "flux-weighted-average" activation fraction, then multiply by (ekd(k)*zs(k)) -! which is the local "turbulent vertical-mixing velocity" - if (k > kts) then - if (flux_fullact(k) > 1.0e-20) then - tmpa = ekd(k)*zs(k) - tmpf = flux_fullact(k) - do n=1,ntype_aer - do m=1,nsize_aer(n) - tmpb = max( fluxn(m,n), 0.0 ) / max( fluxn(m,n), tmpf ) - fluxn(m,n) = tmpa*tmpb - tmpb = max( fluxm(m,n), 0.0 ) / max( fluxm(m,n), tmpf ) - fluxm(m,n) = tmpa*tmpb - enddo - enddo - else - fluxn(:,:) = 0.0 - fluxm(:,:) = 0.0 - endif - endif - - if(k.gt.kts)then - tmpc = lcldfra(k)-lcldfra(km1) - else - tmpc=lcldfra(k) - endif -! rce-comment -! flux of activated mass into layer k (in kg/m2/s) -! = "actmassflux" = dumc*fluxm*raercol(kp1,lmass)*csbot(k) -! source of activated mass (in kg/kg/s) = flux divergence -! = actmassflux/(cs(i,k)*dz(i,k)) -! so need factor of csbot_cscen = csbot(k)/cs(i,k) -! tmpe=1./(dz(k)) - tmpe = csbot_cscen(k)/(dz(k)) - fluxntot=0. - do n=1,ntype_aer - do m=1,nsize_aer(n) - fluxn(m,n)=fluxn(m,n)*tmpc -! fluxs(m,n)=fluxs(m,n)*tmpc - fluxm(m,n)=fluxm(m,n)*tmpc - lnum=numptr_aer(m,n,ai_phase) - fluxntot=fluxntot+fluxn(m,n)*raercol(km1,lnum,nsav) -! print *,'fn=',fn(m,n),' for m,n=',m,n -! print *,'old cloud tmpc=',tmpc,' fn=',fn(m,n),' for m,n=',m,n - nact(k,m,n)=nact(k,m,n)+fluxn(m,n)*tmpe - mact(k,m,n)=mact(k,m,n)+fluxm(m,n)*tmpe - enddo - enddo - flux_fullact(k) = flux_fullact(k)*tmpe - nsource(i,k,j)=nsource(i,k,j)+fluxntot*zs(k) - fluxntot=fluxntot*cs(k) - endif -! 30 continue - - else -! go to 40 -! no cloud - if(qndrop(k).gt.10000.e6)then - print *,'i,k,j,lcldfra,qndrop=',i,k,j,lcldfra(k),qndrop(k) - print *,'cldfra,ql,qi',cldfra(i,k,j),qc(i,k,j),qi(i,k,j) - endif - nsource(i,k,j)=nsource(i,k,j)-qndrop(k)*dtinv - qndrop(k)=0. -! convert activated aerosol to interstitial in decaying cloud - do n=1,ntype_aer - do m=1,nsize_aer(n) - lnum=numptr_aer(m,n,ai_phase) - lnumcw=numptr_aer(m,n,cw_phase) - if(lnum.gt.0)then - raercol(k,lnum,nsav)=raercol(k,lnum,nsav)+raercol(k,lnumcw,nsav) - raercol(k,lnumcw,nsav)=0. - endif - do l=1,ncomp(n) - lmass=massptr_aer(l,m,n,ai_phase) - lmasscw=massptr_aer(l,m,n,cw_phase) - raercol(k,lmass,nsav)=raercol(k,lmass,nsav)+raercol(k,lmasscw,nsav) - raercol(k,lmasscw,nsav)=0. - enddo - enddo - enddo -! 40 continue - endif - - enddo OLD_CLOUD_MAIN_K_LOOP - -! cycle OVERALL_MAIN_I_LOOP - - -! switch nsav, nnew so that nnew is the updated aerosol - - ntemp=nsav - nsav=nnew - nnew=ntemp - -! load new droplets in layers above, below clouds - - dtmin=dtstep - ekk(kts)=0.0 -! rce-comment -- ekd(k) is eddy-diffusivity at k/k-1 interface -! want ekk(k) = ekd(k) * (density at k/k-1 interface) - do k=kts+1,kte - ekk(k)=ekd(k)*csbot(k) - enddo - ekk(kte+1)=0.0 - do k=kts,kte - ekkp(k)=zn(k)*ekk(k+1)*zs(k+1) - ekkm(k)=zn(k)*ekk(k)*zs(k) - tinv=ekkp(k)+ekkm(k) - if(k.eq.kts)tinv=tinv+surfratemax - if(tinv.gt.1.e-6)then - dtt=1./tinv - dtmin=min(dtmin,dtt) - endif - enddo - dtmix=0.9*dtmin - nsubmix=dtstep/dtmix+1 - if(nsubmix>100)then - nsubmix_bnd=100 - else - nsubmix_bnd=nsubmix - endif - count_submix(nsubmix_bnd)=count_submix(nsubmix_bnd)+1 - dtmix=dtstep/nsubmix - fac_srflx = -1.0/(zn(1)*nsubmix) - - do k=kts,kte - kp1=min(k+1,kde-1) - km1=max(k-1,1) - if(lcldfra(kp1).gt.0)then - overlapp(k)=min(lcldfra(k)/lcldfra(kp1),1.) - else - overlapp(k)=1. - endif - if(lcldfra(km1).gt.0)then - overlapm(k)=min(lcldfra(k)/lcldfra(km1),1.) - else - overlapm(k)=1. - endif - enddo - - - -! ...................................................................... -! start of nsubmix-loop for calc of old cloud activation tendencies .... -OLD_CLOUD_NSUBMIX_LOOP: do nsub=1,nsubmix - qndrop_new(kts:kte)=qndrop(kts:kte) -! switch nsav, nnew so that nsav is the updated aerosol - ntemp=nsav - nsav=nnew - nnew=ntemp - srcn(:)=0.0 - do n=1,ntype_aer - do m=1,nsize_aer(n) - lnum=numptr_aer(m,n,ai_phase) -! update droplet source -! rce-comment - activation source in layer k involves particles from k-1 -! srcn(kts :kte)=srcn(kts :kte)+nact(kts :kte,m,n)*(raercol(kts:kte ,lnum,nsav)) - srcn(kts+1:kte)=srcn(kts+1:kte)+nact(kts+1:kte,m,n)*(raercol(kts:kte-1,lnum,nsav)) -! rce-comment - new formulation for k=kts should be implemented - srcn(kts )=srcn(kts )+nact(kts ,m,n)*(raercol(kts ,lnum,nsav)) - enddo - enddo - call explmix(qndrop,srcn,ekkp,ekkm,overlapp,overlapm, & - qndrop_new,surfrate_drop,kms,kme,kts,kte,dtmix,.false.) - do n=1,ntype_aer - do m=1,nsize_aer(n) - lnum=numptr_aer(m,n,ai_phase) - lnumcw=numptr_aer(m,n,cw_phase) - if(lnum>0)then -! rce-comment - activation source in layer k involves particles from k-1 -! source(kts :kte)= nact(kts :kte,m,n)*(raercol(kts:kte ,lnum,nsav)) - source(kts+1:kte)= nact(kts+1:kte,m,n)*(raercol(kts:kte-1,lnum,nsav)) -! rce-comment - new formulation for k=kts should be implemented - source(kts )= nact(kts ,m,n)*(raercol(kts ,lnum,nsav)) - call explmix(raercol(1,lnumcw,nnew),source,ekkp,ekkm,overlapp,overlapm, & - raercol(1,lnumcw,nsav),surfrate(lnumcw),kms,kme,kts,kte,dtmix,& - .false.) - call explmix(raercol(1,lnum,nnew),source,ekkp,ekkm,overlapp,overlapm, & - raercol(1,lnum,nsav),surfrate(lnum),kms,kme,kts,kte,dtmix, & - .true.,raercol(1,lnumcw,nsav)) - qsrflx(i,j,lnum) = qsrflx(i,j,lnum) + fac_srflx* & - raercol(kts,lnum,nsav)*surfrate(lnum) - qsrflx(i,j,lnumcw) = qsrflx(i,j,lnumcw) + fac_srflx* & - raercol(kts,lnumcw,nsav)*surfrate(lnumcw) - endif - do l=1,ncomp(n) - lmass=massptr_aer(l,m,n,ai_phase) - lmasscw=massptr_aer(l,m,n,cw_phase) -! rce-comment - activation source in layer k involves particles from k-1 -! source(kts :kte)= mact(kts :kte,m,n)*(raercol(kts:kte ,lmass,nsav)) - source(kts+1:kte)= mact(kts+1:kte,m,n)*(raercol(kts:kte-1,lmass,nsav)) -! rce-comment - new formulation for k=kts should be implemented - source(kts )= mact(kts ,m,n)*(raercol(kts ,lmass,nsav)) - call explmix(raercol(1,lmasscw,nnew),source,ekkp,ekkm,overlapp,overlapm, & - raercol(1,lmasscw,nsav),surfrate(lmasscw),kms,kme,kts,kte,dtmix, & - .false.) - call explmix(raercol(1,lmass,nnew),source,ekkp,ekkm,overlapp,overlapm, & - raercol(1,lmass,nsav),surfrate(lmass),kms,kme,kts,kte,dtmix, & - .true.,raercol(1,lmasscw,nsav)) - qsrflx(i,j,lmass) = qsrflx(i,j,lmass) + fac_srflx* & - raercol(kts,lmass,nsav)*surfrate(lmass) - qsrflx(i,j,lmasscw) = qsrflx(i,j,lmasscw) + fac_srflx* & - raercol(kts,lmasscw,nsav)*surfrate(lmasscw) - enddo - lwater=waterptr_aer(m,n) ! aerosol water - if(lwater>0)then - source(:)=0. - call explmix( raercol(1,lwater,nnew),source,ekkp,ekkm,overlapp,overlapm, & - raercol(1,lwater,nsav),surfrate(lwater),kms,kme,kts,kte,dtmix, & - .true.,source) - endif - enddo ! size - enddo ! type - - enddo OLD_CLOUD_NSUBMIX_LOOP - -! cycle OVERALL_MAIN_I_LOOP - -! evaporate particles again if no cloud - - do k=kts,kte - if(lcldfra(k).eq.0.)then - -! no cloud - - qndrop(k)=0. -! convert activated aerosol to interstitial in decaying cloud - do n=1,ntype_aer - do m=1,nsize_aer(n) - lnum=numptr_aer(m,n,ai_phase) - lnumcw=numptr_aer(m,n,cw_phase) - if(lnum.gt.0)then - raercol(k,lnum,nnew)=raercol(k,lnum,nnew)+raercol(k,lnumcw,nnew) - raercol(k,lnumcw,nnew)=0. - endif - do l=1,ncomp(n) - lmass=massptr_aer(l,m,n,ai_phase) - lmasscw=massptr_aer(l,m,n,cw_phase) - raercol(k,lmass,nnew)=raercol(k,lmass,nnew)+raercol(k,lmasscw,nnew) - raercol(k,lmasscw,nnew)=0. - enddo - enddo - enddo - endif - enddo - -! cycle OVERALL_MAIN_I_LOOP - -! droplet number - - do k=kts,kte -! if(lcldfra(k).gt.0.1)then -! write(6,'(a,3i5,f12.1)')'i,j,k,qndrop=',i,j,k,qndrop(k) -! endif - if(qndrop(k).lt.-10.e6.or.qndrop(k).gt.1.e12)then - write(6,'(a,g12.2,a,3i5)')'after qndrop=',qndrop(k),' for i,k,j=',i,k,j -! call exit(1) - endif - - qndrop3d(i,k,j) = max(qndrop(k),1.e-6) - - if(qndrop3d(i,k,j).lt.-10.e6.or.qndrop3d(i,k,j).gt.1.E20)then - write(6,'(a,g12.2,a,3i5)')'after qndrop=',qndrop3d(i,k,j),' for i,k,j=',i,k,j -! call exit(1) - endif - if(qc(i,k,j).lt.-1..or.qc(i,k,j).gt.1.)then - write(6,'(a,g12.2,a,3i5)')'qc=',qc(i,k,j),' for i,k,j=',i,k,j - call exit(1) - endif - if(qi(i,k,j).lt.-1..or.qi(i,k,j).gt.1.)then - write(6,'(a,g12.2,a,3i5)')'qi=',qi(i,k,j),' for i,k,j=',i,k,j - call exit(1) - endif - if(qv(i,k,j).lt.-1..or.qv(i,k,j).gt.1.)then - write(6,'(a,g12.2,a,3i5)')'qv=',qv(i,k,j),' for i,k,j=',i,k,j - call exit(1) - endif - cldfra_old(i,k,j) = cldfra(i,k,j) -! if(k.gt.6.and.k.lt.11)cldfra_old(i,k,j)=1. - enddo - -! cycle OVERALL_MAIN_I_LOOP - -! update chem and convert back to mole/mole - - ccn(:,:) = 0. - do n=1,ntype_aer - do m=1,nsize_aer(n) - lnum=numptr_aer(m,n,ai_phase) - lnumcw=numptr_aer(m,n,cw_phase) - if(lnum.gt.0)then - ! scale=mwdry*0.001 - scale = 1. - chem(i,kts:kte,j,lnumcw)= raercol(kts:kte,lnumcw,nnew)*scale - chem(i,kts:kte,j,lnum)= raercol(kts:kte,lnum,nnew)*scale - endif - do l=1,ncomp(n) - lmass=massptr_aer(l,m,n,ai_phase) - lmasscw=massptr_aer(l,m,n,cw_phase) -! scale = mwdry/mw_aer(l,n) - scale = 1.e9 - chem(i,kts:kte,j,lmasscw)=raercol(kts:kte,lmasscw,nnew)*scale ! ug/kg - chem(i,kts:kte,j,lmass)=raercol(kts:kte,lmass,nnew)*scale ! ug/kg - enddo - lwater=waterptr_aer(m,n) - if(lwater>0)chem(i,kts:kte,j,lwater)=raercol(kts:kte,lwater,nnew) ! don't convert units - do k=kts,kte - sm=2.*aten*sqrt(aten/(27.*hygro(i,k,j,m,n)*amcube(m,n))) - do l=1,psat - arg=argfactor(m,n)*log(sm/super(l)) - if(arg<2)then - if(arg<-2)then - ccnfact(l,m,n)=1.e-6 ! convert from #/m3 to #/cm3 - else - ccnfact(l,m,n)=1.e-6*0.5*ERFC_NUM_RECIPES(arg) - endif - else - ccnfact(l,m,n) = 0. - endif -! ccn concentration as diagnostic -! assume same hygroscopicity and ccnfact for cloud-phase and aerosol phase particles - ccn(k,l)=ccn(k,l)+(raercol(k,lnum,nnew)+raercol(k,lnumcw,nnew))*cs(k)*ccnfact(l,m,n) - enddo - enddo - enddo - enddo - do l=1,psat - !wig, 22-Nov-2006: added vertical bounds to prevent out-of-bounds at top - if(l.eq.1)ccn1(i,kts:kte,j)=ccn(:,l) - if(l.eq.2)ccn2(i,kts:kte,j)=ccn(:,l) - if(l.eq.3)ccn3(i,kts:kte,j)=ccn(:,l) - if(l.eq.4)ccn4(i,kts:kte,j)=ccn(:,l) - if(l.eq.5)ccn5(i,kts:kte,j)=ccn(:,l) - if(l.eq.6)ccn6(i,kts:kte,j)=ccn(:,l) - end do - - enddo OVERALL_MAIN_I_LOOP ! end of main loop over i - enddo OVERALL_MAIN_J_LOOP ! end of main loop over j - - - return - end subroutine mixactivate - - -!---------------------------------------------------------------------- -!---------------------------------------------------------------------- - subroutine explmix( q, src, ekkp, ekkm, overlapp, overlapm, & - qold, surfrate, kms, kme, kts, kte, dt, & - is_unact, qactold ) - -! explicit integration of droplet/aerosol mixing -! with source due to activation/nucleation - - - implicit none - integer, intent(in) :: kms,kme ! number of levels for array definition - integer, intent(in) :: kts,kte ! number of levels for looping - real, intent(inout) :: q(kms:kme) ! mixing ratio to be updated - real, intent(in) :: qold(kms:kme) ! mixing ratio from previous time step - real, intent(in) :: src(kms:kme) ! source due to activation/nucleation (/s) - real, intent(in) :: ekkp(kms:kme) ! zn*zs*density*diffusivity (kg/m3 m2/s) at interface - ! below layer k (k,k+1 interface) - real, intent(in) :: ekkm(kms:kme) ! zn*zs*density*diffusivity (kg/m3 m2/s) at interface - ! above layer k (k,k+1 interface) - real, intent(in) :: overlapp(kms:kme) ! cloud overlap below - real, intent(in) :: overlapm(kms:kme) ! cloud overlap above - real, intent(in) :: surfrate ! surface exchange rate (/s) - real, intent(in) :: dt ! time step (s) - logical, intent(in) :: is_unact ! true if this is an unactivated species - real, intent(in),optional :: qactold(kms:kme) - ! mixing ratio of ACTIVATED species from previous step - ! *** this should only be present - ! if the current species is unactivated number/sfc/mass - - integer k,kp1,km1 - - if ( is_unact ) then -! the qactold*(1-overlap) terms are resuspension of activated material - do k=kts,kte - kp1=min(k+1,kte) - km1=max(k-1,kts) - q(k) = qold(k) + dt*( - src(k) + ekkp(k)*(qold(kp1) - qold(k) + & - qactold(kp1)*(1.0-overlapp(k))) & - + ekkm(k)*(qold(km1) - qold(k) + & - qactold(km1)*(1.0-overlapm(k))) ) -! if(q(k)<-1.e-30)then ! force to non-negative -! print *,'q=',q(k),' in explmix' - q(k)=max(q(k),0.) -! endif - end do - - else - do k=kts,kte - kp1=min(k+1,kte) - km1=max(k-1,kts) - q(k) = qold(k) + dt*(src(k) + ekkp(k)*(overlapp(k)*qold(kp1)-qold(k)) + & - ekkm(k)*(overlapm(k)*qold(km1)-qold(k)) ) -! if(q(k)<-1.e-30)then ! force to non-negative -! print *,'q=',q(k),' in explmix' - q(k)=max(q(k),0.) -! endif - end do - end if - -! dry deposition loss at base of lowest layer - q(kts)=q(kts)-surfrate*qold(kts)*dt -! if(q(kts)<-1.e-30)then ! force to non-negative -! print *,'q=',q(kts),' in explmix' - q(kts)=max(q(kts),0.) -! endif - - return - end subroutine explmix - -!---------------------------------------------------------------------- -!---------------------------------------------------------------------- -! 06-nov-2005 rce - grid_id & ktau added to arg list - subroutine activate(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & - msectional, maxd_atype, ntype_aer, maxd_asize, nsize_aer, & - na, volc, dlo_sect,dhi_sect,sigman, hygro, & - fn, fs, fm, fluxn, fluxs, fluxm, flux_fullact, & - grid_id, ktau, ii, jj, kk ) - -! calculates number, surface, and mass fraction of aerosols activated as CCN -! calculates flux of cloud droplets, surface area, and aerosol mass into cloud -! assumes an internal mixture within each of aerosol mode. -! A sectional treatment within each type is assumed if ntype_aer >7. -! A gaussiam spectrum of updrafts can be treated. - -! mks units - -! Abdul-Razzak and Ghan, A parameterization of aerosol activation. -! 2. Multiple aerosol types. J. Geophys. Res., 105, 6837-6844. - - USE module_model_constants, only: g,rhowater, xlv, cp, rvovrd, r_d, r_v, & - mwdry,svp1,svp2,svp3,ep_2 - - implicit none - - -! input - - integer,intent(in) :: maxd_atype ! dimension of types - integer,intent(in) :: maxd_asize ! dimension of sizes - integer,intent(in) :: ntype_aer ! number of types - integer,intent(in) :: nsize_aer(maxd_atype) ! number of sizes for type - integer,intent(in) :: msectional ! 1 for sectional, 0 for modal - integer,intent(in) :: grid_id ! WRF grid%id - integer,intent(in) :: ktau ! WRF time step count - integer,intent(in) :: ii, jj, kk ! i,j,k of current grid cell - real,intent(in) :: wbar ! grid cell mean vertical velocity (m/s) - real,intent(in) :: sigw ! subgrid standard deviation of vertical vel (m/s) - real,intent(in) :: wdiab ! diabatic vertical velocity (0 if adiabatic) - real,intent(in) :: wminf ! minimum updraft velocity for integration (m/s) - real,intent(in) :: wmaxf ! maximum updraft velocity for integration (m/s) - real,intent(in) :: tair ! air temperature (K) - real,intent(in) :: rhoair ! air density (kg/m3) - real,intent(in) :: na(maxd_asize,maxd_atype) ! aerosol number concentration (/m3) - real,intent(in) :: sigman(maxd_asize,maxd_atype) ! geometric standard deviation of aerosol size distribution - real,intent(in) :: hygro(maxd_asize,maxd_atype) ! bulk hygroscopicity of aerosol mode - real,intent(in) :: volc(maxd_asize,maxd_atype) ! total aerosol volume concentration (m3/m3) - real,intent(in) :: dlo_sect( maxd_asize, maxd_atype ), & ! minimum size of section (cm) - dhi_sect( maxd_asize, maxd_atype ) ! maximum size of section (cm) - -! output - - real,intent(inout) :: fn(maxd_asize,maxd_atype) ! number fraction of aerosols activated - real,intent(inout) :: fs(maxd_asize,maxd_atype) ! surface fraction of aerosols activated - real,intent(inout) :: fm(maxd_asize,maxd_atype) ! mass fraction of aerosols activated - real,intent(inout) :: fluxn(maxd_asize,maxd_atype) ! flux of activated aerosol number fraction into cloud (m/s) - real,intent(inout) :: fluxs(maxd_asize,maxd_atype) ! flux of activated aerosol surface fraction (m/s) - real,intent(inout) :: fluxm(maxd_asize,maxd_atype) ! flux of activated aerosol mass fraction into cloud (m/s) - real,intent(inout) :: flux_fullact ! flux when activation fraction = 100% (m/s) - -! local - -!!$ external erf,erfc -!!$ real erf,erfc -! external qsat_water - integer, parameter:: nx=200 - integer iquasisect_option, isectional - real integ,integf - real, save :: surften ! surface tension of water w/respect to air (N/m) - data surften/0.076/ - real, save :: p0 ! reference pressure (Pa) - real, save :: t0 ! reference temperature (K) - data p0/1013.25e2/,t0/273.15/ - real ylo(maxd_asize,maxd_atype),yhi(maxd_asize,maxd_atype) ! 1-particle volume at section interfaces - real ymean(maxd_asize,maxd_atype) ! 1-particle volume at r=rmean - real ycut, lnycut, betayy, betayy2, gammayy, phiyy - real surfc(maxd_asize,maxd_atype) ! surface concentration (m2/m3) - real sign(maxd_asize,maxd_atype) ! geometric standard deviation of size distribution - real alnsign(maxd_asize,maxd_atype) ! natl log of geometric standard dev of aerosol - real am(maxd_asize,maxd_atype) ! number mode radius of dry aerosol (m) - real lnhygro(maxd_asize,maxd_atype) ! ln(b) - real f1(maxd_asize,maxd_atype) ! array to hold parameter for maxsat - real pres ! pressure (Pa) - real path ! mean free path (m) - real diff ! diffusivity (m2/s) - real conduct ! thermal conductivity (Joule/m/sec/deg) - real diff0,conduct0 - real es ! saturation vapor pressure - real qs ! water vapor saturation mixing ratio - real dqsdt ! change in qs with temperature - real dqsdp ! change in qs with pressure - real gg ! thermodynamic function (m2/s) - real sqrtg ! sqrt(gg) - real sm(maxd_asize,maxd_atype) ! critical supersaturation for number mode radius - real lnsm(maxd_asize,maxd_atype) ! ln( sm ) - real zeta, eta(maxd_asize,maxd_atype) - real lnsmax ! ln(smax) - real alpha - real gamma - real beta - real gaus - logical, save :: top ! true if cloud top, false if cloud base or new cloud - data top/.false./ - real asub(maxd_asize,maxd_atype),bsub(maxd_asize,maxd_atype) ! coefficients of submode size distribution N=a+bx - real totn(maxd_atype) ! total aerosol number concentration - real aten ! surface tension parameter - real gmrad(maxd_atype) ! geometric mean radius - real gmradsq(maxd_atype) ! geometric mean of radius squared - real gmlnsig(maxd_atype) ! geometric standard deviation - real gmsm(maxd_atype) ! critical supersaturation at radius gmrad - real sumflxn(maxd_asize,maxd_atype) - real sumflxs(maxd_asize,maxd_atype) - real sumflxm(maxd_asize,maxd_atype) - real sumflx_fullact - real sumfn(maxd_asize,maxd_atype) - real sumfs(maxd_asize,maxd_atype) - real sumfm(maxd_asize,maxd_atype) - real sumns(maxd_atype) - real fnold(maxd_asize,maxd_atype) ! number fraction activated - real fsold(maxd_asize,maxd_atype) ! surface fraction activated - real fmold(maxd_asize,maxd_atype) ! mass fraction activated - real wold,gold - real alogten,alog2,alog3,alogaten - real alogam - real rlo(maxd_asize,maxd_atype), rhi(maxd_asize,maxd_atype) - real rmean(maxd_asize,maxd_atype) - ! mean radius (m) for the section (not used with modal) - ! calculated from current volume & number - real ccc - real dumaa,dumbb - real wmin,wmax,w,dw,dwmax,dwmin,wnuc,dwnew,wb - real dfmin,dfmax,fnew,fold,fnmin,fnbar,fsbar,fmbar - real alw,sqrtalw - real smax - real x,arg - real xmincoeff,xcut - real z,z1,z2,wf1,wf2,zf1,zf2,gf1,gf2,gf - real etafactor1,etafactor2(maxd_asize,maxd_atype),etafactor2max - integer m,n,nw,nwmax - -! numerical integration parameters - real, save :: eps,fmax,sds - data eps/0.3/,fmax/0.99/,sds/3./ - -! mathematical constants - real third, twothird, sixth, zero, one, two, three -! 04-nov-2005 rce - make this more precise -! data third/0.333333/, twothird/0.66666667/, sixth/0.166666667/,zero/0./,one/1./,two/2./,three/3./ -! data third/0.33333333333/, twothird/0.66666666667/, sixth/0.16666666667/ -! data zero/0./,one/1./,two/2./,three/3./ -! save third, sixth,twothird,zero,one,two,three - - real, save :: sq2, sqpi, pi -! 04-nov-2005 rce - make this more precise -! data sq2/1.4142136/, sqpi/1.7724539/,pi/3.14159/ - data sq2/1.4142135624/, sqpi/1.7724538509/,pi/3.1415926536/ - - integer, save :: ndist(nx) ! accumulates frequency distribution of integration bins required - data ndist/nx*0/ - -! for nsize_aer>7, a sectional approach is used and isectional = iquasisect_option -! activation fractions (fn,fs,fm) are computed as follows -! iquasisect_option = 1,3 - each section treated as a narrow lognormal -! iquasisect_option = 2,4 - within-section dn/dx = a + b*x, x = ln(r) -! smax is computed as follows (when explicit activation is OFF) -! iquasisect_option = 1,2 - razzak-ghan modal parameterization with -! single mode having same ntot, dgnum, sigmag as the combined sections -! iquasisect_option = 3,4 - razzak-ghan sectional parameterization -! for nsize_aer=<9, a modal approach is used and isectional = 0 - -! rce 08-jul-2005 -! if either (na(n,m) < nsmall) or (volc(n,m) < vsmall) -! then treat bin/mode (n,m) as being empty, and set its fn/fs/fm=0.0 -! (for single precision, gradual underflow starts around 1.0e-38, -! and strange things can happen when in that region) - real, parameter :: nsmall = 1.0e-20 ! aer number conc in #/m3 - real, parameter :: vsmall = 1.0e-37 ! aer volume conc in m3/m3 - logical bin_is_empty(maxd_asize,maxd_atype), all_bins_empty - logical bin_is_narrow(maxd_asize,maxd_atype) - - integer idiagaa, ipass_nwloop - integer idiag_dndy_neg, idiag_fnsm_prob - -!....................................................................... -! -! start calc. of modal or sectional activation properties (start of section 1) -! -!....................................................................... - idiag_dndy_neg = 1 ! set this to 0 to turn off - ! warnings about dn/dy < 0 - idiag_fnsm_prob = 1 ! set this to 0 to turn off - ! warnings about fn/fs/fm misbehavior - - iquasisect_option = 2 - if(msectional.gt.0)then - isectional = iquasisect_option - else - isectional = 0 - endif - - do n=1,ntype_aer -! print *,'ntype_aer,n,nsize_aer(n)=',ntype_aer,n,nsize_aer(n) - - if(ntype_aer.eq.1.and.nsize_aer(n).eq.1.and.na(1,1).lt.1.e-20)then - fn(1,1)=0. - fs(1,1)=0. - fm(1,1)=0. - fluxn(1,1)=0. - fluxs(1,1)=0. - fluxm(1,1)=0. - flux_fullact=0. - return - endif - enddo - - zero = 0.0 - one = 1.0 - two = 2.0 - three = 3.0 - third = 1.0/3.0 - twothird = 2.0/6.0 - sixth = 1.0/6.0 - - pres=r_d*rhoair*tair - diff0=0.211e-4*(p0/pres)*(tair/t0)**1.94 - conduct0=(5.69+0.017*(tair-t0))*4.186e2*1.e-5 ! convert to J/m/s/deg - es=1000.*svp1*exp( svp2*(tair-t0)/(tair-svp3) ) - qs=ep_2*es/(pres-es) - dqsdt=xlv/(r_v*tair*tair)*qs - alpha=g*(xlv/(cp*r_v*tair*tair)-1./(r_d*tair)) - gamma=(1+xlv/cp*dqsdt)/(rhoair*qs) - gg=1./(rhowater/(diff0*rhoair*qs)+xlv*rhowater/(conduct0*tair)*(xlv/(r_v*tair)-1.)) - sqrtg=sqrt(gg) - beta=4.*pi*rhowater*gg*gamma - aten=2.*surften/(r_v*tair*rhowater) - alogaten=log(aten) - alog2=log(two) - alog3=log(three) - ccc=4.*pi*third - etafactor2max=1.e10/(alpha*wmaxf)**1.5 ! this should make eta big if na is very small. - - all_bins_empty = .true. - do n=1,ntype_aer - totn(n)=0. - gmrad(n)=0. - gmradsq(n)=0. - sumns(n)=0. - do m=1,nsize_aer(n) - alnsign(m,n)=log(sigman(m,n)) -! internal mixture of aerosols - - bin_is_empty(m,n) = .true. - if (volc(m,n).gt.vsmall .and. na(m,n).gt.nsmall) then - bin_is_empty(m,n) = .false. - all_bins_empty = .false. - lnhygro(m,n)=log(hygro(m,n)) -! number mode radius (m,n) -! write(6,*)'alnsign,volc,na=',alnsign(m,n),volc(m,n),na(m,n) - am(m,n)=exp(-1.5*alnsign(m,n)*alnsign(m,n))* & - (3.*volc(m,n)/(4.*pi*na(m,n)))**third - - if (isectional .gt. 0) then -! sectional model. -! need to use bulk properties because parameterization doesn't -! work well for narrow bins. - totn(n)=totn(n)+na(m,n) - alogam=log(am(m,n)) - gmrad(n)=gmrad(n)+na(m,n)*alogam - gmradsq(n)=gmradsq(n)+na(m,n)*alogam*alogam - endif - etafactor2(m,n)=1./(na(m,n)*beta*sqrtg) - - if(hygro(m,n).gt.1.e-10)then - sm(m,n)=2.*aten/(3.*am(m,n))*sqrt(aten/(3.*hygro(m,n)*am(m,n))) - else - sm(m,n)=100. - endif -! write(6,*)'sm,hygro,am=',sm(m,n),hygro(m,n),am(m,n) - else - sm(m,n)=1. - etafactor2(m,n)=etafactor2max ! this should make eta big if na is very small. - - endif - lnsm(m,n)=log(sm(m,n)) - if ((isectional .eq. 3) .or. (isectional .eq. 4)) then - sumns(n)=sumns(n)+na(m,n)/sm(m,n)**twothird - endif -! write(6,'(a,i4,6g12.2)')'m,na,am,hygro,lnhygro,sm,lnsm=',m,na(m,n),am(m,n),hygro(m,n),lnhygro(m,n),sm(m,n),lnsm(m,n) - end do ! size - end do ! type - -! if all bins are empty, set all activation fractions to zero and exit - if ( all_bins_empty ) then - do n=1,ntype_aer - do m=1,nsize_aer(n) - fluxn(m,n)=0. - fn(m,n)=0. - fluxs(m,n)=0. - fs(m,n)=0. - fluxm(m,n)=0. - fm(m,n)=0. - end do - end do - flux_fullact=0. - return - endif - - - - if (isectional .le. 0) then - ! Initialize maxsat at this cell and timestep for the - ! modal setup (the sectional case is handled below). - call maxsat_init(maxd_atype, ntype_aer, & - maxd_asize, nsize_aer, alnsign, f1) - - goto 30000 - end if - - do n=1,ntype_aer - !wig 19-Oct-2006: Add zero trap based May 2006 e-mail from - !Ghan. Transport can clear out a cell leading to - !inconsistencies with the mass. - gmrad(n)=gmrad(n)/max(totn(n),1e-20) - gmlnsig=gmradsq(n)/totn(n)-gmrad(n)*gmrad(n) ! [ln(sigmag)]**2 - gmlnsig(n)=sqrt( max( 1.e-4, gmlnsig(n) ) ) - gmrad(n)=exp(gmrad(n)) - if ((isectional .eq. 3) .or. (isectional .eq. 4)) then - gmsm(n)=totn(n)/sumns(n) - gmsm(n)=gmsm(n)*gmsm(n)*gmsm(n) - gmsm(n)=sqrt(gmsm(n)) - else -! gmsm(n)=2.*aten/(3.*gmrad(n))*sqrt(aten/(3.*hygro(1,n)*gmrad(n))) - gmsm(n)=2.*aten/(3.*gmrad(n))*sqrt(aten/(3.*hygro(nsize_aer(n),n)*gmrad(n))) - endif - enddo - - ! Initialize maxsat at this cell and timestep for the - ! sectional setup (the modal case is handled above)... - call maxsat_init(maxd_atype, ntype_aer, & - maxd_asize, (/1/), gmlnsig, f1) - -!....................................................................... -! calculate sectional "sub-bin" size distribution -! -! dn/dy = nt*( a + b*y ) for ylo < y < yhi -! -! nt = na(m,n) = number mixing ratio of the bin -! y = v/vhi -! v = (4pi/3)*r**3 = particle volume -! vhi = v at r=rhi (upper bin boundary) -! ylo = y at lower bin boundary = vlo/vhi = (rlo/rhi)**3 -! yhi = y at upper bin boundary = 1.0 -! -! dv/dy = v * dn/dy = nt*vhi*( a*y + b*y*y ) -! -!....................................................................... -! 02-may-2006 - this dn/dy replaces the previous -! dn/dx = a + b*x where l = ln(r) -! the old dn/dx was overly complicated for cases of rmean near rlo or rhi -! the new dn/dy is consistent with that used in the movesect routine, -! which does continuous growth by condensation and aqueous chemistry -!....................................................................... - do 25002 n = 1,ntype_aer - do 25000 m = 1,nsize_aer(n) - -! convert from diameter in cm to radius in m - rlo(m,n) = 0.5*0.01*dlo_sect(m,n) - rhi(m,n) = 0.5*0.01*dhi_sect(m,n) - ylo(m,n) = (rlo(m,n)/rhi(m,n))**3 - yhi(m,n) = 1.0 - -! 04-nov-2005 - extremely narrow bins will be treated using 0/1 activation -! this is to avoid potential numerical problems - bin_is_narrow(m,n) = .false. - if ((rhi(m,n)/rlo(m,n)) .le. 1.01) bin_is_narrow(m,n) = .true. - -! rmean is mass mean radius for the bin; xmean = log(rmean) -! just use section midpoint if bin is empty - if ( bin_is_empty(m,n) ) then - rmean(m,n) = sqrt(rlo(m,n)*rhi(m,n)) - ymean(m,n) = (rmean(m,n)/rhi(m,n))**3 - goto 25000 - end if - - rmean(m,n) = (volc(m,n)/(ccc*na(m,n)))**third - rmean(m,n) = max( rlo(m,n), min( rhi(m,n), rmean(m,n) ) ) - ymean(m,n) = (rmean(m,n)/rhi(m,n))**3 - if ( bin_is_narrow(m,n) ) goto 25000 - -! if rmean is extremely close to either rlo or rhi, -! treat the bin as extremely narrow - if ((rhi(m,n)/rmean(m,n)) .le. 1.01) then - bin_is_narrow(m,n) = .true. - rlo(m,n) = min( rmean(m,n), (rhi(m,n)/1.01) ) - ylo(m,n) = (rlo(m,n)/rhi(m,n))**3 - goto 25000 - else if ((rmean(m,n)/rlo(m,n)) .le. 1.01) then - bin_is_narrow(m,n) = .true. - rhi(m,n) = max( rmean(m,n), (rlo(m,n)*1.01) ) - ylo(m,n) = (rlo(m,n)/rhi(m,n))**3 - ymean(m,n) = (rmean(m,n)/rhi(m,n))**3 - goto 25000 - endif - -! if rmean is somewhat close to either rlo or rhi, then dn/dy will be -! negative near the upper or lower bin boundary -! in these cases, assume that all the particles are in a subset of the full bin, -! and adjust rlo or rhi so that rmean will be near the center of this subset -! note that the bin is made narrower LOCALLY/TEMPORARILY, -! just for the purposes of the activation calculation - gammayy = (ymean(m,n)-ylo(m,n)) / (yhi(m,n)-ylo(m,n)) - if (gammayy .lt. 0.34) then - dumaa = ylo(m,n) + (yhi(m,n)-ylo(m,n))*(gammayy/0.34) - rhi(m,n) = rhi(m,n)*(dumaa**third) - ylo(m,n) = (rlo(m,n)/rhi(m,n))**3 - ymean(m,n) = (rmean(m,n)/rhi(m,n))**3 - else if (gammayy .ge. 0.66) then - dumaa = ylo(m,n) + (yhi(m,n)-ylo(m,n))*((gammayy-0.66)/0.34) - ylo(m,n) = dumaa - rlo(m,n) = rhi(m,n)*(dumaa**third) - end if - if ((rhi(m,n)/rlo(m,n)) .le. 1.01) then - bin_is_narrow(m,n) = .true. - goto 25000 - end if - - betayy = ylo(m,n)/yhi(m,n) - betayy2 = betayy*betayy - bsub(m,n) = (12.0*ymean(m,n) - 6.0*(1.0+betayy)) / & - (4.0*(1.0-betayy2*betayy) - 3.0*(1.0-betayy2)*(1.0+betayy)) - asub(m,n) = (1.0 - bsub(m,n)*(1.0-betayy2)*0.5) / (1.0-betayy) - - if ( asub(m,n)+bsub(m,n)*ylo(m,n) .lt. 0. ) then - if (idiag_dndy_neg .gt. 0) then - print *,'dndy<0 at lower boundary' - print *,'n,m=',n,m - print *,'na=',na(m,n),' volc=',volc(m,n) - print *,'volc/(na*pi*4/3)=', (volc(m,n)/(na(m,n)*ccc)) - print *,'rlo(m,n),rhi(m,n)=',rlo(m,n),rhi(m,n) - print *,'dlo_sect/2,dhi_sect/2=', & - (0.005*dlo_sect(m,n)),(0.005*dhi_sect(m,n)) - print *,'asub,bsub,ylo,yhi=',asub(m,n),bsub(m,n),ylo(m,n),yhi(m,n) - print *,'asub+bsub*ylo=', & - (asub(m,n)+bsub(m,n)*ylo(m,n)) - print *,'subr activate error 11 - i,j,k =', ii, jj, kk -! 07-nov-2005 rce - don't stop for this, it's not fatal -! stop - endif - endif - if ( asub(m,n)+bsub(m,n)*yhi(m,n) .lt. 0. ) then - if (idiag_dndy_neg .gt. 0) then - print *,'dndy<0 at upper boundary' - print *,'n,m=',n,m - print *,'na=',na(m,n),' volc=',volc(m,n) - print *,'volc/(na*pi*4/3)=', (volc(m,n)/(na(m,n)*ccc)) - print *,'rlo(m,n),rhi(m,n)=',rlo(m,n),rhi(m,n) - print *,'dlo_sect/2,dhi_sect/2=', & - (0.005*dlo_sect(m,n)),(0.005*dhi_sect(m,n)) - print *,'asub,bsub,ylo,yhi=',asub(m,n),bsub(m,n),ylo(m,n),yhi(m,n) - print *,'asub+bsub*yhi=', & - (asub(m,n)+bsub(m,n)*yhi(m,n)) - print *,'subr activate error 12 - i,j,k =', ii, jj, kk -! stop - endif - endif - -25000 continue ! m=1,nsize_aer(n) -25002 continue ! n=1,ntype_aer - - -30000 continue -!....................................................................... -! -! end calc. of modal or sectional activation properties (end of section 1) -! -!....................................................................... - - - -! sjg 7-16-98 upward -! print *,'wbar,sigw=',wbar,sigw - - if(sigw.le.1.e-5) goto 50000 - -!....................................................................... -! -! start calc. of activation fractions/fluxes -! for spectrum of updrafts (start of section 2) -! -!....................................................................... - ipass_nwloop = 1 - idiagaa = 0 -! 06-nov-2005 rce - set idiagaa=1 for testing/debugging -! if ((grid_id.eq.1) .and. (ktau.eq.167) .and. & -! (ii.eq.24) .and. (jj.eq. 1) .and. (kk.eq.14)) idiagaa = 1 - -40000 continue - if(top)then - wmax=0. - wmin=min(zero,-wdiab) - else - wmax=min(wmaxf,wbar+sds*sigw) - wmin=max(wminf,-wdiab) - endif - wmin=max(wmin,wbar-sds*sigw) - w=wmin - dwmax=eps*sigw - dw=dwmax - dfmax=0.2 - dfmin=0.1 - if(wmax.le.w)then - do n=1,ntype_aer - do m=1,nsize_aer(n) - fluxn(m,n)=0. - fn(m,n)=0. - fluxs(m,n)=0. - fs(m,n)=0. - fluxm(m,n)=0. - fm(m,n)=0. - end do - end do - flux_fullact=0. - return - endif - do n=1,ntype_aer - do m=1,nsize_aer(n) - sumflxn(m,n)=0. - sumfn(m,n)=0. - fnold(m,n)=0. - sumflxs(m,n)=0. - sumfs(m,n)=0. - fsold(m,n)=0. - sumflxm(m,n)=0. - sumfm(m,n)=0. - fmold(m,n)=0. - enddo - enddo - sumflx_fullact=0. - - fold=0 - gold=0 -! 06-nov-2005 rce - set wold=w here -! wold=0 - wold=w - - -! 06-nov-2005 rce - define nwmax; calc dwmin from nwmax - nwmax = 200 -! dwmin = min( dwmax, 0.01 ) - dwmin = (wmax - wmin)/(nwmax-1) - dwmin = min( dwmax, dwmin ) - dwmin = max( 0.01, dwmin ) - -! -! loop over updrafts, incrementing sums as you go -! the "200" is (arbitrary) upper limit for number of updrafts -! if integration finishes before this, OK; otherwise, ERROR -! - if (idiagaa.gt.0) then - write(*,94700) ktau, grid_id, ii, jj, kk, nwmax - write(*,94710) 'wbar,sigw,wdiab=', wbar, sigw, wdiab - write(*,94710) 'wmin,wmax,dwmin,dwmax=', wmin, wmax, dwmin, dwmax - write(*,94720) -1, w, wold, dw - end if -94700 format( / 'activate 47000 - ktau,id,ii,jj,kk,nwmax=', 6i5 ) -94710 format( 'activate 47000 - ', a, 6(1x,f11.5) ) -94720 format( 'activate 47000 - nw,w,wold,dw=', i5, 3(1x,f11.5) ) - - do 47000 nw = 1, nwmax -41000 wnuc=w+wdiab - - if (idiagaa.gt.0) write(*,94720) nw, w, wold, dw - -! write(6,*)'wnuc=',wnuc - alw=alpha*wnuc - sqrtalw=sqrt(alw) - zeta=2.*sqrtalw*aten/(3.*sqrtg) - etafactor1=2.*alw*sqrtalw - if (isectional .gt. 0) then -! sectional model. -! use bulk properties - - do n=1,ntype_aer - if(totn(n).gt.1.e-10)then - eta(1,n)=etafactor1/(totn(n)*beta*sqrtg) - else - eta(1,n)=1.e10 - endif - enddo - call maxsat(zeta,eta,maxd_atype,ntype_aer, & - maxd_asize,(/1/),gmsm,gmlnsig,f1,smax) - lnsmax=log(smax) - x=2*(log(gmsm(1))-lnsmax)/(3*sq2*gmlnsig(1)) - fnew=0.5*(1.-ERF_ALT(x)) - - else - - do n=1,ntype_aer - do m=1,nsize_aer(n) - eta(m,n)=etafactor1*etafactor2(m,n) - enddo - enddo - - call maxsat(zeta,eta,maxd_atype,ntype_aer, & - maxd_asize,nsize_aer,sm,alnsign,f1,smax) -! write(6,*)'w,smax=',w,smax - - lnsmax=log(smax) - - x=2*(lnsm(nsize_aer(1),1)-lnsmax)/(3*sq2*alnsign(nsize_aer(1),1)) - fnew=0.5*(1.-ERF_ALT(x)) - - endif - - dwnew = dw -! 06-nov-2005 rce - "n" here should be "nw" (?) -! if(fnew-fold.gt.dfmax.and.n.gt.1)then - if(fnew-fold.gt.dfmax.and.nw.gt.1)then -! reduce updraft increment for greater accuracy in integration - if (dw .gt. 1.01*dwmin) then - dw=0.7*dw - dw=max(dw,dwmin) - w=wold+dw - go to 41000 - else - dwnew = dwmin - endif - endif - - if(fnew-fold.lt.dfmin)then -! increase updraft increment to accelerate integration - dwnew=min(1.5*dw,dwmax) - endif - fold=fnew - - z=(w-wbar)/(sigw*sq2) - gaus=exp(-z*z) - fnmin=1. - xmincoeff=alogaten-2.*third*(lnsmax-alog2)-alog3 -! write(6,*)'xmincoeff=',xmincoeff - - - do 44002 n=1,ntype_aer - do 44000 m=1,nsize_aer(n) - if ( bin_is_empty(m,n) ) then - fn(m,n)=0. - fs(m,n)=0. - fm(m,n)=0. - else if ((isectional .eq. 2) .or. (isectional .eq. 4)) then -! sectional -! within-section dn/dx = a + b*x - xcut=xmincoeff-third*lnhygro(m,n) -! ycut=(exp(xcut)/rhi(m,n))**3 -! 07-jul-2006 rce - the above line gave a (rare) overflow when smax=1.0e-20 -! if (ycut > yhi), then actual value of ycut is unimportant, -! so do the following to avoid overflow - lnycut = 3.0 * ( xcut - log(rhi(m,n)) ) - lnycut = min( lnycut, log(yhi(m,n)*1.0e5) ) - ycut=exp(lnycut) -! write(6,*)'m,n,rcut,rlo,rhi=',m,n,exp(xcut),rlo(m,n),rhi(m,n) -! if(lnsmax.lt.lnsmn(m,n))then - if(ycut.gt.yhi(m,n))then - fn(m,n)=0. - fs(m,n)=0. - fm(m,n)=0. - elseif(ycut.lt.ylo(m,n))then - fn(m,n)=1. - fs(m,n)=1. - fm(m,n)=1. - elseif ( bin_is_narrow(m,n) ) then -! 04-nov-2005 rce - for extremely narrow bins, -! do zero activation if xcut>xmean, 100% activation otherwise - if (ycut.gt.ymean(m,n)) then - fn(m,n)=0. - fs(m,n)=0. - fm(m,n)=0. - else - fn(m,n)=1. - fs(m,n)=1. - fm(m,n)=1. - endif - else - phiyy=ycut/yhi(m,n) - fn(m,n) = asub(m,n)*(1.0-phiyy) + 0.5*bsub(m,n)*(1.0-phiyy*phiyy) - if (fn(m,n).lt.zero .or. fn(m,n).gt.one) then - if (idiag_fnsm_prob .gt. 0) then - print *,'fn(',m,n,')=',fn(m,n),' outside 0,1 - activate err21' - print *,'na,volc =', na(m,n), volc(m,n) - print *,'asub,bsub =', asub(m,n), bsub(m,n) - print *,'yhi,ycut =', yhi(m,n), ycut - endif - endif - - if (fn(m,n) .le. zero) then -! 10-nov-2005 rce - if fn=0, then fs & fm must be 0 - fn(m,n)=zero - fs(m,n)=zero - fm(m,n)=zero - else if (fn(m,n) .ge. one) then -! 10-nov-2005 rce - if fn=1, then fs & fm must be 1 - fn(m,n)=one - fs(m,n)=one - fm(m,n)=one - else -! 10-nov-2005 rce - otherwise, calc fm and check it - fm(m,n) = (yhi(m,n)/ymean(m,n)) * (0.5*asub(m,n)*(1.0-phiyy*phiyy) + & - third*bsub(m,n)*(1.0-phiyy*phiyy*phiyy)) - if (fm(m,n).lt.fn(m,n) .or. fm(m,n).gt.one) then - if (idiag_fnsm_prob .gt. 0) then - print *,'fm(',m,n,')=',fm(m,n),' outside fn,1 - activate err22' - print *,'na,volc,fn =', na(m,n), volc(m,n), fn(m,n) - print *,'asub,bsub =', asub(m,n), bsub(m,n) - print *,'yhi,ycut =', yhi(m,n), ycut - endif - endif - if (fm(m,n) .le. fn(m,n)) then -! 10-nov-2005 rce - if fm=fn, then fs must =fn - fm(m,n)=fn(m,n) - fs(m,n)=fn(m,n) - else if (fm(m,n) .ge. one) then -! 10-nov-2005 rce - if fm=1, then fs & fn must be 1 - fm(m,n)=one - fs(m,n)=one - fn(m,n)=one - else -! 10-nov-2005 rce - these two checks assure that the mean size -! of the activated & interstitial particles will be between rlo & rhi - dumaa = fn(m,n)*(yhi(m,n)/ymean(m,n)) - fm(m,n) = min( fm(m,n), dumaa ) - dumaa = 1.0 + (fn(m,n)-1.0)*(ylo(m,n)/ymean(m,n)) - fm(m,n) = min( fm(m,n), dumaa ) -! 10-nov-2005 rce - now calculate fs and bound it by fn, fm - betayy = ylo(m,n)/yhi(m,n) - dumaa = phiyy**twothird - dumbb = betayy**twothird - fs(m,n) = & - (asub(m,n)*(1.0-phiyy*dumaa) + & - 0.625*bsub(m,n)*(1.0-phiyy*phiyy*dumaa)) / & - (asub(m,n)*(1.0-betayy*dumbb) + & - 0.625*bsub(m,n)*(1.0-betayy*betayy*dumbb)) - fs(m,n)=max(fs(m,n),fn(m,n)) - fs(m,n)=min(fs(m,n),fm(m,n)) - endif - endif - endif - - else -! modal - x=2*(lnsm(m,n)-lnsmax)/(3*sq2*alnsign(m,n)) - fn(m,n)=0.5*(1.-ERF_ALT(x)) - arg=x-sq2*alnsign(m,n) - fs(m,n)=0.5*(1.-ERF_ALT(arg)) - arg=x-1.5*sq2*alnsign(m,n) - fm(m,n)=0.5*(1.-ERF_ALT(arg)) -! print *,'w,x,fn,fs,fm=',w,x,fn(m,n),fs(m,n),fm(m,n) - endif - -! fn(m,n)=1. !test -! fs(m,n)=1. -! fm(m,n)=1. - fnmin=min(fn(m,n),fnmin) -! integration is second order accurate -! assumes linear variation of f*gaus with w - wb=(w+wold) - fnbar=(fn(m,n)*gaus+fnold(m,n)*gold) - fsbar=(fs(m,n)*gaus+fsold(m,n)*gold) - fmbar=(fm(m,n)*gaus+fmold(m,n)*gold) - if((top.and.w.lt.0.).or.(.not.top.and.w.gt.0.))then - sumflxn(m,n)=sumflxn(m,n)+sixth*(wb*fnbar & - +(fn(m,n)*gaus*w+fnold(m,n)*gold*wold))*dw - sumflxs(m,n)=sumflxs(m,n)+sixth*(wb*fsbar & - +(fs(m,n)*gaus*w+fsold(m,n)*gold*wold))*dw - sumflxm(m,n)=sumflxm(m,n)+sixth*(wb*fmbar & - +(fm(m,n)*gaus*w+fmold(m,n)*gold*wold))*dw - endif - sumfn(m,n)=sumfn(m,n)+0.5*fnbar*dw -! write(6,'(a,9g10.2)')'lnsmax,lnsm(m,n),x,fn(m,n),fnold(m,n),g,gold,fnbar,dw=', & -! lnsmax,lnsm(m,n),x,fn(m,n),fnold(m,n),g,gold,fnbar,dw - fnold(m,n)=fn(m,n) - sumfs(m,n)=sumfs(m,n)+0.5*fsbar*dw - fsold(m,n)=fs(m,n) - sumfm(m,n)=sumfm(m,n)+0.5*fmbar*dw - fmold(m,n)=fm(m,n) - -44000 continue ! m=1,nsize_aer(n) -44002 continue ! n=1,ntype_aer - -! same form as sumflxm(m,n) but replace the fm/fmold(m,n) with 1.0 - sumflx_fullact = sumflx_fullact & - + sixth*(wb*(gaus+gold) + (gaus*w + gold*wold))*dw -! sumg=sumg+0.5*(gaus+gold)*dw - gold=gaus - wold=w - dw=dwnew - - if(nw.gt.1.and.(w.gt.wmax.or.fnmin.gt.fmax))go to 48000 - w=w+dw - -47000 continue ! nw = 1, nwmax - - - print *,'do loop is too short in activate' - print *,'wmin=',wmin,' w=',w,' wmax=',wmax,' dw=',dw - print *,'wbar=',wbar,' sigw=',sigw,' wdiab=',wdiab - print *,'wnuc=',wnuc - do n=1,ntype_aer - print *,'ntype=',n - print *,'na=',(na(m,n),m=1,nsize_aer(n)) - print *,'fn=',(fn(m,n),m=1,nsize_aer(n)) - end do -! dump all subr parameters to allow testing with standalone code -! (build a driver that will read input and call activate) - print *,'top,wbar,sigw,wdiab,tair,rhoair,ntype_aer=' - print *, top,wbar,sigw,wdiab,tair,rhoair,ntype_aer - print *,'na=' - print *, na - print *,'volc=' - print *, volc - print *,'sigman=' - print *, sigman - print *,'hygro=' - print *, hygro - - print *,'subr activate error 31 - i,j,k =', ii, jj, kk -! 06-nov-2005 rce - if integration fails, repeat it once with additional diagnostics - if (ipass_nwloop .eq. 1) then - ipass_nwloop = 2 - idiagaa = 2 - goto 40000 - end if - stop - -48000 continue - - - ndist(n)=ndist(n)+1 - if(.not.top.and.w.lt.wmaxf)then - -! contribution from all updrafts stronger than wmax -! assuming constant f (close to fmax) - wnuc=w+wdiab - - z1=(w-wbar)/(sigw*sq2) - z2=(wmaxf-wbar)/(sigw*sq2) - integ=sigw*0.5*sq2*sqpi*(ERFC_NUM_RECIPES(z1)-ERFC_NUM_RECIPES(z2)) -! consider only upward flow into cloud base when estimating flux - wf1=max(w,zero) - zf1=(wf1-wbar)/(sigw*sq2) - gf1=exp(-zf1*zf1) - wf2=max(wmaxf,zero) - zf2=(wf2-wbar)/(sigw*sq2) - gf2=exp(-zf2*zf2) - gf=(gf1-gf2) - integf=wbar*sigw*0.5*sq2*sqpi*(ERFC_NUM_RECIPES(zf1)-ERFC_NUM_RECIPES(zf2))+sigw*sigw*gf - - do n=1,ntype_aer - do m=1,nsize_aer(n) - sumflxn(m,n)=sumflxn(m,n)+integf*fn(m,n) - sumfn(m,n)=sumfn(m,n)+fn(m,n)*integ - sumflxs(m,n)=sumflxs(m,n)+integf*fs(m,n) - sumfs(m,n)=sumfs(m,n)+fs(m,n)*integ - sumflxm(m,n)=sumflxm(m,n)+integf*fm(m,n) - sumfm(m,n)=sumfm(m,n)+fm(m,n)*integ - end do - end do -! same form as sumflxm(m,n) but replace the fm(m,n) with 1.0 - sumflx_fullact = sumflx_fullact + integf -! sumg=sumg+integ - endif - - - do n=1,ntype_aer - do m=1,nsize_aer(n) - -! fn(m,n)=sumfn(m,n)/(sumg) - fn(m,n)=sumfn(m,n)/(sq2*sqpi*sigw) - fluxn(m,n)=sumflxn(m,n)/(sq2*sqpi*sigw) - if(fn(m,n).gt.1.01)then - if (idiag_fnsm_prob .gt. 0) then - print *,'fn=',fn(m,n),' > 1 - activate err41' - print *,'w,m,n,na,am=',w,m,n,na(m,n),am(m,n) - print *,'integ,sumfn,sigw=',integ,sumfn(m,n),sigw - print *,'subr activate error - i,j,k =', ii, jj, kk -! call exit - endif - fluxn(m,n) = fluxn(m,n)/fn(m,n) - endif - - fs(m,n)=sumfs(m,n)/(sq2*sqpi*sigw) - fluxs(m,n)=sumflxs(m,n)/(sq2*sqpi*sigw) - if(fs(m,n).gt.1.01)then - if (idiag_fnsm_prob .gt. 0) then - print *,'fs=',fs(m,n),' > 1 - activate err42' - print *,'m,n,isectional=',m,n,isectional - print *,'alnsign(m,n)=',alnsign(m,n) - print *,'rcut,rlo(m,n),rhi(m,n)',exp(xcut),rlo(m,n),rhi(m,n) - print *,'w,m,na,am=',w,m,na(m,n),am(m,n) - print *,'integ,sumfs,sigw=',integ,sumfs(m,n),sigw - endif - fluxs(m,n) = fluxs(m,n)/fs(m,n) - endif - -! fm(m,n)=sumfm(m,n)/(sumg) - fm(m,n)=sumfm(m,n)/(sq2*sqpi*sigw) - fluxm(m,n)=sumflxm(m,n)/(sq2*sqpi*sigw) - if(fm(m,n).gt.1.01)then - if (idiag_fnsm_prob .gt. 0) then - print *,'fm(',m,n,')=',fm(m,n),' > 1 - activate err43' - endif - fluxm(m,n) = fluxm(m,n)/fm(m,n) - endif - - end do - end do -! same form as fluxm(m,n) - flux_fullact = sumflx_fullact/(sq2*sqpi*sigw) - - goto 60000 -!....................................................................... -! -! end calc. of activation fractions/fluxes -! for spectrum of updrafts (end of section 2) -! -!....................................................................... - -!....................................................................... -! -! start calc. of activation fractions/fluxes -! for (single) uniform updraft (start of section 3) -! -!....................................................................... -50000 continue - - wnuc=wbar+wdiab -! write(6,*)'uniform updraft =',wnuc - -! 04-nov-2005 rce - moved the code for "wnuc.le.0" code to here - if(wnuc.le.0.)then - do n=1,ntype_aer - do m=1,nsize_aer(n) - fn(m,n)=0 - fluxn(m,n)=0 - fs(m,n)=0 - fluxs(m,n)=0 - fm(m,n)=0 - fluxm(m,n)=0 - end do - end do - flux_fullact=0. - return - endif - - w=wbar - alw=alpha*wnuc - sqrtalw=sqrt(alw) - zeta=2.*sqrtalw*aten/(3.*sqrtg) - - if (isectional .gt. 0) then -! sectional model. -! use bulk properties - do n=1,ntype_aer - if(totn(n).gt.1.e-10)then - eta(1,n)=2*alw*sqrtalw/(totn(n)*beta*sqrtg) - else - eta(1,n)=1.e10 - endif - end do - call maxsat(zeta,eta,maxd_atype,ntype_aer, & - maxd_asize,(/1/),gmsm,gmlnsig,f1,smax) - - else - - do n=1,ntype_aer - do m=1,nsize_aer(n) - if(na(m,n).gt.1.e-10)then - eta(m,n)=2*alw*sqrtalw/(na(m,n)*beta*sqrtg) - else - eta(m,n)=1.e10 - endif - end do - end do - - call maxsat(zeta,eta,maxd_atype,ntype_aer, & - maxd_asize,nsize_aer,sm,alnsign,f1,smax) - - endif - - lnsmax=log(smax) - xmincoeff=alogaten-2.*third*(lnsmax-alog2)-alog3 - - do 55002 n=1,ntype_aer - do 55000 m=1,nsize_aer(n) - -! 04-nov-2005 rce - check for bin_is_empty here too, just like earlier - if ( bin_is_empty(m,n) ) then - fn(m,n)=0. - fs(m,n)=0. - fm(m,n)=0. - - else if ((isectional .eq. 2) .or. (isectional .eq. 4)) then -! sectional -! within-section dn/dx = a + b*x - xcut=xmincoeff-third*lnhygro(m,n) -! ycut=(exp(xcut)/rhi(m,n))**3 -! 07-jul-2006 rce - the above line gave a (rare) overflow when smax=1.0e-20 -! if (ycut > yhi), then actual value of ycut is unimportant, -! so do the following to avoid overflow - lnycut = 3.0 * ( xcut - log(rhi(m,n)) ) - lnycut = min( lnycut, log(yhi(m,n)*1.0e5) ) - ycut=exp(lnycut) -! write(6,*)'m,n,rcut,rlo,rhi=',m,n,exp(xcut),rlo(m,n),rhi(m,n) -! if(lnsmax.lt.lnsmn(m,n))then - if(ycut.gt.yhi(m,n))then - fn(m,n)=0. - fs(m,n)=0. - fm(m,n)=0. -! elseif(lnsmax.gt.lnsmx(m,n))then - elseif(ycut.lt.ylo(m,n))then - fn(m,n)=1. - fs(m,n)=1. - fm(m,n)=1. - elseif ( bin_is_narrow(m,n) ) then -! 04-nov-2005 rce - for extremely narrow bins, -! do zero activation if xcut>xmean, 100% activation otherwise - if (ycut.gt.ymean(m,n)) then - fn(m,n)=0. - fs(m,n)=0. - fm(m,n)=0. - else - fn(m,n)=1. - fs(m,n)=1. - fm(m,n)=1. - endif - else - phiyy=ycut/yhi(m,n) - fn(m,n) = asub(m,n)*(1.0-phiyy) + 0.5*bsub(m,n)*(1.0-phiyy*phiyy) - if (fn(m,n).lt.zero .or. fn(m,n).gt.one) then - if (idiag_fnsm_prob .gt. 0) then - print *,'fn(',m,n,')=',fn(m,n),' outside 0,1 - activate err21' - print *,'na,volc =', na(m,n), volc(m,n) - print *,'asub,bsub =', asub(m,n), bsub(m,n) - print *,'yhi,ycut =', yhi(m,n), ycut - endif - endif - - if (fn(m,n) .le. zero) then -! 10-nov-2005 rce - if fn=0, then fs & fm must be 0 - fn(m,n)=zero - fs(m,n)=zero - fm(m,n)=zero - else if (fn(m,n) .ge. one) then -! 10-nov-2005 rce - if fn=1, then fs & fm must be 1 - fn(m,n)=one - fs(m,n)=one - fm(m,n)=one - else -! 10-nov-2005 rce - otherwise, calc fm and check it - fm(m,n) = (yhi(m,n)/ymean(m,n)) * (0.5*asub(m,n)*(1.0-phiyy*phiyy) + & - third*bsub(m,n)*(1.0-phiyy*phiyy*phiyy)) - if (fm(m,n).lt.fn(m,n) .or. fm(m,n).gt.one) then - if (idiag_fnsm_prob .gt. 0) then - print *,'fm(',m,n,')=',fm(m,n),' outside fn,1 - activate err22' - print *,'na,volc,fn =', na(m,n), volc(m,n), fn(m,n) - print *,'asub,bsub =', asub(m,n), bsub(m,n) - print *,'yhi,ycut =', yhi(m,n), ycut - endif - endif - if (fm(m,n) .le. fn(m,n)) then -! 10-nov-2005 rce - if fm=fn, then fs must =fn - fm(m,n)=fn(m,n) - fs(m,n)=fn(m,n) - else if (fm(m,n) .ge. one) then -! 10-nov-2005 rce - if fm=1, then fs & fn must be 1 - fm(m,n)=one - fs(m,n)=one - fn(m,n)=one - else -! 10-nov-2005 rce - these two checks assure that the mean size -! of the activated & interstitial particles will be between rlo & rhi - dumaa = fn(m,n)*(yhi(m,n)/ymean(m,n)) - fm(m,n) = min( fm(m,n), dumaa ) - dumaa = 1.0 + (fn(m,n)-1.0)*(ylo(m,n)/ymean(m,n)) - fm(m,n) = min( fm(m,n), dumaa ) -! 10-nov-2005 rce - now calculate fs and bound it by fn, fm - betayy = ylo(m,n)/yhi(m,n) - dumaa = phiyy**twothird - dumbb = betayy**twothird - fs(m,n) = & - (asub(m,n)*(1.0-phiyy*dumaa) + & - 0.625*bsub(m,n)*(1.0-phiyy*phiyy*dumaa)) / & - (asub(m,n)*(1.0-betayy*dumbb) + & - 0.625*bsub(m,n)*(1.0-betayy*betayy*dumbb)) - fs(m,n)=max(fs(m,n),fn(m,n)) - fs(m,n)=min(fs(m,n),fm(m,n)) - endif - endif - - endif - - else -! modal - x=2*(lnsm(m,n)-lnsmax)/(3*sq2*alnsign(m,n)) - fn(m,n)=0.5*(1.-ERF_ALT(x)) - arg=x-sq2*alnsign(m,n) - fs(m,n)=0.5*(1.-ERF_ALT(arg)) - arg=x-1.5*sq2*alnsign(m,n) - fm(m,n)=0.5*(1.-ERF_ALT(arg)) - endif - -! fn(m,n)=1. ! test -! fs(m,n)=1. -! fm(m,n)=1. - if((top.and.wbar.lt.0.).or.(.not.top.and.wbar.gt.0.))then - fluxn(m,n)=fn(m,n)*w - fluxs(m,n)=fs(m,n)*w - fluxm(m,n)=fm(m,n)*w - else - fluxn(m,n)=0 - fluxs(m,n)=0 - fluxm(m,n)=0 - endif - -55000 continue ! m=1,nsize_aer(n) -55002 continue ! n=1,ntype_aer - - if((top.and.wbar.lt.0.).or.(.not.top.and.wbar.gt.0.))then - flux_fullact = w - else - flux_fullact = 0.0 - endif - -! 04-nov-2005 rce - moved the code for "wnuc.le.0" from here -! to near the start the uniform undraft section - -!....................................................................... -! -! end calc. of activation fractions/fluxes -! for (single) uniform updraft (end of section 3) -! -!....................................................................... - - - -60000 continue - - -! do n=1,ntype_aer -! do m=1,nsize_aer(n) -! write(6,'(a,2i3,5e10.1)')'n,m,na,wbar,sigw,fn,fm=',n,m,na(m,n),wbar,sigw,fn(m,n),fm(m,n) -! end do -! end do - - - return - end subroutine activate - - - -!---------------------------------------------------------------------- -!---------------------------------------------------------------------- - subroutine maxsat(zeta,eta, & - maxd_atype,ntype_aer,maxd_asize,nsize_aer, & - sm,alnsign,f1,smax) - -! Calculates maximum supersaturation for multiple competing aerosol -! modes. Note that maxsat_init must be called before calling this -! subroutine. - -! Abdul-Razzak and Ghan, A parameterization of aerosol activation. -! 2. Multiple aerosol types. J. Geophys. Res., 105, 6837-6844. - - implicit none - - integer, intent(in) :: maxd_atype - integer, intent(in) :: ntype_aer - integer, intent(in) :: maxd_asize - integer, intent(in) :: nsize_aer(maxd_atype) ! number of size bins - real, intent(in) :: sm(maxd_asize,maxd_atype) ! critical supersaturation for number mode radius - real, intent(in) :: zeta, eta(maxd_asize,maxd_atype) - real, intent(in) :: alnsign(maxd_asize,maxd_atype) ! ln(sigma) - real, intent(in) :: f1(maxd_asize,maxd_atype) - real, intent(out) :: smax ! maximum supersaturation - - real :: g1, g2 - real thesum - real, save :: twothird - data twothird/0.66666666667/ - integer m ! size index - integer n ! type index - - do n=1,ntype_aer - do m=1,nsize_aer(n) - if(zeta.gt.1.e5*eta(m,n) .or. & - sm(m,n)*sm(m,n).gt.1.e5*eta(m,n))then -! weak forcing. essentially none activated - smax=1.e-20 - else -! significant activation of this mode. calc activation all modes. - go to 1 - endif - end do - end do - - return - - 1 continue - - thesum=0 - do n=1,ntype_aer - do m=1,nsize_aer(n) - if(eta(m,n).gt.1.e-20)then - g1=sqrt(zeta/eta(m,n)) - g1=g1*g1*g1 - g2=sm(m,n)/sqrt(eta(m,n)+3*zeta) - g2=sqrt(g2) - g2=g2*g2*g2 - thesum=thesum + & - (f1(m,n)*g1+(1.+0.25*alnsign(m,n))*g2)/(sm(m,n)*sm(m,n)) - else - thesum=1.e20 - endif - end do - end do - - smax=1./sqrt(thesum) - - return - end subroutine maxsat - - - -!---------------------------------------------------------------------- -!---------------------------------------------------------------------- - subroutine maxsat_init(maxd_atype, ntype_aer, & - maxd_asize, nsize_aer, alnsign, f1) - -! Calculates the f1 paramter needed by maxsat. - -! Abdul-Razzak and Ghan, A parameterization of aerosol activation. -! 2. Multiple aerosol types. J. Geophys. Res., 105, 6837-6844. - - implicit none - - integer, intent(in) :: maxd_atype - integer, intent(in) :: ntype_aer ! number of aerosol types - integer, intent(in) :: maxd_asize - integer, intent(in) :: nsize_aer(maxd_atype) ! number of size bins - real, intent(in) :: alnsign(maxd_asize,maxd_atype) ! ln(sigma) - real, intent(out) :: f1(maxd_asize,maxd_atype) - - integer m ! size index - integer n ! type index - -! calculate and save f1(sigma), assumes sigma is invariant -! between calls to this init routine - - do n=1,ntype_aer - do m=1,nsize_aer(n) - f1(m,n)=0.5*exp(2.5*alnsign(m,n)*alnsign(m,n)) - end do - end do - - end subroutine maxsat_init - - - -!---------------------------------------------------------------------- -!---------------------------------------------------------------------- -! 25-apr-2006 rce - dens_aer is (g/cm3), NOT (kg/m3); -! grid_id, ktau, i, j, isize, itype added to arg list to assist debugging - subroutine loadaer(chem,k,kmn,kmx,num_chem,cs,npv, & - dlo_sect,dhi_sect,maxd_acomp, ncomp, & - grid_id, ktau, i, j, isize, itype, & - numptr_aer, numptrcw_aer, dens_aer, & - massptr_aer, massptrcw_aer, & - maerosol, maerosolcw, & - maerosol_tot, maerosol_totcw, & - naerosol, naerosolcw, & - vaerosol, vaerosolcw) - - implicit none - -! load aerosol number, surface, mass concentrations - -! input - - integer, intent(in) :: num_chem ! maximum number of consituents - integer, intent(in) :: k,kmn,kmx - real, intent(in) :: chem(kmn:kmx,num_chem) ! aerosol mass, number mixing ratios - real, intent(in) :: cs ! air density (kg/m3) - real, intent(in) :: npv ! number per volume concentration (/m3) - integer, intent(in) :: maxd_acomp,ncomp - integer, intent(in) :: numptr_aer,numptrcw_aer - integer, intent(in) :: massptr_aer(maxd_acomp), massptrcw_aer(maxd_acomp) - real, intent(in) :: dens_aer(maxd_acomp) ! aerosol material density (g/cm3) - real, intent(in) :: dlo_sect,dhi_sect ! minimum, maximum diameter of section (cm) - integer, intent(in) :: grid_id, ktau, i, j, isize, itype - -! output - - real, intent(out) :: naerosol ! interstitial number conc (/m3) - real, intent(out) :: naerosolcw ! activated number conc (/m3) - real, intent(out) :: maerosol(maxd_acomp) ! interstitial mass conc (kg/m3) - real, intent(out) :: maerosolcw(maxd_acomp) ! activated mass conc (kg/m3) - real, intent(out) :: maerosol_tot ! total-over-species interstitial mass conc (kg/m3) - real, intent(out) :: maerosol_totcw ! total-over-species activated mass conc (kg/m3) - real, intent(out) :: vaerosol ! interstitial volume conc (m3/m3) - real, intent(out) :: vaerosolcw ! activated volume conc (m3/m3) - -! internal - - integer lnum,lnumcw,l,ltype,lmass,lmasscw,lsfc,lsfccw - real num_at_dhi, num_at_dlo - real npv_at_dhi, npv_at_dlo - real, save :: pi - data pi/3.1415926526/ - real specvol ! inverse aerosol material density (m3/kg) - - lnum=numptr_aer - lnumcw=numptrcw_aer - maerosol_tot=0. - maerosol_totcw=0. - vaerosol=0. - vaerosolcw=0. - do l=1,ncomp - lmass=massptr_aer(l) - lmasscw=massptrcw_aer(l) - maerosol(l)=chem(k,lmass)*cs - maerosol(l)=max(maerosol(l),0.) - maerosolcw(l)=chem(k,lmasscw)*cs - maerosolcw(l)=max(maerosolcw(l),0.) - maerosol_tot=maerosol_tot+maerosol(l) - maerosol_totcw=maerosol_totcw+maerosolcw(l) -! [ 1.e-3 factor because dens_aer is (g/cm3), specvol is (m3/kg) ] - specvol=1.0e-3/dens_aer(l) - vaerosol=vaerosol+maerosol(l)*specvol - vaerosolcw=vaerosolcw+maerosolcw(l)*specvol -! write(6,'(a,3e12.2)')'maerosol,dens_aer,vaerosol=',maerosol(l),dens_aer(l),vaerosol - enddo - - if(lnum.gt.0)then -! aerosol number predicted -! [ 1.0e6 factor because because dhi_ & dlo_sect are (cm), vaerosol is (m3) ] - npv_at_dhi = 6.0e6/(pi*dhi_sect*dhi_sect*dhi_sect) - npv_at_dlo = 6.0e6/(pi*dlo_sect*dlo_sect*dlo_sect) - - naerosol=chem(k,lnum)*cs - naerosolcw=chem(k,lnumcw)*cs - num_at_dhi = vaerosol*npv_at_dhi - num_at_dlo = vaerosol*npv_at_dlo - naerosol = max( num_at_dhi, min( num_at_dlo, naerosol ) ) - -! write(6,'(a,5e10.1)')'naerosol,num_at_dhi,num_at_dlo,dhi_sect,dlo_sect', & -! naerosol,num_at_dhi,num_at_dlo,dhi_sect,dlo_sect - num_at_dhi = vaerosolcw*npv_at_dhi - num_at_dlo = vaerosolcw*npv_at_dlo - naerosolcw = max( num_at_dhi, min( num_at_dlo, naerosolcw ) ) - else -! aerosol number diagnosed from mass and prescribed size - naerosol=vaerosol*npv - naerosol=max(naerosol,0.) - naerosolcw=vaerosolcw*npv - naerosolcw=max(naerosolcw,0.) - endif - - - return - end subroutine loadaer - - - -!----------------------------------------------------------------------- - real function erfc_num_recipes( x ) -! -! from press et al, numerical recipes, 1990, page 164 -! - implicit none - real x - double precision erfc_dbl, dum, t, zz - - zz = abs(x) - t = 1.0/(1.0 + 0.5*zz) - -! erfc_num_recipes = -! & t*exp( -zz*zz - 1.26551223 + t*(1.00002368 + t*(0.37409196 + -! & t*(0.09678418 + t*(-0.18628806 + t*(0.27886807 + -! & t*(-1.13520398 + -! & t*(1.48851587 + t*(-0.82215223 + t*0.17087277 ))))))))) - - dum = ( -zz*zz - 1.26551223 + t*(1.00002368 + t*(0.37409196 + & - t*(0.09678418 + t*(-0.18628806 + t*(0.27886807 + & - t*(-1.13520398 + & - t*(1.48851587 + t*(-0.82215223 + t*0.17087277 ))))))))) - - erfc_dbl = t * exp(dum) - if (x .lt. 0.0) erfc_dbl = 2.0d0 - erfc_dbl - - erfc_num_recipes = erfc_dbl - - return - end function erfc_num_recipes - -!----------------------------------------------------------------------- - real function erf_alt( x ) - - implicit none - - real,intent(in) :: x - - erf_alt = 1. - erfc_num_recipes(x) - - end function erf_alt - -END MODULE module_mixactivate diff --git a/src/fim/FIMsrc/fim/wrfphys/module_mp_etanew.F b/src/fim/FIMsrc/fim/wrfphys/module_mp_etanew.F deleted file mode 100644 index b079ae8..0000000 --- a/src/fim/FIMsrc/fim/wrfphys/module_mp_etanew.F +++ /dev/null @@ -1,2593 +0,0 @@ -!WRF:MODEL_MP:PHYSICS -! -MODULE module_mp_etanew -! -!----------------------------------------------------------------------- - REAL,PRIVATE,SAVE :: ABFR, CBFR, CIACW, CIACR, C_N0r0, & - & CN0r0, CN0r_DMRmin, CN0r_DMRmax, CRACW, CRAUT, ESW0, & - & RFmax, RQR_DR1, RQR_DR2, RQR_DR3, RQR_DRmin, & - & RQR_DRmax, RR_DRmin, RR_DR1, RR_DR2, RR_DR3, RR_DRmax -! - INTEGER, PRIVATE,PARAMETER :: MY_T1=1, MY_T2=35 - REAL,PRIVATE,DIMENSION(MY_T1:MY_T2),SAVE :: MY_GROWTH -! - REAL, PRIVATE,PARAMETER :: DMImin=.05e-3, DMImax=1.e-3, & - & DelDMI=1.e-6,XMImin=1.e6*DMImin - INTEGER, PUBLIC,PARAMETER :: XMImax=1.e6*DMImax, XMIexp=.0536, & - & MDImin=XMImin, MDImax=XMImax - REAL, PRIVATE,DIMENSION(MDImin:MDImax) :: & - & ACCRI,SDENS,VSNOWI,VENTI1,VENTI2 -! - REAL, PRIVATE,PARAMETER :: DMRmin=.05e-3, DMRmax=.45e-3, & - & DelDMR=1.e-6,XMRmin=1.e6*DMRmin, XMRmax=1.e6*DMRmax - INTEGER, PRIVATE,PARAMETER :: MDRmin=XMRmin, MDRmax=XMRmax - REAL, PRIVATE,DIMENSION(MDRmin:MDRmax):: & - & ACCRR,MASSR,RRATE,VRAIN,VENTR1,VENTR2 -! - INTEGER, PRIVATE,PARAMETER :: Nrime=40 - REAL, DIMENSION(2:9,0:Nrime),PRIVATE,SAVE :: VEL_RF -! - INTEGER,PARAMETER :: NX=7501 - REAL, PARAMETER :: XMIN=180.0,XMAX=330.0 - REAL, DIMENSION(NX),SAVE :: TBPVS,TBPVS0 - REAL, SAVE :: C1XPVS0,C2XPVS0,C1XPVS,C2XPVS -! - REAL, PRIVATE,PARAMETER :: & -!--- Physical constants follow: - & CP=1004.6, EPSQ=1.E-12, GRAV=9.806, RHOL=1000., RD=287.04 & - & ,RV=461.5, T0C=273.15, XLS=2.834E6 & -!--- Derived physical constants follow: - & ,EPS=RD/RV, EPS1=RV/RD-1., EPSQ1=1.001*EPSQ & - & ,RCP=1./CP, RCPRV=RCP/RV, RGRAV=1./GRAV, RRHOL=1./RHOL & - & ,XLS1=XLS*RCP, XLS2=XLS*XLS*RCPRV, XLS3=XLS*XLS/RV & -!--- Constants specific to the parameterization follow: -!--- CLIMIT/CLIMIT1 are lower limits for treating accumulated precipitation - & ,CLIMIT=10.*EPSQ, CLIMIT1=-CLIMIT & - & ,C1=1./3. & - & ,DMR1=.1E-3, DMR2=.2E-3, DMR3=.32E-3 & - & ,XMR1=1.e6*DMR1, XMR2=1.e6*DMR2, XMR3=1.e6*DMR3 - INTEGER, PARAMETER :: MDR1=XMR1, MDR2=XMR2, MDR3=XMR3 -! -! ====================================================================== -!--- Important tunable parameters that are exported to other modules -! * RHgrd - threshold relative humidity for onset of condensation -! * T_ICE - temperature (C) threshold at which all remaining liquid water -! is glaciated to ice -! * T_ICE_init - maximum temperature (C) at which ice nucleation occurs -! * NLImax - maximum number concentrations (m**-3) of large ice (snow/graupel/sleet) -! * NLImin - minimum number concentrations (m**-3) of large ice (snow/graupel/sleet) -! * N0r0 - assumed intercept (m**-4) of rain drops if drop diameters are between 0.2 and 0.45 mm -! * N0rmin - minimum intercept (m**-4) for rain drops -! * NCW - number concentrations of cloud droplets (m**-3) -! * FLARGE1, FLARGE2 - number fraction of large ice to total (large+snow) ice -! at T>0C and in presence of sublimation (FLARGE1), otherwise in -! presence of ice saturated/supersaturated conditions -! ====================================================================== - REAL, PUBLIC,PARAMETER :: & - & RHgrd=1. & - & ,T_ICE=-40. & - & ,T_ICEK=T0C+T_ICE & - & ,T_ICE_init=-15. & - & ,NLImax=5.E3 & - & ,NLImin=1.E3 & - & ,N0r0=8.E6 & - & ,N0rmin=1.E4 & - & ,NCW=100.E6 & - & ,FLARGE1=1. & - & ,FLARGE2=.2 -!--- Other public variables passed to other routines: - REAL,PUBLIC,SAVE :: QAUT0 - REAL, PUBLIC,DIMENSION(MDImin:MDImax) :: MASSI -! -! - CONTAINS - -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- - SUBROUTINE ETAMP_NEW (itimestep,DT,DX,DY, & - & dz8w,rho_phy,p_phy,pi_phy,th_phy,qv,qt, & - & LOWLYR,SR, & - & F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY, & - & QC,QR,QS, & - & mp_restart_state,tbpvs_state,tbpvs0_state, & - & RAINNC,RAINNCV, & - & ids,ide, jds,jde, kds,kde, & - & ims,ime, jms,jme, kms,kme, & - & its,ite, jts,jte, kts,kte ) -!----------------------------------------------------------------------- - IMPLICIT NONE -!----------------------------------------------------------------------- - INTEGER, PARAMETER :: ITLO=-60, ITHI=40 - - INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & - & ,IMS,IME,JMS,JME,KMS,KME & - & ,ITS,ITE,JTS,JTE,KTS,KTE & - & ,ITIMESTEP - - REAL, INTENT(IN) :: DT,DX,DY - REAL, INTENT(IN), DIMENSION(ims:ime, kms:kme, jms:jme):: & - & dz8w,p_phy,pi_phy,rho_phy - REAL, INTENT(INOUT), DIMENSION(ims:ime, kms:kme, jms:jme):: & - & th_phy,qv,qt - REAL, INTENT(INOUT), DIMENSION(ims:ime, kms:kme, jms:jme ) :: & - & qc,qr,qs - REAL, INTENT(INOUT), DIMENSION(ims:ime, kms:kme, jms:jme ) :: & - & F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY - REAL, INTENT(INOUT), DIMENSION(ims:ime,jms:jme) :: & - & RAINNC,RAINNCV - REAL, INTENT(OUT), DIMENSION(ims:ime,jms:jme):: SR -! - REAL,DIMENSION(*),INTENT(INOUT) :: MP_RESTART_STATE -! - REAL,DIMENSION(nx),INTENT(INOUT) :: TBPVS_STATE,TBPVS0_STATE -! - INTEGER, DIMENSION( ims:ime, jms:jme ),INTENT(INOUT) :: LOWLYR - -!----------------------------------------------------------------------- -! LOCAL VARS -!----------------------------------------------------------------------- - -! NSTATS,QMAX,QTOT are diagnostic vars - - INTEGER,DIMENSION(ITLO:ITHI,4) :: NSTATS - REAL, DIMENSION(ITLO:ITHI,5) :: QMAX - REAL, DIMENSION(ITLO:ITHI,22):: QTOT - -! SOME VARS WILL BE USED FOR DATA ASSIMILATION (DON'T NEED THEM NOW). -! THEY ARE TREATED AS LOCAL VARS, BUT WILL BECOME STATE VARS IN THE -! FUTURE. SO, WE DECLARED THEM AS MEMORY SIZES FOR THE FUTURE USE - -! TLATGS_PHY,TRAIN_PHY,APREC,PREC,ACPREC,SR are not directly related -! the microphysics scheme. Instead, they will be used by Eta precip -! assimilation. - - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: & - & TLATGS_PHY,TRAIN_PHY - REAL, DIMENSION(ims:ime,jms:jme):: APREC,PREC,ACPREC - REAL, DIMENSION(its:ite, kts:kte, jts:jte):: t_phy - - INTEGER :: I,J,K,KFLIP - REAL :: WC -! -!----------------------------------------------------------------------- -!********************************************************************** -!----------------------------------------------------------------------- -! - MY_GROWTH(MY_T1:MY_T2)=MP_RESTART_STATE(MY_T1:MY_T2) -! - C1XPVS0=MP_RESTART_STATE(MY_T2+1) - C2XPVS0=MP_RESTART_STATE(MY_T2+2) - C1XPVS =MP_RESTART_STATE(MY_T2+3) - C2XPVS =MP_RESTART_STATE(MY_T2+4) - CIACW =MP_RESTART_STATE(MY_T2+5) - CIACR =MP_RESTART_STATE(MY_T2+6) - CRACW =MP_RESTART_STATE(MY_T2+7) - CRAUT =MP_RESTART_STATE(MY_T2+8) -! - TBPVS(1:NX) =TBPVS_STATE(1:NX) - TBPVS0(1:NX)=TBPVS0_STATE(1:NX) -! - DO j = jts,jte - DO k = kts,kte - DO i = its,ite - t_phy(i,k,j) = th_phy(i,k,j)*pi_phy(i,k,j) - qv(i,k,j)=qv(i,k,j)/(1.+qv(i,k,j)) !Convert to specific humidity - ENDDO - ENDDO - ENDDO - -! initial diagnostic variables and data assimilation vars -! (will need to delete this part in the future) - - DO k = 1,4 - DO i = ITLO,ITHI - NSTATS(i,k)=0. - ENDDO - ENDDO - - DO k = 1,5 - DO i = ITLO,ITHI - QMAX(i,k)=0. - ENDDO - ENDDO - - DO k = 1,22 - DO i = ITLO,ITHI - QTOT(i,k)=0. - ENDDO - ENDDO - -! initial data assimilation vars (will need to delete this part in the future) - - DO j = jts,jte - DO k = kts,kte - DO i = its,ite - TLATGS_PHY (i,k,j)=0. - TRAIN_PHY (i,k,j)=0. - ENDDO - ENDDO - ENDDO - - DO j = jts,jte - DO i = its,ite - ACPREC(i,j)=0. - APREC (i,j)=0. - PREC (i,j)=0. - SR (i,j)=0. - ENDDO - ENDDO - -!----------------------------------------------------------------------- - - CALL EGCP01DRV(DT,LOWLYR, & - & APREC,PREC,ACPREC,SR,NSTATS,QMAX,QTOT, & - & dz8w,rho_phy,qt,t_phy,qv,F_ICE_PHY,P_PHY, & - & F_RAIN_PHY,F_RIMEF_PHY,TLATGS_PHY,TRAIN_PHY, & - & ids,ide, jds,jde, kds,kde, & - & ims,ime, jms,jme, kms,kme, & - & its,ite, jts,jte, kts,kte ) -!----------------------------------------------------------------------- - - DO j = jts,jte - DO k = kts,kte - DO i = its,ite - th_phy(i,k,j) = t_phy(i,k,j)/pi_phy(i,k,j) - qv(i,k,j)=qv(i,k,j)/(1.-qv(i,k,j)) !Convert to mixing ratio - WC=qt(I,K,J) - QS(I,K,J)=0. - QR(I,K,J)=0. - QC(I,K,J)=0. - IF(F_ICE_PHY(I,K,J)>=1.)THEN - QS(I,K,J)=WC - ELSEIF(F_ICE_PHY(I,K,J)<=0.)THEN - QC(I,K,J)=WC - ELSE - QS(I,K,J)=F_ICE_PHY(I,K,J)*WC - QC(I,K,J)=WC-QS(I,K,J) - ENDIF -! - IF(QC(I,K,J)>0..AND.F_RAIN_PHY(I,K,J)>0.)THEN - IF(F_RAIN_PHY(I,K,J).GE.1.)THEN - QR(I,K,J)=QC(I,K,J) - QC(I,K,J)=0. - ELSE - QR(I,K,J)=F_RAIN_PHY(I,K,J)*QC(I,K,J) - QC(I,K,J)=QC(I,K,J)-QR(I,K,J) - ENDIF - ENDIF - ENDDO - ENDDO - ENDDO -! -! update rain (from m to mm) - - DO j=jts,jte - DO i=its,ite - RAINNC(i,j)=APREC(i,j)*1000.+RAINNC(i,j) - RAINNCV(i,j)=APREC(i,j)*1000. - ENDDO - ENDDO -! - MP_RESTART_STATE(MY_T1:MY_T2)=MY_GROWTH(MY_T1:MY_T2) - MP_RESTART_STATE(MY_T2+1)=C1XPVS0 - MP_RESTART_STATE(MY_T2+2)=C2XPVS0 - MP_RESTART_STATE(MY_T2+3)=C1XPVS - MP_RESTART_STATE(MY_T2+4)=C2XPVS - MP_RESTART_STATE(MY_T2+5)=CIACW - MP_RESTART_STATE(MY_T2+6)=CIACR - MP_RESTART_STATE(MY_T2+7)=CRACW - MP_RESTART_STATE(MY_T2+8)=CRAUT -! - TBPVS_STATE(1:NX) =TBPVS(1:NX) - TBPVS0_STATE(1:NX)=TBPVS0(1:NX) - -!----------------------------------------------------------------------- - - END SUBROUTINE ETAMP_NEW - -!----------------------------------------------------------------------- - - SUBROUTINE EGCP01DRV( & - & DTPH,LOWLYR,APREC,PREC,ACPREC,SR, & - & NSTATS,QMAX,QTOT, & - & dz8w,RHO_PHY,CWM_PHY,T_PHY,Q_PHY,F_ICE_PHY,P_PHY, & - & F_RAIN_PHY,F_RIMEF_PHY,TLATGS_PHY,TRAIN_PHY, & - & ids,ide, jds,jde, kds,kde, & - & ims,ime, jms,jme, kms,kme, & - & its,ite, jts,jte, kts,kte) -!----------------------------------------------------------------------- -! DTPH Physics time step (s) -! CWM_PHY (qt) Mixing ratio of the total condensate. kg/kg -! Q_PHY Mixing ratio of water vapor. kg/kg -! F_RAIN_PHY Fraction of rain. -! F_ICE_PHY Fraction of ice. -! F_RIMEF_PHY Mass ratio of rimed ice (rime factor). -! -!TLATGS_PHY,TRAIN_PHY,APREC,PREC,ACPREC,SR are not directly related the -!micrphysics sechme. Instead, they will be used by Eta precip assimilation. -! -!NSTATS,QMAX,QTOT are used for diagnosis purposes. -! -!----------------------------------------------------------------------- -!--- Variables APREC,PREC,ACPREC,SR are calculated for precip assimilation -! and/or ZHAO's scheme in Eta and are not required by this microphysics -! scheme itself. -!--- NSTATS,QMAX,QTOT are used for diagnosis purposes only. They will be -! printed out when PRINT_diag is true. -! -!----------------------------------------------------------------------- - IMPLICIT NONE -!----------------------------------------------------------------------- -! - INTEGER, PARAMETER :: ITLO=-60, ITHI=40 - LOGICAL, PARAMETER :: PRINT_diag=.FALSE. -! VARIABLES PASSED IN/OUT - INTEGER,INTENT(IN ) :: ids,ide, jds,jde, kds,kde & - & ,ims,ime, jms,jme, kms,kme & - & ,its,ite, jts,jte, kts,kte - REAL,INTENT(IN) :: DTPH - INTEGER, DIMENSION( ims:ime, jms:jme ),INTENT(INOUT) :: LOWLYR - INTEGER,DIMENSION(ITLO:ITHI,4),INTENT(INOUT) :: NSTATS - REAL,DIMENSION(ITLO:ITHI,5),INTENT(INOUT) :: QMAX - REAL,DIMENSION(ITLO:ITHI,22),INTENT(INOUT) :: QTOT - REAL,DIMENSION(ims:ime,jms:jme),INTENT(INOUT) :: & - & APREC,PREC,ACPREC,SR - REAL,DIMENSION( its:ite, kts:kte, jts:jte ),INTENT(INOUT) :: t_phy - REAL,DIMENSION( ims:ime, kms:kme, jms:jme ),INTENT(IN) :: & - & dz8w,P_PHY,RHO_PHY - REAL,DIMENSION( ims:ime, kms:kme, jms:jme ),INTENT(INOUT) :: & - & CWM_PHY, F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY,TLATGS_PHY & - & ,Q_PHY,TRAIN_PHY -! -!----------------------------------------------------------------------- -!LOCAL VARIABLES -!----------------------------------------------------------------------- -! -#define CACHE_FRIENDLY_MP_ETANEW -#ifdef CACHE_FRIENDLY_MP_ETANEW -# define TEMP_DIMS kts:kte,its:ite,jts:jte -# define TEMP_DEX L,I,J -#else -# define TEMP_DIMS its:ite,jts:jte,kts:kte -# define TEMP_DEX I,J,L -#endif -! - INTEGER :: LSFC,I,J,I_index,J_index,L,K,KFLIP - REAL,DIMENSION(TEMP_DIMS) :: CWM,T,Q,TRAIN,TLATGS,P - REAL,DIMENSION(kts:kte,its:ite,jts:jte) :: F_ice,F_rain,F_RimeF - INTEGER,DIMENSION(its:ite,jts:jte) :: LMH - REAL :: TC,WC,QI,QR,QW,Fice,Frain,DUM,ASNOW,ARAIN - REAL,DIMENSION(kts:kte) :: P_col,Q_col,T_col,QV_col,WC_col, & - RimeF_col,QI_col,QR_col,QW_col, THICK_col,DPCOL - REAL,DIMENSION(2) :: PRECtot,PRECmax -!----------------------------------------------------------------------- -! - DO J=JTS,JTE - DO I=ITS,ITE - LMH(I,J) = KTE-LOWLYR(I,J)+1 - ENDDO - ENDDO - - DO 98 J=JTS,JTE - DO 98 I=ITS,ITE - DO L=KTS,KTE - KFLIP=KTE+1-L - CWM(TEMP_DEX)=CWM_PHY(I,KFLIP,J) - T(TEMP_DEX)=T_PHY(I,KFLIP,J) - Q(TEMP_DEX)=Q_PHY(I,KFLIP,J) - P(TEMP_DEX)=P_PHY(I,KFLIP,J) - TLATGS(TEMP_DEX)=TLATGS_PHY(I,KFLIP,J) - TRAIN(TEMP_DEX)=TRAIN_PHY(I,KFLIP,J) - F_ice(L,I,J)=F_ice_PHY(I,KFLIP,J) - F_rain(L,I,J)=F_rain_PHY(I,KFLIP,J) - F_RimeF(L,I,J)=F_RimeF_PHY(I,KFLIP,J) - ENDDO -98 CONTINUE - - DO 100 J=JTS,JTE - DO 100 I=ITS,ITE - LSFC=LMH(I,J) ! "L" of surface -! - DO K=KTS,KTE - KFLIP=KTE+1-K - DPCOL(K)=RHO_PHY(I,KFLIP,J)*GRAV*dz8w(I,KFLIP,J) - ENDDO -! - ! - !--- Initialize column data (1D arrays) - ! - L=1 - IF (CWM(TEMP_DEX) .LE. EPSQ) CWM(TEMP_DEX)=EPSQ - F_ice(1,I,J)=1. - F_rain(1,I,J)=0. - F_RimeF(1,I,J)=1. - DO L=1,LSFC - ! - !--- Pressure (Pa) = (Psfc-Ptop)*(ETA/ETA_sfc)+Ptop - ! - P_col(L)=P(TEMP_DEX) - ! - !--- Layer thickness = RHO*DZ = -DP/G = (Psfc-Ptop)*D_ETA/(G*ETA_sfc) - ! - THICK_col(L)=DPCOL(L)*RGRAV - T_col(L)=T(TEMP_DEX) - TC=T_col(L)-T0C - QV_col(L)=max(EPSQ, Q(TEMP_DEX)) - IF (CWM(TEMP_DEX) .LE. EPSQ1) THEN - WC_col(L)=0. - IF (TC .LT. T_ICE) THEN - F_ice(L,I,J)=1. - ELSE - F_ice(L,I,J)=0. - ENDIF - F_rain(L,I,J)=0. - F_RimeF(L,I,J)=1. - ELSE - WC_col(L)=CWM(TEMP_DEX) - ENDIF - ! - !--- Determine composition of condensate in terms of - ! cloud water, ice, & rain - ! - WC=WC_col(L) - QI=0. - QR=0. - QW=0. - Fice=F_ice(L,I,J) - Frain=F_rain(L,I,J) - IF (Fice .GE. 1.) THEN - QI=WC - ELSE IF (Fice .LE. 0.) THEN - QW=WC - ELSE - QI=Fice*WC - QW=WC-QI - ENDIF - IF (QW.GT.0. .AND. Frain.GT.0.) THEN - IF (Frain .GE. 1.) THEN - QR=QW - QW=0. - ELSE - QR=Frain*QW - QW=QW-QR - ENDIF - ENDIF - IF (QI .LE. 0.) F_RimeF(L,I,J)=1. - RimeF_col(L)=F_RimeF(L,I,J) ! (real) - QI_col(L)=QI - QR_col(L)=QR - QW_col(L)=QW - ENDDO -! -!####################################################################### - ! - !--- Perform the microphysical calculations in this column - ! - I_index=I - J_index=J - CALL EGCP01COLUMN ( ARAIN, ASNOW, DTPH, I_index, J_index, LSFC, & - & P_col, QI_col, QR_col, QV_col, QW_col, RimeF_col, T_col, & - & THICK_col, WC_col,KTS,KTE,NSTATS,QMAX,QTOT ) - - - ! -!####################################################################### -! - ! - !--- Update storage arrays - ! - DO L=1,LSFC - TRAIN(TEMP_DEX)=(T_col(L)-T(TEMP_DEX))/DTPH - TLATGS(TEMP_DEX)=T_col(L)-T(TEMP_DEX) - T(TEMP_DEX)=T_col(L) - Q(TEMP_DEX)=QV_col(L) - CWM(TEMP_DEX)=WC_col(L) - ! - !--- REAL*4 array storage - ! - IF (QI_col(L) .LE. EPSQ) THEN - F_ice(L,I,J)=0. - IF (T_col(L) .LT. T_ICEK) F_ice(L,I,J)=1. - F_RimeF(L,I,J)=1. - ELSE - F_ice(L,I,J)=MAX( 0., MIN(1., QI_col(L)/WC_col(L)) ) - F_RimeF(L,I,J)=MAX(1., RimeF_col(L)) - ENDIF - IF (QR_col(L) .LE. EPSQ) THEN - DUM=0 - ELSE - DUM=QR_col(L)/(QR_col(L)+QW_col(L)) - ENDIF - F_rain(L,I,J)=DUM - ! - ENDDO - ! - !--- Update accumulated precipitation statistics - ! - !--- Surface precipitation statistics; SR is fraction of surface - ! precipitation (if >0) associated with snow - ! - APREC(I,J)=(ARAIN+ASNOW)*RRHOL ! Accumulated surface precip (depth in m) !<--- Ying - PREC(I,J)=PREC(I,J)+APREC(I,J) - ACPREC(I,J)=ACPREC(I,J)+APREC(I,J) - IF(APREC(I,J) .LT. 1.E-8) THEN - SR(I,J)=0. - ELSE - SR(I,J)=RRHOL*ASNOW/APREC(I,J) - ENDIF - ! - !--- Debug statistics - ! - IF (PRINT_diag) THEN - PRECtot(1)=PRECtot(1)+ARAIN - PRECtot(2)=PRECtot(2)+ASNOW - PRECmax(1)=MAX(PRECmax(1), ARAIN) - PRECmax(2)=MAX(PRECmax(2), ASNOW) - ENDIF - - -!####################################################################### -!####################################################################### -! -100 CONTINUE ! End "I" & "J" loops - DO 101 J=JTS,JTE - DO 101 I=ITS,ITE - DO L=KTS,KTE - KFLIP=KTE+1-L - CWM_PHY(I,KFLIP,J)=CWM(TEMP_DEX) - T_PHY(I,KFLIP,J)=T(TEMP_DEX) - Q_PHY(I,KFLIP,J)=Q(TEMP_DEX) - TLATGS_PHY(I,KFLIP,J)=TLATGS(TEMP_DEX) - TRAIN_PHY(I,KFLIP,J)=TRAIN(TEMP_DEX) - F_ice_PHY(I,KFLIP,J)=F_ice(L,I,J) - F_rain_PHY(I,KFLIP,J)=F_rain(L,I,J) - F_RimeF_PHY(I,KFLIP,J)=F_RimeF(L,I,J) - ENDDO -101 CONTINUE - END SUBROUTINE EGCP01DRV -! -! -!############################################################################### -! ***** VERSION OF MICROPHYSICS DESIGNED FOR HIGHER RESOLUTION MESO ETA MODEL -! (1) Represents sedimentation by preserving a portion of the precipitation -! through top-down integration from cloud-top. Modified procedure to -! Zhao and Carr (1997). -! (2) Microphysical equations are modified to be less sensitive to time -! steps by use of Clausius-Clapeyron equation to account for changes in -! saturation mixing ratios in response to latent heating/cooling. -! (3) Prevent spurious temperature oscillations across 0C due to -! microphysics. -! (4) Uses lookup tables for: calculating two different ventilation -! coefficients in condensation and deposition processes; accretion of -! cloud water by precipitation; precipitation mass; precipitation rate -! (and mass-weighted precipitation fall speeds). -! (5) Assumes temperature-dependent variation in mean diameter of large ice -! (Houze et al., 1979; Ryan et al., 1996). -! -> 8/22/01: This relationship has been extended to colder temperatures -! to parameterize smaller large-ice particles down to mean sizes of MDImin, -! which is 50 microns reached at -55.9C. -! (6) Attempts to differentiate growth of large and small ice, mainly for -! improved transition from thin cirrus to thick, precipitating ice -! anvils. -! -> 8/22/01: This feature has been diminished by effectively adjusting to -! ice saturation during depositional growth at temperatures colder than -! -10C. Ice sublimation is calculated more explicitly. The logic is -! that sources of are either poorly understood (e.g., nucleation for NWP) -! or are not represented in the Eta model (e.g., detrainment of ice from -! convection). Otherwise the model is too wet compared to the radiosonde -! observations based on 1 Feb - 18 March 2001 retrospective runs. -! (7) Top-down integration also attempts to treat mixed-phase processes, -! allowing a mixture of ice and water. Based on numerous observational -! studies, ice growth is based on nucleation at cloud top & -! subsequent growth by vapor deposition and riming as the ice particles -! fall through the cloud. Effective nucleation rates are a function -! of ice supersaturation following Meyers et al. (JAM, 1992). -! -> 8/22/01: The simulated relative humidities were far too moist compared -! to the rawinsonde observations. This feature has been substantially -! diminished, limited to a much narrower temperature range of 0 to -10C. -! (8) Depositional growth of newly nucleated ice is calculated for large time -! steps using Fig. 8 of Miller and Young (JAS, 1979), at 1 deg intervals -! using their ice crystal masses calculated after 600 s of growth in water -! saturated conditions. The growth rates are normalized by time step -! assuming 3D growth with time**1.5 following eq. (6.3) in Young (1993). -! -> 8/22/01: This feature has been effectively limited to 0 to -10C. -! (9) Ice precipitation rates can increase due to increase in response to -! cloud water riming due to (a) increased density & mass of the rimed -! ice, and (b) increased fall speeds of rimed ice. -! -> 8/22/01: This feature has been effectively limited to 0 to -10C. -!############################################################################### -!############################################################################### -! - SUBROUTINE EGCP01COLUMN ( ARAIN, ASNOW, DTPH, I_index, J_index, & - & LSFC, P_col, QI_col, QR_col, QV_col, QW_col, RimeF_col, T_col, & - & THICK_col, WC_col ,KTS,KTE,NSTATS,QMAX,QTOT) -! -!############################################################################### -!############################################################################### -! -!------------------------------------------------------------------------------- -!----- NOTE: Code is currently set up w/o threading! -!------------------------------------------------------------------------------- -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: Grid-scale microphysical processes - condensation & precipitation -! PRGRMMR: Ferrier ORG: W/NP22 DATE: 08-2001 -! PRGRMMR: Jin (Modification for WRF structure) -!------------------------------------------------------------------------------- -! ABSTRACT: -! * Merges original GSCOND & PRECPD subroutines. -! * Code has been substantially streamlined and restructured. -! * Exchange between water vapor & small cloud condensate is calculated using -! the original Asai (1965, J. Japan) algorithm. See also references to -! Yau and Austin (1979, JAS), Rutledge and Hobbs (1983, JAS), and Tao et al. -! (1989, MWR). This algorithm replaces the Sundqvist et al. (1989, MWR) -! parameterization. -!------------------------------------------------------------------------------- -! -! USAGE: -! * CALL EGCP01COLUMN FROM SUBROUTINE EGCP01DRV -! -! INPUT ARGUMENT LIST: -! DTPH - physics time step (s) -! I_index - I index -! J_index - J index -! LSFC - Eta level of level above surface, ground -! P_col - vertical column of model pressure (Pa) -! QI_col - vertical column of model ice mixing ratio (kg/kg) -! QR_col - vertical column of model rain ratio (kg/kg) -! QV_col - vertical column of model water vapor specific humidity (kg/kg) -! QW_col - vertical column of model cloud water mixing ratio (kg/kg) -! RimeF_col - vertical column of rime factor for ice in model (ratio, defined below) -! T_col - vertical column of model temperature (deg K) -! THICK_col - vertical column of model mass thickness (density*height increment) -! WC_col - vertical column of model mixing ratio of total condensate (kg/kg) -! -! -! OUTPUT ARGUMENT LIST: -! ARAIN - accumulated rainfall at the surface (kg) -! ASNOW - accumulated snowfall at the surface (kg) -! QV_col - vertical column of model water vapor specific humidity (kg/kg) -! WC_col - vertical column of model mixing ratio of total condensate (kg/kg) -! QW_col - vertical column of model cloud water mixing ratio (kg/kg) -! QI_col - vertical column of model ice mixing ratio (kg/kg) -! QR_col - vertical column of model rain ratio (kg/kg) -! RimeF_col - vertical column of rime factor for ice in model (ratio, defined below) -! T_col - vertical column of model temperature (deg K) -! -! OUTPUT FILES: -! NONE -! -! Subprograms & Functions called: -! * Real Function CONDENSE - cloud water condensation -! * Real Function DEPOSIT - ice deposition (not sublimation) -! -! UNIQUE: NONE -! -! LIBRARY: NONE -! -! COMMON BLOCKS: -! CMICRO_CONS - key constants initialized in GSMCONST -! CMICRO_STATS - accumulated and maximum statistics -! CMY_GROWTH - lookup table for growth of ice crystals in -! water saturated conditions (Miller & Young, 1979) -! IVENT_TABLES - lookup tables for ventilation effects of ice -! IACCR_TABLES - lookup tables for accretion rates of ice -! IMASS_TABLES - lookup tables for mass content of ice -! IRATE_TABLES - lookup tables for precipitation rates of ice -! IRIME_TABLES - lookup tables for increase in fall speed of rimed ice -! RVENT_TABLES - lookup tables for ventilation effects of rain -! RACCR_TABLES - lookup tables for accretion rates of rain -! RMASS_TABLES - lookup tables for mass content of rain -! RVELR_TABLES - lookup tables for fall speeds of rain -! RRATE_TABLES - lookup tables for precipitation rates of rain -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE : IBM SP -! -! -!------------------------------------------------------------------------- -!--------------- Arrays & constants in argument list --------------------- -!------------------------------------------------------------------------- -! - IMPLICIT NONE -! - INTEGER,INTENT(IN) :: KTS,KTE,I_index, J_index, LSFC - REAL,INTENT(INOUT) :: ARAIN, ASNOW - REAL,DIMENSION(KTS:KTE),INTENT(INOUT) :: P_col, QI_col,QR_col & - & ,QV_col ,QW_col, RimeF_col, T_col, THICK_col,WC_col -! -!------------------------------------------------------------------------- -!-------------- Common blocks for microphysical statistics --------------- -!------------------------------------------------------------------------- -! -!------------------------------------------------------------------------- -!--------- Common blocks for constants initialized in GSMCONST ---------- -! - INTEGER, PARAMETER :: ITLO=-60, ITHI=40 - INTEGER,INTENT(INOUT) :: NSTATS(ITLO:ITHI,4) - REAL,INTENT(INOUT) :: QMAX(ITLO:ITHI,5),QTOT(ITLO:ITHI,22) -! -!------------------------------------------------------------------------- -!--------------- Common blocks for various lookup tables ----------------- -! -!--- Discretized growth rates of small ice crystals after their nucleation -! at 1 C intervals from -1 C to -35 C, based on calculations by Miller -! and Young (1979, JAS) after 600 s of growth. Resultant growth rates -! are multiplied by physics time step in GSMCONST. -! -!------------------------------------------------------------------------- -! -!--- Mean ice-particle diameters varying from 50 microns to 1000 microns -! (1 mm), assuming an exponential size distribution. -! -!---- Meaning of the following arrays: -! - mdiam - mean diameter (m) -! - VENTI1 - integrated quantity associated w/ ventilation effects -! (capacitance only) for calculating vapor deposition onto ice -! - VENTI2 - integrated quantity associated w/ ventilation effects -! (with fall speed) for calculating vapor deposition onto ice -! - ACCRI - integrated quantity associated w/ cloud water collection by ice -! - MASSI - integrated quantity associated w/ ice mass -! - VSNOWI - mass-weighted fall speed of snow (large ice), used to calculate -! precipitation rates -! -! -!------------------------------------------------------------------------- -! -!--- VEL_RF - velocity increase of rimed particles as functions of crude -! particle size categories (at 0.1 mm intervals of mean ice particle -! sizes) and rime factor (different values of Rime Factor of 1.1**N, -! where N=0 to Nrime). -! -!------------------------------------------------------------------------- -! -!--- Mean rain drop diameters varying from 50 microns (0.05 mm) to 450 microns -! (0.45 mm), assuming an exponential size distribution. -! -!------------------------------------------------------------------------- -!------- Key parameters, local variables, & important comments --------- -!----------------------------------------------------------------------- -! -!--- TOLER => Tolerance or precision for accumulated precipitation -! - REAL, PARAMETER :: TOLER=5.E-7, C2=1./6., RHO0=1.194, Xratio=.025 -! -!--- If BLEND=1: -! precipitation (large) ice amounts are estimated at each level as a -! blend of ice falling from the grid point above and the precip ice -! present at the start of the time step (see TOT_ICE below). -!--- If BLEND=0: -! precipitation (large) ice amounts are estimated to be the precip -! ice present at the start of the time step. -! -!--- Extended to include sedimentation of rain on 2/5/01 -! - REAL, PARAMETER :: BLEND=1. -! -!--- This variable is for debugging purposes (if .true.) -! - LOGICAL, PARAMETER :: PRINT_diag=.FALSE. -! -!----------------------------------------------------------------------- -!--- Local variables -!----------------------------------------------------------------------- -! - REAL EMAIRI, N0r, NLICE, NSmICE - LOGICAL CLEAR, ICE_logical, DBG_logical, RAIN_logical - INTEGER :: IDR,INDEX_MY,INDEXR,INDEXR1,INDEXS,IPASS,ITDX,IXRF, & - & IXS,LBEF,L -! - REAL :: ABI,ABW,AIEVP,ARAINnew,ASNOWnew,BLDTRH,BUDGET, & - & CREVP,DELI,DELR,DELT,DELV,DELW,DENOMF, & - & DENOMI,DENOMW,DENOMWI,DIDEP, & - & DIEVP,DIFFUS,DLI,DTPH,DTRHO,DUM,DUM1, & - & DUM2,DWV0,DWVI,DWVR,DYNVIS,ESI,ESW,FIR,FLARGE,FLIMASS, & - & FSMALL,FWR,FWS,GAMMAR,GAMMAS, & - & PCOND,PIACR,PIACW,PIACWI,PIACWR,PICND,PIDEP,PIDEP_max, & - & PIEVP,PILOSS,PIMLT,PP,PRACW,PRAUT,PREVP,PRLOSS, & - & QI,QInew,QLICE,QR,QRnew,QSI,QSIgrd,QSInew,QSW,QSW0, & - & QSWgrd,QSWnew,QT,QTICE,QTnew,QTRAIN,QV,QW,QW0,QWnew, & - & RFACTOR,RHO,RIMEF,RIMEF1,RQR,RR,RRHO,SFACTOR, & - & TC,TCC,TFACTOR,THERM_COND,THICK,TK,TK2,TNEW, & - & TOT_ICE,TOT_ICEnew,TOT_RAIN,TOT_RAINnew, & - & VEL_INC,VENTR,VENTIL,VENTIS,VRAIN1,VRAIN2,VRIMEF,VSNOW, & - & WC,WCnew,WSgrd,WS,WSnew,WV,WVnew,WVQW, & - & XLF,XLF1,XLI,XLV,XLV1,XLV2,XLIMASS,XRF,XSIMASS -! -!####################################################################### -!########################## Begin Execution ############################ -!####################################################################### -! -! - ARAIN=0. ! Accumulated rainfall into grid box from above (kg/m**2) - ASNOW=0. ! Accumulated snowfall into grid box from above (kg/m**2) -! -!----------------------------------------------------------------------- -!------------ Loop from top (L=1) to surface (L=LSFC) ------------------ -!----------------------------------------------------------------------- -! - - DO 10 L=1,LSFC - -!--- Skip this level and go to the next lower level if no condensate -! and very low specific humidities -! - IF (QV_col(L).LE.EPSQ .AND. WC_col(L).LE.EPSQ) GO TO 10 -! -!----------------------------------------------------------------------- -!------------ Proceed with cloud microphysics calculations ------------- -!----------------------------------------------------------------------- -! - TK=T_col(L) ! Temperature (deg K) - TC=TK-T0C ! Temperature (deg C) - PP=P_col(L) ! Pressure (Pa) - QV=QV_col(L) ! Specific humidity of water vapor (kg/kg) - WV=QV/(1.-QV) ! Water vapor mixing ratio (kg/kg) - WC=WC_col(L) ! Grid-scale mixing ratio of total condensate (water or ice; kg/kg) -! -!----------------------------------------------------------------------- -!--- Moisture variables below are mixing ratios & not specifc humidities -!----------------------------------------------------------------------- -! - CLEAR=.TRUE. -! -!--- This check is to determine grid-scale saturation when no condensate is present -! - ESW=1000.*FPVS0(TK) ! Saturation vapor pressure w/r/t water - QSW=EPS*ESW/(PP-ESW) ! Saturation mixing ratio w/r/t water - WS=QSW ! General saturation mixing ratio (water/ice) - IF (TC .LT. 0.) THEN - ESI=1000.*FPVS(TK) ! Saturation vapor pressure w/r/t ice - QSI=EPS*ESI/(PP-ESI) ! Saturation mixing ratio w/r/t water - WS=QSI ! General saturation mixing ratio (water/ice) - ENDIF -! -!--- Effective grid-scale Saturation mixing ratios -! - QSWgrd=RHgrd*QSW - QSIgrd=RHgrd*QSI - WSgrd=RHgrd*WS -! -!--- Check if air is subsaturated and w/o condensate -! - IF (WV.GT.WSgrd .OR. WC.GT.EPSQ) CLEAR=.FALSE. -! -!--- Check if any rain is falling into layer from above -! - IF (ARAIN .GT. CLIMIT) THEN - CLEAR=.FALSE. - ELSE - ARAIN=0. - ENDIF -! -!--- Check if any ice is falling into layer from above -! -!--- NOTE that "SNOW" in variable names is synonomous with -! large, precipitation ice particles -! - IF (ASNOW .GT. CLIMIT) THEN - CLEAR=.FALSE. - ELSE - ASNOW=0. - ENDIF -! -!----------------------------------------------------------------------- -!-- Loop to the end if in clear, subsaturated air free of condensate --- -!----------------------------------------------------------------------- -! - IF (CLEAR) GO TO 10 -! -!----------------------------------------------------------------------- -!--------- Initialize RHO, THICK & microphysical processes ------------- -!----------------------------------------------------------------------- -! -! -!--- Virtual temperature, TV=T*(1./EPS-1)*Q, Q is specific humidity; -! (see pp. 63-65 in Fleagle & Businger, 1963) -! - RHO=PP/(RD*TK*(1.+EPS1*QV)) ! Air density (kg/m**3) - RRHO=1./RHO ! Reciprocal of air density - DTRHO=DTPH*RHO ! Time step * air density - BLDTRH=BLEND*DTRHO ! Blend parameter * time step * air density - THICK=THICK_col(L) ! Layer thickness = RHO*DZ = -DP/G = (Psfc-Ptop)*D_ETA/(G*ETA_sfc) -! - ARAINnew=0. ! Updated accumulated rainfall - ASNOWnew=0. ! Updated accumulated snowfall - QI=QI_col(L) ! Ice mixing ratio - QInew=0. ! Updated ice mixing ratio - QR=QR_col(L) ! Rain mixing ratio - QRnew=0. ! Updated rain ratio - QW=QW_col(L) ! Cloud water mixing ratio - QWnew=0. ! Updated cloud water ratio -! - PCOND=0. ! Condensation (>0) or evaporation (<0) of cloud water (kg/kg) - PIDEP=0. ! Deposition (>0) or sublimation (<0) of ice crystals (kg/kg) - PIACW=0. ! Cloud water collection (riming) by precipitation ice (kg/kg; >0) - PIACWI=0. ! Growth of precip ice by riming (kg/kg; >0) - PIACWR=0. ! Shedding of accreted cloud water to form rain (kg/kg; >0) - PIACR=0. ! Freezing of rain onto large ice at supercooled temps (kg/kg; >0) - PICND=0. ! Condensation (>0) onto wet, melting ice (kg/kg) - PIEVP=0. ! Evaporation (<0) from wet, melting ice (kg/kg) - PIMLT=0. ! Melting ice (kg/kg; >0) - PRAUT=0. ! Cloud water autoconversion to rain (kg/kg; >0) - PRACW=0. ! Cloud water collection (accretion) by rain (kg/kg; >0) - PREVP=0. ! Rain evaporation (kg/kg; <0) -! -!--- Double check input hydrometeor mixing ratios -! -! DUM=WC-(QI+QW+QR) -! DUM1=ABS(DUM) -! DUM2=TOLER*MIN(WC, QI+QW+QR) -! IF (DUM1 .GT. DUM2) THEN -! WRITE(6,"(/2(a,i4),a,i2)") '{@ i=',I_index,' j=',J_index, -! & ' L=',L -! WRITE(6,"(4(a12,g11.4,1x))") -! & '{@ TCold=',TC,'P=',.01*PP,'DIFF=',DUM,'WCold=',WC, -! & '{@ QIold=',QI,'QWold=',QW,'QRold=',QR -! ENDIF -! -!*********************************************************************** -!*********** MAIN MICROPHYSICS CALCULATIONS NOW FOLLOW! **************** -!*********************************************************************** -! -!--- Calculate a few variables, which are used more than once below -! -!--- Latent heat of vaporization as a function of temperature from -! Bolton (1980, JAS) -! - XLV=3.148E6-2370*TK ! Latent heat of vaporization (Lv) - XLF=XLS-XLV ! Latent heat of fusion (Lf) - XLV1=XLV*RCP ! Lv/Cp - XLF1=XLF*RCP ! Lf/Cp - TK2=1./(TK*TK) ! 1./TK**2 - XLV2=XLV*XLV*QSW*TK2/RV ! Lv**2*Qsw/(Rv*TK**2) - DENOMW=1.+XLV2*RCP ! Denominator term, Clausius-Clapeyron correction -! -!--- Basic thermodynamic quantities -! * DYNVIS - dynamic viscosity [ kg/(m*s) ] -! * THERM_COND - thermal conductivity [ J/(m*s*K) ] -! * DIFFUS - diffusivity of water vapor [ m**2/s ] -! - TFACTOR=TK**1.5/(TK+120.) - DYNVIS=1.496E-6*TFACTOR - THERM_COND=2.116E-3*TFACTOR - DIFFUS=8.794E-5*TK**1.81/PP -! -!--- Air resistance term for the fall speed of ice following the -! basic research by Heymsfield, Kajikawa, others -! - GAMMAS=(1.E5/PP)**C1 -! -!--- Air resistance for rain fall speed (Beard, 1985, JAS, p.470) -! - GAMMAR=(RHO0/RHO)**.4 -! -!---------------------------------------------------------------------- -!------------- IMPORTANT MICROPHYSICS DECISION TREE ----------------- -!---------------------------------------------------------------------- -! -!--- Determine if conditions supporting ice are present -! - IF (TC.LT.0. .OR. QI.GT. EPSQ .OR. ASNOW.GT.CLIMIT) THEN - ICE_logical=.TRUE. - ELSE - ICE_logical=.FALSE. - QLICE=0. - QTICE=0. - ENDIF -! -!--- Determine if rain is present -! - RAIN_logical=.FALSE. - IF (ARAIN.GT.CLIMIT .OR. QR.GT.EPSQ) RAIN_logical=.TRUE. -! - IF (ICE_logical) THEN -! -!--- IMPORTANT: Estimate time-averaged properties. -! -!--- -! * FLARGE - ratio of number of large ice to total (large & small) ice -! * FSMALL - ratio of number of small ice crystals to large ice particles -! -> Small ice particles are assumed to have a mean diameter of 50 microns. -! * XSIMASS - used for calculating small ice mixing ratio -!--- -! * TOT_ICE - total mass (small & large) ice before microphysics, -! which is the sum of the total mass of large ice in the -! current layer and the input flux of ice from above -! * PILOSS - greatest loss (<0) of total (small & large) ice by -! sublimation, removing all of the ice falling from above -! and the ice within the layer -! * RimeF1 - Rime Factor, which is the mass ratio of total (unrimed & rimed) -! ice mass to the unrimed ice mass (>=1) -! * VrimeF - the velocity increase due to rime factor or melting (ratio, >=1) -! * VSNOW - Fall speed of rimed snow w/ air resistance correction -! * EMAIRI - equivalent mass of air associated layer and with fall of snow into layer -! * XLIMASS - used for calculating large ice mixing ratio -! * FLIMASS - mass fraction of large ice -! * QTICE - time-averaged mixing ratio of total ice -! * QLICE - time-averaged mixing ratio of large ice -! * NLICE - time-averaged number concentration of large ice -! * NSmICE - number concentration of small ice crystals at current level -!--- -!--- Assumed number fraction of large ice particles to total (large & small) -! ice particles, which is based on a general impression of the literature. -! - WVQW=WV+QW ! Water vapor & cloud water -! - - - IF (TC.GE.0. .OR. WVQW.LT.QSIgrd) THEN - ! - !--- Eliminate small ice particle contributions for melting & sublimation - ! - FLARGE=FLARGE1 - ELSE - ! - !--- Enhanced number of small ice particles during depositional growth - ! (effective only when 0C > T >= T_ice [-10C] ) - ! - FLARGE=FLARGE2 - ! - !--- Larger number of small ice particles due to rime splintering - ! - IF (TC.GE.-8. .AND. TC.LE.-3.) FLARGE=.5*FLARGE -! - ENDIF ! End IF (TC.GE.0. .OR. WVQW.LT.QSIgrd) - FSMALL=(1.-FLARGE)/FLARGE - XSIMASS=RRHO*MASSI(MDImin)*FSMALL - IF (QI.LE.EPSQ .AND. ASNOW.LE.CLIMIT) THEN - INDEXS=MDImin - TOT_ICE=0. - PILOSS=0. - RimeF1=1. - VrimeF=1. - VEL_INC=GAMMAS - VSNOW=0. - EMAIRI=THICK - XLIMASS=RRHO*RimeF1*MASSI(INDEXS) - FLIMASS=XLIMASS/(XLIMASS+XSIMASS) - QLICE=0. - QTICE=0. - NLICE=0. - NSmICE=0. - ELSE - ! - !--- For T<0C mean particle size follows Houze et al. (JAS, 1979, p. 160), - ! converted from Fig. 5 plot of LAMDAs. Similar set of relationships - ! also shown in Fig. 8 of Ryan (BAMS, 1996, p. 66). - ! - DUM=XMImax*EXP(.0536*TC) - INDEXS=MIN(MDImax, MAX(MDImin, INT(DUM) ) ) - TOT_ICE=THICK*QI+BLEND*ASNOW - PILOSS=-TOT_ICE/THICK - LBEF=MAX(1,L-1) - DUM1=RimeF_col(LBEF) - DUM2=RimeF_col(L) - RimeF1=(DUM2*THICK*QI+DUM1*BLEND*ASNOW)/TOT_ICE - RimeF1=MIN(RimeF1, RFmax) - DO IPASS=0,1 - IF (RimeF1 .LE. 1.) THEN - RimeF1=1. - VrimeF=1. - ELSE - IXS=MAX(2, MIN(INDEXS/100, 9)) - XRF=10.492*ALOG(RimeF1) - IXRF=MAX(0, MIN(INT(XRF), Nrime)) - IF (IXRF .GE. Nrime) THEN - VrimeF=VEL_RF(IXS,Nrime) - ELSE - VrimeF=VEL_RF(IXS,IXRF)+(XRF-FLOAT(IXRF))* & - & (VEL_RF(IXS,IXRF+1)-VEL_RF(IXS,IXRF)) - ENDIF - ENDIF ! End IF (RimeF1 .LE. 1.) - VEL_INC=GAMMAS*VrimeF - VSNOW=VEL_INC*VSNOWI(INDEXS) - EMAIRI=THICK+BLDTRH*VSNOW - XLIMASS=RRHO*RimeF1*MASSI(INDEXS) - FLIMASS=XLIMASS/(XLIMASS+XSIMASS) - QTICE=TOT_ICE/EMAIRI - QLICE=FLIMASS*QTICE - NLICE=QLICE/XLIMASS - NSmICE=Fsmall*NLICE - ! - IF ( (NLICE.GE.NLImin .AND. NLICE.LE.NLImax) & - & .OR. IPASS.EQ.1) THEN - EXIT - ELSE - IF (TC < 0) THEN - XLI=RHO*(QTICE/DUM-XSIMASS)/RimeF1 - IF (XLI .LE. MASSI(MDImin) ) THEN - INDEXS=MDImin - ELSE IF (XLI .LE. MASSI(450) ) THEN - DLI=9.5885E5*XLI**.42066 ! DLI in microns - INDEXS=MIN(MDImax, MAX(MDImin, INT(DLI) ) ) - ELSE IF (XLI .LE. MASSI(MDImax) ) THEN - DLI=3.9751E6*XLI**.49870 ! DLI in microns - INDEXS=MIN(MDImax, MAX(MDImin, INT(DLI) ) ) - ELSE - INDEXS=MDImax - ENDIF ! End IF (XLI .LE. MASSI(MDImin) ) - ENDIF ! End IF (TC < 0) - ! - !--- Reduce excessive accumulation of ice at upper levels - ! associated with strong grid-resolved ascent - ! - !--- Force NLICE to be between NLImin and NLImax - ! - ! - !--- 8/22/01: Increase density of large ice if maximum limits - ! are reached for number concentration (NLImax) and mean size - ! (MDImax). Done to increase fall out of ice. - ! - DUM=MAX(NLImin, MIN(NLImax, NLICE) ) - IF (DUM.GE.NLImax .AND. INDEXS.GE.MDImax) & - & RimeF1=RHO*(QTICE/NLImax-XSIMASS)/MASSI(INDEXS) -! WRITE(6,"(4(a12,g11.4,1x))") -! & '{$ TC=',TC,'P=',.01*PP,'NLICE=',NLICE,'DUM=',DUM, -! & '{$ XLI=',XLI,'INDEXS=',FLOAT(INDEXS),'RHO=',RHO,'QTICE=',QTICE, -! & '{$ XSIMASS=',XSIMASS,'RimeF1=',RimeF1 - ENDIF ! End IF ( (NLICE.GE.NLImin .AND. NLICE.LE.NLImax) ... - ENDDO ! End DO IPASS=0,1 - ENDIF ! End IF (QI.LE.EPSQ .AND. ASNOW.LE.CLIMIT) - ENDIF ! End IF (ICE_logical) -! -!---------------------------------------------------------------------- -!--------------- Calculate individual processes ----------------------- -!---------------------------------------------------------------------- -! -!--- Cloud water autoconversion to rain and collection by rain -! - IF (QW.GT.EPSQ .AND. TC.GE.T_ICE) THEN - ! - !--- QW0 could be modified based on land/sea properties, - ! presence of convection, etc. This is why QAUT0 and CRAUT - ! are passed into the subroutine as externally determined - ! parameters. Can be changed in the future if desired. - ! - QW0=QAUT0*RRHO - PRAUT=MAX(0., QW-QW0)*CRAUT - IF (QLICE .GT. EPSQ) THEN - ! - !--- Collection of cloud water by large ice particles ("snow") - ! PIACWI=PIACW for riming, PIACWI=0 for shedding - ! - FWS=MIN(1., CIACW*VEL_INC*NLICE*ACCRI(INDEXS)/PP**C1) - PIACW=FWS*QW - IF (TC .LT. 0.) PIACWI=PIACW ! Large ice riming - ENDIF ! End IF (QLICE .GT. EPSQ) - ENDIF ! End IF (QW.GT.EPSQ .AND. TC.GE.T_ICE) -! -!---------------------------------------------------------------------- -!--- Loop around some of the ice-phase processes if no ice should be present -!---------------------------------------------------------------------- -! - IF (ICE_logical .EQV. .FALSE.) GO TO 20 -! -!--- Now the pretzel logic of calculating ice deposition -! - IF (TC.LT.T_ICE .AND. (WV.GT.QSIgrd .OR. QW.GT.EPSQ)) THEN - ! - !--- Adjust to ice saturation at T0) and evaporation - ! - DUM=PIEVP-PIMLT - IF (DUM .LT. PILOSS) THEN - DUM1=PILOSS/DUM - PIMLT=PIMLT*DUM1 - PIEVP=PIEVP*DUM1 - ENDIF ! End IF (DUM .GT. QTICE) - ENDIF ! End IF (TC.GT.0. .AND. TCC.GT.0. .AND. ICE_logical) -! -!--- IMPORTANT: Estimate time-averaged properties. -! -! * TOT_RAIN - total mass of rain before microphysics, which is the sum of -! the total mass of rain in the current layer and the input -! flux of rain from above -! * VRAIN1 - fall speed of rain into grid from above (with air resistance correction) -! * QTRAIN - time-averaged mixing ratio of rain (kg/kg) -! * PRLOSS - greatest loss (<0) of rain, removing all rain falling from -! above and the rain within the layer -! * RQR - rain content (kg/m**3) -! * INDEXR - mean size of rain drops to the nearest 1 micron in size -! * N0r - intercept of rain size distribution (typically 10**6 m**-4) -! - TOT_RAIN=0. - VRAIN1=0. - QTRAIN=0. - PRLOSS=0. - RQR=0. - N0r=0. - INDEXR=MDRmin - INDEXR1=INDEXR !-- For debugging only - IF (RAIN_logical) THEN - IF (ARAIN .LE. 0.) THEN - INDEXR=MDRmin - VRAIN1=0. - ELSE - ! - !--- INDEXR (related to mean diameter) & N0r could be modified - ! by land/sea properties, presence of convection, etc. - ! - !--- Rain rate normalized to a density of 1.194 kg/m**3 - ! - RR=ARAIN/(DTPH*GAMMAR) - ! - IF (RR .LE. RR_DRmin) THEN - ! - !--- Assume fixed mean diameter of rain (0.2 mm) for low rain rates, - ! instead vary N0r with rain rate - ! - INDEXR=MDRmin - ELSE IF (RR .LE. RR_DR1) THEN - ! - !--- Best fit to mass-weighted fall speeds (V) from rain lookup tables - ! for mean diameters (Dr) between 0.05 and 0.10 mm: - ! V(Dr)=5.6023e4*Dr**1.136, V in m/s and Dr in m - ! RR = PI*1000.*N0r0*5.6023e4*Dr**(4+1.136) = 1.408e15*Dr**5.136, - ! RR in kg/(m**2*s) - ! Dr (m) = 1.123e-3*RR**.1947 -> Dr (microns) = 1.123e3*RR**.1947 - ! - INDEXR=INT( 1.123E3*RR**.1947 + .5 ) - INDEXR=MAX( MDRmin, MIN(INDEXR, MDR1) ) - ELSE IF (RR .LE. RR_DR2) THEN - ! - !--- Best fit to mass-weighted fall speeds (V) from rain lookup tables - ! for mean diameters (Dr) between 0.10 and 0.20 mm: - ! V(Dr)=1.0867e4*Dr**.958, V in m/s and Dr in m - ! RR = PI*1000.*N0r0*1.0867e4*Dr**(4+.958) = 2.731e14*Dr**4.958, - ! RR in kg/(m**2*s) - ! Dr (m) = 1.225e-3*RR**.2017 -> Dr (microns) = 1.225e3*RR**.2017 - ! - INDEXR=INT( 1.225E3*RR**.2017 + .5 ) - INDEXR=MAX( MDR1, MIN(INDEXR, MDR2) ) - ELSE IF (RR .LE. RR_DR3) THEN - ! - !--- Best fit to mass-weighted fall speeds (V) from rain lookup tables - ! for mean diameters (Dr) between 0.20 and 0.32 mm: - ! V(Dr)=2831.*Dr**.80, V in m/s and Dr in m - ! RR = PI*1000.*N0r0*2831.*Dr**(4+.80) = 7.115e13*Dr**4.80, - ! RR in kg/(m**2*s) - ! Dr (m) = 1.3006e-3*RR**.2083 -> Dr (microns) = 1.3006e3*RR**.2083 - ! - INDEXR=INT( 1.3006E3*RR**.2083 + .5 ) - INDEXR=MAX( MDR2, MIN(INDEXR, MDR3) ) - ELSE IF (RR .LE. RR_DRmax) THEN - ! - !--- Best fit to mass-weighted fall speeds (V) from rain lookup tables - ! for mean diameters (Dr) between 0.32 and 0.45 mm: - ! V(Dr)=944.8*Dr**.6636, V in m/s and Dr in m - ! RR = PI*1000.*N0r0*944.8*Dr**(4+.6636) = 2.3745e13*Dr**4.6636, - ! RR in kg/(m**2*s) - ! Dr (m) = 1.355e-3*RR**.2144 -> Dr (microns) = 1.355e3*RR**.2144 - ! - INDEXR=INT( 1.355E3*RR**.2144 + .5 ) - INDEXR=MAX( MDR3, MIN(INDEXR, MDRmax) ) - ELSE - ! - !--- Assume fixed mean diameter of rain (0.45 mm) for high rain rates, - ! instead vary N0r with rain rate - ! - INDEXR=MDRmax - ENDIF ! End IF (RR .LE. RR_DRmin) etc. - VRAIN1=GAMMAR*VRAIN(INDEXR) - ENDIF ! End IF (ARAIN .LE. 0.) - INDEXR1=INDEXR ! For debugging only - TOT_RAIN=THICK*QR+BLEND*ARAIN - QTRAIN=TOT_RAIN/(THICK+BLDTRH*VRAIN1) - PRLOSS=-TOT_RAIN/THICK - RQR=RHO*QTRAIN - ! - !--- RQR - time-averaged rain content (kg/m**3) - ! - IF (RQR .LE. RQR_DRmin) THEN - N0r=MAX(N0rmin, CN0r_DMRmin*RQR) - INDEXR=MDRmin - ELSE IF (RQR .GE. RQR_DRmax) THEN - N0r=CN0r_DMRmax*RQR - INDEXR=MDRmax - ELSE - N0r=N0r0 - INDEXR=MAX( XMRmin, MIN(CN0r0*RQR**.25, XMRmax) ) - ENDIF - ! - IF (TC .LT. T_ICE) THEN - PIACR=-PRLOSS - ELSE - DWVr=WV-PCOND-QSW - DUM=QW+PCOND - IF (DWVr.LT.0. .AND. DUM.LE.EPSQ) THEN - ! - !--- Rain evaporation - ! - ! * RFACTOR - [GAMMAR**.5]*[Schmidt**(1./3.)]*[(RHO/DYNVIS)**.5], - ! where Schmidt (Schmidt Number) =DYNVIS/(RHO*DIFFUS) - ! - ! * Units: RFACTOR - s**.5/m ; ABW - m**2/s ; VENTR - m**-2 ; - ! N0r - m**-4 ; VENTR1 - m**2 ; VENTR2 - m**3/s**.5 ; - ! CREVP - unitless - ! - RFACTOR=GAMMAR**.5*(RHO/(DIFFUS*DIFFUS*DYNVIS))**C2 - ABW=1./(RHO*XLV2/THERM_COND+1./DIFFUS) - ! - !--- Note that VENTR1, VENTR2 lookup tables do not include the - ! 1/Davg multiplier as in the ice tables - ! - VENTR=N0r*(VENTR1(INDEXR)+RFACTOR*VENTR2(INDEXR)) - CREVP=ABW*VENTR*DTPH - IF (CREVP .LT. Xratio) THEN - DUM=DWVr*CREVP - ELSE - DUM=DWVr*(1.-EXP(-CREVP*DENOMW))/DENOMW - ENDIF - PREVP=MAX(DUM, PRLOSS) - ELSE IF (QW .GT. EPSQ) THEN - FWR=CRACW*GAMMAR*N0r*ACCRR(INDEXR) - PRACW=MIN(1.,FWR)*QW - ENDIF ! End IF (DWVr.LT.0. .AND. DUM.LE.EPSQ) - ! - IF (TC.LT.0. .AND. TCC.LT.0.) THEN - ! - !--- Biggs (1953) heteorogeneous freezing (e.g., Lin et al., 1983) - ! - Rescaled mean drop diameter from microns (INDEXR) to mm (DUM) to prevent underflow - ! - DUM=.001*FLOAT(INDEXR) - DUM=(EXP(ABFR*TC)-1.)*DUM*DUM*DUM*DUM*DUM*DUM*DUM - PIACR=MIN(CBFR*N0r*RRHO*DUM, QTRAIN) - IF (QLICE .GT. EPSQ) THEN - ! - !--- Freezing of rain by collisions w/ large ice - ! - DUM=GAMMAR*VRAIN(INDEXR) - DUM1=DUM-VSNOW - ! - !--- DUM2 - Difference in spectral fall speeds of rain and - ! large ice, parameterized following eq. (48) on p. 112 of - ! Murakami (J. Meteor. Soc. Japan, 1990) - ! - DUM2=(DUM1*DUM1+.04*DUM*VSNOW)**.5 - DUM1=5.E-12*INDEXR*INDEXR+2.E-12*INDEXR*INDEXS & - & +.5E-12*INDEXS*INDEXS - FIR=MIN(1., CIACR*NLICE*DUM1*DUM2) - ! - !--- Future? Should COLLECTION BY SMALL ICE SHOULD BE INCLUDED??? - ! - PIACR=MIN(PIACR+FIR*QTRAIN, QTRAIN) - ENDIF ! End IF (QLICE .GT. EPSQ) - DUM=PREVP-PIACR - If (DUM .LT. PRLOSS) THEN - DUM1=PRLOSS/DUM - PREVP=DUM1*PREVP - PIACR=DUM1*PIACR - ENDIF ! End If (DUM .LT. PRLOSS) - ENDIF ! End IF (TC.LT.0. .AND. TCC.LT.0.) - ENDIF ! End IF (TC .LT. T_ICE) - ENDIF ! End IF (RAIN_logical) -! -!---------------------------------------------------------------------- -!---------------------- Main Budget Equations ------------------------- -!---------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------- -!--- Update fields, determine characteristics for next lower layer ---- -!----------------------------------------------------------------------- -! -!--- Carefully limit sinks of cloud water -! - DUM1=PIACW+PRAUT+PRACW-MIN(0.,PCOND) - IF (DUM1 .GT. QW) THEN - DUM=QW/DUM1 - PIACW=DUM*PIACW - PIACWI=DUM*PIACWI - PRAUT=DUM*PRAUT - PRACW=DUM*PRACW - IF (PCOND .LT. 0.) PCOND=DUM*PCOND - ENDIF - PIACWR=PIACW-PIACWI ! TC >= 0C -! -!--- QWnew - updated cloud water mixing ratio -! - DELW=PCOND-PIACW-PRAUT-PRACW - QWnew=QW+DELW - IF (QWnew .LE. EPSQ) QWnew=0. - IF (QW.GT.0. .AND. QWnew.NE.0.) THEN - DUM=QWnew/QW - IF (DUM .LT. TOLER) QWnew=0. - ENDIF -! -!--- Update temperature and water vapor mixing ratios -! - DELT= XLV1*(PCOND+PIEVP+PICND+PREVP) & - & +XLS1*PIDEP+XLF1*(PIACWI+PIACR-PIMLT) - Tnew=TK+DELT -! - DELV=-PCOND-PIDEP-PIEVP-PICND-PREVP - WVnew=WV+DELV -! -!--- Update ice mixing ratios -! -!--- -! * TOT_ICEnew - total mass (small & large) ice after microphysics, -! which is the sum of the total mass of large ice in the -! current layer and the flux of ice out of the grid box below -! * RimeF - Rime Factor, which is the mass ratio of total (unrimed & -! rimed) ice mass to the unrimed ice mass (>=1) -! * QInew - updated mixing ratio of total (large & small) ice in layer -! -> TOT_ICEnew=QInew*THICK+BLDTRH*QLICEnew*VSNOW -! -> But QLICEnew=QInew*FLIMASS, so -! -> TOT_ICEnew=QInew*(THICK+BLDTRH*FLIMASS*VSNOW) -! * ASNOWnew - updated accumulation of snow at bottom of grid cell -!--- -! - DELI=0. - RimeF=1. - IF (ICE_logical) THEN - DELI=PIDEP+PIEVP+PIACWI+PIACR-PIMLT - TOT_ICEnew=TOT_ICE+THICK*DELI - IF (TOT_ICE.GT.0. .AND. TOT_ICEnew.NE.0.) THEN - DUM=TOT_ICEnew/TOT_ICE - IF (DUM .LT. TOLER) TOT_ICEnew=0. - ENDIF - IF (TOT_ICEnew .LE. CLIMIT) THEN - TOT_ICEnew=0. - RimeF=1. - QInew=0. - ASNOWnew=0. - ELSE - ! - !--- Update rime factor if appropriate - ! - DUM=PIACWI+PIACR - IF (DUM.LE.EPSQ .AND. PIDEP.LE.EPSQ) THEN - RimeF=RimeF1 - ELSE - ! - !--- Rime Factor, RimeF = (Total ice mass)/(Total unrimed ice mass) - ! DUM1 - Total ice mass, rimed & unrimed - ! DUM2 - Estimated mass of *unrimed* ice - ! - DUM1=TOT_ICE+THICK*(PIDEP+DUM) - DUM2=TOT_ICE/RimeF1+THICK*PIDEP - IF (DUM2 .LE. 0.) THEN - RimeF=RFmax - ELSE - RimeF=MIN(RFmax, MAX(1., DUM1/DUM2) ) - ENDIF - ENDIF ! End IF (DUM.LE.EPSQ .AND. PIDEP.LE.EPSQ) - QInew=TOT_ICEnew/(THICK+BLDTRH*FLIMASS*VSNOW) - IF (QInew .LE. EPSQ) QInew=0. - IF (QI.GT.0. .AND. QInew.NE.0.) THEN - DUM=QInew/QI - IF (DUM .LT. TOLER) QInew=0. - ENDIF - ASNOWnew=BLDTRH*FLIMASS*VSNOW*QInew - IF (ASNOW.GT.0. .AND. ASNOWnew.NE.0.) THEN - DUM=ASNOWnew/ASNOW - IF (DUM .LT. TOLER) ASNOWnew=0. - ENDIF - ENDIF ! End IF (TOT_ICEnew .LE. CLIMIT) - ENDIF ! End IF (ICE_logical) - - -! -!--- Update rain mixing ratios -! -!--- -! * TOT_RAINnew - total mass of rain after microphysics -! current layer and the input flux of ice from above -! * VRAIN2 - time-averaged fall speed of rain in grid and below -! (with air resistance correction) -! * QRnew - updated rain mixing ratio in layer -! -> TOT_RAINnew=QRnew*(THICK+BLDTRH*VRAIN2) -! * ARAINnew - updated accumulation of rain at bottom of grid cell -!--- -! - DELR=PRAUT+PRACW+PIACWR-PIACR+PIMLT+PREVP+PICND - TOT_RAINnew=TOT_RAIN+THICK*DELR - IF (TOT_RAIN.GT.0. .AND. TOT_RAINnew.NE.0.) THEN - DUM=TOT_RAINnew/TOT_RAIN - IF (DUM .LT. TOLER) TOT_RAINnew=0. - ENDIF - IF (TOT_RAINnew .LE. CLIMIT) THEN - TOT_RAINnew=0. - VRAIN2=0. - QRnew=0. - ARAINnew=0. - ELSE - ! - !--- 1st guess time-averaged rain rate at bottom of grid box - ! - RR=TOT_RAINnew/(DTPH*GAMMAR) - ! - !--- Use same algorithm as above for calculating mean drop diameter - ! (IDR, in microns), which is used to estimate the time-averaged - ! fall speed of rain drops at the bottom of the grid layer. This - ! isn't perfect, but the alternative is solving a transcendental - ! equation that is numerically inefficient and nasty to program - ! (coded in earlier versions of GSMCOLUMN prior to 8-22-01). - ! - IF (RR .LE. RR_DRmin) THEN - IDR=MDRmin - ELSE IF (RR .LE. RR_DR1) THEN - IDR=INT( 1.123E3*RR**.1947 + .5 ) - IDR=MAX( MDRmin, MIN(IDR, MDR1) ) - ELSE IF (RR .LE. RR_DR2) THEN - IDR=INT( 1.225E3*RR**.2017 + .5 ) - IDR=MAX( MDR1, MIN(IDR, MDR2) ) - ELSE IF (RR .LE. RR_DR3) THEN - IDR=INT( 1.3006E3*RR**.2083 + .5 ) - IDR=MAX( MDR2, MIN(IDR, MDR3) ) - ELSE IF (RR .LE. RR_DRmax) THEN - IDR=INT( 1.355E3*RR**.2144 + .5 ) - IDR=MAX( MDR3, MIN(IDR, MDRmax) ) - ELSE - IDR=MDRmax - ENDIF ! End IF (RR .LE. RR_DRmin) - VRAIN2=GAMMAR*VRAIN(IDR) - QRnew=TOT_RAINnew/(THICK+BLDTRH*VRAIN2) - IF (QRnew .LE. EPSQ) QRnew=0. - IF (QR.GT.0. .AND. QRnew.NE.0.) THEN - DUM=QRnew/QR - IF (DUM .LT. TOLER) QRnew=0. - ENDIF - ARAINnew=BLDTRH*VRAIN2*QRnew - IF (ARAIN.GT.0. .AND. ARAINnew.NE.0.) THEN - DUM=ARAINnew/ARAIN - IF (DUM .LT. TOLER) ARAINnew=0. - ENDIF - ENDIF -! - WCnew=QWnew+QRnew+QInew -! -!---------------------------------------------------------------------- -!-------------- Begin debugging & verification ------------------------ -!---------------------------------------------------------------------- -! -!--- QT, QTnew - total water (vapor & condensate) before & after microphysics, resp. -! - - - QT=THICK*(WV+WC)+ARAIN+ASNOW - QTnew=THICK*(WVnew+WCnew)+ARAINnew+ASNOWnew - BUDGET=QT-QTnew -! -!--- Additional check on budget preservation, accounting for truncation effects -! - DBG_logical=.FALSE. -! DUM=ABS(BUDGET) -! IF (DUM .GT. TOLER) THEN -! DUM=DUM/MIN(QT, QTnew) -! IF (DUM .GT. TOLER) DBG_logical=.TRUE. -! ENDIF -!! -! DUM=(RHgrd+.001)*QSInew -! IF ( (QWnew.GT.EPSQ) .OR. QRnew.GT.EPSQ .OR. WVnew.GT.DUM) -! & .AND. TC.LT.T_ICE ) DBG_logical=.TRUE. -! -! IF (TC.GT.5. .AND. QInew.GT.EPSQ) DBG_logical=.TRUE. -! - IF ((WVnew.LT.EPSQ .OR. DBG_logical) .AND. PRINT_diag) THEN - ! - WRITE(6,"(/2(a,i4),2(a,i2))") '{} i=',I_index,' j=',J_index,& - & ' L=',L,' LSFC=',LSFC - ! - ESW=1000.*FPVS0(Tnew) - QSWnew=EPS*ESW/(PP-ESW) - IF (TC.LT.0. .OR. Tnew .LT. 0.) THEN - ESI=1000.*FPVS(Tnew) - QSInew=EPS*ESI/(PP-ESI) - ELSE - QSI=QSW - QSInew=QSWnew - ENDIF - WSnew=QSInew - WRITE(6,"(4(a12,g11.4,1x))") & - & '{} TCold=',TC,'TCnew=',Tnew-T0C,'P=',.01*PP,'RHO=',RHO, & - & '{} THICK=',THICK,'RHold=',WV/WS,'RHnew=',WVnew/WSnew, & - & 'RHgrd=',RHgrd, & - & '{} RHWold=',WV/QSW,'RHWnew=',WVnew/QSWnew,'RHIold=',WV/QSI, & - & 'RHInew=',WVnew/QSInew, & - & '{} QSWold=',QSW,'QSWnew=',QSWnew,'QSIold=',QSI,'QSInew=',QSInew, & - & '{} WSold=',WS,'WSnew=',WSnew,'WVold=',WV,'WVnew=',WVnew, & - & '{} WCold=',WC,'WCnew=',WCnew,'QWold=',QW,'QWnew=',QWnew, & - & '{} QIold=',QI,'QInew=',QInew,'QRold=',QR,'QRnew=',QRnew, & - & '{} ARAINold=',ARAIN,'ARAINnew=',ARAINnew,'ASNOWold=',ASNOW, & - & 'ASNOWnew=',ASNOWnew, & - & '{} TOT_RAIN=',TOT_RAIN,'TOT_RAINnew=',TOT_RAINnew, & - & 'TOT_ICE=',TOT_ICE,'TOT_ICEnew=',TOT_ICEnew, & - & '{} BUDGET=',BUDGET,'QTold=',QT,'QTnew=',QTnew - ! - WRITE(6,"(4(a12,g11.4,1x))") & - & '{} DELT=',DELT,'DELV=',DELV,'DELW=',DELW,'DELI=',DELI, & - & '{} DELR=',DELR,'PCOND=',PCOND,'PIDEP=',PIDEP,'PIEVP=',PIEVP, & - & '{} PICND=',PICND,'PREVP=',PREVP,'PRAUT=',PRAUT,'PRACW=',PRACW, & - & '{} PIACW=',PIACW,'PIACWI=',PIACWI,'PIACWR=',PIACWR,'PIMLT=', & - & PIMLT, & - & '{} PIACR=',PIACR - ! - IF (ICE_logical) WRITE(6,"(4(a12,g11.4,1x))") & - & '{} RimeF1=',RimeF1,'GAMMAS=',GAMMAS,'VrimeF=',VrimeF, & - & 'VSNOW=',VSNOW, & - & '{} INDEXS=',FLOAT(INDEXS),'FLARGE=',FLARGE,'FSMALL=',FSMALL, & - & 'FLIMASS=',FLIMASS, & - & '{} XSIMASS=',XSIMASS,'XLIMASS=',XLIMASS,'QLICE=',QLICE, & - & 'QTICE=',QTICE, & - & '{} NLICE=',NLICE,'NSmICE=',NSmICE,'PILOSS=',PILOSS, & - & 'EMAIRI=',EMAIRI, & - & '{} RimeF=',RimeF - ! - IF (TOT_RAIN.GT.0. .OR. TOT_RAINnew.GT.0.) & - & WRITE(6,"(4(a12,g11.4,1x))") & - & '{} INDEXR1=',FLOAT(INDEXR1),'INDEXR=',FLOAT(INDEXR), & - & 'GAMMAR=',GAMMAR,'N0r=',N0r, & - & '{} VRAIN1=',VRAIN1,'VRAIN2=',VRAIN2,'QTRAIN=',QTRAIN,'RQR=',RQR, & - & '{} PRLOSS=',PRLOSS,'VOLR1=',THICK+BLDTRH*VRAIN1, & - & 'VOLR2=',THICK+BLDTRH*VRAIN2 - ! - IF (PRAUT .GT. 0.) WRITE(6,"(a12,g11.4,1x)") '{} QW0=',QW0 - ! - IF (PRACW .GT. 0.) WRITE(6,"(a12,g11.4,1x)") '{} FWR=',FWR - ! - IF (PIACR .GT. 0.) WRITE(6,"(a12,g11.4,1x)") '{} FIR=',FIR - ! - DUM=PIMLT+PICND-PREVP-PIEVP - IF (DUM.GT.0. .or. DWVi.NE.0.) & - & WRITE(6,"(4(a12,g11.4,1x))") & - & '{} TFACTOR=',TFACTOR,'DYNVIS=',DYNVIS, & - & 'THERM_CON=',THERM_COND,'DIFFUS=',DIFFUS - ! - IF (PREVP .LT. 0.) WRITE(6,"(4(a12,g11.4,1x))") & - & '{} RFACTOR=',RFACTOR,'ABW=',ABW,'VENTR=',VENTR,'CREVP=',CREVP, & - & '{} DWVr=',DWVr,'DENOMW=',DENOMW - ! - IF (PIDEP.NE.0. .AND. DWVi.NE.0.) & - & WRITE(6,"(4(a12,g11.4,1x))") & - & '{} DWVi=',DWVi,'DENOMI=',DENOMI,'PIDEP_max=',PIDEP_max, & - & 'SFACTOR=',SFACTOR, & - & '{} ABI=',ABI,'VENTIL=',VENTIL,'VENTIL1=',VENTI1(INDEXS), & - & 'VENTIL2=',SFACTOR*VENTI2(INDEXS), & - & '{} VENTIS=',VENTIS,'DIDEP=',DIDEP - ! - IF (PIDEP.GT.0. .AND. PCOND.NE.0.) & - & WRITE(6,"(4(a12,g11.4,1x))") & - & '{} DENOMW=',DENOMW,'DENOMWI=',DENOMWI,'DENOMF=',DENOMF, & - & 'DUM2=',PCOND-PIACW - ! - IF (FWS .GT. 0.) WRITE(6,"(4(a12,g11.4,1x))") & - & '{} FWS=',FWS - ! - DUM=PIMLT+PICND-PIEVP - IF (DUM.GT. 0.) WRITE(6,"(4(a12,g11.4,1x))") & - & '{} SFACTOR=',SFACTOR,'VENTIL=',VENTIL,'VENTIL1=',VENTI1(INDEXS), & - & 'VENTIL2=',SFACTOR*VENTI2(INDEXS), & - & '{} AIEVP=',AIEVP,'DIEVP=',DIEVP,'QSW0=',QSW0,'DWV0=',DWV0 - ! - ENDIF - - -! -!----------------------------------------------------------------------- -!--------------- Water budget statistics & maximum values -------------- -!----------------------------------------------------------------------- -! - IF (PRINT_diag) THEN - ITdx=MAX( ITLO, MIN( INT(Tnew-T0C), ITHI ) ) - IF (QInew .GT. EPSQ) NSTATS(ITdx,1)=NSTATS(ITdx,1)+1 - IF (QInew.GT.EPSQ .AND. QRnew+QWnew.GT.EPSQ) & - & NSTATS(ITdx,2)=NSTATS(ITdx,2)+1 - IF (QWnew .GT. EPSQ) NSTATS(ITdx,3)=NSTATS(ITdx,3)+1 - IF (QRnew .GT. EPSQ) NSTATS(ITdx,4)=NSTATS(ITdx,4)+1 - ! - QMAX(ITdx,1)=MAX(QMAX(ITdx,1), QInew) - QMAX(ITdx,2)=MAX(QMAX(ITdx,2), QWnew) - QMAX(ITdx,3)=MAX(QMAX(ITdx,3), QRnew) - QMAX(ITdx,4)=MAX(QMAX(ITdx,4), ASNOWnew) - QMAX(ITdx,5)=MAX(QMAX(ITdx,5), ARAINnew) - QTOT(ITdx,1)=QTOT(ITdx,1)+QInew*THICK - QTOT(ITdx,2)=QTOT(ITdx,2)+QWnew*THICK - QTOT(ITdx,3)=QTOT(ITdx,3)+QRnew*THICK - ! - QTOT(ITdx,4)=QTOT(ITdx,4)+PCOND*THICK - QTOT(ITdx,5)=QTOT(ITdx,5)+PICND*THICK - QTOT(ITdx,6)=QTOT(ITdx,6)+PIEVP*THICK - QTOT(ITdx,7)=QTOT(ITdx,7)+PIDEP*THICK - QTOT(ITdx,8)=QTOT(ITdx,8)+PREVP*THICK - QTOT(ITdx,9)=QTOT(ITdx,9)+PRAUT*THICK - QTOT(ITdx,10)=QTOT(ITdx,10)+PRACW*THICK - QTOT(ITdx,11)=QTOT(ITdx,11)+PIMLT*THICK - QTOT(ITdx,12)=QTOT(ITdx,12)+PIACW*THICK - QTOT(ITdx,13)=QTOT(ITdx,13)+PIACWI*THICK - QTOT(ITdx,14)=QTOT(ITdx,14)+PIACWR*THICK - QTOT(ITdx,15)=QTOT(ITdx,15)+PIACR*THICK - ! - QTOT(ITdx,16)=QTOT(ITdx,16)+(WVnew-WV)*THICK - QTOT(ITdx,17)=QTOT(ITdx,17)+(QWnew-QW)*THICK - QTOT(ITdx,18)=QTOT(ITdx,18)+(QInew-QI)*THICK - QTOT(ITdx,19)=QTOT(ITdx,19)+(QRnew-QR)*THICK - QTOT(ITdx,20)=QTOT(ITdx,20)+(ARAINnew-ARAIN) - QTOT(ITdx,21)=QTOT(ITdx,21)+(ASNOWnew-ASNOW) - IF (QInew .GT. 0.) & - & QTOT(ITdx,22)=QTOT(ITdx,22)+QInew*THICK/RimeF - ! - ENDIF -! -!---------------------------------------------------------------------- -!------------------------- Update arrays ------------------------------ -!---------------------------------------------------------------------- -! - - - T_col(L)=Tnew ! Updated temperature -! - QV_col(L)=max(EPSQ, WVnew/(1.+WVnew)) ! Updated specific humidity - WC_col(L)=max(EPSQ, WCnew) ! Updated total condensate mixing ratio - QI_col(L)=max(EPSQ, QInew) ! Updated ice mixing ratio - QR_col(L)=max(EPSQ, QRnew) ! Updated rain mixing ratio - QW_col(L)=max(EPSQ, QWnew) ! Updated cloud water mixing ratio - RimeF_col(L)=RimeF ! Updated rime factor - ASNOW=ASNOWnew ! Updated accumulated snow - ARAIN=ARAINnew ! Updated accumulated rain -! -!####################################################################### -! -10 CONTINUE ! ##### End "L" loop through model levels ##### - - -! -!####################################################################### -! -!----------------------------------------------------------------------- -!--------------------------- Return to GSMDRIVE ----------------------- -!----------------------------------------------------------------------- -! - CONTAINS -!####################################################################### -!--------- Produces accurate calculation of cloud condensation --------- -!####################################################################### -! - REAL FUNCTION CONDENSE (PP, QW, TK, WV) -! -!--------------------------------------------------------------------------------- -!------ The Asai (1965) algorithm takes into consideration the release of ------ -!------ latent heat in increasing the temperature & in increasing the ------ -!------ saturation mixing ratio (following the Clausius-Clapeyron eqn.). ------ -!--------------------------------------------------------------------------------- -! - IMPLICIT NONE -! - INTEGER, PARAMETER :: HIGH_PRES=Selected_Real_Kind(15) - REAL (KIND=HIGH_PRES), PARAMETER :: & - & RHLIMIT=.001, RHLIMIT1=-RHLIMIT - REAL (KIND=HIGH_PRES) :: COND, SSAT, WCdum -! - REAL,INTENT(IN) :: QW,PP,WV,TK - REAL WVdum,Tdum,XLV2,DWV,WS,ESW,XLV1,XLV -integer nsteps -! -!----------------------------------------------------------------------- -! -!--- LV (T) is from Bolton (JAS, 1980) -! - XLV=3.148E6-2370.*TK - XLV1=XLV*RCP - XLV2=XLV*XLV*RCPRV - Tdum=TK - WVdum=WV - WCdum=QW - ESW=1000.*FPVS0(Tdum) ! Saturation vapor press w/r/t water - WS=RHgrd*EPS*ESW/(PP-ESW) ! Saturation mixing ratio w/r/t water - DWV=WVdum-WS ! Deficit grid-scale water vapor mixing ratio - SSAT=DWV/WS ! Supersaturation ratio - CONDENSE=0. -nsteps = 0 - DO WHILE ((SSAT.LT.RHLIMIT1 .AND. WCdum.GT.EPSQ) & - & .OR. SSAT.GT.RHLIMIT) - nsteps = nsteps + 1 - COND=DWV/(1.+XLV2*WS/(Tdum*Tdum)) ! Asai (1965, J. Japan) - COND=MAX(COND, -WCdum) ! Limit cloud water evaporation - Tdum=Tdum+XLV1*COND ! Updated temperature - WVdum=WVdum-COND ! Updated water vapor mixing ratio - WCdum=WCdum+COND ! Updated cloud water mixing ratio - CONDENSE=CONDENSE+COND ! Total cloud water condensation - ESW=1000.*FPVS0(Tdum) ! Updated saturation vapor press w/r/t water - WS=RHgrd*EPS*ESW/(PP-ESW) ! Updated saturation mixing ratio w/r/t water - DWV=WVdum-WS ! Deficit grid-scale water vapor mixing ratio - SSAT=DWV/WS ! Grid-scale supersaturation ratio - ENDDO -! - END FUNCTION CONDENSE -! -!####################################################################### -!---------------- Calculate ice deposition at T betah=0.5*beta=-.46*0.5=-0.23; cn0=1.e-6 -!c if ( itaobraun.eq.0 ) --> betah=0.5*beta=-.6*0.5=-0.30; cn0=1.e-8 - itaobraun = 1 - -!c ice2 = 0 for 3 ice --- ice, snow and graupel/hail -!c ice2 = 1 for 2 ice --- ice and snow only -!c ice2 = 2 for 2 ice --- ice and graupel only, use ihail = 0 only -!c ice2 = 3 for 0 ice --- no ice, warm only - -! if (ice2 .eq. 2) ihail = 0 - - i24h=nint(86400./dt_in) - if (mod(itimestep,i24h).eq.1) then - write(6,*) 'ihail=',ihail,' ice2=',ice2 - if (ice2.eq.0) then - write(6,*) 'Running 3-ice scheme in GSFCGCE with' - if (ihail.eq.0) then - write(6,*) ' ice, snow and graupel' - else if (ihail.eq.1) then - write(6,*) ' ice, snow and hail' - else - write(6,*) 'ihail has to be either 1 or 0' - stop - endif !ihail - else if (ice2.eq.1) then - write(6,*) 'Running 2-ice scheme in GSFCGCE with' - write(6,*) ' ice and snow' - else if (ice2.eq.2) then - write(6,*) 'Running 2-ice scheme in GSFCGCE with' - write(6,*) ' ice and graupel' - else if (ice2.eq.3) then - write(6,*) 'Running warm rain only scheme in GSFCGCE without any ice' - else - write(6,*) 'gsfcgce_2ice in namelist.input has to be 0, 1, 2, or 3' - stop - endif !ice2 - endif !itimestep - -!c new_ice_sat = 0, 1 or 2 - new_ice_sat = 2 - -!c istatmin - istatmin = 180 - -!c id = 0 without in-line staticstics -!c id = 1 with in-line staticstics - id = 0 - -!c ibud = 0 no calculation of dth, dqv, dqrest and dqall -!c ibud = 1 yes - ibud = 0 - -!jjs dt=dt_in -!jjs rhoe_s=1.29 -! -! IF (P_QI .lt. P_FIRST_SCALAR .or. P_QS .lt. P_FIRST_SCALAR) THEN -! CALL wrf_error_fatal3 ( "module_mp_lin.b" , 130 , 'module_mp_lin: Improper use of Lin et al scheme; no ice phase. Please chose another one.') -! ENDIF - -! calculte fallflux and precipiation in MKS system - - call fall_flux(dt_in, qr, qi, qs, qg, p, & - rho, z, dz8w, ht, rainnc, & - rainncv, grav,itimestep, & - rhowater, rhosnow, & - snownc, snowncv, sr, & - graupelnc, graupelncv, & - ihail, ice2, & - ims,ime, jms,jme, kms,kme, & ! memory dims - its,ite, jts,jte, kts,kte ) ! tile dims -!----------------------------------------------------------------------- - -!c set up constants used internally in GCE - - call consat_s (ihail, itaobraun) - - -!c Negative values correction - - iskip = 1 - - if (iskip.eq.0) then - call negcor(qv,rho,dz8w,ims,ime,jms,jme,kms,kme, & - itimestep,1, & - its,ite,jts,jte,kts,kte) - call negcor(ql,rho,dz8w,ims,ime,jms,jme,kms,kme, & - itimestep,2, & - its,ite,jts,jte,kts,kte) - call negcor(qr,rho,dz8w,ims,ime,jms,jme,kms,kme, & - itimestep,3, & - its,ite,jts,jte,kts,kte) - call negcor(qi,rho,dz8w,ims,ime,jms,jme,kms,kme, & - itimestep,4, & - its,ite,jts,jte,kts,kte) - call negcor(qs,rho,dz8w,ims,ime,jms,jme,kms,kme, & - itimestep,5, & - its,ite,jts,jte,kts,kte) - call negcor(qg,rho,dz8w,ims,ime,jms,jme,kms,kme, & - itimestep,6, & - its,ite,jts,jte,kts,kte) -! else if (mod(itimestep,i24h).eq.1) then -! print *,'no neg correction in mp at timestep=',itimestep - endif ! iskip - -!c microphysics in GCE - - call SATICEL_S( dt_in, IHAIL, itaobraun, ICE2, istatmin, & - new_ice_sat, id, & -! th, th_old, qv, ql, qr, & - th, qv, ql, qr, & - qi, qs, qg, & -! qvold, qlold, qrold, & -! qiold, qsold, qgold, & - rho, pii, p, itimestep, & - ids,ide, jds,jde, kds,kde, & ! domain dims - ims,ime, jms,jme, kms,kme, & ! memory dims - its,ite, jts,jte, kts,kte & ! tile dims - ) - - END SUBROUTINE gsfcgce - -!----------------------------------------------------------------------- - SUBROUTINE fall_flux ( dt, qr, qi, qs, qg, p, & - rho, z, dz8w, topo, rainnc, & - rainncv, grav, itimestep, & - rhowater, rhosnow, & - snownc, snowncv, sr, & - graupelnc, graupelncv, & - ihail, ice2, & - ims,ime, jms,jme, kms,kme, & ! memory dims - its,ite, jts,jte, kts,kte ) ! tile dims -!----------------------------------------------------------------------- -! adopted from Jiun-Dar Chern's codes for Purdue Regional Model -! adopted by Jainn J. Shi, 6/10/2005 -!----------------------------------------------------------------------- - - IMPLICIT NONE - INTEGER, INTENT(IN ) :: ihail, ice2, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - INTEGER, INTENT(IN ) :: itimestep - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(INOUT) :: qr, qi, qs, qg - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(INOUT) :: rainnc, rainncv, & - snownc, snowncv, sr, & - graupelnc, graupelncv - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: rho, z, dz8w, p - - REAL, INTENT(IN ) :: dt, grav, rhowater, rhosnow - - - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(IN ) :: topo - -! temperary vars - - REAL, DIMENSION( kts:kte ) :: sqrhoz - REAL :: tmp1, term0 - REAL :: pptrain, pptsnow, & - pptgraul, pptice - REAL, DIMENSION( kts:kte ) :: qrz, qiz, qsz, qgz, & - zz, dzw, prez, rhoz, & - orhoz - - - INTEGER :: k, i, j -! - - REAL, DIMENSION( kts:kte ) :: vtr, vts, vtg, vti - - REAL :: dtb, pi, consta, constc, gambp4, & - gamdp4, gam4pt5, gam4bbar - -! Lin - REAL , PARAMETER :: xnor = 8.0e6 -! REAL , PARAMETER :: xnos = 3.0e6 - REAL , PARAMETER :: xnos = 1.6e7 ! Tao's value - REAL , PARAMETER :: & -! constb = 0.8, constd = 0.25, o6 = 1./6., & - constb = 0.8, constd = 0.11, o6 = 1./6., & - cdrag = 0.6 -! Lin -! REAL , PARAMETER :: xnoh = 4.0e4 - REAL , PARAMETER :: xnoh = 2.0e5 ! Tao's value - REAL , PARAMETER :: rhohail = 917. - -! Hobbs - REAL , PARAMETER :: xnog = 4.0e6 - REAL , PARAMETER :: rhograul = 400. - REAL , PARAMETER :: abar = 19.3, bbar = 0.37, & - p0 = 1.0e5 - - REAL , PARAMETER :: rhoe_s = 1.29 - -! for terminal velocity flux - INTEGER :: min_q, max_q - REAL :: t_del_tv, del_tv, flux, fluxin, fluxout ,tmpqrz - LOGICAL :: notlast - -! if (itimestep.eq.1) then -! write(6, *) 'in fall_flux' -! write(6, *) 'ims=', ims, ' ime=', ime -! write(6, *) 'jms=', jms, ' jme=', jme -! write(6, *) 'kms=', kms, ' kme=', kme -! write(6, *) 'its=', its, ' ite=', ite -! write(6, *) 'jts=', jts, ' jte=', jte -! write(6, *) 'kts=', kts, ' kte=', kte -! write(6, *) 'dt=', dt -! write(6, *) 'ihail=', ihail -! write(6, *) 'ICE2=', ICE2 -! write(6, *) 'dt=', dt -! endif - -!----------------------------------------------------------------------- -! This program calculates precipitation fluxes due to terminal velocities. -!----------------------------------------------------------------------- - - dtb=dt - pi=acos(-1.) - consta=2115.0*0.01**(1-constb) -! constc=152.93*0.01**(1-constd) - constc=78.63*0.01**(1-constd) - -! Gamma function - gambp4=ggamma(constb+4.) - gamdp4=ggamma(constd+4.) - gam4pt5=ggamma(4.5) - gam4bbar=ggamma(4.+bbar) - -!*********************************************************************** -! Calculate precipitation fluxes due to terminal velocities. -!*********************************************************************** -! -!- Calculate termianl velocity (vt?) of precipitation q?z -!- Find maximum vt? to determine the small delta t - - j_loop: do j = jts, jte - i_loop: do i = its, ite - - pptrain = 0. - pptsnow = 0. - pptgraul = 0. - pptice = 0. - - do k = kts, kte - qrz(k)=qr(i,k,j) - rhoz(k)=rho(i,k,j) - orhoz(k)=1./rhoz(k) - prez(k)=p(i,k,j) - sqrhoz(k)=sqrt(rhoe_s/rhoz(k)) - zz(k)=z(i,k,j) - dzw(k)=dz8w(i,k,j) - enddo !k - - DO k = kts, kte - qiz(k)=qi(i,k,j) - ENDDO - - DO k = kts, kte - qsz(k)=qs(i,k,j) - ENDDO - - IF (ice2 .eq. 0) THEN - DO k = kts, kte - qgz(k)=qg(i,k,j) - ENDDO - ELSE - DO k = kts, kte - qgz(k)=0. - ENDDO - ENDIF - - -! -!-- rain -! - t_del_tv=0. - del_tv=dtb - notlast=.true. - DO while (notlast) -! - min_q=kte - max_q=kts-1 -! - do k=kts,kte-1 - if (qrz(k) .gt. 1.0e-8) then - min_q=min0(min_q,k) - max_q=max0(max_q,k) - tmp1=sqrt(pi*rhowater*xnor/rhoz(k)/qrz(k)) - tmp1=sqrt(tmp1) - vtr(k)=consta*gambp4*sqrhoz(k)/tmp1**constb - vtr(k)=vtr(k)/6. - if (k .eq. 1) then - del_tv=amin1(del_tv,0.9*(zz(k)-topo(i,j))/vtr(k)) - else - del_tv=amin1(del_tv,0.9*(zz(k)-zz(k-1))/vtr(k)) - endif - else - vtr(k)=0. - endif - enddo - - if (max_q .ge. min_q) then -! -!- Check if the summation of the small delta t >= big delta t -! (t_del_tv) (del_tv) (dtb) - - t_del_tv=t_del_tv+del_tv -! - if ( t_del_tv .ge. dtb ) then - notlast=.false. - del_tv=dtb+del_tv-t_del_tv - endif - -! use small delta t to calculate the qrz flux -! termi is the qrz flux pass in the grid box through the upper boundary -! termo is the qrz flux pass out the grid box through the lower boundary -! - fluxin=0. - do k=max_q,min_q,-1 - fluxout=rhoz(k)*vtr(k)*qrz(k) - flux=(fluxin-fluxout)/rhoz(k)/dzw(k) -! tmpqrz=qrz(k) - qrz(k)=qrz(k)+del_tv*flux - qrz(k)=amax1(0.,qrz(k)) - qr(i,k,j)=qrz(k) - fluxin=fluxout - enddo - if (min_q .eq. 1) then - pptrain=pptrain+fluxin*del_tv - else - qrz(min_q-1)=qrz(min_q-1)+del_tv* & - fluxin/rhoz(min_q-1)/dzw(min_q-1) - qr(i,min_q-1,j)=qrz(min_q-1) - endif -! - else - notlast=.false. - endif - ENDDO - -! -!-- snow -! - t_del_tv=0. - del_tv=dtb - notlast=.true. - - DO while (notlast) -! - min_q=kte - max_q=kts-1 -! - do k=kts,kte-1 - if (qsz(k) .gt. 1.0e-8) then - min_q=min0(min_q,k) - max_q=max0(max_q,k) - tmp1=sqrt(pi*rhosnow*xnos/rhoz(k)/qsz(k)) - tmp1=sqrt(tmp1) - vts(k)=constc*gamdp4*sqrhoz(k)/tmp1**constd - vts(k)=vts(k)/6. - if (k .eq. 1) then - del_tv=amin1(del_tv,0.9*(zz(k)-topo(i,j))/vts(k)) - else - del_tv=amin1(del_tv,0.9*(zz(k)-zz(k-1))/vts(k)) - endif - else - vts(k)=0. - endif - enddo - - if (max_q .ge. min_q) then -! -! -!- Check if the summation of the small delta t >= big delta t -! (t_del_tv) (del_tv) (dtb) - - t_del_tv=t_del_tv+del_tv - - if ( t_del_tv .ge. dtb ) then - notlast=.false. - del_tv=dtb+del_tv-t_del_tv - endif - -! use small delta t to calculate the qsz flux -! termi is the qsz flux pass in the grid box through the upper boundary -! termo is the qsz flux pass out the grid box through the lower boundary -! - fluxin=0. - do k=max_q,min_q,-1 - fluxout=rhoz(k)*vts(k)*qsz(k) - flux=(fluxin-fluxout)/rhoz(k)/dzw(k) - qsz(k)=qsz(k)+del_tv*flux - qsz(k)=amax1(0.,qsz(k)) - qs(i,k,j)=qsz(k) - fluxin=fluxout - enddo - if (min_q .eq. 1) then - pptsnow=pptsnow+fluxin*del_tv - else - qsz(min_q-1)=qsz(min_q-1)+del_tv* & - fluxin/rhoz(min_q-1)/dzw(min_q-1) - qs(i,min_q-1,j)=qsz(min_q-1) - endif -! - else - notlast=.false. - endif - - ENDDO - -! -! ice2=0 --- with hail/graupel -! ice2=1 --- without hail/graupel -! - if (ice2.eq.0) then -! -!-- If IHAIL=1, use hail. -!-- If IHAIL=0, use graupel. -! -! if (ihail .eq. 1) then -! xnog = xnoh -! rhograul = rhohail -! endif - - t_del_tv=0. - del_tv=dtb - notlast=.true. -! - DO while (notlast) -! - min_q=kte - max_q=kts-1 -! - do k=kts,kte-1 - if (qgz(k) .gt. 1.0e-8) then - if (ihail .eq. 1) then -! for hail, based on Lin et al (1983) - min_q=min0(min_q,k) - max_q=max0(max_q,k) - tmp1=sqrt(pi*rhohail*xnoh/rhoz(k)/qgz(k)) - tmp1=sqrt(tmp1) - term0=sqrt(4.*grav*rhohail/3./rhoz(k)/cdrag) - vtg(k)=gam4pt5*term0*sqrt(1./tmp1) - vtg(k)=vtg(k)/6. - if (k .eq. 1) then - del_tv=amin1(del_tv,0.9*(zz(k)-topo(i,j))/vtg(k)) - else - del_tv=amin1(del_tv,0.9*(zz(k)-zz(k-1))/vtg(k)) - endif !k - else -! added by JJS -! for graupel, based on RH (1984) - min_q=min0(min_q,k) - max_q=max0(max_q,k) - tmp1=sqrt(pi*rhograul*xnog/rhoz(k)/qgz(k)) - tmp1=sqrt(tmp1) - tmp1=tmp1**bbar - tmp1=1./tmp1 - term0=abar*gam4bbar/6. - vtg(k)=term0*tmp1*(p0/prez(k))**0.4 - if (k .eq. 1) then - del_tv=amin1(del_tv,0.9*(zz(k)-topo(i,j))/vtg(k)) - else - del_tv=amin1(del_tv,0.9*(zz(k)-zz(k-1))/vtg(k)) - endif !k - endif !ihail - else - vtg(k)=0. - endif !qgz - enddo !k - - if (max_q .ge. min_q) then -! -! -!- Check if the summation of the small delta t >= big delta t -! (t_del_tv) (del_tv) (dtb) - - t_del_tv=t_del_tv+del_tv - - if ( t_del_tv .ge. dtb ) then - notlast=.false. - del_tv=dtb+del_tv-t_del_tv - endif - -! use small delta t to calculate the qgz flux -! termi is the qgz flux pass in the grid box through the upper boundary -! termo is the qgz flux pass out the grid box through the lower boundary -! - fluxin=0. - do k=max_q,min_q,-1 - fluxout=rhoz(k)*vtg(k)*qgz(k) - flux=(fluxin-fluxout)/rhoz(k)/dzw(k) - qgz(k)=qgz(k)+del_tv*flux - qgz(k)=amax1(0.,qgz(k)) - qg(i,k,j)=qgz(k) - fluxin=fluxout - enddo - if (min_q .eq. 1) then - pptgraul=pptgraul+fluxin*del_tv - else - qgz(min_q-1)=qgz(min_q-1)+del_tv* & - fluxin/rhoz(min_q-1)/dzw(min_q-1) - qg(i,min_q-1,j)=qgz(min_q-1) - endif -! - else - notlast=.false. - endif -! - ENDDO - ENDIF !ice2 -! -!-- cloud ice (03/21/02) follow Vaughan T.J. Phillips at GFDL -! - - t_del_tv=0. - del_tv=dtb - notlast=.true. -! - DO while (notlast) -! - min_q=kte - max_q=kts-1 -! - do k=kts,kte-1 - if (qiz(k) .gt. 1.0e-8) then - min_q=min0(min_q,k) - max_q=max0(max_q,k) - vti(k)= 3.29 * (rhoz(k)* qiz(k))** 0.16 ! Heymsfield and Donner - if (k .eq. 1) then - del_tv=amin1(del_tv,0.9*(zz(k)-topo(i,j))/vti(k)) - else - del_tv=amin1(del_tv,0.9*(zz(k)-zz(k-1))/vti(k)) - endif - else - vti(k)=0. - endif - enddo - - if (max_q .ge. min_q) then -! -! -!- Check if the summation of the small delta t >= big delta t -! (t_del_tv) (del_tv) (dtb) - - t_del_tv=t_del_tv+del_tv - - if ( t_del_tv .ge. dtb ) then - notlast=.false. - del_tv=dtb+del_tv-t_del_tv - endif - -! use small delta t to calculate the qiz flux -! termi is the qiz flux pass in the grid box through the upper boundary -! termo is the qiz flux pass out the grid box through the lower boundary -! - - fluxin=0. - do k=max_q,min_q,-1 - fluxout=rhoz(k)*vti(k)*qiz(k) - flux=(fluxin-fluxout)/rhoz(k)/dzw(k) - qiz(k)=qiz(k)+del_tv*flux - qiz(k)=amax1(0.,qiz(k)) - qi(i,k,j)=qiz(k) - fluxin=fluxout - enddo - if (min_q .eq. 1) then - pptice=pptice+fluxin*del_tv - else - qiz(min_q-1)=qiz(min_q-1)+del_tv* & - fluxin/rhoz(min_q-1)/dzw(min_q-1) - qi(i,min_q-1,j)=qiz(min_q-1) - endif -! - else - notlast=.false. - endif -! - ENDDO !notlast - -! prnc(i,j)=prnc(i,j)+pptrain -! psnowc(i,j)=psnowc(i,j)+pptsnow -! pgrauc(i,j)=pgrauc(i,j)+pptgraul -! picec(i,j)=picec(i,j)+pptice -! - -! write(6,*) 'i=',i,' j=',j,' ', pptrain, pptsnow, pptgraul, pptice -! call flush(6) - - snowncv(i,j) = pptsnow - snownc(i,j) = snownc(i,j) + pptsnow - graupelncv(i,j) = pptgraul - graupelnc(i,j) = graupelnc(i,j) + pptgraul - RAINNCV(i,j) = pptrain + pptsnow + pptgraul + pptice - RAINNC(i,j) = RAINNC(i,j) + pptrain + pptsnow + pptgraul + pptice - sr(i,j) = 0. - if (RAINNCV(i,j) .gt. 0.) sr(i,j) = (pptsnow + pptgraul + pptice) / RAINNCV(i,j) - - ENDDO i_loop - ENDDO j_loop - -! if (itimestep.eq.6480) then -! write(51,*) 'in the end of fallflux, itimestep=',itimestep -! do j=jts,jte -! do i=its,ite -! if (rainnc(i,j).gt.400.) then -! write(50,*) 'i=',i,' j=',j,' rainnc=',rainnc -! endif -! enddo -! enddo -! endif - - END SUBROUTINE fall_flux - -!---------------------------------------------------------------- - REAL FUNCTION ggamma(X) -!---------------------------------------------------------------- - IMPLICIT NONE -!---------------------------------------------------------------- - REAL, INTENT(IN ) :: x - REAL, DIMENSION(8) :: B - INTEGER ::j, K1 - REAL ::PF, G1TO2 ,TEMP - - DATA B/-.577191652,.988205891,-.897056937,.918206857, & - -.756704078,.482199394,-.193527818,.035868343/ - - PF=1. - TEMP=X - DO 10 J=1,200 - IF (TEMP .LE. 2) GO TO 20 - TEMP=TEMP-1. - 10 PF=PF*TEMP - 100 FORMAT(//,5X,'module_gsfcgce: INPUT TO GAMMA FUNCTION TOO LARGE, X=',E12.5) - ! WRITE(wrf_err_message,100)X - ! CALL wrf_error_fatal(wrf_err_message) - 20 G1TO2=1. - TEMP=TEMP - 1. - DO 30 K1=1,8 - 30 G1TO2=G1TO2 + B(K1)*TEMP**K1 - ggamma=PF*G1TO2 - - END FUNCTION ggamma - -!----------------------------------------------------------------------- -!c Correction of negative values - SUBROUTINE negcor ( X, rho, dz8w, & - ims,ime, jms,jme, kms,kme, & ! memory dims - itimestep, ics, & - its,ite, jts,jte, kts,kte ) ! tile dims -!----------------------------------------------------------------------- - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(INOUT) :: X - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: rho, dz8w - integer, INTENT(IN ) :: itimestep, ics - -!c Local variables -! REAL, DIMENSION( kts:kte ) :: Y1, Y2 - REAL :: A0, A1, A2 - - A1=0. - A2=0. - do k=kts,kte - do j=jts,jte - do i=its,ite - A1=A1+max(X(i,k,j), 0.)*rho(i,k,j)*dz8w(i,k,j) - A2=A2+max(-X(i,k,j), 0.)*rho(i,k,j)*dz8w(i,k,j) - enddo - enddo - enddo - -! A1=0.0 -! A2=0.0 -! do k=kts,kte -! A1=A1+Y1(k) -! A2=A2+Y2(k) -! enddo - - A0=0.0 - - if (A1.NE.0.0.and.A1.GT.A2) then - A0=(A1-A2)/A1 - - if (mod(itimestep,540).eq.0) then - if (ics.eq.1) then - write(61,*) 'kms=',kms,' kme=',kme,' kts=',kts,' kte=',kte - write(61,*) 'jms=',jms,' jme=',jme,' jts=',jts,' jte=',jte - write(61,*) 'ims=',ims,' ime=',ime,' its=',its,' ite=',ite - endif - if (ics.eq.1) then - write(61,*) 'qv timestep=',itimestep - write(61,*) ' A1=',A1,' A2=',A2,' A0=',A0 - else if (ics.eq.2) then - write(61,*) 'ql timestep=',itimestep - write(61,*) ' A1=',A1,' A2=',A2,' A0=',A0 - else if (ics.eq.3) then - write(61,*) 'qr timestep=',itimestep - write(61,*) ' A1=',A1,' A2=',A2,' A0=',A0 - else if (ics.eq.4) then - write(61,*) 'qi timestep=',itimestep - write(61,*) ' A1=',A1,' A2=',A2,' A0=',A0 - else if (ics.eq.5) then - write(61,*) 'qs timestep=',itimestep - write(61,*) ' A1=',A1,' A2=',A2,' A0=',A0 - else if (ics.eq.6) then - write(61,*) 'qg timestep=',itimestep - write(61,*) ' A1=',A1,' A2=',A2,' A0=',A0 - else - write(61,*) 'wrong cloud specieis number' - endif - endif - - do k=kts,kte - do j=jts,jte - do i=its,ite - X(i,k,j)=A0*AMAX1(X(i,k,j), 0.0) - enddo - enddo - enddo - endif - - END SUBROUTINE negcor - - SUBROUTINE consat_s (ihail,itaobraun) - -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -! c -! Tao, W.-K., and J. Simpson, 1989: Modeling study of a tropical c -! squall-type convective line. J. Atmos. Sci., 46, 177-202. c -! c -! Tao, W.-K., J. Simpson and M. McCumber, 1989: An ice-water c -! saturation adjustment. Mon. Wea. Rev., 117, 231-235. c -! c -! Tao, W.-K., and J. Simpson, 1993: The Goddard Cumulus Ensemble c -! Model. Part I: Model description. Terrestrial, Atmospheric and c -! Oceanic Sciences, 4, 35-72. c -! c -! Tao, W.-K., J. Simpson, D. Baker, S. Braun, M.-D. Chou, B. c -! Ferrier,D. Johnson, A. Khain, S. Lang, B. Lynn, C.-L. Shie, c -! D. Starr, C.-H. Sui, Y. Wang and P. Wetzel, 2003: Microphysics, c -! radiation and surface processes in the Goddard Cumulus Ensemble c -! (GCE) model, A Special Issue on Non-hydrostatic Mesoscale c -! Modeling, Meteorology and Atmospheric Physics, 82, 97-137. c -! c -! Lang, S., W.-K. Tao, R. Cifelli, W. Olson, J. Halverson, S. c -! Rutledge, and J. Simpson, 2007: Improving simulations of c -! convective system from TRMM LBA: Easterly and Westerly regimes. c -! J. Atmos. Sci., 64, 1141-1164. c -! c -! Coded by Tao (1989-2003), modified by S. Lang (2006/07) c -! c -! Implemented into WRF by Roger Shi 2006/2007 c -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - -! itaobraun=0 ! see Tao and Simpson (1993) -! itaobraun=1 ! see Tao et al. (2003) - - integer :: itaobraun - real :: cn0 - -!JJS 1/3/2008 vvvvv -!JJS the following common blocks have been moved to the top of -!JJS module_mp_gsfcgce_driver_instat.F -! -! real, dimension (1:31) :: a1, a2 -! data a1/.7939e-7,.7841e-6,.3369e-5,.4336e-5,.5285e-5,.3728e-5, & -! .1852e-5,.2991e-6,.4248e-6,.7434e-6,.1812e-5,.4394e-5,.9145e-5, & -! .1725e-4,.3348e-4,.1725e-4,.9175e-5,.4412e-5,.2252e-5,.9115e-6, & -! .4876e-6,.3473e-6,.4758e-6,.6306e-6,.8573e-6,.7868e-6,.7192e-6, & -! .6513e-6,.5956e-6,.5333e-6,.4834e-6/ -! data a2/.4006,.4831,.5320,.5307,.5319,.5249,.4888,.3894,.4047, & -! .4318,.4771,.5183,.5463,.5651,.5813,.5655,.5478,.5203,.4906, & -! .4447,.4126,.3960,.4149,.4320,.4506,.4483,.4460,.4433,.4413, & -! .4382,.4361/ -!JJS 1/3/2008 ^^^^^ - - -! ****************************************************************** -!JJS - al = 2.5e10 - cp = 1.004e7 - rd1 = 1.e-3 - rd2 = 2.2 -!JJS - cpi=4.*atan(1.) - cpi2=cpi*cpi - grvt=980. - cd1=6.e-1 - cd2=4.*grvt/(3.*cd1) - tca=2.43e3 - dwv=.226 - dva=1.718e-4 - amw=18.016 - ars=8.314e7 - scv=2.2904487 - t0=273.16 - t00=238.16 - alv=2.5e10 - alf=3.336e9 - als=2.8336e10 - avc=alv/cp - afc=alf/cp - asc=als/cp - rw=4.615e6 - cw=4.187e7 - ci=2.093e7 - c76=7.66 - c358=35.86 - c172=17.26939 - c409=4098.026 - c218=21.87456 - c580=5807.695 - c610=6.1078e3 - c149=1.496286e-5 - c879=8.794142 - c141=1.4144354e7 -!*** DEFINE THE COEFFICIENTS USED IN TERMINAL VELOCITY -!*** DEFINE THE DENSITY AND SIZE DISTRIBUTION OF PRECIPITATION -!********** HAIL OR GRAUPEL PARAMETERS ********** - if(ihail .eq. 1) then - roqg=.9 - ag=sqrt(cd2*roqg) - bg=.5 - tng=.002 - else - roqg=.4 - ag=351.2 -! AG=372.3 ! if ice913=1 6/15/02 tao's - bg=.37 - tng=.04 - endif -!********** SNOW PARAMETERS ********** -!ccshie 6/15/02 tao's -! TNS=1. -! TNS=.08 ! if ice913=1, tao's - tns=.16 ! if ice913=0, tao's - roqs=.1 -! AS=152.93 - as=78.63 -! BS=.25 - bs=.11 -!********** RAIN PARAMETERS ********** - aw=2115. - bw=.8 - roqr=1. - tnw=.08 -!***************************************************************** - bgh=.5*bg - bsh=.5*bs - bwh=.5*bw - bgq=.25*bg - bsq=.25*bs - bwq=.25*bw -!**********GAMMA FUNCTION CALCULATIONS************* - ga3b = gammagce(3.+bw) - ga4b = gammagce(4.+bw) - ga6b = gammagce(6.+bw) - ga5bh = gammagce((5.+bw)/2.) - ga3g = gammagce(3.+bg) - ga4g = gammagce(4.+bg) - ga5gh = gammagce((5.+bg)/2.) - ga3d = gammagce(3.+bs) - ga4d = gammagce(4.+bs) - ga5dh = gammagce((5.+bs)/2.) -!CCCCC LIN ET AL., 1983 OR LORD ET AL., 1984 CCCCCCCCCCCCCCCCC - ac1=aw -!JJS - ac2=ag - ac3=as -!JJS - bc1=bw - cc1=as - dc1=bs - zrc=(cpi*roqr*tnw)**0.25 - zsc=(cpi*roqs*tns)**0.25 - zgc=(cpi*roqg*tng)**0.25 - vrc=aw*ga4b/(6.*zrc**bw) - vsc=as*ga4d/(6.*zsc**bs) - vgc=ag*ga4g/(6.*zgc**bg) -! **************************** -! RN1=1.E-3 - rn1=9.4e-15 ! 6/15/02 tao's - bnd1=6.e-4 - rn2=1.e-3 -! BND2=1.25E-3 -! BND2=1.5E-3 ! if ice913=1 6/15/02 tao's - bnd2=2.0e-3 ! if ice913=0 6/15/02 tao's - rn3=.25*cpi*tns*cc1*ga3d - esw=1. - rn4=.25*cpi*esw*tns*cc1*ga3d -! ERI=1. - eri=.1 ! 6/17/02 tao's ice913=0 (not 1) - rn5=.25*cpi*eri*tnw*ac1*ga3b -! AMI=1./(24.*4.19E-10) - ami=1./(24.*6.e-9) ! 6/15/02 tao's - rn6=cpi2*eri*tnw*ac1*roqr*ga6b*ami -! ESR=1. ! also if ice913=1 for tao's - esr=.5 ! 6/15/02 for ice913=0 tao's - rn7=cpi2*esr*tnw*tns*roqs - esr=1. - rn8=cpi2*esr*tnw*tns*roqr - rn9=cpi2*tns*tng*roqs - rn10=2.*cpi*tns - rn101=.31*ga5dh*sqrt(cc1) - rn10a=als*als/rw -!JJS - rn10b=alv/tca - rn10c=ars/(dwv*amw) -!JJS - rn11=2.*cpi*tns/alf - rn11a=cw/alf -! AMI50=1.51e-7 - ami50=3.84e-6 ! 6/15/02 tao's -! AMI40=2.41e-8 - ami40=3.08e-8 ! 6/15/02 tao's - eiw=1. -! UI50=20. - ui50=100. ! 6/15/02 tao's - ri50=2.*5.e-3 - cmn=1.05e-15 - rn12=cpi*eiw*ui50*ri50**2 - - do 10 k=1,31 - y1=1.-aa2(k) - rn13(k)=aa1(k)*y1/(ami50**y1-ami40**y1) - rn12a(k)=rn13(k)/ami50 - rn12b(k)=aa1(k)*ami50**aa2(k) - rn25a(k)=aa1(k)*cmn**aa2(k) - 10 continue - - egw=1. - rn14=.25*cpi*egw*tng*ga3g*ag - egi=.1 - rn15=.25*cpi*egi*tng*ga3g*ag - egi=1. - rn15a=.25*cpi*egi*tng*ga3g*ag - egr=1. - rn16=cpi2*egr*tng*tnw*roqr - rn17=2.*cpi*tng - rn17a=.31*ga5gh*sqrt(ag) - rn17b=cw-ci - rn17c=cw - apri=.66 - bpri=1.e-4 - bpri=0.5*bpri ! 6/17/02 tao's - rn18=20.*cpi2*bpri*tnw*roqr - rn18a=apri - rn19=2.*cpi*tng/alf - rn19a=.31*ga5gh*sqrt(ag) - rn19b=cw/alf -! - rnn191=.78 - rnn192=.31*ga5gh*sqrt(ac2/dva) -! - rn20=2.*cpi*tng - rn20a=als*als/rw - rn20b=.31*ga5gh*sqrt(ag) - bnd3=2.e-3 - rn21=1.e3*1.569e-12/0.15 - erw=1. - rn22=.25*cpi*erw*ac1*tnw*ga3b - rn23=2.*cpi*tnw - rn23a=.31*ga5bh*sqrt(ac1) - rn23b=alv*alv/rw - - -!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!cc -!cc "c0" in routine "consat" (2d), "consatrh" (3d) -!cc if ( itaobraun.eq.1 ) --> betah=0.5*beta=-.46*0.5=-0.23; cn0=1.e-6 -!cc if ( itaobraun.eq.0 ) --> betah=0.5*beta=-.6*0.5=-0.30; cn0=1.e-8 - - if (itaobraun .eq. 0) then - cn0=1.e-8 - beta=-.6 - elseif (itaobraun .eq. 1) then - cn0=1.e-6 - beta=-.46 - endif -!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -! CN0=1.E-6 -! CN0=1.E-8 ! 6/15/02 tao's -! BETA=-.46 -! BETA=-.6 ! 6/15/02 tao's - - rn25=cn0 - rn30a=alv*als*amw/(tca*ars) - rn30b=alv/tca - rn30c=ars/(dwv*amw) - rn31=1.e-17 - - rn32=4.*51.545e-4 -! - rn30=2.*cpi*tng - rnn30a=alv*alv*amw/(tca*ars) -! - rn33=4.*tns - rn331=.65 - rn332=.44*sqrt(ac3/dva)*ga5dh -! - - return - END SUBROUTINE consat_s - - SUBROUTINE saticel_s (dt, ihail, itaobraun, ice2, istatmin, & - new_ice_sat, id, & - ptwrf, qvwrf, qlwrf, qrwrf, & - qiwrf, qswrf, qgwrf, & - rho_mks, pi_mks, p0_mks,itimestep, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte & - ) -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -! c -! Tao, W.-K., and J. Simpson, 1989: Modeling study of a tropical c -! squall-type convective line. J. Atmos. Sci., 46, 177-202. c -! c -! Tao, W.-K., J. Simpson and M. McCumber, 1989: An ice-water c -! saturation adjustment. Mon. Wea. Rev., 117, 231-235. c -! c -! Tao, W.-K., and J. Simpson, 1993: The Goddard Cumulus Ensemble c -! Model. Part I: Model description. Terrestrial, Atmospheric and c -! Oceanic Sciences, 4, 35-72. c -! c -! Tao, W.-K., J. Simpson, D. Baker, S. Braun, M.-D. Chou, B. c -! Ferrier,D. Johnson, A. Khain, S. Lang, B. Lynn, C.-L. Shie, c -! D. Starr, C.-H. Sui, Y. Wang and P. Wetzel, 2003: Microphysics, c -! radiation and surface processes in the Goddard Cumulus Ensemble c -! (GCE) model, A Special Issue on Non-hydrostatic Mesoscale c -! Modeling, Meteorology and Atmospheric Physics, 82, 97-137. c -! c -! Lang, S., W.-K. Tao, R. Cifelli, W. Olson, J. Halverson, S. c -! Rutledge, and J. Simpson, 2007: Improving simulations of c -! convective system from TRMM LBA: Easterly and Westerly regimes. c -! J. Atmos. Sci., 64, 1141-1164. c -! c -! Tao, W.-K., J. J. Shi, S. Lang, C. Peters-Lidard, A. Hou, S. c -! Braun, and J. Simpson, 2007: New, improved bulk-microphysical c -! schemes for studying precipitation processes in WRF. Part I: c -! Comparisons with other schemes. to appear on Mon. Wea. Rev. C -! c -! Coded by Tao (1989-2003), modified by S. Lang (2006/07) c -! c -! Implemented into WRF by Roger Shi 2006/2007 c -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -! -! COMPUTE ICE PHASE MICROPHYSICS AND SATURATION PROCESSES -! - integer, parameter :: nt=2880, nt2=2*nt - -!cc using scott braun's way for pint, pidep computations - integer :: itaobraun,ice2,ihail,new_ice_sat,id,istatmin - integer :: itimestep - real :: tairccri, cn0, dt -!cc - -!JJS common/bxyz/ n,isec,nran,kt1,kt2 -!JJS common/option/ lipps,ijkadv,istatmin,iwater,itoga,imlifting,lin, -!JJS 1 irf,iadvh,irfg,ismg,id - -!JJS common/timestat/ ndt_stat,idq -!JJS common/iice/ new_ice_sat -!JJS common/bt/ dt,d2t,rijl2,dts,f5,rd1,rd2,bound,al,cp,ra,ck,ce,eps, -!JJS 1 psfc,fcor,sec,aminut,rdt - -!JJS the following common blocks have been moved to the top of -!JJS module_mp_gsfcgce_driver_instat.F - -! common/bt/ rd1,rd2,al,cp -! -! -! common/bterv/ zrc,zgc,zsc,vrc,vgc,vsc -! common/size/ tnw,tns,tng,roqs,roqg,roqr -! common/cont/ c38,c358,c610,c149,c879,c172,c409,c76,c218,c580,c141 -! common/b3cs/ ag,bg,as,bs,aw,bw,bgh,bgq,bsh,bsq,bwh,bwq -! common/bsnw/ alv,alf,als,t0,t00,avc,afc,asc,rn1,bnd1,rn2,bnd2, & -! rn3,rn4,rn5,rn6,rn7,rn8,rn9,rn10,rn101,rn10a,rn11,rn11a, & -! rn12,rn12a(31),rn12b(31),rn13(31),rn14,rn15,rn15a,rn16,rn17, & -! rn17a,rn17b,rn17c,rn18,rn18a,rn19,rn19a,rn19b,rn20,rn20a,rn20b, & -! bnd3,rn21,rn22,rn23,rn23a,rn23b,rn25,rn25a(31),rn30a,rn30b, & -! rn30c,rn31,beta,rn32 -! common/rsnw1/ rn10b,rn10c,rnn191,rnn192,rn30,rnn30a,rn33,rn331, & -! rn332 -!JJS - - real, dimension (its:ite,jts:jte,kts:kte) :: fv - real, dimension (its:ite,jts:jte,kts:kte) :: dpt, dqv - real, dimension (its:ite,jts:jte,kts:kte) :: qcl, qrn, & - qci, qcs, qcg -!JJS 10/16/06 vvvv -! real dpt1(ims:ime,jms:jme,kms:kme) -! real dqv1(ims:ime,jms:jme,kms:kme), -! 1 qcl1(ims:ime,jms:jme,kms:kme) -! real qrn1(ims:ime,jms:jme,kms:kme), -! 1 qci1(ims:ime,jms:jme,kms:kme) -! real qcs1(ims:ime,jms:jme,kms:kme), -! 1 qcg1(ims:ime,jms:jme,kms:kme) -!JJS 10/16/06 ^^^^ - -!JJS - - real, dimension (ims:ime, kms:kme, jms:jme) :: ptwrf, qvwrf - real, dimension (ims:ime, kms:kme, jms:jme) :: qlwrf, qrwrf, & - qiwrf, qswrf, qgwrf -!JJS 10/16/06 vvvv -! real ptwrfold(ims:ime, kms:kme, jms:jme) -! real qvwrfold(ims:ime, kms:kme, jms:jme), -! 1 qlwrfold(ims:ime, kms:kme, jms:jme) -! real qrwrfold(ims:ime, kms:kme, jms:jme), -! 1 qiwrfold(ims:ime, kms:kme, jms:jme) -! real qswrfold(ims:ime, kms:kme, jms:jme), -! 1 qgwrfold(ims:ime, kms:kme, jms:jme) -!JJS 10/16/06 ^^^^ - -!JJS in MKS - real, dimension (ims:ime, kms:kme, jms:jme) :: rho_mks - real, dimension (ims:ime, kms:kme, jms:jme) :: pi_mks - real, dimension (ims:ime, kms:kme, jms:jme) :: p0_mks -!JJS -! real, dimension (its:ite,jts:jte,kts:kte) :: ww1 -! real, dimension (its:ite,jts:jte,kts:kte) :: rsw -! real, dimension (its:ite,jts:jte,kts:kte) :: rlw - -!JJS COMMON /BADV/ - real, dimension (its:ite,jts:jte) :: & - vg, zg, & - ps, pg, & - prn, psn, & - pwacs, wgacr, & - pidep, pint, & - qsi, ssi, & - esi, esw, & - qsw, pr, & - ssw, pihom, & - pidw, pimlt, & - psaut, qracs, & - psaci, psacw, & - qsacw, praci, & - pmlts, pmltg, & - asss, y1, y2 -!JJS Y2(its:ite,jts:jte), DDE(NB) - -!JJS COMMON/BSAT/ - real, dimension (its:ite,jts:jte) :: & - praut, pracw, & - psfw, psfi, & - dgacs, dgacw, & - dgaci, dgacr, & - pgacs, wgacs, & - qgacw, wgaci, & - qgacr, pgwet, & - pgaut, pracs, & - psacr, qsacr, & - pgfr, psmlt, & - pgmlt, psdep, & - pgdep, piacr, & - y5, scv, & - tca, dwv, & - egs, y3, & - y4, ddb - -!JJS COMMON/BSAT1/ - real, dimension (its:ite,jts:jte) :: & - pt, qv, & - qc, qr, & - qi, qs, & - qg, tair, & - tairc, rtair, & - dep, dd, & - dd1, qvs, & - dm, rq, & - rsub1, col, & - cnd, ern, & - dlt1, dlt2, & - dlt3, dlt4, & - zr, vr, & - zs, vs, & - pssub, & - pgsub, dda - -!JJS COMMON/B5/ - real, dimension (its:ite,jts:jte,kts:kte) :: rho - real, dimension (kts:kte) :: & - tb, qb, rho1, & - ta, qa, ta1, qa1, & - coef, z1, z2, z3, & - am, am1, ub, vb, & - wb, ub1, vb1, rrho, & - rrho1, wbx - -!JJS COMMON/B6/ - real, dimension (its:ite,jts:jte,kts:kte) :: p0, pi, f0 - real, dimension (kts:kte) :: & - fd, fe, & - st, sv, & - sq, sc, & - se, sqa - -!JJS COMMON/BRH1/ - real, dimension (kts:kte) :: & - srro, qrro, sqc, sqr, & - sqi, sqs, sqg, stqc, & - stqr, stqi, stqs, stqg - real, dimension (nt) :: & - tqc, tqr, tqi, tqs, tqg - -!JJS common/bls/ y0(nx,ny),ts0new(nx,ny),qss0new(nx,ny) - -!JJS COMMON/BLS/ - real, dimension (ims:ime,jms:jme) :: & - y0, ts0, qss0 - -!JJS COMMON/BI/ IT(its:ite,jts:jte), ICS(its:ite,jts:jte,4) - integer, dimension (its:ite,jts:jte) :: it - integer, dimension (its:ite,jts:jte, 4) :: ics - - integer :: i24h - integer :: iwarm - real :: r2is, r2ig - - -!JJS COMMON/MICRO/ -! real, dimension (ims:ime,kms:kme,jms:jme) :: dbz - -!23456789012345678901234567890123456789012345678901234567890123456789012 - -! -!JJS 1/3/2008 vvvvv -!JJS the following common blocks have been moved to the top of -!JJS module_mp_gsfcgce_driver.F - -! real, dimension (31) :: aa1, aa2 -! data aa1/.7939e-7, .7841e-6, .3369e-5, .4336e-5, .5285e-5, & -! .3728e-5, .1852e-5, .2991e-6, .4248e-6, .7434e-6, & -! .1812e-5, .4394e-5, .9145e-5, .1725e-4, .3348e-4, & -! .1725e-4, .9175e-5, .4412e-5, .2252e-5, .9115e-6, & -! .4876e-6, .3473e-6, .4758e-6, .6306e-6, .8573e-6, & -! .7868e-6, .7192e-6, .6513e-6, .5956e-6, .5333e-6, & -! .4834e-6/ -! data aa2/.4006, .4831, .5320, .5307, .5319, & -! .5249, .4888, .3894, .4047, .4318, & -! .4771, .5183, .5463, .5651, .5813, & -! .5655, .5478, .5203, .4906, .4447, & -! .4126, .3960, .4149, .4320, .4506, & -! .4483, .4460, .4433, .4413, .4382, & -! .4361/ - -!JJS 1/3/2008 ^^^^^ - -! - save - -! i24h=nint(86400./dt) -! if (mod(itimestep,i24h).eq.1) then -! write(6, *) 'ims=', ims, ' ime=', ime -! write(6, *) 'jms=', jms, ' jme=', jme -! write(6, *) 'kms=', kms, ' kme=', kme -! write(6, *) 'its=', its, ' ite=', ite -! write(6, *) 'jts=', jts, ' jte=', jte -! write(6, *) 'kts=', kts, ' kte=', kte -! write(6, *) ' ihail=', ihail -! write(6, *) 'itaobraun=',itaobraun -! write(6, *) ' ice2=', ICE2 -! write(6, *) 'istatmin=',istatmin -! write(6, *) 'new_ice_sat=', new_ice_sat -! write(6, *) 'id=', id -! write(6, *) 'dt=', dt -! endif - -!JJS convert from mks to cgs, and move from WRF grid to GCE grid - do k=kts,kte - do j=jts,jte - do i=its,ite - rho(i,j,k)=rho_mks(i,k,j)*0.001 - p0(i,j,k)=p0_mks(i,k,j)*10.0 - pi(i,j,k)=pi_mks(i,k,j) - dpt(i,j,k)=ptwrf(i,k,j) - dqv(i,j,k)=qvwrf(i,k,j) - qcl(i,j,k)=qlwrf(i,k,j) - qrn(i,j,k)=qrwrf(i,k,j) - qci(i,j,k)=qiwrf(i,k,j) - qcs(i,j,k)=qswrf(i,k,j) - qcg(i,j,k)=qgwrf(i,k,j) -!JJS 10/16/06 vvvv -! dpt1(i,j,k)=ptwrfold(i,k,j) -! dqv1(i,j,k)=qvwrfold(i,k,j) -! qcl1(i,j,k)=qlwrfold(i,k,j) -! qrn1(i,j,k)=qrwrfold(i,k,j) -! qci1(i,j,k)=qiwrfold(i,k,j) -! qcs1(i,j,k)=qswrfold(i,k,j) -! qcg1(i,j,k)=qgwrfold(i,k,j) -!JJS 10/16/06 ^^^^ - enddo !i - enddo !j - enddo !k - - do k=kts,kte - do j=jts,jte - do i=its,ite - fv(i,j,k)=sqrt(rho(i,j,2)/rho(i,j,k)) - enddo !i - enddo !j - enddo !k -!JJS - -! -! ****** THREE CLASSES OF ICE-PHASE (LIN ET AL, 1983) ********* - -!JJS D22T=D2T -!JJS IF(IJKADV .EQ. 0) THEN -!JJS D2T=D2T -!JJS ELSE - d2t=dt -!JJS ENDIF -! -! itaobraun=0 ! original pint and pidep & see Tao and Simpson 1993 - itaobraun=1 ! see Tao et al. (2003) -! - if ( itaobraun.eq.0 ) then - cn0=1.e-8 -!c beta=-.6 - elseif ( itaobraun.eq.1 ) then - cn0=1.e-6 -! cn0=1.e-8 ! special -!c beta=-.46 - endif -!C TAO 2007 START -! ICE2=0 ! default, 3ice with loud ice, snow and graupel -! r2is=1., r2ig=1. -! ICE2=1 ! 2ice with cloud ice and snow (no graupel) - r2iceg=1, r2ice=0. -! r2is=1., r2ig=0. -! ICE2=2 ! 2ice with cloud ice and graupel (no snow) - r2ice=1, r2iceg=0. -! r2is=0., r2ig=1. -!c -! r2ice=1. -! r2iceg=1. - r2ig=1. - r2is=1. - if (ice2 .eq. 1) then -! r2ice=0. -! r2iceg=1. - r2ig=0. - r2is=1. - endif - if (ice2 .eq. 2) then -! r2ice=1. -! r2iceg=0. - r2ig=1. - r2is=0. - endif -!C TAO 2007 END - -!JJS 10/7/2008 -! ICE2=3 ! no ice, warm rain only - iwarm = 0 - if (ice2 .eq. 3 ) iwarm = 1 - - - - cmin=1.e-19 - cmin1=1.e-20 - cmin2=1.e-12 - ucor=3071.29/tnw**0.75 - ucos=687.97*roqs**0.25/tns**0.75 - ucog=687.97*roqg**0.25/tng**0.75 - uwet=4.464**0.95 - - rijl2 = 1. / (ide-ids) / (jde-jds) - -!JJScap $doacross local(j,i) - -!JJS DO 1 J=1,JMAX -!JJS DO 1 I=1,IMAX - do j=jts,jte - do i=its,ite - it(i,j)=1 - enddo - enddo - - f2=rd1*d2t - f3=rd2*d2t - - ft=dt/d2t - rft=rijl2*ft - a0=.5*istatmin*rijl2 - rt0=1./(t0-t00) - bw3=bw+3. - bs3=bs+3. - bg3=bg+3. - bsh5=2.5+bsh - bgh5=2.5+bgh - bwh5=2.5+bwh - bw6=bw+6. - bs6=bs+6. - betah=.5*beta - r10t=rn10*d2t - r11at=rn11a*d2t - r19bt=rn19b*d2t - r20t=-rn20*d2t - r23t=-rn23*d2t - r25a=rn25 - -! ami50 for use in PINT - ami50=3.76e-8 - ami100=1.51e-7 - ami40=2.41e-8 - -!C ****************************************************************** - -!JJS DO 1000 K=2,kles - do 1000 k=kts,kte - kp=k+1 -!JJS tb0=ta1(k) -!JJS qb0=qa1(k) - tb0=0. - qb0=0. - - do 2000 j=jts,jte - do 2000 i=its,ite - - rp0=3.799052e3/p0(i,j,k) - pi0=pi(i,j,k) - pir=1./(pi(i,j,k)) - pr0=1./p0(i,j,k) - r00=rho(i,j,k) - r0s=sqrt(rho(i,j,k)) -!JJS RR0=RRHO(K) - rr0=1./rho(i,j,k) -!JJS RRS=SRRO(K) - rrs=sqrt(rr0) -!JJS RRQ=QRRO(K) - rrq=sqrt(rrs) - f0(i,j,k)=al/cp/pi(i,j,k) - f00=f0(i,j,k) - fv0=fv(i,j,k) - fvs=sqrt(fv(i,j,k)) - zrr=1.e5*zrc*rrq - zsr=1.e5*zsc*rrq - zgr=1.e5*zgc*rrq - cp409=c409*pi0 - cv409=c409*avc - cp580=c580*pi0 - cs580=c580*asc - alvr=r00*alv - afcp=afc*pir - avcp=avc*pir - ascp=asc*pir - vrcf=vrc*fv0 - vscf=vsc*fv0 - vgcf=vgc*fv0 - vgcr=vgc*rrs - dwvp=c879*pr0 - r3f=rn3*fv0 - r4f=rn4*fv0 - r5f=rn5*fv0 - r6f=rn6*fv0 - r7r=rn7*rr0 - r8r=rn8*rr0 - r9r=rn9*rr0 - r101f=rn101*fvs - r10ar=rn10a*r00 - r11rt=rn11*rr0*d2t - r12r=rn12*r00 - r14r=rn14*rrs - r14f=rn14*fv0 - r15r=rn15*rrs - r15ar=rn15a*rrs - r15f=rn15*fv0 - r15af=rn15a*fv0 - r16r=rn16*rr0 - r17r=rn17*rr0 - r17aq=rn17a*rrq - r17as=rn17a*fvs - r18r=rn18*rr0 - r19rt=rn19*rr0*d2t - r19aq=rn19a*rrq - r19as=rn19a*fvs - r20bq=rn20b*rrq - r20bs=rn20b*fvs - r22f=rn22*fv0 - r23af=rn23a*fvs - r23br=rn23b*r00 - r25rt=rn25*rr0*d2t - r31r=rn31*rr0 - r32rt=rn32*d2t*rrs - -!JJS DO 100 J=3,JLES -!JJS DO 100 I=3,ILES - pt(i,j)=dpt(i,j,k) - qv(i,j)=dqv(i,j,k) - qc(i,j)=qcl(i,j,k) - qr(i,j)=qrn(i,j,k) - qi(i,j)=qci(i,j,k) - qs(i,j)=qcs(i,j,k) - qg(i,j)=qcg(i,j,k) -! IF (QV(I,J)+QB0 .LE. 0.) QV(I,J)=-QB0 - if (qc(i,j) .le. cmin1) qc(i,j)=0.0 - if (qr(i,j) .le. cmin1) qr(i,j)=0.0 - if (qi(i,j) .le. cmin1) qi(i,j)=0.0 - if (qs(i,j) .le. cmin1) qs(i,j)=0.0 - if (qg(i,j) .le. cmin1) qg(i,j)=0.0 - tair(i,j)=(pt(i,j)+tb0)*pi0 - tairc(i,j)=tair(i,j)-t0 - zr(i,j)=zrr - zs(i,j)=zsr - zg(i,j)=zgr - vr(i,j)=0.0 - vs(i,j)=0.0 - vg(i,j)=0.0 - -!JJS 10/7/2008 vvvvv - IF (IWARM .EQ. 1) THEN -!JJS for calculating processes related to warm rain only - qi(i,j)=0.0 - qs(i,j)=0.0 - qg(i,j)=0.0 - dep(i,j)=0. - pint(i,j)=0. - psdep(i,j)=0. - pgdep(i,j)=0. - dd1(i,j)=0. - pgsub(i,j)=0. - psmlt(i,j)=0. - pgmlt(i,j)=0. - pimlt(i,j)=0. - psacw(i,j)=0. - piacr(i,j)=0. - psfw(i,j)=0. - pgfr(i,j)=0. - dgacw(i,j)=0. - dgacr(i,j)=0. - psacr(i,j)=0. - wgacr(i,j)=0. - pihom(i,j)=0. - pidw(i,j)=0. - - if (qr(i,j) .gt. cmin1) then - dd(i,j)=r00*qr(i,j) - y1(i,j)=dd(i,j)**.25 - zr(i,j)=zrc/y1(i,j) - vr(i,j)=max(vrcf*dd(i,j)**bwq, 0.) - endif - -!* 21 * PRAUT AUTOCONVERSION OF QC TO QR **21** -!* 22 * PRACW : ACCRETION OF QC BY QR **22** - pracw(i,j)=0. - praut(i,j)=0.0 - pracw(i,j)=r22f*qc(i,j)/zr(i,j)**bw3 - y1(i,j)=qc(i,j)-bnd3 - if (y1(i,j).gt.0.0) then - praut(i,j)=r00*y1(i,j)*y1(i,j)/(1.2e-4+rn21/y1(i,j)) - endif - -!C******** HANDLING THE NEGATIVE CLOUD WATER (QC) ****************** - Y1(I,J)=QC(I,J)/D2T - PRAUT(I,J)=MIN(Y1(I,J), PRAUT(I,J)) - PRACW(I,J)=MIN(Y1(I,J), PRACW(I,J)) - Y1(I,J)=(PRAUT(I,J)+PRACW(I,J))*D2T - - if (qc(i,j) .lt. y1(i,j) .and. y1(i,j) .ge. cmin2) then - y2(i,j)=qc(i,j)/(y1(i,j)+cmin2) - praut(i,j)=praut(i,j)*y2(i,j) - pracw(i,j)=pracw(i,j)*y2(i,j) - qc(i,j)=0.0 - else - qc(i,j)=qc(i,j)-y1(i,j) - endif - - PR(I,J)=(PRAUT(I,J)+PRACW(I,J))*D2T - QR(I,J)=QR(I,J)+PR(I,J) - -!***** TAO ET AL (1989) SATURATION TECHNIQUE *********************** - - cnd(i,j)=0.0 - tair(i,j)=(pt(i,j)+tb0)*pi0 - y1(i,j)=1./(tair(i,j)-c358) - qsw(i,j)=rp0*exp(c172-c409*y1(i,j)) - dd(i,j)=cp409*y1(i,j)*y1(i,j) - dm(i,j)=qv(i,j)+qb0-qsw(i,j) - cnd(i,j)=dm(i,j)/(1.+avcp*dd(i,j)*qsw(i,j)) -!c ****** condensation or evaporation of qc ****** - cnd(i,j)=max(-qc(i,j), cnd(i,j)) - pt(i,j)=pt(i,j)+avcp*cnd(i,j) - qv(i,j)=qv(i,j)-cnd(i,j) - qc(i,j)=qc(i,j)+cnd(i,j) - -!C ****** EVAPORATION ****** -!* 23 * ERN : EVAPORATION OF QR (SUBSATURATION) **23** - ern(i,j)=0.0 - - if(qr(i,j).gt.0.0) then - tair(i,j)=(pt(i,j)+tb0)*pi0 - rtair(i,j)=1./(tair(i,j)-c358) - qsw(i,j)=rp0*exp(c172-c409*rtair(i,j)) - ssw(i,j)=(qv(i,j)+qb0)/qsw(i,j)-1.0 - dm(i,j)=qv(i,j)+qb0-qsw(i,j) - rsub1(i,j)=cv409*qsw(i,j)*rtair(i,j)*rtair(i,j) - dd1(i,j)=max(-dm(i,j)/(1.+rsub1(i,j)), 0.0) - y1(i,j)=.78/zr(i,j)**2+r23af*scv(i,j)/zr(i,j)**bwh5 - y2(i,j)=r23br/(tca(i,j)*tair(i,j)**2)+1./(dwv(i,j) & - *qsw(i,j)) -!cccc - ern(i,j)=r23t*ssw(i,j)*y1(i,j)/y2(i,j) - ern(i,j)=min(dd1(i,j),qr(i,j),max(ern(i,j),0.)) - pt(i,j)=pt(i,j)-avcp*ern(i,j) - qv(i,j)=qv(i,j)+ern(i,j) - qr(i,j)=qr(i,j)-ern(i,j) - endif - - ELSE ! part of if (iwarm.eq.1) then -!JJS 10/7/2008 ^^^^^ - -!JJS for calculating processes related to both ice and warm rain - -! *** COMPUTE ZR,ZS,ZG,VR,VS,VG ***************************** - - if (qr(i,j) .gt. cmin1) then - dd(i,j)=r00*qr(i,j) - y1(i,j)=dd(i,j)**.25 - zr(i,j)=zrc/y1(i,j) - vr(i,j)=max(vrcf*dd(i,j)**bwq, 0.) - endif - - if (qs(i,j) .gt. cmin1) then - dd(i,j)=r00*qs(i,j) - y1(i,j)=dd(i,j)**.25 - zs(i,j)=zsc/y1(i,j) - vs(i,j)=max(vscf*dd(i,j)**bsq, 0.) - endif - - if (qg(i,j) .gt. cmin1) then - dd(i,j)=r00*qg(i,j) - y1(i,j)=dd(i,j)**.25 - zg(i,j)=zgc/y1(i,j) - if(ihail .eq. 1) then - vg(i,j)=max(vgcr*dd(i,j)**bgq, 0.) - else - vg(i,j)=max(vgcf*dd(i,j)**bgq, 0.) - endif - endif - - if (qr(i,j) .le. cmin2) vr(i,j)=0.0 - if (qs(i,j) .le. cmin2) vs(i,j)=0.0 - if (qg(i,j) .le. cmin2) vg(i,j)=0.0 - -! ****************************************************************** -! *** Y1 : DYNAMIC VISCOSITY OF AIR (U) -! *** DWV : DIFFUSIVITY OF WATER VAPOR IN AIR (PI) -! *** TCA : THERMAL CONDUCTIVITY OF AIR (KA) -! *** Y2 : KINETIC VISCOSITY (V) - - y1(i,j)=c149*tair(i,j)**1.5/(tair(i,j)+120.) - dwv(i,j)=dwvp*tair(i,j)**1.81 - tca(i,j)=c141*y1(i,j) - scv(i,j)=1./((rr0*y1(i,j))**.1666667*dwv(i,j)**.3333333) -!JJS 100 CONTINUE - -!* 1 * PSAUT : AUTOCONVERSION OF QI TO QS ***1** -!* 3 * PSACI : ACCRETION OF QI TO QS ***3** -!* 4 * PSACW : ACCRETION OF QC BY QS (RIMING) (QSACW FOR PSMLT) ***4** -!* 5 * PRACI : ACCRETION OF QI BY QR ***5** -!* 6 * PIACR : ACCRETION OF QR OR QG BY QI ***6** - -!JJS DO 125 J=3,JLES -!JJS DO 125 I=3,ILES - psaut(i,j)=0.0 - psaci(i,j)=0.0 - praci(i,j)=0.0 - piacr(i,j)=0.0 - psacw(i,j)=0.0 - qsacw(i,j)=0.0 - dd(i,j)=1./zs(i,j)**bs3 - - if (tair(i,j).lt.t0) then - esi(i,j)=exp(.025*tairc(i,j)) - psaut(i,j)=r2is*max(rn1*esi(i,j)*(qi(i,j)-bnd1) ,0.0) - psaci(i,j)=r2is*r3f*esi(i,j)*qi(i,j)*dd(i,j) -!JJS 3/30/06 -! to cut water to snow accretion by half -! PSACW(I,J)=R4F*QC(I,J)*DD(I,J) - psacw(i,j)=r2is*0.5*r4f*qc(i,j)*dd(i,j) -!JJS 3/30/06 - praci(i,j)=r2is*r5f*qi(i,j)/zr(i,j)**bw3 - piacr(i,j)=r2is*r6f*qi(i,j)*(zr(i,j)**(-bw6)) -!JJS PIACR(I,J)=R6F*QI(I,J)/ZR(I,J)**BW6 - else - qsacw(i,j)=r2is*r4f*qc(i,j)*dd(i,j) - endif - -!* 21 * PRAUT AUTOCONVERSION OF QC TO QR **21** -!* 22 * PRACW : ACCRETION OF QC BY QR **22** - - pracw(i,j)=r22f*qc(i,j)/zr(i,j)**bw3 - praut(i,j)=0.0 - y1(i,j)=qc(i,j)-bnd3 - if (y1(i,j).gt.0.0) then - praut(i,j)=r00*y1(i,j)*y1(i,j)/(1.2e-4+rn21/y1(i,j)) - endif - -!* 12 * PSFW : BERGERON PROCESSES FOR QS (KOENING, 1971) **12** -!* 13 * PSFI : BERGERON PROCESSES FOR QS **13** - - psfw(i,j)=0.0 - psfi(i,j)=0.0 - pidep(i,j)=0.0 - - if(tair(i,j).lt.t0.and.qi(i,j).gt.cmin) then - y1(i,j)=max( min(tairc(i,j), -1.), -31.) - it(i,j)=int(abs(y1(i,j))) - y1(i,j)=rn12a(it(i,j)) - y2(i,j)=rn12b(it(i,j)) -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - psfw(i,j)=r2is* & - max(d2t*y1(i,j)*(y2(i,j)+r12r*qc(i,j))*qi(i,j),0.0) - rtair(i,j)=1./(tair(i,j)-c76) - y2(i,j)=exp(c218-c580*rtair(i,j)) - qsi(i,j)=rp0*y2(i,j) - esi(i,j)=c610*y2(i,j) - ssi(i,j)=(qv(i,j)+qb0)/qsi(i,j)-1. - r_nci=min(1.e-6*exp(-.46*tairc(i,j)),1.) -! R_NCI=min(1.e-8*EXP(-.6*TAIRC(I,J)),1.) ! use Tao's - dm(i,j)=max( (qv(i,j)+qb0-qsi(i,j)), 0.) - rsub1(i,j)=cs580*qsi(i,j)*rtair(i,j)*rtair(i,j) - y3(i,j)=1./tair(i,j) - dd(i,j)=y3(i,j)*(rn30a*y3(i,j)-rn30b)+rn30c*tair(i,j)/esi(i,j) - y1(i,j)=206.18*ssi(i,j)/dd(i,j) - pidep(i,j)=y1(i,j)*sqrt(r_nci*qi(i,j)/r00) - dep(i,j)=dm(i,j)/(1.+rsub1(i,j))/d2t - if(dm(i,j).gt.cmin2) then - a2=1. - if(pidep(i,j).gt.dep(i,j).and.pidep(i,j).gt.cmin2) then - a2=dep(i,j)/pidep(i,j) - pidep(i,j)=dep(i,j) - endif - psfi(i,j)=r2is*a2*.5*qi(i,j)*y1(i,j)/(sqrt(ami100) & - -sqrt(ami40)) - elseif(dm(i,j).lt.-cmin2) then -! -! SUBLIMATION TERMS USED ONLY WHEN SATURATION ADJUSTMENT FOR ICE -! IS TURNED OFF -! - pidep(i,j)=0. - psfi(i,j)=0. - else - pidep(i,j)=0. - psfi(i,j)=0. - endif - endif - -!TTT***** QG=QG+MIN(PGDRY,PGWET) -!* 9 * PGACS : ACCRETION OF QS BY QG (DGACS,WGACS: DRY AND WET) ***9** -!* 14 * DGACW : ACCRETION OF QC BY QG (QGACW FOR PGMLT) **14** -!* 16 * DGACR : ACCRETION OF QR TO QG (QGACR FOR PGMLT) **16** - - if(qc(i,j)+qr(i,j).lt.1.e-4) then - ee1=.01 - else - ee1=1. - endif - ee2=0.09 - egs(i,j)=ee1*exp(ee2*tairc(i,j)) -! EGS(I,J)=0.1 ! 6/15/02 tao's - if (tair(i,j).ge.t0) egs(i,j)=1.0 - y1(i,j)=abs(vg(i,j)-vs(i,j)) - y2(i,j)=zs(i,j)*zg(i,j) - y3(i,j)=5./y2(i,j) - y4(i,j)=.08*y3(i,j)*y3(i,j) - y5(i,j)=.05*y3(i,j)*y4(i,j) - dd(i,j)=y1(i,j)*(y3(i,j)/zs(i,j)**5+y4(i,j)/zs(i,j)**3 & - +y5(i,j)/zs(i,j)) - pgacs(i,j)=r2ig*r2is*r9r*egs(i,j)*dd(i,j) -!JJS 1/3/06 from Steve and Chunglin - if (ihail.eq.1) then - dgacs(i,j)=pgacs(i,j) - else - dgacs(i,j)=0. - endif -!JJS 1/3/06 from Steve and Chunglin - wgacs(i,j)=r2ig*r2is*r9r*dd(i,j) -! WGACS(I,J)=0. ! 6/15/02 tao's - y1(i,j)=1./zg(i,j)**bg3 - - if(ihail .eq. 1) then - dgacw(i,j)=r2ig*max(r14r*qc(i,j)*y1(i,j), 0.0) - else - dgacw(i,j)=r2ig*max(r14f*qc(i,j)*y1(i,j), 0.0) - endif - - qgacw(i,j)=dgacw(i,j) - y1(i,j)=abs(vg(i,j)-vr(i,j)) - y2(i,j)=zr(i,j)*zg(i,j) - y3(i,j)=5./y2(i,j) - y4(i,j)=.08*y3(i,j)*y3(i,j) - y5(i,j)=.05*y3(i,j)*y4(i,j) - dd(i,j)=r16r*y1(i,j)*(y3(i,j)/zr(i,j)**5+y4(i,j)/zr(i,j)**3 & - +y5(i,j)/zr(i,j)) - dgacr(i,j)=r2ig*max(dd(i,j), 0.0) - qgacr(i,j)=dgacr(i,j) - - if (tair(i,j).ge.t0) then - dgacs(i,j)=0.0 - wgacs(i,j)=0.0 - dgacw(i,j)=0.0 - dgacr(i,j)=0.0 - else - pgacs(i,j)=0.0 - qgacw(i,j)=0.0 - qgacr(i,j)=0.0 - endif - -!*******PGDRY : DGACW+DGACI+DGACR+DGACS ****** -!* 15 * DGACI : ACCRETION OF QI BY QG (WGACI FOR WET GROWTH) **15** -!* 17 * PGWET : WET GROWTH OF QG **17** - - dgaci(i,j)=0.0 - wgaci(i,j)=0.0 - pgwet(i,j)=0.0 - - if (tair(i,j).lt.t0) then - y1(i,j)=qi(i,j)/zg(i,j)**bg3 - if (ihail.eq.1) then - dgaci(i,j)=r2ig*r15r*y1(i,j) - wgaci(i,j)=r2ig*r15ar*y1(i,j) -! WGACI(I,J)=0. ! 6/15/02 tao's - else - -!JJS DGACI(I,J)=r2ig*R15F*Y1(I,J) - dgaci(i,j)=0. - wgaci(i,j)=r2ig*r15af*y1(i,j) -! WGACI(I,J)=0. ! 6/15/02 tao's - endif -! - if (tairc(i,j).ge.-50.) then - if (alf+rn17c*tairc(i,j) .eq. 0.) then - write(91,*) itimestep, i,j,k, alf, rn17c, tairc(i,j) - endif - y1(i,j)=1./(alf+rn17c*tairc(i,j)) - if (ihail.eq.1) then - y3(i,j)=.78/zg(i,j)**2+r17aq*scv(i,j)/zg(i,j)**bgh5 - else - y3(i,j)=.78/zg(i,j)**2+r17as*scv(i,j)/zg(i,j)**bgh5 - endif - y4(i,j)=alvr*dwv(i,j)*(rp0-(qv(i,j)+qb0)) & - -tca(i,j)*tairc(i,j) - dd(i,j)=y1(i,j)*(r17r*y4(i,j)*y3(i,j) & - +(wgaci(i,j)+wgacs(i,j))*(alf+rn17b*tairc(i,j))) - pgwet(i,j)=r2ig*max(dd(i,j), 0.0) - endif - endif -!JJS 125 CONTINUE - -!******** HANDLING THE NEGATIVE CLOUD WATER (QC) ****************** -!******** HANDLING THE NEGATIVE CLOUD ICE (QI) ****************** - -!JJS DO 150 J=3,JLES -!JJS DO 150 I=3,ILES - - y1(i,j)=qc(i,j)/d2t - psacw(i,j)=min(y1(i,j), psacw(i,j)) - praut(i,j)=min(y1(i,j), praut(i,j)) - pracw(i,j)=min(y1(i,j), pracw(i,j)) - psfw(i,j)= min(y1(i,j), psfw(i,j)) - dgacw(i,j)=min(y1(i,j), dgacw(i,j)) - qsacw(i,j)=min(y1(i,j), qsacw(i,j)) - qgacw(i,j)=min(y1(i,j), qgacw(i,j)) - - y1(i,j)=(psacw(i,j)+praut(i,j)+pracw(i,j)+psfw(i,j) & - +dgacw(i,j)+qsacw(i,j)+qgacw(i,j))*d2t - qc(i,j)=qc(i,j)-y1(i,j) - - if (qc(i,j) .lt. 0.0) then - a1=1. - if (y1(i,j) .ne. 0.0) a1=qc(i,j)/y1(i,j)+1. - psacw(i,j)=psacw(i,j)*a1 - praut(i,j)=praut(i,j)*a1 - pracw(i,j)=pracw(i,j)*a1 - psfw(i,j)=psfw(i,j)*a1 - dgacw(i,j)=dgacw(i,j)*a1 - qsacw(i,j)=qsacw(i,j)*a1 - qgacw(i,j)=qgacw(i,j)*a1 - qc(i,j)=0.0 - endif -!c -! -!******** SHED PROCESS (WGACR=PGWET-DGACW-WGACI-WGACS) -!c - wgacr(i,j)=pgwet(i,j)-dgacw(i,j)-wgaci(i,j)-wgacs(i,j) - y2(i,j)=dgacw(i,j)+dgaci(i,j)+dgacr(i,j)+dgacs(i,j) - if (pgwet(i,j).ge.y2(i,j)) then - wgacr(i,j)=0.0 - wgaci(i,j)=0.0 - wgacs(i,j)=0.0 - else - dgacr(i,j)=0.0 - dgaci(i,j)=0.0 - dgacs(i,j)=0.0 - endif -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!c - y1(i,j)=qi(i,j)/d2t - psaut(i,j)=min(y1(i,j), psaut(i,j)) - psaci(i,j)=min(y1(i,j), psaci(i,j)) - praci(i,j)=min(y1(i,j), praci(i,j)) - psfi(i,j)= min(y1(i,j), psfi(i,j)) - dgaci(i,j)=min(y1(i,j), dgaci(i,j)) - wgaci(i,j)=min(y1(i,j), wgaci(i,j)) -! - y2(i,j)=(psaut(i,j)+psaci(i,j)+praci(i,j)+psfi(i,j) & - +dgaci(i,j)+wgaci(i,j))*d2t - qi(i,j)=qi(i,j)-y2(i,j)+pidep(i,j)*d2t - - if (qi(i,j).lt.0.0) then - a2=1. - if (y2(i,j) .ne. 0.0) a2=qi(i,j)/y2(i,j)+1. - psaut(i,j)=psaut(i,j)*a2 - psaci(i,j)=psaci(i,j)*a2 - praci(i,j)=praci(i,j)*a2 - psfi(i,j)=psfi(i,j)*a2 - dgaci(i,j)=dgaci(i,j)*a2 - wgaci(i,j)=wgaci(i,j)*a2 - qi(i,j)=0.0 - endif -! - dlt3(i,j)=0.0 - dlt2(i,j)=0.0 -! - -! DLT4(I,J)=1.0 -! if(qc(i,j) .gt. 5.e-4) dlt4(i,j)=0.0 -! if(qs(i,j) .le. 1.e-4) dlt4(i,j)=1.0 -! -! IF (TAIR(I,J).ge.T0) THEN -! DLT4(I,J)=0.0 -! ENDIF - - if (tair(i,j).lt.t0) then - if (qr(i,j).lt.1.e-4) then - dlt3(i,j)=1.0 - dlt2(i,j)=1.0 - endif - if (qs(i,j).ge.1.e-4) then - dlt2(i,j)=0.0 - endif - endif - - if (ice2 .eq. 1) then - dlt3(i,j)=1.0 - dlt2(i,j)=1.0 - endif -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - pr(i,j)=(qsacw(i,j)+praut(i,j)+pracw(i,j)+qgacw(i,j))*d2t - ps(i,j)=(psaut(i,j)+psaci(i,j)+psacw(i,j)+psfw(i,j) & - +psfi(i,j)+dlt3(i,j)*praci(i,j))*d2t -! PS(I,J)=(PSAUT(I,J)+PSACI(I,J)+dlt4(i,j)*PSACW(I,J) -! 1 +PSFW(I,J)+PSFI(I,J)+DLT3(I,J)*PRACI(I,J))*D2T - pg(i,j)=((1.-dlt3(i,j))*praci(i,j)+dgaci(i,j)+wgaci(i,j) & - +dgacw(i,j))*d2t -! PG(I,J)=((1.-DLT3(I,J))*PRACI(I,J)+DGACI(I,J)+WGACI(I,J) -! 1 +DGACW(I,J)+(1.-dlt4(i,j))*PSACW(I,J))*D2T - -!JJS 150 CONTINUE - -!* 7 * PRACS : ACCRETION OF QS BY QR ***7** -!* 8 * PSACR : ACCRETION OF QR BY QS (QSACR FOR PSMLT) ***8** - -!JJS DO 175 J=3,JLES -!JJS DO 175 I=3,ILES - - y1(i,j)=abs(vr(i,j)-vs(i,j)) - y2(i,j)=zr(i,j)*zs(i,j) - y3(i,j)=5./y2(i,j) - y4(i,j)=.08*y3(i,j)*y3(i,j) - y5(i,j)=.05*y3(i,j)*y4(i,j) - pracs(i,j)=r2ig*r2is*r7r*y1(i,j)*(y3(i,j)/zs(i,j)**5 & - +y4(i,j)/zs(i,j)**3+y5(i,j)/zs(i,j)) - psacr(i,j)=r2is*r8r*y1(i,j)*(y3(i,j)/zr(i,j)**5 & - +y4(i,j)/zr(i,j)**3+y5(i,j)/zr(i,j)) - qsacr(i,j)=psacr(i,j) - - if (tair(i,j).ge.t0) then - pracs(i,j)=0.0 - psacr(i,j)=0.0 - else - qsacr(i,j)=0.0 - endif -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!* 2 * PGAUT : AUTOCONVERSION OF QS TO QG ***2** -!* 18 * PGFR : FREEZING OF QR TO QG **18** - - pgaut(i,j)=0.0 - pgfr(i,j)=0.0 - - if (tair(i,j) .lt. t0) then -! Y1(I,J)=EXP(.09*TAIRC(I,J)) -! PGAUT(I,J)=r2is*max(RN2*Y1(I,J)*(QS(I,J)-BND2), 0.0) -! IF(IHAIL.EQ.1) PGAUT(I,J)=max(RN2*Y1(I,J)*(QS(I,J)-BND2),0.0) - y2(i,j)=exp(rn18a*(t0-tair(i,j))) -!JJS PGFR(I,J)=r2ig*max(R18R*(Y2(I,J)-1.)/ZR(I,J)**7., 0.0) -! pgfr(i,j)=r2ice*max(r18r*(y2(i,j)-1.)* & -! (zr(i,j)**(-7.)), 0.0) -! modify to prevent underflow on some computers (JD) - temp = 1./zr(i,j) - temp = temp*temp*temp*temp*temp*temp*temp - pgfr(i,j)=r2ice*max(r18r*(y2(i,j)-1.)* & - temp, 0.0) - endif - -!JJS 175 CONTINUE - -!******** HANDLING THE NEGATIVE RAIN WATER (QR) ******************* -!******** HANDLING THE NEGATIVE SNOW (QS) ******************* - -!JJS DO 200 J=3,JLES -!JJS DO 200 I=3,ILES - - y1(i,j)=qr(i,j)/d2t - y2(i,j)=-qg(i,j)/d2t - piacr(i,j)=min(y1(i,j), piacr(i,j)) - dgacr(i,j)=min(y1(i,j), dgacr(i,j)) - wgacr(i,j)=min(y1(i,j), wgacr(i,j)) - wgacr(i,j)=max(y2(i,j), wgacr(i,j)) - psacr(i,j)=min(y1(i,j), psacr(i,j)) - pgfr(i,j)= min(y1(i,j), pgfr(i,j)) - del=0. - if(wgacr(i,j) .lt. 0.) del=1. - y1(i,j)=(piacr(i,j)+dgacr(i,j)+(1.-del)*wgacr(i,j) & - +psacr(i,j)+pgfr(i,j))*d2t - qr(i,j)=qr(i,j)+pr(i,j)-y1(i,j)-del*wgacr(i,j)*d2t - if (qr(i,j) .lt. 0.0) then - a1=1. - if(y1(i,j) .ne. 0.) a1=qr(i,j)/y1(i,j)+1. - piacr(i,j)=piacr(i,j)*a1 - dgacr(i,j)=dgacr(i,j)*a1 - if (wgacr(i,j).gt.0.) wgacr(i,j)=wgacr(i,j)*a1 - pgfr(i,j)=pgfr(i,j)*a1 - psacr(i,j)=psacr(i,j)*a1 - qr(i,j)=0.0 - endif -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - prn(i,j)=d2t*((1.-dlt3(i,j))*piacr(i,j)+dgacr(i,j) & - +wgacr(i,j)+(1.-dlt2(i,j))*psacr(i,j)+pgfr(i,j)) - ps(i,j)=ps(i,j)+d2t*(dlt3(i,j)*piacr(i,j) & - +dlt2(i,j)*psacr(i,j)) - pracs(i,j)=(1.-dlt2(i,j))*pracs(i,j) - y1(i,j)=qs(i,j)/d2t - pgacs(i,j)=min(y1(i,j), pgacs(i,j)) - dgacs(i,j)=min(y1(i,j), dgacs(i,j)) - wgacs(i,j)=min(y1(i,j), wgacs(i,j)) - pgaut(i,j)=min(y1(i,j), pgaut(i,j)) - pracs(i,j)=min(y1(i,j), pracs(i,j)) - psn(i,j)=d2t*(pgacs(i,j)+dgacs(i,j)+wgacs(i,j) & - +pgaut(i,j)+pracs(i,j)) - qs(i,j)=qs(i,j)+ps(i,j)-psn(i,j) - - if (qs(i,j).lt.0.0) then - a2=1. - if (psn(i,j) .ne. 0.0) a2=qs(i,j)/psn(i,j)+1. - pgacs(i,j)=pgacs(i,j)*a2 - dgacs(i,j)=dgacs(i,j)*a2 - wgacs(i,j)=wgacs(i,j)*a2 - pgaut(i,j)=pgaut(i,j)*a2 - pracs(i,j)=pracs(i,j)*a2 - psn(i,j)=psn(i,j)*a2 - qs(i,j)=0.0 - endif -! -!C PSN(I,J)=D2T*(PGACS(I,J)+DGACS(I,J)+WGACS(I,J) -!c +PGAUT(I,J)+PRACS(I,J)) - y2(i,j)=d2t*(psacw(i,j)+psfw(i,j)+dgacw(i,j)+piacr(i,j) & - +dgacr(i,j)+wgacr(i,j)+psacr(i,j)+pgfr(i,j)) - pt(i,j)=pt(i,j)+afcp*y2(i,j) - qg(i,j)=qg(i,j)+pg(i,j)+prn(i,j)+psn(i,j) - -!JJS 200 CONTINUE - -!* 11 * PSMLT : MELTING OF QS **11** -!* 19 * PGMLT : MELTING OF QG TO QR **19** - -!JJS DO 225 J=3,JLES -!JJS DO 225 I=3,ILES - - psmlt(i,j)=0.0 - pgmlt(i,j)=0.0 - tair(i,j)=(pt(i,j)+tb0)*pi0 - - if (tair(i,j).ge.t0) then - tairc(i,j)=tair(i,j)-t0 - y1(i,j)=tca(i,j)*tairc(i,j)-alvr*dwv(i,j) & - *(rp0-(qv(i,j)+qb0)) - y2(i,j)=.78/zs(i,j)**2+r101f*scv(i,j)/zs(i,j)**bsh5 - dd(i,j)=r11rt*y1(i,j)*y2(i,j)+r11at*tairc(i,j) & - *(qsacw(i,j)+qsacr(i,j)) - psmlt(i,j)=r2is*max(0.0, min(dd(i,j), qs(i,j))) - - if(ihail.eq.1) then - y3(i,j)=.78/zg(i,j)**2+r19aq*scv(i,j)/zg(i,j)**bgh5 - else - y3(i,j)=.78/zg(i,j)**2+r19as*scv(i,j)/zg(i,j)**bgh5 - endif - - dd1(i,j)=r19rt*y1(i,j)*y3(i,j)+r19bt*tairc(i,j) & - *(qgacw(i,j)+qgacr(i,j)) - pgmlt(i,j)=r2ig*max(0.0, min(dd1(i,j), qg(i,j))) - pt(i,j)=pt(i,j)-afcp*(psmlt(i,j)+pgmlt(i,j)) - qr(i,j)=qr(i,j)+psmlt(i,j)+pgmlt(i,j) - qs(i,j)=qs(i,j)-psmlt(i,j) - qg(i,j)=qg(i,j)-pgmlt(i,j) - endif -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!* 24 * PIHOM : HOMOGENEOUS FREEZING OF QC TO QI (T < T00) **24** -!* 25 * PIDW : DEPOSITION GROWTH OF QC TO QI ( T0 < T <= T00) **25** -!* 26 * PIMLT : MELTING OF QI TO QC (T >= T0) **26** - - if (qc(i,j).le.cmin1) qc(i,j)=0.0 - if (qi(i,j).le.cmin1) qi(i,j)=0.0 - tair(i,j)=(pt(i,j)+tb0)*pi0 - - if(tair(i,j).le.t00) then - pihom(i,j)=qc(i,j) - else - pihom(i,j)=0.0 - endif - if(tair(i,j).ge.t0) then - pimlt(i,j)=qi(i,j) - else - pimlt(i,j)=0.0 - endif - pidw(i,j)=0.0 - - if (tair(i,j).lt.t0 .and. tair(i,j).gt.t00) then - tairc(i,j)=tair(i,j)-t0 - y1(i,j)=max( min(tairc(i,j), -1.), -31.) - it(i,j)=int(abs(y1(i,j))) - y2(i,j)=aa1(it(i,j)) - y3(i,j)=aa2(it(i,j)) - y4(i,j)=exp(abs(beta*tairc(i,j))) - y5(i,j)=(r00*qi(i,j)/(r25a*y4(i,j)))**y3(i,j) - pidw(i,j)=min(r25rt*y2(i,j)*y4(i,j)*y5(i,j), qc(i,j)) - endif - - y1(i,j)=pihom(i,j)-pimlt(i,j)+pidw(i,j) - pt(i,j)=pt(i,j)+afcp*y1(i,j)+ascp*(pidep(i,j))*d2t - qv(i,j)=qv(i,j)-(pidep(i,j))*d2t - qc(i,j)=qc(i,j)-y1(i,j) - qi(i,j)=qi(i,j)+y1(i,j) - -!* 31 * PINT : INITIATION OF QI **31** -!* 32 * PIDEP : DEPOSITION OF QI **32** -! -! CALCULATION OF PINT USES DIFFERENT VALUES OF THE INTERCEPT AND SLOPE FOR -! THE FLETCHER EQUATION. ALSO, ONLY INITIATE MORE ICE IF THE NEW NUMBER -! CONCENTRATION EXCEEDS THAT ALREADY PRESENT. -!* 31 * pint : initiation of qi **31** -!* 32 * pidep : deposition of qi **32** - pint(i,j)=0.0 -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - if ( itaobraun.eq.1 ) then - tair(i,j)=(pt(i,j)+tb0)*pi0 - if (tair(i,j) .lt. t0) then -! if (qi(i,j) .le. cmin) qi(i,j)=0. - if (qi(i,j) .le. cmin2) qi(i,j)=0. - tairc(i,j)=tair(i,j)-t0 - rtair(i,j)=1./(tair(i,j)-c76) - y2(i,j)=exp(c218-c580*rtair(i,j)) - qsi(i,j)=rp0*y2(i,j) - esi(i,j)=c610*y2(i,j) - ssi(i,j)=(qv(i,j)+qb0)/qsi(i,j)-1. - ami50=3.76e-8 - -!ccif ( itaobraun.eq.1 ) --> betah=0.5*beta=-.46*0.5=-0.23; cn0=1.e-6 -!ccif ( itaobraun.eq.0 ) --> betah=0.5*beta=-.6*0.5=-0.30; cn0=1.e-8 - - y1(i,j)=1./tair(i,j) - -!cc insert a restriction on ice collection that ice collection -!cc should be stopped at -30 c (with cn0=1.e-6, beta=-.46) - - tairccri=tairc(i,j) ! in degree c - if(tairccri.le.-30.) tairccri=-30. - -! y2(i,j)=exp(betah*tairc(i,j)) - y2(i,j)=exp(betah*tairccri) - y3(i,j)=sqrt(qi(i,j)) - dd(i,j)=y1(i,j)*(rn10a*y1(i,j)-rn10b)+rn10c*tair(i,j) & - /esi(i,j) - pidep(i,j)=max(r32rt*ssi(i,j)*y2(i,j)*y3(i,j)/dd(i,j), 0.e0) - - r_nci=min(cn0*exp(beta*tairc(i,j)),1.) -! r_nci=min(1.e-6*exp(-.46*tairc(i,j)),1.) - - dd(i,j)=max(1.e-9*r_nci/r00-qi(i,j)*1.e-9/ami50, 0.) - dm(i,j)=max( (qv(i,j)+qb0-qsi(i,j)), 0.0) - rsub1(i,j)=cs580*qsi(i,j)*rtair(i,j)*rtair(i,j) - dep(i,j)=dm(i,j)/(1.+rsub1(i,j)) - pint(i,j)=max(min(dd(i,j), dm(i,j)), 0.) - -! pint(i,j)=min(pint(i,j), dep(i,j)) - pint(i,j)=min(pint(i,j)+pidep(i,j), dep(i,j)) - -! if (pint(i,j) .le. cmin) pint(i,j)=0. - if (pint(i,j) .le. cmin2) pint(i,j)=0. - pt(i,j)=pt(i,j)+ascp*pint(i,j) - qv(i,j)=qv(i,j)-pint(i,j) - qi(i,j)=qi(i,j)+pint(i,j) - endif - endif ! if ( itaobraun.eq.1 ) -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -! -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - if ( itaobraun.eq.0 ) then - tair(i,j)=(pt(i,j)+tb0)*pi0 - if (tair(i,j) .lt. t0) then - if (qi(i,j) .le. cmin1) qi(i,j)=0. - tairc(i,j)=tair(i,j)-t0 - dd(i,j)=r31r*exp(beta*tairc(i,j)) - rtair(i,j)=1./(tair(i,j)-c76) - y2(i,j)=exp(c218-c580*rtair(i,j)) - qsi(i,j)=rp0*y2(i,j) - esi(i,j)=c610*y2(i,j) - ssi(i,j)=(qv(i,j)+qb0)/qsi(i,j)-1. - dm(i,j)=max( (qv(i,j)+qb0-qsi(i,j)), 0.) - rsub1(i,j)=cs580*qsi(i,j)*rtair(i,j)*rtair(i,j) - dep(i,j)=dm(i,j)/(1.+rsub1(i,j)) - pint(i,j)=max(min(dd(i,j), dm(i,j)), 0.) - y1(i,j)=1./tair(i,j) - y2(i,j)=exp(betah*tairc(i,j)) - y3(i,j)=sqrt(qi(i,j)) - dd(i,j)=y1(i,j)*(rn10a*y1(i,j)-rn10b) & - +rn10c*tair(i,j)/esi(i,j) - pidep(i,j)=max(r32rt*ssi(i,j)*y2(i,j)*y3(i,j)/dd(i,j), 0.) - pint(i,j)=pint(i,j)+pidep(i,j) - pint(i,j)=min(pint(i,j),dep(i,j)) -!c if (pint(i,j) .le. cmin2) pint(i,j)=0. - pt(i,j)=pt(i,j)+ascp*pint(i,j) - qv(i,j)=qv(i,j)-pint(i,j) - qi(i,j)=qi(i,j)+pint(i,j) - endif - endif ! if ( itaobraun.eq.0 ) -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - -!JJS 225 CONTINUE - -!***** TAO ET AL (1989) SATURATION TECHNIQUE *********************** - - if (new_ice_sat .eq. 0) then - -!JJS DO 250 J=3,JLES -!JJS DO 250 I=3,ILES - tair(i,j)=(pt(i,j)+tb0)*pi0 - cnd(i,j)=rt0*(tair(i,j)-t00) - dep(i,j)=rt0*(t0-tair(i,j)) - y1(i,j)=1./(tair(i,j)-c358) - y2(i,j)=1./(tair(i,j)-c76) - qsw(i,j)=rp0*exp(c172-c409*y1(i,j)) - qsi(i,j)=rp0*exp(c218-c580*y2(i,j)) - dd(i,j)=cp409*y1(i,j)*y1(i,j) - dd1(i,j)=cp580*y2(i,j)*y2(i,j) - if (qc(i,j).le.cmin) qc(i,j)=cmin - if (qi(i,j).le.cmin) qi(i,j)=cmin - if (tair(i,j).ge.t0) then - dep(i,j)=0.0 - cnd(i,j)=1. - qi(i,j)=0.0 - endif - - if (tair(i,j).lt.t00) then - cnd(i,j)=0.0 - dep(i,j)=1. - qc(i,j)=0.0 - endif - - y5(i,j)=avcp*cnd(i,j)+ascp*dep(i,j) -! if (qc(i,j) .ge. cmin .or. qi(i,j) .ge. cmin) then - y1(i,j)=qc(i,j)*qsw(i,j)/(qc(i,j)+qi(i,j)) - y2(i,j)=qi(i,j)*qsi(i,j)/(qc(i,j)+qi(i,j)) - y4(i,j)=dd(i,j)*y1(i,j)+dd1(i,j)*y2(i,j) - qvs(i,j)=y1(i,j)+y2(i,j) - rsub1(i,j)=(qv(i,j)+qb0-qvs(i,j))/(1.+y4(i,j)*y5(i,j)) - cnd(i,j)=cnd(i,j)*rsub1(i,j) - dep(i,j)=dep(i,j)*rsub1(i,j) - if (qc(i,j).le.cmin) qc(i,j)=0. - if (qi(i,j).le.cmin) qi(i,j)=0. -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!c ****** condensation or evaporation of qc ****** - - cnd(i,j)=max(-qc(i,j),cnd(i,j)) - -!c ****** deposition or sublimation of qi ****** - - dep(i,j)=max(-qi(i,j),dep(i,j)) - - pt(i,j)=pt(i,j)+avcp*cnd(i,j)+ascp*dep(i,j) - qv(i,j)=qv(i,j)-cnd(i,j)-dep(i,j) - qc(i,j)=qc(i,j)+cnd(i,j) - qi(i,j)=qi(i,j)+dep(i,j) -!JJS 250 continue - endif - - if (new_ice_sat .eq. 1) then - -!JJS DO J=3,JLES -!JJS DO I=3,ILES - - tair(i,j)=(pt(i,j)+tb0)*pi0 - cnd(i,j)=rt0*(tair(i,j)-t00) - dep(i,j)=rt0*(t0-tair(i,j)) - y1(i,j)=1./(tair(i,j)-c358) - y2(i,j)=1./(tair(i,j)-c76) - qsw(i,j)=rp0*exp(c172-c409*y1(i,j)) - qsi(i,j)=rp0*exp(c218-c580*y2(i,j)) - dd(i,j)=cp409*y1(i,j)*y1(i,j) - dd1(i,j)=cp580*y2(i,j)*y2(i,j) - y5(i,j)=avcp*cnd(i,j)+ascp*dep(i,j) - y1(i,j)=rt0*(tair(i,j)-t00)*qsw(i,j) - y2(i,j)=rt0*(t0-tair(i,j))*qsi(i,j) -! IF (QC(I,J).LE.CMIN) QC(I,J)=CMIN -! IF (QI(I,J).LE.CMIN) QI(I,J)=CMIN - - if (tair(i,j).ge.t0) then -! QI(I,J)=0.0 - dep(i,j)=0.0 - cnd(i,j)=1. - y2(i,j)=0. - y1(i,j)=qsw(i,j) - endif - if (tair(i,j).lt.t00) then - cnd(i,j)=0.0 - dep(i,j)=1. - y2(i,j)=qsi(i,j) - y1(i,j)=0. -! QC(I,J)=0.0 - endif - -! Y1(I,J)=QC(I,J)*QSW(I,J)/(QC(I,J)+QI(I,J)) -! Y2(I,J)=QI(I,J)*QSI(I,J)/(QC(I,J)+QI(I,J)) - - y4(i,j)=dd(i,j)*y1(i,j)+dd1(i,j)*y2(i,j) - qvs(i,j)=y1(i,j)+y2(i,j) - rsub1(i,j)=(qv(i,j)+qb0-qvs(i,j))/(1.+y4(i,j)*y5(i,j)) - cnd(i,j)=cnd(i,j)*rsub1(i,j) - dep(i,j)=dep(i,j)*rsub1(i,j) -! IF (QC(I,J).LE.CMIN) QC(I,J)=0. -! IF (QI(I,J).LE.CMIN) QI(I,J)=0. - -!C ****** CONDENSATION OR EVAPORATION OF QC ****** - - cnd(i,j)=max(-qc(i,j),cnd(i,j)) - -!C ****** DEPOSITION OR SUBLIMATION OF QI ****** - - dep(i,j)=max(-qi(i,j),dep(i,j)) - - pt(i,j)=pt(i,j)+avcp*cnd(i,j)+ascp*dep(i,j) - qv(i,j)=qv(i,j)-cnd(i,j)-dep(i,j) - qc(i,j)=qc(i,j)+cnd(i,j) - qi(i,j)=qi(i,j)+dep(i,j) -!JJS ENDDO -!JJS ENDDO - endif - -!c -! - if (new_ice_sat .eq. 2) then -!JJS do j=3,jles -!JJS do i=3,iles - dep(i,j)=0.0 - cnd(i,j)=0.0 - tair(i,j)=(pt(i,j)+tb0)*pi0 - if (tair(i,j) .ge. 253.16) then - y1(i,j)=1./(tair(i,j)-c358) - qsw(i,j)=rp0*exp(c172-c409*y1(i,j)) - dd(i,j)=cp409*y1(i,j)*y1(i,j) - dm(i,j)=qv(i,j)+qb0-qsw(i,j) - cnd(i,j)=dm(i,j)/(1.+avcp*dd(i,j)*qsw(i,j)) -!c ****** condensation or evaporation of qc ****** - cnd(i,j)=max(-qc(i,j), cnd(i,j)) - pt(i,j)=pt(i,j)+avcp*cnd(i,j) - qv(i,j)=qv(i,j)-cnd(i,j) - qc(i,j)=qc(i,j)+cnd(i,j) - endif - if (tair(i,j) .le. 258.16) then -!c cnd(i,j)=0.0 - y2(i,j)=1./(tair(i,j)-c76) - qsi(i,j)=rp0*exp(c218-c580*y2(i,j)) - dd1(i,j)=cp580*y2(i,j)*y2(i,j) - dep(i,j)=(qv(i,j)+qb0-qsi(i,j))/(1.+ascp*dd1(i,j)*qsi(i,j)) -!c ****** deposition or sublimation of qi ****** - dep(i,j)=max(-qi(i,j),dep(i,j)) - pt(i,j)=pt(i,j)+ascp*dep(i,j) - qv(i,j)=qv(i,j)-dep(i,j) - qi(i,j)=qi(i,j)+dep(i,j) - endif -!JJS enddo -!JJS enddo - endif - -!c -! -!* 10 * PSDEP : DEPOSITION OR SUBLIMATION OF QS **10** -!* 20 * PGSUB : SUBLIMATION OF QG **20** - -!JJS DO 275 J=3,JLES -!JJS DO 275 I=3,ILES - - psdep(i,j)=0.0 - pssub(i,j)=0.0 - pgsub(i,j)=0.0 - tair(i,j)=(pt(i,j)+tb0)*pi0 - - if(tair(i,j).lt.t0) then - if(qs(i,j).lt.cmin1) qs(i,j)=0.0 - if(qg(i,j).lt.cmin1) qg(i,j)=0.0 - rtair(i,j)=1./(tair(i,j)-c76) - qsi(i,j)=rp0*exp(c218-c580*rtair(i,j)) - ssi(i,j)=(qv(i,j)+qb0)/qsi(i,j)-1. -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - y1(i,j)=r10ar/(tca(i,j)*tair(i,j)**2)+1./(dwv(i,j) & - *qsi(i,j)) - y2(i,j)=.78/zs(i,j)**2+r101f*scv(i,j)/zs(i,j)**bsh5 - psdep(i,j)=r10t*ssi(i,j)*y2(i,j)/y1(i,j) - pssub(i,j)=psdep(i,j) - psdep(i,j)=r2is*max(psdep(i,j), 0.) - pssub(i,j)=r2is*max(-qs(i,j), min(pssub(i,j), 0.)) - - if(ihail.eq.1) then - y2(i,j)=.78/zg(i,j)**2+r20bq*scv(i,j)/zg(i,j)**bgh5 - else - y2(i,j)=.78/zg(i,j)**2+r20bs*scv(i,j)/zg(i,j)**bgh5 - endif - - pgsub(i,j)=r2ig*r20t*ssi(i,j)*y2(i,j)/y1(i,j) - dm(i,j)=qv(i,j)+qb0-qsi(i,j) - rsub1(i,j)=cs580*qsi(i,j)*rtair(i,j)*rtair(i,j) - -! ******** DEPOSITION OR SUBLIMATION OF QS ********************** - - y1(i,j)=dm(i,j)/(1.+rsub1(i,j)) - psdep(i,j)=r2is*min(psdep(i,j),max(y1(i,j),0.)) - y2(i,j)=min(y1(i,j),0.) - pssub(i,j)=r2is*max(pssub(i,j),y2(i,j)) - -! ******** SUBLIMATION OF QG *********************************** - - dd(i,j)=max((-y2(i,j)-qs(i,j)), 0.) - pgsub(i,j)=r2ig*min(dd(i,j), qg(i,j), max(pgsub(i,j),0.)) - - if(qc(i,j)+qi(i,j).gt.1.e-5) then - dlt1(i,j)=1. - else - dlt1(i,j)=0. - endif - - psdep(i,j)=dlt1(i,j)*psdep(i,j) - pssub(i,j)=(1.-dlt1(i,j))*pssub(i,j) - pgsub(i,j)=(1.-dlt1(i,j))*pgsub(i,j) - - pt(i,j)=pt(i,j)+ascp*(psdep(i,j)+pssub(i,j)-pgsub(i,j)) - qv(i,j)=qv(i,j)+pgsub(i,j)-pssub(i,j)-psdep(i,j) - qs(i,j)=qs(i,j)+psdep(i,j)+pssub(i,j) - qg(i,j)=qg(i,j)-pgsub(i,j) - endif - -!* 23 * ERN : EVAPORATION OF QR (SUBSATURATION) **23** - - ern(i,j)=0.0 - - if(qr(i,j).gt.0.0) then - tair(i,j)=(pt(i,j)+tb0)*pi0 - rtair(i,j)=1./(tair(i,j)-c358) - qsw(i,j)=rp0*exp(c172-c409*rtair(i,j)) - ssw(i,j)=(qv(i,j)+qb0)/qsw(i,j)-1.0 - dm(i,j)=qv(i,j)+qb0-qsw(i,j) - rsub1(i,j)=cv409*qsw(i,j)*rtair(i,j)*rtair(i,j) - dd1(i,j)=max(-dm(i,j)/(1.+rsub1(i,j)), 0.0) - y1(i,j)=.78/zr(i,j)**2+r23af*scv(i,j)/zr(i,j)**bwh5 - y2(i,j)=r23br/(tca(i,j)*tair(i,j)**2)+1./(dwv(i,j) & - *qsw(i,j)) -!cccc - ern(i,j)=r23t*ssw(i,j)*y1(i,j)/y2(i,j) - ern(i,j)=min(dd1(i,j),qr(i,j),max(ern(i,j),0.)) - pt(i,j)=pt(i,j)-avcp*ern(i,j) - qv(i,j)=qv(i,j)+ern(i,j) - qr(i,j)=qr(i,j)-ern(i,j) - endif - -!JJS 10/7/2008 vvvvv - ENDIF ! part of if (iwarm.eq.1) then -!JJS 10/7/2008 ^^^^^ - -! IF (QV(I,J)+QB0 .LE. 0.) QV(I,J)=-QB0 - if (qc(i,j) .le. cmin1) qc(i,j)=0. - if (qr(i,j) .le. cmin1) qr(i,j)=0. - if (qi(i,j) .le. cmin1) qi(i,j)=0. - if (qs(i,j) .le. cmin1) qs(i,j)=0. - if (qg(i,j) .le. cmin1) qg(i,j)=0. - dpt(i,j,k)=pt(i,j) - dqv(i,j,k)=qv(i,j) - qcl(i,j,k)=qc(i,j) - qrn(i,j,k)=qr(i,j) - qci(i,j,k)=qi(i,j) - qcs(i,j,k)=qs(i,j) - qcg(i,j,k)=qg(i,j) - -!JJS 275 CONTINUE - - scc=0. - see=0. - -! DO 110 J=3,JLES -! DO 110 I=3,ILES -! DD(I,J)=MAX(-CND(I,J), 0.) -! CND(I,J)=MAX(CND(I,J), 0.) -! DD1(I,J)=MAX(-DEP(I,J), 0.) - -!ccshie 2/21/02 shie follow tao -!CC for reference QI(I,J)=QI(I,J)-Y2(I,J)+PIDEP(I,J)*D2T -!CC for reference QV(I,J)=QV(I,J)-(PIDEP(I,J))*D2T - -!c DEP(I,J)=MAX(DEP(I,J), 0.) -! DEP(I,J)=MAX(DEP(I,J), 0.)+PIDEP(I,J)*D2T -! SCC=SCC+CND(I,J) -! SEE=SEE+DD(I,J)+ERN(I,J) - -! 110 CONTINUE - -! SC(K)=SCC+SC(K) -! SE(K)=SEE+SE(K) - -!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!c henry: please take a look (start) -!JJS modified by JJS on 5/1/2007 vvvvv - -!JJS do 305 j=3,jles -!JJS do 305 i=3,iles - dd(i,j)=max(-cnd(i,j), 0.) - cnd(i,j)=max(cnd(i,j), 0.) - dd1(i,j)=max(-dep(i,j), 0.)+pidep(i,j)*d2t - dep(i,j)=max(dep(i,j), 0.) -!JJS 305 continue - -!JJS do 306 j=3,jles -!JJS do 306 i=3,iles -!JJS scc=scc+cnd(i,j) -!JJS see=see+(dd(i,j)+ern(i,j)) -! -!JJS sddd=sddd+(dep(i,j)+pint(i,j)+psdep(i,j)+pgdep(i,j)) -!JJS ssss=ssss+dd1(i,j) -!JJS -! shhh=shhh+rsw(i,j,k)*d2t -! sccc=sccc+rlw(i,j,k)*d2t -!jjs -!JJS smmm=smmm+(psmlt(i,j)+pgmlt(i,j)+pimlt(i,j)) -!JJS sfff=sfff+d2t*(psacw(i,j)+piacr(i,j)+psfw(i,j) -!JJS 1 +pgfr(i,j)+dgacw(i,j)+dgacr(i,j)+psacr(i,j)) -!JJS 2 -qracs(i,j)+pihom(i,j)+pidw(i,j) - - - sccc=cnd(i,j) - seee=dd(i,j)+ern(i,j) - sddd=dep(i,j)+pint(i,j)+psdep(i,j)+pgdep(i,j) - ssss=dd1(i,j) + pgsub(i,j) - smmm=psmlt(i,j)+pgmlt(i,j)+pimlt(i,j) - sfff=d2t*(psacw(i,j)+piacr(i,j)+psfw(i,j) & - +pgfr(i,j)+dgacw(i,j)+dgacr(i,j)+psacr(i,j) & - +wgacr(i,j))+pihom(i,j)+pidw(i,j) - -! physc(i,k,j) = avcp * sccc / d2t -! physe(i,k,j) = avcp * seee / d2t -! physd(i,k,j) = ascp * sddd / d2t -! physs(i,k,j) = ascp * ssss / d2t -! physf(i,k,j) = afcp * sfff / d2t -! physm(i,k,j) = afcp * smmm / d2t -! physc(i,k,j) = physc(i,k,j) + avcp * sccc -! physe(i,k,j) = physc(i,k,j) + avcp * seee -! physd(i,k,j) = physd(i,k,j) + ascp * sddd -! physs(i,k,j) = physs(i,k,j) + ascp * ssss -! physf(i,k,j) = physf(i,k,j) + afcp * sfff -! physm(i,k,j) = physm(i,k,j) + afcp * smmm - -!JJS modified by JJS on 5/1/2007 ^^^^^ - - 2000 continue - - 1000 continue - -!JJS **************************************************************** -!JJS convert from GCE grid back to WRF grid - do k=kts,kte - do j=jts,jte - do i=its,ite - ptwrf(i,k,j) = dpt(i,j,k) - qvwrf(i,k,j) = dqv(i,j,k) - qlwrf(i,k,j) = qcl(i,j,k) - qrwrf(i,k,j) = qrn(i,j,k) - qiwrf(i,k,j) = qci(i,j,k) - qswrf(i,k,j) = qcs(i,j,k) - qgwrf(i,k,j) = qcg(i,j,k) - enddo !i - enddo !j - enddo !k - -! **************************************************************** - - return - END SUBROUTINE saticel_s - -!JJS -!JJS REAL FUNCTION GAMMA(X) -!JJS Y=GAMMLN(X) -!JJS GAMMA=EXP(Y) -!JJS RETURN -!JJS END -!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!JJS real function GAMMLN (xx) - real function gammagce (xx) -!********************************************************************** - real*8 cof(6),stp,half,one,fpf,x,tmp,ser - data cof,stp / 76.18009173,-86.50532033,24.01409822, & - -1.231739516,.120858003e-2,-.536382e-5, 2.50662827465 / - data half,one,fpf / .5, 1., 5.5 / -! - x=xx-one - tmp=x+fpf - tmp=(x+half)*log(tmp)-tmp - ser=one - do j=1,6 - x=x+one - ser=ser+cof(j)/x - enddo !j - gammln=tmp+log(stp*ser) -!JJS - gammagce=exp(gammln) -!JJS - return - END FUNCTION gammagce - -END MODULE module_mp_gsfcgce diff --git a/src/fim/FIMsrc/fim/wrfphys/module_mp_kessler.F b/src/fim/FIMsrc/fim/wrfphys/module_mp_kessler.F deleted file mode 100644 index 7dd2e36..0000000 --- a/src/fim/FIMsrc/fim/wrfphys/module_mp_kessler.F +++ /dev/null @@ -1,244 +0,0 @@ -!WRF:MODEL_LAYER:PHYSICS -! - -MODULE module_mp_kessler - -CONTAINS -!---------------------------------------------------------------- - SUBROUTINE kessler( t, qv, qc, qr, rho, pii & - ,dt_in, z, xlv, cp & - ,EP2,SVP1,SVP2,SVP3,SVPT0,rhowater & - ,dz8w & - ,RAINNC, RAINNCV & - ,ids,ide, jds,jde, kds,kde & ! domain dims - ,ims,ime, jms,jme, kms,kme & ! memory dims - ,its,ite, jts,jte, kts,kte & ! tile dims - ) -!---------------------------------------------------------------- - IMPLICIT NONE -!---------------------------------------------------------------- - ! taken from the COMMAS code - WCS 10 May 1999. - ! converted from FORTRAN 77 to 90, tiled, WCS 10 May 1999. -!---------------------------------------------------------------- - REAL , PARAMETER :: c1 = .001 - REAL , PARAMETER :: c2 = .001 - REAL , PARAMETER :: c3 = 2.2 - REAL , PARAMETER :: c4 = .875 - REAL , PARAMETER :: fudge = 1.0 - REAL , PARAMETER :: mxfall = 10.0 -!---------------------------------------------------------------- - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - REAL , INTENT(IN ) :: xlv, cp - REAL , INTENT(IN ) :: EP2,SVP1,SVP2,SVP3,SVPT0 - REAL , INTENT(IN ) :: rhowater - - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(INOUT) :: & - t , & - qv, & - qc, & - qr - - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: & - rho, & - pii, & - dz8w - - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: z - - REAL, INTENT(IN ) :: dt_in - - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(INOUT) :: RAINNC, & - RAINNCV - - - - ! local variables - - REAL :: qrprod, ern, gam, rcgs, rcgsi - REAL, DIMENSION( its:ite , kts:kte, jts:jte ) :: prod - REAL, DIMENSION(kts:kte) :: vt, prodk, vtden,rdzk,rhok,factor,rdzw - INTEGER :: i,j,k - INTEGER :: nfall, n, nfall_new - REAL :: qrr, pressure, temp, es, qvs, dz, dt - REAL :: f5, dtfall, rdz, product - REAL :: max_heating, max_condense, max_rain, maxqrp - REAL :: vtmax, ernmax, crmax, factorn, time_sediment - REAL :: qcr, factorr, ppt - REAL, PARAMETER :: max_cr_sedimentation = 0.75 -!---------------------------------------------------------------- - - INTEGER :: imax, kmax - - dt = dt_in - -! f5 = 237.3 * 17.27 * 2.5e6 / cp - f5 = svp2*(svpt0-svp3)*xlv/cp - ernmax = 0. - maxqrp = -100. - -!------------------------------------------------------------------------------ -! parameters for the time split terminal advection -!------------------------------------------------------------------------------ - - max_heating = 0. - max_condense = 0. - max_rain = 0. - -!----------------------------------------------------------------------------- -! outer J loop for entire microphysics, outer i loop for sedimentation -!----------------------------------------------------------------------------- - - microphysics_outer_j_loop: DO j = jts, jte - - sedimentation_outer_i_loop: DO i = its,ite - -! vtmax = 0. - crmax = 0. - - -!------------------------------------------------------------------------------ -! Terminal velocity calculation and advection, set up coefficients and -! compute stable timestep -!------------------------------------------------------------------------------ - - DO k = 1, kte - prodk(k) = qr(i,k,j) - rhok(k) = rho(i,k,j) - qrr = amax1(0.,qr(i,k,j)*0.001*rhok(k)) - vtden(k) = sqrt(rhok(1)/rhok(k)) - vt(k) = 36.34*(qrr**0.1364) * vtden(k) -! vtmax = amax1(vt(k), vtmax) - rdzw(k) = 1./dz8w(i,k,j) - crmax = amax1(vt(k)*dt*rdzw(k),crmax) - ENDDO - DO k = 1, kte-1 - rdzk(k) = 1./(z(i,k+1,j) - z(i,k,j)) - ENDDO - rdzk(kte) = 1./(z(i,kte,j) - z(i,kte-1,j)) - - nfall = max(1,nint(0.5+crmax/max_cr_sedimentation)) ! courant number for big timestep. - dtfall = dt / float(nfall) ! splitting so courant number for sedimentation - time_sediment = dt ! is stable - -!------------------------------------------------------------------------------ -! Terminal velocity calculation and advection -! Do a time split loop on this for stability. -!------------------------------------------------------------------------------ - - column_sedimentation: DO WHILE ( nfall > 0 ) - - time_sediment = time_sediment - dtfall - DO k = 1, kte-1 - factor(k) = dtfall*rdzk(k)/rhok(k) - ENDDO - factor(kte) = dtfall*rdzk(kte) - - ppt=0. - - k = 1 - ppt=rhok(k)*prodk(k)*vt(k)*dtfall/rhowater - RAINNCV(i,j)=ppt*1000. - RAINNC(i,j)=RAINNC(i,j)+ppt*1000. ! unit = mm - -!------------------------------------------------------------------------------ -! Time split loop, Fallout done with flux upstream -!------------------------------------------------------------------------------ - - DO k = kts, kte-1 - prodk(k) = prodk(k) - factor(k) & - * (rhok(k)*prodk(k)*vt(k) & - -rhok(k+1)*prodk(k+1)*vt(k+1)) - ENDDO - - k = kte - prodk(k) = prodk(k) - factor(k)*prodk(k)*vt(k) - -!------------------------------------------------------------------------------ -! compute new sedimentation velocity, and check/recompute new -! sedimentation timestep if this isn't the last split step. -!------------------------------------------------------------------------------ - - IF( nfall > 1 ) THEN ! this wasn't the last split sedimentation timestep - - nfall = nfall - 1 - crmax = 0. - DO k = kts, kte - qrr = amax1(0.,prodk(k)*0.001*rhok(k)) - vt(k) = 36.34*(qrr**0.1364) * vtden(k) -! vtmax = amax1(vt(k), vtmax) - crmax = amax1(vt(k)*time_sediment*rdzw(k),crmax) - ENDDO - - nfall_new = max(1,nint(0.5+crmax/max_cr_sedimentation)) - if (nfall_new /= nfall ) then - nfall = nfall_new - dtfall = time_sediment/nfall - end if - - ELSE ! this was the last timestep - - DO k=kts,kte - prod(i,k,j) = prodk(k) - ENDDO - nfall = 0 ! exit condition for sedimentation loop - - END IF - - ENDDO column_sedimentation - - ENDDO sedimentation_outer_i_loop - -!------------------------------------------------------------------------------ -! Production of rain and deletion of qc -! Production of qc from supersaturation -! Evaporation of QR -!------------------------------------------------------------------------------ - - DO k = kts, kte - DO i = its, ite - factorn = 1.0 / (1.+c3*dt*amax1(0.,qr(i,k,j))**c4) - qrprod = qc(i,k,j) * (1.0 - factorn) & - + factorn*c1*dt*amax1(qc(i,k,j)-c2,0.) - rcgs = 0.001*rho(i,k,j) - - qc(i,k,j) = amax1(qc(i,k,j) - qrprod,0.) - qr(i,k,j) = (qr(i,k,j) + prod(i,k,j)-qr(i,k,j)) - qr(i,k,j) = amax1(qr(i,k,j) + qrprod,0.) - - temp = pii(i,k,j)*t(i,k,j) - pressure = 1.000e+05 * (pii(i,k,j)**(1004./287.)) - gam = 2.5e+06/(1004.*pii(i,k,j)) -! qvs = 380.*exp(17.27*(temp-273.)/(temp- 36.))/pressure - es = 1000.*svp1*exp(svp2*(temp-svpt0)/(temp-svp3)) - qvs = ep2*es/(pressure-es) -! prod(i,k,j) = (qv(i,k,j)-qvs) / (1.+qvs*f5/(temp-36.)**2) - prod(i,k,j) = (qv(i,k,j)-qvs) / (1.+pressure/(pressure-es)*qvs*f5/(temp-svp3)**2) - ern = amin1(dt*(((1.6+124.9*(rcgs*qr(i,k,j))**.2046) & - *(rcgs*qr(i,k,j))**.525)/(2.55e8/(pressure*qvs) & - +5.4e5))*(dim(qvs,qv(i,k,j))/(rcgs*qvs)), & - amax1(-prod(i,k,j)-qc(i,k,j),0.),qr(i,k,j)) - -! Update all variables - - product = amax1(prod(i,k,j),-qc(i,k,j)) - t (i,k,j) = t(i,k,j) + gam*(product - ern) - qv(i,k,j) = amax1(qv(i,k,j) - product + ern,0.) - qc(i,k,j) = qc(i,k,j) + product - qr(i,k,j) = qr(i,k,j) - ern - - ENDDO - ENDDO - - ENDDO microphysics_outer_j_loop - - RETURN - - END SUBROUTINE kessler - -END MODULE module_mp_kessler diff --git a/src/fim/FIMsrc/fim/wrfphys/module_mp_lin.F b/src/fim/FIMsrc/fim/wrfphys/module_mp_lin.F deleted file mode 100644 index 04d1441..0000000 --- a/src/fim/FIMsrc/fim/wrfphys/module_mp_lin.F +++ /dev/null @@ -1,2629 +0,0 @@ -!WRF:MODEL_LAYER:PHYSICS -! - -MODULE module_mp_lin - -! USE module_wrf_error -! - REAL , PARAMETER, PRIVATE :: RH = 1.0 -! REAL , PARAMETER, PRIVATE :: episp0 = 0.622*611.21 - REAL , PARAMETER, PRIVATE :: xnor = 8.0e6 - REAL , PARAMETER, PRIVATE :: xnos = 3.0e6 - -! Lin -! REAL , PARAMETER, PRIVATE :: xnog = 4.0e4 -! REAL , PARAMETER, PRIVATE :: rhograul = 917. - -! Hobbs - REAL , PARAMETER, PRIVATE :: xnog = 4.0e6 - REAL , PARAMETER, PRIVATE :: rhograul = 400. - -! - REAL , PARAMETER, PRIVATE :: & - qi0 = 1.0e-3, ql0 = 7.0e-4, qs0 = 6.0E-4, & - xmi50 = 4.8e-10, xmi40 = 2.46e-10, & - constb = 0.8, constd = 0.25, & - o6 = 1./6., cdrag = 0.6, & - avisc = 1.49628e-6, adiffwv = 8.7602e-5, & - axka = 1.4132e3, di50 = 1.0e-4, xmi = 4.19e-13, & - cw = 4.187e3, vf1s = 0.78, vf2s = 0.31, & - xni0 = 1.0e-2, xmnin = 1.05e-18, bni = 0.5, & - ci = 2.093e3 -CONTAINS - -!------------------------------------------------------------------- -! Lin et al., 1983, JAM, 1065-1092, and -! Rutledge and Hobbs, 1984, JAS, 2949-2972 -!------------------------------------------------------------------- - SUBROUTINE lin_et_al(th & - ,qv, ql, qr & - ,qi, qs & - ,rho, pii, p & - ,dt_in & - ,z,ht, dz8w & - ,grav, cp, Rair, rvapor & - ,XLS, XLV, XLF, rhowater, rhosnow & - ,EP2,SVP1,SVP2,SVP3,SVPT0 & - , RAINNC, RAINNCV & - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte & - ! Optional - ,qlsink, precr, preci, precs, precg & - , F_QG,F_QNDROP & - , qg, qndrop & - ) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -! -! Shuhua 12/17/99 -! - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & - ims,ime, jms,jme, kms,kme , & - its,ite, jts,jte, kts,kte - - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(INOUT) :: & - th, & - qv, & - ql, & - qr - -! - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: & - rho, & - pii, & - p, & - dz8w - - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: z - - - - REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN) :: ht - - REAL, INTENT(IN ) :: dt_in, & - grav, & - Rair, & - rvapor, & - cp, & - XLS, & - XLV, & - XLF, & - rhowater, & - rhosnow - - REAL, INTENT(IN ) :: EP2,SVP1,SVP2,SVP3,SVPT0 - - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(INOUT) :: RAINNC, & - RAINNCV - -! Optional - - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - OPTIONAL, & - INTENT(INOUT) :: & - qi, & - qs, & - qg, & - qndrop - - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - OPTIONAL, INTENT(OUT ) :: & - qlsink, & ! cloud water conversion to rain (/s) - precr, & ! rain precipitation rate at all levels (kg/m2/s) - preci, & ! ice precipitation rate at all levels (kg/m2/s) - precs, & ! snow precipitation rate at all levels (kg/m2/s) - precg ! graupel precipitation rate at all levels (kg/m2/s) - - LOGICAL, INTENT(IN), OPTIONAL :: F_QG, F_QNDROP - -! LOCAL VAR - - INTEGER :: min_q, max_q - - REAL, DIMENSION( its:ite , jts:jte ) & - :: rain, snow, graupel,ice - - REAL, DIMENSION( kts:kte ) :: qvz, qlz, qrz, & - qiz, qsz, qgz, & - thz, & - tothz, rhoz, & - orhoz, sqrhoz, & - prez, zz, & - precrz, preciz, precsz, precgz, & - qndropz, & - dzw, preclw - - LOGICAL :: flag_qg, flag_qndrop -! - REAL :: dt, pptrain, pptsnow, pptgraul, rhoe_s, & - gindex, pptice - real :: qndropconst - - INTEGER :: i,j,k -! - flag_qg = .false. - flag_qndrop = .false. - IF ( PRESENT ( f_qg ) ) flag_qg = f_qg - IF ( PRESENT ( f_qndrop ) ) flag_qndrop = f_qndrop -! - dt=dt_in - rhoe_s=1.29 - qndropconst=100.e6 !sg - gindex=1.0 - - IF (.not.flag_qg) gindex=0. - - j_loop: DO j = jts, jte - i_loop: DO i = its, ite -! -!- write data from 3-D to 1-D -! - DO k = kts, kte - qvz(k)=qv(i,k,j) - qlz(k)=ql(i,k,j) - qrz(k)=qr(i,k,j) - thz(k)=th(i,k,j) -! - rhoz(k)=rho(i,k,j) - orhoz(k)=1./rhoz(k) - prez(k)=p(i,k,j) - sqrhoz(k)=sqrt(rhoe_s*orhoz(k)) - tothz(k)=pii(i,k,j) - zz(k)=z(i,k,j) - dzw(k)=dz8w(i,k,j) - END DO - - IF (flag_qndrop .AND. PRESENT( qndrop )) THEN - DO k = kts, kte - qndropz(k)=qndrop(i,k,j) - ENDDO - ELSE - DO k = kts, kte - qndropz(k)=qndropconst - ENDDO - ENDIF - - DO k = kts, kte - qiz(k)=qi(i,k,j) - qsz(k)=qs(i,k,j) - ENDDO - - IF ( flag_qg .AND. PRESENT( qg ) ) THEN - DO k = kts, kte - qgz(k)=qg(i,k,j) - ENDDO - ELSE - DO k = kts, kte - qgz(k)=0. - ENDDO - ENDIF -! - pptrain=0. - pptsnow=0. - pptgraul=0. - pptice=0. - CALL clphy1d( dt, qvz, qlz, qrz, qiz, qsz, qgz, & - qndropz,flag_qndrop, & - thz, tothz, rhoz, orhoz, sqrhoz, & - prez, zz, dzw, ht(I,J), preclw, & - precrz, preciz, precsz, precgz, & - pptrain, pptsnow, pptgraul, pptice, & - grav, cp, Rair, rvapor, gindex, & - XLS, XLV, XLF, rhowater, rhosnow, & - EP2,SVP1,SVP2,SVP3,SVPT0, & - kts, kte, i, j ) - -! -! Precipitation from cloud microphysics -- only for one time step -! -! unit is transferred from m to mm - -! - rain(i,j)=pptrain - snow(i,j)=pptsnow - graupel(i,j)=pptgraul - ice(i,j)=pptice -! - RAINNCV(i,j)= pptrain + pptsnow + pptgraul + pptice - RAINNC(i,j)=RAINNC(i,j) + pptrain + pptsnow + pptgraul + pptice - -! -!- update data from 1-D back to 3-D -! -! - IF ( present(qlsink) .and. present(precr) ) THEN !sg beg - DO k = kts, kte - if(ql(i,k,j)>1.e-20) then - qlsink(i,k,j)=-preclw(k)/ql(i,k,j) - else - qlsink(i,k,j)=0. - endif - precr(i,k,j)=precrz(k) - END DO - END IF !sg end - - DO k = kts, kte - qv(i,k,j)=qvz(k) - ql(i,k,j)=qlz(k) - qr(i,k,j)=qrz(k) - th(i,k,j)=thz(k) - END DO -! - IF ( flag_qndrop .AND. PRESENT( qndrop ) ) THEN !sg beg - DO k = kts, kte - qndrop(i,k,j)=qndropz(k) - ENDDO - END IF !sg end - - DO k = kts, kte - qi(i,k,j)=qiz(k) - qs(i,k,j)=qsz(k) - ENDDO - - IF ( present(preci) ) THEN !sg beg - DO k = kts, kte - preci(i,k,j)=preciz(k) - ENDDO - END IF - - IF ( present(precs) ) THEN - DO k = kts, kte - precs(i,k,j)=precsz(k) - ENDDO - END IF !sg end - - IF ( flag_qg .AND. PRESENT( qg ) ) THEN - DO k = kts, kte - qg(i,k,j)=qgz(k) - ENDDO - - IF ( present(precg) ) THEN !sg beg - DO k = kts, kte - precg(i,k,j)=precgz(k) - ENDDO !sg end - END IF - ELSE !sg beg - IF ( present(precg) ) precg(i,:,j)=0. !sg end - ENDIF -! - ENDDO i_loop - ENDDO j_loop - - END SUBROUTINE lin_et_al - - -!----------------------------------------------------------------------- - SUBROUTINE clphy1d(dt, qvz, qlz, qrz, qiz, qsz, qgz, & - qndropz,flag_qndrop, & - thz, tothz, rho, orho, sqrho, & - prez, zz, dzw, zsfc, preclw, & - precrz, preciz, precsz, precgz, & - pptrain, pptsnow, pptgraul, & - pptice, grav, cp, Rair, rvapor, gindex, & - XLS, XLV, XLF, rhowater, rhosnow, & - EP2,SVP1,SVP2,SVP3,SVPT0, & - kts, kte, i, j ) -!----------------------------------------------------------------------- - IMPLICIT NONE -!----------------------------------------------------------------------- -! This program handles the vertical 1-D cloud micphysics -!----------------------------------------------------------------------- -! avisc: constant in empirical formular for dynamic viscosity of air -! =1.49628e-6 [kg/m/s] = 1.49628e-5 [g/cm/s] -! adiffwv: constant in empirical formular for diffusivity of water -! vapor in air -! = 8.7602e-5 [kgm/s3] = 8.7602 [gcm/s3] -! axka: constant in empirical formular for thermal conductivity of air -! = 1.4132e3 [m2/s2/K] = 1.4132e7 [cm2/s2/K] -! qi0: mixing ratio threshold for cloud ice aggregation [kg/kg] -! xmi50: mass of a 50 micron ice crystal -! = 4.8e-10 [kg] =4.8e-7 [g] -! xmi40: mass of a 40 micron ice crystal -! = 2.46e-10 [kg] = 2.46e-7 [g] -! di50: diameter of a 50 micro (radius) ice crystal -! =1.0e-4 [m] -! xmi: mass of one cloud ice crystal -! =4.19e-13 [kg] = 4.19e-10 [g] -! oxmi=1.0/xmi -! -! xni0=1.0e-2 [m-3] The value given in Lin et al. is wrong.(see -! Hsie et al.(1980) and Rutledge and Hobbs(1983) ) -! bni=0.5 [K-1] -! xmnin: mass of a natural ice nucleus -! = 1.05e-18 [kg] = 1.05e-15 [g] This values is suggested by -! Hsie et al. (1980) -! = 1.0e-12 [kg] suggested by Rutlegde and Hobbs (1983) -! rhowater: density of water=1.0 g/cm3=1000.0 kg/m3 -! consta: constant in empirical formular for terminal -! velocity of raindrop -! =2115.0 [cm**(1-b)/s] = 2115.0*0.01**(1-b) [m**(1-b)/s] -! constb: constant in empirical formular for terminal -! velocity of raindrop -! =0.8 -! xnor: intercept parameter of the raindrop size distribution -! = 0.08 cm-4 = 8.0e6 m-4 -! araut: time sacle for autoconversion of cloud water to raindrops -! =1.0e-3 [s-1] -! ql0: mixing ratio threshold for cloud watercoalescence [kg/kg] -! vf1r: ventilation factors for rain =0.78 -! vf2r: ventilation factors for rain =0.31 -! rhosnow: density of snow=0.1 g/cm3=100.0 kg/m3 -! constc: constant in empirical formular for terminal -! velocity of snow -! =152.93 [cm**(1-d)/s] = 152.93*0.01**(1-d) [m**(1-d)/s] -! constd: constant in empirical formular for terminal -! velocity of snow -! =0.25 -! xnos: intercept parameter of the snowflake size distribution -! vf1s: ventilation factors for snow =0.78 -! vf2s: ventilation factors for snow =0.31 -! -!---------------------------------------------------------------------- - - INTEGER, INTENT(IN ) :: kts, kte, i, j - - REAL, DIMENSION( kts:kte ), & - INTENT(INOUT) :: qvz, qlz, qrz, qiz, qsz, & - qndropz, & - qgz, thz - - REAL, DIMENSION( kts:kte ), & - INTENT(IN ) :: tothz, rho, orho, sqrho, & - prez, zz, dzw - - REAL, INTENT(IN ) :: dt, grav, cp, Rair, rvapor, & - XLS, XLV, XLF, rhowater, & - rhosnow,EP2,SVP1,SVP2,SVP3,SVPT0 - - REAL, DIMENSION( kts:kte ), INTENT(OUT) :: preclw, & - precrz, preciz, precsz, precgz - - REAL, INTENT(INOUT) :: pptrain, pptsnow, pptgraul, pptice - - REAL, INTENT(IN ) :: zsfc - logical, intent(in) :: flag_qndrop !sg - -! local vars - - REAL :: obp4, bp3, bp5, bp6, odp4, & - dp3, dp5, dp5o2 - - -! temperary vars - - REAL :: tmp, tmp0, tmp1, tmp2,tmp3, & - tmp4,delta2,delta3, delta4, & - tmpa,tmpb,tmpc,tmpd,alpha1, & - qic, abi,abr, abg, odtberg, & - vti50,eiw,eri,esi,esr, esw, & - erw,delrs,term0,term1,araut, & - constg2, vf1r, vf2r,alpha2, & - Ap, Bp, egw, egi, egs, egr, & - constg, gdelta4, g1sdelt4, & - factor, tmp_r, tmp_s,tmp_g, & - qlpqi, rsat, a1, a2, xnin - - INTEGER :: k -! - REAL, DIMENSION( kts:kte ) :: oprez, tem, temcc, theiz, qswz, & - qsiz, qvoqswz, qvoqsiz, qvzodt, & - qlzodt, qizodt, qszodt, qrzodt, & - qgzodt - - REAL, DIMENSION( kts:kte ) :: psnow, psaut, psfw, psfi, praci, & - piacr, psaci, psacw, psdep, pssub, & - pracs, psacr, psmlt, psmltevp, & - prain, praut, pracw, prevp, pvapor, & - pclw, pladj, pcli, pimlt, pihom, & - pidw, piadj, pgraupel, pgaut, & - pgfr, pgacw, pgaci, pgacr, pgacs, & - pgacip,pgacrp,pgacsp,pgwet, pdry, & - pgsub, pgdep, pgmlt, pgmltevp, & - qschg, qgchg -! - - REAL, DIMENSION( kts:kte ) :: qvsbar, rs0, viscmu, visc, diffwv, & - schmidt, xka - - REAL, DIMENSION( kts:kte ) :: vtr, vts, vtg, & - vtrold, vtsold, vtgold, vtiold, & - xlambdar, xlambdas, xlambdag, & - olambdar, olambdas, olambdag - - REAL :: episp0k, dtb, odtb, pi, pio4, & - pio6, oxLf, xLvocp, xLfocp, consta, & - constc, ocdrag, gambp4, gamdp4, & - gam4pt5, Cpor, oxmi, gambp3, gamdp3,& - gambp6, gam3pt5, gam2pt75, gambp5o2,& - gamdp5o2, cwoxlf, ocp, xni50, es -! - REAL :: qvmin=1.e-20 - REAL :: gindex - REAL :: temc1,save1,save2,xni50mx - -! for terminal velocity flux - - INTEGER :: min_q, max_q - REAL :: t_del_tv, del_tv, flux, fluxin, fluxout ,tmpqrz - LOGICAL :: notlast -! - -!sg: begin -! liqconc = liquid water content in gcm^-3 -! capn = droplet number concentration cm^-3 -! dis = relative dispersion (dimensionless) between 0.2 and 1. -! Written by Yangang Liu based on Liu et al., GRL 32, 2005. -! Autoconversion rate P = P0*T -! p0 = rate function -! kappa = constant in Long kernel -! beta = Condensation rate constant -! xc = Normalized critical mass -! *********************************************************** - real liqconc, dis, beta, kappa, p0, xc, capn,rhocgs - if(flag_qndrop)then - dis = 0.5 ! droplet dispersion, set to 0.5 per SG 8-Nov-2006 -! Give empirical constants - kappa=1.1d10 -! Calculate Condensation rate constant - beta = (1.0d0+3.0d0*dis**2)*(1.0d0+4.0d0*dis**2)* & - (1.0d0+5.0d0*dis**2)/((1.0d0+dis**2)*(1.0d0+2.0d0*dis**2)) - endif -!sg: end - - dtb=dt - odtb=1./dtb - pi=acos(-1.) - pio4=acos(-1.)/4. - pio6=acos(-1.)/6. - ocp=1./cp - oxLf=1./xLf - xLvocp=xLv/cp - xLfocp=xLf/cp - consta=2115.0*0.01**(1-constb) - constc=152.93*0.01**(1-constd) - ocdrag=1./Cdrag -! episp0k=RH*episp0 - episp0k=RH*ep2*1000.*svp1 -! - gambp4=ggamma(constb+4.) - gamdp4=ggamma(constd+4.) - gam4pt5=ggamma(4.5) - Cpor=cp/Rair - oxmi=1.0/xmi - gambp3=ggamma(constb+3.) - gamdp3=ggamma(constd+3.) - gambp6=ggamma(constb+6) - gam3pt5=ggamma(3.5) - gam2pt75=ggamma(2.75) - gambp5o2=ggamma((constb+5.)/2.) - gamdp5o2=ggamma((constd+5.)/2.) - cwoxlf=cw/xlf - delta2=0. - delta3=0. - delta4=0. -! -!----------------------------------------------------------------------- -! oprez 1./prez ( prez : pressure) -! qsw saturated mixing ratio on water surface -! qsi saturated mixing ratio on ice surface -! episp0k RH*e*saturated pressure at 273.15 K -! qvoqsw qv/qsw -! qvoqsi qv/qsi -! qvzodt qv/dt -! qlzodt ql/dt -! qizodt qi/dt -! qszodt qs/dt -! qrzodt qr/dt -! qgzodt qg/dt -! -! temcc temperature in dregee C -! - - obp4=1.0/(constb+4.0) - bp3=constb+3.0 - bp5=constb+5.0 - bp6=constb+6.0 - odp4=1.0/(constd+4.0) - dp3=constd+3.0 - dp5=constd+5.0 - dp5o2=0.5*(constd+5.0) -! - do k=kts,kte - oprez(k)=1./prez(k) - enddo - - do k=kts,kte - qlz(k)=amax1( 0.0,qlz(k) ) - qiz(k)=amax1( 0.0,qiz(k) ) - qvz(k)=amax1( qvmin,qvz(k) ) - qsz(k)=amax1( 0.0,qsz(k) ) - qrz(k)=amax1( 0.0,qrz(k) ) - qgz(k)=amax1( 0.0,qgz(k) ) - qndropz(k)=amax1( 0.0,qndropz(k) ) !sg -! - tem(k)=thz(k)*tothz(k) - temcc(k)=tem(k)-273.15 -! -! qswz(k)=episp0k*oprez(k)* & -! exp( svp2*temcc(k)/(tem(k)-svp3) ) - es=1000.*svp1*exp( svp2*temcc(k)/(tem(k)-svp3) ) - qswz(k)=ep2*es/(prez(k)-es) - if (tem(k) .lt. 273.15 ) then -! qsiz(k)=episp0k*oprez(k)* & -! exp( 21.8745584*(tem(k)-273.16)/(tem(k)-7.66) ) - es=1000.*svp1*exp( 21.8745584*(tem(k)-273.16)/(tem(k)-7.66) ) - qsiz(k)=ep2*es/(prez(k)-es) - if (temcc(k) .lt. -40.0) qswz(k)=qsiz(k) - else - qsiz(k)=qswz(k) - endif -! - qvoqswz(k)=qvz(k)/qswz(k) - qvoqsiz(k)=qvz(k)/qsiz(k) - - theiz(k)=thz(k)+(xlvocp*qvz(k)-xlfocp*qiz(k))/tothz(k) - enddo - - -! -! -!----------------------------------------------------------------------- -! In this simple stable cloud parameterization scheme, only five -! forms of water substance (water vapor, cloud water, cloud ice, -! rain and snow are considered. The prognostic variables are total -! water (qp),cloud water (ql), and cloud ice (qi). Rain and snow are -! diagnosed following Nagata and Ogura, 1991, MWR, 1309-1337. Eq (A7). -! the micro physics are based on (1) Hsie et al.,1980, JAM, 950-977 ; -! (2) Lin et al., 1983, JAM, 1065-1092 ; (3) Rutledge and Hobbs, 1983, -! JAS, 1185-1206 ; (4) Rutledge and Hobbs, 1984, JAS, 2949-2972. -!----------------------------------------------------------------------- -! -! rhowater: density of water=1.0 g/cm3=1000.0 kg/m3 -! rhosnow: density of snow=0.1 g/cm3=100.0 kg/m3 -! xnor: intercept parameter of the raindrop size distribution -! = 0.08 cm-4 = 8.0e6 m-4 -! xnos: intercept parameter of the snowflake size distribution -! = 0.03 cm-4 = 3.0e6 m-4 -! xnog: intercept parameter of the graupel size distribution -! = 4.0e-4 cm-4 = 4.0e4 m-4 -! consta: constant in empirical formular for terminal -! velocity of raindrop -! =2115.0 [cm**(1-b)/s] = 2115.0*0.01**(1-b) [m**(1-b)/s] -! constb: constant in empirical formular for terminal -! velocity of raindrop -! =0.8 -! constc: constant in empirical formular for terminal -! velocity of snow -! =152.93 [cm**(1-d)/s] = 152.93*0.01**(1-d) [m**(1-d)/s] -! constd: constant in empirical formular for terminal -! velocity of snow -! =0.25 -! avisc: constant in empirical formular for dynamic viscosity of air -! =1.49628e-6 [kg/m/s] = 1.49628e-5 [g/cm/s] -! adiffwv: constant in empirical formular for diffusivity of water -! vapor in air -! = 8.7602e-5 [kgm/s3] = 8.7602 [gcm/s3] -! axka: constant in empirical formular for thermal conductivity of air -! = 1.4132e3 [m2/s2/K] = 1.4132e7 [cm2/s2/K] -! qi0: mixing ratio threshold for cloud ice aggregation [kg/kg] -! = 1.0e-3 g/g = 1.0e-3 kg/gk -! ql0: mixing ratio threshold for cloud watercoalescence [kg/kg] -! = 2.0e-3 g/g = 2.0e-3 kg/gk -! qs0: mixing ratio threshold for snow aggregation -! = 6.0e-4 g/g = 6.0e-4 kg/gk -! xmi50: mass of a 50 micron ice crystal -! = 4.8e-10 [kg] =4.8e-7 [g] -! xmi40: mass of a 40 micron ice crystal -! = 2.46e-10 [kg] = 2.46e-7 [g] -! di50: diameter of a 50 micro (radius) ice crystal -! =1.0e-4 [m] -! xmi: mass of one cloud ice crystal -! =4.19e-13 [kg] = 4.19e-10 [g] -! oxmi=1.0/xmi -! - - -! if gindex=1.0 include graupel -! if gindex=0. no graupel -! -! - do k=kts,kte - psnow(k)=0.0 - psaut(k)=0.0 - psfw(k)=0.0 - psfi(k)=0.0 - praci(k)=0.0 - piacr(k)=0.0 - psaci(k)=0.0 - psacw(k)=0.0 - psdep(k)=0.0 - pssub(k)=0.0 - pracs(k)=0.0 - psacr(k)=0.0 - psmlt(k)=0.0 - psmltevp(k)=0.0 -! - prain(k)=0.0 - praut(k)=0.0 - pracw(k)=0.0 - prevp(k)=0.0 -! - pvapor(k)=0.0 -! - pclw(k)=0.0 - preclw(k)=0.0 !sg - pladj(k)=0.0 -! - pcli(k)=0.0 - pimlt(k)=0.0 - pihom(k)=0.0 - pidw(k)=0.0 - piadj(k)=0.0 - enddo - -! -!!! graupel -! - do k=kts,kte - pgraupel(k)=0.0 - pgaut(k)=0.0 - pgfr(k)=0.0 - pgacw(k)=0.0 - pgaci(k)=0.0 - pgacr(k)=0.0 - pgacs(k)=0.0 - pgacip(k)=0.0 - pgacrP(k)=0.0 - pgacsp(k)=0.0 - pgwet(k)=0.0 - pdry(k)=0.0 - pgsub(k)=0.0 - pgdep(k)=0.0 - pgmlt(k)=0.0 - pgmltevp(k)=0.0 - qschg(k)=0. - qgchg(k)=0. - enddo -! -! -! Set rs0=episp0*oprez(k) -! episp0=e*saturated pressure at 273.15 K -! e = 0.622 -! - DO k=kts,kte - rs0(k)=ep2*1000.*svp1/(prez(k)-1000.*svp1) - END DO -! -!*********************************************************************** -! Calculate precipitation fluxes due to terminal velocities. -!*********************************************************************** -! -!- Calculate termianl velocity (vt?) of precipitation q?z -!- Find maximum vt? to determine the small delta t -! -!-- rain -! - t_del_tv=0. - del_tv=dtb - notlast=.true. - DO while (notlast) -! - min_q=kte - max_q=kts-1 -! - do k=kts,kte-1 - if (qrz(k) .gt. 1.0e-8) then - min_q=min0(min_q,k) - max_q=max0(max_q,k) - tmp1=sqrt(pi*rhowater*xnor/rho(k)/qrz(k)) - tmp1=sqrt(tmp1) - vtrold(k)=o6*consta*gambp4*sqrho(k)/tmp1**constb - if (k .eq. 1) then - del_tv=amin1(del_tv,0.9*(zz(k)-zsfc)/vtrold(k)) - else - del_tv=amin1(del_tv,0.9*(zz(k)-zz(k-1))/vtrold(k)) - endif - else - vtrold(k)=0. - endif - enddo - - if (max_q .ge. min_q) then -! -!- Check if the summation of the small delta t >= big delta t -! (t_del_tv) (del_tv) (dtb) - - t_del_tv=t_del_tv+del_tv -! - if ( t_del_tv .ge. dtb ) then - notlast=.false. - del_tv=dtb+del_tv-t_del_tv - endif -! - fluxin=0. - do k=max_q,min_q,-1 - fluxout=rho(k)*vtrold(k)*qrz(k) - flux=(fluxin-fluxout)/rho(k)/dzw(k) - tmpqrz=qrz(k) - qrz(k)=qrz(k)+del_tv*flux - fluxin=fluxout - enddo - if (min_q .eq. 1) then - pptrain=pptrain+fluxin*del_tv - else - qrz(min_q-1)=qrz(min_q-1)+del_tv* & - fluxin/rho(min_q-1)/dzw(min_q-1) - endif -! - else - notlast=.false. - endif - ENDDO - -! -!-- snow -! - t_del_tv=0. - del_tv=dtb - notlast=.true. - - DO while (notlast) -! - min_q=kte - max_q=kts-1 -! - do k=kts,kte-1 - if (qsz(k) .gt. 1.0e-8) then - min_q=min0(min_q,k) - max_q=max0(max_q,k) - tmp1=sqrt(pi*rhosnow*xnos/rho(k)/qsz(k)) - tmp1=sqrt(tmp1) - vtsold(k)=o6*constc*gamdp4*sqrho(k)/tmp1**constd - if (k .eq. 1) then - del_tv=amin1(del_tv,0.9*(zz(k)-zsfc)/vtsold(k)) - else - del_tv=amin1(del_tv,0.9*(zz(k)-zz(k-1))/vtsold(k)) - endif - else - vtsold(k)=0. - endif - enddo - - if (max_q .ge. min_q) then -! -! -!- Check if the summation of the small delta t >= big delta t -! (t_del_tv) (del_tv) (dtb) - - t_del_tv=t_del_tv+del_tv - - if ( t_del_tv .ge. dtb ) then - notlast=.false. - del_tv=dtb+del_tv-t_del_tv - endif -! - fluxin=0. - do k=max_q,min_q,-1 - fluxout=rho(k)*vtsold(k)*qsz(k) - flux=(fluxin-fluxout)/rho(k)/dzw(k) - qsz(k)=qsz(k)+del_tv*flux - qsz(k)=amax1(0.,qsz(k)) - fluxin=fluxout - enddo - if (min_q .eq. 1) then - pptsnow=pptsnow+fluxin*del_tv - else - qsz(min_q-1)=qsz(min_q-1)+del_tv* & - fluxin/rho(min_q-1)/dzw(min_q-1) - endif -! - else - notlast=.false. - endif - - ENDDO -! -!-- grauupel -! - t_del_tv=0. - del_tv=dtb - notlast=.true. -! - DO while (notlast) -! - min_q=kte - max_q=kts-1 -! - do k=kts,kte-1 - if (qgz(k) .gt. 1.0e-8) then - min_q=min0(min_q,k) - max_q=max0(max_q,k) - tmp1=sqrt(pi*rhograul*xnog/rho(k)/qgz(k)) - tmp1=sqrt(tmp1) - term0=sqrt(4.*grav*rhograul*0.33334/rho(k)/cdrag) - vtgold(k)=o6*gam4pt5*term0*sqrt(1./tmp1) - if (k .eq. 1) then - del_tv=amin1(del_tv,0.9*(zz(k)-zsfc)/vtgold(k)) - else - del_tv=amin1(del_tv,0.9*(zz(k)-zz(k-1))/vtgold(k)) - endif - else - vtgold(k)=0. - endif - enddo - - if (max_q .ge. min_q) then -! -! -!- Check if the summation of the small delta t >= big delta t -! (t_del_tv) (del_tv) (dtb) - - t_del_tv=t_del_tv+del_tv - - if ( t_del_tv .ge. dtb ) then - notlast=.false. - del_tv=dtb+del_tv-t_del_tv - endif - -! - fluxin=0. - do k=max_q,min_q,-1 - fluxout=rho(k)*vtgold(k)*qgz(k) - flux=(fluxin-fluxout)/rho(k)/dzw(k) - qgz(k)=qgz(k)+del_tv*flux - qgz(k)=amax1(0.,qgz(k)) - fluxin=fluxout - enddo - if (min_q .eq. 1) then - pptgraul=pptgraul+fluxin*del_tv - else - qgz(min_q-1)=qgz(min_q-1)+del_tv* & - fluxin/rho(min_q-1)/dzw(min_q-1) - endif -! - else - notlast=.false. - endif -! - ENDDO - -! -!-- cloud ice (03/21/02) follow Vaughan T.J. Phillips at GFDL -! - t_del_tv=0. - del_tv=dtb - notlast=.true. -! - DO while (notlast) -! - min_q=kte - max_q=kts-1 -! - do k=kts,kte-1 - if (qiz(k) .gt. 1.0e-8) then - min_q=min0(min_q,k) - max_q=max0(max_q,k) - vtiold(k)= 3.29 * (rho(k)* qiz(k))** 0.16 ! Heymsfield and Donner - if (k .eq. 1) then - del_tv=amin1(del_tv,0.9*(zz(k)-zsfc)/vtiold(k)) - else - del_tv=amin1(del_tv,0.9*(zz(k)-zz(k-1))/vtiold(k)) - endif - else - vtiold(k)=0. - endif - enddo - - if (max_q .ge. min_q) then -! -! -!- Check if the summation of the small delta t >= big delta t -! (t_del_tv) (del_tv) (dtb) - - t_del_tv=t_del_tv+del_tv - - if ( t_del_tv .ge. dtb ) then - notlast=.false. - del_tv=dtb+del_tv-t_del_tv - endif - - fluxin=0. - do k=max_q,min_q,-1 - fluxout=rho(k)*vtiold(k)*qiz(k) - flux=(fluxin-fluxout)/rho(k)/dzw(k) - qiz(k)=qiz(k)+del_tv*flux - qiz(k)=amax1(0.,qiz(k)) - fluxin=fluxout - enddo - if (min_q .eq. 1) then - pptice=pptice+fluxin*del_tv - else - qiz(min_q-1)=qiz(min_q-1)+del_tv* & - fluxin/rho(min_q-1)/dzw(min_q-1) - endif -! - else - notlast=.false. - endif -! - ENDDO - do k=kts,kte-1 !sg beg - precrz(k)=rho(k)*vtrold(k)*qrz(k) - preciz(k)=rho(k)*vtiold(k)*qiz(k) - precsz(k)=rho(k)*vtsold(k)*qsz(k) - precgz(k)=rho(k)*vtgold(k)*qgz(k) - enddo !sg end - precrz(kte)=0. !wig - top level never set for vtXold vars - preciz(kte)=0. !wig - precsz(kte)=0. !wig - precgz(kte)=0. !wig - - -! Microphysics processes -! - DO 2000 k=kts,kte -! - qvzodt(k)=amax1( 0.0,odtb*qvz(k) ) - qlzodt(k)=amax1( 0.0,odtb*qlz(k) ) - qizodt(k)=amax1( 0.0,odtb*qiz(k) ) - qszodt(k)=amax1( 0.0,odtb*qsz(k) ) - qrzodt(k)=amax1( 0.0,odtb*qrz(k) ) - qgzodt(k)=amax1( 0.0,odtb*qgz(k) ) -!*********************************************************************** -!***** diagnose mixing ratios (qrz,qsz), terminal ***** -!***** velocities (vtr,vts), and slope parameters in size ***** -!***** distribution(xlambdar,xlambdas) of rain and snow ***** -!***** follows Nagata and Ogura, 1991, MWR, 1309-1337. Eq (A7) ***** -!*********************************************************************** -! -!**** assuming no cloud water can exist in the top two levels due to -!**** radiation consideration -! -!! if -!! unsaturated, -!! no cloud water, rain, ice, snow and graupel -!! then -!! skip these processes and jump to line 2000 -! -! - tmp=qiz(k)+qlz(k)+qsz(k)+qrz(k)+qgz(k)*gindex - if( qvz(k)+qlz(k)+qiz(k) .lt. qsiz(k) & - .and. tmp .eq. 0.0 ) go to 2000 - -!! calculate terminal velocity of rain -! - if (qrz(k) .gt. 1.0e-8) then - tmp1=sqrt(pi*rhowater*xnor*orho(k)/qrz(k)) - xlambdar(k)=sqrt(tmp1) - olambdar(k)=1.0/xlambdar(k) - vtrold(k)=o6*consta*gambp4*sqrho(k)*olambdar(k)**constb - else - vtrold(k)=0. - olambdar(k)=0. - endif -! -! if (qrz(k) .gt. 1.0e-12) then - if (qrz(k) .gt. 1.0e-8) then - tmp1=sqrt(pi*rhowater*xnor*orho(k)/qrz(k)) - xlambdar(k)=sqrt(tmp1) - olambdar(k)=1.0/xlambdar(k) - vtr(k)=o6*consta*gambp4*sqrho(k)*olambdar(k)**constb - else - vtr(k)=0. - olambdar(k)=0. - endif -! -!! calculate terminal velocity of snow -! - if (qsz(k) .gt. 1.0e-8) then - tmp1=sqrt(pi*rhosnow*xnos*orho(k)/qsz(k)) - xlambdas(k)=sqrt(tmp1) - olambdas(k)=1.0/xlambdas(k) - vtsold(k)=o6*constc*gamdp4*sqrho(k)*olambdas(k)**constd - else - vtsold(k)=0. - olambdas(k)=0. - endif -! -! if (qsz(k) .gt. 1.0e-12) then - if (qsz(k) .gt. 1.0e-8) then - tmp1=sqrt(pi*rhosnow*xnos*orho(k)/qsz(k)) - xlambdas(k)=sqrt(tmp1) - olambdas(k)=1.0/xlambdas(k) - vts(k)=o6*constc*gamdp4*sqrho(k)*olambdas(k)**constd - else - vts(k)=0. - olambdas(k)=0. - endif -! -!! calculate terminal velocity of graupel -! - if (qgz(k) .gt. 1.0e-8) then - tmp1=sqrt( pi*rhograul*xnog*orho(k)/qgz(k)) - xlambdag(k)=sqrt(tmp1) - olambdag(k)=1.0/xlambdag(k) - term0=sqrt(4.*grav*rhograul*0.33334*orho(k)*ocdrag) - vtgold(k)=o6*gam4pt5*term0*sqrt(olambdag(k)) - else - vtgold(k)=0. - olambdag(k)=0. - endif -! -! if (qgz(k) .gt. 1.0e-12) then - if (qgz(k) .gt. 1.0e-8) then - tmp1=sqrt( pi*rhograul*xnog*orho(k)/qgz(k)) - xlambdag(k)=sqrt(tmp1) - olambdag(k)=1.0/xlambdag(k) - term0=sqrt(4.*grav*rhograul*0.33334*orho(k)*ocdrag) - vtg(k)=o6*gam4pt5*term0*sqrt(olambdag(k)) - else - vtg(k)=0. - olambdag(k)=0. - endif -! -!*********************************************************************** -!***** compute viscosity,difusivity,thermal conductivity, and ****** -!***** Schmidt number ****** -!*********************************************************************** -!c------------------------------------------------------------------ -!c viscmu: dynamic viscosity of air kg/m/s -!c visc: kinematic viscosity of air = viscmu/rho (m2/s) -!c avisc=1.49628e-6 kg/m/s=1.49628e-5 g/cm/s -!c viscmu=1.718e-5 kg/m/s in RH -!c diffwv: Diffusivity of water vapor in air -!c adiffwv = 8.7602e-5 (8.794e-5 in MM5) kgm/s3 -!c = 8.7602 (8.794 in MM5) gcm/s3 -!c diffwv(k)=2.26e-5 m2/s -!c schmidt: Schmidt number=visc/diffwv -!c xka: thermal conductivity of air J/m/s/K (Kgm/s3/K) -!c xka(k)=2.43e-2 J/m/s/K in RH -!c axka=1.4132e3 (1.414e3 in MM5) m2/s2/k = 1.4132e7 cm2/s2/k -!c------------------------------------------------------------------ - - viscmu(k)=avisc*tem(k)**1.5/(tem(k)+120.0) - visc(k)=viscmu(k)*orho(k) - diffwv(k)=adiffwv*tem(k)**1.81*oprez(k) - schmidt(k)=visc(k)/diffwv(k) - xka(k)=axka*viscmu(k) - - if (tem(k) .lt. 273.15) then - -! -!*********************************************************************** -!********* snow production processes for T < 0 C ********** -!*********************************************************************** -!c -!c (1) ICE CRYSTAL AGGREGATION TO SNOW (Psaut): Lin (21) -!c! psaut=alpha1*(qi-qi0) -!c! alpha1=1.0e-3*exp(0.025*(T-T0)) -!c -! alpha1=1.0e-3*exp( 0.025*temcc(k) ) - - alpha1=1.0e-3*exp( 0.025*temcc(k) ) -! - if(temcc(k) .lt. -20.0) then - tmp1=-7.6+4.0*exp( -0.2443e-3*(abs(temcc(k))-20)**2.455 ) - qic=1.0e-3*exp(tmp1)*orho(k) - else - qic=qi0 - end if -!testing -! tmp1=amax1( 0.0,alpha1*(qiz(k)-qic) ) -! psaut(k)=amin1( tmp1,qizodt(k) ) - - tmp1=odtb*(qiz(k)-qic)*(1.0-exp(-alpha1*dtb)) - psaut(k)=amax1( 0.0,tmp1 ) - -!c -!c (2) BERGERON PROCESS TRANSFER OF CLOUD WATER TO SNOW (Psfw) -!c this process only considered when -31 C < T < 0 C -!c Lin (33) and Hsie (17) -!c -!c! -!c! parama1 and parama2 functions must be user supplied -!c! - -! testing - if( qlz(k) .gt. 1.0e-10 ) then - temc1=amax1(-30.99,temcc(k)) -! print*,'temc1',temc1,qlz(k) - a1=parama1( temc1 ) - a2=parama2( temc1 ) - tmp1=1.0-a2 -!! change unit from cgs to mks - a1=a1*0.001**tmp1 -!c! dtberg is the time needed for a crystal to grow from 40 to 50 um -!c ! odtberg=1.0/dtberg - odtberg=(a1*tmp1)/(xmi50**tmp1-xmi40**tmp1) -! -!c! compute terminal velocity of a 50 micron ice cystal -! - vti50=constc*di50**constd*sqrho(k) -! - eiw=1.0 - save1=a1*xmi50**a2 - save2=0.25*pi*eiw*rho(k)*di50*di50*vti50 -! - tmp2=( save1 + save2*qlz(k) ) -! -!! maximum number of 50 micron crystals limited by the amount -!! of supercool water -! - xni50mx=qlzodt(k)/tmp2 -! -!! number of 50 micron crystals produced -! -! - xni50=qiz(k)*( 1.0-exp(-dtb*odtberg) )/xmi50 - xni50=amin1(xni50,xni50mx) -! - tmp3=odtb*tmp2/save2*( 1.0-exp(-save2*xni50*dtb) ) - psfw(k)=amin1( tmp3,qlzodt(k) ) -!testing -! psfw(k)=0. - -!0915 if( temcc(k).gt.-30.99 ) then -!0915 a1=parama1( temcc(k) ) -!0915 a2=parama2( temcc(k) ) -!0915 tmp1=1.0-a2 -!! change unit from cgs to mks -!0915 a1=a1*0.001**tmp1 - -!c! dtberg is the time needed for a crystal to grow from 40 to 50 um -!c! odtberg=1.0/dtberg -!0915 odtberg=(a1*tmp1)/(xmi50**tmp1-xmi40**tmp1) - -!c! number of 50 micron crystals produced -!0915 xni50=qiz(k)*dtb*odtberg/xmi50 - -!c! need to calculate the terminal velocity of a 50 micron -!c! ice cystal -!0915 vti50=constc*di50**constd*sqrho(k) -!0915 eiw=1.0 -!0915 tmp2=xni50*( a1*xmi50**a2 + & -!0915 0.25*qlz(k)*pi*eiw*rho(k)*di50*di50*vti50 ) -!0915 psfw(k)=amin1( tmp2,qlzodt(k) ) -!0915 psfw(k)=0. -!c -!c (3) REDUCTION OF CLOUD ICE BY BERGERON PROCESS (Psfi): Lin (34) -!c this process only considered when -31 C < T < 0 C -!c - tmp1=xni50*xmi50-psfw(k) - psfi(k)=amin1(tmp1,qizodt(k)) -! testing -! psfi(k)=0. - end if -! - -!0915 tmp1=qiz(k)*odtberg -!0915 psfi(k)=amin1(tmp1,qizodt(k)) -! testing -!0915 psfi(k)=0. -!0915 end if -! - if(qrz(k) .le. 0.0) go to 1000 -! -! Processes (4) and (5) only need when qrz > 0.0 -! -!c -!c (4) CLOUD ICE ACCRETION BY RAIN (Praci): Lin (25) -!c may produce snow or graupel -!c - eri=1.0 -!0915 tmp1=qiz(k)*pio4*eri*xnor*consta*sqrho(k) -!0915 tmp2=tmp1*gambp3*olambdar(k)**bp3 -!0915 praci(k)=amin1( tmp2,qizodt(k) ) - - save1=pio4*eri*xnor*consta*sqrho(k) - tmp1=save1*gambp3*olambdar(k)**bp3 - praci(k)=qizodt(k)*( 1.0-exp(-tmp1*dtb) ) - -!c -!c (5) RAIN ACCRETION BY CLOUD ICE (Piacr): Lin (26) -!c -!0915 tmp2=tmp1*rho(k)*pio6*rhowater*gambp6*oxmi* & -!0915 olambdar(k)**bp6 -!0915 piacr(k)=amin1( tmp2,qrzodt(k) ) - - tmp2=qiz(k)*save1*rho(k)*pio6*rhowater*gambp6*oxmi* & - olambdar(k)**bp6 - piacr(k)=amin1( tmp2,qrzodt(k) ) - -! -1000 continue -! - if(qsz(k) .le. 0.0) go to 1200 -! -! Compute the following processes only when qsz > 0.0 -! -!c -!c (6) ICE CRYSTAL ACCRETION BY SNOW (Psaci): Lin (22) -!c - esi=exp( 0.025*temcc(k) ) - save1=pio4*xnos*constc*gamdp3*sqrho(k)* & - olambdas(k)**dp3 - tmp1=esi*save1 - psaci(k)=qizodt(k)*( 1.0-exp(-tmp1*dtb) ) - -!0915 tmp1=pio4*xnos*constc*gamdp3*sqrho(k)* & -!0915 olambdas(k)**dp3 -!0915 tmp2=qiz(k)*esi*tmp1 -!0915 psaci(k)=amin1( tmp2,qizodt(k) ) -!c -!c (7) CLOUD WATER ACCRETION BY SNOW (Psacw): Lin (24) -!c - esw=1.0 - tmp1=esw*save1 - psacw(k)=qlzodt(K)*( 1.0-exp(-tmp1*dtb) ) - -!0915 tmp2=qlz(k)*esw*tmp1 -!0915 psacw(k)=amin1( tmp2,qlzodt(k) ) -!c -!c (8) DEPOSITION/SUBLIMATION OF SNOW (Psdep/Pssub): Lin (31) -!c includes consideration of ventilation effect -!c -!c abi=2*pi*(Si-1)/rho/(A"+B") -!c - tmpa=rvapor*xka(k)*tem(k)*tem(k) - tmpb=xls*xls*rho(k)*qsiz(k)*diffwv(k) - tmpc=tmpa*qsiz(k)*diffwv(k) - abi=2.0*pi*(qvoqsiz(k)-1.0)*tmpc/(tmpa+tmpb) -! -!c vf1s,vf2s=ventilation factors for snow -!c vf1s=0.78,vf2s=0.31 in LIN -! - tmp1=constc*sqrho(k)*olambdas(k)**dp5/visc(k) - tmp2=abi*xnos*( vf1s*olambdas(k)*olambdas(k)+ & - vf2s*schmidt(k)**0.33334*gamdp5o2*sqrt(tmp1) ) - tmp3=odtb*( qvz(k)-qsiz(k) ) -! - if( tmp2 .le. 0.0) then - tmp2=amax1( tmp2,tmp3) - pssub(k)=amax1( tmp2,-qszodt(k) ) - psdep(k)=0.0 - else - psdep(k)=amin1( tmp2,tmp3 ) - pssub(k)=0.0 - end if - -!0915 psdep(k)=amax1(0.0,tmp2) -!0915 pssub(k)=amin1(0.0,tmp2) -!0915 pssub(k)=amax1( pssub(k),-qszodt(k) ) -! - if(qrz(k) .le. 0.0) go to 1200 -! -! Compute processes (9) and (10) only when qsz > 0.0 and qrz > 0.0 -! -!c -!c (9) ACCRETION OF SNOW BY RAIN (Pracs): Lin (27) -!c - esr=1.0 - tmpa=olambdar(k)*olambdar(k) - tmpb=olambdas(k)*olambdas(k) - tmpc=olambdar(k)*olambdas(k) - tmp1=pi*pi*esr*xnor*xnos*abs( vtr(k)-vts(k) )*orho(k) - tmp2=tmpb*tmpb*olambdar(k)*(5.0*tmpb+2.0*tmpc+0.5*tmpa) - tmp3=tmp1*rhosnow*tmp2 - pracs(k)=amin1( tmp3,qszodt(k) ) -!c -!c (10) ACCRETION OF RAIN BY SNOW (Psacr): Lin (28) -!c - tmp3=tmpa*tmpa*olambdas(k)*(5.0*tmpa+2.0*tmpc+0.5*tmpb) - tmp4=tmp1*rhowater*tmp3 - psacr(k)=amin1( tmp4,qrzodt(k) ) -! -1200 continue -! - else -! -!*********************************************************************** -!********* snow production processes for T > 0 C ********** -!*********************************************************************** -! - if (qsz(k) .le. 0.0) go to 1400 -!c -!c (1) CLOUD WATER ACCRETION BY SNOW (Psacw): Lin (24) -!c - esw=1.0 - - tmp1=esw*pio4*xnos*constc*gamdp3*sqrho(k)* & - olambdas(k)**dp3 - psacw(k)=qlzodt(k)*( 1.0-exp(-tmp1*dtb) ) - -!0915 tmp1=pio4*xnos*constc*gamdp3*sqrho(k)* & -!0915 olambdas(k)**dp3 -!0915 tmp2=qlz(k)*esw*tmp1 -!0915 psacw(k)=amin1( tmp2,qlzodt(k) ) -!c -!c (2) ACCRETION OF RAIN BY SNOW (Psacr): Lin (28) -!c - esr=1.0 - tmpa=olambdar(k)*olambdar(k) - tmpb=olambdas(k)*olambdas(k) - tmpc=olambdar(k)*olambdas(k) - tmp1=pi*pi*esr*xnor*xnos*abs( vtr(k)-vts(k) )*orho(k) - tmp2=tmpa*tmpa*olambdas(k)*(5.0*tmpa+2.0*tmpc+0.5*tmpb) - tmp3=tmp1*rhowater*tmp2 - psacr(k)=amin1( tmp3,qrzodt(k) ) -!c -!c (3) MELTING OF SNOW (Psmlt): Lin (32) -!c Psmlt is negative value -! - delrs=rs0(k)-qvz(k) - term1=2.0*pi*orho(k)*( xlv*diffwv(k)*rho(k)*delrs- & - xka(k)*temcc(k) ) - tmp1=constc*sqrho(k)*olambdas(k)**dp5/visc(k) - tmp2=xnos*( vf1s*olambdas(k)*olambdas(k)+ & - vf2s*schmidt(k)**0.33334*gamdp5o2*sqrt(tmp1) ) - tmp3=term1*oxlf*tmp2-cwoxlf*temcc(k)*( psacw(k)+psacr(k) ) - tmp4=amin1(0.0,tmp3) - psmlt(k)=amax1( tmp4,-qszodt(k) ) -!c -!c (4) EVAPORATION OF MELTING SNOW (Psmltevp): HR (A27) -!c but use Lin et al. coefficience -!c Psmltevp is a negative value -!c - tmpa=rvapor*xka(k)*tem(k)*tem(k) - tmpb=xlv*xlv*rho(k)*qswz(k)*diffwv(k) - tmpc=tmpa*qswz(k)*diffwv(k) - tmpd=amin1( 0.0,(qvoqswz(k)-0.90)*qswz(k)*odtb ) - -! abr=2.0*pi*(qvoqswz(k)-1.0)*tmpc/(tmpa+tmpb) - - abr=2.0*pi*(qvoqswz(k)-0.90)*tmpc/(tmpa+tmpb) -! -!**** allow evaporation to occur when RH less than 90% -!**** here not using 100% because the evaporation cooling -!**** of temperature is not taking into account yet; hence, -!**** the qsw value is a little bit larger. This will avoid -!**** evaporation can generate cloud. -! -!c vf1s,vf2s=ventilation factors for snow -!c vf1s=0.78,vf2s=0.31 in LIN -! - tmp1=constc*sqrho(k)*olambdas(k)**dp5/visc(k) - tmp2=abr*xnos*( vf1s*olambdas(k)*olambdas(k)+ & - vf2s*schmidt(k)**0.33334*gamdp5o2*sqrt(tmp1) ) - tmp3=amin1(0.0,tmp2) - tmp3=amax1( tmp3,tmpd ) - psmltevp(k)=amax1( tmp3,-qszodt(k) ) -1400 continue -! - end if - -!*********************************************************************** -!********* rain production processes ********** -!*********************************************************************** -! -!c -!c (1) AUTOCONVERSION OF RAIN (Praut): RH -!sg: begin - if(flag_qndrop)then - if( qndropz(k) >= 1. ) then -! Liu et al. autoconversion scheme - rhocgs=rho(k)*1.e-3 - liqconc=rhocgs*qlz(k) - capn=rhocgs*qndropz(k) -! rate function - if(liqconc.gt.1.e-10)then - p0=kappa*beta/capn*(liqconc*liqconc*liqconc) - xc=9.7d-17*capn*sqrt(capn)/(liqconc*liqconc) -! Calculate autoconversion rate (g/g/s) - if(xc.lt.10.)then - praut(k)=p0/rhocgs*0.5d0*(xc*xc+2*xc+2.0d0)* & - (1.0d0+xc)*dexp(-2.0d0*xc) - endif - endif - endif - else -!sg: end -!c araut=afa*rho -!c afa=0.001 Rate coefficient for autoconvergence -!c -!c araut=1.0e-3 -!c - araut=0.001 -!testing -! tmp1=amax1( 0.0,araut*(qlz(k)-ql0) ) -! praut(k)=amin1( tmp1,qlzodt(k) ) - tmp1=odtb*(qlz(k)-ql0)*( 1.0-exp(-araut*dtb) ) - praut(k)=amax1( 0.0,tmp1 ) - endif !sg - -!c -!c (2) ACCRETION OF CLOUD WATER BY RAIN (Pracw): Lin (51) -!c - erw=1.0 -! tmp1=qlz(k)*pio4*erw*xnor*consta*sqrho(k) -! tmp2=tmp1*gambp3*olambdar(k)**bp3 -! pracw(k)=amin1( tmp2,qlzodt(k) ) - - tmp1=pio4*erw*xnor*consta*sqrho(k)* & - gambp3*olambdar(k)**bp3 - pracw(k)=qlzodt(k)*( 1.0-exp(-tmp1*dtb) ) - -!c -!c (3) EVAPORATION OF RAIN (Prevp): Lin (52) -!c Prevp is negative value -!c -!c Sw=qvoqsw : saturation ratio -!c - tmpa=rvapor*xka(k)*tem(k)*tem(k) - tmpb=xlv*xlv*rho(k)*qswz(k)*diffwv(k) - tmpc=tmpa*qswz(k)*diffwv(k) - tmpd=amin1(0.0,(qvoqswz(k)-0.90)*qswz(k)*odtb) -! -! abr=2.0*pi*(qvoqswz(k)-1.0)*tmpc/(tmpa+tmpb) - - abr=2.0*pi*(qvoqswz(k)-0.90)*tmpc/(tmpa+tmpb) -! -!c vf1r,vf2r=ventilation factors for rain -!c vf1r=0.78,vf2r=0.31 in RH, LIN and MM5 -! - vf1r=0.78 - vf2r=0.31 - tmp1=consta*sqrho(k)*olambdar(k)**bp5/visc(k) - tmp2=abr*xnor*( vf1r*olambdar(k)*olambdar(k)+ & - vf2r*schmidt(k)**0.33334*gambp5o2*sqrt(tmp1) ) - tmp3=amin1( 0.0,tmp2 ) - tmp3=amax1( tmp3,tmpd ) - prevp(k)=amax1( tmp3,-qrzodt(k) ) - -! -! if(iout .gt. 0) write(20,*)'tmp1,tmp2,tmp3=',tmp1,tmp2,tmp3 -! if(iout .gt. 0) write(20,*)'qlz,qiz,qrz=',qlz(k),qiz(k),qrz(k) -! if(iout .gt. 0) write(20,*)'tem,qsz,qvz=',tem(k),qsz(k),qvz(k) - - - -! if (gindex .eq. 0.) goto 900 -! - if (tem(k) .lt. 273.15) then -! -! -!-- graupel -!*********************************************************************** -!********* graupel production processes for T < 0 C ********** -!*********************************************************************** -!c -!c (1) AUTOCONVERSION OF SNOW TO FORM GRAUPEL (Pgaut): Lin (37) -!c pgaut=alpha2*(qsz-qs0) -!c qs0=6.0E-4 -!c alpha2=1.0e-3*exp(0.09*temcc(k)) Lin (38) -! - alpha2=1.0e-3*exp(0.09*temcc(k)) -! - -! testing -! tmp1=alpha2*(qsz(k)-qs0) -! tmp1=amax1(0.0,tmp1) -! pgaut(k)=amin1( tmp1,qszodt(k) ) - - tmp1=odtb*(qsz(k)-qs0)*(1.0-exp(-alpha2*dtb)) - pgaut(k)=amax1( 0.0,tmp1 ) - -!c -!c (2) FREEZING OF RAIN TO FORM GRAUPEL (Pgfr): Lin (45) -!c positive value -!c Constant in Bigg freezing Aplume=Ap=0.66 /k -!c Constant in raindrop freezing equ. Bplume=Bp=100./m/m/m/s -! - - if (qrz(k) .gt. 1.e-8 ) then - Bp=100. - Ap=0.66 - tmp1=olambdar(k)*olambdar(k)*olambdar(k) - tmp2=20.*pi*pi*Bp*xnor*rhowater*orho(k)* & - (exp(-Ap*temcc(k))-1.0)*tmp1*tmp1*olambdar(k) - Pgfr(k)=amin1( tmp2,qrzodt(k) ) - else - Pgfr(k)=0 - endif - -!c -!c if (qgz(k) = 0.0) skip the other step below about graupel -!c - if (qgz(k) .eq. 0.0) goto 4000 - -!c -!c Comparing Pgwet(wet process) and Pdry(dry process), -!c we will pick up the small one. -!c - -!c --------------- -!c | dry processes | -!c --------------- -!c -!c (3) ACCRETION OF CLOUD WATER BY GRAUPEL (Pgacw): Lin (40) -!c egw=1.0 -!c Cdrag=0.6 drag coefficients for hairstone -!c constg=sqrt(4.*grav*rhograul*0.33334*orho(k)/Cdrag) -!c - egw=1.0 - constg=sqrt(4.*grav*rhograul*0.33334*orho(k)*oCdrag) - tmp1=pio4*xnog*gam3pt5*constg*olambdag(k)**3.5 - tmp2=qlz(k)*egw*tmp1 - Pgacw(k)=amin1( tmp2,qlzodt(k) ) -!c -!c (4) ACCRETION OF ICE CRYSTAL BY GRAUPEL (Pgaci): Lin (41) -!c egi=1. for wet growth -!c egi=0.1 for dry growth -!c - egi=0.1 - tmp2=qiz(k)*egi*tmp1 - pgaci(k)=amin1( tmp2,qizodt(k) ) - - -!c -!c (5) ACCRETION OF SNOW BY GRAUPEL (Pgacs) : Lin (29) -!c Compute processes (6) only when qsz > 0.0 and qgz > 0.0 -!c - egs=exp(0.09*temcc(k)) - tmpa=olambdas(k)*olambdas(k) - tmpb=olambdag(k)*olambdag(k) - tmpc=olambdas(k)*olambdag(k) - tmp1=pi*pi*xnos*xnog*abs( vts(k)-vtg(k) )*orho(k) - tmp2=tmpa*tmpa*olambdag(k)*(5.0*tmpa+2.0*tmpc+0.5*tmpb) - tmp3=tmp1*egs*rhosnow*tmp2 - Pgacs(k)=amin1( tmp3,qszodt(k) ) - - -!c -!c (6) ACCRETION OF RAIN BY GRAUPEL (Pgacr): Lin (42) -!c Compute processes (6) only when qrz > 0.0 and qgz > 0.0 -!c egr=1. -!c - egr=1. - tmpa=olambdar(k)*olambdar(k) - tmpb=olambdag(k)*olambdag(k) - tmpc=olambdar(k)*olambdag(k) - tmp1=pi*pi*xnor*xnog*abs( vtr(k)-vtg(k) )*orho(k) - tmp2=tmpa*tmpa*olambdag(k)*(5.0*tmpa+2.0*tmpc+0.5*tmpb) - tmp3=tmp1*egr*rhowater*tmp2 - pgacr(k)=amin1( tmp3,qrzodt(k) ) - -!c -!c (7) Calculate total dry process effect Pdry(k) -!c - Pdry(k)=Pgacw(k)+pgaci(k)+Pgacs(k)+pgacr(k) - -!c --------------- -!c | wet processes | -!c --------------- -!c -!c (3) ACCRETION OF ICE CRYSTAL BY GRAUPEL (Pgacip): Lin (41) -!c egi=1. for wet growth -!c egi=0.1 for dry growth -!c - tmp2=10.*pgaci(k) - pgacip(k)=amin1( tmp2,qizodt(k) ) - -!c -!c (4) ACCRETION OF SNOW BY GRAUPEL ((Pgacsp) : Lin (29) -!c Compute processes (6) only when qsz > 0.0 and qgz > 0.0 -!c egs=exp(0.09*(tem(k)-273.15)) when T < 273.15 k -!c - tmp3=Pgacs(k)*1.0/egs - Pgacsp(k)=amin1( tmp3,qszodt(k) ) - -!c -!c (5) WET GROWTH OF GRAUPEL (Pgwet) : Lin (43) -!c may involve Pgacs or Pgaci and -!c must include PPgacw or Pgacr, or both. -!c ( The amount of Pgacw which is not able -!c to freeze is shed to rain. ) - IF(temcc(k).gt.-40.)THEN - - term0=constg*olambdag(k)**5.5/visc(k) - -!c -!c vf1s,vf2s=ventilation factors for graupel -!c vf1s=0.78,vf2s=0.31 in LIN -!c Cdrag=0.6 drag coefficient for hairstone -!c constg2=vf1s*olambdag(k)*olambdag(k)+ -!c vf2s*schmidt(k)**0.33334*gam2pt75*sqrt(term0) - - delrs=rs0(k)-qvz(k) - tmp0=1./(xlf+cw*temcc(k)) - tmp1=2.*pi*xnog*(rho(k)*xlv*diffwv(k)*delrs-xka(k)* & - temcc(k))*orho(k)*tmp0 - constg2=vf1s*olambdag(k)*olambdag(k)+ & - vf2s*schmidt(k)**0.33334*gam2pt75*sqrt(term0) - tmp3=tmp1*constg2+(Pgacip(k)+Pgacsp(k))* & - (1-Ci*temcc(k)*tmp0) - tmp3=amax1(0.0,tmp3) - Pgwet(k)=amax1(tmp3,qlzodt(k)+qszodt(k)+qizodt(k) ) - -!c -!c Comparing Pgwet(wet process) and Pdry(dry process), -!c we will apply the small one. -!c if dry processes then delta4=1.0 -!c if wet processes then delta4=0.0 -! - if ( Pdry(k) .lt. Pgwet(k) ) then - delta4=1.0 - else - delta4=0.0 - endif - ELSE - delta4=1.0 - ENDIF - -!c -!c -!c (6) Pgacrp(k)=Pgwet(k)-Pgacw(k)-Pgacip(k)-Pgacsp(k) -!c if Pgacrp(k) > 0. then some of the rain is frozen to hail -!c if Pgacrp(k) < 0. then some of the cloud water collected -!c by the hail is unable to freeze and is -!c shed as rain. -!c - Pgacrp(k)=Pgwet(k)-Pgacw(k)-Pgacip(k)-Pgacsp(k) - -!c -!c (8) DEPOSITION/SUBLIMATION OF GRAUPEL (Pgdep/Pgsub): Lin (46) -!c includes ventilation effect -!c constg=sqrt(4.*grav*rhograul*0.33334*orho(k)/Cdrag) -!c constg2=vf1s*olambdag(k)*olambdag(k)+ -!c vf2s*schmidt(k)**0.33334*gam2pt75*constg -!c -!c abg=2*pi*(Si-1)/rho/(A"+B") -!c - tmpa=rvapor*xka(k)*tem(k)*tem(k) - tmpb=xls*xls*rho(k)*qsiz(k)*diffwv(k) - tmpc=tmpa*qsiz(k)*diffwv(k) - abg=2.0*pi*(qvoqsiz(k)-1.0)*tmpc/(tmpa+tmpb) -!c -!c vf1s,vf2s=ventilation factors for graupel -!c vf1s=0.78,vf2s=0.31 in LIN -!c Cdrag=0.6 drag coefficient for hairstone -!c - term0=constg*olambdag(k)**5.5/visc(k) - constg2=vf1s*olambdag(k)*olambdag(k)+ & - vf2s*schmidt(k)**0.33334*gam2pt75*sqrt(term0) - tmp2=abg*xnog*constg2 - pgdep(k)=amax1(0.0,tmp2) - pgsub(k)=amin1(0.0,tmp2) - pgsub(k)=amax1( pgsub(k),-qgzodt(k) ) - - 4000 continue - else -! -!*********************************************************************** -!********* graupel production processes for T > 0 C ********** -!*********************************************************************** -! -!c -!c (1) ACCRETION OF CLOUD WATER BY GRAUPEL (Pgacw): Lin (40) -!c egw=1.0 -!c Cdrag=0.6 drag coefficients for hairstone -!c constg=sqrt(4.*grav*rhograul*0.33334*orho(k)/Cdrag) - - egw=1.0 - constg=sqrt(4.*grav*rhograul*0.33334*orho(k)*oCdrag) - tmp1=pio4*xnog*gam3pt5*constg*olambdag(k)**3.5 - tmp2=qlz(k)*egw*tmp1 - Pgacw(k)=amin1( tmp2,qlzodt(k) ) - -!c -!c (2) ACCRETION OF RAIN BY GRAUPEL (Pgacr): Lin (42) -!c Compute processes (5) only when qrz > 0.0 and qgz > 0.0 -!c egr=1. -!c - egr=1. - tmpa=olambdar(k)*olambdar(k) - tmpb=olambdag(k)*olambdag(k) - tmpc=olambdar(k)*olambdag(k) - tmp1=pi*pi*xnor*xnog*abs( vtr(k)-vtg(k) )*orho(k) - tmp2=tmpa*tmpa*olambdag(k)*(5.0*tmpa+2.0*tmpc+0.5*tmpb) - tmp3=tmp1*egr*rhowater*tmp2 - pgacr(k)=amin1( tmp3,qrzodt(k) ) - - -!c -!c (3) GRAUPEL MELTING TO FORM RAIN (Pgmlt): Lin (47) -!c Pgmlt is negative value -!c constg=sqrt(4.*grav*rhograul*0.33334*orho(k)/Cdrag) -!c constg2=vf1s*olambdag(k)*olambdag(k)+ -!c vf2s*schmidt(k)**0.33334*gam2pt75*constg -!c Cdrag=0.6 drag coefficients for hairstone -! - delrs=rs0(k)-qvz(k) - term1=2.0*pi*orho(k)*( xlv*diffwv(k)*rho(k)*delrs- & - xka(k)*temcc(k) ) - term0=sqrt(4.*grav*rhograul*0.33334*orho(k)*ocdrag) & - *olambdag(k)**5.5/visc(k) - - constg2=vf1s*olambdag(k)*olambdag(k)+ & - vf2s*schmidt(k)**0.33334*gam2pt75*sqrt(term0) - tmp2=xnog*constg2 - tmp3=term1*oxlf*tmp2-cwoxlf*temcc(k)*( pgacw(k)+pgacr(k) ) - tmp4=amin1(0.0,tmp3) - pgmlt(k)=amax1( tmp4,-qgzodt(k) ) - - -!c -!c (4) EVAPORATION OF MELTING GRAUPEL (Pgmltevp) : HR (A19) -!c but use Lin et al. coefficience -!c Pgmltevp is a negative value -!c abg=2.0*pi*(qvoqsiz(k)-1.0)*tmpc/(tmpa+tmpb) -!c - tmpa=rvapor*xka(k)*tem(k)*tem(k) - tmpb=xlv*xlv*rho(k)*qswz(k)*diffwv(k) - tmpc=tmpa*qswz(k)*diffwv(k) - tmpd=amin1( 0.0,(qvoqswz(k)-0.90)*qswz(k)*odtb ) - -!c -!c abg=2*pi*(Si-1)/rho/(A"+B") -!c - abg=2.0*pi*(qvoqswz(k)-0.90)*tmpc/(tmpa+tmpb) -! -!**** allow evaporation to occur when RH less than 90% -!**** here not using 100% because the evaporation cooling -!**** of temperature is not taking into account yet; hence, -!**** the qgw value is a little bit larger. This will avoid -!**** evaporation can generate cloud. -! -!c vf1s,vf2s=ventilation factors for snow -!c vf1s=0.78,vf2s=0.31 in LIN -!c constg=sqrt(4.*grav*rhograul*0.33334*orho(k)/Cdrag) -!c constg2=vf1s*olambdag(k)*olambdag(k)+ -!c vf2s*schmidt(k)**0.33334*gam2pt75*constg -! - tmp2=abg*xnog*constg2 - tmp3=amin1(0.0,tmp2) - tmp3=amax1( tmp3,tmpd ) - pgmltevp(k)=amax1( tmp3,-qgzodt(k) ) - -!c -!c (5) ACCRETION OF SNOW BY GRAUPEL (Pgacs) : Lin (29) -!c Compute processes (3) only when qsz > 0.0 and qgz > 0.0 -!c egs=1.0 -!c - egs=1. - tmpa=olambdas(k)*olambdas(k) - tmpb=olambdag(k)*olambdag(k) - tmpc=olambdas(k)*olambdag(k) - tmp1=pi*pi*xnos*xnog*abs( vts(k)-vtg(k) )*orho(k) - tmp2=tmpa*tmpa*olambdag(k)*(5.0*tmpa+2.0*tmpc+0.5*tmpb) - tmp3=tmp1*egs*rhosnow*tmp2 - Pgacs(k)=amin1( tmp3,qszodt(k) ) - - endif - - -! - 900 continue - -!cc -!c -!c********************************************************************** -!c***** combine all processes together and avoid negative ***** -!c***** water substances -!*********************************************************************** -!c - if ( temcc(k) .lt. 0.0) then -!,delta4,1.-delta4 -!c -!c gdelta4=gindex*delta4 -!c g1sdelt4=gindex*(1.-delta4) -!c - gdelta4=gindex*delta4 - g1sdelt4=gindex*(1.-delta4) -!c -!c combined water vapor depletions -!c -!cc graupel - tmp=psdep(k)+pgdep(k)*gindex - if ( tmp .gt. qvzodt(k) ) then - factor=qvzodt(k)/tmp - psdep(k)=psdep(k)*factor - pgdep(k)=pgdep(k)*factor*gindex - end if -!c -!c combined cloud water depletions -!c - tmp=praut(k)+psacw(k)+psfw(k)+pracw(k)+gindex*Pgacw(k) - if ( tmp .gt. qlzodt(k) ) then - factor=qlzodt(k)/tmp - praut(k)=praut(k)*factor - psacw(k)=psacw(k)*factor - psfw(k)=psfw(k)*factor - pracw(k)=pracw(k)*factor -!cc graupel - Pgacw(k)=Pgacw(k)*factor*gindex - end if -!c -!c combined cloud ice depletions -!c - tmp=psaut(k)+psaci(k)+praci(k)+psfi(k)+Pgaci(k)*gdelta4 & - +Pgacip(k)*g1sdelt4 - if (tmp .gt. qizodt(k) ) then - factor=qizodt(k)/tmp - psaut(k)=psaut(k)*factor - psaci(k)=psaci(k)*factor - praci(k)=praci(k)*factor - psfi(k)=psfi(k)*factor -!cc graupel - Pgaci(k)=Pgaci(k)*factor*gdelta4 - Pgacip(k)=Pgacip(k)*factor*g1sdelt4 - endif -!c -!c combined all rain processes -!c - tmp_r=piacr(k)+psacr(k)-prevp(k)-praut(k)-pracw(k) & - +Pgfr(k)*gindex+Pgacr(k)*gdelta4 & - +Pgacrp(k)*g1sdelt4 - if (tmp_r .gt. qrzodt(k) ) then - factor=qrzodt(k)/tmp_r - piacr(k)=piacr(k)*factor - psacr(k)=psacr(k)*factor - prevp(k)=prevp(k)*factor -!cc graupel - Pgfr(k)=Pgfr(k)*factor*gindex - Pgacr(k)=Pgacr(k)*factor*gdelta4 - Pgacrp(k)=Pgacrp(k)*factor*g1sdelt4 - endif - -!c -!c if qrz < 1.0E-4 and qsz < 1.0E-4 then delta2=1. -!c (all Pracs and Psacr become to snow) -!c if qrz >= 1.0E-4 or qsz >= 1.0E-4 then delta2=0. -!c (all Pracs and Psacr become to graupel) -!c - if (qrz(k) .lt. 1.0E-4 .and. qsz(k) .lt. 1.0E-4) then - delta2=1.0 - else - delta2=0.0 - endif -! -!cc graupel - -!c -!c if qrz(k) < 1.0e-4 then delta3=1. means praci(k) --> qs -!c piacr(k) --> qs -!c if qrz(k) > 1.0e-4 then delta3=0. means praci(k) --> qg -!c piacr(k) --> qg : Lin (20) - - if (qrz(k) .lt. 1.0e-4) then - delta3=1.0 - else - delta3=0.0 - endif -! -!c -!c if gindex = 0.(no graupel) then delta2=1.0 -!c delta3=1.0 -!c - if (gindex .eq. 0.) then - delta2=1.0 - delta3=1.0 - endif -! -!c -!c combined all snow processes -!c - tmp_s=-pssub(k)-(psaut(k)+psaci(k)+psacw(k)+psfw(k)+ & - psfi(k)+praci(k)*delta3+piacr(k)*delta3+ & - psdep(k))+Pgaut(k)*gindex+Pgacs(k)*gdelta4+ & - Pgacsp(k)*g1sdelt4+Pracs(k)*(1.-delta2)- & - Psacr(k)*delta2 - if ( tmp_s .gt. qszodt(k) ) then - factor=qszodt(k)/tmp_s - pssub(k)=pssub(k)*factor - Pracs(k)=Pracs(k)*factor -!cc graupel - Pgaut(k)=Pgaut(k)*factor*gindex - Pgacs(k)=Pgacs(k)*factor*gdelta4 - Pgacsp(k)=Pgacsp(k)*factor*g1sdelt4 - endif - -!cc graupel -! - -! if (gindex .eq. 0.) goto 998 -!c -!c combined all graupel processes -!c - if(delta4.lt.0.5) then - !Re-define pgwet to account for limiting of pgacrp, - ! pgacip, pgacw and pgacsp above - pgwet(k) = pgacrp(k) + pgacw(k) + pgacip(k) + pgacsp(k) - end if - tmp_g=-pgaut(k)-pgfr(k)-Pgacw(k)*delta4-Pgaci(k)*delta4 & - -Pgacr(k)*delta4-Pgacs(k)*delta4 & - -pgwet(k)*(1.-delta4)-pgsub(k)-pgdep(k) & - -psacr(k)*(1-delta2)-Pracs(k)*(1-delta2) & - -praci(k)*(1-delta3)-piacr(k)*(1-delta3) - if (tmp_g .gt. qgzodt(k)) then - factor=qgzodt(k)/tmp_g - pgsub(k)=pgsub(k)*factor - endif - - 998 continue -!c -!c calculate new water substances, thetae, tem, and qvsbar -!c - -!cc graupel - pvapor(k)=-pssub(k)-psdep(k)-prevp(k)-pgsub(k)*gindex & - -pgdep(k)*gindex - qvz(k)=amax1( qvmin,qvz(k)+dtb*pvapor(k) ) - pclw(k)=-praut(k)-pracw(k)-psacw(k)-psfw(k)-pgacw(k)*gindex - if(flag_qndrop)then - if( qlz(k) > 1e-20 ) & - qndropz(k)=amax1( 0.0,qndropz(k)+dtb*pclw(k)*qndropz(k)/qlz(k) ) !sg - endif - qlz(k)=amax1( 0.0,qlz(k)+dtb*pclw(k) ) - pcli(k)=-psaut(k)-psfi(k)-psaci(k)-praci(k)-pgaci(k)*gdelta4 & - -Pgacip(k)*g1sdelt4 - qiz(k)=amax1( 0.0,qiz(k)+dtb*pcli(k) ) - tmp_r=piacr(k)+psacr(k)-prevp(k)-praut(k)-pracw(k) & - +Pgfr(k)*gindex+Pgacr(k)*gdelta4 & - +Pgacrp(k)*g1sdelt4 - 232 format(i2,1x,6(f9.3,1x)) - prain(k)=-tmp_r - qrz(k)=amax1( 0.0,qrz(k)+dtb*prain(k) ) - tmp_s=-pssub(k)-(psaut(k)+psaci(k)+psacw(k)+psfw(k)+ & - psfi(k)+praci(k)*delta3+piacr(k)*delta3+ & - psdep(k))+Pgaut(k)*gindex+Pgacs(k)*gdelta4+ & - Pgacsp(k)*g1sdelt4+Pracs(k)*(1.-delta2)- & - Psacr(k)*delta2 - psnow(k)=-tmp_s - qsz(k)=amax1( 0.0,qsz(k)+dtb*psnow(k) ) - qschg(k)=qschg(k)+psnow(k) - qschg(k)=psnow(k) -!cc graupel - tmp_g=-pgaut(k)-pgfr(k)-Pgacw(k)*delta4-Pgaci(k)*delta4 & - -Pgacr(k)*delta4-Pgacs(k)*delta4 & - -pgwet(k)*(1.-delta4)-pgsub(k)-pgdep(k) & - -psacr(k)*(1-delta2)-Pracs(k)*(1-delta2) & - -praci(k)*(1-delta3)-piacr(k)*(1-delta3) - 252 format(i2,1x,6(f12.9,1x)) - 262 format(i2,1x,7(f12.9,1x)) - pgraupel(k)=-tmp_g - pgraupel(k)=pgraupel(k)*gindex - qgz(k)=amax1( 0.0,qgz(k)+dtb*pgraupel(k)) -! qgchg(k)=qgchg(k)+pgraupel(k) - qgchg(k)=pgraupel(k) - qgz(k)=qgz(k)*gindex - - tmp=ocp/tothz(k)*xLf*(qschg(k)+qgchg(k)) - theiz(k)=theiz(k)+dtb*tmp - thz(k)=theiz(k)-(xLvocp*qvz(k)-xLfocp*qiz(k))/tothz(k) - tem(k)=thz(k)*tothz(k) - - temcc(k)=tem(k)-273.15 - - if( temcc(k) .lt. -40.0 ) qswz(k)=qsiz(k) - qlpqi=qlz(k)+qiz(k) - if ( qlpqi .eq. 0.0 ) then - qvsbar(k)=qsiz(k) - else - qvsbar(k)=( qiz(k)*qsiz(k)+qlz(k)*qswz(k) )/qlpqi - endif - -! - else -!c -!c combined cloud water depletions -!c - tmp=praut(k)+psacw(k)+pracw(k)+pgacw(k)*gindex - if ( tmp .gt. qlzodt(k) ) then - factor=qlzodt(k)/tmp - praut(k)=praut(k)*factor - psacw(k)=psacw(k)*factor - pracw(k)=pracw(k)*factor -!cc graupel - pgacw(k)=pgacw(k)*factor*gindex - end if -!c -!c combined all snow processes -!c - tmp_s=-(psmlt(k)+psmltevp(k))+Pgacs(k)*gindex - if (tmp_s .gt. qszodt(k) ) then - factor=qszodt(k)/tmp_s - psmlt(k)=psmlt(k)*factor - psmltevp(k)=psmltevp(k)*factor -!cc graupel - Pgacs(k)=Pgacs(k)*factor*gindex - endif - -!c -!c -!cc graupel -!c -! if (gindex .eq. 0.) goto 997 - -!c -!c combined all graupel processes -!c - tmp_g=-pgmlt(k)-pgacs(k)-pgmltevp(k) - if (tmp_g .gt. qgzodt(k)) then - factor=qgzodt(k)/tmp_g - pgmltevp(k)=pgmltevp(k)*factor - pgmlt(k)=pgmlt(k)*factor - endif -!c - 997 continue - -!c -!c combined all rain processes -!c - tmp_r=-prevp(k)-(praut(k)+pracw(k)+psacw(k)-psmlt(k)) & - +pgmlt(k)*gindex-pgacw(k)*gindex - if (tmp_r .gt. qrzodt(k) ) then - factor=qrzodt(k)/tmp_r - prevp(k)=prevp(k)*factor - endif -!c -!c -!c calculate new water substances and thetae -!c - - - pvapor(k)=-psmltevp(k)-prevp(k)-pgmltevp(k)*gindex - qvz(k)=amax1( qvmin,qvz(k)+dtb*pvapor(k)) - pclw(k)=-praut(k)-pracw(k)-psacw(k)-pgacw(k)*gindex - if(flag_qndrop)then - if( qlz(k) > 1e-20 ) & - qndropz(k)=amax1( 0.0,qndropz(k)+dtb*pclw(k)*qndropz(k)/qlz(k) ) !sg - endif - qlz(k)=amax1( 0.0,qlz(k)+dtb*pclw(k) ) - pcli(k)=0.0 - qiz(k)=amax1( 0.0,qiz(k)+dtb*pcli(k) ) - tmp_r=-prevp(k)-(praut(k)+pracw(k)+psacw(k)-psmlt(k)) & - +pgmlt(k)*gindex-pgacw(k)*gindex - 242 format(i2,1x,7(f9.6,1x)) - prain(k)=-tmp_r - tmpqrz=qrz(k) - qrz(k)=amax1( 0.0,qrz(k)+dtb*prain(k) ) - tmp_s=-(psmlt(k)+psmltevp(k))+Pgacs(k)*gindex - psnow(k)=-tmp_s - qsz(k)=amax1( 0.0,qsz(k)+dtb*psnow(k) ) -! qschg(k)=qschg(k)+psnow(k) - qschg(k)=psnow(k) -!cc graupel - - tmp_g=-pgmlt(k)-pgacs(k)-pgmltevp(k) -! write(*,272)k,pgmlt(k),pgacs(k),pgmltevp(k), - 272 format(i2,1x,3(f12.9,1x)) - pgraupel(k)=-tmp_g*gindex - qgz(k)=amax1( 0.0,qgz(k)+dtb*pgraupel(k)) -! qgchg(k)=qgchg(k)+pgraupel(k) - qgchg(k)=pgraupel(k) - qgz(k)=qgz(k)*gindex -! - tmp=ocp/tothz(k)*xLf*(qschg(k)+qgchg(k)) - theiz(k)=theiz(k)+dtb*tmp - thz(k)=theiz(k)-(xLvocp*qvz(k)-xLfocp*qiz(k))/tothz(k) - - tem(k)=thz(k)*tothz(k) - temcc(k)=tem(k)-273.15 -! qswz(k)=episp0k*oprez(k)* & -! exp( svp2*temcc(k)/(tem(k)-svp3) ) - es=1000.*svp1*exp( svp2*temcc(k)/(tem(k)-svp3) ) - qswz(k)=ep2*es/(prez(k)-es) - qsiz(k)=qswz(k) - qvsbar(k)=qswz(k) -! - end if - preclw(k)=pclw(k) !sg - -! -!*********************************************************************** -!********** saturation adjustment ********** -!*********************************************************************** -! -! allow supersaturation exits linearly from 0% at 500 mb to 50% -! above 300 mb -! 5.0e-5=1.0/(500mb-300mb) -! - rsat=1.0+0.5*(50000.0-prez(k))*5.0e-5 - rsat=amax1(1.0,rsat) - rsat=amin1(1.5,rsat) - rsat=1.0 - if( qvz(k)+qlz(k)+qiz(k) .lt. rsat*qvsbar(k) ) then - -!c -!c unsaturated -!c - qvz(k)=qvz(k)+qlz(k)+qiz(k) - qlz(k)=0.0 - qiz(k)=0.0 - - thz(k)=theiz(k)-(xLvocp*qvz(k)-xLfocp*qiz(k))/tothz(k) - tem(k)=thz(k)*tothz(k) - temcc(k)=tem(k)-273.15 - - go to 1800 -! - else -!c -!c saturated -!c -! - pladj(k)=qlz(k) - piadj(k)=qiz(k) -! - - CALL satadj(qvz, qlz, qiz, prez, theiz, thz, tothz, kts, kte, & - k, xLvocp, xLfocp, episp0k, EP2,SVP1,SVP2,SVP3,SVPT0 ) - -! - pladj(k)=odtb*(qlz(k)-pladj(k)) - piadj(k)=odtb*(qiz(k)-piadj(k)) -! - pclw(k)=pclw(k)+pladj(k) - pcli(k)=pcli(k)+piadj(k) - pvapor(k)=pvapor(k)-( pladj(k)+piadj(k) ) -! - thz(k)=theiz(k)-(xLvocp*qvz(k)-xLfocp*qiz(k))/tothz(k) - tem(k)=thz(k)*tothz(k) - - temcc(k)=tem(k)-273.15 - -! qswz(k)=episp0k*oprez(k)* & -! exp( svp2*temcc(k)/(tem(k)-svp3) ) - es=1000.*svp1*exp( svp2*temcc(k)/(tem(k)-svp3) ) - qswz(k)=ep2*es/(prez(k)-es) - if (tem(k) .lt. 273.15 ) then -! qsiz(k)=episp0k*oprez(k)* & -! exp( 21.8745584*(tem(k)-273.16)/(tem(k)-7.66) ) - es=1000.*svp1*exp( 21.8745584*(tem(k)-273.16)/(tem(k)-7.66) ) - qsiz(k)=ep2*es/(prez(k)-es) - if (temcc(k) .lt. -40.0) qswz(k)=qsiz(k) - else - qsiz(k)=qswz(k) - endif - qlpqi=qlz(k)+qiz(k) - if ( qlpqi .eq. 0.0 ) then - qvsbar(k)=qsiz(k) - else - qvsbar(k)=( qiz(k)*qsiz(k)+qlz(k)*qswz(k) )/qlpqi - endif - - end if - -! -!*********************************************************************** -!***** melting and freezing of cloud ice and cloud water ***** -!*********************************************************************** - qlpqi=qlz(k)+qiz(k) - if(qlpqi .le. 0.0) go to 1800 -! -!c -!c (1) HOMOGENEOUS NUCLEATION WHEN T< -40 C (Pihom) -!c - if(temcc(k) .lt. -40.0) pihom(k)=qlz(k)*odtb -!c -!c (2) MELTING OF ICE CRYSTAL WHEN T> 0 C (Pimlt) -!c - if(temcc(k) .gt. 0.0) pimlt(k)=qiz(k)*odtb -!c -!c (3) PRODUCTION OF CLOUD ICE BY BERGERON PROCESS (Pidw): Hsie (p957) -!c this process only considered when -31 C < T < 0 C -!c - if(temcc(k) .lt. 0.0 .and. temcc(k) .gt. -31.0) then -!c! -!c! parama1 and parama2 functions must be user supplied -!c! - a1=parama1( temcc(k) ) - a2=parama2( temcc(k) ) -!! change unit from cgs to mks - a1=a1*0.001**(1.0-a2) - xnin=xni0*exp(-bni*temcc(k)) - pidw(k)=xnin*orho(k)*(a1*xmnin**a2) - end if -! - pcli(k)=pcli(k)+pihom(k)-pimlt(k)+pidw(k) - pclw(k)=pclw(k)-pihom(k)+pimlt(k)-pidw(k) - qlz(k)=amax1( 0.0,qlz(k)+dtb*(-pihom(k)+pimlt(k)-pidw(k)) ) - qiz(k)=amax1( 0.0,qiz(k)+dtb*(pihom(k)-pimlt(k)+pidw(k)) ) - -! - CALL satadj(qvz, qlz, qiz, prez, theiz, thz, tothz, kts, kte, & - k, xLvocp, xLfocp, episp0k ,EP2,SVP1,SVP2,SVP3,SVPT0) - - thz(k)=theiz(k)-(xLvocp*qvz(k)-xLfocp*qiz(k))/tothz(k) - tem(k)=thz(k)*tothz(k) - - temcc(k)=tem(k)-273.15 - -! qswz(k)=episp0k*oprez(k)* & -! exp( svp2*temcc(k)/(tem(k)-svp3) ) - es=1000.*svp1*exp( svp2*temcc(k)/(tem(k)-svp3) ) - qswz(k)=ep2*es/(prez(k)-es) - - if (tem(k) .lt. 273.15 ) then -! qsiz(k)=episp0k*oprez(k)* & -! exp( 21.8745584*(tem(k)-273.16)/(tem(k)-7.66) ) - es=1000.*svp1*exp( 21.8745584*(tem(k)-273.16)/(tem(k)-7.66) ) - qsiz(k)=ep2*es/(prez(k)-es) - if (temcc(k) .lt. -40.0) qswz(k)=qsiz(k) - else - qsiz(k)=qswz(k) - endif - qlpqi=qlz(k)+qiz(k) - if ( qlpqi .eq. 0.0 ) then - qvsbar(k)=qsiz(k) - else - qvsbar(k)=( qiz(k)*qsiz(k)+qlz(k)*qswz(k) )/qlpqi - endif - -1800 continue -! -!*********************************************************************** -!********** integrate the productions of rain and snow ********** -!*********************************************************************** -!c - -2000 continue - - -!--------------------------------------------------------------------- - -! -!*********************************************************************** -!****** Write terms in cloud physics to time series dataset ***** -!*********************************************************************** -! -! open(unit=24,form='formatted',status='new', -! & file='cloud.dat') - -!9030 format(10e12.6) - -! write(24,*)'tmp' -! write(24,9030) (tem(k),k=kts+1,kte) -! write(24,*)'qiz' -! write(24,9030) (qiz(k),k=kts+1,kte) -! write(24,*)'qsz' -! write(24,9030) (qsz(k),k=kts+1,kte) -! write(24,*)'qrz' -! write(24,9030) (qrz(k),k=kts+1,kte) -! write(24,*)'qgz' -! write(24,9030) (qgz(k),k=kts+1,kte) -! write(24,*)'qvoqsw' -! write(24,9030) (qvoqswz(k),k=kts+1,kte) -! write(24,*)'qvoqsi' -! write(24,9030) (qvoqsiz(k),k=kts+1,kte) -! write(24,*)'vtr' -! write(24,9030) (vtr(k),k=kts+1,kte) -! write(24,*)'vts' -! write(24,9030) (vts(k),k=kts+1,kte) -! write(24,*)'vtg' -! write(24,9030) (vtg(k),k=kts+1,kte) -! write(24,*)'pclw' -! write(24,9030) (pclw(k),k=kts+1,kte) -! write(24,*)'pvapor' -! write(24,9030) (pvapor(k),k=kts+1,kte) -! write(24,*)'pcli' -! write(24,9030) (pcli(k),k=kts+1,kte) -! write(24,*)'pimlt' -! write(24,9030) (pimlt(k),k=kts+1,kte) -! write(24,*)'pihom' -! write(24,9030) (pihom(k),k=kts+1,kte) -! write(24,*)'pidw' -! write(24,9030) (pidw(k),k=kts+1,kte) -! write(24,*)'prain' -! write(24,9030) (prain(k),k=kts+1,kte) -! write(24,*)'praut' -! write(24,9030) (praut(k),k=kts+1,kte) -! write(24,*)'pracw' -! write(24,9030) (pracw(k),k=kts+1,kte) -! write(24,*)'prevp' -! write(24,9030) (prevp(k),k=kts+1,kte) -! write(24,*)'psnow' -! write(24,9030) (psnow(k),k=kts+1,kte) -! write(24,*)'psaut' -! write(24,9030) (psaut(k),k=kts+1,kte) -! write(24,*)'psfw' -! write(24,9030) (psfw(k),k=kts+1,kte) -! write(24,*)'psfi' -! write(24,9030) (psfi(k),k=kts+1,kte) -! write(24,*)'praci' -! write(24,9030) (praci(k),k=kts+1,kte) -! write(24,*)'piacr' -! write(24,9030) (piacr(k),k=kts+1,kte) -! write(24,*)'psaci' -! write(24,9030) (psaci(k),k=kts+1,kte) -! write(24,*)'psacw' -! write(24,9030) (psacw(k),k=kts+1,kte) -! write(24,*)'psdep' -! write(24,9030) (psdep(k),k=kts+1,kte) -! write(24,*)'pssub' -! write(24,9030) (pssub(k),k=kts+1,kte) -! write(24,*)'pracs' -! write(24,9030) (pracs(k),k=kts+1,kte) -! write(24,*)'psacr' -! write(24,9030) (psacr(k),k=kts+1,kte) -! write(24,*)'psmlt' -! write(24,9030) (psmlt(k),k=kts+1,kte) -! write(24,*)'psmltevp' -! write(24,9030) (psmltevp(k),k=kts+1,kte) -! write(24,*)'pladj' -! write(24,9030) (pladj(k),k=kts+1,kte) -! write(24,*)'piadj' -! write(24,9030) (piadj(k),k=kts+1,kte) -! write(24,*)'pgraupel' -! write(24,9030) (pgraupel(k),k=kts+1,kte) -! write(24,*)'pgaut' -! write(24,9030) (pgaut(k),k=kts+1,kte) -! write(24,*)'pgfr' -! write(24,9030) (pgfr(k),k=kts+1,kte) -! write(24,*)'pgacw' -! write(24,9030) (pgacw(k),k=kts+1,kte) -! write(24,*)'pgaci' -! write(24,9030) (pgaci(k),k=kts+1,kte) -! write(24,*)'pgacr' -! write(24,9030) (pgacr(k),k=kts+1,kte) -! write(24,*)'pgacs' -! write(24,9030) (pgacs(k),k=kts+1,kte) -! write(24,*)'pgacip' -! write(24,9030) (pgacip(k),k=kts+1,kte) -! write(24,*)'pgacrP' -! write(24,9030) (pgacrP(k),k=kts+1,kte) -! write(24,*)'pgacsp' -! write(24,9030) (pgacsp(k),k=kts+1,kte) -! write(24,*)'pgwet' -! write(24,9030) (pgwet(k),k=kts+1,kte) -! write(24,*)'pdry' -! write(24,9030) (pdry(k),k=kts+1,kte) -! write(24,*)'pgsub' -! write(24,9030) (pgsub(k),k=kts+1,kte) -! write(24,*)'pgdep' -! write(24,9030) (pgdep(k),k=kts+1,kte) -! write(24,*)'pgmlt' -! write(24,9030) (pgmlt(k),k=kts+1,kte) -! write(24,*)'pgmltevp' -! write(24,9030) (pgmltevp(k),k=kts+1,kte) - - - -!**** below if qv < qvmin then qv=qvmin, ql=0.0, and qi=0.0 -! - do k=kts+1,kte - if ( qvz(k) .lt. qvmin ) then - qlz(k)=0.0 - qiz(k)=0.0 - qvz(k)=amax1( qvmin,qvz(k)+qlz(k)+qiz(k) ) - end if - enddo -! - END SUBROUTINE clphy1d - - -!--------------------------------------------------------------------- -! SATURATED ADJUSTMENT -!--------------------------------------------------------------------- - SUBROUTINE satadj(qvz, qlz, qiz, prez, theiz, thz, tothz, & - kts, kte, k, xLvocp, xLfocp, episp0k, EP2,SVP1,SVP2,SVP3,SVPT0) -!--------------------------------------------------------------------- - IMPLICIT NONE -!--------------------------------------------------------------------- -! This program use Newton's method for finding saturated temperature -! and saturation mixing ratio. -! -! In this saturation adjustment scheme we assume -! (1) the saturation mixing ratio is the mass weighted average of -! saturation values over liquid water (qsw), and ice (qsi) -! following Lord et al., 1984 and Tao, 1989 -! -! (2) the percentage of cloud liquid and cloud ice will -! be fixed during the saturation calculation -!--------------------------------------------------------------------- -! - - INTEGER, INTENT(IN ) :: kts, kte, k - - REAL, DIMENSION( kts:kte ), & - INTENT(INOUT) :: qvz, qlz, qiz -! - REAL, DIMENSION( kts:kte ), & - INTENT(IN ) :: prez, theiz, tothz - - REAL, INTENT(IN ) :: xLvocp, xLfocp, episp0k - REAL, INTENT(IN ) :: EP2,SVP1,SVP2,SVP3,SVPT0 - -! LOCAL VARS - - INTEGER :: n - - REAL, DIMENSION( kts:kte ) :: thz, tem, temcc, qsiz, & - qswz, qvsbar - - REAL :: qsat, qlpqi, ratql, t0, t1, tmp1, ratqi, tsat, absft, & - denom1, denom2, dqvsbar, ftsat, dftsat, qpz, & - gindex, es -! -!--------------------------------------------------------------------- - - thz(k)=theiz(k)-(xLvocp*qvz(k)-xLfocp*qiz(k))/tothz(k) - - tem(k)=tothz(k)*thz(k) - if (tem(k) .gt. 273.15) then -! qsat=episp0k/prez(k)* & -! exp( svp2*(tem(k)-273.15)/(tem(k)-svp3) ) - es=1000.*svp1*exp( svp2*(tem(k)-svpt0)/(tem(k)-svp3) ) - qsat=ep2*es/(prez(k)-es) - else - qsat=episp0k/prez(k)* & - exp( 21.8745584*(tem(k)-273.15)/(tem(k)-7.66) ) - end if - qpz=qvz(k)+qlz(k)+qiz(k) - if (qpz .lt. qsat) then - qvz(k)=qpz - qiz(k)=0.0 - qlz(k)=0.0 - go to 400 - end if - qlpqi=qlz(k)+qiz(k) - if( qlpqi .ge. 1.0e-5) then - ratql=qlz(k)/qlpqi - ratqi=qiz(k)/qlpqi - else - t0=273.15 -! t1=233.15 - t1=248.15 - tmp1=( t0-tem(k) )/(t0-t1) - tmp1=amin1(1.0,tmp1) - tmp1=amax1(0.0,tmp1) - ratqi=tmp1 - ratql=1.0-tmp1 - end if -! -! -!-- saturation mixing ratios over water and ice -!-- at the outset we will follow Bolton 1980 MWR for -!-- the water and Murray JAS 1967 for the ice -! -!-- dqvsbar=d(qvsbar)/dT -!-- ftsat=F(Tsat) -!-- dftsat=d(F(T))/dT -! -! First guess of tsat - - tsat=tem(k) - absft=1.0 -! - do 200 n=1,20 - denom1=1.0/(tsat-svp3) - denom2=1.0/(tsat-7.66) -! qswz(k)=episp0k/prez(k)* & -! exp( svp2*denom1*(tsat-273.15) ) - es=1000.*svp1*exp( svp2*denom1*(tsat-svpt0) ) - qswz(k)=ep2*es/(prez(k)-es) - if (tem(k) .lt. 273.15) then -! qsiz(k)=episp0k/prez(k)* & -! exp( 21.8745584*denom2*(tsat-273.15) ) - es=1000.*svp1*exp( 21.8745584*denom2*(tsat-273.15) ) - qsiz(k)=ep2*es/(prez(k)-es) - if (tem(k) .lt. 233.15) qswz(k)=qsiz(k) - else - qsiz(k)=qswz(k) - endif - qvsbar(k)=ratql*qswz(k)+ratqi*qsiz(k) -! -! if( absft .lt. 0.01 .and. n .gt. 3 ) go to 300 - if( absft .lt. 0.01 ) go to 300 -! - dqvsbar=ratql*qswz(k)*svp2*243.5*denom1*denom1+ & - ratqi*qsiz(k)*21.8745584*265.5*denom2*denom2 - ftsat=tsat+(xlvocp+ratqi*xlfocp)*qvsbar(k)- & - tothz(k)*theiz(k)-xlfocp*ratqi*(qvz(k)+qlz(k)+qiz(k)) - dftsat=1.0+(xlvocp+ratqi*xlfocp)*dqvsbar - tsat=tsat-ftsat/dftsat - absft=abs(ftsat) - -200 continue -9020 format(1x,'point can not converge, absft,n=',e12.5,i5) -! -300 continue - if( qpz .gt. qvsbar(k) ) then - qvz(k)=qvsbar(k) - qiz(k)=ratqi*( qpz-qvz(k) ) - qlz(k)=ratql*( qpz-qvz(k) ) - else - qvz(k)=qpz - qiz(k)=0.0 - qlz(k)=0.0 - end if - 400 continue - - END SUBROUTINE satadj - - -!---------------------------------------------------------------- - REAL FUNCTION parama1(temp) -!---------------------------------------------------------------- - IMPLICIT NONE -!---------------------------------------------------------------- -! This program calculate the parameter for crystal growth rate -! in Bergeron process -!---------------------------------------------------------------- - - REAL, INTENT (IN ) :: temp - REAL, DIMENSION(32) :: a1 - INTEGER :: i1, i1p1 - REAL :: ratio - - data a1/0.100e-10,0.7939e-7,0.7841e-6,0.3369e-5,0.4336e-5, & - 0.5285e-5,0.3728e-5,0.1852e-5,0.2991e-6,0.4248e-6, & - 0.7434e-6,0.1812e-5,0.4394e-5,0.9145e-5,0.1725e-4, & - 0.3348e-4,0.1725e-4,0.9175e-5,0.4412e-5,0.2252e-5, & - 0.9115e-6,0.4876e-6,0.3473e-6,0.4758e-6,0.6306e-6, & - 0.8573e-6,0.7868e-6,0.7192e-6,0.6513e-6,0.5956e-6, & - 0.5333e-6,0.4834e-6/ - - i1=int(-temp)+1 - i1p1=i1+1 - ratio=-(temp)-float(i1-1) - parama1=a1(i1)+ratio*( a1(i1p1)-a1(i1) ) - - END FUNCTION parama1 - -!---------------------------------------------------------------- - REAL FUNCTION parama2(temp) -!---------------------------------------------------------------- - IMPLICIT NONE -!---------------------------------------------------------------- -! This program calculate the parameter for crystal growth rate -! in Bergeron process -!---------------------------------------------------------------- - - REAL, INTENT (IN ) :: temp - REAL, DIMENSION(32) :: a2 - INTEGER :: i1, i1p1 - REAL :: ratio - - data a2/0.0100,0.4006,0.4831,0.5320,0.5307,0.5319,0.5249, & - 0.4888,0.3849,0.4047,0.4318,0.4771,0.5183,0.5463, & - 0.5651,0.5813,0.5655,0.5478,0.5203,0.4906,0.4447, & - 0.4126,0.3960,0.4149,0.4320,0.4506,0.4483,0.4460, & - 0.4433,0.4413,0.4382,0.4361/ - i1=int(-temp)+1 - i1p1=i1+1 - ratio=-(temp)-float(i1-1) - parama2=a2(i1)+ratio*( a2(i1p1)-a2(i1) ) - - END FUNCTION parama2 - -!---------------------------------------------------------------- - REAL FUNCTION ggamma(X) -!---------------------------------------------------------------- - IMPLICIT NONE -!---------------------------------------------------------------- - REAL, INTENT(IN ) :: x - REAL, DIMENSION(8) :: B - INTEGER ::j, K1 - REAL ::PF, G1TO2 ,TEMP - - DATA B/-.577191652,.988205891,-.897056937,.918206857, & - -.756704078,.482199394,-.193527818,.035868343/ - - PF=1. - TEMP=X - DO 10 J=1,200 - IF (TEMP .LE. 2) GO TO 20 - TEMP=TEMP-1. - 10 PF=PF*TEMP - 100 FORMAT(//,5X,'module_mp_lin: INPUT TO GAMMA FUNCTION TOO LARGE, X=',E12.5) -! WRITE(wrf_err_message,100)X -! CALL wrf_error_fatal(wrf_err_message) - 20 G1TO2=1. - TEMP=TEMP - 1. - DO 30 K1=1,8 - 30 G1TO2=G1TO2 + B(K1)*TEMP**K1 - ggamma=PF*G1TO2 - - END FUNCTION ggamma - -!---------------------------------------------------------------- - -END MODULE module_mp_lin - diff --git a/src/fim/FIMsrc/fim/wrfphys/module_mp_morr_two_moment.F b/src/fim/FIMsrc/fim/wrfphys/module_mp_morr_two_moment.F deleted file mode 100644 index dc66d0d..0000000 --- a/src/fim/FIMsrc/fim/wrfphys/module_mp_morr_two_moment.F +++ /dev/null @@ -1,4036 +0,0 @@ -!WRF:MODEL_LAYER:PHYSICS -! - -! THIS MODULE CONTAINS THE TWO-MOMENT MICROPHYSICS CODE DESCRIBED BY -! MORRISON ET AL. 2005 JAS; MORRISON AND PINTO 2005 JAS. -! ADDITIONAL CHANGES ARE DESCRIBED IN DETAIL BY MORRISON, THOMPSON, TATARSKII (MWR, SUBMITTED) - -! THIS SCHEME IS A BULK DOUBLE-MOMENT SCHEME THAT PREDICTS MIXING -! RATIOS AND NUMBER CONCENTRATIONS OF FIVE HYDROMETEOR SPECIES: -! CLOUD DROPLETS, CLOUD (SMALL) ICE, RAIN, SNOW, AND GRAUPEL. - -MODULE MODULE_MP_MORR_TWO_MOMENT -! USE module_wrf_error -! USE module_utility, ONLY: WRFU_Clock, WRFU_Alarm ! GT -! USE module_domain, ONLY : HISTORY_ALARM, Is_alarm_tstep ! GT - -! USE module_state_description - - IMPLICIT NONE - - REAL, PARAMETER :: PI = 3.1415926535897932384626434 - REAL, PARAMETER :: SQRTPI = 0.9189385332046727417803297 - - PUBLIC :: MP_MORR_TWO_MOMENT - PUBLIC :: POLYSVP - - PRIVATE :: GAMMA, DERF1 - PRIVATE :: PI, SQRTPI - PRIVATE :: MORR_TWO_MOMENT_MICRO - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! SWITCHES FOR MICROPHYSICS SCHEME -! IACT = 1, USE POWER-LAW CCN SPECTRA, NCCN = CS^K -! IACT = 2, USE LOGNORMAL AEROSOL SIZE DIST TO DERIVE CCN SPECTRA - - INTEGER, PRIVATE :: IACT - -! INUM = 0, PREDICT DROPLET CONCENTRATION -! INUM = 1, ASSUME CONSTANT DROPLET CONCENTRATION -! !!!NOTE: PREDICTED DROPLET CONCENTRATION NOT AVAILABLE IN THIS VERSION -! CONTACT HUGH MORRISON (morrison@ucar.edu) FOR FURTHER INFORMATION - - INTEGER, PRIVATE :: INUM - -! FOR INUM = 1, SET CONSTANT DROPLET CONCENTRATION (CM-3) - REAL, PRIVATE :: NDCNST - -! SWITCH FOR LIQUID-ONLY RUN -! ILIQ = 0, INCLUDE ICE -! ILIQ = 1, LIQUID ONLY, NO ICE - - INTEGER, PRIVATE :: ILIQ - -! SWITCH FOR ICE NUCLEATION -! INUC = 0, USE FORMULA FROM RASMUSSEN ET AL. 2002 (MID-LATITUDE) -! = 1, USE MPACE OBSERVATIONS - - INTEGER, PRIVATE :: INUC - -! IBASE = 1, NEGLECT DROPLET ACTIVATION AT LATERAL CLOUD EDGES DUE TO -! UNRESOLVED ENTRAINMENT AND MIXING, ACTIVATE -! AT CLOUD BASE OR IN REGION WITH LITTLE CLOUD WATER USING -! NON-EQULIBRIUM SUPERSATURATION, -! IN CLOUD INTERIOR ACTIVATE USING EQUILIBRIUM SUPERSATURATION -! IBASE = 2, ASSUME DROPLET ACTIVATION AT LATERAL CLOUD EDGES DUE TO -! UNRESOLVED ENTRAINMENT AND MIXING DOMINATES, -! ACTIVATE DROPLETS EVERYWHERE IN THE CLOUD USING NON-EQUILIBRIUM -! SUPERSATURATION, BASED ON THE -! LOCAL SUB-GRID AND/OR GRID-SCALE VERTICAL VELOCITY -! AT THE GRID POINT - -! NOTE: ONLY USED FOR PREDICTED DROPLET CONCENTRATION (INUM = 0) - - INTEGER, PRIVATE :: IBASE - -! INCLUDE SUB-GRID VERTICAL VELOCITY IN DROPLET ACTIVATION -! ISUB = 0, INCLUDE SUB-GRID W (RECOMMENDED FOR LOWER RESOLUTION) -! ISUB = 1, EXCLUDE SUB-GRID W, ONLY USE GRID-SCALE W - - INTEGER, PRIVATE :: ISUB - -! SWITCH FOR GRAUPEL/NO GRAUPEL -! IGRAUP = 0, INCLUDE GRAUPEL -! IGRAUP = 1, NO GRAUPEL - - INTEGER, PRIVATE :: IGRAUP - -! HM ADDED NEW OPTION FOR HAIL -! SWITCH FOR HAIL/GRAUPEL -! IHAIL = 0, DENSE PRECIPITATING ICE IS GRAUPEL -! IHAIL = 1, DENSE PRECIPITATING GICE IS HAIL - - INTEGER, PRIVATE :: IHAIL - -! CLOUD MICROPHYSICS CONSTANTS - - REAL, PRIVATE :: AI,AC,AS,AR,AG ! 'A' PARAMETER IN FALLSPEED-DIAM RELATIONSHIP - REAL, PRIVATE :: BI,BC,BS,BR,BG ! 'B' PARAMETER IN FALLSPEED-DIAM RELATIONSHIP - REAL, PRIVATE :: R ! GAS CONSTANT FOR AIR - REAL, PRIVATE :: RV ! GAS CONSTANT FOR WATER VAPOR - REAL, PRIVATE :: CP ! SPECIFIC HEAT AT CONSTANT PRESSURE FOR DRY AIR - REAL, PRIVATE :: RHOSU ! STANDARD AIR DENSITY AT 850 MB - REAL, PRIVATE :: RHOW ! DENSITY OF LIQUID WATER - REAL, PRIVATE :: RHOI ! BULK DENSITY OF CLOUD ICE - REAL, PRIVATE :: RHOSN ! BULK DENSITY OF SNOW - REAL, PRIVATE :: RHOG ! BULK DENSITY OF GRAUPEL - REAL, PRIVATE :: AIMM ! PARAMETER IN BIGG IMMERSION FREEZING - REAL, PRIVATE :: BIMM ! PARAMETER IN BIGG IMMERSION FREEZING - REAL, PRIVATE :: ECR ! COLLECTION EFFICIENCY BETWEEN DROPLETS/RAIN AND SNOW/RAIN - REAL, PRIVATE :: DCS ! THRESHOLD SIZE FOR CLOUD ICE AUTOCONVERSION - REAL, PRIVATE :: MI0 ! INITIAL SIZE OF NUCLEATED CRYSTAL - REAL, PRIVATE :: MG0 ! MASS OF EMBRYO GRAUPEL - REAL, PRIVATE :: F1S ! VENTILATION PARAMETER FOR SNOW - REAL, PRIVATE :: F2S ! VENTILATION PARAMETER FOR SNOW - REAL, PRIVATE :: F1R ! VENTILATION PARAMETER FOR RAIN - REAL, PRIVATE :: F2R ! VENTILATION PARAMETER FOR RAIN - REAL, PRIVATE :: G ! GRAVITATIONAL ACCELERATION - REAL, PRIVATE :: QSMALL ! SMALLEST ALLOWED HYDROMETEOR MIXING RATIO - REAL, PRIVATE :: CI,DI,CS,DS,CG,DG ! SIZE DISTRIBUTION PARAMETERS FOR CLOUD ICE, SNOW, GRAUPEL - REAL, PRIVATE :: EII ! COLLECTION EFFICIENCY, ICE-ICE COLLISIONS - REAL, PRIVATE :: ECI ! COLLECTION EFFICIENCY, ICE-DROPLET COLLISIONS - REAL, PRIVATE :: RIN ! RADIUS OF CONTACT NUCLEI (M) - -! CCN SPECTRA FOR IACT = 1 - - REAL, PRIVATE :: C1 ! 'C' IN NCCN = CS^K (CM-3) - REAL, PRIVATE :: K1 ! 'K' IN NCCN = CS^K - -! AEROSOL PARAMETERS FOR IACT = 2 - - REAL, PRIVATE :: MW ! MOLECULAR WEIGHT WATER (KG/MOL) - REAL, PRIVATE :: OSM ! OSMOTIC COEFFICIENT - REAL, PRIVATE :: VI ! NUMBER OF ION DISSOCIATED IN SOLUTION - REAL, PRIVATE :: EPSM ! AEROSOL SOLUBLE FRACTION - REAL, PRIVATE :: RHOA ! AEROSOL BULK DENSITY (KG/M3) - REAL, PRIVATE :: MAP ! MOLECULAR WEIGHT AEROSOL (KG/MOL) - REAL, PRIVATE :: MA ! MOLECULAR WEIGHT OF 'AIR' (KG/MOL) - REAL, PRIVATE :: RR ! UNIVERSAL GAS CONSTANT - REAL, PRIVATE :: BACT ! ACTIVATION PARAMETER - REAL, PRIVATE :: RM1 ! GEOMETRIC MEAN RADIUS, MODE 1 (M) - REAL, PRIVATE :: RM2 ! GEOMETRIC MEAN RADIUS, MODE 2 (M) - REAL, PRIVATE :: NANEW1 ! TOTAL AEROSOL CONCENTRATION, MODE 1 (M^-3) - REAL, PRIVATE :: NANEW2 ! TOTAL AEROSOL CONCENTRATION, MODE 2 (M^-3) - REAL, PRIVATE :: SIG1 ! STANDARD DEVIATION OF AEROSOL S.D., MODE 1 - REAL, PRIVATE :: SIG2 ! STANDARD DEVIATION OF AEROSOL S.D., MODE 2 - REAL, PRIVATE :: F11 ! CORRECTION FACTOR FOR ACTIVATION, MODE 1 - REAL, PRIVATE :: F12 ! CORRECTION FACTOR FOR ACTIVATION, MODE 1 - REAL, PRIVATE :: F21 ! CORRECTION FACTOR FOR ACTIVATION, MODE 2 - REAL, PRIVATE :: F22 ! CORRECTION FACTOR FOR ACTIVATION, MODE 2 - REAL, PRIVATE :: MMULT ! MASS OF SPLINTERED ICE PARTICLE - REAL, PRIVATE :: LAMMAXI,LAMMINI,LAMMAXR,LAMMINR,LAMMAXS,LAMMINS,LAMMAXG,LAMMING - -! CONSTANTS TO IMPROVE EFFICIENCY - - REAL, PRIVATE :: CONS1,CONS2,CONS3,CONS4,CONS5,CONS6,CONS7,CONS8,CONS9,CONS10 - REAL, PRIVATE :: CONS11,CONS12,CONS13,CONS14,CONS15,CONS16,CONS17,CONS18,CONS19,CONS20 - REAL, PRIVATE :: CONS21,CONS22,CONS23,CONS24,CONS25,CONS26,CONS27,CONS28,CONS29,CONS30 - REAL, PRIVATE :: CONS31,CONS32,CONS33,CONS34,CONS35,CONS36,CONS37,CONS38,CONS39,CONS40 - REAL, PRIVATE :: CONS41 - -CONTAINS - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -SUBROUTINE MORR_TWO_MOMENT_INIT -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! THIS SUBROUTINE INITIALIZES ALL PHYSICAL CONSTANTS AMND PARAMETERS -! NEEDED BY THE MICROPHYSICS SCHEME. -! NEEDS TO BE CALLED AT FIRST TIME STEP, PRIOR TO CALL TO MAIN MICROPHYSICS INTERFACE -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - IMPLICIT NONE - - integer n,i - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! THE FOLLOWING PARAMETERS ARE USER-DEFINED SWITCHES AND NEED TO BE -! SET PRIOR TO CODE COMPILATION - -! INUM = 0, PREDICT DROPLET CONCENTRATION -! INUM = 1, ASSUME CONSTANT DROPLET CONCENTRATION -! !!!NOTE: PREDICTED DROPLET CONCENTRATION NOT AVAILABLE IN THIS VERSION -! CONTACT HUGH MORRISON (morrison@ucar.edu) FOR FURTHER INFORMATION -! INUM=1 ONLY IN CURRENT VERSION - - INUM = 1 - -! FOR INUM = 1, SET CONSTANT DROPLET CONCENTRATION (UNITS OF CM-3) - - NDCNST = 250. - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! NOTE, FOLLOWING OPTIONS NOT AVAILABLE IN CURRENT VERSION -! ONLY USED WHEN INUM=0 - - -! IACT = 1, USE POWER-LAW CCN SPECTRA, NCCN = CS^K -! IACT = 2, USE LOGNORMAL AEROSOL SIZE DIST TO DERIVE CCN SPECTRA -! NOTE: ONLY USED FOR PREDICTED DROPLET CONCENTRATION (INUM = 0) - - IACT = 2 - -! IBASE = 1, NEGLECT DROPLET ACTIVATION AT LATERAL CLOUD EDGES DUE TO -! UNRESOLVED ENTRAINMENT AND MIXING, ACTIVATE -! AT CLOUD BASE OR IN REGION WITH LITTLE CLOUD WATER USING -! NON-EQULIBRIUM SUPERSATURATION ASSUMING NO INITIAL CLOUD WATER, -! IN CLOUD INTERIOR ACTIVATE USING EQUILIBRIUM SUPERSATURATION -! IBASE = 2, ASSUME DROPLET ACTIVATION AT LATERAL CLOUD EDGES DUE TO -! UNRESOLVED ENTRAINMENT AND MIXING DOMINATES, -! ACTIVATE DROPLETS EVERYWHERE IN THE CLOUD USING NON-EQUILIBRIUM -! SUPERSATURATION ASSUMING NO INITIAL CLOUD WATER, BASED ON THE -! LOCAL SUB-GRID AND/OR GRID-SCALE VERTICAL VELOCITY -! AT THE GRID POINT - -! NOTE: ONLY USED FOR PREDICTED DROPLET CONCENTRATION (INUM = 0) - - IBASE = 2 - -! INCLUDE SUB-GRID VERTICAL VELOCITY (standard deviation of w) IN DROPLET ACTIVATION -! ISUB = 0, INCLUDE SUB-GRID W (RECOMMENDED FOR LOWER RESOLUTION) -! currently, sub-grid w is constant of 0.5 m/s (not coupled with PBL/turbulence scheme) -! ISUB = 1, EXCLUDE SUB-GRID W, ONLY USE GRID-SCALE W - -! NOTE: ONLY USED FOR PREDICTED DROPLET CONCENTRATION (INUM = 0) - - ISUB = 0 -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - -! SWITCH FOR LIQUID-ONLY RUN -! ILIQ = 0, INCLUDE ICE -! ILIQ = 1, LIQUID ONLY, NO ICE - - ILIQ = 0 - -! SWITCH FOR ICE NUCLEATION -! INUC = 0, USE FORMULA FROM RASMUSSEN ET AL. 2002 (MID-LATITUDE) -! = 1, USE MPACE OBSERVATIONS (ARCTIC ONLY) - - INUC = 0 - -! SWITCH FOR GRAUPEL/HAIL NO GRAUPEL/HAIL -! IGRAUP = 0, INCLUDE GRAUPEL/HAIL -! IGRAUP = 1, NO GRAUPEL/HAIL - - IGRAUP = 0 - -! HM ADDED 11/7/07 -! SWITCH FOR HAIL/GRAUPEL -! IHAIL = 0, DENSE PRECIPITATING ICE IS GRAUPEL -! IHAIL = 1, DENSE PRECIPITATING ICE IS HAIL -! NOTE ---> RECOMMEND IHAIL = 1 FOR CONTINENTAL DEEP CONVECTION - - IHAIL = 0 - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! SET PHYSICAL CONSTANTS - -! FALLSPEED PARAMETERS (V=AD^B) - AI = 700. - AC = 3.E7 - AS = 11.72 - AR = 841.99667 - BI = 1. - BC = 2. - BS = 0.41 - BR = 0.8 - IF (IHAIL.EQ.0) THEN - AG = 19.3 - BG = 0.37 - ELSE ! (MATSUN AND HUGGINS 1980) - AG = 114.5 - BG = 0.5 - END IF - -! CONSTANTS AND PARAMETERS - R = 287.15 - RV = 461.5 - CP = 1005. - RHOSU = 85000./(287.15*273.15) - RHOW = 997. - RHOI = 500. - RHOSN = 100. - IF (IHAIL.EQ.0) THEN - RHOG = 400. - ELSE - RHOG = 900. - END IF - AIMM = 0.66 - BIMM = 100. - ECR = 1. - DCS = 125.E-6 - MI0 = 4./3.*PI*RHOI*(10.E-6)**3 - MG0 = 1.6E-10 - F1S = 0.86 - F2S = 0.28 - F1R = 0.78 - F2R = 0.32 - G = 9.806 - QSMALL = 1.E-14 - EII = 0.1 - ECI = 0.7 - -! SIZE DISTRIBUTION PARAMETERS - - CI = RHOI*PI/6. - DI = 3. - CS = RHOSN*PI/6. - DS = 3. - CG = RHOG*PI/6. - DG = 3. - -! RADIUS OF CONTACT NUCLEI - RIN = 0.1E-6 - - MMULT = 4./3.*PI*RHOI*(5.E-6)**3 - -! SIZE LIMITS FOR LAMBDA - - LAMMAXI = 1./1.E-6 - LAMMINI = 1./(2.*DCS+100.E-6) - LAMMAXR = 1./20.E-6 - LAMMINR = 1./500.E-6 - LAMMAXS = 1./10.E-6 - LAMMINS = 1./2000.E-6 - LAMMAXG = 1./20.E-6 - LAMMING = 1./2000.E-6 - -! CCN SPECTRA FOR IACT = 1 - -! MARITIME -! MODIFIED FROM RASMUSSEN ET AL. 2002 -! NCCN = C*S^K, NCCN IS IN CM-3, S IS SUPERSATURATION RATIO IN % - - K1 = 0.4 - C1 = 120. - -! CONTINENTAL - -! K1 = 0.5 -! C1 = 1000. - -! AEROSOL ACTIVATION PARAMETERS FOR IACT = 2 -! PARAMETERS CURRENTLY SET FOR AMMONIUM SULFATE - - MW = 0.018 - OSM = 1. - VI = 3. - EPSM = 0.7 - RHOA = 1777. - MAP = 0.132 - MA = 0.0284 - RR = 8.3187 - BACT = VI*OSM*EPSM*MW*RHOA/(MAP*RHOW) - -! AEROSOL SIZE DISTRIBUTION PARAMETERS CURRENTLY SET FOR MPACE -! (see morrison et al. 2007, JGR) -! MODE 1 - - RM1 = 0.052E-6 - SIG1 = 2.04 - NANEW1 = 72.2E6 - F11 = 0.5*EXP(2.5*(LOG(SIG1))**2) - F21 = 1.+0.25*LOG(SIG1) - -! MODE 2 - - RM2 = 1.3E-6 - SIG2 = 2.5 - NANEW2 = 1.8E6 - F12 = 0.5*EXP(2.5*(LOG(SIG2))**2) - F22 = 1.+0.25*LOG(SIG2) - -! CONSTANTS FOR EFFICIENCY - - CONS1=GAMMA(1.+DS)*CS - CONS2=GAMMA(1.+DG)*CG - CONS3=GAMMA(4.+BS)/6. - CONS4=GAMMA(4.+BR)/6. - CONS5=GAMMA(1.+BS) - CONS6=GAMMA(1.+BR) - CONS7=GAMMA(4.+BG)/6. - CONS8=GAMMA(1.+BG) - CONS9=GAMMA(5./2.+BR/2.) - CONS10=GAMMA(5./2.+BS/2.) - CONS11=GAMMA(5./2.+BG/2.) - CONS12=GAMMA(1.+DI)*CI - CONS13=GAMMA(BS+3.)*PI/4.*ECI - CONS14=GAMMA(BG+3.)*PI/4.*ECI - CONS15=-1108.*EII*PI**((1.-BS)/3.)*RHOSN**((-2.-BS)/3.)/(4.*720.) - CONS16=GAMMA(BI+3.)*PI/4.*ECI - CONS17=4.*2.*3.*RHOSU*PI*ECI*ECI*GAMMA(2.*BS+2.)/(8.*(RHOG-RHOSN)) - CONS18=RHOSN*RHOSN - CONS19=RHOW*RHOW - CONS20=20.*PI*PI*RHOW*BIMM - CONS21=4./(DCS*RHOI) - CONS22=PI*RHOI*DCS**3/6. - CONS23=PI/4.*EII*GAMMA(BS+3.) - CONS24=PI/4.*ECR*GAMMA(BR+3.) - CONS25=PI*PI/24.*RHOW*ECR*GAMMA(BR+6.) - CONS26=PI/6.*RHOW - CONS27=GAMMA(1.+BI) - CONS28=GAMMA(4.+BI)/6. - CONS29=4./3.*PI*RHOW*(25.E-6)**3 - CONS30=4./3.*PI*RHOW - CONS31=PI*PI*ECR*RHOSN - CONS32=PI/2.*ECR - CONS33=PI*PI*ECR*RHOG - CONS34=5./2.+BR/2. - CONS35=5./2.+BS/2. - CONS36=5./2.+BG/2. - CONS37=4.*PI*1.38E-23/(6.*PI*RIN) - CONS38=PI*PI/3.*RHOW - CONS39=PI*PI/36.*RHOW*BIMM - CONS40=PI/6.*BIMM - CONS41=PI*PI*ECR*RHOW - -END SUBROUTINE MORR_TWO_MOMENT_INIT - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! THIS SUBROUTINE IS MAIN INTERFACE WITH THE TWO-MOMENT MICROPHYSICS SCHEME -! THIS INTERFACE TAKES IN 3D VARIABLES FROM DRIVER MODEL, CONVERTS TO 1D FOR -! CALL TO THE MAIN MICROPHYSICS SUBROUTINE (SUBROUTINE MORR_TWO_MOMENT_MICRO) -! WHICH OPERATES ON 1D VERTICAL COLUMNS. -! 1D VARIABLES FROM THE MAIN MICROPHYSICS SUBROUTINE ARE THEN REASSIGNED BACK TO 3D FOR OUTPUT -! BACK TO DRIVER MODEL USING THIS INTERFACE. -! MICROPHYSICS TENDENCIES ARE ADDED TO VARIABLES HERE BEFORE BEING PASSED BACK TO DRIVER MODEL. - -! THIS CODE WAS WRITTEN BY HUGH MORRISON (NCAR) AND SLAVA TATARSKII (GEORGIA TECH). - -! FOR QUESTIONS, CONTACT: HUGH MORRISON, E-MAIL: MORRISON@UCAR.EDU, PHONE:303-497-8916 - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -SUBROUTINE MP_MORR_TWO_MOMENT(ITIMESTEP, & - TH, QV, QC, QR, QI, QS, QG, NI, NS, NR, NG, & - RHO, PII, P, DT_IN, DZ, HT, W, & - RAINNC, RAINNCV, SR, & - qrcuten, qscuten, qicuten, mu & ! hm added - ,IDS,IDE, JDS,JDE, KDS,KDE & ! domain dims - ,IMS,IME, JMS,JME, KMS,KME & ! memory dims - ,ITS,ITE, JTS,JTE, KTS,KTE & ! tile dims ) - ) - -! QV - water vapor mixing ratio (kg/kg) -! QC - cloud water mixing ratio (kg/kg) -! QR - rain water mixing ratio (kg/kg) -! QI - cloud ice mixing ratio (kg/kg) -! QS - snow mixing ratio (kg/kg) -! QG - graupel mixing ratio (KG/KG) -! NI - cloud ice number concentration (1/kg) -! NS - Snow Number concentration (1/kg) -! NR - Rain Number concentration (1/kg) -! NG - Graupel number concentration (1/kg) -! NOTE: RHO AND HT NOT USED BY THIS SCHEME AND DO NOT NEED TO BE PASSED INTO SCHEME!!!! -! P - AIR PRESSURE (PA) -! W - VERTICAL AIR VELOCITY (M/S) -! TH - POTENTIAL TEMPERATURE (K) -! PII - exner function - used to convert potential temp to temp -! DZ - difference in height over interface (m) -! DT_IN - model time step (sec) -! ITIMESTEP - time step counter -! RAINNC - accumulated grid-scale precipitation (mm) -! RAINNCV - one time step grid scale precipitation (mm/time step) -! SR - one time step mass ratio of snow to total precip -! qrcuten, rain tendency from parameterized cumulus convection -! qscuten, snow tendency from parameterized cumulus convection -! qicuten, cloud ice tendency from parameterized cumulus convection - -! variables below currently not in use, not coupled to PBL or radiation codes -! TKE - turbulence kinetic energy (m^2 s-2), NEEDED FOR DROPLET ACTIVATION (SEE CODE BELOW) -! NCTEND - droplet concentration tendency from pbl (kg-1 s-1) -! NCTEND - CLOUD ICE concentration tendency from pbl (kg-1 s-1) -! KZH - heat eddy diffusion coefficient from YSU scheme (M^2 S-1), NEEDED FOR DROPLET ACTIVATION (SEE CODE BELOW) -! EFFCS - CLOUD DROPLET EFFECTIVE RADIUS OUTPUT TO RADIATION CODE (micron) -! EFFIS - CLOUD DROPLET EFFECTIVE RADIUS OUTPUT TO RADIATION CODE (micron) -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! reflectivity currently not included!!!! -! REFL_10CM - CALCULATED RADAR REFLECTIVITY AT 10 CM (DBZ) -!................................ -! GRID_CLOCK, GRID_ALARMS - parameters to limit radar reflectivity calculation only when needed -! otherwise radar reflectivity calculation every time step is too slow -! only needed for coupling with WRF, see code below for details -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! EFFC - DROPLET EFFECTIVE RADIUS (MICRON) -! EFFR - RAIN EFFECTIVE RADIUS (MICRON) -! EFFS - SNOW EFFECTIVE RADIUS (MICRON) -! EFFI - CLOUD ICE EFFECTIVE RADIUS (MICRON) - -! ADDITIONAL OUTPUT FROM MICRO - SEDIMENTATION TENDENCIES, NEEDED FOR LIQUID-ICE STATIC ENERGY - -! QGSTEN - GRAUPEL SEDIMENTATION TEND (KG/KG/S) -! QRSTEN - RAIN SEDIMENTATION TEND (KG/KG/S) -! QISTEN - CLOUD ICE SEDIMENTATION TEND (KG/KG/S) -! QNISTEN - SNOW SEDIMENTATION TEND (KG/KG/S) -! QCSTEN - CLOUD WATER SEDIMENTATION TEND (KG/KG/S) - -! ADDITIONAL INPUT NEEDED BY MICRO -! ********NOTE: WVAR IS SHOULD BE USED IN DROPLET ACTIVATION -! FOR CASES WHEN UPDRAFT IS NOT RESOLVED, EITHER BECAUSE OF -! LOW MODEL RESOLUTION OR CLOUD TYPE -! WVAR - STANDARD DEVIATION OF SUB-GRID VERTICAL VELOCITY (M/S) - - IMPLICIT NONE - - INTEGER, INTENT(IN ) :: ids, ide, jds, jde, kds, kde , & - ims, ime, jms, jme, kms, kme , & - its, ite, jts, jte, kts, kte -! Temporary changed from INOUT to IN - - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & - qv, qc, qr, qi, qs, qg, ni, ns, nr, TH, NG -!, effcs, effis - - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN):: & - pii, p, dz, rho, w !, tke, nctend, nitend,kzh - REAL, INTENT(IN):: dt_in - INTEGER, INTENT(IN):: ITIMESTEP - - REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT):: & - RAINNC, RAINNCV, SR - -! REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & ! GT -! refl_10cm - - REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN) :: ht - -! TYPE (WRFU_Clock):: grid_clock ! GT -! TYPE (WRFU_Alarm), POINTER:: grid_alarms(:) ! GT - - ! LOCAL VARIABLES - - REAL, DIMENSION(its:ite, kts:kte, jts:jte):: & - effi, effs, effr, EFFG - - REAL, DIMENSION(its:ite, kts:kte, jts:jte):: & - T, WVAR, EFFC - - REAL, DIMENSION(kts:kte) :: & - QC_TEND1D, QI_TEND1D, QNI_TEND1D, QR_TEND1D, & - NI_TEND1D, NS_TEND1D, NR_TEND1D, & - QC1D, QI1D, QR1D,NI1D, NS1D, NR1D, QS1D, & - T_TEND1D,QV_TEND1D, T1D, QV1D, P1D, W1D, WVAR1D, & - EFFC1D, EFFI1D, EFFS1D, EFFR1D,DZ1D, & - ! HM ADD GRAUPEL - QG_TEND1D, NG_TEND1D, QG1D, NG1D, EFFG1D, & - -! ADD SEDIMENTATION TENDENCIES (UNITS OF KG/KG/S) - QGSTEN,QRSTEN, QISTEN, QNISTEN, QCSTEN, & -! ADD CUMULUS TENDENCIES - QRCU1D, QSCU1D, QICU1D - -! add cumulus tendencies - - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN):: & - qrcuten, qscuten, qicuten - REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN):: & - mu - -! HM add reflectivity -! dbz - - REAL PRECPRT1D, SNOWRT1D - - INTEGER I,K,J - - REAL DT - -! LOGICAL:: dBZ_tstep ! GT - - ! Initialize tendencies (all set to 0) and transfer - ! array to local variables - DT = DT_IN - - DO I=ITS,ITE - DO J=JTS,JTE - DO K=KTS,KTE - T(I,K,J) = TH(i,k,j)*PII(i,k,j) - -! wvar is the ST. DEV. OF sub-grid vertical velocity, used for calculating droplet -! activation rates. -! WVAR CAN BE DERIVED EITHER FROM PREDICTED TKE (AS IN MYJ PBL SCHEME), -! OR FROM EDDY DIFFUSION COEFFICIENT KZH (AS IN YSU PBL SCHEME), -! DEPENDING ON THE PARTICULAR pbl SCHEME DRIVER MODEL IS COUPLED WITH -! NOTE: IF MODEL HAS HIGH ENOUGH RESOLUTION TO RESOLVE UPDRAFTS, WVAR MAY -! NOT BE NEEDED - -! currently assign wvar to 0.5 m/s (not coupled with PBL scheme) - - WVAR(I,K,J) = 0.5 - -! currently mixing of number concentrations also is neglected (not coupled with PBL schemes) - - END DO - END DO - END DO - - do i=its,ite ! i loop (east-west) - do j=jts,jte ! j loop (north-south) - ! - ! Transfer 3D arrays into 1D for microphysical calculations - ! - -! hm , initialize 1d tendency arrays to zero - - do k=kts,kte ! k loop (vertical) - - QC_TEND1D(k) = 0. - QI_TEND1D(k) = 0. - QNI_TEND1D(k) = 0. - QR_TEND1D(k) = 0. - NI_TEND1D(k) = 0. - NS_TEND1D(k) = 0. - NR_TEND1D(k) = 0. - T_TEND1D(k) = 0. - QV_TEND1D(k) = 0. - - QC1D(k) = QC(i,k,j) - QI1D(k) = QI(i,k,j) - QS1D(k) = QS(i,k,j) - QR1D(k) = QR(i,k,j) - - NI1D(k) = NI(i,k,j) - - NS1D(k) = NS(i,k,j) - NR1D(k) = NR(i,k,j) -! HM ADD GRAUPEL - QG1D(K) = QG(I,K,j) - NG1D(K) = NG(I,K,j) - QG_TEND1D(K) = 0. - NG_TEND1D(K) = 0. - - T1D(k) = T(i,k,j) - QV1D(k) = QV(i,k,j) - P1D(k) = P(i,k,j) - DZ1D(k) = DZ(i,k,j) - W1D(k) = W(i,k,j) - WVAR1D(k) = WVAR(i,k,j) -! add cumulus tendencies, decouple from mu - qrcu1d(k) = qrcuten(i,k,j)/mu(i,j) - qscu1d(k) = qscuten(i,k,j)/mu(i,j) - qicu1d(k) = qicuten(i,k,j)/mu(i,j) - end do - - call MORR_TWO_MOMENT_MICRO(QC_TEND1D, QI_TEND1D, QNI_TEND1D, QR_TEND1D, & - NI_TEND1D, NS_TEND1D, NR_TEND1D, & - QC1D, QI1D, QS1D, QR1D,NI1D, NS1D, NR1D, & - T_TEND1D,QV_TEND1D, T1D, QV1D, P1D, DZ1D, W1D, WVAR1D, & - PRECPRT1D,SNOWRT1D, & - EFFC1D,EFFI1D,EFFS1D,EFFR1D,DT, & - IMS,IME, JMS,JME, KMS,KME, & - ITS,ITE, JTS,JTE, KTS,KTE, & ! HM ADD GRAUPEL - QG_TEND1D,NG_TEND1D,QG1D,NG1D,EFFG1D, & - qrcu1d, qscu1d, qicu1d, & -! ADD SEDIMENTATION TENDENCIES - QGSTEN,QRSTEN,QISTEN,QNISTEN,QCSTEN) - - ! - ! Transfer 1D arrays back into 3D arrays - ! - do k=kts,kte - -! hm, add tendencies to update global variables -! HM, TENDENCIES FOR Q AND N NOW ADDED IN M2005MICRO, SO WE -! ONLY NEED TO TRANSFER 1D VARIABLES BACK TO 3D - - QC(i,k,j) = QC1D(k) - QI(i,k,j) = QI1D(k) - QS(i,k,j) = QS1D(k) - QR(i,k,j) = QR1D(k) - NI(i,k,j) = NI1D(k) - NS(i,k,j) = NS1D(k) - NR(i,k,j) = NR1D(k) - QG(I,K,j) = QG1D(K) - NG(I,K,j) = NG1D(K) - - T(i,k,j) = T1D(k) - TH(I,K,J) = T(i,k,j)/PII(i,k,j) ! CONVERT TEMP BACK TO POTENTIAL TEMP - QV(i,k,j) = QV1D(k) - - EFFC(i,k,j) = EFFC1D(k) - EFFI(i,k,j) = EFFI1D(k) - EFFS(i,k,j) = EFFS1D(k) - EFFR(i,k,j) = EFFR1D(k) - EFFG(I,K,j) = EFFG1D(K) - -! EFFECTIVE RADIUS FOR RADIATION CODE (currently not coupled) -! HM, ADD LIMIT TO PREVENT BLOWING UP OPTICAL PROPERTIES, 8/18/07 -! EFFCS(I,K,J) = MIN(EFFC(I,K,J),50.) -! EFFCS(I,K,J) = MAX(EFFCS(I,K,J),1.) -! EFFIS(I,K,J) = MIN(EFFI(I,K,J),130.) -! EFFIS(I,K,J) = MAX(EFFIS(I,K,J),13.) - - end do - -! hm modified so that m2005 precip variables correctly match wrf precip variables - RAINNC(i,j) = RAINNC(I,J)+PRECPRT1D - RAINNCV(i,j) = PRECPRT1D - SR(i,j) = SNOWRT1D/(PRECPRT1D+1.E-12) - - end do - end do - -END SUBROUTINE MP_MORR_TWO_MOMENT - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - SUBROUTINE MORR_TWO_MOMENT_MICRO(QC3DTEN,QI3DTEN,QNI3DTEN,QR3DTEN, & - NI3DTEN,NS3DTEN,NR3DTEN,QC3D,QI3D,QNI3D,QR3D,NI3D,NS3D,NR3D, & - T3DTEN,QV3DTEN,T3D,QV3D,PRES,DZQ,W3D,WVAR,PRECRT,SNOWRT, & - EFFC,EFFI,EFFS,EFFR,DT, & - IMS,IME, JMS,JME, KMS,KME, & - ITS,ITE, JTS,JTE, KTS,KTE, & ! ADD GRAUPEL - QG3DTEN,NG3DTEN,QG3D,NG3D,EFFG,qrcu1d,qscu1d, qicu1d, & - QGSTEN,QRSTEN,QISTEN,QNISTEN,QCSTEN) - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! THIS PROGRAM IS THE MAIN TWO-MOMENT MICROPHYSICS SUBROUTINE DESCRIBED BY -! MORRISON ET AL. 2005 JAS; MORRISON AND PINTO 2005 JAS. -! ADDITIONAL CHANGES ARE DESCRIBED IN DETAIL BY MORRISON, THOMPSON, TATARSKII (MWR, SUBMITTED) - -! THIS SCHEME IS A BULK DOUBLE-MOMENT SCHEME THAT PREDICTS MIXING -! RATIOS AND NUMBER CONCENTRATIONS OF FIVE HYDROMETEOR SPECIES: -! CLOUD DROPLETS, CLOUD (SMALL) ICE, RAIN, SNOW, AND GRAUPEL. - -! CODE STRUCTURE: MAIN SUBROUTINE IS 'MORR_TWO_MOMENT'. ALSO INCLUDED IN THIS FILE IS -! 'FUNCTION POLYSVP', 'FUNCTION DERF1', AND -! 'FUNCTION GAMMA'. - -! NOTE: THIS SUBROUTINE USES 1D ARRAY IN VERTICAL (COLUMN), EVEN THOUGH VARIABLES ARE CALLED '3D'...... - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - -! DECLARATIONS - - IMPLICIT NONE - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! THESE VARIABLES BELOW MUST BE LINKED WITH THE MAIN MODEL. -! DEFINE ARRAY SIZES - -! INPUT NUMBER OF GRID CELLS - -! INPUT/OUTPUT PARAMETERS ! DESCRIPTION (UNITS) - INTEGER, INTENT( IN) :: IMS,IME, JMS,JME, KMS,KME, & - ITS,ITE, JTS,JTE, KTS,KTE - - REAL, DIMENSION(KTS:KTE) :: QC3DTEN ! CLOUD WATER MIXING RATIO TENDENCY (KG/KG/S) - REAL, DIMENSION(KTS:KTE) :: QI3DTEN ! CLOUD ICE MIXING RATIO TENDENCY (KG/KG/S) - REAL, DIMENSION(KTS:KTE) :: QNI3DTEN ! SNOW MIXING RATIO TENDENCY (KG/KG/S) - REAL, DIMENSION(KTS:KTE) :: QR3DTEN ! RAIN MIXING RATIO TENDENCY (KG/KG/S) - REAL, DIMENSION(KTS:KTE) :: NI3DTEN ! CLOUD ICE NUMBER CONCENTRATION (1/KG/S) - REAL, DIMENSION(KTS:KTE) :: NS3DTEN ! SNOW NUMBER CONCENTRATION (1/KG/S) - REAL, DIMENSION(KTS:KTE) :: NR3DTEN ! RAIN NUMBER CONCENTRATION (1/KG/S) - REAL, DIMENSION(KTS:KTE) :: QC3D ! CLOUD WATER MIXING RATIO (KG/KG) - REAL, DIMENSION(KTS:KTE) :: QI3D ! CLOUD ICE MIXING RATIO (KG/KG) - REAL, DIMENSION(KTS:KTE) :: QNI3D ! SNOW MIXING RATIO (KG/KG) - REAL, DIMENSION(KTS:KTE) :: QR3D ! RAIN MIXING RATIO (KG/KG) - REAL, DIMENSION(KTS:KTE) :: NI3D ! CLOUD ICE NUMBER CONCENTRATION (1/KG) - REAL, DIMENSION(KTS:KTE) :: NS3D ! SNOW NUMBER CONCENTRATION (1/KG) - REAL, DIMENSION(KTS:KTE) :: NR3D ! RAIN NUMBER CONCENTRATION (1/KG) - REAL, DIMENSION(KTS:KTE) :: T3DTEN ! TEMPERATURE TENDENCY (K/S) - REAL, DIMENSION(KTS:KTE) :: QV3DTEN ! WATER VAPOR MIXING RATIO TENDENCY (KG/KG/S) - REAL, DIMENSION(KTS:KTE) :: T3D ! TEMPERATURE (K) - REAL, DIMENSION(KTS:KTE) :: QV3D ! WATER VAPOR MIXING RATIO (KG/KG) - REAL, DIMENSION(KTS:KTE) :: PRES ! ATMOSPHERIC PRESSURE (PA) - REAL, DIMENSION(KTS:KTE) :: DZQ ! DIFFERENCE IN HEIGHT ACROSS LEVEL (m) - REAL, DIMENSION(KTS:KTE) :: W3D ! GRID-SCALE VERTICAL VELOCITY (M/S) - REAL, DIMENSION(KTS:KTE) :: WVAR ! SUB-GRID VERTICAL VELOCITY (M/S) - -! HM ADDED GRAUPEL VARIABLES - REAL, DIMENSION(KTS:KTE) :: QG3DTEN ! GRAUPEL MIX RATIO TENDENCY (KG/KG/S) - REAL, DIMENSION(KTS:KTE) :: NG3DTEN ! GRAUPEL NUMB CONC TENDENCY (1/KG/S) - REAL, DIMENSION(KTS:KTE) :: QG3D ! GRAUPEL MIX RATIO (KG/KG) - REAL, DIMENSION(KTS:KTE) :: NG3D ! GRAUPEL NUMBER CONC (1/KG) - -! HM, ADD 1/16/07, SEDIMENTATION TENDENCIES FOR MIXING RATIO - - REAL, DIMENSION(KTS:KTE) :: QGSTEN ! GRAUPEL SED TEND (KG/KG/S) - REAL, DIMENSION(KTS:KTE) :: QRSTEN ! RAIN SED TEND (KG/KG/S) - REAL, DIMENSION(KTS:KTE) :: QISTEN ! CLOUD ICE SED TEND (KG/KG/S) - REAL, DIMENSION(KTS:KTE) :: QNISTEN ! SNOW SED TEND (KG/KG/S) - REAL, DIMENSION(KTS:KTE) :: QCSTEN ! CLOUD WAT SED TEND (KG/KG/S) - -! hm add cumulus tendencies for precip - REAL, DIMENSION(KTS:KTE) :: qrcu1d - REAL, DIMENSION(KTS:KTE) :: qscu1d - REAL, DIMENSION(KTS:KTE) :: qicu1d - -! OUTPUT VARIABLES - - REAL PRECRT ! TOTAL PRECIP PER TIME STEP (mm) - REAL SNOWRT ! SNOW PER TIME STEP (mm) - - REAL, DIMENSION(KTS:KTE) :: EFFC ! DROPLET EFFECTIVE RADIUS (MICRON) - REAL, DIMENSION(KTS:KTE) :: EFFI ! CLOUD ICE EFFECTIVE RADIUS (MICRON) - REAL, DIMENSION(KTS:KTE) :: EFFS ! SNOW EFFECTIVE RADIUS (MICRON) - REAL, DIMENSION(KTS:KTE) :: EFFR ! RAIN EFFECTIVE RADIUS (MICRON) - REAL, DIMENSION(KTS:KTE) :: EFFG ! GRAUPEL EFFECTIVE RADIUS (MICRON) - -! MODEL INPUT PARAMETERS (FORMERLY IN COMMON BLOCKS) - - REAL DT ! MODEL TIME STEP (SEC) - -!..................................................................................................... -! LOCAL VARIABLES: ALL PARAMETERS BELOW ARE LOCAL TO SCHEME AND DON'T NEED TO COMMUNICATE WITH THE -! REST OF THE MODEL. - -! SIZE PARAMETER VARIABLES - - REAL, DIMENSION(KTS:KTE) :: LAMC ! SLOPE PARAMETER FOR DROPLETS (M-1) - REAL, DIMENSION(KTS:KTE) :: LAMI ! SLOPE PARAMETER FOR CLOUD ICE (M-1) - REAL, DIMENSION(KTS:KTE) :: LAMS ! SLOPE PARAMETER FOR SNOW (M-1) - REAL, DIMENSION(KTS:KTE) :: LAMR ! SLOPE PARAMETER FOR RAIN (M-1) - REAL, DIMENSION(KTS:KTE) :: LAMG ! SLOPE PARAMETER FOR GRAUPEL (M-1) - REAL, DIMENSION(KTS:KTE) :: CDIST1 ! PSD PARAMETER FOR DROPLETS - REAL, DIMENSION(KTS:KTE) :: N0I ! INTERCEPT PARAMETER FOR CLOUD ICE (KG-1 M-1) - REAL, DIMENSION(KTS:KTE) :: N0S ! INTERCEPT PARAMETER FOR SNOW (KG-1 M-1) - REAL, DIMENSION(KTS:KTE) :: N0RR ! INTERCEPT PARAMETER FOR RAIN (KG-1 M-1) - REAL, DIMENSION(KTS:KTE) :: N0G ! INTERCEPT PARAMETER FOR GRAUPEL (KG-1 M-1) - REAL, DIMENSION(KTS:KTE) :: PGAM ! SPECTRAL SHAPE PARAMETER FOR DROPLETS - -! MICROPHYSICAL PROCESSES - - REAL, DIMENSION(KTS:KTE) :: NSUBC ! LOSS OF NC DURING EVAP - REAL, DIMENSION(KTS:KTE) :: NSUBI ! LOSS OF NI DURING SUB. - REAL, DIMENSION(KTS:KTE) :: NSUBS ! LOSS OF NS DURING SUB. - REAL, DIMENSION(KTS:KTE) :: NSUBR ! LOSS OF NR DURING EVAP - REAL, DIMENSION(KTS:KTE) :: PRD ! DEP CLOUD ICE - REAL, DIMENSION(KTS:KTE) :: PRE ! EVAP OF RAIN - REAL, DIMENSION(KTS:KTE) :: PRDS ! DEP SNOW - REAL, DIMENSION(KTS:KTE) :: NNUCCC ! CHANGE N DUE TO CONTACT FREEZ DROPLETS - REAL, DIMENSION(KTS:KTE) :: MNUCCC ! CHANGE Q DUE TO CONTACT FREEZ DROPLETS - REAL, DIMENSION(KTS:KTE) :: PRA ! ACCRETION DROPLETS BY RAIN - REAL, DIMENSION(KTS:KTE) :: PRC ! AUTOCONVERSION DROPLETS - REAL, DIMENSION(KTS:KTE) :: PCC ! COND/EVAP DROPLETS - REAL, DIMENSION(KTS:KTE) :: NNUCCD ! CHANGE N FREEZING AEROSOL (PRIM ICE NUCLEATION) - REAL, DIMENSION(KTS:KTE) :: MNUCCD ! CHANGE Q FREEZING AEROSOL (PRIM ICE NUCLEATION) - REAL, DIMENSION(KTS:KTE) :: MNUCCR ! CHANGE Q DUE TO CONTACT FREEZ RAIN - REAL, DIMENSION(KTS:KTE) :: NNUCCR ! CHANGE N DUE TO CONTACT FREEZ RAIN - REAL, DIMENSION(KTS:KTE) :: NPRA ! CHANGE IN N DUE TO DROPLET ACC BY RAIN - REAL, DIMENSION(KTS:KTE) :: NRAGG ! SELF-COLLECTION OF RAIN - REAL, DIMENSION(KTS:KTE) :: NSAGG ! SELF-COLLECTION OF SNOW - REAL, DIMENSION(KTS:KTE) :: NPRC ! CHANGE NC AUTOCONVERSION DROPLETS - REAL, DIMENSION(KTS:KTE) :: NPRC1 ! CHANGE NR AUTOCONVERSION DROPLETS - REAL, DIMENSION(KTS:KTE) :: PRAI ! CHANGE Q AUTOCONVERSION CLOUD ICE - REAL, DIMENSION(KTS:KTE) :: PRCI ! CHANGE Q ACCRETION CLOUD ICE BY SNOW - REAL, DIMENSION(KTS:KTE) :: PSACWS ! CHANGE Q DROPLET ACCRETION BY SNOW - REAL, DIMENSION(KTS:KTE) :: NPSACWS ! CHANGE N DROPLET ACCRETION BY SNOW - REAL, DIMENSION(KTS:KTE) :: PSACWI ! CHANGE Q DROPLET ACCRETION BY CLOUD ICE - REAL, DIMENSION(KTS:KTE) :: NPSACWI ! CHANGE N DROPLET ACCRETION BY CLOUD ICE - REAL, DIMENSION(KTS:KTE) :: NPRCI ! CHANGE N AUTOCONVERSION CLOUD ICE BY SNOW - REAL, DIMENSION(KTS:KTE) :: NPRAI ! CHANGE N ACCRETION CLOUD ICE - REAL, DIMENSION(KTS:KTE) :: NMULTS ! ICE MULT DUE TO RIMING DROPLETS BY SNOW - REAL, DIMENSION(KTS:KTE) :: NMULTR ! ICE MULT DUE TO RIMING RAIN BY SNOW - REAL, DIMENSION(KTS:KTE) :: QMULTS ! CHANGE Q DUE TO ICE MULT DROPLETS/SNOW - REAL, DIMENSION(KTS:KTE) :: QMULTR ! CHANGE Q DUE TO ICE RAIN/SNOW - REAL, DIMENSION(KTS:KTE) :: PRACS ! CHANGE Q RAIN-SNOW COLLECTION - REAL, DIMENSION(KTS:KTE) :: NPRACS ! CHANGE N RAIN-SNOW COLLECTION - REAL, DIMENSION(KTS:KTE) :: PCCN ! CHANGE Q DROPLET ACTIVATION - REAL, DIMENSION(KTS:KTE) :: PSMLT ! CHANGE Q MELTING SNOW TO RAIN - REAL, DIMENSION(KTS:KTE) :: EVPMS ! CHNAGE Q MELTING SNOW EVAPORATING - REAL, DIMENSION(KTS:KTE) :: NSMLTS ! CHANGE N MELTING SNOW - REAL, DIMENSION(KTS:KTE) :: NSMLTR ! CHANGE N MELTING SNOW TO RAIN -! HM ADDED 12/13/06 - REAL, DIMENSION(KTS:KTE) :: PIACR ! CHANGE QR, ICE-RAIN COLLECTION - REAL, DIMENSION(KTS:KTE) :: NIACR ! CHANGE N, ICE-RAIN COLLECTION - REAL, DIMENSION(KTS:KTE) :: PRACI ! CHANGE QI, ICE-RAIN COLLECTION - REAL, DIMENSION(KTS:KTE) :: PIACRS ! CHANGE QR, ICE RAIN COLLISION, ADDED TO SNOW - REAL, DIMENSION(KTS:KTE) :: NIACRS ! CHANGE N, ICE RAIN COLLISION, ADDED TO SNOW - REAL, DIMENSION(KTS:KTE) :: PRACIS ! CHANGE QI, ICE RAIN COLLISION, ADDED TO SNOW - REAL, DIMENSION(KTS:KTE) :: EPRD ! SUBLIMATION CLOUD ICE - REAL, DIMENSION(KTS:KTE) :: EPRDS ! SUBLIMATION SNOW -! HM ADDED GRAUPEL PROCESSES - REAL, DIMENSION(KTS:KTE) :: PRACG ! CHANGE IN Q COLLECTION RAIN BY GRAUPEL - REAL, DIMENSION(KTS:KTE) :: PSACWG ! CHANGE IN Q COLLECTION DROPLETS BY GRAUPEL - REAL, DIMENSION(KTS:KTE) :: PGSACW ! CONVERSION Q TO GRAUPEL DUE TO COLLECTION DROPLETS BY SNOW - REAL, DIMENSION(KTS:KTE) :: PGRACS ! CONVERSION Q TO GRAUPEL DUE TO COLLECTION RAIN BY SNOW - REAL, DIMENSION(KTS:KTE) :: PRDG ! DEP OF GRAUPEL - REAL, DIMENSION(KTS:KTE) :: EPRDG ! SUB OF GRAUPEL - REAL, DIMENSION(KTS:KTE) :: EVPMG ! CHANGE Q MELTING OF GRAUPEL AND EVAPORATION - REAL, DIMENSION(KTS:KTE) :: PGMLT ! CHANGE Q MELTING OF GRAUPEL - REAL, DIMENSION(KTS:KTE) :: NPRACG ! CHANGE N COLLECTION RAIN BY GRAUPEL - REAL, DIMENSION(KTS:KTE) :: NPSACWG ! CHANGE N COLLECTION DROPLETS BY GRAUPEL - REAL, DIMENSION(KTS:KTE) :: NSCNG ! CHANGE N CONVERSION TO GRAUPEL DUE TO COLLECTION DROPLETS BY SNOW - REAL, DIMENSION(KTS:KTE) :: NGRACS ! CHANGE N CONVERSION TO GRAUPEL DUE TO COLLECTION RAIN BY SNOW - REAL, DIMENSION(KTS:KTE) :: NGMLTG ! CHANGE N MELTING GRAUPEL - REAL, DIMENSION(KTS:KTE) :: NGMLTR ! CHANGE N MELTING GRAUPEL TO RAIN - REAL, DIMENSION(KTS:KTE) :: NSUBG ! CHANGE N SUB/DEP OF GRAUPEL - REAL, DIMENSION(KTS:KTE) :: PSACR ! CONVERSION DUE TO COLL OF SNOW BY RAIN - REAL, DIMENSION(KTS:KTE) :: NMULTG ! ICE MULT DUE TO ACC DROPLETS BY GRAUPEL - REAL, DIMENSION(KTS:KTE) :: NMULTRG ! ICE MULT DUE TO ACC RAIN BY GRAUPEL - REAL, DIMENSION(KTS:KTE) :: QMULTG ! CHANGE Q DUE TO ICE MULT DROPLETS/GRAUPEL - REAL, DIMENSION(KTS:KTE) :: QMULTRG ! CHANGE Q DUE TO ICE MULT RAIN/GRAUPEL - -! TIME-VARYING ATMOSPHERIC PARAMETERS - - REAL, DIMENSION(KTS:KTE) :: KAP ! THERMAL CONDUCTIVITY OF AIR - REAL, DIMENSION(KTS:KTE) :: EVS ! SATURATION VAPOR PRESSURE - REAL, DIMENSION(KTS:KTE) :: EIS ! ICE SATURATION VAPOR PRESSURE - REAL, DIMENSION(KTS:KTE) :: QVS ! SATURATION MIXING RATIO - REAL, DIMENSION(KTS:KTE) :: QVI ! ICE SATURATION MIXING RATIO - REAL, DIMENSION(KTS:KTE) :: QVQVS ! SAUTRATION RATIO - REAL, DIMENSION(KTS:KTE) :: QVQVSI! ICE SATURAION RATIO - REAL, DIMENSION(KTS:KTE) :: DV ! DIFFUSIVITY OF WATER VAPOR IN AIR - REAL, DIMENSION(KTS:KTE) :: XXLS ! LATENT HEAT OF SUBLIMATION - REAL, DIMENSION(KTS:KTE) :: XXLV ! LATENT HEAT OF VAPORIZATION - REAL, DIMENSION(KTS:KTE) :: CPM ! SPECIFIC HEAT AT CONST PRESSURE FOR MOIST AIR - REAL, DIMENSION(KTS:KTE) :: MU ! VISCOCITY OF AIR - REAL, DIMENSION(KTS:KTE) :: SC ! SCHMIDT NUMBER - REAL, DIMENSION(KTS:KTE) :: XLF ! LATENT HEAT OF FREEZING - REAL, DIMENSION(KTS:KTE) :: RHO ! AIR DENSITY - REAL, DIMENSION(KTS:KTE) :: AB ! CORRECTION TO CONDENSATION RATE DUE TO LATENT HEATING - REAL, DIMENSION(KTS:KTE) :: ABI ! CORRECTION TO DEPOSITION RATE DUE TO LATENT HEATING - -! TIME-VARYING MICROPHYSICS PARAMETERS - - REAL, DIMENSION(KTS:KTE) :: DAP ! DIFFUSIVITY OF AEROSOL - REAL NACNT ! NUMBER OF CONTACT IN - REAL FMULT ! TEMP.-DEP. PARAMETER FOR RIME-SPLINTERING - REAL COFFI ! ICE AUTOCONVERSION PARAMETER - -! FALL SPEED WORKING VARIABLES (DEFINED IN CODE) - - REAL, DIMENSION(KTS:KTE) :: DUMI,DUMR,DUMFNI,DUMG,DUMFNG - REAL UNI, UMI,UMR - REAL, DIMENSION(KTS:KTE) :: FR, FI, FNI,FG,FNG - REAL RGVM - REAL, DIMENSION(KTS:KTE) :: FALOUTR,FALOUTI,FALOUTNI - REAL FALTNDR,FALTNDI,FALTNDNI,RHO2 - REAL, DIMENSION(KTS:KTE) :: DUMQS,DUMFNS - REAL UMS,UNS - REAL, DIMENSION(KTS:KTE) :: FS,FNS, FALOUTS,FALOUTNS,FALOUTG,FALOUTNG - REAL FALTNDS,FALTNDNS,UNR,FALTNDG,FALTNDNG - REAL, DIMENSION(KTS:KTE) :: DUMC,DUMFNC - REAL UNC,UMC,UNG,UMG - REAL, DIMENSION(KTS:KTE) :: FC,FALOUTC,FALOUTNC - REAL FALTNDC,FALTNDNC - REAL, DIMENSION(KTS:KTE) :: FNC,DUMFNR,FALOUTNR - REAL FALTNDNR - REAL, DIMENSION(KTS:KTE) :: FNR - -! FALL-SPEED PARAMETER 'A' WITH AIR DENSITY CORRECTION - - REAL, DIMENSION(KTS:KTE) :: AIN,ARN,ASN,ACN,AGN - -! EXTERNAL FUNCTION CALL RETURN VARIABLES - -! REAL GAMMA, ! EULER GAMMA FUNCTION -! REAL POLYSVP, ! SAT. PRESSURE FUNCTION -! REAL DERF1 ! ERROR FUNCTION - -! DUMMY VARIABLES - - REAL DUM,DUM1,DUM2,DUMT,DUMQV,DUMQSS,DUMQSI,DUMS - -! PROGNOSTIC SUPERSATURATION - - REAL DQSDT ! CHANGE OF SAT. MIX. RAT. WITH TEMPERATURE - REAL DQSIDT ! CHANGE IN ICE SAT. MIXING RAT. WITH T - REAL EPSI ! 1/PHASE REL. TIME (SEE M2005), ICE - REAL EPSS ! 1/PHASE REL. TIME (SEE M2005), SNOW - REAL EPSR ! 1/PHASE REL. TIME (SEE M2005), RAIN - REAL EPSG ! 1/PHASE REL. TIME (SEE M2005), GRAUPEL - -! NEW DROPLET ACTIVATION VARIABLES - REAL TAUC ! PHASE REL. TIME (SEE M2005), DROPLETS - REAL TAUR ! PHASE REL. TIME (SEE M2005), RAIN - REAL TAUI ! PHASE REL. TIME (SEE M2005), CLOUD ICE - REAL TAUS ! PHASE REL. TIME (SEE M2005), SNOW - REAL TAUG ! PHASE REL. TIME (SEE M2005), GRAUPEL - REAL DUMACT,DUM3 - -! COUNTING/INDEX VARIABLES - - INTEGER K,NSTEP,N ! ,I - -! LTRUE IS ONLY USED TO SPEED UP THE CODE !! -! LTRUE, SWITCH = 0, NO HYDROMETEORS IN COLUMN, -! = 1, HYDROMETEORS IN COLUMN - - INTEGER LTRUE - -! DROPLET ACTIVATION/FREEZING AEROSOL - - - REAL CT ! DROPLET ACTIVATION PARAMETER - REAL TEMP1 ! DUMMY TEMPERATURE - REAL SAT1 ! DUMMY SATURATION - REAL SIGVL ! SURFACE TENSION LIQ/VAPOR - REAL KEL ! KELVIN PARAMETER - REAL KC2 ! TOTAL ICE NUCLEATION RATE - - REAL CRY,KRY ! AEROSOL ACTIVATION PARAMETERS - -! MORE WORKING/DUMMY VARIABLES - - REAL DUMQI,DUMNI,DC0,DS0,DG0 - REAL DUMQC,DUMQR,RATIO,SUM_DEP,FUDGEF - -! EFFECTIVE VERTICAL VELOCITY (M/S) - REAL WEF - -! WORKING PARAMETERS FOR ICE NUCLEATION - - REAL ANUC,BNUC - -! WORKING PARAMETERS FOR AEROSOL ACTIVATION - - REAL AACT,GAMM,GG,PSI,ETA1,ETA2,SM1,SM2,SMAX,UU1,UU2,ALPHA - -! DUMMY SIZE DISTRIBUTION PARAMETERS - - REAL DLAMS,DLAMR,DLAMI,DLAMC,DLAMG,LAMMAX,LAMMIN - - INTEGER IDROP - -! DROPLET CONCENTRATION AND ITS TENDENCY -! NOTE: CURRENTLY DROPLET CONCENTRATION IS SPECIFIED !!!!! -! TENDENCY OF NC IS CALCULATED BUT IT IS NOT USED !!! - REAL, DIMENSION(KTS:KTE) :: NC3DTEN ! CLOUD DROPLET NUMBER CONCENTRATION (1/KG/S) - REAL, DIMENSION(KTS:KTE) :: NC3D ! CLOUD DROPLET NUMBER CONCENTRATION (1/KG) - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - -! SET LTRUE INITIALLY TO 0 - - LTRUE = 0 - -! ATMOSPHERIC PARAMETERS THAT VARY IN TIME AND HEIGHT - DO K = KTS,KTE - -! LATENT HEAT OF VAPORATION - - XXLV(K) = 3.1484E6-2370.*T3D(K) - -! LATENT HEAT OF SUBLIMATION - - XXLS(K) = 3.15E6-2370.*T3D(K)+0.3337E6 - - CPM(K) = CP*(1.+0.887*QV3D(K)) - -! SATURATION VAPOR PRESSURE AND MIXING RATIO - - EVS(K) = POLYSVP(T3D(K),0) ! PA - EIS(K) = POLYSVP(T3D(K),1) ! PA - -! MAKE SURE ICE SATURATION DOESN'T EXCEED WATER SAT. NEAR FREEZING - - IF (EIS(K).GT.EVS(K)) EIS(K) = EVS(K) - - QVS(K) = .622*EVS(K)/(PRES(K)-EVS(K)) - QVI(K) = .622*EIS(K)/(PRES(K)-EIS(K)) - - QVQVS(K) = QV3D(K)/QVS(K) - QVQVSI(K) = QV3D(K)/QVI(K) - -! AIR DENSITY - - RHO(K) = PRES(K)/(R*T3D(K)) - -! ADD NUMBER CONCENTRATION DUE TO CUMULUS TENDENCY -! ASSUME N0 ASSOCIATED WITH CUMULUS PARAM RAIN IS 10^7 M^-4 -! ASSUME N0 ASSOCIATED WITH CUMULUS PARAM SNOW IS 2 X 10^7 M^-4 -! FOR DETRAINED CLOUD ICE, ASSUME MEAN VOLUME DIAM OF 80 MICRON - - IF (QRCU1D(K).GE.1.E-10) THEN - DUM=1.8e5*(QRCU1D(K)*DT/(PI*RHOW*RHO(K)**3))**0.25 - NR3D(K)=NR3D(K)+DUM - END IF - IF (QSCU1D(K).GE.1.E-10) THEN - DUM=3.e5*(QSCU1D(K)*DT/(CONS1*RHO(K)**3))**(1./(DS+1.)) - NS3D(K)=NS3D(K)+DUM - END IF - IF (QICU1D(K).GE.1.E-10) THEN - DUM=QICU1D(K)*DT/(CI*(80.E-6)**DI) - NI3D(K)=NI3D(K)+DUM - END IF - -! AT SUBSATURATION, REMOVE SMALL AMOUNTS OF CLOUD/PRECIP WATER - - IF (QVQVS(K).LT.0.9) THEN - IF (QR3D(K).LT.1.E-6) THEN - QV3D(K)=QV3D(K)+QR3D(K) - T3D(K)=T3D(K)-QR3D(K)*XXLV(K)/CPM(K) - QR3D(K)=0. - END IF - IF (QC3D(K).LT.1.E-6) THEN - QV3D(K)=QV3D(K)+QC3D(K) - T3D(K)=T3D(K)-QC3D(K)*XXLV(K)/CPM(K) - QC3D(K)=0. - END IF - END IF - - IF (QVQVSI(K).LT.0.9) THEN - IF (QI3D(K).LT.1.E-6) THEN - QV3D(K)=QV3D(K)+QI3D(K) - T3D(K)=T3D(K)-QI3D(K)*XXLS(K)/CPM(K) - QI3D(K)=0. - END IF - IF (QNI3D(K).LT.1.E-6) THEN - QV3D(K)=QV3D(K)+QNI3D(K) - T3D(K)=T3D(K)-QNI3D(K)*XXLS(K)/CPM(K) - QNI3D(K)=0. - END IF - IF (QG3D(K).LT.1.E-6) THEN - QV3D(K)=QV3D(K)+QG3D(K) - T3D(K)=T3D(K)-QG3D(K)*XXLS(K)/CPM(K) - QG3D(K)=0. - END IF - END IF - -! HEAT OF FUSION - - XLF(K) = XXLS(K)-XXLV(K) - -!.................................................................. -! IF MIXING RATIO < QSMALL SET MIXING RATIO AND NUMBER CONC TO ZERO - - IF (QC3D(K).LT.QSMALL) THEN - QC3D(K) = 0. - NC3D(K) = 0. - EFFC(K) = 0. - END IF - IF (QR3D(K).LT.QSMALL) THEN - QR3D(K) = 0. - NR3D(K) = 0. - EFFR(K) = 0. - END IF - IF (QI3D(K).LT.QSMALL) THEN - QI3D(K) = 0. - NI3D(K) = 0. - EFFI(K) = 0. - END IF - IF (QNI3D(K).LT.QSMALL) THEN - QNI3D(K) = 0. - NS3D(K) = 0. - EFFS(K) = 0. - END IF - IF (QG3D(K).LT.QSMALL) THEN - QG3D(K) = 0. - NG3D(K) = 0. - EFFG(K) = 0. - END IF - -! INITIALIZE SEDIMENTATION TENDENCIES FOR MIXING RATIO - - QRSTEN(K) = 0. - QISTEN(K) = 0. - QNISTEN(K) = 0. - QCSTEN(K) = 0. - QGSTEN(K) = 0. - -!.................................................................. -! MICROPHYSICS PARAMETERS VARYING IN TIME/HEIGHT - -! FALL SPEED WITH DENSITY CORRECTION (HEYMSFIELD AND BENSSEMER 2006) - - DUM = (RHOSU/RHO(K))**0.54 - - AIN(K) = DUM*AI - ARN(K) = DUM*AR - ASN(K) = DUM*AS - ACN(K) = DUM*AC -! HM ADD GRAUPEL 8/28/06 - AGN(K) = DUM*AG - -!.................................. -! IF THERE IS NO CLOUD/PRECIP WATER, AND IF SUBSATURATED, THEN SKIP MICROPHYSICS -! FOR THIS LEVEL - - IF (QC3D(K).LT.QSMALL.AND.QI3D(K).LT.QSMALL.AND.QNI3D(K).LT.QSMALL & - .AND.QR3D(K).LT.QSMALL.AND.QG3D(K).LT.QSMALL) THEN - IF (T3D(K).LT.273.15.AND.QVQVSI(K).LT.0.999) GOTO 200 - IF (T3D(K).GE.273.15.AND.QVQVS(K).LT.0.999) GOTO 200 - END IF - -! THERMAL CONDUCTIVITY FOR AIR - - DUM = 1.496E-6*T3D(K)**1.5/(T3D(K)+120.) - -! KAP(K) = 1.414E3*1.496E-6*T3D(K)**1.5/(T3D(K)+120.) - KAP(K) = 1.414E3*DUM - -! DIFFUSIVITY OF WATER VAPOR - - DV(K) = 8.794E-5*T3D(K)**1.81/PRES(K) - -! VISCOSITY OF AIR -! SCHMIT NUMBER - -! MU(K) = 1.496E-6*T3D(K)**1.5/(T3D(K)+120.)/RHO(K) - MU(K) = DUM/RHO(K) - SC(K) = MU(K)/DV(K) - -! PSYCHOMETIC CORRECTIONS - -! RATE OF CHANGE SAT. MIX. RATIO WITH TEMPERATURE - - DUM = (RV*T3D(K)**2) - - DQSDT = XXLV(K)*QVS(K)/DUM - DQSIDT = XXLS(K)*QVI(K)/DUM - - ABI(K) = 1.+DQSIDT*XXLS(K)/CPM(K) - AB(K) = 1.+DQSDT*XXLV(K)/CPM(K) - -! -!..................................................................... -!..................................................................... -! CASE FOR TEMPERATURE ABOVE FREEZING - - IF (T3D(K).GE.273.15) THEN - -!...................................................................... -!HM ADD, ALLOW FOR CONSTANT DROPLET NUMBER -! INUM = 0, PREDICT DROPLET NUMBER -! INUM = 1, SET CONSTANT DROPLET NUMBER - -! IF (INUM.EQ.1) THEN -! CONVERT NDCNST FROM CM-3 TO KG-1 - NC3D(K)=NDCNST*1.E6/RHO(K) -! END IF - -! GET SIZE DISTRIBUTION PARAMETERS - -! MELT VERY SMALL SNOW AND GRAUPEL MIXING RATIOS, ADD TO RAIN - IF (QNI3D(K).LT.1.E-6) THEN - QR3D(K)=QR3D(K)+QNI3D(K) - NR3D(K)=NR3D(K)+NS3D(K) - T3D(K)=T3D(K)-QNI3D(K)*XLF(K)/CPM(K) - QNI3D(K) = 0. - NS3D(K) = 0. - END IF - IF (QG3D(K).LT.1.E-6) THEN - QR3D(K)=QR3D(K)+QG3D(K) - NR3D(K)=NR3D(K)+NG3D(K) - T3D(K)=T3D(K)-QG3D(K)*XLF(K)/CPM(K) - QG3D(K) = 0. - NG3D(K) = 0. - END IF - - IF (QC3D(K).LT.QSMALL.AND.QNI3D(K).LT.1.E-8.AND.QR3D(K).LT.QSMALL.AND.QG3D(K).LT.1.E-8) GOTO 300 - -! MAKE SURE NUMBER CONCENTRATIONS AREN'T NEGATIVE - - NS3D(K) = MAX(0.,NS3D(K)) - NC3D(K) = MAX(0.,NC3D(K)) - NR3D(K) = MAX(0.,NR3D(K)) - NG3D(K) = MAX(0.,NG3D(K)) - -!...................................................................... -! RAIN - - IF (QR3D(K).GE.QSMALL) THEN - LAMR(K) = (PI*RHOW*NR3D(K)/QR3D(K))**(1./3.) - N0RR(K) = NR3D(K)*LAMR(K) - -! CHECK FOR SLOPE - -! ADJUST VARS - - IF (LAMR(K).LT.LAMMINR) THEN - - LAMR(K) = LAMMINR - - N0RR(K) = LAMR(K)**4*QR3D(K)/(PI*RHOW) - - NR3D(K) = N0RR(K)/LAMR(K) - ELSE IF (LAMR(K).GT.LAMMAXR) THEN - LAMR(K) = LAMMAXR - N0RR(K) = LAMR(K)**4*QR3D(K)/(PI*RHOW) - - NR3D(K) = N0RR(K)/LAMR(K) - END IF - END IF - -!...................................................................... -! CLOUD DROPLETS - -! MARTIN ET AL. (1994) FORMULA FOR PGAM - - IF (QC3D(K).GE.QSMALL) THEN - - DUM = PRES(K)/(287.15*T3D(K)) - PGAM(K)=0.0005714*(NC3D(K)/1.E6/DUM)+0.2714 - PGAM(K)=1./(PGAM(K)**2)-1. - PGAM(K)=MAX(PGAM(K),2.) - PGAM(K)=MIN(PGAM(K),10.) - -! CALCULATE LAMC - - LAMC(K) = (CONS26*NC3D(K)*GAMMA(PGAM(K)+4.)/ & - (QC3D(K)*GAMMA(PGAM(K)+1.)))**(1./3.) - -! LAMMIN, 60 MICRON DIAMETER -! LAMMAX, 1 MICRON - - LAMMIN = (PGAM(K)+1.)/60.E-6 - LAMMAX = (PGAM(K)+1.)/1.E-6 - - IF (LAMC(K).LT.LAMMIN) THEN - LAMC(K) = LAMMIN - - NC3D(K) = EXP(3.*LOG(LAMC(K))+LOG(QC3D(K))+ & - LOG(GAMMA(PGAM(K)+1.))-LOG(GAMMA(PGAM(K)+4.)))/CONS26 - ELSE IF (LAMC(K).GT.LAMMAX) THEN - LAMC(K) = LAMMAX - - NC3D(K) = EXP(3.*LOG(LAMC(K))+LOG(QC3D(K))+ & - LOG(GAMMA(PGAM(K)+1.))-LOG(GAMMA(PGAM(K)+4.)))/CONS26 - - END IF - - END IF - -!...................................................................... -! SNOW - - IF (QNI3D(K).GE.QSMALL) THEN - LAMS(K) = (CONS1*NS3D(K)/QNI3D(K))**(1./DS) - N0S(K) = NS3D(K)*LAMS(K) - -! CHECK FOR SLOPE - -! ADJUST VARS - - IF (LAMS(K).LT.LAMMINS) THEN - LAMS(K) = LAMMINS - N0S(K) = LAMS(K)**4*QNI3D(K)/CONS1 - - NS3D(K) = N0S(K)/LAMS(K) - - ELSE IF (LAMS(K).GT.LAMMAXS) THEN - - LAMS(K) = LAMMAXS - N0S(K) = LAMS(K)**4*QNI3D(K)/CONS1 - - NS3D(K) = N0S(K)/LAMS(K) - END IF - END IF - -!...................................................................... -! GRAUPEL - - IF (QG3D(K).GE.QSMALL) THEN - LAMG(K) = (CONS2*NG3D(K)/QG3D(K))**(1./DG) - N0G(K) = NG3D(K)*LAMG(K) - -! ADJUST VARS - - IF (LAMG(K).LT.LAMMING) THEN - LAMG(K) = LAMMING - N0G(K) = LAMG(K)**4*QG3D(K)/CONS2 - - NG3D(K) = N0G(K)/LAMG(K) - - ELSE IF (LAMG(K).GT.LAMMAXG) THEN - - LAMG(K) = LAMMAXG - N0G(K) = LAMG(K)**4*QG3D(K)/CONS2 - - NG3D(K) = N0G(K)/LAMG(K) - END IF - END IF - -!..................................................................... -! ZERO OUT PROCESS RATES - - PRC(K) = 0. - NPRC(K) = 0. - NPRC1(K) = 0. - PRA(K) = 0. - NPRA(K) = 0. - NRAGG(K) = 0. - PSMLT(K) = 0. - NSMLTS(K) = 0. - NSMLTR(K) = 0. - EVPMS(K) = 0. - PCC(K) = 0. - PRE(K) = 0. - NSUBC(K) = 0. - NSUBR(K) = 0. - PRACG(K) = 0. - NPRACG(K) = 0. - PSMLT(K) = 0. - EVPMS(K) = 0. - PGMLT(K) = 0. - EVPMG(K) = 0. - PRACS(K) = 0. - NPRACS(K) = 0. - NGMLTG(K) = 0. - NGMLTR(K) = 0. - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! CALCULATION OF MICROPHYSICAL PROCESS RATES, T > 273.15 K - -!................................................................. -!....................................................................... -! AUTOCONVERSION OF CLOUD LIQUID WATER TO RAIN -! FORMULA FROM BEHENG (1994) -! USING NUMERICAL SIMULATION OF STOCHASTIC COLLECTION EQUATION -! AND INITIAL CLOUD DROPLET SIZE DISTRIBUTION SPECIFIED -! AS A GAMMA DISTRIBUTION - -! USE MINIMUM VALUE OF 1.E-6 TO PREVENT FLOATING POINT ERROR - - IF (QC3D(K).GE.1.E-6) THEN - -! HM ADD 12/13/06, REPLACE WITH NEWER FORMULA -! FROM KHAIROUTDINOV AND KOGAN 2000, MWR - - PRC(K)=1350.*QC3D(K)**2.47* & - (NC3D(K)/1.e6*RHO(K))**(-1.79) - -! note: nprc1 is change in Nr, -! nprc is change in Nc - - NPRC1(K) = PRC(K)/CONS29 - NPRC(K) = PRC(K)/(QC3D(k)/NC3D(K)) - - NPRC(K) = MIN(NPRC(K),NC3D(K)/DT) - - END IF - -!....................................................................... -! HM ADD 12/13/06, COLLECTION OF SNOW BY RAIN ABOVE FREEZING -! FORMULA FROM IKAWA AND SAITO (1991) - - IF (QR3D(K).GE.1.E-8.AND.QNI3D(K).GE.1.E-8) THEN - - UMS = ASN(K)*CONS3/(LAMS(K)**BS) - UMR = ARN(K)*CONS4/(LAMR(K)**BR) - UNS = ASN(K)*CONS5/LAMS(K)**BS - UNR = ARN(K)*CONS6/LAMR(K)**BR - -! SET REASLISTIC LIMITS ON FALLSPEEDS - UMS=MIN(UMS,1.2) - UNS=MIN(UNS,1.2) - UMR=MIN(UMR,9.1) - UNR=MIN(UNR,9.1) - - PRACS(K) = CONS31*(((1.2*UMR-0.95*UMS)**2+ & - 0.08*UMS*UMR)**0.5*RHO(K)* & - N0RR(K)*N0S(K)/LAMS(K)**3* & - (5./(LAMS(K)**3*LAMR(K))+ & - 2./(LAMS(K)**2*LAMR(K)**2)+ & - 0.5/(LAMS(K)*LAMR(K)**3))) - - NPRACS(K) = CONS32*RHO(K)*(1.7*(UNR-UNS)**2+ & - 0.3*UNR*UNS)**0.5*N0RR(K)*N0S(K)* & - (1./(LAMR(K)**3*LAMS(K))+ & - 1./(LAMR(K)**2*LAMS(K)**2)+ & - 1./(LAMR(K)*LAMS(K)**3)) - - END IF - -! ADD COLLECTION OF GRAUPEL BY RAIN ABOVE FREEZING -! ASSUME ALL RAIN COLLECTION BY GRAUPEL ABOVE FREEZING IS SHED -! ASSUME SHED DROPS ARE 1 MM IN SIZE - - IF (QR3D(K).GE.1.E-8.AND.QG3D(K).GE.1.E-8) THEN - - UMG = AGN(K)*CONS7/(LAMG(K)**BG) - UMR = ARN(K)*CONS4/(LAMR(K)**BR) - UNG = AGN(K)*CONS8/LAMG(K)**BG - UNR = ARN(K)*CONS6/LAMR(K)**BR - -! SET REASLISTIC LIMITS ON FALLSPEEDS - UMG=MIN(UMG,20.) - UNG=MIN(UNG,20.) - UMR=MIN(UMR,9.1) - UNR=MIN(UNR,9.1) - -! DUM IS MIXING RATIO OF RAIN PER SEC COLLECTED BY GRAUPEL/HAIL - DUM = CONS41*(((1.2*UMR-0.95*UMG)**2+ & - 0.08*UMG*UMR)**0.5*RHO(K)* & - N0RR(K)*N0G(K)/LAMR(K)**3* & - (5./(LAMR(K)**3*LAMG(K))+ & - 2./(LAMR(K)**2*LAMG(K)**2)+ & - 0.5/(LAMR(k)*LAMG(k)**3))) - -! ASSUME 1 MM DROPS ARE SHED, GET NUMBER SHED PER SEC - - DUM = DUM/5.2E-7 - - NPRACG(K) = CONS32*RHO(K)*(1.7*(UNR-UNG)**2+ & - 0.3*UNR*UNG)**0.5*N0RR(K)*N0G(K)* & - (1./(LAMR(K)**3*LAMG(K))+ & - 1./(LAMR(K)**2*LAMG(K)**2)+ & - 1./(LAMR(K)*LAMG(K)**3)) - - NPRACG(K)=MAX(NPRACG(K)-DUM,0.) - - END IF - -!....................................................................... -! ACCRETION OF CLOUD LIQUID WATER BY RAIN -! CONTINUOUS COLLECTION EQUATION WITH -! GRAVITATIONAL COLLECTION KERNEL, DROPLET FALL SPEED NEGLECTED - - IF (QR3D(K).GE.1.E-8 .AND. QC3D(K).GE.1.E-8) THEN - -! 12/13/06 HM ADD, REPLACE WITH NEWER FORMULA FROM -! KHAIROUTDINOV AND KOGAN 2000, MWR - - DUM=(QC3D(K)*QR3D(K)) - PRA(K) = 67.*(DUM)**1.15 - NPRA(K) = PRA(K)/(QC3D(K)/NC3D(K)) - - END IF -!....................................................................... -! SELF-COLLECTION OF RAIN DROPS -! FROM BEHENG(1994) -! FROM NUMERICAL SIMULATION OF THE STOCHASTIC COLLECTION EQUATION -! AS DESCRINED ABOVE FOR AUTOCONVERSION - - IF (QR3D(K).GE.1.E-8) THEN - NRAGG(K) = -8.*NR3D(K)*QR3D(K)*RHO(K) - END IF - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! CALCULATE EVAP OF RAIN (RUTLEDGE AND HOBBS 1983) - - IF (QR3D(K).GE.QSMALL) THEN - EPSR = 2.*PI*N0RR(K)*RHO(K)*DV(K)* & - (F1R/(LAMR(K)*LAMR(K))+ & - F2R*(ARN(K)*RHO(K)/MU(K))**0.5* & - SC(K)**(1./3.)*CONS9/ & - (LAMR(K)**CONS34)) - ELSE - EPSR = 0. - END IF - -! NO CONDENSATION ONTO RAIN, ONLY EVAP ALLOWED - - IF (QV3D(K).LT.QVS(K)) THEN - PRE(K) = EPSR*(QV3D(K)-QVS(K))/AB(K) - PRE(K) = MIN(PRE(K),0.) - ELSE - PRE(K) = 0. - END IF - -!....................................................................... -! MELTING OF SNOW - -! SNOW MAY PERSITS ABOVE FREEZING, FORMULA FROM RUTLEDGE AND HOBBS, 1984 -! IF WATER SUPERSATURATION, SNOW MELTS TO FORM RAIN - - IF (QNI3D(K).GE.1.E-8) THEN - - PSMLT(K)=2.*PI*N0S(K)*KAP(K)*(273.15-T3D(K))/ & - XLF(K)*RHO(K)*(F1S/(LAMS(K)*LAMS(K))+ & - F2S*(ASN(K)*RHO(K)/MU(K))**0.5* & - SC(K)**(1./3.)*CONS10/ & - (LAMS(K)**CONS35)) - -! IN WATER SUBSATURATION, SNOW MELTS AND EVAPORATES - - IF (QVQVS(K).LT.1.) THEN - EPSS = 2.*PI*N0S(K)*RHO(K)*DV(K)* & - (F1S/(LAMS(K)*LAMS(K))+ & - F2S*(ASN(K)*RHO(K)/MU(K))**0.5* & - SC(K)**(1./3.)*CONS10/ & - (LAMS(K)**CONS35)) -! hm fix 8/4/08 - EVPMS(K) = (QV3D(K)-QVS(K))*EPSS/AB(K) - EVPMS(K) = MAX(EVPMS(K),PSMLT(K)) - PSMLT(K) = PSMLT(K)-EVPMS(K) - END IF - END IF - -!....................................................................... -! MELTING OF GRAUPEL - -! GRAUPEL MAY PERSITS ABOVE FREEZING, FORMULA FROM RUTLEDGE AND HOBBS, 1984 -! IF WATER SUPERSATURATION, GRAUPEL MELTS TO FORM RAIN - - IF (QG3D(K).GE.1.E-8) THEN - - PGMLT(K)=2.*PI*N0G(K)*KAP(K)*(273.15-T3D(K))/ & - XLF(K)*RHO(K)*(F1S/(LAMG(K)*LAMG(K))+ & - F2S*(AGN(K)*RHO(K)/MU(K))**0.5* & - SC(K)**(1./3.)*CONS11/ & - (LAMG(K)**CONS36)) - -! IN WATER SUBSATURATION, GRAUPEL MELTS AND EVAPORATES - - IF (QVQVS(K).LT.1.) THEN - EPSG = 2.*PI*N0G(K)*RHO(K)*DV(K)* & - (F1S/(LAMG(K)*LAMG(K))+ & - F2S*(AGN(K)*RHO(K)/MU(K))**0.5* & - SC(K)**(1./3.)*CONS11/ & - (LAMG(K)**CONS36)) -! hm fix 8/4/08 - EVPMG(K) = (QV3D(K)-QVS(K))*EPSG/AB(K) - EVPMG(K) = MAX(EVPMG(K),PGMLT(K)) - PGMLT(K) = PGMLT(K)-EVPMG(K) - END IF - END IF - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - -! FOR CLOUD ICE, ONLY PROCESSES OPERATING AT T > 273.15 IS -! MELTING, WHICH IS ALREADY CONSERVED DURING PROCESS -! CALCULATION - -! CONSERVATION OF QC - - DUM = (PRC(K)+PRA(K))*DT - - IF (DUM.GT.QC3D(K).AND.QC3D(K).GE.QSMALL) THEN - - RATIO = QC3D(K)/DUM - - PRC(K) = PRC(K)*RATIO - PRA(K) = PRA(K)*RATIO - - END IF - -! CONSERVATION OF SNOW - - DUM = (-PSMLT(K)-EVPMS(K)+PRACS(K))*DT - - IF (DUM.GT.QNI3D(K).AND.QNI3D(K).GE.QSMALL) THEN - -! NO SOURCE TERMS FOR SNOW AT T > FREEZING - RATIO = QNI3D(K)/DUM - - PSMLT(K) = PSMLT(K)*RATIO - EVPMS(K) = EVPMS(K)*RATIO - PRACS(K) = PRACS(K)*RATIO - - END IF - -! CONSERVATION OF GRAUPEL - - DUM = (-PGMLT(K)-EVPMG(K)+PRACG(K))*DT - - IF (DUM.GT.QG3D(K).AND.QG3D(K).GE.QSMALL) THEN - -! NO SOURCE TERM FOR GRAUPEL ABOVE FREEZING - RATIO = QG3D(K)/DUM - - PGMLT(K) = PGMLT(K)*RATIO - EVPMG(K) = EVPMG(K)*RATIO - PRACG(K) = PRACG(K)*RATIO - - END IF - -! CONSERVATION OF QR -! HM 12/13/06, ADDED CONSERVATION OF RAIN SINCE PRE IS NEGATIVE - - DUM = (-PRACS(K)-PRACG(K)-PRE(K)-PRA(K)-PRC(K)+PSMLT(K)+PGMLT(K))*DT - - IF (DUM.GT.QR3D(K).AND.QR3D(K).GE.QSMALL) THEN - - RATIO = (QR3D(K)/DT+PRACS(K)+PRACG(K)+PRA(K)+PRC(K)-PSMLT(K)-PGMLT(K))/ & - (-PRE(K)) - PRE(K) = PRE(K)*RATIO - - END IF - -!.................................... - - QV3DTEN(K) = QV3DTEN(K)+(-PRE(K)-EVPMS(K)-EVPMG(K)) - - T3DTEN(K) = T3DTEN(K)+(PRE(K)*XXLV(K)+(EVPMS(K)+EVPMG(K))*XXLS(K)+& - (PSMLT(K)+PGMLT(K)-PRACS(K)-PRACG(K))*XLF(K))/CPM(K) - - QC3DTEN(K) = QC3DTEN(K)+(-PRA(K)-PRC(K)) - QR3DTEN(K) = QR3DTEN(K)+(PRE(K)+PRA(K)+PRC(K)-PSMLT(K)-PGMLT(K)+PRACS(K)+PRACG(K)) - QNI3DTEN(K) = QNI3DTEN(K)+(PSMLT(K)+EVPMS(K)-PRACS(K)) - QG3DTEN(K) = QG3DTEN(K)+(PGMLT(K)+EVPMG(K)-PRACG(K)) - NS3DTEN(K) = NS3DTEN(K)-NPRACS(K) -! HM, bug fix 5/12/08, npracg is subtracted from nr not ng -! NG3DTEN(K) = NG3DTEN(K) - NC3DTEN(K) = NC3DTEN(K)+ (-NPRA(K)-NPRC(K)) - NR3DTEN(K) = NR3DTEN(K)+ (NPRC1(K)+NRAGG(K)-NPRACG(K)) - - IF (PRE(K).LT.0.) THEN - DUM = PRE(K)*DT/QR3D(K) - DUM = MAX(-1.,DUM) - NSUBR(K) = DUM*NR3D(K)/DT - END IF - - IF (EVPMS(K)+PSMLT(K).LT.0.) THEN - DUM = (EVPMS(K)+PSMLT(K))*DT/QNI3D(K) - DUM = MAX(-1.,DUM) - NSMLTS(K) = DUM*NS3D(K)/DT - END IF - IF (PSMLT(K).LT.0.) THEN - DUM = PSMLT(K)*DT/QNI3D(K) - DUM = MAX(-1.0,DUM) - NSMLTR(K) = DUM*NS3D(K)/DT - END IF - IF (EVPMG(K)+PGMLT(K).LT.0.) THEN - DUM = (EVPMG(K)+PGMLT(K))*DT/QG3D(K) - DUM = MAX(-1.,DUM) - NGMLTG(K) = DUM*NG3D(K)/DT - END IF - IF (PGMLT(K).LT.0.) THEN - DUM = PGMLT(K)*DT/QG3D(K) - DUM = MAX(-1.0,DUM) - NGMLTR(K) = DUM*NG3D(K)/DT - END IF - - NS3DTEN(K) = NS3DTEN(K)+(NSMLTS(K)) - NG3DTEN(K) = NG3DTEN(K)+(NGMLTG(K)) - NR3DTEN(K) = NR3DTEN(K)+(NSUBR(K)-NSMLTR(K)-NGMLTR(K)) - - 300 CONTINUE - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! NOW CALCULATE SATURATION ADJUSTMENT TO CONDENSE EXTRA VAPOR ABOVE -! WATER SATURATION - - DUMT = T3D(K)+DT*T3DTEN(K) - DUMQV = QV3D(K)+DT*QV3DTEN(K) - DUMQSS = 0.622*POLYSVP(DUMT,0)/ (PRES(K)-POLYSVP(DUMT,0)) - DUMQC = QC3D(K)+DT*QC3DTEN(K) - DUMQC = MAX(DUMQC,0.) - -! SATURATION ADJUSTMENT FOR LIQUID - - DUMS = DUMQV-DUMQSS - PCC(K) = DUMS/(1.+XXLV(K)**2*DUMQSS/(CPM(K)*RV*DUMT**2))/DT - IF (PCC(K)*DT+DUMQC.LT.0.) THEN - PCC(K) = -DUMQC/DT - END IF - - QV3DTEN(K) = QV3DTEN(K)-PCC(K) - T3DTEN(K) = T3DTEN(K)+PCC(K)*XXLV(K)/CPM(K) - QC3DTEN(K) = QC3DTEN(K)+PCC(K) - -!....................................................................... -! ACTIVATION OF CLOUD DROPLETS -! ACTIVATION OF DROPLET CURRENTLY NOT CALCULATED -! DROPLET CONCENTRATION IS SPECIFIED !!!!! - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! SUBLIMATE, MELT, OR EVAPORATE NUMBER CONCENTRATION -! THIS FORMULATION ASSUMES 1:1 RATIO BETWEEN MASS LOSS AND -! LOSS OF NUMBER CONCENTRATION - -! IF (PCC(K).LT.0.) THEN -! DUM = PCC(K)*DT/QC3D(K) -! DUM = MAX(-1.,DUM) -! NSUBC(K) = DUM*NC3D(K)/DT -! END IF - -! UPDATE TENDENCIES - -! NC3DTEN(K) = NC3DTEN(K)+NSUBC(K) - -!..................................................................... -!..................................................................... - ELSE ! TEMPERATURE < 273.15 - -!...................................................................... -!HM ADD, ALLOW FOR CONSTANT DROPLET NUMBER -! INUM = 0, PREDICT DROPLET NUMBER -! INUM = 1, SET CONSTANT DROPLET NUMBER - -! IF (INUM.EQ.1) THEN -! CONVERT NDCNST FROM CM-3 TO KG-1 - NC3D(K)=NDCNST*1.E6/RHO(K) -! END IF - -! CALCULATE SIZE DISTRIBUTION PARAMETERS -! MAKE SURE NUMBER CONCENTRATIONS AREN'T NEGATIVE - - NI3D(K) = MAX(0.,NI3D(K)) - NS3D(K) = MAX(0.,NS3D(K)) - NC3D(K) = MAX(0.,NC3D(K)) - NR3D(K) = MAX(0.,NR3D(K)) - NG3D(K) = MAX(0.,NG3D(K)) - -!...................................................................... -! CLOUD ICE - - IF (QI3D(K).GE.QSMALL) THEN - LAMI(K) = (CONS12* & - NI3D(K)/QI3D(K))**(1./DI) - N0I(K) = NI3D(K)*LAMI(K) - -! CHECK FOR SLOPE - -! ADJUST VARS - - IF (LAMI(K).LT.LAMMINI) THEN - - LAMI(K) = LAMMINI - - N0I(K) = LAMI(K)**4*QI3D(K)/CONS12 - - NI3D(K) = N0I(K)/LAMI(K) - ELSE IF (LAMI(K).GT.LAMMAXI) THEN - LAMI(K) = LAMMAXI - N0I(K) = LAMI(K)**4*QI3D(K)/CONS12 - - NI3D(K) = N0I(K)/LAMI(K) - END IF - END IF - -!...................................................................... -! RAIN - - IF (QR3D(K).GE.QSMALL) THEN - LAMR(K) = (PI*RHOW*NR3D(K)/QR3D(K))**(1./3.) - N0RR(K) = NR3D(K)*LAMR(K) - -! CHECK FOR SLOPE - -! ADJUST VARS - - IF (LAMR(K).LT.LAMMINR) THEN - - LAMR(K) = LAMMINR - - N0RR(K) = LAMR(K)**4*QR3D(K)/(PI*RHOW) - - NR3D(K) = N0RR(K)/LAMR(K) - ELSE IF (LAMR(K).GT.LAMMAXR) THEN - LAMR(K) = LAMMAXR - N0RR(K) = LAMR(K)**4*QR3D(K)/(PI*RHOW) - - NR3D(K) = N0RR(K)/LAMR(K) - END IF - END IF - -!...................................................................... -! CLOUD DROPLETS - -! MARTIN ET AL. (1994) FORMULA FOR PGAM - - IF (QC3D(K).GE.QSMALL) THEN - - DUM = PRES(K)/(287.15*T3D(K)) - PGAM(K)=0.0005714*(NC3D(K)/1.E6/DUM)+0.2714 - PGAM(K)=1./(PGAM(K)**2)-1. - PGAM(K)=MAX(PGAM(K),2.) - PGAM(K)=MIN(PGAM(K),10.) - -! CALCULATE LAMC - - LAMC(K) = (CONS26*NC3D(K)*GAMMA(PGAM(K)+4.)/ & - (QC3D(K)*GAMMA(PGAM(K)+1.)))**(1./3.) - -! LAMMIN, 60 MICRON DIAMETER -! LAMMAX, 1 MICRON - - LAMMIN = (PGAM(K)+1.)/60.E-6 - LAMMAX = (PGAM(K)+1.)/1.E-6 - - IF (LAMC(K).LT.LAMMIN) THEN - LAMC(K) = LAMMIN - - NC3D(K) = EXP(3.*LOG(LAMC(K))+LOG(QC3D(K))+ & - LOG(GAMMA(PGAM(K)+1.))-LOG(GAMMA(PGAM(K)+4.)))/CONS26 - ELSE IF (LAMC(K).GT.LAMMAX) THEN - LAMC(K) = LAMMAX - NC3D(K) = EXP(3.*LOG(LAMC(K))+LOG(QC3D(K))+ & - LOG(GAMMA(PGAM(K)+1.))-LOG(GAMMA(PGAM(K)+4.)))/CONS26 - - END IF - -! TO CALCULATE DROPLET FREEZING - - CDIST1(K) = NC3D(K)/GAMMA(PGAM(K)+1.) - - END IF - -!...................................................................... -! SNOW - - IF (QNI3D(K).GE.QSMALL) THEN - LAMS(K) = (CONS1*NS3D(K)/QNI3D(K))**(1./DS) - N0S(K) = NS3D(K)*LAMS(K) - -! CHECK FOR SLOPE - -! ADJUST VARS - - IF (LAMS(K).LT.LAMMINS) THEN - LAMS(K) = LAMMINS - N0S(K) = LAMS(K)**4*QNI3D(K)/CONS1 - - NS3D(K) = N0S(K)/LAMS(K) - - ELSE IF (LAMS(K).GT.LAMMAXS) THEN - - LAMS(K) = LAMMAXS - N0S(K) = LAMS(K)**4*QNI3D(K)/CONS1 - - NS3D(K) = N0S(K)/LAMS(K) - END IF - END IF - -!...................................................................... -! GRAUPEL - - IF (QG3D(K).GE.QSMALL) THEN - LAMG(K) = (CONS2*NG3D(K)/QG3D(K))**(1./DG) - N0G(K) = NG3D(K)*LAMG(K) - -! CHECK FOR SLOPE - -! ADJUST VARS - - IF (LAMG(K).LT.LAMMING) THEN - LAMG(K) = LAMMING - N0G(K) = LAMG(K)**4*QG3D(K)/CONS2 - - NG3D(K) = N0G(K)/LAMG(K) - - ELSE IF (LAMG(K).GT.LAMMAXG) THEN - - LAMG(K) = LAMMAXG - N0G(K) = LAMG(K)**4*QG3D(K)/CONS2 - - NG3D(K) = N0G(K)/LAMG(K) - END IF - END IF - -!..................................................................... -! ZERO OUT PROCESS RATES - - MNUCCC(K) = 0. - NNUCCC(K) = 0. - PRC(K) = 0. - NPRC(K) = 0. - NPRC1(K) = 0. - NSAGG(K) = 0. - PSACWS(K) = 0. - NPSACWS(K) = 0. - PSACWI(K) = 0. - NPSACWI(K) = 0. - PRACS(K) = 0. - NPRACS(K) = 0. - NMULTS(K) = 0. - QMULTS(K) = 0. - NMULTR(K) = 0. - QMULTR(K) = 0. - NMULTG(K) = 0. - QMULTG(K) = 0. - NMULTRG(K) = 0. - QMULTRG(K) = 0. - MNUCCR(K) = 0. - NNUCCR(K) = 0. - PRA(K) = 0. - NPRA(K) = 0. - NRAGG(K) = 0. - PRCI(K) = 0. - NPRCI(K) = 0. - PRAI(K) = 0. - NPRAI(K) = 0. - NNUCCD(K) = 0. - MNUCCD(K) = 0. - PCC(K) = 0. - PRE(K) = 0. - PRD(K) = 0. - PRDS(K) = 0. - EPRD(K) = 0. - EPRDS(K) = 0. - NSUBC(K) = 0. - NSUBI(K) = 0. - NSUBS(K) = 0. - NSUBR(K) = 0. - PIACR(K) = 0. - NIACR(K) = 0. - PRACI(K) = 0. - PIACRS(K) = 0. - NIACRS(K) = 0. - PRACIS(K) = 0. -! HM: ADD GRAUPEL PROCESSES - PRACG(K) = 0. - PSACR(K) = 0. - PSACWG(K) = 0. - PGSACW(K) = 0. - PGRACS(K) = 0. - PRDG(K) = 0. - EPRDG(K) = 0. - NPRACG(K) = 0. - NPSACWG(K) = 0. - NSCNG(K) = 0. - NGRACS(K) = 0. - NSUBG(K) = 0. - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! CALCULATION OF MICROPHYSICAL PROCESS RATES -! ACCRETION/AUTOCONVERSION/FREEZING/MELTING/COAG. -!....................................................................... -! FREEZING OF CLOUD DROPLETS -! ONLY ALLOWED BELOW -4 C - IF (QC3D(K).GE.QSMALL .AND. T3D(K).LT.269.15) THEN - -! NUMBER OF CONTACT NUCLEI (M^-3) FROM MEYERS ET AL., 1992 -! FACTOR OF 1000 IS TO CONVERT FROM L^-1 TO M^-3 - -! MEYERS CURVE - - NACNT = EXP(-2.80+0.262*(273.15-T3D(K)))*1000. - -! COOPER CURVE -! NACNT = 5.*EXP(0.304*(273.15-T3D(K))) - -! FLECTHER -! NACNT = 0.01*EXP(0.6*(273.15-T3D(K))) - -! CONTACT FREEZING - -! MEAN FREE PATH - - DUM = 7.37*T3D(K)/(288.*10.*PRES(K))/100. - -! EFFECTIVE DIFFUSIVITY OF CONTACT NUCLEI -! BASED ON BROWNIAN DIFFUSION - - DAP(K) = CONS37*T3D(K)*(1.+DUM/RIN)/MU(K) - - MNUCCC(K) = CONS38*DAP(K)*NACNT*EXP(LOG(CDIST1(K))+ & - LOG(GAMMA(PGAM(K)+5.))-4.*LOG(LAMC(K))) - NNUCCC(K) = 2.*PI*DAP(K)*NACNT*CDIST1(K)* & - GAMMA(PGAM(K)+2.)/ & - LAMC(K) - -! IMMERSION FREEZING (BIGG 1953) - - MNUCCC(K) = MNUCCC(K)+CONS39* & - EXP(LOG(CDIST1(K))+LOG(GAMMA(7.+PGAM(K)))-6.*LOG(LAMC(K)))* & - EXP(AIMM*(273.15-T3D(K))) - - NNUCCC(K) = NNUCCC(K)+ & - CONS40*EXP(LOG(CDIST1(K))+LOG(GAMMA(PGAM(K)+4.))-3.*LOG(LAMC(K))) & - *EXP(AIMM*(273.15-T3D(K))) - -! PUT IN A CATCH HERE TO PREVENT DIVERGENCE BETWEEN NUMBER CONC. AND -! MIXING RATIO, SINCE STRICT CONSERVATION NOT CHECKED FOR NUMBER CONC - - NNUCCC(K) = MIN(NNUCCC(K),NC3D(K)/DT) - - END IF - -!................................................................. -!....................................................................... -! AUTOCONVERSION OF CLOUD LIQUID WATER TO RAIN -! FORMULA FROM BEHENG (1994) -! USING NUMERICAL SIMULATION OF STOCHASTIC COLLECTION EQUATION -! AND INITIAL CLOUD DROPLET SIZE DISTRIBUTION SPECIFIED -! AS A GAMMA DISTRIBUTION - -! USE MINIMUM VALUE OF 1.E-6 TO PREVENT FLOATING POINT ERROR - - IF (QC3D(K).GE.1.E-6) THEN - -! HM ADD 12/13/06, REPLACE WITH NEWER FORMULA -! FROM KHAIROUTDINOV AND KOGAN 2000, MWR - - PRC(K)=1350.*QC3D(K)**2.47* & - (NC3D(K)/1.e6*RHO(K))**(-1.79) - -! note: nprc1 is change in Nr, -! nprc is change in Nc - - NPRC1(K) = PRC(K)/CONS29 - NPRC(K) = PRC(K)/(QC3D(K)/NC3D(K)) - - NPRC(K) = MIN(NPRC(K),NC3D(K)/DT) - - END IF - -!....................................................................... -! SELF-COLLECTION OF DROPLET NOT INCLUDED IN KK2000 SCHEME - -! SNOW AGGREGATION FROM PASSARELLI, 1978, USED BY REISNER, 1998 -! THIS IS HARD-WIRED FOR BS = 0.4 FOR NOW - - IF (QNI3D(K).GE.1.E-8) THEN - NSAGG(K) = CONS15*ASN(K)*RHO(K)** & - ((2.+BS)/3.)*QNI3D(K)**((2.+BS)/3.)* & - (NS3D(K)*RHO(K))**((4.-BS)/3.)/ & - (RHO(K)) - END IF - -!....................................................................... -! ACCRETION OF CLOUD DROPLETS ONTO SNOW/GRAUPEL -! HERE USE CONTINUOUS COLLECTION EQUATION WITH -! SIMPLE GRAVITATIONAL COLLECTION KERNEL IGNORING - -! SNOW - - IF (QNI3D(K).GE.1.E-8 .AND. QC3D(K).GE.QSMALL) THEN - - PSACWS(K) = CONS13*ASN(K)*QC3D(K)*RHO(K)* & - N0S(K)/ & - LAMS(K)**(BS+3.) - NPSACWS(K) = CONS13*ASN(K)*NC3D(K)*RHO(K)* & - N0S(K)/ & - LAMS(K)**(BS+3.) - - END IF - -!............................................................................ -! COLLECTION OF CLOUD WATER BY GRAUPEL - - IF (QG3D(K).GE.1.E-8 .AND. QC3D(K).GE.QSMALL) THEN - - PSACWG(K) = CONS14*AGN(K)*QC3D(K)*RHO(K)* & - N0G(K)/ & - LAMG(K)**(BG+3.) - NPSACWG(K) = CONS14*AGN(K)*NC3D(K)*RHO(K)* & - N0G(K)/ & - LAMG(K)**(BG+3.) - END IF - -!....................................................................... -! HM, ADD 12/13/06 -! CLOUD ICE COLLECTING DROPLETS, ASSUME THAT CLOUD ICE MEAN DIAM > 100 MICRON -! BEFORE RIMING CAN OCCUR -! ASSUME THAT RIME COLLECTED ON CLOUD ICE DOES NOT LEAD -! TO HALLET-MOSSOP SPLINTERING - - IF (QI3D(K).GE.1.E-8 .AND. QC3D(K).GE.QSMALL) THEN - -! PUT IN SIZE DEPENDENT COLLECTION EFFICIENCY BASED ON STOKES LAW -! FROM THOMPSON ET AL. 2004, MWR - - IF (1./LAMI(K).GE.100.E-6) THEN - - PSACWI(K) = CONS16*AIN(K)*QC3D(K)*RHO(K)* & - N0I(K)/ & - LAMI(K)**(BI+3.) - NPSACWI(K) = CONS16*AIN(K)*NC3D(K)*RHO(K)* & - N0I(K)/ & - LAMI(K)**(BI+3.) - END IF - END IF - -!....................................................................... -! ACCRETION OF RAIN WATER BY SNOW -! FORMULA FROM IKAWA AND SAITO, 1991, USED BY REISNER ET AL, 1998 - - IF (QR3D(K).GE.1.E-8.AND.QNI3D(K).GE.1.E-8) THEN - - UMS = ASN(K)*CONS3/(LAMS(K)**BS) - UMR = ARN(K)*CONS4/(LAMR(K)**BR) - UNS = ASN(K)*CONS5/LAMS(K)**BS - UNR = ARN(K)*CONS6/LAMR(K)**BR - -! SET REASLISTIC LIMITS ON FALLSPEEDS - UMS=MIN(UMS,1.2) - UNS=MIN(UNS,1.2) - UMR=MIN(UMR,9.1) - UNR=MIN(UNR,9.1) - - PRACS(K) = CONS41*(((1.2*UMR-0.95*UMS)**2+ & - 0.08*UMS*UMR)**0.5*RHO(K)* & - N0RR(K)*N0S(K)/LAMR(K)**3* & - (5./(LAMR(K)**3*LAMS(K))+ & - 2./(LAMR(K)**2*LAMS(K)**2)+ & - 0.5/(LAMR(k)*LAMS(k)**3))) - - NPRACS(K) = CONS32*RHO(K)*(1.7*(UNR-UNS)**2+ & - 0.3*UNR*UNS)**0.5*N0RR(K)*N0S(K)* & - (1./(LAMR(K)**3*LAMS(K))+ & - 1./(LAMR(K)**2*LAMS(K)**2)+ & - 1./(LAMR(K)*LAMS(K)**3)) - -! MAKE SURE PRACS DOESN'T EXCEED TOTAL RAIN MIXING RATIO -! AS THIS MAY OTHERWISE RESULT IN TOO MUCH TRANSFER OF WATER DURING -! RIME-SPLINTERING - - PRACS(K) = MIN(PRACS(K),QR3D(K)/DT) - -! COLLECTION OF SNOW BY RAIN - NEEDED FOR GRAUPEL CONVERSION CALCULATIONS -! ONLY CALCULATE IF SNOW AND RAIN MIXING RATIOS EXCEED 0.1 G/KG - -! ASSUME COLLECTION OF SNOW BY RAIN PRODUCES GRAUPEL NOT HAIL - -! HM MODIFY FOR WRFV3.1 -! IF (IHAIL.EQ.0) THEN - IF (QNI3D(K).GE.0.1E-3.AND.QR3D(K).GE.0.1E-3) THEN - PSACR(K) = CONS31*(((1.2*UMR-0.95*UMS)**2+ & - 0.08*UMS*UMR)**0.5*RHO(K)* & - N0RR(K)*N0S(K)/LAMS(K)**3* & - (5./(LAMS(K)**3*LAMR(K))+ & - 2./(LAMS(K)**2*LAMR(K)**2)+ & - 0.5/(LAMS(K)*LAMR(K)**3))) - END IF -! END IF - - END IF - -!....................................................................... - -! COLLECTION OF RAINWATER BY GRAUPEL, FROM IKAWA AND SAITO 1990, -! USED BY REISNER ET AL 1998 - IF (QR3D(K).GE.1.E-8.AND.QG3D(K).GE.1.E-8) THEN - - UMG = AGN(K)*CONS7/(LAMG(K)**BG) - UMR = ARN(K)*CONS4/(LAMR(K)**BR) - UNG = AGN(K)*CONS8/LAMG(K)**BG - UNR = ARN(K)*CONS6/LAMR(K)**BR - -! SET REASLISTIC LIMITS ON FALLSPEEDS - UMG=MIN(UMG,20.) - UNG=MIN(UNG,20.) - UMR=MIN(UMR,9.1) - UNR=MIN(UNR,9.1) - - PRACG(K) = CONS41*(((1.2*UMR-0.95*UMG)**2+ & - 0.08*UMG*UMR)**0.5*RHO(K)* & - N0RR(K)*N0G(K)/LAMR(K)**3* & - (5./(LAMR(K)**3*LAMG(K))+ & - 2./(LAMR(K)**2*LAMG(K)**2)+ & - 0.5/(LAMR(k)*LAMG(k)**3))) - - NPRACG(K) = CONS32*RHO(K)*(1.7*(UNR-UNG)**2+ & - 0.3*UNR*UNG)**0.5*N0RR(K)*N0G(K)* & - (1./(LAMR(K)**3*LAMG(K))+ & - 1./(LAMR(K)**2*LAMG(K)**2)+ & - 1./(LAMR(K)*LAMG(K)**3)) - -! MAKE SURE PRACG DOESN'T EXCEED TOTAL RAIN MIXING RATIO -! AS THIS MAY OTHERWISE RESULT IN TOO MUCH TRANSFER OF WATER DURING -! RIME-SPLINTERING - - PRACG(K) = MIN(PRACG(K),QR3D(K)/DT) - - END IF - -!....................................................................... -! RIME-SPLINTERING - SNOW -! HALLET-MOSSOP (1974) -! NUMBER OF SPLINTERS FORMED IS BASED ON MASS OF RIMED WATER - -! DUM1 = MASS OF INDIVIDUAL SPLINTERS - -! HM ADD THRESHOLD SNOW AND DROPLET MIXING RATIO FOR RIME-SPLINTERING -! TO LIMIT RIME-SPLINTERING IN STRATIFORM CLOUDS -! THESE THRESHOLDS CORRESPOND WITH GRAUPEL THRESHOLDS IN RH 1984 - -!v1.4 - IF (QNI3D(K).GE.0.1E-3) THEN - IF (QC3D(K).GE.0.5E-3.OR.QR3D(K).GE.0.1E-3) THEN - IF (PSACWS(K).GT.0..OR.PRACS(K).GT.0.) THEN - IF (T3D(K).LT.270.16 .AND. T3D(K).GT.265.16) THEN - - IF (T3D(K).GT.270.16) THEN - FMULT = 0. - ELSE IF (T3D(K).LE.270.16.AND.T3D(K).GT.268.16) THEN - FMULT = (270.16-T3D(K))/2. - ELSE IF (T3D(K).GE.265.16.AND.T3D(K).LE.268.16) THEN - FMULT = (T3D(K)-265.16)/3. - ELSE IF (T3D(K).LT.265.16) THEN - FMULT = 0. - END IF - -! 1000 IS TO CONVERT FROM KG TO G - -! SPLINTERING FROM DROPLETS ACCRETED ONTO SNOW - - IF (PSACWS(K).GT.0.) THEN - NMULTS(K) = 35.E4*PSACWS(K)*FMULT*1000. - QMULTS(K) = NMULTS(K)*MMULT - -! CONSTRAIN SO THAT TRANSFER OF MASS FROM SNOW TO ICE CANNOT BE MORE MASS -! THAN WAS RIMED ONTO SNOW - - QMULTS(K) = MIN(QMULTS(K),PSACWS(K)) - PSACWS(K) = PSACWS(K)-QMULTS(K) - - END IF - -! RIMING AND SPLINTERING FROM ACCRETED RAINDROPS - - IF (PRACS(K).GT.0.) THEN - NMULTR(K) = 35.E4*PRACS(K)*FMULT*1000. - QMULTR(K) = NMULTR(K)*MMULT - -! CONSTRAIN SO THAT TRANSFER OF MASS FROM SNOW TO ICE CANNOT BE MORE MASS -! THAN WAS RIMED ONTO SNOW - - QMULTR(K) = MIN(QMULTR(K),PRACS(K)) - - PRACS(K) = PRACS(K)-QMULTR(K) - - END IF - - END IF - END IF - END IF - END IF - -!....................................................................... -! RIME-SPLINTERING - GRAUPEL -! HALLET-MOSSOP (1974) -! NUMBER OF SPLINTERS FORMED IS BASED ON MASS OF RIMED WATER - -! DUM1 = MASS OF INDIVIDUAL SPLINTERS - -! HM ADD THRESHOLD SNOW MIXING RATIO FOR RIME-SPLINTERING -! TO LIMIT RIME-SPLINTERING IN STRATIFORM CLOUDS - -! ONLY CALCULATE FOR GRAUPEL NOT HAIL -! IF (IHAIL.EQ.0) THEN -! v1.4 - IF (QG3D(K).GE.0.1E-3) THEN - IF (QC3D(K).GE.0.5E-3.OR.QR3D(K).GE.0.1E-3) THEN - IF (PSACWG(K).GT.0..OR.PRACG(K).GT.0.) THEN - IF (T3D(K).LT.270.16 .AND. T3D(K).GT.265.16) THEN - - IF (T3D(K).GT.270.16) THEN - FMULT = 0. - ELSE IF (T3D(K).LE.270.16.AND.T3D(K).GT.268.16) THEN - FMULT = (270.16-T3D(K))/2. - ELSE IF (T3D(K).GE.265.16.AND.T3D(K).LE.268.16) THEN - FMULT = (T3D(K)-265.16)/3. - ELSE IF (T3D(K).LT.265.16) THEN - FMULT = 0. - END IF - -! 1000 IS TO CONVERT FROM KG TO G - -! SPLINTERING FROM DROPLETS ACCRETED ONTO GRAUPEL - - IF (PSACWG(K).GT.0.) THEN - NMULTG(K) = 35.E4*PSACWG(K)*FMULT*1000. - QMULTG(K) = NMULTG(K)*MMULT - -! CONSTRAIN SO THAT TRANSFER OF MASS FROM GRAUPEL TO ICE CANNOT BE MORE MASS -! THAN WAS RIMED ONTO GRAUPEL - - QMULTG(K) = MIN(QMULTG(K),PSACWG(K)) - PSACWG(K) = PSACWG(K)-QMULTG(K) - - END IF - -! RIMING AND SPLINTERING FROM ACCRETED RAINDROPS - - IF (PRACG(K).GT.0.) THEN - NMULTRG(K) = 35.E4*PRACG(K)*FMULT*1000. - QMULTRG(K) = NMULTRG(K)*MMULT - -! CONSTRAIN SO THAT TRANSFER OF MASS FROM GRAUPEL TO ICE CANNOT BE MORE MASS -! THAN WAS RIMED ONTO GRAUPEL - - QMULTRG(K) = MIN(QMULTRG(K),PRACG(K)) - PRACG(K) = PRACG(K)-QMULTRG(K) - - END IF - END IF - END IF - END IF - END IF -! END IF - -!........................................................................ -! CONVERSION OF RIMED CLOUD WATER ONTO SNOW TO GRAUPEL -! ASSUME CONVERTED SNOW FORMS GRAUPEL NOT HAIL -! HAIL ASSUMED TO ONLY FORM BY FREEZING OF RAIN -! OR COLLISIONS OF RAIN WITH CLOUD ICE - -! IF (IHAIL.EQ.0) THEN - IF (PSACWS(K).GT.0.) THEN -! ONLY ALLOW CONVERSION IF QNI > 0.1 AND QC > 0.5 G/KG FOLLOWING RUTLEDGE AND HOBBS (1984) - IF (QNI3D(K).GE.0.1E-3.AND.QC3D(K).GE.0.5E-3) THEN - -! PORTION OF RIMING CONVERTED TO GRAUPEL (REISNER ET AL. 1998, ORIGINALLY IS1991) - PGSACW(K) = MIN(PSACWS(K),CONS17*DT*N0S(K)*QC3D(K)*QC3D(K)* & - ASN(K)*ASN(K)/ & - (RHO(K)*LAMS(K)**(2.*BS+2.))) - -! MIX RAT CONVERTED INTO GRAUPEL AS EMBRYO (REISNER ET AL. 1998, ORIG M1990) - DUM = MAX(RHOSN/(RHOG-RHOSN)*PGSACW(K),0.) - -! NUMBER CONCENTRAITON OF EMBRYO GRAUPEL FROM RIMING OF SNOW - NSCNG(K) = DUM/MG0*RHO(K) -! LIMIT MAX NUMBER CONVERTED TO SNOW NUMBER - NSCNG(K) = MIN(NSCNG(K),NS3D(K)/DT) - -! PORTION OF RIMING LEFT FOR SNOW - PSACWS(K) = PSACWS(K) - PGSACW(K) - END IF - END IF - -! CONVERSION OF RIMED RAINWATER ONTO SNOW CONVERTED TO GRAUPEL - - IF (PRACS(K).GT.0.) THEN -! ONLY ALLOW CONVERSION IF QNI > 0.1 AND QR > 0.1 G/KG FOLLOWING RUTLEDGE AND HOBBS (1984) - IF (QNI3D(K).GE.0.1E-3.AND.QR3D(K).GE.0.1E-3) THEN -! PORTION OF COLLECTED RAINWATER CONVERTED TO GRAUPEL (REISNER ET AL. 1998) - DUM = CONS18*(4./LAMS(K))**3*(4./LAMS(K))**3 & - /(CONS18*(4./LAMS(K))**3*(4./LAMS(K))**3+ & - CONS19*(4./LAMR(K))**3*(4./LAMR(K))**3) - DUM=MIN(DUM,1.) - DUM=MAX(DUM,0.) - PGRACS(K) = (1.-DUM)*PRACS(K) - NGRACS(K) = (1.-DUM)*NPRACS(K) -! LIMIT MAX NUMBER CONVERTED TO MIN OF EITHER RAIN OR SNOW NUMBER CONCENTRATION - NGRACS(K) = MIN(NGRACS(K),NR3D(K)/DT) - NGRACS(K) = MIN(NGRACS(K),NS3D(K)/DT) - -! AMOUNT LEFT FOR SNOW PRODUCTION - PRACS(K) = PRACS(K) - PGRACS(K) - NPRACS(K) = NPRACS(K) - NGRACS(K) -! CONVERSION TO GRAUPEL DUE TO COLLECTION OF SNOW BY RAIN - PSACR(K)=PSACR(K)*(1.-DUM) - END IF - END IF -! END IF - -!....................................................................... -! FREEZING OF RAIN DROPS -! FREEZING ALLOWED BELOW -4 C - - IF (T3D(K).LT.269.15.AND.QR3D(K).GE.QSMALL) THEN - -! IMMERSION FREEZING (BIGG 1953) - MNUCCR(K) = CONS20*NR3D(K)*EXP(AIMM*(273.15-T3D(K)))/LAMR(K)**3 & - /LAMR(K)**3 - - NNUCCR(K) = PI*NR3D(K)*BIMM*EXP(AIMM*(273.15-T3D(K)))/LAMR(K)**3 - -! PREVENT DIVERGENCE BETWEEN MIXING RATIO AND NUMBER CONC - NNUCCR(K) = MIN(NNUCCR(K),NR3D(K)/DT) - - END IF - -!....................................................................... -! ACCRETION OF CLOUD LIQUID WATER BY RAIN -! CONTINUOUS COLLECTION EQUATION WITH -! GRAVITATIONAL COLLECTION KERNEL, DROPLET FALL SPEED NEGLECTED - - IF (QR3D(K).GE.1.E-8 .AND. QC3D(K).GE.1.E-8) THEN - -! 12/13/06 HM ADD, REPLACE WITH NEWER FORMULA FROM -! KHAIROUTDINOV AND KOGAN 2000, MWR - - DUM=(QC3D(K)*QR3D(K)) - PRA(K) = 67.*(DUM)**1.15 - NPRA(K) = PRA(K)/(QC3D(K)/NC3D(K)) - - END IF -!....................................................................... -! SELF-COLLECTION OF RAIN DROPS -! FROM BEHENG(1994) -! FROM NUMERICAL SIMULATION OF THE STOCHASTIC COLLECTION EQUATION -! AS DESCRINED ABOVE FOR AUTOCONVERSION - - IF (QR3D(K).GE.1.E-8) THEN - NRAGG(K) = -8.*NR3D(K)*QR3D(K)*RHO(K) - END IF - -!....................................................................... -! AUTOCONVERSION OF CLOUD ICE TO SNOW -! FOLLOWING HARRINGTON ET AL. (1995) WITH MODIFICATION -! HERE IT IS ASSUMED THAT AUTOCONVERSION CAN ONLY OCCUR WHEN THE -! ICE IS GROWING, I.E. IN CONDITIONS OF ICE SUPERSATURATION - - IF (QI3D(K).GE.1.E-8 .AND.QVQVSI(K).GE.1.) THEN - -! COFFI = 2./LAMI(K) -! IF (COFFI.GE.DCS) THEN - NPRCI(K) = CONS21*(QV3D(K)-QVI(K))*RHO(K) & - *N0I(K)*EXP(-LAMI(K)*DCS)*DV(K)/ABI(K) - PRCI(K) = CONS22*NPRCI(K) - NPRCI(K) = MIN(NPRCI(K),NI3D(K)/DT) - -! END IF - END IF - -!....................................................................... -! ACCRETION OF CLOUD ICE BY SNOW -! FOR THIS CALCULATION, IT IS ASSUMED THAT THE VS >> VI -! AND DS >> DI FOR CONTINUOUS COLLECTION - - IF (QNI3D(K).GE.1.E-8 .AND. QI3D(K).GE.QSMALL) THEN - PRAI(K) = CONS23*ASN(K)*QI3D(K)*RHO(K)*N0S(K)/ & - LAMS(K)**(BS+3.) - NPRAI(K) = CONS23*ASN(K)*NI3D(K)* & - RHO(K)*N0S(K)/ & - LAMS(K)**(BS+3.) - NPRAI(K)=MIN(NPRAI(K),NI3D(K)/DT) - END IF - -!....................................................................... -! HM, ADD 12/13/06, COLLISION OF RAIN AND ICE TO PRODUCE SNOW OR GRAUPEL -! FOLLOWS REISNER ET AL. 1998 -! ASSUMED FALLSPEED AND SIZE OF ICE CRYSTAL << THAN FOR RAIN - - IF (QR3D(K).GE.1.E-8.AND.QI3D(K).GE.1.E-8.AND.T3D(K).LE.273.15) THEN - -! ALLOW GRAUPEL FORMATION FROM RAIN-ICE COLLISIONS ONLY IF RAIN MIXING RATIO > 0.1 G/KG, -! OTHERWISE ADD TO SNOW - - IF (QR3D(K).GE.0.1E-3) THEN - NIACR(K)=CONS24*NI3D(K)*N0RR(K)*ARN(K) & - /LAMR(K)**(BR+3.)*RHO(K) - PIACR(K)=CONS25*NI3D(K)*N0RR(K)*ARN(K) & - /LAMR(K)**(BR+3.)/LAMR(K)**3*RHO(K) - PRACI(K)=CONS24*QI3D(K)*N0RR(K)*ARN(K)/ & - LAMR(K)**(BR+3.)*RHO(K) - NIACR(K)=MIN(NIACR(K),NR3D(K)/DT) - NIACR(K)=MIN(NIACR(K),NI3D(K)/DT) - ELSE - NIACRS(K)=CONS24*NI3D(K)*N0RR(K)*ARN(K) & - /LAMR(K)**(BR+3.)*RHO(K) - PIACRS(K)=CONS25*NI3D(K)*N0RR(K)*ARN(K) & - /LAMR(K)**(BR+3.)/LAMR(K)**3*RHO(K) - PRACIS(K)=CONS24*QI3D(K)*N0RR(K)*ARN(K)/ & - LAMR(K)**(BR+3.)*RHO(K) - NIACRS(K)=MIN(NIACRS(K),NR3D(K)/DT) - NIACRS(K)=MIN(NIACRS(K),NI3D(K)/DT) - END IF - END IF - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! NUCLEATION OF CLOUD ICE FROM HOMOGENEOUS AND HETEROGENEOUS FREEZING ON AEROSOL - - IF (INUC.EQ.0) THEN - -! FREEZING OF AEROSOL ONLY ALLOWED BELOW -5 C -! AND ABOVE DELIQUESCENCE THRESHOLD OF 80% -! AND ABOVE ICE SATURATION - -! add threshold according to Greg Thomspon - - if ((QVQVS(K).GE.0.999.and.T3D(K).le.265.15).or. & - QVQVSI(K).ge.1.08) then - -! hm, modify dec. 5, 2006, replace with cooper curve - kc2 = 0.005*exp(0.304*(273.15-T3D(K)))*1000. ! convert from L-1 to m-3 -! limit to 500 L-1 - kc2 = min(kc2,500.e3) - kc2=MAX(kc2/rho(k),0.) ! convert to kg-1 - - IF (KC2.GT.NI3D(K)+NS3D(K)+NG3D(K)) THEN - NNUCCD(K) = (KC2-NI3D(K)-NS3D(K)-NG3D(K))/DT - MNUCCD(K) = NNUCCD(K)*MI0 - END IF - - END IF - - ELSE IF (INUC.EQ.1) THEN - - IF (T3D(K).LT.273.15.AND.QVQVSI(K).GT.1.) THEN - - KC2 = 0.16*1000./RHO(K) ! CONVERT FROM L-1 TO KG-1 - IF (KC2.GT.NI3D(K)+NS3D(K)+NG3D(K)) THEN - NNUCCD(K) = (KC2-NI3D(K)-NS3D(K)-NG3D(K))/DT - MNUCCD(K) = NNUCCD(K)*MI0 - END IF - END IF - - END IF - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - - 101 CONTINUE - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! CALCULATE EVAP/SUB/DEP TERMS FOR QI,QNI,QR - -! NO VENTILATION FOR CLOUD ICE - - IF (QI3D(K).GE.QSMALL) THEN - - EPSI = 2.*PI*N0I(K)*RHO(K)*DV(K)/(LAMI(K)*LAMI(K)) - - ELSE - EPSI = 0. - END IF - - IF (QNI3D(K).GE.QSMALL) THEN - EPSS = 2.*PI*N0S(K)*RHO(K)*DV(K)* & - (F1S/(LAMS(K)*LAMS(K))+ & - F2S*(ASN(K)*RHO(K)/MU(K))**0.5* & - SC(K)**(1./3.)*CONS10/ & - (LAMS(K)**CONS35)) - ELSE - EPSS = 0. - END IF - - IF (QG3D(K).GE.QSMALL) THEN - EPSG = 2.*PI*N0G(K)*RHO(K)*DV(K)* & - (F1S/(LAMG(K)*LAMG(K))+ & - F2S*(AGN(K)*RHO(K)/MU(K))**0.5* & - SC(K)**(1./3.)*CONS11/ & - (LAMG(K)**CONS36)) - - - ELSE - EPSG = 0. - END IF - - IF (QR3D(K).GE.QSMALL) THEN - EPSR = 2.*PI*N0RR(K)*RHO(K)*DV(K)* & - (F1R/(LAMR(K)*LAMR(K))+ & - F2R*(ARN(K)*RHO(K)/MU(K))**0.5* & - SC(K)**(1./3.)*CONS9/ & - (LAMR(K)**CONS34)) - ELSE - EPSR = 0. - END IF - -! ONLY INCLUDE REGION OF ICE SIZE DIST < DCS -! DUM IS FRACTION OF D*N(D) < DCS - -! LOGIC BELOW FOLLOWS THAT OF HARRINGTON ET AL. 1995 (JAS) - IF (QI3D(K).GE.QSMALL) THEN - DUM=(1.-EXP(-LAMI(K)*DCS)*(1.+LAMI(K)*DCS)) - PRD(K) = EPSI*(QV3D(K)-QVI(K))/ABI(K)*DUM - ELSE - DUM=0. - END IF -! ADD DEPOSITION IN TAIL OF ICE SIZE DIST TO SNOW IF SNOW IS PRESENT - IF (QNI3D(K).GE.QSMALL) THEN - PRDS(K) = EPSS*(QV3D(K)-QVI(K))/ABI(K)+ & - EPSI*(QV3D(K)-QVI(K))/ABI(K)*(1.-DUM) -! OTHERWISE ADD TO CLOUD ICE - ELSE - PRD(K) = PRD(K)+EPSI*(QV3D(K)-QVI(K))/ABI(K)*(1.-DUM) - END IF -! VAPOR DPEOSITION ON GRAUPEL - PRDG(K) = EPSG*(QV3D(K)-QVI(K))/ABI(K) - -! NO CONDENSATION ONTO RAIN, ONLY EVAP - - IF (QV3D(K).LT.QVS(K)) THEN - PRE(K) = EPSR*(QV3D(K)-QVS(K))/AB(K) - PRE(K) = MIN(PRE(K),0.) - ELSE - PRE(K) = 0. - END IF - -! MAKE SURE NOT PUSHED INTO ICE SUPERSAT/SUBSAT -! FORMULA FROM REISNER 2 SCHEME - - DUM = (QV3D(K)-QVI(K))/DT - - FUDGEF = 0.9999 - SUM_DEP = PRD(K)+PRDS(K)+MNUCCD(K)+PRDG(K) - - IF( (DUM.GT.0. .AND. SUM_DEP.GT.DUM*FUDGEF) .OR. & - (DUM.LT.0. .AND. SUM_DEP.LT.DUM*FUDGEF) ) THEN - MNUCCD(K) = FUDGEF*MNUCCD(K)*DUM/SUM_DEP - PRD(K) = FUDGEF*PRD(K)*DUM/SUM_DEP - PRDS(K) = FUDGEF*PRDS(K)*DUM/SUM_DEP - PRDG(K) = FUDGEF*PRDG(K)*DUM/SUM_DEP - ENDIF - -! IF CLOUD ICE/SNOW/GRAUPEL VAP DEPOSITION IS NEG, THEN ASSIGN TO SUBLIMATION PROCESSES - - IF (PRD(K).LT.0.) THEN - EPRD(K)=PRD(K) - PRD(K)=0. - END IF - IF (PRDS(K).LT.0.) THEN - EPRDS(K)=PRDS(K) - PRDS(K)=0. - END IF - IF (PRDG(K).LT.0.) THEN - EPRDG(K)=PRDG(K) - PRDG(K)=0. - END IF - -!....................................................................... -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - -! CONSERVATION OF WATER -! THIS IS ADOPTED LOOSELY FROM MM5 RESINER CODE. HOWEVER, HERE WE -! ONLY ADJUST PROCESSES THAT ARE NEGATIVE, RATHER THAN ALL PROCESSES. - -! IF MIXING RATIOS LESS THAN QSMALL, THEN NO DEPLETION OF WATER -! THROUGH MICROPHYSICAL PROCESSES, SKIP CONSERVATION - -! NOTE: CONSERVATION CHECK NOT APPLIED TO NUMBER CONCENTRATION SPECIES. ADDITIONAL CATCH -! BELOW WILL PREVENT NEGATIVE NUMBER CONCENTRATION -! FOR EACH MICROPHYSICAL PROCESS WHICH PROVIDES A SOURCE FOR NUMBER, THERE IS A CHECK -! TO MAKE SURE THAT CAN'T EXCEED TOTAL NUMBER OF DEPLETED SPECIES WITH THE TIME -! STEP - -!****SENSITIVITY - NO ICE - - IF (ILIQ.EQ.1) THEN - MNUCCC(K)=0. - NNUCCC(K)=0. - MNUCCR(K)=0. - NNUCCR(K)=0. - MNUCCD(K)=0. - NNUCCD(K)=0. - END IF - -! ****SENSITIVITY - NO GRAUPEL - IF (IGRAUP.EQ.1) THEN - PRACG(K) = 0. - PSACR(K) = 0. - PSACWG(K) = 0. - PGSACW(K) = 0. - PGRACS(K) = 0. - PRDG(K) = 0. - EPRDG(K) = 0. - EVPMG(K) = 0. - PGMLT(K) = 0. - NPRACG(K) = 0. - NPSACWG(K) = 0. - NSCNG(K) = 0. - NGRACS(K) = 0. - NSUBG(K) = 0. - NGMLTG(K) = 0. - NGMLTR(K) = 0. - END IF - -! CONSERVATION OF QC - - DUM = (PRC(K)+PRA(K)+MNUCCC(K)+PSACWS(K)+PSACWI(K)+QMULTS(K)+PSACWG(K)+PGSACW(K)+QMULTG(K))*DT - - IF (DUM.GT.QC3D(K).AND.QC3D(K).GE.QSMALL) THEN - RATIO = QC3D(K)/DUM - - PRC(K) = PRC(K)*RATIO - PRA(K) = PRA(K)*RATIO - MNUCCC(K) = MNUCCC(K)*RATIO - PSACWS(K) = PSACWS(K)*RATIO - PSACWI(K) = PSACWI(K)*RATIO - QMULTS(K) = QMULTS(K)*RATIO - QMULTG(K) = QMULTG(K)*RATIO - PSACWG(K) = PSACWG(K)*RATIO - PGSACW(K) = PGSACW(K)*RATIO - END IF - -! CONSERVATION OF QI - - DUM = (-PRD(K)-MNUCCC(K)+PRCI(K)+PRAI(K)-QMULTS(K)-QMULTG(K)-QMULTR(K)-QMULTRG(K) & - -MNUCCD(K)+PRACI(K)+PRACIS(K)-EPRD(K)-PSACWI(K))*DT - - IF (DUM.GT.QI3D(K).AND.QI3D(K).GE.QSMALL) THEN - - RATIO = (QI3D(K)/DT+PRD(K)+MNUCCC(K)+QMULTS(K)+QMULTG(K)+QMULTR(K)+QMULTRG(K)+ & - MNUCCD(K)+PSACWI(K))/ & - (PRCI(K)+PRAI(K)+PRACI(K)+PRACIS(K)-EPRD(K)) - - PRCI(K) = PRCI(K)*RATIO - PRAI(K) = PRAI(K)*RATIO - PRACI(K) = PRACI(K)*RATIO - PRACIS(K) = PRACIS(K)*RATIO - EPRD(K) = EPRD(K)*RATIO - - END IF - -! CONSERVATION OF QR - - DUM=((PRACS(K)-PRE(K))+(QMULTR(K)+QMULTRG(K)-PRC(K))+(MNUCCR(K)-PRA(K))+ & - PIACR(K)+PIACRS(K)+PGRACS(K)+PRACG(K))*DT - - IF (DUM.GT.QR3D(K).AND.QR3D(K).GE.QSMALL) THEN - - RATIO = (QR3D(K)/DT+PRC(K)+PRA(K))/ & - (-PRE(K)+QMULTR(K)+QMULTRG(K)+PRACS(K)+MNUCCR(K)+PIACR(K)+PIACRS(K)+PGRACS(K)+PRACG(K)) - - PRE(K) = PRE(K)*RATIO - PRACS(K) = PRACS(K)*RATIO - QMULTR(K) = QMULTR(K)*RATIO - QMULTRG(K) = QMULTRG(K)*RATIO - MNUCCR(K) = MNUCCR(K)*RATIO - PIACR(K) = PIACR(K)*RATIO - PIACRS(K) = PIACRS(K)*RATIO - PGRACS(K) = PGRACS(K)*RATIO - PRACG(K) = PRACG(K)*RATIO - - END IF - -! CONSERVATION OF QNI -! CONSERVATION FOR GRAUPEL SCHEME - - IF (IGRAUP.EQ.0) THEN - - DUM = (-PRDS(K)-PSACWS(K)-PRAI(K)-PRCI(K)-PRACS(K)-EPRDS(K)+PSACR(K)-PIACRS(K)-PRACIS(K))*DT - - IF (DUM.GT.QNI3D(K).AND.QNI3D(K).GE.QSMALL) THEN - - RATIO = (QNI3D(K)/DT+PRDS(K)+PSACWS(K)+PRAI(K)+PRCI(K)+PRACS(K)+PIACRS(K)+PRACIS(K))/(-EPRDS(K)+PSACR(K)) - - EPRDS(K) = EPRDS(K)*RATIO - PSACR(K) = PSACR(K)*RATIO - - END IF - -! FOR NO GRAUPEL, NEED TO INCLUDE FREEZING OF RAIN FOR SNOW - ELSE IF (IGRAUP.EQ.1) THEN - - DUM = (-PRDS(K)-PSACWS(K)-PRAI(K)-PRCI(K)-PRACS(K)-EPRDS(K)+PSACR(K)-PIACRS(K)-PRACIS(K)-MNUCCR(K))*DT - - IF (DUM.GT.QNI3D(K).AND.QNI3D(K).GE.QSMALL) THEN - - RATIO = (QNI3D(K)/DT+PRDS(K)+PSACWS(K)+PRAI(K)+PRCI(K)+PRACS(K)+PIACRS(K)+PRACIS(K)+MNUCCR(K))/(-EPRDS(K)+PSACR(K)) - - EPRDS(K) = EPRDS(K)*RATIO - PSACR(K) = PSACR(K)*RATIO - - END IF - - END IF - -! CONSERVATION OF QG - - DUM = (-PSACWG(K)-PRACG(K)-PGSACW(K)-PGRACS(K)-PRDG(K)-MNUCCR(K)-EPRDG(K)-PIACR(K)-PRACI(K)-PSACR(K))*DT - - IF (DUM.GT.QG3D(K).AND.QG3D(K).GE.QSMALL) THEN - - RATIO = (QG3D(K)/DT+PSACWG(K)+PRACG(K)+PGSACW(K)+PGRACS(K)+PRDG(K)+MNUCCR(K)+PSACR(K)+& - PIACR(K)+PRACI(K))/(-EPRDG(K)) - - EPRDG(K) = EPRDG(K)*RATIO - - END IF - -! TENDENCIES - - QV3DTEN(K) = QV3DTEN(K)+(-PRE(K)-PRD(K)-PRDS(K)-MNUCCD(K)-EPRD(K)-EPRDS(K)-PRDG(K)-EPRDG(K)) - T3DTEN(K) = T3DTEN(K)+(PRE(K) & - *XXLV(K)+(PRD(K)+PRDS(K)+ & - MNUCCD(K)+EPRD(K)+EPRDS(K)+PRDG(K)+EPRDG(K))*XXLS(K)+ & - (PSACWS(K)+PSACWI(K)+MNUCCC(K)+MNUCCR(K)+ & - QMULTS(K)+QMULTG(K)+QMULTR(K)+QMULTRG(K)+PRACS(K) & - +PSACWG(K)+PRACG(K)+PGSACW(K)+PGRACS(K))*XLF(K))/CPM(K) - - QC3DTEN(K) = QC3DTEN(K)+ & - (-PRA(K)-PRC(K)-MNUCCC(K)+PCC(K)- & - PSACWS(K)-PSACWI(K)-QMULTS(K)-QMULTG(K)-PSACWG(K)-PGSACW(K)) - QI3DTEN(K) = QI3DTEN(K)+ & - (PRD(K)+EPRD(K)+PSACWI(K)+MNUCCC(K)-PRCI(K)- & - PRAI(K)+QMULTS(K)+QMULTG(K)+QMULTR(K)+QMULTRG(K)+MNUCCD(K)-PRACI(K)-PRACIS(K)) - QR3DTEN(K) = QR3DTEN(K)+ & - (PRE(K)+PRA(K)+PRC(K)-PRACS(K)-MNUCCR(K)-QMULTR(K)-QMULTRG(K) & - -PIACR(K)-PIACRS(K)-PRACG(K)-PGRACS(K)) - - IF (IGRAUP.EQ.0) THEN - - QNI3DTEN(K) = QNI3DTEN(K)+ & - (PRAI(K)+PSACWS(K)+PRDS(K)+PRACS(K)+PRCI(K)+EPRDS(K)-PSACR(K)+PIACRS(K)+PRACIS(K)) - NS3DTEN(K) = NS3DTEN(K)+(NSAGG(K)+NPRCI(K)-NSCNG(K)-NGRACS(K)+NIACRS(K)) - QG3DTEN(K) = QG3DTEN(K)+(PRACG(K)+PSACWG(K)+PGSACW(K)+PGRACS(K)+ & - PRDG(K)+EPRDG(K)+MNUCCR(K)+PIACR(K)+PRACI(K)+PSACR(K)) - NG3DTEN(K) = NG3DTEN(K)+(NSCNG(K)+NGRACS(K)+NNUCCR(K)+NIACR(K)) - -! FOR NO GRAUPEL, NEED TO INCLUDE FREEZING OF RAIN FOR SNOW - ELSE IF (IGRAUP.EQ.1) THEN - - QNI3DTEN(K) = QNI3DTEN(K)+ & - (PRAI(K)+PSACWS(K)+PRDS(K)+PRACS(K)+PRCI(K)+EPRDS(K)-PSACR(K)+PIACRS(K)+PRACIS(K)+MNUCCR(K)) - NS3DTEN(K) = NS3DTEN(K)+(NSAGG(K)+NPRCI(K)-NSCNG(K)-NGRACS(K)+NIACRS(K)+NNUCCR(K)) - - END IF - - NC3DTEN(K) = NC3DTEN(K)+(-NNUCCC(K)-NPSACWS(K) & - -NPRA(K)-NPRC(K)-NPSACWI(K)-NPSACWG(K)) - - NI3DTEN(K) = NI3DTEN(K)+ & - (NNUCCC(K)-NPRCI(K)-NPRAI(K)+NMULTS(K)+NMULTG(K)+NMULTR(K)+NMULTRG(K)+ & - NNUCCD(K)-NIACR(K)-NIACRS(K)) - - NR3DTEN(K) = NR3DTEN(K)+(NPRC1(K)-NPRACS(K)-NNUCCR(K) & - +NRAGG(K)-NIACR(K)-NIACRS(K)-NPRACG(K)-NGRACS(K)) - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! NOW CALCULATE SATURATION ADJUSTMENT TO CONDENSE EXTRA VAPOR ABOVE -! WATER SATURATION - - DUMT = T3D(K)+DT*T3DTEN(K) - DUMQV = QV3D(K)+DT*QV3DTEN(K) - DUMQSS = 0.622*POLYSVP(DUMT,0)/ (PRES(K)-POLYSVP(DUMT,0)) - DUMQC = QC3D(K)+DT*QC3DTEN(K) - DUMQC = MAX(DUMQC,0.) - -! SATURATION ADJUSTMENT FOR LIQUID - - DUMS = DUMQV-DUMQSS - PCC(K) = DUMS/(1.+XXLV(K)**2*DUMQSS/(CPM(K)*RV*DUMT**2))/DT - IF (PCC(K)*DT+DUMQC.LT.0.) THEN - PCC(K) = -DUMQC/DT - END IF - - QV3DTEN(K) = QV3DTEN(K)-PCC(K) - T3DTEN(K) = T3DTEN(K)+PCC(K)*XXLV(K)/CPM(K) - QC3DTEN(K) = QC3DTEN(K)+PCC(K) - -!....................................................................... -! ACTIVATION OF CLOUD DROPLETS -! ACTIVATION OF DROPLET CURRENTLY NOT CALCULATED -! DROPLET CONCENTRATION IS SPECIFIED !!!!! - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! SUBLIMATE, MELT, OR EVAPORATE NUMBER CONCENTRATION -! THIS FORMULATION ASSUMES 1:1 RATIO BETWEEN MASS LOSS AND -! LOSS OF NUMBER CONCENTRATION - -! IF (PCC(K).LT.0.) THEN -! DUM = PCC(K)*DT/QC3D(K) -! DUM = MAX(-1.,DUM) -! NSUBC(K) = DUM*NC3D(K)/DT -! END IF - - IF (EPRD(K).LT.0.) THEN - DUM = EPRD(K)*DT/QI3D(K) - DUM = MAX(-1.,DUM) - NSUBI(K) = DUM*NI3D(K)/DT - END IF - IF (EPRDS(K).LT.0.) THEN - DUM = EPRDS(K)*DT/QNI3D(K) - DUM = MAX(-1.,DUM) - NSUBS(K) = DUM*NS3D(K)/DT - END IF - IF (PRE(K).LT.0.) THEN - DUM = PRE(K)*DT/QR3D(K) - DUM = MAX(-1.,DUM) - NSUBR(K) = DUM*NR3D(K)/DT - END IF - IF (EPRDG(K).LT.0.) THEN - DUM = EPRDG(K)*DT/QG3D(K) - DUM = MAX(-1.,DUM) - NSUBG(K) = DUM*NG3D(K)/DT - END IF - -! nsubr(k)=0. -! nsubs(k)=0. -! nsubg(k)=0. - -! UPDATE TENDENCIES - -! NC3DTEN(K) = NC3DTEN(K)+NSUBC(K) - NI3DTEN(K) = NI3DTEN(K)+NSUBI(K) - NS3DTEN(K) = NS3DTEN(K)+NSUBS(K) - NG3DTEN(K) = NG3DTEN(K)+NSUBG(K) - NR3DTEN(K) = NR3DTEN(K)+NSUBR(K) - - END IF !!!!!! TEMPERATURE - -! SWITCH LTRUE TO 1, SINCE HYDROMETEORS ARE PRESENT - LTRUE = 1 - - 200 CONTINUE - - END DO - -! INITIALIZE PRECIP AND SNOW RATES - PRECRT = 0. - SNOWRT = 0. - -! IF THERE ARE NO HYDROMETEORS, THEN SKIP TO END OF SUBROUTINE - - IF (LTRUE.EQ.0) GOTO 400 - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -!....................................................................... -! CALCULATE SEDIMENATION -! THE NUMERICS HERE FOLLOW FROM REISNER ET AL. (1998) -! FALLOUT TERMS ARE CALCULATED ON SPLIT TIME STEPS TO ENSURE NUMERICAL -! STABILITY, I.E. COURANT# < 1 - -!....................................................................... - - NSTEP = 1 - - DO K = KTS,KTE - - DUMI(K) = QI3D(K)+QI3DTEN(K)*DT - DUMQS(K) = QNI3D(K)+QNI3DTEN(K)*DT - DUMR(K) = QR3D(K)+QR3DTEN(K)*DT - DUMFNI(K) = NI3D(K)+NI3DTEN(K)*DT - DUMFNS(K) = NS3D(K)+NS3DTEN(K)*DT - DUMFNR(K) = NR3D(K)+NR3DTEN(K)*DT - DUMC(K) = QC3D(K)+QC3DTEN(K)*DT - DUMFNC(K) = NC3D(K)+NC3DTEN(K)*DT - DUMG(K) = QG3D(K)+QG3DTEN(K)*DT - DUMFNG(K) = NG3D(K)+NG3DTEN(K)*DT - -! SWITCH FOR CONSTANT DROPLET NUMBER -! IF (INUM.EQ.1) THEN - DUMFNC(K) = NC3D(K) -! END IF - -! GET DUMMY LAMDA FOR SEDIMENTATION CALCULATIONS - -! MAKE SURE NUMBER CONCENTRATIONS ARE POSITIVE - DUMFNI(K) = MAX(0.,DUMFNI(K)) - DUMFNS(K) = MAX(0.,DUMFNS(K)) - DUMFNC(K) = MAX(0.,DUMFNC(K)) - DUMFNR(K) = MAX(0.,DUMFNR(K)) - DUMFNG(K) = MAX(0.,DUMFNG(K)) - -!...................................................................... -! CLOUD ICE - - IF (DUMI(K).GE.QSMALL) THEN - DLAMI = (CONS12*DUMFNI(K)/DUMI(K))**(1./DI) - DLAMI=MAX(DLAMI,LAMMINI) - DLAMI=MIN(DLAMI,LAMMAXI) - END IF -!...................................................................... -! RAIN - - IF (DUMR(K).GE.QSMALL) THEN - DLAMR = (PI*RHOW*DUMFNR(K)/DUMR(K))**(1./3.) - DLAMR=MAX(DLAMR,LAMMINR) - DLAMR=MIN(DLAMR,LAMMAXR) - END IF -!...................................................................... -! CLOUD DROPLETS - - IF (DUMC(K).GE.QSMALL) THEN - DUM = PRES(K)/(287.15*T3D(K)) - PGAM(K)=0.0005714*(NC3D(K)/1.E6/DUM)+0.2714 - PGAM(K)=1./(PGAM(K)**2)-1. - PGAM(K)=MAX(PGAM(K),2.) - PGAM(K)=MIN(PGAM(K),10.) - - DLAMC = (CONS26*DUMFNC(K)*GAMMA(PGAM(K)+4.)/(DUMC(K)*GAMMA(PGAM(K)+1.)))**(1./3.) - LAMMIN = (PGAM(K)+1.)/60.E-6 - LAMMAX = (PGAM(K)+1.)/1.E-6 - DLAMC=MAX(DLAMC,LAMMIN) - DLAMC=MIN(DLAMC,LAMMAX) - END IF -!...................................................................... -! SNOW - - IF (DUMQS(K).GE.QSMALL) THEN - DLAMS = (CONS1*DUMFNS(K)/ DUMQS(K))**(1./DS) - DLAMS=MAX(DLAMS,LAMMINS) - DLAMS=MIN(DLAMS,LAMMAXS) - END IF -!...................................................................... -! GRAUPEL - - IF (DUMG(K).GE.QSMALL) THEN - DLAMG = (CONS2*DUMFNG(K)/ DUMG(K))**(1./DG) - DLAMG=MAX(DLAMG,LAMMING) - DLAMG=MIN(DLAMG,LAMMAXG) - END IF - -!...................................................................... -! CALCULATE NUMBER-WEIGHTED AND MASS-WEIGHTED TERMINAL FALL SPEEDS - -! CLOUD WATER - - IF (DUMC(K).GE.QSMALL) THEN - UNC = ACN(K)*GAMMA(1.+BC+PGAM(K))/ (DLAMC**BC*GAMMA(PGAM(K)+1.)) - UMC = ACN(K)*GAMMA(4.+BC+PGAM(K))/ (DLAMC**BC*GAMMA(PGAM(K)+4.)) - ELSE - UMC = 0. - UNC = 0. - END IF - - IF (DUMI(K).GE.QSMALL) THEN - UNI = AIN(K)*CONS27/DLAMI**BI - UMI = AIN(K)*CONS28/(DLAMI**BI) - ELSE - UMI = 0. - UNI = 0. - END IF - - IF (DUMR(K).GE.QSMALL) THEN - UNR = ARN(K)*CONS6/DLAMR**BR - UMR = ARN(K)*CONS4/(DLAMR**BR) - ELSE - UMR = 0. - UNR = 0. - END IF - - IF (DUMQS(K).GE.QSMALL) THEN - UMS = ASN(K)*CONS3/(DLAMS**BS) - UNS = ASN(K)*CONS5/DLAMS**BS - ELSE - UMS = 0. - UNS = 0. - END IF - - IF (DUMG(K).GE.QSMALL) THEN - UMG = AGN(K)*CONS7/(DLAMG**BG) - UNG = AGN(K)*CONS8/DLAMG**BG - ELSE - UMG = 0. - UNG = 0. - END IF - -! SET REALISTIC LIMITS ON FALLSPEED - - UMS=MIN(UMS,1.2) - UNS=MIN(UNS,1.2) - UMI=MIN(UMI,1.2) - UNI=MIN(UNI,1.2) - UMR=MIN(UMR,9.1) - UNR=MIN(UNR,9.1) - UMG=MIN(UMG,20.) - UNG=MIN(UNG,20.) - - FR(K) = UMR - FI(K) = UMI - FNI(K) = UNI - FS(K) = UMS - FNS(K) = UNS - FNR(K) = UNR - FC(K) = UMC - FNC(K) = UNC - FG(K) = UMG - FNG(K) = UNG - -! CALCULATE NUMBER OF SPLIT TIME STEPS - - RGVM = MAX(FR(K),FI(K),FS(K),FC(K),FNI(K),FNR(K),FNS(K),FNC(K),FG(K),FNG(K)) -! VVT CHANGED IFIX -> INT (GENERIC FUNCTION) - NSTEP = MAX(INT(RGVM*DT/DZQ(K)+1.),NSTEP) - -! MULTIPLY VARIABLES BY RHO - DUMR(k) = DUMR(k)*RHO(K) - DUMI(k) = DUMI(k)*RHO(K) - DUMFNI(k) = DUMFNI(K)*RHO(K) - DUMQS(k) = DUMQS(K)*RHO(K) - DUMFNS(k) = DUMFNS(K)*RHO(K) - DUMFNR(k) = DUMFNR(K)*RHO(K) - DUMC(k) = DUMC(K)*RHO(K) - DUMFNC(k) = DUMFNC(K)*RHO(K) - DUMG(k) = DUMG(K)*RHO(K) - DUMFNG(k) = DUMFNG(K)*RHO(K) - - END DO - - DO N = 1,NSTEP - - DO K = KTS,KTE - FALOUTR(K) = FR(K)*DUMR(K) - FALOUTI(K) = FI(K)*DUMI(K) - FALOUTNI(K) = FNI(K)*DUMFNI(K) - FALOUTS(K) = FS(K)*DUMQS(K) - FALOUTNS(K) = FNS(K)*DUMFNS(K) - FALOUTNR(K) = FNR(K)*DUMFNR(K) - FALOUTC(K) = FC(K)*DUMC(K) - FALOUTNC(K) = FNC(K)*DUMFNC(K) - FALOUTG(K) = FG(K)*DUMG(K) - FALOUTNG(K) = FNG(K)*DUMFNG(K) - END DO - -! TOP OF MODEL - - K = KTE - FALTNDR = FALOUTR(K)/DZQ(k) - FALTNDI = FALOUTI(K)/DZQ(k) - FALTNDNI = FALOUTNI(K)/DZQ(k) - FALTNDS = FALOUTS(K)/DZQ(k) - FALTNDNS = FALOUTNS(K)/DZQ(k) - FALTNDNR = FALOUTNR(K)/DZQ(k) - FALTNDC = FALOUTC(K)/DZQ(k) - FALTNDNC = FALOUTNC(K)/DZQ(k) - FALTNDG = FALOUTG(K)/DZQ(k) - FALTNDNG = FALOUTNG(K)/DZQ(k) -! ADD FALLOUT TERMS TO EULERIAN TENDENCIES - - QRSTEN(K) = QRSTEN(K)-FALTNDR/NSTEP/RHO(k) - QISTEN(K) = QISTEN(K)-FALTNDI/NSTEP/RHO(k) - NI3DTEN(K) = NI3DTEN(K)-FALTNDNI/NSTEP/RHO(k) - QNISTEN(K) = QNISTEN(K)-FALTNDS/NSTEP/RHO(k) - NS3DTEN(K) = NS3DTEN(K)-FALTNDNS/NSTEP/RHO(k) - NR3DTEN(K) = NR3DTEN(K)-FALTNDNR/NSTEP/RHO(k) - QCSTEN(K) = QCSTEN(K)-FALTNDC/NSTEP/RHO(k) - NC3DTEN(K) = NC3DTEN(K)-FALTNDNC/NSTEP/RHO(k) - QGSTEN(K) = QGSTEN(K)-FALTNDG/NSTEP/RHO(k) - NG3DTEN(K) = NG3DTEN(K)-FALTNDNG/NSTEP/RHO(k) - - DUMR(K) = DUMR(K)-FALTNDR*DT/NSTEP - DUMI(K) = DUMI(K)-FALTNDI*DT/NSTEP - DUMFNI(K) = DUMFNI(K)-FALTNDNI*DT/NSTEP - DUMQS(K) = DUMQS(K)-FALTNDS*DT/NSTEP - DUMFNS(K) = DUMFNS(K)-FALTNDNS*DT/NSTEP - DUMFNR(K) = DUMFNR(K)-FALTNDNR*DT/NSTEP - DUMC(K) = DUMC(K)-FALTNDC*DT/NSTEP - DUMFNC(K) = DUMFNC(K)-FALTNDNC*DT/NSTEP - DUMG(K) = DUMG(K)-FALTNDG*DT/NSTEP - DUMFNG(K) = DUMFNG(K)-FALTNDNG*DT/NSTEP - - DO K = KTE-1,KTS,-1 - FALTNDR = (FALOUTR(K+1)-FALOUTR(K))/DZQ(K) - FALTNDI = (FALOUTI(K+1)-FALOUTI(K))/DZQ(K) - FALTNDNI = (FALOUTNI(K+1)-FALOUTNI(K))/DZQ(K) - FALTNDS = (FALOUTS(K+1)-FALOUTS(K))/DZQ(K) - FALTNDNS = (FALOUTNS(K+1)-FALOUTNS(K))/DZQ(K) - FALTNDNR = (FALOUTNR(K+1)-FALOUTNR(K))/DZQ(K) - FALTNDC = (FALOUTC(K+1)-FALOUTC(K))/DZQ(K) - FALTNDNC = (FALOUTNC(K+1)-FALOUTNC(K))/DZQ(K) - FALTNDG = (FALOUTG(K+1)-FALOUTG(K))/DZQ(K) - FALTNDNG = (FALOUTNG(K+1)-FALOUTNG(K))/DZQ(K) - -! ADD FALLOUT TERMS TO EULERIAN TENDENCIES - - QRSTEN(K) = QRSTEN(K)+FALTNDR/NSTEP/RHO(k) - QISTEN(K) = QISTEN(K)+FALTNDI/NSTEP/RHO(k) - NI3DTEN(K) = NI3DTEN(K)+FALTNDNI/NSTEP/RHO(k) - QNISTEN(K) = QNISTEN(K)+FALTNDS/NSTEP/RHO(k) - NS3DTEN(K) = NS3DTEN(K)+FALTNDNS/NSTEP/RHO(k) - NR3DTEN(K) = NR3DTEN(K)+FALTNDNR/NSTEP/RHO(k) - QCSTEN(K) = QCSTEN(K)+FALTNDC/NSTEP/RHO(k) - NC3DTEN(K) = NC3DTEN(K)+FALTNDNC/NSTEP/RHO(k) - QGSTEN(K) = QGSTEN(K)+FALTNDG/NSTEP/RHO(k) - NG3DTEN(K) = NG3DTEN(K)+FALTNDNG/NSTEP/RHO(k) - - DUMR(K) = DUMR(K)+FALTNDR*DT/NSTEP - DUMI(K) = DUMI(K)+FALTNDI*DT/NSTEP - DUMFNI(K) = DUMFNI(K)+FALTNDNI*DT/NSTEP - DUMQS(K) = DUMQS(K)+FALTNDS*DT/NSTEP - DUMFNS(K) = DUMFNS(K)+FALTNDNS*DT/NSTEP - DUMFNR(K) = DUMFNR(K)+FALTNDNR*DT/NSTEP - DUMC(K) = DUMC(K)+FALTNDC*DT/NSTEP - DUMFNC(K) = DUMFNC(K)+FALTNDNC*DT/NSTEP - DUMG(K) = DUMG(K)+FALTNDG*DT/NSTEP - DUMFNG(K) = DUMFNG(K)+FALTNDNG*DT/NSTEP - - END DO - -! GET PRECIPITATION AND SNOWFALL ACCUMULATION DURING THE TIME STEP -! FACTOR OF 1000 CONVERTS FROM M TO MM, BUT DIVISION BY DENSITY -! OF LIQUID WATER CANCELS THIS FACTOR OF 1000 - - PRECRT = PRECRT+(FALOUTR(KTS)+FALOUTC(KTS)+FALOUTS(KTS)+FALOUTI(KTS)+FALOUTG(KTS)) & - *DT/NSTEP - SNOWRT = SNOWRT+(FALOUTS(KTS)+FALOUTI(KTS)+FALOUTG(KTS))*DT/NSTEP - - END DO - - DO K=KTS,KTE - -! ADD ON SEDIMENTATION TENDENCIES FOR MIXING RATIO TO REST OF TENDENCIES - - QR3DTEN(K)=QR3DTEN(K)+QRSTEN(K) - QI3DTEN(K)=QI3DTEN(K)+QISTEN(K) - QC3DTEN(K)=QC3DTEN(K)+QCSTEN(K) - QG3DTEN(K)=QG3DTEN(K)+QGSTEN(K) - QNI3DTEN(K)=QNI3DTEN(K)+QNISTEN(K) - -! PUT ALL CLOUD ICE IN SNOW CATEGORY IF MEAN DIAMETER EXCEEDS 2 * dcs - - IF (QI3D(K).GE.QSMALL.AND.T3D(K).LT.273.15) THEN - IF (1./LAMI(K).GE.2.*DCS) THEN - QNI3DTEN(K) = QNI3DTEN(K)+QI3D(K)/DT+ QI3DTEN(K) - NS3DTEN(K) = NS3DTEN(K)+NI3D(K)/DT+ NI3DTEN(K) - QI3DTEN(K) = -QI3D(K)/DT - NI3DTEN(K) = -NI3D(K)/DT - END IF - END IF - -! hm add tendencies here, then call sizeparameter -! to ensure consisitency between mixing ratio and number concentration - - QC3D(k) = QC3D(k)+QC3DTEN(k)*DT - QI3D(k) = QI3D(k)+QI3DTEN(k)*DT - QNI3D(k) = QNI3D(k)+QNI3DTEN(k)*DT - QR3D(k) = QR3D(k)+QR3DTEN(k)*DT -! NC3D(k) = NC3D(k)+NC3DTEN(k)*DT - NI3D(k) = NI3D(k)+NI3DTEN(k)*DT - NS3D(k) = NS3D(k)+NS3DTEN(k)*DT - NR3D(k) = NR3D(k)+NR3DTEN(k)*DT - - IF (IGRAUP.EQ.0) THEN - QG3D(k) = QG3D(k)+QG3DTEN(k)*DT - NG3D(k) = NG3D(k)+NG3DTEN(k)*DT - END IF - -! ADD TEMPERATURE AND WATER VAPOR TENDENCIES FROM MICROPHYSICS - T3D(K) = T3D(K)+T3DTEN(k)*DT - QV3D(K) = QV3D(K)+QV3DTEN(k)*DT - -! SATURATION VAPOR PRESSURE AND MIXING RATIO - - EVS(K) = POLYSVP(T3D(K),0) ! PA - EIS(K) = POLYSVP(T3D(K),1) ! PA - -! MAKE SURE ICE SATURATION DOESN'T EXCEED WATER SAT. NEAR FREEZING - - IF (EIS(K).GT.EVS(K)) EIS(K) = EVS(K) - - QVS(K) = .622*EVS(K)/(PRES(K)-EVS(K)) - QVI(K) = .622*EIS(K)/(PRES(K)-EIS(K)) - - QVQVS(K) = QV3D(K)/QVS(K) - QVQVSI(K) = QV3D(K)/QVI(K) - -! AT SUBSATURATION, REMOVE SMALL AMOUNTS OF CLOUD/PRECIP WATER - - IF (QVQVS(K).LT.0.9) THEN - IF (QR3D(K).LT.1.E-6) THEN - QV3D(K)=QV3D(K)+QR3D(K) - T3D(K)=T3D(K)-QR3D(K)*XXLV(K)/CPM(K) - QR3D(K)=0. - END IF - IF (QC3D(K).LT.1.E-6) THEN - QV3D(K)=QV3D(K)+QC3D(K) - T3D(K)=T3D(K)-QC3D(K)*XXLV(K)/CPM(K) - QC3D(K)=0. - END IF - END IF - - IF (QVQVSI(K).LT.0.9) THEN - IF (QI3D(K).LT.1.E-6) THEN - QV3D(K)=QV3D(K)+QI3D(K) - T3D(K)=T3D(K)-QI3D(K)*XXLS(K)/CPM(K) - QI3D(K)=0. - END IF - IF (QNI3D(K).LT.1.E-6) THEN - QV3D(K)=QV3D(K)+QNI3D(K) - T3D(K)=T3D(K)-QNI3D(K)*XXLS(K)/CPM(K) - QNI3D(K)=0. - END IF - IF (QG3D(K).LT.1.E-6) THEN - QV3D(K)=QV3D(K)+QG3D(K) - T3D(K)=T3D(K)-QG3D(K)*XXLS(K)/CPM(K) - QG3D(K)=0. - END IF - END IF - -!.................................................................. -! IF MIXING RATIO < QSMALL SET MIXING RATIO AND NUMBER CONC TO ZERO - - IF (QC3D(K).LT.QSMALL) THEN - QC3D(K) = 0. - NC3D(K) = 0. - EFFC(K) = 0. - END IF - IF (QR3D(K).LT.QSMALL) THEN - QR3D(K) = 0. - NR3D(K) = 0. - EFFR(K) = 0. - END IF - IF (QI3D(K).LT.QSMALL) THEN - QI3D(K) = 0. - NI3D(K) = 0. - EFFI(K) = 0. - END IF - IF (QNI3D(K).LT.QSMALL) THEN - QNI3D(K) = 0. - NS3D(K) = 0. - EFFS(K) = 0. - END IF - IF (QG3D(K).LT.QSMALL) THEN - QG3D(K) = 0. - NG3D(K) = 0. - EFFG(K) = 0. - END IF - -!.................................. -! IF THERE IS NO CLOUD/PRECIP WATER, THEN SKIP CALCULATIONS - - IF (QC3D(K).LT.QSMALL.AND.QI3D(K).LT.QSMALL.AND.QNI3D(K).LT.QSMALL & - .AND.QR3D(K).LT.QSMALL.AND.QG3D(K).LT.QSMALL) GOTO 500 - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! CALCULATE INSTANTANEOUS PROCESSES - -! ADD MELTING OF CLOUD ICE TO FORM RAIN - - IF (QI3D(K).GE.QSMALL.AND.T3D(K).GE.273.15) THEN - QR3D(K) = QR3D(K)+QI3D(K) - T3D(K) = T3D(K)-QI3D(K)*XLF(K)/CPM(K) - QI3D(K) = 0. - NR3D(K) = NR3D(K)+NI3D(K) - NI3D(K) = 0. - END IF - -! ****SENSITIVITY - NO ICE - IF (ILIQ.EQ.1) GOTO 778 - -! HOMOGENEOUS FREEZING OF CLOUD WATER - - IF (T3D(K).LE.233.15.AND.QC3D(K).GE.QSMALL) THEN - QI3D(K)=QI3D(K)+QC3D(K) - T3D(K)=T3D(K)+QC3D(K)*XLF(K)/CPM(K) - QC3D(K)=0. - NI3D(K)=NI3D(K)+NC3D(K) - NC3D(K)=0. - END IF - -! HOMOGENEOUS FREEZING OF RAIN - - IF (IGRAUP.EQ.0) THEN - - IF (T3D(K).LE.233.15.AND.QR3D(K).GE.QSMALL) THEN - QG3D(K) = QG3D(K)+QR3D(K) - T3D(K) = T3D(K)+QR3D(K)*XLF(K)/CPM(K) - QR3D(K) = 0. - NG3D(K) = NG3D(K)+ NR3D(K) - NR3D(K) = 0. - END IF - - ELSE IF (IGRAUP.EQ.1) THEN - - IF (T3D(K).LE.233.15.AND.QR3D(K).GE.QSMALL) THEN - QNI3D(K) = QNI3D(K)+QR3D(K) - T3D(K) = T3D(K)+QR3D(K)*XLF(K)/CPM(K) - QR3D(K) = 0. - NS3D(K) = NS3D(K)+NR3D(K) - NR3D(K) = 0. - END IF - - END IF - - 778 CONTINUE - -! MAKE SURE NUMBER CONCENTRATIONS AREN'T NEGATIVE - - NI3D(K) = MAX(0.,NI3D(K)) - NS3D(K) = MAX(0.,NS3D(K)) - NC3D(K) = MAX(0.,NC3D(K)) - NR3D(K) = MAX(0.,NR3D(K)) - NG3D(K) = MAX(0.,NG3D(K)) - -!...................................................................... -! CLOUD ICE - - IF (QI3D(K).GE.QSMALL) THEN - LAMI(K) = (CONS12* & - NI3D(K)/QI3D(K))**(1./DI) - -! CHECK FOR SLOPE - -! ADJUST VARS - - IF (LAMI(K).LT.LAMMINI) THEN - - LAMI(K) = LAMMINI - - N0I(K) = LAMI(K)**4*QI3D(K)/CONS12 - - NI3D(K) = N0I(K)/LAMI(K) - ELSE IF (LAMI(K).GT.LAMMAXI) THEN - LAMI(K) = LAMMAXI - N0I(K) = LAMI(K)**4*QI3D(K)/CONS12 - - NI3D(K) = N0I(K)/LAMI(K) - END IF - END IF - -!...................................................................... -! RAIN - - IF (QR3D(K).GE.QSMALL) THEN - LAMR(K) = (PI*RHOW*NR3D(K)/QR3D(K))**(1./3.) - -! CHECK FOR SLOPE - -! ADJUST VARS - - IF (LAMR(K).LT.LAMMINR) THEN - - LAMR(K) = LAMMINR - - N0RR(K) = LAMR(K)**4*QR3D(K)/(PI*RHOW) - - NR3D(K) = N0RR(K)/LAMR(K) - ELSE IF (LAMR(K).GT.LAMMAXR) THEN - LAMR(K) = LAMMAXR - N0RR(K) = LAMR(K)**4*QR3D(K)/(PI*RHOW) - - NR3D(K) = N0RR(K)/LAMR(K) - END IF - - END IF - -!...................................................................... -! CLOUD DROPLETS - -! MARTIN ET AL. (1994) FORMULA FOR PGAM - - IF (QC3D(K).GE.QSMALL) THEN - - DUM = PRES(K)/(287.15*T3D(K)) - PGAM(K)=0.0005714*(NC3D(K)/1.E6/DUM)+0.2714 - PGAM(K)=1./(PGAM(K)**2)-1. - PGAM(K)=MAX(PGAM(K),2.) - PGAM(K)=MIN(PGAM(K),10.) - -! CALCULATE LAMC - - LAMC(K) = (CONS26*NC3D(K)*GAMMA(PGAM(K)+4.)/ & - (QC3D(K)*GAMMA(PGAM(K)+1.)))**(1./3.) - -! LAMMIN, 60 MICRON DIAMETER -! LAMMAX, 1 MICRON - - LAMMIN = (PGAM(K)+1.)/60.E-6 - LAMMAX = (PGAM(K)+1.)/1.E-6 - - IF (LAMC(K).LT.LAMMIN) THEN - LAMC(K) = LAMMIN - NC3D(K) = EXP(3.*LOG(LAMC(K))+LOG(QC3D(K))+ & - LOG(GAMMA(PGAM(K)+1.))-LOG(GAMMA(PGAM(K)+4.)))/CONS26 - - ELSE IF (LAMC(K).GT.LAMMAX) THEN - LAMC(K) = LAMMAX - NC3D(K) = EXP(3.*LOG(LAMC(K))+LOG(QC3D(K))+ & - LOG(GAMMA(PGAM(K)+1.))-LOG(GAMMA(PGAM(K)+4.)))/CONS26 - - END IF - - END IF - -!...................................................................... -! SNOW - - IF (QNI3D(K).GE.QSMALL) THEN - LAMS(K) = (CONS1*NS3D(K)/QNI3D(K))**(1./DS) - -! CHECK FOR SLOPE - -! ADJUST VARS - - IF (LAMS(K).LT.LAMMINS) THEN - LAMS(K) = LAMMINS - N0S(K) = LAMS(K)**4*QNI3D(K)/CONS1 - - NS3D(K) = N0S(K)/LAMS(K) - - ELSE IF (LAMS(K).GT.LAMMAXS) THEN - - LAMS(K) = LAMMAXS - N0S(K) = LAMS(K)**4*QNI3D(K)/CONS1 - NS3D(K) = N0S(K)/LAMS(K) - END IF - - END IF - -!...................................................................... -! GRAUPEL - - IF (QG3D(K).GE.QSMALL) THEN - LAMG(K) = (CONS2*NG3D(K)/QG3D(K))**(1./DG) - -! CHECK FOR SLOPE - -! ADJUST VARS - - IF (LAMG(K).LT.LAMMING) THEN - LAMG(K) = LAMMING - N0G(K) = LAMG(K)**4*QG3D(K)/CONS2 - - NG3D(K) = N0G(K)/LAMG(K) - - ELSE IF (LAMG(K).GT.LAMMAXG) THEN - - LAMG(K) = LAMMAXG - N0G(K) = LAMG(K)**4*QG3D(K)/CONS2 - - NG3D(K) = N0G(K)/LAMG(K) - END IF - - END IF - - 500 CONTINUE - -! CALCULATE EFFECTIVE RADIUS - - IF (QI3D(K).GE.QSMALL) THEN - EFFI(K) = 3./LAMI(K)/2.*1.E6 - ELSE - EFFI(K) = 25. - END IF - - IF (QNI3D(K).GE.QSMALL) THEN - EFFS(K) = 3./LAMS(K)/2.*1.E6 - ELSE - EFFS(K) = 25. - END IF - - IF (QR3D(K).GE.QSMALL) THEN - EFFR(K) = 3./LAMR(K)/2.*1.E6 - ELSE - EFFR(K) = 25. - END IF - - IF (QC3D(K).GE.QSMALL) THEN - EFFC(K) = GAMMA(PGAM(K)+4.)/ & - GAMMA(PGAM(K)+3.)/LAMC(K)/2.*1.E6 - ELSE - EFFC(K) = 25. - END IF - - IF (QG3D(K).GE.QSMALL) THEN - EFFG(K) = 3./LAMG(K)/2.*1.E6 - ELSE - EFFG(K) = 25. - END IF - -! HM ADD 1/10/06, ADD UPPER BOUND ON ICE NUMBER, THIS IS NEEDED -! TO PREVENT VERY LARGE ICE NUMBER DUE TO HOMOGENEOUS FREEZING -! OF DROPLETS, ESPECIALLY WHEN INUM = 1, SET MAX AT 10 CM-3 - NI3D(K) = MIN(NI3D(K),10.E6/RHO(K)) -! ADD BOUND ON DROPLET NUMBER - CANNOT EXCEED AEROSOL CONCENTRATION - IF (INUM.EQ.0.AND.IACT.EQ.2) THEN - NC3D(K) = MIN(NC3D(K),(NANEW1+NANEW2)/RHO(K)) - END IF -! SWITCH FOR CONSTANT DROPLET NUMBER -! IF (INUM.EQ.1) THEN -! CHANGE NDCNST FROM CM-3 TO KG-1 - NC3D(K) = NDCNST*1.E6/RHO(K) -! END IF - - END DO !!! K LOOP - - 400 CONTINUE - -! ALL DONE !!!!!!!!!!! - RETURN - END SUBROUTINE MORR_TWO_MOMENT_MICRO - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - - REAL FUNCTION POLYSVP (T,TYPE) - -!------------------------------------------- - -! COMPUTE SATURATION VAPOR PRESSURE - -! POLYSVP RETURNED IN UNITS OF PA. -! T IS INPUT IN UNITS OF K. -! TYPE REFERS TO SATURATION WITH RESPECT TO LIQUID (0) OR ICE (1) - -! REPLACE GOFF-GRATCH WITH FASTER FORMULATION FROM MARAT KHROUTDINOV - - IMPLICIT NONE - - REAL DUM - REAL T - INTEGER TYPE -! ice - real a0i,a1i,a2i,a3i,a4i,a5i,a6i,a7i,a8i - data a0i,a1i,a2i,a3i,a4i,a5i,a6i,a7i,a8i /& - 6.11147274, 0.503160820, 0.188439774e-1, & - 0.420895665e-3, 0.615021634e-5,0.602588177e-7, & - 0.385852041e-9, 0.146898966e-11, 0.252751365e-14/ - -! liquid - real a0,a1,a2,a3,a4,a5,a6,a7,a8 - data a0,a1,a2,a3,a4,a5,a6,a7,a8 /& - 6.105851, 0.4440316, 0.1430341e-1, & - 0.2641412e-3, 0.2995057e-5, 0.2031998e-7, & - 0.6936113e-10, 0.2564861e-13,-0.3704404e-15/ - real dt - -! ICE - - IF (TYPE.EQ.1) THEN - -! POLYSVP = 10.**(-9.09718*(273.16/T-1.)-3.56654* & -! LOG10(273.16/T)+0.876793*(1.-T/273.16)+ & -! LOG10(6.1071))*100. - - - dt = max(-80.,t-273.16) - polysvp = a0i + dt*(a1i+dt*(a2i+dt*(a3i+dt*(a4i+dt*(a5i+dt*(a6i+dt*(a7i+a8i*dt))))))) - polysvp = polysvp*100. - - END IF - -! LIQUID - - IF (TYPE.EQ.0) THEN - - dt = max(-80.,t-273.16) - polysvp = a0 + dt*(a1+dt*(a2+dt*(a3+dt*(a4+dt*(a5+dt*(a6+dt*(a7+a8*dt))))))) - polysvp = polysvp*100. - -! POLYSVP = 10.**(-7.90298*(373.16/T-1.)+ & -! 5.02808*LOG10(373.16/T)- & -! 1.3816E-7*(10**(11.344*(1.-T/373.16))-1.)+ & -! 8.1328E-3*(10**(-3.49149*(373.16/T-1.))-1.)+ & -! LOG10(1013.246))*100. - - END IF - - - END FUNCTION POLYSVP - -!------------------------------------------------------------------------------ - - REAL FUNCTION GAMMA(X) -!---------------------------------------------------------------------- -! -! THIS ROUTINE CALCULATES THE GAMMA FUNCTION FOR A REAL ARGUMENT X. -! COMPUTATION IS BASED ON AN ALGORITHM OUTLINED IN REFERENCE 1. -! THE PROGRAM USES RATIONAL FUNCTIONS THAT APPROXIMATE THE GAMMA -! FUNCTION TO AT LEAST 20 SIGNIFICANT DECIMAL DIGITS. COEFFICIENTS -! FOR THE APPROXIMATION OVER THE INTERVAL (1,2) ARE UNPUBLISHED. -! THOSE FOR THE APPROXIMATION FOR X .GE. 12 ARE FROM REFERENCE 2. -! THE ACCURACY ACHIEVED DEPENDS ON THE ARITHMETIC SYSTEM, THE -! COMPILER, THE INTRINSIC FUNCTIONS, AND PROPER SELECTION OF THE -! MACHINE-DEPENDENT CONSTANTS. -! -! -!******************************************************************* -!******************************************************************* -! -! EXPLANATION OF MACHINE-DEPENDENT CONSTANTS -! -! BETA - RADIX FOR THE FLOATING-POINT REPRESENTATION -! MAXEXP - THE SMALLEST POSITIVE POWER OF BETA THAT OVERFLOWS -! XBIG - THE LARGEST ARGUMENT FOR WHICH GAMMA(X) IS REPRESENTABLE -! IN THE MACHINE, I.E., THE SOLUTION TO THE EQUATION -! GAMMA(XBIG) = BETA**MAXEXP -! XINF - THE LARGEST MACHINE REPRESENTABLE FLOATING-POINT NUMBER; -! APPROXIMATELY BETA**MAXEXP -! EPS - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT -! 1.0+EPS .GT. 1.0 -! XMININ - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT -! 1/XMININ IS MACHINE REPRESENTABLE -! -! APPROXIMATE VALUES FOR SOME IMPORTANT MACHINES ARE: -! -! BETA MAXEXP XBIG -! -! CRAY-1 (S.P.) 2 8191 966.961 -! CYBER 180/855 -! UNDER NOS (S.P.) 2 1070 177.803 -! IEEE (IBM/XT, -! SUN, ETC.) (S.P.) 2 128 35.040 -! IEEE (IBM/XT, -! SUN, ETC.) (D.P.) 2 1024 171.624 -! IBM 3033 (D.P.) 16 63 57.574 -! VAX D-FORMAT (D.P.) 2 127 34.844 -! VAX G-FORMAT (D.P.) 2 1023 171.489 -! -! XINF EPS XMININ -! -! CRAY-1 (S.P.) 5.45E+2465 7.11E-15 1.84E-2466 -! CYBER 180/855 -! UNDER NOS (S.P.) 1.26E+322 3.55E-15 3.14E-294 -! IEEE (IBM/XT, -! SUN, ETC.) (S.P.) 3.40E+38 1.19E-7 1.18E-38 -! IEEE (IBM/XT, -! SUN, ETC.) (D.P.) 1.79D+308 2.22D-16 2.23D-308 -! IBM 3033 (D.P.) 7.23D+75 2.22D-16 1.39D-76 -! VAX D-FORMAT (D.P.) 1.70D+38 1.39D-17 5.88D-39 -! VAX G-FORMAT (D.P.) 8.98D+307 1.11D-16 1.12D-308 -! -!******************************************************************* -!******************************************************************* -! -! ERROR RETURNS -! -! THE PROGRAM RETURNS THE VALUE XINF FOR SINGULARITIES OR -! WHEN OVERFLOW WOULD OCCUR. THE COMPUTATION IS BELIEVED -! TO BE FREE OF UNDERFLOW AND OVERFLOW. -! -! -! INTRINSIC FUNCTIONS REQUIRED ARE: -! -! INT, DBLE, EXP, LOG, REAL, SIN -! -! -! REFERENCES: AN OVERVIEW OF SOFTWARE DEVELOPMENT FOR SPECIAL -! FUNCTIONS W. J. CODY, LECTURE NOTES IN MATHEMATICS, -! 506, NUMERICAL ANALYSIS DUNDEE, 1975, G. A. WATSON -! (ED.), SPRINGER VERLAG, BERLIN, 1976. -! -! COMPUTER APPROXIMATIONS, HART, ET. AL., WILEY AND -! SONS, NEW YORK, 1968. -! -! LATEST MODIFICATION: OCTOBER 12, 1989 -! -! AUTHORS: W. J. CODY AND L. STOLTZ -! APPLIED MATHEMATICS DIVISION -! ARGONNE NATIONAL LABORATORY -! ARGONNE, IL 60439 -! -!---------------------------------------------------------------------- - implicit none - INTEGER I,N - LOGICAL PARITY - REAL & - CONV,EPS,FACT,HALF,ONE,RES,SUM,TWELVE, & - TWO,X,XBIG,XDEN,XINF,XMININ,XNUM,Y,Y1,YSQ,Z,ZERO - REAL, DIMENSION(7) :: C - REAL, DIMENSION(8) :: P - REAL, DIMENSION(8) :: Q -!---------------------------------------------------------------------- -! MATHEMATICAL CONSTANTS -!---------------------------------------------------------------------- - DATA ONE,HALF,TWELVE,TWO,ZERO/1.0E0,0.5E0,12.0E0,2.0E0,0.0E0/ - - -!---------------------------------------------------------------------- -! MACHINE DEPENDENT PARAMETERS -!---------------------------------------------------------------------- - DATA XBIG,XMININ,EPS/35.040E0,1.18E-38,1.19E-7/,XINF/3.4E38/ -!---------------------------------------------------------------------- -! NUMERATOR AND DENOMINATOR COEFFICIENTS FOR RATIONAL MINIMAX -! APPROXIMATION OVER (1,2). -!---------------------------------------------------------------------- - DATA P/-1.71618513886549492533811E+0,2.47656508055759199108314E+1, & - -3.79804256470945635097577E+2,6.29331155312818442661052E+2, & - 8.66966202790413211295064E+2,-3.14512729688483675254357E+4, & - -3.61444134186911729807069E+4,6.64561438202405440627855E+4/ - DATA Q/-3.08402300119738975254353E+1,3.15350626979604161529144E+2, & - -1.01515636749021914166146E+3,-3.10777167157231109440444E+3, & - 2.25381184209801510330112E+4,4.75584627752788110767815E+3, & - -1.34659959864969306392456E+5,-1.15132259675553483497211E+5/ -!---------------------------------------------------------------------- -! COEFFICIENTS FOR MINIMAX APPROXIMATION OVER (12, INF). -!---------------------------------------------------------------------- - DATA C/-1.910444077728E-03,8.4171387781295E-04, & - -5.952379913043012E-04,7.93650793500350248E-04, & - -2.777777777777681622553E-03,8.333333333333333331554247E-02, & - 5.7083835261E-03/ -!---------------------------------------------------------------------- -! STATEMENT FUNCTIONS FOR CONVERSION BETWEEN INTEGER AND FLOAT -!---------------------------------------------------------------------- - CONV(I) = REAL(I) - PARITY=.FALSE. - FACT=ONE - N=0 - Y=X - IF(Y.LE.ZERO)THEN -!---------------------------------------------------------------------- -! ARGUMENT IS NEGATIVE -!---------------------------------------------------------------------- - Y=-X - Y1=AINT(Y) - RES=Y-Y1 - IF(RES.NE.ZERO)THEN - IF(Y1.NE.AINT(Y1*HALF)*TWO)PARITY=.TRUE. - FACT=-PI/SIN(PI*RES) - Y=Y+ONE - ELSE - RES=XINF - GOTO 900 - ENDIF - ENDIF -!---------------------------------------------------------------------- -! ARGUMENT IS POSITIVE -!---------------------------------------------------------------------- - IF(Y.LT.EPS)THEN -!---------------------------------------------------------------------- -! ARGUMENT .LT. EPS -!---------------------------------------------------------------------- - IF(Y.GE.XMININ)THEN - RES=ONE/Y - ELSE - RES=XINF - GOTO 900 - ENDIF - ELSEIF(Y.LT.TWELVE)THEN - Y1=Y - IF(Y.LT.ONE)THEN -!---------------------------------------------------------------------- -! 0.0 .LT. ARGUMENT .LT. 1.0 -!---------------------------------------------------------------------- - Z=Y - Y=Y+ONE - ELSE -!---------------------------------------------------------------------- -! 1.0 .LT. ARGUMENT .LT. 12.0, REDUCE ARGUMENT IF NECESSARY -!---------------------------------------------------------------------- - N=INT(Y)-1 - Y=Y-CONV(N) - Z=Y-ONE - ENDIF -!---------------------------------------------------------------------- -! EVALUATE APPROXIMATION FOR 1.0 .LT. ARGUMENT .LT. 2.0 -!---------------------------------------------------------------------- - XNUM=ZERO - XDEN=ONE - DO I=1,8 - XNUM=(XNUM+P(I))*Z - XDEN=XDEN*Z+Q(I) - END DO - RES=XNUM/XDEN+ONE - IF(Y1.LT.Y)THEN -!---------------------------------------------------------------------- -! ADJUST RESULT FOR CASE 0.0 .LT. ARGUMENT .LT. 1.0 -!---------------------------------------------------------------------- - RES=RES/Y1 - ELSEIF(Y1.GT.Y)THEN -!---------------------------------------------------------------------- -! ADJUST RESULT FOR CASE 2.0 .LT. ARGUMENT .LT. 12.0 -!---------------------------------------------------------------------- - DO I=1,N - RES=RES*Y - Y=Y+ONE - END DO - ENDIF - ELSE -!---------------------------------------------------------------------- -! EVALUATE FOR ARGUMENT .GE. 12.0, -!---------------------------------------------------------------------- - IF(Y.LE.XBIG)THEN - YSQ=Y*Y - SUM=C(7) - DO I=1,6 - SUM=SUM/YSQ+C(I) - END DO - SUM=SUM/Y-Y+SQRTPI - SUM=SUM+(Y-HALF)*LOG(Y) - RES=EXP(SUM) - ELSE - RES=XINF - GOTO 900 - ENDIF - ENDIF -!---------------------------------------------------------------------- -! FINAL ADJUSTMENTS AND RETURN -!---------------------------------------------------------------------- - IF(PARITY)RES=-RES - IF(FACT.NE.ONE)RES=FACT/RES - 900 GAMMA=RES - RETURN -! ---------- LAST LINE OF GAMMA ---------- - END FUNCTION GAMMA - - - REAL FUNCTION DERF1(X) - IMPLICIT NONE - REAL X - REAL, DIMENSION(0 : 64) :: A, B - REAL W,T,Y - INTEGER K,I - DATA A/ & - 0.00000000005958930743E0, -0.00000000113739022964E0, & - 0.00000001466005199839E0, -0.00000016350354461960E0, & - 0.00000164610044809620E0, -0.00001492559551950604E0, & - 0.00012055331122299265E0, -0.00085483269811296660E0, & - 0.00522397762482322257E0, -0.02686617064507733420E0, & - 0.11283791670954881569E0, -0.37612638903183748117E0, & - 1.12837916709551257377E0, & - 0.00000000002372510631E0, -0.00000000045493253732E0, & - 0.00000000590362766598E0, -0.00000006642090827576E0, & - 0.00000067595634268133E0, -0.00000621188515924000E0, & - 0.00005103883009709690E0, -0.00037015410692956173E0, & - 0.00233307631218880978E0, -0.01254988477182192210E0, & - 0.05657061146827041994E0, -0.21379664776456006580E0, & - 0.84270079294971486929E0, & - 0.00000000000949905026E0, -0.00000000018310229805E0, & - 0.00000000239463074000E0, -0.00000002721444369609E0, & - 0.00000028045522331686E0, -0.00000261830022482897E0, & - 0.00002195455056768781E0, -0.00016358986921372656E0, & - 0.00107052153564110318E0, -0.00608284718113590151E0, & - 0.02986978465246258244E0, -0.13055593046562267625E0, & - 0.67493323603965504676E0, & - 0.00000000000382722073E0, -0.00000000007421598602E0, & - 0.00000000097930574080E0, -0.00000001126008898854E0, & - 0.00000011775134830784E0, -0.00000111992758382650E0, & - 0.00000962023443095201E0, -0.00007404402135070773E0, & - 0.00050689993654144881E0, -0.00307553051439272889E0, & - 0.01668977892553165586E0, -0.08548534594781312114E0, & - 0.56909076642393639985E0, & - 0.00000000000155296588E0, -0.00000000003032205868E0, & - 0.00000000040424830707E0, -0.00000000471135111493E0, & - 0.00000005011915876293E0, -0.00000048722516178974E0, & - 0.00000430683284629395E0, -0.00003445026145385764E0, & - 0.00024879276133931664E0, -0.00162940941748079288E0, & - 0.00988786373932350462E0, -0.05962426839442303805E0, & - 0.49766113250947636708E0 / - DATA (B(I), I = 0, 12) / & - -0.00000000029734388465E0, 0.00000000269776334046E0, & - -0.00000000640788827665E0, -0.00000001667820132100E0, & - -0.00000021854388148686E0, 0.00000266246030457984E0, & - 0.00001612722157047886E0, -0.00025616361025506629E0, & - 0.00015380842432375365E0, 0.00815533022524927908E0, & - -0.01402283663896319337E0, -0.19746892495383021487E0, & - 0.71511720328842845913E0 / - DATA (B(I), I = 13, 25) / & - -0.00000000001951073787E0, -0.00000000032302692214E0, & - 0.00000000522461866919E0, 0.00000000342940918551E0, & - -0.00000035772874310272E0, 0.00000019999935792654E0, & - 0.00002687044575042908E0, -0.00011843240273775776E0, & - -0.00080991728956032271E0, 0.00661062970502241174E0, & - 0.00909530922354827295E0, -0.20160072778491013140E0, & - 0.51169696718727644908E0 / - DATA (B(I), I = 26, 38) / & - 0.00000000003147682272E0, -0.00000000048465972408E0, & - 0.00000000063675740242E0, 0.00000003377623323271E0, & - -0.00000015451139637086E0, -0.00000203340624738438E0, & - 0.00001947204525295057E0, 0.00002854147231653228E0, & - -0.00101565063152200272E0, 0.00271187003520095655E0, & - 0.02328095035422810727E0, -0.16725021123116877197E0, & - 0.32490054966649436974E0 / - DATA (B(I), I = 39, 51) / & - 0.00000000002319363370E0, -0.00000000006303206648E0, & - -0.00000000264888267434E0, 0.00000002050708040581E0, & - 0.00000011371857327578E0, -0.00000211211337219663E0, & - 0.00000368797328322935E0, 0.00009823686253424796E0, & - -0.00065860243990455368E0, -0.00075285814895230877E0, & - 0.02585434424202960464E0, -0.11637092784486193258E0, & - 0.18267336775296612024E0 / - DATA (B(I), I = 52, 64) / & - -0.00000000000367789363E0, 0.00000000020876046746E0, & - -0.00000000193319027226E0, -0.00000000435953392472E0, & - 0.00000018006992266137E0, -0.00000078441223763969E0, & - -0.00000675407647949153E0, 0.00008428418334440096E0, & - -0.00017604388937031815E0, -0.00239729611435071610E0, & - 0.02064129023876022970E0, -0.06905562880005864105E0, & - 0.09084526782065478489E0 / - W = ABS(X) - IF (W .LT. 2.2D0) THEN - T = W * W - K = INT(T) - T = T - K - K = K * 13 - Y = ((((((((((((A(K) * T + A(K + 1)) * T + & - A(K + 2)) * T + A(K + 3)) * T + A(K + 4)) * T + & - A(K + 5)) * T + A(K + 6)) * T + A(K + 7)) * T + & - A(K + 8)) * T + A(K + 9)) * T + A(K + 10)) * T + & - A(K + 11)) * T + A(K + 12)) * W - ELSE IF (W .LT. 6.9D0) THEN - K = INT(W) - T = W - K - K = 13 * (K - 2) - Y = (((((((((((B(K) * T + B(K + 1)) * T + & - B(K + 2)) * T + B(K + 3)) * T + B(K + 4)) * T + & - B(K + 5)) * T + B(K + 6)) * T + B(K + 7)) * T + & - B(K + 8)) * T + B(K + 9)) * T + B(K + 10)) * T + & - B(K + 11)) * T + B(K + 12) - Y = Y * Y - Y = Y * Y - Y = Y * Y - Y = 1 - Y * Y - ELSE - Y = 1 - END IF - IF (X .LT. 0) Y = -Y - DERF1 = Y - END FUNCTION DERF1 - -!+---+-----------------------------------------------------------------+ - -END MODULE module_mp_morr_two_moment diff --git a/src/fim/FIMsrc/fim/wrfphys/module_mp_thompson.F b/src/fim/FIMsrc/fim/wrfphys/module_mp_thompson.F deleted file mode 100644 index 1d13a65..0000000 --- a/src/fim/FIMsrc/fim/wrfphys/module_mp_thompson.F +++ /dev/null @@ -1,3426 +0,0 @@ -!+---+-----------------------------------------------------------------+ -!.. This subroutine computes the moisture tendencies of water vapor, -!.. cloud droplets, rain, cloud ice (pristine), snow, and graupel. -!.. Prior to WRFv2.2 this code was based on Reisner et al (1998), but -!.. few of those pieces remain. A complete description is now found in -!.. Thompson, G., P. R. Field, R. M. Rasmussen, and W. D. Hall, 2008: -!.. Explicit Forecasts of winter precipitation using an improved bulk -!.. microphysics scheme. Part II: Implementation of a new snow -!.. parameterization. Mon. Wea. Rev., 136, 5095-5115. -!.. Prior to WRFv3.1, this code was single-moment rain prediction as -!.. described in the reference above, but in v3.1 and higher, the -!.. scheme is two-moment rain (predicted rain number concentration). -!.. -!.. Most importantly, users may wish to modify the prescribed number of -!.. cloud droplets (Nt_c; see guidelines mentioned below). Otherwise, -!.. users may alter the rain and graupel size distribution parameters -!.. to use exponential (Marshal-Palmer) or generalized gamma shape. -!.. The snow field assumes a combination of two gamma functions (from -!.. Field et al. 2005) and would require significant modifications -!.. throughout the entire code to alter its shape as well as accretion -!.. rates. Users may also alter the constants used for density of rain, -!.. graupel, ice, and snow, but the latter is not constant when using -!.. Paul Field's snow distribution and moments methods. Other values -!.. users can modify include the constants for mass and/or velocity -!.. power law relations and assumed capacitances used in deposition/ -!.. sublimation/evaporation/melting. -!.. Remaining values should probably be left alone. -!.. -!..Author: Greg Thompson, NCAR-RAL, gthompsn@ucar.edu, 303-497-2805 -!..Last modified: 30 Jan 2009 -!+---+-----------------------------------------------------------------+ -!wrft:model_layer:physics -!+---+-----------------------------------------------------------------+ -! - MODULE module_mp_thompson - -! USE module_wrf_error -! USE module_utility, ONLY: WRFU_Clock, WRFU_Alarm -! USE module_domain, ONLY : HISTORY_ALARM, Is_alarm_tstep - - IMPLICIT NONE - - LOGICAL, PARAMETER, PRIVATE:: iiwarm = .false. - INTEGER, PARAMETER, PRIVATE:: IFDRY = 0 - REAL, PARAMETER, PRIVATE:: T_0 = 273.15 - REAL, PARAMETER, PRIVATE:: PI = 3.1415926536 - -!..Densities of rain, snow, graupel, and cloud ice. - REAL, PARAMETER, PRIVATE:: rho_w = 1000.0 - REAL, PARAMETER, PRIVATE:: rho_s = 100.0 - REAL, PARAMETER, PRIVATE:: rho_g = 400.0 - REAL, PARAMETER, PRIVATE:: rho_i = 890.0 - -!..Prescribed number of cloud droplets. Set according to known data or -!.. roughly 100 per cc (100.E6 m^-3) for Maritime cases and -!.. 300 per cc (300.E6 m^-3) for Continental. Gamma shape parameter, -!.. mu_c, calculated based on Nt_c is important in autoconversion -!.. scheme. - REAL, PARAMETER, PRIVATE:: Nt_c = 100.E6 - -!..Generalized gamma distributions for rain, graupel and cloud ice. -!.. N(D) = N_0 * D**mu * exp(-lamda*D); mu=0 is exponential. - REAL, PARAMETER, PRIVATE:: mu_r = 0.0 - REAL, PARAMETER, PRIVATE:: mu_g = 0.0 - REAL, PARAMETER, PRIVATE:: mu_i = 0.0 - REAL, PRIVATE:: mu_c - -!..Sum of two gamma distrib for snow (Field et al. 2005). -!.. N(D) = M2**4/M3**3 * [Kap0*exp(-M2*Lam0*D/M3) -!.. + Kap1*(M2/M3)**mu_s * D**mu_s * exp(-M2*Lam1*D/M3)] -!.. M2 and M3 are the (bm_s)th and (bm_s+1)th moments respectively -!.. calculated as function of ice water content and temperature. - REAL, PARAMETER, PRIVATE:: mu_s = 0.6357 - REAL, PARAMETER, PRIVATE:: Kap0 = 490.6 - REAL, PARAMETER, PRIVATE:: Kap1 = 17.46 - REAL, PARAMETER, PRIVATE:: Lam0 = 20.78 - REAL, PARAMETER, PRIVATE:: Lam1 = 3.29 - -!..Y-intercept parameter for graupel is not constant and depends on -!.. mixing ratio. Also, when mu_g is non-zero, these become equiv -!.. y-intercept for an exponential distrib and proper values are -!.. computed based on same mixing ratio and total number concentration. - REAL, PARAMETER, PRIVATE:: gonv_min = 1.E4 - REAL, PARAMETER, PRIVATE:: gonv_max = 5.E6 - -!..Mass power law relations: mass = am*D**bm -!.. Snow from Field et al. (2005), others assume spherical form. - REAL, PARAMETER, PRIVATE:: am_r = PI*rho_w/6.0 - REAL, PARAMETER, PRIVATE:: bm_r = 3.0 - REAL, PARAMETER, PRIVATE:: am_s = 0.069 - REAL, PARAMETER, PRIVATE:: bm_s = 2.0 - REAL, PARAMETER, PRIVATE:: am_g = PI*rho_g/6.0 - REAL, PARAMETER, PRIVATE:: bm_g = 3.0 - REAL, PARAMETER, PRIVATE:: am_i = PI*rho_i/6.0 - REAL, PARAMETER, PRIVATE:: bm_i = 3.0 - -!..Fallspeed power laws relations: v = (av*D**bv)*exp(-fv*D) -!.. Rain from Ferrier (1994), ice, snow, and graupel from -!.. Thompson et al (2008). Coefficient fv is zero for graupel/ice. - REAL, PARAMETER, PRIVATE:: av_r = 4854.0 - REAL, PARAMETER, PRIVATE:: bv_r = 1.0 - REAL, PARAMETER, PRIVATE:: fv_r = 195.0 - REAL, PARAMETER, PRIVATE:: av_s = 40.0 - REAL, PARAMETER, PRIVATE:: bv_s = 0.55 - REAL, PARAMETER, PRIVATE:: fv_s = 125.0 - REAL, PARAMETER, PRIVATE:: av_g = 442.0 - REAL, PARAMETER, PRIVATE:: bv_g = 0.89 - REAL, PARAMETER, PRIVATE:: av_i = 1847.5 - REAL, PARAMETER, PRIVATE:: bv_i = 1.0 - -!..Capacitance of sphere and plates/aggregates: D**3, D**2 - REAL, PARAMETER, PRIVATE:: C_cube = 0.5 - REAL, PARAMETER, PRIVATE:: C_sqrd = 0.3 - -!..Collection efficiencies. Rain/snow/graupel collection of cloud -!.. droplets use variables (Ef_rw, Ef_sw, Ef_gw respectively) and -!.. get computed elsewhere because they are dependent on stokes -!.. number. - REAL, PARAMETER, PRIVATE:: Ef_si = 0.05 - REAL, PARAMETER, PRIVATE:: Ef_rs = 0.95 - REAL, PARAMETER, PRIVATE:: Ef_rg = 0.95 - REAL, PARAMETER, PRIVATE:: Ef_ri = 0.95 - -!..Minimum microphys values -!.. R1 value, 1.E-12, cannot be set lower because of numerical -!.. problems with Paul Field's moments and should not be set larger -!.. because of truncation problems in snow/ice growth. - REAL, PARAMETER, PRIVATE:: R1 = 1.E-12 - REAL, PARAMETER, PRIVATE:: R2 = 1.E-8 - REAL, PARAMETER, PRIVATE:: eps = 1.E-29 - -!..Constants in Cooper curve relation for cloud ice number. - REAL, PARAMETER, PRIVATE:: TNO = 5.0 * 0.2 - REAL, PARAMETER, PRIVATE:: ATO = 0.304 - -!..Rho_not used in fallspeed relations (rho_not/rho)**.5 adjustment. - REAL, PARAMETER, PRIVATE:: rho_not = 101325.0/(287.05*298.0) - -!..Schmidt number - REAL, PARAMETER, PRIVATE:: Sc = 0.632 - REAL, PRIVATE:: Sc3 - -!..Homogeneous freezing temperature - REAL, PARAMETER, PRIVATE:: HGFR = 235.16 - -!..Water vapor and air gas constants at constant pressure - REAL, PARAMETER, PRIVATE:: Rv = 461.5 - REAL, PARAMETER, PRIVATE:: oRv = 1./Rv - REAL, PARAMETER, PRIVATE:: R = 287.04 - REAL, PARAMETER, PRIVATE:: Cp = 1004.0 - -!..Enthalpy of sublimation, vaporization, and fusion at 0C. - REAL, PARAMETER, PRIVATE:: lsub = 2.834E6 - REAL, PARAMETER, PRIVATE:: lvap0 = 2.5E6 - REAL, PARAMETER, PRIVATE:: lfus = lsub - lvap0 - REAL, PARAMETER, PRIVATE:: olfus = 1./lfus - -!..Ice initiates with this mass (kg), corresponding diameter calc. -!..Min diameters and mass of cloud, rain, snow, and graupel (m, kg). - REAL, PARAMETER, PRIVATE:: xm0i = 1.E-12 - REAL, PARAMETER, PRIVATE:: D0c = 1.E-6 - REAL, PARAMETER, PRIVATE:: D0r = 50.E-6 - REAL, PARAMETER, PRIVATE:: D0s = 200.E-6 - REAL, PARAMETER, PRIVATE:: D0g = 250.E-6 - REAL, PRIVATE:: D0i, xm0s, xm0g - -!..Lookup table dimensions - INTEGER, PARAMETER, PRIVATE:: nbins = 100 - INTEGER, PARAMETER, PRIVATE:: nbc = nbins - INTEGER, PARAMETER, PRIVATE:: nbi = nbins - INTEGER, PARAMETER, PRIVATE:: nbr = nbins - INTEGER, PARAMETER, PRIVATE:: nbs = nbins - INTEGER, PARAMETER, PRIVATE:: nbg = nbins - INTEGER, PARAMETER, PRIVATE:: ntb_c = 37 - INTEGER, PARAMETER, PRIVATE:: ntb_i = 64 - INTEGER, PARAMETER, PRIVATE:: ntb_r = 37 - INTEGER, PARAMETER, PRIVATE:: ntb_s = 28 - INTEGER, PARAMETER, PRIVATE:: ntb_g = 28 - INTEGER, PARAMETER, PRIVATE:: ntb_r1 = 37 - INTEGER, PARAMETER, PRIVATE:: ntb_i1 = 55 - INTEGER, PARAMETER, PRIVATE:: ntb_t = 9 - INTEGER, PRIVATE:: nic2, nii2, nii3, nir2, nir3, nis2, nig2 - - DOUBLE PRECISION, DIMENSION(nbins+1):: xDx - DOUBLE PRECISION, DIMENSION(nbc):: Dc, dtc - DOUBLE PRECISION, DIMENSION(nbi):: Di, dti - DOUBLE PRECISION, DIMENSION(nbr):: Dr, dtr - DOUBLE PRECISION, DIMENSION(nbs):: Ds, dts - DOUBLE PRECISION, DIMENSION(nbg):: Dg, dtg - -!..Lookup tables for cloud water content (kg/m**3). - REAL, DIMENSION(ntb_c), PARAMETER, PRIVATE:: & - r_c = (/1.e-6,2.e-6,3.e-6,4.e-6,5.e-6,6.e-6,7.e-6,8.e-6,9.e-6, & - 1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & - 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & - 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, & - 1.e-2/) - -!..Lookup tables for cloud ice content (kg/m**3). - REAL, DIMENSION(ntb_i), PARAMETER, PRIVATE:: & - r_i = (/1.e-10,2.e-10,3.e-10,4.e-10, & - 5.e-10,6.e-10,7.e-10,8.e-10,9.e-10, & - 1.e-9,2.e-9,3.e-9,4.e-9,5.e-9,6.e-9,7.e-9,8.e-9,9.e-9, & - 1.e-8,2.e-8,3.e-8,4.e-8,5.e-8,6.e-8,7.e-8,8.e-8,9.e-8, & - 1.e-7,2.e-7,3.e-7,4.e-7,5.e-7,6.e-7,7.e-7,8.e-7,9.e-7, & - 1.e-6,2.e-6,3.e-6,4.e-6,5.e-6,6.e-6,7.e-6,8.e-6,9.e-6, & - 1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & - 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & - 1.e-3/) - -!..Lookup tables for rain content (kg/m**3). - REAL, DIMENSION(ntb_r), PARAMETER, PRIVATE:: & - r_r = (/1.e-6,2.e-6,3.e-6,4.e-6,5.e-6,6.e-6,7.e-6,8.e-6,9.e-6, & - 1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & - 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & - 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, & - 1.e-2/) - -!..Lookup tables for graupel content (kg/m**3). - REAL, DIMENSION(ntb_g), PARAMETER, PRIVATE:: & - r_g = (/1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & - 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & - 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, & - 1.e-2/) - -!..Lookup tables for snow content (kg/m**3). - REAL, DIMENSION(ntb_s), PARAMETER, PRIVATE:: & - r_s = (/1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & - 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & - 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, & - 1.e-2/) - -!..Lookup tables for rain y-intercept parameter (/m**4). - REAL, DIMENSION(ntb_r1), PARAMETER, PRIVATE:: & - N0r_exp = (/1.e6,2.e6,3.e6,4.e6,5.e6,6.e6,7.e6,8.e6,9.e6, & - 1.e7,2.e7,3.e7,4.e7,5.e7,6.e7,7.e7,8.e7,9.e7, & - 1.e8,2.e8,3.e8,4.e8,5.e8,6.e8,7.e8,8.e8,9.e8, & - 1.e9,2.e9,3.e9,4.e9,5.e9,6.e9,7.e9,8.e9,9.e9, & - 1.e10/) - -!..Lookup tables for ice number concentration (/m**3). - REAL, DIMENSION(ntb_i1), PARAMETER, PRIVATE:: & - Nt_i = (/1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0, & - 1.e1,2.e1,3.e1,4.e1,5.e1,6.e1,7.e1,8.e1,9.e1, & - 1.e2,2.e2,3.e2,4.e2,5.e2,6.e2,7.e2,8.e2,9.e2, & - 1.e3,2.e3,3.e3,4.e3,5.e3,6.e3,7.e3,8.e3,9.e3, & - 1.e4,2.e4,3.e4,4.e4,5.e4,6.e4,7.e4,8.e4,9.e4, & - 1.e5,2.e5,3.e5,4.e5,5.e5,6.e5,7.e5,8.e5,9.e5, & - 1.e6/) - -!..For snow moments conversions (from Field et al. 2005) - REAL, DIMENSION(10), PARAMETER, PRIVATE:: & - sa = (/ 5.065339, -0.062659, -3.032362, 0.029469, -0.000285, & - 0.31255, 0.000204, 0.003199, 0.0, -0.015952/) - REAL, DIMENSION(10), PARAMETER, PRIVATE:: & - sb = (/ 0.476221, -0.015896, 0.165977, 0.007468, -0.000141, & - 0.060366, 0.000079, 0.000594, 0.0, -0.003577/) - -!..Temperatures (5 C interval 0 to -40) used in lookup tables. - REAL, DIMENSION(ntb_t), PARAMETER, PRIVATE:: & - Tc = (/-0.01, -5., -10., -15., -20., -25., -30., -35., -40./) - -!..Lookup tables for various accretion/collection terms. -!.. ntb_x refers to the number of elements for rain, snow, graupel, -!.. and temperature array indices. Variables beginning with t-p/c/m/n -!.. represent lookup tables. - DOUBLE PRECISION, DIMENSION(ntb_g,ntb_r1,ntb_r):: & - tcg_racg, tmr_racg, tcr_gacr, tmg_gacr, & - tnr_racg, tnr_gacr - DOUBLE PRECISION, DIMENSION(ntb_s,ntb_t,ntb_r1,ntb_r):: & - tcs_racs1, tmr_racs1, tcs_racs2, tmr_racs2, & - tcr_sacr1, tms_sacr1, tcr_sacr2, tms_sacr2, & - tnr_racs1, tnr_racs2, tnr_sacr1, tnr_sacr2 - DOUBLE PRECISION, DIMENSION(ntb_c,45):: & - tpi_qcfz, tni_qcfz - DOUBLE PRECISION, DIMENSION(ntb_r,ntb_r1,45):: & - tpi_qrfz, tpg_qrfz, tni_qrfz, tnr_qrfz - DOUBLE PRECISION, DIMENSION(ntb_i,ntb_i1):: & - tps_iaus, tni_iaus, tpi_ide - REAL, DIMENSION(nbr,nbc):: t_Efrw - REAL, DIMENSION(nbs,nbc):: t_Efsw - DOUBLE PRECISION, DIMENSION(nbr, ntb_r1, ntb_r):: tnr_rev - -!..Variables holding a bunch of exponents and gamma values (cloud water, -!.. cloud ice, rain, snow, then graupel). - REAL, DIMENSION(3), PRIVATE:: cce, ccg - REAL, PRIVATE:: ocg1, ocg2 - REAL, DIMENSION(6), PRIVATE:: cie, cig - REAL, PRIVATE:: oig1, oig2, obmi - REAL, DIMENSION(12), PRIVATE:: cre, crg - REAL, PRIVATE:: ore1, org1, org2, org3, obmr - REAL, DIMENSION(18), PRIVATE:: cse, csg - REAL, PRIVATE:: oams, obms, ocms - REAL, DIMENSION(12), PRIVATE:: cge, cgg - REAL, PRIVATE:: oge1, ogg1, ogg2, ogg3, oamg, obmg, ocmg - -!..Declaration of precomputed constants in various rate eqns. - REAL:: t1_qr_qc, t1_qr_qi, t2_qr_qi, t1_qg_qc, t1_qs_qc, t1_qs_qi - REAL:: t1_qr_ev, t2_qr_ev - REAL:: t1_qs_sd, t2_qs_sd, t1_qg_sd, t2_qg_sd - REAL:: t1_qs_me, t2_qs_me, t1_qg_me, t2_qg_me - - CHARACTER*256:: mp_debug - -!+---+ -!+---+-----------------------------------------------------------------+ -!..END DECLARATIONS -!+---+-----------------------------------------------------------------+ -!+---+ -! - - CONTAINS - - SUBROUTINE thompson_init - - IMPLICIT NONE - - INTEGER:: i, j, k, m, n - -!..From Martin et al. (1994), assign gamma shape parameter mu for cloud -!.. drops according to general dispersion characteristics (disp=~0.25 -!.. for Maritime and 0.45 for Continental). -!.. disp=SQRT((mu+2)/(mu+1) - 1) so mu varies from 15 for Maritime -!.. to 2 for really dirty air. - mu_c = MIN(15., (1000.E6/Nt_c + 2.)) - -!..Schmidt number to one-third used numerous times. - Sc3 = Sc**(1./3.) - -!..Compute min ice diam from mass, min snow/graupel mass from diam. - D0i = (xm0i/am_i)**(1./bm_i) - xm0s = am_s * D0s**bm_s - xm0g = am_g * D0g**bm_g - -!..These constants various exponents and gamma() assoc with cloud, -!.. rain, snow, and graupel. - cce(1) = mu_c + 1. - cce(2) = bm_r + mu_c + 1. - cce(3) = bm_r + mu_c + 4. - ccg(1) = WGAMMA(cce(1)) - ccg(2) = WGAMMA(cce(2)) - ccg(3) = WGAMMA(cce(3)) - ocg1 = 1./ccg(1) - ocg2 = 1./ccg(2) - - cie(1) = mu_i + 1. - cie(2) = bm_i + mu_i + 1. - cie(3) = bm_i + mu_i + bv_i + 1. - cie(4) = mu_i + bv_i + 1. - cie(5) = mu_i + 2. - cie(6) = bm_i + bv_i - cig(1) = WGAMMA(cie(1)) - cig(2) = WGAMMA(cie(2)) - cig(3) = WGAMMA(cie(3)) - cig(4) = WGAMMA(cie(4)) - cig(5) = WGAMMA(cie(5)) - cig(6) = WGAMMA(cie(6)) - oig1 = 1./cig(1) - oig2 = 1./cig(2) - obmi = 1./bm_i - - cre(1) = bm_r + 1. - cre(2) = mu_r + 1. - cre(3) = bm_r + mu_r + 1. - cre(4) = bm_r*2. + mu_r + 1. - cre(5) = mu_r + bv_r + 1. - cre(6) = bm_r + mu_r + bv_r + 1. - cre(7) = bm_r*0.5 + mu_r + bv_r + 1. - cre(8) = bm_r + mu_r + bv_r + 3. - cre(9) = mu_r + bv_r + 3. - cre(10) = mu_r + 2. - cre(11) = 0.5*(bv_r + 5. + 2.*mu_r) - cre(12) = bm_r*0.5 + mu_r + 1. - do n = 1, 12 - crg(n) = WGAMMA(cre(n)) - enddo - obmr = 1./bm_r - ore1 = 1./cre(1) - org1 = 1./crg(1) - org2 = 1./crg(2) - org3 = 1./crg(3) - - cse(1) = bm_s + 1. - cse(2) = bm_s + 2. - cse(3) = bm_s*2. - cse(4) = bm_s + bv_s + 1. - cse(5) = bm_s + bv_s + 2. - cse(6) = bm_s + bv_s + 3. - cse(7) = bm_s + mu_s + 1. - cse(8) = bm_s + mu_s + 2. - cse(9) = bm_s + mu_s + 3. - cse(10) = bm_s + mu_s + bv_s + 1. - cse(11) = bm_s + mu_s + bv_s + 2. - cse(12) = bm_s*2. + mu_s + 1. - cse(13) = bv_s + 2. - cse(14) = bm_s + bv_s - cse(15) = mu_s + 1. - cse(16) = 1.0 + (1.0 + bv_s)/2. - cse(17) = cse(16) + mu_s + 1. - cse(18) = bv_s + mu_s + 3. - do n = 1, 18 - csg(n) = WGAMMA(cse(n)) - enddo - oams = 1./am_s - obms = 1./bm_s - ocms = oams**obms - - cge(1) = bm_g + 1. - cge(2) = mu_g + 1. - cge(3) = bm_g + mu_g + 1. - cge(4) = bm_g*2. + mu_g + 1. - cge(5) = bm_g + mu_g + 3. - cge(6) = bm_g + mu_g + bv_g + 1. - cge(7) = bm_g + mu_g + bv_g + 2. - cge(8) = bm_g + mu_g + bv_g + 3. - cge(9) = mu_g + bv_g + 3. - cge(10) = mu_g + 2. - cge(11) = 0.5*(bv_g + 5. + 2.*mu_g) - cge(12) = 0.5*(bv_g + 5.) + mu_g - do n = 1, 12 - cgg(n) = WGAMMA(cge(n)) - enddo - oamg = 1./am_g - obmg = 1./bm_g - ocmg = oamg**obmg - oge1 = 1./cge(1) - ogg1 = 1./cgg(1) - ogg2 = 1./cgg(2) - ogg3 = 1./cgg(3) - -!+---+-----------------------------------------------------------------+ -!..Simplify various rate eqns the best we can now. -!+---+-----------------------------------------------------------------+ - -!..Rain collecting cloud water and cloud ice - t1_qr_qc = PI*.25*av_r * crg(9) - t1_qr_qi = PI*.25*av_r * crg(9) - t2_qr_qi = PI*.25*am_r*av_r * crg(8) - -!..Graupel collecting cloud water - t1_qg_qc = PI*.25*av_g * cgg(9) - -!..Snow collecting cloud water - t1_qs_qc = PI*.25*av_s - -!..Snow collecting cloud ice - t1_qs_qi = PI*.25*av_s - -!..Evaporation of rain; ignore depositional growth of rain. - t1_qr_ev = 0.78 * crg(10) - t2_qr_ev = 0.308*Sc3*SQRT(av_r) * crg(11) - -!..Sublimation/depositional growth of snow - t1_qs_sd = 0.86 - t2_qs_sd = 0.28*Sc3*SQRT(av_s) - -!..Melting of snow - t1_qs_me = PI*4.*C_sqrd*olfus * 0.86 - t2_qs_me = PI*4.*C_sqrd*olfus * 0.28*Sc3*SQRT(av_s) - -!..Sublimation/depositional growth of graupel - t1_qg_sd = 0.86 * cgg(10) - t2_qg_sd = 0.28*Sc3*SQRT(av_g) * cgg(11) - -!..Melting of graupel - t1_qg_me = PI*4.*C_cube*olfus * 0.86 * cgg(10) - t2_qg_me = PI*4.*C_cube*olfus * 0.28*Sc3*SQRT(av_g) * cgg(11) - -!..Constants for helping find lookup table indexes. - nic2 = NINT(ALOG10(r_c(1))) - nii2 = NINT(ALOG10(r_i(1))) - nii3 = NINT(ALOG10(Nt_i(1))) - nir2 = NINT(ALOG10(r_r(1))) - nir3 = NINT(ALOG10(N0r_exp(1))) - nis2 = NINT(ALOG10(r_s(1))) - nig2 = NINT(ALOG10(r_g(1))) - -!..Create bins of cloud water (from min diameter up to 100 microns). - Dc(1) = D0c*1.0d0 - dtc(1) = D0c*1.0d0 - do n = 2, nbc - Dc(n) = Dc(n-1) + 1.0D-6 - dtc(n) = (Dc(n) - Dc(n-1)) - enddo - -!..Create bins of cloud ice (from min diameter up to 5x min snow size). - xDx(1) = D0i*1.0d0 - xDx(nbi+1) = 5.0d0*D0s - do n = 2, nbi - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbi) & - *DLOG(xDx(nbi+1)/xDx(1)) +DLOG(xDx(1))) - enddo - do n = 1, nbi - Di(n) = DSQRT(xDx(n)*xDx(n+1)) - dti(n) = xDx(n+1) - xDx(n) - enddo - -!..Create bins of rain (from min diameter up to 5 mm). - xDx(1) = D0r*1.0d0 - xDx(nbr+1) = 0.005d0 - do n = 2, nbr - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbr) & - *DLOG(xDx(nbr+1)/xDx(1)) +DLOG(xDx(1))) - enddo - do n = 1, nbr - Dr(n) = DSQRT(xDx(n)*xDx(n+1)) - dtr(n) = xDx(n+1) - xDx(n) - enddo - -!..Create bins of snow (from min diameter up to 2 cm). - xDx(1) = D0s*1.0d0 - xDx(nbs+1) = 0.02d0 - do n = 2, nbs - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbs) & - *DLOG(xDx(nbs+1)/xDx(1)) +DLOG(xDx(1))) - enddo - do n = 1, nbs - Ds(n) = DSQRT(xDx(n)*xDx(n+1)) - dts(n) = xDx(n+1) - xDx(n) - enddo - -!..Create bins of graupel (from min diameter up to 5 cm). - xDx(1) = D0g*1.0d0 - xDx(nbg+1) = 0.05d0 - do n = 2, nbg - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbg) & - *DLOG(xDx(nbg+1)/xDx(1)) +DLOG(xDx(1))) - enddo - do n = 1, nbg - Dg(n) = DSQRT(xDx(n)*xDx(n+1)) - dtg(n) = xDx(n+1) - xDx(n) - enddo - -!+---+-----------------------------------------------------------------+ -!..Create lookup tables for most costly calculations. -!+---+-----------------------------------------------------------------+ - - do k = 1, ntb_r - do j = 1, ntb_r1 - do i = 1, ntb_g - tcg_racg(i,j,k) = 0.0d0 - tmr_racg(i,j,k) = 0.0d0 - tcr_gacr(i,j,k) = 0.0d0 - tmg_gacr(i,j,k) = 0.0d0 - tnr_racg(i,j,k) = 0.0d0 - tnr_gacr(i,j,k) = 0.0d0 - enddo - enddo - enddo - - do m = 1, ntb_r - do k = 1, ntb_r1 - do j = 1, ntb_t - do i = 1, ntb_s - tcs_racs1(i,j,k,m) = 0.0d0 - tmr_racs1(i,j,k,m) = 0.0d0 - tcs_racs2(i,j,k,m) = 0.0d0 - tmr_racs2(i,j,k,m) = 0.0d0 - tcr_sacr1(i,j,k,m) = 0.0d0 - tms_sacr1(i,j,k,m) = 0.0d0 - tcr_sacr2(i,j,k,m) = 0.0d0 - tms_sacr2(i,j,k,m) = 0.0d0 - tnr_racs1(i,j,k,m) = 0.0d0 - tnr_racs2(i,j,k,m) = 0.0d0 - tnr_sacr1(i,j,k,m) = 0.0d0 - tnr_sacr2(i,j,k,m) = 0.0d0 - enddo - enddo - enddo - enddo - - do k = 1, 45 - do j = 1, ntb_r1 - do i = 1, ntb_r - tpi_qrfz(i,j,k) = 0.0d0 - tni_qrfz(i,j,k) = 0.0d0 - tpg_qrfz(i,j,k) = 0.0d0 - tnr_qrfz(i,j,k) = 0.0d0 - enddo - enddo - do i = 1, ntb_c - tpi_qcfz(i,k) = 0.0d0 - tni_qcfz(i,k) = 0.0d0 - enddo - enddo - - do j = 1, ntb_i1 - do i = 1, ntb_i - tps_iaus(i,j) = 0.0d0 - tni_iaus(i,j) = 0.0d0 - tpi_ide(i,j) = 0.0d0 - enddo - enddo - - do j = 1, nbc - do i = 1, nbr - t_Efrw(i,j) = 0.0 - enddo - do i = 1, nbs - t_Efsw(i,j) = 0.0 - enddo - enddo - - do k = 1, ntb_r - do j = 1, ntb_r1 - do i = 1, nbr - tnr_rev(i,j,k) = 0.0d0 - enddo - enddo - enddo - -! CALL wrf_debug(150, 'CREATING MICROPHYSICS LOOKUP TABLES ... ') -! WRITE (wrf_err_message, '(a, f5.2, a, f5.2, a, f5.2, a, f5.2)') & -! ' using: mu_c=',mu_c,' mu_i=',mu_i,' mu_r=',mu_r,' mu_g=',mu_g -! CALL wrf_debug(150, wrf_err_message) - -!..Collision efficiency between rain/snow and cloud water. -! CALL wrf_debug(200, ' creating qc collision eff tables') - call table_Efrw - call table_Efsw - -!..Drop evaporation. -! CALL wrf_debug(200, ' creating rain evap table') -! call table_dropEvap - -!..Initialize various constants for computing radar reflectivity. -! call radar_init - - if (.not. iiwarm) then - -!..Rain collecting graupel & graupel collecting rain. -! CALL wrf_debug(200, ' creating rain collecting graupel table') - call qr_acr_qg - -!..Rain collecting snow & snow collecting rain. -! CALL wrf_debug(200, ' creating rain collecting snow table') - call qr_acr_qs - -!..Cloud water and rain freezing (Bigg, 1953). -! CALL wrf_debug(200, ' creating freezing of water drops table') - call freezeH2O - -!..Conversion of some ice mass into snow category. -! CALL wrf_debug(200, ' creating ice converting to snow table') - call qi_aut_qs - - endif - -! CALL wrf_debug(150, ' ... DONE microphysical lookup tables') - - END SUBROUTINE thompson_init -!+---+-----------------------------------------------------------------+ -! -!+---+-----------------------------------------------------------------+ -!..This is a wrapper routine designed to transfer values from 3D to 1D. -!+---+-----------------------------------------------------------------+ - SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, & - th, pii, p, dz, dt_in, itimestep, & - RAINNC, RAINNCV, & - SNOWNC, SNOWNCV, & - GRAUPELNC, GRAUPELNCV, & - SR, & -! refl_10cm, grid_clock, grid_alarms, & - ids,ide, jds,jde, kds,kde, & ! domain dims - ims,ime, jms,jme, kms,kme, & ! memory dims - its,ite, jts,jte, kts,kte) ! tile dims - - implicit none - -!..Subroutine arguments - INTEGER, INTENT(IN):: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & - qv, qc, qr, qi, qs, qg, ni, nr, th - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN):: & - pii, p, dz - REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT):: & - RAINNC, RAINNCV, SR - REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(INOUT):: & - SNOWNC, SNOWNCV, GRAUPELNC, GRAUPELNCV - -! REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & -! refl_10cm - REAL, INTENT(IN):: dt_in - INTEGER, INTENT(IN):: itimestep - -! TYPE (WRFU_Clock):: grid_clock -! TYPE (WRFU_Alarm), POINTER:: grid_alarms(:) - -!..Local variables - REAL, DIMENSION(kts:kte):: & - qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & - nr1d, t1d, p1d, dz1d, dBZ - REAL, DIMENSION(its:ite, jts:jte):: pcp_ra, pcp_sn, pcp_gr, pcp_ic - REAL:: dt, pptrain, pptsnow, pptgraul, pptice - REAL:: qc_max, qr_max, qs_max, qi_max, qg_max, ni_max, nr_max - INTEGER:: i, j, k - INTEGER:: imax_qc,imax_qr,imax_qi,imax_qs,imax_qg,imax_ni,imax_nr - INTEGER:: jmax_qc,jmax_qr,jmax_qi,jmax_qs,jmax_qg,jmax_ni,jmax_nr - INTEGER:: kmax_qc,kmax_qr,kmax_qi,kmax_qs,kmax_qg,kmax_ni,kmax_nr - INTEGER:: i_start, j_start, i_end, j_end - LOGICAL:: dBZ_tstep - -!+---+ - - dBZ_tstep = .false. -! if ( Is_alarm_tstep(grid_clock, grid_alarms(HISTORY_ALARM)) ) then -! dBZ_tstep = .true. -! endif - - i_start = its - j_start = jts - i_end = ite - j_end = jte - if ( (ite-its+1).gt.4 .and. (jte-jts+1).lt.4) then - i_start = its + 2 - i_end = ite - 1 - j_start = jts - j_end = jte - elseif ( (ite-its+1).lt.4 .and. (jte-jts+1).gt.4) then - i_start = its - i_end = ite - j_start = jts + 2 - j_end = jte - 1 - endif - - dt = dt_in - - qc_max = 0. - qr_max = 0. - qs_max = 0. - qi_max = 0. - qg_max = 0 - ni_max = 0. - nr_max = 0. - imax_qc = 0 - imax_qr = 0 - imax_qi = 0 - imax_qs = 0 - imax_qg = 0 - imax_ni = 0 - imax_nr = 0 - jmax_qc = 0 - jmax_qr = 0 - jmax_qi = 0 - jmax_qs = 0 - jmax_qg = 0 - jmax_ni = 0 - jmax_nr = 0 - kmax_qc = 0 - kmax_qr = 0 - kmax_qi = 0 - kmax_qs = 0 - kmax_qg = 0 - kmax_ni = 0 - kmax_nr = 0 - do i = 1, 256 - mp_debug(i:i) = char(0) - enddo - - j_loop: do j = j_start, j_end - i_loop: do i = i_start, i_end - - pptrain = 0. - pptsnow = 0. - pptgraul = 0. - pptice = 0. - RAINNCV(i,j) = 0. - IF ( PRESENT (snowncv) ) THEN - SNOWNCV(i,j) = 0. - ENDIF - IF ( PRESENT (graupelncv) ) THEN - GRAUPELNCV(i,j) = 0. - ENDIF - SR(i,j) = 0. - - do k = kts, kte - t1d(k) = th(i,k,j)*pii(i,k,j) - p1d(k) = p(i,k,j) - dz1d(k) = dz(i,k,j) - qv1d(k) = qv(i,k,j) - qc1d(k) = qc(i,k,j) - qi1d(k) = qi(i,k,j) - qr1d(k) = qr(i,k,j) - qs1d(k) = qs(i,k,j) - qg1d(k) = qg(i,k,j) - ni1d(k) = ni(i,k,j) - nr1d(k) = nr(i,k,j) - enddo - - call mp_thompson(qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & - nr1d, t1d, p1d, dz1d, & - pptrain, pptsnow, pptgraul, pptice, & - kts, kte, dt, i, j) - - pcp_ra(i,j) = pptrain - pcp_sn(i,j) = pptsnow - pcp_gr(i,j) = pptgraul - pcp_ic(i,j) = pptice - RAINNCV(i,j) = pptrain + pptsnow + pptgraul + pptice - RAINNC(i,j) = RAINNC(i,j) + pptrain + pptsnow + pptgraul + pptice - IF ( PRESENT (snowncv) .AND. PRESENT (snownc) ) THEN - SNOWNCV(i,j) = pptsnow + pptice - SNOWNC(i,j) = SNOWNC(i,j) + pptsnow + pptice - ENDIF - IF ( PRESENT (graupelncv) .AND. PRESENT (graupelnc) ) THEN - GRAUPELNCV(i,j) = pptgraul - GRAUPELNC(i,j) = GRAUPELNC(i,j) + pptgraul - ENDIF - SR(i,j) = (pptsnow + pptgraul + pptice)/(RAINNCV(i,j)+1.e-12) - - do k = kts, kte - qv(i,k,j) = qv1d(k) - qc(i,k,j) = qc1d(k) - qi(i,k,j) = qi1d(k) - qr(i,k,j) = qr1d(k) - qs(i,k,j) = qs1d(k) - qg(i,k,j) = qg1d(k) - ni(i,k,j) = ni1d(k) - nr(i,k,j) = nr1d(k) - th(i,k,j) = t1d(k)/pii(i,k,j) - if (qc1d(k) .gt. qc_max) then - imax_qc = i - jmax_qc = j - kmax_qc = k - qc_max = qc1d(k) - elseif (qc1d(k) .lt. 0.0) then - write(mp_debug,*) 'WARNING, negative qc ', qc1d(k), & - ' at i,j,k=', i,j,k -! CALL wrf_debug(150, mp_debug) - endif - if (qr1d(k) .gt. qr_max) then - imax_qr = i - jmax_qr = j - kmax_qr = k - qr_max = qr1d(k) - elseif (qr1d(k) .lt. 0.0) then - write(mp_debug,*) 'WARNING, negative qr ', qr1d(k), & - ' at i,j,k=', i,j,k -! CALL wrf_debug(150, mp_debug) - endif - if (nr1d(k) .gt. nr_max) then - imax_nr = i - jmax_nr = j - kmax_nr = k - nr_max = nr1d(k) - elseif (nr1d(k) .lt. 0.0) then - write(mp_debug,*) 'WARNING, negative nr ', nr1d(k), & - ' at i,j,k=', i,j,k -! CALL wrf_debug(150, mp_debug) - endif - if (qs1d(k) .gt. qs_max) then - imax_qs = i - jmax_qs = j - kmax_qs = k - qs_max = qs1d(k) - elseif (qs1d(k) .lt. 0.0) then - write(mp_debug,*) 'WARNING, negative qs ', qs1d(k), & - ' at i,j,k=', i,j,k -! CALL wrf_debug(150, mp_debug) - endif - if (qi1d(k) .gt. qi_max) then - imax_qi = i - jmax_qi = j - kmax_qi = k - qi_max = qi1d(k) - elseif (qi1d(k) .lt. 0.0) then - write(mp_debug,*) 'WARNING, negative qi ', qi1d(k), & - ' at i,j,k=', i,j,k -! CALL wrf_debug(150, mp_debug) - endif - if (qg1d(k) .gt. qg_max) then - imax_qg = i - jmax_qg = j - kmax_qg = k - qg_max = qg1d(k) - elseif (qg1d(k) .lt. 0.0) then - write(mp_debug,*) 'WARNING, negative qg ', qg1d(k), & - ' at i,j,k=', i,j,k -! CALL wrf_debug(150, mp_debug) - endif - if (ni1d(k) .gt. ni_max) then - imax_ni = i - jmax_ni = j - kmax_ni = k - ni_max = ni1d(k) - elseif (ni1d(k) .lt. 0.0) then - write(mp_debug,*) 'WARNING, negative ni ', ni1d(k), & - ' at i,j,k=', i,j,k -! CALL wrf_debug(150, mp_debug) - endif - if (qv1d(k) .lt. 0.0) then - if (k.lt.kte-2 .and. k.gt.kts+1) then - qv(i,k,j) = 0.5*(qv(i,k-1,j) + qv(i,k+1,j)) - else - qv(i,k,j) = 1.E-7 - endif - write(mp_debug,*) 'WARNING, negative qv ', qv1d(k), & - ' at i,j,k=', i,j,k -! CALL wrf_debug(150, mp_debug) - endif - enddo - -! if (dBZ_tstep) then -! call calc_refl10cm (qv1d, qr1d, nr1d, qs1d, qg1d, t1d, p1d, & -! dBZ, kts, kte, i, j) -! do k = kts, kte -! refl_10cm(i,k,j) = MAX(-35., dBZ(k)) -! enddo -! endif - - enddo i_loop - enddo j_loop - -! DEBUG - GT - write(mp_debug,'(a,7(a,e13.6,1x,a,i3,a,i3,a,i3,a,1x))') 'MP-GT:', & - 'qc: ', qc_max, '(', imax_qc, ',', jmax_qc, ',', kmax_qc, ')', & - 'qr: ', qr_max, '(', imax_qr, ',', jmax_qr, ',', kmax_qr, ')', & - 'qi: ', qi_max, '(', imax_qi, ',', jmax_qi, ',', kmax_qi, ')', & - 'qs: ', qs_max, '(', imax_qs, ',', jmax_qs, ',', kmax_qs, ')', & - 'qg: ', qg_max, '(', imax_qg, ',', jmax_qg, ',', kmax_qg, ')', & - 'ni: ', ni_max, '(', imax_ni, ',', jmax_ni, ',', kmax_ni, ')', & - 'nr: ', nr_max, '(', imax_nr, ',', jmax_nr, ',', kmax_nr, ')' -! CALL wrf_debug(150, mp_debug) -! END DEBUG - GT - - do i = 1, 256 - mp_debug(i:i) = char(0) - enddo - - END SUBROUTINE mp_gt_driver - -!+---+-----------------------------------------------------------------+ -! -!+---+-----------------------------------------------------------------+ -!+---+-----------------------------------------------------------------+ -!.. This subroutine computes the moisture tendencies of water vapor, -!.. cloud droplets, rain, cloud ice (pristine), snow, and graupel. -!.. Previously this code was based on Reisner et al (1998), but few of -!.. those pieces remain. A complete description is now found in -!.. Thompson et al. (2004, 2008). -!+---+-----------------------------------------------------------------+ -! - subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & - nr1d, t1d, p1d, dzq, & - pptrain, pptsnow, pptgraul, pptice, & - kts, kte, dt, ii, jj) - - implicit none - -!..Sub arguments - INTEGER, INTENT(IN):: kts, kte, ii, jj - REAL, DIMENSION(kts:kte), INTENT(INOUT):: & - qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & - nr1d, t1d, p1d - REAL, DIMENSION(kts:kte), INTENT(IN):: dzq - REAL, INTENT(INOUT):: pptrain, pptsnow, pptgraul, pptice - REAL, INTENT(IN):: dt - -!..Local variables - REAL, DIMENSION(kts:kte):: tten, qvten, qcten, qiten, & - qrten, qsten, qgten, niten, nrten - - DOUBLE PRECISION, DIMENSION(kts:kte):: prw_vcd - - DOUBLE PRECISION, DIMENSION(kts:kte):: prr_wau, prr_rcw, prr_rcs, & - prr_rcg, prr_sml, prr_gml, & - prr_rci, prv_rev, & - pnr_wau, pnr_rcs, pnr_rcg, & - pnr_rci, pnr_sml, pnr_gml, & - pnr_rev, pnr_rcr, pnr_rfz - - DOUBLE PRECISION, DIMENSION(kts:kte):: pri_inu, pni_inu, pri_ihm, & - pni_ihm, pri_wfz, pni_wfz, & - pri_rfz, pni_rfz, pri_ide, & - pni_ide, pri_rci, pni_rci, & - pni_sci, pni_iau - - DOUBLE PRECISION, DIMENSION(kts:kte):: prs_iau, prs_sci, prs_rcs, & - prs_scw, prs_sde, prs_ihm, & - prs_ide - - DOUBLE PRECISION, DIMENSION(kts:kte):: prg_scw, prg_rfz, prg_gde, & - prg_gcw, prg_rci, prg_rcs, & - prg_rcg, prg_ihm - - REAL, DIMENSION(kts:kte):: temp, pres, qv - REAL, DIMENSION(kts:kte):: rc, ri, rr, rs, rg, ni, nr - REAL, DIMENSION(kts:kte):: rho, rhof, rhof2 - REAL, DIMENSION(kts:kte):: qvs, qvsi - REAL, DIMENSION(kts:kte):: satw, sati, ssatw, ssati - REAL, DIMENSION(kts:kte):: diffu, visco, vsc2, & - tcond, lvap, ocp, lvt2 - - DOUBLE PRECISION, DIMENSION(kts:kte):: ilamr, ilamg, N0_r, N0_g - REAL, DIMENSION(kts:kte):: mvd_r, mvd_c - REAL, DIMENSION(kts:kte):: smob, smo2, smo1, smo0, & - smoc, smod, smoe, smof - - REAL, DIMENSION(kts:kte):: sed_r, sed_s, sed_g, sed_i, sed_n - - REAL:: rgvm, delta_tp, orho, lfus2 - REAL, DIMENSION(4):: onstep - DOUBLE PRECISION:: N0_exp, N0_min, lam_exp, lamc, lamr, lamg - DOUBLE PRECISION:: lami, ilami - REAL:: xDc, Dc_b, Dc_g, xDi, xDr, xDs, xDg, Ds_m, Dg_m - DOUBLE PRECISION:: Dr_star - REAL:: zeta1, zeta, taud, tau - REAL:: stoke_r, stoke_s, stoke_g, stoke_i - REAL:: vti, vtr, vts, vtg - REAL, DIMENSION(kts:kte+1):: vtik, vtnik, vtrk, vtnrk, vtsk, vtgk - REAL, DIMENSION(kts:kte):: vts_boost - REAL:: Mrat, ils1, ils2, t1_vts, t2_vts, t3_vts, t4_vts, C_snow - REAL:: a_, b_, loga_, A1, A2, tf - REAL:: tempc, tc0, r_mvd1, r_mvd2, xkrat - REAL:: xnc, xri, xni, xmi, oxmi, xrc, xrr, xnr - REAL:: xsat, rate_max, sump, ratio - REAL:: clap, fcd, dfcd - REAL:: otemp, rvs, rvs_p, rvs_pp, gamsc, alphsc, t1_evap, t1_subl - REAL:: r_frac, g_frac - REAL:: Ef_rw, Ef_sw, Ef_gw - REAL:: dtsave, odts, odt, odzq - INTEGER:: i, k, k2, n, nn, nstep, k_0, kbot, IT, iexfrq - INTEGER, DIMENSION(4):: ksed1 - INTEGER:: nir, nis, nig, nii, nic - INTEGER:: idx_tc,idx_t,idx_s,idx_g,idx_r1,idx_r,idx_i1,idx_i,idx_c - INTEGER:: idx, idx_d - LOGICAL:: melti, no_micro - LOGICAL, DIMENSION(kts:kte):: L_qc, L_qi, L_qr, L_qs, L_qg - LOGICAL:: debug_flag - -!+---+ - - debug_flag = .false. -! if (ii.eq.280 .and. jj.eq.1) debug_flag = .true. - - no_micro = .true. - dtsave = dt - odt = 1./dt - odts = 1./dtsave - iexfrq = 1 - -!+---+-----------------------------------------------------------------+ -!.. Source/sink terms. First 2 chars: "pr" represents source/sink of -!.. mass while "pn" represents source/sink of number. Next char is one -!.. of "v" for water vapor, "r" for rain, "i" for cloud ice, "w" for -!.. cloud water, "s" for snow, and "g" for graupel. Next chars -!.. represent processes: "de" for sublimation/deposition, "ev" for -!.. evaporation, "fz" for freezing, "ml" for melting, "au" for -!.. autoconversion, "nu" for ice nucleation, "hm" for Hallet/Mossop -!.. secondary ice production, and "c" for collection followed by the -!.. character for the species being collected. ALL of these terms are -!.. positive (except for deposition/sublimation terms which can switch -!.. signs based on super/subsaturation) and are treated as negatives -!.. where necessary in the tendency equations. -!+---+-----------------------------------------------------------------+ - - do k = kts, kte - tten(k) = 0. - qvten(k) = 0. - qcten(k) = 0. - qiten(k) = 0. - qrten(k) = 0. - qsten(k) = 0. - qgten(k) = 0. - niten(k) = 0. - nrten(k) = 0. - - prw_vcd(k) = 0. - - prv_rev(k) = 0. - prr_wau(k) = 0. - prr_rcw(k) = 0. - prr_rcs(k) = 0. - prr_rcg(k) = 0. - prr_sml(k) = 0. - prr_gml(k) = 0. - prr_rci(k) = 0. - pnr_wau(k) = 0. - pnr_rcs(k) = 0. - pnr_rcg(k) = 0. - pnr_rci(k) = 0. - pnr_sml(k) = 0. - pnr_gml(k) = 0. - pnr_rev(k) = 0. - pnr_rcr(k) = 0. - pnr_rfz(k) = 0. - - pri_inu(k) = 0. - pni_inu(k) = 0. - pri_ihm(k) = 0. - pni_ihm(k) = 0. - pri_wfz(k) = 0. - pni_wfz(k) = 0. - pri_rfz(k) = 0. - pni_rfz(k) = 0. - pri_ide(k) = 0. - pni_ide(k) = 0. - pri_rci(k) = 0. - pni_rci(k) = 0. - pni_sci(k) = 0. - pni_iau(k) = 0. - - prs_iau(k) = 0. - prs_sci(k) = 0. - prs_rcs(k) = 0. - prs_scw(k) = 0. - prs_sde(k) = 0. - prs_ihm(k) = 0. - prs_ide(k) = 0. - - prg_scw(k) = 0. - prg_rfz(k) = 0. - prg_gde(k) = 0. - prg_gcw(k) = 0. - prg_rci(k) = 0. - prg_rcs(k) = 0. - prg_rcg(k) = 0. - prg_ihm(k) = 0. - enddo - -!+---+-----------------------------------------------------------------+ -!..Put column of data into local arrays. -!+---+-----------------------------------------------------------------+ - do k = kts, kte - temp(k) = t1d(k) - qv(k) = MAX(1.E-10, qv1d(k)) - pres(k) = p1d(k) - rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622)) - if (qc1d(k) .gt. R1) then - no_micro = .false. - rc(k) = qc1d(k)*rho(k) - L_qc(k) = .true. - else - qc1d(k) = 0.0 - rc(k) = R1 - L_qc(k) = .false. - endif - if (qi1d(k) .gt. R1) then - no_micro = .false. - ri(k) = qi1d(k)*rho(k) - ni(k) = MAX(1., ni1d(k)*rho(k)) - L_qi(k) = .true. - lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi - ilami = 1./lami - xDi = (bm_i + mu_i + 1.) * ilami - if (xDi.lt. 30.E-6) then - lami = cie(2)/30.E-6 - ni(k) = MIN(250.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) - elseif (xDi.gt. 300.E-6) then - lami = cie(2)/300.E-6 - ni(k) = cig(1)*oig2*ri(k)/am_i*lami**bm_i - endif - else - qi1d(k) = 0.0 - ni1d(k) = 0.0 - ri(k) = R1 - ni(k) = 0.01 - L_qi(k) = .false. - endif - - if (qr1d(k) .gt. R1) then - no_micro = .false. - rr(k) = qr1d(k)*rho(k) - nr(k) = MAX(1., nr1d(k)*rho(k)) - L_qr(k) = .true. - if (nr(k) .gt. 1.0) then - lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr - mvd_r(k) = (3.0 + mu_r + 0.672) / lamr - if (mvd_r(k) .gt. 2.5E-3) then - mvd_r(k) = 2.5E-3 - lamr = (3.0 + mu_r + 0.672) / mvd_r(k) - nr(k) = crg(2)*org3*rr(k)*lamr**bm_r / am_r - elseif (mvd_r(k) .lt. D0r*0.75) then - mvd_r(k) = D0r*0.75 - lamr = (3.0 + mu_r + 0.672) / mvd_r(k) - nr(k) = crg(2)*org3*rr(k)*lamr**bm_r / am_r - endif - else - if (qr1d(k) .gt. R2) then - mvd_r(k) = 2.5E-3 - else - mvd_r(k) = 2.5E-3 / 3.0**(ALOG10(R2)-ALOG10(qr1d(k))) - endif - lamr = (3.0 + mu_r + 0.672) / mvd_r(k) - nr(k) = crg(2)*org3*rr(k)*lamr**bm_r / am_r - endif - else - qr1d(k) = 0.0 - nr1d(k) = 0.0 - rr(k) = R1 - nr(k) = 1.0 - L_qr(k) = .false. - endif - if (qs1d(k) .gt. R1) then - no_micro = .false. - rs(k) = qs1d(k)*rho(k) - L_qs(k) = .true. - else - qs1d(k) = 0.0 - rs(k) = R1 - L_qs(k) = .false. - endif - if (qg1d(k) .gt. R1) then - no_micro = .false. - rg(k) = qg1d(k)*rho(k) - L_qg(k) = .true. - else - qg1d(k) = 0.0 - rg(k) = R1 - L_qg(k) = .false. - endif - enddo - - -!+---+-----------------------------------------------------------------+ -!..Derive various thermodynamic variables frequently used. -!.. Saturation vapor pressure (mixing ratio) over liquid/ice comes from -!.. Flatau et al. 1992; enthalpy (latent heat) of vaporization from -!.. Bohren & Albrecht 1998; others from Pruppacher & Klett 1978. -!+---+-----------------------------------------------------------------+ - do k = kts, kte - tempc = temp(k) - 273.15 - rhof(k) = SQRT(RHO_NOT/rho(k)) - rhof2(k) = SQRT(rhof(k)) - qvs(k) = rslf(pres(k), temp(k)) - if (tempc .le. 0.0) then - qvsi(k) = rsif(pres(k), temp(k)) - else - qvsi(k) = qvs(k) - endif - satw(k) = qv(k)/qvs(k) - sati(k) = qv(k)/qvsi(k) - ssatw(k) = satw(k) - 1. - ssati(k) = sati(k) - 1. - if (abs(ssatw(k)).lt. eps) ssatw(k) = 0.0 - if (abs(ssati(k)).lt. eps) ssati(k) = 0.0 - if (no_micro .and. ssati(k).gt. 0.0) no_micro = .false. - diffu(k) = 2.11E-5*(temp(k)/273.15)**1.94 * (101325./pres(k)) - if (tempc .ge. 0.0) then - visco(k) = (1.718+0.0049*tempc)*1.0E-5 - else - visco(k) = (1.718+0.0049*tempc-1.2E-5*tempc*tempc)*1.0E-5 - endif - ocp(k) = 1./(Cp*(1.+0.887*qv(k))) - vsc2(k) = SQRT(rho(k)/visco(k)) - lvap(k) = lvap0 + (2106.0 - 4218.0)*tempc - tcond(k) = (5.69 + 0.0168*tempc)*1.0E-5 * 418.936 - enddo - -!+---+-----------------------------------------------------------------+ -!..If no existing hydrometeor species and no chance to initiate ice or -!.. condense cloud water, just exit quickly! -!+---+-----------------------------------------------------------------+ - - if (no_micro) return - -!+---+-----------------------------------------------------------------+ -!..Calculate y-intercept, slope, and useful moments for snow. -!+---+-----------------------------------------------------------------+ - if (.not. iiwarm) then - do k = kts, kte - if (.not. L_qs(k)) CYCLE - tc0 = MIN(-0.1, temp(k)-273.15) - smob(k) = rs(k)*oams - -!..All other moments based on reference, 2nd moment. If bm_s.ne.2, -!.. then we must compute actual 2nd moment and use as reference. - if (bm_s.gt.(2.0-1.e-3) .and. bm_s.lt.(2.0+1.e-3)) then - smo2(k) = smob(k) - else - loga_ = sa(1) + sa(2)*tc0 + sa(3)*bm_s & - + sa(4)*tc0*bm_s + sa(5)*tc0*tc0 & - + sa(6)*bm_s*bm_s + sa(7)*tc0*tc0*bm_s & - + sa(8)*tc0*bm_s*bm_s + sa(9)*tc0*tc0*tc0 & - + sa(10)*bm_s*bm_s*bm_s - a_ = 10.0**loga_ - b_ = sb(1) + sb(2)*tc0 + sb(3)*bm_s & - + sb(4)*tc0*bm_s + sb(5)*tc0*tc0 & - + sb(6)*bm_s*bm_s + sb(7)*tc0*tc0*bm_s & - + sb(8)*tc0*bm_s*bm_s + sb(9)*tc0*tc0*tc0 & - + sb(10)*bm_s*bm_s*bm_s - smo2(k) = (smob(k)/a_)**(1./b_) - endif - -!..Calculate 0th moment. Represents snow number concentration. - loga_ = sa(1) + sa(2)*tc0 + sa(5)*tc0*tc0 + sa(9)*tc0*tc0*tc0 - a_ = 10.0**loga_ - b_ = sb(1) + sb(2)*tc0 + sb(5)*tc0*tc0 + sb(9)*tc0*tc0*tc0 - smo0(k) = a_ * smo2(k)**b_ - -!..Calculate 1st moment. Useful for depositional growth and melting. - loga_ = sa(1) + sa(2)*tc0 + sa(3) & - + sa(4)*tc0 + sa(5)*tc0*tc0 & - + sa(6) + sa(7)*tc0*tc0 & - + sa(8)*tc0 + sa(9)*tc0*tc0*tc0 & - + sa(10) - a_ = 10.0**loga_ - b_ = sb(1)+ sb(2)*tc0 + sb(3) + sb(4)*tc0 & - + sb(5)*tc0*tc0 + sb(6) & - + sb(7)*tc0*tc0 + sb(8)*tc0 & - + sb(9)*tc0*tc0*tc0 + sb(10) - smo1(k) = a_ * smo2(k)**b_ - -!..Calculate bm_s+1 (th) moment. Useful for diameter calcs. - loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(1) & - + sa(4)*tc0*cse(1) + sa(5)*tc0*tc0 & - + sa(6)*cse(1)*cse(1) + sa(7)*tc0*tc0*cse(1) & - + sa(8)*tc0*cse(1)*cse(1) + sa(9)*tc0*tc0*tc0 & - + sa(10)*cse(1)*cse(1)*cse(1) - a_ = 10.0**loga_ - b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(1) + sb(4)*tc0*cse(1) & - + sb(5)*tc0*tc0 + sb(6)*cse(1)*cse(1) & - + sb(7)*tc0*tc0*cse(1) + sb(8)*tc0*cse(1)*cse(1) & - + sb(9)*tc0*tc0*tc0 + sb(10)*cse(1)*cse(1)*cse(1) - smoc(k) = a_ * smo2(k)**b_ - -!..Calculate bv_s+2 (th) moment. Useful for riming. - loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(13) & - + sa(4)*tc0*cse(13) + sa(5)*tc0*tc0 & - + sa(6)*cse(13)*cse(13) + sa(7)*tc0*tc0*cse(13) & - + sa(8)*tc0*cse(13)*cse(13) + sa(9)*tc0*tc0*tc0 & - + sa(10)*cse(13)*cse(13)*cse(13) - a_ = 10.0**loga_ - b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(13) + sb(4)*tc0*cse(13) & - + sb(5)*tc0*tc0 + sb(6)*cse(13)*cse(13) & - + sb(7)*tc0*tc0*cse(13) + sb(8)*tc0*cse(13)*cse(13) & - + sb(9)*tc0*tc0*tc0 + sb(10)*cse(13)*cse(13)*cse(13) - smoe(k) = a_ * smo2(k)**b_ - -!..Calculate 1+(bv_s+1)/2 (th) moment. Useful for depositional growth. - loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(16) & - + sa(4)*tc0*cse(16) + sa(5)*tc0*tc0 & - + sa(6)*cse(16)*cse(16) + sa(7)*tc0*tc0*cse(16) & - + sa(8)*tc0*cse(16)*cse(16) + sa(9)*tc0*tc0*tc0 & - + sa(10)*cse(16)*cse(16)*cse(16) - a_ = 10.0**loga_ - b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(16) + sb(4)*tc0*cse(16) & - + sb(5)*tc0*tc0 + sb(6)*cse(16)*cse(16) & - + sb(7)*tc0*tc0*cse(16) + sb(8)*tc0*cse(16)*cse(16) & - + sb(9)*tc0*tc0*tc0 + sb(10)*cse(16)*cse(16)*cse(16) - smof(k) = a_ * smo2(k)**b_ - - enddo - -!+---+-----------------------------------------------------------------+ -!..Calculate y-intercept, slope values for graupel. -!+---+-----------------------------------------------------------------+ - N0_min = gonv_max - do k = kte, kts, -1 -!-GT if (.not. L_qg(k)) CYCLE -!-GT N0_exp = 100.0*rho(k)/rg(k) -!-GT N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max))) - N0_exp = (gonv_max-gonv_min)*0.5D0 & - * tanh((0.15E-3-rg(k))/0.15E-3) & - + (gonv_max+gonv_min)*0.5D0 - N0_min = MIN(N0_exp, N0_min) - N0_exp = N0_min - lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1 - lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg - ilamg(k) = 1./lamg - N0_g(k) = N0_exp/(cgg(2)*lam_exp) * lamg**cge(2) - enddo - - endif - -!+---+-----------------------------------------------------------------+ -!..Calculate y-intercept, slope values for rain. -!+---+-----------------------------------------------------------------+ - do k = kte, kts, -1 - lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr - ilamr(k) = 1./lamr - mvd_r(k) = (3.0 + mu_r + 0.672) / lamr - N0_r(k) = nr(k)*org2*lamr**cre(2) - enddo - -!+---+-----------------------------------------------------------------+ -!..Compute warm-rain process terms (except evap done later). -!+---+-----------------------------------------------------------------+ - - do k = kts, kte - -!..Rain self-collection (follows Seifert 1994 - checked against my own -!.. explicit/bin scheme and appears very good). RAIN2M - if (L_qr(k) .and. mvd_r(k).gt. D0r) then - pnr_rcr(k) = 8.*nr(k)*rr(k) - endif - - if (.not. L_qc(k)) CYCLE - xDc = MAX(D0c*1.E6, ((rc(k)/(am_r*Nt_c))**obmr) * 1.E6) - lamc = (Nt_c*am_r* ccg(2) * ocg1 / rc(k))**obmr - mvd_c(k) = (3.0+mu_c+0.672) / lamc - -!..Autoconversion follows Berry & Reinhardt (1974) with characteristic -!.. diameters correctly computed from gamma distrib of cloud droplets. - if (rc(k).gt. 0.01e-3) then - Dc_g = ((ccg(3)*ocg2)**obmr / lamc) * 1.E6 - Dc_b = (xDc*xDc*xDc*Dc_g*Dc_g*Dc_g - xDc*xDc*xDc*xDc*xDc*xDc) & - **(1./6.) - zeta1 = 0.5*((6.25E-6*xDc*Dc_b*Dc_b*Dc_b - 0.4) & - + abs(6.25E-6*xDc*Dc_b*Dc_b*Dc_b - 0.4)) - zeta = 0.027*rc(k)*zeta1 - taud = 0.5*((0.5*Dc_b - 7.5) + abs(0.5*Dc_b - 7.5)) + R1 - tau = 3.72/(rc(k)*taud) - prr_wau(k) = zeta/tau - prr_wau(k) = MIN(DBLE(rc(k)*odts), prr_wau(k)) - pnr_wau(k) = prr_wau(k) / (am_r*mu_c/3.*D0r*D0r*D0r/rho(k)) ! RAIN2M - endif - -!..Rain collecting cloud water. In CE, assume Dc<1). Either way, only bother to do sedimentation below -!.. 1st level that contains any sedimenting particles (k=ksed1 on down). -!.. New in v3.0+ is computing separate for rain, ice, snow, and -!.. graupel species thus making code faster with credit to J. Schmidt. -!+---+-----------------------------------------------------------------+ - nstep = 0 - onstep(1) = 1.0 - ksed1(1) = 0 - do k = kte+1, kts, -1 - vtrk(k) = 0. - vtnrk(k) = 0. - vtik(k) = 0. - vtnik(k) = 0. - vtsk(k) = 0. - vtgk(k) = 0. - enddo - do k = kte, kts, -1 - vtr = 0. - rhof(k) = SQRT(RHO_NOT/rho(k)) - - if (rr(k).gt. R2) then - lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr - vtr = rhof(k)*av_r*crg(6)*org3 * lamr**cre(3) & - *((lamr+fv_r)**(-cre(6))) - vtrk(k) = vtr -! First below is technically correct: -! vtr = rhof(k)*av_r*crg(5)*org2 * lamr**cre(2) & -! *((lamr+fv_r)**(-cre(5))) -! Test: make number fall faster (but still slower than mass) -! Goal: less prominent size sorting - vtr = rhof(k)*av_r*crg(7)/crg(12) * lamr**cre(12) & - *((lamr+fv_r)**(-cre(7))) - vtnrk(k) = vtr - endif - - if (MAX(vtrk(k),vtnrk(k)) .gt. 1.E-3) then - ksed1(1) = MAX(ksed1(1), k) - delta_tp = dzq(k)/(MAX(vtrk(k),vtnrk(k))) - nstep = MAX(nstep, INT(DT/delta_tp + 1.)) - endif - enddo - if (ksed1(1) .eq. kte) ksed1(1) = kte-1 - if (nstep .gt. 0) onstep(1) = 1./REAL(nstep) - -!+---+-----------------------------------------------------------------+ - - if (.not. iiwarm) then - - nstep = 0 - onstep(2) = 1.0 - ksed1(2) = 0 - do k = kte, kts, -1 - vti = 0. - - if (ri(k).gt. R2) then - lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi - ilami = 1./lami - vti = rhof(k)*av_i*cig(3)*oig2 * ilami**bv_i - vtik(k) = vti - vti = rhof(k)*av_i*cig(4)*oig1 * ilami**bv_i - vtnik(k) = vti - endif - - if (vtik(k) .gt. 1.E-3) then - ksed1(2) = MAX(ksed1(2), k) - delta_tp = dzq(k)/vtik(k) - nstep = MAX(nstep, INT(DT/delta_tp + 1.)) - endif - enddo - if (ksed1(2) .eq. kte) ksed1(2) = kte-1 - if (nstep .gt. 0) onstep(2) = 1./REAL(nstep) - -!+---+-----------------------------------------------------------------+ - - nstep = 0 - onstep(3) = 1.0 - ksed1(3) = 0 - do k = kte, kts, -1 - vts = 0. - - if (rs(k).gt. R2) then - xDs = smoc(k) / smob(k) - Mrat = 1./xDs - ils1 = 1./(Mrat*Lam0 + fv_s) - ils2 = 1./(Mrat*Lam1 + fv_s) - t1_vts = Kap0*csg(4)*ils1**cse(4) - t2_vts = Kap1*Mrat**mu_s*csg(10)*ils2**cse(10) - t3_vts = Kap0*csg(1)*ils1**cse(1) - t4_vts = Kap1*Mrat**mu_s*csg(7)*ils2**cse(7) - vts = rhof(k)*av_s * (t1_vts+t2_vts)/(t3_vts+t4_vts) - if (temp(k).gt. T_0) then - vtsk(k) = MAX(vts*vts_boost(k), vtrk(k)) - else - vtsk(k) = vts*vts_boost(k) - endif - endif - - if (vtsk(k) .gt. 1.E-3) then - ksed1(3) = MAX(ksed1(3), k) - delta_tp = dzq(k)/vtsk(k) - nstep = MAX(nstep, INT(DT/delta_tp + 1.)) - endif - enddo - if (ksed1(3) .eq. kte) ksed1(3) = kte-1 - if (nstep .gt. 0) onstep(3) = 1./REAL(nstep) - -!+---+-----------------------------------------------------------------+ - - nstep = 0 - onstep(4) = 1.0 - ksed1(4) = 0 - do k = kte, kts, -1 - vtg = 0. - - if (rg(k).gt. R2) then - vtg = rhof(k)*av_g*cgg(6)*ogg3 * ilamg(k)**bv_g - if (temp(k).gt. T_0) then - vtgk(k) = MAX(vtg, vtrk(k)) - else - vtgk(k) = vtg - endif - endif - - if (vtgk(k) .gt. 1.E-3) then - ksed1(4) = MAX(ksed1(4), k) - delta_tp = dzq(k)/vtgk(k) - nstep = MAX(nstep, INT(DT/delta_tp + 1.)) - endif - enddo - if (ksed1(4) .eq. kte) ksed1(4) = kte-1 - if (nstep .gt. 0) onstep(4) = 1./REAL(nstep) - endif - -!+---+-----------------------------------------------------------------+ -!..Sedimentation of mixing ratio is the integral of v(D)*m(D)*N(D)*dD, -!.. whereas neglect m(D) term for number concentration. Therefore, -!.. cloud ice has proper differential sedimentation. -!.. New in v3.0+ is computing separate for rain, ice, snow, and -!.. graupel species thus making code faster with credit to J. Schmidt. -!+---+-----------------------------------------------------------------+ - - nstep = NINT(1./onstep(1)) - do n = 1, nstep - do k = kte, kts, -1 - sed_r(k) = vtrk(k)*rr(k) - sed_n(k) = vtnrk(k)*nr(k) - enddo - k = kte - odzq = 1./dzq(k) - orho = 1./rho(k) - qrten(k) = qrten(k) - sed_r(k)*odzq*onstep(1)*orho - nrten(k) = nrten(k) - sed_n(k)*odzq*onstep(1)*orho - rr(k) = MAX(R1, rr(k) - sed_r(k)*odzq*DT*onstep(1)) - nr(k) = MAX(1., nr(k) - sed_n(k)*odzq*DT*onstep(1)) - do k = ksed1(1), kts, -1 - odzq = 1./dzq(k) - orho = 1./rho(k) - qrten(k) = qrten(k) + (sed_r(k+1)-sed_r(k)) & - *odzq*onstep(1)*orho - nrten(k) = nrten(k) + (sed_n(k+1)-sed_n(k)) & - *odzq*onstep(1)*orho - rr(k) = MAX(R1, rr(k) + (sed_r(k+1)-sed_r(k)) & - *odzq*DT*onstep(1)) - nr(k) = MAX(1., nr(k) + (sed_n(k+1)-sed_n(k)) & - *odzq*DT*onstep(1)) - enddo - - pptrain = pptrain + sed_r(kts)*DT*onstep(1) - enddo - -!+---+-----------------------------------------------------------------+ - - nstep = NINT(1./onstep(2)) - do n = 1, nstep - do k = kte, kts, -1 - sed_i(k) = vtik(k)*ri(k) - sed_n(k) = vtnik(k)*ni(k) - enddo - k = kte - odzq = 1./dzq(k) - orho = 1./rho(k) - qiten(k) = qiten(k) - sed_i(k)*odzq*onstep(2)*orho - niten(k) = niten(k) - sed_n(k)*odzq*onstep(2)*orho - ri(k) = MAX(R1, ri(k) - sed_i(k)*odzq*DT*onstep(2)) - ni(k) = MAX(1., ni(k) - sed_n(k)*odzq*DT*onstep(2)) - do k = ksed1(2), kts, -1 - odzq = 1./dzq(k) - orho = 1./rho(k) - qiten(k) = qiten(k) + (sed_i(k+1)-sed_i(k)) & - *odzq*onstep(2)*orho - niten(k) = niten(k) + (sed_n(k+1)-sed_n(k)) & - *odzq*onstep(2)*orho - ri(k) = MAX(R1, ri(k) + (sed_i(k+1)-sed_i(k)) & - *odzq*DT*onstep(2)) - ni(k) = MAX(1., ni(k) + (sed_n(k+1)-sed_n(k)) & - *odzq*DT*onstep(2)) - enddo - - pptice = pptice + sed_i(kts)*DT*onstep(2) - enddo - -!+---+-----------------------------------------------------------------+ - - nstep = NINT(1./onstep(3)) - do n = 1, nstep - do k = kte, kts, -1 - sed_s(k) = vtsk(k)*rs(k) - enddo - k = kte - odzq = 1./dzq(k) - orho = 1./rho(k) - qsten(k) = qsten(k) - sed_s(k)*odzq*onstep(3)*orho - rs(k) = MAX(R1, rs(k) - sed_s(k)*odzq*DT*onstep(3)) - do k = ksed1(3), kts, -1 - odzq = 1./dzq(k) - orho = 1./rho(k) - qsten(k) = qsten(k) + (sed_s(k+1)-sed_s(k)) & - *odzq*onstep(3)*orho - rs(k) = MAX(R1, rs(k) + (sed_s(k+1)-sed_s(k)) & - *odzq*DT*onstep(3)) - enddo - - pptsnow = pptsnow + sed_s(kts)*DT*onstep(3) - enddo - -!+---+-----------------------------------------------------------------+ - - nstep = NINT(1./onstep(4)) - do n = 1, nstep - do k = kte, kts, -1 - sed_g(k) = vtgk(k)*rg(k) - enddo - k = kte - odzq = 1./dzq(k) - orho = 1./rho(k) - qgten(k) = qgten(k) - sed_g(k)*odzq*onstep(4)*orho - rg(k) = MAX(R1, rg(k) - sed_g(k)*odzq*DT*onstep(4)) - do k = ksed1(4), kts, -1 - odzq = 1./dzq(k) - orho = 1./rho(k) - qgten(k) = qgten(k) + (sed_g(k+1)-sed_g(k)) & - *odzq*onstep(4)*orho - rg(k) = MAX(R1, rg(k) + (sed_g(k+1)-sed_g(k)) & - *odzq*DT*onstep(4)) - enddo - - pptgraul = pptgraul + sed_g(kts)*DT*onstep(4) - enddo - -!+---+-----------------------------------------------------------------+ -!.. Instantly melt any cloud ice into cloud water if above 0C and -!.. instantly freeze any cloud water found below HGFR. -!+---+-----------------------------------------------------------------+ - if (.not. iiwarm) then - do k = kts, kte - xri = MAX(0.0, qi1d(k) + qiten(k)*DT) - if ( (temp(k).gt. T_0) .and. (xri.gt. 0.0) ) then - qcten(k) = qcten(k) + xri*odt - qiten(k) = -qi1d(k)*odt - niten(k) = -ni1d(k)*odt - tten(k) = tten(k) - lfus*ocp(k)*xri*odt*(1-IFDRY) - endif - - xrc = MAX(0.0, qc1d(k) + qcten(k)*DT) - if ( (temp(k).lt. HGFR) .and. (xrc.gt. 0.0) ) then - lfus2 = lsub - lvap(k) - qiten(k) = qiten(k) + xrc*odt - niten(k) = niten(k) + xrc/(2.*xm0i)*odt - qcten(k) = -xrc*odt - tten(k) = tten(k) + lfus2*ocp(k)*xrc*odt*(1-IFDRY) - endif - enddo - endif - -!+---+-----------------------------------------------------------------+ -!.. All tendencies computed, apply and pass back final values to parent. -!+---+-----------------------------------------------------------------+ - do k = kts, kte - t1d(k) = t1d(k) + tten(k)*DT - qv1d(k) = MAX(1.E-10, qv1d(k) + qvten(k)*DT) - qc1d(k) = qc1d(k) + qcten(k)*DT - if (qc1d(k) .le. R1) qc1d(k) = 0.0 - qi1d(k) = qi1d(k) + qiten(k)*DT - ni1d(k) = ni1d(k) + niten(k)*DT - if (qi1d(k) .le. R1) then - qi1d(k) = 0.0 - ni1d(k) = 0.0 - else - if (ni1d(k) .gt. 1.0) then - lami = (am_i*cig(2)*oig1*ni1d(k)/qi1d(k))**obmi - ilami = 1./lami - xDi = (bm_i + mu_i + 1.) * ilami - if (xDi.lt. 30.E-6) then - lami = cie(2)/30.E-6 - elseif (xDi.gt. 300.E-6) then - lami = cie(2)/300.E-6 - endif - else - lami = cie(2)/D0s - endif - ni1d(k) = MIN(cig(1)*oig2*qi1d(k)/am_i*lami**bm_i, & - 250.D3/rho(k)) - endif - qr1d(k) = qr1d(k) + qrten(k)*DT - nr1d(k) = nr1d(k) + nrten(k)*DT - if (qr1d(k) .le. R1) then - qr1d(k) = 0.0 - nr1d(k) = 0.0 - else - if (nr1d(k) .gt. 1.0) then - lamr = (am_r*crg(3)*org2*nr1d(k)/qr1d(k))**obmr - mvd_r(k) = (3.0 + mu_r + 0.672) / lamr - if (mvd_r(k) .gt. 2.5E-3) then - mvd_r(k) = 2.5E-3 - elseif (mvd_r(k) .lt. D0r*0.75) then - mvd_r(k) = D0r*0.75 - endif - else - if (qr1d(k) .gt. R2) then - mvd_r(k) = 2.5E-3 - else - mvd_r(k) = 2.5E-3 / 3.0**(ALOG10(R2)-ALOG10(qr1d(k))) - endif - endif - lamr = (3.0 + mu_r + 0.672) / mvd_r(k) - nr1d(k) = crg(2)*org3*qr1d(k)*lamr**bm_r / am_r - endif - qs1d(k) = qs1d(k) + qsten(k)*DT - if (qs1d(k) .le. R1) qs1d(k) = 0.0 - qg1d(k) = qg1d(k) + qgten(k)*DT - if (qg1d(k) .le. R1) qg1d(k) = 0.0 - enddo - - end subroutine mp_thompson -!+---+-----------------------------------------------------------------+ -! -!+---+-----------------------------------------------------------------+ -!..Creation of the lookup tables and support functions found below here. -!+---+-----------------------------------------------------------------+ -!..Rain collecting graupel (and inverse). Explicit CE integration. -!+---+-----------------------------------------------------------------+ - - subroutine qr_acr_qg - - implicit none - -!..Local variables - INTEGER:: i, j, k, n, n2 - DOUBLE PRECISION, DIMENSION(nbg):: vg, N_g - DOUBLE PRECISION, DIMENSION(nbr):: vr, N_r - DOUBLE PRECISION:: N0_exp, N0_r, N0_g, lam_exp, lamg, lamr - DOUBLE PRECISION:: massg, massr, dvg, dvr, t1, t2, z1, z2, y1, y2 - -!+---+ - - do n2 = 1, nbr - vr(n2) = av_r*Dr(n2)**bv_r * DEXP(-fv_r*Dr(n2)) - enddo - do n = 1, nbg - vg(n) = av_g*Dg(n)**bv_g - enddo - - do k = 1, ntb_r - do j = 1, ntb_r1 - - lam_exp = (N0r_exp(j)*am_r*crg(1)/r_r(k))**ore1 - lamr = lam_exp * (crg(3)*org2*org1)**obmr - N0_r = N0r_exp(j)/(crg(2)*lam_exp) * lamr**cre(2) - do n2 = 1, nbr - N_r(n2) = N0_r*Dr(n2)**mu_r *DEXP(-lamr*Dr(n2))*dtr(n2) - enddo - - do i = 1, ntb_g -!-GT N0_exp = 100.0d0/r_g(i) -!-GT N0_exp = DMAX1(gonv_min*1.d0,DMIN1(N0_exp,gonv_max*1.d0)) - N0_exp = (gonv_max-gonv_min)*0.5D0 & - * tanh((0.15E-3-r_g(i))/0.15E-3) & - + (gonv_max+gonv_min)*0.5D0 - lam_exp = (N0_exp*am_g*cgg(1)/r_g(i))**oge1 - lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg - N0_g = N0_exp/(cgg(2)*lam_exp) * lamg**cge(2) - do n = 1, nbg - N_g(n) = N0_g*Dg(n)**mu_g * DEXP(-lamg*Dg(n))*dtg(n) - enddo - - t1 = 0.0d0 - t2 = 0.0d0 - z1 = 0.0d0 - z2 = 0.0d0 - y1 = 0.0d0 - y2 = 0.0d0 - do n2 = 1, nbr - massr = am_r * Dr(n2)**bm_r - do n = 1, nbg - massg = am_g * Dg(n)**bm_g - - dvg = 0.5d0*((vr(n2) - vg(n)) + DABS(vr(n2)-vg(n))) - dvr = 0.5d0*((vg(n) - vr(n2)) + DABS(vg(n)-vr(n2))) - - t1 = t1+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & - *dvg*massg * N_g(n)* N_r(n2) - z1 = z1+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & - *dvg*massr * N_g(n)* N_r(n2) - y1 = y1+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & - *dvg * N_g(n)* N_r(n2) - - t2 = t2+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & - *dvr*massr * N_g(n)* N_r(n2) - y2 = y2+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & - *dvr * N_g(n)* N_r(n2) - z2 = z2+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & - *dvr*massg * N_g(n)* N_r(n2) - enddo - 97 continue - enddo - tcg_racg(i,j,k) = t1 - tmr_racg(i,j,k) = DMIN1(z1, r_r(k)*1.0d0) - tcr_gacr(i,j,k) = t2 - tmg_gacr(i,j,k) = z2 - tnr_racg(i,j,k) = y1 - tnr_gacr(i,j,k) = y2 - enddo - enddo - enddo - - end subroutine qr_acr_qg -!+---+-----------------------------------------------------------------+ -! -!+---+-----------------------------------------------------------------+ -!..Rain collecting snow (and inverse). Explicit CE integration. -!+---+-----------------------------------------------------------------+ - - subroutine qr_acr_qs - - implicit none - -!..Local variables - INTEGER:: i, j, k, m, n, n2 - DOUBLE PRECISION, DIMENSION(nbr):: vr, D1, N_r - DOUBLE PRECISION, DIMENSION(nbs):: vs, N_s - DOUBLE PRECISION:: loga_, a_, b_, second, M0, M2, M3, Mrat, oM3 - DOUBLE PRECISION:: N0_r, lam_exp, lamr, slam1, slam2 - DOUBLE PRECISION:: dvs, dvr, masss, massr - DOUBLE PRECISION:: t1, t2, t3, t4, z1, z2, z3, z4 - DOUBLE PRECISION:: y1, y2, y3, y4 - -!+---+ - - do n2 = 1, nbr - vr(n2) = av_r*Dr(n2)**bv_r * DEXP(-fv_r*Dr(n2)) - D1(n2) = (vr(n2)/av_s)**(1./bv_s) - enddo - do n = 1, nbs - vs(n) = 1.5*av_s*Ds(n)**bv_s * DEXP(-fv_s*Ds(n)) - enddo - - do m = 1, ntb_r - do k = 1, ntb_r1 - lam_exp = (N0r_exp(k)*am_r*crg(1)/r_r(m))**ore1 - lamr = lam_exp * (crg(3)*org2*org1)**obmr - N0_r = N0r_exp(k)/(crg(2)*lam_exp) * lamr**cre(2) - do n2 = 1, nbr - N_r(n2) = N0_r*Dr(n2)**mu_r * DEXP(-lamr*Dr(n2))*dtr(n2) - enddo - - do j = 1, ntb_t - do i = 1, ntb_s - -!..From the bm_s moment, compute plus one moment. If we are not -!.. using bm_s=2, then we must transform to the pure 2nd moment -!.. (variable called "second") and then to the bm_s+1 moment. - - M2 = r_s(i)*oams *1.0d0 - if (bm_s.gt.2.0-1.E-3 .and. bm_s.lt.2.0+1.E-3) then - loga_ = sa(1) + sa(2)*Tc(j) + sa(3)*bm_s & - + sa(4)*Tc(j)*bm_s + sa(5)*Tc(j)*Tc(j) & - + sa(6)*bm_s*bm_s + sa(7)*Tc(j)*Tc(j)*bm_s & - + sa(8)*Tc(j)*bm_s*bm_s + sa(9)*Tc(j)*Tc(j)*Tc(j) & - + sa(10)*bm_s*bm_s*bm_s - a_ = 10.0**loga_ - b_ = sb(1) + sb(2)*Tc(j) + sb(3)*bm_s & - + sb(4)*Tc(j)*bm_s + sb(5)*Tc(j)*Tc(j) & - + sb(6)*bm_s*bm_s + sb(7)*Tc(j)*Tc(j)*bm_s & - + sb(8)*Tc(j)*bm_s*bm_s + sb(9)*Tc(j)*Tc(j)*Tc(j) & - + sb(10)*bm_s*bm_s*bm_s - second = (M2/a_)**(1./b_) - else - second = M2 - endif - - loga_ = sa(1) + sa(2)*Tc(j) + sa(3)*cse(1) & - + sa(4)*Tc(j)*cse(1) + sa(5)*Tc(j)*Tc(j) & - + sa(6)*cse(1)*cse(1) + sa(7)*Tc(j)*Tc(j)*cse(1) & - + sa(8)*Tc(j)*cse(1)*cse(1) + sa(9)*Tc(j)*Tc(j)*Tc(j) & - + sa(10)*cse(1)*cse(1)*cse(1) - a_ = 10.0**loga_ - b_ = sb(1)+sb(2)*Tc(j)+sb(3)*cse(1) + sb(4)*Tc(j)*cse(1) & - + sb(5)*Tc(j)*Tc(j) + sb(6)*cse(1)*cse(1) & - + sb(7)*Tc(j)*Tc(j)*cse(1) + sb(8)*Tc(j)*cse(1)*cse(1) & - + sb(9)*Tc(j)*Tc(j)*Tc(j)+sb(10)*cse(1)*cse(1)*cse(1) - M3 = a_ * second**b_ - - oM3 = 1./M3 - Mrat = M2*(M2*oM3)*(M2*oM3)*(M2*oM3) - M0 = (M2*oM3)**mu_s - slam1 = M2 * oM3 * Lam0 - slam2 = M2 * oM3 * Lam1 - - do n = 1, nbs - N_s(n) = Mrat*(Kap0*DEXP(-slam1*Ds(n)) & - + Kap1*M0*Ds(n)**mu_s * DEXP(-slam2*Ds(n)))*dts(n) - enddo - - t1 = 0.0d0 - t2 = 0.0d0 - t3 = 0.0d0 - t4 = 0.0d0 - z1 = 0.0d0 - z2 = 0.0d0 - z3 = 0.0d0 - z4 = 0.0d0 - y1 = 0.0d0 - y2 = 0.0d0 - y3 = 0.0d0 - y4 = 0.0d0 - do n2 = 1, nbr - massr = am_r * Dr(n2)**bm_r - do n = 1, nbs - masss = am_s * Ds(n)**bm_s - - dvs = 0.5d0*((vr(n2) - vs(n)) + DABS(vr(n2)-vs(n))) - dvr = 0.5d0*((vs(n) - vr(n2)) + DABS(vs(n)-vr(n2))) - - if (massr .gt. masss) then - t1 = t1+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & - *dvs*masss * N_s(n)* N_r(n2) - z1 = z1+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & - *dvs*massr * N_s(n)* N_r(n2) - y1 = y1+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & - *dvs * N_s(n)* N_r(n2) - else - t3 = t3+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & - *dvs*masss * N_s(n)* N_r(n2) - z3 = z3+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & - *dvs*massr * N_s(n)* N_r(n2) - y3 = y3+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & - *dvs * N_s(n)* N_r(n2) - endif - - if (massr .gt. masss) then - t2 = t2+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & - *dvr*massr * N_s(n)* N_r(n2) - y2 = y2+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & - *dvr * N_s(n)* N_r(n2) - z2 = z2+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & - *dvr*masss * N_s(n)* N_r(n2) - else - t4 = t4+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & - *dvr*massr * N_s(n)* N_r(n2) - y4 = y4+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & - *dvr * N_s(n)* N_r(n2) - z4 = z4+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & - *dvr*masss * N_s(n)* N_r(n2) - endif - - enddo - enddo - tcs_racs1(i,j,k,m) = t1 - tmr_racs1(i,j,k,m) = DMIN1(z1, r_r(m)*1.0d0) - tcs_racs2(i,j,k,m) = t3 - tmr_racs2(i,j,k,m) = z3 - tcr_sacr1(i,j,k,m) = t2 - tms_sacr1(i,j,k,m) = z2 - tcr_sacr2(i,j,k,m) = t4 - tms_sacr2(i,j,k,m) = z4 - tnr_racs1(i,j,k,m) = y1 - tnr_racs2(i,j,k,m) = y3 - tnr_sacr1(i,j,k,m) = y2 - tnr_sacr2(i,j,k,m) = y4 - enddo - enddo - enddo - enddo - - end subroutine qr_acr_qs -!+---+-----------------------------------------------------------------+ -! -!+---+-----------------------------------------------------------------+ -!..This is a literal adaptation of Bigg (1954) probability of drops of -!..a particular volume freezing. Given this probability, simply freeze -!..the proportion of drops summing their masses. -!+---+-----------------------------------------------------------------+ - - subroutine freezeH2O - - implicit none - -!..Local variables - INTEGER:: i, j, k, n, n2 - DOUBLE PRECISION, DIMENSION(nbr):: N_r, massr - DOUBLE PRECISION, DIMENSION(nbc):: N_c, massc - DOUBLE PRECISION:: sum1, sum2, sumn1, sumn2, & - prob, vol, Texp, orho_w, & - lam_exp, lamr, N0_r, lamc, N0_c, y - -!+---+ - - orho_w = 1./rho_w - - do n2 = 1, nbr - massr(n2) = am_r*Dr(n2)**bm_r - enddo - do n = 1, nbc - massc(n) = am_r*Dc(n)**bm_r - enddo - -!..Freeze water (smallest drops become cloud ice, otherwise graupel). - do k = 1, 45 -! print*, ' Freezing water for temp = ', -k - Texp = DEXP( DFLOAT(k) ) - 1.0D0 - do j = 1, ntb_r1 - do i = 1, ntb_r - lam_exp = (N0r_exp(j)*am_r*crg(1)/r_r(i))**ore1 - lamr = lam_exp * (crg(3)*org2*org1)**obmr - N0_r = N0r_exp(j)/(crg(2)*lam_exp) * lamr**cre(2) - sum1 = 0.0d0 - sum2 = 0.0d0 - sumn1 = 0.0d0 - sumn2 = 0.0d0 - do n2 = 1, nbr - N_r(n2) = N0_r*Dr(n2)**mu_r*DEXP(-lamr*Dr(n2))*dtr(n2) - vol = massr(n2)*orho_w - prob = 1.0D0 - DEXP(-120.0D0*vol*5.2D-4 * Texp) - if (massr(n2) .lt. xm0g) then - sumn1 = sumn1 + prob*N_r(n2) - sum1 = sum1 + prob*N_r(n2)*massr(n2) - else - sumn2 = sumn2 + prob*N_r(n2) - sum2 = sum2 + prob*N_r(n2)*massr(n2) - endif - enddo - tpi_qrfz(i,j,k) = sum1 - tni_qrfz(i,j,k) = sumn1 - tpg_qrfz(i,j,k) = sum2 - tnr_qrfz(i,j,k) = sumn2 - enddo - enddo - do i = 1, ntb_c - lamc = 1.0D-6 * (Nt_c*am_r* ccg(2) * ocg1 / r_c(i))**obmr - N0_c = 1.0D-18 * Nt_c*ocg1 * lamc**cce(1) - sum1 = 0.0d0 - sumn2 = 0.0d0 - do n = 1, nbc - y = Dc(n)*1.0D6 - vol = massc(n)*orho_w - prob = 1.0D0 - DEXP(-120.0D0*vol*5.2D-4 * Texp) - N_c(n) = N0_c* y**mu_c * EXP(-lamc*y)*dtc(n) - N_c(n) = 1.0D24 * N_c(n) - sumn2 = sumn2 + prob*N_c(n) - sum1 = sum1 + prob*N_c(n)*massc(n) - enddo - tpi_qcfz(i,k) = sum1 - tni_qcfz(i,k) = sumn2 - enddo - enddo - - end subroutine freezeH2O -!+---+-----------------------------------------------------------------+ -! -!+---+-----------------------------------------------------------------+ -!..Cloud ice converting to snow since portion greater than min snow -!.. size. Given cloud ice content (kg/m**3), number concentration -!.. (#/m**3) and gamma shape parameter, mu_i, break the distrib into -!.. bins and figure out the mass/number of ice with sizes larger than -!.. D0s. Also, compute incomplete gamma function for the integration -!.. of ice depositional growth from diameter=0 to D0s. Amount of -!.. ice depositional growth is this portion of distrib while larger -!.. diameters contribute to snow growth (as in Harrington et al. 1995). -!+---+-----------------------------------------------------------------+ - - subroutine qi_aut_qs - - implicit none - -!..Local variables - INTEGER:: i, j, n2 - DOUBLE PRECISION, DIMENSION(nbi):: N_i - DOUBLE PRECISION:: N0_i, lami, Di_mean, t1, t2 - -!+---+ - - do j = 1, ntb_i1 - do i = 1, ntb_i - lami = (am_i*cig(2)*oig1*Nt_i(j)/r_i(i))**obmi - Di_mean = (bm_i + mu_i + 1.) / lami - N0_i = Nt_i(j)*oig1 * lami**cie(1) - t1 = 0.0d0 - t2 = 0.0d0 - if (SNGL(Di_mean) .gt. 5.*D0s) then - t1 = r_i(i) - t2 = Nt_i(j) - tpi_ide(i,j) = 0.0D0 - elseif (SNGL(Di_mean) .lt. D0i) then - t1 = 0.0D0 - t2 = 0.0D0 - tpi_ide(i,j) = 1.0D0 - else - tpi_ide(i,j) = GAMMP(mu_i+2.0, SNGL(lami)*D0s) * 1.0D0 - do n2 = 1, nbi - N_i(n2) = N0_i*Di(n2)**mu_i * DEXP(-lami*Di(n2))*dti(n2) - if (Di(n2).ge.D0s) then - t1 = t1 + N_i(n2) * am_i*Di(n2)**bm_i - t2 = t2 + N_i(n2) - endif - enddo - endif - tps_iaus(i,j) = t1 - tni_iaus(i,j) = t2 - enddo - enddo - - end subroutine qi_aut_qs -! -!+---+-----------------------------------------------------------------+ -!..Variable collision efficiency for rain collecting cloud water using -!.. method of Beard and Grover, 1974 if a/A less than 0.25; otherwise -!.. uses polynomials to get close match of Pruppacher & Klett Fig 14-9. -!+---+-----------------------------------------------------------------+ - - subroutine table_Efrw - - implicit none - -!..Local variables - DOUBLE PRECISION:: vtr, stokes, reynolds, Ef_rw - DOUBLE PRECISION:: p, yc0, F, G, H, z, K0, X - INTEGER:: i, j - - do j = 1, nbc - do i = 1, nbr - Ef_rw = 0.0 - p = Dc(j)/Dr(i) - if (Dr(i).lt.50.E-6 .or. Dc(j).lt.3.E-6) then - t_Efrw(i,j) = 0.0 - elseif (p.gt.0.25) then - X = Dc(j)*1.D6 - if (Dr(i) .lt. 75.e-6) then - Ef_rw = 0.026794*X - 0.20604 - elseif (Dr(i) .lt. 125.e-6) then - Ef_rw = -0.00066842*X*X + 0.061542*X - 0.37089 - elseif (Dr(i) .lt. 175.e-6) then - Ef_rw = 4.091e-06*X*X*X*X - 0.00030908*X*X*X & - + 0.0066237*X*X - 0.0013687*X - 0.073022 - elseif (Dr(i) .lt. 250.e-6) then - Ef_rw = 9.6719e-5*X*X*X - 0.0068901*X*X + 0.17305*X & - - 0.65988 - elseif (Dr(i) .lt. 350.e-6) then - Ef_rw = 9.0488e-5*X*X*X - 0.006585*X*X + 0.16606*X & - - 0.56125 - else - Ef_rw = 0.00010721*X*X*X - 0.0072962*X*X + 0.1704*X & - - 0.46929 - endif - else - vtr = -0.1021 + 4.932E3*Dr(i) - 0.9551E6*Dr(i)*Dr(i) & - + 0.07934E9*Dr(i)*Dr(i)*Dr(i) & - - 0.002362E12*Dr(i)*Dr(i)*Dr(i)*Dr(i) - stokes = Dc(j)*Dc(j)*vtr*rho_w/(9.*1.718E-5*Dr(i)) - reynolds = 9.*stokes/(p*p*rho_w) - - F = DLOG(reynolds) - G = -0.1007D0 - 0.358D0*F + 0.0261D0*F*F - K0 = DEXP(G) - z = DLOG(stokes/(K0+1.D-15)) - H = 0.1465D0 + 1.302D0*z - 0.607D0*z*z + 0.293D0*z*z*z - yc0 = 2.0D0/PI * ATAN(H) - Ef_rw = (yc0+p)*(yc0+p) / ((1.+p)*(1.+p)) - - endif - - t_Efrw(i,j) = MAX(0.0, MIN(SNGL(Ef_rw), 0.95)) - - enddo - enddo - - end subroutine table_Efrw -! -!+---+-----------------------------------------------------------------+ -!..Variable collision efficiency for snow collecting cloud water using -!.. method of Wang and Ji, 2000 except equate melted snow diameter to -!.. their "effective collision cross-section." -!+---+-----------------------------------------------------------------+ - - subroutine table_Efsw - - implicit none - -!..Local variables - DOUBLE PRECISION:: Ds_m, vts, vtc, stokes, reynolds, Ef_sw - DOUBLE PRECISION:: p, yc0, F, G, H, z, K0 - INTEGER:: i, j - - do j = 1, nbc - vtc = 1.19D4 * (1.0D4*Dc(j)*Dc(j)*0.25D0) - do i = 1, nbs - vts = av_s*Ds(i)**bv_s * DEXP(-fv_s*Ds(i)) - vtc - Ds_m = (am_s*Ds(i)**bm_s / am_r)**obmr - p = Dc(j)/Ds_m - if (p.gt.0.25 .or. Ds(i).lt.D0s .or. Dc(j).lt.6.E-6 & - .or. vts.lt.1.E-3) then - t_Efsw(i,j) = 0.0 - else - stokes = Dc(j)*Dc(j)*vts*rho_w/(9.*1.718E-5*Ds_m) - reynolds = 9.*stokes/(p*p*rho_w) - - F = DLOG(reynolds) - G = -0.1007D0 - 0.358D0*F + 0.0261D0*F*F - K0 = DEXP(G) - z = DLOG(stokes/(K0+1.D-15)) - H = 0.1465D0 + 1.302D0*z - 0.607D0*z*z + 0.293D0*z*z*z - yc0 = 2.0D0/PI * ATAN(H) - Ef_sw = (yc0+p)*(yc0+p) / ((1.+p)*(1.+p)) - - t_Efsw(i,j) = MAX(0.0, MIN(SNGL(Ef_sw), 0.95)) - endif - - enddo - enddo - - end subroutine table_Efsw -! -!+---+-----------------------------------------------------------------+ -!..Integrate rain size distribution from zero to D-star to compute the -!.. number of drops smaller than D-star that evaporate in a single -!.. timestep. Drops larger than D-star dont evaporate entirely so do -!.. not affect number concentration. -!+---+-----------------------------------------------------------------+ - - subroutine table_dropEvap - - implicit none - -!..Local variables - DOUBLE PRECISION:: Nt_r, N0, lam_exp, lam - INTEGER:: i, j, k - - do k = 1, ntb_r - do j = 1, ntb_r1 - lam_exp = (N0r_exp(j)*am_r*crg(1)/r_r(k))**ore1 - lam = lam_exp * (crg(3)*org2*org1)**obmr - N0 = N0r_exp(j)/(crg(2)*lam_exp) * lam**cre(2) - Nt_r = N0 * crg(2) / lam**cre(2) - - do i = 1, nbr - tnr_rev(i,j,k) = GAMMP(mu_r+1.0, SNGL(Dr(i)*lam)) * Nt_r - enddo - - enddo - enddo - - end subroutine table_dropEvap - -! TO APPLY TABLE ABOVE -!..Rain lookup table indexes. -! Dr_star = DSQRT(-2.D0*DT * t1_evap/(2.*PI) & -! * 0.78*4.*diffu(k)*xsat*rvs/rho_w) -! idx_d = NINT(1.0 + FLOAT(nbr) * DLOG(Dr_star/D0r) & -! / DLOG(Dr(nbr)/D0r)) -! idx_d = MAX(1, MIN(idx_d, nbr)) -! -! nir = NINT(ALOG10(rr(k))) -! do nn = nir-1, nir+1 -! n = nn -! if ( (rr(k)/10.**nn).ge.1.0 .and. & -! (rr(k)/10.**nn).lt.10.0) goto 154 -! enddo -!154 continue -! idx_r = INT(rr(k)/10.**n) + 10*(n-nir2) - (n-nir2) -! idx_r = MAX(1, MIN(idx_r, ntb_r)) -! -! lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr -! lam_exp = lamr * (crg(3)*org2*org1)**bm_r -! N0_exp = org1*rr(k)/am_r * lam_exp**cre(1) -! nir = NINT(DLOG10(N0_exp)) -! do nn = nir-1, nir+1 -! n = nn -! if ( (N0_exp/10.**nn).ge.1.0 .and. & -! (N0_exp/10.**nn).lt.10.0) goto 155 -! enddo -!155 continue -! idx_r1 = INT(N0_exp/10.**n) + 10*(n-nir3) - (n-nir3) -! idx_r1 = MAX(1, MIN(idx_r1, ntb_r1)) -! -! pnr_rev(k) = MIN(nr(k)*odts, SNGL(tnr_rev(idx_d,idx_r1,idx_r) & ! RAIN2M -! * odts)) -! -! -!+---+-----------------------------------------------------------------+ -!+---+-----------------------------------------------------------------+ - SUBROUTINE GCF(GAMMCF,A,X,GLN) -! --- RETURNS THE INCOMPLETE GAMMA FUNCTION Q(A,X) EVALUATED BY ITS -! --- CONTINUED FRACTION REPRESENTATION AS GAMMCF. ALSO RETURNS -! --- LN(GAMMA(A)) AS GLN. THE CONTINUED FRACTION IS EVALUATED BY -! --- A MODIFIED LENTZ METHOD. -! --- USES GAMMLN - IMPLICIT NONE - INTEGER, PARAMETER:: ITMAX=100 - REAL, PARAMETER:: gEPS=3.E-7 - REAL, PARAMETER:: FPMIN=1.E-30 - REAL, INTENT(IN):: A, X - REAL:: GAMMCF,GLN - INTEGER:: I - REAL:: AN,B,C,D,DEL,H - GLN=GAMMLN(A) - B=X+1.-A - C=1./FPMIN - D=1./B - H=D - DO 11 I=1,ITMAX - AN=-I*(I-A) - B=B+2. - D=AN*D+B - IF(ABS(D).LT.FPMIN)D=FPMIN - C=B+AN/C - IF(ABS(C).LT.FPMIN)C=FPMIN - D=1./D - DEL=D*C - H=H*DEL - IF(ABS(DEL-1.).LT.gEPS)GOTO 1 - 11 CONTINUE - PRINT *, 'A TOO LARGE, ITMAX TOO SMALL IN GCF' - 1 GAMMCF=EXP(-X+A*LOG(X)-GLN)*H - END SUBROUTINE GCF -! (C) Copr. 1986-92 Numerical Recipes Software 2.02 -!+---+-----------------------------------------------------------------+ - SUBROUTINE GSER(GAMSER,A,X,GLN) -! --- RETURNS THE INCOMPLETE GAMMA FUNCTION P(A,X) EVALUATED BY ITS -! --- ITS SERIES REPRESENTATION AS GAMSER. ALSO RETURNS LN(GAMMA(A)) -! --- AS GLN. -! --- USES GAMMLN - IMPLICIT NONE - INTEGER, PARAMETER:: ITMAX=100 - REAL, PARAMETER:: gEPS=3.E-7 - REAL, INTENT(IN):: A, X - REAL:: GAMSER,GLN - INTEGER:: N - REAL:: AP,DEL,SUM - GLN=GAMMLN(A) - IF(X.LE.0.)THEN - IF(X.LT.0.) PRINT *, 'X < 0 IN GSER' - GAMSER=0. - RETURN - ENDIF - AP=A - SUM=1./A - DEL=SUM - DO 11 N=1,ITMAX - AP=AP+1. - DEL=DEL*X/AP - SUM=SUM+DEL - IF(ABS(DEL).LT.ABS(SUM)*gEPS)GOTO 1 - 11 CONTINUE - PRINT *,'A TOO LARGE, ITMAX TOO SMALL IN GSER' - 1 GAMSER=SUM*EXP(-X+A*LOG(X)-GLN) - END SUBROUTINE GSER -! (C) Copr. 1986-92 Numerical Recipes Software 2.02 -!+---+-----------------------------------------------------------------+ - REAL FUNCTION GAMMLN(XX) -! --- RETURNS THE VALUE LN(GAMMA(XX)) FOR XX > 0. - IMPLICIT NONE - REAL, INTENT(IN):: XX - DOUBLE PRECISION, PARAMETER:: STP = 2.5066282746310005D0 - DOUBLE PRECISION, DIMENSION(6), PARAMETER:: & - COF = (/76.18009172947146D0, -86.50532032941677D0, & - 24.01409824083091D0, -1.231739572450155D0, & - .1208650973866179D-2, -.5395239384953D-5/) - DOUBLE PRECISION:: SER,TMP,X,Y - INTEGER:: J - - X=XX - Y=X - TMP=X+5.5D0 - TMP=(X+0.5D0)*LOG(TMP)-TMP - SER=1.000000000190015D0 - DO 11 J=1,6 - Y=Y+1.D0 - SER=SER+COF(J)/Y -11 CONTINUE - GAMMLN=TMP+LOG(STP*SER/X) - END FUNCTION GAMMLN -! (C) Copr. 1986-92 Numerical Recipes Software 2.02 -!+---+-----------------------------------------------------------------+ - REAL FUNCTION GAMMP(A,X) -! --- COMPUTES THE INCOMPLETE GAMMA FUNCTION P(A,X) -! --- SEE ABRAMOWITZ AND STEGUN 6.5.1 -! --- USES GCF,GSER - IMPLICIT NONE - REAL, INTENT(IN):: A,X - REAL:: GAMMCF,GAMSER,GLN - GAMMP = 0. - IF((X.LT.0.) .OR. (A.LE.0.)) THEN - PRINT *, 'BAD ARGUMENTS IN GAMMP' - RETURN - ELSEIF(X.LT.A+1.)THEN - CALL GSER(GAMSER,A,X,GLN) - GAMMP=GAMSER - ELSE - CALL GCF(GAMMCF,A,X,GLN) - GAMMP=1.-GAMMCF - ENDIF - END FUNCTION GAMMP -! (C) Copr. 1986-92 Numerical Recipes Software 2.02 -!+---+-----------------------------------------------------------------+ - REAL FUNCTION WGAMMA(y) - - IMPLICIT NONE - REAL, INTENT(IN):: y - - WGAMMA = EXP(GAMMLN(y)) - - END FUNCTION WGAMMA -!+---+-----------------------------------------------------------------+ -! THIS FUNCTION CALCULATES THE LIQUID SATURATION VAPOR MIXING RATIO AS -! A FUNCTION OF TEMPERATURE AND PRESSURE -! - REAL FUNCTION RSLF(P,T) - - IMPLICIT NONE - REAL, INTENT(IN):: P, T - REAL:: ESL,X - REAL, PARAMETER:: C0= .611583699E03 - REAL, PARAMETER:: C1= .444606896E02 - REAL, PARAMETER:: C2= .143177157E01 - REAL, PARAMETER:: C3= .264224321E-1 - REAL, PARAMETER:: C4= .299291081E-3 - REAL, PARAMETER:: C5= .203154182E-5 - REAL, PARAMETER:: C6= .702620698E-8 - REAL, PARAMETER:: C7= .379534310E-11 - REAL, PARAMETER:: C8=-.321582393E-13 - - X=MAX(-80.,T-273.16) - -! ESL=612.2*EXP(17.67*X/(T-29.65)) - ESL=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8))))))) - RSLF=.622*ESL/(P-ESL) - - END FUNCTION RSLF -! -! ALTERNATIVE -! ; Source: Murphy and Koop, Review of the vapour pressure of ice and -! supercooled water for atmospheric applications, Q. J. R. -! Meteorol. Soc (2005), 131, pp. 1539-1565. -! Psat = EXP(54.842763 - 6763.22 / T - 4.210 * ALOG(T) + 0.000367 * T -! + TANH(0.0415 * (T - 218.8)) * (53.878 - 1331.22 -! / T - 9.44523 * ALOG(T) + 0.014025 * T)) -! -!+---+-----------------------------------------------------------------+ -! THIS FUNCTION CALCULATES THE ICE SATURATION VAPOR MIXING RATIO AS A -! FUNCTION OF TEMPERATURE AND PRESSURE -! - REAL FUNCTION RSIF(P,T) - - IMPLICIT NONE - REAL, INTENT(IN):: P, T - REAL:: ESI,X - REAL, PARAMETER:: C0= .609868993E03 - REAL, PARAMETER:: C1= .499320233E02 - REAL, PARAMETER:: C2= .184672631E01 - REAL, PARAMETER:: C3= .402737184E-1 - REAL, PARAMETER:: C4= .565392987E-3 - REAL, PARAMETER:: C5= .521693933E-5 - REAL, PARAMETER:: C6= .307839583E-7 - REAL, PARAMETER:: C7= .105785160E-9 - REAL, PARAMETER:: C8= .161444444E-12 - - X=MAX(-80.,T-273.16) - ESI=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8))))))) - RSIF=.622*ESI/(P-ESI) - - END FUNCTION RSIF -! -! ALTERNATIVE -! ; Source: Murphy and Koop, Review of the vapour pressure of ice and -! supercooled water for atmospheric applications, Q. J. R. -! Meteorol. Soc (2005), 131, pp. 1539-1565. -! ESI = EXP(9.550426 - 5723.265/T + 3.53068*ALOG(T) - 0.00728332*T) -! -!+---+-----------------------------------------------------------------+ -!+---+-----------------------------------------------------------------+ -END MODULE module_mp_thompson -!+---+-----------------------------------------------------------------+ diff --git a/src/fim/FIMsrc/fim/wrfphys/module_mp_thompson07.F b/src/fim/FIMsrc/fim/wrfphys/module_mp_thompson07.F deleted file mode 100644 index b9ad986..0000000 --- a/src/fim/FIMsrc/fim/wrfphys/module_mp_thompson07.F +++ /dev/null @@ -1,3196 +0,0 @@ -!+---+-----------------------------------------------------------------+ -!.. This subroutine computes the moisture tendencies of water vapor, -!.. cloud droplets, rain, cloud ice (pristine), snow, and graupel. -!.. Prior to WRFv2.2 this code was based on Reisner et al (1998), but -!.. few of those pieces remain. A complete description is now found -!.. in Thompson et al. (2004, 2007). -!.. Most importantly, users may wish to modify the prescribed number of -!.. cloud droplets (Nt_c; see guidelines mentioned below). Otherwise, -!.. users may alter the rain and graupel size distribution parameters -!.. to use exponential (Marshal-Palmer) or generalized gamma shape. -!.. The snow field assumes a combination of two gamma functions (from -!.. Field et al. 2005) and would require significant modifications -!.. throughout the entire code to alter its shape as well as accretion -!.. rates. Users may also alter the constants used for density of rain, -!.. graupel, ice, and snow, but the latter is not constant when using -!.. Paul Field's snow distribution and moments methods. Other values -!.. users can modify include the constants for mass and/or velocity -!.. power law relations and assumed capacitances used in deposition/ -!.. sublimation/evaporation/melting. -!.. Remaining values should probably be left alone. -!.. -!..Author: Greg Thompson, NCAR-RAL, gthompsn@ucar.edu, 303-497-2805 -!..Last modified: 26 Oct 2007 -!+---+-----------------------------------------------------------------+ -!wrft:model_layer:physics -!+---+-----------------------------------------------------------------+ -! - MODULE module_mp_thompson07 -! USE module_wrf_error - - IMPLICIT NONE - - LOGICAL, PARAMETER, PRIVATE:: iiwarm = .false. - INTEGER, PARAMETER, PRIVATE:: IFDRY = 0 - REAL, PARAMETER, PRIVATE:: T_0 = 273.15 - REAL, PARAMETER, PRIVATE:: PI = 3.1415926536 - -!..Densities of rain, snow, graupel, and cloud ice. - REAL, PARAMETER, PRIVATE:: rho_w = 1000.0 - REAL, PARAMETER, PRIVATE:: rho_s = 100.0 - REAL, PARAMETER, PRIVATE:: rho_g = 400.0 - REAL, PARAMETER, PRIVATE:: rho_i = 890.0 - -!..Prescribed number of cloud droplets. Set according to known data or -!.. roughly 100 per cc (100.E6 m^-3) for Maritime cases and -!.. 300 per cc (300.E6 m^-3) for Continental. Gamma shape parameter, -!.. mu_c, calculated based on Nt_c is important in autoconversion -!.. scheme. - REAL, PARAMETER, PRIVATE:: Nt_c = 100.E6 - -!..Generalized gamma distributions for rain, graupel and cloud ice. -!.. N(D) = N_0 * D**mu * exp(-lamda*D); mu=0 is exponential. - REAL, PARAMETER, PRIVATE:: mu_r = 0.0 - REAL, PARAMETER, PRIVATE:: mu_g = 0.0 - REAL, PARAMETER, PRIVATE:: mu_i = 0.0 - REAL, PRIVATE:: mu_c - -!..Sum of two gamma distrib for snow (Field et al. 2005). -!.. N(D) = M2**4/M3**3 * [Kap0*exp(-M2*Lam0*D/M3) -!.. + Kap1*(M2/M3)**mu_s * D**mu_s * exp(-M2*Lam1*D/M3)] -!.. M2 and M3 are the (bm_s)th and (bm_s+1)th moments respectively -!.. calculated as function of ice water content and temperature. - REAL, PARAMETER, PRIVATE:: mu_s = 0.6357 - REAL, PARAMETER, PRIVATE:: Kap0 = 490.6 - REAL, PARAMETER, PRIVATE:: Kap1 = 17.46 - REAL, PARAMETER, PRIVATE:: Lam0 = 20.78 - REAL, PARAMETER, PRIVATE:: Lam1 = 3.29 - -!..Y-intercept parameters for rain & graupel. However, these are not -!.. constant and vary depending on mixing ratio. Furthermore, when -!.. mu is non-zero, these become equiv y-intercept for an exponential -!.. distrib and proper values computed based on assumed mu value. - REAL, PARAMETER, PRIVATE:: gonv_min = 1.E4 - REAL, PARAMETER, PRIVATE:: gonv_max = 5.E6 - REAL, PARAMETER, PRIVATE:: ronv_min = 2.E6 - REAL, PARAMETER, PRIVATE:: ronv_max = 9.E9 - REAL, PARAMETER, PRIVATE:: ronv_sl = 1./4. - REAL, PARAMETER, PRIVATE:: ronv_r0 = 0.10E-3 - REAL, PARAMETER, PRIVATE:: ronv_c0 = ronv_sl/ronv_r0 - REAL, PARAMETER, PRIVATE:: ronv_c1 = (ronv_max-ronv_min)*0.5 - REAL, PARAMETER, PRIVATE:: ronv_c2 = (ronv_max+ronv_min)*0.5 - -!..Mass power law relations: mass = am*D**bm -!.. Snow from Field et al. (2005), others assume spherical form. - REAL, PARAMETER, PRIVATE:: am_r = PI*rho_w/6.0 - REAL, PARAMETER, PRIVATE:: bm_r = 3.0 - REAL, PARAMETER, PRIVATE:: am_s = 0.069 - REAL, PARAMETER, PRIVATE:: bm_s = 2.0 - REAL, PARAMETER, PRIVATE:: am_g = PI*rho_g/6.0 - REAL, PARAMETER, PRIVATE:: bm_g = 3.0 - REAL, PARAMETER, PRIVATE:: am_i = PI*rho_i/6.0 - REAL, PARAMETER, PRIVATE:: bm_i = 3.0 - -!..Fallspeed power laws relations: v = (av*D**bv)*exp(-fv*D) -!.. Rain from Ferrier (1994), ice, snow, and graupel from -!.. Thompson et al (2006). Coefficient fv is zero for graupel/ice. - REAL, PARAMETER, PRIVATE:: av_r = 4854.0 - REAL, PARAMETER, PRIVATE:: bv_r = 1.0 - REAL, PARAMETER, PRIVATE:: fv_r = 195.0 - REAL, PARAMETER, PRIVATE:: av_s = 40.0 - REAL, PARAMETER, PRIVATE:: bv_s = 0.55 - REAL, PARAMETER, PRIVATE:: fv_s = 125.0 - REAL, PARAMETER, PRIVATE:: av_g = 442.0 - REAL, PARAMETER, PRIVATE:: bv_g = 0.89 - REAL, PARAMETER, PRIVATE:: av_i = 1847.5 - REAL, PARAMETER, PRIVATE:: bv_i = 1.0 - -!..Capacitance of sphere and plates/aggregates: D**3, D**2 - REAL, PARAMETER, PRIVATE:: C_cube = 0.5 - REAL, PARAMETER, PRIVATE:: C_sqrd = 0.3 - -!..Collection efficiencies. Rain/snow/graupel collection of cloud -!.. droplets use variables (Ef_rw, Ef_sw, Ef_gw respectively) and -!.. get computed elsewhere because they are dependent on stokes -!.. number. - REAL, PARAMETER, PRIVATE:: Ef_si = 0.1 - REAL, PARAMETER, PRIVATE:: Ef_rs = 0.95 - REAL, PARAMETER, PRIVATE:: Ef_rg = 0.95 - REAL, PARAMETER, PRIVATE:: Ef_ri = 0.95 - -!..Minimum microphys values -!.. R1 value, 1.E-12, cannot be set lower because of numerical -!.. problems with Paul Field's moments and should not be set larger -!.. because of truncation problems in snow/ice growth. - REAL, PARAMETER, PRIVATE:: R1 = 1.E-12 - REAL, PARAMETER, PRIVATE:: R2 = 1.E-8 - REAL, PARAMETER, PRIVATE:: eps = 1.E-29 - -!..Constants in Cooper curve relation for cloud ice number. - REAL, PARAMETER, PRIVATE:: TNO = 5.0 - REAL, PARAMETER, PRIVATE:: ATO = 0.304 - -!..Rho_not used in fallspeed relations (rho_not/rho)**.5 adjustment. - REAL, PARAMETER, PRIVATE:: rho_not = 101325.0/(287.05*298.0) - -!..Schmidt number - REAL, PARAMETER, PRIVATE:: Sc = 0.632 - REAL, PRIVATE:: Sc3 - -!..Homogeneous freezing temperature - REAL, PARAMETER, PRIVATE:: HGFR = 235.16 - -!..Water vapor and air gas constants at constant pressure - REAL, PARAMETER, PRIVATE:: Rv = 461.5 - REAL, PARAMETER, PRIVATE:: oRv = 1./Rv - REAL, PARAMETER, PRIVATE:: R = 287.04 - REAL, PARAMETER, PRIVATE:: Cp = 1004.0 - -!..Enthalpy of sublimation, vaporization, and fusion at 0C. - REAL, PARAMETER, PRIVATE:: lsub = 2.834E6 - REAL, PARAMETER, PRIVATE:: lvap0 = 2.5E6 - REAL, PARAMETER, PRIVATE:: lfus = lsub - lvap0 - REAL, PARAMETER, PRIVATE:: olfus = 1./lfus - -!..Ice initiates with this mass (kg), corresponding diameter calc. -!..Min diameters and mass of cloud, rain, snow, and graupel (m, kg). - REAL, PARAMETER, PRIVATE:: xm0i = 1.E-12 - REAL, PARAMETER, PRIVATE:: D0c = 1.E-6 - REAL, PARAMETER, PRIVATE:: D0r = 50.E-6 - REAL, PARAMETER, PRIVATE:: D0s = 200.E-6 - REAL, PARAMETER, PRIVATE:: D0g = 250.E-6 - REAL, PRIVATE:: D0i, xm0s, xm0g - -!..Lookup table dimensions - INTEGER, PARAMETER, PRIVATE:: nbins = 100 - INTEGER, PARAMETER, PRIVATE:: nbc = nbins - INTEGER, PARAMETER, PRIVATE:: nbi = nbins - INTEGER, PARAMETER, PRIVATE:: nbr = nbins - INTEGER, PARAMETER, PRIVATE:: nbs = nbins - INTEGER, PARAMETER, PRIVATE:: nbg = nbins - INTEGER, PARAMETER, PRIVATE:: ntb_c = 37 - INTEGER, PARAMETER, PRIVATE:: ntb_i = 64 - INTEGER, PARAMETER, PRIVATE:: ntb_r = 37 - INTEGER, PARAMETER, PRIVATE:: ntb_s = 28 - INTEGER, PARAMETER, PRIVATE:: ntb_g = 28 - INTEGER, PARAMETER, PRIVATE:: ntb_r1 = 37 - INTEGER, PARAMETER, PRIVATE:: ntb_i1 = 55 - INTEGER, PARAMETER, PRIVATE:: ntb_t = 9 - INTEGER, PRIVATE:: nic2, nii2, nii3, nir2, nir3, nis2, nig2 - - DOUBLE PRECISION, DIMENSION(nbins+1):: xDx - DOUBLE PRECISION, DIMENSION(nbc):: Dc, dtc - DOUBLE PRECISION, DIMENSION(nbi):: Di, dti - DOUBLE PRECISION, DIMENSION(nbr):: Dr, dtr - DOUBLE PRECISION, DIMENSION(nbs):: Ds, dts - DOUBLE PRECISION, DIMENSION(nbg):: Dg, dtg - -!..Lookup tables for cloud water content (kg/m**3). - REAL, DIMENSION(ntb_c), PARAMETER, PRIVATE:: & - r_c = (/1.e-6,2.e-6,3.e-6,4.e-6,5.e-6,6.e-6,7.e-6,8.e-6,9.e-6, & - 1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & - 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & - 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, & - 1.e-2/) - -!..Lookup tables for cloud ice content (kg/m**3). - REAL, DIMENSION(ntb_i), PARAMETER, PRIVATE:: & - r_i = (/1.e-10,2.e-10,3.e-10,4.e-10, & - 5.e-10,6.e-10,7.e-10,8.e-10,9.e-10, & - 1.e-9,2.e-9,3.e-9,4.e-9,5.e-9,6.e-9,7.e-9,8.e-9,9.e-9, & - 1.e-8,2.e-8,3.e-8,4.e-8,5.e-8,6.e-8,7.e-8,8.e-8,9.e-8, & - 1.e-7,2.e-7,3.e-7,4.e-7,5.e-7,6.e-7,7.e-7,8.e-7,9.e-7, & - 1.e-6,2.e-6,3.e-6,4.e-6,5.e-6,6.e-6,7.e-6,8.e-6,9.e-6, & - 1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & - 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & - 1.e-3/) - -!..Lookup tables for rain content (kg/m**3). - REAL, DIMENSION(ntb_r), PARAMETER, PRIVATE:: & - r_r = (/1.e-6,2.e-6,3.e-6,4.e-6,5.e-6,6.e-6,7.e-6,8.e-6,9.e-6, & - 1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & - 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & - 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, & - 1.e-2/) - -!..Lookup tables for graupel content (kg/m**3). - REAL, DIMENSION(ntb_g), PARAMETER, PRIVATE:: & - r_g = (/1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & - 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & - 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, & - 1.e-2/) - -!..Lookup tables for snow content (kg/m**3). - REAL, DIMENSION(ntb_s), PARAMETER, PRIVATE:: & - r_s = (/1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & - 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & - 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, & - 1.e-2/) - -!..Lookup tables for rain y-intercept parameter (/m**4). - REAL, DIMENSION(ntb_r1), PARAMETER, PRIVATE:: & - N0r_exp = (/1.e6,2.e6,3.e6,4.e6,5.e6,6.e6,7.e6,8.e6,9.e6, & - 1.e7,2.e7,3.e7,4.e7,5.e7,6.e7,7.e7,8.e7,9.e7, & - 1.e8,2.e8,3.e8,4.e8,5.e8,6.e8,7.e8,8.e8,9.e8, & - 1.e9,2.e9,3.e9,4.e9,5.e9,6.e9,7.e9,8.e9,9.e9, & - 1.e10/) - -!..Lookup tables for ice number concentration (/m**3). - REAL, DIMENSION(ntb_i1), PARAMETER, PRIVATE:: & - Nt_i = (/1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0, & - 1.e1,2.e1,3.e1,4.e1,5.e1,6.e1,7.e1,8.e1,9.e1, & - 1.e2,2.e2,3.e2,4.e2,5.e2,6.e2,7.e2,8.e2,9.e2, & - 1.e3,2.e3,3.e3,4.e3,5.e3,6.e3,7.e3,8.e3,9.e3, & - 1.e4,2.e4,3.e4,4.e4,5.e4,6.e4,7.e4,8.e4,9.e4, & - 1.e5,2.e5,3.e5,4.e5,5.e5,6.e5,7.e5,8.e5,9.e5, & - 1.e6/) - -!..For snow moments conversions (from Field et al. 2005) - REAL, DIMENSION(10), PARAMETER, PRIVATE:: & - sa = (/ 5.065339, -0.062659, -3.032362, 0.029469, -0.000285, & - 0.31255, 0.000204, 0.003199, 0.0, -0.015952/) - REAL, DIMENSION(10), PARAMETER, PRIVATE:: & - sb = (/ 0.476221, -0.015896, 0.165977, 0.007468, -0.000141, & - 0.060366, 0.000079, 0.000594, 0.0, -0.003577/) - -!..Temperatures (5 C interval 0 to -40) used in lookup tables. - REAL, DIMENSION(ntb_t), PARAMETER, PRIVATE:: & - Tc = (/-0.01, -5., -10., -15., -20., -25., -30., -35., -40./) - -!..Lookup tables for various accretion/collection terms. -!.. ntb_x refers to the number of elements for rain, snow, graupel, -!.. and temperature array indices. Variables beginning with tp/tc/tm -!.. represent lookup tables. - DOUBLE PRECISION, DIMENSION(ntb_g,ntb_r1,ntb_r):: & - tcg_racg, tmr_racg, tcr_gacr, tmg_gacr - DOUBLE PRECISION, DIMENSION(ntb_s,ntb_t,ntb_r1,ntb_r):: & - tcs_racs1, tmr_racs1, tcs_racs2, tmr_racs2, & - tcr_sacr1, tms_sacr1, tcr_sacr2, tms_sacr2 - DOUBLE PRECISION, DIMENSION(ntb_c,45):: & - tpi_qcfz, tni_qcfz - DOUBLE PRECISION, DIMENSION(ntb_r,ntb_r1,45):: & - tpi_qrfz, tpg_qrfz, tni_qrfz - DOUBLE PRECISION, DIMENSION(ntb_i,ntb_i1):: & - tps_iaus, tni_iaus, tpi_ide - REAL, DIMENSION(nbr,nbc):: t_Efrw - REAL, DIMENSION(nbs,nbc):: t_Efsw - -!..Variables holding a bunch of exponents and gamma values (cloud water, -!.. cloud ice, rain, snow, then graupel). - REAL, DIMENSION(3), PRIVATE:: cce, ccg - REAL, PRIVATE:: ocg1, ocg2 - REAL, DIMENSION(6), PRIVATE:: cie, cig - REAL, PRIVATE:: oig1, oig2, obmi - REAL, DIMENSION(12), PRIVATE:: cre, crg - REAL, PRIVATE:: ore1, org1, org2, org3, obmr - REAL, DIMENSION(18), PRIVATE:: cse, csg - REAL, PRIVATE:: oams, obms, ocms - REAL, DIMENSION(12), PRIVATE:: cge, cgg - REAL, PRIVATE:: oge1, ogg1, ogg2, ogg3, oamg, obmg, ocmg - -!..Declaration of precomputed constants in various rate eqns. - REAL:: t1_qr_qc, t1_qr_qi, t2_qr_qi, t1_qg_qc, t1_qs_qc, t1_qs_qi - REAL:: t1_qr_ev, t2_qr_ev - REAL:: t1_qs_sd, t2_qs_sd, t1_qg_sd, t2_qg_sd - REAL:: t1_qs_me, t2_qs_me, t1_qg_me, t2_qg_me - - CHARACTER*256:: mp_debug - -!+---+ -!+---+-----------------------------------------------------------------+ -!..END DECLARATIONS -!+---+-----------------------------------------------------------------+ -!+---+ -! - - CONTAINS - - SUBROUTINE thompson07_init - - IMPLICIT NONE - - INTEGER:: i, j, k, m, n - -!..From Martin et al. (1994), assign gamma shape parameter mu for cloud -!.. drops according to general dispersion characteristics (disp=~0.25 -!.. for Maritime and 0.45 for Continental). -!.. disp=SQRT((mu+2)/(mu+1) - 1) so mu varies from 15 for Maritime -!.. to 2 for really dirty air. - mu_c = MIN(15., (1000.E6/Nt_c + 2.)) - -!..Schmidt number to one-third used numerous times. - Sc3 = Sc**(1./3.) - -!..Compute min ice diam from mass, min snow/graupel mass from diam. - D0i = (xm0i/am_i)**(1./bm_i) - xm0s = am_s * D0s**bm_s - xm0g = am_g * D0g**bm_g - -!..These constants various exponents and gamma() assoc with cloud, -!.. rain, snow, and graupel. - cce(1) = mu_c + 1. - cce(2) = bm_r + mu_c + 1. - cce(3) = bm_r + mu_c + 4. - ccg(1) = WGAMMA(cce(1)) - ccg(2) = WGAMMA(cce(2)) - ccg(3) = WGAMMA(cce(3)) - ocg1 = 1./ccg(1) - ocg2 = 1./ccg(2) - - cie(1) = mu_i + 1. - cie(2) = bm_i + mu_i + 1. - cie(3) = bm_i + mu_i + bv_i + 1. - cie(4) = mu_i + bv_i + 1. - cie(5) = mu_i + 2. - cie(6) = bm_i + bv_i - cig(1) = WGAMMA(cie(1)) - cig(2) = WGAMMA(cie(2)) - cig(3) = WGAMMA(cie(3)) - cig(4) = WGAMMA(cie(4)) - cig(5) = WGAMMA(cie(5)) - cig(6) = WGAMMA(cie(6)) - oig1 = 1./cig(1) - oig2 = 1./cig(2) - obmi = 1./bm_i - - cre(1) = bm_r + 1. - cre(2) = mu_r + 1. - cre(3) = bm_r + mu_r + 1. - cre(4) = bm_r*2. + mu_r + 1. - cre(5) = bm_r + mu_r + 3. - cre(6) = bm_r + mu_r + bv_r + 1. - cre(7) = bm_r + mu_r + bv_r + 2. - cre(8) = bm_r + mu_r + bv_r + 3. - cre(9) = mu_r + bv_r + 3. - cre(10) = mu_r + 2. - cre(11) = 0.5*(bv_r + 5. + 2.*mu_r) - cre(12) = bm_r + mu_r + 4. - do n = 1, 12 - crg(n) = WGAMMA(cre(n)) - enddo - obmr = 1./bm_r - ore1 = 1./cre(1) - org1 = 1./crg(1) - org2 = 1./crg(2) - org3 = 1./crg(3) - - cse(1) = bm_s + 1. - cse(2) = bm_s + 2. - cse(3) = bm_s*2. - cse(4) = bm_s + bv_s + 1. - cse(5) = bm_s + bv_s + 2. - cse(6) = bm_s + bv_s + 3. - cse(7) = bm_s + mu_s + 1. - cse(8) = bm_s + mu_s + 2. - cse(9) = bm_s + mu_s + 3. - cse(10) = bm_s + mu_s + bv_s + 1. - cse(11) = bm_s + mu_s + bv_s + 2. - cse(12) = bm_s*2. + mu_s + 1. - cse(13) = bv_s + 2. - cse(14) = bm_s + bv_s - cse(15) = mu_s + 2. - cse(16) = 1.0 + (1.0 + bv_s)/2. - cse(17) = cse(16) + mu_s + 1. - cse(18) = bv_s + mu_s + 3. - do n = 1, 18 - csg(n) = WGAMMA(cse(n)) - enddo - oams = 1./am_s - obms = 1./bm_s - ocms = oams**obms - - cge(1) = bm_g + 1. - cge(2) = mu_g + 1. - cge(3) = bm_g + mu_g + 1. - cge(4) = bm_g*2. + mu_g + 1. - cge(5) = bm_g + mu_g + 3. - cge(6) = bm_g + mu_g + bv_g + 1. - cge(7) = bm_g + mu_g + bv_g + 2. - cge(8) = bm_g + mu_g + bv_g + 3. - cge(9) = mu_g + bv_g + 3. - cge(10) = mu_g + 2. - cge(11) = 0.5*(bv_g + 5. + 2.*mu_g) - cge(12) = 0.5*(bv_g + 5.) + mu_g - do n = 1, 12 - cgg(n) = WGAMMA(cge(n)) - enddo - oamg = 1./am_g - obmg = 1./bm_g - ocmg = oamg**obmg - oge1 = 1./cge(1) - ogg1 = 1./cgg(1) - ogg2 = 1./cgg(2) - ogg3 = 1./cgg(3) - -!+---+-----------------------------------------------------------------+ -!..Simplify various rate eqns the best we can now. -!+---+-----------------------------------------------------------------+ - -!..Rain collecting cloud water and cloud ice - t1_qr_qc = PI*.25*av_r * crg(9) - t1_qr_qi = PI*.25*av_r * crg(9) - t2_qr_qi = PI*.25*am_r*av_r * crg(8) - -!..Graupel collecting cloud water - t1_qg_qc = PI*.25*av_g * cgg(9) - -!..Snow collecting cloud water - t1_qs_qc = PI*.25*av_s - -!..Snow collecting cloud ice - t1_qs_qi = PI*.25*av_s - -!..Evaporation of rain; ignore depositional growth of rain. - t1_qr_ev = 0.78 * crg(10) - t2_qr_ev = 0.308*Sc3*SQRT(av_r) * crg(11) - -!..Sublimation/depositional growth of snow - t1_qs_sd = 0.86 - t2_qs_sd = 0.28*Sc3*SQRT(av_s) - -!..Melting of snow - t1_qs_me = PI*4.*C_sqrd*olfus * 0.86 - t2_qs_me = PI*4.*C_sqrd*olfus * 0.28*Sc3*SQRT(av_s) - -!..Sublimation/depositional growth of graupel - t1_qg_sd = 0.86 * cgg(10) - t2_qg_sd = 0.28*Sc3*SQRT(av_g) * cgg(11) - -!..Melting of graupel - t1_qg_me = PI*4.*C_cube*olfus * 0.86 * cgg(10) - t2_qg_me = PI*4.*C_cube*olfus * 0.28*Sc3*SQRT(av_g) * cgg(11) - -!..Constants for helping find lookup table indexes. - nic2 = NINT(ALOG10(r_c(1))) - nii2 = NINT(ALOG10(r_i(1))) - nii3 = NINT(ALOG10(Nt_i(1))) - nir2 = NINT(ALOG10(r_r(1))) - nir3 = NINT(ALOG10(N0r_exp(1))) - nis2 = NINT(ALOG10(r_s(1))) - nig2 = NINT(ALOG10(r_g(1))) - -!..Create bins of cloud water (from min diameter up to 100 microns). - Dc(1) = D0c*1.0d0 - dtc(1) = D0c*1.0d0 - do n = 2, nbc - Dc(n) = Dc(n-1) + 1.0D-6 - dtc(n) = (Dc(n) - Dc(n-1)) - enddo - -!..Create bins of cloud ice (from min diameter up to 5x min snow size). - xDx(1) = D0i*1.0d0 - xDx(nbi+1) = 5.0d0*D0s - do n = 2, nbi - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbi) & - *DLOG(xDx(nbi+1)/xDx(1)) +DLOG(xDx(1))) - enddo - do n = 1, nbi - Di(n) = DSQRT(xDx(n)*xDx(n+1)) - dti(n) = xDx(n+1) - xDx(n) - enddo - -!..Create bins of rain (from min diameter up to 5 mm). - xDx(1) = D0r*1.0d0 - xDx(nbr+1) = 0.005d0 - do n = 2, nbr - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbr) & - *DLOG(xDx(nbr+1)/xDx(1)) +DLOG(xDx(1))) - enddo - do n = 1, nbr - Dr(n) = DSQRT(xDx(n)*xDx(n+1)) - dtr(n) = xDx(n+1) - xDx(n) - enddo - -!..Create bins of snow (from min diameter up to 2 cm). - xDx(1) = D0s*1.0d0 - xDx(nbs+1) = 0.02d0 - do n = 2, nbs - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbs) & - *DLOG(xDx(nbs+1)/xDx(1)) +DLOG(xDx(1))) - enddo - do n = 1, nbs - Ds(n) = DSQRT(xDx(n)*xDx(n+1)) - dts(n) = xDx(n+1) - xDx(n) - enddo - -!..Create bins of graupel (from min diameter up to 5 cm). - xDx(1) = D0g*1.0d0 - xDx(nbg+1) = 0.05d0 - do n = 2, nbg - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbg) & - *DLOG(xDx(nbg+1)/xDx(1)) +DLOG(xDx(1))) - enddo - do n = 1, nbg - Dg(n) = DSQRT(xDx(n)*xDx(n+1)) - dtg(n) = xDx(n+1) - xDx(n) - enddo - -!+---+-----------------------------------------------------------------+ -!..Create lookup tables for most costly calculations. -!+---+-----------------------------------------------------------------+ - - do k = 1, ntb_r - do j = 1, ntb_r1 - do i = 1, ntb_g - tcg_racg(i,j,k) = 0.0d0 - tmr_racg(i,j,k) = 0.0d0 - tcr_gacr(i,j,k) = 0.0d0 - tmg_gacr(i,j,k) = 0.0d0 - enddo - enddo - enddo - - do m = 1, ntb_r - do k = 1, ntb_r1 - do j = 1, ntb_t - do i = 1, ntb_s - tcs_racs1(i,j,k,m) = 0.0d0 - tmr_racs1(i,j,k,m) = 0.0d0 - tcs_racs2(i,j,k,m) = 0.0d0 - tmr_racs2(i,j,k,m) = 0.0d0 - tcr_sacr1(i,j,k,m) = 0.0d0 - tms_sacr1(i,j,k,m) = 0.0d0 - tcr_sacr2(i,j,k,m) = 0.0d0 - tms_sacr2(i,j,k,m) = 0.0d0 - enddo - enddo - enddo - enddo - - do k = 1, 45 - do j = 1, ntb_r1 - do i = 1, ntb_r - tpi_qrfz(i,j,k) = 0.0d0 - tni_qrfz(i,j,k) = 0.0d0 - tpg_qrfz(i,j,k) = 0.0d0 - enddo - enddo - do i = 1, ntb_c - tpi_qcfz(i,k) = 0.0d0 - tni_qcfz(i,k) = 0.0d0 - enddo - enddo - - do j = 1, ntb_i1 - do i = 1, ntb_i - tps_iaus(i,j) = 0.0d0 - tni_iaus(i,j) = 0.0d0 - tpi_ide(i,j) = 0.0d0 - enddo - enddo - - do j = 1, nbc - do i = 1, nbr - t_Efrw(i,j) = 0.0 - enddo - do i = 1, nbs - t_Efsw(i,j) = 0.0 - enddo - enddo - -! CALL wrf_debug(150, 'CREATING MICROPHYSICS LOOKUP TABLES ... ') -! WRITE (wrf_err_message, '(a, f5.2, a, f5.2, a, f5.2, a, f5.2)') & -! ' using: mu_c=',mu_c,' mu_i=',mu_i,' mu_r=',mu_r,' mu_g=',mu_g -! CALL wrf_debug(150, wrf_err_message) - -!..Collision efficiency between rain/snow and cloud water. -! CALL wrf_debug(200, ' creating qc collision eff tables') - call table_Efrw - call table_Efsw - - if (.not. iiwarm) then -!..Rain collecting graupel & graupel collecting rain. -! CALL wrf_debug(200, ' creating rain collecting graupel table') - call qr_acr_qg - -!..Rain collecting snow & snow collecting rain. -! CALL wrf_debug(200, ' creating rain collecting snow table') - call qr_acr_qs - -!..Cloud water and rain freezing (Bigg, 1953). -! CALL wrf_debug(200, ' creating freezing of water drops table') - call freezeH2O - -!..Conversion of some ice mass into snow category. -! CALL wrf_debug(200, ' creating ice converting to snow table') - call qi_aut_qs - - endif - -! CALL wrf_debug(150, ' ... DONE microphysical lookup tables') - - END SUBROUTINE thompson07_init -!+---+-----------------------------------------------------------------+ -! -!+---+-----------------------------------------------------------------+ -!..This is a wrapper routine designed to transfer values from 3D to 1D. -!+---+-----------------------------------------------------------------+ - SUBROUTINE mp_gt_driver07(qv, qc, qr, qi, qs, qg, ni, & - th, pii, p, dz, dt_in, itimestep, & - RAINNC, RAINNCV, SR, & - ids,ide, jds,jde, kds,kde, & ! domain dims - ims,ime, jms,jme, kms,kme, & ! memory dims - its,ite, jts,jte, kts,kte) ! tile dims - - implicit none - -!..Subroutine arguments - INTEGER, INTENT(IN):: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & - qv, qc, qr, qi, qs, qg, ni, th - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN):: & - pii, p, dz - REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT):: & - RAINNC, RAINNCV, SR - REAL, INTENT(IN):: dt_in - INTEGER, INTENT(IN):: itimestep - -!..Local variables - REAL, DIMENSION(kts:kte):: & - qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & - t1d, p1d, dz1d - REAL, DIMENSION(its:ite, jts:jte):: pcp_ra, pcp_sn, pcp_gr, pcp_ic - REAL:: dt, pptrain, pptsnow, pptgraul, pptice - REAL:: qc_max, qr_max, qs_max, qi_max, qg_max, ni_max - INTEGER:: i, j, k - INTEGER:: imax_qc, imax_qr, imax_qi, imax_qs, imax_qg, imax_ni - INTEGER:: jmax_qc, jmax_qr, jmax_qi, jmax_qs, jmax_qg, jmax_ni - INTEGER:: kmax_qc, kmax_qr, kmax_qi, kmax_qs, kmax_qg, kmax_ni - INTEGER:: i_start, j_start, i_end, j_end - -!+---+ - - i_start = its - j_start = jts - i_end = ite - j_end = jte - if ( (ite-its+1).gt.4 .and. (jte-jts+1).lt.4) then - i_start = its + 1 - i_end = ite - 1 - j_start = jts - j_end = jte - elseif ( (ite-its+1).lt.4 .and. (jte-jts+1).gt.4) then - i_start = its - i_end = ite - j_start = jts + 1 - j_end = jte - 1 - endif - - dt = dt_in - - qc_max = 0. - qr_max = 0. - qs_max = 0. - qi_max = 0. - qg_max = 0 - ni_max = 0. - imax_qc = 0 - imax_qr = 0 - imax_qi = 0 - imax_qs = 0 - imax_qg = 0 - imax_ni = 0 - jmax_qc = 0 - jmax_qr = 0 - jmax_qi = 0 - jmax_qs = 0 - jmax_qg = 0 - jmax_ni = 0 - kmax_qc = 0 - kmax_qr = 0 - kmax_qi = 0 - kmax_qs = 0 - kmax_qg = 0 - kmax_ni = 0 - do i = 1, 256 - mp_debug(i:i) = char(0) - enddo - - j_loop: do j = j_start, j_end - i_loop: do i = i_start, i_end - - pptrain = 0. - pptsnow = 0. - pptgraul = 0. - pptice = 0. - RAINNCV(i,j) = 0. - SR(i,j) = 0. - - do k = kts, kte - t1d(k) = th(i,k,j)*pii(i,k,j) - p1d(k) = p(i,k,j) - dz1d(k) = dz(i,k,j) - qv1d(k) = qv(i,k,j) - qc1d(k) = qc(i,k,j) - qi1d(k) = qi(i,k,j) - qr1d(k) = qr(i,k,j) - qs1d(k) = qs(i,k,j) - qg1d(k) = qg(i,k,j) - ni1d(k) = ni(i,k,j) - enddo - - call mp_thompson(qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & - t1d, p1d, dz1d, & - pptrain, pptsnow, pptgraul, pptice, & - kts, kte, dt, i, j) - - pcp_ra(i,j) = pptrain - pcp_sn(i,j) = pptsnow - pcp_gr(i,j) = pptgraul - pcp_ic(i,j) = pptice - RAINNCV(i,j) = pptrain + pptsnow + pptgraul + pptice - RAINNC(i,j) = RAINNC(i,j) + pptrain + pptsnow + pptgraul + pptice - SR(i,j) = (pptsnow + pptgraul + pptice)/(RAINNCV(i,j)+1.e-12) - - do k = kts, kte - qv(i,k,j) = qv1d(k) - qc(i,k,j) = qc1d(k) - qi(i,k,j) = qi1d(k) - qr(i,k,j) = qr1d(k) - qs(i,k,j) = qs1d(k) - qg(i,k,j) = qg1d(k) - ni(i,k,j) = ni1d(k) - th(i,k,j) = t1d(k)/pii(i,k,j) - if (qc1d(k) .gt. qc_max) then - imax_qc = i - jmax_qc = j - kmax_qc = k - qc_max = qc1d(k) - elseif (qc1d(k) .lt. 0.0) then - write(mp_debug,*) 'WARNING, negative qc ', qc1d(k), & - ' at i,j,k=', i,j,k -! CALL wrf_debug(150, mp_debug) - endif - if (qr1d(k) .gt. qr_max) then - imax_qr = i - jmax_qr = j - kmax_qr = k - qr_max = qr1d(k) - elseif (qr1d(k) .lt. 0.0) then - write(mp_debug,*) 'WARNING, negative qr ', qr1d(k), & - ' at i,j,k=', i,j,k -! CALL wrf_debug(150, mp_debug) - endif - if (qs1d(k) .gt. qs_max) then - imax_qs = i - jmax_qs = j - kmax_qs = k - qs_max = qs1d(k) - elseif (qs1d(k) .lt. 0.0) then - write(mp_debug,*) 'WARNING, negative qs ', qs1d(k), & - ' at i,j,k=', i,j,k -! CALL wrf_debug(150, mp_debug) - endif - if (qi1d(k) .gt. qi_max) then - imax_qi = i - jmax_qi = j - kmax_qi = k - qi_max = qi1d(k) - elseif (qi1d(k) .lt. 0.0) then - write(mp_debug,*) 'WARNING, negative qi ', qi1d(k), & - ' at i,j,k=', i,j,k -! CALL wrf_debug(150, mp_debug) - endif - if (qg1d(k) .gt. qg_max) then - imax_qg = i - jmax_qg = j - kmax_qg = k - qg_max = qg1d(k) - elseif (qg1d(k) .lt. 0.0) then - write(mp_debug,*) 'WARNING, negative qg ', qg1d(k), & - ' at i,j,k=', i,j,k -! CALL wrf_debug(150, mp_debug) - endif - if (ni1d(k) .gt. ni_max) then - imax_ni = i - jmax_ni = j - kmax_ni = k - ni_max = ni1d(k) - elseif (ni1d(k) .lt. 0.0) then - write(mp_debug,*) 'WARNING, negative ni ', ni1d(k), & - ' at i,j,k=', i,j,k -! CALL wrf_debug(150, mp_debug) - endif - if (qv1d(k) .lt. 0.0) then - write(mp_debug,*) 'WARNING, negative qv ', qv1d(k), & - ' at i,j,k=', i,j,k -! CALL wrf_debug(150, mp_debug) - endif - enddo - - enddo i_loop - enddo j_loop - -! DEBUG - GT - write(mp_debug,'(a,6(a,e13.6,1x,a,i3,a,i3,a,i3,a,1x))') 'MP-GT:', & - 'qc: ', qc_max, '(', imax_qc, ',', jmax_qc, ',', kmax_qc, ')', & - 'qr: ', qr_max, '(', imax_qr, ',', jmax_qr, ',', kmax_qr, ')', & - 'qi: ', qi_max, '(', imax_qi, ',', jmax_qi, ',', kmax_qi, ')', & - 'qs: ', qs_max, '(', imax_qs, ',', jmax_qs, ',', kmax_qs, ')', & - 'qg: ', qg_max, '(', imax_qg, ',', jmax_qg, ',', kmax_qg, ')', & - 'ni: ', ni_max, '(', imax_ni, ',', jmax_ni, ',', kmax_ni, ')' -! CALL wrf_debug(150, mp_debug) -! END DEBUG - GT - - do i = 1, 256 - mp_debug(i:i) = char(0) - enddo - - END SUBROUTINE mp_gt_driver07 - -!+---+-----------------------------------------------------------------+ -! -!+---+-----------------------------------------------------------------+ -!+---+-----------------------------------------------------------------+ -!.. This subroutine computes the moisture tendencies of water vapor, -!.. cloud droplets, rain, cloud ice (pristine), snow, and graupel. -!.. Previously this code was based on Reisner et al (1998), but few of -!.. those pieces remain. A complete description is now found in -!.. Thompson et al. (2004, 2006). -!+---+-----------------------------------------------------------------+ -! - subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & - t1d, p1d, dzq, & - pptrain, pptsnow, pptgraul, pptice, & - kts, kte, dt, ii, jj) - - implicit none - -!..Sub arguments - INTEGER, INTENT(IN):: kts, kte, ii, jj - REAL, DIMENSION(kts:kte), INTENT(INOUT):: & - qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & - t1d, p1d - REAL, DIMENSION(kts:kte), INTENT(IN):: dzq - REAL, INTENT(INOUT):: pptrain, pptsnow, pptgraul, pptice - REAL, INTENT(IN):: dt - -!..Local variables - REAL, DIMENSION(kts:kte):: tten, qvten, qcten, qiten, & - qrten, qsten, qgten, niten - - DOUBLE PRECISION, DIMENSION(kts:kte):: prw_vcd - - DOUBLE PRECISION, DIMENSION(kts:kte):: prr_wau, prr_rcw, prr_rcs, & - prr_rcg, prr_sml, prr_gml, & - prr_rci, prv_rev - - DOUBLE PRECISION, DIMENSION(kts:kte):: pri_inu, pni_inu, pri_ihm, & - pni_ihm, pri_wfz, pni_wfz, & - pri_rfz, pni_rfz, pri_ide, & - pni_ide, pri_rci, pni_rci, & - pni_sci, pni_iau - - DOUBLE PRECISION, DIMENSION(kts:kte):: prs_iau, prs_sci, prs_rcs, & - prs_scw, prs_sde, prs_ihm, & - prs_ide - - DOUBLE PRECISION, DIMENSION(kts:kte):: prg_scw, prg_rfz, prg_gde, & - prg_gcw, prg_rci, prg_rcs, & - prg_rcg, prg_ihm - - REAL, DIMENSION(kts:kte):: temp, pres, qv - REAL, DIMENSION(kts:kte):: rc, ri, rr, rs, rg, ni - REAL, DIMENSION(kts:kte):: rho, rhof, rhof2 - REAL, DIMENSION(kts:kte):: qvs, qvsi - REAL, DIMENSION(kts:kte):: satw, sati, ssatw, ssati - REAL, DIMENSION(kts:kte):: diffu, visco, vsc2, & - tcond, lvap, ocp, lvt2 - - DOUBLE PRECISION, DIMENSION(kts:kte):: ilamr, ilamg, N0_r, N0_g - REAL, DIMENSION(kts:kte):: mvd_r, mvd_c - REAL, DIMENSION(kts:kte):: smob, smo2, smo1, & - smoc, smod, smoe, smof - - REAL, DIMENSION(kts:kte):: sed_r, sed_s, sed_g, sed_i, sed_n - - REAL:: rgvm, delta_tp, orho, onstep, lfus2 - DOUBLE PRECISION:: N0_exp, N0_min, lam_exp, lamc, lamr, lamg - DOUBLE PRECISION:: lami, ilami - REAL:: xDc, Dc_b, Dc_g, xDi, xDr, xDs, xDg, Ds_m, Dg_m - REAL:: zeta1, zeta, taud, tau - REAL:: stoke_r, stoke_s, stoke_g, stoke_i - REAL:: vti, vtr, vts, vtg - REAL, DIMENSION(kts:kte+1):: vtik, vtnk, vtrk, vtsk, vtgk - REAL, DIMENSION(kts:kte):: vts_boost - REAL:: Mrat, ils1, ils2, t1_vts, t2_vts, t3_vts, t4_vts, C_snow - REAL:: a_, b_, loga_, A1, A2, tf - REAL:: tempc, tc0, r_mvd1, r_mvd2, xkrat - REAL:: xnc, xri, xni, xmi, oxmi, xrc - REAL:: xsat, rate_max, sump, ratio - REAL:: clap, fcd, dfcd - REAL:: otemp, rvs, rvs_p, rvs_pp, gamsc, alphsc, t1_evap, t1_subl - REAL:: r_frac, g_frac - REAL:: Ef_rw, Ef_sw, Ef_gw - REAL:: dtsave, odts, odt, odzq - INTEGER:: i, k, k2, ksed1, ku, n, nn, nstep, k_0, kbot, IT, iexfrq - INTEGER:: nir, nis, nig, nii, nic - INTEGER:: idx_tc,idx_t,idx_s,idx_g,idx_r1,idx_r,idx_i1,idx_i,idx_c - INTEGER:: idx - LOGICAL:: melti, no_micro - LOGICAL, DIMENSION(kts:kte):: L_qc, L_qi, L_qr, L_qs, L_qg - -!+---+ - - no_micro = .true. - dtsave = dt - odt = 1./dt - odts = 1./dtsave - iexfrq = 1 - -!+---+-----------------------------------------------------------------+ -!.. Source/sink terms. First 2 chars: "pr" represents source/sink of -!.. mass while "pn" represents source/sink of number. Next char is one -!.. of "v" for water vapor, "r" for rain, "i" for cloud ice, "w" for -!.. cloud water, "s" for snow, and "g" for graupel. Next chars -!.. represent processes: "de" for sublimation/deposition, "ev" for -!.. evaporation, "fz" for freezing, "ml" for melting, "au" for -!.. autoconversion, "nu" for ice nucleation, "hm" for Hallet/Mossop -!.. secondary ice production, and "c" for collection followed by the -!.. character for the species being collected. ALL of these terms are -!.. positive (except for deposition/sublimation terms which can switch -!.. signs based on super/subsaturation) and are treated as negatives -!.. where necessary in the tendency equations. -!+---+-----------------------------------------------------------------+ - - do k = kts, kte - tten(k) = 0. - qvten(k) = 0. - qcten(k) = 0. - qiten(k) = 0. - qrten(k) = 0. - qsten(k) = 0. - qgten(k) = 0. - niten(k) = 0. - - prw_vcd(k) = 0. - - prv_rev(k) = 0. - prr_wau(k) = 0. - prr_rcw(k) = 0. - prr_rcs(k) = 0. - prr_rcg(k) = 0. - prr_sml(k) = 0. - prr_gml(k) = 0. - prr_rci(k) = 0. - - pri_inu(k) = 0. - pni_inu(k) = 0. - pri_ihm(k) = 0. - pni_ihm(k) = 0. - pri_wfz(k) = 0. - pni_wfz(k) = 0. - pri_rfz(k) = 0. - pni_rfz(k) = 0. - pri_ide(k) = 0. - pni_ide(k) = 0. - pri_rci(k) = 0. - pni_rci(k) = 0. - pni_sci(k) = 0. - pni_iau(k) = 0. - - prs_iau(k) = 0. - prs_sci(k) = 0. - prs_rcs(k) = 0. - prs_scw(k) = 0. - prs_sde(k) = 0. - prs_ihm(k) = 0. - prs_ide(k) = 0. - - prg_scw(k) = 0. - prg_rfz(k) = 0. - prg_gde(k) = 0. - prg_gcw(k) = 0. - prg_rci(k) = 0. - prg_rcs(k) = 0. - prg_rcg(k) = 0. - prg_ihm(k) = 0. - enddo - -!+---+-----------------------------------------------------------------+ -!..Put column of data into local arrays. -!+---+-----------------------------------------------------------------+ - do k = kts, kte - temp(k) = t1d(k) - qv(k) = MAX(1.E-10, qv1d(k)) - pres(k) = p1d(k) - rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622)) - if (qc1d(k) .gt. R1) then - no_micro = .false. - rc(k) = qc1d(k)*rho(k) - L_qc(k) = .true. - else - qc1d(k) = 0.0 - rc(k) = R1 - L_qc(k) = .false. - endif - if (qi1d(k) .gt. R1) then - no_micro = .false. - ri(k) = qi1d(k)*rho(k) - ni(k) = MAX(1., ni1d(k)*rho(k)) - L_qi(k) = .true. - lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi - ilami = 1./lami - xDi = (bm_i + mu_i + 1.) * ilami - if (xDi.lt. 30.E-6) then - lami = cie(2)/30.E-6 - ni(k) = MIN(250.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) - elseif (xDi.gt. 300.E-6) then - lami = cie(2)/300.E-6 - ni(k) = cig(1)*oig2*ri(k)/am_i*lami**bm_i - endif - else - qi1d(k) = 0.0 - ni1d(k) = 0.0 - ri(k) = R1 - ni(k) = 0.01 - L_qi(k) = .false. - endif - if (qr1d(k) .gt. R1) then - no_micro = .false. - rr(k) = qr1d(k)*rho(k) - L_qr(k) = .true. - else - qr1d(k) = 0.0 - rr(k) = R1 - L_qr(k) = .false. - endif - if (qs1d(k) .gt. R1) then - no_micro = .false. - rs(k) = qs1d(k)*rho(k) - L_qs(k) = .true. - else - qs1d(k) = 0.0 - rs(k) = R1 - L_qs(k) = .false. - endif - if (qg1d(k) .gt. R1) then - no_micro = .false. - rg(k) = qg1d(k)*rho(k) - L_qg(k) = .true. - else - qg1d(k) = 0.0 - rg(k) = R1 - L_qg(k) = .false. - endif - enddo - - -!+---+-----------------------------------------------------------------+ -!..Derive various thermodynamic variables frequently used. -!.. Saturation vapor pressure (mixing ratio) over liquid/ice comes from -!.. Flatau et al. 1992; enthalpy (latent heat) of vaporization from -!.. Bohren & Albrecht 1998; others from Pruppacher & Klett 1978. -!+---+-----------------------------------------------------------------+ - do k = kts, kte - tempc = temp(k) - 273.15 - rhof(k) = SQRT(RHO_NOT/rho(k)) - rhof2(k) = SQRT(rhof(k)) - qvs(k) = rslf(pres(k), temp(k)) - if (tempc .le. 0.0) then - qvsi(k) = rsif(pres(k), temp(k)) - else - qvsi(k) = qvs(k) - endif - satw(k) = qv(k)/qvs(k) - sati(k) = qv(k)/qvsi(k) - ssatw(k) = satw(k) - 1. - ssati(k) = sati(k) - 1. - if (abs(ssatw(k)).lt. eps) ssatw(k) = 0.0 - if (abs(ssati(k)).lt. eps) ssati(k) = 0.0 - if (no_micro .and. ssati(k).gt. 0.0) no_micro = .false. - diffu(k) = 2.11E-5*(temp(k)/273.15)**1.94 * (101325./pres(k)) - if (tempc .ge. 0.0) then - visco(k) = (1.718+0.0049*tempc)*1.0E-5 - else - visco(k) = (1.718+0.0049*tempc-1.2E-5*tempc*tempc)*1.0E-5 - endif - ocp(k) = 1./(Cp*(1.+0.887*qv(k))) - vsc2(k) = SQRT(rho(k)/visco(k)) - lvap(k) = lvap0 + (2106.0 - 4218.0)*tempc - tcond(k) = (5.69 + 0.0168*tempc)*1.0E-5 * 418.936 - enddo - -!+---+-----------------------------------------------------------------+ -!..If no existing hydrometeor species and no chance to initiate ice or -!.. condense cloud water, just exit quickly! -!+---+-----------------------------------------------------------------+ - - if (no_micro) return - -!+---+-----------------------------------------------------------------+ -!..Calculate y-intercept, slope, and useful moments for snow. -!+---+-----------------------------------------------------------------+ - if (.not. iiwarm) then - do k = kts, kte - if (.not. L_qs(k)) CYCLE - tc0 = MIN(-0.1, temp(k)-273.15) - smob(k) = rs(k)*oams - -!..All other moments based on reference, 2nd moment. If bm_s.ne.2, -!.. then we must compute actual 2nd moment and use as reference. - if (bm_s.gt.(2.0-1.e-3) .and. bm_s.lt.(2.0+1.e-3)) then - smo2(k) = smob(k) - else - loga_ = sa(1) + sa(2)*tc0 + sa(3)*bm_s & - + sa(4)*tc0*bm_s + sa(5)*tc0*tc0 & - + sa(6)*bm_s*bm_s + sa(7)*tc0*tc0*bm_s & - + sa(8)*tc0*bm_s*bm_s + sa(9)*tc0*tc0*tc0 & - + sa(10)*bm_s*bm_s*bm_s - a_ = 10.0**loga_ - b_ = sb(1) + sb(2)*tc0 + sb(3)*bm_s & - + sb(4)*tc0*bm_s + sb(5)*tc0*tc0 & - + sb(6)*bm_s*bm_s + sb(7)*tc0*tc0*bm_s & - + sb(8)*tc0*bm_s*bm_s + sb(9)*tc0*tc0*tc0 & - + sb(10)*bm_s*bm_s*bm_s - smo2(k) = (smob(k)/a_)**(1./b_) - endif - -!..Calculate 1st moment. Useful for depositional growth and melting. - loga_ = sa(1) + sa(2)*tc0 + sa(3) & - + sa(4)*tc0 + sa(5)*tc0*tc0 & - + sa(6) + sa(7)*tc0*tc0 & - + sa(8)*tc0 + sa(9)*tc0*tc0*tc0 & - + sa(10) - a_ = 10.0**loga_ - b_ = sb(1)+ sb(2)*tc0 + sb(3) + sb(4)*tc0 & - + sb(5)*tc0*tc0 + sb(6) & - + sb(7)*tc0*tc0 + sb(8)*tc0 & - + sb(9)*tc0*tc0*tc0 + sb(10) - smo1(k) = a_ * smo2(k)**b_ - -!..Calculate bm_s+1 (th) moment. Useful for diameter calcs. - loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(1) & - + sa(4)*tc0*cse(1) + sa(5)*tc0*tc0 & - + sa(6)*cse(1)*cse(1) + sa(7)*tc0*tc0*cse(1) & - + sa(8)*tc0*cse(1)*cse(1) + sa(9)*tc0*tc0*tc0 & - + sa(10)*cse(1)*cse(1)*cse(1) - a_ = 10.0**loga_ - b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(1) + sb(4)*tc0*cse(1) & - + sb(5)*tc0*tc0 + sb(6)*cse(1)*cse(1) & - + sb(7)*tc0*tc0*cse(1) + sb(8)*tc0*cse(1)*cse(1) & - + sb(9)*tc0*tc0*tc0 + sb(10)*cse(1)*cse(1)*cse(1) - smoc(k) = a_ * smo2(k)**b_ - -!..Calculate bv_s+2 (th) moment. Useful for riming. - loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(13) & - + sa(4)*tc0*cse(13) + sa(5)*tc0*tc0 & - + sa(6)*cse(13)*cse(13) + sa(7)*tc0*tc0*cse(13) & - + sa(8)*tc0*cse(13)*cse(13) + sa(9)*tc0*tc0*tc0 & - + sa(10)*cse(13)*cse(13)*cse(13) - a_ = 10.0**loga_ - b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(13) + sb(4)*tc0*cse(13) & - + sb(5)*tc0*tc0 + sb(6)*cse(13)*cse(13) & - + sb(7)*tc0*tc0*cse(13) + sb(8)*tc0*cse(13)*cse(13) & - + sb(9)*tc0*tc0*tc0 + sb(10)*cse(13)*cse(13)*cse(13) - smoe(k) = a_ * smo2(k)**b_ - -!..Calculate 1+(bv_s+1)/2 (th) moment. Useful for depositional growth. - loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(16) & - + sa(4)*tc0*cse(16) + sa(5)*tc0*tc0 & - + sa(6)*cse(16)*cse(16) + sa(7)*tc0*tc0*cse(16) & - + sa(8)*tc0*cse(16)*cse(16) + sa(9)*tc0*tc0*tc0 & - + sa(10)*cse(16)*cse(16)*cse(16) - a_ = 10.0**loga_ - b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(16) + sb(4)*tc0*cse(16) & - + sb(5)*tc0*tc0 + sb(6)*cse(16)*cse(16) & - + sb(7)*tc0*tc0*cse(16) + sb(8)*tc0*cse(16)*cse(16) & - + sb(9)*tc0*tc0*tc0 + sb(10)*cse(16)*cse(16)*cse(16) - smof(k) = a_ * smo2(k)**b_ - - enddo - -!+---+-----------------------------------------------------------------+ -!..Calculate y-intercept, slope values for graupel. -!+---+-----------------------------------------------------------------+ - N0_min = gonv_max - do k = kte, kts, -1 - if (.not. L_qg(k)) CYCLE - N0_exp = 200.0*rho(k)/rg(k) - N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max))) - N0_min = MIN(N0_exp, N0_min) - N0_exp = N0_min - lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1 - lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg - ilamg(k) = 1./lamg - N0_g(k) = N0_exp/(cgg(2)*lam_exp) * lamg**cge(2) - enddo - - endif - -!+---+-----------------------------------------------------------------+ -!..Calculate y-intercept & slope values for rain. -!.. New treatment for variable y-intercept of rain. When rain comes -!.. from melted snow/graupel, compute mass-weighted mean size, melt -!.. into water, compute its mvd and recompute slope/intercept. -!.. If rain not from melted snow, use old relation but hold N0_r -!.. constant at its lowest value. While doing all this, ensure rain -!.. mvd does not exceed reasonable size like 2.5 mm. -!+---+-----------------------------------------------------------------+ - N0_min = ronv_max - do k = kte, kts, -1 -! if (.not. L_qr(k)) CYCLE - N0_exp = ronv_c1*tanh(ronv_c0*(ronv_r0-rr(k))) + ronv_c2 - N0_min = MIN(N0_exp, N0_min) - N0_exp = N0_min - lam_exp = (N0_exp*am_r*crg(1)/rr(k))**ore1 - lamr = lam_exp * (crg(3)*org2*org1)**obmr - mvd_r(k) = (3.0+mu_r+0.672) / lamr - if (mvd_r(k) .gt. 2.5e-3) then - mvd_r(k) = 2.5e-3 - lamr = (3.0+mu_r+0.672) / 2.5e-3 - lam_exp = lamr * (crg(3)*org2*org1)**bm_r - N0_exp = org1*rr(k)/am_r * lam_exp**cre(1) - endif - N0_r(k) = N0_exp/(crg(2)*lam_exp) * lamr**cre(2) - ilamr(k) = 1./lamr - enddo - - if (.not. iiwarm) then - k_0 = kts - melti = .false. - do k = kte-1, kts, -1 - if ( (temp(k).gt. T_0) .and. (rr(k).gt. 0.001e-3) & - .and. ((rs(k+1)+rg(k+1)).gt. 0.01e-3) ) then - k_0 = MAX(k+1, k_0) - melti=.true. - goto 135 - endif - enddo - 135 continue - - if (melti) then -!.. Locate bottom of melting layer (if any). - kbot = kts - do k = k_0-1, kts, -1 - if ( (rs(k)+rg(k)).lt. 0.01e-3) goto 136 - enddo - 136 continue - kbot = MAX(k, kts) - -!.. Compute melted snow/graupel equiv water diameter one K-level above -!.. melting. Set starting rain mvd to either 50 microns or max from -!.. higher up in column. - if (L_qs(k_0)) then - xDs = smoc(k_0) / smob(k_0) - Ds_m = (am_s*xDs**bm_s / am_r)**obmr - else - Ds_m = 1.0e-6 - endif - if (L_qg(k_0)) then - xDg = (bm_g + mu_g + 1.) * ilamg(k_0) - Dg_m = (am_g*xDg**bm_g / am_r)**obmr - else - Dg_m = 1.0e-6 - endif - r_mvd1 = mvd_r(k_0) - r_mvd2 = MIN(MAX(Ds_m, Dg_m, r_mvd1+1.e-6, mvd_r(kbot)), & - 2.5e-3) - -!.. Within melting layer, apply linear increase of rain mvd from r_mvd1 -!.. to equiv melted snow/graupel value (r_mvd2). So, by the bottom of -!.. the melting layer, the rain will have an mvd that matches that from -!.. melted snow and/or graupel. - if (kbot.gt. 2) then - do k = k_0-1, kbot, -1 - if (.not. L_qr(k)) CYCLE - xkrat = REAL(k_0-k)/REAL(k_0-kbot) - mvd_r(k) = MAX(mvd_r(k), xkrat*(r_mvd2-r_mvd1)+r_mvd1) - lamr = (4.0+mu_r) / mvd_r(k) - lam_exp = lamr * (crg(3)*org2*org1)**bm_r - N0_exp = org1*rr(k)/am_r * lam_exp**cre(1) - N0_exp = MAX(DBLE(ronv_min), MIN(N0_exp, DBLE(ronv_max))) - lam_exp = (N0_exp*am_r*crg(1)/rr(k))**ore1 - lamr = lam_exp * (crg(3)*org2*org1)**obmr - mvd_r(k) = (3.0+mu_r+0.672) / lamr - N0_r(k) = rr(k)*lamr**cre(3) / (am_r*crg(3)) - ilamr(k) = 1./lamr - enddo - -!.. Below melting layer, hold N0_r constant unless changes to mixing -!.. ratio increase mvd beyond 2.5 mm threshold, then adjust slope and -!.. intercept to cap mvd at 2.5 mm. In future, we could lower N0_r to -!.. account for self-collection or other sinks. - do k = kbot-1, kts, -1 - if (.not. L_qr(k)) CYCLE - N0_r(k) = MIN(N0_r(k), N0_r(kbot)) - lamr = (N0_r(k)*am_r*crg(3)/rr(k))**(1./cre(3)) - lam_exp = lamr * (crg(3)*org2*org1)**bm_r - N0_exp = org1*rr(k)/am_r * lam_exp**cre(1) - N0_exp = MAX(DBLE(ronv_min), MIN(N0_exp, DBLE(ronv_max))) - lam_exp = (N0_exp*am_r*crg(1)/rr(k))**ore1 - lamr = lam_exp * (crg(3)*org2*org1)**obmr - mvd_r(k) = (3.0+mu_r+0.672) / lamr - if (mvd_r(k) .gt. 2.5e-3) then - mvd_r(k) = 2.5e-3 - lamr = (3.0+mu_r+0.672) / mvd_r(k) - endif - N0_r(k) = rr(k)*lamr**cre(3) / (am_r*crg(3)) - ilamr(k) = 1./lamr - enddo - endif - - endif - endif - -!+---+-----------------------------------------------------------------+ -!..Compute warm-rain process terms (except evap done later). -!+---+-----------------------------------------------------------------+ - - do k = kts, kte - if (.not. L_qc(k)) CYCLE - xDc = MAX(D0c*1.E6, ((rc(k)/(am_r*Nt_c))**obmr) * 1.E6) - lamc = (Nt_c*am_r* ccg(2) * ocg1 / rc(k))**obmr - mvd_c(k) = (3.0+mu_c+0.672) / lamc - -!..Autoconversion follows Berry & Reinhardt (1974) with characteristic -!.. diameters correctly computed from gamma distrib of cloud droplets. - if (rc(k).gt. 0.01e-3) then - Dc_g = ((ccg(3)*ocg2)**obmr / lamc) * 1.E6 - Dc_b = (xDc*xDc*xDc*Dc_g*Dc_g*Dc_g - xDc*xDc*xDc*xDc*xDc*xDc) & - **(1./6.) - zeta1 = 0.5*((6.25E-6*xDc*Dc_b*Dc_b*Dc_b - 0.4) & - + abs(6.25E-6*xDc*Dc_b*Dc_b*Dc_b - 0.4)) - zeta = 0.027*rc(k)*zeta1 - taud = 0.5*((0.5*Dc_b - 7.5) + abs(0.5*Dc_b - 7.5)) + R1 - tau = 3.72/(rc(k)*taud) - prr_wau(k) = zeta/tau - prr_wau(k) = MIN(DBLE(rc(k)*odts), prr_wau(k)) - endif - -!..Rain collecting cloud water. In CE, assume Dc<1). Either way, only bother to do sedimentation below -!.. 1st level that contains any sedimenting particles (k=ksed1 on down). -!+---+-----------------------------------------------------------------+ - nstep = 0 - ksed1 = 0 - do k = kte+1, kts, -1 - vtrk(k) = 0. - vtik(k) = 0. - vtnk(k) = 0. - vtsk(k) = 0. - vtgk(k) = 0. - enddo - do k = kte, kts, -1 - vtr = 0. - vti = 0. - vts = 0. - vtg = 0. - rhof(k) = SQRT(RHO_NOT/rho(k)) - - if (rr(k).gt. R2) then - lamr = 1./ilamr(k) - vtr = rhof(k)*av_r*crg(6)*org3 * (lamr/(lamr+fv_r))**cre(3) & - *((lamr+fv_r)**(-bv_r)) - vtrk(k) = vtr - endif - - if (.not. iiwarm) then - if (ri(k).gt. R2) then - lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi - ilami = 1./lami - vti = rhof(k)*av_i*cig(3)*oig2 * ilami**bv_i - vtik(k) = vti - vti = rhof(k)*av_i*cig(4)*oig1 * ilami**bv_i - vtnk(k) = vti - endif - - if (rs(k).gt. R2) then - xDs = smoc(k) / smob(k) - Mrat = 1./xDs - ils1 = 1./(Mrat*Lam0 + fv_s) - ils2 = 1./(Mrat*Lam1 + fv_s) - t1_vts = Kap0*csg(4)*ils1**cse(4) - t2_vts = Kap1*Mrat**mu_s*csg(10)*ils2**cse(10) - t3_vts = Kap0*csg(1)*ils1**cse(1) - t4_vts = Kap1*Mrat**mu_s*csg(7)*ils2**cse(7) - vts = rhof(k)*av_s * (t1_vts+t2_vts)/(t3_vts+t4_vts) - if (temp(k).gt. T_0) then - vtsk(k) = MAX(vts*vts_boost(k), vtrk(k)) - else - vtsk(k) = vts*vts_boost(k) - endif - endif - - if (rg(k).gt. R2) then - vtg = rhof(k)*av_g*cgg(6)*ogg3 * ilamg(k)**bv_g - if (temp(k).gt. T_0) then - vtgk(k) = MAX(vtg, vtrk(k)) - else - vtgk(k) = vtg - endif - endif - endif - - rgvm = MAX(vtik(k), vtrk(k), vtsk(k), vtgk(k)) - if (rgvm .gt. 1.E-3) then - ksed1 = MAX(ksed1, k) - delta_tp = dzq(k)/rgvm - nstep = MAX(nstep, INT(DT/delta_tp + 1.)) - endif - enddo - if (ksed1 .eq. kte) ksed1 = kte-1 - if (nstep .gt. 0) onstep = 1./REAL(nstep) - -!+---+-----------------------------------------------------------------+ -!..Sedimentation of mixing ratio is the integral of v(D)*m(D)*N(D)*dD, -!.. whereas neglect m(D) term for number concentration. Therefore, -!.. cloud ice has proper differential sedimentation. -!+---+-----------------------------------------------------------------+ - do n = 1, nstep - do k = kte, kts, -1 - sed_r(k) = vtrk(k)*rr(k) - sed_i(k) = vtik(k)*ri(k) - sed_n(k) = vtnk(k)*ni(k) - sed_g(k) = vtgk(k)*rg(k) - sed_s(k) = vtsk(k)*rs(k) - enddo - k = kte - odzq = 1./dzq(k) - orho = 1./rho(k) - qrten(k) = qrten(k) - sed_r(k)*odzq*onstep*orho - qiten(k) = qiten(k) - sed_i(k)*odzq*onstep*orho - niten(k) = niten(k) - sed_n(k)*odzq*onstep*orho - qgten(k) = qgten(k) - sed_g(k)*odzq*onstep*orho - qsten(k) = qsten(k) - sed_s(k)*odzq*onstep*orho - rr(k) = MAX(R1, rr(k) - sed_r(k)*odzq*DT*onstep) - ri(k) = MAX(R1, ri(k) - sed_i(k)*odzq*DT*onstep) - ni(k) = MAX(1., ni(k) - sed_n(k)*odzq*DT*onstep) - rg(k) = MAX(R1, rg(k) - sed_g(k)*odzq*DT*onstep) - rs(k) = MAX(R1, rs(k) - sed_s(k)*odzq*DT*onstep) - do k = ksed1, kts, -1 - odzq = 1./dzq(k) - orho = 1./rho(k) - qrten(k) = qrten(k) + (sed_r(k+1)-sed_r(k)) & - *odzq*onstep*orho - qiten(k) = qiten(k) + (sed_i(k+1)-sed_i(k)) & - *odzq*onstep*orho - niten(k) = niten(k) + (sed_n(k+1)-sed_n(k)) & - *odzq*onstep*orho - qgten(k) = qgten(k) + (sed_g(k+1)-sed_g(k)) & - *odzq*onstep*orho - qsten(k) = qsten(k) + (sed_s(k+1)-sed_s(k)) & - *odzq*onstep*orho - rr(k) = MAX(R1, rr(k) + (sed_r(k+1)-sed_r(k)) & - *odzq*DT*onstep) - ri(k) = MAX(R1, ri(k) + (sed_i(k+1)-sed_i(k)) & - *odzq*DT*onstep) - ni(k) = MAX(1., ni(k) + (sed_n(k+1)-sed_n(k)) & - *odzq*DT*onstep) - rg(k) = MAX(R1, rg(k) + (sed_g(k+1)-sed_g(k)) & - *odzq*DT*onstep) - rs(k) = MAX(R1, rs(k) + (sed_s(k+1)-sed_s(k)) & - *odzq*DT*onstep) - enddo - -!+---+-----------------------------------------------------------------+ -!..Precipitation reaching the ground. -!+---+-----------------------------------------------------------------+ - pptrain = pptrain + sed_r(kts)*DT*onstep - pptsnow = pptsnow + sed_s(kts)*DT*onstep - pptgraul = pptgraul + sed_g(kts)*DT*onstep - pptice = pptice + sed_i(kts)*DT*onstep - - enddo - -!+---+-----------------------------------------------------------------+ -!.. Instantly melt any cloud ice into cloud water if above 0C and -!.. instantly freeze any cloud water found below HGFR. -!+---+-----------------------------------------------------------------+ - if (.not. iiwarm) then - do k = kts, kte - xri = MAX(0.0, qi1d(k) + qiten(k)*DT) - if ( (temp(k).gt. T_0) .and. (xri.gt. 0.0) ) then - qcten(k) = qcten(k) + xri*odt - qiten(k) = -qi1d(k)*odt - niten(k) = -ni1d(k)*odt - tten(k) = tten(k) - lfus*ocp(k)*xri*odt*(1-IFDRY) - endif - - xrc = MAX(0.0, qc1d(k) + qcten(k)*DT) - if ( (temp(k).lt. HGFR) .and. (xrc.gt. 0.0) ) then - lfus2 = lsub - lvap(k) - qiten(k) = qiten(k) + xrc*odt - niten(k) = niten(k) + xrc/(2.*xm0i)*odt - qcten(k) = -xrc*odt - tten(k) = tten(k) + lfus2*ocp(k)*xrc*odt*(1-IFDRY) - endif - enddo - endif - -!+---+-----------------------------------------------------------------+ -!.. All tendencies computed, apply and pass back final values to parent. -!+---+-----------------------------------------------------------------+ - do k = kts, kte - t1d(k) = t1d(k) + tten(k)*DT - qv1d(k) = MAX(1.E-10, qv1d(k) + qvten(k)*DT) - qc1d(k) = qc1d(k) + qcten(k)*DT - if (qc1d(k) .le. R1) qc1d(k) = 0.0 - qi1d(k) = qi1d(k) + qiten(k)*DT - ni1d(k) = ni1d(k) + niten(k)*DT - if (qi1d(k) .le. R1) then - qi1d(k) = 0.0 - ni1d(k) = 0.0 - else - if (ni1d(k) .gt. 1.0) then - lami = (am_i*cig(2)*oig1*ni1d(k)/qi1d(k))**obmi - ilami = 1./lami - xDi = (bm_i + mu_i + 1.) * ilami - if (xDi.lt. 30.E-6) then - lami = cie(2)/30.E-6 - ni1d(k) = MIN(250.D3, cig(1)*oig2*qi1d(k)/am_i*lami**bm_i) - elseif (xDi.gt. 300.E-6) then - lami = cie(2)/300.E-6 - ni1d(k) = cig(1)*oig2*qi1d(k)/am_i*lami**bm_i - endif - else - lami = cie(2)/30.E-6 - ni1d(k) = MIN(250.D3, cig(1)*oig2*qi1d(k)/am_i*lami**bm_i) - endif - endif - qr1d(k) = qr1d(k) + qrten(k)*DT - if (qr1d(k) .le. R1) qr1d(k) = 0.0 - qs1d(k) = qs1d(k) + qsten(k)*DT - if (qs1d(k) .le. R1) qs1d(k) = 0.0 - qg1d(k) = qg1d(k) + qgten(k)*DT - if (qg1d(k) .le. R1) qg1d(k) = 0.0 - enddo - - end subroutine mp_thompson -!+---+-----------------------------------------------------------------+ -! -!+---+-----------------------------------------------------------------+ -!..Creation of the lookup tables and support functions found below here. -!+---+-----------------------------------------------------------------+ -!..Rain collecting graupel (and inverse). Explicit CE integration. -!+---+-----------------------------------------------------------------+ - - subroutine qr_acr_qg - - implicit none - -!..Local variables - INTEGER:: i, j, k, n, n2 - DOUBLE PRECISION, DIMENSION(nbg):: vg, N_g - DOUBLE PRECISION, DIMENSION(nbr):: vr, N_r - DOUBLE PRECISION:: N0_exp, N0_r, N0_g, lam_exp, lamg, lamr, N0_s - DOUBLE PRECISION:: massg, massr, dvg, dvr, t1, t2, z1, z2 - -!+---+ - - do n2 = 1, nbr - vr(n2) = av_r*Dr(n2)**bv_r * DEXP(-fv_r*Dr(n2)) - enddo - do n = 1, nbg - vg(n) = av_g*Dg(n)**bv_g - enddo - - do k = 1, ntb_r - do j = 1, ntb_r1 - - lam_exp = (N0r_exp(j)*am_r*crg(1)/r_r(k))**ore1 - lamr = lam_exp * (crg(3)*org2*org1)**obmr - N0_r = N0r_exp(j)/(crg(2)*lam_exp) * lamr**cre(2) - do n2 = 1, nbr - N_r(n2) = N0_r*Dr(n2)**mu_r *DEXP(-lamr*Dr(n2))*dtr(n2) - enddo - - do i = 1, ntb_g - N0_exp = 200.0d0/r_g(i) - N0_exp = DMAX1(gonv_min*1.d0,DMIN1(N0_exp,gonv_max*1.d0)) - lam_exp = (N0_exp*am_g*cgg(1)/r_g(i))**oge1 - lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg - N0_g = N0_exp/(cgg(2)*lam_exp) * lamg**cge(2) - do n = 1, nbg - N_g(n) = N0_g*Dg(n)**mu_g * DEXP(-lamg*Dg(n))*dtg(n) - enddo - - t1 = 0.0d0 - t2 = 0.0d0 - z1 = 0.0d0 - z2 = 0.0d0 - do n2 = 1, nbr - massr = am_r * Dr(n2)**bm_r - do n = 1, nbg - massg = am_g * Dg(n)**bm_g - - dvg = 0.5d0*((vr(n2) - vg(n)) + DABS(vr(n2)-vg(n))) - dvr = 0.5d0*((vg(n) - vr(n2)) + DABS(vg(n)-vr(n2))) - - t1 = t1+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & - *dvg*massg * N_g(n)* N_r(n2) - z1 = z1+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & - *dvg*massr * N_g(n)* N_r(n2) - - t2 = t2+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & - *dvr*massr * N_g(n)* N_r(n2) - z2 = z2+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & - *dvr*massg * N_g(n)* N_r(n2) - enddo - 97 continue - enddo - tcg_racg(i,j,k) = t1 - tmr_racg(i,j,k) = DMIN1(z1, r_r(k)*1.0d0) - tcr_gacr(i,j,k) = t2 - tmg_gacr(i,j,k) = z2 - enddo - enddo - enddo - - end subroutine qr_acr_qg -!+---+-----------------------------------------------------------------+ -! -!+---+-----------------------------------------------------------------+ -!..Rain collecting snow (and inverse). Explicit CE integration. -!+---+-----------------------------------------------------------------+ - - subroutine qr_acr_qs - - implicit none - -!..Local variables - INTEGER:: i, j, k, m, n, n2 - DOUBLE PRECISION, DIMENSION(nbr):: vr, D1, N_r - DOUBLE PRECISION, DIMENSION(nbs):: vs, N_s - DOUBLE PRECISION:: loga_, a_, b_, second, M0, M2, M3, Mrat, oM3 - DOUBLE PRECISION:: N0_r, lam_exp, lamr, slam1, slam2 - DOUBLE PRECISION:: dvs, dvr, masss, massr - DOUBLE PRECISION:: t1, t2, t3, t4, z1, z2, z3, z4 - -!+---+ - - do n2 = 1, nbr - vr(n2) = av_r*Dr(n2)**bv_r * DEXP(-fv_r*Dr(n2)) - D1(n2) = (vr(n2)/av_s)**(1./bv_s) - enddo - do n = 1, nbs - vs(n) = 1.5*av_s*Ds(n)**bv_s * DEXP(-fv_s*Ds(n)) - enddo - - do m = 1, ntb_r - do k = 1, ntb_r1 - lam_exp = (N0r_exp(k)*am_r*crg(1)/r_r(m))**ore1 - lamr = lam_exp * (crg(3)*org2*org1)**obmr - N0_r = N0r_exp(k)/(crg(2)*lam_exp) * lamr**cre(2) - do n2 = 1, nbr - N_r(n2) = N0_r*Dr(n2)**mu_r * DEXP(-lamr*Dr(n2))*dtr(n2) - enddo - - do j = 1, ntb_t - do i = 1, ntb_s - -!..From the bm_s moment, compute plus one moment. If we are not -!.. using bm_s=2, then we must transform to the pure 2nd moment -!.. (variable called "second") and then to the bm_s+1 moment. - - M2 = r_s(i)*oams *1.0d0 - if (bm_s.gt.2.0-1.E-3 .and. bm_s.lt.2.0+1.E-3) then - loga_ = sa(1) + sa(2)*Tc(j) + sa(3)*bm_s & - + sa(4)*Tc(j)*bm_s + sa(5)*Tc(j)*Tc(j) & - + sa(6)*bm_s*bm_s + sa(7)*Tc(j)*Tc(j)*bm_s & - + sa(8)*Tc(j)*bm_s*bm_s + sa(9)*Tc(j)*Tc(j)*Tc(j) & - + sa(10)*bm_s*bm_s*bm_s - a_ = 10.0**loga_ - b_ = sb(1) + sb(2)*Tc(j) + sb(3)*bm_s & - + sb(4)*Tc(j)*bm_s + sb(5)*Tc(j)*Tc(j) & - + sb(6)*bm_s*bm_s + sb(7)*Tc(j)*Tc(j)*bm_s & - + sb(8)*Tc(j)*bm_s*bm_s + sb(9)*Tc(j)*Tc(j)*Tc(j) & - + sb(10)*bm_s*bm_s*bm_s - second = (M2/a_)**(1./b_) - else - second = M2 - endif - - loga_ = sa(1) + sa(2)*Tc(j) + sa(3)*cse(1) & - + sa(4)*Tc(j)*cse(1) + sa(5)*Tc(j)*Tc(j) & - + sa(6)*cse(1)*cse(1) + sa(7)*Tc(j)*Tc(j)*cse(1) & - + sa(8)*Tc(j)*cse(1)*cse(1) + sa(9)*Tc(j)*Tc(j)*Tc(j) & - + sa(10)*cse(1)*cse(1)*cse(1) - a_ = 10.0**loga_ - b_ = sb(1)+sb(2)*Tc(j)+sb(3)*cse(1) + sb(4)*Tc(j)*cse(1) & - + sb(5)*Tc(j)*Tc(j) + sb(6)*cse(1)*cse(1) & - + sb(7)*Tc(j)*Tc(j)*cse(1) + sb(8)*Tc(j)*cse(1)*cse(1) & - + sb(9)*Tc(j)*Tc(j)*Tc(j)+sb(10)*cse(1)*cse(1)*cse(1) - M3 = a_ * second**b_ - - oM3 = 1./M3 - Mrat = M2*(M2*oM3)*(M2*oM3)*(M2*oM3) - M0 = (M2*oM3)**mu_s - slam1 = M2 * oM3 * Lam0 - slam2 = M2 * oM3 * Lam1 - - do n = 1, nbs - N_s(n) = Mrat*(Kap0*DEXP(-slam1*Ds(n)) & - + Kap1*M0*Ds(n)**mu_s * DEXP(-slam2*Ds(n)))*dts(n) - enddo - - t1 = 0.0d0 - t2 = 0.0d0 - t3 = 0.0d0 - t4 = 0.0d0 - z1 = 0.0d0 - z2 = 0.0d0 - z3 = 0.0d0 - z4 = 0.0d0 - do n2 = 1, nbr - massr = am_r * Dr(n2)**bm_r - do n = 1, nbs - masss = am_s * Ds(n)**bm_s - - dvs = 0.5d0*((vr(n2) - vs(n)) + DABS(vr(n2)-vs(n))) - dvr = 0.5d0*((vs(n) - vr(n2)) + DABS(vs(n)-vr(n2))) - - if (massr .gt. masss) then - t1 = t1+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & - *dvs*masss * N_s(n)* N_r(n2) - z1 = z1+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & - *dvs*massr * N_s(n)* N_r(n2) - else - t3 = t3+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & - *dvs*masss * N_s(n)* N_r(n2) - z3 = z3+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & - *dvs*massr * N_s(n)* N_r(n2) - endif - - if (massr .gt. masss) then - t2 = t2+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & - *dvr*massr * N_s(n)* N_r(n2) - z2 = z2+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & - *dvr*masss * N_s(n)* N_r(n2) - else - t4 = t4+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & - *dvr*massr * N_s(n)* N_r(n2) - z4 = z4+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & - *dvr*masss * N_s(n)* N_r(n2) - endif - - enddo - enddo - tcs_racs1(i,j,k,m) = t1 - tmr_racs1(i,j,k,m) = DMIN1(z1, r_r(m)*1.0d0) - tcs_racs2(i,j,k,m) = t3 - tmr_racs2(i,j,k,m) = z3 - tcr_sacr1(i,j,k,m) = t2 - tms_sacr1(i,j,k,m) = z2 - tcr_sacr2(i,j,k,m) = t4 - tms_sacr2(i,j,k,m) = z4 - enddo - enddo - enddo - enddo - - end subroutine qr_acr_qs -!+---+-----------------------------------------------------------------+ -! -!+---+-----------------------------------------------------------------+ -!..This is a literal adaptation of Bigg (1954) probability of drops of -!..a particular volume freezing. Given this probability, simply freeze -!..the proportion of drops summing their masses. -!+---+-----------------------------------------------------------------+ - - subroutine freezeH2O - - implicit none - -!..Local variables - INTEGER:: i, j, k, n, n2 - DOUBLE PRECISION, DIMENSION(nbr):: N_r, massr - DOUBLE PRECISION, DIMENSION(nbc):: N_c, massc - DOUBLE PRECISION:: sum1, sum2, sumn1, sumn2, & - prob, vol, Texp, orho_w, & - lam_exp, lamr, N0_r, lamc, N0_c, y - -!+---+ - - orho_w = 1./rho_w - - do n2 = 1, nbr - massr(n2) = am_r*Dr(n2)**bm_r - enddo - do n = 1, nbc - massc(n) = am_r*Dc(n)**bm_r - enddo - -!..Freeze water (smallest drops become cloud ice, otherwise graupel). - do k = 1, 45 -! print*, ' Freezing water for temp = ', -k - Texp = DEXP( DFLOAT(k) ) - 1.0D0 - do j = 1, ntb_r1 - do i = 1, ntb_r - lam_exp = (N0r_exp(j)*am_r*crg(1)/r_r(i))**ore1 - lamr = lam_exp * (crg(3)*org2*org1)**obmr - N0_r = N0r_exp(j)/(crg(2)*lam_exp) * lamr**cre(2) - sum1 = 0.0d0 - sum2 = 0.0d0 - sumn1 = 0.0d0 - do n2 = 1, nbr - N_r(n2) = N0_r*Dr(n2)**mu_r*DEXP(-lamr*Dr(n2))*dtr(n2) - vol = massr(n2)*orho_w - prob = 1.0D0 - DEXP(-120.0D0*vol*5.2D-4 * Texp) - if (massr(n2) .lt. xm0g) then - sumn1 = sumn1 + prob*N_r(n2) - sum1 = sum1 + prob*N_r(n2)*massr(n2) - else - sum2 = sum2 + prob*N_r(n2)*massr(n2) - endif - enddo - tpi_qrfz(i,j,k) = sum1 - tni_qrfz(i,j,k) = sumn1 - tpg_qrfz(i,j,k) = sum2 - enddo - enddo - do i = 1, ntb_c - lamc = 1.0D-6 * (Nt_c*am_r* ccg(2) * ocg1 / r_c(i))**obmr - N0_c = 1.0D-18 * Nt_c*ocg1 * lamc**cce(1) - sum1 = 0.0d0 - sumn2 = 0.0d0 - do n = 1, nbc - y = Dc(n)*1.0D6 - vol = massc(n)*orho_w - prob = 1.0D0 - DEXP(-120.0D0*vol*5.2D-4 * Texp) - N_c(n) = N0_c* y**mu_c * EXP(-lamc*y)*dtc(n) - N_c(n) = 1.0D24 * N_c(n) - sumn2 = sumn2 + prob*N_c(n) - sum1 = sum1 + prob*N_c(n)*massc(n) - enddo - tpi_qcfz(i,k) = sum1 - tni_qcfz(i,k) = sumn2 - enddo - enddo - - end subroutine freezeH2O -!+---+-----------------------------------------------------------------+ -! -!+---+-----------------------------------------------------------------+ -!..Cloud ice converting to snow since portion greater than min snow -!.. size. Given cloud ice content (kg/m**3), number concentration -!.. (#/m**3) and gamma shape parameter, mu_i, break the distrib into -!.. bins and figure out the mass/number of ice with sizes larger than -!.. D0s. Also, compute incomplete gamma function for the integration -!.. of ice depositional growth from diameter=0 to D0s. Amount of -!.. ice depositional growth is this portion of distrib while larger -!.. diameters contribute to snow growth (as in Harrington et al. 1995). -!+---+-----------------------------------------------------------------+ - - subroutine qi_aut_qs - - implicit none - -!..Local variables - INTEGER:: i, j, n2 - DOUBLE PRECISION, DIMENSION(nbi):: N_i - DOUBLE PRECISION:: N0_i, lami, Di_mean, t1, t2 - -!+---+ - - do j = 1, ntb_i1 - do i = 1, ntb_i - lami = (am_i*cig(2)*oig1*Nt_i(j)/r_i(i))**obmi - Di_mean = (bm_i + mu_i + 1.) / lami - N0_i = Nt_i(j)*oig1 * lami**cie(1) - t1 = 0.0d0 - t2 = 0.0d0 - if (SNGL(Di_mean) .gt. 5.*D0s) then - t1 = r_i(i) - t2 = Nt_i(j) - tpi_ide(i,j) = 0.0D0 - elseif (SNGL(Di_mean) .lt. D0i) then - t1 = 0.0D0 - t2 = 0.0D0 - tpi_ide(i,j) = 1.0D0 - else - tpi_ide(i,j) = GAMMP(mu_i+2.0, SNGL(lami)*D0s) * 1.0D0 - do n2 = 1, nbi - N_i(n2) = N0_i*Di(n2)**mu_i * DEXP(-lami*Di(n2))*dti(n2) - if (Di(n2).ge.D0s) then - t1 = t1 + N_i(n2) * am_i*Di(n2)**bm_i - t2 = t2 + N_i(n2) - endif - enddo - endif - tps_iaus(i,j) = t1 - tni_iaus(i,j) = t2 - enddo - enddo - - end subroutine qi_aut_qs -! -!+---+-----------------------------------------------------------------+ -!..Variable collision efficiency for rain collecting cloud water using -!.. method of Beard and Grover, 1974 if a/A less than 0.25; otherwise -!.. uses polynomials to get close match of Pruppacher & Klett Fig 14-9. -!+---+-----------------------------------------------------------------+ - - subroutine table_Efrw - - implicit none - -!..Local variables - DOUBLE PRECISION:: vtr, stokes, reynolds, Ef_rw - DOUBLE PRECISION:: p, yc0, F, G, H, z, K0, X - INTEGER:: i, j - - do j = 1, nbc - do i = 1, nbr - Ef_rw = 0.0 - p = Dc(j)/Dr(i) - if (Dr(i).lt.50.E-6 .or. Dc(j).lt.3.E-6) then - t_Efrw(i,j) = 0.0 - elseif (p.gt.0.25) then - X = Dc(j)*1.D6 - if (Dr(i) .lt. 75.e-6) then - Ef_rw = 0.026794*X - 0.20604 - elseif (Dr(i) .lt. 125.e-6) then - Ef_rw = -0.00066842*X*X + 0.061542*X - 0.37089 - elseif (Dr(i) .lt. 175.e-6) then - Ef_rw = 4.091e-06*X*X*X*X - 0.00030908*X*X*X & - + 0.0066237*X*X - 0.0013687*X - 0.073022 - elseif (Dr(i) .lt. 250.e-6) then - Ef_rw = 9.6719e-5*X*X*X - 0.0068901*X*X + 0.17305*X & - - 0.65988 - elseif (Dr(i) .lt. 350.e-6) then - Ef_rw = 9.0488e-5*X*X*X - 0.006585*X*X + 0.16606*X & - - 0.56125 - else - Ef_rw = 0.00010721*X*X*X - 0.0072962*X*X + 0.1704*X & - - 0.46929 - endif - else - vtr = -0.1021 + 4.932E3*Dr(i) - 0.9551E6*Dr(i)*Dr(i) & - + 0.07934E9*Dr(i)*Dr(i)*Dr(i) & - - 0.002362E12*Dr(i)*Dr(i)*Dr(i)*Dr(i) - stokes = Dc(j)*Dc(j)*vtr*rho_w/(9.*1.718E-5*Dr(i)) - reynolds = 9.*stokes/(p*p*rho_w) - - F = DLOG(reynolds) - G = -0.1007D0 - 0.358D0*F + 0.0261D0*F*F - K0 = DEXP(G) - z = DLOG(stokes/(K0+1.D-15)) - H = 0.1465D0 + 1.302D0*z - 0.607D0*z*z + 0.293D0*z*z*z - yc0 = 2.0D0/PI * ATAN(H) - Ef_rw = (yc0+p)*(yc0+p) / ((1.+p)*(1.+p)) - - endif - - t_Efrw(i,j) = MAX(0.0, MIN(SNGL(Ef_rw), 0.95)) - - enddo - enddo - - end subroutine table_Efrw - -!+---+-----------------------------------------------------------------+ -!..Variable collision efficiency for snow collecting cloud water using -!.. method of Wang and Ji, 2000 except equate melted snow diameter to -!.. their "effective collision cross-section." -!+---+-----------------------------------------------------------------+ - - subroutine table_Efsw - - implicit none - -!..Local variables - DOUBLE PRECISION:: Ds_m, vts, vtc, stokes, reynolds, Ef_sw - DOUBLE PRECISION:: p, yc0, F, G, H, z, K0 - INTEGER:: i, j - - do j = 1, nbc - vtc = 1.19D4 * (1.0D4*Dc(j)*Dc(j)*0.25D0) - do i = 1, nbs - vts = av_s*Ds(i)**bv_s * DEXP(-fv_s*Ds(i)) - vtc - Ds_m = (am_s*Ds(i)**bm_s / am_r)**obmr - p = Dc(j)/Ds_m - if (p.gt.0.25 .or. Ds(i).lt.D0s .or. Dc(j).lt.6.E-6 & - .or. vts.lt.1.E-3) then - t_Efsw(i,j) = 0.0 - else - stokes = Dc(j)*Dc(j)*vts*rho_w/(9.*1.718E-5*Ds_m) - reynolds = 9.*stokes/(p*p*rho_w) - - F = DLOG(reynolds) - G = -0.1007D0 - 0.358D0*F + 0.0261D0*F*F - K0 = DEXP(G) - z = DLOG(stokes/(K0+1.D-15)) - H = 0.1465D0 + 1.302D0*z - 0.607D0*z*z + 0.293D0*z*z*z - yc0 = 2.0D0/PI * ATAN(H) - Ef_sw = (yc0+p)*(yc0+p) / ((1.+p)*(1.+p)) - - t_Efsw(i,j) = MAX(0.0, MIN(SNGL(Ef_sw), 0.95)) - endif - - enddo - enddo - - end subroutine table_Efsw - -!+---+-----------------------------------------------------------------+ -!+---+-----------------------------------------------------------------+ - SUBROUTINE GCF(GAMMCF,A,X,GLN) -! --- RETURNS THE INCOMPLETE GAMMA FUNCTION Q(A,X) EVALUATED BY ITS -! --- CONTINUED FRACTION REPRESENTATION AS GAMMCF. ALSO RETURNS -! --- LN(GAMMA(A)) AS GLN. THE CONTINUED FRACTION IS EVALUATED BY -! --- A MODIFIED LENTZ METHOD. -! --- USES GAMMLN - IMPLICIT NONE - INTEGER, PARAMETER:: ITMAX=100 - REAL, PARAMETER:: gEPS=3.E-7 - REAL, PARAMETER:: FPMIN=1.E-30 - REAL, INTENT(IN):: A, X - REAL:: GAMMCF,GLN - INTEGER:: I - REAL:: AN,B,C,D,DEL,H - GLN=GAMMLN(A) - B=X+1.-A - C=1./FPMIN - D=1./B - H=D - DO 11 I=1,ITMAX - AN=-I*(I-A) - B=B+2. - D=AN*D+B - IF(ABS(D).LT.FPMIN)D=FPMIN - C=B+AN/C - IF(ABS(C).LT.FPMIN)C=FPMIN - D=1./D - DEL=D*C - H=H*DEL - IF(ABS(DEL-1.).LT.gEPS)GOTO 1 - 11 CONTINUE - PRINT *, 'A TOO LARGE, ITMAX TOO SMALL IN GCF' - 1 GAMMCF=EXP(-X+A*LOG(X)-GLN)*H - END SUBROUTINE GCF -! (C) Copr. 1986-92 Numerical Recipes Software 2.02 -!+---+-----------------------------------------------------------------+ - SUBROUTINE GSER(GAMSER,A,X,GLN) -! --- RETURNS THE INCOMPLETE GAMMA FUNCTION P(A,X) EVALUATED BY ITS -! --- ITS SERIES REPRESENTATION AS GAMSER. ALSO RETURNS LN(GAMMA(A)) -! --- AS GLN. -! --- USES GAMMLN - IMPLICIT NONE - INTEGER, PARAMETER:: ITMAX=100 - REAL, PARAMETER:: gEPS=3.E-7 - REAL, INTENT(IN):: A, X - REAL:: GAMSER,GLN - INTEGER:: N - REAL:: AP,DEL,SUM - GLN=GAMMLN(A) - IF(X.LE.0.)THEN - IF(X.LT.0.) PRINT *, 'X < 0 IN GSER' - GAMSER=0. - RETURN - ENDIF - AP=A - SUM=1./A - DEL=SUM - DO 11 N=1,ITMAX - AP=AP+1. - DEL=DEL*X/AP - SUM=SUM+DEL - IF(ABS(DEL).LT.ABS(SUM)*gEPS)GOTO 1 - 11 CONTINUE - PRINT *,'A TOO LARGE, ITMAX TOO SMALL IN GSER' - 1 GAMSER=SUM*EXP(-X+A*LOG(X)-GLN) - END SUBROUTINE GSER -! (C) Copr. 1986-92 Numerical Recipes Software 2.02 -!+---+-----------------------------------------------------------------+ - REAL FUNCTION GAMMLN(XX) -! --- RETURNS THE VALUE LN(GAMMA(XX)) FOR XX > 0. - IMPLICIT NONE - REAL, INTENT(IN):: XX - DOUBLE PRECISION, PARAMETER:: STP = 2.5066282746310005D0 - DOUBLE PRECISION, DIMENSION(6), PARAMETER:: & - COF = (/76.18009172947146D0, -86.50532032941677D0, & - 24.01409824083091D0, -1.231739572450155D0, & - .1208650973866179D-2, -.5395239384953D-5/) - DOUBLE PRECISION:: SER,TMP,X,Y - INTEGER:: J - - X=XX - Y=X - TMP=X+5.5D0 - TMP=(X+0.5D0)*LOG(TMP)-TMP - SER=1.000000000190015D0 - DO 11 J=1,6 - Y=Y+1.D0 - SER=SER+COF(J)/Y -11 CONTINUE - GAMMLN=TMP+LOG(STP*SER/X) - END FUNCTION GAMMLN -! (C) Copr. 1986-92 Numerical Recipes Software 2.02 -!+---+-----------------------------------------------------------------+ - REAL FUNCTION GAMMP(A,X) -! --- COMPUTES THE INCOMPLETE GAMMA FUNCTION P(A,X) -! --- SEE ABRAMOWITZ AND STEGUN 6.5.1 -! --- USES GCF,GSER - IMPLICIT NONE - REAL, INTENT(IN):: A,X - REAL:: GAMMCF,GAMSER,GLN - GAMMP = 0. - IF((X.LT.0.) .OR. (A.LE.0.)) THEN - PRINT *, 'BAD ARGUMENTS IN GAMMP' - RETURN - ELSEIF(X.LT.A+1.)THEN - CALL GSER(GAMSER,A,X,GLN) - GAMMP=GAMSER - ELSE - CALL GCF(GAMMCF,A,X,GLN) - GAMMP=1.-GAMMCF - ENDIF - END FUNCTION GAMMP -! (C) Copr. 1986-92 Numerical Recipes Software 2.02 -!+---+-----------------------------------------------------------------+ - REAL FUNCTION WGAMMA(y) - - IMPLICIT NONE - REAL, INTENT(IN):: y - - WGAMMA = EXP(GAMMLN(y)) - - END FUNCTION WGAMMA -!+---+-----------------------------------------------------------------+ -! THIS FUNCTION CALCULATES THE LIQUID SATURATION VAPOR MIXING RATIO AS -! A FUNCTION OF TEMPERATURE AND PRESSURE -! - REAL FUNCTION RSLF(P,T) - - IMPLICIT NONE - REAL, INTENT(IN):: P, T - REAL:: ESL,X - REAL, PARAMETER:: C0= .611583699E03 - REAL, PARAMETER:: C1= .444606896E02 - REAL, PARAMETER:: C2= .143177157E01 - REAL, PARAMETER:: C3= .264224321E-1 - REAL, PARAMETER:: C4= .299291081E-3 - REAL, PARAMETER:: C5= .203154182E-5 - REAL, PARAMETER:: C6= .702620698E-8 - REAL, PARAMETER:: C7= .379534310E-11 - REAL, PARAMETER:: C8=-.321582393E-13 - - X=MAX(-80.,T-273.16) - -! ESL=612.2*EXP(17.67*X/(T-29.65)) - ESL=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8))))))) - RSLF=.622*ESL/(P-ESL) - - END FUNCTION RSLF -! -!+---+-----------------------------------------------------------------+ -! THIS FUNCTION CALCULATES THE ICE SATURATION VAPOR MIXING RATIO AS A -! FUNCTION OF TEMPERATURE AND PRESSURE -! - REAL FUNCTION RSIF(P,T) - - IMPLICIT NONE - REAL, INTENT(IN):: P, T - REAL:: ESI,X - REAL, PARAMETER:: C0= .609868993E03 - REAL, PARAMETER:: C1= .499320233E02 - REAL, PARAMETER:: C2= .184672631E01 - REAL, PARAMETER:: C3= .402737184E-1 - REAL, PARAMETER:: C4= .565392987E-3 - REAL, PARAMETER:: C5= .521693933E-5 - REAL, PARAMETER:: C6= .307839583E-7 - REAL, PARAMETER:: C7= .105785160E-9 - REAL, PARAMETER:: C8= .161444444E-12 - - X=MAX(-80.,T-273.16) - ESI=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8))))))) - RSIF=.622*ESI/(P-ESI) - - END FUNCTION RSIF -!+---+-----------------------------------------------------------------+ -END MODULE module_mp_thompson07 -!+---+-----------------------------------------------------------------+ -! -! MODIFICATIONS TO MAKE IN OTHER MODULES (pre v2.2 code only) -! -! Use this new code by changing the "THOMPSON" section of code found -! in "module_microphysics_driver.F" with this section. [Of course -! remove the leading comment character that you see here.] -! -! CASE (THOMPSON) -! CALL wrf_debug ( 100 , 'microphysics_driver: calling thompson et al' ) -! IF ( PRESENT( QV_CURR ) .AND. PRESENT ( QC_CURR ) .AND. & -! PRESENT( QR_CURR ) .AND. PRESENT ( QI_CURR ) .AND. & -! PRESENT( QS_CURR ) .AND. PRESENT ( QG_CURR ) .AND. & -! PRESENT ( QNI_CURR ).AND. & -! PRESENT( RAINNC ) .AND. PRESENT ( RAINNCV ) ) THEN -! CALL mp_gt_driver( & -! QV=qv_curr, & -! QC=qc_curr, & -! QR=qr_curr, & -! QI=qi_curr, & -! QS=qs_curr, & -! QG=qg_curr, & -! NI=qni_curr, & -! TH=th, & -! PII=pi_phy, & -! P=p, & -! DZ=dz8w, & -! DT_IN=dt, & -! ITIMESTEP=itimestep, & -! RAINNC=RAINNC, & -! RAINNCV=RAINNCV, & -! SR=SR & -! ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & -! ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & -! ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte) -! ELSE -! CALL wrf_error_fatal ( 'arguments not present for calling thompson_et_al' ) -! ENDIF -! -! Then rename the call from "thomp_init" to "thompson_init" in the file -! "module_physics_init.F" (seen below): -! -! CASE (THOMPSON) -! CALL thompson_init diff --git a/src/fim/FIMsrc/fim/wrfphys/module_mp_wdm5.F b/src/fim/FIMsrc/fim/wrfphys/module_mp_wdm5.F deleted file mode 100644 index 466f3da..0000000 --- a/src/fim/FIMsrc/fim/wrfphys/module_mp_wdm5.F +++ /dev/null @@ -1,1625 +0,0 @@ -#if ( RWORDSIZE == 4 ) -# define VREC vsrec -# define VSQRT vssqrt -#else -# define VREC vrec -# define VSQRT vsqrt -#endif - -!Including inline expansion statistical function -MODULE module_mp_wdm5 -! - REAL, PARAMETER, PRIVATE :: dtcldcr = 120. ! maximum time step for minor loops - REAL, PARAMETER, PRIVATE :: n0r = 8.e6 ! intercept parameter rain - REAL, PARAMETER, PRIVATE :: avtr = 841.9 ! a constant for terminal velocity of rain - REAL, PARAMETER, PRIVATE :: bvtr = 0.8 ! a constant for terminal velocity of rain - REAL, PARAMETER, PRIVATE :: r0 = .8e-5 ! 8 microm in contrast to 10 micro m - REAL, PARAMETER, PRIVATE :: peaut = .55 ! collection efficiency - REAL, PARAMETER, PRIVATE :: xncr = 3.e8 ! maritime cloud in contrast to 3.e8 in tc80 - REAL, PARAMETER, PRIVATE :: xmyu = 1.718e-5 ! the dynamic viscosity kgm-1s-1 - REAL, PARAMETER, PRIVATE :: avts = 11.72 ! a constant for terminal velocity of snow - REAL, PARAMETER, PRIVATE :: bvts = .41 ! a constant for terminal velocity of snow - REAL, PARAMETER, PRIVATE :: n0smax = 1.e11 ! maximum n0s (t=-90C unlimited) - REAL, PARAMETER, PRIVATE :: lamdacmax = 1.e10 ! limited maximum value for slope parameter of cloud water - REAL, PARAMETER, PRIVATE :: lamdarmax = 1.e8 ! limited maximum value for slope parameter of rain - REAL, PARAMETER, PRIVATE :: lamdasmax = 1.e5 ! limited maximum value for slope parameter of snow - REAL, PARAMETER, PRIVATE :: lamdagmax = 6.e4 ! limited maximum value for slope parameter of graupel - REAL, PARAMETER, PRIVATE :: dicon = 11.9 ! constant for the cloud-ice diamter - REAL, PARAMETER, PRIVATE :: dimax = 500.e-6 ! limited maximum value for the cloud-ice diamter - REAL, PARAMETER, PRIVATE :: n0s = 2.e6 ! temperature dependent intercept parameter snow - REAL, PARAMETER, PRIVATE :: alpha = .12 ! .122 exponen factor for n0s - REAL, PARAMETER, PRIVATE :: pfrz1 = 100. ! constant in Biggs freezing - REAL, PARAMETER, PRIVATE :: pfrz2 = 0.66 ! constant in Biggs freezing - REAL, PARAMETER, PRIVATE :: qcrmin = 1.e-9 ! minimun values for qr, qs, and qg - REAL, PARAMETER, PRIVATE :: ncmin = 1.e1 ! minimum value for Nc - REAL, PARAMETER, PRIVATE :: nrmin = 1.e-2 ! minimum value for Nr - REAL, PARAMETER, PRIVATE :: eacrc = 1.0 ! Snow/cloud-water collection efficiency -! - REAL, PARAMETER, PRIVATE :: satmax = 1.0048 ! maximum saturation value for CCN activation - ! 1.008 for maritime air mass /1.0048 for conti - REAL, PARAMETER, PRIVATE :: actk = 0.6 ! parameter for the CCN activation - REAL, PARAMETER, PRIVATE :: actr = 1.5 ! radius of activated CCN drops - REAL, PARAMETER, PRIVATE :: ncrk1 = 3.03e3 ! Long's collection kernel coefficient - REAL, PARAMETER, PRIVATE :: ncrk2 = 2.59e15 ! Long's collection kernel coefficient - REAL, PARAMETER, PRIVATE :: di100 = 1.e-4 ! parameter related with accretion and collection of cloud drops - REAL, PARAMETER, PRIVATE :: di600 = 6.e-4 ! parameter related with accretion and collection of cloud drops - REAL, PARAMETER, PRIVATE :: di2000 = 20.e-4 ! parameter related with accretion and collection of cloud drops - REAL, PARAMETER, PRIVATE :: di82 = 82.e-6 ! dimater related with raindrops evaporation - REAL, PARAMETER, PRIVATE :: di15 = 15.e-6 ! auto conversion takes place beyond this diameter - - REAL, SAVE :: & - qc0, qck1,pidnc,bvtr1,bvtr2,bvtr3,bvtr4, & - bvtr5,bvtr7,bvtr2o5,bvtr3o5,g1pbr,g2pbr, & - g3pbr,g4pbr,g5pbr,g7pbr,g5pbro2,g7pbro2, & - pvtr,pvtrn,eacrr,pacrr, & - precr1,precr2,xmmax,roqimax,bvts1, & - bvts2,bvts3,bvts4,g1pbs,g3pbs,g4pbs, & - g5pbso2,pvts,pacrs,precs1,precs2,pidn0r, & - pidn0s,pidnr,xlv1,pacrc, & - rslopecmax,rslopec2max,rslopec3max, & - rslopermax,rslopesmax,rslopegmax, & - rsloperbmax,rslopesbmax,rslopegbmax, & - rsloper2max,rslopes2max,rslopeg2max, & - rsloper3max,rslopes3max,rslopeg3max -! -! Specifies code-inlining of fpvs function in WDM52D below. JM 20040507 -! -CONTAINS -!=================================================================== -! - SUBROUTINE wdm5(th, q, qc, qr, qi, qs & - ,nn, nc, nr & - ,den, pii, p, delz & - ,delt,g, cpd, cpv, ccn0, rd, rv, t0c & - ,ep1, ep2, qmin & - ,XLS, XLV0, XLF0, den0, denr & - ,cliq,cice,psat & - ,rain, rainncv & - ,snow, snowncv & - ,sr & - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte & - ) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -! -! This code is a WRF double-moment 5-class mixed ice -! microphyiscs scheme (WDM5). The WDM microphysics scheme predicts -! number concentrations for warm rain species including clouds and -! rain. cloud condensation nuclei (CCN) is also predicted. -! The cold rain species including ice, snow, graupel follow the -! WRF single-moment 5-class microphysics (WSM5) -! in which theoretical background for WSM ice phase microphysics is -! based on Hong et al. (2004). -! The WDM scheme is described in Lim and Hong (2009). -! All units are in m.k.s. and source/sink terms in kgkg-1s-1. -! -! WDM5 cloud scheme -! -! Coded by Kyo-Sun Lim and Song-You Hong (Yonsei Univ.) Fall 2008 -! -! Implemented by Kyo-Sun Lim and Jimy Dudhia (NCAR) Winter 2008 -! -! Reference) Lim and Hong (LH, 2009) Manuscript in preperation -! Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev. -! Hong and Lim (HL, 2006) J. Korean Meteor. Soc. -! Cohard and Pinty (CP, 2000) Quart. J. Roy. Meteor. Soc. -! Khairoutdinov and Kogan (KK, 2000) Mon. Wea. Rev. -! Dudhia, Hong and Lim (DHL, 2008) J. Meteor. Soc. Japan -! -! Lin, Farley, Orville (LFO, 1983) J. Appl. Meteor. -! Rutledge, Hobbs (RH83, 1983) J. Atmos. Sci. -! Rutledge, Hobbs (RH84, 1984) J. Atmos. Sci. -! - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & - ims,ime, jms,jme, kms,kme , & - its,ite, jts,jte, kts,kte - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(INOUT) :: & - th, & - q, & - qc, & - qi, & - qr, & - qs, & - nn, & - nc, & - nr - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: & - den, & - pii, & - p, & - delz - REAL, INTENT(IN ) :: delt, & - g, & - rd, & - rv, & - t0c, & - den0, & - cpd, & - cpv, & - ccn0, & - ep1, & - ep2, & - qmin, & - XLS, & - XLV0, & - XLF0, & - cliq, & - cice, & - psat, & - denr - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(INOUT) :: rain, & - rainncv, & - sr - - REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, & - INTENT(INOUT) :: snow, & - snowncv - -! LOCAL VAR - REAL, DIMENSION( its:ite , kts:kte ) :: t - REAL, DIMENSION( its:ite , kts:kte, 2 ) :: qci, qrs - REAL, DIMENSION( its:ite , kts:kte, 3 ) :: ncr - CHARACTER*256 :: emess - INTEGER :: mkx_test - INTEGER :: i,j,k - -!------------------------------------------------------------------- - -#ifndef RUN_ON_GPU - DO j=jts,jte - DO k=kts,kte - DO i=its,ite - t(i,k)=th(i,k,j)*pii(i,k,j) - qci(i,k,1) = qc(i,k,j) - qci(i,k,2) = qi(i,k,j) - qrs(i,k,1) = qr(i,k,j) - qrs(i,k,2) = qs(i,k,j) - ncr(i,k,1) = nn(i,k,j) - ncr(i,k,2) = nc(i,k,j) - ncr(i,k,3) = nr(i,k,j) - ENDDO - ENDDO - - ! Sending array starting locations of optional variables may cause - ! troubles, so we explicitly change the call. - - CALL wdm52D(t, q(ims,kms,j), qci, qrs, ncr & - ,den(ims,kms,j) & - ,p(ims,kms,j), delz(ims,kms,j) & - ,delt,g, cpd, cpv, ccn0, rd, rv, t0c & - ,ep1, ep2, qmin & - ,XLS, XLV0, XLF0, den0, denr & - ,cliq,cice,psat & - ,j & - ,rain(ims,j),rainncv(ims,j) & - ,sr(ims,j) & - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte & - ,snow(ims,j),snowncv(ims,j) & - ) - - DO K=kts,kte - DO I=its,ite - th(i,k,j)=t(i,k)/pii(i,k,j) - qc(i,k,j) = qci(i,k,1) - qi(i,k,j) = qci(i,k,2) - qr(i,k,j) = qrs(i,k,1) - qs(i,k,j) = qrs(i,k,2) - nn(i,k,j) = ncr(i,k,1) - nc(i,k,j) = ncr(i,k,2) - nr(i,k,j) = ncr(i,k,3) - ENDDO - ENDDO - ENDDO -#else - CALL get_wsm5_gpu_levels ( mkx_test ) - IF ( mkx_test .LT. kte ) THEN - WRITE(emess,*)'Number of levels compiled for GPU WSM5 too small. ', & - mkx_test,' < ',kte - CALL wrf_error_fatal(emess) - ENDIF - CALL wsm5_host ( & - th(its:ite,kts:kte,jts:jte), pii(its:ite,kts:kte,jts:jte) & - ,q(its:ite,kts:kte,jts:jte), qc(its:ite,kts:kte,jts:jte) & - ,qi(its:ite,kts:kte,jts:jte), qr(its:ite,kts:kte,jts:jte) & - ,qs(its:ite,kts:kte,jts:jte), den(its:ite,kts:kte,jts:jte) & - ,p(its:ite,kts:kte,jts:jte), delz(its:ite,kts:kte,jts:jte) & - ,delt & - ,rain(its:ite,jts:jte),rainncv(its:ite,jts:jte) & - ,snow(its:ite,jts:jte),snowncv(its:ite,jts:jte) & - ,sr(its:ite,jts:jte) & - ,its, ite, jts, jte, kts, kte & - ,its, ite, jts, jte, kts, kte & - ,its, ite, jts, jte, kts, kte & - ) -#endif - - END SUBROUTINE wdm5 -!=================================================================== -! - SUBROUTINE wdm52D(t, q, qci, qrs, ncr, den, p, delz & - ,delt,g, cpd, cpv, ccn0, rd, rv, t0c & - ,ep1, ep2, qmin & - ,XLS, XLV0, XLF0, den0, denr & - ,cliq,cice,psat & - ,lat & - ,rain,rainncv & - ,sr & - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte & - ,snow,snowncv & - ) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & - ims,ime, jms,jme, kms,kme , & - its,ite, jts,jte, kts,kte, & - lat - REAL, DIMENSION( its:ite , kts:kte ), & - INTENT(INOUT) :: & - t - REAL, DIMENSION( its:ite , kts:kte, 2 ), & - INTENT(INOUT) :: & - qci, & - qrs - REAL, DIMENSION( its:ite , kts:kte, 3 ), & - INTENT(INOUT) :: & - ncr - REAL, DIMENSION( ims:ime , kms:kme ), & - INTENT(INOUT) :: & - q - REAL, DIMENSION( ims:ime , kms:kme ), & - INTENT(IN ) :: & - den, & - p, & - delz - REAL, INTENT(IN ) :: delt, & - g, & - cpd, & - cpv, & - ccn0, & - t0c, & - den0, & - rd, & - rv, & - ep1, & - ep2, & - qmin, & - XLS, & - XLV0, & - XLF0, & - cliq, & - cice, & - psat, & - denr - REAL, DIMENSION( ims:ime ), & - INTENT(INOUT) :: rain, & - rainncv, & - sr - - REAL, DIMENSION( ims:ime ), OPTIONAL, & - INTENT(INOUT) :: snow, & - snowncv - -! LOCAL VAR - REAL, DIMENSION( its:ite , kts:kte , 2) :: & - rh, qs, rslope, rslope2, rslope3, rslopeb, & - falk, fall, work1 - REAL, DIMENSION( its:ite , kts:kte ) :: & - rslopec, rslopec2,rslopec3 - REAL, DIMENSION( its:ite , kts:kte, 2) :: & - avedia - REAL, DIMENSION( its:ite , kts:kte ) :: & - workn,falln,falkn - REAL, DIMENSION( its:ite , kts:kte ) :: & - falkc, work1c, work2c, fallc - REAL, DIMENSION( its:ite , kts:kte ) :: & - pcact, praut, psaut, prevp, psdep, pracw, psaci, psacw, & - pigen, pidep, pcond, prevp_s, & - xl, cpm, work2, psmlt, psevp, denfac, xni, & - n0sfac - REAL, DIMENSION( its:ite , kts:kte ) :: & - nraut, nracw, nrevp, ncevp, nccol, nrcol, & - nsacw, nseml, ncact - REAL :: ifac, sfac -! -#define WSM_NO_CONDITIONAL_IN_VECTOR -#ifdef WSM_NO_CONDITIONAL_IN_VECTOR - REAL, DIMENSION(its:ite) :: xal, xbl -#endif - -! variables for optimization - REAL, DIMENSION( its:ite ) :: tvec1 - INTEGER, DIMENSION( its:ite ) :: mnstep, numndt - INTEGER, DIMENSION( its:ite ) :: mstep, numdt - REAL, DIMENSION(its:ite) :: rmstep - REAL dtcldden, rdelz, rdtcld - LOGICAL, DIMENSION( its:ite ) :: flgcld - REAL :: pi, & - cpmcal, xlcal, lamdac, lamdar, lamdas, diffus, & - viscos, xka, venfac, conden, diffac, & - x, y, z, a, b, c, d, e, & - ndt, qdt, holdrr, holdrs, supcol, supcolt, pvt, & - coeres, supsat, dtcld, xmi, eacrs, satdt, & - vt2i,vt2s,acrfac, coecol, & - nfrzdtr, nfrzdtc, & - taucon, lencon, lenconcr, & - qimax, diameter, xni0, roqi0, & - fallsum, fallsum_qsi, xlwork2, factor, source, & - value, xlf, pfrzdtc, pfrzdtr, supice - REAL :: temp - REAL :: holdc, holdci - INTEGER :: i, j, k, mstepmax, & - iprt, latd, lond, loop, loops, ifsat, n -! Temporaries used for inlining fpvs function - REAL :: dldti, xb, xai, tr, xbi, xa, hvap, cvap, hsub, dldt, ttp - REAL :: logtr -! -!================================================================= -! compute internal functions -! - cpmcal(x) = cpd*(1.-max(x,qmin))+max(x,qmin)*cpv - xlcal(x) = xlv0-xlv1*(x-t0c) -!---------------------------------------------------------------- -! size distributions: (x=mixing ratio, y=air density): -! valid for mixing ratio > 1.e-9 kg/kg. -! -! Optimizatin : A**B => exp(log(A)*(B)) - lamdac(x,y,z)= exp(log(((pidnc*z)/(x*y)))*((.33333333))) - lamdar(x,y,z)= exp(log(((pidnr*z)/(x*y)))*((.33333333))) - lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 -! -!---------------------------------------------------------------- -! diffus: diffusion coefficient of the water vapor -! viscos: kinematic viscosity(m2s-1) -! diffus(x,y) = 8.794e-5 * exp(log(x)*(1.81)) / y -! viscos(x,y) = 1.496e-6 * (x*sqrt(x)) /(x+120.)/y -! xka(x,y) = 1.414e3*viscos(x,y)*y -! diffac(a,b,c,d,e) = d*a*a/(xka(c,d)*rv*c*c)+1./(e*diffus(c,b)) -! venfac(a,b,c) = exp(log((viscos(b,c)/diffus(b,a)))*((.3333333))) & -! /sqrt(viscos(b,c))*sqrt(sqrt(den0/c)) -! conden(a,b,c,d,e) = (max(b,qmin)-c)/(1.+d*d/(rv*e)*c/(a*a)) -! -! - pi = 4. * atan(1.) -! -!---------------------------------------------------------------- -! paddint 0 for negative values generated by dynamics -! - do k = kts, kte - do i = its, ite - qci(i,k,1) = max(qci(i,k,1),0.0) - qrs(i,k,1) = max(qrs(i,k,1),0.0) - qci(i,k,2) = max(qci(i,k,2),0.0) - qrs(i,k,2) = max(qrs(i,k,2),0.0) - ncr(i,k,1) = max(ncr(i,k,1),0.) - ncr(i,k,2) = max(ncr(i,k,2),0.) - ncr(i,k,3) = max(ncr(i,k,3),0.) - enddo - enddo -! -! latent heat for phase changes and heat capacity. neglect the -! changes during microphysical process calculation -! emanuel(1994) -! - do k = kts, kte - do i = its, ite - cpm(i,k) = cpmcal(q(i,k)) - xl(i,k) = xlcal(t(i,k)) - enddo - enddo -! -!---------------------------------------------------------------- -! compute the minor time steps. -! - loops = max(nint(delt/dtcldcr),1) - dtcld = delt/loops - if(delt.le.dtcldcr) dtcld = delt -! - do loop = 1,loops -! -!---------------------------------------------------------------- -! initialize the large scale variables -! - do i = its, ite - mstep(i) = 1 - mnstep(i) = 1 - flgcld(i) = .true. - enddo -! -! do k = kts, kte -! do i = its, ite -! denfac(i,k) = sqrt(den0/den(i,k)) -! enddo -! enddo - do k = kts, kte - CALL VREC( tvec1(its), den(its,k), ite-its+1) - do i = its, ite - tvec1(i) = tvec1(i)*den0 - enddo - CALL VSQRT( denfac(its,k), tvec1(its), ite-its+1) - enddo -! -! Inline expansion for fpvs -! qs(i,k,1) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) -! qs(i,k,2) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) - hsub = xls - hvap = xlv0 - cvap = cpv - ttp=t0c+0.01 - dldt=cvap-cliq - xa=-dldt/rv - xb=xa+hvap/(rv*ttp) - dldti=cvap-cice - xai=-dldti/rv - xbi=xai+hsub/(rv*ttp) - -! this is for compilers where the conditional inhibits vectorization -#ifdef WSM_NO_CONDITIONAL_IN_VECTOR - do k = kts, kte - do i = its, ite - if(t(i,k).lt.ttp) then - xal(i) = xai - xbl(i) = xbi - else - xal(i) = xa - xbl(i) = xb - endif - enddo - do i = its, ite - tr=ttp/t(i,k) - logtr=log(tr) - qs(i,k,1)=psat*exp(logtr*(xa)+xb*(1.-tr)) - qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k) - qs(i,k,1)) - qs(i,k,1) = max(qs(i,k,1),qmin) - rh(i,k,1) = max(q(i,k) / qs(i,k,1),qmin) - qs(i,k,2)=psat*exp(logtr*(xal(i))+xbl(i)*(1.-tr)) - qs(i,k,2) = ep2 * qs(i,k,2) / (p(i,k) - qs(i,k,2)) - qs(i,k,2) = max(qs(i,k,2),qmin) - rh(i,k,2) = max(q(i,k) / qs(i,k,2),qmin) - enddo - enddo -#else - do k = kts, kte - do i = its, ite - tr=ttp/t(i,k) - logtr=log(tr) - qs(i,k,1)=psat*exp(logtr*(xa)+xb*(1.-tr)) - qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k) - qs(i,k,1)) - qs(i,k,1) = max(qs(i,k,1),qmin) - rh(i,k,1) = max(q(i,k) / qs(i,k,1),qmin) - if(t(i,k).lt.ttp) then - qs(i,k,2)=psat*exp(logtr*(xai)+xbi*(1.-tr)) - else - qs(i,k,2)=psat*exp(logtr*(xa)+xb*(1.-tr)) - endif - qs(i,k,2) = ep2 * qs(i,k,2) / (p(i,k) - qs(i,k,2)) - qs(i,k,2) = max(qs(i,k,2),qmin) - rh(i,k,2) = max(q(i,k) / qs(i,k,2),qmin) - enddo - enddo -#endif -! -!---------------------------------------------------------------- -! initialize the variables for microphysical physics -! - do k = kts, kte - do i = its, ite - prevp(i,k) = 0. - psdep(i,k) = 0. - praut(i,k) = 0. - psaut(i,k) = 0. - pracw(i,k) = 0. - psaci(i,k) = 0. - psacw(i,k) = 0. - pigen(i,k) = 0. - pidep(i,k) = 0. - pcond(i,k) = 0. - psmlt(i,k) = 0. - psevp(i,k) = 0. - pcact(i,k) = 0. - prevp_s(i,k) = 0. - falk(i,k,1) = 0. - falk(i,k,2) = 0. - fall(i,k,1) = 0. - fall(i,k,2) = 0. - fallc(i,k) = 0. - falkc(i,k) = 0. - falln(i,k) = 0. - falkn(i,k) = 0. - xni(i,k) = 1.e3 - nsacw(i,k) = 0. - nseml(i,k) = 0. - nracw(i,k) = 0. - nccol(i,k) = 0. - nrcol(i,k) = 0. - ncact(i,k) = 0. - nraut(i,k) = 0. - nrevp(i,k) = 0. - ncevp(i,k) = 0. - enddo - enddo -! -!---------------------------------------------------------------- -! compute the fallout term: -! first, vertical terminal velosity for minor loops -! - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) -!--------------------------------------------------------------- -! n0s: Intercept parameter for snow [m-4] [HDC 6] -!--------------------------------------------------------------- - n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) - if(qrs(i,k,1).le.qcrmin .or. ncr(i,k,3).le.nrmin)then - rslope(i,k,1) = rslopermax - rslopeb(i,k,1) = rsloperbmax - rslope2(i,k,1) = rsloper2max - rslope3(i,k,1) = rsloper3max - else - rslope(i,k,1) = 1./lamdar(qrs(i,k,1),den(i,k),ncr(i,k,3)) - rslopeb(i,k,1) = exp(log(rslope(i,k,1))*(bvtr)) - rslope2(i,k,1) = rslope(i,k,1)*rslope(i,k,1) - rslope3(i,k,1) = rslope2(i,k,1)*rslope(i,k,1) - endif - if(qci(i,k,1).le.qmin .or. ncr(i,k,2).le.ncmin)then - rslopec(i,k) = rslopecmax - rslopec2(i,k) = rslopec2max - rslopec3(i,k) = rslopec3max - else - rslopec(i,k) = 1./lamdac(qci(i,k,1),den(i,k),ncr(i,k,2)) - rslopec2(i,k) = rslopec(i,k)*rslopec(i,k) - rslopec3(i,k) = rslopec2(i,k)*rslopec(i,k) - endif - if(qrs(i,k,2).le.qcrmin)then - rslope(i,k,2) = rslopesmax - rslopeb(i,k,2) = rslopesbmax - rslope2(i,k,2) = rslopes2max - rslope3(i,k,2) = rslopes3max - else - rslope(i,k,2) = 1./lamdas(qrs(i,k,2),den(i,k),n0sfac(i,k)) - rslopeb(i,k,2) = exp(log(rslope(i,k,2))*(bvts)) - rslope2(i,k,2) = rslope(i,k,2)*rslope(i,k,2) - rslope3(i,k,2) = rslope2(i,k,2)*rslope(i,k,2) - endif -!------------------------------------------------------------- -! Ni: ice crystal number concentraiton [HDC 5c] -!------------------------------------------------------------- -! xni(i,k) = min(max(5.38e7*(den(i,k) & -! *max(qci(i,k,2),qmin))**0.75,1.e3),1.e6) - temp = (den(i,k)*max(qci(i,k,2),qmin)) - temp = sqrt(sqrt(temp*temp*temp)) - xni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) - enddo - enddo -! - mstepmax = 1 - numndt = 1 - do k = kte, kts, -1 - do i = its, ite - workn(i,k) = pvtrn*rslopeb(i,k,1)*denfac(i,k)/delz(i,k) - numndt(i) = max(nint(workn(i,k)*dtcld+.5),1) - if(numndt(i).ge.mnstep(i)) mnstep(i) = numndt(i) - enddo - enddo - do i = its, ite - if(mstepmax.le.mnstep(i)) mstepmax = mnstep(i) - enddo -! - do n = 1, mstepmax - k = kte - do i = its, ite - if(n.le.mnstep(i)) then - falkn(i,k) = den(i,k)*ncr(i,k,3)*workn(i,k)/mnstep(i) - falln(i,k) = falln(i,k)+falkn(i,k) - ncr(i,k,3) = max(ncr(i,k,3)-falkn(i,k) & - *dtcld/den(i,k),0.) - endif - enddo - do k = kte-1, kts, -1 - do i = its, ite - if(n.le.mnstep(i)) then - falkn(i,k) = den(i,k)*ncr(i,k,3)*workn(i,k)/mnstep(i) - falln(i,k) = falln(i,k)+falkn(i,k) - ncr(i,k,3) = max(ncr(i,k,3)-(falkn(i,k)-falkn(i,k+1) & - *delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) - endif - enddo - enddo - enddo -! - mstepmax = 1 - numdt = 1 - do k = kte, kts, -1 - do i = its, ite - work1(i,k,1) = pvtr*rslopeb(i,k,1)*denfac(i,k)/delz(i,k) - work1(i,k,2) = pvts*rslopeb(i,k,2)*denfac(i,k)/delz(i,k) - numdt(i) = max(nint(max(work1(i,k,1),work1(i,k,2))*dtcld+.5),1) - if(numdt(i).ge.mstep(i)) mstep(i) = numdt(i) - enddo - enddo - do i = its, ite - if(mstepmax.le.mstep(i)) mstepmax = mstep(i) - rmstep(i) = 1./mstep(i) - enddo -! - do n = 1, mstepmax - k = kte - do i = its, ite - if(n.le.mstep(i)) then -! falk(i,k,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)/mstep(i) -! falk(i,k,2) = den(i,k)*qrs(i,k,2)*work1(i,k,2)/mstep(i) - falk(i,k,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)*rmstep(i) - falk(i,k,2) = den(i,k)*qrs(i,k,2)*work1(i,k,2)*rmstep(i) - fall(i,k,1) = fall(i,k,1)+falk(i,k,1) - fall(i,k,2) = fall(i,k,2)+falk(i,k,2) -! qrs(i,k,1) = max(qrs(i,k,1)-falk(i,k,1)*dtcld/den(i,k),0.) -! qrs(i,k,2) = max(qrs(i,k,2)-falk(i,k,2)*dtcld/den(i,k),0.) - dtcldden = dtcld/den(i,k) - qrs(i,k,1) = max(qrs(i,k,1)-falk(i,k,1)*dtcldden,0.) - qrs(i,k,2) = max(qrs(i,k,2)-falk(i,k,2)*dtcldden,0.) - endif - enddo - do k = kte-1, kts, -1 - do i = its, ite - if(n.le.mstep(i)) then -! falk(i,k,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)/mstep(i) -! falk(i,k,2) = den(i,k)*qrs(i,k,2)*work1(i,k,2)/mstep(i) - falk(i,k,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)*rmstep(i) - falk(i,k,2) = den(i,k)*qrs(i,k,2)*work1(i,k,2)*rmstep(i) - fall(i,k,1) = fall(i,k,1)+falk(i,k,1) - fall(i,k,2) = fall(i,k,2)+falk(i,k,2) -! qrs(i,k,1) = max(qrs(i,k,1)-(falk(i,k,1)-falk(i,k+1,1) & -! *delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) -! qrs(i,k,2) = max(qrs(i,k,2)-(falk(i,k,2)-falk(i,k+1,2) & -! *delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) - dtcldden = dtcld/den(i,k) - rdelz = 1./delz(i,k) - qrs(i,k,1) = max(qrs(i,k,1)-(falk(i,k,1)-falk(i,k+1,1) & - *delz(i,k+1)*rdelz)*dtcldden,0.) - qrs(i,k,2) = max(qrs(i,k,2)-(falk(i,k,2)-falk(i,k+1,2) & - *delz(i,k+1)*rdelz)*dtcldden,0.) - endif - enddo - enddo - do k = kte, kts, -1 - do i = its, ite - if(n.le.mstep(i)) then - if(t(i,k).gt.t0c .and. qrs(i,k,2).gt.0.) then -!---------------------------------------------------------------- -! psmlt: melting of snow [HL A33] [RH83 A25] -! (T>T0: S->R) -!---------------------------------------------------------------- - xlf = xlf0 -! work2(i,k)= venfac(p(i,k),t(i,k),den(i,k)) - work2(i,k)= (exp(log(((1.496e-6*((t(i,k))*sqrt(t(i,k))) & - /((t(i,k))+120.)/(den(i,k)))/(8.794e-5 & - *exp(log(t(i,k))*(1.81))/p(i,k)))) & - *((.3333333)))/sqrt((1.496e-6*((t(i,k)) & - *sqrt(t(i,k)))/((t(i,k))+120.)/(den(i,k)))) & - *sqrt(sqrt(den0/(den(i,k))))) - coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) -! psmlt(i,k) = xka(t(i,k),den(i,k))/xlf*(t0c-t(i,k))*pi/2. & -! *n0sfac(i,k)*(precs1*rslope2(i,k,2)+precs2 & -! *work2(i,k)*coeres) - psmlt(i,k) = (1.414e3*(1.496e-6 * ((t(i,k))*sqrt(t(i,k))) & - /((t(i,k))+120.)/(den(i,k)))*(den(i,k)))/xlf & - *(t0c-t(i,k))*pi/2.*n0sfac(i,k) & - *(precs1*rslope2(i,k,2)+precs2*work2(i,k)*coeres) - psmlt(i,k) = min(max(psmlt(i,k)*dtcld/mstep(i),-qrs(i,k,2) & - /mstep(i)),0.) - qrs(i,k,2) = qrs(i,k,2) + psmlt(i,k) - qrs(i,k,1) = qrs(i,k,1) - psmlt(i,k) -!------------------------------------------------------------------- -! nsmlt: melgin of snow -! (T>T0: ->NR) -!------------------------------------------------------------------- - if(qrs(i,k,2).gt.qcrmin) then - sfac = rslope(i,k,2)*n0s*n0sfac(i,k)/qrs(i,k,2) - ncr(i,k,3) = ncr(i,k,3) - sfac*psmlt(i,k) - endif - t(i,k) = t(i,k) + xlf/cpm(i,k)*psmlt(i,k) - endif - endif - enddo - enddo - enddo -!--------------------------------------------------------------- -! Vice [ms-1] : fallout of ice crystal [HDC 5a] -!--------------------------------------------------------------- - mstepmax = 1 - mstep = 1 - numdt = 1 - do k = kte, kts, -1 - do i = its, ite - if(qci(i,k,2).le.0.) then - work2c(i,k) = 0. - else - xmi = den(i,k)*qci(i,k,2)/xni(i,k) -! diameter = min(dicon * sqrt(xmi),dimax) - diameter = max(min(dicon * sqrt(xmi),dimax), 1.e-25) - work1c(i,k) = 1.49e4*exp(log(diameter)*(1.31)) - work2c(i,k) = work1c(i,k)/delz(i,k) - endif - numdt(i) = max(nint(work2c(i,k)*dtcld+.5),1) - if(numdt(i).ge.mstep(i)) mstep(i) = numdt(i) - enddo - enddo - do i = its, ite - if(mstepmax.le.mstep(i)) mstepmax = mstep(i) - enddo -! - do n = 1, mstepmax - k = kte - do i = its, ite - if(n.le.mstep(i)) then - falkc(i,k) = den(i,k)*qci(i,k,2)*work2c(i,k)/mstep(i) - holdc = falkc(i,k) - fallc(i,k) = fallc(i,k)+falkc(i,k) - holdci = qci(i,k,2) - qci(i,k,2) = max(qci(i,k,2)-falkc(i,k)*dtcld/den(i,k),0.) - endif - enddo - do k = kte-1, kts, -1 - do i = its, ite - if(n.le.mstep(i)) then - falkc(i,k) = den(i,k)*qci(i,k,2)*work2c(i,k)/mstep(i) - holdc = falkc(i,k) - fallc(i,k) = fallc(i,k)+falkc(i,k) - holdci = qci(i,k,2) - qci(i,k,2) = max(qci(i,k,2)-(falkc(i,k)-falkc(i,k+1)*delz(i,k+1) & - /delz(i,k))*dtcld/den(i,k),0.) - endif - enddo - enddo - enddo -! -! -!---------------------------------------------------------------- -! rain (unit is mm/sec;kgm-2s-1: /1000*delt ===> m)==> mm for wrf -! - do i = its, ite - fallsum = fall(i,1,1)+fall(i,1,2)+fallc(i,1) - fallsum_qsi = fall(i,1,2)+fallc(i,1) - rainncv(i) = 0. - if(fallsum.gt.0.) then - rainncv(i) = fallsum*delz(i,1)/denr*dtcld*1000. - rain(i) = fallsum*delz(i,1)/denr*dtcld*1000.+rain(i) - endif - if (PRESENT (snowncv) .and. PRESENT (snow)) then - snowncv(i) = 0. - if(fallsum_qsi.gt.0.) then - snowncv(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. - snow(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000.+snow(i) - endif - endif - sr(i) = 0. - if(fallsum.gt.0.)sr(i)=fallsum_qsi*delz(i,kts)/denr*dtcld*1000. & - /(rainncv(i)+1.e-12) - enddo -! -!--------------------------------------------------------------- -! pimlt: instantaneous melting of cloud ice [HL A47] [RH83 A28] -! (T>T0: I->C) -!--------------------------------------------------------------- - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) - xlf = xls-xl(i,k) - if(supcol.lt.0.) xlf = xlf0 - if(supcol.lt.0 .and. qci(i,k,2).gt.0.) then - qci(i,k,1) = qci(i,k,1)+qci(i,k,2) -!--------------------------------------------------------------- -! nimlt: instantaneous melting of cloud ice -! (T>T0: ->NC) -!-------------------------------------------------------------- - if(qci(i,k,2).gt.qmin) then - ifac = xni(i,k)/qci(i,k,2) - ncr(i,k,2) = ncr(i,k,2)+ifac*qci(i,k,2) - endif - t(i,k) = t(i,k) - xlf/cpm(i,k)*qci(i,k,2) - qci(i,k,2) = 0. - endif -!--------------------------------------------------------------- -! pihmf: homogeneous freezing of cloud water below -40c [HL A45] -! (T<-40C: C->I) -!--------------------------------------------------------------- - if(supcol.gt.40. .and. qci(i,k,1).gt.0.) then - qci(i,k,2) = qci(i,k,2) + qci(i,k,1) -!--------------------------------------------------------------- -! nihmf: homogeneous of cloud water below -40c [HL A45] -! (T<-40C: NC->) -!--------------------------------------------------------------- - if(ncr(i,k,2).gt.0.) ncr(i,k,2) = 0. - t(i,k) = t(i,k) + xlf/cpm(i,k)*qci(i,k,1) - qci(i,k,1) = 0. - endif -!--------------------------------------------------------------- -! pihtf: heterogeneous freezing of cloud water [HL A44] -! (T0>T>-40C: C->I) -!--------------------------------------------------------------- - if(supcol.gt.0. .and. qci(i,k,1).gt.0.) then - supcolt=min(supcol,70.) - pfrzdtc = min(pi*pi*pfrz1*(exp(pfrz2*supcolt)-1.)*denr/den(i,k) & - *ncr(i,k,2)*rslopec3(i,k)*rslopec3(i,k)/18.*dtcld,qci(i,k,1)) -!--------------------------------------------------------------- -! nihtf: heterogeneous of cloud water -! (T0>T>-40C: NC->) -!--------------------------------------------------------------- - if(ncr(i,k,2).gt.ncmin) then - nfrzdtc = min(pi*pfrz1*(exp(pfrz2*supcolt)-1.)*ncr(i,k,2) & - *rslopec3(i,k)/6.*dtcld,ncr(i,k,2)) - ncr(i,k,2) = ncr(i,k,2) - nfrzdtc - endif - qci(i,k,2) = qci(i,k,2) + pfrzdtc - t(i,k) = t(i,k) + xlf/cpm(i,k)*pfrzdtc - qci(i,k,1) = qci(i,k,1)-pfrzdtc - endif -!--------------------------------------------------------------- -! psfrz: freezing of rain water [HL A20] [LFO 45] -! (TS) -!--------------------------------------------------------------- - if(supcol.gt.0. .and. qrs(i,k,1).gt.0.) then - supcolt=min(supcol,70.) - pfrzdtr = min(140.*(pi*pi)*pfrz1*ncr(i,k,3)*denr/den(i,k) & - *(exp(pfrz2*supcolt)-1.)*rslope3(i,k,1)*rslope3(i,k,1) & - *dtcld,qrs(i,k,1)) -!--------------------------------------------------------------- -! nsfrz: freezing of rain water -! (T ) -!--------------------------------------------------------------- - if(ncr(i,k,3).gt.nrmin) then - nfrzdtr = min(4.*pi*pfrz1*ncr(i,k,3)*(exp(pfrz2*supcolt)-1.) & - *rslope3(i,k,1)*dtcld,ncr(i,k,3)) - ncr(i,k,3) = ncr(i,k,3)-nfrzdtr - endif - qrs(i,k,2) = qrs(i,k,2) + pfrzdtr - t(i,k) = t(i,k) + xlf/cpm(i,k)*pfrzdtr - qrs(i,k,1) = qrs(i,k,1)-pfrzdtr - endif - enddo - enddo -! - do k = kts, kte - do i = its, ite - ncr(i,k,2) = max(ncr(i,k,2),0.0) - ncr(i,k,3) = max(ncr(i,k,3),0.0) - enddo - enddo -! -!---------------------------------------------------------------- -! rsloper: reverse of the slope parameter of the rain(m) -! xka: thermal conductivity of air(jm-1s-1k-1) -! work1: the thermodynamic term in the denominator associated with -! heat conduction and vapor diffusion -! (ry88, y93, h85) -! work2: parameter associated with the ventilation effects(y93) -! - do k = kts, kte - do i = its, ite - if(qrs(i,k,1).le.qcrmin .or. ncr(i,k,3).le.nrmin)then - rslope(i,k,1) = rslopermax - rslopeb(i,k,1) = rsloperbmax - rslope2(i,k,1) = rsloper2max - rslope3(i,k,1) = rsloper3max - else - rslope(i,k,1) = 1./lamdar(qrs(i,k,1),den(i,k),ncr(i,k,3)) - rslopeb(i,k,1) = exp(log(rslope(i,k,1))*(bvtr)) - rslope2(i,k,1) = rslope(i,k,1)*rslope(i,k,1) - rslope3(i,k,1) = rslope2(i,k,1)*rslope(i,k,1) - endif -! -! compute the mean-volume drop diameter for raindrop distribution - avedia(i,k,2) = rslope(i,k,1)*((24.)**(.3333333)) -! - if(qci(i,k,1).le.qmin .or. ncr(i,k,2).le.ncmin)then - rslopec(i,k) = rslopecmax - rslopec2(i,k) = rslopec2max - rslopec3(i,k) = rslopec3max - else - rslopec(i,k) = 1./lamdac(qci(i,k,1),den(i,k),ncr(i,k,2)) - rslopec2(i,k) = rslopec(i,k)*rslopec(i,k) - rslopec3(i,k) = rslopec2(i,k)*rslopec(i,k) - endif -! -! compute the mean-volume drop diameter for cloud-droplet distribution - avedia(i,k,1) = rslopec(i,k) -! - if(qrs(i,k,2).le.qcrmin)then - rslope(i,k,2) = rslopesmax - rslopeb(i,k,2) = rslopesbmax - rslope2(i,k,2) = rslopes2max - rslope3(i,k,2) = rslopes3max - else -! rslope(i,k,2) = 1./lamdas(qrs(i,k,2),den(i,k),n0sfac(i,k)) - rslope(i,k,2) = 1./(sqrt(sqrt(pidn0s*(n0sfac(i,k))/((qrs(i,k,2)) & - *(den(i,k)))))) - rslopeb(i,k,2) = exp(log(rslope(i,k,2))*(bvts)) - rslope2(i,k,2) = rslope(i,k,2)*rslope(i,k,2) - rslope3(i,k,2) = rslope2(i,k,2)*rslope(i,k,2) - endif - enddo - enddo -! - do k = kts, kte - do i = its, ite -! work1(i,k,1) = diffac(xl(i,k),p(i,k),t(i,k),den(i,k),qs(i,k,1)) - work1(i,k,1) = ((((den(i,k))*(xl(i,k))*(xl(i,k)))*((t(i,k))+120.) & - *(den(i,k)))/(1.414e3*(1.496e-6*((t(i,k))*sqrt(t(i,k))))& - *(den(i,k))*(rv*(t(i,k))*(t(i,k))))) & - + p(i,k)/((qs(i,k,1))*(8.794e-5*exp(log(t(i,k))*(1.81)))) -! work1(i,k,2) = diffac(xls,p(i,k),t(i,k),den(i,k),qs(i,k,2)) - work1(i,k,2) = ((((den(i,k))*(xls)*(xls))*((t(i,k))+120.)*(den(i,k)))& - /(1.414e3*(1.496e-6*((t(i,k))*sqrt(t(i,k))))*(den(i,k)) & - *(rv*(t(i,k))*(t(i,k)))) & - + p(i,k)/(qs(i,k,2)*(8.794e-5*exp(log(t(i,k))*(1.81))))) -! work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) - work2(i,k) = (exp(.3333333*log(((1.496e-6 * ((t(i,k))*sqrt(t(i,k)))) & - *p(i,k))/(((t(i,k))+120.)*den(i,k)*(8.794e-5 & - *exp(log(t(i,k))*(1.81))))))*sqrt(sqrt(den0/(den(i,k))))) & - /sqrt((1.496e-6*((t(i,k))*sqrt(t(i,k)))) & - /(((t(i,k))+120.)*den(i,k))) - enddo - enddo -! -!=============================================================== -! -! warm rain processes -! -! - follows the processes in RH83 and LFO except for autoconcersion -! -!=============================================================== -! - do k = kts, kte - do i = its, ite - supsat = max(q(i,k),qmin)-qs(i,k,1) - satdt = supsat/dtcld -!--------------------------------------------------------------- -! praut: auto conversion rate from cloud to rain [CP 17] -! (C->R) -!--------------------------------------------------------------- - lencon = 2.7e-2*den(i,k)*qci(i,k,1)*(1.e20/16.*rslopec2(i,k) & - *rslopec2(i,k)-0.4) - lenconcr = max(1.2*lencon,qcrmin) - if(avedia(i,k,1).gt.di15) then - taucon = 3.7/den(i,k)/qci(i,k,1)/(0.5e6*rslopec(i,k)-7.5) - praut(i,k) = lencon/taucon - praut(i,k) = min(max(praut(i,k),0.),qci(i,k,1)/dtcld) -!--------------------------------------------------------------- -! nraut: auto conversion rate from cloud to rain [CP 18 & 19] -! (NC->NR) -!--------------------------------------------------------------- - nraut(i,k) = 3.5e9*den(i,k)*praut(i,k) - if(qrs(i,k,1).gt.lenconcr) & - nraut(i,k) = ncr(i,k,3)/qrs(i,k,1)*praut(i,k) - nraut(i,k) = min(nraut(i,k),ncr(i,k,2)/dtcld) - endif -!--------------------------------------------------------------- -! pracw: accretion of cloud water by rain [CP 22 & 23] -! (C->R) -! nracw: accretion of cloud water by rain -! (NC->) -!--------------------------------------------------------------- - if(qrs(i,k,1).ge.lenconcr) then - if(avedia(i,k,2).ge.di100) then - nracw(i,k) = min(ncrk1*ncr(i,k,2)*ncr(i,k,3)*(rslopec3(i,k) & - + 24.*rslope3(i,k,1)),ncr(i,k,2)/dtcld) - pracw(i,k) = min(pi/6.*(denr/den(i,k))*ncrk1*ncr(i,k,2) & - *ncr(i,k,3)*rslopec3(i,k)*(2.*rslopec3(i,k) & - + 24.*rslope3(i,k,1)),qci(i,k,1)/dtcld) - else - nracw(i,k) = min(ncrk2*ncr(i,k,2)*ncr(i,k,3)*(2.*rslopec3(i,k) & - *rslopec3(i,k)+5040.*rslope3(i,k,1) & - *rslope3(i,k,1)),ncr(i,k,2)/dtcld) - pracw(i,k) = min(pi/6.*(denr/den(i,k))*ncrk2*ncr(i,k,2) & - *ncr(i,k,3)*rslopec3(i,k)*(6.*rslopec3(i,k) & - *rslopec3(i,k)+5040.*rslope3(i,k,1) & - *rslope3(i,k,1)),qci(i,k,1)/dtcld) - endif - endif -!---------------------------------------------------------------- -! nccol: self collection of cloud water [CP 24 & 25] -! (NC->) -!---------------------------------------------------------------- - if(avedia(i,k,1).ge.di100) then - nccol(i,k) = ncrk1*ncr(i,k,2)*ncr(i,k,2)*rslopec3(i,k) - else - nccol(i,k) = 2.*ncrk2*ncr(i,k,2)*ncr(i,k,2)*rslopec3(i,k) & - *rslopec3(i,k) - endif -!---------------------------------------------------------------- -! nrcol: self collection of rain-drops and break-up [CP 24 & 25] -! (NR->) -!---------------------------------------------------------------- - if(qrs(i,k,1).ge.lenconcr) then - if(avedia(i,k,2).lt.di100) then - nrcol(i,k) = 5040.*ncrk2*ncr(i,k,3)*ncr(i,k,3)*rslope3(i,k,1) & - *rslope3(i,k,1) - elseif(avedia(i,k,2).ge.di100 .and. avedia(i,k,2).lt.di600) then - nrcol(i,k) = 24.*ncrk1*ncr(i,k,3)*ncr(i,k,3)*rslope3(i,k,1) - elseif(avedia(i,k,2).ge.di600 .and. avedia(i,k,2).lt.di2000) then - coecol = -2.5e3*(avedia(i,k,2)-di600) - nrcol(i,k) = 24.*exp(coecol)*ncrk1*ncr(i,k,3)*ncr(i,k,3) & - *rslope3(i,k,1) - else - nrcol(i,k) = 0. - endif - endif -!--------------------------------------------------------------- -! prevp: evaporation/condensation rate of rain -! (V->R or R->V) -!--------------------------------------------------------------- - if(qrs(i,k,1).gt.0.) then - coeres = rslope(i,k,1)*sqrt(rslope(i,k,1)*rslopeb(i,k,1)) - prevp(i,k) = (rh(i,k,1)-1.)*ncr(i,k,3)*(precr1*rslope(i,k,1) & - +precr2*work2(i,k)*coeres)/work1(i,k,1) - if(prevp(i,k).lt.0.) then - prevp(i,k) = max(prevp(i,k),-qrs(i,k,1)/dtcld) - prevp(i,k) = max(prevp(i,k),satdt/2) -!---------------------------------------------------------------- -! Nrevp: evaporation/condensation rate of rain [CP ] -! (NR->NC) -!---------------------------------------------------------------- - if(avedia(i,k,2).le.di82) then - nrevp(i,k) = ncr(i,k,3)/dtcld -!---------------------------------------------------------------- -! Prevp_s: evaporation/condensation rate of rain [KK 23] -! (R->C) -!---------------------------------------------------------------- - prevp_s(i,k) = qrs(i,k,1)/dtcld - endif - else -! - prevp(i,k) = min(prevp(i,k),satdt/2) - endif - endif - enddo - enddo -! -!=============================================================== -! -! cold rain processes -! -! - follows the revised ice microphysics processes in HDC -! - the processes same as in RH83 and RH84 and LFO behave -! following ice crystal hapits defined in HDC, inclduing -! intercept parameter for snow (n0s), ice crystal number -! concentration (ni), ice nuclei number concentration -! (n0i), ice diameter (d) -! -!=============================================================== -! - rdtcld = 1./dtcld - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) - supsat = max(q(i,k),qmin)-qs(i,k,2) - satdt = supsat/dtcld - ifsat = 0 -!------------------------------------------------------------- -! Ni: ice crystal number concentraiton [HDC 5c] -!------------------------------------------------------------- -! xni(i,k) = min(max(5.38e7*(den(i,k) & -! *max(qci(i,k,2),qmin))**0.75,1.e3),1.e6) - temp = (den(i,k)*max(qci(i,k,2),qmin)) - temp = sqrt(sqrt(temp*temp*temp)) - xni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) - eacrs = exp(0.07*(-supcol)) -! - if(supcol.gt.0) then - if(qrs(i,k,2).gt.qcrmin .and. qci(i,k,2).gt.qmin) then - xmi = den(i,k)*qci(i,k,2)/xni(i,k) - diameter = min(dicon * sqrt(xmi),dimax) - vt2i = 1.49e4*diameter**1.31 - vt2s = pvts*rslopeb(i,k,2)*denfac(i,k) -!------------------------------------------------------------- -! psaci: Accretion of cloud ice by rain [HDC 10] -! (TS) -!------------------------------------------------------------- - acrfac = 2.*rslope3(i,k,2)+2.*diameter*rslope2(i,k,2) & - + diameter**2*rslope(i,k,2) - psaci(i,k) = pi*qci(i,k,2)*eacrs*n0s*n0sfac(i,k)*abs(vt2s-vt2i) & - *acrfac/4. - endif - endif -!------------------------------------------------------------- -! psacw: Accretion of cloud water by snow [HL A7] [LFO 24] -! (TS, and T>=T0: C->R) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.qcrmin .and. qci(i,k,1).gt.qmin) then - psacw(i,k) = min(pacrc*n0sfac(i,k)*rslope3(i,k,2)*rslopeb(i,k,2) & - *qci(i,k,1)*denfac(i,k),qci(i,k,1)*rdtcld) - endif -!------------------------------------------------------------- -! nsacw: Accretion of cloud water by snow -! (NC ->) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.qcrmin .and. ncr(i,k,2).gt.ncmin) then - nsacw(i,k) = min(pacrc*n0sfac(i,k)*rslope3(i,k,2)*rslopeb(i,k,2) & - *ncr(i,k,2)*denfac(i,k),ncr(i,k,2)/dtcld) - endif - if(supcol.le.0) then - xlf = xlf0 -!-------------------------------------------------------------- -! nseml: Enhanced melting of snow by accretion of water -! (T>=T0: ->NR) -!-------------------------------------------------------------- - if (qrs(i,k,2).gt.qcrmin) then - sfac = rslope(i,k,2)*n0s*n0sfac(i,k)/qrs(i,k,2) - nseml(i,k) = -sfac*min(max(cliq*supcol*(psacw(i,k))/xlf & - ,-qrs(i,k,2)/dtcld),0.) - endif - endif - if(supcol.gt.0) then -!------------------------------------------------------------- -! pidep: Deposition/Sublimation rate of ice [HDC 9] -! (TI or I->V) -!------------------------------------------------------------- - if(qci(i,k,2).gt.0 .and. ifsat.ne.1) then - xmi = den(i,k)*qci(i,k,2)/xni(i,k) - diameter = dicon * sqrt(xmi) - pidep(i,k) = 4.*diameter*xni(i,k)*(rh(i,k,2)-1.)/work1(i,k,2) - supice = satdt-prevp(i,k) - if(pidep(i,k).lt.0.) then -! pidep(i,k) = max(max(pidep(i,k),satdt/2),supice) -! pidep(i,k) = max(pidep(i,k),-qci(i,k,2)/dtcld) - pidep(i,k) = max(max(pidep(i,k),satdt*.5),supice) - pidep(i,k) = max(pidep(i,k),-qci(i,k,2)*rdtcld) - else -! pidep(i,k) = min(min(pidep(i,k),satdt/2),supice) - pidep(i,k) = min(min(pidep(i,k),satdt*.5),supice) - endif - if(abs(prevp(i,k)+pidep(i,k)).ge.abs(satdt)) ifsat = 1 - endif -!------------------------------------------------------------- -! psdep: deposition/sublimation rate of snow [HDC 14] -! (V->S or S->V) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.0. .and. ifsat.ne.1) then - coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) - psdep(i,k) = (rh(i,k,2)-1.)*n0sfac(i,k)*(precs1*rslope2(i,k,2) & - + precs2*work2(i,k)*coeres)/work1(i,k,2) - supice = satdt-prevp(i,k)-pidep(i,k) - if(psdep(i,k).lt.0.) then -! psdep(i,k) = max(psdep(i,k),-qrs(i,k,2)/dtcld) -! psdep(i,k) = max(max(psdep(i,k),satdt/2),supice) - psdep(i,k) = max(psdep(i,k),-qrs(i,k,2)*rdtcld) - psdep(i,k) = max(max(psdep(i,k),satdt*.5),supice) - else -! psdep(i,k) = min(min(psdep(i,k),satdt/2),supice) - psdep(i,k) = min(min(psdep(i,k),satdt*.5),supice) - endif - if(abs(prevp(i,k)+pidep(i,k)+psdep(i,k)).ge.abs(satdt)) ifsat = 1 - endif -!------------------------------------------------------------- -! pigen: generation(nucleation) of ice from vapor [HL A50] [HDC 7-8] -! (TI) -!------------------------------------------------------------- - if(supsat.gt.0 .and. ifsat.ne.1) then - supice = satdt-prevp(i,k)-pidep(i,k)-psdep(i,k) - xni0 = 1.e3*exp(0.1*supcol) - roqi0 = 4.92e-11*exp(log(xni0)*(1.33)) - pigen(i,k) = max(0.,(roqi0/den(i,k)-max(qci(i,k,2),0.))*rdtcld) - pigen(i,k) = min(min(pigen(i,k),satdt),supice) - endif -! -!------------------------------------------------------------- -! psaut: conversion(aggregation) of ice to snow [HDC 12] -! (TS) -!------------------------------------------------------------- - if(qci(i,k,2).gt.0.) then - qimax = roqimax/den(i,k) -! psaut(i,k) = max(0.,(qci(i,k,2)-qimax)/dtcld) - psaut(i,k) = max(0.,(qci(i,k,2)-qimax)*rdtcld) - endif - endif -!------------------------------------------------------------- -! psevp: Evaporation of melting snow [HL A35] [RH83 A27] -! (T>T0: S->V) -!------------------------------------------------------------- - if(supcol.lt.0.) then - if(qrs(i,k,2).gt.0. .and. rh(i,k,1).lt.1.) & - psevp(i,k) = psdep(i,k)*work1(i,k,2)/work1(i,k,1) -! psevp(i,k) = min(max(psevp(i,k),-qrs(i,k,2)/dtcld),0.) - psevp(i,k) = min(max(psevp(i,k),-qrs(i,k,2)*rdtcld),0.) - endif - enddo - enddo -! -! -!---------------------------------------------------------------- -! check mass conservation of generation terms and feedback to the -! large scale -! - do k = kts, kte - do i = its, ite - if(t(i,k).le.t0c) then -! -! Q_cloud water -! - value = max(qmin,qci(i,k,1)) - source = (praut(i,k)+pracw(i,k)+psacw(i,k)-prevp_s(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - psacw(i,k) = psacw(i,k)*factor - prevp_s(i,k) = prevp_s(i,k)*factor - endif -! -! Q_cloud ice -! - value = max(qmin,qci(i,k,2)) - source = (psaut(i,k)+psaci(i,k)-pigen(i,k)-pidep(i,k))*dtcld - if (source.gt.value) then - factor = value/source - psaut(i,k) = psaut(i,k)*factor - psaci(i,k) = psaci(i,k)*factor - pigen(i,k) = pigen(i,k)*factor - pidep(i,k) = pidep(i,k)*factor - endif -! -! Q_rain -! -! - value = max(qmin,qrs(i,k,1)) - source = (-praut(i,k)-pracw(i,k)-prevp(i,k)+prevp_s(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - prevp(i,k) = prevp(i,k)*factor - prevp_s(i,k) = prevp_s(i,k)*factor - endif -! -! Q_snow -! - value = max(qmin,qrs(i,k,2)) - source = (-psdep(i,k)-psaut(i,k)-psaci(i,k)-psacw(i,k))*dtcld - if (source.gt.value) then - factor = value/source - psdep(i,k) = psdep(i,k)*factor - psaut(i,k) = psaut(i,k)*factor - psaci(i,k) = psaci(i,k)*factor - psacw(i,k) = psacw(i,k)*factor - endif -! -! N_cloud -! - value = max(ncmin,ncr(i,k,2)) - source = (+nraut(i,k)+nccol(i,k)+nracw(i,k)+nsacw(i,k) & - -nrevp(i,k))*dtcld - if (source.gt.value) then - factor = value/source - nraut(i,k) = nraut(i,k)*factor - nccol(i,k) = nccol(i,k)*factor - nracw(i,k) = nracw(i,k)*factor - nsacw(i,k) = nsacw(i,k)*factor - nrevp(i,k) = nrevp(i,k)*factor - endif -! -! N_rain -! - value = max(nrmin,ncr(i,k,3)) - source = (-nraut(i,k)+nrcol(i,k)+nrevp(i,k))*dtcld - if (source.gt.value) then - factor = value/source - nraut(i,k) = nraut(i,k)*factor - nrcol(i,k) = nrcol(i,k)*factor - nrevp(i,k) = nrevp(i,k)*factor - endif -! - work2(i,k)=-(prevp(i,k)+psdep(i,k)+pigen(i,k)+pidep(i,k)) -! update - q(i,k) = q(i,k)+work2(i,k)*dtcld - qci(i,k,1) = max(qci(i,k,1)-(praut(i,k)+pracw(i,k)+psacw(i,k) & - +prevp_s(i,k))*dtcld,0.) - qrs(i,k,1) = max(qrs(i,k,1)+(praut(i,k)+pracw(i,k)+prevp(i,k) & - -prevp_s(i,k))*dtcld,0.) - qci(i,k,2) = max(qci(i,k,2)-(psaut(i,k)+psaci(i,k)-pigen(i,k) & - -pidep(i,k))*dtcld,0.) - qrs(i,k,2) = max(qrs(i,k,2)+(psdep(i,k)+psaut(i,k)+psaci(i,k) & - +psacw(i,k))*dtcld,0.) - ncr(i,k,2) = max(ncr(i,k,2)+(-nraut(i,k)-nccol(i,k)-nracw(i,k) & - -nsacw(i,k)+nrevp(i,k))*dtcld,0.) - ncr(i,k,3) = max(ncr(i,k,3)+(nraut(i,k)-nrcol(i,k)-nrevp(i,k)) & - *dtcld,0.) - xlf = xls-xl(i,k) - xlwork2 = -xls*(psdep(i,k)+pidep(i,k)+pigen(i,k)) & - -xl(i,k)*prevp(i,k)-xlf*psacw(i,k) - t(i,k) = t(i,k)-xlwork2/cpm(i,k)*dtcld - else -! -! Q_cloud water -! - value = max(qmin,qci(i,k,1)) - source=(praut(i,k)+pracw(i,k)+psacw(i,k)-prevp_s(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - psacw(i,k) = psacw(i,k)*factor - prevp_s(i,k) = prevp_s(i,k)*factor - endif -! -! Q_rain -! - value = max(qmin,qrs(i,k,1)) - source = (-praut(i,k)-pracw(i,k)-prevp(i,k)+prevp_s(i,k) & - -psacw(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - prevp(i,k) = prevp(i,k)*factor - psacw(i,k) = psacw(i,k)*factor - prevp_s(i,k) = prevp_s(i,k)*factor - endif -! -! Q_snow -! - value = max(qcrmin,qrs(i,k,2)) - source=(-psevp(i,k))*dtcld - if (source.gt.value) then - factor = value/source - psevp(i,k) = psevp(i,k)*factor - endif -! -! N_cloud -! - value = max(ncmin,ncr(i,k,2)) - source = (+nraut(i,k)+nccol(i,k)+nracw(i,k)+nsacw(i,k) & - -nrevp(i,k))*dtcld - if (source.gt.value) then - factor = value/source - nraut(i,k) = nraut(i,k)*factor - nccol(i,k) = nccol(i,k)*factor - nracw(i,k) = nracw(i,k)*factor - nsacw(i,k) = nsacw(i,k)*factor - nrevp(i,k) = nrevp(i,k)*factor - endif -! -! N_rain -! - value = max(nrmin,ncr(i,k,3)) - source = (-nraut(i,k)-nseml(i,k)+nrcol(i,k)+nrevp(i,k))*dtcld - if (source.gt.value) then - factor = value/source - nraut(i,k) = nraut(i,k)*factor - nseml(i,k) = nseml(i,k)*factor - nrcol(i,k) = nrcol(i,k)*factor - nrevp(i,k) = nrevp(i,k)*factor - endif - work2(i,k)=-(prevp(i,k)+psevp(i,k)) -! update - q(i,k) = q(i,k)+work2(i,k)*dtcld - qci(i,k,1) = max(qci(i,k,1)-(praut(i,k)+pracw(i,k)+psacw(i,k) & - +prevp_s(i,k))*dtcld,0.) - qrs(i,k,1) = max(qrs(i,k,1)+(praut(i,k)+pracw(i,k)+prevp(i,k) & - +psacw(i,k)-prevp_s(i,k))*dtcld,0.) - qrs(i,k,2) = max(qrs(i,k,2)+psevp(i,k)*dtcld,0.) - ncr(i,k,2) = max(ncr(i,k,2)+(-nraut(i,k)-nccol(i,k)-nracw(i,k) & - -nsacw(i,k)+nrevp(i,k))*dtcld,0.) - ncr(i,k,3) = max(ncr(i,k,3)+(nraut(i,k)+nseml(i,k)-nrcol(i,k) & - -nrevp(i,k))*dtcld,0.) - xlf = xls-xl(i,k) - xlwork2 = -xl(i,k)*(prevp(i,k)+psevp(i,k)) - t(i,k) = t(i,k)-xlwork2/cpm(i,k)*dtcld - endif - enddo - enddo -! -! Inline expansion for fpvs -! qs(i,k,1) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) -! qs(i,k,2) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) - hsub = xls - hvap = xlv0 - cvap = cpv - ttp=t0c+0.01 - dldt=cvap-cliq - xa=-dldt/rv - xb=xa+hvap/(rv*ttp) - dldti=cvap-cice - xai=-dldti/rv - xbi=xai+hsub/(rv*ttp) - do k = kts, kte - do i = its, ite - tr=ttp/t(i,k) - logtr = log(tr) - qs(i,k,1)=psat*exp(logtr*(xa)+xb*(1.-tr)) - qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k) - qs(i,k,1)) - qs(i,k,1) = max(qs(i,k,1),qmin) - rh(i,k,1) = max(q(i,k) / qs(i,k,1),qmin) - enddo - enddo -! - do k = kts, kte - do i = its, ite -!--------------------------------------------------------------- -! put the inital CCN number concentration -! - if(ncr(i,k,1).eq.0.) ncr(i,k,1) = ccn0 -!--------------------------------------------------------------- -! rate of change of cloud drop concentration due to CCN activation -! pcact: V -> C [KK 14] -! ncact: NCCN -> NC [KK 12] - if(rh(i,k,1).gt.1.) then - ncact(i,k) = max(0.,((ncr(i,k,1)+ncr(i,k,2)) & - *min(1.,(rh(i,k,1)/satmax)**actk) - ncr(i,k,2)))/dtcld - ncact(i,k) =min(ncact(i,k),max(ncr(i,k,1),0.)/dtcld) - pcact(i,k) = min(4.*pi*denr*(actr*1.E-6)**3*ncact(i,k)/ & - (3.*den(i,k)),max(q(i,k),0.)/dtcld) - q(i,k) = max(q(i,k)-pcact(i,k)*dtcld,0.) - qci(i,k,1) = max(qci(i,k,1)+pcact(i,k)*dtcld,0.) - ncr(i,k,1) = max(ncr(i,k,1)-ncact(i,k)*dtcld,0.) - ncr(i,k,2) = max(ncr(i,k,2)+ncact(i,k)*dtcld,0.) - t(i,k) = t(i,k)+pcact(i,k)*xl(i,k)/cpm(i,k)*dtcld - endif -!---------------------------------------------------------------- -! pcond: condensational/evaporational rate of cloud water [HL A46] [RH83 A6] -! if there exists additional water vapor condensated/if -! evaporation of cloud water is not enough to remove subsaturation - tr=ttp/t(i,k) - qs(i,k,1)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) - qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k) - qs(i,k,1)) - qs(i,k,1) = max(qs(i,k,1),qmin) - work1(i,k,1) = ((max(q(i,k),qmin)-(qs(i,k,1)))/(1.+(xl(i,k)) & - *(xl(i,k))/(rv*(cpm(i,k)))*(qs(i,k,1))/((t(i,k)) & - *(t(i,k))))) - work2(i,k) = qci(i,k,1)+work1(i,k,1) - pcond(i,k) = min(max(work1(i,k,1)/dtcld,0.),max(q(i,k),0.)/dtcld) - if(qci(i,k,1).gt.0. .and. work1(i,k,1).lt.0.) & - pcond(i,k) = max(work1(i,k,1),-qci(i,k,1))/dtcld -!--------------------------------------------------------------- -! ncevp: evpration of Cloud number concentration -! - if(pcond(i,k).eq.-qci(i,k,1)/dtcld) then - ncr(i,k,2) = 0. - ncr(i,k,1) = ncr(i,k,1)+ncr(i,k,2) - endif -! - q(i,k) = q(i,k)-pcond(i,k)*dtcld - qci(i,k,1) = max(qci(i,k,1)+pcond(i,k)*dtcld,0.) - t(i,k) = t(i,k)+pcond(i,k)*xl(i,k)/cpm(i,k)*dtcld - enddo - enddo -! -!---------------------------------------------------------------- -! padding for small values -! - do k = kts, kte - do i = its, ite - if(qci(i,k,1).le.qmin) qci(i,k,1) = 0.0 - if(qci(i,k,2).le.qmin) qci(i,k,2) = 0.0 - enddo - enddo - enddo ! big loops - END SUBROUTINE wdm52d -! ................................................................... - REAL FUNCTION rgmma(x) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -! rgmma function: use infinite product form - REAL :: euler - PARAMETER (euler=0.577215664901532) - REAL :: x, y - INTEGER :: i - if(x.eq.1.)then - rgmma=0. - else - rgmma=x*exp(euler*x) - do i=1,10000 - y=float(i) - rgmma=rgmma*(1.000+x/y)*exp(-x/y) - enddo - rgmma=1./rgmma - endif - END FUNCTION rgmma -! -!-------------------------------------------------------------------------- - REAL FUNCTION fpvs(t,ice,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c) -!-------------------------------------------------------------------------- - IMPLICIT NONE -!-------------------------------------------------------------------------- - REAL t,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c,dldt,xa,xb,dldti, & - xai,xbi,ttp,tr - INTEGER ice -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ttp=t0c+0.01 - dldt=cvap-cliq - xa=-dldt/rv - xb=xa+hvap/(rv*ttp) - dldti=cvap-cice - xai=-dldti/rv - xbi=xai+hsub/(rv*ttp) - tr=ttp/t - if(t.lt.ttp .and. ice.eq.1) then - fpvs=psat*exp(log(tr)*(xai))*exp(xbi*(1.-tr)) - else - fpvs=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END FUNCTION fpvs -!------------------------------------------------------------------- - SUBROUTINE wdm5init(den0,denr,dens,cl,cpv,ccn0,allowed_to_read) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -!.... constants which may not be tunable - REAL, INTENT(IN) :: den0,denr,dens,cl,cpv,ccn0 - LOGICAL, INTENT(IN) :: allowed_to_read - REAL :: pi -! - pi = 4.*atan(1.) - xlv1 = cl-cpv -! - qc0 = 4./3.*pi*denr*r0**3*xncr/den0 ! 0.419e-3 -- .61e-3 - qck1 = .104*9.8*peaut/(xncr*denr)**(1./3.)/xmyu*den0**(4./3.) ! 7.03 - pidnc = pi*denr/6. -! - bvtr1 = 1.+bvtr - bvtr2 = 2.+bvtr - bvtr3 = 3.+bvtr - bvtr4 = 4.+bvtr - bvtr5 = 5.+bvtr - bvtr7 = 7.+bvtr - bvtr2o5 = 2.5+.5*bvtr - bvtr3o5 = 3.5+.5*bvtr - g1pbr = rgmma(bvtr1) - g2pbr = rgmma(bvtr2) - g3pbr = rgmma(bvtr3) - g4pbr = rgmma(bvtr4) ! 17.837825 - g5pbr = rgmma(bvtr5) - g7pbr = rgmma(bvtr7) - g5pbro2 = rgmma(bvtr2o5) - g7pbro2 = rgmma(bvtr3o5) - pvtr = avtr*g5pbr/24. - pvtrn = avtr*g2pbr - eacrr = 1.0 - pacrr = pi*n0r*avtr*g3pbr*.25*eacrr - precr1 = 2.*pi*1.56 - precr2 = 2.*pi*.31*avtr**.5*g7pbro2 - pidn0r = pi*denr*n0r - pidnr = 4.*pi*denr - xmmax = (dimax/dicon)**2 - roqimax = 2.08e22*dimax**8 -! - bvts1 = 1.+bvts - bvts2 = 2.5+.5*bvts - bvts3 = 3.+bvts - bvts4 = 4.+bvts - g1pbs = rgmma(bvts1) !.8875 - g3pbs = rgmma(bvts3) - g4pbs = rgmma(bvts4) ! 12.0786 - g5pbso2 = rgmma(bvts2) - pvts = avts*g4pbs/6. - pacrs = pi*n0s*avts*g3pbs*.25 - precs1 = 4.*n0s*.65 - precs2 = 4.*n0s*.44*avts**.5*g5pbso2 - pidn0s = pi*dens*n0s - pacrc = pi*n0s*avts*g3pbs*.25*eacrc -! - rslopecmax = 1./lamdacmax - rslopermax = 1./lamdarmax - rslopesmax = 1./lamdasmax - rsloperbmax = rslopermax ** bvtr - rslopesbmax = rslopesmax ** bvts - rslopec2max = rslopecmax * rslopecmax - rsloper2max = rslopermax * rslopermax - rslopes2max = rslopesmax * rslopesmax - rslopec3max = rslopec2max * rslopecmax - rsloper3max = rsloper2max * rslopermax - rslopes3max = rslopes2max * rslopesmax -! - END SUBROUTINE wdm5init -END MODULE module_mp_wdm5 diff --git a/src/fim/FIMsrc/fim/wrfphys/module_mp_wdm6.F b/src/fim/FIMsrc/fim/wrfphys/module_mp_wdm6.F deleted file mode 100644 index 48ea69e..0000000 --- a/src/fim/FIMsrc/fim/wrfphys/module_mp_wdm6.F +++ /dev/null @@ -1,1932 +0,0 @@ -#if ( RWORDSIZE == 4 ) -# define VREC vsrec -# define VSQRT vssqrt -#else -# define VREC vrec -# define VSQRT vsqrt -#endif -! -MODULE module_mp_wdm6 -! -! -! - REAL, PARAMETER, PRIVATE :: dtcldcr = 120. ! maximum time step for minor loops - REAL, PARAMETER, PRIVATE :: n0r = 8.e6 ! intercept parameter rain - REAL, PARAMETER, PRIVATE :: n0g = 4.e6 ! intercept parameter graupel - REAL, PARAMETER, PRIVATE :: avtr = 841.9 ! a constant for terminal velocity of rain - REAL, PARAMETER, PRIVATE :: bvtr = 0.8 ! a constant for terminal velocity of rain - REAL, PARAMETER, PRIVATE :: r0 = .8e-5 ! 8 microm in contrast to 10 micro m - REAL, PARAMETER, PRIVATE :: peaut = .55 ! collection efficiency - REAL, PARAMETER, PRIVATE :: xncr = 3.e8 ! maritime cloud in contrast to 3.e8 in tc80 - REAL, PARAMETER, PRIVATE :: xmyu = 1.718e-5 ! the dynamic viscosity kgm-1s-1 - REAL, PARAMETER, PRIVATE :: avts = 11.72 ! a constant for terminal velocity of snow - REAL, PARAMETER, PRIVATE :: bvts = .41 ! a constant for terminal velocity of snow - REAL, PARAMETER, PRIVATE :: avtg = 330. ! a constant for terminal velocity of graupel - REAL, PARAMETER, PRIVATE :: bvtg = 0.8 ! a constant for terminal velocity of graupel - REAL, PARAMETER, PRIVATE :: deng = 500. ! density of graupel - REAL, PARAMETER, PRIVATE :: n0smax = 1.e11 ! maximum n0s (t=-90C unlimited) - REAL, PARAMETER, PRIVATE :: lamdacmax = 1.e10 ! limited maximum value for slope parameter of cloud water - REAL, PARAMETER, PRIVATE :: lamdarmax = 1.e8 ! limited maximum value for slope parameter of rain - REAL, PARAMETER, PRIVATE :: lamdasmax = 1.e5 ! limited maximum value for slope parameter of snow - REAL, PARAMETER, PRIVATE :: lamdagmax = 6.e4 ! limited maximum value for slope parameter of graupel - REAL, PARAMETER, PRIVATE :: dicon = 11.9 ! constant for the cloud-ice diamter - REAL, PARAMETER, PRIVATE :: dimax = 500.e-6 ! limited maximum value for the cloud-ice diamter - REAL, PARAMETER, PRIVATE :: n0s = 2.e6 ! temperature dependent intercept parameter snow - REAL, PARAMETER, PRIVATE :: alpha = .12 ! .122 exponen factor for n0s - REAL, PARAMETER, PRIVATE :: pfrz1 = 100. ! constant in Biggs freezing - REAL, PARAMETER, PRIVATE :: pfrz2 = 0.66 ! constant in Biggs freezing - REAL, PARAMETER, PRIVATE :: qcrmin = 1.e-9 ! minimun values for qr, qs, and qg - REAL, PARAMETER, PRIVATE :: ncmin = 1.e1 ! minimum value for Nc - REAL, PARAMETER, PRIVATE :: nrmin = 1.e-2 ! minimum value for Nr - REAL, PARAMETER, PRIVATE :: eacrc = 1.0 ! Snow/cloud-water collection efficiency - REAL, PARAMETER, PRIVATE :: dens = 100.0 ! Density of snow - REAL, PARAMETER, PRIVATE :: qs0 = 6.e-4 ! threshold amount for aggretion to occur -! - REAL, PARAMETER, PRIVATE :: satmax = 1.0048 ! maximum saturation value for CCN activation - ! 1.008 for maritime /1.0048 for conti - REAL, PARAMETER, PRIVATE :: actk = 0.6 ! parameter for the CCN activation - REAL, PARAMETER, PRIVATE :: actr = 1.5 ! radius of activated CCN drops - REAL, PARAMETER, PRIVATE :: ncrk1 = 3.03e3 ! Long's collection kernel coefficient - REAL, PARAMETER, PRIVATE :: ncrk2 = 2.59e15 ! Long's collection kernel coefficient - REAL, PARAMETER, PRIVATE :: di100 = 1.e-4 ! parameter related with accretion and collection of cloud drops - REAL, PARAMETER, PRIVATE :: di600 = 6.e-4 ! parameter related with accretion and collection of cloud drops - REAL, PARAMETER, PRIVATE :: di2000 = 2000.e-6 ! parameter related with accretion and collection of cloud drops - REAL, PARAMETER, PRIVATE :: di82 = 82.e-6 ! dimater related with raindrops evaporation - REAL, PARAMETER, PRIVATE :: di15 = 15.e-6 ! auto conversion takes place beyond this diameter -! - REAL, SAVE :: & - qc0,qck1,pidnc,bvtr1,bvtr2,bvtr3,bvtr4,bvtr5, & - bvtr6,bvtr7, bvtr2o5,bvtr3o5, & - g1pbr,g2pbr,g3pbr,g4pbr,g5pbr,g6pbr,g7pbr, & - g5pbro2,g7pbro2, & - pvtr,pvtrn,eacrr,pacrr,pidn0r,pidnr, & - precr1,precr2,xmmax,roqimax,bvts1,bvts2, & - bvts3,bvts4,g1pbs,g3pbs,g4pbs,g5pbso2, & - pvts,pacrs,precs1,precs2,pidn0s,xlv1,pacrc, & - bvtg1,bvtg2,bvtg3,bvtg4,g1pbg,g3pbg,g4pbg, & - g5pbgo2,pvtg,pacrg,precg1,precg2,pidn0g, & - rslopecmax,rslopec2max,rslopec3max, & - rslopermax,rslopesmax,rslopegmax, & - rsloperbmax,rslopesbmax,rslopegbmax, & - rsloper2max,rslopes2max,rslopeg2max, & - rsloper3max,rslopes3max,rslopeg3max -CONTAINS -!=================================================================== -! - SUBROUTINE wdm6(th, q, qc, qr, qi, qs, qg, & - nn, nc, nr, & - den, pii, p, delz, & - delt,g, cpd, cpv, ccn0, rd, rv, t0c, & - ep1, ep2, qmin, & - XLS, XLV0, XLF0, den0, denr, & - cliq,cice,psat, & - rain, rainncv, & - snow, snowncv, & - sr, & - graupel, graupelncv, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte & - ) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -! -! This code is a WRF double-moment 6-class GRAUPEL phase -! microphyiscs scheme (WDM6). The WDM microphysics scheme predicts -! number concentrations for warm rain species including clouds and -! rain. cloud condensation nuclei (CCN) is also predicted. -! The cold rain species including ice, snow, graupel follow the -! WRF single-moment 6-class microphysics (WSM6, Hong and Lim 2006) -! in which theoretical background for WSM ice phase microphysics is -! based on Hong et al. (2004). A new mixed-phase terminal velocity -! for precipitating ice is introduced in WSM6 (Dudhia et al. 2008). -! The WDM scheme is described in Lim and Hong (2009). -! All units are in m.k.s. and source/sink terms in kgkg-1s-1. -! -! WDM6 cloud scheme -! -! Coded by Kyo-Sun Lim and Song-You Hong (Yonsei Univ.) Fall 2008 -! -! Implemented by Kyo-Sun Lim and Jimy Dudhia (NCAR) Winter 2008 -! -! Reference) Lim and Hong (LH, 2009) Manuscript in preperation -! Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev. -! Hong and Lim (HL, 2006) J. Korean Meteor. Soc. -! Cohard and Pinty (CP, 2000) Quart. J. Roy. Meteor. Soc. -! Khairoutdinov and Kogan (KK, 2000) Mon. Wea. Rev. -! Dudhia, Hong and Lim (DHL, 2008) J. Meteor. Soc. Japan -! -! Lin, Farley, Orville (LFO, 1983) J. Appl. Meteor. -! Rutledge, Hobbs (RH83, 1983) J. Atmos. Sci. -! Rutledge, Hobbs (RH84, 1984) J. Atmos. Sci. -! - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & - ims,ime, jms,jme, kms,kme , & - its,ite, jts,jte, kts,kte - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(INOUT) :: & - th, & - q, & - qc, & - qi, & - qr, & - qs, & - qg, & - nn, & - nc, & - nr - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: & - den, & - pii, & - p, & - delz - REAL, INTENT(IN ) :: delt, & - g, & - rd, & - rv, & - t0c, & - den0, & - cpd, & - cpv, & - ccn0, & - ep1, & - ep2, & - qmin, & - XLS, & - XLV0, & - XLF0, & - cliq, & - cice, & - psat, & - denr - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(INOUT) :: rain, & - rainncv, & - sr - REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, & - INTENT(INOUT) :: snow, & - snowncv - REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, & - INTENT(INOUT) :: graupel, & - graupelncv -! LOCAL VAR - REAL, DIMENSION( its:ite , kts:kte ) :: t - REAL, DIMENSION( its:ite , kts:kte, 2 ) :: qci - REAL, DIMENSION( its:ite , kts:kte, 3 ) :: qrs, ncr - INTEGER :: i,j,k -!------------------------------------------------------------------- - DO j=jts,jte - DO k=kts,kte - DO i=its,ite - t(i,k)=th(i,k,j)*pii(i,k,j) - qci(i,k,1) = qc(i,k,j) - qci(i,k,2) = qi(i,k,j) - qrs(i,k,1) = qr(i,k,j) - qrs(i,k,2) = qs(i,k,j) - qrs(i,k,3) = qg(i,k,j) - ncr(i,k,1) = nn(i,k,j) - ncr(i,k,2) = nc(i,k,j) - ncr(i,k,3) = nr(i,k,j) - ENDDO - ENDDO - ! Sending array starting locations of optional variables may cause - ! troubles, so we explicitly change the call. - - CALL wdm62D(t, q(ims,kms,j), qci, qrs, ncr & - ,den(ims,kms,j) & - ,p(ims,kms,j), delz(ims,kms,j) & - ,delt,g, cpd, cpv, ccn0, rd, rv, t0c & - ,ep1, ep2, qmin & - ,XLS, XLV0, XLF0, den0, denr & - ,cliq,cice,psat & - ,j & - ,rain(ims,j),rainncv(ims,j) & - ,sr(ims,j) & - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte & - ,snow(ims,j),snowncv(ims,j) & - ,graupel(ims,j),graupelncv(ims,j) & - ) - DO K=kts,kte - DO I=its,ite - th(i,k,j)=t(i,k)/pii(i,k,j) - qc(i,k,j) = qci(i,k,1) - qi(i,k,j) = qci(i,k,2) - qr(i,k,j) = qrs(i,k,1) - qs(i,k,j) = qrs(i,k,2) - qg(i,k,j) = qrs(i,k,3) - nn(i,k,j) = ncr(i,k,1) - nc(i,k,j) = ncr(i,k,2) - nr(i,k,j) = ncr(i,k,3) - ENDDO - ENDDO - ENDDO - END SUBROUTINE wdm6 -!=================================================================== -! - SUBROUTINE wdm62D(t, q, qci, qrs, ncr, den, p, delz & - ,delt,g, cpd, cpv, ccn0, rd, rv, t0c & - ,ep1, ep2, qmin & - ,XLS, XLV0, XLF0, den0, denr & - ,cliq,cice,psat & - ,lat & - ,rain,rainncv & - ,sr & - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte & - ,snow,snowncv & - ,graupel,graupelncv & - ) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & - ims,ime, jms,jme, kms,kme , & - its,ite, jts,jte, kts,kte , & - lat - REAL, DIMENSION( its:ite , kts:kte ), & - INTENT(INOUT) :: & - t - REAL, DIMENSION( its:ite , kts:kte, 2 ), & - INTENT(INOUT) :: & - qci - REAL, DIMENSION( its:ite , kts:kte, 3 ), & - INTENT(INOUT) :: & - qrs, & - ncr - REAL, DIMENSION( ims:ime , kms:kme ), & - INTENT(INOUT) :: & - q - REAL, DIMENSION( ims:ime , kms:kme ), & - INTENT(IN ) :: & - den, & - p, & - delz - REAL, INTENT(IN ) :: delt, & - g, & - cpd, & - cpv, & - ccn0, & - t0c, & - den0, & - rd, & - rv, & - ep1, & - ep2, & - qmin, & - XLS, & - XLV0, & - XLF0, & - cliq, & - cice, & - psat, & - denr - REAL, DIMENSION( ims:ime ), & - INTENT(INOUT) :: rain, & - rainncv, & - sr - REAL, DIMENSION( ims:ime ), OPTIONAL, & - INTENT(INOUT) :: snow, & - snowncv - REAL, DIMENSION( ims:ime ), OPTIONAL, & - INTENT(INOUT) :: graupel, & - graupelncv -! LOCAL VAR - REAL, DIMENSION( its:ite , kts:kte , 3) :: & - rh, qs, rslope, rslope2, rslope3, rslopeb, & - falk, fall, work1 - REAL, DIMENSION( its:ite , kts:kte ) :: & - rslopec, rslopec2,rslopec3 - REAL, DIMENSION( its:ite , kts:kte, 2) :: & - avedia - REAL, DIMENSION( its:ite , kts:kte ) :: & - workn,falln,falkn - REAL, DIMENSION( its:ite , kts:kte ) :: & - worka - REAL, DIMENSION( its:ite , kts:kte ) :: & - falkc, work1c, work2c, fallc - REAL, DIMENSION( its:ite , kts:kte ) :: & - pcact, prevp, psdep, pgdep, praut, psaut, pgaut, & - pracw, psacw, pgacw, pgacr, pgacs, psaci, pgmlt, praci, & - piacr, pracs, psacr, pgaci, pseml, pgeml, prevp_s - REAL, DIMENSION( its:ite , kts:kte ) :: paacw - REAL, DIMENSION( its:ite , kts:kte ) :: & - nraut, nracw, nrevp, ncevp, nccol, nrcol, & - nsacw, ngacw, niacr, nsacr, ngacr, naacw, & - nseml, ngeml, ncact - REAL, DIMENSION( its:ite , kts:kte ) :: & - pigen, pidep, pcond, xl, cpm, work2, psmlt, psevp, & - denfac, xni, pgevp,n0sfac, qsum - REAL :: ifac, gfac, sfac -! variables for optimization - REAL, DIMENSION( its:ite ) :: tvec1 - REAL :: temp - INTEGER, DIMENSION( its:ite ) :: mnstep, numndt - INTEGER, DIMENSION( its:ite ) :: mstep, numdt - LOGICAL, DIMENSION( its:ite ) :: flgcld - REAL :: pi, & - cpmcal, xlcal, lamdac, lamdar, lamdas, lamdag, & - diffus, & - viscos, xka, venfac, conden, diffac, & - x, y, z, a, b, c, d, e, & - ndt, qdt, holdrr, holdrs, holdrg, supcol, supcolt, & - pvt, coeres, supsat, dtcld, xmi, eacrs, satdt, & - qimax, diameter, xni0, roqi0, & - fallsum, fallsum_qsi, fallsum_qg, & - vt2i,vt2r,vt2s,vt2g,acrfac,egs,egi, & - xlwork2, factor, source, value, coecol, & - nfrzdtr, nfrzdtc, & - taucon, lencon, lenconcr, & - xlf, pfrzdtc, pfrzdtr, supice, alpha2, delta2, delta3 - REAL :: vt2ave - REAL :: holdc, holdci -! - INTEGER :: i, j, k, mstepmax, & - iprt, latd, lond, loop, loops, ifsat, n -! Temporaries used for inlining fpvs function - REAL :: dldti, xb, xai, tr, xbi, xa, hvap, cvap, hsub, dldt, ttp -! -!================================================================= -! compute internal functions -! - cpmcal(x) = cpd*(1.-max(x,qmin))+max(x,qmin)*cpv - xlcal(x) = xlv0-xlv1*(x-t0c) -!---------------------------------------------------------------- -! size distributions: (x=mixing ratio, y=air density): -! valid for mixing ratio > 1.e-9 kg/kg. -! -! Optimizatin : A**B => exp(log(A)*(B)) - lamdac(x,y,z)= exp(log(((pidnc*z)/(x*y)))*((.33333333))) - lamdar(x,y,z)= exp(log(((pidnr*z)/(x*y)))*((.33333333))) - lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 - lamdag(x,y)= sqrt(sqrt(pidn0g/(x*y))) ! (pidn0g/(x*y))**.25 -! -!---------------------------------------------------------------- -! diffus: diffusion coefficient of the water vapor -! viscos: kinematic viscosity(m2s-1) -! - diffus(x,y) = 8.794e-5 * exp(log(x)*(1.81)) / y ! 8.794e-5*x**1.81/y - viscos(x,y) = 1.496e-6 * (x*sqrt(x)) /(x+120.)/y ! 1.496e-6*x**1.5/(x+120.)/y - xka(x,y) = 1.414e3*viscos(x,y)*y - diffac(a,b,c,d,e) = d*a*a/(xka(c,d)*rv*c*c)+1./(e*diffus(c,b)) - venfac(a,b,c) = exp(log((viscos(b,c)/diffus(b,a)))*((.3333333))) & - /sqrt(viscos(b,c))*sqrt(sqrt(den0/c)) - conden(a,b,c,d,e) = (max(b,qmin)-c)/(1.+d*d/(rv*e)*c/(a*a)) -! - pi = 4. * atan(1.) -! -! -!---------------------------------------------------------------- -! paddint 0 for negative values generated by dynamics -! - do k = kts, kte - do i = its, ite - qci(i,k,1) = max(qci(i,k,1),0.0) - qrs(i,k,1) = max(qrs(i,k,1),0.0) - qci(i,k,2) = max(qci(i,k,2),0.0) - qrs(i,k,2) = max(qrs(i,k,2),0.0) - qrs(i,k,3) = max(qrs(i,k,3),0.0) - ncr(i,k,1) = max(ncr(i,k,1),0.0) - ncr(i,k,2) = max(ncr(i,k,2),0.0) - ncr(i,k,3) = max(ncr(i,k,3),0.0) - enddo - enddo -! -!---------------------------------------------------------------- -! latent heat for phase changes and heat capacity. neglect the -! changes during microphysical process calculation -! emanuel(1994) -! - do k = kts, kte - do i = its, ite - cpm(i,k) = cpmcal(q(i,k)) - xl(i,k) = xlcal(t(i,k)) - enddo - enddo -! -!---------------------------------------------------------------- -! compute the minor time steps. -! - loops = max(nint(delt/dtcldcr),1) - dtcld = delt/loops - if(delt.le.dtcldcr) dtcld = delt -! - do loop = 1,loops -! -!---------------------------------------------------------------- -! initialize the large scale variables -! - do i = its, ite - mstep(i) = 1 - mnstep(i) = 1 - flgcld(i) = .true. - enddo -! - do k = kts, kte - CALL VREC( tvec1(its), den(its,k), ite-its+1) - do i = its, ite - tvec1(i) = tvec1(i)*den0 - enddo - CALL VSQRT( denfac(its,k), tvec1(its), ite-its+1) - enddo -! -! Inline expansion for fpvs -! qs(i,k,1) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) -! qs(i,k,2) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) - hsub = xls - hvap = xlv0 - cvap = cpv - ttp=t0c+0.01 - dldt=cvap-cliq - xa=-dldt/rv - xb=xa+hvap/(rv*ttp) - dldti=cvap-cice - xai=-dldti/rv - xbi=xai+hsub/(rv*ttp) - do k = kts, kte - do i = its, ite - tr=ttp/t(i,k) - qs(i,k,1)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) - qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k) - qs(i,k,1)) - qs(i,k,1) = max(qs(i,k,1),qmin) - rh(i,k,1) = max(q(i,k) / qs(i,k,1),qmin) - tr=ttp/t(i,k) - if(t(i,k).lt.ttp) then - qs(i,k,2)=psat*exp(log(tr)*(xai))*exp(xbi*(1.-tr)) - else - qs(i,k,2)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) - endif - qs(i,k,2) = ep2 * qs(i,k,2) / (p(i,k) - qs(i,k,2)) - qs(i,k,2) = max(qs(i,k,2),qmin) - rh(i,k,2) = max(q(i,k) / qs(i,k,2),qmin) - enddo - enddo -! -!---------------------------------------------------------------- -! initialize the variables for microphysical physics -! -! - do k = kts, kte - do i = its, ite - prevp(i,k) = 0. - psdep(i,k) = 0. - pgdep(i,k) = 0. - praut(i,k) = 0. - psaut(i,k) = 0. - pgaut(i,k) = 0. - pracw(i,k) = 0. - praci(i,k) = 0. - piacr(i,k) = 0. - psaci(i,k) = 0. - psacw(i,k) = 0. - pracs(i,k) = 0. - psacr(i,k) = 0. - pgacw(i,k) = 0. - paacw(i,k) = 0. - pgaci(i,k) = 0. - pgacr(i,k) = 0. - pgacs(i,k) = 0. - pigen(i,k) = 0. - pidep(i,k) = 0. - pcond(i,k) = 0. - psmlt(i,k) = 0. - pgmlt(i,k) = 0. - pseml(i,k) = 0. - pgeml(i,k) = 0. - psevp(i,k) = 0. - pgevp(i,k) = 0. - pcact(i,k) = 0. - prevp_s(i,k) = 0. - falk(i,k,1) = 0. - falk(i,k,2) = 0. - falk(i,k,3) = 0. - fall(i,k,1) = 0. - fall(i,k,2) = 0. - fall(i,k,3) = 0. - fallc(i,k) = 0. - falkc(i,k) = 0. - falln(i,k) =0. - falkn(i,k) =0. - xni(i,k) = 1.e3 - nsacw(i,k) = 0. - ngacw(i,k) = 0. - naacw(i,k) = 0. - niacr(i,k) = 0. - nsacr(i,k) = 0. - ngacr(i,k) = 0. - nseml(i,k) = 0. - ngeml(i,k) = 0. - nracw(i,k) = 0. - nccol(i,k) = 0. - nrcol(i,k) = 0. - ncact(i,k) = 0. - nraut(i,k) = 0. - nrevp(i,k) = 0. - ncevp(i,k) = 0. - enddo - enddo -! -!---------------------------------------------------------------- -! compute the fallout term: -! first, vertical terminal velosity for minor loops -! - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) -!--------------------------------------------------------------- -! n0s: Intercept parameter for snow [m-4] [HDC 6] -!--------------------------------------------------------------- - n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) - if(qrs(i,k,1).le.qcrmin .or. ncr(i,k,3).le.nrmin ) then - rslope(i,k,1) = rslopermax - rslopeb(i,k,1) = rsloperbmax - rslope2(i,k,1) = rsloper2max - rslope3(i,k,1) = rsloper3max - else - rslope(i,k,1) = 1./lamdar(qrs(i,k,1),den(i,k),ncr(i,k,3)) - rslopeb(i,k,1) = rslope(i,k,1)**bvtr - rslope2(i,k,1) = rslope(i,k,1)*rslope(i,k,1) - rslope3(i,k,1) = rslope2(i,k,1)*rslope(i,k,1) - endif - if(qci(i,k,1).le.qmin .or. ncr(i,k,2).le.ncmin ) then - rslopec(i,k) = rslopecmax - rslopec2(i,k) = rslopec2max - rslopec3(i,k) = rslopec3max - else - rslopec(i,k) = 1./lamdac(qci(i,k,1),den(i,k),ncr(i,k,2)) - rslopec2(i,k) = rslopec(i,k)*rslopec(i,k) - rslopec3(i,k) = rslopec2(i,k)*rslopec(i,k) - endif - if(qrs(i,k,2).le.qcrmin) then - rslope(i,k,2) = rslopesmax - rslopeb(i,k,2) = rslopesbmax - rslope2(i,k,2) = rslopes2max - rslope3(i,k,2) = rslopes3max - else - rslope(i,k,2) = 1./lamdas(qrs(i,k,2),den(i,k),n0sfac(i,k)) - rslopeb(i,k,2) = rslope(i,k,2)**bvts - rslope2(i,k,2) = rslope(i,k,2)*rslope(i,k,2) - rslope3(i,k,2) = rslope2(i,k,2)*rslope(i,k,2) - endif - if(qrs(i,k,3).le.qcrmin) then - rslope(i,k,3) = rslopegmax - rslopeb(i,k,3) = rslopegbmax - rslope2(i,k,3) = rslopeg2max - rslope3(i,k,3) = rslopeg3max - else - rslope(i,k,3) = 1./lamdag(qrs(i,k,3),den(i,k)) - rslopeb(i,k,3) = rslope(i,k,3)**bvtg - rslope2(i,k,3) = rslope(i,k,3)*rslope(i,k,3) - rslope3(i,k,3) = rslope2(i,k,3)*rslope(i,k,3) - endif -!------------------------------------------------------------- -! Ni: ice crystal number concentraiton [HDC 5c] -!------------------------------------------------------------- - temp = (den(i,k)*max(qci(i,k,2),qmin)) - temp = sqrt(sqrt(temp*temp*temp)) - xni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) - enddo - enddo -! - mstepmax = 1 - numndt = 1 - do k = kte, kts, -1 - do i = its, ite - workn(i,k) = pvtrn*rslopeb(i,k,1)*denfac(i,k)/delz(i,k) - numndt(i) = max(nint(workn(i,k)*dtcld+.5),1) - if(numndt(i).ge.mnstep(i)) mnstep(i) = numndt(i) - enddo - enddo - do i = its, ite - if(mstepmax.le.mnstep(i)) mstepmax = mnstep(i) - enddo -! - do n = 1, mstepmax - k = kte - do i = its, ite - if(n.le.mnstep(i)) then - falkn(i,k) = den(i,k)*ncr(i,k,3)*workn(i,k)/mnstep(i) - falln(i,k) = falln(i,k)+falkn(i,k) - ncr(i,k,3) = max(ncr(i,k,3)-falkn(i,k)*dtcld/den(i,k),0.) - endif - enddo - do k = kte-1, kts, -1 - do i = its, ite - if(n.le.mnstep(i)) then - falkn(i,k) = den(i,k)*ncr(i,k,3)*workn(i,k)/mnstep(i) - falln(i,k) = falln(i,k)+falkn(i,k) - ncr(i,k,3) = max(ncr(i,k,3)-(falkn(i,k)-falkn(i,k+1)*delz(i,k+1) & - /delz(i,k))*dtcld/den(i,k),0.) - endif - enddo - enddo - enddo -! - mstepmax = 1 - numdt = 1 - do k = kte, kts, -1 - do i = its, ite - work1(i,k,1) = pvtr*rslopeb(i,k,1)*denfac(i,k)/delz(i,k) - work1(i,k,2) = pvts*rslopeb(i,k,2)*denfac(i,k)/delz(i,k) - work1(i,k,3) = pvtg*rslopeb(i,k,3)*denfac(i,k)/delz(i,k) - qsum(i,k) = max( (qrs(i,k,2)+qrs(i,k,3)), 1.e-15) - if (qsum(i,k) .gt. 1.e-15) then - worka(i,k) = (work1(i,k,2)*qrs(i,k,2) + work1(i,k,3)*qrs(i,k,3)) & - /qsum(i,k) - else - worka(i,k) = 0. - endif - numdt(i) = max(nint(max(work1(i,k,1),worka(i,k))*dtcld+.5),1) - if(numdt(i).ge.mstep(i)) mstep(i) = numdt(i) - enddo - enddo - do i = its, ite - if(mstepmax.le.mstep(i)) mstepmax = mstep(i) - enddo -! - do n = 1, mstepmax - k = kte - do i = its, ite - if(n.le.mstep(i)) then - falk(i,k,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)/mstep(i) - falk(i,k,2) = den(i,k)*qrs(i,k,2)*worka(i,k)/mstep(i) - falk(i,k,3) = den(i,k)*qrs(i,k,3)*worka(i,k)/mstep(i) - fall(i,k,1) = fall(i,k,1)+falk(i,k,1) - fall(i,k,2) = fall(i,k,2)+falk(i,k,2) - fall(i,k,3) = fall(i,k,3)+falk(i,k,3) - qrs(i,k,1) = max(qrs(i,k,1)-falk(i,k,1)*dtcld/den(i,k),0.) - qrs(i,k,2) = max(qrs(i,k,2)-falk(i,k,2)*dtcld/den(i,k),0.) - qrs(i,k,3) = max(qrs(i,k,3)-falk(i,k,3)*dtcld/den(i,k),0.) - endif - enddo - do k = kte-1, kts, -1 - do i = its, ite - if(n.le.mstep(i)) then - falk(i,k,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)/mstep(i) - falk(i,k,2) = den(i,k)*qrs(i,k,2)*worka(i,k)/mstep(i) - falk(i,k,3) = den(i,k)*qrs(i,k,3)*worka(i,k)/mstep(i) - fall(i,k,1) = fall(i,k,1)+falk(i,k,1) - fall(i,k,2) = fall(i,k,2)+falk(i,k,2) - fall(i,k,3) = fall(i,k,3)+falk(i,k,3) - qrs(i,k,1) = max(qrs(i,k,1)-(falk(i,k,1)-falk(i,k+1,1) & - *delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) - qrs(i,k,2) = max(qrs(i,k,2)-(falk(i,k,2)-falk(i,k+1,2) & - *delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) - qrs(i,k,3) = max(qrs(i,k,3)-(falk(i,k,3)-falk(i,k+1,3) & - *delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) - endif - enddo - enddo - do k = kte, kts, -1 - do i = its, ite - if(n.le.mstep(i) .and. t(i,k).gt.t0c) then -!--------------------------------------------------------------- -! psmlt: melting of snow [HL A33] [RH83 A25] -! (T>T0: S->R) -!--------------------------------------------------------------- - xlf = xlf0 - work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) - if(qrs(i,k,2).gt.0.) then - coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) - psmlt(i,k) = xka(t(i,k),den(i,k))/xlf*(t0c-t(i,k))*pi/2. & - *n0sfac(i,k)*(precs1*rslope2(i,k,2) & - +precs2*work2(i,k)*coeres) - psmlt(i,k) = min(max(psmlt(i,k)*dtcld/mstep(i),-qrs(i,k,2) & - /mstep(i)),0.) - qrs(i,k,2) = qrs(i,k,2) + psmlt(i,k) - qrs(i,k,1) = qrs(i,k,1) - psmlt(i,k) -!------------------------------------------------------------------- -! nsmlt: melting of snow -! (T>T0: ->NR) -!------------------------------------------------------------------- - if(qrs(i,k,2).gt.qcrmin) then - sfac = rslope(i,k,2)*n0s*n0sfac(i,k)/qrs(i,k,2) - ncr(i,k,3) = ncr(i,k,3) - sfac*psmlt(i,k) - endif - t(i,k) = t(i,k) + xlf/cpm(i,k)*psmlt(i,k) - endif -!--------------------------------------------------------------- -! pgmlt: melting of graupel [HL A23] [LFO 47] -! (T>T0: G->R) -!--------------------------------------------------------------- - if(qrs(i,k,3).gt.0.) then - coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) - pgmlt(i,k) = xka(t(i,k),den(i,k))/xlf*(t0c-t(i,k))*(precg1 & - *rslope2(i,k,3) + precg2*work2(i,k)*coeres) - pgmlt(i,k) = min(max(pgmlt(i,k)*dtcld/mstep(i), & - -qrs(i,k,3)/mstep(i)),0.) - qrs(i,k,3) = qrs(i,k,3) + pgmlt(i,k) - qrs(i,k,1) = qrs(i,k,1) - pgmlt(i,k) -!------------------------------------------------------------------- -! ngmlt: melting of graupel -! (T>T0: ->R) -!------------------------------------------------------------------- - if(qrs(i,k,3).gt.qcrmin) then - gfac = rslope(i,k,3)*n0g/qrs(i,k,3) - ncr(i,k,3) = ncr(i,k,3) - gfac*pgmlt(i,k) - endif - t(i,k) = t(i,k) + xlf/cpm(i,k)*pgmlt(i,k) - endif - endif - enddo - enddo - enddo -!--------------------------------------------------------------- -! Vice [ms-1] : fallout of ice crystal [HDC 5a] -!--------------------------------------------------------------- - mstepmax = 1 - mstep = 1 - numdt = 1 - do k = kte, kts, -1 - do i = its, ite - if(qci(i,k,2).le.0.) then - work2c(i,k) = 0. - else - xmi = den(i,k)*qci(i,k,2)/xni(i,k) -! diameter = min(dicon * sqrt(xmi),dimax) - diameter = max(min(dicon * sqrt(xmi),dimax), 1.e-25) - work1c(i,k) = 1.49e4*diameter**1.31 - work2c(i,k) = work1c(i,k)/delz(i,k) - endif - numdt(i) = max(nint(work2c(i,k)*dtcld+.5),1) - if(numdt(i).ge.mstep(i)) mstep(i) = numdt(i) - enddo - enddo - do i = its, ite - if(mstepmax.le.mstep(i)) mstepmax = mstep(i) - enddo -! - do n = 1, mstepmax - k = kte - do i = its, ite - if(n.le.mstep(i)) then - falkc(i,k) = den(i,k)*qci(i,k,2)*work2c(i,k)/mstep(i) - holdc = falkc(i,k) - fallc(i,k) = fallc(i,k)+falkc(i,k) - holdci = qci(i,k,2) - qci(i,k,2) = max(qci(i,k,2)-falkc(i,k)*dtcld/den(i,k),0.) - endif - enddo - do k = kte-1, kts, -1 - do i = its, ite - if(n.le.mstep(i)) then - falkc(i,k) = den(i,k)*qci(i,k,2)*work2c(i,k)/mstep(i) - holdc = falkc(i,k) - fallc(i,k) = fallc(i,k)+falkc(i,k) - holdci = qci(i,k,2) - qci(i,k,2) = max(qci(i,k,2)-(falkc(i,k)-falkc(i,k+1)*delz(i,k+1) & - /delz(i,k))*dtcld/den(i,k),0.) - endif - enddo - enddo - enddo -! -!---------------------------------------------------------------- -! rain (unit is mm/sec;kgm-2s-1: /1000*delt ===> m)==> mm for wrf -! - do i = its, ite - fallsum = fall(i,kts,1)+fall(i,kts,2)+fall(i,kts,3)+fallc(i,kts) - fallsum_qsi = fall(i,kts,2)+fallc(i,kts) - fallsum_qg = fall(i,kts,3) - rainncv(i) = 0. - if(fallsum.gt.0.) then - rainncv(i) = fallsum*delz(i,kts)/denr*dtcld*1000. - rain(i) = fallsum*delz(i,kts)/denr*dtcld*1000. + rain(i) - endif - IF ( PRESENT (snowncv) .AND. PRESENT (snow)) THEN - snowncv(i) = 0. - if(fallsum_qsi.gt.0.) then - snowncv(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. - snow(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + snow(i) - endif - ENDIF - IF ( PRESENT (graupelncv) .AND. PRESENT (graupel)) THEN - graupelncv(i) = 0. - if(fallsum_qg.gt.0.) then - graupelncv(i) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. - graupel(i) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. + graupel(i) - endif - ENDIF - sr(i) = 0. - if(fallsum.gt.0.)sr(i)=(fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + & - fallsum_qg*delz(i,kts)/denr*dtcld*1000.) & - /(rainncv(i)+1.e-12) - enddo -! -!--------------------------------------------------------------- -! pimlt: instantaneous melting of cloud ice [HL A47] [RH83 A28] -! (T>T0: I->C) -!--------------------------------------------------------------- - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) - xlf = xls-xl(i,k) - if(supcol.lt.0.) xlf = xlf0 - if(supcol.lt.0 .and. qci(i,k,2).gt.0.) then - qci(i,k,1) = qci(i,k,1) + qci(i,k,2) -!--------------------------------------------------------------- -! nimlt: instantaneous melting of cloud ice -! (T>T0: ->NC) -!-------------------------------------------------------------- - if(qci(i,k,2).gt.qmin) then - ifac = xni(i,k)/qci(i,k,2) - ncr(i,k,2) = ncr(i,k,2) + ifac*qci(i,k,2) - endif - t(i,k) = t(i,k) - xlf/cpm(i,k)*qci(i,k,2) - qci(i,k,2) = 0. - endif -!--------------------------------------------------------------- -! pihmf: homogeneous of cloud water below -40c [HL A45] -! (T<-40C: C->I) -!--------------------------------------------------------------- - if(supcol.gt.40. .and. qci(i,k,1).gt.0.) then - qci(i,k,2) = qci(i,k,2) + qci(i,k,1) -!--------------------------------------------------------------- -! nihmf: homogeneous of cloud water below -40c [HL A45] -! (T<-40C: NC->) -!--------------------------------------------------------------- - if(ncr(i,k,2).gt.0.) ncr(i,k,2) = 0. - t(i,k) = t(i,k) + xlf/cpm(i,k)*qci(i,k,1) - qci(i,k,1) = 0. - endif -!--------------------------------------------------------------- -! pihtf: heterogeneous of cloud water [HL A44] -! (T0>T>-40C: C->I) -!--------------------------------------------------------------- - if(supcol.gt.0. .and. qci(i,k,1).gt.qmin) then - supcolt=min(supcol,70.) - pfrzdtc = min(pi*pi*pfrz1*(exp(pfrz2*supcolt)-1.)*denr/den(i,k) & - *ncr(i,k,2)*rslopec3(i,k)*rslopec3(i,k)/18.*dtcld & - ,qci(i,k,1)) -!--------------------------------------------------------------- -! nihtf: heterogeneous of cloud water -! (T0>T>-40C: NC->) -!--------------------------------------------------------------- - if(ncr(i,k,2).gt.ncmin) then - nfrzdtc = min(pi*pfrz1*(exp(pfrz2*supcolt)-1.)*ncr(i,k,2) & - *rslopec3(i,k)/6.*dtcld,ncr(i,k,2)) - ncr(i,k,2) = ncr(i,k,2) - nfrzdtc - endif - qci(i,k,2) = qci(i,k,2) + pfrzdtc - t(i,k) = t(i,k) + xlf/cpm(i,k)*pfrzdtc - qci(i,k,1) = qci(i,k,1)-pfrzdtc - endif -!--------------------------------------------------------------- -! pgfrz: freezing of rain water [HL A20] [LFO 45] -! (TG) -!--------------------------------------------------------------- - if(supcol.gt.0. .and. qrs(i,k,1).gt.0.) then - supcolt=min(supcol,70.) - pfrzdtr = min(140.*(pi*pi)*pfrz1*ncr(i,k,3)*denr/den(i,k) & - *(exp(pfrz2*supcolt)-1.)*rslope3(i,k,1)*rslope3(i,k,1) & - *dtcld,qrs(i,k,1)) -!--------------------------------------------------------------- -! ngfrz: freezing of rain water -! (T ) -!--------------------------------------------------------------- - if(ncr(i,k,3).gt.nrmin) then - nfrzdtr = min(4.*pi*pfrz1*ncr(i,k,3)*(exp(pfrz2*supcolt)-1.) & - *rslope3(i,k,1)*dtcld, ncr(i,k,3)) - ncr(i,k,3) = ncr(i,k,3) - nfrzdtr - endif - qrs(i,k,3) = qrs(i,k,3) + pfrzdtr - t(i,k) = t(i,k) + xlf/cpm(i,k)*pfrzdtr - qrs(i,k,1) = qrs(i,k,1) - pfrzdtr - endif - enddo - enddo -! - do k = kts, kte - do i = its, ite - ncr(i,k,2) = max(ncr(i,k,2),0.0) - ncr(i,k,3) = max(ncr(i,k,3),0.0) - enddo - enddo -! -! -!---------------------------------------------------------------- -! rsloper: reverse of the slope parameter of the rain(m) -! xka: thermal conductivity of air(jm-1s-1k-1) -! work1: the thermodynamic term in the denominator associated with -! heat conduction and vapor diffusion -! (ry88, y93, h85) -! work2: parameter associated with the ventilation effects(y93) -! - do k = kts, kte - do i = its, ite - if(qrs(i,k,1).le.qcrmin .or. ncr(i,k,3).le.nrmin ) then - rslope(i,k,1) = rslopermax - rslopeb(i,k,1) = rsloperbmax - rslope2(i,k,1) = rsloper2max - rslope3(i,k,1) = rsloper3max - else - rslope(i,k,1) = 1./lamdar(qrs(i,k,1),den(i,k),ncr(i,k,3)) - rslopeb(i,k,1) = rslope(i,k,1)**bvtr - rslope2(i,k,1) = rslope(i,k,1)*rslope(i,k,1) - rslope3(i,k,1) = rslope2(i,k,1)*rslope(i,k,1) - endif -! -! compute the mean-volume drop diameter for raindrop distribution - avedia(i,k,2) = rslope(i,k,1)*((24.)**(.3333333)) -! - if(qci(i,k,1).le.qmin .or. ncr(i,k,2).le.ncmin) then - rslopec(i,k) = rslopecmax - rslopec2(i,k) = rslopec2max - rslopec3(i,k) = rslopec3max - else - rslopec(i,k) = 1./lamdac(qci(i,k,1),den(i,k),ncr(i,k,2)) - rslopec2(i,k) = rslopec(i,k)*rslopec(i,k) - rslopec3(i,k) = rslopec2(i,k)*rslopec(i,k) - endif -! -! compute the mean-volume drop diameter for cloud-droplet distribution - avedia(i,k,1) = rslopec(i,k) -! - if(qrs(i,k,2).le.qcrmin) then - rslope(i,k,2) = rslopesmax - rslopeb(i,k,2) = rslopesbmax - rslope2(i,k,2) = rslopes2max - rslope3(i,k,2) = rslopes3max - else - rslope(i,k,2) = 1./lamdas(qrs(i,k,2),den(i,k),n0sfac(i,k)) - rslopeb(i,k,2) = rslope(i,k,2)**bvts - rslope2(i,k,2) = rslope(i,k,2)*rslope(i,k,2) - rslope3(i,k,2) = rslope2(i,k,2)*rslope(i,k,2) - endif - if(qrs(i,k,3).le.qcrmin) then - rslope(i,k,3) = rslopegmax - rslopeb(i,k,3) = rslopegbmax - rslope2(i,k,3) = rslopeg2max - rslope3(i,k,3) = rslopeg3max - else - rslope(i,k,3) = 1./lamdag(qrs(i,k,3),den(i,k)) - rslopeb(i,k,3) = rslope(i,k,3)**bvtg - rslope2(i,k,3) = rslope(i,k,3)*rslope(i,k,3) - rslope3(i,k,3) = rslope2(i,k,3)*rslope(i,k,3) - endif - enddo - enddo -! - do k = kts, kte - do i = its, ite - work1(i,k,1) = diffac(xl(i,k),p(i,k),t(i,k),den(i,k),qs(i,k,1)) - work1(i,k,2) = diffac(xls,p(i,k),t(i,k),den(i,k),qs(i,k,2)) - work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) - enddo - enddo -! -!=============================================================== -! -! warm rain processes -! -! - follows the double-moment processes in Lim and Hong -! -!=============================================================== -! - do k = kts, kte - do i = its, ite - supsat = max(q(i,k),qmin)-qs(i,k,1) - satdt = supsat/dtcld -!--------------------------------------------------------------- -! praut: auto conversion rate from cloud to rain [CP 17] -! (C->R) -!-------------------------------------------------------------- - lencon = 2.7e-2*den(i,k)*qci(i,k,1)*(1.e20/16.*rslopec2(i,k) & - *rslopec2(i,k)-0.4) - lenconcr = max(1.2*lencon, qcrmin) - if(avedia(i,k,1).gt.di15) then - taucon = 3.7/den(i,k)/qci(i,k,1)/(0.5e6*rslopec(i,k)-7.5) - praut(i,k) = lencon/taucon - praut(i,k) = min(max(praut(i,k),0.),qci(i,k,1)/dtcld) -!--------------------------------------------------------------- -! nraut: auto conversion rate from cloud to rain [CP 18 & 19] -! (NC->NR) -!--------------------------------------------------------------- - nraut(i,k) = 3.5e9*den(i,k)*praut(i,k) - if(qrs(i,k,1).gt.lenconcr) & - nraut(i,k) = ncr(i,k,3)/qrs(i,k,1)*praut(i,k) - nraut(i,k) = min(nraut(i,k),ncr(i,k,2)/dtcld) - endif -!--------------------------------------------------------------- -! pracw: accretion of cloud water by rain [CP 22 & 23] -! (C->R) -! nracw: accretion of cloud water by rain -! (NC->) -!--------------------------------------------------------------- - if(qrs(i,k,1).ge.lenconcr) then - if(avedia(i,k,2).ge.di100) then - nracw(i,k) = min(ncrk1*ncr(i,k,2)*ncr(i,k,3)*(rslopec3(i,k) & - + 24.*rslope3(i,k,1)),ncr(i,k,2)/dtcld) - pracw(i,k) = min(pi/6.*(denr/den(i,k))*ncrk1*ncr(i,k,2) & - *ncr(i,k,3)*rslopec3(i,k)*(2.*rslopec3(i,k) & - + 24.*rslope3(i,k,1)),qci(i,k,1)/dtcld) - else - nracw(i,k) = min(ncrk2*ncr(i,k,2)*ncr(i,k,3)*(2.*rslopec3(i,k) & - *rslopec3(i,k)+5040.*rslope3(i,k,1) & - *rslope3(i,k,1)),ncr(i,k,2)/dtcld) - pracw(i,k) = min(pi/6.*(denr/den(i,k))*ncrk2*ncr(i,k,2) & - *ncr(i,k,3)*rslopec3(i,k)*(6.*rslopec3(i,k) & - *rslopec3(i,k)+5040.*rslope3(i,k,1)*rslope3(i,k,1)) & - ,qci(i,k,1)/dtcld) - endif - endif -!---------------------------------------------------------------- -! nccol: self collection of cloud water [CP 24 & 25] -! (NC->) -!---------------------------------------------------------------- - if(avedia(i,k,1).ge.di100) then - nccol(i,k) = ncrk1*ncr(i,k,2)*ncr(i,k,2)*rslopec3(i,k) - else - nccol(i,k) = 2.*ncrk2*ncr(i,k,2)*ncr(i,k,2)*rslopec3(i,k) & - *rslopec3(i,k) - endif -!---------------------------------------------------------------- -! nrcol: self collection of rain-drops and break-up [CP 24 & 25] -! (NR->) -!---------------------------------------------------------------- - if(qrs(i,k,1).ge.lenconcr) then - if(avedia(i,k,2).lt.di100) then - nrcol(i,k) = 5040.*ncrk2*ncr(i,k,3)*ncr(i,k,3)*rslope3(i,k,1) & - *rslope3(i,k,1) - elseif(avedia(i,k,2).ge.di100 .and. avedia(i,k,2).lt.di600) then - nrcol(i,k) = 24.*ncrk1*ncr(i,k,3)*ncr(i,k,3)*rslope3(i,k,1) - elseif(avedia(i,k,2).ge.di600 .and. avedia(i,k,2).lt.di2000) then - coecol = -2.5e3*(avedia(i,k,2)-di600) - nrcol(i,k) = 24.*exp(coecol)*ncrk1*ncr(i,k,3)*ncr(i,k,3) & - *rslope3(i,k,1) - else - nrcol(i,k) = 0. - endif - endif -!--------------------------------------------------------------- -! prevp: evaporation/condensation rate of rain -! (V->R or R->V) -!--------------------------------------------------------------- - if(qrs(i,k,1).gt.0.) then - coeres = rslope(i,k,1)*sqrt(rslope(i,k,1)*rslopeb(i,k,1)) - prevp(i,k) = (rh(i,k,1)-1.)*ncr(i,k,3)*(precr1*rslope(i,k,1) & - + precr2*work2(i,k)*coeres)/work1(i,k,1) - if(prevp(i,k).lt.0.) then - prevp(i,k) = max(prevp(i,k),-qrs(i,k,1)/dtcld) - prevp(i,k) = max(prevp(i,k),satdt/2) -!---------------------------------------------------------------- -! Nrevp: evaporation/condensation rate of rain [CP ] -! (NR->NC) -!---------------------------------------------------------------- - if(avedia(i,k,2).le.di82) then - nrevp(i,k) = ncr(i,k,3)/dtcld -!---------------------------------------------------------------- -! Prevp_s: evaporation/condensation rate of rain [KK 23] -! (R->C) -!---------------------------------------------------------------- - prevp_s(i,k) = qrs(i,k,1)/dtcld - endif - else -! - prevp(i,k) = min(prevp(i,k),satdt/2) - endif - endif - enddo - enddo -! -!=============================================================== -! -! cold rain processes -! -! - follows the revised ice microphysics processes in HDC -! - the processes same as in RH83 and RH84 and LFO behave -! following ice crystal hapits defined in HDC, inclduing -! intercept parameter for snow (n0s), ice crystal number -! concentration (ni), ice nuclei number concentration -! (n0i), ice diameter (d) -! -!=============================================================== -! - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) - supsat = max(q(i,k),qmin)-qs(i,k,2) - satdt = supsat/dtcld - ifsat = 0 -!------------------------------------------------------------- -! Ni: ice crystal number concentraiton [HDC 5c] -!------------------------------------------------------------- -! xni(i,k) = min(max(5.38e7*(den(i,k) & -! *max(qci(i,k,2),qmin))**0.75,1.e3),1.e6) - temp = (den(i,k)*max(qci(i,k,2),qmin)) - temp = sqrt(sqrt(temp*temp*temp)) - xni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) - eacrs = exp(0.07*(-supcol)) -! - xmi = den(i,k)*qci(i,k,2)/xni(i,k) - diameter = min(dicon * sqrt(xmi),dimax) - vt2i = 1.49e4*diameter**1.31 - vt2r=pvtr*rslopeb(i,k,1)*denfac(i,k) - vt2s=pvts*rslopeb(i,k,2)*denfac(i,k) - vt2g=pvtg*rslopeb(i,k,3)*denfac(i,k) - qsum(i,k) = max((qrs(i,k,2)+qrs(i,k,3)),1.e-15) - if(qsum(i,k) .gt. 1.e-15) then - vt2ave=(vt2s*qrs(i,k,2)+vt2g*qrs(i,k,3))/(qsum(i,k)) - else - vt2ave=0. - endif - if(supcol.gt.0. .and. qci(i,k,2).gt.qmin) then - if(qrs(i,k,1).gt.qcrmin) then -!------------------------------------------------------------- -! praci: Accretion of cloud ice by rain [HL A15] [LFO 25] -! (TR) -!------------------------------------------------------------- - acrfac = 6.*rslope2(i,k,1)+4.*diameter*rslope(i,k,1) + diameter**2 - praci(i,k) = pi*qci(i,k,2)*ncr(i,k,3)*abs(vt2r-vt2i)*acrfac/4. - praci(i,k) = min(praci(i,k),qci(i,k,2)/dtcld) -!------------------------------------------------------------- -! piacr: Accretion of rain by cloud ice [HL A19] [LFO 26] -! (TS or R->G) -!------------------------------------------------------------- - piacr(i,k) = pi*pi*avtr*ncr(i,k,3)*denr*xni(i,k)*denfac(i,k) & - *g7pbr*rslope3(i,k,1)*rslope2(i,k,1)*rslopeb(i,k,1) & - /24./den(i,k) - piacr(i,k) = min(piacr(i,k),qrs(i,k,1)/dtcld) - endif -!------------------------------------------------------------- -! niacr: Accretion of rain by cloud ice -! (T) -!------------------------------------------------------------- - if(ncr(i,k,3).gt.nrmin) then - niacr(i,k) = pi*avtr*ncr(i,k,3)*xni(i,k)*denfac(i,k)*g4pbr & - *rslope2(i,k,1)*rslopeb(i,k,1)/4. - niacr(i,k) = min(niacr(i,k),ncr(i,k,3)/dtcld) - endif -!------------------------------------------------------------- -! psaci: Accretion of cloud ice by snow [HDC 10] -! (TS) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.qcrmin) then - acrfac = 2.*rslope3(i,k,2)+2.*diameter*rslope2(i,k,2) & - + diameter**2*rslope(i,k,2) - psaci(i,k) = pi*qci(i,k,2)*eacrs*n0s*n0sfac(i,k) & - *abs(vt2ave-vt2i)*acrfac/4. - psaci(i,k) = min(psaci(i,k),qci(i,k,2)/dtcld) - endif -!------------------------------------------------------------- -! pgaci: Accretion of cloud ice by graupel [HL A17] [LFO 41] -! (TG) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.qcrmin) then - egi = exp(0.07*(-supcol)) - acrfac = 2.*rslope3(i,k,3)+2.*diameter*rslope2(i,k,3) & - + diameter**2*rslope(i,k,3) - pgaci(i,k) = pi*egi*qci(i,k,2)*n0g*abs(vt2ave-vt2i)*acrfac/4. - pgaci(i,k) = min(pgaci(i,k),qci(i,k,2)/dtcld) - endif - endif -!------------------------------------------------------------- -! psacw: Accretion of cloud water by snow [HL A7] [LFO 24] -! (TS, and T>=T0: C->R) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.qcrmin .and. qci(i,k,1).gt.qmin) then - psacw(i,k) = min(pacrc*n0sfac(i,k)*rslope3(i,k,2)*rslopeb(i,k,2) & - *qci(i,k,1)*denfac(i,k),qci(i,k,1)/dtcld) - endif -!------------------------------------------------------------- -! nsacw: Accretion of cloud water by snow -! (NC ->) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.qcrmin .and. ncr(i,k,2).gt.ncmin) then - nsacw(i,k) = min(pacrc*n0sfac(i,k)*rslope3(i,k,2)*rslopeb(i,k,2) & - *ncr(i,k,2)*denfac(i,k),ncr(i,k,2)/dtcld) - endif -!------------------------------------------------------------- -! pgacw: Accretion of cloud water by graupel [HL A6] [LFO 40] -! (TG, and T>=T0: C->R) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.qcrmin .and. qci(i,k,1).gt.qmin) then - pgacw(i,k) = min(pacrg*rslope3(i,k,3)*rslopeb(i,k,3)*qci(i,k,1) & - *denfac(i,k),qci(i,k,1)/dtcld) - endif -!------------------------------------------------------------- -! ngacw: Accretion of cloud water by graupel -! (NC-> -!------------------------------------------------------------- - if(qrs(i,k,3).gt.qcrmin .and. ncr(i,k,2).gt.ncmin) then - ngacw(i,k) = min(pacrg*rslope3(i,k,3)*rslopeb(i,k,3)*ncr(i,k,2) & - *denfac(i,k),ncr(i,k,2)/dtcld) - endif -!------------------------------------------------------------- -! paacw: Accretion of cloud water by averaged snow/graupel -! (TG or S, and T>=T0: C->R) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.qcrmin .and. qrs(i,k,3).gt.qcrmin) then - paacw(i,k) = (qrs(i,k,2)*psacw(i,k)+qrs(i,k,3)*pgacw(i,k))/(qsum(i,k)) -!------------------------------------------------------------- -! naacw: Accretion of cloud water by averaged snow/graupel -! (Nc->) -!------------------------------------------------------------- - naacw(i,k) = (qrs(i,k,2)*nsacw(i,k)+qrs(i,k,3)*ngacw(i,k))/(qsum(i,k)) - endif -!------------------------------------------------------------- -! pracs: Accretion of snow by rain [HL A11] [LFO 27] -! (TG) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.qcrmin .and. qrs(i,k,1).gt.qcrmin) then - if(supcol.gt.0) then - acrfac = 5.*rslope3(i,k,2)*rslope3(i,k,2) & - + 4.*rslope3(i,k,2)*rslope2(i,k,2)*rslope(i,k,1) & - + 1.5*rslope2(i,k,2)*rslope2(i,k,2)*rslope2(i,k,1) - pracs(i,k) = pi*pi*ncr(i,k,3)*n0s*n0sfac(i,k)*abs(vt2r-vt2ave) & - *(dens/den(i,k))*acrfac - pracs(i,k) = min(pracs(i,k),qrs(i,k,2)/dtcld) - endif -!------------------------------------------------------------- -! psacr: Accretion of rain by snow [HL A10] [LFO 28] -! (TS or R->G) (T>=T0: enhance melting of snow) -!------------------------------------------------------------- - acrfac = 30.*rslope3(i,k,1)*rslope2(i,k,1)*rslope(i,k,2) & - + 5.*rslope2(i,k,1)*rslope2(i,k,1)*rslope2(i,k,2) & - + 2.*rslope3(i,k,1)*rslope3(i,k,2) - psacr(i,k) = pi*pi*ncr(i,k,3)*n0s*n0sfac(i,k)*abs(vt2ave-vt2r) & - *(denr/den(i,k))*acrfac - psacr(i,k) = min(psacr(i,k),qrs(i,k,1)/dtcld) - endif - if(qrs(i,k,2).gt.qcrmin .and. ncr(i,k,3).gt.nrmin) then -!------------------------------------------------------------- -! nsacr: Accretion of rain by snow -! (T) -!------------------------------------------------------------- - acrfac = 1.5*rslope2(i,k,1)*rslope(i,k,2) & - + 1.0*rslope(i,k,1)*rslope2(i,k,2)+.5*rslope3(i,k,2) - nsacr(i,k) = pi*ncr(i,k,3)*n0s*n0sfac(i,k)*abs(vt2ave-vt2r) & - *acrfac - nsacr(i,k) = min(nsacr(i,k),ncr(i,k,3)/dtcld) - endif -!------------------------------------------------------------- -! pgacr: Accretion of rain by graupel [HL A12] [LFO 42] -! (TG) (T>=T0: enhance melting of graupel) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.qcrmin .and. qrs(i,k,1).gt.qcrmin) then - acrfac = 30.*rslope3(i,k,1)*rslope2(i,k,1)*rslope(i,k,3) & - + 5.*rslope2(i,k,1)*rslope2(i,k,1)*rslope2(i,k,3) & - + 2.*rslope3(i,k,1)*rslope3(i,k,3) - pgacr(i,k) = pi*pi*ncr(i,k,3)*n0g*abs(vt2ave-vt2r)*(denr/den(i,k)) & - *acrfac - pgacr(i,k) = min(pgacr(i,k),qrs(i,k,1)/dtcld) - endif -!------------------------------------------------------------- -! ngacr: Accretion of rain by graupel -! (T) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.qcrmin .and. ncr(i,k,3).gt.nrmin) then - acrfac = 1.5*rslope2(i,k,1)*rslope(i,k,3) & - + 1.0*rslope(i,k,1)*rslope2(i,k,3) + .5*rslope3(i,k,3) - ngacr(i,k) = pi*ncr(i,k,3)*n0g*abs(vt2ave-vt2r)*acrfac - ngacr(i,k) = min(ngacr(i,k),ncr(i,k,3)/dtcld) - endif -! -!------------------------------------------------------------- -! pgacs: Accretion of snow by graupel [HL A13] [LFO 29] -! (S->G) : This process is eliminated in V3.0 with the -! new combined snow/graupel fall speeds -!------------------------------------------------------------- - if(qrs(i,k,3).gt.qcrmin .and. qrs(i,k,2).gt.qcrmin) then - pgacs(i,k) = 0. - endif - if(supcol.le.0) then - xlf = xlf0 -!------------------------------------------------------------- -! pseml: Enhanced melting of snow by accretion of water [HL A34] -! (T>=T0: S->R) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.0.) & - pseml(i,k) = min(max(cliq*supcol*(paacw(i,k)+psacr(i,k)) & - /xlf,-qrs(i,k,2)/dtcld),0.) -!-------------------------------------------------------------- -! nseml: Enhanced melting of snow by accretion of water -! (T>=T0: ->NR) -!-------------------------------------------------------------- - if (qrs(i,k,2).gt.qcrmin) then - sfac = rslope(i,k,2)*n0s*n0sfac(i,k)/qrs(i,k,2) - nseml(i,k) = -sfac*pseml(i,k) - endif -!------------------------------------------------------------- -! pgeml: Enhanced melting of graupel by accretion of water [HL A24] [RH84 A21-A22] -! (T>=T0: G->R) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.0.) & - pgeml(i,k) = min(max(cliq*supcol*(paacw(i,k)+pgacr(i,k))/xlf & - ,-qrs(i,k,3)/dtcld),0.) -!-------------------------------------------------------------- -! ngeml: Enhanced melting of graupel by accretion of water -! (T>=T0: -> NR) -!-------------------------------------------------------------- - if (qrs(i,k,3).gt.qcrmin) then - gfac = rslope(i,k,3)*n0g/qrs(i,k,3) - ngeml(i,k) = -gfac*pgeml(i,k) - endif - endif - if(supcol.gt.0) then -!------------------------------------------------------------- -! pidep: Deposition/Sublimation rate of ice [HDC 9] -! (TI or I->V) -!------------------------------------------------------------- - if(qci(i,k,2).gt.0. .and. ifsat.ne.1) then - pidep(i,k) = 4.*diameter*xni(i,k)*(rh(i,k,2)-1.)/work1(i,k,2) - supice = satdt-prevp(i,k) - if(pidep(i,k).lt.0.) then - pidep(i,k) = max(max(pidep(i,k),satdt/2),supice) - pidep(i,k) = max(pidep(i,k),-qci(i,k,2)/dtcld) - else - pidep(i,k) = min(min(pidep(i,k),satdt/2),supice) - endif - if(abs(prevp(i,k)+pidep(i,k)).ge.abs(satdt)) ifsat = 1 - endif -!------------------------------------------------------------- -! psdep: deposition/sublimation rate of snow [HDC 14] -! (TS or S->V) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.0. .and. ifsat.ne.1) then - coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) - psdep(i,k) = (rh(i,k,2)-1.)*n0sfac(i,k)*(precs1*rslope2(i,k,2) & - + precs2*work2(i,k)*coeres)/work1(i,k,2) - supice = satdt-prevp(i,k)-pidep(i,k) - if(psdep(i,k).lt.0.) then - psdep(i,k) = max(psdep(i,k),-qrs(i,k,2)/dtcld) - psdep(i,k) = max(max(psdep(i,k),satdt/2),supice) - else - psdep(i,k) = min(min(psdep(i,k),satdt/2),supice) - endif - if(abs(prevp(i,k)+pidep(i,k)+psdep(i,k)).ge.abs(satdt)) ifsat = 1 - endif -!------------------------------------------------------------- -! pgdep: deposition/sublimation rate of graupel [HL A21] [LFO 46] -! (TG or G->V) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.0. .and. ifsat.ne.1) then - coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) - pgdep(i,k) = (rh(i,k,2)-1.)*(precg1*rslope2(i,k,3) & - + precg2*work2(i,k)*coeres)/work1(i,k,2) - supice = satdt-prevp(i,k)-pidep(i,k)-psdep(i,k) - if(pgdep(i,k).lt.0.) then - pgdep(i,k) = max(pgdep(i,k),-qrs(i,k,3)/dtcld) - pgdep(i,k) = max(max(pgdep(i,k),satdt/2),supice) - else - pgdep(i,k) = min(min(pgdep(i,k),satdt/2),supice) - endif - if(abs(prevp(i,k)+pidep(i,k)+psdep(i,k)+pgdep(i,k)).ge. & - abs(satdt)) ifsat = 1 - endif -!------------------------------------------------------------- -! pigen: generation(nucleation) of ice from vapor [HL 50] [HDC 7-8] -! (TI) -!------------------------------------------------------------- - if(supsat.gt.0. .and. ifsat.ne.1) then - supice = satdt-prevp(i,k)-pidep(i,k)-psdep(i,k)-pgdep(i,k) - xni0 = 1.e3*exp(0.1*supcol) - roqi0 = 4.92e-11*xni0**1.33 - pigen(i,k) = max(0.,(roqi0/den(i,k)-max(qci(i,k,2),0.))/dtcld) - pigen(i,k) = min(min(pigen(i,k),satdt),supice) - endif -! -!------------------------------------------------------------- -! psaut: conversion(aggregation) of ice to snow [HDC 12] -! (TS) -!------------------------------------------------------------- - if(qci(i,k,2).gt.0.) then - qimax = roqimax/den(i,k) - psaut(i,k) = max(0.,(qci(i,k,2)-qimax)/dtcld) - endif -! -!------------------------------------------------------------- -! pgaut: conversion(aggregation) of snow to graupel [HL A4] [LFO 37] -! (TG) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.0.) then - alpha2 = 1.e-3*exp(0.09*(-supcol)) - pgaut(i,k) = min(max(0.,alpha2*(qrs(i,k,2)-qs0)),qrs(i,k,2)/dtcld) - endif - endif -! -!------------------------------------------------------------- -! psevp: Evaporation of melting snow [HL A35] [RH83 A27] -! (T>=T0: S->V) -!------------------------------------------------------------- - if(supcol.lt.0.) then - if(qrs(i,k,2).gt.0. .and. rh(i,k,1).lt.1.) then - coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) - psevp(i,k) = (rh(i,k,1)-1.)*n0sfac(i,k)*(precs1*rslope2(i,k,2) & - +precs2*work2(i,k)*coeres)/work1(i,k,1) - psevp(i,k) = min(max(psevp(i,k),-qrs(i,k,2)/dtcld),0.) - endif -!------------------------------------------------------------- -! pgevp: Evaporation of melting graupel [HL A25] [RH84 A19] -! (T>=T0: G->V) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.0. .and. rh(i,k,1).lt.1.) then - coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) - pgevp(i,k) = (rh(i,k,1)-1.)*(precg1*rslope2(i,k,3) & - + precg2*work2(i,k)*coeres)/work1(i,k,1) - pgevp(i,k) = min(max(pgevp(i,k),-qrs(i,k,3)/dtcld),0.) - endif - endif - enddo - enddo -! -! -!---------------------------------------------------------------- -! check mass conservation of generation terms and feedback to the -! large scale -! - do k = kts, kte - do i = its, ite -! - delta2=0. - delta3=0. - if(qrs(i,k,1).lt.1.e-4 .and. qrs(i,k,2).lt.1.e-4) delta2=1. - if(qrs(i,k,1).lt.1.e-4) delta3=1. - if(t(i,k).le.t0c) then -! -! cloud water -! - value = max(qmin,qci(i,k,1)) - source = (praut(i,k)+pracw(i,k)+paacw(i,k)+paacw(i,k)-prevp_s(i,k))& - *dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - prevp_s(i,k) = prevp_s(i,k)*factor - endif -! -! cloud ice -! - value = max(qmin,qci(i,k,2)) - source = (psaut(i,k)-pigen(i,k)-pidep(i,k)+praci(i,k)+psaci(i,k) & - +pgaci(i,k))*dtcld - if (source.gt.value) then - factor = value/source - psaut(i,k) = psaut(i,k)*factor - pigen(i,k) = pigen(i,k)*factor - pidep(i,k) = pidep(i,k)*factor - praci(i,k) = praci(i,k)*factor - psaci(i,k) = psaci(i,k)*factor - pgaci(i,k) = pgaci(i,k)*factor - endif -! -! rain -! - value = max(qmin,qrs(i,k,1)) - source = (-praut(i,k)-prevp(i,k)-pracw(i,k)+piacr(i,k) & - +prevp_s(i,k)+psacr(i,k)+pgacr(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - prevp(i,k) = prevp(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - piacr(i,k) = piacr(i,k)*factor - psacr(i,k) = psacr(i,k)*factor - pgacr(i,k) = pgacr(i,k)*factor - prevp_s(i,k) = prevp_s(i,k)*factor - endif -! -! snow -! - value = max(qmin,qrs(i,k,2)) - source = -(psdep(i,k)+psaut(i,k)-pgaut(i,k)+paacw(i,k) & - +piacr(i,k)*delta3+praci(i,k)*delta3 & - -pracs(i,k)*(1.-delta2)+psacr(i,k)*delta2 & - +psaci(i,k)-pgacs(i,k) )*dtcld - if (source.gt.value) then - factor = value/source - psdep(i,k) = psdep(i,k)*factor - psaut(i,k) = psaut(i,k)*factor - pgaut(i,k) = pgaut(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - piacr(i,k) = piacr(i,k)*factor - praci(i,k) = praci(i,k)*factor - psaci(i,k) = psaci(i,k)*factor - pracs(i,k) = pracs(i,k)*factor - psacr(i,k) = psacr(i,k)*factor - pgacs(i,k) = pgacs(i,k)*factor - endif -! -! graupel -! - value = max(qmin,qrs(i,k,3)) - source = -(pgdep(i,k)+pgaut(i,k) & - +piacr(i,k)*(1.-delta3)+praci(i,k)*(1.-delta3) & - +psacr(i,k)*(1.-delta2)+pracs(i,k)*(1.-delta2) & - +pgaci(i,k)+paacw(i,k)+pgacr(i,k)+pgacs(i,k))*dtcld - if (source.gt.value) then - factor = value/source - pgdep(i,k) = pgdep(i,k)*factor - pgaut(i,k) = pgaut(i,k)*factor - piacr(i,k) = piacr(i,k)*factor - praci(i,k) = praci(i,k)*factor - psacr(i,k) = psacr(i,k)*factor - pracs(i,k) = pracs(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - pgaci(i,k) = pgaci(i,k)*factor - pgacr(i,k) = pgacr(i,k)*factor - pgacs(i,k) = pgacs(i,k)*factor - endif -! -! cloud -! - value = max(ncmin,ncr(i,k,2)) - source = (nraut(i,k)+nccol(i,k)+nracw(i,k) & - +naacw(i,k)+naacw(i,k)-nrevp(i,k))*dtcld - if (source.gt.value) then - factor = value/source - nraut(i,k) = nraut(i,k)*factor - nccol(i,k) = nccol(i,k)*factor - nracw(i,k) = nracw(i,k)*factor - naacw(i,k) = naacw(i,k)*factor - nrevp(i,k) = nrevp(i,k)*factor - endif -! -! rain -! - value = max(nrmin,ncr(i,k,3)) - source = (-nraut(i,k)+nrcol(i,k)+niacr(i,k)+nsacr(i,k)+ngacr(i,k) & - +nrevp(i,k))*dtcld - if (source.gt.value) then - factor = value/source - nraut(i,k) = nraut(i,k)*factor - nrcol(i,k) = nrcol(i,k)*factor - niacr(i,k) = niacr(i,k)*factor - nsacr(i,k) = nsacr(i,k)*factor - ngacr(i,k) = ngacr(i,k)*factor - nrevp(i,k) = nrevp(i,k)*factor - endif -! - work2(i,k)=-(prevp(i,k)+psdep(i,k)+pgdep(i,k)+pigen(i,k)+pidep(i,k)) -! update - q(i,k) = q(i,k)+work2(i,k)*dtcld - qci(i,k,1) = max(qci(i,k,1)-(praut(i,k)+pracw(i,k) & - +paacw(i,k)+paacw(i,k)+prevp_s(i,k))*dtcld,0.) - qrs(i,k,1) = max(qrs(i,k,1)+(praut(i,k)+pracw(i,k) & - +prevp(i,k)-piacr(i,k)-pgacr(i,k) & - -psacr(i,k)-prevp_s(i,k))*dtcld,0.) - qci(i,k,2) = max(qci(i,k,2)-(psaut(i,k)+praci(i,k) & - +psaci(i,k)+pgaci(i,k)-pigen(i,k)-pidep(i,k)) & - *dtcld,0.) - qrs(i,k,2) = max(qrs(i,k,2)+(psdep(i,k)+psaut(i,k)+paacw(i,k) & - -pgaut(i,k)+piacr(i,k)*delta3 & - +praci(i,k)*delta3+psaci(i,k)-pgacs(i,k) & - -pracs(i,k)*(1.-delta2)+psacr(i,k)*delta2) & - *dtcld,0.) - qrs(i,k,3) = max(qrs(i,k,3)+(pgdep(i,k)+pgaut(i,k) & - +piacr(i,k)*(1.-delta3) & - +praci(i,k)*(1.-delta3)+psacr(i,k)*(1.-delta2) & - +pracs(i,k)*(1.-delta2)+pgaci(i,k)+paacw(i,k) & - +pgacr(i,k)+pgacs(i,k))*dtcld,0.) - ncr(i,k,2) = max(ncr(i,k,2)+(-nraut(i,k)-nccol(i,k)-nracw(i,k) & - -naacw(i,k)-naacw(i,k)+nrevp(i,k))*dtcld,0.) - ncr(i,k,3) = max(ncr(i,k,3)+(nraut(i,k)-nrcol(i,k)-niacr(i,k) & - -nsacr(i,k)-ngacr(i,k)-nrevp(i,k))*dtcld,0.) - xlf = xls-xl(i,k) - xlwork2 = -xls*(psdep(i,k)+pgdep(i,k)+pidep(i,k)+pigen(i,k)) & - -xl(i,k)*prevp(i,k)-xlf*(piacr(i,k)+paacw(i,k) & - +paacw(i,k)+pgacr(i,k)+psacr(i,k)) - t(i,k) = t(i,k)-xlwork2/cpm(i,k)*dtcld - else -! -! cloud water -! - value = max(qmin,qci(i,k,1)) - source= (praut(i,k)+pracw(i,k)+paacw(i,k)+paacw(i,k)-prevp_s(i,k)) & - *dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - prevp_s(i,k) = prevp_s(i,k)*factor - endif -! -! rain -! - value = max(qmin,qrs(i,k,1)) - source = (-paacw(i,k)-praut(i,k)+pseml(i,k)+pgeml(i,k) & - +prevp_s(i,k)-pracw(i,k)-paacw(i,k)-prevp(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - prevp(i,k) = prevp(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - pseml(i,k) = pseml(i,k)*factor - pgeml(i,k) = pgeml(i,k)*factor - prevp_s(i,k) = prevp_s(i,k)*factor - endif -! -! snow -! - value = max(qcrmin,qrs(i,k,2)) - source=(pgacs(i,k)-pseml(i,k)-psevp(i,k))*dtcld - if (source.gt.value) then - factor = value/source - pgacs(i,k) = pgacs(i,k)*factor - psevp(i,k) = psevp(i,k)*factor - pseml(i,k) = pseml(i,k)*factor - endif -! -! graupel -! - value = max(qcrmin,qrs(i,k,3)) - source=-(pgacs(i,k)+pgevp(i,k)+pgeml(i,k))*dtcld - if (source.gt.value) then - factor = value/source - pgacs(i,k) = pgacs(i,k)*factor - pgevp(i,k) = pgevp(i,k)*factor - pgeml(i,k) = pgeml(i,k)*factor - endif -! -! cloud -! - value = max(ncmin,ncr(i,k,2)) - source = (+nraut(i,k)+nccol(i,k)+nracw(i,k)+naacw(i,k) & - +naacw(i,k)-nrevp(i,k))*dtcld - if (source.gt.value) then - factor = value/source - nraut(i,k) = nraut(i,k)*factor - nccol(i,k) = nccol(i,k)*factor - nracw(i,k) = nracw(i,k)*factor - naacw(i,k) = naacw(i,k)*factor - nrevp(i,k) = nrevp(i,k)*factor - endif -! -! rain -! - value = max(nrmin,ncr(i,k,3)) - source = (-nraut(i,k)+nrcol(i,k)-nseml(i,k)-ngeml(i,k) & - +nrevp(i,k))*dtcld - if (source.gt.value) then - factor = value/source - nraut(i,k) = nraut(i,k)*factor - nrcol(i,k) = nrcol(i,k)*factor - nrevp(i,k) = nrevp(i,k)*factor - nseml(i,k) = nseml(i,k)*factor - ngeml(i,k) = ngeml(i,k)*factor - endif -! - work2(i,k)=-(prevp(i,k)+psevp(i,k)+pgevp(i,k)) -! update - q(i,k) = q(i,k)+work2(i,k)*dtcld - qci(i,k,1) = max(qci(i,k,1)-(praut(i,k)+pracw(i,k) & - +prevp_s(i,k)+paacw(i,k)+paacw(i,k))*dtcld,0.) - qrs(i,k,1) = max(qrs(i,k,1)+(praut(i,k)+pracw(i,k) & - +prevp(i,k)-prevp_s(i,k)+paacw(i,k)+paacw(i,k)-pseml(i,k) & - -pgeml(i,k))*dtcld,0.) - qrs(i,k,2) = max(qrs(i,k,2)+(psevp(i,k)-pgacs(i,k) & - +pseml(i,k))*dtcld,0.) - qrs(i,k,3) = max(qrs(i,k,3)+(pgacs(i,k)+pgevp(i,k) & - +pgeml(i,k))*dtcld,0.) - ncr(i,k,2) = max(ncr(i,k,2)+(-nraut(i,k)-nccol(i,k)-nracw(i,k) & - -naacw(i,k)-naacw(i,k)+nrevp(i,k))*dtcld,0.) - ncr(i,k,3) = max(ncr(i,k,3)+(nraut(i,k)-nrcol(i,k)+nseml(i,k) & - +ngeml(i,k)-nrevp(i,k))*dtcld,0.) - xlf = xls-xl(i,k) - xlwork2 = -xl(i,k)*(prevp(i,k)+psevp(i,k)+pgevp(i,k)) & - -xlf*(pseml(i,k)+pgeml(i,k)) - t(i,k) = t(i,k)-xlwork2/cpm(i,k)*dtcld - endif - enddo - enddo -! -! Inline expansion for fpvs -! qs(i,k,1) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) -! qs(i,k,2) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) - hsub = xls - hvap = xlv0 - cvap = cpv - ttp=t0c+0.01 - dldt=cvap-cliq - xa=-dldt/rv - xb=xa+hvap/(rv*ttp) - dldti=cvap-cice - xai=-dldti/rv - xbi=xai+hsub/(rv*ttp) - do k = kts, kte - do i = its, ite - tr=ttp/t(i,k) - qs(i,k,1)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) - qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k) - qs(i,k,1)) - qs(i,k,1) = max(qs(i,k,1),qmin) - tr=ttp/t(i,k) - if(t(i,k).lt.ttp) then - qs(i,k,2)=psat*exp(log(tr)*(xai))*exp(xbi*(1.-tr)) - else - qs(i,k,2)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) - endif - qs(i,k,2) = ep2 * qs(i,k,2) / (p(i,k) - qs(i,k,2)) - qs(i,k,2) = max(qs(i,k,2),qmin) - rh(i,k,1) = max(q(i,k) / qs(i,k,1),qmin) - enddo - enddo -! - do k = kts, kte - do i = its, ite -!--------------------------------------------------------------- -! put the inital CCN number concentration -! - if(ncr(i,k,1).eq.0.) ncr(i,k,1) = ccn0 -!--------------------------------------------------------------- -! rate of change of cloud drop concentration due to CCN activation -! pcact: V -> C [KK 14] -! ncact: NCCN -> NC [KK 12] - if(rh(i,k,1).gt.1.) then - ncact(i,k) = max(0.,((ncr(i,k,1)+ncr(i,k,2)) & - *min(1.,(rh(i,k,1)/satmax)**actk) - ncr(i,k,2)))/dtcld - ncact(i,k) =min(ncact(i,k),max(ncr(i,k,1),0.)/dtcld) - pcact(i,k) = min(4.*pi*denr*(actr*1.E-6)**3*ncact(i,k)/ & - (3.*den(i,k)),max(q(i,k),0.)/dtcld) - q(i,k) = max(q(i,k)-pcact(i,k)*dtcld,0.) - qci(i,k,1) = max(qci(i,k,1)+pcact(i,k)*dtcld,0.) - ncr(i,k,1) = max(ncr(i,k,1)-ncact(i,k)*dtcld,0.) - ncr(i,k,2) = max(ncr(i,k,2)+ncact(i,k)*dtcld,0.) - t(i,k) = t(i,k)+pcact(i,k)*xl(i,k)/cpm(i,k)*dtcld - endif -!---------------------------------------------------------------- -! pcond: condensational/evaporational rate of cloud water [HL A46] [RH83 A6] -! if there exists additional water vapor condensated/if -! evaporation of cloud water is not enough to remove subsaturation - tr=ttp/t(i,k) - qs(i,k,1)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) - qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k) - qs(i,k,1)) - qs(i,k,1) = max(qs(i,k,1),qmin) - work1(i,k,1) = conden(t(i,k),q(i,k),qs(i,k,1),xl(i,k),cpm(i,k)) - work2(i,k) = qci(i,k,1)+work1(i,k,1) - pcond(i,k) = min(max(work1(i,k,1)/dtcld,0.),max(q(i,k),0.)/dtcld) - if(qci(i,k,1).gt.0. .and. work1(i,k,1).lt.0.) & - pcond(i,k) = max(work1(i,k,1),-qci(i,k,1))/dtcld -!--------------------------------------------------------------- -! ncevp: evpration of Cloud number concentration [CP ] -! - if(pcond(i,k).eq.-qci(i,k,1)/dtcld) then - ncr(i,k,2) = 0. - ncr(i,k,1) = ncr(i,k,1)+ncr(i,k,2) - endif -! - q(i,k) = q(i,k)-pcond(i,k)*dtcld - qci(i,k,1) = max(qci(i,k,1)+pcond(i,k)*dtcld,0.) - t(i,k) = t(i,k)+pcond(i,k)*xl(i,k)/cpm(i,k)*dtcld - enddo - enddo -! -!---------------------------------------------------------------- -! padding for small values -! - do k = kts, kte - do i = its, ite - if(qci(i,k,1).le.qmin) qci(i,k,1) = 0.0 - if(qci(i,k,2).le.qmin) qci(i,k,2) = 0.0 - enddo - enddo - enddo ! big loops - END SUBROUTINE wdm62d -! ................................................................... - REAL FUNCTION rgmma(x) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -! rgmma function: use infinite product form - REAL :: euler - PARAMETER (euler=0.577215664901532) - REAL :: x, y - INTEGER :: i - if(x.eq.1.)then - rgmma=0. - else - rgmma=x*exp(euler*x) - do i=1,10000 - y=float(i) - rgmma=rgmma*(1.000+x/y)*exp(-x/y) - enddo - rgmma=1./rgmma - endif - END FUNCTION rgmma -! -!-------------------------------------------------------------------------- - REAL FUNCTION fpvs(t,ice,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c) -!-------------------------------------------------------------------------- - IMPLICIT NONE -!-------------------------------------------------------------------------- - REAL t,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c,dldt,xa,xb,dldti, & - xai,xbi,ttp,tr - INTEGER ice -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ttp=t0c+0.01 - dldt=cvap-cliq - xa=-dldt/rv - xb=xa+hvap/(rv*ttp) - dldti=cvap-cice - xai=-dldti/rv - xbi=xai+hsub/(rv*ttp) - tr=ttp/t - if(t.lt.ttp .and. ice.eq.1) then - fpvs=psat*(tr**xai)*exp(xbi*(1.-tr)) - else - fpvs=psat*(tr**xa)*exp(xb*(1.-tr)) - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END FUNCTION fpvs -!------------------------------------------------------------------- - SUBROUTINE wdm6init(den0,denr,dens,cl,cpv, ccn0, allowed_to_read) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -!.... constants which may not be tunable - REAL, INTENT(IN) :: den0,denr,dens,cl,cpv,ccn0 - LOGICAL, INTENT(IN) :: allowed_to_read - REAL :: pi -! - pi = 4.*atan(1.) - xlv1 = cl-cpv -! - qc0 = 4./3.*pi*denr*r0**3*xncr/den0 ! 0.419e-3 -- .61e-3 - qck1 = .104*9.8*peaut/(xncr*denr)**(1./3.)/xmyu*den0**(4./3.) ! 7.03 - pidnc = pi*denr/6. -! - bvtr1 = 1.+bvtr - bvtr2 = 2.+bvtr - bvtr3 = 3.+bvtr - bvtr4 = 4.+bvtr - bvtr5 = 5.+bvtr - bvtr6 = 6.+bvtr - bvtr7 = 7.+bvtr - bvtr2o5 = 2.5+.5*bvtr - bvtr3o5 = 3.5+.5*bvtr - g1pbr = rgmma(bvtr1) - g2pbr = rgmma(bvtr2) - g3pbr = rgmma(bvtr3) - g4pbr = rgmma(bvtr4) ! 17.837825 - g5pbr = rgmma(bvtr5) - g6pbr = rgmma(bvtr6) - g7pbr = rgmma(bvtr7) - g5pbro2 = rgmma(bvtr2o5) - g7pbro2 = rgmma(bvtr3o5) - pvtr = avtr*g5pbr/24. - pvtrn = avtr*g2pbr - eacrr = 1.0 - pacrr = pi*n0r*avtr*g3pbr*.25*eacrr - precr1 = 2.*pi*1.56 - precr2 = 2.*pi*.31*avtr**.5*g7pbro2 - pidn0r = pi*denr*n0r - pidnr = 4.*pi*denr -! - xmmax = (dimax/dicon)**2 - roqimax = 2.08e22*dimax**8 -! - bvts1 = 1.+bvts - bvts2 = 2.5+.5*bvts - bvts3 = 3.+bvts - bvts4 = 4.+bvts - g1pbs = rgmma(bvts1) !.8875 - g3pbs = rgmma(bvts3) - g4pbs = rgmma(bvts4) ! 12.0786 - g5pbso2 = rgmma(bvts2) - pvts = avts*g4pbs/6. - pacrs = pi*n0s*avts*g3pbs*.25 - precs1 = 4.*n0s*.65 - precs2 = 4.*n0s*.44*avts**.5*g5pbso2 - pidn0s = pi*dens*n0s -! - pacrc = pi*n0s*avts*g3pbs*.25*eacrc -! - bvtg1 = 1.+bvtg - bvtg2 = 2.5+.5*bvtg - bvtg3 = 3.+bvtg - bvtg4 = 4.+bvtg - g1pbg = rgmma(bvtg1) - g3pbg = rgmma(bvtg3) - g4pbg = rgmma(bvtg4) - g5pbgo2 = rgmma(bvtg2) - pacrg = pi*n0g*avtg*g3pbg*.25 - pvtg = avtg*g4pbg/6. - precg1 = 2.*pi*n0g*.78 - precg2 = 2.*pi*n0g*.31*avtg**.5*g5pbgo2 - pidn0g = pi*deng*n0g -! - rslopecmax = 1./lamdacmax - rslopermax = 1./lamdarmax - rslopesmax = 1./lamdasmax - rslopegmax = 1./lamdagmax - rsloperbmax = rslopermax ** bvtr - rslopesbmax = rslopesmax ** bvts - rslopegbmax = rslopegmax ** bvtg - rslopec2max = rslopecmax * rslopecmax - rsloper2max = rslopermax * rslopermax - rslopes2max = rslopesmax * rslopesmax - rslopeg2max = rslopegmax * rslopegmax - rslopec3max = rslopec2max * rslopecmax - rsloper3max = rsloper2max * rslopermax - rslopes3max = rslopes2max * rslopesmax - rslopeg3max = rslopeg2max * rslopegmax -! - END SUBROUTINE wdm6init -END MODULE module_mp_wdm6 diff --git a/src/fim/FIMsrc/fim/wrfphys/module_mp_wsm3.F b/src/fim/FIMsrc/fim/wrfphys/module_mp_wsm3.F deleted file mode 100644 index 46be657..0000000 --- a/src/fim/FIMsrc/fim/wrfphys/module_mp_wsm3.F +++ /dev/null @@ -1,1014 +0,0 @@ -#if ( RWORDSIZE == 4 ) -# define VREC vsrec -# define VSQRT vssqrt -#else -# define VREC vrec -# define VSQRT vsqrt -#endif - -MODULE module_mp_wsm3 -! -! - REAL, PARAMETER, PRIVATE :: dtcldcr = 120. ! maximum time step for minor loops - REAL, PARAMETER, PRIVATE :: n0r = 8.e6 ! intercept parameter rain - REAL, PARAMETER, PRIVATE :: avtr = 841.9 ! a constant for terminal velocity of rain - REAL, PARAMETER, PRIVATE :: bvtr = 0.8 ! a constant for terminal velocity of rain - REAL, PARAMETER, PRIVATE :: r0 = .8e-5 ! 8 microm in contrast to 10 micro m - REAL, PARAMETER, PRIVATE :: peaut = .55 ! collection efficiency - REAL, PARAMETER, PRIVATE :: xncr = 3.e8 ! maritime cloud in contrast to 3.e8 in tc80 - REAL, PARAMETER, PRIVATE :: xmyu = 1.718e-5 ! the dynamic viscosity kgm-1s-1 - REAL, PARAMETER, PRIVATE :: avts = 11.72 ! a constant for terminal velocity of snow - REAL, PARAMETER, PRIVATE :: bvts = .41 ! a constant for terminal velocity of snow - REAL, PARAMETER, PRIVATE :: n0smax = 1.e11 ! maximum n0s (t=-90C unlimited) - REAL, PARAMETER, PRIVATE :: lamdarmax = 8.e4 ! limited maximum value for slope parameter of rain - REAL, PARAMETER, PRIVATE :: lamdasmax = 1.e5 ! limited maximum value for slope parameter of snow - REAL, PARAMETER, PRIVATE :: lamdagmax = 6.e4 ! limited maximum value for slope parameter of graupel - REAL, PARAMETER, PRIVATE :: dicon = 11.9 ! constant for the cloud-ice diamter - REAL, PARAMETER, PRIVATE :: dimax = 500.e-6 ! limited maximum value for the cloud-ice diamter - REAL, PARAMETER, PRIVATE :: n0s = 2.e6 ! temperature dependent intercept parameter snow - REAL, PARAMETER, PRIVATE :: alpha = .12 ! .122 exponen factor for n0s - REAL, PARAMETER, PRIVATE :: qcrmin = 1.e-9 ! minimun values for qr, qs, and qg - REAL, SAVE :: & - qc0, qck1,bvtr1,bvtr2,bvtr3,bvtr4,g1pbr, & - g3pbr,g4pbr,g5pbro2,pvtr,eacrr,pacrr, & - precr1,precr2,xmmax,roqimax,bvts1, & - bvts2,bvts3,bvts4,g1pbs,g3pbs,g4pbs, & - g5pbso2,pvts,pacrs,precs1,precs2,pidn0r, & - pidn0s,xlv1, & - rslopermax,rslopesmax,rslopegmax, & - rsloperbmax,rslopesbmax,rslopegbmax, & - rsloper2max,rslopes2max,rslopeg2max, & - rsloper3max,rslopes3max,rslopeg3max -! -! Specifies code-inlining of fpvs function in WSM32D below. JM 20040507 -! -CONTAINS -!=================================================================== -! - SUBROUTINE wsm3(th, q, qci, qrs & - , w, den, pii, p, delz & - , delt,g, cpd, cpv, rd, rv, t0c & - , ep1, ep2, qmin & - , XLS, XLV0, XLF0, den0, denr & - , cliq,cice,psat & - , rain, rainncv & - , snow, snowncv & - , sr & - , ids,ide, jds,jde, kds,kde & - , ims,ime, jms,jme, kms,kme & - , its,ite, jts,jte, kts,kte & - ) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -! -! -! This code is a 3-class simple ice microphyiscs scheme (WSM3) of the WRF -! Single-Moment MicroPhyiscs (WSMMP). The WSMMP assumes that ice nuclei -! number concentration is a function of temperature, and seperate assumption -! is developed, in which ice crystal number concentration is a function -! of ice amount. A theoretical background of the ice-microphysics and related -! processes in the WSMMPs are described in Hong et al. (2004). -! Production terms in the WSM6 scheme are described in Hong and Lim (2006). -! All units are in m.k.s. and source/sink terms in kgkg-1s-1. -! -! WSM3 cloud scheme -! -! Coded by Song-You Hong (Yonsei Univ.) -! Jimy Dudhia (NCAR) and Shu-Hua Chen (UC Davis) -! Summer 2002 -! -! Implemented by Song-You Hong (Yonsei Univ.) and Jimy Dudhia (NCAR) -! Summer 2003 -! -! Reference) Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev. -! Dudhia (D89, 1989) J. Atmos. Sci. -! Hong and Lim (HL, 2006) J. Korean Meteor. Soc. -! - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & - ims,ime, jms,jme, kms,kme , & - its,ite, jts,jte, kts,kte - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(INOUT) :: & - th, & - q, & - qci, & - qrs - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: w, & - den, & - pii, & - p, & - delz - - REAL, INTENT(IN ) :: delt, & - g, & - rd, & - rv, & - t0c, & - den0, & - cpd, & - cpv, & - ep1, & - ep2, & - qmin, & - XLS, & - XLV0, & - XLF0, & - cliq, & - cice, & - psat, & - denr - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(INOUT) :: rain, & - rainncv - - REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, & - INTENT(INOUT) :: snow, & - snowncv, & - sr - -! LOCAL VAR - REAL, DIMENSION( its:ite , kts:kte ) :: t - INTEGER :: i,j,k -!------------------------------------------------------------------- - DO j=jts,jte - DO k=kts,kte - DO i=its,ite - t(i,k)=th(i,k,j)*pii(i,k,j) - ENDDO - ENDDO - CALL wsm32D(t, q(ims,kms,j), qci(ims,kms,j) & - ,qrs(ims,kms,j),w(ims,kms,j), den(ims,kms,j) & - ,p(ims,kms,j), delz(ims,kms,j) & - ,delt,g, cpd, cpv, rd, rv, t0c & - ,ep1, ep2, qmin & - ,XLS, XLV0, XLF0, den0, denr & - ,cliq,cice,psat & - ,j & - ,rain(ims,j), rainncv(ims,j) & - ,snow(ims,j),snowncv(ims,j) & - ,sr(ims,j) & - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte & - ) - DO K=kts,kte - DO I=its,ite - th(i,k,j)=t(i,k)/pii(i,k,j) - ENDDO - ENDDO - ENDDO - END SUBROUTINE wsm3 -!=================================================================== -! - SUBROUTINE wsm32D(t, q, qci, qrs,w, den, p, delz & - ,delt,g, cpd, cpv, rd, rv, t0c & - ,ep1, ep2, qmin & - ,XLS, XLV0, XLF0, den0, denr & - ,cliq,cice,psat & - ,lat & - ,rain, rainncv & - ,snow,snowncv & - ,sr & - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte & - ) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - lat - REAL, DIMENSION( its:ite , kts:kte ), & - INTENT(INOUT) :: & - t - REAL, DIMENSION( ims:ime , kms:kme ), & - INTENT(INOUT) :: & - q, & - qci, & - qrs - REAL, DIMENSION( ims:ime , kms:kme ), & - INTENT(IN ) :: w, & - den, & - p, & - delz - REAL, INTENT(IN ) :: delt, & - g, & - cpd, & - cpv, & - t0c, & - den0, & - rd, & - rv, & - ep1, & - ep2, & - qmin, & - XLS, & - XLV0, & - XLF0, & - cliq, & - cice, & - psat, & - denr - REAL, DIMENSION( ims:ime ), & - INTENT(INOUT) :: rain, & - rainncv - - REAL, DIMENSION( ims:ime ), OPTIONAL, & - INTENT(INOUT) :: snow, & - snowncv, & - sr -! LOCAL VAR - REAL, DIMENSION( its:ite , kts:kte ) :: & - rh, & - qs, & - denfac, & - rslope, & - rslope2, & - rslope3, & - rslopeb - REAL, DIMENSION( its:ite , kts:kte ) :: & - pgen, & - pisd, & - paut, & - pacr, & - pres, & - pcon - REAL, DIMENSION( its:ite , kts:kte ) :: & - fall, & - falk, & - xl, & - cpm, & - work1, & - work2, & - xni, & - qs0, & - n0sfac - REAL, DIMENSION( its:ite , kts:kte ) :: & - falkc, & - work1c, & - work2c, & - fallc - - INTEGER, DIMENSION( its:ite ) :: kwork1,& - kwork2 - - INTEGER, DIMENSION( its:ite ) :: mstep, & - numdt - LOGICAL, DIMENSION( its:ite ) :: flgcld - REAL :: pi, & - cpmcal, xlcal, lamdar, lamdas, diffus, & - viscos, xka, venfac, conden, diffac, & - x, y, z, a, b, c, d, e, & - fallsum, fallsum_qsi, vt2i,vt2s,acrfac, & - qdt, pvt, qik, delq, facq, qrsci, frzmlt, & - snomlt, hold, holdrs, facqci, supcol, coeres, & - supsat, dtcld, xmi, qciik, delqci, eacrs, satdt, & - qimax, diameter, xni0, roqi0, supice,holdc, holdci - INTEGER :: i, j, k, mstepmax, & - iprt, latd, lond, loop, loops, ifsat, kk, n -! Temporaries used for inlining fpvs function - REAL :: dldti, xb, xai, tr, xbi, xa, hvap, cvap, hsub, dldt, ttp -! variables for optimization - REAL, DIMENSION( its:ite ) :: tvec1 -! -!================================================================= -! compute internal functions -! - cpmcal(x) = cpd*(1.-max(x,qmin))+max(x,qmin)*cpv - xlcal(x) = xlv0-xlv1*(x-t0c) -!---------------------------------------------------------------- -! size distributions: (x=mixing ratio, y=air density): -! valid for mixing ratio > 1.e-9 kg/kg. -! -! Optimizatin : A**B => exp(log(A)*(B)) - lamdar(x,y)= sqrt(sqrt(pidn0r/(x*y))) ! (pidn0r/(x*y))**.25 - lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 -! -!---------------------------------------------------------------- -! diffus: diffusion coefficient of the water vapor -! viscos: kinematic viscosity(m2s-1) -! - diffus(x,y) = 8.794e-5 * exp(log(x)*(1.81)) / y ! 8.794e-5*x**1.81/y - viscos(x,y) = 1.496e-6 * (x*sqrt(x)) /(x+120.)/y ! 1.496e-6*x**1.5/(x+120.)/y - xka(x,y) = 1.414e3*viscos(x,y)*y - diffac(a,b,c,d,e) = d*a*a/(xka(c,d)*rv*c*c)+1./(e*diffus(c,b)) -! venfac(a,b,c) = (viscos(b,c)/diffus(b,a))**(.3333333) & -! /viscos(b,c)**(.5)*(den0/c)**0.25 - venfac(a,b,c) = exp(log((viscos(b,c)/diffus(b,a)))*((.3333333))) & - /sqrt(viscos(b,c))*sqrt(sqrt(den0/c)) - conden(a,b,c,d,e) = (max(b,qmin)-c)/(1.+d*d/(rv*e)*c/(a*a)) -! - pi = 4. * atan(1.) -! -!---------------------------------------------------------------- -! paddint 0 for negative values generated by dynamics -! - do k = kts, kte - do i = its, ite - qci(i,k) = max(qci(i,k),0.0) - qrs(i,k) = max(qrs(i,k),0.0) - enddo - enddo -! -!---------------------------------------------------------------- -! latent heat for phase changes and heat capacity. neglect the -! changes during microphysical process calculation -! emanuel(1994) -! - do k = kts, kte - do i = its, ite - cpm(i,k) = cpmcal(q(i,k)) - xl(i,k) = xlcal(t(i,k)) - enddo - enddo -! -!---------------------------------------------------------------- -! compute the minor time steps. -! - loops = max(nint(delt/dtcldcr),1) - dtcld = delt/loops - if(delt.le.dtcldcr) dtcld = delt -! - do loop = 1,loops -! -!---------------------------------------------------------------- -! initialize the large scale variables -! - do i = its, ite - mstep(i) = 1 - flgcld(i) = .true. - enddo -! -! do k = kts, kte -! do i = its, ite -! denfac(i,k) = sqrt(den0/den(i,k)) -! enddo -! enddo - do k = kts, kte - CALL VREC( tvec1(its), den(its,k), ite-its+1) - do i = its, ite - tvec1(i) = tvec1(i)*den0 - enddo - CALL VSQRT( denfac(its,k), tvec1(its), ite-its+1) - enddo -! -! Inline expansion for fpvs -! qs(i,k) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) -! qs0(i,k) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) - cvap = cpv - hvap=xlv0 - hsub=xls - ttp=t0c+0.01 - dldt=cvap-cliq - xa=-dldt/rv - xb=xa+hvap/(rv*ttp) - dldti=cvap-cice - xai=-dldti/rv - xbi=xai+hsub/(rv*ttp) - do k = kts, kte - do i = its, ite -! tr=ttp/t(i,k) -! if(t(i,k).lt.ttp) then -! qs(i,k) =psat*(tr**xai)*exp(xbi*(1.-tr)) -! else -! qs(i,k) =psat*(tr**xa)*exp(xb*(1.-tr)) -! endif -! qs0(i,k) =psat*(tr**xa)*exp(xb*(1.-tr)) - tr=ttp/t(i,k) - if(t(i,k).lt.ttp) then - qs(i,k) =psat*(exp(log(tr)*(xai)))*exp(xbi*(1.-tr)) - else - qs(i,k) =psat*(exp(log(tr)*(xa)))*exp(xb*(1.-tr)) - endif - qs0(i,k) =psat*(exp(log(tr)*(xa)))*exp(xb*(1.-tr)) - qs0(i,k) = (qs0(i,k)-qs(i,k))/qs(i,k) - qs(i,k) = ep2 * qs(i,k) / (p(i,k) - qs(i,k)) - qs(i,k) = max(qs(i,k),qmin) - rh(i,k) = max(q(i,k) / qs(i,k),qmin) - enddo - enddo -! -!---------------------------------------------------------------- -! initialize the variables for microphysical physics -! -! - do k = kts, kte - do i = its, ite - pres(i,k) = 0. - paut(i,k) = 0. - pacr(i,k) = 0. - pgen(i,k) = 0. - pisd(i,k) = 0. - pcon(i,k) = 0. - fall(i,k) = 0. - falk(i,k) = 0. - fallc(i,k) = 0. - falkc(i,k) = 0. - xni(i,k) = 1.e3 - enddo - enddo -! -!---------------------------------------------------------------- -! compute the fallout term: -! first, vertical terminal velosity for minor loops -!--------------------------------------------------------------- -! n0s: Intercept parameter for snow [m-4] [HDC 6] -!--------------------------------------------------------------- - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) - n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) - if(t(i,k).ge.t0c) then - if(qrs(i,k).le.qcrmin)then - rslope(i,k) = rslopermax - rslopeb(i,k) = rsloperbmax - rslope2(i,k) = rsloper2max - rslope3(i,k) = rsloper3max - else - rslope(i,k) = 1./lamdar(qrs(i,k),den(i,k)) -! rslopeb(i,k) = rslope(i,k)**bvtr - rslopeb(i,k) = exp(log(rslope(i,k))*(bvtr)) - rslope2(i,k) = rslope(i,k)*rslope(i,k) - rslope3(i,k) = rslope2(i,k)*rslope(i,k) - endif - else - if(qrs(i,k).le.qcrmin)then - rslope(i,k) = rslopesmax - rslopeb(i,k) = rslopesbmax - rslope2(i,k) = rslopes2max - rslope3(i,k) = rslopes3max - else - rslope(i,k) = 1./lamdas(qrs(i,k),den(i,k),n0sfac(i,k)) -! rslopeb(i,k) = rslope(i,k)**bvts - rslopeb(i,k) = exp(log(rslope(i,k))*(bvts)) - rslope2(i,k) = rslope(i,k)*rslope(i,k) - rslope3(i,k) = rslope2(i,k)*rslope(i,k) - endif - endif -!------------------------------------------------------------- -! Ni: ice crystal number concentraiton [HDC 5c] -!------------------------------------------------------------- -! xni(i,k) = min(max(5.38e7 & -! *(den(i,k)*max(qci(i,k),qmin))**0.75,1.e3),1.e6) - xni(i,k) = min(max(5.38e7 & - *exp(log((den(i,k)*max(qci(i,k),qmin)))*(0.75)),1.e3),1.e6) - enddo - enddo -! - mstepmax = 1 - numdt = 1 - do k = kte, kts, -1 - do i = its, ite - if(t(i,k).lt.t0c) then - pvt = pvts - else - pvt = pvtr - endif - work1(i,k) = pvt*rslopeb(i,k)*denfac(i,k) - work2(i,k) = work1(i,k)/delz(i,k) - numdt(i) = max(nint(work2(i,k)*dtcld+.5),1) - if(numdt(i).ge.mstep(i)) mstep(i) = numdt(i) - enddo - enddo - do i = its, ite - if(mstepmax.le.mstep(i)) mstepmax = mstep(i) - enddo -! - do n = 1, mstepmax - k = kte - do i = its, ite - if(n.le.mstep(i)) then - falk(i,k) = den(i,k)*qrs(i,k)*work2(i,k)/mstep(i) - hold = falk(i,k) - fall(i,k) = fall(i,k)+falk(i,k) - holdrs = qrs(i,k) - qrs(i,k) = max(qrs(i,k)-falk(i,k)*dtcld/den(i,k),0.) - endif - enddo - do k = kte-1, kts, -1 - do i = its, ite - if(n.le.mstep(i)) then - falk(i,k) = den(i,k)*qrs(i,k)*work2(i,k)/mstep(i) - hold = falk(i,k) - fall(i,k) = fall(i,k)+falk(i,k) - holdrs = qrs(i,k) - qrs(i,k) = max(qrs(i,k)-(falk(i,k) & - -falk(i,k+1)*delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) - endif - enddo - enddo - enddo -!--------------------------------------------------------------- -! Vice [ms-1] : fallout of ice crystal [HDC 5a] -!--------------------------------------------------------------- - mstepmax = 1 - mstep = 1 - numdt = 1 - do k = kte, kts, -1 - do i = its, ite - if(t(i,k).lt.t0c.and.qci(i,k).gt.0.) then - xmi = den(i,k)*qci(i,k)/xni(i,k) -! diameter = dicon * sqrt(xmi) -! work1c(i,k) = 1.49e4*diameter**1.31 - diameter = max(dicon * sqrt(xmi), 1.e-25) - work1c(i,k) = 1.49e4*exp(log(diameter)*(1.31)) - else - work1c(i,k) = 0. - endif - if(qci(i,k).le.0.) then - work2c(i,k) = 0. - else - work2c(i,k) = work1c(i,k)/delz(i,k) - endif - numdt(i) = max(nint(work2c(i,k)*dtcld+.5),1) - if(numdt(i).ge.mstep(i)) mstep(i) = numdt(i) - enddo - enddo - do i = its, ite - if(mstepmax.le.mstep(i)) mstepmax = mstep(i) - enddo -! - do n = 1, mstepmax - k = kte - do i = its, ite - if (n.le.mstep(i)) then - falkc(i,k) = den(i,k)*qci(i,k)*work2c(i,k)/mstep(i) - holdc = falkc(i,k) - fallc(i,k) = fallc(i,k)+falkc(i,k) - holdci = qci(i,k) - qci(i,k) = max(qci(i,k)-falkc(i,k)*dtcld/den(i,k),0.) - endif - enddo - do k = kte-1, kts, -1 - do i = its, ite - if (n.le.mstep(i)) then - falkc(i,k) = den(i,k)*qci(i,k)*work2c(i,k)/mstep(i) - holdc = falkc(i,k) - fallc(i,k) = fallc(i,k)+falkc(i,k) - holdci = qci(i,k) - qci(i,k) = max(qci(i,k)-(falkc(i,k) & - -falkc(i,k+1)*delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) - endif - enddo - enddo - enddo -! -!---------------------------------------------------------------- -! compute the freezing/melting term. [D89 B16-B17] -! freezing occurs one layer above the melting level -! - do i = its, ite - mstep(i) = 0 - enddo - do k = kts, kte -! - do i = its, ite - if(t(i,k).ge.t0c) then - mstep(i) = k - endif - enddo - enddo -! - do i = its, ite - kwork2(i) = mstep(i) - kwork1(i) = mstep(i) - if(mstep(i).ne.0) then - if (w(i,mstep(i)).gt.0.) then - kwork1(i) = mstep(i) + 1 - endif - endif - enddo -! - do i = its, ite - k = kwork1(i) - kk = kwork2(i) - if(k*kk.ge.1) then - qrsci = qrs(i,k) + qci(i,k) - if(qrsci.gt.0..or.fall(i,kk).gt.0.) then - frzmlt = min(max(-w(i,k)*qrsci/delz(i,k),-qrsci/dtcld), & - qrsci/dtcld) - snomlt = min(max(fall(i,kk)/den(i,kk),-qrs(i,k)/dtcld), & - qrs(i,k)/dtcld) - if(k.eq.kk) then - t(i,k) = t(i,k) - xlf0/cpm(i,k)*(frzmlt+snomlt)*dtcld - else - t(i,k) = t(i,k) - xlf0/cpm(i,k)*frzmlt*dtcld - t(i,kk) = t(i,kk) - xlf0/cpm(i,kk)*snomlt*dtcld - endif - endif - endif - enddo -! -!---------------------------------------------------------------- -! rain (unit is mm/sec;kgm-2s-1: /1000*delt ===> m)==> mm for wrf -! - do i = its, ite - fallsum = fall(i,1) - fallsum_qsi = 0. - if((t0c-t(i,1)).gt.0) then - fallsum = fallsum+fallc(i,1) - fallsum_qsi = fall(i,1)+fallc(i,1) - endif - rainncv(i) = 0. - if(fallsum.gt.0.) then - rainncv(i) = fallsum*delz(i,1)/denr*dtcld*1000. - rain(i) = fallsum*delz(i,1)/denr*dtcld*1000. + rain(i) - endif - IF ( PRESENT (snowncv) .AND. PRESENT (snow)) THEN - snowncv(i) = 0. - if(fallsum_qsi.gt.0.) then - snowncv(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. - snow(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + snow(i) - endif - ENDIF - sr(i) = 0. - if(fallsum.gt.0.) sr(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. & - /(rainncv(i)+1.e-12) - enddo -! -!---------------------------------------------------------------- -! rsloper: reverse of the slope parameter of the rain(m) -! xka: thermal conductivity of air(jm-1s-1k-1) -! work1: the thermodynamic term in the denominator associated with -! heat conduction and vapor diffusion -! (ry88, y93, h85) -! work2: parameter associated with the ventilation effects(y93) -! - do k = kts, kte - do i = its, ite - if(t(i,k).ge.t0c) then - if(qrs(i,k).le.qcrmin)then - rslope(i,k) = rslopermax - rslopeb(i,k) = rsloperbmax - rslope2(i,k) = rsloper2max - rslope3(i,k) = rsloper3max - else - rslope(i,k) = 1./lamdar(qrs(i,k),den(i,k)) - rslopeb(i,k) = exp(log(rslope(i,k))*(bvtr)) - rslope2(i,k) = rslope(i,k)*rslope(i,k) - rslope3(i,k) = rslope2(i,k)*rslope(i,k) - endif - else - if(qrs(i,k).le.qcrmin)then - rslope(i,k) = rslopesmax - rslopeb(i,k) = rslopesbmax - rslope2(i,k) = rslopes2max - rslope3(i,k) = rslopes3max - else - rslope(i,k) = 1./lamdas(qrs(i,k),den(i,k),n0sfac(i,k)) - rslopeb(i,k) = exp(log(rslope(i,k))*(bvts)) - rslope2(i,k) = rslope(i,k)*rslope(i,k) - rslope3(i,k) = rslope2(i,k)*rslope(i,k) - endif - endif - enddo - enddo -! - do k = kts, kte - do i = its, ite - if(t(i,k).ge.t0c) then - work1(i,k) = diffac(xl(i,k),p(i,k),t(i,k),den(i,k),qs(i,k)) - else - work1(i,k) = diffac(xls,p(i,k),t(i,k),den(i,k),qs(i,k)) - endif - work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) - enddo - enddo -! - do k = kts, kte - do i = its, ite - supsat = max(q(i,k),qmin)-qs(i,k) - satdt = supsat/dtcld - if(t(i,k).ge.t0c) then -! -!=============================================================== -! -! warm rain processes -! -! - follows the processes in RH83 and LFO except for autoconcersion -! -!=============================================================== -!--------------------------------------------------------------- -! praut: auto conversion rate from cloud to rain [HDC 16] -! (C->R) -!--------------------------------------------------------------- - if(qci(i,k).gt.qc0) then -! paut(i,k) = qck1*qci(i,k)**(7./3.) - paut(i,k) = qck1*exp(log(qci(i,k))*((7./3.))) - paut(i,k) = min(paut(i,k),qci(i,k)/dtcld) - endif -!--------------------------------------------------------------- -! pracw: accretion of cloud water by rain [HL A40] [D89 B15] -! (C->R) -!--------------------------------------------------------------- - if(qrs(i,k).gt.qcrmin.and.qci(i,k).gt.qmin) then - pacr(i,k) = min(pacrr*rslope3(i,k)*rslopeb(i,k) & - *qci(i,k)*denfac(i,k),qci(i,k)/dtcld) - endif -!--------------------------------------------------------------- -! prevp: evaporation/condensation rate of rain [HDC 14] -! (V->R or R->V) -!--------------------------------------------------------------- - if(qrs(i,k).gt.0.) then - coeres = rslope2(i,k)*sqrt(rslope(i,k)*rslopeb(i,k)) - pres(i,k) = (rh(i,k)-1.)*(precr1*rslope2(i,k) & - +precr2*work2(i,k)*coeres)/work1(i,k) - if(pres(i,k).lt.0.) then - pres(i,k) = max(pres(i,k),-qrs(i,k)/dtcld) - pres(i,k) = max(pres(i,k),satdt/2) - else - pres(i,k) = min(pres(i,k),satdt/2) - endif - endif - else -! -!=============================================================== -! -! cold rain processes -! -! - follows the revised ice microphysics processes in HDC -! - the processes same as in RH83 and LFO behave -! following ice crystal hapits defined in HDC, inclduing -! intercept parameter for snow (n0s), ice crystal number -! concentration (ni), ice nuclei number concentration -! (n0i), ice diameter (d) -! -!=============================================================== -! - supcol = t0c-t(i,k) - ifsat = 0 -!------------------------------------------------------------- -! Ni: ice crystal number concentraiton [HDC 5c] -!------------------------------------------------------------- -! xni(i,k) = min(max(5.38e7 & -! *(den(i,k)*max(qci(i,k),qmin))**0.75,1.e3),1.e6) - xni(i,k) = min(max(5.38e7 & - *exp(log((den(i,k)*max(qci(i,k),qmin)))*(0.75)),1.e3),1.e6) - eacrs = exp(0.07*(-supcol)) -! - if(qrs(i,k).gt.qcrmin.and.qci(i,k).gt.qmin) then - xmi = den(i,k)*qci(i,k)/xni(i,k) - diameter = min(dicon * sqrt(xmi),dimax) - vt2i = 1.49e4*diameter**1.31 -! vt2i = 1.49e4*exp((log(diameter))*(1.31)) - vt2s = pvts*rslopeb(i,k)*denfac(i,k) -!------------------------------------------------------------- -! praci: Accretion of cloud ice by rain [HL A15] [LFO 25] -! (TR) -!------------------------------------------------------------- - acrfac = 2.*rslope3(i,k)+2.*diameter*rslope2(i,k) & - +diameter**2*rslope(i,k) - pacr(i,k) = min(pi*qci(i,k)*eacrs*n0s*n0sfac(i,k) & - *abs(vt2s-vt2i)*acrfac/4.,qci(i,k)/dtcld) - endif -!------------------------------------------------------------- -! pidep: Deposition/Sublimation rate of ice [HDC 9] -! (TI or I->V) -!------------------------------------------------------------- - if(qci(i,k).gt.0.) then - xmi = den(i,k)*qci(i,k)/xni(i,k) - diameter = dicon * sqrt(xmi) - pisd(i,k) = 4.*diameter*xni(i,k)*(rh(i,k)-1.)/work1(i,k) - if(pisd(i,k).lt.0.) then - pisd(i,k) = max(pisd(i,k),satdt/2) - pisd(i,k) = max(pisd(i,k),-qci(i,k)/dtcld) - else - pisd(i,k) = min(pisd(i,k),satdt/2) - endif - if(abs(pisd(i,k)).ge.abs(satdt)) ifsat = 1 - endif -!------------------------------------------------------------- -! psdep: deposition/sublimation rate of snow [HDC 14] -! (V->S or S->V) -!------------------------------------------------------------- - if(qrs(i,k).gt.0..and.ifsat.ne.1) then - coeres = rslope2(i,k)*sqrt(rslope(i,k)*rslopeb(i,k)) - pres(i,k) = (rh(i,k)-1.)*n0sfac(i,k)*(precs1*rslope2(i,k) & - +precs2*work2(i,k)*coeres)/work1(i,k) - supice = satdt-pisd(i,k) - if(pres(i,k).lt.0.) then - pres(i,k) = max(pres(i,k),-qrs(i,k)/dtcld) - pres(i,k) = max(max(pres(i,k),satdt/2),supice) - else - pres(i,k) = min(min(pres(i,k),satdt/2),supice) - endif - if(abs(pisd(i,k)+pres(i,k)).ge.abs(satdt)) ifsat = 1 - endif -!------------------------------------------------------------- -! pigen: generation(nucleation) of ice from vapor [HDC 7-8] -! (TI) -!------------------------------------------------------------- - if(supsat.gt.0.and.ifsat.ne.1) then - supice = satdt-pisd(i,k)-pres(i,k) - xni0 = 1.e3*exp(0.1*supcol) -! roqi0 = 4.92e-11*xni0**1.33 - roqi0 = 4.92e-11*exp(log(xni0)*(1.33)) - pgen(i,k) = max(0.,(roqi0/den(i,k)-max(qci(i,k),0.))/dtcld) - pgen(i,k) = min(min(pgen(i,k),satdt),supice) - endif -!------------------------------------------------------------- -! psaut: conversion(aggregation) of ice to snow [HDC 12] -! (TS) -!------------------------------------------------------------- - if(qci(i,k).gt.0.) then - qimax = roqimax/den(i,k) - paut(i,k) = max(0.,(qci(i,k)-qimax)/dtcld) - endif - endif - enddo - enddo -! -!---------------------------------------------------------------- -! check mass conservation of generation terms and feedback to the -! large scale -! - do k = kts, kte - do i = its, ite - qciik = max(qmin,qci(i,k)) - delqci = (paut(i,k)+pacr(i,k)-pgen(i,k)-pisd(i,k))*dtcld - if(delqci.ge.qciik) then - facqci = qciik/delqci - paut(i,k) = paut(i,k)*facqci - pacr(i,k) = pacr(i,k)*facqci - pgen(i,k) = pgen(i,k)*facqci - pisd(i,k) = pisd(i,k)*facqci - endif - qik = max(qmin,q(i,k)) - delq = (pres(i,k)+pgen(i,k)+pisd(i,k))*dtcld - if(delq.ge.qik) then - facq = qik/delq - pres(i,k) = pres(i,k)*facq - pgen(i,k) = pgen(i,k)*facq - pisd(i,k) = pisd(i,k)*facq - endif - work2(i,k) = -pres(i,k)-pgen(i,k)-pisd(i,k) - q(i,k) = q(i,k)+work2(i,k)*dtcld - qci(i,k) = max(qci(i,k)-(paut(i,k)+pacr(i,k)-pgen(i,k)-pisd(i,k)) & - *dtcld,0.) - qrs(i,k) = max(qrs(i,k)+(paut(i,k)+pacr(i,k)+pres(i,k))*dtcld,0.) - if(t(i,k).lt.t0c) then - t(i,k) = t(i,k)-xls*work2(i,k)/cpm(i,k)*dtcld - else - t(i,k) = t(i,k)-xl(i,k)*work2(i,k)/cpm(i,k)*dtcld - endif - enddo - enddo -! - cvap = cpv - hvap = xlv0 - hsub = xls - ttp=t0c+0.01 - dldt=cvap-cliq - xa=-dldt/rv - xb=xa+hvap/(rv*ttp) - dldti=cvap-cice - xai=-dldti/rv - xbi=xai+hsub/(rv*ttp) - do k = kts, kte - do i = its, ite - tr=ttp/t(i,k) -! qs(i,k)=psat*(tr**xa)*exp(xb*(1.-tr)) - qs(i,k)=psat*(exp(log(tr)*(xa)))*exp(xb*(1.-tr)) - qs(i,k) = ep2 * qs(i,k) / (p(i,k) - qs(i,k)) - qs(i,k) = max(qs(i,k),qmin) - denfac(i,k) = sqrt(den0/den(i,k)) - enddo - enddo -! -!---------------------------------------------------------------- -! pcond: condensational/evaporational rate of cloud water [HL A46] [RH83 A6] -! if there exists additional water vapor condensated/if -! evaporation of cloud water is not enough to remove subsaturation -! - do k = kts, kte - do i = its, ite - work1(i,k) = conden(t(i,k),q(i,k),qs(i,k),xl(i,k),cpm(i,k)) - work2(i,k) = qci(i,k)+work1(i,k) - pcon(i,k) = min(max(work1(i,k),0.),max(q(i,k),0.))/dtcld - if(qci(i,k).gt.0..and.work1(i,k).lt.0.and.t(i,k).gt.t0c) & - pcon(i,k) = max(work1(i,k),-qci(i,k))/dtcld - q(i,k) = q(i,k)-pcon(i,k)*dtcld - qci(i,k) = max(qci(i,k)+pcon(i,k)*dtcld,0.) - t(i,k) = t(i,k)+pcon(i,k)*xl(i,k)/cpm(i,k)*dtcld - enddo - enddo -! -!---------------------------------------------------------------- -! padding for small values -! - do k = kts, kte - do i = its, ite - if(qci(i,k).le.qmin) qci(i,k) = 0.0 - enddo - enddo -! - enddo ! big loops - END SUBROUTINE wsm32D -! ................................................................... - REAL FUNCTION rgmma(x) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -! rgmma function: use infinite product form - REAL :: euler - PARAMETER (euler=0.577215664901532) - REAL :: x, y - INTEGER :: i - if(x.eq.1.)then - rgmma=0. - else - rgmma=x*exp(euler*x) - do i=1,10000 - y=float(i) - rgmma=rgmma*(1.000+x/y)*exp(-x/y) - enddo - rgmma=1./rgmma - endif - END FUNCTION rgmma -! -!-------------------------------------------------------------------------- - REAL FUNCTION fpvs(t,ice,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c) -!-------------------------------------------------------------------------- - IMPLICIT NONE -!-------------------------------------------------------------------------- - REAL t,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c,dldt,xa,xb,dldti, & - xai,xbi,ttp,tr - INTEGER ice -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ttp=t0c+0.01 - dldt=cvap-cliq - xa=-dldt/rv - xb=xa+hvap/(rv*ttp) - dldti=cvap-cice - xai=-dldti/rv - xbi=xai+hsub/(rv*ttp) - tr=ttp/t - if(t.lt.ttp.and.ice.eq.1) then - fpvs=psat*(tr**xai)*exp(xbi*(1.-tr)) - else - fpvs=psat*(tr**xa)*exp(xb*(1.-tr)) - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END FUNCTION fpvs -!------------------------------------------------------------------- - SUBROUTINE wsm3init(den0,denr,dens,cl,cpv,allowed_to_read) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -!.... constants which may not be tunable - REAL, INTENT(IN) :: den0,denr,dens,cl,cpv - LOGICAL, INTENT(IN) :: allowed_to_read - REAL :: pi -! - pi = 4.*atan(1.) - xlv1 = cl-cpv -! - qc0 = 4./3.*pi*denr*r0**3*xncr/den0 ! 0.419e-3 -- .61e-3 - qck1 = .104*9.8*peaut/(xncr*denr)**(1./3.)/xmyu*den0**(4./3.) ! 7.03 -! - bvtr1 = 1.+bvtr - bvtr2 = 2.5+.5*bvtr - bvtr3 = 3.+bvtr - bvtr4 = 4.+bvtr - g1pbr = rgmma(bvtr1) - g3pbr = rgmma(bvtr3) - g4pbr = rgmma(bvtr4) ! 17.837825 - g5pbro2 = rgmma(bvtr2) ! 1.8273 - pvtr = avtr*g4pbr/6. - eacrr = 1.0 - pacrr = pi*n0r*avtr*g3pbr*.25*eacrr - precr1 = 2.*pi*n0r*.78 - precr2 = 2.*pi*n0r*.31*avtr**.5*g5pbro2 - xmmax = (dimax/dicon)**2 - roqimax = 2.08e22*dimax**8 -! - bvts1 = 1.+bvts - bvts2 = 2.5+.5*bvts - bvts3 = 3.+bvts - bvts4 = 4.+bvts - g1pbs = rgmma(bvts1) !.8875 - g3pbs = rgmma(bvts3) - g4pbs = rgmma(bvts4) ! 12.0786 - g5pbso2 = rgmma(bvts2) - pvts = avts*g4pbs/6. - pacrs = pi*n0s*avts*g3pbs*.25 - precs1 = 4.*n0s*.65 - precs2 = 4.*n0s*.44*avts**.5*g5pbso2 - pidn0r = pi*denr*n0r - pidn0s = pi*dens*n0s -! - rslopermax = 1./lamdarmax - rslopesmax = 1./lamdasmax - rsloperbmax = rslopermax ** bvtr - rslopesbmax = rslopesmax ** bvts - rsloper2max = rslopermax * rslopermax - rslopes2max = rslopesmax * rslopesmax - rsloper3max = rsloper2max * rslopermax - rslopes3max = rslopes2max * rslopesmax -! - END SUBROUTINE wsm3init -END MODULE module_mp_wsm3 diff --git a/src/fim/FIMsrc/fim/wrfphys/module_mp_wsm5.F b/src/fim/FIMsrc/fim/wrfphys/module_mp_wsm5.F deleted file mode 100644 index 9662808..0000000 --- a/src/fim/FIMsrc/fim/wrfphys/module_mp_wsm5.F +++ /dev/null @@ -1,1301 +0,0 @@ -#if ( RWORDSIZE == 4 ) -# define VREC vsrec -# define VSQRT vssqrt -#else -# define VREC vrec -# define VSQRT vsqrt -#endif - -!Including inline expansion statistical function -MODULE module_mp_wsm5 -! -! - REAL, PARAMETER, PRIVATE :: dtcldcr = 120. ! maximum time step for minor loops - REAL, PARAMETER, PRIVATE :: n0r = 8.e6 ! intercept parameter rain - REAL, PARAMETER, PRIVATE :: avtr = 841.9 ! a constant for terminal velocity of rain - REAL, PARAMETER, PRIVATE :: bvtr = 0.8 ! a constant for terminal velocity of rain - REAL, PARAMETER, PRIVATE :: r0 = .8e-5 ! 8 microm in contrast to 10 micro m - REAL, PARAMETER, PRIVATE :: peaut = .55 ! collection efficiency - REAL, PARAMETER, PRIVATE :: xncr = 3.e8 ! maritime cloud in contrast to 3.e8 in tc80 - REAL, PARAMETER, PRIVATE :: xmyu = 1.718e-5 ! the dynamic viscosity kgm-1s-1 - REAL, PARAMETER, PRIVATE :: avts = 11.72 ! a constant for terminal velocity of snow - REAL, PARAMETER, PRIVATE :: bvts = .41 ! a constant for terminal velocity of snow - REAL, PARAMETER, PRIVATE :: n0smax = 1.e11 ! maximum n0s (t=-90C unlimited) - REAL, PARAMETER, PRIVATE :: lamdarmax = 8.e4 ! limited maximum value for slope parameter of rain - REAL, PARAMETER, PRIVATE :: lamdasmax = 1.e5 ! limited maximum value for slope parameter of snow - REAL, PARAMETER, PRIVATE :: lamdagmax = 6.e4 ! limited maximum value for slope parameter of graupel - REAL, PARAMETER, PRIVATE :: dicon = 11.9 ! constant for the cloud-ice diamter - REAL, PARAMETER, PRIVATE :: dimax = 500.e-6 ! limited maximum value for the cloud-ice diamter - REAL, PARAMETER, PRIVATE :: n0s = 2.e6 ! temperature dependent intercept parameter snow - REAL, PARAMETER, PRIVATE :: alpha = .12 ! .122 exponen factor for n0s - REAL, PARAMETER, PRIVATE :: pfrz1 = 100. ! constant in Biggs freezing - REAL, PARAMETER, PRIVATE :: pfrz2 = 0.66 ! constant in Biggs freezing - REAL, PARAMETER, PRIVATE :: qcrmin = 1.e-9 ! minimun values for qr, qs, and qg - REAL, PARAMETER, PRIVATE :: eacrc = 1.0 ! Snow/cloud-water collection efficiency - REAL, SAVE :: & - qc0, qck1,bvtr1,bvtr2,bvtr3,bvtr4,g1pbr, & - g3pbr,g4pbr,g5pbro2,pvtr,eacrr,pacrr, & - precr1,precr2,xmmax,roqimax,bvts1, & - bvts2,bvts3,bvts4,g1pbs,g3pbs,g4pbs, & - g5pbso2,pvts,pacrs,precs1,precs2,pidn0r, & - pidn0s,xlv1,pacrc, & - rslopermax,rslopesmax,rslopegmax, & - rsloperbmax,rslopesbmax,rslopegbmax, & - rsloper2max,rslopes2max,rslopeg2max, & - rsloper3max,rslopes3max,rslopeg3max -! -! Specifies code-inlining of fpvs function in WSM52D below. JM 20040507 -! -CONTAINS -!=================================================================== -! - SUBROUTINE wsm5(th, q, qc, qr, qi, qs & - ,den, pii, p, delz & - ,delt,g, cpd, cpv, rd, rv, t0c & - ,ep1, ep2, qmin & - ,XLS, XLV0, XLF0, den0, denr & - ,cliq,cice,psat & - ,rain, rainncv & - ,snow, snowncv & - ,sr & - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte & - ) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -! -! This code is a 5-class mixed ice microphyiscs scheme (WSM5) of the WRF -! Single-Moment MicroPhyiscs (WSMMP). The WSMMP assumes that ice nuclei -! number concentration is a function of temperature, and seperate assumption -! is developed, in which ice crystal number concentration is a function -! of ice amount. A theoretical background of the ice-microphysics and related -! processes in the WSMMPs are described in Hong et al. (2004). -! Production terms in the WSM6 scheme are described in Hong and Lim (2006). -! All units are in m.k.s. and source/sink terms in kgkg-1s-1. -! -! WSM5 cloud scheme -! -! Coded by Song-You Hong (Yonsei Univ.) -! Jimy Dudhia (NCAR) and Shu-Hua Chen (UC Davis) -! Summer 2002 -! -! Implemented by Song-You Hong (Yonsei Univ.) and Jimy Dudhia (NCAR) -! Summer 2003 -! -! Reference) Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev. -! Rutledge, Hobbs (RH83, 1983) J. Atmos. Sci. -! Hong and Lim (HL, 2006) J. Korean Meteor. Soc. -! - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & - ims,ime, jms,jme, kms,kme , & - its,ite, jts,jte, kts,kte - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(INOUT) :: & - th, & - q, & - qc, & - qi, & - qr, & - qs - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: & - den, & - pii, & - p, & - delz - REAL, INTENT(IN ) :: delt, & - g, & - rd, & - rv, & - t0c, & - den0, & - cpd, & - cpv, & - ep1, & - ep2, & - qmin, & - XLS, & - XLV0, & - XLF0, & - cliq, & - cice, & - psat, & - denr - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(INOUT) :: rain, & - rainncv, & - sr - - REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, & - INTENT(INOUT) :: snow, & - snowncv - -! LOCAL VAR - REAL, DIMENSION( its:ite , kts:kte ) :: t - REAL, DIMENSION( its:ite , kts:kte, 2 ) :: qci, qrs - CHARACTER*256 :: emess - INTEGER :: mkx_test - INTEGER :: i,j,k - REAL :: test - -!------------------------------------------------------------------- - -#ifndef RUN_ON_GPU - DO j=jts,jte - DO k=kts,kte - DO i=its,ite - t(i,k)=th(i,k,j)*pii(i,k,j) - qci(i,k,1) = qc(i,k,j) - qci(i,k,2) = qi(i,k,j) - qrs(i,k,1) = qr(i,k,j) - qrs(i,k,2) = qs(i,k,j) -! if(j.eq.1000)then -! write(6,*)k,delz(i,k,j),p(i,k,j),den(i,k,j),t(i,k),qc(i,k,j),qr(i,k,j),q(i,k,j) -! endif - ENDDO - ENDDO - - ! Sending array starting locations of optional variables may cause - ! troubles, so we explicitly change the call. -! if(j.eq.1000)then -! write(6,*)delt,g, cpd, cpv, rd, rv, t0c,ep1, ep2, qmin,XLS, XLV0, XLF0, den0, denr,cliq,cice,psat -! endif - - CALL wsm52D(t, q(ims,kms,j), qci, qrs & - ,den(ims,kms,j) & - ,p(ims,kms,j), delz(ims,kms,j) & - ,delt,g, cpd, cpv, rd, rv, t0c & - ,ep1, ep2, qmin & - ,XLS, XLV0, XLF0, den0, denr & - ,cliq,cice,psat & - ,j & - ,rain(ims,j),rainncv(ims,j) & - ,sr(ims,j) & - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte & - ,snow,snowncv & - ) - - DO K=kts,kte - DO I=its,ite - test=th(i,k,j)-t(i,k)/pii(i,k,j) - th(i,k,j)=t(i,k)/pii(i,k,j) - qc(i,k,j) = qci(i,k,1) - qi(i,k,j) = qci(i,k,2) - qr(i,k,j) = qrs(i,k,1) - qs(i,k,j) = qrs(i,k,2) -! if(j.eq.1000)then -! write(6,*)'2',k,test,t(i,k),qc(i,k,j),qr(i,k,j),q(i,k,j) -! endif - - ENDDO - ENDDO - ENDDO -#else - CALL get_wsm5_gpu_levels ( mkx_test ) - IF ( mkx_test .LT. kte ) THEN - WRITE(emess,*)'Number of levels compiled for GPU WSM5 too small. ', & - mkx_test,' < ',kte - CALL wrf_error_fatal(emess) - ENDIF - CALL wsm5_host ( & - th(its:ite,kts:kte,jts:jte), pii(its:ite,kts:kte,jts:jte) & - ,q(its:ite,kts:kte,jts:jte), qc(its:ite,kts:kte,jts:jte) & - ,qi(its:ite,kts:kte,jts:jte), qr(its:ite,kts:kte,jts:jte) & - ,qs(its:ite,kts:kte,jts:jte), den(its:ite,kts:kte,jts:jte) & - ,p(its:ite,kts:kte,jts:jte), delz(its:ite,kts:kte,jts:jte) & - ,delt & - ,rain(its:ite,jts:jte),rainncv(its:ite,jts:jte) & - ,snow(its:ite,jts:jte),snowncv(its:ite,jts:jte) & - ,sr(its:ite,jts:jte) & - ,its, ite, jts, jte, kts, kte & - ,its, ite, jts, jte, kts, kte & - ,its, ite, jts, jte, kts, kte & - ) -#endif - - END SUBROUTINE wsm5 -!=================================================================== -! - SUBROUTINE wsm52D(t, q, qci, qrs, den, p, delz & - ,delt,g, cpd, cpv, rd, rv, t0c & - ,ep1, ep2, qmin & - ,XLS, XLV0, XLF0, den0, denr & - ,cliq,cice,psat & - ,lat & - ,rain,rainncv & - ,sr & - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte & - ,snow,snowncv & - ) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & - ims,ime, jms,jme, kms,kme , & - its,ite, jts,jte, kts,kte, & - lat - REAL, DIMENSION( its:ite , kts:kte ), & - INTENT(INOUT) :: & - t - REAL, DIMENSION( its:ite , kts:kte, 2 ), & - INTENT(INOUT) :: & - qci, & - qrs - REAL, DIMENSION( ims:ime , kms:kme ), & - INTENT(INOUT) :: & - q - REAL, DIMENSION( ims:ime , kms:kme ), & - INTENT(IN ) :: & - den, & - p, & - delz - REAL, INTENT(IN ) :: delt, & - g, & - cpd, & - cpv, & - t0c, & - den0, & - rd, & - rv, & - ep1, & - ep2, & - qmin, & - XLS, & - XLV0, & - XLF0, & - cliq, & - cice, & - psat, & - denr - REAL, DIMENSION( ims:ime ), & - INTENT(INOUT) :: rain, & - rainncv, & - sr - - REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, & - INTENT(INOUT) :: snow, & - snowncv - -! LOCAL VAR - REAL, DIMENSION( its:ite , kts:kte , 2) :: & - rh, & - qs, & - rslope, & - rslope2, & - rslope3, & - rslopeb, & - falk, & - fall, & - work1 - - REAL, DIMENSION( its:ite , kts:kte ) :: & - falkc, & - fallc, & - xl, & - cpm, & - denfac, & - xni, & - n0sfac, & - work2, & - work1c, & - work2c - - REAL, DIMENSION( its:ite , kts:kte ) :: & - pigen, & - pidep, & - psdep, & - praut, & - psaut, & - prevp, & - psevp, & - pracw, & - psacw, & - psaci, & - pcond, & - psmlt - INTEGER, DIMENSION( its:ite ) :: & - mstep, & - numdt - REAL, DIMENSION(its:ite) :: rmstep - REAL dtcldden, rdelz, rdtcld - LOGICAL, DIMENSION( its:ite ) :: flgcld - -#define WSM_NO_CONDITIONAL_IN_VECTOR -#ifdef WSM_NO_CONDITIONAL_IN_VECTOR - REAL, DIMENSION(its:ite) :: xal, xbl -#endif - - REAL :: pi, & - cpmcal, xlcal, lamdar, lamdas, diffus, & - viscos, xka, venfac, conden, diffac, & - x, y, z, a, b, c, d, e, & - qdt, holdrr, holdrs, supcol, supcolt, pvt, & - coeres, supsat, dtcld, xmi, eacrs, satdt, & - vt2i,vt2s,acrfac, & - qimax, diameter, xni0, roqi0, & - fallsum, fallsum_qsi, xlwork2, factor, source, & - value, xlf, pfrzdtc, pfrzdtr, supice, holdc, holdci -! variables for optimization - REAL, DIMENSION( its:ite ) :: tvec1 - REAL :: temp - INTEGER :: i, j, k, mstepmax, & - iprt, latd, lond, loop, loops, ifsat, n -! Temporaries used for inlining fpvs function - REAL :: dldti, xb, xai, tr, xbi, xa, hvap, cvap, hsub, dldt, ttp - REAL :: logtr -! -!================================================================= -! compute internal functions -! - cpmcal(x) = cpd*(1.-max(x,qmin))+max(x,qmin)*cpv - xlcal(x) = xlv0-xlv1*(x-t0c) -!---------------------------------------------------------------- -! size distributions: (x=mixing ratio, y=air density): -! valid for mixing ratio > 1.e-9 kg/kg. -! -! Optimizatin : A**B => exp(log(A)*(B)) - lamdar(x,y)= sqrt(sqrt(pidn0r/(x*y))) ! (pidn0r/(x*y))**.25 - lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 -! -!---------------------------------------------------------------- -! diffus: diffusion coefficient of the water vapor -! viscos: kinematic viscosity(m2s-1) -! diffus(x,y) = 8.794e-5 * exp(log(x)*(1.81)) / y ! 8.794e-5*x**1.81/y -! viscos(x,y) = 1.496e-6 * (x*sqrt(x)) /(x+120.)/y ! 1.496e-6*x**1.5/(x+120.)/y -! xka(x,y) = 1.414e3*viscos(x,y)*y -! diffac(a,b,c,d,e) = d*a*a/(xka(c,d)*rv*c*c)+1./(e*diffus(c,b)) -! venfac(a,b,c) = exp(log((viscos(b,c)/diffus(b,a)))*((.3333333))) & -! /sqrt(viscos(b,c))*sqrt(sqrt(den0/c)) -! conden(a,b,c,d,e) = (max(b,qmin)-c)/(1.+d*d/(rv*e)*c/(a*a)) -! -! - pi = 4. * atan(1.) -! -!---------------------------------------------------------------- -! paddint 0 for negative values generated by dynamics -! - do k = kts, kte - do i = its, ite - qci(i,k,1) = max(qci(i,k,1),0.0) - qrs(i,k,1) = max(qrs(i,k,1),0.0) - qci(i,k,2) = max(qci(i,k,2),0.0) - qrs(i,k,2) = max(qrs(i,k,2),0.0) - enddo - enddo -! -!---------------------------------------------------------------- -! latent heat for phase changes and heat capacity. neglect the -! changes during microphysical process calculation -! emanuel(1994) -! - do k = kts, kte - do i = its, ite - cpm(i,k) = cpmcal(q(i,k)) - xl(i,k) = xlcal(t(i,k)) - enddo - enddo -! -!---------------------------------------------------------------- -! compute the minor time steps. -! - loops = max(nint(delt/dtcldcr),1) - dtcld = delt/loops - if(delt.le.dtcldcr) dtcld = delt -! - do loop = 1,loops -! -!---------------------------------------------------------------- -! initialize the large scale variables -! - do i = its, ite - mstep(i) = 1 - flgcld(i) = .true. - enddo -! -! do k = kts, kte -! do i = its, ite -! denfac(i,k) = sqrt(den0/den(i,k)) -! enddo -! enddo - do k = kts, kte - CALL VREC( tvec1(its), den(its,k), ite-its+1) - do i = its, ite - tvec1(i) = tvec1(i)*den0 - enddo - CALL VSQRT( denfac(its,k), tvec1(its), ite-its+1) - enddo -! -! Inline expansion for fpvs -! qs(i,k,1) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) -! qs(i,k,2) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) - hsub = xls - hvap = xlv0 - cvap = cpv - ttp=t0c+0.01 - dldt=cvap-cliq - xa=-dldt/rv - xb=xa+hvap/(rv*ttp) - dldti=cvap-cice - xai=-dldti/rv - xbi=xai+hsub/(rv*ttp) - -! this is for compilers where the conditional inhibits vectorization -#ifdef WSM_NO_CONDITIONAL_IN_VECTOR - do k = kts, kte - do i = its, ite - if(t(i,k).lt.ttp) then - xal(i) = xai - xbl(i) = xbi - else - xal(i) = xa - xbl(i) = xb - endif - enddo - do i = its, ite - tr=ttp/t(i,k) - logtr=log(tr) - qs(i,k,1)=psat*exp(logtr*(xa)+xb*(1.-tr)) - qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k) - qs(i,k,1)) - qs(i,k,1) = max(qs(i,k,1),qmin) - rh(i,k,1) = max(q(i,k) / qs(i,k,1),qmin) - qs(i,k,2)=psat*exp(logtr*(xal(i))+xbl(i)*(1.-tr)) - qs(i,k,2) = ep2 * qs(i,k,2) / (p(i,k) - qs(i,k,2)) - qs(i,k,2) = max(qs(i,k,2),qmin) - rh(i,k,2) = max(q(i,k) / qs(i,k,2),qmin) - enddo - enddo -#else - do k = kts, kte - do i = its, ite - tr=ttp/t(i,k) - logtr=log(tr) - qs(i,k,1)=psat*exp(logtr*(xa)+xb*(1.-tr)) - qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k) - qs(i,k,1)) - qs(i,k,1) = max(qs(i,k,1),qmin) - rh(i,k,1) = max(q(i,k) / qs(i,k,1),qmin) - if(t(i,k).lt.ttp) then - qs(i,k,2)=psat*exp(logtr*(xai)+xbi*(1.-tr)) - else - qs(i,k,2)=psat*exp(logtr*(xa)+xb*(1.-tr)) - endif - qs(i,k,2) = ep2 * qs(i,k,2) / (p(i,k) - qs(i,k,2)) - qs(i,k,2) = max(qs(i,k,2),qmin) - rh(i,k,2) = max(q(i,k) / qs(i,k,2),qmin) - enddo - enddo -#endif -! -!---------------------------------------------------------------- -! initialize the variables for microphysical physics -! -! - do k = kts, kte - do i = its, ite - prevp(i,k) = 0. - psdep(i,k) = 0. - praut(i,k) = 0. - psaut(i,k) = 0. - pracw(i,k) = 0. - psaci(i,k) = 0. - psacw(i,k) = 0. - pigen(i,k) = 0. - pidep(i,k) = 0. - pcond(i,k) = 0. - psmlt(i,k) = 0. - psevp(i,k) = 0. - falk(i,k,1) = 0. - falk(i,k,2) = 0. - fall(i,k,1) = 0. - fall(i,k,2) = 0. - fallc(i,k) = 0. - falkc(i,k) = 0. - xni(i,k) = 1.e3 - enddo - enddo -! -!---------------------------------------------------------------- -! compute the fallout term: -! first, vertical terminal velosity for minor loops -! - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) -!--------------------------------------------------------------- -! n0s: Intercept parameter for snow [m-4] [HDC 6] -!--------------------------------------------------------------- - n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) - if(qrs(i,k,1).le.qcrmin)then - rslope(i,k,1) = rslopermax - rslopeb(i,k,1) = rsloperbmax - rslope2(i,k,1) = rsloper2max - rslope3(i,k,1) = rsloper3max - else - rslope(i,k,1) = 1./lamdar(qrs(i,k,1),den(i,k)) - rslopeb(i,k,1) = exp(log(rslope(i,k,1))*(bvtr)) - rslope2(i,k,1) = rslope(i,k,1)*rslope(i,k,1) - rslope3(i,k,1) = rslope2(i,k,1)*rslope(i,k,1) - endif - if(qrs(i,k,2).le.qcrmin)then - rslope(i,k,2) = rslopesmax - rslopeb(i,k,2) = rslopesbmax - rslope2(i,k,2) = rslopes2max - rslope3(i,k,2) = rslopes3max - else - rslope(i,k,2) = 1./lamdas(qrs(i,k,2),den(i,k),n0sfac(i,k)) - rslopeb(i,k,2) = exp(log(rslope(i,k,2))*(bvts)) - rslope2(i,k,2) = rslope(i,k,2)*rslope(i,k,2) - rslope3(i,k,2) = rslope2(i,k,2)*rslope(i,k,2) - endif -!------------------------------------------------------------- -! Ni: ice crystal number concentraiton [HDC 5c] -!------------------------------------------------------------- -! xni(i,k) = min(max(5.38e7*(den(i,k) & -! *max(qci(i,k,2),qmin))**0.75,1.e3),1.e6) - temp = (den(i,k)*max(qci(i,k,2),qmin)) - temp = sqrt(sqrt(temp*temp*temp)) - xni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) - enddo - enddo -! - mstepmax = 1 - numdt = 1 - do k = kte, kts, -1 - do i = its, ite - work1(i,k,1) = pvtr*rslopeb(i,k,1)*denfac(i,k)/delz(i,k) - work1(i,k,2) = pvts*rslopeb(i,k,2)*denfac(i,k)/delz(i,k) - numdt(i) = max(nint(max(work1(i,k,1),work1(i,k,2))*dtcld+.5),1) - if(numdt(i).ge.mstep(i)) mstep(i) = numdt(i) - enddo - enddo - do i = its, ite - if(mstepmax.le.mstep(i)) mstepmax = mstep(i) - rmstep(i) = 1./mstep(i) - enddo -! - do n = 1, mstepmax - k = kte - do i = its, ite - if(n.le.mstep(i)) then -! falk(i,k,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)/mstep(i) -! falk(i,k,2) = den(i,k)*qrs(i,k,2)*work1(i,k,2)/mstep(i) - falk(i,k,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)*rmstep(i) - falk(i,k,2) = den(i,k)*qrs(i,k,2)*work1(i,k,2)*rmstep(i) - fall(i,k,1) = fall(i,k,1)+falk(i,k,1) - fall(i,k,2) = fall(i,k,2)+falk(i,k,2) -! qrs(i,k,1) = max(qrs(i,k,1)-falk(i,k,1)*dtcld/den(i,k),0.) -! qrs(i,k,2) = max(qrs(i,k,2)-falk(i,k,2)*dtcld/den(i,k),0.) - dtcldden = dtcld/den(i,k) - qrs(i,k,1) = max(qrs(i,k,1)-falk(i,k,1)*dtcldden,0.) - qrs(i,k,2) = max(qrs(i,k,2)-falk(i,k,2)*dtcldden,0.) - endif - enddo - do k = kte-1, kts, -1 - do i = its, ite - if(n.le.mstep(i)) then - falk(i,k,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)*rmstep(i) - falk(i,k,2) = den(i,k)*qrs(i,k,2)*work1(i,k,2)*rmstep(i) - fall(i,k,1) = fall(i,k,1)+falk(i,k,1) - fall(i,k,2) = fall(i,k,2)+falk(i,k,2) - dtcldden = dtcld/den(i,k) - rdelz = 1./delz(i,k) - qrs(i,k,1) = max(qrs(i,k,1)-(falk(i,k,1)-falk(i,k+1,1) & - *delz(i,k+1)*rdelz)*dtcldden,0.) - qrs(i,k,2) = max(qrs(i,k,2)-(falk(i,k,2)-falk(i,k+1,2) & - *delz(i,k+1)*rdelz)*dtcldden,0.) - endif - enddo - enddo - do k = kte, kts, -1 - do i = its, ite - if(n.le.mstep(i)) then - if(t(i,k).gt.t0c.and.qrs(i,k,2).gt.0.) then -!---------------------------------------------------------------- -! psmlt: melting of snow [HL A33] [RH83 A25] -! (T>T0: S->R) -!---------------------------------------------------------------- - xlf = xlf0 -! work2(i,k)= venfac(p(i,k),t(i,k),den(i,k)) - work2(i,k)= (exp(log(((1.496e-6*((t(i,k))*sqrt(t(i,k))) & - /((t(i,k))+120.)/(den(i,k)))/(8.794e-5 & - *exp(log(t(i,k))*(1.81))/p(i,k)))) & - *((.3333333)))/sqrt((1.496e-6*((t(i,k)) & - *sqrt(t(i,k)))/((t(i,k))+120.)/(den(i,k)))) & - *sqrt(sqrt(den0/(den(i,k))))) - coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) -! psmlt(i,k) = xka(t(i,k),den(i,k))/xlf*(t0c-t(i,k))*pi/2. & -! *n0sfac(i,k)*(precs1*rslope2(i,k,2)+precs2 & -! *work2(i,k)*coeres) - psmlt(i,k) = (1.414e3*(1.496e-6*((t(i,k))*sqrt(t(i,k))) & - /((t(i,k))+120.)/(den(i,k)) )*(den(i,k))) & - /xlf*(t0c-t(i,k))*pi/2. & - *n0sfac(i,k)*(precs1*rslope2(i,k,2)+precs2 & - *work2(i,k)*coeres) - psmlt(i,k) = min(max(psmlt(i,k)*dtcld/mstep(i), & - -qrs(i,k,2)/mstep(i)),0.) - qrs(i,k,2) = qrs(i,k,2) + psmlt(i,k) - qrs(i,k,1) = qrs(i,k,1) - psmlt(i,k) - t(i,k) = t(i,k) + xlf/cpm(i,k)*psmlt(i,k) - endif - endif - enddo - enddo - enddo -!--------------------------------------------------------------- -! Vice [ms-1] : fallout of ice crystal [HDC 5a] -!--------------------------------------------------------------- - mstepmax = 1 - mstep = 1 - numdt = 1 - do k = kte, kts, -1 - do i = its, ite - if(qci(i,k,2).le.0.) then - work2c(i,k) = 0. - else - xmi = den(i,k)*qci(i,k,2)/xni(i,k) -! diameter = min(dicon * sqrt(xmi),dimax) - diameter = max(min(dicon * sqrt(xmi),dimax), 1.e-25) - work1c(i,k) = 1.49e4*exp(log(diameter)*(1.31)) - work2c(i,k) = work1c(i,k)/delz(i,k) - endif - numdt(i) = max(nint(work2c(i,k)*dtcld+.5),1) - if(numdt(i).ge.mstep(i)) mstep(i) = numdt(i) - enddo - enddo - do i = its, ite - if(mstepmax.le.mstep(i)) mstepmax = mstep(i) - enddo -! - do n = 1, mstepmax - k = kte - do i = its, ite - if(n.le.mstep(i)) then - falkc(i,k) = den(i,k)*qci(i,k,2)*work2c(i,k)/mstep(i) - holdc = falkc(i,k) - fallc(i,k) = fallc(i,k)+falkc(i,k) - holdci = qci(i,k,2) - qci(i,k,2) = max(qci(i,k,2)-falkc(i,k)*dtcld/den(i,k),0.) - endif - enddo - do k = kte-1, kts, -1 - do i = its, ite - if(n.le.mstep(i)) then - falkc(i,k) = den(i,k)*qci(i,k,2)*work2c(i,k)/mstep(i) - holdc = falkc(i,k) - fallc(i,k) = fallc(i,k)+falkc(i,k) - holdci = qci(i,k,2) - qci(i,k,2) = max(qci(i,k,2)-(falkc(i,k)-falkc(i,k+1) & - *delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) - endif - enddo - enddo - enddo -! -! -!---------------------------------------------------------------- -! rain (unit is mm/sec;kgm-2s-1: /1000*delt ===> m)==> mm for wrf -! - do i = its, ite - fallsum = fall(i,1,1)+fall(i,1,2)+fallc(i,1) - fallsum_qsi = fall(i,1,2)+fallc(i,1) - rainncv(i) = 0. - if(fallsum.gt.0.) then - rainncv(i) = fallsum*delz(i,1)/denr*dtcld*1000. - rain(i) = fallsum*delz(i,1)/denr*dtcld*1000. + rain(i) - endif - IF ( PRESENT (snowncv) .AND. PRESENT (snow)) THEN - snowncv(i,lat) = 0. - if(fallsum_qsi.gt.0.) then - snowncv(i,lat) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. - snow(i,lat) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + snow(i,lat) - endif - ENDIF - sr(i) = 0. - if(fallsum.gt.0.)sr(i)=fallsum_qsi*delz(i,kts)/denr*dtcld*1000. & - /(rainncv(i)+1.e-12) - enddo -! -!--------------------------------------------------------------- -! pimlt: instantaneous melting of cloud ice [HL A47] [RH83 A28] -! (T>T0: I->C) -!--------------------------------------------------------------- - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) - xlf = xls-xl(i,k) - if(supcol.lt.0.) xlf = xlf0 - if(supcol.lt.0.and.qci(i,k,2).gt.0.) then - qci(i,k,1) = qci(i,k,1) + qci(i,k,2) - t(i,k) = t(i,k) - xlf/cpm(i,k)*qci(i,k,2) - qci(i,k,2) = 0. - endif -!--------------------------------------------------------------- -! pihmf: homogeneous freezing of cloud water below -40c [HL A45] -! (T<-40C: C->I) -!--------------------------------------------------------------- - if(supcol.gt.40..and.qci(i,k,1).gt.0.) then - qci(i,k,2) = qci(i,k,2) + qci(i,k,1) - t(i,k) = t(i,k) + xlf/cpm(i,k)*qci(i,k,1) - qci(i,k,1) = 0. - endif -!--------------------------------------------------------------- -! pihtf: heterogeneous freezing of cloud water [HL A44] -! (T0>T>-40C: C->I) -!--------------------------------------------------------------- - if(supcol.gt.0..and.qci(i,k,1).gt.0.) then - supcolt=min(supcol,50.) -! pfrzdtc = min(pfrz1*(exp(pfrz2*supcol)-1.) & -! *den(i,k)/denr/xncr*qci(i,k,1)**2*dtcld,qci(i,k,1)) - pfrzdtc = min(pfrz1*(exp(pfrz2*supcolt)-1.) & - *den(i,k)/denr/xncr*qci(i,k,1)*qci(i,k,1)*dtcld,qci(i,k,1)) - qci(i,k,2) = qci(i,k,2) + pfrzdtc - t(i,k) = t(i,k) + xlf/cpm(i,k)*pfrzdtc - qci(i,k,1) = qci(i,k,1)-pfrzdtc - endif -!--------------------------------------------------------------- -! psfrz: freezing of rain water [HL A20] [LFO 45] -! (TS) -!--------------------------------------------------------------- - if(supcol.gt.0..and.qrs(i,k,1).gt.0.) then - supcolt=min(supcol,50.) -! pfrzdtr = min(20.*pi**2*pfrz1*n0r*denr/den(i,k) & -! *(exp(pfrz2*supcol)-1.)*rslope(i,k,1)**7*dtcld, & -! qrs(i,k,1)) - temp = rslope(i,k,1) - temp = temp*temp*temp*temp*temp*temp*temp - pfrzdtr = min(20.*(pi*pi)*pfrz1*n0r*denr/den(i,k) & - *(exp(pfrz2*supcolt)-1.)*temp*dtcld, & - qrs(i,k,1)) - qrs(i,k,2) = qrs(i,k,2) + pfrzdtr - t(i,k) = t(i,k) + xlf/cpm(i,k)*pfrzdtr - qrs(i,k,1) = qrs(i,k,1)-pfrzdtr - endif - enddo - enddo -! -!---------------------------------------------------------------- -! rsloper: reverse of the slope parameter of the rain(m) -! xka: thermal conductivity of air(jm-1s-1k-1) -! work1: the thermodynamic term in the denominator associated with -! heat conduction and vapor diffusion -! (ry88, y93, h85) -! work2: parameter associated with the ventilation effects(y93) -! - do k = kts, kte - do i = its, ite - if(qrs(i,k,1).le.qcrmin)then - rslope(i,k,1) = rslopermax - rslopeb(i,k,1) = rsloperbmax - rslope2(i,k,1) = rsloper2max - rslope3(i,k,1) = rsloper3max - else -! rslope(i,k,1) = 1./lamdar(qrs(i,k,1),den(i,k)) - rslope(i,k,1) = 1./(sqrt(sqrt(pidn0r/((qrs(i,k,1))*(den(i,k)))))) - rslopeb(i,k,1) = exp(log(rslope(i,k,1))*(bvtr)) - rslope2(i,k,1) = rslope(i,k,1)*rslope(i,k,1) - rslope3(i,k,1) = rslope2(i,k,1)*rslope(i,k,1) - endif - if(qrs(i,k,2).le.qcrmin)then - rslope(i,k,2) = rslopesmax - rslopeb(i,k,2) = rslopesbmax - rslope2(i,k,2) = rslopes2max - rslope3(i,k,2) = rslopes3max - else -! rslope(i,k,2) = 1./lamdas(qrs(i,k,2),den(i,k),n0sfac(i,k)) - rslope(i,k,2) = 1./(sqrt(sqrt(pidn0s*(n0sfac(i,k))/((qrs(i,k,2)) & - *(den(i,k)))))) - rslopeb(i,k,2) = exp(log(rslope(i,k,2))*(bvts)) - rslope2(i,k,2) = rslope(i,k,2)*rslope(i,k,2) - rslope3(i,k,2) = rslope2(i,k,2)*rslope(i,k,2) - endif - enddo - enddo -! - do k = kts, kte - do i = its, ite -! work1(i,k,1) = diffac(xl(i,k),p(i,k),t(i,k),den(i,k),qs(i,k,1)) - work1(i,k,1) = ((((den(i,k))*(xl(i,k))*(xl(i,k)))*((t(i,k))+120.) & - *(den(i,k)))/(1.414e3*(1.496e-6*((t(i,k))*sqrt(t(i,k))))& - *(den(i,k))*(rv*(t(i,k))*(t(i,k))))) & - + p(i,k)/((qs(i,k,1))*(8.794e-5*exp(log(t(i,k))*(1.81)))) -! work1(i,k,2) = diffac(xls,p(i,k),t(i,k),den(i,k),qs(i,k,2)) - work1(i,k,2) = ((((den(i,k))*(xls)*(xls))*((t(i,k))+120.)*(den(i,k)))& - /(1.414e3*(1.496e-6*((t(i,k))*sqrt(t(i,k))))*(den(i,k)) & - *(rv*(t(i,k))*(t(i,k)))) & - + p(i,k)/(qs(i,k,2)*(8.794e-5*exp(log(t(i,k))*(1.81))))) -! work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) - work2(i,k) = (exp(.3333333*log(((1.496e-6 * ((t(i,k))*sqrt(t(i,k)))) & - *p(i,k))/(((t(i,k))+120.)*den(i,k)*(8.794e-5 & - *exp(log(t(i,k))*(1.81))))))*sqrt(sqrt(den0/(den(i,k))))) & - /sqrt((1.496e-6*((t(i,k))*sqrt(t(i,k)))) & - /(((t(i,k))+120.)*den(i,k))) - enddo - enddo -! -!=============================================================== -! -! warm rain processes -! -! - follows the processes in RH83 and LFO except for autoconcersion -! -!=============================================================== -! - do k = kts, kte - do i = its, ite - supsat = max(q(i,k),qmin)-qs(i,k,1) - satdt = supsat/dtcld -!--------------------------------------------------------------- -! praut: auto conversion rate from cloud to rain [HDC 16] -! (C->R) -!--------------------------------------------------------------- - if(qci(i,k,1).gt.qc0) then - praut(i,k) = qck1*exp(log(qci(i,k,1))*((7./3.))) - praut(i,k) = min(praut(i,k),qci(i,k,1)/dtcld) - endif -!--------------------------------------------------------------- -! pracw: accretion of cloud water by rain [HL A40] [LFO 51] -! (C->R) -!--------------------------------------------------------------- - if(qrs(i,k,1).gt.qcrmin.and.qci(i,k,1).gt.qmin) then - pracw(i,k) = min(pacrr*rslope3(i,k,1)*rslopeb(i,k,1) & - *qci(i,k,1)*denfac(i,k),qci(i,k,1)/dtcld) - endif -!--------------------------------------------------------------- -! prevp: evaporation/condensation rate of rain [HDC 14] -! (V->R or R->V) -!--------------------------------------------------------------- - if(qrs(i,k,1).gt.0.) then - coeres = rslope2(i,k,1)*sqrt(rslope(i,k,1)*rslopeb(i,k,1)) - prevp(i,k) = (rh(i,k,1)-1.)*(precr1*rslope2(i,k,1) & - +precr2*work2(i,k)*coeres)/work1(i,k,1) - if(prevp(i,k).lt.0.) then - prevp(i,k) = max(prevp(i,k),-qrs(i,k,1)/dtcld) - prevp(i,k) = max(prevp(i,k),satdt/2) - else - prevp(i,k) = min(prevp(i,k),satdt/2) - endif - endif - enddo - enddo -! -!=============================================================== -! -! cold rain processes -! -! - follows the revised ice microphysics processes in HDC -! - the processes same as in RH83 and RH84 and LFO behave -! following ice crystal hapits defined in HDC, inclduing -! intercept parameter for snow (n0s), ice crystal number -! concentration (ni), ice nuclei number concentration -! (n0i), ice diameter (d) -! -!=============================================================== -! - rdtcld = 1./dtcld - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) - supsat = max(q(i,k),qmin)-qs(i,k,2) - satdt = supsat/dtcld - ifsat = 0 -!------------------------------------------------------------- -! Ni: ice crystal number concentraiton [HDC 5c] -!------------------------------------------------------------- -! xni(i,k) = min(max(5.38e7*(den(i,k) & -! *max(qci(i,k,2),qmin))**0.75,1.e3),1.e6) - temp = (den(i,k)*max(qci(i,k,2),qmin)) - temp = sqrt(sqrt(temp*temp*temp)) - xni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) - eacrs = exp(0.07*(-supcol)) -! - if(supcol.gt.0) then - if(qrs(i,k,2).gt.qcrmin.and.qci(i,k,2).gt.qmin) then - xmi = den(i,k)*qci(i,k,2)/xni(i,k) - diameter = min(dicon * sqrt(xmi),dimax) - vt2i = 1.49e4*diameter**1.31 - vt2s = pvts*rslopeb(i,k,2)*denfac(i,k) -!------------------------------------------------------------- -! psaci: Accretion of cloud ice by rain [HDC 10] -! (TS) -!------------------------------------------------------------- - acrfac = 2.*rslope3(i,k,2)+2.*diameter*rslope2(i,k,2) & - +diameter**2*rslope(i,k,2) - psaci(i,k) = pi*qci(i,k,2)*eacrs*n0s*n0sfac(i,k) & - *abs(vt2s-vt2i)*acrfac/4. - endif - endif -!------------------------------------------------------------- -! psacw: Accretion of cloud water by snow [HL A7] [LFO 24] -! (TS, and T>=T0: C->R) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.qcrmin.and.qci(i,k,1).gt.qmin) then - psacw(i,k) = min(pacrc*n0sfac(i,k)*rslope3(i,k,2) & - *rslopeb(i,k,2)*qci(i,k,1)*denfac(i,k) & -! ,qci(i,k,1)/dtcld) - ,qci(i,k,1)*rdtcld) - endif - if(supcol .gt. 0) then -!------------------------------------------------------------- -! pidep: Deposition/Sublimation rate of ice [HDC 9] -! (TI or I->V) -!------------------------------------------------------------- - if(qci(i,k,2).gt.0.and.ifsat.ne.1) then - xmi = den(i,k)*qci(i,k,2)/xni(i,k) - diameter = dicon * sqrt(xmi) - pidep(i,k) = 4.*diameter*xni(i,k)*(rh(i,k,2)-1.)/work1(i,k,2) - supice = satdt-prevp(i,k) - if(pidep(i,k).lt.0.) then -! pidep(i,k) = max(max(pidep(i,k),satdt/2),supice) -! pidep(i,k) = max(pidep(i,k),-qci(i,k,2)/dtcld) - pidep(i,k) = max(max(pidep(i,k),satdt*.5),supice) - pidep(i,k) = max(pidep(i,k),-qci(i,k,2)*rdtcld) - else -! pidep(i,k) = min(min(pidep(i,k),satdt/2),supice) - pidep(i,k) = min(min(pidep(i,k),satdt*.5),supice) - endif - if(abs(prevp(i,k)+pidep(i,k)).ge.abs(satdt)) ifsat = 1 - endif -!------------------------------------------------------------- -! psdep: deposition/sublimation rate of snow [HDC 14] -! (V->S or S->V) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.0..and.ifsat.ne.1) then - coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) - psdep(i,k) = (rh(i,k,2)-1.)*n0sfac(i,k) & - *(precs1*rslope2(i,k,2)+precs2 & - *work2(i,k)*coeres)/work1(i,k,2) - supice = satdt-prevp(i,k)-pidep(i,k) - if(psdep(i,k).lt.0.) then -! psdep(i,k) = max(psdep(i,k),-qrs(i,k,2)/dtcld) -! psdep(i,k) = max(max(psdep(i,k),satdt/2),supice) - psdep(i,k) = max(psdep(i,k),-qrs(i,k,2)*rdtcld) - psdep(i,k) = max(max(psdep(i,k),satdt*.5),supice) - else -! psdep(i,k) = min(min(psdep(i,k),satdt/2),supice) - psdep(i,k) = min(min(psdep(i,k),satdt*.5),supice) - endif - if(abs(prevp(i,k)+pidep(i,k)+psdep(i,k)).ge.abs(satdt)) & - ifsat = 1 - endif -!------------------------------------------------------------- -! pigen: generation(nucleation) of ice from vapor [HL A50] [HDC 7-8] -! (TI) -!------------------------------------------------------------- - if(supsat.gt.0.and.ifsat.ne.1) then - supice = satdt-prevp(i,k)-pidep(i,k)-psdep(i,k) - xni0 = 1.e3*exp(0.1*supcol) - roqi0 = 4.92e-11*exp(log(xni0)*(1.33)) - pigen(i,k) = max(0.,(roqi0/den(i,k)-max(qci(i,k,2),0.)) & -! /dtcld) - *rdtcld) - pigen(i,k) = min(min(pigen(i,k),satdt),supice) - endif -! -!------------------------------------------------------------- -! psaut: conversion(aggregation) of ice to snow [HDC 12] -! (TS) -!------------------------------------------------------------- - if(qci(i,k,2).gt.0.) then - qimax = roqimax/den(i,k) -! psaut(i,k) = max(0.,(qci(i,k,2)-qimax)/dtcld) - psaut(i,k) = max(0.,(qci(i,k,2)-qimax)*rdtcld) - endif - endif -!------------------------------------------------------------- -! psevp: Evaporation of melting snow [HL A35] [RH83 A27] -! (T>T0: S->V) -!------------------------------------------------------------- - if(supcol.lt.0.) then - if(qrs(i,k,2).gt.0..and.rh(i,k,1).lt.1.) & - psevp(i,k) = psdep(i,k)*work1(i,k,2)/work1(i,k,1) -! psevp(i,k) = min(max(psevp(i,k),-qrs(i,k,2)/dtcld),0.) - psevp(i,k) = min(max(psevp(i,k),-qrs(i,k,2)*rdtcld),0.) - endif - enddo - enddo -! -! -!---------------------------------------------------------------- -! check mass conservation of generation terms and feedback to the -! large scale -! - do k = kts, kte - do i = its, ite - if(t(i,k).le.t0c) then -! -! cloud water -! - value = max(qmin,qci(i,k,1)) - source = (praut(i,k)+pracw(i,k)+psacw(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - psacw(i,k) = psacw(i,k)*factor - endif -! -! cloud ice -! - value = max(qmin,qci(i,k,2)) - source = (psaut(i,k)+psaci(i,k)-pigen(i,k)-pidep(i,k))*dtcld - if (source.gt.value) then - factor = value/source - psaut(i,k) = psaut(i,k)*factor - psaci(i,k) = psaci(i,k)*factor - pigen(i,k) = pigen(i,k)*factor - pidep(i,k) = pidep(i,k)*factor - endif -! -! rain -! -! - value = max(qmin,qrs(i,k,1)) - source = (-praut(i,k)-pracw(i,k)-prevp(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - prevp(i,k) = prevp(i,k)*factor - endif -! -! snow -! - value = max(qmin,qrs(i,k,2)) - source = (-psdep(i,k)-psaut(i,k)-psaci(i,k)-psacw(i,k))*dtcld - if (source.gt.value) then - factor = value/source - psdep(i,k) = psdep(i,k)*factor - psaut(i,k) = psaut(i,k)*factor - psaci(i,k) = psaci(i,k)*factor - psacw(i,k) = psacw(i,k)*factor - endif -! - work2(i,k)=-(prevp(i,k)+psdep(i,k)+pigen(i,k)+pidep(i,k)) -! update - q(i,k) = q(i,k)+work2(i,k)*dtcld - qci(i,k,1) = max(qci(i,k,1)-(praut(i,k)+pracw(i,k) & - +psacw(i,k))*dtcld,0.) - qrs(i,k,1) = max(qrs(i,k,1)+(praut(i,k)+pracw(i,k) & - +prevp(i,k))*dtcld,0.) - qci(i,k,2) = max(qci(i,k,2)-(psaut(i,k)+psaci(i,k) & - -pigen(i,k)-pidep(i,k))*dtcld,0.) - qrs(i,k,2) = max(qrs(i,k,2)+(psdep(i,k)+psaut(i,k) & - +psaci(i,k)+psacw(i,k))*dtcld,0.) - xlf = xls-xl(i,k) - xlwork2 = -xls*(psdep(i,k)+pidep(i,k)+pigen(i,k)) & - -xl(i,k)*prevp(i,k)-xlf*psacw(i,k) - t(i,k) = t(i,k)-xlwork2/cpm(i,k)*dtcld - else -! -! cloud water -! - value = max(qmin,qci(i,k,1)) - source=(praut(i,k)+pracw(i,k)+psacw(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - psacw(i,k) = psacw(i,k)*factor - endif -! -! rain -! - value = max(qmin,qrs(i,k,1)) - source = (-praut(i,k)-pracw(i,k)-prevp(i,k)-psacw(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - prevp(i,k) = prevp(i,k)*factor - psacw(i,k) = psacw(i,k)*factor - endif -! -! snow -! - value = max(qcrmin,qrs(i,k,2)) - source=(-psevp(i,k))*dtcld - if (source.gt.value) then - factor = value/source - psevp(i,k) = psevp(i,k)*factor - endif - work2(i,k)=-(prevp(i,k)+psevp(i,k)) -! update - q(i,k) = q(i,k)+work2(i,k)*dtcld - qci(i,k,1) = max(qci(i,k,1)-(praut(i,k)+pracw(i,k) & - +psacw(i,k))*dtcld,0.) - qrs(i,k,1) = max(qrs(i,k,1)+(praut(i,k)+pracw(i,k) & - +prevp(i,k) +psacw(i,k))*dtcld,0.) - qrs(i,k,2) = max(qrs(i,k,2)+psevp(i,k)*dtcld,0.) - xlf = xls-xl(i,k) - xlwork2 = -xl(i,k)*(prevp(i,k)+psevp(i,k)) - t(i,k) = t(i,k)-xlwork2/cpm(i,k)*dtcld - endif - enddo - enddo -! -! Inline expansion for fpvs -! qs(i,k,1) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) -! qs(i,k,2) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) - hsub = xls - hvap = xlv0 - cvap = cpv - ttp=t0c+0.01 - dldt=cvap-cliq - xa=-dldt/rv - xb=xa+hvap/(rv*ttp) - dldti=cvap-cice - xai=-dldti/rv - xbi=xai+hsub/(rv*ttp) - do k = kts, kte - do i = its, ite - tr=ttp/t(i,k) - logtr = log(tr) - qs(i,k,1)=psat*exp(logtr*(xa)+xb*(1.-tr)) - qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k) - qs(i,k,1)) - qs(i,k,1) = max(qs(i,k,1),qmin) - enddo - enddo -! -!---------------------------------------------------------------- -! pcond: condensational/evaporational rate of cloud water [HL A46] [RH83 A6] -! if there exists additional water vapor condensated/if -! evaporation of cloud water is not enough to remove subsaturation -! - do k = kts, kte - do i = its, ite -! work1(i,k,1) = conden(t(i,k),q(i,k),qs(i,k,1),xl(i,k),cpm(i,k)) - work1(i,k,1) = ((max(q(i,k),qmin)-(qs(i,k,1)))/(1.+(xl(i,k)) & - *(xl(i,k))/(rv*(cpm(i,k)))*(qs(i,k,1)) & - /((t(i,k))*(t(i,k))))) - work2(i,k) = qci(i,k,1)+work1(i,k,1) - pcond(i,k) = min(max(work1(i,k,1)/dtcld,0.),max(q(i,k),0.)/dtcld) - if(qci(i,k,1).gt.0..and.work1(i,k,1).lt.0.) & - pcond(i,k) = max(work1(i,k,1),-qci(i,k,1))/dtcld - q(i,k) = q(i,k)-pcond(i,k)*dtcld - qci(i,k,1) = max(qci(i,k,1)+pcond(i,k)*dtcld,0.) - t(i,k) = t(i,k)+pcond(i,k)*xl(i,k)/cpm(i,k)*dtcld - enddo - enddo -! -! -!---------------------------------------------------------------- -! padding for small values -! - do k = kts, kte - do i = its, ite - if(qci(i,k,1).le.qmin) qci(i,k,1) = 0.0 - if(qci(i,k,2).le.qmin) qci(i,k,2) = 0.0 - enddo - enddo - enddo ! big loops - END SUBROUTINE wsm52d -! ................................................................... - REAL FUNCTION rgmma(x) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -! rgmma function: use infinite product form - REAL :: euler - PARAMETER (euler=0.577215664901532) - REAL :: x, y - INTEGER :: i - if(x.eq.1.)then - rgmma=0. - else - rgmma=x*exp(euler*x) - do i=1,10000 - y=float(i) - rgmma=rgmma*(1.000+x/y)*exp(-x/y) - enddo - rgmma=1./rgmma - endif - END FUNCTION rgmma -! -!-------------------------------------------------------------------------- - REAL FUNCTION fpvs(t,ice,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c) -!-------------------------------------------------------------------------- - IMPLICIT NONE -!-------------------------------------------------------------------------- - REAL t,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c,dldt,xa,xb,dldti, & - xai,xbi,ttp,tr - INTEGER ice -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ttp=t0c+0.01 - dldt=cvap-cliq - xa=-dldt/rv - xb=xa+hvap/(rv*ttp) - dldti=cvap-cice - xai=-dldti/rv - xbi=xai+hsub/(rv*ttp) - tr=ttp/t - if(t.lt.ttp.and.ice.eq.1) then - fpvs=psat*exp(log(tr)*(xai))*exp(xbi*(1.-tr)) - else - fpvs=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END FUNCTION fpvs -!------------------------------------------------------------------- - SUBROUTINE wsm5init(den0,denr,dens,cl,cpv,allowed_to_read) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -!.... constants which may not be tunable - REAL, INTENT(IN) :: den0,denr,dens,cl,cpv - LOGICAL, INTENT(IN) :: allowed_to_read - REAL :: pi -! - pi = 4.*atan(1.) - xlv1 = cl-cpv -! - qc0 = 4./3.*pi*denr*r0**3*xncr/den0 ! 0.419e-3 -- .61e-3 - qck1 = .104*9.8*peaut/(xncr*denr)**(1./3.)/xmyu*den0**(4./3.) ! 7.03 -! - bvtr1 = 1.+bvtr - bvtr2 = 2.5+.5*bvtr - bvtr3 = 3.+bvtr - bvtr4 = 4.+bvtr - g1pbr = rgmma(bvtr1) - g3pbr = rgmma(bvtr3) - g4pbr = rgmma(bvtr4) ! 17.837825 - g5pbro2 = rgmma(bvtr2) ! 1.8273 - pvtr = avtr*g4pbr/6. - eacrr = 1.0 - pacrr = pi*n0r*avtr*g3pbr*.25*eacrr - precr1 = 2.*pi*n0r*.78 - precr2 = 2.*pi*n0r*.31*avtr**.5*g5pbro2 - xmmax = (dimax/dicon)**2 - roqimax = 2.08e22*dimax**8 -! - bvts1 = 1.+bvts - bvts2 = 2.5+.5*bvts - bvts3 = 3.+bvts - bvts4 = 4.+bvts - g1pbs = rgmma(bvts1) !.8875 - g3pbs = rgmma(bvts3) - g4pbs = rgmma(bvts4) ! 12.0786 - g5pbso2 = rgmma(bvts2) - pvts = avts*g4pbs/6. - pacrs = pi*n0s*avts*g3pbs*.25 - precs1 = 4.*n0s*.65 - precs2 = 4.*n0s*.44*avts**.5*g5pbso2 - pidn0r = pi*denr*n0r - pidn0s = pi*dens*n0s - pacrc = pi*n0s*avts*g3pbs*.25*eacrc -! - rslopermax = 1./lamdarmax - rslopesmax = 1./lamdasmax - rsloperbmax = rslopermax ** bvtr - rslopesbmax = rslopesmax ** bvts - rsloper2max = rslopermax * rslopermax - rslopes2max = rslopesmax * rslopesmax - rsloper3max = rsloper2max * rslopermax - rslopes3max = rslopes2max * rslopesmax -! - END SUBROUTINE wsm5init -END MODULE module_mp_wsm5 diff --git a/src/fim/FIMsrc/fim/wrfphys/module_mp_wsm6.F b/src/fim/FIMsrc/fim/wrfphys/module_mp_wsm6.F deleted file mode 100644 index 3047000..0000000 --- a/src/fim/FIMsrc/fim/wrfphys/module_mp_wsm6.F +++ /dev/null @@ -1,1552 +0,0 @@ -#if ( RWORDSIZE == 4 ) -# define VREC vsrec -# define VSQRT vssqrt -#else -# define VREC vrec -# define VSQRT vsqrt -#endif - -MODULE module_mp_wsm6 -! -! - REAL, PARAMETER, PRIVATE :: dtcldcr = 120. ! maximum time step for minor loops - REAL, PARAMETER, PRIVATE :: n0r = 8.e6 ! intercept parameter rain - REAL, PARAMETER, PRIVATE :: n0g = 4.e6 ! intercept parameter graupel - REAL, PARAMETER, PRIVATE :: avtr = 841.9 ! a constant for terminal velocity of rain - REAL, PARAMETER, PRIVATE :: bvtr = 0.8 ! a constant for terminal velocity of rain - REAL, PARAMETER, PRIVATE :: r0 = .8e-5 ! 8 microm in contrast to 10 micro m - REAL, PARAMETER, PRIVATE :: peaut = .55 ! collection efficiency - REAL, PARAMETER, PRIVATE :: xncr = 3.e8 ! maritime cloud in contrast to 3.e8 in tc80 - REAL, PARAMETER, PRIVATE :: xmyu = 1.718e-5 ! the dynamic viscosity kgm-1s-1 - REAL, PARAMETER, PRIVATE :: avts = 11.72 ! a constant for terminal velocity of snow - REAL, PARAMETER, PRIVATE :: bvts = .41 ! a constant for terminal velocity of snow - REAL, PARAMETER, PRIVATE :: avtg = 330. ! a constant for terminal velocity of graupel - REAL, PARAMETER, PRIVATE :: bvtg = 0.8 ! a constant for terminal velocity of graupel - REAL, PARAMETER, PRIVATE :: deng = 500. ! density of graupel - REAL, PARAMETER, PRIVATE :: n0smax = 1.e11 ! maximum n0s (t=-90C unlimited) - REAL, PARAMETER, PRIVATE :: lamdarmax = 8.e4 ! limited maximum value for slope parameter of rain - REAL, PARAMETER, PRIVATE :: lamdasmax = 1.e5 ! limited maximum value for slope parameter of snow - REAL, PARAMETER, PRIVATE :: lamdagmax = 6.e4 ! limited maximum value for slope parameter of graupel - REAL, PARAMETER, PRIVATE :: dicon = 11.9 ! constant for the cloud-ice diamter - REAL, PARAMETER, PRIVATE :: dimax = 500.e-6 ! limited maximum value for the cloud-ice diamter - REAL, PARAMETER, PRIVATE :: n0s = 2.e6 ! temperature dependent intercept parameter snow - REAL, PARAMETER, PRIVATE :: alpha = .12 ! .122 exponen factor for n0s - REAL, PARAMETER, PRIVATE :: pfrz1 = 100. ! constant in Biggs freezing - REAL, PARAMETER, PRIVATE :: pfrz2 = 0.66 ! constant in Biggs freezing - REAL, PARAMETER, PRIVATE :: qcrmin = 1.e-9 ! minimun values for qr, qs, and qg - REAL, PARAMETER, PRIVATE :: eacrc = 1.0 ! Snow/cloud-water collection efficiency - REAL, PARAMETER, PRIVATE :: dens = 100.0 ! Density of snow - REAL, PARAMETER, PRIVATE :: qs0 = 6.e-4 ! threshold amount for aggretion to occur - REAL, SAVE :: & - qc0, qck1,bvtr1,bvtr2,bvtr3,bvtr4,g1pbr, & - g3pbr,g4pbr,g5pbro2,pvtr,eacrr,pacrr, & - bvtr6,g6pbr, & - precr1,precr2,roqimax,bvts1, & - bvts2,bvts3,bvts4,g1pbs,g3pbs,g4pbs, & - g5pbso2,pvts,pacrs,precs1,precs2,pidn0r, & - pidn0s,xlv1,pacrc, & - bvtg1,bvtg2,bvtg3,bvtg4,g1pbg, & - g3pbg,g4pbg,g5pbgo2,pvtg,pacrg, & - precg1,precg2,pidn0g, & - rslopermax,rslopesmax,rslopegmax, & - rsloperbmax,rslopesbmax,rslopegbmax, & - rsloper2max,rslopes2max,rslopeg2max, & - rsloper3max,rslopes3max,rslopeg3max -CONTAINS -!=================================================================== -! - SUBROUTINE wsm6(th, q, qc, qr, qi, qs, qg & - ,den, pii, p, delz & - ,delt,g, cpd, cpv, rd, rv, t0c & - ,ep1, ep2, qmin & - ,XLS, XLV0, XLF0, den0, denr & - ,cliq,cice,psat & - ,rain, rainncv & - ,snow, snowncv & - ,sr & - ,graupel, graupelncv & - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte & - ) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -! -! This code is a 6-class GRAUPEL phase microphyiscs scheme (WSM6) of the WRF -! Single-Moment MicroPhyiscs (WSMMP). The WSMMP assumes that ice nuclei -! number concentration is a function of temperature, and seperate assumption -! is developed, in which ice crystal number concentration is a function -! of ice amount. A theoretical background of the ice-microphysics and related -! processes in the WSMMPs are described in Hong et al. (2004). -! All production terms in the WSM6 scheme are described in Hong and Lim (2006). -! All units are in m.k.s. and source/sink terms in kgkg-1s-1. -! -! WSM6 cloud scheme -! -! Coded by Song-You Hong and Jeong-Ock Jade Lim (Yonsei Univ.) -! Summer 2003 -! -! Implemented by Song-You Hong (Yonsei Univ.) and Jimy Dudhia (NCAR) -! Summer 2004 -! -! Reference) Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev. -! Hong and Lim (HL, 2006) J. Korean Meteor. Soc. -! Dudhia, Hong and Lim (DHL, 2008) J. Meteor. Soc. Japan -! Lin, Farley, Orville (LFO, 1983) J. Appl. Meteor. -! Rutledge, Hobbs (RH83, 1983) J. Atmos. Sci. -! Rutledge, Hobbs (RH84, 1984) J. Atmos. Sci. -! - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & - ims,ime, jms,jme, kms,kme , & - its,ite, jts,jte, kts,kte - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(INOUT) :: & - th, & - q, & - qc, & - qi, & - qr, & - qs, & - qg - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: & - den, & - pii, & - p, & - delz - REAL, INTENT(IN ) :: delt, & - g, & - rd, & - rv, & - t0c, & - den0, & - cpd, & - cpv, & - ep1, & - ep2, & - qmin, & - XLS, & - XLV0, & - XLF0, & - cliq, & - cice, & - psat, & - denr - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(INOUT) :: rain, & - rainncv, & - sr - - REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, & - INTENT(INOUT) :: snow, & - snowncv - - REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, & - INTENT(INOUT) :: graupel, & - graupelncv -! LOCAL VAR - REAL, DIMENSION( its:ite , kts:kte ) :: t - REAL, DIMENSION( its:ite , kts:kte, 2 ) :: qci - REAL, DIMENSION( its:ite , kts:kte, 3 ) :: qrs - INTEGER :: i,j,k -!------------------------------------------------------------------- - DO j=jts,jte - DO k=kts,kte - DO i=its,ite - t(i,k)=th(i,k,j)*pii(i,k,j) - qci(i,k,1) = qc(i,k,j) - qci(i,k,2) = qi(i,k,j) - qrs(i,k,1) = qr(i,k,j) - qrs(i,k,2) = qs(i,k,j) - qrs(i,k,3) = qg(i,k,j) - ENDDO - ENDDO - - ! Sending array starting locations of optional variables may cause - ! troubles, so we explicitly change the call. - - CALL wsm62D(t, q(ims,kms,j), qci, qrs & - ,den(ims,kms,j) & - ,p(ims,kms,j), delz(ims,kms,j) & - ,delt,g, cpd, cpv, rd, rv, t0c & - ,ep1, ep2, qmin & - ,XLS, XLV0, XLF0, den0, denr & - ,cliq,cice,psat & - ,j & - ,rain(ims,j),rainncv(ims,j) & - ,sr(ims,j) & - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte & - ,snow,snowncv & - ,graupel,graupelncv & - ) - - DO K=kts,kte - DO I=its,ite - th(i,k,j)=t(i,k)/pii(i,k,j) - qc(i,k,j) = qci(i,k,1) - qi(i,k,j) = qci(i,k,2) - qr(i,k,j) = qrs(i,k,1) - qs(i,k,j) = qrs(i,k,2) - qg(i,k,j) = qrs(i,k,3) - ENDDO - ENDDO - ENDDO - END SUBROUTINE wsm6 -!=================================================================== -! - SUBROUTINE wsm62D(t, q, qci, qrs, den, p, delz & - ,delt,g, cpd, cpv, rd, rv, t0c & - ,ep1, ep2, qmin & - ,XLS, XLV0, XLF0, den0, denr & - ,cliq,cice,psat & - ,lat & - ,rain,rainncv & - ,sr & - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte & - ,snow,snowncv & - ,graupel,graupelncv & - ) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & - ims,ime, jms,jme, kms,kme , & - its,ite, jts,jte, kts,kte, & - lat - REAL, DIMENSION( its:ite , kts:kte ), & - INTENT(INOUT) :: & - t - REAL, DIMENSION( its:ite , kts:kte, 2 ), & - INTENT(INOUT) :: & - qci - REAL, DIMENSION( its:ite , kts:kte, 3 ), & - INTENT(INOUT) :: & - qrs - REAL, DIMENSION( ims:ime , kms:kme ), & - INTENT(INOUT) :: & - q - REAL, DIMENSION( ims:ime , kms:kme ), & - INTENT(IN ) :: & - den, & - p, & - delz - REAL, INTENT(IN ) :: delt, & - g, & - cpd, & - cpv, & - t0c, & - den0, & - rd, & - rv, & - ep1, & - ep2, & - qmin, & - XLS, & - XLV0, & - XLF0, & - cliq, & - cice, & - psat, & - denr - REAL, DIMENSION( ims:ime ), & - INTENT(INOUT) :: rain, & - rainncv, & - sr - REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, & - INTENT(INOUT) :: snow, & - snowncv - - REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, & - INTENT(INOUT) :: graupel, & - graupelncv -! LOCAL VAR - REAL, DIMENSION( its:ite , kts:kte , 3) :: & - rh, & - qs, & - rslope, & - rslope2, & - rslope3, & - rslopeb, & - falk, & - fall, & - work1 - - REAL, DIMENSION( its:ite , kts:kte ) :: & - fallc, & - falkc, & - work1c, & - work2c, & - worka - - REAL, DIMENSION( its:ite , kts:kte ) :: & - pigen, & - pidep, & - pcond, & - prevp, & - psevp, & - pgevp, & - psdep, & - pgdep, & - praut, & - psaut, & - pgaut, & - piacr, & - pracw, & - praci, & - pracs, & - psacw, & - psaci, & - psacr, & - pgacw, & - pgaci, & - pgacr, & - pgacs, & - paacw, & - psmlt, & - pgmlt, & - pseml, & - pgeml - - REAL, DIMENSION( its:ite , kts:kte ) :: & - qsum, & - xl, & - cpm, & - work2, & - denfac, & - xni, & - n0sfac - INTEGER, DIMENSION( its:ite ) :: mstep, & - numdt - LOGICAL, DIMENSION( its:ite ) :: flgcld - REAL :: pi, & - cpmcal, xlcal, lamdar, lamdas, lamdag, diffus, & - viscos, xka, venfac, conden, diffac, & - x, y, z, a, b, c, d, e, & - qdt, holdrr, holdrs, holdrg, supcol, supcolt, pvt, & - coeres, supsat, dtcld, xmi, eacrs, satdt, & - qimax, diameter, xni0, roqi0, & - fallsum, fallsum_qsi, fallsum_qg, & - vt2i,vt2r,vt2s,vt2g,acrfac,egs,egi, & - xlwork2, factor, source, value, & - xlf, pfrzdtc, pfrzdtr, supice, alpha2, delta2, delta3 - REAL :: vt2ave - REAL :: holdc, holdci - INTEGER :: i, j, k, mstepmax, & - iprt, latd, lond, loop, loops, ifsat, n -! Temporaries used for inlining fpvs function - REAL :: dldti, xb, xai, tr, xbi, xa, hvap, cvap, hsub, dldt, ttp -! variables for optimization - REAL, DIMENSION( its:ite ) :: tvec1 - REAL :: temp -! -!================================================================= -! compute internal functions -! - cpmcal(x) = cpd*(1.-max(x,qmin))+max(x,qmin)*cpv - xlcal(x) = xlv0-xlv1*(x-t0c) -!---------------------------------------------------------------- -! size distributions: (x=mixing ratio, y=air density): -! valid for mixing ratio > 1.e-9 kg/kg. -! -! Optimizatin : A**B => exp(log(A)*(B)) - lamdar(x,y)= sqrt(sqrt(pidn0r/(x*y))) ! (pidn0r/(x*y))**.25 - lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 - lamdag(x,y)= sqrt(sqrt(pidn0g/(x*y))) ! (pidn0g/(x*y))**.25 -! -!---------------------------------------------------------------- -! diffus: diffusion coefficient of the water vapor -! viscos: kinematic viscosity(m2s-1) -! - diffus(x,y) = 8.794e-5 * exp(log(x)*(1.81)) / y ! 8.794e-5*x**1.81/y - viscos(x,y) = 1.496e-6 * (x*sqrt(x)) /(x+120.)/y ! 1.496e-6*x**1.5/(x+120.)/y - xka(x,y) = 1.414e3*viscos(x,y)*y - diffac(a,b,c,d,e) = d*a*a/(xka(c,d)*rv*c*c)+1./(e*diffus(c,b)) - venfac(a,b,c) = exp(log((viscos(b,c)/diffus(b,a)))*((.3333333))) & - /sqrt(viscos(b,c))*sqrt(sqrt(den0/c)) - conden(a,b,c,d,e) = (max(b,qmin)-c)/(1.+d*d/(rv*e)*c/(a*a)) -! - pi = 4. * atan(1.) -! -! -!---------------------------------------------------------------- -! paddint 0 for negative values generated by dynamics -! - do k = kts, kte - do i = its, ite - qci(i,k,1) = max(qci(i,k,1),0.0) - qrs(i,k,1) = max(qrs(i,k,1),0.0) - qci(i,k,2) = max(qci(i,k,2),0.0) - qrs(i,k,2) = max(qrs(i,k,2),0.0) - qrs(i,k,3) = max(qrs(i,k,3),0.0) - enddo - enddo -! -!---------------------------------------------------------------- -! latent heat for phase changes and heat capacity. neglect the -! changes during microphysical process calculation -! emanuel(1994) -! - do k = kts, kte - do i = its, ite - cpm(i,k) = cpmcal(q(i,k)) - xl(i,k) = xlcal(t(i,k)) - enddo - enddo -! -!---------------------------------------------------------------- -! compute the minor time steps. -! - loops = max(nint(delt/dtcldcr),1) - dtcld = delt/loops - if(delt.le.dtcldcr) dtcld = delt -! - do loop = 1,loops -! -!---------------------------------------------------------------- -! initialize the large scale variables -! - do i = its, ite - mstep(i) = 1 - flgcld(i) = .true. - enddo -! -! do k = kts, kte -! do i = its, ite -! denfac(i,k) = sqrt(den0/den(i,k)) -! enddo -! enddo - do k = kts, kte - CALL VREC( tvec1(its), den(its,k), ite-its+1) - do i = its, ite - tvec1(i) = tvec1(i)*den0 - enddo - CALL VSQRT( denfac(its,k), tvec1(its), ite-its+1) - enddo -! -! Inline expansion for fpvs -! qs(i,k,1) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) -! qs(i,k,2) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) - hsub = xls - hvap = xlv0 - cvap = cpv - ttp=t0c+0.01 - dldt=cvap-cliq - xa=-dldt/rv - xb=xa+hvap/(rv*ttp) - dldti=cvap-cice - xai=-dldti/rv - xbi=xai+hsub/(rv*ttp) - do k = kts, kte - do i = its, ite - tr=ttp/t(i,k) - qs(i,k,1)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) - qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k) - qs(i,k,1)) - qs(i,k,1) = max(qs(i,k,1),qmin) - rh(i,k,1) = max(q(i,k) / qs(i,k,1),qmin) - tr=ttp/t(i,k) - if(t(i,k).lt.ttp) then - qs(i,k,2)=psat*exp(log(tr)*(xai))*exp(xbi*(1.-tr)) - else - qs(i,k,2)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) - endif - qs(i,k,2) = ep2 * qs(i,k,2) / (p(i,k) - qs(i,k,2)) - qs(i,k,2) = max(qs(i,k,2),qmin) - rh(i,k,2) = max(q(i,k) / qs(i,k,2),qmin) - enddo - enddo -! -!---------------------------------------------------------------- -! initialize the variables for microphysical physics -! -! - do k = kts, kte - do i = its, ite - prevp(i,k) = 0. - psdep(i,k) = 0. - pgdep(i,k) = 0. - praut(i,k) = 0. - psaut(i,k) = 0. - pgaut(i,k) = 0. - pracw(i,k) = 0. - praci(i,k) = 0. - piacr(i,k) = 0. - psaci(i,k) = 0. - psacw(i,k) = 0. - pracs(i,k) = 0. - psacr(i,k) = 0. - pgacw(i,k) = 0. - paacw(i,k) = 0. - pgaci(i,k) = 0. - pgacr(i,k) = 0. - pgacs(i,k) = 0. - pigen(i,k) = 0. - pidep(i,k) = 0. - pcond(i,k) = 0. - psmlt(i,k) = 0. - pgmlt(i,k) = 0. - pseml(i,k) = 0. - pgeml(i,k) = 0. - psevp(i,k) = 0. - pgevp(i,k) = 0. - falk(i,k,1) = 0. - falk(i,k,2) = 0. - falk(i,k,3) = 0. - fall(i,k,1) = 0. - fall(i,k,2) = 0. - fall(i,k,3) = 0. - fallc(i,k) = 0. - falkc(i,k) = 0. - xni(i,k) = 1.e3 - enddo - enddo -! -!---------------------------------------------------------------- -! compute the fallout term: -! first, vertical terminal velosity for minor loops -! - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) -!--------------------------------------------------------------- -! n0s: Intercept parameter for snow [m-4] [HDC 6] -!--------------------------------------------------------------- - n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) - if(qrs(i,k,1).le.qcrmin)then - rslope(i,k,1) = rslopermax - rslopeb(i,k,1) = rsloperbmax - rslope2(i,k,1) = rsloper2max - rslope3(i,k,1) = rsloper3max - else - rslope(i,k,1) = 1./lamdar(qrs(i,k,1),den(i,k)) - rslopeb(i,k,1) = rslope(i,k,1)**bvtr - rslope2(i,k,1) = rslope(i,k,1)*rslope(i,k,1) - rslope3(i,k,1) = rslope2(i,k,1)*rslope(i,k,1) - endif - if(qrs(i,k,2).le.qcrmin)then - rslope(i,k,2) = rslopesmax - rslopeb(i,k,2) = rslopesbmax - rslope2(i,k,2) = rslopes2max - rslope3(i,k,2) = rslopes3max - else - rslope(i,k,2) = 1./lamdas(qrs(i,k,2),den(i,k),n0sfac(i,k)) - rslopeb(i,k,2) = rslope(i,k,2)**bvts - rslope2(i,k,2) = rslope(i,k,2)*rslope(i,k,2) - rslope3(i,k,2) = rslope2(i,k,2)*rslope(i,k,2) - endif - if(qrs(i,k,3).le.qcrmin)then - rslope(i,k,3) = rslopegmax - rslopeb(i,k,3) = rslopegbmax - rslope2(i,k,3) = rslopeg2max - rslope3(i,k,3) = rslopeg3max - else - rslope(i,k,3) = 1./lamdag(qrs(i,k,3),den(i,k)) - rslopeb(i,k,3) = rslope(i,k,3)**bvtg - rslope2(i,k,3) = rslope(i,k,3)*rslope(i,k,3) - rslope3(i,k,3) = rslope2(i,k,3)*rslope(i,k,3) - endif -!------------------------------------------------------------- -! Ni: ice crystal number concentraiton [HDC 5c] -!------------------------------------------------------------- -! xni(i,k) = min(max(5.38e7*(den(i,k) & -! *max(qci(i,k,2),qmin))**0.75,1.e3),1.e6) - temp = (den(i,k)*max(qci(i,k,2),qmin)) - temp = sqrt(sqrt(temp*temp*temp)) - xni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) - enddo - enddo -! - mstepmax = 1 - numdt = 1 - do k = kte, kts, -1 - do i = its, ite - work1(i,k,1) = pvtr*rslopeb(i,k,1)*denfac(i,k)/delz(i,k) - work1(i,k,2) = pvts*rslopeb(i,k,2)*denfac(i,k)/delz(i,k) - work1(i,k,3) = pvtg*rslopeb(i,k,3)*denfac(i,k)/delz(i,k) - qsum(i,k) = max( (qrs(i,k,2)+qrs(i,k,3)), 1.E-15) - IF ( qsum(i,k) .gt. 1.e-15 ) THEN - worka(i,k) = (work1(i,k,2)*qrs(i,k,2) + work1(i,k,3)*qrs(i,k,3)) & - /qsum(i,k) - ELSE - worka(i,k) = 0. - ENDIF - numdt(i) = max(nint(max(work1(i,k,1),worka(i,k)) & - *dtcld+.5),1) - if(numdt(i).ge.mstep(i)) mstep(i) = numdt(i) - enddo - enddo - do i = its, ite - if(mstepmax.le.mstep(i)) mstepmax = mstep(i) - enddo -! - do n = 1, mstepmax - k = kte - do i = its, ite - if(n.le.mstep(i)) then - falk(i,k,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)/mstep(i) - falk(i,k,2) = den(i,k)*qrs(i,k,2)*worka(i,k)/mstep(i) - falk(i,k,3) = den(i,k)*qrs(i,k,3)*worka(i,k)/mstep(i) - fall(i,k,1) = fall(i,k,1)+falk(i,k,1) - fall(i,k,2) = fall(i,k,2)+falk(i,k,2) - fall(i,k,3) = fall(i,k,3)+falk(i,k,3) - qrs(i,k,1) = max(qrs(i,k,1)-falk(i,k,1)*dtcld/den(i,k),0.) - qrs(i,k,2) = max(qrs(i,k,2)-falk(i,k,2)*dtcld/den(i,k),0.) - qrs(i,k,3) = max(qrs(i,k,3)-falk(i,k,3)*dtcld/den(i,k),0.) - endif - enddo - do k = kte-1, kts, -1 - do i = its, ite - if(n.le.mstep(i)) then - falk(i,k,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)/mstep(i) - falk(i,k,2) = den(i,k)*qrs(i,k,2)*worka(i,k)/mstep(i) - falk(i,k,3) = den(i,k)*qrs(i,k,3)*worka(i,k)/mstep(i) - fall(i,k,1) = fall(i,k,1)+falk(i,k,1) - fall(i,k,2) = fall(i,k,2)+falk(i,k,2) - fall(i,k,3) = fall(i,k,3)+falk(i,k,3) - qrs(i,k,1) = max(qrs(i,k,1)-(falk(i,k,1)-falk(i,k+1,1) & - *delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) - qrs(i,k,2) = max(qrs(i,k,2)-(falk(i,k,2)-falk(i,k+1,2) & - *delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) - qrs(i,k,3) = max(qrs(i,k,3)-(falk(i,k,3)-falk(i,k+1,3) & - *delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) - endif - enddo - enddo - do k = kte, kts, -1 - do i = its, ite - if(n.le.mstep(i).and.t(i,k).gt.t0c) then -!--------------------------------------------------------------- -! psmlt: melting of snow [HL A33] [RH83 A25] -! (T>T0: S->R) -!--------------------------------------------------------------- - xlf = xlf0 - work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) - if(qrs(i,k,2).gt.0.) then - coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) - psmlt(i,k) = xka(t(i,k),den(i,k))/xlf*(t0c-t(i,k))*pi/2. & - *n0sfac(i,k)*(precs1*rslope2(i,k,2) & - +precs2*work2(i,k)*coeres) - psmlt(i,k) = min(max(psmlt(i,k)*dtcld/mstep(i), & - -qrs(i,k,2)/mstep(i)),0.) - qrs(i,k,2) = qrs(i,k,2) + psmlt(i,k) - qrs(i,k,1) = qrs(i,k,1) - psmlt(i,k) - t(i,k) = t(i,k) + xlf/cpm(i,k)*psmlt(i,k) - endif -!--------------------------------------------------------------- -! pgmlt: melting of graupel [HL A23] [LFO 47] -! (T>T0: G->R) -!--------------------------------------------------------------- - if(qrs(i,k,3).gt.0.) then - coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) - pgmlt(i,k) = xka(t(i,k),den(i,k))/xlf & - *(t0c-t(i,k))*(precg1*rslope2(i,k,3) & - +precg2*work2(i,k)*coeres) - pgmlt(i,k) = min(max(pgmlt(i,k)*dtcld/mstep(i), & - -qrs(i,k,3)/mstep(i)),0.) - qrs(i,k,3) = qrs(i,k,3) + pgmlt(i,k) - qrs(i,k,1) = qrs(i,k,1) - pgmlt(i,k) - t(i,k) = t(i,k) + xlf/cpm(i,k)*pgmlt(i,k) - endif - endif - enddo - enddo - enddo -!--------------------------------------------------------------- -! Vice [ms-1] : fallout of ice crystal [HDC 5a] -!--------------------------------------------------------------- - mstepmax = 1 - mstep = 1 - numdt = 1 - do k = kte, kts, -1 - do i = its, ite - if(qci(i,k,2).le.0.) then - work2c(i,k) = 0. - else - xmi = den(i,k)*qci(i,k,2)/xni(i,k) -! diameter = min(dicon * sqrt(xmi),dimax) - diameter = max(min(dicon * sqrt(xmi),dimax), 1.e-25) - work1c(i,k) = 1.49e4*diameter**1.31 - work2c(i,k) = work1c(i,k)/delz(i,k) - endif - numdt(i) = max(nint(work2c(i,k)*dtcld+.5),1) - if(numdt(i).ge.mstep(i)) mstep(i) = numdt(i) - enddo - enddo - do i = its, ite - if(mstepmax.le.mstep(i)) mstepmax = mstep(i) - enddo -! - do n = 1, mstepmax - k = kte - do i = its, ite - if(n.le.mstep(i)) then - falkc(i,k) = den(i,k)*qci(i,k,2)*work2c(i,k)/mstep(i) - holdc = falkc(i,k) - fallc(i,k) = fallc(i,k)+falkc(i,k) - holdci = qci(i,k,2) - qci(i,k,2) = max(qci(i,k,2)-falkc(i,k)*dtcld/den(i,k),0.) - endif - enddo - do k = kte-1, kts, -1 - do i = its, ite - if(n.le.mstep(i)) then - falkc(i,k) = den(i,k)*qci(i,k,2)*work2c(i,k)/mstep(i) - holdc = falkc(i,k) - fallc(i,k) = fallc(i,k)+falkc(i,k) - holdci = qci(i,k,2) - qci(i,k,2) = max(qci(i,k,2)-(falkc(i,k)-falkc(i,k+1) & - *delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) - endif - enddo - enddo - enddo -! -!---------------------------------------------------------------- -! rain (unit is mm/sec;kgm-2s-1: /1000*delt ===> m)==> mm for wrf -! - do i = its, ite - fallsum = fall(i,kts,1)+fall(i,kts,2)+fall(i,kts,3)+fallc(i,kts) - fallsum_qsi = fall(i,kts,2)+fallc(i,kts) - fallsum_qg = fall(i,kts,3) - rainncv(i) = 0. - if(fallsum.gt.0.) then - rainncv(i) = fallsum*delz(i,kts)/denr*dtcld*1000. - rain(i) = fallsum*delz(i,kts)/denr*dtcld*1000. + rain(i) - endif - IF ( PRESENT (snowncv) .AND. PRESENT (snow)) THEN - snowncv(i,lat) = 0. - if(fallsum_qsi.gt.0.) then - snowncv(i,lat) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. - snow(i,lat) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + snow(i,lat) - endif - ENDIF - IF ( PRESENT (graupelncv) .AND. PRESENT (graupel)) THEN - graupelncv(i,lat) = 0. - if(fallsum_qg.gt.0.) then - graupelncv(i,lat) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. - graupel(i,lat) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. + graupel(i,lat) - endif - ENDIF - sr(i) = 0. - if(fallsum.gt.0.)sr(i)=(fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + & - fallsum_qg*delz(i,kts)/denr*dtcld*1000.) & - /(rainncv(i)+1.e-12) - enddo -! -!--------------------------------------------------------------- -! pimlt: instantaneous melting of cloud ice [HL A47] [RH83 A28] -! (T>T0: I->C) -!--------------------------------------------------------------- - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) - xlf = xls-xl(i,k) - if(supcol.lt.0.) xlf = xlf0 - if(supcol.lt.0.and.qci(i,k,2).gt.0.) then - qci(i,k,1) = qci(i,k,1) + qci(i,k,2) - t(i,k) = t(i,k) - xlf/cpm(i,k)*qci(i,k,2) - qci(i,k,2) = 0. - endif -!--------------------------------------------------------------- -! pihmf: homogeneous freezing of cloud water below -40c [HL A45] -! (T<-40C: C->I) -!--------------------------------------------------------------- - if(supcol.gt.40..and.qci(i,k,1).gt.0.) then - qci(i,k,2) = qci(i,k,2) + qci(i,k,1) - t(i,k) = t(i,k) + xlf/cpm(i,k)*qci(i,k,1) - qci(i,k,1) = 0. - endif -!--------------------------------------------------------------- -! pihtf: heterogeneous freezing of cloud water [HL A44] -! (T0>T>-40C: C->I) -!--------------------------------------------------------------- - if(supcol.gt.0..and.qci(i,k,1).gt.qmin) then -! pfrzdtc = min(pfrz1*(exp(pfrz2*supcol)-1.) & -! *den(i,k)/denr/xncr*qci(i,k,1)**2*dtcld,qci(i,k,1)) - supcolt=min(supcol,50.) - pfrzdtc = min(pfrz1*(exp(pfrz2*supcolt)-1.) & - *den(i,k)/denr/xncr*qci(i,k,1)*qci(i,k,1)*dtcld,qci(i,k,1)) - qci(i,k,2) = qci(i,k,2) + pfrzdtc - t(i,k) = t(i,k) + xlf/cpm(i,k)*pfrzdtc - qci(i,k,1) = qci(i,k,1)-pfrzdtc - endif -!--------------------------------------------------------------- -! pgfrz: freezing of rain water [HL A20] [LFO 45] -! (TG) -!--------------------------------------------------------------- - if(supcol.gt.0..and.qrs(i,k,1).gt.0.) then -! pfrzdtr = min(20.*pi**2*pfrz1*n0r*denr/den(i,k) & -! *(exp(pfrz2*supcol)-1.)*rslope3(i,k,1)**2 & -! *rslope(i,k,1)*dtcld,qrs(i,k,1)) - temp = rslope3(i,k,1) - temp = temp*temp*rslope(i,k,1) - supcolt=min(supcol,50.) - pfrzdtr = min(20.*(pi*pi)*pfrz1*n0r*denr/den(i,k) & - *(exp(pfrz2*supcolt)-1.)*temp*dtcld, & - qrs(i,k,1)) - qrs(i,k,3) = qrs(i,k,3) + pfrzdtr - t(i,k) = t(i,k) + xlf/cpm(i,k)*pfrzdtr - qrs(i,k,1) = qrs(i,k,1)-pfrzdtr - endif - enddo - enddo -! -! -!---------------------------------------------------------------- -! rsloper: reverse of the slope parameter of the rain(m) -! xka: thermal conductivity of air(jm-1s-1k-1) -! work1: the thermodynamic term in the denominator associated with -! heat conduction and vapor diffusion -! (ry88, y93, h85) -! work2: parameter associated with the ventilation effects(y93) -! - do k = kts, kte - do i = its, ite - if(qrs(i,k,1).le.qcrmin)then - rslope(i,k,1) = rslopermax - rslopeb(i,k,1) = rsloperbmax - rslope2(i,k,1) = rsloper2max - rslope3(i,k,1) = rsloper3max - else - rslope(i,k,1) = 1./lamdar(qrs(i,k,1),den(i,k)) - rslopeb(i,k,1) = rslope(i,k,1)**bvtr - rslope2(i,k,1) = rslope(i,k,1)*rslope(i,k,1) - rslope3(i,k,1) = rslope2(i,k,1)*rslope(i,k,1) - endif - if(qrs(i,k,2).le.qcrmin)then - rslope(i,k,2) = rslopesmax - rslopeb(i,k,2) = rslopesbmax - rslope2(i,k,2) = rslopes2max - rslope3(i,k,2) = rslopes3max - else - rslope(i,k,2) = 1./lamdas(qrs(i,k,2),den(i,k),n0sfac(i,k)) - rslopeb(i,k,2) = rslope(i,k,2)**bvts - rslope2(i,k,2) = rslope(i,k,2)*rslope(i,k,2) - rslope3(i,k,2) = rslope2(i,k,2)*rslope(i,k,2) - endif - if(qrs(i,k,3).le.qcrmin)then - rslope(i,k,3) = rslopegmax - rslopeb(i,k,3) = rslopegbmax - rslope2(i,k,3) = rslopeg2max - rslope3(i,k,3) = rslopeg3max - else - rslope(i,k,3) = 1./lamdag(qrs(i,k,3),den(i,k)) - rslopeb(i,k,3) = rslope(i,k,3)**bvtg - rslope2(i,k,3) = rslope(i,k,3)*rslope(i,k,3) - rslope3(i,k,3) = rslope2(i,k,3)*rslope(i,k,3) - endif - enddo - enddo -! - do k = kts, kte - do i = its, ite - work1(i,k,1) = diffac(xl(i,k),p(i,k),t(i,k),den(i,k),qs(i,k,1)) - work1(i,k,2) = diffac(xls,p(i,k),t(i,k),den(i,k),qs(i,k,2)) - work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) - enddo - enddo -! -!=============================================================== -! -! warm rain processes -! -! - follows the processes in RH83 and LFO except for autoconcersion -! -!=============================================================== -! - do k = kts, kte - do i = its, ite - supsat = max(q(i,k),qmin)-qs(i,k,1) - satdt = supsat/dtcld -!--------------------------------------------------------------- -! praut: auto conversion rate from cloud to rain [HDC 16] -! (C->R) -!--------------------------------------------------------------- - if(qci(i,k,1).gt.qc0) then - praut(i,k) = qck1*qci(i,k,1)**(7./3.) - praut(i,k) = min(praut(i,k),qci(i,k,1)/dtcld) - endif -!--------------------------------------------------------------- -! pracw: accretion of cloud water by rain [HL A40] [LFO 51] -! (C->R) -!--------------------------------------------------------------- - if(qrs(i,k,1).gt.qcrmin.and.qci(i,k,1).gt.qmin) then - pracw(i,k) = min(pacrr*rslope3(i,k,1)*rslopeb(i,k,1) & - *qci(i,k,1)*denfac(i,k),qci(i,k,1)/dtcld) - endif -!--------------------------------------------------------------- -! prevp: evaporation/condensation rate of rain [HDC 14] -! (V->R or R->V) -!--------------------------------------------------------------- - if(qrs(i,k,1).gt.0.) then - coeres = rslope2(i,k,1)*sqrt(rslope(i,k,1)*rslopeb(i,k,1)) - prevp(i,k) = (rh(i,k,1)-1.)*(precr1*rslope2(i,k,1) & - +precr2*work2(i,k)*coeres)/work1(i,k,1) - if(prevp(i,k).lt.0.) then - prevp(i,k) = max(prevp(i,k),-qrs(i,k,1)/dtcld) - prevp(i,k) = max(prevp(i,k),satdt/2) - else - prevp(i,k) = min(prevp(i,k),satdt/2) - endif - endif - enddo - enddo -! -!=============================================================== -! -! cold rain processes -! -! - follows the revised ice microphysics processes in HDC -! - the processes same as in RH83 and RH84 and LFO behave -! following ice crystal hapits defined in HDC, inclduing -! intercept parameter for snow (n0s), ice crystal number -! concentration (ni), ice nuclei number concentration -! (n0i), ice diameter (d) -! -!=============================================================== -! - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) - supsat = max(q(i,k),qmin)-qs(i,k,2) - satdt = supsat/dtcld - ifsat = 0 -!------------------------------------------------------------- -! Ni: ice crystal number concentraiton [HDC 5c] -!------------------------------------------------------------- -! xni(i,k) = min(max(5.38e7*(den(i,k) & -! *max(qci(i,k,2),qmin))**0.75,1.e3),1.e6) - temp = (den(i,k)*max(qci(i,k,2),qmin)) - temp = sqrt(sqrt(temp*temp*temp)) - xni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) - eacrs = exp(0.07*(-supcol)) -! - xmi = den(i,k)*qci(i,k,2)/xni(i,k) - diameter = min(dicon * sqrt(xmi),dimax) - vt2i = 1.49e4*diameter**1.31 - vt2r=pvtr*rslopeb(i,k,1)*denfac(i,k) - vt2s=pvts*rslopeb(i,k,2)*denfac(i,k) - vt2g=pvtg*rslopeb(i,k,3)*denfac(i,k) - qsum(i,k) = max( (qrs(i,k,2)+qrs(i,k,3)), 1.E-15) - if(qsum(i,k) .gt. 1.e-15) then - vt2ave=(vt2s*qrs(i,k,2)+vt2g*qrs(i,k,3))/(qsum(i,k)) - else - vt2ave=0. - endif - if(supcol.gt.0.and.qci(i,k,2).gt.qmin) then - if(qrs(i,k,1).gt.qcrmin) then -!------------------------------------------------------------- -! praci: Accretion of cloud ice by rain [HL A15] [LFO 25] -! (TR) -!------------------------------------------------------------- - acrfac = 2.*rslope3(i,k,1)+2.*diameter*rslope2(i,k,1) & - +diameter**2*rslope(i,k,1) - praci(i,k) = pi*qci(i,k,2)*n0r*abs(vt2r-vt2i)*acrfac/4. - praci(i,k) = min(praci(i,k),qci(i,k,2)/dtcld) -!------------------------------------------------------------- -! piacr: Accretion of rain by cloud ice [HL A19] [LFO 26] -! (TS or R->G) -!------------------------------------------------------------- - piacr(i,k) = pi**2*avtr*n0r*denr*xni(i,k)*denfac(i,k) & - *g6pbr*rslope3(i,k,1)*rslope3(i,k,1) & - *rslopeb(i,k,1)/24./den(i,k) - piacr(i,k) = min(piacr(i,k),qrs(i,k,1)/dtcld) - endif -!------------------------------------------------------------- -! psaci: Accretion of cloud ice by snow [HDC 10] -! (TS) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.qcrmin) then - acrfac = 2.*rslope3(i,k,2)+2.*diameter*rslope2(i,k,2) & - +diameter**2*rslope(i,k,2) - psaci(i,k) = pi*qci(i,k,2)*eacrs*n0s*n0sfac(i,k) & - *abs(vt2ave-vt2i)*acrfac/4. - psaci(i,k) = min(psaci(i,k),qci(i,k,2)/dtcld) - endif -!------------------------------------------------------------- -! pgaci: Accretion of cloud ice by graupel [HL A17] [LFO 41] -! (TG) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.qcrmin) then - egi = exp(0.07*(-supcol)) - acrfac = 2.*rslope3(i,k,3)+2.*diameter*rslope2(i,k,3) & - +diameter**2*rslope(i,k,3) - pgaci(i,k) = pi*egi*qci(i,k,2)*n0g*abs(vt2ave-vt2i)*acrfac/4. - pgaci(i,k) = min(pgaci(i,k),qci(i,k,2)/dtcld) - endif - endif -!------------------------------------------------------------- -! psacw: Accretion of cloud water by snow [HL A7] [LFO 24] -! (TS, and T>=T0: C->R) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.qcrmin.and.qci(i,k,1).gt.qmin) then - psacw(i,k) = min(pacrc*n0sfac(i,k)*rslope3(i,k,2)*rslopeb(i,k,2) & - *qci(i,k,1)*denfac(i,k),qci(i,k,1)/dtcld) - endif -!------------------------------------------------------------- -! pgacw: Accretion of cloud water by graupel [HL A6] [LFO 40] -! (TG, and T>=T0: C->R) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.qcrmin.and.qci(i,k,1).gt.qmin) then - pgacw(i,k) = min(pacrg*rslope3(i,k,3)*rslopeb(i,k,3) & - *qci(i,k,1)*denfac(i,k),qci(i,k,1)/dtcld) - endif -!------------------------------------------------------------- -! paacw: Accretion of cloud water by averaged snow/graupel -! (TG or S, and T>=T0: C->R) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.qcrmin.and.qrs(i,k,3).gt.qcrmin) then - paacw(i,k) = (qrs(i,k,2)*psacw(i,k)+qrs(i,k,3)*pgacw(i,k)) & - /(qsum(i,k)) - endif -!------------------------------------------------------------- -! pracs: Accretion of snow by rain [HL A11] [LFO 27] -! (TG) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.qcrmin.and.qrs(i,k,1).gt.qcrmin) then - if(supcol.gt.0) then - acrfac = 5.*rslope3(i,k,2)*rslope3(i,k,2)*rslope(i,k,1) & - +2.*rslope3(i,k,2)*rslope2(i,k,2)*rslope2(i,k,1) & - +.5*rslope2(i,k,2)*rslope2(i,k,2)*rslope3(i,k,1) - pracs(i,k) = pi**2*n0r*n0s*n0sfac(i,k)*abs(vt2r-vt2ave) & - *(dens/den(i,k))*acrfac - pracs(i,k) = min(pracs(i,k),qrs(i,k,2)/dtcld) - endif -!------------------------------------------------------------- -! psacr: Accretion of rain by snow [HL A10] [LFO 28] -! (TS or R->G) (T>=T0: enhance melting of snow) -!------------------------------------------------------------- - acrfac = 5.*rslope3(i,k,1)*rslope3(i,k,1)*rslope(i,k,2) & - +2.*rslope3(i,k,1)*rslope2(i,k,1)*rslope2(i,k,2) & - +.5*rslope2(i,k,1)*rslope2(i,k,1)*rslope3(i,k,2) - psacr(i,k) = pi**2*n0r*n0s*n0sfac(i,k)*abs(vt2ave-vt2r) & - *(denr/den(i,k))*acrfac - psacr(i,k) = min(psacr(i,k),qrs(i,k,1)/dtcld) - endif -!------------------------------------------------------------- -! pgacr: Accretion of rain by graupel [HL A12] [LFO 42] -! (TG) (T>=T0: enhance melting of graupel) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.qcrmin.and.qrs(i,k,1).gt.qcrmin) then - acrfac = 5.*rslope3(i,k,1)*rslope3(i,k,1)*rslope(i,k,3) & - +2.*rslope3(i,k,1)*rslope2(i,k,1)*rslope2(i,k,3) & - +.5*rslope2(i,k,1)*rslope2(i,k,1)*rslope3(i,k,3) - pgacr(i,k) = pi**2*n0r*n0g*abs(vt2ave-vt2r)*(denr/den(i,k)) & - *acrfac - pgacr(i,k) = min(pgacr(i,k),qrs(i,k,1)/dtcld) - endif -! -!------------------------------------------------------------- -! pgacs: Accretion of snow by graupel [HL A13] [LFO 29] -! (S->G): This process is eliminated in V3.0 with the -! new combined snow/graupel fall speeds -!------------------------------------------------------------- - if(qrs(i,k,3).gt.qcrmin.and.qrs(i,k,2).gt.qcrmin) then - pgacs(i,k) = 0. - endif - if(supcol.le.0) then - xlf = xlf0 -!------------------------------------------------------------- -! pseml: Enhanced melting of snow by accretion of water [HL A34] -! (T>=T0: S->R) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.0.) & - pseml(i,k) = min(max(cliq*supcol*(paacw(i,k)+psacr(i,k)) & - /xlf,-qrs(i,k,2)/dtcld),0.) -!------------------------------------------------------------- -! pgeml: Enhanced melting of graupel by accretion of water [HL A24] [RH84 A21-A22] -! (T>=T0: G->R) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.0.) & - pgeml(i,k) = min(max(cliq*supcol*(paacw(i,k)+pgacr(i,k)) & - /xlf,-qrs(i,k,3)/dtcld),0.) - endif - if(supcol.gt.0) then -!------------------------------------------------------------- -! pidep: Deposition/Sublimation rate of ice [HDC 9] -! (TI or I->V) -!------------------------------------------------------------- - if(qci(i,k,2).gt.0.and.ifsat.ne.1) then - pidep(i,k) = 4.*diameter*xni(i,k)*(rh(i,k,2)-1.)/work1(i,k,2) - supice = satdt-prevp(i,k) - if(pidep(i,k).lt.0.) then - pidep(i,k) = max(max(pidep(i,k),satdt/2),supice) - pidep(i,k) = max(pidep(i,k),-qci(i,k,2)/dtcld) - else - pidep(i,k) = min(min(pidep(i,k),satdt/2),supice) - endif - if(abs(prevp(i,k)+pidep(i,k)).ge.abs(satdt)) ifsat = 1 - endif -!------------------------------------------------------------- -! psdep: deposition/sublimation rate of snow [HDC 14] -! (TS or S->V) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.0..and.ifsat.ne.1) then - coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) - psdep(i,k) = (rh(i,k,2)-1.)*n0sfac(i,k)*(precs1*rslope2(i,k,2) & - + precs2*work2(i,k)*coeres)/work1(i,k,2) - supice = satdt-prevp(i,k)-pidep(i,k) - if(psdep(i,k).lt.0.) then - psdep(i,k) = max(psdep(i,k),-qrs(i,k,2)/dtcld) - psdep(i,k) = max(max(psdep(i,k),satdt/2),supice) - else - psdep(i,k) = min(min(psdep(i,k),satdt/2),supice) - endif - if(abs(prevp(i,k)+pidep(i,k)+psdep(i,k)).ge.abs(satdt)) & - ifsat = 1 - endif -!------------------------------------------------------------- -! pgdep: deposition/sublimation rate of graupel [HL A21] [LFO 46] -! (TG or G->V) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.0..and.ifsat.ne.1) then - coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) - pgdep(i,k) = (rh(i,k,2)-1.)*(precg1*rslope2(i,k,3) & - +precg2*work2(i,k)*coeres)/work1(i,k,2) - supice = satdt-prevp(i,k)-pidep(i,k)-psdep(i,k) - if(pgdep(i,k).lt.0.) then - pgdep(i,k) = max(pgdep(i,k),-qrs(i,k,3)/dtcld) - pgdep(i,k) = max(max(pgdep(i,k),satdt/2),supice) - else - pgdep(i,k) = min(min(pgdep(i,k),satdt/2),supice) - endif - if(abs(prevp(i,k)+pidep(i,k)+psdep(i,k)+pgdep(i,k)).ge. & - abs(satdt)) ifsat = 1 - endif -!------------------------------------------------------------- -! pigen: generation(nucleation) of ice from vapor [HL 50] [HDC 7-8] -! (TI) -!------------------------------------------------------------- - if(supsat.gt.0.and.ifsat.ne.1) then - supice = satdt-prevp(i,k)-pidep(i,k)-psdep(i,k)-pgdep(i,k) - xni0 = 1.e3*exp(0.1*supcol) - roqi0 = 4.92e-11*xni0**1.33 - pigen(i,k) = max(0.,(roqi0/den(i,k)-max(qci(i,k,2),0.))/dtcld) - pigen(i,k) = min(min(pigen(i,k),satdt),supice) - endif -! -!------------------------------------------------------------- -! psaut: conversion(aggregation) of ice to snow [HDC 12] -! (TS) -!------------------------------------------------------------- - if(qci(i,k,2).gt.0.) then - qimax = roqimax/den(i,k) - psaut(i,k) = max(0.,(qci(i,k,2)-qimax)/dtcld) - endif -! -!------------------------------------------------------------- -! pgaut: conversion(aggregation) of snow to graupel [HL A4] [LFO 37] -! (TG) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.0.) then - alpha2 = 1.e-3*exp(0.09*(-supcol)) - pgaut(i,k) = min(max(0.,alpha2*(qrs(i,k,2)-qs0)),qrs(i,k,2)/dtcld) - endif - endif -! -!------------------------------------------------------------- -! psevp: Evaporation of melting snow [HL A35] [RH83 A27] -! (T>=T0: S->V) -!------------------------------------------------------------- - if(supcol.lt.0.) then - if(qrs(i,k,2).gt.0..and.rh(i,k,1).lt.1.) then - coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) - psevp(i,k) = (rh(i,k,1)-1.)*n0sfac(i,k)*(precs1 & - *rslope2(i,k,2)+precs2*work2(i,k) & - *coeres)/work1(i,k,1) - psevp(i,k) = min(max(psevp(i,k),-qrs(i,k,2)/dtcld),0.) - endif -!------------------------------------------------------------- -! pgevp: Evaporation of melting graupel [HL A25] [RH84 A19] -! (T>=T0: G->V) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.0..and.rh(i,k,1).lt.1.) then - coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) - pgevp(i,k) = (rh(i,k,1)-1.)*(precg1*rslope2(i,k,3) & - +precg2*work2(i,k)*coeres)/work1(i,k,1) - pgevp(i,k) = min(max(pgevp(i,k),-qrs(i,k,3)/dtcld),0.) - endif - endif - enddo - enddo -! -! -!---------------------------------------------------------------- -! check mass conservation of generation terms and feedback to the -! large scale -! - do k = kts, kte - do i = its, ite -! - delta2=0. - delta3=0. - if(qrs(i,k,1).lt.1.e-4.and.qrs(i,k,2).lt.1.e-4) delta2=1. - if(qrs(i,k,1).lt.1.e-4) delta3=1. - if(t(i,k).le.t0c) then -! -! cloud water -! - value = max(qmin,qci(i,k,1)) - source = (praut(i,k)+pracw(i,k)+paacw(i,k)+paacw(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - endif -! -! cloud ice -! - value = max(qmin,qci(i,k,2)) - source = (psaut(i,k)-pigen(i,k)-pidep(i,k)+praci(i,k)+psaci(i,k) & - +pgaci(i,k))*dtcld - if (source.gt.value) then - factor = value/source - psaut(i,k) = psaut(i,k)*factor - pigen(i,k) = pigen(i,k)*factor - pidep(i,k) = pidep(i,k)*factor - praci(i,k) = praci(i,k)*factor - psaci(i,k) = psaci(i,k)*factor - pgaci(i,k) = pgaci(i,k)*factor - endif -! -! rain -! - value = max(qmin,qrs(i,k,1)) - source = (-praut(i,k)-prevp(i,k)-pracw(i,k)+piacr(i,k)+psacr(i,k) & - +pgacr(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - prevp(i,k) = prevp(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - piacr(i,k) = piacr(i,k)*factor - psacr(i,k) = psacr(i,k)*factor - pgacr(i,k) = pgacr(i,k)*factor - endif -! -! snow -! - value = max(qmin,qrs(i,k,2)) - source = -(psdep(i,k)+psaut(i,k)-pgaut(i,k)+paacw(i,k)+piacr(i,k) & - *delta3+praci(i,k)*delta3-pracs(i,k)*(1.-delta2) & - +psacr(i,k)*delta2+psaci(i,k)-pgacs(i,k) )*dtcld - if (source.gt.value) then - factor = value/source - psdep(i,k) = psdep(i,k)*factor - psaut(i,k) = psaut(i,k)*factor - pgaut(i,k) = pgaut(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - piacr(i,k) = piacr(i,k)*factor - praci(i,k) = praci(i,k)*factor - psaci(i,k) = psaci(i,k)*factor - pracs(i,k) = pracs(i,k)*factor - psacr(i,k) = psacr(i,k)*factor - pgacs(i,k) = pgacs(i,k)*factor - endif -! -! graupel -! - value = max(qmin,qrs(i,k,3)) - source = -(pgdep(i,k)+pgaut(i,k) & - +piacr(i,k)*(1.-delta3)+praci(i,k)*(1.-delta3) & - +psacr(i,k)*(1.-delta2)+pracs(i,k)*(1.-delta2) & - +pgaci(i,k)+paacw(i,k)+pgacr(i,k)+pgacs(i,k))*dtcld - if (source.gt.value) then - factor = value/source - pgdep(i,k) = pgdep(i,k)*factor - pgaut(i,k) = pgaut(i,k)*factor - piacr(i,k) = piacr(i,k)*factor - praci(i,k) = praci(i,k)*factor - psacr(i,k) = psacr(i,k)*factor - pracs(i,k) = pracs(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - pgaci(i,k) = pgaci(i,k)*factor - pgacr(i,k) = pgacr(i,k)*factor - pgacs(i,k) = pgacs(i,k)*factor - endif -! - work2(i,k)=-(prevp(i,k)+psdep(i,k)+pgdep(i,k)+pigen(i,k)+pidep(i,k)) -! update - q(i,k) = q(i,k)+work2(i,k)*dtcld - qci(i,k,1) = max(qci(i,k,1)-(praut(i,k)+pracw(i,k) & - +paacw(i,k)+paacw(i,k))*dtcld,0.) - qrs(i,k,1) = max(qrs(i,k,1)+(praut(i,k)+pracw(i,k) & - +prevp(i,k)-piacr(i,k)-pgacr(i,k) & - -psacr(i,k))*dtcld,0.) - qci(i,k,2) = max(qci(i,k,2)-(psaut(i,k)+praci(i,k) & - +psaci(i,k)+pgaci(i,k)-pigen(i,k)-pidep(i,k)) & - *dtcld,0.) - qrs(i,k,2) = max(qrs(i,k,2)+(psdep(i,k)+psaut(i,k)+paacw(i,k) & - -pgaut(i,k)+piacr(i,k)*delta3 & - +praci(i,k)*delta3+psaci(i,k)-pgacs(i,k) & - -pracs(i,k)*(1.-delta2)+psacr(i,k)*delta2) & - *dtcld,0.) - qrs(i,k,3) = max(qrs(i,k,3)+(pgdep(i,k)+pgaut(i,k) & - +piacr(i,k)*(1.-delta3) & - +praci(i,k)*(1.-delta3)+psacr(i,k)*(1.-delta2) & - +pracs(i,k)*(1.-delta2)+pgaci(i,k)+paacw(i,k) & - +pgacr(i,k)+pgacs(i,k))*dtcld,0.) - xlf = xls-xl(i,k) - xlwork2 = -xls*(psdep(i,k)+pgdep(i,k)+pidep(i,k)+pigen(i,k)) & - -xl(i,k)*prevp(i,k)-xlf*(piacr(i,k)+paacw(i,k) & - +paacw(i,k)+pgacr(i,k)+psacr(i,k)) - t(i,k) = t(i,k)-xlwork2/cpm(i,k)*dtcld - else -! -! cloud water -! - value = max(qmin,qci(i,k,1)) - source=(praut(i,k)+pracw(i,k)+paacw(i,k)+paacw(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - endif -! -! rain -! - value = max(qmin,qrs(i,k,1)) - source = (-paacw(i,k)-praut(i,k)+pseml(i,k)+pgeml(i,k)-pracw(i,k) & - -paacw(i,k)-prevp(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - prevp(i,k) = prevp(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - pseml(i,k) = pseml(i,k)*factor - pgeml(i,k) = pgeml(i,k)*factor - endif -! -! snow -! - value = max(qcrmin,qrs(i,k,2)) - source=(pgacs(i,k)-pseml(i,k)-psevp(i,k))*dtcld - if (source.gt.value) then - factor = value/source - pgacs(i,k) = pgacs(i,k)*factor - psevp(i,k) = psevp(i,k)*factor - pseml(i,k) = pseml(i,k)*factor - endif -! -! graupel -! - value = max(qcrmin,qrs(i,k,3)) - source=-(pgacs(i,k)+pgevp(i,k)+pgeml(i,k))*dtcld - if (source.gt.value) then - factor = value/source - pgacs(i,k) = pgacs(i,k)*factor - pgevp(i,k) = pgevp(i,k)*factor - pgeml(i,k) = pgeml(i,k)*factor - endif - work2(i,k)=-(prevp(i,k)+psevp(i,k)+pgevp(i,k)) -! update - q(i,k) = q(i,k)+work2(i,k)*dtcld - qci(i,k,1) = max(qci(i,k,1)-(praut(i,k)+pracw(i,k) & - +paacw(i,k)+paacw(i,k))*dtcld,0.) - qrs(i,k,1) = max(qrs(i,k,1)+(praut(i,k)+pracw(i,k) & - +prevp(i,k)+paacw(i,k)+paacw(i,k)-pseml(i,k) & - -pgeml(i,k))*dtcld,0.) - qrs(i,k,2) = max(qrs(i,k,2)+(psevp(i,k)-pgacs(i,k) & - +pseml(i,k))*dtcld,0.) - qrs(i,k,3) = max(qrs(i,k,3)+(pgacs(i,k)+pgevp(i,k) & - +pgeml(i,k))*dtcld,0.) - xlf = xls-xl(i,k) - xlwork2 = -xl(i,k)*(prevp(i,k)+psevp(i,k)+pgevp(i,k)) & - -xlf*(pseml(i,k)+pgeml(i,k)) - t(i,k) = t(i,k)-xlwork2/cpm(i,k)*dtcld - endif - enddo - enddo -! -! Inline expansion for fpvs -! qs(i,k,1) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) -! qs(i,k,2) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) - hsub = xls - hvap = xlv0 - cvap = cpv - ttp=t0c+0.01 - dldt=cvap-cliq - xa=-dldt/rv - xb=xa+hvap/(rv*ttp) - dldti=cvap-cice - xai=-dldti/rv - xbi=xai+hsub/(rv*ttp) - do k = kts, kte - do i = its, ite - tr=ttp/t(i,k) - qs(i,k,1)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) - qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k) - qs(i,k,1)) - qs(i,k,1) = max(qs(i,k,1),qmin) - tr=ttp/t(i,k) - if(t(i,k).lt.ttp) then - qs(i,k,2)=psat*exp(log(tr)*(xai))*exp(xbi*(1.-tr)) - else - qs(i,k,2)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) - endif - qs(i,k,2) = ep2 * qs(i,k,2) / (p(i,k) - qs(i,k,2)) - qs(i,k,2) = max(qs(i,k,2),qmin) - enddo - enddo -! -!---------------------------------------------------------------- -! pcond: condensational/evaporational rate of cloud water [HL A46] [RH83 A6] -! if there exists additional water vapor condensated/if -! evaporation of cloud water is not enough to remove subsaturation -! - do k = kts, kte - do i = its, ite - work1(i,k,1) = conden(t(i,k),q(i,k),qs(i,k,1),xl(i,k),cpm(i,k)) - work2(i,k) = qci(i,k,1)+work1(i,k,1) - pcond(i,k) = min(max(work1(i,k,1)/dtcld,0.),max(q(i,k),0.)/dtcld) - if(qci(i,k,1).gt.0..and.work1(i,k,1).lt.0.) & - pcond(i,k) = max(work1(i,k,1),-qci(i,k,1))/dtcld - q(i,k) = q(i,k)-pcond(i,k)*dtcld - qci(i,k,1) = max(qci(i,k,1)+pcond(i,k)*dtcld,0.) - t(i,k) = t(i,k)+pcond(i,k)*xl(i,k)/cpm(i,k)*dtcld - enddo - enddo -! -! -!---------------------------------------------------------------- -! padding for small values -! - do k = kts, kte - do i = its, ite - if(qci(i,k,1).le.qmin) qci(i,k,1) = 0.0 - if(qci(i,k,2).le.qmin) qci(i,k,2) = 0.0 - enddo - enddo - enddo ! big loops - END SUBROUTINE wsm62d -! ................................................................... - REAL FUNCTION rgmma(x) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -! rgmma function: use infinite product form - REAL :: euler - PARAMETER (euler=0.577215664901532) - REAL :: x, y - INTEGER :: i - if(x.eq.1.)then - rgmma=0. - else - rgmma=x*exp(euler*x) - do i=1,10000 - y=float(i) - rgmma=rgmma*(1.000+x/y)*exp(-x/y) - enddo - rgmma=1./rgmma - endif - END FUNCTION rgmma -! -!-------------------------------------------------------------------------- - REAL FUNCTION fpvs(t,ice,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c) -!-------------------------------------------------------------------------- - IMPLICIT NONE -!-------------------------------------------------------------------------- - REAL t,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c,dldt,xa,xb,dldti, & - xai,xbi,ttp,tr - INTEGER ice -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ttp=t0c+0.01 - dldt=cvap-cliq - xa=-dldt/rv - xb=xa+hvap/(rv*ttp) - dldti=cvap-cice - xai=-dldti/rv - xbi=xai+hsub/(rv*ttp) - tr=ttp/t - if(t.lt.ttp.and.ice.eq.1) then - fpvs=psat*(tr**xai)*exp(xbi*(1.-tr)) - else - fpvs=psat*(tr**xa)*exp(xb*(1.-tr)) - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END FUNCTION fpvs -!------------------------------------------------------------------- - SUBROUTINE wsm6init(den0,denr,dens,cl,cpv,allowed_to_read) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -!.... constants which may not be tunable - REAL, INTENT(IN) :: den0,denr,dens,cl,cpv - LOGICAL, INTENT(IN) :: allowed_to_read - REAL :: pi -! - pi = 4.*atan(1.) - xlv1 = cl-cpv -! - qc0 = 4./3.*pi*denr*r0**3*xncr/den0 ! 0.419e-3 -- .61e-3 - qck1 = .104*9.8*peaut/(xncr*denr)**(1./3.)/xmyu*den0**(4./3.) ! 7.03 -! - bvtr1 = 1.+bvtr - bvtr2 = 2.5+.5*bvtr - bvtr3 = 3.+bvtr - bvtr4 = 4.+bvtr - bvtr6 = 6.+bvtr - g1pbr = rgmma(bvtr1) - g3pbr = rgmma(bvtr3) - g4pbr = rgmma(bvtr4) ! 17.837825 - g6pbr = rgmma(bvtr6) - g5pbro2 = rgmma(bvtr2) ! 1.8273 - pvtr = avtr*g4pbr/6. - eacrr = 1.0 - pacrr = pi*n0r*avtr*g3pbr*.25*eacrr - precr1 = 2.*pi*n0r*.78 - precr2 = 2.*pi*n0r*.31*avtr**.5*g5pbro2 - roqimax = 2.08e22*dimax**8 -! - bvts1 = 1.+bvts - bvts2 = 2.5+.5*bvts - bvts3 = 3.+bvts - bvts4 = 4.+bvts - g1pbs = rgmma(bvts1) !.8875 - g3pbs = rgmma(bvts3) - g4pbs = rgmma(bvts4) ! 12.0786 - g5pbso2 = rgmma(bvts2) - pvts = avts*g4pbs/6. - pacrs = pi*n0s*avts*g3pbs*.25 - precs1 = 4.*n0s*.65 - precs2 = 4.*n0s*.44*avts**.5*g5pbso2 - pidn0r = pi*denr*n0r - pidn0s = pi*dens*n0s -! - pacrc = pi*n0s*avts*g3pbs*.25*eacrc -! - bvtg1 = 1.+bvtg - bvtg2 = 2.5+.5*bvtg - bvtg3 = 3.+bvtg - bvtg4 = 4.+bvtg - g1pbg = rgmma(bvtg1) - g3pbg = rgmma(bvtg3) - g4pbg = rgmma(bvtg4) - pacrg = pi*n0g*avtg*g3pbg*.25 - g5pbgo2 = rgmma(bvtg2) - pvtg = avtg*g4pbg/6. - precg1 = 2.*pi*n0g*.78 - precg2 = 2.*pi*n0g*.31*avtg**.5*g5pbgo2 - pidn0g = pi*deng*n0g -! - rslopermax = 1./lamdarmax - rslopesmax = 1./lamdasmax - rslopegmax = 1./lamdagmax - rsloperbmax = rslopermax ** bvtr - rslopesbmax = rslopesmax ** bvts - rslopegbmax = rslopegmax ** bvtg - rsloper2max = rslopermax * rslopermax - rslopes2max = rslopesmax * rslopesmax - rslopeg2max = rslopegmax * rslopegmax - rsloper3max = rsloper2max * rslopermax - rslopes3max = rslopes2max * rslopesmax - rslopeg3max = rslopeg2max * rslopegmax -! - END SUBROUTINE wsm6init -END MODULE module_mp_wsm6 diff --git a/src/fim/FIMsrc/fim/wrfphys/module_set_wrfphys.F b/src/fim/FIMsrc/fim/wrfphys/module_set_wrfphys.F deleted file mode 100644 index 4f82c2d..0000000 --- a/src/fim/FIMsrc/fim/wrfphys/module_set_wrfphys.F +++ /dev/null @@ -1,155 +0,0 @@ -Module module_set_wrfphys -USE module_initial_chem_namelists -CONTAINS -SUBROUTINE set_wrfphys (mp_physics) -USE module_wrfphysvars -USE module_control, only: ntra,ntrb -USE module_wrf_control, only: num_moist,num_chem -implicit none -!! TBH: Ignore these so PPP doesn't have to translate them -!!SMS$IGNORE BEGIN -!USE module_initial_chem_namelists -!USE module_data_gocart_dust -!USE module_data_gocart_seas -!!SMS$IGNORE END -integer, intent(in) :: mp_physics -integer :: itest -!!SMS$DISTRIBUTE (dh,2) BEGIN -!real, intent(in) :: tr3d(:,:,:) -!integer :: itest -!!SMS$DISTRIBUTE END -! -! microphysics -! -if(mp_physics.eq.4)then - if(num_moist.ne.5)then - write(6,*) ' num_moist is not equal 5 ' - stop - endif - itest=ntra+ntrb-num_moist-num_chem+1 - if(itest.ne.ntra)then - write(6,*) ' ntra ist falsch' - write(6,*) ' ntra,num_moist,num_chem = ',ntra,num_moist,num_chem - stop - endif - p_qv=1 - f_qv=.true. - p_qc=2 - f_qc=.true. - p_qr=3 - f_qr=.true. - p_qi=4 - f_qi=.true. - p_qs=5 - f_qs=.true. -else if(mp_physics.eq.2)then - if(num_moist.ne.6)then - write(6,*) ' num_moist is not equal 6 ' - stop - endif - itest=ntra+ntrb-num_moist-num_chem+1 - if(itest.ne.ntra)then - write(6,*) ' ntra ist falsch' - stop - endif - p_qv=1 - f_qv=.true. - p_qc=2 - f_qc=.true. - p_qr=3 - f_qr=.true. - p_qi=4 - f_qi=.true. - p_qs=5 - f_qs=.true. - p_qg=6 - f_qg=.true. -else if(mp_physics.eq.0)then - if(num_moist.ne.3)then - write(6,*) ' num_moist is not equal 3 ' -! stop - endif - itest=ntra+ntrb-num_moist-num_chem+3 - if(itest.ne.ntra)then - write(6,*) ' ntra ist falsch',ntra,num_moist,num_chem -! stop - endif - p_qv=1 - f_qv=.true. - p_qc=2 - f_qc=.true. -endif -END SUBROUTINE set_wrfphys - subroutine set_wrfphys_namelist_defaults -implicit none -!STARTOFREGISTRYGENERATEDINCLUDE 'inc/namelist_defaults.inc' -! from V3.1 -! -! THIS does not need to be recopied. Defaults are simple to set! -! -mp_physics = 0 -gsfcgce_hail = 0 -gsfcgce_2ice = 0 -progn = 0 -ra_lw_physics = 0 -ra_sw_physics = 0 -radt = 0 -naer = 1e9 -sf_sfclay_physics = 0 -sf_surface_physics = 0 -bl_pbl_physics = 0 -sf_urban_physics = 0 -bldt = 0 -cu_physics = 0 -cudt = 0 -gsmdt = 0 -isfflx = 1 -ifsnow = 0 -icloud = 1 -swrad_scat = 1 -surface_input_source = 1 -num_urban_layers = 400 -num_months = 12 -maxiens = 1 -maxens = 3 -maxens2 = 3 -maxens3 = 16 -ensdim = 144 -cugd_avedx = 1 -imomentum = 0 -clos_choice = 0 -num_land_cat = 24 -num_soil_cat = 16 -mp_zero_out = 0 -mp_zero_out_thresh = 1.e-8 -seaice_threshold = 271 -sst_update = 0 -sst_skin = 0 -tmn_update = 0 -usemonalb = .false. -rdmaxalb = .true. -rdlai2d = .false. -co2tf = 1 -ra_call_offset = 0 -cam_abs_freq_s = 21600. -levsiz = 1 -paerlev = 1 -cam_abs_dim1 = 1 -cam_abs_dim2 = 1 -lagday = 1 -cu_rad_feedback = .false. -pxlsm_smois_init = 1 -omlcall = 0 -oml_hml0 = 50 -oml_gamma = 0.14 -isftcflx = 0 -shadlen = 25000. -slope_rad = 0 -topo_shading = 0 -no_mp_heating = 0 -fractional_seaice = 0 -bucket_mm = -1. -bucket_j = -1. -grav_settling = 0 -END SUBROUTINE set_wrfphys_namelist_defaults -END MODULE module_set_wrfphys diff --git a/src/fim/FIMsrc/fim/wrfphys/module_wrfphys_prep_fim.F b/src/fim/FIMsrc/fim/wrfphys/module_wrfphys_prep_fim.F deleted file mode 100644 index 6258098..0000000 --- a/src/fim/FIMsrc/fim/wrfphys/module_wrfphys_prep_fim.F +++ /dev/null @@ -1,220 +0,0 @@ -MODULE MODULE_WRFPHYS_PREP_FIM -CONTAINS - subroutine wrfphys_prep_fim(ktau,dtstep,tr3d,tk3d,st3d,sm3d,dp3d,mp3d,ts2d,us2d,sw2d,pr3d, & - VFRAC2d,VTYPE2d,STYPE2d,us3d,vs3d,ws3d,slmsk2d,zorl2d,exch,pb2d,hf2d,& - ex3d,pi_phy,gmt,julday,ph3d,deg_lat,deg_lon,nvl,nvlp1,ntra,ntrb, & - th,rri,t_phy,moist,u_phy,v_phy,p_phy,tsk,g,rd,cp,& - u10,v10,ivgtyp,isltyp,gsw,vegfra,rmol,ust,znt,xland,t8w,p8w,exch_h,pbl,hfx,ht, & - phys3dwrf,rqvblten,rqvften,rthraten,rthblten,rthften, & - xlat,xlong,z_at_w,zmid,dz8w,vvel,rho_phy,smois,num_soil_layers,num_moist,& - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite,jts,jte,kts,kte) -! -! input fim variables -! -IMPLICIT NONE -INTEGER, INTENT(IN ) :: ktau,nvl,nvlp1,ntra,ntrb -REAL, INTENT(IN ) :: g,rd,dtstep,gmt,cp -real, intent(in) :: dp3d(nvl,jms:jme) ! del p between coord levels (pascals) -real, intent(in) :: mp3d(nvl,jms:jme) ! Montgomery Potential (m^2/s^2) -real, intent(in) :: tk3d(nvl,jms:jme) ! temperature, kelvin -real, intent(in) :: exch(nvl,jms:jme) ! -real, intent(in) :: tr3d(nvl,jms:jme,ntra+ntrb) ! 1=pot.temp, 2=water vapor, 3=cloud water, 4=ozone -real, intent(in) :: phys3dwrf(nvl,jms:jme,11) ! 1=pot.temp, 2=water vapor, 3=cloud water, 4=ozone -real, intent(in) :: st3d(4,jms:jme) ! soil temperature -real, intent(in) :: sm3d(4,jms:jme) ! soil moisture -real, intent(in) :: ts2d(jms:jme) ! skin temperature -real, intent(in) :: us2d(jms:jme) ! friction velocity/equivalent momentum flux -real, intent(in) :: pb2d(jms:jme) ! -real, intent(in) :: hf2d(jms:jme) ! -real, intent(in) :: sw2d(jms:jme) ! downward short-wave radiation flux -real, intent(in) :: pr3d(nvlp1,jms:jme) ! pressure (pascal) -real, intent(in) :: ex3d(nvlp1,jms:jme) ! exner function -real, intent(in) :: ph3d(nvlp1,jms:jme) ! geopotential (=gz), m^2/s^2 -real, dimension (jms:jme), intent(in) :: vfrac2d,VTYPE2d,STYPE2d,zorl2d,slmsk2d -real, dimension (nvl,jms:jme), intent(in) :: us3d,vs3d,ws3d -real, intent(in) :: deg_lat(jms:jme),deg_lon(jms:jme) ! lat and lon in degrees - - INTEGER, INTENT(IN ) :: num_soil_layers,num_moist,julday, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & - INTENT(OUT ) :: moist - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & - INTENT(OUT ) :: & - rri, & - t_phy,th, & - p_phy,pi_phy, & - dz8w,p8w,t8w, & - rqvblten,rqvften,rthraten,rthblten,rthften, & - z_at_w , zmid ,exch_h, & - u_phy,v_phy,vvel,rho_phy - INTEGER,DIMENSION( ims:ime , jms:jme ) , & - INTENT(OUT ) :: & - ivgtyp, & - isltyp - REAL, DIMENSION( ims:ime , jms:jme ) , & - INTENT(OUT ) :: & - u10, & - v10, & - gsw, & - vegfra, & - rmol, & - ust, & - xland, & - xlat, & - xlong,tsk, & - znt,pbl,hfx,ht - REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ) , & - INTENT(OUT) :: smois - integer i,j,k,kk,nv,jmax,jmaxi,l,ll,n,ndystep,ixhour - real maxv,factor,factor2,pu,pl,aln,pwant,rlat - real xhour,xmin,gmtp,xlonn,xtime -! .. Intrinsic Functions .. - INTRINSIC max, min, float -!TBH write(6,*)'in prep fim !!!!!!!!!!!!!!!!!!!' - do i=its,ite - do k=kts,kte+1 - do j=jts,jte -! z_at_w(i,k,j)=ph3d(k,j)/g - p8w(i,k,j)=pr3d(k,j) - enddo - enddo - enddo - do i=its,ite - do j=jts,jte - z_at_w(i,kts,j)=max(0.,ph3d(kts,j)/g) - ht(i,j)=z_at_w(i,kts,j) - enddo - enddo - do i=its,ite - do k=kts,kte - do j=jts,jte - dz8w(i,k,j)=(ph3d(k+1,j)-ph3d(k,j))/g - if(dz8w(i,k,j).lt.0.)dz8w(i,k,j)=-dz8w(i,k,j) - z_at_w(i,k+1,j)=z_at_w(i,k,j)+dz8w(i,k,j) - enddo - enddo - enddo -! print *,maxval(vtype2d) -! print *,maxval(stype2d) -! print *,maxval(VFRAC2d) - do i=its,ite - do j=jts,jte - pbl(i,j)=pb2d(j) - hfx(i,j)=hf2d(j) - xlat(i,j)=deg_lat(j) - xlong(i,j)=deg_lon(j) - ust(i,j)=us2d(j) - tsk(i,j)=ts2d(j) - ivgtyp(i,j)=VTYPE2d(j) - isltyp(i,j)=STYPE2d(j) - gsw(i,j)=sw2d(j) - vegfra(i,j)=VFRAC2d(j) -! if(j.eq.1000)write(6,*)'j1000 ',ivgtyp(i,j),isltyp(i,j),vegfra(i,j),slmsk2d(j) -! if(ivgtyp(i,j).ne.0)write(6,*)i,j,ivgtyp(i,j),isltyp(i,j),vegfra(i,j),pb2d(j),VTYPE2d(j) - rmol(i,j)=0. - znt(i,j)=zorl2d(j)*.01 -!SLMSK - SEA(0),LAND(1),ICE(2) MASK - xland(i,j)=1. - if(slmsk2d(j).eq.0)xland(i,j)=0. - if(slmsk2d(j).eq.1)xland(i,j)=1. - if(slmsk2d(j).eq.2)xland(i,j)=2. -! if (slmsk2d(j).gt.0.)write(6,*)j,slmsk2d(j) - u10(i,j)=us3d(1,j) - v10(i,j)=vs3d(1,j) -! if(j.eq.1000)then -! write(6,*)xlat(i,j),xlong(i,j),ph3d(1,j),xland(i,j) -! write(6,*)vegfra(i,j),ust(i,j),tsk(i,j),ivgtyp(i,j) -! write(6,*)isltyp(i,j),gsw(i,j),znt(i,j),z_at_w(i,kts,j) -! endif - enddo - enddo -! if(j.eq.3836)write(6,*)'in prep_fim !!!!!!!!!!!!!!!!!!!!!' - do i=its,ite - do k=kts,kte+1 - kk=min(k,kte) - do j=jts,jte - rqvblten(i,k,j)=phys3dwrf(kk,j,2) - rthblten(i,k,j)=phys3dwrf(kk,j,5) - rthraten(i,k,j)=phys3dwrf(kk,j,6) - rthften(i,k,j)=phys3dwrf(kk,j,7)+rthblten(i,k,j)+rthraten(i,k,j) - rqvften(i,k,j)=phys3dwrf(kk,j,3)+rqvblten(i,k,j) -! t_phy(i,k,j)=tk3d(kk,j) - th(i,k,j)=tr3d(kk,j,1)/(1.+.6078*tr3d(kk,j,2)) - zmid(i,k,j)=.5*(z_at_w(i,kk+1,j)+z_at_w(i,kk,j)) -! dz8w(i,k,j)=z_at_w(i,kk+1,j)-z_at_w(i,kk,j) - p_phy(i,k,j)=.5*(p8w(i,kk,j)+p8w(i,kk+1,j)) - pi_phy(i,k,j)=.5*(ex3d(kk,j)+ex3d(kk+1,j))/cp - t_phy(i,k,j)=th(i,k,j)*pi_phy(i,k,j) - u_phy(i,k,j)=us3d(kk,j) - exch_h(i,k,j)=exch(kk,j) - v_phy(i,k,j)=vs3d(kk,j) - rho_phy(i,k,j)= p_phy(i,k,j)/(RD*T_phy(i,k,j)*(1.+.608*tr3d(kk,j,2))) - rri(i,k,j)=1./rho_phy(i,k,j) - vvel(i,k,j)=-ws3d(kk,j)*rri(i,k,j)/g -! if(j.eq.89)then -! write(6,*)k,z_at_w(i,k,j),zmid(i,k,j),t_phy(i,k,j),p_phy(i,k,j) -! endif -! if(z_at_w(i,k,j).lt.0 .or. zmid(i,k,j).lt.0.) then -! write(6,*)k,z_at_w(i,k,j),zmid(i,k,j),ph3d(kk,j),ph3d(kk+1,j) -! write(6,*)i,j,t_phy(i,k,j),th(i,k,j),pi_phy(i,k,j),p_phy(i,k,j) -! stop -! endif - enddo - enddo - enddo - do i=its,ite - do k=2,kte - do j=jts,jte - t8w(i,k,j)=.5*(t_phy(i,k,j)-t_phy(i,k-1,j)) ! .5*(tk3d(k-1,j)+tk3d(k,j)) - enddo - enddo - enddo -! do we know this here? do we need this? - do i=its,ite - do j=jts,jte - t8w(i,1,j)=t_phy(i,1,j) -! t8w(i,kte+1,j)=tk3d(kte,j) - enddo - enddo -! qv is in tr3d(2) ! -! write(6,*)'in wrfphysprep, kte,nvl,num_moist = ',kte,nvl,num_moist - do nv=2,num_moist - do i=its,ite - do k=kts,kte+1 - kk=min(k,kte) - do j=jts,jte - moist(i,k,j,nv)=tr3d(kk,j,ntra+nv-1) - if(moist(i,k,j,nv).lt.1.e-15)moist(i,k,j,nv)=0. - enddo - enddo - enddo - enddo -! p_qv is always 1! - do i=its,ite - do k=kts,kte+1 - kk=min(k,kte) - do j=jts,jte - moist(i,k,j,1)=tr3d(kk,j,2) - if(j.eq.1000)then -!TBH write(6,*)k,moist(i,k,j,p_qv),moist(i,k,j,p_qc),moist(i,k,j,p_qi) - endif - enddo - enddo - enddo - do i=its,ite - do j=jts,jte - do nv=1,num_soil_layers - smois(i,nv,j)=sm3d(nv,j) - enddo - enddo - enddo -!TBH write(6,*)'done prep fim !!!!!!!!!!!!!!!!!!!' -! maxv=maxval(raincv_b) -! write(6,*)maxv - -END subroutine wrfphys_prep_fim -END MODULE MODULE_WRFPHYS_PREP_FIM diff --git a/src/fim/FIMsrc/fim/wrfphys/module_wrfphysvars.F b/src/fim/FIMsrc/fim/wrfphys/module_wrfphysvars.F deleted file mode 100644 index b58226d..0000000 --- a/src/fim/FIMsrc/fim/wrfphys/module_wrfphysvars.F +++ /dev/null @@ -1,83 +0,0 @@ -MODULE MODULE_WRFPHYSVARS - - IMPLICIT NONE - -! -! the next are variables that chemdriver will need -! - REAL, ALLOCATABLE :: moist( :, :, :, : ) - REAL, ALLOCATABLE :: scalar( :, :, :, : ) - REAL, ALLOCATABLE :: tsk( :, :) - REAL, ALLOCATABLE :: dxy( :, :) - REAL, ALLOCATABLE :: rri( : , : , : ) - REAL, ALLOCATABLE :: t_phy( : , : , : ) - REAL, ALLOCATABLE :: th_phy( : , : , : ) - REAL, ALLOCATABLE :: p_phy( : , : , : ) - REAL, ALLOCATABLE :: pi_phy( : , : , : ) - REAL, ALLOCATABLE :: dz8w( : , : , : ) - REAL, ALLOCATABLE :: t8w( : , : , : ) - REAL, ALLOCATABLE :: p8w( : , : , : ) - REAL, ALLOCATABLE :: z_at_w ( : , : , : ) - REAL, ALLOCATABLE :: zmid ( : , : , : ) - REAL, ALLOCATABLE :: u_phy( : , : , : ) - REAL, ALLOCATABLE :: v_phy( : , : , : ) - REAL, ALLOCATABLE :: vvel( : , : , : ) - REAL, ALLOCATABLE :: rho_phy( : , : , : ) - REAL, ALLOCATABLE :: exch_h( : , : , : ) - REAL, ALLOCATABLE :: cldfra( : , : , : ) - REAL, ALLOCATABLE :: rqvcuten( : , : , : ) - REAL, ALLOCATABLE :: rqvblten( : , : , : ) - REAL, ALLOCATABLE :: rqvften( : , : , : ) - REAL, ALLOCATABLE :: rthcuten( : , : , : ) - REAL, ALLOCATABLE :: rthblten( : , : , : ) - REAL, ALLOCATABLE :: rthraten( : , : , : ) - REAL, ALLOCATABLE :: rthften( : , : , : ) - REAL, ALLOCATABLE :: rqrcuten( : , : , : ) - REAL, ALLOCATABLE :: rqccuten( : , : , : ) - REAL, ALLOCATABLE :: rqscuten( : , : , : ) - REAL, ALLOCATABLE :: rqicuten( : , : , : ) - REAL, ALLOCATABLE :: rqgcuten( : , : , : ) - INTEGER, ALLOCATABLE :: ivgtyp( : , : ) - INTEGER, ALLOCATABLE :: isltyp( : , : ) - REAL, ALLOCATABLE :: u10( : , : ) - REAL, ALLOCATABLE :: v10( : , : ) - REAL, ALLOCATABLE :: gsw( : , : ) - REAL, ALLOCATABLE :: sr( : , : ) - REAL, ALLOCATABLE :: pbl( : , : ) - REAL, ALLOCATABLE :: hfx( : , : ) - REAL, ALLOCATABLE :: vegfra( : , : ) - REAL, ALLOCATABLE :: rmol( : , : ) - REAL, ALLOCATABLE :: ust( : , : ) - REAL, ALLOCATABLE :: xland( : , : ) - REAL, ALLOCATABLE :: xlat( : , : ) - REAL, ALLOCATABLE :: xlong( : , : ) - REAL, ALLOCATABLE :: znt( : , : ) - REAL, ALLOCATABLE :: ht( : , : ) -! for convective schemes - REAL, ALLOCATABLE :: rainc( : , : ) - REAL, ALLOCATABLE :: apr_gr( : , : ) - REAL, ALLOCATABLE :: apr_w( : , : ) - REAL, ALLOCATABLE :: apr_mc( : , : ) - REAL, ALLOCATABLE :: apr_as( : , : ) - REAL, ALLOCATABLE :: apr_st( : , : ) - REAL, ALLOCATABLE :: apr_capma( : , : ) - REAL, ALLOCATABLE :: apr_capme( : , : ) - REAL, ALLOCATABLE :: apr_capmi( : , : ) - REAL, ALLOCATABLE :: mass_flux( : , : ) - REAL, ALLOCATABLE :: cugd_tten( : , : , : ) - REAL, ALLOCATABLE :: cugd_ttens( : , : , : ) - REAL, ALLOCATABLE :: cugd_qvten( : , : , : ) - REAL, ALLOCATABLE :: cugd_qcten( : , : , : ) - REAL, ALLOCATABLE :: cugd_qvtens( : , : , : ) - REAL, ALLOCATABLE :: gd_cloud( : , : , : ) - REAL, ALLOCATABLE :: gd_cloud2( : , : , : ) - REAL, ALLOCATABLE :: raincv( : , : ) -! end convective schemes - REAL, ALLOCATABLE :: rainnc( : , : ) - REAL, ALLOCATABLE :: rainncv( : , : ) - REAL, ALLOCATABLE :: snownc( : , : ) - REAL, ALLOCATABLE :: snowncv( : , : ) - REAL, ALLOCATABLE :: graupelnc( : , : ) - REAL, ALLOCATABLE :: graupelncv( : , : ) - REAL, ALLOCATABLE :: smois( :, :, : ) -END MODULE MODULE_WRFPHYSVARS diff --git a/src/fim/FIMsrc/fim_setup.ksh b/src/fim/FIMsrc/fim_setup.ksh deleted file mode 100644 index 2c08308..0000000 --- a/src/fim/FIMsrc/fim_setup.ksh +++ /dev/null @@ -1,165 +0,0 @@ -#!/bin/ksh - -CONTEXT="fim_setup.ksh" - -# Purpose: -# Sets up environment for FIM build or run. -# -# Usage: -# This script should be executed from another script via the ksh "." (source) -# command. It takes zero, one, or two arguments: -# . fim_setup.ksh -# . fim_setup.ksh [fim_configuration] -# . fim_setup.ksh [fim_configuration] [loquacious] -# -# The "fim_configuration" argument is used to select non-default -# environmental settings. -# -# When present, the "loquacious" argument causes intermediate results to be -# printed. - -loquacious="false" -use_modules="true" -module_ksh="/opt/modules/Modules/default/init/ksh" -mpif90="mpif90" - -# Process command-line arguments if present. -usage_msg="Usage: . fim_setup.ksh [fim_configuration] [loquacious]" - -case "$#" in - 2) fim_configuration="$1"; loquacious="true";; - 1) fim_configuration="$1";; - 0) fim_configuration="openmpi";; - *) print "$usage_msg"; exit 1;; -esac - -#TODO: Paul, we need to call the makefim "check" function here to -#TODO: validate fim_configuration - -# Set environment variables and reset $use_modules if needed. -case "$fim_configuration" in - "vapor") # vapor -q64 - # Add FIM_ESMF_INSTALL_LIBDIR_ABSPATH later... - use_modules="false" - ;; - "devccs") # cirrus/stratus -q64 - # Add FIM_ESMF_INSTALL_LIBDIR_ABSPATH later... - use_modules="false" - ;; - "bluefire") # bluefire -q64 - # Add FIM_ESMF_INSTALL_LIBDIR_ABSPATH later... - use_modules="false" - ;; - "nems") # ifort+mvapich: jet default + ESMF - # Set location of esmf.mk. - export FIM_ESMF_INSTALL_LIBDIR_ABSPATH="/home/rosinski/esmf-3.1.0rp2/lib/libO/Linux.intel.64.mpich2.default" - ;; - "ranger") # ranger, mvapich/1.01 - ;; - "linuxpcgnu") - use_modules="false" - export NETCDF="$HOME/x86_64" - #JR NOTE: FIM under gfortran requires v 4.4 or greater of the compiler. - #JR Earlier revs. didn't allow "allocatables" inside derived types. - #JR By setting MPICH_F90 below, you can tell mpirun to use a different - #JR compiler if it's needed to address such issues. - #JR export MPICH_F90="gfortran44" - ;; - "macgnu") - use_modules="false" - export NETCDF="$HOME" - #JR NOTE: FIM under gfortran requires v 4.4 or greater of the compiler. - #JR Earlier revs. didn't allow "allocatables" inside derived types. - #JR By setting MPICH_F90 below, you can tell mpirun to use a different - #JR compiler if it's needed to address such issues. - #JR export MPICH_F90="gfortran44" - ;; - "jaguarintel") - use_modules="true" - module_ksh="/opt/modules/3.1.6/init/ksh" - ;; - "jaguargnu") - use_modules="true" - module_ksh="/opt/modules/3.1.6/init/ksh" - ;; - "frostintel") - mpif90="ifort" - use_modules="false" - ;; - *) - ;; -esac - -# Module setup -test "$use_modules" == "true" && . $module_ksh - -# load default modules -if [[ "$fim_configuration" != "ranger" && "$fim_configuration" != "jaguarintel" && "$fim_configuration" != "jaguargnu" ]] -then - if [[ "$use_modules" == "true" ]] - then - module purge # unload all modules - module load wjet - # Now we know what modules we are switching from... - fi -fi - -# Switch modules if needed. -if [[ "$use_modules" == "true" ]] -then - case "$fim_configuration" in - "debug") - # ifort-11.1+mvapich2-1.4.1 (jet default) - ;; - "jaguarintel") - mpif90="ftn" - # The following will break if/when PrgEnv-pgi is no longer the default - module switch PrgEnv-pgi PrgEnv-intel - # Current default on jaguar (11.1.046) fails on phy_init.F90 with "internal compiler error" - # so use the most recent intel compiler version available - module switch intel intel/11.1.064 - module unload netcdf - module load netcdf - ;; - "jaguargnu") - mpif90="ftn" - # The following will break if/when PrgEnv-pgi is no longer the default - module switch PrgEnv-pgi PrgEnv-gnu - module unload netcdf - module load netcdf - ;; - "lahey") - # lahey+mvapich2-1.4.1 - module switch intel lahey/8.10b - ;; - "mvapich") - # ifort-11.1+mvapich2-1.4.1 (jet default) - ;; - "nems") - # ifort-11.1+mvapich2-1.4.1 (jet default) - ;; - "openmpi") - # ifort-11.1+openmpi-1.4.1 - module switch mvapich2 openmpi/1.4.1-intel-11.1 - ;; - "ranger") - # ranger, mvapich/1.01 - module unload pgi mvapich - module load intel - module load mvapich - module load netcdf - ;; - *) - ;; - esac -fi - -# List modules iff loquacious switch is set and modules are used -if [[ "$loquacious" == "true" && "$use_modules" == "true" ]] -then - module list - print "whence $mpif90: $(whence $mpif90)" - #TODO: IBM-specific software stack listing here... -fi - -return 0 diff --git a/src/fim/FIMsrc/fimtopo/Makefile b/src/fim/FIMsrc/fimtopo/Makefile deleted file mode 100644 index a94df58..0000000 --- a/src/fim/FIMsrc/fimtopo/Makefile +++ /dev/null @@ -1,36 +0,0 @@ -# fimtopo Makefile - -include ../macros.make - -#FC = g95 -#LD = g95 -CMD = fimtopo.x -CPPFLAGS = -FC = /opt/lahey/lf6480/bin/f95 -FC = ifort -FFLAGS = -LD = /opt/lahey/lf6480/bin/f95 -LD = ifort -LDFLAGS = -g -LIBS = -OBJS = fimtopo.o -SHELL = /bin/sh - -# Lines from here on down should not need to be changed. They are the actual -# rules which make uses to build the executable. - -$(CMD): $(OBJS) - $(LD) -o $(CMD) $(OBJS) $(LIBS) $(LDFLAGS) - -clean: - rm -f *.o $(CMD) *.mod - -%.o: %.f90 - @echo Compiling $<; $(FC) -o $@ -c $< - - - - - - - diff --git a/src/fim/FIMsrc/fimtopo/README b/src/fim/FIMsrc/fimtopo/README deleted file mode 100644 index 446921e..0000000 --- a/src/fim/FIMsrc/fimtopo/README +++ /dev/null @@ -1,21 +0,0 @@ - - FIMsrc/fimtopo - Mike Fiorino - 20091026 - -Tthis is the standalone code to make analyze 5' wrf global topo to the fim icos -grid. - -Files: -====== - -Makefile # uses ifort to make -const.mod # module from compile with constants (built) -fimtopo.f90 # main program with all modules -fimtopo.nl # namelist -fimtopo.o # (built) -fimtopo.x # application (built) -libmf.mod # module from compile with utility subroutines (built) - -This code was added to prep/ss2icos/mktopo.f90 to make wrf topo during the fim -run. diff --git a/src/fim/FIMsrc/fimtopo/fimtopo.f90 b/src/fim/FIMsrc/fimtopo/fimtopo.f90 deleted file mode 100644 index a632089..0000000 --- a/src/fim/FIMsrc/fimtopo/fimtopo.f90 +++ /dev/null @@ -1,711 +0,0 @@ - -module const - -real, parameter :: pi=3.1415926535897931 -real, parameter :: pi4=pi/4.0 -real, parameter :: pi2=pi/2.0 -real, parameter :: deg2rad=pi/180.0 -real, parameter :: rad2deg=1.0/deg2rad - -real, parameter :: rearth=6371.0 -real, parameter :: earthcircum=2.0*pi*rearth -real, parameter :: earthomega=7.292e-5 - -real, parameter :: km2nm=60.0/(2*pi*rearth/360.0) -real, parameter :: nm2km=1.0/km2nm -real, parameter :: deglat2km=((2.0*pi*rearth)/360.0) -real, parameter :: deglat2nm=60.0 -real, parameter :: km2deglat=1.0/deglat2km -real, parameter :: nm2deglat=1.0/deglat2nm -real, parameter :: knots2ms=1000.0/(km2nm*3600.0) -real, parameter :: yms2knots=1.0/knots2ms -real, parameter :: epsilonm5=1.0e-5 -real, parameter :: gravity=9.80665 - -end module const - -module libmf - -contains - -subroutine stat2(a,m,n,amin,amax,amean,avar,asigma) - - real(kind=4) :: a(m,n) - - amean = 0.0 - amin = 9.9e25 - amax = -9.9e25 - avar = 0.0 - asigma = 0.0 - do i=1,m - do j=1,n - if(a(i,j).lt.amin) amin=a(i,j) - if(a(i,j).gt.amax) amax=a(i,j) - amean=amean+a(i,j) - end do - end do - amean = amean/m*n - do i=1,m - do j=1,n - avar = avar + (a(i,j)-amean)**2 - end do - end do - avar = avar/(m*n-1) - asigma=sqrt(avar) - return - -end subroutine stat2 - -subroutine qprntn(a,qtitle,ibeg,jbeg,m,n,iskip,iunit) - -! -!********** 12 APR 91 this version outputs to iunit -!********** using write on the Cray Y/MP -! -!*************************************************************** -!*************************************************************** -!***** ***** -!***** qprint output routine (!orrected 4/26/86) ***** -!***** ***** -!*************************************************************** -!*************************************************************** -! -! a= fwa of m x n array -! qtitle - title -! ibeg,jbeg=lower left corner coords to be printed -! up to 43 x 83 points printed -! - real(kind=4) a(m,n),ix(81) - real(kind=4) xm - character qtitle*24 -! -! determine grid limits -! - if(iskip.eq.0) iskip=1 - iend=min0(ibeg+79*iskip,m) - jend=min0(jbeg+79*iskip,n) - - half=0.5 -! - 24 continue -! -! index backwards checking for max -! - 11 xm=0. - jendsc=min0(jend,n) - do j=jbeg,jendsc,iskip - jend_qp = j - do i=ibeg,iend,iskip - xm=max(xm*1.d0,abs(a(i,j))) - end do - end do -! -! determine scaling factor limits -! - if(xm.lt.1.0e-32.or.xm.eq.0.0) xm=99.0 - xm=alog10(99.0/xm) - kp=xm - if(xm.lt.0.0)kp=kp-1 -! -! print scaling constants -! - 12 write(iunit,1) qtitle,kp,iskip,(i,i=ibeg,iend,2*iskip) - - 1 format('0',a,' k=',i3,' iskip=',i2,/,' ',41i6) - fk=10.0**kp -! -! quickprint field -! - do jli=jend_qp,jbeg,-iskip - ii= 0 - if(kp.eq.0) then - do i=ibeg,iend,iskip - ii=ii+1 - ix(ii)=a(i,jli)+sign(half,a(i,jli)) - end do - else - do i=ibeg,iend,iskip - ii=ii+1 - ix(ii)=a(i,jli)*fk+sign(half,a(i,jli)) - end do - end if - write(iunit,'(i4,81i3)') jli,(ix(i),i=1,ii),jli - enddo - return - -end subroutine qprntn - -subroutine smth2d(a,ni,nj,ib,ie,jb,je, & - anu,npass,nnu,ioresp,io,iskip,dx,b,undef) - -!... routine to smooth a 2-d field at subsection of interior points -!... using a noncomplex shuman (1957) smoother-desmoother - - real (kind=4) a(ni,nj),b(ni,nj),anu(nnu) - real (kind=4) pi,rlambda,dx,undef - - logical ioresp,io - character qtitle*24 - -!... output unsmoothed field if io.ne.0 - - if(io) then - call stat2(a,ni,nj,amin,amax,amean,avar,asd) - write(6,12) amean,amin,amax,avar,asd -12 format(' ',/,' ',' input field mean = ',1pe13.4,/ & - ' ',' amin = ',1pe13.4,/ & - ' ',' amax = ',1pe13.4,/ & - ' ',' variance = ',1pe13.4,/ & - ' ',' stnd dev = ',1pe13.4,//) - qtitle='raw field ' - call qprntn(a,qtitle,1,1,ni,nj,iskip,6) - - end if - -! mmmmmmmmmmmmmmmmm main loops, npass, the nus - - do nn=1,npass - - do l=1,nnu - - do i=ib,ie - do j=jb,je - - if( & - a(i,j).eq.undef.or. & - a(i+1,j).eq.undef.or. & - a(i-1,j).eq.undef.or. & - a(i,j-1).eq.undef.or. & - a(i,j+1).eq.undef.or. & - a(i+1,j+1).eq.undef.or. & - a(i+1,j-1).eq.undef.or. & - a(i-1,j-1).eq.undef.or. & - a(i-1,j+1).eq.undef & - ) then - b(i,j)=a(i,j) - - else - - b(i,j)=a(i,j)*(1.0-anu(l))**2 & - + 0.5*anu(l)*(1.0-anu(l))* & - (a(i+1,j)+a(i-1,j)+a(i,j+1)+a(i,j-1)) & - + 0.25*(anu(l)**2)* & - (a(i-1,j-1)+a(i-1,j+1)+a(i+1,j-1)+a(i+1,j+1)) - endif - end do - end do - - do i=ib,ie - do j=jb,je - a(i,j)=b(i,j) - end do - end do - - end do - - end do - - if(ioresp) then - - write(6,200) npass,nnu -200 format(' ',//,' ','smoothing function analysis'/ & - ' ',5x,'number of passes = ',i2/ & - ' ',5x,'number of elements per pass = ',i2) - do k=1,nnu - write(6,201) k,anu(k) -201 format(' ',7x,'k = ',i2, & - ' smoothing coefficient nu = ',f6.3) - end do - - pi=4.0*atan(1.0) - - do i=2,ni - b(i,1)=float(i) - b(i,2)=1.0 - do mm=1,nnu - b(i,2)=b(i,2)*(1.0-anu(mm)*(1.0-cos(2.0*pi/float(i)))) - end do - - b(i,2)=b(i,2)**npass - end do - -! - write(6,222) -222 format(' ','response function as a function of wavelength ', & - 'in grid units*dx',//, & - ' ',' lambda response ',//) -! - do i=2,ni - rlambda=dx*i - write(6,225) rlambda,b(i,2) -225 format(' ',f7.1,3x,f6.3) - end do - - end if - - return - -end subroutine smth2d - -end module libmf - - - - -program fimtopo - - use const - use libmf - - character topodatfile*120,topoglvldir*120 - - real(kind=4), allocatable :: z0out(:) - - namelist /TOPOnamelist/ toponpass,toposmoothfact,& - topodatfile,topoglvldir - - integer :: glvl ! The grid level defined in the Makefile - integer :: SubdivNum(20) ! Subdivision numbers for each recursive refinement(2: bisection, 3: trisection, etc.) - integer :: nvl ! Number of vertical native levels - - namelist /CNTLnamelist/ glvl, SubdivNum, nvl - - OPEN (10,file="FIMnamelist") - READ (10,NML=CNTLnamelist) - close(10) - - - OPEN(12,file="fimtopo.nl") - read(12, nml=TOPOnamelist) - write(*,nml=TOPOnamelist) - close(12) - - - ! - ! fim properties - ! - - nip=10*(2**glvl)**2+2 ! # of icosahedral point - if(glvl <= 9) then - gridscale=15.0*(10-glvl) - else - print*,'EEE invalid glvl must be <= 9' - stop 'bad glvl' - endif - - allocate (z0out(nip),stat=irc) - - call mktopo(topodatfile,topoglvldir,glvl,nip,gridscale,toposmoothfact,toponpass, & - z0out) - - deallocate (z0out) - - stop - -!!$ !dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd -!!$ ! -!!$ ! diagnostic code -!!$ ! -!!$ -!!$ allocate (z0(nip),stat=irc) -!!$ -!!$ compdata='wrf' -!!$ compdata='gfs' -!!$ -!!$ -!!$ open(14,file='g'//cglvl//'z0_'//compdata//'.dat',form='unformatted',status='old',err=801) -!!$ read(14) z0 -!!$ close(14) -!!$ -!!$ open(iunitobs,file='g'//cglvl//'z0'//version//'.obs',form='unformatted',status='unknown',err=812) -!!$ -!!$ z0mnc=0.0 -!!$ z0maxc=-1e20 -!!$ z0minc=1e20 -!!$ -!!$ nmc=0 -!!$ do i=1,nip -!!$ if(z0(i) > -1e10 .and. z0(i) < 1e20) then -!!$ nmc=nmc+1 -!!$ z0mnc=z0mnc+z0(i) -!!$ endif -!!$ -!!$ if(z0(i) < z0minc) z0minc=z0(i) -!!$ if(z0(i) > z0maxc) z0maxc=z0(i) -!!$ enddo -!!$ -!!$ z0mnc=z0mnc/nmc -!!$ -!!$ -!!$ dlon=360.0/(ni) -!!$ dlat=180.0/(nj) -!!$ -!!$ print*,'dlon: ',dlon,' dlat: ',dlat,' elon: ',blon+(ni-1)*dlon,' elat: ',blat+(nj-1)*dlat -!!$ -!!$ radinfj=(gridscale*smoothfact*km2deglat)/dlat -!!$ radinfj=radinfj*0.5 -!!$ -!!$ do i=1,nip -!!$ rlat=lat(i)*rad2deg -!!$ rlon=lon(i)*rad2deg -!!$ if(rlon > 180.0) rlon=rlon-360.0 -!!$ z0in=z0(i) -!!$ call anltopo(z0(i),topo,rlat,rlon,ni,nj,z0out(i)) -!!$ !write(*,'("i:",i6,2x,4f12.3,2x,"ib,ie: ",2(i5,1x),"jb,je: ",2(i5,1x))') i,rlat,rlon,ri,rj,ib,ie,jb,je -!!$ enddo -!!$ -!!$ -!!$ z0mn=0.0 -!!$ z0max=-1e20 -!!$ z0min=1e20 -!!$ -!!$ z0dmn=0.0 -!!$ z0dmna=0.0 -!!$ z0dmax=-1e20 -!!$ z0dmin=1e20 -!!$ -!!$ nm=0 -!!$ do i=1,nip -!!$ -!!$ if(z0(i) > -1e10 .and. z0(i) < 1e20) then -!!$ dz0=z0(i)-z0out(i) -!!$ nm=nm+1 -!!$ z0mn=z0mn+z0out(i) -!!$ z0dmn=z0dmn+dz0 -!!$ z0dmna=z0dmna+abs(dz0) -!!$ -!!$ if(abs(dz0) > 500.0) then -!!$ write(*,'(a,2x,f9.2,2x,f7.2,1x,f7.2)') 'BBBBBBBBBBBBBBB dz0: ',dz0,lat(i)*rad2deg,lon(i)*rad2deg -!!$ endif -!!$ -!!$ if(dz0 < z0dmin) z0dmin=dz0 -!!$ if(dz0 > z0dmax) z0dmax=dz0 -!!$ if(z0out(i) < z0min) z0min=z0out(i) -!!$ if(z0out(i) > z0max) z0max=z0out(i) -!!$ endif -!!$ -!!$ write(stid,'(a1,i7.7)') 's',i -!!$ rlat=lat(i)*rad2deg -!!$ rlon=lon(i)*rad2deg -!!$ tim = 0.0 -!!$ nlev = 1 -!!$ nflag = 1 -!!$ write (iunitobs) stid,rlat,rlon,tim,nlev,nflag -!!$ write (iunitobs) z0out(i) -!!$ -!!$ enddo -!!$ -!!$ z0mn=z0mn/nm -!!$ z0dmn=z0dmn/nm -!!$ z0dmna=z0dmna/nm -!!$ -!!$ print*,' cglvl: ',cglvl -!!$ print*,' compdata: ',compdata -!!$ print*,' gridscale: ',gridscale -!!$ print*,' smoothfact: ',smoothfact -!!$ print*,' radinf in dj units: ',radinfj -!!$ print*,' nip: ',nip -!!$ print*,' nmc,nm: ',nmc,nm -!!$ print* -!!$ print*,' version: ',version -!!$ print* -!!$ print*,' z0mnc,z0mn: ',z0mnc,z0mn -!!$ print*,' z0maxc,z0max: ',z0maxc,z0max -!!$ print*,' z0minc,z0max: ',z0minc,z0min -!!$ print* -!!$ print*,' z0dmn: ',z0dmn -!!$ print*,' z0dmna: ',z0dmna -!!$ print*,' z0dmax: ',z0dmax -!!$ print*,' z0dmin: ',z0dmin -!!$ -!!$ -!!$ -!!$ ! -!!$ ! finalize .obs -!!$ ! -!!$ -!!$ nlev = 0 -!!$ write (iunitobs) stid,rlat,rlon,tim,nlev,nflag -!!$ close(iunitobs) -!!$ -!!$ - - goto 900 -800 continue - print*,'error in open of g?glvl.dat' - -801 continue - print*,'error in open of ',topodatfile - - -802 continue - print*,'read end' - -803 continue - print*,'read err' - -900 continue - stop - -end program fimtopo - - - - -subroutine mktopo(topodatfile,glvldir,glvl,nip,gridscale,smoothfact,npass, & - z0out) - - use const - use libmf - - parameter(ni=4001,nj=2000,nnu=2) - - character(120) :: topodatfile,glvldir,tpath,gpath - character(16) :: header - - real(kind=4), allocatable :: lat(:),lon(:) - - real(4) topo(ni,nj),dum(ni,nj),anu(nnu),z0out(nip) - - integer :: glvl - - logical iosmth2dresp,iosmth2d,diag - - blon=-179.9550 - blat=-89.9550 - - dlon=360.0/(ni) - dlat=180.0/(nj) - - print*,'dlon: ',dlon,' dlat: ',dlat,' elon: ',blon+(ni-1)*dlon,' elat: ',blat+(nj-1)*dlat - - ! - ! allocate arrays - ! - - allocate (lat(nip),lon(nip),stat=irc) - - print*, 'allocate irc = ',irc,' nip: ',nip,gridscale,smoothfact - - iunittopo=10 - iunitglvl=12 - - - gpath=trim(glvldir)//'glvl.dat' - tpath=trim(topodatfile) - - print*,'iiiiiiiiii ',gpath - print*,'tttttttttt ',tpath - - ! - ! read in the glvl.dat for lat/lons - ! - open(iunitglvl,file=gpath,form='unformatted',status='old',err=800) - - read(iunitglvl) header - print*,'h1 ',header - read(iunitglvl) header - - print*,'h2 ',header - read(iunitglvl) lat - read(iunitglvl) lon - close(iunitglvl) - - print*,'HHHHHHHHHHHHHHHHH ',header - - ! - ! read in 5' wrf topo file - ! - - open(iunittopo,file=tpath,form='unformatted',status='old',err=801) - read(iunittopo) topo - - ! - ! smooth topo - ! - - if(npass > 0) then - - ib=1 - ie=ni - jb=1 - je=nj - anu(1)=0.5 - anu(2)=0.5 - undef=1e20 - iskip=1 - dx=gridscale - - call smth2d(topo,ni,nj,ib,ie,jb,je, & - anu,npass,nnu,iosmth2dresp,iosmth2d,iskip,dx,dum,undef) - endif - - ! - ! analyze the topo to the icos grid - ! - - radinf=gridscale*smoothfact*0.5 - radinfj=(radinf*km2deglat)/dlat - - print*,'nnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnn nip:',nip,rad2deg - do i=1,nip - rlat=lat(i)*rad2deg - rlon=lon(i)*rad2deg - if(rlon > 180.0) rlon=rlon-360.0 - z0comp=0.0 - call anltopo(z0comp,topo,rlat,rlon,ni,nj,z0out(i), & - blat,dlat,blon,dlon,radinf,radinfj) - enddo - - - z0outmean=0.0 - z0outmax=-1e20 - z0outmin=1e20 - - nm=0 - do i=1,nip - if(z0out(i) > -1e10 .and. z0out(i) < 1e20) then - nm=nm+1 - z0outmean=z0outmean+z0out(i) - endif - - if(z0out(i) < z0outmin) z0outmin=z0out(i) - if(z0out(i) > z0outmax) z0outmax=z0out(i) - enddo - - z0outmean=z0outmean/nm - - print*,' glvl: ',glvl - print*,' gridscale: ',gridscale - print*,' smoothfact: ',smoothfact - print*,' radinf in dj units: ',radinfj - print*,' nip: ',nip - print*,' nm: ',nm - print* - print*,' version: ',version - print* - print*,' z0outmean: ',z0outmean - print*,' z0outmax: ',z0outmax - print*,' z0outmin: ',z0outmin - print* - - deallocate(lat,lon) - - goto 900 -800 continue - print*,'error in open of g?glvl.dat' - -801 continue - print*,'error in open of ',topodatfile - - -900 continue - stop - return - - -end subroutine mktopo - - - -subroutine anltopo(z0test,topo,rlat,rlon,ni,nj,z0out, & - blat,dlat,blon,dlon,radinf,radinfj) - - use const - - real(4) topo(ni,nj),z0s(ni*20) - - integer verb - - verb=0 - - ri=(rlon-blon)/dlon+1.0 - rj=(rlat-blat)/dlat+1.0 - - rlatfact=cos(rlat*deg2rad) - - radinfi=0.0 - if(rlatfact > 0.0) radinfi=radinfj/rlatfact - - rjb=rj-radinfj-1.0 - rje=rj+radinfj+1.0 - - if(rjb < 1) rjb=1.0 - if(rje > nj) rje=nj - - if(radinfi == 0) then - rib=1 - rie=ni - else - rib=ri-radinfi-1.0 - rie=ri+radinfi+1.0 - endif - - if(rlatfact == 0.0) then - rib=1.0 - rie=ni/2 - else - if(rib < 1) rib=1.0 - if(rie > ni) rie=ni - endif - - ib=nint(rib) - ie=nint(rie) - - jb=nint(rjb) - je=nint(rje) - - if(ib < 1) ib=1 - if(ie > ni) ie=ni - - if(jb < 1) jb=1 - if(je > nj) je=nj - - - z0bar=0.0 - z0rms=0.0 - nz0=0 - - - do ii=ib,ie - do jj=jb,je - tlat=blat+(jj-1)*dlat - tlon=blon+(ii-1)*dlon - dy=(tlat-rlat) - dx=(tlon-rlon)*rlatfact - dist=sqrt(dx*dx+dy*dy)*deglat2km - if(dist < distmin) then - distmin=dist - z0min=topo(ii,jj) - endif - - if(dist <= radinf) then - nz0=nz0+1 - z0s(nz0)=topo(ii,jj) - endif - - end do - end do - - do n=1,nz0 - z0bar=z0bar+z0s(n) - enddo - - if(nz0 > 0) then - z0bar=z0bar/nz0 - else - print*,'in analtopo no points! nz0 = 0',rlat,rlon - stop 'no points' - endif - - if(verb == 1) then - dz0=z0test-z0bar - write(*,'("final",2x,2(f7.2,1x),2x,i6,1x,2(f7.2,1x),2x,(2(f7.2,1x)),2x,4(i5,1x))') & - rlat,rlon,nz0,z0bar,dz0,distmin,z0min,ib,(ie-ib),jb,(je-jb) - endif - - z0out=z0bar - - return - -end subroutine anltopo diff --git a/src/fim/FIMsrc/fimtopo/fimtopo.nl b/src/fim/FIMsrc/fimtopo/fimtopo.nl deleted file mode 100644 index de340f5..0000000 --- a/src/fim/FIMsrc/fimtopo/fimtopo.nl +++ /dev/null @@ -1,6 +0,0 @@ -&TOPOnamelist - toponpass=0, - toposmoothfact=1.25, - topodatfile='/lfs1/projects/rtfim/fimdata/wrf5mintopo.dat', - topoglvldir='./', -/ diff --git a/src/fim/FIMsrc/icosio/Makefile b/src/fim/FIMsrc/icosio/Makefile deleted file mode 100644 index c66740a..0000000 --- a/src/fim/FIMsrc/icosio/Makefile +++ /dev/null @@ -1,15 +0,0 @@ -# icosio Makefile - -# DEFS may include: -DSERIAL for no-MPI build -# -DNOGRIB for no-GRIB build - -all: icosio.o - -icosio.o: icosio_cpp.F90 - $(FC) -c $(FFLAGS) $(GPTL_FFLAGS) icosio_cpp.F90 -o icosio.o - -icosio_cpp.F90: icosio.F90 - $(CPP) $(CPP_FLAGS) $(DEFS) icosio.F90 > icosio_cpp.F90 - -clean: - $(RM) icosio_cpp.F90 icosio.o *.mod diff --git a/src/fim/FIMsrc/icosio/icosio.F90 b/src/fim/FIMsrc/icosio/icosio.F90 deleted file mode 100644 index 621aa45..0000000 --- a/src/fim/FIMsrc/icosio/icosio.F90 +++ /dev/null @@ -1,1790 +0,0 @@ -module icosio - -! NOTE Two cpp tokens, SERIAL and NOGRIB, guard portions of this code. When -! NOTE SERIAL is set, code sections that introduce a dependence on MPI are -! NOTE removed by cpp. Therefore, if SERIAL is *not* set, icosio must be linked -! NOTE with MPI. Likewise, when NOGRIB is set, code sections relating to grib -! NOTE output file production are removed by cpp. For SERIAL, the following -! NOTE convention has been followed: If a routine is unneeded in serial mode but -! NOTE introduces no MPI dependence, it is left alone; if it is unneeded but -! NOTE does introduce an MPI dependence, it is completely removed; and if it -! NOTE is needed in serial mode, only the lines introducing MPI dependencies -! NOTE are removed. If NOGRIB is not set, the three routines post_init_file, -! NOTE post_write_field, and post_finalize_file must be available at link time. - -! TODO Ideally, the necessary grib-production code would be moved into and built -! TODO as part of icosio. - - implicit none - save - private - -#ifndef SERIAL - - include 'mpif.h' - -! Public subroutines defining the icosio API: for parallel builds only - - public icosio_prep,icosio_run - -#endif /* SERIAL */ - -! Public subroutines defining the icosio API: for parallel and serial builds - - public icosio_end_frame,icosio_out,icosio_set_inv_perm,icosio_setup - -! Module parameters (for serial and parallel builds) - - integer,parameter::max_filename_len=80 ! max file name length - integer,parameter::max_header_size=1024 ! max header length - integer,parameter::max_output_files=100 - integer,parameter::max_varname_len=64 ! max variable name length - -! Module variables (for serial and parallel builds) - - character(len=max_filename_len),allocatable::filename_list(:) - character*1000::msg ! buffer for messages - character*2::tasktype='__' ! set to 'ct' or 'wt' in write_share_init() - integer,allocatable::interior_sizes(:) - integer,pointer::inv_perm_global(:)=>null() - integer,pointer::inv_perm_local(:)=>null() - integer,private::size_c,size_i,size_l,size_r ! intrinsic sizes per MPI - integer::comm_framecmd ! mpi derived type for frame commands - integer::comm_varmeta ! mpi derived type for variable metadata - integer::intercomm ! intercommunicator between compute and write tasks - integer::interior_size=0 ! number of interior points on this compute task - integer::intracomm ! communicator for my group - integer::istatus - integer::me ! 0..(n-1) MPI rank - integer::nct=-1 ! number of compute tasks - integer::nwt=-1 ! number of write tasks - integer::outfiles=0 ! number of assigned write tasks - integer::wtindex=0 ! tracks which write task is next to receive data - logical::i_am_compute_root ! am I serial or root of a compute intracommunicator? - logical::i_am_compute_task ! am I a compute task? - logical::i_am_write_root ! am I root of a write intracommunicator? - logical::icosio_setup_called=.false. ! has icosio_setup() been called? - logical::serial ! am I running serial? - logical::single ! am I serial or the only task in my intracommunicator? - -! MPI comm tags - - integer,parameter::tag_cmd=100 - integer,parameter::tag_collect_inv_perm_control=101 - integer,parameter::tag_collect_inv_perm_segment=102 - integer,parameter::tag_collect_var_bounds=103 - integer,parameter::tag_collect_var_segment=104 - integer,parameter::tag_data=105 - integer,parameter::tag_interior_sizes=106 - integer,parameter::tag_inv_perm_control=107 - integer,parameter::tag_inv_perm_data=108 - integer,parameter::tag_metadata=109 - -! These shared variables, set in icosio_setup(), are set directly by the -! calling model code. See icosio_setup() for more details. - - character(len=12)::yyyymmddhhmm='____________' ! Date - integer::comm ! An MPI communicator - integer::filename_len=-1 ! Length of filenames - integer::glvl=-1 ! Grid level - integer::header_size ! Product of header cols x rows - integer::ime=-1 ! Bounds: upper outer - integer::ims=-1 ! Bounds: lower outer - integer::ipe=-1 ! Bounds: upper inner - integer::ips=-1 ! Bounds: lower inner - integer::lunout=-1 ! Use this lun for disk writes - integer::nip=-1 ! Number of icosahedral points - integer::nts=-1 ! Number of time steps - integer::nvl=-1 ! Number of vertical levels - integer::varname_len=-1 ! Length of variable names - logical::binout=.true. ! Write non-grib history files? - logical::client_server_io ! Use client/server io? - logical::debugmsg_on=.false. ! Print verbose status messages? - logical::gribout=.false. ! Write grib files? - logical::i_am_write_task ! Am I a write task? - logical::print_diags ! Only print diagnostics? - logical::using_write_tasks ! Are we using write tasks? - real::dt=-1.0 ! Time step length - -! Packet types for compute-task/write-task communications - - type framecmd - sequence - integer::its=-1 ! Time step - integer::segments=-1 ! # of segments to expect from each compute task - end type framecmd - - type varmeta - sequence - real::scalefactor=1. ! Scale factor for grib output - integer::accum_start=-1 ! Time accumulation factor for grib output - integer::levels=-1 ! Number of vertical levels for this variable - integer::segment_size=-1 ! Bytes in this variable segment - integer::time=-1 ! Time this variable represents - integer::filename_len=-1 ! Length of the supplied filename - character(len=max_varname_len)::varname='' ! Name of the variable - character(len=max_filename_len)::filename='' ! Name of the output file - character::header(max_header_size) ! Header for native binary output -! Padding may be required here if data isn't aligned to 8-byte boundary - end type varmeta - -! Types for buffering data & metadata - - type buffer - integer::segments=0 - type(buffer_node),pointer::current=>null() - type(buffer_node),pointer::head=>null() - end type buffer - - type buffer_node - real,pointer::segment(:)=>null() - type(buffer_node),pointer::next=>null() - type(varmeta)::vm - end type buffer_node - - type(buffer),pointer::buffers(:) ! read/write buffers - -contains - -!-------------------------------------------------------------------------------- - subroutine append_to_list(writetask,varname,levels,segment_size,segment,& - filename,header,time,scalefactor,accum_start) -!-------------------------------------------------------------------------------- - -! Attach a new node to the linked list of buffer nodes for the specified write -! task. If the optional variable name is not specified an empty node is appended; -! otherwise, it is assumed that the rest of the optional arguments are also -! present, and the variable metadata and field data are filled in with the -! supplied values. This is a private routine -- not part of the icosio API. It is -! called by both compute and write tasks. - - character(len=*),intent(in),optional::filename,varname - character,intent(in),optional::header(header_size) - integer,intent(in),optional::levels,segment_size,time,accum_start - integer,intent(in)::writetask - real,intent(in),optional::scalefactor - - character(len=14)::this='append_to_list' - real,pointer,optional::segment(:) - type(buffer),pointer::bp - type(buffer_node),pointer::newnode - -! Allocate a new node, set its variable metadata and point it at the passed-in -! variable data segment. - - allocate(newnode,stat=istatus) - write(msg,'(a,a,a,a,a,i0,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): Failed to allocate new buffer_node.' - call die_if(istatus.ne.0,istatus,msg) - -! "segment" may be large, so use a pointer instead of copying. "segment" is -! deallocated in clear_list(). - - if (present(varname)) then - newnode%vm%levels=levels - newnode%vm%segment_size=segment_size - newnode%vm%varname(1:varname_len)=varname(1:varname_len) - newnode%vm%filename(1:filename_len)=filename(1:filename_len) - newnode%vm%header(1:header_size)=header(1:header_size) - newnode%vm%time=time - newnode%vm%scalefactor=scalefactor - newnode%vm%accum_start=accum_start - newnode%segment=>segment - write(msg,'(a,a,a,a,i0,a,a,a)') this,' (',tasktype,' ',me,& - '): Set varmeta for ',varname,'.' - call debugmsg - endif - -! Append the new node to the appropriate linked list. - - bp=>buffers(writetask) - if (associated(bp%head)) then - bp%current%next=>newnode - else - bp%head=>newnode - endif - bp%current=>newnode - bp%segments=bp%segments+1 - - if (present(varname)) then - write(msg,'(a,a,a,a,i0,a,a,a)') this,' (',tasktype,' ',me,& - '): Appended ',varname,' to list.' - call debugmsg - else - write(msg,'(a,a,a,a,i0,a)') this,' (',tasktype,' ',me,& - '): Appended blank node to list.' - call debugmsg - endif - - end subroutine append_to_list - -!-------------------------------------------------------------------------------- - subroutine buffer_var(its,varname,var,levels,filename,header,time,scalefactor,& - accum_start) -!-------------------------------------------------------------------------------- - -! Buffer data for eventual transmission to write task(s), which is triggered by a -! icosio_flush() call. This is a private routine -- not part of the icosio API. -! It is called only by compute tasks. - - character(len=*),intent(in)::filename,varname - character,intent(in)::header(header_size) - integer,intent(in)::accum_start,its,levels,time - real,intent(in)::scalefactor - real,intent(in)::var(levels,ims:ime) - - character(len=10)::this='buffer_var' - integer::i,ipn,ivl,offset,segment_size,writetask - real,pointer::segment(:) - type(buffer_node),pointer::node - - write(msg,'(a,a,a,a,i0,a,i0,a,a,a)') this,' (',tasktype,' ',me,'): its=',& - its,' varname=',varname(1:varname_len),' entry' - call debugmsg - -! Lay out variable data in a 1D buffer. - - segment_size=levels*interior_size - allocate(segment(segment_size),stat=istatus) - write(msg,'(a,a,a,a,a,i0,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): Failed to allocate segment.' - call die_if(istatus.ne.0,istatus,msg) - offset=0 - do ipn=ips,ipe - do ivl=1,levels - offset=offset+1 - segment(offset)=var(ivl,ipn) - enddo - enddo - - write(msg,'(a,a,a,a,i0,a,a,a)') this,' (',tasktype,' ',me,& - '): Laid out ',varname(1:varname_len),' in 1D buffer.' - call debugmsg - -! Determine which write task will receive this variable. mod() ensures -! round-robin assignment of responsibility for output files to write tasks. -! When there are fewer write tasks than output files, multiple variables will be -! assigned to some write task(s). When there are more write tasks than output -! files, write tasks not used in one output frame may be used in the next. In a -! future enhancement, it may be possible to split a single variable across two or -! more write tasks for output, for scalability. - -! Search the buffers for a matching filename. If we find one, the same -! write task should receive this variable segment as well. - - writetask=0 - do i=1,nwt - node=>buffers(i)%head - do while (associated(node).and.writetask.eq.0) - if (node%vm%filename(1:filename_len).eq.filename(1:filename_len))& - writetask=i - node=>node%next - enddo - if (writetask.ne.0) exit - enddo - -! If no matching filename was found, do round-robin assignment. - - if (writetask.eq.0) then - wtindex=mod(wtindex,nwt) - outfiles=outfiles+1 - wtindex=wtindex+1 - writetask=wtindex - write(msg,'(a,a,a,a,i0,a,a,a,i0,a)') this,' (',tasktype,' ',me,'): ',& - varname(1:varname_len),' assigned to wt ',writetask,' round-robin.' - call debugmsg - else - write(msg,'(a,a,a,a,i0,a,a,a,i0,a)') this,' (',tasktype,' ',me,'): ',& - varname(1:varname_len),' assigned to wt ',writetask,'.' - call debugmsg - endif - -! Buffer data to send later. - - call append_to_list(writetask,varname,levels,segment_size,segment,filename,& - header,time,scalefactor,accum_start) - - write(msg,'(a,a,a,a,i0,a,i0,a,a,a)') this,' (',tasktype,' ',me,'): its=',& - its,' varname=',varname(1:varname_len),' exit' - call debugmsg - - end subroutine buffer_var - -!-------------------------------------------------------------------------------- - subroutine check_setup_called(caller) -!-------------------------------------------------------------------------------- - -! Return with error if icosio_setup() has not been called. - - character(len=*),intent(in)::caller - - write(msg,'(a,a,a,a,a,i0,a)') 'ERROR: ',caller,' (',tasktype,' ',me,& - '): icosio_setup has not been called.' - call die_if(.not.icosio_setup_called,istatus,msg) - - end subroutine check_setup_called - -!-------------------------------------------------------------------------------- - subroutine clear_list -!-------------------------------------------------------------------------------- - -! Walk the list of data buffers for the specified write task and deallocate -! dynamic buffers. Reset the buffer-head pointers & counter. This is a private -! routine -- not part of the icosio API. It is called by both compute and write -! tasks. - - character(len=10)::this='clear_list' - integer::i - type(buffer_node),pointer::node,next - - write(msg,'(a,a,a,a,i0,a)') this,' (',tasktype,' ',me,'): entry' - call debugmsg - - if (associated(buffers)) then - do i=1,size(buffers) - if (associated(buffers(i)%head)) then - node=>buffers(i)%head - do while (associated(node)) - next=>node%next - deallocate(node%segment) - node%segment=>null() - deallocate(node) - node=>next - enddo - endif - buffers(i)%segments=0 - buffers(i)%current=>null() - buffers(i)%head=>null() - enddo - else - write(msg,'(a,a,a,a,a,i0,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): Called but buffers not allocated!' - call die(istatus,msg) - endif - - write(msg,'(a,a,a,a,i0,a)') this,' (',tasktype,' ',me,'): exit' - call debugmsg - - end subroutine clear_list - -!-------------------------------------------------------------------------------- - subroutine collect_inv_perm -!-------------------------------------------------------------------------------- - -! Collect the various segments of the inverse grid permutation array on the -! compute root. This is a private routine -- not parts of the icosio API. It is -! called only by compute tasks, and only when write tasks are not in use. - -! TODO Consider using MPI 2 intercomm collective operations (probably MPI_Gather -! TODO and MPI_Gatherv) to get interior sizes and then global inv_perm. - - character(len=16)::this='collect_inv_perm' - integer::bound(2),ct,inv_perm_global_size,segment_size - - write(msg,'(a,a,a,a,i0,a)') this,' (',tasktype,' ',me,'): entry' - call debugmsg - -! Do some initial error checking. - - write(msg,'(a,a,a,a,a,i0,a,a,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): Calling ',this,' twice is a bug.' - call die_if(associated(inv_perm_global),istatus,msg) - - write(msg,'(a,a,a,a,a,i0,a,a,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): A write task calling ',this,' is a bug.' - call die_if(associated(inv_perm_global),istatus,msg) - -! The association status of inv_perm_global is used to signal the the compute -! root has already collected the necessary global-size inv_perm, so both root -! and non-root compute tasks need to allocate it. So, allocate the compute root's -! inv_perm_global as global size, and allocate the other compute tasks' as a -! single integer. - - if (i_am_compute_root) then - inv_perm_global_size=nip - else - inv_perm_global_size=1 - endif - - allocate(inv_perm_global(inv_perm_global_size),stat=istatus) - write(msg,'(a,a,a,a,a,i0,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): Failed to allocate inv_perm_global.' - call die_if(istatus.ne.0,istatus,msg) - - if (i_am_compute_root) then - -! The compute root already has its own local segment: Copy it into the correct -! location in inv_perm_global. - - inv_perm_global(ips:ipe)=inv_perm_local(ips:ipe) - -! If running in single mode (serial or one-task MPI), inv_perm_global=inv_perm -! on the one and only task, and the previous assignment statement is sufficient, -! so simply return here. - - if (single) then - write(msg,'(a,a,a,a,i0,a)') this,' (',tasktype,' ',me,& - '): Single task returning...' - call debugmsg - return - endif - -#ifndef SERIAL -! Otherwise, the compute root collects the local inv_perm segments from each -! compute task to assemble a global-size inv_perm. - - do ct=1,nct-1 ! MPI tasks start from 0 - - write(msg,'(a,a,a,a,i0,a,i0,a)') this,' (',tasktype,' ',me,& - '): Receiving inv_perm bounds from ',ct,'.' - call debugmsg - -! Receive the start and end indicies of inv_perm_global into which to copy the -! segment about to be received. - - call mpi_recv(bound,2,mpi_integer,ct,tag_collect_inv_perm_control,& - intracomm,mpi_status_ignore,istatus) - write(msg,'(a,a,a,a,a,i0,a,i0)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): MPI_Recv returned ',istatus - call die_if(istatus.ne.mpi_success,istatus,msg) - - segment_size=bound(2)-bound(1)+1 - -! Receive a segment into the appropriate location in the global array. - - write(msg,'(a,a,a,a,i0,a,i0,a)') this,' (',tasktype,' ',me,& - '): Receiving inv_perm segment from ',ct,'.' - call debugmsg - - call mpi_recv(inv_perm_global(bound(1):bound(2)),segment_size,& - mpi_integer,ct,tag_collect_inv_perm_segment,intracomm,& - mpi_status_ignore,istatus) - write(msg,'(a,a,a,a,a,i0,a,i0)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): MPI_Recv returned ',istatus - call die_if(istatus.ne.mpi_success,istatus,msg) - - enddo - - else ! I am a non-root compute task... - - inv_perm_global(1)=-1 ! A default value. - - segment_size=ipe-ips+1 - - bound(1)=ips - bound(2)=ipe - - write(msg,'(a,a,a,a,i0,a)') this,' (',tasktype,' ',me,& - '): Sending inv_perm bounds to root.' - call debugmsg - -! Inform the compute root of the inv_perm_global bounds into which this task's -! segment should be written. - - call mpi_send(bound,2,mpi_integer,0,tag_collect_inv_perm_control,intracomm,& - istatus) - write(msg,'(a,a,a,a,a,i0,a,i0)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): MPI_Send returned ',istatus - call die_if(istatus.ne.mpi_success,istatus,msg) - -! Send this task's segment to the compute root. - - write(msg,'(a,a,a,a,i0,a)') this,' (',tasktype,' ',me,& - '): Sending inv_perm segment to root.' - call debugmsg - - call mpi_send(inv_perm_local(ips:ipe),segment_size,mpi_integer,0,& - tag_collect_inv_perm_segment,intracomm,istatus) - write(msg,'(a,a,a,a,a,i0,a,i0)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): MPI_Send returned ',istatus - call die_if(istatus.ne.mpi_success,istatus,msg) -#endif /* SERIAL */ - - endif ! (i_am_compute_root) - - write(msg,'(a,a,a,a,i0,a)') this,' (',tasktype,' ',me,'): exit' - call debugmsg - - end subroutine collect_inv_perm - -!-------------------------------------------------------------------------------- - subroutine collect_var(var,levels,glbvar) -!-------------------------------------------------------------------------------- - -! Collect the various segments of a global model field array on the compute root. -! This is a private routine -- not parts of the icosio API. It is called only by -! compute tasks, and only when write tasks are not in use. - -! TODO Consider using MPI 2 intercomm collective operations (probably MPI_Gather -! TODO and MPI_Gatherv) to get interior sizes and then global fields. - - integer,intent(in)::levels - real,intent(in)::var(levels,ims:ime) - real,pointer::glbvar(:,:) - - character(len=11)::this='collect_var' - integer::bound(2),ct,segment_size - - if (i_am_compute_root) then - -! Allocate space for a global-size variable. - - allocate(glbvar(levels,nip),stat=istatus) - write(msg,'(a,a,a,a,a,i0,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): Failed to allocate glbvar.' - call die_if(istatus.ne.0,istatus,msg) - -! Copy my local segment into the global array. - - glbvar(:,ips:ipe)=var(:,ips:ipe) - -#ifndef SERIAL -! If nct=1 (i.e. we are 'single') this loop will not execute. - - do ct=1,nct-1 ! MPI tasks start from 0 - -! Receive the start and end indicies of inv_perm_global into which to copy the -! segment about to be received. - - write(msg,'(a,a,a,a,i0,a,i0,a)') this,' (',tasktype,' ',me,& - '): Receiving var bounds from ',ct,'.' - call debugmsg - - call mpi_recv(bound,2,mpi_integer,ct,tag_collect_var_bounds,intracomm,& - mpi_status_ignore,istatus) - write(msg,'(a,a,a,a,a,i0,a,i0)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): MPI_Recv returned ',istatus - call die_if(istatus.ne.mpi_success,istatus,msg) - - segment_size=levels*(bound(2)-bound(1)+1) - -! Receive a segment into the appropriate location in the global array. - - write(msg,'(a,a,a,a,i0,a,i0,a)') this,' (',tasktype,' ',me,& - '): Receiving var segment from ',ct,'.' - call debugmsg - - call mpi_recv(glbvar(:,bound(1):bound(2)),segment_size,mpi_real,ct,& - tag_collect_var_segment,intracomm,mpi_status_ignore,istatus) - write(msg,'(a,a,a,a,a,i0,a,i0)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): MPI_Recv returned ',istatus - call die_if(istatus.ne.mpi_success,istatus,msg) - - enddo - - else ! I am a non-root compute task... - - segment_size=levels*(ipe-ips+1) - - bound(1)=ips - bound(2)=ipe - -! Inform the compute root of the inv_perm_global bounds into which this task's -! segment should be written. - - write(msg,'(a,a,a,a,i0,a)') this,' (',tasktype,' ',me,& - '): Sending var bounds to root.' - call debugmsg - - call mpi_send(bound,2,mpi_integer,0,tag_collect_var_bounds,intracomm,& - istatus) - write(msg,'(a,a,a,a,a,i0,a,i0)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): MPI_Send returned ',istatus - call die_if(istatus.ne.mpi_success,istatus,msg) - -! Send this task's segment to the compute root. - - write(msg,'(a,a,a,a,i0,a)') this,' (',tasktype,' ',me,& - '): Sending var segment to root.' - call debugmsg - - call mpi_send(var(:,ips:ipe),segment_size,mpi_real,0,& - tag_collect_var_segment,intracomm,istatus) - write(msg,'(a,a,a,a,a,i0,a,i0)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): MPI_Send returned ',istatus - call die_if(istatus.ne.mpi_success,istatus,msg) -#endif /* SERIAL */ - - endif ! (i_am_compute_root) - - end subroutine collect_var - -#ifndef SERIAL -!-------------------------------------------------------------------------------- - subroutine comm_type_common(n,counts,offsets,types,comm_type) -!-------------------------------------------------------------------------------- - -! Common steps for creating MPI derived types. This is a private routine -- not -! part of the icosio API. It is called by both compute and write tasks. - - integer,intent(in)::n,counts(:),offsets(:),types(:) - integer,intent(out)::comm_type - - call mpi_type_struct(n,counts,offsets,types,comm_type,istatus) - call die_if(istatus.ne.mpi_success,istatus,'ERROR calling MPI_Type_struct.') - call mpi_type_commit(comm_type,istatus) - call die_if(istatus.ne.mpi_success,istatus,'ERROR calling MPI_Type_commit.') - - end subroutine comm_type_common -#endif /* SERIAL */ - -#ifndef SERIAL -!-------------------------------------------------------------------------------- - subroutine comm_type_framecmd(comm_framecmd) -!-------------------------------------------------------------------------------- - -! MPI derived type to communicate type framecmd (frame command). This is a -! private routine -- not part of the icosio API. It is called by both compute and -! write tasks. - - integer,intent(out)::comm_framecmd - - integer,parameter::n=1 - integer::counts(n),offsets(n),types(n) - - call comm_type_sizes - -! For: its, segments - counts(1)=2 - offsets(1)=0 - types(1)=mpi_integer - - call comm_type_common(n,counts,offsets,types,comm_framecmd) - - end subroutine comm_type_framecmd -#endif /* SERIAL*/ - -#ifndef SERIAL -!-------------------------------------------------------------------------------- - subroutine comm_type_setup -!-------------------------------------------------------------------------------- - -! Create the necessary MPI derived types. This is a private routine -- not part -! of the icosio API. It is called by both compute and write tasks. - - call comm_type_framecmd(comm_framecmd) - call comm_type_varmeta(comm_varmeta) - - end subroutine comm_type_setup -#endif /* SERIAL */ - -#ifndef SERIAL -!-------------------------------------------------------------------------------- - subroutine comm_type_sizes -!-------------------------------------------------------------------------------- - -! Query MPI for the sizes of intrinsic types. This is a private routine -- not -! part of the icosio API. It is called by both compute and write tasks. - - logical::set=.false. - - if (.not.set) then - call mpi_type_extent(mpi_character,size_c,istatus) - call die_if(istatus.ne.mpi_success,istatus,& - 'ERROR calling MPI_Type_extent for MPI_CHARACTER.') - call mpi_type_extent(mpi_integer,size_i,istatus) - call die_if(istatus.ne.mpi_success,istatus,& - 'ERROR calling MPI_Type_extent for MPI_INTEGER.') - call mpi_type_extent(mpi_logical,size_l,istatus) - call die_if(istatus.ne.mpi_success,istatus,& - 'ERROR calling MPI_Type_extent for MPI_LOGICAL.') - call mpi_type_extent(mpi_real,size_r,istatus) - call die_if(istatus.ne.mpi_success,istatus,& - 'ERROR calling MPI_Type_extent for MPI_REAL.') - set=.true. - endif - - end subroutine comm_type_sizes -#endif /* SERIAL */ - -#ifndef SERIAL -!-------------------------------------------------------------------------------- - subroutine comm_type_varmeta(comm_varmeta) -!-------------------------------------------------------------------------------- - -! MPI derived type to communicate type varmeta (variable metadata). This is a -! private routine -- not part of the icosio API. It is called by both compute and -! write tasks. - - integer,intent(out)::comm_varmeta - - integer,parameter::n=3 ! number of MPI kinds - integer::counts(n),offsets(n),types(n) - - call comm_type_sizes - -! For: scalefactor - counts(1)=1 - offsets(1)=0 - types(1)=mpi_real - -! For: accum_start, levels, segment_size, time, filename_len - counts(2)=5 - offsets(2)=offsets(1) + counts(1)*size_r - types(2)=mpi_integer - -! For: varname, filename, header - counts(3)=max_varname_len+max_filename_len+max_header_size - offsets(3)=offsets(2) + counts(2)*size_i - types(3)=mpi_character - - call comm_type_common(n,counts,offsets,types,comm_varmeta) - - end subroutine comm_type_varmeta -#endif /* SERIAL */ - -!-------------------------------------------------------------------------------- - subroutine debugmsg -!-------------------------------------------------------------------------------- - -! Print a message to stdout if verbose debugging is enabled. This is a private -! routine -- not part of the icosio API. It is called by both compute and write -! tasks. - - if (debugmsg_on) then - write (6,'(a,a)') 'DEBUGMSG: ',trim(msg) - call flush(6) - endif - - end subroutine debugmsg - -!-------------------------------------------------------------------------------- - subroutine die(i,message,oldstatus) -!-------------------------------------------------------------------------------- - -! End program after printing the specified message to stdout. This is a private -! routine -- not part of the icosio API. It is called by both compute and write -! tasks. - - integer,intent(inout)::i - character(len=*),intent(in)::message - integer,intent(in),optional::oldstatus - - integer::ignore - - if (present(oldstatus)) then - write (*,"(a,i0)") trim(message),oldstatus - else - write (*,*) trim(message) - endif - call flush(6) -#ifndef SERIAL - call mpi_abort(mpi_comm_world,i,ignore) -#endif /* SERIAL */ - stop - - end subroutine die - -!-------------------------------------------------------------------------------- - subroutine die_if(condition,i,message,oldstatus) -!-------------------------------------------------------------------------------- - -! End program and print message if condition is true. This is a private -! routine -- not part of the icosio API. It is called by both compute and write -! tasks. - - logical,intent(in)::condition - integer,intent(inout)::i - character(len=*),intent(in)::message - integer,intent(in),optional::oldstatus - - if (condition) then - if (present(oldstatus)) then - call die(i,message,oldstatus) - else - call die(i,message) - endif - endif - - end subroutine die_if - -!-------------------------------------------------------------------------------- - subroutine icosio_end_frame(its) -!-------------------------------------------------------------------------------- - -! Reset the list of filenames written to during this output interval. If write -! tasks are not in use, simply return; otherwise, call icosio_flush(). This is a -! public routine -- part of the icosio API. It is called by both compute and -! write tasks. - - integer,intent(in)::its - - character(len=16)::this='icosio_end_frame' - - call check_setup_called(this) - if (allocated(filename_list)) deallocate(filename_list) - if (nwt.eq.0) return -#ifndef SERIAL - call icosio_flush(its) -#endif /* SERIAL */ - - end subroutine icosio_end_frame - -#ifndef SERIAL -!-------------------------------------------------------------------------------- - subroutine flush_one(its,writetask) -!-------------------------------------------------------------------------------- - -! Send the metadata and field-data segments accumulated in one write-task linked- -! list buffer to the appropriate write task. This is a private routine -- not -! part of the icosio API. It is called only by compute tasks. - - integer,intent(in)::its,writetask - - character(len=9)::this='flush_one' - integer::wt - type(buffer_node),pointer::head,node - type(framecmd)::cmd - - write(msg,'(a,a,a,a,i0,a,i0,a,i0,a)') this,' (',tasktype,' ',me,& - '): its=',its,' writetask=',writetask,' entry' - call debugmsg - - head=>buffers(writetask)%head - - if (associated(head)) then - - wt=writetask-1 ! MPI tasks start from 0 - - if ((writetask.lt.1).or.(writetask.gt.nwt)) then - write(msg,'(a,a,a,a,a,i0,a,i0,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): (writetask=',writetask,') Out of range.' - call die(istatus,msg) - endif - -! Send framecmd. A frame command with value > 0 informs the write task that a -! frame of output metadata and field data follows, and its value indicates how -! many different variables' segments will be sent. - - if (i_am_compute_root) then - cmd%its=its - cmd%segments=buffers(writetask)%segments - call mpi_send(cmd,1,comm_framecmd,wt,tag_cmd,intercomm,istatus) - write(msg,'(a,a,a,a,a,i0,a,i0,a,i0,a)') 'ERROR: ',this,' (',tasktype,& - ' ',me,'): MPI_Send of go cmd to wt ',writetask,' returned ',istatus,& - '.' - call die_if(istatus.ne.mpi_success,istatus,msg) - endif - -! Send metadata: Walk the linked list and send the metadata packets. - - node=>head - do while (associated(node)) - write(msg,'(a,a,a,a,i0,a,i0,a,a,a)') this,' (',tasktype,' ',me,& - '): sending wt ',writetask,' ',trim(node%vm%varname),' metadata...' - call debugmsg - call mpi_send(node%vm,1,comm_varmeta,wt,tag_metadata,intercomm,istatus) - write(msg,'(a,a,a,a,a,i0,a,i0,a,i0,a)') 'ERROR: ',this,' (',tasktype,& - ' ',me,'): MPI_Send var meta to ',writetask,' returned ',istatus,'.' - call die_if(istatus.ne.mpi_success,istatus,msg) - node=>node%next - enddo - -! Send variable data: Walk the linked list and send the field data packets. - - node=>head - do while (associated(node)) - call mpi_send(node%segment,node%vm%segment_size,mpi_real,wt,tag_data,& - intercomm,istatus) - write(msg,'(a,a,a,a,a,i0,a,i0,a,i0,a)') 'ERROR: ',this,' (',tasktype,& - ' ',me,'): MPI_Send var data to ',writetask,' returned ',istatus,'.' - call die_if(istatus.ne.mpi_success,istatus,msg) - node=>node%next - enddo - - endif ! associated(head) - - write(msg,'(a,a,a,a,i0,a,i0,a,i0,a)') this,' (',tasktype,' ',me,'): its=',& - its,' writetask=',writetask,' exit' - call debugmsg - - end subroutine flush_one -#endif /* SERIAL */ - -#ifndef SERIAL -!-------------------------------------------------------------------------------- - subroutine icosio_flush(its) -!-------------------------------------------------------------------------------- - -! Send accumulated metadata and field-data segments to all write tasks involed in -! the output of data for this frame. This is a private routine -- not part of -! the icosio API. If is called only by compute tasks. - - integer,intent(in)::its - - character(len=12)::this='icosio_flush' - integer::i,wt,j,k - logical::warning_given=.false. - type(framecmd)::cmd - -! Return if buffers have not accumulated any output data - - if (buffers(1)%segments.eq.0) return - -! Print one-per-file write task layout instructions. - - if (i_am_compute_root.and..not.warning_given) then - if (nwt.eq.1) then - write(*,'(a,i0,a)') 'NOTE: Using one write task for ',outfiles,& - ' output files.' - else if (outfiles.ne.nwt) then - write(*,'(a,i0,a)') 'NOTE: Set num_write_tasks=',outfiles,& - ' in namelist file for a one-per-file write-task layout.' - endif - warning_given=.true. - endif - -! Flush the buffers of all write tasks holding data from the current frame. - - i=mod(outfiles-wtindex,nwt) - if (outfiles.lt.nwt) then - j=outfiles-1 - else - j=nwt-1 - endif - do k=i,i+j - call flush_one(its,mod(k,nwt)+1) - enddo - - call clear_list - -! If this was the terminal timestep, tell the write tasks we're done by sending a -! framecmd packet with a zero value... - - if (its.eq.nts) then - if (i_am_compute_root) then - cmd%segments=0. - do i=1,nwt - wt=i-1 - call mpi_send(cmd,1,comm_framecmd,wt,tag_cmd,intercomm,istatus) - write(msg,'(a,a,a,a,a,i0,a,i0,a,i0,a)') 'ERROR: ',this,' (',tasktype,& - ' ',me,'): MPI_Send terminal cmd to wt ',i,' returned ',istatus,'.' - call die_if(istatus.ne.mpi_success,istatus,msg) - enddo - endif - else ! ...otherwise reset for next frame. - outfiles=0 - endif - - end subroutine icosio_flush -#endif /* SERIAL */ - -#ifndef SERIAL -!-------------------------------------------------------------------------------- - subroutine icosio_prep -!-------------------------------------------------------------------------------- - -! Send some one-time initialization data to write tasks. Allocates some arrays -! needed for communication with write tasks. This is a public routine -- part of -! the icosio API. It is called only by compute tasks. - -! TODO Consider using MPI 2 intercomm collective operations here to broadcast -! TODO interior size and inv_perm segments. - - character(len=11)::this='isocio_prep' - integer::wt - logical::send_inv_perm - - write(msg,'(a,a,a,a,i0,a,i0,a)') this,' (',tasktype,' ',me,'): entry' - call debugmsg - - call check_setup_called(this) - -! Set up MPI derived types. - - call comm_type_setup - -! Allocate dynamic buffers. - - allocate(buffers(nwt),stat=istatus) - write(msg,'(a,a,a,a,a,i0,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): Failed to allocate write buffers.' - call die_if(istatus.ne.0,istatus,msg) - -! Calculate interior points owned by this compute task. - - interior_size=ipe-ips+1 - -! Send interior size to write task(s). - - write(msg,'(a,a,a,a,i0,a)') this,' (',tasktype,' ',me,& - '): Sending interior_size to write tasks.' - call debugmsg - do wt=0,nwt-1 ! MPI tasks start from 0 - call mpi_send(interior_size,1,mpi_integer,wt,tag_interior_sizes,& - intercomm,istatus) - write(msg,'(a,a,a,a,a,i0,a,i0,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): MPI_Send interior_size returned ',istatus,'.' - call die_if(istatus.ne.mpi_success,istatus,msg) - write(msg,'(a,a,a,a,i0,a,i0,a,i0,a)') this,' (',tasktype,' ',me,& - '): Sent interior_size ',interior_size,' to wt ',wt+1,'.' - call debugmsg - enddo - -! If inv_perm_local is associated -- by a call to icosio_set_inv_perm() -- then -! it must be sent to the write task(s). Decide, then let the write task(s) know -! whether or not inv_perm segments will be sent. - - send_inv_perm=.false. - if (associated(inv_perm_local)) then - send_inv_perm=.true. - endif - - write(msg,'(a,a,a,a,i0,a)') this,' (',tasktype,' ',me,& - '): Sending inv_perm control bit to write tasks.' - call debugmsg - - do wt=0,nwt-1 ! MPI tasks start from 0 - call mpi_send(send_inv_perm,1,mpi_logical,wt,tag_inv_perm_control,& - intercomm,istatus) - write(msg,'(a,a,a,a,a,i0,a,i0,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): MPI_Send send_inv_perm returned ',istatus,'.' - call die_if(istatus.ne.mpi_success,istatus,msg) - write(msg,'(a,a,a,a,i0,a,i0,a)') this,' (',tasktype,' ',me,& - '): Sent inv_perm control bit to wt ',wt+1,'.' - call debugmsg - enddo - -! Send local inv_perm segment to write task(s), if needed. - - if (send_inv_perm) then - - write(msg,'(a,a,a,a,i0,a)') this,' (',tasktype,' ',me,& - '): Sending inv_perm segment to write tasks.' - call debugmsg - - do wt=0,nwt-1 ! MPI tasks start from 0 - call mpi_send(inv_perm_local(ips:ipe),interior_size,mpi_integer,wt,& - tag_inv_perm_data,intercomm,istatus) - write(msg,'(a,a,a,a,a,i0,a,i0,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): MPI_Send inv_perm returned ',istatus,'.' - call die_if(istatus.ne.mpi_success,istatus,msg) - write(msg,'(a,a,a,a,i0,a,i0,a)') this,' (',tasktype,' ',me,& - '): Sent inv_perm segment to wt ',wt+1,'.' - call debugmsg - enddo - - endif - - write(msg,'(a,a,a,a,i0,a)') this,' (',tasktype,' ',me,'): exit' - call debugmsg - - end subroutine icosio_prep -#endif /* SERIAL */ - -!-------------------------------------------------------------------------------- - subroutine icosio_out(its,time,varname,var,levels,filename,header,scalefactor,& - accum_start) -!-------------------------------------------------------------------------------- - -! Receive a field-data array and either write it to disk directly, or buffer it -! for a later transmisstion to write task(s). This is a public routine -- part of -! the icosio API. It is called only by compute tasks. - - character(len=*),intent(in)::filename,varname - character,intent(in)::header(header_size) - integer,intent(in),optional::accum_start - integer,intent(in)::levels,its,time - real,intent(in),optional::scalefactor - real,intent(in)::var(levels,ims:ime) - - character(len=10)::this='icosio_out' - integer::accum_start_local - real,pointer::glbvar(:,:) - real::scalefactor_local - - call check_setup_called(this) - -! Set default values for scalefactor (factor to scale input by for grib output) -! and accum_start (accumulation start) if not provided by caller. - - scalefactor_local=1. - if (present(scalefactor)) scalefactor_local=scalefactor - - accum_start_local=-1 - if (present(accum_start)) accum_start_local=accum_start - -! If write tasks are in use, buffer data for eventual overlapped write; -! otherwise, write data directly. - - if (using_write_tasks) then - - call buffer_var(its,varname,var,levels,filename,header,time,& - scalefactor_local,accum_start_local) - - else - -! Collect inv_perm on the compute root if fixed grid-order reordering is needed. - - if (i_am_compute_task) then - if (associated(inv_perm_local)) then - if (.not.associated(inv_perm_global)) then - call collect_inv_perm - endif - endif - endif - -! If running in single mode (serial or one-task MPI), write the array immediately -! to disk. Otherwise, collect the distributed array onto the compute root and -! then write to disk. - - if (single) then - call var_to_disk(accum_start_local,ips,ims,ipe,ime,filename,header,its,& - levels,scalefactor_local,time,var,varname) - else - call collect_var(var,levels,glbvar) - if (i_am_compute_root) then - call var_to_disk(accum_start_local,1,1,nip,nip,filename,header,its,& - levels,scalefactor_local,time,glbvar,varname) - deallocate(glbvar) - endif - endif - - endif - - end subroutine icosio_out - -#ifndef SERIAL -!-------------------------------------------------------------------------------- - subroutine icosio_run -!-------------------------------------------------------------------------------- - -! Main routine for write tasks. Allocate dynamic buffers, receive some one-time -! data, then enter a loop waiting for and responding to frame commands, which -! trigger either the receipt and output of a frame of output data, or stop. This -! is a public routine -- part of the icosio API. It is called only by write -! tasks. - -! TODO Consider using MPI 2 intercomm collective operations here to broadcast -! TODO (receive, in ths case) interior size and inv_perm segments. - - character(len=10)::this='icosio_run' - integer::ct,offset - logical::recv_inv_perm,running=.true. - type(framecmd)::cmd - - call check_setup_called(this) - -! If the model is running in an "only print diagnostics" mode, either stop or -! return, depending on the client/server io settting. - - if (print_diags) then - if (client_server_io) then - call mpi_finalize(istatus) - stop - else - return - endif - endif - -! Set up MPI derived types. - - call comm_type_setup - -! Allocate dynamic buffers. - - allocate(buffers(nct),stat=istatus) - write(msg,'(a,a,a,a,a,i0,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): Failed to allocate buffers.' - call die_if(istatus.ne.0,istatus,msg) - -! Allocate and receive interior sizes from compute task(s). - - write(msg,'(a,a,a,a,i0,a)') this,' (',tasktype,' ',me,& - '): Receiving interior sizes from compute tasks.' - call debugmsg - - allocate(interior_sizes(0:nct-1),stat=istatus) - write(msg,'(a,a,a,a,a,i0,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): Failed to allocate interior_sizes.' - call die_if(istatus.ne.0,istatus,msg) - - do ct=0,nct-1 - call mpi_recv(interior_sizes(ct),1,mpi_integer,ct,tag_interior_sizes,& - intercomm,mpi_status_ignore,istatus) - write(msg,'(a,a,a,a,a,i0,a,i0,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): MPI_Recv interior_sizes returned ',istatus,'.' - call die_if(istatus.ne.mpi_success,istatus,msg) - write(msg,'(a,a,a,a,i0,a,i0,a,i0,a)') this,' (',tasktype,' ',me,& - '): Received interior size ',interior_sizes(ct),' from ct ',ct,'.' - call debugmsg - enddo - -! Allocate and receive from compute task(s) inv_perm, if needed. - - call mpi_recv(recv_inv_perm,1,mpi_logical,0,tag_inv_perm_control,& - intercomm,mpi_status_ignore,istatus) - write(msg,'(a,a,a,a,a,i0,a,i0,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): MPI_Recv recv_inv_perm returned ',istatus,'.' - call die_if(istatus.ne.mpi_success,istatus,msg) - write(msg,'(a,a,a,a,i0,a,i0,a)') this,' (',tasktype,' ',me,& - '): Received inv_perm control bit from ct ',ct,'.' - call debugmsg - - if (recv_inv_perm) then - - allocate(inv_perm_global(nip),stat=istatus) - write(msg,'(a,a,a,a,a,i0,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): Failed to allocate inv_perm_global.' - call die_if(istatus.ne.0,istatus,msg) - - offset=1 - do ct=0,nct-1 - call mpi_recv(inv_perm_global(offset:offset-1+interior_sizes(ct)),& - interior_sizes(ct),mpi_integer,ct,tag_inv_perm_data,intercomm,& - mpi_status_ignore,istatus) - write(msg,'(a,a,a,a,a,i0,a,i0,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): MPI_Recv inv_perm_global returned ',istatus,'.' - call die_if(istatus.ne.mpi_success,istatus,msg) - write(msg,'(a,a,a,a,i0,a,i0,a)') this,' (',tasktype,' ',me,& - '): Received inv_perm segment from ct ',ct,'.' - call debugmsg - offset=offset+interior_sizes(ct) - enddo - - endif ! (recv_inv_perm) - -! Main loop - - do while (running) - -! Receve a frame command from the compute root. - - call mpi_recv(cmd,1,comm_framecmd,0,tag_cmd,intercomm,& - mpi_status_ignore,istatus) - write(msg,'(a,a,a,a,a,i0,a,i0,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): MPI_Recv cmd returned ',istatus,'.' - call die_if(istatus.ne.mpi_success,istatus,msg) - call die_if(cmd%segments.lt.0,istatus,'framecmd segment count < 0.') - -! If a zero frame command value was sent, stop in the appriate manner... - - if (cmd%segments.eq.0) then - write(msg,'(a,a,a,a,i0,a)') this,' (',tasktype,' ',me,& - '): Stop command received.' - call debugmsg - running=.false. - if (client_server_io) then - write(msg,'(a,a,a,a,i0,a)') this,' (',tasktype,' ',me,& - '): Client-server mode enabled, stopping...' - call debugmsg - call mpi_finalize(istatus) - stop - else - return - endif - else ! ...otherwise, process the incoming frame of output data. - write(msg,'(a,a,a,a,i0,a,i0,a)') this,' (',tasktype,' ',me,& - '): its=',cmd%its,' Go command received.' - call debugmsg - call process_frame(cmd%its,cmd%segments) - endif - enddo - - end subroutine icosio_run -#endif /* SERIAL */ - -!-------------------------------------------------------------------------------- - subroutine icosio_set_inv_perm(inv_perm_in) -!-------------------------------------------------------------------------------- - -! Point inv_perm_local to the supplied inv_perm segment. If this routine is -! called, icosio assumes that grid reordering (via a reassembled global-size -! inverse grid permutation array) should be applied to variables before they are -! written to disk. Otherwise, arrays will be written as-is. This is a public -! routine -- part of the icosio inteface. It is called only by compute tasks. - - character(len=19)::this='icosio_set_inv_perm' - integer,allocatable,target,intent(in)::inv_perm_in(:) - - call check_setup_called(this) - - inv_perm_local=>inv_perm_in - - end subroutine icosio_set_inv_perm - -!-------------------------------------------------------------------------------- - subroutine icosio_setup(binout_in,client_server_io_in,comm_in,debugmsg_on_in,& - dt_in,filename_len_in,glvl_in,gribout_in,header_size_in,i_am_write_task_in,& - ips_in,ims_in,ipe_in,ime_in,lunout_in,nip_in,nts_in,nvl_in,print_diags_in,& - using_write_tasks_in,varname_len_in,yyyymmddhhmm_in) -!-------------------------------------------------------------------------------- - -! Sets values known by the calling model and required by icosio. This is a public -! routine -- part of the icosio API. It is called by both compute and write -! tasks. - - character(len=12),intent(in)::yyyymmddhhmm_in - integer,intent(in)::comm_in,filename_len_in,glvl_in,header_size_in,ims_in,& - ips_in,ipe_in,ime_in,lunout_in,nip_in,nts_in,nvl_in,varname_len_in - logical,intent(in)::binout_in,client_server_io_in,debugmsg_on_in,gribout_in,& - i_am_write_task_in,print_diags_in,using_write_tasks_in - real,intent(in)::dt_in - - character(len=12)::this='icosio_setup' - integer::group - logical::have_intercomm - -! Set module variables. -! -! A number of necessary parameters are deduced from three settings: comm, -! i_am_write_task, and using_write_tasks. If write tasks are in use, comm must -! be an intercommunicator between the compute and write tasks; otherwise, it must -! be an intracommunicator for the compute tasks. The two logical values have the -! obvious meanings. - - binout=binout_in - client_server_io=client_server_io_in - comm=comm_in - debugmsg_on=debugmsg_on_in - dt=dt_in - filename_len=filename_len_in - glvl=glvl_in - gribout=gribout_in - header_size=header_size_in - i_am_write_task=i_am_write_task_in - ime=ime_in - ims=ims_in - ipe=ipe_in - ips=ips_in - lunout=lunout_in - nip=nip_in - nts=nts_in - nvl=nvl_in - print_diags=print_diags_in - using_write_tasks=using_write_tasks_in - varname_len=varname_len_in - yyyymmddhhmm=yyyymmddhhmm_in - -! Set serial non-MPI defaults. - - i_am_compute_root=.true. - i_am_compute_task=.true. - i_am_write_root=.false. - me=0 - nct=1 - nwt=0 - serial=.true. - single=.true. - tasktype='ct' - -#ifndef SERIAL - intercomm=mpi_comm_null ! default value - intracomm=mpi_comm_null ! default value - -! Override defaults. - - if (using_write_tasks) then - call mpi_comm_test_inter(comm,have_intercomm,istatus) - write(msg,'(a,a,a,a,a,i0,a,i0)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): MPI_Comm_test_inter returned ',istatus - call die_if(istatus.ne.mpi_success,istatus,msg) - write(msg,'(a,a,a,a,a,i0,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): Pass icosio an intercommunicator when write tasks are enabled.' - call die_if(.not.have_intercomm,istatus,msg) - call mpi_comm_group(comm,group,istatus) - write(msg,'(a,a,a,a,a,i0,a,i0)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): MPI_Comm_group returned ',istatus - call die_if(istatus.ne.mpi_success,istatus,msg) - call mpi_comm_create(comm,group,intracomm,istatus) - write(msg,'(a,a,a,a,a,i0,a,i0)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): MPI_Comm_create returned ',istatus - call die_if(istatus.ne.mpi_success,istatus,msg) - intercomm=comm - else if (comm.ne.mpi_comm_null) then - call mpi_comm_test_inter(comm,have_intercomm,istatus) - write(msg,'(a,a,a,a,a,i0,a,i0)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): MPI_Comm_test_inter returned ',istatus - call die_if(istatus.ne.mpi_success,istatus,msg) - write(msg,'(a,a,a,a,a,i0,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): Pass icosio an intracommunicator when write tasks are disabled.' - call die_if(have_intercomm,istatus,msg) - intracomm=comm - endif - - if (i_am_write_task) then - call mpi_comm_rank(intracomm,me,istatus) - write(msg,'(a,a,a,a,a,i0,a,i0)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): MPI_Comm_rank returned ',istatus - call die_if(istatus.ne.mpi_success,istatus,msg) - call mpi_comm_remote_size(intercomm,nct,istatus) - write(msg,'(a,a,a,a,a,i0,a,i0)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): MPI_Comm_remote_size returned ',istatus - call die_if(istatus.ne.mpi_success,istatus,msg) - call mpi_comm_size(intracomm,nwt,istatus) - write(msg,'(a,a,a,a,a,i0,a,i0)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): MPI_Comm_size returned ',istatus - call die_if(istatus.ne.mpi_success,istatus,msg) - i_am_compute_root=.false. - i_am_compute_task=.false. - serial=.false. - if (nwt.gt.1) single=.false. - tasktype='wt' - if (me.eq.0) i_am_write_root=.true. - else - if (intracomm.ne.mpi_comm_null) then - call mpi_comm_rank(intracomm,me,istatus) - write(msg,'(a,a,a,a,a,i0,a,i0)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): MPI_Comm_rank returned ',istatus - call die_if(istatus.ne.mpi_success,istatus,msg) - call mpi_comm_size(intracomm,nct,istatus) - write(msg,'(a,a,a,a,a,i0,a,i0)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): MPI_Comm_size returned ',istatus - call die_if(istatus.ne.mpi_success,istatus,msg) - if (me.ne.mpi_success) i_am_compute_root=.false. - serial=.false. - if (nct.ne.1) single=.false. - endif - if (intercomm.ne.mpi_comm_null) then - call mpi_comm_remote_size(intercomm,nwt,istatus) - write(msg,'(a,a,a,a,a,i0,a,i0)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): MPI_Comm_remote_size returned ',istatus - call die_if(istatus.ne.mpi_success,istatus,msg) - endif - endif -#endif /* SERIAL */ - -! Check for problems. - - write(msg,'(a,a,a,a,a,i0,a,i0,a,i0,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): model filename length (',filename_len,') exceeds icosio max (',& - max_filename_len,'). Adjust "max_filename_len" parameter in icosio.' - call die_if(filename_len.gt.max_filename_len,istatus,msg) - - write(msg,'(a,a,a,a,a,i0,a,i0,a,i0,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): model varname length (',varname_len,') exceeds icosio max (',& - max_varname_len,'). Adjust "max_varname_len" parameter in icosio.' - call die_if(varname_len.gt.max_varname_len,istatus,msg) - - write(msg,'(a,a,a,a,a,i0,a,i0,a,i0,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): model header size (',header_size,') exceeds icosio max (',& - max_header_size,'). Adjust "max_header_size" parameter in icosio.' - call die_if(varname_len.gt.max_varname_len,istatus,msg) - -! Record that icosio_setup has run. - - icosio_setup_called=.true. - -#ifndef SERIAL -! If I am a write task, enter client-server mode if selected. - - if (i_am_write_task.and.client_server_io) call icosio_run -#endif - - end subroutine icosio_setup - -#ifndef SERIAL -!-------------------------------------------------------------------------------- - subroutine process_frame(its,segments) -!-------------------------------------------------------------------------------- - -! Receive metadata and field data from compute tasks, then write to disk. This is -! a public routine -- part of the icosio API. It is called only by write tasks. - - integer,intent(in)::its,segments - - character(len=13)::this='process_frame' - integer::ct,ctbuffer,isegment - type(buffer_node),pointer::node - - write(msg,'(a,a,a,a,i0,a,i0,a,i0,a)') this,' (',tasktype,' ',me,'): its=',& - its,' segments=',segments,' entry' - call debugmsg - -! Receive metadata. - - write(msg,'(a,a,a,a,i0,a,i0,a)') this,' (',tasktype,' ',me,& - '): receiving variable metadata for its=',its,'.' - call debugmsg - do ct=0,nct-1 - ctbuffer=ct+1 - do isegment=1,segments - call append_to_list(ctbuffer) ! append an empty buffer node - node=>buffers(ctbuffer)%current - call mpi_recv(node%vm,1,comm_varmeta,ct,tag_metadata,intercomm,& - mpi_status_ignore,istatus) - write(msg,'(a,a,a,a,a,i0,a,i0,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): MPI_Recv metadata returned ',istatus,'.' - call die_if(istatus.ne.mpi_success,istatus,msg) - write(msg,'(a,a,a,a,i0,a,i0,a,a,a,i0,a)') this,' (',tasktype,' ',me,& - '): its=',its,' received ',node%vm%varname(1:varname_len),& - ' metadata: allocating ',node%vm%segment_size,& - ' bytes for variable data.' - call debugmsg - allocate(node%segment(node%vm%segment_size),stat=istatus) - write(msg,'(a,a,a,a,a,i0,a,a,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): Allocate failed for ',node%vm%varname(1:varname_len),' segment.' - call die_if(istatus.ne.0,istatus,msg) - enddo - enddo - write(msg,'(a,a,a,a,i0,a,i0,a)') this,' (',tasktype,' ',me,& - '): received variable metadata for its=',its,'.' - call debugmsg - -! Receive variable data. - - write(msg,'(a,a,a,a,i0,a,i0,a)') this,' (',tasktype,' ',me,& - '): receiving variable data for its=',its,'.' - call debugmsg - do ct=0,nct-1 - ctbuffer=ct+1 - node=>buffers(ctbuffer)%head - do while (associated(node)) - call mpi_recv(node%segment,node%vm%segment_size,mpi_real,ct,tag_data,& - intercomm,mpi_status_ignore,istatus) - write (msg,'(a,a,a,a,a,i0,a,i0,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): MPI_Recv variable data returned ',istatus,'.' - call die_if(istatus.ne.mpi_success,istatus,msg) - write(msg,'(a,a,a,a,i0,a,i0,a,a,a)') this,' (',tasktype,' ',me,& - '): its=',its,' received ',node%vm%varname(1:varname_len),& - ' variable data.' - call debugmsg - node=>node%next - enddo - enddo - write(msg,'(a,a,a,a,i0,a,i0,a)') this,' (',tasktype,' ',me,& - '): received variable data for its=',its,'.' - call debugmsg - call write_vars_to_disk(its) - call clear_list - write(msg,'(a,a,a,a,i0,a,i0,a,i0,a)') this,' (',tasktype,' ',me,'): its=',& - its,' segments=',segments,' exit' - call debugmsg - - end subroutine process_frame -#endif /* SERIAL */ - -!-------------------------------------------------------------------------------- - subroutine var_to_disk(accum_start,ips,ims,ipe,ime,filename,header,its,levels,& - scalefactor,time,var,varname) -!-------------------------------------------------------------------------------- - -! Write a global-size model field array to disk. This is a private routine -- not -! part of the icosio API. It is called by both compute and write tasks. - - character(len=*),intent(in)::filename,varname - character,intent(in)::header(header_size) - integer,intent(in)::accum_start,ips,ims,ipe,ime,its,levels,time - real,intent(in)::scalefactor,var(levels,ims:ime) - - character(len=11)::this='var_to_disk' - integer::index,ipn,ivl - integer,save::count - logical::append - real,allocatable::reordered_var(:,:) - -! If the list of filenames that have already been written to during this output -! frame has not already been allocated, do that now and zero its associated -! counter. - - if (.not.allocated(filename_list)) then - allocate(filename_list(max_output_files),stat=istatus) - write(msg,'(a,a,a,a,a,i0,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): failed to allocate filename_list.' - call die_if(istatus.ne.0,istatus,msg) - count=0 - endif - -! Determine whether or not we need to append to the output file: If the current -! filename appears in the list of files we've already written to this frame, -! we will append; otherwise we will create a new file, potentially overwriting -! any existing file (as may be the case for restart runs). - - append=.false. - do index=1,count - if (trim(filename).eq.trim(filename_list(index))) then - append=.true. - exit - endif - enddo - -! If we've decided not to append, check that we're not exceeding the size of -! our list of already-written-to filenames. If that's ok, increment the counter -! and record the current filename. - - if (.not.append) then - count=count+1 - write(msg,'(a,a,a,a,a,i0,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): max_output_files limit exceeded.' - call die_if(count.gt.max_output_files,istatus,msg) - filename_list(count)=filename - endif - -! If non-grib binary history output is enabled: - - if (binout) then - if (append) then - open (lunout,file=filename(1:filename_len),form="unformatted",& - iostat=istatus,position="append") - else - open (lunout,file=filename(1:filename_len),form="unformatted",& - iostat=istatus) - endif - write(msg,'(a,a,a,a,a,i0,a,a,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): failed to open file ',filename(1:filename_len),'.' - call die_if(istatus.ne.0,istatus,msg) - write(msg,'(a,a,a,a,a)') 'ERROR: ',this,': Could not open file ',& - filename(1:filename_len),'.' - write (lunout) header - if (associated(inv_perm_global)) then - allocate(reordered_var(levels,ipe-ips+1)) - do ipn=ips,ipe - do ivl=1,levels - reordered_var(ivl,ipn)=var(ivl,inv_perm_global(ipn)) - enddo - enddo - write (lunout) reordered_var - deallocate(reordered_var) - else - write (lunout) var(:,ips:ipe) - endif - write(msg,'(a,a,a,a,i0,a,a,a)') this,' (',tasktype,' ',me,& - '): Wrote binary FIM field ',varname(1:varname_len),'.' - call debugmsg - close (lunout) - endif - -#ifndef NOGRIB -! If grib output is enabled: - - if (gribout) then - call post_write_field(var,varname(1:varname_len),scalefactor,accum_start,& - istatus) - write(msg,'(a,a,a,a,a,i0,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): Bad return from post_write_field.' - call die_if(istatus.ne.0,istatus,msg) - endif -#endif /* NOGRIB */ - - end subroutine var_to_disk - -!-------------------------------------------------------------------------------- - subroutine write_vars_to_disk(its) -!-------------------------------------------------------------------------------- - -! Write to disk one output frame of all the variables for which this write task -! is responsible. If grib output is enabled, one one write task is allowed: The -! single write task open the grib file, writes all necessary data to it, then -! closes the file. This is a private routine -- not part of the icosio API. It -! is called only by write tasks. - -! Array "glbvar" is allocated and deallocated inside of a while loop over -! variables, so its size neveer exceeds that of a single 3D global variable. - - integer,intent(in)::its - - type buffer_node_ptr - type(buffer_node),pointer::ptr=>null() - end type buffer_node_ptr - - character(len=18)::this='write_vars_to_disk' - character(len=max_filename_len)::filename - character(len=max_varname_len)::varname - integer::accum_start,inode,ipn,ipns,ipnstart,istatus,levels,offset,ret,time - real,pointer::glbvar(:,:),segment(:) - real::scalefactor - type(buffer_node),pointer::master - type(buffer_node_ptr),pointer::nodes(:) - - write(msg,'(a,a,a,a,i0,a,i0,a)') this,' (',tasktype,' ',me,'): its=',its,& - ' entry' - call debugmsg - -! Allocate buffer node pointers, one per compute task. - - allocate(nodes(nct),stat=istatus) - write(msg,'(a,a,a,a,a,i0,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): Failed to allocate nodes.' - call die_if(istatus.ne.0,istatus,msg) - -! Point the buffer node pointers to the list heads. - - do inode=1,size(nodes) - nodes(inode)%ptr=>buffers(inode)%head - enddo - - master=>nodes(1)%ptr ! Set the master pointer - -#ifndef NOGRIB -! If gribout enabled, open the grib file. - - if (gribout) then - time=master%vm%time - call post_init_file(time,istatus) - write (msg,'(a,a,a,a,a,i0,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): post_init_file failed.' - call die_if (istatus.ne.0,istatus,msg) - - write (msg,'(a,a,a,a,i0,a,i0,a)') this,' (',tasktype,' ',me,& - '): post_init_file opened grib file time=',time,'.' - call debugmsg - endif -#endif /* NOGRIB */ - -! Allocate & populate the global variable buffer and have it written to disk. - - do while (associated(master)) ! One iteration per variable - - accum_start=master%vm%accum_start - filename(1:filename_len)=master%vm%filename(1:filename_len) - levels=master%vm%levels - scalefactor=master%vm%scalefactor - time=master%vm%time - varname(1:varname_len)=master%vm%varname(1:varname_len) - - allocate(glbvar(levels,nip),stat=istatus) - write(msg,'(a,a,a,a,a,i0,a)') 'ERROR: ',this,' (',tasktype,' ',me,& - '): Failed to allocate glbvar.' - call die_if(istatus.ne.0,istatus,msg) - -! Copy data from buffer nodes into global buffer. - - ipnstart=1 - do inode=1,size(nodes) - segment=>nodes(inode)%ptr%segment - ipns=nodes(inode)%ptr%vm%segment_size/levels - offset=1 - do ipn=1,ipns - glbvar(1:levels,ipnstart-1+ipn)=segment(offset:offset-1+levels) - offset=offset+levels - enddo - ipnstart=ipnstart+ipns - enddo - - call var_to_disk(accum_start,1,1,nip,nip,filename,& - master%vm%header(1:header_size),its,levels,scalefactor,time,glbvar,& - varname) - -! Step forward in buffer node list to handle another variable. - - do inode=1,size(nodes) - nodes(inode)%ptr=>nodes(inode)%ptr%next - enddo - master=>nodes(1)%ptr - - deallocate(glbvar) - - enddo - -! Reset the list of filenames written to during this output interval. - - if (allocated(filename_list)) deallocate(filename_list) - - write(msg,'(a,a,a,a,i0,a,i0,a)') this,' (',tasktype,' ',me,'): its=',its,& - ' exit' - call debugmsg - -#ifndef NOGRIB -! Close the output grib file. - - if (gribout) then - call post_finalize_file(ret) - write (msg,'(a,a,a,a,i0,a,i0,a)') this,' (',tasktype,' ',me,& - '): post_finalize_file closed grib file time=',time,'.' - call debugmsg - endif -#endif - - end subroutine write_vars_to_disk - -end module icosio diff --git a/src/fim/FIMsrc/macros.make.bluefire b/src/fim/FIMsrc/macros.make.bluefire deleted file mode 100644 index a97899e..0000000 --- a/src/fim/FIMsrc/macros.make.bluefire +++ /dev/null @@ -1,82 +0,0 @@ -# Target being built (i.e. as defined by makefim ) -MAKEFIM_TARGET = bluefire - -# Preprocessor and flags -CPP = /lib/cpp -CPP_FLAGS = -C -P - -# Number of parallel tasks for gmake (NOTE: horizontal/ still must be serial) -GMAKEMINUSJ = -j8 - -# Record control word flag (currently required only by gfortran: specifies 4-byte RCW) -RCWFLAG = - -# Optimization flags -OPTFLAGS = - -# Load flags. In most cases this can be empty due to the use of MPI compiler wrappers -#JR the following give around a 10% performance boost on vapor -LDFLAGS = -lmass -lmassv - -# cpp ifdef for Fortran name-mangling (needed when linebuf_stdout.c is enabled). Options are: -# FORTRAN_UNDERSCORING = -DFORTRANUNDERSCORE -# FORTRAN_UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE -# FORTRAN_UNDERSCORING = -FORTRAN_UNDERSCORING = - -# To turn on debugging, set DEBUG=yes. When DEBUG=yes, default optimization level is -O0 -# but it can be changed here -DEBUG = no -ifeq ($(DEBUG),yes) - OPTFLAGS = -g -O0 -endif - -# gfortran doesn't provide all degree-based trig functions as intrinsics -# Most compilers provide these and it is safe to set NEED_SINDCOSD = no -NEED_SINDCOSD = no - -# To enable attaching a debugger such as gdb or ddd to a running process, set ATTACH_DEBUGGER = yes -ATTACH_DEBUGGER = no - -# Whether to enable FIM profiling using GPTL. -USE_GPTL = no -ifeq ($(USE_GPTL),yes) -# Set include path for GPTL - GPTL_CPPFLAGS = -I/blhome/rosinski/aix/include -# For auto-profiling of MPI functions, set USE_PMPI=yes. The name of the GPTL -# library in this case is libgptl_pmpi.a. Otherwise the name is libgptl.a - USE_PMPI = no - ifeq ($(USE_PMPI),yes) - GPTL_LDFLAGS = -L -lgptl_pmpi -# When auto-profiling the MPI layer, set HAVE_IARGCGETARG=yes if the Fortran -# compiler supports functions iargc and getarg. - HAVE_IARGCGETARG = no - else - GPTL_LDFLAGS = -L/blhome/rosinski/aix/lib -lgptl - endif -# AUTOINST=yes enables function-level compiler-generated auto-profiling, - AUTOINST = no - ifeq ($(AUTOINST),yes) - GPTL_FFLAGS = -qdebug=function_trace -g -O2 - GPTL_LDFLAGS += -qdebug=function_trace - endif -# If GPTL was built with PAPI support, add the required flags - HAVE_PAPI = yes - ifeq ($(HAVE_PAPI),yes) - GPTL_LDFLAGS += -lpapi - endif -# Need to call GPTL init and print functions manually when GPTL enabled and HAVE_IARGCGETARG -# isn't set. These functions are called automatically from GPTL MPI wrappers when -# HAVE_IARGCGETARG is set - ifneq ($(HAVE_IARGCGETARG),yes) - GPTL_CPPFLAGS += -DMANUALGPTL - endif -endif - -# SMS library location -ifeq ($(USE_GPTL),yes) -# If available, use SMS version compiled with auto-profiling flag - SMS = /blhome/rosinski/sms_r226 -else - SMS = /blhome/rosinski/sms_r226 -endif diff --git a/src/fim/FIMsrc/macros.make.debug b/src/fim/FIMsrc/macros.make.debug deleted file mode 100644 index 9591ef2..0000000 --- a/src/fim/FIMsrc/macros.make.debug +++ /dev/null @@ -1,80 +0,0 @@ -# Target being built (i.e. as defined by makefim ) -MAKEFIM_TARGET = debug - -# Preprocessor and flags -CPP = /lib/cpp -CPP_FLAGS = -C -P - -# Number of parallel tasks for gmake (NOTE: horizontal/ still must be serial) -GMAKEMINUSJ = -j8 - -# Record control word flag (currently required only by gfortran: specifies 4-byte RCW) -RCWFLAG = - -# Optimization flags -OPTFLAGS = - -# Load flags. In most cases this can be empty due to the use of MPI compiler wrappers -LDFLAGS = - -# cpp ifdef for Fortran name-mangling (needed when linebuf_stdout.c is enabled). Options are: -# FORTRAN_UNDERSCORING = -DFORTRANUNDERSCORE -# FORTRAN_UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE -# FORTRAN_UNDERSCORING = -FORTRAN_UNDERSCORING = -DFORTRANUNDERSCORE - -# To turn on debugging, set DEBUG=yes. When DEBUG=yes, default optimization level is -O0 -# but it can be changed here -DEBUG = no -ifeq ($(DEBUG),yes) - OPTFLAGS = -g -O0 -endif - -# gfortran doesn't provide all degree-based trig functions as intrinsics -# Most compilers provide these and it is safe to set NEED_SINDCOSD = no -NEED_SINDCOSD = no - -# To enable attaching a debugger such as gdb or ddd to a running process, set ATTACH_DEBUGGER = yes -ATTACH_DEBUGGER = no - -# Whether to enable FIM profiling using GPTL. -USE_GPTL = no -ifeq ($(USE_GPTL),yes) -# Set include path for GPTL - GPTL_CPPFLAGS = -I -# For auto-profiling of MPI functions, set USE_PMPI=yes. The name of the GPTL -# library in this case is libgptl_pmpi.a. Otherwise the name is libgptl.a - USE_PMPI = yes - ifeq ($(USE_PMPI),yes) - GPTL_LDFLAGS = -L -lgptl_pmpi -# When auto-profiling the MPI layer, set HAVE_IARGCGETARG=yes if the Fortran -# compiler supports functions iargc and getarg. - HAVE_IARGCGETARG = no - else - GPTL_LDFLAGS = -L -lgptl - endif -# AUTOINST=yes enables function-level compiler-generated auto-profiling, - AUTOINST = yes - ifeq ($(AUTOINST),yes) - GPTL_FFLAGS = -finstrument-functions -g -O2 - GPTL_LDFLAGS += -finstrument-functions - endif -# If GPTL was built with PAPI support, add the required flags - HAVE_PAPI = no - ifeq ($(HAVE_PAPI),yes) - GPTL_LDFLAGS += -lpapi - endif -# Need to call GPTL init and print functions manually when GPTL enabled and HAVE_IARGCGETARG -# isn't set. These functions are called automatically from GPTL MPI wrappers when -# HAVE_IARGCGETARG is set - ifneq ($(HAVE_IARGCGETARG),yes) - GPTL_CPPFLAGS += -DMANUALGPTL - endif -endif - -# SMS library location -ifeq ($(USE_GPTL),yes) # use an SMS with auto-profiling enabled - SMS = /home/hender/SMS/jet-intel-mvapich_r226_intel_11.1.072_mvapich2_1.4.1 -else - SMS = /home/hender/SMS/jet-intel-mvapich_r226_intel_11.1.072_mvapich2_1.4.1 -endif diff --git a/src/fim/FIMsrc/macros.make.devccs b/src/fim/FIMsrc/macros.make.devccs deleted file mode 100644 index 9935ed0..0000000 --- a/src/fim/FIMsrc/macros.make.devccs +++ /dev/null @@ -1,82 +0,0 @@ -# Target being built (i.e. as defined by makefim ) -MAKEFIM_TARGET = devccs - -# Preprocessor and flags -CPP = /lib/cpp -CPP_FLAGS = -C -P - -# Number of parallel tasks for gmake (NOTE: horizontal/ still must be serial) -GMAKEMINUSJ = -j8 - -# Record control word flag (currently required only by gfortran: specifies 4-byte RCW) -RCWFLAG = - -# Optimization flags -OPTFLAGS = - -# Load flags. In most cases this can be empty due to the use of MPI compiler wrappers -#JR the following give around a 10% performance boost on IBMs -LDFLAGS = -lmass -lmassv - -# cpp ifdef for Fortran name-mangling (needed when linebuf_stdout.c is enabled). Options are: -# FORTRAN_UNDERSCORING = -DFORTRANUNDERSCORE -# FORTRAN_UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE -# FORTRAN_UNDERSCORING = -FORTRAN_UNDERSCORING = - -# To turn on debugging, set DEBUG=yes. When DEBUG=yes, default optimization level is -O0 -# but it can be changed here -DEBUG = no -ifeq ($(DEBUG),yes) - OPTFLAGS = -g -O0 -endif - -# gfortran doesn't provide all degree-based trig functions as intrinsics -# Most compilers provide these and it is safe to set NEED_SINDCOSD = no -NEED_SINDCOSD = no - -# To enable attaching a debugger such as gdb or ddd to a running process, set ATTACH_DEBUGGER = yes -ATTACH_DEBUGGER = no - -# Whether to enable FIM profiling using GPTL. -USE_GPTL = no -ifeq ($(USE_GPTL),yes) -# Set include path for GPTL - GPTL_CPPFLAGS = -I -# For auto-profiling of MPI functions, set USE_PMPI=yes. The name of the GPTL -# library in this case is libgptl_pmpi.a. Otherwise the name is libgptl.a - USE_PMPI = yes - ifeq ($(USE_PMPI),yes) - GPTL_LDFLAGS = -L -lgptl_pmpi -# When auto-profiling the MPI layer, set HAVE_IARGCGETARG=yes if the Fortran -# compiler supports functions iargc and getarg. - HAVE_IARGCGETARG = no - else - GPTL_LDFLAGS = -L -lgptl - endif -# AUTOINST=yes enables function-level compiler-generated auto-profiling, - AUTOINST = no - ifeq ($(AUTOINST),yes) - GPTL_FFLAGS = auto-instrumentation-flag -g -O2 - GPTL_LDFLAGS += auto-instrumentation-flag - endif -# If GPTL was built with PAPI support, add the required flags - HAVE_PAPI = yes - ifeq ($(HAVE_PAPI),yes) - GPTL_LDFLAGS += -lpapi - endif -# Need to call GPTL init and print functions manually when GPTL enabled and HAVE_IARGCGETARG -# isn't set. These functions are called automatically from GPTL MPI wrappers when -# HAVE_IARGCGETARG is set - ifneq ($(HAVE_IARGCGETARG),yes) - GPTL_CPPFLAGS += -DMANUALGPTL - endif -endif - -# SMS library location -ifeq ($(USE_GPTL),yes) -# If available, use SMS version compiled with auto-profiling flag - SMS = /gpfs/t3/global/save/wx20tbh/SMS/SMS_r237 -else - SMS = /gpfs/t3/global/save/wx20tbh/SMS/SMS_r237 -endif diff --git a/src/fim/FIMsrc/macros.make.frostintel b/src/fim/FIMsrc/macros.make.frostintel deleted file mode 100644 index 49c536c..0000000 --- a/src/fim/FIMsrc/macros.make.frostintel +++ /dev/null @@ -1,81 +0,0 @@ -# Target being built (i.e. as defined by makefim ) -MAKEFIM_TARGET = frostintel - -# Preprocessor and flags -CPP = /lib/cpp -CPP_FLAGS = -C -P - -# Number of parallel tasks for gmake (NOTE: horizontal/ still must be serial) -GMAKEMINUSJ = -j8 - -# Record control word flag (currently required only by gfortran: specifies 4-byte RCW) -RCWFLAG = - -# Optimization flags -OPTFLAGS = - -# Load flags. In most cases this can be empty due to the use of MPI compiler wrappers -LDFLAGS = -lmpi - -# cpp ifdef for Fortran name-mangling (needed when linebuf_stdout.c is enabled). Options are: -# FORTRAN_UNDERSCORING = -DFORTRANUNDERSCORE -# FORTRAN_UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE -# FORTRAN_UNDERSCORING = -FORTRAN_UNDERSCORING = -DFORTRANUNDERSCORE - -# To turn on debugging, set DEBUG=yes. When DEBUG=yes, default optimization level is -O0 -# but it can be changed here -DEBUG = no -ifeq ($(DEBUG),yes) - OPTFLAGS = -g -O0 -endif - -# gfortran doesn't provide all degree-based trig functions as intrinsics -# Most compilers provide these and it is safe to set NEED_SINDCOSD = no -NEED_SINDCOSD = no - -# To enable attaching a debugger such as gdb or ddd to a running process, set ATTACH_DEBUGGER = yes -ATTACH_DEBUGGER = no - -# Whether to enable FIM profiling using GPTL. -USE_GPTL = no -ifeq ($(USE_GPTL),yes) -# Set include path for GPTL - GPTL_CPPFLAGS = -I/ccs/home/rosinski/frost/intel/include -# For auto-profiling of MPI functions, set USE_PMPI=yes. The name of the GPTL -# library in this case is libgptl_pmpi.a. Otherwise the name is libgptl.a - USE_PMPI = yes - ifeq ($(USE_PMPI),yes) - GPTL_LDFLAGS = -L/ccs/home/rosinski/frost/intel/lib -lgptl_pmpi -# When auto-profiling the MPI layer, set HAVE_IARGCGETARG=yes if the Fortran -# compiler supports functions iargc and getarg. - HAVE_IARGCGETARG = no - else - GPTL_LDFLAGS = -L/ccs/home/rosinski/frost/intel/lib -lgptl - endif -# AUTOINST=yes enables function-level compiler-generated auto-profiling, - AUTOINST = yes - ifeq ($(AUTOINST),yes) - GPTL_FFLAGS = -finstrument-functions -g -O2 - GPTL_LDFLAGS += -finstrument-functions - endif -# If GPTL was built with PAPI support, add the required flags - HAVE_PAPI = no - ifeq ($(HAVE_PAPI),yes) - GPTL_LDFLAGS += -lpapi - endif -# Need to call GPTL init and print functions manually when GPTL enabled and HAVE_IARGCGETARG -# isn't set. These functions are called automatically from GPTL MPI wrappers when -# HAVE_IARGCGETARG is set - ifneq ($(HAVE_IARGCGETARG),yes) - GPTL_CPPFLAGS += -DMANUALGPTL - endif -endif - -# SMS library location -ifeq ($(USE_GPTL),yes) -# If available, use SMS version compiled with auto-profiling flag - SMS = /ccs/home/rosinski/sms_r226_frost -else - SMS = /ccs/home/rosinski/sms_r226_frost -endif diff --git a/src/fim/FIMsrc/macros.make.jaguargnu b/src/fim/FIMsrc/macros.make.jaguargnu deleted file mode 100644 index 25a15c2..0000000 --- a/src/fim/FIMsrc/macros.make.jaguargnu +++ /dev/null @@ -1,81 +0,0 @@ -# Target being built (i.e. as defined by makefim ) -MAKEFIM_TARGET = jaguargnu - -# Preprocessor and flags -CPP = /lib/cpp -CPP_FLAGS = -C -P - -# Number of parallel tasks for gmake (NOTE: horizontal/ still must be serial) -GMAKEMINUSJ = -j8 - -# Record control word flag (currently required only by gfortran: specifies 4-byte RCW) -RCWFLAG = -frecord-marker=4 - -# Optimization flags -OPTFLAGS = - -# Load flags. In most cases this can be empty due to the use of MPI compiler wrappers -LDFLAGS = - -# cpp ifdef for Fortran name-mangling (needed when linebuf_stdout.c is enabled). Options are: -# FORTRAN_UNDERSCORING = -DFORTRANUNDERSCORE -# FORTRAN_UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE -# FORTRAN_UNDERSCORING = -FORTRAN_UNDERSCORING = -DFORTRANUNDERSCORE - -# To turn on debugging, set DEBUG=yes. When DEBUG=yes, default optimization level is -O0 -# but it can be changed here -DEBUG = no -ifeq ($(DEBUG),yes) - OPTFLAGS = -g -O0 -endif - -# gfortran doesn't provide all degree-based trig functions as intrinsics -# Most compilers provide these and it is safe to set NEED_SINDCOSD = no -NEED_SINDCOSD = yes - -# To enable attaching a debugger such as gdb or ddd to a running process, set ATTACH_DEBUGGER = yes -ATTACH_DEBUGGER = no - -# Whether to enable FIM profiling using GPTL. -USE_GPTL = no -ifeq ($(USE_GPTL),yes) -# Set include path for GPTL - GPTL_CPPFLAGS = -I/ccs/home/rosinski/xt5/intel/include -# For auto-profiling of MPI functions, set USE_PMPI=yes. The name of the GPTL -# library in this case is libgptl_pmpi.a. Otherwise the name is libgptl.a - USE_PMPI = yes - ifeq ($(USE_PMPI),yes) - GPTL_LDFLAGS = -L/ccs/home/rosinski/xt5/intel/lib -lgptl_pmpi -# When auto-profiling the MPI layer, set HAVE_IARGCGETARG=yes if the Fortran -# compiler supports functions iargc and getarg. - HAVE_IARGCGETARG = no - else - GPTL_LDFLAGS = -L/ccs/home/rosinski/xt5/intel/lib -lgptl - endif -# AUTOINST=yes enables function-level compiler-generated auto-profiling, - AUTOINST = yes - ifeq ($(AUTOINST),yes) - GPTL_FFLAGS = -finstrument-functions -g -O2 - GPTL_LDFLAGS += -finstrument-functions - endif -# If GPTL was built with PAPI support, add the required flags - HAVE_PAPI = no - ifeq ($(HAVE_PAPI),yes) - GPTL_LDFLAGS += -L/opt/xt-tools/papi/3.6.2.2/lib -lpapi -lpfm - endif -# Need to call GPTL init and print functions manually when GPTL enabled and HAVE_IARGCGETARG -# isn't set. These functions are called automatically from GPTL MPI wrappers when -# HAVE_IARGCGETARG is set - ifneq ($(HAVE_IARGCGETARG),yes) - GPTL_CPPFLAGS += -DMANUALGPTL - endif -endif - -# SMS library location -ifeq ($(USE_GPTL),yes) -# If available, use SMS version compiled with auto-profiling flag - SMS = /ccs/home/rosinski/sms_r226_gnu -else - SMS = /ccs/home/rosinski/sms_r226_gnu -endif diff --git a/src/fim/FIMsrc/macros.make.jaguarintel b/src/fim/FIMsrc/macros.make.jaguarintel deleted file mode 100644 index 98b0283..0000000 --- a/src/fim/FIMsrc/macros.make.jaguarintel +++ /dev/null @@ -1,81 +0,0 @@ -# Target being built (i.e. as defined by makefim ) -MAKEFIM_TARGET = jaguarintel - -# Preprocessor and flags -CPP = /lib/cpp -CPP_FLAGS = -C -P - -# Number of parallel tasks for gmake (NOTE: horizontal/ still must be serial) -GMAKEMINUSJ = -j8 - -# Record control word flag (currently required only by gfortran: specifies 4-byte RCW) -RCWFLAG = - -# Optimization flags -OPTFLAGS = - -# Load flags. In most cases this can be empty due to the use of MPI compiler wrappers -LDFLAGS = - -# cpp ifdef for Fortran name-mangling (needed when linebuf_stdout.c is enabled). Options are: -# FORTRAN_UNDERSCORING = -DFORTRANUNDERSCORE -# FORTRAN_UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE -# FORTRAN_UNDERSCORING = -FORTRAN_UNDERSCORING = -DFORTRANUNDERSCORE - -# To turn on debugging, set DEBUG=yes. When DEBUG=yes, default optimization level is -O0 -# but it can be changed here -DEBUG = no -ifeq ($(DEBUG),yes) - OPTFLAGS = -g -O0 -endif - -# gfortran doesn't provide all degree-based trig functions as intrinsics -# Most compilers provide these and it is safe to set NEED_SINDCOSD = no -NEED_SINDCOSD = no - -# To enable attaching a debugger such as gdb or ddd to a running process, set ATTACH_DEBUGGER = yes -ATTACH_DEBUGGER = no - -# Whether to enable FIM profiling using GPTL. -USE_GPTL = no -ifeq ($(USE_GPTL),yes) -# Set include path for GPTL - GPTL_CPPFLAGS = -I/ccs/home/rosinski/xt5/intel/include -# For auto-profiling of MPI functions, set USE_PMPI=yes. The name of the GPTL -# library in this case is libgptl_pmpi.a. Otherwise the name is libgptl.a - USE_PMPI = yes - ifeq ($(USE_PMPI),yes) - GPTL_LDFLAGS = -L/ccs/home/rosinski/xt5/intel/lib -lgptl_pmpi -# When auto-profiling the MPI layer, set HAVE_IARGCGETARG=yes if the Fortran -# compiler supports functions iargc and getarg. - HAVE_IARGCGETARG = no - else - GPTL_LDFLAGS = -L/ccs/home/rosinski/xt5/intel/lib -lgptl - endif -# AUTOINST=yes enables function-level compiler-generated auto-profiling, - AUTOINST = yes - ifeq ($(AUTOINST),yes) - GPTL_FFLAGS = -finstrument-functions -g -O2 - GPTL_LDFLAGS += -finstrument-functions - endif -# If GPTL was built with PAPI support, add the required flags - HAVE_PAPI = no - ifeq ($(HAVE_PAPI),yes) - GPTL_LDFLAGS += -L/opt/xt-tools/papi/3.6.2.2/lib -lpapi -lpfm - endif -# Need to call GPTL init and print functions manually when GPTL enabled and HAVE_IARGCGETARG -# isn't set. These functions are called automatically from GPTL MPI wrappers when -# HAVE_IARGCGETARG is set - ifneq ($(HAVE_IARGCGETARG),yes) - GPTL_CPPFLAGS += -DMANUALGPTL - endif -endif - -# SMS library location -ifeq ($(USE_GPTL),yes) -# If available, use SMS version compiled with auto-profiling flag - SMS = /ccs/home/rosinski/sms_r226 -else - SMS = /ccs/home/rosinski/sms_r226 -endif diff --git a/src/fim/FIMsrc/macros.make.lahey b/src/fim/FIMsrc/macros.make.lahey deleted file mode 100644 index a2e7e7a..0000000 --- a/src/fim/FIMsrc/macros.make.lahey +++ /dev/null @@ -1,81 +0,0 @@ -# Target being built (i.e. as defined by makefim ) -MAKEFIM_TARGET = lahey - -# Preprocessor and flags -CPP = /lib/cpp -CPP_FLAGS = -C -P - -# Number of parallel tasks for gmake (NOTE: horizontal/ still must be serial) -GMAKEMINUSJ = -j8 - -# Record control word flag (currently required only by gfortran: specifies 4-byte RCW) -RCWFLAG = - -# Optimization flags -OPTFLAGS = - -# Load flags. In most cases this can be empty due to the use of MPI compiler wrappers -LDFLAGS = - -# cpp ifdef for Fortran name-mangling (needed when linebuf_stdout.c is enabled). Options are: -# FORTRAN_UNDERSCORING = -DFORTRANUNDERSCORE -# FORTRAN_UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE -# FORTRAN_UNDERSCORING = -FORTRAN_UNDERSCORING = -DFORTRANUNDERSCORE - -# To turn on debugging, set DEBUG=yes. When DEBUG=yes, default optimization level is -O0 -# but it can be changed here -DEBUG = no -ifeq ($(DEBUG),yes) - OPTFLAGS = -g -O0 -endif - -# gfortran doesn't provide all degree-based trig functions as intrinsics -# Most compilers provide these and it is safe to set NEED_SINDCOSD = no -NEED_SINDCOSD = no - -# To enable attaching a debugger such as gdb or ddd to a running process, set ATTACH_DEBUGGER = yes -ATTACH_DEBUGGER = no - -# Whether to enable FIM profiling using GPTL. -USE_GPTL = no -ifeq ($(USE_GPTL),yes) -# Set include path for GPTL - GPTL_CPPFLAGS = -I -# For auto-profiling of MPI functions, set USE_PMPI=yes. The name of the GPTL -# library in this case is libgptl_pmpi.a. Otherwise the name is libgptl.a - USE_PMPI = yes - ifeq ($(USE_PMPI),yes) - GPTL_LDFLAGS = -L -lgptl_pmpi -# When auto-profiling the MPI layer, set HAVE_IARGCGETARG=yes if the Fortran -# compiler supports functions iargc and getarg. - HAVE_IARGCGETARG = no - else - GPTL_LDFLAGS = -L -lgptl - endif -# AUTOINST=yes enables function-level compiler-generated auto-profiling, - AUTOINST = no - ifeq ($(AUTOINST),yes) - GPTL_FFLAGS = auto-instrumentation unavailable in lahey compiler - GPTL_LDFLAGS += auto-instrumentation unavailable in lahey compiler - endif -# If GPTL was built with PAPI support, add the required flags - HAVE_PAPI = no - ifeq ($(HAVE_PAPI),yes) - GPTL_LDFLAGS += -lpapi - endif -# Need to call GPTL init and print functions manually when GPTL enabled and HAVE_IARGCGETARG -# isn't set. These functions are called automatically from GPTL MPI wrappers when -# HAVE_IARGCGETARG is set - ifneq ($(HAVE_IARGCGETARG),yes) - GPTL_CPPFLAGS += -DMANUALGPTL - endif -endif - -# SMS library location -ifeq ($(USE_GPTL),yes) -# If available, use SMS version compiled with auto-profiling flag - SMS = /home/hender/SMS/jet-lahey-mvapich_r226_lahey_8.10b_mvapich2_1.4.1 -else - SMS = /home/hender/SMS/jet-lahey-mvapich_r226_lahey_8.10b_mvapich2_1.4.1 -endif diff --git a/src/fim/FIMsrc/macros.make.linuxpcgnu b/src/fim/FIMsrc/macros.make.linuxpcgnu deleted file mode 100644 index b83f547..0000000 --- a/src/fim/FIMsrc/macros.make.linuxpcgnu +++ /dev/null @@ -1,81 +0,0 @@ -# Target being built (i.e. as defined by makefim ) -MAKEFIM_TARGET = linuxpcgnu - -# Preprocessor and flags -CPP = cpp -CPP_FLAGS = -C -P - -# Number of parallel tasks for gmake (NOTE: horizontal/ still must be serial) -GMAKEMINUSJ = -j4 - -# Record control word flag (currently required only by gfortran: specifies 4-byte RCW) -RCWFLAG = -frecord-marker=4 - -# Optimization flags -OPTFLAGS = -ffpe-trap=invalid,overflow -fbacktrace -fno-range-check - -# Load flags. In most cases this can be empty due to the use of MPI compiler wrappers -LDFLAGS = - -# cpp ifdef for Fortran name-mangling (needed when linebuf_stdout.c is enabled). Options are: -# FORTRAN_UNDERSCORING = -DFORTRANUNDERSCORE -# FORTRAN_UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE -# FORTRAN_UNDERSCORING = -FORTRAN_UNDERSCORING = -DFORTRANUNDERSCORE - -# To turn on debugging, set DEBUG=yes. When DEBUG=yes, default optimization level is -O0 -# but it can be changed here -DEBUG = yes -ifeq ($(DEBUG),yes) - OPTFLAGS = -g -O1 -ffpe-trap=invalid,overflow -fbacktrace -fno-range-check -endif - -# gfortran doesn't provide all degree-based trig functions as intrinsics -# Most compilers provide these and it is safe to set NEED_SINDCOSD = no -NEED_SINDCOSD = yes - -# To enable attaching a debugger such as gdb or ddd to a running process, set ATTACH_DEBUGGER = yes -ATTACH_DEBUGGER = no - -# Whether to enable FIM profiling using GPTL. -USE_GPTL = no -ifeq ($(USE_GPTL),yes) -# Set include path for GPTL - GPTL_CPPFLAGS = -I/home/rosinski/x86_64/gptl-4.0/include -# For auto-profiling of MPI functions, set USE_PMPI=yes. The name of the GPTL -# library in this case is libgptl_pmpi.a. Otherwise the name is libgptl.a - USE_PMPI = no - ifeq ($(USE_PMPI),yes) - GPTL_LDFLAGS = -L/home/rosinski/x86_64/gptl-4.0/lib -lgptl_pmpi -# When auto-profiling the MPI layer, set HAVE_IARGCGETARG=yes if the Fortran -# compiler supports functions iargc and getarg. - HAVE_IARGCGETARG = no - else - GPTL_LDFLAGS = -L/home/rosinski/x86_64/gptl-4.0/lib -lgptl - endif -# AUTOINST=yes enables function-level compiler-generated auto-profiling, - AUTOINST = yes - ifeq ($(AUTOINST),yes) - GPTL_FFLAGS = -finstrument-functions -g -O2 - GPTL_LDFLAGS += -finstrument-functions - endif -# If GPTL was built with PAPI support, add the required flags - HAVE_PAPI = no - ifeq ($(HAVE_PAPI),yes) - GPTL_LDFLAGS += -lpapi - endif -# Need to call GPTL init and print functions manually when GPTL enabled and HAVE_IARGCGETARG -# isn't set. These functions are called automatically from GPTL MPI wrappers when -# HAVE_IARGCGETARG is set - ifneq ($(HAVE_IARGCGETARG),yes) - GPTL_CPPFLAGS += -DMANUALGPTL - endif -endif - -# SMS library location -ifeq ($(USE_GPTL),yes) -# If available, use SMS version compiled with auto-profiling flag - SMS = /home/rosinski/sms_r226 -else - SMS = /home/rosinski/sms_r226 -endif diff --git a/src/fim/FIMsrc/macros.make.macgnu b/src/fim/FIMsrc/macros.make.macgnu deleted file mode 100644 index cc559cd..0000000 --- a/src/fim/FIMsrc/macros.make.macgnu +++ /dev/null @@ -1,81 +0,0 @@ -# Target being built (i.e. as defined by makefim ) -MAKEFIM_TARGET = macgnu - -# Preprocessor and flags -CPP = cpp -CPP_FLAGS = -C -P - -# Number of parallel tasks for gmake (NOTE: horizontal/ still must be serial) -GMAKEMINUSJ = -j2 - -# Record control word flag (currently required only by gfortran: specifies 4-byte RCW) -RCWFLAG = -frecord-marker=4 - -# Optimization flags -OPTFLAGS = - -# Load flags. In most cases this can be empty due to the use of MPI compiler wrappers -LDFLAGS = - -# cpp ifdef for Fortran name-mangling (needed when linebuf_stdout.c is enabled). Options are: -# FORTRAN_UNDERSCORING = -DFORTRANUNDERSCORE -# FORTRAN_UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE -# FORTRAN_UNDERSCORING = -FORTRAN_UNDERSCORING = -DFORTRANUNDERSCORE - -# To turn on debugging, set DEBUG=yes. When DEBUG=yes, default optimization level is -O0 -# but it can be changed here -DEBUG = no -ifeq ($(DEBUG),yes) - OPTFLAGS = -g -O0 -endif - -# gfortran doesn't provide all degree-based trig functions as intrinsics -# Most compilers provide these and it is safe to set NEED_SINDCOSD = no -NEED_SINDCOSD = yes - -# To enable attaching a debugger such as gdb or ddd to a running process, set ATTACH_DEBUGGER = yes -ATTACH_DEBUGGER = no - -# Whether to enable FIM profiling using GPTL. -USE_GPTL = no -ifeq ($(USE_GPTL),yes) -# Set include path for GPTL - GPTL_CPPFLAGS = -I/Users/rosinski/include -# For auto-profiling of MPI functions, set USE_PMPI=yes. The name of the GPTL -# library in this case is libgptl_pmpi.a. Otherwise the name is libgptl.a - USE_PMPI = yes - ifeq ($(USE_PMPI),yes) - GPTL_LDFLAGS = -L/Users/rosinski/lib -lgptl_pmpi -# When auto-profiling the MPI layer, set HAVE_IARGCGETARG=yes if the Fortran -# compiler supports functions iargc and getarg. - HAVE_IARGCGETARG = no - else - GPTL_LDFLAGS = -L/Users/rosinski/lib -lgptl - endif -# AUTOINST=yes enables function-level compiler-generated auto-profiling, - AUTOINST = yes - ifeq ($(AUTOINST),yes) - GPTL_FFLAGS = -finstrument-functions -g -O2 - GPTL_LDFLAGS += -finstrument-functions - endif -# If GPTL was built with PAPI support, add the required flags - HAVE_PAPI = no - ifeq ($(HAVE_PAPI),yes) - GPTL_LDFLAGS += -lpapi - endif -# Need to call GPTL init and print functions manually when GPTL enabled and HAVE_IARGCGETARG -# isn't set. These functions are called automatically from GPTL MPI wrappers when -# HAVE_IARGCGETARG is set - ifneq ($(HAVE_IARGCGETARG),yes) - GPTL_CPPFLAGS += -DMANUALGPTL - endif -endif - -# SMS library location -ifeq ($(USE_GPTL),yes) -# If available, use SMS version compiled with auto-profiling flag - SMS = $(HOME)/sms_r226 -else - SMS = $(HOME)/sms_r226 -endif diff --git a/src/fim/FIMsrc/macros.make.mvapich b/src/fim/FIMsrc/macros.make.mvapich deleted file mode 100644 index a62ae13..0000000 --- a/src/fim/FIMsrc/macros.make.mvapich +++ /dev/null @@ -1,81 +0,0 @@ -# Target being built (i.e. as defined by makefim ) -MAKEFIM_TARGET = mvapich - -# Preprocessor and flags -CPP = /lib/cpp -CPP_FLAGS = -C -P - -# Number of parallel tasks for gmake (NOTE: horizontal/ still must be serial) -GMAKEMINUSJ = -j8 - -# Record control word flag (currently required only by gfortran: specifies 4-byte RCW) -RCWFLAG = - -# Optimization flags -OPTFLAGS = - -# Load flags. In most cases this can be empty due to the use of MPI compiler wrappers -LDFLAGS = - -# cpp ifdef for Fortran name-mangling (needed when linebuf_stdout.c is enabled). Options are: -# FORTRAN_UNDERSCORING = -DFORTRANUNDERSCORE -# FORTRAN_UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE -# FORTRAN_UNDERSCORING = -FORTRAN_UNDERSCORING = -DFORTRANUNDERSCORE - -# To turn on debugging, set DEBUG=yes. When DEBUG=yes, default optimization level is -O0 -# but it can be changed here -DEBUG = no -ifeq ($(DEBUG),yes) - OPTFLAGS = -g -O0 -traceback -check bounds -fpe0 -ftz -endif - -# gfortran doesn't provide all degree-based trig functions as intrinsics -# Most compilers provide these and it is safe to set NEED_SINDCOSD = no -NEED_SINDCOSD = no - -# To enable attaching a debugger such as gdb or ddd to a running process, set ATTACH_DEBUGGER = yes -ATTACH_DEBUGGER = no - -# Whether to enable FIM profiling using GPTL. -USE_GPTL = no -ifeq ($(USE_GPTL),yes) -# Set include path for GPTL - GPTL_CPPFLAGS = -I/home/rosinski/jet/gptl-4.0/intel/include -# For auto-profiling of MPI functions, set USE_PMPI=yes. The name of the GPTL -# library in this case is libgptl_pmpi.a. Otherwise the name is libgptl.a - USE_PMPI = no - ifeq ($(USE_PMPI),yes) - GPTL_LDFLAGS = -L -lgptl_pmpi -# When auto-profiling the MPI layer, set HAVE_IARGCGETARG=yes if the Fortran -# compiler supports functions iargc and getarg. - HAVE_IARGCGETARG = no - else - GPTL_LDFLAGS = -L/home/rosinski/jet/gptl-4.0/intel/lib -lgptl - endif -# AUTOINST=yes enables function-level compiler-generated auto-profiling, - AUTOINST = yes - ifeq ($(AUTOINST),yes) - GPTL_FFLAGS = -finstrument-functions -g -O2 - GPTL_LDFLAGS += -finstrument-functions - endif -# If GPTL was built with PAPI support, add the required flags - HAVE_PAPI = yes - ifeq ($(HAVE_PAPI),yes) - GPTL_LDFLAGS += -L/opt/papi/4.1.0/lib -lpapi - endif -# Need to call GPTL init and print functions manually when GPTL enabled and HAVE_IARGCGETARG -# isn't set. These functions are called automatically from GPTL MPI wrappers when -# HAVE_IARGCGETARG is set - ifneq ($(HAVE_IARGCGETARG),yes) - GPTL_CPPFLAGS += -DMANUALGPTL - endif -endif - -# SMS library location -ifeq ($(USE_GPTL),yes) -# If available, use SMS version compiled with auto-profiling flag - SMS = /home/hender/SMS/jet-intel-mvapich_r226_intel_11.1.072_mvapich2_1.4.1 -else - SMS = /home/hender/SMS/jet-intel-mvapich_r226_intel_11.1.072_mvapich2_1.4.1 -endif diff --git a/src/fim/FIMsrc/macros.make.nems b/src/fim/FIMsrc/macros.make.nems deleted file mode 100644 index a30b609..0000000 --- a/src/fim/FIMsrc/macros.make.nems +++ /dev/null @@ -1,81 +0,0 @@ -# Target being built (i.e. as defined by makefim ) -MAKEFIM_TARGET = nems - -# Preprocessor and flags -CPP = /lib/cpp -CPP_FLAGS = -C -P - -# Number of parallel tasks for gmake (NOTE: horizontal/ still must be serial) -GMAKEMINUSJ = -j8 - -# Record control word flag (currently required only by gfortran: specifies 4-byte RCW) -RCWFLAG = - -# Optimization flags -OPTFLAGS = - -# Load flags. In most cases this can be empty due to the use of MPI compiler wrappers -LDFLAGS = - -# cpp ifdef for Fortran name-mangling (needed when linebuf_stdout.c is enabled). Options are: -# FORTRAN_UNDERSCORING = -DFORTRANUNDERSCORE -# FORTRAN_UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE -# FORTRAN_UNDERSCORING = -FORTRAN_UNDERSCORING = -DFORTRANUNDERSCORE - -# To turn on debugging, set DEBUG=yes. When DEBUG=yes, default optimization level is -O0 -# but it can be changed here -DEBUG = no -ifeq ($(DEBUG),yes) - OPTFLAGS = -g -O0 -endif - -# gfortran doesn't provide all degree-based trig functions as intrinsics -# Most compilers provide these and it is safe to set NEED_SINDCOSD = no -NEED_SINDCOSD = no - -# To enable attaching a debugger such as gdb or ddd to a running process, set ATTACH_DEBUGGER = yes -ATTACH_DEBUGGER = no - -# Whether to enable FIM profiling using GPTL. -USE_GPTL = no -ifeq ($(USE_GPTL),yes) -# Set include path for GPTL - GPTL_CPPFLAGS = -I -# For auto-profiling of MPI functions, set USE_PMPI=yes. The name of the GPTL -# library in this case is libgptl_pmpi.a. Otherwise the name is libgptl.a - USE_PMPI = yes - ifeq ($(USE_PMPI),yes) - GPTL_LDFLAGS = -L -lgptl_pmpi -# When auto-profiling the MPI layer, set HAVE_IARGCGETARG=yes if the Fortran -# compiler supports functions iargc and getarg. - HAVE_IARGCGETARG = no - else - GPTL_LDFLAGS = -L -lgptl - endif -# AUTOINST=yes enables function-level compiler-generated auto-profiling, - AUTOINST = yes - ifeq ($(AUTOINST),yes) - GPTL_FFLAGS = -finstrument-functions -g -O2 - GPTL_LDFLAGS += -finstrument-functions - endif -# If GPTL was built with PAPI support, add the required flags - HAVE_PAPI = no - ifeq ($(HAVE_PAPI),yes) - GPTL_LDFLAGS += -lpapi - endif -# Need to call GPTL init and print functions manually when GPTL enabled and HAVE_IARGCGETARG -# isn't set. These functions are called automatically from GPTL MPI wrappers when -# HAVE_IARGCGETARG is set - ifneq ($(HAVE_IARGCGETARG),yes) - GPTL_CPPFLAGS += -DMANUALGPTL - endif -endif - -# SMS library location -ifeq ($(USE_GPTL),yes) # use an SMS with auto-profiling enabled - SMS = /home/hender/SMS/jet-intel-mvapich_r226_intel_11.1.072_mvapich2_1.4.1 -else - SMS = /home/hender/SMS/jet-intel-mvapich_r226_intel_11.1.072_mvapich2_1.4.1 -endif - diff --git a/src/fim/FIMsrc/macros.make.openmpi b/src/fim/FIMsrc/macros.make.openmpi deleted file mode 100644 index 74d09f9..0000000 --- a/src/fim/FIMsrc/macros.make.openmpi +++ /dev/null @@ -1,81 +0,0 @@ -# Target being built (i.e. as defined by makefim ) -MAKEFIM_TARGET = openmpi - -# Preprocessor and flags -CPP = /lib/cpp -CPP_FLAGS = -C -P - -# Number of parallel tasks for gmake (NOTE: horizontal/ still must be serial) -GMAKEMINUSJ = -j8 - -# Record control word flag (currently required only by gfortran: specifies 4-byte RCW) -RCWFLAG = - -# Optimization flags -OPTFLAGS = - -# Load flags. In most cases this can be empty due to the use of MPI compiler wrappers -LDFLAGS = - -# cpp ifdef for Fortran name-mangling (needed when linebuf_stdout.c is enabled). Options are: -# FORTRAN_UNDERSCORING = -DFORTRANUNDERSCORE -# FORTRAN_UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE -# FORTRAN_UNDERSCORING = -FORTRAN_UNDERSCORING = -DFORTRANUNDERSCORE - -# To turn on debugging, set DEBUG=yes. When DEBUG=yes, default optimization level is -O0 -# but it can be changed here -DEBUG = no -ifeq ($(DEBUG),yes) - OPTFLAGS = -g -O1 -traceback -check bounds -endif - -# gfortran doesn't provide all degree-based trig functions as intrinsics -# Most compilers provide these and it is safe to set NEED_SINDCOSD = no -NEED_SINDCOSD = no - -# To enable attaching a debugger such as gdb or ddd to a running process, set ATTACH_DEBUGGER = yes -ATTACH_DEBUGGER = no - -# Whether to enable FIM profiling using GPTL. -USE_GPTL = no -ifeq ($(USE_GPTL),yes) -# Set include path for GPTL - GPTL_CPPFLAGS = -I/home/rosinski/jet/gptl-4.0/intel/include -# For auto-profiling of MPI functions, set USE_PMPI=yes. The name of the GPTL -# library in this case is libgptl_pmpi.a. Otherwise the name is libgptl.a - USE_PMPI = no - ifeq ($(USE_PMPI),yes) - GPTL_LDFLAGS = -L -lgptl_pmpi -# When auto-profiling the MPI layer, set HAVE_IARGCGETARG=yes if the Fortran -# compiler supports functions iargc and getarg. - HAVE_IARGCGETARG = no - else - GPTL_LDFLAGS = -L/home/rosinski/jet/gptl-4.0/intel/lib -lgptl - endif -# AUTOINST=yes enables function-level compiler-generated auto-profiling, - AUTOINST = yes - ifeq ($(AUTOINST),yes) - GPTL_FFLAGS = -finstrument-functions -g -O2 - GPTL_LDFLAGS += -finstrument-functions - endif -# If GPTL was built with PAPI support, add the required flags - HAVE_PAPI = yes - ifeq ($(HAVE_PAPI),yes) - GPTL_LDFLAGS += -L/opt/papi/4.1.0/lib -lpapi - endif -# Need to call GPTL init and print functions manually when GPTL enabled and HAVE_IARGCGETARG -# isn't set. These functions are called automatically from GPTL MPI wrappers when -# HAVE_IARGCGETARG is set - ifneq ($(HAVE_IARGCGETARG),yes) - GPTL_CPPFLAGS += -DMANUALGPTL - endif -endif - -# SMS library location -ifeq ($(USE_GPTL),yes) -# If available, use SMS version compiled with auto-profiling flag - SMS = /home/hender/SMS/jet-intel-openmpi_r226_intel_11.1.072_openmpi_1.4.1 -else - SMS = /home/hender/SMS/jet-intel-openmpi_r226_intel_11.1.072_openmpi_1.4.1 -endif diff --git a/src/fim/FIMsrc/macros.make.ranger b/src/fim/FIMsrc/macros.make.ranger deleted file mode 100644 index 628fedd..0000000 --- a/src/fim/FIMsrc/macros.make.ranger +++ /dev/null @@ -1,81 +0,0 @@ -# Target being built (i.e. as defined by makefim ) -MAKEFIM_TARGET = ranger - -# Preprocessor and flags -CPP = /lib/cpp -CPP_FLAGS = -C -P - -# Number of parallel tasks for gmake (NOTE: horizontal/ still must be serial) -GMAKEMINUSJ = -j8 - -# Record control word flag (currently required only by gfortran: specifies 4-byte RCW) -RCWFLAG = - -# Optimization flags -OPTFLAGS = - -# Load flags. In most cases this can be empty due to the use of MPI compiler wrappers -LDFLAGS = - -# cpp ifdef for Fortran name-mangling (needed when linebuf_stdout.c is enabled). Options are: -# FORTRAN_UNDERSCORING = -DFORTRANUNDERSCORE -# FORTRAN_UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE -# FORTRAN_UNDERSCORING = -FORTRAN_UNDERSCORING = -DFORTRANUNDERSCORE - -# To turn on debugging, set DEBUG=yes. When DEBUG=yes, default optimization level is -O0 -# but it can be changed here -DEBUG = no -ifeq ($(DEBUG),yes) - OPTFLAGS = -g -O0 -endif - -# gfortran doesn't provide all degree-based trig functions as intrinsics -# Most compilers provide these and it is safe to set NEED_SINDCOSD = no -NEED_SINDCOSD = no - -# To enable attaching a debugger such as gdb or ddd to a running process, set ATTACH_DEBUGGER = yes -ATTACH_DEBUGGER = no - -# Whether to enable FIM profiling using GPTL. -USE_GPTL = no -ifeq ($(USE_GPTL),yes) -# Set include path for GPTL - GPTL_CPPFLAGS = -I -# For auto-profiling of MPI functions, set USE_PMPI=yes. The name of the GPTL -# library in this case is libgptl_pmpi.a. Otherwise the name is libgptl.a - USE_PMPI = yes - ifeq ($(USE_PMPI),yes) - GPTL_LDFLAGS = -L -lgptl_pmpi -# When auto-profiling the MPI layer, set HAVE_IARGCGETARG=yes if the Fortran -# compiler supports functions iargc and getarg. - HAVE_IARGCGETARG = no - else - GPTL_LDFLAGS = -L -lgptl - endif -# AUTOINST=yes enables function-level compiler-generated auto-profiling, - AUTOINST = yes - ifeq ($(AUTOINST),yes) - GPTL_FFLAGS = -finstrument-functions -g -O2 - GPTL_LDFLAGS += -finstrument-functions - endif -# If GPTL was built with PAPI support, add the required flags - HAVE_PAPI = no - ifeq ($(HAVE_PAPI),yes) - GPTL_LDFLAGS += -lpapi - endif -# Need to call GPTL init and print functions manually when GPTL enabled and HAVE_IARGCGETARG -# isn't set. These functions are called automatically from GPTL MPI wrappers when -# HAVE_IARGCGETARG is set - ifneq ($(HAVE_IARGCGETARG),yes) - GPTL_CPPFLAGS += -DMANUALGPTL - endif -endif - -# SMS library location -ifeq ($(USE_GPTL),yes) -# If available, use SMS version compiled with auto-profiling flag - SMS = /share/home/01033/harrop/SMS_r42_intel-10.1-mvapich-1.0.1 -else - SMS = /share/home/01033/harrop/SMS_r42_intel-10.1-mvapich-1.0.1 -endif diff --git a/src/fim/FIMsrc/macros.make.vapor b/src/fim/FIMsrc/macros.make.vapor deleted file mode 100644 index 68881ba..0000000 --- a/src/fim/FIMsrc/macros.make.vapor +++ /dev/null @@ -1,82 +0,0 @@ -# Target being built (i.e. as defined by makefim ) -MAKEFIM_TARGET = vapor - -# Preprocessor and flags -CPP = /lib/cpp -CPP_FLAGS = -C -P - -# Number of parallel tasks for gmake (NOTE: horizontal/ still must be serial) -GMAKEMINUSJ = -j8 - -# Record control word flag (currently required only by gfortran: specifies 4-byte RCW) -RCWFLAG = - -# Optimization flags -OPTFLAGS = - -# Load flags. In most cases this can be empty due to the use of MPI compiler wrappers -#JR the following give around a 10% performance boost on vapor -LDFLAGS = -lmass -lmassv - -# cpp ifdef for Fortran name-mangling (needed when linebuf_stdout.c is enabled). Options are: -# FORTRAN_UNDERSCORING = -DFORTRANUNDERSCORE -# FORTRAN_UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE -# FORTRAN_UNDERSCORING = -FORTRAN_UNDERSCORING = - -# To turn on debugging, set DEBUG=yes. When DEBUG=yes, default optimization level is -O0 -# but it can be changed here -DEBUG = no -ifeq ($(DEBUG),yes) - OPTFLAGS = -g -O0 -endif - -# gfortran doesn't provide all degree-based trig functions as intrinsics -# Most compilers provide these and it is safe to set NEED_SINDCOSD = no -NEED_SINDCOSD = no - -# To enable attaching a debugger such as gdb or ddd to a running process, set ATTACH_DEBUGGER = yes -ATTACH_DEBUGGER = no - -# Whether to enable FIM profiling using GPTL. -USE_GPTL = no -ifeq ($(USE_GPTL),yes) -# Set include path for GPTL - GPTL_CPPFLAGS = -I -# For auto-profiling of MPI functions, set USE_PMPI=yes. The name of the GPTL -# library in this case is libgptl_pmpi.a. Otherwise the name is libgptl.a - USE_PMPI = yes - ifeq ($(USE_PMPI),yes) - GPTL_LDFLAGS = -L -lgptl_pmpi -# When auto-profiling the MPI layer, set HAVE_IARGCGETARG=yes if the Fortran -# compiler supports functions iargc and getarg. - HAVE_IARGCGETARG = no - else - GPTL_LDFLAGS = -L -lgptl - endif -# AUTOINST=yes enables function-level compiler-generated auto-profiling, - AUTOINST = no - ifeq ($(AUTOINST),yes) - GPTL_FFLAGS = auto-instrumentation-flag -g -O2 - GPTL_LDFLAGS += auto-instrumentation-flag - endif -# If GPTL was built with PAPI support, add the required flags - HAVE_PAPI = yes - ifeq ($(HAVE_PAPI),yes) - GPTL_LDFLAGS += -lpapi - endif -# Need to call GPTL init and print functions manually when GPTL enabled and HAVE_IARGCGETARG -# isn't set. These functions are called automatically from GPTL MPI wrappers when -# HAVE_IARGCGETARG is set - ifneq ($(HAVE_IARGCGETARG),yes) - GPTL_CPPFLAGS += -DMANUALGPTL - endif -endif - -# SMS library location -ifeq ($(USE_GPTL),yes) -# If available, use SMS version compiled with auto-profiling flag - SMS = /u/wx22jmr/sms_r226 -else - SMS = /u/wx22jmr/sms_r226 -endif diff --git a/src/fim/FIMsrc/makefim b/src/fim/FIMsrc/makefim deleted file mode 100755 index 18b953d..0000000 --- a/src/fim/FIMsrc/makefim +++ /dev/null @@ -1,117 +0,0 @@ -#!/bin/ksh - -# This script builds the fim system. For best results, start with the default -# module setup. See function usage below for usage. If no argument is specified, -# the default "openmpi" build is assumed. -# -# Argument meanings are: -# -# bluefire - build with default -q64 settings on bluefire -# debug - build with ifort+mvapich, debugging on -# frostintel - frost+intel -# jaguargnu - jaguar+gnu -# jaguarintel - jaguar+intel -# lahey - build with lahey+mvapich -# linuxpcgnu - gfortran+mpich on PC-linux -# macgnu - gfortran+mpich on Mac -# mvapich - build with ifort+mvapich -# nems - build FIM within the NCEP top-level ESMF components (ifort+mvapich) -# openmpi - build with ifort+openmpi (makefim's default) -# ranger - build with intel/10.1-mvapich-1.0.1 on ranger.tacc.utexas.edu -# serial - build ifort+openmpi, serial -# vapor - build with default -q64 settings on vapor -# devccs - build with default -q64 settings on devccs (cirrus or stratus) -# -# See fim_setup.ksh for specific compiler & MPI version numbers. - -function fail { test -n $1 && print $1; exit 1; } - -function usage -{ - cat << EOF - -usage: makefim [debug,linuxpcgnu,macgnu,lahey,mvapich,openmpi,nems,serial,ranger,vapor,devccs,bluefire,jaguarintel,jaguargnu,frostintel] - or: makefim [debug,linuxpcgnu,macgnu,lahey,mvapich,openmpi,ranger,vapor,devccs,bluefire,jaguarintel,jaguargnu,frostintel] [serial] - or: makefim [serial] [debug,linuxpcgnu,macgnu,lahey,mvapich openmpi,ranger,vapor,devccs,bluefire,jaguarintel,jaguargnu,frostintel] - -EOF - fail -} - -function check -{ - case $FTNMPI in - "bluefire") ;; - "debug") ;; - "frostintel") ;; - "jaguargnu") ;; - "jaguarintel") ;; - "lahey") ;; - "linuxpcgnu") ;; - "macgnu") ;; - "mvapich") ;; - "nems") test ! -z $P && test $P == "S" && fail "\nSerial nems build is not supported.\n";; - "openmpi") ;; - "ranger") ;; - "serial") FTNMPI="openmpi"; P="S";; - "vapor") ;; - "devccs") ;; - *) usage;; - esac -} - -# avoid accidental inheritance of env -unset P - -#Determine location of gnu make -MAKE=not_found -for x in gnumake gmake make -do -p=$(which $x 2>/dev/null) -if [[ -n $p && -x $p ]] -then - MAKE="$x" - break -fi -done - -test $MAKE == "not_found" && fail "gnu make not found" - -case $# in - 0) - print "default parallel build" - FTNMPI="openmpi" - ;; - 1) - case $1 in - "clean") touch macros.make; $MAKE clean; return $?;; - "cleanall") touch macros.make; $MAKE cleanall; return $?;; - *) FTNMPI=$1;; - esac - ;; - 2) - P="S" - test $1 == "serial" && FTNMPI=$2 - test $2 == "serial" && FTNMPI=$1 - ;; - *) - fail "\nonly 0, 1, or 2 arguments are supported.\n" - ;; -esac - -check -cd .. -#TBH Hack since IBM does not include rsync in default path -#TBH rsync -au FIMsrc/ FIMsrc_$FTNMPI -cp -rf FIMsrc/ FIMsrc_$FTNMPI -cd FIMsrc_$FTNMPI - -#JR If a macros.make.$FTNMPI file exists, use it. -#JR Otherwise the empty placeholder created by -#JR "touch macros.make" above will be used. -test -f macros.make.$FTNMPI && cp macros.make.$FTNMPI macros.make - -. ./fim_setup.ksh $FTNMPI -print "$FTNMPI $P build" -$MAKE $FTNMPI P=$P MAKE=$MAKE -return $? diff --git a/src/fim/FIMsrc/post/Makefile b/src/fim/FIMsrc/post/Makefile deleted file mode 100644 index 6b52a04..0000000 --- a/src/fim/FIMsrc/post/Makefile +++ /dev/null @@ -1,20 +0,0 @@ -# post Makefile - -SHELL = /bin/sh - -include ../macros.make - -all: - (cd gribio && $(MAKE) $(GMAKEMINUSJ) FC=$(FC) FFLAGS="$(FFLAGS)" LIBDIR=$(LIBDIR) CFLAGS="$(CFLAGS)") - (cd vlint && $(MAKE) FC=$(FC) FFLAGS="$(FFLAGS)" LIBDIR=$(LIBDIR)) - (cd wrfio && $(MAKE) FC=$(FC) FFLAGS="$(FFLAGS)" LIBDIR=$(LIBDIR) LIBNETCDF="$(LIBNETCDF)" INCNETCDF=$(INCNETCDF)) - (cd pop && $(MAKE) FC=$(FC) FFLAGS="$(FFLAGS)" LIBDIR=$(LIBDIR) BINDIR=$(BINDIR) LIBNETCDF="$(LIBNETCDF)") - -clean: - (cd gribio && $(MAKE) clean) - (cd vlint && $(MAKE) clean) - (cd wrfio && $(MAKE) clean) - (cd pop && $(MAKE) clean) - - - diff --git a/src/fim/FIMsrc/post/gribio/Makefile b/src/fim/FIMsrc/post/gribio/Makefile deleted file mode 100644 index 12cd69e..0000000 --- a/src/fim/FIMsrc/post/gribio/Makefile +++ /dev/null @@ -1,44 +0,0 @@ -# gribio Makefile - -# This makefile builds library of subroutines that writes grib files. - -include ../../macros.make -SHELL = /bin/sh - -AR = ar ruv -CC = cc -FFLAGS = $(FFLAGS) -LIBGRIBIO = $(LIBDIR)/libgribio.a -OBJS = $(addsuffix .o, $(basename $(SRCS))) -SRCS = $(shell ls *.F90 *.c) - -.SUFFIXES: -.SUFFIXES: .F90 .c .o .a - -#JR Changed to enable parallel make, and to generate dependencies -#JR automatically. Parallel make enabled by building the library -#JR with a single $(AR) cmd - -all: $(LIBGRIBIO) - -$(LIBGRIBIO): DEPENDENCIES $(OBJS) - $(AR) $@ $(OBJS) - -#JR If OPTFLAGS not empty, hopefully compiler will override contradictory FFLAGS settings -.F90.o: - $(FC) -c $(FFLAGS) $(OPTFLAGS) $< - -.c.o: - $(CC) $(CFLAGS) -c $(GRIBIO_CPP_FLAGS) $< -#JR $(CC) $(CFLAGS) -c -g -O0 -UDEBUG $(GRIBIO_CPP_FLAGS) $< - -DEPENDENCIES: - $(RM) -f Filepath Srcfiles - echo "." > Filepath - ls -1 *.F90 > Srcfiles - $(MKDEPENDS) -m Filepath Srcfiles > $@ - --include DEPENDENCIES - -clean: - $(RM) *.o *.mod DEPENDENCIES diff --git a/src/fim/FIMsrc/post/gribio/grib_datastru.F90 b/src/fim/FIMsrc/post/gribio/grib_datastru.F90 deleted file mode 100644 index eab97f2..0000000 --- a/src/fim/FIMsrc/post/gribio/grib_datastru.F90 +++ /dev/null @@ -1,11 +0,0 @@ -MODULE grib_datastru - - INTEGER tbl_sz, grib_lun - PARAMETER(tbl_sz=300) !maximum table size - CHARACTER*80 varnames(tbl_sz) - CHARACTER*10 varabv(tbl_sz) - INTEGER parm(tbl_sz), ztype(tbl_sz), iz1(tbl_sz),iz2(tbl_sz) - INTEGER itime_range(tbl_sz), dscal(tbl_sz) - INTEGER nvars_in_tbl - -END MODULE grib_datastru diff --git a/src/fim/FIMsrc/post/gribio/gribroutines.F90 b/src/fim/FIMsrc/post/gribio/gribroutines.F90 deleted file mode 100644 index d9b2658..0000000 --- a/src/fim/FIMsrc/post/gribio/gribroutines.F90 +++ /dev/null @@ -1,419 +0,0 @@ -!******************************************************************** -! SUBROUTINE initgrib -! -! This subroutine initializes the grib table from the text file -! and opens a grib output file for writing. -! -! Syntax: -! CALL initgrib(gribtable) -! -! -! N. Wang, May 2007, initial verision. -!******************************************************************** - subroutine initgrib (gribtable) - use grib_datastru - implicit none - - character(len=*), intent(in) :: gribtable ! rosetta stone of grib data - character(len=128) dummy_line - integer i - integer :: ioerr - - open (unit=10, file=gribtable, form='formatted', action='read', iostat=ioerr) - if (ioerr /= 0) then - write(6,*)'initgrib: bad attempt to open ', trim(gribtable) -!TODO: pass back a bad return code - end if - -! skip header lines - - do i=1,5 - read (unit=10, fmt='(a128)', iostat=ioerr) dummy_line - if (ioerr /= 0) then - write(6,*)'initgrib: bad attempt to skip line ', i, ' of file ', trim(gribtable) -!TODO: pass back a bad return code - end if - end do - -! Read in the gribtable - do i=1,tbl_sz - read (unit=10, fmt=50, end=100, iostat=ioerr) & - varnames(i),parm(i),ztype(i), iz1(i),iz2(i),itime_range(i),dscal(i),varabv(i) - 50 format(a60, i3,3x, i3,2x, i4,2x, i4,2x, i3,5x, i2,3x, a7) - - if (ioerr /= 0) then - write(6,*)'initgrib: bad attempt to read line ', i, ' of file ', trim(gribtable) -!TODO: pass back a bad return code - end if -! print *, 'initgrib: varname: ',trim(varnames(i)),' parm: ',parm(i),' ztype: ',ztype(i), ' iz1: ',iz1(i),' iz2: ',iz2(i),' itime: ', itime_range(i),' dscal: ',dscal(i),'var: ',trim(varabv(i)) - end do - 100 nvars_in_tbl = i - 1 - close (10) - - grib_lun = 0 -! CALL opengrib(gribfile) - - END SUBROUTINE initgrib - - - -!******************************************************************** -! SUBROUTINE writegrib -! -! This subroutine writes out (a variable of) grid data in 3d volume. -! It is called after the call to subroutine initgrib() -! -! Syntax: -! CALL writegrib(varname,nx,ny,nz,glvl,ct,data,date) -! varname - variable name; -! nx, ny, nz -- sizes for each dimension when it is rectangular grid; -! glvl -- grid refinement levels, only for icosahedral grid; -! ct -- curve type, only for icosahedral grid; -! data -- data array to be coded; -! date -- year, julian day and hours for the model. -! -! Note: -! nx -- the total number of grid points, when ny = 0, indicating icosahedral grid; -! -! N. Wang, May 2007, initial verision. -! N. Wang, Aug. 2007, added icosahedral model native grid. -!******************************************************************** - SUBROUTINE writegrib(var_name,nx,ny,nz,glvl,ct,data,date, nt, tba, nvlp, pres_hpa) - USE grib_datastru - IMPLICIT NONE - - CHARACTER*(*) var_name, date - INTEGER nx, ny, nz, nt, glvl, ct, nvlp - INTEGER,INTENT(IN)::tba - REAL data(*) - INTEGER pres_hpa(*) - - INTEGER pds_sz, gds_sz, bms_sz, max_vlevels - PARAMETER(pds_sz=28) - PARAMETER(gds_sz=50) - PARAMETER(max_vlevels=150) - - CHARACTER*80 varname - -! declare variables for grib table entries - CHARACTER da_char(80) - INTEGER id(pds_sz) - INTEGER idx, igrid - INTEGER yr,jday,hr, mo, day - INTEGER type, bitl, pflag, gflag, comp, bflag, blen, da_int(1) - INTEGER tot_len, err, npts, i, c_write,j - INTEGER levels(max_vlevels) - - INTEGER bdsfl(9) - DATA bdsfl/9*0/ - - character, ALLOCATABLE :: grib_buf(:) - REAL, ALLOCATABLE :: bms(:) - INTEGER, ALLOCATABLE :: gds(:) - -!JR If the size of grib_buf becomes too big, Ning says the 10 could probably -!JR be made as small as 4. The whole key is compression, specified in the -!JR gribtable. -!TODO: Reduce the 10 to something smaller for high-resolution runs. - ALLOCATE(grib_buf(nx * ny * nz * 10)) - ALLOCATE(gds(gds_sz)) - ALLOCATE(bms(nx*ny)) - -! First search the grib table for variable entry - varname = var_name - PRINT *,'writegrib: var_name: ',trim(var_name),' varname: ',trim(varname) - CALL touppercase(varname) - idx = 0 - DO i = 1,nvars_in_tbl - IF (varname .EQ. varabv(i)) THEN - idx = i - EXIT - ENDIF - ENDDO - IF (idx .EQ. 0) THEN - PRINT *,'ERROR! Variable ',varname,' does not match any variables in GRIB table' - PRINT *,'writegrib terminates!!' - STOP - ENDIF - - READ(date,'(i2,i3,i2)') yr,jday,hr !for later -! PRINT *,'Variable found ',varnames(idx),parm(idx),ztype(idx), iz1(idx),iz2(idx),itime_range(idx),dscal(idx) - -! Second, assign values to id array, which is used to create PDS by w3fi68, -! which in turn called bt w3fi72. - id(1) = 28 ! number of bytes in PDS - id(2) = 2 ! parm_table version - id(3) = 59 ! id_center: GSD = 59, NCEP = 7 - id(4) = 106 ! id_model: 105 = RUC, 106 = FIM - igrid = 255 ! 255 -- unknown grid, be defined in GDS. - IF (nx == 144) igrid = 228 !(144, 73) - IF (nx == 288) igrid = 45 !(288, 145) - IF (nx == 360) igrid = 3 !(360, 181) - IF (nx == 720) igrid = 4 !(720, 361) - id(5) = igrid ! predefined grid and proj. - id(6) = 1 ! gds_flag - id(7) = 0 ! bms_flag - - id(8) = parm(idx) ! indicator of param. and units. (Table2) - id(9) = ztype(idx) ! indicator of level type. - id(10) = iz1(idx) ! value 1 of level - id(11) = iz2(idx) ! value 2 of level - - id(12) = yr ! year of century - CALL jday2moday(yr, jday, mo, day) - id(13) = mo ! month of year - id(14) = day ! day of the month - id(15) = hr ! hour of the day - id(16) = 0 ! minute of hour - - id(17) = 1 ! forecast time unit: 0 minute, 1 hour, 2 day, 3 month - IF (itime_range(idx) == 4) THEN - id(18) = tba ! time for the beginning of accumulation - id(19) = nt ! time for the end of the accumulation - ELSE - id(18) = nt ! p1 period of time, 0 for initial analysis. - id(19) = 0 ! p2 period of time, time interval between successive - ENDIF ! analyses, or forecasts undergoing averaging. - id(20) = itime_range(idx) - - id(21) = 0 ! number included in average - id(22) = 0 ! number missing from average - IF(yr.gt.95.or.yr.eq.0) then - id(23) = 20 - ELSE - id(23) = 21 - ENDIF - id(24) = 0 ! sub_center - id(25) = dscal(idx)! decimal scale factor - - type = 0 ! 0 floating point number, 1 integer number - bitl = 0 ! computer determines the length for packing data - pflag = 0 ! pds flag, 0:make pds from caller supplied array (id) - gflag = 0 ! gds flag, 0: make gds based on igrid value - comp = 1 ! 0 earth oriented wind, 1 grid oriented wind - bflag = 1 ! bitmap flag, 0: make bitmap from caller supplied data - blen = 0 ! length of bit map, - -! if data is icosahedral model grid - IF (ny == 1) THEN - gds(1) = 0 - gds(2) = 255 - gds(3) = 12 ! grid type we give to our icosahedral hexagnal grid - gds(4) = 1024 ! the "two dimension sizes for the grid" - gds(5) = nx / 1024 + 1 - gds(6) = 26565 ! millidegrees for the lat. of the first anchor point - gds(7) = 10000 ! millidegrees for the lon. of the first anchor point - gds(8) = 0 ! N/A for our grid - gds(9) = -26565 ! millidegrees for the lat. of the last anchor point - gds(10) = 334000 ! millidegrees for the lon. of the last anchor point - gds(11) = 0 ! N/A for our grid - gds(12) = 0 ! N/A for our grid - gds(13) = ct ! curve type - gds(14) = glvl ! grid refinement levels - gflag = 1 - ENDIF -! print *,'in writegrib before create_levels ztype: ',ztype(idx),' id(11): ', id(11) - CALL create_levels(ztype(idx),nz, levels, nvlp, pres_hpa, id(11)) - DO i = 1, nz - id(11) = levels(i) -! print *,'in writegrib after create_levels: id(11): ', id(11) - if(ny==1) then - j = (i-1)*gds(4)*gds(5) + 1 - else - j = (i-1)*nx*ny + 1 - endif - CALL w3fi72(type,data(j),da_int,bitl,pflag,id,da_char,gflag,igrid,gds,comp,bflag, & - da_int,blen,bdsfl,npts,grib_buf,tot_len,err) - IF (err /= 0) THEN - CALL errormsg(err) - EXIT - ELSE -!JR Need an error check here? - err = c_write(0, tot_len, grib_buf, grib_lun) - END IF - END DO - -1111 continue - DEALLOCATE(grib_buf, gds, bms) - RETURN - END SUBROUTINE writegrib - -!******************************************************************** -! SUBROUTINE endgrib -! -! This subroutine ends the writing of grib file. -! -! Syntax: -! CALL endgrib() -! -! -! N. Wang, May 2007, initial verision. -!******************************************************************** - SUBROUTINE endgrib() - USE grib_datastru - IMPLICIT NONE - -! CALL closegrib() - - END SUBROUTINE endgrib - - -! opens an grib file using 'C' style open statement - SUBROUTINE opengrib(gribfile) - USE grib_datastru, ONLY: grib_lun - IMPLICIT NONE - CHARACTER*80 gribfile - INTEGER c_open - -!JR Should there be an error return code check here? - grib_lun = c_open(gribfile(1:LEN_TRIM(gribfile))//CHAR(0), 'w'//CHAR(0)) - write(6,*) 'opengrib: opened gribfile ', trim(gribfile), ' to grib_lun=', grib_lun - - END SUBROUTINE opengrib - - -! closes an grib file using 'C' style close statement - SUBROUTINE closegrib() - - USE grib_datastru, ONLY: grib_lun - IMPLICIT NONE - INTEGER ret, c_close - - ret = c_close(grib_lun) - - END SUBROUTINE closegrib - - SUBROUTINE create_levels(ztype, nz, levels, nvlp, pres_hpa, iz2) - IMPLICIT NONE - INTEGER ztype, nz, levels(*), nvlp, iz2 - INTEGER pres_hpa(*) - - INTEGER n_std_pres_levels, n_reg_pres_levels, n_reg_pres_levels2 - PARAMETER(n_std_pres_levels=17) - PARAMETER(n_reg_pres_levels2=111) - INTEGER i - INTEGER std_pres_levels(n_std_pres_levels) - DATA std_pres_levels/1000, 925, 850, 700, 600, 500, 400, 300, 250, 200, 150, 100, 70, 50, 30, 20, 10/ - n_reg_pres_levels = nvlp - -! print *, 'in create_levels: ztype: ',ztype,' nz: ',nz,' iz2: ',iz2 - - ! pressure levels - IF (ztype == 100) THEN - IF (nz == n_std_pres_levels) THEN - DO i = 1, n_std_pres_levels - levels(i) = std_pres_levels(i) - END DO - ELSE IF(nz == n_reg_pres_levels) THEN - DO i = 1, n_reg_pres_levels - levels(i) = pres_hpa(i) - END DO - ELSE - DO i = 1, n_reg_pres_levels2 - levels(i) = (n_reg_pres_levels2 - i) * 10 - END DO - ENDIF - ! m above ground - nz should be 1 - ELSE IF (ztype == 105) THEN - DO i = 1, nz - levels(i) = iz2 - END DO - ! hybrid levels - ELSE - DO i = 1, nz - levels(i) = i - END DO - END IF - - END SUBROUTINE create_levels - -! Misc subroutines - SUBROUTINE jday2moday(yr, jday, mo, day) - - IMPLICIT NONE - INTEGER yr, jday, mo, day - INTEGER jdate(13), jdate_ly(13), i - LOGICAL leap_year - - DATA jdate/0, 31,59,90,120,151,181,212,243,273,304,334,365/ - DATA jdate_ly/0, 31,60,91,121,152,182,213,244,274,305,335,366/ - - IF (mod(yr, 4) == 0 .AND. mod(yr, 100) /= 0) THEN - leap_year = .TRUE. - ELSE - leap_year = .FALSE. - ENDIF - - DO i = 2, 13 - IF (.NOT. leap_year .AND. jday <= jdate(i)) THEN - mo = i - 1 - day = jday - jdate(mo) - EXIT - END IF - IF (leap_year .AND. jday <= jdate_ly(i)) THEN - mo = i - 1 - day = jday - jdate_ly(mo) - EXIT - END IF - END DO - END SUBROUTINE jday2moday - - - SUBROUTINE touppercase(str) - IMPLICIT NONE - - CHARACTER*80 str - INTEGER len, i - - len = LEN_TRIM(str) - DO i = 1, len - IF (ichar(str(i:i)) >= ichar('a') .AND. ichar(str(i:i)) <= ichar('z')) THEN - str(i:i) = char(ichar(str(i:i)) - 32) - END IF - END DO - - END SUBROUTINE touppercase - - SUBROUTINE tolowercase(str) - IMPLICIT NONE - - CHARACTER*80 str - INTEGER len, i - - len = LEN_TRIM(str) - DO i = 1, len - IF (ichar(str(i:i)) >= ichar('A') .AND. ichar(str(i:i)) <= ichar('Z')) THEN - str(i:i) = char(ichar(str(i:i)) + 32) - END IF - END DO - END SUBROUTINE tolowercase - - - SUBROUTINE errormsg(err) - IMPLICIT NONE - - INTEGER err - IF (err == 1) THEN - PRINT*, 'PDS flag error (It should be 1 or 0)' - ELSEIF (err == 2) THEN - PRINT*, 'GDS flag error (It should be 1 or 0)' - ELSEIF (err == 3) THEN - PRINT*, 'Error converting IEEE floating point number to IBM 370 floating point number' - ELSEIF (err == 4) THEN - PRINT*, 'Grid id not defined' - ELSEIF (err == 5) THEN - PRINT*, 'W3fi74 error: grid representation type not valid' - ELSEIF (err == 6) THEN - PRINT*, 'Grid too large for packer dimension arrays' - ELSEIF (err == 7) THEN - PRINT*, 'Length of bitmap not equal to size of the filed' - ELSEIF (err == 8) THEN - PRINT*, 'W3fi73 error: bitmap values all zero' - ELSEIF (err == 9) THEN - PRINT*, 'W3fi75(58) error: pack routine dynamic range overflow' - ELSE - PRINT*, 'Error code is ', err - END IF - PRINT*, 'Gribbing failed' - - END SUBROUTINE errormsg diff --git a/src/fim/FIMsrc/post/gribio/gribroutines.F90.old b/src/fim/FIMsrc/post/gribio/gribroutines.F90.old deleted file mode 100644 index 480793d..0000000 --- a/src/fim/FIMsrc/post/gribio/gribroutines.F90.old +++ /dev/null @@ -1,362 +0,0 @@ -!******************************************************************** -! SUBROUTINE initgrib -! -! This subroutine initializes the grib table from the text file -! and opens a grib output file for writing. -! -! Syntax: -! CALL initgrib(gribtable) -! -! -! N. Wang, May 2007, initial verision. -!******************************************************************** - SUBROUTINE initgrib(gribtable) - USE grib_datastru - IMPLICIT NONE - - CHARACTER*80 gribtable, gribfile - CHARACTER*128 dummy_line - INTEGER i - - OPEN(unit=10,file=gribtable,status='old') - - DO i = 1, 5 ! skip header lines - READ(10,'(a128)',end=20) dummy_line - ENDDO -20 CONTINUE - -! Read in the table - DO i = 1, tbl_sz - READ(10, 50, end=100) varnames(i),parm(i),ztype(i), iz1(i),iz2(i),itime_range(i),dscal(i),varabv(i) - 50 format(a60,i3,3x,i3,2x,i4,2x,i4,2x,i3,5x,i2,3x,a7) - -! PRINT*, varnames(i),parm(i),ztype(i), iz1(i),iz2(i),itime_range(i),dscal(i),varabv(i) - ENDDO - 100 nvars_in_tbl = i - 1 - CLOSE(10) - - grib_lun = 0 -! CALL opengrib(gribfile) - - END SUBROUTINE initgrib - - - -!******************************************************************** -! SUBROUTINE writegrib -! -! This subroutine writes out (a variable of) grid data in 3d volume. -! It is called after the call to subroutine initgrib() -! -! Syntax: -! CALL writegrib(varname,nx,ny,nz,glvl,ct,data,date) -! varname - variable name; -! nx, ny, nz -- sizes for each dimension when it is rectangular grid; -! glvl -- grid refinement levels, only for icosahedral grid; -! ct -- curve type, only for icosahedral grid; -! data -- data array to be coded; -! date -- year, julian day and hours for the model. -! -! Note: -! nx -- the total number of grid points, when ny = 0, indicating icosahedral grid; -! -! N. Wang, May 2007, initial verision. -! N. Wang, Aug. 2007, added icosahedral model native grid. -!******************************************************************** - SUBROUTINE writegrib(var_name,nx,ny,nz,glvl,ct,data,date, nt) - USE grib_datastru - IMPLICIT NONE - - CHARACTER*80 var_name, date - INTEGER nx, ny, nz, nt, glvl, ct - REAL data(*) - - INTEGER pds_sz, gds_sz, bms_sz, max_vlevels - PARAMETER(pds_sz=28) - PARAMETER(gds_sz=50) - PARAMETER(max_vlevels=150) - - CHARACTER*80 varname - -! declare variables for grib table entries - CHARACTER da_char - INTEGER id(pds_sz) - INTEGER idx, igrid - INTEGER yr,jday,hr, mo, day - INTEGER type, bitl, pflag, gflag, comp, bflag, blen, da_int - INTEGER tot_len, err, npts, i, c_write - INTEGER levels(max_vlevels) - - INTEGER bdsfl(9) - DATA bdsfl/9*0/ - - REAL, ALLOCATABLE :: grib_buf(:) - REAL, ALLOCATABLE :: bms(:) - INTEGER, ALLOCATABLE :: gds(:) - - ALLOCATE(grib_buf(nx * ny * nz * 10)) - ALLOCATE(gds(gds_sz)) - ALLOCATE(bms(nx*ny)) - -! First search the grib table for variable entry - varname = var_name - CALL touppercase(varname) - idx = 0 - DO i = 1,nvars_in_tbl - IF (varname .EQ. varabv(i)) THEN - idx = i - EXIT - ENDIF - ENDDO - IF (idx .EQ. 0) THEN - PRINT *,'ERROR! Variable ',varname,' does not match any variables in GRIB table' - PRINT *,'writegrib terminates!!' - STOP - ENDIF - - READ(date,'(i2,i3,i2)') yr,jday,hr !for later -! PRINT *,'Variable found ',varnames(idx),parm(idx),ztype(idx), iz1(idx),iz2(idx),itime_range(idx),dscal(idx) - -! Second, assign values to id array, which is used to create PDS by w3fi68, -! which in turn called bt w3fi72. - id(1) = 28 ! number of bytes in PDS - id(2) = 2 ! parm_table version - id(3) = 59 ! id_center - id(4) = 105 ! id_model: 7 = NCEP, 105 = FSL - igrid = 255 ! 255 -- unknown grid, be defined in GDS. - IF (nx == 144) igrid = 228 !(144, 73) - IF (nx == 288) igrid = 45 !(288, 145) - IF (nx == 360) igrid = 3 !(360, 181) - IF (nx == 720) igrid = 4 !(720, 361) - id(5) = igrid ! predefined grid and proj. - id(6) = 1 ! gds_flag - id(7) = 0 ! bms_flag - - id(8) = parm(idx) ! indicator of param. and units. (Table2) - id(9) = ztype(idx) ! indicator of level type. - id(10) = iz1(idx) ! value 1 of level - id(11) = iz2(idx) ! value 2 of level - - id(12) = yr ! year of century - CALL jday2moday(yr, jday, mo, day) - id(13) = mo ! month of year - id(14) = day ! day of the month - id(15) = hr ! hour of the day - id(16) = 0 ! minute of hour - - id(17) = 1 ! forecast time unit: 0 minute, 1 hour, 2 day, 3 month - id(18) = nt ! p1 period of time, 0 for initial analysis. - id(19) = 0 ! p2 period of time, time interval between successive - ! analyses, or forecasts undergoing averaging. - id(20) = itime_range(idx) - - id(21) = 0 ! number included in average - id(22) = 0 ! number missing from average - IF(yr.gt.95.or.yr.eq.0) then - id(23) = 20 - ELSE - id(23) = 21 - ENDIF - id(24) = 0 ! sub_center - id(25) = dscal(idx)! decimal scale factor - - type = 0 ! 0 floating point number, 1 integer number - bitl = 0 ! computer determines the length for packing data - pflag = 0 ! pds flag, 0:make pds from caller supplied array (id) - gflag = 0 ! gds flag, 0: make gds based on igrid value - comp = 1 ! 0 earth oriented wind, 1 grid oriented wind - bflag = 1 ! bitmap flag, 0: make bitmap from caller supplied data - blen = 0 ! length of bit map, - -! if data is icosahedral model grid - IF (ny == 1) THEN - gds(1) = 0 - gds(2) = 255 - gds(3) = 12 ! grid type we give to our icosahedral hexagnal grid - gds(4) = 1024 ! the "two dimension sizes for the grid" - gds(5) = nx / 1024 + 1 - gds(6) = 26565 ! millidegrees for the lat. of the first anchor point - gds(7) = 10000 ! millidegrees for the lon. of the first anchor point - gds(8) = 0 ! N/A for our grid - gds(9) = -26565 ! millidegrees for the lat. of the last anchor point - gds(10) = 334000 ! millidegrees for the lon. of the last anchor point - gds(11) = 0 ! N/A for our grid - gds(12) = 0 ! N/A for our grid - gds(13) = ct ! curve type - gds(14) = glvl ! grid refinement levels - gflag = 1 - ENDIF - CALL create_levels(ztype(idx),nz, levels) - DO i = 1, nz - enddo - DO i = 1, nz - id(11) = levels(i) - CALL w3fi72(type,data((i-1)*gds(4)*gds(5) + 1),da_int,bitl,pflag,id,da_char,gflag,igrid,gds,comp,bflag,da_int,blen,bdsfl,npts,grib_buf,tot_len,err) - IF (err /= 0) THEN - CALL errormsg(err) - EXIT - ELSE - err = c_write(0, tot_len, grib_buf, grib_lun) - END IF - END DO - -1111 continue - DEALLOCATE(grib_buf, gds, bms) - RETURN - END SUBROUTINE writegrib - -!******************************************************************** -! SUBROUTINE endgrib -! -! This subroutine ends the writing of grib file. -! -! Syntax: -! CALL endgrib() -! -! -! N. Wang, May 2007, initial verision. -!******************************************************************** - SUBROUTINE endgrib() - USE grib_datastru - IMPLICIT NONE - -! CALL closegrib() - - END SUBROUTINE endgrib - - -! opens an grib file using 'C' style open statement - SUBROUTINE opengrib(gribfile) - USE grib_datastru, ONLY: grib_lun - IMPLICIT NONE - CHARACTER*80 gribfile - INTEGER c_open - - grib_lun = c_open(gribfile(1:LEN_TRIM(gribfile))//CHAR(0), 'w'//CHAR(0)) - - END SUBROUTINE opengrib - - -! closes an grib file using 'C' style close statement - SUBROUTINE closegrib() - - USE grib_datastru, ONLY: grib_lun - IMPLICIT NONE - INTEGER ret, c_close - - ret = c_close(grib_lun) - - END SUBROUTINE closegrib - - SUBROUTINE create_levels(ztype, nz, levels) - IMPLICIT NONE - INTEGER ztype, nz, levels(*) - - INTEGER n_std_pres_levels, n_reg_pres_levels - PARAMETER(n_std_pres_levels=17) - PARAMETER(n_reg_pres_levels=111) - INTEGER i - INTEGER std_pres_levels(n_std_pres_levels) - DATA std_pres_levels/1000, 925, 850, 700, 600, 500, 400, 300, 250, 200, 150, 100, 70, 50, 30, 20, 10/ - - IF (ztype == 100) THEN - IF (nz .le. 17) THEN - DO i = 1, n_std_pres_levels - levels(i) = std_pres_levels(i) - END DO - ELSE - DO i = 1, n_reg_pres_levels - levels(i) = (n_reg_pres_levels - i) * 10 - END DO - ENDIF - ELSE - DO i = 1, nz - levels(i) = i - END DO - END IF - - END SUBROUTINE create_levels - -! Misc subroutines - SUBROUTINE jday2moday(yr, jday, mo, day) - - IMPLICIT NONE - INTEGER yr, jday, mo, day - INTEGER jdate(13), jdate_ly(13), i - LOGICAL leap_year - - DATA jdate/0, 31,59,90,120,151,181,212,243,273,304,334,365/ - DATA jdate_ly/0, 31,60,91,121,152,182,213,244,274,305,335,366/ - - IF (mod(yr, 4) == 0 .AND. mod(yr, 100) /= 0) THEN - leap_year = .TRUE. - ELSE - leap_year = .FALSE. - ENDIF - - DO i = 2, 12 - IF (.NOT. leap_year .AND. jday <= jdate(i)) THEN - mo = i - 1 - day = jday - jdate(mo) - EXIT - END IF - IF (leap_year .AND. jday <= jdate_ly(i)) THEN - mo = i - 1 - day = jday - jdate_ly(mo) - EXIT - END IF - END DO - END SUBROUTINE jday2moday - - - SUBROUTINE touppercase(str) - IMPLICIT NONE - - CHARACTER*80 str - INTEGER len, i - - len = LEN_TRIM(str) - DO i = 1, len - IF (ichar(str(i:i)) > ichar('a')) THEN - str(i:i) = char(ichar(str(i:i)) - 32) - END IF - END DO - - END SUBROUTINE touppercase - - - SUBROUTINE errormsg(err) - IMPLICIT NONE - - INTEGER err - IF (err == 1) THEN - PRINT*, 'PDS flag error (It should be 1 or 0)' - ELSEIF (err == 2) THEN - PRINT*, 'GDS flag error (It should be 1 or 0)' - ELSEIF (err == 3) THEN - PRINT*, 'Error converting IEEE floating point number to IBM 370 floating point number' - ELSEIF (err == 4) THEN - PRINT*, 'Grid id not defined' - ELSEIF (err == 5) THEN - PRINT*, 'W3fi74 error: grid representation type not valid' - ELSEIF (err == 6) THEN - PRINT*, 'Grid too large for packer dimension arrays' - ELSEIF (err == 7) THEN - PRINT*, 'Length of bitmap not equal to size of the filed' - ELSEIF (err == 8) THEN - PRINT*, 'W3fi73 error: bitmap values all zero' - ELSEIF (err == 9) THEN - PRINT*, 'W3fi75(58) error: pack routine dynamic range overflow' - ELSE - PRINT*, 'Error code is ', err - END IF - PRINT*, 'Gribbing failed' - - END SUBROUTINE errormsg - - - - - - - diff --git a/src/fim/FIMsrc/post/gribio/io_utils.c b/src/fim/FIMsrc/post/gribio/io_utils.c deleted file mode 100644 index b8d86df..0000000 --- a/src/fim/FIMsrc/post/gribio/io_utils.c +++ /dev/null @@ -1,727 +0,0 @@ -#if defined(IBM) || defined(HP) - -#define c_pause c_pause -#define iralloc iralloc -#define irfree irfree -#define c_open c_open -#define c_close c_close -#define c_read c_read -#define c_write c_write -#define findgrib findgrib -#define cv_to_ut cv_to_ut -#define cv_fr_ut cv_fr_ut -#define julian_date julian_date -#define calandar_date calander_date - -#elif defined(SUN) || defined(SGI) - -#define c_pause c_pause_ -#define iralloc iralloc_ -#define irfree irfree_ -#define c_open c_open_ -#define c_close c_close_ -#define c_read c_read_ -#define c_write c_write_ -#define findgrib findgrib_ -#define cv_to_ut cv_to_ut_ -#define cv_fr_ut cv_fr_ut_ -#define julian_date julian_date_ -#define calandar_date calander_date_ -#define c_swap4 c_swap4_ -#define c_view4 c_view4_ - -#elif defined(ALPHA) - -#define c_pause c_pause__ -#define iralloc iralloc__ -#define irfree irfree__ -#define c_open c_open__ -#define c_close c_close__ -#define c_read c_read__ -#define c_write c_write__ -#define findgrib findgrib__ -#define cv_to_ut cv_to_ut__ -#define cv_fr_ut cv_fr_ut__ -#define julian_date julian_date__ -#define calandar_date calander_date__ -#define c_swap4 c_swap4__ -#define c_view4 c_view4__ - -#elif defined(STARDENT) || defined(CRAY) - -#define c_pause C_PAUSE -#define iralloc IRALLOC -#define irfree IRFREE -#define c_open C_OPEN -#define c_close C_CLOSE -#define c_read C_READ -#define c_write C_WRITE -#define findgrib FINDGRIB -#define cv_to_ut CV_TO_UT -#define cv_fr_ut CV_FR_UT -#define julian_date JULIAN_DATE -#define calandar_date CALANDER_DATE - -#endif - - -/*#ifdef LITTLE_END*/ - #define BDS_LEN(bds) ((int) ((bds[0]<<16)+(bds[1]<<8)+bds[2])) - #define BMS_LEN(bms) ((bms) == NULL ? 0 : (bms[0]<<16)+(bms[1]<<8)+bms[2]) - #define GDS_LEN(gds) ((int) ((gds[0]<<16)+(gds[1]<<8)+gds[2])) - #define PDS_LEN(pds) ((int) ((pds[0]<<16)+(pds[1]<<8)+pds[2])) - - #define PDS_HAS_GDS(pds) ((pds[7] & 128) != 0) - #define PDS_HAS_BMS(pds) ((pds[7] & 64) != 0) - - #define LEN_HEADER_PDS (28+42+100) - #define END_LEN 4 -/*#endif*/ - -#include -#include -#include -#include -#include -#include -#include -#define TRUE 1 -#define FALSE 0 - -#define MAXFILES 256 - -struct file_s{ - FILE *F; - int f; -}; - -struct file_s file[MAXFILES]; -int init = 0; - - -struct s_gribstat{ - int bds_start; - long pds_len; - long gds_len; - long bms_len; - long end_len; - long bds_len; -} sg; - - -/*---+----------------------------------------------------------------*/ -/* -int isprint(char c){ - return(c>=0 && c<126); -} -*/ -/*---+----------------------------------------------------------------*/ - - -/*---+----------------------------------------------------------------*/ -FILE *findfile(int fd){ - - int i; - - -#ifdef DEBUG - i=0; - printf("file[%d].f : %d\tfile[%d].F : %d\n", i, file[i].f, i, file[i].F); - i=1; - while(i findfile() : file descriptor not found"); - exit(1); -}/*end fildfile()*/ -/*---+----------------------------------------------------------------*/ - - -/*---+----------------------------------------------------------------*/ - -void *iralloc(int *memtot, char *ia, int *ioff) - -{ - char *addr; - - addr = calloc(*memtot,4); - *ioff = (addr-ia)/4; -/* printf("in ralloc- %i %i %i \n",*memtot,iaddr,*ioff); -*/ - return(addr); -} - - - -/*---+----------------------------------------------------------------*/ - -void irfree(char **addr) - -{ - free(*addr); -} - - -/*---+----------------------------------------------------------------*/ - -int c_open(char *filename, char *faccess) - -{ - - int i; - int done=0; - - /* initialize file structure */ - if(init == 0) { - for(i=0; i= MAXFILES) { - perror("io_utils.c -> c_open(): MAXFILES exceeded"); - exit(1); - } - if ((file[i].f==0) && (file[i].F==NULL)) { - file[i].F = fopen(filename,faccess); - if (file[i].F==NULL) { - file[i].f=0; - } - else { - file[i].f = fileno(file[i].F); - } - done=1; - } - else { - i++; - } - } - - return(file[i].f); -} - - - -/*---+----------------------------------------------------------------*/ - -int c_close(int *fd) -{ -#ifdef DEBUG - printf("c_close called...\n\n"); -#endif - - int i,err; - - - for(i=0; i c_close() : file descriptor not found"); - exit(1); - -} - - - -/*---+----------------------------------------------------------------*/ - -int c_read(int *fbyte, int *numbytes, void *a, int *fd) - -{ - int retcode; - -#ifdef DEBUG - printf("c_read called...\n\n"); - printf("fbyte %d\n",(int)*fbyte); - printf("numbytes : %d\n",(int)*numbytes); - printf("fd : %d\n",(int)*fd); - printf("findfile result : %d\n",findfile((int)*fd)); -#endif - - - retcode=fseek(findfile((int)*fd),*fbyte,0); - - if(retcode != 0) - { - /* JR NOTE: "file" is not a char * */ - printf("C_read error - filename %s \n",file); - return(retcode); - } - - retcode=fread((char*)a,1,*numbytes,findfile((int)*fd)); - - if(retcode != *numbytes) - { - return(errno); - } - else - { - return(0); - } -} - -/*---+----------------------------------------------------------------*/ - -int c_write(int *fbyte, int *numbytes, void *a, int *fd) -{ - int retcode; - int i = 0; - - -#ifdef DEBUG - char *b = (char *) a; -#endif - - - -#ifdef DEBUG - - printf("c_write called...\n\n"); - printf("entered c_write...\n"); - printf("*fbyte : %d\n",*fbyte); - printf("*numbytes : %d\n",*numbytes); - printf("*a : %p\n",a); - printf("*fd : %d\n\n",*fd); - - while(getchar() != 'q' && (i < (*numbytes-1))){ - /*printf("a[%i] = %c\n", i, (char ) ((char *)a + i*sizeof(char *)));*/ - if((char)*(b) == 0){ printf("NULL\n"); i++; b++; continue; } - - if((char)*(b)== 1){ printf("'1'\n"); i++; b++; continue; } - - printf("b[%i] = %c\n", i, (char ) *(b++)); - i++; - } -#endif - - if(*numbytes == 0 ){ - perror("asked c_write to write ZERO bytes!!"); - return -1; - } - - retcode=fseek(findfile((int)*fd),*fbyte,2); - - if(retcode != 0) - { - /* JR NOTE "findfile" is not a char * */ - printf("C_write error - filename %s \n",findfile((int)*fd)); - return(retcode); - } - - - retcode=fwrite((char*)a,1,*numbytes,findfile((int)*fd)); - - if(retcode != *numbytes) - { - - return(errno); - } - else - { - return(0); - } -} - - - - -/*---+----------------------------------------------------------------*/ - -#define WORD_SIZE sizeof(int) /*assumed addresses are same size as INT*/ - - - -int c_swap4(int *numbytes, void *a) -{ - int retcode = 0; - int i = 0; - - int j = 0; /*where the data starts*/ - int last = 0; /*index of last full word to swap*/ - int n_end = 0; /*number of 'lose' bytes at end of odd length buffer*/ - - char *b = (char *) a; - - - if(*numbytes < 4) perror("SWAPPING LESS THAN FOUR BYTES! "); - - if((unsigned long) b % WORD_SIZE != 0 ) printf("INPUT BUFFER NOT ALIGNED ON WORD BOUNDRY!\n"); - - /*perror("INPUT BUFFER NOT ALIGNED ON WORD BOUNDRY! ");*/ - - - last = (int) (((*numbytes / ((int) WORD_SIZE))-1) * ((int) WORD_SIZE)); - - - if(last < 0 || *numbytes < 0) { perror("OVERFLOW IN IO_UTILS.C - C_SWAP4"); exit(1); } - - n_end = *numbytes % WORD_SIZE; - -#ifdef DEBUG - printf("c_swap4 called...\n\n"); - printf("\n\n"); - printf("a's addr : %ld\n", a); - printf("WORD_SIZE : %d\n", WORD_SIZE); - printf("numbytes : %d\n", *numbytes); - printf("last = (((*numbytes / WORD_SIZE)-1) * WORD_SIZE)\n"); - printf("last : %d\n", last); - printf("n_end : %d\n", n_end); - - /* get j to the right place!!!! */ -j: - printf("\nenter a byte to start swapping at! : "); - scanf ("%d",&j); - printf("\n"); - if(j%100000 == 0) printf("j : %d\n",j); - printf("a+j's addr : %d\n\n",a+j); - printf("SWAPPING!!\n"); -#endif - - -/*code to align on a word boundry*/ -/*while((int)a % sizeof(int) != 0) j++;*/ - - - - -/* swap bytes from big/little endian to little/big endian */ - - if(*numbytes >= 4){ - while(j <= last){ - - b[j] = b[j] ^ b[j+3]; - b[j+3] = b[j] ^ b[j+3]; /*swap j and j+3*/ - b[j] = b[j] ^ b[j+3]; - - b[j+1] = b[j+1] ^ b[j+2]; - b[j+2] = b[j+1] ^ b[j+2]; /*swap j+1 and j+2*/ - b[j+1] = b[j+1] ^ b[j+2]; - - j += 4; -#ifdef DEBUG -/* printf("j : %d\n",j); */ -#endif - } - } - - switch(n_end){ - case 3: b[j+1] = b[j+1] ^ b[j+2]; - b[j+2] = b[j+1] ^ b[j+2]; /*swap j+1 and j+2*/ - b[j+1] = b[j+1] ^ b[j+2]; - -/*#ifdef DEBUG*/ - if(b[j] != 0) perror("CANNOT SWAP THIS WORD, UNKNOWN BYTE # 4! "); - retcode = 1; -/*#endif*/ - break; - -#ifdef DEBUG - case 2: if((b[j]+b[j+1]) != 0) perror("CANNOT SWAP THIS WORD, UNKNOWN BYTE # 3 AND 4! "); - retcode = 1; - break; - - case 1: if(b[j] != 0) perror("CANNOT SWAP THIS WORD, UNKNOWN BYTE # 2 AND 3 AND 4! "); - retcode = 1; - break; -#endif - - default: break; - } - - return(retcode); -}/* end c_swap4() */ - - -/*---+----------------------------------------------------------------*/ - -int c_view4(int *numbytes, void *a, int *iy) -{ - int retcode = 0; - int i = 0; - int old_numbytes = *numbytes; - long j = 0; /*where the data starts*/ - char C[3]; - - char *b = (char *) a; - float *c = (float *) a; - int *d = (int *) a; - - C[0] = C[1] = C[2] = 0; - - printf("\n\n\n"); - printf("c_view4 called...\n"); - printf("a's addr : %p\n",a); - printf("numbytes : %d\n",*numbytes); - printf("iy : %i\n",*iy); - - if(*iy == 0){ - printf("viewing as CHAR...\n"); - - i = 0; -/* - while(i < *numbytes && ((char) *b == NULL)){ - i++; - b++; - } -*/ - while(i < *numbytes && getchar() != 'q'){ - C[1] = (char) *b; - printf("b[%i] = %o\t@ %d\n", i, C[1] ,b); - i++; - b++; - } - } - - if(*iy == 1){ - printf("viewing as FLOAT...\n"); - - i = 0; - while(i < *numbytes && ((float) *(c) == 0)){ - i++; - c++; - } - - while(i < *numbytes && getchar() != 'q'){ - printf("c[%i] = %f\t@ %p\n", i, (float ) *(c), c); - if(i < *numbytes && ((float) *c != 0)){ - i++; - c++; - continue; - } - while(i < *numbytes && ((float) *c == 0)){ - i++; - c++; - } - } - } - - if(*iy == 2){ - printf("viewing as INT...\n"); - - i = 0; - while(i < *numbytes && ((int) *d == 0) ){ - i++; - d++; - } - - while(getchar() != 'q'){ - printf("d[%i] = %i\t@ %p\n", i, (int ) *d, d); - if(i < *numbytes && ( (int) *d != 0)){ - i++; - d++; - continue; - } - while(i < *numbytes && ((int) *(d) == 0)){ - i++; - d++; - } - } - } - - /**numbytes = old_numbytes;*/ - return(retcode); -}/* end c_view4() */ - - -/*---+----------------------------------------------------------------*/ - -int findgrib(int *fd) -{ - int found, grib_byte, buf_counter, num; - char buf[8200], *place_ptr, *t_ptr; - - grib_byte=0; - found=FALSE; - buf_counter=0; - - rewind(findfile((int)*fd)); - - while (!found) - { - fread(buf,sizeof(char),8192,findfile((int)*fd)); - buf[8192]=0; -/* replace occurrences of null with a blank in buf - because strstr will stop when it reaches a null -*/ - t_ptr = buf; - num = 8192; - while((t_ptr = memchr(t_ptr,0,num)) != NULL) - { - *t_ptr=' '; - num = 8192 - (t_ptr-buf); - } - place_ptr = strstr(buf,"GRIB"); - if(place_ptr == NULL) - { - buf_counter+=8192; - } - else - { - found=TRUE; - grib_byte=(place_ptr - buf) + buf_counter; - } - } - return(grib_byte); -} - - - - - - - - - - -/************************************************************************* - * TIME_DATE.C: Routines to do time/date convertions. FORTRAN CALLABLE - * Note. Use Full year, i.e. 1991, not '91. (Unix time routines - * often leave off the '19'.) Watch out! - * Jan is month 1. - * - * F Hage Oct, 1992 NCAR/RAP - * Converted names for Stupid CRAY Naming conventions - - */ - -/************************************************************************* - * CONVERT_TO_UNIX_TIME: Take the separate time fields - * and calculate the unix time. FORTRAN CALLABLE: - * CALL CONVERT_TO_UNIX_TIME(YEAR,MONTH,DAY,HOUR,MIN,SEC,UTIME) - * Returns the unix time in UTIME - */ - -void cv_to_ut(year,month,day,hour,min,sec,utime) - int *year,*month,*day,*hour,*min,*sec,*utime; -{ - long u_day,jday,days; - long u_time; - - u_day = julian_date(1,1,1970); - jday = julian_date((*day),(*month),(*year)); - - days = jday - u_day; - - *utime = (days * 86400) + (*hour * 3600) + (*min * 60) + *sec; -} - - -/************************************************************************* - * CONVERT_FROM_UNIX_TIME: Take the unix time field - * and calculate the seperate time fields. FORTRAN CALLABLE: - * CALL CONVERT_FROM_UNIX_TIME(YEAR,MONTH,DAY,HOUR,MIN,SEC,UTIME) - * Returns the time in YEAR,MONTH,DAY,HOUR,MIN,SEC - */ - -void cv_fr_ut(year,month,day,hour,min,sec,utime) - int *year,*month,*day,*hour,*min,*sec,*utime; -{ - long u_day,j_day,days; - - u_day = julian_date(1,1,1970); - - j_day = (*utime / 86400); - - calandar_date((u_day + j_day),day,month,year); - - j_day = (*utime % 86400); - *hour = j_day / 3600; - *min = (j_day / 60) - (*hour * 60); - *sec = j_day % 60; -} - -/************************************************************************* - * JULIAN_DATE: Calc the Julian calandar Day Number - * As Taken from Computer Language- Dec 1990, pg 58 - */ - -int julian_date(int *day_ptr,int *month_ptr,int *year_ptr) -{ - int day,month,year; - int a,b; - double yr_corr; - - day=*day_ptr; - month=*month_ptr; - year=*year_ptr; - - /* correct for negative year */ - yr_corr = (year > 0? 0.0: 0.75); - if(month <=2) { - year--; - month += 12; - } - b=0; - - /* Cope with Gregorian Calandar reform */ - if(year * 10000.0 + month * 100.0 + day >= 15821015.0) { - a = year / 100; - b = 2 - a + a / 4; - } - - return (int) ((365.25 * year - yr_corr) + (long) (30.6001 * (month +1)) + day + 1720994 + b); -} - -/************************************************************************* - * CALANDAR_DATE: Calc the calandar Day from the Julian date - * As Taken from Computer Language- Dec 1990, pg 58 - * Sets day,month,year as return values. - */ - -calandar_date(jdate,day,month,year) - int jdate; - int *day,*month,*year; -{ - long a,b,c,d,e,z,alpha; - - z = jdate +1; - - /* Gregorian reform correction */ - if (z < 2299161) { - a = z; - } else { - alpha = (long) ((z - 1867216.25) / 36524.25); - a = z + 1 + alpha - alpha / 4; - } - - b = a + 1524; - c = (long) ((b - 122.1) / 365.25); - d = (long) (365.25 * c); - e = (long) ((b - d) / 30.6001); - *day = (int) b - d - (long) (30.6001 * e); - *month = (int) (e < 13.5)? e - 1 : e - 13; - *year = (int) (*month > 2.5)? (c - 4716) : c - 4715; - - return 0; -} - - -int c_pause(void){ - printf("Press any key to continue..."); getchar(); - return 0; -} diff --git a/src/fim/FIMsrc/post/pop/Makefile b/src/fim/FIMsrc/post/pop/Makefile deleted file mode 100644 index f2f682f..0000000 --- a/src/fim/FIMsrc/post/pop/Makefile +++ /dev/null @@ -1,43 +0,0 @@ -# pop Makefile - -include ../../macros.make -SHELL = /bin/sh - -DEPLIBS = $(LIBBACIO) $(LIBW3) $(LIBSLINT) $(LIBVLINT) $(LIBGRIBIO) $(LIBCNTL) $(LIBSYSSHARE) $(LIBWRFIO) -INCS = -I ../../cntl -I../../prep/incmod -I $(UTILDIR) -LIBBACIO = $(LIBDIR)/libbacio_4.a -LIBCNTL = $(LIBDIR)/libcntl.a -LIBGRIBIO = $(LIBDIR)/libgribio.a -LIBS = -L$(LIBDIR) -lbacio_4 -lw3_4 -lslint -lvlint -lgribio -lwrfio -lw3_4 -lcntl -lsysshare -LIBSLINT = $(LIBDIR)/libslint.a -LIBSYSSHARE = $(LIBDIR)/libsysshare.a -LIBVLINT = $(LIBDIR)/libvlint.a -LIBW3 = $(LIBDIR)/libw3_4.a -LIBWRFIO = $(LIBDIR)/libwrfio.a -POP = $(BINDIR)/pop -GET_GRIBOUT = $(BINDIR)/get_gribout -UTILDIR = ../../utils -UTILOBJS = $(UTILDIR)/read_queue_namelist.o \ - $(UTILDIR)/module_initial_chem_namelists.o \ - $(UTILDIR)/headers.o - -.SUFFIXES: -.SUFFIXES: .F90 .o - -#JR If OPTFLAGS not empty, hopefully compiler will override contradictory FFLAGS settings -.F90.o: - $(FC) -c $(FFLAGS) $(OPTFLAGS) $(INCS) $< $(LIBNETCDF) $(INCNETCDF) - -all: $(POP) $(GET_GRIBOUT) post.o - -$(POP): pop.F90 smooth.o fimnc.o postdata.o $(DEPLIBS) - $(FC) $(FFLAGS) $(OPTFLAGS) $(INCS) -o $(POP) smooth.o fimnc.o postdata.o $(UTILOBJS) pop.F90 $(LIBS) $(LIBNETCDF) $(INCNETCDF) - -$(GET_GRIBOUT): get_gribout.o postdata.o - $(FC) $(FFLAGS) -o $@ get_gribout.o postdata.o $(LIBSYSSHARE) - -clean: - $(RM) *.o *.mod -#post.F90 is the subroutine pop interface to FIM -post.o: post.F90 fimnc.o postdata.o -get_gribout.o: get_gribout.F90 postdata.o diff --git a/src/fim/FIMsrc/post/pop/fimnc.F90 b/src/fim/FIMsrc/post/pop/fimnc.F90 deleted file mode 100644 index 25fd8df..0000000 --- a/src/fim/FIMsrc/post/pop/fimnc.F90 +++ /dev/null @@ -1,939 +0,0 @@ -!------------------------------------------------------------------------- -! This file contsins the subroutines to create FIM output -! CF compatible netCDF file. -! -! These subroutines use WRF I/O API to create and write -! the netCDF file. At this point we have to use direct -! netCDF calls in addition to the WRF I/O API defined -! subroutines to make the netCDF file CF compatible. -! -! Ning Wang Feb. 2006 Apapted partially from Dan Shaffer's -! post.F90; -! -! Ning Wang May 2006 Added vertically interpolated datasets. -! -!------------------------------------------------------------------------- -!#define VARIABLE_LEVELS -#define ERROR_CHECK(a) call IO_DEBUG(a, __LINE__, __FILE__) - MODULE fimnc - IMPLICIT NONE - - INTEGER, PARAMETER :: dummy_com = 999 ! Dummy MPI communicator - INTEGER, PARAMETER :: WRF_REAL = 104 - INTEGER, PARAMETER :: char_len = 512 - - INTEGER :: nvls, STATUS - CHARACTER(len=char_len), dimension(3) :: dim_names - INTEGER, DIMENSION(4) :: domain_start = (/1, 1, 1, 1/) - INTEGER, DIMENSION(4) :: domain_end - CHARACTER(len=char_len) :: sysdepinfo = " " - - INTEGER :: dim_allo_set = 0 - REAL, ALLOCATABLE :: lons(:) - REAL, ALLOCATABLE :: lats(:) - REAL, ALLOCATABLE :: levels(:) - REAL, ALLOCATABLE :: times(:) - - CONTAINS - -! subroutine to init and create the netcdf file with specified variables - SUBROUTINE init_cdf_vars(output_file, file_handle, lon_dim, lat_dim, & - level_dim, num_fcst_times, training_commit, nvars, var_names, date, nvlp) - - CHARACTER(len=*) :: output_file - INTEGER :: file_handle - INTEGER :: nvlp - INTEGER :: lon_dim, lat_dim, level_dim, num_fcst_times - INTEGER :: training_commit, nvars - CHARACTER(len=*) var_names(nvars) - CHARACTER(len=19) :: date - - CHARACTER(len=char_len) :: var_name, var_description, units - - REAL :: dummy_array(1) - INTEGER :: i, nlevels - - nvls = level_dim - 1 - - domain_end(1) = lon_dim - domain_end(2) = lat_dim - domain_end(3) = level_dim - domain_end(4) = num_fcst_times - - CALL ext_ncd_ioinit(sysdepinfo, STATUS) - - CALL ext_ncd_open_for_write_begin (output_file , & - dummy_com, dummy_com, sysdepinfo, file_handle, STATUS ) - - CALL ext_ncd_put_dom_ti_char (file_handle, "Title", & - "FIM_OUTPUT", STATUS) - - ERROR_CHECK(STATUS) - - IF(training_commit == 1) THEN - DO i = 1, nvars - CALL var_info(var_names(i), var_description, units, nlevels, nvlp) - CALL write_meta(file_handle, date, var_names(i), & - var_description, units, nlevels, dummy_array) - END DO - CALL ext_ncd_open_for_write_commit (file_handle, STATUS) - ERROR_CHECK(STATUS) - ENDIF - - END SUBROUTINE init_cdf_vars - -! subroutine to init and create the netcdf file for vertical cross sections - SUBROUTINE init_cdf_vars_v(output_file, file_handle, lon_dim, lat_dim, & - level_dim, num_fcst_times, training_commit, nverlvs, nvars, var_names, date, nvlp) - - CHARACTER *(*) :: output_file - INTEGER :: file_handle - INTEGER :: nvlp - INTEGER :: lon_dim, lat_dim, level_dim, num_fcst_times - INTEGER :: training_commit, nverlvs, nvars - CHARACTER(len=19) :: date - - CHARACTER(len=char_len) :: var_name, var_description, units - CHARACTER(len=*) :: var_names(nvars) - CHARACTER(len=char_len) :: pr3d_name - - INTEGER :: nlevels, i - REAL :: dummy_array(1) - - pr3d_name = "pr3d" - nvls = nverlvs - domain_end(1) = lon_dim - domain_end(2) = lat_dim - domain_end(3) = level_dim - domain_end(4) = num_fcst_times - - CALL ext_ncd_ioinit(sysdepinfo, STATUS) - - CALL ext_ncd_open_for_write_begin (output_file , & - dummy_com, dummy_com, sysdepinfo, file_handle, STATUS ) - - CALL ext_ncd_put_dom_ti_char (file_handle, "Title", & - "FIM_OUTPUT", STATUS) - - ERROR_CHECK(STATUS) - - IF(training_commit == 1) THEN - DO i = 1, nvars - CALL var_info(var_names(i), var_description, units, nlevels, nvlp) - CALL write_meta(file_handle, date, var_names(i), & - var_description, units, level_dim, dummy_array) - END DO - CALL var_info(pr3d_name, var_description, units, nlevels, nvlp) - CALL write_meta(file_handle, date, pr3d_name, & - var_description, units, nlevels, dummy_array) - CALL ext_ncd_open_for_write_commit (file_handle, STATUS) - ERROR_CHECK(STATUS) - ENDIF - - END SUBROUTINE init_cdf_vars_v - -! subroutine to init and create the netcdf file with specified variables of -! the original icosahedral grid. - SUBROUTINE init_cdf_icos(output_file, file_handle, nip, & - level_dim, num_fcst_times, training_commit, nvars, var_names, date, nvlp) - - CHARACTER *(*) :: output_file - INTEGER :: file_handle - INTEGER :: nvlp - INTEGER :: nip, level_dim, num_fcst_times - INTEGER :: training_commit, nvars - CHARACTER(len=char_len) var_names(nvars) - CHARACTER(len=19) :: date - - CHARACTER(len=char_len) :: var_name, var_description, units - - REAL :: dummy_array(1) - INTEGER :: i, nlevels - - nvls = level_dim - 1 - - domain_end(1) = nip - domain_end(2) = 1 - domain_end(3) = level_dim - domain_end(4) = num_fcst_times - - CALL ext_ncd_ioinit(sysdepinfo, STATUS) - - CALL ext_ncd_open_for_write_begin (output_file , & - dummy_com, dummy_com, sysdepinfo, file_handle, STATUS ) - - CALL ext_ncd_put_dom_ti_char (file_handle, "Title", & - "FIM_OUTPUT", STATUS) - - ERROR_CHECK(STATUS) - - IF(training_commit == 1) THEN - DO i = 1, nvars - CALL var_info(var_names(i), var_description, units, nlevels, nvlp) - CALL write_meta(file_handle, date, var_names(i), & - var_description, units, nlevels, dummy_array) - END DO - CALL ext_ncd_open_for_write_commit (file_handle, STATUS) - ERROR_CHECK(STATUS) - ENDIF - - END SUBROUTINE init_cdf_icos - -! subroutine to close the netcdf file - SUBROUTINE close_cdf (file_handle) - INTEGER :: file_handle - call ext_ncd_ioclose(file_handle, STATUS ) - ERROR_CHECK(STATUS) - - call ext_ncd_ioexit( STATUS ) - ERROR_CHECK(STATUS) - - END SUBROUTINE close_cdf - -! subroutine to set dim_names once before first use - SUBROUTINE set_dim_names - LOGICAL,SAVE :: first_time = .true. - IF (first_time) THEN - dim_names(1) = "lon" - dim_names(2) = "lat" - dim_names(3) = "levels" - first_time = .false. - ENDIF - END SUBROUTINE set_dim_names - -! subroutines to write a variable to the netcdf file - SUBROUTINE write_data (file_handle, date, var_name, & - var_description, var_data, units, time_step) - INTEGER :: file_handle, time_step - CHARACTER(*) :: date - REAL :: var_data(*) - CHARACTER(len=*) :: var_name, var_description, units - - CALL set_dim_names - domain_start(4) = time_step - domain_end(4) = time_step - CALL ext_ncd_write_field (file_handle, date, var_name, & - var_data, WRF_REAL, dummy_com, dummy_com, & - 0, & ! Domain Descriptor - "XYZ", & ! MemoryOrder - "", & ! Stagger - dim_names, & - domain_start, & ! Domain Start - domain_end, & ! Domain End - domain_start, & ! Memory Start - domain_end, & ! Memory End - domain_start, & ! Patch Start - domain_end, & ! Patch End - STATUS ) - ERROR_CHECK(STATUS) - - END SUBROUTINE write_data - - -! subroutine to write meta info - SUBROUTINE write_meta (file_handle, date, var_name, & - var_description, units, nlevels, var_data) - INTEGER :: file_handle, nlevels - CHARACTER(*) :: date - REAL :: var_data(*) - CHARACTER(len=char_len) :: var_name, var_description, units - - CALL set_dim_names - domain_start(4) = 1 - domain_end(4) = 1 - CALL ext_ncd_write_field (file_handle, date, var_name, & - var_data, WRF_REAL, dummy_com, dummy_com, & - 0, & ! Domain Descriptor - "XYZ", & ! MemoryOrder - "", & ! Stagger - dim_names, & - domain_start, & ! Domain Start - domain_end, & ! Domain End - domain_start, & ! Memory Start - domain_end, & ! Memory End - domain_start, & ! Patch Start - domain_end, & ! Patch End - STATUS ) - ERROR_CHECK(STATUS) - - ! Add metadata for the field - CALL ext_ncd_put_var_ti_char (file_handle ,"description", & - var_name, var_description, STATUS) - ERROR_CHECK(STATUS) - - CALL ext_ncd_put_var_ti_char (file_handle,"units", var_name, & - units, STATUS ) - ERROR_CHECK(STATUS) - - END SUBROUTINE write_meta - -! subroutine needed by wrfio API - SUBROUTINE io_debug (message_level, line_number, file_name) - INTEGER, intent(in) :: message_level, line_number - CHARACTER(len=*), intent(in) :: file_name - - IF (message_level > 0) THEN - PRINT *, "Error at ", file_name, line_number - END IF - END SUBROUTINE io_debug - -! subroutine to obtain the variable info through variable number - SUBROUTINE var_info(var_name, var_description, units, nlevels, nvlp) - CHARACTER(len=*) :: var_name, var_description, units - INTEGER :: nlevels, nvlp - - SELECT CASE (var_name) - -! 3D variables for dynamics - CASE ("us3D") - var_description = "U wind" - units = "meter.second" - nlevels = nvls - - CASE ("vs3D") - var_description = "V wind" - units = "meter.second" - nlevels = nvls - - CASE ("dp3D") - var_description = "3-D Delta Pressure" - units = "pascals" - nlevels = nvls - - CASE ("pr3D") - var_description = "3-D Pressure" - units = "pascals" - nlevels = nvls + 1 - - CASE ("mp3D") - var_description = "Montgomery Potential" - units = "meter2.second2" - nlevels = nvls - - CASE ("th3D") - var_description = "Potential Temperature" - units = "kelvin" - nlevels = nvls - - CASE ("ph3D") - var_description = "Geo Potential" - units = "meter2/second2" - nlevels = nvls + 1 - - CASE ("qv3D") - var_description = "Specific humidity" - units = "non-dimensional" - nlevels = nvls - - CASE ("rh3D") - var_description = "Relative humidity" - units = "percentage" - nlevels = nvls - - CASE ("vr3D") - var_description = "Vorticity" - units = "1/second" - nlevels = nvls - - CASE ("ws3D") - var_description = "Omega" - units = "Micro-bar/second" - nlevels = nvls - - CASE ("tk3D") - var_description = "Temperature" - units = "Kelvin" - nlevels = nvls - - CASE ("td3D") - var_description = "Dew-point temperature" - units = "Kelvin" - nlevels = nvls - -! 3D variables for chemistry - CASE ("d2st") - var_description = "coarse dust particles" - units = "ug/kg" - nlevels = nvls - - CASE ("d1st") - var_description = "fine dust particles" - units = "ug/kg" - nlevels = nvls - - CASE ("dms1") - var_description = "dms" - units = "ppm" - nlevels = nvls - - CASE ("pso2") - var_description = "so2" - units = "ppm" - nlevels = nvls - - CASE ("sulf") - var_description = "sulfate" - units = "ppm" - nlevels = nvls - - CASE ("pp25") - var_description = "other primary pm25 +volcanic ash " - units = "ug/Kg" - nlevels = nvls - - CASE ("pp10") - var_description = "other primary pm10 +volcanic ash" - units = "ug/Kg" - nlevels = nvls - - CASE ("obc1") - var_description = "hydrophobic organic carbon" - units = "ug/Kg" - nlevels = nvls - - CASE ("obc2") - var_description = "hydrophillic organic carbon" - units = "ug/Kg" - nlevels = nvls - - CASE ("pbc1") - var_description = "hydrophobic black carbon" - units = "ug/Kg" - nlevels = nvls - - CASE ("pbc2") - var_description = "hydrophillic black carbon" - units = "ug/Kg" - nlevels = nvls - - CASE ("ash1") - var_description = "volcanic ash size bin 1" - units = "ug/Kg" - nlevels = nvls - - CASE ("ash2") - var_description = "volcanic ash size bin 2" - units = "ug/Kg" - nlevels = nvls - - CASE ("ash3") - var_description = "volcanic ash size bin 3" - units = "ug/Kg" - nlevels = nvls - - CASE ("ash4") - var_description = "volcanic ash size bin 4" - units = "ug/Kg" - nlevels = nvls - - CASE ("c13D") - var_description = "radioactive tracer 1, explosive emissions with height" - units = "?" - nlevels = nvls - - CASE ("c23D") - var_description = "radioactive tracer 2, linear emissions with height" - units = "?" - nlevels = nvls - - CASE ("oc1P") - var_description = "hydrophobic organic carbon" - units = "ug/Kg" - nlevels = 40 - - CASE ("oc2P") - var_description = "hydrophobic organic carbon" - units = "ug/Kg" - nlevels = 40 - - CASE ("bc1P") - var_description = "hydrophobic black carbon" - units = "ug/Kg" - nlevels = 40 - - CASE ("bc2P") - var_description = "hydrophobic black carbon" - units = "ug/Kg" - nlevels = 40 - - CASE ("so2P") - var_description = "so2" - units = "ppm" - nlevels = 40 - - CASE ("slfP") - var_description = "sulfate" - units = "ppm" - nlevels = 40 - - CASE ("d1sP") - var_description = "dust particles" - units = "ppm" - nlevels = 40 - - CASE ("d2sP") - var_description = "dust particles" - units = "ppm" - nlevels = 40 - - CASE ("d3sP") - var_description = "dust particles" - units = "ppm" - nlevels = 40 - - CASE ("d4sP") - var_description = "dust particles" - units = "ppm" - nlevels = 40 - - CASE ("d5sP") - var_description = "dust particles" - units = "ppm" - nlevels = 40 - - CASE ("s1sP") - var_description = "seasalt" - units = "ppm" - nlevels = 40 - - CASE ("s2sP") - var_description = "seasalt" - units = "ppm" - nlevels = 40 - - CASE ("s3sP") - var_description = "seasalt" - units = "ppm" - nlevels = 40 - - CASE ("s4sP") - var_description = "seasalt" - units = "ppm" - nlevels = 40 - - CASE ("dmsP") - var_description = "dms" - units = "ppm" - nlevels = 40 - - CASE ("msaP") - var_description = "msa" - units = "ppm" - nlevels = 40 - - CASE ("p25P") - var_description = "other primary pm25" - units = "ug/Kg" - nlevels = 40 - - CASE ("p10P") - var_description = "other primary pm25" - units = "ug/Kg" - nlevels = 40 - -! 3D variables for physics - CASE ("qw3D") - var_description = "liquid cloud mixing ratio" - units = "Kg/Kg" - nlevels = nvls - - CASE ("hl3D") - var_description = "long-wave heating rate" - units = "Kelvin/second" - nlevels = nvls - - CASE ("hs3D") - var_description = "short-wave heating rate" - units = "Kelvin/second" - nlevels = nvls - - CASE ("oz3D") - var_description = "ozone" - units = "Kg/Kg" - nlevels = nvls - - CASE ("ar3D") - var_description = "aerosol" - units = "Kg/Kg" - nlevels = nvls - - CASE ("cf3D") - var_description = "cloud fraction" - units = "percent(%)" - nlevels = nvls - - CASE ("st3D") - var_description = "st" - units = "kg/meter^2" - nlevels = 4 - - CASE ("sm3D") - var_description = "sm" - units = "kg/meter^2" - nlevels = 4 - -!2D variables for physics - CASE ("sn2D") - var_description = "snow water equivalent" - units = "meter" - nlevels = 1 - - CASE ("rn2D") - var_description = "rainfall(accumulated total)" - units = "millimeter" - nlevels = 1 - - CASE ("rc2D") - var_description = "rainfall(accumulated conv.)" - units = "millimeter" - nlevels = 1 - - CASE ("rg2D") - var_description = "rainfall(accumulated large-scale)" - units = "millimeter" - nlevels = 1 - - CASE ("r12D") - var_description = "precipitation (total, since last output)" - units = "millimeter" - nlevels = 1 - - CASE ("r22D") - var_description = "precipitation (conv, since last output)" - units = "millimeter" - nlevels = 1 - - CASE ("r32D") - var_description = "precipitation (large-scale, since last output)" - units = "millimeter" - nlevels = 1 - - CASE ("pw2D") - var_description = "precipitable water" - units = "millimeter" - nlevels = 1 - - CASE ("ts2D") - var_description = "skin temperature" - units = "deg. Kelvin" - nlevels = 1 - - CASE ("us2D") - var_description = "friction velocity" - units = "meter/sec." - nlevels = 1 - - CASE ("u12D") - var_description = "u-component of wind" - units = "meter/sec." - nlevels = 1 - - CASE ("v12D") - var_description = "v-component of wind" - units = "meter/sec." - nlevels = 1 - - CASE ("hf2D") - var_description = "sensible heat flux" - units = "watt/meter^2" - nlevels = 1 - - CASE ("qf2D") - var_description = "water vapor flux" - units = "kg/meter^2" - nlevels = 1 - - CASE ("sw2D") - var_description = "sw" - units = "kg/meter^2" - nlevels = 1 - - CASE ("lw2D") - var_description = "lw" - units = "kg/meter^2" - nlevels = 1 - - CASE ("ms2D") - var_description = "mean sea level pressure" - units = "Pa" - nlevels = 1 - - CASE ("ct2D") - var_description = "cloud top height" - units = "m" - nlevels = 1 - - CASE ("cb2D") - var_description = "cloud base height" - units = "m" - nlevels = 1 - - CASE ("io2D") - var_description = "integrated organic carbon" - units = "ug/kg" - nlevels = 1 - - CASE ("ib2D") - var_description = "integrated black carbon" - units = "ug/kg" - nlevels = 1 - - CASE ("id2D") - var_description = "integrated fine dust" - units = "ug/kg" - nlevels = 1 - - CASE ("is2D") - var_description = "integrated sulfate" - units = "ppm" - nlevels = 1 - - CASE ("ia2D") - var_description = "integrated PM25" - units = "ug/m3" - nlevels = 1 - - CASE ("ao2D") - var_description = "Aerosol Optical Depth" - units = "unitless" - nlevels = 1 - - CASE ("iash") - var_description = "Vertically integrated volcanic ash" - units = "ug/kg" - nlevels = 1 - - CASE ("fl2D") - var_description = "fallout" - units = "?" - nlevels = 1 - - CASE ("rp2D") - var_description = "relative humidity with respect to precipitable water" - units = "%" - nlevels = 1 - - CASE ("ol2D") - var_description = "outgoing LW radiation at top of atmosphere" - units = "W/m**2" - nlevels = 1 - - -! FIM output variables at standard pressure levels - CASE ("hgtP") - var_description = "height at pressure levels" - units = "meter2/second2" - nlevels = nvlp - - CASE ("tmpP") - var_description = "temperature at pressure levels" - units = "deg" - nlevels = nvlp - - CASE ("rp3P") - var_description = "Relative humidity" - units = "percentage" - nlevels = nvlp - - CASE ("up3P") - var_description = "U wind" - units = "meter.second" - nlevels = nvlp - - CASE ("vp3P") - var_description = "V wind" - units = "meter.second" - nlevels = nvlp - -!temp variables - CASE ("t1xx") - var_description = "temporary variable 1" - units = "unit" - nlevels = nvls - - CASE ("t2xx") - var_description = "temporary variable 2" - units = "unit" - nlevels = nvls - - CASE ("t3xx") - var_description = "temporary variable 3" - units = "unit" - nlevels = nvls + 1 - - CASE ("t4xx") - var_description = "temporary variable 4" - units = "unit" - nlevels = 4 - - CASE ("t5xx") - var_description = "temporary variable 5" - units = "unit" - nlevels = 1 - - CASE default - write(6,*)'var_info: unknown input variable:', var_name(1:len_trim(var_name)) - STOP - - END SELECT - - END SUBROUTINE var_info - -! subroutine to set number of levels for the model - SUBROUTINE set_model_nlevels(nlevels) - INTEGER nlevels - nvls = nlevels - END SUBROUTINE set_model_nlevels - -! subroutine to specificaly train and commit to write - SUBROUTINE train_commite (file_handle, var_name, & - var_description, units, nlevels, date) - INTEGER :: file_handle, nlevels - CHARACTER(len=char_len) :: var_name, var_description, units - CHARACTER(len=19) date - REAL :: dummy_array(1) - - CALL write_meta(file_handle, date, var_name, & - var_description, units, nlevels, dummy_array) - - CALL ext_ncd_open_for_write_commit (file_handle, STATUS) - ERROR_CHECK(STATUS) - - END SUBROUTINE train_commite - -! subroutine to write all dimension variables using direct netCDF API - SUBROUTINE write_cdf_cdfapi(nc_file, lon_dim, lat_dim, & - level_dim, num_fcst_times, date, delta_t, vip_flg, nvlp, pres_hpa) - include 'netcdf.inc' - CHARACTER *(*) :: nc_file - CHARACTER(len = 19) date - INTEGER :: lon_dim, lat_dim, level_dim, num_fcst_times, delta_t, vip_flg, nvlp - INTEGER :: pres_hpa(*) - - INTEGER :: STATUS, NCID, its, i - INTEGER :: LAT_VAR_ID, LAT_DIM_ID, LON_VAR_ID, LON_DIM_ID - INTEGER :: LEVELS_VAR_ID, LEVELS_DIM_ID - INTEGER :: TIME_VAR_ID, TIME_DIM_ID - REAL :: D2R - CHARACTER(len=50) time_att_str - - D2R = atan(1.0) * 4.0 / 180.0 - - IF (dim_allo_set == 0) THEN - ALLOCATE(lons(lon_dim)) - DO its = 1, lon_dim - lons(its) = 2.0 * 180.0 * REAL(its - 1.0) & - / REAL(lon_dim) - END DO - - ALLOCATE(lats(lat_dim)) - DO its = 1, lat_dim - lats(its) = 180.0 * (REAL(its - 1) - REAL(lat_dim - 1) / 2.0) & - / REAL(lat_dim - 1.0) - lats(its) = -lats(its) - END DO - - ALLOCATE(levels(level_dim)) - IF (vip_flg == 0) THEN - DO its = 1, level_dim - levels(its) = REAL(its) - END DO - ELSE IF (vip_flg == 1) THEN - DO its = 1, level_dim - levels(its) = REAL(pres_hpa(its)) - END DO - ELSE IF (vip_flg == 2) THEN - DO its = 1, level_dim - levels(its) = REAL(level_dim - its) * 10 ! 10 mb per vertical grid - END DO - END IF - - ALLOCATE(times(num_fcst_times)) - DO its = 1, num_fcst_times - times(its) = REAL(its - 1) * REAL(delta_t) - END DO - END IF - - STATUS = nf_open(nc_file, NF_WRITE, NCID) - ERROR_CHECK(STATUS) - - STATUS = nf_redef(NCID) - ERROR_CHECK(STATUS) - - STATUS = nf_inq_dimid(NCID, 'lat', LAT_DIM_ID) - ERROR_CHECK(STATUS) - - STATUS = nf_def_var(NCID, 'lat', nf_float, 1, LAT_DIM_ID, & - LAT_VAR_ID) - ERROR_CHECK(STATUS) - - STATUS = nf_put_att_text(NCID, LAT_VAR_ID, "units", 13, & - "degrees_north") - ERROR_CHECK(STATUS) - - STATUS = nf_inq_dimid(NCID, 'lon', LON_DIM_ID) - ERROR_CHECK(STATUS) - - STATUS = nf_def_var(NCID, 'lon', nf_float, 1, LON_DIM_ID,& - LON_VAR_ID) - ERROR_CHECK(STATUS) - - STATUS = nf_put_att_text(NCID, LON_VAR_ID, "units", 12, & - "degrees_east") - ERROR_CHECK(STATUS) - - STATUS = nf_inq_dimid(NCID, 'levels', LEVELS_DIM_ID) - ERROR_CHECK(STATUS) - - STATUS = nf_def_var(NCID, 'levels', nf_float, 1, & - LEVELS_DIM_ID, LEVELS_VAR_ID) - ERROR_CHECK(STATUS) - - STATUS = nf_put_att_text(NCID, LEVELS_VAR_ID, "units", 5, & - "meter") - ERROR_CHECK(STATUS) - - STATUS = nf_inq_dimid(NCID, 'Time', TIME_DIM_ID) - ERROR_CHECK(STATUS) - - STATUS = nf_def_var(NCID, 'Time', nf_float, 1, TIME_DIM_ID, & - TIME_VAR_ID) - ERROR_CHECK(STATUS) - -! time_att_str = "Fcst intv from " // date - time_att_str = "hours since " // date - STATUS = nf_put_att_text(NCID, TIME_VAR_ID, "units", 31, & - time_att_str) -! "hours since 2006-01-01 00:00:00") - ERROR_CHECK(STATUS) - - STATUS = nf_enddef(NCID) - ERROR_CHECK(STATUS) - - STATUS = nf_put_var_real(NCID, LAT_VAR_ID, lats) - ERROR_CHECK(STATUS) - - STATUS = nf_put_var_real(NCID, LON_VAR_ID, lons) - ERROR_CHECK(STATUS) - - STATUS = nf_put_var_real(NCID, LEVELS_VAR_ID, LEVELS) - ERROR_CHECK(STATUS) - - STATUS = nf_put_var_real(NCID, TIME_VAR_ID, TIMES) - ERROR_CHECK(STATUS) - - STATUS = nf_close(NCID) - ERROR_CHECK(STATUS) - - END SUBROUTINE write_cdf_cdfapi - - END MODULE fimnc - - SUBROUTINE wrf_debug (message_level, message) - INTEGER, INTENT(in) :: message_level - CHARACTER(len=*), INTENT(in) :: message - - IF (message_level > 0) THEN - PRINT *, "Error ", message - END IF - END SUBROUTINE wrf_debug diff --git a/src/fim/FIMsrc/post/pop/get_gribout.F90 b/src/fim/FIMsrc/post/pop/get_gribout.F90 deleted file mode 100644 index 9de189e..0000000 --- a/src/fim/FIMsrc/post/pop/get_gribout.F90 +++ /dev/null @@ -1,30 +0,0 @@ -program get_gribout - use postdata, only: post_read_namelist, fimout, gribout - - implicit none - - integer :: ioerr - integer :: ret - -! After calling post_read_namelist, its public variables (fimout, gribout) are available for use - - call post_read_namelist (ret) - - if (ret < 0) then - write(*,*) 'get_gribout: failure from post_read_namelist' - stop 999 - end if - - if (gribout) then - write(*,'(a)') 'gribout:TRUE' - else - write(*,'(a)') 'gribout:FALSE' - end if - - if (fimout) then - write(*,'(a)') 'fimout:TRUE' - else - write(*,'(a)') 'fimout:FALSE' - end if - stop -end program get_gribout diff --git a/src/fim/FIMsrc/post/pop/pop.F90 b/src/fim/FIMsrc/post/pop/pop.F90 deleted file mode 100644 index 586c161..0000000 --- a/src/fim/FIMsrc/post/pop/pop.F90 +++ /dev/null @@ -1,720 +0,0 @@ -!============================================================= -! Post processor utility -! -! -! Main packages: slint (spherical linear interpolation), -! vlint (vertical linear interpolation), -! fimnc (FIM netCDF utility routines), -! gribio (FIM grib utility routines) -! -! Ning Wang, March 2007 -! -! -!============================================================= - - program pop - USE fimnc - use module_control,only: TotalTime,ArchvIntvl,curve,NumCacheBlocksPerPE,& - PrintMAXMINtimes,FixedGridOrder,nvlp,pres_hpa,& - TimingBarriers,glvl,nip,nvl,control,& - yyyymmddhhmm,ArchvTimeUnit,numphr - use postdata, only: post_read_namelist, datadir, outputdir, input, output, output_fmt, max_vars, var_list, & - multiple_output_files, gribtable, grid_id, mx, my, latlonfld, is, vres, & - mode, nsmooth_var, & - t1, t2, delta_t - USE slint, ONLY: bilinear_init_i2r, bilinear_interp_i2r, tgt_grid - - IMPLICIT NONE - -! define a derived type for variable data - TYPE array_pointer - REAL, DIMENSION(:,:), POINTER :: p - END TYPE array_pointer - - INTEGER :: nverlvs !The number of vertical levels defined in the Makefile - INTEGER :: iargc ! command line argument count - INTEGER :: nvars, nfct - CHARACTER(len=char_len) :: init_file - CHARACTER(len=6) :: ahr - CHARACTER(len=8) :: FMT='(I3.3)' - CHARACTER(len=80) :: FMT2 - INTEGER :: file_handle - INTEGER :: var_num, nlevels - INTEGER :: year, month, day, hour, minute, jday, IW3JDN, is2Dvar - INTEGER :: nt, i, j, k , idx, ierr - REAL, ALLOCATABLE :: data_xyz(:,:,:), vardata(:), vardata_n(:) - REAL, ALLOCATABLE :: data_xyz_var(:,:,:) - REAL, ALLOCATABLE :: data_xyz_pr(:,:,:) - REAL, ALLOCATABLE :: llpoints(:,:) - CHARACTER(len=char_len) :: var_name, var_description, units - CHARACTER(len=19 ) :: date_str, date_str2 - CHARACTER(len=10 ) :: jdate - CHARACTER(len=char_len) :: gribfile - REAL :: missing_value, r2d, pi - integer :: ioerr - integer :: ret ! returned from subroutine call - integer :: maxlevs ! max number of levels for array allocation - -! check and get the commandline arguments - IF (iargc() .NE. 0) THEN - WRITE(0,*) 'Usage: pop' - WRITE(0,*) 'Note: Make sure that namelist file pop.nl is in the current directory' - STOP - END IF - -! set up control variables -!JR Subroutine "control" reads in postnamelist, but it is opened and read in again here -!TODO: Only read it once - - call control () - nverlvs = nvl - delta_t=ArchvIntvl - t2=TotalTime - nsmooth_var=0 - t1=0 - call post_read_namelist (ret) - if (ret < 0) then - write(6,*) 'pop: bad return from post_read_namelist' - stop - end if - -!JR Determine number of variables input - nvars = 0 - do while (var_list(nvars+1) /= ' ' .and. nvars < max_vars) - nvars = nvars + 1 - end do - -!JR is=1 in default FIM => horiz. interp and no vert. interp - IF (is == 3 .AND. nvars > 3) THEN - WRITE(0,*) 'Only allow maximum 3 variables for vertical cross sections' - STOP - ENDIF - -! get date info from the date string - READ(UNIT=yyyymmddhhmm(1:4), FMT='(I4)') year - READ(UNIT=yyyymmddhhmm(5:6), FMT='(I2)') month - READ(UNIT=yyyymmddhhmm(7:8), FMT='(I2)') day - READ(UNIT=yyyymmddhhmm(9:10), FMT='(I2)') hour - READ(UNIT=yyyymmddhhmm(11:12), FMT='(I2)') minute - -! create a year 'month-date-hour-minute' date string - date_str = yyyymmddhhmm(1:4) // "-" // yyyymmddhhmm(5:6) // "-" // yyyymmddhhmm(7:8) // "-" // & - yyyymmddhhmm(9:10) // ":" // yyyymmddhhmm(11:12) // ":00" - date_str2 = date_str - -! create the jdate string - jday = IW3JDN(year,month,day) - IW3JDN(year,1, 1) + 1 - WRITE(UNIT=jdate(1:2), FMT='(I2.2)') MOD (year, 100) - WRITE(UNIT=jdate(3:5), FMT='(I3.3)') jday - WRITE(UNIT=jdate(6:7), FMT='(I2.2)') hour - jdate = jdate(1:7) // '000' - -! compute the number of forecast time and number of icosahedral grid - nfct = (t2 - t1) / delta_t - -!JR FIM default is "grib" -!JR grid_id=228 => mx=144, my=73 - IF (output_fmt == "grib") THEN - CALL gridid2mxmy(grid_id, mx, my) - ENDIF - - IF (is == 0) THEN - mx = 1024 - my = nip / 1024 + 1 - ENDIF - - IF (is == 0) THEN - ALLOCATE(vardata(nip * (nverlvs+1))) - ALLOCATE(vardata_n(mx * my * (nverlvs+1))) - ELSE IF (is == 1) THEN -!JR The following is a HACK to get pop to work when number of pressure levels exceeds number of model levels - maxlevs = max (nverlvs+1,nvlp) - ALLOCATE(vardata(nip * maxlevs)) - ALLOCATE(data_xyz(mx, my, maxlevs)) - ELSE IF (is == 2) THEN - ALLOCATE(vardata(nip * (nverlvs+1))) - ALLOCATE(data_xyz_var(mx,my,nverlvs+1)) - ALLOCATE(data_xyz_pr(mx,my,nverlvs+1)) - ALLOCATE(data_xyz(mx, my, nvlp)) - ELSE IF (is == 3) THEN - ALLOCATE(vardata(nip * (nverlvs+1))) - ALLOCATE(data_xyz_var(mx,my,nverlvs+1)) - ALLOCATE(data_xyz_pr(mx,my,nverlvs+1)) - ALLOCATE(data_xyz(mx, my, vres)) - ENDIF - - missing_value = -99.0 - -! open and init the netCDF or GRIB file - IF(is == 0) THEN - CALL set_model_nlevels(nverlvs) - CALL initgrib(gribtable) - ELSE IF(is == 1) THEN - IF (output_fmt == "nc") THEN - CALL init_cdf_vars(output, file_handle, mx, my, nverlvs+1, nfct + 1, 1, nvars, var_list, date_str, nvlp) - ELSEIF (output_fmt == "grib") THEN - CALL set_model_nlevels(nverlvs) - CALL initgrib(gribtable) - IF (.not. multiple_output_files) CALL opengrib(output) - END IF - ELSE IF (is == 2) THEN - IF (output_fmt == "nc") THEN - CALL init_cdf_vars_v(output, file_handle, mx, my, nvlp, nfct + 1, 1, nverlvs, nvars, var_list, date_str, nvlp) - ELSEIF (output_fmt == "grib") THEN - CALL set_model_nlevels(nverlvs) - CALL initgrib(gribtable) - IF (.not. multiple_output_files) CALL opengrib(output) - END IF - ELSE IF (is == 3) THEN - IF (output_fmt == "nc") THEN - CALL init_cdf_vars_v(output, file_handle, mx, my, vres, nfct + 1, 1, nverlvs, nvars, var_list, date_str, nvlp) - ELSEIF (output_fmt == "grib") THEN - CALL set_model_nlevels(nverlvs) - CALL initgrib(gribtable) - IF (.not. multiple_output_files) CALL opengrib(output) - END IF - ENDIF - - datadir = datadir(1:LEN_TRIM(datadir)) // '/' - -! if interpolation scheme is not 0, init the horizontal interpolation. - IF (is /= 0) THEN - IF (FixedGridOrder) THEN - FMT2 = '(a,"latlonIJ.dat")' - write(init_file,FMT2) datadir(1:LEN_TRIM(datadir)) - ALLOCATE(llpoints(nip, 2)) - OPEN (10, file=init_file, action='read', form='unformatted', iostat=ioerr) - if (ioerr == 0) then - write(6,*)'pop: successfully opened init_file=', trim(init_file) - else - write(6,*)'pop: failed to open init_file=', trim(init_file) - end if - call TestGlvlHeader(10,init_file,'pop',glvl) - READ (10, iostat=ioerr) llpoints(:, 1), llpoints(:, 2) - if (ioerr /= 0) then - write(6,*)'pop: bad attempt to read ', trim (init_file), 'nelem=', & - ubound(llpoints,1), ' iostat=', ioerr - end if - CLOSE(10) - ELSE - init_file = './icos_grid_info_level.dat' - ALLOCATE(llpoints(nip, 2)) - OPEN (10, file=init_file, action='read', form='unformatted', iostat=ioerr) - if (ioerr == 0) then - write(6,*)'pop: successfully opened init_file=', trim(init_file) - else - write(6,*)'pop: failed to open init_file=', trim(init_file) - end if - call TestGlvlHeader (10,init_file,'pop',glvl ) - call TestCurveHeader(10,init_file,'pop',curve) - READ (10, iostat=ioerr) llpoints(:, 1), llpoints(:, 2) - if (ioerr == 0) then -! write(6,*)'pop: successfully read llpoints nelem=',ubound(llpoints,1) - else - write(6,*)'pop: bad attempt to read ', trim (init_file), 'nelem=', & - ubound(llpoints,1), ' iostat=', ioerr - end if - CLOSE(10) - ENDIF -! write(6,*)'JR pop: calling bilinear_init_i2r llpoints=', llpoints(:,1) - CALL bilinear_init_i2r(mx, my, llpoints, nip) - - DEALLOCATE(llpoints) - ENDIF - - IF (latlonfld) THEN - pi = 4.0*ATAN(1.0) - r2d = 180.0 / pi - ALLOCATE(llpoints(nip, 2)) - FMT2 = '(a,"latlonIJ.dat")' - write(init_file,FMT2) datadir(1:LEN_TRIM(datadir)) - OPEN(10,file=init_file,status='old',form='unformatted') - call TestGlvlHeader(10,'latlonIJ.dat','pop',glvl) - READ(10) llpoints(:, 1), llpoints(:, 2) - CLOSE(10) - llpoints(1:nip, 1) = llpoints(1:nip, 1) * r2d - llpoints(1:nip, 2) = (llpoints(1:nip, 2) - pi) * r2d - END IF - - IF (is == 0) THEN ! no interpolation, native grid can only be saved in GRIB file format at this point. - DO nt = t1, t2, delta_t - IF (output_fmt.eq."grib" .and. multiple_output_files) THEN - WRITE(ahr, FMT) nt - gribfile = outputdir(1:LEN_TRIM(outputdir)) // '/' // jdate // ahr - CALL opengrib(gribfile) - ELSE - PRINT*, 'Native grid can only be saved in GRIB file format.' - STOP - ENDIF - DO var_num = 1, nvars ! for each variable - var_name = var_list(var_num)(1:LEN_TRIM(var_list(var_num))) - CALL read_1var(nt, delta_t, datadir, vardata, var_name, nip, nverlvs + 1,ArchvTimeUnit, nvlp) - CALL var_info(var_list(var_num), var_description, units, nlevels, nvlp) - DO i = 1, nlevels - DO j = 1, nip - vardata_n(mx*my*(i-1)+j) = vardata(i + (j - 1) * (nverlvs + 1)) - END DO - Do j = nip + 1, mx * my - vardata_n(mx*my*(i-1)+j) = vardata(i + (nip - 1) * (nverlvs + 1)) - END DO - ENDDO - IF (nlevels > 2) THEN - var_name = var_list(var_num)(1:LEN_TRIM(var_list(var_num))) // '_B' - ELSE - var_name = var_list(var_num)(1:LEN_TRIM(var_list(var_num))) - ENDIF - CALL writegrib(var_name, nip, 1, nlevels, glvl, curve, vardata_n, jdate, nt, & - tba(nt,t1,delta_t,var_name), nvlp, pres_hpa) - ENDDO - IF (latlonfld) THEN - vardata_n(1:nip) = llpoints(1:nip,1) - vardata_n(nip+1:mx * my) = 0.0 - var_name = "LAT" - CALL writegrib(var_name, nip, 1, 1, glvl, curve, vardata_n, jdate, t1, 0, nvlp, pres_hpa) - vardata_n(1:nip) = llpoints(1:nip,2) - vardata_n(nip+1:mx * my) = 0.0 - var_name = "LON" - CALL writegrib(var_name, nip, 1, 1, glvl, curve, vardata_n, jdate, t1, 0, nvlp, pres_hpa) - ENDIF - IF (output_fmt.eq."grib" .and. multiple_output_files) CALL closegrib() - PRINT "('*'$)" ! progress '*' - ENDDO - ELSE IF (is == 1) THEN ! Horizontal interpolation - DO nt = t1, t2, delta_t - IF (output_fmt.eq."grib" .and. multiple_output_files) THEN - WRITE(ahr, FMT) nt - gribfile = outputdir(1:LEN_TRIM(outputdir)) // '/' // jdate // ahr - open (unit=1, file=gribfile, status='old', action='read', iostat=ioerr) - close (1) - if (ioerr == 0) then - write(6,*)'pop: GRIB file ', trim(gribfile), ' already exists: stopping...' - stop 999 - end if - CALL opengrib(gribfile) - ENDIF - DO var_num = 1, nvars ! for each variable - IF (input /= "") THEN - CALL read_1var_direct(input, nip, nverlvs, vardata,ArchvTimeUnit, nvlp) - nlevels = nverlvs - ELSE - var_name = var_list(var_num)(1:LEN_TRIM(var_list(var_num))) - CALL read_1var(nt, delta_t, datadir, vardata, var_name, nip, nverlvs + 1,ArchvTimeUnit, nvlp) - CALL var_info(var_list(var_num), var_description, units, nlevels, nvlp) - ENDIF -! write(6,*)'JR pop: calling bilinear_interp_i2r for field ', trim(var_name) - DO k=1,nlevels - CALL bilinear_interp_i2r(k, nlevels, vardata, data_xyz) - END DO !level loop -! write(6,*)'JR pop after bilinear_interp_i2r: nlevels,vardata,data_xyz=', & -! nlevels, vardata(1), data_xyz(1,1,1) - DO i = 1, nsmooth_var(var_num) - CALL smooth(data_xyz,mx,my,nlevels,0.2) - END DO - - - IF (nlevels < nverlvs + 1) THEN - data_xyz(:,:,nlevels + 1:) = 0.0 - END IF - IF (output_fmt == "nc") THEN - CALL write_data (file_handle, date_str, var_list(var_num), & - var_description, data_xyz, units, nt / delta_t) - ELSEIF (output_fmt == "grib") THEN - IF (nlevels > 2) THEN - var_name = var_list(var_num)(1:LEN_TRIM(var_list(var_num))) -!JR The "_B" means the data are on native levels rather than pressure levels - IF(var_name /= "hgtP" .AND. var_name /= "tmpP" .AND. & - var_name /= "up3P" .AND. var_name /= "vp3P" .AND. & - var_name /= "oc1P" .AND. var_name /= "oc2P" .AND. & - var_name /= "bc1P" .AND. var_name /= "bc2P" .AND. & - var_name /= "so2P" .AND. var_name /= "slfP" .AND. & - var_name /= "d1sP" .AND. var_name /= "d2sP" .AND. & - var_name /= "d3sP" .AND. var_name /= "d4sP" .AND. & - var_name /= "d5sP" .AND. var_name /= "s1sP" .AND. & - var_name /= "s2sP" .AND. var_name /= "s3sP" .AND. & - var_name /= "s4sP" .AND. var_name /= "dmsP" .AND. & - var_name /= "msaP" .AND. var_name /= "p25P" .AND. & - var_name /= "rh3P" .AND. var_name /= "p10P") THEN - var_name = var_list(var_num)(1:LEN_TRIM(var_list(var_num))) // '_B' - ENDIF - ELSE - var_name = var_list(var_num)(1:LEN_TRIM(var_list(var_num))) - ENDIF - CALL writegrib(var_name, mx, my, nlevels, 0, 0, data_xyz, jdate, nt, & - tba(nt,t1,delta_t,var_name),nvlp, pres_hpa) - ENDIF - END DO - CALL mmdddateadj(date_str, delta_t) - IF (output_fmt.eq."grib" .and. multiple_output_files) CALL closegrib() - PRINT "('*'$)" ! progress '*' - END DO - ELSE ! vertical interpolation - var_list(nvars+1) = "pr3D" - DO nt = t1, t2, delta_t - IF (output_fmt.eq."grib" .and. multiple_output_files) THEN - WRITE(ahr, FMT) nt - gribfile = outputdir(1:LEN_TRIM(outputdir)) // '/' // jdate // ahr - CALL opengrib(gribfile) - ENDIF - - ! interpolate pressure to latlon grid - var_name = var_list(var_num)(1:LEN_TRIM(var_list(var_num))) - CALL read_1var(nt, delta_t, datadir, vardata, var_name, nip, nverlvs + 1,ArchvTimeUnit,nvlp) - CALL var_info(var_list(nvars+1), var_description, units, nlevels,nvlp) - DO k = 1, nlevels - CALL bilinear_interp_i2r (k, nlevels, vardata, data_xyz_pr) - END DO - - ! interpolate the specified variables to latlon grid - DO var_num = 1, nvars ! for each variable - var_name = var_list(var_num)(1:LEN_TRIM(var_list(var_num))) - CALL read_1var(nt, delta_t, datadir, vardata, var_name, nip, nverlvs + 1,ArchvTimeUnit, nvlp) - CALL var_info(var_list(var_num), var_description, units, nlevels, nvlp) - DO k = 1, nlevels - CALL bilinear_interp_i2r (k, nlevels, vardata, data_xyz_var) - END DO - ! interpolate to vertical plane - data_xyz = 0.0 - IF (is == 2) THEN - IF (is2Dvar(var_list(var_num)) == 1) THEN - var_name = var_list(var_num)(1:LEN_TRIM(var_list(var_num))) - DO i = 1, nsmooth_var(var_num) - CALL smooth(data_xyz_var,mx,my,1,0.2) - END DO - CALL writegrib(var_name, mx, my, 1, 0, 0, data_xyz_var, jdate, nt, & - tba(nt,t1,delta_t,var_name),nvlp,pres_hpa) - CYCLE - ENDIF - CALL vlint2coor(mx, my, nlevels, nverlvs + 1, data_xyz_pr, data_xyz_var, data_xyz, pres_hpa, nvlp) - ELSE IF (nlevels == nverlvs) THEN - IF (mode == "step") THEN - CALL v_interp(mx, my, nlevels, data_xyz_pr, data_xyz_var, vres, data_xyz, missing_value, 1) - ELSE IF (mode == "linear") THEN - CALL v_interp(mx, my, nlevels, data_xyz_pr, data_xyz_var, vres, data_xyz, missing_value, 0) - ENDIF - ELSEIF (nlevels == nverlvs + 1) THEN ! variables defined on interface - CALL v_interp_lvlvar(mx, my, nlevels, data_xyz_pr, data_xyz_var, vres, data_xyz, missing_value, 0) - ENDIF - DO i = 1, nsmooth_var(var_num) - IF (is == 2) THEN - CALL smooth(data_xyz,mx,my,nvlp,0.2) - ELSE if (is == 3) THEN - CALL smooth(data_xyz,mx,my,vres,0.2) - END IF - END DO - -! write data to the netCDF file, the variable interpolated - IF (output_fmt == "nc") THEN - CALL write_data (file_handle, date_str, var_list(var_num), & - var_description, data_xyz, units, nt / delta_t) - ELSEIF (output_fmt == "grib") THEN - var_name = var_list(var_num)(1:LEN_TRIM(var_list(var_num))) // '_P' - IF (is == 2) THEN - CALL writegrib(var_name, mx, my, nvlp, 0, 0, data_xyz, jdate, nt, & - tba(nt,t1,delta_t,var_name),nvlp,pres_hpa) - ELSE - CALL writegrib(var_name, mx, my, vres, 0, 0, data_xyz, jdate, nt, & - tba(nt,t1,delta_t,var_name),nvlp,pres_hpa) - ENDIF - ENDIF - END DO - ! write pressure field to the nc file - IF (is == 3) THEN - DO k=1,vres - IF (k <= nverlvs + 1) THEN - data_xyz(1:mx, 1:my, k) = data_xyz_pr(1:mx, 1:my, k) - ELSE - data_xyz(1:mx, 1:my, k) = 0 - ENDIF - END DO !level loop - CALL var_info(var_list(nvars+1), var_description, units, nlevels, nvlp) - IF (output_fmt == "nc") THEN - CALL write_data (file_handle, date_str, var_list(nvars+1), & - var_description, data_xyz, units, nt / delta_t) - ELSEIF (output_fmt == "grib") THEN - var_name = var_list(nvars+1)(1:LEN_TRIM(var_list(nvars+1))) // '_B' - CALL writegrib(var_name, mx, my, nlevels, 0, 0, data_xyz, jdate, nt, & - tba(nt,t1,delta_t,var_name), nvlp, pres_hpa) - ENDIF - ENDIF - CALL mmdddateadj(date_str, delta_t) - IF (output_fmt.eq."grib" .and. multiple_output_files) CALL closegrib() - PRINT "('*'$)" ! progress '*' -! time iteration - END DO - ENDIF - - IF (output_fmt == "nc") THEN - CALL close_cdf(file_handle) - IF (is == 1) THEN - CALL write_cdf_cdfapi(output, mx, my, nverlvs+1, nfct + 1, date_str2, delta_t, 0, nvlp, pres_hpa) - ELSEIF (is == 2) THEN - CALL write_cdf_cdfapi(output, mx, my, nvlp, nfct + 1, date_str2, delta_t, 1, nvlp, pres_hpa) - ELSEIF (is == 3) THEN - CALL write_cdf_cdfapi(output, mx, my, vres, nfct + 1, date_str2, delta_t, 2, nvlp, pres_hpa) - ENDIF - ELSEIF (output_fmt == "grib") THEN - CALL endgrib() - ENDIF - - PRINT*, ' ' - - IF (is == 0) THEN - DEALLOCATE(vardata, vardata_n) - ELSE IF (is == 1) THEN - DEALLOCATE(vardata, data_xyz) - ELSE - DEALLOCATE(data_xyz_var, data_xyz_pr, vardata, data_xyz) - ENDIF - - STOP - - contains - - integer function tba (nt, t1, delta_t, varname) - implicit none - - integer, intent(in) :: nt, t1, delta_t - character(len=*), intent(in) :: varname -!JR Changed logic to give correct accumulation behavior for precip. variables. -!JR The equivalent behavior for gribout=.true. is handled in horizontal/output.F90 -!JR tba=nt-delta_t -!JR if (tba.lt.0.or.varname.eq.'rn2D'.or.varname.eq.'rc2D'.or.varname.eq.'rg2D') tba=0 - if (nt > delta_t .and. (varname == 'rn2D' .or. varname == 'rc2D' .or. varname == 'rg2D')) then - tba = nt - delta_t - else - tba = 0 - end if - return - end function tba - end program pop - -SUBROUTINE read_1var(nt, delta_t, datadir, vardata, var_name, nip, nverlvs,ArchvTimeUnit, nvlp) - USE fimnc, ONLY: var_info,char_len - IMPLICIT NONE - - INTEGER nt, delta_t, nip, nverlvs, nvlp - CHARACTER *(*) :: datadir - CHARACTER *(*) :: var_name - CHARACTER(80) :: header(10) -!JR Don't know the actual dimension of vardata - REAL vardata(*) - character(2),intent(in)::ArchvTimeUnit - - CHARACTER (len=char_len) :: var_description, units - INTEGER :: nlevels - - INTEGER time, lunout, is2Dvar, ioerr - CHARACTER (len=char_len) :: filename - -! when all 2d vars, sm3d, and st3d are in one file, comment the following statements -! if these variables are in seperate files. - IF (is2Dvar(var_name) == 1) THEN - CALL read_2Dvar(nt, datadir, var_name, nip, nverlvs, vardata,ArchvTimeUnit, nvlp) -!print*, 'var =', var_name, minval(vardata(1:nip)), maxval(vardata(1:nip)) - RETURN - ENDIF - - lunout = 29 - time = nt - WRITE(filename,"('fim_out_',a4,i6.6,a2)") var_name,time,ArchvTimeUnit - filename = datadir(1:LEN_TRIM(datadir)) // filename - CALL var_info(var_name, var_description, units, nlevels, nvlp) - OPEN (lunout, file=filename, form="unformatted", action='read', iostat=ioerr) - if (ioerr /= 0) then - write(6,*)'read_1var: Failed to open file ', trim(filename), '. Stopping' - stop - end if - - READ (lunout, iostat=ioerr) header - if (ioerr /= 0) then - write(6,*)'read_1var: Failed to read header from file ',trim(filename), '. Stopping' - stop - end if - - READ (lunout, iostat=ioerr) vardata(1:nip*nlevels) - if (ioerr /= 0) then - write(6,*)'read_1var: Failed to read vardata from file ',trim(filename), '. ioerr=', ioerr - write(6,*)'var_name=', var_name, 'nlevels=', nlevels - write(6,*)'Stopping.' - stop - end if - - CLOSE(lunout) - ! special treament for qv3d and qw3d - IF (var_name == "qv3D" .OR. var_name == "qw3D") THEN - vardata(1:nip*nlevels) = vardata(1:nip*nlevels) * 1000.0 - ENDIF - ! special treament for ph3d - IF (var_name == "ph3D") THEN -!JR Changed to multiply by reciprocal to match scalefactor passed in when gribout=true - vardata(1:nip*nlevels) = vardata(1:nip*nlevels) * (1./9.8) - ENDIF - ! special treament for oz3d - IF (var_name == "oz3D") THEN - vardata(1:nip*nlevels) = vardata(1:nip*nlevels) * 1000.0 - ENDIF -!print*, 'var ', var_name, minval(vardata(1:nip*nlevels)), maxval(vardata(1:nip*nlevels)) -END SUBROUTINE read_1var - -SUBROUTINE read_2Dvar(nt, datadir, var_name, nip, nverlvs, vardata,ArchvTimeUnit, nvlp) - USE fimnc, ONLY: var_info, char_len - IMPLICIT NONE - - CHARACTER *(*) :: datadir, var_name - INTEGER nt, nip, nverlvs - -!JR Don't know the actual dimension of vardata - REAL vardata(*) - - INTEGER i, j, lunout, nlevels, nvlp - CHARACTER(len=char_len) :: filename - - CHARACTER(len=80) :: header(10) - CHARACTER(len=char_len) :: varname, varname_uc - CHARACTER(len=char_len) :: var_description, units - character(2),intent(in)::ArchvTimeUnit - - lunout = 29 - varname_uc = var_name(1:LEN_TRIM(var_name)) - CALL tolowercase(var_name) - WRITE(filename,"('fim_out_2D__',i6.6,a2)") nt,ArchvTimeUnit - filename = datadir(1:LEN_TRIM(datadir)) // filename - OPEN(lunout,file=filename,form="unformatted") - - READ(lunout) header - READ(header,FMT="(4X A4)") varname ! for now 10:00 am - CALL tolowercase(varname) - - DO WHILE (var_name /= varname) - IF (varname == "sm3d" .OR. varname == "st3d") THEN - READ(lunout) vardata(1:4*nip) - ELSE - READ(lunout) vardata(1:nip) - ENDIF - READ(lunout) header - READ(header,FMT="(4X A4)") varname - CALL tolowercase(varname) - END DO - - CALL var_info(varname_uc, var_description, units, nlevels, nvlp) - - ! special treatment for rainfall amount - IF (var_name == "rn2d" .OR. var_name == "rc2d" .OR. & - var_name == "rg2d" ) THEN - nlevels = 1 - END IF - - READ (lunout) vardata(1:nip*nlevels) - CLOSE(lunout) - -END SUBROUTINE read_2Dvar - -SUBROUTINE read_1var_direct(filename, nip, nverlvs, vardata) - USE fimnc - IMPLICIT NONE - - CHARACTER *(*) :: filename - INTEGER nip, nverlvs - REAL vardata(nip * nverlvs) - - INTEGER :: lunout=30 - - OPEN (lunout,file=filename,form="unformatted") - READ(lunout) vardata(1:nip*nverlvs) - CLOSE(lunout) -END SUBROUTINE read_1var_direct - -INTEGER FUNCTION is2Dvar(var_name) - IMPLICIT NONE - - CHARACTER *(*) :: var_name - - IF(var_name(3:4) == "2D" .OR. var_name(3:4) == "2d" .or. var_name(1:4) == "iash") THEN - is2Dvar = 1 - ELSE - is2Dvar = 0 - ENDIF - - RETURN -END FUNCTION is2Dvar - -SUBROUTINE gridid2mxmy(gridid, mx, my) - IMPLICIT NONE - INTEGER gridid, mx, my - IF (gridid == 228) THEN - mx = 144 - my = 73 - ELSEIF (gridid == 45) THEN - mx = 288 - my = 145 - ELSEIF (gridid == 3) THEN - mx = 360 - my = 181 - ELSEIF (gridid == 4) THEN - mx = 720 - my = 361 - ENDIF -END SUBROUTINE gridid2mxmy - -SUBROUTINE mmdddateadj(mmdddate, delta_t) - IMPLICIT NONE - CHARACTER*19 mmdddate - INTEGER delta_t - - INTEGER year, month, day, hour, minute,second,ly - INTEGER month_ny(12), month_ly(12) - CHARACTER dash, col - DATA month_ny/31,28,31,30,31,30,31,31,30,31,30,31/ - DATA month_ly/31,29,31,30,31,30,31,31,30,31,30,31/ - dash = '-' - col = ':' - - READ(mmdddate,'(i4,1x,i2,1x,i2,1x,i2,1x,i2,1x,i2)') year,month,day,hour,minute,second -!print*, year,month,day,hour,minute,second - IF (mod(year, 4) == 0 .AND. mod(year, 100) /= 0) THEN - ly = 1 - ELSE - ly = 0 - ENDIF - IF (hour + delta_t .GE. 24) THEN - day = day + 1 - IF ((ly == 0 .AND. day > month_ny(month)) .OR. (ly == 1 .AND. day > month_ly(month))) THEN - day = 1 - month = month + 1 - ENDIF - IF (month > 12) THEN - month = 1 - year = year + 1 - ENDIF - ENDIF - hour = MOD(hour + delta_t, 24) -!print*, year,month,day,hour,minute,second - WRITE(mmdddate,'(i4.4,A1,i2.2,A1,i2.2,A1,i2.2,A1,i2.2,A1,i2.2)') year,dash,month,dash,day,dash,hour,col,minute,col,second - -END SUBROUTINE mmdddateadj - -SUBROUTINE jdateadj(jdate, delta_t) - IMPLICIT NONE - CHARACTER*7 jdate - INTEGER delta_t - - INTEGER yr, jday, hr, ly - - READ(jdate,'(i2,i3,i2)') yr,jday,hr - IF (hr + delta_t .GE. 24) THEN - jday = jday + 1 - IF (mod(yr, 4) == 0 .AND. mod(yr, 100) /= 0) THEN - ly = 1 - ELSE - ly = 0 - ENDIF - IF (jday > 365 + ly) THEN - jday = 1 - yr = yr + 1 - ENDIF - ENDIF - hr = MOD(hr + delta_t, 24) - WRITE(jdate,'(i2.2,i3.3,i2.2)') yr,jday,hr - -END SUBROUTINE jdateadj - diff --git a/src/fim/FIMsrc/post/pop/post.F90 b/src/fim/FIMsrc/post/pop/post.F90 deleted file mode 100644 index 683bd3b..0000000 --- a/src/fim/FIMsrc/post/pop/post.F90 +++ /dev/null @@ -1,457 +0,0 @@ -! The contents of this file were taken from pop.F90, and broken into 4 parts due to needing -! to be called at different times from FIM: -! 1) things that are done once during the run (post_init) -! 2) things that are done every output time slice (post_init_file) -! 3) things that are done for each output field (post_write_field) -! 4) closing the output GRIB file (post_finalize_file) -! -! Jim Rosinski, Feb, 2011 -! Split the subroutine post_init() into two subroutines: post_init_readnl() and post_init_slint(), -! in order to accommodate the initialization logic in dyn_init() subroutine. -! N. Wang, Sep, 2011 - -module post - use module_control, only: curve, fixedgridorder, nvlp, glvl, nip, nvl, nvlp1, & - yyyymmddhhmm, ArchvIntvl, totaltime - use fimnc, only: var_info, set_model_nlevels - use slint, only: bilinear_init_i2r, bilinear_interp_i2r, tgt_grid - use postdata, only: post_read_namelist, datadir, outputdir, input, output, output_fmt, max_vars, var_list, & - multiple_output_files, gribtable, grid_id, mx, my, latlonfld, is, vres, & - mode, nsmooth_var, & - max_pathlen, max_varnamelen, gribout, fimout - use units, only: getunit, returnunit - - implicit none - - private - save - -!JR For some reason, the FIM fields created all have a length of 4 -!JR The choice of 16 for max length is arbitrary - integer :: file_handle = -1 ! File handle for netcdf output: init to bad value - integer :: nvars ! Number of variables to output - integer :: time = -999 ! needed by grib routines - integer :: timebeg = -999 ! needed by grib routines - integer :: maxlevs ! max number of levels to allocate for data_xyz - - character(len=10) :: jdate ! julian date (?) used to construct name of grib file - - logical :: post_init_readnl_called = .false. ! flag indicates part of the post init has been called - logical :: post_init_slint_called = .false. ! flag indicates part of the post init has been called - - real, allocatable :: data_xyz(:,:,:) ! data array sent to grib file (allocated in post_init) - real :: r2d ! convert radians to degrees - real :: pi ! 3.14159... - - logical :: gribfile_is_open = .false. ! indicates a GRIB file is currently open (thus writable) - - ! Public variables - - public :: data_xyz - public :: fimout - public :: gribfile_is_open - public :: gribout - public :: jdate - public :: post_init_readnl_called - public :: post_init_slint_called - public :: time - public :: timebeg - public :: maxlevs - - ! Public routines - - public :: post_init_readnl ! Called once per run: reads namelist - public :: post_init_slint ! Called once per run: initialize the interpolation package - public :: varindex - -contains - -! -! post_init must be called once during the model run. It reads the namelist, determines -! some resolution-dependent variables and allocates requisite one-time memory -! - subroutine post_init_readnl (retcode) - integer, intent(out) :: retcode ! return code to caller - - integer :: ret ! return code from called routines - retcode = 0 - -! Read the postnamelist, then check validity of input - call post_read_namelist (ret) - - if (ret < 0) then - write(6,*) 'post_init_readnl: bad return from post_read_namelist' - call flush(6) - retcode = -1 - return - end if - -!JR Only is=1 works for now - if (is /= 1) then - write(6,*) 'post_init_readnl: only is=1 is currently supported' - call flush(6) - retcode = -1 - return - end if - -!JR Ensure "input" and "output" are empty--handle later if needed - if (input /= '') then - write(6,*) 'post_init_readnl: input must be empty' - call flush(6) - retcode = -1 - return - end if - - if (output /= '') then - write(6,*) 'post_init_readnl: output must be empty' - call flush(6) - retcode = -1 - return - end if - -!JR Determine number of variables input - nvars = 0 - do while (var_list(nvars+1) /= ' ' .and. nvars < max_vars) - nvars = nvars + 1 - end do - -!JR FIM default is "grib", grid_id=228 => mx=144, my=73 - if (output_fmt == 'grib') then - call gridid2mxmy (grid_id, mx, my) - else - write(0,*) 'post_init_readnl: Only output_fmt="grib" is currently supported' - call flush(6) - retcode = -1 - return - end if - post_init_readnl_called = .true. - - end subroutine post_init_readnl - - - subroutine post_init_slint (retcode) - integer, intent(out) :: retcode ! return code to caller - - integer :: ioerr ! return value from IO routines - integer :: ret ! return code from called routines - integer :: unitno ! unit number - character(len=max_pathlen) :: init_file ! full path to file containing icos grid info - real, allocatable :: llpoints(:,:) - - retcode = 0 - if (post_init_slint_called) then - write(6,*) 'post_init_slint: must only be invoked once during FIM execution' - call flush(6) - retcode = -1 - return - endif - - maxlevs = max (nvlp1,nvlp) - allocate (data_xyz(mx, my, maxlevs)) - datadir = datadir(1:len_trim(datadir)) // '/' - - init_file = './icos_grid_info_level.dat' - allocate (llpoints(nip, 2)) - - unitno = getunit () - if (unitno < 0) then - print*,'post_init: getunit failed for ', trim(init_file), ' Stopping' - stop - end if - - open (unitno, file=init_file, status='old', action='read', form='unformatted', iostat=ioerr) - if (ioerr /= 0) then - write(6,*)'post_init_slint: bad attempt to open ', trim (init_file) - call flush(6) - retcode = -1 - return - end if - - call testglvlheader (unitno, init_file, 'post_init_slint', glvl) -!JR Again, skip fixedgridorder test because we're always reading icos_grid_info_level.dat -! if (.not. fixedgridorder) then - call testcurveheader (unitno, init_file, 'post_init_slint', curve) -! end if - read (unitno, iostat=ioerr) llpoints(:, 1), llpoints(:, 2) - if (ioerr == 0) then -! write(6,*)'post_init_slint: successfully read llpoints from ', trim (init_file) - else - write(6,*)'post_init_slint: bad attempt to read ', trim (init_file), ' nelem=', & - ubound(llpoints,1), ' iostat=', ioerr - call flush(6) - retcode = -1 - return - end if - close (unitno) - call returnunit (unitno) - call bilinear_init_i2r (mx, my, llpoints, nip) - - deallocate (llpoints) - -!JR fix later for netcdf - if (output_fmt == 'nc') then -!JR call init_cdf_vars (output, file_handle, mx, my, nvlp1, & -!JR nfct + 1, 1, nvars, var_list, date_str) - else if (output_fmt == 'grib') then -!JR The call to set_model_nlevels sets nvl in fimnc.F90. It is needed by the call to var_info - call set_model_nlevels (nvl) -! Read the gribtable - call initgrib (gribtable) - end if - - post_init_slint_called = .true. - return - end subroutine post_init_slint - - subroutine gridid2mxmy (gridid, mx, my) - integer, intent(in) :: gridid - integer, intent(out) :: mx, my - - if (gridid == 228) then - mx = 144 - my = 73 - else if (gridid == 45) then - mx = 288 - my = 145 - else if (gridid == 3) then - mx = 360 - my = 181 - else if (gridid == 4) then - mx = 720 - my = 361 - end if - return - end subroutine gridid2mxmy - -! varindex returns the index of the field in var_list, or -1 if not found -! TODO: devise a more elegant approach -! TODO: ensure this function doesn't cost a lot - - integer function varindex (varname) - character(len=*), intent(in) :: varname - integer :: i - - varindex = -1 ! return value if not found - do i=1,max_vars - if (varname == var_list(i)) then - varindex = i - end if - end do - return - end function varindex -end module post - -subroutine post_finalize_file (retcode) - -! post_finalize_file closes the open GRIB file - - use post, only: gribfile_is_open - use postdata, only: output_fmt - - implicit none - - integer, intent(out) :: retcode - - retcode = 0 - - if (.not. gribfile_is_open) then - write(6,*)'post_finalize_file: gribfile already closed' - call flush(6) - retcode = -1 - return - end if -!JR Looks like closegrib knows some "currently open unit number" under the covers - if (output_fmt == 'grib') then - call closegrib () - gribfile_is_open = .false. - end if - -end subroutine post_finalize_file - -subroutine post_init_file (newtime, retcode) - -! post_init_file opens the output GRIB or (for future) netCDF file - - use module_control, only: yyyymmddhhmm - use post, only: gribfile_is_open, jdate, post_init_slint_called, time, timebeg - use postdata, only: max_pathlen, outputdir, output_fmt - - implicit none - - integer, intent(in) :: newtime - integer, intent(out) :: retcode ! return code to caller - - character(len=19) :: date_str ! unknown: used only for netcdf files - character(len=6) :: ahr - character(len=max_pathlen) :: gribfile ! full path of grib file to open - integer :: nfct = -1 ! number of forecast times (netcdf only) - integer :: year, month, day, hour, minute, jday - integer, external :: iw3jdn - - retcode = 0 - write(6,*) 'post_init_file: newtime=',newtime -! commented on 10/03/2011 -! if (.not. post_init_slint_called) then -! write(6,*) 'post_init_file: post_init_slint has not yet been called' -! call flush(6) -! retcode = -1 -! return -! end if - - if (gribfile_is_open) then - write(6,*) 'post_init_file: gribfile is already open--cannot open a new one' - call flush(6) - retcode = -1 - return - end if - - time = newtime - timebeg = max (time-1, 0) - write(6,*)'post_init_file: initializing GRIB file for time=', time - -! open and init the netCDF or GRIB file - - if (output_fmt == 'grib') then -! get date info from the date string - read (unit=yyyymmddhhmm(1:4), fmt='(i4)') year - read (unit=yyyymmddhhmm(5:6), fmt='(i2)') month - read (unit=yyyymmddhhmm(7:8), fmt='(i2)') day - read (unit=yyyymmddhhmm(9:10), fmt='(i2)') hour - read (unit=yyyymmddhhmm(11:12), fmt='(i2)') minute - -! create a year 'month-date-hour-minute' date string - date_str = yyyymmddhhmm(1:4) // '-' // yyyymmddhhmm(5:6) // '-' // yyyymmddhhmm(7:8) // & - '-' // yyyymmddhhmm(9:10) // ':' // yyyymmddhhmm(11:12) // ':00' - -! create the jdate string - jday = iw3jdn (year, month, day) - iw3jdn (year, 1, 1) + 1 - write (unit=jdate(1:2), fmt='(i2.2)') mod (year, 100) - write (unit=jdate(3:5), fmt='(i3.3)') jday - write (unit=jdate(6:7), fmt='(i2.2)') hour - -! changed to write i6.6 instead of i3.3 so we can output time resolutions > 3 digits (ex., minutes) as part of the filename - jdate = jdate(1:7) // '000' - WRITE(gribfile,'(a,"/",a7,i6.6)') outputdir(1:len_trim(outputdir)), jdate, time - write(6,*) 'post_init_file: gribfile: ', trim(gribfile) - call opengrib (gribfile) - gribfile_is_open = .true. - end if - -end subroutine post_init_file - - -subroutine post_write_field (vardata, varname, scalefactor, accum_start, retcode) - -! post_write_field writes a single field to the already-open GRIB file - - use fimnc, only: var_info - use module_control, only: nip, nvlp1, nvlp, pres_hpa - use post, only: data_xyz, gribfile_is_open, jdate, time, timebeg, varindex, maxlevs - use postdata, only: max_varnamelen, mx, my, nsmooth_var, output_fmt, var_list, outputdir - use slint, only: bilinear_interp_i2r - - implicit none - - real, intent(in) :: vardata(*) ! Data on FIM grid to be written. -! Can be as big as nip*nvlp1. Note collapsing of dims to 1 - character(len=*), intent(in) :: varname ! FIM variable name - real, intent(in) :: scalefactor ! scaling factor for GRIB data - integer, intent(in) :: accum_start ! beginning time for GRIB data (-1 means use default) - integer, intent(out) :: retcode ! return code to send caller - - integer, parameter :: unknown = -999 ! placeholder in netcdf output - integer :: nlevels ! number of levels in field - integer :: v ! index of varname in var_list - integer :: i, k ! loop indices - character(len=max_varnamelen+2) :: var_name ! varname maybe with '_B' appended - character(len=max_varnamelen) :: units ! needed only for netcdf output - character(len=max_varnamelen) :: var_desc ! variable description - real, allocatable :: vardata_scaled(:) - - character(len=128) :: intbinfile - character(len=6) :: ahr - character(len=8) :: FMT='(I3.3)' - - retcode = 0 - if (.not. gribfile_is_open) then - write(6,*)'post_write_field: trying to write field ', trim(varname), ' but gribfile not open' - call flush(6) - retcode = -1 - return - end if - - v = varindex (varname) - if (v < 0) then - write(6,*)'post_write_field: no grib equivalent found for ', trim(varname), ' so skipping' - call flush(6) - return - end if - - call var_info (varname, var_desc, units, nlevels, nvlp) - -! Scale data for GRIB output if required - if (scalefactor == 1.) then - do k=1,nlevels - call bilinear_interp_i2r (k, nlevels, vardata, data_xyz) - end do - else -!TODO modify bilinear_interp_i2r_post to do 1 level at a time, avoiding the necessity of -! allocating a full 3-d temporary array here - allocate (vardata_scaled(1:nip*nlevels)) - vardata_scaled(1:nip*nlevels) = vardata(1:nip*nlevels) * scalefactor - do k=1,nlevels - call bilinear_interp_i2r (k, nlevels, vardata_scaled, data_xyz) - end do - deallocate (vardata_scaled) - end if - - do i=1,nsmooth_var(v) - call smooth (data_xyz, mx, my, nlevels, 0.2) - end do -!JR Zero out output array above top level needed - if (nlevels < maxlevs) then - do k=nlevels+1,maxlevs - data_xyz(:,:,k) = 0.0 - end do - end if - - if (output_fmt == 'nc') then -!JR call write_data (file_handle, date_str, var_list(v), & -!JR var_desc, data_xyz, units, unknown) - else if (output_fmt == 'grib') then -!JR Why the test on nlevels > 2??? - if (nlevels > 2) then - var_name = var_list(v)(1:len_trim(var_list(v))) - IF(var_name /= "hgtP" .AND. var_name /= "tmpP" .AND. & - var_name /= "up3P" .AND. var_name /= "vp3P" .AND. & - var_name /= "oc1P" .AND. var_name /= "oc2P" .AND. & - var_name /= "bc1P" .AND. var_name /= "bc2P" .AND. & - var_name /= "so2P" .AND. var_name /= "slfP" .AND. & - var_name /= "d1sP" .AND. var_name /= "d2sP" .AND. & - var_name /= "d3sP" .AND. var_name /= "d4sP" .AND. & - var_name /= "d5sP" .AND. var_name /= "s1sP" .AND. & - var_name /= "s2sP" .AND. var_name /= "s3sP" .AND. & - var_name /= "s4sP" .AND. var_name /= "dmsP" .AND. & - var_name /= "msaP" .AND. var_name /= "p25P" .AND. & - var_name /= "rh3P" .AND. var_name /= "p10P") THEN - var_name = var_list(v)(1:len_trim(var_list(v))) // '_B' - end if - else - var_name = var_list(v)(1:len_trim(var_list(v))) - end if - write(6,*)'post_write_field: writing field ', trim(var_name) - -!JR Some variables are accumulated from a time other than "timebeg" -!JR Flag value -1 says use default - - if (accum_start == -1) then ! flag value meaning use default - call writegrib (var_name, mx, my, nlevels, 0, & - 0, data_xyz, jdate, time, timebeg, nvlp, pres_hpa) - else - call writegrib (var_name, mx, my, nlevels, 0, & - 0, data_xyz, jdate, time, accum_start, nvlp, pres_hpa) - end if - write(6,*)'post_write_field: done writing GRIB field ', trim(varname), ' index=', v - end if - return -end subroutine post_write_field diff --git a/src/fim/FIMsrc/post/pop/postdata.F90 b/src/fim/FIMsrc/post/pop/postdata.F90 deleted file mode 100644 index d8dc294..0000000 --- a/src/fim/FIMsrc/post/pop/postdata.F90 +++ /dev/null @@ -1,99 +0,0 @@ -! The purpose of module postdata is to hold all the namelist values for post and pop. An advantage to keeping -! this information in a separate module is that executables such as get_gribout also need to "use" this -! module. If it were contained in post.F90, tons of extra baggage would need to be included at link time -! (e.g. netcdf, module_control. -! -! Unfortunately the default data spec needs to be "public", because post.F90 and pop.F90 both need to "use" -! all of it. - -module postdata - implicit none - - public - save - -!JR postnamelist - integer, parameter :: max_vars=200 ! max number of output vars - integer, parameter :: max_pathlen=512 ! max length of pathname - integer, parameter :: max_filelen=32 ! max length of filename -!JR For some reason, the FIM fields created all have a length of 4 -!JR The choice of 16 for max length is arbitrary - integer, parameter :: max_varnamelen=16 ! max length of variable name - - character(len=max_pathlen) :: datadir = ''! path to input FIM data - character(len=max_pathlen) :: outputdir = '' ! path to output GRIB or netCDF files - character(len=1) :: input = '' !JR unknown functionality not ported from pop - character(len=1) :: output = '' !JR unknown functionality not ported from pop - character(len=max_varnamelen) :: mode ! Unused namelist placebo (needed by pop) - character(len=16) :: output_fmt ! 'grib' or 'nc' - logical :: multiple_output_files ! placebo: In pop a flag indicating multiple output files - character(len=max_filelen) :: gribtable = '' ! name of grib table - integer :: grid_id ! GRIB-specific var. related to horizontal resolution - integer :: mx = -999 ! number of points in x on output lat-lon grid - integer :: my = -999 ! number of points in y on output lat-lon grid - logical :: latlonfld = .true. ! flag indicates output grib file is lat-lon (default true) - integer :: is = -999 ! Interpolation scheme. Only valid value is 1. Init to invalid - integer :: vres = -999 ! number of vertical levels (init to bad value) - character(len=max_varnamelen) :: var_list(max_vars) = ' ' ! list of GRIB output variables - integer :: nsmooth_var(max_vars) = 0 ! number of smoothing invocations -!JR t1, t2, and delta_t are unused placebos by FIM when gribout=.true. - integer :: t1 ! used only in pop.F90 - integer :: t2, delta_t ! used only in pop.F90 -!JR fimout and gribout are unused placebos by pop when run as a separate executable. - logical :: fimout = .true. ! whether to write FIM-style output files directly (default true) - logical :: gribout = .false. ! whether to write GRIB files directly (default false) - - namelist /postnamelist/ datadir, outputdir, input, output, output_fmt, multiple_output_files, & - gribtable, grid_id, mx, my, latlonfld, is, vres, mode, var_list, & - nsmooth_var, t1, t2, delta_t, gribout, fimout - -contains - - subroutine post_read_namelist (retcode) - integer, intent(out) :: retcode - - integer :: j - integer :: ioerr=0 - integer :: me=0 - logical, save :: post_namelist_read = .false. - - retcode = 0 - - if (.not. post_namelist_read) then -!sms$insert call nnt_me(me) - open (11, file="./FIMnamelist", status='old', action='read', iostat=ioerr) - if (ioerr /= 0) then - write(*,'(a,i0)') 'post_read_namelist: error opening FIMnamelist by task ',me - call flush(6) - retcode = -1 - return - end if - - read (11, nml=postnamelist, iostat=ioerr) - if (ioerr /= 0) then - write(*,'(a,i0)') 'post_init: error reading POSTnamelist from FIMnamelist by task ',me - call flush(6) - retcode = -1 - return - end if - close (11) - - ! Ensure against old-style input fields by checking for embedded spaces in the field name - - do j=1,max_vars - if (index (trim (var_list(j)), ' ') /= 0) then - write(*,'(a,i0,a,a)') 'post_read_namelist: var_list element ',j, ' contains an embedded blank character ', & - 'which is not allowed.' - write(*,'(a,a)') 'The first bad input field is:', trim (var_list(j)) - write(*,'(a,a)') 'Perhaps you are using the old-style syntax of "var1 var2 var3 ..." instead of ', & - 'the new syntax of "var1", "var2", "var3", ...?' - retcode = -1 - return - end if - end do - - post_namelist_read = .true. - end if - return - end subroutine post_read_namelist -end module postdata diff --git a/src/fim/FIMsrc/post/pop/smooth.F90 b/src/fim/FIMsrc/post/pop/smooth.F90 deleted file mode 100644 index ab72177..0000000 --- a/src/fim/FIMsrc/post/pop/smooth.F90 +++ /dev/null @@ -1,36 +0,0 @@ -! wgt = 0.2 for now -subroutine smooth(a,mx,my,mz,wgt) -! -! --- 3-dimensional smoothing routine -! -real a(mx,my,mz) -real, allocatable, dimension(:,:) :: a2d -real, allocatable, dimension(:,:,:) :: b -! -allocate(a2d(mx, my)) -allocate(b(mx, my, mz)) -! -do 6 k=1,mz -! -! --- Smooth in i direction -do 4 i=1,mx -ia=2*max0( 1,i-1)-(i-1) -ib=2*min0(mx,i+1)-(i+1) -do 4 j=1,my -4 a2d(i,j)=(1.-wgt-wgt)*a(i,j,k)+wgt*(a(ia,j,k)+a(ib,j,k)) -! -! --- Smooth in j direction -do 5 j=1,my -ja=2*max0( 1,j-1)-(j-1) -jb=2*min0(my,j+1)-(j+1) -do 5 i=1,mx -5 b(i,j,k)=(1.-wgt-wgt)*a2d(i,j)+wgt*(a2d(i,ja)+a2d(i,jb)) -6 continue - -a = b - -deallocate(a2d,b) -! -return -end - diff --git a/src/fim/FIMsrc/post/vlint/Makefile b/src/fim/FIMsrc/post/vlint/Makefile deleted file mode 100644 index 2c59e06..0000000 --- a/src/fim/FIMsrc/post/vlint/Makefile +++ /dev/null @@ -1,19 +0,0 @@ -# vlint Makefile - -SHELL = /bin/sh - -AR = ar ruv -FFLAGS = $(FFLAGS) -LIBVLINT = $(LIBDIR)/libvlint.a - -.SUFFIXES: .F90 .o .a - -$(LIBVLINT): $(LIBVLINT)(vlint.o) - -.F90.a: - $(FC) -c $(FFLAGS) $< - $(AR) $@ $*.o - rm -f $*.o - -clean: - rm -f *.o diff --git a/src/fim/FIMsrc/post/vlint/vlint.F90 b/src/fim/FIMsrc/post/vlint/vlint.F90 deleted file mode 100644 index a626391..0000000 --- a/src/fim/FIMsrc/post/vlint/vlint.F90 +++ /dev/null @@ -1,242 +0,0 @@ -!============================================================================= -! subroutines to perform vertical interpolations -! -! -! Ning Wang, June 2007 -! -! -!============================================================================= -! layer interpolation, target coordinate: 1100mb -- 0mb with -10mb increment -! the interpolated data will have constant layers and transition layers - SUBROUTINE v_interp(mx, my, nvl, data_xyz_pr, data_xyz_var, nvgp, data_xyz, nodata, mode) - IMPLICIT NONE - INTEGER mx, my, nvl, nvgp, mode - REAL data_xyz_pr(mx, my,nvl + 1), data_xyz_var(mx, my, nvl), data_xyz(mx, my, nvgp) - REAL nodata; - - REAL max_pr, min_pr, intv, extent, up_pr, dn_pr, mid_pr, last_up_val - REAL l_dn_pr, l_up_pr, l_pr - INTEGER i, j, k, l, up_idx, dn_idx, last_up_idx, up_b_idx - - IF (mode == 1) THEN - extent = 0.85 - ELSE - extent = 0.0 - ENDIF - max_pr = 110000 !1100 mb - min_pr = 0 !0 mb - - intv = (max_pr - min_pr) / (nvgp - 1) - - DO i = 1, mx - DO j = 1, my - last_up_val = data_xyz_var(i, j, 1) - last_up_idx = nvgp - (data_xyz_pr(i, j, 1) - min_pr) / intv - IF (last_up_idx >= 1) THEN - data_xyz(i, j, last_up_idx) = last_up_val - ENDIF - - DO k = 1, nvl - ! pressures for the upper and lower side of the current layer - up_pr = data_xyz_pr(i, j, k + 1) - dn_pr = data_xyz_pr(i, j, k) - mid_pr = (up_pr + dn_pr) / 2.0 - up_pr = mid_pr - extent * 0.5 * (dn_pr - up_pr) - dn_pr = mid_pr + extent * 0.5 * (dn_pr - up_pr) - - ! fill in the constant layer value (middle) - up_idx = nvgp - INT((up_pr - min_pr) / intv) - dn_idx = nvgp - INT((dn_pr - min_pr) / intv) - DO l = dn_idx, up_idx - data_xyz(i, j, l) = data_xyz_var(i, j, k) - END DO - - ! linearly interpolate the transition layer (down, between two layers) - l_dn_pr = log(REAL((nvgp - last_up_idx) * intv + min_pr)) - l_up_pr = log(REAL((nvgp - dn_idx + 1) * intv + min_pr)) - DO l = last_up_idx + 1, dn_idx - 1 - l_pr = log(REAL((nvgp - l) * intv + min_pr)) - data_xyz(i, j, l) = last_up_val + (l_pr - l_dn_pr) * & - (data_xyz(i, j, dn_idx) - last_up_val) / & - (l_up_pr - l_dn_pr) - END DO - - ! if it is the lowest layer, fill in the no value for the data points below - IF (k == 1) THEN - DO l = 1, last_up_idx - data_xyz(i, j, l) = nodata - END DO - - ! if it is the highest layer, interpolate to the interface - ELSE IF (k == nvl) THEN - up_b_idx = nvgp - (data_xyz_pr(i, j, nvl + 1) - min_pr) / intv - l_dn_pr = log(REAL((nvgp - up_idx) * intv + min_pr)) - l_up_pr = log(REAL((nvgp - up_b_idx) * intv + min_pr)) - DO l = up_idx + 1, up_b_idx - l_pr = log(REAL((nvgp - l) * intv + min_pr)) - data_xyz(i, j, l) = data_xyz(i, j, up_idx) + (l_pr - l_dn_pr) * & - (data_xyz_var(i, j, nvl) - data_xyz(i, j, up_idx)) / & - (l_up_pr - l_dn_pr) - END DO - ! then fill in the nodata value for the data points above - DO l = up_b_idx + 1, nvgp - data_xyz(i, j, l) = nodata - END DO - ENDIF - last_up_idx = up_idx - last_up_val = data_xyz(i, j, up_idx) - END DO - END DO - END DO - - END SUBROUTINE - -! level interpolation, target coordinate: 1100mb -- 0mb with -10mb increment - SUBROUTINE v_interp_lvlvar(mx, my, nvl, data_xyz_pr, data_xyz_var, nvgp, data_xyz, nodata, mode) - IMPLICIT NONE - INTEGER mx, my, nvl, nvgp, mode - REAL data_xyz_pr(mx, my,nvl + 1), data_xyz_var(mx, my, nvl), data_xyz(mx, my, nvgp) - REAL nodata; - - REAL max_pr, min_pr, intv, extent, up_pr, dn_pr, mid_pr, last_up_val - REAL l_dn_pr, l_up_pr, l_pr, pi_dn, pi_up, pi_pr - INTEGER i, j, k, l, up_idx, dn_idx, last_up_idx, up_b_idx - - max_pr = 110000.00 !1100 mb - min_pr = 0.00 !0 mb - - intv = (max_pr - min_pr) / (nvgp - 1) - - DO i = 1, mx - DO j = 1, my - DO k = 1, nvl - 1 - ! pressures for the upper and lower side of the current layer - up_pr = data_xyz_pr(i, j, k + 1) - dn_pr = data_xyz_pr(i, j, k) - up_idx = nvgp - (up_pr - min_pr) / intv - dn_idx = nvgp - (dn_pr - min_pr) / intv - ! linearly interpolate the transition layer - pi_dn = (dn_pr / 100000.00)**0.286 - pi_up = (up_pr / 100000.00)**0.286 - DO l = dn_idx, up_idx - l_pr = (nvgp - l) * intv + min_pr - pi_pr = (l_pr / 100000.00)**0.286 - data_xyz(i, j, l) = data_xyz_var(i, j, k) + (pi_pr - pi_dn) * & - (data_xyz_var(i, j, k + 1) - data_xyz_var(i, j, k)) / & - (pi_up - pi_dn) - END DO - - ! if it is the lowest layer, fill in the no value for the data points below - IF (k == 1) THEN - DO l = 1, dn_idx - 1 - data_xyz(i, j, l) = nodata - END DO - ! then fill in the nodata value for the data points above - ELSE IF (k == nvl) THEN - DO l = up_idx + 1, nvgp - data_xyz(i, j, l) = nodata - END DO - ENDIF - END DO - END DO - END DO - - END SUBROUTINE - -!============================================================================= -! Level and layer interpolation, target coordinate: passed in (v_coor) -! -! -! Figure 1. | Figure 2. -! Level variables at interface: | Layer variables: -! | -! -------------- int. level nvl + 1 | ---------------- int. level nvl + 1 -! : | : -! : | : -! -------------- int. level k + 1 | ---------------- int. level k + 1 -! | //////////////// variable at layer k -! -------------- int. level k | ---------------- int. level k -! : | : -! : | : -! -------------- int. level 1 | ---------------- int. level 1 -! | -! -! -! N. Wang, Feb. 2008 -!============================================================================= - - SUBROUTINE vlint2coor(mx, my, nvl, nvlp1, data_xyz_pr, data_xyz_var, data_xyz, v_coor, nvc) - IMPLICIT NONE - INTEGER mx, my, nvl, nvlp1, nvc - REAL data_xyz_pr(mx, my, nvlp1), data_xyz_var(mx, my, nvl), data_xyz(mx, my, nvc), v_coor(nvc) - REAL v_coor_pa(nvc), pi_dn, pi_up, pi_co, dn_val, up_val - INTEGER i, j, k, l - - v_coor_pa = v_coor * 100.0 - DO i = 1, mx - DO j = 1, my - k = 1 - DO l = 1, nvc - IF (v_coor_pa(l) >= data_xyz_pr(i, j, 1)) THEN - data_xyz(i, j, l) = data_xyz_var(i, j, 1) - CYCLE - END IF - IF (v_coor_pa(l) <= data_xyz_pr(i, j, nvlp1)) THEN - data_xyz(i, j, l) = data_xyz_var(i, j, nvl) - CYCLE - END IF - DO WHILE (v_coor_pa(l) < data_xyz_pr(i, j, k + 1)) - IF (k == nvlp1 - 1) THEN - EXIT - ELSE - k = k + 1 - ENDIF - END DO ! k and k+1 are the current indexes for interpolation - IF (nvl == nvlp1) THEN ! level variables, see fig. 1. - pi_dn = (data_xyz_pr(i, j, k) / 100000.00)**0.286 - pi_up = (data_xyz_pr(i, j, k + 1) / 100000.00)**0.286 - pi_co = (v_coor_pa(l) / 100000.00)**0.286 - dn_val = data_xyz_var(i, j, k) - up_val = data_xyz_var(i, j, k + 1) - ELSE ! layer variables, see fig. 2. - pi_dn = (data_xyz_pr(i, j, k) / 100000.00)**0.286 - pi_up = (data_xyz_pr(i, j, k + 1) / 100000.00)**0.286 - pi_co = (v_coor_pa(l) / 100000.00)**0.286 - IF (pi_co > (pi_dn + pi_up) / 2.0) THEN ! lower half of the layer - IF (k == 1) THEN - pi_dn = (data_xyz_pr(i, j, k) / 100000.00)**0.286 - pi_up = ((data_xyz_pr(i, j, k) / 100000.00)**0.286 + (data_xyz_pr(i, j, k + 1) / 100000.00)**0.286)/ 2.0 - pi_co = (v_coor_pa(l) / 100000.00)**0.286 - dn_val = data_xyz_var(i, j, k) - up_val = dn_val - ELSE - pi_dn = ((data_xyz_pr(i, j, k) / 100000.00)**0.286 + (data_xyz_pr(i, j, k - 1) / 100000.00)**0.286)/ 2.0 - pi_up = ((data_xyz_pr(i, j, k) / 100000.00)**0.286 + (data_xyz_pr(i, j, k + 1) / 100000.00)**0.286)/ 2.0 - pi_co = (v_coor_pa(l) / 100000.00)**0.286 - dn_val = data_xyz_var(i, j, k - 1) - up_val = data_xyz_var(i, j, k) - ENDIF - ELSE ! upper half of the layer - IF (k == nvl) THEN - pi_dn = ((data_xyz_pr(i, j, k) / 100000.00)**0.286 + (data_xyz_pr(i, j, k + 1) / 100000.00)**0.286)/ 2.0 - pi_up = (data_xyz_pr(i, j, k + 1) / 100000.00)**0.286 - pi_co = (v_coor_pa(l) / 100000.00)**0.286 - dn_val = data_xyz_var(i, j, k) - up_val = dn_val - ELSE - pi_dn = ((data_xyz_pr(i, j, k) / 100000.00)**0.286 + (data_xyz_pr(i, j, k + 1) / 100000.00)**0.286)/ 2.0 - pi_up = ((data_xyz_pr(i, j, k + 1) / 100000.00)**0.286 + (data_xyz_pr(i, j, k + 2) / 100000.00)**0.286)/ 2.0 - pi_co = (v_coor_pa(l) / 100000.00)**0.286 - dn_val = data_xyz_var(i, j, k) - up_val = data_xyz_var(i, j, k + 1) - ENDIF - - ENDIF - ENDIF - data_xyz(i, j, l) = up_val + (pi_co - pi_up) * & - (dn_val - up_val) / (pi_dn - pi_up) - END DO - END DO - END DO - END SUBROUTINE - diff --git a/src/fim/FIMsrc/post/wrfio/Makefile b/src/fim/FIMsrc/post/wrfio/Makefile deleted file mode 100644 index 0150aec..0000000 --- a/src/fim/FIMsrc/post/wrfio/Makefile +++ /dev/null @@ -1,31 +0,0 @@ -# wrfio Makefile - -SHELL = /bin/sh - -include ../../macros.make - -AR = ar ruv -LIBWRFIO = $(LIBDIR)/libwrfio.a - -.SUFFIXES: .F90 .o .a - -$(LIBWRFIO): $(LIBWRFIO)(wrf_io.o field_routines.o ) - -#JR On Mac, cpp doesn't handle concatenation (##) corectly, -#JR and "cc -E" only does the right thing when handed a .c file. Therefore -#JR need to temporarily rename the .F90 file to .c, and for Mac override -#JR the default CPP with "cc -E" - -ifeq ($(MAKEFIM_TARGET),macgnu) - CPP = cc -E -endif - -.F90.a: - cp -f $< $*.c - $(CPP) $(CPP_FLAGS) $*.c > $*_cpp.F90 - $(FC) -c $(FFLAGS) $*_cpp.F90 $(LIBNETCDF) $(INCNETCDF) - mv $*_cpp.o $*.o - $(AR) $@ $*.o - $(RM) $*.o $*.c -clean: - $(RM) *.o *.mod *_cpp.F90 *.c diff --git a/src/fim/FIMsrc/post/wrfio/ext_ncd_get_dom_ti.code b/src/fim/FIMsrc/post/wrfio/ext_ncd_get_dom_ti.code deleted file mode 100644 index fe365f1..0000000 --- a/src/fim/FIMsrc/post/wrfio/ext_ncd_get_dom_ti.code +++ /dev/null @@ -1,157 +0,0 @@ -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - TYPE_DATA - TYPE_COUNT - TYPE_OUTCOUNT - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XType - integer :: Len - integer :: stat - TYPE_BUFFER - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif -! Do nothing unless it is time to read time-independent domain metadata. -IF ( ncd_ok_to_get_dom_ti( DataHandle ) ) THEN - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WRITE ONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - stat = NF_INQ_ATT(DH%NCID,NF_GLOBAL,Element, XType, Len) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - if ( NF_TYPE == NF_DOUBLE .OR. NF_TYPE == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - else - if( XType/=NF_TYPE) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - endif - if(Len<=0) then - Status = WRF_WARN_LENGTH_LESS_THAN_1 - write(msg,*) & -'Warning LENGTH < 1 in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif -#ifndef CHAR_TYPE - allocate(Buffer(Len), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_ROUTINE (DH%NCID,NF_GLOBAL,Element,Buffer) -#else - Data = '' - stat = NF_GET_ATT_TEXT(DH%NCID,NF_GLOBAL,Element,Data) -#endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif -#ifndef CHAR_TYPE - COPY - deallocate(Buffer, STAT=stat) - if(stat/= WRF_NO_ERR) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - if(Len > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = Len - Status = WRF_NO_ERR - endif -#endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - endif -ENDIF - return diff --git a/src/fim/FIMsrc/post/wrfio/ext_ncd_get_var_td.code b/src/fim/FIMsrc/post/wrfio/ext_ncd_get_var_td.code deleted file mode 100644 index bd28dc3..0000000 --- a/src/fim/FIMsrc/post/wrfio/ext_ncd_get_var_td.code +++ /dev/null @@ -1,227 +0,0 @@ -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character (DateStrLen),intent(in) :: DateStr - character*(*) ,intent(in) :: Var - TYPE_DATA - TYPE_COUNT - TYPE_OUTCOUNT - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - character (40+len(Element)) :: Name - character (40+len(Element)) :: FName - integer :: stat - TYPE_BUFFER ,allocatable :: Buffer(:) - integer :: i - integer :: VDims (2) - integer :: VStart(2) - integer :: VCount(2) - integer :: NVar - integer :: TimeIndex - integer :: NCID - integer :: DimIDs(2) - integer :: VarID - integer :: XType - integer :: NDims - integer :: NAtts - integer :: Len1 - - if(Count <= 0) then - Status = WRF_WARN_ZERO_LENGTH_GET - write(msg,*) & -'Warning ZERO LENGTH GET in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - VarName = Var - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning DATE STRING ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - NCID = DH%NCID - call GetName(Element, VarName, Name, Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - stat = NF_INQ_VARID(NCID,Name,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_INQ_VAR(NCID,VarID,FName,XType,NDims,DimIDs,NAtts) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - if ( NF_TYPE == NF_DOUBLE .OR. NF_TYPE == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - else - if(XType /= NF_TYPE) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - endif - if(NDims /= NMDVarDims) then - Status = WRF_ERR_FATAL_MDVAR_DIM_NOT_1D - write(msg,*) & -'Fatal MDVAR DIM NOT 1D in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_INQ_DIMLEN(NCID,DimIDs(1),Len1) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' DimIDs(1) ',DimIDs(1) - call wrf_debug ( WARN , msg) - return - endif - call GetTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - VStart(1) = 1 - VStart(2) = TimeIndex - VCount(1) = LENGTH - VCount(2) = 1 -#ifndef CHAR_TYPE - allocate(Buffer(VCount(1)), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_ROUTINE (NCID,VarID,VStart,VCount,Buffer) -#else - if(Len1 > len(Data)) then - Status = WRF_WARN_CHARSTR_GT_LENDATA - write(msg,*) & -'Warning LEN CHAR STRING > LEN DATA in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - Data = '' - stat = NF_GET_VARA_TEXT (NCID,VarID,VStart,VCount,Data) -#endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif -#ifndef CHAR_TYPE - COPY - deallocate(Buffer, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - if(Len1 > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = Len1 - Status = WRF_NO_ERR - endif -#endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - endif - return diff --git a/src/fim/FIMsrc/post/wrfio/ext_ncd_get_var_ti.code b/src/fim/FIMsrc/post/wrfio/ext_ncd_get_var_ti.code deleted file mode 100644 index 47a161b..0000000 --- a/src/fim/FIMsrc/post/wrfio/ext_ncd_get_var_ti.code +++ /dev/null @@ -1,174 +0,0 @@ -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: Var - TYPE_DATA - TYPE_COUNT - TYPE_OUTCOUNT - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XLen - TYPE_BUFFER - character (VarNameLen) :: VarName - integer :: stat - integer :: NVar - integer :: XType - - if(Count <= 0) then - Status = WRF_WARN_ZERO_LENGTH_GET - write(msg,*) & -'Warning ZERO LENGTH GET in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - do NVar=1,DH%NumVars - if(DH%VarNames(NVar) == VarName) then - exit - elseif(NVar == DH%NumVars) then - Status = WRF_WARN_VAR_NF - write(msg,*) & -'Warning VARIABLE NOT FOUND in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - enddo - stat = NF_INQ_ATT(DH%NCID,DH%VarIDs(NVar),trim(Element),XType,XLen) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - endif - if ( NF_TYPE == NF_DOUBLE .OR. NF_TYPE == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - else - if(XType /= NF_TYPE) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - endif -#ifndef CHAR_TYPE - allocate(Buffer(XLen), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_ROUTINE(DH%NCID,DH%VarIDs(NVar),trim(Element), Buffer ) -#else - if(XLen > len(Data)) then - Status = WRF_WARN_CHARSTR_GT_LENDATA - write(msg,*) & -'Warning LEN CHAR STRING > LEN DATA in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - stat = NF_ROUTINE(DH%NCID,DH%VarIDs(NVar),trim(Element), Data ) -#endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - endif - COPY -#ifndef CHAR_TYPE - deallocate(Buffer, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - if(XLen > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = XLen - Status = WRF_NO_ERR - endif -#endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - return diff --git a/src/fim/FIMsrc/post/wrfio/ext_ncd_put_dom_ti.code b/src/fim/FIMsrc/post/wrfio/ext_ncd_put_dom_ti.code deleted file mode 100644 index 6b98425..0000000 --- a/src/fim/FIMsrc/post/wrfio/ext_ncd_put_dom_ti.code +++ /dev/null @@ -1,164 +0,0 @@ -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - TYPE_DATA - TYPE_COUNT - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: stat - integer :: stat2 - integer ,allocatable :: Buffer(:) - integer :: i - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif -! Do nothing unless it is time to write time-independent domain metadata. -IF ( ncd_ok_to_put_dom_ti( DataHandle ) ) THEN - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - STATUS = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then -#ifdef LOG - allocate(Buffer(Count), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - do i=1,Count - if(data(i)) then - Buffer(i)=1 - else - Buffer(i)=0 - endif - enddo - stat = NF_ROUTINE (DH%NCID,NF_GLOBAL,Element,ARGS) - deallocate(Buffer, STAT=stat2) - if(stat2/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif -#else - stat = NF_ROUTINE (DH%NCID,NF_GLOBAL,Element,ARGS) -#endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - stat = NF_REDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif -#ifdef LOG - allocate(Buffer(Count), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - do i=1,Count - if(data(i)) then - Buffer(i)=1 - else - Buffer(i)=0 - endif - enddo - stat = NF_ROUTINE (DH%NCID,NF_GLOBAL,Element,ARGS) - deallocate(Buffer, STAT=stat2) - if(stat2/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif -#else - stat = NF_ROUTINE (DH%NCID,NF_GLOBAL,Element,ARGS) -#endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_ENDDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - endif -ENDIF - return diff --git a/src/fim/FIMsrc/post/wrfio/ext_ncd_put_var_td.code b/src/fim/FIMsrc/post/wrfio/ext_ncd_put_var_td.code deleted file mode 100644 index 750e1ec..0000000 --- a/src/fim/FIMsrc/post/wrfio/ext_ncd_put_var_td.code +++ /dev/null @@ -1,233 +0,0 @@ -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(in) :: Var - TYPE_DATA - TYPE_COUNT - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - character (40+len(Element)) :: Name - integer :: stat - integer :: stat2 - integer ,allocatable :: Buffer(:) - integer :: i - integer :: VDims (2) - integer :: VStart(2) - integer :: VCount(2) - integer :: NVar - integer :: TimeIndex - integer :: NCID - - VarName = Var - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning DATE STRING ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - NCID = DH%NCID - call GetName(Element, VarName, Name, Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - if(LENGTH < 1) then - Status = WRF_WARN_ZERO_LENGTH_PUT - return - endif - do NVar=1,MaxVars - if(DH%MDVarNames(NVar) == Name) then - Status = WRF_WARN_2DRYRUNS_1VARIABLE - return - elseif(DH%MDVarNames(NVar) == NO_NAME) then - DH%MDVarNames(NVar) = Name - exit - elseif(NVar == MaxVars) then - Status = WRF_WARN_TOO_MANY_VARIABLES - write(msg,*) & -'Warning TOO MANY VARIABLES in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - enddo - do i=1,MaxDims - if(DH%DimLengths(i) == LENGTH) then - exit - elseif(DH%DimLengths(i) == NO_DIM) then - stat = NF_DEF_DIM(NCID,DH%DimNames(i),LENGTH,DH%DimIDs(i)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - DH%DimLengths(i) = LENGTH - exit - elseif(i == MaxDims) then - Status = WRF_WARN_TOO_MANY_DIMS - write(msg,*) & -'Warning TOO MANY DIMENSIONS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - enddo - DH%MDVarDimLens(NVar) = LENGTH - VDims(1) = DH%DimIDs(i) - VDims(2) = DH%DimUnlimID - stat = NF_DEF_VAR(NCID,Name,NF_TYPE,2,VDims,DH%MDVarIDs(NVar)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - do NVar=1,MaxVars - if(DH%MDVarNames(NVar) == Name) then - exit - elseif(DH%MDVarNames(NVar) == NO_NAME) then - Status = WRF_WARN_MD_NF - write(msg,*) & -'Warning METADATA NOT FOUND in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - elseif(NVar == MaxVars) then - Status = WRF_WARN_TOO_MANY_VARIABLES - write(msg,*) & -'Warning TOO MANY VARIABLES in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - enddo - if(LENGTH > DH%MDVarDimLens(NVar)) then - Status = WRF_WARN_COUNT_TOO_LONG - write(msg,*) & -'Warning COUNT TOO LONG in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - elseif(LENGTH < 1) then - Status = WRF_WARN_ZERO_LENGTH_PUT - write(msg,*) & -'Warning ZERO LENGTH PUT in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - call GetTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - VStart(1) = 1 - VStart(2) = TimeIndex - VCount(1) = LENGTH - VCount(2) = 1 -#ifdef LOG - allocate(Buffer(LENGTH), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - do i=1,Count - if(data(i)) then - Buffer(i)=1 - else - Buffer(i)=0 - endif - enddo - stat = NF_ROUTINE (NCID,DH%MDVarIDs(NVar),VStart,VCount,Buffer) - deallocate(Buffer, STAT=stat2) - if(stat2/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif -#else - stat = NF_ROUTINE (NCID,DH%MDVarIDs(NVar),VStart,VCount,Data) -#endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - return diff --git a/src/fim/FIMsrc/post/wrfio/ext_ncd_put_var_ti.code b/src/fim/FIMsrc/post/wrfio/ext_ncd_put_var_ti.code deleted file mode 100644 index 05bfc64..0000000 --- a/src/fim/FIMsrc/post/wrfio/ext_ncd_put_var_ti.code +++ /dev/null @@ -1,144 +0,0 @@ -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: Var - TYPE_DATA - TYPE_COUNT - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - integer :: stat - integer ,allocatable :: Buffer(:) - integer :: i - integer :: NVar - character*1 :: null - - null=char(0) - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_MD_AFTER_OPEN - write(msg,*) & -'Warning WRITE METADATA AFTER OPEN in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - do NVar=1,MaxVars - if(TRIM(DH%VarNames(NVar)) == TRIM(VarName)) then - exit - elseif(NVar == MaxVars) then - Status = WRF_WARN_VAR_NF - write(msg,*) & -'Warning VARIABLE NOT FOUND in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ & - ,NVar,VarName - call wrf_debug ( WARN , msg) - return - endif - enddo -#ifdef LOG - allocate(Buffer(Count), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - do i=1,Count - if(data(i)) then - Buffer(i)=1 - else - Buffer(i)=0 - endif - enddo -#endif -#ifdef CHAR_TYPE - if(len_trim(Data).le.0) then - stat = NF_ROUTINE(DH%NCID,DH%VarIDs(NVar),trim(Element),len_trim(null),null) - else - stat = NF_ROUTINE(DH%NCID,DH%VarIDs(NVar),trim(Element), ARGS ) - endif -#else - stat = NF_ROUTINE(DH%NCID,DH%VarIDs(NVar),trim(Element), ARGS ) -#endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error for Var ',TRIM(Var),& - ' Element ',trim(Element),' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - endif -#ifdef LOG - deallocate(Buffer, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif -#endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - return diff --git a/src/fim/FIMsrc/post/wrfio/field_routines.F90 b/src/fim/FIMsrc/post/wrfio/field_routines.F90 deleted file mode 100644 index cd9bcfa..0000000 --- a/src/fim/FIMsrc/post/wrfio/field_routines.F90 +++ /dev/null @@ -1,175 +0,0 @@ -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- -subroutine ext_ncd_RealFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character (*) ,intent(in) :: IO - integer ,intent(in) :: NCID - integer ,intent(in) :: VarID - integer ,dimension(NVarDims),intent(in) :: VStart - integer ,dimension(NVarDims),intent(in) :: VCount - real, dimension(*) ,intent(inout) :: Data - integer ,intent(out) :: Status - integer :: stat - - if(IO == 'write') then - stat = NF_PUT_VARA_REAL(NCID,VarID,VStart,VCount,Data) - else - stat = NF_GET_VARA_REAL(NCID,VarID,VStart,VCount,Data) - endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , msg) - endif - return -end subroutine ext_ncd_RealFieldIO - -subroutine ext_ncd_DoubleFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character (*) ,intent(in) :: IO - integer ,intent(in) :: NCID - integer ,intent(in) :: VarID - integer ,dimension(NVarDims),intent(in) :: VStart - integer ,dimension(NVarDims),intent(in) :: VCount - real*8 ,intent(inout) :: Data - integer ,intent(out) :: Status - integer :: stat - - if(IO == 'write') then - stat = NF_PUT_VARA_DOUBLE(NCID,VarID,VStart,VCount,Data) - else - stat = NF_GET_VARA_DOUBLE(NCID,VarID,VStart,VCount,Data) - endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , msg) - endif - return -end subroutine ext_ncd_DoubleFieldIO - -subroutine ext_ncd_IntFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character (*) ,intent(in) :: IO - integer ,intent(in) :: NCID - integer ,intent(in) :: VarID - integer ,dimension(NVarDims),intent(in) :: VStart - integer ,dimension(NVarDims),intent(in) :: VCount - integer ,intent(inout) :: Data - integer ,intent(out) :: Status - integer :: stat - - if(IO == 'write') then - stat = NF_PUT_VARA_INT(NCID,VarID,VStart,VCount,Data) - else - stat = NF_GET_VARA_INT(NCID,VarID,VStart,VCount,Data) - endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , msg) - endif - return -end subroutine ext_ncd_IntFieldIO - -subroutine ext_ncd_LogicalFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character (*) ,intent(in) :: IO - integer ,intent(in) :: NCID - integer ,intent(in) :: VarID - integer,dimension(NVarDims) ,intent(in) :: VStart - integer,dimension(NVarDims) ,intent(in) :: VCount - logical,dimension(VCount(1),VCount(2),VCount(3)),intent(inout) :: Data - integer ,intent(out) :: Status - integer,dimension(:,:,:),allocatable :: Buffer - integer :: stat - integer :: i,j,k - - allocate(Buffer(VCount(1),VCount(2),VCount(3)), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - if(IO == 'write') then - do k=1,VCount(3) - do j=1,VCount(2) - do i=1,VCount(1) - if(data(i,j,k)) then - Buffer(i,j,k)=1 - else - Buffer(i,j,k)=0 - endif - enddo - enddo - enddo - stat = NF_PUT_VARA_INT(NCID,VarID,VStart,VCount,Buffer) - else - stat = NF_GET_VARA_INT(NCID,VarID,VStart,VCount,Buffer) - Data = Buffer == 1 - endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - deallocate(Buffer, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_LogicalFieldIO diff --git a/src/fim/FIMsrc/post/wrfio/transpose.code b/src/fim/FIMsrc/post/wrfio/transpose.code deleted file mode 100644 index 47b23ac..0000000 --- a/src/fim/FIMsrc/post/wrfio/transpose.code +++ /dev/null @@ -1,34 +0,0 @@ - ix=0 - jx=0 - kx=0 - call reorder(MemoryOrder,MemO) - if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 - if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 - if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 - -! pjj/cray - if(IO == 'write') then -!dir$ concurrent - do k=k1,k2 - do j=j1,j2 -!dir$ prefervector -!dir$ concurrent - do i=i1,i2 - DFIELD = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) - enddo - enddo - enddo -else -!dir$ concurrent - do k=k1,k2 - do j=j1,j2 -!dir$ prefervector -!dir$ concurrent - do i=i1,i2 - Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = DFIELD - enddo - enddo - enddo -endif - - return diff --git a/src/fim/FIMsrc/post/wrfio/wrf_io.F90 b/src/fim/FIMsrc/post/wrfio/wrf_io.F90 deleted file mode 100644 index 1d2c687..0000000 --- a/src/fim/FIMsrc/post/wrfio/wrf_io.F90 +++ /dev/null @@ -1,3362 +0,0 @@ -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - -module wrf_data - - integer , parameter :: FATAL = 1 - integer , parameter :: WARN = 1 - integer , parameter :: WrfDataHandleMax = 99 - integer , parameter :: MaxDims = 2000 ! = NF_MAX_VARS - integer , parameter :: MaxVars = 2000 - integer , parameter :: MaxTimes = 9000 - integer , parameter :: DateStrLen = 19 - integer , parameter :: VarNameLen = 31 - integer , parameter :: NO_DIM = 0 - integer , parameter :: NVarDims = 4 - integer , parameter :: NMDVarDims = 2 - character (8) , parameter :: NO_NAME = 'NULL' - character (DateStrLen) , parameter :: ZeroDate = '0000-00-00-00:00:00' - - include 'wrf_io_flags.h' - - character (256) :: msg - logical :: WrfIOnotInitialized = .true. - - type :: wrf_data_handle - character (255) :: FileName - integer :: FileStatus - integer :: Comm - integer :: NCID - logical :: Free - logical :: Write - character (5) :: TimesName - integer :: TimeIndex - integer :: CurrentTime !Only used for read - integer :: NumberTimes !Only used for read - character (DateStrLen), pointer :: Times(:) - integer :: TimesVarID - integer , pointer :: DimLengths(:) - integer , pointer :: DimIDs(:) - character (31) , pointer :: DimNames(:) - integer :: DimUnlimID - character (9) :: DimUnlimName - integer , dimension(NVarDims) :: DimID - integer , dimension(NVarDims) :: Dimension - integer , pointer :: MDVarIDs(:) - integer , pointer :: MDVarDimLens(:) - character (80) , pointer :: MDVarNames(:) - integer , pointer :: VarIDs(:) - integer , pointer :: VarDimLens(:,:) - character (VarNameLen), pointer :: VarNames(:) - integer :: CurrentVariable !Only used for read - integer :: NumVars -! first_operation is set to .TRUE. when a new handle is allocated -! or when open-for-write or open-for-read are committed. It is set -! to .FALSE. when the first field is read or written. - logical :: first_operation - end type wrf_data_handle - type(wrf_data_handle),target :: WrfDataHandles(WrfDataHandleMax) -end module wrf_data - -module ext_ncd_support_routines - - implicit none - -CONTAINS - -subroutine allocHandle(DataHandle,DH,Comm,Status) - use wrf_data - include 'wrf_status_codes.h' - integer ,intent(out) :: DataHandle - type(wrf_data_handle),pointer :: DH - integer ,intent(IN) :: Comm - integer ,intent(out) :: Status - integer :: i - integer :: stat - - do i=1,WrfDataHandleMax - if(WrfDataHandles(i)%Free) then - DH => WrfDataHandles(i) - DataHandle = i - allocate(DH%Times(MaxTimes), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%DimLengths(MaxDims), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%DimIDs(MaxDims), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%DimNames(MaxDims), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%MDVarIDs(MaxVars), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%MDVarDimLens(MaxVars), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%MDVarNames(MaxVars), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%VarIDs(MaxVars), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%VarDimLens(NVarDims-1,MaxVars), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%VarNames(MaxVars), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - exit - endif - if(i==WrfDataHandleMax) then - Status = WRF_WARN_TOO_MANY_FILES - write(msg,*) 'Warning TOO MANY FILES in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - write(msg,*) 'Did you call ext_ncd_ioinit?' - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - DH%Free =.false. - DH%Comm = Comm - DH%Write =.false. - DH%first_operation = .TRUE. - Status = WRF_NO_ERR -end subroutine allocHandle - -subroutine deallocHandle(DataHandle, Status) - use wrf_data - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: i - integer :: stat - - IF ( DataHandle .GE. 1 .AND. DataHandle .LE. WrfDataHandleMax ) THEN - if(.NOT. WrfDataHandles(DataHandle)%Free) then - DH => WrfDataHandles(DataHandle) - deallocate(DH%Times, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%DimLengths, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%DimIDs, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%DimNames, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%MDVarIDs, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%MDVarDimLens, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%MDVarNames, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%VarIDs, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%VarDimLens, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%VarNames, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - DH%Free =.TRUE. - endif - ENDIF - Status = WRF_NO_ERR -end subroutine deallocHandle - -subroutine GetDH(DataHandle,DH,Status) - use wrf_data - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - type(wrf_data_handle) ,pointer :: DH - integer ,intent(out) :: Status - - if(DataHandle < 1 .or. DataHandle > WrfDataHandleMax) then - Status = WRF_WARN_BAD_DATA_HANDLE - return - endif - DH => WrfDataHandles(DataHandle) - if(DH%Free) then - Status = WRF_WARN_BAD_DATA_HANDLE - return - endif - Status = WRF_NO_ERR - return -end subroutine GetDH - -subroutine DateCheck(Date,Status) - use wrf_data - include 'wrf_status_codes.h' - character*(*) ,intent(in) :: Date - integer ,intent(out) :: Status - - if(len(Date) /= DateStrLen) then - Status = WRF_WARN_DATESTR_BAD_LENGTH - else - Status = WRF_NO_ERR - endif - return -end subroutine DateCheck - -subroutine GetName(Element,Var,Name,Status) - use wrf_data - include 'wrf_status_codes.h' - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: Var - character*(*) ,intent(out) :: Name - integer ,intent(out) :: Status - character (VarNameLen) :: VarName - character (1) :: c - integer :: i - integer, parameter :: upper_to_lower =IACHAR('a')-IACHAR('A') - - VarName = Var - Name = 'MD___'//trim(Element)//VarName - do i=1,len(Name) - c=Name(i:i) - if('A'<=c .and. c <='Z') Name(i:i)=achar(iachar(c)+upper_to_lower) - if(c=='-'.or.c==':') Name(i:i)='_' - enddo - Status = WRF_NO_ERR - return -end subroutine GetName - -subroutine GetTimeIndex(IO,DataHandle,DateStr,TimeIndex,Status) - use wrf_data - include 'wrf_status_codes.h' - include 'netcdf.inc' - character (*) ,intent(in) :: IO - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: DateStr - integer ,intent(out) :: TimeIndex - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: VStart(2) - integer :: VCount(2) - integer :: stat - integer :: i - - DH => WrfDataHandles(DataHandle) - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - Status = WRF_WARN_DATESTR_ERROR - write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(IO == 'write') then - TimeIndex = DH%TimeIndex - if(TimeIndex <= 0) then - TimeIndex = 1 - elseif(DateStr == DH%Times(TimeIndex)) then - Status = WRF_NO_ERR - return - else - TimeIndex = TimeIndex +1 - if(TimeIndex > MaxTimes) then - Status = WRF_WARN_TIME_EOF - write(msg,*) 'Warning TIME EOF in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - endif - DH%TimeIndex = TimeIndex - DH%Times(TimeIndex) = DateStr - VStart(1) = 1 - VStart(2) = TimeIndex - VCount(1) = DateStrLen - VCount(2) = 1 - stat = NF_PUT_VARA_TEXT(DH%NCID,DH%TimesVarID,VStart,VCount,DateStr) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - else - do i=1,MaxTimes - if(DH%Times(i)==DateStr) then - Status = WRF_NO_ERR - TimeIndex = i - exit - endif - if(i==MaxTimes) then - Status = WRF_WARN_TIME_NF - write(msg,*) 'Warning TIME ',DateStr,' NOT FOUND in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - endif - return -end subroutine GetTimeIndex - -subroutine GetDim(MemoryOrder,NDim,Status) - include 'wrf_status_codes.h' - character*(*) ,intent(in) :: MemoryOrder - integer ,intent(out) :: NDim - integer ,intent(out) :: Status - character*3 :: MemOrd - - call LowerCase(MemoryOrder,MemOrd) - select case (MemOrd) - case ('xyz','xzy','yxz','yzx','zxy','zyx','xsz','xez','ysz','yez') - NDim = 3 - case ('xy','yx','xs','xe','ys','ye') - NDim = 2 - case ('z','c','0') - NDim = 1 - case default - print *, 'memory order = ',MemOrd,' ',MemoryOrder - Status = WRF_WARN_BAD_MEMORYORDER - return - end select - Status = WRF_NO_ERR - return -end subroutine GetDim - -subroutine GetIndices(NDim,Start,End,i1,i2,j1,j2,k1,k2) - integer ,intent(in) :: NDim - integer ,dimension(*),intent(in) :: Start,End - integer ,intent(out) :: i1,i2,j1,j2,k1,k2 - - i1=1 - i2=1 - j1=1 - j2=1 - k1=1 - k2=1 - i1 = Start(1) - i2 = End (1) - if(NDim == 1) return - j1 = Start(2) - j2 = End (2) - if(NDim == 2) return - k1 = Start(3) - k2 = End (3) - return -end subroutine GetIndices - -subroutine ExtOrder(MemoryOrder,Vector,Status) - use wrf_data - include 'wrf_status_codes.h' - character*(*) ,intent(in) :: MemoryOrder - integer,dimension(*) ,intent(inout) :: Vector - integer ,intent(out) :: Status - integer :: NDim - integer,dimension(NVarDims) :: temp - character*3 :: MemOrd - - call GetDim(MemoryOrder,NDim,Status) - temp(1:NDim) = Vector(1:NDim) - call LowerCase(MemoryOrder,MemOrd) - select case (MemOrd) - - case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c') - continue - case ('0') - Vector(1) = 1 - case ('xzy') - Vector(2) = temp(3) - Vector(3) = temp(2) - case ('yxz') - Vector(1) = temp(2) - Vector(2) = temp(1) - case ('yzx') - Vector(1) = temp(3) - Vector(2) = temp(1) - Vector(3) = temp(2) - case ('zxy') - Vector(1) = temp(2) - Vector(2) = temp(3) - Vector(3) = temp(1) - case ('zyx') - Vector(1) = temp(3) - Vector(3) = temp(1) - case ('yx') - Vector(1) = temp(2) - Vector(2) = temp(1) - case default - Status = WRF_WARN_BAD_MEMORYORDER - return - end select - Status = WRF_NO_ERR - return -end subroutine ExtOrder - -subroutine ExtOrderStr(MemoryOrder,Vector,ROVector,Status) - use wrf_data - include 'wrf_status_codes.h' - character*(*) ,intent(in) :: MemoryOrder - character*(*),dimension(*) ,intent(in) :: Vector - character(80),dimension(NVarDims),intent(out) :: ROVector - integer ,intent(out) :: Status - integer :: NDim - character*3 :: MemOrd - - call GetDim(MemoryOrder,NDim,Status) - ROVector(1:NDim) = Vector(1:NDim) - call LowerCase(MemoryOrder,MemOrd) - select case (MemOrd) - - case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c') - continue - case ('0') - ROVector(1) = 'ext_scalar' - case ('xzy') - ROVector(2) = Vector(3) - ROVector(3) = Vector(2) - case ('yxz') - ROVector(1) = Vector(2) - ROVector(2) = Vector(1) - case ('yzx') - ROVector(1) = Vector(3) - ROVector(2) = Vector(1) - ROVector(3) = Vector(2) - case ('zxy') - ROVector(1) = Vector(2) - ROVector(2) = Vector(3) - ROVector(3) = Vector(1) - case ('zyx') - ROVector(1) = Vector(3) - ROVector(3) = Vector(1) - case ('yx') - ROVector(1) = Vector(2) - ROVector(2) = Vector(1) - case default - Status = WRF_WARN_BAD_MEMORYORDER - return - end select - Status = WRF_NO_ERR - return -end subroutine ExtOrderStr - - -subroutine LowerCase(MemoryOrder,MemOrd) - character*(*) ,intent(in) :: MemoryOrder - character*(*) ,intent(out) :: MemOrd - character*1 :: c - integer ,parameter :: upper_to_lower =IACHAR('a')-IACHAR('A') - integer :: i,N - - MemOrd = ' ' - N = len(MemoryOrder) - MemOrd(1:N) = MemoryOrder(1:N) - do i=1,N - c = MemoryOrder(i:i) - if('A'<=c .and. c <='Z') MemOrd(i:i)=achar(iachar(c)+upper_to_lower) - enddo - return -end subroutine LowerCase - -subroutine UpperCase(MemoryOrder,MemOrd) - character*(*) ,intent(in) :: MemoryOrder - character*(*) ,intent(out) :: MemOrd - character*1 :: c - integer ,parameter :: lower_to_upper =IACHAR('A')-IACHAR('a') - integer :: i,N - - MemOrd = ' ' - N = len(MemoryOrder) - MemOrd(1:N) = MemoryOrder(1:N) - do i=1,N - c = MemoryOrder(i:i) - if('a'<=c .and. c <='z') MemOrd(i:i)=achar(iachar(c)+lower_to_upper) - enddo - return -end subroutine UpperCase - -subroutine netcdf_err(err,Status) - use wrf_data - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: err - integer ,intent(out) :: Status - character(len=80) :: errmsg - integer :: stat - - if( err==NF_NOERR )then - Status = WRF_NO_ERR - else - errmsg = NF_STRERROR(err) - write(msg,*) 'NetCDF error: ',errmsg - call wrf_debug ( WARN , TRIM(msg)) - Status = WRF_WARN_NETCDF - endif - return -end subroutine netcdf_err - -subroutine FieldIO(IO,DataHandle,DateStr,Length,MemoryOrder & - ,FieldType,NCID,VarID,XField,Status) - use wrf_data - include 'wrf_status_codes.h' - include 'netcdf.inc' - character (*) ,intent(in) :: IO - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: DateStr - integer,dimension(NVarDims),intent(in) :: Length - character*(*) ,intent(in) :: MemoryOrder - integer ,intent(in) :: FieldType - integer ,intent(in) :: NCID - integer ,intent(in) :: VarID - integer,dimension(*) ,intent(inout) :: XField - integer ,intent(out) :: Status - integer :: TimeIndex - integer :: NDim - integer,dimension(NVarDims) :: VStart - integer,dimension(NVarDims) :: VCount - - call GetTimeIndex(IO,DataHandle,DateStr,TimeIndex,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - write(msg,*) ' Bad time index for DateStr = ',DateStr - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call GetDim(MemoryOrder,NDim,Status) -VStart(:) = 1 -VCount(:) = 1 - VStart(1:NDim) = 1 - VCount(1:NDim) = Length(1:NDim) - VStart(NDim+1) = TimeIndex - VCount(NDim+1) = 1 - select case (FieldType) - case (WRF_REAL) - call ext_ncd_RealFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status) - case (WRF_DOUBLE) - call ext_ncd_DoubleFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status) - case (WRF_INTEGER) - call ext_ncd_IntFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status) - case (WRF_LOGICAL) - call ext_ncd_LogicalFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status) - if(Status /= WRF_NO_ERR) return - case default -!for wrf_complex, double_complex - Status = WRF_WARN_DATA_TYPE_NOT_FOUND - write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - end select - return -end subroutine FieldIO - -subroutine Transpose(IO,MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & - ,XField,x1,x2,y1,y2,z1,z2 & - ,i1,i2,j1,j2,k1,k2 ) - character*(*) ,intent(in) :: IO - character*(*) ,intent(in) :: MemoryOrder - integer ,intent(in) :: l1,l2,m1,m2,n1,n2 - integer ,intent(in) :: di - integer ,intent(in) :: x1,x2,y1,y2,z1,z2 - integer ,intent(in) :: i1,i2,j1,j2,k1,k2 - integer ,intent(inout) :: Field(di,l1:l2,m1:m2,n1:n2) -!jm 010827 integer ,intent(inout) :: XField(di,x1:x2,y1:y2,z1:z2) - integer ,intent(inout) :: XField(di,(i2-i1+1)*(j2-j1+1)*(k2-k1+1)) - character*3 :: MemOrd - character*3 :: MemO - integer ,parameter :: MaxUpperCase=IACHAR('Z') - integer :: i,j,k,ix,jx,kx - - call LowerCase(MemoryOrder,MemOrd) - select case (MemOrd) - -#define XDEX(A,B,C) A-A ## 1+1+(A ## 2-A ## 1+1)*((B-B ## 1)+(C-C ## 1)*(B ## 2-B ## 1+1)) -! define(`XDEX',($1-``$1''1+1+(``$1''2-``$1''1+1)*(($2-``$2''1)+($3-``$3''1)*(``$2''2-``$2''1+1)))) - - case ('xzy') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(i,k,j)) -#include "transpose.code" - case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c','0') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(i,j,k)) -#include "transpose.code" - case ('yxz') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(j,i,k)) -#include "transpose.code" - case ('zxy') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(k,i,j)) -#include "transpose.code" - case ('yzx') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(j,k,i)) -#include "transpose.code" - case ('zyx') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(k,j,i)) -#include "transpose.code" - case ('yx') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(j,i,k)) -#include "transpose.code" - end select - return -end subroutine Transpose - -subroutine reorder (MemoryOrder,MemO) - character*(*) ,intent(in) :: MemoryOrder - character*3 ,intent(out) :: MemO - character*3 :: MemOrd - integer :: N,i,i1,i2,i3 - - MemO = MemoryOrder - N = len_trim(MemoryOrder) - if(N == 1) return - call lowercase(MemoryOrder,MemOrd) -! never invert the boundary codes - select case ( MemOrd ) - case ( 'xsz','xez','ysz','yez' ) - return - case default - continue - end select - i1 = 1 - i3 = 1 - do i=2,N - if(ichar(MemOrd(i:i)) < ichar(MemOrd(i1:i1))) I1 = i - if(ichar(MemOrd(i:i)) > ichar(MemOrd(i3:i3))) I3 = i - enddo - if(N == 2) then - i2=i3 - else - i2 = 6-i1-i3 - endif - MemO(1:1) = MemoryOrder(i1:i1) - MemO(2:2) = MemoryOrder(i2:i2) - if(N == 3) MemO(3:3) = MemoryOrder(i3:i3) - if(MemOrd(i1:i1) == 's' .or. MemOrd(i1:i1) == 'e') then - MemO(1:N-1) = MemO(2:N) - MemO(N:N ) = MemoryOrder(i1:i1) - endif - return -end subroutine reorder - -! Returns .TRUE. iff it is OK to write time-independent domain metadata to the -! file referenced by DataHandle. If DataHandle is invalid, .FALSE. is -! returned. -LOGICAL FUNCTION ncd_ok_to_put_dom_ti( DataHandle ) - USE wrf_data - include 'wrf_status_codes.h' - INTEGER, INTENT(IN) :: DataHandle - CHARACTER*80 :: fname - INTEGER :: filestate - INTEGER :: Status - LOGICAL :: dryrun, first_output, retval - call ext_ncd_inquire_filename( DataHandle, fname, filestate, Status ) - IF ( Status /= WRF_NO_ERR ) THEN - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, & - ', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg) ) - retval = .FALSE. - ELSE - dryrun = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) - first_output = ncd_is_first_operation( DataHandle ) - retval = .NOT. dryrun .AND. first_output - ENDIF - ncd_ok_to_put_dom_ti = retval - RETURN -END FUNCTION ncd_ok_to_put_dom_ti - -! Returns .TRUE. iff it is OK to read time-independent domain metadata from the -! file referenced by DataHandle. If DataHandle is invalid, .FALSE. is -! returned. -LOGICAL FUNCTION ncd_ok_to_get_dom_ti( DataHandle ) - USE wrf_data - include 'wrf_status_codes.h' - INTEGER, INTENT(IN) :: DataHandle - CHARACTER*80 :: fname - INTEGER :: filestate - INTEGER :: Status - LOGICAL :: dryrun, retval - call ext_ncd_inquire_filename( DataHandle, fname, filestate, Status ) - IF ( Status /= WRF_NO_ERR ) THEN - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, & - ', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg) ) - retval = .FALSE. - ELSE - dryrun = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) - retval = .NOT. dryrun - ENDIF - ncd_ok_to_get_dom_ti = retval - RETURN -END FUNCTION ncd_ok_to_get_dom_ti - -! Returns .TRUE. iff nothing has been read from or written to the file -! referenced by DataHandle. If DataHandle is invalid, .FALSE. is returned. -LOGICAL FUNCTION ncd_is_first_operation( DataHandle ) - USE wrf_data - INCLUDE 'wrf_status_codes.h' - INTEGER, INTENT(IN) :: DataHandle - TYPE(wrf_data_handle) ,POINTER :: DH - INTEGER :: Status - LOGICAL :: retval - CALL GetDH( DataHandle, DH, Status ) - IF ( Status /= WRF_NO_ERR ) THEN - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, & - ', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg) ) - retval = .FALSE. - ELSE - retval = DH%first_operation - ENDIF - ncd_is_first_operation = retval - RETURN -END FUNCTION ncd_is_first_operation - -end module ext_ncd_support_routines - -subroutine ext_ncd_open_for_read(DatasetName, Comm1, Comm2, SysDepInfo, DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character *(*), INTENT(IN) :: DatasetName - integer , INTENT(IN) :: Comm1, Comm2 - character *(*), INTENT(IN) :: SysDepInfo - integer , INTENT(OUT) :: DataHandle - integer , INTENT(OUT) :: Status - DataHandle = 0 ! dummy setting to quiet warning message - CALL ext_ncd_open_for_read_begin( DatasetName, Comm1, Comm2, SysDepInfo, DataHandle, Status ) - IF ( Status .EQ. WRF_NO_ERR ) THEN - CALL ext_ncd_open_for_read_commit( DataHandle, Status ) - ENDIF - return -end subroutine ext_ncd_open_for_read - -!ends training phase; switches internal flag to enable input -!must be paired with call to ext_ncd_open_for_read_begin -subroutine ext_ncd_open_for_read_commit(DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer, intent(in) :: DataHandle - integer, intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - - if(WrfIOnotInitialized) then - Status = WRF_IO_NOT_INITIALIZED - write(msg,*) 'ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%FileStatus = WRF_FILE_OPENED_FOR_READ - DH%first_operation = .TRUE. - Status = WRF_NO_ERR - return -end subroutine ext_ncd_open_for_read_commit - -subroutine ext_ncd_open_for_read_begin( FileName, Comm, IOComm, SysDepInfo, DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character*(*) ,intent(IN) :: FileName - integer ,intent(IN) :: Comm - integer ,intent(IN) :: IOComm - character*(*) ,intent(in) :: SysDepInfo - integer ,intent(out) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XType - integer :: stat - integer ,allocatable :: Buffer(:) - integer :: VarID - integer :: StoredDim - integer :: NAtts - integer :: DimIDs(2) - integer :: VStart(2) - integer :: VLen(2) - integer :: TotalNumVars - integer :: NumVars - integer :: i - character (NF_MAX_NAME) :: Name - - if(WrfIOnotInitialized) then - Status = WRF_IO_NOT_INITIALIZED - write(msg,*) 'ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - call allocHandle(DataHandle,DH,Comm,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_OPEN(FileName, NF_NOWRITE, DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VARID(DH%NCID,DH%TimesName,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VAR(DH%NCID,VarID,DH%TimesName, XType, StoredDim, DimIDs, NAtts) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(XType/=NF_CHAR) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(1),VLen(1)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(VLen(1) /= DateStrLen) then - Status = WRF_WARN_DATESTR_BAD_LENGTH - write(msg,*) 'Warning DATESTR BAD LENGTH in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(2),VLen(2)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(VLen(2) > MaxTimes) then - Status = WRF_ERR_FATAL_TOO_MANY_TIMES - write(msg,*) 'Fatal TOO MANY TIME VALUES in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - VStart(1) = 1 - VStart(2) = 1 - stat = NF_GET_VARA_TEXT(DH%NCID,VarID,VStart,VLen,DH%Times) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_NVARS(DH%NCID,TotalNumVars) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - NumVars = 0 - do i=1,TotalNumVars - stat = NF_INQ_VARNAME(DH%NCID,i,Name) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(Name(1:5) /= 'md___' .and. Name /= DH%TimesName) then - NumVars = NumVars+1 - DH%VarNames(NumVars) = Name - DH%VarIDs(NumVars) = i - endif - enddo - DH%NumVars = NumVars - DH%NumberTimes = VLen(2) - DH%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED - DH%FileName = FileName - DH%CurrentVariable = 0 - DH%CurrentTime = 0 - DH%TimesVarID = VarID - DH%TimeIndex = 0 - return -end subroutine ext_ncd_open_for_read_begin - -subroutine ext_ncd_open_for_update( FileName, Comm, IOComm, SysDepInfo, DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character*(*) ,intent(IN) :: FileName - integer ,intent(IN) :: Comm - integer ,intent(IN) :: IOComm - character*(*) ,intent(in) :: SysDepInfo - integer ,intent(out) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XType - integer :: stat - integer ,allocatable :: Buffer(:) - integer :: VarID - integer :: StoredDim - integer :: NAtts - integer :: DimIDs(2) - integer :: VStart(2) - integer :: VLen(2) - integer :: TotalNumVars - integer :: NumVars - integer :: i - character (NF_MAX_NAME) :: Name - - if(WrfIOnotInitialized) then - Status = WRF_IO_NOT_INITIALIZED - write(msg,*) 'ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - call allocHandle(DataHandle,DH,Comm,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_OPEN(FileName, NF_WRITE, DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VARID(DH%NCID,DH%TimesName,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VAR(DH%NCID,VarID,DH%TimesName, XType, StoredDim, DimIDs, NAtts) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(XType/=NF_CHAR) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(1),VLen(1)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(VLen(1) /= DateStrLen) then - Status = WRF_WARN_DATESTR_BAD_LENGTH - write(msg,*) 'Warning DATESTR BAD LENGTH in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(2),VLen(2)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(VLen(2) > MaxTimes) then - Status = WRF_ERR_FATAL_TOO_MANY_TIMES - write(msg,*) 'Fatal TOO MANY TIME VALUES in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - VStart(1) = 1 - VStart(2) = 1 - stat = NF_GET_VARA_TEXT(DH%NCID,VarID,VStart,VLen,DH%Times) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_NVARS(DH%NCID,TotalNumVars) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - NumVars = 0 - do i=1,TotalNumVars - stat = NF_INQ_VARNAME(DH%NCID,i,Name) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(Name(1:5) /= 'md___' .and. Name /= DH%TimesName) then - NumVars = NumVars+1 - DH%VarNames(NumVars) = Name - DH%VarIDs(NumVars) = i - endif - enddo - DH%NumVars = NumVars - DH%NumberTimes = VLen(2) - DH%FileStatus = WRF_FILE_OPENED_FOR_UPDATE - DH%FileName = FileName - DH%CurrentVariable = 0 - DH%CurrentTime = 0 - DH%TimesVarID = VarID - DH%TimeIndex = 0 - return -end subroutine ext_ncd_open_for_update - - -SUBROUTINE ext_ncd_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,DataHandle,Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character*(*) ,intent(in) :: FileName - integer ,intent(in) :: Comm - integer ,intent(in) :: IOComm - character*(*) ,intent(in) :: SysDepInfo - integer ,intent(out) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: i - integer :: stat - character (7) :: Buffer - integer :: VDimIDs(2) - - if(WrfIOnotInitialized) then - Status = WRF_IO_NOT_INITIALIZED - write(msg,*) 'ext_ncd_open_for_write_begin: ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - call allocHandle(DataHandle,DH,Comm,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Fatal ALLOCATION ERROR in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - DH%TimeIndex = 0 - DH%Times = ZeroDate - stat = NF_CREATE(FileName, NF_CLOBBER, DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED - DH%FileName = FileName - stat = NF_DEF_DIM(DH%NCID,DH%DimUnlimName,NF_UNLIMITED,DH%DimUnlimID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%VarNames (1:MaxVars) = NO_NAME - DH%MDVarNames(1:MaxVars) = NO_NAME - do i=1,MaxDims - write(Buffer,FMT="('DIM',i4.4)") i - DH%DimNames (i) = Buffer - DH%DimLengths(i) = NO_DIM - enddo - DH%DimNames(1) = 'DateStrLen' - stat = NF_DEF_DIM(DH%NCID,DH%DimNames(1),DateStrLen,DH%DimIDs(1)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - VDimIDs(1) = DH%DimIDs(1) - VDimIDs(2) = DH%DimUnlimID - stat = NF_DEF_VAR(DH%NCID,DH%TimesName,NF_CHAR,2,VDimIDs,DH%TimesVarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%DimLengths(1) = DateStrLen - return -end subroutine ext_ncd_open_for_write_begin - -!stub -!opens a file for writing or coupler datastream for sending messages. -!no training phase for this version of the open stmt. -subroutine ext_ncd_open_for_write (DatasetName, Comm1, Comm2, & - SysDepInfo, DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character *(*), intent(in) ::DatasetName - integer , intent(in) ::Comm1, Comm2 - character *(*), intent(in) ::SysDepInfo - integer , intent(out) :: DataHandle - integer , intent(out) :: Status - Status=WRF_WARN_NOOP - DataHandle = 0 ! dummy setting to quiet warning message - return -end subroutine ext_ncd_open_for_write - -SUBROUTINE ext_ncd_open_for_write_commit(DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: i - integer :: stat - - if(WrfIOnotInitialized) then - Status = WRF_IO_NOT_INITIALIZED - write(msg,*) 'ext_ncd_open_for_write_commit: ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ext_ncd_open_for_write_commit ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_ENDDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_open_for_write_commit ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%FileStatus = WRF_FILE_OPENED_FOR_WRITE - DH%first_operation = .TRUE. - return -end subroutine ext_ncd_open_for_write_commit - -subroutine ext_ncd_ioclose(DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: stat - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ext_ncd_ioclose ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ext_ncd_ioclose ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_CLOSE - write(msg,*) 'Warning TRY TO CLOSE DRYRUN in ext_ncd_ioclose ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - continue - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - continue - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - continue - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ext_ncd_ioclose ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - - stat = NF_CLOSE(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_ioclose ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - CALL deallocHandle( DataHandle, Status ) - DH%Free=.true. - return -end subroutine ext_ncd_ioclose - -subroutine ext_ncd_iosync( DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: stat - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ext_ncd_iosync ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ext_ncd_iosync ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_FILE_NOT_COMMITTED - write(msg,*) 'Warning FILE NOT COMMITTED in ext_ncd_iosync ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - continue - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - continue - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ext_ncd_iosync ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - stat = NF_SYNC(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_iosync ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - return -end subroutine ext_ncd_iosync - - - -subroutine ext_ncd_redef( DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: stat - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_FILE_NOT_COMMITTED - write(msg,*) 'Warning FILE NOT COMMITTED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - continue - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_FILE_OPEN_FOR_READ - write(msg,*) 'Warning FILE OPEN FOR READ in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - stat = NF_REDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED - return -end subroutine ext_ncd_redef - -subroutine ext_ncd_enddef( DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: stat - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_FILE_NOT_COMMITTED - write(msg,*) 'Warning FILE NOT COMMITTED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - continue - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_FILE_OPEN_FOR_READ - write(msg,*) 'Warning FILE OPEN FOR READ in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - stat = NF_ENDDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%FileStatus = WRF_FILE_OPENED_FOR_WRITE - return -end subroutine ext_ncd_enddef - -subroutine ext_ncd_ioinit(SysDepInfo, Status) - use wrf_data - implicit none - include 'wrf_status_codes.h' - CHARACTER*(*), INTENT(IN) :: SysDepInfo - INTEGER ,INTENT(INOUT) :: Status - - WrfIOnotInitialized = .false. - WrfDataHandles(1:WrfDataHandleMax)%Free = .true. - WrfDataHandles(1:WrfDataHandleMax)%TimesName = 'Times' - WrfDataHandles(1:WrfDataHandleMax)%DimUnlimName = 'Time' - WrfDataHandles(1:WrfDataHandleMax)%FileStatus = WRF_FILE_NOT_OPENED - Status = WRF_NO_ERR - return -end subroutine ext_ncd_ioinit - - -subroutine ext_ncd_inquiry (Inquiry, Result, Status) - use wrf_data - implicit none - include 'wrf_status_codes.h' - character *(*), INTENT(IN) :: Inquiry - character *(*), INTENT(OUT) :: Result - integer ,INTENT(INOUT) :: Status - SELECT CASE (Inquiry) - CASE ("RANDOM_WRITE","RANDOM_READ","SEQUENTIAL_WRITE","SEQUENTIAL_READ") - Result='ALLOW' - CASE ("OPEN_READ","OPEN_COMMIT_WRITE") - Result='REQUIRE' - CASE ("OPEN_WRITE","OPEN_COMMIT_READ","PARALLEL_IO") - Result='NO' - CASE ("SELF_DESCRIBING","SUPPORT_METADATA","SUPPORT_3D_FIELDS") - Result='YES' - CASE ("MEDIUM") - Result ='FILE' - CASE DEFAULT - Result = 'No Result for that inquiry!' - END SELECT - Status=WRF_NO_ERR - return -end subroutine ext_ncd_inquiry - - - - -subroutine ext_ncd_ioexit(Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer , INTENT(INOUT) ::Status - integer :: error - type(wrf_data_handle),pointer :: DH - integer :: i - integer :: stat - if(WrfIOnotInitialized) then - Status = WRF_IO_NOT_INITIALIZED - write(msg,*) 'ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - do i=1,WrfDataHandleMax - CALL deallocHandle( i , stat ) - enddo - return -end subroutine ext_ncd_ioexit - -subroutine ext_ncd_get_dom_ti_real(DataHandle,Element,Data,Count,OutCount,Status) -#define ROUTINE_TYPE 'REAL' -#define TYPE_DATA real,intent(out) :: Data(*) -#define TYPE_COUNT integer,intent(in) :: Count -#define TYPE_OUTCOUNT integer,intent(out) :: OutCOunt -#define TYPE_BUFFER real,allocatable :: Buffer(:) -#define NF_TYPE NF_FLOAT -#define NF_ROUTINE NF_GET_ATT_REAL -#define COPY Data(1:min(Len,Count)) = Buffer(1:min(Len,Count)) -#include "ext_ncd_get_dom_ti.code" -end subroutine ext_ncd_get_dom_ti_real - -subroutine ext_ncd_get_dom_ti_integer(DataHandle,Element,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef NF_TYPE -#undef NF_ROUTINE -#undef COPY -#define ROUTINE_TYPE 'INTEGER' -#define TYPE_DATA integer,intent(out) :: Data(*) -#define TYPE_BUFFER integer,allocatable :: Buffer(:) -#define NF_TYPE NF_INT -#define NF_ROUTINE NF_GET_ATT_INT -#define COPY Data(1:min(Len,Count)) = Buffer(1:min(Len,Count)) -#include "ext_ncd_get_dom_ti.code" -end subroutine ext_ncd_get_dom_ti_integer - -subroutine ext_ncd_get_dom_ti_double(DataHandle,Element,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef NF_TYPE -#undef NF_ROUTINE -#undef COPY -#define ROUTINE_TYPE 'DOUBLE' -#define TYPE_DATA real*8,intent(out) :: Data(*) -#define TYPE_BUFFER real*8,allocatable :: Buffer(:) -#define NF_TYPE NF_DOUBLE -#define NF_ROUTINE NF_GET_ATT_DOUBLE -#define COPY Data(1:min(Len,Count)) = Buffer(1:min(Len,Count)) -#include "ext_ncd_get_dom_ti.code" -end subroutine ext_ncd_get_dom_ti_double - -subroutine ext_ncd_get_dom_ti_logical(DataHandle,Element,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef NF_TYPE -#undef NF_ROUTINE -#undef COPY -#define ROUTINE_TYPE 'LOGICAL' -#define TYPE_DATA logical,intent(out) :: Data(*) -#define TYPE_BUFFER integer,allocatable :: Buffer(:) -#define NF_TYPE NF_INT -#define NF_ROUTINE NF_GET_ATT_INT -#define COPY Data(1:min(Len,Count)) = Buffer(1:min(Len,Count))==1 -#include "ext_ncd_get_dom_ti.code" -end subroutine ext_ncd_get_dom_ti_logical - -subroutine ext_ncd_get_dom_ti_char(DataHandle,Element,Data,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef TYPE_BUFFER -#undef NF_TYPE -#define ROUTINE_TYPE 'CHAR' -#define TYPE_DATA character*(*),intent(out) :: Data -#define TYPE_COUNT -#define TYPE_OUTCOUNT -#define TYPE_BUFFER -#define NF_TYPE NF_CHAR -#define CHAR_TYPE -#include "ext_ncd_get_dom_ti.code" -#undef CHAR_TYPE -end subroutine ext_ncd_get_dom_ti_char - -subroutine ext_ncd_put_dom_ti_real(DataHandle,Element,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef ARGS -#undef LOG -#define ROUTINE_TYPE 'REAL' -#define TYPE_DATA real ,intent(in) :: Data(*) -#define TYPE_COUNT integer,intent(in) :: Count -#define NF_ROUTINE NF_PUT_ATT_REAL -#define ARGS NF_FLOAT,Count,Data -#include "ext_ncd_put_dom_ti.code" -end subroutine ext_ncd_put_dom_ti_real - -subroutine ext_ncd_put_dom_ti_integer(DataHandle,Element,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef ARGS -#undef LOG -#define ROUTINE_TYPE 'INTEGER' -#define TYPE_DATA integer,intent(in) :: Data(*) -#define TYPE_COUNT integer,intent(in) :: Count -#define NF_ROUTINE NF_PUT_ATT_INT -#define ARGS NF_INT,Count,Data -#include "ext_ncd_put_dom_ti.code" -end subroutine ext_ncd_put_dom_ti_integer - -subroutine ext_ncd_put_dom_ti_double(DataHandle,Element,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef ARGS -#undef LOG -#define ROUTINE_TYPE 'DOUBLE' -#define TYPE_DATA real*8 ,intent(in) :: Data(*) -#define TYPE_COUNT integer,intent(in) :: Count -#define NF_ROUTINE NF_PUT_ATT_DOUBLE -#define ARGS NF_DOUBLE,Count,Data -#include "ext_ncd_put_dom_ti.code" -end subroutine ext_ncd_put_dom_ti_double - -subroutine ext_ncd_put_dom_ti_logical(DataHandle,Element,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef ARGS -#define ROUTINE_TYPE 'LOGICAL' -#define TYPE_DATA logical,intent(in) :: Data(*) -#define TYPE_COUNT integer,intent(in) :: Count -#define NF_ROUTINE NF_PUT_ATT_INT -#define ARGS NF_INT,Count,Buffer -#define LOG -#include "ext_ncd_put_dom_ti.code" -end subroutine ext_ncd_put_dom_ti_logical - -subroutine ext_ncd_put_dom_ti_char(DataHandle,Element,Data,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef ARGS -#undef LOG -#define ROUTINE_TYPE 'CHAR' -#define TYPE_DATA character*(*),intent(in) :: Data -#define TYPE_COUNT integer,parameter :: Count=1 -#define NF_ROUTINE NF_PUT_ATT_TEXT -#define ARGS len_trim(Data),Data -#include "ext_ncd_put_dom_ti.code" -end subroutine ext_ncd_put_dom_ti_char - -subroutine ext_ncd_put_var_ti_real(DataHandle,Element,Var,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef ARGS -#undef LOG -#define ROUTINE_TYPE 'REAL' -#define TYPE_DATA real ,intent(in) :: Data(*) -#define TYPE_COUNT integer ,intent(in) :: Count -#define NF_ROUTINE NF_PUT_ATT_REAL -#define ARGS NF_FLOAT,Count,Data -#include "ext_ncd_put_var_ti.code" -end subroutine ext_ncd_put_var_ti_real - -subroutine ext_ncd_put_var_td_real(DataHandle,Element,DateStr,Var,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef NF_TYPE -#undef LENGTH -#undef ARG -#undef LOG -#define ROUTINE_TYPE 'REAL' -#define TYPE_DATA real ,intent(in) :: Data(*) -#define TYPE_COUNT integer ,intent(in) :: Count -#define NF_ROUTINE NF_PUT_VARA_REAL -#define NF_TYPE NF_FLOAT -#define LENGTH Count -#define ARG -#include "ext_ncd_put_var_td.code" -end subroutine ext_ncd_put_var_td_real - -subroutine ext_ncd_put_var_ti_double(DataHandle,Element,Var,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef ARGS -#undef LOG -#define ROUTINE_TYPE 'DOUBLE' -#define TYPE_DATA real*8 ,intent(in) :: Data(*) -#define TYPE_COUNT integer ,intent(in) :: Count -#define NF_ROUTINE NF_PUT_ATT_DOUBLE -#define ARGS NF_DOUBLE,Count,Data -#include "ext_ncd_put_var_ti.code" -end subroutine ext_ncd_put_var_ti_double - -subroutine ext_ncd_put_var_td_double(DataHandle,Element,DateStr,Var,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef NF_TYPE -#undef LENGTH -#undef ARG -#undef LOG -#define ROUTINE_TYPE 'DOUBLE' -#define TYPE_DATA real*8,intent(in) :: Data(*) -#define TYPE_COUNT integer ,intent(in) :: Count -#define NF_ROUTINE NF_PUT_VARA_DOUBLE -#define NF_TYPE NF_DOUBLE -#define LENGTH Count -#define ARG -#include "ext_ncd_put_var_td.code" -end subroutine ext_ncd_put_var_td_double - -subroutine ext_ncd_put_var_ti_integer(DataHandle,Element,Var,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef ARGS -#undef LOG -#define ROUTINE_TYPE 'INTEGER' -#define TYPE_DATA integer ,intent(in) :: Data(*) -#define TYPE_COUNT integer ,intent(in) :: Count -#define NF_ROUTINE NF_PUT_ATT_INT -#define ARGS NF_INT,Count,Data -#include "ext_ncd_put_var_ti.code" -end subroutine ext_ncd_put_var_ti_integer - -subroutine ext_ncd_put_var_td_integer(DataHandle,Element,DateStr,Var,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef NF_TYPE -#undef LENGTH -#undef ARG -#undef LOG -#define ROUTINE_TYPE 'INTEGER' -#define TYPE_DATA integer ,intent(in) :: Data(*) -#define TYPE_COUNT integer ,intent(in) :: Count -#define NF_ROUTINE NF_PUT_VARA_INT -#define NF_TYPE NF_INT -#define LENGTH Count -#define ARG -#include "ext_ncd_put_var_td.code" -end subroutine ext_ncd_put_var_td_integer - -subroutine ext_ncd_put_var_ti_logical(DataHandle,Element,Var,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef ARGS -#define ROUTINE_TYPE 'LOGICAL' -#define TYPE_DATA logical ,intent(in) :: Data(*) -#define TYPE_COUNT integer ,intent(in) :: Count -#define NF_ROUTINE NF_PUT_ATT_INT -#define LOG -#define ARGS NF_INT,Count,Buffer -#include "ext_ncd_put_var_ti.code" -end subroutine ext_ncd_put_var_ti_logical - -subroutine ext_ncd_put_var_td_logical(DataHandle,Element,DateStr,Var,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef NF_TYPE -#undef LENGTH -#undef ARG -#define ROUTINE_TYPE 'LOGICAL' -#define TYPE_DATA logical ,intent(in) :: Data(*) -#define TYPE_COUNT integer ,intent(in) :: Count -#define NF_ROUTINE NF_PUT_VARA_INT -#define NF_TYPE NF_INT -#define LOG -#define LENGTH Count -#define ARG -#include "ext_ncd_put_var_td.code" -end subroutine ext_ncd_put_var_td_logical - -subroutine ext_ncd_put_var_ti_char(DataHandle,Element,Var,Data,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef ARGS -#undef LOG -#define ROUTINE_TYPE 'CHAR' -#define TYPE_DATA character*(*) ,intent(in) :: Data -#define TYPE_COUNT -#define NF_ROUTINE NF_PUT_ATT_TEXT -#define ARGS len_trim(Data),trim(Data) -#define CHAR_TYPE -#include "ext_ncd_put_var_ti.code" -#undef CHAR_TYPE -end subroutine ext_ncd_put_var_ti_char - -subroutine ext_ncd_put_var_td_char(DataHandle,Element,DateStr,Var,Data,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef NF_TYPE -#undef LENGTH -#undef ARG -#undef LOG -#define ROUTINE_TYPE 'CHAR' -#define TYPE_DATA character*(*) ,intent(in) :: Data -#define TYPE_COUNT -#define NF_ROUTINE NF_PUT_VARA_TEXT -#define NF_TYPE NF_CHAR -#define LENGTH len(Data) -#include "ext_ncd_put_var_td.code" -end subroutine ext_ncd_put_var_td_char - -subroutine ext_ncd_get_var_ti_real(DataHandle,Element,Var,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef NF_TYPE -#undef NF_ROUTINE -#undef COPY -#define ROUTINE_TYPE 'REAL' -#define TYPE_DATA real ,intent(out) :: Data(*) -#define TYPE_BUFFER real ,allocatable :: Buffer(:) -#define TYPE_COUNT integer,intent(in) :: Count -#define TYPE_OUTCOUNT integer,intent(out) :: OutCount -#define NF_TYPE NF_FLOAT -#define NF_ROUTINE NF_GET_ATT_REAL -#define COPY Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count)) -#include "ext_ncd_get_var_ti.code" -end subroutine ext_ncd_get_var_ti_real - -subroutine ext_ncd_get_var_td_real(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef NF_TYPE -#undef NF_ROUTINE -#undef LENGTH -#undef COPY -#define ROUTINE_TYPE 'REAL' -#define TYPE_DATA real ,intent(out) :: Data(*) -#define TYPE_BUFFER real -#define TYPE_COUNT integer,intent(in) :: Count -#define TYPE_OUTCOUNT integer,intent(out) :: OutCount -#define NF_TYPE NF_FLOAT -#define NF_ROUTINE NF_GET_VARA_REAL -#define LENGTH min(Count,Len1) -#define COPY Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count)) -#include "ext_ncd_get_var_td.code" -end subroutine ext_ncd_get_var_td_real - -subroutine ext_ncd_get_var_ti_double(DataHandle,Element,Var,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef NF_TYPE -#undef NF_ROUTINE -#undef COPY -#define ROUTINE_TYPE 'DOUBLE' -#define TYPE_DATA real*8 ,intent(out) :: Data(*) -#define TYPE_BUFFER real*8 ,allocatable :: Buffer(:) -#define TYPE_COUNT integer,intent(in) :: Count -#define TYPE_OUTCOUNT integer,intent(out) :: OutCount -#define NF_TYPE NF_DOUBLE -#define NF_ROUTINE NF_GET_ATT_DOUBLE -#define COPY Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count)) -#include "ext_ncd_get_var_ti.code" -end subroutine ext_ncd_get_var_ti_double - -subroutine ext_ncd_get_var_td_double(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef NF_TYPE -#undef NF_ROUTINE -#undef LENGTH -#undef COPY -#define ROUTINE_TYPE 'DOUBLE' -#define TYPE_DATA real*8 ,intent(out) :: Data(*) -#define TYPE_BUFFER real*8 -#define TYPE_COUNT integer,intent(in) :: Count -#define TYPE_OUTCOUNT integer,intent(out) :: OutCount -#define NF_TYPE NF_DOUBLE -#define NF_ROUTINE NF_GET_VARA_DOUBLE -#define LENGTH min(Count,Len1) -#define COPY Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count)) -#include "ext_ncd_get_var_td.code" -end subroutine ext_ncd_get_var_td_double - -subroutine ext_ncd_get_var_ti_integer(DataHandle,Element,Var,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef NF_TYPE -#undef NF_ROUTINE -#undef COPY -#define ROUTINE_TYPE 'INTEGER' -#define TYPE_DATA integer,intent(out) :: Data(*) -#define TYPE_BUFFER integer,allocatable :: Buffer(:) -#define TYPE_COUNT integer,intent(in) :: Count -#define TYPE_OUTCOUNT integer,intent(out) :: OutCount -#define NF_TYPE NF_INT -#define NF_ROUTINE NF_GET_ATT_INT -#define COPY Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count)) -#include "ext_ncd_get_var_ti.code" -end subroutine ext_ncd_get_var_ti_integer - -subroutine ext_ncd_get_var_td_integer(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef NF_TYPE -#undef NF_ROUTINE -#undef LENGTH -#undef COPY -#define ROUTINE_TYPE 'INTEGER' -#define TYPE_DATA integer,intent(out) :: Data(*) -#define TYPE_BUFFER integer -#define TYPE_COUNT integer,intent(in) :: Count -#define TYPE_OUTCOUNT integer,intent(out) :: OutCount -#define NF_TYPE NF_INT -#define NF_ROUTINE NF_GET_VARA_INT -#define LENGTH min(Count,Len1) -#define COPY Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count)) -#include "ext_ncd_get_var_td.code" -end subroutine ext_ncd_get_var_td_integer - -subroutine ext_ncd_get_var_ti_logical(DataHandle,Element,Var,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef NF_TYPE -#undef NF_ROUTINE -#undef COPY -#define ROUTINE_TYPE 'LOGICAL' -#define TYPE_DATA logical,intent(out) :: Data(*) -#define TYPE_BUFFER integer,allocatable :: Buffer(:) -#define TYPE_COUNT integer,intent(in) :: Count -#define TYPE_OUTCOUNT integer,intent(out) :: OutCount -#define NF_TYPE NF_INT -#define NF_ROUTINE NF_GET_ATT_INT -#define COPY Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count))==1 -#include "ext_ncd_get_var_ti.code" -end subroutine ext_ncd_get_var_ti_logical - -subroutine ext_ncd_get_var_td_logical(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef NF_TYPE -#undef NF_ROUTINE -#undef LENGTH -#undef COPY -#define ROUTINE_TYPE 'LOGICAL' -#define TYPE_DATA logical,intent(out) :: Data(*) -#define TYPE_BUFFER integer -#define TYPE_COUNT integer,intent(in) :: Count -#define TYPE_OUTCOUNT integer,intent(out) :: OutCount -#define NF_TYPE NF_INT -#define NF_ROUTINE NF_GET_VARA_INT -#define LENGTH min(Count,Len1) -#define COPY Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count))==1 -#include "ext_ncd_get_var_td.code" -end subroutine ext_ncd_get_var_td_logical - -subroutine ext_ncd_get_var_ti_char(DataHandle,Element,Var,Data,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef NF_TYPE -#undef NF_ROUTINE -#undef COPY -#define ROUTINE_TYPE 'CHAR' -#define TYPE_DATA character*(*) ,intent(out) :: Data -#define TYPE_BUFFER -#define TYPE_COUNT integer :: Count = 1 -#define TYPE_OUTCOUNT -#define NF_TYPE NF_CHAR -#define NF_ROUTINE NF_GET_ATT_TEXT -#define COPY -#define CHAR_TYPE -#include "ext_ncd_get_var_ti.code" -#undef CHAR_TYPE -end subroutine ext_ncd_get_var_ti_char - -subroutine ext_ncd_get_var_td_char(DataHandle,Element,DateStr,Var,Data,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef NF_TYPE -#undef NF_ROUTINE -#undef LENGTH -#define ROUTINE_TYPE 'CHAR' -#define TYPE_DATA character*(*) ,intent(out) :: Data -#define TYPE_BUFFER character (80) -#define TYPE_COUNT integer :: Count = 1 -#define TYPE_OUTCOUNT -#define NF_TYPE NF_CHAR -#define NF_ROUTINE NF_GET_VARA_TEXT -#define LENGTH Len1 -#define CHAR_TYPE -#include "ext_ncd_get_var_td.code" -#undef CHAR_TYPE -end subroutine ext_ncd_get_var_td_char - -subroutine ext_ncd_put_dom_td_real(DataHandle,Element,DateStr,Data,Count,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - real ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - - call ext_ncd_put_var_td_real(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) - return -end subroutine ext_ncd_put_dom_td_real - -subroutine ext_ncd_put_dom_td_integer(DataHandle,Element,DateStr,Data,Count,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - integer ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - - call ext_ncd_put_var_td_integer(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) - return -end subroutine ext_ncd_put_dom_td_integer - -subroutine ext_ncd_put_dom_td_double(DataHandle,Element,DateStr,Data,Count,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - real*8 ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - - call ext_ncd_put_var_td_double(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) - return -end subroutine ext_ncd_put_dom_td_double - -subroutine ext_ncd_put_dom_td_logical(DataHandle,Element,DateStr,Data,Count,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - logical ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - - call ext_ncd_put_var_td_logical(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) - return -end subroutine ext_ncd_put_dom_td_logical - -subroutine ext_ncd_put_dom_td_char(DataHandle,Element,DateStr,Data,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(in) :: Data - integer ,intent(out) :: Status - - call ext_ncd_put_var_td_char(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Status) - return -end subroutine ext_ncd_put_dom_td_char - -subroutine ext_ncd_get_dom_td_real(DataHandle,Element,DateStr,Data,Count,OutCount,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - real ,intent(out) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: OutCount - integer ,intent(out) :: Status - call ext_ncd_get_var_td_real(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) - return -end subroutine ext_ncd_get_dom_td_real - -subroutine ext_ncd_get_dom_td_integer(DataHandle,Element,DateStr,Data,Count,OutCount,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - integer ,intent(out) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: OutCount - integer ,intent(out) :: Status - call ext_ncd_get_var_td_integer(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) - return -end subroutine ext_ncd_get_dom_td_integer - -subroutine ext_ncd_get_dom_td_double(DataHandle,Element,DateStr,Data,Count,OutCount,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - real*8 ,intent(out) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: OutCount - integer ,intent(out) :: Status - call ext_ncd_get_var_td_double(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) - return -end subroutine ext_ncd_get_dom_td_double - -subroutine ext_ncd_get_dom_td_logical(DataHandle,Element,DateStr,Data,Count,OutCount,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - logical ,intent(out) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: OutCount - integer ,intent(out) :: Status - call ext_ncd_get_var_td_logical(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) - return -end subroutine ext_ncd_get_dom_td_logical - -subroutine ext_ncd_get_dom_td_char(DataHandle,Element,DateStr,Data,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(out) :: Data - integer ,intent(out) :: Status - call ext_ncd_get_var_td_char(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Status) - return -end subroutine ext_ncd_get_dom_td_char - - -subroutine ext_ncd_write_field(DataHandle,DateStr,Var,Field,FieldType,Comm, & - IOComm, DomainDesc, MemoryOrdIn, Stagger, DimNames, & - DomainStart,DomainEnd,MemoryStart,MemoryEnd,PatchStart,PatchEnd,Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(in) :: Var - integer ,intent(inout) :: Field(*) - integer ,intent(in) :: FieldType - integer ,intent(inout) :: Comm - integer ,intent(inout) :: IOComm - integer ,intent(in) :: DomainDesc - character*(*) ,intent(in) :: MemoryOrdIn - character*(*) ,intent(in) :: Stagger ! Dummy for now - character*(*) ,dimension(*) ,intent(in) :: DimNames - integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd - integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd - integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd - integer ,intent(out) :: Status - character (3) :: MemoryOrder - type(wrf_data_handle) ,pointer :: DH - integer :: NCID - integer :: NDim - character (VarNameLen) :: VarName - character (3) :: MemO - character (3) :: UCMemO - integer :: VarID - integer ,dimension(NVarDims) :: Length - integer ,dimension(NVarDims) :: VDimIDs - character(80),dimension(NVarDims) :: RODimNames - integer ,dimension(NVarDims) :: StoredStart - integer ,dimension(:,:,:,:),allocatable :: XField - integer :: stat - integer :: NVar - integer :: i,j - integer :: i1,i2,j1,j2,k1,k2 - integer :: x1,x2,y1,y2,z1,z2 - integer :: l1,l2,m1,m2,n1,n2 - integer :: XType - integer :: di - character (80) :: NullName - logical :: NotFound - - MemoryOrder = trim(adjustl(MemoryOrdIn)) - NullName=char(0) - call GetDim(MemoryOrder,NDim,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning BAD MEMORY ORDER |',MemoryOrder,'| in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning DATE STRING ERROR |',DateStr,'| in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - NCID = DH%NCID - - write(msg,*)'ext_ncd_write_field: called for ',TRIM(Var) - -!jm 010827 Length(1:NDim) = DomainEnd(1:NDim)-DomainStart(1:NDim)+1 - - Length(1:NDim) = PatchEnd(1:NDim)-PatchStart(1:NDim)+1 - - call ExtOrder(MemoryOrder,Length,Status) - call ExtOrderStr(MemoryOrder,DimNames,RODimNames,Status) - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - do NVar=1,MaxVars - if(DH%VarNames(NVar) == VarName ) then - Status = WRF_WARN_2DRYRUNS_1VARIABLE - write(msg,*) 'Warning 2 DRYRUNS 1 VARIABLE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(DH%VarNames(NVar) == NO_NAME) then - DH%VarNames(NVar) = VarName - DH%NumVars = NVar - exit - elseif(NVar == MaxVars) then - Status = WRF_WARN_TOO_MANY_VARIABLES - write(msg,*) 'Warning TOO MANY VARIABLES in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - do j = 1,NDim - if(RODimNames(j) == NullName .or. RODimNames(j) == '') then - do i=1,MaxDims - if(DH%DimLengths(i) == Length(j)) then - exit - elseif(DH%DimLengths(i) == NO_DIM) then - stat = NF_DEF_DIM(NCID,DH%DimNames(i),Length(j),DH%DimIDs(i)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%DimLengths(i) = Length(j) - exit - elseif(i == MaxDims) then - Status = WRF_WARN_TOO_MANY_DIMS - write(msg,*) 'Warning TOO MANY DIMENSIONS in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - else !look for input name and check if already defined - NotFound = .true. - do i=1,MaxDims - if (DH%DimNames(i) == RODimNames(j)) then - if (DH%DimLengths(i) == Length(j)) then - NotFound = .false. - exit - else - Status = WRF_WARN_DIMNAME_REDEFINED - write(msg,*) 'Warning DIM ',i,', NAME ',TRIM(DH%DimNames(i)),' REDIFINED by var ', & - TRIM(Var),' ',DH%DimLengths(i),Length(j) ,' in ', __FILE__ ,' line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - endif - enddo - if (NotFound) then - do i=1,MaxDims - if (DH%DimLengths(i) == NO_DIM) then - DH%DimNames(i) = RODimNames(j) - stat = NF_DEF_DIM(NCID,DH%DimNames(i),Length(j),DH%DimIDs(i)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%DimLengths(i) = Length(j) - exit - elseif(i == MaxDims) then - Status = WRF_WARN_TOO_MANY_DIMS - write(msg,*) 'Warning TOO MANY DIMENSIONS in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - endif - endif - VDimIDs(j) = DH%DimIDs(i) - DH%VarDimLens(j,NVar) = Length(j) - enddo - VDimIDs(NDim+1) = DH%DimUnlimID - select case (FieldType) - case (WRF_REAL) - XType = NF_FLOAT - case (WRF_DOUBLE) - Xtype = NF_DOUBLE - case (WRF_INTEGER) - XType = NF_INT - case (WRF_LOGICAL) - XType = NF_INT - case default - Status = WRF_WARN_DATA_TYPE_NOT_FOUND - write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - end select - stat = NF_DEF_VAR(NCID,VarName,XType,NDim+1,VDimIDs,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'ext_ncd_write_field: NetCDF error for ',TRIM(VarName),' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%VarIDs(NVar) = VarID - stat = NF_PUT_ATT_INT(NCID,VarID,'FieldType',NF_INT,1,FieldType) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'ext_ncd_write_field: NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call reorder(MemoryOrder,MemO) - call uppercase(MemO,UCMemO) - stat = NF_PUT_ATT_TEXT(NCID,VarID,'MemoryOrder',3,UCMemO) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'ext_ncd_write_field: NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - do NVar=1,DH%NumVars - if(DH%VarNames(NVar) == VarName) then - exit - elseif(NVar == DH%NumVars) then - Status = WRF_WARN_VAR_NF - write(msg,*) 'Warning VARIABLE NOT FOUND in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - VarID = DH%VarIDs(NVar) - do j=1,NDim - if(Length(j) /= DH%VarDimLens(j,NVar) .AND. DH%FileStatus /= WRF_FILE_OPENED_FOR_UPDATE ) then - Status = WRF_WARN_WRTLEN_NE_DRRUNLEN - write(msg,*) 'Warning LENGTH != DRY RUN LENGTH for |', & - VarName,'| dim ',j,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - write(msg,*) ' LENGTH ',Length(j),' DRY RUN LENGTH ',DH%VarDimLens(j,NVar) - call wrf_debug ( WARN , TRIM(msg)) - return -!jm 010825 elseif(DomainStart(j) < MemoryStart(j)) then - elseif(PatchStart(j) < MemoryStart(j)) then - Status = WRF_WARN_DIMENSION_ERROR - write(msg,*) 'Warning DIMENSION ERROR for |',VarName, & - '| in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - StoredStart = 1 - call GetIndices(NDim,MemoryStart,MemoryEnd,l1,l2,m1,m2,n1,n2) - call GetIndices(NDim,StoredStart,Length ,x1,x2,y1,y2,z1,z2) - call GetIndices(NDim,PatchStart, PatchEnd ,i1,i2,j1,j2,k1,k2) - di=1 - if(FieldType == WRF_DOUBLE) di=2 - allocate(XField(di,x1:x2,y1:y2,z1:z2), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - call Transpose('write',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & - ,XField,x1,x2,y1,y2,z1,z2 & - ,i1,i2,j1,j2,k1,k2 ) - call FieldIO('write',DataHandle,DateStr,Length,MemoryOrder, & - FieldType,NCID,VarID,XField,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - deallocate(XField, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , TRIM(msg)) - endif - DH%first_operation = .FALSE. - return -end subroutine ext_ncd_write_field - -subroutine ext_ncd_read_field(DataHandle,DateStr,Var,Field,FieldType,Comm, & - IOComm, DomainDesc, MemoryOrdIn, Stagger, DimNames, & - DomainStart,DomainEnd,MemoryStart,MemoryEnd,PatchStart,PatchEnd,Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(in) :: Var - integer ,intent(out) :: Field(*) - integer ,intent(in) :: FieldType - integer ,intent(inout) :: Comm - integer ,intent(inout) :: IOComm - integer ,intent(in) :: DomainDesc - character*(*) ,intent(in) :: MemoryOrdIn - character*(*) ,intent(in) :: Stagger ! Dummy for now - character*(*) , dimension (*) ,intent(in) :: DimNames - integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd - integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd - integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd - integer ,intent(out) :: Status - character (3) :: MemoryOrder - type(wrf_data_handle) ,pointer :: DH - integer :: NDim - integer :: NCID - character (VarNameLen) :: VarName - integer :: VarID - integer ,dimension(NVarDims) :: VCount - integer ,dimension(NVarDims) :: VStart - integer ,dimension(NVarDims) :: Length - integer ,dimension(NVarDims) :: VDimIDs - integer ,dimension(NVarDims) :: MemS - integer ,dimension(NVarDims) :: MemE - integer ,dimension(NVarDims) :: StoredStart - integer ,dimension(NVarDims) :: StoredLen - integer ,dimension(:,:,:,:) ,allocatable :: XField - integer :: NVar - integer :: j - integer :: i1,i2,j1,j2,k1,k2 - integer :: x1,x2,y1,y2,z1,z2 - integer :: l1,l2,m1,m2,n1,n2 - character (VarNameLen) :: Name - integer :: XType - integer :: StoredDim - integer :: NAtts - integer :: Len - integer :: stat - integer :: di - integer :: FType - - MemoryOrder = trim(adjustl(MemoryOrdIn)) - call GetDim(MemoryOrder,NDim,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning BAD MEMORY ORDER |',TRIM(MemoryOrder),'| for |', & - TRIM(Var),'| in ext_ncd_read_field ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning DATE STRING ERROR |',TRIM(DateStr),'| for |',TRIM(Var), & - '| in ext_ncd_read_field ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ext_ncd_read_field ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then -! jm it is okay to have a dry run read. means read is called between ofrb and ofrc. Just return. -! Status = WRF_WARN_DRYRUN_READ -! write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ -! call wrf_debug ( WARN , TRIM(msg)) - Status = WRF_NO_ERR - RETURN - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE ) then - NCID = DH%NCID - -!jm Length(1:NDim) = DomainEnd(1:NDim)-DomainStart(1:NDim)+1 - Length(1:NDim) = PatchEnd(1:NDim)-PatchStart(1:NDim)+1 - call ExtOrder(MemoryOrder,Length,Status) - stat = NF_INQ_VARID(NCID,VarName,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Varname ',Varname - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VAR(NCID,VarID,Name,XType,StoredDim,VDimIDs,NAtts) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_GET_ATT_INT(NCID,VarID,'FieldType',FType) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif -! allow coercion between double and single prec real -!jm if(FieldType /= Ftype) then - if( (FieldType == WRF_REAL .OR. FieldType == WRF_DOUBLE) ) then - if ( .NOT. (Ftype == WRF_REAL .OR. Ftype == WRF_DOUBLE )) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - else if(FieldType /= Ftype) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - select case (FieldType) - case (WRF_REAL) -! allow coercion between double and single prec real - if(.NOT. (XType == NF_FLOAT .OR. XType == NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning REAL TYPE MISMATCH in ',__FILE__,', line', __LINE__ - endif - case (WRF_DOUBLE) -! allow coercion between double and single prec real - if(.NOT. (XType == NF_FLOAT .OR. XType == NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning DOUBLE TYPE MISMATCH in ',__FILE__,', line', __LINE__ - endif - case (WRF_INTEGER) - if(XType /= NF_INT) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning INTEGER TYPE MISMATCH in ',__FILE__,', line', __LINE__ - endif - case (WRF_LOGICAL) - if(XType /= NF_INT) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning LOGICAL TYPE MISMATCH in ',__FILE__,', line', __LINE__ - endif - case default - Status = WRF_WARN_DATA_TYPE_NOT_FOUND - write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ - end select - if(Status /= WRF_NO_ERR) then - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(StoredDim /= NDim+1) then - Status = WRF_ERR_FATAL_BAD_VARIABLE_DIM - write(msg,*) 'Fatal error BAD VARIABLE DIMENSION in ext_ncd_read_field ',TRIM(Var),TRIM(DateStr) - call wrf_debug ( FATAL , msg) - write(msg,*) ' StoredDim ', StoredDim, ' .NE. NDim+1 ', NDim+1 - call wrf_debug ( FATAL , msg) - return - endif - do j=1,NDim - stat = NF_INQ_DIMLEN(NCID,VDimIDs(j),StoredLen(j)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(Length(j) > StoredLen(j)) then - Status = WRF_WARN_READ_PAST_EOF - write(msg,*) 'Warning READ PAST EOF in ext_ncd_read_field of ',TRIM(Var),Length(j),'>',StoredLen(j) - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(Length(j) <= 0) then - Status = WRF_WARN_ZERO_LENGTH_READ - write(msg,*) 'Warning ZERO LENGTH READ in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(DomainStart(j) < MemoryStart(j)) then - Status = WRF_WARN_DIMENSION_ERROR - write(msg,*) 'Warning dim ',j,' DomainStart (',DomainStart(j), & - ') < MemoryStart (',MemoryStart(j),') in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) -! return - endif - enddo - - StoredStart = 1 - call GetIndices(NDim,MemoryStart,MemoryEnd,l1,l2,m1,m2,n1,n2) - call GetIndices(NDim,StoredStart,StoredLen,x1,x2,y1,y2,z1,z2) -!jm call GetIndices(NDim,DomainStart,DomainEnd,i1,i2,j1,j2,k1,k2) - call GetIndices(NDim,PatchStart,PatchEnd,i1,i2,j1,j2,k1,k2) - - di=1 - if(FieldType == WRF_DOUBLE) di=2 - allocate(XField(di,x1:x2,y1:y2,z1:z2), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - call FieldIO('read',DataHandle,DateStr,Length,MemoryOrder, & - FieldType,NCID,VarID,XField,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call Transpose('read',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & - ,XField,x1,x2,y1,y2,z1,z2 & - ,i1,i2,j1,j2,k1,k2 ) - deallocate(XField, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - endif - DH%first_operation = .FALSE. - return -end subroutine ext_ncd_read_field - -subroutine ext_ncd_inquire_opened( DataHandle, FileName , FileStatus, Status ) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: FileName - integer ,intent(out) :: FileStatus - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - FileStatus = WRF_FILE_NOT_OPENED - return - endif - if(FileName /= DH%FileName) then - FileStatus = WRF_FILE_NOT_OPENED - else - FileStatus = DH%FileStatus - endif - Status = WRF_NO_ERR - return -end subroutine ext_ncd_inquire_opened - -subroutine ext_ncd_inquire_filename( Datahandle, FileName, FileStatus, Status ) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(out) :: FileName - integer ,intent(out) :: FileStatus - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - FileStatus = WRF_FILE_NOT_OPENED - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - FileName = DH%FileName - FileStatus = DH%FileStatus - Status = WRF_NO_ERR - return -end subroutine ext_ncd_inquire_filename - -subroutine ext_ncd_set_time(DataHandle, DateStr, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: DateStr - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: i - - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_FILE_NOT_COMMITTED - write(msg,*) 'Warning FILE NOT COMMITTED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - do i=1,MaxTimes - if(DH%Times(i)==DateStr) then - DH%CurrentTime = i - exit - endif - if(i==MaxTimes) then - Status = WRF_WARN_TIME_NF - return - endif - enddo - DH%CurrentVariable = 0 - Status = WRF_NO_ERR - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_set_time - -subroutine ext_ncd_get_next_time(DataHandle, DateStr, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(out) :: DateStr - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE ) then - if(DH%CurrentTime >= DH%NumberTimes) then - Status = WRF_WARN_TIME_EOF - return - endif - DH%CurrentTime = DH%CurrentTime +1 - DateStr = DH%Times(DH%CurrentTime) - DH%CurrentVariable = 0 - Status = WRF_NO_ERR - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_get_next_time - -subroutine ext_ncd_get_previous_time(DataHandle, DateStr, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(out) :: DateStr - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - if(DH%CurrentTime.GT.0) then - DH%CurrentTime = DH%CurrentTime -1 - endif - DateStr = DH%Times(DH%CurrentTime) - DH%CurrentVariable = 0 - Status = WRF_NO_ERR - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_get_previous_time - -subroutine ext_ncd_get_next_var(DataHandle, VarName, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(out) :: VarName - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: stat - character (80) :: Name - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - - DH%CurrentVariable = DH%CurrentVariable +1 - if(DH%CurrentVariable > DH%NumVars) then - Status = WRF_WARN_VAR_EOF - return - endif - VarName = DH%VarNames(DH%CurrentVariable) - Status = WRF_NO_ERR - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_get_next_var - -subroutine ext_ncd_end_of_frame(DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - - call GetDH(DataHandle,DH,Status) - return -end subroutine ext_ncd_end_of_frame - -subroutine ext_ncd_get_var_info(DataHandle,Name,NDim,MemoryOrder,Stagger,DomainStart,DomainEnd,WrfType,Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Name - integer ,intent(out) :: NDim - character*(*) ,intent(out) :: MemoryOrder - character*(*) :: Stagger ! Dummy for now - integer ,dimension(*) ,intent(out) :: DomainStart, DomainEnd - integer ,intent(out) :: WrfType - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: VarID - integer ,dimension(NVarDims) :: VDimIDs - integer :: j - integer :: stat - integer :: XType - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - stat = NF_INQ_VARID(DH%NCID,Name,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VARTYPE(DH%NCID,VarID,XType) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_GET_ATT_INT(DH%NCID,VarID,'FieldType',WrfType) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - select case (XType) - case (NF_BYTE) - Status = WRF_WARN_BAD_DATA_TYPE - write(msg,*) 'Warning BYTE IS BAD DATA TYPE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - case (NF_CHAR) - Status = WRF_WARN_BAD_DATA_TYPE - write(msg,*) 'Warning CHAR IS BAD DATA TYPE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - case (NF_SHORT) - Status = WRF_WARN_BAD_DATA_TYPE - write(msg,*) 'Warning SHORT IS BAD DATA TYPE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - case (NF_INT) - if(WrfType /= WRF_INTEGER .and. WrfType /= WRF_LOGICAL) then - Status = WRF_WARN_BAD_DATA_TYPE - write(msg,*) 'Warning BAD DATA TYPE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - case (NF_FLOAT) - if(WrfType /= WRF_REAL) then - Status = WRF_WARN_BAD_DATA_TYPE - write(msg,*) 'Warning BAD DATA TYPE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - case (NF_DOUBLE) - if(WrfType /= WRF_DOUBLE) then - Status = WRF_WARN_BAD_DATA_TYPE - write(msg,*) 'Warning BAD DATA TYPE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - case default - Status = WRF_WARN_DATA_TYPE_NOT_FOUND - write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - end select - - stat = NF_GET_ATT_TEXT(DH%NCID,VarID,'MemoryOrder',MemoryOrder) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call GetDim(MemoryOrder,NDim,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning BAD MEMORY ORDER ',TRIM(MemoryOrder),' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VARDIMID(DH%NCID,VarID,VDimIDs) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - do j = 1, NDim - DomainStart(j) = 1 - stat = NF_INQ_DIMLEN(DH%NCID,VDimIDs(j),DomainEnd(j)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_get_var_info - -subroutine ext_ncd_warning_str( Code, ReturnString, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - - integer , intent(in) ::Code - character *(*), intent(out) :: ReturnString - integer, intent(out) ::Status - - SELECT CASE (Code) - CASE (0) - ReturnString='No error' - Status=WRF_NO_ERR - return - CASE (-1) - ReturnString= 'File not found (or file is incomplete)' - Status=WRF_NO_ERR - return - CASE (-2) - ReturnString='Metadata not found' - Status=WRF_NO_ERR - return - CASE (-3) - ReturnString= 'Timestamp not found' - Status=WRF_NO_ERR - return - CASE (-4) - ReturnString= 'No more timestamps' - Status=WRF_NO_ERR - return - CASE (-5) - ReturnString= 'Variable not found' - Status=WRF_NO_ERR - return - CASE (-6) - ReturnString= 'No more variables for the current time' - Status=WRF_NO_ERR - return - CASE (-7) - ReturnString= 'Too many open files' - Status=WRF_NO_ERR - return - CASE (-8) - ReturnString= 'Data type mismatch' - Status=WRF_NO_ERR - return - CASE (-9) - ReturnString= 'Attempt to write read-only file' - Status=WRF_NO_ERR - return - CASE (-10) - ReturnString= 'Attempt to read write-only file' - Status=WRF_NO_ERR - return - CASE (-11) - ReturnString= 'Attempt to access unopened file' - Status=WRF_NO_ERR - return - CASE (-12) - ReturnString= 'Attempt to do 2 trainings for 1 variable' - Status=WRF_NO_ERR - return - CASE (-13) - ReturnString= 'Attempt to read past EOF' - Status=WRF_NO_ERR - return - CASE (-14) - ReturnString= 'Bad data handle' - Status=WRF_NO_ERR - return - CASE (-15) - ReturnString= 'Write length not equal to training length' - Status=WRF_NO_ERR - return - CASE (-16) - ReturnString= 'More dimensions requested than training' - Status=WRF_NO_ERR - return - CASE (-17) - ReturnString= 'Attempt to read more data than exists' - Status=WRF_NO_ERR - return - CASE (-18) - ReturnString= 'Input dimensions inconsistent' - Status=WRF_NO_ERR - return - CASE (-19) - ReturnString= 'Input MemoryOrder not recognized' - Status=WRF_NO_ERR - return - CASE (-20) - ReturnString= 'A dimension name with 2 different lengths' - Status=WRF_NO_ERR - return - CASE (-21) - ReturnString= 'String longer than provided storage' - Status=WRF_NO_ERR - return - CASE (-22) - ReturnString= 'Function not supportable' - Status=WRF_NO_ERR - return - CASE (-23) - ReturnString= 'Package implements this routine as NOOP' - Status=WRF_NO_ERR - return - -!netcdf-specific warning messages - CASE (-1007) - ReturnString= 'Bad data type' - Status=WRF_NO_ERR - return - CASE (-1008) - ReturnString= 'File not committed' - Status=WRF_NO_ERR - return - CASE (-1009) - ReturnString= 'File is opened for reading' - Status=WRF_NO_ERR - return - CASE (-1011) - ReturnString= 'Attempt to write metadata after open commit' - Status=WRF_NO_ERR - return - CASE (-1010) - ReturnString= 'I/O not initialized' - Status=WRF_NO_ERR - return - CASE (-1012) - ReturnString= 'Too many variables requested' - Status=WRF_NO_ERR - return - CASE (-1013) - ReturnString= 'Attempt to close file during a dry run' - Status=WRF_NO_ERR - return - CASE (-1014) - ReturnString= 'Date string not 19 characters in length' - Status=WRF_NO_ERR - return - CASE (-1015) - ReturnString= 'Attempt to read zero length words' - Status=WRF_NO_ERR - return - CASE (-1016) - ReturnString= 'Data type not found' - Status=WRF_NO_ERR - return - CASE (-1017) - ReturnString= 'Badly formatted date string' - Status=WRF_NO_ERR - return - CASE (-1018) - ReturnString= 'Attempt at read during a dry run' - Status=WRF_NO_ERR - return - CASE (-1019) - ReturnString= 'Attempt to get zero words' - Status=WRF_NO_ERR - return - CASE (-1020) - ReturnString= 'Attempt to put zero length words' - Status=WRF_NO_ERR - return - CASE (-1021) - ReturnString= 'NetCDF error' - Status=WRF_NO_ERR - return - CASE (-1022) - ReturnString= 'Requested length <= 1' - Status=WRF_NO_ERR - return - CASE (-1023) - ReturnString= 'More data available than requested' - Status=WRF_NO_ERR - return - CASE (-1024) - ReturnString= 'New date less than previous date' - Status=WRF_NO_ERR - return - - CASE DEFAULT - ReturnString= 'This warning code is not supported or handled directly by WRF and NetCDF. & - & Might be an erroneous number, or specific to an i/o package other than NetCDF; you may need & - & to be calling a package-specific routine to return a message for this warning code.' - Status=WRF_NO_ERR - END SELECT - - return -end subroutine ext_ncd_warning_str - - -!returns message string for all WRF and netCDF warning/error status codes -!Other i/o packages must provide their own routines to return their own status messages -subroutine ext_ncd_error_str( Code, ReturnString, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - - integer , intent(in) ::Code - character *(*), intent(out) :: ReturnString - integer, intent(out) ::Status - - SELECT CASE (Code) - CASE (-100) - ReturnString= 'Allocation Error' - Status=WRF_NO_ERR - return - CASE (-101) - ReturnString= 'Deallocation Error' - Status=WRF_NO_ERR - return - CASE (-102) - ReturnString= 'Bad File Status' - Status=WRF_NO_ERR - return - CASE (-1004) - ReturnString= 'Variable on disk is not 3D' - Status=WRF_NO_ERR - return - CASE (-1005) - ReturnString= 'Metadata on disk is not 1D' - Status=WRF_NO_ERR - return - CASE (-1006) - ReturnString= 'Time dimension too small' - Status=WRF_NO_ERR - return - CASE DEFAULT - ReturnString= 'This error code is not supported or handled directly by WRF and NetCDF. & - & Might be an erroneous number, or specific to an i/o package other than NetCDF; you may need & - & to be calling a package-specific routine to return a message for this error code.' - Status=WRF_NO_ERR - END SELECT - - return -end subroutine ext_ncd_error_str diff --git a/src/fim/FIMsrc/post/wrfio/wrf_io_flags.h b/src/fim/FIMsrc/post/wrfio/wrf_io_flags.h deleted file mode 100644 index c36b6c2..0000000 --- a/src/fim/FIMsrc/post/wrfio/wrf_io_flags.h +++ /dev/null @@ -1,14 +0,0 @@ - integer, parameter :: WRF_FILE_NOT_OPENED = 100 - integer, parameter :: WRF_FILE_OPENED_NOT_COMMITTED = 101 - integer, parameter :: WRF_FILE_OPENED_FOR_WRITE = 102 - integer, parameter :: WRF_FILE_OPENED_FOR_READ = 103 - integer, parameter :: WRF_REAL = 104 - integer, parameter :: WRF_DOUBLE = 105 - integer, parameter :: WRF_INTEGER = 106 - integer, parameter :: WRF_LOGICAL = 107 - integer, parameter :: WRF_COMPLEX = 108 - integer, parameter :: WRF_DOUBLE_COMPLEX = 109 - integer, parameter :: WRF_FILE_OPENED_FOR_UPDATE = 110 -! This bit is for backwards compatibility with old variants of these flags -! that are still being used in io_grib1 and io_phdf5. It should be removed! - integer, parameter :: WRF_FILE_OPENED_AND_COMMITTED = 102 diff --git a/src/fim/FIMsrc/post/wrfio/wrf_status_codes.h b/src/fim/FIMsrc/post/wrfio/wrf_status_codes.h deleted file mode 100644 index 059d9ea..0000000 --- a/src/fim/FIMsrc/post/wrfio/wrf_status_codes.h +++ /dev/null @@ -1,133 +0,0 @@ - -!WRF Error and Warning messages (1-999) -!All i/o package-specific status codes you may want to add must be handled by your package (see below) -! WRF handles these and netCDF messages only - integer, parameter :: WRF_NO_ERR = 0 !no error - integer, parameter :: WRF_WARN_FILE_NF = -1 !file not found, or incomplete - integer, parameter :: WRF_WARN_MD_NF = -2 !metadata not found - integer, parameter :: WRF_WARN_TIME_NF = -3 !timestamp not found - integer, parameter :: WRF_WARN_TIME_EOF = -4 !no more timestamps - integer, parameter :: WRF_WARN_VAR_NF = -5 !variable not found - integer, parameter :: WRF_WARN_VAR_EOF = -6 !no more variables for the current time - integer, parameter :: WRF_WARN_TOO_MANY_FILES = -7 !too many open files - integer, parameter :: WRF_WARN_TYPE_MISMATCH = -8 !data type mismatch - integer, parameter :: WRF_WARN_WRITE_RONLY_FILE = -9 !attempt to write readonly file - integer, parameter :: WRF_WARN_READ_WONLY_FILE = -10 !attempt to read writeonly file - integer, parameter :: WRF_WARN_FILE_NOT_OPENED = -11 !attempt to access unopened file - integer, parameter :: WRF_WARN_2DRYRUNS_1VARIABLE = -12 !attempt to do 2 trainings for 1 variable - integer, parameter :: WRF_WARN_READ_PAST_EOF = -13 !attempt to read past EOF - integer, parameter :: WRF_WARN_BAD_DATA_HANDLE = -14 !bad data handle - integer, parameter :: WRF_WARN_WRTLEN_NE_DRRUNLEN = -15 !write length not equal to training length - integer, parameter :: WRF_WARN_TOO_MANY_DIMS = -16 !more dimensions requested than training - integer, parameter :: WRF_WARN_COUNT_TOO_LONG = -17 !attempt to read more data than exists - integer, parameter :: WRF_WARN_DIMENSION_ERROR = -18 !input dimension inconsistent - integer, parameter :: WRF_WARN_BAD_MEMORYORDER = -19 !input MemoryOrder not recognized - integer, parameter :: WRF_WARN_DIMNAME_REDEFINED = -20 !a dimension name with 2 different lengths - integer, parameter :: WRF_WARN_CHARSTR_GT_LENDATA = -21 !string longer than provided storage - integer, parameter :: WRF_WARN_NOTSUPPORTED = -22 !function not supportable - integer, parameter :: WRF_WARN_NOOP = -23 !package implements this routine as NOOP - -!Fatal errors - integer, parameter :: WRF_ERR_FATAL_ALLOCATION_ERROR = -100 !allocation error - integer, parameter :: WRF_ERR_FATAL_DEALLOCATION_ERR = -101 !dealloc error - integer, parameter :: WRF_ERR_FATAL_BAD_FILE_STATUS = -102 !bad file status - - -!Package specific errors (1000+) -!Netcdf status codes -!WRF will accept status codes of 1000+, but it is up to the package to handle -! and return the status to the user. - - integer, parameter :: WRF_ERR_FATAL_BAD_VARIABLE_DIM = -1004 - integer, parameter :: WRF_ERR_FATAL_MDVAR_DIM_NOT_1D = -1005 - integer, parameter :: WRF_ERR_FATAL_TOO_MANY_TIMES = -1006 - integer, parameter :: WRF_WARN_BAD_DATA_TYPE = -1007 !this code not in either spec? - integer, parameter :: WRF_WARN_FILE_NOT_COMMITTED = -1008 !this code not in either spec? - integer, parameter :: WRF_WARN_FILE_OPEN_FOR_READ = -1009 - integer, parameter :: WRF_IO_NOT_INITIALIZED = -1010 - integer, parameter :: WRF_WARN_MD_AFTER_OPEN = -1011 - integer, parameter :: WRF_WARN_TOO_MANY_VARIABLES = -1012 - integer, parameter :: WRF_WARN_DRYRUN_CLOSE = -1013 - integer, parameter :: WRF_WARN_DATESTR_BAD_LENGTH = -1014 - integer, parameter :: WRF_WARN_ZERO_LENGTH_READ = -1015 - integer, parameter :: WRF_WARN_DATA_TYPE_NOT_FOUND = -1016 - integer, parameter :: WRF_WARN_DATESTR_ERROR = -1017 - integer, parameter :: WRF_WARN_DRYRUN_READ = -1018 - integer, parameter :: WRF_WARN_ZERO_LENGTH_GET = -1019 - integer, parameter :: WRF_WARN_ZERO_LENGTH_PUT = -1020 - integer, parameter :: WRF_WARN_NETCDF = -1021 - integer, parameter :: WRF_WARN_LENGTH_LESS_THAN_1 = -1022 - integer, parameter :: WRF_WARN_MORE_DATA_IN_FILE = -1023 - integer, parameter :: WRF_WARN_DATE_LT_LAST_DATE = -1024 - -! For HDF5 only - integer, parameter :: WRF_HDF5_ERR_FILE = -200 - integer, parameter :: WRF_HDF5_ERR_MD = -201 - integer, parameter :: WRF_HDF5_ERR_TIME = -202 - integer, parameter :: WRF_HDF5_ERR_TIME_EOF = -203 - integer, parameter :: WRF_HDF5_ERR_MORE_DATA_IN_FILE = -204 - integer, parameter :: WRF_HDF5_ERR_DATE_LT_LAST_DATE = -205 - integer, parameter :: WRF_HDF5_ERR_TOO_MANY_FILES = -206 - integer, parameter :: WRF_HDF5_ERR_TYPE_MISMATCH = -207 - integer, parameter :: WRF_HDF5_ERR_LENGTH_LESS_THAN_1 = -208 - integer, parameter :: WRF_HDF5_ERR_WRITE_RONLY_FILE = -209 - integer, parameter :: WRF_HDF5_ERR_READ_WONLY_FILE = -210 - integer, parameter :: WRF_HDF5_ERR_FILE_NOT_OPENED = -211 - integer, parameter :: WRF_HDF5_ERR_DATESTR_ERROR = -212 - integer, parameter :: WRF_HDF5_ERR_DRYRUN_READ = -213 - integer, parameter :: WRF_HDF5_ERR_ZERO_LENGTH_GET = -214 - integer, parameter :: WRF_HDF5_ERR_ZERO_LENGTH_PUT = -215 - integer, parameter :: WRF_HDF5_ERR_2DRYRUNS_1VARIABLE = -216 - integer, parameter :: WRF_HDF5_ERR_DATA_TYPE_NOTFOUND = -217 - integer, parameter :: WRF_HDF5_ERR_READ_PAST_EOF = -218 - integer, parameter :: WRF_HDF5_ERR_BAD_DATA_HANDLE = -219 - integer, parameter :: WRF_HDF5_ERR_WRTLEN_NE_DRRUNLEN = -220 - integer, parameter :: WRF_HDF5_ERR_DRYRUN_CLOSE = -221 - integer, parameter :: WRF_HDF5_ERR_DATESTR_BAD_LENGTH = -222 - integer, parameter :: WRF_HDF5_ERR_ZERO_LENGTH_READ = -223 - integer, parameter :: WRF_HDF5_ERR_TOO_MANY_DIMS = -224 - integer, parameter :: WRF_HDF5_ERR_TOO_MANY_VARIABLES = -225 - integer, parameter :: WRF_HDF5_ERR_COUNT_TOO_LONG = -226 - integer, parameter :: WRF_HDF5_ERR_DIMENSION_ERROR = -227 - integer, parameter :: WRF_HDF5_ERR_BAD_MEMORYORDER = -228 - integer, parameter :: WRF_HDF5_ERR_DIMNAME_REDEFINED = -229 - integer, parameter :: WRF_HDF5_ERR_MD_AFTER_OPEN = -230 - integer, parameter :: WRF_HDF5_ERR_CHARSTR_GT_LENDATA = -231 - integer, parameter :: WRF_HDF5_ERR_BAD_DATA_TYPE = -232 - integer, parameter :: WRF_HDF5_ERR_FILE_NOT_COMMITTED = -233 - - integer, parameter :: WRF_HDF5_ERR_ALLOCATION = -2001 - integer, parameter :: WRF_HDF5_ERR_DEALLOCATION = -2002 - integer, parameter :: WRF_HDF5_ERR_BAD_FILE_STATUS = -2003 - integer, parameter :: WRF_HDF5_ERR_BAD_VARIABLE_DIM = -2004 - integer, parameter :: WRF_HDF5_ERR_MDVAR_DIM_NOT_1D = -2005 - integer, parameter :: WRF_HDF5_ERR_TOO_MANY_TIMES = -2006 - integer, parameter :: WRF_HDF5_ERR_DATA_ID_NOTFOUND = -2007 - - integer, parameter :: WRF_HDF5_ERR_DATASPACE = -300 - integer, parameter :: WRF_HDF5_ERR_DATATYPE = -301 - integer, parameter :: WRF_HDF5_ERR_PROPERTY_LIST = -302 - - integer, parameter :: WRF_HDF5_ERR_DATASET_CREATE = -303 - integer, parameter :: WRF_HDF5_ERR_DATASET_READ = -304 - integer, parameter :: WRF_HDF5_ERR_DATASET_WRITE = -305 - integer, parameter :: WRF_HDF5_ERR_DATASET_OPEN = -306 - integer, parameter :: WRF_HDF5_ERR_DATASET_GENERAL = -307 - integer, parameter :: WRF_HDF5_ERR_GROUP = -308 - - integer, parameter :: WRF_HDF5_ERR_FILE_OPEN = -309 - integer, parameter :: WRF_HDF5_ERR_FILE_CREATE = -310 - integer, parameter :: WRF_HDF5_ERR_DATASET_CLOSE = -311 - integer, parameter :: WRF_HDF5_ERR_FILE_CLOSE = -312 - integer, parameter :: WRF_HDF5_ERR_CLOSE_GENERAL = -313 - - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_CREATE = -314 - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_READ = -315 - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_WRITE = -316 - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_OPEN = -317 - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_GENERAL = -318 - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_CLOSE = -319 - - integer, parameter :: WRF_HDF5_ERR_OTHERS = -320 - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_OTHERS = -321 - diff --git a/src/fim/FIMsrc/prep/Makefile b/src/fim/FIMsrc/prep/Makefile deleted file mode 100644 index 3d8d1ec..0000000 --- a/src/fim/FIMsrc/prep/Makefile +++ /dev/null @@ -1,46 +0,0 @@ -# prep Makefile - -SHELL = /bin/sh - -include ../macros.make - -#JR Use GMAKEMINUSJ where appropriate to enable parallel capability of gmake - -all: - (cd grid && $(MAKE) $(GMAKEMINUSJ) FC=$(FC) FFLAGS="$(FFLAGS)" \ - LIBDIR=$(LIBDIR) BINDIR=$(BINDIR)) || \ - (echo "make failure in grid/" && exit 1) - - (cd sfcio && $(MAKE) FC=$(FC) BYTE_SWAP_FLAG=$(BYTE_SWAP_FLAG) \ - LIBDIR=$(LIBDIR)) || \ - (echo "make failure in sfcio/" && exit 1) - - (cd sigio && $(MAKE) $(GMAKEMINUSJ) FC=$(FC) \ - BYTE_SWAP_FLAG=$(BYTE_SWAP_FLAG) FREEFLAG=$(FREEFLAG) \ - FIXEDFLAG=$(FIXEDFLAG) LIBDIR=$(LIBDIR)) || \ - (echo "make failure in sigio/" && exit 1) - - (cd slint && $(MAKE) $(GMAKEMINUSJ) FC=$(FC) FFLAGS="$(FFLAGS)" \ - LIBDIR=$(LIBDIR) BINDIR=$(BINDIR)) || \ - (echo "make failure in slint/" && exit 1) - - (cd sp && $(MAKE) $(GMAKEMINUSJ) MAKE=$(MAKE) FC=$(FC) FFLAGS="$(SP_FFLAGS)" \ - FREEFLAG=$(FREEFLAG) FIXEDFLAG=$(FIXEDFLAG) LIBDIR=$(LIBDIR)) || \ - (echo "make failure in sp/" && exit 1) - - (cd ssfc2icos && $(MAKE) FC=$(FC) FFLAGS="$(FFLAGS)" \ - BYTE_SWAP_FLAG=$(BYTE_SWAP_FLAG) LIBDIR=$(LIBDIR) BINDIR=$(BINDIR)) || \ - (echo "make failure in ssfc2icos/" && exit 1) - - (cd gfsenkf && $(MAKE) FC=$(FCserial) FFLAGS="$(FFLAGS)" LIBDIR=$(LIBDIR) \ - BINDIR=$(BINDIR) FREEFLAG=$(FREEFLAG)) || \ - (echo "make failure in gfsenkf/" && exit 1) - -clean: - (cd gfsenkf && $(MAKE) clean) - (cd grid && $(MAKE) clean) - (cd sfcio && $(MAKE) clean) - (cd sigio && $(MAKE) clean) - (cd slint && $(MAKE) clean) - (cd sp && $(MAKE) clean) - (cd ssfc2icos && $(MAKE) clean) diff --git a/src/fim/FIMsrc/prep/gfsenkf/Makefile b/src/fim/FIMsrc/prep/gfsenkf/Makefile deleted file mode 100644 index 4bc8058..0000000 --- a/src/fim/FIMsrc/prep/gfsenkf/Makefile +++ /dev/null @@ -1,13 +0,0 @@ -include ../../macros.make - -all: - (cd global_sfchdr.fd && $(MAKE) FC=$(FC) FFLAGS="$(FFLAGS)" LIBDIR=$(LIBDIR) \ - BINDIR=$(BINDIR) FREEFLAG=$(FREEFLAG)) || \ - (echo "make failure in global_sfchdr.fd/" && exit 1) - (cd global_sighdr.fd && $(MAKE) FC=$(FC) FFLAGS="$(FFLAGS)" LIBDIR=$(LIBDIR) \ - BINDIR=$(BINDIR) FREEFLAG=$(FREEFLAG)) || \ - (echo "make failure in global_sighdr.fd/" && exit 1) - -clean: - (cd global_sfchdr.fd && $(MAKE) clean) - (cd global_sighdr.fd && $(MAKE) clean) diff --git a/src/fim/FIMsrc/prep/gfsenkf/README b/src/fim/FIMsrc/prep/gfsenkf/README deleted file mode 100644 index 7924189..0000000 --- a/src/fim/FIMsrc/prep/gfsenkf/README +++ /dev/null @@ -1,2 +0,0 @@ -Code provided by Jeff Whitaker (Jeffrey.S.Whitaker@noaa.gov), available from -http://code.google.com/p/ncepgfs. diff --git a/src/fim/FIMsrc/prep/gfsenkf/global_sfchdr.fd/Makefile b/src/fim/FIMsrc/prep/gfsenkf/global_sfchdr.fd/Makefile deleted file mode 100755 index c51c8c8..0000000 --- a/src/fim/FIMsrc/prep/gfsenkf/global_sfchdr.fd/Makefile +++ /dev/null @@ -1,13 +0,0 @@ -include ../../../macros.make - -CMD=$(BINDIR)/global_sfchdr -INCMOD=../../sfcio -LIBS=-L$(LIBDIR) -lsfcio_4 -lw3_4 -SHELL=/bin/sh -SRCM=sfchdr.f - -$(CMD): $(SRCM) - $(FC) $(FREEFLAG) -I $(INCMOD) $(FFLAGS) $(LDFLAGS) $(SRCM) $(LIBS) -o $(CMD) - -clean: - $(RM) $(CMD) diff --git a/src/fim/FIMsrc/prep/gfsenkf/global_sfchdr.fd/sfchdr.f b/src/fim/FIMsrc/prep/gfsenkf/global_sfchdr.fd/sfchdr.f deleted file mode 100755 index 88b7828..0000000 --- a/src/fim/FIMsrc/prep/gfsenkf/global_sfchdr.fd/sfchdr.f +++ /dev/null @@ -1,212 +0,0 @@ -program sfchdr -!$$$ main program documentation block -! -! Main program: sfchdr Print information from surface header -! Prgmmr: Iredell Org: np23 Date: 1999-08-23 -! -! Abstract: This program prints information from the surface header. -! The following parameters may be printed out: -! filetype -! fhour -! ifhr -! idate -! iyr -! imo -! idy -! ihr -! vdate -! vyr -! vmo -! vdy -! vhr -! latb -! lonb -! ivs -! lpl -! lsoil -! zsoil -! -! Program history log: -! 1999-08-23 Iredell -! 2005-01-13 Iredell use sfcio, change IVSN to IVS -! -! Input files: -! arg. 1 surface file(s) -! -! Subprograms called: -! iargc -! errmsg -! eusage -! errexit -! getarg -! sfcvar -! -! Attributes: -! Language: fortran90 -! -!$$$ - use sfcio_module - implicit none - integer narg,iargc - integer,parameter:: lusfc=11 - character(255) cfsfc - character(16) cvar - integer ncfsfc,ios - type(sfcio_head) head - narg=iargc() - if(narg.lt.1.or.narg.gt.2) then - if(narg.ne.0) call errmsg('sfchdr: too many arguments') - call eusage - call errexit(1) - endif - call getarg(1,cfsfc) - ncfsfc=len_trim(cfsfc) - call sfcio_sropen(lusfc,cfsfc(1:ncfsfc),ios) - if(ios.ne.0) then - call errmsg('sfchdr: error opening file '//cfsfc(1:ncfsfc)) - call errexit(2) - endif - call sfcio_srhead(lusfc,head,ios) - if(ios.ne.0) then - call errmsg('sfchdr: error reading header from file '//cfsfc(1:ncfsfc)) - call errexit(2) - endif - if(narg.eq.2) then - call getarg(2,cvar) - call sfcvar(head,cvar) - else - do - read(5,*,iostat=ios) cvar - if(ios.ne.0) exit - call sfcvar(head,cvar) - enddo - endif -end program -subroutine sfcvar(head,cvar) - use sfcio_module - implicit none - type(sfcio_head),intent(in):: head - character(16),intent(in):: cvar - integer lval - character(16) cval - integer jdat(8) - select case(cvar) - case('FILETYPE','filetype') - print '(a)','GFS/SFC/' - case('FHOUR','fhour') - call inch(int(head%fhour),lval,cval) - print '(a,f3.2)',cval(1:lval),head%fhour-int(head%fhour) - case('IFHR','ifhr') - call inch(int(head%fhour),lval,cval) - if(lval.le.1) then - print '(a)','0'//cval(1:lval) - else - print '(a)',cval(1:lval) - endif - case('IDATE','idate') - print '(i4.4,3i2.2)',head%idate(4),head%idate(2),& - head%idate(3),head%idate(1) - case('IYR','iyr') - call inch(head%idate(4),lval,cval) - print '(a)',cval(1:lval) - case('IMO','imo') - call inch(head%idate(2),lval,cval) - print '(a)',cval(1:lval) - case('IDY','idy') - call inch(head%idate(3),lval,cval) - print '(a)',cval(1:lval) - case('IHR','ihr') - call inch(head%idate(1),lval,cval) - print '(a)',cval(1:lval) - case('VDATE','vdate') - call w3movdat((/0.,head%fhour,0.,0.,0./),& - (/head%idate(4),head%idate(2),head%idate(3),0,& - head%idate(1),0,0,0/),jdat) - print '(i4.4,3i2.2)',jdat(1),jdat(2),jdat(3),jdat(5) - case('VYR','vyr') - call w3movdat((/0.,head%fhour,0.,0.,0./),& - (/head%idate(4),head%idate(2),head%idate(3),0,& - head%idate(1),0,0,0/),jdat) - call inch(jdat(1),lval,cval) - print '(a)',cval(1:lval) - case('VMO','vmo') - call w3movdat((/0.,head%fhour,0.,0.,0./),& - (/head%idate(4),head%idate(2),head%idate(3),0,& - head%idate(1),0,0,0/),jdat) - call inch(jdat(2),lval,cval) - print '(a)',cval(1:lval) - case('VDY','vdy') - call w3movdat((/0.,head%fhour,0.,0.,0./),& - (/head%idate(4),head%idate(2),head%idate(3),0,& - head%idate(1),0,0,0/),jdat) - call inch(jdat(3),lval,cval) - print '(a)',cval(1:lval) - case('VHR','vhr') - call w3movdat((/0.,head%fhour,0.,0.,0./),& - (/head%idate(4),head%idate(2),head%idate(3),0,& - head%idate(1),0,0,0/),jdat) - call inch(jdat(5),lval,cval) - print '(a)',cval(1:lval) - case('LATB','latb') - call inch(head%latb,lval,cval) - print '(a)',cval(1:lval) - case('LONB','lonb') - call inch(head%lonb,lval,cval) - print '(a)',cval(1:lval) - case('IVS','ivs') - call inch(head%ivs,lval,cval) - print '(a)',cval(1:lval) - case('LSOIL','lsoil') - call inch(head%lsoil,lval,cval) - print '(a)',cval(1:lval) - case('IREALF','irealf') - call inch(head%irealf,lval,cval) - print '(a)',cval(1:lval) - case('LPL','lpl') - print '(i6)',head%latb/2 - print '(10i6)',head%lpl - case('ZSOIL','zsoil') - print '(i6)',head%lsoil - print '(10f8.3)',head%zsoil - case('?') - print '(a)','Choose from:' - print '(a)',' filetype' - print '(a)',' fhour' - print '(a)',' ifhr' - print '(a)',' idate' - print '(a)',' iyr' - print '(a)',' imo' - print '(a)',' idy' - print '(a)',' ihr' - print '(a)',' vdate' - print '(a)',' vyr' - print '(a)',' vmo' - print '(a)',' vdy' - print '(a)',' vhr' - print '(a)',' latb' - print '(a)',' lonb' - print '(a)',' ivs' - print '(a)',' lsoil' - print '(a)',' irealf' - print '(a)',' lpl' - print '(a)',' zsoil' - case default - print '(a)','?' - end select -end subroutine -subroutine inch(i,l,c) - implicit none - integer,intent(in):: i - integer,intent(out):: l - character(*),intent(out):: c - character*20 cform - l=log10(abs(i)+0.5)+1 - if(i.le.0) l=l+1 - write(cform,'("(i",i1,")")') l - write(c,cform) i -end subroutine -subroutine eusage - implicit none - call errmsg('Usage: sfchdr sfcfile value.list') - call errmsg(' or sfchdr sfcfile variable >value') -end subroutine diff --git a/src/fim/FIMsrc/prep/gfsenkf/global_sighdr.fd/Makefile b/src/fim/FIMsrc/prep/gfsenkf/global_sighdr.fd/Makefile deleted file mode 100755 index 0c28720..0000000 --- a/src/fim/FIMsrc/prep/gfsenkf/global_sighdr.fd/Makefile +++ /dev/null @@ -1,13 +0,0 @@ -include ../../../macros.make - -CMD=$(BINDIR)/global_sighdr -INCMOD=../../sigio -LIBS=-L$(LIBDIR) -lsigio_4 -lw3_4 -SHELL=/bin/sh -SRCM=sighdr.f - -$(CMD): $(SRCM) - $(FC) $(FREEFLAG) -I $(INCMOD) $(FFLAGS) $(LDFLAGS) $(SRCM) $(LIBS) -o $(CMD) - -clean: - $(RM) $(CMD) diff --git a/src/fim/FIMsrc/prep/gfsenkf/global_sighdr.fd/sighdr.f b/src/fim/FIMsrc/prep/gfsenkf/global_sighdr.fd/sighdr.f deleted file mode 100755 index a09428a..0000000 --- a/src/fim/FIMsrc/prep/gfsenkf/global_sighdr.fd/sighdr.f +++ /dev/null @@ -1,374 +0,0 @@ -program sighdr -!$$$ main program documentation block -! -! Main program: sighdr Print information from sigma header -! Prgmmr: Iredell Org: np23 Date: 1999-08-23 -! -! Abstract: This program prints information from the sigma header. -! The following parameters may be printed out: -! filetype -! fhour -! ifhr -! idate -! iyr -! imo -! idy -! ihr -! vdate -! vyr -! vmo -! vdy -! vhr -! si -! sl -! ak -! bk -! siglev -! jcap -! levs -! itrun -! iorder -! irealf -! igen -! latf -! lonf -! latb -! lonb -! latr -! lonr -! ntrac -! icen2 -! ienst -! iensi -! idpp -! idsl -! idvc -! idvm -! idvt -! idrun -! idusr -! pdryini -! ncldt -! ixgr -! nxgr -! nxss -! ivs -! nvcoord -! vcoord -! cfvars -! -! Program history log: -! 1999-08-23 Iredell -! -! Input files: -! arg. 1 sigma file(s) -! -! Modules used: -! sigio_module -! -! Subprograms called: -! iargc -! errmsg -! eusage -! errexit -! getarg -! sigio_sropen -! sigio_srhead -! sigvar -! sigvar -! -! Attributes: -! Language: fortran90 -! -!$$$ - use sigio_module - implicit none - integer narg,iargc - integer(sigio_intkind),parameter:: lusig=11 - integer(sigio_intkind):: irets - character(255) cfsig - type(sigio_head):: sighead - character(16) cvar - integer ncfsig,ios - narg=iargc() - if(narg.lt.1.or.narg.gt.2) then - if(narg.ne.0) call errmsg('sighdr: too many arguments') - call eusage - call errexit(1) - endif - call getarg(1,cfsig) - ncfsig=len_trim(cfsig) - call sigio_sropen(lusig,cfsig(1:ncfsig),irets) - if(irets.ne.0) then - call errmsg('sighdr: error opening file '//cfsig(1:ncfsig)) - call errexit(2) - endif - call sigio_srhead(lusig,sighead,irets) - if(irets.ne.0) then - call errmsg('sighdr: error reading header from file '//cfsig(1:ncfsig)) - call errexit(2) - endif - if(narg.eq.2) then - call getarg(2,cvar) - call sigvar(sighead,cvar) - else - do - read(5,*,iostat=ios) cvar - if(ios.ne.0) exit - call sigvar(sighead,cvar) - enddo - endif -end program -subroutine sigvar(sighead,cvar) - use sigio_module - implicit none - type(sigio_head),intent(in):: sighead - character(16),intent(in):: cvar - integer lval - character(16) cval - integer jdat(8) - integer k - select case(cvar) - case('FILETYPE','filetype') - print '(a)','sig' - case('FHOUR','fhour') - call inch(int(sighead%fhour),lval,cval) - print '(a,f3.2)',cval(1:lval),sighead%fhour-int(sighead%fhour) - case('IFHR','ifhr') - call inch(int(sighead%fhour),lval,cval) - if(lval.le.1) then - print '(a)','0'//cval(1:lval) - else - print '(a)',cval(1:lval) - endif - case('IDATE','idate') - print '(i4.4,3i2.2)',sighead%idate(4),sighead%idate(2),& - sighead%idate(3),sighead%idate(1) - case('IYR','iyr') - call inch(sighead%idate(4),lval,cval) - print '(a)',cval(1:lval) - case('IMO','imo') - call inch(sighead%idate(2),lval,cval) - print '(a)',cval(1:lval) - case('IDY','idy') - call inch(sighead%idate(3),lval,cval) - print '(a)',cval(1:lval) - case('IHR','ihr') - call inch(sighead%idate(1),lval,cval) - print '(a)',cval(1:lval) - case('VDATE','vdate') - call w3movdat((/0.,sighead%fhour,0.,0.,0./),& - (/sighead%idate(4),sighead%idate(2),sighead%idate(3),0,& - sighead%idate(1),0,0,0/),jdat) - print '(i4.4,3i2.2)',jdat(1),jdat(2),jdat(3),jdat(5) - case('VYR','vyr') - call w3movdat((/0.,sighead%fhour,0.,0.,0./),& - (/sighead%idate(4),sighead%idate(2),sighead%idate(3),0,& - sighead%idate(1),0,0,0/),jdat) - call inch(jdat(1),lval,cval) - print '(a)',cval(1:lval) - case('VMO','vmo') - call w3movdat((/0.,sighead%fhour,0.,0.,0./),& - (/sighead%idate(4),sighead%idate(2),sighead%idate(3),0,& - sighead%idate(1),0,0,0/),jdat) - call inch(jdat(2),lval,cval) - print '(a)',cval(1:lval) - case('VDY','vdy') - call w3movdat((/0.,sighead%fhour,0.,0.,0./),& - (/sighead%idate(4),sighead%idate(2),sighead%idate(3),0,& - sighead%idate(1),0,0,0/),jdat) - call inch(jdat(3),lval,cval) - print '(a)',cval(1:lval) - case('VHR','vhr') - call w3movdat((/0.,sighead%fhour,0.,0.,0./),& - (/sighead%idate(4),sighead%idate(2),sighead%idate(3),0,& - sighead%idate(1),0,0,0/),jdat) - call inch(jdat(5),lval,cval) - print '(a)',cval(1:lval) - case('SI','si') - print '(f12.8)',sighead%si(1:sighead%levs+1) - case('SL','sl') - print '(f12.8)',sighead%sl(1:sighead%levs) - case('AK','ak') - print '(f12.3)',sighead%ak(1:sighead%levs+1) - case('BK','bk') - print '(f12.8)',sighead%bk(1:sighead%levs+1) - case('SIGLEV','siglev') - if(sighead%idvc.lt.2) then - print '(i3)',sighead%levs - print '(f12.8)',sighead%si(2:sighead%levs) - elseif(sighead%idvc.eq.2) then - print '(2i6)',sighead%idvc,sighead%levs - print '(f12.3,f12.8)',(sighead%ak(k),sighead%bk(k),k=1,sighead%levs+1) - else - print '(3i6)',sighead%idvc,sighead%levs,sighead%nvcoord - do k=1,sighead%levs+1 - print '(5g16.8)',sighead%vcoord(k,:) - enddo - endif - case('JCAP','jcap') - call inch(sighead%jcap,lval,cval) - print '(a)',cval(1:lval) - case('LEVS','levs') - call inch(sighead%levs,lval,cval) - print '(a)',cval(1:lval) - case('ITRUN','itrun') - call inch(sighead%itrun,lval,cval) - print '(a)',cval(1:lval) - case('IORDER','iorder') - call inch(sighead%iorder,lval,cval) - print '(a)',cval(1:lval) - case('IREALF','irealf') - call inch(sighead%irealf,lval,cval) - print '(a)',cval(1:lval) - case('IGEN','igen') - call inch(sighead%igen,lval,cval) - print '(a)',cval(1:lval) - case('LATF','latf') - call inch(sighead%latf,lval,cval) - print '(a)',cval(1:lval) - case('LONF','lonf') - call inch(sighead%lonf,lval,cval) - print '(a)',cval(1:lval) - case('LATB','latb') - call inch(sighead%latb,lval,cval) - print '(a)',cval(1:lval) - case('LONB','lonb') - call inch(sighead%lonb,lval,cval) - print '(a)',cval(1:lval) - case('LATR','latr') - call inch(sighead%latr,lval,cval) - print '(a)',cval(1:lval) - case('LONR','lonr') - call inch(sighead%lonr,lval,cval) - print '(a)',cval(1:lval) - case('NTRAC','ntrac') - call inch(sighead%ntrac,lval,cval) - print '(a)',cval(1:lval) - case('ICEN2','icen2') - call inch(sighead%icen2,lval,cval) - print '(a)',cval(1:lval) - case('IENST','ienst') - call inch(sighead%iens(1),lval,cval) - print '(a)',cval(1:lval) - case('IENSI','iensi') - call inch(sighead%iens(2),lval,cval) - print '(a)',cval(1:lval) - case('IDPP','idpp') - call inch(sighead%idpp,lval,cval) - print '(a)',cval(1:lval) - case('IDSL','idsl') - call inch(sighead%idsl,lval,cval) - print '(a)',cval(1:lval) - case('IDVC','idvc') - call inch(sighead%idvc,lval,cval) - print '(a)',cval(1:lval) - case('IDVM','idvm') - call inch(sighead%idvm,lval,cval) - print '(a)',cval(1:lval) - case('IDVT','idvt') - call inch(sighead%idvt,lval,cval) - print '(a)',cval(1:lval) - case('IDRUN','idrun') - call inch(sighead%idrun,lval,cval) - print '(a)',cval(1:lval) - case('IDUSR','idusr') - call inch(sighead%idusr,lval,cval) - print '(a)',cval(1:lval) - case('PDRYINI','pdryini') - call inch(int(sighead%pdryini),lval,cval) - print '(a,f6.5)',cval(1:lval),sighead%pdryini-int(sighead%pdryini) - case('NCLDT','ncldt') - call inch(sighead%ncldt,lval,cval) - print '(a)',cval(1:lval) - case('IXGR','ixgr') - call inch(sighead%ixgr,lval,cval) - print '(a)',cval(1:lval) - case('NXGR','nxgr') - call inch(sighead%nxgr,lval,cval) - print '(a)',cval(1:lval) - case('NXSS','nxss') - call inch(sighead%nxss,lval,cval) - print '(a)',cval(1:lval) - case('IVS','ivs') - call inch(sighead%ivs,lval,cval) - print '(a)',cval(1:lval) - case('NVCOORD','nvcoord') - call inch(sighead%nvcoord,lval,cval) - print '(a)',cval(1:lval) - case('VCOORD','vcoord') - print '(2i6)',sighead%idvc,sighead%levs,sighead%nvcoord - do k=1,sighead%levs+1 - print '(5g16.8)',sighead%vcoord(k,:) - enddo - case('?') - print '(a)','Choose from:' - print '(a)',' filetype' - print '(a)',' fhour' - print '(a)',' ifhr' - print '(a)',' idate' - print '(a)',' iyr' - print '(a)',' imo' - print '(a)',' idy' - print '(a)',' ihr' - print '(a)',' vdate' - print '(a)',' vyr' - print '(a)',' vmo' - print '(a)',' vdy' - print '(a)',' vhr' - print '(a)',' si' - print '(a)',' sl' - print '(a)',' ak' - print '(a)',' bk' - print '(a)',' siglev' - print '(a)',' jcap' - print '(a)',' levs' - print '(a)',' itrun' - print '(a)',' iorder' - print '(a)',' irealf' - print '(a)',' igen' - print '(a)',' latf' - print '(a)',' lonf' - print '(a)',' latb' - print '(a)',' lonb' - print '(a)',' latr' - print '(a)',' lonr' - print '(a)',' ntrac' - print '(a)',' icen2' - print '(a)',' ienst' - print '(a)',' iensi' - print '(a)',' idpp' - print '(a)',' idsl' - print '(a)',' idvc' - print '(a)',' idvm' - print '(a)',' idvt' - print '(a)',' idrun' - print '(a)',' idusr' - print '(a)',' pdryini' - print '(a)',' ncldt' - print '(a)',' ixgr' - print '(a)',' nxgr' - print '(a)',' nxss' - print '(a)',' ivs' - print '(a)',' nvcoord' - print '(a)',' vcoord' - case default - print '(a)','?' - end select -end subroutine -subroutine inch(i,l,c) - implicit none - integer,intent(in):: i - integer,intent(out):: l - character(*),intent(out):: c - character*20 cform - l=log10(abs(i)+0.5)+1 - if(i.le.0) l=l+1 - write(cform,'("(i",i1,")")') l - write(c,cform) i -end subroutine -subroutine eusage - implicit none - call errmsg('Usage: sighdr sigfile value.list') - call errmsg(' or sighdr sigfile variable >value') -end subroutine diff --git a/src/fim/FIMsrc/prep/grid/GetRegions.F90 b/src/fim/FIMsrc/prep/grid/GetRegions.F90 deleted file mode 100644 index 9d2c22e..0000000 --- a/src/fim/FIMsrc/prep/grid/GetRegions.F90 +++ /dev/null @@ -1,43 +0,0 @@ -subroutine GetRegions(BlockSize,PEstart,PEend,nPEs,FirstTIme,Rstart,Rend) -!This routine does a simple equally sized 1-D decomposition -!This routine divides a BlockSize sized block into nprocs equal sized regions. -!This routine returns the start and end of each region (processor footprint). - -!Author: Jacques Middlecoff, September, 2009 -!Added FirstTime so it will work section by section - Jacques Middlecoff, November 2009 - -implicit none -INTEGER,PARAMETER :: MAX_DECOMP_DIMS = 2 !If this is changed ppp_factors,perm and ijblock must be changed -INTEGER,intent(IN ) :: BlockSize !Number of icosahedral points in the block to be decomposed -integer,intent(IN) :: PEstart,PEend !Start and end index for Rstart and Rend -INTEGER,intent(IN ) :: nPEs !Total number of processors -LOGICAL,intent(IN ) :: FirstTime !true means this is the first call -INTEGER,intent(INOUT) :: Rstart(nPEs) !Global starting location for each PE -INTEGER,intent(INOUT) :: Rend (nPEs) !Global ending location for each PE -INTEGER :: RegDim(nPEs) !Temporary for region dimensions -INTEGER :: RD(MAX_DECOMP_DIMS) !Tempory for RegionDim -INTEGER :: RF(MAX_DECOMP_DIMS) !Temporary for rhombus or region factors -INTEGER :: nprocs !Number of processors by which to divide BlockSIze -INTEGER :: inc !Increment added to PEstart -INTEGER :: PE !Processor number - - nprocs = PEend - PEstart+1 - RD(1) = BlockSize - RD(2) = 1 - RF(1) = nprocs - RF(2) = 1 - call ppp_regions(1,RD,RF,nprocs,RegDim(PEstart:PEend)) - if(FirstTime) then - Rstart(PEstart) = 2 - Rend (PEstart) = RegDim(PEstart)+1 - inc = 1 - else - inc = 0 - endif - do PE = PEstart+inc,PEend - Rstart(PE) = Rend(PE-1) + 1 - Rend (PE) = Rstart(PE) + RegDim(PE) - 1 - enddo - return - -end subroutine GetRegions diff --git a/src/fim/FIMsrc/prep/grid/GridGen.F90 b/src/fim/FIMsrc/prep/grid/GridGen.F90 deleted file mode 100644 index 5d496b2..0000000 --- a/src/fim/FIMsrc/prep/grid/GridGen.F90 +++ /dev/null @@ -1,805 +0,0 @@ -PROGRAM GridInfoGen - -!========================================================== -! This program reads in the icosahedren grid (grid point -! sequencial number, lat and lon values), and generates -! the necessary information arrays associated with the grid -! (Vorinoi cells mainly) to allow efficient numerical -! integration of the model (finite volume model). -! -! Ning Wang, Sep. 2006, Partially adapted from Yuanfu Xie's -! GridGen.F90 program. -!========================================================== - - USE datastru ,only: perm, inv_perm - use module_control,only: control,glvl,curve,NumCacheBlocksPerPE - use read_queue_namelist,only: GetNprocs - IMPLICIT NONE - - INTEGER :: n,i,j,k,l, jmax, nb(6), seq, diam_sz, edge_ln, gp_type - INTEGER :: diam_idx, pg_idx, r_i, sgp_type - INTEGER :: grid_point_type - REAL*8 :: d, d2r, dist, distance - REAL*8 :: lat, lon - REAL*8 :: cos_theta,e,pi2, topgrid(12,2),eps - REAL*8 :: v(3,6) - LOGICAL :: double_precision, statistics - - ! FIM grid info arrays: - REAL*8, ALLOCATABLE :: icos_grid(:,:) ! grid location (ll) - REAL, ALLOCATABLE :: icos_grid4(:,:) ! grid location (ll), single precision - INTEGER, ALLOCATABLE :: icos_nprox(:) ! number of neighbors(5 or 6) - INTEGER, ALLOCATABLE :: icos_prox(:,:) ! neighbor seq nidex - REAL*8, ALLOCATABLE :: icos_edge(:,:,:,:) ! end points of edges (ll) - REAL, ALLOCATABLE :: icos_edge4(:,:,:,:)! end points of edges (ll), single precision - REAL*8, ALLOCATABLE :: xyz(:,:,:) - - ! temp arrays to help move the grid point around - REAL*8, ALLOCATABLE :: icos_grid_tmp(:,:) ! grid location (ll) - INTEGER, ALLOCATABLE :: icos_nprox_tmp(:) ! number of neighbors(5 or 6) - INTEGER, ALLOCATABLE :: icos_prox_tmp(:,:) ! neighbor seq nidex - REAL*8, ALLOCATABLE :: icos_edge_tmp(:,:,:,:) ! end points of edges (ll) - REAL*8 :: v1(3), v2(3) - INTEGER :: isn,i2,i3 - INTEGER :: nprocs,PE - INTEGER :: HaloSize - CHARACTER(len=80) :: DecompInfoFile - integer :: glvlh - integer,allocatable :: Rstart(:),Rend(:),RegionSize(:) - LOGICAL :: write_human_readable - - call control ! To read the namelist - - d2r = 4.0*ATAN(1.0)/180.0 - pi2 = 8.0*ATAN(1.0) - eps = 1.0e-4 - - double_precision = .false. - statistics = .false. - - ! Read in 12 gridpoints with 5 neighbors: - OPEN(unit=11,file='top_grid',status='old') - DO i=1,12 - READ(11,*) topgrid(i,1),topgrid(i,2) - topgrid(i,1:2) = topgrid(i,1:2)*d2r ! To radians - ENDDO - CLOSE(11) - - OPEN(10,file='icos_grid_level.dat',status='old') - READ(10,*) n - - ALLOCATE(icos_grid(2,n)) - ALLOCATE(icos_prox(6,n)) - ALLOCATE(icos_nprox(n)) - ALLOCATE(icos_edge(6,2,2,n)) - ALLOCATE(xyz(n,0:6,3)) - icos_edge = 0.0 - - ! Default 6 neighbors: - icos_nprox = 6 - - DO i = 1, n - READ(10, *) seq, lat, lon - IF (lon < 0) THEN - lon = lon + 360.0 - ENDIF - icos_grid(1,seq) = lat*d2r ! To radians - icos_grid(2,seq) = lon*d2r ! To radians - END DO - CLOSE(10) - - PRINT*,'Number of gridpoints: ',n - - diam_sz = (n - 2) / 10 - edge_ln = SQRT(REAL(diam_sz)) + 0.5 - - ! Assign the neighbors to each grid point - -! s * -! /\ /\ -! 1 /0 \4 / \ -! s ___ /____\/____\ ___ s -! \ 0 /\ /\ -! 2\ /0 \5 / \ -! s ___ \/____\/____\ ___ s -! \ 0 /\ / -! 3\ /6 \ / -! \/ \/ -! s * - - DO i = 1, n - CALL special_points(i, nb, diam_sz, edge_ln, sgp_type) - IF (sgp_type == 1) THEN - icos_nprox(i) = 5 - END IF - IF (sgp_type == 0) THEN - gp_type = grid_point_type(i, diam_sz, edge_ln) - IF (gp_type == 0) THEN ! internal gridpoint - nb(1) = i - 1 - nb(2) = i - edge_ln - nb(3) = i - edge_ln + 1 - nb(4) = i + 1 - nb(5) = i + edge_ln - nb(6) = i + edge_ln - 1 - ELSE IF (gp_type == 1) THEN ! see the fig above - nb(1) = i - 1 - pg_idx = (i - 1) / (2 * diam_sz) - IF (pg_idx >= 1) THEN - pg_idx = pg_idx - 1 - ELSE - pg_idx = 4 - END IF - r_i = MOD((i - 1), 2 * diam_sz) - nb(2) = pg_idx * 2 * diam_sz + (r_i - 1) * edge_ln + 2 - nb(3) = nb(2) + edge_ln - nb(4) = i + 1 - nb(5) = i + edge_ln - nb(6) = i + edge_ln - 1 - ELSE IF (gp_type == 2) THEN ! see the fig above - nb(1) = i - edge_ln - pg_idx = (i - 1) / (2 * diam_sz) - IF (pg_idx >= 1) THEN - pg_idx = pg_idx - 1 - ELSE - pg_idx = 4 - END IF - r_i = MOD((i - 1), 2 * diam_sz) - nb(2) = pg_idx * 2 * diam_sz + diam_sz - 2 * edge_ln + r_i + 2 - nb(3) = nb(2) + edge_ln - nb(4) = i + edge_ln - nb(5) = nb(4) - 1 - nb(6) = i - 1 - ELSE IF (gp_type == 3) THEN ! see the fig above - nb(1) = i - edge_ln - pg_idx = (i - 1) / (2 * diam_sz) - IF (pg_idx >= 1) THEN - pg_idx = pg_idx - 1 - ELSE - pg_idx = 4 - END IF - r_i = MOD((i - 1), 2 * diam_sz) - nb(2) = (pg_idx + 1) * 2 * diam_sz - edge_ln + (r_i - (diam_sz + 2 * edge_ln)) / edge_ln + 2 - nb(3) = nb(2) + 1 - nb(4) = i + edge_ln - nb(5) = nb(4) - 1 - nb(6) = i - 1 - ELSE IF (gp_type == 4) THEN ! see the fig above - nb(1) = i - edge_ln - nb(2) = nb(1) + 1 - nb(3) = i + 1 - nb(4) = i + edge_ln - pg_idx = (i - 1) / (2 * diam_sz) - IF (pg_idx < 4) THEN - pg_idx = pg_idx + 1 - ELSE - pg_idx = 0 - END IF - r_i = MOD((i - 1), 2 * diam_sz) - nb(5) = pg_idx * 2 * diam_sz + 2 + ((r_i - 1) / edge_ln) - nb(6) = nb(5) - 1 - ELSE IF (gp_type == 5) THEN ! see the fig above - nb(1) = i - edge_ln - nb(2) = nb(1) + 1 - nb(3) = nb(2) + edge_ln - nb(4) = i + edge_ln - pg_idx = (i - 1) / (2 * diam_sz) - IF (pg_idx < 4) THEN - pg_idx = pg_idx + 1 - ELSE - pg_idx = 0 - END IF - r_i = MOD((i - 1), 2 * diam_sz) - nb(5) = pg_idx * 2 * diam_sz + r_i - diam_sz + 2 * edge_ln - nb(6) = nb(5) - edge_ln - ELSE IF (gp_type == 6) THEN ! see the fig above - nb(1) = i - 1 - nb(2) = i - edge_ln - nb(3) = nb(2) + 1 - nb(4) = i + 1 - pg_idx = (i - 1) / (2 * diam_sz) - IF (pg_idx < 4) THEN - pg_idx = pg_idx + 1 - ELSE - pg_idx = 0 - END IF - r_i = MOD((i - 1), 2 * diam_sz) - nb(5) = pg_idx * 2 * diam_sz + diam_sz + (r_i - 2 * diam_sz + edge_ln + 1) * edge_ln + 1 - nb(6) = nb(5) - edge_ln - END IF - ENDIF - - xyz(i, 0, 1) = COS(icos_grid(1,i))*COS(icos_grid(2,i)) - xyz(i, 0, 2) = COS(icos_grid(1,i))*SIN(icos_grid(2,i)) - xyz(i, 0, 3) = SIN(icos_grid(1,i)) - IF (nb(6) == -1) THEN - jmax = 5 - ELSE - jmax = 6 - ENDIF - DO j = 1, jmax - xyz(i, j, 1) = COS(icos_grid(1,nb(j)))*COS(icos_grid(2,nb(j))) - xyz(i, j, 2) = COS(icos_grid(1,nb(j)))*SIN(icos_grid(2,nb(j))) - xyz(i, j, 3) = SIN(icos_grid(1,nb(j))) - END DO - - icos_prox(1:6,i) = nb - - -! DO j = 1, icos_nprox(i) -! distance = dist(icos_grid(1, i), icos_grid(2, i), & -! icos_grid(1, icos_prox(j,i)) , icos_grid(2, icos_prox(j,i)) ) -! if (i < 30) THEN -! if (i == 0) THEN -! print*, 'i = ', i, 'j = ', icos_prox(j,i) -! print*, icos_grid(1, i), icos_grid(2, i), icos_grid(1, icos_prox(j,i)), icos_grid(2, icos_prox(j,i)) -! print*, 'distance = ', distance -! print*, ' ' -! ENDIF -! END DO - - - ! Voronoi corners: - DO j=1,6 - IF (nb(j) .GT. 0) THEN - ! Do not do the extra point for a 5-neighbor point: - k = j+1 - IF (k .GT. 6) k = k-6 - IF (nb(k) .LT. 0) k = k+1 - IF (k .GT. 6) k = k-6 - - v1 = xyz(i,j,1:3)-xyz(i,0,1:3) - v2 = xyz(i,k,1:3)-xyz(i,0,1:3) - CALL cross_product(v(1,j),v1,v2) - d = SQRT(DOT_PRODUCT(v(1:3,j),v(1:3,j))) - ! Normalize the Voronoi points to the unit sphere: - v(1:3,j) = v(1:3,j)/d - ENDIF - ENDDO - - ! Edges connecting these Voronoi points: - DO j=1,6 - IF (nb(j) .GT. 0) THEN - - ! Do not do the extra point for a 5-neighbor point: - k = j+1 - IF (k .GT. 6) k = k-6 - IF (nb(k) .LT. 0) k = k+1 - IF (k .GT. 6) k = k-6 - - ! Convert to lat/lon: - icos_edge(j,1,1,i) = ASIN(v(3,j)) - IF (ABS(icos_edge(j,1,1,i)) .GT. pi2/4.0-eps) THEN - icos_edge(j,1,2,i) = 0.0 - ELSE - IF (v(1,j)/COS(icos_edge(j,1,1,i)) .GE. 1.0) THEN - icos_edge(j,1,2,i) = 0.0 - ELSE IF (v(1,j)/COS(icos_edge(j,1,1,i)) .LE. -1.0) THEN - icos_edge(j,1,2,i) = pi2/2.0 - ELSE - icos_edge(j,1,2,i) = ACOS(v(1,j)/COS(icos_edge(j,1,1,i))) - IF (v(2,j) .LT. 0.0) then - icos_edge(j,1,2,i) = pi2-icos_edge(j,1,2,i) - ENDIF - ENDIF - ENDIF - - icos_edge(j,2,1,i) = ASIN(v(3,k)) - IF (ABS(icos_edge(j,2,1,i)) .GT. pi2/4.0-eps) THEN - icos_edge(j,2,2,i) = 0.0 - ELSE - IF (v(1,k)/COS(icos_edge(j,2,1,i)) .GE. 1.0) THEN - icos_edge(j,2,2,i) = 0.0 - ELSE IF (v(1,k)/COS(icos_edge(j,2,1,i)) .LE. -1.0) THEN - icos_edge(j,2,2,i) = pi2/2.0 - ELSE - icos_edge(j,2,2,i)=ACOS(v(1,k)/COS(icos_edge(j,2,1,i))) - IF (v(2,k) .LT. 0.0) then - icos_edge(j,2,2,i) = pi2-icos_edge(j,2,2,i) - ENDIF - ENDIF - ENDIF - - ENDIF - ENDDO - ENDDO - - ! Output lat and lon in IJ cordinates for post - open(28,file="latlonIJ.dat", form="unformatted") - call WriteGlvlHeader(28,glvl) - ALLOCATE(icos_grid4(2,n)) - icos_grid4 = icos_grid - write(28) icos_grid4(1,:),icos_grid4(2,:) - close(28) - DEALLOCATE(icos_grid4) - print*, 'done saving latlonIJ.dat' - - ! move the grid points around to follow the 2D filling curve order - call GetNprocs(nprocs) - allocate(Rstart(nprocs),Rend(nprocs)) - CALL mk_perm (n,curve,nprocs,NumCacheBlocksPerPE,Rstart,Rend) - - ALLOCATE(icos_grid_tmp(2,n)) - DO i = 1, n - icos_grid_tmp(1:2, i) = icos_grid(1:2,perm(i)) - END DO - DO i = 1, n - icos_grid(1:2, i) = icos_grid_tmp(1:2,i) - END DO - - DEALLOCATE(icos_grid_tmp) - - ALLOCATE(icos_prox_tmp(6,n)) - ALLOCATE(icos_nprox_tmp(n)) - DO i = 1, n - icos_prox_tmp(1:6, i) = icos_prox(1:6,perm(i)) - icos_nprox_tmp(i) = icos_nprox(perm(i)) - DO j = 1, icos_nprox_tmp(i) - icos_prox_tmp(j, i) = inv_perm(icos_prox_tmp(j, i)) -! icos_prox_tmp(j, i) = perm(icos_prox_tmp(j, i)) - END DO - END DO - DO i = 1, n - icos_prox(1:6, i) = icos_prox_tmp(1:6,i) - icos_nprox(i) = icos_nprox_tmp(i) - END DO - DEALLOCATE(icos_prox_tmp) - DEALLOCATE(icos_nprox_tmp) - - call UnstructuredHaloCalc(6,n,nprocs,icos_prox,Rstart,Rend,HaloSize) !Get halo size - allocate(RegionSize(nprocs)) - do PE=1,nprocs - RegionSize(PE) = Rend(PE)-Rstart(PE)+1 - enddo - deallocate(Rstart,Rend) - print*,'HaloSize,minval(RegionSize)',HaloSize,minval(RegionSize) - if(HaloSize > minval(RegionSize)) then - !Halo size greater than interior size causes problems in GET_PPP_TRANS_INDX - !and perhaps other places because it was not allowed by SMS and therefore not tested. - print*,'Error in GridGen: Halo size > interior size', & - HaloSize,minval(RegionSize) - print*,'Reduce the number of processor and/or increase ', & - 'the G level and try again' - stop - endif - - ALLOCATE(icos_edge_tmp(6,2,2,n)) - DO i = 1, n - icos_edge_tmp(1:6, 1:2, 1:2, i) = icos_edge(1:6,1:2, 1:2, perm(i)) - END DO - DO i = 1, n - icos_edge(1:6, 1:2, 1:2, i) = icos_edge_tmp(1:6,1:2, 1:2, i) - END DO - DEALLOCATE(icos_edge_tmp) - - IF (statistics) THEN - CALL minmax_values(n, icos_grid, icos_prox, icos_nprox, icos_edge) - END IF - DEALLOCATE(xyz) - - ! Write out the grid information: - - ! halo size is used for SMS parallel runs. - write(DecompInfoFile,"('DecompInfo_',i0,'.dat')") nprocs - open (10,file=TRIM(DecompInfoFile)) - write(10,*) HaloSize - write(10,*) RegionSize - close(10) - deallocate(RegionSize) - - write_human_readable = .FALSE. - IF (write_human_readable) THEN - !TBH: write a more easily human-readable file - OPEN (40,file="icos_grid_info_human.txt",form='formatted') - WRITE(40,*) 'number of grid cells = ',n - WRITE(40,*) 'glvl = ',glvl - WRITE(40,*) 'curve = ',curve - IF (.not.double_precision) THEN - ALLOCATE(icos_grid4(2,n)) - ALLOCATE(icos_edge4(6,2,2,n)) - icos_grid4 = icos_grid - icos_edge4 = icos_edge - ENDIF - do i=1,n - WRITE(40,*) 'Grid cell ',i - WRITE(40,*) ' Number of sides = ',icos_nprox(i) - do isn = 1,icos_nprox(i) - WRITE(40,*) ' Neighbor across edge #',isn,' = ',icos_prox(isn,i) - enddo - IF (double_precision) THEN - WRITE(40,*) ' Latitude of cell center (radians) = ',icos_grid(1,i) - WRITE(40,*) ' Longitude of cell center (radians) = ',icos_grid(2,i) - do isn = 1,icos_nprox(i) - WRITE(40,*) ' Edge #',isn,':' - WRITE(40,*) ' Lat-lon of 1st edge endpoint = ', & - icos_edge(isn,1,1,i),',',icos_edge(isn,1,2,i) - WRITE(40,*) ' Lat-lon of 2nd edge endpoint = ', & - icos_edge(isn,2,1,i),',',icos_edge(isn,2,2,i) - enddo - ELSE - WRITE(40,*) ' Latitude of cell center (radians) = ',icos_grid4(1,i) - WRITE(40,*) ' Longitude of cell center (radians) = ',icos_grid4(2,i) - do isn = 1,icos_nprox(i) - WRITE(40,*) ' Edge #',isn,':' - WRITE(40,*) ' Lat-lon of 1st edge endpoint = ', & - icos_edge4(isn,1,1,i),',',icos_edge4(isn,1,2,i) - WRITE(40,*) ' Lat-lon of 2nd edge endpoint = ', & - icos_edge4(isn,2,1,i),',',icos_edge4(isn,2,2,i) - enddo - ENDIF - enddo - IF (.not.double_precision) THEN - DEALLOCATE(icos_grid4) - DEALLOCATE(icos_edge4) - ENDIF - CLOSE (40) - ENDIF ! write_human_readable - - OPEN (10,file="icos_grid_info_level.dat",form='unformatted') - call WriteGlvlHeader (10,glvl ) - call WriteCurveHeader(10,curve) - - IF (double_precision) THEN - WRITE(10) icos_grid(1,1:n),icos_grid(2,1:n) - do isn = 1,size(icos_prox,1) - WRITE(10) icos_prox(isn,1:n) - enddo - WRITE(10) icos_nprox(1:n) - do i3 = 1,size(icos_edge,3) - do i2 = 1,size(icos_edge,2) - do isn = 1,size(icos_edge,1) - WRITE(10) icos_edge(isn,i2,i3,1:n) - enddo - enddo - enddo - do i=1,n - if(perm(inv_perm(i)) /= i) then - print*,'inv_perm error in GridInfoGen',i,inv_perm(i),perm(inv_perm(i)) - stop - endif - enddo - WRITE(10) inv_perm - DEALLOCATE(icos_grid) - DEALLOCATE(icos_prox) - DEALLOCATE(icos_nprox) - DEALLOCATE(icos_edge) - ELSE - ALLOCATE(icos_grid4(2,n)) - icos_grid4 = icos_grid - DEALLOCATE(icos_grid) - ALLOCATE(icos_edge4(6,2,2,n)) - icos_edge4 = icos_edge - DEALLOCATE(icos_edge) - WRITE(10) icos_grid4(1,1:n),icos_grid4(2,1:n) - do isn = 1,size(icos_prox,1) - WRITE(10) icos_prox(isn,1:n) - enddo - WRITE(10) icos_nprox(1:n) - do i3 = 1,size(icos_edge4,3) - do i2 = 1,size(icos_edge4,2) - do isn = 1,size(icos_edge4,1) - WRITE(10) icos_edge4(isn,i2,i3,1:n) - enddo - enddo - enddo - do i=1,n - if(perm(inv_perm(i)) /= i) then - print*,'inv_perm error in GridInfoGen',i,inv_perm(i),perm(inv_perm(i)) - stop - endif - enddo - WRITE(10) inv_perm - DEALLOCATE(icos_grid4) - DEALLOCATE(icos_prox) - DEALLOCATE(icos_nprox) - DEALLOCATE(icos_edge4) - END IF - - CLOSE(10) - -END PROGRAM GridInfoGen - -! functions and subroutines - -INTEGER FUNCTION grid_point_type(seq, diam_sz, edge_ln) - IMPLICIT NONE - INTEGER seq, diam_sz, edge_ln - INTEGER i - - i = MOD((seq - 1), 2 * diam_sz) - - IF (i < edge_ln ) THEN - grid_point_type = 1 - ELSE IF (MOD(i, edge_ln) == 0 .AND. i <= diam_sz) THEN - grid_point_type = 2 - ELSE IF (MOD(i, edge_ln) == 0 .AND. i < 2 * diam_sz) THEN - grid_point_type = 3 - ELSE IF (MOD(i, edge_ln) == 1 .AND. i < diam_sz) THEN - grid_point_type = 4 - ELSE IF (MOD(i, edge_ln) == 1 .AND. i < 2 * diam_sz) THEN - grid_point_type = 5 - ELSE IF (i >= 2 * diam_sz - edge_ln + 1) THEN - grid_point_type = 6 - ELSE - grid_point_type = 0 - END IF - -END FUNCTION grid_point_type - - -SUBROUTINE special_points(i, nb, diam_sz, edge_ln, type) - INTEGER i, diam_sz, edge_ln, type - INTEGER nb(6) - - INTEGER r_i, pg_idx - - type = 0 - r_i = MOD((i - 1), 2 * diam_sz) - IF (i == 1) THEN ! North pole - nb(1) = 2 - DO k = 2, 5 - nb(k) = nb(k-1) + 2 * diam_sz - END DO - nb(6) = -1 - type = 1 - ELSE IF (i == 10 * diam_sz + 2) THEN ! South pole - nb(1) = 10 * diam_sz + 1 - DO k = 2, 5 - nb(k) = nb(k-1) - 2 * diam_sz - END DO - nb(6) = -1 - type = 1 - ELSE IF (r_i == 1) THEN ! top end point of the parallel graph - nb(1) = 1 !North pole - IF ((i - 2 * diam_sz) > 0) THEN - nb(2) = i - 2 * diam_sz - ELSE - nb(2) = i + 8 * diam_sz - END IF - nb(3) = nb(2) + edge_ln - nb(4) = i + 1 - nb(5) = i + edge_ln - nb(6) = MOD(i + 2 * diam_sz, 10 * diam_sz) - type = 2 - ELSE IF (r_i == 0) THEN ! bottom end point of the parallel graph - nb(1) = i - edge_ln - IF ((i - 4 * diam_sz) > 0) THEN - nb(2) = i - 2 * diam_sz - 1 - ELSE - nb(2) = i + 8 * diam_sz - 1 - END IF - nb(3) = nb(2) + 1 - nb(4) = 10 * diam_sz + 2 ! South pole - IF ((i + 2 * diam_sz ) <= 10 * diam_sz + 1) THEN - nb(5) = i + 2 * diam_sz - ELSE - nb(5) = i + 2 * diam_sz - 10 * diam_sz - END IF - nb(6) = i - 1 - type = 2 - ELSE IF (r_i == edge_ln) THEN ! 5 neighbors grid point in the first diamond - nb(1) = i - 1 - pg_idx = i / (2 * diam_sz) - if (pg_idx >= 1) THEN - pg_idx = pg_idx - 1 - ELSE - pg_idx = 4 - END IF - nb(2) = pg_idx * 2 * diam_sz + diam_sz - edge_ln + 2 - nb(3) = nb(2) + edge_ln - nb(4) = i + edge_ln - nb(5) = nb(4) - 1 - nb(6) = -1 - type = 1 - ELSE IF (r_i == diam_sz + edge_ln) THEN ! 5 neighbors grid point in the second diamond - nb(1) = i - 1 - nb(2) = i - edge_ln - pg_idx = i / (2 * diam_sz) - if (pg_idx >= 1) THEN - pg_idx = pg_idx - 1 - ELSE - pg_idx = 4 - END IF - nb(3) = pg_idx * 2 * diam_sz + 2 * diam_sz - edge_ln + 2 - nb(4) = i + edge_ln - nb(5) = nb(4) - 1 - nb(6) = -1 - type = 1 - ELSE IF (r_i == 2 * diam_sz - edge_ln + 1) THEN - nb(1) = i - edge_ln - nb(2) = nb(1) + 1 - nb(3) = nb(2) + edge_ln - pg_idx = (i - 1) / (2 * diam_sz) - IF (pg_idx < 4) THEN - pg_idx = pg_idx + 1 - ELSE - pg_idx = 0 - END IF - r_i = MOD((i - 1), 2 * diam_sz) - nb(4) = pg_idx * 2 * diam_sz + r_i - diam_sz + 3 * edge_ln - nb(5) = nb(4) - edge_ln - nb(6) = nb(5) - edge_ln - type = 2 - END IF -END SUBROUTINE special_points - - -REAL*8 FUNCTION cos_theta(v,w) - -IMPLICIT NONE - -REAL, INTENT(IN) :: v(3),w(3) - - cos_theta = DOT_PRODUCT(v,w) / & - SQRT(DOT_PRODUCT(v,v))/ & - SQRT(DOT_PRODUCT(w,w)) - -END FUNCTION cos_theta - -SUBROUTINE cross_product(p,v,w) - -IMPLICIT NONE - -REAL*8, INTENT(IN) :: v(3),w(3) -REAL*8, INTENT(OUT) :: p(3) - -p(1) = v(2)*w(3)-v(3)*w(2) -p(2) = v(3)*w(1)-v(1)*w(3) -p(3) = v(1)*w(2)-v(2)*w(1) - -END SUBROUTINE cross_product - -SUBROUTINE minmax_values(m, icos_grid, icos_prox, icos_nprox, icos_edge) - - IMPLICIT NONE - - REAL*8 :: dist - INTEGER i, j, k - INTEGER :: m - INTEGER :: icos_prox(6,m),icos_nprox(m) - REAL*8 :: icos_grid(2,m) ! grid location (ll) - REAL*8 :: icos_edge(6,2,2,m) ! end points of edges (ll) - - REAL*8 max_value, min_value, value(6), ratio, dist_corner(6) - REAL*8 border_value, max_value_wc, min_value_wc, max_ratio_wc, max_ratio_wt, edge_sum - REAL*8 avg_grid_dist, avg_grid_dist_sq - REAL*8 a, b, c, s, area - REAL*8 lat, lon, lat1, lon1, lat2, lon2, lat3, lon3, min_apr, avg_apr - INTEGER :: idx1, idx2, next - - avg_grid_dist = 0.0 - avg_grid_dist_sq = 0.0 - max_value = 0.0 - min_value = 1000000.0 - max_value_wc = 0.0 - min_value_wc = 1000000.0 - max_ratio_wc = 0.0 - max_ratio_wt = 0.0 - border_value = dist(icos_grid(1, 1), icos_grid(2, 1), icos_grid(1, 2), icos_grid(2, 2)) - DO i = 1, m - DO j = 1, icos_nprox(i) - value(j) = dist(icos_grid(1, i), icos_grid(2, i), icos_grid(1, icos_prox(j, i)), icos_grid(2, icos_prox(j, i))) -! PRINT*, i, icos_prox(j, i), value(j) / border_value - avg_grid_dist = avg_grid_dist + value(j) - avg_grid_dist_sq = avg_grid_dist_sq + value(j) * value(j) - IF (value(j) < min_value) THEN - min_value = value(j) - END IF - IF (value(j) > max_value) THEN - max_value = value(j) - END IF - IF (value(j) < min_value_wc) THEN - min_value_wc = value(j) - END IF - IF (value(j) > max_value_wc) THEN - max_value_wc = value(j) - END IF - END DO - DO j = 1, icos_nprox(i) - IF (j == icos_nprox(i)) THEN - ratio = max(value(j), value(1)) / min(value(j), value(1)) - idx2 = 1 - ELSE - ratio = max(value(j), value(j+1)) / min(value(j), value(j+1)) - idx2 = j + 1 - END IF - IF (max_ratio_wt < ratio) THEN - max_ratio_wt = ratio - idx1 = i - END IF - END DO - IF (max_ratio_wc < max_value_wc / min_value_wc) THEN - max_ratio_wc = max_value_wc / min_value_wc - END IF - max_value_wc = 0.0 - min_value_wc = 1000000.0 - END DO - PRINT*,'min max distance between neighboring grid points = ', min_value, max_value, & - max_value / min_value - PRINT*,'min max distance ratio within a triangle = ', max_ratio_wt, 'at ', idx1 - PRINT*,'min max distance ratio within a cell = ', max_ratio_wc - PRINT*,'average distance between neighboring grid points = ', avg_grid_dist / (6 * m) - PRINT*,'average distance square between neighboring grid points =', & - avg_grid_dist_sq / (6 * m) - - max_value = 0.0 - min_value = 1000000.0 - min_apr = 1000000.0 - avg_apr = 0.0 - DO i = 1, m - DO j = 1, icos_nprox(i) - value(j) = dist(icos_edge(j, 1, 1, i), icos_edge(j, 1, 2, i), & - icos_edge(j, 2, 1, i), icos_edge(j, 2, 2, i)) - dist_corner(j) = dist(icos_edge(j, 1, 1, i), icos_edge(j, 1, 2, i), & - icos_grid(1, i), icos_grid(2, i)) - IF (value(j) < min_value) THEN - min_value = value(j) - lat = icos_grid(1, i) - lon = icos_grid(2, i) - lat1 = icos_grid(1, icos_prox(j, i)) - lon1 = icos_grid(2, icos_prox(j, i)) - IF (j < icos_nprox(i)) THEN - lat2 = icos_grid(1, icos_prox(j+1, i)) - lon2 = icos_grid(2, icos_prox(j+1, i)) - ELSE - lat2 = icos_grid(1, icos_prox(1, i)) - lon2 = icos_grid(2, icos_prox(1, i)) - END IF - IF (j < icos_nprox(i) - 1) THEN - lat3 = icos_grid(1, icos_prox(j+2, i)) - lon3 = icos_grid(2, icos_prox(j+2, i)) - ELSE - lat3 = icos_grid(1, icos_prox(2, i)) - lon3 = icos_grid(2, icos_prox(2, i)) - END IF - END IF - IF (value(j) > max_value) THEN - max_value = value(j) - END IF - END DO - edge_sum = 0 - DO j = 1, icos_nprox(i) - edge_sum = edge_sum + value(j) - IF (j == icos_nprox(i)) THEN - next = 1 - ELSE - next = j+1 - END IF - a = value(j) / 6371.220 - b = dist_corner(j) / 6371.220 - c = dist_corner(next) / 6371.220 - s = (a + b + c) / 2.0 - area = tan(s) * tan(s-a) * tan (s-b) * tan(s-c) - area = atan(area) - area = area * 4.0 - avg_apr = avg_apr + area / edge_sum - IF (min_apr > area / edge_sum) THEN - min_apr = area / edge_sum - END IF - END DO - END DO - avg_apr = avg_apr / m - PRINT*, 'min max distance of the Voronoi cell edges = ', min_value, max_value - PRINT*, 'distances of three adjacent neighbors, which yields minimum Voronoi cell edge', & - dist(lat, lon, lat1, lon1),dist(lat, lon, lat2, lon2),dist(lat, lon, lat3, lon3) - PRINT*, 'average area / cell perimeter ratio = ', avg_apr, & - 'minmum area / cell perimeter ratio = ', min_apr - -END SUBROUTINE minmax_values - - -REAL*8 FUNCTION dist(lat1, lon1, lat2, lon2) - -IMPLICIT NONE - -REAL*8, INTENT(IN) :: lat1, lon1, lat2, lon2 -REAL*8 :: x - -x = COS(lat1) * COS(lat2) * COS(lon1 - lon2) + SIN(lat1) * SIN(lat2) -if(abs(x) >= 1.0D0) then - dist = 0.0D0 -else - dist = 6371.220D0 * ACOS(x) -endif - -END FUNCTION dist - diff --git a/src/fim/FIMsrc/prep/grid/GridStat.F90 b/src/fim/FIMsrc/prep/grid/GridStat.F90 deleted file mode 100644 index 6cdce20..0000000 --- a/src/fim/FIMsrc/prep/grid/GridStat.F90 +++ /dev/null @@ -1,87 +0,0 @@ - PROGRAM GridStat - -!========================================================== -! This program generates the important statistics of the -! given unstructed grid. -! -! Note: all lat/lon are in radians. -! -! HISTORY: May. 2006 by Ning Wang. -!========================================================== - - IMPLICIT NONE - INTEGER, PARAMETER :: n=163842 -! INTEGER, PARAMETER :: n=40962 - INTEGER, PARAMETER :: mnc = 6 - INTEGER :: icos_prox(mnc,n), icos_nprox(n) - REAL :: icos_grid(2,n) ! grid location (ll) - REAL :: icos_edge(mnc,2,2,n) ! end points of edges (ll) - REAL :: icos_map(mnc,n) ! mapping factor - - OPEN(unit=10,file='icos_grid_info.dat',form='unformatted') - READ(10) icos_grid(1,1:n),icos_grid(2,1:n), & - icos_prox(1:mnc,1:n),icos_nprox(1:n), & - icos_edge(1:mnc,1:2,1:2,1:n), & - icos_map(1:mnc,1:n) - CLOSE(10) - CALL minmax_values(n, mnc, icos_grid, icos_prox, icos_nprox, icos_edge) - - END PROGRAM GridStat - -SUBROUTINE minmax_values(n, mnc, icos_grid, icos_prox, icos_nprox, icos_edge) - - IMPLICIT NONE - - REAL :: dist - INTEGER i, j, k - INTEGER :: n, mnc - INTEGER :: icos_prox(mnc,n),icos_nprox(n) - REAL :: icos_grid(2,n) ! grid location (ll) - REAL :: icos_edge(mnc,2,2,n) ! end points of edges (ll) - - REAL max_value, min_value, value - - max_value = 0.0 - min_value = 1000000.0 - DO i = 1, n - DO j = 1, icos_nprox(i) - value = dist(icos_grid(1:1, i), icos_grid(2:2, i), icos_grid(1:1, icos_prox(j, i)), icos_grid(2:2, icos_prox(j, i))) - min_value = min(value, min_value) - max_value = max(value, max_value) - END DO - END DO - PRINT*, 'min max distance between neighboring grid points = ', min_value, max_value - - max_value = 0.0 - min_value = 1000000.0 - DO i = 1, n - DO j = 1, icos_nprox(i) - value = dist(icos_edge(j, 1, 1, i), icos_edge(j, 1, 2, i), & - icos_edge(j, 2, 1, i), icos_edge(j, 2, 2, i)) - min_value = min(value, min_value) - max_value = max(value, max_value) -!print*, icos_edge(j, 1, 2, i), icos_edge(j, 2, 2, i) - END DO -!print*, '---------------' - END DO - PRINT*, 'min max distance of the Voronoi cell edges = ', min_value, max_value - -END SUBROUTINE minmax_values - - -REAL FUNCTION dist(lat1, lon1, lat2, lon2) - - IMPLICIT NONE - - REAL, INTENT(IN) :: lat1, lon1, lat2, lon2 - REAL :: x - - x = COS(lat1) * COS(lat2) * COS(lon1 - lon2) + SIN(lat1) * SIN(lat2) - if(abs(x) >= 1.0) then - dist = 0.0 - else - dist = 6371.220 * ACOS(x) - endif - -END FUNCTION dist - diff --git a/src/fim/FIMsrc/prep/grid/IJblockLayout.F90 b/src/fim/FIMsrc/prep/grid/IJblockLayout.F90 deleted file mode 100644 index b914b7c..0000000 --- a/src/fim/FIMsrc/prep/grid/IJblockLayout.F90 +++ /dev/null @@ -1,68 +0,0 @@ -subroutine IJblockLayout(nPEs,nip,NB,perm,Rstart,Rend) -!This routine creates a retangular block layout. -!The blocks are determined by the factors of the number of processors. -!The algorithm is the same on each of the 10 rhombi. -!The same blocking algorithm is reapplied to create NB cache sub-blocks -!If nPEs not divisable by 10 then decompose with PEsPerRhombus which is generally better than ij -!Created this routine using logic from perm.F90 - Jacques Middlecoff Nov. 2009 - -implicit none -integer,intent(IN) :: nPEs ! Total number of processors -integer,intent(IN) :: nip ! Number of icosahedral points -INTEGER,intent(IN ) :: NB ! The number of cache blocks per processor. -integer,intent(OUT) :: perm(nip) ! Mapping from ij order to desired order -INTEGER,intent(OUT) :: Rstart(nPEs) ! Global starting location for each PE -INTEGER,intent(OUT) :: Rend (nPEs) ! Global ending location for each PE -INTEGER,PARAMETER :: MAX_DECOMP_DIMS = 2 ! If this is changed ppp_factors GetRegions and ijblock must be changed -INTEGER :: start_gc,i,rhombus,f1,f2 -INTEGER :: RhombusDim (MAX_DECOMP_DIMS) ! Number of points on rhombus side -INTEGER :: RD (MAX_DECOMP_DIMS) ! Tempory for RegionDim -INTEGER :: RF (MAX_DECOMP_DIMS) ! Temporary for rhombus or region factors -INTEGER :: RhombusFactors(MAX_DECOMP_DIMS) ! Factorization of PEsPerRhombus -INTEGER :: RegDim (nPEs) ! Temporary for region dimensions -INTEGER :: BlkDim (nPEs) ! Temporary for block dimensions -INTEGER :: PointsPerRhombus -INTEGER :: PEsPerRhombus -INTEGER :: RegionFactors (NB*nPEs,MAX_DECOMP_DIMS) ! Factorization of PEsPerRhombus -INTEGER :: RegionDim (NB*nPEs,MAX_DECOMP_DIMS) ! Region dimensions -INTEGER :: BlockDim (NB,NPEs,MAX_DECOMP_DIMS) ! Cache block dimensions -INTEGER :: PE ! Processor number for start and end - - PEsPerRhombus = nPEs/10 - PointsPerRhombus = nip /10 - RhombusDim(1) = nint(sqrt(float(PointsPerRhombus))) - RhombusDim(2) = nint(sqrt(float(PointsPerRhombus))) - call ppp_factors(PEsPerRhombus,RhombusDim,RF) - call ppp_regions(2 ,RhombusDim,RF,PEsPerRhombus,RegDim) - RegionDim(1:RF(1),1) = RegDim( 1:RF(1) ) - RegionDim(1:RF(2),2) = RegDim(RF(1)+1:RF(1)+RF(2)) - RhombusFactors = RF - do f1 = 1,RhombusFactors(1) - RD(1) = RegionDim(f1,1) - RD(2) = RegionDim( 1,2) - call ppp_factors(NB,RD,RF) - call ppp_regions(2,RD,RF,NB,BlockDim(:,f1,1)) - RegionFactors(f1,1) = RF(1) - enddo - DO f2 = 1,RhombusFactors(2) - RD(1) = RegionDim( 1,1) - RD(2) = RegionDim(f2,2) - call ppp_factors(NB,RD,RF) - call ppp_regions(2,RD,RF,NB,BlkDim) - RegionFactors(f2,2) = RF(2) - BlockDim(1:RF(2),f2,2) = BlkDim(RF(1)+1:RF(1)+RF(2)) - enddo - PE = 0 - DO rhombus = 1, 10 - start_gc = (rhombus-1)*PointsPerRhombus+2 - call ijblock_curve(nip,nPEs,NB,PE,start_gc, & - RhombusFactors,RhombusDim, & - RegionFactors, RegionDim, & - BlockDim,Rstart,Rend,perm ) - END DO - if(PE /= nPEs) then ! Must set Rstart and Rend corrrectly - call GetRegions(nip-2,1,nPEs,nPEs,.true.,Rstart,Rend) - endif - return - -end subroutine IJblockLayout diff --git a/src/fim/FIMsrc/prep/grid/Makefile b/src/fim/FIMsrc/prep/grid/Makefile deleted file mode 100644 index 9e2c5f5..0000000 --- a/src/fim/FIMsrc/prep/grid/Makefile +++ /dev/null @@ -1,52 +0,0 @@ -# grid Makefile - -SHELL = /bin/sh - -include ../../macros.make - -# Build a grid generator: - -FLAGS = $(FFLAGS) $(INCS) -GETLVL = $(BINDIR)/getlvl -GINFO = $(BINDIR)/ginfo -GRID = $(BINDIR)/grid -GRID_OBJS = icos.o bisect_triangle.o trisect_triangle.o top_gridpoints.o \ - middle.o trisect.o third.o avg.o top_triangles.o rotate.o datastru.o -GINFO_OBJS = GridGen.o hilbert.o ijblock.o perm.o IJblockLayout.o \ - GetRegions.o SquareDecomp.o SquareLayout.o datastru.o mpi_stubs.o -INCS = -I ../../cntl -I $(UTILDIR) -LIBCNTL = $(LIBDIR)/libcntl.a -LIBSYSSHARE = $(LIBDIR)/libsysshare.a -UTILDIR = ../../utils -UTILOBJS = $(UTILDIR)/read_queue_namelist.o $(UTILDIR)/headers.o \ - $(UTILDIR)/module_initial_chem_namelists.o - -#JR Only need for deleting default suffix rule is to add INCS to FFLAGS - -.SUFFIXES: -.SUFFIXES: .F90 .o - -.F90.o: - $(FC) -c $(FLAGS) $< - -all: $(GRID) $(GINFO) $(GETLVL) - -$(GRID): DEPENDENCIES $(LIBCNTL)(module_control.o) $(LIBSYSSHARE)(sys_share.o) $(GRID_OBJS) $(UTILOBJS) - $(FCserial) $(FLAGS) -o $(GRID) $(GRID_OBJS) $(UTILOBJS) $(LIBCNTL) $(LIBSYSSHARE) - -$(GINFO): DEPENDENCIES $(LIBCNTL)(module_control.o) $(LIBSYSSHARE)(sys_share.o) $(GINFO_OBJS) $(UTILOBJS) - $(FCginfo) $(FLAGS) -o $(GINFO) $(GINFO_OBJS) $(LIBCNTL) $(LIBSYSSHARE) $(UTILOBJS) -L$(SMS)/lib -lsms $(LDFLAGS) - -$(GETLVL): DEPENDENCIES getlvl.o $(LIBCNTL)(module_control.o) $(LIBSYSSHARE)(sys_share.o) $(UTILOBJS) - $(FCserial) $(FLAGS) -o $(GETLVL) getlvl.o $(LIBCNTL) $(LIBSYSSHARE) $(UTILOBJS) - -DEPENDENCIES: - $(RM) -f Filepath Srcfiles - echo "." > Filepath - ls -1 *.F90 > Srcfiles - $(MKDEPENDS) -m Filepath Srcfiles > $@ - --include DEPENDENCIES - -clean: - $(RM) *.o *.mod DEPENDENCIES diff --git a/src/fim/FIMsrc/prep/grid/SquareDecomp.F90 b/src/fim/FIMsrc/prep/grid/SquareDecomp.F90 deleted file mode 100644 index 2a70d4f..0000000 --- a/src/fim/FIMsrc/prep/grid/SquareDecomp.F90 +++ /dev/null @@ -1,86 +0,0 @@ -subroutine SquareDecomp(nip,nPEs,PEstart,NumCols,PEsPerCol,start_gc, & - FirstTime,perm,Rstart,Rend) -!This routine decomposes a rhombus into NumRegions=sum(PEsPerCol) regions -!A region is a processor footprint. -!The regions are almost square and almost equally sized. -!The algorithm divides a rhombus into columns. -!Each column has a possibly different number of rows. -!Each column is then divided equally into it's number of rows. -!The resulting layout has nearly square regions of nearly equal size. -!For a square processor count this routine gives results identical to ij-block. -!This routine returns the permutation array and the region size for each region -!The default layout is ij on the rhombus - -!Author: Jacques Middlecoff, November, 2009 - -implicit none -integer,intent(IN) :: nip ! Number of icosahedral points -integer,intent(IN) :: nPEs ! Total number of processors -integer,intent(IN) :: PEstart ! Start index for Rstart and Rend -integer,intent(IN) :: NumCols ! Number of columns the rhombus is divided into -integer,intent(IN) :: PEsPerCol(NumCols) ! Number of regions per column -integer,intent(IN) :: start_gc ! Starting point for perm -logical,intent(INOUT) :: FirstTime ! True means this is the first call -integer,intent(OUT) :: perm(nip) ! Mapping from ij order to desired order -INTEGER,intent(OUT) :: Rstart(nPEs) ! Global starting location for each region -INTEGER,intent(OUT) :: Rend (nPEs) ! Global ending location for each region -integer :: PointsPerRhombus ! Number of points in the rhombus -integer :: NumRegions ! Number of regions to divide the rhombus into -integer :: RhombusSide ! Length of each side of the rhombus -integer :: k ! index for the perm array -integer :: mincol ! index for the column with the minimum ratio -integer :: PEcolStart,PEcolEnd ! Column start and end index for Rstart and Rend -integer :: row,col,column ! Row and column indexes -integer :: ColStart,Cstart,Cend! Column starting and end indecies -integer :: ColWidth(NumCols) -integer :: PointsInThisCol -integer :: ExtraColPoints -integer :: ExtraPoint -real :: RegionSize ! Number or points in each region -real :: RowWidth - - NumRegions = sum(PEsPerCol) - PointsPerRhombus = nip/10 - RhombusSide = sqrt(Float(PointsPerRhombus)) - RegionSize = float(PointsPerRhombus)/float(NumRegions) - k = start_gc - ColStart = start_gc-1 - -!Calculate column widths adding extra points to columns with minimum ratio - do col = 1,NumCols - RowWidth = float(RhombusSide)/Float(PEsPerCol(col)) - ColWidth(col) = RegionSize/RowWidth - enddo - ExtraColPoints = RhombusSide - sum(ColWidth) - if(ExtraColPoints < 0 .or. ExtraColPoints > NumCols) then - Print*,'Error in SquareDecomp',ExtraColPoints,RhombusSide,sum(ColWidth),NumCols - stop - endif - do ExtraPoint=1,ExtraColPoints - mincol = minloc(float(colWidth)/float(PEsPerCol),DIM=1) - ColWidth(mincol) = ColWidth(mincol)+1 - enddo - -!Fill perm column by column - do column = 1,NumCols - do row =1,RhombusSide - do col=1,ColWidth(column) - perm(k) = col + (row-1)*RhombusSide + ColStart - k = k + 1 - enddo - enddo - ColStart = ColStart + ColWidth(column) - enddo - -!Calculate Rstart and Rend by equally dividing each column into nearly equal regions. - PEcolStart = PEstart - do col = 1,NumCols - PointsInThisCol = RhombusSide*ColWidth(col) - PEcolEnd = PEcolStart + PEsPerCol(col)-1 - call GetRegions(PointsInThisCol,PEcolStart,PEcolEnd,nPEs,FirstTime,Rstart,Rend) - FirstTime = .false. - PEcolStart = PEcolEnd+1 - enddo - - return -end subroutine SquareDecomp diff --git a/src/fim/FIMsrc/prep/grid/SquareLayout.F90 b/src/fim/FIMsrc/prep/grid/SquareLayout.F90 deleted file mode 100644 index 62615d0..0000000 --- a/src/fim/FIMsrc/prep/grid/SquareLayout.F90 +++ /dev/null @@ -1,73 +0,0 @@ -subroutine SquareLayout(nPEs,nip,perm,Rstart,Rend) -!This routine calculates an almost square almost equally sized layout. -!The number of processors must be divisible by 10. -!For an input processor count and number of points, this routine returns the -!permutation array and the processor footprint start and end values. -!The algorithm is the same on each of the 10 rhombi. -!The algorithm divides a rhombus into columns. -!Each column has a possibly different number of rows. -!Each column is then divided equally into it's number of rows. -!The resulting layout has nearly square footprints of nearly equal size. -!For a square processor count this routine gives results identical to ij-block. -!Compared to ij-block for 150p G7, this algorithm reduced the difference in -! largest to smallest footprint size by a factor of three: -! from a 6% difference for ij-block to a 2% difference for this algorithm. -! -!Author: Jacques Middlecoff, November, 2009 - -implicit none -integer,intent(IN) :: nPEs ! Total number of processors -integer,intent(IN) :: nip ! Number of icosahedral points -integer,intent(OUT) :: perm(nip) ! Mapping from ij order to desired order -INTEGER,intent(OUT) :: Rstart(nPEs) ! Global starting location for each PE -INTEGER,intent(OUT) :: Rend (nPEs) ! Global ending location for each PE -integer,allocatable :: PEsPerCol(:) -integer :: PEsPerRhombus -integer :: PointsPerRhombus -integer :: MinPEsPerCol,MaxPEsPerCol,PEsLeft -integer :: col,ColsLeft,NumCols -integer :: rhombus,start_gc -integer :: PEstart,PEend -logical :: FirstTime - - PEsPerRhombus = nPEs/10 - if(10*PEsPerRhombus /= nPEs) then - print*,'The number of processors must be divisible by 10, nPEs=',nPEs - stop - endif - PointsPerRhombus = nip /10 - PEstart = 1 - FirstTime = .true. - do rhombus = 1, 10 - start_gc = (rhombus-1)*PointsPerRhombus+2 - MinPEsPerCol = sqrt(float(PEsPerRhombus)) - MaxPEsPerCol = sqrt(float(PEsPerRhombus)) + 1 - if(PEsPerRhombus-MinPEsPerCol**2 ml) THEN - RETURN - END IF - - CALL compute_index(a%seqnum, b%seqnum, c%seqnum, a_b%seqnum, a_c%seqnum, b_c%seqnum, clevel, 0) - - CALL middle(a%latlon, b%latlon, a_b%latlon) - CALL middle(a%latlon, c%latlon, a_c%latlon) - CALL middle(b%latlon, c%latlon, b_c%latlon) - IF (side == 1) THEN - CALL oneThird(b_c%latlon, a1%latlon, t1%latlon) - CALL oneThird(a_c%latlon, a2%latlon, t2%latlon) - !CALL middle(t1%latlon, t2%latlon, a_b%latlon) - CALL middle(a%latlon, b%latlon, t3%latlon) - CALL average(t1%latlon, t2%latlon, t3%latlon, a_b%latlon) -! CALL gcc(b_c%latlon, a1%latlon, a_c%latlon, a2%latlon, a%latlon, b%latlon, a_b%latlon) - a3 = a_b - ELSE IF (side == 2) THEN - CALL oneThird(b_c%latlon, a1%latlon, t1%latlon) - CALL oneThird(a_b%latlon, a2%latlon, t2%latlon) - !CALL middle(t1%latlon, t2%latlon, a_c%latlon) - CALL middle(a%latlon, c%latlon, t3%latlon) - CALL average(t1%latlon, t2%latlon, t3%latlon, a_c%latlon) -! CALL gcc(b_c%latlon, a1%latlon, a_b%latlon, a2%latlon, a%latlon, c%latlon, a_c%latlon) - a3 = a_c ! save the result and return it to the caller - ELSE IF (side == 3) THEN - CALL oneThird(a_c%latlon, a1%latlon, t1%latlon) - CALL oneThird(a_b%latlon, a2%latlon, t2%latlon) - !CALL middle(t1%latlon, t2%latlon, b_c%latlon) - CALL middle(b%latlon, c%latlon, t3%latlon) - CALL average(t1%latlon, t2%latlon, t3%latlon, b_c%latlon) -! CALL gcc(a_c%latlon, a1%latlon, a_b%latlon, a2%latlon, b%latlon, c%latlon, b_c%latlon) - a3 = b_c ! save the result and return it to the caller - ELSE IF (side == 4) THEN - ! don't need to compute, it is passed in - a_b = a1 - a_c = a2 - b_c = a3 - ENDIF - -! compute some anchor points for the next level - CALL middle(a%latlon, a_b%latlon, a_a_b%latlon) - CALL middle(a_b%latlon, b%latlon, a_b_b%latlon) - CALL middle(a%latlon, a_c%latlon, a_a_c%latlon) - CALL middle(a_c%latlon, c%latlon, a_c_c%latlon) - CALL middle(b%latlon, b_c%latlon, b_b_c%latlon) - CALL middle(b_c%latlon, c%latlon, b_c_c%latlon) - -! recursive calls to create next level grid - CALL bisect_r_triangle_new2(a, a_b, a_c, b_b_c, b_c_c, anc1, clevel, 3) - CALL bisect_r_triangle_new2(a_b, b, b_c, a_a_c, a_c_c, anc2, clevel, 2) - CALL bisect_r_triangle_new2(a_c, b_c, c, a_a_b, a_b_b, anc3, clevel, 1) - CALL bisect_triangle_new2(a_b, a_c, b_c, anc1, anc2, anc3, clevel, 4) - -END SUBROUTINE bisect_r_triangle_new2 - - -RECURSIVE SUBROUTINE bisect_triangle_new(a, b, c, a1, a2, a3, level, side) - - USE DataStru - IMPLICIT NONE - - TYPE(GridPoint) :: a, b, c, a1, a2, a3 - INTEGER :: level, side - - TYPE(GridPoint) :: a_b, a_c, b_c - TYPE(GridPoint) :: ph - INTEGER :: clevel - - clevel = level + 1 - -! store the vertex grid point in an array according to their seq num. - gp(a%seqnum + offset)%latlon = a%latlon(:) - gp(b%seqnum + offset)%latlon = b%latlon(:) - gp(c%seqnum + offset)%latlon = c%latlon(:) - gp(a%seqnum + offset)%seqnum = a%seqnum - gp(b%seqnum + offset)%seqnum = b%seqnum - gp(c%seqnum + offset)%seqnum = c%seqnum - -! check to see if recursive call bottoms out. - IF (clevel > ml) THEN - RETURN - END IF - - CALL compute_index(a%seqnum, b%seqnum, c%seqnum, a_b%seqnum, a_c%seqnum, b_c%seqnum, clevel, 1) - - CALL middle(a%latlon, b%latlon, a_b%latlon) - CALL middle(a%latlon, c%latlon, a_c%latlon) - CALL middle(b%latlon, c%latlon, b_c%latlon) - IF (side == 1) THEN - CALL middle(a1%latlon, a2%latlon, a_b%latlon) - ELSE IF (side == 2) THEN - CALL middle(a1%latlon, a2%latlon, a_c%latlon) - ELSE IF (side == 3) THEN - CALL middle(a1%latlon, a2%latlon, b_c%latlon) - ELSE IF (side == 4) THEN - CALL middle(a1%latlon, c%latlon, a_b%latlon) - CALL middle(b%latlon, a2%latlon, a_c%latlon) - CALL middle(a%latlon, a3%latlon, b_c%latlon) - ENDIF - - CALL bisect_triangle_new(a, a_b, a_c, a, b_c, ph, clevel, 3) - CALL bisect_triangle_new(a_b, b, b_c, b, a_c, ph, clevel, 2) - CALL bisect_r_triangle_new(a_b, a_c, b_c, a, b, c, clevel, 4) - CALL bisect_triangle_new(a_c, b_c, c, c, a_b, ph, clevel, 1) - -END SUBROUTINE bisect_triangle_new - -RECURSIVE SUBROUTINE bisect_r_triangle_new(a, b, c, a1, a2, a3, level, side) - - USE DataStru - IMPLICIT NONE - - TYPE(GridPoint) :: a, b, c, a1, a2, a3 - INTEGER :: level, side - - TYPE(GridPoint) :: a_b, a_c, b_c - TYPE(GridPoint) :: ph - INTEGER :: clevel - - gp(a%seqnum + offset)%latlon = a%latlon(:) - gp(b%seqnum + offset)%latlon = b%latlon(:) - gp(c%seqnum + offset)%latlon = c%latlon(:) - - gp(a%seqnum + offset)%seqnum = a%seqnum - gp(b%seqnum + offset)%seqnum = b%seqnum - gp(c%seqnum + offset)%seqnum = c%seqnum - - clevel = level + 1 -! check to see if recursive call bottoms out. - IF (clevel > ml) THEN - RETURN - END IF - - CALL compute_index(a%seqnum, b%seqnum, c%seqnum, a_b%seqnum, a_c%seqnum, b_c%seqnum, clevel, 0) - - CALL middle(a%latlon, b%latlon, a_b%latlon) - CALL middle(a%latlon, c%latlon, a_c%latlon) - CALL middle(b%latlon, c%latlon, b_c%latlon) - IF (side == 1) THEN - CALL middle(a1%latlon, a2%latlon, a_b%latlon) - ELSE IF (side == 2) THEN - CALL middle(a1%latlon, a2%latlon, a_c%latlon) - ELSE IF (side == 3) THEN - CALL middle(a1%latlon, a2%latlon, b_c%latlon) - ELSE IF (side == 4) THEN - CALL middle(a1%latlon, c%latlon, a_b%latlon) - CALL middle(b%latlon, a2%latlon, a_c%latlon) - CALL middle(a%latlon, a3%latlon, b_c%latlon) - ENDIF - - CALL bisect_r_triangle_new(a, a_b, a_c, a, b_c, ph, clevel, 3) - CALL bisect_triangle_new(a_b, a_c, b_c, a, b, c, clevel, 4) - CALL bisect_r_triangle_new(a_b, b, b_c, b, a_c, ph, clevel, 2) - CALL bisect_r_triangle_new(a_c, b_c, c, c, a_b, ph, clevel, 1) - -END SUBROUTINE bisect_r_triangle_new - -SUBROUTINE compute_index(a_sn, b_sn, c_sn, a_b_sn, a_c_sn, b_c_sn, level, delta_triangle) - - USE DataStru - IMPLICIT NONE - INTEGER :: a_sn, b_sn, c_sn, a_b_sn, a_c_sn, b_c_sn, level, delta_triangle - INTEGER :: init_stride, nrtm, stride1, stride2 - REAL :: row - - init_stride = (sl + 1) - row(a_sn) - nrtm = (row(c_sn) - row(a_sn)) / 2 - stride1 = (2 * init_stride - (nrtm -1)) * nrtm / 2 - stride2 = (2 * (init_stride - 1) - (nrtm -1)) * nrtm / 2 - a_c_sn = a_sn + stride1 - - IF (delta_triangle == 1) THEN - a_b_sn = (a_sn + b_sn) / 2 - b_c_sn = b_sn + stride2 - ELSE - b_c_sn = (b_sn + c_sn) / 2 - a_b_sn = a_sn + stride2 - END IF - -END SUBROUTINE compute_index - -REAL FUNCTION row(x) - - USE DataStru - - IMPLICIT NONE - - INTEGER :: x, s, n - - s = init_c_sn - x - n = INT((sqrt(REAL(1 + 8 * s)) - 1) / 2) - row = sl - n - -END FUNCTION row - -SUBROUTINE remove_edge1(start_idx, end_idx) - - USE DataStru - IMPLICIT NONE - - INTEGER start_idx, end_idx - INTEGER stride, idx, idx2 - -! mark the grid points that need to be removed - stride = sl + 1 - idx = start_idx - DO WHILE (idx <= end_idx .AND. stride >= 0) - gp(idx)%seqnum = -1 - idx = idx + stride - stride = stride - 1 - END DO - -! skip marked grid points, and ... - stride = 0 - idx2 = start_idx - DO idx = start_idx, end_idx - IF (gp(idx)%seqnum == -1) THEN - stride = stride + 1 - CYCLE - END IF - gp(idx2)%latlon = gp(idx)%latlon - gp(idx2)%seqnum = gp(idx)%seqnum - stride - idx2 = idx2 + 1 - END DO - - end_idx = end_idx - stride - -END SUBROUTINE remove_edge1 - - -SUBROUTINE remove_edge2(start_idx, end_idx) - - USE DataStru - IMPLICIT NONE - - INTEGER start_idx, end_idx - INTEGER stride, idx, idx2 - -! mark the grid points that need to be removed - DO idx = start_idx, start_idx + sl - gp(idx)%seqnum = -1 - END DO - - stride = sl - 1 - idx = start_idx + sl * 2 - DO WHILE (idx <= end_idx .AND. stride >= 0) - gp(idx)%seqnum = -1 - idx = idx + stride - stride = stride - 1 - END DO - -! skip marked grid points, and ... - stride = 0 - idx2 = start_idx - DO idx = start_idx, end_idx - IF (gp(idx)%seqnum == -1) THEN - stride = stride + 1 - CYCLE - END IF - gp(idx2)%latlon = gp(idx)%latlon(:) - gp(idx2)%seqnum = gp(idx)%seqnum - stride - idx2 = idx2 + 1 - END DO - - end_idx = end_idx - stride - -END SUBROUTINE remove_edge2 - -SUBROUTINE combine(triangle1, triangle2) - - USE DataStru - IMPLICIT NONE - - TYPE(Triangle) :: triangle1, triangle2 - INTEGER idx, idx2, stride, gap, delta - - DO idx = triangle2%start_idx, triangle2%end_idx - gp(idx)%seqnum = gp(triangle2%end_idx)%seqnum - gp(idx)%seqnum - END DO - -! for triangle one ... - stride = sl - 3 - gap = 1 - delta = 1 - - idx = triangle1%start_idx + (2 * sl - 1) - DO WHILE (idx <= triangle1%end_idx) - DO idx2 = idx, idx + stride - gp(idx2)%seqnum = gp(idx2)%seqnum + gap - END DO - stride = stride - 1 - delta = delta + 1 - gap = gap + delta - idx = idx2 - END DO - -! for triangle two ... - - stride = 0 - gap = 2 * sl - 1 - delta = sl - 1 - - idx = triangle2%end_idx - DO WHILE (idx >= triangle2%start_idx) - DO idx2 = idx, idx - stride, -1 - gp(idx2)%seqnum = gp(idx2)%seqnum + gap - END DO - stride = stride + 1 - delta = delta - 1 - gap = gap + delta - idx = idx2 - END DO - - -END SUBROUTINE combine - diff --git a/src/fim/FIMsrc/prep/grid/datastru.F90 b/src/fim/FIMsrc/prep/grid/datastru.F90 deleted file mode 100644 index 2068fd3..0000000 --- a/src/fim/FIMsrc/prep/grid/datastru.F90 +++ /dev/null @@ -1,36 +0,0 @@ -MODULE DataStru - - INTEGER :: ml, sl, offset - INTEGER :: init_a_sn, init_b_sn, init_c_sn - INTEGER :: gc, xdim, ydim, orient - - TYPE GridPoint - REAL*8 :: latlon(2) - INTEGER :: seqnum - END TYPE GridPoint - - TYPE GridPointWnb - REAL*8 :: latlon(2) - REAL*8 :: neighbor(2,6) - INTEGER :: seqnum - END TYPE GridPointWnb - - TYPE GridPointXYZ - REAL*8 :: x - REAL*8 :: y - REAL*8 :: z - INTEGER :: seqnum - END TYPE GridPointXYZ - - TYPE Triangle - TYPE(GridPoint) :: vertex(3) - INTEGER start_idx, end_idx - END TYPE Triangle - - TYPE(GridPoint), TARGET, ALLOCATABLE :: gp(:) - INTEGER, ALLOCATABLE :: perm(:) - INTEGER, ALLOCATABLE :: inv_perm(:) - -END MODULE DataStru - - diff --git a/src/fim/FIMsrc/prep/grid/dnspl.F90 b/src/fim/FIMsrc/prep/grid/dnspl.F90 deleted file mode 100644 index da9937f..0000000 --- a/src/fim/FIMsrc/prep/grid/dnspl.F90 +++ /dev/null @@ -1,90 +0,0 @@ -!============================================================= -! -! Ning Wang, March 2007 -! -!============================================================= - program dnspl - IMPLICIT NONE - -! command line argument count - INTEGER :: iargc - CHARACTER(len=128) :: org_file - CHARACTER(len=1) :: glvls - INTEGER :: nip, glvl, i, seq - REAL*8 lat, lon, d2r - - REAL*8 ll(2), min_dist - INTEGER nn(3) - - REAL*8, ALLOCATABLE :: icos_grid_h(:,:) ! grid location (ll) - REAL*8, ALLOCATABLE :: icos_grid(:,:) ! grid location (ll) - INTEGER, ALLOCATABLE ::seqs(:) ! seq numbers for the grid - - IF (iargc() .NE. 2 ) THEN - WRITE(0,*) 'Usage: dnspl [original grid file] [glvl:4-8]' - STOP - END IF - - CALL getarg(1,org_file) - CALL getarg(2,glvls) - - d2r = 4.0 * atan(1.0) / 180.0 - - glvl = 7 - nip = 10 * (2 ** (2 * glvl)) + 2 - -! init kd tree for the original high resolution grid. - CALL init_kd_tree2(org_file, nip, 3) - -! allocate the data structure for original high resolution grid. - ALLOCATE(icos_grid_h(nip, 2)) - -! open and read in the original high resolution grid file. - OPEN(10,file=org_file) - READ(10,*) nip - DO i = 1, nip - READ(10,*) seq, lat, lon - icos_grid_h(i,1) = lat - icos_grid_h(i,2) = lon - END DO - CLOSE(10) - -! allocate the data structure for low resolution grid. - READ(glvls, *) glvl - nip = 10 * (2 ** (2 * glvl)) + 2 - ALLOCATE(icos_grid(nip, 2)) - ALLOCATE(seqs(nip)) - -! open and read in the low resolution grid file. - OPEN (10,"icos_grid_level.dat") - call TestGlvlHeader(10,'icos_grid_level.dat','dnspl',glvl) - READ(10,*) nip - DO i = 1, nip - READ(10,*) seqs(i), lat, lon - icos_grid(i,1) = lat - icos_grid(i,2) = lon - END DO - CLOSE(10) - - DO i = 1, nip - ll(1) = icos_grid(i,1) * d2r - ll(2) = icos_grid(i,2) * d2r - CALL knn_search(ll, nn, min_dist) - icos_grid(i,1) = icos_grid_h(nn(1),1) - icos_grid(i,2) = icos_grid_h(nn(1),2) - END DO - -! open and write in the down sampled low resolution grid file. - OPEN(10,file="icos_grid_level.dat") - call WriteGlvlHeader(10,glvls) - WRITE(10,*) nip - DO i = 1, nip - lat = icos_grid(i,1) - lon = icos_grid(i,2) - WRITE(10,*) seqs(i), lat, lon - END DO - CLOSE(10) - - END program dnspl - - diff --git a/src/fim/FIMsrc/prep/grid/getlvl.F90 b/src/fim/FIMsrc/prep/grid/getlvl.F90 deleted file mode 100644 index f43d0c8..0000000 --- a/src/fim/FIMsrc/prep/grid/getlvl.F90 +++ /dev/null @@ -1,347 +0,0 @@ -! -!********************************************************************* - program getlvl -! Loads the initial variables and constants to start sgm -! Alexander E. MacDonald 11/27/05 -! J. Lee September, 2005 -! N.W. Added namelist definition and reading statements. -! Changed to dynamic memory allocation for big arrays. -! N.W. Changed the computation of nip to work with the icos grid -! that has mixed bi-section and tri-section subdivisions. -! N.W. Changed to a more accurate computation of the middle points -! of the Voronoi-cell edges. -!********************************************************************* -use module_control,only: control,glvl,nip,curve -use read_queue_namelist, only: ReturnNIP -implicit none - -integer, parameter :: npp=6 -integer, parameter :: nd=2 -real, parameter :: pi = 3.1415926535897 -real, parameter :: ae = 6371220. !earth radius - -! -real*4 map -real*4 conr_xy(npp,2,2) -real*4 prox_xy(npp,2) ! holds x and y locs for prox pts (m) - -! -real*4 eltp(4),elnp(4) ! 4 lat/lon surrounding a particular edge -real*4 conr_tmp(1:6,1:2) - -! -real*4, allocatable :: conr_ll(:,:,:,:), lle(:,:,:) -integer, allocatable :: nprox(:), prox(:, :), proxs(:, :), inv_perm(:) -real*4, allocatable :: lat(:),lon(:),area(:) -real*4, allocatable :: sideln(:, :),rprox_ln(:, :) -real*4, allocatable :: sidevec_c(:, :, :),sidevec_e(:, :, :) -real*4, allocatable :: cs(:,:,:),sn(:,:,:) - -integer :: ipn, isn, ism, ixy, ipt, iprox, ip1, im1, j, idx, i2, i3 -real :: xlat, xlon, xxp, yyp, xxm, yym, xx, yy, xltc, xlnc, rf -real :: p1(2), p2(2), pm(2) - -call control - -! allocate memory for arrays -ALLOCATE(conr_ll(npp,2,2,nip)) -ALLOCATE(lle(npp,2,nip)) -ALLOCATE(nprox(nip)) -ALLOCATE(prox(npp, nip)) -ALLOCATE(proxs(npp, nip)) -ALLOCATE(lat(nip)) -ALLOCATE(lon(nip)) -ALLOCATE(area(nip)) -ALLOCATE(sideln(npp, nip)) -ALLOCATE(rprox_ln(npp, nip)) -ALLOCATE(sidevec_c(nd, npp, nip)) -ALLOCATE(sidevec_e(nd, npp, nip)) -ALLOCATE(cs(4,npp,nip)) -ALLOCATE(sn(4,npp,nip)) -ALLOCATE(inv_perm(nip)) - -print*, 'start getlvl ... ' -!................................................................... - -cs (:,6,:) = 0.0 -sn (:,6,:) = 0.0 -sidevec_c(:,6,:) = 0.0 -sidevec_e(:,6,:) = 0.0 -sideln ( 6,:) = 0.0 -rprox_ln ( 6,:) = 0.0 - -OPEN (10,file='icos_grid_info_level.dat',form='unformatted') -call TestGlvlHeader (10, 'icos_grid_info_level.dat','getlvl',glvl) -call TestCurveHeader(10, 'icos_grid_info_level.dat','getlvl',curve) -READ(10) lat,lon -do isn = 1,size(prox,1) - READ(10) prox(isn,:) -enddo -READ(10) nprox -do i3 = 1,size(conr_ll,3) - do i2 = 1,size(conr_ll,2) - do isn = 1,size(conr_ll,1) - READ(10) conr_ll(isn,i2,i3,:) - enddo - enddo -enddo -READ(10) inv_perm -CLOSE(10) -! -do ipn=1,nip -if(lon(ipn).lt.0.) lon(ipn)=lon(ipn)+2.*pi -end do -! -do ipn=1,nip -! -do isn=1,nprox(ipn) -do ixy=1,2 -conr_tmp(isn,ixy)=conr_ll(isn,1,ixy,ipn) -conr_tmp(isn,ixy)=conr_ll(isn,1,ixy,ipn) -end do -end do -! -do isn=1,nprox(ipn) -ism=isn-1 -if(isn.eq.1) ism=nprox(ipn) -do ixy=1,2 -conr_ll(isn,1,ixy,ipn)=conr_tmp(ism,ixy) -conr_ll(isn,2,ixy,ipn)=conr_tmp(isn,ixy) -end do -! -end do -end do -! -proxs=-99 -do ipn=1,nip -do 20 isn=1,nprox(ipn) -iprox=prox(isn,ipn) -do j=1,nprox(iprox) -if(prox(j,iprox).eq.ipn) then -proxs(isn,ipn)=j -goto 20 -end if -end do -20 continue -end do -! -!................................................................... -! -do ipn=1,nip -do isn=1,nprox(ipn) -!do ixy=1,nd -!lle(isn,ixy,ipn)=.5*(conr_ll(isn,1,ixy,ipn)+conr_ll(isn,2,ixy,ipn)) -!end do -!if ( abs( conr_ll(isn,1,2,ipn)-conr_ll(isn,2,2,ipn)).gt.pi) & -!lle(isn,2,ipn)=lle(isn,2,ipn)-pi - -p1(1:2) = conr_ll(isn,1,1:2,ipn) -p2(1:2) = conr_ll(isn,2,1:2,ipn) -call middle_r(p1, p2, pm) -lle(isn, 1:2, ipn) = pm(1:2) - -end do -end do -! -!................................................................... -!Caculate sidevec and lat/lon at edges -! -do ipn=1,nip -do isn=1,nprox(ipn) -xlon=lon(prox(isn,ipn)) -xlat=lat(prox(isn,ipn)) -call ll2xy(lon(ipn),lat(ipn),xlon,xlat,prox_xy(isn,1),prox_xy(isn,2)) -rprox_ln(isn,ipn)=1./(ae*sqrt(prox_xy(isn,1)**2+prox_xy(isn,2)**2)) -do ipt=1,2 -xlon=conr_ll(isn,ipt,2,ipn) -xlat=conr_ll(isn,ipt,1,ipn) -call ll2xy(lon(ipn),lat(ipn),xlon,xlat,conr_xy(isn,ipt,1),conr_xy(isn,ipt,2)) -end do -map=2./(1.+sin(lle(isn,1,ipn))*sin(lat(ipn)) & -+cos(lle(isn,1,ipn))*cos(lat(ipn)) & - *cos(lle(isn,2,ipn)-lon(ipn))) -do ixy=1,nd -sidevec_c(ixy,isn,ipn)=ae*( conr_xy(isn,2,ixy) & - -conr_xy(isn,1,ixy)) *map -end do -call ll2xy(lle(isn,2,ipn),lle(isn,1,ipn),conr_ll(isn,2,2,ipn) & -,conr_ll(isn,2,1,ipn),xxp,yyp) -call ll2xy(lle(isn,2,ipn),lle(isn,1,ipn),conr_ll(isn,1,2,ipn) & -,conr_ll(isn,1,1,ipn),xxm,yym) -sidevec_e(1,isn,ipn)= ae*(xxp-xxm) -sidevec_e(2,isn,ipn)= ae*(yyp-yym) -sideln(isn,ipn)=sqrt(sidevec_e(1,isn,ipn)**2+sidevec_e(2,isn,ipn)**2) -end do ! isn loop -area(ipn)=0. -do isn=1,nprox(ipn) -xx=ae*.5*(conr_xy(isn,2,1)+conr_xy(isn,1,1)) -yy=ae*.5*(conr_xy(isn,2,2)+conr_xy(isn,1,2)) -area(ipn)=area(ipn)+.5*(xx*sidevec_c(2,isn,ipn)-yy*sidevec_c(1,isn,ipn)) -end do -end do ! ipn loop -! -!................................................................... -! -do ipn=1,nip - do isn=1,nprox(ipn) - xltc=lle(isn,1,ipn) - xlnc=lle(isn,2,ipn) - ip1=mod(isn,nprox(ipn))+1 - im1=isn-1 - if(im1.eq.0) im1=nprox(ipn) - eltp(1)=lat(ipn) - elnp(1)=lon(ipn) - eltp(2)=lat(prox(isn,ipn)) - elnp(2)=lon(prox(isn,ipn)) - eltp(3)=lat(prox(im1,ipn)) - elnp(3)=lon(prox(im1,ipn)) - eltp(4)=lat(prox(ip1,ipn)) - elnp(4)=lon(prox(ip1,ipn)) - do ipt=1,4 - rf=1.0/(1.0+sin(xltc)*sin(eltp(ipt))+cos(xltc)*cos(eltp(ipt))*cos(elnp(ipt)-xlnc)) - cs(ipt,isn,ipn)=rf*( cos(xltc)*cos(eltp(ipt))+(1.0+sin(xltc)*sin(eltp(ipt)))*cos(elnp(ipt)-xlnc)) - sn(ipt,isn,ipn)=-rf*sin(elnp(ipt)-xlnc)*(sin(xltc)+sin(eltp(ipt))) - end do - enddo -enddo - -open(unit=28,file="glvl.dat", form="unformatted") -call WriteGlvlHeader (28,glvl ) -call WriteCurveHeader(28,curve) -write(28) lat -write(28) lon -write(28) nprox -do isn=1,size(proxs,1) - write(28) proxs(isn,:) -enddo -do isn=1,size(prox,1) - write(28) prox(isn,:) -enddo -write(28) area -do isn=1,size(cs,2) - do idx=1,size(cs,1) - write(28) cs(idx,isn,:) - enddo -enddo -do isn=1,size(sn,2) - do idx=1,size(sn,1) - write(28) sn(idx,isn,:) - enddo -enddo -do isn=1,size(sidevec_c,2) - do idx=1,size(sidevec_c,1) - write(28) sidevec_c(idx,isn,:) - enddo -enddo -do isn=1,size(sidevec_e,2) - do idx=1,size(sidevec_e,1) - write(28) sidevec_e(idx,isn,:) - enddo -enddo -do isn=1,size(sideln,1) - write(28) sideln(isn,:) -enddo -do isn=1,size(rprox_ln,1) - write(28) rprox_ln(isn,:) -enddo -write(28) inv_perm -close(28) -print*, 'done saving glvl.dat' -!................................................................... -! -stop -end program getlvl -! -!!! -! -!############################################################# -! ll2xy.f -! Convert lat/lon to (x,y) on General Stereographic Coordinate (GSTC). -! Original program: J.Lee - 2004 -! Program testing: J.Lee - 2004 -! Modified for Non-Structure Grid: J.Lee - 2004 -!############################################################ - -! Purpose: Given latitude and longitude on Spherical coordinate, -! this subroutine computes X and Y coordinates on GSTC. -! Reference: J.Lee, G. Browning, and Y. Xie: -! TELLUS (1995), p.892-910. -! -! Input Variables : Angles are assumed in unit of "radian" -! -! (latc,lonc) : the GSTC projected point. -! ( lat, lon) : Input lat/lon in radians. -! -! OUTPUT Variables: -! -! xm : X-Coordinate values on GSTC. -! positive to East of central longitude -! ym : Y-Coordinate values on GSTC. -! positive to North of central latitude. -! Note: Output variables of xm and ym are -! nondimensionalized with "ae", the radius of earth. -! -subroutine ll2xy(lonc,latc,lon,lat,xm,ym) -! -implicit none - -integer i -real*4 lonc,latc,lon,lat,mf -real*4 xm,ym -! -mf=2.0/(1.0+sin(lat)*sin(latc)+cos(lat)*cos(latc) & - *cos(lon-lonc)) -xm=mf*(cos(lat)*sin(lon-lonc)) -ym=mf*((sin(lat)*cos(latc)-cos(lat) & - *sin(latc)*cos(lon-lonc)) ) -! -return -end - -!====================================================== -! This subroutine computes the latitude and longitude -! of the middle point between two given ponits. The -! subroutine is similar to what is in the middle.F90, -! except that its input and output variables have -! single precision and use radians for lat-lon values. -! -! Ning Wang, March, 2006 -!====================================================== - -SUBROUTINE middle_r(p1,p2,p) - - IMPLICIT NONE - - REAL :: pi, d2r - - ! Two given points in lat/lon: - REAL :: p1(2),p2(2),p(2) - - REAL :: xyz1(3),xyz2(3),xyz(3) - - pi = atan(1.0) * 4.0 - ! Convert them into Cardesian coor: - xyz1(1) = cos(p1(1)) * cos(p1(2)) - xyz1(2) = cos(p1(1)) * sin(p1(2)) - xyz1(3) = sin(p1(1)) - - xyz2(1) = cos(p2(1)) * cos(p2(2)) - xyz2(2) = cos(p2(1)) * sin(p2(2)) - xyz2(3) = sin(p2(1)) - - ! middle point: - - xyz = 0.5 * (xyz1 + xyz2) - xyz = xyz / sqrt(xyz(1)*xyz(1) + xyz(2)*xyz(2) + xyz(3)*xyz(3)) - - ! Convert the middle point to lat/lon coor: - p(1) = atan2(xyz(3), sqrt(xyz(1) * xyz(1) + xyz(2) * xyz(2))) - p(2) = atan2(xyz(2), xyz(1)) - - IF (p(2) < 0.0) THEN - p(2) = p(2) + 2 * pi - END IF - -END SUBROUTINE middle_r - - diff --git a/src/fim/FIMsrc/prep/grid/grid.nl b/src/fim/FIMsrc/prep/grid/grid.nl deleted file mode 100644 index 7eb7e47..0000000 --- a/src/fim/FIMsrc/prep/grid/grid.nl +++ /dev/null @@ -1,5 +0,0 @@ -&setup -grid_level = 7 -curve = 0 ! 0: ij order; 1: Hilbert curve order; 2:ij block order -datadir = "/p72/fim/wang/dnsmpled_grid/" ! directory for the data files -plot = 0/ diff --git a/src/fim/FIMsrc/prep/grid/gridst.F90 b/src/fim/FIMsrc/prep/grid/gridst.F90 deleted file mode 100644 index 796d940..0000000 --- a/src/fim/FIMsrc/prep/grid/gridst.F90 +++ /dev/null @@ -1,99 +0,0 @@ -!==================================================== -! This routine sets up the initial grid points for a -! Icosahedron grid. -! -! Author: Yuanfu Xie on Feb. 2002 -!==================================================== - -SUBROUTINE Gridst(top) - - USE DataStru - - IMPLICIT NONE - - REAL, PARAMETER :: Lat0 = 26.565, Lon0 = -62.0 - - TYPE(GridPoint) :: top(12) - - ! Local: - INTEGER :: i,n - - ! North pole: - top(1)%LatLon(1) = 90.0 - top(1)%LatLon(2) = 0.0 - ! 5 neighbors of this pole: - DO i=1,5 - top(1)%Neighbor(1,i) = Lat0 - top(1)%Neighbor(2,i) = Lon0+72.0*i - END DO - - ! 5 neighbors: - DO i=2,6 - top(i)%LatLon(1) = top(1)%Neighbor(1,i-1) - top(i)%LatLon(2) = top(1)%Neighbor(2,i-1) - - ! North pole is one of its neighbor: - top(i)%Neighbor(1,1) = top(1)%LatLon(1) - top(i)%Neighbor(2,1) = top(1)%LatLon(2) - - ! Left neighbor: - n = i-1 - if (n == 1) n = 5 - top(i)%Neighbor(1,2) = top(1)%Neighbor(1,n) - top(i)%Neighbor(2,2) = top(1)%Neighbor(2,n) - ! Right neighbor: - n = i+1 - if (n == 7) n = 2 - top(i)%Neighbor(1,3) = top(1)%Neighbor(1,n) - top(i)%Neighbor(2,3) = top(1)%Neighbor(2,n) - END DO - - ! South pole: - top(7)%LatLon(1) = -90.0 - top(7)%LatLon(2) = 0.0 - ! 5 neighbors: - DO i=1,5 - top(7)%Neighbor(1,i) = -Lat0 - top(7)%Neighbor(2,i) = Lon0+36.0+72.0*i - END DO - - ! 5 neighbors: - DO i=8,12 - top(i)%LatLon(1) = top(7)%Neighbor(1,i-7) - top(i)%LatLon(2) = top(7)%Neighbor(2,i-7) - - ! South pole is one of its neighbor: - top(i)%Neighbor(1,1) = top(7)%LatLon(1) - top(i)%Neighbor(2,1) = top(7)%LatLon(2) - - ! Left neighbor: - n = i-1 - if (n == 7) n = 12 - top(i)%Neighbor(1,2) = top(7)%Neighbor(1,n-7) - top(i)%Neighbor(2,2) = top(7)%Neighbor(2,n-7) - ! Right neighbor: - n = i - if (n == 12) n = 8 - top(i)%Neighbor(1,3) = top(7)%Neighbor(1,n-7) - top(i)%Neighbor(2,3) = top(7)%Neighbor(2,n-7) - END DO - - ! Neighbors cross the equater: - DO i=2,6 - - ! South starts 36 degree ahead: - n = i+6 - top(i)%Neighbor(1,4) = top(n)%LatLon(1) - top(i)%Neighbor(2,4) = top(n)%LatLon(2) - top(n)%Neighbor(1,4) = top(i)%LatLon(1) - top(n)%Neighbor(2,4) = top(i)%LatLon(2) - n = i+5 - if (n == 7) n = 12 - top(i)%Neighbor(1,5) = top(n)%LatLon(1) - top(i)%Neighbor(2,5) = top(n)%LatLon(2) - top(n)%Neighbor(1,5) = top(i)%LatLon(1) - top(n)%Neighbor(2,5) = top(i)%LatLon(2) - - END DO - -END SUBROUTINE Gridst diff --git a/src/fim/FIMsrc/prep/grid/hilbert.F90 b/src/fim/FIMsrc/prep/grid/hilbert.F90 deleted file mode 100644 index 0200368..0000000 --- a/src/fim/FIMsrc/prep/grid/hilbert.F90 +++ /dev/null @@ -1,71 +0,0 @@ -!====================================================== -! This subroutine computes the hilbert 2d filling -! curve. -! -! orientation 0: -! ________ -! | | | -! |___| ___| -! | -! ___ |___ -! | | | -! | |________| -! orientation 1, 2,and 3 rotates 90 deg each clockwise. -! -! Author: Ning Wang, Oct., 2006 -!====================================================== - -SUBROUTINE hilbert_curve(n, ort, start_gc) - USE DataStru - IMPLICIT NONE - - INTEGER :: n, ort, start_gc - INTEGER :: level - - xdim = SQRT(REAL(n)) + 0.5 - ydim = SQRT(REAL(n)) + 0.5 - level = LOG(REAL(xdim)) / LOG(2.0) + 0.5 - - gc = start_gc - offset = start_gc - 1 - orient = ort - CALL hilbert(0.0, 0.0, REAL(xdim), 0.0, 0.0, REAL(ydim),level) - -END SUBROUTINE hilbert_curve - - - -RECURSIVE SUBROUTINE hilbert(x0, y0, xis, xjs, yis, yjs, level) - USE DataStru - IMPLICIT NONE - - REAL :: x0, y0, xis, xjs, yis, yjs - INTEGER :: level - INTEGER :: i, j, tmp - IF (level == 0) THEN - i = x0 + (xis + yis) / 2 - j = y0 + (xjs + yjs) / 2 - IF (orient == 1) THEN - tmp = i - i = j - j = tmp - END IF - IF (orient == 2) THEN - i = xdim - i - 1 - END IF - IF (orient == 3) THEN - tmp = i - i = j - j = ydim - tmp - 1 - END IF - perm(gc) = offset + i + xdim * j + 1 - gc = gc + 1 - ELSE - CALL hilbert(x0, y0, yis / 2, yjs / 2, xis / 2, xjs / 2, level - 1) - CALL hilbert(x0 + xis / 2, y0 + xjs / 2, xis / 2, xjs / 2, yis /2, yjs / 2, level - 1) - CALL hilbert(x0 + xis / 2 + yis / 2, y0 + xjs / 2 + yjs / 2, xis / 2, xjs / 2, yis / 2, yjs / 2, level - 1) - CALL hilbert(x0 + xis / 2 + yis, y0 + xjs / 2 + yjs, - yis / 2, - yjs / 2, -xis / 2, -xjs / 2, level - 1) - END IF -END SUBROUTINE hilbert - - diff --git a/src/fim/FIMsrc/prep/grid/icos.F90 b/src/fim/FIMsrc/prep/grid/icos.F90 deleted file mode 100644 index 1cbabb2..0000000 --- a/src/fim/FIMsrc/prep/grid/icos.F90 +++ /dev/null @@ -1,212 +0,0 @@ -!---------------------------------------------------- -! This program generates an icosahedron grid using -! triangle_bisect subroutines. -! -! Ning Wang, Aug. 2006, partially adpated from -! Yuanfu Xie's icos.F90 files. The main feature of -! this new version is that the grid points created -! are in an order on the globe. -! -!---------------------------------------------------- - - PROGRAM Icosahedral_grid - - USE DataStru - USE read_queue_namelist,only: ReturnGLVL, ReturnSubdivNum - - IMPLICIT NONE - - ! Grid spec variables - INTEGER :: glvl ! The grid level - INTEGER :: SubdivNum(20) ! subdivision specs. - - ! Position of plot title: - CHARACTER(len=80) :: datadir - REAL*8 latlon_d(2), theta, lambda - INTEGER i, j, seqnum, nip, buf_sz - - CHARACTER(len=128) :: icos_grid_file - CHARACTER(len=1) :: gls - - ! Initial Icosahedron always has 12 grid points - TYPE(GridPointWnb) :: top_grid(12) - TYPE(Triangle) :: top_triangle(20) - -! define and read in the name list - CALL ReturnGLVL(glvl) - CALL ReturnSubdivNum(SubdivNum) - -! Set up initial 12 icosahedron points: - CALL set_top_gridpoints(top_grid) - -! Rotate the top grid to a desired orientation. It consists of two intrinsic -! rotations. First rotate theta degrees about the z axis, then lambda degrees -! about the vector v, (-sin(theta), cos(theta), 0). - theta = 10.0 - lambda = 0.0 - CALL rotate(theta, lambda, top_grid, 12) - -! Create the top triangles, with the top_grid values - CALL set_top_triangle(top_triangle, top_grid) - - ml = glvl - sl = 1 - i = 1 - DO WHILE (SubdivNum(i) /= 0 .AND. i <= ml) - sl = sl * SubdivNum(i) - i = i + 1 - ENDDO - - IF (i /= ml + 1) THEN - PRINT*, "Namelist variable 'SubdivNum' specification is incomplete." - STOP - ENDIF - SubdivNum(i) = 2 - - buf_sz = 20 * (sl + 2) * (sl + 1) / 2 - ALLOCATE(gp(buf_sz)) - -! num of icos grid points - nip = 10 * sl * sl + 2 - -! compute icos grid starting from the top grid - CALL comp_grid(top_triangle, SubdivNum, 10) - -! post process the grid foir each triangle, including remove overlapped grid points, combine triangles -! to form diamond, etc. - CALL proc_grid(top_triangle) - -! save the results - icos_grid_file = "icos_grid_level.dat" - OPEN(10,file=icos_grid_file) - WRITE(10,*) nip - ! North pole and South pole - latlon_d(1) = top_grid(1)%latlon(1) - latlon_d(2) = top_grid(1)%latlon(2) - WRITE(10,*) 1, latlon_d(1),latlon_d(2) - latlon_d(1) = top_grid(7)%latlon(1) - latlon_d(2) = top_grid(7)%latlon(2) - WRITE(10,*) nip, latlon_d(1),latlon_d(2) - DO j = 1, 20 - DO i= top_triangle(j)%start_idx, top_triangle(j)%end_idx - latlon_d = gp(i)%latlon - seqnum = gp(i)%seqnum + 1 - WRITE(10,*) seqnum, latlon_d(1),latlon_d(2) - END DO - END DO - CLOSE(10) - - DEALLOCATE(gp) - PRINT*,'End of the grid point generation.' - - END PROGRAM Icosahedral_grid - - -SUBROUTINE comp_grid(top_triangle, SubdivNum, type) - USE DataStru - - IMPLICIT NONE - - TYPE(Triangle) :: top_triangle(20) - INTEGER type, SubdivNum(20) - - INTEGER i - TYPE(GridPoint) :: ph - - init_a_sn = 0 - init_b_sn = sl - init_c_sn = (sl + 2) * (sl + 1) / 2 - 1 -! for each of the 20 triangles, recursively bisect them, and -! order them long the line that is parallel to the side (a, b) - DO i = 1,20 - PRINT*, i - offset = (i - 1) * (init_c_sn + 1) + 1 - top_triangle(i)%vertex(1)%seqnum = init_a_sn - top_triangle(i)%vertex(2)%seqnum = init_b_sn - top_triangle(i)%vertex(3)%seqnum = init_c_sn - top_triangle(i)%start_idx = offset + init_a_sn - top_triangle(i)%end_idx = offset + init_c_sn - IF (type == 0) THEN - CALL bisect_triangle(top_triangle(i)%vertex(1), top_triangle(i)%vertex(2), top_triangle(i)%vertex(3), 0) - ELSE IF (type == 2) THEN - CALL bisect_triangle_new2(top_triangle(i)%vertex(1), top_triangle(i)%vertex(2), & - top_triangle(i)%vertex(3), ph, ph, ph, 0, 0) - ELSE IF (type == 10) THEN - IF (SubdivNum(1) == 2) THEN - CALL bisect_triangle_nasr(top_triangle(i)%vertex(1), top_triangle(i)%vertex(2), top_triangle(i)%vertex(3), 0, SubdivNum) - ENDIF - IF (SubdivNum(1) == 3) THEN - CALL trisect_triangle_nasr(top_triangle(i)%vertex(1), top_triangle(i)%vertex(2), top_triangle(i)%vertex(3), 0, SubdivNum) - ENDIF - ENDIF - END DO - -END SUBROUTINE comp_grid - - -SUBROUTINE proc_grid(top_triangle) - USE DataStru - IMPLICIT NONE - - TYPE(Triangle) :: top_triangle(20) - - INTEGER i, j, j_offset - -! for each triangle remove the grid points along the edge that are overlapped with adjacent triangles - DO i=1,5 - CALL remove_edge1(top_triangle(i)%start_idx, top_triangle(i)%end_idx) - END DO - DO i=11,15 - CALL remove_edge1(top_triangle(i)%start_idx, top_triangle(i)%end_idx) - END DO - DO i=6,10 - CALL remove_edge2(top_triangle(i)%start_idx, top_triangle(i)%end_idx) - END DO - DO i=16,20 - CALL remove_edge2(top_triangle(i)%start_idx, top_triangle(i)%end_idx) - END DO - -! combine them together to create diamond - DO i=1,5 - CALL combine(top_triangle(i), top_triangle(i + 15)) - END DO - - DO i=6,9 - CALL combine(top_triangle(i + 6), top_triangle(i)) - END DO - CALL combine(top_triangle(11), top_triangle(10)) - -! add offset to each diamond - offset = sl * sl - DO j = 1, 5 - j_offset = (j - 1) * offset * 2 + 1 - DO i= top_triangle(j)%start_idx, top_triangle(j)%end_idx - gp(i)%seqnum = gp(i)%seqnum + j_offset - END DO - END DO - DO j = 16, 20 - j_offset = (j - 16) * offset * 2 + 1 - DO i= top_triangle(j)%start_idx, top_triangle(j)%end_idx - gp(i)%seqnum = gp(i)%seqnum + j_offset - END DO - END DO - DO j = 12, 15 - j_offset = (j - 12) * offset * 2 + offset + 1 - DO i= top_triangle(j)%start_idx, top_triangle(j)%end_idx - gp(i)%seqnum = gp(i)%seqnum + j_offset - END DO - END DO - j_offset = 4 * offset * 2 + offset + 1 - DO i= top_triangle(11)%start_idx, top_triangle(11)%end_idx - gp(i)%seqnum = gp(i)%seqnum + j_offset - END DO - DO j = 6, 10 - j_offset = (j - 6) * offset * 2 + offset + 1 - DO i= top_triangle(j)%start_idx, top_triangle(j)%end_idx - gp(i)%seqnum = gp(i)%seqnum + j_offset - END DO - END DO - -END SUBROUTINE proc_grid - - diff --git a/src/fim/FIMsrc/prep/grid/ijblock.F90 b/src/fim/FIMsrc/prep/grid/ijblock.F90 deleted file mode 100644 index 4120996..0000000 --- a/src/fim/FIMsrc/prep/grid/ijblock.F90 +++ /dev/null @@ -1,56 +0,0 @@ -!====================================================== -! This subroutine fills in sub-regions and cache blocks of a rhombus in IJ row major order. -! The regions follow each other in column major order because that is what SMS does. -! If no cache blocking, then RegionFactors=1 and BlockDim=RegionDim. -! Each processor has one region. The results are returned in perm. -! The default layout is ij on the rhombus and perm is a mapping from ij order on the rhombus to the desired order -! MAX_DECOMP_DIMS is hardcoded as 2 -! Jacques Middlecoff April, 2008 -!====================================================== -SUBROUTINE ijblock_curve(nip,nPEs,NB,PE,start_gc,Nregions,RhombusDim,Nblocks,RegionDim,BlockDim,Rstart,Rend,perm) -IMPLICIT NONE -INTEGER,intent(IN ) :: nip !Number of Icosahedral points -INTEGER,intent(IN ) :: nPEs !Number of processors -INTEGER,intent(IN ) :: NB !Number of cache blocks per processor -INTEGER,intent(INOUT) :: PE !Processor number for saving start and end -INTEGER,intent(IN ) :: start_gc !Starting location in the globe -INTEGER,intent(IN ) :: Nregions (2) !Number of regions in each dimension of the rhombus -INTEGER,intent(IN ) :: RhombusDim (2) !The dimension of the rhombus -INTEGER,intent(IN ) :: Nblocks (NB*nPEs,2)!Number of blocks in each dimension of each region -INTEGER,intent(IN ) :: RegionDim (NB*nPEs,2)!The dimensions of each region -INTEGER,intent(IN ) :: BlockDim (NB,nPEs,2)!The dimensions of each block -INTEGER,intent( OUT) :: Rstart ( nPEs )!Global starting location for each PE -INTEGER,intent( OUT) :: Rend ( nPEs )!Global ending location for each PE -INTEGER,intent( OUT) :: perm (nip) !The calculated permutation - -INTEGER :: k,rhf1,rhf2,rd1,rd2,ref1,ref2,bd1,bd2 -INTEGER :: RowOffset,ColOffset,BrowOffset,BcolOffset,RegionStart - - k=start_gc - ColOffset = 0 - DO rhf1 = 1,Nregions(1) - RowOffset = 0 - DO rhf2 = 1,Nregions(2) - PE = PE + 1 - Rstart(PE) = k - RegionStart = start_gc+RowOffset+ColOffset - BcolOffset = 0 - do ref1 = 1,Nblocks(rhf1,1) - BrowOffset = 0 - do ref2 = 1, Nblocks(rhf2,2) - do bd2 = 1, BlockDim(ref2,rhf2,2) - do bd1 = 1, BlockDim(ref1,rhf1,1) - perm(k)=RegionStart+bd1-1+(bd2-1)*RhombusDim(1)+BrowOffset+BcolOffset - k=k+1 - enddo - enddo - BrowOffset = BrowOffset+RhombusDim(1)*BlockDim(ref2,rhf2,2) - enddo - BcolOffset = BcolOffset + BlockDim(ref1,rhf1,1) - enddo - RowOffset = RowOffset+RhombusDim(1)*RegionDim(rhf2,2) - Rend(PE) = k-1 - END DO - ColOffset = ColOffset + RegionDim(rhf1,1) - END DO -END SUBROUTINE ijblock_curve diff --git a/src/fim/FIMsrc/prep/grid/ll2xy.F90 b/src/fim/FIMsrc/prep/grid/ll2xy.F90 deleted file mode 100644 index 8a49ff8..0000000 --- a/src/fim/FIMsrc/prep/grid/ll2xy.F90 +++ /dev/null @@ -1,44 +0,0 @@ -! -!############################################################# -! ll2xy.f -! Convert lat/lon to (x,y) on General Stereographic Coordinate (GSTC). -! Original program: J.Lee - 2004 -! Program testing: J.Lee - 2004 -! Modified for Non-Structure Grid: J.Lee - 2004 -!############################################################ - -! Purpose: Given latitude and longitude on Spherical coordinate, -! this subroutine computes X and Y coordinates on GSTC. -! Reference: J.Lee, G. Browning, and Y. Xie: -! TELLUS (1995), p.892-910. -! -! Input Variables : Angles are assumed in unit of "radian" -! -! (latc,lonc) : the GSTC projected point. -! ( lat, lon) : Input lat/lon in radians. -! -! OUTPUT Variables: -! -! xm : X-Coordinate values on GSTC. -! positive to East of central longitude -! ym : Y-Coordinate values on GSTC. -! positive to North of central latitude. -! Note: Output variables of xm and ym are -! nondimensionalized with "ae", the radius of earth. -! -subroutine ll2xy(lonc,latc,lon,lat,xm,ym) -! -implicit none - -integer i -real*4 lonc,latc,lon,lat,mf -real*4 xm,ym -! -mf=2.0/(1.0+sin(lat)*sin(latc)+cos(lat)*cos(latc) & - *cos(lon-lonc)) -xm=mf*(cos(lat)*sin(lon-lonc)) -ym=mf*((sin(lat)*cos(latc)-cos(lat) & - *sin(latc)*cos(lon-lonc)) ) -! -return -end diff --git a/src/fim/FIMsrc/prep/grid/middle.F90 b/src/fim/FIMsrc/prep/grid/middle.F90 deleted file mode 100644 index 8aee4d8..0000000 --- a/src/fim/FIMsrc/prep/grid/middle.F90 +++ /dev/null @@ -1,72 +0,0 @@ -!====================================================== -! This subroutine computes the latitude and longitude -! of the middle point between two given ponits. -! -! There are two formulae available to compute it. -! -! One derived from a more general m-sect formula: -! -! xyz = sin((1-f)*theta) / sin(theta) * xyz1 + -! sin(f*theta) /sin(theta) * xyz2 ; -! where theta is the angle of xyz1, and xyz2. -! -! xyz = 0.5 / sqrt[(1+dot(xyz1,xyz2))/2] * (xyz1+xyz2) -! -! and the other one is the normalized middle point of -! the two end points: -! -! xyz = 0.5 * (xyz1+xyz2), xyz = xyz / sqrt(dot(xyz,xyz)) -! -! Author: Ning Wang, March, 2006 -!====================================================== - -SUBROUTINE middle(p1,p2,p) - - IMPLICIT NONE - - REAL*8 :: pi, d2r - - ! Two given points in lat/lon: - REAL*8 :: p1(2),p2(2),p(2) - - REAL*8 :: xyz1(3),xyz2(3),xyz(3) - - ! Radian-Degree: - pi = 4.0 * ATAN(1.0) - d2r = pi / 180.0 - - ! Convert to radian: - p1 = p1 * d2r - p2 = p2 * d2r - - ! Convert them into Cardesian coor: - xyz1(1) = cos(p1(1)) * cos(p1(2)) - xyz1(2) = cos(p1(1)) * sin(p1(2)) - xyz1(3) = sin(p1(1)) - - xyz2(1) = cos(p2(1)) * cos(p2(2)) - xyz2(2) = cos(p2(1)) * sin(p2(2)) - xyz2(3) = sin(p2(1)) - - ! middle point: - -! coeff = 0.5 / sqrt((1.0 + DOT_PRODUCT(xyz1,xyz2)) / 2) -! xyz = coeff * (xyz1 + xyz2) - - xyz = 0.5 * (xyz1 + xyz2) - xyz = xyz / sqrt(DOT_PRODUCT(xyz,xyz)) - - ! Convert the middle point to lat/lon coor: - p(1) = atan2(xyz(3), sqrt(xyz(1) * xyz(1) + xyz(2) * xyz(2))) - p(2) = atan2(xyz(2), xyz(1)) - - IF (p(2) < -pi / 2.0) THEN - p(2) = p(2) + 2 * pi - END IF - - p1 = p1 / d2r - p2 = p2 / d2r - p = p / d2r - -END SUBROUTINE middle - diff --git a/src/fim/FIMsrc/prep/grid/mpi_stubs.F90 b/src/fim/FIMsrc/prep/grid/mpi_stubs.F90 deleted file mode 100644 index 1a814c2..0000000 --- a/src/fim/FIMsrc/prep/grid/mpi_stubs.F90 +++ /dev/null @@ -1,18 +0,0 @@ - -! -! Stubs to attmept work around a ugly build problem... -! Probably won't work! -! - -subroutine mpi_initialized(initialized, istatus) - logical, intent(inout) :: initialized - integer, intent(inout) :: istatus - initialized = .false. - istatus = 0 -end subroutine mpi_initialized - -subroutine mpi_abort(comm,istatus,ignore) - integer, intent(inout) :: comm,istatus,ignore - istatus = 0 -end subroutine mpi_abort - diff --git a/src/fim/FIMsrc/prep/grid/perm.F90 b/src/fim/FIMsrc/prep/grid/perm.F90 deleted file mode 100644 index 09a3189..0000000 --- a/src/fim/FIMsrc/prep/grid/perm.F90 +++ /dev/null @@ -1,84 +0,0 @@ -!====================================================== -! This subroutine creates the permutation array for -! the 2D filling curve. -! This subroutine also calculates the start and end location for each PE -! -! Author: Ning Wang, Oct., 2006 -! Added IJ per PE blocking and cache blocking - Jacques Middlecoff, May 2008 -! Moved calculation of start and end from GetDecomp to here J. Middlecoff, Sep 2009 -!====================================================== -SUBROUTINE mk_perm(nip, curve, nPEs, NB, Rstart, Rend) -USE DataStru,only: perm,inv_perm -IMPLICIT NONE - -INTEGER,PARAMETER :: MAX_DECOMP_DIMS = 2 !If this is changed ppp_factors GetRegions and ijblock must be changed -INTEGER,intent(IN ) :: nip !Number of icosahedral points -INTEGER,intent(IN ) :: curve !The type of space filling curve -INTEGER,intent(IN ) :: nPEs !Number of processors -INTEGER,intent(IN ) :: NB !The number of cache blocks per processor. -INTEGER,intent(OUT) :: Rstart(nPEs) !Global starting location for each PE -INTEGER,intent(OUT) :: Rend (nPEs) !Global ending location for each PE - -INTEGER :: start_gc, i, rhombus, f1, f2 -INTEGER :: RhombusDim (MAX_DECOMP_DIMS) ! Number of points on rhombus side -INTEGER :: RD (MAX_DECOMP_DIMS) ! Tempory for RegionDim -INTEGER :: RF (MAX_DECOMP_DIMS) ! Temporary for rhombus or region factors -INTEGER :: RhombusFactors(MAX_DECOMP_DIMS) ! Factorization of PEsPerRhombus -INTEGER :: RegDim (nPEs) ! Temporary for region dimensions -INTEGER :: BlkDim (nPEs) ! Temporary for block dimensions -INTEGER :: PointsPerRhombus ! Number of points in each rhombus -INTEGER :: PEsPerRhombus ! Number of PEs allocated to each rhombus -INTEGER :: RegionFactors (NB*nPEs,MAX_DECOMP_DIMS) ! Factorization of PEsPerRhombus -INTEGER :: RegionDim (NB*nPEs,MAX_DECOMP_DIMS) ! Region dimensions -INTEGER :: BlockDim (NB,NPEs,MAX_DECOMP_DIMS) ! Cache block dimensions -INTEGER :: PE ! Processor number for start and end -LOGICAL :: C3NotDivBy10 ! For curve 3 is nPEs not divisible by 10? - - write (6,*) 'JR mk_perm allocating perm nip=', nip - ALLOCATE( perm(nip)) - ALLOCATE(inv_perm(nip)) - - PointsPerRhombus = nip /10 - PEsPerRhombus = nPEs/10 - C3NotDivBy10 = curve==3.and.10*PEsPerRhombus/=nPEs - IF(curve==0.or.curve==1.or.PESperRhombus==0.or.C3NotDivBy10)THEN !IJ or Hilbert order - IF (curve == 1) THEN !Hilbert curve - DO rhombus = 1, 10 - start_gc = (rhombus - 1) * PointsPerRhombus + 2 - CALL hilbert_curve(PointsPerRhombus, 1, start_gc) - END DO - ELSE !IJ order - DO i = 1, nip - perm(i) = i - END DO - ENDIF - call GetRegions(nip-2,1,nPEs,nPEs,.true.,Rstart,Rend) - ELSE IF (curve == 2) THEN !IJ block order with cache blocking - call IJblockLayout(nPEs,nip,NB,perm,Rstart,Rend) - ELSE IF (curve == 3) THEN !Square Layout - no cache blocking - call SquareLayout(nPEs,nip,perm,Rstart,Rend) - ELSE - print*,'Error in perm.F90: Curve out of range, curve =',curve - stop - END IF - !Add the 2 extra points at the poles to the first and last points - perm(1) = 1 - perm(nip) = nip - Rstart(1) = Rstart(1) - 1 - Rend(nPEs) = Rend(nPEs) + 1 - DO i = 1, nip - inv_perm(perm(i)) = i - END DO -END SUBROUTINE mk_perm - - -SUBROUTINE dealloc_perm_array -USE DataStru -IMPLICIT NONE - - write (6,*) 'JR dealloc_perm_array deallocating perm' - DEALLOCATE(perm) - DEALLOCATE(inv_perm) - -END SUBROUTINE dealloc_perm_array - diff --git a/src/fim/FIMsrc/prep/grid/rotate.F90 b/src/fim/FIMsrc/prep/grid/rotate.F90 deleted file mode 100644 index c478f68..0000000 --- a/src/fim/FIMsrc/prep/grid/rotate.F90 +++ /dev/null @@ -1,92 +0,0 @@ -!================================================================== -! The two subroutines in this file rotate the top icosahedral -! grid for the given amount of angles, in theta and lambda directions -! -! Ning Wang, Jan. 2008 -! -!=================================================================== -SUBROUTINE rotate(theta,lambda,topgrid, n) - USE DataStru - - IMPLICIT NONE - - REAL*8 :: theta, lambda - TYPE(GridPointWnb) :: topgrid(n) - INTEGER :: n - - REAL*8 :: pi, d2r, cos_t, sin_t, cos_l, sin_l - REAL*8 :: latlon(2) - INTEGER :: i, j - - ! Degree-Radian: - pi = 4.0 * ATAN(1.0) - d2r = pi / 180.0 - - ! Convert to radian: - theta = theta * d2r - lambda = lambda * d2r - - sin_t = SIN(theta) - cos_t = COS(theta) - sin_l = SIN(lambda) - cos_l = COS(lambda) - - DO i = 1, n - latlon(1) = topgrid(i)%latlon(1) * d2r - latlon(2) = topgrid(i)%latlon(2) * d2r - CALL rotate_latlon(latlon, sin_t, cos_t, sin_l, cos_l) - topgrid(i)%latlon(1) = latlon(1) / d2r - topgrid(i)%latlon(2) = latlon(2) / d2r - DO j = 1, 6 - latlon(1) = topgrid(i)%neighbor(1,j) * d2r - latlon(2) = topgrid(i)%neighbor(2,j) * d2r - CALL rotate_latlon(latlon, sin_t, cos_t, sin_l, cos_l) - topgrid(i)%neighbor(1,j) = latlon(1) / d2r - topgrid(i)%neighbor(2,j) = latlon(2) / d2r - ENDDO - ENDDO - -END SUBROUTINE rotate - -SUBROUTINE rotate_latlon(latlon, sin_t, cos_t, sin_l, cos_l) - IMPLICIT NONE - REAL*8 :: latlon(2), sin_t, cos_t, sin_l, cos_l - REAL*8 :: xyz(3), xyz1(3), xyz2(3) - REAL*8 :: pi, c11, c12, c13, c21, c22, c23, c31, c32, c33 - - pi = 4.0 * ATAN(1.0) - ! Convert them into Cardesian coor: - xyz(1) = cos(latlon(1)) * cos(latlon(2)) - xyz(2) = cos(latlon(1)) * sin(latlon(2)) - xyz(3) = sin(latlon(1)) - - ! rotate about Z axis, theta degrees - xyz1(1) = cos_t * xyz(1) - sin_t * xyz(2) - xyz1(2) = sin_t * xyz(1) + cos_t * xyz(2) - xyz1(3) = xyz(3) - ! ratate about new axis (sin_t, -cos_t, 0), lambda degrees - c11 = cos_l + (1 - cos_l) * sin_t * sin_t - c12 = -(1 - cos_l) * sin_t * cos_t - c13 = -sin_l * cos_t - c21 = c12 - c22 = cos_l + (1 - cos_l) * cos_t * cos_t - c23 = -sin_l * sin_t - c31 = -c13 - c32 = -c23 - c33 = cos_l - - xyz2(1) = c11 * xyz1(1) + c12 * xyz1(2) + c13 * xyz1(3) - xyz2(2) = c21 * xyz1(1) + c22 * xyz1(2) + c23 * xyz1(3) - xyz2(3) = c31 * xyz1(1) + c32 * xyz1(2) + c33 * xyz1(3) - - ! Convert the grid point back to lat/lon coor: - latlon(1) = atan2(xyz2(3), sqrt(xyz2(1) * xyz2(1) + xyz2(2) * xyz2(2))) - latlon(2) = atan2(xyz2(2), xyz2(1)) - - IF (latlon(2) < - pi / 2.0) THEN - latlon(2) = latlon(2) + 2 * pi - END IF - -END SUBROUTINE rotate_latlon - - diff --git a/src/fim/FIMsrc/prep/grid/third.F90 b/src/fim/FIMsrc/prep/grid/third.F90 deleted file mode 100644 index d9d55f7..0000000 --- a/src/fim/FIMsrc/prep/grid/third.F90 +++ /dev/null @@ -1,73 +0,0 @@ -!====================================================== -! This subroutine computes the latitude and longitude -! of the middle point between two given ponits. -! -! There are two formulae available to compute it. -! -! One derived from a more general m-sect formula: -! -! xyz = sin((1-f)*theta) / sin(theta) * xyz1 + -! sin(f*theta) /sin(theta) * xyz2 ; -! where theta is the angle of xyz1, and xyz2. -! -! xyz = 0.5 / sqrt[(1+dot(xyz1,xyz2))/2] * (xyz1+xyz2) -! -! and the other one is the normalized middle point of -! the two end points: -! -! xyz = 0.5 * (xyz1+xyz2), xyz = xyz / sqrt(dot(xyz,xyz)) -! -! Author: Ning Wang, March, 2006 -!====================================================== - -SUBROUTINE oneThird(p1,p2,p) - ! USE module_constants - - IMPLICIT NONE - - REAL*8 :: pi, d2r, f, theta, coeff1, coeff2 - - ! Two given points in lat/lon: - REAL*8 :: p1(2),p2(2),p(2) - - REAL*8 :: xyz1(3),xyz2(3),xyz(3) - - ! Radian-Degree: - pi = 4.0 * ATAN(1.0) - d2r = pi / 180.0 - - ! Convert to radian: - p1 = p1 * d2r - p2 = p2 * d2r - - ! Convert them into Cardesian coor: - xyz1(1) = cos(p1(1)) * cos(p1(2)) - xyz1(2) = cos(p1(1)) * sin(p1(2)) - xyz1(3) = sin(p1(1)) - - xyz2(1) = cos(p2(1)) * cos(p2(2)) - xyz2(2) = cos(p2(1)) * sin(p2(2)) - xyz2(3) = sin(p2(1)) - - ! one third point: - f = 1.0/3.0 - - theta = ACOS(DOT_PRODUCT(xyz1, xyz2)) - coeff1 = SIN((1-f)*theta)/SIN(theta) - coeff2 = SIN(f*theta)/SIN(theta) - xyz = coeff1 * xyz1 + coeff2 * xyz2 - - ! Convert the one third point to lat/lon coor: - p(1) = atan2(xyz(3), sqrt(xyz(1) * xyz(1) + xyz(2) * xyz(2))) - p(2) = atan2(xyz(2), xyz(1)) - - IF (p(2) < -pi / 2.0) THEN - p(2) = p(2) + 2 * pi - END IF - - p1 = p1 / d2r - p2 = p2 / d2r - p = p / d2r - -END SUBROUTINE oneThird - diff --git a/src/fim/FIMsrc/prep/grid/top_gridpoints.F90 b/src/fim/FIMsrc/prep/grid/top_gridpoints.F90 deleted file mode 100644 index 7d16495..0000000 --- a/src/fim/FIMsrc/prep/grid/top_gridpoints.F90 +++ /dev/null @@ -1,108 +0,0 @@ -!==================================================== -! This routine sets up the initial grid points for a -! Icosahedron grid. -! -! Author: Yuanfu Xie on Feb. 2002 -!==================================================== - -SUBROUTINE set_top_gridpoints(top) - - USE DataStru - - IMPLICIT NONE - -! REAL*8, PARAMETER :: pi = atan(1.0) * 4.0 -! REAL*8, PARAMETER :: Lat0 = 90.0 - 2.0 *acos(0.5/sin(pi/5.0))*180.0/pi, Lon0 = -72.0 -! REAL*8, PARAMETER :: Lat0 = 26.56505118, Lon0 = -72.0 - - REAL*8, PARAMETER :: Lat0 = 26.5650428671016, Lon0 = -72.0 - - TYPE(GridPointWnb) :: top(12) - - ! Local: - INTEGER :: i,n - - print*, 'lat0=', lat0 - DO i = 1,12 - top(i)%Neighbor(1:2,6) = 0.0 - END DO - - ! North pole: - top(1)%LatLon(1) = 90.0 - top(1)%LatLon(2) = 0.0 - ! 5 neighbors of this pole: - DO i=1,5 - top(1)%Neighbor(1,i) = Lat0 - top(1)%Neighbor(2,i) = Lon0+72.0*i - END DO - - ! 5 neighbors: - DO i=2,6 - top(i)%LatLon(1) = top(1)%Neighbor(1,i-1) - top(i)%LatLon(2) = top(1)%Neighbor(2,i-1) - - ! North pole is one of its neighbor: - top(i)%Neighbor(1,1) = top(1)%LatLon(1) - top(i)%Neighbor(2,1) = top(1)%LatLon(2) - - ! Left neighbor: - n = i-1 - if (n == 1) n = 5 - top(i)%Neighbor(1,2) = top(1)%Neighbor(1,n) - top(i)%Neighbor(2,2) = top(1)%Neighbor(2,n) - ! Right neighbor: - n = i+1 - if (n == 7) n = 2 - top(i)%Neighbor(1,3) = top(1)%Neighbor(1,n) - top(i)%Neighbor(2,3) = top(1)%Neighbor(2,n) - END DO - - ! South pole: - top(7)%LatLon(1) = -90.0 - top(7)%LatLon(2) = 0.0 - ! 5 neighbors: - DO i=1,5 - top(7)%Neighbor(1,i) = -Lat0 - top(7)%Neighbor(2,i) = Lon0+36.0+72.0*i - END DO - - ! 5 neighbors: - DO i=8,12 - top(i)%LatLon(1) = top(7)%Neighbor(1,i-7) - top(i)%LatLon(2) = top(7)%Neighbor(2,i-7) - - ! South pole is one of its neighbor: - top(i)%Neighbor(1,1) = top(7)%LatLon(1) - top(i)%Neighbor(2,1) = top(7)%LatLon(2) - - ! Left neighbor: - n = i-1 - if (n == 7) n = 12 - top(i)%Neighbor(1,2) = top(7)%Neighbor(1,n-7) - top(i)%Neighbor(2,2) = top(7)%Neighbor(2,n-7) - ! Right neighbor: - n = i - if (n == 12) n = 8 - top(i)%Neighbor(1,3) = top(7)%Neighbor(1,n-7) - top(i)%Neighbor(2,3) = top(7)%Neighbor(2,n-7) - END DO - - ! Neighbors cross the equater: - DO i=2,6 - - ! South starts 36 degree ahead: - n = i+6 - top(i)%Neighbor(1,4) = top(n)%LatLon(1) - top(i)%Neighbor(2,4) = top(n)%LatLon(2) - top(n)%Neighbor(1,4) = top(i)%LatLon(1) - top(n)%Neighbor(2,4) = top(i)%LatLon(2) - n = i+5 - if (n == 7) n = 12 - top(i)%Neighbor(1,5) = top(n)%LatLon(1) - top(i)%Neighbor(2,5) = top(n)%LatLon(2) - top(n)%Neighbor(1,5) = top(i)%LatLon(1) - top(n)%Neighbor(2,5) = top(i)%LatLon(2) - - END DO - -END SUBROUTINE set_top_gridpoints diff --git a/src/fim/FIMsrc/prep/grid/top_triangles.F90 b/src/fim/FIMsrc/prep/grid/top_triangles.F90 deleted file mode 100644 index 622918b..0000000 --- a/src/fim/FIMsrc/prep/grid/top_triangles.F90 +++ /dev/null @@ -1,84 +0,0 @@ -!==================================================== -! This routine sets up the initial triangles for a -! Icosahedron grid. -! -! Author: Yuanfu Xie on Feb. 2002 -! -! Aug 2006, made modifications to fit new data -! structure, and changed the orders of the veritces -! to make them consistent. Changed name of the -! subroutine to set_top_triangle(); -! Added some comments. -!==================================================== - -SUBROUTINE set_top_triangle(high,top) - - USE DataStru - - IMPLICIT NONE - - TYPE(GridPointWnb) :: top(12) - TYPE(Triangle) :: high(20) - - INTEGER :: i,n - - ! Top 5: - do i=1,5 - - ! first vertex is always the north pole - high(i)%vertex(1)%LatLon(1) = top(1)%LatLon(1) - high(i)%vertex(1)%LatLon(2) = top(1)%LatLon(2) - - ! second and third is are north pole's first level neighbors - high(i)%vertex(2)%LatLon(1) = top(1)%Neighbor(1,i) - high(i)%vertex(2)%LatLon(2) = top(1)%Neighbor(2,i) - n = i+1 - if (n == 6) n = 1 - high(i)%vertex(3)%LatLon(1) = top(1)%Neighbor(1,n) - high(i)%vertex(3)%LatLon(2) = top(1)%Neighbor(2,n) - END DO - - ! Bottom 5: - do i=6,10 - - ! last vertex is always the south pole - high(i)%vertex(1)%LatLon(1) = top(7)%LatLon(1) - high(i)%vertex(1)%LatLon(2) = top(7)%LatLon(2) - - ! second and third is are south pole's first level neighbors - high(i)%vertex(3)%LatLon(1) = top(7)%Neighbor(1,i-5) - high(i)%vertex(3)%LatLon(2) = top(7)%Neighbor(2,i-5) - n = i+1 - if (n == 11) n = 6 - high(i)%vertex(2)%LatLon(1) = top(7)%Neighbor(1,n-5) - high(i)%vertex(2)%LatLon(2) = top(7)%Neighbor(2,n-5) - - END DO - - ! Middle 10: - do i=1,5 - - high(i+10)%vertex(1)%LatLon(1) = top(i+1)%LatLon(1) - high(i+10)%vertex(1)%LatLon(2) = top(i+1)%LatLon(2) - - high(i+10)%vertex(3)%LatLon(1) = top(i+1)%Neighbor(1,4) - high(i+10)%vertex(3)%LatLon(2) = top(i+1)%Neighbor(2,4) - - high(i+10)%vertex(2)%LatLon(1) = top(i+1)%Neighbor(1,5) - high(i+10)%vertex(2)%LatLon(2) = top(i+1)%Neighbor(2,5) - - end do - do i=8,12 - - high(i+8)%vertex(1)%LatLon(1) = top(i)%LatLon(1) - high(i+8)%vertex(1)%LatLon(2) = top(i)%LatLon(2) - - high(i+8)%vertex(3)%LatLon(1) = top(i)%Neighbor(1,4) - high(i+8)%vertex(3)%LatLon(2) = top(i)%Neighbor(2,4) - - high(i+8)%vertex(2)%LatLon(1) = top(i)%Neighbor(1,5) - high(i+8)%vertex(2)%LatLon(2) = top(i)%Neighbor(2,5) - - end do - -END SUBROUTINE set_top_triangle diff --git a/src/fim/FIMsrc/prep/grid/triang.F90 b/src/fim/FIMsrc/prep/grid/triang.F90 deleted file mode 100644 index de16c02..0000000 --- a/src/fim/FIMsrc/prep/grid/triang.F90 +++ /dev/null @@ -1,97 +0,0 @@ -!==================================================== -! This routine sets up the initial triangles for a -! Icosahedron grid. -! -! Author: Yuanfu Xie on Feb. 2002 -! Aug 2006, made modifications to fit new data -! structure, and changed name of the subroutine to -! set_top_triangle(); Added some comments. N.W. -!==================================================== - -SUBROUTINE set_top_triangle(high,top) - - USE DataStru - - IMPLICIT NONE - - TYPE(GridPoint) :: top(12) - TYPE(Triangle) :: high(20) - - INTEGER :: i,n - - ! Top 5: - do i=1,5 - - ! first vertex is always the north pole - high(i)%vertex(1)%LatLon(1) = top(1)%LatLon(1) - high(i)%vertex(1)%LatLon(2) = top(1)%LatLon(2) - - ! second and third is are north pole's first level neighbors - high(i)%vertex(2)%LatLon(1) = top(1)%Neighbor(1,i) - high(i)%vertex(2)%LatLon(2) = top(1)%Neighbor(2,i) - n = i+1 - if (n == 6) n = 1 - high(i)%vertex(3)%LatLon(1) = top(1)%Neighbor(1,n) - high(i)%vertex(3)%LatLon(2) = top(1)%Neighbor(2,n) -! PRINT*, 'top', high(i)%vertex(1)%LatLon -! PRINT*, 'top', high(i)%vertex(2)%LatLon -! PRINT*, 'top', high(i)%vertex(3)%LatLon -! PRINT*, '------------------------------------------------------' - END DO - - ! Bottom 5: - do i=6,10 - - ! last vertex is always the south pole - high(i)%vertex(1)%LatLon(1) = top(7)%LatLon(1) - high(i)%vertex(1)%LatLon(2) = top(7)%LatLon(2) - - ! second and third is are south pole's first level neighbors - high(i)%vertex(3)%LatLon(1) = top(7)%Neighbor(1,i-5) - high(i)%vertex(3)%LatLon(2) = top(7)%Neighbor(2,i-5) - n = i+1 - if (n == 11) n = 6 - high(i)%vertex(2)%LatLon(1) = top(7)%Neighbor(1,n-5) - high(i)%vertex(2)%LatLon(2) = top(7)%Neighbor(2,n-5) -! PRINT*, 'bottom', high(i)%vertex(1)%LatLon -! PRINT*, 'bottom', high(i)%vertex(2)%LatLon -! PRINT*, 'bottom', high(i)%vertex(3)%LatLon -! PRINT*, '------------------------------------------------------' - - END DO - - ! Middle 10: - do i=1,5 - - high(i+10)%vertex(1)%LatLon(1) = top(i+1)%LatLon(1) - high(i+10)%vertex(1)%LatLon(2) = top(i+1)%LatLon(2) - - high(i+10)%vertex(3)%LatLon(1) = top(i+1)%Neighbor(1,4) - high(i+10)%vertex(3)%LatLon(2) = top(i+1)%Neighbor(2,4) - - high(i+10)%vertex(2)%LatLon(1) = top(i+1)%Neighbor(1,5) - high(i+10)%vertex(2)%LatLon(2) = top(i+1)%Neighbor(2,5) -! PRINT*, 'middle', high(i+10)%vertex(1)%LatLon -! PRINT*, 'middle', high(i+10)%vertex(2)%LatLon -! PRINT*, 'middle', high(i+10)%vertex(3)%LatLon -! PRINT*, '------------------------------------------------------' - - end do - do i=8,12 - - high(i+8)%vertex(1)%LatLon(1) = top(i)%LatLon(1) - high(i+8)%vertex(1)%LatLon(2) = top(i)%LatLon(2) - - high(i+8)%vertex(3)%LatLon(1) = top(i)%Neighbor(1,4) - high(i+8)%vertex(3)%LatLon(2) = top(i)%Neighbor(2,4) - - high(i+8)%vertex(2)%LatLon(1) = top(i)%Neighbor(1,5) - high(i+8)%vertex(2)%LatLon(2) = top(i)%Neighbor(2,5) -! PRINT*, 'middle', high(i+8)%vertex(1)%LatLon -! PRINT*, 'middle', high(i+8)%vertex(2)%LatLon -! PRINT*, 'middle', high(i+8)%vertex(3)%LatLon -! PRINT*, '------------------------------------------------------' - - end do - -END SUBROUTINE set_top_triangle diff --git a/src/fim/FIMsrc/prep/grid/trisect.F90 b/src/fim/FIMsrc/prep/grid/trisect.F90 deleted file mode 100644 index 64d6005..0000000 --- a/src/fim/FIMsrc/prep/grid/trisect.F90 +++ /dev/null @@ -1,74 +0,0 @@ -!====================================================================== -! This subroutine computes the latitude and longitude of the one-third -! and two-third points between two given ponits, on the unit sphere. -! -! From a general m-sect formula: -! -! xyz = sin((1-f)*theta) / sin(theta) * xyz1 + -! sin(f*theta) /sin(theta) * xyz2 ; -! where theta is the angle between unit vector xyz1 and xyz2. -! -! xyz_1 = (xyz1 * sin(2/3*theta) + xyz2 * sin(1/3*theta)) / sin(theta) -! xyz_2 = (xyz1 * sin(1/3*theta) + xyz2 * sin(2/3*theta)) / sin(theta) -! -! Author: Ning Wang, June, 2009 -!====================================================================== - -SUBROUTINE trisect(p1, p2, p_1, p_2) - ! USE module_constants - - IMPLICIT NONE - - REAL*8 :: pi, d2r - - ! Two given points in lat/lon: - REAL*8 :: p1(2),p2(2),p_1(2),p_2(2) - - REAL*8 :: xyz1(3),xyz2(3),xyz_1(3), xyz_2(3) - REAL*8 :: theta, sin_theta, sin_1thetaov3, sin_2thetaov3 - - pi = 4.0 * ATAN(1.0) - d2r = pi / 180.0 - - ! Convert to radian: - p1 = p1 * d2r - p2 = p2 * d2r - - ! Convert them into Cardesian coor: - xyz1(1) = cos(p1(1)) * cos(p1(2)) - xyz1(2) = cos(p1(1)) * sin(p1(2)) - xyz1(3) = sin(p1(1)) - - xyz2(1) = cos(p2(1)) * cos(p2(2)) - xyz2(2) = cos(p2(1)) * sin(p2(2)) - xyz2(3) = sin(p2(1)) - - theta = acos(cos(p1(1)) * cos(p2(1)) * cos(p1(2) - p2(2)) + sin(p1(1)) * sin(p2(1))) - sin_theta = sin(theta) - sin_1thetaov3 = sin(theta / 3.0) - sin_2thetaov3 = sin(theta / 1.5) - ! the one-third point: - xyz_1 = (xyz1 * sin_2thetaov3 + xyz2 * sin_1thetaov3) / sin_theta - ! the two-third point: - xyz_2 = (xyz1 * sin_1thetaov3 + xyz2 * sin_2thetaov3) / sin_theta - - ! Convert to lat/lon coor: - p_1(1) = atan2(xyz_1(3), sqrt(xyz_1(1) * xyz_1(1) + xyz_1(2) * xyz_1(2))) - p_1(2) = atan2(xyz_1(2), xyz_1(1)) - IF (p_1(2) < -pi / 2.0) THEN - p_1(2) = p_1(2) + 2 * pi - END IF - - p_2(1) = atan2(xyz_2(3), sqrt(xyz_2(1) * xyz_2(1) + xyz_2(2) * xyz_2(2))) - p_2(2) = atan2(xyz_2(2), xyz_2(1)) - IF (p_2(2) < -pi / 2.0) THEN - p_2(2) = p_2(2) + 2 * pi - END IF - - p1 = p1 / d2r - p2 = p2 / d2r - p_1 = p_1 / d2r - p_2 = p_2 / d2r - -END SUBROUTINE trisect - diff --git a/src/fim/FIMsrc/prep/grid/trisect_triangle.F90 b/src/fim/FIMsrc/prep/grid/trisect_triangle.F90 deleted file mode 100644 index 57d61ca..0000000 --- a/src/fim/FIMsrc/prep/grid/trisect_triangle.F90 +++ /dev/null @@ -1,218 +0,0 @@ -!======================================================================= -! This set of subroutines trisect the given triangle and recursively -! calls a appropriate multisection routines to generate the icos grid. -! -! HISTORY: -! Jun. 2009: Original version, Ning Wang. -! Created to allow combined multi-section refinements. -!======================================================================= - -! Non-automatic self recursive trisection - -RECURSIVE SUBROUTINE trisect_triangle_nasr(a, b, c, level, msec) - USE DataStru - IMPLICIT NONE - - TYPE(GridPoint) :: a, b, c - INTEGER :: level, side, msec(20) - - TYPE(GridPoint) :: a_b_1, a_b_2, a_c_1, a_c_2, b_c_1, b_c_2, o - TYPE(GridPoint) :: t1, t2, t3 - INTEGER :: clevel - - clevel = level + 1 - -! store the vertex grid point in an array according to their seq num. - gp(a%seqnum + offset)%latlon = a%latlon(:) - gp(b%seqnum + offset)%latlon = b%latlon(:) - gp(c%seqnum + offset)%latlon = c%latlon(:) - gp(a%seqnum + offset)%seqnum = a%seqnum - gp(b%seqnum + offset)%seqnum = b%seqnum - gp(c%seqnum + offset)%seqnum = c%seqnum - -! check to see if recursive call bottoms out. - IF (clevel > ml) THEN - RETURN - END IF - -! a -! /\ -! / \ -! / \ -! / \ -! / \ -! a_b_1 /__________\ a_c_1 -! / \ / \ -! / \ / \ -! / \ / \ -! / \o / \ -! a_b_2 /_________\/_________\ a_c_2 -! / \ /\ / \ -! / \ / \ / \ -! / \ / \ / \ -! / \ / \ / \ -! b/_________\/________\/_________\ c -! b_c_1 b_c_2 -! - - CALL compute_index_tri(a%seqnum, b%seqnum, c%seqnum, & - a_b_1%seqnum, a_b_2%seqnum, a_c_1%seqnum, a_c_2%seqnum,& - b_c_1%seqnum, b_c_2%seqnum, o%seqnum, clevel, 1) -!print*, a%seqnum , b%seqnum, c%seqnum,a_b_1%seqnum, a_b_2%seqnum, a_c_1%seqnum, a_c_2%seqnum, b_c_1%seqnum, b_c_2%seqnum, o%seqnum, clevel - - CALL trisect(a%latlon, b%latlon, a_b_1%latlon, a_b_2%latlon) - CALL trisect(a%latlon, c%latlon, a_c_1%latlon, a_c_2%latlon) - CALL trisect(b%latlon, c%latlon, b_c_1%latlon, b_c_2%latlon) - - CALL middle(a_b_1%latlon, b_c_2%latlon, t1%latlon) - CALL middle(a_c_1%latlon, b_c_1%latlon, t2%latlon) - CALL middle(a_b_2%latlon, a_c_2%latlon, t3%latlon) - o%latlon = (t1%latlon + t2%latlon + t3%latlon) / 3.0 - - IF (msec(clevel + 1) == 2) THEN - CALL bisect_triangle_nasr(a, a_b_1, a_c_1, clevel, msec) - CALL bisect_triangle_nasr(a_b_1, a_b_2, o, clevel, msec) - CALL bisect_r_triangle_nasr(a_b_1, a_c_1, o, clevel, msec) - CALL bisect_triangle_nasr(a_c_1, o, a_c_2, clevel, msec) - CALL bisect_triangle_nasr(a_b_2, b, b_c_1, clevel, msec) - CALL bisect_r_triangle_nasr(a_b_2, o, b_c_1, clevel, msec) - CALL bisect_triangle_nasr(o, b_c_1, b_c_2, clevel, msec) - CALL bisect_r_triangle_nasr(o, a_c_2, b_c_2, clevel, msec) - CALL bisect_triangle_nasr(a_c_2, b_c_2, c, clevel, msec) - ENDIF - IF (msec(clevel + 1) == 3) THEN - CALL trisect_triangle_nasr(a, a_b_1, a_c_1, clevel, msec) - CALL trisect_triangle_nasr(a_b_1, a_b_2, o, clevel, msec) - CALL trisect_r_triangle_nasr(a_b_1, a_c_1, o, clevel, msec) - CALL trisect_triangle_nasr(a_c_1, o, a_c_2, clevel, msec) - CALL trisect_triangle_nasr(a_b_2, b, b_c_1, clevel, msec) - CALL trisect_r_triangle_nasr(a_b_2, o, b_c_1, clevel, msec) - CALL trisect_triangle_nasr(o, b_c_1, b_c_2, clevel, msec) - CALL trisect_r_triangle_nasr(o, a_c_2, b_c_2, clevel, msec) - CALL trisect_triangle_nasr(a_c_2, b_c_2, c, clevel, msec) - ENDIF - -END SUBROUTINE trisect_triangle_nasr - - -RECURSIVE SUBROUTINE trisect_r_triangle_nasr(a, b, c, level, msec) - - USE DataStru - IMPLICIT NONE - - TYPE(GridPoint) :: a, b, c - INTEGER :: level, msec(20) - - TYPE(GridPoint) :: a_b_1, a_b_2, a_c_1, a_c_2, b_c_1, b_c_2, o - TYPE(GridPoint) :: t1, t2, t3 - INTEGER :: clevel - - gp(a%seqnum + offset)%latlon = a%latlon(:) - gp(b%seqnum + offset)%latlon = b%latlon(:) - gp(c%seqnum + offset)%latlon = c%latlon(:) - - gp(a%seqnum + offset)%seqnum = a%seqnum - gp(b%seqnum + offset)%seqnum = b%seqnum - gp(c%seqnum + offset)%seqnum = c%seqnum - - clevel = level + 1 - -! check to see if recursive call bottoms out. - IF (clevel > ml) THEN - RETURN - END IF -! a_b_1 a_b_2 -! a ______________________________ b -! \ /\ /\ / -! \ / \ / \ / -! \ / \ / \ / -! \ / \o / \ / -! a_c_1 \/________\/________\/ b_c_1 -! \ /\ / -! \ / \ / -! \ / \ / -! \ / \ / -! a_c_2 \/________\/ b_c_2 -! \ / -! \ / -! \ / -! \ / -! \/ -! c - - CALL compute_index_tri(a%seqnum, b%seqnum, c%seqnum, & - a_b_1%seqnum, a_b_2%seqnum, a_c_1%seqnum,a_c_2%seqnum, & - b_c_1%seqnum, b_c_2%seqnum, o%seqnum, clevel, 0) - - CALL trisect(a%latlon, b%latlon, a_b_1%latlon, a_b_2%latlon) - CALL trisect(a%latlon, c%latlon, a_c_1%latlon, a_c_2%latlon) - CALL trisect(b%latlon, c%latlon, b_c_1%latlon, b_c_2%latlon) - - CALL middle(a_b_1%latlon, b_c_2%latlon, t1%latlon) - CALL middle(a_c_1%latlon, b_c_1%latlon, t2%latlon) - CALL middle(a_b_2%latlon, a_c_2%latlon, t3%latlon) - o%latlon = (t1%latlon + t2%latlon + t3%latlon) / 3.0 - IF (msec(clevel + 1) == 2) THEN - CALL bisect_r_triangle_nasr(a, a_b_1, a_c_1, clevel, msec) - CALL bisect_triangle_nasr(a_b_1, a_c_1, o, clevel, msec) - CALL bisect_r_triangle_nasr(a_b_1, a_b_2, o, clevel, msec) - CALL bisect_triangle_nasr(a_b_2, o, b_c_1, clevel, msec) - CALL bisect_r_triangle_nasr(a_b_2, b, b_c_1, clevel, msec) - CALL bisect_r_triangle_nasr(a_c_1, o, a_c_2, clevel, msec) - CALL bisect_triangle_nasr(o, a_c_2, b_c_2, clevel, msec) - CALL bisect_r_triangle_nasr(o, b_c_1, b_c_2, clevel, msec) - CALL bisect_r_triangle_nasr(a_c_2, b_c_2, c, clevel, msec) - ENDIF - IF (msec(clevel + 1) == 3) THEN - CALL trisect_r_triangle_nasr(a, a_b_1, a_c_1, clevel, msec) - CALL trisect_triangle_nasr(a_b_1, a_c_1, o, clevel, msec) - CALL trisect_r_triangle_nasr(a_b_1, a_b_2, o, clevel, msec) - CALL trisect_triangle_nasr(a_b_2, o, b_c_1, clevel, msec) - CALL trisect_r_triangle_nasr(a_b_2, b, b_c_1, clevel, msec) - CALL trisect_r_triangle_nasr(a_c_1, o, a_c_2, clevel, msec) - CALL trisect_triangle_nasr(o, a_c_2, b_c_2, clevel, msec) - CALL trisect_r_triangle_nasr(o, b_c_1, b_c_2, clevel, msec) - CALL trisect_r_triangle_nasr(a_c_2, b_c_2, c, clevel, msec) - ENDIF - -END SUBROUTINE trisect_r_triangle_nasr - - -SUBROUTINE compute_index_tri(a_sn, b_sn, c_sn, a_b_1_sn, a_b_2_sn, & - a_c_1_sn, a_c_2_sn, b_c_1_sn, b_c_2_sn, o_sn, level, delta_triangle) - - USE DataStru - - IMPLICIT NONE - - INTEGER :: a_sn, b_sn, c_sn, a_b_1_sn, a_b_2_sn, a_c_1_sn, a_c_2_sn - INTEGER :: b_c_1_sn, b_c_2_sn, o_sn, level, delta_triangle - INTEGER :: init_stride, nrtt, nrt2t, stride1_1, stride1_2, stride2_1, stride2_2 - REAL :: row - - init_stride = (sl + 1) - row(a_sn) - nrtt = (row(c_sn) - row(a_sn)) / 3 - nrt2t = 2 * nrtt - stride1_1 = (2 * init_stride - (nrtt -1)) * nrtt / 2 - stride1_2 = (2 * init_stride - (nrt2t -1)) * nrt2t / 2 - stride2_1 = (2 * (init_stride - 1) - (nrtt -1)) * nrtt / 2 - stride2_2 = (2 * (init_stride - 1) - (nrt2t -1)) * nrt2t / 2 - a_c_1_sn = a_sn + stride1_1 - a_c_2_sn = a_sn + stride1_2 - - IF (delta_triangle == 1) THEN - a_b_1_sn = a_sn + (b_sn - a_sn) / 3 - a_b_2_sn = a_sn + 2 * (b_sn - a_sn) / 3 - b_c_1_sn = b_sn + stride2_1 - b_c_2_sn = b_sn + stride2_2 - o_sn = (a_c_1_sn + b_c_1_sn) / 2 - ELSE - b_c_1_sn = b_sn + (c_sn - b_sn) / 3 - b_c_2_sn = b_sn + 2 * (c_sn - b_sn) / 3 - a_b_1_sn = a_sn + stride2_1 - a_b_2_sn = a_sn + stride2_2 - o_sn = (a_b_2_sn + a_c_2_sn) / 2 - END IF - -END SUBROUTINE compute_index_tri - diff --git a/src/fim/FIMsrc/prep/sfcio/Makefile b/src/fim/FIMsrc/prep/sfcio/Makefile deleted file mode 100755 index c981aef..0000000 --- a/src/fim/FIMsrc/prep/sfcio/Makefile +++ /dev/null @@ -1,22 +0,0 @@ -# sfcio Makefile - -SHELL = /bin/sh - -include ../../macros.make - -#"-O0 -g -traceback -C" does not work with -mcmodel=medium -i-dynamic - JFM 12/12/07 -FLAGS = $(FFLAGS_NO_DEBUG) $(BYTE_SWAP_FLAG) $(DEBUG_FLAGS) -LIBSFCIO = $(LIBDIR)/libsfcio_4.a - -.SUFFIXES: -.SUFFIXES: .a .o .F90 - -all: $(LIBSFCIO) - -$(LIBSFCIO): $(LIBSFCIO)(sfcio_module.o) - -.F90.o: - $(FC) -c $(FLAGS) $< - -clean: - rm -f *.o sfcio*.mod diff --git a/src/fim/FIMsrc/prep/sfcio/sfcio_module.F90 b/src/fim/FIMsrc/prep/sfcio/sfcio_module.F90 deleted file mode 100644 index 691cbe8..0000000 --- a/src/fim/FIMsrc/prep/sfcio/sfcio_module.F90 +++ /dev/null @@ -1,2278 +0,0 @@ -!------------------------------------------------------------------------------- -module sfcio_module -!$$$ Module Documentation Block -! -! Module: sfcio_module API for global spectral surface file I/O -! Prgmmr: iredell Org: w/nx23 date: 1999-01-18 -! -! Abstract: This module provides an Application Program Interface -! for performing I/O on the surface restart file of the global spectral model. -! Functions include opening, reading, writing, and closing as well as -! allocating and deallocating data buffers used in the transfers. -! The I/O performed here is sequential. -! The transfers are limited to header records or data records. -! -! Program History Log: -! 1999-01-18 Mark Iredell -! -! Public Variables: -! sfcio_lhead1 Integer parameter length of first header record (=32) -! sfcio_intkind Integer parameter kind or length of passed integers (=4) -! sfcio_realkind Integer parameter kind or length of passed reals (=4) -! sfcio_dblekind Integer parameter kind or length of passed longreals (=8) -! sfcio_realfill Real(sfcio_realkind) fill value (=-9999.) -! sfcio_dblefill Real(sfcio_dblekind) fill value (=-9999.) -! -! Public Defined Types: -! sfcio_head Surface file header information -! clabsfc Character(sfcio_lhead1) ON85 label -! fhour Real(sfcio_realkind) forecast hour -! idate Integer(sfcio_intkind)(4) initial date -! (hour, month, day, 4-digit year) -! latb Integer(sfcio_intkind) latitudes -! lonb Integer(sfcio_intkind) longitudes -! ivs Integer(sfcio_intkind) version number -! lsoil Integer(sfcio_intkind) soil levels -! irealf Integer(sigio_intkind) floating point flag -! (=1 for 4-byte ieee, =2 for 8-byte ieee) -! lpl Integer(sfcio_intkind)(latb/2) lons per lat -! zsoil Real(sfcio_realkind) soil depths (meter) -! -! sfcio_data Surface file data fields -! tsea Real(sfcio_realkind)(:,:) pointer to lonb*latb -! surface temperature in K -! smc Real(sfcio_realkind)(:,:,:) pointer to lonb*latb*lsoil -! soil volumetric water content in fraction -! sheleg Real(sfcio_realkind)(:,:) pointer to lonb*latb -! snow depth in m -! stc Real(sfcio_realkind)(:,:,:) pointer to lonb*latb*lsoil -! soil temperature in K -! tg3 Real(sfcio_realkind)(:,:) pointer to lonb*latb -! deep soil temperature in K -! zorl Real(sfcio_realkind)(:,:) pointer to lonb*latb -! roughness in cm -! cv Real(sfcio_realkind)(:,:) pointer to lonb*latb -! convective cloud cover in fraction -! cvb Real(sfcio_realkind)(:,:) pointer to lonb*latb -! convective cloud bottom in kpa -! cvt Real(sfcio_realkind)(:,:) pointer to lonb*latb -! convective cloud top in kpa -! alvsf Real(sfcio_realkind)(:,:) pointer to lonb*latb -! albedo for visible scattered in fraction -! alvwf Real(sfcio_realkind)(:,:) pointer to lonb*latb -! albedo for visible beam in fraction -! alnsf Real(sfcio_realkind)(:,:) pointer to lonb*latb -! albedo for near-IR scattered in fraction -! alnwf Real(sfcio_realkind)(:,:) pointer to lonb*latb -! albedo for near-IR beam in fraction -! slmsk Real(sfcio_realkind)(:,:) pointer to lonb*latb -! sea-land-ice mask (0-sea, 1-land, 2-ice) -! vfrac Real(sfcio_realkind)(:,:) pointer to lonb*latb -! vegetation fraction in fraction -! canopy Real(sfcio_realkind)(:,:) pointer to lonb*latb -! canopy water in m -! f10m Real(sfcio_realkind)(:,:) pointer to lonb*latb -! 10-meter wind speed over lowest model wind speed -! t2m Real(sfcio_realkind)(:,:) pointer to lonb*latb -! 2-meter temperature in K -! q2m Real(sfcio_realkind)(:,:) pointer to lonb*latb -! 2-meter specific humidity in kg/kg -! vtype Real(sfcio_realkind)(:,:) pointer to lonb*latb -! vegetation type in integer 1-13 -! stype Real(sfcio_realkind)(:,:) pointer to lonb*latb -! soil type in integer 1-9 -! facsf Real(sfcio_realkind)(:,:) pointer to lonb*latb -! xxx in fraction -! facwf Real(sfcio_realkind)(:,:) pointer to lonb*latb -! xxx in fraction -! uustar Real(sfcio_realkind)(:,:) pointer to lonb*latb -! xxx in xxx -! ffmm Real(sfcio_realkind)(:,:) pointer to lonb*latb -! xxx in xxx -! ffhh Real(sfcio_realkind)(:,:) pointer to lonb*latb -! xxx in xxx -! hice Real(sfcio_realkind)(:,:) pointer to lonb*latb -! xxx in xxx -! fice Real(sfcio_realkind)(:,:) pointer to lonb*latb -! xxx in xxx -! tisfc Real(sfcio_realkind)(:,:) pointer to lonb*latb -! xxx in xxx -! tprcp Real(sfcio_realkind)(:,:) pointer to lonb*latb -! xxx in xxx -! srflag Real(sfcio_realkind)(:,:) pointer to lonb*latb -! xxx in xxx -! snwdph Real(sfcio_realkind)(:,:) pointer to lonb*latb -! xxx in xxx -! slc Real(sfcio_realkind)(:,:,:) pointer to lonb*latb*lsoil -! xxx in xxx -! shdmin Real(sfcio_realkind)(:,:) pointer to lonb*latb -! xxx in xxx -! shdmax Real(sfcio_realkind)(:,:) pointer to lonb*latb -! xxx in xxx -! slope Real(sfcio_realkind)(:,:) pointer to lonb*latb -! xxx in xxx -! snoalb Real(sfcio_realkind)(:,:) pointer to lonb*latb -! xxx in xxx -! orog Real(sfcio_realkind)(:,:) pointer to lonb*latb -! orography in m -! -! sfcio_dbta Surface file longreal data fields -! -! Public Subprograms: -! sfcio_sropen Open surface file for sequential reading -! lu Integer(sfcio_intkind) input logical unit -! cfname Character(*) input filename -! iret Integer(sfcio_intkind) output return code -! -! sfcio_swopen Open surface file for sequential writing -! lu Integer(sfcio_intkind) input logical unit -! cfname Character(*) input filename -! iret Integer(sfcio_intkind) output return code -! -! sfcio_sclose Close surface file for sequential I/O -! lu Integer(sfcio_intkind) input logical unit -! iret Integer(sfcio_intkind) output return code -! -! sfcio_srhead Read header information with sequential I/O -! lu Integer(sfcio_intkind) input logical unit -! head Type(sfcio_head) output header information -! iret Integer(sfcio_intkind) output return code -! -! sfcio_swhead Write header information with sequential I/O -! lu Integer(sfcio_intkind) input logical unit -! head Type(sfcio_head) input header information -! iret Integer(sfcio_intkind) output return code -! -! sfcio_alhead Allocate head allocatables -! head Type(sfcio_head) input/output header information -! iret Integer(sfcio_intkind) output return code -! latb Integer(sfcio_intkind) optional latitudes -! lsoil Integer(sfcio_intkind) optional soil levels -! -! sfcio_aldata Allocate data fields -! head Type(sfcio_head) input header information -! data Type(sfcio_data) output data fields -! iret Integer(sfcio_intkind) output return code -! -! sfcio_axdata Deallocate data fields -! data Type(sfcio_data) output data fields -! iret Integer(sfcio_intkind) output return code -! -! sfcio_srdata Read data fields with sequential I/O -! lu Integer(sfcio_intkind) input logical unit -! head Type(sfcio_head) input header information -! data Type(sfcio_data) output data fields -! iret Integer(sfcio_intkind) output return code -! -! sfcio_swdata Write data fields with sequential I/O -! lu Integer(sfcio_intkind) input logical unit -! head Type(sfcio_head) input header information -! data Type(sfcio_data) input data fields -! iret Integer(sfcio_intkind) output return code -! -! sfcio_srohdc Open, read header & data and close with sequential I/O -! lu Integer(sfcio_intkind) input logical unit -! cfname Character(*) input filename -! head Type(sfcio_head) output header information -! data Type(sfcio_data) output data fields -! iret Integer(sfcio_intkind) output return code -! -! sfcio_swohdc Open, write header & data and close with sequential I/O -! lu Integer(sfcio_intkind) input logical unit -! cfname Character(*) input filename -! head Type(sfcio_head) input header information -! data Type(sfcio_data) input data fields -! iret Integer(sfcio_intkind) output return code -! -! sfcio_aldbta Allocate longreal data fields -! head Type(sfcio_head) input header information -! dbta Type(sfcio_dbta) output longreal data fields -! iret Integer(sfcio_intkind) output return code -! -! sfcio_axdbta Deallocate longreal data fields -! dbta Type(sfcio_dbta) output longreal data fields -! iret Integer(sfcio_intkind) output return code -! -! sfcio_srdbta Read longreal data fields with sequential I/O -! lu Integer(sfcio_intkind) input logical unit -! head Type(sfcio_head) input header information -! dbta Type(sfcio_dbta) output longreal data fields -! iret Integer(sfcio_intkind) output return code -! -! sfcio_swdbta Write longreal data fields with sequential I/O -! lu Integer(sfcio_intkind) input logical unit -! head Type(sfcio_head) input header information -! dbta Type(sfcio_dbta) input longreal data fields -! iret Integer(sfcio_intkind) output return code -! -! Remarks: -! (1) Here's the supported surface file formats. -! For ivs=199802 (read-only): -! ON85 label (32 bytes) -! Header information record containing -! fhour, idate, lonb, latb, ivs (8 4-byte words) -! tsea (lonb*latb 4-byte words) -! smc (lonb*latb*lsoil 4-byte words) -! sheleg (lonb*latb 4-byte words) -! stc (lonb*latb*lsoil 4-byte words) -! tg3 (lonb*latb 4-byte words) -! zorl (lonb*latb 4-byte words) -! cv (lonb*latb 4-byte words) -! cvb (lonb*latb 4-byte words) -! cvt (lonb*latb 4-byte words) -! alvsf,alvwf,alnsf,alnwf (lonb*latb*4 4-byte words) -! slmsk (lonb*latb 4-byte words) -! vfrac (lonb*latb 4-byte words) -! canopy (lonb*latb 4-byte words) -! f10m (lonb*latb 4-byte words) -! vtype (lonb*latb 4-byte words) -! stype (lonb*latb 4-byte words) -! facsf,facwf (lonb*latb*2 4-byte words) -! uustar (lonb*latb 4-byte words) -! ffmm (lonb*latb 4-byte words) -! ffhh (lonb*latb 4-byte words) -! For ivs=200004: -! ON85 label (32 bytes) -! Header information record containing -! fhour, idate, lonb, latb, ivs, lpl (8+latb/2 4-byte words) -! tsea (lonb*latb 4-byte words) -! smc (lonb*latb*lsoil 4-byte words) -! sheleg (lonb*latb 4-byte words) -! stc (lonb*latb*lsoil 4-byte words) -! tg3 (lonb*latb 4-byte words) -! zorl (lonb*latb 4-byte words) -! cv (lonb*latb 4-byte words) -! cvb (lonb*latb 4-byte words) -! cvt (lonb*latb 4-byte words) -! alvsf,alvwf,alnsf,alnwf (lonb*latb*4 4-byte words) -! slmsk (lonb*latb 4-byte words) -! vfrac (lonb*latb 4-byte words) -! canopy (lonb*latb 4-byte words) -! f10m (lonb*latb 4-byte words) -! vtype (lonb*latb 4-byte words) -! stype (lonb*latb 4-byte words) -! facsf,facwf (lonb*latb*2 4-byte words) -! uustar (lonb*latb 4-byte words) -! ffmm (lonb*latb 4-byte words) -! ffhh (lonb*latb 4-byte words) -! For ivs=200412 (read-only): -! ON85 label (32 bytes) -! Header information record containing -! fhour, idate, lonb, latb, ivs, lpl (8+latb/2 4-byte words) -! tsea (lonb*latb 4-byte words) -! smc (lonb*latb*lsoil 4-byte words) -! sheleg (lonb*latb 4-byte words) -! stc (lonb*latb*lsoil 4-byte words) -! tg3 (lonb*latb 4-byte words) -! zorl (lonb*latb 4-byte words) -! cv (lonb*latb 4-byte words) -! cvb (lonb*latb 4-byte words) -! cvt (lonb*latb 4-byte words) -! alvsf,alvwf,alnsf,alnwf (lonb*latb*4 4-byte words) -! slmsk (lonb*latb 4-byte words) -! vfrac (lonb*latb 4-byte words) -! canopy (lonb*latb 4-byte words) -! f10m (lonb*latb 4-byte words) -! vtype (lonb*latb 4-byte words) -! stype (lonb*latb 4-byte words) -! facsf,facwf (lonb*latb*2 4-byte words) -! uustar (lonb*latb 4-byte words) -! ffmm (lonb*latb 4-byte words) -! ffhh (lonb*latb 4-byte words) -! hice (lonb*latb 4-byte words) -! fice (lonb*latb 4-byte words) -! tisfc (lonb*latb 4-byte words) -! tprcp (lonb*latb 4-byte words) -! srflag (lonb*latb 4-byte words) -! snwdph (lonb*latb 4-byte words) -! slc (lonb*latb*lsoil 4-byte words) -! shdmin (lonb*latb 4-byte words) -! shdmax (lonb*latb 4-byte words) -! slope (lonb*latb 4-byte words) -! snoalb (lonb*latb 4-byte words) -! For ivs=200501: -! Label containing -! 'GFS ','SFC ',ivs,nhead,ndata,reserved(3) (8 4-byte words) -! Header records -! lhead(nhead),ldata(ndata) (nhead+ndata 4-byte words) -! fhour, idate(4), lonb, latb, lsoil (8 4-byte words) -! lpl (latb/2 4-byte words) -! zsoil (lsoil 4-byte words) -! Data records -! slmsk (lonb*latb 4-byte words) -! orog (lonb*latb 4-byte words) -! tsea (lonb*latb 4-byte words) -! sheleg (lonb*latb 4-byte words) -! tg3 (lonb*latb 4-byte words) -! zorl (lonb*latb 4-byte words) -! alvsf (lonb*latb 4-byte words) -! alvwf (lonb*latb 4-byte words) -! alnsf (lonb*latb 4-byte words) -! alnwf (lonb*latb 4-byte words) -! vfrac (lonb*latb 4-byte words) -! canopy (lonb*latb 4-byte words) -! f10m (lonb*latb 4-byte words) -! vtype (lonb*latb 4-byte words) -! stype (lonb*latb 4-byte words) -! facsf (lonb*latb 4-byte words) -! facwf (lonb*latb 4-byte words) -! uustar (lonb*latb 4-byte words) -! ffmm (lonb*latb 4-byte words) -! ffhh (lonb*latb 4-byte words) -! hice (lonb*latb 4-byte words) -! fice (lonb*latb 4-byte words) -! tprcp (lonb*latb 4-byte words) -! srflag (lonb*latb 4-byte words) -! snwdph (lonb*latb 4-byte words) -! shdmin (lonb*latb 4-byte words) -! shdmax (lonb*latb 4-byte words) -! slope (lonb*latb 4-byte words) -! snoalb (lonb*latb 4-byte words) -! lsoil stc (lonb*latb 4-byte words) -! lsoil smc (lonb*latb 4-byte words) -! lsoil slc (lonb*latb 4-byte words) -! For ivs=200509: -! Label containing -! 'GFS ','SFC ',ivs,nhead,ndata,reserved(3) (8 4-byte words) -! Header records -! lhead(nhead),ldata(ndata) (nhead+ndata 4-byte words) -! fhour, idate(4), lonb, latb, lsoil, irealf, -! reserved(16) (25 4-byte words) -! lpl (latb/2 4-byte words) -! zsoil (lsoil 4-byte words) -! Data records -! slmsk (lonb*latb 4-byte words) -! orog (lonb*latb 4-byte words) -! tsea (lonb*latb 4-byte words) -! sheleg (lonb*latb 4-byte words) -! tg3 (lonb*latb 4-byte words) -! zorl (lonb*latb 4-byte words) -! alvsf (lonb*latb 4-byte words) -! alvwf (lonb*latb 4-byte words) -! alnsf (lonb*latb 4-byte words) -! alnwf (lonb*latb 4-byte words) -! vfrac (lonb*latb 4-byte words) -! canopy (lonb*latb 4-byte words) -! f10m (lonb*latb 4-byte words) -! t2m (lonb*latb 4-byte words) -! q2m (lonb*latb 4-byte words) -! vtype (lonb*latb 4-byte words) -! stype (lonb*latb 4-byte words) -! facsf (lonb*latb 4-byte words) -! facwf (lonb*latb 4-byte words) -! uustar (lonb*latb 4-byte words) -! ffmm (lonb*latb 4-byte words) -! ffhh (lonb*latb 4-byte words) -! hice (lonb*latb 4-byte words) -! fice (lonb*latb 4-byte words) -! tisfc (lonb*latb 4-byte words) -! tprcp (lonb*latb 4-byte words) -! srflag (lonb*latb 4-byte words) -! snwdph (lonb*latb 4-byte words) -! shdmin (lonb*latb 4-byte words) -! shdmax (lonb*latb 4-byte words) -! slope (lonb*latb 4-byte words) -! snoalb (lonb*latb 4-byte words) -! lsoil stc (lonb*latb 4-byte words) -! lsoil smc (lonb*latb 4-byte words) -! lsoil slc (lonb*latb 4-byte words) -! -! (2) Possible return codes: -! 0 Successful call -! -1 Open or close I/O error -! -2 Header record I/O error or unrecognized version -! -3 Allocation or deallocation error -! -4 Data record I/O error -! -5 Insufficient data dimensions allocated -! -! Examples: -! (1) Read the entire surface file 'sfcf24' and -! print out the northernmost surface temperature at greenwich. -! -! use sfcio_module -! type(sfcio_head):: head -! type(sfcio_data):: data -! call sfcio_srohdc(11,'sfcf24',head,data,iret) -! print '(f8.2)',data%tsea(1,1) -! end -! -! Attributes: -! Language: Fortran 90 -! -!$$$ - implicit none - private -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Public Variables - integer,parameter,public:: sfcio_lhead1=32 - integer,parameter,public:: sfcio_intkind=4,sfcio_realkind=4,sfcio_dblekind=8 - real(sfcio_realkind),parameter,public:: sfcio_realfill=-9999. - real(sfcio_dblekind),parameter,public:: sfcio_dblefill=sfcio_realfill -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Public Types - type,public:: sfcio_head - character(sfcio_lhead1):: clabsfc=' ' - real(sfcio_realkind):: fhour=0. - integer(sfcio_intkind):: idate(4)=(/0,0,0,0/),latb=0,lonb=0,lsoil=0,ivs=0 - integer(sfcio_intkind):: irealf=1 - integer(sfcio_intkind),allocatable:: lpl(:) - real(sfcio_realkind),allocatable:: zsoil(:) - end type - type,public:: sfcio_data - real(sfcio_realkind),pointer:: tsea(:,:)=>null() - real(sfcio_realkind),pointer:: smc(:,:,:)=>null() - real(sfcio_realkind),pointer:: sheleg(:,:)=>null() - real(sfcio_realkind),pointer:: stc(:,:,:)=>null() - real(sfcio_realkind),pointer:: tg3(:,:)=>null() - real(sfcio_realkind),pointer:: zorl(:,:)=>null() - real(sfcio_realkind),pointer:: cv(:,:)=>null() - real(sfcio_realkind),pointer:: cvb(:,:)=>null() - real(sfcio_realkind),pointer:: cvt(:,:)=>null() - real(sfcio_realkind),pointer:: alvsf(:,:)=>null() - real(sfcio_realkind),pointer:: alvwf(:,:)=>null() - real(sfcio_realkind),pointer:: alnsf(:,:)=>null() - real(sfcio_realkind),pointer:: alnwf(:,:)=>null() - real(sfcio_realkind),pointer:: slmsk(:,:)=>null() - real(sfcio_realkind),pointer:: vfrac(:,:)=>null() - real(sfcio_realkind),pointer:: canopy(:,:)=>null() - real(sfcio_realkind),pointer:: f10m(:,:)=>null() - real(sfcio_realkind),pointer:: t2m(:,:)=>null() - real(sfcio_realkind),pointer:: q2m(:,:)=>null() - real(sfcio_realkind),pointer:: vtype(:,:)=>null() - real(sfcio_realkind),pointer:: stype(:,:)=>null() - real(sfcio_realkind),pointer:: facsf(:,:)=>null() - real(sfcio_realkind),pointer:: facwf(:,:)=>null() - real(sfcio_realkind),pointer:: uustar(:,:)=>null() - real(sfcio_realkind),pointer:: ffmm(:,:)=>null() - real(sfcio_realkind),pointer:: ffhh(:,:)=>null() - real(sfcio_realkind),pointer:: hice(:,:)=>null() - real(sfcio_realkind),pointer:: fice(:,:)=>null() - real(sfcio_realkind),pointer:: tisfc(:,:)=>null() - real(sfcio_realkind),pointer:: tprcp(:,:)=>null() - real(sfcio_realkind),pointer:: srflag(:,:)=>null() - real(sfcio_realkind),pointer:: snwdph(:,:)=>null() - real(sfcio_realkind),pointer:: slc(:,:,:)=>null() - real(sfcio_realkind),pointer:: shdmin(:,:)=>null() - real(sfcio_realkind),pointer:: shdmax(:,:)=>null() - real(sfcio_realkind),pointer:: slope(:,:)=>null() - real(sfcio_realkind),pointer:: snoalb(:,:)=>null() - real(sfcio_realkind),pointer:: orog(:,:)=>null() - end type - type,public:: sfcio_dbta - real(sfcio_dblekind),pointer:: tsea(:,:)=>null() - real(sfcio_dblekind),pointer:: smc(:,:,:)=>null() - real(sfcio_dblekind),pointer:: sheleg(:,:)=>null() - real(sfcio_dblekind),pointer:: stc(:,:,:)=>null() - real(sfcio_dblekind),pointer:: tg3(:,:)=>null() - real(sfcio_dblekind),pointer:: zorl(:,:)=>null() - real(sfcio_dblekind),pointer:: cv(:,:)=>null() - real(sfcio_dblekind),pointer:: cvb(:,:)=>null() - real(sfcio_dblekind),pointer:: cvt(:,:)=>null() - real(sfcio_dblekind),pointer:: alvsf(:,:)=>null() - real(sfcio_dblekind),pointer:: alvwf(:,:)=>null() - real(sfcio_dblekind),pointer:: alnsf(:,:)=>null() - real(sfcio_dblekind),pointer:: alnwf(:,:)=>null() - real(sfcio_dblekind),pointer:: slmsk(:,:)=>null() - real(sfcio_dblekind),pointer:: vfrac(:,:)=>null() - real(sfcio_dblekind),pointer:: canopy(:,:)=>null() - real(sfcio_dblekind),pointer:: f10m(:,:)=>null() - real(sfcio_dblekind),pointer:: t2m(:,:)=>null() - real(sfcio_dblekind),pointer:: q2m(:,:)=>null() - real(sfcio_dblekind),pointer:: vtype(:,:)=>null() - real(sfcio_dblekind),pointer:: stype(:,:)=>null() - real(sfcio_dblekind),pointer:: facsf(:,:)=>null() - real(sfcio_dblekind),pointer:: facwf(:,:)=>null() - real(sfcio_dblekind),pointer:: uustar(:,:)=>null() - real(sfcio_dblekind),pointer:: ffmm(:,:)=>null() - real(sfcio_dblekind),pointer:: ffhh(:,:)=>null() - real(sfcio_dblekind),pointer:: hice(:,:)=>null() - real(sfcio_dblekind),pointer:: fice(:,:)=>null() - real(sfcio_dblekind),pointer:: tisfc(:,:)=>null() - real(sfcio_dblekind),pointer:: tprcp(:,:)=>null() - real(sfcio_dblekind),pointer:: srflag(:,:)=>null() - real(sfcio_dblekind),pointer:: snwdph(:,:)=>null() - real(sfcio_dblekind),pointer:: slc(:,:,:)=>null() - real(sfcio_dblekind),pointer:: shdmin(:,:)=>null() - real(sfcio_dblekind),pointer:: shdmax(:,:)=>null() - real(sfcio_dblekind),pointer:: slope(:,:)=>null() - real(sfcio_dblekind),pointer:: snoalb(:,:)=>null() - real(sfcio_dblekind),pointer:: orog(:,:)=>null() - end type -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Public Subprograms - public sfcio_sropen,sfcio_swopen,sfcio_sclose,sfcio_srhead,sfcio_swhead - public sfcio_alhead,sfcio_aldata,sfcio_axdata,sfcio_srdata,sfcio_swdata - public sfcio_aldbta,sfcio_axdbta,sfcio_srdbta,sfcio_swdbta - public sfcio_srohdc,sfcio_swohdc - interface sfcio_srohdc - module procedure sfcio_srohdca,sfcio_srohdcb - end interface - interface sfcio_swohdc - module procedure sfcio_swohdca,sfcio_swohdcb - end interface -contains -!------------------------------------------------------------------------------- - subroutine sfcio_sropen(lu,cfname,iret) - implicit none - integer(sfcio_intkind),intent(in):: lu - character*(*),intent(in):: cfname - integer(sfcio_intkind),intent(out):: iret - integer ios -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - open(lu,file=cfname,form='unformatted',& - status='old',action='read',iostat=ios) - iret=ios - if(iret.ne.0) iret=-1 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sfcio_swopen(lu,cfname,iret) - implicit none - integer(sfcio_intkind),intent(in):: lu - character*(*),intent(in):: cfname - integer(sfcio_intkind),intent(out):: iret - integer ios -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - open(lu,file=cfname,form='unformatted',& - status='unknown',action='readwrite',iostat=ios) - iret=ios - if(iret.ne.0) iret=-1 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sfcio_sclose(lu,iret) - implicit none - integer(sfcio_intkind),intent(in):: lu - integer(sfcio_intkind),intent(out):: iret - integer ios -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - close(lu,iostat=ios) - iret=ios - if(iret.ne.0) iret=-1 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sfcio_srhead(lu,head,iret) - implicit none - integer(sfcio_intkind),intent(in):: lu - type(sfcio_head),intent(out):: head - integer(sfcio_intkind),intent(out):: iret - integer:: ios - character(4):: cgfs,csfc - integer(sfcio_intkind):: nhead,ndata,nresv(3) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=-2 - rewind lu - read(lu,iostat=ios) head%clabsfc - if(ios.ne.0) return - if(head%clabsfc(1:8).eq.'GFS SFC ') then ! modern surface file - rewind lu - read(lu,iostat=ios) cgfs,csfc,head%ivs,nhead,ndata,nresv - if(ios.ne.0) return - if(head%ivs.eq.200509) then - read(lu,iostat=ios) - if(ios.ne.0) return - read(lu,iostat=ios) head%fhour,head%idate,head%lonb,head%latb,& - head%lsoil,head%irealf - if(ios.ne.0) return - call sfcio_alhead(head,ios) - if(ios.ne.0) return - read(lu,iostat=ios) head%lpl - if(ios.ne.0) return - read(lu,iostat=ios) head%zsoil - if(ios.ne.0) return - elseif(head%ivs.eq.200501) then - read(lu,iostat=ios) - if(ios.ne.0) return - read(lu,iostat=ios) head%fhour,head%idate,head%lonb,head%latb,head%lsoil - if(ios.ne.0) return - call sfcio_alhead(head,ios) - if(ios.ne.0) return - read(lu,iostat=ios) head%lpl - if(ios.ne.0) return - read(lu,iostat=ios) head%zsoil - if(ios.ne.0) return - else - return - endif - else - read(lu,iostat=ios) head%fhour,head%idate,head%lonb,head%latb,head%ivs - if(ios.ne.0) return - if(head%ivs.eq.199802) then - head%lsoil=2 - call sfcio_alhead(head,ios) - if(ios.ne.0) return - head%lpl=head%lonb - head%zsoil=(/-0.1,-2.0/) - elseif(head%ivs.eq.200004) then - head%lsoil=2 - call sfcio_alhead(head,ios) - if(ios.ne.0) return - rewind lu - read(lu) head%clabsfc - read(lu,iostat=ios) head%fhour,head%idate,head%lonb,head%latb,head%ivs,& - head%lpl - if(ios.ne.0) return - head%zsoil=(/-0.1,-2.0/) - elseif(head%ivs.eq.200412) then - head%lsoil=4 - call sfcio_alhead(head,ios) - if(ios.ne.0) return - rewind lu - read(lu) head%clabsfc - read(lu,iostat=ios) head%fhour,head%idate,head%lonb,head%latb,head%ivs,& - head%lpl - if(ios.ne.0) return - head%zsoil=(/-0.1,-0.4,-1.0,-2.0/) - else - return - endif - iret=0 - endif - iret=0 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sfcio_swhead(lu,head,iret) - implicit none - integer(sfcio_intkind),intent(in):: lu - type(sfcio_head),intent(in):: head - integer(sfcio_intkind),intent(out):: iret - integer:: ios - integer i -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=-2 - if(head%ivs.eq.200509) then - rewind lu - write(lu,iostat=ios) 'GFS SFC ',head%ivs,5,29+3*head%lsoil,0,0,0 - if(ios.ne.0) return - write(lu,iostat=ios) 4*(/8,5+29+3*head%lsoil,25,head%latb/2,head%lsoil/),& - 4*head%irealf*(/(head%lonb*head%latb,& - i=1,29+3*head%lsoil)/) - if(ios.ne.0) return - write(lu,iostat=ios) head%fhour,head%idate,head%lonb,head%latb,& - head%lsoil,head%irealf,(0,i=1,16) - if(ios.ne.0) return - write(lu,iostat=ios) head%lpl - if(ios.ne.0) return - write(lu,iostat=ios) head%zsoil - if(ios.ne.0) return - iret=0 - elseif(head%ivs.eq.200501) then - rewind lu - write(lu,iostat=ios) 'GFS SFC ',head%ivs,5,29+3*head%lsoil,0,0,0 - if(ios.ne.0) return - write(lu,iostat=ios) 4*(/8,5+29+3*head%lsoil,8,head%latb/2,head%lsoil/),& - 4*(/(head%lonb*head%latb,i=1,29+3*head%lsoil)/) - if(ios.ne.0) return - write(lu,iostat=ios) head%fhour,head%idate,head%lonb,head%latb,head%lsoil - if(ios.ne.0) return - write(lu,iostat=ios) head%lpl - if(ios.ne.0) return - write(lu,iostat=ios) head%zsoil - if(ios.ne.0) return - iret=0 - elseif(head%ivs.eq.200004.and.head%lsoil.eq.2) then - rewind lu - write(lu,iostat=ios) head%clabsfc - if(ios.ne.0) return - write(lu,iostat=ios) head%fhour,head%idate,head%lonb,head%latb,head%ivs,& - head%lpl - if(ios.ne.0) return - iret=0 - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sfcio_alhead(head,iret,latb,lsoil) - implicit none - type(sfcio_head),intent(inout):: head - integer(sfcio_intkind),intent(out):: iret - integer(sfcio_intkind),optional,intent(in):: latb,lsoil - integer dim1l,dim1z -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(present(latb)) then - dim1l=latb/2 - else - dim1l=head%latb/2 - endif - if(present(lsoil)) then - dim1z=lsoil - else - dim1z=head%lsoil - endif - if(allocated(head%lpl)) deallocate(head%lpl) - if(allocated(head%zsoil)) deallocate(head%zsoil) - allocate(head%lpl(dim1l),head%zsoil(dim1z),stat=iret) - if(iret.eq.0) then - head%lpl=0 - head%zsoil=sfcio_realfill - endif - if(iret.ne.0) iret=-3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sfcio_aldata(head,data,iret) - implicit none - type(sfcio_head),intent(in):: head - type(sfcio_data),intent(inout):: data - integer(sfcio_intkind),intent(out):: iret - integer dim1,dim2,dim3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sfcio_axdata(data,iret) - dim1=head%lonb - dim2=head%latb - dim3=head%lsoil - allocate(& - data%tsea(dim1,dim2),& - data%smc(dim1,dim2,dim3),& - data%sheleg(dim1,dim2),& - data%stc(dim1,dim2,dim3),& - data%tg3(dim1,dim2),& - data%zorl(dim1,dim2),& - data%cv(dim1,dim2),& - data%cvb(dim1,dim2),& - data%cvt(dim1,dim2),& - data%alvsf(dim1,dim2),& - data%alvwf(dim1,dim2),& - data%alnsf(dim1,dim2),& - data%alnwf(dim1,dim2),& - data%slmsk(dim1,dim2),& - data%vfrac(dim1,dim2),& - data%canopy(dim1,dim2),& - data%f10m(dim1,dim2),& - data%t2m(dim1,dim2),& - data%q2m(dim1,dim2),& - data%vtype(dim1,dim2),& - data%stype(dim1,dim2),& - data%facsf(dim1,dim2),& - data%facwf(dim1,dim2),& - data%uustar(dim1,dim2),& - data%ffmm(dim1,dim2),& - data%ffhh(dim1,dim2),& - data%hice(dim1,dim2),& - data%fice(dim1,dim2),& - data%tisfc(dim1,dim2),& - data%tprcp(dim1,dim2),& - data%srflag(dim1,dim2),& - data%snwdph(dim1,dim2),& - data%slc(dim1,dim2,dim3),& - data%shdmin(dim1,dim2),& - data%shdmax(dim1,dim2),& - data%slope(dim1,dim2),& - data%snoalb(dim1,dim2),& - data%orog(dim1,dim2),& - stat=iret) - if(iret.ne.0) iret=-3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sfcio_axdata(data,iret) - implicit none - type(sfcio_data),intent(inout):: data - integer(sfcio_intkind),intent(out):: iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - deallocate(& - data%tsea,& - data%smc,& - data%sheleg,& - data%stc,& - data%tg3,& - data%zorl,& - data%cv,& - data%cvb,& - data%cvt,& - data%alvsf,& - data%alvwf,& - data%alnsf,& - data%alnwf,& - data%slmsk,& - data%vfrac,& - data%canopy,& - data%f10m,& - data%t2m,& - data%q2m,& - data%vtype,& - data%stype,& - data%facsf,& - data%facwf,& - data%uustar,& - data%ffmm,& - data%ffhh,& - data%hice,& - data%fice,& - data%tisfc,& - data%tprcp,& - data%srflag,& - data%snwdph,& - data%slc,& - data%shdmin,& - data%shdmax,& - data%slope,& - data%snoalb,& - data%orog,& - stat=iret) - nullify(& - data%tsea,& - data%smc,& - data%sheleg,& - data%stc,& - data%tg3,& - data%zorl,& - data%cv,& - data%cvb,& - data%cvt,& - data%alvsf,& - data%alvwf,& - data%alnsf,& - data%alnwf,& - data%slmsk,& - data%vfrac,& - data%canopy,& - data%f10m,& - data%t2m,& - data%q2m,& - data%vtype,& - data%stype,& - data%facsf,& - data%facwf,& - data%uustar,& - data%ffmm,& - data%ffhh,& - data%hice,& - data%fice,& - data%tisfc,& - data%tprcp,& - data%srflag,& - data%snwdph,& - data%slc,& - data%shdmin,& - data%shdmax,& - data%slope,& - data%snoalb,& - data%orog) - if(iret.ne.0) iret=-3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sfcio_srdata(lu,head,data,iret) - implicit none - integer(sfcio_intkind),intent(in):: lu - type(sfcio_head),intent(in):: head - type(sfcio_data),intent(inout):: data - integer(sfcio_intkind),intent(out):: iret - integer:: dim1,dim2,dim3,mdim1,mdim2,mdim3 - integer:: ios - integer i - type(sfcio_dbta) dbta -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - dim1=head%lonb - dim2=head%latb - dim3=head%lsoil - mdim1=min(& - size(data%tsea,1),& - size(data%smc,1),& - size(data%sheleg,1),& - size(data%stc,1),& - size(data%tg3,1),& - size(data%zorl,1),& - size(data%alvsf,1),& - size(data%alvwf,1),& - size(data%alnsf,1),& - size(data%alnwf,1),& - size(data%slmsk,1),& - size(data%vfrac,1),& - size(data%canopy,1),& - size(data%f10m,1),& - size(data%t2m,1),& - size(data%q2m,1),& - size(data%vtype,1),& - size(data%stype,1),& - size(data%facsf,1),& - size(data%facwf,1),& - size(data%uustar,1),& - size(data%ffmm,1),& - size(data%ffhh,1),& - size(data%hice,1),& - size(data%fice,1),& - size(data%tisfc,1),& - size(data%tprcp,1),& - size(data%srflag,1),& - size(data%snwdph,1),& - size(data%slc,1),& - size(data%shdmin,1),& - size(data%shdmax,1),& - size(data%slope,1),& - size(data%snoalb,1),& - size(data%orog,1)) - mdim2=min(& - size(data%tsea,2),& - size(data%smc,2),& - size(data%sheleg,2),& - size(data%stc,2),& - size(data%tg3,2),& - size(data%zorl,2),& - size(data%alvsf,2),& - size(data%alvwf,2),& - size(data%alnsf,2),& - size(data%alnwf,2),& - size(data%slmsk,2),& - size(data%vfrac,2),& - size(data%canopy,2),& - size(data%f10m,2),& - size(data%t2m,2),& - size(data%q2m,2),& - size(data%vtype,2),& - size(data%stype,2),& - size(data%facsf,2),& - size(data%facwf,2),& - size(data%uustar,2),& - size(data%ffmm,2),& - size(data%ffhh,2),& - size(data%hice,2),& - size(data%fice,2),& - size(data%tisfc,2),& - size(data%tprcp,2),& - size(data%srflag,2),& - size(data%snwdph,2),& - size(data%slc,2),& - size(data%shdmin,2),& - size(data%shdmax,2),& - size(data%slope,2),& - size(data%snoalb,2),& - size(data%orog,2)) - mdim3=min(& - size(data%smc,3),& - size(data%stc,3),& - size(data%slc,3)) - iret=-5 - if(mdim1.lt.dim1.or.& - mdim2.lt.dim2.or.& - mdim3.lt.dim3) return - iret=-4 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - data%t2m(:dim1,:dim2)=sfcio_realfill - data%q2m(:dim1,:dim2)=sfcio_realfill - data%tisfc(:dim1,:dim2)=sfcio_realfill - if(head%ivs.eq.200509) then - if(head%irealf.ne.2) then - read(lu,iostat=ios) data%slmsk(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%orog(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%tsea(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%sheleg(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%tg3(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%zorl(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%alvsf(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%alvwf(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%alnsf(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%alnwf(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%vfrac(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%canopy(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%f10m(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%t2m(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%q2m(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%vtype(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%stype(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%facsf(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%facwf(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%uustar(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%ffmm(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%ffhh(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%hice(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%fice(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%tisfc(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%tprcp(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%srflag(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%snwdph(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%shdmin(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%shdmax(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%slope(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%snoalb(:dim1,:dim2) - if(ios.ne.0) return - do i=1,head%lsoil - read(lu,iostat=ios) data%stc(:dim1,:dim2,i) - if(ios.ne.0) return - enddo - do i=1,head%lsoil - read(lu,iostat=ios) data%smc(:dim1,:dim2,i) - if(ios.ne.0) return - enddo - do i=1,head%lsoil - read(lu,iostat=ios) data%slc(:dim1,:dim2,i) - if(ios.ne.0) return - enddo - data%cv(:dim1,:dim2)=sfcio_realfill - data%cvb(:dim1,:dim2)=sfcio_realfill - data%cvt(:dim1,:dim2)=sfcio_realfill - else - call sfcio_aldbta(head,dbta,iret) - if(iret.ne.0) return - call sfcio_srdbta(lu,head,dbta,iret) - if(iret.ne.0) return - data%tsea(:dim1,:dim2)=dbta%tsea(:dim1,:dim2) - data%smc(:dim1,:dim2,:dim3)=dbta%smc(:dim1,:dim2,:dim3) - data%sheleg(:dim1,:dim2)=dbta%sheleg(:dim1,:dim2) - data%stc(:dim1,:dim2,:dim3)=dbta%stc(:dim1,:dim2,:dim3) - data%tg3(:dim1,:dim2)=dbta%tg3(:dim1,:dim2) - data%zorl(:dim1,:dim2)=dbta%zorl(:dim1,:dim2) - data%cv(:dim1,:dim2)=dbta%cv(:dim1,:dim2) - data%cvb(:dim1,:dim2)=dbta%cvb(:dim1,:dim2) - data%cvt(:dim1,:dim2)=dbta%cvt(:dim1,:dim2) - data%alvsf(:dim1,:dim2)=dbta%alvsf(:dim1,:dim2) - data%alvwf(:dim1,:dim2)=dbta%alvwf(:dim1,:dim2) - data%alnsf(:dim1,:dim2)=dbta%alnsf(:dim1,:dim2) - data%alnwf(:dim1,:dim2)=dbta%alnwf(:dim1,:dim2) - data%slmsk(:dim1,:dim2)=dbta%slmsk(:dim1,:dim2) - data%vfrac(:dim1,:dim2)=dbta%vfrac(:dim1,:dim2) - data%canopy(:dim1,:dim2)=dbta%canopy(:dim1,:dim2) - data%f10m(:dim1,:dim2)=dbta%f10m(:dim1,:dim2) - data%t2m(:dim1,:dim2)=dbta%t2m(:dim1,:dim2) - data%q2m(:dim1,:dim2)=dbta%q2m(:dim1,:dim2) - data%vtype(:dim1,:dim2)=dbta%vtype(:dim1,:dim2) - data%stype(:dim1,:dim2)=dbta%stype(:dim1,:dim2) - data%facsf(:dim1,:dim2)=dbta%facsf(:dim1,:dim2) - data%facwf(:dim1,:dim2)=dbta%facwf(:dim1,:dim2) - data%uustar(:dim1,:dim2)=dbta%uustar(:dim1,:dim2) - data%ffmm(:dim1,:dim2)=dbta%ffmm(:dim1,:dim2) - data%ffhh(:dim1,:dim2)=dbta%ffhh(:dim1,:dim2) - data%hice(:dim1,:dim2)=dbta%hice(:dim1,:dim2) - data%fice(:dim1,:dim2)=dbta%fice(:dim1,:dim2) - data%tisfc(:dim1,:dim2)=dbta%tisfc(:dim1,:dim2) - data%tprcp(:dim1,:dim2)=dbta%tprcp(:dim1,:dim2) - data%srflag(:dim1,:dim2)=dbta%srflag(:dim1,:dim2) - data%snwdph(:dim1,:dim2)=dbta%snwdph(:dim1,:dim2) - data%slc(:dim1,:dim2,:dim3)=dbta%slc(:dim1,:dim2,:dim3) - data%shdmin(:dim1,:dim2)=dbta%shdmin(:dim1,:dim2) - data%shdmax(:dim1,:dim2)=dbta%shdmax(:dim1,:dim2) - data%slope(:dim1,:dim2)=dbta%slope(:dim1,:dim2) - data%snoalb(:dim1,:dim2)=dbta%snoalb(:dim1,:dim2) - data%orog(:dim1,:dim2)=dbta%orog(:dim1,:dim2) - call sfcio_axdbta(dbta,iret) - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - elseif(head%ivs.eq.200501.and.head%irealf.ne.2) then - read(lu,iostat=ios) data%slmsk(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%orog(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%tsea(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%sheleg(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%tg3(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%zorl(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%alvsf(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%alvwf(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%alnsf(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%alnwf(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%vfrac(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%canopy(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%f10m(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%vtype(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%stype(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%facsf(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%facwf(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%uustar(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%ffmm(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%ffhh(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%hice(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%fice(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%tprcp(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%srflag(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%snwdph(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%shdmin(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%shdmax(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%slope(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%snoalb(:dim1,:dim2) - if(ios.ne.0) return - do i=1,head%lsoil - read(lu,iostat=ios) data%stc(:dim1,:dim2,i) - if(ios.ne.0) return - enddo - do i=1,head%lsoil - read(lu,iostat=ios) data%smc(:dim1,:dim2,i) - if(ios.ne.0) return - enddo - do i=1,head%lsoil - read(lu,iostat=ios) data%slc(:dim1,:dim2,i) - if(ios.ne.0) return - enddo - data%cv(:dim1,:dim2)=sfcio_realfill - data%cvb(:dim1,:dim2)=sfcio_realfill - data%cvt(:dim1,:dim2)=sfcio_realfill -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - else - read(lu,iostat=ios) data%tsea(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%smc(:dim1,:dim2,:dim3) - if(ios.ne.0) return - read(lu,iostat=ios) data%sheleg(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%stc(:dim1,:dim2,:dim3) - if(ios.ne.0) return - read(lu,iostat=ios) data%tg3(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%zorl(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%cv(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%cvb(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%cvt(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%alvsf(:dim1,:dim2),& - data%alvwf(:dim1,:dim2),& - data%alnsf(:dim1,:dim2),& - data%alnwf(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%slmsk(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%vfrac(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%canopy(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%f10m(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%vtype(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%stype(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%facsf(:dim1,:dim2),& - data%facwf(:dim1,:dim2) - if(ios.ne.0) return - if(head%ivs.ge.200004) then - read(lu,iostat=ios) data%uustar(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%ffmm(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%ffhh(:dim1,:dim2) - if(ios.ne.0) return - else - data%uustar(:dim1,:dim2)=sfcio_realfill - data%ffmm(:dim1,:dim2)=sfcio_realfill - data%ffhh(:dim1,:dim2)=sfcio_realfill - endif - if(head%ivs.eq.200412) then - read(lu,iostat=ios) data%hice(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%fice(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%tprcp(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%srflag(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%snwdph(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%slc(:dim1,:dim2,:dim3) - if(ios.ne.0) return - read(lu,iostat=ios) data%shdmin(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%shdmax(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%slope(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%snoalb(:dim1,:dim2) - if(ios.ne.0) return - data%orog(:dim1,:dim2)=sfcio_realfill - else - data%hice(:dim1,:dim2)=sfcio_realfill - data%fice(:dim1,:dim2)=sfcio_realfill - data%tprcp(:dim1,:dim2)=sfcio_realfill - data%srflag(:dim1,:dim2)=sfcio_realfill - data%snwdph(:dim1,:dim2)=sfcio_realfill - data%slc(:dim1,:dim2,:dim3)=sfcio_realfill - data%shdmin(:dim1,:dim2)=sfcio_realfill - data%shdmax(:dim1,:dim2)=sfcio_realfill - data%slope(:dim1,:dim2)=sfcio_realfill - data%snoalb(:dim1,:dim2)=sfcio_realfill - data%orog(:dim1,:dim2)=sfcio_realfill - endif - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=0 - end subroutine -!------------------------------------------------------------------------------- - subroutine sfcio_swdata(lu,head,data,iret) - implicit none - integer(sfcio_intkind),intent(in):: lu - type(sfcio_head),intent(in):: head - type(sfcio_data),intent(in):: data - integer(sfcio_intkind),intent(out):: iret - integer:: dim1,dim2,dim3,mdim1,mdim2,mdim3 - integer:: ios - integer i - type(sfcio_dbta) dbta -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - dim1=head%lonb - dim2=head%latb - dim3=head%lsoil - mdim1=min(& - size(data%tsea,1),& - size(data%smc,1),& - size(data%sheleg,1),& - size(data%stc,1),& - size(data%tg3,1),& - size(data%zorl,1),& - size(data%alvsf,1),& - size(data%alvwf,1),& - size(data%alnsf,1),& - size(data%alnwf,1),& - size(data%slmsk,1),& - size(data%vfrac,1),& - size(data%canopy,1),& - size(data%f10m,1),& - size(data%t2m,1),& - size(data%q2m,1),& - size(data%vtype,1),& - size(data%stype,1),& - size(data%facsf,1),& - size(data%facwf,1),& - size(data%uustar,1),& - size(data%ffmm,1),& - size(data%ffhh,1),& - size(data%hice,1),& - size(data%fice,1),& - size(data%tisfc,1),& - size(data%tprcp,1),& - size(data%srflag,1),& - size(data%snwdph,1),& - size(data%slc,1),& - size(data%shdmin,1),& - size(data%shdmax,1),& - size(data%slope,1),& - size(data%snoalb,1),& - size(data%orog,1)) - mdim2=min(& - size(data%tsea,2),& - size(data%smc,2),& - size(data%sheleg,2),& - size(data%stc,2),& - size(data%tg3,2),& - size(data%zorl,2),& - size(data%alvsf,2),& - size(data%alvwf,2),& - size(data%alnsf,2),& - size(data%alnwf,2),& - size(data%slmsk,2),& - size(data%vfrac,2),& - size(data%canopy,2),& - size(data%f10m,2),& - size(data%t2m,2),& - size(data%q2m,2),& - size(data%vtype,2),& - size(data%stype,2),& - size(data%facsf,2),& - size(data%facwf,2),& - size(data%uustar,2),& - size(data%ffmm,2),& - size(data%ffhh,2),& - size(data%hice,2),& - size(data%fice,2),& - size(data%tisfc,2),& - size(data%tprcp,2),& - size(data%srflag,2),& - size(data%snwdph,2),& - size(data%slc,2),& - size(data%shdmin,2),& - size(data%shdmax,2),& - size(data%slope,2),& - size(data%snoalb,2),& - size(data%orog,2)) - mdim3=min(& - size(data%smc,3),& - size(data%stc,3),& - size(data%slc,3)) - iret=-5 - if(mdim1.lt.dim1.or.& - mdim2.lt.dim2.or.& - mdim3.lt.dim3) return - iret=-4 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(head%ivs.eq.200509) then - if(head%irealf.ne.2) then - write(lu,iostat=ios) data%slmsk(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%orog(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%tsea(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%sheleg(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%tg3(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%zorl(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%alvsf(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%alvwf(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%alnsf(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%alnwf(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%vfrac(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%canopy(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%f10m(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%t2m(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%q2m(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%vtype(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%stype(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%facsf(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%facwf(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%uustar(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%ffmm(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%ffhh(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%hice(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%fice(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%tisfc(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%tprcp(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%srflag(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%snwdph(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%shdmin(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%shdmax(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%slope(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%snoalb(:dim1,:dim2) - if(ios.ne.0) return - do i=1,head%lsoil - write(lu,iostat=ios) data%stc(:dim1,:dim2,i) - if(ios.ne.0) return - enddo - do i=1,head%lsoil - write(lu,iostat=ios) data%smc(:dim1,:dim2,i) - if(ios.ne.0) return - enddo - do i=1,head%lsoil - write(lu,iostat=ios) data%slc(:dim1,:dim2,i) - if(ios.ne.0) return - enddo - else - call sfcio_aldbta(head,dbta,iret) - if(iret.ne.0) return - dbta%tsea(:dim1,:dim2)=data%tsea(:dim1,:dim2) - dbta%smc(:dim1,:dim2,:dim3)=data%smc(:dim1,:dim2,:dim3) - dbta%sheleg(:dim1,:dim2)=data%sheleg(:dim1,:dim2) - dbta%stc(:dim1,:dim2,:dim3)=data%stc(:dim1,:dim2,:dim3) - dbta%tg3(:dim1,:dim2)=data%tg3(:dim1,:dim2) - dbta%zorl(:dim1,:dim2)=data%zorl(:dim1,:dim2) - dbta%cv(:dim1,:dim2)=data%cv(:dim1,:dim2) - dbta%cvb(:dim1,:dim2)=data%cvb(:dim1,:dim2) - dbta%cvt(:dim1,:dim2)=data%cvt(:dim1,:dim2) - dbta%alvsf(:dim1,:dim2)=data%alvsf(:dim1,:dim2) - dbta%alvwf(:dim1,:dim2)=data%alvwf(:dim1,:dim2) - dbta%alnsf(:dim1,:dim2)=data%alnsf(:dim1,:dim2) - dbta%alnwf(:dim1,:dim2)=data%alnwf(:dim1,:dim2) - dbta%slmsk(:dim1,:dim2)=data%slmsk(:dim1,:dim2) - dbta%vfrac(:dim1,:dim2)=data%vfrac(:dim1,:dim2) - dbta%canopy(:dim1,:dim2)=data%canopy(:dim1,:dim2) - dbta%f10m(:dim1,:dim2)=data%f10m(:dim1,:dim2) - dbta%t2m(:dim1,:dim2)=data%t2m(:dim1,:dim2) - dbta%q2m(:dim1,:dim2)=data%q2m(:dim1,:dim2) - dbta%vtype(:dim1,:dim2)=data%vtype(:dim1,:dim2) - dbta%stype(:dim1,:dim2)=data%stype(:dim1,:dim2) - dbta%facsf(:dim1,:dim2)=data%facsf(:dim1,:dim2) - dbta%facwf(:dim1,:dim2)=data%facwf(:dim1,:dim2) - dbta%uustar(:dim1,:dim2)=data%uustar(:dim1,:dim2) - dbta%ffmm(:dim1,:dim2)=data%ffmm(:dim1,:dim2) - dbta%ffhh(:dim1,:dim2)=data%ffhh(:dim1,:dim2) - dbta%hice(:dim1,:dim2)=data%hice(:dim1,:dim2) - dbta%fice(:dim1,:dim2)=data%fice(:dim1,:dim2) - dbta%tisfc(:dim1,:dim2)=data%tisfc(:dim1,:dim2) - dbta%tprcp(:dim1,:dim2)=data%tprcp(:dim1,:dim2) - dbta%srflag(:dim1,:dim2)=data%srflag(:dim1,:dim2) - dbta%snwdph(:dim1,:dim2)=data%snwdph(:dim1,:dim2) - dbta%slc(:dim1,:dim2,:dim3)=data%slc(:dim1,:dim2,:dim3) - dbta%shdmin(:dim1,:dim2)=data%shdmin(:dim1,:dim2) - dbta%shdmax(:dim1,:dim2)=data%shdmax(:dim1,:dim2) - dbta%slope(:dim1,:dim2)=data%slope(:dim1,:dim2) - dbta%snoalb(:dim1,:dim2)=data%snoalb(:dim1,:dim2) - dbta%orog(:dim1,:dim2)=data%orog(:dim1,:dim2) - call sfcio_swdbta(lu,head,dbta,iret) - if(iret.ne.0) return - call sfcio_axdbta(dbta,iret) - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - elseif(head%ivs.eq.200501.and.head%irealf.ne.2) then - write(lu,iostat=ios) data%slmsk(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%orog(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%tsea(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%sheleg(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%tg3(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%zorl(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%alvsf(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%alvwf(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%alnsf(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%alnwf(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%vfrac(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%canopy(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%f10m(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%vtype(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%stype(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%facsf(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%facwf(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%uustar(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%ffmm(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%ffhh(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%hice(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%fice(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%tprcp(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%srflag(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%snwdph(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%shdmin(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%shdmax(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%slope(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%snoalb(:dim1,:dim2) - if(ios.ne.0) return - do i=1,head%lsoil - write(lu,iostat=ios) data%stc(:dim1,:dim2,i) - if(ios.ne.0) return - enddo - do i=1,head%lsoil - write(lu,iostat=ios) data%smc(:dim1,:dim2,i) - if(ios.ne.0) return - enddo - do i=1,head%lsoil - write(lu,iostat=ios) data%slc(:dim1,:dim2,i) - if(ios.ne.0) return - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - elseif(head%ivs.eq.200004.and.head%lsoil.eq.2) then - write(lu,iostat=ios) data%tsea(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%smc(:dim1,:dim2,:dim3) - if(ios.ne.0) return - write(lu,iostat=ios) data%sheleg(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%stc(:dim1,:dim2,:dim3) - if(ios.ne.0) return - write(lu,iostat=ios) data%tg3(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%zorl(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%cv(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%cvb(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%cvt(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%alvsf(:dim1,:dim2),& - data%alvwf(:dim1,:dim2),& - data%alnsf(:dim1,:dim2),& - data%alnwf(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%slmsk(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%vfrac(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%canopy(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%f10m(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%vtype(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%stype(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%facsf(:dim1,:dim2),& - data%facwf(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%uustar(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%ffmm(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%ffhh(:dim1,:dim2) - if(ios.ne.0) return - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=0 - end subroutine -!------------------------------------------------------------------------------- - subroutine sfcio_srohdca(lu,cfname,head,data,iret) - implicit none - integer(sfcio_intkind),intent(in):: lu - character*(*),intent(in):: cfname - type(sfcio_head),intent(inout):: head - type(sfcio_data),intent(inout):: data - integer(sfcio_intkind),intent(out):: iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sfcio_sropen(lu,cfname,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sfcio_srhead(lu,head,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sfcio_aldata(head,data,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sfcio_srdata(lu,head,data,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sfcio_sclose(lu,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sfcio_swohdca(lu,cfname,head,data,iret) - implicit none - integer(sfcio_intkind),intent(in):: lu - character*(*),intent(in):: cfname - type(sfcio_head),intent(in):: head - type(sfcio_data),intent(in):: data - integer(sfcio_intkind),intent(out):: iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sfcio_swopen(lu,cfname,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sfcio_swhead(lu,head,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sfcio_swdata(lu,head,data,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sfcio_sclose(lu,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sfcio_aldbta(head,dbta,iret) - implicit none - type(sfcio_head),intent(in):: head - type(sfcio_dbta),intent(inout):: dbta - integer(sfcio_intkind),intent(out):: iret - integer dim1,dim2,dim3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sfcio_axdbta(dbta,iret) - dim1=head%lonb - dim2=head%latb - dim3=head%lsoil - allocate(& - dbta%tsea(dim1,dim2),& - dbta%smc(dim1,dim2,dim3),& - dbta%sheleg(dim1,dim2),& - dbta%stc(dim1,dim2,dim3),& - dbta%tg3(dim1,dim2),& - dbta%zorl(dim1,dim2),& - dbta%cv(dim1,dim2),& - dbta%cvb(dim1,dim2),& - dbta%cvt(dim1,dim2),& - dbta%alvsf(dim1,dim2),& - dbta%alvwf(dim1,dim2),& - dbta%alnsf(dim1,dim2),& - dbta%alnwf(dim1,dim2),& - dbta%slmsk(dim1,dim2),& - dbta%vfrac(dim1,dim2),& - dbta%canopy(dim1,dim2),& - dbta%f10m(dim1,dim2),& - dbta%t2m(dim1,dim2),& - dbta%q2m(dim1,dim2),& - dbta%vtype(dim1,dim2),& - dbta%stype(dim1,dim2),& - dbta%facsf(dim1,dim2),& - dbta%facwf(dim1,dim2),& - dbta%uustar(dim1,dim2),& - dbta%ffmm(dim1,dim2),& - dbta%ffhh(dim1,dim2),& - dbta%hice(dim1,dim2),& - dbta%fice(dim1,dim2),& - dbta%tisfc(dim1,dim2),& - dbta%tprcp(dim1,dim2),& - dbta%srflag(dim1,dim2),& - dbta%snwdph(dim1,dim2),& - dbta%slc(dim1,dim2,dim3),& - dbta%shdmin(dim1,dim2),& - dbta%shdmax(dim1,dim2),& - dbta%slope(dim1,dim2),& - dbta%snoalb(dim1,dim2),& - dbta%orog(dim1,dim2),& - stat=iret) - if(iret.ne.0) iret=-3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sfcio_axdbta(dbta,iret) - implicit none - type(sfcio_dbta),intent(inout):: dbta - integer(sfcio_intkind),intent(out):: iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - deallocate(& - dbta%tsea,& - dbta%smc,& - dbta%sheleg,& - dbta%stc,& - dbta%tg3,& - dbta%zorl,& - dbta%cv,& - dbta%cvb,& - dbta%cvt,& - dbta%alvsf,& - dbta%alvwf,& - dbta%alnsf,& - dbta%alnwf,& - dbta%slmsk,& - dbta%vfrac,& - dbta%canopy,& - dbta%f10m,& - dbta%t2m,& - dbta%q2m,& - dbta%vtype,& - dbta%stype,& - dbta%facsf,& - dbta%facwf,& - dbta%uustar,& - dbta%ffmm,& - dbta%ffhh,& - dbta%hice,& - dbta%fice,& - dbta%tisfc,& - dbta%tprcp,& - dbta%srflag,& - dbta%snwdph,& - dbta%slc,& - dbta%shdmin,& - dbta%shdmax,& - dbta%slope,& - dbta%snoalb,& - dbta%orog,& - stat=iret) - nullify(& - dbta%tsea,& - dbta%smc,& - dbta%sheleg,& - dbta%stc,& - dbta%tg3,& - dbta%zorl,& - dbta%cv,& - dbta%cvb,& - dbta%cvt,& - dbta%alvsf,& - dbta%alvwf,& - dbta%alnsf,& - dbta%alnwf,& - dbta%slmsk,& - dbta%vfrac,& - dbta%canopy,& - dbta%f10m,& - dbta%t2m,& - dbta%q2m,& - dbta%vtype,& - dbta%stype,& - dbta%facsf,& - dbta%facwf,& - dbta%uustar,& - dbta%ffmm,& - dbta%ffhh,& - dbta%hice,& - dbta%fice,& - dbta%tisfc,& - dbta%tprcp,& - dbta%srflag,& - dbta%snwdph,& - dbta%slc,& - dbta%shdmin,& - dbta%shdmax,& - dbta%slope,& - dbta%snoalb,& - dbta%orog) - if(iret.ne.0) iret=-3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sfcio_srdbta(lu,head,dbta,iret) - implicit none - integer(sfcio_intkind),intent(in):: lu - type(sfcio_head),intent(in):: head - type(sfcio_dbta),intent(inout):: dbta - integer(sfcio_intkind),intent(out):: iret - integer:: dim1,dim2,dim3,mdim1,mdim2,mdim3 - integer:: ios - integer i - type(sfcio_data):: data -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - dim1=head%lonb - dim2=head%latb - dim3=head%lsoil - mdim1=min(& - size(dbta%tsea,1),& - size(dbta%smc,1),& - size(dbta%sheleg,1),& - size(dbta%stc,1),& - size(dbta%tg3,1),& - size(dbta%zorl,1),& - size(dbta%alvsf,1),& - size(dbta%alvwf,1),& - size(dbta%alnsf,1),& - size(dbta%alnwf,1),& - size(dbta%slmsk,1),& - size(dbta%vfrac,1),& - size(dbta%canopy,1),& - size(dbta%f10m,1),& - size(dbta%t2m,1),& - size(dbta%q2m,1),& - size(dbta%vtype,1),& - size(dbta%stype,1),& - size(dbta%facsf,1),& - size(dbta%facwf,1),& - size(dbta%uustar,1),& - size(dbta%ffmm,1),& - size(dbta%ffhh,1),& - size(dbta%hice,1),& - size(dbta%fice,1),& - size(dbta%tisfc,1),& - size(dbta%tprcp,1),& - size(dbta%srflag,1),& - size(dbta%snwdph,1),& - size(dbta%slc,1),& - size(dbta%shdmin,1),& - size(dbta%shdmax,1),& - size(dbta%slope,1),& - size(dbta%snoalb,1),& - size(dbta%orog,1)) - mdim2=min(& - size(dbta%tsea,2),& - size(dbta%smc,2),& - size(dbta%sheleg,2),& - size(dbta%stc,2),& - size(dbta%tg3,2),& - size(dbta%zorl,2),& - size(dbta%alvsf,2),& - size(dbta%alvwf,2),& - size(dbta%alnsf,2),& - size(dbta%alnwf,2),& - size(dbta%slmsk,2),& - size(dbta%vfrac,2),& - size(dbta%canopy,2),& - size(dbta%f10m,2),& - size(dbta%t2m,2),& - size(dbta%q2m,2),& - size(dbta%vtype,2),& - size(dbta%stype,2),& - size(dbta%facsf,2),& - size(dbta%facwf,2),& - size(dbta%uustar,2),& - size(dbta%ffmm,2),& - size(dbta%ffhh,2),& - size(dbta%hice,2),& - size(dbta%fice,2),& - size(dbta%tisfc,2),& - size(dbta%tprcp,2),& - size(dbta%srflag,2),& - size(dbta%snwdph,2),& - size(dbta%slc,2),& - size(dbta%shdmin,2),& - size(dbta%shdmax,2),& - size(dbta%slope,2),& - size(dbta%snoalb,2),& - size(dbta%orog,2)) - mdim3=min(& - size(dbta%smc,3),& - size(dbta%stc,3),& - size(dbta%slc,3)) - iret=-5 - if(mdim1.lt.dim1.or.& - mdim2.lt.dim2.or.& - mdim3.lt.dim3) return - iret=-4 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(head%irealf.ne.2) then - call sfcio_aldata(head,data,iret) - if(iret.ne.0) return - call sfcio_srdata(lu,head,data,iret) - if(iret.ne.0) return - dbta%tsea(:dim1,:dim2)=data%tsea(:dim1,:dim2) - dbta%smc(:dim1,:dim2,:dim3)=data%smc(:dim1,:dim2,:dim3) - dbta%sheleg(:dim1,:dim2)=data%sheleg(:dim1,:dim2) - dbta%stc(:dim1,:dim2,:dim3)=data%stc(:dim1,:dim2,:dim3) - dbta%tg3(:dim1,:dim2)=data%tg3(:dim1,:dim2) - dbta%zorl(:dim1,:dim2)=data%zorl(:dim1,:dim2) - dbta%cv(:dim1,:dim2)=data%cv(:dim1,:dim2) - dbta%cvb(:dim1,:dim2)=data%cvb(:dim1,:dim2) - dbta%cvt(:dim1,:dim2)=data%cvt(:dim1,:dim2) - dbta%alvsf(:dim1,:dim2)=data%alvsf(:dim1,:dim2) - dbta%alvwf(:dim1,:dim2)=data%alvwf(:dim1,:dim2) - dbta%alnsf(:dim1,:dim2)=data%alnsf(:dim1,:dim2) - dbta%alnwf(:dim1,:dim2)=data%alnwf(:dim1,:dim2) - dbta%slmsk(:dim1,:dim2)=data%slmsk(:dim1,:dim2) - dbta%vfrac(:dim1,:dim2)=data%vfrac(:dim1,:dim2) - dbta%canopy(:dim1,:dim2)=data%canopy(:dim1,:dim2) - dbta%f10m(:dim1,:dim2)=data%f10m(:dim1,:dim2) - dbta%t2m(:dim1,:dim2)=data%t2m(:dim1,:dim2) - dbta%q2m(:dim1,:dim2)=data%q2m(:dim1,:dim2) - dbta%vtype(:dim1,:dim2)=data%vtype(:dim1,:dim2) - dbta%stype(:dim1,:dim2)=data%stype(:dim1,:dim2) - dbta%facsf(:dim1,:dim2)=data%facsf(:dim1,:dim2) - dbta%facwf(:dim1,:dim2)=data%facwf(:dim1,:dim2) - dbta%uustar(:dim1,:dim2)=data%uustar(:dim1,:dim2) - dbta%ffmm(:dim1,:dim2)=data%ffmm(:dim1,:dim2) - dbta%ffhh(:dim1,:dim2)=data%ffhh(:dim1,:dim2) - dbta%hice(:dim1,:dim2)=data%hice(:dim1,:dim2) - dbta%fice(:dim1,:dim2)=data%fice(:dim1,:dim2) - dbta%tisfc(:dim1,:dim2)=data%tisfc(:dim1,:dim2) - dbta%tprcp(:dim1,:dim2)=data%tprcp(:dim1,:dim2) - dbta%srflag(:dim1,:dim2)=data%srflag(:dim1,:dim2) - dbta%snwdph(:dim1,:dim2)=data%snwdph(:dim1,:dim2) - dbta%slc(:dim1,:dim2,:dim3)=data%slc(:dim1,:dim2,:dim3) - dbta%shdmin(:dim1,:dim2)=data%shdmin(:dim1,:dim2) - dbta%shdmax(:dim1,:dim2)=data%shdmax(:dim1,:dim2) - dbta%slope(:dim1,:dim2)=data%slope(:dim1,:dim2) - dbta%snoalb(:dim1,:dim2)=data%snoalb(:dim1,:dim2) - dbta%orog(:dim1,:dim2)=data%orog(:dim1,:dim2) - call sfcio_axdata(data,iret) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - elseif(head%ivs == 200509) then - read(lu,iostat=ios) dbta%slmsk(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%orog(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%tsea(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%sheleg(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%tg3(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%zorl(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%alvsf(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%alvwf(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%alnsf(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%alnwf(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%vfrac(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%canopy(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%f10m(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%t2m(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%q2m(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%vtype(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%stype(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%facsf(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%facwf(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%uustar(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%ffmm(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%ffhh(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%hice(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%fice(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%tisfc(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%tprcp(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%srflag(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%snwdph(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%shdmin(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%shdmax(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%slope(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%snoalb(:dim1,:dim2) - if(ios.ne.0) return - do i=1,head%lsoil - read(lu,iostat=ios) dbta%stc(:dim1,:dim2,i) - if(ios.ne.0) return - enddo - do i=1,head%lsoil - read(lu,iostat=ios) dbta%smc(:dim1,:dim2,i) - if(ios.ne.0) return - enddo - do i=1,head%lsoil - read(lu,iostat=ios) dbta%slc(:dim1,:dim2,i) - if(ios.ne.0) return - enddo - dbta%cv(:dim1,:dim2)=sfcio_realfill - dbta%cvb(:dim1,:dim2)=sfcio_realfill - dbta%cvt(:dim1,:dim2)=sfcio_realfill - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=0 - end subroutine -!------------------------------------------------------------------------------- - subroutine sfcio_swdbta(lu,head,dbta,iret) - implicit none - integer(sfcio_intkind),intent(in):: lu - type(sfcio_head),intent(in):: head - type(sfcio_dbta),intent(in):: dbta - integer(sfcio_intkind),intent(out):: iret - integer:: dim1,dim2,dim3,mdim1,mdim2,mdim3 - integer:: ios - integer i - type(sfcio_data):: data -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - dim1=head%lonb - dim2=head%latb - dim3=head%lsoil - mdim1=min(& - size(dbta%tsea,1),& - size(dbta%smc,1),& - size(dbta%sheleg,1),& - size(dbta%stc,1),& - size(dbta%tg3,1),& - size(dbta%zorl,1),& - size(dbta%alvsf,1),& - size(dbta%alvwf,1),& - size(dbta%alnsf,1),& - size(dbta%alnwf,1),& - size(dbta%slmsk,1),& - size(dbta%vfrac,1),& - size(dbta%canopy,1),& - size(dbta%f10m,1),& - size(dbta%t2m,1),& - size(dbta%q2m,1),& - size(dbta%vtype,1),& - size(dbta%stype,1),& - size(dbta%facsf,1),& - size(dbta%facwf,1),& - size(dbta%uustar,1),& - size(dbta%ffmm,1),& - size(dbta%ffhh,1),& - size(dbta%hice,1),& - size(dbta%fice,1),& - size(dbta%tisfc,1),& - size(dbta%tprcp,1),& - size(dbta%srflag,1),& - size(dbta%snwdph,1),& - size(dbta%slc,1),& - size(dbta%shdmin,1),& - size(dbta%shdmax,1),& - size(dbta%slope,1),& - size(dbta%snoalb,1),& - size(dbta%orog,1)) - mdim2=min(& - size(dbta%tsea,2),& - size(dbta%smc,2),& - size(dbta%sheleg,2),& - size(dbta%stc,2),& - size(dbta%tg3,2),& - size(dbta%zorl,2),& - size(dbta%alvsf,2),& - size(dbta%alvwf,2),& - size(dbta%alnsf,2),& - size(dbta%alnwf,2),& - size(dbta%slmsk,2),& - size(dbta%vfrac,2),& - size(dbta%canopy,2),& - size(dbta%f10m,2),& - size(dbta%t2m,2),& - size(dbta%q2m,2),& - size(dbta%vtype,2),& - size(dbta%stype,2),& - size(dbta%facsf,2),& - size(dbta%facwf,2),& - size(dbta%uustar,2),& - size(dbta%ffmm,2),& - size(dbta%ffhh,2),& - size(dbta%hice,2),& - size(dbta%fice,2),& - size(dbta%tisfc,2),& - size(dbta%tprcp,2),& - size(dbta%srflag,2),& - size(dbta%snwdph,2),& - size(dbta%slc,2),& - size(dbta%shdmin,2),& - size(dbta%shdmax,2),& - size(dbta%slope,2),& - size(dbta%snoalb,2),& - size(dbta%orog,2)) - mdim3=min(& - size(dbta%smc,3),& - size(dbta%stc,3),& - size(dbta%slc,3)) - iret=-5 - if(mdim1.lt.dim1.or.& - mdim2.lt.dim2.or.& - mdim3.lt.dim3) return - iret=-4 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(head%irealf.ne.2) then - call sfcio_aldata(head,data,iret) - if(iret.ne.0) return - data%tsea(:dim1,:dim2)=dbta%tsea(:dim1,:dim2) - data%smc(:dim1,:dim2,:dim3)=dbta%smc(:dim1,:dim2,:dim3) - data%sheleg(:dim1,:dim2)=dbta%sheleg(:dim1,:dim2) - data%stc(:dim1,:dim2,:dim3)=dbta%stc(:dim1,:dim2,:dim3) - data%tg3(:dim1,:dim2)=dbta%tg3(:dim1,:dim2) - data%zorl(:dim1,:dim2)=dbta%zorl(:dim1,:dim2) - data%cv(:dim1,:dim2)=dbta%cv(:dim1,:dim2) - data%cvb(:dim1,:dim2)=dbta%cvb(:dim1,:dim2) - data%cvt(:dim1,:dim2)=dbta%cvt(:dim1,:dim2) - data%alvsf(:dim1,:dim2)=dbta%alvsf(:dim1,:dim2) - data%alvwf(:dim1,:dim2)=dbta%alvwf(:dim1,:dim2) - data%alnsf(:dim1,:dim2)=dbta%alnsf(:dim1,:dim2) - data%alnwf(:dim1,:dim2)=dbta%alnwf(:dim1,:dim2) - data%slmsk(:dim1,:dim2)=dbta%slmsk(:dim1,:dim2) - data%vfrac(:dim1,:dim2)=dbta%vfrac(:dim1,:dim2) - data%canopy(:dim1,:dim2)=dbta%canopy(:dim1,:dim2) - data%f10m(:dim1,:dim2)=dbta%f10m(:dim1,:dim2) - data%t2m(:dim1,:dim2)=dbta%t2m(:dim1,:dim2) - data%q2m(:dim1,:dim2)=dbta%q2m(:dim1,:dim2) - data%vtype(:dim1,:dim2)=dbta%vtype(:dim1,:dim2) - data%stype(:dim1,:dim2)=dbta%stype(:dim1,:dim2) - data%facsf(:dim1,:dim2)=dbta%facsf(:dim1,:dim2) - data%facwf(:dim1,:dim2)=dbta%facwf(:dim1,:dim2) - data%uustar(:dim1,:dim2)=dbta%uustar(:dim1,:dim2) - data%ffmm(:dim1,:dim2)=dbta%ffmm(:dim1,:dim2) - data%ffhh(:dim1,:dim2)=dbta%ffhh(:dim1,:dim2) - data%hice(:dim1,:dim2)=dbta%hice(:dim1,:dim2) - data%fice(:dim1,:dim2)=dbta%fice(:dim1,:dim2) - data%tisfc(:dim1,:dim2)=dbta%tisfc(:dim1,:dim2) - data%tprcp(:dim1,:dim2)=dbta%tprcp(:dim1,:dim2) - data%srflag(:dim1,:dim2)=dbta%srflag(:dim1,:dim2) - data%snwdph(:dim1,:dim2)=dbta%snwdph(:dim1,:dim2) - data%slc(:dim1,:dim2,:dim3)=dbta%slc(:dim1,:dim2,:dim3) - data%shdmin(:dim1,:dim2)=dbta%shdmin(:dim1,:dim2) - data%shdmax(:dim1,:dim2)=dbta%shdmax(:dim1,:dim2) - data%slope(:dim1,:dim2)=dbta%slope(:dim1,:dim2) - data%snoalb(:dim1,:dim2)=dbta%snoalb(:dim1,:dim2) - data%orog(:dim1,:dim2)=dbta%orog(:dim1,:dim2) - call sfcio_swdata(lu,head,data,iret) - if(iret.ne.0) return - call sfcio_axdata(data,iret) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - elseif(head%ivs == 200509) then - write(lu,iostat=ios) dbta%slmsk(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%orog(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%tsea(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%sheleg(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%tg3(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%zorl(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%alvsf(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%alvwf(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%alnsf(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%alnwf(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%vfrac(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%canopy(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%f10m(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%t2m(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%q2m(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%vtype(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%stype(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%facsf(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%facwf(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%uustar(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%ffmm(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%ffhh(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%hice(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%fice(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%tisfc(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%tprcp(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%srflag(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%snwdph(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%shdmin(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%shdmax(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%slope(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%snoalb(:dim1,:dim2) - if(ios.ne.0) return - do i=1,head%lsoil - write(lu,iostat=ios) dbta%stc(:dim1,:dim2,i) - if(ios.ne.0) return - enddo - do i=1,head%lsoil - write(lu,iostat=ios) dbta%smc(:dim1,:dim2,i) - if(ios.ne.0) return - enddo - do i=1,head%lsoil - write(lu,iostat=ios) dbta%slc(:dim1,:dim2,i) - if(ios.ne.0) return - enddo - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=0 - end subroutine -!------------------------------------------------------------------------------- - subroutine sfcio_srohdcb(lu,cfname,head,dbta,iret) - implicit none - integer(sfcio_intkind),intent(in):: lu - character*(*),intent(in):: cfname - type(sfcio_head),intent(inout):: head - type(sfcio_dbta),intent(inout):: dbta - integer(sfcio_intkind),intent(out):: iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sfcio_sropen(lu,cfname,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sfcio_srhead(lu,head,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sfcio_aldbta(head,dbta,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sfcio_srdbta(lu,head,dbta,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sfcio_sclose(lu,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sfcio_swohdcb(lu,cfname,head,dbta,iret) - implicit none - integer(sfcio_intkind),intent(in):: lu - character*(*),intent(in):: cfname - type(sfcio_head),intent(in):: head - type(sfcio_dbta),intent(in):: dbta - integer(sfcio_intkind),intent(out):: iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sfcio_swopen(lu,cfname,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sfcio_swhead(lu,head,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sfcio_swdbta(lu,head,dbta,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sfcio_sclose(lu,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- -end module diff --git a/src/fim/FIMsrc/prep/sigio/Makefile b/src/fim/FIMsrc/prep/sigio/Makefile deleted file mode 100644 index 986d298..0000000 --- a/src/fim/FIMsrc/prep/sigio/Makefile +++ /dev/null @@ -1,39 +0,0 @@ -# sigio Makefile - -SHELL = /bin/sh - -include ../../macros.make - -FC = $(FC) -FLAGB = $(BYTE_SWAP_FLAG) $(FFLAGS_NO_DEBUG) -#FFLAGS are not imported from the calling Makefile because in sigio_module.f the allocate statement -#fails for "-g -traceback -C" and "-g -traceback -C" does not work with "-mcmodel=medium -i-dynamic" -FLAGS = $(FFLAGS_NO_DEBUG) -LIBSIGIO = $(LIBDIR)/libsigio_4.a -OBJS = $(addsuffix .o, $(basename $(SRCS))) -SRCS = $(shell ls *.f *.F90) - -.SUFFIXES: -.SUFFIXES: .a .o .f .F90 - -.F90.o: - $(FC) -c $(FLAGB) $(FREEFLAG) $(FFLAGS) $(RCWFLAG) $< - -.f.o: - $(FC) -c $(FLAGS) $(FIXEDFLAG) $(FFLAGS) $(RCWFLAG) $< - -all: $(LIBSIGIO) - -$(LIBSIGIO): DEPENDENCIES $(OBJS) - $(AR) ruv $(LIBSIGIO) $(OBJS) - -DEPENDENCIES: - $(RM) -f Filepath Srcfiles - echo "." > Filepath - ls -1 *.F90 *.f > Srcfiles - $(MKDEPENDS) -m Filepath Srcfiles > $@ - --include DEPENDENCIES - -clean: - $(RM) -f *.o sigio*.mod $(LIBSIGIO) DEPENDENCIES diff --git a/src/fim/FIMsrc/prep/sigio/bafrio.f b/src/fim/FIMsrc/prep/sigio/bafrio.f deleted file mode 100644 index 23eabd0..0000000 --- a/src/fim/FIMsrc/prep/sigio/bafrio.f +++ /dev/null @@ -1,187 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE BAFRINDEX(LU,IB,LX,IX) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BAFRINDEX BYTE-ADDRESSABLE FORTRAN RECORD INDEX -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1999-01-21 -C -C ABSTRACT: THIS SUBPROGRAM EITHER READS AN UNFORMATTED FORTRAN RECORD -C AND RETURN ITS LENGTH AND START BYTE OF THE NEXT FORTRAN RECORD; -C OR GIVEN THE RECORD LENGTH, WITHOUT I/O IT DETERMINES THE START BYTE -C OF THE NEXT FORTRAN RECORD. -C -C PROGRAM HISTORY LOG: -C 1999-01-21 IREDELL -C -C USAGE: CALL BAFRINDEX(LU,IB,LX,IX) -C INPUT ARGUMENTS: -C LU INTEGER LOGICAL UNIT TO READ -C IF LU<=0, THEN DETERMINE IX FROM LX -C IB INTEGER FORTRAN RECORD START BYTE -C (FOR THE FIRST FORTRAN RECORD, IB SHOULD BE 0) -C LX INTEGER RECORD LENGTH IN BYTES IF LU<=0 -C -C OUTPUT ARGUMENTS: -C LX INTEGER RECORD LENGTH IN BYTES IF LU>0, -C OR LX=-1 FOR I/O ERROR (PROBABLE END OF FILE), -C OR LX=-2 FOR I/O ERROR (INVALID FORTRAN RECORD) -C IX INTEGER START BYTE FOR THE NEXT FORTRAN RECORD -C (COMPUTED ONLY IF LX>=0) -C -C SUBPROGRAMS CALLED: -C BAREAD BYTE-ADDRESSABLE READ -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - IMPLICIT NONE - INTEGER,INTENT(IN):: LU,IB - INTEGER,INTENT(INOUT):: LX - INTEGER,INTENT(OUT):: IX - INTEGER,PARAMETER:: LBCW=4 - INTEGER(LBCW):: BCW1,BCW2 - INTEGER:: KR -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COMPARE FIRST BLOCK CONTROL WORD AND TRAILING BLOCK CONTROL WORD - IF(LU.GT.0) THEN - CALL BAREAD(LU,IB,LBCW,KR,BCW1) - IF(KR.NE.LBCW) THEN - LX=-1 - ELSE - CALL BAREAD(LU,IB+LBCW+BCW1,LBCW,KR,BCW2) - IF(KR.NE.LBCW.OR.BCW1.NE.BCW2) THEN - LX=-2 - ELSE - LX=BCW1 - ENDIF - ENDIF - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COMPUTE START BYTE FOR THE NEXT FORTRAN RECORD - IF(LX.GE.0) IX=IB+LBCW+LX+LBCW -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END -C----------------------------------------------------------------------- - SUBROUTINE BAFRREAD(LU,IB,NB,KA,A) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BAFRREAD BYTE-ADDRESSABLE FORTRAN RECORD READ -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1999-01-21 -C -C ABSTRACT: THIS SUBPROGRAM READS AN UNFORMATTED FORTRAN RECORD -C -C PROGRAM HISTORY LOG: -C 1999-01-21 IREDELL -C -C USAGE: CALL BAFRREAD(LU,IB,NB,KA,A) -C INPUT ARGUMENTS: -C LU INTEGER LOGICAL UNIT TO READ -C IB INTEGER FORTRAN RECORD START BYTE -C (FOR THE FIRST FORTRAN RECORD, IB SHOULD BE 0) -C NB INTEGER NUMBER OF BYTES TO READ -C -C OUTPUT ARGUMENTS: -C KA INTEGER NUMBER OF BYTES IN FORTRAN RECORD -C (IN WHICH CASE THE NEXT FORTRAN RECORD -C SHOULD HAVE A START BYTE OF IB+KA), -C OR KA=-1 FOR I/O ERROR (PROBABLE END OF FILE), -C OR KA=-2 FOR I/O ERROR (INVALID FORTRAN RECORD), -C OR KA=-3 FOR I/O ERROR (REQUEST LONGER THAN RECORD) -C A CHARACTER*1 (NB) DATA READ -C -C SUBPROGRAMS CALLED: -C BAFRINDEX BYTE-ADDRESSABLE FORTRAN RECORD INDEX -C BAREAD BYTE-ADDRESSABLE READ -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - IMPLICIT NONE - INTEGER,INTENT(IN):: LU,IB,NB - INTEGER,INTENT(OUT):: KA - CHARACTER,INTENT(OUT):: A(NB) - INTEGER,PARAMETER:: LBCW=4 - INTEGER:: LX,IX - INTEGER:: KR -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C VALIDATE FORTRAN RECORD - CALL BAFRINDEX(LU,IB,LX,IX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ IF VALID - IF(LX.LT.0) THEN - KA=LX - ELSEIF(LX.LT.NB) THEN - KA=-3 - ELSE - CALL BAREAD(LU,IB+LBCW,NB,KR,A) - IF(KR.NE.NB) THEN - KA=-1 - ELSE - KA=LBCW+LX+LBCW - ENDIF - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END -C----------------------------------------------------------------------- - SUBROUTINE BAFRWRITE(LU,IB,NB,KA,A) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BAFRWRITE BYTE-ADDRESSABLE FORTRAN RECORD WRITE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1999-01-21 -C -C ABSTRACT: THIS SUBPROGRAM WRITES AN UNFORMATTED FORTRAN RECORD -C -C PROGRAM HISTORY LOG: -C 1999-01-21 IREDELL -C -C USAGE: CALL BAFRWRITE(LU,IB,NB,KA,A) -C INPUT ARGUMENTS: -C LU INTEGER LOGICAL UNIT TO WRITE -C IB INTEGER FORTRAN RECORD START BYTE -C (FOR THE FIRST FORTRAN RECORD, IB SHOULD BE 0) -C NB INTEGER NUMBER OF BYTES TO WRITE -C A CHARACTER*1 (NB) DATA TO WRITE -C -C OUTPUT ARGUMENTS: -C KA INTEGER NUMBER OF BYTES IN FORTRAN RECORD -C (IN WHICH CASE THE NEXT FORTRAN RECORD -C SHOULD HAVE A START BYTE OF IB+KA), -C OR KA=-1 FOR I/O ERROR -C -C SUBPROGRAMS CALLED: -C BAWRITE BYTE-ADDRESSABLE WRITE -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - IMPLICIT NONE - INTEGER,INTENT(IN):: LU,IB,NB - INTEGER,INTENT(OUT):: KA - CHARACTER,INTENT(IN):: A(NB) - INTEGER,PARAMETER:: LBCW=4 - INTEGER(LBCW):: BCW - INTEGER:: KR -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C WRITE DATA BRACKETED BY BLOCK CONTROL WORDS - BCW=NB - CALL BAWRITE(LU,IB,LBCW,KR,BCW) - IF(KR.NE.LBCW) THEN - KA=-1 - ELSE - CALL BAWRITE(LU,IB+LBCW,NB,KR,A) - IF(KR.NE.NB) THEN - KA=-1 - ELSE - CALL BAWRITE(LU,IB+LBCW+BCW,LBCW,KR,BCW) - IF(KR.NE.LBCW) THEN - KA=-1 - ELSE - KA=LBCW+BCW+LBCW - ENDIF - ENDIF - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sigio/sigio_module.F90 b/src/fim/FIMsrc/prep/sigio/sigio_module.F90 deleted file mode 100644 index 478c627..0000000 --- a/src/fim/FIMsrc/prep/sigio/sigio_module.F90 +++ /dev/null @@ -1,1309 +0,0 @@ -!------------------------------------------------------------------------------- -module sigio_module -!$$$ Module Documentation Block -! -! Module: sigio_module API for global spectral sigma file I/O -! Prgmmr: iredell Org: w/nx23 date: 1999-01-18 -! -! Abstract: This module provides an Application Program Interface -! for performing I/O on the sigma restart file of the global spectral model. -! Functions include opening, reading, writing, and closing as well as -! allocating and deallocating data buffers used in the transfers. -! The I/O performed here is sequential. -! The transfers are limited to header records or data records. -! -! Program History Log: -! 1999-01-18 Mark Iredell -! -! Public Variables: -! sigio_lhead1 Integer parameter length of first header record (=32) -! sigio_charkind Integer parameter kind or length of passed characters (=8) -! sigio_intkind Integer parameter kind or length of passed integers (=4) -! sigio_realkind Integer parameter kind or length of passed reals (=4) -! sigio_dblekind Integer parameter kind or length of passed longreals (=8) -! sigio_realfill Real(sigio_realkind) parameter fill value (=-9999.) -! sigio_dblefill Real(sigio_dblekind) parameter fill value (=-9999.) -! -! Public Defined Types: -! sigio_head Sigma file header information -! clabsig Character(sigio_lhead1) ON85 label -! (obsolescent) -! fhour Real(sigio_realkind) forecast hour -! idate Integer(sigio_intkind)(4) initial date -! (hour, month, day, 4-digit year) -! si Real(sigio_realkind)(101) sigma interfaces -! (obsolescent) -! sl Real(sigio_realkind)(100) sigma levels -! (obsolescent) -! ak Real(sigio_realkind)(101) hybrid interface a -! (obsolescent) -! bk Real(sigio_realkind)(101) hybrid interface b -! (obsolescent) -! jcap Integer(sigio_intkind) spectral truncation -! levs Integer(sigio_intkind) number of levels -! itrun Integer(sigio_intkind) truncation flag -! (=1 for triangular) -! iorder Integer(sigio_intkind) coefficient order flag -! (=2 for ibm order) -! irealf Integer(sigio_intkind) floating point flag -! (=1 for 4-byte ieee, =2 for 8-byte ieee) -! igen Integer(sigio_intkind) model generating flag -! latf Integer(sigio_intkind) latitudes in dynamics -! (=(jcap+1)*3/2) -! lonf Integer(sigio_intkind) longitudes in dynamics -! (>=(jcap+1)*3 appropriate for fft) -! latb Integer(sigio_intkind) latitudes in physics -! lonb Integer(sigio_intkind) longitudes in physics -! latr Integer(sigio_intkind) latitudes in radiation -! lonr Integer(sigio_intkind) longitudes in radiation -! ntrac Integer(sigio_intkind) number of tracers -! icen2 Integer(sigio_intkind) subcenter id -! iens Integer(sigio_intkind)(2) ensemble ids -! idpp Integer(sigio_intkind) processing id -! idsl Integer(sigio_intkind) semi-lagrangian id -! idvc Integer(sigio_intkind) vertical coordinate id -! (=1 for sigma, =2 for ec-hybrid, =3 for ncep hybrid) -! idvm Integer(sigio_intkind) mass variable id -! idvt Integer(sigio_intkind) tracer variable id -! idrun Integer(sigio_intkind) run id -! idusr Integer(sigio_intkind) user-defined id -! pdryini Real(sigio_realkind) global mean dry air pressure (kPa) -! (obsolescent) -! ncldt Integer(sigio_intkind) number of cloud types -! ixgr Integer(sigio_intkind) extra grid field id -! (=0 for none, =1 for zhao1, =2 for zhao2, -! =3 for ferrier) -! ivs Integer(sigio_intkind) version number -! nvcoord Integer(sigio_intkind) number of vcoord profiles -! The following variables should be allocated with sigio_alhead: -! vcoord Real(sigio_realkind)((levs+1),nvcoord) vcoord profiles -! cfvars Character(8)(5+ntrac) field variable names -! The following variables should not be modified by the user: -! nxgr Integer(sigio_intkind) number of extra grid fields -! nxss Integer(sigio_intkind) number of extra scalars -! nhead Integer(sigio_intkind) number of header records -! ndata Integer(sigio_intkind) number of data records -! lhead Integer(sigio_intkind)(nhead) header record lengths -! ldata Integer(sigio_intkind)(ndata) data record lengths -! -! sigio_data Sigma file data fields -! hs Real(sigio_realkind)(:) pointer to spectral -! coefficients of surface height in m -! ps Real(sigio_realkind)(:) pointer to spectral -! coefficients of log of surface pressure over 1 kPa -! t Real(sigio_realkind)(:,:) pointer to spectral -! coefficients of virtual temperature by level in K -! d Real(sigio_realkind)(:,:) pointer to spectral -! coefficients of divergence by level in 1/second -! z Real(sigio_realkind)(:,:) pointer to spectral -! coefficients of vorticity by level in 1/second -! q Real(sigio_realkind)(:,:,:) pointer to spectral -! coefficients of tracers by level and tracer number -! in specific densities -! xgr Real(sigio_realkind)(:,:,:) pointer to extra grid fields -! by longitude, latitude and number of extra grid fields -! xss Real(sigio_realkind)(:) pointer to scalar array -! -! sigio_dbta Sigma file longreal data fields -! hs Real(sigio_dblekind)(:) pointer to spectral -! coefficients of surface height in m -! ps Real(sigio_dblekind)(:) pointer to spectral -! coefficients of log of surface pressure over 1 kPa -! t Real(sigio_dblekind)(:,:) pointer to spectral -! coefficients of virtual temperature by level in K -! d Real(sigio_dblekind)(:,:) pointer to spectral -! coefficients of divergence by level in 1/second -! z Real(sigio_dblekind)(:,:) pointer to spectral -! coefficients of vorticity by level in 1/second -! q Real(sigio_dblekind)(:,:,:) pointer to spectral -! coefficients of tracers by level and tracer number -! in specific densities -! xgr Real(sigio_dblekind)(:,:,:) pointer to extra grid fields -! by longitude, latitude and number of extra grid fields -! xss Real(sigio_dblekind)(:) pointer to scalar array -! -! Public Subprograms: -! sigio_sropen Open sigma file for sequential reading -! lu Integer(sigio_intkind) input logical unit -! cfname Character(*) input filename -! iret Integer(sigio_intkind) output return code -! -! sigio_swopen Open sigma file for sequential writing -! lu Integer(sigio_intkind) input logical unit -! cfname Character(*) input filename -! iret Integer(sigio_intkind) output return code -! -! sigio_sclose Close sigma file for sequential I/O -! lu Integer(sigio_intkind) input logical unit -! iret Integer(sigio_intkind) output return code -! -! sigio_srhead Read header information with sequential I/O -! lu Integer(sigio_intkind) input logical unit -! head Type(sigio_head) output header information -! iret Integer(sigio_intkind) output return code -! -! sigio_swhead Write header information with sequential I/O -! lu Integer(sigio_intkind) input logical unit -! head Type(sigio_head) input header information -! iret Integer(sigio_intkind) output return code -! -! sigio_alhead Allocate head allocatables -! head Type(sigio_head) input/output header information -! iret Integer(sigio_intkind) output return code -! levs Integer(sigio_intkind) optional number of levels -! nvcoord Integer(sigio_intkind) optional number of vcoords -! ntrac Integer(sigio_intkind) optional number of tracers -! -! sigio_aldata Allocate data fields -! head Type(sigio_head) input header information -! data Type(sigio_data) output data fields -! iret Integer(sigio_intkind) output return code -! -! sigio_axdata Deallocate data fields -! data Type(sigio_data) output data fields -! iret Integer(sigio_intkind) output return code -! -! sigio_srdata Read data fields with sequential I/O -! lu Integer(sigio_intkind) input logical unit -! head Type(sigio_head) input header information -! data Type(sigio_data) output data fields -! iret Integer(sigio_intkind) output return code -! -! sigio_swdata Write data fields with sequential I/O -! lu Integer(sigio_intkind) input logical unit -! head Type(sigio_head) input header information -! data Type(sigio_data) input data fields -! iret Integer(sigio_intkind) output return code -! -! sigio_aldbta Allocate longreal data fields -! head Type(sigio_head) input header information -! dbta Type(sigio_dbta) output longreal data fields -! iret Integer(sigio_intkind) output return code -! -! sigio_axdbta Deallocate longreal data fields -! dbta Type(sigio_dbta) output longreal data fields -! iret Integer(sigio_intkind) output return code -! -! sigio_srdbta Read longreal data fields with sequential I/O -! lu Integer(sigio_intkind) input logical unit -! head Type(sigio_head) input header information -! dbta Type(sigio_dbta) output longreal data fields -! iret Integer(sigio_intkind) output return code -! -! sigio_swdbta Write longreal data fields with sequential I/O -! lu Integer(sigio_intkind) input logical unit -! head Type(sigio_head) input header information -! dbta Type(sigio_dbta) input longreal data fields -! iret Integer(sigio_intkind) output return code -! -! sigio_srohdc Open, read header & data and close with sequential I/O -! lu Integer(sigio_intkind) input logical unit -! cfname Character(*) input filename -! head Type(sigio_head) output header information -! data Type(sigio_data) or type(sigio_dbta) output data fields -! iret Integer(sigio_intkind) output return code -! -! sigio_swohdc Open, write header & data and close with sequential I/O -! lu Integer(sigio_intkind) input logical unit -! cfname Character(*) input filename -! head Type(sigio_head) input header information -! data Type(sigio_data) or type(sigio_dbta) output data fields -! iret Integer(sigio_intkind) output return code -! -! sigio_modpr Compute model pressures -! im Integer(sigio_intkind) input number of points -! ix Integer(sigio_intkind) input first dimension -! km Integer(sigio_intkind) input number of levels -! nvcoord Integer(sigio_intkind) input number of vertical coords -! idvc Integer(sigio_intkind) input vertical coordinate id -! (1 for sigma and 2 for hybrid) -! idsl Integer(sigio_intkind) input type of sigma structure -! (1 for phillips or 2 for mean) -! vcoord Real(sigio_realkind)(km+1,nvcoord) input vertical coords -! for idvc=1, nvcoord=1: sigma interface -! for idvc=2, nvcoord=2: hybrid interface a and b -! iret Integer(sigio_intkind) output return code -! ps Real(sigio_realkind)(ix) input optional surface pressure (Pa) -! tv Real(sigio_realkind)(ix,km) input optional virtual temperature (K) -! pd Real(sigio_realkind)(ix,km) output optional delta pressure (Pa) -! pm Real(sigio_realkind)(ix,km) output optional layer pressure (Pa) -! -! sigio_adhead Set private data in header -! head Type(sigio_head) input/output header information -! -! Remarks: -! (1) The sigma file format follows: -! For ivs=198410: -! ON85 label (32 bytes) -! Header information record containing -! real forecast hour, initial date, sigma interfaces, sigma levels, -! padding to allow for 100 levels, and finally 44 identifier words -! containing JCAP, LEVS, NTRAC, IREALF, etc. (250 4-byte words) -! (word size in the remaining records depends on the value of IREALF) -! Orography (NC words, where NC=(JCAP+1)*(JCAP+2)) -! Log surface pressure (NC words) -! Temperature (LEVS records of NC words) -! Divergence & Vorticity interleaved (2*LEVS records of NC words) -! Tracers (LEVS*NTRAC records of NC words) -! Extra grid fields (NXGR records of LONB*LATB words) -! For ivs=200509: -! Label containing -! 'GFS ','SIG ',ivs,nhead,ndata,reserved(3) (8 4-byte words) -! Header records -! lhead(nhead),ldata(ndata) (nhead+ndata 4-byte words) -! fhour, idate(4), jcap, levs, itrun, iorder, irealf, igen, -! latf, lonf, latb, lonb, latr, lonr, ntrac, nvcoord, -! icen2, iens(2), idpp, idsl, idvc, idvm, idvt, idrun, idusr, -! pdryini, ncldt, ixgr, reserved(18) (50 4-byte words) -! vcoord((levs+1)*nvcoord 4-byte words) -! cfvars(5+ntrac 8-byte character words) -! Data records (word size depends on irealf) -! orography (nc words, where nc=(jcap+1)*(jcap+2)) -! log surface pressure (nc words) -! temperature (levs records of nc words) -! divergence (levs records of nc words) -! vorticity (levs records of nc words) -! tracers (levs*ntrac records of nc words) -! scalars (nxss words) -! extra grid fields (nxgr records of lonb*latb words) -! extra scalars (nxss words) -! -! (2) Possible return codes: -! 0 Successful call -! -1 Open or close I/O error -! -2 Header record I/O error (possible EOF) -! -3 Allocation or deallocation error -! -4 Data record I/O error -! -5 Insufficient data dimensions allocated -! -! Examples: -! (1) Read the entire sigma file 'sigf24' and -! print out the global mean temperature profile. -! -! use sigio_module -! type(sigio_head):: head -! type(sigio_data):: data -! call sigio_srohdc(11,'sigf24',head,data,iret) -! print '(f8.2)',data%t(1,head%levs:1:-1)/sqrt(2.) -! end -! -! Attributes: -! Language: Fortran 90 -! -!$$$ - implicit none - private -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Public Variables - integer,parameter,public:: sigio_lhead1=32 - integer,parameter,public:: sigio_intkind=4,sigio_realkind=4,sigio_dblekind=8 - integer,parameter,public:: sigio_charkind=8 - real(sigio_intkind),parameter,public:: sigio_intfill=-9999_sigio_intkind - real(sigio_realkind),parameter,public:: sigio_realfill=-9999._sigio_realkind - real(sigio_dblekind),parameter,public:: sigio_dblefill=-9999._sigio_dblekind -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Public Types - type,public:: sigio_head - character(sigio_lhead1):: clabsig=' ' - real(sigio_realkind):: fhour=sigio_realfill - integer(sigio_intkind):: idate(4)=sigio_intfill - real(sigio_realkind):: si(101)=sigio_realfill - real(sigio_realkind):: sl(100)=sigio_realfill - real(sigio_realkind):: ak(101)=sigio_realfill - real(sigio_realkind):: bk(101)=sigio_realfill - integer(sigio_intkind):: jcap=sigio_intfill - integer(sigio_intkind):: levs=sigio_intfill - integer(sigio_intkind):: itrun=sigio_intfill - integer(sigio_intkind):: iorder=sigio_intfill - integer(sigio_intkind):: irealf=sigio_intfill - integer(sigio_intkind):: igen=sigio_intfill - integer(sigio_intkind):: latf=sigio_intfill - integer(sigio_intkind):: lonf=sigio_intfill - integer(sigio_intkind):: latb=sigio_intfill - integer(sigio_intkind):: lonb=sigio_intfill - integer(sigio_intkind):: latr=sigio_intfill - integer(sigio_intkind):: lonr=sigio_intfill - integer(sigio_intkind):: ntrac=sigio_intfill - integer(sigio_intkind):: icen2=sigio_intfill - integer(sigio_intkind):: iens(2)=sigio_intfill - integer(sigio_intkind):: idpp=sigio_intfill - integer(sigio_intkind):: idsl=sigio_intfill - integer(sigio_intkind):: idvc=sigio_intfill - integer(sigio_intkind):: idvm=sigio_intfill - integer(sigio_intkind):: idvt=sigio_intfill - integer(sigio_intkind):: idrun=sigio_intfill - integer(sigio_intkind):: idusr=sigio_intfill - real(sigio_realkind):: pdryini=sigio_realfill - integer(sigio_intkind):: ncldt=sigio_intfill - integer(sigio_intkind):: ixgr=sigio_intfill - integer(sigio_intkind):: ivs=sigio_intfill - integer(sigio_intkind):: nvcoord=sigio_intfill - real(sigio_realkind),allocatable:: vcoord(:,:) - character(sigio_charkind),allocatable:: cfvars(:) - integer(sigio_intkind):: nxgr=sigio_intfill - integer(sigio_intkind):: nxss=sigio_intfill - integer(sigio_intkind):: nhead=sigio_intfill - integer(sigio_intkind):: ndata=sigio_intfill - integer(sigio_intkind),allocatable:: lhead(:) - integer(sigio_intkind),allocatable:: ldata(:) - end type - type,public:: sigio_data - real(sigio_realkind),pointer:: hs(:)=>null() - real(sigio_realkind),pointer:: ps(:)=>null() - real(sigio_realkind),pointer:: t(:,:)=>null() - real(sigio_realkind),pointer:: d(:,:)=>null() - real(sigio_realkind),pointer:: z(:,:)=>null() - real(sigio_realkind),pointer:: q(:,:,:)=>null() - real(sigio_realkind),pointer:: xgr(:,:,:)=>null() - real(sigio_realkind),pointer:: xss(:)=>null() - end type - type,public:: sigio_dbta - real(sigio_dblekind),pointer:: hs(:)=>null() - real(sigio_dblekind),pointer:: ps(:)=>null() - real(sigio_dblekind),pointer:: t(:,:)=>null() - real(sigio_dblekind),pointer:: d(:,:)=>null() - real(sigio_dblekind),pointer:: z(:,:)=>null() - real(sigio_dblekind),pointer:: q(:,:,:)=>null() - real(sigio_dblekind),pointer:: xgr(:,:,:)=>null() - real(sigio_dblekind),pointer:: xss(:)=>null() - end type -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Public Subprograms - public sigio_sropen,sigio_swopen,sigio_sclose,sigio_srhead,sigio_swhead - public sigio_alhead,sigio_aldata,sigio_axdata,sigio_srdata,sigio_swdata - public sigio_aldbta,sigio_axdbta,sigio_srdbta,sigio_swdbta - public sigio_srohdc,sigio_swohdc - interface sigio_srohdc - module procedure sigio_srohdca,sigio_srohdcb - end interface - interface sigio_swohdc - module procedure sigio_swohdca,sigio_swohdcb - end interface - public sigio_modpr,sigio_adhead -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Private Variables -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Private Types - type sigio_head2 - sequence - real(sigio_realkind):: fhour - integer(sigio_intkind):: idate(4) - real(sigio_realkind):: sisl(2*100+1) - real(sigio_realkind):: ext(44) - end type -contains -!------------------------------------------------------------------------------- - subroutine sigio_sropen(lu,cfname,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - character*(*),intent(in):: cfname - integer(sigio_intkind),intent(out):: iret - integer ios -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - open(lu,file=cfname,form='unformatted',& - status='old',action='read',iostat=ios) - iret=ios - if(iret.ne.0) iret=-1 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_swopen(lu,cfname,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - character*(*),intent(in):: cfname - integer(sigio_intkind),intent(out):: iret - integer ios -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - open(lu,file=cfname,form='unformatted',& - status='unknown',action='readwrite',iostat=ios) - iret=ios - if(iret.ne.0) iret=-1 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_sclose(lu,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - integer(sigio_intkind),intent(out):: iret - integer ios -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - close(lu,iostat=ios) - iret=ios - if(iret.ne.0) iret=-1 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_srhead(lu,head,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - type(sigio_head),intent(inout):: head - integer(sigio_intkind),intent(out):: iret - type(sigio_head2):: head2 - character(4):: cgfs,csig - integer(sigio_intkind):: nhead,ndata,nresv(3) - integer:: ios -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=-2 - rewind lu - read(lu,iostat=ios) head%clabsig - if(ios.ne.0) return - if(head%clabsig(1:8).eq.'GFS SIG ') then ! modern sigma file - rewind lu - read(lu,iostat=ios) cgfs,csig,head%ivs,nhead,ndata,nresv - if(ios.ne.0) return - if(head%ivs.eq.200509) then - read(lu,iostat=ios) - if(ios.ne.0) return - read(lu,iostat=ios) head%fhour,head%idate,head%jcap,head%levs,& - head%itrun,head%iorder,head%irealf,head%igen,head%latf,head%lonf,& - head%latb,head%lonb,head%latr,head%lonr,head%ntrac,head%nvcoord,& - head%icen2,head%iens,head%idpp,head%idsl,head%idvc,head%idvm,& - head%idvt,head%idrun,head%idusr,head%pdryini,head%ncldt,head%ixgr - if(ios.ne.0) return - call sigio_alhead(head,iret) - read(lu,iostat=ios) head%vcoord - if(ios.ne.0) return - read(lu,iostat=ios) head%cfvars - if(ios.ne.0) return - head%clabsig=' ' - head%si=sigio_realfill - head%sl=sigio_realfill - head%ak=sigio_realfill - head%bk=sigio_realfill - head%pdryini=sigio_realfill - else - return - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - else - read(lu,iostat=ios) head2%fhour,head2%idate,head2%sisl,head2%ext - if(ios.ne.0) return - head%fhour=head2%fhour - head%idate=head2%idate - head%jcap=head2%ext(1) - head%levs=head2%ext(2) - head%itrun=head2%ext(3) - head%iorder=head2%ext(4) - head%irealf=head2%ext(5) - head%igen=head2%ext(6) - head%lonf=head2%ext(7) - head%latf=head2%ext(8) - head%lonb=head2%ext(9) - head%latb=head2%ext(10) - head%lonr=head2%ext(11) - head%latr=head2%ext(12) - head%ntrac=max(head2%ext(13),1.) - head%icen2=head2%ext(14) - head%iens=head2%ext(15:16) - head%idpp=head2%ext(17) - head%idsl=head2%ext(18) - head%idvc=head2%ext(19) - head%idvm=head2%ext(20) - head%idvt=head2%ext(21) - head%idrun=head2%ext(22) - head%idusr=head2%ext(23) - head%pdryini=head2%ext(24) - head%ncldt=head2%ext(25) - head%ixgr=head2%ext(26) - head%si=sigio_realfill - head%sl=sigio_realfill - head%ak=sigio_realfill - head%bk=sigio_realfill - if(head%idvc.eq.0.or.head%idvc.eq.1) then - head%si(1:head%levs+1)=head2%sisl(1:head%levs+1) - head%sl(1:head%levs)=head2%sisl(head%levs+2:2*head%levs+1) - head%nvcoord=1 - call sigio_alhead(head,iret) - head%vcoord(1:head%levs+1,1)=head2%sisl(1:head%levs+1) - elseif(head%idvc.eq.2) then - head%ak(1:head%levs+1)=head2%sisl(1:head%levs+1) - head%bk(1:head%levs+1)=head2%sisl(head%levs+2:2*head%levs+2) - head%nvcoord=2 - call sigio_alhead(head,iret) - head%vcoord(1:head%levs+1,1)=head2%sisl(1:head%levs+1) - head%vcoord(1:head%levs+1,2)=head2%sisl(head%levs+2:2*head%levs+2) - elseif(head%idvc.eq.3) then - head%nvcoord=2 - call sigio_alhead(head,iret) - head%vcoord(1:head%levs+1,1)=head2%sisl(1:head%levs+1) - head%vcoord(1:head%levs+1,2)=head2%sisl(head%levs+2:2*head%levs+2) - endif - head%ivs=198410 - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_adhead(head) - iret=0 - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_swhead(lu,head,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - type(sigio_head),intent(inout):: head - integer(sigio_intkind),intent(out):: iret - integer(sigio_intkind) lhead,ldata - type(sigio_head2):: head2 - integer:: ios - integer i -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=-2 - call sigio_adhead(head) - rewind lu - if(head%ivs.ge.200509) then - write(lu,iostat=ios) 'GFS SIG ',head%ivs,head%nhead,head%ndata,0,0,0 - if(ios.ne.0) return - write(lu,iostat=ios) head%lhead,head%ldata - if(ios.ne.0) return - write(lu,iostat=ios) head%fhour,head%idate,head%jcap,head%levs,& - head%itrun,head%iorder,head%irealf,head%igen,head%latf,head%lonf,& - head%latb,head%lonb,head%latr,head%lonr,head%ntrac,head%nvcoord,& - head%icen2,head%iens,head%idpp,head%idsl,head%idvc,head%idvm,& - head%idvt,head%idrun,head%idusr,head%pdryini,head%ncldt,head%ixgr,& - (0,i=1,18) - if(ios.ne.0) return - if(size(head%vcoord).ne.(head%levs+1)*head%nvcoord) return - write(lu,iostat=ios) head%vcoord - if(ios.ne.0) return - if(size(head%cfvars).ne.5+head%ntrac) return - write(lu,iostat=ios) head%cfvars - if(ios.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - else - head2%fhour=head%fhour - head2%idate=head%idate - head2%sisl=0 - if(head%idvc.eq.0.or.head%idvc.eq.1) then - if(head%nvcoord.eq.1.and.head%vcoord(1,1).eq.1.) then - head2%sisl(1:head%levs+1)=head%vcoord(1:head%levs+1,1) - call sigio_modpr(1,1,head%levs,head%nvcoord,head%idvc,head%idsl,& - head%vcoord,iret,ps=(/1./),& - pm=head2%sisl(head%levs+2:2*head%levs+1)) - else - head2%sisl(1:head%levs+1)=head%si(1:head%levs+1) - head2%sisl(head%levs+2:2*head%levs+1)=head%sl(1:head%levs) - endif - elseif(head%idvc.eq.2) then - if(head%nvcoord.eq.2.and.head%vcoord(1,2).eq.1.) then - head2%sisl(1:head%levs+1)=head%vcoord(1:head%levs+1,1) - head2%sisl(head%levs+2:2*head%levs+2)=head%vcoord(1:head%levs+1,2) - else - head2%sisl(1:head%levs+1)=head%ak(1:head%levs+1) - head2%sisl(head%levs+2:2*head%levs+2)=head%bk(1:head%levs+1) - endif - elseif(head%idvc.eq.3) then - if(head%nvcoord.eq.2.and.head%vcoord(1,2).eq.1.) then - head2%sisl(1:head%levs+1)=head%vcoord(1:head%levs+1,1) - head2%sisl(head%levs+2:2*head%levs+2)=head%vcoord(1:head%levs+1,2) - endif - endif - head2%ext(1)=head%jcap - head2%ext(2)=head%levs - head2%ext(3)=head%itrun - head2%ext(4)=head%iorder - head2%ext(5)=head%irealf - head2%ext(6)=head%igen - head2%ext(7)=head%lonf - head2%ext(8)=head%latf - head2%ext(9)=head%lonb - head2%ext(10)=head%latb - head2%ext(11)=head%lonr - head2%ext(12)=head%latr - head2%ext(13)=head%ntrac - head2%ext(14)=head%icen2 - head2%ext(15:16)=head%iens - head2%ext(17)=head%idpp - head2%ext(18)=head%idsl - head2%ext(19)=head%idvc - head2%ext(20)=head%idvm - head2%ext(21)=head%idvt - head2%ext(22)=head%idrun - head2%ext(23)=head%idusr - head2%ext(24)=head%pdryini - head2%ext(25)=head%ncldt - head2%ext(26)=head%ixgr - head2%ext(27:44)=0 - write(lu,iostat=ios) head%clabsig - if(ios.ne.0) return - write(lu,iostat=ios) head2%fhour,head2%idate,head2%sisl,head2%ext - if(ios.ne.0) return - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=0 - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_alhead(head,iret,levs,nvcoord,ntrac) - implicit none - type(sigio_head),intent(inout):: head - integer(sigio_intkind),intent(out):: iret - integer(sigio_intkind),optional,intent(in):: levs,nvcoord,ntrac - integer dim1v,dim2v,dim1c -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(present(levs)) then - dim1v=levs+1 - else - dim1v=head%levs+1 - endif - if(present(nvcoord)) then - dim2v=nvcoord - else - dim2v=head%nvcoord - endif - if(present(ntrac)) then - dim1c=5+ntrac - else - dim1c=5+head%ntrac - endif - if(allocated(head%vcoord)) then - deallocate(head%vcoord) - endif - if(allocated(head%cfvars)) deallocate(head%cfvars) - allocate(head%vcoord(dim1v,dim2v),head%cfvars(dim1c),stat=iret) - if(iret.eq.0) then - head%vcoord=sigio_realfill - head%cfvars=' ' - endif - if(iret.ne.0) iret=-3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_aldata(head,data,iret) - implicit none - type(sigio_head),intent(in):: head - type(sigio_data),intent(inout):: data - integer(sigio_intkind),intent(out):: iret - integer nc,dim1,dim2,dim3q,dim1x,dim2x,dim3x -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_axdata(data,iret) - nc=(head%jcap+1)*(head%jcap+2) - dim1=nc - dim2=head%levs - dim3q=head%ntrac - dim1x=head%lonb - dim2x=head%latb - dim3x=head%nxgr - allocate(data%hs(dim1),data%ps(dim1),& - data%t(dim1,dim2),data%d(dim1,dim2),data%z(dim1,dim2),& - data%q(dim1,dim2,dim3q),& - data%xgr(dim1x,dim2x,dim3x),data%xss(head%nxss),stat=iret) - if(iret.ne.0) iret=-3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_axdata(data,iret) - implicit none - type(sigio_data),intent(inout):: data - integer(sigio_intkind),intent(out):: iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - deallocate(data%hs,data%ps,data%t,data%d,data%z,data%q,data%xgr,stat=iret) - nullify(data%hs,data%ps,data%t,data%d,data%z,data%q,data%xgr) - if(iret.ne.0) iret=-3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_srdata(lu,head,data,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - type(sigio_head),intent(in):: head - type(sigio_data),intent(inout):: data - integer(sigio_intkind),intent(out):: iret - type(sigio_dbta):: dbta - integer:: nc,mdim1,mdim2,mdim3q,mdim1x,mdim2x,mdim3x,k,n,ios -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - nc=(head%jcap+1)*(head%jcap+2) - mdim1=min(size(data%hs,1),size(data%ps,1),& - size(data%t,1),size(data%d,1),size(data%z,1),& - size(data%q,1)) - mdim2=min(size(data%t,2),size(data%d,2),size(data%z,2),& - size(data%q,2)) - mdim3q=size(data%q,3) - iret=-5 - if(mdim1.lt.nc.or.& - mdim2.lt.head%levs.or.& - mdim3q.lt.head%ntrac) return - if(head%nxgr.gt.0) then - mdim1x=size(data%xgr,1) - mdim2x=size(data%xgr,2) - mdim3x=size(data%xgr,3) - if(mdim1x.lt.head%lonb.or.& - mdim2x.lt.head%latb.or.& - mdim3x.lt.head%nxgr) return - if(size(data%xss).lt.head%nxss) return - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(head%irealf.ne.2) then - iret=-4 - read(lu,iostat=ios) data%hs(:nc) - if(ios.ne.0) return - read(lu,iostat=ios) data%ps(:nc) - if(ios.ne.0) return - do k=1,head%levs - read(lu,iostat=ios) data%t(:nc,k) - if(ios.ne.0) return - enddo - do k=1,head%levs - read(lu,iostat=ios) data%d(:nc,k) - if(ios.ne.0) return - read(lu,iostat=ios) data%z(:nc,k) - if(ios.ne.0) return - enddo - do n=1,head%ntrac - do k=1,head%levs - read(lu,iostat=ios) data%q(:nc,k,n) - if(ios.ne.0) return - enddo - enddo - do n=1,head%nxgr - read(lu,iostat=ios) data%xgr(:head%lonb,:head%latb,n) - if(ios.ne.0) return - enddo - if(head%nxss.gt.0) then - read(lu,iostat=ios) data%xss(:head%nxss) - if(ios.ne.0) return - endif - iret=0 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - else - call sigio_aldbta(head,dbta,iret) - if(iret.ne.0) return - call sigio_srdbta(lu,head,dbta,iret) - if(iret.ne.0) return - data%hs(:nc)=dbta%hs(:nc) - data%ps(:nc)=dbta%ps(:nc) - data%t(:nc,:head%levs)=dbta%t(:nc,:head%levs) - data%d(:nc,:head%levs)=dbta%d(:nc,:head%levs) - data%z(:nc,:head%levs)=dbta%z(:nc,:head%levs) - data%q(:nc,:head%levs,:head%ntrac)=dbta%q(:nc,:head%levs,:head%ntrac) - data%xgr(:head%lonb,:head%latb,:head%nxgr)=& - dbta%xgr(:head%lonb,:head%latb,:head%nxgr) - data%xss(:head%nxss)=dbta%xss(:head%nxss) - call sigio_axdbta(dbta,iret) - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_swdata(lu,head,data,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - type(sigio_head),intent(in):: head - type(sigio_data),intent(in):: data - integer(sigio_intkind),intent(out):: iret - type(sigio_dbta):: dbta - integer:: nc,mdim1,mdim2,mdim3q,mdim1x,mdim2x,mdim3x,k,n,ios -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - nc=(head%jcap+1)*(head%jcap+2) - mdim1=min(size(data%hs,1),size(data%ps,1),& - size(data%t,1),size(data%d,1),size(data%z,1),& - size(data%q,1)) - mdim2=min(size(data%t,2),size(data%d,2),size(data%z,2),& - size(data%q,2)) - mdim3q=size(data%q,3) - iret=-5 - if(mdim1.lt.nc.or.& - mdim2.lt.head%levs.or.& - mdim3q.lt.head%ntrac) return - if(head%nxgr.gt.0) then - mdim1x=size(data%xgr,1) - mdim2x=size(data%xgr,2) - mdim3x=size(data%xgr,3) - if(mdim1x.lt.head%lonb.or.& - mdim2x.lt.head%latb.or.& - mdim3x.lt.head%nxgr) return - if(size(data%xss).lt.head%nxss) return - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(head%irealf.ne.2) then - iret=-4 - write(lu,iostat=ios) data%hs(:nc) - if(ios.ne.0) return - write(lu,iostat=ios) data%ps(:nc) - if(ios.ne.0) return - do k=1,head%levs - write(lu,iostat=ios) data%t(:nc,k) - if(ios.ne.0) return - enddo - do k=1,head%levs - write(lu,iostat=ios) data%d(:nc,k) - if(ios.ne.0) return - write(lu,iostat=ios) data%z(:nc,k) - if(ios.ne.0) return - enddo - do n=1,head%ntrac - do k=1,head%levs - write(lu,iostat=ios) data%q(:nc,k,n) - if(ios.ne.0) return - enddo - enddo - do n=1,head%nxgr - write(lu,iostat=ios) data%xgr(:head%lonb,:head%latb,n) - if(ios.ne.0) return - enddo - if(head%nxss.gt.0) then - write(lu,iostat=ios) data%xss(:head%nxss) - if(ios.ne.0) return - endif - iret=0 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - else - call sigio_aldbta(head,dbta,iret) - if(iret.ne.0) return - dbta%hs(:nc)=data%hs(:nc) - dbta%ps(:nc)=data%ps(:nc) - dbta%t(:nc,:head%levs)=data%t(:nc,:head%levs) - dbta%d(:nc,:head%levs)=data%d(:nc,:head%levs) - dbta%z(:nc,:head%levs)=data%z(:nc,:head%levs) - dbta%q(:nc,:head%levs,:head%ntrac)=data%q(:nc,:head%levs,:head%ntrac) - dbta%xgr(:head%lonb,:head%latb,:head%nxgr)=& - data%xgr(:head%lonb,:head%latb,:head%nxgr) - dbta%xss(:head%nxss)=data%xss(:head%nxss) - call sigio_swdbta(lu,head,dbta,iret) - if(iret.ne.0) return - call sigio_axdbta(dbta,iret) - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_srohdca(lu,cfname,head,data,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - character*(*),intent(in):: cfname - type(sigio_head),intent(inout):: head - type(sigio_data),intent(inout):: data - integer(sigio_intkind),intent(out):: iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_sropen(lu,cfname,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_srhead(lu,head,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_aldata(head,data,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_srdata(lu,head,data,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_sclose(lu,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_swohdca(lu,cfname,head,data,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - character*(*),intent(in):: cfname - type(sigio_head),intent(inout):: head - type(sigio_data),intent(in):: data - integer(sigio_intkind),intent(out):: iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_swopen(lu,cfname,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_swhead(lu,head,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_swdata(lu,head,data,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_sclose(lu,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_aldbta(head,dbta,iret) - implicit none - type(sigio_head),intent(in):: head - type(sigio_dbta),intent(inout):: dbta - integer(sigio_intkind),intent(out):: iret - integer nc,dim1,dim2,dim3q,dim1x,dim2x,dim3x -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_axdbta(dbta,iret) - nc=(head%jcap+1)*(head%jcap+2) - dim1=nc - dim2=head%levs - dim3q=head%ntrac - dim1x=head%lonb - dim2x=head%latb - dim3x=head%nxgr - allocate(dbta%hs(dim1),dbta%ps(dim1),& - dbta%t(dim1,dim2),dbta%d(dim1,dim2),dbta%z(dim1,dim2),& - dbta%q(dim1,dim2,dim3q),& - dbta%xgr(dim1x,dim2x,dim3x),dbta%xss(head%nxss),stat=iret) - if(iret.ne.0) iret=-3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_axdbta(dbta,iret) - implicit none - type(sigio_dbta),intent(inout):: dbta - integer(sigio_intkind),intent(out):: iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - deallocate(dbta%hs,dbta%ps,dbta%t,dbta%d,dbta%z,dbta%q,dbta%xgr,stat=iret) - nullify(dbta%hs,dbta%ps,dbta%t,dbta%d,dbta%z,dbta%q,dbta%xgr) - if(iret.ne.0) iret=-3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_srdbta(lu,head,dbta,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - type(sigio_head),intent(in):: head - type(sigio_dbta),intent(inout):: dbta - integer(sigio_intkind),intent(out):: iret - type(sigio_data):: data - integer:: nc,mdim1,mdim2,mdim3q,mdim1x,mdim2x,mdim3x,k,n,ios -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - nc=(head%jcap+1)*(head%jcap+2) - mdim1=min(size(dbta%hs,1),size(dbta%ps,1),& - size(dbta%t,1),size(dbta%d,1),size(dbta%z,1),& - size(dbta%q,1)) - mdim2=min(size(dbta%t,2),size(dbta%d,2),size(dbta%z,2),& - size(dbta%q,2)) - mdim3q=size(dbta%q,3) - iret=-5 - if(mdim1.lt.nc.or.& - mdim2.lt.head%levs.or.& - mdim3q.lt.head%ntrac) return - if(head%nxgr.gt.0) then - mdim1x=size(dbta%xgr,1) - mdim2x=size(dbta%xgr,2) - mdim3x=size(dbta%xgr,3) - if(mdim1x.lt.head%lonb.or.& - mdim2x.lt.head%latb.or.& - mdim3x.lt.head%nxgr) return - if(size(dbta%xss).lt.head%nxss) return - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(head%irealf.ne.2) then - call sigio_aldata(head,data,iret) - if(iret.ne.0) return - call sigio_srdata(lu,head,data,iret) - if(iret.ne.0) return - dbta%hs(:nc)=data%hs(:nc) - dbta%ps(:nc)=data%ps(:nc) - dbta%t(:nc,:head%levs)=data%t(:nc,:head%levs) - dbta%d(:nc,:head%levs)=data%d(:nc,:head%levs) - dbta%z(:nc,:head%levs)=data%z(:nc,:head%levs) - dbta%q(:nc,:head%levs,:head%ntrac)=data%q(:nc,:head%levs,:head%ntrac) - dbta%xgr(:head%lonb,:head%latb,:head%nxgr)=& - data%xgr(:head%lonb,:head%latb,:head%nxgr) - dbta%xss(:head%nxss)=data%xss(:head%nxss) - call sigio_axdata(data,iret) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - else - iret=-4 - read(lu,iostat=ios) dbta%hs(:nc) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%ps(:nc) - if(ios.ne.0) return - do k=1,head%levs - read(lu,iostat=ios) dbta%t(:nc,k) - if(ios.ne.0) return - enddo - do k=1,head%levs - read(lu,iostat=ios) dbta%d(:nc,k) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%z(:nc,k) - if(ios.ne.0) return - enddo - do n=1,head%ntrac - do k=1,head%levs - read(lu,iostat=ios) dbta%q(:nc,k,n) - if(ios.ne.0) return - enddo - enddo - do n=1,head%nxgr - read(lu,iostat=ios) dbta%xgr(:head%lonb,:head%latb,n) - if(ios.ne.0) return - enddo - if(head%nxss.gt.0) then - read(lu,iostat=ios) dbta%xss(:head%nxss) - if(ios.ne.0) return - endif - iret=0 - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_swdbta(lu,head,dbta,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - type(sigio_head),intent(in):: head - type(sigio_dbta),intent(in):: dbta - integer(sigio_intkind),intent(out):: iret - type(sigio_data):: data - integer:: nc,mdim1,mdim2,mdim3q,mdim1x,mdim2x,mdim3x,k,n,ios -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - nc=(head%jcap+1)*(head%jcap+2) - mdim1=min(size(dbta%hs,1),size(dbta%ps,1),& - size(dbta%t,1),size(dbta%d,1),size(dbta%z,1),& - size(dbta%q,1)) - mdim2=min(size(dbta%t,2),size(dbta%d,2),size(dbta%z,2),& - size(dbta%q,2)) - mdim3q=size(dbta%q,3) - iret=-5 - if(mdim1.lt.nc.or.& - mdim2.lt.head%levs.or.& - mdim3q.lt.head%ntrac) return - if(head%nxgr.gt.0) then - mdim1x=size(dbta%xgr,1) - mdim2x=size(dbta%xgr,2) - mdim3x=size(dbta%xgr,3) - if(mdim1x.lt.head%lonb.or.& - mdim2x.lt.head%latb.or.& - mdim3x.lt.head%nxgr) return - if(size(dbta%xss).lt.head%nxss) return - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(head%irealf.ne.2) then - call sigio_aldata(head,data,iret) - if(iret.ne.0) return - data%hs(:nc)=dbta%hs(:nc) - data%ps(:nc)=dbta%ps(:nc) - data%t(:nc,:head%levs)=dbta%t(:nc,:head%levs) - data%d(:nc,:head%levs)=dbta%d(:nc,:head%levs) - data%z(:nc,:head%levs)=dbta%z(:nc,:head%levs) - data%q(:nc,:head%levs,:head%ntrac)=dbta%q(:nc,:head%levs,:head%ntrac) - data%xgr(:head%lonb,:head%latb,:head%nxgr)=& - dbta%xgr(:head%lonb,:head%latb,:head%nxgr) - data%xss(:head%nxss)=dbta%xss(:head%nxss) - call sigio_swdata(lu,head,data,iret) - if(iret.ne.0) return - call sigio_axdata(data,iret) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - else - iret=-4 - write(lu,iostat=ios) dbta%hs(:nc) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%ps(:nc) - if(ios.ne.0) return - do k=1,head%levs - write(lu,iostat=ios) dbta%t(:nc,k) - if(ios.ne.0) return - enddo - do k=1,head%levs - write(lu,iostat=ios) dbta%d(:nc,k) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%z(:nc,k) - if(ios.ne.0) return - enddo - do n=1,head%ntrac - do k=1,head%levs - write(lu,iostat=ios) dbta%q(:nc,k,n) - if(ios.ne.0) return - enddo - enddo - do n=1,head%nxgr - write(lu,iostat=ios) dbta%xgr(:head%lonb,:head%latb,n) - if(ios.ne.0) return - enddo - if(head%nxss.gt.0) then - write(lu,iostat=ios) dbta%xss(:head%nxss) - if(ios.ne.0) return - endif - iret=0 - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_srohdcb(lu,cfname,head,dbta,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - character*(*),intent(in):: cfname - type(sigio_head),intent(inout):: head - type(sigio_dbta),intent(inout):: dbta - integer(sigio_intkind),intent(out):: iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_sropen(lu,cfname,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_srhead(lu,head,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_aldbta(head,dbta,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_srdbta(lu,head,dbta,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_sclose(lu,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_swohdcb(lu,cfname,head,dbta,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - character*(*),intent(in):: cfname - type(sigio_head),intent(inout):: head - type(sigio_dbta),intent(in):: dbta - integer(sigio_intkind),intent(out):: iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_swopen(lu,cfname,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_swhead(lu,head,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_swdbta(lu,head,dbta,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_sclose(lu,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_modpr(im,ix,km,nvcoord,idvc,idsl,vcoord,iret,& - ps,t,pd,dpddps,dpddt,pm,dpmdps,dpmdt) - implicit none - integer,intent(in):: im,ix,km,nvcoord,idvc,idsl - real,intent(in):: vcoord(km+1,nvcoord) - integer,intent(out):: iret - real,intent(in),optional:: ps(ix),t(ix,km) - real,intent(out),optional:: pd(ix,km),pm(ix,km) - real,intent(out),optional:: dpddps(ix,km),dpddt(ix,km) - real,intent(out),optional:: dpmdps(ix,km),dpmdt(ix,km) - real(sigio_dblekind),parameter:: rocp=287.05/1004.6,rocpr=1/rocp - real(sigio_dblekind),parameter:: t00=300. - integer id1,id2 - real(sigio_dblekind) pid(im),dpiddps(im),dpiddt(im),tid(im),pidk(im) - real(sigio_dblekind) piu,dpiudps,dpiudt,tiu,piuk - real(sigio_dblekind) pmm,dpmdpid,dpmdpiu - real(sigio_dblekind) pmk - integer i,k -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if((idvc.eq.0.or.idvc.eq.1).and.nvcoord.eq.1.and.present(ps)) then - id1=11 - elseif(idvc.eq.2.and.nvcoord.eq.2.and.present(ps)) then - id1=22 - elseif(idvc.eq.3.and.nvcoord.eq.2.and.present(ps).and.present(t)) then - id1=32 - elseif(idvc.eq.3.and.nvcoord.eq.3.and.present(ps).and.present(t)) then - id1=33 - else - id1=0 - endif - if(idsl.eq.0.or.idsl.eq.1) then - id2=1 - elseif(idsl.eq.2) then - id2=2 - else - id2=0 - endif - iret=0 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(id1.gt.0.and.id2.gt.0) then - do i=1,im - pid(i)=ps(i) - dpiddps(i)=1 - dpiddt(i)=0 - tid(i)=0 - if(id2.eq.1) pidk(i)=pid(i)**rocp - enddo - do k=1,km - do i=1,im - select case(id1) - case(11) - piu=vcoord(k+1,1)*ps(i) - dpiudps=vcoord(k+1,1) - dpiudt=0 - case(22) - piu=vcoord(k+1,1)+vcoord(k+1,2)*ps(i) - dpiudps=vcoord(k+1,2) - dpiudt=0 - case(32) - tiu=(t(i,k)+t(i,min(k+1,km)))/2 - piu=vcoord(k+1,2)*ps(i)+vcoord(k+1,1)*(tiu/t00)**rocpr - dpiudps=vcoord(k+1,2) - dpiudt=vcoord(k+1,1)*(tiu/t00)**rocpr*rocpr/tiu - if(k.lt.km) dpiudt=dpiudt/2 - case(33) - tiu=(t(i,k)+t(i,min(k+1,km)))/2 - piu=vcoord(k+1,1)+vcoord(k+1,2)*ps(i)+vcoord(k+1,3)*(tiu/t00)**rocpr - dpiudps=vcoord(k+1,2) - dpiudt=vcoord(k+1,3)*(tiu/t00)**rocpr*rocpr/tiu - if(k.lt.km) dpiudt=dpiudt/2 - end select - if(present(pd)) pd(i,k)=pid(i)-piu - if(present(dpddps)) dpddps(i,k)=dpiddps(i)-dpiudps - if(present(dpddt)) dpddt(i,k)=dpiddt(i)-dpiudt -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - select case(id2) - case(1) - piuk=piu**rocp - pmk=(pid(i)*pidk(i)-piu*piuk)/((rocp+1)*(pid(i)-piu)) - pmm=pmk**rocpr - dpmdpid=rocpr*pmm/(pid(i)-piu)*(pidk(i)/pmk-1) - dpmdpiu=rocpr*pmm/(pid(i)-piu)*(1-piuk/pmk) - case(2) - pmm=(pid(i)+piu)/2 - dpmdpid=0.5 - dpmdpiu=0.5 - end select - if(present(pm)) pm(i,k)=pmm - if(present(dpmdps)) dpmdps(i,k)=dpmdpid*dpiddps(i)+dpmdpiu*dpiudps - if(present(dpmdt)) dpmdt(i,k)=dpmdpid*dpiddt(i)+dpmdpiu*dpiudt -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - pid(i)=piu - dpiddps(i)=dpiudps - dpiddt(i)=dpiudt - tid(i)=tiu - if(id2.eq.1) pidk(i)=piuk - enddo - enddo - else - if(id1.le.0) iret=iret+1 - if(id2.le.0) iret=iret+2 - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_adhead(head) - implicit none - type(sigio_head),intent(inout):: head - integer jxss,nspec - head%nxgr=0 - head%nxss=0 - if(head%ixgr.eq.1) then - head%nxgr=2*head%levs+1 - head%nxss=0 - elseif(head%ixgr.eq.2) then - head%nxgr=4*head%levs+3 - head%nxss=0 - elseif(head%ixgr.eq.3) then - head%nxgr=3*head%levs+1 - head%nxss=0 - elseif(head%ixgr.eq.4) then - head%nxgr=4*head%levs+3 - head%nxss=1 - elseif(head%ixgr.eq.5) then - head%nxgr=3*head%levs+1 - head%nxss=1 - endif - nspec=2+(3+head%ntrac)*head%levs - if(head%ivs.eq.200509) then - jxss=0 - if(head%nxss.gt.0) jxss=1 - head%nhead=5 - head%ndata=nspec+head%nxgr+jxss - if(allocated(head%lhead)) deallocate(head%lhead) - if(allocated(head%ldata)) deallocate(head%ldata) - allocate(head%lhead(head%nhead)) - allocate(head%ldata(head%ndata)) - head%lhead=(/sigio_lhead1,4*(head%nhead+head%ndata),4*50,& - 4*((head%levs+1)*head%nvcoord),8*(5+head%ntrac)/) - head%ldata(1:nspec)=4*head%irealf*(head%jcap+1)*(head%jcap+2) - head%ldata(nspec+1:nspec+head%nxgr)=4*head%irealf*head%lonb*head%latb - head%ldata(nspec+head%nxgr+1:head%ndata)=4*head%irealf*head%nxss - else - head%nhead=2 - head%ndata=nspec+head%nxgr - if(allocated(head%lhead)) deallocate(head%lhead) - if(allocated(head%ldata)) deallocate(head%ldata) - allocate(head%lhead(head%nhead)) - allocate(head%ldata(head%ndata)) - head%lhead=(/sigio_lhead1,4*250/) - head%ldata(1:nspec)=4*head%irealf*(head%jcap+1)*(head%jcap+2) - head%ldata(nspec+1:nspec+head%nxgr)=4*head%irealf*head%lonb*head%latb - endif - end subroutine -!------------------------------------------------------------------------------- -end module diff --git a/src/fim/FIMsrc/prep/sigio/sigio_r_module.F90 b/src/fim/FIMsrc/prep/sigio/sigio_r_module.F90 deleted file mode 100644 index 9416882..0000000 --- a/src/fim/FIMsrc/prep/sigio/sigio_r_module.F90 +++ /dev/null @@ -1,2128 +0,0 @@ -!------------------------------------------------------------------------------- -module sigio_r_module -!$$$ Module Documentation Block -! -! Module: sigio_r_module API for global spectral sigma file random I/O -! Prgmmr: Iredell Org: W/NX23 Date: 1999-01-18 -! -! Abstract: This module provides an Application Program Interface extension -! for performing I/O on the sigma restart file of the global spectral model. -! Functions include opening, reading, writing, and closing as well as -! allocating and deallocating data buffers used in the transfers. -! The I/O performed here is random. -! The transfers are limited to header records, data records, -! surface data records, or specific levels of upper air data records. -! See the documentation for sigio_module for sequential I/O. -! -! Program History Log: -! 1999-01-18 Mark Iredell -! -! Modules Used: -! sigio_module API for global spectral sigma file I/O -! -! Public Variables: -! -! Public Defined Types: -! sigio_dats Sigma file surface data fields -! hs Real(sigio_realkind)(:) pointer to spectral -! coefficients of surface height in m -! ps Real(sigio_realkind)(:) pointer to spectral -! coefficients of log of surface pressure over 1 kPa -! -! sigio_datm Sigma file multilevel data fields -! k1 Integer(sigio_intkind) first level number -! k2 Integer(sigio_intkind) last level number -! t Real(sigio_realkind)(:,:) pointer to spectral -! coefficients of virtual temperature by level in K -! d Real(sigio_realkind)(:,:) pointer to spectral -! coefficients of divergence by level in 1/second -! z Real(sigio_realkind)(:,:) pointer to spectral -! coefficients of vorticity by level in 1/second -! q Real(sigio_realkind)(:,:,:) pointer to spectral -! coefficients of tracers by tracer number and level -! in specific densities -! -! sigio_dati Sigma file single data field -! i Integer(sigio_intkind) record index -! f Real(sigio_realkind)(:) pointer to field -! -! sigio_dbts Sigma file longreal surface data fields -! hs Real(sigio_dblekind)(:) pointer to spectral -! coefficients of surface height in m -! ps Real(sigio_dblekind)(:) pointer to spectral -! coefficients of log of surface pressure over 1 kPa -! -! sigio_dbtm Sigma file longreal multilevel data fields -! k1 Integer(sigio_intkind) first level number -! k2 Integer(sigio_intkind) last level number -! t Real(sigio_dblekind)(:,:) pointer to spectral -! coefficients of virtual temperature by level in K -! d Real(sigio_dblekind)(:,:) pointer to spectral -! coefficients of divergence by level in 1/second -! z Real(sigio_dblekind)(:,:) pointer to spectral -! coefficients of vorticity by level in 1/second -! q Real(sigio_dblekind)(:,:,:) pointer to spectral -! coefficients of tracers by tracer number and level -! in specific densities -! -! sigio_dbti Sigma file longreal single data field -! i Integer(sigio_intkind) record index -! f Real(sigio_dblekind)(:) pointer to field -! -! Public Subprograms: -! sigio_rropen Open sigma file for random reading -! lu Integer(sigio_intkind) input logical unit -! cfname Character(*) input filename -! iret Integer(sigio_intkind) output return code -! -! sigio_rwopen Open sigma file for random writing -! lu Integer(sigio_intkind) input logical unit -! cfname Character(*) input filename -! iret Integer(sigio_intkind) output return code -! -! sigio_rxopen Open sigma file for random reading and writing -! lu Integer(sigio_intkind) input logical unit -! cfname Character(*) input filename -! iret Integer(sigio_intkind) output return code -! -! sigio_rclose Close sigma file for random I/O -! lu Integer(sigio_intkind) input logical unit -! iret Integer(sigio_intkind) output return code -! -! sigio_rrhead Read header information with random I/O -! lu Integer(sigio_intkind) input logical unit -! head Type(sigio_head) output header information -! iret Integer(sigio_intkind) output return code -! -! sigio_rwhead Write header information with random I/O -! lu Integer(sigio_intkind) input logical unit -! head Type(sigio_head) input header information -! iret Integer(sigio_intkind) output return code -! -! sigio_aldats Allocate surface data fields -! head Type(sigio_head) input header information -! dats Type(sigio_dats) output surface data fields -! iret Integer(sigio_intkind) output return code -! -! sigio_axdats Deallocate surface data fields -! dats Type(sigio_dats) output surface data fields -! iret Integer(sigio_intkind) output return code -! -! sigio_aldatm Allocate multilevel data fields -! head Type(sigio_head) input header information -! k1 Integer(sigio_intkind) input first level number -! k2 Integer(sigio_intkind) input last level number -! datm Type(sigio_datm) output multilevel data fields -! iret Integer(sigio_intkind) output return code -! -! sigio_axdatm Deallocate multilevel data fields -! datm Type(sigio_datm) output multilevel data fields -! iret Integer(sigio_intkind) output return code -! -! sigio_aldati Allocate single data fields -! head Type(sigio_head) input header information -! i Integer(sigio_intkind) input record index -! dati Type(sigio_dati) output single data field -! iret Integer(sigio_intkind) output return code -! -! sigio_axdati Deallocate single data fields -! dati Type(sigio_dati) output single data field -! iret Integer(sigio_intkind) output return code -! -! sigio_rrdata Read data fields with random I/O -! lu Integer(sigio_intkind) input logical unit -! head Type(sigio_head) input header information -! data Type(sigio_data) output data fields -! iret Integer(sigio_intkind) output return code -! -! sigio_rwdata Write data fields with random I/O -! lu Integer(sigio_intkind) input logical unit -! head Type(sigio_head) input header information -! data Type(sigio_data) input data fields -! iret Integer(sigio_intkind) output return code -! -! sigio_rrohdc Open, read header & data and close with random I/O -! lu Integer(sigio_intkind) input logical unit -! cfname Character(*) input filename -! head Type(sigio_head) output header information -! data Type(sigio_data) or type(sigio_dbta) output data fields -! iret Integer(sigio_intkind) output return code -! -! sigio_rwohdc Open, write header & data and close with random I/O -! lu Integer(sigio_intkind) input logical unit -! cfname Character(*) input filename -! head Type(sigio_head) input header information -! data Type(sigio_data) or type(sigio_dbta) input data fields -! iret Integer(sigio_intkind) output return code -! -! sigio_rrdats Read surface data fields with random I/O -! lu Integer(sigio_intkind) input logical unit -! head Type(sigio_head) input header information -! dats Type(sigio_dats) output surface data fields -! iret Integer(sigio_intkind) output return code -! -! sigio_rwdats Write surface data fields with random I/O -! lu Integer(sigio_intkind) input logical unit -! head Type(sigio_head) input header information -! dats Type(sigio_dats) input surface data fields -! iret Integer(sigio_intkind) output return code -! -! sigio_rrdatm Read multilevel data fields with random I/O -! lu Integer(sigio_intkind) input logical unit -! head Type(sigio_head) input header information -! datm Type(sigio_datm) output multilevel data fields -! iret Integer(sigio_intkind) output return code -! -! sigio_rwdatm Write multilevel data fields with random I/O -! lu Integer(sigio_intkind) input logical unit -! head Type(sigio_head) input header information -! datm Type(sigio_datm) input multilevel data fields -! iret Integer(sigio_intkind) output return code -! -! sigio_rrdati Read single data field with random I/O -! lu Integer(sigio_intkind) input logical unit -! head Type(sigio_head) input header information -! dati Type(sigio_dati) output single data field -! iret Integer(sigio_intkind) output return code -! -! sigio_rwdati Write single data field with random I/O -! lu Integer(sigio_intkind) input logical unit -! head Type(sigio_head) input header information -! dati Type(sigio_dati) input single data field -! iret Integer(sigio_intkind) output return code -! -! sigio_aldbts Allocate longreal surface data fields -! head Type(sigio_head) input header information -! dbts Type(sigio_dbts) output longreal surface data fields -! iret Integer(sigio_intkind) output return code -! -! sigio_axdbts Deallocate longreal surface data fields -! dbts Type(sigio_dbts) output longreal surface data fields -! iret Integer(sigio_intkind) output return code -! -! sigio_aldbtm Allocate longreal multilevel data fields -! head Type(sigio_head) input header information -! k Integer(sigio_intkind) input level number -! dbtm Type(sigio_dbtm) output longreal multilevel data fields -! iret Integer(sigio_intkind) output return code -! -! sigio_axdbtm Deallocate longreal multilevel data fields -! dbtm Type(sigio_dbtm) output longreal multilevel data fields -! iret Integer(sigio_intkind) output return code -! -! sigio_aldbti Allocate longreal single data fields -! head Type(sigio_head) input header information -! i Integer(sigio_intkind) input record index -! dbti Type(sigio_dbti) output longreal single data field -! iret Integer(sigio_intkind) output return code -! -! sigio_axdbti Deallocate longreal single data fields -! dbti Type(sigio_dbti) output longreal single data field -! iret Integer(sigio_intkind) output return code -! -! sigio_rrdbta Read longreal data fields with random I/O -! lu Integer(sigio_intkind) input logical unit -! head Type(sigio_head) input header information -! dbta Type(sigio_dbta) output longreal data fields -! iret Integer(sigio_intkind) output return code -! -! sigio_rwdbta Write longreal data fields with random I/O -! lu Integer(sigio_intkind) input logical unit -! head Type(sigio_head) input header information -! dbta Type(sigio_dbta) input longreal data fields -! iret Integer(sigio_intkind) output return code -! -! sigio_rrdbts Read longreal surface data fields with random I/O -! lu Integer(sigio_intkind) input logical unit -! head Type(sigio_head) input header information -! dbts Type(sigio_dbts) output longreal surface data fields -! iret Integer(sigio_intkind) output return code -! -! sigio_rwdbts Write longreal surface data fields with random I/O -! lu Integer(sigio_intkind) input logical unit -! head Type(sigio_head) input header information -! dbts Type(sigio_dbts) input longreal surface data fields -! iret Integer(sigio_intkind) output return code -! -! sigio_rrdbtm Read longreal multilevel data fields with random I/O -! lu Integer(sigio_intkind) input logical unit -! head Type(sigio_head) input header information -! dbtm Type(sigio_dbtm) output longreal multilevel data fields -! iret Integer(sigio_intkind) output return code -! -! sigio_rwdbtm Write longreal multilevel data fields with random I/O -! lu Integer(sigio_intkind) input logical unit -! head Type(sigio_head) input header information -! dbtm Type(sigio_dbtm) input longreal multilevel data fields -! iret Integer(sigio_intkind) output return code -! -! sigio_rrdbti Read longreal single data field with random I/O -! lu Integer(sigio_intkind) input logical unit -! head Type(sigio_head) input header information -! dbti Type(sigio_dbti) output longreal single data field -! iret Integer(sigio_intkind) output return code -! -! sigio_rwdbti Write longreal single data field with random I/O -! lu Integer(sigio_intkind) input logical unit -! head Type(sigio_head) input header information -! dbti Type(sigio_dbti) input longreal single data field -! iret Integer(sigio_intkind) output return code -! -! Subprograms called: -! baopenr Byte-addressable open for reading -! baopenw Byte-addressable open for writing -! baclose Byte-addressable close -! bafrindex Byte-addressable Fortran record index -! bafrread Byte-addressable Fortran record read -! bafrwrite Byte-addressable Fortran record write -! -! Remarks: -! (1) The sigma file format follows: -! ON85 label (32 bytes) -! Header information record containing -! real forecast hour, initial date, sigma interfaces, sigma levels, -! padding to allow for 100 levels, and finally 44 identifier words -! containing JCAP, LEVS, NTRAC, etc. (250 4-byte words) -! Orography (NC 4-byte words, where NC=(JCAP+1)*(JCAP+2)) -! Log surface pressure (NC 4-byte words) -! Temperature (LEVS records of NC 4-byte words) -! Divergence & Vorticity interleaved (2*LEVS records of NC 4-byte words) -! Tracers (LEVS*NTRAC records of NC 4-byte words) -! -! (2) Possible return codes: -! 0 Successful call -! -1 Open or close I/O error -! -2 Header record I/O error (possible EOF) -! -3 Allocation or deallocation error -! -4 Data record I/O error -! -5 Insufficient data dimensions allocated -! -! Examples: -! (1) Write out orography and surface pressure only from processor 0: -! -! subroutine write_surface_fields(me,head,len,orog,lnps) -! use sigio_r_module -! integer,intent(in):: me -! type(sigio_head),intent(in):: head -! integer,intent(in):: len -! real(sigio_dblekind),intent(in),target:: orog(len),lnps(len) -! type(sigio_dbts) dbts -! integer iret -! if(me.eq.0) then -! dbts%hs=>orog -! dbts%ps=>lnps -! call sigio_rwdbts(51,head,dbts,iret) -! endif -! end subroutine -! -! Attributes: -! Language: Fortran 90 -! -!$$$ - use sigio_module - implicit none - private -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Public Variables -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Public Types - type,public:: sigio_dats - real(sigio_realkind),pointer:: hs(:),ps(:) - end type - type,public:: sigio_datm - integer(sigio_intkind):: k1,k2 - real(sigio_realkind),pointer:: t(:,:),d(:,:),z(:,:) - real(sigio_realkind),pointer:: q(:,:,:) - end type - type,public:: sigio_dati - integer(sigio_intkind):: i - real(sigio_realkind),pointer:: f(:) - end type - type,public:: sigio_dbts - real(sigio_dblekind),pointer:: hs(:),ps(:) - end type - type,public:: sigio_dbtm - integer(sigio_intkind):: k1,k2 - real(sigio_dblekind),pointer:: t(:,:),d(:,:),z(:,:) - real(sigio_dblekind),pointer:: q(:,:,:) - end type - type,public:: sigio_dbti - integer(sigio_intkind):: i - real(sigio_dblekind),pointer:: f(:) - end type -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Private Variables -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Private Types - type sigio_head2 - sequence - real(sigio_realkind):: fhour - integer(sigio_intkind):: idate(4) - real(sigio_realkind):: sisl(2*100+1) - real(sigio_realkind):: ext(44) - end type - type sigio_head1a - sequence - character(8):: clab8 - integer(sigio_intkind):: ivs,nhead,ndata,reserved(3) - end type - type sigio_head3a - sequence - real(sigio_realkind) fhour - integer(sigio_intkind):: idate(4) - integer(sigio_intkind):: jcap,levs,& - itrun,iorder,irealf,igen,latf,lonf,& - latb,lonb,latr,lonr,ntrac,nvcoord,& - icen2,iens(2),idpp,idsl,idvc,idvm,& - idvt,idrun,idusr - real(sigio_realkind) pdryini - integer(sigio_intkind):: ncldt,ixgr - integer(sigio_intkind):: reserved(18) - end type -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Public Subprograms - public sigio_rropen,sigio_rwopen,sigio_rxopen,sigio_rclose - public sigio_rrhead,sigio_rwhead - public sigio_aldats,sigio_axdats - public sigio_aldatm,sigio_axdatm - public sigio_aldati,sigio_axdati - public sigio_rrdata,sigio_rwdata - public sigio_rrohdc,sigio_rwohdc - public sigio_rrdats,sigio_rwdats - public sigio_rrdatm,sigio_rwdatm - public sigio_rrdati,sigio_rwdati - public sigio_aldbts,sigio_axdbts - public sigio_aldbtm,sigio_axdbtm - public sigio_aldbti,sigio_axdbti - public sigio_rrdbta,sigio_rwdbta - public sigio_rrdbts,sigio_rwdbts - public sigio_rrdbtm,sigio_rwdbtm - public sigio_rrdbti,sigio_rwdbti - interface sigio_rrohdc - module procedure sigio_rrohdca,sigio_rrohdcb - end interface - interface sigio_rwohdc - module procedure sigio_rwohdca,sigio_rwohdcb - end interface -contains -!------------------------------------------------------------------------------- - subroutine sigio_rropen(lu,cfname,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - character*(*),intent(in):: cfname - integer(sigio_intkind),intent(out):: iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call baopenr(lu,cfname,iret) - if(iret.ne.0) iret=-1 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_rwopen(lu,cfname,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - character*(*),intent(in):: cfname - integer(sigio_intkind),intent(out):: iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call baopenw(lu,cfname,iret) - if(iret.ne.0) iret=-1 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_rxopen(lu,cfname,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - character*(*),intent(in):: cfname - integer(sigio_intkind),intent(out):: iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call baopen(lu,cfname,iret) - if(iret.ne.0) iret=-1 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_rclose(lu,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - integer(sigio_intkind),intent(out):: iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call baclose(lu,iret) - if(iret.ne.0) iret=-1 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_rrhead(lu,head,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - type(sigio_head),intent(inout):: head - integer(sigio_intkind),intent(out):: iret - type(sigio_head2):: head2 - type(sigio_head1a):: head1a - type(sigio_head3a):: head3a - integer:: iskip,iread,nread -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=-2 - iskip=0 - iread=sigio_lhead1 - call bafrread(lu,iskip,iread,nread,head1a) - if(nread.lt.iread) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(head1a%clab8.eq.'GFS SIG ') then ! modern sigma file - head%ivs=head1a%ivs - call bafrindex(lu,iskip+nread,nread,iskip) - iread=200 - call bafrread(lu,iskip,iread,nread,head3a) - if(nread.lt.iread) return - head%fhour=head3a%fhour - head%idate=head3a%idate - head%jcap=head3a%jcap - head%levs=head3a%levs - head%itrun=head3a%itrun - head%iorder=head3a%iorder - head%irealf=head3a%irealf - head%igen=head3a%igen - head%latf=head3a%latf - head%lonf=head3a%lonf - head%latb=head3a%latb - head%lonb=head3a%lonb - head%latr=head3a%latr - head%lonr=head3a%lonr - head%ntrac=head3a%ntrac - head%nvcoord=head3a%nvcoord - head%icen2=head3a%icen2 - head%iens=head3a%iens - head%idpp=head3a%idpp - head%idsl=head3a%idsl - head%idvc=head3a%idvc - head%idvm=head3a%idvm - head%idvt=head3a%idvt - head%idrun=head3a%idrun - head%idusr=head3a%idusr - head%pdryini=head3a%pdryini - head%ncldt=head3a%ncldt - head%ixgr=head3a%ixgr - call sigio_alhead(head,iret) - iskip=iskip+nread - iread=4*size(head%vcoord) - call bafrread(lu,iskip,iread,nread,head%vcoord) - if(nread.lt.iread) return - iskip=iskip+nread - iread=size(head%cfvars) - call bafrread(lu,iskip,iread,nread,head%cfvars) - if(nread.lt.iread) return - head%clabsig=' ' - head%si=sigio_realfill - head%sl=sigio_realfill - head%ak=sigio_realfill - head%bk=sigio_realfill - head%pdryini=sigio_realfill -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - else - iskip=0 - iread=sigio_lhead1 - call bafrread(lu,iskip,iread,nread,head%clabsig) - if(nread.lt.iread) return - iskip=iskip+nread - iread=1000 - call bafrread(lu,iskip,iread,nread,head2) - if(nread.lt.iread) return - iret=0 - head%fhour=head2%fhour - head%idate=head2%idate - head%jcap=head2%ext(1) - head%levs=head2%ext(2) - head%itrun=head2%ext(3) - head%iorder=head2%ext(4) - head%irealf=head2%ext(5) - head%igen=head2%ext(6) - head%lonf=head2%ext(7) - head%latf=head2%ext(8) - head%lonb=head2%ext(9) - head%latb=head2%ext(10) - head%lonr=head2%ext(11) - head%latr=head2%ext(12) - head%ntrac=max(head2%ext(13),1.) - head%icen2=head2%ext(14) - head%iens=head2%ext(15:16) - head%idpp=head2%ext(17) - head%idsl=head2%ext(18) - head%idvc=head2%ext(19) - head%idvm=head2%ext(20) - head%idvt=head2%ext(21) - head%idrun=head2%ext(22) - head%idusr=head2%ext(23) - head%pdryini=head2%ext(24) - head%ncldt=head2%ext(25) - head%si=sigio_realfill - head%sl=sigio_realfill - head%ak=sigio_realfill - head%bk=sigio_realfill - if(head%idvc.eq.2) then - head%ak(1:head%levs+1)=head2%sisl(1:head%levs+1) - head%bk(1:head%levs+1)=head2%sisl(head%levs+2:2*head%levs+2) - else - head%si(1:head%levs+1)=head2%sisl(1:head%levs+1) - head%sl(1:head%levs)=head2%sisl(head%levs+2:2*head%levs+1) - endif - head%ivs=198410 - if(head%idvc.eq.2) then - head%nvcoord=2 - call sigio_alhead(head,iret) - head%vcoord(1:head%levs+1,1)=head%ak(1:head%levs+1) - head%vcoord(1:head%levs+1,2)=head%bk(1:head%levs+1) - elseif(head%idvc.eq.0.or.head%idvc.eq.1) then - head%nvcoord=1 - call sigio_alhead(head,iret) - head%vcoord(1:head%levs+1,1)=head%si(1:head%levs+1) - endif - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_adhead(head) - iret=0 - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_rwhead(lu,head,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - type(sigio_head),intent(inout):: head - integer(sigio_intkind),intent(out):: iret - type(sigio_head2):: head2 - type(sigio_head1a):: head1a - integer,allocatable:: head2a(:) - type(sigio_head3a):: head3a - integer:: iskip,iwrite,nwrite -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=-2 - call sigio_adhead(head) - if(head%ivs.ge.200509) then - head1a%clab8='GFS SIG ' - head1a%ivs=head%ivs - head1a%nhead=head%nhead - head1a%ndata=head%ndata - head1a%reserved=0 - iskip=0 - iwrite=head%lhead(1) - call bafrwrite(lu,iskip,iwrite,nwrite,head1a) - if(nwrite.lt.iwrite) return - allocate(head2a(head%nhead+head%ndata)) - head2a(:head%nhead)=head%lhead - head2a(head%nhead+1:)=head%ldata - iskip=iskip+nwrite - iwrite=head%lhead(2) - call bafrwrite(lu,iskip,iwrite,nwrite,head2a) - deallocate(head2a) - if(nwrite.lt.iwrite) return - head3a%fhour=head%fhour - head3a%idate=head%idate - head3a%jcap=head%jcap - head3a%levs=head%levs - head3a%itrun=head%itrun - head3a%iorder=head%iorder - head3a%irealf=head%irealf - head3a%igen=head%igen - head3a%latf=head%latf - head3a%lonf=head%lonf - head3a%latb=head%latb - head3a%lonb=head%lonb - head3a%latr=head%latr - head3a%lonr=head%lonr - head3a%ntrac=head%ntrac - head3a%nvcoord=head%nvcoord - head3a%icen2=head%icen2 - head3a%iens=head%iens - head3a%idpp=head%idpp - head3a%idsl=head%idsl - head3a%idvc=head%idvc - head3a%idvm=head%idvm - head3a%idvt=head%idvt - head3a%idrun=head%idrun - head3a%idusr=head%idusr - head3a%pdryini=head%pdryini - head3a%ncldt=head%ncldt - head3a%ixgr=head%ixgr - head3a%reserved=0 - iskip=iskip+nwrite - iwrite=head%lhead(3) - call bafrwrite(lu,iskip,iwrite,nwrite,head3a) - if(nwrite.lt.iwrite) return - iskip=iskip+nwrite - iwrite=head%lhead(4) - call bafrwrite(lu,iskip,iwrite,nwrite,head%vcoord) - if(nwrite.lt.iwrite) return - iskip=iskip+nwrite - iwrite=head%lhead(5) - call bafrwrite(lu,iskip,iwrite,nwrite,head%cfvars) - if(nwrite.lt.iwrite) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - else - iskip=0 - iwrite=sigio_lhead1 - call bafrwrite(lu,iskip,iwrite,nwrite,head%clabsig) - if(nwrite.lt.iwrite) return - head2%fhour=head%fhour - head2%idate=head%idate - head2%sisl=0 - if(head%idvc.eq.2) then - if(head%nvcoord.eq.2.and.head%vcoord(1,2).eq.1.) then - head2%sisl(1:head%levs+1)=head%vcoord(1:head%levs+1,1) - head2%sisl(head%levs+2:2*head%levs+2)=head%vcoord(1:head%levs+1,2) - else - head2%sisl(1:head%levs+1)=head%ak(1:head%levs+1) - head2%sisl(head%levs+2:2*head%levs+2)=head%bk(1:head%levs+1) - endif - elseif(head%idvc.eq.0.or.head%idvc.eq.1) then - if(head%nvcoord.eq.1.and.head%vcoord(1,1).eq.1.) then - head2%sisl(1:head%levs+1)=head%vcoord(1:head%levs+1,1) - call sigio_modpr(1,1,head%levs,head%nvcoord,head%idvc,head%idsl,& - head%vcoord,iret,ps=(/1./),& - pm=head2%sisl(head%levs+2:2*head%levs+1)) - else - head2%sisl(1:head%levs+1)=head%si(1:head%levs+1) - head2%sisl(head%levs+2:2*head%levs+1)=head%sl(1:head%levs) - endif - endif - head2%ext(1)=head%jcap - head2%ext(2)=head%levs - head2%ext(3)=head%itrun - head2%ext(4)=head%iorder - head2%ext(5)=head%irealf - head2%ext(6)=head%igen - head2%ext(7)=head%lonf - head2%ext(8)=head%latf - head2%ext(9)=head%lonb - head2%ext(10)=head%latb - head2%ext(11)=head%lonr - head2%ext(12)=head%latr - head2%ext(13)=head%ntrac - head2%ext(14)=head%icen2 - head2%ext(15:16)=head%iens - head2%ext(17)=head%idpp - head2%ext(18)=head%idsl - head2%ext(19)=head%idvc - head2%ext(20)=head%idvm - head2%ext(21)=head%idvt - head2%ext(22)=head%idrun - head2%ext(23)=head%idusr - head2%ext(24)=head%pdryini - head2%ext(25)=head%ncldt - head2%ext(26:44)=0 - iskip=iskip+nwrite - iwrite=1000 - call bafrwrite(lu,iskip,iwrite,nwrite,head2) - if(nwrite.lt.iwrite) return - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=0 - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_aldats(head,dats,iret) - implicit none - type(sigio_head),intent(in):: head - type(sigio_dats),intent(inout):: dats - integer(sigio_intkind),intent(out):: iret - integer nc,dim1 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_axdats(dats,iret) - nc=(head%jcap+1)*(head%jcap+2) - dim1=nc - allocate(dats%hs(dim1),dats%ps(dim1),stat=iret) - if(iret.ne.0) iret=-3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_axdats(dats,iret) - implicit none - type(sigio_dats),intent(inout):: dats - integer(sigio_intkind),intent(out):: iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - deallocate(dats%hs,dats%ps,stat=iret) - nullify(dats%hs,dats%ps) - if(iret.ne.0) iret=-3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_aldatm(head,k1,k2,datm,iret) - implicit none - type(sigio_head),intent(in):: head - integer(sigio_intkind),intent(in):: k1,k2 - type(sigio_datm),intent(inout):: datm - integer(sigio_intkind),intent(out):: iret - integer nc,dim1,dim3q -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_axdatm(datm,iret) - iret=-3 - if(k1.lt.1.or.k2.gt.head%levs) return - nc=(head%jcap+1)*(head%jcap+2) - dim1=nc - dim3q=head%ntrac - datm%k1=k1 - datm%k2=k2 - allocate(datm%t(dim1,k1:k2),datm%d(dim1,k1:k2),datm%z(dim1,k1:k2),& - datm%q(dim1,k1:k2,dim3q),stat=iret) - if(iret.ne.0) iret=-3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_axdatm(datm,iret) - implicit none - type(sigio_datm),intent(inout):: datm - integer(sigio_intkind),intent(out):: iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - datm%k1=0 - datm%k2=0 - deallocate(datm%t,datm%d,datm%z,datm%q,stat=iret) - nullify(datm%t,datm%d,datm%z,datm%q) - if(iret.ne.0) iret=-3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_aldati(head,i,dati,iret) - implicit none - type(sigio_head),intent(in):: head - integer(sigio_intkind),intent(in):: i - type(sigio_dati),intent(inout):: dati - integer(sigio_intkind),intent(out):: iret - integer dim1 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_axdati(dati,iret) - iret=-3 - if(i.lt.1.or.i.gt.head%ndata) return - dim1=head%ldata(i)/(4*head%irealf) - dati%i=i - allocate(dati%f(dim1),stat=iret) - if(iret.ne.0) iret=-3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_axdati(dati,iret) - implicit none - type(sigio_dati),intent(inout):: dati - integer(sigio_intkind),intent(out):: iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - dati%i=0 - deallocate(dati%f,stat=iret) - nullify(dati%f) - if(iret.ne.0) iret=-3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_rrdata(lu,head,data,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - type(sigio_head),intent(in):: head - type(sigio_data),intent(inout):: data - integer(sigio_intkind),intent(out):: iret - integer:: i,k,n - integer:: nc,mdim1,mdim2,mdim3q - integer:: iskip,iread,nread - type(sigio_dbta):: dbta -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - mdim1=min(size(data%hs,1),size(data%ps,1),& - size(data%t,1),size(data%d,1),size(data%z,1),& - size(data%q,1)) - mdim2=min(size(data%t,2),size(data%d,2),size(data%z,2),& - size(data%q,2)) - mdim3q=size(data%q,3) - nc=(head%jcap+1)*(head%jcap+2) - iret=-5 - if(mdim1.lt.nc.or.& - mdim2.lt.head%levs.or.& - mdim3q.lt.head%ntrac) return - iret=-4 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(head%irealf.ne.2) then - iskip=0 - do i=1,head%nhead - call bafrindex(0,iskip,head%lhead(i),iskip) - enddo - i=1 - iread=head%ldata(i) - call bafrread(lu,iskip,iread,nread,data%hs) - if(nread.lt.iread) return - i=i+1 - iskip=iskip+nread - iread=head%ldata(i) - call bafrread(lu,iskip,iread,nread,data%ps) - if(nread.lt.iread) return - do k=1,head%levs - i=i+1 - iskip=iskip+nread - iread=head%ldata(i) - call bafrread(lu,iskip,iread,nread,data%t(1,k)) - if(nread.lt.iread) return - enddo - do k=1,head%levs - i=i+1 - iskip=iskip+nread - iread=head%ldata(i) - call bafrread(lu,iskip,iread,nread,data%d(1,k)) - if(nread.lt.iread) return - i=i+1 - iskip=iskip+nread - iread=head%ldata(i) - call bafrread(lu,iskip,iread,nread,data%z(1,k)) - if(nread.lt.iread) return - enddo - do n=1,head%ntrac - do k=1,head%levs - i=i+1 - iskip=iskip+nread - iread=head%ldata(i) - call bafrread(lu,iskip,iread,nread,data%q(1,k,n)) - if(nread.lt.iread) return - enddo - enddo - do n=1,head%nxgr - i=i+1 - iskip=iskip+nread - iread=head%ldata(i) - call bafrread(lu,iskip,iread,nread,data%xgr(1,1,n)) - if(nread.lt.iread) return - enddo - if(head%nxss.gt.0) then - i=i+1 - iskip=iskip+nread - iread=head%ldata(i) - call bafrread(lu,iskip,iread,nread,data%xss) - if(nread.lt.iread) return - endif - else - call sigio_aldbta(head,dbta,iret) - if(iret.ne.0) return - call sigio_rrdbta(lu,head,dbta,iret) - if(iret.ne.0) return - data%hs(:nc)=dbta%hs(:nc) - data%ps(:nc)=dbta%ps(:nc) - data%t(:nc,:head%levs)=dbta%t(:nc,:head%levs) - data%d(:nc,:head%levs)=dbta%d(:nc,:head%levs) - data%z(:nc,:head%levs)=dbta%z(:nc,:head%levs) - data%q(:nc,:head%levs,:head%ntrac)=dbta%q(:nc,:head%levs,:head%ntrac) - data%xgr(:head%lonb,:head%latb,:head%nxgr)=& - dbta%xgr(:head%lonb,:head%latb,:head%nxgr) - data%xss(:head%nxss)=dbta%xss(:head%nxss) - call sigio_axdbta(dbta,iret) - endif - iret=0 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_rwdata(lu,head,data,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - type(sigio_head),intent(in):: head - type(sigio_data),intent(in):: data - integer(sigio_intkind),intent(out):: iret - integer:: i,k,n - integer:: nc,mdim1,mdim2,mdim3q - integer:: iskip,iwrite,nwrite - type(sigio_dbta):: dbta -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - mdim1=min(size(data%hs,1),size(data%ps,1),& - size(data%t,1),size(data%d,1),size(data%z,1),& - size(data%q,1)) - mdim2=min(size(data%t,2),size(data%d,2),size(data%z,2),& - size(data%q,2)) - mdim3q=size(data%q,3) - nc=(head%jcap+1)*(head%jcap+2) - iret=-5 - if(mdim1.lt.nc.or.& - mdim2.lt.head%levs.or.& - mdim3q.lt.head%ntrac) return - iret=-4 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(head%irealf.ne.2) then - iskip=0 - do i=1,head%nhead - call bafrindex(0,iskip,head%lhead(i),iskip) - enddo - i=1 - iwrite=head%ldata(i) - call bafrwrite(lu,iskip,iwrite,nwrite,data%hs) - if(nwrite.lt.iwrite) return - i=i+1 - iskip=iskip+nwrite - iwrite=head%ldata(i) - call bafrwrite(lu,iskip,iwrite,nwrite,data%ps) - if(nwrite.lt.iwrite) return - do k=1,head%levs - i=i+1 - iskip=iskip+nwrite - iwrite=head%ldata(i) - call bafrwrite(lu,iskip,iwrite,nwrite,data%t(1,k)) - if(nwrite.lt.iwrite) return - enddo - do k=1,head%levs - i=i+1 - iskip=iskip+nwrite - iwrite=head%ldata(i) - call bafrwrite(lu,iskip,iwrite,nwrite,data%d(1,k)) - if(nwrite.lt.iwrite) return - i=i+1 - iskip=iskip+nwrite - iwrite=head%ldata(i) - call bafrwrite(lu,iskip,iwrite,nwrite,data%z(1,k)) - if(nwrite.lt.iwrite) return - enddo - do n=1,head%ntrac - do k=1,head%levs - i=i+1 - iskip=iskip+nwrite - iwrite=head%ldata(i) - call bafrwrite(lu,iskip,iwrite,nwrite,data%q(1,k,n)) - if(nwrite.lt.iwrite) return - enddo - enddo - do n=1,head%nxgr - i=i+1 - iskip=iskip+nwrite - iwrite=head%ldata(i) - call bafrwrite(lu,iskip,iwrite,nwrite,data%xgr(1,1,n)) - if(nwrite.lt.iwrite) return - enddo - if(head%nxss.gt.0) then - i=i+1 - iskip=iskip+nwrite - iwrite=head%ldata(i) - call bafrwrite(lu,iskip,iwrite,nwrite,data%xss) - if(nwrite.lt.iwrite) return - endif - else - call sigio_aldbta(head,dbta,iret) - if(iret.ne.0) return - dbta%hs(:nc)=data%hs(:nc) - dbta%ps(:nc)=data%ps(:nc) - dbta%t(:nc,:head%levs)=data%t(:nc,:head%levs) - dbta%d(:nc,:head%levs)=data%d(:nc,:head%levs) - dbta%z(:nc,:head%levs)=data%z(:nc,:head%levs) - dbta%q(:nc,:head%levs,:head%ntrac)=data%q(:nc,:head%levs,:head%ntrac) - dbta%xgr(:head%lonb,:head%latb,:head%nxgr)=& - data%xgr(:head%lonb,:head%latb,:head%nxgr) - dbta%xss(:head%nxss)=data%xss(:head%nxss) - call sigio_rwdbta(lu,head,dbta,iret) - if(iret.ne.0) return - call sigio_axdbta(dbta,iret) - endif - iret=0 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_rrohdca(lu,cfname,head,data,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - character*(*),intent(in):: cfname - type(sigio_head),intent(inout):: head - type(sigio_data),intent(inout):: data - integer(sigio_intkind),intent(out):: iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_rropen(lu,cfname,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_rrhead(lu,head,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_aldata(head,data,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_rrdata(lu,head,data,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_rclose(lu,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_rwohdca(lu,cfname,head,data,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - character*(*),intent(in):: cfname - type(sigio_head),intent(inout):: head - type(sigio_data),intent(in):: data - integer(sigio_intkind),intent(out):: iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_rwopen(lu,cfname,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_rwhead(lu,head,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_rwdata(lu,head,data,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_rclose(lu,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_rrdats(lu,head,dats,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - type(sigio_head),intent(in):: head - type(sigio_dats),intent(inout):: dats - integer(sigio_intkind),intent(out):: iret - integer:: i - integer:: nc,mdim1 - integer:: iskip,iread,nread - type(sigio_dbts):: dbts -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - mdim1=min(size(dats%hs,1),size(dats%ps,1)) - nc=(head%jcap+1)*(head%jcap+2) - iret=-5 - if(mdim1.lt.nc) return - iret=-4 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(head%irealf.ne.2) then - iskip=0 - do i=1,head%nhead - call bafrindex(0,iskip,head%lhead(i),iskip) - enddo - i=1 - iread=head%ldata(i) - call bafrread(lu,iskip,iread,nread,dats%hs) - if(nread.lt.iread) return - i=i+1 - iskip=iskip+nread - iread=head%ldata(i) - call bafrread(lu,iskip,iread,nread,dats%ps) - if(nread.lt.iread) return - else - call sigio_aldbts(head,dbts,iret) - if(iret.ne.0) return - call sigio_rrdbts(lu,head,dbts,iret) - if(iret.ne.0) return - dats%hs(:nc)=dbts%hs(:nc) - dats%ps(:nc)=dbts%ps(:nc) - call sigio_axdbts(dbts,iret) - endif - iret=0 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_rwdats(lu,head,dats,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - type(sigio_head),intent(in):: head - type(sigio_dats),intent(in):: dats - integer(sigio_intkind),intent(out):: iret - integer:: i - integer:: nc,mdim1 - integer:: iskip,iwrite,nwrite - type(sigio_dbts):: dbts -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - mdim1=min(size(dats%hs,1),size(dats%ps,1)) - nc=(head%jcap+1)*(head%jcap+2) - iret=-5 - if(mdim1.lt.nc) return - iret=-4 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(head%irealf.ne.2) then - iskip=0 - do i=1,head%nhead - call bafrindex(0,iskip,head%lhead(i),iskip) - enddo - i=1 - iwrite=head%ldata(i) - call bafrwrite(lu,iskip,iwrite,nwrite,dats%hs) - if(nwrite.lt.iwrite) return - i=i+1 - iskip=iskip+nwrite - iwrite=head%ldata(i) - call bafrwrite(lu,iskip,iwrite,nwrite,dats%ps) - if(nwrite.lt.iwrite) return - else - call sigio_aldbts(head,dbts,iret) - if(iret.ne.0) return - dbts%hs(:nc)=dats%hs(:nc) - dbts%ps(:nc)=dats%ps(:nc) - call sigio_rwdbts(lu,head,dbts,iret) - if(iret.ne.0) return - call sigio_axdbts(dbts,iret) - endif - iret=0 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_rrdatm(lu,head,datm,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - type(sigio_head),intent(in):: head - type(sigio_datm),intent(inout):: datm - integer(sigio_intkind),intent(out):: iret - integer:: i,k,n - integer:: nc,k1,k2,mdim1,ldim2,udim2,mdim3q - integer:: iskip,iread,nread - type(sigio_dbtm):: dbtm -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - k1=datm%k1 - k2=datm%k2 - mdim1=min(size(datm%t,1),size(datm%d,1),size(datm%z,1),& - size(datm%q,1)) - ldim2=max(lbound(datm%t,2),lbound(datm%d,2),lbound(datm%z,2),& - lbound(datm%q,2)) - udim2=min(ubound(datm%t,2),ubound(datm%d,2),ubound(datm%z,2),& - ubound(datm%q,2)) - mdim3q=size(datm%q,3) - nc=(head%jcap+1)*(head%jcap+2) - iret=-5 - if(k1.lt.1.or.k2.gt.head%levs.or.& - mdim1.lt.nc.or.& - ldim2.gt.k1.or.udim2.lt.k2.or.& - mdim3q.lt.head%ntrac) return - iret=-4 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(head%irealf.ne.2) then - iskip=0 - do i=1,head%nhead - call bafrindex(0,iskip,head%lhead(i),iskip) - enddo - i=1 - call bafrindex(0,iskip,head%ldata(i),iskip) - i=i+1 - call bafrindex(0,iskip,head%ldata(i),iskip) - do k=1,head%levs - if(k.lt.k1.or.k.gt.k2) then - i=i+1 - call bafrindex(0,iskip,head%ldata(i),iskip) - else - i=i+1 - iread=head%ldata(i) - call bafrread(lu,iskip,iread,nread,datm%t(1,k)) - if(nread.lt.iread) return - iskip=iskip+nread - endif - enddo - do k=1,head%levs - if(k.lt.k1.or.k.gt.k2) then - i=i+1 - call bafrindex(0,iskip,head%ldata(i),iskip) - i=i+1 - call bafrindex(0,iskip,head%ldata(i),iskip) - else - iread=head%ldata(i) - call bafrread(lu,iskip,iread,nread,datm%d(1,k)) - if(nread.lt.iread) return - iskip=iskip+nread - iread=head%ldata(i) - call bafrread(lu,iskip,iread,nread,datm%z(1,k)) - if(nread.lt.iread) return - iskip=iskip+nread - endif - enddo - do n=1,head%ntrac - do k=1,head%levs - if(k.lt.k1.or.k.gt.k2) then - i=i+1 - call bafrindex(0,iskip,head%ldata(i),iskip) - else - i=i+1 - iread=head%ldata(i) - call bafrread(lu,iskip,iread,nread,datm%q(1,k,n)) - if(nread.lt.iread) return - iskip=iskip+nread - endif - enddo - enddo - else - call sigio_aldbtm(head,k1,k2,dbtm,iret) - if(iret.ne.0) return - call sigio_rrdbtm(lu,head,dbtm,iret) - if(iret.ne.0) return - datm%t(:nc,k1:k2)=dbtm%t(:nc,k1:k2) - datm%d(:nc,k1:k2)=dbtm%d(:nc,k1:k2) - datm%z(:nc,k1:k2)=dbtm%z(:nc,k1:k2) - datm%q(:nc,k1:k2,:head%ntrac)=dbtm%q(:nc,k1:k2,:head%ntrac) - call sigio_axdbtm(dbtm,iret) - endif - iret=0 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_rwdatm(lu,head,datm,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - type(sigio_head),intent(in):: head - type(sigio_datm),intent(in):: datm - integer(sigio_intkind),intent(out):: iret - integer:: i,k,n - integer:: nc,k1,k2,mdim1,ldim2,udim2,mdim3q - integer:: iskip,iwrite,nwrite - type(sigio_dbtm):: dbtm -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - k1=datm%k1 - k2=datm%k2 - mdim1=min(size(datm%t,1),size(datm%d,1),size(datm%z,1),& - size(datm%q,1)) - ldim2=max(lbound(datm%t,2),lbound(datm%d,2),lbound(datm%z,2),& - lbound(datm%q,2)) - udim2=min(ubound(datm%t,2),ubound(datm%d,2),ubound(datm%z,2),& - ubound(datm%q,2)) - mdim3q=size(datm%q,3) - nc=(head%jcap+1)*(head%jcap+2) - iret=-5 - if(k1.lt.1.or.k2.gt.head%levs.or.& - mdim1.lt.nc.or.& - ldim2.gt.k1.or.udim2.lt.k2.or.& - mdim3q.lt.head%ntrac) return - iret=-4 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(head%irealf.ne.2) then - iskip=0 - do i=1,head%nhead - call bafrindex(0,iskip,head%lhead(i),iskip) - enddo - i=1 - call bafrindex(0,iskip,head%ldata(i),iskip) - i=i+1 - call bafrindex(0,iskip,head%ldata(i),iskip) - do k=1,head%levs - if(k.lt.k1.or.k.gt.k2) then - i=i+1 - call bafrindex(0,iskip,head%ldata(i),iskip) - else - i=i+1 - iwrite=head%ldata(i) - call bafrwrite(lu,iskip,iwrite,nwrite,datm%t(1,k)) - if(nwrite.lt.iwrite) return - iskip=iskip+nwrite - endif - enddo - do k=1,head%levs - if(k.lt.k1.or.k.gt.k2) then - i=i+1 - call bafrindex(0,iskip,head%ldata(i),iskip) - i=i+1 - call bafrindex(0,iskip,head%ldata(i),iskip) - else - iwrite=head%ldata(i) - call bafrwrite(lu,iskip,iwrite,nwrite,datm%d(1,k)) - if(nwrite.lt.iwrite) return - iskip=iskip+nwrite - iwrite=head%ldata(i) - call bafrwrite(lu,iskip,iwrite,nwrite,datm%z(1,k)) - if(nwrite.lt.iwrite) return - iskip=iskip+nwrite - endif - enddo - do n=1,head%ntrac - do k=1,head%levs - if(k.lt.k1.or.k.gt.k2) then - i=i+1 - call bafrindex(0,iskip,head%ldata(i),iskip) - else - i=i+1 - iwrite=head%ldata(i) - call bafrwrite(lu,iskip,iwrite,nwrite,datm%q(1,k,n)) - if(nwrite.lt.iwrite) return - iskip=iskip+nwrite - endif - enddo - enddo - else - call sigio_aldbtm(head,k1,k2,dbtm,iret) - if(iret.ne.0) return - dbtm%t(:nc,k1:k2)=datm%t(:nc,k1:k2) - dbtm%d(:nc,k1:k2)=datm%d(:nc,k1:k2) - dbtm%z(:nc,k1:k2)=datm%z(:nc,k1:k2) - dbtm%q(:nc,k1:k2,:head%ntrac)=datm%q(:nc,k1:k2,:head%ntrac) - call sigio_rwdbtm(lu,head,dbtm,iret) - if(iret.ne.0) return - call sigio_axdbtm(dbtm,iret) - endif - iret=0 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_rrdati(lu,head,dati,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - type(sigio_head),intent(in):: head - type(sigio_dati),intent(inout):: dati - integer(sigio_intkind),intent(out):: iret - integer:: i,k,n - integer:: mdim1 - integer:: mlen - integer:: iskip,iread,nread - type(sigio_dbti):: dbti -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - i=dati%i - mdim1=size(dati%f,1) - iret=-5 - if(i.lt.1.or.i.gt.head%ndata) return - mlen=head%ldata(i)/(4*head%irealf) - if(mdim1.lt.mlen) return - iret=-4 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(head%irealf.ne.2) then - iskip=0 - do i=1,head%nhead - call bafrindex(0,iskip,head%lhead(i),iskip) - enddo - do i=1,dati%i-1 - call bafrindex(0,iskip,head%ldata(i),iskip) - enddo - i=dati%i - iread=head%ldata(i) - call bafrread(lu,iskip,iread,nread,dati%f) - if(nread.lt.iread) return - else - i=dati%i - call sigio_aldbti(head,i,dbti,iret) - if(iret.ne.0) return - call sigio_rrdbti(lu,head,dbti,iret) - if(iret.ne.0) return - dati%f(:mlen)=dbti%f(:mlen) - call sigio_axdbti(dbti,iret) - endif - iret=0 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_rwdati(lu,head,dati,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - type(sigio_head),intent(in):: head - type(sigio_dati),intent(in):: dati - integer(sigio_intkind),intent(out):: iret - integer:: i,k,n - integer:: mdim1 - integer:: mlen - integer:: iskip,iwrite,nwrite - type(sigio_dbti):: dbti -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - i=dati%i - mdim1=size(dati%f,1) - iret=-5 - if(i.lt.1.or.i.gt.head%ndata) return - mlen=head%ldata(i)/(4*head%irealf) - if(mdim1.lt.mlen) return - iret=-4 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(head%irealf.ne.2) then - iskip=0 - do i=1,head%nhead - call bafrindex(0,iskip,head%lhead(i),iskip) - enddo - do i=1,dati%i-1 - call bafrindex(0,iskip,head%ldata(i),iskip) - enddo - i=dati%i - iwrite=head%ldata(i) - call bafrwrite(lu,iskip,iwrite,nwrite,dati%f) - if(nwrite.lt.iwrite) return - iret=0 - else - i=dati%i - call sigio_aldbti(head,i,dbti,iret) - if(iret.ne.0) return - dbti%f(:mlen)=dati%f(:mlen) - call sigio_rwdbti(lu,head,dbti,iret) - if(iret.ne.0) return - call sigio_axdbti(dbti,iret) - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_aldbts(head,dbts,iret) - implicit none - type(sigio_head),intent(in):: head - type(sigio_dbts),intent(inout):: dbts - integer(sigio_intkind),intent(out):: iret - integer nc,dim1 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_axdbts(dbts,iret) - nc=(head%jcap+1)*(head%jcap+2) - dim1=nc - allocate(dbts%hs(dim1),dbts%ps(dim1),stat=iret) - if(iret.ne.0) iret=-3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_axdbts(dbts,iret) - implicit none - type(sigio_dbts),intent(inout):: dbts - integer(sigio_intkind),intent(out):: iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - deallocate(dbts%hs,dbts%ps,stat=iret) - nullify(dbts%hs,dbts%ps) - if(iret.ne.0) iret=-3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_aldbtm(head,k1,k2,dbtm,iret) - implicit none - type(sigio_head),intent(in):: head - integer(sigio_intkind),intent(in):: k1,k2 - type(sigio_dbtm),intent(inout):: dbtm - integer(sigio_intkind),intent(out):: iret - integer nc,dim1,dim3q -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_axdbtm(dbtm,iret) - iret=-3 - if(k1.lt.1.or.k2.gt.head%levs) return - nc=(head%jcap+1)*(head%jcap+2) - dim1=nc - dim3q=head%ntrac - dbtm%k1=k1 - dbtm%k2=k2 - allocate(dbtm%t(dim1,k1:k2),dbtm%d(dim1,k1:k2),dbtm%z(dim1,k1:k2),& - dbtm%q(dim1,k1:k2,dim3q),stat=iret) - if(iret.ne.0) iret=-3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_axdbtm(dbtm,iret) - implicit none - type(sigio_dbtm),intent(inout):: dbtm - integer(sigio_intkind),intent(out):: iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - dbtm%k1=0 - dbtm%k2=0 - deallocate(dbtm%t,dbtm%d,dbtm%z,dbtm%q,stat=iret) - nullify(dbtm%t,dbtm%d,dbtm%z,dbtm%q) - if(iret.ne.0) iret=-3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_aldbti(head,i,dbti,iret) - implicit none - type(sigio_head),intent(in):: head - integer(sigio_intkind),intent(in):: i - type(sigio_dbti),intent(inout):: dbti - integer(sigio_intkind),intent(out):: iret - integer dim1 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_axdbti(dbti,iret) - iret=-3 - if(i.lt.1.or.i.gt.head%ndata) return - dim1=head%ldata(i)/(4*head%irealf) - dbti%i=i - allocate(dbti%f(dim1),stat=iret) - if(iret.ne.0) iret=-3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_axdbti(dbti,iret) - implicit none - type(sigio_dbti),intent(inout):: dbti - integer(sigio_intkind),intent(out):: iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - dbti%i=0 - deallocate(dbti%f,stat=iret) - nullify(dbti%f) - if(iret.ne.0) iret=-3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_rrdbta(lu,head,dbta,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - type(sigio_head),intent(in):: head - type(sigio_dbta),intent(inout):: dbta - integer(sigio_intkind),intent(out):: iret - integer:: i,k,n - integer:: nc,mdim1,mdim2,mdim3q - integer:: iskip,iread,nread - type(sigio_data):: data -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - mdim1=min(size(dbta%hs,1),size(dbta%ps,1),& - size(dbta%t,1),size(dbta%d,1),size(dbta%z,1),& - size(dbta%q,1)) - mdim2=min(size(dbta%t,2),size(dbta%d,2),size(dbta%z,2),& - size(dbta%q,2)) - mdim3q=size(dbta%q,3) - nc=(head%jcap+1)*(head%jcap+2) - iret=-5 - if(mdim1.lt.nc.or.& - mdim2.lt.head%levs.or.& - mdim3q.lt.head%ntrac) return - iret=-4 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(head%irealf.eq.2) then - iskip=0 - do i=1,head%nhead - call bafrindex(0,iskip,head%lhead(i),iskip) - enddo - i=1 - iread=head%ldata(i) - call bafrread(lu,iskip,iread,nread,dbta%hs) - if(nread.lt.iread) return - i=i+1 - iskip=iskip+nread - iread=head%ldata(i) - call bafrread(lu,iskip,iread,nread,dbta%ps) - if(nread.lt.iread) return - do k=1,head%levs - i=i+1 - iskip=iskip+nread - iread=head%ldata(i) - call bafrread(lu,iskip,iread,nread,dbta%t(1,k)) - if(nread.lt.iread) return - enddo - do k=1,head%levs - i=i+1 - iskip=iskip+nread - iread=head%ldata(i) - call bafrread(lu,iskip,iread,nread,dbta%d(1,k)) - if(nread.lt.iread) return - i=i+1 - iskip=iskip+nread - iread=head%ldata(i) - call bafrread(lu,iskip,iread,nread,dbta%z(1,k)) - if(nread.lt.iread) return - enddo - do n=1,head%ntrac - do k=1,head%levs - i=i+1 - iskip=iskip+nread - iread=head%ldata(i) - call bafrread(lu,iskip,iread,nread,dbta%q(1,k,n)) - if(nread.lt.iread) return - enddo - enddo - do n=1,head%nxgr - i=i+1 - iskip=iskip+nread - iread=head%ldata(i) - call bafrread(lu,iskip,iread,nread,dbta%xgr(1,1,n)) - if(nread.lt.iread) return - enddo - if(head%nxss.gt.0) then - i=i+1 - iskip=iskip+nread - iread=head%ldata(i) - call bafrread(lu,iskip,iread,nread,dbta%xss) - if(nread.lt.iread) return - endif - else - call sigio_aldata(head,data,iret) - if(iret.ne.0) return - call sigio_rrdata(lu,head,data,iret) - if(iret.ne.0) return - dbta%hs(:nc)=data%hs(:nc) - dbta%ps(:nc)=data%ps(:nc) - dbta%t(:nc,:head%levs)=data%t(:nc,:head%levs) - dbta%d(:nc,:head%levs)=data%d(:nc,:head%levs) - dbta%z(:nc,:head%levs)=data%z(:nc,:head%levs) - dbta%q(:nc,:head%levs,:head%ntrac)=data%q(:nc,:head%levs,:head%ntrac) - dbta%xgr(:head%lonb,:head%latb,:head%nxgr)=& - data%xgr(:head%lonb,:head%latb,:head%nxgr) - dbta%xss(:head%nxss)=data%xss(:head%nxss) - call sigio_axdata(data,iret) - endif - iret=0 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_rwdbta(lu,head,dbta,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - type(sigio_head),intent(in):: head - type(sigio_dbta),intent(in):: dbta - integer(sigio_intkind),intent(out):: iret - integer:: i,k,n - integer:: nc,mdim1,mdim2,mdim3q - integer:: iskip,iwrite,nwrite - type(sigio_data):: data -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - mdim1=min(size(dbta%hs,1),size(dbta%ps,1),& - size(dbta%t,1),size(dbta%d,1),size(dbta%z,1),& - size(dbta%q,1)) - mdim2=min(size(dbta%t,2),size(dbta%d,2),size(dbta%z,2),& - size(dbta%q,2)) - mdim3q=size(dbta%q,3) - nc=(head%jcap+1)*(head%jcap+2) - iret=-5 - if(mdim1.lt.nc.or.& - mdim2.lt.head%levs.or.& - mdim3q.lt.head%ntrac) return - iret=-4 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(head%irealf.eq.2) then - iskip=0 - do i=1,head%nhead - call bafrindex(0,iskip,head%lhead(i),iskip) - enddo - i=1 - iwrite=head%ldata(i) - call bafrwrite(lu,iskip,iwrite,nwrite,dbta%hs) - if(nwrite.lt.iwrite) return - i=i+1 - iskip=iskip+nwrite - iwrite=head%ldata(i) - call bafrwrite(lu,iskip,iwrite,nwrite,dbta%ps) - if(nwrite.lt.iwrite) return - do k=1,head%levs - i=i+1 - iskip=iskip+nwrite - iwrite=head%ldata(i) - call bafrwrite(lu,iskip,iwrite,nwrite,dbta%t(1,k)) - if(nwrite.lt.iwrite) return - enddo - do k=1,head%levs - i=i+1 - iskip=iskip+nwrite - iwrite=head%ldata(i) - call bafrwrite(lu,iskip,iwrite,nwrite,dbta%d(1,k)) - if(nwrite.lt.iwrite) return - i=i+1 - iskip=iskip+nwrite - iwrite=head%ldata(i) - call bafrwrite(lu,iskip,iwrite,nwrite,dbta%z(1,k)) - if(nwrite.lt.iwrite) return - enddo - do n=1,head%ntrac - do k=1,head%levs - i=i+1 - iskip=iskip+nwrite - iwrite=head%ldata(i) - call bafrwrite(lu,iskip,iwrite,nwrite,dbta%q(1,k,n)) - if(nwrite.lt.iwrite) return - enddo - enddo - do n=1,head%nxgr - i=i+1 - iskip=iskip+nwrite - iwrite=head%ldata(i) - call bafrwrite(lu,iskip,iwrite,nwrite,dbta%xgr(1,1,n)) - if(nwrite.lt.iwrite) return - enddo - if(head%nxss.gt.0) then - i=i+1 - iskip=iskip+nwrite - iwrite=head%ldata(i) - call bafrwrite(lu,iskip,iwrite,nwrite,dbta%xss) - if(nwrite.lt.iwrite) return - endif - else - call sigio_aldata(head,data,iret) - if(iret.ne.0) return - data%hs(:nc)=dbta%hs(:nc) - data%ps(:nc)=dbta%ps(:nc) - data%t(:nc,:head%levs)=dbta%t(:nc,:head%levs) - data%d(:nc,:head%levs)=dbta%d(:nc,:head%levs) - data%z(:nc,:head%levs)=dbta%z(:nc,:head%levs) - data%q(:nc,:head%levs,:head%ntrac)=dbta%q(:nc,:head%levs,:head%ntrac) - data%xgr(:head%lonb,:head%latb,:head%nxgr)=& - dbta%xgr(:head%lonb,:head%latb,:head%nxgr) - data%xss(:head%nxss)=dbta%xss(:head%nxss) - call sigio_rwdata(lu,head,data,iret) - if(iret.ne.0) return - call sigio_axdata(data,iret) - endif - iret=0 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_rrohdcb(lu,cfname,head,dbta,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - character*(*),intent(in):: cfname - type(sigio_head),intent(inout):: head - type(sigio_dbta),intent(inout):: dbta - integer(sigio_intkind),intent(out):: iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_rropen(lu,cfname,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_rrhead(lu,head,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_aldbta(head,dbta,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_rrdbta(lu,head,dbta,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_rclose(lu,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_rwohdcb(lu,cfname,head,dbta,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - character*(*),intent(in):: cfname - type(sigio_head),intent(inout):: head - type(sigio_dbta),intent(in):: dbta - integer(sigio_intkind),intent(out):: iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_rwopen(lu,cfname,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_rwhead(lu,head,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_rwdbta(lu,head,dbta,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_rclose(lu,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_rrdbts(lu,head,dbts,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - type(sigio_head),intent(in):: head - type(sigio_dbts),intent(inout):: dbts - integer(sigio_intkind),intent(out):: iret - integer:: i - integer:: nc,mdim1 - integer:: iskip,iread,nread - type(sigio_dats):: dats -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - mdim1=min(size(dbts%hs,1),size(dbts%ps,1)) - nc=(head%jcap+1)*(head%jcap+2) - iret=-5 - if(mdim1.lt.nc) return - iret=-4 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(head%irealf.eq.2) then - iskip=0 - do i=1,head%nhead - call bafrindex(0,iskip,head%lhead(i),iskip) - enddo - i=1 - iread=head%ldata(i) - call bafrread(lu,iskip,iread,nread,dbts%hs) - if(nread.lt.iread) return - i=i+1 - iskip=iskip+nread - iread=head%ldata(i) - call bafrread(lu,iskip,iread,nread,dbts%ps) - if(nread.lt.iread) return - else - call sigio_aldats(head,dats,iret) - if(iret.ne.0) return - call sigio_rrdats(lu,head,dats,iret) - if(iret.ne.0) return - dbts%hs(:nc)=dats%hs(:nc) - dbts%ps(:nc)=dats%ps(:nc) - call sigio_axdats(dats,iret) - endif - iret=0 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_rwdbts(lu,head,dbts,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - type(sigio_head),intent(in):: head - type(sigio_dbts),intent(in):: dbts - integer(sigio_intkind),intent(out):: iret - integer:: i - integer:: nc,mdim1 - integer:: iskip,iwrite,nwrite - type(sigio_dats):: dats -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - mdim1=min(size(dbts%hs,1),size(dbts%ps,1)) - nc=(head%jcap+1)*(head%jcap+2) - iret=-5 - if(mdim1.lt.nc) return - iret=-4 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(head%irealf.eq.2) then - iskip=0 - do i=1,head%nhead - call bafrindex(0,iskip,head%lhead(i),iskip) - enddo - i=1 - iwrite=head%ldata(i) - call bafrwrite(lu,iskip,iwrite,nwrite,dbts%hs) - if(nwrite.lt.iwrite) return - i=i+1 - iskip=iskip+nwrite - iwrite=head%ldata(i) - call bafrwrite(lu,iskip,iwrite,nwrite,dbts%ps) - if(nwrite.lt.iwrite) return - else - call sigio_aldats(head,dats,iret) - if(iret.ne.0) return - dats%hs(:nc)=dbts%hs(:nc) - dats%ps(:nc)=dbts%ps(:nc) - call sigio_rwdats(lu,head,dats,iret) - if(iret.ne.0) return - call sigio_axdats(dats,iret) - endif - iret=0 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_rrdbtm(lu,head,dbtm,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - type(sigio_head),intent(in):: head - type(sigio_dbtm),intent(inout):: dbtm - integer(sigio_intkind),intent(out):: iret - integer:: i,k,n - integer:: nc,k1,k2,mdim1,ldim2,udim2,mdim3q - integer:: iskip,iread,nread - type(sigio_datm):: datm -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - k1=dbtm%k1 - k2=dbtm%k2 - mdim1=min(size(dbtm%t,1),size(dbtm%d,1),size(dbtm%z,1),& - size(dbtm%q,1)) - ldim2=max(lbound(dbtm%t,2),lbound(dbtm%d,2),lbound(dbtm%z,2),& - lbound(dbtm%q,2)) - udim2=min(ubound(dbtm%t,2),ubound(dbtm%d,2),ubound(dbtm%z,2),& - ubound(dbtm%q,2)) - mdim3q=size(dbtm%q,3) - nc=(head%jcap+1)*(head%jcap+2) - iret=-5 - if(k1.lt.1.or.k2.gt.head%levs.or.& - mdim1.lt.nc.or.& - ldim2.gt.k1.or.udim2.lt.k2.or.& - mdim3q.lt.head%ntrac) return - iret=-4 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(head%irealf.eq.2) then - iskip=0 - do i=1,head%nhead - call bafrindex(0,iskip,head%lhead(i),iskip) - enddo - i=1 - call bafrindex(0,iskip,head%ldata(i),iskip) - i=i+1 - call bafrindex(0,iskip,head%ldata(i),iskip) - do k=1,head%levs - if(k.lt.k1.or.k.gt.k2) then - i=i+1 - call bafrindex(0,iskip,head%ldata(i),iskip) - else - i=i+1 - iread=head%ldata(i) - call bafrread(lu,iskip,iread,nread,dbtm%t(1,k)) - if(nread.lt.iread) return - iskip=iskip+nread - endif - enddo - do k=1,head%levs - if(k.lt.k1.or.k.gt.k2) then - i=i+1 - call bafrindex(0,iskip,head%ldata(i),iskip) - i=i+1 - call bafrindex(0,iskip,head%ldata(i),iskip) - else - iread=head%ldata(i) - call bafrread(lu,iskip,iread,nread,dbtm%d(1,k)) - if(nread.lt.iread) return - iskip=iskip+nread - iread=head%ldata(i) - call bafrread(lu,iskip,iread,nread,dbtm%z(1,k)) - if(nread.lt.iread) return - iskip=iskip+nread - endif - enddo - do n=1,head%ntrac - do k=1,head%levs - if(k.lt.k1.or.k.gt.k2) then - i=i+1 - call bafrindex(0,iskip,head%ldata(i),iskip) - else - i=i+1 - iread=head%ldata(i) - call bafrread(lu,iskip,iread,nread,dbtm%q(1,k,n)) - if(nread.lt.iread) return - iskip=iskip+nread - endif - enddo - enddo - else - call sigio_aldatm(head,k1,k2,datm,iret) - if(iret.ne.0) return - call sigio_rrdatm(lu,head,datm,iret) - if(iret.ne.0) return - dbtm%t(:nc,k1:k2)=datm%t(:nc,k1:k2) - dbtm%d(:nc,k1:k2)=datm%d(:nc,k1:k2) - dbtm%z(:nc,k1:k2)=datm%z(:nc,k1:k2) - dbtm%q(:nc,k1:k2,:head%ntrac)=datm%q(:nc,k1:k2,:head%ntrac) - call sigio_axdatm(datm,iret) - endif - iret=0 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_rwdbtm(lu,head,dbtm,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - type(sigio_head),intent(in):: head - type(sigio_dbtm),intent(in):: dbtm - integer(sigio_intkind),intent(out):: iret - integer:: i,k,n - integer:: nc,k1,k2,mdim1,ldim2,udim2,mdim3q - integer:: iskip,iwrite,nwrite - type(sigio_datm):: datm -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - k1=dbtm%k1 - k2=dbtm%k2 - mdim1=min(size(dbtm%t,1),size(dbtm%d,1),size(dbtm%z,1),& - size(dbtm%q,1)) - ldim2=max(lbound(dbtm%t,2),lbound(dbtm%d,2),lbound(dbtm%z,2),& - lbound(dbtm%q,2)) - udim2=min(ubound(dbtm%t,2),ubound(dbtm%d,2),ubound(dbtm%z,2),& - ubound(dbtm%q,2)) - mdim3q=size(dbtm%q,3) - nc=(head%jcap+1)*(head%jcap+2) - iret=-5 - if(k1.lt.1.or.k2.gt.head%levs.or.& - mdim1.lt.nc.or.& - ldim2.gt.k1.or.udim2.lt.k2.or.& - mdim3q.lt.head%ntrac) return - iret=-4 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(head%irealf.eq.2) then - iskip=0 - do i=1,head%nhead - call bafrindex(0,iskip,head%lhead(i),iskip) - enddo - i=1 - call bafrindex(0,iskip,head%ldata(i),iskip) - i=i+1 - call bafrindex(0,iskip,head%ldata(i),iskip) - do k=1,head%levs - if(k.lt.k1.or.k.gt.k2) then - i=i+1 - call bafrindex(0,iskip,head%ldata(i),iskip) - else - i=i+1 - iwrite=head%ldata(i) - call bafrwrite(lu,iskip,iwrite,nwrite,dbtm%t(1,k)) - if(nwrite.lt.iwrite) return - iskip=iskip+nwrite - endif - enddo - do k=1,head%levs - if(k.lt.k1.or.k.gt.k2) then - i=i+1 - call bafrindex(0,iskip,head%ldata(i),iskip) - i=i+1 - call bafrindex(0,iskip,head%ldata(i),iskip) - else - iwrite=head%ldata(i) - call bafrwrite(lu,iskip,iwrite,nwrite,dbtm%d(1,k)) - if(nwrite.lt.iwrite) return - iskip=iskip+nwrite - iwrite=head%ldata(i) - call bafrwrite(lu,iskip,iwrite,nwrite,dbtm%z(1,k)) - if(nwrite.lt.iwrite) return - iskip=iskip+nwrite - endif - enddo - do n=1,head%ntrac - do k=1,head%levs - if(k.lt.k1.or.k.gt.k2) then - i=i+1 - call bafrindex(0,iskip,head%ldata(i),iskip) - else - i=i+1 - iwrite=head%ldata(i) - call bafrwrite(lu,iskip,iwrite,nwrite,dbtm%q(1,k,n)) - if(nwrite.lt.iwrite) return - iskip=iskip+nwrite - endif - enddo - enddo - else - call sigio_aldatm(head,k1,k2,datm,iret) - if(iret.ne.0) return - datm%t(:nc,k1:k2)=dbtm%t(:nc,k1:k2) - datm%d(:nc,k1:k2)=dbtm%d(:nc,k1:k2) - datm%z(:nc,k1:k2)=dbtm%z(:nc,k1:k2) - datm%q(:nc,k1:k2,:head%ntrac)=dbtm%q(:nc,k1:k2,:head%ntrac) - call sigio_rwdatm(lu,head,datm,iret) - if(iret.ne.0) return - call sigio_axdatm(datm,iret) - endif - iret=0 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_rrdbti(lu,head,dbti,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - type(sigio_head),intent(in):: head - type(sigio_dbti),intent(inout):: dbti - integer(sigio_intkind),intent(out):: iret - integer:: i,k,n - integer:: mdim1 - integer:: mlen - integer:: iskip,iread,nread - type(sigio_dati):: dati -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - i=dbti%i - mdim1=size(dbti%f,1) - iret=-5 - if(i.lt.1.or.i.gt.head%ndata) return - mlen=head%ldata(i)/(4*head%irealf) - if(mdim1.lt.mlen) return - iret=-4 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(head%irealf.eq.2) then - iskip=0 - do i=1,head%nhead - call bafrindex(0,iskip,head%lhead(i),iskip) - enddo - do i=1,dbti%i-1 - call bafrindex(0,iskip,head%ldata(i),iskip) - enddo - i=dbti%i - iread=head%ldata(i) - call bafrread(lu,iskip,iread,nread,dbti%f) - if(nread.lt.iread) return - else - i=dbti%i - call sigio_aldati(head,i,dati,iret) - if(iret.ne.0) return - call sigio_rrdati(lu,head,dati,iret) - if(iret.ne.0) return - dbti%f(:mlen)=dati%f(:mlen) - call sigio_axdati(dati,iret) - endif - iret=0 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine sigio_rwdbti(lu,head,dbti,iret) - implicit none - integer(sigio_intkind),intent(in):: lu - type(sigio_head),intent(in):: head - type(sigio_dbti),intent(in):: dbti - integer(sigio_intkind),intent(out):: iret - integer:: i,k,n - integer:: mdim1 - integer:: mlen - integer:: iskip,iwrite,nwrite - type(sigio_dati):: dati -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - i=dbti%i - mdim1=size(dbti%f,1) - iret=-5 - if(i.lt.1.or.i.gt.head%ndata) return - mlen=head%ldata(i)/(4*head%irealf) - if(mdim1.lt.mlen) return - iret=-4 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(head%irealf.eq.2) then - iskip=0 - do i=1,head%nhead - call bafrindex(0,iskip,head%lhead(i),iskip) - enddo - do i=1,dbti%i-1 - call bafrindex(0,iskip,head%ldata(i),iskip) - enddo - i=dbti%i - iwrite=head%ldata(i) - call bafrwrite(lu,iskip,iwrite,nwrite,dbti%f) - if(nwrite.lt.iwrite) return - else - i=dbti%i - call sigio_aldati(head,i,dati,iret) - if(iret.ne.0) return - dati%f(:mlen)=dbti%f(:mlen) - call sigio_rwdati(lu,head,dati,iret) - if(iret.ne.0) return - call sigio_axdati(dati,iret) - endif - iret=0 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- -end module diff --git a/src/fim/FIMsrc/prep/slint/Makefile b/src/fim/FIMsrc/prep/slint/Makefile deleted file mode 100644 index a3ee553..0000000 --- a/src/fim/FIMsrc/prep/slint/Makefile +++ /dev/null @@ -1,46 +0,0 @@ -# slint Makefile - -SHELL = /bin/sh - -include ../../macros.make - -FLAGS = $(FFLAGS) -LIBSYSSHARE = $(LIBDIR)/libsysshare.a -SLINTEXE = $(BINDIR)/slint -SLINTLIB = $(LIBDIR)/libslint.a -INCMOD = ../incmod -FLAGS = $(FFLAGS) -I$(INCMOD) - -#JR: Blank out all suffix rules. Mac does some weird .s stuff without it. - -.SUFFIXES: -.SUFFIXES: .F90 .o - -#JR If OPTFLAGS not empty, hopefully compiler will override contradictory FFLAGS settings -.F90.o: - $(FC) $(FLAGS) $(OPTFLAGS) -c $< - -KDOBJ = kd.o -SLINTOBJ = slint.o - -all: $(SLINTLIB) $(SLINTEXE) - -$(SLINTLIB): DEPENDENCIES $(KDOBJ) $(SLINTOBJ) - $(AR) ruv $(SLINTLIB) $(SLINTOBJ) $(KDOBJ) - mv -f *.mod $(INCMOD) - -$(SLINTEXE): DEPENDENCIES slintest.o $(SLINTLIB) - $(FC) $(FLAGS) -o $(SLINTEXE) slintest.o $(SLINTLIB) $(LIBSYSSHARE) - -DEPENDENCIES: - $(RM) -f Filepath Srcfiles - echo "." > Filepath - ls -1 *.F90 > Srcfiles - $(MKDEPENDS) -m Filepath Srcfiles > $@ - --include DEPENDENCIES - -clean: - $(RM) *.o *.mod *_cpp.F90 DEPENDENCIES - -# Ning Wang, Feb 2006 diff --git a/src/fim/FIMsrc/prep/slint/README b/src/fim/FIMsrc/prep/slint/README deleted file mode 100644 index 252591d..0000000 --- a/src/fim/FIMsrc/prep/slint/README +++ /dev/null @@ -1,8 +0,0 @@ - -bilinear_init(grid_file1, n1, grid_file2, n2) -INTEGER :: n1, n2 -CHARACTER *(*) :: grid_file1, grid_file2 - -bilinear_interp (grid1, grid2) -REAL grid1(n1), grid2(n2) - diff --git a/src/fim/FIMsrc/prep/slint/ints_test.F90 b/src/fim/FIMsrc/prep/slint/ints_test.F90 deleted file mode 100644 index 634e90d..0000000 --- a/src/fim/FIMsrc/prep/slint/ints_test.F90 +++ /dev/null @@ -1,27 +0,0 @@ - PROGRAM ints_test - - REAL*8 p1(2), p2(2), p3(2), p4(2), p(2) - - REAL*8 d2r, r2d - - d2r = 4.0 * atan(1.0) / 180.0 - r2d = 1.0 / d2r - - p1(1) = 10.0 * d2r - p1(2) = 30.0 * d2r - p2(1) = 10.0 * d2r - p2(2) = 60.0 * d2r - - p3(1) = 30.0 * d2r - p3(2) = 40.0 * d2r - p4(1) = 12.00 * d2r - p4(2) = 60.0 * d2r - - - CALL intersection(p1, p2, p3, p4, p) - - PRINT*, p1 * r2d, p2 * r2d - PRINT*, p3 * r2d, p4 * r2d - PRINT*, p * r2d - - END PROGRAM ints_test diff --git a/src/fim/FIMsrc/prep/slint/kd.F90 b/src/fim/FIMsrc/prep/slint/kd.F90 deleted file mode 100644 index 3b56d63..0000000 --- a/src/fim/FIMsrc/prep/slint/kd.F90 +++ /dev/null @@ -1,517 +0,0 @@ -!========================================================================== -! Module for the k-d tree -! -! The algorithm is based on Bentley's optimal k-d tree, plus -! some modifications of mine. The priority queue was omitted -! since the number of nearest neighbors to be searched is -! always relatively small (3-11). -! -! Ning Wang, Nov. 2006: Initial implementation. -! -! Ning Wang, Jul. 2011: Created a new version of the k-d tree, which -! includes following modifications and enhancements. -! a). wrapped kd_datastru.F90 and kd.F90 into one module; -! b). simplified interface to the recursive subroutine SearchRec; -! c). added a new capability to the k-d tree, such that the search -! space can be bounded with a pair of hyper-planes for each -! query (search). -!========================================================================== -MODULE kd - TYPE Node - LOGICAL :: bucket ! true if it is a bucket node -! INTEGER :: npoints ! number of points of the node - INTEGER :: discrim ! discriminant dimension - REAL :: cutval ! the cut value for the space - INTEGER :: lopt ! lower point - INTEGER :: hipt ! high point - TYPE(Node), POINTER :: loson - TYPE(Node), POINTER :: hison - END TYPE Node - - INTEGER n, d, gc, bottom_level, dir, num_k - REAL, ALLOCATABLE :: hp1(:), hp2(:), tc1(:), tc2(:), qry(:) - - TYPE(Node), TARGET, ALLOCATABLE :: nodes(:) - INTEGER, ALLOCATABLE :: perm(:) - INTEGER, TARGET, ALLOCATABLE :: nni(:) - REAL, ALLOCATABLE :: nnd(:) - REAL, ALLOCATABLE :: q2cut(:) - REAL, POINTER:: ppoints(:,:) - TYPE(Node), POINTER :: root - - REAL :: curDistSq, partsum -CONTAINS - -SUBROUTINE BuildTree(num, dim, points) - - IMPLICIT NONE - - INTEGER :: num, dim - REAL, TARGET :: points(dim, num) - INTEGER :: i - - IF (ALLOCATED(nodes)) THEN - DEALLOCATE(nodes) - END IF - IF (ALLOCATED(perm)) THEN - DEALLOCATE(perm) - END IF - IF (ALLOCATED(q2cut).AND.ALLOCATED(hp1).AND.ALLOCATED(hp2)) THEN - DEALLOCATE(q2cut, hp1, hp2) - END IF - IF (ALLOCATED(qry).AND.ALLOCATED(tc1).AND.ALLOCATED(tc2)) THEN - DEALLOCATE(qry, tc1, tc2) - END IF - - ALLOCATE(nodes(2 * num)) - ALLOCATE(perm(num)) - ALLOCATE(q2cut(dim), hp1(dim), hp2(dim)) - ALLOCATE(qry(dim), tc1(dim), tc2(dim)) - - DO i = 1, num - perm(i) = i - END DO - - n = num - d = dim - num_k = 1 - dir = 0 - gc = 1 - - ppoints => points - bottom_level = log(REAL(n)) / log(2.0) + 1 - root => BuildTreeRec(points, 1, n, 1) - -END SUBROUTINE BuildTree - -SUBROUTINE DeleteTree() - - DEALLOCATE(nodes) - DEALLOCATE(perm) - DEALLOCATE(q2cut) - DEALLOCATE(hp1, hp2, tc1, tc2, qry) - DEALLOCATE(ppoints) - -END SUBROUTINE DeleteTree - -RECURSIVE FUNCTION BuildTreeRec(points, l, u, level) RESULT(theNode) - - IMPLICIT NONE - - REAL points(d, n) - INTEGER :: l, u, level - TYPE(Node), POINTER :: theNode - - INTEGER :: m - - theNode => NewNode() ! get a new node - - IF (level >= bottom_level) THEN - theNode%bucket = .true. - theNode%lopt = l - theNode%hipt = u - ELSE - theNode%bucket = .false. - m = (l + u ) / 2 - theNode%discrim = dir2cut(l, u, points) - CALL partition(points,l, u, m, theNode%discrim) - theNode%cutval = points(theNode%discrim, perm(m)) - theNode%loson => BuildTreeRec(points, l, m, level + 1) - theNode%hison => BuildTreeRec(points, m+1, u, level + 1) - END IF - -END FUNCTION BuildTreeRec - -SUBROUTINE Set_k(k) - IMPLICIT NONE - - INTEGER::k - - num_k = k - - IF (ALLOCATED(nni)) THEN - DEALLOCATE(nni) - END IF - IF (ALLOCATED(nnd)) THEN - DEALLOCATE(nnd) - END IF - - ALLOCATE(nni(k)) - ALLOCATE(nnd(k)) - -END SUBROUTINE Set_k - -SUBROUTINE Set_qry(q) - IMPLICIT NONE - - REAL::q(d) - - qry = q - -END SUBROUTINE Set_qry - -SUBROUTINE Set_hps(hp_1, hp_2) - IMPLICIT NONE - - REAL::hp_1(d), hp_2(d) - - hp1 = hp_1 - hp2 = hp_2 - -END SUBROUTINE Set_hps - -SUBROUTINE Set_tcs(hp_1, hp_2) - IMPLICIT NONE - - REAL::hp_1(d), hp_2(d) - INTEGER i - - DO i = 1, d - tc1(i) = REAL(sgn(hp_1(i))) - tc2(i) = REAL(sgn(hp_2(i))) - END DO - -END SUBROUTINE Set_tcs - -FUNCTION sgn(x) - IMPLICIT NONE - REAL x - INTEGER sgn - IF (x .GE. 0.0) THEN - sgn = 1 - ELSE - sgn = -1 - END IF -END FUNCTION sgn - -SUBROUTINE Search(query) - - IMPLICIT NONE - - REAL :: query(d) - - INTEGER :: i - - partsum = 0 - DO i = 1, d - q2cut(i) = 0.0 - END DO - - DO i = 1, num_k - nnd(i) = 10.0 * 10.0 - nni(i) = 0 - END DO - curDistSq = 10.0 * 10.0 - - CALL SearchRec(query, root) - -END SUBROUTINE Search - -RECURSIVE SUBROUTINE SearchRec(query, tnode) - - IMPLICIT NONE - - REAL :: query(d), cur_q2c, cur_ps, cur_tc1, cur_tc2 - TYPE(Node) :: tnode - - INTEGER :: i - REAL :: distSq, d2o - IF (tnode%bucket) THEN - DO i = tnode%lopt, tnode%hipt - IF (in_ss(ppoints(1:3, perm(i)), ppoints(1:3, perm(i)))) THEN - distSq = inp(query, ppoints(1:3, perm(i))) - IF (distSq < curDistSq) THEN - curDistSq = distSq - CALL insert(perm(i)) - END IF - END IF - END DO - ELSE - d2o = query(tnode%discrim) - tnode%cutval - IF (d2o < 0.0) THEN - cur_ps = partsum - cur_q2c = q2cut(tnode%discrim) - cur_tc1 = tc1(tnode%discrim) - cur_tc2 = tc2(tnode%discrim) - CALL SearchRec(query, tnode%loson) - partsum = cur_ps + d2o * d2o - q2cut(tnode%discrim) - q2cut(tnode%discrim) = d2o * d2o - tc1(tnode%discrim) = max(tnode%cutval, tc1(tnode%discrim)) - tc2(tnode%discrim) = max(tnode%cutval, tc2(tnode%discrim)) - IF (partsum < curDistSq .AND. in_ss(tc1, tc2) ) THEN - CALL SearchRec(query, tnode%hison) - END IF - q2cut(tnode%discrim) = cur_q2c - tc1(tnode%discrim) = cur_tc1 - tc2(tnode%discrim) = cur_tc2 - ELSE - cur_ps = partsum - cur_q2c = q2cut(tnode%discrim) - cur_tc1 = tc1(tnode%discrim) - cur_tc2 = tc2(tnode%discrim) - CALL SearchRec(query, tnode%hison) - partsum = cur_ps + d2o * d2o - q2cut(tnode%discrim) - q2cut(tnode%discrim) = d2o * d2o - tc1(tnode%discrim) = min(tnode%cutval, tc1(tnode%discrim)) - tc2(tnode%discrim) = min(tnode%cutval, tc2(tnode%discrim)) - IF (partsum < curDistSq .AND. in_ss(tc1, tc2)) THEN - CALL SearchRec(query, tnode%loson) - END IF - q2cut(tnode%discrim) = cur_q2c - tc1(tnode%discrim) = cur_tc1 - tc2(tnode%discrim) = cur_tc2 - END IF - END IF - - END SUBROUTINE SearchRec - - FUNCTION in_ss(tc1, tc2) - IMPLICIT NONE - - LOGICAL in_ss - REAL tc1(d), tc2(d) - - REAL ip, tc(d) - INTEGER i - - tc = tc1 - qry - ip = 0.0 - DO i = 1, d - ip = ip + tc(i) * hp1(i) - END DO - IF (ip < 0) THEN - in_ss = .false. - RETURN - ENDIF - - tc = tc2 - qry - ip = 0.0 - DO i = 1, d - ip = ip + tc(i) * hp2(i) - END DO - IF (ip < 0) THEN - in_ss = .false. - RETURN - ENDIF - - in_ss = .true. - END FUNCTION in_ss - -! Subroutines and functions that are helps creatation and searching k-d tree. -! get a new node -FUNCTION NewNode() - IMPLICIT NONE - - TYPE(Node), POINTER :: NewNode - - NewNode => nodes(gc) - gc = gc + 1 - -END FUNCTION NewNode - -! partition the points along dir 'discrim' into lower and upper parts -SUBROUTINE partition(points, l, u, m, discrim) - IMPLICIT NONE - - REAL :: points(d, n) - INTEGER :: l, u, m, discrim - - REAL :: v - INTEGER :: i, j, t, r, lo - - r = u - lo = l - - DO WHILE ( r > lo) - v = points(discrim, perm(r)) - i = lo - j = r - 1 - DO WHILE (.true.) - DO WHILE (points(discrim,perm(i)) < v) - i = i + 1 - END DO - DO WHILE (points(discrim, perm(j)) >= v .AND. j > lo) - j = j - 1 - END DO - IF (i >= j) EXIT - t = perm(i) - perm(i) = perm(j) - perm(j) = t - END DO - t = perm(i) - perm(i) = perm(r) - perm(r) = t - IF (i >= m) r = i - 1; - IF (i <= m) lo = i + 1 - END DO - -END SUBROUTINE partition - -! function returns the direction to divide -FUNCTION dir2cut(l, u, points) - IMPLICIT NONE - - REAL :: points(d, n) - INTEGER :: l, u - - INTEGER :: dir2cut - - dir = dir + 1 - IF (dir > d) THEN - dir = 1 - END IF - dir2cut = dir - -END FUNCTION dir2cut - -! function to compute the inner product of p1-p2 -FUNCTION inp(p1, p2) - IMPLICIT NONE - - REAL :: p1(d), p2(d) - REAL :: inp - - REAL sum, dif - INTEGER i - - sum = 0 - DO i = 1, d - dif = p1(i) - p2(i) - sum = sum + dif * dif - END DO - - inp = sum - -END FUNCTION inp - -! subroutine to insert the current nn -SUBROUTINE insert(pt_idx) - IMPLICIT NONE - - INTEGER :: pt_idx - - INTEGER :: i, j - - DO i = 1, num_k - IF (curDistSq < nnd(i)) THEN - DO j = num_k, i + 1, -1 - nni(j) = nni(j - 1) - nnd(j) = nnd(j - 1) - END DO - nni(i) = pt_idx - nnd(i) = curDistSq - EXIT - END IF - END DO - - curDistSq = nnd(num_k) - -END SUBROUTINE insert - - -! function to return the index array -SUBROUTINE result() - IMPLICIT NONE - INTEGER :: i - - DO i = 1, num_k - PRINT*, nni(i) - PRINT*, ppoints(:, nni(i)), nnd(i) - END DO - -END SUBROUTINE result - -SUBROUTINE init_kd_tree(llpoints, n, k) - IMPLICIT NONE - integer,intent(in) :: n,k - REAL ,intent(in) :: llpoints(n,2) - REAL, ALLOCATABLE, SAVE :: points(:,:) - INTEGER :: i, seq, dim - - dim = 3 - IF (ALLOCATED(points)) THEN - DEALLOCATE(points) - ENDIF - ALLOCATE(points(dim,n)) - CALL lls2xyzs(llpoints, points, n) - CALL BuildTree(n, dim, points) - CALL Set_k(k) -END SUBROUTINE init_kd_tree - -SUBROUTINE close_kd_tree() - - CALL DeleteTree() - -END SUBROUTINE close_kd_tree - - -SUBROUTINE knn_search(ll, nn, min_dist, hp1, hp2) - IMPLICIT NONE - - REAL ll(2) - INTEGER nn(num_k) - REAL hp1(3), hp2(3), min_dist - - REAL :: q(3) - INTEGER i - - CALL ll2xyz(ll, q) - CALL Set_qry(q) - CALL Set_hps(hp1, hp2) - CALL Set_tcs(hp1, hp2) - CALL Search (q) - DO i = 1, num_k - nn(i) = nni(i) - END DO - min_dist = nnd(1) - -END SUBROUTINE knn_search - -SUBROUTINE knn_search_e(p, nn, nbs, min_dist) - IMPLICIT NONE - - REAL, INTENT(IN) :: p(3) - INTEGER, INTENT(OUT) :: nn(num_k) - REAL, INTENT(OUT) :: nbs(3,3), min_dist - - REAL q(3) - INTEGER i - - q = p - CALL Search (q) - DO i = 1, num_k - nn(i) = nni(i) - nbs(1:3,i) = ppoints(1:3, nni(i)) - END DO - min_dist = nnd(1) - -END SUBROUTINE knn_search_e - -SUBROUTINE ll2xyz(p, e) - IMPLICIT NONE - REAL p(2) - REAL e(3) - - e(1) = cos(p(1)) * cos(p(2)) - e(2) = cos(p(1)) * sin(p(2)) - e(3) = sin(p(1)) - -END SUBROUTINE ll2xyz - -SUBROUTINE lls2xyzs(llpts, xyzpts, n) - IMPLICIT NONE - - INTEGER :: n - REAL :: llpts(n, 2), xyzpts(3, n) - - INTEGER :: i - - DO i = 1, n - xyzpts(1,i) = cos(llpts(i,1)) * cos(llpts(i,2)) - xyzpts(2,i) = cos(llpts(i,1)) * sin(llpts(i,2)) - xyzpts(3,i) = sin(llpts(i,1)) - END DO - -END SUBROUTINE lls2xyzs - -END MODULE kd diff --git a/src/fim/FIMsrc/prep/slint/kd_datastru.F90 b/src/fim/FIMsrc/prep/slint/kd_datastru.F90 deleted file mode 100644 index 7d32156..0000000 --- a/src/fim/FIMsrc/prep/slint/kd_datastru.F90 +++ /dev/null @@ -1,27 +0,0 @@ -MODULE kd_datastru - - TYPE Node - LOGICAL :: bucket ! true if it is a bucket node - INTEGER :: npoints ! number of points of the node - INTEGER :: discrim ! discrimator - REAL :: cutval ! the cut value for the space - INTEGER :: lopt ! lower point - INTEGER :: hipt ! high point - TYPE(Node) , POINTER :: loson - TYPE(Node) , POINTER :: hison - END TYPE Node - - INTEGER n, d, gc, bottom_level, dir, num_k - - TYPE(Node), TARGET, ALLOCATABLE :: nodes(:) - INTEGER, ALLOCATABLE :: perm(:) - INTEGER, TARGET, ALLOCATABLE :: nni(:) - REAL, ALLOCATABLE :: nnd(:) - REAL, ALLOCATABLE :: os(:) - REAL, POINTER:: ppoints(:,:) - TYPE(Node), POINTER :: root - - REAL :: curDistSq, cur_o_s - - -END MODULE kd_datastru diff --git a/src/fim/FIMsrc/prep/slint/slint.F90 b/src/fim/FIMsrc/prep/slint/slint.F90 deleted file mode 100644 index a91fec7..0000000 --- a/src/fim/FIMsrc/prep/slint/slint.F90 +++ /dev/null @@ -1,978 +0,0 @@ -!------------------------------------------------------------ -! This file contains the routines needed to perform linear -! interpolation on sphere. -! -! -! Ning Wang, Jan 2007, init version -! This file contains the routines needed to perform linear -! interpolation on sphere. -! -! -! Ning Wang, Jan 2007, initial version -! Ning Wang, Jan 2011, Added some subroutines and comments. -! -! General purpose subroutines: -! (1) slint_init(grid1, n1, grid2, n2) -! grid1, grid2: array of lat-lons that specifies source -! and target grid; -! n1, n2, gripoint numners of source and target grids. -! (2) slint_init_fn(grid_file1, n1, grid_file2, n2, nn) -! grid_file1: file name for the source grid specification; -! grid_file2: file name for the target grid specification; -! n1, n2: grid point numbers of source and target grids; -! slint_init (...) initialize the associated data structures -! and computes the -! -! (3) bilinear_interp (src_data, tgt_data) -! src_data: an array of n1 elements that contains the data -! at source grid points. -! tgt_data: an array of n2 elements that contains the data -! at target grid points. -! bilinear_interp (...) interpolates the src_data bilinearly -! to tgt_dat. -! -! (4) nn_interp (src_data, tgt_data) -! Same as bilinear_interp, except it assigns the nearest -! neighbor's value in the src_data to the tgt_data. -! -! Special and legacy subroutines: -! Following the similar naming convention as those used -! in general subroutines. Details see in-line comments. -! -! Ning Wang, July 2011, important revision to the package. -! -!------------------------------------------------------------- -MODULE slint - TYPE GRID - INTEGER :: type - INTEGER :: ngp, mx, my - REAL, ALLOCATABLE :: latlon(:,:) - REAL, ALLOCATABLE :: coeffs(:,:) - REAL, ALLOCATABLE :: data(:) - INTEGER, ALLOCATABLE :: nn(:,:) - - END TYPE GRID - - TYPE(GRID) src_grid, tgt_grid - -CONTAINS - -! General purpose subroutines, -SUBROUTINE slint_init(grid1, n1, grid2, n2) - IMPLICIT NONE - INTEGER :: n1, n2 - REAL,INTENT(IN) :: grid1(n1, 2), grid2(n2, 2) - - CALL init_intern_array(grid1, n1, grid2, n2) - -END SUBROUTINE slint_init - -SUBROUTINE slint_init_fn(grid_file1, n1, grid_file2, n2) - IMPLICIT NONE - INTEGER :: n1, n2 - CHARACTER *(*),intent(in) :: grid_file1, grid_file2 - - CALL init_intern_fn(grid_file1, n1, grid_file2, n2, 0) - -END SUBROUTINE slint_init_fn - -SUBROUTINE bilinear_interp (src_data, tgt_data) - IMPLICIT NONE - - REAL src_data(*), tgt_data(*) - REAL v(3) - REAL*8 c(3) - INTEGER i - - DO i = 1, tgt_grid%ngp - c = tgt_grid%coeffs(1:3,i) - v(1) = src_data(tgt_grid%nn(1, i)) - v(2) = src_data(tgt_grid%nn(2, i)) - v(3) = src_data(tgt_grid%nn(3, i)) - tgt_data(i) = c(1) * v(1) + c(2) * v(2) + c(3) * v(3) - END DO - -END SUBROUTINE bilinear_interp - -SUBROUTINE nn_interp (src_data, tgt_data) - IMPLICIT NONE - - REAL src_data(*), tgt_data(*) - REAL v(3) - REAL*8 c(3) - INTEGER i - - DO i = 1, tgt_grid%ngp - v(1) = src_data(tgt_grid%nn(1, i)) - tgt_data(i) = v(1) - END DO - -END SUBROUTINE nn_interp - -! Generic init subroutine for bilinear interpolation -! To be deprecated -SUBROUTINE bilinear_init_fn(grid_file1, n1, grid_file2, n2) - IMPLICIT NONE - - INTEGER :: n1, n2 - CHARACTER *(*) :: grid_file1, grid_file2 - - CALL init_intern_fn(grid_file1, n1, grid_file2, n2, 0) - -END SUBROUTINE bilinear_init_fn - -! Generic init subroutine for nearest neighbor interpolation -! To be deprecated -SUBROUTINE nn_init_fn(grid_file1, n1, grid_file2, n2) - IMPLICIT NONE - - INTEGER :: n1, n2 - CHARACTER *(*) :: grid_file1, grid_file2 - - CALL init_intern_fn(grid_file1, n1, grid_file2, n2, 1) - -END SUBROUTINE nn_init_fn - -! Special init subroutine for bilinear interpolation -SUBROUTINE bilinear_init(grid_file1, n1, unit2, n2) - IMPLICIT NONE - INTEGER :: n1, n2 - CHARACTER *(*),intent(in) :: grid_file1 - integer ,intent(in) :: unit2 - - CALL init_intern_fn_unit(grid_file1, n1, unit2, n2, 0) - -END SUBROUTINE bilinear_init - -! Special init subroutine for nearest neighbor interpolation -SUBROUTINE nn_init(grid_file1, n1, unit2, n2) - IMPLICIT NONE - INTEGER :: n1, n2 - CHARACTER *(*),intent(in) :: grid_file1 - integer ,intent(in) :: unit2 - - CALL init_intern_fn_unit(grid_file1, n1, unit2, n2, 1) - -END SUBROUTINE nn_init - -! Internal subroutines called by those within the module -SUBROUTINE init_intern_fn(grid_file1, n1, grid_file2, n2, nn) - USE kd, ONLY: init_kd_tree - IMPLICIT NONE - - INTEGER :: n1, n2, nn - CHARACTER *(*) :: grid_file1, grid_file2 - - INTEGER i, j, g_idx, seq - REAL, ALLOCATABLE :: llpoints(:,:) - - ALLOCATE(llpoints(n1, 2)) - OPEN (10,file=grid_file1,status='old',form='unformatted') -! READ (10) ! comment out the two read statements for -! READ (10) ! a non-icos grid file - READ (10) llpoints(:, 1), llpoints(:, 2) - CLOSE(10) - CALL init_kd_tree(llpoints, n1, 1) - - src_grid%type = 1 - src_grid%ngp = n1 - IF (ALLOCATED(src_grid%latlon)) THEN - DEALLOCATE(src_grid%latlon) - ENDIF - IF (ALLOCATED(src_grid%data)) THEN - DEALLOCATE(src_grid%data) - ENDIF - ALLOCATE(src_grid%latlon(2, n1)) - ALLOCATE(src_grid%data(n1)) - - DO i = 1, n1 - src_grid%latlon(1,i) = llpoints(i, 1) - src_grid%latlon(2,i) = llpoints(i, 2) - END DO - - DEALLOCATE(llpoints) - - tgt_grid%type = 1 - tgt_grid%ngp = n2 - - IF (ALLOCATED(tgt_grid%latlon)) THEN - DEALLOCATE(tgt_grid%latlon) - ENDIF - IF (ALLOCATED(tgt_grid%data)) THEN - DEALLOCATE(tgt_grid%data) - ENDIF - IF (ALLOCATED(tgt_grid%coeffs)) THEN - DEALLOCATE(tgt_grid%coeffs) - ENDIF - IF (ALLOCATED(tgt_grid%nn)) THEN - DEALLOCATE(tgt_grid%nn) - ENDIF - - ALLOCATE(tgt_grid%latlon(2, n2)) - ALLOCATE(tgt_grid%nn(3, n2)) - ALLOCATE(tgt_grid%coeffs(3, n2)) - ALLOCATE(tgt_grid%data(n2)) - ALLOCATE(llpoints(n2, 2)) - - OPEN(10,file=grid_file2,status='old',form='unformatted') - READ (10) ! comment out the two READ statements - READ (10) ! for non-icos grid fiiles - READ(10) llpoints(:, 1), llpoints(:, 2) - CLOSE(10) - - DO i = 1, n2 - tgt_grid%latlon(1,i) = llpoints(i, 1) - tgt_grid%latlon(2,i) = llpoints(i, 2) - END DO - - CALL coeff_comp(nn) - -END SUBROUTINE init_intern_fn - -SUBROUTINE init_intern_fn_unit(grid_file1, n1, unit2, n2, nn) - USE kd, ONLY: init_kd_tree - IMPLICIT NONE - - INTEGER :: n1, n2, nn - CHARACTER *(*),INTENT(IN) :: grid_file1 - INTEGER ,INTENT(IN) :: unit2 - - REAL*8 lat, lon, d2r, r2d - INTEGER i, j, g_idx, seq - REAL, ALLOCATABLE :: llpoints(:,:) - INTEGER :: ierr - - d2r = 4.0*ATAN(1.0)/180.0 - r2d = 1 / d2r - - ALLOCATE(llpoints(n1, 2)) - OPEN (30,file=grid_file1,status='old',form='unformatted') - READ (30,iostat=ierr) llpoints(:, 1), llpoints(:, 2) - IF (ierr /= 0) then - WRITE(6,*)'slint.F90:init_intern_fn_unit: Error reading from unit 30' - WRITE(6,*)'init_interp_fn_unit: read(30) returns ierr=',ierr - END IF - CLOSE(30) - CALL init_kd_tree(llpoints, n1, 1) - - src_grid%type = 1 - src_grid%ngp = n1 - IF (ALLOCATED(src_grid%latlon)) THEN - DEALLOCATE(src_grid%latlon) - END IF - IF (ALLOCATED(src_grid%data)) THEN - DEALLOCATE(src_grid%data) - END IF - ALLOCATE(src_grid%latlon(2, n1)) - ALLOCATE(src_grid%data(n1)) - - DO i = 1, n1 - src_grid%latlon(1,i) = llpoints(i, 1) - src_grid%latlon(2,i) = llpoints(i, 2) - END DO - - DEALLOCATE(llpoints) - - tgt_grid%type = 1 - tgt_grid%ngp = n2 - - IF (ALLOCATED(tgt_grid%latlon)) THEN - DEALLOCATE(tgt_grid%latlon) - ENDIF - IF (ALLOCATED(tgt_grid%data)) THEN - DEALLOCATE(tgt_grid%data) - ENDIF - IF (ALLOCATED(tgt_grid%coeffs)) THEN - DEALLOCATE(tgt_grid%coeffs) - ENDIF - IF (ALLOCATED(tgt_grid%nn)) THEN - DEALLOCATE(tgt_grid%nn) - ENDIF - - ALLOCATE(tgt_grid%latlon(2, n2)) - ALLOCATE(tgt_grid%nn(3, n2)) - ALLOCATE(tgt_grid%coeffs(3, n2)) - ALLOCATE(tgt_grid%data(n2)) - ALLOCATE(llpoints(n2, 2)) - - READ (unit2) llpoints(:, 1) - READ (unit2) llpoints(:, 2) - DO i = 1, n2 - tgt_grid%latlon(1,i) = llpoints(i, 1) - tgt_grid%latlon(2,i) = llpoints(i, 2) - END DO - - DEALLOCATE(llpoints) - - CALL coeff_comp(nn) - -END SUBROUTINE init_intern_fn_unit - -! internal routine that does the interpolation -SUBROUTINE interp_intern() - IMPLICIT NONE - - INTEGER i, j, mx, my, g_idx - REAL*4 v(3), c(3) - - IF (src_grid%type == 1 .AND. tgt_grid%type == 0) THEN - mx = tgt_grid%mx - my = tgt_grid%my - DO j = 1, my - DO i = 1, mx - g_idx = (i + (j - 1) * mx) - c = tgt_grid%coeffs(1:3,g_idx) - v(1) = src_grid%data(tgt_grid%nn(1, g_idx)) - v(2) = src_grid%data(tgt_grid%nn(2, g_idx)) - v(3) = src_grid%data(tgt_grid%nn(3, g_idx)) - tgt_grid%data(g_idx) = c(1) * v(1) + c(2) * v(2) + c(3) * v(3) - END DO - END DO - ELSE IF (src_grid%type == 1 .AND. tgt_grid%type == 1) THEN - DO i = 1, tgt_grid%ngp - c = tgt_grid%coeffs(1:3,i) - v(1) = src_grid%data(tgt_grid%nn(1, i)) - v(2) = src_grid%data(tgt_grid%nn(2, i)) - v(3) = src_grid%data(tgt_grid%nn(3, i)) - tgt_grid%data(i) = c(1) * v(1) + c(2) * v(2) + c(3) * v(3) - END DO - END IF - -END SUBROUTINE interp_intern - -! Subroutine to compute interpolation coefficients -SUBROUTINE coeff_comp(nn_w) - IMPLICIT NONE - - INTEGER nn_w - - REAL latlon(2, 3), intsec(2), gcd1, gcd2 - REAL hp1(3), hp2(3), min_dist - INTEGER i, j,mx, my, g_idx, nn(3), num - REAL epsilon, r2d , t1, t2 - - epsilon = 0.00000000001 - r2d = 180.0/(ATAN(1.0) * 4.0) - - IF (src_grid%type == 1 .AND. tgt_grid%type == 0) THEN - mx = tgt_grid%mx - my = tgt_grid%my - DO i = 1, mx - DO j = 1, my - g_idx = (i + (j - 1) * mx) - CALL nsn(tgt_grid%latlon(1,g_idx), nn, num, min_dist) - tgt_grid%nn(1:3, g_idx) = nn(1:3) - IF (min_dist < epsilon .OR. nn_w == 1) THEN - tgt_grid%coeffs(1, g_idx) = 1.0 - tgt_grid%coeffs(2, g_idx) = 0.0 - tgt_grid%coeffs(3, g_idx) = 0.0 - ELSE IF (num == 2) THEN - latlon(1:2,1) = src_grid%latlon(1:2,nn(1)) - latlon(1:2,2) = src_grid%latlon(1:2,nn(2)) - CALL gcd_ratio(latlon(1,1), latlon(1,2), tgt_grid%latlon(1,g_idx), gcd1, t1) - tgt_grid%coeffs(1, g_idx) = (1.0 - t1) - tgt_grid%coeffs(2, g_idx) = t1 - tgt_grid%coeffs(3, g_idx) = 0.0 - ELSE - latlon(1:2,1) = src_grid%latlon(1:2,nn(1)) - latlon(1:2,2) = src_grid%latlon(1:2,nn(2)) - latlon(1:2,3) = src_grid%latlon(1:2,nn(3)) - CALL intersection (latlon(1,1), tgt_grid%latlon(1,g_idx), latlon(1,2), latlon(1,3), intsec) - CALL gcd_ratio(latlon(1,2), latlon(1,3), intsec, gcd1, t1) - CALL gcd_ratio(latlon(1,1), intsec, tgt_grid%latlon(1,g_idx), gcd2, t2) - - IF (t1 /= t1 .OR. t2 /= t2) THEN - PRINT*, 't1 or t2 NaN:', t1, t2 - ENDIF - - tgt_grid%coeffs(1, g_idx) = (1.0 - t2) - tgt_grid%coeffs(2, g_idx) = t2 * (1.0 - t1) - tgt_grid%coeffs(3, g_idx) = t2 * t1 - END IF - END DO - END DO - ELSE IF (src_grid%type == 1 .AND. tgt_grid%type == 1) THEN - DO i = 1, tgt_grid%ngp - CALL nsn(tgt_grid%latlon(1,i), nn, num, min_dist) - tgt_grid%nn(1:3, i) = nn(1:3) - IF (min_dist < epsilon .OR. nn_w == 1) THEN - tgt_grid%coeffs(1, i) = 1.0 - tgt_grid%coeffs(2, i) = 0.0 - tgt_grid%coeffs(3, i) = 0.0 - ELSE IF (num == 2) THEN - latlon(1:2,1) = src_grid%latlon(1:2,nn(1)) - latlon(1:2,2) = src_grid%latlon(1:2,nn(2)) - CALL gcd_ratio(latlon(1,1), latlon(1,2), tgt_grid%latlon(1,i), gcd1, t1) - tgt_grid%coeffs(1, i) = (1.0 - t1) - tgt_grid%coeffs(2, i) = t1 - tgt_grid%coeffs(3, i) = 0.0 - ELSE - latlon(1:2,1) = src_grid%latlon(1:2,nn(1)) - latlon(1:2,2) = src_grid%latlon(1:2,nn(2)) - latlon(1:2,3) = src_grid%latlon(1:2,nn(3)) - CALL intersection (latlon(1,1), tgt_grid%latlon(1,i), latlon(1,2), latlon(1,3), intsec) - CALL gcd_ratio(latlon(1,2), latlon(1,3), intsec, gcd1, t1) - CALL gcd_ratio(latlon(1,1), intsec, tgt_grid%latlon(1,i), gcd2, t2) - - IF (t1 /= t1 .OR. t2 /= t2) THEN - PRINT*, 't1 or t2 NaN:', t1, t2 - ENDIF - - tgt_grid%coeffs(1, i) = (1.0 - t2) - tgt_grid%coeffs(2, i) = t2 * (1.0 - t1) - tgt_grid%coeffs(3, i) = t2 * t1 - END IF - END DO - END IF - -END SUBROUTINE coeff_comp - -! Subroutine to compute interpolation coefficients, distance weight -SUBROUTINE coeff_comp1(nn_w) - USE kd, ONLY:knn_search - IMPLICIT NONE - - INTEGER nn_w - - REAL latlon(2, 3), intsec(2), gcd1, gcd2, part_gcd1, part_gcd2 - REAL hp1(3), hp2(3), min_dist - INTEGER i, j, mx, my, g_idx, nn(3), num - REAL epsilon, r2d , d1, d2, d3, rd1, rd2, rd3, srds - - epsilon = 0.00000000001 - r2d = 180.0/(ATAN(1.0) * 4.0) - - IF (src_grid%type == 1 .AND. tgt_grid%type == 0) THEN - mx = tgt_grid%mx - my = tgt_grid%my - DO i = 1, mx - DO j = 1, my - g_idx = (i + (j - 1) * mx) - CALL nsn(tgt_grid%latlon(1,g_idx), nn, num, min_dist) - tgt_grid%nn(1:3, g_idx) = nn(1:3) - IF (min_dist < epsilon .OR. nn_w == 1) THEN - tgt_grid%coeffs(1, g_idx) = 1.0 - tgt_grid%coeffs(2, g_idx) = 0.0 - tgt_grid%coeffs(3, g_idx) = 0.0 - ELSE - latlon(1:2,1) = src_grid%latlon(1:2,nn(1)) - latlon(1:2,2) = src_grid%latlon(1:2,nn(2)) - latlon(1:2,3) = src_grid%latlon(1:2,nn(3)) - d1 = gc_dist2(latlon(1,1), tgt_grid%latlon(1,g_idx)) - d2 = gc_dist2(latlon(1,2), tgt_grid%latlon(1,g_idx)) - d3 = gc_dist2(latlon(1,3), tgt_grid%latlon(1,g_idx)) - - rd1 = 1.0/d1 - rd2 = 1.0/d2 - rd3 = 1.0/d3 - srds = rd1 + rd2 + rd3 - - tgt_grid%coeffs(1, g_idx) = rd1 / srds - tgt_grid%coeffs(2, g_idx) = rd2 / srds - tgt_grid%coeffs(3, g_idx) = rd3 / srds - END IF - END DO - END DO - ELSE IF (src_grid%type == 1 .AND. tgt_grid%type == 1) THEN - DO i = 1, tgt_grid%ngp - CALL nsn(tgt_grid%latlon(1,i), nn, num, min_dist) - tgt_grid%nn(1:3, i) = nn(1:3) - IF (min_dist < epsilon .OR. nn_w == 1) THEN - tgt_grid%coeffs(1, i) = 1.0 - tgt_grid%coeffs(2, i) = 0.0 - tgt_grid%coeffs(3, i) = 0.0 - ELSE - latlon(1:2,1) = src_grid%latlon(1:2,nn(1)) - latlon(1:2,2) = src_grid%latlon(1:2,nn(2)) - latlon(1:2,3) = src_grid%latlon(1:2,nn(3)) - d1 = gc_dist2(latlon(1,1), tgt_grid%latlon(1,i)) - d2 = gc_dist2(latlon(1,2), tgt_grid%latlon(1,i)) - d3 = gc_dist2(latlon(1,3), tgt_grid%latlon(1,i)) - - rd1 = 1.0/d1 - rd2 = 1.0/d2 - rd3 = 1.0/d3 - srds = rd1 + rd2 + rd3 - - tgt_grid%coeffs(1, i) = rd1 / srds - tgt_grid%coeffs(2, i) = rd2 / srds - tgt_grid%coeffs(3, i) = rd3 / srds - END IF - END DO - END IF - -END SUBROUTINE coeff_comp1 - -SUBROUTINE interp (src_data, tgt_data) - IMPLICIT NONE - - REAL src_data(*) - REAL tgt_data(*) - - INTEGER i, n - - n = src_grid%ngp - DO i = 1, n - src_grid%data(i) = src_data(i) - END DO - - CALL interp_intern() - - n = tgt_grid%ngp - DO i = 1, n - tgt_data(i) = tgt_grid%data(i) - END DO -END SUBROUTINE interp - -! Two legacy subroutines, keep them for backward compatiablity. -SUBROUTINE nn_int (src_data, tgt_data) - IMPLICIT NONE - - REAL src_data(*) - REAL tgt_data(*) - CALL interp(src_data, tgt_data) - -END SUBROUTINE nn_int - -SUBROUTINE bl_int (src_data, tgt_data) - IMPLICIT NONE - - REAL src_data(*) - REAL tgt_data(*) - CALL interp(src_data, tgt_data) - -END SUBROUTINE bl_int - -! Two convenient subroutines for post process use. -SUBROUTINE bilinear_init_i2r(mx, my, llpoints, nip) - USE kd, ONLY:init_kd_tree - IMPLICIT NONE - - INTEGER, intent(in) :: mx, my, nip - REAL , intent(in) :: llpoints(nip,2) - - INTEGER i, j, g_idx, seq - REAL pi - - CALL init_kd_tree(llpoints, nip, 1) - - src_grid%type = 1 - src_grid%ngp = nip - IF (ALLOCATED(src_grid%latlon)) THEN - DEALLOCATE(src_grid%latlon) - END IF - IF (ALLOCATED(src_grid%data)) THEN - DEALLOCATE(src_grid%data) - END IF - ALLOCATE(src_grid%latlon(2, nip)) - ALLOCATE(src_grid%data(nip)) - - DO i = 1, nip - src_grid%latlon(1,i) = llpoints(i, 1) - src_grid%latlon(2,i) = llpoints(i, 2) - END DO - - tgt_grid%type = 0 - tgt_grid%mx = mx - tgt_grid%my = my - - IF (ALLOCATED(tgt_grid%latlon)) THEN - DEALLOCATE(tgt_grid%latlon) - ENDIF - IF (ALLOCATED(tgt_grid%data)) THEN - DEALLOCATE(tgt_grid%data) - ENDIF - IF (ALLOCATED(tgt_grid%coeffs)) THEN - DEALLOCATE(tgt_grid%coeffs) - ENDIF - IF (ALLOCATED(tgt_grid%nn)) THEN - DEALLOCATE(tgt_grid%nn) - ENDIF - - ALLOCATE(tgt_grid%latlon(2, mx * my)) - ALLOCATE(tgt_grid%nn(3, mx * my)) - ALLOCATE(tgt_grid%coeffs(3, mx * my)) - ALLOCATE(tgt_grid%data(mx * my)) - pi = 4.0*ATAN(1.0) - DO i = 1, mx - DO j = 1, my - g_idx = (i + (j - 1) * mx) - tgt_grid%latlon(1, g_idx) = (REAL(j - 1) - REAL(my - 1) * 0.5) * pi / REAL(my - 1) - tgt_grid%latlon(1, g_idx) = -tgt_grid%latlon(1, g_idx) - tgt_grid%latlon(2, g_idx) = REAL(i - 1) * 2.0 * pi / REAL(mx) - END DO - END DO - - CALL coeff_comp(0) - -END SUBROUTINE bilinear_init_i2r - -SUBROUTINE bilinear_interp_i2r(k, nlevels, vardata, data_xyz) - IMPLICIT NONE - - INTEGER k, nlevels - REAL vardata(*) - REAL data_xyz(*) - - INTEGER i, j, n, mx, my - - n = src_grid%ngp - DO i = 1, n - src_grid%data(i) = vardata(k + (i - 1) * nlevels) - END DO - - CALL interp_intern() - - mx = tgt_grid%mx - my = tgt_grid%my - DO i = 1, mx - DO j = 1, my - data_xyz((k - 1) * mx * my + (j - 1) * mx + i) = & - tgt_grid%data((j - 1) * mx + i) - END DO - END DO - -END SUBROUTINE bilinear_interp_i2r - -! Convenient subroutine to init the interpolation from given arrays -SUBROUTINE init_intern_array(grid1, n1, grid2, n2) - USE kd, ONLY: init_kd_tree - IMPLICIT NONE - - INTEGER :: n1, n2 - REAL grid1(n1, 2), grid2(n2, 2) - - INTEGER i, j, g_idx, seq - - CALL init_kd_tree(grid1, n1, 1) - - src_grid%type = 1 - src_grid%ngp = n1 - IF (ALLOCATED(src_grid%latlon)) THEN - DEALLOCATE(src_grid%latlon) - PRINT*, 'src_grid%latlon deallocated' - ENDIF - IF (ALLOCATED(src_grid%data)) THEN - DEALLOCATE(src_grid%data) - PRINT*, 'src_grid%data deallocated' - ENDIF - ALLOCATE(src_grid%latlon(2, n1)) - ALLOCATE(src_grid%data(n1)) - - DO i = 1, n1 - src_grid%latlon(1,i) = grid1(i, 1) - src_grid%latlon(2,i) = grid1(i, 2) - END DO - - tgt_grid%type = 1 - tgt_grid%ngp = n2 - - IF (ALLOCATED(tgt_grid%latlon)) THEN - DEALLOCATE(tgt_grid%latlon) - ENDIF - IF (ALLOCATED(tgt_grid%data)) THEN - DEALLOCATE(tgt_grid%data) - ENDIF - IF (ALLOCATED(tgt_grid%coeffs)) THEN - DEALLOCATE(tgt_grid%coeffs) - ENDIF - IF (ALLOCATED(tgt_grid%nn)) THEN - DEALLOCATE(tgt_grid%nn) - ENDIF - ALLOCATE(tgt_grid%latlon(2, n2)) - ALLOCATE(tgt_grid%data(n2)) - ALLOCATE(tgt_grid%coeffs(3, n2)) - ALLOCATE(tgt_grid%nn(3, n2)) - - DO i = 1, n2 - tgt_grid%latlon(1,i) = grid2(i, 1) - tgt_grid%latlon(2,i) = grid2(i, 2) - END DO - - CALL coeff_comp(0) - -END SUBROUTINE init_intern_array - -! subrountines for spherical curve interpolation -SUBROUTINE gcd_ratio (p1, p2, p, gcd, p_gcd) - IMPLICIT NONE - - REAL p1(2), p2(2), p(2), gcd, p_gcd - REAL gcdp1p2, gcdp1p, gcdp2p - REAL r2d, eps - - r2d = 180.0 / (atan(1.0)*4.0) - eps = 1.0E-6 - - gcdp1p2 = gc_dist2(p1, p2) - gcdp1p = gc_dist2(p1, p) - gcdp2p = gc_dist2(p2, p) - - IF (gcdp1p2 <= eps) THEN - PRINT*, 'nearest neighbor almost overlap!!' - PRINT*, p1*r2d, p2*r2d, p*r2d - p_gcd = 0.0 - ELSE IF (gcdp1p <= gcdp1p2 .AND. gcdp2p <= gcdp1p2) THEN ! p inside the p1p2 segment - p_gcd = gcdp1p / gcdp1p2 - ELSE IF (gcdp1p > gcdp1p2) THEN ! outside of end point p2 - p_gcd = 1.0 ! don't allow ! extrapolation - IF (gcdp2p > eps) THEN - PRINT*, 'extrapolation! outside of p2' - PRINT*, p1*r2d, p2*r2d, p*r2d - PRINT*, gcdp1p, gcdp1p2, gc_dist2(p,p2) - ENDIF - ELSE IF (gcdp2p > gcdp1p2) THEN ! outside of end point p1 - p_gcd = 0.0 ! don't allow ! extrapolation - IF (gcdp1p > eps) THEN - PRINT*, 'extrapolation! outside of p1' - PRINT*, p1*r2d, p2*r2d, p*r2d - PRINT*, gcdp2p, gcdp1p2, gc_dist2(p,p1) - ENDIF - ENDIF - gcd = gcdp1p2 - -END SUBROUTINE gcd_ratio - -! Great circle distance calculation, law of cosine formula -FUNCTION gc_dist(p1, p2) - IMPLICIT NONE - - REAL gc_dist - REAL, INTENT(IN) :: p1(2), p2(2) - - gc_dist = ACOS(COS(p1(1)) * COS(p2(1)) * COS(p1(2) - p2(2)) + SIN(p1(1)) * SIN(p2(1))) - -END FUNCTION gc_dist - - -! Great circle distance calculation, using Haversine formula. -! It is more accurate to compute small angular distances. -FUNCTION gc_dist2(p1, p2) - - IMPLICIT NONE - - REAL gc_dist2 - REAL, INTENT(IN) :: p1(2), p2(2) - - REAL dlatov2, dlonov2, a - - dlatov2 = (p2(1)-p1(1))/2.0 - dlonov2 = (p2(2)-p1(2))/2.0 - a = sin(dlatov2) * sin(dlatov2) + cos(p1(1))*cos(p2(1))*sin(dlonov2)*sin(dlonov2) - gc_dist2 = 2.0 * atan2(sqrt(a), sqrt(1.0-a)) - -END FUNCTION gc_dist2 - -LOGICAL FUNCTION enclosure(p1, p2, p3, p, co_gc) - IMPLICIT NONE - REAL, INTENT(IN) :: p1(2), p2(2), p3(2), p(2) - INTEGER, INTENT(OUT) :: co_gc - - REAL*8 p1_xy(2), p2_xy(2), p3_xy(2), p_xy(2) - REAL*8 cp1_z, cp2_z, cp3_z, cos_d2c, eps, eps2 - - eps = 0.00000001 - eps2 = 0.00000000001 - eps2 = 0.0000001 - co_gc = 0 - cos_d2c = sin(p(1))*sin(p1(1)) + cos(p(1))*cos(p1(1))*cos(p1(2)-p(2)) - p1_xy(1) = (cos(p1(1))*sin(p1(2) - p(2))) / cos_d2c - p1_xy(2) = (cos(p(1))*sin(p1(1)) - sin(p(1))*cos(p1(1))*cos(p1(2) - p(2))) / cos_d2c - - cos_d2c = sin(p(1))*sin(p2(1)) + cos(p(1))*cos(p2(1))*cos(p2(2)-p(2)) - p2_xy(1) = (cos(p2(1))*sin(p2(2) - p(2))) / cos_d2c - p2_xy(2) = (cos(p(1))*sin(p2(1)) - sin(p(1))*cos(p2(1))*cos(p2(2) - p(2))) / cos_d2c - - cos_d2c = sin(p(1))*sin(p3(1)) + cos(p(1))*cos(p3(1))*cos(p3(2)-p(2)) - p3_xy(1) = (cos(p3(1))*sin(p3(2) - p(2))) / cos_d2c - p3_xy(2) = (cos(p(1))*sin(p3(1)) - sin(p(1))*cos(p3(1))*cos(p3(2) - p(2))) / cos_d2c - - cp1_z = p1_xy(1)*p2_xy(2) - p1_xy(2)*p2_xy(1) - cp2_z = p2_xy(1)*p3_xy(2) - p2_xy(2)*p3_xy(1) - cp3_z = p3_xy(1)*p1_xy(2) - p3_xy(2)*p1_xy(1) - - IF (abs(cp1_z) < eps2) co_gc = 1 - IF (abs(cp2_z) < eps2) co_gc = 2 - IF (abs(cp3_z) < eps2) co_gc = 3 - - IF (cp1_z*cp2_z .LT. -eps2) THEN - enclosure = .false. - RETURN - ENDIF - - IF (cp1_z*cp3_z .LT. -eps2) THEN - enclosure = .false. - RETURN - ENDIF - - enclosure = .true. - RETURN - -END FUNCTION enclosure - -LOGICAL FUNCTION co_gc(p1, p2, p3) - IMPLICIT NONE - REAL, INTENT(IN) :: p1(2), p2(2), p3(2) - - co_gc = .true. -END FUNCTION co_gc - - -SUBROUTINE nsn(q_ll, nn, num, min_dist) - USE kd, ONLY: knn_search - IMPLICIT NONE - REAL, INTENT(IN) :: q_ll(2) - INTEGER, INTENT(out) :: nn(3), num - REAL,INTENT(OUT) :: min_dist - - REAL nn_ll(2, 3), hp1(3), hp2(3) - REAL qxyz(3), nnxyz(3), min_d - REAL eps - - INTEGER nni(3), co_gc, nn_swp - - eps = 0.00000000001 - - hp1 = 0.0 - hp2 = 0.0 - CALL knn_search(q_ll, nni, min_dist, hp1, hp2) - nn(1) = nni(1) - nn_ll(1:2, 1) = src_grid%latlon(1:2,nn(1)) ! the first vertex - - IF (min_dist < eps) THEN ! if the nearest neighbor is too close - nn(2) = nn(1) - nn(3) = nn(1) - num = 1 - RETURN - ENDIF - - CALL ll2xyz(q_ll, qxyz) - CALL ll2xyz(nn_ll(1:2,1), nnxyz) - hp1 = qxyz - nnxyz / inner_product(qxyz, nnxyz) - CALL cross_product2(qxyz, nnxyz, hp2) - hp1 = hp1 / sqrt(inner_product(hp1, hp1)) - hp2 = hp2 / sqrt(inner_product(hp2, hp2)) - - CALL knn_search(q_ll, nni, min_d, hp1, hp2) - nn(2) = nni(1) - nn_ll(1:2, 2) = src_grid%latlon(1:2,nn(2)) ! the second vertex - - hp2 = -hp2 - CALL ll2xyz(nn_ll(1:2,2), nnxyz) - CALL cross_product2(qxyz, nnxyz, hp1) - CALL knn_search(q_ll, nni, min_d, hp1, hp2) - nn(3) = nni(1) - nn_ll(1:2, 3) = src_grid%latlon(1:2,nn(3)) ! the third vertex - - IF (enclosure(nn_ll(1:2, 1), nn_ll(1:2, 2), nn_ll(1:2, 3), q_ll, co_gc)) THEN - num = 3 - ELSE - PRINT*, 'inside test fails' - END IF - - IF (co_gc /= 0) THEN - num = 2 - IF (nn(1) == nn(3)) THEN - RETURN - ELSE IF (co_gc == 1) THEN - RETURN - ELSE IF (co_gc == 2) THEN - nn_swp = nn(1) - nn(1) = nn(2) - nn(2) = nn(3) - nn(3) = nn_swp - RETURN - ELSE IF (co_gc == 3) THEN - nn_swp = nn(2) - nn(2) = nn(3) - nn(3) = nn_swp - RETURN - ENDIF - ENDIF -END SUBROUTINE nsn - -SUBROUTINE intersection (p1, p2, p3, p4, p) - IMPLICIT NONE - REAL p1(2), p2(2), p3(2), p4(2), p(2) - REAL gc1(3), gc2(3), e(3) - REAL pi - - pi = ATAN(1.0) * 4.0 - - CALL cross_product1(p1, p2, gc1) - CALL cross_product1(p4, p3, gc2) - CALL cross_product2(gc1, gc2, e) - - CALL xyz2ll(e, p) - - IF (gc_dist(p2, p) > pi / 4.0) THEN - p(2) = p(2) + pi - p(1) = -p(1) - END IF - - IF (p(2) < 0.0) THEN - p(2) = p(2) + 2.0 * pi - END IF - -END SUBROUTINE intersection - -FUNCTION inner_product(x1, x2) - IMPLICIT NONE - - REAL x1(3), x2(3), inner_product - - inner_product = x1(1)*x2(1) + x1(2)*x2(2) + x1(3)*x2(3) - -END FUNCTION inner_product - -SUBROUTINE cross_product1(p1, p2, gc) - IMPLICIT NONE - - REAL p1(2), p2(2), gc(3) - REAL a, b, c, d, e, f, g - - a = SIN(p1(1) + p2(1)) - b = SIN(p1(1) - p2(1)) - c = SIN((p1(2) + p2(2))/ 2.0) - d = SIN((p1(2) - p2(2))/ 2.0) - e = COS((p1(2) + p2(2))/ 2.0) - f = COS((p1(2) - p2(2))/ 2.0) - g = COS(p1(1)) * COS(p2(1)) - - gc(1) = b * c * f - a * e * d - gc(2) = b * e * f + a * c * d - gc(3) = 2.0 * g * d * f - -END SUBROUTINE cross_product1 - -SUBROUTINE cross_product2(e1, e2, e) - IMPLICIT NONE - REAL e1(3), e2(3), e(3) - - e(1) = e1(2) * e2(3) - e2(2) * e1(3) - e(2) = e1(3) * e2(1) - e2(3) * e1(1) - e(3) = e1(1) * e2(2) - e2(1) * e1(2) - -END SUBROUTINE cross_product2 - -SUBROUTINE xyz2ll(e, p) - IMPLICIT NONE - REAL e(3), p(2) - - p(1) = atan2(e(3), SQRT(e(1) * e(1) + e(2) * e(2))) - p(2) = atan2(-e(2), e(1)) - -END SUBROUTINE xyz2ll - -SUBROUTINE ll2xyz(p, e) - IMPLICIT NONE - REAL p(2) - REAL e(3) - - e(1) = cos(p(1)) * cos(p(2)) - e(2) = cos(p(1)) * sin(p(2)) - e(3) = sin(p(1)) - -END SUBROUTINE ll2xyz - -END MODULE slint diff --git a/src/fim/FIMsrc/prep/slint/slint.F90.jin b/src/fim/FIMsrc/prep/slint/slint.F90.jin deleted file mode 100644 index f315d5f..0000000 --- a/src/fim/FIMsrc/prep/slint/slint.F90.jin +++ /dev/null @@ -1,406 +0,0 @@ -!--------------------------------------------------------i---- -! This file contains the routines needed to perform linear -! interpolation on sphere. -! -! -! Ning Wang, Jan 2007, init version -! -!------------------------------------------------------------- -SUBROUTINE bilinear_init_i2r(mx, my, grid_file, nip) - USE slintdatastru - IMPLICIT NONE - - INTEGER :: mx, my, nip - CHARACTER *(*) :: grid_file - - REAL*8 pi - REAL*8 lat, lon, d2r, r2d - INTEGER i, j, g_idx, seq - REAL, ALLOCATABLE :: llpoints(:,:) - -!REAL*8 ll(2), min_dist -!INTEGER nn(3) - - print*,'JFM entering slint' - d2r = 4.0*ATAN(1.0)/180.0 - r2d = 1 / d2r - - CALL init_kd_tree(grid_file, nip, 3) - -!ll(1) = 45.0 * d2r -!ll(2) = (210.0) * d2r -!CALL knn_search(ll, nn, min_dist) -!PRINT*, nn(1), min_dist - - src_grid%type = 1 - src_grid%ngp = nip - ALLOCATE(src_grid%latlon(2, nip)) - ALLOCATE(src_grid%data(nip)) - ALLOCATE(llpoints(nip, 2)) - - OPEN(10,file=grid_file,status='old',form='unformatted') - READ(10) llpoints(:, 1), llpoints(:, 2) - CLOSE(10) - -!PRINT*, llpoints(8794,:) * r2d -! llpoints = llpoints*d2r - - DO i = 1, nip - src_grid%latlon(1,i) = llpoints(i, 1) - src_grid%latlon(2,i) = llpoints(i, 2) - END DO - - DEALLOCATE(llpoints) - - tgt_grid%type = 0 - tgt_grid%mx = mx - tgt_grid%my = my - - ALLOCATE(tgt_grid%latlon(2, mx * my)) - ALLOCATE(tgt_grid%nn(3, mx * my)) - ALLOCATE(tgt_grid%coeffs(3, mx * my)) - ALLOCATE(tgt_grid%data(mx * my)) - pi = 4.0*ATAN(1.0) - DO i = 1, mx - DO j = 1, my - g_idx = (i + (j - 1) * mx) - tgt_grid%latlon(1, g_idx) = (REAL(j - 1) - REAL(my - 1) * 0.5) * pi / REAL(my - 1) - tgt_grid%latlon(2, g_idx) = REAL(i - 1) * 2.0 * pi / REAL(mx - 1) - END DO - END DO - - CALL coeff_comp() - -END SUBROUTINE bilinear_init_i2r - -SUBROUTINE bilinear_init(grid_file1, n1, grid_file2, n2) - USE slintdatastru - IMPLICIT NONE - - INTEGER :: n1, n2 - CHARACTER *(*) :: grid_file1, grid_file2 - - REAL*8 lat, lon, d2r, r2d - INTEGER i, j, g_idx, seq - REAL, ALLOCATABLE :: llpoints(:,:) - - d2r = 4.0*ATAN(1.0)/180.0 - r2d = 1 / d2r - - CALL init_kd_tree(grid_file1, n1, 3) - - src_grid%type = 1 - src_grid%ngp = n1 - ALLOCATE(src_grid%latlon(2, n1)) - ALLOCATE(src_grid%data(n1)) - ALLOCATE(llpoints(n1, 2)) - - OPEN(10,file=grid_file1,status='old',form='unformatted') - READ(10) llpoints(:, 1), llpoints(:, 2) - CLOSE(10) - - DO i = 1, n1 - src_grid%latlon(1,i) = llpoints(i, 1) - src_grid%latlon(2,i) = llpoints(i, 2) - END DO - - DEALLOCATE(llpoints) - - tgt_grid%type = 1 - tgt_grid%ngp = n2 - - ALLOCATE(tgt_grid%latlon(2, n2)) - ALLOCATE(tgt_grid%nn(3, n2)) - ALLOCATE(tgt_grid%coeffs(3, n2)) - ALLOCATE(tgt_grid%data(n2)) - ALLOCATE(llpoints(n2, 2)) - - OPEN(10,file=grid_file2,status='old',form='unformatted') - READ(10) llpoints(:, 1), llpoints(:, 2) - CLOSE(10) - - DO i = 1, n2 - tgt_grid%latlon(1,i) = llpoints(i, 1) - tgt_grid%latlon(2,i) = llpoints(i, 2) - END DO - - CALL coeff_comp() - -END SUBROUTINE bilinear_init - - -SUBROUTINE bilinear_interp_intern() - USE slintdatastru - IMPLICIT NONE - - INTEGER i, j, mx, my, g_idx - REAL*4 v(3), c(3) - - IF (src_grid%type == 1 .AND. tgt_grid%type == 0) THEN - mx = tgt_grid%mx - my = tgt_grid%my - DO i = 1, mx - DO j = 1, my - g_idx = (i + (j - 1) * mx) - c = tgt_grid%coeffs(1:3,g_idx) - v(1) = src_grid%data(tgt_grid%nn(1, g_idx)) - v(2) = src_grid%data(tgt_grid%nn(2, g_idx)) - v(3) = src_grid%data(tgt_grid%nn(3, g_idx)) - tgt_grid%data(g_idx) = c(1) * v(1) + c(2) * v(2) + c(3) * v(3) - END DO - END DO - ELSE IF (src_grid%type == 1 .AND. tgt_grid%type == 1) THEN - DO i = 1, tgt_grid%ngp - c = tgt_grid%coeffs(1:3,i) - v(1) = src_grid%data(tgt_grid%nn(1, i)) - v(2) = src_grid%data(tgt_grid%nn(2, i)) - v(3) = src_grid%data(tgt_grid%nn(3, i)) - tgt_grid%data(i) = c(1) * v(1) + c(2) * v(2) + c(3) * v(3) - END DO - END IF - -END SUBROUTINE bilinear_interp_intern - -SUBROUTINE coeff_comp() - USE slintdatastru - IMPLICIT NONE - - REAL*8 latlon(2, 3), intsec(2), gcd1, gcd2, part_gcd1, part_gcd2 - INTEGER i, j,mx, my, g_idx, nn(3) - REAL*8 min_dist, epsilon, r2d , t1, t2, theta1, theta2 - - epsilon = 0.00000000001 - r2d = 180.0/(ATAN(1.0) * 4.0) - - IF (src_grid%type == 1 .AND. tgt_grid%type == 0) THEN - mx = tgt_grid%mx - my = tgt_grid%my - DO i = 1, mx - DO j = 1, my - g_idx = (i + (j - 1) * mx) - CALL knn_search(tgt_grid%latlon(1,g_idx), nn, min_dist) - latlon(1:2,1) = src_grid%latlon(1:2,nn(1)) - latlon(1:2,2) = src_grid%latlon(1:2,nn(2)) - latlon(1:2,3) = src_grid%latlon(1:2,nn(3)) - CALL intersection (latlon(1,1), tgt_grid%latlon(1,g_idx), latlon(1,2), latlon(1,3), intsec) - - CALL gcd_ratio(latlon(1,2), latlon(1,3), intsec, gcd1, part_gcd1) - CALL gcd_ratio(latlon(1,1), intsec, tgt_grid%latlon(1,g_idx), gcd2, part_gcd2) - - tgt_grid%nn(1:3, g_idx) = nn(1:3) - IF (min_dist < epsilon) THEN - tgt_grid%coeffs(1, g_idx) = 1.0 - tgt_grid%coeffs(2, g_idx) = 0.0 - tgt_grid%coeffs(3, g_idx) = 0.0 - ELSE - theta1 = gcd1 - t1 = part_gcd1 - theta2 = gcd2 - t2 = part_gcd2 -! tgt_grid%coeffs(1, g_idx) = SIN((1.0 - t2) * theta2) / SIN(theta2) -! tgt_grid%coeffs(2, g_idx) = SIN(t2 * theta2) / SIN(theta2) * & -! SIN((1.0 - t1) * theta1) / SIN(theta1) -! tgt_grid%coeffs(3, g_idx) = SIN(t2 * theta2) / SIN(theta2) * & -! SIN(t1 * theta1) / SIN(theta1) - - tgt_grid%coeffs(1, g_idx) = (1.0 - t2) - tgt_grid%coeffs(2, g_idx) = t2 * (1.0 - t1) - tgt_grid%coeffs(3, g_idx) = t2 * t1 - END IF - END DO - END DO - ELSE IF (src_grid%type == 1 .AND. tgt_grid%type == 1) THEN - DO i = 1, tgt_grid%ngp - CALL knn_search(tgt_grid%latlon(1,i), nn, min_dist) - latlon(1:2,1) = src_grid%latlon(1:2,nn(1)) - latlon(1:2,2) = src_grid%latlon(1:2,nn(2)) - latlon(1:2,3) = src_grid%latlon(1:2,nn(3)) - CALL intersection (latlon(1,1), tgt_grid%latlon(1,i), latlon(1,2), latlon(1,3), intsec) - - CALL gcd_ratio(latlon(1,2), latlon(1,3), intsec, gcd1, part_gcd1) - CALL gcd_ratio(latlon(1,1), intsec, tgt_grid%latlon(1,i), gcd2, part_gcd2) - - tgt_grid%nn(1:3, i) = nn(1:3) - IF (min_dist < epsilon) THEN - tgt_grid%coeffs(1, i) = 1.0 - tgt_grid%coeffs(2, i) = 0.0 - tgt_grid%coeffs(3, i) = 0.0 - ELSE - theta1 = gcd1 - t1 = part_gcd1 - theta2 = gcd2 - t2 = part_gcd2 - tgt_grid%coeffs(1, i) = (1.0 - t2) - tgt_grid%coeffs(2, i) = t2 * (1.0 - t1) - tgt_grid%coeffs(3, i) = t2 * t1 - END IF - END DO - END IF - -END SUBROUTINE coeff_comp - -SUBROUTINE bl_int (src_data, tgt_data) - USE slintdatastru - IMPLICIT NONE - - REAL src_data(*) - REAL tgt_data(*) - - INTEGER i, n - - n = src_grid%ngp - DO i = 1, n - src_grid%data(i) = src_data(i) - END DO - - CALL bilinear_interp_intern() - - n = tgt_grid%ngp - DO i = 1, n - tgt_data(i) = tgt_grid%data(i) - END DO - -END SUBROUTINE bl_int - -SUBROUTINE bilinear_interp_i2r(k, nlevels, vardata, data_xyz) - USE slintdatastru - IMPLICIT NONE - - INTEGER k, nlevels - REAL vardata(*) - REAL data_xyz(*) - - INTEGER i, j, n, mx, my - - n = src_grid%ngp - DO i = 1, n - src_grid%data(i) = vardata(k + (i - 1) * nlevels) - END DO - - CALL bilinear_interp_intern() - - mx = tgt_grid%mx - my = tgt_grid%my - DO i = 1, mx - DO j = 1, my - data_xyz((k - 1) * mx * my + (j - 1) * mx + i) = & - tgt_grid%data((j - 1) * mx + i) - END DO - END DO - -END SUBROUTINE bilinear_interp_i2r - -! subrountines for spherical curve interpolation -SUBROUTINE gcd_ratio (p1, p2, p, gcd, p_gcd) - IMPLICIT NONE - - REAL*8 p1(2), p2(2), p(2), gcd, p_gcd - REAL*8 gc_dist - -!print*,'in gcd_ratio', p1, p2, p - gcd = gc_dist(p1, p2) - p_gcd = gc_dist(p1, p) -!print*,'in gcd_ratio', gcd, p_gcd - -END SUBROUTINE gcd_ratio - -FUNCTION gc_dist(p1, p2) - IMPLICIT NONE - - REAL*8 gc_dist - REAL*8 p1(2), p2(2) - - gc_dist = ACOS(COS(p1(1)) * COS(p2(1)) * COS(p1(2) - p2(2)) + SIN(p1(1)) * SIN(p2(1))) - -END FUNCTION gc_dist - -SUBROUTINE intersection (p1, p2, p3, p4, p) - IMPLICIT NONE - REAL*8 p1(2), p2(2), p3(2), p4(2), p(2) - REAL*8 gc1(3), gc2(3), e(3) - REAL*8 pi, gc_dist - - pi = ATAN(1.0) * 4.0 - - CALL cross_product1(p1, p2, gc1) - CALL cross_product1(p3, p4, gc2) - CALL cross_product2(gc1, gc2, e) - - CALL xyz2ll(e, p) - -! IF (p(2) < 0) THEN -! p(2) = p(2) + 2 * pi -! END IF -! IF (ABS(p(2) - p1(2)) > pi / 2 .AND. & -! ((p(1) < 0 .AND. p1(1) > 0) .OR. (p(1) > 0 .AND. p1(1) < 0))) THEN -! p(2) = p(2) + pi -! p(1) = -p(1) -! END IF - - IF (gc_dist(p2, p) > pi / 4.0) THEN - p(2) = p(2) + pi - p(1) = -p(1) - END IF - - IF (p(2) < 0.0) THEN - p(2) = p(2) + 2.0 * pi - END IF - -END SUBROUTINE intersection - - -SUBROUTINE cross_product1(p1, p2, gc) - IMPLICIT NONE - - REAL*8 p1(2), p2(2), gc(3) - REAL*8 a, b, c, d, e, f, g - - a = SIN(p1(1) + p2(1)) - b = SIN(p1(1) - p2(1)) - c = SIN((p1(2) + p2(2))/ 2.0) - d = SIN((p1(2) - p2(2))/ 2.0) - e = COS((p1(2) + p2(2))/ 2.0) - f = COS((p1(2) - p2(2))/ 2.0) - g = COS(p1(1)) * COS(p2(1)) - - gc(1) = b * c * f - a * e * d - gc(2) = b * e * f + a * c * d - gc(3) = 2.0 * g * d * f - -END SUBROUTINE cross_product1 - -SUBROUTINE cross_product2(e1, e2, e) - IMPLICIT NONE - REAL*8 e1(3), e2(3), e(3) - - e(1) = e1(2) * e2(3) - e2(2) * e1(3) - e(2) = e1(3) * e2(1) - e2(3) * e1(1) - e(3) = e1(1) * e2(2) - e1(2) * e2(1) - -END SUBROUTINE cross_product2 - -SUBROUTINE xyz2ll(e, p) - IMPLICIT NONE - REAL*8 e(3), p(2) - - p(1) = atan2(e(3), SQRT(e(1) * e(1) + e(2) * e(2))) - p(2) = atan2(-e(2), e(1)) - -END SUBROUTINE xyz2ll - -SUBROUTINE ll2xyz(p, e) - IMPLICIT NONE - REAL*8 p(2) - REAL e(3) - - e(1) = cos(p(1)) * cos(p(2)) - e(2) = cos(p(1)) * sin(p(2)) - e(3) = sin(p(1)) - -END SUBROUTINE ll2xyz - - - - - - diff --git a/src/fim/FIMsrc/prep/slint/slintdatastru.F90 b/src/fim/FIMsrc/prep/slint/slintdatastru.F90 deleted file mode 100644 index be358dc..0000000 --- a/src/fim/FIMsrc/prep/slint/slintdatastru.F90 +++ /dev/null @@ -1,17 +0,0 @@ -MODULE SlintDataStru - - TYPE GRID - INTEGER :: type - INTEGER :: ngp, mx, my - REAL*8, ALLOCATABLE :: latlon(:,:) - REAL*8, ALLOCATABLE :: coeffs(:,:) - REAL*4, ALLOCATABLE :: data(:) - INTEGER, ALLOCATABLE :: nn(:,:) - - END TYPE GRID - - TYPE(GRID) src_grid, tgt_grid - -END MODULE SlintDataStru - - diff --git a/src/fim/FIMsrc/prep/slint/slintest.F90 b/src/fim/FIMsrc/prep/slint/slintest.F90 deleted file mode 100644 index b2ab522..0000000 --- a/src/fim/FIMsrc/prep/slint/slintest.F90 +++ /dev/null @@ -1,38 +0,0 @@ - PROGRAM slintest - USE slint, only:bilinear_init_fn - - IMPLICIT NONE - - INTEGER mx, my, i, nip - CHARACTER (len=128) grid_file1, grid_file2 - REAL llpoints(10242, 2) - REAL time_beg, time_end - - nip = 163842 - grid_file1 = "gfsltln_t382.dat" - grid_file2 = "icos_grid_info_level.dat" - mx = 1152 - my = 576 - CALL cpu_time(time_beg) - CALL bilinear_init_fn(grid_file1, mx*my, grid_file2, nip) - CALL cpu_time(time_end) - PRINT*, 'It took ', time_end - time_beg, 'seconds to init slint' - -! nip = 10242 -! grid_file = "grid_info.dat" -! mx = 128 -! my = 64 -! OPEN (10,file=grid_file,status='old',form='unformatted') -! READ(10) -! READ(10) -! READ (10) llpoints(:, 1), llpoints(:, 2) -! CLOSE(10) - -! print*, llpoints(1:32, 1) -! print*, llpoints(1:32, 2) -! DO i = 1, 100 -! print*, i -! CALL bilinear_interp_i2r() -! END DO - - END PROGRAM slintest diff --git a/src/fim/FIMsrc/prep/sp/Makefile b/src/fim/FIMsrc/prep/sp/Makefile deleted file mode 100644 index b35dbf0..0000000 --- a/src/fim/FIMsrc/prep/sp/Makefile +++ /dev/null @@ -1,50 +0,0 @@ -#!/bin/sh -############################################################### -# -# AUTHOR: Vuong - W/NP11 -# -# DATE: 12/04/2000 -# -# PURPOSE: This script uses the make utility to update the libsp -# archive libraries. -# It first reads a list of source files in the library and -# then generates a makefile used to update the archive -# libraries. The make command is then executed for each -# archive library, where the archive library name and -# compilation flags are passed to the makefile through -# environment variables. -# -# REMARKS: Only source files that have been modified since the last -# library update are recompiled and replaced in the object -# archive libraries. The make utility determines this -# from the file modification times. -# -# New source files are also compiled and added to the object -# archive libraries. -# -############################################################### - -# -# Generate a list of object files that corresponds to the -# list of Fortran ( .f ) files in the current directory -# - -include ../../macros.make - -SRCS = $(shell ls *.f) -OBJS = $(addsuffix .o, $(basename $(SRCS))) -LIB = $(LIBDIR)/libsp_4.a - -.SUFFIXES: -.SUFFIXES: .o .f - -.f.o: - $(FC) -c $(FFLAGS) $(FIXEDFLAG) $< - -all: $(LIB) - -$(LIB): $(OBJS) - ar ruv $(AFLAGS) $@ $(OBJS) - -clean: - $(RM) *.o *.mod diff --git a/src/fim/FIMsrc/prep/sp/bll2ps.f b/src/fim/FIMsrc/prep/sp/bll2ps.f deleted file mode 100644 index 82b8927..0000000 --- a/src/fim/FIMsrc/prep/sp/bll2ps.f +++ /dev/null @@ -1,315 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE BLL2PS(IBM,IM,JM,KM,NPS,KB,TRUE,XMESH,ORIENT, - & LB,B,LBN,BN,LBS,BS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BLL2PS INTERP. LATLON BUDGET TO POLAR STEREOGRAPHIC -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-20 -C -C ABSTRACT: INTERPOLATES A BUDGET-TYPE SCALAR FIELD FROM A GLOBAL -C LATITUDE-LONGITUDE CYLINDRICAL GRID (INCLUDING THE POLES) -C TO A MATCHED PAIR OF POLAR STEREOGRAPHIC GRIDS CENTERED -C ON THE RESPECTIVE POLES, WHERE THE ORIENTATION LONGITUDE -C OF THE SOUTHERN HEMISPHERE GRID IS 180 DEGREES OPPOSITE -C THAT OF THE NORTHERN HEMISPHERE GRID. THIS INTERPOLATION -C IS DESIGNED TO APPROXIMATE AN AREA-AVERAGE CONSERVING -C INTERPOLATION FROM FINE TO COARSE RESOLUTION BUT TO BECOME -C A BILINEAR INTERPOLATION FROM COARSE TO FINE RESOLUTION. -C THIS IS ACCOMPLISHED BY BILINEARLY INTERPOLATING TO A MUCH -C FINER POLAR STEREOGRAPHIC GRID AND THEN AREA-AVERAGING TO -C THE OUTPUT GRID. THE CURRENT CONFIGURATION INTERPOLATES -C TO AN EXTRAVAGANT 121 POINTS IN EVERY OUTPUT GRID BOX. -C THIS ROUTINE ALSO WOULD INTERPOLATE ASSOCIATED BITMAPS. -C THIS ROUTINE IS CONFIGURED ONLY FOR (I,J,K) ORDER GRIDS. -C THIS ROUTINE IS FULLY VECTORIZED AND MULTITASKED. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OBSOLESCENCE WARNING MESSAGE ISSUED -C -C USAGE: CALL BLL2PS(IBM,IM,JM,KM,NPS,KB,TRUE,XMESH,ORIENT, -C & LB,B,LBN,BN,LBS,BS) -C -C INPUT ARGUMENT LIST: -C IBM - INTEGER BITMAP IDENTIFIER -C (0 FOR NO BITMAP, 1 TO INTERPOLATE BITMAP) -C IM - INTEGER NUMBER OF INPUT LONGITUDES -C JM - INTEGER NUMBER OF INPUT LATITUDES -C KM - INTEGER NUMBER OF FIELDS TO INTERPOLATE -C NPS - INTEGER ODD ORDER OF THE POLAR STEREOGRAPHIC GRIDS -C (CENTER POINTS ARE THE POLE POINTS) -C KB - INTEGER SKIP NUMBER BETWEEN INPUT FIELDS -C TRUE - REAL LATITUDE AT WHICH PS GRID IS TRUE (USUALLY 60.) -C XMESH - REAL GRID LENGTH AT TRUE LATITUDE (M) -C ORIENT - REAL LONGITUDE AT BOTTOM OF NORTHERN PS GRID -C (SOUTHERN PS GRID WILL HAVE OPPOSITE ORIENTATION.) -C LB - LOGICAL (IM,JM,KM) BITMAP IF IBM=1 -C B - REAL (IM,JM,KM) SCALAR FIELD TO INTERPOLATE -C -C OUTPUT ARGUMENT LIST: -C LBN - LOGICAL (NPS,NPS,KM) NORTHERN PS BITMAP IF IBM=1 -C BN - REAL (IM,JM,KM) INTERPOLATED NORTHERN PS FIELD -C LBN - LOGICAL (NPS,NPS,KM) SOUTHERN PS BITMAP IF IBM=1 -C BN - REAL (IM,JM,KM) INTERPOLATED SOUTHERN PS FIELD -C -C REMARKS: FORTRAN 90 EXTENSIONS ARE USED. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - LOGICAL LB(KB,KM),LBN(NPS,NPS,KM),LBS(NPS,NPS,KM) - REAL B(KB,KM),BN(NPS,NPS,KM),BS(NPS,NPS,KM) - PARAMETER(NXH=5,NX=2*NXH+1,NXQ=NX*NX) - PARAMETER(RERTH=6.3712E6) - PARAMETER(PI=3.14159265358979,DPR=180./PI) - REAL WN(NPS,NPS,KM),WS(NPS,NPS,KM) - INTEGER IN1(NXQ),IN2(NXQ),JN1(NXQ),JN2(NXQ) - REAL WIN1(NXQ),WIN2(NXQ),WJN1(NXQ),WJN2(NXQ) - INTEGER IS1(NXQ),IS2(NXQ),JS1(NXQ),JS2(NXQ) - REAL WIS1(NXQ),WIS2(NXQ),WJS1(NXQ),WJS2(NXQ) - INTEGER IJN11(NXQ),IJN21(NXQ),IJN12(NXQ),IJN22(NXQ) - INTEGER IJS11(NXQ),IJS21(NXQ),IJS12(NXQ),IJS22(NXQ) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - CALL ERRMSG('BLL2PS will no longer be supported.') - CALL ERRMSG('Please call IPOLATES(3,...) rather than BLL2PS.') -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - XPX=(NPS-1)/2*NX+NXH+1 - XMESHX=XMESH/NX - G2=((1.+SIN(TRUE/DPR))*RERTH/XMESHX)**2 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(KM.EQ.1) THEN -cccCDIR$ IVDEP - DO IJ=1,NPS*NPS - J=(IJ-1)/NPS+1 - I=IJ-(J-1)*NPS - BN(I,J,1)=0. - WN(I,J,1)=0. - BS(I,J,1)=0. - WS(I,J,1)=0. - ENDDO - ELSE - DO IJ=1,NPS*NPS - J=(IJ-1)/NPS+1 - I=IJ-(J-1)*NPS - DO K=1,KM - BN(I,J,K)=0. - WN(I,J,K)=0. - BS(I,J,K)=0. - WS(I,J,K)=0. - ENDDO - ENDDO - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -cCMIC$ DO ALL PRIVATE(K,IJ,J,I,N,JXI,IXI,JX,IX,DJX,DIX,R2) -cCMIC$& PRIVATE(RLATN,RLONN,RLATS,RLONS) -cCMIC$& PRIVATE(YN,XN,IN1,IN2,WIN2,WIN1,JN1,JN2,WJN2,WJN1) -cCMIC$& PRIVATE(YS,XS,IS1,IS2,WIS2,WIS1,JS1,JS2,WJS2,WJS1) -cCMIC$& PRIVATE(IJN11,IJN21,IJN12,IJN22,IJS11,IJS21,IJS12,IJS22) -cCMIC$& SHARED(KM,NPS,NXQ,NX,XPX,DPR,G2,ORIENT) -cCMIC$& SHARED(IM,JM,IBM,B,LB,BN,BS,WN,WS) - DO IJ=1,NPS*NPS - J=(IJ-1)/NPS+1 - I=IJ-(J-1)*NPS -cCDIR$ IVDEP - DO N=1,NXQ - JXI=(N-1)/NX+1 - IXI=N-(JXI-1)*NX - JX=(J-1)*NX+JXI - IX=(I-1)*NX+IXI - DJX=JX-XPX - DIX=IX-XPX - R2=DJX**2+DIX**2 - IF(R2.GT.0.) THEN - RLATN=DPR*ASIN((G2-R2)/(G2+R2)) - RLONN=MOD(720+ORIENT+(DPR*ATAN2(DIX,-DJX)),360.) - RLATS=-DPR*ASIN((G2-R2)/(G2+R2)) - RLONS=MOD(720+180+ORIENT-(DPR*ATAN2(DIX,-DJX)),360.) - ELSE - RLATN=90 - RLONN=0 - RLATS=-90 - RLONS=0 - ENDIF - YN=(90-RLATN)/180*(JM-1)+1 - XN=RLONN/360*IM+1 - IN1(N)=XN - IN2(N)=MOD(IN1(N),IM)+1 - WIN2(N)=XN-IN1(N) - WIN1(N)=1-WIN2(N) - JN1(N)=YN - JN2(N)=MIN(JN1(N)+1,JM) - WJN2(N)=YN-JN1(N) - WJN1(N)=1-WJN2(N) - YS=(90-RLATS)/180*(JM-1)+1 - XS=RLONS/360*IM+1 - IS1(N)=XS - IS2(N)=MOD(IS1(N),IM)+1 - WIS2(N)=XS-IS1(N) - WIS1(N)=1-WIS2(N) - JS1(N)=YS - JS2(N)=MIN(JS1(N)+1,JM) - WJS2(N)=YS-JS1(N) - WJS1(N)=1-WJS2(N) - IJN11(N)=IN1(N)+(JN1(N)-1)*IM - IJN21(N)=IN2(N)+(JN1(N)-1)*IM - IJN12(N)=IN1(N)+(JN2(N)-1)*IM - IJN22(N)=IN2(N)+(JN2(N)-1)*IM - IJS11(N)=IS1(N)+(JS1(N)-1)*IM - IJS21(N)=IS2(N)+(JS1(N)-1)*IM - IJS12(N)=IS1(N)+(JS2(N)-1)*IM - IJS22(N)=IS2(N)+(JS2(N)-1)*IM - ENDDO - IF(KM.EQ.1) THEN -cCDIR$ IVDEP - DO N=1,NXQ - IF(IBM.EQ.0) THEN - BN(I,J,1)=BN(I,J,1)+WJN1(N)*WIN1(N)*B(IJN11(N),1) - & +WJN1(N)*WIN2(N)*B(IJN21(N),1) - & +WJN2(N)*WIN1(N)*B(IJN12(N),1) - & +WJN2(N)*WIN2(N)*B(IJN22(N),1) - BS(I,J,1)=BS(I,J,1)+WJS1(N)*WIS1(N)*B(IJS11(N),1) - & +WJS1(N)*WIS2(N)*B(IJS21(N),1) - & +WJS2(N)*WIS1(N)*B(IJS12(N),1) - & +WJS2(N)*WIS2(N)*B(IJS22(N),1) - ELSE - IF(LB(IJN11(N),1)) THEN - BN(I,J,1)=BN(I,J,1)+WIN1(N)*WJN1(N)*B(IJN11(N),1) - WN(I,J,1)=WN(I,J,1)+WIN1(N)*WJN1(N) - ENDIF - IF(LB(IJN21(N),1)) THEN - BN(I,J,1)=BN(I,J,1)+WIN2(N)*WJN1(N)*B(IJN21(N),1) - WN(I,J,1)=WN(I,J,1)+WIN2(N)*WJN1(N) - ENDIF - IF(LB(IJN12(N),1)) THEN - BN(I,J,1)=BN(I,J,1)+WIN1(N)*WJN2(N)*B(IJN12(N),1) - WN(I,J,1)=WN(I,J,1)+WIN1(N)*WJN2(N) - ENDIF - IF(LB(IJN22(N),1)) THEN - BN(I,J,1)=BN(I,J,1)+WIN2(N)*WJN2(N)*B(IJN22(N),1) - WN(I,J,1)=WN(I,J,1)+WIN2(N)*WJN2(N) - ENDIF - IF(LB(IJS11(N),1)) THEN - BS(I,J,1)=BS(I,J,1)+WIS1(N)*WJS1(N)*B(IJS11(N),1) - WS(I,J,1)=WS(I,J,1)+WIS1(N)*WJS1(N) - ENDIF - IF(LB(IJS21(N),1)) THEN - BS(I,J,1)=BS(I,J,1)+WIS2(N)*WJS1(N)*B(IJS21(N),1) - WS(I,J,1)=WS(I,J,1)+WIS2(N)*WJS1(N) - ENDIF - IF(LB(IJS12(N),1)) THEN - BS(I,J,1)=BS(I,J,1)+WIS1(N)*WJS2(N)*B(IJS12(N),1) - WS(I,J,1)=WS(I,J,1)+WIS1(N)*WJS2(N) - ENDIF - IF(LB(IJS22(N),1)) THEN - BS(I,J,1)=BS(I,J,1)+WIS2(N)*WJS2(N)*B(IJS22(N),1) - WS(I,J,1)=WS(I,J,1)+WIS2(N)*WJS2(N) - ENDIF - ENDIF - ENDDO - ELSE - DO N=1,NXQ - IF(IBM.EQ.0) THEN - DO K=1,KM - BN(I,J,K)=BN(I,J,K)+WJN1(N)*WIN1(N)*B(IJN11(N),K) - & +WJN1(N)*WIN2(N)*B(IJN21(N),K) - & +WJN2(N)*WIN1(N)*B(IJN12(N),K) - & +WJN2(N)*WIN2(N)*B(IJN22(N),K) - BS(I,J,K)=BS(I,J,K)+WJS1(N)*WIS1(N)*B(IJS11(N),K) - & +WJS1(N)*WIS2(N)*B(IJS21(N),K) - & +WJS2(N)*WIS1(N)*B(IJS12(N),K) - & +WJS2(N)*WIS2(N)*B(IJS22(N),K) - ENDDO - ELSE - DO K=1,KM - IF(LB(IJN11(N),K)) THEN - BN(I,J,K)=BN(I,J,K)+WIN1(N)*WJN1(N)*B(IJN11(N),K) - WN(I,J,K)=WN(I,J,K)+WIN1(N)*WJN1(N) - ENDIF - IF(LB(IJN21(N),K)) THEN - BN(I,J,K)=BN(I,J,K)+WIN2(N)*WJN1(N)*B(IJN21(N),K) - WN(I,J,K)=WN(I,J,K)+WIN2(N)*WJN1(N) - ENDIF - IF(LB(IJN12(N),K)) THEN - BN(I,J,K)=BN(I,J,K)+WIN1(N)*WJN2(N)*B(IJN12(N),K) - WN(I,J,K)=WN(I,J,K)+WIN1(N)*WJN2(N) - ENDIF - IF(LB(IJN22(N),K)) THEN - BN(I,J,K)=BN(I,J,K)+WIN2(N)*WJN2(N)*B(IJN22(N),K) - WN(I,J,K)=WN(I,J,K)+WIN2(N)*WJN2(N) - ENDIF - IF(LB(IJS11(N),K)) THEN - BS(I,J,K)=BS(I,J,K)+WIS1(N)*WJS1(N)*B(IJS11(N),K) - WS(I,J,K)=WS(I,J,K)+WIS1(N)*WJS1(N) - ENDIF - IF(LB(IJS21(N),K)) THEN - BS(I,J,K)=BS(I,J,K)+WIS2(N)*WJS1(N)*B(IJS21(N),K) - WS(I,J,K)=WS(I,J,K)+WIS2(N)*WJS1(N) - ENDIF - IF(LB(IJS12(N),K)) THEN - BS(I,J,K)=BS(I,J,K)+WIS1(N)*WJS2(N)*B(IJS12(N),K) - WS(I,J,K)=WS(I,J,K)+WIS1(N)*WJS2(N) - ENDIF - IF(LB(IJS22(N),K)) THEN - BS(I,J,K)=BS(I,J,K)+WIS2(N)*WJS2(N)*B(IJS22(N),K) - WS(I,J,K)=WS(I,J,K)+WIS2(N)*WJS2(N) - ENDIF - ENDDO - ENDIF - ENDDO - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -cCDIR$ IVDEP - IF(KM.EQ.1) THEN -cCDIR$ IVDEP - DO IJ=1,NPS*NPS - J=(IJ-1)/NPS+1 - I=IJ-(J-1)*NPS - IF(IBM.EQ.0) THEN - BN(I,J,1)=BN(I,J,1)/NXQ - BS(I,J,1)=BS(I,J,1)/NXQ - ELSE - LBN(I,J,1)=WN(I,J,1).GE.0.5*NXQ - IF(LBN(I,J,1)) THEN - BN(I,J,1)=BN(I,J,1)/WN(I,J,1) - ELSE - BN(I,J,1)=0. - ENDIF - LBS(I,J,1)=WS(I,J,1).GE.0.5*NXQ - IF(LBS(I,J,1)) THEN - BS(I,J,1)=BS(I,J,1)/WS(I,J,1) - ELSE - BS(I,J,1)=0. - ENDIF - ENDIF - ENDDO - ELSE - DO IJ=1,NPS*NPS - J=(IJ-1)/NPS+1 - I=IJ-(J-1)*NPS - IF(IBM.EQ.0) THEN - DO K=1,KM - BN(I,J,K)=BN(I,J,K)/NXQ - BS(I,J,K)=BS(I,J,K)/NXQ - ENDDO - ELSE - DO K=1,KM - LBN(I,J,K)=WN(I,J,K).GE.0.5*NXQ - IF(LBN(I,J,K)) THEN - BN(I,J,K)=BN(I,J,K)/WN(I,J,K) - ELSE - BN(I,J,K)=0. - ENDIF - LBS(I,J,K)=WS(I,J,K).GE.0.5*NXQ - IF(LBS(I,J,K)) THEN - BS(I,J,K)=BS(I,J,K)/WS(I,J,K) - ELSE - BS(I,J,K)=0. - ENDIF - ENDDO - ENDIF - ENDDO - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/ncpus.f b/src/fim/FIMsrc/prep/sp/ncpus.f deleted file mode 100644 index 2824707..0000000 --- a/src/fim/FIMsrc/prep/sp/ncpus.f +++ /dev/null @@ -1,32 +0,0 @@ -C----------------------------------------------------------------------- - FUNCTION NCPUS() -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: NCPUS SET NUMBER OF CPUS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-08-19 -C -C ABSTRACT: SET NUMBER OF CPUS -C DESIGNATING THE NUMBER OF PROCESSORS OVER WHICH TO PARALLELIZE. -C -C PROGRAM HISTORY LOG: -C 94-08-19 IREDELL -C 98-11-09 VUONG ADD DOC BLOCK AND REMOVE CRAY REFERENCES -C 1998-12-18 IREDELL IBM SMP VERSION -C -C USAGE: NC=NCPUS() -C OUTPUT ARGUMENTS: -C NCPUS INTEGER NUMBER OF CPUS -C -C SUBPROGRAMS CALLED: -C NUM_PARTHDS XLF INTRINSIC TO RETURN NUMBER OF THREADS -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN -C -C$$$ -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -c NCPUS=omp_get_num_threads() -c NCPUS=NUM_PARTHDS() - NCPUS=1 - RETURN - END diff --git a/src/fim/FIMsrc/prep/sp/spanaly.f b/src/fim/FIMsrc/prep/sp/spanaly.f deleted file mode 100644 index 6a58d11..0000000 --- a/src/fim/FIMsrc/prep/sp/spanaly.f +++ /dev/null @@ -1,89 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPANALY(I,M,IM,IX,NC,NCTOP,KM,WGT,CLAT,PLN,PLNTOP,MP, - & F,SPC,SPCTOP) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPANALY ANALYZE SPECTRAL FROM FOURIER -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: ANALYZES SPECTRAL COEFFICIENTS FROM FOURIER COEFFICIENTS -C FOR A LATITUDE PAIR (NORTHERN AND SOUTHERN HEMISPHERES). -C VECTOR COMPONENTS ARE MULTIPLIED BY COSINE OF LATITUDE. -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C 94-08-01 MARK IREDELL MOVED ZONAL WAVENUMBER LOOP INSIDE -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPANALY(I,M,IM,IX,NC,NCTOP,KM,WGT,CLAT,PLN,PLNTOP,MP, -C & F,SPC,SPCTOP) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C IM - INTEGER EVEN NUMBER OF FOURIER COEFFICIENTS -C IX - INTEGER DIMENSION OF FOURIER COEFFICIENTS (IX>=IM+2) -C NC - INTEGER DIMENSION OF SPECTRAL COEFFICIENTS -C (NC>=(M+1)*((I+1)*M+2)) -C NCTOP - INTEGER DIMENSION OF SPECTRAL COEFFICIENTS OVER TOP -C (NCTOP>=2*(M+1)) -C KM - INTEGER NUMBER OF FIELDS -C WGT - REAL GAUSSIAN WEIGHT -C CLAT - REAL COSINE OF LATITUDE -C PLN - REAL ((M+1)*((I+1)*M+2)/2) LEGENDRE POLYNOMIALS -C PLNTOP - REAL (M+1) LEGENDRE POLYNOMIAL OVER TOP -C MP - INTEGER (KM) IDENTIFIERS (0 FOR SCALAR, 1 FOR VECTOR) -C F - REAL (IX,2,KM) FOURIER COEFFICIENTS COMBINED -C SPC - REAL (NC,KM) SPECTRAL COEFFICIENTS -C SPCTOP - REAL (NCTOP,KM) SPECTRAL COEFFICIENTS OVER TOP -C -C OUTPUT ARGUMENT LIST: -C SPC - REAL (NC,KM) SPECTRAL COEFFICIENTS -C SPCTOP - REAL (NCTOP,KM) SPECTRAL COEFFICIENTS OVER TOP -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - INTEGER MP(KM) - REAL PLN((M+1)*((I+1)*M+2)/2),PLNTOP(M+1) - REAL F(IX,2,KM) - REAL SPC(NC,KM),SPCTOP(NCTOP,KM) - REAL FW(2,2) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C FOR EACH ZONAL WAVENUMBER, ANALYZE TERMS OVER TOTAL WAVENUMBER. -C ANALYZE EVEN AND ODD POLYNOMIALS SEPARATELY. - LX=MIN(M,IM/2) -!C$OMP PARALLEL DO PRIVATE(L,NT,KS,KP,FW) - DO K=1,KM - DO L=0,LX - NT=MOD(M+1+(I-1)*L,2)+1 - KS=L*(2*M+(I-1)*(L-1)) - KP=KS/2+1 - IF(MP(K).EQ.0) THEN - FW(1,1)=WGT*(F(2*L+1,1,K)+F(2*L+1,2,K)) - FW(2,1)=WGT*(F(2*L+2,1,K)+F(2*L+2,2,K)) - FW(1,2)=WGT*(F(2*L+1,1,K)-F(2*L+1,2,K)) - FW(2,2)=WGT*(F(2*L+2,1,K)-F(2*L+2,2,K)) - ELSE - FW(1,1)=WGT*CLAT*(F(2*L+1,1,K)+F(2*L+1,2,K)) - FW(2,1)=WGT*CLAT*(F(2*L+2,1,K)+F(2*L+2,2,K)) - FW(1,2)=WGT*CLAT*(F(2*L+1,1,K)-F(2*L+1,2,K)) - FW(2,2)=WGT*CLAT*(F(2*L+2,1,K)-F(2*L+2,2,K)) - SPCTOP(2*L+1,K)=SPCTOP(2*L+1,K)+PLNTOP(L+1)*FW(1,NT) - SPCTOP(2*L+2,K)=SPCTOP(2*L+2,K)+PLNTOP(L+1)*FW(2,NT) - ENDIF - DO N=L,I*L+M,2 - SPC(KS+2*N+1,K)=SPC(KS+2*N+1,K)+PLN(KP+N)*FW(1,1) - SPC(KS+2*N+2,K)=SPC(KS+2*N+2,K)+PLN(KP+N)*FW(2,1) - ENDDO - DO N=L+1,I*L+M,2 - SPC(KS+2*N+1,K)=SPC(KS+2*N+1,K)+PLN(KP+N)*FW(1,2) - SPC(KS+2*N+2,K)=SPC(KS+2*N+2,K)+PLN(KP+N)*FW(2,2) - ENDDO - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/prep/sp/spdz2uv.f b/src/fim/FIMsrc/prep/sp/spdz2uv.f deleted file mode 100644 index 2ec5796..0000000 --- a/src/fim/FIMsrc/prep/sp/spdz2uv.f +++ /dev/null @@ -1,85 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPDZ2UV(I,M,ENN1,ELONN1,EON,EONTOP,D,Z,U,V,UTOP,VTOP) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPDZ2UV COMPUTE WINDS FROM DIVERGENCE AND VORTICITY -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: COMPUTES THE WIND COMPONENTS FROM DIVERGENCE AND VORTICITY -C IN SPECTRAL SPACE. -C SUBPROGRAM SPEPS SHOULD BE CALLED ALREADY. -C IF L IS THE ZONAL WAVENUMBER, N IS THE TOTAL WAVENUMBER, -C EPS(L,N)=SQRT((N**2-L**2)/(4*N**2-1)) AND A IS EARTH RADIUS, -C THEN THE ZONAL WIND COMPONENT U IS COMPUTED AS -C U(L,N)=-I*L/(N*(N+1))*A*D(L,N) -C +EPS(L,N+1)/(N+1)*A*Z(L,N+1)-EPS(L,N)/N*A*Z(L,N-1) -C AND THE MERIDIONAL WIND COMPONENT V IS COMPUTED AS -C V(L,N)=-I*L/(N*(N+1))*A*Z(L,N) -C -EPS(L,N+1)/(N+1)*A*D(L,N+1)+EPS(L,N)/N*A*D(L,N-1) -C WHERE D IS DIVERGENCE AND Z IS VORTICITY. -C U AND V ARE WEIGHTED BY THE COSINE OF LATITUDE. -C EXTRA TERMS ARE COMPUTED OVER TOP OF THE SPECTRAL DOMAIN. -C ADVANTAGE IS TAKEN OF THE FACT THAT EPS(L,L)=0 -C IN ORDER TO VECTORIZE OVER THE ENTIRE SPECTRAL DOMAIN. -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C -C USAGE: CALL SPDZ2UV(I,M,ENN1,ELONN1,EON,EONTOP,D,Z,U,V,UTOP,VTOP) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C ENN1 - REAL ((M+1)*((I+1)*M+2)/2) N*(N+1)/A**2 -C ELONN1 - REAL ((M+1)*((I+1)*M+2)/2) L/(N*(N+1))*A -C EON - REAL ((M+1)*((I+1)*M+2)/2) EPSILON/N*A -C EONTOP - REAL (M+1) EPSILON/N*A OVER TOP -C D - REAL ((M+1)*((I+1)*M+2)) DIVERGENCE -C Z - REAL ((M+1)*((I+1)*M+2)) VORTICITY -C -C OUTPUT ARGUMENT LIST: -C U - REAL ((M+1)*((I+1)*M+2)) ZONAL WIND (TIMES COSLAT) -C V - REAL ((M+1)*((I+1)*M+2)) MERID WIND (TIMES COSLAT) -C UTOP - REAL (2*(M+1)) ZONAL WIND (TIMES COSLAT) OVER TOP -C VTOP - REAL (2*(M+1)) MERID WIND (TIMES COSLAT) OVER TOP -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - REAL ENN1((M+1)*((I+1)*M+2)/2),ELONN1((M+1)*((I+1)*M+2)/2) - REAL EON((M+1)*((I+1)*M+2)/2),EONTOP(M+1) - REAL D((M+1)*((I+1)*M+2)),Z((M+1)*((I+1)*M+2)) - REAL U((M+1)*((I+1)*M+2)),V((M+1)*((I+1)*M+2)) - REAL UTOP(2*(M+1)),VTOP(2*(M+1)) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COMPUTE WINDS IN THE SPECTRAL DOMAIN - K=1 - U(2*K-1)=EON(K+1)*Z(2*K+1) - U(2*K)=EON(K+1)*Z(2*K+2) - V(2*K-1)=-EON(K+1)*D(2*K+1) - V(2*K)=-EON(K+1)*D(2*K+2) - DO K=2,(M+1)*((I+1)*M+2)/2-1 - U(2*K-1)=ELONN1(K)*D(2*K)+EON(K+1)*Z(2*K+1)-EON(K)*Z(2*K-3) - U(2*K)=-ELONN1(K)*D(2*K-1)+EON(K+1)*Z(2*K+2)-EON(K)*Z(2*K-2) - V(2*K-1)=ELONN1(K)*Z(2*K)-EON(K+1)*D(2*K+1)+EON(K)*D(2*K-3) - V(2*K)=-ELONN1(K)*Z(2*K-1)-EON(K+1)*D(2*K+2)+EON(K)*D(2*K-2) - ENDDO - K=(M+1)*((I+1)*M+2)/2 - U(2*K-1)=ELONN1(K)*D(2*K)-EON(K)*Z(2*K-3) - U(2*K)=-ELONN1(K)*D(2*K-1)-EON(K)*Z(2*K-2) - V(2*K-1)=ELONN1(K)*Z(2*K)+EON(K)*D(2*K-3) - V(2*K)=-ELONN1(K)*Z(2*K-1)+EON(K)*D(2*K-2) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COMPUTE WINDS OVER TOP OF THE SPECTRAL DOMAIN - DO L=0,M - K=L*(2*M+(I-1)*(L-1))/2+I*L+M+1 - UTOP(2*L+1)=-EONTOP(L+1)*Z(2*K-1) - UTOP(2*L+2)=-EONTOP(L+1)*Z(2*K) - VTOP(2*L+1)=EONTOP(L+1)*D(2*K-1) - VTOP(2*L+2)=EONTOP(L+1)*D(2*K) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/prep/sp/speps.f b/src/fim/FIMsrc/prep/sp/speps.f deleted file mode 100644 index bb7ad72..0000000 --- a/src/fim/FIMsrc/prep/sp/speps.f +++ /dev/null @@ -1,67 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPEPS(I,M,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPEPS COMPUTE UTILITY SPECTRAL FIELDS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: COMPUTES CONSTANT FIELDS INDEXED IN THE SPECTRAL DOMAIN -C IN "IBM ORDER" (ZONAL WAVENUMBER IS THE SLOWER INDEX). -C IF L IS THE ZONAL WAVENUMBER AND N IS THE TOTAL WAVENUMBER -C AND A IS THE EARTH RADIUS, THEN THE FIELDS RETURNED ARE: -C (1) NORMALIZING FACTOR EPSILON=SQRT((N**2-L**2)/(4*N**2-1)) -C (2) LAPLACIAN FACTOR N*(N+1)/A**2 -C (3) ZONAL DERIVATIVE/LAPLACIAN FACTOR L/(N*(N+1))*A -C (4) MERIDIONAL DERIVATIVE/LAPLACIAN FACTOR EPSILON/N*A -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C -C USAGE: CALL SPEPS(I,M,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C -C OUTPUT ARGUMENT LIST: -C EPS - REAL ((M+1)*((I+1)*M+2)/2) SQRT((N**2-L**2)/(4*N**2-1)) -C EPSTOP - REAL (M+1) SQRT((N**2-L**2)/(4*N**2-1)) OVER TOP -C ENN1 - REAL ((M+1)*((I+1)*M+2)/2) N*(N+1)/A**2 -C ELONN1 - REAL ((M+1)*((I+1)*M+2)/2) L/(N*(N+1))*A -C EON - REAL ((M+1)*((I+1)*M+2)/2) EPSILON/N*A -C EONTOP - REAL (M+1) EPSILON/N*A OVER TOP -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - REAL EPS((M+1)*((I+1)*M+2)/2),EPSTOP(M+1) - REAL ENN1((M+1)*((I+1)*M+2)/2),ELONN1((M+1)*((I+1)*M+2)/2) - REAL EON((M+1)*((I+1)*M+2)/2),EONTOP(M+1) - PARAMETER(RERTH=6.3712E6,RA2=1./RERTH**2) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - DO L=0,M - K=L*(2*M+(I-1)*(L-1))/2+L+1 - EPS(K)=0. - ENN1(K)=RA2*L*(L+1) - ELONN1(K)=RERTH/(L+1) - EON(K)=0. - ENDDO - DO L=0,M - DO N=L+1,I*L+M - K=L*(2*M+(I-1)*(L-1))/2+N+1 - EPS(K)=SQRT(FLOAT(N**2-L**2)/FLOAT(4*N**2-1)) - ENN1(K)=RA2*N*(N+1) - ELONN1(K)=RERTH*L/(N*(N+1)) - EON(K)=RERTH/N*EPS(K) - ENDDO - ENDDO - DO L=0,M - N=I*L+M+1 - EPSTOP(L+1)=SQRT(FLOAT(N**2-L**2)/FLOAT(4*N**2-1)) - EONTOP(L+1)=RERTH/N*EPSTOP(L+1) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/prep/sp/spfft.f b/src/fim/FIMsrc/prep/sp/spfft.f deleted file mode 100644 index d429aac..0000000 --- a/src/fim/FIMsrc/prep/sp/spfft.f +++ /dev/null @@ -1,93 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPFFT(IMAX,INCW,INCG,KMAX,W,G,IDIR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPFFT PERFORM MULTIPLE FAST FOURIER TRANSFORMS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-20 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS MULTIPLE FAST FOURIER TRANSFORMS -C BETWEEN COMPLEX AMPLITUDES IN FOURIER SPACE AND REAL VALUES -C IN CYCLIC PHYSICAL SPACE. -C SUBPROGRAM SPFFT MUST BE INVOKED FIRST WITH IDIR=0 -C TO INITIALIZE TRIGONEMETRIC DATA. USE SUBPROGRAM SPFFT1 -C TO PERFORM AN FFT WITHOUT PREVIOUS INITIALIZATION. -C THIS VERSION INVOKES THE IBM ESSL FFT. -C -C PROGRAM HISTORY LOG: -C 1998-12-18 IREDELL -C -C USAGE: CALL SPFFT(IMAX,INCW,INCG,KMAX,W,G,IDIR) -C -C INPUT ARGUMENT LIST: -C IMAX - INTEGER NUMBER OF VALUES IN THE CYCLIC PHYSICAL SPACE -C (SEE LIMITATIONS ON IMAX IN REMARKS BELOW.) -C INCW - INTEGER FIRST DIMENSION OF THE COMPLEX AMPLITUDE ARRAY -C (INCW >= IMAX/2+1) -C INCG - INTEGER FIRST DIMENSION OF THE REAL VALUE ARRAY -C (INCG >= IMAX) -C KMAX - INTEGER NUMBER OF TRANSFORMS TO PERFORM -C W - COMPLEX(INCW,KMAX) COMPLEX AMPLITUDES IF IDIR>0 -C G - REAL(INCG,KMAX) REAL VALUES IF IDIR<0 -C IDIR - INTEGER DIRECTION FLAG -C IDIR=0 TO INITIALIZE INTERNAL TRIGONOMETRIC DATA -C IDIR>0 TO TRANSFORM FROM FOURIER TO PHYSICAL SPACE -C IDIR<0 TO TRANSFORM FROM PHYSICAL TO FOURIER SPACE -C -C OUTPUT ARGUMENT LIST: -C W - COMPLEX(INCW,KMAX) COMPLEX AMPLITUDES IF IDIR<0 -C G - REAL(INCG,KMAX) REAL VALUES IF IDIR>0 -C -C SUBPROGRAMS CALLED: -C SCRFT IBM ESSL COMPLEX TO REAL FOURIER TRANSFORM -C SRCFT IBM ESSL REAL TO COMPLEX FOURIER TRANSFORM -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C REMARKS: -C THE RESTRICTIONS ON IMAX ARE THAT IT MUST BE A MULTIPLE -C OF 1 TO 25 FACTORS OF TWO, UP TO 2 FACTORS OF THREE, -C AND UP TO 1 FACTOR OF FIVE, SEVEN AND ELEVEN. -C -C IF IDIR=0, THEN W AND G NEED NOT CONTAIN ANY VALID DATA. -C THE OTHER PARAMETERS MUST BE SUPPLIED AND CANNOT CHANGE -C IN SUCCEEDING CALLS UNTIL THE NEXT TIME IT IS CALLED WITH IDIR=0. -C -C THIS SUBPROGRAM IS NOT THREAD-SAFE WHEN IDIR=0. ON THE OTHER HAND, -C WHEN IDIR IS NOT ZERO, IT CAN BE CALLED FROM A THREADED REGION. -C -C$$$ - IMPLICIT NONE - INTEGER,INTENT(IN):: IMAX,INCW,INCG,KMAX,IDIR - COMPLEX,INTENT(INOUT):: W(INCW,KMAX) - REAL,INTENT(INOUT):: G(INCG,KMAX) - INTEGER,SAVE:: NAUX1=0 - REAL,SAVE,ALLOCATABLE:: AUX1CR(:),AUX1RC(:) - INTEGER:: NAUX2 - REAL:: AUX2(20000+INT(0.57*IMAX)) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - NAUX2=20000+INT(0.57*IMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C INITIALIZATION. -C ALLOCATE AND FILL AUXILIARY ARRAYS WITH TRIGONOMETRIC DATA - SELECT CASE(IDIR) - CASE(0) - IF(NAUX1.GT.0) DEALLOCATE(AUX1CR,AUX1RC) - NAUX1=25000+INT(0.82*IMAX) - ALLOCATE(AUX1CR(NAUX1),AUX1RC(NAUX1)) - CALL SCRFT(1,W,INCW,G,INCG,IMAX,KMAX,-1,1., - & AUX1CR,NAUX1,AUX2,NAUX2,0.,0) - CALL SRCFT(1,G,INCG,W,INCW,IMAX,KMAX,+1,1./IMAX, - & AUX1RC,NAUX1,AUX2,NAUX2,0.,0) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C FOURIER TO PHYSICAL TRANSFORM. - CASE(1:) - CALL SCRFT(0,W,INCW,G,INCG,IMAX,KMAX,-1,1., - & AUX1CR,NAUX1,AUX2,NAUX2,0.,0) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C PHYSICAL TO FOURIER TRANSFORM. - CASE(:-1) - CALL SRCFT(0,G,INCG,W,INCW,IMAX,KMAX,+1,1./IMAX, - & AUX1RC,NAUX1,AUX2,NAUX2,0.,0) - END SELECT - END SUBROUTINE diff --git a/src/fim/FIMsrc/prep/sp/spfft1.f b/src/fim/FIMsrc/prep/sp/spfft1.f deleted file mode 100644 index fe506a5..0000000 --- a/src/fim/FIMsrc/prep/sp/spfft1.f +++ /dev/null @@ -1,79 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPFFT1(IMAX,INCW,INCG,KMAX,W,G,IDIR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPFFT1 PERFORM MULTIPLE FAST FOURIER TRANSFORMS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-20 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS MULTIPLE FAST FOURIER TRANSFORMS -C BETWEEN COMPLEX AMPLITUDES IN FOURIER SPACE AND REAL VALUES -C IN CYCLIC PHYSICAL SPACE. -C SUBPROGRAM SPFFT1 INITIALIZES TRIGONOMETRIC DATA EACH CALL. -C USE SUBPROGRAM SPFFT TO SAVE TIME AND INITIALIZE ONCE. -C THIS VERSION INVOKES THE IBM ESSL FFT. -C -C PROGRAM HISTORY LOG: -C 1998-12-18 IREDELL -C -C USAGE: CALL SPFFT1(IMAX,INCW,INCG,KMAX,W,G,IDIR) -C -C INPUT ARGUMENT LIST: -C IMAX - INTEGER NUMBER OF VALUES IN THE CYCLIC PHYSICAL SPACE -C (SEE LIMITATIONS ON IMAX IN REMARKS BELOW.) -C INCW - INTEGER FIRST DIMENSION OF THE COMPLEX AMPLITUDE ARRAY -C (INCW >= IMAX/2+1) -C INCG - INTEGER FIRST DIMENSION OF THE REAL VALUE ARRAY -C (INCG >= IMAX) -C KMAX - INTEGER NUMBER OF TRANSFORMS TO PERFORM -C W - COMPLEX(INCW,KMAX) COMPLEX AMPLITUDES IF IDIR>0 -C G - REAL(INCG,KMAX) REAL VALUES IF IDIR<0 -C IDIR - INTEGER DIRECTION FLAG -C IDIR>0 TO TRANSFORM FROM FOURIER TO PHYSICAL SPACE -C IDIR<0 TO TRANSFORM FROM PHYSICAL TO FOURIER SPACE -C -C OUTPUT ARGUMENT LIST: -C W - COMPLEX(INCW,KMAX) COMPLEX AMPLITUDES IF IDIR<0 -C G - REAL(INCG,KMAX) REAL VALUES IF IDIR>0 -C -C SUBPROGRAMS CALLED: -C SCRFT IBM ESSL COMPLEX TO REAL FOURIER TRANSFORM -C SRCFT IBM ESSL REAL TO COMPLEX FOURIER TRANSFORM -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C REMARKS: -C THE RESTRICTIONS ON IMAX ARE THAT IT MUST BE A MULTIPLE -C OF 1 TO 25 FACTORS OF TWO, UP TO 2 FACTORS OF THREE, -C AND UP TO 1 FACTOR OF FIVE, SEVEN AND ELEVEN. -C -C THIS SUBPROGRAM IS THREAD-SAFE. -C -C$$$ - IMPLICIT NONE - INTEGER,INTENT(IN):: IMAX,INCW,INCG,KMAX,IDIR - COMPLEX,INTENT(INOUT):: W(INCW,KMAX) - REAL,INTENT(INOUT):: G(INCG,KMAX) - REAL:: AUX1(25000+INT(0.82*IMAX)) - REAL:: AUX2(20000+INT(0.57*IMAX)) - INTEGER:: NAUX1,NAUX2 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - NAUX1=25000+INT(0.82*IMAX) - NAUX2=20000+INT(0.57*IMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C FOURIER TO PHYSICAL TRANSFORM. - SELECT CASE(IDIR) - CASE(1:) - CALL SCRFT(1,W,INCW,G,INCG,IMAX,KMAX,-1,1., - & AUX1,NAUX1,AUX2,NAUX2,0.,0) - CALL SCRFT(0,W,INCW,G,INCG,IMAX,KMAX,-1,1., - & AUX1,NAUX1,AUX2,NAUX2,0.,0) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C PHYSICAL TO FOURIER TRANSFORM. - CASE(:-1) - CALL SRCFT(1,G,INCG,W,INCW,IMAX,KMAX,+1,1./IMAX, - & AUX1,NAUX1,AUX2,NAUX2,0.,0) - CALL SRCFT(0,G,INCG,W,INCW,IMAX,KMAX,+1,1./IMAX, - & AUX1,NAUX1,AUX2,NAUX2,0.,0) - END SELECT - END SUBROUTINE diff --git a/src/fim/FIMsrc/prep/sp/spffte.f b/src/fim/FIMsrc/prep/sp/spffte.f deleted file mode 100644 index 6f3d98f..0000000 --- a/src/fim/FIMsrc/prep/sp/spffte.f +++ /dev/null @@ -1,1058 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPFFTE(IMAX,INCW,INCG,KMAX,W,G,IDIR,AFFT) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPFFTE PERFORM MULTIPLE FAST FOURIER TRANSFORMS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-20 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS MULTIPLE FAST FOURIER TRANSFORMS -C BETWEEN COMPLEX AMPLITUDES IN FOURIER SPACE AND REAL VALUES -C IN CYCLIC PHYSICAL SPACE. -C SUBPROGRAM SPFFTE MUST BE INVOKED FIRST WITH IDIR=0 -C TO INITIALIZE TRIGONEMETRIC DATA. USE SUBPROGRAM SPFFT1 -C TO PERFORM AN FFT WITHOUT PREVIOUS INITIALIZATION. -C THIS VERSION INVOKES A GENERIC FFT. -C -C PROGRAM HISTORY LOG: -C 1998-12-18 IREDELL -C -C USAGE: CALL SPFFTE(IMAX,INCW,INCG,KMAX,W,G,IDIR,AFFT) -C -C INPUT ARGUMENT LIST: -C IMAX - INTEGER NUMBER OF VALUES IN THE CYCLIC PHYSICAL SPACE -C (SEE LIMITATIONS ON IMAX IN REMARKS BELOW.) -C INCW - INTEGER FIRST DIMENSION OF THE COMPLEX AMPLITUDE ARRAY -C (INCW >= IMAX/2+1) -C INCG - INTEGER FIRST DIMENSION OF THE REAL VALUE ARRAY -C (INCG >= IMAX) -C KMAX - INTEGER NUMBER OF TRANSFORMS TO PERFORM -C W - COMPLEX(INCW,KMAX) COMPLEX AMPLITUDES IF IDIR>0 -C G - REAL(INCG,KMAX) REAL VALUES IF IDIR<0 -C IDIR - INTEGER DIRECTION FLAG -C IDIR=0 TO INITIALIZE TRIGONOMETRIC DATA -C IDIR>0 TO TRANSFORM FROM FOURIER TO PHYSICAL SPACE -C IDIR<0 TO TRANSFORM FROM PHYSICAL TO FOURIER SPACE -C AFFT REAL(8) (25+2*IMAX) AUXILIARY ARRAY IF IDIR<>0 -C -C OUTPUT ARGUMENT LIST: -C W - COMPLEX(INCW,KMAX) COMPLEX AMPLITUDES IF IDIR<0 -C G - REAL(INCG,KMAX) REAL VALUES IF IDIR>0 -C AFFT REAL(8) (25+2*IMAX) AUXILIARY ARRAY IF IDIR=0 -C -C SUBPROGRAMS CALLED: -C SCRFT IBM ESSL COMPLEX TO REAL FOURIER TRANSFORM -C DCRFT IBM ESSL COMPLEX TO REAL FOURIER TRANSFORM -C SRCFT IBM ESSL REAL TO COMPLEX FOURIER TRANSFORM -C DRCFT IBM ESSL REAL TO COMPLEX FOURIER TRANSFORM -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C REMARKS: -C THE RESTRICTIONS ON IMAX ARE THAT IT MUST BE A MULTIPLE -C OF 1 TO 25 FACTORS OF TWO, UP TO 2 FACTORS OF THREE, -C AND UP TO 1 FACTOR OF FIVE, SEVEN AND ELEVEN. -C -C IF IDIR=0, THEN W AND G NEED NOT CONTAIN ANY VALID DATA. -C THE OTHER PARAMETERS MUST BE SUPPLIED AND CANNOT CHANGE -C IN SUCCEEDING CALLS UNTIL THE NEXT TIME IT IS CALLED WITH IDIR=0. -C -C THIS SUBPROGRAM IS THREAD-SAFE. -C -C$$$ - IMPLICIT NONE - INTEGER,INTENT(IN):: IMAX,INCW,INCG,KMAX,IDIR - REAL,INTENT(INOUT):: W(2*INCW,KMAX) - REAL,INTENT(INOUT):: G(INCG,KMAX) - INTEGER:: I,K - REAL(8),INTENT(INOUT):: AFFT(25+2*IMAX) - REAL(8):: T(IMAX+2) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C INITIALIZATION. - SELECT CASE(IDIR) - CASE(0) - CALL RFFTI(IMAX,AFFT) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C FOURIER TO PHYSICAL TRANSFORM. - CASE(1:) - DO K=1,KMAX - T(1)=W(1,K) - DO I=2,IMAX - T(I)=W(I+1,K) - ENDDO - CALL RFFTB(IMAX,T,AFFT) - DO I=1,IMAX - G(I,K)=T(I) - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C PHYSICAL TO FOURIER TRANSFORM. - CASE(:-1) - DO K=1,KMAX - DO I=1,IMAX - T(I)=G(I,K) - ENDDO - CALL RFFTF(IMAX,T,AFFT) - W(1,K)=T(1)/IMAX - W(2,K)=0. - DO I=2,IMAX - W(I+1,K)=T(I)/IMAX - ENDDO - W(IMAX+2,K)=0. - ENDDO - END SELECT - END SUBROUTINE -C -C ****************************************************************** -C ****************************************************************** -C ****** ****** -C ****** FFTPACK ****** -C ****** ****** -C ****************************************************************** -C ****************************************************************** -C - SUBROUTINE RFFTF (N,R,WSAVE) - IMPLICIT NONE - REAL (KIND=8) R(1) ,WSAVE(1) - INTEGER N - IF (N .EQ. 1) RETURN - CALL RFFTF1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1)) - RETURN - END - SUBROUTINE RFFTB (N,R,WSAVE) - IMPLICIT NONE - REAL (KIND=8) R(1) ,WSAVE(1) - INTEGER N - IF (N .EQ. 1) RETURN - CALL RFFTB1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1)) - RETURN - END - SUBROUTINE RFFTI (N,WSAVE) - IMPLICIT NONE - REAL (KIND=8) WSAVE(1) - INTEGER N - IF (N .EQ. 1) RETURN - CALL RFFTI1 (N,WSAVE(N+1),WSAVE(2*N+1)) - RETURN - END - SUBROUTINE RFFTB1 (N,C,CH,WA,IFAC) - IMPLICIT NONE - REAL (KIND=8) CH(1) ,C(1) ,WA(1) - INTEGER IFAC(*),N,NF,NA,L1,IW,K1,IP,L2,IDO,IDL1,IX2,IX3,I,IX4 - NF = IFAC(2) - NA = 0 - L1 = 1 - IW = 1 - DO 116 K1=1,NF - IP = IFAC(K1+2) - L2 = IP*L1 - IDO = N/L2 - IDL1 = IDO*L1 - IF (IP .NE. 4) GO TO 103 - IX2 = IW+IDO - IX3 = IX2+IDO - IF (NA .NE. 0) GO TO 101 - CALL RADB4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) - GO TO 102 - 101 CALL RADB4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) - 102 NA = 1-NA - GO TO 115 - 103 IF (IP .NE. 2) GO TO 106 - IF (NA .NE. 0) GO TO 104 - CALL RADB2 (IDO,L1,C,CH,WA(IW)) - GO TO 105 - 104 CALL RADB2 (IDO,L1,CH,C,WA(IW)) - 105 NA = 1-NA - GO TO 115 - 106 IF (IP .NE. 3) GO TO 109 - IX2 = IW+IDO - IF (NA .NE. 0) GO TO 107 - CALL RADB3 (IDO,L1,C,CH,WA(IW),WA(IX2)) - GO TO 108 - 107 CALL RADB3 (IDO,L1,CH,C,WA(IW),WA(IX2)) - 108 NA = 1-NA - GO TO 115 - 109 IF (IP .NE. 5) GO TO 112 - IX2 = IW+IDO - IX3 = IX2+IDO - IX4 = IX3+IDO - IF (NA .NE. 0) GO TO 110 - CALL RADB5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) - GO TO 111 - 110 CALL RADB5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) - 111 NA = 1-NA - GO TO 115 - 112 IF (NA .NE. 0) GO TO 113 - CALL RADBG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) - GO TO 114 - 113 CALL RADBG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) - 114 IF (IDO .EQ. 1) NA = 1-NA - 115 L1 = L2 - IW = IW+(IP-1)*IDO - 116 CONTINUE - IF (NA .EQ. 0) RETURN - DO 117 I=1,N - C(I) = CH(I) - 117 CONTINUE - RETURN - END - SUBROUTINE RFFTF1 (N,C,CH,WA,IFAC) - IMPLICIT NONE - REAL (KIND=8) CH(1) ,C(1) ,WA(1) - INTEGER IFAC(*),N,NF,NA,L1,IW,K1,IP,L2,IDO,IDL1,IX2,IX3,KH,I,IX4 - NF = IFAC(2) - NA = 1 - L2 = N - IW = N - DO 111 K1=1,NF - KH = NF-K1 - IP = IFAC(KH+3) - L1 = L2/IP - IDO = N/L2 - IDL1 = IDO*L1 - IW = IW-(IP-1)*IDO - NA = 1-NA - IF (IP .NE. 4) GO TO 102 - IX2 = IW+IDO - IX3 = IX2+IDO - IF (NA .NE. 0) GO TO 101 - CALL RADF4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) - GO TO 110 - 101 CALL RADF4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) - GO TO 110 - 102 IF (IP .NE. 2) GO TO 104 - IF (NA .NE. 0) GO TO 103 - CALL RADF2 (IDO,L1,C,CH,WA(IW)) - GO TO 110 - 103 CALL RADF2 (IDO,L1,CH,C,WA(IW)) - GO TO 110 - 104 IF (IP .NE. 3) GO TO 106 - IX2 = IW+IDO - IF (NA .NE. 0) GO TO 105 - CALL RADF3 (IDO,L1,C,CH,WA(IW),WA(IX2)) - GO TO 110 - 105 CALL RADF3 (IDO,L1,CH,C,WA(IW),WA(IX2)) - GO TO 110 - 106 IF (IP .NE. 5) GO TO 108 - IX2 = IW+IDO - IX3 = IX2+IDO - IX4 = IX3+IDO - IF (NA .NE. 0) GO TO 107 - CALL RADF5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) - GO TO 110 - 107 CALL RADF5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) - GO TO 110 - 108 IF (IDO .EQ. 1) NA = 1-NA - IF (NA .NE. 0) GO TO 109 - CALL RADFG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) - NA = 1 - GO TO 110 - 109 CALL RADFG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) - NA = 0 - 110 L2 = L1 - 111 CONTINUE - IF (NA .EQ. 1) RETURN - DO 112 I=1,N - C(I) = CH(I) - 112 CONTINUE - RETURN - END - SUBROUTINE RFFTI1 (N,WA,IFAC) - IMPLICIT NONE - REAL (KIND=8) WA(1),TPI,ARGH,ARGLD,FI,ARG - INTEGER IFAC(*),NTRYH(4),NL,N,NF,J,NTRY,NQ,NR,I,IB,IS,NFM1,L1, - & K1,IP,LD,L2,IDO,IPM,II - DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/ - NL = N - NF = 0 - J = 0 - 101 J = J+1 - IF (J-4) 102,102,103 - 102 NTRY = NTRYH(J) - GO TO 104 - 103 NTRY = NTRY+2 - 104 NQ = NL/NTRY - NR = NL-NTRY*NQ - IF (NR) 101,105,101 - 105 NF = NF+1 - IFAC(NF+2) = NTRY - NL = NQ - IF (NTRY .NE. 2) GO TO 107 - IF (NF .EQ. 1) GO TO 107 - DO 106 I=2,NF - IB = NF-I+2 - IFAC(IB+2) = IFAC(IB+1) - 106 CONTINUE - IFAC(3) = 2 - 107 IF (NL .NE. 1) GO TO 104 - IFAC(1) = N - IFAC(2) = NF - TPI = 6.28318530717959 - ARGH = TPI/FLOAT(N) - IS = 0 - NFM1 = NF-1 - L1 = 1 - IF (NFM1 .EQ. 0) RETURN -!OCL NOVREC - DO 110 K1=1,NFM1 - IP = IFAC(K1+2) - LD = 0 - L2 = L1*IP - IDO = N/L2 - IPM = IP-1 - DO 109 J=1,IPM - LD = LD+L1 - I = IS - ARGLD = FLOAT(LD)*ARGH - FI = 0 -!OCL SCALAR - DO 108 II=3,IDO,2 - I = I+2 - FI = FI+1 - ARG = FI*ARGLD - WA(I-1) = COS(ARG) - WA(I) = SIN(ARG) - 108 CONTINUE - IS = IS+IDO - 109 CONTINUE - L1 = L2 - 110 CONTINUE - RETURN - END - SUBROUTINE RADB2 (IDO,L1,CC,CH,WA1) - IMPLICIT NONE - INTEGER IDO,L1,K,IDP2,I,IC - REAL (KIND=8) WA1(1),CC(IDO,2,L1),CH(IDO,L1,2),TR2,TI2 - - DO 101 K=1,L1 - CH(1,K,1) = CC(1,1,K)+CC(IDO,2,K) - CH(1,K,2) = CC(1,1,K)-CC(IDO,2,K) - 101 CONTINUE - IF (IDO-2) 107,105,102 - 102 IDP2 = IDO+2 -!OCL NOVREC - DO 104 K=1,L1 - DO 103 I=3,IDO,2 - IC = IDP2-I - CH(I-1,K,1) = CC(I-1,1,K)+CC(IC-1,2,K) - TR2 = CC(I-1,1,K)-CC(IC-1,2,K) - CH(I,K,1) = CC(I,1,K)-CC(IC,2,K) - TI2 = CC(I,1,K)+CC(IC,2,K) - CH(I-1,K,2) = WA1(I-2)*TR2-WA1(I-1)*TI2 - CH(I,K,2) = WA1(I-2)*TI2+WA1(I-1)*TR2 - 103 CONTINUE - 104 CONTINUE - IF (MOD(IDO,2) .EQ. 1) RETURN - 105 DO 106 K=1,L1 - CH(IDO,K,1) = CC(IDO,1,K)+CC(IDO,1,K) - CH(IDO,K,2) = -(CC(1,2,K)+CC(1,2,K)) - 106 CONTINUE - 107 RETURN - END - SUBROUTINE RADB3 (IDO,L1,CC,CH,WA1,WA2) - IMPLICIT NONE - INTEGER IDO,L1,K,IDP2,I,IC - REAL (KIND=8) CC(IDO,3,L1),CH(IDO,L1,3),WA1(1),WA2(1), - & TR2,CR2,CI3,TAUR,TAUI,DR2,DR3,DI2,DI3, - & CR3,CI2,TI2 - DATA TAUR,TAUI /-.5,.866025403784439/ - - DO 101 K=1,L1 - TR2 = CC(IDO,2,K)+CC(IDO,2,K) - CR2 = CC(1,1,K)+TAUR*TR2 - CH(1,K,1) = CC(1,1,K)+TR2 - CI3 = TAUI*(CC(1,3,K)+CC(1,3,K)) - CH(1,K,2) = CR2-CI3 - CH(1,K,3) = CR2+CI3 - 101 CONTINUE - IF (IDO .EQ. 1) RETURN - IDP2 = IDO+2 -!OCL NOVREC - DO 103 K=1,L1 - DO 102 I=3,IDO,2 - IC = IDP2-I - TR2 = CC(I-1,3,K)+CC(IC-1,2,K) - CR2 = CC(I-1,1,K)+TAUR*TR2 - CH(I-1,K,1) = CC(I-1,1,K)+TR2 - TI2 = CC(I,3,K)-CC(IC,2,K) - CI2 = CC(I,1,K)+TAUR*TI2 - CH(I,K,1) = CC(I,1,K)+TI2 - CR3 = TAUI*(CC(I-1,3,K)-CC(IC-1,2,K)) - CI3 = TAUI*(CC(I,3,K)+CC(IC,2,K)) - DR2 = CR2-CI3 - DR3 = CR2+CI3 - DI2 = CI2+CR3 - DI3 = CI2-CR3 - CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 - CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 - CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 - CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 - 102 CONTINUE - 103 CONTINUE - RETURN - END - SUBROUTINE RADB4 (IDO,L1,CC,CH,WA1,WA2,WA3) - IMPLICIT NONE - INTEGER IDO,L1,K,IDP2,I,IC - REAL (KIND=8) CC(IDO,4,L1),CH(IDO,L1,4),WA1(1),WA2(1), - & WA3(1),TR1,TR2,TR3,TR4,SQRT2,TI1,TI2,TI3, - & TI4,CI3,CR2,CR4,CI2,CI4,CR3 - DATA SQRT2 /1.414213562373095/ - - DO 101 K=1,L1 - TR1 = CC(1,1,K)-CC(IDO,4,K) - TR2 = CC(1,1,K)+CC(IDO,4,K) - TR3 = CC(IDO,2,K)+CC(IDO,2,K) - TR4 = CC(1,3,K)+CC(1,3,K) - CH(1,K,1) = TR2+TR3 - CH(1,K,2) = TR1-TR4 - CH(1,K,3) = TR2-TR3 - CH(1,K,4) = TR1+TR4 - 101 CONTINUE - IF (IDO-2) 107,105,102 - 102 IDP2 = IDO+2 -!OCL NOVREC - DO 104 K=1,L1 - DO 103 I=3,IDO,2 - IC = IDP2-I - TI1 = CC(I,1,K)+CC(IC,4,K) - TI2 = CC(I,1,K)-CC(IC,4,K) - TI3 = CC(I,3,K)-CC(IC,2,K) - TR4 = CC(I,3,K)+CC(IC,2,K) - TR1 = CC(I-1,1,K)-CC(IC-1,4,K) - TR2 = CC(I-1,1,K)+CC(IC-1,4,K) - TI4 = CC(I-1,3,K)-CC(IC-1,2,K) - TR3 = CC(I-1,3,K)+CC(IC-1,2,K) - CH(I-1,K,1) = TR2+TR3 - CR3 = TR2-TR3 - CH(I,K,1) = TI2+TI3 - CI3 = TI2-TI3 - CR2 = TR1-TR4 - CR4 = TR1+TR4 - CI2 = TI1+TI4 - CI4 = TI1-TI4 - CH(I-1,K,2) = WA1(I-2)*CR2-WA1(I-1)*CI2 - CH(I,K,2) = WA1(I-2)*CI2+WA1(I-1)*CR2 - CH(I-1,K,3) = WA2(I-2)*CR3-WA2(I-1)*CI3 - CH(I,K,3) = WA2(I-2)*CI3+WA2(I-1)*CR3 - CH(I-1,K,4) = WA3(I-2)*CR4-WA3(I-1)*CI4 - CH(I,K,4) = WA3(I-2)*CI4+WA3(I-1)*CR4 - 103 CONTINUE - 104 CONTINUE - IF (MOD(IDO,2) .EQ. 1) RETURN - 105 CONTINUE - DO 106 K=1,L1 - TI1 = CC(1,2,K)+CC(1,4,K) - TI2 = CC(1,4,K)-CC(1,2,K) - TR1 = CC(IDO,1,K)-CC(IDO,3,K) - TR2 = CC(IDO,1,K)+CC(IDO,3,K) - CH(IDO,K,1) = TR2+TR2 - CH(IDO,K,2) = SQRT2*(TR1-TI1) - CH(IDO,K,3) = TI2+TI2 - CH(IDO,K,4) = -SQRT2*(TR1+TI1) - 106 CONTINUE - 107 RETURN - END - SUBROUTINE RADB5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) - IMPLICIT NONE - INTEGER IDO,L1,K,IDP2,I,IC - REAL (KIND=8) CC(IDO,5,L1),CH(IDO,L1,5),WA1(1),WA2(1), - & WA3(1),WA4(1),TR11,TI11,TR12,TI12,TI5,TI4, - & TR2,TR3,CR2,CR3,CI5,CI4,DI3,DI4,DR3,DR4, - & DI5,DI2,DR5,DR2,TR5,TR4,TI2,TI3,CR5, - & CR4,CI2,CI3 - DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154, - 1-.809016994374947,.587785252292473/ - - DO 101 K=1,L1 - TI5 = CC(1,3,K)+CC(1,3,K) - TI4 = CC(1,5,K)+CC(1,5,K) - TR2 = CC(IDO,2,K)+CC(IDO,2,K) - TR3 = CC(IDO,4,K)+CC(IDO,4,K) - CH(1,K,1) = CC(1,1,K)+TR2+TR3 - CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 - CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 - CI5 = TI11*TI5+TI12*TI4 - CI4 = TI12*TI5-TI11*TI4 - CH(1,K,2) = CR2-CI5 - CH(1,K,3) = CR3-CI4 - CH(1,K,4) = CR3+CI4 - CH(1,K,5) = CR2+CI5 - 101 CONTINUE - IF (IDO .EQ. 1) RETURN - IDP2 = IDO+2 - DO 103 K=1,L1 - DO 102 I=3,IDO,2 - IC = IDP2-I - TI5 = CC(I,3,K)+CC(IC,2,K) - TI2 = CC(I,3,K)-CC(IC,2,K) - TI4 = CC(I,5,K)+CC(IC,4,K) - TI3 = CC(I,5,K)-CC(IC,4,K) - TR5 = CC(I-1,3,K)-CC(IC-1,2,K) - TR2 = CC(I-1,3,K)+CC(IC-1,2,K) - TR4 = CC(I-1,5,K)-CC(IC-1,4,K) - TR3 = CC(I-1,5,K)+CC(IC-1,4,K) - CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 - CH(I,K,1) = CC(I,1,K)+TI2+TI3 - CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 - CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 - CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 - CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 - CR5 = TI11*TR5+TI12*TR4 - CI5 = TI11*TI5+TI12*TI4 - CR4 = TI12*TR5-TI11*TR4 - CI4 = TI12*TI5-TI11*TI4 - DR3 = CR3-CI4 - DR4 = CR3+CI4 - DI3 = CI3+CR4 - DI4 = CI3-CR4 - DR5 = CR2+CI5 - DR2 = CR2-CI5 - DI5 = CI2-CR5 - DI2 = CI2+CR5 - CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 - CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 - CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 - CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 - CH(I-1,K,4) = WA3(I-2)*DR4-WA3(I-1)*DI4 - CH(I,K,4) = WA3(I-2)*DI4+WA3(I-1)*DR4 - CH(I-1,K,5) = WA4(I-2)*DR5-WA4(I-1)*DI5 - CH(I,K,5) = WA4(I-2)*DI5+WA4(I-1)*DR5 - 102 CONTINUE - 103 CONTINUE - RETURN - END - SUBROUTINE RADBG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) - IMPLICIT NONE - INTEGER IDO,L1,K,IDP2,I,IC,IP,NBD,IPP2,IPPH,JC,J,J2,IDIJ,IS,IK, - & IDL1,LC,L - REAL (KIND=8) CC(IDO,IP,L1),CH(IDO,L1,IP),TPI,ARG,DCP, - & C1(IDO,L1,IP),C2(IDL1,IP),DSP,AR2,DS2,DC2,AI2, - & CH2(IDL1,IP),WA(1),AR2H,AR1,AI1,AR1H - DATA TPI/6.28318530717959/ - - ARG = TPI/FLOAT(IP) - DCP = COS(ARG) - DSP = SIN(ARG) - IDP2 = IDO+2 - NBD = (IDO-1)/2 - IPP2 = IP+2 - IPPH = (IP+1)/2 - IF (IDO .LT. L1) GO TO 103 - DO 102 K=1,L1 - DO 101 I=1,IDO - CH(I,K,1) = CC(I,1,K) - 101 CONTINUE - 102 CONTINUE - GO TO 106 - 103 DO 105 I=1,IDO - DO 104 K=1,L1 - CH(I,K,1) = CC(I,1,K) - 104 CONTINUE - 105 CONTINUE -!OCL NOVREC - 106 DO 108 J=2,IPPH - JC = IPP2-J - J2 = J+J - DO 107 K=1,L1 - CH(1,K,J) = CC(IDO,J2-2,K)+CC(IDO,J2-2,K) - CH(1,K,JC) = CC(1,J2-1,K)+CC(1,J2-1,K) - 107 CONTINUE - 108 CONTINUE - IF (IDO .EQ. 1) GO TO 116 - IF (NBD .LT. L1) GO TO 112 -!OCL NOVREC - DO 111 J=2,IPPH - JC = IPP2-J - DO 110 K=1,L1 - DO 109 I=3,IDO,2 - IC = IDP2-I - CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K) - CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K) - CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K) - CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K) - 109 CONTINUE - 110 CONTINUE - 111 CONTINUE - GO TO 116 - 112 DO 115 J=2,IPPH - JC = IPP2-J - DO 114 I=3,IDO,2 - IC = IDP2-I - DO 113 K=1,L1 - CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K) - CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K) - CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K) - CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K) - 113 CONTINUE - 114 CONTINUE - 115 CONTINUE - 116 AR1 = 1. - AI1 = 0. -!OCL NOVREC - DO 120 L=2,IPPH - LC = IPP2-L - AR1H = DCP*AR1-DSP*AI1 - AI1 = DCP*AI1+DSP*AR1 - AR1 = AR1H - DO 117 IK=1,IDL1 - C2(IK,L) = CH2(IK,1)+AR1*CH2(IK,2) - C2(IK,LC) = AI1*CH2(IK,IP) - 117 CONTINUE - DC2 = AR1 - DS2 = AI1 - AR2 = AR1 - AI2 = AI1 -!OCL NOVREC - DO 119 J=3,IPPH - JC = IPP2-J - AR2H = DC2*AR2-DS2*AI2 - AI2 = DC2*AI2+DS2*AR2 - AR2 = AR2H - DO 118 IK=1,IDL1 - C2(IK,L) = C2(IK,L)+AR2*CH2(IK,J) - C2(IK,LC) = C2(IK,LC)+AI2*CH2(IK,JC) - 118 CONTINUE - 119 CONTINUE - 120 CONTINUE -!OCL NOVREC - DO 122 J=2,IPPH - DO 121 IK=1,IDL1 - CH2(IK,1) = CH2(IK,1)+CH2(IK,J) - 121 CONTINUE - 122 CONTINUE -!OCL NOVREC - DO 124 J=2,IPPH - JC = IPP2-J - DO 123 K=1,L1 - CH(1,K,J) = C1(1,K,J)-C1(1,K,JC) - CH(1,K,JC) = C1(1,K,J)+C1(1,K,JC) - 123 CONTINUE - 124 CONTINUE - IF (IDO .EQ. 1) GO TO 132 - IF (NBD .LT. L1) GO TO 128 -!OCL NOVREC - DO 127 J=2,IPPH - JC = IPP2-J - DO 126 K=1,L1 - DO 125 I=3,IDO,2 - CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC) - CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC) - CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC) - CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC) - 125 CONTINUE - 126 CONTINUE - 127 CONTINUE - GO TO 132 - 128 DO 131 J=2,IPPH - JC = IPP2-J - DO 130 I=3,IDO,2 - DO 129 K=1,L1 - CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC) - CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC) - CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC) - CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC) - 129 CONTINUE - 130 CONTINUE - 131 CONTINUE - 132 CONTINUE - IF (IDO .EQ. 1) RETURN - DO 133 IK=1,IDL1 - C2(IK,1) = CH2(IK,1) - 133 CONTINUE - DO 135 J=2,IP - DO 134 K=1,L1 - C1(1,K,J) = CH(1,K,J) - 134 CONTINUE - 135 CONTINUE - IF (NBD .GT. L1) GO TO 139 - IS = -IDO - DO 138 J=2,IP - IS = IS+IDO - IDIJ = IS - DO 137 I=3,IDO,2 - IDIJ = IDIJ+2 - DO 136 K=1,L1 - C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) - C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) - 136 CONTINUE - 137 CONTINUE - 138 CONTINUE - GO TO 143 - 139 IS = -IDO -!OCL NOVREC - DO 142 J=2,IP - IS = IS+IDO - DO 141 K=1,L1 - IDIJ = IS - DO 140 I=3,IDO,2 - IDIJ = IDIJ+2 - C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) - C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) - 140 CONTINUE - 141 CONTINUE - 142 CONTINUE - 143 RETURN - END - SUBROUTINE RADF2 (IDO,L1,CC,CH,WA1) - IMPLICIT NONE - INTEGER IDO,L1,K,IDP2,I,IC - REAL (KIND=8) CC(IDO,L1,2),CH(IDO,2,L1),WA1(1),TR2,TI2 - - DO 101 K=1,L1 - CH(1,1,K) = CC(1,K,1)+CC(1,K,2) - CH(IDO,2,K) = CC(1,K,1)-CC(1,K,2) - 101 CONTINUE - IF (IDO-2) 107,105,102 - 102 IDP2 = IDO+2 - DO 104 K=1,L1 - DO 103 I=3,IDO,2 - IC = IDP2-I - TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) - TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) - CH(I,1,K) = CC(I,K,1)+TI2 - CH(IC,2,K) = TI2-CC(I,K,1) - CH(I-1,1,K) = CC(I-1,K,1)+TR2 - CH(IC-1,2,K) = CC(I-1,K,1)-TR2 - 103 CONTINUE - 104 CONTINUE - IF (MOD(IDO,2) .EQ. 1) RETURN - 105 DO 106 K=1,L1 - CH(1,2,K) = -CC(IDO,K,2) - CH(IDO,1,K) = CC(IDO,K,1) - 106 CONTINUE - 107 RETURN - END - SUBROUTINE RADF3 (IDO,L1,CC,CH,WA1,WA2) - IMPLICIT NONE - INTEGER IDO,L1,K,IDP2,I,IC - REAL (KIND=8) CC(IDO,L1,3),CH(IDO,3,L1),WA1(1),WA2(1), - & TAUR,TAUI,CR2,DR2,DI2,DR3,DI3,CI2,TR3,TI3 - & ,TI2,TR2 - DATA TAUR,TAUI /-.5,.866025403784439/ - - DO 101 K=1,L1 - CR2 = CC(1,K,2)+CC(1,K,3) - CH(1,1,K) = CC(1,K,1)+CR2 - CH(1,3,K) = TAUI*(CC(1,K,3)-CC(1,K,2)) - CH(IDO,2,K) = CC(1,K,1)+TAUR*CR2 - 101 CONTINUE - IF (IDO .EQ. 1) RETURN - IDP2 = IDO+2 - DO 103 K=1,L1 - DO 102 I=3,IDO,2 - IC = IDP2-I - DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) - DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) - DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) - DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) - CR2 = DR2+DR3 - CI2 = DI2+DI3 - CH(I-1,1,K) = CC(I-1,K,1)+CR2 - CH(I,1,K) = CC(I,K,1)+CI2 - TR2 = CC(I-1,K,1)+TAUR*CR2 - TI2 = CC(I,K,1)+TAUR*CI2 - TR3 = TAUI*(DI2-DI3) - TI3 = TAUI*(DR3-DR2) - CH(I-1,3,K) = TR2+TR3 - CH(IC-1,2,K) = TR2-TR3 - CH(I,3,K) = TI2+TI3 - CH(IC,2,K) = TI3-TI2 - 102 CONTINUE - 103 CONTINUE - RETURN - END - SUBROUTINE RADF4 (IDO,L1,CC,CH,WA1,WA2,WA3) - IMPLICIT NONE - INTEGER IDO,L1,K,IDP2,I,IC - REAL (KIND=8) CC(IDO,L1,4),CH(IDO,4,L1),WA1(1),WA2(1), - & WA3(1),TR1,TR2,CR2,CI2,CR3,CI3,CR4,CI4,TR4, - & TI2,TI3,TI4,TI1,TR3,HSQT2 - DATA HSQT2 /.7071067811865475/ - - DO 101 K=1,L1 - TR1 = CC(1,K,2)+CC(1,K,4) - TR2 = CC(1,K,1)+CC(1,K,3) - CH(1,1,K) = TR1+TR2 - CH(IDO,4,K) = TR2-TR1 - CH(IDO,2,K) = CC(1,K,1)-CC(1,K,3) - CH(1,3,K) = CC(1,K,4)-CC(1,K,2) - 101 CONTINUE - IF (IDO-2) 107,105,102 - 102 IDP2 = IDO+2 -!OCL NOVREC - DO 104 K=1,L1 - DO 103 I=3,IDO,2 - IC = IDP2-I - CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) - CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) - CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) - CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) - CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) - CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) - TR1 = CR2+CR4 - TR4 = CR4-CR2 - TI1 = CI2+CI4 - TI4 = CI2-CI4 - TI2 = CC(I,K,1)+CI3 - TI3 = CC(I,K,1)-CI3 - TR2 = CC(I-1,K,1)+CR3 - TR3 = CC(I-1,K,1)-CR3 - CH(I-1,1,K) = TR1+TR2 - CH(IC-1,4,K) = TR2-TR1 - CH(I,1,K) = TI1+TI2 - CH(IC,4,K) = TI1-TI2 - CH(I-1,3,K) = TI4+TR3 - CH(IC-1,2,K) = TR3-TI4 - CH(I,3,K) = TR4+TI3 - CH(IC,2,K) = TR4-TI3 - 103 CONTINUE - 104 CONTINUE - IF (MOD(IDO,2) .EQ. 1) RETURN - 105 CONTINUE - DO 106 K=1,L1 - TI1 = -HSQT2*(CC(IDO,K,2)+CC(IDO,K,4)) - TR1 = HSQT2*(CC(IDO,K,2)-CC(IDO,K,4)) - CH(IDO,1,K) = TR1+CC(IDO,K,1) - CH(IDO,3,K) = CC(IDO,K,1)-TR1 - CH(1,2,K) = TI1-CC(IDO,K,3) - CH(1,4,K) = TI1+CC(IDO,K,3) - 106 CONTINUE - 107 RETURN - END - SUBROUTINE RADF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) - IMPLICIT NONE - INTEGER IDO,L1,K,IDP2,I,IC - REAL (KIND=8) CC(IDO,L1,5),CH(IDO,5,L1),WA1(1),WA2(1), - & WA3(1),WA4(1),TR11,TI11,TR12,TI12,CR2, - & CI5,CR3,CI4,DR2,DI2,DR3,DI3,DR4,DI4,DR5,DI5 - & ,TR3,TR5,TI3,TI4,TR4, - & TI5,CR4,CI2,CR5,TI2,TR2,CI3 - - DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154, - 1-.809016994374947,.587785252292473/ - - DO 101 K=1,L1 - CR2 = CC(1,K,5)+CC(1,K,2) - CI5 = CC(1,K,5)-CC(1,K,2) - CR3 = CC(1,K,4)+CC(1,K,3) - CI4 = CC(1,K,4)-CC(1,K,3) - CH(1,1,K) = CC(1,K,1)+CR2+CR3 - CH(IDO,2,K) = CC(1,K,1)+TR11*CR2+TR12*CR3 - CH(1,3,K) = TI11*CI5+TI12*CI4 - CH(IDO,4,K) = CC(1,K,1)+TR12*CR2+TR11*CR3 - CH(1,5,K) = TI12*CI5-TI11*CI4 - 101 CONTINUE - IF (IDO .EQ. 1) RETURN - IDP2 = IDO+2 - DO 103 K=1,L1 - DO 102 I=3,IDO,2 - IC = IDP2-I - DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) - DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) - DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) - DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) - DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) - DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) - DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5) - DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5) - CR2 = DR2+DR5 - CI5 = DR5-DR2 - CR5 = DI2-DI5 - CI2 = DI2+DI5 - CR3 = DR3+DR4 - CI4 = DR4-DR3 - CR4 = DI3-DI4 - CI3 = DI3+DI4 - CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3 - CH(I,1,K) = CC(I,K,1)+CI2+CI3 - TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3 - TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3 - TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3 - TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3 - TR5 = TI11*CR5+TI12*CR4 - TI5 = TI11*CI5+TI12*CI4 - TR4 = TI12*CR5-TI11*CR4 - TI4 = TI12*CI5-TI11*CI4 - CH(I-1,3,K) = TR2+TR5 - CH(IC-1,2,K) = TR2-TR5 - CH(I,3,K) = TI2+TI5 - CH(IC,2,K) = TI5-TI2 - CH(I-1,5,K) = TR3+TR4 - CH(IC-1,4,K) = TR3-TR4 - CH(I,5,K) = TI3+TI4 - CH(IC,4,K) = TI4-TI3 - 102 CONTINUE - 103 CONTINUE - RETURN - END - SUBROUTINE RADFG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) - IMPLICIT NONE - INTEGER IDO,L1,K,IDP2,I,IC,IPPH,IPP2,NBD,IS,IDIJ,LC,J2,IK,J,IP, - & IDL1,L,JC - REAL (KIND=8) CC(IDO,L1,IP),CH(IDO,IP,L1),C1(IDO,L1,IP), - & C2(IDL1,IP),CH2(IDL1,IP),WA(1),TPI,ARG,DCP, - & DSP,DC2,DS2,AR1H,AR2H,AR2,AI2,AI1,AR1 - DATA TPI/6.28318530717959/ - - ARG = TPI/FLOAT(IP) - DCP = COS(ARG) - DSP = SIN(ARG) - IPPH = (IP+1)/2 - IPP2 = IP+2 - IDP2 = IDO+2 - NBD = (IDO-1)/2 - IF (IDO .EQ. 1) GO TO 119 - DO 101 IK=1,IDL1 - CH2(IK,1) = C2(IK,1) - 101 CONTINUE - DO 103 J=2,IP - DO 102 K=1,L1 - CH(1,K,J) = C1(1,K,J) - 102 CONTINUE - 103 CONTINUE - IF (NBD .GT. L1) GO TO 107 - IS = -IDO - DO 106 J=2,IP - IS = IS+IDO - IDIJ = IS - DO 105 I=3,IDO,2 - IDIJ = IDIJ+2 - DO 104 K=1,L1 - CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J) - CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J) - 104 CONTINUE - 105 CONTINUE - 106 CONTINUE - GO TO 111 - 107 IS = -IDO - DO 110 J=2,IP - IS = IS+IDO - DO 109 K=1,L1 - IDIJ = IS - DO 108 I=3,IDO,2 - IDIJ = IDIJ+2 - CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J) - CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J) - 108 CONTINUE - 109 CONTINUE - 110 CONTINUE - 111 IF (NBD .LT. L1) GO TO 115 - DO 114 J=2,IPPH - JC = IPP2-J - DO 113 K=1,L1 - DO 112 I=3,IDO,2 - C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC) - C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC) - C1(I,K,J) = CH(I,K,J)+CH(I,K,JC) - C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J) - 112 CONTINUE - 113 CONTINUE - 114 CONTINUE - GO TO 121 - 115 DO 118 J=2,IPPH - JC = IPP2-J - DO 117 I=3,IDO,2 - DO 116 K=1,L1 - C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC) - C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC) - C1(I,K,J) = CH(I,K,J)+CH(I,K,JC) - C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J) - 116 CONTINUE - 117 CONTINUE - 118 CONTINUE - GO TO 121 - 119 DO 120 IK=1,IDL1 - C2(IK,1) = CH2(IK,1) - 120 CONTINUE - 121 DO 123 J=2,IPPH - JC = IPP2-J - DO 122 K=1,L1 - C1(1,K,J) = CH(1,K,J)+CH(1,K,JC) - C1(1,K,JC) = CH(1,K,JC)-CH(1,K,J) - 122 CONTINUE - 123 CONTINUE -C - AR1 = 1. - AI1 = 0. - DO 127 L=2,IPPH - LC = IPP2-L - AR1H = DCP*AR1-DSP*AI1 - AI1 = DCP*AI1+DSP*AR1 - AR1 = AR1H - DO 124 IK=1,IDL1 - CH2(IK,L) = C2(IK,1)+AR1*C2(IK,2) - CH2(IK,LC) = AI1*C2(IK,IP) - 124 CONTINUE - DC2 = AR1 - DS2 = AI1 - AR2 = AR1 - AI2 = AI1 - DO 126 J=3,IPPH - JC = IPP2-J - AR2H = DC2*AR2-DS2*AI2 - AI2 = DC2*AI2+DS2*AR2 - AR2 = AR2H - DO 125 IK=1,IDL1 - CH2(IK,L) = CH2(IK,L)+AR2*C2(IK,J) - CH2(IK,LC) = CH2(IK,LC)+AI2*C2(IK,JC) - 125 CONTINUE - 126 CONTINUE - 127 CONTINUE - DO 129 J=2,IPPH - DO 128 IK=1,IDL1 - CH2(IK,1) = CH2(IK,1)+C2(IK,J) - 128 CONTINUE - 129 CONTINUE -C - IF (IDO .LT. L1) GO TO 132 - DO 131 K=1,L1 - DO 130 I=1,IDO - CC(I,1,K) = CH(I,K,1) - 130 CONTINUE - 131 CONTINUE - GO TO 135 - 132 DO 134 I=1,IDO - DO 133 K=1,L1 - CC(I,1,K) = CH(I,K,1) - 133 CONTINUE - 134 CONTINUE - 135 DO 137 J=2,IPPH - JC = IPP2-J - J2 = J+J - DO 136 K=1,L1 - CC(IDO,J2-2,K) = CH(1,K,J) - CC(1,J2-1,K) = CH(1,K,JC) - 136 CONTINUE - 137 CONTINUE - IF (IDO .EQ. 1) RETURN - IF (NBD .LT. L1) GO TO 141 - DO 140 J=2,IPPH - JC = IPP2-J - J2 = J+J - DO 139 K=1,L1 - DO 138 I=3,IDO,2 - IC = IDP2-I - CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC) - CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC) - CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC) - CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J) - 138 CONTINUE - 139 CONTINUE - 140 CONTINUE - RETURN - 141 DO 144 J=2,IPPH - JC = IPP2-J - J2 = J+J - DO 143 I=3,IDO,2 - IC = IDP2-I - DO 142 K=1,L1 - CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC) - CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC) - CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC) - CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J) - 142 CONTINUE - 143 CONTINUE - 144 CONTINUE - RETURN - END diff --git a/src/fim/FIMsrc/prep/sp/spffte.f.IBM b/src/fim/FIMsrc/prep/sp/spffte.f.IBM deleted file mode 100644 index cb84538..0000000 --- a/src/fim/FIMsrc/prep/sp/spffte.f.IBM +++ /dev/null @@ -1,146 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPFFTE(IMAX,INCW,INCG,KMAX,W,G,IDIR,AFFT) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPFFTE PERFORM MULTIPLE FAST FOURIER TRANSFORMS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-20 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS MULTIPLE FAST FOURIER TRANSFORMS -C BETWEEN COMPLEX AMPLITUDES IN FOURIER SPACE AND REAL VALUES -C IN CYCLIC PHYSICAL SPACE. -C SUBPROGRAM SPFFTE MUST BE INVOKED FIRST WITH IDIR=0 -C TO INITIALIZE TRIGONEMETRIC DATA. USE SUBPROGRAM SPFFT1 -C TO PERFORM AN FFT WITHOUT PREVIOUS INITIALIZATION. -C THIS VERSION INVOKES THE IBM ESSL FFT. -C -C PROGRAM HISTORY LOG: -C 1998-12-18 IREDELL -C -C USAGE: CALL SPFFTE(IMAX,INCW,INCG,KMAX,W,G,IDIR,AFFT) -C -C INPUT ARGUMENT LIST: -C IMAX - INTEGER NUMBER OF VALUES IN THE CYCLIC PHYSICAL SPACE -C (SEE LIMITATIONS ON IMAX IN REMARKS BELOW.) -C INCW - INTEGER FIRST DIMENSION OF THE COMPLEX AMPLITUDE ARRAY -C (INCW >= IMAX/2+1) -C INCG - INTEGER FIRST DIMENSION OF THE REAL VALUE ARRAY -C (INCG >= IMAX) -C KMAX - INTEGER NUMBER OF TRANSFORMS TO PERFORM -C W - COMPLEX(INCW,KMAX) COMPLEX AMPLITUDES IF IDIR>0 -C G - REAL(INCG,KMAX) REAL VALUES IF IDIR<0 -C IDIR - INTEGER DIRECTION FLAG -C IDIR=0 TO INITIALIZE TRIGONOMETRIC DATA -C IDIR>0 TO TRANSFORM FROM FOURIER TO PHYSICAL SPACE -C IDIR<0 TO TRANSFORM FROM PHYSICAL TO FOURIER SPACE -C AFFT REAL(8) (50000+4*IMAX) AUXILIARY ARRAY IF IDIR<>0 -C -C OUTPUT ARGUMENT LIST: -C W - COMPLEX(INCW,KMAX) COMPLEX AMPLITUDES IF IDIR<0 -C G - REAL(INCG,KMAX) REAL VALUES IF IDIR>0 -C AFFT REAL(8) (50000+4*IMAX) AUXILIARY ARRAY IF IDIR=0 -C -C SUBPROGRAMS CALLED: -C SCRFT IBM ESSL COMPLEX TO REAL FOURIER TRANSFORM -C DCRFT IBM ESSL COMPLEX TO REAL FOURIER TRANSFORM -C SRCFT IBM ESSL REAL TO COMPLEX FOURIER TRANSFORM -C DRCFT IBM ESSL REAL TO COMPLEX FOURIER TRANSFORM -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C REMARKS: -C THE RESTRICTIONS ON IMAX ARE THAT IT MUST BE A MULTIPLE -C OF 1 TO 25 FACTORS OF TWO, UP TO 2 FACTORS OF THREE, -C AND UP TO 1 FACTOR OF FIVE, SEVEN AND ELEVEN. -C -C IF IDIR=0, THEN W AND G NEED NOT CONTAIN ANY VALID DATA. -C THE OTHER PARAMETERS MUST BE SUPPLIED AND CANNOT CHANGE -C IN SUCCEEDING CALLS UNTIL THE NEXT TIME IT IS CALLED WITH IDIR=0. -C -C THIS SUBPROGRAM IS THREAD-SAFE. -C -C$$$ - IMPLICIT NONE - INTEGER,INTENT(IN):: IMAX,INCW,INCG,KMAX,IDIR - REAL,INTENT(INOUT):: W(2*INCW,KMAX) - REAL,INTENT(INOUT):: G(INCG,KMAX) - REAL(8),INTENT(INOUT):: AFFT(50000+4*IMAX) - INTEGER(4):: INIT,INC2X,INC2Y,N,M,ISIGN,NAUX1,NAUX2,NAUX3 - REAL:: SCALE - REAL(8):: AUX2(20000+2*IMAX),AUX3 - INTEGER:: IACR,IARC -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - NAUX1=25000+2*IMAX - NAUX2=20000+2*IMAX - NAUX3=1 - IACR=1 - IARC=1+NAUX1 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C INITIALIZATION. -C FILL AUXILIARY ARRAYS WITH TRIGONOMETRIC DATA - SELECT CASE(IDIR) - CASE(0) - INIT=1 - INC2X=INCW - INC2Y=INCG - N=IMAX - M=KMAX - ISIGN=-1 - SCALE=1. - IF(DIGITS(1.).LT.DIGITS(1._8)) THEN - CALL SCRFT(INIT,W,INC2X,G,INC2Y,N,M,ISIGN,SCALE, - & AFFT(IACR),NAUX1,AUX2,NAUX2,AUX3,NAUX3) - ELSE - CALL DCRFT(INIT,W,INC2X,G,INC2Y,N,M,ISIGN,SCALE, - & AFFT(IACR),NAUX1,AUX2,NAUX2) - ENDIF - INIT=1 - INC2X=INCG - INC2Y=INCW - N=IMAX - M=KMAX - ISIGN=+1 - SCALE=1./IMAX - IF(DIGITS(1.).LT.DIGITS(1._8)) THEN - CALL SRCFT(INIT,G,INC2X,W,INC2Y,N,M,ISIGN,SCALE, - & AFFT(IARC),NAUX1,AUX2,NAUX2,AUX3,NAUX3) - ELSE - CALL DRCFT(INIT,G,INC2X,W,INC2Y,N,M,ISIGN,SCALE, - & AFFT(IARC),NAUX1,AUX2,NAUX2) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C FOURIER TO PHYSICAL TRANSFORM. - CASE(1:) - INIT=0 - INC2X=INCW - INC2Y=INCG - N=IMAX - M=KMAX - ISIGN=-1 - SCALE=1. - IF(DIGITS(1.).LT.DIGITS(1._8)) THEN - CALL SCRFT(INIT,W,INC2X,G,INC2Y,N,M,ISIGN,SCALE, - & AFFT(IACR),NAUX1,AUX2,NAUX2,AUX3,NAUX3) - ELSE - CALL DCRFT(INIT,W,INC2X,G,INC2Y,N,M,ISIGN,SCALE, - & AFFT(IACR),NAUX1,AUX2,NAUX2) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C PHYSICAL TO FOURIER TRANSFORM. - CASE(:-1) - INIT=0 - INC2X=INCG - INC2Y=INCW - N=IMAX - M=KMAX - ISIGN=+1 - SCALE=1./IMAX - IF(DIGITS(1.).LT.DIGITS(1._8)) THEN - CALL SRCFT(INIT,G,INC2X,W,INC2Y,N,M,ISIGN,SCALE, - & AFFT(IARC),NAUX1,AUX2,NAUX2,AUX3,NAUX3) - ELSE - CALL DRCFT(INIT,G,INC2X,W,INC2Y,N,M,ISIGN,SCALE, - & AFFT(IARC),NAUX1,AUX2,NAUX2) - ENDIF - END SELECT - END SUBROUTINE diff --git a/src/fim/FIMsrc/prep/sp/spfftpt.f b/src/fim/FIMsrc/prep/sp/spfftpt.f deleted file mode 100644 index 68f6bc5..0000000 --- a/src/fim/FIMsrc/prep/sp/spfftpt.f +++ /dev/null @@ -1,64 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPFFTPT(M,N,INCW,INCG,KMAX,RLON,W,G) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPFFTPT COMPUTE FOURIER TRANSFORM TO GRIDPOINTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-20 -C -C ABSTRACT: THIS SUBPROGRAM COMPUTES A SLOW FOURIER TRANSFORM -C FROM FOURIER SPACE TO A SET OF GRIDPOINTS. -C -C PROGRAM HISTORY LOG: -C 1998-12-18 IREDELL -C -C USAGE: CALL SPFFTPT(M,N,INCW,INCG,KMAX,RLON,W,G) -C -C INPUT ARGUMENT LIST: -C M - INTEGER FOURIER WAVENUMBER TRUNCATION -C N - INTEGER NUMBER OF GRIDPOINTS -C INCW - INTEGER FIRST DIMENSION OF THE COMPLEX AMPLITUDE ARRAY -C (INCW >= M+1) -C INCG - INTEGER FIRST DIMENSION OF THE GRIDPOINT ARRAY -C (INCG >= N) -C KMAX - INTEGER NUMBER OF FOURIER FIELDS -C RLON - REAL(N) GRID LONGITUDES IN DEGREES -C W - COMPLEX(INCW,KMAX) FOURIER AMPLITUDES -C -C OUTPUT ARGUMENT LIST: -C G - REAL(INCG,KMAX) GRIDPOINT VALUES -C -C SUBPROGRAMS CALLED: -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C REMARKS: -C THIS SUBPROGRAM IS THREAD-SAFE. -C -C$$$ - IMPLICIT NONE - INTEGER,INTENT(IN):: M,N,INCW,INCG,KMAX - REAL,INTENT(IN):: RLON(N) - REAL,INTENT(IN):: W(2*INCW,KMAX) - REAL,INTENT(OUT):: G(INCG,KMAX) - INTEGER I,K,L - REAL RADLON,SLON(M),CLON(M) - REAL,PARAMETER:: PI=3.14159265358979 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - DO I=1,N - RADLON=PI/180*RLON(I) - DO L=1,M - SLON(L)=SIN(L*RADLON) - CLON(L)=COS(L*RADLON) - ENDDO - DO K=1,KMAX - G(I,K)=W(1,K) - ENDDO - DO L=1,M - DO K=1,KMAX - G(I,K)=G(I,K)+2.*(W(2*L+1,K)*CLON(L)-W(2*L+2,K)*SLON(L)) - ENDDO - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END SUBROUTINE diff --git a/src/fim/FIMsrc/prep/sp/spgradq.f b/src/fim/FIMsrc/prep/sp/spgradq.f deleted file mode 100644 index f8bef43..0000000 --- a/src/fim/FIMsrc/prep/sp/spgradq.f +++ /dev/null @@ -1,76 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPGRADQ(I,M,ENN1,ELONN1,EON,EONTOP,Q,QDX,QDY,QDYTOP) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPGRADQ COMPUTE GRADIENT IN SPECTRAL SPACE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: COMPUTES THE HORIZONTAL VECTOR GRADIENT OF A SCALAR FIELD -C IN SPECTRAL SPACE. -C SUBPROGRAM SPEPS SHOULD BE CALLED ALREADY. -C IF L IS THE ZONAL WAVENUMBER, N IS THE TOTAL WAVENUMBER, -C EPS(L,N)=SQRT((N**2-L**2)/(4*N**2-1)) AND A IS EARTH RADIUS, -C THEN THE ZONAL GRADIENT OF Q(L,N) IS SIMPLY I*L/A*Q(L,N) -C WHILE THE MERIDIONAL GRADIENT OF Q(L,N) IS COMPUTED AS -C EPS(L,N+1)*(N+2)/A*Q(L,N+1)-EPS(L,N+1)*(N-1)/A*Q(L,N-1). -C EXTRA TERMS ARE COMPUTED OVER TOP OF THE SPECTRAL DOMAIN. -C ADVANTAGE IS TAKEN OF THE FACT THAT EPS(L,L)=0 -C IN ORDER TO VECTORIZE OVER THE ENTIRE SPECTRAL DOMAIN. -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C -C USAGE: CALL SPGRADQ(I,M,ENN1,ELONN1,EON,EONTOP,Q,QDX,QDY,QDYTOP) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C ENN1 - REAL ((M+1)*((I+1)*M+2)/2) N*(N+1)/A**2 -C ELONN1 - REAL ((M+1)*((I+1)*M+2)/2) L/(N*(N+1))*A -C EON - REAL ((M+1)*((I+1)*M+2)/2) EPSILON/N*A -C EONTOP - REAL (M+1) EPSILON/N*A OVER TOP -C Q - REAL ((M+1)*((I+1)*M+2)) SCALAR FIELD -C -C OUTPUT ARGUMENT LIST: -C QDX - REAL ((M+1)*((I+1)*M+2)) ZONAL GRADIENT (TIMES COSLAT) -C QDY - REAL ((M+1)*((I+1)*M+2)) MERID GRADIENT (TIMES COSLAT) -C QDYTOP - REAL (2*(M+1)) MERID GRADIENT (TIMES COSLAT) OVER TOP -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - REAL ENN1((M+1)*((I+1)*M+2)/2),ELONN1((M+1)*((I+1)*M+2)/2) - REAL EON((M+1)*((I+1)*M+2)/2),EONTOP(M+1) - REAL Q((M+1)*((I+1)*M+2)) - REAL QDX((M+1)*((I+1)*M+2)),QDY((M+1)*((I+1)*M+2)) - REAL QDYTOP(2*(M+1)) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TAKE ZONAL AND MERIDIONAL GRADIENTS - K=1 - QDX(2*K-1)=0. - QDX(2*K)=0. - QDY(2*K-1)=EON(K+1)*ENN1(K+1)*Q(2*K+1) - QDY(2*K)=EON(K+1)*ENN1(K+1)*Q(2*K+2) - DO K=2,(M+1)*((I+1)*M+2)/2-1 - QDX(2*K-1)=-ELONN1(K)*ENN1(K)*Q(2*K) - QDX(2*K)=ELONN1(K)*ENN1(K)*Q(2*K-1) - QDY(2*K-1)=EON(K+1)*ENN1(K+1)*Q(2*K+1)-EON(K)*ENN1(K-1)*Q(2*K-3) - QDY(2*K)=EON(K+1)*ENN1(K+1)*Q(2*K+2)-EON(K)*ENN1(K-1)*Q(2*K-2) - ENDDO - K=(M+1)*((I+1)*M+2)/2 - QDX(2*K-1)=-ELONN1(K)*ENN1(K)*Q(2*K) - QDX(2*K)=ELONN1(K)*ENN1(K)*Q(2*K-1) - QDY(2*K-1)=-EON(K)*ENN1(K-1)*Q(2*K-3) - QDY(2*K)=-EON(K)*ENN1(K-1)*Q(2*K-2) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TAKE MERIDIONAL GRADIENT OVER TOP - DO L=0,M - K=L*(2*M+(I-1)*(L-1))/2+I*L+M+1 - QDYTOP(2*L+1)=-EONTOP(L+1)*ENN1(K)*Q(2*K-1) - QDYTOP(2*L+2)=-EONTOP(L+1)*ENN1(K)*Q(2*K) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/prep/sp/spgradx.f b/src/fim/FIMsrc/prep/sp/spgradx.f deleted file mode 100644 index 911d8e2..0000000 --- a/src/fim/FIMsrc/prep/sp/spgradx.f +++ /dev/null @@ -1,86 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPGRADX(M,INCW,KMAX,MP,CLAT,W,WX) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPGRADX COMPUTE X-GRADIENT IN FOURIER SPACE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-20 -C -C ABSTRACT: THIS SUBPROGRAM COMPUTES THE X-GRADIENT OF FIELDS -C IN COMPLEX FOURIER SPACE. -C THE X-GRADIENT OF A VECTOR FIELD W IS -C WX=CONJG(W)*L/RERTH -C WHERE L IS THE WAVENUMBER AND RERTH IS THE EARTH RADIUS, -C SO THAT THE RESULT IS THE X-GRADIENT OF THE PSEUDO-VECTOR. -C THE X-GRADIENT OF A SCALAR FIELD W IS -C WX=CONJG(W)*L/(RERTH*CLAT) -C WHERE CLAT IS THE COSINE OF LATITUDE. -C AT THE POLE THIS IS UNDEFINED, SO THE WAY TO GET -C THE X-GRADIENT AT THE POLE IS BY PASSING BOTH -C THE WEIGHTED WAVENUMBER 0 AND THE UNWEIGHTED WAVENUMBER 1 -C AMPLITUDES AT THE POLE AND SETTING MP=10. -C IN THIS CASE, THE WAVENUMBER 1 AMPLITUDES ARE USED -C TO COMPUTE THE X-GRADIENT AND THEN ZEROED OUT. -C -C PROGRAM HISTORY LOG: -C 1998-12-18 IREDELL -C -C USAGE: CALL SPGRADX(M,INCW,KMAX,W,WX) -C -C INPUT ARGUMENT LIST: -C M - INTEGER FOURIER WAVENUMBER TRUNCATION -C INCW - INTEGER FIRST DIMENSION OF THE COMPLEX AMPLITUDE ARRAY -C (INCW >= M+1) -C KMAX - INTEGER NUMBER OF FOURIER FIELDS -C MP - INTEGER (KM) IDENTIFIERS -C (0 OR 10 FOR SCALAR, 1 FOR VECTOR) -C CLAT - REAL COSINE OF LATITUDE -C W - COMPLEX(INCW,KMAX) FOURIER AMPLITUDES -C -C OUTPUT ARGUMENT LIST: -C W - COMPLEX(INCW,KMAX) FOURIER AMPLITUDES -C CORRECTED WHEN MP=10 AND CLAT=0 -C WX - COMPLEX(INCW,KMAX) COMPLEX AMPLITUDES OF X-GRADIENTS -C -C SUBPROGRAMS CALLED: -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C REMARKS: -C THIS SUBPROGRAM IS THREAD-SAFE. -C -C$$$ - IMPLICIT NONE - INTEGER,INTENT(IN):: M,INCW,KMAX,MP(KMAX) - REAL,INTENT(IN):: CLAT - REAL,INTENT(INOUT):: W(2*INCW,KMAX) - REAL,INTENT(OUT):: WX(2*INCW,KMAX) - INTEGER K,L - REAL,PARAMETER:: RERTH=6.3712E6 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - DO K=1,KMAX - IF(MP(K).EQ.1) THEN - DO L=0,M - WX(2*L+1,K)=-W(2*L+2,K)*(L/RERTH) - WX(2*L+2,K)=+W(2*L+1,K)*(L/RERTH) - ENDDO - ELSEIF(CLAT.EQ.0.) THEN - DO L=0,M - WX(2*L+1,K)=0 - WX(2*L+2,K)=0 - ENDDO - IF(MP(K).EQ.10.AND.M.GE.2) THEN - WX(3,K)=-W(4,K)/RERTH - WX(4,K)=+W(3,K)/RERTH - W(3,K)=0 - W(4,K)=0 - ENDIF - ELSE - DO L=0,M - WX(2*L+1,K)=-W(2*L+2,K)*(L/(RERTH*CLAT)) - WX(2*L+2,K)=+W(2*L+1,K)*(L/(RERTH*CLAT)) - ENDDO - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END SUBROUTINE diff --git a/src/fim/FIMsrc/prep/sp/spgrady.f b/src/fim/FIMsrc/prep/sp/spgrady.f deleted file mode 100644 index 5a77922..0000000 --- a/src/fim/FIMsrc/prep/sp/spgrady.f +++ /dev/null @@ -1,67 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPGRADY(I,M,ENN1,EON,EONTOP,Q,QDY,QDYTOP) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPGRADY COMPUTE Y-GRADIENT IN SPECTRAL SPACE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: COMPUTES THE HORIZONTAL VECTOR Y-GRADIENT OF A SCALAR FIELD -C IN SPECTRAL SPACE. -C SUBPROGRAM SPEPS SHOULD BE CALLED ALREADY. -C IF L IS THE ZONAL WAVENUMBER, N IS THE TOTAL WAVENUMBER, -C EPS(L,N)=SQRT((N**2-L**2)/(4*N**2-1)) AND A IS EARTH RADIUS, -C THEN THE MERIDIONAL GRADIENT OF Q(L,N) IS COMPUTED AS -C EPS(L,N+1)*(N+2)/A*Q(L,N+1)-EPS(L,N+1)*(N-1)/A*Q(L,N-1). -C EXTRA TERMS ARE COMPUTED OVER TOP OF THE SPECTRAL DOMAIN. -C ADVANTAGE IS TAKEN OF THE FACT THAT EPS(L,L)=0 -C IN ORDER TO VECTORIZE OVER THE ENTIRE SPECTRAL DOMAIN. -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C -C USAGE: CALL SPGRADY(I,M,ENN1,EON,EONTOP,Q,QDY,QDYTOP) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C ENN1 - REAL ((M+1)*((I+1)*M+2)/2) N*(N+1)/A**2 -C EON - REAL ((M+1)*((I+1)*M+2)/2) EPSILON/N*A -C EONTOP - REAL (M+1) EPSILON/N*A OVER TOP -C Q - REAL ((M+1)*((I+1)*M+2)) SCALAR FIELD -C -C OUTPUT ARGUMENT LIST: -C QDY - REAL ((M+1)*((I+1)*M+2)) MERID GRADIENT (TIMES COSLAT) -C QDYTOP - REAL (2*(M+1)) MERID GRADIENT (TIMES COSLAT) OVER TOP -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - REAL ENN1((M+1)*((I+1)*M+2)/2) - REAL EON((M+1)*((I+1)*M+2)/2),EONTOP(M+1) - REAL Q((M+1)*((I+1)*M+2)) - REAL QDY((M+1)*((I+1)*M+2)) - REAL QDYTOP(2*(M+1)) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TAKE MERIDIONAL GRADIENT - K=1 - QDY(2*K-1)=EON(K+1)*ENN1(K+1)*Q(2*K+1) - QDY(2*K)=EON(K+1)*ENN1(K+1)*Q(2*K+2) - DO K=2,(M+1)*((I+1)*M+2)/2-1 - QDY(2*K-1)=EON(K+1)*ENN1(K+1)*Q(2*K+1)-EON(K)*ENN1(K-1)*Q(2*K-3) - QDY(2*K)=EON(K+1)*ENN1(K+1)*Q(2*K+2)-EON(K)*ENN1(K-1)*Q(2*K-2) - ENDDO - K=(M+1)*((I+1)*M+2)/2 - QDY(2*K-1)=-EON(K)*ENN1(K-1)*Q(2*K-3) - QDY(2*K)=-EON(K)*ENN1(K-1)*Q(2*K-2) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TAKE MERIDIONAL GRADIENT OVER TOP - DO L=0,M - K=L*(2*M+(I-1)*(L-1))/2+I*L+M+1 - QDYTOP(2*L+1)=-EONTOP(L+1)*ENN1(K)*Q(2*K-1) - QDYTOP(2*L+2)=-EONTOP(L+1)*ENN1(K)*Q(2*K) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/prep/sp/splaplac.f b/src/fim/FIMsrc/prep/sp/splaplac.f deleted file mode 100644 index 5ee7eed..0000000 --- a/src/fim/FIMsrc/prep/sp/splaplac.f +++ /dev/null @@ -1,61 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPLAPLAC(I,M,ENN1,Q,QD2,IDIR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: COMPUTES THE LAPLACIAN OR THE INVERSE LAPLACIAN -C OF A SCALAR FIELD IN SPECTRAL SPACE. -C SUBPROGRAM SPEPS SHOULD BE CALLED ALREADY. -C THE LAPLACIAN OF Q(L,N) IS SIMPLY -N*(N+1)/A**2*Q(L,N) -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C -C USAGE: CALL SPLAPLAC(I,M,ENN1,Q,QD2,IDIR) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C ENN1 - REAL ((M+1)*((I+1)*M+2)/2) N*(N+1)/A**2 -C Q - IF IDIR > 0, REAL ((M+1)*((I+1)*M+2)) SCALAR FIELD -C QD2 - IF IDIR < 0, REAL ((M+1)*((I+1)*M+2)) LAPLACIAN -C IDIR - INTEGER FLAG -C IDIR > 0 TO TAKE LAPLACIAN -C IDIR < 0 TO TAKE INVERSE LAPLACIAN -C -C OUTPUT ARGUMENT LIST: -C Q - IF IDIR < 0, REAL ((M+1)*((I+1)*M+2)) SCALAR FIELD -C (Q(0,0) IS NOT COMPUTED) -C QD2 - IF IDIR > 0, REAL ((M+1)*((I+1)*M+2)) LAPLACIAN -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - REAL ENN1((M+1)*((I+1)*M+2)/2) - REAL Q((M+1)*((I+1)*M+2)) - REAL QD2((M+1)*((I+1)*M+2)) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TAKE LAPLACIAN - IF(IDIR.GT.0) THEN - K=1 - QD2(2*K-1)=0. - QD2(2*K)=0. - DO K=2,(M+1)*((I+1)*M+2)/2 - QD2(2*K-1)=Q(2*K-1)*(-ENN1(K)) - QD2(2*K)=Q(2*K)*(-ENN1(K)) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TAKE INVERSE LAPLACIAN - ELSE - DO K=2,(M+1)*((I+1)*M+2)/2 - Q(2*K-1)=QD2(2*K-1)/(-ENN1(K)) - Q(2*K)=QD2(2*K)/(-ENN1(K)) - ENDDO - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/prep/sp/splat.f b/src/fim/FIMsrc/prep/sp/splat.f deleted file mode 100644 index aa8b450..0000000 --- a/src/fim/FIMsrc/prep/sp/splat.f +++ /dev/null @@ -1,196 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPLAT(IDRT,JMAX,SLAT,WLAT) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPLAT COMPUTE LATITUDE FUNCTIONS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-20 -C -C ABSTRACT: COMPUTES COSINES OF COLATITUDE AND GAUSSIAN WEIGHTS -C FOR ONE OF THE FOLLOWING SPECIFIC GLOBAL SETS OF LATITUDES. -C GAUSSIAN LATITUDES (IDRT=4) -C EQUALLY-SPACED LATITUDES INCLUDING POLES (IDRT=0) -C EQUALLY-SPACED LATITUDES EXCLUDING POLES (IDRT=256) -C THE GAUSSIAN LATITUDES ARE LOCATED AT THE ZEROES OF THE -C LEGENDRE POLYNOMIAL OF THE GIVEN ORDER. THESE LATITUDES -C ARE EFFICIENT FOR REVERSIBLE TRANSFORMS FROM SPECTRAL SPACE. -C (ABOUT TWICE AS MANY EQUALLY-SPACED LATITUDES ARE NEEDED.) -C THE WEIGHTS FOR THE EQUALLY-SPACED LATITUDES ARE BASED ON -C ELLSAESSER (JAM,1966). (NO WEIGHT IS GIVEN THE POLE POINT.) -C NOTE THAT WHEN ANALYZING GRID TO SPECTRAL IN LATITUDE PAIRS, -C IF AN EQUATOR POINT EXISTS, ITS WEIGHT SHOULD BE HALVED. -C THIS VERSION INVOKES THE IBM ESSL MATRIX SOLVER. -C -C PROGRAM HISTORY LOG: -C 96-02-20 IREDELL -C 97-10-20 IREDELL ADJUST PRECISION -C 98-06-11 IREDELL GENERALIZE PRECISION USING FORTRAN 90 INTRINSIC -C 1998-12-03 IREDELL GENERALIZE PRECISION FURTHER -C 1998-12-03 IREDELL USE BLAS CALLS -C -C USAGE: CALL SPLAT(IDRT,JMAX,SLAT,WLAT) -C -C INPUT ARGUMENT LIST: -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C JMAX - INTEGER NUMBER OF LATITUDES. -C -C OUTPUT ARGUMENT LIST: -C SLAT - REAL (JMAX) SINES OF LATITUDE. -C WLAT - REAL (JMAX) GAUSSIAN WEIGHTS. -C -C SUBPROGRAMS CALLED: -C DGEF MATRIX FACTORIZATION -C DGES MATRIX SOLVER -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - REAL SLAT(JMAX),WLAT(JMAX) - INTEGER,PARAMETER:: KD=SELECTED_REAL_KIND(15,45) - REAL(KIND=KD):: PK(JMAX/2),PKM1(JMAX/2),PKM2(JMAX/2) - REAL(KIND=KD):: SLATD(JMAX/2),SP,SPMAX,EPS=10.*EPSILON(SP) - PARAMETER(JZ=50) - REAL BZ(JZ) - DATA BZ / 2.4048255577, 5.5200781103, - $ 8.6537279129, 11.7915344391, 14.9309177086, 18.0710639679, - $ 21.2116366299, 24.3524715308, 27.4934791320, 30.6346064684, - $ 33.7758202136, 36.9170983537, 40.0584257646, 43.1997917132, - $ 46.3411883717, 49.4826098974, 52.6240518411, 55.7655107550, - $ 58.9069839261, 62.0484691902, 65.1899648002, 68.3314693299, - $ 71.4729816036, 74.6145006437, 77.7560256304, 80.8975558711, - $ 84.0390907769, 87.1806298436, 90.3221726372, 93.4637187819, - $ 96.6052679510, 99.7468198587, 102.888374254, 106.029930916, - $ 109.171489649, 112.313050280, 115.454612653, 118.596176630, - $ 121.737742088, 124.879308913, 128.020877005, 131.162446275, - $ 134.304016638, 137.445588020, 140.587160352, 143.728733573, - $ 146.870307625, 150.011882457, 153.153458019, 156.295034268 / - REAL(8):: DLT,D1=1. - REAL(8) AWORK((JMAX+1)/2,((JMAX+1)/2)),BWORK(((JMAX+1)/2)) - INTEGER(4):: JHE,JHO,J0=0 - INTEGER(4) IPVT((JMAX+1)/2) - PARAMETER(PI=3.14159265358979,C=(1.-(2./PI)**2)*0.25) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C GAUSSIAN LATITUDES - IF(IDRT.EQ.4) THEN - JH=JMAX/2 - JHE=(JMAX+1)/2 - R=1./SQRT((JMAX+0.5)**2+C) - DO J=1,MIN(JH,JZ) - SLATD(J)=COS(BZ(J)*R) - ENDDO - DO J=JZ+1,JH - SLATD(J)=COS((BZ(JZ)+(J-JZ)*PI)*R) - ENDDO - SPMAX=1. - DO WHILE(SPMAX.GT.EPS) - SPMAX=0. - DO J=1,JH - PKM1(J)=1. - PK(J)=SLATD(J) - ENDDO - DO N=2,JMAX - DO J=1,JH - PKM2(J)=PKM1(J) - PKM1(J)=PK(J) - PK(J)=((2*N-1)*SLATD(J)*PKM1(J)-(N-1)*PKM2(J))/N - ENDDO - ENDDO - DO J=1,JH - SP=PK(J)*(1.-SLATD(J)**2)/(JMAX*(PKM1(J)-SLATD(J)*PK(J))) - SLATD(J)=SLATD(J)-SP - SPMAX=MAX(SPMAX,ABS(SP)) - ENDDO - ENDDO -CDIR$ IVDEP - DO J=1,JH - SLAT(J)=SLATD(J) - WLAT(J)=(2.*(1.-SLATD(J)**2))/(JMAX*PKM1(J))**2 - SLAT(JMAX+1-J)=-SLAT(J) - WLAT(JMAX+1-J)=WLAT(J) - ENDDO - IF(JHE.GT.JH) THEN - SLAT(JHE)=0. - WLAT(JHE)=2./JMAX**2 - DO N=2,JMAX,2 - WLAT(JHE)=WLAT(JHE)*N**2/(N-1)**2 - ENDDO - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C EQUALLY-SPACED LATITUDES INCLUDING POLES - ELSEIF(IDRT.EQ.0) THEN - print*,'Do not have DGEF or DGES' - stop - JH=JMAX/2 - JHE=(JMAX+1)/2 - JHO=JHE-1 - DLT=PI/(JMAX-1) - SLAT(1)=1. - DO J=2,JH - SLAT(J)=COS((J-1)*DLT) - ENDDO - DO JS=1,JHO - DO J=1,JHO - AWORK(JS,J)=COS(2*(JS-1)*J*DLT) - ENDDO - ENDDO - DO JS=1,JHO - BWORK(JS)=-D1/(4*(JS-1)**2-1) - ENDDO -! CALL DGEF(AWORK,JHE,JHO,IPVT) -! CALL DGES(AWORK,JHE,JHO,IPVT,BWORK,J0) - WLAT(1)=0. - DO J=1,JHO - WLAT(J+1)=BWORK(J) - ENDDO -CDIR$ IVDEP - DO J=1,JH - SLAT(JMAX+1-J)=-SLAT(J) - WLAT(JMAX+1-J)=WLAT(J) - ENDDO - IF(JHE.GT.JH) THEN - SLAT(JHE)=0. - WLAT(JHE)=2.*WLAT(JHE) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C EQUALLY-SPACED LATITUDES EXCLUDING POLES - ELSEIF(IDRT.EQ.256) THEN - print*,'Do not have DGEF or DGES' - stop - JH=JMAX/2 - JHE=(JMAX+1)/2 - JHO=JHE - DLT=PI/JMAX - SLAT(1)=1. - DO J=1,JH - SLAT(J)=COS((J-0.5)*DLT) - ENDDO - DO JS=1,JHO - DO J=1,JHO - AWORK(JS,J)=COS(2*(JS-1)*(J-0.5)*DLT) - ENDDO - ENDDO - DO JS=1,JHO - BWORK(JS)=-D1/(4*(JS-1)**2-1) - ENDDO -! CALL DGEF(AWORK,JHE,JHO,IPVT) -! CALL DGES(AWORK,JHE,JHO,IPVT,BWORK,J0) - WLAT(1)=0. - DO J=1,JHO - WLAT(J)=BWORK(J) - ENDDO -CDIR$ IVDEP - DO J=1,JH - SLAT(JMAX+1-J)=-SLAT(J) - WLAT(JMAX+1-J)=WLAT(J) - ENDDO - IF(JHE.GT.JH) THEN - SLAT(JHE)=0. - WLAT(JHE)=2.*WLAT(JHE) - ENDIF - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/prep/sp/splegend.f b/src/fim/FIMsrc/prep/sp/splegend.f deleted file mode 100644 index d8b1bcc..0000000 --- a/src/fim/FIMsrc/prep/sp/splegend.f +++ /dev/null @@ -1,134 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPLEGEND(I,M,SLAT,CLAT,EPS,EPSTOP,PLN,PLNTOP) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: EVALUATES THE ORTHONORMAL ASSOCIATED LEGENDRE POLYNOMIALS -C IN THE SPECTRAL DOMAIN AT A GIVEN LATITUDE. -C SUBPROGRAM SPLEGEND SHOULD BE CALLED ALREADY. -C IF L IS THE ZONAL WAVENUMBER, N IS THE TOTAL WAVENUMBER, -C AND EPS(L,N)=SQRT((N**2-L**2)/(4*N**2-1)) THEN -C THE FOLLOWING BOOTSTRAPPING FORMULAS ARE USED: -C PLN(0,0)=SQRT(0.5) -C PLN(L,L)=PLN(L-1,L-1)*CLAT*SQRT(FLOAT(2*L+1)/FLOAT(2*L)) -C PLN(L,N)=(SLAT*PLN(L,N-1)-EPS(L,N-1)*PLN(L,N-2))/EPS(L,N) -C SYNTHESIS AT THE POLE NEEDS ONLY TWO ZONAL WAVENUMBERS. -C SCALAR FIELDS ARE SYNTHESIZED WITH ZONAL WAVENUMBER 0 WHILE -C VECTOR FIELDS ARE SYNTHESIZED WITH ZONAL WAVENUMBER 1. -C (THUS POLAR VECTOR FIELDS ARE IMPLICITLY DIVIDED BY CLAT.) -C THE FOLLOWING BOOTSTRAPPING FORMULAS ARE USED AT THE POLE: -C PLN(0,0)=SQRT(0.5) -C PLN(1,1)=SQRT(0.75) -C PLN(L,N)=(PLN(L,N-1)-EPS(L,N-1)*PLN(L,N-2))/EPS(L,N) -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C 98-06-10 MARK IREDELL GENERALIZE PRECISION -C -C USAGE: CALL SPLEGEND(I,M,SLAT,CLAT,EPS,EPSTOP,PLN,PLNTOP) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C SLAT - REAL SINE OF LATITUDE -C CLAT - REAL COSINE OF LATITUDE -C EPS - REAL ((M+1)*((I+1)*M+2)/2) SQRT((N**2-L**2)/(4*N**2-1)) -C EPSTOP - REAL (M+1) SQRT((N**2-L**2)/(4*N**2-1)) OVER TOP -C -C OUTPUT ARGUMENT LIST: -C PLN - REAL ((M+1)*((I+1)*M+2)/2) LEGENDRE POLYNOMIAL -C PLNTOP - REAL (M+1) LEGENDRE POLYNOMIAL OVER TOP -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ -CFPP$ NOCONCUR R - REAL EPS((M+1)*((I+1)*M+2)/2),EPSTOP(M+1) - REAL PLN((M+1)*((I+1)*M+2)/2),PLNTOP(M+1) - REAL(KIND=SELECTED_REAL_KIND(15,45)):: DLN((M+1)*((I+1)*M+2)/2) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C ITERATIVELY COMPUTE PLN WITHIN SPECTRAL DOMAIN AT POLE - M1=M+1 - M2=2*M+I+1 - MX=(M+1)*((I+1)*M+2)/2 - IF(CLAT.EQ.0.) THEN - DLN(1)=SQRT(0.5) - IF(M.GT.0) THEN - DLN(M1+1)=SQRT(0.75) - DLN(2)=SLAT*DLN(1)/EPS(2) - ENDIF - IF(M.GT.1) THEN - DLN(M1+2)=SLAT*DLN(M1+1)/EPS(M1+2) - DLN(3)=(SLAT*DLN(2)-EPS(2)*DLN(1))/EPS(3) - DO N=3,M - K=1+N - DLN(K)=(SLAT*DLN(K-1)-EPS(K-1)*DLN(K-2))/EPS(K) - K=M1+N - DLN(K)=(SLAT*DLN(K-1)-EPS(K-1)*DLN(K-2))/EPS(K) - ENDDO - IF(I.EQ.1) THEN - K=M2 - DLN(K)=(SLAT*DLN(K-1)-EPS(K-1)*DLN(K-2))/EPS(K) - ENDIF - DO K=M2+1,MX - DLN(K)=0. - ENDDO - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COMPUTE POLYNOMIALS OVER TOP OF SPECTRAL DOMAIN - K=M1+1 - PLNTOP(1)=(SLAT*DLN(K-1)-EPS(K-1)*DLN(K-2))/EPSTOP(1) - IF(M.GT.0) THEN - K=M2+1 - PLNTOP(2)=(SLAT*DLN(K-1)-EPS(K-1)*DLN(K-2))/EPSTOP(2) - DO L=2,M - PLNTOP(L+1)=0. - ENDDO - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C ITERATIVELY COMPUTE PLN(L,L) (BOTTOM HYPOTENUSE OF DOMAIN) - ELSE - NML=0 - K=1 - DLN(K)=SQRT(0.5) - DO L=1,M+(I-1)*NML - KP=K - K=L*(2*M+(I-1)*(L-1))/2+L+NML+1 - DLN(K)=DLN(KP)*CLAT*SQRT(FLOAT(2*L+1)/FLOAT(2*L)) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COMPUTE PLN(L,L+1) (DIAGONAL NEXT TO BOTTOM HYPOTENUSE OF DOMAIN) - NML=1 -CDIR$ IVDEP - DO L=0,M+(I-1)*NML - K=L*(2*M+(I-1)*(L-1))/2+L+NML+1 - DLN(K)=SLAT*DLN(K-1)/EPS(K) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COMPUTE REMAINING PLN IN SPECTRAL DOMAIN - DO NML=2,M -CDIR$ IVDEP - DO L=0,M+(I-1)*NML - K=L*(2*M+(I-1)*(L-1))/2+L+NML+1 - DLN(K)=(SLAT*DLN(K-1)-EPS(K-1)*DLN(K-2))/EPS(K) - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COMPUTE POLYNOMIALS OVER TOP OF SPECTRAL DOMAIN - DO L=0,M - NML=M+1+(I-1)*L - K=L*(2*M+(I-1)*(L-1))/2+L+NML+1 - PLNTOP(L+1)=(SLAT*DLN(K-1)-EPS(K-1)*DLN(K-2))/EPSTOP(L+1) - ENDDO - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C RETURN VALUES - DO K=1,MX - PLN(K)=DLN(K) - ENDDO - RETURN - END diff --git a/src/fim/FIMsrc/prep/sp/splib.doc b/src/fim/FIMsrc/prep/sp/splib.doc deleted file mode 100644 index 5db4205..0000000 --- a/src/fim/FIMsrc/prep/sp/splib.doc +++ /dev/null @@ -1,2621 +0,0 @@ -Documentation of the spectral transform library splib May 2, 1996 --------------------------------------------------------------------------------- - -I. Introduction - -The spectral transform library splib contains FORTRAN subprograms -to be used for a variety of spectral transform functions. -The library has been optimized for the CRAY machines, taking full advantage -of both the vector and parallel capabilities. The library is particularly -efficient when transforming many fields at one time. Some entry points -will diagnose the environmental number of CPUs available, but others require -the number of CPUs used be specified. The library is reasonably transportable -to other platforms with compilers allowing dynamic automatic arrays. - -The library can handle both scalar and two-dimensional vector fields. -Each vector field will be represented in spectral space appropriately -by its respective spherical divergence and curl (vorticity), thus -avoiding the pole problems associated with representing components separately. - -Some of the functions performed by the library are spectral interpolations -between two grids, spectral truncations in place on a grid, and basic -spectral transforms between grid and wave space. Only global Gaussian -or global equidistant cylindrical grids are allowed for transforming into -wave space. There are no such restricitions on grids for transforming from -wave space. However, there are special fast entry points for transforming wave -space to polar stereographic and Mercator grids as well as the aforementioned -cylindrical grids. - -The indexing of the cylindrical transform grids is totally general. -The grids may run north to south or south to north; they may run east to west -or west to east; they may start at any longitude as long as the prime meridian -is on the grid; they may be dimensioned in any order (e.g. (i,j,k), (k,j,i), -(i,k,nfield,j), etc.). Furthermore, the transform may be performed on only -some of the latitudes at one time as long as both hemisphere counterparts -are transformed at the same time (as in the global spectral model). -The grid indexing will default to the customary global indexing, i.e. north to -south, east to west, prime meridian as first longitude, and (i,j,k) order. - -The wave space may be either triangular or rhomboidal in shape. -Its internal indexing is strictly "IBM order", i.e. zonal wavenumber is the -slower index with the real and imaginary components always paired together. -The imaginary components of all the zonally symmetric modes should always -be zero, as should the global mean of any divergence and vorticity fields. -The stride between the start of successive wave fields is general, -defaulting to the computed length of each field. - -This documentation is divided into 4 chapters. Chapter I is this introduction. -Chapter II is a list of all entry points. Chapter III is a set of examples. -Chapter IV is a recapitulation of all the docblocks. The chapters all start -on a line number that is 1 modulo 60 in order to facilitate laser printing. - - - - - - - - - - -II. Entry point list - - Name Function - ---- ------------------------------------------------------------------ - - Spectral interpolations or truncations between grid and grid - - SPTRUN SPECTRALLY TRUNCATE GRIDDED SCALAR FIELDS - SPTRUNV SPECTRALLY TRUNCATE GRIDDED VECTOR FIELDS - SPTRUNG SPECTRALLY INTERPOLATE SCALARS TO STATIONS - SPTRUNGV SPECTRALLY INTERPOLATE VECTORS TO STATIONS - SPTRUNS SPECTRALLY INTERPOLATE SCALARS TO POLAR STEREO - SPTRUNSV SPECTRALLY INTERPOLATE VECTORS TO POLAR STEREO - SPTRUNM SPECTRALLY INTERPOLATE SCALARS TO MERCATOR - SPTRUNMV SPECTRALLY INTERPOLATE VECTORS TO MERCATOR - - Spectral transforms between wave and grid - - SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM - SPTRANV PERFORM A VECTOR SPHERICAL TRANSFORM - SPTRAND PERFORM A GRADIENT SPHERICAL TRANSFORM - SPTGPT TRANSFORM SPECTRAL SCALAR TO STATION POINTS - SPTGPTV TRANSFORM SPECTRAL VECTOR TO STATION POINTS - SPTGPTD TRANSFORM SPECTRAL TO STATION POINT GRADIENTS - SPTGPS TRANSFORM SPECTRAL SCALAR TO POLAR STEREO - SPTGPSV TRANSFORM SPECTRAL VECTOR TO POLAR STEREO - SPTGPSD TRANSFORM SPECTRAL TO POLAR STEREO GRADIENTS - SPTGPM TRANSFORM SPECTRAL SCALAR TO MERCATOR - SPTGPMV TRANSFORM SPECTRAL VECTOR TO MERCATOR - SPTGPMD TRANSFORM SPECTRAL TO MERCATOR GRADIENTS - - Spectral transform utilities - - SPGGET GET GRID-SPACE CONSTANTS - SPWGET GET WAVE-SPACE CONSTANTS - SPLAT COMPUTE LATITUDE FUNCTIONS - SPEPS COMPUTE UTILITY SPECTRAL FIELDS - SPLEGEND COMPUTE LEGENDRE POLYNOMIALS - SPANALY ANALYZE SPECTRAL FROM FOURIER - SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL - SPDZ2UV COMPUTE WINDS FROM DIVERGENCE AND VORTICITY - SPUV2DZ COMPUTE DIVERGENCE AND VORTICITY FROM WINDS - SPGRADQ COMPUTE GRADIENT IN SPECTRAL SPACE - SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE - - - - - - - - - - - - - - - - -III. Examples - -Example 1. Interpolate heights and winds from a latlon grid - to two antipodal polar stereographic grids. - Subprograms GETGB and PUTGB from w3lib are referenced. - -c unit number 11 is the input latlon grib file -c unit number 31 is the input latlon grib index file -c unit number 51 is the output northern polar stereographic grib file -c unit number 52 is the output southern polar stereographic grib file -c nominal spectral truncation is r40 -c maximum input gridsize is 360x181 -c maximum number of levels wanted is 12 - parameter(lug=11,lui=31,lun=51,lus=52) - parameter(iromb=1,maxwv=40,jf=360*181,kx=12) - integer kp5(kx),kp6(kx),kp7(kx) - integer kpo(kx) - data kpo/1000,850,700,500,400,300,250,200,150,100,70,50/ -c height - km=12 - kp5=7 - kp6=100 - kp7=kpo - call gs65(lug,lui,lun,lus,jf,km,kp5,kp6,kp7,iromb,maxwv) -c winds - km=12 - kp5=33 - kp6=100 - kp7=kpo - call gv65(lug,lui,lun,lus,jf,km,kp5,kp6,kp7,iromb,maxwv) -c - stop - end -c - subroutine gs65(lug,lui,lun,lus,jf,km,kp5,kp6,kp7,iromb,maxwv) -c interpolates a scalar field using spectral transforms. - integer kp5(km),kp6(km),kp7(km) -c output grids are 65x65 (381 km true at latitide 60). -c nh grid oriented at 280E; sh grid oriented at 100E. - parameter(nph=32,nps=2*nph+1,npq=nps*nps) - parameter(true=60.,xmesh=381.e3,orient=280.) - parameter(rerth=6.3712e6) - parameter(pi=3.14159265358979,dpr=180./pi) - real gn(npq,km),gs(npq,km) - integer jpds(25),jgds(22),kpds(25,km),kgds(22,km) - logical lb(jf) - real f(jf,km) -c - g2=((1.+sin(abs(true)/dpr))*rerth/xmesh)**2 - r2=2*nph**2 - rlatn1=dpr*asin((g2-r2)/(g2+r2)) - rlonn1=mod(orient+315,360.) - rlats1=-rlatn1 - rlons1=mod(rlonn1+270,360.) - jpds=-1 - do k=1,km - jpds(5)=kp5(k) - jpds(6)=kp6(k) - jpds(7)=kp7(k) - j=0 - call getgb(lug,lui,jf,j,jpds,jgds,kf,j,kpds(1,k),kgds(1,k), - & lb,f(1,k),iret) - if(iret.ne.0) call exit(1) - if(mod(kpds(4,k)/64,2).eq.1) call exit(2) - enddo - idrt=kgds(1,1) - imax=kgds(2,1) - jmax=kgds(3,1) -c - call sptruns(iromb,maxwv,idrt,imax,jmax,km,nps, - & 0,0,0,jf,0,0,0,0,true,xmesh,orient,f,gn,gs) -c - do k=1,km - kpds(3,k)=27 - kgds(1,k)=5 - kgds(2,k)=nps - kgds(3,k)=nps - kgds(4,k)=nint(rlatn1*1.e3) - kgds(5,k)=nint(rlonn1*1.e3) - kgds(6,k)=8 - kgds(7,k)=nint(orient*1.e3) - kgds(8,k)=nint(xmesh) - kgds(9,k)=nint(xmesh) - kgds(10,k)=0 - kgds(11,k)=64 - call putgb(lun,npq,kpds(1,k),kgds(1,k),lb,gn(1,k),iret) - enddo - do k=1,km - kpds(3,k)=28 - kgds(1,k)=5 - kgds(2,k)=nps - kgds(3,k)=nps - kgds(4,k)=nint(rlats1*1.e3) - kgds(5,k)=nint(rlons1*1.e3) - kgds(6,k)=8 - kgds(7,k)=nint(mod(orient+180,360.)*1.e3) - kgds(8,k)=nint(xmesh) - kgds(9,k)=nint(xmesh) - kgds(10,k)=128 - kgds(11,k)=64 - call putgb(lus,npq,kpds(1,k),kgds(1,k),lb,gs(1,k),iret) - enddo -c - end -c - subroutine gv65(lug,lui,lun,lus,jf,km,kp5,kp6,kp7,iromb,maxwv) -c interpolates a vector field using spectral transforms. - integer kp5(km),kp6(km),kp7(km) -c output grids are 65x65 (381 km true at latitide 60). -c nh grid oriented at 280E; sh grid oriented at 100E. -c winds are rotated to be relative to grid coordinates. - parameter(nph=32,nps=2*nph+1,npq=nps*nps) - parameter(true=60.,xmesh=381.e3,orient=280.) - parameter(rerth=6.3712e6) - parameter(pi=3.14159265358979,dpr=180./pi) - real un(npq,km),vn(npq,km),us(npq,km),vs(npq,km) - integer jpds(25),jgds(22),kpds(25,km),kgds(22,km) - logical lb(jf) - real u(jf,km),v(jf,km) -c - g2=((1.+sin(abs(true)/dpr))*rerth/xmesh)**2 - r2=2*nph**2 - rlatn1=dpr*asin((g2-r2)/(g2+r2)) - rlonn1=mod(orient+315,360.) - rlats1=-rlatn1 - rlons1=mod(rlonn1+270,360.) - jpds=-1 - do k=1,km - jpds(5)=kp5(k) - jpds(6)=kp6(k) - jpds(7)=kp7(k) - j=0 - call getgb(lug,lui,jf,j,jpds,jgds,kf,j,kpds(1,k),kgds(1,k), - & lb,u(1,k),iret) - if(iret.ne.0) call exit(1) - if(mod(kpds(4,k)/64,2).eq.1) call exit(2) - jpds=kpds(:,k) - jgds=kgds(:,k) - jpds(5)=jpds(5)+1 - j=0 - call getgb(lug,lui,jf,j,jpds,jgds,kf,j,kpds(1,k),kgds(1,k), - & lb,v(1,k),iret) - if(iret.ne.0) call exit(1) - if(mod(kpds(4,k)/64,2).eq.1) call exit(2) - enddo - idrt=kgds(1,1) - imax=kgds(2,1) - jmax=kgds(3,1) -c - call sptrunsv(iromb,maxwv,idrt,imax,jmax,km,nps, - & 0,0,0,jf,0,0,0,0,true,xmesh,orient,u,v, - & .true.,un,vn,us,vs,.false.,dum,dum,dum,dum, - & .false.,dum,dum,dum,dum) -c - do k=1,km - kpds(3,k)=27 - kgds(1,k)=5 - kgds(2,k)=nps - kgds(3,k)=nps - kgds(4,k)=nint(rlatn1*1.e3) - kgds(5,k)=nint(rlonn1*1.e3) - kgds(6,k)=8 - kgds(7,k)=nint(orient*1.e3) - kgds(8,k)=nint(xmesh) - kgds(9,k)=nint(xmesh) - kgds(10,k)=0 - kgds(11,k)=64 - kpds(5,k)=kp5(k) - call putgb(lun,npq,kpds(1,k),kgds(1,k),lb,un(1,k),iret) - enddo - do k=1,km - kpds(3,k)=27 - kgds(1,k)=5 - kgds(2,k)=nps - kgds(3,k)=nps - kgds(4,k)=nint(rlatn1*1.e3) - kgds(5,k)=nint(rlonn1*1.e3) - kgds(6,k)=8 - kgds(7,k)=nint(orient*1.e3) - kgds(8,k)=nint(xmesh) - kgds(9,k)=nint(xmesh) - kgds(10,k)=0 - kgds(11,k)=64 - kpds(5,k)=kp5(k)+1 - call putgb(lun,npq,kpds(1,k),kgds(1,k),lb,vn(1,k),iret) - enddo - do k=1,km - kpds(3,k)=28 - kgds(1,k)=5 - kgds(2,k)=nps - kgds(3,k)=nps - kgds(4,k)=nint(rlats1*1.e3) - kgds(5,k)=nint(rlons1*1.e3) - kgds(6,k)=8 - kgds(7,k)=nint(mod(orient+180,360.)*1.e3) - kgds(8,k)=nint(xmesh) - kgds(9,k)=nint(xmesh) - kgds(10,k)=128 - kgds(11,k)=64 - kpds(5,k)=kp5(k) - call putgb(lus,npq,kpds(1,k),kgds(1,k),lb,us(1,k),iret) - enddo - do k=1,km - kpds(3,k)=28 - kgds(1,k)=5 - kgds(2,k)=nps - kgds(3,k)=nps - kgds(4,k)=nint(rlats1*1.e3) - kgds(5,k)=nint(rlons1*1.e3) - kgds(6,k)=8 - kgds(7,k)=nint(mod(orient+180,360.)*1.e3) - kgds(8,k)=nint(xmesh) - kgds(9,k)=nint(xmesh) - kgds(10,k)=128 - kgds(11,k)=64 - kpds(5,k)=kp5(k)+1 - call putgb(lus,npq,kpds(1,k),kgds(1,k),lb,vs(1,k),iret) - enddo -c - end - -Example 2. Spectrally truncate winds in place on a latlon grid. - -c unit number 11 is the input latlon grib file -c unit number 31 is the input latlon grib index file -c unit number 51 is the output latlon grib file -c nominal spectral truncation is r40 -c maximum input gridsize is 360x181 -c maximum number of levels wanted is 12 - parameter(lug=11,lui=31,luo=51) - parameter(iromb=1,maxwv=40,jf=360*181,kx=12) - integer kp5(kx),kp6(kx),kp7(kx) - integer kpo(kx) - data kpo/1000,850,700,500,400,300,250,200,150,100,70,50/ -c winds - km=12 - kp5=33 - kp6=100 - kp7=kpo - call gvr40(lug,lui,luo,jf,km,kp5,kp6,kp7,iromb,maxwv) -c - stop - end -c - subroutine gvr40(lug,lui,luo,jf,km,kp5,kp6,kp7,iromb,maxwv) -c interpolates a vector field using spectral transforms. - integer kp5(km),kp6(km),kp7(km) - integer jpds(25),jgds(22),kpds(25,km),kgds(22,km) - logical lb(jf) - real u(jf,km),v(jf,km) -c - jpds=-1 - do k=1,km - jpds(5)=kp5(k) - jpds(6)=kp6(k) - jpds(7)=kp7(k) - j=0 - call getgb(lug,lui,jf,j,jpds,jgds,kf,j,kpds(1,k),kgds(1,k), - & lb,u(1,k),iret) - if(iret.ne.0) call exit(1) - if(mod(kpds(4,k)/64,2).eq.1) call exit(2) - jpds=kpds(:,k) - jgds=kgds(:,k) - jpds(5)=jpds(5)+1 - j=0 - call getgb(lug,lui,jf,j,jpds,jgds,kf,j,kpds(1,k),kgds(1,k), - & lb,v(1,k),iret) - if(iret.ne.0) call exit(1) - if(mod(kpds(4,k)/64,2).eq.1) call exit(2) - enddo - idrt=kgds(1,1) - imax=kgds(2,1) - jmax=kgds(3,1) -c - call sptrunv(iromb,maxwv,idrt,imax,jmax,idrt,imax,jmax,km, - & 0,0,0,jf,0,0,jf,0,u,v,.true.,u,v, - & .false.,dum,dum,.false.,dum,dum) -c - do k=1,km - kpds(5,k)=kp5(k) - call putgb(luo,kf,kpds(1,k),kgds(1,k),lb,u(1,k),iret) - enddo - do k=1,km - kpds(5,k)=kp5(k)+1 - call putgb(luo,kf,kpds(1,k),kgds(1,k),lb,v(1,k),iret) - enddo -c - end - -Example 3. Compute latlon temperatures from spectral temperatures and - compute latlon winds from spectral divergence and vorticity. - -c unit number 11 is the input sigma file -c unit number 51 is the output latlon file -c nominal spectral truncation is t62 -c output gridsize is 144x73 -c number of levels is 28 - parameter(iromb=0,maxwv=62) - parameter(idrt=0,im=144,jm=73) - parameter(levs=28) - parameter(mx=(maxwv+1)*((iromb+1)*maxwv+2)/2) - real t(mx,levs),d(mx,levs),z(mx,levs) - real tg(im,jm,km),ug(im,jm,km),vg(im,jm,km) -c temperature - do k=1,4 - read(11) - enddo - do k=1,levs - read(11) (t(m,k),m=1,mx) - enddo - call sptran(iromb,maxwv,idrt,im,jm,levs,0,0,0,0,0,0,0,0,1, - & t,tg(1,1,1),tg(1,jm,1),1) - call sptran( - do k=1,levs - write(51) ((tg(i,j,k),i=1,im),j=1,jm) - enddo -c winds - do k=1,levs - read(11) (d(m,k),m=1,mx) - read(11) (z(m,k),m=1,mx) - enddo - call sptranv(iromb,maxwv,idrt,im,jm,levs,0,0,0,0,0,0,0,0,1, - & d,z,ug(1,1,1),ug(1,jm,1),vg(1,1,1),vg(1,jm,1),1) - do k=1,levs - write(51) ((ug(i,j,k),i=1,im),j=1,jm) - write(51) ((vg(i,j,k),i=1,im),j=1,jm) - enddo - end - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -IV. Docblocks - -The primary documentation of splib is via the docblocks in its subprograms. -The following recapitulation of docblocks is current as of May, 1996. - -Docblock for sptrun. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUN SPECTRALLY TRUNCATE GRIDDED SCALAR FIELDS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES SCALAR FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS -C TO A POSSIBLY DIFFERENT GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C EITHER GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTRUN(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,IDRTO,IMAXO,JMAXO, -C & KMAX,IPRIME,ISKIPI,JSKIPI,KSKIPI, -C & ISKIPO,JSKIPO,KSKIPO,JCPU,GRIDI,GRIDO) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C IDRTO - INTEGER OUTPUT GRID IDENTIFIER -C (IDRTO=4 FOR GAUSSIAN GRID, -C IDRTO=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTO=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXO - INTEGER EVEN NUMBER OF OUTPUT LONGITUDES. -C JMAXO - INTEGER NUMBER OF OUTPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C ISKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPO=0) -C JSKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXO IF JSKIPO=0) -C KSKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT GRID FIELDS -C (DEFAULTS TO IMAXO*JMAXO IF KSKIPO=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C GRIDI - REAL (*) INPUT GRID FIELDS -C OUTPUT ARGUMENTS: -C GRIDO - REAL (*) OUTPUT GRID FIELDS -C (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE) -C -C SUBPROGRAMS CALLED: -C SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptrunv. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUNV SPECTRALLY TRUNCATE GRIDDED VECTOR FIELDS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES VECTOR FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS -C TO A POSSIBLY DIFFERENT GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C EITHER GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C OVER ZONAL WAVENUMBER TO ENSURE REPRODUCIBILITY. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTRUNV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI, -C & IDRTO,IMAXO,JMAXO,KMAX, -C & IPRIME,ISKIPI,JSKIPI,KSKIPI, -C & ISKIPO,JSKIPO,KSKIPO,JCPU,GRIDUI,GRIDVI, -C & LUV,GRIDUO,GRIDVO,LDZ,GRIDDO,GRIDZO, -C & LPS,GRIDPO,GRIDSO) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C IDRTO - INTEGER OUTPUT GRID IDENTIFIER -C (IDRTO=4 FOR GAUSSIAN GRID, -C IDRTO=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTO=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXO - INTEGER EVEN NUMBER OF OUTPUT LONGITUDES. -C JMAXO - INTEGER NUMBER OF OUTPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C ISKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPO=0) -C JSKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXO IF JSKIPO=0) -C KSKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT GRID FIELDS -C (DEFAULTS TO IMAXO*JMAXO IF KSKIPO=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C GRIDUI - REAL (*) INPUT GRID U-WINDS -C GRIDVI - REAL (*) INPUT GRID V-WINDS -C LUV - LOGICAL FLAG WHETHER TO RETURN WINDS -C LDZ - LOGICAL FLAG WHETHER TO RETURN DIVERGENCE AND VORTICITY -C LPS - LOGICAL FLAG WHETHER TO RETURN POTENTIAL AND STREAMFCN -C OUTPUT ARGUMENTS: -C GRIDUO - REAL (*) OUTPUT U-WINDS IF LUV -C (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE) -C GRIDVO - REAL (*) OUTPUT V-WINDS IF LUV -C (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE) -C GRIDDO - REAL (*) OUTPUT DIVERGENCES IF LDZ -C (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE) -C GRIDZO - REAL (*) OUTPUT VORTICITIES IF LDZ -C (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE) -C GRIDPO - REAL (*) OUTPUT POTENTIALS IF LPS -C (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE) -C GRIDSO - REAL (*) OUTPUT STREAMFCNS IF LPS -C (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE) -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -C SPTRANV PERFORM A VECTOR SPHERICAL TRANSFORM -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptrung. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUNG SPECTRALLY INTERPOLATE SCALARS TO STATIONS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES SCALAR FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS -C TO SPECIFIED SETS OF STATION POINTS ON THE GLOBE. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID AND POINT FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTRUNG(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,NMAX, -C & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, -C & NRSKIP,NGSKIP,JCPU,RLAT,RLON,GRIDI,GP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NMAX - INTEGER NUMBER OF STATION POINTS TO RETURN -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINT SETS -C (DEFAULTS TO NMAX IF KGSKIP=0) -C NRSKIP - INTEGER SKIP NUMBER BETWEEN STATION LATS AND LONS -C (DEFAULTS TO 1 IF NRSKIP=0) -C NGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINTS -C (DEFAULTS TO 1 IF NGSKIP=0) -C RLAT - REAL (*) STATION LATITUDES IN DEGREES -C RLON - REAL (*) STATION LONGITUDES IN DEGREES -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C GRIDI - REAL (*) INPUT GRID FIELDS -C OUTPUT ARGUMENTS: -C GP - REAL (*) STATION POINT SETS -C -C SUBPROGRAMS CALLED: -C SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -C SPTGPT TRANSFORM SPECTRAL SCALAR TO STATION POINTS -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptrungv. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUNGV SPECTRALLY INTERPOLATE VECTORS TO STATIONS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES VECTORS FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS -C TO SPECIFIED SETS OF STATION POINTS ON THE GLOBE. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID AND POINT FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTRUNGV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,NMAX, -C & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, -C & NRSKIP,NGSKIP,JCPU,RLAT,RLON,GRIDUI,GRIDVI, -C & LUV,UP,VP,LDZ,DP,ZP,LPS,PP,SP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NMAX - INTEGER NUMBER OF STATION POINTS TO RETURN -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINT SETS -C (DEFAULTS TO NMAX IF KGSKIP=0) -C NRSKIP - INTEGER SKIP NUMBER BETWEEN STATION LATS AND LONS -C (DEFAULTS TO 1 IF NRSKIP=0) -C NGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINTS -C (DEFAULTS TO 1 IF NGSKIP=0) -C RLAT - REAL (*) STATION LATITUDES IN DEGREES -C RLON - REAL (*) STATION LONGITUDES IN DEGREES -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C GRIDUI - REAL (*) INPUT GRID U-WINDS -C GRIDVI - REAL (*) INPUT GRID V-WINDS -C LUV - LOGICAL FLAG WHETHER TO RETURN WINDS -C LDZ - LOGICAL FLAG WHETHER TO RETURN DIVERGENCE AND VORTICITY -C LPS - LOGICAL FLAG WHETHER TO RETURN POTENTIAL AND STREAMFCN -C OUTPUT ARGUMENTS: -C UP - REAL (*) STATION U-WINDS IF LUV -C VP - REAL (*) STATION V-WINDS IF LUV -C DP - REAL (*) STATION DIVERGENCES IF LDZ -C ZP - REAL (*) STATION VORTICITIES IF LDZ -C PP - REAL (*) STATION POTENTIALS IF LPS -C SP - REAL (*) STATION STREAMFCNS IF LPS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTRANV PERFORM A VECTOR SPHERICAL TRANSFORM -C SPTGPT TRANSFORM SPECTRAL SCALAR TO STATION POINTS -C SPTGPTV TRANSFORM SPECTRAL VECTOR TO STATION POINTS -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptruns. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUNS SPECTRALLY INTERPOLATE SCALARS TO POLAR STEREO -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES SCALAR FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS -C TO SPECIFIC PAIRS OF POLAR STEREOGRAPHIC SCALAR FIELDS. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTRUNS(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,NPS, -C & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, -C & NISKIP,NJSKIP,JCPU,TRUE,XMESH,ORIENT, -C & GRIDI,GN,GS) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NPS - INTEGER ODD ORDER OF THE POLAR STEREOGRAPHIC GRIDS -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO NPS*NPS IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO NPS IF NJSKIP=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C TRUE - REAL LATITUDE AT WHICH PS GRID IS TRUE (USUALLY 60.) -C XMESH - REAL GRID LENGTH AT TRUE LATITUDE (M) -C ORIENT - REAL LONGITUDE AT BOTTOM OF NORTHERN PS GRID -C (SOUTHERN PS GRID WILL HAVE OPPOSITE ORIENTATION.) -C GRIDI - REAL (*) INPUT GRID FIELDS -C OUTPUT ARGUMENTS: -C GN - REAL (*) NORTHERN POLAR STEREOGRAPHIC FIELDS -C GS - REAL (*) SOUTHERN POLAR STEREOGRAPHIC FIELDS -C -C SUBPROGRAMS CALLED: -C SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -C SPTGPS TRANSFORM SPECTRAL SCALAR TO POLAR STEREO. -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptrunsv. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUNSV SPECTRALLY INTERPOLATE VECTORS TO POLAR STEREO -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES VECTOR FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS -C TO SPECIFIC PAIRS OF POLAR STEREOGRAPHIC SCALAR FIELDS. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTRUNSV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,NPS, -C & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, -C & NISKIP,NJSKIP,JCPU,TRUE,XMESH,ORIENT, -C & GRIDUI,GRIDVI, -C & LUV,UN,VN,US,VS,LDZ,DN,ZN,DS,ZS, -C & LPS,PN,SN,PS,SS) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NPS - INTEGER ODD ORDER OF THE POLAR STEREOGRAPHIC GRIDS -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO NPS*NPS IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO NPS IF NJSKIP=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C TRUE - REAL LATITUDE AT WHICH PS GRID IS TRUE (USUALLY 60.) -C XMESH - REAL GRID LENGTH AT TRUE LATITUDE (M) -C ORIENT - REAL LONGITUDE AT BOTTOM OF NORTHERN PS GRID -C (SOUTHERN PS GRID WILL HAVE OPPOSITE ORIENTATION.) -C GRIDUI - REAL (*) INPUT GRID U-WINDS -C GRIDVI - REAL (*) INPUT GRID V-WINDS -C LUV - LOGICAL FLAG WHETHER TO RETURN WINDS -C LDZ - LOGICAL FLAG WHETHER TO RETURN DIVERGENCE AND VORTICITY -C LPS - LOGICAL FLAG WHETHER TO RETURN POTENTIAL AND STREAMFCN -C OUTPUT ARGUMENTS: -C UN - REAL (*) NORTHERN PS U-WINDS IF LUV -C VN - REAL (*) NORTHERN PS V-WINDS IF LUV -C US - REAL (*) SOUTHERN PS U-WINDS IF LUV -C VS - REAL (*) SOUTHERN PS V-WINDS IF LUV -C DN - REAL (*) NORTHERN DIVERGENCES IF LDZ -C ZN - REAL (*) NORTHERN VORTICITIES IF LDZ -C DS - REAL (*) SOUTHERN DIVERGENCES IF LDZ -C ZS - REAL (*) SOUTHERN VORTICITIES IF LDZ -C PN - REAL (*) NORTHERN POTENTIALS IF LPS -C SN - REAL (*) NORTHERN STREAMFCNS IF LPS -C PS - REAL (*) SOUTHERN POTENTIALS IF LPS -C SS - REAL (*) SOUTHERN STREAMFCNS IF LPS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTRANV PERFORM A VECTOR SPHERICAL TRANSFORM -C SPTGPS TRANSFORM SPECTRAL SCALAR TO POLAR STEREO. -C SPTGPSV TRANSFORM SPECTRAL VECTOR TO POLAR STEREO. -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptrunm. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUNM SPECTRALLY INTERPOLATE SCALARS TO MERCATOR -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES SCALAR FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS -C TO A MERCATOR GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTRUNM(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,MI,MJ, -C & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, -C & NISKIP,NJSKIP,JCPU,RLAT1,RLON1,DLAT,DLON, -C & GRIDI,GM) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C MI - INTEGER NUMBER OF POINTS IN THE FASTER ZONAL DIRECTION -C MJ - INTEGER NUMBER OF POINTS IN THE SLOWER MERID DIRECTION -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO NPS*NPS IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO NPS IF NJSKIP=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C RLAT1 - REAL LATITUDE OF THE FIRST GRID POINT IN DEGREES -C RLON1 - REAL LONGITUDE OF THE FIRST GRID POINT IN DEGREES -C DLAT - REAL LATITUDE INCREMENT IN DEGREES SUCH THAT -C D(PHI)/D(J)=DLAT*COS(PHI) WHERE J IS MERIDIONAL INDEX. -C DLAT IS NEGATIVE FOR GRIDS INDEXED SOUTHWARD. -C (IN TERMS OF GRID INCREMENT DY VALID AT LATITUDE RLATI, -C THE LATITUDE INCREMENT DLAT IS DETERMINED AS -C DLAT=DPR*DY/(RERTH*COS(RLATI/DPR)) -C WHERE DPR=180/PI AND RERTH IS EARTH'S RADIUS) -C DLON - REAL LONGITUDE INCREMENT IN DEGREES SUCH THAT -C D(LAMBDA)/D(I)=DLON WHERE I IS ZONAL INDEX. -C DLON IS NEGATIVE FOR GRIDS INDEXED WESTWARD. -C GRIDI - REAL (*) INPUT GRID FIELDS -C OUTPUT ARGUMENTS: -C GM - REAL (*) MERCATOR FIELDS -C -C SUBPROGRAMS CALLED: -C SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -C SPTGPM TRANSFORM SPECTRAL SCALAR TO MERCATOR -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptrunmv. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUNMV SPECTRALLY INTERPOLATE VECTORS TO MERCATOR -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES VECTOR FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS -C TO A MERCATOR GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTRUNMV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,MI,MJ, -C & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, -C & NISKIP,NJSKIP,JCPU,RLAT1,RLON1,DLAT,DLON, -C & GRIDUI,GRIDVI,LUV,UM,VM,LDZ,DM,ZM,LPS,PM,SM) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C MI - INTEGER NUMBER OF POINTS IN THE FASTER ZONAL DIRECTION -C MJ - INTEGER NUMBER OF POINTS IN THE SLOWER MERID DIRECTION -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO MI*MJ IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO MI IF NJSKIP=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C RLAT1 - REAL LATITUDE OF THE FIRST GRID POINT IN DEGREES -C RLON1 - REAL LONGITUDE OF THE FIRST GRID POINT IN DEGREES -C DLAT - REAL LATITUDE INCREMENT IN DEGREES SUCH THAT -C D(PHI)/D(J)=DLAT*COS(PHI) WHERE J IS MERIDIONAL INDEX. -C DLAT IS NEGATIVE FOR GRIDS INDEXED SOUTHWARD. -C (IN TERMS OF GRID INCREMENT DY VALID AT LATITUDE RLATI, -C THE LATITUDE INCREMENT DLAT IS DETERMINED AS -C DLAT=DPR*DY/(RERTH*COS(RLATI/DPR)) -C WHERE DPR=180/PI AND RERTH IS EARTH'S RADIUS) -C DLON - REAL LONGITUDE INCREMENT IN DEGREES SUCH THAT -C D(LAMBDA)/D(I)=DLON WHERE I IS ZONAL INDEX. -C DLON IS NEGATIVE FOR GRIDS INDEXED WESTWARD. -C GRIDUI - REAL (*) INPUT GRID U-WINDS -C GRIDVI - REAL (*) INPUT GRID V-WINDS -C LUV - LOGICAL FLAG WHETHER TO RETURN WINDS -C LDZ - LOGICAL FLAG WHETHER TO RETURN DIVERGENCE AND VORTICITY -C LPS - LOGICAL FLAG WHETHER TO RETURN POTENTIAL AND STREAMFCN -C OUTPUT ARGUMENTS: -C UM - REAL (*) MERCATOR U-WINDS IF LUV -C VM - REAL (*) MERCATOR V-WINDS IF LUV -C DM - REAL (*) MERCATOR DIVERGENCES IF LDZ -C ZM - REAL (*) MERCATOR VORTICITIES IF LDZ -C PM - REAL (*) MERCATOR POTENTIALS IF LPS -C SM - REAL (*) MERCATOR STREAMFCNS IF LPS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTRANV PERFORM A VECTOR SPHERICAL TRANSFORM -C SPTGPM TRANSFORM SPECTRAL SCALAR TO MERCATOR -C SPTGPMV TRANSFORM SPECTRAL VECTOR TO MERCATOR -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptran. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C BETWEEN SPECTRAL COEFFICIENTS OF SCALAR QUANTITIES -C AND FIELDS ON A GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C TRANSFORMS ARE DONE IN LATITUDE PAIRS FOR EFFICIENCY; -C THUS GRID ARRAYS FOR EACH HEMISPHERE MUST BE PASSED. -C IF SO REQUESTED, JUST A SUBSET OF THE LATITUDE PAIRS -C MAY BE TRANSFORMED IN EACH INVOCATION OF THE SUBPROGRAM. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER LATITUDE EXCEPT -C THE TRANSFORM FROM FOURIER TO SPECTRAL IS MULTIPROCESSED -C OVER ZONAL WAVENUMBER TO ENSURE REPRODUCIBILITY. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTRAN(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, -C & IPRIME,ISKIP,JNSKIP,JSSKIP,KWSKIP,KGSKIP, -C & JBEG,JEND,JCPU, -C & WAVE,GRIDN,GRIDS,IDIR) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES. -C JMAX - INTEGER NUMBER OF LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C IPRIME - INTEGER LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C ISKIP - INTEGER SKIP NUMBER BETWEEN LONGITUDES -C (DEFAULTS TO 1 IF ISKIP=0) -C JNSKIP - INTEGER SKIP NUMBER BETWEEN N.H. LATITUDES FROM NORTH -C (DEFAULTS TO IMAX IF JNSKIP=0) -C JSSKIP - INTEGER SKIP NUMBER BETWEEN S.H. LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAX IF JSSKIP=0) -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO IMAX*JMAX IF KGSKIP=0) -C JBEG - INTEGER LATITUDE INDEX (FROM POLE) TO BEGIN TRANSFORM -C (DEFAULTS TO 1 IF JBEG=0) -C (IF JBEG=0 AND IDIR<0, WAVE IS ZEROED BEFORE TRANSFORM) -C JEND - INTEGER LATITUDE INDEX (FROM POLE) TO END TRANSFORM -C (DEFAULTS TO (JMAX+1)/2 IF JEND=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C WAVE - REAL (*) WAVE FIELDS IF IDIR>0 -C GRIDN - REAL (*) N.H. GRID FIELDS (STARTING AT JBEG) IF IDIR<0 -C GRIDS - REAL (*) S.H. GRID FIELDS (STARTING AT JBEG) IF IDIR<0 -C IDIR - INTEGER TRANSFORM FLAG -C (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -C OUTPUT ARGUMENTS: -C WAVE - REAL (*) WAVE FIELDS IF IDIR<0 -C GRIDN - REAL (*) N.H. GRID FIELDS (STARTING AT JBEG) IF IDIR>0 -C GRIDS - REAL (*) S.H. GRID FIELDS (STARTING AT JBEG) IF IDIR>0 -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPGGET GET GRID-SPACE CONSTANTS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C SPANALY ANALYZE SPECTRAL FROM FOURIER -C RFFTMLT PERFORM FAST FOURIER TRANSFORM -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptranv. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRANV PERFORM A VECTOR SPHERICAL TRANSFORM -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C BETWEEN SPECTRAL COEFFICIENTS OF DIVERGENCES AND CURLS -C AND VECTOR FIELDS ON A GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C TRANSFORMS ARE DONE IN LATITUDE PAIRS FOR EFFICIENCY; -C THUS GRID ARRAYS FOR EACH HEMISPHERE MUST BE PASSED. -C IF SO REQUESTED, JUST A SUBSET OF THE LATITUDE PAIRS -C MAY BE TRANSFORMED IN EACH INVOCATION OF THE SUBPROGRAM. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER LATITUDE EXCEPT -C THE TRANSFORM FROM FOURIER TO SPECTRAL IS MULTIPROCESSED -C OVER ZONAL WAVENUMBER TO ENSURE REPRODUCIBILITY. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTRANV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, -C & IPRIME,ISKIP,JNSKIP,JSSKIP,KWSKIP,KGSKIP, -C & JBEG,JEND,JCPU, -C & WAVED,WAVEZ,GRIDUN,GRIDUS,GRIDVN,GRIDVS,IDIR) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES. -C JMAX - INTEGER NUMBER OF LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C IPRIME - INTEGER LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C ISKIP - INTEGER SKIP NUMBER BETWEEN LONGITUDES -C (DEFAULTS TO 1 IF ISKIP=0) -C JNSKIP - INTEGER SKIP NUMBER BETWEEN N.H. LATITUDES FROM NORTH -C (DEFAULTS TO IMAX IF JNSKIP=0) -C JSSKIP - INTEGER SKIP NUMBER BETWEEN S.H. LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAX IF JSSKIP=0) -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO IMAX*JMAX IF KGSKIP=0) -C JBEG - INTEGER LATITUDE INDEX (FROM POLE) TO BEGIN TRANSFORM -C (DEFAULTS TO 1 IF JBEG=0) -C (IF JBEG=0 AND IDIR<0, WAVE IS ZEROED BEFORE TRANSFORM) -C JEND - INTEGER LATITUDE INDEX (FROM POLE) TO END TRANSFORM -C (DEFAULTS TO (JMAX+1)/2 IF JEND=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C WAVED - REAL (*) WAVE DIVERGENCE FIELDS IF IDIR>0 -C WAVEZ - REAL (*) WAVE VORTICITY FIELDS IF IDIR>0 -C GRIDUN - REAL (*) N.H. GRID U-WINDS (STARTING AT JBEG) IF IDIR<0 -C GRIDUS - REAL (*) S.H. GRID U-WINDS (STARTING AT JBEG) IF IDIR<0 -C GRIDVN - REAL (*) N.H. GRID V-WINDS (STARTING AT JBEG) IF IDIR<0 -C GRIDVS - REAL (*) S.H. GRID V-WINDS (STARTING AT JBEG) IF IDIR<0 -C IDIR - INTEGER TRANSFORM FLAG -C (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -C OUTPUT ARGUMENTS: -C WAVED - REAL (*) WAVE DIVERGENCE FIELDS IF IDIR<0 -C [WAVED=(D(GRIDU)/DLAM+D(CLAT*GRIDV)/DPHI)/(CLAT*RERTH)] -C WAVEZ - REAL (*) WAVE VORTICITY FIELDS IF IDIR<0 -C [WAVEZ=(D(GRIDV)/DLAM-D(CLAT*GRIDU)/DPHI)/(CLAT*RERTH)] -C GRIDUN - REAL (*) N.H. GRID U-WINDS (STARTING AT JBEG) IF IDIR>0 -C GRIDUS - REAL (*) S.H. GRID U-WINDS (STARTING AT JBEG) IF IDIR>0 -C GRIDVN - REAL (*) N.H. GRID V-WINDS (STARTING AT JBEG) IF IDIR>0 -C GRIDVS - REAL (*) S.H. GRID V-WINDS (STARTING AT JBEG) IF IDIR>0 -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPGGET GET GRID-SPACE CONSTANTS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C SPANALY ANALYZE SPECTRAL FROM FOURIER -C RFFTMLT PERFORM FAST FOURIER TRANSFORM -C SPDZ2UV COMPUTE WINDS FROM DIVERGENCE AND VORTICITY -C SPUV2DZ COMPUTE DIVERGENCE AND VORTICITY FROM WINDS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptrand. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRAND PERFORM A GRADIENT SPHERICAL TRANSFORM -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C BETWEEN SPECTRAL COEFFICIENTS OF SCALAR FIELDS -C AND THEIR MEANS AND GRADIENTS ON A GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C TRANSFORMS ARE DONE IN LATITUDE PAIRS FOR EFFICIENCY; -C THUS GRID ARRAYS FOR EACH HEMISPHERE MUST BE PASSED. -C IF SO REQUESTED, JUST A SUBSET OF THE LATITUDE PAIRS -C MAY BE TRANSFORMED IN EACH INVOCATION OF THE SUBPROGRAM. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER LATITUDE EXCEPT -C THE TRANSFORM FROM FOURIER TO SPECTRAL IS MULTIPROCESSED -C OVER ZONAL WAVENUMBER TO ENSURE REPRODUCIBILITY. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTRAND(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, -C & IPRIME,ISKIP,JNSKIP,JSSKIP,KWSKIP,KGSKIP, -C & JBEG,JEND,JCPU, -C & WAVE,GRIDMN,GRIDXN,GRIDXS,GRIDYN,GRIDYS,IDIR) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES. -C JMAX - INTEGER NUMBER OF LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C IPRIME - INTEGER LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C ISKIP - INTEGER SKIP NUMBER BETWEEN LONGITUDES -C (DEFAULTS TO 1 IF ISKIP=0) -C JNSKIP - INTEGER SKIP NUMBER BETWEEN N.H. LATITUDES FROM NORTH -C (DEFAULTS TO IMAX IF JNSKIP=0) -C JSSKIP - INTEGER SKIP NUMBER BETWEEN S.H. LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAX IF JSSKIP=0) -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO IMAX*JMAX IF KGSKIP=0) -C JBEG - INTEGER LATITUDE INDEX (FROM POLE) TO BEGIN TRANSFORM -C (DEFAULTS TO 1 IF JBEG=0) -C (IF JBEG=0 AND IDIR<0, WAVE IS ZEROED BEFORE TRANSFORM) -C JEND - INTEGER LATITUDE INDEX (FROM POLE) TO END TRANSFORM -C (DEFAULTS TO (JMAX+1)/2 IF JEND=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C WAVE - REAL (*) WAVE FIELDS IF IDIR>0 -C GRIDMN - REAL (KMAX) GLOBAL MEANS IF IDIR<0 -C GRIDXN - REAL (*) N.H. X-GRADIENTS (STARTING AT JBEG) IF IDIR<0 -C GRIDXS - REAL (*) S.H. X-GRADIENTS (STARTING AT JBEG) IF IDIR<0 -C GRIDYN - REAL (*) N.H. Y-GRADIENTS (STARTING AT JBEG) IF IDIR<0 -C GRIDYS - REAL (*) S.H. Y-GRADIENTS (STARTING AT JBEG) IF IDIR<0 -C IDIR - INTEGER TRANSFORM FLAG -C (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -C OUTPUT ARGUMENTS: -C WAVE - REAL (*) WAVE FIELDS IF IDIR<0 -C GRIDMN - REAL (KMAX) GLOBAL MEANS IF IDIR>0 -C GRIDXN - REAL (*) N.H. X-GRADIENTS (STARTING AT JBEG) IF IDIR>0 -C GRIDXS - REAL (*) S.H. X-GRADIENTS (STARTING AT JBEG) IF IDIR>0 -C [GRIDX=(D(WAVE)/DLAM)/(CLAT*RERTH)] -C GRIDYN - REAL (*) N.H. Y-GRADIENTS (STARTING AT JBEG) IF IDIR>0 -C GRIDYS - REAL (*) S.H. Y-GRADIENTS (STARTING AT JBEG) IF IDIR>0 -C [GRIDY=(D(WAVE)/DPHI)/RERTH] -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTRANV PERFORM A VECTOR SPHERICAL TRANSFORM -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptgpt. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPT TRANSFORM SPECTRAL SCALAR TO STATION POINTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF SCALAR QUANTITIES -C TO SPECIFIED SETS OF STATION POINTS ON THE GLOBE. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND POINT FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER STATIONS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTGPT(IROMB,MAXWV,KMAX,NMAX, -C & KWSKIP,KGSKIP,NRSKIP,NGSKIP, -C & RLAT,RLON,WAVE,GP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NMAX - INTEGER NUMBER OF STATION POINTS TO RETURN -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINT SETS -C (DEFAULTS TO NMAX IF KGSKIP=0) -C NRSKIP - INTEGER SKIP NUMBER BETWEEN STATION LATS AND LONS -C (DEFAULTS TO 1 IF NRSKIP=0) -C NGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINTS -C (DEFAULTS TO 1 IF NGSKIP=0) -C RLAT - REAL (*) STATION LATITUDES IN DEGREES -C RLON - REAL (*) STATION LONGITUDES IN DEGREES -C WAVE - REAL (*) WAVE FIELDS -C OUTPUT ARGUMENTS: -C GP - REAL (*) STATION POINT SETS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptgptv. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPTV TRANSFORM SPECTRAL VECTOR TO STATION POINTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF DIVERGENCES AND CURLS -C TO SPECIFIED SETS OF STATION POINT VECTORS ON THE GLOBE. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND POINT FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER STATIONS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTGPTV(IROMB,MAXWV,KMAX,NMAX, -C & KWSKIP,KGSKIP,NRSKIP,NGSKIP, -C & RLAT,RLON,WAVED,WAVEZ,UP,VP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NMAX - INTEGER NUMBER OF STATION POINTS TO RETURN -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINT SETS -C (DEFAULTS TO NMAX IF KGSKIP=0) -C NRSKIP - INTEGER SKIP NUMBER BETWEEN STATION LATS AND LONS -C (DEFAULTS TO 1 IF NRSKIP=0) -C NGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINTS -C (DEFAULTS TO 1 IF NGSKIP=0) -C RLAT - REAL (*) STATION LATITUDES IN DEGREES -C RLON - REAL (*) STATION LONGITUDES IN DEGREES -C WAVED - REAL (*) WAVE DIVERGENCE FIELDS -C WAVEZ - REAL (*) WAVE VORTICITY FIELDS -C OUTPUT ARGUMENTS: -C UP - REAL (*) STATION POINT U-WIND SETS -C VP - REAL (*) STATION POINT V-WIND SETS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C SPDZ2UV COMPUTE WINDS FROM DIVERGENCE AND VORTICITY -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptgptd. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPTD TRANSFORM SPECTRAL TO STATION POINT GRADIENTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF SCALAR FIELDS -C TO SPECIFIED SETS OF STATION POINT GRADIENTS ON THE GLOBE. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND POINT FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER STATIONS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTGPTD(IROMB,MAXWV,KMAX,NMAX, -C & KWSKIP,KGSKIP,NRSKIP,NGSKIP, -C & RLAT,RLON,WAVE,XP,YP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NMAX - INTEGER NUMBER OF STATION POINTS TO RETURN -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINT SETS -C (DEFAULTS TO NMAX IF KGSKIP=0) -C NRSKIP - INTEGER SKIP NUMBER BETWEEN STATION LATS AND LONS -C (DEFAULTS TO 1 IF NRSKIP=0) -C NGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINTS -C (DEFAULTS TO 1 IF NGSKIP=0) -C RLAT - REAL (*) STATION LATITUDES IN DEGREES -C RLON - REAL (*) STATION LONGITUDES IN DEGREES -C WAVE - REAL (*) WAVE FIELDS -C OUTPUT ARGUMENTS: -C XP - REAL (*) STATION POINT X-GRADIENT SETS -C YP - REAL (*) STATION POINT Y-GRADIENT SETS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTGPTV TRANSFORM SPECTRAL VECTOR TO STATION POINTS -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptgps. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPS TRANSFORM SPECTRAL SCALAR TO POLAR STEREO. -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF SCALAR QUANTITIES -C TO SCALAR FIELDS ON A PAIR OF POLAR STEREOGRAPHIC GRIDS. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE TWO SQUARE POLAR STEREOGRAPHIC GRIDS ARE CENTERED -C ON THE RESPECTIVE POLES, WITH THE ORIENTATION LONGITUDE -C OF THE SOUTHERN HEMISPHERE GRID 180 DEGREES OPPOSITE -C THAT OF THE NORTHERN HEMISPHERE GRID. -C -C THE TRANSFORM IS MADE EFFICIENT \ 4 | 5 / -C BY COMBINING POINTS IN EIGHT SECTORS \ | / -C OF EACH POLAR STEREOGRAPHIC GRID, 3 \ | / 6 -C NUMBERED AS IN THE DIAGRAM AT RIGHT. \|/ -C THE POLE AND THE SECTOR BOUNDARIES ----+---- -C ARE TREATED SPECIALLY IN THE CODE. /|\ -C UNFORTUNATELY, THIS APPROACH INDUCES 2 / | \ 7 -C SOME HAIRY INDEXING AND CODE LOQUACITY, / | \ -C FOR WHICH THE DEVELOPER APOLOGIZES. / 1 | 8 \ -C -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER SECTOR POINTS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTGPS(IROMB,MAXWV,KMAX,NPS, -C & KWSKIP,KGSKIP,NISKIP,NJSKIP, -C & TRUE,XMESH,ORIENT,WAVE,GN,GS) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NPS - INTEGER ODD ORDER OF THE POLAR STEREOGRAPHIC GRIDS -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO NPS*NPS IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO NPS IF NJSKIP=0) -C TRUE - REAL LATITUDE AT WHICH PS GRID IS TRUE (USUALLY 60.) -C XMESH - REAL GRID LENGTH AT TRUE LATITUDE (M) -C ORIENT - REAL LONGITUDE AT BOTTOM OF NORTHERN PS GRID -C (SOUTHERN PS GRID WILL HAVE OPPOSITE ORIENTATION.) -C WAVE - REAL (*) WAVE FIELDS -C OUTPUT ARGUMENTS: -C GN - REAL (*) NORTHERN POLAR STEREOGRAPHIC FIELDS -C GS - REAL (*) SOUTHERN POLAR STEREOGRAPHIC FIELDS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptgpsv. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPSV TRANSFORM SPECTRAL VECTOR TO POLAR STEREO. -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF DIVERGENCES AND CURLS -C TO VECTOR FIELDS ON A PAIR OF POLAR STEREOGRAPHIC GRIDS. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE TWO SQUARE POLAR STEREOGRAPHIC GRIDS ARE CENTERED -C ON THE RESPECTIVE POLES, WITH THE ORIENTATION LONGITUDE -C OF THE SOUTHERN HEMISPHERE GRID 180 DEGREES OPPOSITE -C THAT OF THE NORTHERN HEMISPHERE GRID. -C THE VECTORS ARE AUTOMATICALLY ROTATED TO BE RESOLVED -C RELATIVE TO THE RESPECTIVE POLAR STEREOGRAPHIC GRIDS. -C -C THE TRANSFORM IS MADE EFFICIENT \ 4 | 5 / -C BY COMBINING POINTS IN EIGHT SECTORS \ | / -C OF EACH POLAR STEREOGRAPHIC GRID, 3 \ | / 6 -C NUMBERED AS IN THE DIAGRAM AT RIGHT. \|/ -C THE POLE AND THE SECTOR BOUNDARIES ----+---- -C ARE TREATED SPECIALLY IN THE CODE. /|\ -C UNFORTUNATELY, THIS APPROACH INDUCES 2 / | \ 7 -C SOME HAIRY INDEXING AND CODE LOQUACITY, / | \ -C FOR WHICH THE DEVELOPER APOLOGIZES. / 1 | 8 \ -C -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER SECTOR POINTS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTGPSV(IROMB,MAXWV,KMAX,NPS, -C & KWSKIP,KGSKIP,NISKIP,NJSKIP, -C & TRUE,XMESH,ORIENT,WAVED,WAVEZ,UN,VN,US,VS) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NPS - INTEGER ODD ORDER OF THE POLAR STEREOGRAPHIC GRIDS -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO NPS*NPS IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO NPS IF NJSKIP=0) -C TRUE - REAL LATITUDE AT WHICH PS GRID IS TRUE (USUALLY 60.) -C XMESH - REAL GRID LENGTH AT TRUE LATITUDE (M) -C ORIENT - REAL LONGITUDE AT BOTTOM OF NORTHERN PS GRID -C (SOUTHERN PS GRID WILL HAVE OPPOSITE ORIENTATION.) -C WAVED - REAL (*) WAVE DIVERGENCE FIELDS -C WAVEZ - REAL (*) WAVE VORTICITY FIELDS -C OUTPUT ARGUMENTS: -C UN - REAL (*) NORTHERN POLAR STEREOGRAPHIC U-WINDS -C VN - REAL (*) NORTHERN POLAR STEREOGRAPHIC V-WINDS -C US - REAL (*) SOUTHERN POLAR STEREOGRAPHIC U-WINDS -C VS - REAL (*) SOUTHERN POLAR STEREOGRAPHIC V-WINDS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C SPDZ2UV COMPUTE WINDS FROM DIVERGENCE AND VORTICITY -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptgpsd. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPSD TRANSFORM SPECTRAL TO POLAR STEREO. GRADIENTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF SCALAR FIELDS -C TO GRADIENT FIELDS ON A PAIR OF POLAR STEREOGRAPHIC GRIDS. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE TWO SQUARE POLAR STEREOGRAPHIC GRIDS ARE CENTERED -C ON THE RESPECTIVE POLES, WITH THE ORIENTATION LONGITUDE -C OF THE SOUTHERN HEMISPHERE GRID 180 DEGREES OPPOSITE -C THAT OF THE NORTHERN HEMISPHERE GRID. -C THE VECTORS ARE AUTOMATICALLY ROTATED TO BE RESOLVED -C RELATIVE TO THE RESPECTIVE POLAR STEREOGRAPHIC GRIDS. -C -C THE TRANSFORM IS MADE EFFICIENT \ 4 | 5 / -C BY COMBINING POINTS IN EIGHT SECTORS \ | / -C OF EACH POLAR STEREOGRAPHIC GRID, 3 \ | / 6 -C NUMBERED AS IN THE DIAGRAM AT RIGHT. \|/ -C THE POLE AND THE SECTOR BOUNDARIES ----+---- -C ARE TREATED SPECIALLY IN THE CODE. /|\ -C UNFORTUNATELY, THIS APPROACH INDUCES 2 / | \ 7 -C SOME HAIRY INDEXING AND CODE LOQUACITY, / | \ -C FOR WHICH THE DEVELOPER APOLOGIZES. / 1 | 8 \ -C -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER SECTOR POINTS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTGPSD(IROMB,MAXWV,KMAX,NPS, -C & KWSKIP,KGSKIP,NISKIP,NJSKIP, -C & TRUE,XMESH,ORIENT,WAVE,XP,YP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NPS - INTEGER ODD ORDER OF THE POLAR STEREOGRAPHIC GRIDS -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO NPS*NPS IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO NPS IF NJSKIP=0) -C TRUE - REAL LATITUDE AT WHICH PS GRID IS TRUE (USUALLY 60.) -C XMESH - REAL GRID LENGTH AT TRUE LATITUDE (M) -C ORIENT - REAL LONGITUDE AT BOTTOM OF NORTHERN PS GRID -C (SOUTHERN PS GRID WILL HAVE OPPOSITE ORIENTATION.) -C WAVE - REAL (*) WAVE FIELDS -C OUTPUT ARGUMENTS: -C XN - REAL (*) NORTHERN POLAR STEREOGRAPHIC X-GRADIENTS -C YN - REAL (*) NORTHERN POLAR STEREOGRAPHIC Y-GRADIENTS -C XS - REAL (*) SOUTHERN POLAR STEREOGRAPHIC X-GRADIENTS -C YS - REAL (*) SOUTHERN POLAR STEREOGRAPHIC Y-GRADIENTS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTGPSV TRANSFORM SPECTRAL VECTOR TO POLAR STEREO. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptgpm. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPM TRANSFORM SPECTRAL SCALAR TO MERCATOR -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF SCALAR QUANTITIES -C TO SCALAR FIELDS ON A MERCATOR GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE MERCATOR GRID IS IDENTIFIED BY THE LOCATION -C OF ITS FIRST POINT AND BY ITS RESPECTIVE INCREMENTS. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER SECTOR POINTS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTGPM(IROMB,MAXWV,KMAX,MI,MJ, -C & KWSKIP,KGSKIP,NISKIP,NJSKIP, -C & RLAT1,RLON1,DLAT,DLON,WAVE,GM) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C MI - INTEGER NUMBER OF POINTS IN THE FASTER ZONAL DIRECTION -C MJ - INTEGER NUMBER OF POINTS IN THE SLOWER MERID DIRECTION -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO MI*MJ IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO MI IF NJSKIP=0) -C RLAT1 - REAL LATITUDE OF THE FIRST GRID POINT IN DEGREES -C RLON1 - REAL LONGITUDE OF THE FIRST GRID POINT IN DEGREES -C DLAT - REAL LATITUDE INCREMENT IN DEGREES SUCH THAT -C D(PHI)/D(J)=DLAT*COS(PHI) WHERE J IS MERIDIONAL INDEX. -C DLAT IS NEGATIVE FOR GRIDS INDEXED SOUTHWARD. -C (IN TERMS OF GRID INCREMENT DY VALID AT LATITUDE RLATI, -C THE LATITUDE INCREMENT DLAT IS DETERMINED AS -C DLAT=DPR*DY/(RERTH*COS(RLATI/DPR)) -C WHERE DPR=180/PI AND RERTH IS EARTH'S RADIUS) -C DLON - REAL LONGITUDE INCREMENT IN DEGREES SUCH THAT -C D(LAMBDA)/D(I)=DLON WHERE I IS ZONAL INDEX. -C DLON IS NEGATIVE FOR GRIDS INDEXED WESTWARD. -C WAVE - REAL (*) WAVE FIELDS -C OUTPUT ARGUMENTS: -C GM - REAL (*) MERCATOR FIELDS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptgpmv. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPMV TRANSFORM SPECTRAL VECTOR TO MERCATOR -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF DIVERGENCES AND CURLS -C TO VECTOR FIELDS ON A MERCATOR GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE MERCATOR GRID IS IDENTIFIED BY THE LOCATION -C OF ITS FIRST POINT AND BY ITS RESPECTIVE INCREMENTS. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER SECTOR POINTS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTGPMV(IROMB,MAXWV,KMAX,MI,MJ, -C & KWSKIP,KGSKIP,NISKIP,NJSKIP, -C & RLAT1,RLON1,DLAT,DLON,WAVED,WAVEZ,UM,VM) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C MI - INTEGER NUMBER OF POINTS IN THE FASTER ZONAL DIRECTION -C MJ - INTEGER NUMBER OF POINTS IN THE SLOWER MERID DIRECTION -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO MI*MJ IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO MI IF NJSKIP=0) -C RLAT1 - REAL LATITUDE OF THE FIRST GRID POINT IN DEGREES -C RLON1 - REAL LONGITUDE OF THE FIRST GRID POINT IN DEGREES -C DLAT - REAL LATITUDE INCREMENT IN DEGREES SUCH THAT -C D(PHI)/D(J)=DLAT*COS(PHI) WHERE J IS MERIDIONAL INDEX. -C DLAT IS NEGATIVE FOR GRIDS INDEXED SOUTHWARD. -C (IN TERMS OF GRID INCREMENT DY VALID AT LATITUDE RLATI, -C THE LATITUDE INCREMENT DLAT IS DETERMINED AS -C DLAT=DPR*DY/(RERTH*COS(RLATI/DPR)) -C WHERE DPR=180/PI AND RERTH IS EARTH'S RADIUS) -C DLON - REAL LONGITUDE INCREMENT IN DEGREES SUCH THAT -C D(LAMBDA)/D(I)=DLON WHERE I IS ZONAL INDEX. -C DLON IS NEGATIVE FOR GRIDS INDEXED WESTWARD. -C WAVED - REAL (*) WAVE DIVERGENCE FIELDS -C WAVEZ - REAL (*) WAVE VORTICITY FIELDS -C OUTPUT ARGUMENTS: -C UM - REAL (*) MERCATOR U-WINDS -C VM - REAL (*) MERCATOR V-WINDS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C SPDZ2UV COMPUTE WINDS FROM DIVERGENCE AND VORTICITY -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptgpmd. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPMD TRANSFORM SPECTRAL TO MERCATOR GRADIENTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF SCALAR FIELDS -C TO GRADIENT FIELDS ON A MERCATOR GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE MERCATOR GRID IS IDENTIFIED BY THE LOCATION -C OF ITS FIRST POINT AND BY ITS RESPECTIVE INCREMENTS. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER SECTOR POINTS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTGPMD(IROMB,MAXWV,KMAX,MI,MJ, -C & KWSKIP,KGSKIP,NISKIP,NJSKIP, -C & RLAT1,RLON1,DLAT,DLON,WAVE,XM,YM) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C MI - INTEGER NUMBER OF POINTS IN THE FASTER ZONAL DIRECTION -C MJ - INTEGER NUMBER OF POINTS IN THE SLOWER MERID DIRECTION -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO MI*MJ IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO MI IF NJSKIP=0) -C RLAT1 - REAL LATITUDE OF THE FIRST GRID POINT IN DEGREES -C RLON1 - REAL LONGITUDE OF THE FIRST GRID POINT IN DEGREES -C DLAT - REAL LATITUDE INCREMENT IN DEGREES SUCH THAT -C D(PHI)/D(J)=DLAT*COS(PHI) WHERE J IS MERIDIONAL INDEX. -C DLAT IS NEGATIVE FOR GRIDS INDEXED SOUTHWARD. -C (IN TERMS OF GRID INCREMENT DY VALID AT LATITUDE RLATI, -C THE LATITUDE INCREMENT DLAT IS DETERMINED AS -C DLAT=DPR*DY/(RERTH*COS(RLATI/DPR)) -C WHERE DPR=180/PI AND RERTH IS EARTH'S RADIUS) -C DLON - REAL LONGITUDE INCREMENT IN DEGREES SUCH THAT -C D(LAMBDA)/D(I)=DLON WHERE I IS ZONAL INDEX. -C DLON IS NEGATIVE FOR GRIDS INDEXED WESTWARD. -C WAVE - REAL (*) WAVE FIELDS -C OUTPUT ARGUMENTS: -C XM - REAL (*) MERCATOR X-GRADIENTS -C YM - REAL (*) MERCATOR Y-GRADIENTS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTGPMV TRANSFORM SPECTRAL VECTOR TO MERCATOR -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for spgget. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPGGET GET GRID-SPACE CONSTANTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM GETS GRID-SPACE CONSTANTS. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPGGET(IDRT,IMAX,JMAX,CLAT,SLAT,WLAT,TRIG,IFAX) -C INPUT ARGUMENTS: -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER NUMBER OF LONGITUDES. -C JMAX - INTEGER NUMBER OF LATITUDES. -C OUTPUT ARGUMENTS: -C CLAT - REAL (JMAX) COSINES LATITUDE -C SLAT - REAL (JMAX) SINES LATITUDE -C WLAT - REAL (JMAX) GAUSSIAN WEIGHTS -C TRIG - REAL (2*IMAX) FFT TRIG VALUES -C IFAX - INTEGER (20) FFT FACTORS -C -C SUBPROGRAMS CALLED: -C SPLAT COMPUTE LATITUDE FUNCTIONS -C FFTFAX COMPUTE FFT CONSTANTS -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for spwget. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPWGET GET WAVE-SPACE CONSTANTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM GETS WAVE-SPACE CONSTANTS. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C OUTPUT ARGUMENTS: -C EPS - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) -C EPSTOP - REAL (MAXWV+1) -C ENN1 - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) -C ELONN1 - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) -C EON - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) -C EONTOP - REAL (MAXWV+1) -C -C SUBPROGRAMS CALLED: -C SPEPS COMPUTE UTILITY SPECTRAL FIELDS -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for splat. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPLAT COMPUTE LATITUDE FUNCTIONS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-20 -C -C ABSTRACT: COMPUTES COSINES OF COLATITUDE AND GAUSSIAN WEIGHTS -C FOR ONE OF THE FOLLOWING SPECIFIC GLOBAL SETS OF LATITUDES. -C GAUSSIAN LATITUDES (IDRT=4) -C EQUALLY-SPACED LATITUDES INCLUDING POLES (IDRT=0) -C EQUALLY-SPACED LATITUDES EXCLUDING POLES (IDRT=256) -C THE GAUSSIAN LATITUDES ARE LOCATED AT THE ZEROES OF THE -C LEGENDRE POLYNOMIAL OF THE GIVEN ORDER. THESE LATITUDES -C ARE EFFICIENT FOR REVERSIBLE TRANSFORMS FROM SPECTRAL SPACE. -C (ABOUT TWICE AS MANY EQUALLY-SPACED LATITUDES ARE NEEDED.) -C THE WEIGHTS FOR THE EQUALLY-SPACED LATITUDES ARE BASED ON -C ELLSAESSER (JAM,1966). (NO WEIGHT IS GIVEN THE POLE POINT.) -C NOTE THAT WHEN ANALYZING GRID TO SPECTRAL IN LATITUDE PAIRS, -C IF AN EQUATOR POINT EXISTS, ITS WEIGHT SHOULD BE HALVED. -C -C PROGRAM HISTORY LOG: -C 96-02-20 IREDELL -C -C USAGE: CALL SPLAT(IDRT,JMAX,SLAT,WLAT) -C -C INPUT ARGUMENT LIST: -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C JMAX - INTEGER NUMBER OF LATITUDES. -C -C OUTPUT ARGUMENT LIST: -C SLAT - REAL (JMAX) SINES OF LATITUDE. -C WLAT - REAL (JMAX) GAUSSIAN WEIGHTS. -C -C SUBPROGRAMS CALLED: -C MINV SOLVES FULL MATRIX PROBLEM -C -C REMARKS: FORTRAN 90 EXTENSIONS ARE USED. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for speps. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPEPS COMPUTE UTILITY SPECTRAL FIELDS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: COMPUTES CONSTANT FIELDS INDEXED IN THE SPECTRAL DOMAIN -C IN "IBM ORDER" (ZONAL WAVENUMBER IS THE SLOWER INDEX). -C IF L IS THE ZONAL WAVENUMBER AND N IS THE TOTAL WAVENUMBER -C AND A IS THE EARTH RADIUS, THEN THE FIELDS RETURNED ARE: -C (1) NORMALIZING FACTOR EPSILON=SQRT((N**2-L**2)/(4*N**2-1)) -C (2) LAPLACIAN FACTOR N*(N+1)/A**2 -C (3) ZONAL DERIVATIVE/LAPLACIAN FACTOR L/(N*(N+1))*A -C (4) MERIDIONAL DERIVATIVE/LAPLACIAN FACTOR EPSILON/N*A -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C -C USAGE: CALL SPEPS(I,M,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C -C OUTPUT ARGUMENT LIST: -C EPS - REAL ((M+1)*((I+1)*M+2)/2) SQRT((N**2-L**2)/(4*N**2-1)) -C EPSTOP - REAL (M+1) SQRT((N**2-L**2)/(4*N**2-1)) OVER TOP -C ENN1 - REAL ((M+1)*((I+1)*M+2)/2) N*(N+1)/A**2 -C ELONN1 - REAL ((M+1)*((I+1)*M+2)/2) L/(N*(N+1))*A -C EON - REAL ((M+1)*((I+1)*M+2)/2) EPSILON/N*A -C EONTOP - REAL (M+1) EPSILON/N*A OVER TOP -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - -Docblock for splegend. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: EVALUATES THE ORTHONORMAL ASSOCIATED LEGENDRE POLYNOMIALS -C IN THE SPECTRAL DOMAIN AT A GIVEN LATITUDE. -C SUBPROGRAM SPLEGEND SHOULD BE CALLED ALREADY. -C IF L IS THE ZONAL WAVENUMBER, N IS THE TOTAL WAVENUMBER, -C AND EPS(L,N)=SQRT((N**2-L**2)/(4*N**2-1)) THEN -C THE FOLLOWING BOOTSTRAPPING FORMULAS ARE USED: -C PLN(0,0)=SQRT(0.5) -C PLN(L,L)=PLN(L-1,L-1)*CLAT*SQRT(FLOAT(2*L+1)/FLOAT(2*L)) -C PLN(L,N)=(SLAT*PLN(L,N-1)-EPS(L,N-1)*PLN(L,N-2))/EPS(L,N) -C SYNTHESIS AT THE POLE NEEDS ONLY TWO ZONAL WAVENUMBERS. -C SCALAR FIELDS ARE SYNTHESIZED WITH ZONAL WAVENUMBER 0 WHILE -C VECTOR FIELDS ARE SYNTHESIZED WITH ZONAL WAVENUMBER 1. -C (THUS POLAR VECTOR FIELDS ARE IMPLICITLY DIVIDED BY CLAT.) -C THE FOLLOWING BOOTSTRAPPING FORMULAS ARE USED AT THE POLE: -C PLN(0,0)=SQRT(0.5) -C PLN(1,1)=SQRT(0.75) -C PLN(L,N)=(PLN(L,N-1)-EPS(L,N-1)*PLN(L,N-2))/EPS(L,N) -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C -C USAGE: CALL SPLEGEND(I,M,SLAT,CLAT,EPS,EPSTOP,PLN,PLNTOP) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C SLAT - REAL SINE OF LATITUDE -C CLAT - REAL COSINE OF LATITUDE -C EPS - REAL ((M+1)*((I+1)*M+2)/2) SQRT((N**2-L**2)/(4*N**2-1)) -C EPSTOP - REAL (M+1) SQRT((N**2-L**2)/(4*N**2-1)) OVER TOP -C -C OUTPUT ARGUMENT LIST: -C PLN - REAL ((M+1)*((I+1)*M+2)/2) LEGENDRE POLYNOMIAL -C PLNTOP - REAL (M+1) LEGENDRE POLYNOMIAL OVER TOP -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - -Docblock for spanaly. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPANALY ANALYZE SPECTRAL FROM FOURIER -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: ANALYZES SPECTRAL COEFFICIENTS FROM FOURIER COEFFICIENTS -C FOR A LATITUDE PAIR (NORTHERN AND SOUTHERN HEMISPHERES). -C VECTOR COMPONENTS ARE MULTIPLIED BY COSINE OF LATITUDE. -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C 94-08-01 MARK IREDELL MOVED ZONAL WAVENUMBER LOOP INSIDE -C -C USAGE: CALL SPANALY(I,M,IM,IX,NC,NCTOP,KM,WGT,CLAT,PLN,PLNTOP,MP, -C & F,SPC,SPCTOP) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C IM - INTEGER EVEN NUMBER OF FOURIER COEFFICIENTS -C IX - INTEGER DIMENSION OF FOURIER COEFFICIENTS (IX>=IM+2) -C NC - INTEGER DIMENSION OF SPECTRAL COEFFICIENTS -C (NC>=(M+1)*((I+1)*M+2)) -C NCTOP - INTEGER DIMENSION OF SPECTRAL COEFFICIENTS OVER TOP -C (NCTOP>=2*(M+1)) -C KM - INTEGER NUMBER OF FIELDS -C WGT - REAL GAUSSIAN WEIGHT -C CLAT - REAL COSINE OF LATITUDE -C PLN - REAL ((M+1)*((I+1)*M+2)/2) LEGENDRE POLYNOMIALS -C PLNTOP - REAL (M+1) LEGENDRE POLYNOMIAL OVER TOP -C MP - INTEGER (KM) IDENTIFIERS (0 FOR SCALAR, 1 FOR VECTOR) -C F - REAL (IX,2,KM) FOURIER COEFFICIENTS COMBINED -C SPC - REAL (NC,KM) SPECTRAL COEFFICIENTS -C SPCTOP - REAL (NCTOP,KM) SPECTRAL COEFFICIENTS OVER TOP -C -C OUTPUT ARGUMENT LIST: -C SPC - REAL (NC,KM) SPECTRAL COEFFICIENTS -C SPCTOP - REAL (NCTOP,KM) SPECTRAL COEFFICIENTS OVER TOP -C -C SUBPROGRAMS CALLED: -C SGERX1 CRAY LIBRARY MATRIX RANK 1 UPDATE -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - -Docblock for spsynth. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: SYNTHESIZES FOURIER COEFFICIENTS FROM SPECTRAL COEFFICIENTS -C FOR A LATITUDE PAIR (NORTHERN AND SOUTHERN HEMISPHERES). -C VECTOR COMPONENTS ARE DIVIDED BY COSINE OF LATITUDE. -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C -C USAGE: CALL SPSYNTH(I,M,IM,IX,NC,NCTOP,KM,CLAT,PLN,PLNTOP,MP, -C & SPC,SPCTOP,F) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C IM - INTEGER EVEN NUMBER OF FOURIER COEFFICIENTS -C IX - INTEGER DIMENSION OF FOURIER COEFFICIENTS (IX>=IM+2) -C NC - INTEGER DIMENSION OF SPECTRAL COEFFICIENTS -C (NC>=(M+1)*((I+1)*M+2)) -C NCTOP - INTEGER DIMENSION OF SPECTRAL COEFFICIENTS OVER TOP -C (NCTOP>=2*(M+1)) -C KM - INTEGER NUMBER OF FIELDS -C CLAT - REAL COSINE OF LATITUDE -C PLN - REAL ((M+1)*((I+1)*M+2)/2) LEGENDRE POLYNOMIAL -C PLNTOP - REAL (M+1) LEGENDRE POLYNOMIAL OVER TOP -C SPC - REAL (NC,KM) SPECTRAL COEFFICIENTS -C SPCTOP - REAL (NCTOP,KM) SPECTRAL COEFFICIENTS OVER TOP -C MP - INTEGER (KM) IDENTIFIERS (0 FOR SCALAR, 1 FOR VECTOR) -C -C OUTPUT ARGUMENT LIST: -C F - REAL (IX,2,KM) FOURIER COEFFICIENTS FOR LATITUDE PAIR -C -C SUBPROGRAMS CALLED: -C SGEMVX1 CRAY LIBRARY MATRIX TIMES VECTOR -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - -Docblock for spdz2uv. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPDZ2UV COMPUTE WINDS FROM DIVERGENCE AND VORTICITY -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: COMPUTES THE WIND COMPONENTS FROM DIVERGENCE AND VORTICITY -C IN SPECTRAL SPACE. -C SUBPROGRAM SPEPS SHOULD BE CALLED ALREADY. -C IF L IS THE ZONAL WAVENUMBER, N IS THE TOTAL WAVENUMBER, -C EPS(L,N)=SQRT((N**2-L**2)/(4*N**2-1)) AND A IS EARTH RADIUS, -C THEN THE ZONAL WIND COMPONENT U IS COMPUTED AS -C U(L,N)=-I*L/(N*(N+1))*A*D(L,N) -C +EPS(L,N+1)/(N+1)*A*Z(L,N+1)-EPS(L,N)/N*A*Z(L,N-1) -C AND THE MERIDIONAL WIND COMPONENT V IS COMPUTED AS -C V(L,N)=-I*L/(N*(N+1))*A*Z(L,N) -C -EPS(L,N+1)/(N+1)*A*D(L,N+1)+EPS(L,N)/N*A*D(L,N-1) -C WHERE D IS DIVERGENCE AND Z IS VORTICITY. -C U AND V ARE WEIGHTED BY THE COSINE OF LATITUDE. -C EXTRA TERMS ARE COMPUTED OVER TOP OF THE SPECTRAL DOMAIN. -C ADVANTAGE IS TAKEN OF THE FACT THAT EPS(L,L)=0 -C IN ORDER TO VECTORIZE OVER THE ENTIRE SPECTRAL DOMAIN. -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C -C USAGE: CALL SPDZ2UV(I,M,ENN1,ELONN1,EON,EONTOP,D,Z,U,V,UTOP,VTOP) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C ENN1 - REAL ((M+1)*((I+1)*M+2)/2) N*(N+1)/A**2 -C ELONN1 - REAL ((M+1)*((I+1)*M+2)/2) L/(N*(N+1))*A -C EON - REAL ((M+1)*((I+1)*M+2)/2) EPSILON/N*A -C EONTOP - REAL (M+1) EPSILON/N*A OVER TOP -C D - REAL ((M+1)*((I+1)*M+2)) DIVERGENCE -C Z - REAL ((M+1)*((I+1)*M+2)) VORTICITY -C -C OUTPUT ARGUMENT LIST: -C U - REAL ((M+1)*((I+1)*M+2)) ZONAL WIND (TIMES COSLAT) -C V - REAL ((M+1)*((I+1)*M+2)) MERID WIND (TIMES COSLAT) -C UTOP - REAL (2*(M+1)) ZONAL WIND (TIMES COSLAT) OVER TOP -C VTOP - REAL (2*(M+1)) MERID WIND (TIMES COSLAT) OVER TOP -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - -Docblock for spuv2dz. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPUV2DZ COMPUTE DIVERGENCE AND VORTICITY FROM WINDS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: COMPUTES THE DIVERGENCE AND VORTICITY FROM WIND COMPONENTS -C IN SPECTRAL SPACE. -C SUBPROGRAM SPEPS SHOULD BE CALLED ALREADY. -C IF L IS THE ZONAL WAVENUMBER, N IS THE TOTAL WAVENUMBER, -C EPS(L,N)=SQRT((N**2-L**2)/(4*N**2-1)) AND A IS EARTH RADIUS, -C THEN THE DIVERGENCE D IS COMPUTED AS -C D(L,N)=I*L*A*U(L,N) -C +EPS(L,N+1)*N*A*V(L,N+1)-EPS(L,N)*(N+1)*A*V(L,N-1) -C AND THE VORTICITY Z IS COMPUTED AS -C Z(L,N)=I*L*A*V(L,N) -C -EPS(L,N+1)*N*A*U(L,N+1)+EPS(L,N)*(N+1)*A*U(L,N-1) -C WHERE U IS THE ZONAL WIND AND V IS THE MERIDIONAL WIND. -C U AND V ARE WEIGHTED BY THE SECANT OF LATITUDE. -C EXTRA TERMS ARE USED OVER TOP OF THE SPECTRAL DOMAIN. -C ADVANTAGE IS TAKEN OF THE FACT THAT EPS(L,L)=0 -C IN ORDER TO VECTORIZE OVER THE ENTIRE SPECTRAL DOMAIN. -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C -C USAGE: CALL SPUV2DZ(I,M,ENN1,ELONN1,EON,EONTOP,U,V,UTOP,VTOP,D,Z) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C ENN1 - REAL ((M+1)*((I+1)*M+2)/2) N*(N+1)/A**2 -C ELONN1 - REAL ((M+1)*((I+1)*M+2)/2) L/(N*(N+1))*A -C EON - REAL ((M+1)*((I+1)*M+2)/2) EPSILON/N*A -C EONTOP - REAL (M+1) EPSILON/N*A OVER TOP -C U - REAL ((M+1)*((I+1)*M+2)) ZONAL WIND (OVER COSLAT) -C V - REAL ((M+1)*((I+1)*M+2)) MERID WIND (OVER COSLAT) -C UTOP - REAL (2*(M+1)) ZONAL WIND (OVER COSLAT) OVER TOP -C VTOP - REAL (2*(M+1)) MERID WIND (OVER COSLAT) OVER TOP -C -C OUTPUT ARGUMENT LIST: -C D - REAL ((M+1)*((I+1)*M+2)) DIVERGENCE -C Z - REAL ((M+1)*((I+1)*M+2)) VORTICITY -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - -Docblock for spgradq. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPGRADQ COMPUTE GRADIENT IN SPECTRAL SPACE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: COMPUTES THE HORIZONTAL VECTOR GRADIENT OF A SCALAR FIELD -C IN SPECTRAL SPACE. -C SUBPROGRAM SPEPS SHOULD BE CALLED ALREADY. -C IF L IS THE ZONAL WAVENUMBER, N IS THE TOTAL WAVENUMBER, -C EPS(L,N)=SQRT((N**2-L**2)/(4*N**2-1)) AND A IS EARTH RADIUS, -C THEN THE ZONAL GRADIENT OF Q(L,N) IS SIMPLY I*L/A*Q(L,N) -C WHILE THE MERIDIONAL GRADIENT OF Q(L,N) IS COMPUTED AS -C EPS(L,N+1)*(N+2)/A*Q(L,N+1)-EPS(L,N+1)*(N-1)/A*Q(L,N-1). -C EXTRA TERMS ARE COMPUTED OVER TOP OF THE SPECTRAL DOMAIN. -C ADVANTAGE IS TAKEN OF THE FACT THAT EPS(L,L)=0 -C IN ORDER TO VECTORIZE OVER THE ENTIRE SPECTRAL DOMAIN. -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C -C USAGE: CALL SPGRADQ(I,M,ENN1,ELONN1,EON,EONTOP,Q,QDX,QDY,QDYTOP) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C ENN1 - REAL ((M+1)*((I+1)*M+2)/2) N*(N+1)/A**2 -C ELONN1 - REAL ((M+1)*((I+1)*M+2)/2) L/(N*(N+1))*A -C EON - REAL ((M+1)*((I+1)*M+2)/2) EPSILON/N*A -C EONTOP - REAL (M+1) EPSILON/N*A OVER TOP -C Q - REAL ((M+1)*((I+1)*M+2)) SCALAR FIELD -C -C OUTPUT ARGUMENT LIST: -C QDX - REAL ((M+1)*((I+1)*M+2)) ZONAL GRADIENT (TIMES COSLAT) -C QDY - REAL ((M+1)*((I+1)*M+2)) MERID GRADIENT (TIMES COSLAT) -C QDYTOP - REAL (2*(M+1)) MERID GRADIENT (TIMES COSLAT) OVER TOP -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - -Docblock for splaplac. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: COMPUTES THE LAPLACIAN OR THE INVERSE LAPLACIAN -C OF A SCALAR FIELD IN SPECTRAL SPACE. -C SUBPROGRAM SPEPS SHOULD BE CALLED ALREADY. -C THE LAPLACIAN OF Q(L,N) IS SIMPLY -N*(N+1)/A**2*Q(L,N) -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C -C USAGE: CALL SPLAPLAC(I,M,ENN1,Q,QD2,IDIR) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C ENN1 - REAL ((M+1)*((I+1)*M+2)/2) N*(N+1)/A**2 -C Q - IF IDIR > 0, REAL ((M+1)*((I+1)*M+2)) SCALAR FIELD -C QD2 - IF IDIR < 0, REAL ((M+1)*((I+1)*M+2)) LAPLACIAN -C IDIR - INTEGER FLAG -C IDIR > 0 TO TAKE LAPLACIAN -C IDIR < 0 TO TAKE INVERSE LAPLACIAN -C -C OUTPUT ARGUMENT LIST: -C Q - IF IDIR < 0, REAL ((M+1)*((I+1)*M+2)) SCALAR FIELD -C (Q(0,0) IS NOT COMPUTED) -C QD2 - IF IDIR > 0, REAL ((M+1)*((I+1)*M+2)) LAPLACIAN -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ diff --git a/src/fim/FIMsrc/prep/sp/sppad.f b/src/fim/FIMsrc/prep/sp/sppad.f deleted file mode 100644 index 8d7140d..0000000 --- a/src/fim/FIMsrc/prep/sp/sppad.f +++ /dev/null @@ -1,49 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPPAD(I1,M1,Q1,I2,M2,Q2) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPPAD PAD OR TRUNCATE A SPECTRAL FIELD -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: PAD OR TRUNCATE A SPECTRAL FIELD -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C -C USAGE: CALL SPPAD(I1,M1,Q1,I2,M2,Q2) -C -C INPUT ARGUMENT LIST: -C I1 - INTEGER INPUT SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M1 - INTEGER INPUT SPECTRAL TRUNCATION -C Q1 - REAL ((M+1)*((I+1)*M+2)) INPUT FIELD -C I2 - INTEGER OUTPUT SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M2 - INTEGER OUTPUT SPECTRAL TRUNCATION -C -C OUTPUT ARGUMENT LIST: -C Q2 - REAL ((M+1)*((I+1)*M+2)) OUTPUT FIELD -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN -C -C$$$ - REAL Q1((M1+1)*((I1+1)*M1+2)) - REAL Q2((M2+1)*((I2+1)*M2+2)) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - DO L=0,M2 - DO N=L,I2*L+M2 - KS2=L*(2*M2+(I2-1)*(L-1))+2*N - IF(L.LE.M1.AND.N.LE.I1*L+M1) THEN - KS1=L*(2*M1+(I1-1)*(L-1))+2*N - Q2(KS2+1)=Q1(KS1+1) - Q2(KS2+2)=Q1(KS1+2) - ELSE - Q2(KS2+1)=0 - Q2(KS2+2)=0 - ENDIF - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/prep/sp/spsynth.f b/src/fim/FIMsrc/prep/sp/spsynth.f deleted file mode 100644 index 4f6c0f4..0000000 --- a/src/fim/FIMsrc/prep/sp/spsynth.f +++ /dev/null @@ -1,165 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPSYNTH(I,M,IM,IX,NC,NCTOP,KM,CLAT,PLN,PLNTOP,MP, - & SPC,SPCTOP,F) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: SYNTHESIZES FOURIER COEFFICIENTS FROM SPECTRAL COEFFICIENTS -C FOR A LATITUDE PAIR (NORTHERN AND SOUTHERN HEMISPHERES). -C VECTOR COMPONENTS ARE DIVIDED BY COSINE OF LATITUDE. -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C 1998-12-18 MARK IREDELL INCLUDE SCALAR AND GRADIENT OPTION -C -C USAGE: CALL SPSYNTH(I,M,IM,IX,NC,NCTOP,KM,CLAT,PLN,PLNTOP,MP, -C & SPC,SPCTOP,F) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C IM - INTEGER EVEN NUMBER OF FOURIER COEFFICIENTS -C IX - INTEGER DIMENSION OF FOURIER COEFFICIENTS (IX>=IM+2) -C NC - INTEGER DIMENSION OF SPECTRAL COEFFICIENTS -C (NC>=(M+1)*((I+1)*M+2)) -C NCTOP - INTEGER DIMENSION OF SPECTRAL COEFFICIENTS OVER TOP -C (NCTOP>=2*(M+1)) -C KM - INTEGER NUMBER OF FIELDS -C CLAT - REAL COSINE OF LATITUDE -C PLN - REAL ((M+1)*((I+1)*M+2)/2) LEGENDRE POLYNOMIAL -C PLNTOP - REAL (M+1) LEGENDRE POLYNOMIAL OVER TOP -C SPC - REAL (NC,KM) SPECTRAL COEFFICIENTS -C SPCTOP - REAL (NCTOP,KM) SPECTRAL COEFFICIENTS OVER TOP -C MP - INTEGER (KM) IDENTIFIERS (0 FOR SCALAR, 1 FOR VECTOR, -C OR 10 FOR SCALAR AND GRADIENT) -C -C OUTPUT ARGUMENT LIST: -C F - REAL (IX,2,KM) FOURIER COEFFICIENTS FOR LATITUDE PAIR -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - REAL PLN((M+1)*((I+1)*M+2)/2),PLNTOP(M+1) - INTEGER MP(KM) - REAL SPC(NC,KM),SPCTOP(NCTOP,KM) - REAL F(IX,2,KM) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C ZERO OUT FOURIER COEFFICIENTS. - DO K=1,KM - DO L=0,IM/2 - F(2*L+1,1,K)=0. - F(2*L+2,1,K)=0. - F(2*L+1,2,K)=0. - F(2*L+2,2,K)=0. - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SYNTHESIS OVER POLE. -C INITIALIZE FOURIER COEFFICIENTS WITH TERMS OVER TOP OF THE SPECTRUM. -C INITIALIZE EVEN AND ODD POLYNOMIALS SEPARATELY. - IF(CLAT.EQ.0) THEN - LTOPE=MOD(M+1+I,2) -!C$OMP PARALLEL DO PRIVATE(LB,LE,L,KS,KP,N,F1R,F1I) - DO K=1,KM - LB=MP(K) - LE=MP(K) - IF(MP(K).EQ.10) THEN - LB=0 - LE=1 - ENDIF - L=LB - IF(L.EQ.1) THEN - IF(L.EQ.LTOPE) THEN - F(2*L+1,1,K)=PLNTOP(L+1)*SPCTOP(2*L+1,K) - F(2*L+2,1,K)=PLNTOP(L+1)*SPCTOP(2*L+2,K) - ELSE - F(2*L+1,2,K)=PLNTOP(L+1)*SPCTOP(2*L+1,K) - F(2*L+2,2,K)=PLNTOP(L+1)*SPCTOP(2*L+2,K) - ENDIF - ENDIF -C FOR EACH ZONAL WAVENUMBER, SYNTHESIZE TERMS OVER TOTAL WAVENUMBER. -C SYNTHESIZE EVEN AND ODD POLYNOMIALS SEPARATELY. - DO L=LB,LE - KS=L*(2*M+(I-1)*(L-1)) - KP=KS/2+1 - DO N=L,I*L+M,2 - F(2*L+1,1,K)=F(2*L+1,1,K)+PLN(KP+N)*SPC(KS+2*N+1,K) - F(2*L+2,1,K)=F(2*L+2,1,K)+PLN(KP+N)*SPC(KS+2*N+2,K) - ENDDO - DO N=L+1,I*L+M,2 - F(2*L+1,2,K)=F(2*L+1,2,K)+PLN(KP+N)*SPC(KS+2*N+1,K) - F(2*L+2,2,K)=F(2*L+2,2,K)+PLN(KP+N)*SPC(KS+2*N+2,K) - ENDDO -C SEPARATE FOURIER COEFFICIENTS FROM EACH HEMISPHERE. -C ODD POLYNOMIALS CONTRIBUTE NEGATIVELY TO THE SOUTHERN HEMISPHERE. - F1R=F(2*L+1,1,K) - F1I=F(2*L+2,1,K) - F(2*L+1,1,K)=F1R+F(2*L+1,2,K) - F(2*L+2,1,K)=F1I+F(2*L+2,2,K) - F(2*L+1,2,K)=F1R-F(2*L+1,2,K) - F(2*L+2,2,K)=F1I-F(2*L+2,2,K) - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SYNTHESIS OVER FINITE LATITUDE. -C INITIALIZE FOURIER COEFFICIENTS WITH TERMS OVER TOP OF THE SPECTRUM. -C INITIALIZE EVEN AND ODD POLYNOMIALS SEPARATELY. - ELSE - LX=MIN(M,IM/2) - LTOPE=MOD(M+1,2) - LTOPO=1-LTOPE - LE=1+I*LTOPE - LO=2-I*LTOPO -!C$OMP PARALLEL DO PRIVATE(L,KS,KP,N,F1R,F1I) - DO K=1,KM - IF(MP(K).EQ.1) THEN - DO L=LTOPE,LX,2 - F(2*L+1,LE,K)=PLNTOP(L+1)*SPCTOP(2*L+1,K) - F(2*L+2,LE,K)=PLNTOP(L+1)*SPCTOP(2*L+2,K) - ENDDO - DO L=LTOPO,LX,2 - F(2*L+1,LO,K)=PLNTOP(L+1)*SPCTOP(2*L+1,K) - F(2*L+2,LO,K)=PLNTOP(L+1)*SPCTOP(2*L+2,K) - ENDDO - ENDIF -C FOR EACH ZONAL WAVENUMBER, SYNTHESIZE TERMS OVER TOTAL WAVENUMBER. -C SYNTHESIZE EVEN AND ODD POLYNOMIALS SEPARATELY. - DO L=0,LX - KS=L*(2*M+(I-1)*(L-1)) - KP=KS/2+1 - DO N=L,I*L+M,2 - F(2*L+1,1,K)=F(2*L+1,1,K)+PLN(KP+N)*SPC(KS+2*N+1,K) - F(2*L+2,1,K)=F(2*L+2,1,K)+PLN(KP+N)*SPC(KS+2*N+2,K) - ENDDO - DO N=L+1,I*L+M,2 - F(2*L+1,2,K)=F(2*L+1,2,K)+PLN(KP+N)*SPC(KS+2*N+1,K) - F(2*L+2,2,K)=F(2*L+2,2,K)+PLN(KP+N)*SPC(KS+2*N+2,K) - ENDDO - ENDDO -C SEPARATE FOURIER COEFFICIENTS FROM EACH HEMISPHERE. -C ODD POLYNOMIALS CONTRIBUTE NEGATIVELY TO THE SOUTHERN HEMISPHERE. -C DIVIDE VECTOR COMPONENTS BY COSINE LATITUDE. - DO L=0,LX - F1R=F(2*L+1,1,K) - F1I=F(2*L+2,1,K) - F(2*L+1,1,K)=F1R+F(2*L+1,2,K) - F(2*L+2,1,K)=F1I+F(2*L+2,2,K) - F(2*L+1,2,K)=F1R-F(2*L+1,2,K) - F(2*L+2,2,K)=F1I-F(2*L+2,2,K) - ENDDO - IF(MP(K).EQ.1) THEN - DO L=0,LX - F(2*L+1,1,K)=F(2*L+1,1,K)/CLAT - F(2*L+2,1,K)=F(2*L+2,1,K)/CLAT - F(2*L+1,2,K)=F(2*L+1,2,K)/CLAT - F(2*L+2,2,K)=F(2*L+2,2,K)/CLAT - ENDDO - ENDIF - ENDDO - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptez.f b/src/fim/FIMsrc/prep/sp/sptez.f deleted file mode 100644 index 9048577..0000000 --- a/src/fim/FIMsrc/prep/sp/sptez.f +++ /dev/null @@ -1,82 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTEZ(IROMB,MAXWV,IDRT,IMAX,JMAX,WAVE,GRID,IDIR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTEZ PERFORM A SIMPLE SCALAR SPHERICAL TRANSFORM -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C BETWEEN SPECTRAL COEFFICIENTS OF A SCALAR QUANTITY -C AND A FIELD ON A GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER'. -C THE GRID FIELD IS INDEXED EAST TO WEST, THEN NORTH TO SOUTH. -C FOR MORE FLEXIBILITY AND EFFICIENCY, CALL SPTRAN. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTEZ(IROMB,MAXWV,IDRT,IMAX,JMAX,WAVE,GRID,IDIR) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES. -C JMAX - INTEGER NUMBER OF LATITUDES. -C WAVE - REAL (2*MX) WAVE FIELD IF IDIR>0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 -C GRID - REAL (IMAX,JMAX) GRID FIELD (E->W,N->S) IF IDIR<0 -C IDIR - INTEGER TRANSFORM FLAG -C (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -C OUTPUT ARGUMENTS: -C WAVE - REAL (2*MX) WAVE FIELD IF IDIR<0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 -C GRID - REAL (IMAX,JMAX) GRID FIELD (E->W,N->S) IF IDIR>0 -C -C SUBPROGRAMS CALLED: -C SPTRANF PERFORM A SCALAR SPHERICAL TRANSFORM -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVE((MAXWV+1)*((IROMB+1)*MAXWV+2)) - REAL GRID(IMAX,JMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - IP=1 - IS=1 - JN=IMAX - JS=-JN !JFM This causes a negative subscript in SPTRANF - KW=2*MX - KG=IMAX*JMAX - JB=1 - JE=(JMAX+1)/2 - JC=NCPUS() - IF(IDIR.LT.0) WAVE=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - CALL SPTRANF(IROMB,MAXWV,IDRT,IMAX,JMAX,1, - & IP,IS,JN,JS,KW,KG,JB,JE,JC, - & WAVE,GRID,GRID(1,JMAX),IDIR) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptezd.f b/src/fim/FIMsrc/prep/sp/sptezd.f deleted file mode 100644 index d2818bd..0000000 --- a/src/fim/FIMsrc/prep/sp/sptezd.f +++ /dev/null @@ -1,75 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTEZD(IROMB,MAXWV,IDRT,IMAX,JMAX, - & WAVE,GRIDMN,GRIDX,GRIDY,IDIR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTEZD PERFORM A SIMPLE GRADIENT SPHERICAL TRANSFORM -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C BETWEEN SPECTRAL COEFFICIENTS OF A SCALAR FIELD -C AND ITS MEAN AND GRADIENT ON A GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER'. -C THE GRID FIELS IS INDEXED EAST TO WEST, THEN NORTH TO SOUTH. -C FOR MORE FLEXIBILITY AND EFFICIENCY, CALL SPTRAN. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTEZD(IROMB,MAXWV,IDRT,IMAX,JMAX, -C & WAVE,GRIDMN,GRIDX,GRIDY,IDIR) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES. -C JMAX - INTEGER NUMBER OF LATITUDES. -C WAVE - REAL (*) WAVE FIELD IF IDIR>0 -C GRIDMN - REAL GLOBAL MEAN IF IDIR<0 -C GRIDX - REAL (IMAX,JMAX) GRID X-GRADIENTS (E->W,N->S) IF IDIR<0 -C GRIDY - REAL (IMAX,JMAX) GRID Y-GRADIENTS (E->W,N->S) IF IDIR<0 -C IDIR - INTEGER TRANSFORM FLAG -C (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -C OUTPUT ARGUMENTS: -C WAVE - REAL (*) WAVE FIELD IF IDIR<0 -C GRIDMN - REAL GLOBAL MEAN IF IDIR>0 -C GRIDX - REAL (IMAX,JMAX) GRID X-GRADIENTS (E->W,N->S) IF IDIR>0 -C GRIDY - REAL (IMAX,JMAX) GRID Y-GRADIENTS (E->W,N->S) IF IDIR>0 -C -C SUBPROGRAMS CALLED: -C SPTRAND PERFORM A GRADIENT SPHERICAL TRANSFORM -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVE(*),GRIDX(IMAX,JMAX),GRIDY(IMAX,JMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - JC=NCPUS() - CALL SPTRAND(IROMB,MAXWV,IDRT,IMAX,JMAX,1, - & 0,0,0,0,0,0,0,0,JC, - & WAVE,GRIDMN, - & GRIDX,GRIDX(1,JMAX),GRIDY,GRIDY(1,JMAX),1) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptezm.f b/src/fim/FIMsrc/prep/sp/sptezm.f deleted file mode 100644 index 5e78444..0000000 --- a/src/fim/FIMsrc/prep/sp/sptezm.f +++ /dev/null @@ -1,83 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTEZM(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX,WAVE,GRID,IDIR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTEZ PERFORM SIMPLE SCALAR SPHERICAL TRANSFORMS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS SPHERICAL TRANSFORMS -C BETWEEN SPECTRAL COEFFICIENTS OF SCALAR QUANTITIES -C AND FIELDS ON A GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C WAVE FIELDS ARE IN SEQUENTIAL 'IBM ORDER'. -C GRID FIELDS ARE INDEXED EAST TO WEST, THEN NORTH TO SOUTH. -C FOR MORE FLEXIBILITY AND EFFICIENCY, CALL SPTRAN. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTEZM(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX,WAVE,GRID,IDIR) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES -C JMAX - INTEGER NUMBER OF LATITUDES -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM -C WAVE - REAL (2*MX,KMAX) WAVE FIELD IF IDIR>0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 -C GRID - REAL (IMAX,JMAX,KMAX) GRID FIELD (E->W,N->S) IF IDIR<0 -C IDIR - INTEGER TRANSFORM FLAG -C (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -C OUTPUT ARGUMENTS: -C WAVE - REAL (2*MX,KMAX) WAVE FIELD IF IDIR<0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 -C GRID - REAL (IMAX,JMAX,KMAX) GRID FIELD (E->W,N->S) IF IDIR>0 -C -C SUBPROGRAMS CALLED: -C SPTRANF PERFORM A SCALAR SPHERICAL TRANSFORM -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVE((MAXWV+1)*((IROMB+1)*MAXWV+2),KMAX) - REAL GRID(IMAX,JMAX,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - IP=1 - IS=1 - JN=IMAX - JS=-JN - KW=2*MX - KG=IMAX*JMAX - JB=1 - JE=(JMAX+1)/2 - JC=NCPUS() - IF(IDIR.LT.0) WAVE=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - CALL SPTRANF(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, - & IP,IS,JN,JS,KW,KG,JB,JE,JC, - & WAVE,GRID,GRID(1,JMAX,1),IDIR) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptezmd.f b/src/fim/FIMsrc/prep/sp/sptezmd.f deleted file mode 100644 index 4c91cf4..0000000 --- a/src/fim/FIMsrc/prep/sp/sptezmd.f +++ /dev/null @@ -1,78 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTEZMD(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, - & WAVE,GRIDMN,GRIDX,GRIDY,IDIR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTEZMD PERFORM SIMPLE GRADIENT SPHERICAL TRANSFORMS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS SPHERICAL TRANSFORMS -C BETWEEN SPECTRAL COEFFICIENTS OF SCALAR FIELDS -C AND THEIR MEANS AND GRADIENTS ON A GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE WAVE FIELDS ARE IN SEQUENTIAL 'IBM ORDER'. -C THE GRID FIELDS ARE INDEXED EAST TO WEST, THEN NORTH TO SOUTH. -C FOR MORE FLEXIBILITY AND EFFICIENCY, CALL SPTRAN. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTEZMD(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, -C & WAVE,GRIDMN,GRIDX,GRIDY,IDIR) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES. -C JMAX - INTEGER NUMBER OF LATITUDES. -C WAVE - REAL (MX,KMAX) WAVE FIELD IF IDIR>0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2) -C GRIDMN - REAL (KMAX) GLOBAL MEAN IF IDIR<0 -C GRIDX - REAL (IMAX,JMAX,KMAX) GRID X-GRADIENTS (E->W,N->S) IF IDIR<0 -C GRIDY - REAL (IMAX,JMAX,KMAX) GRID Y-GRADIENTS (E->W,N->S) IF IDIR<0 -C IDIR - INTEGER TRANSFORM FLAG -C (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -C OUTPUT ARGUMENTS: -C WAVE - REAL (MX,KMAX) WAVE FIELD IF IDIR<0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2) -C GRIDMN - REAL (KMAX) GLOBAL MEAN IF IDIR>0 -C GRIDX - REAL (IMAX,JMAX,KMAX) GRID X-GRADIENTS (E->W,N->S) IF IDIR>0 -C GRIDY - REAL (IMAX,JMAX,KMAX) GRID Y-GRADIENTS (E->W,N->S) IF IDIR>0 -C -C SUBPROGRAMS CALLED: -C SPTRAND PERFORM A GRADIENT SPHERICAL TRANSFORM -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVE((MAXWV+1)*((IROMB+1)*MAXWV+2),KMAX) - REAL GRIDMN(KMAX),GRIDX(IMAX,JMAX,KMAX),GRIDY(IMAX,JMAX,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - JC=NCPUS() - CALL SPTRAND(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, - & 0,0,0,0,0,0,0,0,JC, - & WAVE,GRIDMN, - & GRIDX,GRIDX(1,JMAX,1),GRIDY,GRIDY(1,JMAX,1),IDIR) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptezmv.f b/src/fim/FIMsrc/prep/sp/sptezmv.f deleted file mode 100644 index b33bcaf..0000000 --- a/src/fim/FIMsrc/prep/sp/sptezmv.f +++ /dev/null @@ -1,95 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTEZMV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, - & WAVED,WAVEZ,GRIDU,GRIDV,IDIR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTEZVM PERFORM SIMPLE VECTOR SPHERICAL TRANSFORMS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS SPHERICAL TRANSFORMS -C BETWEEN SPECTRAL COEFFICIENTS OF DIVERGENCE AND CURL -C AND VECTOR FIELDS ON A GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C WAVE FIELDS ARE IN SEQUENTIAL 'IBM ORDER'. -C GRID FIELDS ARE INDEXED EAST TO WEST, THEN NORTH TO SOUTH. -C FOR MORE FLEXIBILITY AND EFFICIENCY, CALL SPTRAN. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTEZMV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, -C & WAVED,WAVEZ,GRIDU,GRIDV,IDIR) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES -C JMAX - INTEGER NUMBER OF LATITUDES -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM -C WAVED - REAL (2*MX,KMAX) WAVE DIVERGENCE FIELD IF IDIR>0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 -C WAVEZ - REAL (2*MX,KMAX) WAVE VORTICITY FIELD IF IDIR>0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 -C GRIDU - REAL (IMAX,JMAX,KMAX) GRID U-WIND (E->W,N->S) IF IDIR<0 -C GRIDV - REAL (IMAX,JMAX,KMAX) GRID V-WIND (E->W,N->S) IF IDIR<0 -C IDIR - INTEGER TRANSFORM FLAG -C (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -C OUTPUT ARGUMENTS: -C WAVED - REAL (2*MX,KMAX) WAVE DIVERGENCE FIELD IF IDIR<0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 -C WAVEZ - REAL (2*MX,KMAX) WAVE VORTICITY FIELD IF IDIR>0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 -C GRIDU - REAL (IMAX,JMAX,KMAX) GRID U-WIND (E->W,N->S) IF IDIR>0 -C GRIDV - REAL (IMAX,JMAX,KMAX) GRID V-WIND (E->W,N->S) IF IDIR>0 -C -C SUBPROGRAMS CALLED: -C SPTRANFV PERFORM A VECTOR SPHERICAL TRANSFORM -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVED((MAXWV+1)*((IROMB+1)*MAXWV+2),KMAX) - REAL WAVEZ((MAXWV+1)*((IROMB+1)*MAXWV+2),KMAX) - REAL GRIDU(IMAX,JMAX,KMAX) - REAL GRIDV(IMAX,JMAX,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - IP=1 - IS=1 - JN=IMAX - JS=-JN - KW=2*MX - KG=IMAX*JMAX - JB=1 - JE=(JMAX+1)/2 - JC=NCPUS() - IF(IDIR.LT.0) WAVED=0 - IF(IDIR.LT.0) WAVEZ=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - CALL SPTRANFV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, - & IP,IS,JN,JS,KW,KG,JB,JE,JC, - & WAVED,WAVEZ, - & GRIDU,GRIDU(1,JMAX,1),GRIDV,GRIDV(1,JMAX,1),IDIR) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptezv.f b/src/fim/FIMsrc/prep/sp/sptezv.f deleted file mode 100644 index 97fadcd..0000000 --- a/src/fim/FIMsrc/prep/sp/sptezv.f +++ /dev/null @@ -1,94 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTEZV(IROMB,MAXWV,IDRT,IMAX,JMAX, - & WAVED,WAVEZ,GRIDU,GRIDV,IDIR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTEZV PERFORM A SIMPLE VECTOR SPHERICAL TRANSFORM -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C BETWEEN SPECTRAL COEFFICIENTS OF DIVERGENCE AND CURL -C AND A VECTOR FIELD ON A GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER'. -C THE GRID FIELS IS INDEXED EAST TO WEST, THEN NORTH TO SOUTH. -C FOR MORE FLEXIBILITY AND EFFICIENCY, CALL SPTRAN. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTEZV(IROMB,MAXWV,IDRT,IMAX,JMAX, -C & WAVED,WAVEZ,GRIDU,GRIDV,IDIR) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES. -C JMAX - INTEGER NUMBER OF LATITUDES. -C WAVED - REAL (2*MX) WAVE DIVERGENCE FIELD IF IDIR>0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 -C WAVEZ - REAL (2*MX) WAVE VORTICITY FIELD IF IDIR>0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 -C GRIDU - REAL (IMAX,JMAX) GRID U-WIND (E->W,N->S) IF IDIR<0 -C GRIDV - REAL (IMAX,JMAX) GRID V-WIND (E->W,N->S) IF IDIR<0 -C IDIR - INTEGER TRANSFORM FLAG -C (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -C OUTPUT ARGUMENTS: -C WAVED - REAL (2*MX) WAVE DIVERGENCE FIELD IF IDIR<0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 -C WAVEZ - REAL (2*MX) WAVE VORTICITY FIELD IF IDIR>0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 -C GRIDU - REAL (IMAX,JMAX) GRID U-WIND (E->W,N->S) IF IDIR>0 -C GRIDV - REAL (IMAX,JMAX) GRID V-WIND (E->W,N->S) IF IDIR>0 -C -C SUBPROGRAMS CALLED: -C SPTRANFV PERFORM A VECTOR SPHERICAL TRANSFORM -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVED((MAXWV+1)*((IROMB+1)*MAXWV+2)) - REAL WAVEZ((MAXWV+1)*((IROMB+1)*MAXWV+2)) - REAL GRIDU(IMAX,JMAX) - REAL GRIDV(IMAX,JMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - IP=1 - IS=1 - JN=IMAX - JS=-JN - KW=2*MX - KG=IMAX*JMAX - JB=1 - JE=(JMAX+1)/2 - JC=NCPUS() - IF(IDIR.LT.0) WAVED=0 - IF(IDIR.LT.0) WAVEZ=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - CALL SPTRANFV(IROMB,MAXWV,IDRT,IMAX,JMAX,1, - & IP,IS,JN,JS,KW,KG,JB,JE,JC, - & WAVED,WAVEZ, - & GRIDU,GRIDU(1,JMAX),GRIDV,GRIDV(1,JMAX),IDIR) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptgpm.f b/src/fim/FIMsrc/prep/sp/sptgpm.f deleted file mode 100644 index c1ad551..0000000 --- a/src/fim/FIMsrc/prep/sp/sptgpm.f +++ /dev/null @@ -1,137 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTGPM(IROMB,MAXWV,KMAX,MI,MJ, - & KWSKIP,KGSKIP,NISKIP,NJSKIP, - & RLAT1,RLON1,DLAT,DLON,WAVE,GM) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPM TRANSFORM SPECTRAL SCALAR TO MERCATOR -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF SCALAR QUANTITIES -C TO SCALAR FIELDS ON A MERCATOR GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE MERCATOR GRID IS IDENTIFIED BY THE LOCATION -C OF ITS FIRST POINT AND BY ITS RESPECTIVE INCREMENTS. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER SECTOR POINTS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPTGPM(IROMB,MAXWV,KMAX,MI,MJ, -C & KWSKIP,KGSKIP,NISKIP,NJSKIP, -C & RLAT1,RLON1,DLAT,DLON,WAVE,GM) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C MI - INTEGER NUMBER OF POINTS IN THE FASTER ZONAL DIRECTION -C MJ - INTEGER NUMBER OF POINTS IN THE SLOWER MERID DIRECTION -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO MI*MJ IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO MI IF NJSKIP=0) -C RLAT1 - REAL LATITUDE OF THE FIRST GRID POINT IN DEGREES -C RLON1 - REAL LONGITUDE OF THE FIRST GRID POINT IN DEGREES -C DLAT - REAL LATITUDE INCREMENT IN DEGREES SUCH THAT -C D(PHI)/D(J)=DLAT*COS(PHI) WHERE J IS MERIDIONAL INDEX. -C DLAT IS NEGATIVE FOR GRIDS INDEXED SOUTHWARD. -C (IN TERMS OF GRID INCREMENT DY VALID AT LATITUDE RLATI, -C THE LATITUDE INCREMENT DLAT IS DETERMINED AS -C DLAT=DPR*DY/(RERTH*COS(RLATI/DPR)) -C WHERE DPR=180/PI AND RERTH IS EARTH'S RADIUS) -C DLON - REAL LONGITUDE INCREMENT IN DEGREES SUCH THAT -C D(LAMBDA)/D(I)=DLON WHERE I IS ZONAL INDEX. -C DLON IS NEGATIVE FOR GRIDS INDEXED WESTWARD. -C WAVE - REAL (*) WAVE FIELDS -C OUTPUT ARGUMENTS: -C GM - REAL (*) MERCATOR FIELDS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVE(*),GM(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - INTEGER MP(KMAX) - REAL WTOP(2*(MAXWV+1),KMAX) - REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),PLNTOP(MAXWV+1) - REAL F(2*MAXWV+3,2,KMAX) - REAL CLAT(MJ),SLAT(MJ),CLON(MAXWV,MI),SLON(MAXWV,MI) - PARAMETER(RERTH=6.3712E6) - PARAMETER(PI=3.14159265358979,DPR=180./PI) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE PRELIMINARY CONSTANTS - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MXTOP=MAXWV+1 - IDIM=2*MAXWV+3 - KW=KWSKIP - KG=KGSKIP - NI=NISKIP - NJ=NJSKIP - IF(KW.EQ.0) KW=2*MX - IF(KG.EQ.0) KG=MI*MJ - IF(NI.EQ.0) NI=1 - IF(NJ.EQ.0) NJ=MI - DO I=1,MI - RLON=MOD(RLON1+DLON*(I-1)+3600,360.) - DO L=1,MAXWV - CLON(L,I)=COS(L*RLON/DPR) - SLON(L,I)=SIN(L*RLON/DPR) - ENDDO - ENDDO - YE=1-LOG(TAN((RLAT1+90)/2/DPR))*DPR/DLAT - DO J=1,MJ - RLAT=ATAN(EXP(DLAT/DPR*(J-YE)))*2*DPR-90 - CLAT(J)=COS(RLAT/DPR) - SLAT(J)=SIN(RLAT/DPR) - ENDDO - MP=0 -C$OMP PARALLEL DO - DO K=1,KMAX - WTOP(1:2*MXTOP,K)=0 - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM TO GRID -C$OMP PARALLEL DO PRIVATE(PLN,PLNTOP,F,IJK) - DO J=1,MJ - CALL SPLEGEND(IROMB,MAXWV,SLAT(J),CLAT(J),EPS,EPSTOP, - & PLN,PLNTOP) - CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,KW,2*MXTOP,KMAX, - & CLAT(J),PLN,PLNTOP,MP,WAVE,WTOP,F) - DO K=1,KMAX - DO I=1,MI - IJK=(I-1)*NI+(J-1)*NJ+(K-1)*KG+1 - GM(IJK)=F(1,1,K) - ENDDO - DO L=1,MAXWV - DO I=1,MI - IJK=(I-1)*NI+(J-1)*NJ+(K-1)*KG+1 - GM(IJK)=GM(IJK)+2.*(F(2*L+1,1,K)*CLON(L,I) - & -F(2*L+2,1,K)*SLON(L,I)) - ENDDO - ENDDO - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptgpmd.f b/src/fim/FIMsrc/prep/sp/sptgpmd.f deleted file mode 100644 index e083ce4..0000000 --- a/src/fim/FIMsrc/prep/sp/sptgpmd.f +++ /dev/null @@ -1,96 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTGPMD(IROMB,MAXWV,KMAX,MI,MJ, - & KWSKIP,KGSKIP,NISKIP,NJSKIP, - & RLAT1,RLON1,DLAT,DLON,WAVE,XM,YM) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPMD TRANSFORM SPECTRAL TO MERCATOR GRADIENTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF SCALAR FIELDS -C TO GRADIENT FIELDS ON A MERCATOR GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE MERCATOR GRID IS IDENTIFIED BY THE LOCATION -C OF ITS FIRST POINT AND BY ITS RESPECTIVE INCREMENTS. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER SECTOR POINTS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPTGPMD(IROMB,MAXWV,KMAX,MI,MJ, -C & KWSKIP,KGSKIP,NISKIP,NJSKIP, -C & RLAT1,RLON1,DLAT,DLON,WAVE,XM,YM) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C MI - INTEGER NUMBER OF POINTS IN THE FASTER ZONAL DIRECTION -C MJ - INTEGER NUMBER OF POINTS IN THE SLOWER MERID DIRECTION -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO MI*MJ IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO MI IF NJSKIP=0) -C RLAT1 - REAL LATITUDE OF THE FIRST GRID POINT IN DEGREES -C RLON1 - REAL LONGITUDE OF THE FIRST GRID POINT IN DEGREES -C DLAT - REAL LATITUDE INCREMENT IN DEGREES SUCH THAT -C D(PHI)/D(J)=DLAT*COS(PHI) WHERE J IS MERIDIONAL INDEX. -C DLAT IS NEGATIVE FOR GRIDS INDEXED SOUTHWARD. -C (IN TERMS OF GRID INCREMENT DY VALID AT LATITUDE RLATI, -C THE LATITUDE INCREMENT DLAT IS DETERMINED AS -C DLAT=DPR*DY/(RERTH*COS(RLATI/DPR)) -C WHERE DPR=180/PI AND RERTH IS EARTH'S RADIUS) -C DLON - REAL LONGITUDE INCREMENT IN DEGREES SUCH THAT -C D(LAMBDA)/D(I)=DLON WHERE I IS ZONAL INDEX. -C DLON IS NEGATIVE FOR GRIDS INDEXED WESTWARD. -C WAVE - REAL (*) WAVE FIELDS -C OUTPUT ARGUMENTS: -C XM - REAL (*) MERCATOR X-GRADIENTS -C YM - REAL (*) MERCATOR Y-GRADIENTS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTGPMV TRANSFORM SPECTRAL VECTOR TO MERCATOR -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVE(*),XM(*),YM(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - REAL WD((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) - REAL WZ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE PRELIMINARY CONSTANTS - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MDIM=2*MX+1 - KW=KWSKIP - IF(KW.EQ.0) KW=2*MX -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE GRADIENTS -C$OMP PARALLEL DO PRIVATE(KWS) - DO K=1,KMAX - KWS=(K-1)*KW - CALL SPLAPLAC(IROMB,MAXWV,ENN1,WAVE(KWS+1),WD(1,K),1) - WZ(1:2*MX,K)=0. - ENDDO - CALL SPTGPMV(IROMB,MAXWV,KMAX,MI,MJ,MDIM,KGSKIP,NISKIP,NJSKIP, - & RLAT1,RLON1,DLAT,DLON,WD,WZ,XM,YM) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptgpmv.f b/src/fim/FIMsrc/prep/sp/sptgpmv.f deleted file mode 100644 index 317ac6a..0000000 --- a/src/fim/FIMsrc/prep/sp/sptgpmv.f +++ /dev/null @@ -1,152 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTGPMV(IROMB,MAXWV,KMAX,MI,MJ, - & KWSKIP,KGSKIP,NISKIP,NJSKIP, - & RLAT1,RLON1,DLAT,DLON,WAVED,WAVEZ,UM,VM) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPMV TRANSFORM SPECTRAL VECTOR TO MERCATOR -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF DIVERGENCES AND CURLS -C TO VECTOR FIELDS ON A MERCATOR GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE MERCATOR GRID IS IDENTIFIED BY THE LOCATION -C OF ITS FIRST POINT AND BY ITS RESPECTIVE INCREMENTS. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER SECTOR POINTS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPTGPMV(IROMB,MAXWV,KMAX,MI,MJ, -C & KWSKIP,KGSKIP,NISKIP,NJSKIP, -C & RLAT1,RLON1,DLAT,DLON,WAVED,WAVEZ,UM,VM) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C MI - INTEGER NUMBER OF POINTS IN THE FASTER ZONAL DIRECTION -C MJ - INTEGER NUMBER OF POINTS IN THE SLOWER MERID DIRECTION -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO MI*MJ IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO MI IF NJSKIP=0) -C RLAT1 - REAL LATITUDE OF THE FIRST GRID POINT IN DEGREES -C RLON1 - REAL LONGITUDE OF THE FIRST GRID POINT IN DEGREES -C DLAT - REAL LATITUDE INCREMENT IN DEGREES SUCH THAT -C D(PHI)/D(J)=DLAT*COS(PHI) WHERE J IS MERIDIONAL INDEX. -C DLAT IS NEGATIVE FOR GRIDS INDEXED SOUTHWARD. -C (IN TERMS OF GRID INCREMENT DY VALID AT LATITUDE RLATI, -C THE LATITUDE INCREMENT DLAT IS DETERMINED AS -C DLAT=DPR*DY/(RERTH*COS(RLATI/DPR)) -C WHERE DPR=180/PI AND RERTH IS EARTH'S RADIUS) -C DLON - REAL LONGITUDE INCREMENT IN DEGREES SUCH THAT -C D(LAMBDA)/D(I)=DLON WHERE I IS ZONAL INDEX. -C DLON IS NEGATIVE FOR GRIDS INDEXED WESTWARD. -C WAVED - REAL (*) WAVE DIVERGENCE FIELDS -C WAVEZ - REAL (*) WAVE VORTICITY FIELDS -C OUTPUT ARGUMENTS: -C UM - REAL (*) MERCATOR U-WINDS -C VM - REAL (*) MERCATOR V-WINDS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C SPDZ2UV COMPUTE WINDS FROM DIVERGENCE AND VORTICITY -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVED(*),WAVEZ(*),UM(*),VM(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - INTEGER MP(2*KMAX) - REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,2*KMAX) - REAL WTOP(2*(MAXWV+1),2*KMAX) - REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),PLNTOP(MAXWV+1) - REAL F(2*MAXWV+3,2,2*KMAX) - REAL CLAT(MJ),SLAT(MJ),CLON(MAXWV,MI),SLON(MAXWV,MI) - PARAMETER(RERTH=6.3712E6) - PARAMETER(PI=3.14159265358979,DPR=180./PI) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE PRELIMINARY CONSTANTS - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MXTOP=MAXWV+1 - MDIM=2*MX+1 - IDIM=2*MAXWV+3 - KW=KWSKIP - KG=KGSKIP - NI=NISKIP - NJ=NJSKIP - IF(KW.EQ.0) KW=2*MX - IF(KG.EQ.0) KG=MI*MJ - IF(NI.EQ.0) NI=1 - IF(NJ.EQ.0) NJ=MI - DO I=1,MI - RLON=MOD(RLON1+DLON*(I-1)+3600,360.) - DO L=1,MAXWV - CLON(L,I)=COS(L*RLON/DPR) - SLON(L,I)=SIN(L*RLON/DPR) - ENDDO - ENDDO - YE=1-LOG(TAN((RLAT1+90)/2/DPR))*DPR/DLAT - DO J=1,MJ - RLAT=ATAN(EXP(DLAT/DPR*(J-YE)))*2*DPR-90 - CLAT(J)=COS(RLAT/DPR) - SLAT(J)=SIN(RLAT/DPR) - ENDDO - MP=1 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE SPECTRAL WINDS -C$OMP PARALLEL DO PRIVATE(KWS) - DO K=1,KMAX - KWS=(K-1)*KW - CALL SPDZ2UV(IROMB,MAXWV,ENN1,ELONN1,EON,EONTOP, - & WAVED(KWS+1),WAVEZ(KWS+1), - & W(1,K),W(1,KMAX+K),WTOP(1,K),WTOP(1,KMAX+K)) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM TO GRID -C$OMP PARALLEL DO PRIVATE(PLN,PLNTOP,F,KU,KV,IJK) - DO J=1,MJ - CALL SPLEGEND(IROMB,MAXWV,SLAT(J),CLAT(J),EPS,EPSTOP, - & PLN,PLNTOP) - CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,MDIM,2*MXTOP,2*KMAX, - & CLAT(J),PLN,PLNTOP,MP,W,WTOP,F) - DO K=1,KMAX - KU=K - KV=K+KMAX - DO I=1,MI - IJK=(I-1)*NI+(J-1)*NJ+(K-1)*KG+1 - UM(IJK)=F(1,1,KU) - VM(IJK)=F(1,1,KV) - ENDDO - DO L=1,MAXWV - DO I=1,MI - IJK=(I-1)*NI+(J-1)*NJ+(K-1)*KG+1 - UM(IJK)=UM(IJK)+2.*(F(2*L+1,1,KU)*CLON(L,I) - & -F(2*L+2,1,KU)*SLON(L,I)) - VM(IJK)=VM(IJK)+2.*(F(2*L+1,1,KV)*CLON(L,I) - & -F(2*L+2,1,KV)*SLON(L,I)) - ENDDO - ENDDO - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptgps.f b/src/fim/FIMsrc/prep/sp/sptgps.f deleted file mode 100644 index 867fc71..0000000 --- a/src/fim/FIMsrc/prep/sp/sptgps.f +++ /dev/null @@ -1,540 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTGPS(IROMB,MAXWV,KMAX,NPS, - & KWSKIP,KGSKIP,NISKIP,NJSKIP, - & TRUE,XMESH,ORIENT,WAVE,GN,GS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPS TRANSFORM SPECTRAL SCALAR TO POLAR STEREO. -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF SCALAR QUANTITIES -C TO SCALAR FIELDS ON A PAIR OF POLAR STEREOGRAPHIC GRIDS. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE TWO SQUARE POLAR STEREOGRAPHIC GRIDS ARE CENTERED -C ON THE RESPECTIVE POLES, WITH THE ORIENTATION LONGITUDE -C OF THE SOUTHERN HEMISPHERE GRID 180 DEGREES OPPOSITE -C THAT OF THE NORTHERN HEMISPHERE GRID. -C -C THE TRANSFORM IS MADE EFFICIENT \ 4 | 5 / -C BY COMBINING POINTS IN EIGHT SECTORS \ | / -C OF EACH POLAR STEREOGRAPHIC GRID, 3 \ | / 6 -C NUMBERED AS IN THE DIAGRAM AT RIGHT. \|/ -C THE POLE AND THE SECTOR BOUNDARIES ----+---- -C ARE TREATED SPECIALLY IN THE CODE. /|\ -C UNFORTUNATELY, THIS APPROACH INDUCES 2 / | \ 7 -C SOME HAIRY INDEXING AND CODE LOQUACITY, / | \ -C FOR WHICH THE DEVELOPER APOLOGIZES. / 1 | 8 \ -C -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER SECTOR POINTS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPTGPS(IROMB,MAXWV,KMAX,NPS, -C & KWSKIP,KGSKIP,NISKIP,NJSKIP, -C & TRUE,XMESH,ORIENT,WAVE,GN,GS) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NPS - INTEGER ODD ORDER OF THE POLAR STEREOGRAPHIC GRIDS -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO NPS*NPS IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO NPS IF NJSKIP=0) -C TRUE - REAL LATITUDE AT WHICH PS GRID IS TRUE (USUALLY 60.) -C XMESH - REAL GRID LENGTH AT TRUE LATITUDE (M) -C ORIENT - REAL LONGITUDE AT BOTTOM OF NORTHERN PS GRID -C (SOUTHERN PS GRID WILL HAVE OPPOSITE ORIENTATION.) -C WAVE - REAL (*) WAVE FIELDS -C OUTPUT ARGUMENTS: -C GN - REAL (*) NORTHERN POLAR STEREOGRAPHIC FIELDS -C GS - REAL (*) SOUTHERN POLAR STEREOGRAPHIC FIELDS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVE(*),GN(*),GS(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - INTEGER MP(KMAX) - REAL SLON(MAXWV,8),CLON(MAXWV,8),SROT(0:3),CROT(0:3) - REAL WTOP(2*(MAXWV+1),KMAX) - REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),PLNTOP(MAXWV+1) - REAL F(2*MAXWV+3,2,KMAX) - DATA SROT/0.,1.,0.,-1./,CROT/1.,0.,-1.,0./ - PARAMETER(RERTH=6.3712E6) - PARAMETER(PI=3.14159265358979,DPR=180./PI) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE PRELIMINARY CONSTANTS - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MXTOP=MAXWV+1 - IDIM=2*MAXWV+3 - KW=KWSKIP - KG=KGSKIP - NI=NISKIP - NJ=NJSKIP - IF(KW.EQ.0) KW=2*MX - IF(KG.EQ.0) KG=NPS*NPS - IF(NI.EQ.0) NI=1 - IF(NJ.EQ.0) NJ=NPS - MP=0 - NPH=(NPS-1)/2 - GQ=((1.+SIN(TRUE/DPR))*RERTH/XMESH)**2 -C$OMP PARALLEL DO - DO K=1,KMAX - WTOP(1:2*MXTOP,K)=0 - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE POLE POINT - I1=NPH+1 - J1=NPH+1 - IJ1=(I1-1)*NI+(J1-1)*NJ+1 - SLAT1=1. - CLAT1=0. - CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP, - & PLN,PLNTOP) - CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,KW,2*MXTOP,KMAX, - & CLAT1,PLN,PLNTOP,MP,WAVE,WTOP,F) -CDIR$ IVDEP - DO K=1,KMAX - IJK1=IJ1+(K-1)*KG - GN(IJK1)=F(1,1,K) - GS(IJK1)=F(1,2,K) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE POINTS ALONG THE ROW AND COLUMN OF THE POLE, -C STARTING AT THE ORIENTATION LONGITUDE AND GOING CLOCKWISE. -C$OMP PARALLEL DO PRIVATE(I1,J2,I2,J3,I3,J4,I4,J5,I5,J6,I6,J7,I7,J8,I8) -C$OMP& PRIVATE(IJ1,IJ2,IJ3,IJ4,IJ5,IJ6,IJ7,IJ8) -C$OMP& PRIVATE(IJK1,IJK2,IJK3,IJK4,IJK5,IJK6,IJK7,IJK8) -C$OMP& PRIVATE(DJ1,DI1,RQ,RADLON,RADLON1,RADLON2,SLAT1,CLAT1) -C$OMP& PRIVATE(PLN,PLNTOP,F,SLON,CLON,LR,LI) - DO J1=1,NPH - I1=NPH+1 - RADLON=ORIENT/DPR - J3=NPS+1-I1 - I3=J1 - J5=NPS+1-J1 - I5=NPS+1-I1 - J7=I1 - I7=NPS+1-J1 - IJ1=(I1-1)*NI+(J1-1)*NJ+1 - IJ3=(I3-1)*NI+(J3-1)*NJ+1 - IJ5=(I5-1)*NI+(J5-1)*NJ+1 - IJ7=(I7-1)*NI+(J7-1)*NJ+1 - DI1=I1-NPH-1 - DJ1=J1-NPH-1 - RQ=DI1**2+DJ1**2 - SLAT1=(GQ-RQ)/(GQ+RQ) - CLAT1=SQRT(1.-SLAT1**2) - CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP, - & PLN,PLNTOP) - CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,KW,2*MXTOP,KMAX, - & CLAT1,PLN,PLNTOP,MP,WAVE,WTOP,F) - DO L=1,MAXWV - SLON(L,1)=SIN(L*RADLON) - CLON(L,1)=COS(L*RADLON) - SLON(L,3)=SLON(L,1)*CROT(MOD(1*L,4)) - & -CLON(L,1)*SROT(MOD(1*L,4)) - CLON(L,3)=CLON(L,1)*CROT(MOD(1*L,4)) - & +SLON(L,1)*SROT(MOD(1*L,4)) - SLON(L,5)=SLON(L,1)*CROT(MOD(2*L,4)) - & -CLON(L,1)*SROT(MOD(2*L,4)) - CLON(L,5)=CLON(L,1)*CROT(MOD(2*L,4)) - & +SLON(L,1)*SROT(MOD(2*L,4)) - SLON(L,7)=SLON(L,1)*CROT(MOD(3*L,4)) - & -CLON(L,1)*SROT(MOD(3*L,4)) - CLON(L,7)=CLON(L,1)*CROT(MOD(3*L,4)) - & +SLON(L,1)*SROT(MOD(3*L,4)) - ENDDO -CDIR$ IVDEP - DO K=1,KMAX - IJK1=IJ1+(K-1)*KG - IJK3=IJ3+(K-1)*KG - IJK5=IJ5+(K-1)*KG - IJK7=IJ7+(K-1)*KG - GN(IJK1)=F(1,1,K) - GN(IJK3)=F(1,1,K) - GN(IJK5)=F(1,1,K) - GN(IJK7)=F(1,1,K) - GS(IJK1)=F(1,2,K) - GS(IJK3)=F(1,2,K) - GS(IJK5)=F(1,2,K) - GS(IJK7)=F(1,2,K) - ENDDO - IF(KMAX.EQ.1) THEN - DO L=1,MAXWV - LR=2*L+1 - LI=2*L+2 - GN(IJ1)=GN(IJ1)+2*(F(LR,1,1)*CLON(L,1) - & -F(LI,1,1)*SLON(L,1)) - GN(IJ3)=GN(IJ3)+2*(F(LR,1,1)*CLON(L,3) - & -F(LI,1,1)*SLON(L,3)) - GN(IJ5)=GN(IJ5)+2*(F(LR,1,1)*CLON(L,5) - & -F(LI,1,1)*SLON(L,5)) - GN(IJ7)=GN(IJ7)+2*(F(LR,1,1)*CLON(L,7) - & -F(LI,1,1)*SLON(L,7)) - GS(IJ1)=GS(IJ1)+2*(F(LR,2,1)*CLON(L,5) - & -F(LI,2,1)*SLON(L,5)) - GS(IJ3)=GS(IJ3)+2*(F(LR,2,1)*CLON(L,3) - & -F(LI,2,1)*SLON(L,3)) - GS(IJ5)=GS(IJ5)+2*(F(LR,2,1)*CLON(L,1) - & -F(LI,2,1)*SLON(L,1)) - GS(IJ7)=GS(IJ7)+2*(F(LR,2,1)*CLON(L,7) - & -F(LI,2,1)*SLON(L,7)) - ENDDO - ELSE - DO L=1,MAXWV - LR=2*L+1 - LI=2*L+2 -CDIR$ IVDEP - DO K=1,KMAX - IJK1=IJ1+(K-1)*KG - IJK3=IJ3+(K-1)*KG - IJK5=IJ5+(K-1)*KG - IJK7=IJ7+(K-1)*KG - GN(IJK1)=GN(IJK1)+2*(F(LR,1,K)*CLON(L,1) - & -F(LI,1,K)*SLON(L,1)) - GN(IJK3)=GN(IJK3)+2*(F(LR,1,K)*CLON(L,3) - & -F(LI,1,K)*SLON(L,3)) - GN(IJK5)=GN(IJK5)+2*(F(LR,1,K)*CLON(L,5) - & -F(LI,1,K)*SLON(L,5)) - GN(IJK7)=GN(IJK7)+2*(F(LR,1,K)*CLON(L,7) - & -F(LI,1,K)*SLON(L,7)) - GS(IJK1)=GS(IJK1)+2*(F(LR,2,K)*CLON(L,5) - & -F(LI,2,K)*SLON(L,5)) - GS(IJK3)=GS(IJK3)+2*(F(LR,2,K)*CLON(L,3) - & -F(LI,2,K)*SLON(L,3)) - GS(IJK5)=GS(IJK5)+2*(F(LR,2,K)*CLON(L,1) - & -F(LI,2,K)*SLON(L,1)) - GS(IJK7)=GS(IJK7)+2*(F(LR,2,K)*CLON(L,7) - & -F(LI,2,K)*SLON(L,7)) - ENDDO - ENDDO - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE POINTS ON THE MAIN DIAGONALS THROUGH THE POLE, -C STARTING CLOCKWISE OF THE ORIENTATION LONGITUDE AND GOING CLOCKWISE. -C$OMP PARALLEL DO PRIVATE(I1,J2,I2,J3,I3,J4,I4,J5,I5,J6,I6,J7,I7,J8,I8) -C$OMP& PRIVATE(IJ1,IJ2,IJ3,IJ4,IJ5,IJ6,IJ7,IJ8) -C$OMP& PRIVATE(IJK1,IJK2,IJK3,IJK4,IJK5,IJK6,IJK7,IJK8) -C$OMP& PRIVATE(DJ1,DI1,RQ,RADLON,RADLON1,RADLON2,SLAT1,CLAT1) -C$OMP& PRIVATE(PLN,PLNTOP,F,SLON,CLON,LR,LI) - DO J1=1,NPH - I1=J1 - RADLON=(ORIENT-45)/DPR - J3=NPS+1-I1 - I3=J1 - J5=NPS+1-J1 - I5=NPS+1-I1 - J7=I1 - I7=NPS+1-J1 - IJ1=(I1-1)*NI+(J1-1)*NJ+1 - IJ3=(I3-1)*NI+(J3-1)*NJ+1 - IJ5=(I5-1)*NI+(J5-1)*NJ+1 - IJ7=(I7-1)*NI+(J7-1)*NJ+1 - DI1=I1-NPH-1 - DJ1=J1-NPH-1 - RQ=DI1**2+DJ1**2 - SLAT1=(GQ-RQ)/(GQ+RQ) - CLAT1=SQRT(1.-SLAT1**2) - CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP, - & PLN,PLNTOP) - CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,KW,2*MXTOP,KMAX, - & CLAT1,PLN,PLNTOP,MP,WAVE,WTOP,F) - DO L=1,MAXWV - SLON(L,1)=SIN(L*RADLON) - CLON(L,1)=COS(L*RADLON) - SLON(L,3)=SLON(L,1)*CROT(MOD(1*L,4)) - & -CLON(L,1)*SROT(MOD(1*L,4)) - CLON(L,3)=CLON(L,1)*CROT(MOD(1*L,4)) - & +SLON(L,1)*SROT(MOD(1*L,4)) - SLON(L,5)=SLON(L,1)*CROT(MOD(2*L,4)) - & -CLON(L,1)*SROT(MOD(2*L,4)) - CLON(L,5)=CLON(L,1)*CROT(MOD(2*L,4)) - & +SLON(L,1)*SROT(MOD(2*L,4)) - SLON(L,7)=SLON(L,1)*CROT(MOD(3*L,4)) - & -CLON(L,1)*SROT(MOD(3*L,4)) - CLON(L,7)=CLON(L,1)*CROT(MOD(3*L,4)) - & +SLON(L,1)*SROT(MOD(3*L,4)) - ENDDO -CDIR$ IVDEP - DO K=1,KMAX - IJK1=IJ1+(K-1)*KG - IJK3=IJ3+(K-1)*KG - IJK5=IJ5+(K-1)*KG - IJK7=IJ7+(K-1)*KG - GN(IJK1)=F(1,1,K) - GN(IJK3)=F(1,1,K) - GN(IJK5)=F(1,1,K) - GN(IJK7)=F(1,1,K) - GS(IJK1)=F(1,2,K) - GS(IJK3)=F(1,2,K) - GS(IJK5)=F(1,2,K) - GS(IJK7)=F(1,2,K) - ENDDO - IF(KMAX.EQ.1) THEN - DO L=1,MAXWV - LR=2*L+1 - LI=2*L+2 - GN(IJ1)=GN(IJ1)+2*(F(LR,1,1)*CLON(L,1) - & -F(LI,1,1)*SLON(L,1)) - GN(IJ3)=GN(IJ3)+2*(F(LR,1,1)*CLON(L,3) - & -F(LI,1,1)*SLON(L,3)) - GN(IJ5)=GN(IJ5)+2*(F(LR,1,1)*CLON(L,5) - & -F(LI,1,1)*SLON(L,5)) - GN(IJ7)=GN(IJ7)+2*(F(LR,1,1)*CLON(L,7) - & -F(LI,1,1)*SLON(L,7)) - GS(IJ1)=GS(IJ1)+2*(F(LR,2,1)*CLON(L,3) - & -F(LI,2,1)*SLON(L,3)) - GS(IJ3)=GS(IJ3)+2*(F(LR,2,1)*CLON(L,1) - & -F(LI,2,1)*SLON(L,1)) - GS(IJ5)=GS(IJ5)+2*(F(LR,2,1)*CLON(L,7) - & -F(LI,2,1)*SLON(L,7)) - GS(IJ7)=GS(IJ7)+2*(F(LR,2,1)*CLON(L,5) - & -F(LI,2,1)*SLON(L,5)) - ENDDO - ELSE - DO L=1,MAXWV - LR=2*L+1 - LI=2*L+2 -CDIR$ IVDEP - DO K=1,KMAX - IJK1=IJ1+(K-1)*KG - IJK3=IJ3+(K-1)*KG - IJK5=IJ5+(K-1)*KG - IJK7=IJ7+(K-1)*KG - GN(IJK1)=GN(IJK1)+2*(F(LR,1,K)*CLON(L,1) - & -F(LI,1,K)*SLON(L,1)) - GN(IJK3)=GN(IJK3)+2*(F(LR,1,K)*CLON(L,3) - & -F(LI,1,K)*SLON(L,3)) - GN(IJK5)=GN(IJK5)+2*(F(LR,1,K)*CLON(L,5) - & -F(LI,1,K)*SLON(L,5)) - GN(IJK7)=GN(IJK7)+2*(F(LR,1,K)*CLON(L,7) - & -F(LI,1,K)*SLON(L,7)) - GS(IJK1)=GS(IJK1)+2*(F(LR,2,K)*CLON(L,3) - & -F(LI,2,K)*SLON(L,3)) - GS(IJK3)=GS(IJK3)+2*(F(LR,2,K)*CLON(L,1) - & -F(LI,2,K)*SLON(L,1)) - GS(IJK5)=GS(IJK5)+2*(F(LR,2,K)*CLON(L,7) - & -F(LI,2,K)*SLON(L,7)) - GS(IJK7)=GS(IJK7)+2*(F(LR,2,K)*CLON(L,5) - & -F(LI,2,K)*SLON(L,5)) - ENDDO - ENDDO - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE THE REMAINDER OF THE POLAR STEREOGRAPHIC DOMAIN, -C STARTING AT THE SECTOR JUST CLOCKWISE OF THE ORIENTATION LONGITUDE -C AND GOING CLOCKWISE UNTIL ALL EIGHT SECTORS ARE DONE. -C$OMP PARALLEL DO PRIVATE(I1,J2,I2,J3,I3,J4,I4,J5,I5,J6,I6,J7,I7,J8,I8) -C$OMP& PRIVATE(IJ1,IJ2,IJ3,IJ4,IJ5,IJ6,IJ7,IJ8) -C$OMP& PRIVATE(IJK1,IJK2,IJK3,IJK4,IJK5,IJK6,IJK7,IJK8) -C$OMP& PRIVATE(DJ1,DI1,RQ,RADLON,RADLON1,RADLON2,SLAT1,CLAT1) -C$OMP& PRIVATE(PLN,PLNTOP,F,SLON,CLON,LR,LI) - DO J1=1,NPH-1 - DO I1=J1+1,NPH - J2=I1 - I2=J1 - J3=NPS+1-I1 - I3=J1 - J4=NPS+1-J1 - I4=I1 - J5=NPS+1-J1 - I5=NPS+1-I1 - J6=NPS+1-I1 - I6=NPS+1-J1 - J7=I1 - I7=NPS+1-J1 - J8=J1 - I8=NPS+1-I1 - IJ1=(I1-1)*NI+(J1-1)*NJ+1 - IJ2=(I2-1)*NI+(J2-1)*NJ+1 - IJ3=(I3-1)*NI+(J3-1)*NJ+1 - IJ4=(I4-1)*NI+(J4-1)*NJ+1 - IJ5=(I5-1)*NI+(J5-1)*NJ+1 - IJ6=(I6-1)*NI+(J6-1)*NJ+1 - IJ7=(I7-1)*NI+(J7-1)*NJ+1 - IJ8=(I8-1)*NI+(J8-1)*NJ+1 - DI1=I1-NPH-1 - DJ1=J1-NPH-1 - RQ=DI1**2+DJ1**2 - SLAT1=(GQ-RQ)/(GQ+RQ) - CLAT1=SQRT(1.-SLAT1**2) - RADLON1=ORIENT/DPR+ATAN(-DI1/DJ1) - RADLON2=(ORIENT-45)/DPR*2-RADLON1 - CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP, - & PLN,PLNTOP) - CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,KW,2*MXTOP,KMAX, - & CLAT1,PLN,PLNTOP,MP,WAVE,WTOP,F) - DO L=1,MAXWV - SLON(L,1)=SIN(L*RADLON1) - CLON(L,1)=COS(L*RADLON1) - SLON(L,2)=SIN(L*RADLON2) - CLON(L,2)=COS(L*RADLON2) - SLON(L,3)=SLON(L,1)*CROT(MOD(1*L,4)) - & -CLON(L,1)*SROT(MOD(1*L,4)) - CLON(L,3)=CLON(L,1)*CROT(MOD(1*L,4)) - & +SLON(L,1)*SROT(MOD(1*L,4)) - SLON(L,4)=SLON(L,2)*CROT(MOD(1*L,4)) - & -CLON(L,2)*SROT(MOD(1*L,4)) - CLON(L,4)=CLON(L,2)*CROT(MOD(1*L,4)) - & +SLON(L,2)*SROT(MOD(1*L,4)) - SLON(L,5)=SLON(L,1)*CROT(MOD(2*L,4)) - & -CLON(L,1)*SROT(MOD(2*L,4)) - CLON(L,5)=CLON(L,1)*CROT(MOD(2*L,4)) - & +SLON(L,1)*SROT(MOD(2*L,4)) - SLON(L,6)=SLON(L,2)*CROT(MOD(2*L,4)) - & -CLON(L,2)*SROT(MOD(2*L,4)) - CLON(L,6)=CLON(L,2)*CROT(MOD(2*L,4)) - & +SLON(L,2)*SROT(MOD(2*L,4)) - SLON(L,7)=SLON(L,1)*CROT(MOD(3*L,4)) - & -CLON(L,1)*SROT(MOD(3*L,4)) - CLON(L,7)=CLON(L,1)*CROT(MOD(3*L,4)) - & +SLON(L,1)*SROT(MOD(3*L,4)) - SLON(L,8)=SLON(L,2)*CROT(MOD(3*L,4)) - & -CLON(L,2)*SROT(MOD(3*L,4)) - CLON(L,8)=CLON(L,2)*CROT(MOD(3*L,4)) - & +SLON(L,2)*SROT(MOD(3*L,4)) - ENDDO -CDIR$ IVDEP - DO K=1,KMAX - IJK1=IJ1+(K-1)*KG - IJK2=IJ2+(K-1)*KG - IJK3=IJ3+(K-1)*KG - IJK4=IJ4+(K-1)*KG - IJK5=IJ5+(K-1)*KG - IJK6=IJ6+(K-1)*KG - IJK7=IJ7+(K-1)*KG - IJK8=IJ8+(K-1)*KG - GN(IJK1)=F(1,1,K) - GN(IJK2)=F(1,1,K) - GN(IJK3)=F(1,1,K) - GN(IJK4)=F(1,1,K) - GN(IJK5)=F(1,1,K) - GN(IJK6)=F(1,1,K) - GN(IJK7)=F(1,1,K) - GN(IJK8)=F(1,1,K) - GS(IJK1)=F(1,2,K) - GS(IJK2)=F(1,2,K) - GS(IJK3)=F(1,2,K) - GS(IJK4)=F(1,2,K) - GS(IJK5)=F(1,2,K) - GS(IJK6)=F(1,2,K) - GS(IJK7)=F(1,2,K) - GS(IJK8)=F(1,2,K) - ENDDO - IF(KMAX.EQ.1) THEN - DO L=1,MAXWV - LR=2*L+1 - LI=2*L+2 - GN(IJ1)=GN(IJ1)+2*(F(LR,1,1)*CLON(L,1) - & -F(LI,1,1)*SLON(L,1)) - GN(IJ2)=GN(IJ2)+2*(F(LR,1,1)*CLON(L,2) - & -F(LI,1,1)*SLON(L,2)) - GN(IJ3)=GN(IJ3)+2*(F(LR,1,1)*CLON(L,3) - & -F(LI,1,1)*SLON(L,3)) - GN(IJ4)=GN(IJ4)+2*(F(LR,1,1)*CLON(L,4) - & -F(LI,1,1)*SLON(L,4)) - GN(IJ5)=GN(IJ5)+2*(F(LR,1,1)*CLON(L,5) - & -F(LI,1,1)*SLON(L,5)) - GN(IJ6)=GN(IJ6)+2*(F(LR,1,1)*CLON(L,6) - & -F(LI,1,1)*SLON(L,6)) - GN(IJ7)=GN(IJ7)+2*(F(LR,1,1)*CLON(L,7) - & -F(LI,1,1)*SLON(L,7)) - GN(IJ8)=GN(IJ8)+2*(F(LR,1,1)*CLON(L,8) - & -F(LI,1,1)*SLON(L,8)) - GS(IJ1)=GS(IJ1)+2*(F(LR,2,1)*CLON(L,4) - & -F(LI,2,1)*SLON(L,4)) - GS(IJ2)=GS(IJ2)+2*(F(LR,2,1)*CLON(L,3) - & -F(LI,2,1)*SLON(L,3)) - GS(IJ3)=GS(IJ3)+2*(F(LR,2,1)*CLON(L,2) - & -F(LI,2,1)*SLON(L,2)) - GS(IJ4)=GS(IJ4)+2*(F(LR,2,1)*CLON(L,1) - & -F(LI,2,1)*SLON(L,1)) - GS(IJ5)=GS(IJ5)+2*(F(LR,2,1)*CLON(L,8) - & -F(LI,2,1)*SLON(L,8)) - GS(IJ6)=GS(IJ6)+2*(F(LR,2,1)*CLON(L,7) - & -F(LI,2,1)*SLON(L,7)) - GS(IJ7)=GS(IJ7)+2*(F(LR,2,1)*CLON(L,6) - & -F(LI,2,1)*SLON(L,6)) - GS(IJ8)=GS(IJ8)+2*(F(LR,2,1)*CLON(L,5) - & -F(LI,2,1)*SLON(L,5)) - ENDDO - ELSE - DO L=1,MAXWV - LR=2*L+1 - LI=2*L+2 -CDIR$ IVDEP - DO K=1,KMAX - IJK1=IJ1+(K-1)*KG - IJK2=IJ2+(K-1)*KG - IJK3=IJ3+(K-1)*KG - IJK4=IJ4+(K-1)*KG - IJK5=IJ5+(K-1)*KG - IJK6=IJ6+(K-1)*KG - IJK7=IJ7+(K-1)*KG - IJK8=IJ8+(K-1)*KG - GN(IJK1)=GN(IJK1)+2*(F(LR,1,K)*CLON(L,1) - & -F(LI,1,K)*SLON(L,1)) - GN(IJK2)=GN(IJK2)+2*(F(LR,1,K)*CLON(L,2) - & -F(LI,1,K)*SLON(L,2)) - GN(IJK3)=GN(IJK3)+2*(F(LR,1,K)*CLON(L,3) - & -F(LI,1,K)*SLON(L,3)) - GN(IJK4)=GN(IJK4)+2*(F(LR,1,K)*CLON(L,4) - & -F(LI,1,K)*SLON(L,4)) - GN(IJK5)=GN(IJK5)+2*(F(LR,1,K)*CLON(L,5) - & -F(LI,1,K)*SLON(L,5)) - GN(IJK6)=GN(IJK6)+2*(F(LR,1,K)*CLON(L,6) - & -F(LI,1,K)*SLON(L,6)) - GN(IJK7)=GN(IJK7)+2*(F(LR,1,K)*CLON(L,7) - & -F(LI,1,K)*SLON(L,7)) - GN(IJK8)=GN(IJK8)+2*(F(LR,1,K)*CLON(L,8) - & -F(LI,1,K)*SLON(L,8)) - GS(IJK1)=GS(IJK1)+2*(F(LR,2,K)*CLON(L,4) - & -F(LI,2,K)*SLON(L,4)) - GS(IJK2)=GS(IJK2)+2*(F(LR,2,K)*CLON(L,3) - & -F(LI,2,K)*SLON(L,3)) - GS(IJK3)=GS(IJK3)+2*(F(LR,2,K)*CLON(L,2) - & -F(LI,2,K)*SLON(L,2)) - GS(IJK4)=GS(IJK4)+2*(F(LR,2,K)*CLON(L,1) - & -F(LI,2,K)*SLON(L,1)) - GS(IJK5)=GS(IJK5)+2*(F(LR,2,K)*CLON(L,8) - & -F(LI,2,K)*SLON(L,8)) - GS(IJK6)=GS(IJK6)+2*(F(LR,2,K)*CLON(L,7) - & -F(LI,2,K)*SLON(L,7)) - GS(IJK7)=GS(IJK7)+2*(F(LR,2,K)*CLON(L,6) - & -F(LI,2,K)*SLON(L,6)) - GS(IJK8)=GS(IJK8)+2*(F(LR,2,K)*CLON(L,5) - & -F(LI,2,K)*SLON(L,5)) - ENDDO - ENDDO - ENDIF - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptgpsd.f b/src/fim/FIMsrc/prep/sp/sptgpsd.f deleted file mode 100644 index 25a9ecc..0000000 --- a/src/fim/FIMsrc/prep/sp/sptgpsd.f +++ /dev/null @@ -1,104 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTGPSD(IROMB,MAXWV,KMAX,NPS, - & KWSKIP,KGSKIP,NISKIP,NJSKIP, - & TRUE,XMESH,ORIENT,WAVE,XN,YN,XS,YS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPSD TRANSFORM SPECTRAL TO POLAR STEREO. GRADIENTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF SCALAR FIELDS -C TO GRADIENT FIELDS ON A PAIR OF POLAR STEREOGRAPHIC GRIDS. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE TWO SQUARE POLAR STEREOGRAPHIC GRIDS ARE CENTERED -C ON THE RESPECTIVE POLES, WITH THE ORIENTATION LONGITUDE -C OF THE SOUTHERN HEMISPHERE GRID 180 DEGREES OPPOSITE -C THAT OF THE NORTHERN HEMISPHERE GRID. -C THE VECTORS ARE AUTOMATICALLY ROTATED TO BE RESOLVED -C RELATIVE TO THE RESPECTIVE POLAR STEREOGRAPHIC GRIDS. -C -C THE TRANSFORM IS MADE EFFICIENT \ 4 | 5 / -C BY COMBINING POINTS IN EIGHT SECTORS \ | / -C OF EACH POLAR STEREOGRAPHIC GRID, 3 \ | / 6 -C NUMBERED AS IN THE DIAGRAM AT RIGHT. \|/ -C THE POLE AND THE SECTOR BOUNDARIES ----+---- -C ARE TREATED SPECIALLY IN THE CODE. /|\ -C UNFORTUNATELY, THIS APPROACH INDUCES 2 / | \ 7 -C SOME HAIRY INDEXING AND CODE LOQUACITY, / | \ -C FOR WHICH THE DEVELOPER APOLOGIZES. / 1 | 8 \ -C -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER SECTOR POINTS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPTGPSD(IROMB,MAXWV,KMAX,NPS, -C & KWSKIP,KGSKIP,NISKIP,NJSKIP, -C & TRUE,XMESH,ORIENT,WAVE,XP,YP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NPS - INTEGER ODD ORDER OF THE POLAR STEREOGRAPHIC GRIDS -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO NPS*NPS IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO NPS IF NJSKIP=0) -C TRUE - REAL LATITUDE AT WHICH PS GRID IS TRUE (USUALLY 60.) -C XMESH - REAL GRID LENGTH AT TRUE LATITUDE (M) -C ORIENT - REAL LONGITUDE AT BOTTOM OF NORTHERN PS GRID -C (SOUTHERN PS GRID WILL HAVE OPPOSITE ORIENTATION.) -C WAVE - REAL (*) WAVE FIELDS -C OUTPUT ARGUMENTS: -C XN - REAL (*) NORTHERN POLAR STEREOGRAPHIC X-GRADIENTS -C YN - REAL (*) NORTHERN POLAR STEREOGRAPHIC Y-GRADIENTS -C XS - REAL (*) SOUTHERN POLAR STEREOGRAPHIC X-GRADIENTS -C YS - REAL (*) SOUTHERN POLAR STEREOGRAPHIC Y-GRADIENTS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTGPSV TRANSFORM SPECTRAL VECTOR TO POLAR STEREO. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVE(*),XN(*),YN(*),XS(*),YS(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - REAL WD((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) - REAL WZ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE PRELIMINARY CONSTANTS - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MDIM=2*MX+1 - KW=KWSKIP - IF(KW.EQ.0) KW=2*MX -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE GRADIENTS -C$OMP PARALLEL DO PRIVATE(KWS) - DO K=1,KMAX - KWS=(K-1)*KW - CALL SPLAPLAC(IROMB,MAXWV,ENN1,WAVE(KWS+1),WD(1,K),1) - WZ(1:2*MX,K)=0. - ENDDO - CALL SPTGPSV(IROMB,MAXWV,KMAX,NPS,MDIM,KGSKIP,NISKIP,NJSKIP, - & TRUE,XMESH,ORIENT,WD,WZ,XN,YN,XS,YS) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptgpsv.f b/src/fim/FIMsrc/prep/sp/sptgpsv.f deleted file mode 100644 index 0ac1160..0000000 --- a/src/fim/FIMsrc/prep/sp/sptgpsv.f +++ /dev/null @@ -1,931 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTGPSV(IROMB,MAXWV,KMAX,NPS, - & KWSKIP,KGSKIP,NISKIP,NJSKIP, - & TRUE,XMESH,ORIENT,WAVED,WAVEZ,UN,VN,US,VS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPSV TRANSFORM SPECTRAL VECTOR TO POLAR STEREO. -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF DIVERGENCES AND CURLS -C TO VECTOR FIELDS ON A PAIR OF POLAR STEREOGRAPHIC GRIDS. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE TWO SQUARE POLAR STEREOGRAPHIC GRIDS ARE CENTERED -C ON THE RESPECTIVE POLES, WITH THE ORIENTATION LONGITUDE -C OF THE SOUTHERN HEMISPHERE GRID 180 DEGREES OPPOSITE -C THAT OF THE NORTHERN HEMISPHERE GRID. -C THE VECTORS ARE AUTOMATICALLY ROTATED TO BE RESOLVED -C RELATIVE TO THE RESPECTIVE POLAR STEREOGRAPHIC GRIDS. -C -C THE TRANSFORM IS MADE EFFICIENT \ 4 | 5 / -C BY COMBINING POINTS IN EIGHT SECTORS \ | / -C OF EACH POLAR STEREOGRAPHIC GRID, 3 \ | / 6 -C NUMBERED AS IN THE DIAGRAM AT RIGHT. \|/ -C THE POLE AND THE SECTOR BOUNDARIES ----+---- -C ARE TREATED SPECIALLY IN THE CODE. /|\ -C UNFORTUNATELY, THIS APPROACH INDUCES 2 / | \ 7 -C SOME HAIRY INDEXING AND CODE LOQUACITY, / | \ -C FOR WHICH THE DEVELOPER APOLOGIZES. / 1 | 8 \ -C -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER SECTOR POINTS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPTGPSV(IROMB,MAXWV,KMAX,NPS, -C & KWSKIP,KGSKIP,NISKIP,NJSKIP, -C & TRUE,XMESH,ORIENT,WAVED,WAVEZ,UN,VN,US,VS) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NPS - INTEGER ODD ORDER OF THE POLAR STEREOGRAPHIC GRIDS -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO NPS*NPS IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO NPS IF NJSKIP=0) -C TRUE - REAL LATITUDE AT WHICH PS GRID IS TRUE (USUALLY 60.) -C XMESH - REAL GRID LENGTH AT TRUE LATITUDE (M) -C ORIENT - REAL LONGITUDE AT BOTTOM OF NORTHERN PS GRID -C (SOUTHERN PS GRID WILL HAVE OPPOSITE ORIENTATION.) -C WAVED - REAL (*) WAVE DIVERGENCE FIELDS -C WAVEZ - REAL (*) WAVE VORTICITY FIELDS -C OUTPUT ARGUMENTS: -C UN - REAL (*) NORTHERN POLAR STEREOGRAPHIC U-WINDS -C VN - REAL (*) NORTHERN POLAR STEREOGRAPHIC V-WINDS -C US - REAL (*) SOUTHERN POLAR STEREOGRAPHIC U-WINDS -C VS - REAL (*) SOUTHERN POLAR STEREOGRAPHIC V-WINDS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C SPDZ2UV COMPUTE WINDS FROM DIVERGENCE AND VORTICITY -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVED(*),WAVEZ(*),UN(*),VN(*),US(*),VS(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - INTEGER MP(2*KMAX) - REAL SLON(MAXWV,8),CLON(MAXWV,8),SROT(0:3),CROT(0:3) - REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,2*KMAX) - REAL WTOP(2*(MAXWV+1),2*KMAX) - REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),PLNTOP(MAXWV+1) - REAL F(2*MAXWV+3,2,2*KMAX) - DATA SROT/0.,1.,0.,-1./,CROT/1.,0.,-1.,0./ - PARAMETER(RERTH=6.3712E6) - PARAMETER(PI=3.14159265358979,DPR=180./PI) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE PRELIMINARY CONSTANTS - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MXTOP=MAXWV+1 - MDIM=2*MX+1 - IDIM=2*MAXWV+3 - KW=KWSKIP - KG=KGSKIP - NI=NISKIP - NJ=NJSKIP - IF(KW.EQ.0) KW=2*MX - IF(KG.EQ.0) KG=NPS*NPS - IF(NI.EQ.0) NI=1 - IF(NJ.EQ.0) NJ=NPS - MP=1 - NPH=(NPS-1)/2 - GQ=((1.+SIN(TRUE/DPR))*RERTH/XMESH)**2 - SRH=SQRT(0.5) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE SPECTRAL WINDS -C$OMP PARALLEL DO PRIVATE(KWS) - DO K=1,KMAX - KWS=(K-1)*KW - CALL SPDZ2UV(IROMB,MAXWV,ENN1,ELONN1,EON,EONTOP, - & WAVED(KWS+1),WAVEZ(KWS+1), - & W(1,K),W(1,KMAX+K),WTOP(1,K),WTOP(1,KMAX+K)) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE POLE POINT - I1=NPH+1 - J1=NPH+1 - IJ1=(I1-1)*NI+(J1-1)*NJ+1 - SLAT1=1. - CLAT1=0. - CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP, - & PLN,PLNTOP) - CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,MDIM,2*MXTOP,2*KMAX, - & CLAT1,PLN,PLNTOP,MP,W,WTOP,F) - COSO=COS(ORIENT/DPR) - SINO=SIN(ORIENT/DPR) -CDIR$ IVDEP - DO K=1,KMAX - KU=K - KV=K+KMAX - IJK1=IJ1+(K-1)*KG - UN(IJK1)=2*( COSO*F(3,1,KU)+SINO*F(3,1,KV)) - VN(IJK1)=2*(-SINO*F(3,1,KU)+COSO*F(3,1,KV)) - US(IJK1)=2*( COSO*F(3,2,KU)-SINO*F(3,2,KV)) - VS(IJK1)=2*( SINO*F(3,2,KU)+COSO*F(3,2,KV)) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE POINTS ALONG THE ROW AND COLUMN OF THE POLE, -C STARTING AT THE ORIENTATION LONGITUDE AND GOING CLOCKWISE. -C$OMP PARALLEL DO PRIVATE(I1,J2,I2,J3,I3,J4,I4,J5,I5,J6,I6,J7,I7,J8,I8) -C$OMP& PRIVATE(IJ1,IJ2,IJ3,IJ4,IJ5,IJ6,IJ7,IJ8) -C$OMP& PRIVATE(IJK1,IJK2,IJK3,IJK4,IJK5,IJK6,IJK7,IJK8) -C$OMP& PRIVATE(DJ1,DI1,RQ,RR,RADLON,RADLON1,RADLON2,SLAT1,CLAT1) -C$OMP& PRIVATE(PLN,PLNTOP,F,SLON,CLON,KU,KV,LR,LI) - DO J1=1,NPH - I1=NPH+1 - RADLON=ORIENT/DPR - J3=NPS+1-I1 - I3=J1 - J5=NPS+1-J1 - I5=NPS+1-I1 - J7=I1 - I7=NPS+1-J1 - IJ1=(I1-1)*NI+(J1-1)*NJ+1 - IJ3=(I3-1)*NI+(J3-1)*NJ+1 - IJ5=(I5-1)*NI+(J5-1)*NJ+1 - IJ7=(I7-1)*NI+(J7-1)*NJ+1 - DI1=I1-NPH-1 - DJ1=J1-NPH-1 - RQ=DI1**2+DJ1**2 - SLAT1=(GQ-RQ)/(GQ+RQ) - CLAT1=SQRT(1.-SLAT1**2) - CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP, - & PLN,PLNTOP) - CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,MDIM,2*MXTOP,2*KMAX, - & CLAT1,PLN,PLNTOP,MP,W,WTOP,F) - DO L=1,MAXWV - SLON(L,1)=SIN(L*RADLON) - CLON(L,1)=COS(L*RADLON) - SLON(L,3)=SLON(L,1)*CROT(MOD(1*L,4)) - & -CLON(L,1)*SROT(MOD(1*L,4)) - CLON(L,3)=CLON(L,1)*CROT(MOD(1*L,4)) - & +SLON(L,1)*SROT(MOD(1*L,4)) - SLON(L,5)=SLON(L,1)*CROT(MOD(2*L,4)) - & -CLON(L,1)*SROT(MOD(2*L,4)) - CLON(L,5)=CLON(L,1)*CROT(MOD(2*L,4)) - & +SLON(L,1)*SROT(MOD(2*L,4)) - SLON(L,7)=SLON(L,1)*CROT(MOD(3*L,4)) - & -CLON(L,1)*SROT(MOD(3*L,4)) - CLON(L,7)=CLON(L,1)*CROT(MOD(3*L,4)) - & +SLON(L,1)*SROT(MOD(3*L,4)) - ENDDO -CDIR$ IVDEP - DO K=1,KMAX - KU=K - KV=K+KMAX - IJK1=IJ1+(K-1)*KG - IJK3=IJ3+(K-1)*KG - IJK5=IJ5+(K-1)*KG - IJK7=IJ7+(K-1)*KG - UN(IJK1)= F(1,1,KU) - VN(IJK1)= F(1,1,KV) - UN(IJK3)= F(1,1,KV) - VN(IJK3)=-F(1,1,KU) - UN(IJK5)=-F(1,1,KU) - VN(IJK5)=-F(1,1,KV) - UN(IJK7)=-F(1,1,KV) - VN(IJK7)= F(1,1,KU) - US(IJK1)=-F(1,2,KU) - VS(IJK1)=-F(1,2,KV) - US(IJK3)=-F(1,2,KV) - VS(IJK3)= F(1,2,KU) - US(IJK5)= F(1,2,KU) - VS(IJK5)= F(1,2,KV) - US(IJK7)= F(1,2,KV) - VS(IJK7)=-F(1,2,KU) - ENDDO - IF(KMAX.EQ.1) THEN - KU=1 - KV=2 - DO L=1,MAXWV - LR=2*L+1 - LI=2*L+2 - UN(IJ1)=UN(IJ1)+2*(F(LR,1,KU)*CLON(L,1) - & -F(LI,1,KU)*SLON(L,1)) - VN(IJ1)=VN(IJ1)+2*(F(LR,1,KV)*CLON(L,1) - & -F(LI,1,KV)*SLON(L,1)) - UN(IJ3)=UN(IJ3)+2*(F(LR,1,KV)*CLON(L,3) - & -F(LI,1,KV)*SLON(L,3)) - VN(IJ3)=VN(IJ3)-2*(F(LR,1,KU)*CLON(L,3) - & -F(LI,1,KU)*SLON(L,3)) - UN(IJ5)=UN(IJ5)-2*(F(LR,1,KU)*CLON(L,5) - & -F(LI,1,KU)*SLON(L,5)) - VN(IJ5)=VN(IJ5)-2*(F(LR,1,KV)*CLON(L,5) - & -F(LI,1,KV)*SLON(L,5)) - UN(IJ7)=UN(IJ7)-2*(F(LR,1,KV)*CLON(L,7) - & -F(LI,1,KV)*SLON(L,7)) - VN(IJ7)=VN(IJ7)+2*(F(LR,1,KU)*CLON(L,7) - & -F(LI,1,KU)*SLON(L,7)) - US(IJ1)=US(IJ1)-2*(F(LR,2,KU)*CLON(L,5) - & -F(LI,2,KU)*SLON(L,5)) - VS(IJ1)=VS(IJ1)-2*(F(LR,2,KV)*CLON(L,5) - & -F(LI,2,KV)*SLON(L,5)) - US(IJ3)=US(IJ3)-2*(F(LR,2,KV)*CLON(L,3) - & -F(LI,2,KV)*SLON(L,3)) - VS(IJ3)=VS(IJ3)+2*(F(LR,2,KU)*CLON(L,3) - & -F(LI,2,KU)*SLON(L,3)) - US(IJ5)=US(IJ5)+2*(F(LR,2,KU)*CLON(L,1) - & -F(LI,2,KU)*SLON(L,1)) - VS(IJ5)=VS(IJ5)+2*(F(LR,2,KV)*CLON(L,1) - & -F(LI,2,KV)*SLON(L,1)) - US(IJ7)=US(IJ7)+2*(F(LR,2,KV)*CLON(L,7) - & -F(LI,2,KV)*SLON(L,7)) - VS(IJ7)=VS(IJ7)-2*(F(LR,2,KU)*CLON(L,7) - & -F(LI,2,KU)*SLON(L,7)) - ENDDO - ELSE - DO L=1,MAXWV - LR=2*L+1 - LI=2*L+2 -CDIR$ IVDEP - DO K=1,KMAX - KU=K - KV=K+KMAX - IJK1=IJ1+(K-1)*KG - IJK3=IJ3+(K-1)*KG - IJK5=IJ5+(K-1)*KG - IJK7=IJ7+(K-1)*KG - UN(IJK1)=UN(IJK1)+2*(F(LR,1,KU)*CLON(L,1) - & -F(LI,1,KU)*SLON(L,1)) - VN(IJK1)=VN(IJK1)+2*(F(LR,1,KV)*CLON(L,1) - & -F(LI,1,KV)*SLON(L,1)) - UN(IJK3)=UN(IJK3)+2*(F(LR,1,KV)*CLON(L,3) - & -F(LI,1,KV)*SLON(L,3)) - VN(IJK3)=VN(IJK3)-2*(F(LR,1,KU)*CLON(L,3) - & -F(LI,1,KU)*SLON(L,3)) - UN(IJK5)=UN(IJK5)-2*(F(LR,1,KU)*CLON(L,5) - & -F(LI,1,KU)*SLON(L,5)) - VN(IJK5)=VN(IJK5)-2*(F(LR,1,KV)*CLON(L,5) - & -F(LI,1,KV)*SLON(L,5)) - UN(IJK7)=UN(IJK7)-2*(F(LR,1,KV)*CLON(L,7) - & -F(LI,1,KV)*SLON(L,7)) - VN(IJK7)=VN(IJK7)+2*(F(LR,1,KU)*CLON(L,7) - & -F(LI,1,KU)*SLON(L,7)) - US(IJK1)=US(IJK1)-2*(F(LR,2,KU)*CLON(L,5) - & -F(LI,2,KU)*SLON(L,5)) - VS(IJK1)=VS(IJK1)-2*(F(LR,2,KV)*CLON(L,5) - & -F(LI,2,KV)*SLON(L,5)) - US(IJK3)=US(IJK3)-2*(F(LR,2,KV)*CLON(L,3) - & -F(LI,2,KV)*SLON(L,3)) - VS(IJK3)=VS(IJK3)+2*(F(LR,2,KU)*CLON(L,3) - & -F(LI,2,KU)*SLON(L,3)) - US(IJK5)=US(IJK5)+2*(F(LR,2,KU)*CLON(L,1) - & -F(LI,2,KU)*SLON(L,1)) - VS(IJK5)=VS(IJK5)+2*(F(LR,2,KV)*CLON(L,1) - & -F(LI,2,KV)*SLON(L,1)) - US(IJK7)=US(IJK7)+2*(F(LR,2,KV)*CLON(L,7) - & -F(LI,2,KV)*SLON(L,7)) - VS(IJK7)=VS(IJK7)-2*(F(LR,2,KU)*CLON(L,7) - & -F(LI,2,KU)*SLON(L,7)) - ENDDO - ENDDO - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE POINTS ON THE MAIN DIAGONALS THROUGH THE POLE, -C STARTING CLOCKWISE OF THE ORIENTATION LONGITUDE AND GOING CLOCKWISE. -C$OMP PARALLEL DO PRIVATE(I1,J2,I2,J3,I3,J4,I4,J5,I5,J6,I6,J7,I7,J8,I8) -C$OMP& PRIVATE(IJ1,IJ2,IJ3,IJ4,IJ5,IJ6,IJ7,IJ8) -C$OMP& PRIVATE(IJK1,IJK2,IJK3,IJK4,IJK5,IJK6,IJK7,IJK8) -C$OMP& PRIVATE(DJ1,DI1,RQ,RR,RADLON,RADLON1,RADLON2,SLAT1,CLAT1) -C$OMP& PRIVATE(PLN,PLNTOP,F,SLON,CLON,KU,KV,LR,LI) - DO J1=1,NPH - I1=J1 - RADLON=(ORIENT-45)/DPR - J3=NPS+1-I1 - I3=J1 - J5=NPS+1-J1 - I5=NPS+1-I1 - J7=I1 - I7=NPS+1-J1 - IJ1=(I1-1)*NI+(J1-1)*NJ+1 - IJ3=(I3-1)*NI+(J3-1)*NJ+1 - IJ5=(I5-1)*NI+(J5-1)*NJ+1 - IJ7=(I7-1)*NI+(J7-1)*NJ+1 - DI1=I1-NPH-1 - DJ1=J1-NPH-1 - RQ=DI1**2+DJ1**2 - SLAT1=(GQ-RQ)/(GQ+RQ) - CLAT1=SQRT(1.-SLAT1**2) - CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP, - & PLN,PLNTOP) - CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,MDIM,2*MXTOP,2*KMAX, - & CLAT1,PLN,PLNTOP,MP,W,WTOP,F) - DO L=1,MAXWV - SLON(L,1)=SIN(L*RADLON) - CLON(L,1)=COS(L*RADLON) - SLON(L,3)=SLON(L,1)*CROT(MOD(1*L,4)) - & -CLON(L,1)*SROT(MOD(1*L,4)) - CLON(L,3)=CLON(L,1)*CROT(MOD(1*L,4)) - & +SLON(L,1)*SROT(MOD(1*L,4)) - SLON(L,5)=SLON(L,1)*CROT(MOD(2*L,4)) - & -CLON(L,1)*SROT(MOD(2*L,4)) - CLON(L,5)=CLON(L,1)*CROT(MOD(2*L,4)) - & +SLON(L,1)*SROT(MOD(2*L,4)) - SLON(L,7)=SLON(L,1)*CROT(MOD(3*L,4)) - & -CLON(L,1)*SROT(MOD(3*L,4)) - CLON(L,7)=CLON(L,1)*CROT(MOD(3*L,4)) - & +SLON(L,1)*SROT(MOD(3*L,4)) - ENDDO -CDIR$ IVDEP - DO K=1,KMAX - KU=K - KV=K+KMAX - IJK1=IJ1+(K-1)*KG - IJK3=IJ3+(K-1)*KG - IJK5=IJ5+(K-1)*KG - IJK7=IJ7+(K-1)*KG - UN(IJK1)=SRH*( F(1,1,KU)+F(1,1,KV)) - VN(IJK1)=SRH*(-F(1,1,KU)+F(1,1,KV)) - UN(IJK3)=SRH*(-F(1,1,KU)+F(1,1,KV)) - VN(IJK3)=SRH*(-F(1,1,KU)-F(1,1,KV)) - UN(IJK5)=SRH*(-F(1,1,KU)-F(1,1,KV)) - VN(IJK5)=SRH*( F(1,1,KU)-F(1,1,KV)) - UN(IJK7)=SRH*( F(1,1,KU)-F(1,1,KV)) - VN(IJK7)=SRH*( F(1,1,KU)+F(1,1,KV)) - US(IJK1)=SRH*(-F(1,2,KU)-F(1,2,KV)) - VS(IJK1)=SRH*( F(1,2,KU)-F(1,2,KV)) - US(IJK3)=SRH*( F(1,2,KU)-F(1,2,KV)) - VS(IJK3)=SRH*( F(1,2,KU)+F(1,2,KV)) - US(IJK5)=SRH*( F(1,2,KU)+F(1,2,KV)) - VS(IJK5)=SRH*(-F(1,2,KU)+F(1,2,KV)) - US(IJK7)=SRH*(-F(1,2,KU)+F(1,2,KV)) - VS(IJK7)=SRH*(-F(1,2,KU)-F(1,2,KV)) - ENDDO - IF(KMAX.EQ.1) THEN - KU=1 - KV=2 - DO L=1,MAXWV - LR=2*L+1 - LI=2*L+2 - UN(IJ1)=UN(IJ1)+2*SRH*(( F(LR,1,KU)+F(LR,1,KV)) - & *CLON(L,1) - & -( F(LI,1,KU)+F(LI,1,KV)) - & *SLON(L,1)) - VN(IJ1)=VN(IJ1)+2*SRH*((-F(LR,1,KU)+F(LR,1,KV)) - & *CLON(L,1) - & -(-F(LI,1,KU)+F(LI,1,KV)) - & *SLON(L,1)) - UN(IJ3)=UN(IJ3)+2*SRH*((-F(LR,1,KU)+F(LR,1,KV)) - & *CLON(L,3) - & -(-F(LI,1,KU)+F(LI,1,KV)) - & *SLON(L,3)) - VN(IJ3)=VN(IJ3)+2*SRH*((-F(LR,1,KU)-F(LR,1,KV)) - & *CLON(L,3) - & -(-F(LI,1,KU)-F(LI,1,KV)) - & *SLON(L,3)) - UN(IJ5)=UN(IJ5)+2*SRH*((-F(LR,1,KU)-F(LR,1,KV)) - & *CLON(L,5) - & -(-F(LI,1,KU)-F(LI,1,KV)) - & *SLON(L,5)) - VN(IJ5)=VN(IJ5)+2*SRH*(( F(LR,1,KU)-F(LR,1,KV)) - & *CLON(L,5) - & -( F(LI,1,KU)-F(LI,1,KV)) - & *SLON(L,5)) - UN(IJ7)=UN(IJ7)+2*SRH*(( F(LR,1,KU)-F(LR,1,KV)) - & *CLON(L,7) - & -( F(LI,1,KU)-F(LI,1,KV)) - & *SLON(L,7)) - VN(IJ7)=VN(IJ7)+2*SRH*(( F(LR,1,KU)+F(LR,1,KV)) - & *CLON(L,7) - & -( F(LI,1,KU)+F(LI,1,KV)) - & *SLON(L,7)) - US(IJ1)=US(IJ1)+2*SRH*((-F(LR,2,KU)-F(LR,2,KV)) - & *CLON(L,3) - & -(-F(LI,2,KU)-F(LI,2,KV)) - & *SLON(L,3)) - VS(IJ1)=VS(IJ1)+2*SRH*(( F(LR,2,KU)-F(LR,2,KV)) - & *CLON(L,3) - & -( F(LI,2,KU)-F(LI,2,KV)) - & *SLON(L,3)) - US(IJ3)=US(IJ3)+2*SRH*(( F(LR,2,KU)-F(LR,2,KV)) - & *CLON(L,1) - & -( F(LI,2,KU)-F(LI,2,KV)) - & *SLON(L,1)) - VS(IJ3)=VS(IJ3)+2*SRH*(( F(LR,2,KU)+F(LR,2,KV)) - & *CLON(L,1) - & -( F(LI,2,KU)+F(LI,2,KV)) - & *SLON(L,1)) - US(IJ5)=US(IJ5)+2*SRH*(( F(LR,2,KU)+F(LR,2,KV)) - & *CLON(L,7) - & -( F(LI,2,KU)+F(LI,2,KV)) - & *SLON(L,7)) - VS(IJ5)=VS(IJ5)+2*SRH*((-F(LR,2,KU)+F(LR,2,KV)) - & *CLON(L,7) - & -(-F(LI,2,KU)+F(LI,2,KV)) - & *SLON(L,7)) - US(IJ7)=US(IJ7)+2*SRH*((-F(LR,2,KU)+F(LR,2,KV)) - & *CLON(L,5) - & -(-F(LI,2,KU)+F(LI,2,KV)) - & *SLON(L,5)) - VS(IJ7)=VS(IJ7)+2*SRH*((-F(LR,2,KU)-F(LR,2,KV)) - & *CLON(L,5) - & -(-F(LI,2,KU)-F(LI,2,KV)) - & *SLON(L,5)) - ENDDO - ELSE - DO L=1,MAXWV - LR=2*L+1 - LI=2*L+2 -CDIR$ IVDEP - DO K=1,KMAX - KU=K - KV=K+KMAX - IJK1=IJ1+(K-1)*KG - IJK3=IJ3+(K-1)*KG - IJK5=IJ5+(K-1)*KG - IJK7=IJ7+(K-1)*KG - UN(IJK1)=UN(IJK1)+2*SRH*(( F(LR,1,KU)+F(LR,1,KV)) - & *CLON(L,1) - & -( F(LI,1,KU)+F(LI,1,KV)) - & *SLON(L,1)) - VN(IJK1)=VN(IJK1)+2*SRH*((-F(LR,1,KU)+F(LR,1,KV)) - & *CLON(L,1) - & -(-F(LI,1,KU)+F(LI,1,KV)) - & *SLON(L,1)) - UN(IJK3)=UN(IJK3)+2*SRH*((-F(LR,1,KU)+F(LR,1,KV)) - & *CLON(L,3) - & -(-F(LI,1,KU)+F(LI,1,KV)) - & *SLON(L,3)) - VN(IJK3)=VN(IJK3)+2*SRH*((-F(LR,1,KU)-F(LR,1,KV)) - & *CLON(L,3) - & -(-F(LI,1,KU)-F(LI,1,KV)) - & *SLON(L,3)) - UN(IJK5)=UN(IJK5)+2*SRH*((-F(LR,1,KU)-F(LR,1,KV)) - & *CLON(L,5) - & -(-F(LI,1,KU)-F(LI,1,KV)) - & *SLON(L,5)) - VN(IJK5)=VN(IJK5)+2*SRH*(( F(LR,1,KU)-F(LR,1,KV)) - & *CLON(L,5) - & -( F(LI,1,KU)-F(LI,1,KV)) - & *SLON(L,5)) - UN(IJK7)=UN(IJK7)+2*SRH*(( F(LR,1,KU)-F(LR,1,KV)) - & *CLON(L,7) - & -( F(LI,1,KU)-F(LI,1,KV)) - & *SLON(L,7)) - VN(IJK7)=VN(IJK7)+2*SRH*(( F(LR,1,KU)+F(LR,1,KV)) - & *CLON(L,7) - & -( F(LI,1,KU)+F(LI,1,KV)) - & *SLON(L,7)) - US(IJK1)=US(IJK1)+2*SRH*((-F(LR,2,KU)-F(LR,2,KV)) - & *CLON(L,3) - & -(-F(LI,2,KU)-F(LI,2,KV)) - & *SLON(L,3)) - VS(IJK1)=VS(IJK1)+2*SRH*(( F(LR,2,KU)-F(LR,2,KV)) - & *CLON(L,3) - & -( F(LI,2,KU)-F(LI,2,KV)) - & *SLON(L,3)) - US(IJK3)=US(IJK3)+2*SRH*(( F(LR,2,KU)-F(LR,2,KV)) - & *CLON(L,1) - & -( F(LI,2,KU)-F(LI,2,KV)) - & *SLON(L,1)) - VS(IJK3)=VS(IJK3)+2*SRH*(( F(LR,2,KU)+F(LR,2,KV)) - & *CLON(L,1) - & -( F(LI,2,KU)+F(LI,2,KV)) - & *SLON(L,1)) - US(IJK5)=US(IJK5)+2*SRH*(( F(LR,2,KU)+F(LR,2,KV)) - & *CLON(L,7) - & -( F(LI,2,KU)+F(LI,2,KV)) - & *SLON(L,7)) - VS(IJK5)=VS(IJK5)+2*SRH*((-F(LR,2,KU)+F(LR,2,KV)) - & *CLON(L,7) - & -(-F(LI,2,KU)+F(LI,2,KV)) - & *SLON(L,7)) - US(IJK7)=US(IJK7)+2*SRH*((-F(LR,2,KU)+F(LR,2,KV)) - & *CLON(L,5) - & -(-F(LI,2,KU)+F(LI,2,KV)) - & *SLON(L,5)) - VS(IJK7)=VS(IJK7)+2*SRH*((-F(LR,2,KU)-F(LR,2,KV)) - & *CLON(L,5) - & -(-F(LI,2,KU)-F(LI,2,KV)) - & *SLON(L,5)) - ENDDO - ENDDO - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE THE REMAINDER OF THE POLAR STEREOGRAPHIC DOMAIN, -C STARTING AT THE SECTOR JUST CLOCKWISE OF THE ORIENTATION LONGITUDE -C AND GOING CLOCKWISE UNTIL ALL EIGHT SECTORS ARE DONE. -C$OMP PARALLEL DO PRIVATE(I1,J2,I2,J3,I3,J4,I4,J5,I5,J6,I6,J7,I7,J8,I8) -C$OMP& PRIVATE(IJ1,IJ2,IJ3,IJ4,IJ5,IJ6,IJ7,IJ8) -C$OMP& PRIVATE(IJK1,IJK2,IJK3,IJK4,IJK5,IJK6,IJK7,IJK8) -C$OMP& PRIVATE(DJ1,DI1,RQ,RR,RADLON,RADLON1,RADLON2,SLAT1,CLAT1) -C$OMP& PRIVATE(PLN,PLNTOP,F,SLON,CLON,KU,KV,LR,LI) - DO J1=1,NPH-1 - DO I1=J1+1,NPH - J2=I1 - I2=J1 - J3=NPS+1-I1 - I3=J1 - J4=NPS+1-J1 - I4=I1 - J5=NPS+1-J1 - I5=NPS+1-I1 - J6=NPS+1-I1 - I6=NPS+1-J1 - J7=I1 - I7=NPS+1-J1 - J8=J1 - I8=NPS+1-I1 - IJ1=(I1-1)*NI+(J1-1)*NJ+1 - IJ2=(I2-1)*NI+(J2-1)*NJ+1 - IJ3=(I3-1)*NI+(J3-1)*NJ+1 - IJ4=(I4-1)*NI+(J4-1)*NJ+1 - IJ5=(I5-1)*NI+(J5-1)*NJ+1 - IJ6=(I6-1)*NI+(J6-1)*NJ+1 - IJ7=(I7-1)*NI+(J7-1)*NJ+1 - IJ8=(I8-1)*NI+(J8-1)*NJ+1 - DI1=I1-NPH-1 - DJ1=J1-NPH-1 - RQ=DI1**2+DJ1**2 - RR=SQRT(1/RQ) - SLAT1=(GQ-RQ)/(GQ+RQ) - CLAT1=SQRT(1.-SLAT1**2) - RADLON1=ORIENT/DPR+ATAN(-DI1/DJ1) - RADLON2=(ORIENT-45)/DPR*2-RADLON1 - CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP, - & PLN,PLNTOP) - CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,MDIM,2*MXTOP,2*KMAX, - & CLAT1,PLN,PLNTOP,MP,W,WTOP,F) - DO L=1,MAXWV - SLON(L,1)=SIN(L*RADLON1) - CLON(L,1)=COS(L*RADLON1) - SLON(L,2)=SIN(L*RADLON2) - CLON(L,2)=COS(L*RADLON2) - SLON(L,3)=SLON(L,1)*CROT(MOD(1*L,4)) - & -CLON(L,1)*SROT(MOD(1*L,4)) - CLON(L,3)=CLON(L,1)*CROT(MOD(1*L,4)) - & +SLON(L,1)*SROT(MOD(1*L,4)) - SLON(L,4)=SLON(L,2)*CROT(MOD(1*L,4)) - & -CLON(L,2)*SROT(MOD(1*L,4)) - CLON(L,4)=CLON(L,2)*CROT(MOD(1*L,4)) - & +SLON(L,2)*SROT(MOD(1*L,4)) - SLON(L,5)=SLON(L,1)*CROT(MOD(2*L,4)) - & -CLON(L,1)*SROT(MOD(2*L,4)) - CLON(L,5)=CLON(L,1)*CROT(MOD(2*L,4)) - & +SLON(L,1)*SROT(MOD(2*L,4)) - SLON(L,6)=SLON(L,2)*CROT(MOD(2*L,4)) - & -CLON(L,2)*SROT(MOD(2*L,4)) - CLON(L,6)=CLON(L,2)*CROT(MOD(2*L,4)) - & +SLON(L,2)*SROT(MOD(2*L,4)) - SLON(L,7)=SLON(L,1)*CROT(MOD(3*L,4)) - & -CLON(L,1)*SROT(MOD(3*L,4)) - CLON(L,7)=CLON(L,1)*CROT(MOD(3*L,4)) - & +SLON(L,1)*SROT(MOD(3*L,4)) - SLON(L,8)=SLON(L,2)*CROT(MOD(3*L,4)) - & -CLON(L,2)*SROT(MOD(3*L,4)) - CLON(L,8)=CLON(L,2)*CROT(MOD(3*L,4)) - & +SLON(L,2)*SROT(MOD(3*L,4)) - ENDDO -CDIR$ IVDEP - DO K=1,KMAX - KU=K - KV=K+KMAX - IJK1=IJ1+(K-1)*KG - IJK2=IJ2+(K-1)*KG - IJK3=IJ3+(K-1)*KG - IJK4=IJ4+(K-1)*KG - IJK5=IJ5+(K-1)*KG - IJK6=IJ6+(K-1)*KG - IJK7=IJ7+(K-1)*KG - IJK8=IJ8+(K-1)*KG - UN(IJK1)=RR*(-DJ1*F(1,1,KU)-DI1*F(1,1,KV)) - VN(IJK1)=RR*( DI1*F(1,1,KU)-DJ1*F(1,1,KV)) - UN(IJK2)=RR*(-DI1*F(1,1,KU)-DJ1*F(1,1,KV)) - VN(IJK2)=RR*( DJ1*F(1,1,KU)-DI1*F(1,1,KV)) - UN(IJK3)=RR*( DI1*F(1,1,KU)-DJ1*F(1,1,KV)) - VN(IJK3)=RR*( DJ1*F(1,1,KU)+DI1*F(1,1,KV)) - UN(IJK4)=RR*( DJ1*F(1,1,KU)-DI1*F(1,1,KV)) - VN(IJK4)=RR*( DI1*F(1,1,KU)+DJ1*F(1,1,KV)) - UN(IJK5)=RR*( DJ1*F(1,1,KU)+DI1*F(1,1,KV)) - VN(IJK5)=RR*(-DI1*F(1,1,KU)+DJ1*F(1,1,KV)) - UN(IJK6)=RR*( DI1*F(1,1,KU)+DJ1*F(1,1,KV)) - VN(IJK6)=RR*(-DJ1*F(1,1,KU)+DI1*F(1,1,KV)) - UN(IJK7)=RR*(-DI1*F(1,1,KU)+DJ1*F(1,1,KV)) - VN(IJK7)=RR*(-DJ1*F(1,1,KU)-DI1*F(1,1,KV)) - UN(IJK8)=RR*(-DJ1*F(1,1,KU)+DI1*F(1,1,KV)) - VN(IJK8)=RR*(-DI1*F(1,1,KU)-DJ1*F(1,1,KV)) - US(IJK1)=RR*( DJ1*F(1,2,KU)+DI1*F(1,2,KV)) - VS(IJK1)=RR*(-DI1*F(1,2,KU)+DJ1*F(1,2,KV)) - US(IJK2)=RR*( DI1*F(1,2,KU)+DJ1*F(1,2,KV)) - VS(IJK2)=RR*(-DJ1*F(1,2,KU)+DI1*F(1,2,KV)) - US(IJK3)=RR*(-DI1*F(1,2,KU)+DJ1*F(1,2,KV)) - VS(IJK3)=RR*(-DJ1*F(1,2,KU)-DI1*F(1,2,KV)) - US(IJK4)=RR*(-DJ1*F(1,2,KU)+DI1*F(1,2,KV)) - VS(IJK4)=RR*(-DI1*F(1,2,KU)-DJ1*F(1,2,KV)) - US(IJK5)=RR*(-DJ1*F(1,2,KU)-DI1*F(1,2,KV)) - VS(IJK5)=RR*( DI1*F(1,2,KU)-DJ1*F(1,2,KV)) - US(IJK6)=RR*(-DI1*F(1,2,KU)-DJ1*F(1,2,KV)) - VS(IJK6)=RR*( DJ1*F(1,2,KU)-DI1*F(1,2,KV)) - US(IJK7)=RR*( DI1*F(1,2,KU)-DJ1*F(1,2,KV)) - VS(IJK7)=RR*( DJ1*F(1,2,KU)+DI1*F(1,2,KV)) - US(IJK8)=RR*( DJ1*F(1,2,KU)-DI1*F(1,2,KV)) - VS(IJK8)=RR*( DI1*F(1,2,KU)+DJ1*F(1,2,KV)) - ENDDO - IF(KMAX.EQ.1) THEN - KU=1 - KV=2 - DO L=1,MAXWV - LR=2*L+1 - LI=2*L+2 - UN(IJ1)=UN(IJ1)+2*RR*((-DJ1*F(LR,1,KU)-DI1*F(LR,1,KV)) - & *CLON(L,1) - & -(-DJ1*F(LI,1,KU)-DI1*F(LI,1,KV)) - & *SLON(L,1)) - VN(IJ1)=VN(IJ1)+2*RR*(( DI1*F(LR,1,KU)-DJ1*F(LR,1,KV)) - & *CLON(L,1) - & -( DI1*F(LI,1,KU)-DJ1*F(LI,1,KV)) - & *SLON(L,1)) - UN(IJ2)=UN(IJ2)+2*RR*((-DI1*F(LR,1,KU)-DJ1*F(LR,1,KV)) - & *CLON(L,2) - & -(-DI1*F(LI,1,KU)-DJ1*F(LI,1,KV)) - & *SLON(L,2)) - VN(IJ2)=VN(IJ2)+2*RR*(( DJ1*F(LR,1,KU)-DI1*F(LR,1,KV)) - & *CLON(L,2) - & -( DJ1*F(LI,1,KU)-DI1*F(LI,1,KV)) - & *SLON(L,2)) - UN(IJ3)=UN(IJ3)+2*RR*(( DI1*F(LR,1,KU)-DJ1*F(LR,1,KV)) - & *CLON(L,3) - & -( DI1*F(LI,1,KU)-DJ1*F(LI,1,KV)) - & *SLON(L,3)) - VN(IJ3)=VN(IJ3)+2*RR*(( DJ1*F(LR,1,KU)+DI1*F(LR,1,KV)) - & *CLON(L,3) - & -( DJ1*F(LI,1,KU)+DI1*F(LI,1,KV)) - & *SLON(L,3)) - UN(IJ4)=UN(IJ4)+2*RR*(( DJ1*F(LR,1,KU)-DI1*F(LR,1,KV)) - & *CLON(L,4) - & -( DJ1*F(LI,1,KU)-DI1*F(LI,1,KV)) - & *SLON(L,4)) - VN(IJ4)=VN(IJ4)+2*RR*(( DI1*F(LR,1,KU)+DJ1*F(LR,1,KV)) - & *CLON(L,4) - & -( DI1*F(LI,1,KU)+DJ1*F(LI,1,KV)) - & *SLON(L,4)) - UN(IJ5)=UN(IJ5)+2*RR*(( DJ1*F(LR,1,KU)+DI1*F(LR,1,KV)) - & *CLON(L,5) - & -( DJ1*F(LI,1,KU)+DI1*F(LI,1,KV)) - & *SLON(L,5)) - VN(IJ5)=VN(IJ5)+2*RR*((-DI1*F(LR,1,KU)+DJ1*F(LR,1,KV)) - & *CLON(L,5) - & -(-DI1*F(LI,1,KU)+DJ1*F(LI,1,KV)) - & *SLON(L,5)) - UN(IJ6)=UN(IJ6)+2*RR*(( DI1*F(LR,1,KU)+DJ1*F(LR,1,KV)) - & *CLON(L,6) - & -( DI1*F(LI,1,KU)+DJ1*F(LI,1,KV)) - & *SLON(L,6)) - VN(IJ6)=VN(IJ6)+2*RR*((-DJ1*F(LR,1,KU)+DI1*F(LR,1,KV)) - & *CLON(L,6) - & -(-DJ1*F(LI,1,KU)+DI1*F(LI,1,KV)) - & *SLON(L,6)) - UN(IJ7)=UN(IJ7)+2*RR*((-DI1*F(LR,1,KU)+DJ1*F(LR,1,KV)) - & *CLON(L,7) - & -(-DI1*F(LI,1,KU)+DJ1*F(LI,1,KV)) - & *SLON(L,7)) - VN(IJ7)=VN(IJ7)+2*RR*((-DJ1*F(LR,1,KU)-DI1*F(LR,1,KV)) - & *CLON(L,7) - & -(-DJ1*F(LI,1,KU)-DI1*F(LI,1,KV)) - & *SLON(L,7)) - UN(IJ8)=UN(IJ8)+2*RR*((-DJ1*F(LR,1,KU)+DI1*F(LR,1,KV)) - & *CLON(L,8) - & -(-DJ1*F(LI,1,KU)+DI1*F(LI,1,KV)) - & *SLON(L,8)) - VN(IJ8)=VN(IJ8)+2*RR*((-DI1*F(LR,1,KU)-DJ1*F(LR,1,KV)) - & *CLON(L,8) - & -(-DI1*F(LI,1,KU)-DJ1*F(LI,1,KV)) - & *SLON(L,8)) - US(IJ1)=US(IJ1)+2*RR*(( DJ1*F(LR,2,KU)+DI1*F(LR,2,KV)) - & *CLON(L,4) - & -( DJ1*F(LI,2,KU)+DI1*F(LI,2,KV)) - & *SLON(L,4)) - VS(IJ1)=VS(IJ1)+2*RR*((-DI1*F(LR,2,KU)+DJ1*F(LR,2,KV)) - & *CLON(L,4) - & -(-DI1*F(LI,2,KU)+DJ1*F(LI,2,KV)) - & *SLON(L,4)) - US(IJ2)=US(IJ2)+2*RR*(( DI1*F(LR,2,KU)+DJ1*F(LR,2,KV)) - & *CLON(L,3) - & -( DI1*F(LI,2,KU)+DJ1*F(LI,2,KV)) - & *SLON(L,3)) - VS(IJ2)=VS(IJ2)+2*RR*((-DJ1*F(LR,2,KU)+DI1*F(LR,2,KV)) - & *CLON(L,3) - & -(-DJ1*F(LI,2,KU)+DI1*F(LI,2,KV)) - & *SLON(L,3)) - US(IJ3)=US(IJ3)+2*RR*((-DI1*F(LR,2,KU)+DJ1*F(LR,2,KV)) - & *CLON(L,2) - & -(-DI1*F(LI,2,KU)+DJ1*F(LI,2,KV)) - & *SLON(L,2)) - VS(IJ3)=VS(IJ3)+2*RR*((-DJ1*F(LR,2,KU)-DI1*F(LR,2,KV)) - & *CLON(L,2) - & -(-DJ1*F(LI,2,KU)-DI1*F(LI,2,KV)) - & *SLON(L,2)) - US(IJ4)=US(IJ4)+2*RR*((-DJ1*F(LR,2,KU)+DI1*F(LR,2,KV)) - & *CLON(L,1) - & -(-DJ1*F(LI,2,KU)+DI1*F(LI,2,KV)) - & *SLON(L,1)) - VS(IJ4)=VS(IJ4)+2*RR*((-DI1*F(LR,2,KU)-DJ1*F(LR,2,KV)) - & *CLON(L,1) - & -(-DI1*F(LI,2,KU)-DJ1*F(LI,2,KV)) - & *SLON(L,1)) - US(IJ5)=US(IJ5)+2*RR*((-DJ1*F(LR,2,KU)-DI1*F(LR,2,KV)) - & *CLON(L,8) - & -(-DJ1*F(LI,2,KU)-DI1*F(LI,2,KV)) - & *SLON(L,8)) - VS(IJ5)=VS(IJ5)+2*RR*(( DI1*F(LR,2,KU)-DJ1*F(LR,2,KV)) - & *CLON(L,8) - & -( DI1*F(LI,2,KU)-DJ1*F(LI,2,KV)) - & *SLON(L,8)) - US(IJ6)=US(IJ6)+2*RR*((-DI1*F(LR,2,KU)-DJ1*F(LR,2,KV)) - & *CLON(L,7) - & -(-DI1*F(LI,2,KU)-DJ1*F(LI,2,KV)) - & *SLON(L,7)) - VS(IJ6)=VS(IJ6)+2*RR*(( DJ1*F(LR,2,KU)-DI1*F(LR,2,KV)) - & *CLON(L,7) - & -( DJ1*F(LI,2,KU)-DI1*F(LI,2,KV)) - & *SLON(L,7)) - US(IJ7)=US(IJ7)+2*RR*(( DI1*F(LR,2,KU)-DJ1*F(LR,2,KV)) - & *CLON(L,6) - & -( DI1*F(LI,2,KU)-DJ1*F(LI,2,KV)) - & *SLON(L,6)) - VS(IJ7)=VS(IJ7)+2*RR*(( DJ1*F(LR,2,KU)+DI1*F(LR,2,KV)) - & *CLON(L,6) - & -( DJ1*F(LI,2,KU)+DI1*F(LI,2,KV)) - & *SLON(L,6)) - US(IJ8)=US(IJ8)+2*RR*(( DJ1*F(LR,2,KU)-DI1*F(LR,2,KV)) - & *CLON(L,5) - & -( DJ1*F(LI,2,KU)-DI1*F(LI,2,KV)) - & *SLON(L,5)) - VS(IJ8)=VS(IJ8)+2*RR*(( DI1*F(LR,2,KU)+DJ1*F(LR,2,KV)) - & *CLON(L,5) - & -( DI1*F(LI,2,KU)+DJ1*F(LI,2,KV)) - & *SLON(L,5)) - ENDDO - ELSE - DO L=1,MAXWV - LR=2*L+1 - LI=2*L+2 -CDIR$ IVDEP - DO K=1,KMAX - KU=K - KV=K+KMAX - IJK1=IJ1+(K-1)*KG - IJK2=IJ2+(K-1)*KG - IJK3=IJ3+(K-1)*KG - IJK4=IJ4+(K-1)*KG - IJK5=IJ5+(K-1)*KG - IJK6=IJ6+(K-1)*KG - IJK7=IJ7+(K-1)*KG - IJK8=IJ8+(K-1)*KG - UN(IJK1)=UN(IJK1)+2*RR*((-DJ1*F(LR,1,KU)-DI1*F(LR,1,KV)) - & *CLON(L,1) - & -(-DJ1*F(LI,1,KU)-DI1*F(LI,1,KV)) - & *SLON(L,1)) - VN(IJK1)=VN(IJK1)+2*RR*(( DI1*F(LR,1,KU)-DJ1*F(LR,1,KV)) - & *CLON(L,1) - & -( DI1*F(LI,1,KU)-DJ1*F(LI,1,KV)) - & *SLON(L,1)) - UN(IJK2)=UN(IJK2)+2*RR*((-DI1*F(LR,1,KU)-DJ1*F(LR,1,KV)) - & *CLON(L,2) - & -(-DI1*F(LI,1,KU)-DJ1*F(LI,1,KV)) - & *SLON(L,2)) - VN(IJK2)=VN(IJK2)+2*RR*(( DJ1*F(LR,1,KU)-DI1*F(LR,1,KV)) - & *CLON(L,2) - & -( DJ1*F(LI,1,KU)-DI1*F(LI,1,KV)) - & *SLON(L,2)) - UN(IJK3)=UN(IJK3)+2*RR*(( DI1*F(LR,1,KU)-DJ1*F(LR,1,KV)) - & *CLON(L,3) - & -( DI1*F(LI,1,KU)-DJ1*F(LI,1,KV)) - & *SLON(L,3)) - VN(IJK3)=VN(IJK3)+2*RR*(( DJ1*F(LR,1,KU)+DI1*F(LR,1,KV)) - & *CLON(L,3) - & -( DJ1*F(LI,1,KU)+DI1*F(LI,1,KV)) - & *SLON(L,3)) - UN(IJK4)=UN(IJK4)+2*RR*(( DJ1*F(LR,1,KU)-DI1*F(LR,1,KV)) - & *CLON(L,4) - & -( DJ1*F(LI,1,KU)-DI1*F(LI,1,KV)) - & *SLON(L,4)) - VN(IJK4)=VN(IJK4)+2*RR*(( DI1*F(LR,1,KU)+DJ1*F(LR,1,KV)) - & *CLON(L,4) - & -( DI1*F(LI,1,KU)+DJ1*F(LI,1,KV)) - & *SLON(L,4)) - UN(IJK5)=UN(IJK5)+2*RR*(( DJ1*F(LR,1,KU)+DI1*F(LR,1,KV)) - & *CLON(L,5) - & -( DJ1*F(LI,1,KU)+DI1*F(LI,1,KV)) - & *SLON(L,5)) - VN(IJK5)=VN(IJK5)+2*RR*((-DI1*F(LR,1,KU)+DJ1*F(LR,1,KV)) - & *CLON(L,5) - & -(-DI1*F(LI,1,KU)+DJ1*F(LI,1,KV)) - & *SLON(L,5)) - UN(IJK6)=UN(IJK6)+2*RR*(( DI1*F(LR,1,KU)+DJ1*F(LR,1,KV)) - & *CLON(L,6) - & -( DI1*F(LI,1,KU)+DJ1*F(LI,1,KV)) - & *SLON(L,6)) - VN(IJK6)=VN(IJK6)+2*RR*((-DJ1*F(LR,1,KU)+DI1*F(LR,1,KV)) - & *CLON(L,6) - & -(-DJ1*F(LI,1,KU)+DI1*F(LI,1,KV)) - & *SLON(L,6)) - UN(IJK7)=UN(IJK7)+2*RR*((-DI1*F(LR,1,KU)+DJ1*F(LR,1,KV)) - & *CLON(L,7) - & -(-DI1*F(LI,1,KU)+DJ1*F(LI,1,KV)) - & *SLON(L,7)) - VN(IJK7)=VN(IJK7)+2*RR*((-DJ1*F(LR,1,KU)-DI1*F(LR,1,KV)) - & *CLON(L,7) - & -(-DJ1*F(LI,1,KU)-DI1*F(LI,1,KV)) - & *SLON(L,7)) - UN(IJK8)=UN(IJK8)+2*RR*((-DJ1*F(LR,1,KU)+DI1*F(LR,1,KV)) - & *CLON(L,8) - & -(-DJ1*F(LI,1,KU)+DI1*F(LI,1,KV)) - & *SLON(L,8)) - VN(IJK8)=VN(IJK8)+2*RR*((-DI1*F(LR,1,KU)-DJ1*F(LR,1,KV)) - & *CLON(L,8) - & -(-DI1*F(LI,1,KU)-DJ1*F(LI,1,KV)) - & *SLON(L,8)) - US(IJK1)=US(IJK1)+2*RR*(( DJ1*F(LR,2,KU)+DI1*F(LR,2,KV)) - & *CLON(L,4) - & -( DJ1*F(LI,2,KU)+DI1*F(LI,2,KV)) - & *SLON(L,4)) - VS(IJK1)=VS(IJK1)+2*RR*((-DI1*F(LR,2,KU)+DJ1*F(LR,2,KV)) - & *CLON(L,4) - & -(-DI1*F(LI,2,KU)+DJ1*F(LI,2,KV)) - & *SLON(L,4)) - US(IJK2)=US(IJK2)+2*RR*(( DI1*F(LR,2,KU)+DJ1*F(LR,2,KV)) - & *CLON(L,3) - & -( DI1*F(LI,2,KU)+DJ1*F(LI,2,KV)) - & *SLON(L,3)) - VS(IJK2)=VS(IJK2)+2*RR*((-DJ1*F(LR,2,KU)+DI1*F(LR,2,KV)) - & *CLON(L,3) - & -(-DJ1*F(LI,2,KU)+DI1*F(LI,2,KV)) - & *SLON(L,3)) - US(IJK3)=US(IJK3)+2*RR*((-DI1*F(LR,2,KU)+DJ1*F(LR,2,KV)) - & *CLON(L,2) - & -(-DI1*F(LI,2,KU)+DJ1*F(LI,2,KV)) - & *SLON(L,2)) - VS(IJK3)=VS(IJK3)+2*RR*((-DJ1*F(LR,2,KU)-DI1*F(LR,2,KV)) - & *CLON(L,2) - & -(-DJ1*F(LI,2,KU)-DI1*F(LI,2,KV)) - & *SLON(L,2)) - US(IJK4)=US(IJK4)+2*RR*((-DJ1*F(LR,2,KU)+DI1*F(LR,2,KV)) - & *CLON(L,1) - & -(-DJ1*F(LI,2,KU)+DI1*F(LI,2,KV)) - & *SLON(L,1)) - VS(IJK4)=VS(IJK4)+2*RR*((-DI1*F(LR,2,KU)-DJ1*F(LR,2,KV)) - & *CLON(L,1) - & -(-DI1*F(LI,2,KU)-DJ1*F(LI,2,KV)) - & *SLON(L,1)) - US(IJK5)=US(IJK5)+2*RR*((-DJ1*F(LR,2,KU)-DI1*F(LR,2,KV)) - & *CLON(L,8) - & -(-DJ1*F(LI,2,KU)-DI1*F(LI,2,KV)) - & *SLON(L,8)) - VS(IJK5)=VS(IJK5)+2*RR*(( DI1*F(LR,2,KU)-DJ1*F(LR,2,KV)) - & *CLON(L,8) - & -( DI1*F(LI,2,KU)-DJ1*F(LI,2,KV)) - & *SLON(L,8)) - US(IJK6)=US(IJK6)+2*RR*((-DI1*F(LR,2,KU)-DJ1*F(LR,2,KV)) - & *CLON(L,7) - & -(-DI1*F(LI,2,KU)-DJ1*F(LI,2,KV)) - & *SLON(L,7)) - VS(IJK6)=VS(IJK6)+2*RR*(( DJ1*F(LR,2,KU)-DI1*F(LR,2,KV)) - & *CLON(L,7) - & -( DJ1*F(LI,2,KU)-DI1*F(LI,2,KV)) - & *SLON(L,7)) - US(IJK7)=US(IJK7)+2*RR*(( DI1*F(LR,2,KU)-DJ1*F(LR,2,KV)) - & *CLON(L,6) - & -( DI1*F(LI,2,KU)-DJ1*F(LI,2,KV)) - & *SLON(L,6)) - VS(IJK7)=VS(IJK7)+2*RR*(( DJ1*F(LR,2,KU)+DI1*F(LR,2,KV)) - & *CLON(L,6) - & -( DJ1*F(LI,2,KU)+DI1*F(LI,2,KV)) - & *SLON(L,6)) - US(IJK8)=US(IJK8)+2*RR*(( DJ1*F(LR,2,KU)-DI1*F(LR,2,KV)) - & *CLON(L,5) - & -( DJ1*F(LI,2,KU)-DI1*F(LI,2,KV)) - & *SLON(L,5)) - VS(IJK8)=VS(IJK8)+2*RR*(( DI1*F(LR,2,KU)+DJ1*F(LR,2,KV)) - & *CLON(L,5) - & -( DI1*F(LI,2,KU)+DJ1*F(LI,2,KV)) - & *SLON(L,5)) - ENDDO - ENDDO - ENDIF - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptgpt.f b/src/fim/FIMsrc/prep/sp/sptgpt.f deleted file mode 100644 index 56a74e0..0000000 --- a/src/fim/FIMsrc/prep/sp/sptgpt.f +++ /dev/null @@ -1,112 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTGPT(IROMB,MAXWV,KMAX,NMAX, - & KWSKIP,KGSKIP,NRSKIP,NGSKIP, - & RLAT,RLON,WAVE,GP) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPT TRANSFORM SPECTRAL SCALAR TO STATION POINTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF SCALAR QUANTITIES -C TO SPECIFIED SETS OF STATION POINTS ON THE GLOBE. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND POINT FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER STATIONS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C 2003-06-30 IREDELL USE SPFFTPT -C -C USAGE: CALL SPTGPT(IROMB,MAXWV,KMAX,NMAX, -C & KWSKIP,KGSKIP,NRSKIP,NGSKIP, -C & RLAT,RLON,WAVE,GP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NMAX - INTEGER NUMBER OF STATION POINTS TO RETURN -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINT SETS -C (DEFAULTS TO NMAX IF KGSKIP=0) -C NRSKIP - INTEGER SKIP NUMBER BETWEEN STATION LATS AND LONS -C (DEFAULTS TO 1 IF NRSKIP=0) -C NGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINTS -C (DEFAULTS TO 1 IF NGSKIP=0) -C RLAT - REAL (*) STATION LATITUDES IN DEGREES -C RLON - REAL (*) STATION LONGITUDES IN DEGREES -C WAVE - REAL (*) WAVE FIELDS -C OUTPUT ARGUMENTS: -C GP - REAL (*) STATION POINT SETS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C SPFFTPT POINTWISE FOURIER TRANSFORM -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL RLAT(*),RLON(*),WAVE(*),GP(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - INTEGER MP(KMAX) - REAL WTOP(2*(MAXWV+1),KMAX) - REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),PLNTOP(MAXWV+1) - REAL F(2*MAXWV+3,2,KMAX) - PARAMETER(PI=3.14159265358979) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE PRELIMINARY CONSTANTS - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MXTOP=MAXWV+1 - IDIM=2*MAXWV+3 - KW=KWSKIP - KG=KGSKIP - NR=NRSKIP - NG=NGSKIP - IF(KW.EQ.0) KW=2*MX - IF(KG.EQ.0) KG=NMAX - IF(NR.EQ.0) NR=1 - IF(NG.EQ.0) NG=1 - MP=0 -C$OMP PARALLEL DO - DO K=1,KMAX - WTOP(1:2*MXTOP,K)=0 - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE STATION FIELDS -C$OMP PARALLEL DO PRIVATE(RADLAT,SLAT1,CLAT1) -C$OMP& PRIVATE(PLN,PLNTOP,F,NK) - DO N=1,NMAX - RADLAT=PI/180*RLAT((N-1)*NR+1) - IF(RLAT((N-1)*NR+1).GE.89.9995) THEN - SLAT1=1. - CLAT1=0. - ELSEIF(RLAT((N-1)*NR+1).LE.-89.9995) THEN - SLAT1=-1. - CLAT1=0. - ELSE - SLAT1=SIN(RADLAT) - CLAT1=COS(RADLAT) - ENDIF - CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP, - & PLN,PLNTOP) - CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,KW,2*MXTOP,KMAX, - & CLAT1,PLN,PLNTOP,MP,WAVE,WTOP,F) - CALL SPFFTPT(MAXWV,1,2*MAXWV+3,KG,KMAX,RLON((N-1)*NR+1), - & F,GP((N-1)*NG+1)) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptgptd.f b/src/fim/FIMsrc/prep/sp/sptgptd.f deleted file mode 100644 index d8c8586..0000000 --- a/src/fim/FIMsrc/prep/sp/sptgptd.f +++ /dev/null @@ -1,83 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTGPTD(IROMB,MAXWV,KMAX,NMAX, - & KWSKIP,KGSKIP,NRSKIP,NGSKIP, - & RLAT,RLON,WAVE,XP,YP) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPTD TRANSFORM SPECTRAL TO STATION POINT GRADIENTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF SCALAR FIELDS -C TO SPECIFIED SETS OF STATION POINT GRADIENTS ON THE GLOBE. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND POINT FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER STATIONS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPTGPTD(IROMB,MAXWV,KMAX,NMAX, -C & KWSKIP,KGSKIP,NRSKIP,NGSKIP, -C & RLAT,RLON,WAVE,XP,YP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NMAX - INTEGER NUMBER OF STATION POINTS TO RETURN -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINT SETS -C (DEFAULTS TO NMAX IF KGSKIP=0) -C NRSKIP - INTEGER SKIP NUMBER BETWEEN STATION LATS AND LONS -C (DEFAULTS TO 1 IF NRSKIP=0) -C NGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINTS -C (DEFAULTS TO 1 IF NGSKIP=0) -C RLAT - REAL (*) STATION LATITUDES IN DEGREES -C RLON - REAL (*) STATION LONGITUDES IN DEGREES -C WAVE - REAL (*) WAVE FIELDS -C OUTPUT ARGUMENTS: -C XP - REAL (*) STATION POINT X-GRADIENT SETS -C YP - REAL (*) STATION POINT Y-GRADIENT SETS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTGPTV TRANSFORM SPECTRAL VECTOR TO STATION POINTS -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL RLAT(*),RLON(*),WAVE(*),XP(*),YP(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - REAL WD((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) - REAL WZ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE PRELIMINARY CONSTANTS - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MDIM=2*MX+1 - KW=KWSKIP - IF(KW.EQ.0) KW=2*MX -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE STATION FIELDS -C$OMP PARALLEL DO PRIVATE(KWS) - DO K=1,KMAX - KWS=(K-1)*KW - CALL SPLAPLAC(IROMB,MAXWV,ENN1,WAVE(KWS+1),WD(1,K),1) - WZ(1:2*MX,K)=0. - ENDDO - CALL SPTGPTV(IROMB,MAXWV,KMAX,NMAX,MDIM,KGSKIP,NRSKIP,NGSKIP, - & RLAT,RLON,WD,WZ,XP,YP) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptgptsd.f b/src/fim/FIMsrc/prep/sp/sptgptsd.f deleted file mode 100644 index a25bbe5..0000000 --- a/src/fim/FIMsrc/prep/sp/sptgptsd.f +++ /dev/null @@ -1,138 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTGPTSD(IROMB,MAXWV,KMAX,NMAX, - & KWSKIP,KGSKIP,NRSKIP,NGSKIP, - & RLAT,RLON,WAVE,GP,XP,YP) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPTSD TRANSFORM SPECTRAL SCALAR TO STATION POINTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF SCALAR QUANTITIES -C TO SPECIFIED SETS OF STATION POINT VALUES -C AND THEIR GRADIENTS ON THE GLOBE. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND POINT FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER STATIONS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C 1999-08-18 IREDELL OPENMP DIRECTIVE TYPO FIXED -C -C USAGE: CALL SPTGPTSD(IROMB,MAXWV,KMAX,NMAX, -C & KWSKIP,KGSKIP,NRSKIP,NGSKIP, -C & RLAT,RLON,WAVE,GP,XP,YP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NMAX - INTEGER NUMBER OF STATION POINTS TO RETURN -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINT SETS -C (DEFAULTS TO NMAX IF KGSKIP=0) -C NRSKIP - INTEGER SKIP NUMBER BETWEEN STATION LATS AND LONS -C (DEFAULTS TO 1 IF NRSKIP=0) -C NGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINTS -C (DEFAULTS TO 1 IF NGSKIP=0) -C RLAT - REAL (*) STATION LATITUDES IN DEGREES -C RLON - REAL (*) STATION LONGITUDES IN DEGREES -C WAVE - REAL (*) WAVE FIELDS -C OUTPUT ARGUMENTS: -C GP - REAL (*) STATION POINT SETS -C XP - REAL (*) STATION POINT X-GRADIENT SETS -C YP - REAL (*) STATION POINT Y-GRADIENT SETS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C SPGRADY COMPUTE Y-GRADIENT IN SPECTRAL SPACE -C SPGRADX COMPUTE X-GRADIENT IN FOURIER SPACE -C SPFFTPT COMPUTE FOURIER TRANSFORM TO GRIDPOINTS -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL RLAT(*),RLON(*),WAVE(*) - REAL GP(*),XP(*),YP(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - INTEGER MP(2*KMAX) - REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2,2*KMAX) - REAL WTOP(2*(MAXWV+1),2*KMAX) - REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),PLNTOP(MAXWV+1) - REAL F(2*MAXWV+2,2,3*KMAX),G(3*KMAX) - PARAMETER(PI=3.14159265358979) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE PRELIMINARY CONSTANTS - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MXTOP=MAXWV+1 - MDIM=2*MX - IDIM=2*MAXWV+2 - KW=KWSKIP - KG=KGSKIP - NR=NRSKIP - NG=NGSKIP - IF(KW.EQ.0) KW=2*MX - IF(KG.EQ.0) KG=NMAX - IF(NR.EQ.0) NR=1 - IF(NG.EQ.0) NG=1 - MP(1:KMAX)=10 - MP(KMAX+1:2*KMAX)=1 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE SPECTRAL WINDS -C$OMP PARALLEL DO PRIVATE(KWS,KS,KY) - DO K=1,KMAX - KWS=(K-1)*KW - KS=0*KMAX+K - KY=1*KMAX+K - DO I=1,2*MX - W(I,KS)=WAVE(KWS+I) - ENDDO - DO I=1,2*MXTOP - WTOP(I,KS)=0 - ENDDO - CALL SPGRADY(IROMB,MAXWV,ENN1,EON,EONTOP, - & WAVE(KWS+1),W(1,KY),WTOP(1,KY)) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE STATION FIELDS -C$OMP PARALLEL DO PRIVATE(KS,KY,KX,SLAT1,CLAT1) -C$OMP& PRIVATE(PLN,PLNTOP,F,G,NK) - DO N=1,NMAX - IF(ABS(RLAT((N-1)*NR+1)).GE.89.9995) THEN - SLAT1=SIGN(1.,RLAT((N-1)*NR+1)) - CLAT1=0. - ELSE - SLAT1=SIN(PI/180*RLAT((N-1)*NR+1)) - CLAT1=COS(PI/180*RLAT((N-1)*NR+1)) - ENDIF - CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP, - & PLN,PLNTOP) - CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,MDIM,2*MXTOP,2*KMAX, - & CLAT1,PLN,PLNTOP,MP,W,WTOP,F) - CALL SPGRADX(MAXWV,IDIM,KMAX,MP,CLAT1,F(1,1,1),F(1,1,2*KMAX+1)) - CALL SPFFTPT(MAXWV,1,IDIM,1,3*KMAX,RLON((N-1)*NR+1),F,G) - DO K=1,KMAX - KS=0*KMAX+K - KY=1*KMAX+K - KX=2*KMAX+K - NK=(N-1)*NG+(K-1)*KG+1 - GP(NK)=G(KS) - XP(NK)=G(KX) - YP(NK)=G(KY) - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptgptv.f b/src/fim/FIMsrc/prep/sp/sptgptv.f deleted file mode 100644 index db4ddbd..0000000 --- a/src/fim/FIMsrc/prep/sp/sptgptv.f +++ /dev/null @@ -1,130 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTGPTV(IROMB,MAXWV,KMAX,NMAX, - & KWSKIP,KGSKIP,NRSKIP,NGSKIP, - & RLAT,RLON,WAVED,WAVEZ,UP,VP) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPTV TRANSFORM SPECTRAL VECTOR TO STATION POINTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF DIVERGENCES AND CURLS -C TO SPECIFIED SETS OF STATION POINT VECTORS ON THE GLOBE. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND POINT FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER STATIONS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C 1999-08-18 IREDELL OPENMP DIRECTIVE TYPO FIXED -C 2003-06-30 IREDELL USE SPFFTPT -C -C USAGE: CALL SPTGPTV(IROMB,MAXWV,KMAX,NMAX, -C & KWSKIP,KGSKIP,NRSKIP,NGSKIP, -C & RLAT,RLON,WAVED,WAVEZ,UP,VP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NMAX - INTEGER NUMBER OF STATION POINTS TO RETURN -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINT SETS -C (DEFAULTS TO NMAX IF KGSKIP=0) -C NRSKIP - INTEGER SKIP NUMBER BETWEEN STATION LATS AND LONS -C (DEFAULTS TO 1 IF NRSKIP=0) -C NGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINTS -C (DEFAULTS TO 1 IF NGSKIP=0) -C RLAT - REAL (*) STATION LATITUDES IN DEGREES -C RLON - REAL (*) STATION LONGITUDES IN DEGREES -C WAVED - REAL (*) WAVE DIVERGENCE FIELDS -C WAVEZ - REAL (*) WAVE VORTICITY FIELDS -C OUTPUT ARGUMENTS: -C UP - REAL (*) STATION POINT U-WIND SETS -C VP - REAL (*) STATION POINT V-WIND SETS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C SPDZ2UV COMPUTE WINDS FROM DIVERGENCE AND VORTICITY -C SPFFTPT POINTWISE FOURIER TRANSFORM -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL RLAT(*),RLON(*),WAVED(*),WAVEZ(*),UP(*),VP(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - INTEGER MP(2*KMAX) - REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,2*KMAX) - REAL WTOP(2*(MAXWV+1),2*KMAX) - REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),PLNTOP(MAXWV+1) - REAL F(2*MAXWV+3,2,2*KMAX) - REAL G(2*KMAX) - PARAMETER(PI=3.14159265358979) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE PRELIMINARY CONSTANTS - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MXTOP=MAXWV+1 - MDIM=2*MX+1 - IDIM=2*MAXWV+3 - KW=KWSKIP - KG=KGSKIP - NR=NRSKIP - NG=NGSKIP - IF(KW.EQ.0) KW=2*MX - IF(KG.EQ.0) KG=NMAX - IF(NR.EQ.0) NR=1 - IF(NG.EQ.0) NG=1 - MP=1 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE SPECTRAL WINDS -C$OMP PARALLEL DO PRIVATE(KWS) - DO K=1,KMAX - KWS=(K-1)*KW - CALL SPDZ2UV(IROMB,MAXWV,ENN1,ELONN1,EON,EONTOP, - & WAVED(KWS+1),WAVEZ(KWS+1), - & W(1,K),W(1,KMAX+K),WTOP(1,K),WTOP(1,KMAX+K)) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE STATION FIELDS -C$OMP PARALLEL DO PRIVATE(KU,KV,RADLAT,SLAT1,CLAT1) -C$OMP& PRIVATE(PLN,PLNTOP,F,G,NK) - DO N=1,NMAX - RADLAT=PI/180*RLAT((N-1)*NR+1) - IF(RLAT((N-1)*NR+1).GE.89.9995) THEN - SLAT1=1. - CLAT1=0. - ELSEIF(RLAT((N-1)*NR+1).LE.-89.9995) THEN - SLAT1=-1. - CLAT1=0. - ELSE - SLAT1=SIN(RADLAT) - CLAT1=COS(RADLAT) - ENDIF - CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP, - & PLN,PLNTOP) - CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,MDIM,2*MXTOP,2*KMAX, - & CLAT1,PLN,PLNTOP,MP,W,WTOP,F) - CALL SPFFTPT(MAXWV,1,2*MAXWV+3,1,2*KMAX,RLON((N-1)*NR+1),F,G) - DO K=1,KMAX - KU=K - KV=K+KMAX - NK=(N-1)*NG+(K-1)*KG+1 - UP(NK)=G(KU) - VP(NK)=G(KV) - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptgptvd.f b/src/fim/FIMsrc/prep/sp/sptgptvd.f deleted file mode 100644 index ec2326d..0000000 --- a/src/fim/FIMsrc/prep/sp/sptgptvd.f +++ /dev/null @@ -1,168 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTGPTVD(IROMB,MAXWV,KMAX,NMAX, - & KWSKIP,KGSKIP,NRSKIP,NGSKIP, - & RLAT,RLON,WAVED,WAVEZ, - & DP,ZP,UP,VP,UXP,VXP,UYP,VYP) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPTVD TRANSFORM SPECTRAL VECTOR TO STATION POINTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF DIVERGENCES AND CURLS -C TO SPECIFIED SETS OF STATION POINT VECTORS AND THEIR -C GRADIENTS ON THE GLOBE. -C DP=(D(UP)/DLON+D(VP*CLAT)/DLAT)/(R*CLAT) -C ZP=(D(VP)/DLON-D(UP*CLAT)/DLAT)/(R*CLAT) -C UXP=D(UP*CLAT)/DLON/(R*CLAT) -C VXP=D(VP*CLAT)/DLON/(R*CLAT) -C UYP=D(UP*CLAT)/DLAT/R -C VYP=D(VP*CLAT)/DLAT/R -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND POINT FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER STATIONS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C 1999-08-18 IREDELL OPENMP DIRECTIVE TYPO FIXED -C -C USAGE: CALL SPTGPTVD(IROMB,MAXWV,KMAX,NMAX, -C & KWSKIP,KGSKIP,NRSKIP,NGSKIP, -C & RLAT,RLON,WAVED,WAVEZ, -C & DP,ZP,UP,VP,UXP,VXP,UYP,VYP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NMAX - INTEGER NUMBER OF STATION POINTS TO RETURN -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINT SETS -C (DEFAULTS TO NMAX IF KGSKIP=0) -C NRSKIP - INTEGER SKIP NUMBER BETWEEN STATION LATS AND LONS -C (DEFAULTS TO 1 IF NRSKIP=0) -C NGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINTS -C (DEFAULTS TO 1 IF NGSKIP=0) -C RLAT - REAL (*) STATION LATITUDES IN DEGREES -C RLON - REAL (*) STATION LONGITUDES IN DEGREES -C WAVED - REAL (*) WAVE DIVERGENCE FIELDS -C WAVEZ - REAL (*) WAVE VORTICITY FIELDS -C OUTPUT ARGUMENTS: -C DP - REAL (*) STATION POINT DIVERGENCE SETS -C ZP - REAL (*) STATION POINT VORTICITY SETS -C UP - REAL (*) STATION POINT U-WIND SETS -C VP - REAL (*) STATION POINT V-WIND SETS -C UXP - REAL (*) STATION POINT U-WIND X-GRADIENT SETS -C VXP - REAL (*) STATION POINT V-WIND X-GRADIENT SETS -C UYP - REAL (*) STATION POINT U-WIND Y-GRADIENT SETS -C VYP - REAL (*) STATION POINT V-WIND Y-GRADIENT SETS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C SPDZ2UV COMPUTE WINDS FROM DIVERGENCE AND VORTICITY -C SPGRADX COMPUTE X-GRADIENT IN FOURIER SPACE -C SPFFTPT COMPUTE FOURIER TRANSFORM TO GRIDPOINTS -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL RLAT(*),RLON(*),WAVED(*),WAVEZ(*) - REAL DP(*),ZP(*),UP(*),VP(*),UXP(*),VXP(*),UYP(*),VYP(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - INTEGER MP(4*KMAX) - REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2,4*KMAX) - REAL WTOP(2*(MAXWV+1),4*KMAX) - REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),PLNTOP(MAXWV+1) - REAL F(2*MAXWV+2,2,6*KMAX),G(6*KMAX) - PARAMETER(PI=3.14159265358979) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE PRELIMINARY CONSTANTS - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MXTOP=MAXWV+1 - MDIM=2*MX - IDIM=2*MAXWV+2 - KW=KWSKIP - KG=KGSKIP - NR=NRSKIP - NG=NGSKIP - IF(KW.EQ.0) KW=2*MX - IF(KG.EQ.0) KG=NMAX - IF(NR.EQ.0) NR=1 - IF(NG.EQ.0) NG=1 - MP(1:2*KMAX)=0 - MP(2*KMAX+1:4*KMAX)=1 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE SPECTRAL WINDS -C$OMP PARALLEL DO PRIVATE(KWS,KD,KZ,KU,KV) - DO K=1,KMAX - KWS=(K-1)*KW - KD=0*KMAX+K - KZ=1*KMAX+K - KU=2*KMAX+K - KV=3*KMAX+K - DO I=1,2*MX - W(I,KD)=WAVED(KWS+I) - W(I,KZ)=WAVEZ(KWS+I) - ENDDO - DO I=1,2*MXTOP - WTOP(I,KD)=0 - WTOP(I,KZ)=0 - ENDDO - CALL SPDZ2UV(IROMB,MAXWV,ENN1,ELONN1,EON,EONTOP, - & WAVED(KWS+1),WAVEZ(KWS+1), - & W(1,KU),W(1,KV),WTOP(1,KU),WTOP(1,KV)) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE STATION FIELDS -C$OMP PARALLEL DO PRIVATE(KD,KZ,KU,KV,KUX,KVX,SLAT1,CLAT1) -C$OMP& PRIVATE(PLN,PLNTOP,F,G,NK) - DO N=1,NMAX - KU=2*KMAX+1 - KUX=4*KMAX+1 - IF(ABS(RLAT((N-1)*NR+1)).GE.89.9995) THEN - SLAT1=SIGN(1.,RLAT((N-1)*NR+1)) - CLAT1=0. - ELSE - SLAT1=SIN(PI/180*RLAT((N-1)*NR+1)) - CLAT1=COS(PI/180*RLAT((N-1)*NR+1)) - ENDIF - CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP, - & PLN,PLNTOP) - CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,MDIM,2*MXTOP,4*KMAX, - & CLAT1,PLN,PLNTOP,MP,W,WTOP,F) - CALL SPGRADX(MAXWV,IDIM,2*KMAX,MP(2*KMAX+1),CLAT1, - & F(1,1,2*KMAX+1),F(1,1,4*KMAX+1)) - CALL SPFFTPT(MAXWV,1,IDIM,1,6*KMAX,RLON((N-1)*NR+1),F,G) - DO K=1,KMAX - KD=0*KMAX+K - KZ=1*KMAX+K - KU=2*KMAX+K - KV=3*KMAX+K - KUX=4*KMAX+K - KVX=5*KMAX+K - NK=(N-1)*NG+(K-1)*KG+1 - DP(NK)=G(KD) - ZP(NK)=G(KZ) - UP(NK)=G(KU) - VP(NK)=G(KV) - UXP(NK)=G(KUX) - VXP(NK)=G(KVX) - UYP(NK)=G(KVX)-CLAT1*G(KZ) - VYP(NK)=CLAT1*G(KD)-G(KUX) - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptran.f b/src/fim/FIMsrc/prep/sp/sptran.f deleted file mode 100644 index a151384..0000000 --- a/src/fim/FIMsrc/prep/sp/sptran.f +++ /dev/null @@ -1,130 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTRAN(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, - & IPRIME,ISKIP,JNSKIP,JSSKIP,KWSKIP,KGSKIP, - & JBEG,JEND,JCPU, - & WAVE,GRIDN,GRIDS,IDIR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C BETWEEN SPECTRAL COEFFICIENTS OF SCALAR QUANTITIES -C AND FIELDS ON A GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C TRANSFORMS ARE DONE IN LATITUDE PAIRS FOR EFFICIENCY; -C THUS GRID ARRAYS FOR EACH HEMISPHERE MUST BE PASSED. -C IF SO REQUESTED, JUST A SUBSET OF THE LATITUDE PAIRS -C MAY BE TRANSFORMED IN EACH INVOCATION OF THE SUBPROGRAM. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER LATITUDE EXCEPT -C THE TRANSFORM FROM FOURIER TO SPECTRAL IS MULTIPROCESSED -C OVER ZONAL WAVENUMBER TO ENSURE REPRODUCIBILITY. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL GENERIC FFT USED -C OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPTRAN(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, -C & IPRIME,ISKIP,JNSKIP,JSSKIP,KWSKIP,KGSKIP, -C & JBEG,JEND,JCPU, -C & WAVE,GRIDN,GRIDS,IDIR) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES. -C JMAX - INTEGER NUMBER OF LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C IPRIME - INTEGER LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C ISKIP - INTEGER SKIP NUMBER BETWEEN LONGITUDES -C (DEFAULTS TO 1 IF ISKIP=0) -C JNSKIP - INTEGER SKIP NUMBER BETWEEN N.H. LATITUDES FROM NORTH -C (DEFAULTS TO IMAX IF JNSKIP=0) -C JSSKIP - INTEGER SKIP NUMBER BETWEEN S.H. LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAX IF JSSKIP=0) -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO IMAX*JMAX IF KGSKIP=0) -C JBEG - INTEGER LATITUDE INDEX (FROM POLE) TO BEGIN TRANSFORM -C (DEFAULTS TO 1 IF JBEG=0) -C (IF JBEG=0 AND IDIR<0, WAVE IS ZEROED BEFORE TRANSFORM) -C JEND - INTEGER LATITUDE INDEX (FROM POLE) TO END TRANSFORM -C (DEFAULTS TO (JMAX+1)/2 IF JEND=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C WAVE - REAL (*) WAVE FIELDS IF IDIR>0 -C GRIDN - REAL (*) N.H. GRID FIELDS (STARTING AT JBEG) IF IDIR<0 -C GRIDS - REAL (*) S.H. GRID FIELDS (STARTING AT JBEG) IF IDIR<0 -C IDIR - INTEGER TRANSFORM FLAG -C (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -C OUTPUT ARGUMENTS: -C WAVE - REAL (*) WAVE FIELDS IF IDIR<0 -C GRIDN - REAL (*) N.H. GRID FIELDS (STARTING AT JBEG) IF IDIR>0 -C GRIDS - REAL (*) S.H. GRID FIELDS (STARTING AT JBEG) IF IDIR>0 -C -C SUBPROGRAMS CALLED: -C SPTRANF PERFORM A SCALAR SPHERICAL TRANSFORM -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVE(*),GRIDN(*),GRIDS(*) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - IP=IPRIME - IS=ISKIP - JN=JNSKIP - JS=JSSKIP - KW=KWSKIP - KG=KGSKIP - JB=JBEG - JE=JEND - JC=JCPU - IF(IP.EQ.0) IP=1 - IF(IS.EQ.0) IS=1 - IF(JN.EQ.0) JN=IMAX - IF(JS.EQ.0) JS=-JN - IF(KW.EQ.0) KW=2*MX - IF(KG.EQ.0) KG=IMAX*JMAX - IF(JB.EQ.0) JB=1 - IF(JE.EQ.0) JE=(JMAX+1)/2 - IF(JC.EQ.0) JC=NCPUS() -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(IDIR.LT.0.AND.JBEG.EQ.0) THEN - DO K=1,KMAX - KWS=(K-1)*KW - WAVE(KWS+1:KWS+2*MX)=0 - ENDDO - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - CALL SPTRANF(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, - & IP,IS,JN,JS,KW,KG,JB,JE,JC, - & WAVE,GRIDN,GRIDS,IDIR) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptrand.f b/src/fim/FIMsrc/prep/sp/sptrand.f deleted file mode 100644 index 323815b..0000000 --- a/src/fim/FIMsrc/prep/sp/sptrand.f +++ /dev/null @@ -1,164 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTRAND(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, - & IPRIME,ISKIP,JNSKIP,JSSKIP,KWSKIP,KGSKIP, - & JBEG,JEND,JCPU, - & WAVE,GRIDMN,GRIDXN,GRIDXS,GRIDYN,GRIDYS,IDIR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRAND PERFORM A GRADIENT SPHERICAL TRANSFORM -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C BETWEEN SPECTRAL COEFFICIENTS OF SCALAR FIELDS -C AND THEIR MEANS AND GRADIENTS ON A GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C TRANSFORMS ARE DONE IN LATITUDE PAIRS FOR EFFICIENCY; -C THUS GRID ARRAYS FOR EACH HEMISPHERE MUST BE PASSED. -C IF SO REQUESTED, JUST A SUBSET OF THE LATITUDE PAIRS -C MAY BE TRANSFORMED IN EACH INVOCATION OF THE SUBPROGRAM. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER LATITUDE EXCEPT -C THE TRANSFORM FROM FOURIER TO SPECTRAL IS MULTIPROCESSED -C OVER ZONAL WAVENUMBER TO ENSURE REPRODUCIBILITY. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPTRAND(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, -C & IPRIME,ISKIP,JNSKIP,JSSKIP,KWSKIP,KGSKIP, -C & JBEG,JEND,JCPU, -C & WAVE,GRIDMN,GRIDXN,GRIDXS,GRIDYN,GRIDYS,IDIR) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES. -C JMAX - INTEGER NUMBER OF LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C IPRIME - INTEGER LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C ISKIP - INTEGER SKIP NUMBER BETWEEN LONGITUDES -C (DEFAULTS TO 1 IF ISKIP=0) -C JNSKIP - INTEGER SKIP NUMBER BETWEEN N.H. LATITUDES FROM NORTH -C (DEFAULTS TO IMAX IF JNSKIP=0) -C JSSKIP - INTEGER SKIP NUMBER BETWEEN S.H. LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAX IF JSSKIP=0) -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO IMAX*JMAX IF KGSKIP=0) -C JBEG - INTEGER LATITUDE INDEX (FROM POLE) TO BEGIN TRANSFORM -C (DEFAULTS TO 1 IF JBEG=0) -C (IF JBEG=0 AND IDIR<0, WAVE IS ZEROED BEFORE TRANSFORM) -C JEND - INTEGER LATITUDE INDEX (FROM POLE) TO END TRANSFORM -C (DEFAULTS TO (JMAX+1)/2 IF JEND=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C WAVE - REAL (*) WAVE FIELDS IF IDIR>0 -C GRIDMN - REAL (KMAX) GLOBAL MEANS IF IDIR<0 -C GRIDXN - REAL (*) N.H. X-GRADIENTS (STARTING AT JBEG) IF IDIR<0 -C GRIDXS - REAL (*) S.H. X-GRADIENTS (STARTING AT JBEG) IF IDIR<0 -C GRIDYN - REAL (*) N.H. Y-GRADIENTS (STARTING AT JBEG) IF IDIR<0 -C GRIDYS - REAL (*) S.H. Y-GRADIENTS (STARTING AT JBEG) IF IDIR<0 -C IDIR - INTEGER TRANSFORM FLAG -C (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -C OUTPUT ARGUMENTS: -C WAVE - REAL (*) WAVE FIELDS IF IDIR<0 -C GRIDMN - REAL (KMAX) GLOBAL MEANS IF IDIR>0 -C GRIDXN - REAL (*) N.H. X-GRADIENTS (STARTING AT JBEG) IF IDIR>0 -C GRIDXS - REAL (*) S.H. X-GRADIENTS (STARTING AT JBEG) IF IDIR>0 -C [GRIDX=(D(WAVE)/DLAM)/(CLAT*RERTH)] -C GRIDYN - REAL (*) N.H. Y-GRADIENTS (STARTING AT JBEG) IF IDIR>0 -C GRIDYS - REAL (*) S.H. Y-GRADIENTS (STARTING AT JBEG) IF IDIR>0 -C [GRIDY=(D(WAVE)/DPHI)/RERTH] -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTRANV PERFORM A VECTOR SPHERICAL TRANSFORM -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVE(*),GRIDMN(KMAX),GRIDXN(*),GRIDXS(*),GRIDYN(*),GRIDYS(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - REAL WD((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) - REAL WZ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SET PARAMETERS - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MDIM=2*MX+1 - KW=KWSKIP - IF(KW.EQ.0) KW=2*MX -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO GRID - IF(IDIR.GT.0) THEN -C$OMP PARALLEL DO PRIVATE(KWS) - DO K=1,KMAX - KWS=(K-1)*KW - GRIDMN(K)=WAVE(KWS+1)/SQRT(2.) - CALL SPLAPLAC(IROMB,MAXWV,ENN1,WAVE(KWS+1),WD(1,K),1) - WZ(1:2*MX,K)=0. - ENDDO - CALL SPTRANV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, - & IPRIME,ISKIP,JNSKIP,JSSKIP,MDIM,KGSKIP, - & JBEG,JEND,JCPU, - & WD,WZ,GRIDXN,GRIDXS,GRIDYN,GRIDYS,IDIR) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM GRID TO WAVE - ELSE -C$OMP PARALLEL DO - DO K=1,KMAX - WD(1:2*MX,K)=0. - WZ(1:2*MX,K)=0. - ENDDO - CALL SPTRANV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, - & IPRIME,ISKIP,JNSKIP,JSSKIP,MDIM,KGSKIP, - & JBEG,JEND,JCPU, - & WD,WZ,GRIDXN,GRIDXS,GRIDYN,GRIDYS,IDIR) - IF(JBEG.EQ.0) THEN -C$OMP PARALLEL DO PRIVATE(KWS) - DO K=1,KMAX - KWS=(K-1)*KW - CALL SPLAPLAC(IROMB,MAXWV,ENN1,WAVE(KWS+1),WD(1,K),-1) - WAVE(KWS+1)=GRIDMN(K)*SQRT(2.) - ENDDO - ELSE -C$OMP PARALLEL DO PRIVATE(KWS) - DO K=1,KMAX - KWS=(K-1)*KW - CALL SPLAPLAC(IROMB,MAXWV,ENN1,WZ(1,K),WD(1,K),-1) - WAVE(KWS+1:KWS+2*MX)=WAVE(KWS+1:KWS+2*MX)+WZ(1:2*MX,K) - WAVE(KWS+1)=GRIDMN(K)*SQRT(2.) - ENDDO - ENDIF - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptranf.f b/src/fim/FIMsrc/prep/sp/sptranf.f deleted file mode 100644 index f9d868d..0000000 --- a/src/fim/FIMsrc/prep/sp/sptranf.f +++ /dev/null @@ -1,177 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTRANF(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, - & IP,IS,JN,JS,KW,KG,JB,JE,JC, - & WAVE,GRIDN,GRIDS,IDIR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C BETWEEN SPECTRAL COEFFICIENTS OF SCALAR QUANTITIES -C AND FIELDS ON A GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C TRANSFORMS ARE DONE IN LATITUDE PAIRS FOR EFFICIENCY; -C THUS GRID ARRAYS FOR EACH HEMISPHERE MUST BE PASSED. -C IF SO REQUESTED, JUST A SUBSET OF THE LATITUDE PAIRS -C MAY BE TRANSFORMED IN EACH INVOCATION OF THE SUBPROGRAM. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER LATITUDE EXCEPT -C THE TRANSFORM FROM FOURIER TO SPECTRAL IS MULTIPROCESSED -C OVER ZONAL WAVENUMBER TO ENSURE REPRODUCIBILITY. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL GENERIC FFT USED -C OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPTRANF(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, -C & IP,IS,JN,JS,KW,KG,JB,JE,JC, -C & WAVE,GRIDN,GRIDS,IDIR) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES. -C JMAX - INTEGER NUMBER OF LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C IP - INTEGER LONGITUDE INDEX FOR THE PRIME MERIDIAN -C IS - INTEGER SKIP NUMBER BETWEEN LONGITUDES -C JN - INTEGER SKIP NUMBER BETWEEN N.H. LATITUDES FROM NORTH -C JS - INTEGER SKIP NUMBER BETWEEN S.H. LATITUDES FROM SOUTH -C KW - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C KG - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C JB - INTEGER LATITUDE INDEX (FROM POLE) TO BEGIN TRANSFORM -C JE - INTEGER LATITUDE INDEX (FROM POLE) TO END TRANSFORM -C JC - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C WAVE - REAL (*) WAVE FIELDS IF IDIR>0 -C GRIDN - REAL (*) N.H. GRID FIELDS (STARTING AT JB) IF IDIR<0 -C GRIDS - REAL (*) S.H. GRID FIELDS (STARTING AT JB) IF IDIR<0 -C IDIR - INTEGER TRANSFORM FLAG -C (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -C OUTPUT ARGUMENTS: -C WAVE - REAL (*) WAVE FIELDS IF IDIR<0 -C GRIDN - REAL (*) N.H. GRID FIELDS (STARTING AT JB) IF IDIR>0 -C GRIDS - REAL (*) S.H. GRID FIELDS (STARTING AT JB) IF IDIR>0 -C -C SUBPROGRAMS CALLED: -C SPTRANF0 SPTRANF SPECTRAL INITIALIZATION -C SPTRANF1 SPTRANF SPECTRAL TRANSFORM -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVE(*),GRIDN(*),GRIDS(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - REAL(8) AFFT(50000+4*IMAX) - REAL CLAT(JB:JE),SLAT(JB:JE),WLAT(JB:JE) - REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2,JB:JE) - REAL PLNTOP(MAXWV+1,JB:JE) - REAL WTOP(2*(MAXWV+1)) - REAL G(IMAX,2) -! write(0,*) 'sptranf top' -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SET PARAMETERS - MP=0 -! write(0,*) 'sptranf call sptranf0' - CALL SPTRANF0(IROMB,MAXWV,IDRT,IMAX,JMAX,JB,JE, - & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP, - & AFFT,CLAT,SLAT,WLAT,PLN,PLNTOP) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO GRID - IF(IDIR.GT.0) THEN -C$OMP PARALLEL DO PRIVATE(KWS,WTOP,G,IJKN,IJKS) - DO K=1,KMAX - KWS=(K-1)*KW - WTOP=0 - DO J=JB,JE -! write(0,*) 'sptranf call sptranf1 k,j=',k,j,kws - CALL SPTRANF1(IROMB,MAXWV,IDRT,IMAX,JMAX,J,J, - & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP, - & AFFT,CLAT(J),SLAT(J),WLAT(J), - & PLN(1,J),PLNTOP(1,J),MP, - & WAVE(KWS+1),WTOP,G,IDIR) -! write(0,*) 'sptranf exit sptranf1' - IF(IP.EQ.1.AND.IS.EQ.1) THEN - DO I=1,IMAX - IJKN=I+(J-JB)*JN+(K-1)*KG - IJKS=I+(J-JB)*JS+(K-1)*KG -! print"('JFM sptranf1A',7i7)",i,j,jb,js, k,kg, IJKS !js=-1152 so at i=k=1,j=JB+1 IJKS=-1151 -! JFM sptranf1A 1 2 1 -1152 1 663552 -1151 -!JFM The problem starts in sptez.f -!JFM This is ok because of the way GRIDS is passed in from sptez.f -!JFM Same problem in sptranfv.f. - GRIDN(IJKN)=G(I,1) - GRIDS(IJKS)=G(I,2) - ENDDO - ELSE - DO I=1,IMAX - IJKN=MOD(I+IP-2,IMAX)*IS+(J-JB)*JN+(K-1)*KG+1 - IJKS=MOD(I+IP-2,IMAX)*IS+(J-JB)*JS+(K-1)*KG+1 - GRIDN(IJKN)=G(I,1) - GRIDS(IJKS)=G(I,2) - ENDDO - ENDIF - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM GRID TO WAVE - ELSE -C$OMP PARALLEL DO PRIVATE(KWS,WTOP,G,IJKN,IJKS) - DO K=1,KMAX - KWS=(K-1)*KW - WTOP=0 - DO J=JB,JE - IF(WLAT(J).GT.0.) THEN - IF(IP.EQ.1.AND.IS.EQ.1) THEN - DO I=1,IMAX - IJKN=I+(J-JB)*JN+(K-1)*KG - IJKS=I+(J-JB)*JS+(K-1)*KG - G(I,1)=GRIDN(IJKN) - G(I,2)=GRIDS(IJKS) - ENDDO - ELSE - DO I=1,IMAX - IJKN=MOD(I+IP-2,IMAX)*IS+(J-JB)*JN+(K-1)*KG+1 - IJKS=MOD(I+IP-2,IMAX)*IS+(J-JB)*JS+(K-1)*KG+1 - G(I,1)=GRIDN(IJKN) - G(I,2)=GRIDS(IJKS) - ENDDO - ENDIF - CALL SPTRANF1(IROMB,MAXWV,IDRT,IMAX,JMAX,J,J, - & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP, - & AFFT,CLAT(J),SLAT(J),WLAT(J), - & PLN(1,J),PLNTOP(1,J),MP, - & WAVE(KWS+1),WTOP,G,IDIR) - ENDIF - ENDDO - ENDDO - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptranf0.f b/src/fim/FIMsrc/prep/sp/sptranf0.f deleted file mode 100644 index 484f939..0000000 --- a/src/fim/FIMsrc/prep/sp/sptranf0.f +++ /dev/null @@ -1,80 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTRANF0(IROMB,MAXWV,IDRT,IMAX,JMAX,JB,JE, - & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP, - & AFFT,CLAT,SLAT,WLAT,PLN,PLNTOP) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRANF0 SPTRANF SPECTRAL INITIALIZATION -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS AN INITIALIZATION FOR -C SUBPROGRAM SPTRANF. USE THIS SUBPROGRAM OUTSIDE -C THE SPTRANF FAMILY CONTEXT AT YOUR OWN RISK. -C -C PROGRAM HISTORY LOG: -C 1998-12-15 IREDELL -C -C USAGE: CALL SPTRANF0(IROMB,MAXWV,IDRT,IMAX,JMAX,JB,JE, -C & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP, -C & AFFT,CLAT,SLAT,WLAT,PLN,PLNTOP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES -C JMAX - INTEGER NUMBER OF LATITUDES -C JB - INTEGER LATITUDE INDEX (FROM POLE) TO BEGIN TRANSFORM -C JE - INTEGER LATITUDE INDEX (FROM POLE) TO END TRANSFORM -C OUTPUT ARGUMENTS: -C EPS - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) -C EPSTOP - REAL (MAXWV+1) -C ENN1 - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) -C ELONN1 - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) -C EON - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) -C EONTOP - REAL (MAXWV+1) -C AFFT - REAL(8) (50000+4*IMAX) AUXILIARY ARRAY IF IDIR=0 -C CLAT - REAL (JB:JE) COSINES OF LATITUDE -C SLAT - REAL (JB:JE) SINES OF LATITUDE -C WLAT - REAL (JB:JE) GAUSSIAN WEIGHTS -C PLN - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2,JB:JE) -C LEGENDRE POLYNOMIALS -C PLNTOP - REAL (MAXWV+1,JB:JE) LEGENDRE POLYNOMIAL OVER TOP -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPFFTE PERFORM FAST FOURIER TRANSFORM -C SPLAT COMPUTE LATITUDE FUNCTIONS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - REAL(8) AFFT(50000+4*IMAX) - REAL CLAT(JB:JE),SLAT(JB:JE),WLAT(JB:JE) - REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2,JB:JE) - REAL PLNTOP(MAXWV+1,JB:JE) - REAL SLATX(JMAX),WLATX(JMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) - CALL SPFFTE(IMAX,(IMAX+2)/2,IMAX,2,0.,0.,0,AFFT) - CALL SPLAT(IDRT,JMAX,SLATX,WLATX) - JHE=(JMAX+1)/2 - IF(JHE.GT.JMAX/2) WLATX(JHE)=WLATX(JHE)/2 - DO J=JB,JE - CLAT(J)=SQRT(1.-SLATX(J)**2) - SLAT(J)=SLATX(J) - WLAT(J)=WLATX(J) - CALL SPLEGEND(IROMB,MAXWV,SLAT(J),CLAT(J),EPS,EPSTOP, - & PLN(1,J),PLNTOP(1,J)) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptranf1.f b/src/fim/FIMsrc/prep/sp/sptranf1.f deleted file mode 100644 index 2c479ef..0000000 --- a/src/fim/FIMsrc/prep/sp/sptranf1.f +++ /dev/null @@ -1,99 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTRANF1(IROMB,MAXWV,IDRT,IMAX,JMAX,JB,JE, - & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP, - & AFFT,CLAT,SLAT,WLAT,PLN,PLNTOP,MP, - & W,WTOP,G,IDIR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRANF1 SPTRANF SPECTRAL TRANSFORM -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS AN SINGLE LATITUDE TRANSFORM FOR -C SUBPROGRAM SPTRANF. USE THIS SUBPROGRAM OUTSIDE -C THE SPTRANF FAMILY CONTEXT AT YOUR OWN RISK. -C -C PROGRAM HISTORY LOG: -C 1998-12-15 IREDELL -C -C USAGE: CALL SPTRANF1(IROMB,MAXWV,IDRT,IMAX,JMAX,JB,JE, -C & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP, -C & AFFT,CLAT,SLAT,WLAT,PLN,PLNTOP,MP, -C & W,WTOP,G,IDIR) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES -C JMAX - INTEGER NUMBER OF LATITUDES -C JB - INTEGER LATITUDE INDEX (FROM POLE) TO BEGIN TRANSFORM -C JE - INTEGER LATITUDE INDEX (FROM POLE) TO END TRANSFORM -C EPS - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) -C EPSTOP - REAL (MAXWV+1) -C ENN1 - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) -C ELONN1 - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) -C EON - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) -C EONTOP - REAL (MAXWV+1) -C CLAT - REAL (JB:JE) COSINES OF LATITUDE -C SLAT - REAL (JB:JE) SINES OF LATITUDE -C WLAT - REAL (JB:JE) GAUSSIAN WEIGHTS -C AFFT - REAL(8) (50000+4*IMAX) AUXILIARY ARRAY IF IDIR=0 -C PLN - REAL ((M+1)*((I+1)*M+2)/2,JB:JE) LEGENDRE POLYNOMIALS -C PLNTOP - REAL (M+1,JB:JE) LEGENDRE POLYNOMIAL OVER TOP -C MP - INTEGER IDENTIFIER (0 FOR SCALAR, 1 FOR VECTOR) -C W - REAL (*) WAVE FIELD IF IDIR>0 -C WTOP - REAL (*) WAVE FIELD OVER TOP IF IDIR>0 -C G - REAL (IMAX,2,JB:JE) GRID FIELD IF IDIR<0 -C IDIR - INTEGER TRANSFORM FLAG -C (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -C OUTPUT ARGUMENTS: -C W - REAL (*) WAVE FIELD IF IDIR<0 -C WTOP - REAL (*) WAVE FIELD OVER TOP IF IDIR<0 -C G - REAL (IMAX,2,JB:JE) GRID FIELD IF IDIR>0 -C -C SUBPROGRAMS CALLED: -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C SPANALY ANALYZE SPECTRAL FROM FOURIER -C SPFFTE PERFORM FAST FOURIER TRANSFORM -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - REAL(8) AFFT(50000+4*IMAX) - REAL CLAT(JB:JE),SLAT(JB:JE),WLAT(JB:JE) - REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2,JB:JE) - REAL PLNTOP(MAXWV+1,JB:JE) - REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)) - REAL WTOP(2*(MAXWV+1)) - REAL G(IMAX,2,JB:JE) - REAL F(IMAX+2,2) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! write(0,*) 'sptranf1 top' - KW=(MAXWV+1)*((IROMB+1)*MAXWV+2) - KWTOP=2*(MAXWV+1) - IF(IDIR.GT.0) THEN - DO J=JB,JE - CALL SPSYNTH(IROMB,MAXWV,IMAX,IMAX+2,KW,KWTOP,1, - & CLAT(J),PLN(1,J),PLNTOP(1,J),MP, - & W,WTOP,F) - CALL SPFFTE(IMAX,(IMAX+2)/2,IMAX,2,F,G(1,1,J),+1,AFFT) - ENDDO - ELSE - DO J=JB,JE - CALL SPFFTE(IMAX,(IMAX+2)/2,IMAX,2,F,G(1,1,J),-1,AFFT) - CALL SPANALY(IROMB,MAXWV,IMAX,IMAX+2,KW,KWTOP,1, - & WLAT(J),CLAT(J),PLN(1,J),PLNTOP(1,J),MP, - & F,W,WTOP) - ENDDO -! write(0,*) 'sptranf1 end' - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptranfv.f b/src/fim/FIMsrc/prep/sp/sptranfv.f deleted file mode 100644 index dd347f8..0000000 --- a/src/fim/FIMsrc/prep/sp/sptranfv.f +++ /dev/null @@ -1,208 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTRANFV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, - & IP,IS,JN,JS,KW,KG,JB,JE,JC, - & WAVED,WAVEZ,GRIDUN,GRIDUS,GRIDVN,GRIDVS,IDIR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRANFV PERFORM A VECTOR SPHERICAL TRANSFORM -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C BETWEEN SPECTRAL COEFFICIENTS OF DIVERGENCES AND CURLS -C AND VECTOR FIELDS ON A GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C TRANSFORMS ARE DONE IN LATITUDE PAIRS FOR EFFICIENCY; -C THUS GRID ARRAYS FOR EACH HEMISPHERE MUST BE PASSED. -C IF SO REQUESTED, JUST A SUBSET OF THE LATITUDE PAIRS -C MAY BE TRANSFORMED IN EACH INVOCATION OF THE SUBPROGRAM. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER LATITUDE EXCEPT -C THE TRANSFORM FROM FOURIER TO SPECTRAL IS MULTIPROCESSED -C OVER ZONAL WAVENUMBER TO ENSURE REPRODUCIBILITY. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL GENERIC FFT USED -C OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPTRANFV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, -C & IP,IS,JN,JS,KW,KG,JB,JE,JC, -C & WAVED,WAVEZ,GRIDUN,GRIDUS,GRIDVN,GRIDVS,IDIR) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES. -C JMAX - INTEGER NUMBER OF LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C IP - INTEGER LONGITUDE INDEX FOR THE PRIME MERIDIAN -C IS - INTEGER SKIP NUMBER BETWEEN LONGITUDES -C JN - INTEGER SKIP NUMBER BETWEEN N.H. LATITUDES FROM NORTH -C JS - INTEGER SKIP NUMBER BETWEEN S.H. LATITUDES FROM SOUTH -C KW - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C KG - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C JB - INTEGER LATITUDE INDEX (FROM POLE) TO BEGIN TRANSFORM -C JE - INTEGER LATITUDE INDEX (FROM POLE) TO END TRANSFORM -C JC - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C WAVED - REAL (*) WAVE DIVERGENCE FIELDS IF IDIR>0 -C WAVEZ - REAL (*) WAVE VORTICITY FIELDS IF IDIR>0 -C GRIDUN - REAL (*) N.H. GRID U-WINDS (STARTING AT JB) IF IDIR<0 -C GRIDUS - REAL (*) S.H. GRID U-WINDS (STARTING AT JB) IF IDIR<0 -C GRIDVN - REAL (*) N.H. GRID V-WINDS (STARTING AT JB) IF IDIR<0 -C GRIDVS - REAL (*) S.H. GRID V-WINDS (STARTING AT JB) IF IDIR<0 -C IDIR - INTEGER TRANSFORM FLAG -C (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -C OUTPUT ARGUMENTS: -C WAVED - REAL (*) WAVE DIVERGENCE FIELDS IF IDIR<0 -C [WAVED=(D(GRIDU)/DLAM+D(CLAT*GRIDV)/DPHI)/(CLAT*RERTH)] -C WAVEZ - REAL (*) WAVE VORTICITY FIELDS IF IDIR<0 -C [WAVEZ=(D(GRIDV)/DLAM-D(CLAT*GRIDU)/DPHI)/(CLAT*RERTH)] -C GRIDUN - REAL (*) N.H. GRID U-WINDS (STARTING AT JB) IF IDIR>0 -C GRIDUS - REAL (*) S.H. GRID U-WINDS (STARTING AT JB) IF IDIR>0 -C GRIDVN - REAL (*) N.H. GRID V-WINDS (STARTING AT JB) IF IDIR>0 -C GRIDVS - REAL (*) S.H. GRID V-WINDS (STARTING AT JB) IF IDIR>0 -C -C SUBPROGRAMS CALLED: -C SPTRANF0 SPTRANF SPECTRAL INITIALIZATION -C SPTRANF1 SPTRANF SPECTRAL TRANSFORM -C SPDZ2UV COMPUTE WINDS FROM DIVERGENCE AND VORTICITY -C SPUV2DZ COMPUTE DIVERGENCE AND VORTICITY FROM WINDS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVED(*),WAVEZ(*),GRIDUN(*),GRIDUS(*),GRIDVN(*),GRIDVS(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - REAL(8) AFFT(50000+4*IMAX) - REAL CLAT(JB:JE),SLAT(JB:JE),WLAT(JB:JE) - REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2,JB:JE) - REAL PLNTOP(MAXWV+1,JB:JE) - INTEGER MP(2) - REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2,2) - REAL WTOP(2*(MAXWV+1),2) - REAL G(IMAX,2,2) - REAL WINC((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2,2) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SET PARAMETERS - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MP=1 - CALL SPTRANF0(IROMB,MAXWV,IDRT,IMAX,JMAX,JB,JE, - & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP, - & AFFT,CLAT,SLAT,WLAT,PLN,PLNTOP) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO GRID - IF(IDIR.GT.0) THEN -C$OMP PARALLEL DO PRIVATE(KWS,W,WTOP,G,IJKN,IJKS) - DO K=1,KMAX - KWS=(K-1)*KW - CALL SPDZ2UV(IROMB,MAXWV,ENN1,ELONN1,EON,EONTOP, - & WAVED(KWS+1),WAVEZ(KWS+1), - & W(1,1),W(1,2),WTOP(1,1),WTOP(1,2)) - DO J=JB,JE - CALL SPTRANF1(IROMB,MAXWV,IDRT,IMAX,JMAX,J,J, - & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP, - & AFFT,CLAT(J),SLAT(J),WLAT(J), - & PLN(1,J),PLNTOP(1,J),MP, - & W(1,1),WTOP(1,1),G(1,1,1),IDIR) - CALL SPTRANF1(IROMB,MAXWV,IDRT,IMAX,JMAX,J,J, - & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP, - & AFFT,CLAT(J),SLAT(J),WLAT(J), - & PLN(1,J),PLNTOP(1,J),MP, - & W(1,2),WTOP(1,2),G(1,1,2),IDIR) - IF(IP.EQ.1.AND.IS.EQ.1) THEN - DO I=1,IMAX - IJKN=I+(J-JB)*JN+(K-1)*KG - IJKS=I+(J-JB)*JS+(K-1)*KG - GRIDUN(IJKN)=G(I,1,1) - GRIDUS(IJKS)=G(I,2,1) - GRIDVN(IJKN)=G(I,1,2) - GRIDVS(IJKS)=G(I,2,2) - ENDDO - ELSE - DO I=1,IMAX - IJKN=MOD(I+IP-2,IMAX)*IS+(J-JB)*JN+(K-1)*KG+1 - IJKS=MOD(I+IP-2,IMAX)*IS+(J-JB)*JS+(K-1)*KG+1 - GRIDUN(IJKN)=G(I,1,1) - GRIDUS(IJKS)=G(I,2,1) - GRIDVN(IJKN)=G(I,1,2) - GRIDVS(IJKS)=G(I,2,2) - ENDDO - ENDIF - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM GRID TO WAVE - ELSE -C$OMP PARALLEL DO PRIVATE(KWS,W,WTOP,G,IJKN,IJKS,WINC) - DO K=1,KMAX - KWS=(K-1)*KW - W=0 - WTOP=0 - DO J=JB,JE - IF(WLAT(J).GT.0.) THEN - IF(IP.EQ.1.AND.IS.EQ.1) THEN - DO I=1,IMAX - IJKN=I+(J-JB)*JN+(K-1)*KG - IJKS=I+(J-JB)*JS+(K-1)*KG - G(I,1,1)=GRIDUN(IJKN)/CLAT(J)**2 - G(I,2,1)=GRIDUS(IJKS)/CLAT(J)**2 - G(I,1,2)=GRIDVN(IJKN)/CLAT(J)**2 - G(I,2,2)=GRIDVS(IJKS)/CLAT(J)**2 - ENDDO - ELSE - DO I=1,IMAX - IJKN=MOD(I+IP-2,IMAX)*IS+(J-JB)*JN+(K-1)*KG+1 - IJKS=MOD(I+IP-2,IMAX)*IS+(J-JB)*JS+(K-1)*KG+1 - G(I,1,1)=GRIDUN(IJKN)/CLAT(J)**2 - G(I,2,1)=GRIDUS(IJKS)/CLAT(J)**2 - G(I,1,2)=GRIDVN(IJKN)/CLAT(J)**2 - G(I,2,2)=GRIDVS(IJKS)/CLAT(J)**2 - ENDDO - ENDIF - CALL SPTRANF1(IROMB,MAXWV,IDRT,IMAX,JMAX,J,J, - & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP, - & AFFT,CLAT(J),SLAT(J),WLAT(J), - & PLN(1,J),PLNTOP(1,J),MP, - & W(1,1),WTOP(1,1),G(1,1,1),IDIR) - CALL SPTRANF1(IROMB,MAXWV,IDRT,IMAX,JMAX,J,J, - & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP, - & AFFT,CLAT(J),SLAT(J),WLAT(J), - & PLN(1,J),PLNTOP(1,J),MP, - & W(1,2),WTOP(1,2),G(1,1,2),IDIR) - ENDIF - ENDDO - CALL SPUV2DZ(IROMB,MAXWV,ENN1,ELONN1,EON,EONTOP, - & W(1,1),W(1,2),WTOP(1,1),WTOP(1,2), - & WINC(1,1),WINC(1,2)) - WAVED(KWS+1:KWS+2*MX)=WAVED(KWS+1:KWS+2*MX)+WINC(1:2*MX,1) - WAVEZ(KWS+1:KWS+2*MX)=WAVEZ(KWS+1:KWS+2*MX)+WINC(1:2*MX,2) - ENDDO - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptranv.f b/src/fim/FIMsrc/prep/sp/sptranv.f deleted file mode 100644 index f4cd073..0000000 --- a/src/fim/FIMsrc/prep/sp/sptranv.f +++ /dev/null @@ -1,139 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTRANV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, - & IPRIME,ISKIP,JNSKIP,JSSKIP,KWSKIP,KGSKIP, - & JBEG,JEND,JCPU, - & WAVED,WAVEZ,GRIDUN,GRIDUS,GRIDVN,GRIDVS,IDIR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRANV PERFORM A VECTOR SPHERICAL TRANSFORM -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C BETWEEN SPECTRAL COEFFICIENTS OF DIVERGENCES AND CURLS -C AND VECTOR FIELDS ON A GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C TRANSFORMS ARE DONE IN LATITUDE PAIRS FOR EFFICIENCY; -C THUS GRID ARRAYS FOR EACH HEMISPHERE MUST BE PASSED. -C IF SO REQUESTED, JUST A SUBSET OF THE LATITUDE PAIRS -C MAY BE TRANSFORMED IN EACH INVOCATION OF THE SUBPROGRAM. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER LATITUDE EXCEPT -C THE TRANSFORM FROM FOURIER TO SPECTRAL IS MULTIPROCESSED -C OVER ZONAL WAVENUMBER TO ENSURE REPRODUCIBILITY. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL GENERIC FFT USED -C OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPTRANV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, -C & IPRIME,ISKIP,JNSKIP,JSSKIP,KWSKIP,KGSKIP, -C & JBEG,JEND,JCPU, -C & WAVED,WAVEZ,GRIDUN,GRIDUS,GRIDVN,GRIDVS,IDIR) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES. -C JMAX - INTEGER NUMBER OF LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C IPRIME - INTEGER LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C ISKIP - INTEGER SKIP NUMBER BETWEEN LONGITUDES -C (DEFAULTS TO 1 IF ISKIP=0) -C JNSKIP - INTEGER SKIP NUMBER BETWEEN N.H. LATITUDES FROM NORTH -C (DEFAULTS TO IMAX IF JNSKIP=0) -C JSSKIP - INTEGER SKIP NUMBER BETWEEN S.H. LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAX IF JSSKIP=0) -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO IMAX*JMAX IF KGSKIP=0) -C JBEG - INTEGER LATITUDE INDEX (FROM POLE) TO BEGIN TRANSFORM -C (DEFAULTS TO 1 IF JBEG=0) -C (IF JBEG=0 AND IDIR<0, WAVE IS ZEROED BEFORE TRANSFORM) -C JEND - INTEGER LATITUDE INDEX (FROM POLE) TO END TRANSFORM -C (DEFAULTS TO (JMAX+1)/2 IF JEND=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C WAVED - REAL (*) WAVE DIVERGENCE FIELDS IF IDIR>0 -C WAVEZ - REAL (*) WAVE VORTICITY FIELDS IF IDIR>0 -C GRIDUN - REAL (*) N.H. GRID U-WINDS (STARTING AT JBEG) IF IDIR<0 -C GRIDUS - REAL (*) S.H. GRID U-WINDS (STARTING AT JBEG) IF IDIR<0 -C GRIDVN - REAL (*) N.H. GRID V-WINDS (STARTING AT JBEG) IF IDIR<0 -C GRIDVS - REAL (*) S.H. GRID V-WINDS (STARTING AT JBEG) IF IDIR<0 -C IDIR - INTEGER TRANSFORM FLAG -C (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -C OUTPUT ARGUMENTS: -C WAVED - REAL (*) WAVE DIVERGENCE FIELDS IF IDIR<0 -C [WAVED=(D(GRIDU)/DLAM+D(CLAT*GRIDV)/DPHI)/(CLAT*RERTH)] -C WAVEZ - REAL (*) WAVE VORTICITY FIELDS IF IDIR<0 -C [WAVEZ=(D(GRIDV)/DLAM-D(CLAT*GRIDU)/DPHI)/(CLAT*RERTH)] -C GRIDUN - REAL (*) N.H. GRID U-WINDS (STARTING AT JBEG) IF IDIR>0 -C GRIDUS - REAL (*) S.H. GRID U-WINDS (STARTING AT JBEG) IF IDIR>0 -C GRIDVN - REAL (*) N.H. GRID V-WINDS (STARTING AT JBEG) IF IDIR>0 -C GRIDVS - REAL (*) S.H. GRID V-WINDS (STARTING AT JBEG) IF IDIR>0 -C -C SUBPROGRAMS CALLED: -C SPTRANFV PERFORM A VECTOR SPHERICAL TRANSFORM -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVED(*),WAVEZ(*),GRIDUN(*),GRIDUS(*),GRIDVN(*),GRIDVS(*) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - IP=IPRIME - IS=ISKIP - JN=JNSKIP - JS=JSSKIP - KW=KWSKIP - KG=KGSKIP - JB=JBEG - JE=JEND - JC=JCPU - IF(IP.EQ.0) IP=1 - IF(IS.EQ.0) IS=1 - IF(JN.EQ.0) JN=IMAX - IF(JS.EQ.0) JS=-JN - IF(KW.EQ.0) KW=2*MX - IF(KG.EQ.0) KG=IMAX*JMAX - IF(JB.EQ.0) JB=1 - IF(JE.EQ.0) JE=(JMAX+1)/2 - IF(JC.EQ.0) JC=NCPUS() -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(IDIR.LT.0.AND.JBEG.EQ.0) THEN - DO K=1,KMAX - KWS=(K-1)*KW - WAVED(KWS+1:KWS+2*MX)=0 - WAVEZ(KWS+1:KWS+2*MX)=0 - ENDDO - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - CALL SPTRANFV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, - & IP,IS,JN,JS,KW,KG,JB,JE,JC, - & WAVED,WAVEZ,GRIDUN,GRIDUS,GRIDVN,GRIDVS,IDIR) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptrun.f b/src/fim/FIMsrc/prep/sp/sptrun.f deleted file mode 100644 index a3b4730..0000000 --- a/src/fim/FIMsrc/prep/sp/sptrun.f +++ /dev/null @@ -1,113 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTRUN(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,IDRTO,IMAXO,JMAXO, - & KMAX,IPRIME,ISKIPI,JSKIPI,KSKIPI, - & ISKIPO,JSKIPO,KSKIPO,JCPU,GRIDI,GRIDO) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUN SPECTRALLY TRUNCATE GRIDDED SCALAR FIELDS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES SCALAR FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS -C TO A POSSIBLY DIFFERENT GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C EITHER GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTRUN(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,IDRTO,IMAXO,JMAXO, -C & KMAX,IPRIME,ISKIPI,JSKIPI,KSKIPI, -C & ISKIPO,JSKIPO,KSKIPO,JCPU,GRIDI,GRIDO) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C IDRTO - INTEGER OUTPUT GRID IDENTIFIER -C (IDRTO=4 FOR GAUSSIAN GRID, -C IDRTO=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTO=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXO - INTEGER EVEN NUMBER OF OUTPUT LONGITUDES. -C JMAXO - INTEGER NUMBER OF OUTPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C ISKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPO=0) -C JSKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXO IF JSKIPO=0) -C KSKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT GRID FIELDS -C (DEFAULTS TO IMAXO*JMAXO IF KSKIPO=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C GRIDI - REAL (*) INPUT GRID FIELDS -C OUTPUT ARGUMENTS: -C GRIDO - REAL (*) OUTPUT GRID FIELDS -C (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE) -C -C SUBPROGRAMS CALLED: -C SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL GRIDI(*),GRIDO(*) - REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM INPUT GRID TO WAVE - JC=JCPU - IF(JC.EQ.0) JC=NCPUS() - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MDIM=2*MX+1 - JN=-JSKIPI - IF(JN.EQ.0) JN=IMAXI - JS=-JN - INP=(JMAXI-1)*MAX(0,-JN)+1 - ISP=(JMAXI-1)*MAX(0,-JS)+1 - CALL SPTRAN(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX, - & IPRIME,ISKIPI,JN,JS,MDIM,KSKIPI,0,0,JC, - & W,GRIDI(INP),GRIDI(ISP),-1) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT - JN=-JSKIPO - IF(JN.EQ.0) JN=IMAXO - JS=-JN - INP=(JMAXO-1)*MAX(0,-JN)+1 - ISP=(JMAXO-1)*MAX(0,-JS)+1 - CALL SPTRAN(IROMB,MAXWV,IDRTO,IMAXO,JMAXO,KMAX, - & 0,ISKIPO,JN,JS,MDIM,KSKIPO,0,0,JC, - & W,GRIDO(INP),GRIDO(ISP),1) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptrund.f b/src/fim/FIMsrc/prep/sp/sptrund.f deleted file mode 100644 index 68e1981..0000000 --- a/src/fim/FIMsrc/prep/sp/sptrund.f +++ /dev/null @@ -1,121 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTRUND(IROMB,MAXWV,IDRTI,IMAXI,JMAXI, - & IDRTO,IMAXO,JMAXO,KMAX, - & IPRIME,ISKIPI,JSKIPI,KSKIPI, - & ISKIPO,JSKIPO,KSKIPO,JCPU,GRID, - & GRIDMN,GRIDX,GRIDY) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUND SPECTRALLY TRUNCATE TO GRADIENTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES SCALAR FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THEIR MEANS AND -C GRADIENTS TO A POSSIBLY DIFFERENT GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C EITHER GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C OVER ZONAL WAVENUMBER TO ENSURE REPRODUCIBILITY. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTRUND(IROMB,MAXWV,IDRTI,IMAXI,JMAXI, -C & IDRTO,IMAXO,JMAXO,KMAX, -C & IPRIME,ISKIPI,JSKIPI,KSKIPI, -C & ISKIPO,JSKIPO,KSKIPO,JCPU,GRID, -C & GRIDMN,GRIDX,GRIDY) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C IDRTO - INTEGER OUTPUT GRID IDENTIFIER -C (IDRTO=4 FOR GAUSSIAN GRID, -C IDRTO=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTO=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXO - INTEGER EVEN NUMBER OF OUTPUT LONGITUDES. -C JMAXO - INTEGER NUMBER OF OUTPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C ISKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPO=0) -C JSKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXO IF JSKIPO=0) -C KSKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT GRID FIELDS -C (DEFAULTS TO IMAXO*JMAXO IF KSKIPO=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C GRID - REAL (*) INPUT GRID FIELDS -C OUTPUT ARGUMENTS: -C GRIDMN - REAL (KMAX) OUTPUT GLOBAL MEANS -C GRIDX - REAL (*) OUTPUT X-GRADIENTS -C GRIDY - REAL (*) OUTPUT Y-GRADIENTS -C -C SUBPROGRAMS CALLED: -C SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -C SPTRAND PERFORM A GRADIENT SPHERICAL TRANSFORM -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL GRID(*),GRIDX(*),GRIDY(*) - REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM INPUT GRID TO WAVE - JC=JCPU - IF(JC.EQ.0) JC=NCPUS() - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MDIM=2*MX+1 - JN=-JSKIPI - IF(JN.EQ.0) JN=IMAXI - JS=-JN - INP=(JMAXI-1)*MAX(0,-JN)+1 - ISP=(JMAXI-1)*MAX(0,-JS)+1 - CALL SPTRAN(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX, - & IPRIME,ISKIPI,JN,JS,MDIM,KSKIPI,0,0,JC, - & W,GRID(INP),GRID(ISP),-1) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT GRADIENTS - JN=-JSKIPO - IF(JN.EQ.0) JN=IMAXO - JS=-JN - INP=(JMAXO-1)*MAX(0,-JN)+1 - ISP=(JMAXO-1)*MAX(0,-JS)+1 - CALL SPTRAND(IROMB,MAXWV,IDRTO,IMAXO,JMAXO,KMAX, - & 0,ISKIPO,JN,JS,MDIM,KSKIPO,0,0,JC, - & W,GRIDMN, - & GRIDX(INP),GRIDX(ISP),GRIDY(INP),GRIDY(ISP),1) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptrung.f b/src/fim/FIMsrc/prep/sp/sptrung.f deleted file mode 100644 index b31d9e8..0000000 --- a/src/fim/FIMsrc/prep/sp/sptrung.f +++ /dev/null @@ -1,104 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTRUNG(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,NMAX, - & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, - & NRSKIP,NGSKIP,JCPU,RLAT,RLON,GRIDI,GP) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUNG SPECTRALLY INTERPOLATE SCALARS TO STATIONS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES SCALAR FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS -C TO SPECIFIED SETS OF STATION POINTS ON THE GLOBE. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID AND POINT FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTRUNG(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,NMAX, -C & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, -C & NRSKIP,NGSKIP,JCPU,RLAT,RLON,GRIDI,GP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NMAX - INTEGER NUMBER OF STATION POINTS TO RETURN -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINT SETS -C (DEFAULTS TO NMAX IF KGSKIP=0) -C NRSKIP - INTEGER SKIP NUMBER BETWEEN STATION LATS AND LONS -C (DEFAULTS TO 1 IF NRSKIP=0) -C NGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINTS -C (DEFAULTS TO 1 IF NGSKIP=0) -C RLAT - REAL (*) STATION LATITUDES IN DEGREES -C RLON - REAL (*) STATION LONGITUDES IN DEGREES -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C GRIDI - REAL (*) INPUT GRID FIELDS -C OUTPUT ARGUMENTS: -C GP - REAL (*) STATION POINT SETS -C -C SUBPROGRAMS CALLED: -C SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -C SPTGPT TRANSFORM SPECTRAL SCALAR TO STATION POINTS -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL RLAT(*),RLON(*),GRIDI(*),GP(*) - REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM INPUT GRID TO WAVE - JC=JCPU - IF(JC.EQ.0) JC=NCPUS() - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MDIM=2*MX+1 - JN=-JSKIPI - IF(JN.EQ.0) JN=IMAXI - JS=-JN - INP=(JMAXI-1)*MAX(0,-JN)+1 - ISP=(JMAXI-1)*MAX(0,-JS)+1 - CALL SPTRAN(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX, - & IPRIME,ISKIPI,JN,JS,MDIM,KSKIPI,0,0,JC, - & W,GRIDI(INP),GRIDI(ISP),-1) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT - CALL SPTGPT(IROMB,MAXWV,KMAX,NMAX,MDIM,KGSKIP,NRSKIP,NGSKIP, - & RLAT,RLON,W,GP) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptrungv.f b/src/fim/FIMsrc/prep/sp/sptrungv.f deleted file mode 100644 index ba8f01b..0000000 --- a/src/fim/FIMsrc/prep/sp/sptrungv.f +++ /dev/null @@ -1,153 +0,0 @@ -C------------------------------------------------------------------------- - SUBROUTINE SPTRUNGV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,NMAX, - & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, - & NRSKIP,NGSKIP,JCPU,RLAT,RLON,GRIDUI,GRIDVI, - & LUV,UP,VP,LDZ,DP,ZP,LPS,PP,SP) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUNGV SPECTRALLY INTERPOLATE VECTORS TO STATIONS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES VECTORS FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS -C TO SPECIFIED SETS OF STATION POINTS ON THE GLOBE. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID AND POINT FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPTRUNGV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,NMAX, -C & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, -C & NRSKIP,NGSKIP,JCPU,RLAT,RLON,GRIDUI,GRIDVI, -C & LUV,UP,VP,LDZ,DP,ZP,LPS,PP,SP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NMAX - INTEGER NUMBER OF STATION POINTS TO RETURN -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINT SETS -C (DEFAULTS TO NMAX IF KGSKIP=0) -C NRSKIP - INTEGER SKIP NUMBER BETWEEN STATION LATS AND LONS -C (DEFAULTS TO 1 IF NRSKIP=0) -C NGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINTS -C (DEFAULTS TO 1 IF NGSKIP=0) -C RLAT - REAL (*) STATION LATITUDES IN DEGREES -C RLON - REAL (*) STATION LONGITUDES IN DEGREES -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C GRIDUI - REAL (*) INPUT GRID U-WINDS -C GRIDVI - REAL (*) INPUT GRID V-WINDS -C LUV - LOGICAL FLAG WHETHER TO RETURN WINDS -C LDZ - LOGICAL FLAG WHETHER TO RETURN DIVERGENCE AND VORTICITY -C LPS - LOGICAL FLAG WHETHER TO RETURN POTENTIAL AND STREAMFCN -C OUTPUT ARGUMENTS: -C UP - REAL (*) STATION U-WINDS IF LUV -C VP - REAL (*) STATION V-WINDS IF LUV -C DP - REAL (*) STATION DIVERGENCES IF LDZ -C ZP - REAL (*) STATION VORTICITIES IF LDZ -C PP - REAL (*) STATION POTENTIALS IF LPS -C SP - REAL (*) STATION STREAMFCNS IF LPS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTRANV PERFORM A VECTOR SPHERICAL TRANSFORM -C SPTGPT TRANSFORM SPECTRAL SCALAR TO STATION POINTS -C SPTGPTV TRANSFORM SPECTRAL VECTOR TO STATION POINTS -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - LOGICAL LUV,LDZ,LPS - REAL RLAT(*),RLON(*),GRIDUI(*),GRIDVI(*) - REAL UP(*),VP(*),DP(*),ZP(*),PP(*),SP(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - REAL WD((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) - REAL WZ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM INPUT GRID TO WAVE - JC=JCPU - IF(JC.EQ.0) JC=NCPUS() - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MDIM=2*MX+1 - JN=-JSKIPI - IF(JN.EQ.0) JN=IMAXI - JS=-JN - INP=(JMAXI-1)*MAX(0,-JN)+1 - ISP=(JMAXI-1)*MAX(0,-JS)+1 - CALL SPTRANV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX, - & IPRIME,ISKIPI,JN,JS,MDIM,KSKIPI,0,0,JC, - & WD,WZ, - & GRIDUI(INP),GRIDUI(ISP),GRIDVI(INP),GRIDVI(ISP),-1) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT WINDS - IF(LUV) THEN - CALL SPTGPTV(IROMB,MAXWV,KMAX,NMAX,MDIM,KGSKIP,NRSKIP,NGSKIP, - & RLAT,RLON,WD,WZ,UP,VP) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT DIVERGENCE AND VORTICITY - IF(LDZ) THEN - CALL SPTGPT(IROMB,MAXWV,KMAX,NMAX,MDIM,KGSKIP,NRSKIP,NGSKIP, - & RLAT,RLON,WD,DP) - CALL SPTGPT(IROMB,MAXWV,KMAX,NMAX,MDIM,KGSKIP,NRSKIP,NGSKIP, - & RLAT,RLON,WZ,ZP) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT POTENTIAL AND STREAMFUNCTION - IF(LPS) THEN - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) -C$OMP PARALLEL DO - DO K=1,KMAX - CALL SPLAPLAC(IROMB,MAXWV,ENN1,WD(1,K),WD(1,K),-1) - CALL SPLAPLAC(IROMB,MAXWV,ENN1,WZ(1,K),WZ(1,K),-1) - WD(1:2,K)=0. - WZ(1:2,K)=0. - ENDDO - CALL SPTGPT(IROMB,MAXWV,KMAX,NMAX,MDIM,KGSKIP,NRSKIP,NGSKIP, - & RLAT,RLON,WD,PP) - CALL SPTGPT(IROMB,MAXWV,KMAX,NMAX,MDIM,KGSKIP,NRSKIP,NGSKIP, - & RLAT,RLON,WZ,SP) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptrunl.f b/src/fim/FIMsrc/prep/sp/sptrunl.f deleted file mode 100644 index e150de1..0000000 --- a/src/fim/FIMsrc/prep/sp/sptrunl.f +++ /dev/null @@ -1,127 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTRUNL(IROMB,MAXWV,IDRTI,IMAXI,JMAXI, - & IDRTO,IMAXO,JMAXO,KMAX, - & IPRIME,ISKIPI,JSKIPI,KSKIPI, - & ISKIPO,JSKIPO,KSKIPO,JCPU,IDIR,GRIDI,GRIDO) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUNL SPECTRALLY TRUNCATE TO LAPLACIAN -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES SCALAR FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THEIR LAPLACIAN -C OR INVERSE TO A POSSIBLY DIFFERENT GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C EITHER GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C OVER ZONAL WAVENUMBER TO ENSURE REPRODUCIBILITY. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPTRUNL(IROMB,MAXWV,IDRTI,IMAXI,JMAXI, -C & IDRTO,IMAXO,JMAXO,KMAX, -C & IPRIME,ISKIPI,JSKIPI,KSKIPI, -C & ISKIPO,JSKIPO,KSKIPO,JCPU,IDIR,GRIDI,GRIDO) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C IDRTO - INTEGER OUTPUT GRID IDENTIFIER -C (IDRTO=4 FOR GAUSSIAN GRID, -C IDRTO=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTO=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXO - INTEGER EVEN NUMBER OF OUTPUT LONGITUDES. -C JMAXO - INTEGER NUMBER OF OUTPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C ISKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPO=0) -C JSKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXO IF JSKIPO=0) -C KSKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT GRID FIELDS -C (DEFAULTS TO IMAXO*JMAXO IF KSKIPO=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C IDIR - INTEGER FLAG -C IDIR > 0 TO TAKE LAPLACIAN -C IDIR < 0 TO TAKE INVERSE LAPLACIAN -C GRIDI - REAL (*) INPUT GRID FIELDS -C OUTPUT ARGUMENTS: -C GRIDO - REAL (*) OUTPUT GRID FIELDS -C (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE) -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL GRIDI(*),GRIDO(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM INPUT GRID TO WAVE - JC=JCPU - IF(JC.EQ.0) JC=NCPUS() - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MDIM=2*MX+1 - JN=-JSKIPI - IF(JN.EQ.0) JN=IMAXI - JS=-JN - INP=(JMAXI-1)*MAX(0,-JN)+1 - ISP=(JMAXI-1)*MAX(0,-JS)+1 - CALL SPTRAN(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX, - & IPRIME,ISKIPI,JN,JS,MDIM,KSKIPI,0,0,JC, - & W,GRIDI(INP),GRIDI(ISP),-1) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TAKE LAPLACIAN AND TRANSFORM WAVE TO OUTPUT GRID - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) -C$OMP PARALLEL DO - DO K=1,KMAX - CALL SPLAPLAC(IROMB,MAXWV,ENN1,W(1,K),W(1,K),IDIR) - W(1:2,K)=0. - ENDDO - CALL SPTRAN(IROMB,MAXWV,IDRTO,IMAXO,JMAXO,KMAX, - & 0,ISKIPO,JN,JS,MDIM,KSKIPO,0,0,JC, - & W,GRIDO(INP),GRIDO(ISP),1) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptrunm.f b/src/fim/FIMsrc/prep/sp/sptrunm.f deleted file mode 100644 index c949797..0000000 --- a/src/fim/FIMsrc/prep/sp/sptrunm.f +++ /dev/null @@ -1,117 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTRUNM(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,MI,MJ, - & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, - & NISKIP,NJSKIP,JCPU,RLAT1,RLON1,DLAT,DLON, - & GRIDI,GM) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUNM SPECTRALLY INTERPOLATE SCALARS TO MERCATOR -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES SCALAR FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS -C TO A MERCATOR GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTRUNM(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,MI,MJ, -C & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, -C & NISKIP,NJSKIP,JCPU,RLAT1,RLON1,DLAT,DLON, -C & GRIDI,GM) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C MI - INTEGER NUMBER OF POINTS IN THE FASTER ZONAL DIRECTION -C MJ - INTEGER NUMBER OF POINTS IN THE SLOWER MERID DIRECTION -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO NPS*NPS IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO NPS IF NJSKIP=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C RLAT1 - REAL LATITUDE OF THE FIRST GRID POINT IN DEGREES -C RLON1 - REAL LONGITUDE OF THE FIRST GRID POINT IN DEGREES -C DLAT - REAL LATITUDE INCREMENT IN DEGREES SUCH THAT -C D(PHI)/D(J)=DLAT*COS(PHI) WHERE J IS MERIDIONAL INDEX. -C DLAT IS NEGATIVE FOR GRIDS INDEXED SOUTHWARD. -C (IN TERMS OF GRID INCREMENT DY VALID AT LATITUDE RLATI, -C THE LATITUDE INCREMENT DLAT IS DETERMINED AS -C DLAT=DPR*DY/(RERTH*COS(RLATI/DPR)) -C WHERE DPR=180/PI AND RERTH IS EARTH'S RADIUS) -C DLON - REAL LONGITUDE INCREMENT IN DEGREES SUCH THAT -C D(LAMBDA)/D(I)=DLON WHERE I IS ZONAL INDEX. -C DLON IS NEGATIVE FOR GRIDS INDEXED WESTWARD. -C GRIDI - REAL (*) INPUT GRID FIELDS -C OUTPUT ARGUMENTS: -C GM - REAL (*) MERCATOR FIELDS -C -C SUBPROGRAMS CALLED: -C SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -C SPTGPM TRANSFORM SPECTRAL SCALAR TO MERCATOR -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL GRIDI(*),GM(*) - REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM INPUT GRID TO WAVE - JC=JCPU - IF(JC.EQ.0) JC=NCPUS() - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MDIM=2*MX+1 - JN=-JSKIPI - IF(JN.EQ.0) JN=IMAXI - JS=-JN - INP=(JMAXI-1)*MAX(0,-JN)+1 - ISP=(JMAXI-1)*MAX(0,-JS)+1 - CALL SPTRAN(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX, - & IPRIME,ISKIPI,JN,JS,MDIM,KSKIPI,0,0,JC, - & W,GRIDI(INP),GRIDI(ISP),-1) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT - CALL SPTGPM(IROMB,MAXWV,KMAX,MI,MJ,MDIM,KGSKIP,NISKIP,NJSKIP, - & RLAT1,RLON1,DLAT,DLON,W,GM) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptrunmv.f b/src/fim/FIMsrc/prep/sp/sptrunmv.f deleted file mode 100644 index e32a738..0000000 --- a/src/fim/FIMsrc/prep/sp/sptrunmv.f +++ /dev/null @@ -1,165 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTRUNMV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,MI,MJ, - & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, - & NISKIP,NJSKIP,JCPU,RLAT1,RLON1,DLAT,DLON, - & GRIDUI,GRIDVI,LUV,UM,VM,LDZ,DM,ZM,LPS,PM,SM) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUNMV SPECTRALLY INTERPOLATE VECTORS TO MERCATOR -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES VECTOR FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS -C TO A MERCATOR GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPTRUNMV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,MI,MJ, -C & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, -C & NISKIP,NJSKIP,JCPU,RLAT1,RLON1,DLAT,DLON, -C & GRIDUI,GRIDVI,LUV,UM,VM,LDZ,DM,ZM,LPS,PM,SM) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C MI - INTEGER NUMBER OF POINTS IN THE FASTER ZONAL DIRECTION -C MJ - INTEGER NUMBER OF POINTS IN THE SLOWER MERID DIRECTION -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO MI*MJ IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO MI IF NJSKIP=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C RLAT1 - REAL LATITUDE OF THE FIRST GRID POINT IN DEGREES -C RLON1 - REAL LONGITUDE OF THE FIRST GRID POINT IN DEGREES -C DLAT - REAL LATITUDE INCREMENT IN DEGREES SUCH THAT -C D(PHI)/D(J)=DLAT*COS(PHI) WHERE J IS MERIDIONAL INDEX. -C DLAT IS NEGATIVE FOR GRIDS INDEXED SOUTHWARD. -C (IN TERMS OF GRID INCREMENT DY VALID AT LATITUDE RLATI, -C THE LATITUDE INCREMENT DLAT IS DETERMINED AS -C DLAT=DPR*DY/(RERTH*COS(RLATI/DPR)) -C WHERE DPR=180/PI AND RERTH IS EARTH'S RADIUS) -C DLON - REAL LONGITUDE INCREMENT IN DEGREES SUCH THAT -C D(LAMBDA)/D(I)=DLON WHERE I IS ZONAL INDEX. -C DLON IS NEGATIVE FOR GRIDS INDEXED WESTWARD. -C GRIDUI - REAL (*) INPUT GRID U-WINDS -C GRIDVI - REAL (*) INPUT GRID V-WINDS -C LUV - LOGICAL FLAG WHETHER TO RETURN WINDS -C LDZ - LOGICAL FLAG WHETHER TO RETURN DIVERGENCE AND VORTICITY -C LPS - LOGICAL FLAG WHETHER TO RETURN POTENTIAL AND STREAMFCN -C OUTPUT ARGUMENTS: -C UM - REAL (*) MERCATOR U-WINDS IF LUV -C VM - REAL (*) MERCATOR V-WINDS IF LUV -C DM - REAL (*) MERCATOR DIVERGENCES IF LDZ -C ZM - REAL (*) MERCATOR VORTICITIES IF LDZ -C PM - REAL (*) MERCATOR POTENTIALS IF LPS -C SM - REAL (*) MERCATOR STREAMFCNS IF LPS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTRANV PERFORM A VECTOR SPHERICAL TRANSFORM -C SPTGPM TRANSFORM SPECTRAL SCALAR TO MERCATOR -C SPTGPMV TRANSFORM SPECTRAL VECTOR TO MERCATOR -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - LOGICAL LUV,LDZ,LPS - REAL GRIDUI(*),GRIDVI(*) - REAL UM(*),VM(*),DM(*),ZM(*),PM(*),SM(*) - REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - REAL WD((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) - REAL WZ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM INPUT GRID TO WAVE - JC=JCPU - IF(JC.EQ.0) JC=NCPUS() - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MDIM=2*MX+1 - JN=-JSKIPI - IF(JN.EQ.0) JN=IMAXI - JS=-JN - INP=(JMAXI-1)*MAX(0,-JN)+1 - ISP=(JMAXI-1)*MAX(0,-JS)+1 - CALL SPTRANV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX, - & IPRIME,ISKIPI,JN,JS,MDIM,KSKIPI,0,0,JC, - & WD,WZ, - & GRIDUI(INP),GRIDUI(ISP),GRIDVI(INP),GRIDVI(ISP),-1) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT WINDS - IF(LUV) THEN - CALL SPTGPMV(IROMB,MAXWV,KMAX,MI,MJ,MDIM,KGSKIP,NISKIP,NJSKIP, - & RLAT1,RLON1,DLAT,DLON,WD,WZ,UM,VM) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT DIVERGENCE AND VORTICITY - IF(LDZ) THEN - CALL SPTGPM(IROMB,MAXWV,KMAX,MI,MJ,MDIM,KGSKIP,NISKIP,NJSKIP, - & RLAT1,RLON1,DLAT,DLON,WD,DM) - CALL SPTGPM(IROMB,MAXWV,KMAX,MI,MJ,MDIM,KGSKIP,NISKIP,NJSKIP, - & RLAT1,RLON1,DLAT,DLON,WZ,ZM) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT POTENTIAL AND STREAMFUNCTION - IF(LPS) THEN - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) -C$OMP PARALLEL DO - DO K=1,KMAX - CALL SPLAPLAC(IROMB,MAXWV,ENN1,WD(1,K),WD(1,K),-1) - CALL SPLAPLAC(IROMB,MAXWV,ENN1,WZ(1,K),WZ(1,K),-1) - WD(1:2,K)=0. - WZ(1:2,K)=0. - ENDDO - CALL SPTGPM(IROMB,MAXWV,KMAX,MI,MJ,MDIM,KGSKIP,NISKIP,NJSKIP, - & RLAT1,RLON1,DLAT,DLON,WD,PM) - CALL SPTGPM(IROMB,MAXWV,KMAX,MI,MJ,MDIM,KGSKIP,NISKIP,NJSKIP, - & RLAT1,RLON1,DLAT,DLON,WZ,SM) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptruns.f b/src/fim/FIMsrc/prep/sp/sptruns.f deleted file mode 100644 index a12bdc8..0000000 --- a/src/fim/FIMsrc/prep/sp/sptruns.f +++ /dev/null @@ -1,109 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTRUNS(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,NPS, - & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, - & NISKIP,NJSKIP,JCPU,TRUE,XMESH,ORIENT, - & GRIDI,GN,GS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUNS SPECTRALLY INTERPOLATE SCALARS TO POLAR STEREO -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES SCALAR FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS -C TO SPECIFIC PAIRS OF POLAR STEREOGRAPHIC SCALAR FIELDS. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTRUNS(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,NPS, -C & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, -C & NISKIP,NJSKIP,JCPU,TRUE,XMESH,ORIENT, -C & GRIDI,GN,GS) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NPS - INTEGER ODD ORDER OF THE POLAR STEREOGRAPHIC GRIDS -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO NPS*NPS IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO NPS IF NJSKIP=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C TRUE - REAL LATITUDE AT WHICH PS GRID IS TRUE (USUALLY 60.) -C XMESH - REAL GRID LENGTH AT TRUE LATITUDE (M) -C ORIENT - REAL LONGITUDE AT BOTTOM OF NORTHERN PS GRID -C (SOUTHERN PS GRID WILL HAVE OPPOSITE ORIENTATION.) -C GRIDI - REAL (*) INPUT GRID FIELDS -C OUTPUT ARGUMENTS: -C GN - REAL (*) NORTHERN POLAR STEREOGRAPHIC FIELDS -C GS - REAL (*) SOUTHERN POLAR STEREOGRAPHIC FIELDS -C -C SUBPROGRAMS CALLED: -C SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -C SPTGPS TRANSFORM SPECTRAL SCALAR TO POLAR STEREO. -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL GRIDI(*),GN(*),GS(*) - REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM INPUT GRID TO WAVE - JC=JCPU - IF(JC.EQ.0) JC=NCPUS() - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MDIM=2*MX+1 - JN=-JSKIPI - IF(JN.EQ.0) JN=IMAXI - JS=-JN - INP=(JMAXI-1)*MAX(0,-JN)+1 - ISP=(JMAXI-1)*MAX(0,-JS)+1 - CALL SPTRAN(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX, - & IPRIME,ISKIPI,JN,JS,MDIM,KSKIPI,0,0,JC, - & W,GRIDI(INP),GRIDI(ISP),-1) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT - CALL SPTGPS(IROMB,MAXWV,KMAX,NPS,MDIM,KGSKIP,NISKIP,NJSKIP, - & TRUE,XMESH,ORIENT,W,GN,GS) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptrunsv.f b/src/fim/FIMsrc/prep/sp/sptrunsv.f deleted file mode 100644 index cfdfe4a..0000000 --- a/src/fim/FIMsrc/prep/sp/sptrunsv.f +++ /dev/null @@ -1,166 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTRUNSV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,NPS, - & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, - & NISKIP,NJSKIP,JCPU,TRUE,XMESH,ORIENT, - & GRIDUI,GRIDVI, - & LUV,UN,VN,US,VS,LDZ,DN,ZN,DS,ZS, - & LPS,PN,SN,PS,SS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUNSV SPECTRALLY INTERPOLATE VECTORS TO POLAR STEREO -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES VECTOR FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS -C TO SPECIFIC PAIRS OF POLAR STEREOGRAPHIC SCALAR FIELDS. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPTRUNSV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,NPS, -C & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, -C & NISKIP,NJSKIP,JCPU,TRUE,XMESH,ORIENT, -C & GRIDUI,GRIDVI, -C & LUV,UN,VN,US,VS,LDZ,DN,ZN,DS,ZS, -C & LPS,PN,SN,PS,SS) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NPS - INTEGER ODD ORDER OF THE POLAR STEREOGRAPHIC GRIDS -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO NPS*NPS IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO NPS IF NJSKIP=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C TRUE - REAL LATITUDE AT WHICH PS GRID IS TRUE (USUALLY 60.) -C XMESH - REAL GRID LENGTH AT TRUE LATITUDE (M) -C ORIENT - REAL LONGITUDE AT BOTTOM OF NORTHERN PS GRID -C (SOUTHERN PS GRID WILL HAVE OPPOSITE ORIENTATION.) -C GRIDUI - REAL (*) INPUT GRID U-WINDS -C GRIDVI - REAL (*) INPUT GRID V-WINDS -C LUV - LOGICAL FLAG WHETHER TO RETURN WINDS -C LDZ - LOGICAL FLAG WHETHER TO RETURN DIVERGENCE AND VORTICITY -C LPS - LOGICAL FLAG WHETHER TO RETURN POTENTIAL AND STREAMFCN -C OUTPUT ARGUMENTS: -C UN - REAL (*) NORTHERN PS U-WINDS IF LUV -C VN - REAL (*) NORTHERN PS V-WINDS IF LUV -C US - REAL (*) SOUTHERN PS U-WINDS IF LUV -C VS - REAL (*) SOUTHERN PS V-WINDS IF LUV -C DN - REAL (*) NORTHERN DIVERGENCES IF LDZ -C ZN - REAL (*) NORTHERN VORTICITIES IF LDZ -C DS - REAL (*) SOUTHERN DIVERGENCES IF LDZ -C ZS - REAL (*) SOUTHERN VORTICITIES IF LDZ -C PN - REAL (*) NORTHERN POTENTIALS IF LPS -C SN - REAL (*) NORTHERN STREAMFCNS IF LPS -C PS - REAL (*) SOUTHERN POTENTIALS IF LPS -C SS - REAL (*) SOUTHERN STREAMFCNS IF LPS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTRANV PERFORM A VECTOR SPHERICAL TRANSFORM -C SPTGPS TRANSFORM SPECTRAL SCALAR TO POLAR STEREO. -C SPTGPSV TRANSFORM SPECTRAL VECTOR TO POLAR STEREO. -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - LOGICAL LUV,LDZ,LPS - REAL GRIDUI(*),GRIDVI(*) - REAL UN(*),VN(*),US(*),VS(*),DN(*),ZN(*),DS(*),ZS(*) - REAL PN(*),SN(*),PS(*),SS(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - REAL WD((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) - REAL WZ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM INPUT GRID TO WAVE - JC=JCPU - IF(JC.EQ.0) JC=NCPUS() - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MDIM=2*MX+1 - JN=-JSKIPI - IF(JN.EQ.0) JN=IMAXI - JS=-JN - INP=(JMAXI-1)*MAX(0,-JN)+1 - ISP=(JMAXI-1)*MAX(0,-JS)+1 - CALL SPTRANV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX, - & IPRIME,ISKIPI,JN,JS,MDIM,KSKIPI,0,0,JC, - & WD,WZ, - & GRIDUI(INP),GRIDUI(ISP),GRIDVI(INP),GRIDVI(ISP),-1) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT WINDS - IF(LUV) THEN - CALL SPTGPSV(IROMB,MAXWV,KMAX,NPS,MDIM,KGSKIP,NISKIP,NJSKIP, - & TRUE,XMESH,ORIENT,WD,WZ,UN,VN,US,VS) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT DIVERGENCE AND VORTICITY - IF(LDZ) THEN - CALL SPTGPS(IROMB,MAXWV,KMAX,NPS,MDIM,KGSKIP,NISKIP,NJSKIP, - & TRUE,XMESH,ORIENT,WD,DN,DS) - CALL SPTGPS(IROMB,MAXWV,KMAX,NPS,MDIM,KGSKIP,NISKIP,NJSKIP, - & TRUE,XMESH,ORIENT,WZ,ZN,ZS) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT POTENTIAL AND STREAMFUNCTION - IF(LPS) THEN - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) -C$OMP PARALLEL DO - DO K=1,KMAX - CALL SPLAPLAC(IROMB,MAXWV,ENN1,WD(1,K),WD(1,K),-1) - CALL SPLAPLAC(IROMB,MAXWV,ENN1,WZ(1,K),WZ(1,K),-1) - WD(1:2,K)=0. - WZ(1:2,K)=0. - ENDDO - CALL SPTGPS(IROMB,MAXWV,KMAX,NPS,MDIM,KGSKIP,NISKIP,NJSKIP, - & TRUE,XMESH,ORIENT,WD,PN,PS) - CALL SPTGPS(IROMB,MAXWV,KMAX,NPS,MDIM,KGSKIP,NISKIP,NJSKIP, - & TRUE,XMESH,ORIENT,WZ,SN,SS) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/sptrunv.f b/src/fim/FIMsrc/prep/sp/sptrunv.f deleted file mode 100644 index 9563868..0000000 --- a/src/fim/FIMsrc/prep/sp/sptrunv.f +++ /dev/null @@ -1,177 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTRUNV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI, - & IDRTO,IMAXO,JMAXO,KMAX, - & IPRIME,ISKIPI,JSKIPI,KSKIPI, - & ISKIPO,JSKIPO,KSKIPO,JCPU,GRIDUI,GRIDVI, - & LUV,GRIDUO,GRIDVO,LDZ,GRIDDO,GRIDZO, - & LPS,GRIDPO,GRIDSO) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUNV SPECTRALLY TRUNCATE GRIDDED VECTOR FIELDS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES VECTOR FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS -C TO A POSSIBLY DIFFERENT GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C EITHER GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C OVER ZONAL WAVENUMBER TO ENSURE REPRODUCIBILITY. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPTRUNV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI, -C & IDRTO,IMAXO,JMAXO,KMAX, -C & IPRIME,ISKIPI,JSKIPI,KSKIPI, -C & ISKIPO,JSKIPO,KSKIPO,JCPU,GRIDUI,GRIDVI, -C & LUV,GRIDUO,GRIDVO,LDZ,GRIDDO,GRIDZO, -C & LPS,GRIDPO,GRIDSO) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C IDRTO - INTEGER OUTPUT GRID IDENTIFIER -C (IDRTO=4 FOR GAUSSIAN GRID, -C IDRTO=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTO=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXO - INTEGER EVEN NUMBER OF OUTPUT LONGITUDES. -C JMAXO - INTEGER NUMBER OF OUTPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C ISKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPO=0) -C JSKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXO IF JSKIPO=0) -C KSKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT GRID FIELDS -C (DEFAULTS TO IMAXO*JMAXO IF KSKIPO=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C GRIDUI - REAL (*) INPUT GRID U-WINDS -C GRIDVI - REAL (*) INPUT GRID V-WINDS -C LUV - LOGICAL FLAG WHETHER TO RETURN WINDS -C LDZ - LOGICAL FLAG WHETHER TO RETURN DIVERGENCE AND VORTICITY -C LPS - LOGICAL FLAG WHETHER TO RETURN POTENTIAL AND STREAMFCN -C OUTPUT ARGUMENTS: -C GRIDUO - REAL (*) OUTPUT U-WINDS IF LUV -C (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE) -C GRIDVO - REAL (*) OUTPUT V-WINDS IF LUV -C (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE) -C GRIDDO - REAL (*) OUTPUT DIVERGENCES IF LDZ -C (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE) -C GRIDZO - REAL (*) OUTPUT VORTICITIES IF LDZ -C (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE) -C GRIDPO - REAL (*) OUTPUT POTENTIALS IF LPS -C (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE) -C GRIDSO - REAL (*) OUTPUT STREAMFCNS IF LPS -C (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE) -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -C SPTRANV PERFORM A VECTOR SPHERICAL TRANSFORM -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - LOGICAL LUV,LDZ,LPS - REAL GRIDUI(*),GRIDVI(*) - REAL GRIDUO(*),GRIDVO(*),GRIDDO(*),GRIDZO(*),GRIDPO(*),GRIDSO(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - REAL WD((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) - REAL WZ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM INPUT GRID TO WAVE - JC=JCPU - IF(JC.EQ.0) JC=NCPUS() - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MDIM=2*MX+1 - JN=-JSKIPI - IF(JN.EQ.0) JN=IMAXI - JS=-JN - INP=(JMAXI-1)*MAX(0,-JN)+1 - ISP=(JMAXI-1)*MAX(0,-JS)+1 - CALL SPTRANV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX, - & IPRIME,ISKIPI,JN,JS,MDIM,KSKIPI,0,0,JC, - & WD,WZ, - & GRIDUI(INP),GRIDUI(ISP),GRIDVI(INP),GRIDVI(ISP),-1) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT WINDS - JN=-JSKIPO - IF(JN.EQ.0) JN=IMAXO - JS=-JN - INP=(JMAXO-1)*MAX(0,-JN)+1 - ISP=(JMAXO-1)*MAX(0,-JS)+1 - IF(LUV) THEN - CALL SPTRANV(IROMB,MAXWV,IDRTO,IMAXO,JMAXO,KMAX, - & 0,ISKIPO,JN,JS,MDIM,KSKIPO,0,0,JC, - & WD,WZ, - & GRIDUO(INP),GRIDUO(ISP),GRIDVO(INP),GRIDVO(ISP),1) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT DIVERGENCE AND VORTICITY - IF(LDZ) THEN - CALL SPTRAN(IROMB,MAXWV,IDRTO,IMAXO,JMAXO,KMAX, - & 0,ISKIPO,JN,JS,MDIM,KSKIPO,0,0,JC, - & WD,GRIDDO(INP),GRIDDO(ISP),1) - CALL SPTRAN(IROMB,MAXWV,IDRTO,IMAXO,JMAXO,KMAX, - & 0,ISKIPO,JN,JS,MDIM,KSKIPO,0,0,JC, - & WZ,GRIDZO(INP),GRIDZO(ISP),1) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT POTENTIAL AND STREAMFUNCTION - IF(LPS) THEN - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) -C$OMP PARALLEL DO - DO K=1,KMAX - CALL SPLAPLAC(IROMB,MAXWV,ENN1,WD(1,K),WD(1,K),-1) - CALL SPLAPLAC(IROMB,MAXWV,ENN1,WZ(1,K),WZ(1,K),-1) - WD(1:2,K)=0. - WZ(1:2,K)=0. - ENDDO - CALL SPTRAN(IROMB,MAXWV,IDRTO,IMAXO,JMAXO,KMAX, - & 0,ISKIPO,JN,JS,MDIM,KSKIPO,0,0,JC, - & WD,GRIDPO(INP),GRIDPO(ISP),1) - CALL SPTRAN(IROMB,MAXWV,IDRTO,IMAXO,JMAXO,KMAX, - & 0,ISKIPO,JN,JS,MDIM,KSKIPO,0,0,JC, - & WZ,GRIDSO(INP),GRIDSO(ISP),1) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/prep/sp/spuv2dz.f b/src/fim/FIMsrc/prep/sp/spuv2dz.f deleted file mode 100644 index 573a237..0000000 --- a/src/fim/FIMsrc/prep/sp/spuv2dz.f +++ /dev/null @@ -1,94 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPUV2DZ(I,M,ENN1,ELONN1,EON,EONTOP,U,V,UTOP,VTOP,D,Z) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPUV2DZ COMPUTE DIVERGENCE AND VORTICITY FROM WINDS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: COMPUTES THE DIVERGENCE AND VORTICITY FROM WIND COMPONENTS -C IN SPECTRAL SPACE. -C SUBPROGRAM SPEPS SHOULD BE CALLED ALREADY. -C IF L IS THE ZONAL WAVENUMBER, N IS THE TOTAL WAVENUMBER, -C EPS(L,N)=SQRT((N**2-L**2)/(4*N**2-1)) AND A IS EARTH RADIUS, -C THEN THE DIVERGENCE D IS COMPUTED AS -C D(L,N)=I*L*A*U(L,N) -C +EPS(L,N+1)*N*A*V(L,N+1)-EPS(L,N)*(N+1)*A*V(L,N-1) -C AND THE VORTICITY Z IS COMPUTED AS -C Z(L,N)=I*L*A*V(L,N) -C -EPS(L,N+1)*N*A*U(L,N+1)+EPS(L,N)*(N+1)*A*U(L,N-1) -C WHERE U IS THE ZONAL WIND AND V IS THE MERIDIONAL WIND. -C U AND V ARE WEIGHTED BY THE SECANT OF LATITUDE. -C EXTRA TERMS ARE USED OVER TOP OF THE SPECTRAL DOMAIN. -C ADVANTAGE IS TAKEN OF THE FACT THAT EPS(L,L)=0 -C IN ORDER TO VECTORIZE OVER THE ENTIRE SPECTRAL DOMAIN. -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C -C USAGE: CALL SPUV2DZ(I,M,ENN1,ELONN1,EON,EONTOP,U,V,UTOP,VTOP,D,Z) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C ENN1 - REAL ((M+1)*((I+1)*M+2)/2) N*(N+1)/A**2 -C ELONN1 - REAL ((M+1)*((I+1)*M+2)/2) L/(N*(N+1))*A -C EON - REAL ((M+1)*((I+1)*M+2)/2) EPSILON/N*A -C EONTOP - REAL (M+1) EPSILON/N*A OVER TOP -C U - REAL ((M+1)*((I+1)*M+2)) ZONAL WIND (OVER COSLAT) -C V - REAL ((M+1)*((I+1)*M+2)) MERID WIND (OVER COSLAT) -C UTOP - REAL (2*(M+1)) ZONAL WIND (OVER COSLAT) OVER TOP -C VTOP - REAL (2*(M+1)) MERID WIND (OVER COSLAT) OVER TOP -C -C OUTPUT ARGUMENT LIST: -C D - REAL ((M+1)*((I+1)*M+2)) DIVERGENCE -C Z - REAL ((M+1)*((I+1)*M+2)) VORTICITY -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - REAL ENN1((M+1)*((I+1)*M+2)/2),ELONN1((M+1)*((I+1)*M+2)/2) - REAL EON((M+1)*((I+1)*M+2)/2),EONTOP(M+1) - REAL U((M+1)*((I+1)*M+2)),V((M+1)*((I+1)*M+2)) - REAL UTOP(2*(M+1)),VTOP(2*(M+1)) - REAL D((M+1)*((I+1)*M+2)),Z((M+1)*((I+1)*M+2)) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COMPUTE TERMS FROM THE SPECTRAL DOMAIN - K=1 - D(2*K-1)=0. - D(2*K)=0. - Z(2*K-1)=0. - Z(2*K)=0. - DO K=2,(M+1)*((I+1)*M+2)/2-1 - D(2*K-1)=-ELONN1(K)*U(2*K)+EON(K+1)*V(2*K+1)-EON(K)*V(2*K-3) - D(2*K)=ELONN1(K)*U(2*K-1)+EON(K+1)*V(2*K+2)-EON(K)*V(2*K-2) - Z(2*K-1)=-ELONN1(K)*V(2*K)-EON(K+1)*U(2*K+1)+EON(K)*U(2*K-3) - Z(2*K)=ELONN1(K)*V(2*K-1)-EON(K+1)*U(2*K+2)+EON(K)*U(2*K-2) - ENDDO - K=(M+1)*((I+1)*M+2)/2 - D(2*K-1)=-ELONN1(K)*U(2*K)-EON(K)*V(2*K-3) - D(2*K)=ELONN1(K)*U(2*K-1)-EON(K)*V(2*K-2) - Z(2*K-1)=-ELONN1(K)*V(2*K)+EON(K)*U(2*K-3) - Z(2*K)=ELONN1(K)*V(2*K-1)+EON(K)*U(2*K-2) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COMPUTE TERMS FROM OVER TOP OF THE SPECTRAL DOMAIN -CDIR$ IVDEP - DO L=0,M - K=L*(2*M+(I-1)*(L-1))/2+I*L+M+1 - D(2*K-1)=D(2*K-1)+EONTOP(L+1)*VTOP(2*L+1) - D(2*K)=D(2*K)+EONTOP(L+1)*VTOP(2*L+2) - Z(2*K-1)=Z(2*K-1)-EONTOP(L+1)*UTOP(2*L+1) - Z(2*K)=Z(2*K)-EONTOP(L+1)*UTOP(2*L+2) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C MULTIPLY BY LAPLACIAN TERM - DO K=2,(M+1)*((I+1)*M+2)/2 - D(2*K-1)=D(2*K-1)*ENN1(K) - D(2*K)=D(2*K)*ENN1(K) - Z(2*K-1)=Z(2*K-1)*ENN1(K) - Z(2*K)=Z(2*K)*ENN1(K) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/prep/sp/spvar.f b/src/fim/FIMsrc/prep/sp/spvar.f deleted file mode 100644 index 87187e9..0000000 --- a/src/fim/FIMsrc/prep/sp/spvar.f +++ /dev/null @@ -1,48 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPVAR(I,M,Q,QVAR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPVAR COMPUTE VARIANCE BY TOTAL WAVENUMBER -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: COMPUTES THE VARIANCES BY TOTAL WAVENUMBER -C OF A SCALAR FIELD IN SPECTRAL SPACE. -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C -C USAGE: CALL SPVAR(I,M,Q,QVAR) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C Q - REAL ((M+1)*((I+1)*M+2)) SCALAR FIELD -C -C OUTPUT ARGUMENT LIST: -C QVAR - REAL (0:(I+1)*M) VARIANCES -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - REAL Q((M+1)*((I+1)*M+2)) - REAL QVAR(0:(I+1)*M) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - L=0 - DO N=0,M - KS=L*(2*M+(I-1)*(L-1))+2*N - QVAR(N)=0.5*Q(KS+1)**2 - ENDDO - DO N=M+1,(I+1)*M - QVAR(N)=0. - ENDDO - DO N=0,(I+1)*M - DO L=MAX(1,N-M),MIN(N,M) - KS=L*(2*M+(I-1)*(L-1))+2*N - QVAR(N)=QVAR(N)+Q(KS+1)**2+Q(KS+2)**2 - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/prep/sp/spwget.f b/src/fim/FIMsrc/prep/sp/spwget.f deleted file mode 100644 index 171a8b4..0000000 --- a/src/fim/FIMsrc/prep/sp/spwget.f +++ /dev/null @@ -1,41 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPWGET GET WAVE-SPACE CONSTANTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM GETS WAVE-SPACE CONSTANTS. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C OUTPUT ARGUMENTS: -C EPS - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) -C EPSTOP - REAL (MAXWV+1) -C ENN1 - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) -C ELONN1 - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) -C EON - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) -C EONTOP - REAL (MAXWV+1) -C -C SUBPROGRAMS CALLED: -C SPEPS COMPUTE UTILITY SPECTRAL FIELDS -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MXTOP=MAXWV+1 - CALL SPEPS(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) - END diff --git a/src/fim/FIMsrc/prep/ss2icos/fimini.F90 b/src/fim/FIMsrc/prep/ss2icos/fimini.F90 deleted file mode 100644 index 802c823..0000000 --- a/src/fim/FIMsrc/prep/ss2icos/fimini.F90 +++ /dev/null @@ -1,265 +0,0 @@ - -!********************************************************************* -! fimini -! Initialization subroutine to restep/remap GFS data for FIM -! initial condition. -! -! R. Bleck April,2007 -! J. Lee July,2007 -! R. Bleck Aug. 2008 -!********************************************************************* - - subroutine fimini(nlyr,ter_in,psf_in,gz_in,p_in,t_in,q_in, & - u_in,v_in,o3_in,qc_in, & - us3d,vs3d,dp3d,mp3d,pr3d,ex3d,ph3d,tr3d) - - use module_control ,only: nip,nvl,nvlp1,glvl,kbl,ntra,ntrb,npp, & - PrintDiags,PrintIpnDiag,pure_sig,EnKFAnl - use module_constants,only: p1000,rd,cp,qvmin,deg_lat - use findmaxmin2 - use findmaxmin3 - - implicit none - integer,intent(IN) :: nlyr ! number of input layers -!SMS$DISTRIBUTE(dh,NIP) BEGIN - real,intent(IN ) :: ter_in( nip) ! surface geopotential - real,intent(IN ) :: psf_in( nip) ! surface pressure - real,intent(IN ) :: gz_in(nlyr+1,nip) ! geopotential - real,intent(IN ) :: p_in (nlyr+1,nip) ! interface pressure - real,intent(IN ) :: t_in (nlyr ,nip) ! layer temperature - real,intent(IN ) :: q_in (nlyr ,nip) ! layer rel humid - real,intent(IN ) :: qc_in (nlyr ,nip) ! layer cloud condensate - real,intent(IN ) :: u_in (nlyr ,nip) ! layer u wind - real,intent(IN ) :: v_in (nlyr ,nip) ! layer v wind - real,intent(IN ) :: o3_in(nlyr ,nip) ! layer ozone - real,intent(OUT) :: us3d (nvl ,nip) ! zonal wind (m/s), layer - real,intent(OUT) :: vs3d (nvl ,nip) ! meridional wind (m/s), layer - real,intent(OUT) :: dp3d (nvl ,nip) ! layer thickness (pascal) - real,intent(OUT) :: mp3d (nvl ,nip) ! Montgomery Potential (m^2/s^2) - real,intent(OUT) :: pr3d (nvlp1 ,nip) ! pressure (pascal) - real,intent(OUT) :: ex3d (nvlp1 ,nip) ! exner function - real,intent(OUT) :: ph3d (nvlp1 ,nip) ! geopotential (=gz), m^2/s^2 - real,intent(OUT) :: tr3d (nvl ,nip,ntra+ntrb)! 1=pot.temp - ! 2=water vapor - ! 3=cloud water/condensate - ! 4=ozone - - real, dimension(nvl ,nip) :: uswrk,vswrk,thwrk,qvwrk,o3wrk,qcwrk - real, dimension(nvlp1,nip) :: exwrk - -! --- variables on spherical grid in sigma layers: - real :: th_in (nlyr,nip) - real :: targ_in(nvl,nip) - -! --- variables on spherical grid at sigma levels: - real :: exlev_in(nlyr+1,nip) - -!SMS$DISTRIBUTE END - - integer :: ipn - integer :: k,k1,k2 - - real :: theta_lyrs(nvl) - real :: ex_top - - character(len=16) :: string - logical :: vrbos ! switch for 'verbose' mode - -!<><><><><><><><><><><><><><>><><><><><><><><><><><><><><><><><><><><><><> -! e x t e r n a l g r i d d e d d a t a i n g e s t -! f o r F I M i n i t i a l c o n d i t i o n s -!<><><><><><><><><><><><><><>><><><><><><><><><><><><><><><><><><><><><><> - -!SMS$PARALLEL (dh,ipn) BEGIN - - open(10, file="theta_coor.txt",form="formatted",action="read") - read(10,*) theta_lyrs(1:nvl) - close(10) - -! --- diagnostic output - if (PrintDiags) then -!SMS$SERIAL BEGIN - print 102,'terrain hgt min,max:',minval(ter_in),maxval(ter_in) - print 102,'surface prs min,max:',minval(psf_in),maxval(psf_in) - print 102,'geopot min,max:',minval(gz_in),maxval(gz_in) - print 102,'pressure min,max:',minval(p_in),maxval(p_in) - print 102,'temperature min,max:',minval(t_in),maxval(t_in) - print 102,'moisture min,max:',minval(q_in),maxval(q_in) - print 102,'condensate min,max:',minval(qc_in),maxval(qc_in) - print 102,'u velocity min,max:',minval(u_in),maxval(u_in) - print 102,'v velocity min,max:',minval(v_in),maxval(v_in) - print 102,' O3 min,max:',minval(o3_in),maxval(o3_in) -!SMS$SERIAL END - end if -102 format (a,2es15.5) - -! --- compute Exner function and potential temperature in input layers - - do ipn = 1, nip ! horizontal loop - vrbos=ipn.eq.PrintIpnDiag - - do k = 1, nlyr+1 - exlev_in(k,ipn)=cp*(p_in(k,ipn)/p1000)**(rd/cp) - end do - -! --- infer virt.pot.temperature from geopotential and Exner fct - do k=1,nlyr - if (exlev_in(k,ipn).gt.exlev_in(k+1,ipn)+.01) then - th_in(k,ipn)=(gz_in(k+1,ipn)-gz_in(k,ipn)) & - /(exlev_in(k,ipn)-exlev_in(k+1,ipn)) - else - th_in(k,ipn)=t_in(k,ipn)*(p1000/p_in(k,ipn))**(rd/cp) - end if - end do - - if (vrbos) then -!SMS$ignore begin - print '(a,i8/7x,a)','fimini input at ipn =',ipn, & - 'geopot pres exner temp theta moist u v' - print 103,0,ter_in(ipn) - print 103,(k,gz_in(k,ipn),p_in(k,ipn),exlev_in(k,ipn), & - t_in(k,ipn),th_in(k,ipn),q_in(k,ipn),u_in(k,ipn), v_in(k,ipn), & - k=1,nlyr),nlyr+1,gz_in(nlyr+1,ipn),p_in(nlyr+1,ipn), & - exlev_in(nlyr+1,ipn) -103 format (i4,2f10.1,3f9.2,es10.2,2f7.2) -!SMS$ignore end - end if - - end do ! horizontal loop - - if (PrintDiags) then - do k=1,nlyr - write (string,'(a,i3)') 'theta lyr',k - call findmxmn2(th_in,nlyr,nip,k,string) - write (string,'(a,i3)') 'u-vel lyr',k - call findmxmn2(u_in,nlyr,nip,k,string) - write (string,'(a,i3)') 'v-vel lyr',k - call findmxmn2(v_in,nlyr,nip,k,string) - write (string,'(a,i3)') 'moist lyr',k - call findmxmn2(q_in,nlyr,nip,k,string) - end do - end if - -!<><><><><><><><><><><><><><>><><><><><><><><><><><><><><><><><><><><><><><> -! c o n v e r t t o h y b r i d - i s e n t r o p i c l a y e r s -!<><><><><><><><><><><><><><>><><><><><><><><><><><><><><><><><><><><><><><> - - if (pure_sig .or. EnKFAnl) then - us3d(:,:) = u_in (:,:) - vs3d(:,:) = v_in (:,:) - ex3d(:,:) = exlev_in (:,:) - tr3d(:,:,1) = th_in (:,:) ! virt.pot.temperature - tr3d(:,:,2) = max(q_in (:,:),qvmin) ! water vapor - tr3d(:,:,3) = max(qc_in(:,:),0. ) ! liquid water/condensate - tr3d(:,:,4) = o3_in (:,:) ! ozone - - else ! grid is hybrid-isentropic - do ipn=1,nip - targ_in(:,ipn)=theta_lyrs - end do - -! --- convert input stairstep profiles into continuous line segments. -! --- integrate those segments over new layers consistent with chosen -! --- coordinate ('target') values, subject to min thknss constraints. - - call lay2lay(nlyr,exlev_in,th_in,q_in, u_in, v_in, o3_in,qc_in, & - nvl ,exwrk ,thwrk,qvwrk,uswrk,vswrk,o3wrk,qcwrk, & - targ_in,nip, PrintDiags) - - us3d(:,:) = uswrk(:,:) - vs3d(:,:) = vswrk(:,:) - ex3d(:,:) = exwrk(:,:) - tr3d(:,:,1) = thwrk(:,:) ! virt.pot.temperature - tr3d(:,:,2) = max(qvwrk(:,:),qvmin) ! water vapor - tr3d(:,:,3) = max(qcwrk(:,:),0. ) ! liquid water/condensate - tr3d(:,:,4) = o3wrk(:,:) ! ozone - -! --- add nontrivial content to class B and remaining class A tracer arrays. -! --- for testing purposes, use initl pressure and initial latitude as tracers. -! --- copy class B tracers into class A to provide reference tracer fields. - - do ipn = 1,nip ! horizontal loop - do k=1,nvl - if (ntrb.ge.1) then -! --- choose initial pressure as tracer 1 - tr3d(k,ipn,ntra+1)=p1000*(exwrk(k,ipn)/cp)**3.5 ! => class B - if (ntra.ge.5) tr3d(k,ipn,5)=tr3d(k,ipn,ntra+1) ! duplicate in class A - end if - - if (ntrb.ge.2) then -! --- choose initial latitude (+90 for pos.def.) as tracer 2 - tr3d(k,ipn,ntra+2)=deg_lat(ipn) + 90. ! => class B - if (ntra.ge.6) tr3d(k,ipn,6)=tr3d(k,ipn,ntra+2) ! duplicate in class A - end if - end do - end do - end if ! pure_sig: true or false - - do ipn = 1,nip ! horizontal loop - vrbos=ipn.eq.PrintIpnDiag - - pr3d(nvlp1,ipn)=p1000*(ex3d(nvlp1,ipn)/cp)**(cp/rd) - do k = nvl,1,-1 - pr3d(k,ipn)=p1000*(ex3d(k,ipn)/cp)**(cp/rd) - dp3d(k,ipn)=pr3d(k,ipn)-pr3d(k+1,ipn) - end do - -! --- solve hydrostatic eqn for geo- and montgomery potential - mp3d(1,ipn)=ter_in(ipn)+ex3d(1,ipn)*tr3d(1,ipn,1) ! first layer - ph3d(1,ipn)=ter_in(ipn) - do k = 2,nvl - mp3d(k,ipn)=mp3d(k-1,ipn)+ex3d(k,ipn)*(tr3d(k,ipn,1)-tr3d(k-1,ipn,1)) - ph3d(k,ipn)=mp3d(k,ipn)-ex3d(k,ipn)*tr3d(k,ipn,1) - end do - ph3d(nvlp1,ipn)=mp3d(nvl,ipn)-ex3d(nvlp1,ipn)*tr3d(nvl,ipn,1) - - if (vrbos) then -!SMS$ignore begin - write (6,99) ipn,'o u t p u t p r o f i l e :' -99 format ('ipn =',i8,' fimini ',a/ & - '(5-line groups: pres, exn.fct, geopot(km), theta, montg.pot/1000)') - do k2=1,nvl,10 - print '( -2p,11f7.1)',(pr3d(k1,ipn) ,k1=k2,min(nvlp1,k2+10) ) - print '( 11f7.1)',(ex3d(k1,ipn) ,k1=k2,min(nvlp1,k2+10) ) - print '( -4p,11f7.3)',(ph3d(k1,ipn) ,k1=k2,min(nvlp1,k2+10) ) - print '(4x, 10f7.2)',(tr3d(k1,ipn,1),k1=k2,min(nvl ,k2+9) ) - print '(4x,-3p,10f7.2)',(mp3d(k1,ipn) ,k1=k2,min(nvl ,k2+9) ) - print * - end do -!SMS$ignore end - end if - - end do ! horizontal loop -!SMS$PARALLEL END - -! --- show max/min of all tracer fields in a single mid-range layer - k1=nvl/2 - do k2=1,ntra - write (string,'(a,i2,a,i3)') 'trc A',k2,' lyr',k1 - call findmxmn3(tr3d,nvl,nip,ntra+ntrb,k1,k2,string) - end do - do k2=1,ntrb - write (string,'(a,i2,a,i3)') 'trc B',k2,' lyr',k1 - call findmxmn3(tr3d,nvl,nip,ntra+ntrb,k1,ntra+k2,string) - end do - - if(PrintDiags) then -!SMS$SERIAL BEGIN - print 102,'minmax u ',minval(us3d(1,:)),maxval(us3d(nvl,:)) - print 102,'minmax v ',minval(vs3d(1,:)),maxval(vs3d(nvl,:)) - print 102,'minmax dp ',minval(dp3d(1,:)),maxval(dp3d(nvl,:)) - print 102,'minmax ph ',minval(ph3d(1,:)),maxval(ph3d(nvl+1,:)) - print 102,'minmax pres ',minval(pr3d(nvl+1,:)),maxval(pr3d(1,:)) - print 102,'minmax pi ',minval(ex3d(nvl+1,:)),maxval(ex3d(1,:)) - print 102,'minmax mp ',minval(mp3d(1,:)),maxval(mp3d(nvl,:)) - print 102,'minmax tr(1) ',minval(tr3d(:,:,1)),maxval(tr3d(:,:,1)) - print 102,'minmax tr(2) ',minval(tr3d(:,:,2)),maxval(tr3d(:,:,2)) - print 102,'minmax tr(3) ',minval(tr3d(:,:,3)),maxval(tr3d(:,:,3)) - print 102,'minmax tr(4) ',minval(tr3d(:,:,4)),maxval(tr3d(:,:,4)) - print 102,'max ter&ph1 ',maxval(ter_in(:)),maxval(ph3d(1,:)) -!SMS$SERIAL END - end if - - print *,'... exiting fimini' - return - end subroutine fimini diff --git a/src/fim/FIMsrc/prep/ss2icos/lay2lay.F90 b/src/fim/FIMsrc/prep/ss2icos/lay2lay.F90 deleted file mode 100644 index e0096a2..0000000 --- a/src/fim/FIMsrc/prep/ss2icos/lay2lay.F90 +++ /dev/null @@ -1,546 +0,0 @@ - subroutine lay2lay(kkold,pold,thold, & - varin1,varin2,varin3,varin4,varin5, & - kknew,pnew,thnew, & - varou1,varou2,varou3,varou4,varou5, & - targt,nip,PrintDiags) -! -!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ -! Layer-to-layer conversion routine, obtained by combining routines -! lay2lev4 (layer to level) and lin2stp (linear to step fct) -! -! (Lay2lev based on Bleck, R., 1984: Vertical Coordinate Transformation -! of Vertically Discretized Atmospheric Fields. Mon. Wea. Rev., 112, -! 2537-2541) -! -! Specifically, lay2lay .... - -! (1) fits continuous, piecewise linear curves to input stairstep -! profiles thold(pold), varin1(pold), varin2(pold), ...; -! (2) creates a new stairstep profile of theta by piecewise -! integrating over the continous theta curve such that the new -! steps theta(pnew) match prescribed 'target' values; -! (3) modifies the new pressure -pnew- where necessary to satisfy -! minimum layer thickness constraints; -! (4) integrates the continuous curves for thold, varin1, varin2,... -! over pressure intervals obtained in (3) to produce new -! stairstep profiles varout1(pnew), varout2(pnew), ...; -! -! The routine is presently configured to conserve the height of the -! air column. It can easily be modified to conserve column thermal -! energy instead. -! -! Rainer Bleck 2008 -!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ -! -! --- More details: -! -! --- 'Old' data consisting of 3-dim. arrays of -! -! --- (a) 'kkold+1' interface pressure (or Exner fct) values (pold) -! --- (b) 'kkold' layer averages of pot.temperature (thold) -! --- (b) 'kkold' layer averages of dep.variables (varin1,varin2,..) -! -! --- ...are transformed from piecewise constant (stairstep-type) -! --- functions of -p- to continuous, piecewise linear functions of -p- -! --- preserving the column mean of the input data. This intrinsically -! --- nonunique curve fitting problem is rendered unique by minimizing -! --- zigzags in the curves, i.e., imposing penalties for large 2nd -! --- derivatives. Additional penalties are imposed for large overshoots -! --- in the center portion of each layer. (Sharply raising the latter -! --- penalties will force the algorithm to generate curves resembling -! --- the input stairstep curves.) -! -! --- The resulting line segments are integrated to form layers -! --- constrained to yield prescribed values of pot.temperature (targt). -! --- New values of intfc pressure, theta, and dep.variables are returned -! --- in pnew(:,:,kknew+1), thnew(:,:,kknew), varou1(:,:,kknew), .... -! - use module_hybgen - use module_constants,only: p1000,rd,cp - use module_control, only: yyyymmddhhmm,PrintIpnDiag,ptop -! - implicit none - integer,intent(IN) :: nip,kkold,kknew - logical,intent(IN) :: PrintDiags -!SMS$DISTRIBUTE(dh,NIP) BEGIN - real,intent(IN) :: pold(kkold+1,nip),thold (kkold,nip), & - varin1(kkold,nip),varin2(kkold,nip), & - varin3(kkold,nip),varin4(kkold,nip), & - varin5(kkold,nip), & - targt (kknew,nip) - real,intent(OUT) :: pnew(kknew+1,nip),thnew (kknew,nip), & - varou1(kknew,nip),varou2(kknew,nip), & - varou3(kknew,nip),varou4(kknew,nip), & - varou5(kknew,nip) -!SMS$DISTRIBUTE END -! - integer,parameter :: nsize = 321 ! must be 5*kkold+1 or larger - integer ipn,k,l,n,indx(nsize),last - real matrix(nsize,nsize),pint(nsize),solth(nsize), & - solu1(nsize),solu2(nsize),solu3(nsize),solu4(nsize), & - solu5(nsize),excol(kknew+1),thcol(kknew), & - v1col(kknew),v2col(kknew),v3col(kknew),v4col(kknew), & - v5col(kknew),tarcol(kknew),prcol(kknew+1), & - exold(kknew+1),exwrk(kknew+1),unusd(nsize), & - oddev,p2ex,ex2p,arg - real pr_extd(nsize+3),th_extd(nsize+3),tg_extd(kknew+1) -! - real,parameter :: penlty = 0. ! penalty for midlyr overshoots - real,parameter :: flag = -.03125 ! missing data - logical realyr,vrbos -! - ex2p(arg)=p1000*(arg/cp)**(cp/rd) ! convert Pi => p -! p2ex(arg)=cp*(arg/p1000)**(rd/cp) ! convert p => Pi - - print *,'entering lay2lay...' - if (nsize.lt.5*kkold+1) stop '(nsize too small in subr.lay2lev)' -! - n=kkold ! number of input layers -! - do 30 k=1,nsize - solth(k)=0. - solu1(k)=0. - solu2(k)=0. - solu3(k)=0. - solu4(k)=0. - solu5(k)=0. - do 30 l=1,nsize - 30 matrix(k,l)=0. -! - do 18 k=1,n -! --- upper left quadrant: - matrix(k,4*k-3)=1. - matrix(k,4*k-2)=2. - matrix(k,4*k-1)=2. - matrix(k,4*k )=2. - matrix(k,4*k+1)=1. -! --- lower right quadrant: - matrix(n+4*k-3,4*n+1+k)=1. - matrix(n+4*k-2,4*n+1+k)=2. - matrix(n+4*k-1,4*n+1+k)=2. - matrix(n+4*k ,4*n+1+k)=2. - 18 matrix(n+4*k+1,4*n+1+k)=1. -! -! --- lower left quadrant: - do 19 k=2,4*n - matrix(n+k+1,k-1)=1. - matrix(n+k-1,k+1)=1. - 19 matrix(n+k ,k )=6. -! - do 20 k=2,4*n-1 - matrix(n+k+1,k )=-4. - 20 matrix(n+k ,k+1)=-4. -! - matrix( n+1, 1)=1. - matrix(5*n+1,4*n+1)=1. - matrix(5*n ,4*n+1)=-2. - matrix(5*n+1,4*n )=-2. - matrix( n+1, 2)=-2. - matrix( n+2, 1)=-2. - matrix(5*n ,4*n )=5. - matrix( n+2, 2)=5. -! -! --- penalize overshoots at layer midpoints -! - do 15 k=1,n - matrix(n+4*k-2,4*k-2)=matrix(n+4*k-2,4*k-2)+penlty*.25 - matrix(n+4*k-1,4*k-1)=matrix(n+4*k-1,4*k-1)+penlty - matrix(n+4*k ,4*k )=matrix(n+4*k ,4*k )+penlty*.25 - 15 continue -! -! --- decompose matrix - call ludcmp(matrix,5*n+1,nsize,indx,oddev) -! -!! Cray modification (thanks to Pete Johnsen): -!! Make multi-line OMP directive conform to the -!! OpenMP Application Program Interface Version 2.5 May 2005, -!! Sect. 2.1.2 Free Source Form Directives, according to which: -!! Continued directive lines must have an ampersand as the -!! last nonblank character on the line, prior to any comment -!! placed inside the directive. Continuation directive lines -!! can have an ampersand after the directive sentinel with -!! optional white space before and after the ampersand. -!TBH: NOTE that this file has not been tested with OpenMP in quite a while -!TBH: so the directive below mauy require adjustment. -!!$OMP PARALLEL DO PRIVATE(solth,solu1,solu2,solu3,solu4,solu5,pint, & -!!$OMP& kold,knew,dp1,dp2,realyr,vrbos , ipnGlob,mype,last, & -!!$OMP& tarcol,pr_extd,th_extd,tg_extd,excol,exold, & -!!$OMP& thcol,prcol,dpcol,v1col,v2col,v3col,v4col,v5col) & -!!$OMP& SHARED(matrix,indx) -!SMS$PARALLEL (dh,ipn) BEGIN - do 1 ipn=1,nip - vrbos=ipn.eq.PrintIpnDiag -! -! --- open file for saving step-by-step details of the interpolation procedure - if (vrbos) then -!SMS$ignore begin - print '(3a,i8,a)','store data for date = ',yyyymmddhhmm, & - ', ipn =',ipn,' in file "stairstep_details" for offln plotting' - open (31,file='stairstep_details',form='formatted') - write (31,'(a10,i8,4i5)') yyyymmddhhmm,ipn,kkold,4*n+1,kknew,kknew -!SMS$ignore end - end if -! - do 10 k=1,kknew - varou1(k,ipn)=flag - varou2(k,ipn)=flag - varou3(k,ipn)=flag - varou4(k,ipn)=flag - varou5(k,ipn)=flag - 10 continue -! - do 2 k=1,n - solth(k)=8.*thold (k,ipn) - solu1(k)=8.*varin1(k,ipn) - solu2(k)=8.*varin2(k,ipn) - solu3(k)=8.*varin3(k,ipn) - solu4(k)=8.*varin4(k,ipn) - solu5(k)=8.*varin5(k,ipn) - 2 continue -! - do 31 k=n+1,nsize - solth(k)=0. - solu1(k)=0. - solu2(k)=0. - solu3(k)=0. - solu4(k)=0. - solu5(k)=0. - 31 continue -! -! --- penalize overshoots at layer midpoints -! - do 16 k=1,n - solth(n+4*k-2)=thold (k,ipn)*penlty*.25 - solth(n+4*k-1)=thold (k,ipn)*penlty - solth(n+4*k )=thold (k,ipn)*penlty*.25 -! - solu1(n+4*k-2)=varin1(k,ipn)*penlty*.25 - solu1(n+4*k-1)=varin1(k,ipn)*penlty - solu1(n+4*k )=varin1(k,ipn)*penlty*.25 -! - solu2(n+4*k-2)=varin2(k,ipn)*penlty*.25 - solu2(n+4*k-1)=varin2(k,ipn)*penlty - solu2(n+4*k )=varin2(k,ipn)*penlty*.25 -! - solu3(n+4*k-2)=varin3(k,ipn)*penlty*.25 - solu3(n+4*k-1)=varin3(k,ipn)*penlty - solu3(n+4*k )=varin3(k,ipn)*penlty*.25 -! - solu4(n+4*k-2)=varin4(k,ipn)*penlty*.25 - solu4(n+4*k-1)=varin4(k,ipn)*penlty - solu4(n+4*k )=varin4(k,ipn)*penlty*.25 -! - solu5(n+4*k-2)=varin5(k,ipn)*penlty*.25 - solu5(n+4*k-1)=varin5(k,ipn)*penlty - solu5(n+4*k )=varin5(k,ipn)*penlty*.25 -! - 16 continue -! -! --- replace values in massless layers by values from nearest 'real' layer -! -!cc realyr=.false. -!cc do 8 k=1,n -!cc if (pold(ipn,k+1).gt.pold(ipn,k)+.01) realyr=.true. -!cc if (k.eq.1) go to 8 -!cc if (realyr .and. pold(ipn,k).ge.pold(ipn,k+1)-.01) then -!cc solth(k)=solth(k-1) -!cc solu1(k)=solu1(k-1) -!cc solu2(k)=solu2(k-1) -!cc solu3(k)=solu3(k-1) -!cc end if -!cc 8 continue -! -!cc realyr=.false. -!cc do 9 k=n,1,-1 -!cc if (pold(ipn,k+1).gt.pold(ipn,k)+.01) realyr=.true. -!cc if (k.eq.n) go to 9 -!cc if (realyr .and. pold(ipn,k).ge.pold(ipn,k+1)-.01) then -!cc solth(k)=solth(k+1) -!cc solu1(k)=solu1(k+1) -!cc solu2(k)=solu2(k+1) -!cc solu3(k)=solu3(k+1) -!cc end if -!cc 9 continue -! - if (vrbos) then -!SMS$ignore begin - write (*,101) ipn,'thold inpt',(pold(k,ipn),.125*solth(k),k=1,n),& - pold(n+1,ipn) -!! write (*,101) ipn,'vrbl 1 inpt',(pold(k,ipn),.125*solu1(k),k=1,n) -!! write (*,101) ipn,'vrbl 2 inpt',(pold(k,ipn),.125*solu2(k),k=1,n) -!! write (*,101) ipn,'vrbl 3 inpt',(pold(k,ipn),.125*solu3(k),k=1,n) -!! write (*,101) ipn,'vrbl 4 inpt',(pold(k,ipn),.125*solu4(k),k=1,n) -!! write (*,101) ipn,'vrbl 5 inpt',(pold(k,ipn),.125*solu5(k),k=1,n) - write (31,*) 'input profile' - write (31,100) (pold(k,ipn),.125*solth(k),k=1,n) - 100 format (2es15.7) -!SMS$ignore end - end if - 101 format (i10,3x,a,' profile:'/(4(f9.1,es10.3))) -! - call lubksb(matrix,5*n+1,nsize,indx,solth) - call lubksb(matrix,5*n+1,nsize,indx,solu1) - call lubksb(matrix,5*n+1,nsize,indx,solu2) - call lubksb(matrix,5*n+1,nsize,indx,solu3) - call lubksb(matrix,5*n+1,nsize,indx,solu4) - call lubksb(matrix,5*n+1,nsize,indx,solu5) -! -! --- assign pressure values to the end points of the 4*n line segments -! - do 4 k=1,n - 4 pint(4*k-3)=pold(k,ipn ) - pint(4*n+1)=pold(kkold+1,ipn) - do 5 k=1,n - pint(4*k-2)=.75*pint(4*k-3)+.25*pint(4*k+1) - pint(4*k-1)=.50*pint(4*k-3)+.50*pint(4*k+1) - 5 pint(4*k )=.25*pint(4*k-3)+.75*pint(4*k+1) -! - if (vrbos) then -!SMS$ignore begin - write (*,101) ipn,'theta pcwise lin.',(pint(k),solth(k),k=1,4*n+1) -!! write (*,101) ipn,'vrbl 1 pcwise lin.',(pint(k),solu1(k),k=1,4*n+1) -!! write (*,101) ipn,'vrbl 2 pcwise lin.',(pint(k),solu2(k),k=1,4*n+1) -!! write (*,101) ipn,'vrbl 3 pcwise lin.',(pint(k),solu3(k),k=1,4*n+1) -!! write (*,101) ipn,'vrbl 4 pcwise lin.',(pint(k),solu4(k),k=1,4*n+1) -!! write (*,101) ipn,'vrbl 5 pcwise lin.',(pint(k),solu5(k),k=1,5*n+1) - write (31,*) 'piecewise linear fit' - write (31,100) (pint(k),solth(k),k=1,4*n+1) -!SMS$ignore end - end if -! -! <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> -! --- Step 1 completed. Now break -solth- into stairsteps whose 'risers' -! --- are at prescribed -targt- values -! <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> -! - tarcol(:)=targt(:,ipn) -! -! --- extend fitted curve at bottom and top to match range of target values -! --- extend list of target values to match range of fitted curve -! - pr_extd(2:4*n+2)=pint(1:4*n+1) - pr_extd( 1)=pint( 1) - pr_extd(4*n+3)=pint(4*n+1) -! - th_extd(2:4*n+2)=solth(1:4*n+1) - th_extd( 1)=min(tarcol( 1),solth( 1)) - th_extd(4*n+3)=max(tarcol(kknew),solth(4*n+1)) -! - tg_extd(1:kknew)=tarcol - tg_extd( 1)=min(tarcol( 1),solth( 1)) - tg_extd(kknew+1)=max(tarcol(kknew),solth(4*n+1)) -! - do k=2,4*n+3 - th_extd(k)=max(th_extd(k),th_extd(k-1)) ! remove superadiabats - end do -! - call lin2stp(th_extd,pr_extd,4*n+3,tg_extd,excol,kknew, & - vrbos,ipn) - do k=kknew,2,-1 - excol(k+1)=excol(k) - end do - excol(1)=pint(1) - thcol(:)=tarcol(:) -! - if (vrbos) then -!SMS$ignore begin - write (31,*) 'output profile before hybridization' - write (31,100) (excol(k),thcol(k),k=1,kknew) -!SMS$ignore end - end if -! -! <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> -! --- Step 2 completed. Now hybridize the grid -! <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> -! -! --- FIM atmosphere ends at pressure -ptop- - excol(kknew+1)=cp*(ptop/p1000)**(rd/cp) - do 14 k=kknew,kknew/2,-1 - 14 excol(k)=max(excol(k),excol(k+1)) -! -! --- inflate massless layers to create hybrid-isentropic grid. -! --- it is assumed here that -pint- represents Exner fctn, *not* pressure -! - prcol( 1)=ex2p(excol( 1)) - do 13 k=1,kknew - excol(k+1)=min(excol(k),excol(k+1)) ! remove superadiabats - prcol(k+1)=ex2p(excol(k+1)) - 13 continue - exold(:)=excol(:) -! -! --- for consistency between initialization and time integration, -! --- regrid_1d (part of the FIM grid generator) is used to here -! --- to inflate massless layers. however, vertical regridding of -! --- dependent variables will be done separately by lin2stp. -! -!SMS$ignore begin - if (vrbos) print *,'lay2lay calling regrid_1d/remap_1d ...' -!SMS$ignore end -! - call regrid_1d(0,tarcol,thcol,excol,prcol,vrbos,ipn,PrintDiags) - exwrk(:)=exold(:) - call remap_1d(0,tarcol,1,thcol,unusd,unusd,exwrk,excol, & - unusd,prcol,vrbos,ipn,PrintDiags) - excol(:)=exwrk(:) -! -! <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> -! --- Step 3 completed. Now interpolate input variables to the new grid. -! <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> -! - do k=1,4*n+1 - pint(k)=max(pint(k),excol(kknew+1)) - end do -! -! --- do full-column regridding for all variables except theta -! - call lin2stp(pint,solu1,4*n+1,excol,v1col,kknew,vrbos,ipn) - call lin2stp(pint,solu2,4*n+1,excol,v2col,kknew,vrbos,ipn) - call lin2stp(pint,solu3,4*n+1,excol,v3col,kknew,vrbos,ipn) - call lin2stp(pint,solu4,4*n+1,excol,v4col,kknew,vrbos,ipn) - call lin2stp(pint,solu5,4*n+1,excol,v5col,kknew,vrbos,ipn) -! -! --- regrid theta in inflated layers only. this keeps theta values in -! --- isentropic region on target but may violate the integral constraint -! - do k=2,kkold+1 - if (excol(k).eq.exold(k)) go to 21 - end do - stop '(lay2lay error)' - 21 last=k-1 - do k=1,4*n+1 - pint(k)=max(pint(k),excol(last+1)) - end do - call lin2stp(pint,solth,4*n+1,excol,thcol,last ,vrbos,ipn) -! -! <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> -! --- Steps 4 completed. Finish up. -! <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> -! - do 6 k=1,kknew - pnew (k,ipn)=excol(k) - thnew (k,ipn)=thcol(k) - varou1(k,ipn)=v1col(k) - varou2(k,ipn)=v2col(k) - varou3(k,ipn)=v3col(k) - varou4(k,ipn)=v4col(k) - varou5(k,ipn)=v5col(k) - 6 continue - pnew(kknew+1,ipn)=excol(kknew+1) -! - if (vrbos) then -!SMS$ignore begin - write (*,101) ipn,'theta outp',(excol(k),thcol(k),k=1,kknew) & - ,excol(kknew+1) -!! write (*,101) ipn,'vrbl 1 outp',(excol(k),v1col(k),k=1,kknew) & -!! ,excol(kknew+1) -!! write (*,101) ipn,'vrbl 2 outp',(excol(k),v2col(k),k=1,kknew) & -!! ,excol(kknew+1) -!! write (*,101) ipn,'vrbl 3 outp',(excol(k),v3col(k),k=1,kknew) & -!! ,excol(kknew+1) -!! write (*,101) ipn,'vrbl 4 outp',(excol(k),v4col(k),k=1,kknew) & -!! ,excol(kknew+1) -!! write (*,101) ipn,'vrbl 5 outp',(excol(k),v5col(k),k=1,kknew) & -!! ,excol(kknew+1) - write (31,*) 'output profile after hybridization' - write (31,100) (excol(k),thcol(k),k=1,kknew) - close (31) -!SMS$ignore end - end if -! - 1 continue -!SMS$PARALLEL END -! - print *,'... exiting lay2lay' - return - end subroutine lay2lay -! -! - SUBROUTINE lubksb(a,n,np,indx,b) - INTEGER n,np,indx(n) - REAL a(np,np),b(n) - INTEGER i,ii,j,ll - REAL sum - ii=0 -! - do 12 i=1,n - ll=indx(i) - sum=b(ll) - b(ll)=b(i) - if (ii.ne.0)then - do 11 j=ii,i-1 - sum=sum-a(i,j)*b(j) -11 continue - else if (sum.ne.0.) then - ii=i - endif - b(i)=sum -12 continue - do 14 i=n,1,-1 - sum=b(i) - do 13 j=i+1,n - sum=sum-a(i,j)*b(j) -13 continue - b(i)=sum/a(i,i) -14 continue - return - END -! (C) Copr. 1986-92 Numerical Recipes Software 'W3. -! -! - SUBROUTINE ludcmp(a,n,np,indx,d) - INTEGER n,np,indx(n),NMAX - REAL d,a(np,np),TINY - PARAMETER (NMAX=500,TINY=1.0e-20) - INTEGER i,imax,j,k - REAL aamax,dum,sum,vv(NMAX) - d=1. - do 12 i=1,n - aamax=0. - do 11 j=1,n - if (abs(a(i,j)).gt.aamax) aamax=abs(a(i,j)) -11 continue - if (aamax.eq.0.) pause 'singular matrix in ludcmp' - vv(i)=1./aamax -12 continue - do 19 j=1,n - do 14 i=1,j-1 - sum=a(i,j) - do 13 k=1,i-1 - sum=sum-a(i,k)*a(k,j) -13 continue - a(i,j)=sum -14 continue - aamax=0. - do 16 i=j,n - sum=a(i,j) - do 15 k=1,j-1 - sum=sum-a(i,k)*a(k,j) -15 continue - a(i,j)=sum - dum=vv(i)*abs(sum) - if (dum.ge.aamax) then - imax=i - aamax=dum - endif -16 continue - if (j.ne.imax)then - do 17 k=1,n - dum=a(imax,k) - a(imax,k)=a(j,k) - a(j,k)=dum -17 continue - d=-d - vv(imax)=vv(j) - endif - indx(j)=imax - if(a(j,j).eq.0.)a(j,j)=TINY - if(j.ne.n)then - dum=1./a(j,j) - do 18 i=j+1,n - a(i,j)=a(i,j)*dum -18 continue - endif -19 continue - return - END -! (C) Copr. 1986-92 Numerical Recipes Software 'W3. diff --git a/src/fim/FIMsrc/prep/ss2icos/lin2stp.F90 b/src/fim/FIMsrc/prep/ss2icos/lin2stp.F90 deleted file mode 100644 index ef75b1b..0000000 --- a/src/fim/FIMsrc/prep/ss2icos/lin2stp.F90 +++ /dev/null @@ -1,80 +0,0 @@ - subroutine lin2stp(xold,yold,kold,xnew,ynew,knew,vrbos,ipn) -! -! --- convert piecewise linear curve (xold,yold) into stairstep curve by -! --- integrating -yold- over consecutive -xnew- intervals -! - implicit none - integer,intent(IN) :: kold,knew - integer,intent(IN) :: ipn ! current location in horiz.grid - real,intent(IN) :: xold(kold),yold(kold),xnew(knew+1) - real,intent(OUT) :: ynew(knew) - logical,intent(IN) :: vrbos ! if true, print diagnostics - integer k,ko - real*8 colin,clout,colmx,yinteg,xlo,xhi,xa,xb,ya,yb,wgt - real*8 xxold(kold),yyold(kold),xxnew(knew+1),yynew(knew) - real,parameter :: acurcy=1.e-9 -! - if (vrbos) & - write (*,101) ipn,' lin2stp -- old profile: x y', & - (k,xold(k),yold(k),k=1,kold) - 101 format (i8,a/(i30,f12.1,es13.4)) -! - if (xold(1).lt.xold(kold)) then - xxold= xold - xxnew= xnew - else - xxold=-xold - xxnew=-xnew - end if - yyold=yold -! -! --- column integrals (colin/clout) are computed for diagnostic purposes only - if (xold(1).ne.xnew(1)) & - print *,ipn,' lin2stp warning - bottom xold and xnew differ', & - xold(1),xnew(1) - if (xold(kold).ne.xnew(knew+1)) & - print *,ipn,' lin2stp warning - top xold and xnew differ', & - xold(kold),xnew(knew+1) - colin=0. - clout=0. - colmx=0. - do 3 k=1,kold-1 - colmx=max(colmx,abs(yyold(k))) - 3 colin=colin+.5*(yyold(k)+yyold(k+1))*(xxold(k+1)-xxold(k)) -! - do 4 k=1,knew - xlo=xxnew(k ) - xhi=xxnew(k+1) - yynew(k)=yyold(1) - if (xhi.gt.xlo) then - yinteg=0. - do ko=1,kold-1 - xa=max(xlo,min(xhi,xxold(ko ))) - xb=max(xlo,min(xhi,xxold(ko+1))) - if (xb.gt.xa) then - wgt=(xa-xxold(ko))/(xxold(ko+1)-xxold(ko)) - ya=yyold(ko+1)*wgt+yyold(ko)*(1.-wgt) - wgt=(xb-xxold(ko))/(xxold(ko+1)-xxold(ko)) - yb=yyold(ko+1)*wgt+yyold(ko)*(1.-wgt) -! if (vrbos) print '(2i3,a,4f7.1,2es11.4)',k,ko, & -! ' xlo,xhi,xa,xb,ya,yb:',xlo,xhi,xa,xb,ya,yb - yinteg=yinteg+.5*(ya+yb)*(xb-xa) - end if - end do - yynew(k)=yinteg/(xhi-xlo) -! if (vrbos) print '(i3,a,es12.4)',k,' ynew:',yynew(k) - clout=clout+yinteg - end if - 4 continue - ynew=yynew -! - if (abs(clout-colin).gt.acurcy*colmx*xold(kold/2)) & - write (*,100) ipn,' lin2stp - column intgl.error', & - colin,clout,(clout-colin)/colin - 100 format (i8,a,2es14.6,es9.1) -! - if (vrbos) & - write (*,101) ipn,' lin2stp -- new profile: x y', & - (k,xnew(k),ynew(k),k=1,knew),knew+1,xnew(knew+1) - return - end subroutine lin2stp diff --git a/src/fim/FIMsrc/prep/ss2icos/mktopo.F90 b/src/fim/FIMsrc/prep/ss2icos/mktopo.F90 deleted file mode 100644 index f8fa394..0000000 --- a/src/fim/FIMsrc/prep/ss2icos/mktopo.F90 +++ /dev/null @@ -1,545 +0,0 @@ -module const - -!sms$ignore begin - - real, parameter :: pi=3.1415926535897931 - real, parameter :: pi4=pi/4.0 - real, parameter :: pi2=pi/2.0 - real, parameter :: deg2rad=pi/180.0 - real, parameter :: rad2deg=1.0/deg2rad - - real, parameter :: rearth=6371.0 - real, parameter :: earthcircum=2.0*pi*rearth - real, parameter :: earthomega=7.292e-5 - - real, parameter :: km2nm=60.0/(2*pi*rearth/360.0) - real, parameter :: nm2km=1.0/km2nm - real, parameter :: deglat2km=((2.0*pi*rearth)/360.0) - real, parameter :: deglat2nm=60.0 - real, parameter :: km2deglat=1.0/deglat2km - real, parameter :: nm2deglat=1.0/deglat2nm - real, parameter :: knots2ms=1000.0/(km2nm*3600.0) - real, parameter :: yms2knots=1.0/knots2ms - real, parameter :: epsilonm5=1.0e-5 - real, parameter :: gravity=9.80665 - -!sms$ignore end - -end module const - -module libmf - -!sms$ignore begin - -contains - - subroutine stat2(a,m,n,amin,amax,amean,avar,asigma) - - real(kind=4) :: a(m,n) - - amean = 0.0 - amin = 9.9e25 - amax = -9.9e25 - avar = 0.0 - asigma = 0.0 - do i=1,m - do j=1,n - if(a(i,j).lt.amin) amin=a(i,j) - if(a(i,j).gt.amax) amax=a(i,j) - amean=amean+a(i,j) - end do - end do - amean = amean/m*n - do i=1,m - do j=1,n - avar = avar + (a(i,j)-amean)**2 - end do - end do - avar = avar/(m*n-1) - asigma=sqrt(avar) - return - - end subroutine stat2 - - subroutine qprntn(a,qtitle,ibeg,jbeg,m,n,iskip,iunit) - -! -!********** 12 APR 91 this version outputs to iunit -!********** using write on the Cray Y/MP -! -!*************************************************************** -!*************************************************************** -!***** ***** -!***** qprint output routine (!orrected 4/26/86) ***** -!***** ***** -!*************************************************************** -!*************************************************************** -! -! a= fwa of m x n array -! qtitle - title -! ibeg,jbeg=lower left corner coords to be printed -! up to 43 x 83 points printed -! - real(kind=4) a(m,n),ix(81) - real(kind=4) xm - character qtitle*24 -! -! determine grid limits -! - if(iskip.eq.0) iskip=1 - iend=min0(ibeg+79*iskip,m) - jend=min0(jbeg+79*iskip,n) - - half=0.5 -! -24 continue -! -! index backwards checking for max -! -11 xm=0. - jendsc=min0(jend,n) - do j=jbeg,jendsc,iskip - jend_qp = j - do i=ibeg,iend,iskip - xm=max(xm,abs(a(i,j))) - end do - end do -! -! determine scaling factor limits -! - if(xm.lt.1.0e-32.or.xm.eq.0.0) xm=99.0 - xm=alog10(99.0/xm) - kp=xm - if(xm.lt.0.0)kp=kp-1 -! -! print scaling constants -! -12 write(iunit,1) qtitle,kp,iskip,(i,i=ibeg,iend,2*iskip) - -1 format('0',a,' k=',i3,' iskip=',i2,/,' ',41i6) - fk=10.0**kp -! -! quickprint field -! - do jli=jend_qp,jbeg,-iskip - ii= 0 - if(kp.eq.0) then - do i=ibeg,iend,iskip - ii=ii+1 - ix(ii)=a(i,jli)+sign(half,a(i,jli)) - end do - else - do i=ibeg,iend,iskip - ii=ii+1 - ix(ii)=a(i,jli)*fk+sign(half,a(i,jli)) - end do - end if - write(iunit,'(i4,81i3)') jli,(ix(i),i=1,ii),jli - enddo - return - - end subroutine qprntn - - subroutine smth2d(a,ni,nj,ib,ie,jb,je, & - anu,npass,nnu,ioresp,io,iskip,dx,b,undef) - -!... routine to smooth a 2-d field at subsection of interior points -!... using a noncomplex shuman (1957) smoother-desmoother - - real (kind=4) a(ni,nj),b(ni,nj),anu(nnu) - real (kind=4) pi,rlambda,dx,undef - - logical ioresp,io - character qtitle*24 - -!... output unsmoothed field if io.ne.0 - - if(io) then - call stat2(a,ni,nj,amin,amax,amean,avar,asd) - write(6,12) amean,amin,amax,avar,asd -12 format(' ',/,' ',' input field mean = ',1pe13.4,/ & - ' ',' amin = ',1pe13.4,/ & - ' ',' amax = ',1pe13.4,/ & - ' ',' variance = ',1pe13.4,/ & - ' ',' stnd dev = ',1pe13.4,//) - qtitle='raw field ' - call qprntn(a,qtitle,1,1,ni,nj,iskip,6) - - end if - -! mmmmmmmmmmmmmmmmm main loops, npass, the nus - - do nn=1,npass - - do l=1,nnu - - do i=ib,ie - do j=jb,je - - if( & - a(i,j).eq.undef.or. & - a(i+1,j).eq.undef.or. & - a(i-1,j).eq.undef.or. & - a(i,j-1).eq.undef.or. & - a(i,j+1).eq.undef.or. & - a(i+1,j+1).eq.undef.or. & - a(i+1,j-1).eq.undef.or. & - a(i-1,j-1).eq.undef.or. & - a(i-1,j+1).eq.undef & - ) then - b(i,j)=a(i,j) - - else - - b(i,j)=a(i,j)*(1.0-anu(l))**2 & - + 0.5*anu(l)*(1.0-anu(l))* & - (a(i+1,j)+a(i-1,j)+a(i,j+1)+a(i,j-1)) & - + 0.25*(anu(l)**2)* & - (a(i-1,j-1)+a(i-1,j+1)+a(i+1,j-1)+a(i+1,j+1)) - endif - end do - end do - - do i=ib,ie - do j=jb,je - a(i,j)=b(i,j) - end do - end do - - end do - - end do - - if(ioresp) then - - write(6,200) npass,nnu -200 format(' ',//,' ','smoothing function analysis'/ & - ' ',5x,'number of passes = ',i2/ & - ' ',5x,'number of elements per pass = ',i2) - do k=1,nnu - write(6,201) k,anu(k) -201 format(' ',7x,'k = ',i2, & - ' smoothing coefficient nu = ',f6.3) - end do - - pi=4.0*atan(1.0) - - do i=2,ni - b(i,1)=float(i) - b(i,2)=1.0 - do mm=1,nnu - b(i,2)=b(i,2)*(1.0-anu(mm)*(1.0-cos(2.0*pi/float(i)))) - end do - - b(i,2)=b(i,2)**npass - end do - -! - write(6,222) -222 format(' ','response function as a function of wavelength ', & - 'in grid units*dx',//, & - ' ',' lambda response ',//) -! - do i=2,ni - rlambda=dx*i - write(6,225) rlambda,b(i,2) -225 format(' ',f7.1,3x,f6.3) - end do - - end if - - return - - end subroutine smth2d - -!sms$ignore end - -end module libmf - -subroutine mktopo(z0in,nip) - -!sms$ignore begin - - use const - use libmf - - use module_control,only: glvl,topodatfile,topoglvldir,toponpass,toposmoothfact - - implicit none - - integer,intent(IN) :: nip - real,intent(INOUT) :: z0in(nip) - - real gridscale - real blat,blon,dlon,dlat,rlat,rlon - real radinf,radinfj,undef,z0comp,z0mean,dx - real z0outmean,z0outmax,z0outmin - - integer ni,nj,nnu,i,j,ib,ie,jb,je - - integer nm,irc,iunittopo,iunitglvl,iskip - - parameter(ni=4001,nj=2000,nnu=2) - - character(16) :: header - character(120) :: gpath,tpath - - real(kind=4), allocatable :: lat(:),lon(:) - - real(4) topo(ni,nj),dum(ni,nj),anu(nnu),z0out(nip) - - logical iosmth2dresp,iosmth2d,diag - - if(glvl <= 9) then - gridscale=15.0*(10-glvl) - else - print*,'EEE invalid glvl must be <= 9' - stop 'bad glvl' - endif - - - blon=-179.9550 - blat=-89.9550 - - dlon=360.0/(ni) - dlat=180.0/(nj) - - print*,'dlon: ',dlon,' dlat: ',dlat,' elon: ',blon+(ni-1)*dlon,' elat: ',blat+(nj-1)*dlat - -! -! allocate arrays -! - - allocate (lat(nip),lon(nip),stat=irc) - - print*, 'allocate irc = ',irc,' nip: ',nip,gridscale,toposmoothfact - - iunittopo=30 - iunitglvl=12 - - - gpath=trim(topoglvldir)//'glvl.dat' - tpath=trim(topodatfile) - - print*,'iiiiiiiiii ',gpath - print*,'tttttttttt ',tpath - -! -! read in the glvl.dat for lat/lons -! - - open(iunitglvl,file=gpath,form='unformatted',status='old',err=800) - - read(iunitglvl) header - print*,'h1 ',header - read(iunitglvl) header - - print*,'h2 ',header - read(iunitglvl) lat - read(iunitglvl) lon - close(iunitglvl) - - print*,'HHHHHHHHHHHHHHHHH ',header - -! -! read in 5' wrf topo file -! - - open(iunittopo,file=tpath,form='unformatted',status='old',err=801) - read(iunittopo) topo - close(iunittopo) - - -! -! smooth topo -! - - if(toponpass > 0) then - - ib=1 - ie=ni - jb=1 - je=nj - anu(1)=0.5 - anu(2)=0.5 - undef=1e20 - iskip=1 - dx=gridscale - - call smth2d(topo,ni,nj,ib,ie,jb,je, & - anu,toponpass,nnu,iosmth2dresp,iosmth2d,iskip,dx,dum,undef) - endif - -! -! analyze the topo to the icos grid -! - - radinf=gridscale*toposmoothfact*0.5 - radinfj=(radinf*km2deglat)/dlat - - do i=1,nip - rlat=lat(i)*rad2deg - rlon=lon(i)*rad2deg - if(rlon > 180.0) rlon=rlon-360.0 - z0comp=z0in(i) - call anltopo(z0comp,topo,rlat,rlon,ni,nj,z0out(i), & - blat,dlat,blon,dlon,radinf,radinfj) - enddo - - - z0outmean=0.0 - z0outmax=-1e20 - z0outmin=1e20 - - nm=0 - do i=1,nip - if(z0out(i) > -1e10 .and. z0out(i) < 1e20) then - nm=nm+1 - z0outmean=z0outmean+z0out(i) - endif - - if(z0out(i) < z0outmin) z0outmin=z0out(i) - if(z0out(i) > z0outmax) z0outmax=z0out(i) - enddo - - z0outmean=z0outmean/nm - - print*,' glvl: ',glvl - print*,' gridscale: ',gridscale - print*,' toposmoothfact: ',toposmoothfact - print*,' radinf in dj units: ',radinfj - print*,' nip: ',nip - print*,' nm: ',nm - print* - print*,' z0outmean: ',z0outmean - print*,' z0outmax: ',z0outmax - print*,' z0outmin: ',z0outmin - print* - - deallocate(lat,lon) - - goto 900 -800 continue - print*,'error in open of g?glvl.dat' - -801 continue - print*,'error in open of topo dat file' - - -900 continue - - do i=1,nip - z0in(i)=z0out(i) - enddo - - return - -!sms$ignore end - -end subroutine mktopo - -subroutine anltopo(z0test,topo,rlat,rlon,ni,nj,z0out, & - blat,dlat,blon,dlon,radinf,radinfj) - -!sms$ignore begin - - use const - - real(4) topo(ni,nj),z0s(ni*20) - - integer verb - - verb=0 - - ri=(rlon-blon)/dlon+1.0 - rj=(rlat-blat)/dlat+1.0 - - rlatfact=cos(rlat*deg2rad) - - radinfi=0.0 - if(rlatfact > 0.0) radinfi=radinfj/rlatfact - - rjb=rj-radinfj-1.0 - rje=rj+radinfj+1.0 - - if(rjb < 1) rjb=1.0 - if(rje > nj) rje=nj - - if(radinfi == 0) then - rib=1 - rie=ni - else - rib=ri-radinfi-1.0 - rie=ri+radinfi+1.0 - endif - - if(rlatfact == 0.0) then - rib=1.0 - rie=ni/2 - else - if(rib < 1) rib=1.0 - if(rie > ni) rie=ni - endif - - ib=nint(rib) - ie=nint(rie) - - jb=nint(rjb) - je=nint(rje) - - if(ib < 1) ib=1 - if(ie > ni) ie=ni - - if(jb < 1) jb=1 - if(je > nj) je=nj - - - z0bar=0.0 - z0rms=0.0 - nz0=0 - distmin=1e20 - - do ii=ib,ie - do jj=jb,je - tlat=blat+(jj-1)*dlat - tlon=blon+(ii-1)*dlon - dy=(tlat-rlat) - dx=(tlon-rlon)*rlatfact - dist=sqrt(dx*dx+dy*dy)*deglat2km - if(dist < distmin) then - distmin=dist - z0min=topo(ii,jj) - endif - - if(dist <= radinf) then - nz0=nz0+1 - z0s(nz0)=topo(ii,jj) - endif - - end do - end do - - do n=1,nz0 - z0bar=z0bar+z0s(n) - enddo - - if(nz0 > 0) then - z0bar=z0bar/nz0 - else - print*,'in analtopo no points! nz0 = 0',rlat,rlon - stop 'no points' - endif - - if(verb == 1) then - dz0=z0test-z0bar - write(*,'("final",2x,2(f7.2,1x),2x,i6,1x,2(f7.2,1x),2x,(2(f7.2,1x)),2x,4(i5,1x))') & - rlat,rlon,nz0,z0bar,dz0,distmin,z0min,ib,(ie-ib),jb,(je-jb) - endif - - z0out=z0bar - - return - -!sms$ignore end - -end subroutine anltopo diff --git a/src/fim/FIMsrc/prep/ss2icos/readenkfanal.F90 b/src/fim/FIMsrc/prep/ss2icos/readenkfanal.F90 deleted file mode 100644 index a7f0325..0000000 --- a/src/fim/FIMsrc/prep/ss2icos/readenkfanal.F90 +++ /dev/null @@ -1,510 +0,0 @@ -subroutine readenkfanal(nvp,bkgFile,anlFile,bkgFileSig,us3d,vs3d,dp3d,mp3d,pr3d,ex3d,ph3d,tr3d) - -! read data produced by EnKF analysis - - use module_control,only: glvl,nvl,nvlp1,nip,ntra,ntrb,curve,NumCacheBLocksPerPE,& - PrintIpnDiag,PrintDiagProgVars,PrintDiagNoise,PrintDiags,ptop,pure_sig - use module_constants,only:sigak,sigbk - implicit none - - integer ,intent(IN) :: nvp - CHARACTER(len=80),intent(IN) :: anlFile,bkgFile,bkgFileSig - -!SMS$DISTRIBUTE(dh,NIP) BEGIN - real,intent(out) :: us3d(nvl ,nip) ! zonal wind (m/s), layer - real,intent(out) :: vs3d(nvl ,nip) ! meridional wind (m/s), layer - real,intent(out) :: dp3d(nvl ,nip) ! del p between coord levels (pascals) - real,intent(out) :: mp3d(nvl ,nip) ! Montgomery Potential (m^2/s^2) - real,intent(out) :: pr3d(nvlp1,nip) ! pressure (pascal) - real,intent(out) :: ex3d(nvlp1,nip) ! exner function - real,intent(out) :: ph3d(nvlp1,nip) ! geopotential (=gz), m^2/s^2 - real,intent(out) :: tr3d(nvl ,nip,ntra+ntrb)! 1=pot.temp, 2=water vapor, 3=cloud condensate, 4=ozone - real(4) :: hs_i( nip) ! geopotential (g*zs) at surface - real(4) :: ps_i( nip) ! surface pressure in pascals - real(4) :: t_i (nvp ,nip) ! temperature in Kelvins - real(4) :: qv_i(nvp ,nip) ! specific humidity - real(4) :: qc_i(nvp ,nip) ! cloud condensate - real(4) :: u_i (nvp ,nip) ! zonal velocity - real(4) :: v_i (nvp ,nip) ! meridional velocity - real(4) :: o3_i(nvp ,nip) ! ozone mixing ratio - real(4) :: p_i (nvp+1,nip) ! interface pressure - real(4) :: z_i (nvp+1,nip) ! geopotential height - integer :: k -!SMS$DISTRIBUTE END - -! don't use 82, since it's assumed to be big endian - integer,parameter :: luanl=83 - - allocate(sigak(nvlp1),sigbk(nvlp1)) - sigak(1:65) = & - (/ 0.000000, 0.000000, 0.575000, 5.741000, 21.516001, & - 55.712002, 116.899002, 214.014999, 356.222992, 552.719971, & - 812.489014, 1143.988037, 1554.788940, 2051.149902, 2637.552979, & - 3316.217041, 4086.614014, 4945.028809, 5884.206055, 6893.117188, & - 7956.908203, 9057.050781, 10171.711914, 11276.347656, 12344.490234, & - 13348.670898, 14261.434570, 15056.341797, 15708.892578, 16197.315430, & - 16503.144531, 16611.603516, 16511.736328, 16197.966797, 15683.489258, & - 14993.074219, 14154.316406, 13197.065430, 12152.936523, 11054.852539, & - 9936.614258, 8832.537109, 7777.149902, 6804.874023, 5937.049805, & - 5167.145996, 4485.493164, 3883.052002, 3351.459961, 2883.038086, & - 2470.788086, 2108.365967, 1790.051025, 1510.711060, 1265.751953, & - 1051.079956, 863.057983, 698.456970, 554.424011, 428.433990, & - 318.265991, 221.957993, 137.789993, 64.247002, 0.000000 /) - - sigbk(1:65) = & -(/ 1.000000000, 0.994671166, 0.988626599, 0.981742263, 0.973867595, & - 0.964827597, 0.954434097, 0.942491055, 0.928797305, 0.913151026, & - 0.895354986, 0.875223577, 0.852590680, 0.827318847, 0.799309731, & - 0.768514693, 0.734945238, 0.698682904, 0.659887016, 0.618799627, & - 0.575746655, 0.531134844, 0.485443324, 0.439210802, 0.393018246, & - 0.347468495, 0.303164124, 0.260685444, 0.220570192, 0.183296233, & - 0.149268776, 0.118812189, 0.092166908, 0.069474578, 0.050646842, & - 0.035441618, 0.023555880, 0.014637120, 0.008294020, 0.004106710, & - 0.001635910, 0.000431060, 0.000036970, 0.000000000, 0.000000000, & - 0.000000000, 0.000000000, 0.000000000, 0.000000000, 0.000000000, & - 0.000000000, 0.000000000, 0.000000000, 0.000000000, 0.000000000, & - 0.000000000, 0.000000000, 0.000000000, 0.000000000, 0.000000000, & - 0.000000000, 0.000000000, 0.000000000, 0.000000000, 0.000000000 /) - - sigak(65)=ptop -!SMS$SERIAL ( : default=ignore) BEGIN - if ( pure_sig) then - call readgriddata_sig(luanl, anlFile, hs_i,ps_i,p_i,z_i,t_i,u_i,v_i,qv_i,o3_i,qc_i,nvp,nip) - else - call readgriddata( luanl,bkgFile,anlFile,bkgFileSig,hs_i,ps_i,p_i,z_i,t_i,u_i,v_i,qv_i,o3_i,qc_i,nvp,nip) - endif - - print*,'returned from readgriddata' - print*,hs_i(100),ps_i(100),nvp,nip - DO k=1,nvp,6 - print*,p_i(k,100),z_i(k,100),t_i(k,100) - ENDDO -!SMS$SERIAL END -! Now do vertical interpolation. - call fimini(nvp,hs_i,ps_i,z_i,p_i,t_i,qv_i,u_i,v_i,o3_i,qc_i, & - us3d,vs3d,dp3d,mp3d,pr3d,ex3d,ph3d,tr3d) - print*,'returned from fimini' - DO k=1,nvp,6 - print*,pr3d(k,100),ex3d(k,100),tr3d(k,100,1) - ENDDO - - - return - -end subroutine readenkfanal - - subroutine readgriddata(iunit,filename,filename1,filename2,topo,psg,pr3d,ph3d,tempg,u3d,v3d,qg1,qg2,qg3,nlevs,npts) - - use module_constants,only: rd,cp,grvity,p1000,qvmin,sigak,sigbk - use module_control ,only: ptop,PrintDiags,PrintIpnDiag - use physcons ,only: con_fvirt - implicit none - integer, intent(in) :: nlevs,npts,iunit - character, intent(in) :: filename*80,filename1*80,filename2*80 - real, dimension(npts), intent(out) :: topo,psg - real, dimension(nlevs,npts), intent(out) :: tempg,u3d,v3d,qg1,qg2,qg3 - real, dimension(nlevs+1,npts), intent(out) :: pr3d,ph3d - -! locals - real, dimension(npts) :: lons,lats,tmp1,tmp2 - real, dimension(nlevs,npts) :: pslg - real, dimension(nlevs,npts) :: inc,tmp3d,sig - real, dimension(nlevs+1,npts) :: pr3da,ex3d - real :: exn,ptopin - integer i,k,nlevsin,ntracin,nptsin,ierr,iunit1,iunit2,ii - real, dimension(nlevs,npts) :: uswrk,vswrk,thwrk,qvwrk,o3wrk,qcwrk - real, dimension(nlevs+1,npts) :: exwrk - real :: theta_lyrs(nlevs) - real :: targ_in(nlevs,npts) - real :: th_in (nlevs,npts) - -!SMS$ignore begin - iunit1=44 - iunit2=45 - open(iunit,file=trim(filename),form="unformatted") - open(iunit1,file=trim(filename1),form="unformatted") - open(iunit2,file=trim(filename2),form="unformatted") - read(iunit,iostat=ierr) nptsin,nlevsin,ntracin,ptopin - read(iunit1,iostat=ierr) nptsin,nlevsin,ntracin,ptopin - read(iunit2,iostat=ierr) nptsin,nlevsin,ntracin,ptopin - if (npts .ne. nptsin .or. nlevs .ne. nlevsin .or. ntracin .ne. 3) then - print *,'error reading input file - npts,nlevs,ntrac !=',& - npts,nlevs,3,nptsin,nlevsin,ntracin - stop - end if - print *,'ptop = ',ptop - ! read lons, lats on model grid (radians) - not used here. - read(iunit) lons - read(iunit1) - read(iunit2) - read(iunit) lats - read(iunit1) - read(iunit2) - ! read surface orography. - read(iunit) topo - read(iunit1) - read(iunit2) - print *,'min/max topo',minval(topo),maxval(topo) - ! read pressure (hPa) on model layer midpoints. - do k=1,nlevs - read(iunit) pslg(k,:) - read(iunit1) - read(iunit2) - enddo - print *,'min/max pslg',minval(pslg),maxval(pslg) - ! read pressure (hPa) on model layer interaces (including - ! surface pressure (k=1) but not model top (k=nlevs+1)). - ! Model top pressure is assumed constant = ptop. - do k=1,nlevs - read(iunit) pr3d(k,:) - read(iunit1) pr3da(k,:) - read(iunit2) - enddo -! calculate sigma values for pr3d, update surface pressure from analysis, then re-calculate pr3d for rest of interfaces - ii=100 - DO k=2,nlevs - sig(k,:)=pr3d(k,:)/pr3d(1,:) - ENDDO - print*,'pr3d at ',ii,'=',pr3d(:,ii) - print*,'pr3da at ',ii,'=',pr3da(:,ii) - pr3d(1,:)=pr3da(1,:) - DO k=2,nlevs - pr3d(k,:)=sig(k,:)*pr3d(1,:) - ENDDO - print*,'pr3d at ',ii,'=',pr3d(:,ii) -! surface pressure does not need to be interpolated - pr3d = 1.0e2*pr3d - pr3da = 1.0e2*pr3da - pr3d(nlevs+1,:)=ptop - pr3da(nlevs+1,:)=ptopin - !reset pr3da to be on the gfs coordimate - do k=2,nlevs+1 - pr3da(k,:) =sigak(k)+sigbk(k)*pr3da(1,:) - enddo - ! re-diagnose layer pressures from interface pressures - ! using FIM's algorithm (from output.F90). - ex3d = cp*(pr3d/p1000)**(rd/cp) - do k=1,nlevs - do i=1,npts - if (pr3d(k,i).gt.pr3d(k+1,i)+0.1) then - exn = (ex3d(k ,i)*pr3d(k ,i) & - -ex3d(k+1,i)*pr3d(k+1,i))/ & - ((cp+rd)*(pr3d(k,i)-pr3d(k+1,i))) - else - exn = .5*(ex3d(k,i)+ex3d(k+1,i))/cp - end if - pslg(k,i)=p1000*(exn)**(cp/rd) ! layer pressure - enddo - enddo - ! put pr3da back to mb for interpolation - print *,'min/max pr3d',minval(pr3d),maxval(pr3d) - print *,'min/max psf',minval(pr3d(1,:)),maxval(pr3d(1,:)) - DO k=1,nlevs - print*,pr3d(k,ii),pr3da(k,ii),pslg(k,ii) - ENDDO - ! read virtual temperature. - do k=1,nlevs - read(iunit) tempg(k,:) - read(iunit1) tmp1 - read(iunit2) tmp2 - inc(k,:)=tmp1-tmp2 - print*,'temp inc =',k,inc(k,ii),tmp1(ii),tmp2(ii),tempg(k,ii) - enddo - call vlint2coor(npts, nlevs, nlevs+1, pr3da, inc,tmp3d, pslg, nlevs) - tempg(:,:) = tmp3d(:,:) + tempg(:,:) ! virt.pot.temperature - do k=1,nlevs - print*,'temp inc =',k,inc(k,ii),tmp3d(k,ii),tempg(k,ii) - enddo - print *,'min/max tempg',minval(tempg),maxval(tempg) - ! read u and v winds. - do k=1,nlevs - read(iunit) u3d(k,:) - read(iunit1) tmp1 - read(iunit2) tmp2 - inc(k,:)=tmp1-tmp2 - enddo - call vlint2coor(npts, nlevs, nlevs+1, pr3da, inc, tmp3d, pslg, nlevs) - u3d(:,:) = tmp3d(:,:) + u3d(:,:) - do k=1,nlevs - read(iunit) v3d(k,:) - read(iunit1) tmp1 - read(iunit2) tmp2 - inc(k,:)=tmp1-tmp2 - enddo - call vlint2coor(npts, nlevs, nlevs+1, pr3da, inc, tmp3d, pslg, nlevs) - v3d(:,:) = tmp3d(:,:) + v3d(:,:) - ! read "tracers" (vapor, ozone, cloud condensate) - do k=1,nlevs - read(iunit) qg1(k,:) - read(iunit1) tmp1 - read(iunit2) tmp2 - inc(k,:)=tmp1-tmp2 - enddo - call vlint2coor(npts, nlevs, nlevs+1, pr3da, inc,tmp3d, pslg, nlevs) - qg1(:,:) = max(tmp3d(:,:) + qg1(:,:),qvmin) ! water vapor - do k=1,nlevs - read(iunit) qg2(k,:) - read(iunit1) tmp1 - read(iunit2) tmp2 - inc(k,:)=tmp1-tmp2 - enddo - call vlint2coor(npts, nlevs, nlevs+1, pr3da, inc,tmp3d, pslg, nlevs) - qg2(:,:) = max(tmp3d(:,:) + qg2(:,:),0.) ! liquid water/condensate - do k=1,nlevs - read(iunit) qg3(k,:) - read(iunit1) tmp1 - read(iunit2) tmp2 - inc(k,:)=tmp1-tmp2 - enddo - call vlint2coor(npts, nlevs, nlevs+1, pr3da, inc,tmp3d, pslg, nlevs) - qg3(:,:) = max(tmp3d(:,:) + qg3(:,:),0.) ! ozone - close(iunit) - close(iunit1) - close(iunit2) - -!SMS$ignore end - - topo=topo*grvity - psg = pr3d(1,:) - call temptoz(npts,nlevs,rd,cp,p1000,pr3d,pslg,topo,tempg,ph3d) -! convert virtual t to sensible t. - tempg=tempg/(1.+con_fvirt*qg1(:,:)) - - end subroutine readgriddata - - subroutine readgriddata_sig(iunit,filename,topo,psg,pr3d,ph3d,tempg,u3d,v3d,qg1,qg2,qg3,nlevs,npts) - - use module_constants,only: rd,cp,grvity,p1000,qvmin,sigak,sigbk - use module_control ,only: ptop,PrintDiags,PrintIpnDiag - use physcons ,only: con_fvirt - implicit none - integer, intent(in) :: nlevs,npts,iunit - character, intent(in) :: filename*80 - real, dimension(npts), intent(out) :: topo,psg - real, dimension(nlevs,npts), intent(out) :: tempg,u3d,v3d,qg1,qg2,qg3 - real, dimension(nlevs+1,npts), intent(out) :: pr3d,ph3d - -! locals - real, dimension(npts) :: lons,lats,tmp1,tmp2 - real, dimension(nlevs,npts) :: pslg - real, dimension(nlevs,npts) :: inc,tmp3d,sig - real, dimension(nlevs+1,npts) :: ex3d - real :: exn,ptopin - integer i,k,nlevsin,ntracin,nptsin,ierr,ii - real, dimension(nlevs,npts) :: uswrk,vswrk,thwrk,qvwrk,o3wrk,qcwrk - real, dimension(nlevs+1,npts) :: exwrk - real :: theta_lyrs(nlevs) - real :: targ_in(nlevs,npts) - real :: th_in (nlevs,npts) - -!SMS$ignore begin - open(iunit,file=trim(filename),form="unformatted") - read(iunit,iostat=ierr) nptsin,nlevsin,ntracin,ptopin - if (npts .ne. nptsin .or. nlevs .ne. nlevsin .or. ntracin .ne. 3) then - print *,'error reading input file - npts,nlevs,ntrac !=',& - npts,nlevs,3,nptsin,nlevsin,ntracin - stop - end if - print *,'ptop = ',ptop - ! read lons, lats on model grid (radians) - not used here. - read(iunit) lons - read(iunit) lats - ! read surface orography. - read(iunit) topo - print *,'min/max topo',minval(topo),maxval(topo) - ! read pressure (hPa) on model layer midpoints. - do k=1,nlevs - read(iunit) pslg(k,:) - enddo - print *,'min/max pslg',minval(pslg),maxval(pslg) - ! read pressure (hPa) on model layer interaces (including - ! surface pressure (k=1) but not model top (k=nlevs+1)). - ! Model top pressure is assumed constant = ptop. - do k=1,nlevs - read(iunit) pr3d(k,:) - enddo - ii=100 - print*,'before pr3d at ',ii,'=',pr3d(:,ii) - pr3d(1,:) = 1.0e2*pr3d(1,:) - !reset pr3d to be on the gfs coordimate - do k=2,nlevs - pr3d(k,:) =sigak(k)+sigbk(k)*pr3d(1,:) - enddo - pr3d(nlevs+1,:)=ptop - print*,'after pr3d at ',ii,'=',pr3d(:,ii) - ! re-diagnose layer pressures from interface pressures - ! using FIM's algorithm (from output.F90). - ex3d = cp*(pr3d/p1000)**(rd/cp) - do k=1,nlevs - do i=1,npts - if (pr3d(k,i).gt.pr3d(k+1,i)+0.1) then - exn = (ex3d(k ,i)*pr3d(k ,i) & - -ex3d(k+1,i)*pr3d(k+1,i))/ & - ((cp+rd)*(pr3d(k,i)-pr3d(k+1,i))) - else - exn = .5*(ex3d(k,i)+ex3d(k+1,i))/cp - end if - pslg(k,i)=p1000*(exn)**(cp/rd) ! layer pressure - enddo - enddo - print*,'after pslg at ',ii,'=',pslg(:,ii) - - ! read virtual temperature. - do k=1,nlevs - read(iunit) tempg(k,:) - enddo - print *,'min/max tempg',minval(tempg),maxval(tempg) - ! read u and v winds. - do k=1,nlevs - read(iunit) u3d(k,:) - enddo - do k=1,nlevs - read(iunit) v3d(k,:) - enddo - ! read "tracers" (vapor, ozone, cloud condensate) - do k=1,nlevs - read(iunit) qg1(k,:) - enddo - do k=1,nlevs - read(iunit) qg2(k,:) - enddo - do k=1,nlevs - read(iunit) qg3(k,:) - enddo - close(iunit) - -!SMS$ignore end - - topo=topo*grvity - psg = pr3d(1,:) - call temptoz(npts,nlevs,rd,cp,p1000,pr3d,pslg,topo,tempg,ph3d) -! convert virtual t to sensible t. - tempg=tempg/(1.+con_fvirt*qg1(:,:)) - - end subroutine readgriddata_sig - -!============================================================================= -! Level and layer interpolation, target coordinate: passed in (v_coor) -! -! -! Figure 1. | Figure 2. -! Level variables at interface: | Layer variables: -! | -! -------------- int. level nvl + 1 | ---------------- int. level nvl + 1 -! : | : -! : | : -! -------------- int. level k + 1 | ---------------- int. level k + 1 -! | //////////////// variable at layer k -! -------------- int. level k | ---------------- int. level k -! : | : -! : | : -! -------------- int. level 1 | ---------------- int. level 1 -! | -! -! -! N. Wang, Feb. 2008 -!============================================================================= - - SUBROUTINE vlint2coor(nip, nvl, nvlp1, data_pr, data_var, data, v_coor, nvc) - IMPLICIT NONE - - INTEGER, intent(in) :: nip, nvl, nvlp1, nvc - REAL, intent(in) :: data_pr(nvlp1,nip), data_var(nvl,nip), v_coor(nvl,nip) - REAL, intent(out) :: data(nvc,nip) - - REAL pi_dn, pi_up, pi_co, dn_val, up_val - INTEGER k,i, l - DO i = 1, nip - k = 1 - DO l = 1, nvc - IF (v_coor(l,i) >= data_pr(1,i)) THEN - data(l,i) = data_var(1,i) - CYCLE - END IF - IF (v_coor(l,i) <= data_pr(nvlp1,i)) THEN - data(l,i) = data_var(nvl,i) - CYCLE - END IF - DO WHILE (v_coor(l,i) < data_pr(k+1,i)) - IF (k == nvlp1 - 1) THEN - EXIT - ELSE - k = k + 1 - ENDIF - END DO ! k and k+1 are the current indexes for interpolation - IF (nvl == nvlp1) THEN ! level variables, see fig. 1. - pi_dn = (data_pr(k,i) / 1000.00)**0.286 - pi_up = (data_pr(k+1,i) / 1000.00)**0.286 - pi_co = (v_coor(l,i) / 1000.00)**0.286 - dn_val = data_var(k,i) - up_val = data_var(k+1,i) - ELSE ! layer variables, see fig. 2. - pi_dn = (data_pr(k,i) / 1000.00)**0.286 - pi_up = (data_pr(k+1,i) / 1000.00)**0.286 - pi_co = (v_coor(l,i) / 1000.00)**0.286 - IF (pi_co > (pi_dn + pi_up) / 2.0) THEN ! lower half of the layer - IF (k == 1) THEN - pi_dn = (data_pr(k,i) / 1000.00)**0.286 - pi_up = ((data_pr(k,i) / 1000.00)**0.286 + (data_pr(k+1,i) / 1000.00)**0.286)/ 2.0 - pi_co = (v_coor(l,i) / 1000.00)**0.286 - dn_val = data_var(k,i) - up_val = dn_val - ELSE - pi_dn = ((data_pr(k,i) / 1000.00)**0.286 + (data_pr(k-1,i) / 1000.00)**0.286)/ 2.0 - pi_up = ((data_pr(k,i) / 1000.00)**0.286 + (data_pr(k+1,i) / 1000.00)**0.286)/ 2.0 - pi_co = (v_coor(l,i) / 1000.00)**0.286 - dn_val = data_var(k-1,i) - up_val = data_var(k,i) - ENDIF - ELSE ! upper half of the layer - IF (k == nvl) THEN - pi_dn = ((data_pr(k,i) / 1000.00)**0.286 + (data_pr(k+1,i) / 1000.00)**0.286)/ 2.0 - pi_up = (data_pr(k+1,i) / 1000.00)**0.286 - pi_co = (v_coor(l,i) / 1000.00)**0.286 - dn_val = data_var(k,i) - up_val = dn_val - ELSE - pi_dn = ((data_pr(k,i) / 1000.00)**0.286 + (data_pr(k+1,i) / 1000.00)**0.286)/ 2.0 - pi_up = ((data_pr(k+1,i) / 1000.00)**0.286 + (data_pr(k+2,i) / 1000.00)**0.286)/ 2.0 - pi_co = (v_coor(l,i) / 1000.00)**0.286 - dn_val = data_var(k,i) - up_val = data_var(k+1,i) - ENDIF - - ENDIF - ENDIF - data(l,i) = up_val + (pi_co - pi_up) * & - (dn_val - up_val) / (pi_dn - pi_up) - END DO - IF (i.EQ.100) THEN - print*,'in vlint' - print*,'data_pr=',data_pr(:,i) - print*,'data_var=',data_var(:,i) - print*,'data=',data(:,i) - print*,'v_coor=',v_coor(:,i) - ENDIF - END DO - END SUBROUTINE vlint2coor - subroutine temptoz(npts,nlevs,rgas,cp,p1000,pint,pl,zs,tv,z) - implicit none - integer, intent(in) :: npts,nlevs - real, dimension(nlevs, npts) :: thetav,pil - real, dimension(nlevs+1,npts) :: pii - real, intent(in), dimension(nlevs,npts) :: tv,pl - real, intent(in), dimension(nlevs+1,npts) :: pint - real, intent(out), dimension(nlevs+1,npts) :: z - real, intent(in), dimension(npts) :: zs - real, intent(in) :: rgas,cp,p1000 - integer j,k - - pii = cp*(pint/p1000)**(rgas/cp) - pil = cp*(pl/p1000)**(rgas/cp) - thetav = cp*tv/pil - do j=1,npts - z(1,j) = zs(j) - do k=1,nlevs - z(k+1,j) = z(k,j) - thetav(k,j) * (pii(k+1,j)-pii(k,j)) - end do - end do - - end subroutine temptoz diff --git a/src/fim/FIMsrc/prep/ss2icos/ss2icos.F90 b/src/fim/FIMsrc/prep/ss2icos/ss2icos.F90 deleted file mode 100644 index 82fe1c4..0000000 --- a/src/fim/FIMsrc/prep/ss2icos/ss2icos.F90 +++ /dev/null @@ -1,748 +0,0 @@ - -! Thanks to Pete Johnsen of Cray for the following optimization which -! allows 10km FIM to run on as many as 33,000 cores. This optimization has -! general utility. See "pjj" for details. -! -!pjj -! Cray XT code to reduce amount of memory used by icos grid -! variables. This splits the 10 variables into 5 sets of 2 -! which reuses available memory. - -subroutine ss2icos(nvp,sanlFile,us3d,vs3d,dp3d,mp3d,pr3d,ex3d,ph3d,tr3d,gfsltln_file) - -! read spherical data (GFS) and perform 2-step transform: -! --- (1) horizontal transform from spherical to icos grid -! --- (2) vertical transform from sigma to hybrid-isentropic coord. - -!SMS$ignore begin - use sigio_module -!SMS$ignore end - use module_control,only: glvl,nvl,nvlp1,nip,ntra,ntrb,curve, & - NumCacheBLocksPerPE,PrintIpnDiag, & - PrintDiagProgVars,PrintDiagNoise,PrintDiags, & - alt_topo,pure_sig - use module_constants,only: grvity,sigak,sigbk -!SMS$ignore begin - USE slint, ONLY: bilinear_init -!SMS$ignore end - use stencilprint - implicit none - - integer ,intent(IN) :: nvp - CHARACTER(len=80),intent(IN) :: sanlFile - CHARACTER(len=80),intent(IN) :: gfsltln_file - -!SMS$DISTRIBUTE(dh,NIP) BEGIN - real,intent(out) :: us3d(nvl ,nip) ! zonal wind (m/s), layer - real,intent(out) :: vs3d(nvl ,nip) ! meridional wind (m/s), layer - real,intent(out) :: dp3d(nvl ,nip) ! del p between coord levels (pascals) - real,intent(out) :: mp3d(nvl ,nip) ! Montgomery Potential (m^2/s^2) - real,intent(out) :: pr3d(nvlp1,nip) ! pressure (pascal) - real,intent(out) :: ex3d(nvlp1,nip) ! exner function - real,intent(out) :: ph3d(nvlp1,nip) ! geopotential (=gz), m^2/s^2 - real,intent(out) :: tr3d(nvl ,nip,ntra+ntrb)! 1=pot.temp, 2=water vapor, 3=cloud condensate, 4=ozone - - real(4) :: hs_lev( nip) ! surface height (m) - real(4) :: ps_lev( nip) ! surface pressure in pascals - real(4) :: t_lyr (nvp ,nip) ! temperature in Kelvins - real(4) :: qv_lyr(nvp ,nip) ! specific humidity - real(4) :: qc_lyr(nvp ,nip) ! cloud condensate - real(4) :: u_lyr (nvp ,nip) ! zonal velocity - real(4) :: v_lyr (nvp ,nip) ! meridional velocity - real(4) :: o3_lyr(nvp ,nip) ! ozone mixing ratio - real(4) :: p_lev (nvp+1,nip) ! interface pressure - real(4) :: z_lev (nvp+1,nip) ! geopotential height -!SMS$DISTRIBUTE END - - integer :: ipn - integer(sigio_intkind),parameter :: lusig=82 - type(sigio_head) :: head - type(sigio_data) :: data - - real(4) :: sig_lyr(nvp ) ! sig at layer midpoints and interfaces. - real(4) :: sig_lev(nvp+1) ! sig at layer midpoints and interfaces. - - integer(sigio_intkind) :: iret - -! integer :: n -! pjj/cray - from ss2g1 - integer :: imax, jmax -! Storage routines for GFS input -- may be used multiply as indicated by '/' - real(4), allocatable :: & - f1(:), & ! surface pressure - f2(:), & ! surface height (m) - g1(:,:), & ! layer virt.temp/u_wind/ozone/condensate - g2(:,:), & ! layer specif.hum/v_wind - g3(:,:), & ! interface geopotential - pi(:,:), & ! interface pressure - pl(:,:), & ! layer midpoint pressure - dl(:,:) ! sig layer thickness - -!SMS$SERIAL ( : default=ignore) BEGIN - call sigio_srohdc(lusig,sanlFile,head,data,iret) - if (iret .ne. 0) then - call errmsg('ss2icos: error reading '//sanlFile) -! call errexit(2) ! errexit doesn't call MPI_ABORT -> use STOP - STOP - endif - if(nvp /= head%levs) then - call errmsg('ss2icos: nvp differs from head%levs') - print '(a,2i5)','nvp,head%levs =',nvp,head%levs -! call errexit(2) ! errexit doesn't call MPI_ABORT -> use STOP - STOP - endif - if (pure_sig .and. nvl /= head%levs) then - call errmsg('ss2icos: in "pure_sig" mode, nvl must match head%levs') - print '(a,2i5)','nvl,head%levs =',nvl,head%levs -! call errexit(2) ! errexit doesn't call MPI_ABORT -> use STOP - STOP - end if - -! pjj/cray - from ss2gg1 -! grid_file2 = "glvl.dat" -! imax = 1152 -! jmax = 576 - - imax=head%lonb - jmax=head%latb - - -!SMS$ignore begin - OPEN (66,file="glvl.dat",status='old',form='unformatted') - call TestGlvlHeader (66, "glvl.dat",'ss2icos',glvl) - call TestCurveHeader(66, "glvl.dat",'ss2icos',curve) - CALL bilinear_init(gfsltln_file, imax*jmax, 66, nip) - close(66) -!SMS$ignore end - - ! get surface height & pres (hs_lev,ps_lev) - ! interpolated to icos grid. - - allocate(f1(imax*jmax), f2(imax*jmax)) - - call ss2gg_xt1(4,imax, jmax, head,data,nip,glvl,curve,nvp, & - hs_lev,ps_lev, f1, f2) - - ! write out GrADS control file. - call ss2gg2(4,imax, jmax, head,'siganl.ieee',sig_lev,sig_lyr) -!SMS$SERIAL end - - allocate (sigak(nvp+1),sigbk(nvp+1)) - -!SMS$SERIAL ( : default=ignore) BEGIN - - ! get temp (t_lyr), pres (p_lev), - ! spec hum (qv_lyr), cloud condensate (qc_lyr), - ! geopot height (z_lev) winds (u_lyr,v_lyr) and - ! ozone (o3_lyr) interpolated to icos grid. - - allocate( & - g1(imax*jmax,head%levs), & ! layer virt.temp/u_wind/ozone/condensate - g2(imax*jmax,head%levs), & ! layer specif.hum/v_wind - g3(imax*jmax,head%levs+1), & ! interface geopotential - pi(imax*jmax,head%levs+1), & ! interface pressure - pl(imax*jmax,head%levs), & ! layer midpoint pressure - dl(imax*jmax,head%levs) ) ! sig layer thickness - - call ss2gg_xt2(4,imax, jmax, head,data,nip,glvl,curve,nvp, & - sigak,sigbk,z_lev,p_lev, f1,f2,g1,g2,g3,pi,pl,dl ) - -!SMS$SERIAL end - -!SMS$SERIAL ( : default=ignore) BEGIN - call ss2gg_xt3(4,imax, jmax, head,data,nip,glvl,curve,nvp, & - t_lyr,qv_lyr, g1,g2 ) -!SMS$SERIAL end - -!SMS$SERIAL ( : default=ignore) BEGIN - call ss2gg_xt4(4,imax, jmax, head,data,nip,glvl,curve,nvp, & - u_lyr,v_lyr, g1,g2 ) - -! --- reverse velocity vectors at poles - u_lyr(:,1 )=-u_lyr(:,1 ) - v_lyr(:,1 )=-v_lyr(:,1 ) - u_lyr(:,nip)=-u_lyr(:,nip) - v_lyr(:,nip)=-v_lyr(:,nip) -!SMS$SERIAL end - -!SMS$SERIAL ( : default=ignore) BEGIN - call ss2gg_xt5(4,imax, jmax, head,data,nip,glvl,curve,nvp, & - o3_lyr,qc_lyr, g1) - call sigio_axdata(data,iret) ! deallocate array -! also done with these - deallocate (f1) - deallocate (f2) - deallocate (g1) - deallocate (g2) - deallocate (g3) - deallocate (pi) - deallocate (pl) - deallocate (dl) -!SMS$SERIAL end - - ! horizontal interpolation done. - - if (alt_topo) then - -!SMS$SERIAL ( : default=ignore) BEGIN - ! get topo on icos grid - !call rdtopo(hs_lev,nip) - call mktopo(hs_lev,nip) -!SMS$SERIAL END - - ! correct zg for new topo - call ss2ggtopo(nip,nvp, & - hs_lev,ps_lev,z_lev,p_lev,t_lyr,qv_lyr, & - u_lyr,v_lyr,o3_lyr,qc_lyr) - - end if - -!SMS$PARALLEL (dh,ipn) BEGIN - do ipn=1,nip - hs_lev(ipn)=hs_lev(ipn)*grvity ! surface height => surface geopot - enddo -!SMS$PARALLEL END - - call stencl(hs_lev,1,1.,'surface height (m)') - - ! Now do vertical interpolation. - - call fimini(nvp,hs_lev,ps_lev,z_lev,p_lev,t_lyr,qv_lyr, & - u_lyr,v_lyr,o3_lyr,qc_lyr,us3d,vs3d, & - dp3d,mp3d,pr3d,ex3d,ph3d,tr3d) - return -end subroutine ss2icos - - - - -! pjj/cray - first set -subroutine ss2gg_xt1(idrt,imax,jmax,head,data,nip,glvl,curve,nvp, & - hs_lev,ps_lev, f1, f2) - - use module_constants,only: rd,cp,qvmin,grvity,p1000 -!SMS$ignore begin - use sigio_module - use physcons - USE slint, ONLY:bl_int -!SMS$ignore end - implicit none - - integer,intent(in):: idrt,imax,jmax,nip,glvl,curve - type(sigio_head),intent(in):: head - type(sigio_data),intent(in):: data -! Storage routines for GFS input -- may be used multiply as indicated by '/' - real(4) f1(imax*jmax), & ! surface pressure - f2(imax*jmax) ! surface height (m) - - integer j,k,k1,ipn,nvp,kgrnd(nip) - real(4) icos2d(nip),icos2d1(nip) - real(4),intent(OUT) :: hs_lev(nip),ps_lev(nip) - real exlo,exup,th_lyr,pkap,zold(nip),znew - -! perform spherical transform on surface height (f2) field - call sptez(0,head%jcap,idrt,imax,jmax,data%hs,f2,1) - -! interpolate surface height to icos grid - CALL bl_int (f2, hs_lev) - -! perform spherical transform on surface pressure (f1) field - call sptez(0,head%jcap,idrt,imax,jmax,data%ps,f1,1) - f1=exp(f1)*1.e3 ! convert ln(ps) in centibars to ps in Pa. - -! interpolate surface pressure to icos grid - CALL bl_int (f1, ps_lev) ! unit in pascal - - print 100,'min,max of srf.height on spherical grid:', & - minval(f2),maxval(f2) - print 100,'min,max of srf.press on spherical grid:', & - minval(f1),maxval(f1) - print 100,'min,max of srf.height on icos grid:', & - minval(hs_lev),maxval(hs_lev) - print 100,'min,max of srf.press on icos grid:', & - minval(ps_lev),maxval(ps_lev) - 100 format (a,2f13.2) - - return -end subroutine ss2gg_xt1 - - - -subroutine ss2gg_xt2(idrt,imax,jmax,head,data,nip,glvl,curve,nvp, & - sigak,sigbk,z_lev,p_lev,f1,f2,g1,g2,g3,pi,pl,dl) - use module_constants,only: rd,cp,qvmin,grvity,p1000 -!SMS$ignore begin - use sigio_module - use physcons - USE slint, ONLY:bl_int -!SMS$ignore end - implicit none - - integer,intent(in):: idrt,imax,jmax,nip,glvl,curve - type(sigio_head),intent(inout):: head - type(sigio_data),intent(in):: data -! Storage routines for GFS input -- may be used multiply as indicated by '/' - real(4) f1(imax*jmax), & ! surface pressure - f2(imax*jmax), & ! surface height (m) - g1(imax*jmax,head%levs), & ! layer virt.temp/u_wind/ozone/condensate - g2(imax*jmax,head%levs), & ! layer specif.hum/v_wind - g3(imax*jmax,head%levs+1), & ! interface geopotential - pi(imax*jmax,head%levs+1), & ! interface pressure - pl(imax*jmax,head%levs), & ! layer midpoint pressure - dl(imax*jmax,head%levs) ! sig layer thickness - real,intent(OUT) :: sigak(head%levs+1),sigbk(head%levs+1) - - integer j,k,ipn,nvp - real(4) icos2d(nip),icos2d1(nip), exlo, exup - real(4),intent(OUT) :: z_lev(nvp+1,nip) - real(4),intent(OUT) :: p_lev(nvp+1,nip) - -! perform spherical transform on virt.temp. (g1) and specif.hum. (g2) field - call sptezm(0,head%jcap,idrt,imax,jmax,head%levs,data%t,g1,1) - call sptezm(0,head%jcap,idrt,imax,jmax,head%levs,data%q,g2,1) - -! calculate pressure at sigma layer midlevels (pl) and -! interfaces (pi). dl is pressure drop across layer. - - call modpr(imax*jmax,imax*jmax,head%levs,head%idvc,head%idsl,& - head%si,head%ak,head%bk,f1,pl,dl) - if(head%idvc.eq.2) then - write (*,'(/a)') & - 'GFS intfc.prs is defined as p(k) = ak(k) + bk(k) * surf.prs' - -! avoid zero pressure at top - head%ak(head%levs+1)=max(head%ak(head%levs+1),.2*head%ak(head%levs)) - head%bk(head%levs+1)=0. - - do k=1,head%levs+1 - pi(:,k)=head%ak(k)+head%bk(k)*f1 - sigak(k)=head%ak(k) - sigbk(k)=head%bk(k) - enddo - else - write (*,'(/a)') & - 'GFS intfc.prs is defined as p(k) = bk(k) * surf.prs' - do k=1,head%levs+1 - pi(:,k)=head%si(k)*f1 - sigak(k)=0. - sigbk(k)=head%si(k) - enddo - endif - write (*,'(a/(5f14.6))') 'ak array:',(head%ak(k),k=1,head%levs+1) - write (*,'(a/(5f14.6))') 'bk array:',(head%bk(k),k=1,head%levs+1) - -! Compute geopotential (g3) on interfaces (still on spherical grid!) - - do j=1,imax*jmax - exup=cp*(pi(j,1)/p1000)**(rd/cp) - g3(j,1)=f2(j)*grvity ! f2 = surface height - do k=1,head%levs - exlo=exup - exup=cp*(pi(j,k+1)/p1000)**(rd/cp) - g3(j,k+1)=g3(j,k)+(exlo-exup)*g1(j,k)*(p1000/pl(j,k))**(rd/cp) - end do - end do - -! interpolate geopotential and intfc.pressure to icos grid - - do k=1,head%levs+1 - CALL bl_int (g3(1,k), icos2d) - do ipn=1,nip - z_lev(k,ipn)=icos2d(ipn) - end do - CALL bl_int (pi(1,k), icos2d) - do ipn=1,nip - p_lev(k,ipn)=icos2d(ipn) - end do - enddo - - return -end subroutine ss2gg_xt2 - - - -subroutine ss2gg_xt3(idrt,imax,jmax,head,data,nip,glvl,curve,nvp, & - t_lyr,qv_lyr, g1,g2) - use module_constants,only: rd,cp,qvmin,grvity,p1000 -!SMS$ignore begin - use sigio_module - use physcons - USE slint, ONLY:bl_int -!SMS$ignore end - implicit none - - integer,intent(in):: idrt,imax,jmax,nip,glvl,curve - type(sigio_head),intent(in):: head - type(sigio_data),intent(in):: data -! Storage routines for GFS input -- may be used multiply as indicated by '/' - real(4) g1(imax*jmax,head%levs), & ! layer virt.temp/u_wind/ozone/condensate - g2(imax*jmax,head%levs) ! layer specif.hum/v_wind - - integer j,k,ipn,nvp - real(4) icos2d(nip),icos2d1(nip), exlo, exup - real(4),intent(OUT) :: t_lyr(nvp,nip),qv_lyr(nvp,nip) - -! interpolate virt.temp and specif.hum to icos grid - - do k=1,head%levs - CALL bl_int (g1(1,k), icos2d) - do ipn=1,nip - t_lyr(k,ipn)=icos2d(ipn) - end do - CALL bl_int (g2(1,k), icos2d) - do ipn=1,nip - qv_lyr(k,ipn)=max( icos2d(ipn), qvmin ) - end do - enddo - - return -end subroutine ss2gg_xt3 - - - -subroutine ss2gg_xt4(idrt,imax,jmax,head,data,nip,glvl,curve,nvp, & - u_lyr,v_lyr, g1,g2) - use module_constants,only: rd,cp,qvmin,grvity,p1000 -!SMS$ignore begin - use sigio_module - use physcons - USE slint, ONLY:bl_int -!SMS$ignore end - implicit none - - integer,intent(in):: idrt,imax,jmax,nip,glvl,curve - type(sigio_head),intent(in):: head - type(sigio_data),intent(in):: data -! Storage routines for GFS input -- may be used multiply as indicated by '/' - real(4) g1(imax*jmax,head%levs), & ! layer virt.temp/u_wind/ozone/condensate - g2(imax*jmax,head%levs) ! layer specif.hum/v_wind - - integer j,k,ipn,nvp - real(4) icos2d(nip),icos2d1(nip), exlo, exup - real(4),intent(OUT) :: u_lyr(nvp,nip),v_lyr(nvp,nip) - -! perform spherical transform on u wind (g1) and v wind (g2) field - call sptezmv(0,head%jcap,idrt,imax,jmax,head%levs,data%d,data%z,g1,g2,1) - -! interpolate u,v to icos grid - do k=1,head%levs - CALL bl_int (g1(1,k), icos2d) - CALL bl_int (g2(1,k), icos2d1) - do ipn=1,nip - u_lyr(k,ipn)=icos2d(ipn) - v_lyr(k,ipn)=icos2d1(ipn) - end do - enddo - - return -end subroutine ss2gg_xt4 - - - -subroutine ss2gg_xt5(idrt,imax,jmax,head,data,nip,glvl,curve,nvp, & - o3_lyr,qc_lyr, g1 ) - use module_constants,only: rd,cp,qvmin,grvity,p1000 -!SMS$ignore begin - use sigio_module - use physcons - USE slint, ONLY:bl_int -!SMS$ignore end - implicit none - - integer,intent(in):: idrt,imax,jmax,nip,glvl,curve - type(sigio_head),intent(in):: head - type(sigio_data),intent(in):: data -! Storage routines for GFS input -- may be used multiply as indicated by '/' - real(4) :: g1(imax*jmax,head%levs) ! layer virt.temp/u_wind/ozone/condensate - - integer j,k,ipn,nvp -! CHARACTER(len=80) :: grid_file1,grid_file2 - real(4) icos2d(nip),icos2d1(nip), exlo, exup - real(4),intent(OUT) :: qc_lyr(nvp,nip) - real(4),intent(OUT) :: o3_lyr(nvp,nip) - -! perform spherical transform on ozone (g1) field - call sptezm(0,head%jcap,idrt,imax,jmax,head%levs,data%q(1,1,2),g1,1) - -! interpolate ozone to icos grid - do k=1,head%levs - CALL bl_int (g1(1,k), icos2d) - do ipn=1,nip - o3_lyr(k,ipn)=max( icos2d(ipn), 0. ) - end do - enddo - -! perform spherical transform on cloud condensate (g1) field - call sptezm(0,head%jcap,idrt,imax,jmax,head%levs,data%q(1,1,3),g1,1) - -! interpolate cloud condensate to icos grid - do k=1,head%levs - CALL bl_int (g1(1,k), icos2d) - do ipn=1,nip - qc_lyr(k,ipn)=max( icos2d(ipn), 0. ) - end do - enddo - - return -end subroutine ss2gg_xt5 - - - -subroutine ss2gg2(idrt,imax,jmax,head,cfggg,si,sl) -!SMS$ignore begin - use sigio_module -!SMS$ignore end - implicit none - integer, intent(in) :: idrt,imax,jmax - type(sigio_head),intent(in) :: head - character*(*) cfggg - real(4) slat(jmax),wlat(jmax) - integer idat(8),jdat(8),jhr - real(8) rincin(5) !r8 because w3movdat is in libcol where it is r8 - integer idatin(8) - character*10 cdat(8) - integer n,luctl,iret - real :: ps(1) = 1.e5 - real(4) sl(head%levs),dl(head%levs),si(head%levs+1) - - luctl=12 - open(luctl,file='siganl.ctl',status='replace',iostat=iret) - - rincin = 0. - rincin(2) = head%fhour - idatin = 0 - idatin(1) = head%idate(4) - idatin(2) = head%idate(2) - idatin(3) = head%idate(3) - idatin(5) = head%idate(1) - call w3movdat(rincin,idatin,idat) - call w3pradat(idat,cdat) - jhr=12 ! ?? jsw - what is this for ?? - - call modpr(1,1,head%levs,head%idvc,head%idsl,& - head%si,head%ak,head%bk,ps,sl,dl) - sl=sl/1.e5 - dl=dl/1.e5 - do n=1,head%levs+1 - si(n)=(head%ak(n) + head%bk(n)*ps(1))/1.e5 - enddo - if(cfggg(1:1).eq.'/') then - write(luctl,'("dset ",a)') cfggg - else - write(luctl,'("dset ^",a)') cfggg - endif - write(luctl,'("options yrev")') - write(luctl,'("undef -9.99E+33")') - write(luctl,'("title ss2icos")') - write(luctl,'("xdef",i6," linear",2f12.6)') imax,0.d0,360.d0/imax - if(idrt.eq.0) then - write(luctl,'("ydef",i6," linear",2f12.6)')& - jmax,-90.d0,180.d0/(jmax-1) - elseif(idrt.eq.256) then - write(luctl,'("ydef",i6," linear",2f12.6)')& - jmax,-90.d0*(jmax-1)/jmax,180.d0/jmax - elseif(idrt.eq.4) then - call splat(idrt,jmax,slat,wlat) - write(luctl,'("ydef",i6," levels")') jmax - write(luctl,'(5f12.6)') 180.d0/acos(-1.d0)*asin(dble(slat(jmax:1:-1))) - endif - write(luctl,'("zdef",i6," levels")') head%levs - write(luctl,'(5f12.6)') sl - write(luctl,'("tdef",i6," linear ",i2.2,"Z",i2.2,a3,i4.4,1x,i6,"hr")')& - 1,idat(5),idat(3),cdat(2)(1:3),idat(1),jhr - write(luctl,'("vars",i6)') 10+head%ntrac - write(luctl,'("HS ",i3," 99 surface orography (m)")') 1 - write(luctl,'("PS ",i3," 99 surface pressure (Pa)")') 1 - write(luctl,'("P ",i3," 99 pressure (Pa)")') head%levs - write(luctl,'("DP ",i3," 99 delta pressure (Pa)")') head%levs - write(luctl,'("T ",i3," 99 temperature (K)")') head%levs - write(luctl,'("Q ",i3," 99 specific humidity (kg/kg)")') head%levs - write(luctl,'("RH ",i3," 99 relative humidity (%)")') head%levs - write(luctl,'("U ",i3," 99 zonal wind (m/s)")') head%levs - write(luctl,'("V ",i3," 99 meridional wind (m/s)")') head%levs - write(luctl,'("DIV ",i3," 99 divergence (m/s**2)")') head%levs - write(luctl,'("VOR ",i3," 99 vorticity (m/s**2)")') head%levs - do n=2,min(head%ntrac,9) - write(luctl,'("Q",i1,2x,i3," 99 tracer ",i1," (kg/kg)")') n,head%levs,n - enddo - do n=10,head%ntrac - write(luctl,'("Q",i2,1x,i3," 99 tracer ",i2," (kg/kg)")') n,head%levs,n - enddo - write(luctl,'("endvars")') - close (luctl) -end subroutine ss2gg2 - - -subroutine modpr(im,ix,km,idvc,idsl,si,ak,bk,ps,pm,pd) -!$$$ subprogram documentation block -! -! subprogram: modpr compute model pressures -! prgmmr: iredell org: w/nmc23 date: 92-10-31 -! -! abstract: compute model pressures. -! -! program history log: -! 2001-07-25 mark iredell -! -! usage: call modpr(im,ix,km,idvc,idsl,si,ak,bk,ps,pm,pd) -! input argument list: -! im integer number of points to compute -! ix integer first dimension -! km integer number of levels -! idvc integer vertical coordinate id -! (1 for sigma and 2 for hybrid) -! idsl integer type of sigma structure -! (1 for phillips or 2 for mean) -! si real (km+1) sigma interface values (idvc=1) -! ak real (km+1) hybrid interface a (idvc=2) -! bk real (km+1) hybrid interface b (idvc=2) -! ps real (ix) surface pressure (pa) -! output argument list: -! pm real (ix,km) mid-layer pressure (pa) -! pd real (ix,km) delta pressure (pa) -! -! attributes: -! language: fortran -! -!$$$ - implicit none - integer,intent(in):: im,ix,km,idvc,idsl - real,intent(in):: si(km+1),ak(km+1),bk(km+1),ps(im) - real,intent(out):: pm(ix,km),pd(ix,km) - real,parameter:: rocp=287.05/1004.6,rocp1=rocp+1,rocpr=1/rocp - real pid,piu - integer i,k -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - do k=1,km - do i=1,im - if(idvc.eq.2) then - pid=ak(k)+bk(k)*ps(i) - piu=ak(k+1)+bk(k+1)*ps(i) - else - pid=si(k)*ps(i) - piu=si(k+1)*ps(i) - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(idsl.eq.2) then - pm(i,k)=(pid+piu)/2 - else - pm(i,k)=((pid**rocp1-piu**rocp1)/(rocp1*(pid-piu)))**rocpr - endif - pd(i,k)=pid-piu - enddo - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -end subroutine modpr - - - -subroutine ss2ggtopo(nip,nvp, & - hs_lev,ps_lev,z_lev,p_lev,t_lyr,qv_lyr, & - u_lyr,v_lyr,o3_lyr,qc_lyr) - - use module_constants,only: rd,cp,qvmin,grvity,p1000 - - implicit none - -!SMS$DISTRIBUTE(dh,nip) BEGIN - integer j,k,k1,ipn,nip,nvp,kgrnd(nip) - - real(4) :: hs_lev(nip),ps_lev(nip),z_lev(nvp+1,nip), & - p_lev(nvp+1,nip),t_lyr(nvp,nip), & - qv_lyr(nvp,nip),qc_lyr(nvp,nip), & - u_lyr(nvp,nip),v_lyr(nvp,nip),o3_lyr(nvp,nip) - - real exlo,exup,th_lyr,pkap,zold(nip),znew - real hmax,hmin,pmax,pmin -!SMS$DISTRIBUTE END - -!SMS$PARALLEL (dh,ipn) BEGIN - print *,'switch to non-GFS surface height (topo dat file) ....' - do ipn=1,nip ! horiz. loop - do k=1,nvp ! vert. loop - if (z_lev(k+1,ipn).gt.hs_lev(ipn)*grvity) then - -! --- level k+1 is above ground. integrate hydrostat.eqn down from there. -! --- sequence of operations (layer k is sandwiched between interfaces k,k+1): -! --- (a) get old midlayer p^kappa from (partial p^(1+kappa))/(partial p) -! --- (b) get old theta from -! --- partial phi_old / partial pi_old = -theta_old -! --- (c) set theta_new = theta_old (not optimal, but tolerable for now) -! --- (d) get new bottom pressure from -! --- partial phi_new / partial pi_new = -theta_new -! --- (e) get new surf.temp. from theta_new and new bottom pressure - - exup=cp*(p_lev(k+1,ipn)/p1000)**(rd/cp) - exlo=cp*(p_lev(k ,ipn)/p1000)**(rd/cp) -! pkap=(exlo*p_lev(k,ipn)-exup*p_lev(k+1,ipn))/ & -! ((rd+cp)*(p_lev(k,ipn)- p_lev(k+1,ipn))) - th_lyr=(z_lev(k+1,ipn)-z_lev(k,ipn))/(exlo-exup) - exlo=exup+(z_lev(k+1,ipn)-hs_lev(ipn)*grvity)/th_lyr - p_lev(1,ipn)=p1000*(exlo/cp)**(cp/rd) ! new srf.pres. - ps_lev(ipn)=p_lev(1,ipn) - if (exlo.gt.exup+.01) then - pkap=(exlo*p_lev(1,ipn)-exup*p_lev(k+1,ipn))/ & - ((rd+cp)*(p_lev(1,ipn)- p_lev(k+1,ipn))) - else - pkap=.5*(exlo+exup)/cp - end if -! pkap=(exlo*p_lev(1,ipn)-exup*p_lev(k+1,ipn))/ & -! ((rd+cp)*(p_lev(1,ipn)- p_lev(k+1,ipn))) - t_lyr(1,ipn)=th_lyr*pkap ! new srf.temp. - z_lev(1,ipn)=hs_lev(ipn)*grvity ! new srf.geopot. - do k1=2,k - p_lev(k1,ipn)=p_lev(1,ipn) - t_lyr(k1,ipn)=t_lyr(1,ipn) - z_lev(k1,ipn)=z_lev(1,ipn) - end do - kgrnd(ipn)=k - zold(ipn)=z_lev(k+1,ipn) - exit - end if - end do ! vert. loop - end do ! horiz. loop - - hmin = minval(hs_lev(1:nip)) - hmax = maxval(hs_lev(1:nip)) - pmin = minval(ps_lev(1:nip)) - pmax = maxval(ps_lev(1:nip)) -!SMS$REDUCE(hmax,pmax,max) -!SMS$REDUCE(hmin,pmin,min) - - print 100,'min,max of new srf.height on icos grid:',hmin,hmax - print 100,'min,max of new srf.press on icos grid:',pmin,pmax - 100 format (a,2f13.2) - -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! optional: re-compute geopotential on interfaces to check for errors - do ipn=1,nip - znew=z_lev(1,ipn) - exup=cp*(p_lev(1,ipn)/p1000)**(rd/cp) - do k=1,kgrnd(ipn) - exlo=exup - exup=cp*(p_lev(k+1,ipn)/p1000)**(rd/cp) - if (exlo.gt.exup+.01) then - pkap=(exlo*p_lev(1,ipn)-exup*p_lev(k+1,ipn))/ & - ((rd+cp)*(p_lev(1,ipn)- p_lev(k+1,ipn))) - else - pkap=.5*(exlo+exup)/cp - end if - !pkap=(exlo*p_lev(k,ipn)-exup*p_lev(k+1,ipn))/ & - ! ((rd+cp)*(p_lev(k,ipn)- p_lev(k+1,ipn))) - znew=znew+(exlo-exup)*t_lyr(k,ipn)/pkap - end do - k=kgrnd(ipn) - if (abs(znew-zold(ipn)).gt.1.) & - print '(a,2i7,f11.1,f9.1)', & - 'height discrepancy at ipn,kgrnd =',ipn,k,zold(ipn),znew - end do -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!SMS$PARALLEL END - - return -end subroutine ss2ggtopo - - - - - diff --git a/src/fim/FIMsrc/prep/ssfc2icos/Makefile b/src/fim/FIMsrc/prep/ssfc2icos/Makefile deleted file mode 100644 index 517ca73..0000000 --- a/src/fim/FIMsrc/prep/ssfc2icos/Makefile +++ /dev/null @@ -1,41 +0,0 @@ -# ssfc2icos Makefile - -include ../../macros.make - -SHELL = /bin/sh - -DEPLIBS = $(LIBW3) $(LIBSP) $(LIBSIGIO) $(LIBSFCIO) $(LIBSLINT) $(LIBSYSSHARE) -FLAG1 = $(FFLAGS) -FLAGS = $(FLAG1) $(INCS) $(DEBUG_FLAGS) -INCS = -I ../incmod -I../../utils -I../../cntl -I../sfcio -LIBS = -L$(LIBDIR) -lw3_4 -lsp_4 -lsigio_4 -lsfcio_4 -lslint -LIBSFCIO = $(LIBDIR)/libsfcio_4.a -LIBSIGIO = $(LIBDIR)/libsigio_4.a -LIBSLINT = $(LIBDIR)/libslint.a -LIBSP = $(LIBDIR)/libsp_4.a -LIBSYSSHARE= $(LIBDIR)/libsysshare.a -LIBW3 = $(LIBDIR)/libw3_4.a -NEWNAME = $(BINDIR)/newname.exe -SSFC2ICOS = $(BINDIR)/ssfc2icos -UTILDIR = ../../utils - -.SUFFIXES: -.SUFFIXES: .F90 .o - -.F90.o: - $(FC) -c $(FLAGS) $< - -all: $(SSFC2ICOS) $(NEWNAME) - -$(NEWNAME): newname.F90 $(DEPLIBS) $(UTILDIR)/headers.o $(UTILDIR)/read_queue_namelist.o - $(FC) $(FLAGS) -o $(NEWNAME) $(INCS) -I../../cntl/incmod newname.F90 $(LIBS) $(LIBSYSSHARE) -lcntl $(UTILDIR)/headers.o $(UTILDIR)/read_queue_namelist.o $(UTILDIR)/module_initial_chem_namelists.o - -$(SSFC2ICOS): ssfc2icos.F90 $(DEPLIBS) $(UTILDIR)/headers.o $(UTILDIR)/read_queue_namelist.o read_mtnvar.o - $(FCserial) $(FLAGS) -o $(SSFC2ICOS) $(INCS) ssfc2icos.F90 $(LIBS) $(LIBSLINT) $(LIBSYSSHARE) $(UTILDIR)/headers.o $(UTILDIR)/read_queue_namelist.o $(UTILDIR)/module_initial_chem_namelists.o read_mtnvar.o - -read_mtnvar.o: read_mtnvar.F90 - $(FC) -c $(FLAGS) $(BYTE_SWAP_FLAG) read_mtnvar.F90 - -clean: - $(RM) *.o *.mod - diff --git a/src/fim/FIMsrc/prep/ssfc2icos/newname.F90 b/src/fim/FIMsrc/prep/ssfc2icos/newname.F90 deleted file mode 100644 index b22411a..0000000 --- a/src/fim/FIMsrc/prep/ssfc2icos/newname.F90 +++ /dev/null @@ -1,271 +0,0 @@ - program newname - use module_control ,only: nip,glvl,curve,control -!SMS$ignore begin - USE slint, ONLY: bilinear_init, bl_int -!SMS$ignore end - implicit none - integer, parameter :: imax=288,jmax=181,nspecies=25,imax2=360, & - klev=55,iklev=56 - - real(4) f1(imax*jmax),f2(imax*jmax),f3(imax*jmax),f4(imax*jmax) - real(4) tmp_h2o2(imax,jmax,klev),tmp_oh(imax,jmax,klev), & - tmp_no3(imax,jmax,klev),gocart_lev(iklev) - real(4) emissions(imax*jmax,nspecies),minv,maxv - real(4) p_gocart(iklev) - integer k,nv,nv_g,itime - - integer ipn,nvp,ios - real(4), allocatable :: ps_i(:) ! ps_i(nip) - real(4), allocatable :: oh(:,:) ! oh(klev,nip) - CHARACTER (LEN=7) :: ename(nspecies) - CHARACTER (LEN=20) :: dname - CHARACTER(len=80) :: grid_file1,grid_file2,g3 - DATA ename/'e_so2','e_no','e_ald','e_hcho','e_ora2','e_nh3','e_hc3','e_hc5','e_hc8', & - 'e_eth','e_co','e_ol2','e_olt','e_oli','e_tol','e_xyl','e_ket','e_csl', & - 'e_iso','e_pm_25','e_pm_10','e_oc','e_bc','e_dms','e_sulf'/ - -! read FIM namelists - call control(.true.) - -! allocate arrays - ALLOCATE(ps_i(nip)) - ALLOCATE(oh(klev,nip)) - -! set up interpolation from chem grid to icos - grid_file1 = "chemltln.dat" - grid_file2 = "glvl.dat" - write(6,*) 'newname: generating interpolation weights from ',TRIM(grid_file1),' to ',TRIM(grid_file2),' ...' - OPEN(66,file=grid_file2,status='old',form='unformatted',iostat=ios) - if (ios /= 0) then - write(6,*) 'ERROR: newname failed to open file ',TRIM(grid_file1) - stop - endif - call TestGlvlHeader (66, grid_file2,'newname',glvl) - call TestCurveHeader(66, grid_file2,'newname',curve) - CALL bilinear_init(grid_file1, imax*jmax, 66, nip) - close(66) -! -! first do dust erosion map -! - write(6,*) 'newname: interpolating erod_binary ...' - open(unit=21,file='erod_binary',form='unformatted',status='old',iostat=ios) - if (ios /= 0) then - write(6,*) 'ERROR: failed to open file erod_binary' - stop - endif - read(21)f1,f2,f3 - write(6,*)maxval(f1) - write(6,*)minval(f1) - - CALL bl_int (f1, ps_i) ! unit in pascal - g3 = "erod1.dat" - write(6,*)g3 - open(unit=23,file=g3,form='unformatted',iostat=ios) - if (ios /= 0) then - write(6,*) 'ERROR: failed to open file ',TRIM(g3) - stop - endif - write(23)ps_i - write(6,*)maxval(ps_i) - write(6,*)minval(ps_i) - - - write(6,*)maxval(f2) - write(6,*)minval(f2) - CALL bl_int (f2, ps_i) ! unit in pascal - g3 = "erod2.dat" - write(6,*)g3 - open(unit=24,file=g3,form='unformatted',iostat=ios) - if (ios /= 0) then - write(6,*) 'ERROR: failed to open file ',TRIM(g3) - stop - endif - write(24)ps_i - write(6,*)maxval(ps_i) - write(6,*)minval(ps_i) - - - write(6,*)maxval(f3) - write(6,*)minval(f3) - CALL bl_int (f3, ps_i) ! unit in pascal - g3 = "erod3.dat" - write(6,*)g3 - open(unit=25,file=g3,form='unformatted',iostat=ios) - if (ios /= 0) then - write(6,*) 'ERROR: failed to open file ',TRIM(g3) - stop - endif - write(25)ps_i - - close (21) - close (23) - close (24) - close (25) -! -! dms emissions -! - write(6,*) 'newname: interpolating dm0_binary ...' - open(unit=22,file='dm0_binary',form='unformatted',status='old',iostat=ios) - if (ios /= 0) then - write(6,*) 'ERROR: failed to open file dm0_binary' - stop - endif - read(22)f1 - close (22) - CALL bl_int (f1, ps_i) ! unit in pascal - g3 = "dm0.dat" - write(6,*)g3 - open(unit=26,file=g3,form='unformatted',iostat=ios) - if (ios /= 0) then - write(6,*) 'ERROR: failed to open file ',TRIM(g3) - stop - endif - write(26)ps_i - close (26) - write(6,*)'dms emissions ',maxval(f1) - write(6,*)minval(f1) - write(6,*)maxval(ps_i) - write(6,*)minval(ps_i) -! -! gocart background fields -! - write(6,*) 'newname: interpolating gocart_backgd_littlee ...' - open(unit=29,file='gocart_backgd_littlee',convert='little_endian',form='unformatted',status='old',iostat=ios) - if (ios /= 0) then - write(6,*) 'ERROR: failed to open file gocart_backgd_littlee' - stop - endif - write(6,*) 'opened file gocart_backgd ' - read(29)p_gocart - write(6,*)p_gocart - read(29)tmp_oh - write(6,*)'read oh' - read(29)tmp_h2o2 - write(6,*)'read h2o2' - read(29)tmp_no3 - write(6,*)'read no3' - close(29) -! -! loop over levels -! - do nv=1,klev - print *,'read level ',nv - minv=minval(tmp_oh(:,:,nv)) - maxv=maxval(tmp_oh(:,:,nv)) - print *,'minv,maxv = ',minv,maxv - CALL bl_int (tmp_oh(:,:,nv), ps_i) ! unit in pascal - write(6,*)'after interpolation ',minval(ps_i),maxval(ps_i) - oh(nv,:)=ps_i(:) - enddo -! -! end level loop, now write -! - g3 = "oh.dat" - open(unit=26,file=g3,form='unformatted',iostat=ios) - if (ios /= 0) then - write(6,*) 'ERROR: failed to open file ',TRIM(g3) - stop - endif - write(26)p_gocart - write(26)oh - close (26) -! -! next variable -! -! -! loop over levels -! - do nv=1,klev - print *,'read level ',nv - minv=minval(tmp_h2o2(:,:,nv)) - maxv=maxval(tmp_h2o2(:,:,nv)) - print *,'minv,maxv = ',minv,maxv - CALL bl_int (tmp_h2o2(:,:,nv), ps_i) ! unit in pascal - write(6,*)'after interpolation ',minval(ps_i),maxval(ps_i) - oh(nv,:)=ps_i(:) - enddo -! -! end level loop, now write -! - g3 = "h2o2.dat" - open(unit=26,file=g3,form='unformatted',iostat=ios) - if (ios /= 0) then - write(6,*) 'ERROR: failed to open file ',TRIM(g3) - stop - endif - write(26)p_gocart - write(26)oh - close (26) -! -! next variable -! -! -! loop over levels -! - do nv=1,klev - print *,'read level ',nv - minv=minval(tmp_no3(:,:,nv)) - maxv=maxval(tmp_no3(:,:,nv)) - print *,'minv,maxv = ',minv,maxv - CALL bl_int (tmp_no3(:,:,nv), ps_i) ! unit in pascal - write(6,*)'after interpolation ',minval(ps_i),maxval(ps_i) - oh(nv,:)=ps_i(:) - enddo -! -! end level loop, now write -! - g3 = "no3.dat" - open(unit=26,file=g3,form='unformatted',iostat=ios) - if (ios /= 0) then - write(6,*) 'ERROR: failed to open file ',TRIM(g3) - stop - endif - write(26)p_gocart - write(26)oh - close (26) -! -! anhropogenic emissions -! - write(6,*) 'newname: interpolating anthro_binary ...' - open(unit=29,file='anthro_binary',convert='big_endian',form='unformatted',status='old',iostat=ios) - if (ios /= 0) then - write(6,*) 'ERROR: failed to open file anthro_binary' - stop - endif - write(6,*) 'opened file anthro' - read(29)nv_g - print *,nv_g - read(29)dname - print *,dname - read(29)itime - print *,itime - do nv=1,nspecies - read(29)f4 !emissions - minv=minval(f4) - maxv=maxval(f4) - write(6,*)'read max,min = ',maxv,minv -! f1(1:imax*jmax)=emissions(1:imax*jmax,nv) - CALL bl_int (f4, ps_i) ! unit in pascal - g3 = TRIM(ename(nv)) // ".dat" - write(6,*)'species ',nv,'file = ',TRIM(g3),' emissions ',TRIM(ename(nv)) - open(unit=26,file=g3,form='unformatted',iostat=ios) - if (ios /= 0) then - write(6,*) 'ERROR: failed to open file ',TRIM(g3) - stop - endif - write(26)ps_i - close (26) -! write(6,*)ename(nv), ' emissions ',maxval(f1) -! write(6,*)minval(f1) - write(6,*)maxval(ps_i) - write(6,*)minval(ps_i) - enddo - close (29) -! -! horizontal interp of chemistry background for gocart -! - -! deallocate arrays - DEALLOCATE(ps_i) - - end program diff --git a/src/fim/FIMsrc/prep/ssfc2icos/read_mtnvar.F90 b/src/fim/FIMsrc/prep/ssfc2icos/read_mtnvar.F90 deleted file mode 100644 index 9451f64..0000000 --- a/src/fim/FIMsrc/prep/ssfc2icos/read_mtnvar.F90 +++ /dev/null @@ -1,17 +0,0 @@ -subroutine read_mtnvar(mdrag3d,imax,jmax,mvar,filename) - integer,intent(in)::imax,jmax,mvar - real,intent(out)::mdrag3d(imax,jmax,mvar) - character(len=*),intent(in)::filename - integer::i - open(21,file=trim(filename),form="unformatted",status='old',iostat=i) - if (i.ne.0) then - write (*,'(a,a,a)') 'ERROR in read_mtnvar: Could not open ',trim(filename),'.' - stop - endif - read(21,iostat=i) mdrag3d - if (i.ne.0) then - write (*,'(a)') 'ERROR in read_mtnvar: Could not read mdrag3d.' - stop - endif - close(21) -end subroutine read_mtnvar diff --git a/src/fim/FIMsrc/prep/ssfc2icos/ssfc2icos.F90 b/src/fim/FIMsrc/prep/ssfc2icos/ssfc2icos.F90 deleted file mode 100644 index c6409cd..0000000 --- a/src/fim/FIMsrc/prep/ssfc2icos/ssfc2icos.F90 +++ /dev/null @@ -1,405 +0,0 @@ -!********************************************************************* -! sfc2gg -! sfc-to-global program for fim global model -! - J-W Bao, Jin Lee, Ning Wang 2007 -! - initial version -! - Stan Benjamin May 2008 -! - correction to change to nearest-neighbor interpolation -! for land-surface 2-d variables instead of -! previous bilinear-interpolation, which had caused -! many land points to be erroneously set as water points -! - Ning Wang Aug 2008 -! - Replaced a call to subroutine bilinear_init() with -! a call to nn_init(), to work with the new version of -! slint library. -! - Ning Wang -! - Replaced computation of nip with a more general code. -!********************************************************************* - -program sfc2gg - use sfcio_module - USE read_queue_namelist,only: ReturnGLVL, ReturnNIP - implicit none - - integer(sfcio_intkind),parameter:: lusfc=11,luggg=51,luctl=52 - integer(sfcio_intkind) :: irets - integer :: iret,n,nip - CHARACTER(len=9 ) :: jdate - CHARACTER(len=2 ) :: hh - CHARACTER(len=80) :: sfcanlFile - type(sfcio_head),allocatable :: head(:) - type(sfcio_data) :: data - - ! Grid spec variables - integer :: glvl ! The grid level - integer :: curve,NumCacheBLocksPerPE - CHARACTER(len=12) :: yyyymmddhhmm - logical :: alt_topo=.false. - character(len=80) :: mtnvar_file='NO_SUCH_FILE' - character(len=80) :: gfsltln_file='NO_SUCH_FILE' - character(len=80) :: aerosol_file='NO_SUCH_FILE' - character(len=80) :: co2_2008_file='NO_SUCH_FILE' - character(len=80) :: co2_glb_file='NO_SUCH_FILE' - - ! Define and read in the name list - NAMELIST /PREPnamelist/curve,NumCacheBlocksPerPE,alt_topo,gfsltln_file,mtnvar_file & - ,aerosol_file,co2_2008_file,co2_glb_file - NAMELIST /TIMEnamelist/yyyymmddhhmm - - print *,'entering sfc2gg ...' - - OPEN(10, file="FIMnamelist") - READ(10, NML=PREPnamelist) - WRITE(*, NML=PREPnamelist) - READ(10, NML=TIMEnamelist) - WRITE(*, NML=TIMEnamelist) - close(10) - call GetJdate(yyyymmddhhmm,jdate) - hh=yyyymmddhhmm(9:10) - sfcanlFile = jdate // ".gfs.t" // hh // "z.sfcanl" - CALL ReturnGLVL(glvl) - CALL ReturnNIP(nip) - - open(luctl,file='sfcanl.ctl',status='replace',iostat=iret) - if (iret.ne.0) then - ! fail here with informative message? - endif - allocate(head(1)) - do n=1,1 - print *,'calling sfcio_srohdc ...' - call sfcio_srohdc(lusfc,sfcanlFile,head(n),data,irets) - if(head(n)%latb.ne.head(1)%latb.or.& - head(n)%lonb.ne.head(1)%lonb.or.& - head(n)%lsoil.ne.head(1)%lsoil.or.& - head(n)%ivs.ne.head(1)%ivs) then - call errmsg('sfc2gg: incompatible data in file sfcanl.ctl') -! call errexit(2) ! errexit doesn't call MPI_ABORT -> use STOP - STOP - endif - print *,'calling sfc2gg1 ...' - call sfc2gg1(luggg,head(n),data,glvl,nip,curve,mtnvar_file,gfsltln_file) - print *,'calling sfcio_axdata' - call sfcio_axdata(data,irets) - enddo - print *,'calling sfc2gg2 ...' - call sfc2gg2(luctl,1,head,'sfcanl.ieee') - - print *,'... exiting sfc2gg' - -contains -subroutine eusage - implicit none - call errmsg('Usage: sfc2gg sfcfile(s) gggfile ctlfile') -end subroutine eusage -end program sfc2gg - -subroutine sfc2gg1(luggg,head,data,glvl,nip,curve,mtnvar_file,gfsltln_file) - use sfcio_module -!SMS$ignore begin - USE slint, ONLY: nn_init, nn_int -!SMS$ignore end - implicit none -! integer, parameter :: imax=1152 -! integer, parameter :: jmax= 576 - - integer :: imax - integer :: jmax - integer ,intent(in) :: luggg - type(sfcio_head),intent(in) :: head - type(sfcio_data),intent(in) :: data - integer ,intent(in) :: glvl - integer ,intent(in) :: nip - integer ,intent(in) :: curve - - integer l - integer ipn -! - CHARACTER(len=80) :: grid_file2,mtnvar_file,gfsltln_file - real(4) icos2d(nip) - -real :: st3d(4,nip) ! soil temperature -real :: sm3d(4,nip) ! soil moisture -real :: slc3d(4,nip) ! liquid soil moisture -real :: ts2d(nip) ! skin temperature -real :: sheleg2d(nip) -real :: tg32d(nip) -real :: zorl2d(nip) -real :: cv2d(nip) -real :: cvb2d(nip) -real :: cvt2d(nip) -real :: alvsf2d(nip) -real :: alvwf2d(nip) -real :: alnsf2d(nip) -real :: alnwf2d(nip) -real :: slmsk2d(nip) -real :: vfrac2d(nip) -real :: canopy2d(nip) -real :: f10m2d(nip) -real :: t2m2d(nip) -real :: q2m2d(nip) -real :: vtype2d(nip) -real :: stype2d(nip) -real :: facsf2d(nip) -real :: facwf2d(nip) -real :: uustar2d(nip) -real :: ffmm2d(nip) -real :: ffhh2d(nip) -real :: work2d(nip) -real :: hice2d(nip) -real :: fice2d(nip) -real tprcp2d(nip) -real srflag2d(nip) -real snwdph2d(nip) -real slc2d(nip) -real shdmin2d(nip) -real shdmax2d(nip) -real slope2d(nip) -real snoalb2d(nip) - -integer :: mvar = 14 -real ,allocatable:: mdrag3d(:,:,:), mdrag(:,:) -integer idx - - grid_file2 = "glvl.dat" - OPEN(66,file=grid_file2,status='old',form='unformatted') - call TestGlvlHeader (66,grid_file2,'sfc2gg1',glvl) - call TestCurveHeader(66,grid_file2,'sfc2gg1',curve) - imax=head%lonb - jmax=head%latb - - CALL nn_init(gfsltln_file, imax*jmax, 66, nip) - close(66) - - allocate(mdrag3d(imax,jmax,mvar)) - allocate(mdrag(mvar,nip)) - call read_mtnvar(mdrag3d,imax,jmax,mvar,mtnvar_file) - do l=1,mvar - CALL nn_int (mdrag3d(:,:,l), icos2d) - do ipn=1,nip - mdrag(l,ipn)=icos2d(ipn) - end do - end do - deallocate(mdrag3d) -! - CALL nn_int (data%tsea, ts2d) -! - do l=1,head%lsoil - CALL nn_int (data%smc(:,:,l), icos2d) - do ipn=1,nip - sm3d(l,ipn)=icos2d(ipn) - end do - enddo - do l=1,head%lsoil - CALL nn_int (data%slc(:,:,l), icos2d) - do ipn=1,nip - slc3d(l,ipn)=icos2d(ipn) - end do - enddo -! do l=1,head%lsoil -! CALL nn_int (data%smc(:,:,l), icos2d) -! do ipn=1,nip -! slc3d(l,ipn)=icos2d(ipn) -! end do -! enddo - CALL nn_int (data%sheleg, sheleg2d) - do l=1,head%lsoil - CALL nn_int (data%stc(:,:,l), icos2d) - do ipn=1,nip - st3d(l,ipn)=icos2d(ipn) - end do - enddo - CALL nn_int (data%tg3, tg32d) - CALL nn_int (data%zorl, zorl2d) -! CALL bl_int (data%cv, cv2d) -! CALL bl_int (data%cvb, cvb2d) -! CALL bl_int (data%cvt, cvt2d) - cv2d=0. !zero out cv2d suggested by Bao - cvb2d=0. !zero out cv2d suggested by Bao - cvt2d=0. !zero out cv2d suggested by Bao - CALL nn_int (data%alvsf, alvsf2d) - CALL nn_int (data%alvwf, alvwf2d) - CALL nn_int (data%alnsf, alnsf2d) - CALL nn_int (data%alnwf, alnwf2d) - CALL nn_int (data%slmsk, slmsk2d) - CALL nn_int (data%vfrac, vfrac2d) - CALL nn_int (data%canopy,canopy2d) - CALL nn_int (data%f10m , f10m2d) - CALL nn_int (data%t2m , t2m2d) - CALL nn_int (data%q2m , q2m2d) - CALL nn_int (data%vtype, vtype2d) - CALL nn_int (data%stype, stype2d) - CALL nn_int (data%facsf, facsf2d) - CALL nn_int (data%facwf, facwf2d) - CALL nn_int (data%uustar,uustar2d) - CALL nn_int (data%ffmm , ffmm2d) - CALL nn_int (data%ffhh , ffhh2d) - CALL nn_int (data%hice , hice2d) - CALL nn_int (data%fice , fice2d) - CALL nn_int (data%tprcp, tprcp2d) - CALL nn_int (data%srflag, srflag2d) - CALL nn_int (data%snwdph, snwdph2d) - CALL nn_int (data%slc, slc2d) - CALL nn_int (data%shdmin, shdmin2d) - CALL nn_int (data%shdmax, shdmax2d) - CALL nn_int (data%slope, slope2d) - CALL nn_int (data%snoalb, snoalb2d) -! -! --- open output file - open (10,file="gfsfc.dat",form='unformatted') - call WriteGlvlHeader (10,glvl ) - call WriteCurveHeader(10,curve) - do idx = 1,SIZE(st3d,1) - do ipn=1,nip - work2d(ipn) = st3d(idx,ipn) - enddo - write(10) work2d - enddo - do idx = 1,SIZE(sm3d,1) - do ipn=1,nip - work2d(ipn) = sm3d(idx,ipn) - enddo - write(10) work2d - enddo - do idx = 1,SIZE(slc3d,1) - do ipn=1,nip - work2d(ipn) = slc3d(idx,ipn) - enddo - write(10) work2d - enddo - write(10) ts2d - write(10) sheleg2d - write(10) tg32d - write(10) zorl2d - write(10) cv2d - write(10) cvb2d - write(10) cvt2d - write(10) alvsf2d - write(10) alvwf2d - write(10) alnsf2d - write(10) alnwf2d - write(10) slmsk2d - write(10) vfrac2d - write(10) canopy2d - write(10) f10m2d - write(10) t2m2d - write(10) q2m2d - write(10) vtype2d - write(10) stype2d - write(10) facsf2d - write(10) facwf2d - write(10) uustar2d - write(10) ffmm2d - write(10) ffhh2d - write(10) hice2d - write(10) fice2d - write(10) tprcp2d - write(10) srflag2d - write(10) snwdph2d - write(10) slc2d - write(10) shdmin2d - write(10) shdmax2d - write(10) slope2d - write(10) snoalb2d - do idx = 1,SIZE(mdrag,1) - do ipn=1,nip - work2d(ipn) = mdrag(idx,ipn) - enddo - write(10) work2d - enddo - close(10) -! -end subroutine sfc2gg1 - -subroutine sfc2gg2(luctl,nsfc,head,cfggg) - use sfcio_module - implicit none - integer,intent(in):: luctl,nsfc - type(sfcio_head),intent(in):: head(nsfc) - character*(*) cfggg - real(4),allocatable:: slat(:),wlat(:) - integer idat(8),jdat(8),jhr - real(4) rinc(5),rincin(5) - integer idatin(8) - character*10 cdat(8) -! call w3movdat((/0.,head(1)%fhour,0.,0.,0./),& -! (/head(1)%idate(4),head(1)%idate(2),head(1)%idate(3),0,& -! head(1)%idate(1),0,0,0/),idat) - rincin = 0. - rincin(2) = head(1)%fhour - idatin = 0 - idatin(1) = head(1)%idate(4) - idatin(2) = head(1)%idate(2) - idatin(3) = head(1)%idate(3) - idatin(5) = head(1)%idate(1) - call w3movdat(rincin,idatin,idat) - call w3pradat(idat,cdat) - if(nsfc.gt.1) then -! call w3movdat((/0.,head(2)%fhour,0.,0.,0./),& -! (/head(2)%idate(4),head(2)%idate(2),head(2)%idate(3),0,& -! head(2)%idate(1),0,0,0/),jdat) - rincin(2) = head(2)%fhour - idatin(1) = head(2)%idate(4) - idatin(2) = head(2)%idate(2) - idatin(3) = head(2)%idate(3) - idatin(5) = head(2)%idate(1) - call w3movdat(rincin,idatin,idat) - call w3difdat(jdat,idat,2,rinc) - jhr=nint(rinc(2)) - else - jhr=12 - endif - if(cfggg(1:1).eq.'/') then - write(luctl,'("dset ",a)') cfggg - else - write(luctl,'("dset ^",a)') cfggg - endif - write(luctl,'("options yrev sequential")') - write(luctl,'("undef -9.99E+33")') - write(luctl,'("title sfc2gg")') - write(luctl,'("xdef",i6," linear",2f12.6)') head(1)%lonb,0.d0,360.d0/head(1)%lonb - allocate(slat(head(1)%latb),wlat(head(1)%latb)) - call splat(4,head(1)%latb,slat,wlat) - write(luctl,'("ydef",i6," levels")') head(1)%latb - write(luctl,'(5f12.6)') 180.d0/acos(-1.d0)*asin(dble(slat(head(1)%latb:1:-1))) - write(luctl,'("zdef",i6," levels")') head(1)%lsoil - write(luctl,'(5f12.6)') head(1)%zsoil - write(luctl,'("tdef",i6," linear ",i2.2,"Z",i2.2,a3,i4.4,1x,i6,"hr")')& - nsfc,idat(5),idat(3),cdat(2)(1:3),idat(1),jhr - write(luctl,'("vars",i6)') 35 - write(luctl,'("tsea ",i3," 99 surface temperature (K)")') 1 - write(luctl,'("smc ",i3," 99 soil volumetric water content ()")') head(1)%lsoil - write(luctl,'("sheleg ",i3," 99 snow depth (m)")') 1 - write(luctl,'("stc ",i3," 99 soil temperature (K)")') head(1)%lsoil - write(luctl,'("tg3 ",i3," 99 deep soil temperature (K)")') 1 - write(luctl,'("zorl ",i3," 99 roughness (cm)")') 1 - write(luctl,'("cv ",i3," 99 convective cloud cover ()")') 1 - write(luctl,'("cvb ",i3," 99 convective cloud bottom (kPa)")') 1 - write(luctl,'("cvt ",i3," 99 convective cloud top (kPa)")') 1 - write(luctl,'("alvsf ",i3," 99 albedo for visible scattered ()")') 1 - write(luctl,'("alvwf ",i3," 99 albedo for visible beam ()")') 1 - write(luctl,'("alnsf ",i3," 99 albedo for near-IR scattered ()")') 1 - write(luctl,'("alnwf ",i3," 99 albedo for near-IR beam ()")') 1 - write(luctl,'("slmsk ",i3," 99 sea-land-ice mask (0-sea, 1-land, 2-ice)")') 1 - write(luctl,'("vfrac ",i3," 99 vegetation fraction ()")') 1 - write(luctl,'("canopy ",i3," 99 canopy water (m)")') 1 - write(luctl,'("f10m ",i3," 99 10-meter wind speed over lowest model wind speed ()")') 1 - write(luctl,'("vtype ",i3," 99 vegetation type (integer 1-13)")') 1 - write(luctl,'("stype ",i3," 99 soil type (integer 1-9)")') 1 - write(luctl,'("facsf ",i3," 99 ???")') 1 - write(luctl,'("facwf ",i3," 99 ???")') 1 - write(luctl,'("uustar ",i3," 99 ???")') 1 - write(luctl,'("ffmm ",i3," 99 ???")') 1 - write(luctl,'("ffhh ",i3," 99 ???")') 1 - write(luctl,'("hice ",i3," 99 ???")') 1 - write(luctl,'("fice ",i3," 99 ???")') 1 - write(luctl,'("tprcp ",i3," 99 ???")') 1 - write(luctl,'("srflag ",i3," 99 ???")') 1 - write(luctl,'("snwdph ",i3," 99 ???")') 1 - write(luctl,'("slc ",i3," 99 ???")') head(1)%lsoil - write(luctl,'("shdmin ",i3," 99 ???")') 1 - write(luctl,'("shdmax ",i3," 99 ???")') 1 - write(luctl,'("slope ",i3," 99 ???")') 1 - write(luctl,'("snoalb ",i3," 99 ???")') 1 - write(luctl,'("orog ",i3," 99 orography (m)")') 1 - write(luctl,'("endvars")') -end subroutine sfc2gg2 diff --git a/src/fim/FIMsrc/sys_share/Makefile b/src/fim/FIMsrc/sys_share/Makefile deleted file mode 100644 index 32f4db3..0000000 --- a/src/fim/FIMsrc/sys_share/Makefile +++ /dev/null @@ -1,23 +0,0 @@ -# sys_share Makefile - -SHELL = /bin/sh - -include ../macros.make - -FLAGS = $(FFLAGS) $(FLUSH_DEF) -LIBSYSSHARE = $(LIBDIR)/libsysshare.a -OBJ = sys_share.o - -.SUFFIXES: -.SUFFIXES: .F90 .o - -.F90.o: - $(FC) -c $(FLAGS) $< - -all: $(LIBSYSSHARE) - -$(LIBSYSSHARE): $(LIBSYSSHARE)($(OBJ)) - $(RM) *.o - -clean: - $(RM) *.o *.mod diff --git a/src/fim/FIMsrc/sys_share/sys_share.F90 b/src/fim/FIMsrc/sys_share/sys_share.F90 deleted file mode 100644 index 2aa1067..0000000 --- a/src/fim/FIMsrc/sys_share/sys_share.F90 +++ /dev/null @@ -1,27 +0,0 @@ -! Substitutes for non-standard system intrinsic subroutines. -!JR Why is an empty module with a (also possibly empty) subroutine appended -!JR to the end needed? Mac complained about empty file, so added a stub. - -module module_sys_share -implicit none -end module module_sys_share - -! Substitute for non-standard flush() intrinsic subroutine. -! -! If your system does not support flush(), #define NO_FLUSH -! and build this proxy. - -! if flush() is not supported... -#ifdef NO_FLUSH -!SMS$IGNORE BEGIN - subroutine flush(lun) - implicit none - integer,intent(in)::lun -!TODO: this works on IBM, generalize if needed for other machines - call flush_(lun) - end subroutine flush -!SMS$IGNORE END -#endif - -subroutine stub_to_satisfy_linkers_that_cant_handle_empty_doto_files -end subroutine stub_to_satisfy_linkers_that_cant_handle_empty_doto_files diff --git a/src/fim/FIMsrc/tools/mkDepends b/src/fim/FIMsrc/tools/mkDepends deleted file mode 100755 index 9103316..0000000 --- a/src/fim/FIMsrc/tools/mkDepends +++ /dev/null @@ -1,357 +0,0 @@ -#!/usr/bin/env perl - -# Modifications to Brian Eaton's original to relax the restrictions on -# source file name matching module name and only one module per source -# file. See the new "-m" and "-d" options for details. -# -# One important limitation remains. If your module is named "procedure", -# this script will quietly ignore it. -# -# Tom Henderson -# Global Systems Division, NOAA/OAR -# Mar 2011 -# -# Brian Eaton's original comments follow: -# -# Generate dependencies in a form suitable for inclusion into a Makefile. -# The source filenames are provided in a file, one per line. Directories -# to be searched for the source files and for their dependencies are provided -# in another file, one per line. Output is written to STDOUT. -# -# For CPP type dependencies (lines beginning with #include) the dependency -# search is recursive. Only dependencies that are found in the specified -# directories are included. So, for example, the standard include file -# stdio.h would not be included as a dependency unless /usr/include were -# one of the specified directories to be searched. -# -# For Fortran module USE dependencies (lines beginning with a case -# insensitive "USE", possibly preceded by whitespace) the Fortran compiler -# must be able to access the .mod file associated with the .o file that -# contains the module. In order to correctly generate these dependencies -# two restrictions must be observed. -# 1) All modules must be contained in files that have the same base name as -# the module, in a case insensitive sense. This restriction implies that -# there can only be one module per file. -# 2) All modules that are to be contained in the dependency list must be -# contained in one of the source files in the list provided on the command -# line. -# The reason for the second restriction is that since the makefile doesn't -# contain rules to build .mod files the dependency takes the form of the .o -# file that contains the module. If a module is being used for which the -# source code is not available (e.g., a module from a library), then adding -# a .o dependency for that module is a mistake because make will attempt to -# build that .o file, and will fail if the source code is not available. -# -# Author: B. Eaton -# Climate Modelling Section, NCAR -# Feb 2001 - -use Getopt::Std; -use File::Basename; - -# Check for usage request. -@ARGV >= 2 or usage(); - -# Process command line. -my %opt = (); -getopts( "t:wmd:", \%opt ) or usage(); -my $filepath_arg = shift() or usage(); -my $srcfile_arg = shift() or usage(); -@ARGV == 0 or usage(); # Check that all args were processed. - -my $obj_dir; -if ( defined $opt{'t'} ) { $obj_dir = $opt{'t'}; } - -my $additional_obj = ""; -if ( defined $opt{'d'} ) { $additional_obj = $opt{'d'}; } - -open(FILEPATH, $filepath_arg) or die "Can't open $filepath_arg: $!\n"; -open(SRCFILES, $srcfile_arg) or die "Can't open $srcfile_arg: $!\n"; - -# Make list of paths to use when looking for files. -# Prepend "." so search starts in current directory. This default is for -# consistency with the way GNU Make searches for dependencies. -my @file_paths = ; -close(FILEPATH); -chomp @file_paths; -unshift(@file_paths,'.'); -foreach $dir (@file_paths) { # (could check that directories exist here) - $dir =~ s!/?\s*$!!; # remove / and any whitespace at end of directory name - ($dir) = glob $dir; # Expand tildes in path names. -} - -# Make list of files containing source code. -my @src = ; -close(SRCFILES); -chomp @src; - -my %module_files = (); - -#TODO: DRY this out -if ( defined $opt{'m'} ) { - # Attempt to parse each file for /^\s*module/ and extract module names - # for each file. - my ($f, $name, $path, $suffix, $mod); - my @suffixes = ('\.[fF]90', '\.[fF]' ); - foreach $f (@src) { - ($name, $path, $suffix) = fileparse($f, @suffixes); - open(FH, $f) or die "Can't open $f: $!\n"; - while ( ) { - # Search for module definitions. - if ( /^\s*MODULE\s+(\w+)/i ) { - ($mod = $1) =~ tr/a-z/A-Z/; - # skip "module procedure foo" statements - if ( $mod ne "PROCEDURE" ) { - if ( defined $module_files{$mod} ) { - die "Duplicate definitions of module $mod in $module_files{$mod} and $name: $!\n"; - } - $module_files{$mod} = $name; - } - } - } - close( FH ); - } -} else { - # For each file that may contain a Fortran module (*.[fF]90 *.[fF]) convert the - # file's basename to uppercase and use it as a hash key whose value is the file's - # basename. This allows fast identification of the files that contain modules. - # The only restriction is that the file's basename and the module name must match - # in a case insensitive way. - my ($f, $name, $path, $suffix, $mod); - my @suffixes = ('\.[fF]90', '\.[fF]' ); - foreach $f (@src) { - ($name, $path, $suffix) = fileparse($f, @suffixes); - ($mod = $name) =~ tr/a-z/A-Z/; - $module_files{$mod} = $name; - } -} - -#print STDERR "\%module_files\n"; -#while ( ($k,$v) = each %module_files ) { -# print STDERR "$k => $v\n"; -#} - -# Find module and include dependencies of the source files. -my ($file_path, $rmods, $rincs); -my %file_modules = (); -my %file_includes = (); -my @check_includes = (); -foreach $f ( @src ) { - - # Find the file in the seach path (@file_paths). - unless ($file_path = find_file($f)) { - if (defined $opt{'w'}) {print STDERR "$f not found\n";} - next; - } - - # Find the module and include dependencies. - ($rmods, $rincs) = find_dependencies( $file_path ); - - # Remove redundancies (a file can contain multiple procedures that have - # the same dependencies). - $file_modules{$f} = rm_duplicates($rmods); - $file_includes{$f} = rm_duplicates($rincs); - - # Make a list of all include files. - push @check_includes, @{$file_includes{$f}}; -} - -#print STDERR "\%file_modules\n"; -#while ( ($k,$v) = each %file_modules ) { -# print STDERR "$k => @$v\n"; -#} -#print STDERR "\%file_includes\n"; -#while ( ($k,$v) = each %file_includes ) { -# print STDERR "$k => @$v\n"; -#} -#print STDERR "\@check_includes\n"; -#print STDERR "@check_includes\n"; - -# Find include file dependencies. -my %include_depends = (); -while (@check_includes) { - $f = shift @check_includes; - if (defined($include_depends{$f})) { next; } - - # Mark files not in path so they can be removed from the dependency list. - unless ($file_path = find_file($f)) { - $include_depends{$f} = -1; - next; - } - - # Find include file dependencies. - ($rmods, $include_depends{$f}) = find_dependencies($file_path); - - # Add included include files to the back of the check_includes list so - # that their dependencies can be found. - push @check_includes, @{$include_depends{$f}}; - - # Add included modules to the include_depends list. - if ( @$rmods ) { push @{$include_depends{$f}}, @$rmods; } -} - -#print STDERR "\%include_depends\n"; -#while ( ($k,$v) = each %include_depends ) { -# print STDERR (ref $v ? "$k => @$v\n" : "$k => $v\n"); -#} - -# Remove include file dependencies that are not in the Filepath. -my $i, $ii; -foreach $f (keys %include_depends) { - - unless (ref $include_depends{$f}) { next; } - $rincs = $include_depends{$f}; - unless (@$rincs) { next; } - $ii = 0; - $num_incs = @$rincs; - for ($i = 0; $i < $num_incs; ++$i) { - if ($include_depends{$$rincs[$ii]} == -1) { - splice @$rincs, $ii, 1; - next; - } - ++$ii; - } -} - -# Substitute the include file dependencies into the %file_includes lists. -foreach $f (keys %file_includes) { - my @expand_incs = (); - - # Initialize the expanded %file_includes list. - my $i; - unless (@{$file_includes{$f}}) { next; } - foreach $i (@{$file_includes{$f}}) { - push @expand_incs, $i unless ($include_depends{$i} == -1); - } - unless (@expand_incs) { - $file_includes{$f} = []; - next; - } - - # Expand - for ($i = 0; $i <= $#expand_incs; ++$i) { - push @expand_incs, @{ $include_depends{$expand_incs[$i]} }; - } - - $file_includes{$f} = rm_duplicates(\@expand_incs); -} - -#print STDERR "expanded \%file_includes\n"; -#while ( ($k,$v) = each %file_includes ) { -# print STDERR "$k => @$v\n"; -#} - -# Print dependencies to STDOUT. -foreach $f (sort keys %file_modules) { - $f =~ /(.+)\./; - $target = "$1.o"; - if ( defined $opt{'t'} ) { $target = "$opt{'t'}/$1.o"; } - push(@{$file_modules{$f}},$additional_obj); - print "$target : $f @{noncircular(@{$file_modules{$f}},$target)} @{$file_includes{$f}}\n"; -} - -#-------------------------------------------------------------------------------------- - -sub noncircular -{ - # Return an array identical to that represented by the first argument, except - # for the absence of the element specified by the second argument. - my @a=(); - my $x=pop(@_); - foreach (@_) { unless ($_ eq $x) { push(@a,$_) } }; - return \@a; -} - -sub find_dependencies { - - # Find dependencies of input file. - # Use'd Fortran 90 modules are returned in \@mods. - # Files that are "#include"d by the cpp preprocessor are returned in \@incs. - - my( $file ) = @_; - my( @mods, @incs ); - - open(FH, $file) or die "Can't open $file: $!\n"; - - while ( ) { - # Search for "#include" and strip filename when found. - if ( /^#include\s+[<"](.*)[>"]/ ) { - push @incs, $1; - } - # Search for module dependencies. - elsif ( /^\s*USE\s+(\w+)/i ) { - # Return dependency in the form of a .o version of the file that contains - # the module. - ($module = $1) =~ tr/a-z/A-Z/; - if ( defined $module_files{$module} ) { - if ( defined $obj_dir ) { - push @mods, "$obj_dir/$module_files{$module}.o"; - } else { - push @mods, "$module_files{$module}.o"; - } - } - } - } - close( FH ); - return (\@mods, \@incs); -} - -#-------------------------------------------------------------------------------------- - -sub find_file { - -# Search for the specified file in the list of directories in the global -# array @file_paths. Return the first occurance found, or the null string if -# the file is not found. - - my($file) = @_; - my($dir, $fname); - - foreach $dir (@file_paths) { - $fname = "$dir/$file"; - if ( -f $fname ) { return $fname; } - } - return ''; # file not found -} - -#-------------------------------------------------------------------------------------- - -sub rm_duplicates { - -# Return a list with duplicates removed. - - my ($in) = @_; # input arrary reference - my @out = (); - my $i; - my %h = (); - foreach $i (@$in) { - $h{$i} = ''; - } - @out = keys %h; - return \@out; -} - -#-------------------------------------------------------------------------------------- - -sub usage { - ($ProgName = $0) =~ s!.*/!!; # name of program - die < Filepath - ls -1 *.F90 > Srcfiles - $(MKDEPENDS) -m Filepath Srcfiles > $@ - --include DEPENDENCIES - -clean: - $(RM) *.o *.mod DEPENDENCIES diff --git a/src/fim/FIMsrc/utils/extract_atcf.F90 b/src/fim/FIMsrc/utils/extract_atcf.F90 deleted file mode 100755 index 8c3d6d4..0000000 --- a/src/fim/FIMsrc/utils/extract_atcf.F90 +++ /dev/null @@ -1,352 +0,0 @@ -PROGRAM extract_atcf - -! called by plot_ellipses.pro, this should extract the desired GFS ensemble forecast -! information and write it to idl_fcst.dat, which idl will read back in. - -! NOTE: will need to change directory name of output file, possibly. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! HARDWIRED CHANGES TO MAKE !!!!! -! PARAMETER (nmembers = 4) -! DATA cmem /'01','02','03','04'/ -! CHARACTER*2, DIMENSION(4) :: cmem -! build_filename -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -PARAMETER (nmembers = 4) -PARAMETER (nleads = 29) ! 28 - -TYPE ens_fcst - CHARACTER(LEN=2) :: basin - INTEGER :: id - INTEGER :: ibasetime - INTEGER :: iflead - REAL :: ctr_lat(nmembers) - REAL :: ctr_lon(nmembers) - REAL :: centralpressure(nmembers) - REAL :: windspeed(nmembers) -END TYPE - -TYPE (ens_fcst), DIMENSION(nleads) :: hurricane_ens_fcst -TYPE (ens_fcst), DIMENSION(nmembers, nleads) :: GEFS - -CHARACTER*120 :: infile, outfile, outfile_ens -CHARACTER*2, DIMENSION(nmembers) :: cmem -CHARACTER*2, DIMENSION(nmembers) :: cmem_avail -CHARACTER*2 :: stormnumber - -CHARACTER*10 :: cyyyymmddhh_in -CHARACTER*2 :: cbasin_in -CHARACTER*2 :: cstormno_in -CHARACTER*80 :: rundir_in -CHARACTER*2 :: glvl_in -CHARACTER*3 :: fcst_len_in -CHARACTER*3 :: fcst_output_int_in -CHARACTER*4, DIMENSION(183) :: cmmdd -CHARACTER*4 :: cmmddt - -INTEGER :: fcst_len -INTEGER :: fcst_output_int -INTEGER :: ios -INTEGER :: imemktr -INTEGER :: nmember_out - -LOGICAL iex - -DATA cmem /'01','02','03','04'/ - -DATA cmmdd /& - '0601','0602','0603','0604','0605','0606','0607','0608','0609','0610',& - '0611','0612','0613','0614','0615','0616','0617','0618','0619','0620',& - '0621','0622','0623','0624','0625','0626','0627','0628','0629','0630',& - '0701','0702','0703','0704','0705','0706','0707','0708','0709','0710',& - '0711','0712','0713','0714','0715','0716','0717','0718','0719','0720',& - '0721','0722','0723','0724','0725','0726','0727','0728','0729','0730',& - '0731',& - '0801','0802','0803','0804','0805','0806','0807','0808','0809','0810',& - '0811','0812','0813','0814','0815','0816','0817','0818','0819','0820',& - '0821','0822','0823','0824','0825','0826','0827','0828','0829','0830',& - '0831',& - '0901','0902','0903','0904','0905','0906','0907','0908','0909','0910',& - '0911','0912','0913','0914','0915','0916','0917','0918','0919','0920',& - '0921','0922','0923','0924','0925','0926','0927','0928','0929','0930',& - '1001','1002','1003','1004','1005','1006','1007','1008','1009','1010',& - '1011','1012','1013','1014','1015','1016','1017','1018','1019','1020',& - '1021','1022','1023','1024','1025','1026','1027','1028','1029','1030',& - '1031',& - '1101','1102','1103','1104','1105','1106','1107','1108','1109','1110',& - '1111','1112','1113','1114','1115','1116','1117','1118','1119','1120',& - '1121','1122','1123','1124','1125','1126','1127','1128','1129','1130'/ - -! ---------------------------------------------------------------- -! input beginning and end date to process, and then find indices of -! dates to process in cmmdd array -! ---------------------------------------------------------------- - -CALL getarg (1, cyyyymmddhh_in) -CALL getarg (2, cstormno_in) -CALL getarg (3, cbasin_in) -CALL getarg (4, rundir_in) -CALL getarg (5, glvl_in) -CALL getarg (6, fcst_len_in) -CALL getarg (7, fcst_output_int_in) -read (fcst_len_in,*)fcst_len -read (fcst_output_int_in,*)fcst_output_int - -! ---------------------------------------------------------------- -! set up forecast structure, and write a warning to the output file -! that will be overwritten if the program later runs successfully -! to conclusion -! ---------------------------------------------------------------- - -! print *, 'in extract: fcst_len: ',fcst_len,' fcst_output_int: ',fcst_output_int -DO i = 1, nleads - CALL init_ens_fcst_structure (hurricane_ens_fcst(i)) -END DO - -! print *, 'in extract: before outfile ' -outfile = trim(rundir_in) // '/fimens/track/idl_fcst.dat' -! print *, 'in extract: outfile: ',outfile -OPEN (UNIT=1, FILE=outfile, STATUS='replace',FORM='formatted') -WRITE (1, 460) 666 ! this will indicate an error unless replaced later -CLOSE (1) - -! ---------------------------------------------------------------- -! read in the ensemble forecast data for this lead -! ---------------------------------------------------------------- -DO ilead = 0,fcst_len,fcst_output_int - !PRINT *,'calling get_ens_fcstinfo, lead = ',ilead,cyyyymmddhh_in - CALL get_ens_fcstinfo(ilead, cyyyymmddhh_in, cbasin_in, & - cstormno_in,rundir_in, glvl_in, fcst_len_in ,hurricane_ens_fcst,iex, & - imemktr) - !PRINT *,'returning from get_ens_fcstinfo' -END DO - -! -------------------------------------------------------------- -! write to file -! -------------------------------------------------------------- - -! outfile = '/lfs1/projects/rtfim/FIMYENS/FIMwfm/ensplots/idl_fcst.dat' -! PRINT *,'Program extract_atcf.x writing to ',TRIM(outfile) -OPEN (UNIT=1, FILE=outfile, STATUS='replace',FORM='formatted', IOSTAT=ios) -if (ios .ne. 0) then - print *, 'error: ',ios,' opening ',outfile -endif - -DO ilead = 0, fcst_len, fcst_output_int - ileadidx = 1 + ilead/fcst_output_int - WRITE (1, 460, iostat=ios) ileadidx - if (ios .ne. 0) then - print *, 'error: ',ios,' writing ',ileadidx - endif - 460 FORMAT(i3) - DO imem = 1, imemktr - WRITE (1,461,iostat=ios) imem, hurricane_ens_fcst(ileadidx)%iflead, & - hurricane_ens_fcst(ileadidx)%ctr_lat(imem),& - hurricane_ens_fcst(ileadidx)%ctr_lon(imem),& - hurricane_ens_fcst(ileadidx)%centralpressure(imem),& - hurricane_ens_fcst(ileadidx)%windspeed(imem) - 461 FORMAT (i2,1x,i3,1x,4(f8.2,1x)) - if (ios .ne. 0) then - print *, 'error: ',ios,' writing values' - endif -! print *, 'writing to :',trim(outfile),' ',ileadidx,' imem: ',imem, hurricane_ens_fcst(ileadidx)%iflead, & -! hurricane_ens_fcst(ileadidx)%ctr_lat(imem),& -! hurricane_ens_fcst(ileadidx)%ctr_lon(imem),& -! hurricane_ens_fcst(ileadidx)%centralpressure(imem),& -! hurricane_ens_fcst(ileadidx)%windspeed(imem) - 462 FORMAT (i2,1x,i2,1x,i3,1x,4(f8.2,1x)) - END DO -END DO - -! PRINT *,'end program extract_atcf.x' -! PRINT *,'BEFORE END OF PROGRAM - IMEMKTR: ',imemktr - - WRITE (*, '(i2)') imemktr - ! PRINT (*, '(i2)') imemktr - -CONTAINS - -! =================================================================== - -SUBROUTINE get_ens_fcstinfo(ilead_in, cyyyymmddhh_in, cbasin_in, & - cstormno_in, rundir_in, glvl_in, fcst_len_in, hurricane_ens_fcst, iex, & - imemktr) - -! -------------------------------------------------------------------- -! read ATCF hurricane ens forecast files. -! the chosen lead in hours (ilead). Return the forecast information -! for all in the storms that have been tracked for this lead time. -! -------------------------------------------------------------------- - -INTEGER, INTENT(IN) :: ilead_in ! forecast lead, h -CHARACTER*10, INTENT(IN) :: cyyyymmddhh_in -CHARACTER*2, INTENT(IN) :: cbasin_in -CHARACTER*2, INTENT(IN) :: cstormno_in -CHARACTER*80, INTENT(IN) :: rundir_in -CHARACTER*2, INTENT(IN) :: glvl_in -CHARACTER*3, INTENT(IN) :: fcst_len_in - -TYPE (ens_fcst), INTENT(OUT), DIMENSION(29) :: hurricane_ens_fcst -LOGICAL, INTENT(OUT) :: iex ! did the forecast files exist? - -CHARACTER*120 :: infile -CHARACTER*112 cline -CHARACTER*2 cbasin -CHARACTER*2 cstormno -CHARACTER*2, DIMENSION(4) :: cmem -CHARACTER*2, DIMENSION(4) :: cmem_avail - -INTEGER imemktr, ileady - -DATA cmem /'01','02','03','04'/ - - -! --------------------------------------------------------------------- -! check to make sure that all ensemble forecast members were computed; -! if not all 10, don't make plot... -! --------------------------------------------------------------------- - -! PRINT *,' ------ ilead = ',ilead_in -iex = .TRUE. -imemktr = 0 -DO imem = 1,nmembers - CALL build_filename(cyyyymmddhh_in, cmem(imem), rundir_in, glvl_in, fcst_len_in, infile) - INQUIRE (file=infile,exist=iex) - ! PRINT *,TRIM(infile),' iex: ',iex - IF (iex) THEN - imemktr = imemktr + 1 - cmem_avail(imemktr) = cmem(imem) - ENDIF -END DO -! PRINT *,imemktr, ' member forecast files found' - -ileadidx = 1 + ilead/fcst_output_int -!print *,ileadidx,ilead,trim(infile) - -! IF (imemktr .eq. nmembers) THEN ! only process if all members available - - ifound = 0 - ! DO imem = 1, nmembers - DO imem = 1, imemktr - ! CALL build_filename(cyyyymmddhh_in, cmem(imem), infile) - CALL build_filename(cyyyymmddhh_in, cmem_avail(imem), rundir_in, glvl_in, fcst_len_in, infile) - ! PRINT *, '************* infile: ',TRIM(infile) - OPEN (UNIT=1, FILE=infile, STATUS='old', FORM='formatted') - DO - READ (1,'(a112)', END=2000) cline - ! PRINT *,'cline: ',cline - READ (cline(31:33), '(i3)', ERR=234) ileady - cstormno = cline(5:6) - READ (cline(5:6), '(i2)') id - cbasin = cline(1:2) - - ifoundtc = 0 - IF (cbasin .eq. cbasin_in .and. cstormno .eq. cstormno_in .and. & - ileady .eq. ilead_in) THEN - - ! -------------------------------------------------------- - ! This member is tracking the storm. Get the central pressure, - ! max wind speed, center's lat/lon for this member - ! -------------------------------------------------------- - - ifoundtc = 1 - READ (cline(36:38), '(i3)') ilat -! print *, " *******ifoundtc: ",ifoundtc, 'ilat: ',ilat - IF (ilat .ne. 0) THEN - IF (cline(39:39) .eq. 'N' .or. cline(39:39) .eq. 'n') THEN - hurricane_ens_fcst(ileadidx)%ctr_lat(imem) = REAL(ilat)/10. - ELSE - hurricane_ens_fcst(ileadidx)%ctr_lat(imem) = - REAL(ilat)/10. - END IF - - READ (cline(42:45), '(i4)') ilon - IF (cline(46:46) .eq. 'E' .or. cline(46:46) .eq. 'e') THEN - hurricane_ens_fcst(ileadidx)%ctr_lon(imem) = REAL(ilon)/10. - ELSE - hurricane_ens_fcst(ileadidx)%ctr_lon(imem) = 360. - REAL(ilon)/10. - END IF - - IF (cline(54:57) .NE. ' -99') THEN - READ (cline(54:57), '(i4)') imslp - hurricane_ens_fcst(ileadidx)%centralpressure(imem) = REAL(imslp) - ENDIF - - IF (cline(49:51) .NE. '***') THEN - READ (cline(49:51), '(i3)') iwindkt ! in knots - hurricane_ens_fcst(ileadidx)%windspeed(imem) = REAL(iwindkt)*.514444 - ENDIF - GOTO 2000 - END IF - END IF - 234 CONTINUE - END DO - 2000 CLOSE (1) -! print *, " mem: ",imem," *******windspeed: ",hurricane_ens_fcst(ileadidx)%windspeed(imem) - END DO ! imem = 1, 10 - - hurricane_ens_fcst (ileadidx)%basin = cline(1:2) - hurricane_ens_fcst (ileadidx)%id = idsv - READ (cline(9:18), '(i10)') ibasetime - hurricane_ens_fcst (ileadidx)%ibasetime = ibasetime - hurricane_ens_fcst (ileadidx)%iflead = ilead - -! ENDIF ! imemktr = 10 - -RETURN -END SUBROUTINE get_ens_fcstinfo - -! ====================================================================== - -! SUBROUTINE build_filename(cyyyymmddhh, cmem, infile) -SUBROUTINE build_filename(cyyyymmddhh, cmem, rundir_in, glvl_in, fcst_len_in, infile) - -CHARACTER*10, INTENT(IN) :: cyyyymmddhh -CHARACTER*2, INTENT(IN) :: cmem ! member number -CHARACTER*80, INTENT(IN) :: rundir_in -CHARACTER*2, INTENT(IN) :: glvl_in -CHARACTER*3, INTENT(IN) :: fcst_len_in -CHARACTER*120, INTENT(OUT) :: infile - -CHARACTER*90 :: cdir -LOGICAL iex - -!cdir = '/Users/thamill/hfip/2010/' -!cdir = '/lfs1/projects/fim/fiorino/w21/dat/tc/adeck/esrl/2010/gfsenkf/' - -! cdir = '/lfs1/projects/gfsenkf/gfsenkf_t574/' // cyyyymmddhh // & -! '/fimens/mem0' //cmem//'/fim_C/' -! infile = TRIM(cdir)//'track.'//cyyyymmddhh//'.FIM'//cmem - -cdir = TRIM(rundir_in) // '/tracker_0' // cmem // '/' // fcst_len_in -infile = TRIM(cdir)//'/track.'//cyyyymmddhh//'00.F'// TRIM(glvl_in) // '0' // cmem - -!print*,'in build_filename: reading ',infile -INQUIRE (file=infile,exist=iex) -!print*,'reading iex: ',iex - -RETURN -END SUBROUTINE build_filename - -! ============================================================= - -SUBROUTINE init_ens_fcst_structure(eforecast) -TYPE (ens_fcst), INTENT(OUT) :: eforecast - -eforecast%basin = 'ZZ' -eforecast%id = -999 - -eforecast%ibasetime = -999 -eforecast%iflead = -999 - -eforecast%ctr_lat(:) = -999.99 -eforecast%ctr_lon(:) = -999.99 -eforecast%centralpressure(:) = -999.99 -eforecast%windspeed(:) = -999.99 - -RETURN -END SUBROUTINE init_ens_fcst_structure - -! =============================================================== - -END PROGRAM extract_atcf - diff --git a/src/fim/FIMsrc/utils/get_num_cores.F90 b/src/fim/FIMsrc/utils/get_num_cores.F90 deleted file mode 100644 index 013b835..0000000 --- a/src/fim/FIMsrc/utils/get_num_cores.F90 +++ /dev/null @@ -1,125 +0,0 @@ -program get_num_cores - - use module_wtinfo,only:wtinfo - use read_queue_namelist,only:getnprocs - - implicit none - - integer :: cpn ! number of cores per node - integer :: leftover ! left over tasks for a mod() calculation - integer :: mwtpn ! max write tasks per node - integer :: nct ! number of compute tasks - integer :: num_nodes_wt ! number of nodes filled w/ write tasks - integer :: numcores_batch ! numcores_mpirun modified to fill all nodes - integer :: numcores_donothing ! number of cores which will be MPI do-nothing tasks - integer :: numcores_mpirun ! cores needed by mpirun cmd - integer :: nwt ! number of write tasks - integer :: tot_nodes ! number of nodes needed by batch environment - logical :: debugmsg_on ! write-task debug message control - - logical :: root_own_node ! whether root has a node to himself - logical :: abort_on_bad_task_distrib ! ignored in this program - logical :: compute_tasks_after_write_tasks ! whether there are compute tasks after write tasks - - call wtinfo(cpn,nwt,mwtpn,root_own_node,abort_on_bad_task_distrib,debugmsg_on) - call getnprocs (nct) - - if (mwtpn > cpn) then - write(6,*) 'get_num_cores: Max write tasks per node=', mwtpn, & - ' exceeds cores_per_node=', cpn - stop 999 - end if - -!JR TODO: FIX THIS! - - if (nct < cpn .and. .not. root_own_node) then - write(6,*) 'get_num_cores: root_own_node false and nct < cpn is not allowed.' - write(6,*) 'This is because core_setup_fim doesnt know the number of compute tasks a-priori.' - write(6,*) 'It could easily call GetNprocs to get the value, but that routine is INSANELY expensive because' - write(6,*) 'all MPI tasks open 2 files and read the namelists contained therein in order to get the value.' - stop 999 - end if - - numcores_donothing = 0 - -! Initialize numcores_mpirun to number of compute tasks, then add for root being -! on his own node, and write tasks - - compute_tasks_after_write_tasks = .false. - numcores_mpirun = nct - if (root_own_node) then - if (nwt > 0 .or. nct > 1) then ! fill rest of 1st node with idle tasks - numcores_mpirun = numcores_mpirun + cpn - 1 - numcores_donothing = numcores_donothing + cpn - 1 - end if - if (nct > 1) then - compute_tasks_after_write_tasks = .true. - end if - else - if (nct > cpn) then ! more than root node needed for compute tasks - compute_tasks_after_write_tasks = .true. - else if (nwt > 0) then ! fill rest of 1st node with idle tasks - numcores_mpirun = numcores_mpirun + (cpn - nct) - numcores_donothing = numcores_donothing + (cpn - nct) - end if - end if - -! Write tasks: first handle nodes filled with write tasks - - num_nodes_wt = nwt / mwtpn - numcores_mpirun = numcores_mpirun + (num_nodes_wt * cpn) - numcores_donothing = numcores_donothing + num_nodes_wt * (cpn - mwtpn) - -! Last node with write tasks may have less than mwtpn - - leftover = mod (nwt, mwtpn) - if (leftover > 0) then - if (compute_tasks_after_write_tasks) then - ! Allocate the full node since compute tasks start at next empty node - numcores_mpirun = numcores_mpirun + cpn - numcores_donothing = numcores_donothing + (cpn - leftover) - else - ! No compute tasks to follow: Just account for the remaining write tasks - numcores_mpirun = numcores_mpirun + leftover - num_nodes_wt = num_nodes_wt + 1 - end if - end if - -! Check to ensure numbers were calculated correctly - - if (nct + nwt + numcores_donothing /= numcores_mpirun) then - write(*,*) 'get_num_cores failure:', nct, nwt, numcores_donothing, numcores_mpirun - stop 999 - end if - - write (*,'(a,i0)') 'num_cores_mpirun:', numcores_mpirun - -! numcores_batch considers all nodes to be full. -! This is critical for jaguar* because the core count -! requested on the #PBS line must be a multiple of cpn - - numcores_batch = numcores_mpirun - leftover = mod (numcores_batch, cpn) - if (leftover /= 0) then - numcores_batch = numcores_batch + (cpn - leftover) - end if - write (*,'(a,i0)') 'num_cores_batch:', numcores_batch - - tot_nodes = numcores_batch / cpn - write (*,'(a,i0)') 'tot_nodes:', tot_nodes - write (*,'(a,i0)') 'num_nodes_wt:', num_nodes_wt - write (*,'(a,i0)') 'num_cores_donothing:', numcores_donothing - -! Print number of cores left over due to final allocated node being less than full - - write (*,'(a,i0)') 'num_cores_notattached:', numcores_batch - numcores_mpirun - -! root_own_node is needed in some of the scripts: print in a way that grep -! will be sure to find it - - if (root_own_node) then - write(*,'(a)')'root_own_node:TRUE' - else - write(*,'(a)')'root_own_node:FALSE' - end if -end program get_num_cores diff --git a/src/fim/FIMsrc/utils/headers.F90 b/src/fim/FIMsrc/utils/headers.F90 deleted file mode 100644 index b5f5ed2..0000000 --- a/src/fim/FIMsrc/utils/headers.F90 +++ /dev/null @@ -1,62 +0,0 @@ -!These are the four routines that write, and verify the headers in the *.dat file. -!The I/O in all four routines must match. - -subroutine WriteGlvlHeader(unit,glvl) -integer ,intent(IN ) :: unit -integer ,intent(IN ) :: glvl -character(16) :: header -write(header,"('glvl =',I2)") glvl -write(unit) header -return -end subroutine WriteGlvlHeader - -subroutine WriteCurveHeader(unit,curve) -integer ,intent(IN ) :: unit -integer ,intent(IN ) :: curve -character(16) :: header -write(header,"('curve =',I2)") curve -write(unit) header -return -end subroutine WriteCurveHeader - -subroutine TestGlvlHeader(unit,FileName,RoutineName,glvl) -integer ,intent(IN) :: unit -character(*),intent(IN) :: FileName -character(*),intent(IN) :: RoutineName -integer ,intent(IN) :: glvl -integer :: glvlHeader -character(16) :: header -character(80) :: FMT -integer :: ioerr -FMT ="('Error in ',a,' unit ',i0,' glvl=',i0,' does not match header glvl=',i0)" -read(unit, iostat=ioerr) header -if (ioerr /= 0) then - write(6,*) 'testglvlheader: bad attempt to read header info file=', trim(filename) - stop -end if -read(header,"(6x,I2)") glvlHeader -if(glvl /= glvlHeader) then - write(6,FMT) RoutineName,unit,glvl,glvlHeader -endif -end subroutine TestGlvlHeader - -subroutine TestCurveHeader(unit,FileName,RoutineName,curve) -integer ,intent(IN) :: unit -character(*),intent(IN) :: FileName -character(*),intent(IN) :: RoutineName -integer ,intent(IN) :: curve -integer :: curveHeader -character(16) :: header -character(80) :: FMT -integer :: ioerr -FMT ="('Error in ',a,' unit ',i0,' curve=',i0,' does not match header curve=',i0)" -read(unit, iostat=ioerr) header -if (ioerr /= 0) then - write(6,*) 'testcurveheader: bad attempt to read header info file=', trim(filename) - stop -end if -read(header,"(7x,I2)") curveHeader -if(curve /= curveHeader) then - write(6,FMT) RoutineName,unit,curve,curveHeader -endif -end subroutine TestCurveHeader diff --git a/src/fim/FIMsrc/utils/module_initial_chem_namelists.F90 b/src/fim/FIMsrc/utils/module_initial_chem_namelists.F90 deleted file mode 100644 index 78d79ea..0000000 --- a/src/fim/FIMsrc/utils/module_initial_chem_namelists.F90 +++ /dev/null @@ -1,3295 +0,0 @@ -MODULE module_initial_chem_namelists -! this includes part of state_struct.inc V3.1, all of module_state_description, all of -! namelist_defines2 and a small part (format was changed) of namelist_statements.inc -! The NUM_xxx decs (num_moist, num_chem, num_emis_ant,....to find the important ones search for ggnum) -! from state_description are commented for fim, -! since they have to be defined in module_control -! -! first from state_struct.inc -! GG: updated 11Mar09 to V3.1 -integer :: ktauc -integer :: last_chem_time_year -integer :: last_chem_time_month -integer :: last_chem_time_day -integer :: last_chem_time_hour -integer :: last_chem_time_minute -integer :: last_chem_time_second -integer :: emissframes -integer :: fireemissframes -integer :: stepave_count -integer :: stepbioe -integer :: stepphot -integer :: stepchem -integer :: stepfirepl -character*256 :: emi_inname -character*256 :: fireemi_inname -character*256 :: input_chem_inname -character*256 :: emi_outname -character*256 :: fireemi_outname -character*256 :: input_chem_outname -integer :: frames_per_emissfile -integer :: frames_per_fireemissfile -integer :: io_style_emissions -integer :: io_form_emissions -integer :: io_style_fireemissions -integer :: io_form_fireemissions -real :: bioemdt -real :: photdt -real :: chemdt -integer :: ne_area -integer :: kemit -integer :: nmegan -integer :: kfuture -integer :: errosion_dim -integer :: biomass_emiss_opt -integer :: chem_conv_tr -integer :: chem_opt -integer :: gaschem_onoff -integer :: aerchem_onoff -integer :: wetscav_onoff -integer :: cldchem_onoff -integer :: vertmix_onoff -integer :: chem_in_opt -integer :: phot_opt -integer :: drydep_opt -integer :: emiss_opt -integer :: dust_opt -integer :: dmsemis_opt -integer :: seas_opt -integer :: bio_emiss_opt -integer :: biomass_burn_opt -integer :: plumerisefire_frq -integer :: emiss_inpt_opt -integer :: gas_bc_opt -integer :: gas_ic_opt -integer :: aer_bc_opt -integer :: aer_ic_opt -logical :: have_bcs_chem -integer :: aer_ra_feedback -integer :: aer_op_opt -integer :: scalar_opt -! next is wrfphys -! -integer :: mp_physics -integer :: gsfcgce_hail -integer :: gsfcgce_2ice -integer :: progn -integer :: ra_lw_physics -integer :: ra_sw_physics -real :: radt -real :: naer -integer :: sf_sfclay_physics -integer :: sf_surface_physics -integer :: bl_pbl_physics -integer :: sf_urban_physics -real :: bldt -integer :: cu_physics -real :: cudt -real :: gsmdt -integer :: isfflx -integer :: ifsnow -integer :: icloud -real :: swrad_scat -integer :: surface_input_source -integer :: num_urban_layers -integer :: num_months -integer :: maxiens -integer :: maxens -integer :: maxens2 -integer :: maxens3 -integer :: ensdim -integer :: cugd_avedx -integer :: imomentum -integer :: clos_choice -integer :: num_land_cat -integer :: num_soil_cat -integer :: mp_zero_out -real :: mp_zero_out_thresh -real :: seaice_threshold -integer :: sst_update -integer :: sst_skin -integer :: tmn_update -logical :: usemonalb -logical :: rdmaxalb -logical :: rdlai2d -integer :: co2tf -integer :: ra_call_offset -real :: cam_abs_freq_s -integer :: levsiz -integer :: paerlev -integer :: cam_abs_dim1 -integer :: cam_abs_dim2 -integer :: lagday -logical :: cu_rad_feedback -integer :: pxlsm_smois_init -integer :: omlcall -real :: oml_hml0 -real :: oml_gamma -integer :: isftcflx -real :: shadlen -integer :: slope_rad -integer :: topo_shading -integer :: no_mp_heating -integer :: fractional_seaice -real :: bucket_mm -real :: bucket_j -integer :: grav_settling -! -! package definitions next: they are defined in module_state_description -! updated 10 Mar09 to V3.1 - ! package constants - -!STARTOFREGISTRYGENERATEDINCLUDE 'frame/module_state_description.F' -! -! WARNING This file is generated automatically by use_registry -! using the data base in the file named Registry. -! Do not edit. Your changes to this file will be lost. -! - ! package constants - INTEGER, PARAMETER :: prescribe_aerosol = 0 - INTEGER, PARAMETER :: radm2 = 1 - INTEGER, PARAMETER :: radm2sorg = 2 - INTEGER, PARAMETER :: cbmz = 5 - INTEGER, PARAMETER :: cbmz_bb = 6 - INTEGER, PARAMETER :: cbmz_mosaic_4bin = 7 - INTEGER, PARAMETER :: cbmz_mosaic_8bin = 8 - INTEGER, PARAMETER :: cbmz_mosaic_4bin_aq = 9 - INTEGER, PARAMETER :: cbmz_mosaic_8bin_aq = 10 - INTEGER, PARAMETER :: radm2sorg_aq = 11 - INTEGER, PARAMETER :: racmsorg_aq = 12 - INTEGER, PARAMETER :: chem_tracer = 13 - INTEGER, PARAMETER :: chem_trace2 = 14 - INTEGER, PARAMETER :: chem_trace_ens = 15 - INTEGER, PARAMETER :: chem_vash = 16 - INTEGER, PARAMETER :: radm2_kpp = 101 - INTEGER, PARAMETER :: racm_mim_kpp = 102 - INTEGER, PARAMETER :: racm_kpp = 103 - INTEGER, PARAMETER :: racmpm_kpp = 104 - INTEGER, PARAMETER :: racmsorg_kpp = 105 - INTEGER, PARAMETER :: radm2sorg_kpp = 106 - INTEGER, PARAMETER :: cbm4_kpp = 110 - INTEGER, PARAMETER :: nmhc9_kpp = 200 - INTEGER, PARAMETER :: gocart_simple = 300 - INTEGER, PARAMETER :: gocartracm_kpp = 301 - INTEGER, PARAMETER :: gocartradm2_kpp = 302 - INTEGER, PARAMETER :: gocartradm2 = 303 - INTEGER, PARAMETER :: gocartfim = 304 - INTEGER, PARAMETER :: eradm = 2 - INTEGER, PARAMETER :: eradmsorg = 3 - INTEGER, PARAMETER :: ecbmz_mosaic = 4 - INTEGER, PARAMETER :: ecptec = 5 - INTEGER, PARAMETER :: gocart_ecptec = 6 - INTEGER, PARAMETER :: vash = 7 - INTEGER, PARAMETER :: photmad = 1 - INTEGER, PARAMETER :: photfastj = 2 - INTEGER, PARAMETER :: ftuv = 3 - INTEGER, PARAMETER :: wesely = 1 - INTEGER, PARAMETER :: gunther1 = 1 - INTEGER, PARAMETER :: beis313 = 2 - INTEGER, PARAMETER :: megan2 = 3 - INTEGER, PARAMETER :: biomassb = 1 - INTEGER, PARAMETER :: dustgocart = 1 - INTEGER, PARAMETER :: seasgocart = 1 - INTEGER, PARAMETER :: dmsgocart = 1 - INTEGER, PARAMETER :: volume_approx = 1 - INTEGER, PARAMETER :: maxwell_approx = 2 - INTEGER, PARAMETER :: volume_exact = 3 - INTEGER, PARAMETER :: maxwell_exact = 4 - INTEGER, PARAMETER :: shell_exact = 5 - INTEGER, PARAMETER :: emiss_inpt_default = 1 - INTEGER, PARAMETER :: emiss_inpt_cptec = 3 - INTEGER, PARAMETER :: emiss_inpt_pnnl_cm = 101 - INTEGER, PARAMETER :: emiss_inpt_pnnl_rs = 102 - INTEGER, PARAMETER :: emiss_inpt_cb4 = 103 - INTEGER, PARAMETER :: gas_bc_default = 1 - INTEGER, PARAMETER :: gas_bc_pnnl = 101 - INTEGER, PARAMETER :: gas_bc_cbm4 = 102 - INTEGER, PARAMETER :: gas_ic_default = 1 - INTEGER, PARAMETER :: gas_ic_pnnl = 101 - INTEGER, PARAMETER :: gas_ic_cbm4 = 102 - INTEGER, PARAMETER :: aer_bc_default = 1 - INTEGER, PARAMETER :: aer_bc_pnnl = 101 - INTEGER, PARAMETER :: aer_ic_default = 1 - INTEGER, PARAMETER :: aer_ic_pnnl = 101 - INTEGER, PARAMETER :: scalar_me = 1 - INTEGER, PARAMETER :: scalar_sus = 2 - INTEGER, PARAMETER :: passiveqv = 0 - INTEGER, PARAMETER :: kesslerscheme = 1 - INTEGER, PARAMETER :: linscheme = 2 - INTEGER, PARAMETER :: wsm3scheme = 3 - INTEGER, PARAMETER :: wsm5scheme = 4 - INTEGER, PARAMETER :: etampnew = 5 - INTEGER, PARAMETER :: wsm6scheme = 6 - INTEGER, PARAMETER :: gsfcgcescheme = 7 - INTEGER, PARAMETER :: thompson = 8 - INTEGER, PARAMETER :: morr_two_moment = 10 - INTEGER, PARAMETER :: wdm5scheme = 14 - INTEGER, PARAMETER :: wdm6scheme = 16 - INTEGER, PARAMETER :: thompson07 = 98 - INTEGER, PARAMETER :: passiveqv_dfi = 0 - INTEGER, PARAMETER :: kesslerscheme_dfi = 1 - INTEGER, PARAMETER :: linscheme_dfi = 2 - INTEGER, PARAMETER :: wsm3scheme_dfi = 3 - INTEGER, PARAMETER :: wsm5scheme_dfi = 4 - INTEGER, PARAMETER :: etampnew_dfi = 5 - INTEGER, PARAMETER :: wsm6scheme_dfi = 6 - INTEGER, PARAMETER :: gsfcgcescheme_dfi = 7 - INTEGER, PARAMETER :: thompson_dfi = 8 - INTEGER, PARAMETER :: morr_two_moment_dfi = 10 - INTEGER, PARAMETER :: wdm5scheme_dfi = 14 - INTEGER, PARAMETER :: wdm6scheme_dfi = 16 - INTEGER, PARAMETER :: thompson07_dfi = 98 - INTEGER, PARAMETER :: noprogn = 0 - INTEGER, PARAMETER :: progndrop = 1 - INTEGER, PARAMETER :: rrtmscheme = 1 - INTEGER, PARAMETER :: camlwscheme = 3 - INTEGER, PARAMETER :: rrtmg_lwscheme = 4 - INTEGER, PARAMETER :: gfdllwscheme = 99 - INTEGER, PARAMETER :: heldsuarez = 31 - INTEGER, PARAMETER :: swradscheme = 1 - INTEGER, PARAMETER :: gsfcswscheme = 2 - INTEGER, PARAMETER :: camswscheme = 3 - INTEGER, PARAMETER :: rrtmg_swscheme = 4 - INTEGER, PARAMETER :: gfdlswscheme = 99 - INTEGER, PARAMETER :: sfclayscheme = 1 - INTEGER, PARAMETER :: myjsfcscheme = 2 - INTEGER, PARAMETER :: gfssfcscheme = 3 - INTEGER, PARAMETER :: qnsesfcscheme = 4 - INTEGER, PARAMETER :: mynnsfcscheme = 5 - INTEGER, PARAMETER :: pxsfcscheme = 7 - INTEGER, PARAMETER :: noahucmscheme = 1 - INTEGER, PARAMETER :: bepscheme = 2 - INTEGER, PARAMETER :: slabscheme = 1 - INTEGER, PARAMETER :: lsmscheme = 2 - INTEGER, PARAMETER :: ruclsmscheme = 3 - INTEGER, PARAMETER :: pxlsmscheme = 7 - INTEGER, PARAMETER :: ysuscheme = 1 - INTEGER, PARAMETER :: myjpblscheme = 2 - INTEGER, PARAMETER :: gfsscheme = 3 - INTEGER, PARAMETER :: qnsepblscheme = 4 - INTEGER, PARAMETER :: mynnpblscheme2 = 5 - INTEGER, PARAMETER :: mynnpblscheme3 = 6 - INTEGER, PARAMETER :: acmpblscheme = 7 - INTEGER, PARAMETER :: boulacscheme = 8 - INTEGER, PARAMETER :: mrfscheme = 99 - INTEGER, PARAMETER :: kfetascheme = 1 - INTEGER, PARAMETER :: bmjscheme = 2 - INTEGER, PARAMETER :: gdscheme = 3 - INTEGER, PARAMETER :: sasscheme = 4 - INTEGER, PARAMETER :: g3scheme = 5 - INTEGER, PARAMETER :: kfscheme = 99 - INTEGER, PARAMETER :: psufddagd = 1 - INTEGER, PARAMETER :: psusfddagd = 1 - INTEGER, PARAMETER :: spnudging = 2 - INTEGER, PARAMETER :: restofwrf = 0 - INTEGER, PARAMETER :: original = 0 - INTEGER, PARAMETER :: positivedef = 1 - INTEGER, PARAMETER :: monotonic = 2 - INTEGER, PARAMETER :: dfi_setup = 0 - INTEGER, PARAMETER :: dfi_bck = 1 - INTEGER, PARAMETER :: dfi_fwd = 2 - INTEGER, PARAMETER :: dfi_fst = 3 - INTEGER, PARAMETER :: dfi_nodfi = 0 - INTEGER, PARAMETER :: dfi_dfl = 1 - INTEGER, PARAMETER :: dfi_ddfi = 2 - INTEGER, PARAMETER :: dfi_tdfi = 3 - INTEGER, PARAMETER :: realonly = 1 - INTEGER, PARAMETER :: io_intio = 1 - INTEGER, PARAMETER :: io_netcdf = 2 - INTEGER, PARAMETER :: io_hdf = 3 - INTEGER, PARAMETER :: io_phdf5 = 4 - INTEGER, PARAMETER :: io_grib1 = 5 - INTEGER, PARAMETER :: io_mcel = 6 - INTEGER, PARAMETER :: io_esmf = 7 - INTEGER, PARAMETER :: io_yyy = 8 - INTEGER, PARAMETER :: io_zzz = 9 - INTEGER, PARAMETER :: io_grib2 = 10 - INTEGER, PARAMETER :: io_pnetcdf = 11 - INTEGER, PARAMETER :: fire_sfire = 2 - ! 4D array constants - INTEGER, PARAMETER :: PARAM_qv = 1 - INTEGER :: P_qv = 1 - LOGICAL :: F_qv = .FALSE. - INTEGER, PARAMETER :: PARAM_qc = 2 - INTEGER :: P_qc = 1 - LOGICAL :: F_qc = .FALSE. - INTEGER, PARAMETER :: PARAM_qr = 3 - INTEGER :: P_qr = 1 - LOGICAL :: F_qr = .FALSE. - INTEGER, PARAMETER :: PARAM_qi = 4 - INTEGER :: P_qi = 1 - LOGICAL :: F_qi = .FALSE. - INTEGER, PARAMETER :: PARAM_qs = 5 - INTEGER :: P_qs = 1 - LOGICAL :: F_qs = .FALSE. - INTEGER, PARAMETER :: PARAM_qg = 6 - INTEGER :: P_qg = 1 - LOGICAL :: F_qg = .FALSE. - INTEGER, PARAMETER :: PARAM_NUM_moist = 7 -!ggnum INTEGER :: NUM_moist = 1 - INTEGER, PARAMETER :: PARAM_dfi_qv = 1 - INTEGER :: P_dfi_qv = 1 - LOGICAL :: F_dfi_qv = .FALSE. - INTEGER, PARAMETER :: PARAM_dfi_qc = 2 - INTEGER :: P_dfi_qc = 1 - LOGICAL :: F_dfi_qc = .FALSE. - INTEGER, PARAMETER :: PARAM_dfi_qr = 3 - INTEGER :: P_dfi_qr = 1 - LOGICAL :: F_dfi_qr = .FALSE. - INTEGER, PARAMETER :: PARAM_dfi_qi = 4 - INTEGER :: P_dfi_qi = 1 - LOGICAL :: F_dfi_qi = .FALSE. - INTEGER, PARAMETER :: PARAM_dfi_qs = 5 - INTEGER :: P_dfi_qs = 1 - LOGICAL :: F_dfi_qs = .FALSE. - INTEGER, PARAMETER :: PARAM_dfi_qg = 6 - INTEGER :: P_dfi_qg = 1 - LOGICAL :: F_dfi_qg = .FALSE. - INTEGER, PARAMETER :: PARAM_NUM_dfi_moist = 7 - INTEGER :: NUM_dfi_moist = 1 - INTEGER, PARAMETER :: PARAM_e_iso = 1 - INTEGER :: P_e_iso = 1 - LOGICAL :: F_e_iso = .FALSE. - INTEGER, PARAMETER :: PARAM_e_so2 = 2 - INTEGER :: P_e_so2 = 1 - LOGICAL :: F_e_so2 = .FALSE. - INTEGER, PARAMETER :: PARAM_e_no = 3 - INTEGER :: P_e_no = 1 - LOGICAL :: F_e_no = .FALSE. - INTEGER, PARAMETER :: PARAM_e_co = 4 - INTEGER :: P_e_co = 1 - LOGICAL :: F_e_co = .FALSE. - INTEGER, PARAMETER :: PARAM_e_eth = 5 - INTEGER :: P_e_eth = 1 - LOGICAL :: F_e_eth = .FALSE. - INTEGER, PARAMETER :: PARAM_e_hc3 = 6 - INTEGER :: P_e_hc3 = 1 - LOGICAL :: F_e_hc3 = .FALSE. - INTEGER, PARAMETER :: PARAM_e_hc5 = 7 - INTEGER :: P_e_hc5 = 1 - LOGICAL :: F_e_hc5 = .FALSE. - INTEGER, PARAMETER :: PARAM_e_hc8 = 8 - INTEGER :: P_e_hc8 = 1 - LOGICAL :: F_e_hc8 = .FALSE. - INTEGER, PARAMETER :: PARAM_e_xyl = 9 - INTEGER :: P_e_xyl = 1 - LOGICAL :: F_e_xyl = .FALSE. - INTEGER, PARAMETER :: PARAM_e_ol2 = 10 - INTEGER :: P_e_ol2 = 1 - LOGICAL :: F_e_ol2 = .FALSE. - INTEGER, PARAMETER :: PARAM_e_olt = 11 - INTEGER :: P_e_olt = 1 - LOGICAL :: F_e_olt = .FALSE. - INTEGER, PARAMETER :: PARAM_e_oli = 12 - INTEGER :: P_e_oli = 1 - LOGICAL :: F_e_oli = .FALSE. - INTEGER, PARAMETER :: PARAM_e_tol = 13 - INTEGER :: P_e_tol = 1 - LOGICAL :: F_e_tol = .FALSE. - INTEGER, PARAMETER :: PARAM_e_csl = 14 - INTEGER :: P_e_csl = 1 - LOGICAL :: F_e_csl = .FALSE. - INTEGER, PARAMETER :: PARAM_e_hcho = 15 - INTEGER :: P_e_hcho = 1 - LOGICAL :: F_e_hcho = .FALSE. - INTEGER, PARAMETER :: PARAM_e_ald = 16 - INTEGER :: P_e_ald = 1 - LOGICAL :: F_e_ald = .FALSE. - INTEGER, PARAMETER :: PARAM_e_ket = 17 - INTEGER :: P_e_ket = 1 - LOGICAL :: F_e_ket = .FALSE. - INTEGER, PARAMETER :: PARAM_e_ora2 = 18 - INTEGER :: P_e_ora2 = 1 - LOGICAL :: F_e_ora2 = .FALSE. - INTEGER, PARAMETER :: PARAM_e_nh3 = 19 - INTEGER :: P_e_nh3 = 1 - LOGICAL :: F_e_nh3 = .FALSE. - INTEGER, PARAMETER :: PARAM_e_pm_25 = 20 - INTEGER :: P_e_pm_25 = 1 - LOGICAL :: F_e_pm_25 = .FALSE. - INTEGER, PARAMETER :: PARAM_e_pm_10 = 21 - INTEGER :: P_e_pm_10 = 1 - LOGICAL :: F_e_pm_10 = .FALSE. - INTEGER, PARAMETER :: PARAM_e_pm25i = 22 - INTEGER :: P_e_pm25i = 1 - LOGICAL :: F_e_pm25i = .FALSE. - INTEGER, PARAMETER :: PARAM_e_pm25j = 23 - INTEGER :: P_e_pm25j = 1 - LOGICAL :: F_e_pm25j = .FALSE. - INTEGER, PARAMETER :: PARAM_e_eci = 24 - INTEGER :: P_e_eci = 1 - LOGICAL :: F_e_eci = .FALSE. - INTEGER, PARAMETER :: PARAM_e_ecj = 25 - INTEGER :: P_e_ecj = 1 - LOGICAL :: F_e_ecj = .FALSE. - INTEGER, PARAMETER :: PARAM_e_orgi = 26 - INTEGER :: P_e_orgi = 1 - LOGICAL :: F_e_orgi = .FALSE. - INTEGER, PARAMETER :: PARAM_e_orgj = 27 - INTEGER :: P_e_orgj = 1 - LOGICAL :: F_e_orgj = .FALSE. - INTEGER, PARAMETER :: PARAM_e_so4i = 28 - INTEGER :: P_e_so4i = 1 - LOGICAL :: F_e_so4i = .FALSE. - INTEGER, PARAMETER :: PARAM_e_so4j = 29 - INTEGER :: P_e_so4j = 1 - LOGICAL :: F_e_so4j = .FALSE. - INTEGER, PARAMETER :: PARAM_e_no3i = 30 - INTEGER :: P_e_no3i = 1 - LOGICAL :: F_e_no3i = .FALSE. - INTEGER, PARAMETER :: PARAM_e_no3j = 31 - INTEGER :: P_e_no3j = 1 - LOGICAL :: F_e_no3j = .FALSE. - INTEGER, PARAMETER :: PARAM_e_no2 = 32 - INTEGER :: P_e_no2 = 1 - LOGICAL :: F_e_no2 = .FALSE. - INTEGER, PARAMETER :: PARAM_e_ch3oh = 33 - INTEGER :: P_e_ch3oh = 1 - LOGICAL :: F_e_ch3oh = .FALSE. - INTEGER, PARAMETER :: PARAM_e_c2h5oh = 34 - INTEGER :: P_e_c2h5oh = 1 - LOGICAL :: F_e_c2h5oh = .FALSE. - INTEGER, PARAMETER :: PARAM_e_so4c = 35 - INTEGER :: P_e_so4c = 1 - LOGICAL :: F_e_so4c = .FALSE. - INTEGER, PARAMETER :: PARAM_e_no3c = 36 - INTEGER :: P_e_no3c = 1 - LOGICAL :: F_e_no3c = .FALSE. - INTEGER, PARAMETER :: PARAM_e_orgc = 37 - INTEGER :: P_e_orgc = 1 - LOGICAL :: F_e_orgc = .FALSE. - INTEGER, PARAMETER :: PARAM_e_ecc = 38 - INTEGER :: P_e_ecc = 1 - LOGICAL :: F_e_ecc = .FALSE. - INTEGER, PARAMETER :: PARAM_e_bc = 39 - INTEGER :: P_e_bc = 1 - LOGICAL :: F_e_bc = .FALSE. - INTEGER, PARAMETER :: PARAM_e_oc = 40 - INTEGER :: P_e_oc = 1 - LOGICAL :: F_e_oc = .FALSE. - INTEGER, PARAMETER :: PARAM_e_sulf = 41 - INTEGER :: P_e_sulf = 1 - LOGICAL :: F_e_sulf = .FALSE. - INTEGER, PARAMETER :: PARAM_e_vash1 = 42 - INTEGER :: P_e_vash1 = 1 - LOGICAL :: F_e_vash1 = .FALSE. - INTEGER, PARAMETER :: PARAM_e_vash2 = 43 - INTEGER :: P_e_vash2 = 1 - LOGICAL :: F_e_vash2 = .FALSE. - INTEGER, PARAMETER :: PARAM_e_vash3 = 44 - INTEGER :: P_e_vash3 = 1 - LOGICAL :: F_e_vash3 = .FALSE. - INTEGER, PARAMETER :: PARAM_e_vash4 = 45 - INTEGER :: P_e_vash4 = 1 - LOGICAL :: F_e_vash4 = .FALSE. - INTEGER, PARAMETER :: PARAM_e_vash5 = 46 - INTEGER :: P_e_vash5 = 1 - LOGICAL :: F_e_vash5 = .FALSE. - INTEGER, PARAMETER :: PARAM_e_vash6 = 47 - INTEGER :: P_e_vash6 = 1 - LOGICAL :: F_e_vash6 = .FALSE. - INTEGER, PARAMETER :: PARAM_e_vash7 = 48 - INTEGER :: P_e_vash7 = 1 - LOGICAL :: F_e_vash7 = .FALSE. - INTEGER, PARAMETER :: PARAM_e_vash8 = 49 - INTEGER :: P_e_vash8 = 1 - LOGICAL :: F_e_vash8 = .FALSE. - INTEGER, PARAMETER :: PARAM_e_vash9 = 50 - INTEGER :: P_e_vash9 = 1 - LOGICAL :: F_e_vash9 = .FALSE. - INTEGER, PARAMETER :: PARAM_e_vash10 = 51 - INTEGER :: P_e_vash10 = 1 - LOGICAL :: F_e_vash10 = .FALSE. - INTEGER, PARAMETER :: PARAM_e_tr1 = 52 - INTEGER :: P_e_tr1 = 1 - LOGICAL :: F_e_tr1 = .FALSE. - INTEGER, PARAMETER :: PARAM_e_tr2 = 53 - INTEGER :: P_e_tr2 = 1 - LOGICAL :: F_e_tr2 = .FALSE. - INTEGER, PARAMETER :: PARAM_NUM_emis_ant = 54 - -! INTEGER, PARAMETER :: PARAM_NUM_emis_ant = 52 -!ggnum INTEGER :: NUM_emis_ant = 1 - INTEGER, PARAMETER :: PARAM_edust1 = 1 - INTEGER :: P_edust1 = 1 - LOGICAL :: F_edust1 = .FALSE. - INTEGER, PARAMETER :: PARAM_edust2 = 2 - INTEGER :: P_edust2 = 1 - LOGICAL :: F_edust2 = .FALSE. - INTEGER, PARAMETER :: PARAM_edust3 = 3 - INTEGER :: P_edust3 = 1 - LOGICAL :: F_edust3 = .FALSE. - INTEGER, PARAMETER :: PARAM_edust4 = 4 - INTEGER :: P_edust4 = 1 - LOGICAL :: F_edust4 = .FALSE. - INTEGER, PARAMETER :: PARAM_edust5 = 5 - INTEGER :: P_edust5 = 1 - LOGICAL :: F_edust5 = .FALSE. - INTEGER, PARAMETER :: PARAM_NUM_emis_dust = 6 -!ggnum INTEGER :: NUM_emis_dust = 1 - INTEGER, PARAMETER :: PARAM_eseas1 = 1 - INTEGER :: P_eseas1 = 1 - LOGICAL :: F_eseas1 = .FALSE. - INTEGER, PARAMETER :: PARAM_eseas2 = 2 - INTEGER :: P_eseas2 = 1 - LOGICAL :: F_eseas2 = .FALSE. - INTEGER, PARAMETER :: PARAM_eseas3 = 3 - INTEGER :: P_eseas3 = 1 - LOGICAL :: F_eseas3 = .FALSE. - INTEGER, PARAMETER :: PARAM_eseas4 = 4 - INTEGER :: P_eseas4 = 1 - LOGICAL :: F_eseas4 = .FALSE. - INTEGER, PARAMETER :: PARAM_NUM_emis_seas = 5 - INTEGER, PARAMETER :: PARAM_extcof3 = 1 - INTEGER :: P_extcof3 = 1 - LOGICAL :: F_extcof3 = .FALSE. - INTEGER, PARAMETER :: PARAM_extcof55 = 2 - INTEGER :: P_extcof55 = 1 - LOGICAL :: F_extcof55 = .FALSE. - INTEGER, PARAMETER :: PARAM_extcof106 = 3 - INTEGER :: P_extcof106 = 1 - LOGICAL :: F_extcof106 = .FALSE. - INTEGER, PARAMETER :: PARAM_extcof3_5 = 4 - INTEGER :: P_extcof3_5 = 1 - LOGICAL :: F_extcof3_5 = .FALSE. - INTEGER, PARAMETER :: PARAM_extcof8_12 = 5 - INTEGER :: P_extcof8_12 = 1 - LOGICAL :: F_extcof8_12 = .FALSE. - INTEGER, PARAMETER :: PARAM_NUM_ext_coef = 6 -! INTEGER :: NUM_ext_coef = 1 - INTEGER, PARAMETER :: PARAM_bscof3 = 1 - INTEGER :: P_bscof3 = 1 - LOGICAL :: F_bscof3 = .FALSE. - INTEGER, PARAMETER :: PARAM_bscof55 = 2 - INTEGER :: P_bscof55 = 1 - LOGICAL :: F_bscof55 = .FALSE. - INTEGER, PARAMETER :: PARAM_bscof106 = 3 - INTEGER :: P_bscof106 = 1 - LOGICAL :: F_bscof106 = .FALSE. - INTEGER, PARAMETER :: PARAM_NUM_bscat_coef = 4 -! INTEGER :: NUM_bscat_coef = 1 - INTEGER, PARAMETER :: PARAM_asympar3 = 1 - INTEGER :: P_asympar3 = 1 - LOGICAL :: F_asympar3 = .FALSE. - INTEGER, PARAMETER :: PARAM_asympar55 = 2 - INTEGER :: P_asympar55 = 1 - LOGICAL :: F_asympar55 = .FALSE. - INTEGER, PARAMETER :: PARAM_asympar106 = 3 - INTEGER :: P_asympar106 = 1 - LOGICAL :: F_asympar106 = .FALSE. - INTEGER, PARAMETER :: PARAM_NUM_asym_par = 4 -! INTEGER :: NUM_asym_par = 1 - -!ggnum INTEGER :: NUM_emis_seas = 1 - INTEGER, PARAMETER :: PARAM_so2 = 1 - INTEGER :: P_so2 = 1 - LOGICAL :: F_so2 = .FALSE. - INTEGER, PARAMETER :: PARAM_sulf = 2 - INTEGER :: P_sulf = 1 - LOGICAL :: F_sulf = .FALSE. - INTEGER, PARAMETER :: PARAM_no2 = 3 - INTEGER :: P_no2 = 1 - LOGICAL :: F_no2 = .FALSE. - INTEGER, PARAMETER :: PARAM_no = 4 - INTEGER :: P_no = 1 - LOGICAL :: F_no = .FALSE. - INTEGER, PARAMETER :: PARAM_o3 = 5 - INTEGER :: P_o3 = 1 - LOGICAL :: F_o3 = .FALSE. - INTEGER, PARAMETER :: PARAM_hno3 = 6 - INTEGER :: P_hno3 = 1 - LOGICAL :: F_hno3 = .FALSE. - INTEGER, PARAMETER :: PARAM_h2o2 = 7 - INTEGER :: P_h2o2 = 1 - LOGICAL :: F_h2o2 = .FALSE. - INTEGER, PARAMETER :: PARAM_ald = 8 - INTEGER :: P_ald = 1 - LOGICAL :: F_ald = .FALSE. - INTEGER, PARAMETER :: PARAM_hcho = 9 - INTEGER :: P_hcho = 1 - LOGICAL :: F_hcho = .FALSE. - INTEGER, PARAMETER :: PARAM_op1 = 10 - INTEGER :: P_op1 = 1 - LOGICAL :: F_op1 = .FALSE. - INTEGER, PARAMETER :: PARAM_op2 = 11 - INTEGER :: P_op2 = 1 - LOGICAL :: F_op2 = .FALSE. - INTEGER, PARAMETER :: PARAM_paa = 12 - INTEGER :: P_paa = 1 - LOGICAL :: F_paa = .FALSE. - INTEGER, PARAMETER :: PARAM_ora1 = 13 - INTEGER :: P_ora1 = 1 - LOGICAL :: F_ora1 = .FALSE. - INTEGER, PARAMETER :: PARAM_ora2 = 14 - INTEGER :: P_ora2 = 1 - LOGICAL :: F_ora2 = .FALSE. - INTEGER, PARAMETER :: PARAM_nh3 = 15 - INTEGER :: P_nh3 = 1 - LOGICAL :: F_nh3 = .FALSE. - INTEGER, PARAMETER :: PARAM_n2o5 = 16 - INTEGER :: P_n2o5 = 1 - LOGICAL :: F_n2o5 = .FALSE. - INTEGER, PARAMETER :: PARAM_no3 = 17 - INTEGER :: P_no3 = 1 - LOGICAL :: F_no3 = .FALSE. - INTEGER, PARAMETER :: PARAM_pan = 18 - INTEGER :: P_pan = 1 - LOGICAL :: F_pan = .FALSE. - INTEGER, PARAMETER :: PARAM_hc3 = 19 - INTEGER :: P_hc3 = 1 - LOGICAL :: F_hc3 = .FALSE. - INTEGER, PARAMETER :: PARAM_hc5 = 20 - INTEGER :: P_hc5 = 1 - LOGICAL :: F_hc5 = .FALSE. - INTEGER, PARAMETER :: PARAM_hc8 = 21 - INTEGER :: P_hc8 = 1 - LOGICAL :: F_hc8 = .FALSE. - INTEGER, PARAMETER :: PARAM_eth = 22 - INTEGER :: P_eth = 1 - LOGICAL :: F_eth = .FALSE. - INTEGER, PARAMETER :: PARAM_co = 23 - INTEGER :: P_co = 1 - LOGICAL :: F_co = .FALSE. - INTEGER, PARAMETER :: PARAM_ol2 = 24 - INTEGER :: P_ol2 = 1 - LOGICAL :: F_ol2 = .FALSE. - INTEGER, PARAMETER :: PARAM_olt = 25 - INTEGER :: P_olt = 1 - LOGICAL :: F_olt = .FALSE. - INTEGER, PARAMETER :: PARAM_oli = 26 - INTEGER :: P_oli = 1 - LOGICAL :: F_oli = .FALSE. - INTEGER, PARAMETER :: PARAM_tol = 27 - INTEGER :: P_tol = 1 - LOGICAL :: F_tol = .FALSE. - INTEGER, PARAMETER :: PARAM_xyl = 28 - INTEGER :: P_xyl = 1 - LOGICAL :: F_xyl = .FALSE. - INTEGER, PARAMETER :: PARAM_aco3 = 29 - INTEGER :: P_aco3 = 1 - LOGICAL :: F_aco3 = .FALSE. - INTEGER, PARAMETER :: PARAM_tpan = 30 - INTEGER :: P_tpan = 1 - LOGICAL :: F_tpan = .FALSE. - INTEGER, PARAMETER :: PARAM_hono = 31 - INTEGER :: P_hono = 1 - LOGICAL :: F_hono = .FALSE. - INTEGER, PARAMETER :: PARAM_hno4 = 32 - INTEGER :: P_hno4 = 1 - LOGICAL :: F_hno4 = .FALSE. - INTEGER, PARAMETER :: PARAM_ket = 33 - INTEGER :: P_ket = 1 - LOGICAL :: F_ket = .FALSE. - INTEGER, PARAMETER :: PARAM_gly = 34 - INTEGER :: P_gly = 1 - LOGICAL :: F_gly = .FALSE. - INTEGER, PARAMETER :: PARAM_mgly = 35 - INTEGER :: P_mgly = 1 - LOGICAL :: F_mgly = .FALSE. - INTEGER, PARAMETER :: PARAM_dcb = 36 - INTEGER :: P_dcb = 1 - LOGICAL :: F_dcb = .FALSE. - INTEGER, PARAMETER :: PARAM_onit = 37 - INTEGER :: P_onit = 1 - LOGICAL :: F_onit = .FALSE. - INTEGER, PARAMETER :: PARAM_csl = 38 - INTEGER :: P_csl = 1 - LOGICAL :: F_csl = .FALSE. - INTEGER, PARAMETER :: PARAM_iso = 39 - INTEGER :: P_iso = 1 - LOGICAL :: F_iso = .FALSE. - INTEGER, PARAMETER :: PARAM_ho = 40 - INTEGER :: P_ho = 1 - LOGICAL :: F_ho = .FALSE. - INTEGER, PARAMETER :: PARAM_ho2 = 41 - INTEGER :: P_ho2 = 1 - LOGICAL :: F_ho2 = .FALSE. - INTEGER, PARAMETER :: PARAM_ete = 42 - INTEGER :: P_ete = 1 - LOGICAL :: F_ete = .FALSE. - INTEGER, PARAMETER :: PARAM_co2 = 43 - INTEGER :: P_co2 = 1 - LOGICAL :: F_co2 = .FALSE. - INTEGER, PARAMETER :: PARAM_ch4 = 44 - INTEGER :: P_ch4 = 1 - LOGICAL :: F_ch4 = .FALSE. - INTEGER, PARAMETER :: PARAM_udd = 45 - INTEGER :: P_udd = 1 - LOGICAL :: F_udd = .FALSE. - INTEGER, PARAMETER :: PARAM_hket = 46 - INTEGER :: P_hket = 1 - LOGICAL :: F_hket = .FALSE. - INTEGER, PARAMETER :: PARAM_api = 47 - INTEGER :: P_api = 1 - LOGICAL :: F_api = .FALSE. - INTEGER, PARAMETER :: PARAM_lim = 48 - INTEGER :: P_lim = 1 - LOGICAL :: F_lim = .FALSE. - INTEGER, PARAMETER :: PARAM_dien = 49 - INTEGER :: P_dien = 1 - LOGICAL :: F_dien = .FALSE. - INTEGER, PARAMETER :: PARAM_macr = 50 - INTEGER :: P_macr = 1 - LOGICAL :: F_macr = .FALSE. - INTEGER, PARAMETER :: PARAM_hcl = 51 - INTEGER :: P_hcl = 1 - LOGICAL :: F_hcl = .FALSE. - INTEGER, PARAMETER :: PARAM_ch3o2 = 52 - INTEGER :: P_ch3o2 = 1 - LOGICAL :: F_ch3o2 = .FALSE. - INTEGER, PARAMETER :: PARAM_ethp = 53 - INTEGER :: P_ethp = 1 - LOGICAL :: F_ethp = .FALSE. - INTEGER, PARAMETER :: PARAM_ch3oh = 54 - INTEGER :: P_ch3oh = 1 - LOGICAL :: F_ch3oh = .FALSE. - INTEGER, PARAMETER :: PARAM_c2h5oh = 55 - INTEGER :: P_c2h5oh = 1 - LOGICAL :: F_c2h5oh = .FALSE. - INTEGER, PARAMETER :: PARAM_par = 56 - INTEGER :: P_par = 1 - LOGICAL :: F_par = .FALSE. - INTEGER, PARAMETER :: PARAM_to2 = 57 - INTEGER :: P_to2 = 1 - LOGICAL :: F_to2 = .FALSE. - INTEGER, PARAMETER :: PARAM_cro = 58 - INTEGER :: P_cro = 1 - LOGICAL :: F_cro = .FALSE. - INTEGER, PARAMETER :: PARAM_open = 59 - INTEGER :: P_open = 1 - LOGICAL :: F_open = .FALSE. - INTEGER, PARAMETER :: PARAM_op3 = 60 - INTEGER :: P_op3 = 1 - LOGICAL :: F_op3 = .FALSE. - INTEGER, PARAMETER :: PARAM_c2o3 = 61 - INTEGER :: P_c2o3 = 1 - LOGICAL :: F_c2o3 = .FALSE. - INTEGER, PARAMETER :: PARAM_ro2 = 62 - INTEGER :: P_ro2 = 1 - LOGICAL :: F_ro2 = .FALSE. - INTEGER, PARAMETER :: PARAM_ano2 = 63 - INTEGER :: P_ano2 = 1 - LOGICAL :: F_ano2 = .FALSE. - INTEGER, PARAMETER :: PARAM_nap = 64 - INTEGER :: P_nap = 1 - LOGICAL :: F_nap = .FALSE. - INTEGER, PARAMETER :: PARAM_xo2 = 65 - INTEGER :: P_xo2 = 1 - LOGICAL :: F_xo2 = .FALSE. - INTEGER, PARAMETER :: PARAM_xpar = 66 - INTEGER :: P_xpar = 1 - LOGICAL :: F_xpar = .FALSE. - INTEGER, PARAMETER :: PARAM_isoprd = 67 - INTEGER :: P_isoprd = 1 - LOGICAL :: F_isoprd = .FALSE. - INTEGER, PARAMETER :: PARAM_isopp = 68 - INTEGER :: P_isopp = 1 - LOGICAL :: F_isopp = .FALSE. - INTEGER, PARAMETER :: PARAM_isopn = 69 - INTEGER :: P_isopn = 1 - LOGICAL :: F_isopn = .FALSE. - INTEGER, PARAMETER :: PARAM_isopo2 = 70 - INTEGER :: P_isopo2 = 1 - LOGICAL :: F_isopo2 = .FALSE. - INTEGER, PARAMETER :: PARAM_dms = 71 - INTEGER :: P_dms = 1 - LOGICAL :: F_dms = .FALSE. - INTEGER, PARAMETER :: PARAM_msa = 72 - INTEGER :: P_msa = 1 - LOGICAL :: F_msa = .FALSE. - INTEGER, PARAMETER :: PARAM_dmso = 73 - INTEGER :: P_dmso = 1 - LOGICAL :: F_dmso = .FALSE. - INTEGER, PARAMETER :: PARAM_dmso2 = 74 - INTEGER :: P_dmso2 = 1 - LOGICAL :: F_dmso2 = .FALSE. - INTEGER, PARAMETER :: PARAM_ch3so2h = 75 - INTEGER :: P_ch3so2h = 1 - LOGICAL :: F_ch3so2h = .FALSE. - INTEGER, PARAMETER :: PARAM_ch3sch2oo = 76 - INTEGER :: P_ch3sch2oo = 1 - LOGICAL :: F_ch3sch2oo = .FALSE. - INTEGER, PARAMETER :: PARAM_ch3so2 = 77 - INTEGER :: P_ch3so2 = 1 - LOGICAL :: F_ch3so2 = .FALSE. - INTEGER, PARAMETER :: PARAM_ch3so3 = 78 - INTEGER :: P_ch3so3 = 1 - LOGICAL :: F_ch3so3 = .FALSE. - INTEGER, PARAMETER :: PARAM_ch3so2oo = 79 - INTEGER :: P_ch3so2oo = 1 - LOGICAL :: F_ch3so2oo = .FALSE. - INTEGER, PARAMETER :: PARAM_ch3so2ch2oo = 80 - INTEGER :: P_ch3so2ch2oo = 1 - LOGICAL :: F_ch3so2ch2oo = .FALSE. - INTEGER, PARAMETER :: PARAM_mtf = 81 - INTEGER :: P_mtf = 1 - LOGICAL :: F_mtf = .FALSE. - INTEGER, PARAMETER :: PARAM_ald2 = 82 - INTEGER :: P_ald2 = 1 - LOGICAL :: F_ald2 = .FALSE. - INTEGER, PARAMETER :: PARAM_ror = 83 - INTEGER :: P_ror = 1 - LOGICAL :: F_ror = .FALSE. - INTEGER, PARAMETER :: PARAM_ole = 84 - INTEGER :: P_ole = 1 - LOGICAL :: F_ole = .FALSE. - INTEGER, PARAMETER :: PARAM_cres = 85 - INTEGER :: P_cres = 1 - LOGICAL :: F_cres = .FALSE. - INTEGER, PARAMETER :: PARAM_xo2n = 86 - INTEGER :: P_xo2n = 1 - LOGICAL :: F_xo2n = .FALSE. - INTEGER, PARAMETER :: PARAM_pna = 87 - INTEGER :: P_pna = 1 - LOGICAL :: F_pna = .FALSE. - INTEGER, PARAMETER :: PARAM_o = 88 - INTEGER :: P_o = 1 - LOGICAL :: F_o = .FALSE. - INTEGER, PARAMETER :: PARAM_o1d_cb4 = 89 - INTEGER :: P_o1d_cb4 = 1 - LOGICAL :: F_o1d_cb4 = .FALSE. - INTEGER, PARAMETER :: PARAM_tracer_1 = 90 - INTEGER :: P_tracer_1 = 1 - LOGICAL :: F_tracer_1 = .FALSE. - INTEGER, PARAMETER :: PARAM_tracer_2 = 91 - INTEGER :: P_tracer_2 = 1 - LOGICAL :: F_tracer_2 = .FALSE. - INTEGER, PARAMETER :: PARAM_tracer_3 = 92 - INTEGER :: P_tracer_3 = 1 - LOGICAL :: F_tracer_3 = .FALSE. - INTEGER, PARAMETER :: PARAM_tracer_4 = 93 - INTEGER :: P_tracer_4 = 1 - LOGICAL :: F_tracer_4 = .FALSE. - INTEGER, PARAMETER :: PARAM_tracer_5 = 94 - INTEGER :: P_tracer_5 = 1 - LOGICAL :: F_tracer_5 = .FALSE. - INTEGER, PARAMETER :: PARAM_tracer_6 = 95 - INTEGER :: P_tracer_6 = 1 - LOGICAL :: F_tracer_6 = .FALSE. - INTEGER, PARAMETER :: PARAM_tracer_7 = 96 - INTEGER :: P_tracer_7 = 1 - LOGICAL :: F_tracer_7 = .FALSE. - INTEGER, PARAMETER :: PARAM_tracer_8 = 97 - INTEGER :: P_tracer_8 = 1 - LOGICAL :: F_tracer_8 = .FALSE. - INTEGER, PARAMETER :: PARAM_tracer_9 = 98 - INTEGER :: P_tracer_9 = 1 - LOGICAL :: F_tracer_9 = .FALSE. - INTEGER, PARAMETER :: PARAM_tracer_10 = 99 - INTEGER :: P_tracer_10 = 1 - LOGICAL :: F_tracer_10 = .FALSE. - INTEGER, PARAMETER :: PARAM_tracer_11 = 100 - INTEGER :: P_tracer_11 = 1 - LOGICAL :: F_tracer_11 = .FALSE. - INTEGER, PARAMETER :: PARAM_tracer_12 = 101 - INTEGER :: P_tracer_12 = 1 - LOGICAL :: F_tracer_12 = .FALSE. - INTEGER, PARAMETER :: PARAM_tracer_13 = 102 - INTEGER :: P_tracer_13 = 1 - LOGICAL :: F_tracer_13 = .FALSE. - INTEGER, PARAMETER :: PARAM_tracer_14 = 103 - INTEGER :: P_tracer_14 = 1 - LOGICAL :: F_tracer_14 = .FALSE. - INTEGER, PARAMETER :: PARAM_tracer_15 = 104 - INTEGER :: P_tracer_15 = 1 - LOGICAL :: F_tracer_15 = .FALSE. - INTEGER, PARAMETER :: PARAM_tracer_16 = 105 - INTEGER :: P_tracer_16 = 1 - LOGICAL :: F_tracer_16 = .FALSE. - INTEGER, PARAMETER :: PARAM_tracer_17 = 106 - INTEGER :: P_tracer_17 = 1 - LOGICAL :: F_tracer_17 = .FALSE. - INTEGER, PARAMETER :: PARAM_tracer_18 = 107 - INTEGER :: P_tracer_18 = 1 - LOGICAL :: F_tracer_18 = .FALSE. - INTEGER, PARAMETER :: PARAM_tracer_19 = 108 - INTEGER :: P_tracer_19 = 1 - LOGICAL :: F_tracer_19 = .FALSE. - INTEGER, PARAMETER :: PARAM_tracer_20 = 109 - INTEGER :: P_tracer_20 = 1 - LOGICAL :: F_tracer_20 = .FALSE. - INTEGER, PARAMETER :: PARAM_tracer_ens = 110 - INTEGER :: P_tracer_ens = 1 - LOGICAL :: F_tracer_ens = .FALSE. - INTEGER, PARAMETER :: PARAM_vash_1 = 111 - INTEGER :: P_vash_1 = 1 - LOGICAL :: F_vash_1 = .FALSE. - INTEGER, PARAMETER :: PARAM_vash_2 = 112 - INTEGER :: P_vash_2 = 1 - LOGICAL :: F_vash_2 = .FALSE. - INTEGER, PARAMETER :: PARAM_vash_3 = 113 - INTEGER :: P_vash_3 = 1 - LOGICAL :: F_vash_3 = .FALSE. - INTEGER, PARAMETER :: PARAM_vash_4 = 114 - INTEGER :: P_vash_4 = 1 - LOGICAL :: F_vash_4 = .FALSE. - INTEGER, PARAMETER :: PARAM_vash_5 = 115 - INTEGER :: P_vash_5 = 1 - LOGICAL :: F_vash_5 = .FALSE. - INTEGER, PARAMETER :: PARAM_vash_6 = 116 - INTEGER :: P_vash_6 = 1 - LOGICAL :: F_vash_6 = .FALSE. - INTEGER, PARAMETER :: PARAM_vash_7 = 117 - INTEGER :: P_vash_7 = 1 - LOGICAL :: F_vash_7 = .FALSE. - INTEGER, PARAMETER :: PARAM_vash_8 = 118 - INTEGER :: P_vash_8 = 1 - LOGICAL :: F_vash_8 = .FALSE. - INTEGER, PARAMETER :: PARAM_vash_9 = 119 - INTEGER :: P_vash_9 = 1 - LOGICAL :: F_vash_9 = .FALSE. - INTEGER, PARAMETER :: PARAM_vash_10 = 120 - INTEGER :: P_vash_10 = 1 - LOGICAL :: F_vash_10 = .FALSE. - INTEGER, PARAMETER :: PARAM_pm_25 = 121 - INTEGER :: P_pm_25 = 1 - LOGICAL :: F_pm_25 = .FALSE. - INTEGER, PARAMETER :: PARAM_pm_10 = 122 - INTEGER :: P_pm_10 = 1 - LOGICAL :: F_pm_10 = .FALSE. - INTEGER, PARAMETER :: PARAM_so4aj = 123 - INTEGER :: P_so4aj = 1 - LOGICAL :: F_so4aj = .FALSE. - INTEGER, PARAMETER :: PARAM_so4ai = 124 - INTEGER :: P_so4ai = 1 - LOGICAL :: F_so4ai = .FALSE. - INTEGER, PARAMETER :: PARAM_nh4aj = 125 - INTEGER :: P_nh4aj = 1 - LOGICAL :: F_nh4aj = .FALSE. - INTEGER, PARAMETER :: PARAM_nh4ai = 126 - INTEGER :: P_nh4ai = 1 - LOGICAL :: F_nh4ai = .FALSE. - INTEGER, PARAMETER :: PARAM_no3aj = 127 - INTEGER :: P_no3aj = 1 - LOGICAL :: F_no3aj = .FALSE. - INTEGER, PARAMETER :: PARAM_no3ai = 128 - INTEGER :: P_no3ai = 1 - LOGICAL :: F_no3ai = .FALSE. - INTEGER, PARAMETER :: PARAM_naaj = 129 - INTEGER :: P_naaj = 1 - LOGICAL :: F_naaj = .FALSE. - INTEGER, PARAMETER :: PARAM_naai = 130 - INTEGER :: P_naai = 1 - LOGICAL :: F_naai = .FALSE. - INTEGER, PARAMETER :: PARAM_claj = 131 - INTEGER :: P_claj = 1 - LOGICAL :: F_claj = .FALSE. - INTEGER, PARAMETER :: PARAM_clai = 132 - INTEGER :: P_clai = 1 - LOGICAL :: F_clai = .FALSE. - INTEGER, PARAMETER :: PARAM_orgaro1j = 133 - INTEGER :: P_orgaro1j = 1 - LOGICAL :: F_orgaro1j = .FALSE. - INTEGER, PARAMETER :: PARAM_orgaro1i = 134 - INTEGER :: P_orgaro1i = 1 - LOGICAL :: F_orgaro1i = .FALSE. - INTEGER, PARAMETER :: PARAM_orgaro2j = 135 - INTEGER :: P_orgaro2j = 1 - LOGICAL :: F_orgaro2j = .FALSE. - INTEGER, PARAMETER :: PARAM_orgaro2i = 136 - INTEGER :: P_orgaro2i = 1 - LOGICAL :: F_orgaro2i = .FALSE. - INTEGER, PARAMETER :: PARAM_orgalk1j = 137 - INTEGER :: P_orgalk1j = 1 - LOGICAL :: F_orgalk1j = .FALSE. - INTEGER, PARAMETER :: PARAM_orgalk1i = 138 - INTEGER :: P_orgalk1i = 1 - LOGICAL :: F_orgalk1i = .FALSE. - INTEGER, PARAMETER :: PARAM_orgole1j = 139 - INTEGER :: P_orgole1j = 1 - LOGICAL :: F_orgole1j = .FALSE. - INTEGER, PARAMETER :: PARAM_orgole1i = 140 - INTEGER :: P_orgole1i = 1 - LOGICAL :: F_orgole1i = .FALSE. - INTEGER, PARAMETER :: PARAM_orgba1j = 141 - INTEGER :: P_orgba1j = 1 - LOGICAL :: F_orgba1j = .FALSE. - INTEGER, PARAMETER :: PARAM_orgba1i = 142 - INTEGER :: P_orgba1i = 1 - LOGICAL :: F_orgba1i = .FALSE. - INTEGER, PARAMETER :: PARAM_orgba2j = 143 - INTEGER :: P_orgba2j = 1 - LOGICAL :: F_orgba2j = .FALSE. - INTEGER, PARAMETER :: PARAM_orgba2i = 144 - INTEGER :: P_orgba2i = 1 - LOGICAL :: F_orgba2i = .FALSE. - INTEGER, PARAMETER :: PARAM_orgba3j = 145 - INTEGER :: P_orgba3j = 1 - LOGICAL :: F_orgba3j = .FALSE. - INTEGER, PARAMETER :: PARAM_orgba3i = 146 - INTEGER :: P_orgba3i = 1 - LOGICAL :: F_orgba3i = .FALSE. - INTEGER, PARAMETER :: PARAM_orgba4j = 147 - INTEGER :: P_orgba4j = 1 - LOGICAL :: F_orgba4j = .FALSE. - INTEGER, PARAMETER :: PARAM_orgba4i = 148 - INTEGER :: P_orgba4i = 1 - LOGICAL :: F_orgba4i = .FALSE. - INTEGER, PARAMETER :: PARAM_orgpaj = 149 - INTEGER :: P_orgpaj = 1 - LOGICAL :: F_orgpaj = .FALSE. - INTEGER, PARAMETER :: PARAM_orgpai = 150 - INTEGER :: P_orgpai = 1 - LOGICAL :: F_orgpai = .FALSE. - INTEGER, PARAMETER :: PARAM_ecj = 151 - INTEGER :: P_ecj = 1 - LOGICAL :: F_ecj = .FALSE. - INTEGER, PARAMETER :: PARAM_eci = 152 - INTEGER :: P_eci = 1 - LOGICAL :: F_eci = .FALSE. - INTEGER, PARAMETER :: PARAM_p25j = 153 - INTEGER :: P_p25j = 1 - LOGICAL :: F_p25j = .FALSE. - INTEGER, PARAMETER :: PARAM_p25i = 154 - INTEGER :: P_p25i = 1 - LOGICAL :: F_p25i = .FALSE. - INTEGER, PARAMETER :: PARAM_antha = 155 - INTEGER :: P_antha = 1 - LOGICAL :: F_antha = .FALSE. - INTEGER, PARAMETER :: PARAM_seas = 156 - INTEGER :: P_seas = 1 - LOGICAL :: F_seas = .FALSE. - INTEGER, PARAMETER :: PARAM_soila = 157 - INTEGER :: P_soila = 1 - LOGICAL :: F_soila = .FALSE. - INTEGER, PARAMETER :: PARAM_nu0 = 158 - INTEGER :: P_nu0 = 1 - LOGICAL :: F_nu0 = .FALSE. - INTEGER, PARAMETER :: PARAM_ac0 = 159 - INTEGER :: P_ac0 = 1 - LOGICAL :: F_ac0 = .FALSE. - INTEGER, PARAMETER :: PARAM_corn = 160 - INTEGER :: P_corn = 1 - LOGICAL :: F_corn = .FALSE. - INTEGER, PARAMETER :: PARAM_so4cwj = 161 - INTEGER :: P_so4cwj = 1 - LOGICAL :: F_so4cwj = .FALSE. - INTEGER, PARAMETER :: PARAM_so4cwi = 162 - INTEGER :: P_so4cwi = 1 - LOGICAL :: F_so4cwi = .FALSE. - INTEGER, PARAMETER :: PARAM_nh4cwj = 163 - INTEGER :: P_nh4cwj = 1 - LOGICAL :: F_nh4cwj = .FALSE. - INTEGER, PARAMETER :: PARAM_nh4cwi = 164 - INTEGER :: P_nh4cwi = 1 - LOGICAL :: F_nh4cwi = .FALSE. - INTEGER, PARAMETER :: PARAM_no3cwj = 165 - INTEGER :: P_no3cwj = 1 - LOGICAL :: F_no3cwj = .FALSE. - INTEGER, PARAMETER :: PARAM_no3cwi = 166 - INTEGER :: P_no3cwi = 1 - LOGICAL :: F_no3cwi = .FALSE. - INTEGER, PARAMETER :: PARAM_nacwj = 167 - INTEGER :: P_nacwj = 1 - LOGICAL :: F_nacwj = .FALSE. - INTEGER, PARAMETER :: PARAM_nacwi = 168 - INTEGER :: P_nacwi = 1 - LOGICAL :: F_nacwi = .FALSE. - INTEGER, PARAMETER :: PARAM_clcwj = 169 - INTEGER :: P_clcwj = 1 - LOGICAL :: F_clcwj = .FALSE. - INTEGER, PARAMETER :: PARAM_clcwi = 170 - INTEGER :: P_clcwi = 1 - LOGICAL :: F_clcwi = .FALSE. - INTEGER, PARAMETER :: PARAM_orgaro1cwj = 171 - INTEGER :: P_orgaro1cwj = 1 - LOGICAL :: F_orgaro1cwj = .FALSE. - INTEGER, PARAMETER :: PARAM_orgaro1cwi = 172 - INTEGER :: P_orgaro1cwi = 1 - LOGICAL :: F_orgaro1cwi = .FALSE. - INTEGER, PARAMETER :: PARAM_orgaro2cwj = 173 - INTEGER :: P_orgaro2cwj = 1 - LOGICAL :: F_orgaro2cwj = .FALSE. - INTEGER, PARAMETER :: PARAM_orgaro2cwi = 174 - INTEGER :: P_orgaro2cwi = 1 - LOGICAL :: F_orgaro2cwi = .FALSE. - INTEGER, PARAMETER :: PARAM_orgalk1cwj = 175 - INTEGER :: P_orgalk1cwj = 1 - LOGICAL :: F_orgalk1cwj = .FALSE. - INTEGER, PARAMETER :: PARAM_orgalk1cwi = 176 - INTEGER :: P_orgalk1cwi = 1 - LOGICAL :: F_orgalk1cwi = .FALSE. - INTEGER, PARAMETER :: PARAM_orgole1cwj = 177 - INTEGER :: P_orgole1cwj = 1 - LOGICAL :: F_orgole1cwj = .FALSE. - INTEGER, PARAMETER :: PARAM_orgole1cwi = 178 - INTEGER :: P_orgole1cwi = 1 - LOGICAL :: F_orgole1cwi = .FALSE. - INTEGER, PARAMETER :: PARAM_orgba1cwj = 179 - INTEGER :: P_orgba1cwj = 1 - LOGICAL :: F_orgba1cwj = .FALSE. - INTEGER, PARAMETER :: PARAM_orgba1cwi = 180 - INTEGER :: P_orgba1cwi = 1 - LOGICAL :: F_orgba1cwi = .FALSE. - INTEGER, PARAMETER :: PARAM_orgba2cwj = 181 - INTEGER :: P_orgba2cwj = 1 - LOGICAL :: F_orgba2cwj = .FALSE. - INTEGER, PARAMETER :: PARAM_orgba2cwi = 182 - INTEGER :: P_orgba2cwi = 1 - LOGICAL :: F_orgba2cwi = .FALSE. - INTEGER, PARAMETER :: PARAM_orgba3cwj = 183 - INTEGER :: P_orgba3cwj = 1 - LOGICAL :: F_orgba3cwj = .FALSE. - INTEGER, PARAMETER :: PARAM_orgba3cwi = 184 - INTEGER :: P_orgba3cwi = 1 - LOGICAL :: F_orgba3cwi = .FALSE. - INTEGER, PARAMETER :: PARAM_orgba4cwj = 185 - INTEGER :: P_orgba4cwj = 1 - LOGICAL :: F_orgba4cwj = .FALSE. - INTEGER, PARAMETER :: PARAM_orgba4cwi = 186 - INTEGER :: P_orgba4cwi = 1 - LOGICAL :: F_orgba4cwi = .FALSE. - INTEGER, PARAMETER :: PARAM_orgpacwj = 187 - INTEGER :: P_orgpacwj = 1 - LOGICAL :: F_orgpacwj = .FALSE. - INTEGER, PARAMETER :: PARAM_orgpacwi = 188 - INTEGER :: P_orgpacwi = 1 - LOGICAL :: F_orgpacwi = .FALSE. - INTEGER, PARAMETER :: PARAM_eccwj = 189 - INTEGER :: P_eccwj = 1 - LOGICAL :: F_eccwj = .FALSE. - INTEGER, PARAMETER :: PARAM_eccwi = 190 - INTEGER :: P_eccwi = 1 - LOGICAL :: F_eccwi = .FALSE. - INTEGER, PARAMETER :: PARAM_p25cwj = 191 - INTEGER :: P_p25cwj = 1 - LOGICAL :: F_p25cwj = .FALSE. - INTEGER, PARAMETER :: PARAM_p25cwi = 192 - INTEGER :: P_p25cwi = 1 - LOGICAL :: F_p25cwi = .FALSE. - INTEGER, PARAMETER :: PARAM_anthcw = 193 - INTEGER :: P_anthcw = 1 - LOGICAL :: F_anthcw = .FALSE. - INTEGER, PARAMETER :: PARAM_seascw = 194 - INTEGER :: P_seascw = 1 - LOGICAL :: F_seascw = .FALSE. - INTEGER, PARAMETER :: PARAM_soilcw = 195 - INTEGER :: P_soilcw = 1 - LOGICAL :: F_soilcw = .FALSE. - INTEGER, PARAMETER :: PARAM_nu0cw = 196 - INTEGER :: P_nu0cw = 1 - LOGICAL :: F_nu0cw = .FALSE. - INTEGER, PARAMETER :: PARAM_ac0cw = 197 - INTEGER :: P_ac0cw = 1 - LOGICAL :: F_ac0cw = .FALSE. - INTEGER, PARAMETER :: PARAM_corncw = 198 - INTEGER :: P_corncw = 1 - LOGICAL :: F_corncw = .FALSE. - INTEGER, PARAMETER :: PARAM_hace = 199 - INTEGER :: P_hace = 1 - LOGICAL :: F_hace = .FALSE. - INTEGER, PARAMETER :: PARAM_ishp = 200 - INTEGER :: P_ishp = 1 - LOGICAL :: F_ishp = .FALSE. - INTEGER, PARAMETER :: PARAM_ison = 201 - INTEGER :: P_ison = 1 - LOGICAL :: F_ison = .FALSE. - INTEGER, PARAMETER :: PARAM_mahp = 202 - INTEGER :: P_mahp = 1 - LOGICAL :: F_mahp = .FALSE. - INTEGER, PARAMETER :: PARAM_mpan = 203 - INTEGER :: P_mpan = 1 - LOGICAL :: F_mpan = .FALSE. - INTEGER, PARAMETER :: PARAM_nald = 204 - INTEGER :: P_nald = 1 - LOGICAL :: F_nald = .FALSE. - INTEGER, PARAMETER :: PARAM_so4_a01 = 205 - INTEGER :: P_so4_a01 = 1 - LOGICAL :: F_so4_a01 = .FALSE. - INTEGER, PARAMETER :: PARAM_no3_a01 = 206 - INTEGER :: P_no3_a01 = 1 - LOGICAL :: F_no3_a01 = .FALSE. - INTEGER, PARAMETER :: PARAM_cl_a01 = 207 - INTEGER :: P_cl_a01 = 1 - LOGICAL :: F_cl_a01 = .FALSE. - INTEGER, PARAMETER :: PARAM_msa_a01 = 208 - INTEGER :: P_msa_a01 = 1 - LOGICAL :: F_msa_a01 = .FALSE. - INTEGER, PARAMETER :: PARAM_co3_a01 = 209 - INTEGER :: P_co3_a01 = 1 - LOGICAL :: F_co3_a01 = .FALSE. - INTEGER, PARAMETER :: PARAM_nh4_a01 = 210 - INTEGER :: P_nh4_a01 = 1 - LOGICAL :: F_nh4_a01 = .FALSE. - INTEGER, PARAMETER :: PARAM_na_a01 = 211 - INTEGER :: P_na_a01 = 1 - LOGICAL :: F_na_a01 = .FALSE. - INTEGER, PARAMETER :: PARAM_ca_a01 = 212 - INTEGER :: P_ca_a01 = 1 - LOGICAL :: F_ca_a01 = .FALSE. - INTEGER, PARAMETER :: PARAM_oin_a01 = 213 - INTEGER :: P_oin_a01 = 1 - LOGICAL :: F_oin_a01 = .FALSE. - INTEGER, PARAMETER :: PARAM_oc_a01 = 214 - INTEGER :: P_oc_a01 = 1 - LOGICAL :: F_oc_a01 = .FALSE. - INTEGER, PARAMETER :: PARAM_bc_a01 = 215 - INTEGER :: P_bc_a01 = 1 - LOGICAL :: F_bc_a01 = .FALSE. - INTEGER, PARAMETER :: PARAM_hysw_a01 = 216 - INTEGER :: P_hysw_a01 = 1 - LOGICAL :: F_hysw_a01 = .FALSE. - INTEGER, PARAMETER :: PARAM_water_a01 = 217 - INTEGER :: P_water_a01 = 1 - LOGICAL :: F_water_a01 = .FALSE. - INTEGER, PARAMETER :: PARAM_num_a01 = 218 - INTEGER :: P_num_a01 = 1 - LOGICAL :: F_num_a01 = .FALSE. - INTEGER, PARAMETER :: PARAM_so4_a02 = 219 - INTEGER :: P_so4_a02 = 1 - LOGICAL :: F_so4_a02 = .FALSE. - INTEGER, PARAMETER :: PARAM_no3_a02 = 220 - INTEGER :: P_no3_a02 = 1 - LOGICAL :: F_no3_a02 = .FALSE. - INTEGER, PARAMETER :: PARAM_cl_a02 = 221 - INTEGER :: P_cl_a02 = 1 - LOGICAL :: F_cl_a02 = .FALSE. - INTEGER, PARAMETER :: PARAM_msa_a02 = 222 - INTEGER :: P_msa_a02 = 1 - LOGICAL :: F_msa_a02 = .FALSE. - INTEGER, PARAMETER :: PARAM_co3_a02 = 223 - INTEGER :: P_co3_a02 = 1 - LOGICAL :: F_co3_a02 = .FALSE. - INTEGER, PARAMETER :: PARAM_nh4_a02 = 224 - INTEGER :: P_nh4_a02 = 1 - LOGICAL :: F_nh4_a02 = .FALSE. - INTEGER, PARAMETER :: PARAM_na_a02 = 225 - INTEGER :: P_na_a02 = 1 - LOGICAL :: F_na_a02 = .FALSE. - INTEGER, PARAMETER :: PARAM_ca_a02 = 226 - INTEGER :: P_ca_a02 = 1 - LOGICAL :: F_ca_a02 = .FALSE. - INTEGER, PARAMETER :: PARAM_oin_a02 = 227 - INTEGER :: P_oin_a02 = 1 - LOGICAL :: F_oin_a02 = .FALSE. - INTEGER, PARAMETER :: PARAM_oc_a02 = 228 - INTEGER :: P_oc_a02 = 1 - LOGICAL :: F_oc_a02 = .FALSE. - INTEGER, PARAMETER :: PARAM_bc_a02 = 229 - INTEGER :: P_bc_a02 = 1 - LOGICAL :: F_bc_a02 = .FALSE. - INTEGER, PARAMETER :: PARAM_hysw_a02 = 230 - INTEGER :: P_hysw_a02 = 1 - LOGICAL :: F_hysw_a02 = .FALSE. - INTEGER, PARAMETER :: PARAM_water_a02 = 231 - INTEGER :: P_water_a02 = 1 - LOGICAL :: F_water_a02 = .FALSE. - INTEGER, PARAMETER :: PARAM_num_a02 = 232 - INTEGER :: P_num_a02 = 1 - LOGICAL :: F_num_a02 = .FALSE. - INTEGER, PARAMETER :: PARAM_so4_a03 = 233 - INTEGER :: P_so4_a03 = 1 - LOGICAL :: F_so4_a03 = .FALSE. - INTEGER, PARAMETER :: PARAM_no3_a03 = 234 - INTEGER :: P_no3_a03 = 1 - LOGICAL :: F_no3_a03 = .FALSE. - INTEGER, PARAMETER :: PARAM_cl_a03 = 235 - INTEGER :: P_cl_a03 = 1 - LOGICAL :: F_cl_a03 = .FALSE. - INTEGER, PARAMETER :: PARAM_msa_a03 = 236 - INTEGER :: P_msa_a03 = 1 - LOGICAL :: F_msa_a03 = .FALSE. - INTEGER, PARAMETER :: PARAM_co3_a03 = 237 - INTEGER :: P_co3_a03 = 1 - LOGICAL :: F_co3_a03 = .FALSE. - INTEGER, PARAMETER :: PARAM_nh4_a03 = 238 - INTEGER :: P_nh4_a03 = 1 - LOGICAL :: F_nh4_a03 = .FALSE. - INTEGER, PARAMETER :: PARAM_na_a03 = 239 - INTEGER :: P_na_a03 = 1 - LOGICAL :: F_na_a03 = .FALSE. - INTEGER, PARAMETER :: PARAM_ca_a03 = 240 - INTEGER :: P_ca_a03 = 1 - LOGICAL :: F_ca_a03 = .FALSE. - INTEGER, PARAMETER :: PARAM_oin_a03 = 241 - INTEGER :: P_oin_a03 = 1 - LOGICAL :: F_oin_a03 = .FALSE. - INTEGER, PARAMETER :: PARAM_oc_a03 = 242 - INTEGER :: P_oc_a03 = 1 - LOGICAL :: F_oc_a03 = .FALSE. - INTEGER, PARAMETER :: PARAM_bc_a03 = 243 - INTEGER :: P_bc_a03 = 1 - LOGICAL :: F_bc_a03 = .FALSE. - INTEGER, PARAMETER :: PARAM_hysw_a03 = 244 - INTEGER :: P_hysw_a03 = 1 - LOGICAL :: F_hysw_a03 = .FALSE. - INTEGER, PARAMETER :: PARAM_water_a03 = 245 - INTEGER :: P_water_a03 = 1 - LOGICAL :: F_water_a03 = .FALSE. - INTEGER, PARAMETER :: PARAM_num_a03 = 246 - INTEGER :: P_num_a03 = 1 - LOGICAL :: F_num_a03 = .FALSE. - INTEGER, PARAMETER :: PARAM_so4_a04 = 247 - INTEGER :: P_so4_a04 = 1 - LOGICAL :: F_so4_a04 = .FALSE. - INTEGER, PARAMETER :: PARAM_no3_a04 = 248 - INTEGER :: P_no3_a04 = 1 - LOGICAL :: F_no3_a04 = .FALSE. - INTEGER, PARAMETER :: PARAM_cl_a04 = 249 - INTEGER :: P_cl_a04 = 1 - LOGICAL :: F_cl_a04 = .FALSE. - INTEGER, PARAMETER :: PARAM_msa_a04 = 250 - INTEGER :: P_msa_a04 = 1 - LOGICAL :: F_msa_a04 = .FALSE. - INTEGER, PARAMETER :: PARAM_co3_a04 = 251 - INTEGER :: P_co3_a04 = 1 - LOGICAL :: F_co3_a04 = .FALSE. - INTEGER, PARAMETER :: PARAM_nh4_a04 = 252 - INTEGER :: P_nh4_a04 = 1 - LOGICAL :: F_nh4_a04 = .FALSE. - INTEGER, PARAMETER :: PARAM_na_a04 = 253 - INTEGER :: P_na_a04 = 1 - LOGICAL :: F_na_a04 = .FALSE. - INTEGER, PARAMETER :: PARAM_ca_a04 = 254 - INTEGER :: P_ca_a04 = 1 - LOGICAL :: F_ca_a04 = .FALSE. - INTEGER, PARAMETER :: PARAM_oin_a04 = 255 - INTEGER :: P_oin_a04 = 1 - LOGICAL :: F_oin_a04 = .FALSE. - INTEGER, PARAMETER :: PARAM_oc_a04 = 256 - INTEGER :: P_oc_a04 = 1 - LOGICAL :: F_oc_a04 = .FALSE. - INTEGER, PARAMETER :: PARAM_bc_a04 = 257 - INTEGER :: P_bc_a04 = 1 - LOGICAL :: F_bc_a04 = .FALSE. - INTEGER, PARAMETER :: PARAM_hysw_a04 = 258 - INTEGER :: P_hysw_a04 = 1 - LOGICAL :: F_hysw_a04 = .FALSE. - INTEGER, PARAMETER :: PARAM_water_a04 = 259 - INTEGER :: P_water_a04 = 1 - LOGICAL :: F_water_a04 = .FALSE. - INTEGER, PARAMETER :: PARAM_num_a04 = 260 - INTEGER :: P_num_a04 = 1 - LOGICAL :: F_num_a04 = .FALSE. - INTEGER, PARAMETER :: PARAM_so4_a05 = 261 - INTEGER :: P_so4_a05 = 1 - LOGICAL :: F_so4_a05 = .FALSE. - INTEGER, PARAMETER :: PARAM_no3_a05 = 262 - INTEGER :: P_no3_a05 = 1 - LOGICAL :: F_no3_a05 = .FALSE. - INTEGER, PARAMETER :: PARAM_cl_a05 = 263 - INTEGER :: P_cl_a05 = 1 - LOGICAL :: F_cl_a05 = .FALSE. - INTEGER, PARAMETER :: PARAM_msa_a05 = 264 - INTEGER :: P_msa_a05 = 1 - LOGICAL :: F_msa_a05 = .FALSE. - INTEGER, PARAMETER :: PARAM_co3_a05 = 265 - INTEGER :: P_co3_a05 = 1 - LOGICAL :: F_co3_a05 = .FALSE. - INTEGER, PARAMETER :: PARAM_nh4_a05 = 266 - INTEGER :: P_nh4_a05 = 1 - LOGICAL :: F_nh4_a05 = .FALSE. - INTEGER, PARAMETER :: PARAM_na_a05 = 267 - INTEGER :: P_na_a05 = 1 - LOGICAL :: F_na_a05 = .FALSE. - INTEGER, PARAMETER :: PARAM_ca_a05 = 268 - INTEGER :: P_ca_a05 = 1 - LOGICAL :: F_ca_a05 = .FALSE. - INTEGER, PARAMETER :: PARAM_oin_a05 = 269 - INTEGER :: P_oin_a05 = 1 - LOGICAL :: F_oin_a05 = .FALSE. - INTEGER, PARAMETER :: PARAM_oc_a05 = 270 - INTEGER :: P_oc_a05 = 1 - LOGICAL :: F_oc_a05 = .FALSE. - INTEGER, PARAMETER :: PARAM_bc_a05 = 271 - INTEGER :: P_bc_a05 = 1 - LOGICAL :: F_bc_a05 = .FALSE. - INTEGER, PARAMETER :: PARAM_hysw_a05 = 272 - INTEGER :: P_hysw_a05 = 1 - LOGICAL :: F_hysw_a05 = .FALSE. - INTEGER, PARAMETER :: PARAM_water_a05 = 273 - INTEGER :: P_water_a05 = 1 - LOGICAL :: F_water_a05 = .FALSE. - INTEGER, PARAMETER :: PARAM_num_a05 = 274 - INTEGER :: P_num_a05 = 1 - LOGICAL :: F_num_a05 = .FALSE. - INTEGER, PARAMETER :: PARAM_so4_a06 = 275 - INTEGER :: P_so4_a06 = 1 - LOGICAL :: F_so4_a06 = .FALSE. - INTEGER, PARAMETER :: PARAM_no3_a06 = 276 - INTEGER :: P_no3_a06 = 1 - LOGICAL :: F_no3_a06 = .FALSE. - INTEGER, PARAMETER :: PARAM_cl_a06 = 277 - INTEGER :: P_cl_a06 = 1 - LOGICAL :: F_cl_a06 = .FALSE. - INTEGER, PARAMETER :: PARAM_msa_a06 = 278 - INTEGER :: P_msa_a06 = 1 - LOGICAL :: F_msa_a06 = .FALSE. - INTEGER, PARAMETER :: PARAM_co3_a06 = 279 - INTEGER :: P_co3_a06 = 1 - LOGICAL :: F_co3_a06 = .FALSE. - INTEGER, PARAMETER :: PARAM_nh4_a06 = 280 - INTEGER :: P_nh4_a06 = 1 - LOGICAL :: F_nh4_a06 = .FALSE. - INTEGER, PARAMETER :: PARAM_na_a06 = 281 - INTEGER :: P_na_a06 = 1 - LOGICAL :: F_na_a06 = .FALSE. - INTEGER, PARAMETER :: PARAM_ca_a06 = 282 - INTEGER :: P_ca_a06 = 1 - LOGICAL :: F_ca_a06 = .FALSE. - INTEGER, PARAMETER :: PARAM_oin_a06 = 283 - INTEGER :: P_oin_a06 = 1 - LOGICAL :: F_oin_a06 = .FALSE. - INTEGER, PARAMETER :: PARAM_oc_a06 = 284 - INTEGER :: P_oc_a06 = 1 - LOGICAL :: F_oc_a06 = .FALSE. - INTEGER, PARAMETER :: PARAM_bc_a06 = 285 - INTEGER :: P_bc_a06 = 1 - LOGICAL :: F_bc_a06 = .FALSE. - INTEGER, PARAMETER :: PARAM_hysw_a06 = 286 - INTEGER :: P_hysw_a06 = 1 - LOGICAL :: F_hysw_a06 = .FALSE. - INTEGER, PARAMETER :: PARAM_water_a06 = 287 - INTEGER :: P_water_a06 = 1 - LOGICAL :: F_water_a06 = .FALSE. - INTEGER, PARAMETER :: PARAM_num_a06 = 288 - INTEGER :: P_num_a06 = 1 - LOGICAL :: F_num_a06 = .FALSE. - INTEGER, PARAMETER :: PARAM_so4_a07 = 289 - INTEGER :: P_so4_a07 = 1 - LOGICAL :: F_so4_a07 = .FALSE. - INTEGER, PARAMETER :: PARAM_no3_a07 = 290 - INTEGER :: P_no3_a07 = 1 - LOGICAL :: F_no3_a07 = .FALSE. - INTEGER, PARAMETER :: PARAM_cl_a07 = 291 - INTEGER :: P_cl_a07 = 1 - LOGICAL :: F_cl_a07 = .FALSE. - INTEGER, PARAMETER :: PARAM_msa_a07 = 292 - INTEGER :: P_msa_a07 = 1 - LOGICAL :: F_msa_a07 = .FALSE. - INTEGER, PARAMETER :: PARAM_co3_a07 = 293 - INTEGER :: P_co3_a07 = 1 - LOGICAL :: F_co3_a07 = .FALSE. - INTEGER, PARAMETER :: PARAM_nh4_a07 = 294 - INTEGER :: P_nh4_a07 = 1 - LOGICAL :: F_nh4_a07 = .FALSE. - INTEGER, PARAMETER :: PARAM_na_a07 = 295 - INTEGER :: P_na_a07 = 1 - LOGICAL :: F_na_a07 = .FALSE. - INTEGER, PARAMETER :: PARAM_ca_a07 = 296 - INTEGER :: P_ca_a07 = 1 - LOGICAL :: F_ca_a07 = .FALSE. - INTEGER, PARAMETER :: PARAM_oin_a07 = 297 - INTEGER :: P_oin_a07 = 1 - LOGICAL :: F_oin_a07 = .FALSE. - INTEGER, PARAMETER :: PARAM_oc_a07 = 298 - INTEGER :: P_oc_a07 = 1 - LOGICAL :: F_oc_a07 = .FALSE. - INTEGER, PARAMETER :: PARAM_bc_a07 = 299 - INTEGER :: P_bc_a07 = 1 - LOGICAL :: F_bc_a07 = .FALSE. - INTEGER, PARAMETER :: PARAM_hysw_a07 = 300 - INTEGER :: P_hysw_a07 = 1 - LOGICAL :: F_hysw_a07 = .FALSE. - INTEGER, PARAMETER :: PARAM_water_a07 = 301 - INTEGER :: P_water_a07 = 1 - LOGICAL :: F_water_a07 = .FALSE. - INTEGER, PARAMETER :: PARAM_num_a07 = 302 - INTEGER :: P_num_a07 = 1 - LOGICAL :: F_num_a07 = .FALSE. - INTEGER, PARAMETER :: PARAM_so4_a08 = 303 - INTEGER :: P_so4_a08 = 1 - LOGICAL :: F_so4_a08 = .FALSE. - INTEGER, PARAMETER :: PARAM_no3_a08 = 304 - INTEGER :: P_no3_a08 = 1 - LOGICAL :: F_no3_a08 = .FALSE. - INTEGER, PARAMETER :: PARAM_cl_a08 = 305 - INTEGER :: P_cl_a08 = 1 - LOGICAL :: F_cl_a08 = .FALSE. - INTEGER, PARAMETER :: PARAM_msa_a08 = 306 - INTEGER :: P_msa_a08 = 1 - LOGICAL :: F_msa_a08 = .FALSE. - INTEGER, PARAMETER :: PARAM_co3_a08 = 307 - INTEGER :: P_co3_a08 = 1 - LOGICAL :: F_co3_a08 = .FALSE. - INTEGER, PARAMETER :: PARAM_nh4_a08 = 308 - INTEGER :: P_nh4_a08 = 1 - LOGICAL :: F_nh4_a08 = .FALSE. - INTEGER, PARAMETER :: PARAM_na_a08 = 309 - INTEGER :: P_na_a08 = 1 - LOGICAL :: F_na_a08 = .FALSE. - INTEGER, PARAMETER :: PARAM_ca_a08 = 310 - INTEGER :: P_ca_a08 = 1 - LOGICAL :: F_ca_a08 = .FALSE. - INTEGER, PARAMETER :: PARAM_oin_a08 = 311 - INTEGER :: P_oin_a08 = 1 - LOGICAL :: F_oin_a08 = .FALSE. - INTEGER, PARAMETER :: PARAM_oc_a08 = 312 - INTEGER :: P_oc_a08 = 1 - LOGICAL :: F_oc_a08 = .FALSE. - INTEGER, PARAMETER :: PARAM_bc_a08 = 313 - INTEGER :: P_bc_a08 = 1 - LOGICAL :: F_bc_a08 = .FALSE. - INTEGER, PARAMETER :: PARAM_hysw_a08 = 314 - INTEGER :: P_hysw_a08 = 1 - LOGICAL :: F_hysw_a08 = .FALSE. - INTEGER, PARAMETER :: PARAM_water_a08 = 315 - INTEGER :: P_water_a08 = 1 - LOGICAL :: F_water_a08 = .FALSE. - INTEGER, PARAMETER :: PARAM_num_a08 = 316 - INTEGER :: P_num_a08 = 1 - LOGICAL :: F_num_a08 = .FALSE. - INTEGER, PARAMETER :: PARAM_so4_cw01 = 317 - INTEGER :: P_so4_cw01 = 1 - LOGICAL :: F_so4_cw01 = .FALSE. - INTEGER, PARAMETER :: PARAM_no3_cw01 = 318 - INTEGER :: P_no3_cw01 = 1 - LOGICAL :: F_no3_cw01 = .FALSE. - INTEGER, PARAMETER :: PARAM_cl_cw01 = 319 - INTEGER :: P_cl_cw01 = 1 - LOGICAL :: F_cl_cw01 = .FALSE. - INTEGER, PARAMETER :: PARAM_msa_cw01 = 320 - INTEGER :: P_msa_cw01 = 1 - LOGICAL :: F_msa_cw01 = .FALSE. - INTEGER, PARAMETER :: PARAM_co3_cw01 = 321 - INTEGER :: P_co3_cw01 = 1 - LOGICAL :: F_co3_cw01 = .FALSE. - INTEGER, PARAMETER :: PARAM_nh4_cw01 = 322 - INTEGER :: P_nh4_cw01 = 1 - LOGICAL :: F_nh4_cw01 = .FALSE. - INTEGER, PARAMETER :: PARAM_na_cw01 = 323 - INTEGER :: P_na_cw01 = 1 - LOGICAL :: F_na_cw01 = .FALSE. - INTEGER, PARAMETER :: PARAM_ca_cw01 = 324 - INTEGER :: P_ca_cw01 = 1 - LOGICAL :: F_ca_cw01 = .FALSE. - INTEGER, PARAMETER :: PARAM_oin_cw01 = 325 - INTEGER :: P_oin_cw01 = 1 - LOGICAL :: F_oin_cw01 = .FALSE. - INTEGER, PARAMETER :: PARAM_oc_cw01 = 326 - INTEGER :: P_oc_cw01 = 1 - LOGICAL :: F_oc_cw01 = .FALSE. - INTEGER, PARAMETER :: PARAM_bc_cw01 = 327 - INTEGER :: P_bc_cw01 = 1 - LOGICAL :: F_bc_cw01 = .FALSE. - INTEGER, PARAMETER :: PARAM_num_cw01 = 328 - INTEGER :: P_num_cw01 = 1 - LOGICAL :: F_num_cw01 = .FALSE. - INTEGER, PARAMETER :: PARAM_so4_cw02 = 329 - INTEGER :: P_so4_cw02 = 1 - LOGICAL :: F_so4_cw02 = .FALSE. - INTEGER, PARAMETER :: PARAM_no3_cw02 = 330 - INTEGER :: P_no3_cw02 = 1 - LOGICAL :: F_no3_cw02 = .FALSE. - INTEGER, PARAMETER :: PARAM_cl_cw02 = 331 - INTEGER :: P_cl_cw02 = 1 - LOGICAL :: F_cl_cw02 = .FALSE. - INTEGER, PARAMETER :: PARAM_msa_cw02 = 332 - INTEGER :: P_msa_cw02 = 1 - LOGICAL :: F_msa_cw02 = .FALSE. - INTEGER, PARAMETER :: PARAM_co3_cw02 = 333 - INTEGER :: P_co3_cw02 = 1 - LOGICAL :: F_co3_cw02 = .FALSE. - INTEGER, PARAMETER :: PARAM_nh4_cw02 = 334 - INTEGER :: P_nh4_cw02 = 1 - LOGICAL :: F_nh4_cw02 = .FALSE. - INTEGER, PARAMETER :: PARAM_na_cw02 = 335 - INTEGER :: P_na_cw02 = 1 - LOGICAL :: F_na_cw02 = .FALSE. - INTEGER, PARAMETER :: PARAM_ca_cw02 = 336 - INTEGER :: P_ca_cw02 = 1 - LOGICAL :: F_ca_cw02 = .FALSE. - INTEGER, PARAMETER :: PARAM_oin_cw02 = 337 - INTEGER :: P_oin_cw02 = 1 - LOGICAL :: F_oin_cw02 = .FALSE. - INTEGER, PARAMETER :: PARAM_oc_cw02 = 338 - INTEGER :: P_oc_cw02 = 1 - LOGICAL :: F_oc_cw02 = .FALSE. - INTEGER, PARAMETER :: PARAM_bc_cw02 = 339 - INTEGER :: P_bc_cw02 = 1 - LOGICAL :: F_bc_cw02 = .FALSE. - INTEGER, PARAMETER :: PARAM_num_cw02 = 340 - INTEGER :: P_num_cw02 = 1 - LOGICAL :: F_num_cw02 = .FALSE. - INTEGER, PARAMETER :: PARAM_so4_cw03 = 341 - INTEGER :: P_so4_cw03 = 1 - LOGICAL :: F_so4_cw03 = .FALSE. - INTEGER, PARAMETER :: PARAM_no3_cw03 = 342 - INTEGER :: P_no3_cw03 = 1 - LOGICAL :: F_no3_cw03 = .FALSE. - INTEGER, PARAMETER :: PARAM_cl_cw03 = 343 - INTEGER :: P_cl_cw03 = 1 - LOGICAL :: F_cl_cw03 = .FALSE. - INTEGER, PARAMETER :: PARAM_msa_cw03 = 344 - INTEGER :: P_msa_cw03 = 1 - LOGICAL :: F_msa_cw03 = .FALSE. - INTEGER, PARAMETER :: PARAM_co3_cw03 = 345 - INTEGER :: P_co3_cw03 = 1 - LOGICAL :: F_co3_cw03 = .FALSE. - INTEGER, PARAMETER :: PARAM_nh4_cw03 = 346 - INTEGER :: P_nh4_cw03 = 1 - LOGICAL :: F_nh4_cw03 = .FALSE. - INTEGER, PARAMETER :: PARAM_na_cw03 = 347 - INTEGER :: P_na_cw03 = 1 - LOGICAL :: F_na_cw03 = .FALSE. - INTEGER, PARAMETER :: PARAM_ca_cw03 = 348 - INTEGER :: P_ca_cw03 = 1 - LOGICAL :: F_ca_cw03 = .FALSE. - INTEGER, PARAMETER :: PARAM_oin_cw03 = 349 - INTEGER :: P_oin_cw03 = 1 - LOGICAL :: F_oin_cw03 = .FALSE. - INTEGER, PARAMETER :: PARAM_oc_cw03 = 350 - INTEGER :: P_oc_cw03 = 1 - LOGICAL :: F_oc_cw03 = .FALSE. - INTEGER, PARAMETER :: PARAM_bc_cw03 = 351 - INTEGER :: P_bc_cw03 = 1 - LOGICAL :: F_bc_cw03 = .FALSE. - INTEGER, PARAMETER :: PARAM_num_cw03 = 352 - INTEGER :: P_num_cw03 = 1 - LOGICAL :: F_num_cw03 = .FALSE. - INTEGER, PARAMETER :: PARAM_so4_cw04 = 353 - INTEGER :: P_so4_cw04 = 1 - LOGICAL :: F_so4_cw04 = .FALSE. - INTEGER, PARAMETER :: PARAM_no3_cw04 = 354 - INTEGER :: P_no3_cw04 = 1 - LOGICAL :: F_no3_cw04 = .FALSE. - INTEGER, PARAMETER :: PARAM_cl_cw04 = 355 - INTEGER :: P_cl_cw04 = 1 - LOGICAL :: F_cl_cw04 = .FALSE. - INTEGER, PARAMETER :: PARAM_msa_cw04 = 356 - INTEGER :: P_msa_cw04 = 1 - LOGICAL :: F_msa_cw04 = .FALSE. - INTEGER, PARAMETER :: PARAM_co3_cw04 = 357 - INTEGER :: P_co3_cw04 = 1 - LOGICAL :: F_co3_cw04 = .FALSE. - INTEGER, PARAMETER :: PARAM_nh4_cw04 = 358 - INTEGER :: P_nh4_cw04 = 1 - LOGICAL :: F_nh4_cw04 = .FALSE. - INTEGER, PARAMETER :: PARAM_na_cw04 = 359 - INTEGER :: P_na_cw04 = 1 - LOGICAL :: F_na_cw04 = .FALSE. - INTEGER, PARAMETER :: PARAM_ca_cw04 = 360 - INTEGER :: P_ca_cw04 = 1 - LOGICAL :: F_ca_cw04 = .FALSE. - INTEGER, PARAMETER :: PARAM_oin_cw04 = 361 - INTEGER :: P_oin_cw04 = 1 - LOGICAL :: F_oin_cw04 = .FALSE. - INTEGER, PARAMETER :: PARAM_oc_cw04 = 362 - INTEGER :: P_oc_cw04 = 1 - LOGICAL :: F_oc_cw04 = .FALSE. - INTEGER, PARAMETER :: PARAM_bc_cw04 = 363 - INTEGER :: P_bc_cw04 = 1 - LOGICAL :: F_bc_cw04 = .FALSE. - INTEGER, PARAMETER :: PARAM_num_cw04 = 364 - INTEGER :: P_num_cw04 = 1 - LOGICAL :: F_num_cw04 = .FALSE. - INTEGER, PARAMETER :: PARAM_so4_cw05 = 365 - INTEGER :: P_so4_cw05 = 1 - LOGICAL :: F_so4_cw05 = .FALSE. - INTEGER, PARAMETER :: PARAM_no3_cw05 = 366 - INTEGER :: P_no3_cw05 = 1 - LOGICAL :: F_no3_cw05 = .FALSE. - INTEGER, PARAMETER :: PARAM_cl_cw05 = 367 - INTEGER :: P_cl_cw05 = 1 - LOGICAL :: F_cl_cw05 = .FALSE. - INTEGER, PARAMETER :: PARAM_msa_cw05 = 368 - INTEGER :: P_msa_cw05 = 1 - LOGICAL :: F_msa_cw05 = .FALSE. - INTEGER, PARAMETER :: PARAM_co3_cw05 = 369 - INTEGER :: P_co3_cw05 = 1 - LOGICAL :: F_co3_cw05 = .FALSE. - INTEGER, PARAMETER :: PARAM_nh4_cw05 = 370 - INTEGER :: P_nh4_cw05 = 1 - LOGICAL :: F_nh4_cw05 = .FALSE. - INTEGER, PARAMETER :: PARAM_na_cw05 = 371 - INTEGER :: P_na_cw05 = 1 - LOGICAL :: F_na_cw05 = .FALSE. - INTEGER, PARAMETER :: PARAM_ca_cw05 = 372 - INTEGER :: P_ca_cw05 = 1 - LOGICAL :: F_ca_cw05 = .FALSE. - INTEGER, PARAMETER :: PARAM_oin_cw05 = 373 - INTEGER :: P_oin_cw05 = 1 - LOGICAL :: F_oin_cw05 = .FALSE. - INTEGER, PARAMETER :: PARAM_oc_cw05 = 374 - INTEGER :: P_oc_cw05 = 1 - LOGICAL :: F_oc_cw05 = .FALSE. - INTEGER, PARAMETER :: PARAM_bc_cw05 = 375 - INTEGER :: P_bc_cw05 = 1 - LOGICAL :: F_bc_cw05 = .FALSE. - INTEGER, PARAMETER :: PARAM_num_cw05 = 376 - INTEGER :: P_num_cw05 = 1 - LOGICAL :: F_num_cw05 = .FALSE. - INTEGER, PARAMETER :: PARAM_so4_cw06 = 377 - INTEGER :: P_so4_cw06 = 1 - LOGICAL :: F_so4_cw06 = .FALSE. - INTEGER, PARAMETER :: PARAM_no3_cw06 = 378 - INTEGER :: P_no3_cw06 = 1 - LOGICAL :: F_no3_cw06 = .FALSE. - INTEGER, PARAMETER :: PARAM_cl_cw06 = 379 - INTEGER :: P_cl_cw06 = 1 - LOGICAL :: F_cl_cw06 = .FALSE. - INTEGER, PARAMETER :: PARAM_msa_cw06 = 380 - INTEGER :: P_msa_cw06 = 1 - LOGICAL :: F_msa_cw06 = .FALSE. - INTEGER, PARAMETER :: PARAM_co3_cw06 = 381 - INTEGER :: P_co3_cw06 = 1 - LOGICAL :: F_co3_cw06 = .FALSE. - INTEGER, PARAMETER :: PARAM_nh4_cw06 = 382 - INTEGER :: P_nh4_cw06 = 1 - LOGICAL :: F_nh4_cw06 = .FALSE. - INTEGER, PARAMETER :: PARAM_na_cw06 = 383 - INTEGER :: P_na_cw06 = 1 - LOGICAL :: F_na_cw06 = .FALSE. - INTEGER, PARAMETER :: PARAM_ca_cw06 = 384 - INTEGER :: P_ca_cw06 = 1 - LOGICAL :: F_ca_cw06 = .FALSE. - INTEGER, PARAMETER :: PARAM_oin_cw06 = 385 - INTEGER :: P_oin_cw06 = 1 - LOGICAL :: F_oin_cw06 = .FALSE. - INTEGER, PARAMETER :: PARAM_oc_cw06 = 386 - INTEGER :: P_oc_cw06 = 1 - LOGICAL :: F_oc_cw06 = .FALSE. - INTEGER, PARAMETER :: PARAM_bc_cw06 = 387 - INTEGER :: P_bc_cw06 = 1 - LOGICAL :: F_bc_cw06 = .FALSE. - INTEGER, PARAMETER :: PARAM_num_cw06 = 388 - INTEGER :: P_num_cw06 = 1 - LOGICAL :: F_num_cw06 = .FALSE. - INTEGER, PARAMETER :: PARAM_so4_cw07 = 389 - INTEGER :: P_so4_cw07 = 1 - LOGICAL :: F_so4_cw07 = .FALSE. - INTEGER, PARAMETER :: PARAM_no3_cw07 = 390 - INTEGER :: P_no3_cw07 = 1 - LOGICAL :: F_no3_cw07 = .FALSE. - INTEGER, PARAMETER :: PARAM_cl_cw07 = 391 - INTEGER :: P_cl_cw07 = 1 - LOGICAL :: F_cl_cw07 = .FALSE. - INTEGER, PARAMETER :: PARAM_msa_cw07 = 392 - INTEGER :: P_msa_cw07 = 1 - LOGICAL :: F_msa_cw07 = .FALSE. - INTEGER, PARAMETER :: PARAM_co3_cw07 = 393 - INTEGER :: P_co3_cw07 = 1 - LOGICAL :: F_co3_cw07 = .FALSE. - INTEGER, PARAMETER :: PARAM_nh4_cw07 = 394 - INTEGER :: P_nh4_cw07 = 1 - LOGICAL :: F_nh4_cw07 = .FALSE. - INTEGER, PARAMETER :: PARAM_na_cw07 = 395 - INTEGER :: P_na_cw07 = 1 - LOGICAL :: F_na_cw07 = .FALSE. - INTEGER, PARAMETER :: PARAM_ca_cw07 = 396 - INTEGER :: P_ca_cw07 = 1 - LOGICAL :: F_ca_cw07 = .FALSE. - INTEGER, PARAMETER :: PARAM_oin_cw07 = 397 - INTEGER :: P_oin_cw07 = 1 - LOGICAL :: F_oin_cw07 = .FALSE. - INTEGER, PARAMETER :: PARAM_oc_cw07 = 398 - INTEGER :: P_oc_cw07 = 1 - LOGICAL :: F_oc_cw07 = .FALSE. - INTEGER, PARAMETER :: PARAM_bc_cw07 = 399 - INTEGER :: P_bc_cw07 = 1 - LOGICAL :: F_bc_cw07 = .FALSE. - INTEGER, PARAMETER :: PARAM_num_cw07 = 400 - INTEGER :: P_num_cw07 = 1 - LOGICAL :: F_num_cw07 = .FALSE. - INTEGER, PARAMETER :: PARAM_so4_cw08 = 401 - INTEGER :: P_so4_cw08 = 1 - LOGICAL :: F_so4_cw08 = .FALSE. - INTEGER, PARAMETER :: PARAM_no3_cw08 = 402 - INTEGER :: P_no3_cw08 = 1 - LOGICAL :: F_no3_cw08 = .FALSE. - INTEGER, PARAMETER :: PARAM_cl_cw08 = 403 - INTEGER :: P_cl_cw08 = 1 - LOGICAL :: F_cl_cw08 = .FALSE. - INTEGER, PARAMETER :: PARAM_msa_cw08 = 404 - INTEGER :: P_msa_cw08 = 1 - LOGICAL :: F_msa_cw08 = .FALSE. - INTEGER, PARAMETER :: PARAM_co3_cw08 = 405 - INTEGER :: P_co3_cw08 = 1 - LOGICAL :: F_co3_cw08 = .FALSE. - INTEGER, PARAMETER :: PARAM_nh4_cw08 = 406 - INTEGER :: P_nh4_cw08 = 1 - LOGICAL :: F_nh4_cw08 = .FALSE. - INTEGER, PARAMETER :: PARAM_na_cw08 = 407 - INTEGER :: P_na_cw08 = 1 - LOGICAL :: F_na_cw08 = .FALSE. - INTEGER, PARAMETER :: PARAM_ca_cw08 = 408 - INTEGER :: P_ca_cw08 = 1 - LOGICAL :: F_ca_cw08 = .FALSE. - INTEGER, PARAMETER :: PARAM_oin_cw08 = 409 - INTEGER :: P_oin_cw08 = 1 - LOGICAL :: F_oin_cw08 = .FALSE. - INTEGER, PARAMETER :: PARAM_oc_cw08 = 410 - INTEGER :: P_oc_cw08 = 1 - LOGICAL :: F_oc_cw08 = .FALSE. - INTEGER, PARAMETER :: PARAM_bc_cw08 = 411 - INTEGER :: P_bc_cw08 = 1 - LOGICAL :: F_bc_cw08 = .FALSE. - INTEGER, PARAMETER :: PARAM_num_cw08 = 412 - INTEGER :: P_num_cw08 = 1 - LOGICAL :: F_num_cw08 = .FALSE. - INTEGER, PARAMETER :: PARAM_bc1 = 413 - INTEGER :: P_bc1 = 1 - LOGICAL :: F_bc1 = .FALSE. - INTEGER, PARAMETER :: PARAM_bc2 = 414 - INTEGER :: P_bc2 = 1 - LOGICAL :: F_bc2 = .FALSE. - INTEGER, PARAMETER :: PARAM_oc1 = 415 - INTEGER :: P_oc1 = 1 - LOGICAL :: F_oc1 = .FALSE. - INTEGER, PARAMETER :: PARAM_oc2 = 416 - INTEGER :: P_oc2 = 1 - LOGICAL :: F_oc2 = .FALSE. - INTEGER, PARAMETER :: PARAM_p25 = 417 - INTEGER :: P_p25 = 1 - LOGICAL :: F_p25 = .FALSE. - INTEGER, PARAMETER :: PARAM_p10 = 418 - INTEGER :: P_p10 = 1 - LOGICAL :: F_p10 = .FALSE. - INTEGER, PARAMETER :: PARAM_dust_1 = 419 - INTEGER :: P_dust_1 = 1 - LOGICAL :: F_dust_1 = .FALSE. - INTEGER, PARAMETER :: PARAM_dust_2 = 420 - INTEGER :: P_dust_2 = 1 - LOGICAL :: F_dust_2 = .FALSE. - INTEGER, PARAMETER :: PARAM_dust_3 = 421 - INTEGER :: P_dust_3 = 1 - LOGICAL :: F_dust_3 = .FALSE. - INTEGER, PARAMETER :: PARAM_dust_4 = 422 - INTEGER :: P_dust_4 = 1 - LOGICAL :: F_dust_4 = .FALSE. - INTEGER, PARAMETER :: PARAM_dust_5 = 423 - INTEGER :: P_dust_5 = 1 - LOGICAL :: F_dust_5 = .FALSE. - INTEGER, PARAMETER :: PARAM_seas_1 = 424 - INTEGER :: P_seas_1 = 1 - LOGICAL :: F_seas_1 = .FALSE. - INTEGER, PARAMETER :: PARAM_seas_2 = 425 - INTEGER :: P_seas_2 = 1 - LOGICAL :: F_seas_2 = .FALSE. - INTEGER, PARAMETER :: PARAM_seas_3 = 426 - INTEGER :: P_seas_3 = 1 - LOGICAL :: F_seas_3 = .FALSE. - INTEGER, PARAMETER :: PARAM_seas_4 = 427 - INTEGER :: P_seas_4 = 1 - LOGICAL :: F_seas_4 = .FALSE. - INTEGER, PARAMETER :: PARAM_pa = 428 - INTEGER :: P_pa = 1 - LOGICAL :: F_pa = .FALSE. - INTEGER, PARAMETER :: PARAM_aca = 429 - INTEGER :: P_aca = 1 - LOGICAL :: F_aca = .FALSE. - INTEGER, PARAMETER :: PARAM_acet = 430 - INTEGER :: P_acet = 1 - LOGICAL :: F_acet = .FALSE. - INTEGER, PARAMETER :: PARAM_isopr = 431 - INTEGER :: P_isopr = 1 - LOGICAL :: F_isopr = .FALSE. - INTEGER, PARAMETER :: PARAM_mvk = 432 - INTEGER :: P_mvk = 1 - LOGICAL :: F_mvk = .FALSE. - INTEGER, PARAMETER :: PARAM_iso2 = 433 - INTEGER :: P_iso2 = 1 - LOGICAL :: F_iso2 = .FALSE. - INTEGER, PARAMETER :: PARAM_isooh = 434 - INTEGER :: P_isooh = 1 - LOGICAL :: F_isooh = .FALSE. - INTEGER, PARAMETER :: PARAM_mvko2 = 435 - INTEGER :: P_mvko2 = 1 - LOGICAL :: F_mvko2 = .FALSE. - INTEGER, PARAMETER :: PARAM_mvkooh = 436 - INTEGER :: P_mvkooh = 1 - LOGICAL :: F_mvkooh = .FALSE. - INTEGER, PARAMETER :: PARAM_acol = 437 - INTEGER :: P_acol = 1 - LOGICAL :: F_acol = .FALSE. - INTEGER, PARAMETER :: PARAM_hcooh = 438 - INTEGER :: P_hcooh = 1 - LOGICAL :: F_hcooh = .FALSE. - INTEGER, PARAMETER :: PARAM_naca = 439 - INTEGER :: P_naca = 1 - LOGICAL :: F_naca = .FALSE. - INTEGER, PARAMETER :: PARAM_mglo = 440 - INTEGER :: P_mglo = 1 - LOGICAL :: F_mglo = .FALSE. - INTEGER, PARAMETER :: PARAM_c2h6 = 441 - INTEGER :: P_c2h6 = 1 - LOGICAL :: F_c2h6 = .FALSE. - INTEGER, PARAMETER :: PARAM_etooh = 442 - INTEGER :: P_etooh = 1 - LOGICAL :: F_etooh = .FALSE. - INTEGER, PARAMETER :: PARAM_c3h8 = 443 - INTEGER :: P_c3h8 = 1 - LOGICAL :: F_c3h8 = .FALSE. - INTEGER, PARAMETER :: PARAM_prooh = 444 - INTEGER :: P_prooh = 1 - LOGICAL :: F_prooh = .FALSE. - INTEGER, PARAMETER :: PARAM_acooh = 445 - INTEGER :: P_acooh = 1 - LOGICAL :: F_acooh = .FALSE. - INTEGER, PARAMETER :: PARAM_eto2 = 446 - INTEGER :: P_eto2 = 1 - LOGICAL :: F_eto2 = .FALSE. - INTEGER, PARAMETER :: PARAM_pro2 = 447 - INTEGER :: P_pro2 = 1 - LOGICAL :: F_pro2 = .FALSE. - INTEGER, PARAMETER :: PARAM_aco2 = 448 - INTEGER :: P_aco2 = 1 - LOGICAL :: F_aco2 = .FALSE. - INTEGER, PARAMETER :: PARAM_c3h6 = 449 - INTEGER :: P_c3h6 = 1 - LOGICAL :: F_c3h6 = .FALSE. - INTEGER, PARAMETER :: PARAM_c3h6ooh = 450 - INTEGER :: P_c3h6ooh = 1 - LOGICAL :: F_c3h6ooh = .FALSE. - INTEGER, PARAMETER :: PARAM_c2h4 = 451 - INTEGER :: P_c2h4 = 1 - LOGICAL :: F_c2h4 = .FALSE. - INTEGER, PARAMETER :: PARAM_c4h10 = 452 - INTEGER :: P_c4h10 = 1 - LOGICAL :: F_c4h10 = .FALSE. - INTEGER, PARAMETER :: PARAM_buooh = 453 - INTEGER :: P_buooh = 1 - LOGICAL :: F_buooh = .FALSE. - INTEGER, PARAMETER :: PARAM_mek = 454 - INTEGER :: P_mek = 1 - LOGICAL :: F_mek = .FALSE. - INTEGER, PARAMETER :: PARAM_mekooh = 455 - INTEGER :: P_mekooh = 1 - LOGICAL :: F_mekooh = .FALSE. - INTEGER, PARAMETER :: PARAM_mecoco = 456 - INTEGER :: P_mecoco = 1 - LOGICAL :: F_mecoco = .FALSE. - INTEGER, PARAMETER :: PARAM_c3h6o2 = 457 - INTEGER :: P_c3h6o2 = 1 - LOGICAL :: F_c3h6o2 = .FALSE. - INTEGER, PARAMETER :: PARAM_c4h9o2 = 458 - INTEGER :: P_c4h9o2 = 1 - LOGICAL :: F_c4h9o2 = .FALSE. - INTEGER, PARAMETER :: PARAM_meko2 = 459 - INTEGER :: P_meko2 = 1 - LOGICAL :: F_meko2 = .FALSE. - INTEGER, PARAMETER :: PARAM_prono2 = 460 - INTEGER :: P_prono2 = 1 - LOGICAL :: F_prono2 = .FALSE. - INTEGER, PARAMETER :: PARAM_acetol = 461 - INTEGER :: P_acetol = 1 - LOGICAL :: F_acetol = .FALSE. - INTEGER, PARAMETER :: PARAM_acetp = 462 - INTEGER :: P_acetp = 1 - LOGICAL :: F_acetp = .FALSE. - INTEGER, PARAMETER :: PARAM_aceto2 = 463 - INTEGER :: P_aceto2 = 1 - LOGICAL :: F_aceto2 = .FALSE. - INTEGER, PARAMETER :: PARAM_ch3cooh = 464 - INTEGER :: P_ch3cooh = 1 - LOGICAL :: F_ch3cooh = .FALSE. - INTEGER, PARAMETER :: PARAM_c4h9ooh = 465 - INTEGER :: P_c4h9ooh = 1 - LOGICAL :: F_c4h9ooh = .FALSE. - INTEGER, PARAMETER :: PARAM_meo2 = 466 - INTEGER :: P_meo2 = 1 - LOGICAL :: F_meo2 = .FALSE. - INTEGER, PARAMETER :: PARAM_meoh = 467 - INTEGER :: P_meoh = 1 - LOGICAL :: F_meoh = .FALSE. - INTEGER, PARAMETER :: PARAM_meo2no2 = 468 - INTEGER :: P_meo2no2 = 1 - LOGICAL :: F_meo2no2 = .FALSE. - INTEGER, PARAMETER :: PARAM_tr1 = 469 - INTEGER :: P_tr1 = 1 - LOGICAL :: F_tr1 = .FALSE. - INTEGER, PARAMETER :: PARAM_tr2 = 470 - INTEGER :: P_tr2 = 1 - LOGICAL :: F_tr2 = .FALSE. - INTEGER, PARAMETER :: PARAM_NUM_chem = 471 -!ggnum INTEGER :: NUM_chem = 1 - INTEGER, PARAMETER :: PARAM_tr17_0 = 0 - INTEGER :: P_tr17_0 = 1 - LOGICAL :: F_tr17_0 = .FALSE. - INTEGER, PARAMETER :: PARAM_tr17_1 = 1 - INTEGER :: P_tr17_1 = 1 - LOGICAL :: F_tr17_1 = .FALSE. - INTEGER, PARAMETER :: PARAM_tr17_2 = 2 - INTEGER :: P_tr17_2 = 1 - LOGICAL :: F_tr17_2 = .FALSE. - INTEGER, PARAMETER :: PARAM_tr17_3 = 3 - INTEGER :: P_tr17_3 = 1 - LOGICAL :: F_tr17_3 = .FALSE. - INTEGER, PARAMETER :: PARAM_tr17_4 = 4 - INTEGER :: P_tr17_4 = 1 - LOGICAL :: F_tr17_4 = .FALSE. - INTEGER, PARAMETER :: PARAM_tr17_5 = 5 - INTEGER :: P_tr17_5 = 1 - LOGICAL :: F_tr17_5 = .FALSE. - INTEGER, PARAMETER :: PARAM_tr17_6 = 6 - INTEGER :: P_tr17_6 = 1 - LOGICAL :: F_tr17_6 = .FALSE. - INTEGER, PARAMETER :: PARAM_tr17_7 = 7 - INTEGER :: P_tr17_7 = 1 - LOGICAL :: F_tr17_7 = .FALSE. - INTEGER, PARAMETER :: PARAM_tr17_8 = 8 - INTEGER :: P_tr17_8 = 1 - LOGICAL :: F_tr17_8 = .FALSE. - INTEGER, PARAMETER :: PARAM_tr17_9 = 9 - INTEGER :: P_tr17_9 = 1 - LOGICAL :: F_tr17_9 = .FALSE. - INTEGER, PARAMETER :: PARAM_tr18_0 = 10 - INTEGER :: P_tr18_0 = 1 - LOGICAL :: F_tr18_0 = .FALSE. - INTEGER, PARAMETER :: PARAM_tr18_1 = 11 - INTEGER :: P_tr18_1 = 1 - LOGICAL :: F_tr18_1 = .FALSE. - INTEGER, PARAMETER :: PARAM_tr18_2 = 12 - INTEGER :: P_tr18_2 = 1 - LOGICAL :: F_tr18_2 = .FALSE. - INTEGER, PARAMETER :: PARAM_tr18_3 = 13 - INTEGER :: P_tr18_3 = 1 - LOGICAL :: F_tr18_3 = .FALSE. - INTEGER, PARAMETER :: PARAM_tr18_4 = 14 - INTEGER :: P_tr18_4 = 1 - LOGICAL :: F_tr18_4 = .FALSE. - INTEGER, PARAMETER :: PARAM_tr18_5 = 15 - INTEGER :: P_tr18_5 = 1 - LOGICAL :: F_tr18_5 = .FALSE. - INTEGER, PARAMETER :: PARAM_tr18_6 = 16 - INTEGER :: P_tr18_6 = 1 - LOGICAL :: F_tr18_6 = .FALSE. - INTEGER, PARAMETER :: PARAM_tr18_7 = 17 - INTEGER :: P_tr18_7 = 1 - LOGICAL :: F_tr18_7 = .FALSE. - INTEGER, PARAMETER :: PARAM_tr18_8 = 18 - INTEGER :: P_tr18_8 = 1 - LOGICAL :: F_tr18_8 = .FALSE. - INTEGER, PARAMETER :: PARAM_tr18_9 = 19 - INTEGER :: P_tr18_9 = 1 - LOGICAL :: F_tr18_9 = .FALSE. - INTEGER, PARAMETER :: PARAM_qni = 21 - INTEGER :: P_qni = 1 - LOGICAL :: F_qni = .FALSE. - INTEGER, PARAMETER :: PARAM_qndrop = 22 - INTEGER :: P_qndrop = 1 - LOGICAL :: F_qndrop = .FALSE. - INTEGER, PARAMETER :: PARAM_qt = 23 - INTEGER :: P_qt = 1 - LOGICAL :: F_qt = .FALSE. - INTEGER, PARAMETER :: PARAM_qns = 24 - INTEGER :: P_qns = 1 - LOGICAL :: F_qns = .FALSE. - INTEGER, PARAMETER :: PARAM_qnr = 25 - INTEGER :: P_qnr = 1 - LOGICAL :: F_qnr = .FALSE. - INTEGER, PARAMETER :: PARAM_qng = 26 - INTEGER :: P_qng = 1 - LOGICAL :: F_qng = .FALSE. - INTEGER, PARAMETER :: PARAM_qnn = 27 - INTEGER :: P_qnn = 1 - LOGICAL :: F_qnn = .FALSE. - INTEGER, PARAMETER :: PARAM_qnc = 28 - INTEGER :: P_qnc = 1 - LOGICAL :: F_qnc = .FALSE. - INTEGER, PARAMETER :: PARAM_NUM_scalar = 29 -!ggnum INTEGER :: NUM_scalar = 1 - INTEGER, PARAMETER :: PARAM_dfi_qndrop = 1 - INTEGER :: P_dfi_qndrop = 1 - LOGICAL :: F_dfi_qndrop = .FALSE. - INTEGER, PARAMETER :: PARAM_dfi_qni = 2 - INTEGER :: P_dfi_qni = 1 - LOGICAL :: F_dfi_qni = .FALSE. - INTEGER, PARAMETER :: PARAM_dfi_qt = 3 - INTEGER :: P_dfi_qt = 1 - LOGICAL :: F_dfi_qt = .FALSE. - INTEGER, PARAMETER :: PARAM_dfi_qns = 4 - INTEGER :: P_dfi_qns = 1 - LOGICAL :: F_dfi_qns = .FALSE. - INTEGER, PARAMETER :: PARAM_dfi_qnr = 5 - INTEGER :: P_dfi_qnr = 1 - LOGICAL :: F_dfi_qnr = .FALSE. - INTEGER, PARAMETER :: PARAM_dfi_qng = 6 - INTEGER :: P_dfi_qng = 1 - LOGICAL :: F_dfi_qng = .FALSE. - INTEGER, PARAMETER :: PARAM_dfi_qnn = 7 - INTEGER :: P_dfi_qnn = 1 - LOGICAL :: F_dfi_qnn = .FALSE. - INTEGER, PARAMETER :: PARAM_dfi_qnc = 8 - INTEGER :: P_dfi_qnc = 1 - LOGICAL :: F_dfi_qnc = .FALSE. - INTEGER, PARAMETER :: PARAM_NUM_dfi_scalar = 9 - INTEGER :: NUM_dfi_scalar = 1 - INTEGER, PARAMETER :: PARAM_mth01 = 1 - INTEGER :: P_mth01 = 1 - LOGICAL :: F_mth01 = .FALSE. - INTEGER, PARAMETER :: PARAM_mth02 = 2 - INTEGER :: P_mth02 = 1 - LOGICAL :: F_mth02 = .FALSE. - INTEGER, PARAMETER :: PARAM_mth03 = 3 - INTEGER :: P_mth03 = 1 - LOGICAL :: F_mth03 = .FALSE. - INTEGER, PARAMETER :: PARAM_mth04 = 4 - INTEGER :: P_mth04 = 1 - LOGICAL :: F_mth04 = .FALSE. - INTEGER, PARAMETER :: PARAM_mth05 = 5 - INTEGER :: P_mth05 = 1 - LOGICAL :: F_mth05 = .FALSE. - INTEGER, PARAMETER :: PARAM_mth06 = 6 - INTEGER :: P_mth06 = 1 - LOGICAL :: F_mth06 = .FALSE. - INTEGER, PARAMETER :: PARAM_mth07 = 7 - INTEGER :: P_mth07 = 1 - LOGICAL :: F_mth07 = .FALSE. - INTEGER, PARAMETER :: PARAM_mth08 = 8 - INTEGER :: P_mth08 = 1 - LOGICAL :: F_mth08 = .FALSE. - INTEGER, PARAMETER :: PARAM_mth09 = 9 - INTEGER :: P_mth09 = 1 - LOGICAL :: F_mth09 = .FALSE. - INTEGER, PARAMETER :: PARAM_mth10 = 10 - INTEGER :: P_mth10 = 1 - LOGICAL :: F_mth10 = .FALSE. - INTEGER, PARAMETER :: PARAM_mth11 = 11 - INTEGER :: P_mth11 = 1 - LOGICAL :: F_mth11 = .FALSE. - INTEGER, PARAMETER :: PARAM_mth12 = 12 - INTEGER :: P_mth12 = 1 - LOGICAL :: F_mth12 = .FALSE. - INTEGER, PARAMETER :: PARAM_NUM_ozmixm = 13 - INTEGER :: NUM_ozmixm = 1 - INTEGER, PARAMETER :: PARAM_sul = 1 - INTEGER :: P_sul = 1 - LOGICAL :: F_sul = .FALSE. - INTEGER, PARAMETER :: PARAM_sslt = 2 - INTEGER :: P_sslt = 1 - LOGICAL :: F_sslt = .FALSE. - INTEGER, PARAMETER :: PARAM_dust1 = 3 - INTEGER :: P_dust1 = 1 - LOGICAL :: F_dust1 = .FALSE. - INTEGER, PARAMETER :: PARAM_dust2 = 4 - INTEGER :: P_dust2 = 1 - LOGICAL :: F_dust2 = .FALSE. - INTEGER, PARAMETER :: PARAM_dust3 = 5 - INTEGER :: P_dust3 = 1 - LOGICAL :: F_dust3 = .FALSE. - INTEGER, PARAMETER :: PARAM_dust4 = 6 - INTEGER :: P_dust4 = 1 - LOGICAL :: F_dust4 = .FALSE. - INTEGER, PARAMETER :: PARAM_ocpho = 7 - INTEGER :: P_ocpho = 1 - LOGICAL :: F_ocpho = .FALSE. - INTEGER, PARAMETER :: PARAM_bcpho = 8 - INTEGER :: P_bcpho = 1 - LOGICAL :: F_bcpho = .FALSE. - INTEGER, PARAMETER :: PARAM_ocphi = 9 - INTEGER :: P_ocphi = 1 - LOGICAL :: F_ocphi = .FALSE. - INTEGER, PARAMETER :: PARAM_bcphi = 10 - INTEGER :: P_bcphi = 1 - LOGICAL :: F_bcphi = .FALSE. - INTEGER, PARAMETER :: PARAM_bg = 11 - INTEGER :: P_bg = 1 - LOGICAL :: F_bg = .FALSE. - INTEGER, PARAMETER :: PARAM_volc = 12 - INTEGER :: P_volc = 1 - LOGICAL :: F_volc = .FALSE. - INTEGER, PARAMETER :: PARAM_NUM_aerosolc = 13 - INTEGER :: NUM_aerosolc = 1 - INTEGER, PARAMETER :: PARAM_u_ndg_new = 1 - INTEGER :: P_u_ndg_new = 1 - LOGICAL :: F_u_ndg_new = .FALSE. - INTEGER, PARAMETER :: PARAM_v_ndg_new = 2 - INTEGER :: P_v_ndg_new = 1 - LOGICAL :: F_v_ndg_new = .FALSE. - INTEGER, PARAMETER :: PARAM_t_ndg_new = 3 - INTEGER :: P_t_ndg_new = 1 - LOGICAL :: F_t_ndg_new = .FALSE. - INTEGER, PARAMETER :: PARAM_q_ndg_new = 4 - INTEGER :: P_q_ndg_new = 1 - LOGICAL :: F_q_ndg_new = .FALSE. - INTEGER, PARAMETER :: PARAM_ph_ndg_new = 5 - INTEGER :: P_ph_ndg_new = 1 - LOGICAL :: F_ph_ndg_new = .FALSE. - INTEGER, PARAMETER :: PARAM_u_ndg_old = 6 - INTEGER :: P_u_ndg_old = 1 - LOGICAL :: F_u_ndg_old = .FALSE. - INTEGER, PARAMETER :: PARAM_v_ndg_old = 7 - INTEGER :: P_v_ndg_old = 1 - LOGICAL :: F_v_ndg_old = .FALSE. - INTEGER, PARAMETER :: PARAM_t_ndg_old = 8 - INTEGER :: P_t_ndg_old = 1 - LOGICAL :: F_t_ndg_old = .FALSE. - INTEGER, PARAMETER :: PARAM_q_ndg_old = 9 - INTEGER :: P_q_ndg_old = 1 - LOGICAL :: F_q_ndg_old = .FALSE. - INTEGER, PARAMETER :: PARAM_ph_ndg_old = 10 - INTEGER :: P_ph_ndg_old = 1 - LOGICAL :: F_ph_ndg_old = .FALSE. - INTEGER, PARAMETER :: PARAM_NUM_fdda3d = 11 - INTEGER :: NUM_fdda3d = 1 - INTEGER, PARAMETER :: PARAM_mu_ndg_new = 1 - INTEGER :: P_mu_ndg_new = 1 - LOGICAL :: F_mu_ndg_new = .FALSE. - INTEGER, PARAMETER :: PARAM_mu_ndg_old = 2 - INTEGER :: P_mu_ndg_old = 1 - LOGICAL :: F_mu_ndg_old = .FALSE. - INTEGER, PARAMETER :: PARAM_NUM_fdda2d = 3 - INTEGER :: NUM_fdda2d = 1 - INTEGER, PARAMETER :: P_XSB = 1 - INTEGER, PARAMETER :: P_XEB = 2 - INTEGER, PARAMETER :: P_YSB = 3 - INTEGER, PARAMETER :: P_YEB = 4 - INTEGER, PARAMETER :: NUM_TIME_LEVELS = 2 - INTEGER , PARAMETER :: PARAM_FIRST_SCALAR = 2 -!ENDOFREGISTRYGENERATEDINCLUDE -! That was all of state_description V3.1!!!!!! - TYPE grid_config_rec_type - SEQUENCE -!#include V3.1 - Mar10, 2009 !GG - -!STARTOFREGISTRYGENERATEDINCLUDE 'inc/namelist_defines2.inc' -! -! WARNING This file is generated automatically by use_registry -! using the data base in the file named Registry. -! Do not edit. Your changes to this file will be lost. -! -integer :: first_item_in_struct -character*256 :: emi_inname -character*256 :: fireemi_inname -character*256 :: input_chem_inname -character*256 :: emi_outname -character*256 :: fireemi_outname -character*256 :: input_chem_outname -integer :: frames_per_emissfile -integer :: frames_per_fireemissfile -integer :: io_style_emissions -integer :: io_form_emissions -integer :: io_style_fireemissions -integer :: io_form_fireemissions -real :: bioemdt -real :: photdt -real :: chemdt -integer :: ne_area -integer :: kemit -integer :: nmegan -integer :: kfuture -integer :: errosion_dim -integer :: biomass_emiss_opt -integer :: chem_conv_tr -integer :: chem_opt -integer :: gaschem_onoff -integer :: aerchem_onoff -integer :: wetscav_onoff -integer :: cldchem_onoff -integer :: vertmix_onoff -integer :: chem_in_opt -integer :: phot_opt -integer :: drydep_opt -integer :: emiss_opt -integer :: dust_opt -integer :: dmsemis_opt -integer :: seas_opt -integer :: bio_emiss_opt -integer :: biomass_burn_opt -integer :: plumerisefire_frq -integer :: emiss_inpt_opt -integer :: gas_bc_opt -integer :: gas_ic_opt -integer :: aer_bc_opt -integer :: aer_ic_opt -logical :: have_bcs_chem -integer :: aer_ra_feedback -integer :: aer_op_opt -integer :: scalar_opt -integer :: run_days -integer :: run_hours -integer :: run_minutes -integer :: run_seconds -integer :: start_year -integer :: start_month -integer :: start_day -integer :: start_hour -integer :: start_minute -integer :: start_second -integer :: end_year -integer :: end_month -integer :: end_day -integer :: end_hour -integer :: end_minute -integer :: end_second -integer :: interval_seconds -logical :: input_from_file -integer :: fine_input_stream -logical :: input_from_hires -character*256 :: rsmas_data_path -logical :: all_ic_times -integer :: history_interval -integer :: frames_per_outfile -integer :: frames_per_auxhist1 -integer :: frames_per_auxhist2 -integer :: frames_per_auxhist3 -integer :: frames_per_auxhist4 -integer :: frames_per_auxhist5 -integer :: frames_per_auxhist6 -integer :: frames_per_auxhist7 -integer :: frames_per_auxhist8 -integer :: frames_per_auxhist9 -integer :: frames_per_auxhist10 -integer :: frames_per_auxhist11 -logical :: restart -integer :: restart_interval -integer :: io_form_input -integer :: io_form_history -integer :: io_form_restart -integer :: io_form_boundary -integer :: debug_level -logical :: self_test_domain -character*256 :: history_outname -character*256 :: auxhist1_outname -character*256 :: auxhist2_outname -character*256 :: auxhist3_outname -character*256 :: auxhist4_outname -character*256 :: auxhist5_outname -character*256 :: auxhist6_outname -character*256 :: auxhist7_outname -character*256 :: auxhist8_outname -character*256 :: auxhist9_outname -character*256 :: auxhist10_outname -character*256 :: auxhist11_outname -character*256 :: history_inname -character*256 :: auxhist1_inname -character*256 :: auxhist2_inname -character*256 :: auxhist3_inname -character*256 :: auxhist4_inname -character*256 :: auxhist5_inname -character*256 :: auxhist6_inname -character*256 :: auxhist7_inname -character*256 :: auxhist8_inname -character*256 :: auxhist9_inname -character*256 :: auxhist10_inname -character*256 :: auxhist11_inname -character*256 :: auxinput1_outname -character*256 :: auxinput2_outname -character*256 :: auxinput3_outname -character*256 :: auxinput4_outname -character*256 :: auxinput5_outname -character*256 :: auxinput6_outname -character*256 :: auxinput7_outname -character*256 :: auxinput8_outname -character*256 :: auxinput9_outname -character*256 :: auxinput10_outname -character*256 :: auxinput11_outname -character*256 :: auxinput1_inname -character*256 :: auxinput2_inname -character*256 :: auxinput3_inname -character*256 :: auxinput4_inname -character*256 :: auxinput5_inname -character*256 :: auxinput6_inname -character*256 :: auxinput7_inname -character*256 :: auxinput8_inname -character*256 :: sgfdda_inname -character*256 :: gfdda_inname -character*256 :: auxinput11_inname -integer :: history_interval_mo -integer :: history_interval_d -integer :: history_interval_h -integer :: history_interval_m -integer :: history_interval_s -integer :: inputout_interval_mo -integer :: inputout_interval_d -integer :: inputout_interval_h -integer :: inputout_interval_m -integer :: inputout_interval_s -integer :: inputout_interval -integer :: auxhist1_interval_mo -integer :: auxhist1_interval_d -integer :: auxhist1_interval_h -integer :: auxhist1_interval_m -integer :: auxhist1_interval_s -integer :: auxhist1_interval -integer :: auxhist2_interval_mo -integer :: auxhist2_interval_d -integer :: auxhist2_interval_h -integer :: auxhist2_interval_m -integer :: auxhist2_interval_s -integer :: auxhist2_interval -integer :: auxhist3_interval_mo -integer :: auxhist3_interval_d -integer :: auxhist3_interval_h -integer :: auxhist3_interval_m -integer :: auxhist3_interval_s -integer :: auxhist3_interval -integer :: auxhist4_interval_mo -integer :: auxhist4_interval_d -integer :: auxhist4_interval_h -integer :: auxhist4_interval_m -integer :: auxhist4_interval_s -integer :: auxhist4_interval -integer :: auxhist5_interval_mo -integer :: auxhist5_interval_d -integer :: auxhist5_interval_h -integer :: auxhist5_interval_m -integer :: auxhist5_interval_s -integer :: auxhist5_interval -integer :: auxhist6_interval_mo -integer :: auxhist6_interval_d -integer :: auxhist6_interval_h -integer :: auxhist6_interval_m -integer :: auxhist6_interval_s -integer :: auxhist6_interval -integer :: auxhist7_interval_mo -integer :: auxhist7_interval_d -integer :: auxhist7_interval_h -integer :: auxhist7_interval_m -integer :: auxhist7_interval_s -integer :: auxhist7_interval -integer :: auxhist8_interval_mo -integer :: auxhist8_interval_d -integer :: auxhist8_interval_h -integer :: auxhist8_interval_m -integer :: auxhist8_interval_s -integer :: auxhist8_interval -integer :: auxhist9_interval_mo -integer :: auxhist9_interval_d -integer :: auxhist9_interval_h -integer :: auxhist9_interval_m -integer :: auxhist9_interval_s -integer :: auxhist9_interval -integer :: auxhist10_interval_mo -integer :: auxhist10_interval_d -integer :: auxhist10_interval_h -integer :: auxhist10_interval_m -integer :: auxhist10_interval_s -integer :: auxhist10_interval -integer :: auxhist11_interval_mo -integer :: auxhist11_interval_d -integer :: auxhist11_interval_h -integer :: auxhist11_interval_m -integer :: auxhist11_interval_s -integer :: auxhist11_interval -integer :: auxinput1_interval_mo -integer :: auxinput1_interval_d -integer :: auxinput1_interval_h -integer :: auxinput1_interval_m -integer :: auxinput1_interval_s -integer :: auxinput1_interval -integer :: auxinput2_interval_mo -integer :: auxinput2_interval_d -integer :: auxinput2_interval_h -integer :: auxinput2_interval_m -integer :: auxinput2_interval_s -integer :: auxinput2_interval -integer :: auxinput3_interval_mo -integer :: auxinput3_interval_d -integer :: auxinput3_interval_h -integer :: auxinput3_interval_m -integer :: auxinput3_interval_s -integer :: auxinput3_interval -integer :: auxinput4_interval_mo -integer :: auxinput4_interval_d -integer :: auxinput4_interval_h -integer :: auxinput4_interval_m -integer :: auxinput4_interval_s -integer :: auxinput4_interval -integer :: auxinput5_interval_mo -integer :: auxinput5_interval_d -integer :: auxinput5_interval_h -integer :: auxinput5_interval_m -integer :: auxinput5_interval_s -integer :: auxinput5_interval -integer :: auxinput6_interval_mo -integer :: auxinput6_interval_d -integer :: auxinput6_interval_h -integer :: auxinput6_interval_m -integer :: auxinput6_interval_s -integer :: auxinput6_interval -integer :: auxinput7_interval_mo -integer :: auxinput7_interval_d -integer :: auxinput7_interval_h -integer :: auxinput7_interval_m -integer :: auxinput7_interval_s -integer :: auxinput7_interval -integer :: auxinput8_interval_mo -integer :: auxinput8_interval_d -integer :: auxinput8_interval_h -integer :: auxinput8_interval_m -integer :: auxinput8_interval_s -integer :: auxinput8_interval -integer :: sgfdda_interval_mo -integer :: sgfdda_interval_d -integer :: sgfdda_interval_h -integer :: sgfdda_interval_m -integer :: sgfdda_interval_s -integer :: sgfdda_interval -integer :: gfdda_interval_mo -integer :: gfdda_interval_d -integer :: gfdda_interval_h -integer :: gfdda_interval_m -integer :: gfdda_interval_s -integer :: gfdda_interval -integer :: auxinput11_interval_mo -integer :: auxinput11_interval_d -integer :: auxinput11_interval_h -integer :: auxinput11_interval_m -integer :: auxinput11_interval_s -integer :: auxinput11_interval -integer :: restart_interval_mo -integer :: restart_interval_d -integer :: restart_interval_h -integer :: restart_interval_m -integer :: restart_interval_s -integer :: history_begin_y -integer :: history_begin_mo -integer :: history_begin_d -integer :: history_begin_h -integer :: history_begin_m -integer :: history_begin_s -integer :: inputout_begin_y -integer :: inputout_begin_mo -integer :: inputout_begin_d -integer :: inputout_begin_h -integer :: inputout_begin_m -integer :: inputout_begin_s -integer :: auxhist1_begin_y -integer :: auxhist1_begin_mo -integer :: auxhist1_begin_d -integer :: auxhist1_begin_h -integer :: auxhist1_begin_m -integer :: auxhist1_begin_s -integer :: auxhist2_begin_y -integer :: auxhist2_begin_mo -integer :: auxhist2_begin_d -integer :: auxhist2_begin_h -integer :: auxhist2_begin_m -integer :: auxhist2_begin_s -integer :: auxhist3_begin_y -integer :: auxhist3_begin_mo -integer :: auxhist3_begin_d -integer :: auxhist3_begin_h -integer :: auxhist3_begin_m -integer :: auxhist3_begin_s -integer :: auxhist4_begin_y -integer :: auxhist4_begin_mo -integer :: auxhist4_begin_d -integer :: auxhist4_begin_h -integer :: auxhist4_begin_m -integer :: auxhist4_begin_s -integer :: auxhist5_begin_y -integer :: auxhist5_begin_mo -integer :: auxhist5_begin_d -integer :: auxhist5_begin_h -integer :: auxhist5_begin_m -integer :: auxhist5_begin_s -integer :: auxhist6_begin_y -integer :: auxhist6_begin_mo -integer :: auxhist6_begin_d -integer :: auxhist6_begin_h -integer :: auxhist6_begin_m -integer :: auxhist6_begin_s -integer :: auxhist7_begin_y -integer :: auxhist7_begin_mo -integer :: auxhist7_begin_d -integer :: auxhist7_begin_h -integer :: auxhist7_begin_m -integer :: auxhist7_begin_s -integer :: auxhist8_begin_y -integer :: auxhist8_begin_mo -integer :: auxhist8_begin_d -integer :: auxhist8_begin_h -integer :: auxhist8_begin_m -integer :: auxhist8_begin_s -integer :: auxhist9_begin_y -integer :: auxhist9_begin_mo -integer :: auxhist9_begin_d -integer :: auxhist9_begin_h -integer :: auxhist9_begin_m -integer :: auxhist9_begin_s -integer :: auxhist10_begin_y -integer :: auxhist10_begin_mo -integer :: auxhist10_begin_d -integer :: auxhist10_begin_h -integer :: auxhist10_begin_m -integer :: auxhist10_begin_s -integer :: auxhist11_begin_y -integer :: auxhist11_begin_mo -integer :: auxhist11_begin_d -integer :: auxhist11_begin_h -integer :: auxhist11_begin_m -integer :: auxhist11_begin_s -integer :: auxinput1_begin_y -integer :: auxinput1_begin_mo -integer :: auxinput1_begin_d -integer :: auxinput1_begin_h -integer :: auxinput1_begin_m -integer :: auxinput1_begin_s -integer :: auxinput2_begin_y -integer :: auxinput2_begin_mo -integer :: auxinput2_begin_d -integer :: auxinput2_begin_h -integer :: auxinput2_begin_m -integer :: auxinput2_begin_s -integer :: auxinput3_begin_y -integer :: auxinput3_begin_mo -integer :: auxinput3_begin_d -integer :: auxinput3_begin_h -integer :: auxinput3_begin_m -integer :: auxinput3_begin_s -integer :: auxinput4_begin_y -integer :: auxinput4_begin_mo -integer :: auxinput4_begin_d -integer :: auxinput4_begin_h -integer :: auxinput4_begin_m -integer :: auxinput4_begin_s -integer :: auxinput5_begin_y -integer :: auxinput5_begin_mo -integer :: auxinput5_begin_d -integer :: auxinput5_begin_h -integer :: auxinput5_begin_m -integer :: auxinput5_begin_s -integer :: auxinput6_begin_y -integer :: auxinput6_begin_mo -integer :: auxinput6_begin_d -integer :: auxinput6_begin_h -integer :: auxinput6_begin_m -integer :: auxinput6_begin_s -integer :: auxinput7_begin_y -integer :: auxinput7_begin_mo -integer :: auxinput7_begin_d -integer :: auxinput7_begin_h -integer :: auxinput7_begin_m -integer :: auxinput7_begin_s -integer :: auxinput8_begin_y -integer :: auxinput8_begin_mo -integer :: auxinput8_begin_d -integer :: auxinput8_begin_h -integer :: auxinput8_begin_m -integer :: auxinput8_begin_s -integer :: sgfdda_begin_y -integer :: sgfdda_begin_mo -integer :: sgfdda_begin_d -integer :: sgfdda_begin_h -integer :: sgfdda_begin_m -integer :: sgfdda_begin_s -integer :: gfdda_begin_y -integer :: gfdda_begin_mo -integer :: gfdda_begin_d -integer :: gfdda_begin_h -integer :: gfdda_begin_m -integer :: gfdda_begin_s -integer :: auxinput11_begin_y -integer :: auxinput11_begin_mo -integer :: auxinput11_begin_d -integer :: auxinput11_begin_h -integer :: auxinput11_begin_m -integer :: auxinput11_begin_s -integer :: restart_begin_y -integer :: restart_begin_mo -integer :: restart_begin_d -integer :: restart_begin_h -integer :: restart_begin_m -integer :: restart_begin_s -integer :: history_end_y -integer :: history_end_mo -integer :: history_end_d -integer :: history_end_h -integer :: history_end_m -integer :: history_end_s -integer :: inputout_end_y -integer :: inputout_end_mo -integer :: inputout_end_d -integer :: inputout_end_h -integer :: inputout_end_m -integer :: inputout_end_s -integer :: auxhist1_end_y -integer :: auxhist1_end_mo -integer :: auxhist1_end_d -integer :: auxhist1_end_h -integer :: auxhist1_end_m -integer :: auxhist1_end_s -integer :: auxhist2_end_y -integer :: auxhist2_end_mo -integer :: auxhist2_end_d -integer :: auxhist2_end_h -integer :: auxhist2_end_m -integer :: auxhist2_end_s -integer :: auxhist3_end_y -integer :: auxhist3_end_mo -integer :: auxhist3_end_d -integer :: auxhist3_end_h -integer :: auxhist3_end_m -integer :: auxhist3_end_s -integer :: auxhist4_end_y -integer :: auxhist4_end_mo -integer :: auxhist4_end_d -integer :: auxhist4_end_h -integer :: auxhist4_end_m -integer :: auxhist4_end_s -integer :: auxhist5_end_y -integer :: auxhist5_end_mo -integer :: auxhist5_end_d -integer :: auxhist5_end_h -integer :: auxhist5_end_m -integer :: auxhist5_end_s -integer :: auxhist6_end_y -integer :: auxhist6_end_mo -integer :: auxhist6_end_d -integer :: auxhist6_end_h -integer :: auxhist6_end_m -integer :: auxhist6_end_s -integer :: auxhist7_end_y -integer :: auxhist7_end_mo -integer :: auxhist7_end_d -integer :: auxhist7_end_h -integer :: auxhist7_end_m -integer :: auxhist7_end_s -integer :: auxhist8_end_y -integer :: auxhist8_end_mo -integer :: auxhist8_end_d -integer :: auxhist8_end_h -integer :: auxhist8_end_m -integer :: auxhist8_end_s -integer :: auxhist9_end_y -integer :: auxhist9_end_mo -integer :: auxhist9_end_d -integer :: auxhist9_end_h -integer :: auxhist9_end_m -integer :: auxhist9_end_s -integer :: auxhist10_end_y -integer :: auxhist10_end_mo -integer :: auxhist10_end_d -integer :: auxhist10_end_h -integer :: auxhist10_end_m -integer :: auxhist10_end_s -integer :: auxhist11_end_y -integer :: auxhist11_end_mo -integer :: auxhist11_end_d -integer :: auxhist11_end_h -integer :: auxhist11_end_m -integer :: auxhist11_end_s -integer :: auxinput1_end_y -integer :: auxinput1_end_mo -integer :: auxinput1_end_d -integer :: auxinput1_end_h -integer :: auxinput1_end_m -integer :: auxinput1_end_s -integer :: auxinput2_end_y -integer :: auxinput2_end_mo -integer :: auxinput2_end_d -integer :: auxinput2_end_h -integer :: auxinput2_end_m -integer :: auxinput2_end_s -integer :: auxinput3_end_y -integer :: auxinput3_end_mo -integer :: auxinput3_end_d -integer :: auxinput3_end_h -integer :: auxinput3_end_m -integer :: auxinput3_end_s -integer :: auxinput4_end_y -integer :: auxinput4_end_mo -integer :: auxinput4_end_d -integer :: auxinput4_end_h -integer :: auxinput4_end_m -integer :: auxinput4_end_s -integer :: auxinput5_end_y -integer :: auxinput5_end_mo -integer :: auxinput5_end_d -integer :: auxinput5_end_h -integer :: auxinput5_end_m -integer :: auxinput5_end_s -integer :: auxinput6_end_y -integer :: auxinput6_end_mo -integer :: auxinput6_end_d -integer :: auxinput6_end_h -integer :: auxinput6_end_m -integer :: auxinput6_end_s -integer :: auxinput7_end_y -integer :: auxinput7_end_mo -integer :: auxinput7_end_d -integer :: auxinput7_end_h -integer :: auxinput7_end_m -integer :: auxinput7_end_s -integer :: auxinput8_end_y -integer :: auxinput8_end_mo -integer :: auxinput8_end_d -integer :: auxinput8_end_h -integer :: auxinput8_end_m -integer :: auxinput8_end_s -integer :: sgfdda_end_y -integer :: sgfdda_end_mo -integer :: sgfdda_end_d -integer :: sgfdda_end_h -integer :: sgfdda_end_m -integer :: sgfdda_end_s -integer :: gfdda_end_y -integer :: gfdda_end_mo -integer :: gfdda_end_d -integer :: gfdda_end_h -integer :: gfdda_end_m -integer :: gfdda_end_s -integer :: auxinput11_end_y -integer :: auxinput11_end_mo -integer :: auxinput11_end_d -integer :: auxinput11_end_h -integer :: auxinput11_end_m -integer :: auxinput11_end_s -integer :: io_form_auxinput1 -integer :: io_form_auxinput2 -integer :: io_form_auxinput3 -integer :: io_form_auxinput4 -integer :: io_form_auxinput5 -integer :: io_form_auxinput6 -integer :: io_form_auxinput7 -integer :: io_form_auxinput8 -integer :: io_form_sgfdda -integer :: io_form_gfdda -integer :: io_form_auxinput11 -integer :: io_form_auxhist1 -integer :: io_form_auxhist2 -integer :: io_form_auxhist3 -integer :: io_form_auxhist4 -integer :: io_form_auxhist5 -integer :: io_form_auxhist6 -integer :: io_form_auxhist7 -integer :: io_form_auxhist8 -integer :: io_form_auxhist9 -integer :: io_form_auxhist10 -integer :: io_form_auxhist11 -integer :: simulation_start_year -integer :: simulation_start_month -integer :: simulation_start_day -integer :: simulation_start_hour -integer :: simulation_start_minute -integer :: simulation_start_second -logical :: reset_simulation_start -integer :: sr_x -integer :: sr_y -integer :: julyr -integer :: julday -real :: gmt -character*256 :: input_inname -character*256 :: input_outname -character*256 :: bdy_inname -character*256 :: bdy_outname -character*256 :: rst_inname -character*256 :: rst_outname -logical :: write_input -logical :: write_restart_at_0h -logical :: adjust_output_times -logical :: adjust_input_times -integer :: diag_print -logical :: nocolons -integer :: dfi_opt -integer :: dfi_nfilter -logical :: dfi_write_filtered_input -logical :: dfi_write_dfi_history -integer :: dfi_cutoff_seconds -integer :: dfi_time_dim -integer :: dfi_fwdstop_year -integer :: dfi_fwdstop_month -integer :: dfi_fwdstop_day -integer :: dfi_fwdstop_hour -integer :: dfi_fwdstop_minute -integer :: dfi_fwdstop_second -integer :: dfi_bckstop_year -integer :: dfi_bckstop_month -integer :: dfi_bckstop_day -integer :: dfi_bckstop_hour -integer :: dfi_bckstop_minute -integer :: dfi_bckstop_second -integer :: time_step -integer :: time_step_fract_num -integer :: time_step_fract_den -integer :: min_time_step -integer :: max_time_step -real :: target_cfl -integer :: max_step_increase_pct -integer :: starting_time_step -logical :: step_to_output_time -logical :: use_adaptive_time_step -integer :: max_dom -integer :: s_we -integer :: e_we -integer :: s_sn -integer :: e_sn -integer :: s_vert -integer :: e_vert -integer :: num_metgrid_levels -integer :: num_soil_layers_in -real :: p_top_requested -integer :: interp_type -integer :: extrap_type -integer :: t_extrap_type -logical :: lowest_lev_from_sfc -logical :: use_levels_below_ground -logical :: use_surface -integer :: lagrange_order -integer :: force_sfc_in_vinterp -real :: zap_close_levels -logical :: sfcp_to_sfcp -logical :: adjust_heights -logical :: smooth_cg_topo -logical :: rh2qv_wrt_liquid -real :: dx -real :: dy -integer :: grid_id -logical :: grid_allowed -integer :: parent_id -integer :: i_parent_start -integer :: j_parent_start -integer :: parent_grid_ratio -integer :: parent_time_step_ratio -integer :: feedback -integer :: smooth_option -integer :: blend_width -real :: ztop -integer :: moad_grid_ratio -integer :: moad_time_step_ratio -integer :: shw -integer :: tile_sz_x -integer :: tile_sz_y -integer :: numtiles -integer :: nproc_x -integer :: nproc_y -integer :: irand -integer :: num_moves -integer :: ts_buf_size -integer :: max_ts_locs -integer :: vortex_interval -integer :: max_vortex_speed -integer :: corral_dist -integer :: track_level -integer :: move_id -integer :: move_interval -integer :: move_cd_x -integer :: move_cd_y -logical :: swap_x -logical :: swap_y -logical :: cycle_x -logical :: cycle_y -logical :: reorder_mesh -logical :: perturb_input -real :: eta_levels -real :: max_dz -logical :: insert_bogus_storm -integer :: num_storm -real :: latc_loc -real :: lonc_loc -real :: vmax_meters_per_second -real :: rmax -real :: vmax_ratio -integer :: mp_physics -integer :: gsfcgce_hail -integer :: gsfcgce_2ice -integer :: progn -integer :: ra_lw_physics -integer :: ra_sw_physics -real :: radt -real :: naer -integer :: sf_sfclay_physics -integer :: sf_surface_physics -integer :: bl_pbl_physics -integer :: sf_urban_physics -real :: bldt -integer :: cu_physics -real :: cudt -real :: gsmdt -integer :: isfflx -integer :: ifsnow -integer :: icloud -real :: swrad_scat -integer :: surface_input_source -!TBH: avoid conflict with declaration in module_control -!TBH integer :: num_soil_layers -integer :: num_urban_layers -integer :: num_months -integer :: maxiens -integer :: maxens -integer :: maxens2 -integer :: maxens3 -integer :: ensdim -integer :: cugd_avedx -integer :: imomentum -integer :: clos_choice -integer :: num_land_cat -integer :: num_soil_cat -integer :: mp_zero_out -real :: mp_zero_out_thresh -real :: seaice_threshold -integer :: sst_update -integer :: sst_skin -integer :: tmn_update -logical :: usemonalb -logical :: rdmaxalb -logical :: rdlai2d -integer :: co2tf -integer :: ra_call_offset -real :: cam_abs_freq_s -integer :: levsiz -integer :: paerlev -integer :: cam_abs_dim1 -integer :: cam_abs_dim2 -integer :: lagday -logical :: cu_rad_feedback -integer :: pxlsm_smois_init -integer :: omlcall -real :: oml_hml0 -real :: oml_gamma -integer :: isftcflx -real :: shadlen -integer :: slope_rad -integer :: topo_shading -integer :: no_mp_heating -integer :: fractional_seaice -real :: bucket_mm -real :: bucket_j -integer :: grav_settling -real :: fgdt -integer :: fgdtzero -integer :: grid_fdda -integer :: grid_sfdda -integer :: if_no_pbl_nudging_uv -integer :: if_no_pbl_nudging_t -integer :: if_no_pbl_nudging_ph -integer :: if_no_pbl_nudging_q -integer :: if_zfac_uv -integer :: k_zfac_uv -integer :: if_zfac_t -integer :: k_zfac_t -integer :: if_zfac_ph -integer :: k_zfac_ph -integer :: if_zfac_q -integer :: k_zfac_q -integer :: dk_zfac_uv -integer :: dk_zfac_t -integer :: dk_zfac_ph -real :: guv -real :: guv_sfc -real :: gt -real :: gt_sfc -real :: gq -real :: gq_sfc -real :: gph -real :: dtramp_min -integer :: if_ramping -real :: rinblw -integer :: xwavenum -integer :: ywavenum -integer :: obs_nudge_opt -integer :: max_obs -real :: fdda_start -real :: fdda_end -integer :: obs_nudge_wind -real :: obs_coef_wind -integer :: obs_nudge_temp -real :: obs_coef_temp -integer :: obs_nudge_mois -real :: obs_coef_mois -integer :: obs_nudge_pstr -real :: obs_coef_pstr -real :: obs_rinxy -real :: obs_rinsig -real :: obs_twindo -integer :: obs_npfi -integer :: obs_ionf -integer :: obs_idynin -real :: obs_dtramp -integer :: obs_prt_max -integer :: obs_prt_freq -logical :: obs_ipf_in4dob -logical :: obs_ipf_errob -logical :: obs_ipf_nudob -logical :: obs_ipf_init -integer :: scm_force -real :: scm_force_dx -integer :: num_force_layers -integer :: scm_lu_index -integer :: scm_isltyp -real :: scm_vegfra -integer :: scm_canwat -real :: scm_lat -real :: scm_lon -logical :: scm_th_adv -logical :: scm_wind_adv -logical :: scm_qv_adv -logical :: scm_vert_adv -integer :: rk_ord -integer :: w_damping -integer :: diff_opt -integer :: km_opt -integer :: km_opt_dfi -integer :: damp_opt -integer :: gwd_opt -real :: zdamp -real :: dampcoef -real :: khdif -real :: kvdif -real :: diff_6th_factor -integer :: diff_6th_opt -real :: c_s -real :: c_k -real :: smdiv -real :: emdiv -real :: epssm -logical :: non_hydrostatic -integer :: time_step_sound -integer :: h_mom_adv_order -integer :: v_mom_adv_order -integer :: h_sca_adv_order -integer :: v_sca_adv_order -integer :: moist_adv_opt -integer :: moist_adv_dfi_opt -integer :: chem_adv_opt -integer :: scalar_adv_opt -integer :: tke_adv_opt -logical :: top_radiation -integer :: mix_isotropic -real :: mix_upper_bound -logical :: top_lid -real :: tke_upper_bound -real :: tke_drag_coefficient -real :: tke_heat_flux -logical :: pert_coriolis -logical :: coriolis2d -logical :: mix_full_fields -real :: base_pres -real :: base_temp -real :: base_lapse -real :: iso_temp -real :: fft_filter_lat -logical :: rotated_pole -logical :: do_coriolis -logical :: do_curvature -logical :: do_gradp -integer :: spec_bdy_width -integer :: spec_zone -integer :: relax_zone -logical :: specified -logical :: periodic_x -logical :: symmetric_xs -logical :: symmetric_xe -logical :: open_xs -logical :: open_xe -logical :: periodic_y -logical :: symmetric_ys -logical :: symmetric_ye -logical :: open_ys -logical :: open_ye -logical :: polar -logical :: nested -real :: spec_exp -integer :: real_data_init_type -integer :: background_proc_id -integer :: forecast_proc_id -integer :: production_status -integer :: compression -integer :: nobs_ndg_vars -integer :: nobs_err_flds -real :: cen_lat -real :: cen_lon -real :: truelat1 -real :: truelat2 -real :: moad_cen_lat -real :: stand_lon -real :: bdyfrq -character*256 :: mminlu -real :: emifrq -integer :: iswater -integer :: islake -integer :: isice -integer :: isurban -integer :: isoilwater -integer :: map_proj -integer :: use_wps_input -integer :: dfi_stage -integer :: mp_physics_dfi -integer :: ifire -integer :: fire_boundary_guard -integer :: fire_num_ignitions -real :: fire_ignition_start_long1 -real :: fire_ignition_start_lat1 -real :: fire_ignition_end_long1 -real :: fire_ignition_end_lat1 -real :: fire_ignition_radius1 -real :: fire_ignition_time1 -real :: fire_ignition_start_long2 -real :: fire_ignition_start_lat2 -real :: fire_ignition_end_long2 -real :: fire_ignition_end_lat2 -real :: fire_ignition_radius2 -real :: fire_ignition_time2 -real :: fire_ignition_start_long3 -real :: fire_ignition_start_lat3 -real :: fire_ignition_end_long3 -real :: fire_ignition_end_lat3 -real :: fire_ignition_radius3 -real :: fire_ignition_time3 -real :: fire_ignition_start_long4 -real :: fire_ignition_start_lat4 -real :: fire_ignition_end_long4 -real :: fire_ignition_end_lat4 -real :: fire_ignition_radius4 -real :: fire_ignition_time4 -real :: fire_ignition_start_long5 -real :: fire_ignition_start_lat5 -real :: fire_ignition_end_long5 -real :: fire_ignition_end_lat5 -real :: fire_ignition_radius5 -real :: fire_ignition_time5 -real :: fire_ignition_start_x1 -real :: fire_ignition_start_y1 -real :: fire_ignition_end_x1 -real :: fire_ignition_end_y1 -real :: fire_ignition_start_x2 -real :: fire_ignition_start_y2 -real :: fire_ignition_end_x2 -real :: fire_ignition_end_y2 -real :: fire_ignition_start_x3 -real :: fire_ignition_start_y3 -real :: fire_ignition_end_x3 -real :: fire_ignition_end_y3 -real :: fire_ignition_start_x4 -real :: fire_ignition_start_y4 -real :: fire_ignition_end_x4 -real :: fire_ignition_end_y4 -real :: fire_ignition_start_x5 -real :: fire_ignition_start_y5 -real :: fire_ignition_end_x5 -real :: fire_ignition_end_y5 -real :: fire_lat_init -real :: fire_lon_init -real :: fire_ign_time -integer :: fire_shape -integer :: fire_sprd_mdl -real :: fire_crwn_hgt -real :: fire_ext_grnd -real :: fire_ext_crwn -integer :: fire_fuel_read -integer :: fire_fuel_cat -integer :: fire_print_msg -integer :: fire_print_file -integer :: fire_fuel_left_method -integer :: fire_fuel_left_irl -integer :: fire_fuel_left_jrl -real :: fire_atm_feedback -real :: fire_back_weight -integer :: fire_grows_only -integer :: fire_upwinding -integer :: fire_upwind_split -real :: fire_viscosity -real :: fire_lfn_ext_up -integer :: fire_test_steps -integer :: fire_topo_from_atm -integer :: last_item_in_struct -real :: ash_height -real :: ash_mass -real :: tr_height -real :: tr_mass -!ENDOFREGISTRYGENERATEDINCLUDE - END TYPE grid_config_rec_type -! -!ENDOFREGISTRYGENERATEDINCLUDE -!TBH: HACK FOR SMS -- put NAMELIST definition on one line -NAMELIST /chemwrf/ emi_inname,fireemi_inname,emi_outname,fireemi_outname,input_chem_inname, & - input_chem_outname,frames_per_emissfile,frames_per_fireemissfile, & - io_style_emissions,io_form_emissions,bioemdt,photdt,chemdt,ne_area,kemit, & - nmegan,kfuture,errosion_dim,chem_conv_tr,chem_opt,gaschem_onoff, & - aerchem_onoff,wetscav_onoff,cldchem_onoff,vertmix_onoff,chem_in_opt, & - phot_opt,drydep_opt,emiss_opt,dust_opt,dmsemis_opt,seas_opt,bio_emiss_opt,& - biomass_burn_opt,plumerisefire_frq,emiss_inpt_opt,gas_bc_opt,gas_ic_opt, & - aer_bc_opt,aer_ic_opt,have_bcs_chem,aer_ra_feedback,aer_op_opt, & - ash_height,ash_mass, tr_height, tr_mass -NAMELIST /wrfphysics/mp_physics,gsfcgce_hail,gsfcgce_2ice,progn,ra_lw_physics,ra_sw_physics, & - naer,sf_sfclay_physics,sf_surface_physics,bl_pbl_physics,sf_urban_physics, & - cu_physics,num_urban_layers,cugd_avedx,imomentum, & - clos_choice,num_land_cat,num_soil_cat,mp_zero_out,mp_zero_out_thresh, & - seaice_threshold,cu_rad_feedback,slope_rad,topo_shading,topo_shading - - type (grid_config_rec_type) config_flags - -END MODULE module_initial_chem_namelists diff --git a/src/fim/FIMsrc/utils/read_queue_namelist.F90 b/src/fim/FIMsrc/utils/read_queue_namelist.F90 deleted file mode 100644 index 7bcdc56..0000000 --- a/src/fim/FIMsrc/utils/read_queue_namelist.F90 +++ /dev/null @@ -1,172 +0,0 @@ -module read_queue_namelist - - use module_initial_chem_namelists - implicit none - save - - character(8) :: ComputeTasks = '10' ! Number of compute tasks for FIM; 'S' means Serial - character(8) :: MaxQueueTime = '00:05:00' ! Run time for the complete job (HH:MM:SS) - character(160) :: SRCDIR = '../FIMsrc' ! Location of the FIM source - character(160) :: PREPDIR = 'nodir' ! If exists, use for prep otherwise calculate prep - character(160) :: FIMDIR = 'nodir' ! If exists, use for FIM otherwise calculate FIM -!JR Changed paths to something non-existent, so namelist value is always used - character(160) :: DATADIR = '/no_such_path' ! Location of gfsltln and global_mtnvar files - character(160) :: DATADR2 = '/no_such_path' ! Location of the sanl file and the sfcanl file - character(160) :: chem_datadir = '/no_such_path' ! Location of the chemistry data files - integer :: glvl ! The grid level defined in the Makefile - integer :: SubdivNum(20) ! Subdivision numbers for each recursive refinement(2: bisection, 3: trisection, etc.) - integer :: nvl ! Number of vertical native levels - -contains - - subroutine ReadQUEUEnamelist - integer::ierr - logical,save::alreadyReadNamelists = .false. - namelist /QUEUEnamelist/ ComputeTasks,MaxQueueTime,SRCDIR,PREPDIR,FIMDIR,DATADIR,DATADR2,chem_datadir - namelist /CNTLnamelist/ glvl, SubdivNum, nvl -! TODO: Remove duplicate namelist declarations via use of include -! TODO: or use association. Or, better yet, just call FIM routines... -! Note: REWIND required by IBM! -! TODO: Using open-read-close in place of REWIND until SMS is updated -!JR add status and action to ensure 0-byte file doesn't get created by accident! - if (.not.alreadyReadNamelists) then - OPEN (10,file="FIMnamelist",status='old',action='read',iostat=ierr) - if (ierr.ne.0) then - write (0,'(a)') 'ERROR: Could not open FIMnamelist for read.' - stop - endif - READ (10,NML=QUEUEnamelist,iostat=ierr) - if (ierr.ne.0) then - write (0,'(a)') 'ERROR: Could not read QUEUEnamelist namelist.' - stop - endif - CLOSE(10) - OPEN (10,file="FIMnamelist",status='old',action='read',iostat=ierr) - if (ierr.ne.0) then - write (0,'(a)') 'ERROR: Could not open FIMnamelist for read.' - stop - endif - READ (10,NML=CNTLnamelist,iostat=ierr) - if (ierr.ne.0) then - write (0,'(a)') 'ERROR: Could not read CNTLnamelist namelist.' - stop - endif - CLOSE(10) - OPEN (10,file="FIMnamelist",status='old',action='read',iostat=ierr) - if (ierr.ne.0) then - write (0,'(a)') 'ERROR: Could not open FIMnamelist for read.' - stop - endif - READ (10,NML=chemwrf,iostat=ierr) - if (ierr.ne.0) then - write (0,'(a)') 'NOTE: chemwrf namelist not read, continuing with chemistry disabled...' - endif - CLOSE(10) - OPEN (10,file="FIMnamelist",status='old',action='read',iostat=ierr) - if (ierr.ne.0) then - write (0,'(a)') 'ERROR: Could not open FIMnamelist for read.' - stop - endif - READ (10,NML=wrfphysics,iostat=ierr) - if (ierr.ne.0) then - write (0,'(a)') 'NOTE: wrfphysics namelist not read, continuing...' - endif - close(10) - alreadyReadNamelists = .true. - endif - end subroutine ReadQUEUEnamelist - - subroutine GetNprocs (nprocs) - integer,intent(OUT) :: nprocs - call ReadQUEUEnamelist - if(ComputeTasks=='S'.or.ComputeTasks=='s') then - nprocs=1 - else - read(ComputeTasks,*) nprocs - endif - end subroutine GetNprocs - - subroutine GetMaxQueueTime (QueueTime) - character(8),intent(OUT) :: QueueTime - call ReadQUEUEnamelist - QueueTime = MaxQueueTime - end subroutine GetMaxQueueTime - - subroutine ReturnGLVL (glvlout) - integer,intent(OUT) :: glvlout - call ReadQUEUEnamelist - glvlout = glvl - end subroutine ReturnGLVL - - subroutine ReturnNIP (nipout) - integer,intent(OUT) :: nipout - integer i - call ReadQUEUEnamelist - nipout = 1 - do i = 1, glvl - nipout = nipout * SubdivNum(i) - enddo - nipout = 10 * nipout * nipout + 2 - end subroutine ReturnNIP - - subroutine ReturnSubdivNum(SubdivNumout) - integer,intent(OUT) :: SubdivNumout(20) - integer i - call ReadQUEUEnamelist - SubdivNumout = 0 - do i = 1, glvl - SubdivNumout(i) = SubdivNum(i) - enddo - end subroutine ReturnSubdivNum - - subroutine ReturnNVL (nvlout) - integer,intent(OUT) :: nvlout - call ReadQUEUEnamelist - nvlout = nvl - end subroutine ReturnNVL - - subroutine ReturnDT(dtout) - REAL,intent(OUT) :: dtout - integer i, rsl - call ReadQUEUEnamelist - rsl = 1 - do i = 1, glvl - rsl = rsl * SubdivNum(i) - enddo - rsl = INT(REAL(rsl) / 2.0) - dtout = 1.2*4800./REAL(rsl) - end subroutine ReturnDT - - subroutine GetChemOn (chem_on) - logical,intent(OUT) :: chem_on - call ReadQUEUEnamelist -!TODO: need a better way to maintain this... - chem_on = (chem_opt /= 0) - end subroutine GetChemOn - - subroutine GetWRFcuOn (wrfcu_on) - logical,intent(OUT) :: wrfcu_on - call ReadQUEUEnamelist -!TODO: need a better way to maintain this... - wrfcu_on = (cu_physics /= 0) - end subroutine GetWRFcuOn - - subroutine GetWRFmpOn (wrfmp_on) - logical,intent(OUT) :: wrfmp_on - call ReadQUEUEnamelist -!TODO: need a better way to maintain this... - wrfmp_on = (mp_physics /= 0) - end subroutine GetWRFmpOn - -! returns .true. iff any WRF physics or chemistry is turned on - subroutine GetWRFOn (wrf_on) - logical,intent(OUT) :: wrf_on - logical :: chem_on, wrfcu_on, wrfmp_on - call GetChemOn(chem_on) - call GetWRFcuOn(wrfcu_on) - call GetWRFmpOn(wrfmp_on) -!TODO: need a better way to maintain this... - wrf_on = (chem_on .OR. wrfcu_on .OR. wrfmp_on) - end subroutine GetWRFOn - -end module read_queue_namelist diff --git a/src/fim/FIMsrc/utils/reduce.F90 b/src/fim/FIMsrc/utils/reduce.F90 deleted file mode 100644 index 77b0e34..0000000 --- a/src/fim/FIMsrc/utils/reduce.F90 +++ /dev/null @@ -1,142 +0,0 @@ -program reduce -!********************************************************************* -!This program reads in one or more FIM pressure-level output files and -! creates new files with one selected pressure level per file. -!The pressure levels and file names are set in the file REDUCEinput. -!There are only 5 pressure level variables - see PLvars below. -!Before output the files are changed to fixed ij grid order using inv_perm. -!Jacques Middlecoff December 2009. -!********************************************************************* -implicit none -integer,parameter :: NPLvars = 5 !Number of pressure level variables -character(200) :: FullName !PathName+FileName -character(120) :: PathName !Path name where the pressure level files reside -character(80) :: FileName !Name of the pressure level file to be read -character(80) :: header(10) !FIM output file header -character(12) :: yyyymmddhhmm! Forecast initial time -character(6) :: FileTime !FIM variable name read from the FIM header -character(4) :: VarName !FIM variable name read from the FIM header -character(4) :: PLvars(NPLvars)=(/'up3P','vp3P','tmpP','rp3P','hgtP'/) -character(2) :: Var(NPLvars)!Name of the FIM out variables to process -integer :: Nvars !Number of FIM out variables to process (max 5) -integer :: Ntimes !Number of FIM output times to process -integer :: NumLevels !The number of pressure levels to output -integer :: Dim1 !FIM vertical dimension read from the header -integer :: nip !FIM # of icosahedral points read from the header -integer :: unit=50 !I/O unit -integer :: n,level,ivl !Indexes -integer :: ipn,t,v !Indexes -integer,allocatable :: Time (:) !The pressure levels (mb) for output -integer,allocatable :: Pressure(:) !The pressure levels (mb) for output -integer,allocatable :: inv_perm(:) !Permutation array for fixed grid order -real ,allocatable :: invar (:,:) !Location for FIM variable to be read in -real ,allocatable :: outvar(:,:) !Output variable before inv_perm -real ,allocatable :: fixvar (:) !Output variable after inv_perm - -OPEN (10,file="REDUCEinput") -read (10,*) PathName -read (10,*) Nvars -read (10,*) (Var(n),n=1,Nvars) -read (10,*) Ntimes -allocate( Time(Ntimes)) -read (10,*) Time -read (10,*) NumLevels -allocate( Pressure(NumLevels)) -read (10,*) Pressure -close(10) -write(FileTime,"(i6.6)") Time(1) -FileName = 'fim_out_' // trim(Var(1)) // FileTime -FullName = trim(PathName) // trim(FileName) -open(unit,file=FullName,form="unformatted") -read(unit) header -read(header(3),"(5x,i2,6x,i10)") Dim1,nip -close(unit) -allocate(inv_perm(nip)) -call GetInvPerm(nip,inv_perm) -do v=1,Nvars - do t=1,Ntimes - write(FileTime,"(i6.6)") Time(t) - FileName = 'fim_out_' // trim(Var(v)) // FileTime - FullName = trim(PathName) // trim(FileName) - open(unit,file=FullName,form="unformatted") - read(unit) header - read(header,"(4x,A,37x,A)") VarName,yyyymmddhhmm - read(header(3),"(5x,i2,6x,i10)") Dim1,nip - if(NumLevels > Dim1) then - print"('NumLevels=',I0,' > the number of levels Dim1=',I0)",NumLevels,Dim1 - print*,'In the file ',trim(Filename) - print*,'Fatal error' - stop - endif - do n=1,NPLvars - if(VarName == PLvars(n)) then - exit - elseif(n==NPLvars) then - print*,'Error: ',VarName,' is not a pressure level variable' - stop - endif - enddo - allocate(invar(Dim1,nip)) - read (unit) invar - close(unit) - allocate(outvar(nip,NumLevels),fixvar(nip)) - level = 1 - do ivl=1,Dim1 - if( 1000-(ivl-1)*25 == Pressure(level) ) then - outvar(:,level) = invar(ivl,:) - level=level+1 - if(level > NumLevels) exit - endif - enddo - if(level /= NumLevels+1) then - print*,'Error: did not find correct pressure levels' - stop - endif - do level = 1,NumLevels - do ipn=1,nip - fixvar(ipn) = outvar(inv_perm(ipn),level) - enddo - write(FullName,"(a10,'_',a6,'_',i4.4,'_',a8,'_',a2)") FileName(1:10),FileName(11:16),Pressure(level), & - yyyymmddhhmm(1:8),yyyymmddhhmm(9:10) - write(header(10),"('Pressure level = ',i4.4,' mb')") Pressure(level) - open (unit,file=FullName,form="unformatted") - write(unit) header - write(unit) fixvar - enddo - deallocate(invar,outvar,fixvar) - enddo !Ntimes -enddo !Nvars - -stop -end program reduce - -subroutine GetInvPerm(nip,inv_perm) -implicit none -integer,parameter :: npp=6 ! number of proximity points(max) -integer,intent(IN) :: nip -integer,intent(OUT) :: inv_perm(nip) -real :: work2d(nip) -integer :: iwork2d(nip) -integer :: isn,i2,i3 -character(16) :: header - -OPEN(10, file='icos_grid_info_level.dat',form='unformatted') -READ(10) header -READ(10) header -READ(10) work2d,work2d -do isn = 1,npp - READ(10) iwork2d -enddo -READ(10) iwork2d -do i3 = 1,2 - do i2 = 1,2 - do isn = 1,npp - READ(10) work2d - enddo - enddo -enddo -READ(10) inv_perm -CLOSE(10) - -return -end subroutine GetInvPerm diff --git a/src/fim/FIMsrc/utils/wtinfo.F90 b/src/fim/FIMsrc/utils/wtinfo.F90 deleted file mode 100644 index 64bb4b3..0000000 --- a/src/fim/FIMsrc/utils/wtinfo.F90 +++ /dev/null @@ -1,195 +0,0 @@ -module module_wtinfo - - implicit none - -contains - - subroutine wtinfo(cpn_out,num_write_tasks_out,mwtpn_out,root_own_node_out,& - abort_on_bad_task_distrib_out,debugmsg_on_out,comm_in) - -! Read namelist and return cores per node (cpn), number of write tasks -! (num_write_tasks), max write tasks per node (mwtpn), and whether root has node -! to himself (root_own_node). -! -! If this module is built in an SMS-parallelized context, insert and compile code -! to read the namelist only on the root task, package the write-task info in a -! user-defined type, and broadcast these values to the other tasks via an MPI -! derived type. - - implicit none - -!sms$insert include 'mpif.h' - - type wtconf - sequence - integer::cpn - integer::mwtpn - integer::nwt - logical::aobtd - logical::do - logical::ron - end type wtconf - - integer, intent(out) :: cpn_out ! number of cores per node - integer, intent(out) :: mwtpn_out ! max write tasks per node - integer, intent(out) :: num_write_tasks_out ! number of write tasks - integer, parameter :: lun = 11 ! unit number - logical, intent(out) :: abort_on_bad_task_distrib_out - logical, intent(out) :: debugmsg_on_out ! write-task debug msg control - logical, intent(out) :: root_own_node_out ! rank 0 has node to himself? - integer,intent(in),optional :: comm_in ! an MPI intracommunicator - - integer :: comm,istatus,me=0,comm_wtconf,size_i,size_l - integer :: count(2),offset(2),type(2) - type(wtconf) :: conf - -! Namelist variables - -! If something fishy is encountered w.r.t. node names associated with MPI tasks, -! default is to abort the model - - integer, save :: cpn = 0 ! init to bad value (user MUST specify in namelist) - integer, save :: max_write_tasks_per_node = 7 - integer, save :: num_write_tasks = 0 ! default is no write tasks - logical, save :: abort_on_bad_task_distrib = .true. - logical, save :: debugmsg_on=.false. ! write-task debug message control - logical, save :: root_own_node = .true. ! Put rank 0 on node by himself - logical, save :: alreadyReadWriteTaskInfo = .false. - - namelist /WRITETASKnamelist/ abort_on_bad_task_distrib,cpn,debugmsg_on,& - max_write_tasks_per_node,num_write_tasks,root_own_node - -! Prefer the passed-in MPI communicator, if provided. - -!sms$insert if (present(comm_in)) then -!sms$insert comm=comm_in -!sms$insert else -!sms$insert comm=mpi_comm_world -!sms$insert endif - - if (.not.alreadyReadWriteTaskInfo) then - -!sms$insert call mpi_comm_rank(comm,me,istatus) - -!sms$insert if (me.eq.0) then - -!sms$ignore begin - open (lun,file='FIMnamelist',status='old',action='read',iostat=istatus) - - if (istatus.ne.0) then - write (*,'(a,i0,a,i0)') 'wtinfo: task ',me,& - ' failed to open namelist file on unit ',lun - call flush(6) - stop - endif - - read (lun,WRITETASKnamelist,iostat=istatus) - if (istatus.ne.0) then - write (*,'(a,i0,a,i0)') 'wtinfo: task ',me,' failed to read WRITETASKnamelist on unit ',lun - call flush(6) - stop - endif - - close(lun) -!sms$ignore end - -! Populate conf with individual values. - -!sms$insert conf%aobtd = abort_on_bad_task_distrib -!sms$insert conf%cpn = cpn -!sms$insert conf%do = debugmsg_on -!sms$insert conf%mwtpn = max_write_tasks_per_node -!sms$insert conf%nwt = num_write_tasks -!sms$insert conf%ron = root_own_node - -!sms$insert endif ! me.eq.0 - -! Determine the size in bytes of the MPI integer type - -!sms$insert call mpi_type_extent(mpi_integer,size_i,istatus) -!sms$insert if (istatus.ne.0) then -!sms$ignore begin -!sms$insert write (*,'(a,i0)') 'wtinfo: MPI_Type_extent returned ',istatus -!sms$insert call mpi_abort(comm,istatus) -!sms$insert stop -!sms$ignore end -!sms$insert endif - -! Determine the size in bytes of the MPI logical type - -!sms$insert call mpi_type_extent(mpi_logical,size_l,istatus) -!sms$insert if (istatus.ne.0) then -!sms$ignore begin -!sms$insert write (*,'(a,i0)') 'wtinfo: MPI_Type_extent returned ',istatus -!sms$insert call mpi_abort(comm,istatus) -!sms$insert stop -!sms$ignore end -!sms$insert endif - -! Populate the arrays defining the MPI derived type - -!sms$insert count(1)=3 -!sms$insert offset(1)=0 -!sms$insert type(1)=mpi_integer -!sms$insert count(2)=3 -!sms$insert offset(2)=offset(1)+(count(1)*size_i) -!sms$insert type(2)=mpi_logical - -! Create the MPI derived-type struct - -!sms$insert call mpi_type_struct(2,count,offset,type,comm_wtconf,istatus) -!sms$insert if (istatus.ne.0) then -!sms$ignore begin -!sms$insert write (*,'(a,i0)') 'wtinfo: MPI_Type_struct returned ',istatus -!sms$insert call mpi_abort(comm,istatus) -!sms$insert stop -!sms$ignore end -!sms$insert endif - -! Commit the MPI derived type - -!sms$insert call mpi_type_commit(comm_wtconf,istatus) -!sms$insert if (istatus.ne.0) then -!sms$ignore begin -!sms$insert write (*,'(a,i0)') 'wtinfo: MPI_Type_commit returned ',istatus -!sms$insert call mpi_abort(comm,istatus) -!sms$insert stop -!sms$ignore end -!sms$insert endif - -! Broadcast the writetask configuration info - -!sms$insert call mpi_bcast(conf,1,comm_wtconf,0,comm,istatus) -!sms$insert if (istatus.ne.0) then -!sms$ignore begin -!sms$insert write (*,'(a,i0)') 'wtinfo: MPI_Bcast returned ',istatus -!sms$insert call mpi_abort(comm,istatus) -!sms$insert stop -!sms$ignore end -!sms$insert endif - -! Non-root tasks unpack conf to individual values. - -!sms$insert if (me.ne.0) then -!sms$insert abort_on_bad_task_distrib = conf%aobtd -!sms$insert cpn = conf%cpn -!sms$insert debugmsg_on = conf%do -!sms$insert max_write_tasks_per_node = conf%mwtpn -!sms$insert num_write_tasks = conf%nwt -!sms$insert root_own_node = conf%ron -!sms$insert endif ! me.ne.0 - - alreadyReadWriteTaskInfo=.true. - - endif ! .not.alreadyReadWriteTaskInfo - - num_write_tasks_out = num_write_tasks - mwtpn_out = max_write_tasks_per_node - cpn_out = cpn - root_own_node_out = root_own_node - abort_on_bad_task_distrib_out = abort_on_bad_task_distrib - debugmsg_on_out = debugmsg_on - - end subroutine wtinfo - -end module module_wtinfo diff --git a/src/fim/FIMsrc/w3/CFILES/dbn_alert.c b/src/fim/FIMsrc/w3/CFILES/dbn_alert.c deleted file mode 100644 index 8affee0..0000000 --- a/src/fim/FIMsrc/w3/CFILES/dbn_alert.c +++ /dev/null @@ -1,258 +0,0 @@ -/* - * dbn_alert.c - * - * Distributed Brokered Networking (DBNet) alert hook - * - * author: Luis J. Cano - * date: 2/20/96 - * - * - * $Date: 1996/09/16 18:51:08 $ - * $Id: dbn_alert.c,v 2.5 1996/09/16 18:51:08 dbnet-bl Exp $ - * $Log: dbn_alert.c,v $ - * Revision 2.5 1996/09/16 18:51:08 dbnet-bl - * Added local (file scope) variables to hold the exec parameters, using - * the vars passed in from a fortran program would cause a Bad Address error - * on the cray. This is apparently a problem with doing an exec in c when - * called by fortran.... Larry - * - * Revision 2.4 1996/09/11 12:39:48 dbnet-bl - * Changed exec call to a fork, exec, waitpid to allow fortran callers - * to use this module in the blocked mode.. - * - * Revision 2.3 1996/08/21 13:53:21 dbnet-bl - * Added -D option for the dbn_alert function to be all caps. - * This option will work in conjuntion with the UNDERSCORE option. - * The option name is CAPS. This is needed for the fortran bindin - * on the cray. Larry - * - * Revision 2.2 1996/08/14 17:18:06 dbnet-bl - * execl would not execute a script on the cray (only binary executables). - * Changed execl to execlp. Changed the second param when using execlp to the - * file name DBNALERTFILE vice the entire path. Changed the NULL to (char *)0, - * per posix. Louie. - * - * Revision 2.1 1996/08/07 15:05:05 dbnet-bl - * Bug with the execlp, doesn't work in a qsub on a cray. Larry found and fixed it - * by changing the execlp to execl. Added a NOT_BLOCKED macro that can be set when - * compiled (-DNOT_BLOCKED), which will do the alert work in a granchild - * process, or if not set, defaults the execlp in the current process. Going back - * to the execlp on the cray, the bug is not with execlp, but the way it was being - * used. When in a qsup, it doesn't like when the execlp is used with a complete - * path. Works when not in a qsub, and has been working on the workstations. Louie - * - * Revision 2.0 1996/08/07 14:29:49 dbnet-bl - * initial DBNet 2.0 module checkin - * - * - */ - - -#define _POSIX_SOURCE 1 - -#include -#include -#include -#include -#include -#include - - -/* add new define for CAPS. Make it work with UNDERSCORE */ -#ifdef UNDERSCORE - -#ifdef CAPS -#define dbn_alert DBN_ALERT_ -#else -#define dbn_alert dbn_alert_ -#endif - -#else - -#ifdef CAPS -#define dbn_alert DBN_ALERT -#else -#define dbn_alert dbn_alert -#endif - -#endif - -#define DBNROOT_ENV "DBNROOT" -#define DBNALERTPL "/bin/dbn_alert.pl" -#define DBNALERTFILE "dbn_alert.pl" - - -static char *ntype = NULL; -static char *nsubtype = NULL; -static char *njob = NULL; -static char *npath = NULL; -static char *dbn_alertpl=NULL; - -void free_mem(void) ; - -/* - * main function - */ -void dbn_alert(char *type, int *typelen, - char *subtype, int *subtypelen, - char *job, int *joblen, - char *path, int *pathlen, - int *iret ) { - - const char myname[]="\ndbn_alert:"; - - pid_t cpid, gpid; - static char *dbn_root=NULL; - -/* - * ensure null terminated strings - */ - type[*typelen]=0x0; - subtype[*subtypelen]=0x0; - job[*joblen]=0x0; - path[*pathlen]=0x0; - *iret=1; /* assume an error */ - -/* - * validate DBNet root env variable - */ - if (dbn_root==NULL) { - dbn_root=getenv(DBNROOT_ENV); - if (dbn_root==NULL) { - (void)fprintf(stderr, "\n%s environment variable %s not set!\n", myname, DBNROOT_ENV); - return; - } - } - -/* - * determine path to dbn_alert.pl - */ - - if (dbn_alertpl==NULL) { - dbn_alertpl=malloc(strlen(dbn_root)+strlen(DBNALERTPL)+1); /* include null */ - if (dbn_alertpl==NULL) { - (void)fprintf(stderr, "%s malloc(%u) for the dnb_alert.pl path failed", - myname, strlen(dbn_root)+strlen(DBNALERTPL)+1); - return; - } - (void)strcpy(dbn_alertpl, dbn_root); - (void)strcat(dbn_alertpl, DBNALERTPL); - } - - if ( (ntype=malloc((size_t)typelen + 1)) == NULL) { /* include null */ - (void)fprintf(stderr, "%s malloc(%u) for the ntype failed", - myname, typelen + 1); - free_mem(); - return; - } - (void)strcpy(ntype, type); - - if ( (nsubtype=malloc((size_t)subtypelen + 1)) == NULL) { /* include null */ - (void)fprintf(stderr, "%s malloc(%u) for the nsubtype failed", - myname, subtypelen + 1); - free_mem(); - return; - } - (void)strcpy(nsubtype, subtype); - - if ( (njob=malloc((size_t)joblen + 1)) == NULL) { /* include null */ - (void)fprintf(stderr, "%s malloc(%u) for the njob failed", - myname, joblen + 1); - free_mem(); - return; - } - (void)strcpy(njob, job); - - if ( (npath=malloc((size_t)pathlen + 1)) == NULL) { /* include null */ - (void)fprintf(stderr, "%s malloc(%u) for the npath failed", - myname, pathlen + 1); - free_mem(); - return; - } - (void)strcpy(npath, path); - -#if NOT_BLOCKED - -/* - * do the alert work in a grandchild process - */ - if ((cpid=fork()) < 0) { - perror("dbn_alert: fork"); - (void)fprintf(stderr, "%s fork failed", myname); - free_mem(); - return; - } - if (cpid==0) { /* child processing */ - if ((gpid=fork()) < 0) { - perror("dbn_alert: child: fork"); - (void)fprintf(stderr, "%s child: fork failed", myname); - exit(EXIT_FAILURE); - } - if (gpid==0) { /* grandchild process */ - if (execlp(dbn_alertpl, DBNALERTFILE, ntype, nsubtype, njob, npath, (char *)0)<0) { - perror("dbn_alert: grandchild: execlp"); - (void)fprintf(stderr, "%s grandchild: execlp(%s, %s, %s, %s,%s, %s) failed\n", - myname, dbn_alertpl, DBNALERTFILE, ntype, nsubtype, njob,npath); - } - exit(EXIT_FAILURE); - } - exit(EXIT_SUCCESS); - } - while (wait((int *)NULL) != cpid) - ; - -#else - -/* - * do the alert work in current proccess - */ -/* change the exec to a system call for the blocked version, this will allow the - caller to get the return code. - if (execlp(dbn_alertpl, DBNALERTFILE, type, subtype, job, path, (char *)0)<0) { - perror("dbn_alert: execlp"); - (void)fprintf(stderr, "%s execlp(%s, %s, %s, %s, %s, %s) failed\n", - myname, dbn_alertpl, DBNALERTFILE, type, subtype, job, path); - return; - } -*/ - if ((cpid=fork()) < 0) { - perror("dbn_alert: fork"); - (void)fprintf(stderr, "%s fork failed", myname); - free_mem(); - return; - } - if (cpid==0) { /* child processing */ - - if (execlp(dbn_alertpl, DBNALERTFILE, ntype, nsubtype, njob, npath,'\0')<0) { - perror("dbn_alert: execle"); - (void)fprintf(stderr, "%s execlp(%s, %s, %s, %s, %s, %s) failed\n", - myname, dbn_alertpl, DBNALERTFILE, ntype, nsubtype, njob, npath); - *iret = 2; - return; - } - } else { - waitpid(cpid,iret,0); - free_mem(); - return; - } - -#endif - free_mem(); - *iret=0; /* indicate success */ - return; -} - -void free_mem(void) { - - if (ntype != NULL) - free(ntype); - if (njob != NULL) - free(njob); - if (nsubtype != NULL) - free(nsubtype); - if (npath != NULL) - free(npath); - if (dbn_alertpl != NULL) - free(dbn_alertpl); -} - diff --git a/src/fim/FIMsrc/w3/CFILES/mova2i.c b/src/fim/FIMsrc/w3/CFILES/mova2i.c deleted file mode 100644 index f706b37..0000000 --- a/src/fim/FIMsrc/w3/CFILES/mova2i.c +++ /dev/null @@ -1,40 +0,0 @@ -/*$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: mova2i Moves a bit string from a char*1 to int -C PRGMMR: Gilbert ORG: W/NP11 DATE: 02-08-15 -C -C ABSTRACT: This Function copies a bit string from a Character*1 variable -C to an integer variable. It is intended to replace the Fortran Intrinsic -C Function ICHAR, which only supports 0 <= ICHAR(a) <= 127 on the -C IBM SP. If "a" is greater than 127 in the collating sequence, -C ICHAR(a) does not return the expected bit value. -C This function can be used for all values 0 <= ICHAR(a) <= 255. -C -C PROGRAM HISTORY LOG: -C 98-12-15 Gilbert -C -C USAGE: I = mova2i(a) -C -C INPUT ARGUMENT : -C -C a - Character*1 variable that holds the bitstring to extract -C -C RETURN ARGUMENT : -C -C mova2i - Integer value of the bitstring in character a -C -C REMARKS: -C -C None -C -C ATTRIBUTES: -C LANGUAGE: C -C MACHINE: IBM SP - -C -C$$$i*/ - -int mova2i(unsigned char *a) -{ - return (int)(*a); -} diff --git a/src/fim/FIMsrc/w3/CFILES/summary.c b/src/fim/FIMsrc/w3/CFILES/summary.c deleted file mode 100755 index e3e8969..0000000 --- a/src/fim/FIMsrc/w3/CFILES/summary.c +++ /dev/null @@ -1,40 +0,0 @@ -/*************************************************************** - -This code will make a system call to return various -useful parameters. When subroutine summary is called, a list -of system resource statistics is printed to stdout. - -Users need to place a call to start() at the beginning of the -section of code to be "measured" and a call to summary() at the end. - -Use as follows: - -call start() - do stuff -call summary() - -Jim Tuccillo August 1999 - -***************************************************************/ -#include -#include -#include -#include -#include -#include -#include -#include - -void summary_( returnVal ) -int * returnVal; -{ - - return; -} - -void start_() -{ - - return; -} - diff --git a/src/fim/FIMsrc/w3/GetJdate.f b/src/fim/FIMsrc/w3/GetJdate.f deleted file mode 100644 index c50d9f6..0000000 --- a/src/fim/FIMsrc/w3/GetJdate.f +++ /dev/null @@ -1,22 +0,0 @@ - subroutine GetJdate(yyyymmddhhmm,jdate) - implicit none - CHARACTER(len=12) :: yyyymmddhhmm - CHARACTER(len=9) :: jdate - INTEGER year, month, day, hour, minute, jday, IW3JDN - - ! get date info from the date string - READ(UNIT=yyyymmddhhmm(1:4), FMT='(I4)') year - READ(UNIT=yyyymmddhhmm(5:6), FMT='(I2)') month - READ(UNIT=yyyymmddhhmm(7:8), FMT='(I2)') day - READ(UNIT=yyyymmddhhmm(9:10), FMT='(I2)') hour - READ(UNIT=yyyymmddhhmm(11:12), FMT='(I2)') minute - - ! create the jdate string - jday = IW3JDN(year,month,day) - IW3JDN(year,1, 1) + 1 - WRITE(UNIT=jdate(1:2), FMT='(I2.2)') MOD (year, 100) - WRITE(UNIT=jdate(3:5), FMT='(I3.3)') jday - WRITE(UNIT=jdate(6:7), FMT='(I2.2)') hour - WRITE(UNIT=jdate(8:9), FMT='(I2.2)') minute - - return - end subroutine GetJdate diff --git a/src/fim/FIMsrc/w3/Makefile b/src/fim/FIMsrc/w3/Makefile deleted file mode 100644 index 52bfe8b..0000000 --- a/src/fim/FIMsrc/w3/Makefile +++ /dev/null @@ -1,42 +0,0 @@ -############################################################### -# -# AUTHOR: Gilbert - W/NP11 -# -# DATE: 01/11/1999 -# -# DATE: 03/25/2010 -# Modified by Rosinski (NOAA/ESRL) to use only a Makefile, -# eliminate the need for a script -# -############################################################### - -# -# Generate a list of object files that corresponds to the -# list of Fortran ( .f, .F90 ) files in the current directory -# - -include ../macros.make - -LIB = $(LIBDIR)/libw3_4.a -OBJS = $(addsuffix .o, $(basename $(SRCS))) -SRCS = $(shell ls *.f *.F90 | grep -v jdate.F90) - -.SUFFIXES: -.SUFFIXES: .o .f .F90 - -.F90.o: - $(FC) $(FFLAGS_NO_DEBUG) $(FREEFLAG) -c $< - -.f.o: - $(FC) -c $(FFLAGS) $(FIXEDFLAG) $< - -all: $(LIB) $(BINDIR)/jdate - -$(LIB): $(OBJS) - ar ruv $(AFLAGS) $@ $(OBJS) - -$(BINDIR)/jdate: $(LIB) - $(FCserial) $(FFLAGS) $(FREEFLAG) -o $@ jdate.F90 $(LIB) - -clean: - $(RM) *.o *.mod diff --git a/src/fim/FIMsrc/w3/MovChar.F90 b/src/fim/FIMsrc/w3/MovChar.F90 deleted file mode 100644 index 0dec840..0000000 --- a/src/fim/FIMsrc/w3/MovChar.F90 +++ /dev/null @@ -1,9 +0,0 @@ -subroutine MovChar(KBUF,PFLD,LEN) -implicit none -integer ,intent( IN) :: len -character*1,intent( IN) :: PFLD(LEN) -character*1,intent(OUT) :: kbuf(LEN) - - KBUF = PFLD - -end subroutine MovChar diff --git a/src/fim/FIMsrc/w3/README.w3 b/src/fim/FIMsrc/w3/README.w3 deleted file mode 100644 index 04f47d5..0000000 --- a/src/fim/FIMsrc/w3/README.w3 +++ /dev/null @@ -1,167 +0,0 @@ - - README.w3 - - This directory, /nwprod/lib/sorc/w3 on IBM RS/6000 SP, contains various - relocatable libraries. Several versions of each library may exist - and they follow the naming convention libname_n_xxx. - - The first qualifier in the library name, _n, is set to _4, _d or - _8 to indicate the default size of the integer and real variables used - in the routines. Libraries with the _4 qualifier were compiled - specifying that integer and real variables have a default size - of 4 bytes, whereas the _8 libraries compiled the source specifying - 8 byte integer and real variables (i.e. compiler options "-qintsize=8" - and "-qrealsize=8" were used). The third type, _d, indicates that - real variables are 8 bytes, but integer variables are 4 bytes - (i.e. compiler option "-qrealsize=8" is used). Note that - "-qintsize=4" and "-qrealsize=4" are the default compiler options. - - The second qualifier indicates the RISC processor type on which the - library was compiled to run. The _604 qualifier indicates that the - library was compiled to run on the 604 processor used in the Silver - Nodes ( compiler option "-qarch=604" ). The _pwr3 libraries were - compiled using option "-qarch=pwr3" to run on the Winterhawk Nodes. - Note that codes compiled with "-qarch=604" will run on the PWR3 - processors, but programs specifying "-qarch=pwr3" may not run - properly on the 604 processors. - - Here is a list of libraries currently available. - - "w3lib" is collection of relocatable utility modules - - w3lib_4_604 (4_Byte Integer and 4_Byte Real) - w3lib_4_pwr3 (4_Byte Integer and 4_Byte Real) - - w3lib_d_604 (4_Byte Integer and 8_Byte Real) - w3lib_d_pwr3 (4_Byte Integer and 8_Byte Real) - - w3lib_8_604 (8_Byte Integer and 8_Byte Real) - - "splib" is collection of spectral transformation modules - (see /nwprod/lib/sorc/sp for more details) - - splib_4_604 (4_Byte Integer and 4_Byte Real) - splib_4_pwr3 (4_Byte Integer and 4_Byte Real) - - splib_d_604 (4_Byte Integer and 8_Byte Real) - splib_d_pwr3 (4_Byte Integer and 8_Byte Real) - - splib_8_604 (8_Byte Integer and 8_Byte Real) - - Note: To properly link to one of the above libraries, the - xlf_r or xlf90_r compiler is required so that - the threaded versions of the system libraries are - linked in as well. Also, the options "-qsmp" and - "-lessl" must be used in the link step. - - "iplib" is collection of general interpolation routines - (see /nwprod/lib/sorc/ip for details) - - iplib_4_604 (4_Byte Integer and 4_Byte Real) - iplib_4_pwr3 (4_Byte Integer and 4_Byte Real) - - iplib_d_604 (4_Byte Integer and 8_Byte Real) - iplib_d_pwr3 (4_Byte Integer and 8_Byte Real) - - iplib_8_604 (8_Byte Integer and 8_Byte Real) - - Note: When linking to one of the iplib libraries, it is - often required to link to the corresponding splib - as well. See the "splib" section above. - - "gemlib" is collection of relocatable utility modules - - gemlib_4_604 (4_Byte Integer and 4_Byte Real) - gemlib_4_pwr3 (4_Byte Integer and 4_Byte Real) - - gemlib_d_604 (4_Byte Integer and 8_Byte Real) - gemlib_d_pwr3 (4_Byte Integer and 8_Byte Real) - - gemlib_8_604 (8_Byte Integer and 8_Byte Real) - - "bacio" contains byte-addressable C I/O routines and Fortran - interface - - bacio_4_604 (4_Byte Integer ) - bacio_4_pwr3 (4_Byte Integer ) - - bacio_8_604 (8_Byte Integer ) - bacio_8_pwr3 (8_Byte Integer ) - - "sigio" contains routines to access sigma restart files. - - sigio_4_604 (4_Byte Integer ) - sigio_4_pwr3 (4_Byte Integer ) - - "w3mod" contains specifications and definitions that can be - accessed from other program units. - - w3mod_4 (4_Byte Integer and 4_Byte Real) - - w3mod_8 (8_Byte Integer and 8_Byte Real) - - w3mod_d (4_Byte Integer and 8_Byte Real) - - -=============================================================================== - - Library Maintenance - - - * "makew3lib.sh", "makesplib.sh", "makeiplib.sh", "makegemlib.sh" - and "makebacio.sh" are used primarily to compile source code - files and to place their object files into libraries "w3lib", - "splib", "iplib", "gemlib", and "bacio", respectively. - - * The compile options used in the scripts mentioned above are "-O3" - "-qnosave", "-qarch=604 or pwr3". Options "-qintsize=8" and/or - "-qrealsize=8" are used to create the _d or _8 libraries. - - * The "archive ar" command is also used in the compile scripts. It - enables the user to manipulate the relocatable libraries - in a number of ways. - - * "ar -r" adds a module to the relocatable library or replaces - the module in the library if it already exists. - - ex. ar -r w3lib_8_604 w3fi88.o - - * "ar -d" deletes the named module from a relocatable library. - - ex. ar -d w3lib_8_604 w3fi88.o - - * "ar -tv" prints a table of contents and gives a verbose module by - module description of the making of a new library file. This is - useful to do after running the compile script to verify how - the relocatable library has been altered. - - ex. ar -tv w3lib_8_604 - - - NOTE: 1) It is a good idea to make a backup copy of the relocatable - library before manipulating it in any way. - - 2) The script uses the make utility to add or to update all w3lib - archive libraries: w3lib_4_604, w3lib_4_pwr3, w3lib_8_604, - w3lib_8_pwr3, w3lib_d_604, w3lib_d_pwr3, w3mod_4, w3mod_8, - and w3mod_d. - - For example, you would enter the following: - - /nwprod/lib/sorc/w3/makew3lib.sh - - - REMARKS: Only source files that have been modified since - the last library update are recompiled and replaced - in the object archive libraries. The make utility - determines this from the file modification times. - - New source files are also compiled and added to the - object archive libraries. - - 3) If you need to re-compile all object files, you have to change - the file date by using the command "touch *.f " or rename the - existing libraries "w3lib". Then, you run the script - "makew3lib.sh" to generate all w3lib archive libraries. - - -> End of README.w3 diff --git a/src/fim/FIMsrc/w3/aea.f b/src/fim/FIMsrc/w3/aea.f deleted file mode 100644 index f0361fd..0000000 --- a/src/fim/FIMsrc/w3/aea.f +++ /dev/null @@ -1,117 +0,0 @@ - SUBROUTINE AEA (IA, IE, NC ) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: AEA ASCII TO EBCDIC, OR EBCDIC TO ASCII -C PRGMMR: DESMARAIS ORG: W342 DATE: 82-11-29 -C -C ABSTRACT: CONVERT ASCII TO EBCDIC, OR EBCDIC TO ASCII BY CHARACTER. -C THIS SUBROUTINE CAN BE REPLACED BY CRAY UTILITY SUBROUTINES -C USCCTC AND USCCTT. SEE MANUAL SR-2079 PAGE 3-15. CRAY UTILITY TR -C CAN ALSO BE USED FOR ASCII, EBCDIC CONVERSION. SEE MANUAL SR-2079 -C PAGE 9-35. -C -C PROGRAM HISTORY LOG: -C 82-11-29 DESMARAIS -C 88-03-31 R.E.JONES CHANGE LOGIC SO IT WORKS LIKE A -C IBM370 TRANSLATE INSTRUCTION. -C 88-08-22 R.E.JONES CHANGES FOR MICROSOFT FORTRAN 4.10 -C 88-09-04 R.E.JONES CHANGE TABLES TO 128 CHARACTER SET -C 90-01-31 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C CRAY DOES NOT ALLOW CHAR*1 TO BE SET TO HEX -C 98-12-21 Gilbert Replaced Function ICHAR with mova2i. -C -C USAGE: CALL AEA (IA, IE, NC) -C INPUT ARGUMENT LIST: -C IA - CHARACTER*1 ARRAY OF ASCII DATA IF NC < 0 -C IE - CHARACTER*1 ARRAY OF EBCDIC DATA IF NC > 0 -C NC - INTEGER, CONTAINS CHARACTER COUNT TO CONVERT.... -C IF NC .LT. 0, CONVERT ASCII TO EBCDIC -C IF NC .GT. 0, CONVERT EBCDIC TO ASCII -C -C OUTPUT ARGUMENT LIST: -C IA - CHARACTER*1 ARRAY OF ASCII DATA IF NC > 0 -C IE - CHARACTER*1 ARRAY OF EBCDIC DATA IF NC < 0 -C -C REMARKS: SOFTWARE VERSION OF IBM370 TRANSLATE INSTRUCTION, BY -C CHANGING THE TWO TABLES WE COULD DO A 64, 96, 128 ASCII -C CHARACTER SET, CHANGE LOWER CASE TO UPPER, ETC. -C AEA CONVERTS DATA AT A RATE OF 1.5 MILLION CHARACTERS PER SEC. -C CRAY UTILITY USCCTI CONVERT IBM EBCDIC TO ASCII -C CRAY UTILITY USCCTC CONVERT ASCII TO IBM EBCDIC -C THEY CONVERT DATA AT A RATE OF 2.1 MILLION CHARACTERS PER SEC. -C CRAY UTILITY TR WILL ALSO DO A ASCII, EBCDIC CONVERSION. -C TR CONVERT DATA AT A RATE OF 5.4 MILLION CHARACTERS PER SEC. -C TR IS IN LIBRARY /USR/LIB/LIBCOS.A ADD TO SEGLDR CARD. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM SP -C -C$$$ -C*** ASCII CONTAINS ASCII CHARACTERS, AS PUNCHED ON IBM029 -C - INTEGER(8) IASCII(32) - INTEGER(8) IEBCDC(32) -C - CHARACTER*1 IA(*) - CHARACTER*1 IE(*) - CHARACTER*1 ASCII(0:255) - CHARACTER*1 EBCDIC(0:255) -C - EQUIVALENCE (IASCII(1),ASCII(0)) - EQUIVALENCE (IEBCDC(1),EBCDIC(0)) -C - DATA IASCII/ - & X'000102030009007F',X'0000000B0C0D0E0F', - & X'1011120000000000',X'1819000000000000', - & X'00001C000A001700',X'0000000000050607', - & X'00001600001E0004',X'000000001415001A', - & X'2000600000000000',X'0000602E3C282B00', - & X'2600000000000000',X'000021242A293B5E', - & X'2D2F000000000000',X'00007C2C255F3E3F', - & X'0000000000000000',X'00603A2340273D22', - & X'2061626364656667',X'6869202020202020', - & X'206A6B6C6D6E6F70',X'7172202020202020', - & X'207E737475767778',X'797A2020205B2020', - & X'0000000000000000',X'00000000005D0000', - & X'7B41424344454647',X'4849202020202020', - & X'7D4A4B4C4D4E4F50',X'5152202020202020', - & X'5C20535455565758',X'595A202020202020', - & X'3031323334353637',X'3839202020202020'/ -C -C*** EBCDIC CONTAINS HEX. REPRESENTATION OF EBCDIC CHARACTERS -C - DATA IEBCDC/ - & X'00010203372D2E2F',X'1605250B0C0D0E0F', - & X'101112003C3D3226',X'18193F2722003500', - & X'405A7F7B5B6C507D',X'4D5D5C4E6B604B61', - & X'F0F1F2F3F4F5F6F7',X'F8F97A5E4C7E6E6F', - & X'7CC1C2C3C4C5C6C7',X'C8C9D1D2D3D4D5D6', - & X'D7D8D9E2E3E4E5E6',X'E7E8E9ADE0BD5F6D', - & X'7981828384858687',X'8889919293949596', - & X'979899A2A3A4A5A6',X'A7A8A9C06AD0A107', - & 16*X'4040404040404040'/ -C - NUM = IABS(NC) -C - IF (NC .EQ. 0) RETURN -C - IF (NC .GT. 0) THEN -C -C*** CONVERT STRING ... EBCDIC TO ASCII, NUM CHARACTERS -C - DO 10 J = 1, NUM - IA(J) = ASCII(mova2i(IE(J))) - 10 CONTINUE -C - ELSE -C -C*** CONVERT STRING ... ASCII TO EBCDIC, NUM CHARACTERS -C - DO 20 J = 1, NUM - IE(J) = EBCDIC(mova2i(IA(J))) - 20 CONTINUE - END IF -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/args_mod.f b/src/fim/FIMsrc/w3/args_mod.f deleted file mode 100644 index e290919..0000000 --- a/src/fim/FIMsrc/w3/args_mod.f +++ /dev/null @@ -1,45 +0,0 @@ -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: args_mod Wrapper for routines iargc and getarg -C PRGMMR: Iredell ORG: W/NMC23 DATE: 98-11-DD -C -C ABSTRACT: This Fortran Module acts as a wrapper to the system -C routines IARGC and GETARG. Use of this module allows IARGC and -C GETARG to work properly with 4-byte or 8-byte integer arguments. -C -C PROGRAM HISTORY LOG: -C 98-11-DD Iredell -C -C USAGE: use args_mod -C -C REMARKS: None -C -C ATTRIBUTES: -C LANGUAGE: XL Fortran -C MACHINE: IBM SP -C -C$$$ - module args_mod -!JFM interface iargc -!JFM module procedure iargc_8 -!JFM end interface - interface getarg - subroutine getarg(k,c) - integer(4) k - character*(*) c - end subroutine getarg - module procedure getarg_8 - end interface - contains -!JFM integer(8) function iargc_8() -!JFM integer(4) iargc -!JFM iargc_8=iargc() -!JFM end function iargc_8 - subroutine getarg_8(k,c) - integer(8) k - character*(*) c - integer(4) k4 - k4=k - call getarg(k4,c) - end subroutine getarg_8 - end module args_mod diff --git a/src/fim/FIMsrc/w3/errexit.f b/src/fim/FIMsrc/w3/errexit.f deleted file mode 100644 index cfbff87..0000000 --- a/src/fim/FIMsrc/w3/errexit.f +++ /dev/null @@ -1,34 +0,0 @@ - SUBROUTINE ERREXIT(IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: ERREXIT EXIT WITH A RETURN CODE -C PRGMMR: IREDELL ORG: NP23 DATE:1998-06-04 -C -C ABSTRACT: EXIT WITH A RETURN CODE -C -C PROGRAM HISTORY LOG: -C 1998-06-04 IREDELL -C 1999-01-26 Gilbert - changed to use XLF utility routine exit_(n) -C instead of exit(n). exit_(n) will return -C the proper value ( n must be 4 byte int ) -C to the sh/ksh shell status variable $? -C ( $status for csh ) on the IBM SP. -C -C USAGE: CALL ERREXIT(IRET) -C INPUT ARGUMENT LIST: -C IRET - INTEGER RETURN CODE -C -C SUBPROGRAMS CALLED: -C EXIT_ - EXITS FROM A FORTRAN PROGRAM -C -C ATTRIBUTES: -C LANGUAGE: XLF FORTRAN 90 -C MACHINE: IBM SP -C -C$$$ - INTEGER IRET - INTEGER(4) JRET - JRET=IRET -!JFM CALL exit_(JRET) - CALL exit(JRET) !JFM - END diff --git a/src/fim/FIMsrc/w3/errmsg.f b/src/fim/FIMsrc/w3/errmsg.f deleted file mode 100644 index c15a541..0000000 --- a/src/fim/FIMsrc/w3/errmsg.f +++ /dev/null @@ -1,29 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE ERRMSG(CMSG) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: ERRMSG WRITE A MESSAGE TO STDERR -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 95-10-31 -C -C ABSTRACT: WRITE A MESSAGE TO STDERR. -C -C PROGRAM HISTORY LOG: -C 95-10-31 IREDELL -C -C USAGE: CALL ERRMSG(CMSG) -C INPUT ARGUMENTS: -C CMSG CHARACTER*(*) MESSAGE TO WRITE -C -C REMARKS: THIS IS A MACHINE-DEPENDENT SUBPROGRAM. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN -C MACHINE: CRAY -C -C$$$ - CHARACTER*(*) CMSG -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - WRITE(0,'(A)') CMSG -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/fparsei.f b/src/fim/FIMsrc/w3/fparsei.f deleted file mode 100644 index dccf3aa..0000000 --- a/src/fim/FIMsrc/w3/fparsei.f +++ /dev/null @@ -1,39 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE FPARSEI(CARG,MARG,KARG) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FPARSER PARSE INTEGERS FROM A CHARACTER STRING -C PRGMMR: IREDELL ORG: NP23 DATE:1998-09-03 -C -C ABSTRACT: THIS SUBPROGRAM EXTRACTS INTEGERS FROM A FREE-FORMAT -C CHARACTER STRING. IT IS USEFUL FOR PARSING COMMAND ARGUMENTS. -C -C PROGRAM HISTORY LOG: -C 1998-09-03 IREDELL -C -C USAGE: CALL FPARSEI(CARG,MARG,KARG) -C -C INPUT ARGUMENT LIST: -C CARG - CHARACTER*(*) STRING OF ASCII DIGITS TO PARSE. -C INTEGERS MAY BE SEPARATED BY A COMMA OR BY BLANKS. -C MARG - INTEGER MAXIMUM NUMBER OF INTEGERS TO PARSE. -C -C OUTPUT ARGUMENT LIST: -C KARG - INTEGER (MARG) NUMBERS PARSED. -C (FROM 0 TO MARG VALUES MAY BE RETURNED.) -C -C REMARKS: -C TO DETERMINE THE ACTUAL NUMBER OF INTEGERS FOUND IN THE STRING, -C KARG SHOULD BE SET TO FILL VALUES BEFORE THE CALL TO FPARSEI AND -C THE NUMBER OF NON-FILL VALUES SHOULD BE COUNTED AFTER THE CALL. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - CHARACTER*(*) CARG - INTEGER KARG(MARG) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - READ(CARG,*,IOSTAT=IOS) KARG -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/w3/fparser.f b/src/fim/FIMsrc/w3/fparser.f deleted file mode 100644 index 85370cc..0000000 --- a/src/fim/FIMsrc/w3/fparser.f +++ /dev/null @@ -1,39 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE FPARSER(CARG,MARG,RARG) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FPARSER PARSE REAL NUMBERS FROM A CHARACTER STRING -C PRGMMR: IREDELL ORG: NP23 DATE:1998-09-03 -C -C ABSTRACT: THIS SUBPROGRAM EXTRACTS REAL NUMBERS FROM A FREE-FORMAT -C CHARACTER STRING. IT IS USEFUL FOR PARSING COMMAND ARGUMENTS. -C -C PROGRAM HISTORY LOG: -C 1998-09-03 IREDELL -C -C USAGE: CALL FPARSER(CARG,MARG,RARG) -C -C INPUT ARGUMENT LIST: -C CARG - CHARACTER*(*) STRING OF ASCII DIGITS TO PARSE. -C REAL NUMBERS MAY BE SEPARATED BY A COMMA OR BY BLANKS. -C MARG - INTEGER MAXIMUM NUMBER OF REAL NUMBERS TO PARSE. -C -C OUTPUT ARGUMENT LIST: -C RARG - REAL (MARG) NUMBERS PARSED. -C (FROM 0 TO MARG VALUES MAY BE RETURNED.) -C -C REMARKS: -C TO DETERMINE THE ACTUAL NUMBER OF REAL NUMBERS FOUND IN THE STRING, -C RARG SHOULD BE SET TO FILL VALUES BEFORE THE CALL TO FPARSER AND -C THE NUMBER OF NON-FILL VALUES SHOULD BE COUNTED AFTER THE CALL. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - CHARACTER*(*) CARG - REAL RARG(MARG) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - READ(CARG,*,IOSTAT=IOS) RARG -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/w3/gblevents.f b/src/fim/FIMsrc/w3/gblevents.f deleted file mode 100644 index dd1c060..0000000 --- a/src/fim/FIMsrc/w3/gblevents.f +++ /dev/null @@ -1,2436 +0,0 @@ -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GBLEVENTS PRE/POST PROCESSING OF PREPBUFR EVENTS -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2006-07-14 -C -C ABSTRACT: RUNS IN TWO MODES: "PREVENTS" AND "POSTEVENTS". IN THE -C PREVENTS MODE, PREPARES OBSERVATIONAL PREPBUFR REPORTS FOR -C SUBSEQUENT QUALITY CONTROL AND ANALYSIS PROGRAMS. THIS IS DONE -C THROUGH THE FOLLOWING: INTERPOLATION OF GLOBAL SPECTRAL SIMGA -C FIRST GUESS TO PREPBUFR OBSERVATION LOCATIONS WITH ENCODING OF -C FIRST GUESS VALUES INTO PREPBUFR REPORTS; ENCODING OF "PREVENT" -C AND/OR "VIRTMP" EVENTS INTO PREPBUFR REPORTS; AND ENCODING OF -C OBSERVATION ERRORS FROM THE ERROR SPECIFICATION FILE INTO -C PREPBUFR REPORTS. IN THE POSTEVENTS MODE, AFTER ALL QUALITY -C CONTROL AND ANALYSIS PROGRAMS HAVE RUN, INTERPOLATES THE GLOBAL -C SPECTRAL SIMGA ANALYSIS TO PREPBUFR OBSERVATION LOCATIONS AND -C ENCODES THESE ANALYZED VALUES INTO PREPBUFR REPORTS. THE -C REMAINDER OF THIS ABSTRACT APPLIES ONLY TO THE PREVENTS MODE. -C THE "PREVENT" EVENT CAN CHANGE A QUALITY MARKER TO FLAG AN -C OBSERVATION DATUM FOR NON-USE BY SUBSEQUENT QC AND ANALYSIS -C PROGRAMS (FILTERING). EXAMPLES WHERE THIS SUBROUTINE WILL WRITE -C AN EVENT TO FLAG A DATUM INCLUDE: THE OBSERVATION ERROR FOR THAT -C DATUM IS READ IN AS MISSING IN THE INPUT ERROR FILE, THE DATUM -C ITSELF VIOLATES A GROSS OR "SANITY" CHECK, OR THE OBSERVED -C PRESSURE DATUM IS MORE THAN 100 MB BELOW THE GUESS SURFACE -C PRESSURE. THE "VIRTMP" EVENT CAN CHANGE THE SPECIFIC HUMIDITY -C OBSERVATION (RE-CALCULATED) AS WELL AS THE TEMPERATURE -C OBSERVATION (FROM SENSIBLE TO VIRTUAL TEMPERATURE, BASED ON -C JUST-CALCULATED SPECIFIC HUMIDITY). CURRENTLY THIS APPLIES ONLY -C TO SURFACE (LAND, MARINE AND MESONET) DATA TYPES, POSSIBLY TO -C RAOB, DROP AND MULTI-LEVEL RECCO DAA TYPES IF THE SWITCH -C "ADPUPA_VIRT" IS TRUE (NORMALLY, HOWEVER IT IS FALSE) [OTHER DATA -C TYPES WITH REPORTED SENSIBLE TEMPERATURE EITHER HAVE MISSING -C MOISTURE (E.G., ALL AIRCRAFT TYPES EXCEPT FOR SOME ACARS, SATELLITE -C WIND TYPES), FLAGGED MOISTURE (E.G., SOME ACARS) OR CALCULATE -C SPECIFIC HUMIDITY/VIRTUAL TEMPERATURE IN SUBSEQUENT PROGRAMS (E.G., -C RAOBS, DROPS AND MULTI-LEVEL RECCOS WHICH CALCULATE THESE IN -C PROGRAM "CQCBUFR", IN WHICH CASE THE SWITCH "ADPUPA_VIRT" HERE MUST -C BE FALSE!)]. FOR CASES WHERE THE SWITCH "DOBERR" IS FALSE, THE -C OBSERVATION ERROR FOR ALL DATA REMAINS MISSING IN THE PREPBUFR -C FILE. IN THIS CASE, THE INPUT ERROR FILE IS USUALLY A NULL FILE -C AND THE "PREVENT" EVENT TO FLAG THE DATUM IS NOT INVOKED. FOR -C CASES WHERE THE SWITCH "DOFCST" IS FALSE, IF THE SWITCH "SOME_FCST" -C IS ALSO FALSE, THEN FORECAST VALUES ARE NOT ENCODED FOR ANY MESSAGE -C TYPE; IF "SOME_FCST" IS TRUE THEN FORECAST VALUES ARE ENCODED, BUT -C ONLY FOR REPORTS IN THOSE MESSAGE TYPES FOR WHICH A GUESS VALUE IS -C NEEDED BY SUBSEQUENT QC PROGRAMS. IT SHOULD BE NOTED THAT THE -C FILTERING OF DATA ASSOCIATED WITH THE "PREVENT" EVENT PROCESSING IS -C NOT INVOKED IF ALL THREE ARE TRUE: DOBERR= FALSE, THE FORECAST -C VALUES ARE MISSING (DOFCST=FALSE & SOME_FCST=TRUE & MESSAGE TYPE IS -C NOT "ADPUPA", "AIRCFT", "AIRCAR", "PROFLR", OR "VADWND" -- OR -- -C DOFCST=FALSE & SOME_FCST=FALSE), AND "VIRTMP" EVENT PROCESSING IS -C NOT INVOKED (EITHER MESSAGE TYPE IS NOT "ADPSFC", "SFCSHP" OR -C "MSONET" WHEN "ADPUPA_VIRT" IS FALSE, OR MESSAGE TYPE IS NOT -C "ADPSFC", "SFCSHP", "MSONET" OR "ADPUPA" WHEN "ADPUPA_VIRT" IS -C TRUE). -C -C PROGRAM HISTORY LOG: -C 1999-07-01 D. A. KEYSER -- ORIGINAL AUTHOR (ADAPTED FROM PREVENTS -C SUBROUTINE IN PREPDATA PROGRAM, BUT NOW GENERALIZED FOR -C POSTEVENTS MODE) -C 1999-07-12 D. A. KEYSER -- MODIFIED TO INTERPOLATE MODEL SPECIFIC -C HUMIDITY TO OBSERVATION LOCATION WHEN OBS. SPECIFIC HUMIDITY IS -C MISSING AS LONG AS OBS. TEMPERATURE IS NON-MISSING -C 1999-09-09 D. A. KEYSER -- ADDED "VADWND" TO THE LIST OF MESSAGE -C TYPES FOR WHICH FORECAST VALUES MUST BE ENCODED, EVEN WHEN -C DOFCST=FALSE (NECESSARY BECAUSE THE NEW PROGRAM CQCVAD NEEDS THE -C BACKGROUND DATA) -C 1999-09-09 D. A. KEYSER -- CHANGES TO MAKE CODE MORE PORTABLE; -C 'TFC' NOW GENERATED FOR VADWND MESSAGE TYPES EVEN THOUGH TOB IS -C MISSING (NEEDED BY CQCVAD PROGRAM) -C 1999-12-01 D. A. KEYSER -- SPEC. HUMIDITY AND VIRT. TEMPERATURE ARE -C NOW CALCULATED WHEN SPEC. HUMIDITY QUAL. MARKER IS BAD (SUBJECT -C TO A SANITY CHECK), HOWEVER THE VIRT. TEMPERATURE GETS A BAD -C QUAL. MARKER (8) -C 2000-09-21 D. A. KEYSER -- THE PRESSURE LEVEL ABOVE WHICH ALL SPEC. -C HUMIDITY QUAL. MARKERS ARE "REJECTED" (Q.M. SET TO 9) IS NOW READ -C IN AS A N-LIST SWITCH (QTOP_REJ), BEFORE IT WAS HARDWIRED TO 300 -C MB -C 2000-12-13 D. A. KEYSER -- WILL NO LONGER PERFORM VIRTUAL TEMPERATURE -C PROCESSING FOR ACARS DATA SINCE MOISTURE IS FLAGGED RIGHT NOW -C (ACARS MOISTURE ONLY WRITTEN INTO PREPBUFR FILE FOR STATISTICAL -C REASONS) -C 2001-02-02 D. A. KEYSER -- RESTORED LEGACY LOGIC TO FLAG CERTAIN -C SATELLITE TEMPERATURE SOUNDINGS EITHER BELOW 100 MB (TEMP. OBS) -C OR ON ALL LEVELS (SPEC. HUM. OBS), CONTROLLED BY NEW NAMELIST -C SWITCH "SATMQC" -C 2001-09-27 D. A. KEYSER -- 'TFC' AND 'QFC' NOW GENERATED FOR REPORT -C TYPE 111 (SYNDAT REPORTS AT STORM CENTER) EVEN THOUGH "TOB" AND -C "QOB" ARE MISSING (NEEDED BY SYNDATA PROGRAM); IN PREPARATION FOR -C CHANGE FROM T170L42 TO T254L64 SGES, NOW MAKES COEFFICIENT ARRAYS -C ALLOCATABLE TO ALLOW THEM TO OBTAIN MEMORY FROM "HEAP" RATHER -C THAN FROM "STACK", ALSO HAVE INCREASED THE MAX NUMBER OF LEVELS -C IN ARRAYS FROM 42 TO 64, FINALLY ALSO NO LONGER STOPS WITH C. -C CODE 70 IF EVEN NUMBER OF LONGITUDES IN SIGMA GUESS (IMAX, -C HARDWIRED TO 384) IS .LT. SPECTRAL RESOLUTION (JCAP) * 2 -C 2001-10-10 D. A. KEYSER -- AT PREPBUFR CENTER DATES WITH AN HOUR THAT -C IS NOT A MULTIPLE OF 3 (WHEN A GLOBAL SIGMA GUESS/ANAL FILE IS -C NOT AVAILABLE; E.G., IN RUC2A RUNS) NOW PERFORMS A LINEAR -C INTERPOLATION BETWEEN SPECTRAL COEFFICIENTS IN 2 SPANNING SIGMA -C GUESS/ANAL FILES 3-HRS APART TO CENERATE A GUESS/ANAL FILE VALID -C AT THE PREPBUFR CENTER TIME -C 2002-05-10 D. A. KEYSER -- ADDED "AIRCAR" TO THE LIST OF TABLE A -C MESSAGE TYPES THAT WILL STILL HAVE THE BACKGROUND ENCODED WHEN -C DOFCST IS FALSE (BECAUSE ACARS ARE NOW Q.C.'d IN PREPOBS_ACARSQC -C PROGRAM) -C 2003-09-02 D. A. KEYSER -- ADDED "MSONET" TO THE LIST OF TABLE A -C MESSAGE TYPES THAT WILL HAVE THE VIRTUAL TEMPERATURE CALCULATED; -C DOES NOT CALL UFBINT FOR OUTPUTTING DATA IF "NLEV" (4'TH -C ARGUMENT) IS ZERO (NOW CAN ONLY HAPPEN FOR GOESND FORECAST DATA -C WHEN ONLY RADIANCES ARE PRESENT) -C 2004-08-30 D. A. KEYSER -- NOW INCLUDES THE 4 LAYER PWATERS, THESE -C GET AN OBS. ERROR (EACH THE SAME AS TOTAL PWATER) AND AN EVENT -C IS GENERATED WITH A REJECTED Q.M. FOR THE 4 LAYER PWATERS IF THE -C PWATER OBS. ERROR READ IN IS MISSING (THIS CHANGE ALLOWS THE ETA/ -C GSI TO PROCESS OBS. ERRORS IN THE PREPBUFR FILE THE SAME AS THE -C ETA/3DVAR DID WHEN READING THE OBS. ERRORS FROM AN EXTERNAL -C FILE); FOR "RASSDA" TYPES, ENCODES A SIMPLE COPY OF THE REPORTED -C (VIRTUAL) TEMPERATURE AS A "VIRTMP" EVENT IF DOVTMP IS TRUE, GETS -C NEW REASON CODE 3 -C 2004-09-10 D. T. KLEIST -- ADDED CAPABILITY TO READ GUESS FIELDS FROM -C EITHER HYBRID OR, AS BEFORE, SIGMA GLOBAL FORECAST FILES -C 2005-01-03 D. A. KEYSER -- FIXED ERROR READING CDAS SGES FILE WHICH -C STILL HAS A 207-WORD HEADER (T62) {2004-09-10 CHANGE ASSUMED ALL -C SGES FILES HAD A 226-WORD HEADER (T254), BUT THIS IS VALID ONLY -C FOR GFS SGES) -C 2006-05-05 R. E. TREADON -- CHANGE VERTICAL INTERPOLATION TO DIRECTLY -C USE PRESSURE PROFILE, NOT PRESSURE PROFILE CONVERTED TO SIGMA. -C THIS CHANGE IS IN SUBROUTINE GBLEVN03. AS A RESULT OF THIS -C CHANGE, SUBROUTINE GBLEVN07 WAS REMOVED. -C 2006-07-14 D. A. KEYSER -- ADDED NEW NAMELIST SWITCH "SOME_FCST" -C WHICH APPLIES ONLY WHEN EXISTING SWITCH "DOFCST" IS FALSE: IF -C DOFCST=F AND SOME_FCST=T THEN, JUST AS BEFORE WHEN DOFCST=F, A -C FORECAST WILL STILL BE ENCODED FOR REPORTS IN CERTAIN MESSAGE -C TYPES USED IN SUBSEQUENT Q.C. PROGRAMS (I.E, "ADPUPA", "AIRCFT", -C "AIRCAR", "PROFLR" OR "VADWND") (THE DEFAULT FOR SOME_FCST IS -C TRUE); HOWEVER IF DOFCST=F AND SOME_FCST=F THEN A FORECAST WILL -C NOT BE ENCODED INTO REPORTS IN ANY MESSAGE TYPE (THIS ALLOWS -C THIS PROGRAM TO ENCODE OBS ERRORS AND/OR VIRTUAL TEMPERATURE -C EVENTS INTO A PREPBUFR FILE WITHOUT ENCODING A FORECAST); ADDED -C NEW NAMELIST SWITCH "ADPUPA_VIRT" WHICH, WHEN TRUE, INCLUDES -C REPORTS IN MESSAGE TYPE ADPUPA (I.E., RAOBS, DROPS, MULTI-LEVEL -C RECCOS) IN THE "VIRTMP" PROCESSING (PROCESSING THEM WITH SAME -C LOGIC AS IN SUBROUTINE VTPEVN OF PROGRAM PREPOBS_CQCBUFR) -C {NORMALLY "ADPUPA_VIRT" IS FALSE (DEFAULT) BECAUSE SUBSEQUENT -C PROGRAM PREPOBS_CQCBUFR PERFORMS THIS FUNCTION} -C -C USAGE: CALL GBLEVENTS(IDATEP,IUNITF,IUNITE,IUNITP,IUNITS,SUBSET, -C $ NEWTYP) -C INPUT ARGUMENT LIST: -C IDATEP - CENTER DATE FOR PREPBUFR FILE IN THE FORM YYYYMMDDHH -C IUNITF - 2-WORD ARRAY: -C - WORD 1 - UNIT NUMBER OF FIRST INPUT SPECTRAL (GLOBAL) -C - SIGMA FILE (EITHER FIRST GUESS OR ANALYSIS); IF HH IN -C - IDATEP IS A MULTIPLE OF 3 THEN THIS FILE IS VALID AT -C - THE DATE IN IDATEP, IF HH IN IDATEP IS NOT A -C - MULTIPLE OF 3 THEN THIS FILE IS VALID AT THE CLOSEST -C - TIME PRIOR TO THE DATE IN IDATEP THAT IS A MULTIPLE -C - OF 3 -C - WORD 2 - UNIT NUMBER OF SECOND INPUT SPECTRAL (GLOBAL) -C - SIGMA FILE (EITHER FIRST GUESS OR ANALYSIS); IF HH IN -C - IDATEP IS A MULTIPLE OF 3 THEN THIS FILE IS EMPTY, IF -C - HH IN IDATEP IS NOT A MULTIPLE OF 3 THEN THIS FILE IS -C - VALID AT THE CLOSEST TIME AFTER THE DATE IN IDATEP -C - THAT IS A MULTIPLE OF 3 -C IUNITE - UNIT NUMBER OF INPUT OBSERVATION ERROR FILE -C - (USED ONLY IN PREVENTS MODE) -C IUNITP - UNIT NUMBER OF OUTPUT PREPBUFR DATA SET -C IUNITS - UNIT NUMBER OF "PREVENT" EVENTS DATA FILTERING -C - SUMMARY PRINT FILE -C - (USED ONLY IN PREVENTS MODE) -C SUBSET - THE BUFR MESSAGE TABLE A ENTRY FOR THE PARTICULAR -C - REPORT BEING PROCESSED -C NEWTYP - INDICATOR IF THE BUFR MESSAGE TABLE A ENTRY HAS -C - CHANGED FROM THAT OF THE PREVIOUS REPORT (=0 - NO, -C - =1 - YES) -C -C -C INPUT FILES: -C UNIT 05 - STANDARD INPUT (DATA CARDS - SEE NAMELIST -C DOCUMENTATION BELOW) -C (NOTE: IF STANDARD INPUT FILE IS NULL, THEN THIS -C SUBROUTINE RUNS IN POSTEVENTS MODE) -C UNIT AA - PREPBUFR DATA SET -C - (WHERE AA IS UNIT NUMBER DEFINED AS IUNITP IN -C - INPUT ARGUMENT LIST) -C UNIT BB - SPECTRAL (GLOBAL) SIGMA GUESS (PREVENTS MODE) OR -C - ANALYSIS (POSTEVENTS MODE) FILE -C - (WHERE BB IS UNIT NUMBER DEFINED AS IUNITF(1) IN -C - INPUT ARGUMENT LIST) -C UNIT CC - SPECTRAL (GLOBAL) SIGMA GUESS (PREVENTS MODE) OR -C - ANALYSIS (POSTEVENTS MODE) FILE -C - (WHERE CC IS UNIT NUMBER DEFINED AS IUNITF(2) IN -C - INPUT ARGUMENT LIST) -C UNIT DD - OBSERVATION ERROR FILE (WHERE DD IS UNIT NUMBER -C - DEFINED AS IUNITE IN INPUT ARGUMENT LIST) -C - (USED ONLY IN PREVENTS MODE) -C -C OUTPUT FILES: -C UNIT 06 - STANDARD OUTPUT PRINT -C UNIT AA - PREPBUFR DATA SET -C - (WHERE AA IS UNIT NUMBER DEFINED AS IUNITP IN -C - INPUT ARGUMENT LIST) -C UNIT DD - "PREVENT" EVENTS DATA FILTERING SUMMARY PRINT FILE -C - (WHERE DD IS UNIT NUMBER DEFINED AS IUNITS IN -C - INPUT ARGUMENT LIST) -C - (USED ONLY IN PREVENTS MODE) -C -C SUBPROGRAMS CALLED: -C UNIQUE: GBLENV01 GBLEVN02 GBLEVN03 GBLEVN04 -C GBLEVN05 GBLEVN06 OEFG01 -C GBLEVN08 GBLEVN09 GBLEVN10 GBLEVN11 -C ZSG01 GBLEVN12 PSG01 GBLEVN13 -C TG01 GBLEVN14 UG01 GBLEVN15 -C VG01 GBLEVN16 QG01 GBLEVN17 -C LIBRARY: -C SPLIB - SPTEZM SPTEZMV -C W3LIB - W3MOVDAT ERREXIT -C BUFRLIB - UFBINT UFBQCD -C -C EXIT STATES: -C COND = 0 - SUCCESSFUL RUN -C COND = 60 - OBSERVATION ERROR TABLE EMPTY OR DOES NOT EXIST -C COND = 61 - VARIABLE NLTD .NE. VARIABLE NLEV -C COND = 62 - VARIABLE NLTQ .NE. VARIABLE NLEV -C COND = 63 - VARIABLE NLQQ .NE. VARIABLE NLEV -C COND = 64 - END OF FILE READING SIGMA FIRST GUESS OR ANALYSIS -C - - UNABLE TO TRANSFORM FIRST GUESS OR ANALYSIS -C COND = 65 - ERROR READING FIRST GUESS OR ANALYSIS - UNABLE TO -C - TRANSFORM FIRST GUESS OR ANALYSIS -C COND = 66 - VARIABLE IDIM NOT FACTORABLE - UNABLE TO TRANSFORM -C FIRST GUESS OR ANALYSIS -C COND = 67 - BAD OR MISSING FIRST GUESS OR ANALYSIS FILE(S) -C COND = 68 - DATE OF FIRST GUESS/ANALYSIS FILE(S) DOES NOT MATCH, -C - OR AT LEAST SPAN, THE CENTER DATE FOR THE PREPBUFR -C - FILE -C COND = 69 - VARIABLE KMAX TOO BIG - UNABLE TO TRANSFORM FIRST -C - GUESS OR ANALYSIS FILE(S) -C COND = 70 - VARIABLE IMAX TOO SMALL - UNABLE TO TRANSFORM FIRST -C - GUESS OR ANALYSIS FILE(S) (NOTE: Effective 9/27/01 -C - this can never occur) -C COND = 71 - ONE OR MORE HEADER VALUES DO NOT MATCH WHEN TWO -C - SIGMA FILES SPANNING THE CENTER DATE FOR THE -C - PREPBUFR FILE ARE READ -C -C -C REMARKS: THIS ROUTINE PROCESSES ONE REPORT AT A TIME. IT EXPECTS -C THAT THE CALLING PROGRAM HAS ALREADY ENCODED THE REPORT INTO -C THE PREPBUFR FILE VIA THE UFBINT OR UFBCPY ROUTINES. THE CALLING -C PROGRAM SHOULD THEN CALL THIS ROUTINE AND, UPON ITS RETURN, THE -C CALLING PROGRAM SHOULD CALL WRITSB TO ACTUALLY WRITE THE UPDATED -C SUBSET (REPORT) INTO THE BUFR MESSAGE. -CC -C ***** VARIABLES IN NAMELIST PREVDATA READ IN BY THIS SUBROUTINE ***** -C (NOTE: IF STANDARD INPUT FILE IS NULL, THEN THIS -C SUBROUTINE RUNS IN POSTEVENTS MODE - DOANLS=TRUE -C AND ALL OTHER VARIABLES ARE SET TO FALSE) -CC -CC -C DOVTMP & ADPUPA_VIRT: -C DOVTMP - WRITE VIRTUAL TEMPERATURE EVENT FOR THE FOLLOWING -C TYPES OF REPORTS: -C ADPUPA_VIRT = .FALSE. ---> SURFACE LAND, MARINE, -C MESONET AND RASS REPORTS? -C ADPUPA_VIRT = .TRUE. ---> SURFACE LAND, MARINE, -C MESONET RASS, RAOB, DROP -C AND MULTI-LEVEL RECCO -C REPORTS? -C FOR ALL TYPES EXCEPT RASS, THIS WILL ATTEMPT TO -C CALCULATE VIRTUAL TEMPERATURE FROM SENSIBLE TEMPERATURE -C AND ENCODE IT AS A STACKED EVENT IN THE PREPBUFR FILE. -C FOR RASS REPORTS THIS WILL JUST ENCODE THE REPORTED -C TEMPERATURE AS A STACKED EVENT IN THE PREPBUFR FILE -C SINCE THE REPORTED TEMPERATURE IS ALREADY VIRTUAL. -C DOVTMP = .TRUE. ---> YES (DEFAULT) -C DOVTMP = .FALSE. ---> NO -C {NOTE1: FOR SURFACE LAND, MARINE AND MESONET REPORTS, (AND -C RAOB, DROP AND MULTI-LEVEL RECCO REPORTS IF -C "ADPUPA_VIRT"=TRUE) DOVTMP=FALSE WILL STILL RE-CALCULATE -C SPECIFIC HUMIDITY AND ENCODE IT AS A STACKED EVENT IN -C THE PREPBUFR FILE UNLESS DOANLS IS TRUE.) -C (NOTE2: DOES NOT APPLY TO ANY REPORT TYPES OTHER THAN THOSE -C MENTIONED ABOVE) -C (NOTE3: IF DOANLS=TRUE, THEN DOVTMP IS NOT ONLY FORCED TO BE -C FALSE, BUT ALSO SPECIFIC HUMIDITY IS NOT RE-CALCULATED.) -C (NOTE4: ADPUPA_VIRT DEFAULTS TO FALSE.) -C -C DOFCST & SOME_FCST: -C DOFCST - ENCODE FORECAST (FIRST GUESS) VALUES, INTERPOLATED -C FROM THE SPECTRAL SIGMA GUESS FILE, INTO THE PREPBUFR -C FILE FOR ALL MESSAGE TYPES OR AT LEAST SOME MESSAGE -C TYPES? -C DOFCST = .TRUE. ---> YES, ENCODE FORECST FOR ALL -C MESSAGE TYPES (DEFAULT) -C DOFCST = .FALSE. -C SOME_FCST = .FALSE. ---> NO, DO NOT ENCODE FORECAST -C FOR ANY MESSAGE TYPE -C (VALUES REMAIN MISSING) -C SOME_FCST = .TRUE. ---> YES, BUT ONLY FOR MESSAGE -C TYPES "ADPUPA", "AIRCFT", -C "AIRCAR", "PROFLR" OR -C "VADWND" (VALUES REMAIN -C MISSING FOR ALL OTHER -C MESSAGE TYPES) -C (NOTE1: THE CASE DOFCST=FALSE & SOME_FCST=TRUE WRITES THE -C FORECAST VALUES FOR THE TYPES MENTIONED ABOVE BECAUSE -C THEY ARE NEEDED BY SUBSEQUENT QUALITY CONTROL PROGRAMS.) -C (NOTE2: THIS WAS ADDED AS A TIME SAVING FEATURE IN THE -C NON-GLOBAL VERSIONS SINCE ONLY THE GLOBAL-SSI REQUIRES -C A FIRST GUESS TO BE PRESENT FOR ALL CONVENTIONAL MESSAGE -C TYPES IN THE PREPBUFR FILE.) -C (NOTE3: IF DOANLS=TRUE, THEN DOFCST & SOME_FCST ARE FORCED TO BE -C FALSE, MEANING A GUESS WILL NOT BE ENCODED FOR ANY -C MESSAGE TYPE.) -C (NOTE4: IF DOFCST=TRUE, THEN SOME_FCST IS MEANINGLESS.) -C (NOTE5: SOME_FCST DEFAULTS TO TRUE.) -C -C DOANLS - ENCODE ANALYZED VALUES, INTERPOLATED FROM THE SPECTRAL -C SIGMA ANALYSIS FILE, INTO THE PREPBUFR FILE - POSTEVENTS -C MODE - ? -C DOANLS = .TRUE. ---> YES, FOR ALL MESSAGE TYPES -C DOANLS = .FALSE. ---> NO, FOR ALL MESSAGE TYPES -C - PREVENTS MODE - (DEFAULT) -C (NOTE: DOANLS=TRUE WILL OVERRIDE AND FORCE TO FALSE ALL OTHER -C SWITCHES. IN ADDITION, THE FORECAST VALUES WILL NOT -C BE ENCODED FOR ANY MESSAGE TYPE AND SPECIFIC HUMIDITY -C WILL NOT BE RE-CALCULATED.) -C -C DOBERR - ENCODE OBSERVATIONAL ERROR VALUES, AS READ FROM OBS. -C ERROR FILE, INTO THE PREPBUFR FILE? -C DOBERR = .TRUE. ---> YES (DEFAULT) -C DOBERR = .FALSE. ---> NO (VALUES REMAIN MISSING) -C (NOTE1: THIS WAS ADDED AS A TIME SAVING FEATURE IN THE -C RUC VERSION SINCE IT DOES NOT REQUIRE OBSERVATIONAL -C ERRORS TO BE PRESENT IN THE PREPBUFR FILE. THE GSI WILL -C REQUIRE THE OBS ERROR IN THE PREPBUFR FILE FOR THE ETA, -C UNLIKE THE 3DVAR WHICH DID NOT.) -C (NOTE2: IF DOANLS=TRUE, THEN DOBERR IS FORCED TO BE FALSE.) -C -C QTOP_REJ - THE PRESSURE LEVEL (IN MB) ABOVE WHICH ALL SPECIFIC -C HUMIDITY QUALITY MARKERS ARE "REJECTED" (THE QUALITY -C MARKER IS SET TO 9 ON ALL PRESSURE LEVELS LESS THAN -C THIS LEVEL) (DEFAULT=300.) -C -C SATMQC - PERFORM SPECIAL QUALITY CONTROL ON SATELLITE TEMPERATURE -C SOUNDINGS IN REPORT TYPES 160-179? -C SATMQC = .TRUE. ---> YES -C SATMQC = .FALSE. ---> NO (DEFAULT) -C (NOTE: THIS APPLIES ONLY TO THE CDAS OR HISTORICAL RE-RUNS -C WITH TEMPERATURE SOUNDINGS IN THESE REPORT TYPES) -C -CC -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE GBLEVENTS(IDATEP,IUNITF,IUNITE,IUNITP,IUNITS,SUBSET, - $ NEWTYP) - - CHARACTER*80 HEADR,OBSTR,FCSTR,OESTR,ANSTR - CHARACTER*8 SUBSET - REAL(8) OBS,BAK,SID,HDR(10) - LOGICAL DOVTMP,DOFCST,SOME_FCST,DOBERR,FCST,VIRT,DOANLS, - $ SATMQC,ADPUPA_VIRT - - DIMENSION IUNITF(2) - - COMMON /GBEVAA/ SID,OBS(12,255),BAK(12,255),NLEV,XOB,YOB,DHR,TYP - COMMON /GBEVBB/ PVCD,VTCD - COMMON /GBEVCC/ DOVTMP,DOFCST,SOME_FCST,DOBERR,FCST,VIRT, - $ QTOP_REJ,SATMQC,ADPUPA_VIRT - COMMON /GBEVDD/ ERRS(300,33,6) - - SAVE - - DATA IFIRST/0/ - - DATA HEADR / - $ 'SID XOB YOB DHR TYP '/ - DATA OBSTR / - $ 'POB QOB TOB ZOB UOB VOB PWO PW1O PW2O PW3O PW4O CAT '/ - DATA FCSTR / - $ 'PFC QFC TFC ZFC UFC VFC PWF PW1F PW2F PW3F PW4F NUL '/ - DATA ANSTR / - $ 'PAN QAN TAN ZAN UAN VAN PWA PW1A PW2A PW3A PW4A NUL '/ - DATA OESTR / - $ 'POE QOE TOE ZOE WOE PWE PW1E PW2E PW3E PW4E NUL NUL '/ - - NAMELIST /PREVDATA/DOVTMP,DOFCST,SOME_FCST,DOBERR,DOANLS, - $ QTOP_REJ,SATMQC,ADPUPA_VIRT - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - IF(IFIRST.EQ.0) THEN - -C ------------------------------- -C FIRST TIME IN DO A FEW THINGS... -C ------------------------------- - - IFIRST = 1 - PRINT 700 - 700 FORMAT(/1X,100('#')/' =====> SUBROUTINE GBLEVENTS INVOKED FOR ', - $ 'THE FIRST TIME - VERSION LAST UPDATED 2006-07-14'/) - -C INITIALIZE NAMELIST SWITCHES TO DEFAULT VALUES -C ---------------------------------------------- - - DOVTMP = .TRUE. - DOFCST = .TRUE. - SOME_FCST = .TRUE. - DOBERR = .TRUE. - DOANLS = .FALSE. - QTOP_REJ = 300. - SATMQC = .FALSE. - ADPUPA_VIRT = .FALSE. - READ(5,PREVDATA,ERR=101,END=102) - GO TO 103 -C----------------------------------------------------------------------- - 101 CONTINUE - -C ERROR READING STANDARD INPUT - THIS DEFAULTS TO POSTEVENTS MODE -C --------------------------------------------------------------- - - PRINT 7013 - 7013 FORMAT(/' ##> GBLEVENTS: ERROR READING STANDARD INPUT DATA CARDS', - $ ' -- DEFAULTS TO "POSTEVENTS" MODE'/) - DOANLS = .TRUE. - GO TO 103 - -C----------------------------------------------------------------------- - 102 CONTINUE - -C STANDARD INPUT IS EMPTY - THIS DEFAULTS TO POSTEVENTS MODE -C ---------------------------------------------------------- - - PRINT 7014 - 7014 FORMAT(/' ##> GBLEVENTS: STANDARD INPUT DATA CARDS DO NOT ', - $ 'EXIST -- DEFAULTS TO "POSTEVENTS" MODE'/) - DOANLS = .TRUE. - -C----------------------------------------------------------------------- - 103 CONTINUE - IF(DOANLS) THEN - DOVTMP = .FALSE. - DOFCST = .FALSE. - SOME_FCST = .FALSE. - DOBERR = .FALSE. - ADPUPA_VIRT = .FALSE. - ENDIF - WRITE (6,PREVDATA) - - FCST = DOFCST - VIRT = .FALSE. - -C CHECK VALID-TIME DATE OF GUESS/ANALYSIS FILE(S) AGAINST THE CENTER -C DATE FOR THE PREPBUFR FILE AND OBTAIN THE FIRST GUESS/ANALYSIS -C UNLESS ALL OF DOFCST, SOME_FCST, DOANLS ARE FALSE -C ------------------------------------------------------------------ - - IF(.NOT.DOANLS) THEN - IF(.NOT.DOFCST.AND..NOT.SOME_FCST) THEN - PRINT 901 - 901 FORMAT(/' --> GBLEVENTS: PREVENTS MODE - FIRST GUESS NOT READ ', - $ 'IN'/) - ELSE - PRINT 701 - 701 FORMAT(/' --> GBLEVENTS: PREVENTS MODE - DATE CHECK AND ', - $ 'TRANSFORM THE FIRST GUESS'/) - END IF - ELSE - PRINT 7701 - 7701 FORMAT(/' --> GBLEVENTS: POSTEVENTS MODE - DATE CHECK AND ', - $ 'TRANSFORM THE ANALYSIS'/) - END IF - - IF(DOFCST .OR. SOME_FCST .OR. DOANLS) - $ CALL GBLEVN10(IUNITF,IDATEP) - - IF(DOBERR) THEN - -C IF REQUESTED, READ ERROR FILES (ONLY POSSIBLE IN PREVENTS MODE) -C --------------------------------------------------------------- - - PRINT 702 - 702 FORMAT(/' --> GBLEVENTS: READ ERROR FILES'/) - - CALL GBLEVN01(IUNITE) - - ELSE - - ERRS = 0 - IF(.NOT.DOANLS) PRINT 3702 - 3702 FORMAT(/' --> GBLEVENTS: OBS. ERROR NOT ENCODED IN PREPBUFR ', - $ '(BY CHOICE)'/) - - END IF - -C OBTAIN NECESSARY PROGRAM CODES (ONLY USED IN PREVENTS MODE) -C ----------------------------------------------------------- - - CALL UFBQCD(IUNITP,'PREVENT',PVCD) - CALL UFBQCD(IUNITP,'VIRTMP ',VTCD) - - PRINT 703 - 703 FORMAT(/1X,100('#')/) - -C SET-UP OUTPUT "PREVENT" EVENTS DATA FILTERING SUMMARY PRINT FILE -C (ONLY USED IN PREVENTS MODE) -C ---------------------------------------------------------------- - - IF(.NOT.DOANLS) WRITE(IUNITS,1701) IDATEP - 1701 FORMAT(//130('#')//38X,'*** "PREVENT" EVENTS DATA FILTERING ', - $ 'SUMMARY ***'/35X,'--> CENTER DATE FOR PREPBUFR FILE IS: ',I10, - $ ' <--'//) - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - END IF - - IF(.NOT.DOANLS) THEN - - IF(NEWTYP.EQ.1) WRITE(IUNITS,1702) SUBSET - 1702 FORMAT(130('-')/39X,'--> SUMMARY FOR TABLE A ENTRY "',A8,'" <--'/) - - IF(.NOT.DOFCST .AND. SOME_FCST) FCST = (SUBSET.EQ.'ADPUPA ' - $ .OR.SUBSET.EQ.'PROFLR '.OR.SUBSET .EQ.'AIRCFT '.OR.SUBSET - $ .EQ.'AIRCAR '.OR.SUBSET .EQ.'VADWND ') - -C Will not subject ACARS reports to virtual temp. processing until -C spec. humidity is used in production - -ccccc VIRT = (SUBSET.EQ.'ADPSFC '.OR.SUBSET.EQ.'SFCSHP '.OR. -ccccc$ SUBSET.EQ.'MSONET '.OR.SUBSET.EQ.'AIRCAR '.OR. -ccccc$ SUBSET.EQ.'RASSDA '.OR.(SUBSET.EQ.'ADPUPA '.AND. -ccccc$ ADPUPA_VIRT))) - VIRT = (SUBSET.EQ.'ADPSFC '.OR.SUBSET.EQ.'SFCSHP '.OR. - $ SUBSET.EQ.'MSONET '.OR.SUBSET.EQ.'RASSDA '.OR. - $ (SUBSET.EQ.'ADPUPA '.AND.ADPUPA_VIRT)) - - - IF(.NOT.(FCST.OR.DOBERR.OR.VIRT)) THEN - IF(NEWTYP.EQ.1) WRITE(IUNITS,1703) - 1703 FORMAT(/' ==> DATA FILTERING NOT PERFORMED FOR THIS TABLE A ', - $ 'ENTRY -- FORECAST, OBS ERROR, "VIRTMP" PROCESSING NOT DONE'/) - RETURN - ENDIF - - END IF - -C READY TO RETRIEVE NECESSARY INFORMATION OUT OF THE NEXT REPORT WHICH -C HAS BEEN "UFB" ENCODED INTO THE PREPBUFR FILE BY THE CALLING PROGRAM -C (USE NEGATIVE UNIT NUMBER HERE SINCE FILE OPEN FOR OUTPUT) -C (NOTE: THE CALLING PROGRAM HAS NOT YET WRIITEN THE REPORT INTO -C THE PREPBUFR FILE VIA WRITSB!) -C ---------------------------------------------------------------- - - CALL UFBINT(-IUNITP,OBS,12,255,NLEV,OBSTR) - CALL UFBINT(-IUNITP,HDR,10, 1,IRET,HEADR) - SID = HDR(1) - XOB = HDR(2) - YOB = HDR(3) - DHR = HDR(4) - TYP = HDR(5) - - IF(FCST.OR.DOANLS) THEN - -C PREVENTS MODE: ENCODE FIRST GUESS VALUES INTO PREPBUFR FILE -C ------------------------------------------------------------ - -C POSTEVENTS MODE: ENCODE ANALYSIS VALUES INTO REPORT AND RETURN TO -C CALLING PROGRAM TO WRITE GBL-EVENTED REPORT -C (SUBSET) INTO PREPBUFR FILE -C ----------------------------------------------------------------- - - CALL GBLEVN03(SUBSET) - IF(NLEV.GT.0) THEN - IF(FCST) THEN - CALL UFBINT(IUNITP,BAK,12,NLEV,IRET,FCSTR) - ELSE - CALL UFBINT(IUNITP,BAK,12,NLEV,IRET,ANSTR) - RETURN - END IF - END IF - END IF - -C -------------------------------------------------------------------- -C LOGIC FROM HERE ON PERTAINS ONLY TO PREVENTS MODE OF THIS SUBROUTINE -C -------------------------------------------------------------------- - - - IF(DOBERR) THEN - -C ENCODE OBSERVATION ERRORS INTO REPORT -C ------------------------------------- - - CALL GBLEVN04 - IF(NLEV.GT.0) CALL UFBINT(IUNITP,BAK,12,NLEV,IRET,OESTR) - END IF - -C MAKE THE GBLEVENTS EVENTS AND ENCODE INTO REPORT -C ------------------------------------------------ - - IF(.NOT.FCST) THEN - IF(NEWTYP.EQ.1) WRITE(IUNITS,1704) - 1704 FORMAT(/' ==> FORECAST VALUES NOT ENCODED FOR THIS TABLE A ', - $ 'ENTRY'//' ==> FILTERING VIA POB VS. GESS PSFC TEST NOT ', - $ 'PERFORMED FOR THIS TABLE A ENTRY SINCE FORECAST VALUES NOT ', - $ 'PROCESSED/STORED'/) - ELSE - IF(NEWTYP.EQ.1) WRITE(IUNITS,1708) - 1708 FORMAT(/' ==> FORECAST VALUES ARE ENCODED FOR THIS TABLE A ', - $ 'ENTRY'//' ==> FILTERING VIA POB VS. GESS PSFC TEST IS ', - $ 'PERFORMED FOR THIS TABLE A ENTRY SINCE FORECAST VALUES ARE ', - $ 'PROCESSED/STORED'/) - ENDIF - - IF(.NOT.DOBERR) THEN - IF(NEWTYP.EQ.1) WRITE(IUNITS,1705) - 1705 FORMAT(/' ==> FILTERING VIA MISSING OBS ERROR TEST NOT POSSIBLE', - $ ' FOR THIS TABLE A ENTRY SINCE OBS ERROR VALUES NOT PROCESSED/', - $ 'STORED'/) - ENDIF - - CALL GBLEVN02(IUNITP,IUNITS,NEWTYP) - -C MAKE THE VIRTUAL TEMPERATURE EVENTS AND ENCODE INTO REPORT -C ---------------------------------------------------------- - - IF(.NOT.VIRT) THEN - IF(NEWTYP.EQ.1) WRITE(IUNITS,1706) - 1706 FORMAT(/' ==> "VIRTMP" EVENT PROCESSING NOT PERFORMED FOR THIS ', - $ 'TABLE A ENTRY'/) - ELSE - IF(NEWTYP.EQ.1) WRITE(IUNITS,1707) - 1707 FORMAT(/' ==> "VIRTMP" EVENT PROCESSING IS PERFORMED FOR THIS ', - $ 'TABLE A ENTRY'/) - CALL GBLEVN08(IUNITP,SUBSET) - ENDIF - -C RETURN TO CALLING PROGRAM TO WRITE GBL-EVENTED REPORT (SUBSET) INTO -C PREPBUFR FILE -C ------------------------------------------------------------------- - - RETURN - - END -C*********************************************************************** -C*********************************************************************** - SUBROUTINE GBLEVN01(IUNITE) ! FORMERLY SUBROUTINE ETABLE - - COMMON /GBEVDD/ ERRS(300,33,6) - -C READ THE OBSERVATION ERROR TABLES -C --------------------------------- - - REWIND IUNITE - - IREC = 0 - - 10 CONTINUE - READ(IUNITE,'(1X,I3)',END=100) KX - IREC = IREC + 1 - DO K=1,33 - READ(IUNITE,'(1X,6E12.5)') (ERRS(KX,K,M),M=1,6) - ENDDO - GO TO 10 - - 100 CONTINUE - IF(IREC.EQ.0) THEN - PRINT *, '##GBLEVENTS/GBLEVN01 - OBS. ERROR TABLE EMPTY OR ', - $ 'DOES NOT EXIST - STOP 60' - CALL ERREXIT(60) - END IF - - RETURN - - END -C*********************************************************************** -C*********************************************************************** - SUBROUTINE GBLEVN02(IUNITP,IUNITS,NEWTYP) - ! FORMERLY SUBROUTINE FILTAN - - DIMENSION NFLGRT(100:299,12) - CHARACTER*8 STNID - CHARACTER*40 PEVN,QEVN,TEVN,WEVN,PWVN,PW1VN,PW2VN,PW3VN,PW4VN - REAL(8) PEV(4,255),QEV(4,255),TEV(4,255),WEV(5,255), - $ PWV(4,255),PW1V(4,255),PW2V(4,255),PW3V(4,255), - $ PW4V(4,255),OBS,BAK,SID - LOGICAL FCST,DN2FAR,REJPS,REJT,REJQ,REJW,REJPW,REJPW1,REJPW2, - $ REJPW3,REJPW4,SATMQC,SATEMP,SOLN60,SOLS60 - - COMMON /GBEVAA/ SID,OBS(12,255),BAK(12,255),NLEV,XOB,YOB,DHR,TYP - COMMON /GBEVBB/ PVCD,VTCD - COMMON /GBEVCC/ DOVTMP,DOFCST,SOME_FCST,DOBERR,FCST,VIRT, - $ QTOP_REJ,SATMQC,ADPUPA_VIRT - COMMON /GBEVEE/PSG01,ZSG01,TG01(100),UG01(100),VG01(100), - x QG01(100),zint(100),pint(100),pintlog(100),plev(100), - x plevlog(100) - - EQUIVALENCE (SID,STNID) - - DATA PEVN /'POB PQM PPC PRC '/ - DATA QEVN /'QOB QQM QPC QRC '/ - DATA TEVN /'TOB TQM TPC TRC '/ - DATA WEVN /'UOB VOB WQM WPC WRC '/ - DATA PWVN /'PWO PWQ PWP PWR '/ - DATA PW1VN /'PW1O PW1Q PW1P PW1R '/ - DATA PW2VN /'PW2O PW2Q PW2P PW2R '/ - DATA PW3VN /'PW3O PW3Q PW3P PW3R '/ - DATA PW4VN /'PW4O PW4Q PW4P PW4R '/ - - DATA BMISS /10E10/,NFLGRT/2400*0/ - - NI = MOD((NINT(TYP)/10),10) - - IF(NEWTYP.EQ.1) NFLGRT = 0 - -C LOGICAL SWITCHES FOR OBSERVATION LOCATION FILTERING -C --------------------------------------------------- - - SATEMP = ((TYP.GE.160.AND.TYP.LE.179).AND.SATMQC) - SOLN60 = ((TYP.GE.160.AND.TYP.LE.163).AND.YOB.GE.-60.AND.SATMQC) - SOLS60 = ((TYP.EQ.160.OR.TYP.EQ.162.OR.TYP.EQ.163).AND.YOB.LT.-60 - $ .AND.SATMQC) - -C CLEAR THE EVENT ARRAYS -C ---------------------- - - PEV = BMISS - QEV = BMISS - TEV = BMISS - WEV = BMISS - PWV = BMISS - PW1V = BMISS - PW2V = BMISS - PW3V = BMISS - PW4V = BMISS - - MAXPEV = 0 - MAXQEV = 0 - MAXTEV = 0 - MAXWEV = 0 - MAXPWV = 0 - MAXPW1V = 0 - MAXPW2V = 0 - MAXPW3V = 0 - MAXPW4V = 0 - -C LOOP OVER LEVELS APPLYING UNDERGROUND FILTERING AND SPECIAL RULES -C ----------------------------------------------------------------- - - IF(NLEV.GT.0) THEN - DO L=1,NLEV - - POB = OBS( 1,L) - QOB = OBS( 2,L) - TOB = OBS( 3,L) - UOB = OBS( 5,L) - VOB = OBS( 6,L) - PWO = OBS( 7,L) - PW1O = OBS( 8,L) - PW2O = OBS( 9,L) - PW3O = OBS(10,L) - PW4O = OBS(11,L) - CAT = OBS(12,L) - - DN2FAR = .FALSE. - REJ = 9 - RCD = 9 - -C ------------------------------------------------------------------- -C RULES FOR PRESSURE (ON ANY LEVEL) -- ALL DATA ON LEVEL REJECTED IF: -C - PRESSURE MORE THAN 100 MB BELOW MODEL (GUESS) SURFACE PRESSURE -C (AND SWITCH FCST=TRUE) -- "PREVENT" PGM REASON CODE 1 -C - PRESSURE IS ZERO OR IS NEGATIVE -- "PREVENT" PGM REASON CODE 2 -C REJECTION MEANS Q.M. SET TO 8 -C ------------------------------------------------------------------- - - IF(POB.LT.BMISS) THEN - IF(.NOT.FCST) PSG01 = POB - IF(POB-PSG01.GE.100. .OR. POB.LE.0.) THEN - IF(POB.LE.0.) THEN - IF(NI.EQ.8) THEN - WRITE(IUNITS,302) STNID,NINT(TYP),YOB,XOB,POB - 302 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, - $'E, REJECT ALL DATA ON SFC LVL - POB=',F6.1,' MB, FAILS SANITY ', - $'CHECK') - ELSE - WRITE(IUNITS,101) STNID,NINT(TYP),YOB,XOB,POB - 101 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, - $'E, REJECT ALL DATA ON LVL - POB=',F6.1,' MB, FAILS SANITY CHECK') - ENDIF - RCD = 2 - ELSE - IF(NI.EQ.8) THEN - WRITE(IUNITS,303) STNID,NINT(TYP),YOB,XOB,POB,PSG01 - 303 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, - $ 'E, REJECT ALL DATA ON SFC LVL - POB=',F6.1,' MB, > 100 MB ', - $ 'BELOW GES PSFC(=',F6.1,'MB)') - ELSE - WRITE(IUNITS,102) STNID,NINT(TYP),YOB,XOB,POB,PSG01 - 102 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, - $ 'E, REJECT ALL DATA ON LVL - POB=',F6.1,' MB, > 100 MB BELOW ', - $ 'GES PSFC(=',F6.1,' MB)') - ENDIF - RCD = 1 - END IF - REJ = 8 - DN2FAR = .TRUE. - PEV(1,L) = POB - PEV(2,L) = REJ - PEV(3,L) = PVCD - PEV(4,L) = RCD - MAXPEV = L - ENDIF - ENDIF - -C ------------------------------------------------------------------- -C RULES FOR SURFACE PRESSURE -- ALL DATA ON SURFACE LEVEL REJECTED IF: -C - OBSERVATION ERROR IS MISSING (AND SWITCH DOBERR=TRUE) -- -C "PREVENT" PGM REASON CODE 3 -C - PRESSURE IS MORE THAN 100 MB ABOVE OR BELOW MODEL (GUESS) -C SURFACE PRESSURE (AND SWITCH FCST=TRUE) -- -C "PREVENT" PGM REASON CODE 4 -C - PRESSURE IS REPORTED ABOVE 450 MB OR BELOW 1100 MB -- "PREVENT" -C PGM REASON CODE 2 -C - PRESSURE VIOLATES RULES FOR PRESSURE ON ANY LEVEL (SEE ABOVE) -C REJECTION FOR ALL BUT LAST RULE MEANS Q.M. SET TO 9 -C REJECTION FOR LAST RULE MEANS Q.M. SET TO 8 -C ------------------------------------------------------------------- - - IF(POB.LT.BMISS .AND. CAT.EQ.0) THEN - IF(.NOT.FCST) PSG01 = POB - REJPS = OEFG01(POB,TYP,5).GE.BMISS .OR. - $ ABS(POB-PSG01).GE.100. .OR. - $ POB.LE.450. .OR. - $ POB.GE.1100. - IF(REJPS.OR.DN2FAR) THEN - IF(.NOT.DN2FAR) THEN - IF(OEFG01(POB,TYP,5).GE.BMISS) THEN - IF(NFLGRT(NINT(TYP),1).EQ.0) THEN - WRITE(IUNITS,201) NINT(TYP) - 201 FORMAT(/' --> FOR ALL REPORTS WITH REPORT TYPE ',I3,', REJECT ', - $ 'ALL DATA ON SURFACE LEVEL DUE TO MISSING SFC-P OBS ERROR'/) - NFLGRT(NINT(TYP),1) = 1 - ENDIF -CDAK CDAK CDAK CDAK WRITE(IUNITS,103) STNID,NINT(TYP),YOB,XOB,POB -CD103 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, -CDAK $ 'E, REJECT ALL DATA ON SFC LVL - POB=',F6.1,'MB, MISSING OBS.', -CDAK $ ' ERROR') - RCD = 3 - ELSE IF(ABS(POB-PSG01).GE.100.) THEN - WRITE(IUNITS,104) STNID,NINT(TYP),YOB,XOB,POB,PSG01 - 104 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, - $ 'E, REJECT ALL DATA ON SFC LVL - POB=',F6.1,' MB, > 100 MB ', - $ 'ABOVE GES PSFC(=',F6.1,'MB)') - RCD = 4 - ELSE - WRITE(IUNITS,105) STNID,NINT(TYP),YOB,XOB,POB - 105 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, - $ 'E, REJECT ALL DATA ON SFC LVL - POB=',F6.1,' MB, FAILS SANITY ', - $ 'CHECK') - RCD = 2 - ENDIF - ENDIF - DN2FAR = .TRUE. - PEV(1,L) = POB - PEV(2,L) = REJ - PEV(3,L) = PVCD - PEV(4,L) = RCD - MAXPEV = L - ENDIF - ENDIF - -C ------------------------------------------------------------------- -C RULES FOR TEMPERATURE -- TOB AND QOB ON LEVEL REJECTED IF: -C - OBSERVATION ERROR IS MISSING (AND SWITCH DOBERR=TRUE) -- -C "PREVENT" PGM REASON CODE 3 -C - REPORT IS TYPE 160-163 (LAND TOVS/RTOVS/ATOVS TEMPERATURE -C SOUNDINGS, ALL PATHS), AND IS AT OR NORTH OF 60 DEGREES SOUTH -C LATITUDE, AND PRESSURE ON LEVEL IS AT OR BELOW 100 MB (AND -C SWITCH SATMQC=TRUE) -- "PREVENT" PGM REASON CODE 6 -C - REPORT IS TYPE 160,162,163 (LAND TOVS/RTOVS/ATOVS TEMPERATURE -C SOUNDINGS, ALL PATHS BUT CLEAR), AND IS SOUTH OF 60 DEGREES -C SOUTH LATITUDE, AND PRESSURE ON LEVEL IS BELOW 100 MB (AND -C SWITCH SATMQC=TRUE) -- "PREVENT" PGM REASON CODE 6 -C - THIS IS SFC LEVEL AND PRESSURE VIOLATES RULES FOR SFC PRESSURE -C (SEE ABOVE) -C - PRESSURE ON LEVEL VIOLATES RULES FOR PRESSURE (SEE ABOVE) -C REJECTION FOR ALL BUT LAST RULE MEANS Q.M. SET TO 9 -C REJECTION FOR LAST RULE MEANS Q.M. SET TO 8 -C ------------------------------------------------------------------- - - IF(TOB.LT.BMISS) THEN - REJT = OEFG01(POB,TYP,2).GE.BMISS .OR. - $ (SOLN60.AND.NINT(POB*10.).GE.1000) .OR. - $ (SOLS60.AND.NINT(POB*10.).GT.1000) - IF(REJT.OR.DN2FAR) THEN - IF(.NOT.DN2FAR) THEN - IF(OEFG01(POB,TYP,2).GE.BMISS) THEN - IF(NFLGRT(NINT(TYP),2).EQ.0) THEN - IF(NI.EQ.8) THEN - WRITE(IUNITS,304) NINT(TYP) - 304 FORMAT(/' --> FOR ALL REPORTS WITH REPORT TYPE ',I3,', REJECT ', - $ 'TOB/QOB ON SFC LVL DUE TO MISSING OBS ERROR'/) - ELSE - WRITE(IUNITS,202) NINT(TYP) - 202 FORMAT(/' --> FOR ALL REPORTS WITH REPORT TYPE ',I3,', REJECT ', - $ 'TOB/QOB ON AT LEAST ONE LVL (IF AVAILABLE ON THAT LVL) DUE TO ', - $ 'MISSING OBS ERROR'/) - ENDIF - NFLGRT(NINT(TYP),2) = 1 -cdak cdak cdak cdak cdakWRITE(IUNITS,106) STNID,NINT(TYP),YOB,XOB,TOB -cd106 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, -cdak $ 'E, REJECT TOB/QOB ON LVL - TOB=',F5.1,'C, MISSING OBS. ERROR') - ENDIF - RCD = 3 - ELSE IF(SOLN60.AND.NINT(POB*10.).GE.1000) THEN - IF(NFLGRT(NINT(TYP),6).EQ.0) THEN - WRITE(IUNITS,7304) NINT(TYP) - 7304 FORMAT(/' --> FOR ALL REPORTS WITH REPORT TYPE ',I3,', REJECT ', - $'TOB/QOB AT AND BELOW 100 MB IF REPORT IS NORTH OF 60S LATITUDE'/) - NFLGRT(NINT(TYP),6) = 1 - ENDIF - RCD = 6 - ELSE IF(SOLS60.AND.NINT(POB*10.).GT.1000) THEN - IF(NFLGRT(NINT(TYP),7).EQ.0) THEN - WRITE(IUNITS,7305) NINT(TYP) - 7305 FORMAT(/' --> FOR ALL REPORTS WITH REPORT TYPE ',I3,', REJECT ', - $ 'TOB/QOB BELOW 100 MB IF REPORT IS SOUTH OF 60S LATITUDE'/) - NFLGRT(NINT(TYP),7) = 1 - ENDIF - RCD = 6 - ENDIF - ENDIF - TEV(1,L) = TOB - TEV(2,L) = REJ - TEV(3,L) = PVCD - TEV(4,L) = RCD - MAXTEV = L - ENDIF - ENDIF - -C ------------------------------------------------------------------- -C RULES FOR SPECIFIC HUMIDITY -- QOB ON LEVEL REJECTED IF: -C - OBSERVATION ERROR IS MISSING (AND SWITCH DOBERR=TRUE) -- -C "PREVENT" PGM REASON CODE 3 -C - TEMPERATURE ON LEVEL IS MISSING OR IS LESS THAN -150 DEG. C -- -C "PREVENT" PGM REASON CODE 2 -C - PRESSURE ON LEVEL IS ABOVE "QTOP_REJ" MB {WHERE QTOP_REJ IS -C READ IN FROM NAMELIST "PREVDATA" (SEE DOCBLOCK)} -- "PREVENT" -C PGM REASON CODE 5 -C - SPECIFIC HUMIDITY IS ZERO OR IS NEGATIVE -- "PREVENT" PGM REASON -C CODE 2 -C - REPORT IS TYPE 160-179 (SATELLITE TEMPERATURE SOUNDINGS, ALL -C TYPES, ALL PATHS, LAND AND SEA), ALL PRESSURE LEVELS (AND -C SWITCH SATMQC=TRUE) -- "PREVENT" PGM REASON CODE 7 -C - TEMPERATURE ON LEVEL VIOLATES RULES FOR TEMPERATURE (SEE ABOVE) -C - THIS IS SFC LEVEL AND PRESSURE VIOLATES RULES FOR SFC PRESSURE -C (SEE ABOVE) -C - PRESSURE ON LEVEL VIOLATES RULES FOR PRESSURE (SEE ABOVE) -C REJECTION FOR ALL BUT LAST RULE MEANS Q.M. SET TO 9 -C REJECTION FOR LAST RULE MEANS Q.M. SET TO 8 -C ------------------------------------------------------------------- - - IF(QOB.LT.BMISS) THEN - REJQ = OEFG01(POB,TYP,3).GE.BMISS .OR. - $ TOB.GE.BMISS .OR. - $ TOB.LE.-150. .OR. - $ NINT(POB * 10.).LT.NINT(QTOP_REJ * 10.) .OR. - $ QOB.LE.0. .OR. - $ SATEMP .OR. - $ REJT - IF(REJQ.OR.DN2FAR) THEN - IF(.NOT.DN2FAR.AND..NOT.REJT) THEN - IF(OEFG01(POB,TYP,3).GE.BMISS) THEN - IF(NFLGRT(NINT(TYP),3).EQ.0) THEN - IF(NI.EQ.8) THEN - WRITE(IUNITS,305) NINT(TYP) - 305 FORMAT(/' --> FOR ALL REPORTS WITH REPORT TYPE ',I3,', REJECT ', - $ 'QOB ON SFC LVL DUE TO MISSING OBS ERROR'/) - ELSE - WRITE(IUNITS,203) NINT(TYP) - 203 FORMAT(/' --> FOR ALL REPORTS WITH REPORT TYPE ',I3,', REJECT ', - $ 'QOB ON AT LEAST ONE LEVEL (IF AVAILABLE ON THAT LEVEL) DUE TO ', - $ 'MISSING OBS ERROR'/) - ENDIF - NFLGRT(NINT(TYP),3) = 1 - ENDIF -cdak cdak cdak cdak WRITE(IUNITS,108) STNID,NINT(TYP),YOB,XOB,QOB/1000. -cd108 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, -cdak $'E, REJECT QOB ON LVL - QOB=',F6.3,'G/KG, MISSING OBS. ERROR') - ELSE IF(NINT(POB*10.).LT.NINT(QTOP_REJ*10.)) THEN - WRITE(IUNITS,109) STNID,NINT(TYP),YOB,XOB, - $ QOB/1000.,QTOP_REJ,POB - 109 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, - $ 'E, REJECT QOB ON LVL - QOB=',F6.3,' G/KG, ABOVE ',F6.1, - $ 'MB (POB=',F6.1,' MB)') - RCD = 5 - ELSE IF(SATEMP) THEN - IF(NFLGRT(NINT(TYP),8).EQ.0) THEN - WRITE(IUNITS,7306) NINT(TYP) - 7306 FORMAT(/' --> FOR ALL REPORTS WITH REPORT TYPE ',I3,', REJECT ', - $ 'QOB ON ALL LEVELS'/) - NFLGRT(NINT(TYP),8) = 1 - ENDIF - RCD = 7 - ELSE - WRITE(IUNITS,111) STNID,NINT(TYP),YOB,XOB, - $ QOB/1000.,TOB - 111 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, - $ 'E, REJECT QOB ON LVL - QOB=',F6.3,' G/KG, FAILS SANITY CHECK ', - $ '(TOB=',F5.1,' C)') - RCD = 2 - ENDIF - ENDIF - QEV(1,L) = QOB - QEV(2,L) = REJ - QEV(3,L) = PVCD - QEV(4,L) = RCD - MAXQEV = L - ENDIF - ENDIF - -C ------------------------------------------------------------------- -C RULES FOR WINDS -- UOB AND VOB ON LEVEL REJECTED IF: -C - OBSERVATION ERROR IS MISSING (AND SWITCH DOBERR=TRUE) -- -C "PREVENT" PGM REASON CODE 3 -C - THIS IS SFC LEVEL AND PRESSURE VIOLATES RULES FOR SFC PRESSURE -C (SEE ABOVE) -C - PRESSURE ON LEVEL VIOLATES RULES FOR PRESSURE (SEE ABOVE) -C REJECTION FOR ALL BUT LAST RULE MEANS Q.M. SET TO 9 -C REJECTION FOR LAST RULE MEANS Q.M. SET TO 8 -C ------------------------------------------------------------------- - - IF(MIN(UOB,VOB).LT.BMISS) THEN - REJW = OEFG01(POB,TYP,4).GE.BMISS - IF(REJW.OR.DN2FAR) THEN - IF(.NOT.DN2FAR) THEN - IF(NFLGRT(NINT(TYP),4).EQ.0) THEN - IF(NI.EQ.8) THEN - WRITE(IUNITS,1304) NINT(TYP) - 1304 FORMAT(/' --> FOR ALL REPORTS WITH REPORT TYPE ',I3,', REJECT ', - $ 'UOB/VOB ON SFC LVL DUE TO MISSING OBS ERROR'/) - ELSE - WRITE(IUNITS,204) NINT(TYP) - 204 FORMAT(/' --> FOR ALL REPORTS WITH REPORT TYPE ',I3,', REJECT ', - $ 'UOB/VOB ON AT LEAST ONE LVL (IF AVAILABLE ON THAT LVL) DUE TO ', - $ 'MISSING OBS ERROR'/) - ENDIF - NFLGRT(NINT(TYP),4) = 1 - ENDIF -cdak cdak cdak WRITE(IUNITS,112) STNID,NINT(TYP),YOB,XOB -cd112 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, -cdak $'E, REJECT UOB/VOB ON LVL - MISSING OBS. ERROR') - RCD = 3 - ENDIF - WEV(1,L) = UOB - WEV(2,L) = VOB - WEV(3,L) = REJ - WEV(4,L) = PVCD - WEV(5,L) = RCD - MAXWEV = L - ENDIF - ENDIF - -C ------------------------------------------------------------------- -C RULES FOR TOTAL COLUMN PRECIPITABLE WATER -- PWO REJECTED IF: -C - OBSERVATION ERROR IS MISSING (AND SWITCH DOBERR=TRUE) -- -C "PREVENT" PGM REASON CODE 3 -C REJECTION MEANS Q.M. SET TO 9 -C ------------------------------------------------------------------- - - IF(PWO.LT.BMISS) THEN - REJPW = OEFG01(POB,TYP,6).GE.BMISS - IF(REJPW) THEN - IF(NFLGRT(NINT(TYP),5).EQ.0) THEN - WRITE(IUNITS,205) NINT(TYP) - 205 FORMAT(/' --> FOR ALL REPORTS WITH REPORT TYPE ',I3,', REJECT ', - $ 'PWO DUE TO MISSING OBS ERROR'/) - NFLGRT(NINT(TYP),5) = 1 - ENDIF -cdakcdakcdak WRITE(IUNITS,113) STNID,NINT(TYP),YOB,XOB,PWO -cd113 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, -cdak $'E, REJECT PWO ON LVL - PWO=',F5.1,'MM, MISSING OBS. ERROR') - PWV(1,L) = PWO - PWV(2,L) = 9 - PWV(3,L) = PVCD - PWV(4,L) = 3 - MAXPWV = L - ENDIF - ENDIF - -C ------------------------------------------------------------------- -C RULES FOR LAYER 1 PRECIPITABLE WATER -- PW1O REJECTED IF: -C - OBSERVATION ERROR IS MISSING (AND SWITCH DOBERR=TRUE) -- -C "PREVENT" PGM REASON CODE 3 -C REJECTION MEANS Q.M. SET TO 9 -C ------------------------------------------------------------------- - - IF(PW1O.LT.BMISS) THEN - REJPW1 = OEFG01(POB,TYP,6).GE.BMISS - IF(REJPW1) THEN - IF(NFLGRT(NINT(TYP),9).EQ.0) THEN - WRITE(IUNITS,206) NINT(TYP) - 206 FORMAT(/' --> FOR ALL REPORTS WITH REPORT TYPE ',I3,', REJECT ', - $ 'PW1O DUE TO MISSING OBS ERROR'/) - NFLGRT(NINT(TYP),9) = 1 - ENDIF -cdakcdakcdak WRITE(IUNITS,114) STNID,NINT(TYP),YOB,XOB,PW1O -cd114 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, -cdak $'E, REJECT PW1O ON LVL - PW1O=',F5.1,'MM, MISSING OBS. ERROR') - PW1V(1,L) = PW1O - PW1V(2,L) = 9 - PW1V(3,L) = PVCD - PW1V(4,L) = 3 - MAXPW1V = L - ENDIF - ENDIF - -C ------------------------------------------------------------------- -C RULES FOR LAYER 2 PRECIPITABLE WATER -- PW2O REJECTED IF: -C - OBSERVATION ERROR IS MISSING (AND SWITCH DOBERR=TRUE) -- -C "PREVENT" PGM REASON CODE 3 -C REJECTION MEANS Q.M. SET TO 9 -C ------------------------------------------------------------------- - - IF(PW2O.LT.BMISS) THEN - REJPW2 = OEFG01(POB,TYP,6).GE.BMISS - IF(REJPW2) THEN - IF(NFLGRT(NINT(TYP),10).EQ.0) THEN - WRITE(IUNITS,207) NINT(TYP) - 207 FORMAT(/' --> FOR ALL REPORTS WITH REPORT TYPE ',I3,', REJECT ', - $ 'PW2O DUE TO MISSING OBS ERROR'/) - NFLGRT(NINT(TYP),10) = 1 - ENDIF -cdakcdakcdak WRITE(IUNITS,115) STNID,NINT(TYP),YOB,XOB,PW2O -cd115 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, -cdak $'E, REJECT PW2O ON LVL - PW2O=',F5.1,'MM, MISSING OBS. ERROR') - PW2V(1,L) = PW2O - PW2V(2,L) = 9 - PW2V(3,L) = PVCD - PW2V(4,L) = 3 - MAXPW2V = L - ENDIF - ENDIF - -C ------------------------------------------------------------------- -C RULES FOR LAYER 3 PRECIPITABLE WATER -- PW3O REJECTED IF: -C - OBSERVATION ERROR IS MISSING (AND SWITCH DOBERR=TRUE) -- -C "PREVENT" PGM REASON CODE 3 -C REJECTION MEANS Q.M. SET TO 9 -C ------------------------------------------------------------------- - - IF(PW3O.LT.BMISS) THEN - REJPW3 = OEFG01(POB,TYP,6).GE.BMISS - IF(REJPW3) THEN - IF(NFLGRT(NINT(TYP),11).EQ.0) THEN - WRITE(IUNITS,208) NINT(TYP) - 208 FORMAT(/' --> FOR ALL REPORTS WITH REPORT TYPE ',I3,', REJECT ', - $ 'PW3O DUE TO MISSING OBS ERROR'/) - NFLGRT(NINT(TYP),11) = 1 - ENDIF -cdakcdakcdak WRITE(IUNITS,116) STNID,NINT(TYP),YOB,XOB,PW3O -cd116 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, -cdak $'E, REJECT PW3O ON LVL - PW3O=',F5.1,'MM, MISSING OBS. ERROR') - PW3V(1,L) = PW3O - PW3V(2,L) = 9 - PW3V(3,L) = PVCD - PW3V(4,L) = 3 - MAXPW3V = L - ENDIF - ENDIF - -C ------------------------------------------------------------------- -C RULES FOR LAYER 4 PRECIPITABLE WATER -- PW4O REJECTED IF: -C - OBSERVATION ERROR IS MISSING (AND SWITCH DOBERR=TRUE) -- -C "PREVENT" PGM REASON CODE 3 -C REJECTION MEANS Q.M. SET TO 9 -C ------------------------------------------------------------------- - - IF(PW4O.LT.BMISS) THEN - REJPW4 = OEFG01(POB,TYP,6).GE.BMISS - IF(REJPW4) THEN - IF(NFLGRT(NINT(TYP),12).EQ.0) THEN - WRITE(IUNITS,209) NINT(TYP) - 209 FORMAT(/' --> FOR ALL REPORTS WITH REPORT TYPE ',I3,', REJECT ', - $ 'PW4O DUE TO MISSING OBS ERROR'/) - NFLGRT(NINT(TYP),12) = 1 - ENDIF -cdakcdakcdak WRITE(IUNITS,117) STNID,NINT(TYP),YOB,XOB,PW4O -cd117 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, -cdak $'E, REJECT PW4O ON LVL - PW4O=',F5.1,'MM, MISSING OBS. ERROR') - PW4V(1,L) = PW4O - PW4V(2,L) = 9 - PW4V(3,L) = PVCD - PW4V(4,L) = 3 - MAXPW4V = L - ENDIF - ENDIF - - ENDDO - ENDIF - -C APPLY THE PROPER EVENTS -C ----------------------- - - IF(MAXPEV .GT.0) CALL UFBINT(IUNITP,PEV, 4,MAXPEV, IRET,PEVN) - IF(MAXQEV .GT.0) CALL UFBINT(IUNITP,QEV, 4,MAXQEV, IRET,QEVN) - IF(MAXTEV .GT.0) CALL UFBINT(IUNITP,TEV, 4,MAXTEV, IRET,TEVN) - IF(MAXWEV .GT.0) CALL UFBINT(IUNITP,WEV, 5,MAXWEV, IRET,WEVN) - IF(MAXPWV .GT.0) CALL UFBINT(IUNITP,PWV, 4,MAXPWV, IRET,PWVN) - IF(MAXPW1V.GT.0) CALL UFBINT(IUNITP,PW1V,4,MAXPW1V,IRET,PW1VN) - IF(MAXPW2V.GT.0) CALL UFBINT(IUNITP,PW2V,4,MAXPW2V,IRET,PW2VN) - IF(MAXPW3V.GT.0) CALL UFBINT(IUNITP,PW3V,4,MAXPW3V,IRET,PW3VN) - IF(MAXPW4V.GT.0) CALL UFBINT(IUNITP,PW4V,4,MAXPW4V,IRET,PW4VN) - - RETURN - END -C*********************************************************************** -C*********************************************************************** -C GBLEVN03 - INTERPOLATE MODEL DATA (FIRST GUESS OR ANALYSIS) TO OB -C LOCATIONS -C----------------------------------------------------------------------- - SUBROUTINE GBLEVN03(SUBSET) ! FORMERLY SUBROUTINE GETFC - - REAL(8) OBS,BAK,SID - CHARACTER*8 SUBSET - - COMMON /GBEVAA/ SID,OBS(12,255),BAK(12,255),NLEV,XOB,YOB,DHR,TYP - COMMON /GBEVFF/IMAX,JMAX,KMAX,kmaxs,DLAT,DLON,IDVC,SL(100),SI(101) - COMMON /GBEVEE/PSG01,ZSG01,TG01(100),UG01(100),VG01(100), - x QG01(100),zint(100),pint(100),pintlog(100),plev(100), - x plevlog(100) - - - DATA BMISS / 10E10 / - DATA TZERO / 273.15 / - DATA BETAP / .0552 / - DATA BETA / .00650 / - DATA ROG / 29.261 / - -C CLEAR THE BACKGROUND EVENT ARRAY -C -------------------------------- - - BAK = BMISS - -C GET GUESS PROFILE AT OB LOCATION -C -------------------------------- - CALL GBLEVN06(XOB,YOB) - - -C INTERPOLATE GUESS PROFILES TO OB PRESSURES -C ------------------------------------------ - - IF(NLEV.GT.0) THEN - DO 10 L=1,NLEV - - POB = OBS( 1,L) - QOB = OBS( 2,L) - TOB = OBS( 3,L) - ZOB = OBS( 4,L) - UOB = OBS( 5,L) - VOB = OBS( 6,L) - PWO = OBS( 7,L) - PW1O = OBS( 8,L) - PW2O = OBS( 9,L) - PW3O = OBS(10,L) - PW4O = OBS(11,L) - CAT = OBS(12,L) - - IF(POB.LE.0. .OR. POB.GE.BMISS) GOTO 10 - - poblog = log(pob) - - la = -999 - lb = -999 - do k=1,kmax-1 - if (poblog<=plevlog(k) .and. poblog>plevlog(k+1)) then - la = k - lb = k+1 - exit - endif - end do - if (la > 0) then - wt = (poblog-plevlog(lb)) / (plevlog(la)-plevlog(lb)) - else - la = 1 - lb = la+1 - wt = 0.0 - endif - - li=0 - do k=1,kmax-1 - if (poblog<=pintlog(k) .and. poblog>pintlog(k+1)) then - li = k - exit - endif - end do - -C SURFACE PRESSURE -C ---------------- - - IF(CAT.EQ.0 .AND. ZOB.LT.BMISS) THEN - TS = TG01(1) + (PSG01-PLEV(1))*BETAP - DZ = ZOB-ZSG01 - TM = TS - DZ*BETA*.5 - PFC = PSG01*EXP(-DZ/(TM*ROG)) - ELSE - PFC = BMISS - ENDIF - -C SPECIFIC HUMIDITY -C ----------------- - - IF(QOB.LT.BMISS.OR.TOB.LT.BMISS.OR.TYP.EQ.111) THEN - -C (QFC NEEDED BY SYNDATA PROGRAM BUT ONLY FOR REPORT TYPE 111) - - QOB = QG01(LB) + (QG01(LA)-QG01(LB))*WT - ENDIF - -C TEMPERATURE -C ----------- - - IF(TOB.LT.BMISS.OR.SUBSET.EQ.'VADWND '.OR.TYP.EQ.111) THEN - -C (TFC NEEDED BY CQCVAD AND SYNDATA PROGRAMS, LATTER ONLY FOR REPORT -C TYPE 111) - - IF(POB.GT.PLEV(1)) THEN - TOB = TG01(1) + (POB-PLEV(1))*BETAP - ELSE - TOB = TG01(LB) + (TG01(LA)-TG01(LB))*WT - ENDIF - TOB = TOB - TZERO - ENDIF - -C HEIGHT -C ------ - - IF(ZOB.LT.BMISS) THEN - IF(POB.GT.PLEV(1)) THEN - TM = TG01(1) + (.5*(PINT(1)+POB)-PLEV(1))*BETAP - ZOB = ZINT(1) - ROG*TM*LOG(POB/PINT(1)) - ELSE - TM = TG01(LB) + (TG01(LA)-TG01(LB))*WT - ZOB = ZINT(LI) - ROG*TM*LOG(POB/PINT(LI)) - ENDIF - ENDIF - -C U AND V COMPONENTS -C ------------------ - - IF(UOB.LT.BMISS .OR. VOB.LT.BMISS) THEN - UOB = UG01(LB) + (UG01(LA)-UG01(LB))*WT - VOB = VG01(LB) + (VG01(LA)-VG01(LB))*WT - ENDIF - - -C PRECIPITABLE WATER -C ------------------ - - PWO = BMISS - PW1O = BMISS - PW2O = BMISS - PW3O = BMISS - PW4O = BMISS - -C RELATIVE HUMIDITY -C ----------------- - - RHO = BMISS - -C SCATTER THE PROPER FIRST GUESS/ANALYSIS VALUES -C ---------------------------------------------- - - BAK(1,L) = PFC - BAK(2,L) = QOB - BAK(3,L) = TOB - BAK(4,L) = ZOB - BAK(5,L) = UOB - BAK(6,L) = VOB - BAK(7,L) = PWO - BAK(8,L) = PW1O - BAK(9,L) = PW2O - BAK(10,L) = PW3O - BAK(11,L) = PW4O - BAK(12,L) = RHO - - 10 ENDDO - ENDIF - - RETURN - END -C*********************************************************************** -C*********************************************************************** - SUBROUTINE GBLEVN04 ! FORMERLY SUBROUTINE GETOE - - REAL(8) OBS,BAK,SID - - COMMON /GBEVAA/ SID,OBS(12,255),BAK(12,255),NLEV,XOB,YOB,DHR,TYP - - DATA BMISS /10E10/ - -C CLEAR THE EVENT ARRAY -C --------------------- - - BAK = BMISS - -C LOOP OVER LEVELS LOOKING UP THE OBSERVATION ERROR -C ------------------------------------------------- - - IF(NLEV.GT.0) THEN - DO L=1,NLEV - - POB = OBS( 1,L) - QOB = OBS( 2,L) - TOB = OBS( 3,L) - WOB = MAX(OBS(5,L),OBS(6,L)) - PWO = OBS( 7,L) - PW1O = OBS( 8,L) - PW2O = OBS( 9,L) - PW3O = OBS(10,L) - PW4O = OBS(11,L) - CAT = OBS(12,L) - - IF(CAT .EQ.0 ) BAK( 1,L) = OEFG01(POB,TYP,5) - IF(QOB .LT.BMISS) BAK( 2,L) = OEFG01(POB,TYP,3) - IF(TOB .LT.BMISS) BAK( 3,L) = OEFG01(POB,TYP,2) - IF(WOB .LT.BMISS) BAK( 5,L) = OEFG01(POB,TYP,4) - IF(PWO .LT.BMISS) BAK( 6,L) = OEFG01(POB,TYP,6) - IF(PW1O.LT.BMISS) BAK( 7,L) = OEFG01(POB,TYP,6) - IF(PW2O.LT.BMISS) BAK( 8,L) = OEFG01(POB,TYP,6) - IF(PW3O.LT.BMISS) BAK( 9,L) = OEFG01(POB,TYP,6) - IF(PW4O.LT.BMISS) BAK(10,L) = OEFG01(POB,TYP,6) - - ENDDO - ENDIF - - RETURN - END -C*********************************************************************** -C*********************************************************************** -C SUBROUTINE GBLEVN05 - GUSER (GBLEVN10) USER INTERFACE FOR -C PREPFIT (PSG01,ZSG01,TG01,UG01,VG01) -C----------------------------------------------------------------------- - SUBROUTINE GBLEVN05(GRD,IQ,LEV) ! FORMERLY SUBROUTINE GUSER - - COMMON /GBEVFF/IMAX,JMAX,KMAX,kmaxs,DLAT,DLON,IDVC,SL(100),SI(101) - - DIMENSION GRD(IMAX,JMAX,2) - -C PACK 2D FIRST GUESS/ANALYSIS FIELD INTO BIT PACKED ARRAYS -C --------------------------------------------------------- - - IF(IQ.EQ.1) THEN - DO J=1,JMAX - DO I=1,IMAX - CALL GBLEVN12(I,J,GRD(I,J,1)) - ENDDO - ENDDO - ELSEIF(IQ.EQ.2) THEN - DO J=1,JMAX - DO I=1,IMAX - CALL GBLEVN13(I,J,GRD(I,J,1)) - ENDDO - ENDDO - ELSEIF(IQ.EQ.3) THEN - DO J=1,JMAX - DO I=1,IMAX - CALL GBLEVN14(I,J,LEV,GRD(I,J,1)) - ENDDO - ENDDO - ELSEIF(IQ.EQ.4) THEN - DO J=1,JMAX - DO I=1,IMAX - CALL GBLEVN15(I,J,LEV,GRD(I,J,1)) - CALL GBLEVN16(I,J,LEV,GRD(I,J,2)) - ENDDO - ENDDO - ELSEIF(IQ.EQ.5) THEN - DO J=1,JMAX - DO I=1,IMAX - CALL GBLEVN17(I,J,LEV,MAX(0.,GRD(I,J,1))*1E6) - ENDDO - ENDDO - ENDIF - - RETURN - END -C*********************************************************************** -C*********************************************************************** -C SUBROUTINE GBLEVN06 - 2D LINEAR HORIZONTAL INTERPOLATION -C----------------------------------------------------------------------- - SUBROUTINE GBLEVN06(XOB,YOB) ! FORMERLY SUBROUTINE HTERP - REAL KAP1,KAPR - - - COMMON /GBEVFF/IMAX,JMAX,KMAX,kmaxs,DLAT,DLON,IDVC,SL(100),SI(101) - COMMON /GBEVEE/ PSI,ZSI,TI(100),UI(100),VI(100),QI(100), - x zint(100),pint(100),pintlog(100),plev(100),plevlog(100) - - DATA ROG / 29.261 / - DATA KAP1 / 1.2857 /, KAPR / 3.4997 / - - -C CALCULATE HORIZONTAL WEIGHTS AND INTERPOLATE -C -------------------------------------------- - - WX = XOB/DLON + 1.0 - I0 = WX - I1 = MOD(I0,IMAX) + 1 - WX = WX-I0 - - WY = (YOB+90.)/DLAT + 1.0 - J0 = WY - J1 = MIN(J0+1,JMAX) - WY = WY-J0 - -C HTERP FOR SURFACE HEIGHT -C ------------------------ - - P1 = ZSG01(I0,J0) - P2 = ZSG01(I0,J1) - P3 = ZSG01(I1,J0) - P4 = ZSG01(I1,J1) - P5 = P1+(P2-P1)*WY - P6 = P3+(P4-P3)*WY - ZSI = P5+(P6-P5)*WX - -C HTERP FOR SURFACE PRESSURE -C -------------------------- - - P1 = PSG01(I0,J0) - P2 = PSG01(I0,J1) - P3 = PSG01(I1,J0) - P4 = PSG01(I1,J1) - P5 = P1+(P2-P1)*WY - P6 = P3+(P4-P3)*WY - PSI = P5+(P6-P5)*WX - -C HTERP FOR UPA T,U,V,Q -C --------------------- - - DO K=1,KMAX - - P1 = TG01(I0,J0,K) - P2 = TG01(I0,J1,K) - P3 = TG01(I1,J0,K) - P4 = TG01(I1,J1,K) - P5 = P1+(P2-P1)*WY - P6 = P3+(P4-P3)*WY - TI(K) = P5+(P6-P5)*WX - - P1 = UG01(I0,J0,K) - P2 = UG01(I0,J1,K) - P3 = UG01(I1,J0,K) - P4 = UG01(I1,J1,K) - P5 = P1+(P2-P1)*WY - P6 = P3+(P4-P3)*WY - UI(K) = P5+(P6-P5)*WX - - P1 = VG01(I0,J0,K) - P2 = VG01(I0,J1,K) - P3 = VG01(I1,J0,K) - P4 = VG01(I1,J1,K) - P5 = P1+(P2-P1)*WY - P6 = P3+(P4-P3)*WY - VI(K) = P5+(P6-P5)*WX - - P1 = QG01(I0,J0,K) - P2 = QG01(I0,J1,K) - P3 = QG01(I1,J0,K) - P4 = QG01(I1,J1,K) - P5 = P1+(P2-P1)*WY - P6 = P3+(P4-P3)*WY - QI(K) = P5+(P6-P5)*WX - - ENDDO - -c Compute interface pressures and heights - zint(1) = zsi - pint(1) = psi - pintlog(1) = log(pint(1)) - do k=2,kmax - k0 = k-1 - if(idvc.eq.1) then - pint(k) = psi*si(k) - else if(idvc.eq.2) then - pint(k)=si(k)+sl(k)*psi - end if - zint(k) = zint(k0) - rog*ti(k0)*log(pint(k)/pint(k0)) - pintlog(k) = log(pint(k)) - enddo - pint(kmax+1) = 0.0 - -C Compute pressure at layer midpoints - do k=1,kmax - if (idvc.eq.1) then - plev(k) = psi*sl(k) - else if (idvc.eq.2) then - plev(k) = ((PINT(k)**KAP1-PINT(k+1)**KAP1)/ - $ (KAP1*(PINT(k)-PINT(k+1))))**KAPR - endif - plevlog(k) = log(plev(k)) - end do - - - RETURN - END -C*********************************************************************** -C*********************************************************************** - FUNCTION OEFG01(P,TYP,IE) ! FORMERLY FUNCTION OEF - - COMMON /GBEVDD/ERRS(300,33,6) - - OEFG01 = 10E10 - KX = TYP - -C LOOK UP ERRORS FOR PARTICULAR OB TYPES -C -------------------------------------- - - IF(IE.GE.2 .AND. IE.LE.4) THEN - DO LA=1,33 - IF(P.GE.ERRS(KX,LA,1)) GOTO 10 - ENDDO - 10 CONTINUE - LB = LA-1 - IF(LB.EQ.33) LA = 6 - IF(LB.EQ.33) LB = 5 - IF(LB.EQ. 0) THEN - OEFG01 = ERRS(KX,1,IE) - ELSE - DEL = (P-ERRS(KX,LB,1))/(ERRS(KX,LA,1)-ERRS(KX,LB,1)) - OEFG01 = (1.-DEL)*ERRS(KX,LB,IE) + DEL*ERRS(KX,LA,IE) - ENDIF - ELSEIF(IE.EQ.5) THEN - OEFG01 = ERRS(KX,1,5) - ELSEIF(IE.EQ.6) THEN - OEFG01 = ERRS(KX,1,6) - ENDIF - -C SET MISSING ERROR VALUE TO 10E10 -C -------------------------------- - - IF(OEFG01.GE.5E5) OEFG01 = 10E10 - - RETURN - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GBLEVN08 CALCULATE SPEC. HUMIDITY AND VIRTUAL TEMP -C PRGMMR: D.A. KEYSER ORG: NP22 DATE: 2006-07-14 -C -C ABSTRACT: CREATE VIRTUAL TEMPERATURE EVENTS WITHIN GBLEVENTS -C SUBROUTINE. FOR ALL TYPES EXCEPT RASS, THIS CONSISTS OF FIRST RE- -C CALCULATING THE SPECIFIC HUMIDITY FROM THE REPORTED DEWPOINT -C TEMPERATURE AND PRESSURE, FOLLOWED BY THE CALCULATION OF VIRTUAL -C TEMPERATURE FROM THE JUST-CALCULATED SPECIFIC HUMIDITY AND THE -C REPORTED (SENSIBLE) TEMPERATURE. THE RE-CALCULATED SPECIFIC -C HUMIDITY IS THEN ENCODED AS A STACKED EVENT TO BE LATER WRITTEN -C INTO THE PREPBUFR FILE (UNDER PROGRAM "VIRTMP", REASON CODE 0). -C IF THE NAMELIST SWITCH DOVTMP IS TRUE, THEN THE JUST-CALCULATED -C VIRTUAL TEMPERATURE IS THEN ALSO ENCODED AS A STACKED EVENT TO BE -C LATER WRITTEN INTO THE PREPBUFR FILE (UNDER PROGRAM "VIRTMP", -C REASON CODE 0, 2 OR 6). FOR RASS DATA, SPECIFIC HUMIDITY IS -C MISSING HOWEVER IF THE NAMELIST SWITCH DOVTMP IS TRUE, A SIMPLE -C COPY OF THE REPORTED (VIRTUAL) TEMPERATURE IS ENCODED AS A STACKED -C EVENT TO BE LATER WRITTEN INTO THE PREPBUFR FILE (UNDER PROGRAM -C "VIRTMP", REASON CODE 3). THIS SUBROUTINE IS CURRENTLY ONLY -C CALLED FOR SURFACE LAND ("ADPSFC"), MARINE ("SFCSHP"), MESONET -C ("MSONET") OR RASS ("RASSDA") DATA TYPES WHEN SWITCH "ADPUPA_VIRT" -C IS FALSE AND ONLY FOR SURFACE LAND ("ADPSFC"), MARINE ("SFCSHP"), -C MESONET ("MSONET"), RASS ("RASSDA"), RAOB/DROP/MULTI-LVL RECCO -C ("ADPUPA") DATA TYPES WHEN SWITCH "ADPUPA_VIRT" IS TRUE. IT IS -C ALSO ONLY CALLED IN THE PREVENTS MODE. THIS ROUTINE IS CALLED ONCE -C FOR EACH VALID REPORT IN THE PREPBUFR FILE. -C -C PROGRAM HISTORY LOG: -C 1995-05-17 J. WOOLLEN (NP20) - ORIGINAL AUTHOR -C 1997-06-01 D.A. KEYSER - STREAMLINED, ADDED SWITCH DOVTMP -C 1999-12-01 D. A. KEYSER -- SPEC. HUMIDITY AND VIRT. TEMPERATURE ARE -C NOW CALCULATED WHEN SPEC. HUMIDITY QUAL. MARKER IS BAD (SUBJECT -C TO A SANITY CHECK), HOWEVER THE VIRT. TEMPERATURE GETS A BAD -C QUAL. MARKER (8) -C 2004-08-30 D. A. KEYSER -- FOR "RASSDA" TYPES, ENCODES A SIMPLE COPY -C OF THE REPORTED (VIRTUAL) TEMPERATURE AS A "VIRTMP" EVENT IF -C DOVTMP IS TRUE, GETS NEW REASON CODE 3 -C 2006-07-14 D. A. KEYSER -- PROCESSES REPORTS IN MESSAGE TYPE ADPUPA -C (I.E., RAOBS, DROPS, MULTI-LEVEL RECCOS) WITH SAME LOGIC AS IN -C SUBROUTINE VTPEVN OF PROGRAM PREPOBS_CQCBUFR WHEN NEW NAMELIST -C SWITCH "ADPUPA_VIRT" IS TRUE {NORMALLY "ADPUPA_VIRT" IS FALSE -C (DEFAULT) BECAUSE SUBSEQUENT PROGRAM PREPOBS_CQCBUFR PERFORMS -C THIS FUNCTION} -C -C USAGE: CALL GBLEVN08(IUNITP) -C INPUT ARGUMENT LIST: -C IUNITP - BUFR OUTPUT FILE UNIT -C SUBSET - THE BUFR MESSAGE TABLE A ENTRY FOR THE PARTICULAR -C - REPORT BEING PROCESSED -C -C REMARKS: WILL IMMEDIATELY RETURN TO CALLING PROGRAM IF ANY OF THE -C FOLLOWING CONDITIONS EXIST: THERE ARE NO LEVELS OF VALID DEWPOINT, -C OBS, TEMPERATURE Q.M. OR SPEC. HUMIDITY Q.M. IN THE INPUT PREPBUFR -C FILE FOR THE REPORT. WILL NOT ATTEMPT EITHER SPEC. HUMIDITY NOR -C VIRT. TEMP CALC. ON A GIVEN LEVEL IF ANY OF THE FOLLOWING -C CONDITIONS EXIST: REPORTED PRESSURE OBS IS MISSING, REPORTED -C (SENSIBLE) TEMPERATURE OBS IS MISSING, OR REPORTED DEWPOINT OBS IS -C MISSING. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE GBLEVN08(IUNITP,SUBSET) ! FORMERLY SUBROUTINE VTPEVN - - CHARACTER*80 EVNSTQ,EVNSTV - CHARACTER*8 SUBSET - REAL(8) TDP(255),TQM(255),QQM(255),BAKQ(4,255),BAKV(4,255), - $ OBS,BAK,SID - - LOGICAL EVNQ,EVNV,DOVTMP,TROP - - COMMON /GBEVAA/ SID,OBS(12,255),BAK(12,255),NLEV,XOB,YOB,DHR,TYP - COMMON /GBEVBB/ PVCD,VTCD - COMMON /GBEVCC/ DOVTMP,DOFCST,SOME_FCST,DOBERR,FCST,VIRT, - $ QTOP_REJ,SATMQC,ADPUPA_VIRT - - DATA EVNSTQ /'QOB QQM QPC QRC'/ - DATA EVNSTV /'TOB TQM TPC TRC'/ - DATA BMISS /10E10/ - -C----------------------------------------------------------------------- -C FCNS BELOW CONVERT TEMP/TD (K) & PRESS (MB) INTO SAT./ SPEC. HUM.(G/G) -C----------------------------------------------------------------------- - ES(T) = 6.1078*EXP((17.269*(T - 273.16))/((T - 273.16)+237.3)) - QS(T,P) = (0.622*ES(T))/(P-(0.378*ES(T))) -C----------------------------------------------------------------------- - -C CLEAR TEMPERATURE AND SPECIFIC HUMIDITY EVENTS -C ---------------------------------------------- - - EVNQ = .FALSE. - EVNV = .FALSE. - BAKQ = BMISS - BAKV = BMISS - TROP = .FALSE. - -C GET DEWPOINT TEMPERATURE AND CURRENT T,Q QUALITY MARKERS -C -------------------------------------------------------- - - CALL UFBINT(-IUNITP,TDP,1,255,NLTD,'TDO') - CALL UFBINT(-IUNITP,QQM,1,255,NLQQ,'QQM') - CALL UFBINT(-IUNITP,TQM,1,255,NLTQ,'TQM') - IF(SUBSET.NE.'RASSDA ') THEN - IF(NLTD.EQ.0) RETURN - IF(NLQQ.EQ.0) RETURN - END IF - IF(NLTQ.EQ.0) RETURN - IF(SUBSET.NE.'RASSDA ') THEN - IF(NLTD.NE.NLEV) THEN - PRINT *, '##GBLEVENTS/GBLEVN08 - NLTD .NE. NLEV - STOP 61' - CALL ERREXIT(61) - END IF - IF(NLQQ.NE.NLEV) THEN - PRINT *, '##GBLEVENTS/GBLEVN08 - NLQQ .NE. NLEV - STOP 63' - CALL ERREXIT(63) - END IF - END IF - IF(NLTQ.NE.NLEV) THEN - PRINT *, '##GBLEVENTS/GBLEVN08 - NLTQ .NE. NLEV - STOP 62' - CALL ERREXIT(62) - END IF - -C COMPUTE VIRTUAL TEMPERATURE AND SPECIFIC HUMIDITY USING REPORTED DEWP -C --------------------------------------------------------------------- - - IF(NLEV.GT.0) THEN - DO L=1,NLEV - POB = OBS(1,L) - TDO = TDP(L) - TOB = OBS(3,L) - CAT = OBS(12,L) - IF(DOVTMP) THEN - IF(SUBSET.EQ.'RASSDA ') THEN - IF(TOB.LT.BMISS) THEN - BAKV(1,L) = TOB - BAKV(2,L) = TQM(L) - BAKV(3,L) = VTCD - BAKV(4,L) = 3 - EVNV = .TRUE. - CYCLE - END IF - END IF - END IF - IF(POB.LT.BMISS .AND. TOB.LT.BMISS - $ .AND. TDO.LT.BMISS) THEN - IF(QQM(L).GT.3) THEN -C Don't update q or calculate Tv if bad moisture obs fails sanity check -cdak IF(TDO.LT.-103.15 .OR. TDO.GT.46.83 .OR. POB.LT.0.1 .OR. -cdak $ POB.GT.1100.) -cdak $ print *, '&&& bad QM fails sanity check' - IF(TDO.LT.-103.15 .OR. TDO.GT.46.83 .OR. POB.LT.0.1 .OR. - $ POB.GT.1100.) CYCLE - ENDIF - QOB = QS(TDO+273.16,POB) - BAKQ(1,L) = QOB*1E6 - BAKQ(2,L) = QQM(L) ! Moist qm same as before for re-calc. q - BAKQ(3,L) = VTCD - BAKQ(4,L) = 0 ! Re-calc. q gets unique reason code 0 - EVNQ = .TRUE. -C If message type ADPUPA, test this level to see if at or above trop -C (trop must be above 500 mb to pass test; if no trop level found -C assume it's at 80 mb) -C Don't calculate Tv on this level if at or above trop (doesn't affect -C q calculation) - TROP = (SUBSET.EQ.'ADPUPA ' .AND. - $ ((CAT.EQ.5 .AND. POB.LT.500.) .OR. POB.LT. 80. .OR. TROP)) - IF(DOVTMP .AND. .NOT.TROP) THEN - BAKV(1,L) = (TOB+273.16)*(1.+.61*QOB)-273.16 - BAKV(3,L) = VTCD - IF(SUBSET.EQ.'ADPUPA ') THEN -C Message type ADPUPA comes here - IF(QQM(L).LT.4 .OR. TQM(L).EQ.0 .OR. TQM(L).GT.3 .OR. - $ POB.LE.700.) THEN - BAKV(2,L) = TQM(L) ! Tv qm same as for T when q ok - BAKV(4,L) = 0 ! Tv gets unique reason code 0 - ELSE - BAKV(2,L) = 3 !Tv qm susp for bad moist below 700mb - BAKV(4,L) = 6 !Tv gets unique reason code 6 - ENDIF - ELSE -C All other message types come here - IF(QQM(L).LT.4) THEN - BAKV(2,L) = TQM(L) ! Tv qm same as for T when q ok - BAKV(4,L) = 0 ! Tv gets unique reason code 0 - ELSE -cdak print *, '%%% process tvirt on lvl ',l,' for bad QQM case' - BAKV(2,L) = 8 ! Tv qm bad for bad moist - BAKV(4,L) = 2 ! Tv gets unique reason code 2 - ENDIF - ENDIF - EVNV = .TRUE. - ENDIF - ENDIF - ENDDO - ENDIF - -C ENCODE EVENTS INTO REPORT -C ------------------------- - - IF(NLEV.GT.0) THEN - IF(EVNQ) CALL UFBINT(IUNITP,BAKQ,4,NLEV,IRET,EVNSTQ) - IF(EVNV) CALL UFBINT(IUNITP,BAKV,4,NLEV,IRET,EVNSTV) - ENDIF - - RETURN - END -C####################### -C####################### -C####################### -C####################### -C####################### -C####################### -C*********************************************************************** -C*********************************************************************** - SUBROUTINE GBLEVN10(IUNITF,IDATEP) ! FORMERLY SUBROUTINE GESRES - - COMMON /GBEVFF/IMAX,JMAX,KMAX,kmaxs,DLAT,DLON,IDVC,SL(100),SI(101) - COMMON /GBEVHH/ JCAP,JCAP1,JCAP2,JCAP1X2,MDIMA,MDIMB,MDIMC - - DIMENSION IDATE(8,2),JDATE(8,2),KDATE(8,2),IUNITF(2),FHR(2), - $ KINDX(2) - - DIMENSION HEADR2(226,2) - - CHARACTER*6 COORD(2) - - DATA COORD /'SIGMA ','HYBRID'/ - - IF(MOD(MOD(IDATEP,100),3).EQ.0) THEN - KFILES = 1 - KINDX = 0 - PRINT 331, MOD(IDATEP,100) - 331 FORMAT(/' --> GBLEVENTS: THE PREPBUFR CENTER HOUR (',I2.2, - $ ') IS A MULTIPLE OF 3 - ONLY ONE GLOBAL SIGMA FILE IS READ,'/ - $ 16X,'NO INTERPOLATION OF SPECTRAL COEFFICIENTS IS PERFORMED'/) - ELSE - KFILES = 2 - KINDX(1) = MOD(MOD(IDATEP,100),3) - KINDX(2) = KINDX(1) - 3 - PRINT 332, MOD(IDATEP,100) - 332 FORMAT(/' --> GBLEVENTS: THE PREPBUFR CENTER HOUR (',I2.2, - $ ') IS NOT A MULTIPLE OF 3 - TWO SPANNING GLOBAL SIGMA FILES'/ - $ 16X,'ARE READ AND THE SPECTRAL COEFFICIENTS ARE INTERPOLATED', - $ ' TO THE PREPBUFR CENTER TIME'/) - END IF - -C GET VALID-TIME DATE OF SIGMA FILE(S), ALSO READ HEADERS -C ------------------------------------------------------- - - JFILE = 0 - DO IFILE=1,KFILES - JFILE = IFILE - REWIND IUNITF(IFILE) - READ(IUNITF(IFILE),ERR=900) DUMMY - IDATE(:,IFILE) = 0 - READ(IUNITF(IFILE),END=800,ERR=800) FHR(IFILE),idate(5,IFILE), - $ idate(2,IFILE),idate(3,IFILE),idate(1,IFILE),HEADR2(:,IFILE) - IHEADR2_SIZE = 226 -cppppp - print * - print *, '##GBLEVENTS/GBLEVN10 - Guess file has a 226 word header' - print * -cppppp - GO TO 801 - 800 CONTINUE - REWIND IUNITF(IFILE) - READ(IUNITF(IFILE),ERR=900) DUMMY - IDATE(:,IFILE) = 0 - READ(IUNITF(IFILE),END=900,ERR=900) FHR(IFILE),idate(5,IFILE), - $ idate(2,IFILE),idate(3,IFILE),idate(1,IFILE), - $ HEADR2(1:207,IFILE) - IHEADR2_SIZE = 207 -cppppp - print * - print *, '##GBLEVENTS/GBLEVN10 - Guess file has a 207 word header' - print *, ' - most likely a CDAS sges file' - print * -cppppp - 801 CONTINUE - IF(IDATE(1,IFILE).LT.100) THEN - -C IF 2-DIGIT YEAR FOUND IN GLOBAL SIMGA FILE INITIAL DATE -C (IDATE(1,IFILE)), MUST USE "WINDOWING" TECHNIQUE TO CREATE A 4-DIGIT -C YEAR (NOTE: THE T170 IMPLEMENTATION IN JUNE 1998 WAS TO INCLUDE THE -C WRITING OF A 4-DIGIT YEAR HERE. PRIOR TO THIS, THE YEAR HERE WAS -C 2-DIGIT.) - - PRINT *, '##GBLEVENTS/GBLEVN10 - 2-DIGIT YEAR FOUND IN ', - $ 'GLOBAL SIGMA FILE ',IFILE,'; INITIAL DATE (YEAR IS: ', - $ idate(1,IFILE),') - USE WINDOWING TECHNIQUE TO OBTAIN ', - $ '4-DIGIT YEAR' - IF(IDATE(1,IFILE).GT.20) THEN - IDATE(1,IFILE) = 1900 + IDATE(1,IFILE) - ELSE - IDATE(1,IFILE) = 2000 + IDATE(1,IFILE) - ENDIF - PRINT *,'##GBLEVENTS/GBLEVN10 - CORRECTED 4-DIGIT YEAR IS ', - $ 'NOW: ',IDATE(1,IFILE) - ENDIF - CALL W3MOVDAT((/0.,ANINT(FHR(IFILE)),0.,0.,0./),IDATE(:,IFILE), - $ JDATE(:,IFILE)) - PRINT 1, IFILE,ANINT(FHR(IFILE)),(IDATE(II,IFILE),II=1,3), - $ IDATE(5,IFILE),(JDATE(II,IFILE),II=1,3),JDATE(5,IFILE) - 1 FORMAT(' --> GBLEVENTS: GLOBAL SIGMA FILE',I2,' HERE IS A ', - $ F5.1,' HOUR FORECAST FROM ',I5.4,3I3.2,' VALID AT ',I5.4,3I3.2) - KDATE(:,IFILE) = JDATE(:,IFILE) - IF(KFILES.EQ.2) CALL W3MOVDAT((/0.,REAL(KINDX(IFILE)),0.,0., - $ 0./),JDATE(:,IFILE),KDATE(:,IFILE)) - IDATGS_COR = (KDATE(1,IFILE) * 1000000) + (KDATE(2,IFILE) * - $ 10000) + (KDATE(3,IFILE) * 100) + KDATE(5,IFILE) - -C VALID DATES MUST MATCH -C ---------------------- - - IF(IDATEP.NE.IDATGS_COR) GO TO 901 - - ENDDO - - IF(KFILES.EQ.2) THEN - -C IF THERE ARE TWO SIGMA FILES, THEIR HEADERS MUST MATCH -C ------------------------------------------------------- - - JNDEX = 0 - DO INDEX=1,IHEADR2_SIZE - JNDEX = INDEX - IF(HEADR2(INDEX,1).NE.HEADR2(INDEX,2)) GO TO 904 - ENDDO - ENDIF - -C EXTRACT HEADER INFO -C ------------------- - - JCAP = HEADR2(202,1) - KMAX = HEADR2(203,1) - IF(IHEADR2_SIZE.EQ.226) THEN - IDVC = HEADR2(220,1) - ELSE - IDVC=0 - END IF - kmaxs = 2*kmax+2 - - if(idvc.eq.0) idvc = 1 ! Reset IDVC=0 to 1 (sigma coord.) - IF(IDVC.NE.1.AND.IDVC.NE.2) THEN - PRINT *, '##GBLEVENTS/GBLEVN10: INVALID VERT COORD ID (=', - $ IDVC,'), DEFAULTING TO SIGMA COORD, RESETTING IDVC = 1' - IDVC = 1 - END IF - - IF(KMAX.GT.100) GO TO 902 - - IF(IDVC.EQ.1) THEN - -C SIGMA COORDINATE COEFFICIENTS -C ----------------------------- - - DO L = 1,KMAX - SI(L) = HEADR2(L,1) - SL(L) = HEADR2(KMAX+1+L,1) - ENDDO - SI(KMAX+1) = HEADR2(KMAX+1,1) - ELSEIF(IDVC.EQ.2) THEN - -C HYBRID COORDINATE COEFFICIENTS -C ------------------------------ - - DO L = 1,KMAX+1 - -C Convert AK HYBRID coeff for use in HPA -C -------------------------------------- - - SI(L) = (0.01)*HEADR2(L,1) - SL(L) = HEADR2(KMAX+1+L,1) - END DO - END IF - -C DEFINE THE OTHER RESOLUTION PARAMETERS -C -------------------------------------- - - JCAP1 = JCAP+1 - JCAP2 = JCAP+2 - JCAP1X2 = JCAP1*2 - MDIMA = JCAP1*JCAP2 - MDIMB = MDIMA/2+JCAP1 - MDIMC = MDIMB*2 - IMAX = 384 - JMAX = IMAX/2+1 - -cdak IF(IMAX.LT.JCAP1X2) GO TO 903 ! commented out 9/27/01 - - DLAT = 180./(JMAX-1) - DLON = 360./IMAX - - PRINT 2, JCAP,KMAX,kmaxs,DLAT,DLON,COORD(IDVC) - 2 FORMAT(/' --> GBLEVENTS: GLOBAL MODEL SPECS: T',I3,' ',I3, - $ ' LEVELS ',I3,' SCALARS -------> ',F4.2,' X ',F4.2,' VERT. ', - $ 'COORD: ',A) - - CALL GBLEVN09(IUNITF,KINDX) - - RETURN - - 900 CONTINUE - PRINT *, '##GBLEVENTS/GBLEVN10 - BAD OR MISSING GLOBAL SIGMA ', - $ 'FILE ',JFILE,' - STOP 67' - CALL ERREXIT(67) - 901 CONTINUE - PRINT 9901, JFILE,(JDATE(II,JFILE),II=1,3),JDATE(5,JFILE),IDATEP - 9901 FORMAT(/' ##GBLEVENTS/GBLEVN10 - SIGMA FILE',I2,' DATE (',I4.4, - $3(I2.2),'), DOES NOT MATCH -OR SPAN- PREPBUFR FILE CENTER DATE (', - $ I10,') -STOP 68'/) - CALL ERREXIT(68) - 902 CONTINUE - PRINT *,'##GBLEVENTS/GBLEVN10 - KMAX TOO BIG = ',KMAX,' - UNABLE', - $ ' TO TRANSFORM GLOBAL SIGMA FILE(S) - STOP 69' - CALL ERREXIT(69) - 903 CONTINUE - PRINT *, '##GBLEVENTS/GBLEVN10 - IMAX TOO SMALL = ',IMAX,' - ', - $ 'UNABLE TO TRANSFORM GLOBAL SIGMA FILE(S) - STOP 70' - CALL ERREXIT(70) - 904 CONTINUE - PRINT *, '##GBLEVENTS/GBLEVN10 - HEADER INDEX ',JNDEX,' FOR ', - $ 'SIGMA FILE 1 (=',HEADR2(JNDEX,1),') DOES NOT MATCH THAT FOR ', - $ ' SIGMA FILE 2 (=',HEADR2(JNDEX,2),' - STOP 71' - CALL ERREXIT(71) - END -C*********************************************************************** -C*********************************************************************** - SUBROUTINE GBLEVN09(IUNITF,KINDX) - ! FORMERLY SUBROUTINE COF2GRD - - parameter (PI180=.0174532) - - COMMON /GBEVFF/IMAX,JMAX,KMAX,kmaxs,DLAT,DLON,IDVC,SL(100),SI(101) - COMMON /GBEVHH/ JCAP,JCAP1,JCAP2,JCAP1X2,MDIMA,MDIMB,MDIMC - - DIMENSION IUNITF(2),KINDX(2) - -C Changes below allocates arrays from "heap" rather than "stack" -C real cofs(mdima,kmaxs), cofv(mdima,kmax,2) -C real cofs_f(mdima,kmaxs,2), cofv_f(mdima,kmax,2,2) -C real grds(IMAX,JMAX,kmaxs), grdv(IMAX,JMAX,kmax,2) -C real grd2(IMAX,JMAX,2) - real,allocatable:: cofs(:,:), cofv(:,:,:) - real,allocatable:: cofs_f(:,:,:), cofv_f(:,:,:,:) - real,allocatable:: grds(:,:,:), grdv(:,:,:,:) - real,allocatable:: grd2(:,:,:) - -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -C USAGE: CALL SPTEZM(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX,WAVE,GRID,IDIR) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES -C JMAX - INTEGER NUMBER OF LATITUDES -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM -C WAVE - REAL (2*MX,KMAX) WAVE FIELD IF IDIR>0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 -C GRID - REAL (IMAX,JMAX,KMAX) GRID FIELD (E->W,N->S) IF IDIR<0 -C IDIR - INTEGER TRANSFORM FLAG -C (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -C OUTPUT ARGUMENTS: -C WAVE - REAL (2*MX,KMAX) WAVE FIELD IF IDIR<0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 -C GRID - REAL (IMAX,JMAX,KMAX) GRID FIELD (E->W,N->S) IF IDIR>0 - - -C USAGE: CALL SPTEZMV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, -C & WAVED,WAVEZ,GRIDU,GRIDV,IDIR) -C INPUT ARGUMENTS: -C WAVED - REAL (2*MX,KMAX) WAVE DIVERGENCE FIELD IF IDIR>0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 -C WAVEZ - REAL (2*MX,KMAX) WAVE VORTICITY FIELD IF IDIR>0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 -C GRIDU - REAL (IMAX,JMAX,KMAX) GRID U-WIND (E->W,N->S) IF IDIR<0 -C GRIDV - REAL (IMAX,JMAX,KMAX) GRID V-WIND (E->W,N->S) IF IDIR<0 -C OUTPUT ARGUMENTS: -C WAVED - REAL (2*MX,KMAX) WAVE DIVERGENCE FIELD IF IDIR<0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 -C WAVEZ - REAL (2*MX,KMAX) WAVE VORTICITY FIELD IF IDIR>0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 -C GRIDU - REAL (IMAX,JMAX,KMAX) GRID U-WIND (E->W,N->S) IF IDIR>0 -C GRIDV - REAL (IMAX,JMAX,KMAX) GRID V-WIND (E->W,N->S) IF IDIR>0 - -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - allocate (cofs(mdima,kmaxs), cofv(mdima,kmax,2)) - allocate (cofs_f(mdima,kmaxs,2), cofv_f(mdima,kmax,2,2)) - allocate (grds(IMAX,JMAX,kmaxs), grdv(IMAX,JMAX,kmax,2)) - allocate (grd2(IMAX,JMAX,2)) - - IROMB=0 - MAXWV=JCAP - IDRT=0 - IDIR=1 - - - IF(KINDX(1).EQ.0) THEN - KFILES = 1 - ELSE - KFILES = 2 - ENDIF - - DO IFILE=1,KFILES - ns=1 - DO I=1,5 - if (i.ne.4) then - LEV = KMAX - IF(I.LE.2) LEV = 1 - DO L=1,LEV - READ(IUNITF(IFILE),END=900,ERR=901) - $ (COFS_f(II,NS,IFILE),II=1,MDIMA) - ns=ns+1 - enddo - else - NRD = 2 - DO L=1,LEV - DO K=1,NRD - READ(IUNITF(IFILE),END=900,ERR=901) - $ (COFV_f(II,L,K,IFILE),II=1,MDIMA) - ENDDO - enddo - endif - enddo - ENDDO - - IF(KFILES.EQ.1) THEN - DO I = 1,MDIMA - COFS(I,1:KMAXS) = COFS_f(I,1:KMAXS,1) - COFV(I,1:KMAX,1:2) = COFV_f(I,1:KMAX,1:2,1) - ENDDO - - ELSE - COFS= - $ ((ABS(KINDX(2))*COFS_f(:,:,1)) +(KINDX(1)*COFS_f(:,:,2)))/3. - COFV= - $ ((ABS(KINDX(2))*COFV_f(:,:,:,1))+(KINDX(1)*COFV_f(:,:,:,2)))/3. - ENDIF - - CALL SPTEZM(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAXS,COFS,GRDS,IDIR) - CALL SPTEZMV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, - & COFV(1,1,1),COFV(1,1,2),GRDV(1,1,1,1),GRDV(1,1,1,2),IDIR) - ns=1 - DO I=1,5 - if (i.ne.4) then - LEV = KMAX - IF(I.LE.2) LEV = 1 - DO L=1,LEV - call gblevn11(imax,jmax,grds(1,1,ns)) - if (ns.eq.2) then - DO J=1,JMAX - DO II=1,IMAX - GRDS(II,J,NS) = 10.*EXP(GRDS(II,J,NS)) - ENDDO - ENDDO - endif - !print'(2i5,2e13.6)',i,l,grds(1,1,ns),GRDs(1,jmax/2,ns) - CALL GBLEVN05(GRDS(1,1,NS),I,L) - ns=ns+1 - enddo - else - NRD = 2 - DO L=1,LEV - DO K=1,NRD - call gblevn11(imax,jmax,grdv(1,1,l,k)) - do J=1,jmax - grd2(1:imax,j,k)=grdv(1:imax,j,l,k) - enddo - enddo - !print'(2i5,2e13.6)',i,l,grd2(1,1,1),GRD2(1,jmax/2,1) - CALL GBLEVN05(GRD2,I,L) - enddo - endif - enddo - - deallocate (cofs, cofv) - deallocate (cofs_f, cofv_f) - deallocate (grds, grdv) - deallocate (grd2) - - RETURN - - 900 CONTINUE - PRINT *,'##GBLEVENTS/GBLEVN09 - EOF READING GLOBAL SIGMA FILE - ', - $ 'UNABLE TO TRANSFORM GLOBAL SIGMA FILE - STOP 64' - CALL ERREXIT(64) - 901 CONTINUE - PRINT *,'##GBLEVENTS/GBLEVN09 - ERROR READING GLOBAL SIGMA FILE ', - $ '- UNABLE TO TRANSFORM GLOBAL SIGMA FILE - STOP 65' - CALL ERREXIT(65) - 902 CONTINUE - PRINT *,'##GBLEVENTS/GBLEVN09 - IDIM NOT FACTORABLE - UNABLE TO ', - $ 'TRANSFORM GLOBAL SIGMA FILE - STOP 66' - CALL ERREXIT(66) - END -C*********************************************************************** -C*********************************************************************** - subroutine gblevn11(imax,jmax,grid) ! formerly subroutine n_s_swap - real grid(imax,jmax) - real temp (imax) - - do j=1,jmax/2 - jj=jmax-j+1 - temp(1:imax) =grid(1:imax,j) - grid(1:imax,j) =grid(1:imax,jj) - grid(1:imax,jj)=temp(1:imax) - enddo - return - end -C#################### -C#################### -C#################### -C#################### -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C ============================================================== C -C | DESCRIPTION | NAME | BITS | MAX VALUE | DIMENSIONS | C -C |=============*========*======*============*=================| C -C | ZSG01 | ZSG01 | WORD | REAL | 384,193 | C -C |-------------+--------+------+------------+-----------------| C -C | PSG01 | PSG01 | WORD | REAL | 384,193 | C -C |-------------+--------+------+------------+-----------------| C -C | TG01 | TG01 | WORD | REAL | 384,193,64 | C -C |-------------+--------+------+------------+-----------------| C -C | UG01 | UG01 | WORD | REAL | 384,193,64 | C -C |-------------+--------+------+------------+-----------------| C -C | VG01 | VG01 | WORD | REAL | 384,193,64 | C -C |-------------+--------+------+------------+-----------------| C -C | QG01 | QG01 | WORD | REAL | 384,193,64 | C -C ==============^========^======^============^================== C -C C -C*********************************************************************** -C*********************************************************************** - FUNCTION ZSG01(I,J) ! FORMERLY FUNCTION ZS - PARAMETER (IM = 384) - PARAMETER (JM = 193) - COMMON /GBEVJJ/IAR(IM,JM) - REAL(8) IAR - REAL ZSG01 - ZSG01 = IAR(I,J) - RETURN - END -C*********************************************************************** -C*********************************************************************** - SUBROUTINE GBLEVN12(I,J,V) ! FORMERLY SUBROUTINE ZSP - PARAMETER (IM = 384) - PARAMETER (JM = 193) - COMMON /GBEVJJ/IAR(IM,JM) - REAL(8) IAR - REAL V - IAR(I,J) = V - RETURN - END -C*********************************************************************** -C*********************************************************************** - FUNCTION PSG01(I,J) ! FORMERLY FUNCTION PS - PARAMETER (IM = 384) - PARAMETER (JM = 193) - COMMON /GBEVKK/IAR(IM,JM) - REAL(8) IAR - REAL PSG01 - PSG01 = IAR(I,J) - RETURN - END -C*********************************************************************** -C*********************************************************************** - SUBROUTINE GBLEVN13(I,J,V) ! FORMERLY SUBROUTINE PSP - PARAMETER (IM = 384) - PARAMETER (JM = 193) - COMMON /GBEVKK/IAR(IM,JM) - REAL(8) IAR - REAL V - IAR(I,J) = V - RETURN - END -C*********************************************************************** -C*********************************************************************** - FUNCTION TG01(I,J,K) ! FORMERLY FUNCTION T - PARAMETER (IM = 384) - PARAMETER (JM = 193) - PARAMETER (KM = 64) - COMMON /GBEVLL/IAR(IM,JM,KM) - REAL(8) IAR - REAL TG01 - TG01 = IAR(I,J,K) - RETURN - END -C*********************************************************************** -C*********************************************************************** - SUBROUTINE GBLEVN14(I,J,K,V) ! FORMERLY SUBROUTINE TP - PARAMETER (IM = 384) - PARAMETER (JM = 193) - PARAMETER (KM = 64) - COMMON /GBEVLL/IAR(IM,JM,KM) - REAL(8) IAR - REAL V - IAR(I,J,K) = V - RETURN - END -C*********************************************************************** -C*********************************************************************** - FUNCTION UG01(I,J,K) ! FORMERLY FUNCTION U - PARAMETER (IM = 384) - PARAMETER (JM = 193) - PARAMETER (KM = 64) - COMMON /GBEVMM/IAR(IM,JM,KM) - REAL(8) IAR - REAL UG01 - UG01 = IAR(I,J,K) - RETURN - END -C*********************************************************************** -C*********************************************************************** - SUBROUTINE GBLEVN15(I,J,K,V) ! FORMERLY SUBROUTINE UP - PARAMETER (IM = 384) - PARAMETER (JM = 193) - PARAMETER (KM = 64) - COMMON /GBEVMM/IAR(IM,JM,KM) - REAL(8) IAR - REAL V - IAR(I,J,K) = V - RETURN - END -C*********************************************************************** -C*********************************************************************** - FUNCTION VG01(I,J,K) ! FORMERLY FUNCTION V - PARAMETER (IM = 384) - PARAMETER (JM = 193) - PARAMETER (KM = 64) - COMMON /GBEVNN/IAR(IM,JM,KM) - REAL(8) IAR - REAL VG01 - VG01 = IAR(I,J,K) - RETURN - END -C*********************************************************************** -C*********************************************************************** - SUBROUTINE GBLEVN16(I,J,K,V) ! FORMERLY SUBROUTINE VP - PARAMETER (IM = 384) - PARAMETER (JM = 193) - PARAMETER (KM = 64) - COMMON /GBEVNN/IAR(IM,JM,KM) - REAL(8) IAR - REAL V - IAR(I,J,K) = V - RETURN - END -C*********************************************************************** -C*********************************************************************** - FUNCTION QG01(I,J,K) ! FORMERLY FUNCTION Q - PARAMETER (IM = 384) - PARAMETER (JM = 193) - PARAMETER (KM = 64) - COMMON /GBEVOO/IAR(IM,JM,KM) - REAL(8) IAR - REAL QG01 - QG01 = IAR(I,J,K) - RETURN - END -C*********************************************************************** -C*********************************************************************** - SUBROUTINE GBLEVN17(I,J,K,V) ! FORMERLY SUBROUTINE QP - PARAMETER (IM = 384) - PARAMETER (JM = 193) - PARAMETER (KM = 64) - COMMON /GBEVOO/IAR(IM,JM,KM) - REAL(8) IAR - REAL V - IAR(I,J,K) = V - RETURN - END diff --git a/src/fim/FIMsrc/w3/gbyte.f b/src/fim/FIMsrc/w3/gbyte.f deleted file mode 100644 index 4e0e60d..0000000 --- a/src/fim/FIMsrc/w3/gbyte.f +++ /dev/null @@ -1,108 +0,0 @@ - SUBROUTINE GBYTE(IPACKD,IUNPKD,NOFF,NBITS) -C -C THIS PROGRAM WRITTEN BY..... -C DR. ROBERT C. GAMMILL, CONSULTANT -C NATIONAL CENTER FOR ATMOSPHERIC RESEARCH -C MAY 1972 -C -C CHANGES FOR SiliconGraphics IRIS-4D/25 -C SiliconGraphics 3.3 FORTRAN 77 -C March 1991, RUSSELL E. JONES -C NATIONAL WEATHER SERVICE -C -C THIS IS THE FORTRAN VERSION OF GBYTE -C -C*********************************************************************** -C -C SUBROUTINE GBYTE (IPACKD,IUNPKD,NOFF,NBITS) -C -C PURPOSE TO UNPACK A BYTE INTO A TARGET WORD. THE -C UNPACKED BYTE IS RIGHT-JUSTIFIED IN THE -C TARGET WORD, AND THE REMAINDER OF THE -C WORD IS ZERO-FILLED. -C -C USAGE CALL GBYTE(IPACKD,IUNPKD,NOFF,NBITS) -C -C ARGUMENTS -C -C ON INPUT IPACKD -C THE WORD OR ARRAY CONTAINING THE BYTE TO BE -C UNPACKED. -C -C IUNPKD -C THE WORD WHICH WILL CONTAIN THE UNPACKED -C BYTE. -C -C NOFF -C THE NUMBER OF BITS TO SKIP, LEFT TO RIGHT, -C IN 'IPACKD' IN ORDER TO LOCATE THE BYTE -C TO BE UNPACKED. -C -C NBITS -C NUMBER OF BITS IN THE BYTE TO BE UNPACKED. -C MAXIMUM OF 64 BITS ON 64 BIT MACHINE, 32 -C BITS ON 32 BIT MACHINE. -C -C ON OUTPUT IUNPKD -C CONTAINS THE REQUESTED UNPACKED BYTE. -C*********************************************************************** - - INTEGER IPACKD(*) - INTEGER IUNPKD - INTEGER MASKS(64) -C - SAVE -C - DATA IFIRST/1/ - IF(IFIRST.EQ.1) THEN - CALL W3FI01(LW) - NBITSW = 8 * LW - JSHIFT = -1 * NINT(ALOG(FLOAT(NBITSW)) / ALOG(2.0)) - MASKS(1) = 1 - DO I=2,NBITSW-1 - MASKS(I) = 2 * MASKS(I-1) + 1 - ENDDO - MASKS(NBITSW) = -1 - IFIRST = 0 - ENDIF -C -C NBITS MUST BE LESS THAN OR EQUAL TO NBITSW -C - ICON = NBITSW - NBITS - IF (ICON.LT.0) RETURN - MASK = MASKS(NBITS) -C -C INDEX TELLS HOW MANY WORDS INTO THE ARRAY 'IPACKD' THE NEXT BYTE -C APPEARS. -C - INDEX = ISHFT(NOFF,JSHIFT) -C -C II TELLS HOW MANY BITS THE BYTE IS FROM THE LEFT SIDE OF THE WORD. -C - II = MOD(NOFF,NBITSW) -C -C MOVER SPECIFIES HOW FAR TO THE RIGHT NBITS MUST BE MOVED IN ORDER -C -C TO BE RIGHT ADJUSTED. -C - MOVER = ICON - II -C - IF (MOVER.GT.0) THEN - IUNPKD = IAND(ISHFT(IPACKD(INDEX+1),-MOVER),MASK) -C -C THE BYTE IS SPLIT ACROSS A WORD BREAK. -C - ELSE IF (MOVER.LT.0) THEN - MOVEL = - MOVER - MOVER = NBITSW - MOVEL - IUNPKD = IAND(IOR(ISHFT(IPACKD(INDEX+1),MOVEL), - & ISHFT(IPACKD(INDEX+2),-MOVER)),MASK) -C -C THE BYTE IS ALREADY RIGHT ADJUSTED. -C - ELSE - IUNPKD = IAND(IPACKD(INDEX+1),MASK) - ENDIF -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/gbytes.f b/src/fim/FIMsrc/w3/gbytes.f deleted file mode 100644 index 1551117..0000000 --- a/src/fim/FIMsrc/w3/gbytes.f +++ /dev/null @@ -1,144 +0,0 @@ - SUBROUTINE GBYTES(IPACKD,IUNPKD,NOFF,NBITS,ISKIP,ITER) -C -C THIS PROGRAM WRITTEN BY..... -C DR. ROBERT C. GAMMILL, CONSULTANT -C NATIONAL CENTER FOR ATMOSPHERIC RESEARCH -C MAY 1972 -C -C CHANGES FOR SiliconGraphics IRIS-4D/25 -C SiliconGraphics 3.3 FORTRAN 77 -C MARCH 1991, RUSSELL E. JONES -C NATIONAL WEATHER SERVICE -C -C THIS IS THE FORTRAN VERSION OF GBYTES. -C -C*********************************************************************** -C -C SUBROUTINE GBYTES (IPACKD,IUNPKD,NOFF,NBITS,ISKIP,ITER) -C -C PURPOSE TO UNPACK A SERIES OF BYTES INTO A TARGET -C ARRAY. EACH UNPACKED BYTE IS RIGHT-JUSTIFIED -C IN ITS TARGET WORD, AND THE REMAINDER OF THE -C WORD IS ZERO-FILLED. -C -C USAGE CALL GBYTES (IPACKD,IUNPKD,NOFF,NBITS,NSKIP, -C ITER) -C -C ARGUMENTS -C ON INPUT IPACKD -C THE WORD OR ARRAY CONTAINING THE PACKED -C BYTES. -C -C IUNPKD -C THE ARRAY WHICH WILL CONTAIN THE UNPACKED -C BYTES. -C -C NOFF -C THE INITIAL NUMBER OF BITS TO SKIP, LEFT -C TO RIGHT, IN 'IPACKD' IN ORDER TO LOCATE -C THE FIRST BYTE TO UNPACK. -C -C NBITS -C NUMBER OF BITS IN THE BYTE TO BE UNPACKED. -C MAXIMUM OF 64 BITS ON 64 BIT MACHINE, 32 -C BITS ON 32 BIT MACHINE. -C -C ISKIP -C THE NUMBER OF BITS TO SKIP BETWEEN EACH BYTE -C IN 'IPACKD' IN ORDER TO LOCATE THE NEXT BYTE -C TO BE UNPACKED. -C -C ITER -C THE NUMBER OF BYTES TO BE UNPACKED. -C -C ARGUMENTS -C ON OUTPUT IUNPKD -C CONTAINS THE REQUESTED UNPACKED BYTES. -C*********************************************************************** - - INTEGER IPACKD(*) - - INTEGER IUNPKD(*) - INTEGER MASKS(64) -C - SAVE -C - DATA IFIRST/1/ - IF(IFIRST.EQ.1) THEN - CALL W3FI01(LW) - NBITSW = 8 * LW - JSHIFT = -1 * NINT(ALOG(FLOAT(NBITSW)) / ALOG(2.0)) - MASKS(1) = 1 - DO I=2,NBITSW-1 - MASKS(I) = 2 * MASKS(I-1) + 1 - ENDDO - MASKS(NBITSW) = -1 - IFIRST = 0 - ENDIF -C -C NBITS MUST BE LESS THAN OR EQUAL TO NBITSW -C - ICON = NBITSW - NBITS - IF (ICON.LT.0) RETURN - MASK = MASKS(NBITS) -C -C INDEX TELLS HOW MANY WORDS INTO THE ARRAY 'IPACKD' THE NEXT BYTE -C APPEARS. -C - INDEX = ISHFT(NOFF,JSHIFT) -C -C II TELLS HOW MANY BITS THE BYTE IS FROM THE LEFT SIDE OF THE WORD. -C - II = MOD(NOFF,NBITSW) -C -C ISTEP IS THE DISTANCE IN BITS FROM THE START OF ONE BYTE TO THE NEXT. -C - ISTEP = NBITS + ISKIP -C -C IWORDS TELLS HOW MANY WORDS TO SKIP FROM ONE BYTE TO THE NEXT. -C - IWORDS = ISTEP / NBITSW -C -C IBITS TELLS HOW MANY BITS TO SKIP AFTER SKIPPING IWORDS. -C - IBITS = MOD(ISTEP,NBITSW) -C - DO 10 I = 1,ITER -C -C MOVER SPECIFIES HOW FAR TO THE RIGHT A BYTE MUST BE MOVED IN ORDER -C -C TO BE RIGHT ADJUSTED. -C - MOVER = ICON - II -C -C THE BYTE IS SPLIT ACROSS A WORD BREAK. -C - IF (MOVER.LT.0) THEN - MOVEL = - MOVER - MOVER = NBITSW - MOVEL - IUNPKD(I) = IAND(IOR(ISHFT(IPACKD(INDEX+1),MOVEL), - & ISHFT(IPACKD(INDEX+2),-MOVER)),MASK) -C -C RIGHT ADJUST THE BYTE. -C - ELSE IF (MOVER.GT.0) THEN - IUNPKD(I) = IAND(ISHFT(IPACKD(INDEX+1),-MOVER),MASK) -C -C THE BYTE IS ALREADY RIGHT ADJUSTED. -C - ELSE - IUNPKD(I) = IAND(IPACKD(INDEX+1),MASK) - ENDIF -C -C INCREMENT II AND INDEX. -C - II = II + IBITS - INDEX = INDEX + IWORDS - IF (II.GE.NBITSW) THEN - II = II - NBITSW - INDEX = INDEX + 1 - ENDIF -C - 10 CONTINUE - RETURN - END diff --git a/src/fim/FIMsrc/w3/gbytes_char.f b/src/fim/FIMsrc/w3/gbytes_char.f deleted file mode 100644 index 067d782..0000000 --- a/src/fim/FIMsrc/w3/gbytes_char.f +++ /dev/null @@ -1,127 +0,0 @@ - SUBROUTINE GBYTEC(IN,IOUT,ISKIP,NBYTE) - character*1 in(*) - integer iout(*) - CALL GBYTESC(IN,IOUT,ISKIP,NBYTE,0,1) - RETURN - END - - SUBROUTINE SBYTEC(OUT,IN,ISKIP,NBYTE) - character*1 out(*) - integer in(*) - CALL SBYTESC(OUT,IN,ISKIP,NBYTE,0,1) - RETURN - END - - SUBROUTINE GBYTESC(IN,IOUT,ISKIP,NBYTE,NSKIP,N) -C Get bytes - unpack bits: Extract arbitrary size values from a -C packed bit string, right justifying each value in the unpacked -C array. -C IN = character*1 array input -C IOUT = unpacked array output -C ISKIP = initial number of bits to skip -C NBYTE = number of bits to take -C NSKIP = additional number of bits to skip on each iteration -C N = number of iterations -C v1.1 -C - character*1 in(*) - integer iout(*) - integer ones(8), tbit, bitcnt - save ones - data ones/1,3,7,15,31,63,127,255/ - -c nbit is the start position of the field in bits - nbit = iskip - do i = 1, n - bitcnt = nbyte - index=nbit/8+1 - ibit=mod(nbit,8) - nbit = nbit + nbyte + nskip - -c first byte - tbit = min(bitcnt,8-ibit) - itmp = iand(mova2i(in(index)),ones(8-ibit)) - if (tbit.ne.8-ibit) itmp = ishft(itmp,tbit-8+ibit) - index = index + 1 - bitcnt = bitcnt - tbit - -c now transfer whole bytes - do while (bitcnt.ge.8) - itmp = ior(ishft(itmp,8),mova2i(in(index))) - bitcnt = bitcnt - 8 - index = index + 1 - enddo - -c get data from last byte - if (bitcnt.gt.0) then - itmp = ior(ishft(itmp,bitcnt),iand(ishft(mova2i(in(index)), - 1 -(8-bitcnt)),ones(bitcnt))) - endif - - iout(i) = itmp - enddo - - RETURN - END - - SUBROUTINE SBYTESC(OUT,IN,ISKIP,NBYTE,NSKIP,N) -C Store bytes - pack bits: Put arbitrary size values into a -C packed bit string, taking the low order bits from each value -C in the unpacked array. -C IOUT = packed array output -C IN = unpacked array input -C ISKIP = initial number of bits to skip -C NBYTE = number of bits to pack -C NSKIP = additional number of bits to skip on each iteration -C N = number of iterations -C v1.1 -C - character*1 out(*) - integer in(N), bitcnt, ones(8), tbit - save ones - data ones/ 1, 3, 7, 15, 31, 63,127,255/ - -c number bits from zero to ... -c nbit is the last bit of the field to be filled - - nbit = iskip + nbyte - 1 - do i = 1, n - itmp = in(i) - bitcnt = nbyte - index=nbit/8+1 - ibit=mod(nbit,8) - nbit = nbit + nbyte + nskip - -c make byte aligned - if (ibit.ne.7) then - tbit = min(bitcnt,ibit+1) - imask = ishft(ones(tbit),7-ibit) - itmp2 = iand(ishft(itmp,7-ibit),imask) - itmp3 = iand(mova2i(out(index)), 255-imask) - out(index) = char(ior(itmp2,itmp3)) - bitcnt = bitcnt - tbit - itmp = ishft(itmp, -tbit) - index = index - 1 - endif - -c now byte aligned - -c do by bytes - do while (bitcnt.ge.8) - out(index) = char(iand(itmp,255)) - itmp = ishft(itmp,-8) - bitcnt = bitcnt - 8 - index = index - 1 - enddo - -c do last byte - - if (bitcnt.gt.0) then - itmp2 = iand(itmp,ones(bitcnt)) - itmp3 = iand(mova2i(out(index)), 255-ones(bitcnt)) - out(index) = char(ior(itmp2,itmp3)) - endif - enddo - - return - end diff --git a/src/fim/FIMsrc/w3/getbit.f b/src/fim/FIMsrc/w3/getbit.f deleted file mode 100644 index 3e4aea6..0000000 --- a/src/fim/FIMsrc/w3/getbit.f +++ /dev/null @@ -1,87 +0,0 @@ - SUBROUTINE GETBIT(IBM,IBS,IDS,LEN,MG,G,GROUND,GMIN,GMAX,NBIT) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETBIT COMPUTE NUMBER OF BITS AND ROUND FIELD. -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: THE NUMBER OF BITS REQUIRED TO PACK A GIVEN FIELD -C FOR PARTICULAR BINARY AND DECIMAL SCALINGS IS COMPUTED. -C THE FIELD IS ROUNDED OFF TO THE DECIMAL SCALING FOR PACKING. -C THE MINIMUM AND MAXIMUM ROUNDED FIELD VALUES ARE ALSO RETURNED. -C GRIB BITMAP MASKING FOR VALID DATA IS OPTIONALLY USED. -C -C PROGRAM HISTORY LOG: -C 96-09-16 IREDELL -C -C USAGE: CALL GTBITS(IBM,IBS,IDS,LEN,MG,G,GMIN,GMAX,NBIT) -C INPUT ARGUMENT LIST: -C IBM - INTEGER BITMAP FLAG (=0 FOR NO BITMAP) -C IBS - INTEGER BINARY SCALING -C (E.G. IBS=3 TO ROUND FIELD TO NEAREST EIGHTH VALUE) -C IDS - INTEGER DECIMAL SCALING -C (E.G. IDS=3 TO ROUND FIELD TO NEAREST MILLI-VALUE) -C (NOTE THAT IDS AND IBS CAN BOTH BE NONZERO, -C E.G. IDS=1 AND IBS=1 ROUNDS TO THE NEAREST TWENTIETH) -C LEN - INTEGER LENGTH OF THE FIELD AND BITMAP -C MG - INTEGER (LEN) BITMAP IF IBM=1 (0 TO SKIP, 1 TO KEEP) -C G - REAL (LEN) FIELD -C -C OUTPUT ARGUMENT LIST: -C GROUND - REAL (LEN) FIELD ROUNDED TO DECIMAL AND BINARY SCALING -C (SET TO ZERO WHERE BITMAP IS 0 IF IBM=1) -C GMIN - REAL MINIMUM VALID ROUNDED FIELD VALUE -C GMAX - REAL MAXIMUM VALID ROUNDED FIELD VALUE -C NBIT - INTEGER NUMBER OF BITS TO PACK -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - DIMENSION MG(LEN),G(LEN),GROUND(LEN) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C ROUND FIELD AND DETERMINE EXTREMES WHERE BITMAP IS ON - S=2.**IBS*10.**IDS - IF(IBM.EQ.0) THEN - GROUND(1)=NINT(G(1)*S)/S - GMAX=GROUND(1) - GMIN=GROUND(1) - DO I=2,LEN - GROUND(I)=NINT(G(I)*S)/S - GMAX=MAX(GMAX,GROUND(I)) - GMIN=MIN(GMIN,GROUND(I)) - ENDDO - ELSE - I1=1 - DOWHILE(I1.LE.LEN.AND.MG(I1).EQ.0) - I1=I1+1 - ENDDO - IF(I1.LE.LEN) THEN - DO I=1,I1-1 - GROUND(I)=0. - ENDDO - GROUND(I1)=NINT(G(I1)*S)/S - GMAX=GROUND(I1) - GMIN=GROUND(I1) - DO I=I1+1,LEN - IF(MG(I).NE.0) THEN - GROUND(I)=NINT(G(I)*S)/S - GMAX=MAX(GMAX,GROUND(I)) - GMIN=MIN(GMIN,GROUND(I)) - ELSE - GROUND(I)=0. - ENDIF - ENDDO - ELSE - DO I=1,LEN - GROUND(I)=0. - ENDDO - GMAX=0. - GMIN=0. - ENDIF - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COMPUTE NUMBER OF BITS - NBIT=LOG((GMAX-GMIN)*S+0.9)/LOG(2.)+1. -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/getgb.f b/src/fim/FIMsrc/w3/getgb.f deleted file mode 100644 index fac9c3d..0000000 --- a/src/fim/FIMsrc/w3/getgb.f +++ /dev/null @@ -1,213 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGB(LUGB,LUGI,JF,J,JPDS,JGDS, - & KF,K,KPDS,KGDS,LB,F,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGB FINDS AND UNPACKS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND AND UNPACK A GRIB MESSAGE. -C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) -C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. -C (THE INDEX BUFFER IS SAVED FOR USE BY FUTURE PROSPECTIVE CALLS.) -C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE -C GRIB FILE AND UNPACKED. ITS MESSAGE NUMBER IS RETURNED ALONG WITH -C THE UNPACKED PDS AND GDS PARAMETERS, THE UNPACKED BITMAP (IF ANY), -C AND THE UNPACKED DATA. IF THE GRIB MESSAGE IS NOT FOUND, THEN THE -C RETURN CODE WILL BE NONZERO. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS -C AND ALLOWED FOR UNSPECIFIED INDEX FILE -C -C USAGE: CALL GETGB(LUGB,LUGI,JF,J,JPDS,JGDS, -C & KF,K,KPDS,KGDS,LB,F,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) -C JF INTEGER MAXIMUM NUMBER OF DATA POINTS TO UNPACK -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C OUTPUT ARGUMENTS: -C KF INTEGER NUMBER OF DATA POINTS UNPACKED -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C LB LOGICAL*1 (KF) UNPACKED BITMAP IF PRESENT -C F REAL (KF) UNPACKED DATA -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 97 ERROR READING GRIB FILE -C 98 NUMBER OF DATA POINTS GREATER THAN JF -C 99 REQUEST NOT FOUND -C OTHER W3FI63 GRIB UNPACKER RETURN CODE -C -C SUBPROGRAMS CALLED: -C GETGBM FIND AND UNPACK GRIB MESSAGE -C -C REMARKS: IN ORDER TO UNPACK GRIB FROM A MULTIPROCESSING ENVIRONMENT -C WHERE EACH PROCESSOR IS ATTEMPTING TO READ FROM ITS OWN PAIR OF -C LOGICAL UNITS, ONE MUST DIRECTLY CALL SUBPROGRAM GETGBM AS BELOW, -C ALLOCATING A PRIVATE COPY OF CBUF, NLEN AND NNUM TO EACH PROCESSOR. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER JPDS(200),JGDS(200),KPDS(200),KGDS(200) - LOGICAL*1 LB(JF) - REAL F(JF) - PARAMETER(MBUF=256*1024) - CHARACTER CBUF(MBUF) - SAVE CBUF,NLEN,NNUM,MNUM - DATA LUX/0/ -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED - IF(LUGI.GT.0.AND.(J.LT.0.OR.LUGI.NE.LUX)) THEN - LUX=LUGI - JJ=MIN(J,-1-J) - ELSEIF(LUGI.LE.0.AND.(J.LT.0.OR.LUGB.NE.LUX)) THEN - LUX=LUGB - JJ=MIN(J,-1-J) - ELSE - JJ=J - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C FIND AND UNPACK GRIB MESSAGE - CALL GETGBM(LUGB,LUGI,JF,JJ,JPDS,JGDS, - & MBUF,CBUF,NLEN,NNUM,MNUM, - & KF,K,KPDS,KGDS,LB,F,IRET) - IF(IRET.EQ.96) LUX=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/getgb1.f b/src/fim/FIMsrc/w3/getgb1.f deleted file mode 100644 index 405be3a..0000000 --- a/src/fim/FIMsrc/w3/getgb1.f +++ /dev/null @@ -1,197 +0,0 @@ - SUBROUTINE GETGB1(LUGB,LUGI,JF,J,JPDS,JGDS, - & GRIB,KF,K,KPDS,KGDS,LB,F,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGB1 FINDS AND UNPACKS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND AND UNPACK A GRIB MESSAGE. -C READ AN ASSOCIATED GRIB INDEX FILE (UNLESS IT ALREADY WAS READ). -C FIND IN THE INDEX FILE A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE -C GRIB FILE AND UNPACKED. ITS MESSAGE NUMBER IS RETURNED ALONG WITH -C THE UNPACKED PDS AND GDS PARAMETERS, THE UNPACKED BITMAP (IF ANY), -C AND THE UNPACKED DATA. IF THE GRIB MESSAGE IS NOT FOUND, THEN THE -C RETURN CODE WILL BE NONZERO. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-05-10 R.E.JONES ADD ONE MORE PARAMETER TO GETGB AND -C CHANGE NAME TO GETGB1 -C -C USAGE: CALL GETGB1(LUGB,LUGI,JF,J,JPDS,JGDS, -C & GRIB,KF,K,KPDS,KGDS,LB,F,IRET) -C INPUT ARGUMENTS: -C LUGB LOGICAL UNIT OF THE UNBLOCKED GRIB DATA FILE -C LUGI LOGICAL UNIT OF THE UNBLOCKED GRIB INDEX FILE -C JF INTEGER MAXIMUM NUMBER OF DATA POINTS TO UNPACK -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO REOPEN INDEX FILE AND SEARCH FROM BEGINNING) -C JPDS INTEGER (25) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C LOOK IN DOC BLOCK OF W3FI63 FOR ARRAY KPDS -C FOR LIST OF ORDER OF UNPACKED PDS VALUES. IN -C MOST CASES YOU ONLY NEED TO SET 4 OR 5 VALUES -C TO PICK UP RECORD. -C JGDS INTEGER (22) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C OUTPUT ARGUMENTS: -C GRIB GRIB DATA ARRAY BEFORE IT IS UNPACKED -C KF INTEGER NUMBER OF DATA POINTS UNPACKED -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (25) UNPACKED PDS PARAMETERS -C KGDS INTEGER (22) UNPACKED GDS PARAMETERS -C LB LOGICAL (KF) UNPACKED BITMAP IF PRESENT -C F REAL (KF) UNPACKED DATA -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 97 ERROR READING GRIB FILE -C 98 NUMBER OF DATA POINTS GREATER THAN JF -C 99 REQUEST NOT FOUND -C OTHER W3FI63 GRIB UNPACKER RETURN CODE -C -C SUBPROGRAMS CALLED: -C BAREAD BYTE-ADDRESSABLE READ -C GBYTE UNPACK BYTES -C FI632 UNPACK PDS -C FI633 UNPACK GDS -C W3FI63 UNPACK GRIB -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916/256, J916/2048 -C -C$$$ -C - PARAMETER (MBUF=8192*128) - PARAMETER (LPDS=23,LGDS=22) -C - INTEGER JPDS(25),JGDS(*),KPDS(25),KGDS(*) - INTEGER IPDSP(LPDS),JPDSP(LPDS),IGDSP(LGDS) - INTEGER JGDSP(LGDS) - INTEGER KPTR(20) -C - LOGICAL LB(*) -C - REAL F(*) -C - CHARACTER CBUF(MBUF) - CHARACTER*81 CHEAD(2) - CHARACTER*1 CPDS(28) - CHARACTER*1 CGDS(42) - CHARACTER*1 GRIB(*) -C -C SAVE LUX,NSKP,NLEN,NNUM,CBUF - SAVE -C - DATA LUX/0/ -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ INDEX FILE - IF(J.LT.0.OR.LUGI.NE.LUX) THEN -C REWIND LUGI -C READ(LUGI,fmt='(2A81)',IOSTAT=IOS) CHEAD - CALL BAREAD(LUGI,0,162,ios,chead) - IF(IOS.EQ.162.AND.CHEAD(1)(42:47).EQ.'GB1IX1') THEN - LUX=0 - READ(CHEAD(2),'(8X,3I10,2X,A40)',IOSTAT=IOS) NSKP,NLEN,NNUM - IF(IOS.EQ.0) THEN - NBUF=NNUM*NLEN - IF(NBUF.GT.MBUF) THEN - PRINT *,'GETGB1: INCREASE BUFFER FROM ',MBUF,' TO ',NBUF - NNUM=MBUF/NLEN - NBUF=NNUM*NLEN - ENDIF - CALL BAREAD(LUGI,NSKP,NBUF,LBUF,CBUF) - IF(LBUF.EQ.NBUF) THEN - LUX=LUGI - J=MAX(J,0) - ENDIF - ENDIF - ENDIF - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SEARCH FOR REQUEST - LGRIB=0 - KJ=J - K=J - KF=0 - IF(J.GE.0.AND.LUGI.EQ.LUX) THEN - LPDSP=0 - DO I=1,LPDS - IF(JPDS(I).NE.-1) THEN - LPDSP=LPDSP+1 - IPDSP(LPDSP)=I - JPDSP(LPDSP)=JPDS(I) - ENDIF - ENDDO - LGDSP=0 - IF(JPDS(3).EQ.255) THEN - DO I=1,LGDS - IF(JGDS(I).NE.-1) THEN - LGDSP=LGDSP+1 - IGDSP(LGDSP)=I - JGDSP(LGDSP)=JGDS(I) - ENDIF - ENDDO - ENDIF - IRET=99 - DOWHILE(LGRIB.EQ.0.AND.KJ.LT.NNUM) - KJ=KJ+1 - LT=0 - IF(LPDSP.GT.0) THEN - CPDS=CBUF((KJ-1)*NLEN+26:(KJ-1)*NLEN+53) - KPTR=0 - CALL GBYTE(CBUF,KPTR(3),(KJ-1)*NLEN*8+25*8,3*8) - CALL FI632(CPDS,KPTR,KPDS,IRET) - DO I=1,LPDSP - IP=IPDSP(I) - LT=LT+ABS(JPDS(IP)-KPDS(IP)) - ENDDO - ENDIF - IF(LT.EQ.0.AND.LGDSP.GT.0) THEN - CGDS=CBUF((KJ-1)*NLEN+54:(KJ-1)*NLEN+95) - KPTR=0 - CALL FI633(CGDS,KPTR,KGDS,IRET) - DO I=1,LGDSP - IP=IGDSP(I) - LT=LT+ABS(JGDS(IP)-KGDS(IP)) - ENDDO - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ AND UNPACK GRIB DATA - IF(LT.EQ.0) THEN - CALL GBYTE(CBUF,LSKIP,(KJ-1)*NLEN*8,4*8) - CALL GBYTE(CBUF,LGRIB,(KJ-1)*NLEN*8+20*8,4*8) - CGDS=CBUF((KJ-1)*NLEN+54:(KJ-1)*NLEN+95) - KPTR=0 - CALL FI633(CGDS,KPTR,KGDS,IRET) - IF(LGRIB.LE.200+17*JF/8.AND.KGDS(2)*KGDS(3).LE.JF) THEN - CALL BAREAD(LUGB,LSKIP,LGRIB,LREAD,GRIB) - IF(LREAD.EQ.LGRIB) THEN - CALL W3FI63(GRIB,KPDS,KGDS,LB,F,KPTR,IRET) - IF(IRET.EQ.0) THEN - K=KJ - KF=KPTR(10) - ENDIF - ELSE - IRET=97 - ENDIF - ELSE - IRET=98 - ENDIF - ENDIF - ENDDO - ELSE - IRET=96 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/getgb1r.f b/src/fim/FIMsrc/w3/getgb1r.f deleted file mode 100644 index 70d335e..0000000 --- a/src/fim/FIMsrc/w3/getgb1r.f +++ /dev/null @@ -1,75 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGB1R(LUGB,LSKIP,LGRIB,KF,KPDS,KGDS,KENS,LB,F,NBITSS - + ,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGB1R READS AND UNPACKS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 95-10-31 -C -C ABSTRACT: READ AND UNPACK A GRIB MESSAGE. -C -C PROGRAM HISTORY LOG: -C 95-10-31 IREDELL -C 04-07-22 CHUANG ADD PACKING BIT NUMBER NBITSS IN THE ARGUMENT -C LIST BECAUSE ETA GRIB FILES NEED IT TO REPACK GRIB FILE -C USAGE: CALL GETGB1R(LUGB,LSKIP,LGRIB,KF,KPDS,KGDS,KENS,LB,F,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C LSKIP INTEGER NUMBER OF BYTES TO SKIP -C LGRIB INTEGER NUMBER OF BYTES TO READ -C OUTPUT ARGUMENTS: -C KF INTEGER NUMBER OF DATA POINTS UNPACKED -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS -C LB LOGICAL*1 (KF) UNPACKED BITMAP IF PRESENT -C F REAL (KF) UNPACKED DATA -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 97 ERROR READING GRIB FILE -C OTHER W3FI63 GRIB UNPACKER RETURN CODE -C -C SUBPROGRAMS CALLED: -C BAREAD BYTE-ADDRESSABLE READ -C W3FI63 UNPACK GRIB -C PDSEUP UNPACK PDS EXTENSION -C -C REMARKS: THERE IS NO PROTECTION AGAINST UNPACKING TOO MUCH DATA. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C THIS SUBPROGRAM IS INTENDED FOR PRIVATE USE BY GETGB ROUTINES ONLY. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER KPDS(200),KGDS(200),KENS(200) - LOGICAL*1 LB(*) - REAL F(*) - INTEGER KPTR(200) - CHARACTER GRIB(LGRIB)*1 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ GRIB RECORD - CALL BAREAD(LUGB,LSKIP,LGRIB,LREAD,GRIB) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C UNPACK GRIB RECORD - IF(LREAD.EQ.LGRIB) THEN - CALL W3FI63(GRIB,KPDS,KGDS,LB,F,KPTR,IRET) - IF(IRET.EQ.0.AND.KPDS(23).EQ.2) THEN - CALL PDSEUP(KENS,KPROB,XPROB,KCLUST,KMEMBR,45,GRIB(9)) - ENDIF - ELSE - IRET=97 - ENDIF - NBITSS=KPTR(20) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C RETURN NUMBER OF POINTS - IF(IRET.EQ.0) THEN - KF=KPTR(10) - ELSE - KF=0 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/getgb1re.f b/src/fim/FIMsrc/w3/getgb1re.f deleted file mode 100644 index 46ad99e..0000000 --- a/src/fim/FIMsrc/w3/getgb1re.f +++ /dev/null @@ -1,81 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGB1RE(LUGB,LSKIP,LGRIB,KF,KPDS,KGDS,KENS, - & KPROB,XPROB,KCLUST,KMEMBR,LB,F,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGB1RE READS AND UNPACKS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 95-10-31 -C -C ABSTRACT: READ AND UNPACK A GRIB MESSAGE. -C -C PROGRAM HISTORY LOG: -C 95-10-31 IREDELL -C 97-02-11 Y.ZHU INCLUDED PROBABILITY AND CLUSTER ARGUMENTS -C -C USAGE: CALL GETGB1RE(LUGB,LSKIP,LGRIB,KF,KPDS,KGDS,KENS, -C & KPROB,XPROB,KCLUST,KMEMBR,LB,F,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C LSKIP INTEGER NUMBER OF BYTES TO SKIP -C LGRIB INTEGER NUMBER OF BYTES TO READ -C OUTPUT ARGUMENTS: -C KF INTEGER NUMBER OF DATA POINTS UNPACKED -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS -C KPROB INTEGER (2) PROBABILITY ENSEMBLE PARMS -C XPROB REAL (2) PROBABILITY ENSEMBLE PARMS -C KCLUST INTEGER (16) CLUSTER ENSEMBLE PARMS -C KMEMBR INTEGER (8) CLUSTER ENSEMBLE PARMS -C LB LOGICAL*1 (KF) UNPACKED BITMAP IF PRESENT -C F REAL (KF) UNPACKED DATA -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 97 ERROR READING GRIB FILE -C OTHER W3FI63 GRIB UNPACKER RETURN CODE -C -C SUBPROGRAMS CALLED: -C BAREAD BYTE-ADDRESSABLE READ -C W3FI63 UNPACK GRIB -C PDSEUP UNPACK PDS EXTENSION -C -C REMARKS: THERE IS NO PROTECTION AGAINST UNPACKING TOO MUCH DATA. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C THIS SUBPROGRAM IS INTENDED FOR PRIVATE USE BY GETGB ROUTINES ONLY. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER KPDS(200),KGDS(200),KENS(200) - INTEGER KPROB(2),KCLUST(16),KMEMBR(80) - REAL XPROB(2) - LOGICAL*1 LB(*) - REAL F(*) - INTEGER KPTR(200) - CHARACTER GRIB(LGRIB)*1 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ GRIB RECORD - CALL BAREAD(LUGB,LSKIP,LGRIB,LREAD,GRIB) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C UNPACK GRIB RECORD - IF(LREAD.EQ.LGRIB) THEN - CALL W3FI63(GRIB,KPDS,KGDS,LB,F,KPTR,IRET) - IF(IRET.EQ.0.AND.KPDS(23).EQ.2) THEN - CALL PDSEUP(KENS,KPROB,XPROB,KCLUST,KMEMBR,86,GRIB(9)) - ENDIF - ELSE - IRET=97 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C RETURN NUMBER OF POINTS - IF(IRET.EQ.0) THEN - KF=KPTR(10) - ELSE - KF=0 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/getgb1s.f b/src/fim/FIMsrc/w3/getgb1s.f deleted file mode 100644 index ec54d7e..0000000 --- a/src/fim/FIMsrc/w3/getgb1s.f +++ /dev/null @@ -1,185 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGB1S(CBUF,NLEN,NNUM,J,JPDS,JGDS,JENS, - & K,KPDS,KGDS,KENS,LSKIP,LGRIB,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGB1S FINDS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 95-10-31 -C -C ABSTRACT: FIND A GRIB MESSAGE. -C FIND IN THE INDEX FILE A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C -C PROGRAM HISTORY LOG: -C 95-10-31 IREDELL -C 2001-06-05 IREDELL APPLY LINUX PORT BY EBISUZAKI -C -C USAGE: CALL GETGB1S(CBUF,NLEN,NNUM,J,JPDS,JGDS,JENS, -C & K,KPDS,KGDS,KENS,LSKIP,LGRIB,IRET) -C INPUT ARGUMENTS: -C CBUF CHARACTER*1 (NLEN*NNUM) BUFFER CONTAINING INDEX DATA -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C NNUM INTEGER NUMBER OF INDEX RECORDS -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C JENS INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(23)=2) -C (=-1 FOR WILDCARD) -C OUTPUT ARGUMENTS: -C K INTEGER MESSAGE NUMBER FOUND -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS -C LSKIP INTEGER NUMBER OF BYTES TO SKIP -C LGRIB INTEGER NUMBER OF BYTES TO READ -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 1 REQUEST NOT FOUND -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C THIS SUBPROGRAM IS INTENDED FOR PRIVATE USE BY GETGB ROUTINES ONLY. -C -C SUBPROGRAMS CALLED: -C GBYTEC UNPACK BYTES -C FI632 UNPACK PDS -C FI633 UNPACK GDS -C PDSEUP UNPACK PDS EXTENSION -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - CHARACTER CBUF(NLEN*NNUM) - INTEGER JPDS(200),JGDS(200),JENS(200) - INTEGER KPDS(200),KGDS(200),KENS(200) - PARAMETER(LPDS=23,LGDS=22,LENS=5) ! ACTUAL SEARCH RANGES - CHARACTER CPDS(400)*1,CGDS(400)*1 - INTEGER KPTR(200) - INTEGER IPDSP(LPDS),JPDSP(LPDS) - INTEGER IGDSP(LGDS),JGDSP(LGDS) - INTEGER IENSP(LENS),JENSP(LENS) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COMPRESS REQUEST LISTS - K=J - LSKIP=0 - LGRIB=0 - IRET=1 -C COMPRESS PDS REQUEST - LPDSP=0 - DO I=1,LPDS - IF(JPDS(I).NE.-1) THEN - LPDSP=LPDSP+1 - IPDSP(LPDSP)=I - JPDSP(LPDSP)=JPDS(I) - ENDIF - ENDDO -C COMPRESS GDS REQUEST - LGDSP=0 - IF(JPDS(3).EQ.255) THEN - DO I=1,LGDS - IF(JGDS(I).NE.-1) THEN - LGDSP=LGDSP+1 - IGDSP(LGDSP)=I - JGDSP(LGDSP)=JGDS(I) - ENDIF - ENDDO - ENDIF -C COMPRESS ENS REQUEST - LENSP=0 - IF(JPDS(23).EQ.2) THEN - DO I=1,LENS - IF(JENS(I).NE.-1) THEN - LENSP=LENSP+1 - IENSP(LENSP)=I - JENSP(LENSP)=JENS(I) - ENDIF - ENDDO - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SEARCH FOR REQUEST - DOWHILE(IRET.NE.0.AND.K.LT.NNUM) - K=K+1 - LT=0 -C SEARCH FOR PDS REQUEST - IF(LPDSP.GT.0) THEN - CPDS=CHAR(0) - CPDS(1:28)=CBUF((K-1)*NLEN+26:(K-1)*NLEN+53) - NLESS=MAX(184-NLEN,0) - CPDS(29:40-NLESS)=CBUF((K-1)*NLEN+173:(K-1)*NLEN+184-NLESS) - KPTR=0 - CALL GBYTEC(CBUF,KPTR(3),(K-1)*NLEN*8+25*8,3*8) - KPDS(18)=1 - CALL GBYTEC(CPDS,KPDS(4),7*8,8) - CALL FI632(CPDS,KPTR,KPDS,KRET) - DO I=1,LPDSP - IP=IPDSP(I) - LT=LT+ABS(JPDS(IP)-KPDS(IP)) - ENDDO - ENDIF -C SEARCH FOR GDS REQUEST - IF(LT.EQ.0.AND.LGDSP.GT.0) THEN - CGDS=CHAR(0) - CGDS(1:42)=CBUF((K-1)*NLEN+54:(K-1)*NLEN+95) - NLESS=MAX(320-NLEN,0) - CGDS(43:178-NLESS)=CBUF((K-1)*NLEN+185:(K-1)*NLEN+320-NLESS) - KPTR=0 - CALL FI633(CGDS,KPTR,KGDS,KRET) - DO I=1,LGDSP - IP=IGDSP(I) - LT=LT+ABS(JGDS(IP)-KGDS(IP)) - ENDDO - ENDIF -C SEARCH FOR ENS REQUEST - IF(LT.EQ.0.AND.LENSP.GT.0) THEN - NLESS=MAX(172-NLEN,0) - CPDS(41:100-NLESS)=CBUF((K-1)*NLEN+113:(K-1)*NLEN+172-NLESS) - CALL PDSEUP(KENS,KPROB,XPROB,KCLUST,KMEMBR,45,CPDS) - DO I=1,LENSP - IP=IENSP(I) - LT=LT+ABS(JENS(IP)-KENS(IP)) - ENDDO - ENDIF -C RETURN IF REQUEST IS FOUND - IF(LT.EQ.0) THEN - CALL GBYTEC(CBUF,LSKIP,(K-1)*NLEN*8,4*8) - CALL GBYTEC(CBUF,LGRIB,(K-1)*NLEN*8+20*8,4*8) - IF(LPDSP.EQ.0) THEN - CPDS=CHAR(0) - CPDS(1:28)=CBUF((K-1)*NLEN+26:(K-1)*NLEN+53) - NLESS=MAX(184-NLEN,0) - CPDS(29:40-NLESS)=CBUF((K-1)*NLEN+173:(K-1)*NLEN+184-NLESS) - KPTR=0 - CALL GBYTEC(CBUF,KPTR(3),(K-1)*NLEN*8+25*8,3*8) - KPDS(18)=1 - CALL GBYTEC(CPDS,KPDS(4),7*8,8) - CALL FI632(CPDS,KPTR,KPDS,KRET) - ENDIF - IF(LGDSP.EQ.0) THEN - CGDS=CHAR(0) - CGDS(1:42)=CBUF((K-1)*NLEN+54:(K-1)*NLEN+95) - NLESS=MAX(320-NLEN,0) - CGDS(43:178-NLESS)=CBUF((K-1)*NLEN+185:(K-1)*NLEN+320-NLESS) - KPTR=0 - CALL FI633(CGDS,KPTR,KGDS,KRET) - ENDIF - IF(KPDS(23).EQ.2.AND.LENSP.EQ.0) THEN - NLESS=MAX(172-NLEN,0) - CPDS(41:100-NLESS)=CBUF((K-1)*NLEN+113:(K-1)*NLEN+172-NLESS) - CALL PDSEUP(KENS,KPROB,XPROB,KCLUST,KMEMBR,45,CPDS) - ENDIF - IRET=0 - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/getgbe.f b/src/fim/FIMsrc/w3/getgbe.f deleted file mode 100644 index 1569522..0000000 --- a/src/fim/FIMsrc/w3/getgbe.f +++ /dev/null @@ -1,223 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGBE(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, - & KF,K,KPDS,KGDS,KENS,LB,F,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGBE FINDS AND UNPACKS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND AND UNPACK A GRIB MESSAGE. -C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) -C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. -C (THE INDEX BUFFER IS SAVED FOR USE BY FUTURE PROSPECTIVE CALLS.) -C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE -C GRIB FILE AND UNPACKED. ITS MESSAGE NUMBER IS RETURNED ALONG WITH -C THE UNPACKED PDS AND GDS PARAMETERS, THE UNPACKED BITMAP (IF ANY), -C AND THE UNPACKED DATA. IF THE GRIB MESSAGE IS NOT FOUND, THEN THE -C RETURN CODE WILL BE NONZERO. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS -C AND ALLOWED FOR UNSPECIFIED INDEX FILE -C -C USAGE: CALL GETGBE(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, -C & KF,K,KPDS,KGDS,KENS,LB,F,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) -C JF INTEGER MAXIMUM NUMBER OF DATA POINTS TO UNPACK -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C JENS INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(23)=2) -C (=-1 FOR WILDCARD) -C (1) - APPLICATION IDENTIFIER -C (2) - ENSEMBLE TYPE -C (3) - ENSEMBLE IDENTIFIER -C (4) - PRODUCT IDENTIFIER -C (5) - SMOOTHING FLAG -C OUTPUT ARGUMENTS: -C KF INTEGER NUMBER OF DATA POINTS UNPACKED -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS -C LB LOGICAL*1 (KF) UNPACKED BITMAP IF PRESENT -C F REAL (KF) UNPACKED DATA -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 97 ERROR READING GRIB FILE -C 98 NUMBER OF DATA POINTS GREATER THAN JF -C 99 REQUEST NOT FOUND -C OTHER W3FI63 GRIB UNPACKER RETURN CODE -C -C SUBPROGRAMS CALLED: -C GETGBEM FIND AND UNPACK GRIB MESSAGE -C -C REMARKS: IN ORDER TO UNPACK GRIB FROM A MULTIPROCESSING ENVIRONMENT -C WHERE EACH PROCESSOR IS ATTEMPTING TO READ FROM ITS OWN PAIR OF -C LOGICAL UNITS, ONE MUST DIRECTLY CALL SUBPROGRAM GETGBEM AS BELOW, -C ALLOCATING A PRIVATE COPY OF CBUF, NLEN AND NNUM TO EACH PROCESSOR. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER JPDS(200),JGDS(200),JENS(200) - INTEGER KPDS(200),KGDS(200),KENS(200) - LOGICAL*1 LB(JF) - REAL F(JF) - PARAMETER(MBUF=256*1024) - CHARACTER CBUF(MBUF) - SAVE CBUF,NLEN,NNUM,MNUM - DATA LUX/0/ -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED - IF(LUGI.GT.0.AND.(J.LT.0.OR.LUGI.NE.LUX)) THEN - LUX=LUGI - JJ=MIN(J,-1-J) - ELSEIF(LUGI.LE.0.AND.(J.LT.0.OR.LUGB.NE.LUX)) THEN - LUX=LUGB - JJ=MIN(J,-1-J) - ELSE - JJ=J - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C FIND AND UNPACK GRIB MESSAGE - CALL GETGBEM(LUGB,LUGI,JF,JJ,JPDS,JGDS,JENS, - & MBUF,CBUF,NLEN,NNUM,MNUM, - & KF,K,KPDS,KGDS,KENS,LB,F,IRET) - IF(IRET.EQ.96) LUX=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/getgbeh.f b/src/fim/FIMsrc/w3/getgbeh.f deleted file mode 100644 index 030bed0..0000000 --- a/src/fim/FIMsrc/w3/getgbeh.f +++ /dev/null @@ -1,215 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGBEH(LUGB,LUGI,J,JPDS,JGDS,JENS, - & KG,KF,K,KPDS,KGDS,KENS,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGBEH FINDS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND A GRIB MESSAGE. -C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) -C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. -C (THE INDEX BUFFER IS SAVED FOR USE BY FUTURE PROSPECTIVE CALLS.) -C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN ITS MESSAGE NUMBER IS -C RETURNED ALONG WITH THE UNPACKED PDS AND GDS PARAMETERS. IF THE -C GRIB MESSAGE IS NOT FOUND, THEN THE RETURN CODE WILL BE NONZERO. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS -C AND ALLOWED FOR UNSPECIFIED INDEX FILE -C -C USAGE: CALL GETGBEH(LUGB,LUGI,J,JPDS,JGDS,JENS, -C & KG,KF,K,KPDS,KGDS,KENS,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C (ONLY USED IF LUGI=0) -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C JENS INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(23)=2) -C (=-1 FOR WILDCARD) -C (1) - APPLICATION IDENTIFIER -C (2) - ENSEMBLE TYPE -C (3) - ENSEMBLE IDENTIFIER -C (4) - PRODUCT IDENTIFIER -C (5) - SMOOTHING FLAG -C OUTPUT ARGUMENTS: -C KG INTEGER NUMBER OF BYTES IN THE GRIB MESSAGE -C KF INTEGER NUMBER OF DATA POINTS IN THE MESSAGE -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 99 REQUEST NOT FOUND -C -C SUBPROGRAMS CALLED: -C GETGBEMH FIND GRIB MESSAGE -C -C REMARKS: IN ORDER TO UNPACK GRIB FROM A MULTIPROCESSING ENVIRONMENT -C WHERE EACH PROCESSOR IS ATTEMPTING TO READ FROM ITS OWN PAIR OF -C LOGICAL UNITS, ONE MUST DIRECTLY CALL SUBPROGRAM GETGBEMH AS BELOW, -C ALLOCATING A PRIVATE COPY OF CBUF, NLEN AND NNUM TO EACH PROCESSOR. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER JPDS(200),JGDS(200),JENS(200) - INTEGER KPDS(200),KGDS(200),KENS(200) - PARAMETER(MBUF=256*1024) - CHARACTER CBUF(MBUF) - SAVE CBUF,NLEN,NNUM,MNUM - DATA LUX/0/ -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED - IF(LUGI.GT.0.AND.(J.LT.0.OR.LUGI.NE.LUX)) THEN - LUX=LUGI - JJ=MIN(J,-1-J) - ELSEIF(LUGI.LE.0.AND.(J.LT.0.OR.LUGB.NE.LUX)) THEN - LUX=LUGB - JJ=MIN(J,-1-J) - ELSE - JJ=J - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C FIND AND UNPACK GRIB MESSAGE - CALL GETGBEMH(LUGB,LUGI,JJ,JPDS,JGDS,JENS, - & MBUF,CBUF,NLEN,NNUM,MNUM, - & KG,KF,K,KPDS,KGDS,KENS,IRET) - IF(IRET.EQ.96) LUX=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/getgbem.f b/src/fim/FIMsrc/w3/getgbem.f deleted file mode 100644 index 722870d..0000000 --- a/src/fim/FIMsrc/w3/getgbem.f +++ /dev/null @@ -1,275 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGBEM(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, - & MBUF,CBUF,NLEN,NNUM,MNUM, - & KF,K,KPDS,KGDS,KENS,LB,F,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGBEM FINDS AND UNPACKS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND AND UNPACK A GRIB MESSAGE. -C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) -C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. -C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE -C GRIB FILE AND UNPACKED. ITS MESSAGE NUMBER IS RETURNED ALONG WITH -C THE UNPACKED PDS AND GDS PARAMETERS, THE UNPACKED BITMAP (IF ANY), -C AND THE UNPACKED DATA. IF THE GRIB MESSAGE IS NOT FOUND, THEN THE -C RETURN CODE WILL BE NONZERO. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS -C AND ALLOWED FOR UNSPECIFIED INDEX FILE -C -C USAGE: CALL GETGBEM(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, -C & MBUF,CBUF,NLEN,NNUM,MNUM, -C & KF,K,KPDS,KGDS,KENS,LB,F,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) -C JF INTEGER MAXIMUM NUMBER OF DATA POINTS TO UNPACK -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C JENS INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(23)=2) -C (=-1 FOR WILDCARD) -C (1) - APPLICATION IDENTIFIER -C (2) - ENSEMBLE TYPE -C (3) - ENSEMBLE IDENTIFIER -C (4) - PRODUCT IDENTIFIER -C (5) - SMOOTHING FLAG -C MBUF INTEGER LENGTH OF INDEX BUFFER IN BYTES -C CBUF CHARACTER*1 (MBUF) INDEX BUFFER -C (INITIALIZE BY SETTING J=-1) -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C (INITIALIZE BY SETTING J=-1) -C NNUM INTEGER NUMBER OF INDEX RECORDS -C (INITIALIZE BY SETTING J=-1) -C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED -C (INITIALIZE BY SETTING J=-1) -C OUTPUT ARGUMENTS: -C CBUF CHARACTER*1 (MBUF) INDEX BUFFER -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C NNUM INTEGER NUMBER OF INDEX RECORDS -C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED -C KF INTEGER NUMBER OF DATA POINTS UNPACKED -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS -C LB LOGICAL*1 (KF) UNPACKED BITMAP IF PRESENT -C F REAL (KF) UNPACKED DATA -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 97 ERROR READING GRIB FILE -C 98 NUMBER OF DATA POINTS GREATER THAN JF -C 99 REQUEST NOT FOUND -C OTHER W3FI63 GRIB UNPACKER RETURN CODE -C -C SUBPROGRAMS CALLED: -C GETGI READ INDEX FILE -C GETGIR READ INDEX BUFFER FROM GRIB FILE -C GETGB1S SEARCH INDEX RECORDS -C GETGB1R READ AND UNPACK GRIB RECORD -C LENGDS RETURN THE LENGTH OF A GRID -C -C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER JPDS(200),JGDS(200),JENS(200) - INTEGER KPDS(200),KGDS(200),KENS(200) - CHARACTER CBUF(MBUF) - LOGICAL*1 LB(JF) - REAL F(JF) - PARAMETER(MSK1=32000,MSK2=4000) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SEARCH PREVIOUS INDEX BUFFER IF POSSIBLE - IF(J.GE.0) THEN - IF(MNUM.GE.0) THEN - IRGI=0 - ELSE - MNUM=-1-MNUM - IRGI=1 - ENDIF - JR=J-MNUM - IF(JR.GE.0.AND.(JR.LT.NNUM.OR.IRGI.EQ.0)) THEN - CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, - & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) - IF(IRGS.EQ.0) K=KR+MNUM - IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM - IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM - ELSE - MNUM=J - IRGI=1 - IRGS=1 - ENDIF - ELSE - MNUM=-1-J - IRGI=1 - IRGS=1 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ AND SEARCH NEXT INDEX BUFFER - JR=0 - DOWHILE(IRGI.EQ.1.AND.IRGS.EQ.1) - IF(LUGI.GT.0) THEN - CALL GETGI(LUGI,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) - ELSE - CALL GETGIR(LUGB,MSK1,MSK2,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) - ENDIF - IF(IRGI.LE.1) THEN - CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, - & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) - IF(IRGS.EQ.0) K=KR+MNUM - IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM - IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ AND UNPACK GRIB RECORD - IF(IRGI.GT.1) THEN - IRET=96 - ELSEIF(IRGS.NE.0) THEN - IRET=99 - ELSEIF(LENGDS(KGDS).GT.JF) THEN - IRET=98 - ELSE - CALL GETGB1R(LUGB,LSKIP,LGRIB,KF,KPDS,KGDS,KENS,LB,F,NBITSS - + ,IRET) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/getgbemh.f b/src/fim/FIMsrc/w3/getgbemh.f deleted file mode 100644 index deb36ab..0000000 --- a/src/fim/FIMsrc/w3/getgbemh.f +++ /dev/null @@ -1,265 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGBEMH(LUGB,LUGI,J,JPDS,JGDS,JENS, - & MBUF,CBUF,NLEN,NNUM,MNUM, - & KG,KF,K,KPDS,KGDS,KENS,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGBEMH FINDS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND A GRIB MESSAGE. -C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) -C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. -C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN ITS MESSAGE NUMBER IS -C RETURNED ALONG WITH THE UNPACKED PDS AND GDS PARAMETERS. IF THE -C GRIB MESSAGE IS NOT FOUND, THEN THE RETURN CODE WILL BE NONZERO. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS -C AND ALLOWED FOR UNSPECIFIED INDEX FILE -C -C USAGE: CALL GETGBEMH(LUGB,LUGI,J,JPDS,JGDS,JENS, -C & MBUF,CBUF,NLEN,NNUM,MNUM, -C & KG,KF,K,KPDS,KGDS,KENS,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C (ONLY USED IF LUGI=0) -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C JENS INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(23)=2) -C (=-1 FOR WILDCARD) -C (1) - APPLICATION IDENTIFIER -C (2) - ENSEMBLE TYPE -C (3) - ENSEMBLE IDENTIFIER -C (4) - PRODUCT IDENTIFIER -C (5) - SMOOTHING FLAG -C MBUF INTEGER LENGTH OF INDEX BUFFER IN BYTES -C CBUF CHARACTER*1 (MBUF) INDEX BUFFER -C (INITIALIZE BY SETTING J=-1) -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C (INITIALIZE BY SETTING J=-1) -C NNUM INTEGER NUMBER OF INDEX RECORDS -C (INITIALIZE BY SETTING J=-1) -C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED -C (INITIALIZE BY SETTING J=-1) -C OUTPUT ARGUMENTS: -C CBUF CHARACTER*1 (MBUF) INDEX BUFFER -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C NNUM INTEGER NUMBER OF INDEX RECORDS -C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED -C KG INTEGER NUMBER OF BYTES IN THE GRIB MESSAGE -C KF INTEGER NUMBER OF DATA POINTS IN THE MESSAGE -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 99 REQUEST NOT FOUND -C -C SUBPROGRAMS CALLED: -C GETGI READ INDEX FILE -C GETGIR READ INDEX BUFFER FROM GRIB FILE -C GETGB1S SEARCH INDEX RECORDS -C LENGDS RETURN THE LENGTH OF A GRID -C -C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER JPDS(200),JGDS(200),JENS(200) - INTEGER KPDS(200),KGDS(200),KENS(200) - CHARACTER CBUF(MBUF) - PARAMETER(MSK1=32000,MSK2=4000) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SEARCH PREVIOUS INDEX BUFFER IF POSSIBLE - IF(J.GE.0) THEN - IF(MNUM.GE.0) THEN - IRGI=0 - ELSE - MNUM=-1-MNUM - IRGI=1 - ENDIF - JR=J-MNUM - IF(JR.GE.0.AND.(JR.LT.NNUM.OR.IRGI.EQ.0)) THEN - CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, - & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) - IF(IRGS.EQ.0) K=KR+MNUM - IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM - IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM - ELSE - MNUM=J - IRGI=1 - IRGS=1 - ENDIF - ELSE - MNUM=-1-J - IRGI=1 - IRGS=1 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ AND SEARCH NEXT INDEX BUFFER - JR=0 - DOWHILE(IRGI.EQ.1.AND.IRGS.EQ.1) - IF(LUGI.GT.0) THEN - CALL GETGI(LUGI,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) - ELSE - CALL GETGIR(LUGB,MSK1,MSK2,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) - ENDIF - IF(IRGI.LE.1) THEN - CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, - & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) - IF(IRGS.EQ.0) K=KR+MNUM - IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM - IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ GRIB RECORD - IF(IRGI.GT.1) THEN - IRET=96 - ELSEIF(IRGS.NE.0) THEN - IRET=99 - ELSE - KG=LGRIB - KF=LENGDS(KGDS) - IRET=0 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/getgbemn.f b/src/fim/FIMsrc/w3/getgbemn.f deleted file mode 100644 index 8b97458..0000000 --- a/src/fim/FIMsrc/w3/getgbemn.f +++ /dev/null @@ -1,277 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGBEMN(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, - & MBUF,CBUF,NLEN,NNUM,MNUM, - & KF,K,KPDS,KGDS,KENS,LB,F,NBITSS,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGBEM FINDS AND UNPACKS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND AND UNPACK A GRIB MESSAGE. -C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) -C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. -C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE -C GRIB FILE AND UNPACKED. ITS MESSAGE NUMBER IS RETURNED ALONG WITH -C THE UNPACKED PDS AND GDS PARAMETERS, THE UNPACKED BITMAP (IF ANY), -C AND THE UNPACKED DATA. IF THE GRIB MESSAGE IS NOT FOUND, THEN THE -C RETURN CODE WILL BE NONZERO. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS -C AND ALLOWED FOR UNSPECIFIED INDEX FILE -C 04-07-22 CHUANG ADD PACKING BIT NUMBER NBITSS IN THE ARGUMENT -C LIST BECAUSE ETA GRIB FILES NEED IT TO REPACK GRIB FILE -C -C USAGE: CALL GETGBEM(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, -C & MBUF,CBUF,NLEN,NNUM,MNUM, -C & KF,K,KPDS,KGDS,KENS,LB,F,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) -C JF INTEGER MAXIMUM NUMBER OF DATA POINTS TO UNPACK -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C JENS INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(23)=2) -C (=-1 FOR WILDCARD) -C (1) - APPLICATION IDENTIFIER -C (2) - ENSEMBLE TYPE -C (3) - ENSEMBLE IDENTIFIER -C (4) - PRODUCT IDENTIFIER -C (5) - SMOOTHING FLAG -C MBUF INTEGER LENGTH OF INDEX BUFFER IN BYTES -C CBUF CHARACTER*1 (MBUF) INDEX BUFFER -C (INITIALIZE BY SETTING J=-1) -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C (INITIALIZE BY SETTING J=-1) -C NNUM INTEGER NUMBER OF INDEX RECORDS -C (INITIALIZE BY SETTING J=-1) -C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED -C (INITIALIZE BY SETTING J=-1) -C OUTPUT ARGUMENTS: -C CBUF CHARACTER*1 (MBUF) INDEX BUFFER -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C NNUM INTEGER NUMBER OF INDEX RECORDS -C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED -C KF INTEGER NUMBER OF DATA POINTS UNPACKED -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS -C LB LOGICAL*1 (KF) UNPACKED BITMAP IF PRESENT -C F REAL (KF) UNPACKED DATA -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 97 ERROR READING GRIB FILE -C 98 NUMBER OF DATA POINTS GREATER THAN JF -C 99 REQUEST NOT FOUND -C OTHER W3FI63 GRIB UNPACKER RETURN CODE -C -C SUBPROGRAMS CALLED: -C GETGI READ INDEX FILE -C GETGIR READ INDEX BUFFER FROM GRIB FILE -C GETGB1S SEARCH INDEX RECORDS -C GETGB1R READ AND UNPACK GRIB RECORD -C LENGDS RETURN THE LENGTH OF A GRID -C -C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER JPDS(200),JGDS(200),JENS(200) - INTEGER KPDS(200),KGDS(200),KENS(200) - CHARACTER CBUF(MBUF) - LOGICAL*1 LB(JF) - REAL F(JF) - PARAMETER(MSK1=32000,MSK2=4000) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SEARCH PREVIOUS INDEX BUFFER IF POSSIBLE - IF(J.GE.0) THEN - IF(MNUM.GE.0) THEN - IRGI=0 - ELSE - MNUM=-1-MNUM - IRGI=1 - ENDIF - JR=J-MNUM - IF(JR.GE.0.AND.(JR.LT.NNUM.OR.IRGI.EQ.0)) THEN - CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, - & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) - IF(IRGS.EQ.0) K=KR+MNUM - IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM - IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM - ELSE - MNUM=J - IRGI=1 - IRGS=1 - ENDIF - ELSE - MNUM=-1-J - IRGI=1 - IRGS=1 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ AND SEARCH NEXT INDEX BUFFER - JR=0 - DOWHILE(IRGI.EQ.1.AND.IRGS.EQ.1) - IF(LUGI.GT.0) THEN - CALL GETGI(LUGI,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) - ELSE - CALL GETGIR(LUGB,MSK1,MSK2,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) - ENDIF - IF(IRGI.LE.1) THEN - CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, - & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) - IF(IRGS.EQ.0) K=KR+MNUM - IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM - IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ AND UNPACK GRIB RECORD - IF(IRGI.GT.1) THEN - IRET=96 - ELSEIF(IRGS.NE.0) THEN - IRET=99 - ELSEIF(LENGDS(KGDS).GT.JF) THEN - IRET=98 - ELSE - CALL GETGB1R(LUGB,LSKIP,LGRIB,KF,KPDS,KGDS,KENS,LB,F,NBITSS - + ,IRET) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/getgbemp.f b/src/fim/FIMsrc/w3/getgbemp.f deleted file mode 100644 index b21b83c..0000000 --- a/src/fim/FIMsrc/w3/getgbemp.f +++ /dev/null @@ -1,271 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGBEMP(LUGB,LUGI,JG,J,JPDS,JGDS,JENS, - & MBUF,CBUF,NLEN,NNUM,MNUM, - & KG,K,KPDS,KGDS,KENS,G,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGBEMP FINDS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND A GRIB MESSAGE. -C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) -C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. -C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE -C GRIB FILE. ITS MESSAGE NUMBER IS RETURNED ALONG WITH THE UNPACKED -C PDS AND GDS PARAMETERS AND THE PACKED GRIB MESSAGE. IF THE GRIB -C MESSAGE IS NOT FOUND, THEN THE RETURN CODE WILL BE NONZERO. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS -C AND ALLOWED FOR UNSPECIFIED INDEX FILE -C -C USAGE: CALL GETGBEMP(LUGB,LUGI,JG,J,JPDS,JGDS,JENS, -C & MBUF,CBUF,NLEN,NNUM,MNUM, -C & KG,K,KPDS,KGDS,KENS,G,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) -C JG INTEGER MAXIMUM NUMBER OF BYTES IN THE GRIB MESSAGE -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C JENS INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(23)=2) -C (=-1 FOR WILDCARD) -C (1) - APPLICATION IDENTIFIER -C (2) - ENSEMBLE TYPE -C (3) - ENSEMBLE IDENTIFIER -C (4) - PRODUCT IDENTIFIER -C (5) - SMOOTHING FLAG -C MBUF INTEGER LENGTH OF INDEX BUFFER IN BYTES -C CBUF CHARACTER*1 (MBUF) INDEX BUFFER -C (INITIALIZE BY SETTING J=-1) -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C (INITIALIZE BY SETTING J=-1) -C NNUM INTEGER NUMBER OF INDEX RECORDS -C (INITIALIZE BY SETTING J=-1) -C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED -C (INITIALIZE BY SETTING J=-1) -C OUTPUT ARGUMENTS: -C CBUF CHARACTER*1 (MBUF) INDEX BUFFER -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C NNUM INTEGER NUMBER OF INDEX RECORDS -C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED -C KG INTEGER NUMBER OF BYTES IN THE GRIB MESSAGE -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS -C G CHARACTER*1 (KG) GRIB MESSAGE -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 97 ERROR READING GRIB FILE -C 98 NUMBER OF BYTES GREATER THAN JG -C 99 REQUEST NOT FOUND -C -C SUBPROGRAMS CALLED: -C GETGI READ INDEX FILE -C GETGIR READ INDEX BUFFER FROM GRIB FILE -C GETGB1S SEARCH INDEX RECORDS -C BAREAD READ GRIB RECORD -C -C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER JPDS(200),JGDS(200),JENS(200) - INTEGER KPDS(200),KGDS(200),KENS(200) - CHARACTER CBUF(MBUF) - CHARACTER G(JG) - PARAMETER(MSK1=32000,MSK2=4000) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SEARCH PREVIOUS INDEX BUFFER IF POSSIBLE - IF(J.GE.0) THEN - IF(MNUM.GE.0) THEN - IRGI=0 - ELSE - MNUM=-1-MNUM - IRGI=1 - ENDIF - JR=J-MNUM - IF(JR.GE.0.AND.(JR.LT.NNUM.OR.IRGI.EQ.0)) THEN - CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, - & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) - IF(IRGS.EQ.0) K=KR+MNUM - IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM - IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM - ELSE - MNUM=J - IRGI=1 - IRGS=1 - ENDIF - ELSE - MNUM=-1-J - IRGI=1 - IRGS=1 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ AND SEARCH NEXT INDEX BUFFER - JR=0 - DOWHILE(IRGI.EQ.1.AND.IRGS.EQ.1) - IF(LUGI.GT.0) THEN - CALL GETGI(LUGI,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) - ELSE - CALL GETGIR(LUGB,MSK1,MSK2,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) - ENDIF - IF(IRGI.LE.1) THEN - CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, - & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) - IF(IRGS.EQ.0) K=KR+MNUM - IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM - IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ GRIB RECORD - IF(IRGI.GT.1) THEN - IRET=96 - ELSEIF(IRGS.NE.0) THEN - IRET=99 - ELSEIF(LGRIB.GT.JG) THEN - IRET=98 - ELSE - IRET=97 - CALL BAREAD(LUGB,LSKIP,LGRIB,KG,G) - IF(KG.EQ.LGRIB) IRET=0 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/getgbens.f b/src/fim/FIMsrc/w3/getgbens.f deleted file mode 100644 index 039680e..0000000 --- a/src/fim/FIMsrc/w3/getgbens.f +++ /dev/null @@ -1,207 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGBENS(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, - & KF,K,KPDS,KGDS,KENS,LB,F,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGBENS FINDS AND UNPACKS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND AND UNPACK A GRIB MESSAGE. -C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) -C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. -C (THE INDEX BUFFER IS SAVED FOR USE BY FUTURE PROSPECTIVE CALLS.) -C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE -C GRIB FILE AND UNPACKED. ITS MESSAGE NUMBER IS RETURNED ALONG WITH -C THE UNPACKED PDS AND GDS PARAMETERS, THE UNPACKED BITMAP (IF ANY), -C AND THE UNPACKED DATA. IF THE GRIB MESSAGE IS NOT FOUND, THEN THE -C RETURN CODE WILL BE NONZERO. -C THIS OBSOLESCENT VERSION HAS BEEN REPLACED BY GETGBE. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS -C AND ALLOWED FOR UNSPECIFIED INDEX FILE -C -C USAGE: CALL GETGBENS(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, -C & KF,K,KPDS,KGDS,KENS,LB,F,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) -C JF INTEGER MAXIMUM NUMBER OF DATA POINTS TO UNPACK -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C JENS INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(23)=2) -C (=-1 FOR WILDCARD) -C (1) - APPLICATION IDENTIFIER -C (2) - ENSEMBLE TYPE -C (3) - ENSEMBLE IDENTIFIER -C (4) - PRODUCT IDENTIFIER -C (5) - SMOOTHING FLAG -C OUTPUT ARGUMENTS: -C KF INTEGER NUMBER OF DATA POINTS UNPACKED -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS -C LB LOGICAL*1 (KF) UNPACKED BITMAP IF PRESENT -C F REAL (KF) UNPACKED DATA -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 97 ERROR READING GRIB FILE -C 98 NUMBER OF DATA POINTS GREATER THAN JF -C 99 REQUEST NOT FOUND -C OTHER W3FI63 GRIB UNPACKER RETURN CODE -C -C SUBPROGRAMS CALLED: -C GETGBE FIND AND UNPACK GRIB MESSAGE -C -C REMARKS: IN ORDER TO UNPACK GRIB FROM A MULTIPROCESSING ENVIRONMENT -C WHERE EACH PROCESSOR IS ATTEMPTING TO READ FROM ITS OWN PAIR OF -C LOGICAL UNITS, ONE MUST DIRECTLY CALL SUBPROGRAM GETGBEM AS BELOW, -C ALLOCATING A PRIVATE COPY OF CBUF, NLEN AND NNUM TO EACH PROCESSOR. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER JPDS(200),JGDS(200),JENS(200) - INTEGER KPDS(200),KGDS(200),KENS(200) - LOGICAL*1 LB(JF) - REAL F(JF) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - PRINT *,'PLEASE USE GETGBE RATHER THAN GETGBENS' - CALL GETGBE(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, - & KF,K,KPDS,KGDS,KENS,LB,F,IRET) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/getgbep.f b/src/fim/FIMsrc/w3/getgbep.f deleted file mode 100644 index 19faea0..0000000 --- a/src/fim/FIMsrc/w3/getgbep.f +++ /dev/null @@ -1,219 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGBEP(LUGB,LUGI,JG,J,JPDS,JGDS,JENS, - & KG,K,KPDS,KGDS,KENS,G,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGBEP FINDS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND A GRIB MESSAGE. -C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) -C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. -C (THE INDEX BUFFER IS SAVED FOR USE BY FUTURE PROSPECTIVE CALLS.) -C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE -C GRIB FILE. ITS MESSAGE NUMBER IS RETURNED ALONG WITH THE UNPACKED -C PDS AND GDS PARAMETERS AND THE PACKED GRIB MESSAGE. IF THE GRIB -C MESSAGE IS NOT FOUND, THEN THE RETURN CODE WILL BE NONZERO. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS -C AND ALLOWED FOR UNSPECIFIED INDEX FILE -C -C USAGE: CALL GETGBEP(LUGB,LUGI,JG,J,JPDS,JGDS,JENS, -C & KG,K,KPDS,KGDS,KENS,G,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) -C JG INTEGER MAXIMUM NUMBER OF BYTES IN THE GRIB MESSAGE -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C JENS INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(23)=2) -C (=-1 FOR WILDCARD) -C (1) - APPLICATION IDENTIFIER -C (2) - ENSEMBLE TYPE -C (3) - ENSEMBLE IDENTIFIER -C (4) - PRODUCT IDENTIFIER -C (5) - SMOOTHING FLAG -C OUTPUT ARGUMENTS: -C KG INTEGER NUMBER OF BYTES IN THE GRIB MESSAGE -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS -C G CHARACTER*1 (KG) GRIB MESSAGE -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 97 ERROR READING GRIB FILE -C 98 NUMBER OF BYTES GREATER THAN JG -C 99 REQUEST NOT FOUND -C -C SUBPROGRAMS CALLED: -C GETGBEMP FIND GRIB MESSAGE -C -C REMARKS: IN ORDER TO UNPACK GRIB FROM A MULTIPROCESSING ENVIRONMENT -C WHERE EACH PROCESSOR IS ATTEMPTING TO READ FROM ITS OWN PAIR OF -C LOGICAL UNITS, ONE MUST DIRECTLY CALL SUBPROGRAM GETGBEMP AS BELOW, -C ALLOCATING A PRIVATE COPY OF CBUF, NLEN AND NNUM TO EACH PROCESSOR. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER JPDS(200),JGDS(200),JENS(200) - INTEGER KPDS(200),KGDS(200),KENS(200) - CHARACTER G(JG) - PARAMETER(MBUF=256*1024) - CHARACTER CBUF(MBUF) - SAVE CBUF,NLEN,NNUM,MNUM - DATA LUX/0/ -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED - IF(LUGI.GT.0.AND.(J.LT.0.OR.LUGI.NE.LUX)) THEN - LUX=LUGI - JJ=MIN(J,-1-J) - ELSEIF(LUGI.LE.0.AND.(J.LT.0.OR.LUGB.NE.LUX)) THEN - LUX=LUGB - JJ=MIN(J,-1-J) - ELSE - JJ=J - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C FIND AND UNPACK GRIB MESSAGE - CALL GETGBEMP(LUGB,LUGI,JG,JJ,JPDS,JGDS,JENS, - & MBUF,CBUF,NLEN,NNUM,MNUM, - & KG,K,KPDS,KGDS,KENS,G,IRET) - IF(IRET.EQ.96) LUX=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/getgbex.f b/src/fim/FIMsrc/w3/getgbex.f deleted file mode 100644 index 4698b0f..0000000 --- a/src/fim/FIMsrc/w3/getgbex.f +++ /dev/null @@ -1,233 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGBEX(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, - & KF,K,KPDS,KGDS,KENS,KPROB,XPROB,KCLUST,KMEMBR, - & LB,F,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGBEX FINDS AND UNPACKS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND AND UNPACK A GRIB MESSAGE. -C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) -C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. -C (THE INDEX BUFFER IS SAVED FOR USE BY FUTURE PROSPECTIVE CALLS.) -C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE -C GRIB FILE AND UNPACKED. ITS MESSAGE NUMBER IS RETURNED ALONG WITH -C THE UNPACKED PDS AND GDS PARAMETERS, THE UNPACKED BITMAP (IF ANY), -C AND THE UNPACKED DATA. IF THE GRIB MESSAGE IS NOT FOUND, THEN THE -C RETURN CODE WILL BE NONZERO. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS -C AND ALLOWED FOR UNSPECIFIED INDEX FILE -C 97-02-11 Y.ZHU INCLUDED PROBABILITY AND CLUSTER ARGUMENTS -C -C USAGE: CALL GETGBEX(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, -C & KF,K,KPDS,KGDS,KENS,KPROB,XPROB,KCLUST,KMEMBR, -C & LB,F,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) -C JF INTEGER MAXIMUM NUMBER OF DATA POINTS TO UNPACK -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C JENS INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(23)=2) -C (=-1 FOR WILDCARD) -C (1) - APPLICATION IDENTIFIER -C (2) - ENSEMBLE TYPE -C (3) - ENSEMBLE IDENTIFIER -C (4) - PRODUCT IDENTIFIER -C (5) - SMOOTHING FLAG -C OUTPUT ARGUMENTS: -C KF INTEGER NUMBER OF DATA POINTS UNPACKED -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS -C KPROB INTEGER (2) PROBABILITY ENSEMBLE PARMS -C XPROB REAL (2) PROBABILITY ENSEMBLE PARMS -C KCLUST INTEGER (16) CLUSTER ENSEMBLE PARMS -C KMEMBR INTEGER (8) CLUSTER ENSEMBLE PARMS -C LB LOGICAL*1 (KF) UNPACKED BITMAP IF PRESENT -C F REAL (KF) UNPACKED DATA -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 97 ERROR READING GRIB FILE -C 98 NUMBER OF DATA POINTS GREATER THAN JF -C 99 REQUEST NOT FOUND -C OTHER W3FI63 GRIB UNPACKER RETURN CODE -C -C SUBPROGRAMS CALLED: -C GETGBEXM FIND AND UNPACK GRIB MESSAGE -C -C REMARKS: IN ORDER TO UNPACK GRIB FROM A MULTIPROCESSING ENVIRONMENT -C WHERE EACH PROCESSOR IS ATTEMPTING TO READ FROM ITS OWN PAIR OF -C LOGICAL UNITS, ONE MUST DIRECTLY CALL SUBPROGRAM GETGBEXM AS BELOW, -C ALLOCATING A PRIVATE COPY OF CBUF, NLEN AND NNUM TO EACH PROCESSOR. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER JPDS(200),JGDS(200),JENS(200) - INTEGER KPDS(200),KGDS(200),KENS(200) - INTEGER KPROB(2),KCLUST(16),KMEMBR(80) - REAL XPROB(2) - LOGICAL*1 LB(JF) - REAL F(JF) - PARAMETER(MBUF=256*1024) - CHARACTER CBUF(MBUF) - SAVE CBUF,NLEN,NNUM,MNUM - DATA LUX/0/ -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED - IF(LUGI.GT.0.AND.(J.LT.0.OR.LUGI.NE.LUX)) THEN - LUX=LUGI - JJ=MIN(J,-1-J) - ELSEIF(LUGI.LE.0.AND.(J.LT.0.OR.LUGB.NE.LUX)) THEN - LUX=LUGB - JJ=MIN(J,-1-J) - ELSE - JJ=J - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C FIND AND UNPACK GRIB MESSAGE - CALL GETGBEXM(LUGB,LUGI,JF,JJ,JPDS,JGDS,JENS, - & MBUF,CBUF,NLEN,NNUM,MNUM, - & KF,K,KPDS,KGDS,KENS,KPROB,XPROB,KCLUST,KMEMBR, - & LB,F,IRET) - IF(IRET.EQ.96) LUX=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/getgbexm.f b/src/fim/FIMsrc/w3/getgbexm.f deleted file mode 100644 index 765c6d5..0000000 --- a/src/fim/FIMsrc/w3/getgbexm.f +++ /dev/null @@ -1,284 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGBEXM(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, - & MBUF,CBUF,NLEN,NNUM,MNUM, - & KF,K,KPDS,KGDS,KENS,KPROB,XPROB,KCLUST,KMEMBR, - & LB,F,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGBEXM FINDS AND UNPACKS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND AND UNPACK A GRIB MESSAGE. -C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) -C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. -C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE -C GRIB FILE AND UNPACKED. ITS MESSAGE NUMBER IS RETURNED ALONG WITH -C THE UNPACKED PDS AND GDS PARAMETERS, THE UNPACKED BITMAP (IF ANY), -C AND THE UNPACKED DATA. IF THE GRIB MESSAGE IS NOT FOUND, THEN THE -C RETURN CODE WILL BE NONZERO. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS -C AND ALLOWED FOR UNSPECIFIED INDEX FILE -C 97-02-11 Y.ZHU INCLUDED PROBABILITY AND CLUSTER ARGUMENTS -C -C USAGE: CALL GETGBEXM(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, -C & MBUF,CBUF,NLEN,NNUM,MNUM, -C & KF,K,KPDS,KGDS,KENS,KPROB,XPROB,KCLUST,KMEMBR, -C & LB,F,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) -C JF INTEGER MAXIMUM NUMBER OF DATA POINTS TO UNPACK -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C JENS INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(23)=2) -C (=-1 FOR WILDCARD) -C (1) - APPLICATION IDENTIFIER -C (2) - ENSEMBLE TYPE -C (3) - ENSEMBLE IDENTIFIER -C (4) - PRODUCT IDENTIFIER -C (5) - SMOOTHING FLAG -C MBUF INTEGER LENGTH OF INDEX BUFFER IN BYTES -C CBUF CHARACTER*1 (MBUF) INDEX BUFFER -C (INITIALIZE BY SETTING J=-1) -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C (INITIALIZE BY SETTING J=-1) -C NNUM INTEGER NUMBER OF INDEX RECORDS -C (INITIALIZE BY SETTING J=-1) -C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED -C (INITIALIZE BY SETTING J=-1) -C OUTPUT ARGUMENTS: -C CBUF CHARACTER*1 (MBUF) INDEX BUFFER -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C NNUM INTEGER NUMBER OF INDEX RECORDS -C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED -C KF INTEGER NUMBER OF DATA POINTS UNPACKED -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS -C KPROB INTEGER (2) PROBABILITY ENSEMBLE PARMS -C XPROB REAL (2) PROBABILITY ENSEMBLE PARMS -C KCLUST INTEGER (16) CLUSTER ENSEMBLE PARMS -C KMEMBR INTEGER (8) CLUSTER ENSEMBLE PARMS -C LB LOGICAL*1 (KF) UNPACKED BITMAP IF PRESENT -C F REAL (KF) UNPACKED DATA -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 97 ERROR READING GRIB FILE -C 98 NUMBER OF DATA POINTS GREATER THAN JF -C 99 REQUEST NOT FOUND -C OTHER W3FI63 GRIB UNPACKER RETURN CODE -C -C SUBPROGRAMS CALLED: -C GETGI READ INDEX FILE -C GETGIR READ INDEX BUFFER FROM GRIB FILE -C GETGB1S SEARCH INDEX RECORDS -C GETGB1RE READ AND UNPACK GRIB RECORD -C LENGDS RETURN THE LENGTH OF A GRID -C -C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER JPDS(200),JGDS(200),JENS(200) - INTEGER KPDS(200),KGDS(200),KENS(200) - INTEGER KPROB(2),KCLUST(16),KMEMBR(80) - REAL XPROB(2) - CHARACTER CBUF(MBUF) - LOGICAL*1 LB(JF) - REAL F(JF) - PARAMETER(MSK1=32000,MSK2=4000) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SEARCH PREVIOUS INDEX BUFFER IF POSSIBLE - IF(J.GE.0) THEN - IF(MNUM.GE.0) THEN - IRGI=0 - ELSE - MNUM=-1-MNUM - IRGI=1 - ENDIF - JR=J-MNUM - IF(JR.GE.0.AND.(JR.LT.NNUM.OR.IRGI.EQ.0)) THEN - CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, - & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) - IF(IRGS.EQ.0) K=KR+MNUM - IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM - IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM - ELSE - MNUM=J - IRGI=1 - IRGS=1 - ENDIF - ELSE - MNUM=-1-J - IRGI=1 - IRGS=1 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ AND SEARCH NEXT INDEX BUFFER - JR=0 - DOWHILE(IRGI.EQ.1.AND.IRGS.EQ.1) - IF(LUGI.GT.0) THEN - CALL GETGI(LUGI,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) - ELSE - CALL GETGIR(LUGB,MSK1,MSK2,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) - ENDIF - IF(IRGI.LE.1) THEN - CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, - & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) - IF(IRGS.EQ.0) K=KR+MNUM - IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM - IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ AND UNPACK GRIB RECORD - IF(IRGI.GT.1) THEN - IRET=96 - ELSEIF(IRGS.NE.0) THEN - IRET=99 - ELSEIF(LENGDS(KGDS).GT.JF) THEN - IRET=98 - ELSE - CALL GETGB1RE(LUGB,LSKIP,LGRIB,KF,KPDS,KGDS,KENS, - & KPROB,XPROB,KCLUST,KMEMBR,LB,F,IRET) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/getgbh.f b/src/fim/FIMsrc/w3/getgbh.f deleted file mode 100644 index 115dee4..0000000 --- a/src/fim/FIMsrc/w3/getgbh.f +++ /dev/null @@ -1,206 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGBH(LUGB,LUGI,J,JPDS,JGDS, - & KG,KF,K,KPDS,KGDS,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGBH FINDS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND A GRIB MESSAGE. -C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) -C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. -C (THE INDEX BUFFER IS SAVED FOR USE BY FUTURE PROSPECTIVE CALLS.) -C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN ITS MESSAGE NUMBER IS -C RETURNED ALONG WITH THE UNPACKED PDS AND GDS PARAMETERS. IF THE -C GRIB MESSAGE IS NOT FOUND, THEN THE RETURN CODE WILL BE NONZERO. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS -C AND ALLOWED FOR UNSPECIFIED INDEX FILE -C -C USAGE: CALL GETGBH(LUGB,LUGI,J,JPDS,JGDS, -C & KG,KF,K,KPDS,KGDS,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C (ONLY USED IF LUGI=0) -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C OUTPUT ARGUMENTS: -C KG INTEGER NUMBER OF BYTES IN THE GRIB MESSAGE -C KF INTEGER NUMBER OF DATA POINTS IN THE MESSAGE -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 99 REQUEST NOT FOUND -C -C SUBPROGRAMS CALLED: -C GETGBMH FIND GRIB MESSAGE -C -C REMARKS: IN ORDER TO UNPACK GRIB FROM A MULTIPROCESSING ENVIRONMENT -C WHERE EACH PROCESSOR IS ATTEMPTING TO READ FROM ITS OWN PAIR OF -C LOGICAL UNITS, ONE MUST DIRECTLY CALL SUBPROGRAM GETGBMH AS BELOW, -C ALLOCATING A PRIVATE COPY OF CBUF, NLEN AND NNUM TO EACH PROCESSOR. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER JPDS(200),JGDS(200) - INTEGER KPDS(200),KGDS(200) - PARAMETER(MBUF=256*1024) - CHARACTER CBUF(MBUF) - SAVE CBUF,NLEN,NNUM,MNUM - DATA LUX/0/ -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED - IF(LUGI.GT.0.AND.(J.LT.0.OR.LUGI.NE.LUX)) THEN - LUX=LUGI - JJ=MIN(J,-1-J) - ELSEIF(LUGI.LE.0.AND.(J.LT.0.OR.LUGB.NE.LUX)) THEN - LUX=LUGB - JJ=MIN(J,-1-J) - ELSE - JJ=J - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C FIND AND UNPACK GRIB MESSAGE - CALL GETGBMH(LUGB,LUGI,JJ,JPDS,JGDS, - & MBUF,CBUF,NLEN,NNUM,MNUM, - & KG,KF,K,KPDS,KGDS,IRET) - IF(IRET.EQ.96) LUX=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/getgbm.f b/src/fim/FIMsrc/w3/getgbm.f deleted file mode 100644 index d95b542..0000000 --- a/src/fim/FIMsrc/w3/getgbm.f +++ /dev/null @@ -1,270 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGBM(LUGB,LUGI,JF,J,JPDS,JGDS, - & MBUF,CBUF,NLEN,NNUM,MNUM, - & KF,K,KPDS,KGDS,LB,F,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGBM FINDS AND UNPACKS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND AND UNPACK A GRIB MESSAGE. -C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) -C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. -C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE -C GRIB FILE AND UNPACKED. ITS MESSAGE NUMBER IS RETURNED ALONG WITH -C THE UNPACKED PDS AND GDS PARAMETERS, THE UNPACKED BITMAP (IF ANY), -C AND THE UNPACKED DATA. IF THE GRIB MESSAGE IS NOT FOUND, THEN THE -C RETURN CODE WILL BE NONZERO. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS -C AND ALLOWED FOR UNSPECIFIED INDEX FILE -C 04-07-22 CHUANG ADD NBITSS TO THE ARGUMENT LIST OF GETGB1R THAT -C IS CALLED IN THIS SUBROUTINE -C -C USAGE: CALL GETGBM(LUGB,LUGI,JF,J,JPDS,JGDS, -C & MBUF,CBUF,NLEN,NNUM,MNUM, -C & KF,K,KPDS,KGDS,LB,F,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) -C JF INTEGER MAXIMUM NUMBER OF DATA POINTS TO UNPACK -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C MBUF INTEGER LENGTH OF INDEX BUFFER IN BYTES -C CBUF CHARACTER*1 (MBUF) INDEX BUFFER -C (INITIALIZE BY SETTING J=-1) -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C (INITIALIZE BY SETTING J=-1) -C NNUM INTEGER NUMBER OF INDEX RECORDS -C (INITIALIZE BY SETTING J=-1) -C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED -C (INITIALIZE BY SETTING J=-1) -C OUTPUT ARGUMENTS: -C CBUF CHARACTER*1 (MBUF) INDEX BUFFER -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C NNUM INTEGER NUMBER OF INDEX RECORDS -C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED -C KF INTEGER NUMBER OF DATA POINTS UNPACKED -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C LB LOGICAL*1 (KF) UNPACKED BITMAP IF PRESENT -C F REAL (KF) UNPACKED DATA -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 97 ERROR READING GRIB FILE -C 98 NUMBER OF DATA POINTS GREATER THAN JF -C 99 REQUEST NOT FOUND -C OTHER W3FI63 GRIB UNPACKER RETURN CODE -C -C SUBPROGRAMS CALLED: -C GETGI READ INDEX FILE -C GETGIR READ INDEX BUFFER FROM GRIB FILE -C GETGB1S SEARCH INDEX RECORDS -C GETGB1R READ AND UNPACK GRIB RECORD -C LENGDS RETURN THE LENGTH OF A GRID -C -C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER JPDS(200),JGDS(200) - INTEGER KPDS(200),KGDS(200) - CHARACTER CBUF(MBUF) - LOGICAL*1 LB(JF) - REAL F(JF) - PARAMETER(MSK1=32000,MSK2=4000) - INTEGER JENS(200),KENS(200) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SEARCH PREVIOUS INDEX BUFFER IF POSSIBLE - JENS=-1 - IF(J.GE.0) THEN - IF(MNUM.GE.0) THEN - IRGI=0 - ELSE - MNUM=-1-MNUM - IRGI=1 - ENDIF - JR=J-MNUM - IF(JR.GE.0.AND.(JR.LT.NNUM.OR.IRGI.EQ.0)) THEN - CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, - & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) - IF(IRGS.EQ.0) K=KR+MNUM - IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM - IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM - ELSE - MNUM=J - IRGI=1 - IRGS=1 - ENDIF - ELSE - MNUM=-1-J - IRGI=1 - IRGS=1 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ AND SEARCH NEXT INDEX BUFFER - JR=0 - DOWHILE(IRGI.EQ.1.AND.IRGS.EQ.1) - IF(LUGI.GT.0) THEN - CALL GETGI(LUGI,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) - ELSE - CALL GETGIR(LUGB,MSK1,MSK2,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) - ENDIF - IF(IRGI.LE.1) THEN - CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, - & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) - IF(IRGS.EQ.0) K=KR+MNUM - IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM - IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ AND UNPACK GRIB RECORD - IF(IRGI.GT.1) THEN - IRET=96 - ELSEIF(IRGS.NE.0) THEN - IRET=99 - ELSEIF(LENGDS(KGDS).GT.JF) THEN - IRET=98 - ELSE - CALL GETGB1R(LUGB,LSKIP,LGRIB,KF,KPDS,KGDS,KENS,LB,F,NBITSS - + ,IRET) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/getgbmh.f b/src/fim/FIMsrc/w3/getgbmh.f deleted file mode 100644 index 6d7f78e..0000000 --- a/src/fim/FIMsrc/w3/getgbmh.f +++ /dev/null @@ -1,258 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGBMH(LUGB,LUGI,J,JPDS,JGDS, - & MBUF,CBUF,NLEN,NNUM,MNUM, - & KG,KF,K,KPDS,KGDS,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGBMH FINDS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND A GRIB MESSAGE. -C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) -C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. -C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN ITS MESSAGE NUMBER IS -C RETURNED ALONG WITH THE UNPACKED PDS AND GDS PARAMETERS. IF THE -C GRIB MESSAGE IS NOT FOUND, THEN THE RETURN CODE WILL BE NONZERO. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS -C AND ALLOWED FOR UNSPECIFIED INDEX FILE -C -C USAGE: CALL GETGBMH(LUGB,LUGI,J,JPDS,JGDS, -C & MBUF,CBUF,NLEN,NNUM,MNUM, -C & KG,KF,K,KPDS,KGDS,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C (ONLY USED IF LUGI=0) -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C MBUF INTEGER LENGTH OF INDEX BUFFER IN BYTES -C CBUF CHARACTER*1 (MBUF) INDEX BUFFER -C (INITIALIZE BY SETTING J=-1) -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C (INITIALIZE BY SETTING J=-1) -C NNUM INTEGER NUMBER OF INDEX RECORDS -C (INITIALIZE BY SETTING J=-1) -C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED -C (INITIALIZE BY SETTING J=-1) -C OUTPUT ARGUMENTS: -C CBUF CHARACTER*1 (MBUF) INDEX BUFFER -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C NNUM INTEGER NUMBER OF INDEX RECORDS -C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED -C KG INTEGER NUMBER OF BYTES IN THE GRIB MESSAGE -C KF INTEGER NUMBER OF DATA POINTS IN THE MESSAGE -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 99 REQUEST NOT FOUND -C -C SUBPROGRAMS CALLED: -C GETGI READ INDEX FILE -C GETGIR READ INDEX BUFFER FROM GRIB FILE -C GETGB1S SEARCH INDEX RECORDS -C LENGDS RETURN THE LENGTH OF A GRID -C -C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER JPDS(200),JGDS(200) - INTEGER KPDS(200),KGDS(200) - CHARACTER CBUF(MBUF) - PARAMETER(MSK1=32000,MSK2=4000) - INTEGER JENS(200),KENS(200) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SEARCH PREVIOUS INDEX BUFFER IF POSSIBLE - JENS=-1 - IF(J.GE.0) THEN - IF(MNUM.GE.0) THEN - IRGI=0 - ELSE - MNUM=-1-MNUM - IRGI=1 - ENDIF - JR=J-MNUM - IF(JR.GE.0.AND.(JR.LT.NNUM.OR.IRGI.EQ.0)) THEN - CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, - & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) - IF(IRGS.EQ.0) K=KR+MNUM - IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM - IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM - ELSE - MNUM=J - IRGI=1 - IRGS=1 - ENDIF - ELSE - MNUM=-1-J - IRGI=1 - IRGS=1 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ AND SEARCH NEXT INDEX BUFFER - JR=0 - DOWHILE(IRGI.EQ.1.AND.IRGS.EQ.1) - IF(LUGI.GT.0) THEN - CALL GETGI(LUGI,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) - ELSE - CALL GETGIR(LUGB,MSK1,MSK2,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) - ENDIF - IF(IRGI.LE.1) THEN - CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, - & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) - IF(IRGS.EQ.0) K=KR+MNUM - IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM - IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ GRIB RECORD - IF(IRGI.GT.1) THEN - IRET=96 - ELSEIF(IRGS.NE.0) THEN - IRET=99 - ELSE - KG=LGRIB - KF=LENGDS(KGDS) - IRET=0 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/getgbmp.f b/src/fim/FIMsrc/w3/getgbmp.f deleted file mode 100644 index ca6e1ef..0000000 --- a/src/fim/FIMsrc/w3/getgbmp.f +++ /dev/null @@ -1,264 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGBMP(LUGB,LUGI,JG,J,JPDS,JGDS, - & MBUF,CBUF,NLEN,NNUM,MNUM, - & KG,K,KPDS,KGDS,G,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGBMP FINDS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND A GRIB MESSAGE. -C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) -C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. -C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE -C GRIB FILE. ITS MESSAGE NUMBER IS RETURNED ALONG WITH THE UNPACKED -C PDS AND GDS PARAMETERS AND THE PACKED GRIB MESSAGE. IF THE GRIB -C MESSAGE IS NOT FOUND, THEN THE RETURN CODE WILL BE NONZERO. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS -C AND ALLOWED FOR UNSPECIFIED INDEX FILE -C -C USAGE: CALL GETGBMP(LUGB,LUGI,JG,J,JPDS,JGDS, -C & MBUF,CBUF,NLEN,NNUM,MNUM, -C & KG,K,KPDS,KGDS,G,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) -C JG INTEGER MAXIMUM NUMBER OF BYTES IN THE GRIB MESSAGE -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C MBUF INTEGER LENGTH OF INDEX BUFFER IN BYTES -C CBUF CHARACTER*1 (MBUF) INDEX BUFFER -C (INITIALIZE BY SETTING J=-1) -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C (INITIALIZE BY SETTING J=-1) -C NNUM INTEGER NUMBER OF INDEX RECORDS -C (INITIALIZE BY SETTING J=-1) -C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED -C (INITIALIZE BY SETTING J=-1) -C OUTPUT ARGUMENTS: -C CBUF CHARACTER*1 (MBUF) INDEX BUFFER -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C NNUM INTEGER NUMBER OF INDEX RECORDS -C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED -C KG INTEGER NUMBER OF BYTES IN THE GRIB MESSAGE -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C G CHARACTER*1 (KG) GRIB MESSAGE -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 97 ERROR READING GRIB FILE -C 98 NUMBER OF BYTES GREATER THAN JG -C 99 REQUEST NOT FOUND -C -C SUBPROGRAMS CALLED: -C GETGI READ INDEX FILE -C GETGIR READ INDEX BUFFER FROM GRIB FILE -C GETGB1S SEARCH INDEX RECORDS -C BAREAD READ GRIB RECORD -C -C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER JPDS(200),JGDS(200) - INTEGER KPDS(200),KGDS(200) - CHARACTER CBUF(MBUF) - CHARACTER G(JG) - PARAMETER(MSK1=32000,MSK2=4000) - INTEGER JENS(200),KENS(200) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SEARCH PREVIOUS INDEX BUFFER IF POSSIBLE - JENS=-1 - IF(J.GE.0) THEN - IF(MNUM.GE.0) THEN - IRGI=0 - ELSE - MNUM=-1-MNUM - IRGI=1 - ENDIF - JR=J-MNUM - IF(JR.GE.0.AND.(JR.LT.NNUM.OR.IRGI.EQ.0)) THEN - CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, - & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) - IF(IRGS.EQ.0) K=KR+MNUM - IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM - IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM - ELSE - MNUM=J - IRGI=1 - IRGS=1 - ENDIF - ELSE - MNUM=-1-J - IRGI=1 - IRGS=1 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ AND SEARCH NEXT INDEX BUFFER - JR=0 - DOWHILE(IRGI.EQ.1.AND.IRGS.EQ.1) - IF(LUGI.GT.0) THEN - CALL GETGI(LUGI,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) - ELSE - CALL GETGIR(LUGB,MSK1,MSK2,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) - ENDIF - IF(IRGI.LE.1) THEN - CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, - & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) - IF(IRGS.EQ.0) K=KR+MNUM - IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM - IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ GRIB RECORD - IF(IRGI.GT.1) THEN - IRET=96 - ELSEIF(IRGS.NE.0) THEN - IRET=99 - ELSEIF(LGRIB.GT.JG) THEN - IRET=98 - ELSE - IRET=97 - CALL BAREAD(LUGB,LSKIP,LGRIB,KG,G) - IF(KG.EQ.LGRIB) IRET=0 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/getgbp.f b/src/fim/FIMsrc/w3/getgbp.f deleted file mode 100644 index fdfd486..0000000 --- a/src/fim/FIMsrc/w3/getgbp.f +++ /dev/null @@ -1,209 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGBP(LUGB,LUGI,JG,J,JPDS,JGDS, - & KG,K,KPDS,KGDS,G,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGBP FINDS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND A GRIB MESSAGE. -C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) -C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. -C (THE INDEX BUFFER IS SAVED FOR USE BY FUTURE PROSPECTIVE CALLS.) -C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE -C GRIB FILE. ITS MESSAGE NUMBER IS RETURNED ALONG WITH THE UNPACKED -C PDS AND GDS PARAMETERS AND THE PACKED GRIB MESSAGE. IF THE GRIB -C MESSAGE IS NOT FOUND, THEN THE RETURN CODE WILL BE NONZERO. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS -C AND ALLOWED FOR UNSPECIFIED INDEX FILE -C -C USAGE: CALL GETGBP(LUGB,LUGI,JG,J,JPDS,JGDS, -C & KG,K,KPDS,KGDS,G,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) -C JG INTEGER MAXIMUM NUMBER OF BYTES IN THE GRIB MESSAGE -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C OUTPUT ARGUMENTS: -C KG INTEGER NUMBER OF BYTES IN THE GRIB MESSAGE -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C G CHARACTER*1 (KG) GRIB MESSAGE -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 97 ERROR READING GRIB FILE -C 98 NUMBER OF BYTES GREATER THAN JG -C 99 REQUEST NOT FOUND -C -C SUBPROGRAMS CALLED: -C GETGBMP FIND GRIB MESSAGE -C -C REMARKS: IN ORDER TO UNPACK GRIB FROM A MULTIPROCESSING ENVIRONMENT -C WHERE EACH PROCESSOR IS ATTEMPTING TO READ FROM ITS OWN PAIR OF -C LOGICAL UNITS, ONE MUST DIRECTLY CALL SUBPROGRAM GETGBMP AS BELOW, -C ALLOCATING A PRIVATE COPY OF CBUF, NLEN AND NNUM TO EACH PROCESSOR. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER JPDS(200),JGDS(200),KPDS(200),KGDS(200) - CHARACTER G(JG) - PARAMETER(MBUF=256*1024) - CHARACTER CBUF(MBUF) - SAVE CBUF,NLEN,NNUM,MNUM - DATA LUX/0/ -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED - IF(LUGI.GT.0.AND.(J.LT.0.OR.LUGI.NE.LUX)) THEN - LUX=LUGI - JJ=MIN(J,-1-J) - ELSEIF(LUGI.LE.0.AND.(J.LT.0.OR.LUGB.NE.LUX)) THEN - LUX=LUGB - JJ=MIN(J,-1-J) - ELSE - JJ=J - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C FIND AND UNPACK GRIB MESSAGE - CALL GETGBMP(LUGB,LUGI,JG,JJ,JPDS,JGDS, - & MBUF,CBUF,NLEN,NNUM,MNUM, - & KG,K,KPDS,KGDS,G,IRET) - IF(IRET.EQ.96) LUX=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/getgi.f b/src/fim/FIMsrc/w3/getgi.f deleted file mode 100644 index 0c47dd7..0000000 --- a/src/fim/FIMsrc/w3/getgi.f +++ /dev/null @@ -1,88 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGI(LUGI,MNUM,MBUF,CBUF,NLEN,NNUM,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGI READS A GRIB INDEX FILE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 95-10-31 -C -C ABSTRACT: READ A GRIB INDEX FILE AND RETURN ITS CONTENTS. -C VERSION 1 OF THE INDEX FILE HAS THE FOLLOWING FORMAT: -C 81-BYTE S.LORD HEADER WITH 'GB1IX1' IN COLUMNS 42-47 FOLLOWED BY -C 81-BYTE HEADER WITH NUMBER OF BYTES TO SKIP BEFORE INDEX RECORDS, -C NUMBER OF BYTES IN EACH INDEX RECORD, NUMBER OF INDEX RECORDS, -C AND GRIB FILE BASENAME WRITTEN IN FORMAT ('IX1FORM:',3I10,2X,A40). -C EACH FOLLOWING INDEX RECORD CORRESPONDS TO A GRIB MESSAGE -C AND HAS THE INTERNAL FORMAT: -C BYTE 001-004: BYTES TO SKIP IN DATA FILE BEFORE GRIB MESSAGE -C BYTE 005-008: BYTES TO SKIP IN MESSAGE BEFORE PDS -C BYTE 009-012: BYTES TO SKIP IN MESSAGE BEFORE GDS (0 IF NO GDS) -C BYTE 013-016: BYTES TO SKIP IN MESSAGE BEFORE BMS (0 IF NO BMS) -C BYTE 017-020: BYTES TO SKIP IN MESSAGE BEFORE BDS -C BYTE 021-024: BYTES TOTAL IN THE MESSAGE -C BYTE 025-025: GRIB VERSION NUMBER -C BYTE 026-053: PRODUCT DEFINITION SECTION (PDS) -C BYTE 054-095: GRID DEFINITION SECTION (GDS) (OR NULLS) -C BYTE 096-101: FIRST PART OF THE BIT MAP SECTION (BMS) (OR NULLS) -C BYTE 102-112: FIRST PART OF THE BINARY DATA SECTION (BDS) -C BYTE 113-172: (OPTIONAL) BYTES 41-100 OF THE PDS -C BYTE 173-184: (OPTIONAL) BYTES 29-40 OF THE PDS -C BYTE 185-320: (OPTIONAL) BYTES 43-178 OF THE GDS -C -C PROGRAM HISTORY LOG: -C 95-10-31 IREDELL -C 96-10-31 IREDELL AUGMENTED OPTIONAL DEFINITIONS TO BYTE 320 -C -C USAGE: CALL GETGI(LUGI,MNUM,MBUF,CBUF,NLEN,NNUM,IRET) -C INPUT ARGUMENTS: -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C MNUM INTEGER NUMBER OF INDEX RECORDS TO SKIP (USUALLY 0) -C MBUF INTEGER LENGTH OF CBUF IN BYTES -C OUTPUT ARGUMENTS: -C CBUF CHARACTER*1 (MBUF) BUFFER TO RECEIVE INDEX DATA -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C NNUM INTEGER NUMBER OF INDEX RECORDS -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 1 CBUF TOO SMALL TO HOLD INDEX BUFFER -C 2 ERROR READING INDEX FILE BUFFER -C 3 ERROR READING INDEX FILE HEADER -C -C SUBPROGRAMS CALLED: -C BAREAD BYTE-ADDRESSABLE READ -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - CHARACTER CBUF(MBUF) - CHARACTER CHEAD*162 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - NLEN=0 - NNUM=0 - IRET=3 - CALL BAREAD(LUGI,0,162,LHEAD,CHEAD) - IF(LHEAD.EQ.162.AND.CHEAD(42:47).EQ.'GB1IX1') THEN - READ(CHEAD(82:162),'(8X,3I10,2X,A40)',IOSTAT=IOS) NSKP,NLEN,NNUM - IF(IOS.EQ.0) THEN - NSKP=NSKP+MNUM*NLEN - NNUM=NNUM-MNUM - NBUF=NNUM*NLEN - IRET=0 - IF(NBUF.GT.MBUF) THEN - NNUM=MBUF/NLEN - NBUF=NNUM*NLEN - IRET=1 - ENDIF - IF(NBUF.GT.0) THEN - CALL BAREAD(LUGI,NSKP,NBUF,LBUF,CBUF) - IF(LBUF.NE.NBUF) IRET=2 - ENDIF - ENDIF - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/getgir.f b/src/fim/FIMsrc/w3/getgir.f deleted file mode 100644 index e23871c..0000000 --- a/src/fim/FIMsrc/w3/getgir.f +++ /dev/null @@ -1,90 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGIR(LUGB,MSK1,MSK2,MNUM,MBUF,CBUF,NLEN,NNUM,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGIR READS A GRIB INDEX FILE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 95-10-31 -C -C ABSTRACT: READ A GRIB FILE AND RETURN ITS INDEX CONTENTS. -C THE INDEX BUFFER RETURNED CONTAINS INDEX RECORDS WITH THE INTERNAL FORMAT: -C BYTE 001-004: BYTES TO SKIP IN DATA FILE BEFORE GRIB MESSAGE -C BYTE 005-008: BYTES TO SKIP IN MESSAGE BEFORE PDS -C BYTE 009-012: BYTES TO SKIP IN MESSAGE BEFORE GDS (0 IF NO GDS) -C BYTE 013-016: BYTES TO SKIP IN MESSAGE BEFORE BMS (0 IF NO BMS) -C BYTE 017-020: BYTES TO SKIP IN MESSAGE BEFORE BDS -C BYTE 021-024: BYTES TOTAL IN THE MESSAGE -C BYTE 025-025: GRIB VERSION NUMBER -C BYTE 026-053: PRODUCT DEFINITION SECTION (PDS) -C BYTE 054-095: GRID DEFINITION SECTION (GDS) (OR NULLS) -C BYTE 096-101: FIRST PART OF THE BIT MAP SECTION (BMS) (OR NULLS) -C BYTE 102-112: FIRST PART OF THE BINARY DATA SECTION (BDS) -C BYTE 113-172: (OPTIONAL) BYTES 41-100 OF THE PDS -C BYTE 173-184: (OPTIONAL) BYTES 29-40 OF THE PDS -C BYTE 185-320: (OPTIONAL) BYTES 43-178 OF THE GDS -C -C PROGRAM HISTORY LOG: -C 95-10-31 IREDELL -C 96-10-31 IREDELL AUGMENTED OPTIONAL DEFINITIONS TO BYTE 320 -C -C USAGE: CALL GETGIR(LUGB,MSK1,MSK2,MNUM,MBUF,CBUF,NLEN,NNUM,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB FILE -C MSK1 INTEGER NUMBER OF BYTES TO SEARCH FOR FIRST MESSAGE -C MSK2 INTEGER NUMBER OF BYTES TO SEARCH FOR OTHER MESSAGES -C MNUM INTEGER NUMBER OF INDEX RECORDS TO SKIP (USUALLY 0) -C MBUF INTEGER LENGTH OF CBUF IN BYTES -C OUTPUT ARGUMENTS: -C CBUF CHARACTER*1 (MBUF) BUFFER TO RECEIVE INDEX DATA -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C NNUM INTEGER NUMBER OF INDEX RECORDS -C (=0 IF NO GRIB MESSAGES ARE FOUND) -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 1 CBUF TOO SMALL TO HOLD INDEX DATA -C -C SUBPROGRAMS CALLED: -C SKGB SEEK NEXT GRIB MESSAGE -C IXGB MAKE INDEX RECORD -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - CHARACTER CBUF(MBUF) - PARAMETER(MINDEX=320) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SEARCH FOR FIRST GRIB MESSAGE - ISEEK=0 - CALL SKGB(LUGB,ISEEK,MSK1,LSKIP,LGRIB) - IF(LGRIB.GT.0.AND.MINDEX.LE.MBUF) THEN - CALL IXGB(LUGB,LSKIP,LGRIB,MINDEX,1,NLEN,CBUF) - ELSE - NLEN=MINDEX - ENDIF - DO M=1,MNUM - IF(LGRIB.GT.0) THEN - ISEEK=LSKIP+LGRIB - CALL SKGB(LUGB,ISEEK,MSK2,LSKIP,LGRIB) - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C MAKE AN INDEX RECORD FOR EVERY GRIB RECORD FOUND - NNUM=0 - IRET=0 - DOWHILE(IRET.EQ.0.AND.LGRIB.GT.0) - IF(NLEN*(NNUM+1).LE.MBUF) THEN - NNUM=NNUM+1 - CALL IXGB(LUGB,LSKIP,LGRIB,NLEN,NNUM,MLEN,CBUF) - ISEEK=LSKIP+LGRIB - CALL SKGB(LUGB,ISEEK,MSK2,LSKIP,LGRIB) - ELSE - IRET=1 - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/gtbits.f b/src/fim/FIMsrc/w3/gtbits.f deleted file mode 100644 index 8c46e9f..0000000 --- a/src/fim/FIMsrc/w3/gtbits.f +++ /dev/null @@ -1,83 +0,0 @@ - SUBROUTINE GTBITS(IBM,IDS,LEN,MG,G,GROUND,GMIN,GMAX,NBIT) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GTBITS COMPUTE NUMBER OF BITS AND ROUND FIELD. -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: THE NUMBER OF BITS REQUIRED TO PACK A GIVEN FIELD -C AT A PARTICULAR DECIMAL SCALING IS COMPUTED USING THE FIELD RANGE. -C THE FIELD IS ROUNDED OFF TO THE DECIMAL SCALING FOR PACKING. -C THE MINIMUM AND MAXIMUM ROUNDED FIELD VALUES ARE ALSO RETURNED. -C GRIB BITMAP MASKING FOR VALID DATA IS OPTIONALLY USED. -C -C PROGRAM HISTORY LOG: -C 92-10-31 IREDELL -C -C USAGE: CALL GTBITS(IBM,IDS,LEN,MG,G,GMIN,GMAX,NBIT) -C INPUT ARGUMENT LIST: -C IBM - INTEGER BITMAP FLAG (=0 FOR NO BITMAP) -C IDS - INTEGER DECIMAL SCALING -C (E.G. IDS=3 TO ROUND FIELD TO NEAREST MILLI-VALUE) -C LEN - INTEGER LENGTH OF THE FIELD AND BITMAP -C MG - INTEGER (LEN) BITMAP IF IBM=1 (0 TO SKIP, 1 TO KEEP) -C G - REAL (LEN) FIELD -C -C OUTPUT ARGUMENT LIST: -C GROUND - REAL (LEN) FIELD ROUNDED TO DECIMAL SCALING -C (SET TO ZERO WHERE BITMAP IS 0 IF IBM=1) -C GMIN - REAL MINIMUM VALID ROUNDED FIELD VALUE -C GMAX - REAL MAXIMUM VALID ROUNDED FIELD VALUE -C NBIT - INTEGER NUMBER OF BITS TO PACK -C -C SUBPROGRAMS CALLED: -C ISRCHNE - FIND FIRST VALUE IN AN ARRAY NOT EQUAL TO TARGET VALUE -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - DIMENSION MG(LEN),G(LEN),GROUND(LEN) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C ROUND FIELD AND DETERMINE EXTREMES WHERE BITMAP IS ON - DS=10.**IDS - IF(IBM.EQ.0) THEN - GROUND(1)=NINT(G(1)*DS)/DS - GMAX=GROUND(1) - GMIN=GROUND(1) - DO I=2,LEN - GROUND(I)=NINT(G(I)*DS)/DS - GMAX=MAX(GMAX,GROUND(I)) - GMIN=MIN(GMIN,GROUND(I)) - ENDDO - ELSE - I1=ISRCHNE(LEN,MG,1,0) - IF(I1.GT.0.AND.I1.LE.LEN) THEN - DO I=1,I1-1 - GROUND(I)=0. - ENDDO - GROUND(I1)=NINT(G(I1)*DS)/DS - GMAX=GROUND(I1) - GMIN=GROUND(I1) - DO I=I1+1,LEN - IF(MG(I).NE.0) THEN - GROUND(I)=NINT(G(I)*DS)/DS - GMAX=MAX(GMAX,GROUND(I)) - GMIN=MIN(GMIN,GROUND(I)) - ELSE - GROUND(I)=0. - ENDIF - ENDDO - ELSE - DO I=1,LEN - GROUND(I)=0. - ENDDO - GMAX=0. - GMIN=0. - ENDIF - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COMPUTE NUMBER OF BITS - NBIT=LOG((GMAX-GMIN)*DS+0.9)/LOG(2.)+1. -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/hostname.f b/src/fim/FIMsrc/w3/hostname.f deleted file mode 100644 index cc6c4cd..0000000 --- a/src/fim/FIMsrc/w3/hostname.f +++ /dev/null @@ -1,32 +0,0 @@ - CHARACTER(15) FUNCTION HOSTNAME() -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: HOSTNAME RETURN CURRENT HOSTNAME -C PRGMMR: IREDELL ORG: NP23 DATE:1998-06-04 -C -C ABSTRACT: RETURN A 15-CHARACTER NAME OF THE CURRENT COMPUTER NODE. -C -C PROGRAM HISTORY LOG: -C 1998-06-04 IREDELL -C 2003-08-15 Gilbert - XLF 8.1 doesn't like calling gethostname() -C with a constant argument. Put size of hostname -C in a variable and passed that to gethostname(). -C -C USAGE: ...=HOSTNAME() -C INPUT ARGUMENT LIST: -C -C OUTPUT ARGUMENT LIST: -C HOSTNAME - CHARACTER(15) HOSTNAME -C -C SUBPROGRAMS CALLED: -C GETHOSTNAME GET NAME OF CURRENT HOST -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: ORIGIN -C -C$$$ - integer :: nsize=15 - HOSTNAME=' ' - CALL GETHOSTNAME(HOSTNAME,nsize) - END diff --git a/src/fim/FIMsrc/w3/idsdef.f b/src/fim/FIMsrc/w3/idsdef.f deleted file mode 100644 index ca8862c..0000000 --- a/src/fim/FIMsrc/w3/idsdef.f +++ /dev/null @@ -1,285 +0,0 @@ - SUBROUTINE IDSDEF(IPTV,IDS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: IDSDEF SETS DEFAULT DECIMAL SCALINGS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: SETS DECIMAL SCALINGS DEFAULTS FOR VARIOUS PARAMETERS. -C A DECIMAL SCALING OF -3 MEANS DATA IS PACKED IN KILO-SI UNITS. -C -C PROGRAM HISTORY LOG: -C 92-10-31 IREDELL -C -C USAGE: CALL IDSDEF(IPTV,IDS) -C INPUT ARGUMENTS: -C IPTV PARAMTER TABLE VERSION (ONLY 1 OR 2 IS RECOGNIZED) -C OUTPUT ARGUMENTS: -C IDS INTEGER (255) DECIMAL SCALINGS -C (UNKNOWN DECIMAL SCALINGS WILL NOT BE SET) -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - DIMENSION IDS(255) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(IPTV.EQ.1.OR.IPTV.EQ.2) THEN - IDS(001)=-1 ! PRESSURE (PA) - IDS(002)=-1 ! SEA-LEVEL PRESSURE (PA) - IDS(003)=3 ! PRESSURE TENDENCY (PA/S) - ! - ! - IDS(006)=-1 ! GEOPOTENTIAL (M2/S2) - IDS(007)=0 ! GEOPOTENTIAL HEIGHT (M) - IDS(008)=0 ! GEOMETRIC HEIGHT (M) - IDS(009)=0 ! STANDARD DEVIATION OF HEIGHT (M) - ! - IDS(011)=1 ! TEMPERATURE (K) - IDS(012)=1 ! VIRTUAL TEMPERATURE (K) - IDS(013)=1 ! POTENTIAL TEMPERATURE (K) - IDS(014)=1 ! PSEUDO-ADIABATIC POTENTIAL TEMPERATURE (K) - IDS(015)=1 ! MAXIMUM TEMPERATURE (K) - IDS(016)=1 ! MINIMUM TEMPERATURE (K) - IDS(017)=1 ! DEWPOINT TEMPERATURE (K) - IDS(018)=1 ! DEWPOINT DEPRESSION (K) - IDS(019)=4 ! TEMPERATURE LAPSE RATE (K/M) - IDS(020)=0 ! VISIBILITY (M) - ! RADAR SPECTRA 1 () - ! RADAR SPECTRA 2 () - ! RADAR SPECTRA 3 () - ! - IDS(025)=1 ! TEMPERATURE ANOMALY (K) - IDS(026)=-1 ! PRESSURE ANOMALY (PA) - IDS(027)=0 ! GEOPOTENTIAL HEIGHT ANOMALY (M) - ! WAVE SPECTRA 1 () - ! WAVE SPECTRA 2 () - ! WAVE SPECTRA 3 () - IDS(031)=0 ! WIND DIRECTION (DEGREES) - IDS(032)=1 ! WIND SPEED (M/S) - IDS(033)=1 ! ZONAL WIND (M/S) - IDS(034)=1 ! MERIDIONAL WIND (M/S) - IDS(035)=-4 ! STREAMFUNCTION (M2/S) - IDS(036)=-4 ! VELOCITY POTENTIAL (M2/S) - IDS(037)=-1 ! MONTGOMERY STREAM FUNCTION (M2/S2) - IDS(038)=8 ! SIGMA VERTICAL VELOCITY (1/S) - IDS(039)=3 ! PRESSURE VERTICAL VELOCITY (PA/S) - IDS(040)=4 ! GEOMETRIC VERTICAL VELOCITY (M/S) - IDS(041)=6 ! ABSOLUTE VORTICITY (1/S) - IDS(042)=6 ! ABSOLUTE DIVERGENCE (1/S) - IDS(043)=6 ! RELATIVE VORTICITY (1/S) - IDS(044)=6 ! RELATIVE DIVERGENCE (1/S) - IDS(045)=4 ! VERTICAL U SHEAR (1/S) - IDS(046)=4 ! VERTICAL V SHEAR (1/S) - IDS(047)=0 ! DIRECTION OF CURRENT (DEGREES) - ! SPEED OF CURRENT (M/S) - ! U OF CURRENT (M/S) - ! V OF CURRENT (M/S) - IDS(051)=4 ! SPECIFIC HUMIDITY (KG/KG) - IDS(052)=0 ! RELATIVE HUMIDITY (PERCENT) - IDS(053)=4 ! HUMIDITY MIXING RATIO (KG/KG) - IDS(054)=1 ! PRECIPITABLE WATER (KG/M2) - IDS(055)=-1 ! VAPOR PRESSURE (PA) - IDS(056)=-1 ! SATURATION DEFICIT (PA) - IDS(057)=1 ! EVAPORATION (KG/M2) - IDS(058)=1 ! CLOUD ICE (KG/M2) - IDS(059)=6 ! PRECIPITATION RATE (KG/M2/S) - IDS(060)=0 ! THUNDERSTORM PROBABILITY (PERCENT) - IDS(061)=1 ! TOTAL PRECIPITATION (KG/M2) - IDS(062)=1 ! LARGE-SCALE PRECIPITATION (KG/M2) - IDS(063)=1 ! CONVECTIVE PRECIPITATION (KG/M2) - IDS(064)=6 ! WATER EQUIVALENT SNOWFALL RATE (KG/M2/S) - IDS(065)=0 ! WATER EQUIVALENT OF SNOW DEPTH (KG/M2) - IDS(066)=2 ! SNOW DEPTH (M) - ! MIXED-LAYER DEPTH (M) - ! TRANSIENT THERMOCLINE DEPTH (M) - ! MAIN THERMOCLINE DEPTH (M) - ! MAIN THERMOCLINE ANOMALY (M) - IDS(071)=0 ! TOTAL CLOUD COVER (PERCENT) - IDS(072)=0 ! CONVECTIVE CLOUD COVER (PERCENT) - IDS(073)=0 ! LOW CLOUD COVER (PERCENT) - IDS(074)=0 ! MIDDLE CLOUD COVER (PERCENT) - IDS(075)=0 ! HIGH CLOUD COVER (PERCENT) - IDS(076)=1 ! CLOUD WATER (KG/M2) - ! - IDS(078)=1 ! CONVECTIVE SNOW (KG/M2) - IDS(079)=1 ! LARGE SCALE SNOW (KG/M2) - IDS(080)=1 ! WATER TEMPERATURE (K) - IDS(081)=0 ! SEA-LAND MASK () - ! DEVIATION OF SEA LEVEL FROM MEAN (M) - IDS(083)=5 ! ROUGHNESS (M) - IDS(084)=1 ! ALBEDO (PERCENT) - IDS(085)=1 ! SOIL TEMPERATURE (K) - IDS(086)=0 ! SOIL WETNESS (KG/M2) - IDS(087)=0 ! VEGETATION (PERCENT) - ! SALINITY (KG/KG) - IDS(089)=4 ! DENSITY (KG/M3) - IDS(090)=1 ! RUNOFF (KG/M2) - IDS(091)=0 ! ICE CONCENTRATION () - ! ICE THICKNESS (M) - IDS(093)=0 ! DIRECTION OF ICE DRIFT (DEGREES) - ! SPEED OF ICE DRIFT (M/S) - ! U OF ICE DRIFT (M/S) - ! V OF ICE DRIFT (M/S) - ! ICE GROWTH (M) - ! ICE DIVERGENCE (1/S) - IDS(099)=1 ! SNOW MELT (KG/M2) - ! SIG HEIGHT OF WAVES AND SWELL (M) - IDS(101)=0 ! DIRECTION OF WIND WAVES (DEGREES) - ! SIG HEIGHT OF WIND WAVES (M) - ! MEAN PERIOD OF WIND WAVES (S) - IDS(104)=0 ! DIRECTION OF SWELL WAVES (DEGREES) - ! SIG HEIGHT OF SWELL WAVES (M) - ! MEAN PERIOD OF SWELL WAVES (S) - IDS(107)=0 ! PRIMARY WAVE DIRECTION (DEGREES) - ! PRIMARY WAVE MEAN PERIOD (S) - IDS(109)=0 ! SECONDARY WAVE DIRECTION (DEGREES) - ! SECONDARY WAVE MEAN PERIOD (S) - IDS(111)=0 ! NET SOLAR RADIATIVE FLUX AT SURFACE (W/M2) - IDS(112)=0 ! NET LONGWAVE RADIATIVE FLUX AT SURFACE (W/M2) - IDS(113)=0 ! NET SOLAR RADIATIVE FLUX AT TOP (W/M2) - IDS(114)=0 ! NET LONGWAVE RADIATIVE FLUX AT TOP (W/M2) - IDS(115)=0 ! NET LONGWAVE RADIATIVE FLUX (W/M2) - IDS(116)=0 ! NET SOLAR RADIATIVE FLUX (W/M2) - IDS(117)=0 ! TOTAL RADIATIVE FLUX (W/M2) - ! - ! - ! - IDS(121)=0 ! LATENT HEAT FLUX (W/M2) - IDS(122)=0 ! SENSIBLE HEAT FLUX (W/M2) - IDS(123)=0 ! BOUNDARY LAYER DISSIPATION (W/M2) - IDS(124)=3 ! U WIND STRESS (N/M2) - IDS(125)=3 ! V WIND STRESS (N/M2) - ! WIND MIXING ENERGY (J) - ! IMAGE DATA () - IDS(128)=-1 ! MEAN SEA-LEVEL PRESSURE (STDATM) (PA) - IDS(129)=-1 ! MEAN SEA-LEVEL PRESSURE (MAPS) (PA) - IDS(130)=-1 ! MEAN SEA-LEVEL PRESSURE (ETA) (PA) - IDS(131)=1 ! SURFACE LIFTED INDEX (K) - IDS(132)=1 ! BEST LIFTED INDEX (K) - IDS(133)=1 ! K INDEX (K) - IDS(134)=1 ! SWEAT INDEX (K) - IDS(135)=10 ! HORIZONTAL MOISTURE DIVERGENCE (KG/KG/S) - IDS(136)=4 ! SPEED SHEAR (1/S) - IDS(137)=3 ! 3-HR PRESSURE TENDENCY (PA/S) - IDS(138)=6 ! BRUNT-VAISALA FREQUENCY SQUARED (1/S2) - IDS(139)=11 ! POTENTIAL VORTICITY (MASS-WEIGHTED) (1/S/M) - IDS(140)=0 ! RAIN MASK () - IDS(141)=0 ! FREEZING RAIN MASK () - IDS(142)=0 ! ICE PELLETS MASK () - IDS(143)=0 ! SNOW MASK () - IDS(144)=3 ! VOLUMETRIC SOIL MOISTURE CONTENT (FRACTION) - IDS(145)=0 ! POTENTIAL EVAPORATION RATE (W/M2) - IDS(146)=0 ! CLOUD WORKFUNCTION (J/KG) - IDS(147)=3 ! U GRAVITY WAVE STRESS (N/M2) - IDS(148)=3 ! V GRAVITY WAVE STRESS (N/M2) - IDS(149)=10 ! POTENTIAL VORTICITY (M2/S/KG) - ! COVARIANCE BETWEEN V AND U (M2/S2) - ! COVARIANCE BETWEEN U AND T (K*M/S) - ! COVARIANCE BETWEEN V AND T (K*M/S) - ! - ! - IDS(155)=0 ! GROUND HEAT FLUX (W/M2) - IDS(156)=0 ! CONVECTIVE INHIBITION (W/M2) - IDS(157)=0 ! CONVECTIVE APE (J/KG) - IDS(158)=0 ! TURBULENT KE (J/KG) - IDS(159)=-1 ! CONDENSATION PRESSURE OF LIFTED PARCEL (PA) - IDS(160)=0 ! CLEAR SKY UPWARD SOLAR FLUX (W/M2) - IDS(161)=0 ! CLEAR SKY DOWNWARD SOLAR FLUX (W/M2) - IDS(162)=0 ! CLEAR SKY UPWARD LONGWAVE FLUX (W/M2) - IDS(163)=0 ! CLEAR SKY DOWNWARD LONGWAVE FLUX (W/M2) - IDS(164)=0 ! CLOUD FORCING NET SOLAR FLUX (W/M2) - IDS(165)=0 ! CLOUD FORCING NET LONGWAVE FLUX (W/M2) - IDS(166)=0 ! VISIBLE BEAM DOWNWARD SOLAR FLUX (W/M2) - IDS(167)=0 ! VISIBLE DIFFUSE DOWNWARD SOLAR FLUX (W/M2) - IDS(168)=0 ! NEAR IR BEAM DOWNWARD SOLAR FLUX (W/M2) - IDS(169)=0 ! NEAR IR DIFFUSE DOWNWARD SOLAR FLUX (W/M2) - ! - ! - IDS(172)=3 ! MOMENTUM FLUX (N/M2) - IDS(173)=0 ! MASS POINT MODEL SURFACE () - IDS(174)=0 ! VELOCITY POINT MODEL SURFACE () - IDS(175)=0 ! SIGMA LAYER NUMBER () - IDS(176)=2 ! LATITUDE (DEGREES) - IDS(177)=2 ! EAST LONGITUDE (DEGREES) - ! - ! - ! - IDS(181)=9 ! X-GRADIENT LOG PRESSURE (1/M) - IDS(182)=9 ! Y-GRADIENT LOG PRESSURE (1/M) - IDS(183)=5 ! X-GRADIENT HEIGHT (M/M) - IDS(184)=5 ! Y-GRADIENT HEIGHT (M/M) - ! - ! - ! - ! - ! - ! - ! - ! - ! - ! - ! - ! - ! - ! - ! - ! - IDS(201)=0 ! ICE-FREE WATER SURCACE (PERCENT) - ! - ! - IDS(204)=0 ! DOWNWARD SOLAR RADIATIVE FLUX (W/M2) - IDS(205)=0 ! DOWNWARD LONGWAVE RADIATIVE FLUX (W/M2) - ! - IDS(207)=0 ! MOISTURE AVAILABILITY (PERCENT) - ! EXCHANGE COEFFICIENT (KG/M2/S) - IDS(209)=0 ! NUMBER OF MIXED LAYER NEXT TO SFC () - ! - IDS(211)=0 ! UPWARD SOLAR RADIATIVE FLUX (W/M2) - IDS(212)=0 ! UPWARD LONGWAVE RADIATIVE FLUX (W/M2) - IDS(213)=0 ! NON-CONVECTIVE CLOUD COVER (PERCENT) - IDS(214)=6 ! CONVECTIVE PRECIPITATION RATE (KG/M2/S) - IDS(215)=7 ! TOTAL DIABATIC HEATING RATE (K/S) - IDS(216)=7 ! TOTAL RADIATIVE HEATING RATE (K/S) - IDS(217)=7 ! TOTAL DIABATIC NONRADIATIVE HEATING RATE (K/S) - IDS(218)=2 ! PRECIPITATION INDEX (FRACTION) - IDS(219)=1 ! STD DEV OF IR T OVER 1X1 DEG AREA (K) - IDS(220)=4 ! NATURAL LOG OF SURFACE PRESSURE OVER 1 KPA () - ! - IDS(222)=0 ! 5-WAVE GEOPOTENTIAL HEIGHT (M) - IDS(223)=1 ! PLANT CANOPY SURFACE WATER (KG/M2) - ! - ! - ! BLACKADARS MIXING LENGTH (M) - ! ASYMPTOTIC MIXING LENGTH (M) - IDS(228)=1 ! POTENTIAL EVAPORATION (KG/M2) - IDS(229)=0 ! SNOW PHASE-CHANGE HEAT FLUX (W/M2) - ! - IDS(231)=3 ! CONVECTIVE CLOUD MASS FLUX (PA/S) - IDS(232)=0 ! DOWNWARD TOTAL RADIATION FLUX (W/M2) - IDS(233)=0 ! UPWARD TOTAL RADIATION FLUX (W/M2) - IDS(224)=1 ! BASEFLOW-GROUNDWATER RUNOFF (KG/M2) - IDS(225)=1 ! STORM SURFACE RUNOFF (KG/M2) - ! - ! - IDS(238)=0 ! SNOW COVER (PERCENT) - IDS(239)=1 ! SNOW TEMPERATURE (K) - ! - IDS(241)=7 ! LARGE SCALE CONDENSATION HEATING RATE (K/S) - IDS(242)=7 ! DEEP CONVECTIVE HEATING RATE (K/S) - IDS(243)=10 ! DEEP CONVECTIVE MOISTENING RATE (KG/KG/S) - IDS(244)=7 ! SHALLOW CONVECTIVE HEATING RATE (K/S) - IDS(245)=10 ! SHALLOW CONVECTIVE MOISTENING RATE (KG/KG/S) - IDS(246)=7 ! VERTICAL DIFFUSION HEATING RATE (KG/KG/S) - IDS(247)=7 ! VERTICAL DIFFUSION ZONAL ACCELERATION (M/S/S) - IDS(248)=7 ! VERTICAL DIFFUSION MERID ACCELERATION (M/S/S) - IDS(249)=10 ! VERTICAL DIFFUSION MOISTENING RATE (KG/KG/S) - IDS(250)=7 ! SOLAR RADIATIVE HEATING RATE (K/S) - IDS(251)=7 ! LONGWAVE RADIATIVE HEATING RATE (K/S) - ! DRAG COEFFICIENT () - ! FRICTION VELOCITY (M/S) - ! RICHARDSON NUMBER () - ! - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/instrument.f b/src/fim/FIMsrc/w3/instrument.f deleted file mode 100644 index b8e2ded..0000000 --- a/src/fim/FIMsrc/w3/instrument.f +++ /dev/null @@ -1,113 +0,0 @@ -!----------------------------------------------------------------------- - SUBROUTINE INSTRUMENT(K,KALL,TTOT,TMIN,TMAX) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . . -! SUBPROGRAM: INSTRUMENT MONITOR WALL-CLOCK TIMES, ETC. -! PRGMMR: IREDELL ORG: NP23 DATE:1998-07-16 -! -! ABSTRACT: THIS SUBPROGRAM IS USEFUL IN INSTRUMENTING A CODE -! BY MONITORING THE NUMBER OF TIMES EACH GIVEN SECTION -! OF A PROGRAM IS INVOKED AS WELL AS THE MINIMUM, MAXIMUM -! AND TOTAL WALL-CLOCK TIME SPENT IN THE GIVEN SECTION. -! -! PROGRAM HISTORY LOG: -! 1998-07-16 IREDELL -! -! USAGE: CALL INSTRUMENT(K,KALL,TTOT,TMIN,TMAX) -! INPUT ARGUMENT LIST: -! K - INTEGER POSITIVE SECTION NUMBER -! OR MAXIMUM SECTION NUMBER IN THE FIRST INVOCATION -! OR ZERO TO RESET ALL WALL-CLOCK STATISTICS -! OR NEGATIVE SECTION NUMBER TO SKIP MONITORING -! AND JUST RETURN STATISTICS. -! -! OUTPUT ARGUMENT LIST: -! KALL - INTEGER NUMBER OF TIMES SECTION IS CALLED -! TTOT - REAL TOTAL SECONDS SPENT IN SECTION -! TMIN - REAL MINIMUM SECONDS SPENT IN SECTION -! TMAX - REAL MAXIMUM SECONDS SPENT IN SECTION -! -! SUBPROGRAMS CALLED: -! W3UTCDAT RETURN THE UTC DATE AND TIME -! W3DIFDAT RETURN A TIME INTERVAL BETWEEN TWO DATES -! -! REMARKS: -! THIS SUBPROGRAM SHOULD NOT BE INVOKED FROM A MULTITASKING REGION. -! NORMALLY, TIME SPENT INSIDE THIS SUBPROGRAM IS NOT COUNTED. -! WALL-CLOCK TIMES ARE KEPT TO THE NEAREST MILLISECOND. -! -! EXAMPLE. -! CALL INSTRUMENT(2,KALL,TTOT,TMIN,TMAX) ! KEEP STATS FOR 2 SUBS -! DO K=1,N -! CALL SUB1 -! CALL INSTRUMENT(1,KALL,TTOT,TMIN,TMAX) ! ACCUM STATS FOR SUB1 -! CALL SUB2 -! CALL INSTRUMENT(2,KALL,TTOT,TMIN,TMAX) ! ACCUM STATS FOR SUB2 -! ENDDO -! PRINT *,'SUB2 STATS: ',KALL,TTOT,TMIN,TMAX -! CALL INSTRUMENT(-1,KALL,TTOT,TMIN,TMAX) ! RETURN STATS FOR SUB1 -! PRINT *,'SUB1 STATS: ',KALL,TTOT,TMIN,TMAX -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! -!$$$ - IMPLICIT NONE - INTEGER,INTENT(IN):: K - INTEGER,INTENT(OUT):: KALL - REAL,INTENT(OUT):: TTOT,TMIN,TMAX - INTEGER,SAVE:: KMAX=0 - INTEGER,DIMENSION(:),ALLOCATABLE,SAVE:: KALLS - REAL,DIMENSION(:),ALLOCATABLE,SAVE:: TTOTS,TMINS,TMAXS - INTEGER,DIMENSION(8),SAVE:: IDAT - INTEGER,DIMENSION(8):: JDAT - REAL,DIMENSION(5):: RINC - INTEGER:: KA -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - KA=ABS(K) -! ALLOCATE MONITORING ARRAYS IF INITIAL INVOCATION - IF(KMAX.EQ.0) THEN - KMAX=K - ALLOCATE(KALLS(KMAX)) - ALLOCATE(TTOTS(KMAX)) - ALLOCATE(TMINS(KMAX)) - ALLOCATE(TMAXS(KMAX)) - KALLS=0 - KA=0 -! OR RESET ALL STATISTICS BACK TO ZERO - ELSEIF(K.EQ.0) THEN - KALLS=0 -! OR COUNT TIME SINCE LAST INVOCATION AGAINST THIS SECTION - ELSEIF(K.GT.0) THEN - CALL W3UTCDAT(JDAT) - CALL W3DIFDAT(JDAT,IDAT,4,RINC) - KALLS(K)=KALLS(K)+1 - IF(KALLS(K).EQ.1) THEN - TTOTS(K)=RINC(4) - TMINS(K)=RINC(4) - TMAXS(K)=RINC(4) - ELSE - TTOTS(K)=TTOTS(K)+RINC(4) - TMINS(K)=MIN(TMINS(K),RINC(4)) - TMAXS(K)=MAX(TMAXS(K),RINC(4)) - ENDIF - ENDIF -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! RETURN STATISTICS -! JFM - rearranged to avoid out-of-bounds exit. - KALL=0 - TTOT=0 - TMIN=0 - TMAX=0 - IF(KA.GE.1.AND.KA.LE.KMAX) THEN - IF(KALLS(KA).GT.0) THEN - KALL=KALLS(KA) - TTOT=TTOTS(KA) - TMIN=TMINS(KA) - TMAX=TMAXS(KA) - ENDIF - ENDIF -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! KEEP CURRENT TIME FOR NEXT INVOCATION - IF(K.GE.0) CALL W3UTCDAT(IDAT) - END SUBROUTINE INSTRUMENT diff --git a/src/fim/FIMsrc/w3/isrchne.f b/src/fim/FIMsrc/w3/isrchne.f deleted file mode 100644 index 9237fac..0000000 --- a/src/fim/FIMsrc/w3/isrchne.f +++ /dev/null @@ -1,45 +0,0 @@ - FUNCTION ISRCHNE(N,X,INCX,TARGET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: ISRCHNE Searches vector given a target -C PRGMMR: gilbert ORG: W/NP11 DATE: 99-02-11 -C -C ABSTRACT: Searches a vector for the first element -C not equal to a target -C -C PROGRAM HISTORY LOG: -C 99-02-11 Gilbert -C -C USAGE: index=ISRCHNE(n, x, incx, target) -C INPUT ARGUMENT LIST: -C n - Number of elements to be searched -C x - Real or integer array of dimension (n-1) * |incx| + 1. -C Array x contains the vector to be searched. -C incx - Increment between elements of the searched array. -C target - Value for which to search in the array. -C -C OUTPUT VALUE -C index - Index of the first element equal or not equal to target. If -C target is not found, n+1 is returned. If n <= 0, 0 is -C returned. -C -C REMARKS: This code and documentation was taken directly from the -C man page for routine ISRCHNE on a CRAY UNICOS system. -C -C ATTRIBUTES: -C LANGUAGE: Fortran -C -C$$$ - INTEGER X(*), TARGET - J=1 - ISRCHNE=0 - IF(N.LE.0) RETURN - IF(INCX.LT.0) J=1-(N-1)*INCX - DO 100 I=1,N - IF(X(J).NE.TARGET) GO TO 200 - J=J+INCX - 100 CONTINUE - 200 ISRCHNE=I - RETURN - END - diff --git a/src/fim/FIMsrc/w3/iw3jdn.f b/src/fim/FIMsrc/w3/iw3jdn.f deleted file mode 100644 index 896d621..0000000 --- a/src/fim/FIMsrc/w3/iw3jdn.f +++ /dev/null @@ -1,62 +0,0 @@ - FUNCTION IW3JDN(IYEAR,MONTH,IDAY) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: IW3JDN COMPUTE JULIAN DAY NUMBER -C AUTHOR: JONES,R.E. ORG: W342 DATE: 87-03-29 -C -C ABSTRACT: COMPUTES JULIAN DAY NUMBER FROM YEAR (4 DIGITS), MONTH, -C AND DAY. IW3JDN IS VALID FOR YEARS 1583 A.D. TO 3300 A.D. -C JULIAN DAY NUMBER CAN BE USED TO COMPUTE DAY OF WEEK, DAY OF -C YEAR, RECORD NUMBERS IN AN ARCHIVE, REPLACE DAY OF CENTURY, -C FIND THE NUMBER OF DAYS BETWEEN TWO DATES. -C -C PROGRAM HISTORY LOG: -C 87-03-29 R.E.JONES -C 89-10-25 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C -C USAGE: II = IW3JDN(IYEAR,MONTH,IDAY) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C IYEAR ARG LIST INTEGER YEAR ( 4 DIGITS) -C MONTH ARG LIST INTEGER MONTH OF YEAR (1 - 12) -C IDAY ARG LIST INTEGER DAY OF MONTH (1 - 31) -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C IW3JDN FUNTION INTEGER JULIAN DAY NUMBER -C JAN. 1,1960 IS JULIAN DAY NUMBER 2436935 -C JAN. 1,1987 IS JULIAN DAY NUMBER 2446797 -C -C REMARKS: JULIAN PERIOD WAS DEVISED BY JOSEPH SCALIGER IN 1582. -C JULIAN DAY NUMBER #1 STARTED ON JAN. 1,4713 B.C. THREE MAJOR -C CHRONOLOGICAL CYCLES BEGIN ON THE SAME DAY. A 28-YEAR SOLAR -C CYCLE, A 19-YEAR LUNER CYCLE, A 15-YEAR INDICTION CYCLE, USED -C IN ANCIENT ROME TO REGULATE TAXES. IT WILL TAKE 7980 YEARS -C TO COMPLETE THE PERIOD, THE PRODUCT OF 28, 19, AND 15. -C SCALIGER NAMED THE PERIOD, DATE, AND NUMBER AFTER HIS FATHER -C JULIUS (NOT AFTER THE JULIAN CALENDAR). THIS SEEMS TO HAVE -C CAUSED A LOT OF CONFUSION IN TEXT BOOKS. SCALIGER NAME IS -C SPELLED THREE DIFFERENT WAYS. JULIAN DATE AND JULIAN DAY -C NUMBER ARE INTERCHANGED. A JULIAN DATE IS USED BY ASTRONOMERS -C TO COMPUTE ACCURATE TIME, IT HAS A FRACTION. WHEN TRUNCATED TO -C AN INTEGER IT IS CALLED AN JULIAN DAY NUMBER. THIS FUNCTION -C WAS IN A LETTER TO THE EDITOR OF THE COMMUNICATIONS OF THE ACM -C VOLUME 11 / NUMBER 10 / OCTOBER 1968. THE JULIAN DAY NUMBER -C CAN BE CONVERTED TO A YEAR, MONTH, DAY, DAY OF WEEK, DAY OF -C YEAR BY CALLING SUBROUTINE W3FS26. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/864, CRAY Y-MP EL2/256 -C -C$$$ -C - IW3JDN = IDAY - 32075 - & + 1461 * (IYEAR + 4800 + (MONTH - 14) / 12) / 4 - & + 367 * (MONTH - 2 - (MONTH -14) / 12 * 12) / 12 - & - 3 * ((IYEAR + 4900 + (MONTH - 14) / 12) / 100) / 4 - RETURN - END diff --git a/src/fim/FIMsrc/w3/iw3mat.f b/src/fim/FIMsrc/w3/iw3mat.f deleted file mode 100644 index 8da307d..0000000 --- a/src/fim/FIMsrc/w3/iw3mat.f +++ /dev/null @@ -1,47 +0,0 @@ - LOGICAL FUNCTION IW3MAT(L1, L2, N) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C FUNCTION: IW3MAT TEST FOR MATCH TWO INTEGER ARRAYS -C AUTHOR: STACKPOLE. J.D. ORG: W342 DATE: 86-01-13 -C -C ABSTACT: TEST N WORDS STARTING AT L1, L2 FOR EQUALITY, RETURN .TRUE. -C IF ALL EQUAL; OTHERWISE .FALSE. -C -C PROGRAM HISTORY LOG: -C 86-01-13 J.D.STACKPOLE -C 90-03-15 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C -C USAGE: II = IW3MAT(L1,L2,N) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C L1 ARG LIST INTEGER ARRAY TO MATCH WITH L2 -C L2 ARG LIST INTEGER ARRAY TO MATCH WITH L1 -C N ARG LIST NUMBER OF INTEGER WORDS TO TEST FOR MATCH -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C IW3MAT FUNCTION LOGICAL .TRUE. IF L1 AND L2 MATCH ON ALL WORDS, -C LOGICAL .FALSE. IF NOT MATCH ON ANY WORD -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/864, CRAY Y-MP EL@/256 -C -C$$$ -C - INTEGER L1(*) - INTEGER L2(*) -C - IW3MAT = .TRUE. - DO 10 I = 1,N - IF (L1(I).NE.L2(I)) GO TO 20 - 10 CONTINUE - RETURN -C - 20 CONTINUE - IW3MAT = .FALSE. - RETURN - END diff --git a/src/fim/FIMsrc/w3/iw3pds.f b/src/fim/FIMsrc/w3/iw3pds.f deleted file mode 100644 index 103beb6..0000000 --- a/src/fim/FIMsrc/w3/iw3pds.f +++ /dev/null @@ -1,177 +0,0 @@ - LOGICAL FUNCTION IW3PDS(L1, L2, KEY) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C FUNCTION: IW3PDS TEST FOR MATCH OF TWO PDS -C AUTHOR: JONES, R.E. ORG: W342 DATE: 88-02-22 -C -C ABSTACT: TEST TWO PDS (GRIB PRODUCT DEFINITION SECTION) TO SEE -C IF ALL EQUAL; OTHERWISE .FALSE. IF KEY = 1, ALL 24 CHARACTERS -C ARE TESTED, IF KEY = 0 , THE DATE (CHARACTERS 13-17) ARE NOT -C TESTED. IF KEY = 2, 11 OF 1ST 12 BYTES ARE TESTED. BYTE 4 IS -C IS NOT TESTED, SO TABLE VERSION NUMBER CAN CHANGE AND YOUR -C PROGRAM WILL STILL WORK. IF KEY=3, TEST BYTES 1-3, 7-12. -C -C PROGRAM HISTORY LOG: -C 88-02-22 R.E.JONES -C 89-08-29 R.E.JONES ADD ENTRY IW3PDS, AN ALIAS NAME. -C 89-08-29 R.E.JONES CHANGE TO CRAY CFT77 FORTRAN, MAKE IW3PDS -C THE FUNCTION NAME, IW3PDB THE ALIAS. -C 94-02-10 R.E.JONES ADD KEY=2, TEST ONLY 11 OF 1ST 12 BYTES. -C BYTE 4 (TABLE VERSION NO.) IS NOT TESTED -C 94-07-07 R.E.JONES ADD KEY=3, TEST BYTES 1-3, 7-12. -C -C USAGE: II = IW3PDS(L1,L2,KEY) -C II = IW3PDB(L1,L2,KEY) ALIAS -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C L1 ARG LIST CHARACTER ARRAY TO MATCH WITH L2, -C L1 CAN ALSO BE A 3 WORD INTEGER ARRAY -C L2 ARG LIST CHARACTER ARRAY TO MATCH WITH L1, -C L2 CAN ALSO BE A 3 WORD INTEGER ARRAY -C KEY ARG LIST 0, DO NOT INCLUDE THE DATE (BYTES 13-17) IN -C MATCH. -C 1, MATCH 24 BYTES OF PDS -C 2, MATCH BYTES 1-3, 5-12 OF PDS -C 3, MATCH BYTES 1-3, 7-12 OF PDS -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C IW3PDB FUNCTION LOGICAL .TRUE. IF L1 AND L2 MATCH ON ALL CHAR., -C LOGICAL .FALSE. IF NOT MATCH ON ANY CHAR. -C -C EXAMPLE: SEARCH IDTBL FOR MATCH WITH GIVEN (PDS), USE RBA IN 7TH -C ID WORD TO READ RECORD BY RBA. -C -C INTEGER IDTBL(1794), IPDS(6), RBA -C LOGICAL IW3PDS -C -C KEY = 0 -C DO 400 I = 9,1793,7 -C IF (IDTBL(I).EQ.0) GO TO 500 -C IF (IW3PDS(IPDS,IDTBL(I),KEY)) THEN -C RBA = IDTBL(I+6) -C GO TO 600 -C END IF -C 400 CONTINUE -C -C 500 CONTINUE -C GO TO XXXX ... ERROR EXIT , CAN NOT FIND RECORD -C -C 600 .. READ RECORD WITH RBA -C -C REMARK: ALIAS ADDED BECAUSE OF NAME CHANGE IN GRIB WRITE UP. -C NAME OF PDB (PRODUCT DEFINITION BLOCK) WAS CHANGD TO PDS -C (PRODUCT DEFINITION SECTION). -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256 -C -C$$$ -C - CHARACTER*1 L1(24) - CHARACTER*1 L2(24) -C - LOGICAL IW3PDB -C - SAVE -C - IW3PDS = .TRUE. -C - IF (KEY.EQ.1) THEN - DO 10 I = 1,3 - IF (L1(I).NE.L2(I)) GO TO 70 - 10 CONTINUE -C - DO 20 I = 5,24 - IF (L1(I).NE.L2(I)) GO TO 70 - 20 CONTINUE -C - ELSE -C - DO 30 I = 1,3 - IF (L1(I).NE.L2(I)) GO TO 70 - 30 CONTINUE -C -C DO NOT TEST BYTE 4, 5, 6 PDS VER. NO., COUNTRY -C MODEL NUMBER. U.S., U.K., FNOC WAFS DATA WILL -C WORK. -C - IF (KEY.EQ.3) THEN - DO I = 7,12 - IF (L1(I).NE.L2(I)) GO TO 70 - END DO - GO TO 60 - END IF -C -C DO NOT TEST PDS VERSION NUMBER, IT MAY BE 1 O 2 -C - DO 40 I = 5,12 - IF (L1(I).NE.L2(I)) GO TO 70 - 40 CONTINUE - IF (KEY.EQ.2) GO TO 60 -C - DO 50 I = 18,24 - IF (L1(I).NE.L2(I)) GO TO 70 - 50 CONTINUE - ENDIF -C - 60 CONTINUE - RETURN -C - 70 CONTINUE - IW3PDS = .FALSE. - RETURN -C - ENTRY IW3PDB (L1, L2, KEY) -C - IW3PDB = .TRUE. -C - IF (KEY.EQ.1) THEN - DO 80 I = 1,3 - IF (L1(I).NE.L2(I)) GO TO 140 - 80 CONTINUE -C - DO 90 I = 5,24 - IF (L1(I).NE.L2(I)) GO TO 140 - 90 CONTINUE -C - ELSE -C - DO 100 I = 1,3 - IF (L1(I).NE.L2(I)) GO TO 140 - 100 CONTINUE -C -C DO NOT TEST BYTE 4, 5, 6 PDS VER. NO., COUNTRY -C MODEL NUMBER. U.S., U.K., FNOC WAFS DATA WILL -C WORK. -C - IF (KEY.EQ.3) THEN - DO I = 7,12 - IF (L1(I).NE.L2(I)) GO TO 140 - END DO - GO TO 130 - END IF -C -C DO NOT TEST PDS VERSION NUMBER, IT MAY BE 1 O 2 -C - DO 110 I = 5,12 - IF (L1(I).NE.L2(I)) GO TO 140 - 110 CONTINUE - IF (KEY.EQ.2) GO TO 130 -C - DO 120 I = 18,24 - IF (L1(I).NE.L2(I)) GO TO 140 - 120 CONTINUE - ENDIF -C - 130 CONTINUE - RETURN -C - 140 CONTINUE - IW3PDB = .FALSE. - RETURN - END diff --git a/src/fim/FIMsrc/w3/iw3unp29.f b/src/fim/FIMsrc/w3/iw3unp29.f deleted file mode 100644 index c6a025e..0000000 --- a/src/fim/FIMsrc/w3/iw3unp29.f +++ /dev/null @@ -1,5002 +0,0 @@ -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: IW3UNP29 UNPACKS A REPORT INTO UNPKED ON29/124 FMT -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-03-05 -C -C ABSTRACT: READS AND UNPACKS ONE REPORT INTO THE UNPACKED OFFICE NOTE -C 29/124 FORMAT. THE INPUT DATA MAY BE PACKED INTO EITHER JBUFR OR -C TRUE ON29/124 FORMAT WITH A Y2K COMPLIANT PSEUDO-ON85 HEADER LABEL. -C (NOTE: AS A TEMPORARY MEASURE, THIS CODE WILL STILL OPERATE ON A -C TRUE ON29/124 FORMAT FILE WITH A NON-Y2K COMPLIANT ON85 HEADER -C LABEL. THE CODE WILL USE THE "WINDOWING" TECHNIQUE TO OBTAIN A -C 4-DIGIT YEAR.) THIS ROUTINE WILL DETERMINE THE FORMAT OF THE -C INPUT DATA AND TAKE THE APPROPRIATE ACTION. IT RETURNS THE -C UNPACKED REPORT TO THE CALLING PROGRAM IN THE ARRAY 'OBS'. -C VARIOUS CONTINGENCIES ARE COVERED BY RETURN VALUE OF THE FUNCTION -C AND PARAMETER 'IER' - FUNCTION AND IER HAVE SAME VALUE. REPEATED -C CALLS OF FUNCTION WILL RETURN A SEQUENCE OF UNPACKED ON29/124 -C REPORTS. THE CALLING PROGRAM MAY SWITCH TO A NEW 'NUNIT' AT ANY -C TIME, THAT DATASET WILL THEN BE READ IN SEQUENCE. IF USER -C SWITCHES BACK TO A PREVIOUS 'NUNIT', THAT DATA SET WILL BE READ -C FROM THE BEGINNING, NOT FROM WHERE THE USER LEFT OFF (THIS IS A -C 'SOFTWARE TOOL', NOT AN ENTIRE I/O SYSTEM). -C -C PROGRAM HISTORY LOG: -C 1996-12-13 J. S. WOOLLEN (GSC) -- ORIGINAL AUTHOR - NOTE THIS NEW -C VERSION OF IW3GAD INCORPORATES THE EARLIER VERSION WHICH -C WAS WRITTEN BY J. STACKPOLE AND DEALT ONLY WITH TRUE -C ON29/124 DATA AS INPUT - THIS OPTION IS STILL AVAILABLE -C BUT IS A SMALL PART OF THE NEW ROUTINE WHICH WAS WRITTEN -C FROM SCRATCH TO READ IN JBUFR DATA. -C 1997-01-27 D. A. KEYSER -- CHANGES TO MORE CLOSELY DUPLICATE FORMAT -C OBTAINED WHEN READING FROM TRUE ON29/124 DATA SETS. -C 1997-02-04 D. A. KEYSER -- DROPS WITH MISSING STNID GET STNID SET TO -C "DRP88A"; SATWNDS WITH ZERO PRESSURE ARE TOSSED -C 1997-02-12 D. A. KEYSER -- TO GET AROUND THE 3-BIT LIMITATION TO -C THE ON29 PRESSURE Q.M. MNEMONIC "QMPR", AN SDMEDIT/QUIPS -C PURGE OR REJECT FLAG ON PRESSURE IS CHANGED FROM 12 OR 14 -C TO 6 IN ORDER TO FIT INTO 3-BITS, SEE FUNCTION E35O29; -C INTERPRETS SDMEDIT AND QUIPS PURGE/KEEP/CHANGE FLAGS -C PROPERLY FOR ALL DATA TYPES; CAN NOW PROCESS CAT. 6 AND -C CAT. 2/3 TYPE FLIGHT-LEVEL RECCOS (BEFORE SKIPPED THESE); -C TESTS FOR MISSING LAT, LON, OBTIME DECODED FROM BUFR AND -C RETAINS MISSING VALUE ON THESE IN UNPACKED ON29/124 -C FORMAT (BEFORE NO MISSING CHECK, LED TO POSSIBLE NON- -C MISSING BUT INCORRECT VALUES FOR THESE); THE CHECK FOR -C DROPS WITH MISSING STNID REMOVED SINCE DECODER FIXED FOR -C THIS -C 1997-05-01 D. A. KEYSER -- LOOKS FOR DUPLICATE LEVELS WHEN -C PROCESSING ON29 CAT. 2, 3, AND 4 (IN ALL DATA ON LEVEL) -C AND REMOVES DUPLICATE LEVEL; IN PROCESSING ON29 CAT. 3 -C LEVELS, REMOVES ALL LEVELS WHERE WIND IS MISSING; FIXED -C BUG IN AIRCRAFT (AIREP/PIREP/AMDAR) QUALITY MARK -C ASSIGNMENT (WAS NOT ASSIGNING KEEP FLAG TO REPORT IF -C PRESSURE HAD A KEEP Q.M. BUT TEMPERATURE Q.M. WAS -C MISSING) -C 1997-05-30 D. A. KEYSER -- FOR AIRCFT: (ONLY ACARS RIGHT NOW) - -C SECONDS ARE DECODED (IF AVAIL.) AND USED TO OBTAIN -C REPORT TIME; ONLY ASDAR/AMDAR - NEW CAT. 8 CODE FIGS. -C O-PUT 917 (CHAR. 1 & 2 OF ACTUAL STNID), 918 (CHAR. 3 & -C 4 OF ACTUAL STNID), 919 (CHAR. 5 & 6 OF ACTUAL STNID); -C ASDAR/AMDAR AND ACARS - NEW CAT. 8 CODE FIG. O-PUT 920 -C (CHAR. 7 & 8 OF ACTUAL STNID); ONLY ACARS - NEW CAT. 8 -C CODE FIG. O-PUT 921 (REPORT TIME TO NEAREST 1000'TH OF -C AN HOUR); ONLY SOME ACARS - NEW MNEMONIC "IALT" NOW -C EXISTS AND CAN (IF LINE NOT COMMENTED OUT) BE USED TO -C OBTAIN UNPACKED ON29 CAT. 6 -C 1997-07-02 D. A. KEYSER -- REMOVED FILTERING OF AIRCRAFT DATA AS -C FOLLOWS: AIR FRANCE AMDARS NO LONGER FILTERED, AMDAR/ -C ASDAR BELOW 7500 FT. NO LONGER FILTERED, AIREP/PIREP -C BELOW 100 METERS NO LONGER FILTERED, ALL AIRCRAFT WITH -C MISSING WIND BUT VALID TEMPERATURE ARE NO LONGER -C FILTERED; REPROCESSES U.S. SATWND STN. IDS TO CONFORM -C WITH PREVIOUS ON29 APPEARANCE EXCEPT NOW 8-CHAR (TAG -C CHAR. 1 & 6 NOT CHANGED FROM JBUFR STN. ID) - NEVER ANY -C DUPL. IDS NOW FOR U.S. SATWNDS DECODED FROM A SINGLE -C JBUFR FILE; STREAMLINED/ELIMINATED SOME DO LOOPS TO -C SPEED UP A BIT -C 1997-09-18 D. A. KEYSER -- CORRECTED ERRORS IN REFORMATTING SURFACE -C DATA INTO UNPACKED ON124, SPECIFICALLY-HEADER: INST. TYPE -C (SYNOPTIC FMT FLG, AUTO STN. TYPE, CONVERTED HRLY FLG), -C INDICATORS (PRECIP., WIND SPEED, WX/AUTO STN), CAT51: -C P-TEND, HORIZ. VIZ., PRESENT/PAST WX, CLOUD INFO, MAX/ -C MIN TEMP, CAT52: PRECIP., SNOW DPTH, WAVE INFO, SHIP -C COURSE/SPEED, CAT8: CODE FIGS. 81-85,98; CORRECTED -C PROBLEM WHICH CODED UPPER-AIR MANDATORY LEVEL WINDS -C AS CAT. 3 INSTEAD OF CAT. 1 WHEN MASS DATA (ONLY) WAS -C REPORTED ON SAME MANDATORY LEVEL IN A SEPARATE REPORTED -C LEVEL IN THE RAW BULLETIN -C 1997-10-06 D. A. KEYSER -- UPDATED LOGIC TO READ AND PROCESS NESDIS -C HI-DENSITY SATELLITE WINDS PROPERLY -C 1997-10-30 D. A. KEYSER -- ADDED GROSS CHECK ON U-AIR PRESSURE, ALL -C LEVELS WITH REPORTED PRESSURE .LE. ZERO NOW TOSSED; SFC -C CAT. 52 SEA-SFC TEMPERATURE NOW READ FROM HIERARCHY OF -C SST IN BUFR {1ST CHOICE - HI-RES SST ('SST2'), 2ND -C CHOICE - LO-RES SST ('SST1'), 3RD CHOICE - SEA TEMP -C ('STMP')}, BEFORE ONLY READ 'SST1' -C 1998-01-26 D. A. KEYSER -- CHANGED PQM PROCESSING FOR ADPUPA TYPES -C SUCH THAT SDMEDIT FLAGS ARE NOW HONORED (BEFORE, PQM -C WAS ALWAYS HARDWIRED TO 2 FOR ADPUPA TYPES); BUMPED -C LIMIT FOR NUMBER OF LEVELS THAT CAN BE PROCESSED FROM -C 100 TO 150 AND ADDED DIAGNOSTIC PRINT WHEN THE LIMIT -C IS EXCEEDED -C 1998-05-19 D. A. KEYSER -- Y2K COMPLIANT VERSION OF IW3GAD ROUTINE -C ACCOMPLISHED BY REDEFINING ORIGINAL 32-CHARACTER ON85 -C HEADER LABEL TO BE A 40-CHARACTER LABEL THAT CONTAINS A -C FULL 4-DIGIT YEAR, CAN STILL READ "TRUE" ON29/124 DATA -C SETS PROVIDED THEIR HEADER LABEL IS IN THIS MODIFIED -C FORM -C 1998-07-22 D. A. KEYSER -- MINOR MODIFICATIONS TO ACCOUNT FOR -C CORRECTIONS IN Y2K/F90 BUFRLIB (MAINLY RELATED TO -C BUFRLIB ROUTINE DUMPBF) -C 1998-08-04 D. A. KEYSER -- FIXED A BUG THAT RESULTED IN CODE BEING -C CLOBBERED IN CERTAIN SITUATIONS FOR RECCO REPORTS; MINOR -C MODIFICATIONS TO GIVE SAME ANSWERS ON CRAY AS ON SGI; -C ALLOWED CODE TO READ TRUE ON29/124 FILES WITH NON-Y2K -C COMPLIANT ON85 LABEL (A TEMPORARY MEASURE DURING -C TRANSITION OF MAIN PROGRAMS TO Y2K); ADDED CALL TO "AEA" -C WHICH CONVERTS EBCDIC CHARACTERS TO ASCII FOR INPUT -C TRUE ON29/124 DATA SET PROCESSING OF SGI (WHICH DOES -C NOT SUPPORT "-Cebcdic" IN ASSIGN STATEMENT) -C 1999-02-25 D. A. KEYSER -- ADDED ABILITY TO READ REPROCESSED SSM/I -C JBUFR DATA SET (SPSSMI); ADDED ABILITY TO READ MEAN -C SEA-LEVEL PRESSURE BOGUS (PAOBS) DATA SET (SFCBOG) -C 1999-05-14 D. A. KEYSER -- MADE CHANGES NECESSARY TO PORT THIS -C ROUTINE TO THE IBM SP -C 1999-06-18 D. A. KEYSER -- CAN NOW PROCESS WATER VAPOR SATWNDS -C FROM FOREIGN PRODUCERS; STN. ID FOR FOREIGN SATWNDS -C NOW REPROCESSED IN SAME WAY AS FOR NESDIS/GOES SATWNDS, -C CHARACTER 1 OF STN. ID NOW DEFINES EVEN VS. ODD -C SATELLITE WHILE CHARACTER 6 OF STN. ID NOW DEFINES -C IR CLOUD-DRFT VS. VISIBLE CLOUD DRFT VS. WATER VAPOR -C 2002-03-05 D. A. KEYSER -- REMOVED ENTRY "E02O29", NOW PERFORMS -C HEIGHT TO PRESS. CONVERSION DIRECTLY IN CODE FOR CAT. 7; -C TEST FOR MISSING "RPID" CORRECTED FOR ADPUPA DATA (NOW -C CHECKS UFBINT RETURN CODE RATHER THAN VALUE=BMISS); -C ACCOUNTS FOR CHANGES IN INPUT ADPUPA, ADPSFC, AIRCFT -C AND AIRCAR BUFR DUMP FILES AFTER 3/2002: CAT. 7 AND CAT. -C 51 USE MNEMONIC "HBLCS" TO GET HEIGHT OF CLOUD BASE IF -C MNEMONIC "HOCB" NOT AVAILABLE (AND IT WILL NOT BE FOR ALL -C CAT. 7 AND SOME CAT. 51 REPORTS); MNEMONIC "TIWM" -C REPLACES "SUWS" IN HEADER FOR SURFACE DATA; MNEMONIC -C "BORG" REPLACES "ICLI" IN CAT. 8 FOR AIRCRAFT DATA (WILL -C STILL WORK PROPERLY FOR INPUT ADPUPA, ADPSFC, AIRCFT AND -C AIRCAR DUMP FILES PRIOR TO 3/2002) -C -C -C USAGE: II = IW3UNP29(NUNIT, OBS, IER) -C INPUT ARGUMENT LIST: -C NUNIT - FORTRAN UNIT NUMBER FOR SEQUENTIAL DATA SET CONTAINING -C - PACKED JBUFR REPORTS OR PACKED AND BLOCKED OFFICE NOTE -C - 29/124 REPORTS -C -C OUTPUT ARGUMENT LIST: -C OBS - ARRAY CONTAINING ONE REPORT IN UNPACKED OFFICE NOTE -C - 29/124 FORMAT. FORMAT IS MIXED, USER MUST EQUIVALENCE -C - INTEGER AND CHARACTER ARRAYS TO THIS ARRAY (SEE -C - DOCBLOCK FOR W3FI64 IN /nwprod/w3libs/w3lib.source -C - OR WRITEUPS ON W3FI64, ON29, ON124 FOR HELP) -C - THE LENGTH OF THE ARRAY SHOULD BE AT LEAST 1608 -C IER - RETURN FLAG (EQUAL TO FUNCTION VALUE) - SEE REMARKS -C -C INPUT FILES: -C UNIT AA - SEQUENTIAL JBUFR OR OFFICE NOTE 29/124 DATA SET ("AA" -C - IS UNIT NUMBER SPECIFIED BY INPUT ARGUMENT "NUNIT") -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C SUBPROGRAMS CALLED: -C UNIQUE: xxxxxx -C LIBRARY: -C UTILITY - xxxxxx -C W3LIB - xxxxxx -C BUFRLIB - xxxxxx -C -C REMARKS: -C IF INPUT DATA SET IS ON29/124, IT SHOULD BE ASSIGNED IN THIS WAY: -C Cray: -C assign -a ADPUPA -Fcos -Cebcdic fort.XX -C SGI: -C assign -a ADPUPA -Fcos fort.XX -C (Note: -Cebcdic is not possible on SGI, so call to W3LIB -C routine "AEA" takes care of the conversion as each -C ON29 record is read in) -C IF INPUT DATA SET IS JBUFR, IT SHOULD BE ASSIGNED IN THIS WAY: -C Cray: -C assign -a ADPUPA fort.XX -C SGI: -C assign -a ADPUPA -F cos fort.XX -C -C NOTE: FOR INPUT ON29/124 DATA SETS, A CONTINGENCY HAS BEEN BUILT -C INTO THIS SUBROUTINE TO PERFORM THE CONVERSION FROM EBCDIC TO -C ASCII IN THE EVENT THE assign DOES NOT PERFORM THE CONVERSION -C -C THE RETURN FLAGS IN IER (AND FUNCTION IW3UNP29 ITSELF) ARE: -C = 0 OBSERVATION READ AND UNPACKED INTO LOCATION 'OBS'. -C SEE WRITEUP OF W3FI64 FOR CONTENTS. (ALL CHARACTER -C WORDS ARE LEFT-JUSTIFIED.) NEXT CALL TO IW3UNP29 -C WILL RETURN NEXT OBSERVATION IN DATA SET. -C = 1 A 40 BYTE HEADER IN THE FORMAT DESCRIBED HERE -C (Y2K COMPLIANT PSEUDO-OFFICE NOTE 85) IS RETURNED -cvvvvvdak port -C IN THE FIRST 10 WORDS OF 'OBS' ON a 4-BYTE MACHINE -C (IBM) AND IN THE FIRST 5 WORDS OF 'OBS' ON AN -C 8-BYTE MACHINE (CRAY). NEXT CALL TO -caaaaadak port -C IW3UNP29 WILL RETURN FIRST OBS. IN THIS DATA SET. -C (NOTE: IF INPUT DATA SET IS A TRUE ON29/124 FILE -C WITH THE Y2K COMPLIANT PSEUDO-ON85 HEADER RECORD, -C THEN THE PSEUDO-ON85 HEADER RECORD IS ACTUALLY -C READ IN AND RETURNED; IF INPUT DATA SET IS A TRUE -C ON29/124 FILE WITH A NON-Y2K COMPLIANT ON85 HEADER -C RECORD, THEN A Y2K COMPLIANT PSEUDO-ON85 HEADER -C RECORD IS CONSTRUCTED FROM IT USING THE "WINDOWING" -C TECHNIQUE TO OBTAIN A 4-DIGIT YEAR FROM A 2-DIGIT -C YEAR.) -C FORMAT FOR Y2K COMPLIANT PSEUDO-ON85 HEADER RECORD -C RETURNED (40 BYTES IN CHARACTER): -C BYTES 1- 8 -- DATA SET NAME (AS DEFINED IN ON85 -C EXCEPT UP TO EIGHT ASCII CHAR., -C LEFT JUSTIFIED WITH BLANK FILL) -C BYTES 9-10 -- SET TYPE (AS DEFINED IN ON85) -C BYTES 11-20 -- CENTER (ANALYSIS) DATE FOR DATA -C SET (TEN ASCII CHARACTERS IN FORM -C "YYYYMMDDHH") -C BYTES 21-24 -- SET INITIALIZE (DUMP) TIME, AS -C DEDINED IN ON85) -C BYTES 25-34 -- ALWAYS "WASHINGTON" (AS IN ON85) -C BYTES 35-36 -- SOURCE MACHINE (AS DEFINED IN ON85) -C BYTES 37-40 -- BLANK FILL CHARACTERS -C -C = 2 END-OF-FILE (NEVER AN EMPTY OR NULL FILE): -C INPUT ON29/124 DATA SET: THE "ENDOF FILE" RECORD IS -C ENCOUNTERED - NO USEFUL INFORMATION IN 'OBS' ARRAY. -C NEXT CALL TO IW3UNP29 WILL RETURN PHYSICAL END OF -C FILE FOR DATA SET IN 'NUNIT' (SEE IER=3 BELOW). -C INPUT JBUFR DATA SET: THE PHYSICAL END OF FILE IS -C ENCOUNTERED. -C = 3 END-OF-FILE: -C PHYSICAL END OF FILE ENCOUNTERED ON DATA SET - -C THIS CAN ONLY HAPPEN FOR AN EMPTY (NULL) DATA SET -C OR FOR A TRUE ON29/124 DATA SET. THERE ARE NO -C MORE REPORTS (OR NEVER WERE ANY IF NULL) ASSOCIATED -C WITH DATA SET IN THIS UNIT NUMBER - NO USEFUL -C INFORMATION IN 'OBS' ARRAY. EITHER ALL DONE (IF -C NO MORE UNIT NUMBERS ARE TO BE READ IN), OR RESET -C 'NUNIT' TO POINT TO A NEW DATA SET (IN WHICH CASE -C NEXT CALL TO IW3UNP29 SHOULD RETURN WITH IER=1). -C = 4 ONLY VALID FOR INPUT ON29/124 DATA SET - I/O ERROR -C READING THE NEXT RECORD OF REPORTS - NO USEFUL -C INFORMATION IN 'OBS' ARRAY. CALLING PROGRAM CAN -C CHOOSE TO STOP OR AGAIN CALL IW3UNP29 WHICH WILL -C ATTEMPT TO UNPACK THE FIRST OBSERVATION IN THE NEXT -C RECORD OF REPORTS. -C = 999 APPLIES ONLY TO NON-EMPTY DATA SETS: -C INPUT ON29/124 DATA SET: FIRST CHOICE Y2K COMPLIANT -C PSEUDO-ON85 FILE HEADER LABEL NOT ENCOUNTERED WHERE -C EXPECTED, AND SECOND CHOICE NON-Y2K COMPLIANT ON85 -C FILE HEADER LABEL ALSO NOT ENCOUNTERED. -C INPUT JBUFR DATA SET: EITHER HEADER LABEL IN -C FORMAT OF PSEUDO-ON85 COULD NOT BE RETURNED, OR AN -C ABNORMAL ERROR OCCURRED IN THE ATTEMPT TO DECODE AN -C OBSERVATION. FOR EITHER INPUT DATA SET TYPE, NO -C USEFUL INFORMATION IN 'OBS' ARRAY. CALLING PROGRAM -C CAN CHOOSE TO STOP WITH NON-ZERO CONDITION CODE OR -C RESET 'NUNIT' TO POINT TO A NEW DATA SET (IN WHICH -C CASE NEXT CALL TO IW3UNP29 SHOULD RETURN WITH -C IER=1). -C INPUT DATA SET NEITHER ON29/124 NOR BUFR: SPEAKS FOR -C ITSELF. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP, CRAY, SGI -C -C$$$ - FUNCTION IW3UNP29(LUNIT,OBS,IER) - - COMMON/IO29AA/JWFILE(100),LASTF - COMMON/IO29BB/KNDX,KSKACF(8),KSKUPA,KSKSFC,KSKSAT,KSKSMI - COMMON/IO29CC/SUBSET,IDAT10 - COMMON/IO29DD/HDR(12),RCATS(50,150,11),IKAT(11),MCAT(11),NCAT(11) - COMMON/IO29EE/ROBS(255,11) - COMMON/IO29FF/QMS(255,9) - COMMON/IO29GG/SFO(34) - COMMON/IO29HH/SFQ(5) - COMMON/IO29II/PWMIN - COMMON/IO29JJ/ISET,MANLIN(1001) - COMMON/IO29KK/KOUNT(499,18) - - DIMENSION OBS(*) - - SAVE - - DATA ITIMES/0/ - - IF(ITIMES.EQ.0) THEN - -C THE FIRST TIME IN, INITIALIZE SOME DATA -C (NOTE: FORTRAN 77/90 STANDARD DOES NOT ALLOW COMMON BLOCK VARIABLES -C TO BE INITIALIZED VIA DATA STATEMENTS, AND, FOR SOME REASON, -C THE BLOCK DATA DOES NOT INITIALIZE DATA IN THE W3LIB -C A V O I D B L O C K D A T A I N W 3 L I B ) -C -------------------------------------------------------------------- - - ITIMES = 1 - JWFILE = 0 - LASTF = 0 - KNDX = 0 - KSKACF = 0 - KSKUPA = 0 - KSKSFC = 0 - KSKSAT = 0 - KSKSMI = 0 - KOUNT = 0 - IKAT(1) = 1 - IKAT(2) = 2 - IKAT(3) = 3 - IKAT(4) = 4 - IKAT(5) = 5 - IKAT(6) = 6 - IKAT(7) = 7 - IKAT(8) = 8 - IKAT(9) = 51 - IKAT(10) = 52 - IKAT(11) = 9 - MCAT(1) = 6 - MCAT(2) = 4 - MCAT(3) = 4 - MCAT(4) = 4 - MCAT(5) = 6 - MCAT(6) = 6 - MCAT(7) = 3 - MCAT(8) = 3 - MCAT(9) = 21 - MCAT(10) = 15 - MCAT(11) = 3 - ISET = 0 - END IF - -C UNIT NUMBER OUT OF RANGE RETURNS A 999 -C -------------------------------------- - - IF(LUNIT.LT.1 .OR. LUNIT.GT.100) THEN - PRINT *, '##IW3UNP29 - UNIT NUMBER ',LUNIT,' OUT OF RANGE -- ', - $ 'IER = 999' - GO TO 9999 - END IF - IF(LASTF.NE.LUNIT .AND. LASTF.GT.0) THEN - CALL CLOSBF(LASTF) - JWFILE(LASTF) = 0 - END IF - LASTF = LUNIT - -C THE JWFILE INDICATOR: =0 IF UNOPENED; =1 IF ON29; =2 IF BUFR -C ------------------------------------------------------------ - - IF(JWFILE(LUNIT).EQ.0) THEN - PRINT *,'===> IW3UNP29 - VERSION: 03-05-2002' - IF(I03O29(LUNIT,OBS,IER).EQ.1) THEN - PRINT *,'IW3UNP29 - OPENED A TRUE OFFICE NOTE 29 FILE IN ', - $ 'UNIT ',LUNIT - JWFILE(LUNIT) = 1 - IER = 1 - IW3UNP29 = 1 - ELSEIF(I03O29(LUNIT,OBS,IER).EQ.3) THEN - PRINT 107, LUNIT - 107 FORMAT(/,' ##IW3UNP29 - FILE IN UNIT',I3,' IS EMPTY OR NULL -- ', - $ 'IER = 3'/) - IER = 3 - IW3UNP29 = 3 - ELSEIF(I02O29(LUNIT,OBS,IER).EQ.1) THEN - PRINT *,'IW3UNP29 - OPENED A JBUFR FILE IN UNIT ',LUNIT - JWFILE(LUNIT) = 2 - KNDX = 0 - KSKACF = 0 - KSKUPA = 0 - KSKSFC = 0 - KSKSAT = 0 - KSKSMI = 0 - IER = 1 - IW3UNP29 = 1 - ELSEIF(I03O29(LUNIT,OBS,IER).EQ.999) THEN - PRINT *,'IW3UNP29 - OPENED A TRUE OFFICE NOTE 29 FILE IN ', - $ 'UNIT ',LUNIT - PRINT 88 - 88 FORMAT(/' ##IW3UNP29/I03O29 - NEITHER EXPECTED Y2K COMPLIANT ', - $ 'PSEUDO-ON85 LABEL NOR SECOND CHOICE NON-Y2K COMPLIANT ON85 ', - $ 'LABEL FOUND IN'/21X,'FIRST RECORD OF FILE -- IER = 999'/) - GO TO 9999 - ELSE - PRINT 108, LUNIT - 108 FORMAT(/,' ##IW3UNP29 - FILE IN UNIT',I3,' IS NEITHER JBUFR NOR ', - $ 'TRUE OFFICE NOTE 29 -- IER = 999'/) - GO TO 9999 - END IF - ELSEIF(JWFILE(LUNIT).EQ.1) THEN - IF(I03O29(LUNIT,OBS,IER).NE.0) JWFILE(LUNIT) = 0 - IF(IER.GT.0) CLOSE (LUNIT) - IW3UNP29 = IER - ELSEIF(JWFILE(LUNIT).EQ.2) THEN - IF(I02O29(LUNIT,OBS,IER).NE.0) JWFILE(LUNIT) = 0 - IF(IER.GT.0) CALL CLOSBF(LUNIT) - IF(IER.EQ.2.OR.IER.EQ.3) THEN - IF(KSKACF(1).GT.0) PRINT *, 'IW3UNP29 - NO. OF AIRCFT/', - $ 'AIRCAR REPORTS TOSSED DUE TO ZERO CAT. 6 LVLS = ',KSKACF(1) - IF(KSKACF(2).GT.0) PRINT *, 'IW3UNP29 - NO. OF AIRCFT ', - $ 'REPORTS TOSSED DUE TO BEING "LFPW" AMDAR = ',KSKACF(2) - IF(KSKACF(8).GT.0) PRINT *, 'IW3UNP29 - NO. OF AIRCFT ', - $ 'REPORTS TOSSED DUE TO BEING "PHWR" AIREP = ',KSKACF(8) - IF(KSKACF(3).GT.0) PRINT *, 'IW3UNP29 - NO. OF AIRCFT ', - $ 'REPORTS TOSSED DUE TO BEING CARSWELL AMDAR = ',KSKACF(3) - IF(KSKACF(4).GT.0) PRINT *, 'IW3UNP29 - NO. OF AIRCFT ', - $ 'REPORTS TOSSED DUE TO BEING CARSWELL ACARS = ',KSKACF(4) - IF(KSKACF(5).GT.0) PRINT *, 'IW3UNP29 - NO. OF AIRCFT/', - $ 'AIRCAR REPORTS TOSSED DUE TO HAVING MISSING WIND = ', - $ KSKACF(5) - IF(KSKACF(6).GT.0) PRINT *, 'IW3UNP29 - NO. OF AIRCFT ', - $ 'REPORTS TOSSED DUE TO BEING AMDAR < 2286 M = ',KSKACF(6) - IF(KSKACF(7).GT.0) PRINT *, 'IW3UNP29 - NO. OF AIRCFT ', - $ 'REPORTS TOSSED DUE TO BEING AIREP < 100 M = ',KSKACF(7) - IF(KSKACF(1)+KSKACF(2)+KSKACF(3)+KSKACF(4)+KSKACF(5)+ - $ KSKACF(6)+KSKACF(7)+KSKACF(8).GT.0) - $ PRINT *, 'IW3UNP29 - TOTAL NO. OF AIRCFT/AIRCAR REPORTS ', - $ 'TOSSED = ',KSKACF(1)+KSKACF(2)+KSKACF(3)+KSKACF(4)+ - $ KSKACF(5)+KSKACF(6)+KSKACF(7)+KSKACF(8) - IF(KSKUPA.GT.0) PRINT *, 'IW3UNP29 - TOTAL NO. OF ADPUPA ', - $ 'REPORTS TOSSED = ',KSKUPA - IF(KSKSFC.GT.0) PRINT *, 'IW3UNP29 - TOTAL NO. OF ADPSFC/', - $ 'SFCSHP/SFCBOG REPORTS TOSSED = ',KSKSFC - IF(KSKSAT.GT.0) PRINT *, 'IW3UNP29 - TOTAL NO. OF SATWND ', - $ 'REPORTS TOSSED = ',KSKSAT - IF(KSKSMI.GT.0) PRINT *, 'IW3UNP29 - TOTAL NO. OF SPSSMI ', - $ 'REPORTS TOSSED = ',KSKSMI - KNDX = 0 - KSKACF = 0 - KSKUPA = 0 - KSKSFC = 0 - KSKSAT = 0 - KSKSMI = 0 - END IF - IW3UNP29 = IER - END IF - - RETURN - - 9999 CONTINUE - IER = 999 - IW3UNP29 = 999 - RETURN - - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** -C----------------------------------------------------------------------- -C I01O29 RETURNS LOOK ALIKE Y2K COMPL. PSEUDO-ON85 HDR FROM A DATA FILE -C----------------------------------------------------------------------- - FUNCTION I01O29(LUNIT,HDR,IER) -C ---> formerly FUNCTION IW3HDR - - COMMON/IO29AA/JWFILE(100),LASTF - - DIMENSION HDR(*) - - SAVE - -C UNIT NUMBER OUT OF RANGE RETURNS A 999 -C -------------------------------------- - - IF(LUNIT.LT.1 .OR. LUNIT.GT.100) THEN - PRINT *, '##IW3UNP29/I01O29 - UNIT NUMBER ',LUNIT,' OUT OF ', - $ 'RANGE -- IER = 999' - GO TO 9999 - END IF - -C THE JWFILE INDICATOR: =0 IF UNOPENED; =1 IF ON29; =2 IF BUFR -C ------------------------------------------------------------ - - IF(JWFILE(LUNIT).EQ.0) THEN - IF(I03O29(LUNIT,HDR,IER).EQ.1) THEN - I01O29 = I03O29(0,HDR,IER) - I01O29 = 1 - RETURN - ELSEIF(I02O29(LUNIT,HDR,IER).EQ.1) THEN - CALL CLOSBF(LUNIT) - I01O29 = 1 - RETURN - ELSE - -C CAN'T READ FILE HEADER RETURNS A 999 -C ------------------------------------ - - PRINT *, '##IW3UNP29/I01O29 - CANT READ FILE HEADER -- ', - $ 'IER = 999' - GO TO 9999 - END IF - ELSE - -C FILE ALREADY OPEN RETURNS A 999 -C ------------------------------- - - PRINT *, '##IW3UNP29/I01O29 - FILE ALREADY OPEN -- IER = 999' - GO TO 9999 - END IF - - RETURN - - 9999 CONTINUE - IER = 999 - I01O29 = 999 - RETURN - - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - FUNCTION I02O29(LUNIT,OBS,IER) -C ---> formerly FUNCTION JW3O29 - - COMMON/IO29CC/SUBSET,IDAT10 - - CHARACTER*40 ON85 - CHARACTER*10 CDATE - CHARACTER*8 SUBSET - CHARACTER*6 C01O29 - CHARACTER*4 CDUMP -cvvvvvdak port -cdak DIMENSION OBS(1608),RON85(8),JDATE(5),JDUMP(5) - DIMENSION OBS(1608),RON85(16),JDATE(5),JDUMP(5) -caaaaadak port - EQUIVALENCE (RON85(1),ON85) - - SAVE - -cvvvvvdak port -cdak DATA RON85/' '/ - DATA ON85/' '/ -caaaaadak port - - JDATE = -1 - JDUMP = -1 - -C IF FILE IS CLOSED TRY TO OPEN IT AND RETURN A Y2K COMPLIANT -C PSEUDO-ON85 LABEL -C ----------------------------------------------------------- - - CALL STATUS(LUNIT,LUN,IL,IM) - - IF(IL.EQ.0) THEN - IRET = -1 - I02O29 = 2 - REWIND LUNIT - READ(LUNIT,END=10,ERR=10) ON85 - IF(ON85(1:4).NE.'BUFR') GO TO 10 -cvvvvvy2k - call datelen(10) -caaaaay2k - CALL DUMPBF(LUNIT,JDATE,JDUMP) -cppppp - print *, 'CENTER DATE (JDATE) = ',jdate - print *, 'DUMP DATE (JDUMP) (year not used anywhere) = ',jdump -cppppp -Cvvvvvvvvvvvvvvvvvvvvvvvvvvv - IF(JDATE(1).GT.999) THEN - WRITE(CDATE,'(I4.4,3I2.2)') (JDATE(I),I=1,4) - ELSE IF(JDATE(1).GT.0) THEN - -C If 2-digit year returned in JDATE(1), must use "windowing" technique -C 2 create a 4-digit year - -cvvvvvy2k - PRINT *, '##IW3UNP29/I02O29 - 2-DIGIT YEAR IN JDATE(1) ', - $ 'RETURNED FROM DUMPBF (JDATE IS: ',JDATE,') - USE ', - $ 'WINDWOING TECHNIQUE TO OBTAIN 4-DIGIT YEAR' -caaaaay2k - IF(JDATE(1).GT.20) THEN - WRITE(CDATE,101) (JDATE(I),I=1,4) - 101 FORMAT('19',4I2.2) - ELSE - WRITE(CDATE,102) (JDATE(I),I=1,4) - 102 FORMAT('20',4I2.2) - ENDIF -cvvvvvy2k - PRINT *, '##IW3UNP29/I02O29 - CORRECTED JDATE(1) WITH ', - $ '4-DIGIT YEAR, JDATE NOW IS: ',JDATE -caaaaay2k - ELSE - GO TO 10 - ENDIF - - CALL OPENBF(LUNIT,'IN',LUNIT) - -C This next call, I believe, is needed only because SUBSET is not -C returned in DUMPBF ... - call readmg(lunit,subset,idat10,iret) - - WRITE(CDUMP,'(2I2.2)') JDUMP(4),100*JDUMP(5)/60 - IF(JDUMP(1).LT.0) CDUMP = '9999' - ON85=C01O29(SUBSET)//' C2'//CDATE//CDUMP//'WASHINGTONCR ' -cvvvvvdak port -cdak OBS(1:8) = RON85 - OBS(1:16) = RON85 -caaaaadak port - I02O29 = 1 -Caaaaaaaaaaaaaaaaaaaaaaaaaaa - 10 CONTINUE - IER = I02O29 - RETURN - END IF - -C IF THE FILE IS ALREADY OPENED FOR INPUT TRY TO READ THE NEXT SUBSET -C ------------------------------------------------------------------- - - IF(IL.LT.0) THEN - 7822 CONTINUE - CALL READNS(LUNIT,SUBSET,IDAT10,IRET) - IF(IRET.EQ.0) I02O29 = R01O29(SUBSET,LUNIT,OBS) - IF(IRET.NE.0) I02O29 = 2 - IF(I02O29.EQ.-9999) GO TO 7822 - IER = I02O29 - RETURN - END IF - -C FILE MUST BE OPEN FOR INPUT! -C ---------------------------- - - PRINT *, '##IW3UNP29/I02O29 - FILE ON UNIT ',LUNIT,' IS OPENED ', - $ 'FOR OUTPUT -- IER = 999' - I02O29 = 999 - IER = 999 - RETURN - - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: I03O29 UNPACKS REPORT FROM A TRUE ON29/124 DSET -C PRGMMR: J. S. WOOLLEN ORG: NP20 DATE: 1996-10-04 -C -C ABSTRACT: READS A TRUE (SEE *) ON29/124 DATA SET AND UNPACKS ONE -C REPORT INTO THE UNPACKED OFFICE NOTE 29/124 FORMAT. THE INPUT AND -C OUTPUT ARGUMENTS HERE HAVE THE SAME MEANING AS FOR IW3UNP29. -C REPEATED CALLS OF FUNCTION WILL RETURN A SEQUENCE OF UNPACKED -C ON29/124 REPORTS. * - UNLIKE ORIGINAL "TRUE" ON29/124 DATA SETS, -C THE "EXPECTED" FILE HEADER LABEL IS A Y2K COMPLIANT 40-BYTE -C PSEUDO-ON85 VERSION - IF THIS IS NOT ENCOUNTERED THIS CODE, AS A -C TEMPORARY MEASURE DURING THE Y2K TRANSITION PERIOD, WILL LOOK FOR -C THE ORIGINAL NON-Y2K COMPLIANT 32-BYTE ON85 HEADER LABEL AND USE -C THE "WINDOWING" TECHNIQUE TO CONVERT THE 2-DIGIT YEAR TO A 4-DIGIT -C YEAR IN PREPARATION FOR RETURNING A 40-BYTE PSEUDO-ON85 LABEL IN -C THE FIRST C CALL. (SEE IW3UNP29 DOCBLOCK FOR FORMAT OF 40-BYTE -C PSEUDO-ON85 HEADER LABEL.) -C -C PROGRAM HISTORY LOG: -C 1980-12-01 J.STACKPOLE -- ORIGINAL W3LIB ROUTINE IW3GAD -C 1984-06-26 R.E.JONES -- CONVERT TO VS FORTRAN -C 1991-07-23 D.A.KEYSER -- NOW CALLS W3FI64 (F77); INTERNAL READ ERROR -C NO LONGER CAUSES CALLING PROGRAM TO FAIL BUT WILL MOVE -C TO NEXT RECORD IF CAN'T RECOVER TO NEXT REPORT -C 1993-10-07 D.A.KEYSER -- ADAPTED FOR USE ON CRAY (ADDED SAVE -C STATEMENT, REMOVED IBM-SPECIFIC CODE, ETC.) -C 1993-10-15 R.E.JONES -- ADDED CODE SO IF FILE IS EBCDIC IT CONVERTS -C IT TO ASCII -C 1996-10-04 J.S.WOOLLEN -- CHANGED NAME TO I03GAD AND INCORPORATED -C INTO NEW W3LIB ROUTINE IW3GAD -C -C USAGE: II = I03O29(NUNIT, OBS, IER) -C INPUT ARGUMENT LIST: -C NUNIT - FORTRAN UNIT NUMBER FOR SEQUENTIAL DATA SET CONTAINING -C - PACKED AND BLOCKED OFFICE NOTE 29/124 REPORTS -C -C OUTPUT ARGUMENT LIST: -C OBS - ARRAY CONTAINING ONE REPORT IN UNPACKED OFFICE NOTE -C - 29/124 FORMAT. FORMAT IS MIXED, USER MUST EQUIVALENCE -C - INTEGER AND CHARACTER ARRAYS TO THIS ARRAY (SEE -C - DOCBLOCK FOR W3FI64 IN /nwprod/w3libs/w3lib.source -C - OR WRITEUPS ON W3FI64, ON29, ON124 FOR HELP) -C - THE LENGTH OF THE ARRAY SHOULD BE AT LEAST 1608 -C IER - RETURN FLAG (EQUAL TO FUNCTION VALUE) - SEE REMARKS -C - IN IW3UNP29 DOCBLOCK -C -C INPUT FILES: -C UNIT AA - SEQUENTIAL OFFICE NOTE 29/124 DATA SET ("AA" IS UNIT -C - NUMBER SPECIFIED BY INPUT ARGUMENT "NUNIT") -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY SUBPROGRAM IW3UNP29. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP, CRAY, SGI -C -C$$$ - FUNCTION I03O29(NUNIT, OBS, IER) -C ---> formerly FUNCTION KW3O29 - - CHARACTER*1 CBUFF(6432),CON85L(32) -cvvvvvdak port - CHARACTER*2 CBF910 -caaaaadak port - CHARACTER*4 CYR4D - INTEGER IBUFF(5),OBS(*) - - EQUIVALENCE (IBUFF,CBUFF) - - SAVE - - DATA IOLDUN/0/ - -C TEST FOR NEW (OR PREVIOUSLY USED) NUNIT AND ADJUST 'NEXT' -C (THIS ALLOWS USER TO SWITCH TO NEW NUNIT PRIOR TO READING TO -C THE 'END OF FILE' ON AN OLD UNIT. ANY SWITCH TO A NEW UNIT WILL -C START THE READ AT THE BEGINNING) -C ---------------------------------------------------------------- - - if(nunit.eq.0) then - if(ioldun.gt.0) rewind ioldun - I03O29 = 0 - ioldun = 0 - return - end if - - IF(NUNIT.NE.IOLDUN) THEN - -C THIS IS A NEW UNIT NUMBER, SET 'NEXT' TO 0 AND REWIND THIS UNIT -C --------------------------------------------------------------- - -CDAKCDAK PRINT 87, NUNIT NOW REDUNDANT TO PRINT THIS - 87 FORMAT(//' IW3UNP29/I03O29 - PREPARING TO READ ON29 DATA SET IN ', - $ 'UNIT ',I3/) - IOLDUN = NUNIT - NEXT = 0 - NFILE = 0 - REWIND NUNIT - ISWT = 0 - END IF - - 10 CONTINUE - - IF(NEXT.NE.0) GO TO 70 - -C COME HERE TO READ IN A NEW RECORD (EITHER REPORTS, Y2K COMPLIANT 40- -C BYTE PSEUDO-ON85 LBL, NON-Y2K 32-BYTE COMPLIANT ON85 LBL, OR E-O-F) -C -------------------------------------------------------------------- - - READ(NUNIT,ERR=9998,END=9997) CBUFF - - IF(CBUFF(1)//CBUFF(2)//CBUFF(3)//CBUFF(4).EQ.'BUFR') THEN - -C INPUT DATASET IS JBUFR - EXIT IMMEDIATELY -C ----------------------------------------- - - IOLDUN = 0 - NEXT = 0 - IER = 999 - GO TO 90 - END IF - - -C IF ISWT=1, CHARACTER DATA IN RECORD ARE EBCDIC - CONVERT TO ASCII -C ----------------------------------------------------------------- - - IF(ISWT.EQ.1) CALL AEA(CBUFF,CBUFF,6432) - - IF(NFILE.EQ.0) THEN - -C TEST FOR EXPECTED HEADER LABEL -C ------------------------------ - - NFILE = 1 - - IF(CBUFF(25)//CBUFF(26)//CBUFF(27)//CBUFF(28).EQ.'WASH') THEN - ELSEIF(CBUFF(21)//CBUFF(22)//CBUFF(23)//CBUFF(24).EQ.'WASH')THEN - ELSE - -C QUICK CHECK SHOWS SOMETHING OTHER THAN EITHER Y2K COMPLIANT PSEUDO- -C ON85 LBL OR NON-Y2K COMPLIANT ON85 LBL FOUND -- COULD MEAN CHARACTER -C DATA ARE IN EBCDIC, SO SEE IF CONVERSION TO ASCII RECTIFIES THIS -C --------------------------------------------------------------------- - - PRINT 78 - 78 FORMAT(/' ##IW3UNP29 - NEITHER EXPECTED Y2K COMPLIANT PSEUDO-', - $ 'ON85 LABEL NOR SECOND CHOICE NON-Y2K COMPLIANT ON85 LABEL ', - $ 'FOUND IN'/14X,'FIRST RECORD OF FILE -- TRY EBCDIC TO ASCII ', - $ 'CONVERSION'/) - CALL AEA(CBUFF,CBUFF,6432) - ISWT = 1 - END IF - - IF(CBUFF(25)//CBUFF(26)//CBUFF(27)//CBUFF(28).EQ.'WASH') THEN - -C THIS IS Y2K COMPLIANT 40-BYTE PSEUDO-ON85 LBL; RESET 'NEXT', SET -C 'IER', FILL 'OBS(1)-(4)', AND QUIT -C --------------------------------------------------------------- - NEXT = 0 - IER = 1 -cvvvvvy2k -cdak CALL XMOVEX(OBS,IBUFF,40) - OBS(1:5) = IBUFF(1:5) - GO TO 90 - ELSE IF(CBUFF(21)//CBUFF(22)//CBUFF(23)//CBUFF(24).EQ.'WASH') - $ THEN - -C THIS IS NON-Y2K COMPLIANT 32-BYTE ON85 LBL; RESET 'NEXT', SET -C 'IER', USE "WINDOWING" TECHNIQUE TO CONTRUCT 4-DIGIT YEAR, -C CONSTRUCT A 40-BYTE PSEUDO-ON85 LABE, FILL 'OBS(1)-(4)', AND QUIT -C ------------------------------------------------------------------ - PRINT *, '==> THIS IS A TRUE OFFICE NOTE 29 FILE!! <==' - PRINT 88 - 88 FORMAT(/' ##IW3UNP29/I03O29 - WARNING: ORIGINAL NON-Y2K ', - $ 'COMPLIANT ON85 LABEL FOUND IN FIRST RECORD OF FILE INSTEAD OF ', - $ 'EXPECTED'/30X,'Y2K COMPLIANT PSEUDO-ON85 LABEL -- THIS ', - $ 'ROUTINE IS FORCED TO USE "WINDOWING" TECHNIQUE TO CONTRUCT'/30X, - $'A Y2K COMPLIANT PSEUDO-ON85 LABEL TO RETURN TO CALLING PROGRAM'/) - - NEXT = 0 - IER = 1 - -cvvvvvdak port -cdak READ(CBUFF(9)//CBUFF(10),'(I2)') IYR2D - CBF910 = CBUFF(9)//CBUFF(10) - READ(CBF910,'(I2)') IYR2D -caaaaadak port - PRINT *, '##IW3UNP29/I03O29 - 2-DIGIT YEAR FOUND IN ON85 ', - $ 'LBL (',CBUFF(1:32),') IS: ',IYR2D - PRINT *, ' - USE WINDOWING TECHNIQUE TO ', - $ 'OBTAIN 4-DIGIT YEAR' - IF(IYR2D.GT.20) THEN - IYR4D = 1900 + IYR2D - ELSE - IYR4D = 2000 + IYR2D - ENDIF - PRINT *, '##IW3UNP29/I03O29 - 4-DIGIT YEAR OBTAINED VIA ', - $ 'WINDOWING TECHNIQUE IS: ',IYR4D - PRINT *, ' ' - CON85L = CBUFF(1:32) - CBUFF(7:40) = ' ' - CBUFF(9:10) = CON85L(7:8) - WRITE(CYR4D,'(I4.4)') IYR4D - DO I=1,4 - CBUFF(10+I) = CYR4D(I:I) - ENDDO - CBUFF(15:36) = CON85L(11:32) - OBS(1:5) = IBUFF(1:5) - GO TO 90 -caaaaay2k - ELSE - -C SOMETHING OTHER THAN EITHER Y2K COMPLIANT PSEUDO-ON85 LBL OR -C NON-Y2K COMPLIANT ON85 LBL FOUND; RESET 'NEXT', SET 'IER' AND QUIT -C ------------------------------------------------------------------ -CDAKCDAK PRINT 88 CAN'T PRINT THIS ANYMORE -CDA88 FORMAT(/' ##IW3UNP29/I03O29 - EXPECTED ON85 LABEL NOT FOUND IN ', -CDAK $ 'FIRST RECORD OF NEW LOGICAL FILE -- IER = 999'/) - IOLDUN = 0 - NEXT = 0 - IER = 999 - GO TO 90 - END IF - - END IF - - IF(CBUFF(1)//CBUFF(2)//CBUFF(3)//CBUFF(4).EQ.'ENDO') THEN - -C LOGICAL "ENDOF FILE" READ; RESET NEXT, SET IER, AND QUIT -C -------------------------------------------------------- - - NEXT = 0 - IER = 2 - NFILE = 0 - GO TO 90 - END IF - GO TO 70 - - 9997 CONTINUE - -C PHYSICAL END OF FILE; RESET 'NEXT', SET 'IER' AND QUIT -C ------------------------------------------------------ - - NEXT = 0 - IER = 3 - GO TO 90 - - 9998 CONTINUE - -C I/O ERROR; RESET 'NEXT', SET 'IER' AND QUIT -C ------------------------------------------- - -cppppp - print *, '##IW3UNP29/I03O29 - ERROR READING DATA RECORD' -cppppp - NEXT = 0 - IER = 4 - GO TO 90 - - 70 CONTINUE - -C WORKING WITHIN ACTUAL DATA REC. READ, CALL W3FI64 TO READ IN NEXT RPT -C --------------------------------------------------------------------- - - CALL W3FI64(CBUFF,OBS,NEXT) - - IF(NEXT.GE.0) THEN - -C REPORT SUCCESSFULLY RETURNED IN ARRAY 'OBS' -C ------------------------------------------- - - IER = 0 - - ELSE - -C HIT END-OF-RECORD, OR INTERNAL READ ERROR ENCOUNTERED & CAN'T RECOVER -C -- READ IN NEXT RECORD OF REPORTS -C --------------------------------------------------------------------- - - NEXT = 0 - GO TO 10 - END IF - - 90 CONTINUE - - I03O29 = IER - - RETURN - - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - FUNCTION C01O29(SUBSET) -C ---> formerly FUNCTION ADP - - CHARACTER*(*) SUBSET - CHARACTER*6 C01O29 - - SAVE - - C01O29 = 'NONE' - - IF(SUBSET(1:5).EQ.'NC000') C01O29 = 'ADPSFC' - IF(SUBSET(1:5).EQ.'NC001') THEN - IF(SUBSET(6:8).NE.'006') THEN - C01O29 = 'SFCSHP' - ELSE - C01O29 = 'SFCBOG' - END IF - END IF - IF(SUBSET(1:5).EQ.'NC002') C01O29 = 'ADPUPA' - IF(SUBSET(1:5).EQ.'NC004') C01O29 = 'AIRCFT' - IF(SUBSET(1:5).EQ.'NC005') C01O29 = 'SATWND' - IF(SUBSET(1:5).EQ.'NC012') C01O29 = 'SPSSMI' - - IF(SUBSET .EQ. 'NC003101') C01O29 = 'SATEMP' - IF(SUBSET .EQ. 'NC004004') C01O29 = 'AIRCAR' - IF(SUBSET .EQ. 'NC004005') C01O29 = 'ADPUPA' - - IF(SUBSET .EQ. 'ADPSFC') C01O29 = 'ADPSFC' - IF(SUBSET .EQ. 'SFCSHP') C01O29 = 'SFCSHP' - IF(SUBSET .EQ. 'SFCBOG') C01O29 = 'SFCBOG' - IF(SUBSET .EQ. 'ADPUPA') C01O29 = 'ADPUPA' - IF(SUBSET .EQ. 'AIRCFT') C01O29 = 'AIRCFT' - IF(SUBSET .EQ. 'SATWND') C01O29 = 'SATWND' - IF(SUBSET .EQ. 'SATEMP') C01O29 = 'SATEMP' - IF(SUBSET .EQ. 'AIRCAR') C01O29 = 'AIRCAR' - IF(SUBSET .EQ. 'SPSSMI') C01O29 = 'SPSSMI' - - IF(C01O29.EQ.'NONE') PRINT*,'##IW3UNP29/C01O29 - UNKNOWN SUBSET ', - $ '(=',SUBSET,') -- CONTINUE~~' - - RETURN - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - FUNCTION R01O29(SUBSET,LUNIT,OBS) -C ---> formerly FUNCTION ADC - - CHARACTER*(*) SUBSET - CHARACTER*6 C01O29,ADPSUB - DIMENSION OBS(*) - - SAVE - -C FIND AN ON29/124 DATA TYPE AND CALL A TRANSLATOR -C ------------------------------------------------ - - R01O29 = 4 - ADPSUB = C01O29(SUBSET) - IF(ADPSUB .EQ. 'ADPSFC') R01O29 = R04O29(LUNIT,OBS) - IF(ADPSUB .EQ. 'SFCSHP') R01O29 = R04O29(LUNIT,OBS) - IF(ADPSUB .EQ. 'SFCBOG') R01O29 = R04O29(LUNIT,OBS) - IF(ADPSUB .EQ. 'ADPUPA') R01O29 = R03O29(LUNIT,OBS) - IF(ADPSUB .EQ. 'AIRCFT') R01O29 = R05O29(LUNIT,OBS) - IF(ADPSUB .EQ. 'AIRCAR') R01O29 = R05O29(LUNIT,OBS) - IF(ADPSUB .EQ. 'SATWND') R01O29 = R06O29(LUNIT,OBS) - IF(ADPSUB .EQ. 'SPSSMI') R01O29 = R07O29(LUNIT,OBS) - RETURN - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - SUBROUTINE S01O29(SID,XOB,YOB,RHR,RCH,RSV,RSV2,ELV,ITP,RTP) -C ---> Formerly SUBROUTINE O29HDR - - COMMON/IO29DD/HDR(12),RCATS(50,150,11),IKAT(11),MCAT(11),NCAT(11) - - CHARACTER*(*) RSV,RSV2 -cvvvvvdak port -cdak CHARACTER*8 SID,RCT,CHDR(12) - CHARACTER*8 COB,SID,RCT - DIMENSION IHDR(12),RHDR(12),ICATS(50,150,11) -cdak EQUIVALENCE (CHDR(1),IHDR(1),RHDR(1)) - EQUIVALENCE (IHDR(1),RHDR(1)),(COB,IOB),(ICATS,RCATS) -caaaaadak port - - SAVE - -cvvvvvdak port -cdak DATA BLANK/' '/,OMISS/99999/,BMISS/10E10/ - DATA OMISS/99999/,BMISS/10E10/ -caaaaadak port - -C INITIALIZE THE UNPACK ARRAY TO MISSINGS -C --------------------------------------- - - NCAT = 0 - RCATS = OMISS -cvvvvvdak port - COB = ' ' -cdak RCATS(6,1:149,1) = BLANK -cdak RCATS(4,1:149,2) = BLANK -cdak RCATS(4,1:149,3) = BLANK -cdak RCATS(4,1:149,4) = BLANK -cdak RCATS(6,1:149,5) = BLANK -cdak RCATS(6,1:149,6) = BLANK -cdak RCATS(3,1:149,7) = BLANK -cdak RCATS(3,1:149,8) = BLANK - ICATS(6,1:149,1) = IOB - ICATS(4,1:149,2) = IOB - ICATS(4,1:149,3) = IOB - ICATS(4,1:149,4) = IOB - ICATS(6,1:149,5) = IOB - ICATS(6,1:149,6) = IOB - ICATS(3,1:149,7) = IOB - ICATS(3,1:149,8) = IOB -caaaaadak port - -C WRITE THE RECEIPT TIME IN CHARACTERS -C ------------------------------------ - - RCT = '9999 ' - IF(RCH*100.LT.2401.AND.RCH*100.GT.-1) - $ WRITE(RCT,'(I4.4)') NINT(RCH*100.) - -C STORE THE ON29 HEADER INFORMATION INTO UNP FORMAT -C ------------------------------------------------- - - RHDR( 1) = OMISS - IF(YOB.LT.BMISS) RHDR( 1) = NINT(100.*YOB) -cppppp - IF(YOB.GE.BMISS) print *, '~~IW3UNP29/S01O29: ID ',sid,' has a ', - $ 'missing LATITUDE - on29 hdr, word 1 is set to ',RHDR(1) -cppppp - RHDR( 2) = OMISS - IF(XOB.LT.BMISS) RHDR( 2) = NINT(100.*MOD(720.-XOB,360.)) -cppppp - IF(XOB.GE.BMISS) print *, '~~IW3UNP29/S01O29: ID ',sid,' has a ', - $ 'missing LONGITUDE - on29 hdr, word 2 is set to ',RHDR(2) -cppppp - RHDR( 3) = OMISS - RHDR( 4) = OMISS -cvvvvvdak port -cdak IF(RHR.LT.BMISS) RHDR( 4) = NINT((100.*RHR)+0.0000001) - IF(RHR.LT.BMISS) RHDR( 4) = NINT((100.*RHR)+0.0001) -caaaaadak port -cppppp - IF(RHR.GE.BMISS) print *, '~~IW3UNP29/S01O29: ID ',sid,' has a ', - $ 'missing OB TIME - on29 hdr, word 4 is set to ',RHDR(4) -cppppp - IF(RSV2.EQ.' ') THEN -cvvvvvdak port - COB = ' ' - COB(1:4) = RCT(3:4)//RSV(1:2) - IHDR(5) = IOB -cdak CHDR( 5) = RCT(3:4)//RSV(1:2) - COB = ' ' - COB(1:3) = RCT(1:2)//RSV(3:3) - IHDR(6) = IOB -cdak CHDR( 6) = RCT(1:2)//RSV(3:3) - ELSE - COB = ' ' - COB(1:4) = RSV2(3:4)//RSV(1:2) - IHDR(5) = IOB -cdak CHDR( 5) = RSV2(3:4)//RSV(1:2) - COB = ' ' - COB(1:3) = RSV2(1:2)//RSV(3:3) - IHDR(6) = IOB -cdak CHDR( 6) = RSV2(1:2)//RSV(3:3) -caaaaadak port - END IF - RHDR( 7) = NINT(ELV) - IHDR( 8) = ITP - IHDR( 9) = RTP - RHDR(10) = OMISS -cvvvvvdak port - COB = ' ' - COB(1:4) = SID(1:4) - IHDR(11) = IOB -cdak CHDR(11) = SID(1:4) - COB = ' ' - COB(1:4) = SID(5:6)//' ' - IHDR(12) = IOB -cdak CHDR(12) = SID(5:6)//' ' -caaaaadak port - -C STORE THE HEADER INTO A HOLDING ARRAY -C ------------------------------------- - - HDR = RHDR - - RETURN - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - SUBROUTINE S02O29(ICAT,N,*) -C ---> Formerly SUBROUTINE O29CAT - - COMMON/IO29DD/HDR(12),RCATS(50,150,11),IKAT(11),MCAT(11),NCAT(11) - COMMON/IO29EE/POB(255),QOB(255),TOB(255),ZOB(255),DOB(255), - $ SOB(255),VSG(255),CLP(255),CLA(255),OB8(255), - $ CF8(255) - COMMON/IO29FF/PQM(255),QQM(255),TQM(255),ZQM(255),WQM(255), - $ QCP(255),QCA(255),Q81(255),Q82(255) - COMMON/IO29GG/PSL,STP,SDR,SSP,STM,DPD,TMX,TMI,HVZ,PRW,PW1,CCN,CHN, - $ CTL,CTM,CTH,HCB,CPT,APT,PC6,SND,P24,DOP,POW,HOW,SWD, - $ SWP,SWH,SST,SPG,SPD,SHC,SAS,WES - COMMON/IO29HH/PSQ,SPQ,SWQ,STQ,DDQ - COMMON/IO29II/PWMIN - -cvvvvvdak port -cdak CHARACTER*8 CCAT(50),C11,C12 - CHARACTER*8 COB,C11,C12 -caaaaadak port - CHARACTER*1 PQM,QQM,TQM,ZQM,WQM,QCP,QCA,Q81,Q82,PSQ,SPQ,SWQ,STQ, - $ DDQ - DIMENSION RCAT(50),JCAT(50) -cvvvvvdak port -cdak EQUIVALENCE (RCAT(1),CCAT(1),JCAT(1)),(C11,HDR(11)),(C12,HDR(12)) - EQUIVALENCE (RCAT(1),JCAT(1)),(C11,HDR(11)),(C12,HDR(12)), - $ (COB,IOB) -caaaaadak port - LOGICAL SURF - - SAVE - - DATA BMISS/10E10/ - -cppppp-ID - iprint = 0 -c if(C11(1:4)//C12(1:2).eq.'59758 ') iprint = 1 -c if(C11(1:4)//C12(1:2).eq.'59362 ') iprint = 1 -c if(C11(1:4)//C12(1:2).eq.'57957 ') iprint = 1 -c if(C11(1:4)//C12(1:2).eq.'74794 ') iprint = 1 -c if(C11(1:4)//C12(1:2).eq.'74389 ') iprint = 1 -c if(C11(1:4)//C12(1:2).eq.'96801A') iprint = 1 -cppppp-ID - - SURF = .FALSE. - GOTO 1 - -C ENTRY POINT SE01O29 FORCES DATA INTO THE SURFACE (FIRST) LEVEL -C -------------------------------------------------------------- - - ENTRY SE01O29(ICAT,N) -C ---> formerly ENTRY O29SFC - SURF = .TRUE. - -C CHECK THE PARAMETERS COMING IN -C ------------------------------ - -1 KCAT = 0 - DO I = 1,11 - IF(ICAT.EQ.IKAT(I)) THEN - KCAT = I - GO TO 991 - END IF - ENDDO - - 991 CONTINUE - -C PARAMETER ICAT (ON29 CATEGORY) OUT OF BOUNDS RETURNS A 999 -C ---------------------------------------------------------- - - IF(KCAT.EQ.0) THEN - PRINT *, '##IW3UNP29/S02O29 - ON29 CATEGORY ',ICAT,' OUT OF ', - $ 'BOUNDS -- IER = 999' - RETURN 1 - END IF - -C PARAMETER N (LEVEL INDEX) OUT OF BOUNDS RETURNS A 999 -C ----------------------------------------------------- - - IF(N.GT.255) THEN - PRINT *, '##IW3UNP29/S02O29 - LEVEL INDEX ',N,' EXCEEDS 255 ', - $ '-- IER = 999' - RETURN 1 - END IF - -C MAKE A MISSING LEVEL AND RETURN WHEN N=0 (NOT ALLOWED FOR CAT 01) -C ----------------------------------------------------------------- - - IF(N.EQ.0) THEN - IF(KCAT.EQ.1) RETURN - NCAT(KCAT) = MIN(149,NCAT(KCAT)+1) -cppppp - if(iprint.eq.1) - $ print *, 'To prepare for sfc. data, write all missings on ', - $ 'lvl ',ncat(kcat),' for cat ',kcat -cppppp - RETURN - END IF - -C FIGURE OUT WHICH LEVEL TO UPDATE AND RESET THE LEVEL COUNTER -C ------------------------------------------------------------ - - IF(KCAT.EQ.1) THEN - L = I04O29(POB(N)*.1) - IF(L.EQ.999999) GO TO 9999 - -C BAD MANDATORY LEVEL RETURNS A 999 -C --------------------------------- - - IF(L.LE.0) THEN - PRINT *, '##IW3UNP29/S02O29 - BAD MANDATORY LEVEL (P = ', - $ POB(N),') -- IER = 999' - RETURN 1 - END IF - NCAT(KCAT) = MAX(NCAT(KCAT),L) -cppppp - if(iprint.eq.1) - $ print *, 'Will write cat. 1 data on lvl ',L,' for cat ',kcat, - $ ', - total no. cat. 1 lvls processed so far = ',ncat(kcat) -cppppp - ELSEIF(SURF) THEN - L = 1 - NCAT(KCAT) = MAX(NCAT(KCAT),1) -cppppp - if(iprint.eq.1) - $ print *, 'Will write cat. ',kcat,' SURFACE data on lvl ',L, - $ ', - total no. cat. ',kcat,' lvls processed so far = ', - $ ncat(kcat) -cppppp - ELSE - L = MIN(149,NCAT(KCAT)+1) - IF(L.EQ.149) THEN -cppppp - print *, '~~IW3UNP29/S02O29: ID ',c11(1:4)//c12(1:2), - $ ' - This cat. ',kcat,', level cannot be processed because ', - $ 'the limit has already been reached' -cppppp - RETURN - END IF - NCAT(KCAT) = L -cppppp - if(iprint.eq.1) - $ print *, 'Will write cat. ',kcat,' NON-SFC data on lvl ',L, - $ ', - total no. cat. ',kcat,' lvls processed so far = ', - $ ncat(kcat) -cppppp - END IF - -C EACH CATEGORY NEEDS A SPECIFIC DATA ARRANGEMENT -C ----------------------------------------------- - -cvvvvvdak port - COB = ' ' -caaaaadak port - IF(ICAT.EQ.1) THEN - RCAT(1) = MIN(NINT(ZOB(N)),NINT(RCATS(1,L,KCAT))) - RCAT(2) = MIN(NINT(TOB(N)),NINT(RCATS(2,L,KCAT))) - RCAT(3) = MIN(NINT(QOB(N)),NINT(RCATS(3,L,KCAT))) - RCAT(4) = MIN(NINT(DOB(N)),NINT(RCATS(4,L,KCAT))) - RCAT(5) = MIN(NINT(SOB(N)),NINT(RCATS(5,L,KCAT))) -cvvvvvdak port - COB(1:4) = ZQM(N)//TQM(N)//QQM(N)//WQM(N) - JCAT(6) = IOB -cdak CCAT(6) = ZQM(N)//TQM(N)//QQM(N)//WQM(N) -caaaaadak port - ELSEIF(ICAT.EQ.2) THEN - RCAT(1) = MIN(NINT(POB(N)),99999) - RCAT(2) = MIN(NINT(TOB(N)),99999) - RCAT(3) = MIN(NINT(QOB(N)),99999) -cvvvvvdak port - COB(1:3) = PQM(N)//TQM(N)//QQM(N) - JCAT(4) = IOB -cdak CCAT(4) = PQM(N)//TQM(N)//QQM(N) -caaaaadak port - ELSEIF(ICAT.EQ.3) THEN - RCAT(1) = MIN(NINT(POB(N)),99999) - RCAT(2) = MIN(NINT(DOB(N)),99999) - RCAT(3) = MIN(NINT(SOB(N)),99999) - -C MARK THE TROPOPAUSE LEVEL IN CAT. 3 - - IF(NINT(VSG(N)).EQ.16) PQM(N) = 'T' - -C MARK THE MAXIMUM WIND LEVEL IN CAT. 3 - - IF(NINT(VSG(N)).EQ. 8) THEN - PQM(N) = 'W' - IF(POB(N).EQ.PWMIN) PQM(N) = 'X' - END IF -cvvvvvdak port - COB(1:2) = PQM(N)//WQM(N) - JCAT(4) = IOB -cdak CCAT(4) = PQM(N)//WQM(N) -caaaaadak port - ELSEIF(ICAT.EQ.4) THEN - RCAT(1) = MIN(NINT(ZOB(N)),99999) - RCAT(2) = MIN(NINT(DOB(N)),99999) - RCAT(3) = MIN(NINT(SOB(N)),99999) -cvvvvvdak port - COB(1:2) = ZQM(N)//WQM(N) - JCAT(4) = IOB -cdak CCAT(4) = ZQM(N)//WQM(N) -caaaaadak port - ELSEIF(ICAT.EQ.5) THEN - RCAT(1) = MIN(NINT(POB(N)),99999) - RCAT(2) = MIN(NINT(TOB(N)),99999) - RCAT(3) = MIN(NINT(QOB(N)),99999) - RCAT(4) = MIN(NINT(DOB(N)),99999) - RCAT(5) = MIN(NINT(SOB(N)),99999) -cvvvvvdak port - COB(1:4) = PQM(N)//TQM(N)//QQM(N)//WQM(N) - JCAT(6) = IOB -cdak CCAT(6) = PQM(N)//TQM(N)//QQM(N)//WQM(N) -caaaaadak port - ELSEIF(ICAT.EQ.6) THEN - RCAT(1) = MIN(NINT(ZOB(N)),99999) - RCAT(2) = MIN(NINT(TOB(N)),99999) - RCAT(3) = MIN(NINT(QOB(N)),99999) - RCAT(4) = MIN(NINT(DOB(N)),99999) - RCAT(5) = MIN(NINT(SOB(N)),99999) -cvvvvvdak port - COB(1:4) = ZQM(N)//TQM(N)//QQM(N)//WQM(N) - JCAT(6) = IOB -cdak CCAT(6) = ZQM(N)//TQM(N)//QQM(N)//WQM(N) -caaaaadak port - ELSEIF(ICAT.EQ.7) THEN - RCAT(1) = MIN(NINT(CLP(N)),99999) - RCAT(2) = MIN(NINT(CLA(N)),99999) -cvvvvvdak port - COB(1:2) = QCP(N)//QCA(N) - JCAT(3) = IOB -cdak CCAT(3) = QCP(N)//QCA(N) -caaaaadak port - ELSEIF(ICAT.EQ.8) THEN - RCAT(1) = MIN(NINT(OB8(N)),99999) - RCAT(2) = MIN(NINT(CF8(N)),99999) -cvvvvvdak port - COB(1:2) = Q81(N)//Q82(N) - JCAT(3) = IOB -cdak CCAT(3) = Q81(N)//Q82(N) -caaaaadak port - ELSEIF(ICAT.EQ.51) THEN - RCAT( 1) = MIN(NINT(PSL),99999) - RCAT( 2) = MIN(NINT(STP),99999) - RCAT( 3) = MIN(NINT(SDR),99999) - RCAT( 4) = MIN(NINT(SSP),99999) - RCAT( 5) = MIN(NINT(STM),99999) - RCAT( 6) = MIN(NINT(DPD),99999) - RCAT( 7) = MIN(NINT(TMX),99999) - RCAT( 8) = MIN(NINT(TMI),99999) -cvvvvvdak port - COB(1:4) = PSQ//SPQ//SWQ//STQ - JCAT(9) = IOB -cdak CCAT( 9) = PSQ//SPQ//SWQ//STQ - COB = ' ' - COB(1:1) = DDQ - JCAT(10) = IOB -cdak CCAT(10) = DDQ -caaaaadak port - JCAT(11) = MIN(NINT(HVZ),99999) - JCAT(12) = MIN(NINT(PRW),99999) - JCAT(13) = MIN(NINT(PW1),99999) - JCAT(14) = MIN(NINT(CCN),99999) - JCAT(15) = MIN(NINT(CHN),99999) - JCAT(16) = MIN(NINT(CTL),99999) - JCAT(17) = MIN(NINT(HCB),99999) - JCAT(18) = MIN(NINT(CTM),99999) - JCAT(19) = MIN(NINT(CTH),99999) - JCAT(20) = MIN(NINT(CPT),99999) -cvvvvvdak port -cdak RCAT(21) = MIN(IABS(NINT(APT)),99999) - RCAT(21) = MIN(ABS(NINT(APT)),99999) -caaaaadak port - IF(CPT.GE.BMISS.AND.APT.LT.0.) -cvvvvvdak port -cdak $ RCAT(21) = MIN(IABS(NINT(APT))+500,99999) - $ RCAT(21) = MIN(ABS(NINT(APT))+500,99999) -caaaaadak port - ELSEIF(ICAT.EQ.52) THEN - JCAT( 1) = MIN(NINT(PC6),99999) - JCAT( 2) = MIN(NINT(SND),99999) - JCAT( 3) = MIN(NINT(P24),99999) - JCAT( 4) = MIN(NINT(DOP),99999) - JCAT( 5) = MIN(NINT(POW),99999) - JCAT( 6) = MIN(NINT(HOW),99999) - JCAT( 7) = MIN(NINT(SWD),99999) - JCAT( 8) = MIN(NINT(SWP),99999) - JCAT( 9) = MIN(NINT(SWH),99999) - JCAT(10) = MIN(NINT(SST),99999) - JCAT(11) = MIN(NINT(SPG),99999) - JCAT(12) = MIN(NINT(SPD),99999) - JCAT(13) = MIN(NINT(SHC),99999) - JCAT(14) = MIN(NINT(SAS),99999) - JCAT(15) = MIN(NINT(WES),99999) - ELSE - -C UNSUPPORTED CATEGORY RETURNS A 999 -C ---------------------------------- - - PRINT *, '##IW3UNP29/S02O29 - CATEGORY ',ICAT,' NOT SUPPORTED', - $ ' -- IER = 999' - RETURN 1 - END IF - -C TRANSFER THE LEVEL DATA INTO THE HOLDING ARRAY AND EXIT -C ------------------------------------------------------- - - DO I = 1,MCAT(KCAT) - RCATS(I,L,KCAT) = RCAT(I) - ENDDO - - RETURN - 9999 CONTINUE - RETURN 1 - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - SUBROUTINE S03O29(UNP,SUBSET,*,*) -C ---> Formerly SUBROUTINE O29UNP - - COMMON/IO29DD/HDR(12),RCATS(50,150,11),IKAT(11),MCAT(11),NCAT(11) - - DIMENSION RCAT(50),JCAT(50),UNP(*) - CHARACTER*8 SUBSET - EQUIVALENCE (RCAT(1),JCAT(1)) - - SAVE - -C CALL TO SORT CATEGORIES 02, 03, 04, AND 08 LEVELS -C ------------------------------------------------- - - CALL S04O29 - -C TRANSFER DATA FROM ALL CATEGORIES INTO UNP ARRAY & SET POINTERS -C --------------------------------------------------------------- - - INDX = 43 - JCAT = 0 - NLEVTO = 0 - NLEVC8 = 0 - - DO K = 1,11 - JCAT(2*K+11) = NCAT(K) - IF(K.NE.7.AND.K.NE.8.AND.K.NE.11) THEN - NLEVTO = NLEVTO + NCAT(K) - ELSE IF(K.EQ.8) THEN - NLEVC8 = NLEVC8 + NCAT(K) - END IF - IF(NCAT(K).GT.0) JCAT(2*K+12) = INDX - IF(NCAT(K).EQ.0) JCAT(2*K+12) = 0 - DO J = 1,NCAT(K) - DO I = 1,MCAT(K) - -C UNPACKED ON29 REPORT CONTAINS MORE THAN 1608 WORDS - RETURNS A 999 -C ------------------------------------------------------------------ - - IF(INDX.GT.1608) THEN - PRINT *, '##IW3UNP29/S03O29 - UNPKED ON29 RPT CONTAINS ', - $ INDX,' WORDS, > LIMIT OF 1608 -- IER = 999' - RETURN 1 - END IF - UNP(INDX) = RCATS(I,J,K) - INDX = INDX+1 - ENDDO - ENDDO - ENDDO - -C RETURN WITHOUT PROCESSING THIS REPORT IF NO DATA IN CAT. 1-6, 51, 52 -C (UNLESS SSM/I REPORT, THEN DO NOT RETURN UNLESS ALSO NO CAT. 8 DATA) -C -------------------------------------------------------------------- - - IF(NLEVTO.EQ.0) THEN - IF(SUBSET(1:5).NE.'NC012') THEN - RETURN 2 - ELSE - IF(NLEVC8.EQ.0) RETURN 2 - END IF - END IF - -C TRANSFER THE HEADER AND POINTER ARRAYS INTO UNP -C ----------------------------------------------- - -cvvvvvy2k -cdak CALL XMOVEX(UNP(1), HDR(1), 12*8) - UNP(1:12) = HDR -cdak CALL XMOVEX(UNP(13),RCAT(13),30*8) - UNP(13:42) = RCAT(13:42) -caaaaay2k - - RETURN - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - SUBROUTINE S04O29 -C ---> Formerly SUBROUTINE O29SRT - - COMMON/IO29DD/HDR(12),RCATS(50,150,11),IKAT(11),MCAT(11),NCAT(11) -cppppp - character*8 c11,c12,sid -cppppp - - DIMENSION RCAT(50,150),IORD(150),IWORK(65536),SCAT(50,150),RCTL(3) -cppppp - EQUIVALENCE (C11,HDR(11)),(C12,HDR(12)) -cppppp - - SAVE - -cppppp - sid = c11(1:4)//c12(1:4) -cppppp - -C SORT CATEGORIES 2, 3, AND 4 - LEAVE THE FIRST LEVEL IN EACH INTACT -C ------------------------------------------------------------------ - - DO K=2,4 - IF(NCAT(K).GT.1) THEN - DO J=1,NCAT(K)-1 - DO I=1,MCAT(K) - SCAT(I,J) = RCATS(I,J+1,K) - ENDDO - ENDDO - CALL ORDERS(2,IWORK,SCAT(1,1),IORD,NCAT(K)-1,50,8,2) - RCTL = 10E9 - DO J=1,NCAT(K)-1 - IF(K.LT.4) JJ = IORD((NCAT(K)-1)-J+1) - IF(K.EQ.4) JJ = IORD(J) - DO I=1,MCAT(K) - RCAT(I,J) = SCAT(I,JJ) - ENDDO - IDUP = 0 - IF(NINT(RCAT(1,J)).EQ.NINT(RCTL(1))) THEN - IF(NINT(RCAT(2,J)).EQ.NINT(RCTL(2)).AND. - $ NINT(RCAT(3,J)).EQ.NINT(RCTL(3))) THEN -cppppp - if(k.ne.4) then - print *,'~~@@IW3UNP29/S04O29: ID ',sid,' has a', - $ ' dupl. cat. ',k,' lvl (all data) at ',rcat(1,j)*.1,' mb -- lvl', - $ ' will be excluded from processing' - else - print *,'~~@@IW3UNP29/S04O29: ID ',sid,' has a', - $ ' dupl. cat. ',k,' lvl (all data) at ',rcat(1,j),' m -- lvl', - $ ' will be excluded from processing' - end if -cppppp - IDUP = 1 - ELSE -cppppp - if(k.ne.4) then - print *,'~~@@#IW3UNP29/S04O29: ID ',sid,' has ', - $ 'a dupl. cat. ',k,' press. lvl (data differ) at ',rcat(1,j)*.1, - $ ' mb -- lvl will NOT be excluded' - else - print *,'~~@@#IW3UNP29/S04O29: ID ',sid,' has ', - $ 'a dupl. cat. ',k,' height lvl (data differ) at ',rcat(1,j), - $ ' m -- lvl will NOT be excluded' - end if -cppppp - END IF - END IF -cvvvvvy2k -cdak CALL XMOVEX(RCTL,RCAT(1,J),3*8) - RCTL = RCAT(1:3,J) -caaaaay2k - IF(IDUP.EQ.1) RCAT(1,J) = 10E8 - ENDDO - JJJ = 1 - DO J=2,NCAT(K) - IF(RCAT(1,J-1).GE.10E8) GO TO 887 - JJJ = JJJ + 1 - DO I=1,MCAT(K) - RCATS(I,JJJ,K) = RCAT(I,J-1) - ENDDO - 887 CONTINUE - ENDDO -cppppp - if(jjj.ne.NCAT(K)) - $ print *,'~~@@IW3UNP29/S04O29: ID ',sid,' has had ', - $ NCAT(K)-jjj,' lvls removed due to their being duplicates' -cppppp - ncat(k) = jjj - end if - IF(NCAT(K).EQ.1) THEN -cvvvvvdak port -cdak IF(AMIN1(RCATS(1,1,K),RCATS(2,1,K),RCATS(3,1,K)).GT.99998.8) - IF(MIN(RCATS(1,1,K),RCATS(2,1,K),RCATS(3,1,K)).GT.99998.8) -caaaaadak port - $ NCAT(K) = 0 - END IF - ENDDO - -C SORT CATEGORY 08 BY CODE FIGURE -C ------------------------------- - - DO K=8,8 - IF(NCAT(K).GT.1) THEN - CALL ORDERS(2,IWORK,RCATS(2,1,K),IORD,NCAT(K),50,8,2) - DO J=1,NCAT(K) - DO I=1,MCAT(K) - RCAT(I,J) = RCATS(I,IORD(J),K) - ENDDO - ENDDO - DO J=1,NCAT(K) - DO I=1,MCAT(K) - RCATS(I,J,K) = RCAT(I,J) - ENDDO - ENDDO - END IF - ENDDO - -C NORMAL EXIT -C ----------- - - RETURN - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - SUBROUTINE S05O29 -C ---> Formerly SUBROUTINE O29INX - - COMMON/IO29EE/OBS(255,11) - COMMON/IO29FF/QMS(255,9) - COMMON/IO29GG/SFO(34) - COMMON/IO29HH/SFQ(5) - - CHARACTER*1 QMS,SFQ -cvvvvvdak port -cdak CHARACTER*1 BLANK - CHARACTER*1 CBLANK - -caaaaadak port - - SAVE - -cvvvvvdak port -cdak DATA BMISS/10E10/,BLANK/' '/ - DATA BMISS/10E10/,CBLANK/' '/ -caaaaadak port - -C SET THE INPUT DATA ARRAYS TO MISSING OR BLANK -C --------------------------------------------- - - OBS = BMISS -cvvvvvdak port - QMS = CBLANK -caaaaadak port - SFO = BMISS -cvvvvvdak port - SFQ = CBLANK -caaaaadak port - - RETURN - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - FUNCTION I04O29(P) -C ---> formerly FUNCTION MANO29 - - COMMON/IO29JJ/ISET,MANLIN(1001) - - SAVE - - IF(ISET.EQ.0) THEN -cvvvvvy2k -cdak CALL XSTORE(MANLIN,0,1001) - MANLIN = 0 -caaaaay2k - - MANLIN(1000) = 1 - MANLIN(850) = 2 - MANLIN(700) = 3 - MANLIN(500) = 4 - MANLIN(400) = 5 - MANLIN(300) = 6 - MANLIN(250) = 7 - MANLIN(200) = 8 - MANLIN(150) = 9 - MANLIN(100) = 10 - MANLIN(70) = 11 - MANLIN(50) = 12 - MANLIN(30) = 13 - MANLIN(20) = 14 - MANLIN(10) = 15 - MANLIN(7) = 16 - MANLIN(5) = 17 - MANLIN(3) = 18 - MANLIN(2) = 19 - MANLIN(1) = 20 - - ISET = 1 - END IF - - IP = NINT(P*10.) - - IF(IP.GT.10000 .OR. IP.LT.10 .OR. MOD(IP,10).NE.0) THEN - I04O29 = 0 - ELSE - I04O29 = MANLIN(IP/10) - END IF - - RETURN - - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - FUNCTION R02O29() -C ---> formerly FUNCTION ONFUN - - CHARACTER*8 SUBSET,RPID - LOGICAL L02O29,L03O29 - INTEGER KKK(0:99),KKKK(49) - - SAVE - - DATA GRAV/9.8/,CM2K/1.94/,TZRO/273.15/,BMISS/10E10/ - DATA KKK /5*90,16*91,30*92,49*93/ - DATA KKKK/94,2*95,6*96,10*97,30*98/ - - PRS1(Z) = 1013.25 * (((288.15 - (.0065 * Z))/288.15)**5.256) - PRS2(Z) = 226.3 * EXP(1.576106E-4 * (11000. - Z)) - PRS3(PMND,TEMP,Z,ZMND) - $ = PMND * (((TEMP - (.0065 * (Z - ZMND)))/TEMP)**5.256) - ES(T) = 6.1078 * EXP((17.269 * (T-273.16))/((T-273.16)+237.3)) - QFRMTP(T,PPPP) = (0.622 * ES(T))/(PPPP-(0.378 * ES(T))) - HGTF(P) = (1.-(P/1013.25)**(1./5.256))*(288.15/.0065) - - R02O29 = 0 - - RETURN - - ENTRY E01O29(PRS) -C ---> formerly ENTRY ONPRS - IF(PRS.LT.BMISS) E01O29 = NINT(PRS*.1) - IF(PRS.GE.BMISS) E01O29 = BMISS - RETURN - ENTRY E37O29(PMND,TEMP,HGT,ZMND,TQM) -C ---> formerly ENTRY ONPFHT - IF(HGT.GE.BMISS) THEN - E37O29 = BMISS - ELSE - IF(HGT.LE.11000) THEN - P = PRS1(HGT) - ELSE - P = PRS2(HGT) - END IF -cvvvvvdak port -cdak IF(AMAX1(PMND,ZMND).GE.BMISS) THEN - IF(MAX(PMND,ZMND).GE.BMISS) THEN -caaaaadak port - E37O29 = P - RETURN - END IF - IF(TEMP.GE.9999.) TEMP = BMISS - IF(TQM.GE.BMISS) TQM = 2 - IF(TEMP.GE.BMISS.OR.TQM.GE.4) CALL W3FA03(P,D1,TEMP,D2) - Q = QFRMTP(TEMP,P) - TVIRT = TEMP * (1.0 + (0.61 * Q)) - E37O29 = PRS3(PMND,TVIRT,HGT,ZMND) - END IF - RETURN - ENTRY E03O29(PRS) -C ---> formerly ENTRY ONHFP - IF(PRS.LT.BMISS) E03O29 = HGTF(PRS) - IF(PRS.GE.BMISS) E03O29 = BMISS - RETURN - ENTRY E04O29(WDR,WSP) -C ---> formerly ENTRY ONWDR - E04O29 = WDR - RETURN - ENTRY E05O29(WDR,WSP) -C ---> formerly ENTRY ONWSP - IF(WSP.LT.BMISS) THEN - E05O29 = (WSP*CM2K) - E05O29 = E05O29 + 0.0000001 - ELSE - E05O29 = BMISS - END IF - RETURN - ENTRY E06O29(TMP) -C ---> formerly ENTRY ONTMP - ITMP = NINT(TMP*100.) - ITZRO = NINT(TZRO*100.) - IF(TMP.LT.BMISS) E06O29 = NINT((ITMP - ITZRO)*0.1) - IF(TMP.GE.BMISS) E06O29 = BMISS - RETURN - ENTRY E07O29(DPD,TMP) -C ---> formerly ENTRY ONDPD - IF(DPD.LT.BMISS .AND. TMP.LT.BMISS) E07O29 = (TMP-DPD)*10. - IF(DPD.GE.BMISS .OR. TMP.GE.BMISS) E07O29 = BMISS - RETURN - ENTRY E08O29(HGT) -C ---> formerly ENTRY ONHGT - E08O29 = HGT - IF(HGT.LT.BMISS) E08O29 = (HGT/GRAV) - RETURN - ENTRY E09O29(HVZ) -C ---> formerly ENTRY ONHVZ - IF(HVZ.GE.BMISS.OR.HVZ.LT.0.) THEN - E09O29 = BMISS - ELSE IF(NINT(HVZ).LT.6000) THEN - E09O29 = MIN(INT(NINT(HVZ)/100),50) - ELSE IF(NINT(HVZ).LT.30000) THEN - E09O29 = INT(NINT(HVZ)/1000) + 50 - ELSE IF(NINT(HVZ).LE.70000) THEN - E09O29 = INT(NINT(HVZ)/5000) + 74 - ELSE - E09O29 = 89 - END IF - RETURN - ENTRY E10O29(PRW) -C ---> formerly ENTRY ONPRW - E10O29 = BMISS - IF(PRW.LT.BMISS) E10O29 = NINT(MOD(PRW,100.)) - RETURN - ENTRY E11O29(PAW) -C ---> formerly ENTRY ONPAW - E11O29 = BMISS - IF(PAW.LT.BMISS) E11O29 = NINT(MOD(PAW,10.)) - RETURN - ENTRY E12O29(CCN) -C ---> formerly ENTRY ONCCN - IF(NINT(CCN).EQ.0) THEN - E12O29 = 0 - ELSE IF(CCN.LT. 15) THEN - E12O29 = 1 - ELSE IF(CCN.LT. 35) THEN - E12O29 = 2 - ELSE IF(CCN.LT. 45) THEN - E12O29 = 3 - ELSE IF(CCN.LT. 55) THEN - E12O29 = 4 - ELSE IF(CCN.LT. 65) THEN - E12O29 = 5 - ELSE IF(CCN.LT. 85) THEN - E12O29 = 6 - ELSE IF(CCN.LT.100) THEN - E12O29 = 7 - ELSE IF(NINT(CCN).EQ.100) THEN - E12O29 = 8 - ELSE - E12O29 = BMISS - END IF - RETURN - ENTRY E13O29(CLA) -C ---> formerly ENTRY ONCLA - E13O29 = BMISS - IF(CLA.EQ.0) E13O29 = 0 - IF(CLA.EQ.1) E13O29 = 5 - IF(CLA.EQ.2) E13O29 = 25 - IF(CLA.EQ.3) E13O29 = 40 - IF(CLA.EQ.4) E13O29 = 50 - IF(CLA.EQ.5) E13O29 = 60 - IF(CLA.EQ.6) E13O29 = 75 - IF(CLA.EQ.7) E13O29 = 95 - IF(CLA.EQ.8) E13O29 = 100 - RETURN - ENTRY E14O29(CCL,CCM) -C ---> formerly ENTRY ONCHN - E14O29 = CCL - IF(NINT(E14O29).EQ.0) E14O29 = CCM - IF(NINT(E14O29).LT.10) RETURN - IF(NINT(E14O29).EQ.10) THEN - E14O29 = 9. - ELSE IF(NINT(E14O29).EQ.15) THEN - E14O29 = 10. - ELSE - E14O29 = BMISS - END IF - RETURN - ENTRY E15O29(CTLMH) -C ---> formerly ENTRY ONCTL, ONCTM, ONCTH - E15O29 = CTLMH - RETURN - ENTRY E18O29(CHL,CHM,CHH,CTL,CTM,CTH) -C ---> formerly ENTRY ONHCB -cvvvvvdak port -cdak IF(NINT(AMAX1(CTL,CTM,CTH)).EQ.0) THEN - IF(NINT(MAX(CTL,CTM,CTH)).EQ.0) THEN -caaaaadak port - E18O29 = 9 - RETURN - END IF - E18O29 = BMISS - IF(CHH.LT.BMISS) E18O29 = CHH - IF(CHM.LT.BMISS) E18O29 = CHM - IF(CHL.LT.BMISS) E18O29 = CHL - IF(E18O29.GE.BMISS.OR.E18O29.LT.0) RETURN - IF(E18O29.LT. 150) THEN - E18O29 = 0 - ELSE IF(E18O29.LT. 350) THEN - E18O29 = 1 - ELSE IF(E18O29.LT. 650) THEN - E18O29 = 2 - ELSE IF(E18O29.LT. 950) THEN - E18O29 = 3 - ELSE IF(E18O29.LT.1950) THEN - E18O29 = 4 - ELSE IF(E18O29.LT.3250) THEN - E18O29 = 5 - ELSE IF(E18O29.LT.4950) THEN - E18O29 = 6 - ELSE IF(E18O29.LT.6750) THEN - E18O29 = 7 - ELSE IF(E18O29.LT.8250) THEN - E18O29 = 8 - ELSE - E18O29 = 9 - END IF - RETURN - ENTRY E19O29(CPT) -C ---> formerly ENTRY ONCPT - E19O29 = BMISS - IF(NINT(CPT).GT.-1.AND.NINT(CPT).LT.9) E19O29 = CPT - RETURN - ENTRY E20O29(PRC) -C ---> formerly ENTRY ONPRC - E20O29 = PRC - IF(PRC.LT.0.) THEN - E20O29 = 9998 - ELSE IF(PRC.LT.BMISS) THEN - E20O29 = NINT(PRC*3.937) - END IF - RETURN - ENTRY E21O29(SND) -C ---> formerly ENTRY ONSND - E21O29 = SND - IF(SND.LT.0.) THEN - E21O29 = 998 - ELSE IF(SND.LT.BMISS) THEN - E21O29 = NINT(SND*39.37) - END IF - RETURN - ENTRY E22O29(PC6) -C ---> formerly ENTRY ONDOP - E22O29 = BMISS - IF(PC6.LT.BMISS) E22O29 = 1 - RETURN - ENTRY E23O29(PER) -C ---> formerly ENTRY ONPOW, ONSWP - E23O29 = NINT(PER) - RETURN - ENTRY E24O29(HGT) -C ---> formerly ENTRY ONHOW, ONSWH - E24O29 = HGT - IF(HGT.LT.BMISS) E24O29 = NINT(2.*HGT) - RETURN - ENTRY E25O29(SWD) -C ---> formerly ENTRY ONSWD - E25O29 = SWD - IF(SWD.EQ.0) THEN - E25O29 = 0 - ELSE IF(SWD.LT.5) THEN - E25O29 = 36 - ELSE IF(SWD.LT.BMISS) THEN - E25O29 = NINT((SWD+.001)*.1) - END IF - RETURN - ENTRY E28O29(SPG) -C ---> formerly ENTRY ONSPG - E28O29 = SPG - RETURN - ENTRY E29O29(SPD) -C ---> formerly ENTRY ONSPD - E29O29 = SPD - RETURN - ENTRY E30O29(SHC) -C ---> formerly ENTRY ONSHC - E30O29 = BMISS - IF(NINT(SHC).GT.-1.AND.NINT(SHC).LT.9) E30O29 = NINT(SHC) - RETURN - ENTRY E31O29(SAS) -C ---> formerly ENTRY ONSAS - E31O29 = BMISS - IF(NINT(SAS).GT.-1.AND.NINT(SAS).LT.10) E31O29 = NINT(SAS) - RETURN - ENTRY E32O29(WES) -C ---> formerly ENTRY ONWES - E32O29 = WES - RETURN - ENTRY E33O29(SUBSET,RPID) -C ---> formerly ENTRY ONRTP - E33O29 = BMISS - IF(SUBSET(1:5).EQ.'NC000'.AND.L02O29(RPID) ) E33O29 = 511 - IF(SUBSET(1:5).EQ.'NC000'.AND.L03O29(RPID) ) E33O29 = 512 - IF(SUBSET.EQ.'NC001001'.AND.RPID.NE.'SHIP') E33O29 = 522 - IF(SUBSET.EQ.'NC001001'.AND.RPID.EQ.'SHIP') E33O29 = 523 - IF(SUBSET.EQ.'NC001002') E33O29 = 562 - IF(SUBSET.EQ.'NC001003') E33O29 = 561 - IF(SUBSET.EQ.'NC001004') E33O29 = 531 - IF(SUBSET.EQ.'NC001006') E33O29 = 551 - IF(SUBSET.EQ.'NC002001') THEN - -C LAND RADIOSONDE - FIXED -C ----------------------- - - E33O29 = 011 - IF(L03O29(RPID)) E33O29 = 012 - IF(RPID(1:4).EQ.'CLAS') E33O29 = 013 - END IF - IF(SUBSET.EQ.'NC002002') THEN - -C LAND RADIOSONDE - MOBILE -C ------------------------ - - E33O29 = 013 - END IF - IF(SUBSET.EQ.'NC002003') THEN - -C SHIP RADIOSONDE -C --------------- - - E33O29 = 022 - IF(RPID(1:4).EQ.'SHIP') E33O29 = 023 - END IF - IF(SUBSET.EQ.'NC002004') THEN - -C DROPWINSONDE -C ------------- - - E33O29 = 031 - END IF - IF(SUBSET.EQ.'NC002005') THEN - -C PIBAL -C ----- - - E33O29 = 011 - IF(L03O29(RPID)) E33O29 = 012 - END IF - - IF(SUBSET.EQ.'NC004001') E33O29 = 041 - IF(SUBSET.EQ.'NC004002') E33O29 = 041 - IF(SUBSET.EQ.'NC004003') E33O29 = 041 - IF(SUBSET.EQ.'NC004004') E33O29 = 041 - IF(SUBSET.EQ.'NC004005') E33O29 = 031 - IF(SUBSET(1:5).EQ.'NC005') E33O29 = 063 - RETURN - ENTRY E34O29(HGT,Z100) -C ---> formerly ENTRY ONFIX -C - With Jeff Ator's fix on 1/30/97, don't need this anymore -cdak HGT0 = HGT -cdak IF(MOD(NINT(HGT),300).EQ.0.OR.MOD(NINT(HGT),500).EQ.0) -cdak $ HGT = HGT * 1.016 - -C ALL WINDS-BY-HEIGHT HEIGHTS ARE TRUNCATED DOWN TO THE NEXT -C 10 METER LEVEL IF PART DD (ABOVE 100 MB LEVEL) (ON29 CONVENTION) -C ----------------------------------------------------------------- - - IF(HGT.GT.Z100) THEN - IF(MOD(NINT(HGT),10).NE.0) HGT = INT(HGT/10.) * 10 - E34O29 = NINT(HGT) - ELSE -C - With Jeff Ator's fix on 1/30/97, don't need this anymore -cdak IF(HGT.NE.HGT0) THEN -cdak IF(MOD(NINT(HGT0),1500).EQ.0) HGT = HGT - 1.0 -cdak ELSE - IF(MOD(NINT(HGT/1.016),1500).EQ.0) HGT = NINT(HGT - 1.0) -cdak END IF - E34O29 = INT(HGT) - END IF - RETURN - ENTRY E38O29(HVZ) - IF(HVZ.GE.BMISS.OR.HVZ.LT.0.) THEN - E38O29 = BMISS - ELSE IF(NINT(HVZ).LT.1000) THEN - KK = MIN(INT(NINT(HVZ)/10),99) - E38O29 = KKK(KK) - ELSE IF(NINT(HVZ).LT.50000) THEN - KK = MIN(INT(NINT(HVZ)/1000),49) - E38O29 = KKKK(KK) - ELSE - E38O29 = 99 - END IF - RETURN - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - FUNCTION C02O29() -C ---> formerly FUNCTION ONCHR - CHARACTER*8 C02O29,E35O29,E36O29 - CHARACTER*1 CPRT(0:11),CMR29(0:15) - - SAVE - -C (NOTE: Prior to mid-March 1999, a purge or reject flag on pressure -C was set to 6 (instead of 14 or 12, resp.) to get around the -C 3-bit limit to ON29 pressure q.m. mnemonic "QMPR". The 3-bit -C limit on "QMPR" was changed to 4-bits with a decoder change -C in February 1999. However, the codes that write the q.m.'s -C out (EDTBUFR and QUIPC) were not changed to write out 14 or -C 12 for purge or reject until mid-March 1999. In order to -C allow old runs to work properly, a q.m. of 6 will continue -C to be interpreted as a "P". This would have to change if -C q.m.=6 ever has a defined meaning.) - -C Code Table Value: 0 1 2 3 4 5 6 7 - - DATA CMR29 /'H','A',' ','Q','C','F','P','F', - -C Code Table Value: 8 9 10 11 12 13 14 15 - - . 'F','F','O','B','R','F','P','F'/ - - DATA CPRT /' ',' ',' ',' ','A','B','C','D','I','J','K','L'/ - - C02O29 = ' ' - RETURN - ENTRY E35O29(QMK) -C ---> formerly ENTRY ONQMK - IF(QMK.GE.0 .AND. QMK.LE.15) E35O29 = CMR29(NINT(QMK)) - IF(QMK.LT.0 .OR. QMK.GT.15) E35O29 = ' ' - RETURN - ENTRY E36O29(NPRT) -C ---> formerly ENTRY ONPRT - E36O29 = ' ' - IF(NPRT.LT.12) E36O29 = CPRT(NPRT)//' ' - RETURN - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - FUNCTION L01O29() -C ---> formerly FUNCTION ONLOG - CHARACTER*8 RPID - LOGICAL L01O29,L02O29,L03O29 - - SAVE - - L01O29 = .TRUE. - - RETURN - - ENTRY L02O29(RPID) -C ---> formerly ENTRY ONBKS - L02O29 = .FALSE. - READ(RPID,'(I5)',ERR=1) IBKS - L02O29 = .TRUE. -1 RETURN - ENTRY L03O29(RPID) -C ---> formerly ENTRY ONCAL - L03O29 = .TRUE. - READ(RPID,'(I5)',ERR=2) IBKS - L03O29 = .FALSE. -2 RETURN - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - FUNCTION R03O29(LUNIT,OBS) -C ---> formerly FUNCTION ADPUPA - - COMMON/IO29DD/HDR(12),RCATS(50,150,11),IKAT(11),MCAT(11),NCAT(11) - COMMON/IO29EE/POB(255),QOB(255),TOB(255),ZOB(255),DOB(255), - $ SOB(255),VSG(255),CLP(255),CLA(255),OB8(255), - $ CF8(255) - COMMON/IO29FF/PQM(255),QQM(255),TQM(255),ZQM(255),WQM(255), - $ QCP(255),QCA(255),Q81(255),Q82(255) - COMMON/IO29CC/SUBSET,IDAT10 - COMMON/IO29BB/KNDX,KSKACF(8),KSKUPA,KSKSFC,KSKSAT,KSKSMI - COMMON/IO29II/PWMIN - - CHARACTER*80 HDSTR,LVSTR,QMSTR,RCSTR - CHARACTER*8 SUBSET,SID,E35O29,E36O29,RSV,RSV2 - CHARACTER*1 PQM,QQM,TQM,ZQM,WQM,QCP,QCA,Q81,Q82,PQML -cvvvvvdak port - REAL(8) RID_8,HDR_8(12),VSG_8(255) - REAL(8) RCT_8(5,255),ARR_8(10,255) - REAL(8) RAT_8(255),RMORE_8(4),RGP10_8(255),RPMSL_8,RPSAL_8 -caaaaadak port - INTEGER IHBLCS(0:9) - DIMENSION OBS(*),RCT(5,255),ARR(10,255) - DIMENSION RAT(255),RMORE(4),RGP10(255) - DIMENSION P2(255),P8(255),P16(255) - - EQUIVALENCE (RID_8,SID) - LOGICAL L02O29 - - SAVE - - DATA HDSTR/'NULL CLON CLAT HOUR MINU SELV '/ - DATA LVSTR/'PRLC TMDP TMDB GP07 GP10 WDIR WSPD '/ - DATA QMSTR/'QMPR QMAT QMDD QMGP QMWN '/ - DATA RCSTR/'RCHR RCMI RCTS '/ - - DATA IHBLCS/25,75,150,250,450,800,1250,1750,2250,2500/ - DATA BMISS/10E10/ - - PRS1(Z) = 1013.25 * (((288.15 - (.0065 * Z))/288.15)**5.256) - PRS2(Z) = 226.3 * EXP(1.576106E-4 * (11000. - Z)) - -C CHECK IF THIS IS A PREPBUFR FILE -C -------------------------------- - - R03O29 = 99 -c#V#V#dak - future -cdak IF(SUBSET.EQ.'ADPUPA') R03O29 = PRPUPA(LUNIT,OBS) -caaaaadak - future - IF(R03O29.NE.99) RETURN - R03O29 = 0 - - CALL S05O29 - -C VERTICAL SIGNIFICANCE DESCRIPTOR TO ASSIGN ON29 CATEGORY -C -------------------------------------------------------- - -C NOTE: MNEMONIC "VSIG" 008001 IS DEFINED AS VERTICAL SOUNDING -C SIGNIFICANCE -- CODE TABLE FOLLOWS: -C 64 Surface -C processed as ON29 category 2 and/or 3 and/or 4 -C 32 Standard (mandatory) level -C processed as ON29 category 1 -C 16 Tropopause level -C processed as ON29 category 5 -C 8 Maximum wind level -C processed as ON29 category 3 or 4 -C 4 Significant level, temperature -C processed as ON29 category 2 -C 2 Significant level, wind -C processed as ON29 category 3 or 4 -C 1 ??????????????????????? -C processed as ON29 category 6 -C -C anything else - the level is not processed - - CALL UFBINT(LUNIT,VSG_8,1,255,NLEV,'VSIG');VSG=VSG_8 - -C PUT THE HEADER INFORMATION INTO ON29 FORMAT -C ------------------------------------------- - - CALL UFBINT(LUNIT,HDR_8,12, 1,IRET,HDSTR);HDR(2:)=HDR_8(2:) - IF(HDR(5).GE.BMISS) HDR(5) = 0 - CALL UFBINT(LUNIT,RID_8,1,1,IRET,'RPID') - IF(IRET.NE.1) SID = 'MISSING ' -cppppp-ID - iprint = 0 -c if(sid.eq.'59758 ') iprint = 1 -c if(sid.eq.'61094 ') iprint = 1 -c if(sid.eq.'62414 ') iprint = 1 -c if(sid.eq.'59362 ') iprint = 1 -c if(sid.eq.'57957 ') iprint = 1 -c if(sid.eq.'74794 ') iprint = 1 -c if(sid.eq.'74389 ') iprint = 1 -c if(sid.eq.'96801A ') iprint = 1 - if(iprint.eq.1) - $ print *, '@@@ START DIAGNOSTIC PRINTOUT FOR ID ',sid -cppppp-ID - - IRECCO = 0 -cvvvvvdak port -cdak CALL UFBINT(LUNIT,RPMSL,1, 1,IRET,'PMSL') - CALL UFBINT(LUNIT,RPMSL_8,1, 1,IRET,'PMSL');RPMSL=RPMSL_8 -caaaaadak port - IF(SUBSET.EQ.'NC004005') THEN -cdak CALL UFBINT(LUNIT,RGP10,1,255,NLEV,'GP10') -cdak CALL UFBINT(LUNIT,RPSAL,1,1,IRET,'PSAL') - CALL UFBINT(LUNIT,RGP10_8,1,255,NLEV,'GP10');RGP10=RGP10_8 - CALL UFBINT(LUNIT,RPSAL_8,1,1,IRET,'PSAL');RPSAL=RPSAL_8 -caaaaadak port - IF(NINT(VSG(1)).EQ.32.AND.RPMSL.GE.BMISS.AND. -cvvvvvdak port -cdak $ AMAX1(RGP10(1),RPSAL).LT.BMISS) THEN - $ MAX(RGP10(1),RPSAL).LT.BMISS) THEN -caaaaadak port -cppppp -cdak print *, '~~IW3UNP29/R03O29: ID ',sid,' is a Cat. 1 type ', -cdak $ 'Flight-level RECCO' -cppppp - IRECCO = 1 -cvvvvvdak port -cdak ELSE IF(AMIN1(VSG(1),RPMSL,RGP10(1)).GE.BMISS.AND.RPSAL.LT. - ELSE IF(MIN(VSG(1),RPMSL,RGP10(1)).GE.BMISS.AND.RPSAL.LT. -caaaaadak port - $ BMISS) - $ THEN -cppppp -cdak print *, '~~IW3UNP29/R03O29: ID ',sid,' is a Cat. 6 type ', -cdak $ 'Flight-level RECCO (but reformatted into cat. 2/3)' -cppppp - IRECCO = 6 -cvvvvvdak port -cdak ELSE IF(AMIN1(VSG(1),RGP10(1)).GE.BMISS.AND.AMAX1(RPMSL,RPSAL) - ELSE IF(MIN(VSG(1),RGP10(1)).GE.BMISS.AND.MAX(RPMSL,RPSAL) -caaaaadak port - $ .LT.BMISS) THEN -cppppp -cdak print *, '~~IW3UNP29/R03O29: ID ',sid,' is a Cat. 2/3 type', -cdak $ ' Flight-level RECCO with valid PMSL' -cppppp - IRECCO = 23 - ELSE -cppppp - print *, '~~IW3UNP29/R03O29: ID ',sid,' is currently an ', - $ 'unknown type of Flight-level RECCO - VSIG =',VSG(1), - $ '; PMSL =',RPMSL,'; GP10 =',RGP10(1),' -- SKIP IT for now' - R03O29 = -9999 - KSKUPA =KSKUPA + 1 - RETURN -cppppp - END IF - END IF - - XOB = HDR(2) - YOB = HDR(3) - RHR = BMISS - IF(HDR(4).LT.BMISS) RHR = NINT(HDR(4))+NINT(HDR(5))/60. - RCH = BMISS - RSV = '999 ' - ELV = HDR(6) - IF(IRECCO.GT.0) THEN - RPSAL = RPSAL + SIGN(0.0000001,RPSAL) - ELV = RPSAL - END IF - - CALL UFBINT(LUNIT,RAT_8, 1,255,NLEV,'RATP');RAT=RAT_8 - ITP = MIN(99,NINT(RAT(1))) - RTP = E33O29(SUBSET,SID) - IF(ELV.GE.BMISS) THEN -cppppp - print *, 'IW3UNP29/R03O29: ID ',sid,' has a missing elev, so ', - $ 'elevation set to ZERO' -cppppp - IF((RTP.GT.20.AND.RTP.LT.24).OR.SUBSET.EQ.'NC002004') ELV = 0 - END IF -cdak if(sid(5:5).eq.' ') print*,sid - IF(L02O29(SID).AND.SID(5:5).EQ.' ') SID = '0'//SID - RSV2 = ' ' - CALL S01O29(SID,XOB,YOB,RHR,RCH,RSV,RSV2,ELV,ITP,RTP) - -C PUT THE LEVEL DATA INTO ON29 UNITS -C ---------------------------------- - -cvvvvvdak port -cdak CALL UFBINT(LUNIT,ARR,10,255,NLEV,LVSTR) - CALL UFBINT(LUNIT,ARR_8,10,255,NLEV,LVSTR);ARR=ARR_8 -caaaaadak port - - PWMIN = 999999. - JLV = 2 - IF(IRECCO.EQ.6) JLV = 1 - IF(IRECCO.GT.0.AND.NLEV.EQ.1) THEN - VSG(JLV) = 4 - VSG(JLV+1) = 2 - QOB(JLV) = E07O29(ARR(2,1),ARR(3,1)) - TOB(JLV) = E06O29(ARR(3,1)) - ARR(2,1) = BMISS - ARR(3,1) = BMISS - DOB(JLV+1) = E04O29(ARR(6,1),ARR(7,1)) - SOB(JLV+1) = E05O29(ARR(6,1),ARR(7,1)) - IF(NINT(DOB(JLV+1)).EQ.0.AND.NINT(SOB(JLV+1)).GT.0) - $ DOB(JLV+1) = 360. - IF(NINT(DOB(JLV+1)).EQ.360.AND.NINT(SOB(JLV+1)).EQ.0) - $ DOB(JLV+1) = 0. - ARR(6,1) = BMISS - ARR(7,1) = BMISS - IF(IRECCO.EQ.23) THEN - VSG(1) = 64 - ARR(1,1) = RPMSL - END IF - END IF - - IF(IRECCO.EQ.6) GO TO 4523 - - DO L=1,NLEV - POB(L) = E01O29(ARR(1,L)) - IF(NINT(ARR(1,L)).LE.0) THEN - POB(L) = BMISS -cppppp - print *,'~~@@IW3UNP29/R03O29: ID ',sid,' has a ZERO or ', - $ 'negative reported pressure that is reset to missing' -cppppp - END IF - QOB(L) = E07O29(ARR(2,L),ARR(3,L)) - TOB(L) = E06O29(ARR(3,L)) - ZOB(L) = MIN(E08O29(ARR(4,L)),E08O29(ARR(5,L))) -cppppp - if(iprint.eq.1) then - if(irecco.gt.0) print *, 'At lvl=',L,'; orig. ZOB = ',zob(L) - end if -cppppp - IF(IRECCO.EQ.1) THEN - IF(MOD(NINT(ZOB(L)),10).NE.0) ZOB(L) = INT(ZOB(L)/10.) * 10 - ZOB(L) = NINT(ZOB(L)) - ELSEIF(IRECCO.EQ.23) THEN - ZOB(L) = 0 - END IF - DOB(L) = E04O29(ARR(6,L),ARR(7,L)) - SOB(L) = E05O29(ARR(6,L),ARR(7,L)) - IF(NINT(DOB(L)).EQ.0.AND.NINT(SOB(L)).GT.0) DOB(L) = 360. - IF(NINT(DOB(L)).EQ.360.AND.NINT(SOB(L)).EQ.0) DOB(L) = 0. -cppppp - if(iprint.eq.1) then - print *, 'At lvl=',L,'; VSG=',vsg(L),'; POB = ',pob(L), - $ '; QOB = ',qob(L),'; TOB = ',tob(L),'; ZOB = ',zob(L), - $ '; DOB = ',dob(L),'; final SOB (kts) = ',sob(L), - $ '; origl SOB (mps) = ',arr(7,L) - end if -cppppp -cvvvvvdak port -cdak IF(IRECCO.EQ.0.AND.AMAX1(POB(L),DOB(L),SOB(L)).LT.BMISS) -cdak $ PWMIN=AMIN1(PWMIN,POB(L)) - IF(IRECCO.EQ.0.AND.MAX(POB(L),DOB(L),SOB(L)).LT.BMISS) - $ PWMIN=MIN(PWMIN,POB(L)) -caaaaadak port - ENDDO - - 4523 CONTINUE - - MLEV = NLEV - -cvvvvvdak port -cdak CALL UFBINT(LUNIT,ARR,10,255,NLEV,QMSTR) - CALL UFBINT(LUNIT,ARR_8,10,255,NLEV,QMSTR);ARR=ARR_8 -caaaaadak port - - IF(IRECCO.GT.0.AND.MLEV.EQ.1) THEN - POB1 = BMISS - IF(POB(1).LT.BMISS) POB1 = POB(1) * 0.1 - TOB1 = BMISS - IF(TOB(JLV).LT.BMISS) TOB1 = (TOB(JLV) * 0.1) + 273.15 - RPS1 = RPSAL - ZOB1 = ZOB(1) - TQM1 = ARR(3,1) - POB(JLV)=NINT(E37O29(POB1,TOB1,RPS1,ZOB1,TQM1)) * 10 - POB(JLV+1) = POB(JLV) -cppppp - if(iprint.eq.1) then - do L=JLV,JLV+1 - print *, 'At lvl=',L,'; VSG=',vsg(L),'; POB = ',pob(L), - $ '; QOB = ',qob(L),'; TOB = ',tob(L),'; ZOB = ',zob(L), - $ '; DOB = ',dob(L),'; SOB = ',sob(L) - enddo - end if -cppppp - END IF - - IF(IRECCO.GT.0.AND.NLEV.EQ.1) THEN - PQM(JLV) = 'E' - PQM(JLV+1) = 'E' - TQM(JLV) = E35O29(ARR(2,1)) - ARR(2,1) = BMISS - QQM(JLV) = E35O29(ARR(3,1)) - ARR(3,1) = BMISS - ARR(4,1) = 3 - WQM(JLV+1) = E35O29(ARR(5,1)) - ARR(5,1) = BMISS - END IF - - IF(IRECCO.EQ.6) GO TO 4524 - - DO L=1,NLEV - PQM(L) = E35O29(ARR(1,L)) - TQM(L) = E35O29(ARR(2,L)) - QQM(L) = E35O29(ARR(3,L)) - ZQM(L) = E35O29(ARR(4,L)) - WQM(L) = E35O29(ARR(5,L)) - ENDDO - - 4524 CONTINUE - - IF(IRECCO.GT.0.AND.NLEV.EQ.1) NLEV = JLV + 1 - -C SURFACE DATA MUST GO FIRST -C -------------------------- - - CALL S02O29(2,0,*9999) - CALL S02O29(3,0,*9999) - CALL S02O29(4,0,*9999) - - INDX2 = 0 - INDX8 = 0 - INDX16 = 0 - P2 = BMISS - P8 = BMISS - P16 = BMISS - - DO L=1,NLEV - IF(NINT(VSG(L)).EQ.64) THEN -cppppp - if(iprint.eq.1) then - print *, 'Lvl=',L,' is a surface level' - end if - if(iprint.eq.1.and.POB(L).LT.BMISS.AND.(TOB(L).LT.BMISS.OR.IRECCO - $ .EQ.23)) then - print *, ' --> valid cat. 2 sfc. lvl ' - end if -cppppp - IF(POB(L).LT.BMISS.AND.(TOB(L).LT.BMISS.OR.IRECCO.EQ.23)) - $ CALL SE01O29(2,L) -cppppp - if(iprint.eq.1.and.POB(L).LT.BMISS.AND.(DOB(L).LT.BMISS.OR.IRECCO - $ .EQ.23)) then - print *, ' --> valid cat. 3 sfc. lvl ' - end if -cppppp - IF(POB(L).LT.BMISS.AND.(DOB(L).LT.BMISS.OR.IRECCO.EQ.23)) - $ CALL SE01O29(3,L) - IF(ZOB(L).LT.BMISS.AND.DOB(L).LT.BMISS) THEN -cppppp - if(iprint.eq.1) print *, ' --> valid cat. 4 sfc. lvl ' -cppppp - -C CAT. 4 HEIGHT DOES NOT PASS ON A KEEP, PURGE, OR REJECT LIST Q.M. -C ----------------------------------------------------------------- - - ZQM(L) = ' ' - CALL SE01O29(4,L) - END IF - VSG(L) = 0 - ELSE IF(NINT(VSG(L)).EQ.2) THEN - P2(L) = POB(L) - INDX2 = L - IF(INDX8.GT.0) THEN - DO II = 1,INDX8 - IF(POB(L).EQ.P8(II).AND.POB(L).LT.BMISS) THEN -cppppp - if(iprint.eq.1) then - print *, ' ## This cat. 3 level, on lvl ',L, - $ ' will have already been processed as a cat. 3 ', - $ 'MAX wind lvl (on lvl ',II,') - skip this Cat. ', - $ '3 lvl' - end if -cppppp -cvvvvvdak port -cdak IF(AMAX1(SOB(II),DOB(II)).GE.BMISS) THEN - IF(MAX(SOB(II),DOB(II)).GE.BMISS) THEN -caaaaadak port - SOB(II) = SOB(L) - DOB(II) = DOB(L) -cppppp - if(iprint.eq.1) then - print *, ' ...... also on lvl ',L,' - transfer', - $ ' wind data to dupl. MAX wind lvl because its ', - $ 'missing there' - end if -cppppp - END IF - VSG(L) = 0 - GO TO 7732 - END IF - ENDDO - END IF - ELSE IF(NINT(VSG(L)).EQ.8) THEN - P8(L) = POB(L) - INDX8 = L - IF(INDX2.GT.0) THEN - DO II = 1,INDX2 - IF(POB(L).EQ.P2(II).AND.POB(L).LT.BMISS) THEN -cppppp - if(iprint.eq.1) then - print *, ' ## This MAX wind level, on lvl ',L, - $ ' will have already been processed as a cat. 3 ', - $ 'lvl (on lvl ',II,') - skip this MAX wind lvl ', - $ 'but set' - print *, ' cat. 3 lvl PQM to "W"' - end if -cppppp - PQM(II) = 'W' - IF(POB(L).EQ.PWMIN) PQM(II) = 'X' -cvvvvvdak port -cdak IF(AMAX1(SOB(II),DOB(II)).GE.BMISS) THEN - IF(MAX(SOB(II),DOB(II)).GE.BMISS) THEN -caaaaadak port - SOB(II) = SOB(L) - DOB(II) = DOB(L) -cppppp - if(iprint.eq.1) then - print *, ' ...... also on lvl ',L,' - transfer', - $ ' wind data to dupl. cat. 3 lvl because its ', - $ 'missing there' - end if -cppppp - END IF - VSG(L) = 0 - GO TO 7732 - END IF - ENDDO - END IF - IF(INDX8-1.GT.0) THEN - DO II = 1,INDX8-1 - IF(POB(L).EQ.P8(II).AND.POB(L).LT.BMISS) THEN -cppppp - if(iprint.eq.1) then - print *, ' ## This cat. 3 MAX wind lvl, on lvl ',L, - $ ' will have already been processed as a cat. 3 ', - $ 'MAX wind lvl (on lvl ',II,') - skip this Cat. ', - $ '3 MAX wind lvl' - end if -cppppp -cvvvvvdak port -cdak IF(AMAX1(SOB(II),DOB(II)).GE.BMISS) THEN - IF(MAX(SOB(II),DOB(II)).GE.BMISS) THEN -caaaaadak port - SOB(II) = SOB(L) - DOB(II) = DOB(L) -cppppp - if(iprint.eq.1) then - print *, ' ...... also on lvl ',L,' - transfer', - $ ' wind data to dupl. MAX wind lvl because its ', - $ 'missing there' - end if -cppppp - END IF - VSG(L) = 0 - GO TO 7732 - END IF - ENDDO - END IF - ELSE IF(NINT(VSG(L)).EQ.16) THEN - INDX16 = INDX16 + 1 - P16(INDX16) = POB(L) - END IF - 7732 CONTINUE - ENDDO - -C TAKE CARE OF 925 MB NEXT -C ------------------------ - - DO L=1,NLEV - IF(NINT(VSG(L)).EQ.32 .AND. NINT(POB(L)).EQ.9250) THEN - CF8(L) = 925 - OB8(L) = ZOB(L) - Q81(L) = ' ' - Q82(L) = ' ' - IF(TOB(L).LT.BMISS) CALL S02O29(2,L,*9999) - IF(DOB(L).LT.BMISS) CALL S02O29(3,L,*9999) - IF(OB8(L).LT.BMISS) CALL S02O29(8,L,*9999) - VSG(L) = 0 - END IF - ENDDO - -C REST OF THE DATA -C ---------------- - - Z100 = 16000 - DO L=1,NLEV - IF(NINT(VSG(L)).EQ.32) THEN -cvvvvvdak port -cdak IF(AMIN1(DOB(L),ZOB(L),TOB(L)).GE.BMISS) THEN - IF(MIN(DOB(L),ZOB(L),TOB(L)).GE.BMISS) THEN -caaaavdak port -cppppp - if(iprint.eq.1) then - print *,' ==> For lvl ',L,'; VSG=32 & DOB,ZOB,TOB all ', - $ 'missing --> this level not processed' - end if - VSG(L) = 0 -cvvvvvdak port -cdak ELSE IF(AMIN1(ZOB(L),TOB(L)).LT.BMISS) THEN - ELSE IF(MIN(ZOB(L),TOB(L)).LT.BMISS) THEN -caaaaadak port -cppppp - if(iprint.eq.1) then - print *,' ==> For lvl ',L,'; VSG=32 & one or both of ', - $ 'ZOB,TOB non-missing --> valid cat. 1 lvl' - end if -cppppp - CALL S02O29(1,L,*9999) - IF(NINT(POB(L)).EQ.1000.AND.ZOB(L).LT.BMISS) Z100 = ZOB(L) - VSG(L) = 0 - END IF - END IF - ENDDO - DO L=1,NLEV - IF(NINT(VSG(L)).EQ.32) THEN -cvvvvvdak port -cdak IF(DOB(L).LT.BMISS.AND.AMIN1(ZOB(L),TOB(L)).GE.BMISS) THEN - IF(DOB(L).LT.BMISS.AND.MIN(ZOB(L),TOB(L)).GE.BMISS) THEN -caaaaadak port - LL = I04O29(POB(L)*.1) - IF(LL.EQ.999999) THEN -cppppp - print *, '~~IW3UNP29/R03O29: ID ',sid,' has VSG=32 for ', - $ 'lvl ',L,' but pressure not mand.!! --> this level ', - $ 'not processed' -cppppp -cvvvvvdak port -cdak ELSE IF(AMIN1(RCATS(1,LL,1),RCATS(2,LL,1)).LT.99999.) THEN - ELSE IF(MIN(RCATS(1,LL,1),RCATS(2,LL,1)).LT.99999.) THEN -caaaaadak port - IF(RCATS(4,LL,1).GE.99998.) THEN -cppppp - if(iprint.eq.1) then - print *,' ==> For lvl ',L,'; VSG=32 & ZOB,TOB ', - $ 'both missing while DOB non-missing BUT one or ', - $ 'both of Z, T non-missing while wind missing in' - print *,' earlier cat. 1 processing of this ', - $ POB(L)*.1,'mb level --> valid cat. 1 lvl' - end if -cppppp - CALL S02O29(1,L,*9999) - ELSE -cppppp - if(iprint.eq.1) then - print *,' ==> For lvl ',L,'; VSG=32 & ZOB,TOB ', - $ 'both missing while DOB non-missing BUT one or ', - $ 'both of Z, T non-missing while wind non-missing', - $ ' in' - print *,' earlier cat. 1 processing of this ', - $ POB(L)*.1,'mb level --> valid cat. 3 lvl' - end if -cppppp - CALL S02O29(3,L,*9999) - END IF - ELSE -cppppp - if(iprint.eq.1) then - print *,' ==> For lvl ',L,'; VSG=32 & ZOB,TOB both ', - $ 'missing while DOB non-missing AND both Z, T ', - $ 'missing on' - print *,' this ',POB(L)*.1,'mb level in cat. 1 ', - $ ' --> valid cat. 3 lvl' - end if -cppppp - CALL S02O29(3,L,*9999) - END IF - ELSE -cppppp - print *, '~~IW3UNP29/R03O29: ID ',sid,' has VSG=32 for ', - $ 'lvl ',L,' & should never come here!! - by default output', - $ ' as cat. 1 lvl' -cppppp - CALL S02O29(1,L,*9999) - END IF - VSG(L) = 0 - END IF - ENDDO - - DO L=1,NLEV - IF(NINT(VSG(L)).EQ. 4) THEN -cppppp - if(iprint.eq.1) then - print *, ' ==> For lvl ',L,'; VSG= 4 --> valid cat. 2 lvl' - end if -cppppp - IF(INDX16.GT.0) THEN - DO II = 1,INDX16 - IF(POB(L).EQ.P16(II).AND.POB(L).LT.BMISS) THEN -cppppp - if(iprint.eq.1) then - print *, ' ## This cat. 2 level, on lvl ',L,' is', - $ ' also the tropopause level, as its pressure ', - $ 'matches that of trop. lvl no. ',II,' - ', - $ 'set this cat. 2' - print *, ' lvl PQM to "T"' - end if -cppppp - PQM(L) = 'T' - GO TO 7738 - END IF - ENDDO - END IF - 7738 CONTINUE - CALL S02O29(2,L,*9999) - VSG(L) = 0 - ELSEIF(NINT(VSG(L)).EQ.16) THEN -cppppp - if(iprint.eq.1) then - print *, ' ==> For lvl ',L,'; VSG=16 --> valid cat. 3/5 lvl' - end if -cppppp - PQML = PQM(L) -cvvvvvdak port -cdak IF(AMIN1(SOB(L),DOB(L)).LT.BMISS) CALL S02O29(3,L,*9999) - IF(MIN(SOB(L),DOB(L)).LT.BMISS) CALL S02O29(3,L,*9999) -caaaaadak port - PQM(L) = PQML - CALL S02O29(5,L,*9999) - VSG(L) = 0 - ELSEIF(NINT(VSG(L)).EQ. 1) THEN -cppppp - print *, '~~IW3UNP29/R03O29: HERE IS A VSG =1, SET TO CAT.6, ', - $ 'AT ID ',SID,'; SHOULD NEVER HAPPEN!!' -cppppp - CALL S02O29(6,L,*9999) - VSG(L) = 0 - ELSEIF(NINT(VSG(L)).EQ. 2 .AND. POB(L).LT.BMISS) THEN -cvvvvvdak port -cdak IF(AMAX1(SOB(L),DOB(L)).LT.BMISS) THEN - IF(MAX(SOB(L),DOB(L)).LT.BMISS) THEN -caaaaadak port -cppppp - if(iprint.eq.1) then - print *, ' ==> For lvl ',L,'; VSG= 2 & POB .ne. missing ', - $ '--> valid cat. 3 lvl (expect that ZOB is missing)' - end if -cppppp - CALL S02O29(3,L,*9999) - ELSE -cppppp - if(iprint.eq.1) then - print *, ' ==> For lvl ',L,'; VSG= 2 & POB .ne. missing ', - $ '--> Cat. 3 level not processed - wind is missing' - end if -cppppp - END IF - VSG(L) = 0 - ELSEIF(NINT(VSG(L)).EQ. 2 .AND. ZOB(L).LT.BMISS) THEN -cvvvvvdak port -cdak IF(AMAX1(SOB(L),DOB(L)).LT.BMISS) THEN - IF(MAX(SOB(L),DOB(L)).LT.BMISS) THEN -caaaaadak port - -C CERTAIN U.S. WINDS-BY-HEIGHT ARE CORRECTED TO ON29 CONVENTION -C ------------------------------------------------------------- - - IF(SID(1:2).EQ.'70'.OR.SID(1:2).EQ.'71'.OR.SID(1:2).EQ.'72' - $ .OR.SID(1:2).EQ.'74') ZOB(L) = E34O29(ZOB(L),Z100) -cppppp - if(iprint.eq.1) then - print *, ' ==> For lvl ',L,'; VSG= 2 & ZOB .ne. missing ', - $ '--> valid cat. 4 lvl (POB must always be missing)' - if(sid(1:2).eq.'70'.or.sid(1:2).eq.'71'.or.sid(1:2).eq.'72' - $ .or.sid(1:2).eq.'74') print *, ' .... ZOB at this ', - $ 'U.S. site adjusted to ',zob(L) - end if -cppppp - -C CAT. 4 HEIGHT DOES NOT PASS ON A KEEP, PURGE, OR REJECT LIST Q.M. -C ----------------------------------------------------------------- - - ZQM(L) = ' ' - - CALL S02O29(4,L,*9999) - ELSE -cppppp - if(iprint.eq.1) then - print *, ' ==> For lvl ',L,'; VSG= 2 & ZOB .ne. missing ', - $ '--> Cat. 4 level not processed - wind is missing' - end if -cppppp - END IF - VSG(L) = 0 - ELSEIF(NINT(VSG(L)).EQ. 8 .AND. POB(L).LT.BMISS) THEN -cppppp - if(iprint.eq.1) then - print *, ' ==> For lvl ',L,'; VSG= 8 & POB .ne. missing ', - $ '--> valid cat. 3 lvl (expect that ZOB is missing)' - end if -cppppp - CALL S02O29(3,L,*9999) - VSG(L) = 0 - ELSEIF(NINT(VSG(L)).EQ. 8 .AND. ZOB(L).LT.BMISS) THEN -cvvvvvdak port -cdak IF(AMAX1(SOB(L),DOB(L)).LT.BMISS) THEN - IF(MAX(SOB(L),DOB(L)).LT.BMISS) THEN -caaaaadak port - -C CERTAIN U.S. WINDS-BY-HEIGHT ARE CORRECTED TO ON29 CONVENTION -C ------------------------------------------------------------- - - IF(SID(1:2).EQ.'70'.OR.SID(1:2).EQ.'71'.OR.SID(1:2).EQ.'72' - $ .OR.SID(1:2).EQ.'74') ZOB(L) = E34O29(ZOB(L),Z100) -cppppp - if(iprint.eq.1) then - print *, ' ==> For lvl ',L,'; VSG= 8 & ZOB .ne. missing ', - $ '--> valid cat. 4 lvl (POB must always be missing)' - if(sid(1:2).eq.'70'.or.sid(1:2).eq.'71'.or.sid(1:2).eq.'72' - $ .or.sid(1:2).eq.'74') print *, ' .... ZOB at this ', - $ 'U.S. site adjusted to ',zob(L) - end if -cppppp - -C CAT. 4 HEIGHT DOES NOT PASS ON A KEEP, PURGE, OR REJECT LIST Q.M. -C ----------------------------------------------------------------- - - ZQM(L) = ' ' - - CALL S02O29(4,L,*9999) - ELSE -cppppp - if(iprint.eq.1) then - print *, ' ==> For lvl ',L,'; VSG= 8 & ZOB .ne. missing ', - $ '--> Cat. 4 level not processed - wind is missing' - end if -cppppp - END IF - VSG(L) = 0 - END IF - ENDDO - -C CHECK FOR LEVELS WHICH GOT LEFT OUT -C ----------------------------------- - - DO L=1,NLEV - IF(NINT(VSG(L)).GT.0) THEN - PRINT 887, L,SID,NINT(VSG(L)) - 887 FORMAT(' ##IW3UNP29/R03O29 - ~~ON LVL',I4,' OF ID ',A8,', A ', - $ 'VERTICAL SIGNIFICANCE OF',I3,' WAS NOT SUPPORTED - LEAVE ', - $ 'THIS LEVEL OUT OF THE PROCESSING') - print *, ' ..... at lvl=',L,'; POB = ',pob(L),'; QOB = ', - $ qob(L),'; TOB = ',tob(L),'; ZOB = ',zob(L),'; DOB = ',dob(L), - $ ';' - print *, ' SOB = ',sob(L) - END IF - ENDDO - -C CLOUD DATA GOES INTO CATEGORY 07 -C -------------------------------- - - CALL UFBINT(LUNIT,ARR_8,10,255,NLEV,'HOCB CLAM QMCA HBLCS') - ARR=ARR_8 - DO L=1,NLEV - IF(ARR(1,L).LT.BMISS/2.) THEN - ! Prior to 3/2002 HBLCS was not available, this will - ! always be tested first because it is more precise - ! in theory but will now be missing after 3/2002 - IF(ELV+ARR(1,L).GE.BMISS/2.) THEN - CLP(L) = BMISS - ELSE IF(ELV+ARR(1,L).LE.11000) THEN - CLP(L) = (PRS1(ELV+ARR(1,L))*10.) + 0.001 - ELSE - CLP(L) = (PRS2(ELV+ARR(1,L))*10.) + 0.001 - END IF - ELSE - ! Effective 3/2002 only this will be available - IF(NINT(ARR(4,L)).GE.10) THEN - CLP(L) = BMISS - ELSE - IF(ELV+IHBLCS(NINT(ARR(4,L))).GE.BMISS/2.) THEN - CLP(L) = BMISS - ELSE IF(ELV+IHBLCS(NINT(ARR(4,L))).LE.11000) THEN - CLP(L) = (PRS1(ELV+IHBLCS(NINT(ARR(4,L))))*10.) +0.001 - ELSE - CLP(L) = (PRS2(ELV+IHBLCS(NINT(ARR(4,L))))*10.) +0.001 - END IF - END IF - END IF - CLA(L) = E13O29(ARR(2,L)) - QCP(L) = ' ' - QCA(L) = E35O29(ARR(3,L)) - IF(CLP(L).LT.BMISS .OR. CLA(L).LT.BMISS) CALL S02O29(7,L,*9999) - ENDDO - -C ----------------------------------------------------- -C MISC DATA GOES INTO CATEGORY 08 -C ----------------------------------------------------- -C CODE FIGURE 104 - RELEASE TIME IN .01*HR -C CODE FIGURE 105 - RECEIPT TIME IN .01*HR -C CODE FIGURE 106 - RADIOSONDE INSTR. TYPE, -C SOLAR/IR CORRECTION INDICATOR, -C TRACKING TECH/STATUS OF SYSTEM USED -C CODE FIGURE 925 - HEIGHT OF 925 LEVEL -C ----------------------------------------------------- - -cvvvvvdak port -cdak CALL UFBINT(LUNIT,RCT, 5,255,NRCT,RCSTR) - CALL UFBINT(LUNIT,RCT_8, 5,255,NRCT,RCSTR);RCT=RCT_8 -caaaaadak port - -C NOTE: MNEMONIC "RCTS" 008202 IS A LOCAL DESCRIPTOR DEFINED AS -C RECEIPT TIME SIGNIFICANCE -- CODE TABLE FOLLOWS: -C 0 General decoder receipt time -C 1 NCEP receipt time -C 2 OSO receipt time -C 3 ARINC ground station receipt time -C 4 Radiosonde TEMP AA part receipt time -C 5 Radiosonde TEMP BB part receipt time -C 6 Radiosonde TEMP CC part receipt time -C 7 Radiosonde TEMP DD part receipt time -C 8 Radiosonde PILOT AA part receipt time -C 9 Radiosonde PILOT BB part receipt time -C 10 Radiosonde PILOT CC part receipt time -C 11 Radiosonde PILOT DD part receipt time -C 12-62 Reserved for future use -C 63 Missing - - DO L=1,NRCT - CF8(L) = 105 - OB8(L) = NINT((NINT(RCT(1,L))+NINT(RCT(2,L))/60.) * 100.) - IF(IRECCO.GT.0.AND.NINT(RCT(3,L)).EQ.0) RCT(3,L) = 9 - Q81(L) = E36O29(NINT(RCT(3,L))) - Q82(L) = ' ' - CALL S02O29(8,L,*9999) - ENDDO - -cvvvvvdak port -cdak CALL UFBINT(LUNIT,RMORE,4,1,NRMORE,'SIRC TTSS UALNHR UALNMN') - CALL UFBINT(LUNIT,RMORE_8,4,1,NRMORE,'SIRC TTSS UALNHR UALNMN') - RMORE=RMORE_8 -cdak IF(AMAX1(RMORE(3),RMORE(4)).LT.BMISS) THEN - IF(MAX(RMORE(3),RMORE(4)).LT.BMISS) THEN -caaaaadak port - CF8(1) = 104 - OB8(1) = NINT((RMORE(3)+RMORE(4)/60.) * 100.) - Q81(1) = ' ' - Q82(1) = ' ' - CALL S02O29(8,1,*9999) - END IF - IF(NINT(RAT(1)).LT.100) THEN - CF8(1) = 106 - ISIR = 9 - IF(NINT(RMORE(1)).LT.9) ISIR = NINT(RMORE(1)) - ITEC = 99 - IF(NINT(RMORE(2)).LT.99) ITEC = NINT(RMORE(2)) - OB8(1) = (ISIR * 10000) + (NINT(RAT(1)) * 100) + ITEC - Q81(1) = ' ' - Q82(1) = ' ' - CALL S02O29(8,1,*9999) - END IF - -C PUT THE UNPACKED ON29 REPORT INTO OBS -C ------------------------------------- - - CALL S03O29(OBS,SUBSET,*9999,*9998) - - RETURN - 9999 CONTINUE - R03O29 = 999 - RETURN - 9998 CONTINUE - print *,'IW3UNP29/R03O29: RPT with ID= ',SID,' TOSSED - ZERO ', - $ 'CAT.1-6,51,52 LVLS' - R03O29 = -9999 - KSKUPA =KSKUPA + 1 - RETURN - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - FUNCTION R04O29(LUNIT,OBS) -C ---> formerly FUNCTION SURFCE - - COMMON/IO29EE/POB(255),QOB(255),TOB(255),ZOB(255),DOB(255), - $ SOB(255),VSG(255),CLP(255),CLA(255),OB8(255), - $ CF8(255) - COMMON/IO29FF/PQM(255),QQM(255),TQM(255),ZQM(255),WQM(255), - $ QCP(255),QCA(255),Q81(255),Q82(255) - COMMON/IO29GG/PSL,STP,SDR,SSP,STM,DPD,TMX,TMI,HVZ,PRW,PW1,CCN,CHN, - $ CTL,CTM,CTH,HCB,CPT,APT,PC6,SND,P24,DOP,POW,HOW,SWD, - $ SWP,SWH,SST,SPG,SPD,SHC,SAS,WES - COMMON/IO29HH/PSQ,SPQ,SWQ,STQ,DDQ - COMMON/IO29CC/SUBSET,IDAT10 - COMMON/IO29BB/KNDX,KSKACF(8),KSKUPA,KSKSFC,KSKSAT,KSKSMI - - CHARACTER*80 HDSTR,RCSTR - CHARACTER*8 SUBSET,SID,E35O29,RSV,RSV2 - CHARACTER*1 PQM,QQM,TQM,ZQM,WQM,QCP,QCA,Q81,Q82,PSQ,SPQ,SWQ,STQ, - $ DDQ -cvvvvvdak port - REAL(8) RID_8,UFBINT_8 - REAL(8) HDR_8(20),RCT_8(5,255),RRSV_8(3),CLDS_8(4,255), - $ TMXMNM_8(4,255) -caaaaadak port - INTEGER ITIWM(0:15),IHBLCS(0:9) - DIMENSION OBS(*),HDR(20),RCT(5,255),RRSV(3),CLDS(4,255),JTH(0:9), - $ JTL(0:9),LTL(0:9),TMXMNM(4,255) - EQUIVALENCE (RID_8,SID) - - SAVE - - DATA HDSTR/'RPID CLON CLAT HOUR MINU SELV AUTO '/ - DATA RCSTR/'RCHR RCMI RCTS '/ - - DATA BMISS /10E10 / - - DATA JTH/0,1,2,3,4,5,6,8,7,9/,JTL/0,1,5,8,7,2,3,4,6,9/ - DATA LTL/0,1,5,6,7,2,8,4,3,9/ - DATA ITIWM/0,3*7,3,3*7,1,3*7,4,3*7/ - DATA IHBLCS/25,75,150,250,450,800,1250,1750,2250,2500/ - -C CHECK IF THIS IS A PREPBUFR FILE -C -------------------------------- - - R04O29 = 99 -c#V#V#dak - future -cdak IF(SUBSET.EQ.'ADPSFC') R04O29 = PRPSFC(LUNIT,OBS) -cdak IF(SUBSET.EQ.'SFCSHP') R04O29 = PRPSFC(LUNIT,OBS) -cdak IF(SUBSET.EQ.'SFCBOG') R04O29 = PRPSFC(LUNIT,OBS) -caaaaadak - future - IF(R04O29.NE.99) RETURN - R04O29 = 0 - - CALL S05O29 - -C PUT THE HEADER INFORMATION INTO ON29 FORMAT -C ------------------------------------------- - - CALL UFBINT(LUNIT,HDR_8,20, 1,IRET,HDSTR);HDR(2:)=HDR_8(2:) - CALL UFBINT(LUNIT,RCT_8, 5,255,NRCT,RCSTR);RCT=RCT_8 - IF(HDR(5).GE.BMISS) HDR(5) = 0 - RCTIM = NINT(RCT(1,1))+NINT(RCT(2,1))/60. - RID_8 = HDR_8(1) - XOB = HDR(2) - YOB = HDR(3) - RHR = BMISS - IF(HDR(4).LT.BMISS) RHR = NINT(HDR(4))+NINT(HDR(5))/60. - RCH = RCTIM - ELV = HDR(6) - -C I1 DEFINES SYNOPTIC FORMAT FLAG (SUBSET NC000001, NC000009) -C I1 DEFINES AUTOMATED STATION TYPE (SUBSET NC000003-NC000008,NC000010) -C I2 DEFINES CONVERTED HOURLY FLAG (SUBSET NC000xxx) -C I2 DEFINES SHIP LOCATION FLAG (SUBSET NC001xxx) (WHERE xxx != 006) - - I1 = 9 - I2 = 9 - IF(SUBSET(1:5).EQ.'NC000') THEN - IF(SUBSET(6:8).EQ.'001'.OR.SUBSET(6:8).EQ.'009') THEN - I1 = 1 - IF(SUBSET(6:8).EQ.'009') I2 = 1 - ELSE IF(SUBSET(6:8).NE.'002') THEN - IF(HDR(7).LT.15) THEN - IF(HDR(7).GT.0.AND.HDR(7).LT.5) THEN - I1 = 2 - ELSE IF(HDR(7).EQ.8) THEN - I1 = 3 - ELSE - I1 = 4 - END IF - END IF - END IF - END IF - ITP = (10 * I1) + I2 - RTP = E33O29(SUBSET,SID) - -C THE 25'TH (RESERVE) CHARACTER IS INDICATOR FOR PRECIP. (INCL./EXCL.) -C THE 26'TH (RESERVE) CHARACTER IS INDICATOR FOR W SPEED (SOURCE/UNITS) -C '0' - Wind speed estimated in m/s (uncertified instrument) -C '1' - Wind speed obtained from anemometer in m/s (certified -C instrument) -C '3' - Wind speed estimated in knots (uncertified instrument) -C '4' - Wind speed obtained from anemometer in knots (certified -C instrument) -C '7' - Missing -C THE 27'TH (RESERVE) CHARACTER IS INDICATOR FOR STN OPER./PAST WX DATA - - CALL UFBINT(LUNIT,UFBINT_8,1,1,NRSV,'INPC');RRSV(1)=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,NRSV,'TIWM');TIWM=UFBINT_8 - IF(TIWM.LT.BMISS) THEN ! Effective 3/2002 - RRSV(2) = 7 - IF(NINT(TIWM).LE.15) RRSV(2) = ITIWM(NINT(TIWM)) - ELSE ! Prior to 3/2002 - CALL UFBINT(LUNIT,UFBINT_8,1,1,NRSV,'SUWS');RRSV(2)=UFBINT_8 - END IF - CALL UFBINT(LUNIT,UFBINT_8,1,1,NRSV,'ITSO');RRSV(3)=UFBINT_8 - RSV = '999 ' - DO I=1,3 - IF(RRSV(I).LT.BMISS) WRITE(RSV(I:I),'(I1)') NINT(RRSV(I)) - ENDDO - -C READ THE CATEGORY 51 SURFACE DATA FROM BUFR -C ------------------------------------------- - -cvvvvvdak port -cdak CALL UFBINT(LUNIT,PSL,1,1,IRET,'PMSL') -cdak CALL UFBINT(LUNIT,STP,1,1,IRET,'PRES') -cdak CALL UFBINT(LUNIT,SDR,1,1,IRET,'WDIR') -cdak CALL UFBINT(LUNIT,SSP,1,1,IRET,'WSPD') -cdak WSPD1 = SSP -cdak CALL UFBINT(LUNIT,STM,1,1,IRET,'TMDB') -cdak CALL UFBINT(LUNIT,DPD,1,1,IRET,'TMDP') - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'PMSL');PSL=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'PRES');STP=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'WDIR');SDR=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'WSPD');SSP=UFBINT_8 - WSPD1 = SSP - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TMDB');STM=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TMDP');DPD=UFBINT_8 - IF(SUBSET.NE.'NC000007') THEN -cdak CALL UFBINT(LUNIT,TMX,1,1,IRET,'MXTM') -cdak CALL UFBINT(LUNIT,TMI,1,1,IRET,'MITM') - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'MXTM');TMX=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'MITM');TMI=UFBINT_8 -caaaaadak port - ELSE - TMX = BMISS - TMI = BMISS - END IF -cvvvvvdak port -cdak CALL UFBINT(LUNIT,QSL,1,1,IRET,'QMPR') -cdak CALL UFBINT(LUNIT,QSP,1,1,IRET,'QMPR') -cdak CALL UFBINT(LUNIT,QMW,1,1,IRET,'QMWN') -cdak CALL UFBINT(LUNIT,QMT,1,1,IRET,'QMAT') -cdak CALL UFBINT(LUNIT,QMD,1,1,IRET,'QMDD') -cdak CALL UFBINT(LUNIT,HVZ,1,1,IRET,'HOVI') -cdak CALL UFBINT(LUNIT,PRW,1,1,IRET,'PRWE') -cdak CALL UFBINT(LUNIT,PW1,1,1,IRET,'PSW1') -cdak CALL UFBINT(LUNIT,PW2,1,1,IRET,'PSW2') -cdak CALL UFBINT(LUNIT,CCN,1,1,IRET,'TOCC') -cdak CALL UFBINT(LUNIT,CPT,1,1,IRET,'CHPT') -cdak CALL UFBINT(LUNIT,APT,1,1,IRET,'3HPC') - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'QMPR');QSL=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'QMPR');QSP=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'QMWN');QMW=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'QMAT');QMT=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'QMDD');QMD=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'HOVI');HVZ=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'PRWE');PRW=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'PSW1');PW1=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'PSW2');PW2=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TOCC');CCN=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'CHPT');CPT=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'3HPC');APT=UFBINT_8 -cdak IF(AMAX1(APT,CPT).GE.BMISS) THEN - IF(MAX(APT,CPT).GE.BMISS) THEN -caaaaadak port - APT = BMISS -cvvvvvdak port -cdak CALL UFBINT(LUNIT,APT24,1,1,IRET,'24PC') - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'24PC');APT24=UFBINT_8 -caaaaadak port - IF(APT24.LT.BMISS) THEN - APT = APT24 - CPT = BMISS - END IF - END IF - - -C READ THE CATEGORY 52 SURFACE DATA FROM BUFR -C ------------------------------------------- - -cvvvvvdak port -cdak CALL UFBINT(LUNIT,PC6,1,1,IRET,'TP06') -cdak CALL UFBINT(LUNIT,SND,1,1,IRET,'TOSD') -cdak CALL UFBINT(LUNIT,P24,1,1,IRET,'TP24') -cdak CALL UFBINT(LUNIT,PTO,1,1,IRET,'TOPC') -cdak CALL UFBINT(LUNIT,DOP,1,1,IRET,'.DTHTOPC') - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TP06');PC6=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TOSD');SND=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TP24');P24=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TOPC');PTO=UFBINT_8 -caaaaadak port - IF(PTO.LT.BMISS) THEN - IF(PC6.GE.BMISS.AND.NINT(DOP).EQ. 6) PC6 = PTO -cppppp - IF(PC6.GE.BMISS.AND.NINT(DOP).EQ. 6) - $ print *, '~~IW3UNP29/R04O29: PTO used for PC6 since latter ', - $ 'missing & 6-hr DOP' -cppppp - IF(P24.GE.BMISS.AND.NINT(DOP).EQ.24) P24 = PTO -cppppp - IF(P24.GE.BMISS.AND.NINT(DOP).EQ.24) - $ print *, '~~IW3UNP29/R04O29: PTO used for P24 since latter ', - $ 'missing & 24-hr DOP' -cppppp - END IF -cvvvvvdak port -cdak CALL UFBINT(LUNIT,POW,1,1,IRET,'POWW') -cdak CALL UFBINT(LUNIT,HOW,1,1,IRET,'HOWW') - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'POWW');POW=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'HOWW');HOW=UFBINT_8 -caaaaadak port - IF(SUBSET(1:5).EQ.'NC001') THEN - IF(SUBSET(6:8).NE.'006') THEN -cvvvvvdak port -cdak IF(AMIN1(POW,HOW).GE.BMISS) THEN - IF(MIN(POW,HOW).GE.BMISS) THEN -cdak CALL UFBINT(LUNIT,POW,1,1,IRET,'POWV') -cdak CALL UFBINT(LUNIT,HOW,1,1,IRET,'HOWV') - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'POWV');POW=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'HOWV');HOW=UFBINT_8 -caaaaadak port - END IF - ELSE -C PAOBS always have a missing elev, but we know they are at sea level - ELV = 0 - END IF - END IF -cvvvvvdak port -cdak CALL UFBINT(LUNIT,SWD,1,1,IRET,'DOSW') -cdak CALL UFBINT(LUNIT,SWP,1,1,IRET,'POSW') -cdak CALL UFBINT(LUNIT,SWH,1,1,IRET,'HOSW') -cdak CALL UFBINT(LUNIT,SST,1,1,IRET,'SST2') -cdak IF(SST.GE.BMISS) THEN -cdak CALL UFBINT(LUNIT,SST,1,1,IRET,'SST1') -cdak IF(SST.GE.BMISS) CALL UFBINT(LUNIT,SST,1,1,IRET,'STMP') -cdak END IF -cdak CALL UFBINT(LUNIT,SPG,1,1,IRET,'????') -cdak CALL UFBINT(LUNIT,SPD,1,1,IRET,'????') -cdak CALL UFBINT(LUNIT,SHC,1,1,IRET,'TDMP') -cdak CALL UFBINT(LUNIT,SAS,1,1,IRET,'ASMP') -cdak CALL UFBINT(LUNIT,WES,1,1,IRET,'????') - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'DOSW');SWD=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'POSW');SWP=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'HOSW');SWH=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SST1');SST=UFBINT_8 - IF(SST.GE.BMISS) THEN - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'STMP');SST=UFBINT_8 - ENDIF - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'????');SPG=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'????');SPD=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TDMP');SHC=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'ASMP');SAS=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'????');WES=UFBINT_8 -caaaaadak port - I52FLG = 0 -cvvvvvdak port -cdak IF(AMIN1(SND,P24,POW,HOW,SWD,SWP,SWH,SST,SPG,SPD,SHC,SAS,WES) - IF(MIN(SND,P24,POW,HOW,SWD,SWP,SWH,SST,SPG,SPD,SHC,SAS,WES) -caaaaadak port - $ .GE.BMISS.AND.(PC6.EQ.0..OR.PC6.GE.BMISS)) I52FLG= 1 - -C SOME CLOUD DATA IS NEEDED FOR LOW, MIDDLE, AND HIGH CLOUDS IN CAT. 51 -C --------------------------------------------------------------------- - - CALL UFBINT(LUNIT,CLDS_8,4,255,NCLD,'VSSO CLAM CLTP HOCB') - CLDS=CLDS_8 - CTH = -9999. - CTM = -9999. - CTL = -9999. - CHH = BMISS - CHM = BMISS - CHL = BMISS - IF(NCLD.EQ.0) THEN - CCM = BMISS - CCL = BMISS - ELSE - CCM = 0. - CCL = 0. - DO L=1,NCLD - VSS = CLDS(1,L) - CAM = CLDS(2,L) - CTP = CLDS(3,L) - CHT = BMISS - IF(CLDS(4,L).LT.BMISS) THEN - ! Prior to 3/2002 HBLCS was not available, this will - ! always be tested first because it is more precise - ! and may still be available for some types after - ! 3/2002 - CHT = CLDS(4,L) - ELSE - ! Effective 3/2002 this will be available and can be - ! used for types where HOCB is not available - less - ! precise and only available on 1 level - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'HBLCS') - HBLCS=UFBINT_8 - IF(NINT(HBLCS).LT.10) CHT = IHBLCS(NINT(HBLCS)) - END IF - IF(CHT.LT.BMISS) CHT = CHT * 3.2808 - IF(NINT(VSS).EQ.0) THEN - IF(NINT(CTP).GT.9.AND.NINT(CTP).LT.20) THEN - ITH = MOD(NINT(CTP),10) - KTH = JTH(ITH) - CTH = MAX(KTH,NINT(CTH)) -cvvvvvdak port -cdak CHH = MIN(NINT(CHT),NINT(CHH)) - CHH = MIN(CHT,CHH) -caaaaadak port - ELSE IF(NINT(CTP).LT.30) THEN - ITM = MOD(NINT(CTP),10) - CTM = MAX(ITM,NINT(CTM)) - IF(ITM.EQ.0) CAM = 0. -cvvvvvdak port -cdak CCM = MAX(NINT(CAM),NINT(CCM)) - CCM = MAX(CAM,CCM) -cdak CHM = MIN(NINT(CHT),NINT(CHM)) - CHM = MIN(CHT,CHM) -caaaaadak port - ELSE IF(NINT(CTP).LT.40) THEN - ITL = MOD(NINT(CTP),10) - KTL = JTL(ITL) - CTL = MAX(KTL,NINT(CTL)) - IF(ITL.EQ.0) CAM = 0. -cvvvvvdak port -cdak CCL = MAX(NINT(CAM),NINT(CCL)) - CCL = MAX(CAM,CCL) -cdak CHL = MIN(NINT(CHT),NINT(CHL)) - CHL = MIN(CHT,CHL) -caaaaadak port - ELSE IF(NINT(CTP).EQ.59) THEN - CTH = 10. - CTM = 10. - IF(CCM.EQ.0.) CCM = 15. - CTL = 10. - IF(CCL.EQ.0.) CCL = 15. - ELSE IF(NINT(CTP).EQ.60) THEN - CTH = 10. - ELSE IF(NINT(CTP).EQ.61) THEN - CTM = 10. - IF(CCM.EQ.0.) CCM = 15. - ELSE IF(NINT(CTP).EQ.62) THEN - CTL = 10. - IF(CCL.EQ.0.) CCL = 15. - END IF - END IF - ENDDO - END IF - IF(NINT(CTH).GT.-1.AND.NINT(CTH).LT.10) THEN - CTH = JTH(NINT(CTH)) - ELSE IF(NINT(CTH).NE.10) THEN - CTH = BMISS - END IF - IF(NINT(CTM).LT.0.OR.NINT(CTM).GT.10) THEN - CTM = BMISS - CCM = BMISS - END IF - IF(NINT(CTL).GT.-1.AND.NINT(CTL).LT.10) THEN - CTL = LTL(NINT(CTL)) - ELSE IF(NINT(CTL).NE.10) THEN - CTL = BMISS - CCL = BMISS - END IF - -C CALL FUNCTIONS TO TRANSFORM TO ON29/124 UNITS -C --------------------------------------------- - - PSL = E01O29(PSL) - STP = E01O29(STP) - SDR = E04O29(SDR,SSP) - SSP = E05O29(SDR,SSP) - IF(NINT(SDR).EQ.0) SDR = 360. - IF(SDR.GE.BMISS.AND.NINT(SSP).EQ.0) SDR = 360. - DPD = E07O29(DPD,STM) - STM = E06O29(STM) - TMX = E06O29(TMX) - TMI = E06O29(TMI) - - PSQ = E35O29(QSL) - SPQ = E35O29(QSP) - SWQ = E35O29(QMW) - STQ = E35O29(QMT) - DDQ = E35O29(QMD) - -C ADJUST QUIPS QUALITY MARKERS TO REFLECT UNPACKED ON29 CONVENTION - - IF(SUBSET(1:5).EQ.'NC001'.AND.PSQ.EQ.'C') STP = BMISS - IF(PSL.GE.BMISS) PSQ = ' ' - IF(STP.GE.BMISS) SPQ = ' ' -cvvvvvdak port -cdak IF(AMAX1(SDR,SSP).GE.BMISS) SWQ = ' ' - IF(MAX(SDR,SSP).GE.BMISS) SWQ = ' ' -caaaaadak port - IF(STM.GE.BMISS) STQ = ' ' - - IF(SUBSET(1:5).EQ.'NC000'.OR.SUBSET.EQ.'NC001004') THEN - HVZ = E09O29(HVZ) - ELSE - HVZ = E38O29(HVZ) - END IF - PRW = E10O29(PRW) - PW1 = E11O29(PW1) - PW2 = E11O29(PW2) - IF(DDQ.NE.'P'.AND.DDQ.NE.'H'.AND.DDQ.NE.'C') THEN - DDQ = ' ' - IPW2 = NINT(PW2) - IF(IPW2.GT.-1.AND.IPW2.LT.10) WRITE(DDQ,'(I1)') IPW2 - END IF - CCN = E12O29(CCN) - CHN = E14O29(CCL,CCM) - CTL = E15O29(CTL) - CTM = E15O29(CTM) - CTH = E15O29(CTH) - HCB = E18O29(CHL,CHM,CHH,CTL,CTM,CTH) - CPT = E19O29(CPT) - APT = E01O29(APT) - - PC6 = E20O29(PC6) - SND = E21O29(SND) - P24 = E20O29(P24) - DOP = E22O29(PC6) - POW = E23O29(POW) - HOW = E24O29(HOW) - SWD = E25O29(SWD) - SWP = E23O29(SWP) - SWH = E24O29(SWH) - SST = E06O29(SST) - SPG = E28O29(SPG) - SPD = E29O29(SPD) - SHC = E30O29(SHC) - SAS = E31O29(SAS) - WES = E32O29(WES) - -C MAKE THE UNPACKED ON29/124 REPORT INTO OBS -C ------------------------------------------ - - RSV2 = ' ' - CALL S01O29(SID,XOB,YOB,RHR,RCH,RSV,RSV2,ELV,ITP,RTP) - CALL S02O29(51,1,*9999) - IF(I52FLG.EQ.0) CALL S02O29(52,1,*9999) - -C ------------------------------------------------------------------ -C MISC DATA GOES INTO CATEGORY 08 -C ------------------------------------------------------------------ -C CODE FIGURE 020 - ALTIMETER SETTING IN 0.1*MB -C CODE FIGURE 081 - CALENDAR DAY MAXIMUM TEMPERATURE -C CODE FIGURE 082 - CALENDAR DAY MINIMUM TEMPERATURE -C CODE FIGURE 083 - SIX HOUR MAXIMUM TEMPERATURE -C CODE FIGURE 084 - SIX HOUR MINIMUM TEMPERATURE -C CODE FIGURE 085 - PRECIPITATION OVER PAST HOUR IN 0.01*INCHES -C CODE FIGURE 098 - DURATION OF SUNSHINE FOR CALENDAR DAY IN MINUTES -C CODE FIGURE 924 - WIND SPEED IN 0.01*M/S -C ------------------------------------------------------------------ - -cvvvvvdak port -cdak CALL UFBINT(LUNIT,ALS,1,1,IRET,'ALSE') - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'ALSE');ALS=UFBINT_8 -caaaaadak port - IF(ALS.LT.BMISS) THEN - OB8(1) = E01O29(ALS) - CF8(1) = 20 - Q81(1) = ' ' - Q82(1) = ' ' - CALL S02O29(8,1,*9999) - END IF - IF(SUBSET.EQ.'NC000007') THEN -cvvvvvdak port -cdak CALL UFBINT(LUNIT,TMXMNM,4,255,NTXM, -cdak $ '.DTHMXTM MXTM .DTHMITM MITM') - CALL UFBINT(LUNIT,TMXMNM_8,4,255,NTXM, - $ '.DTHMXTM MXTM .DTHMITM MITM');TMXMNM=TMXMNM_8 -caaaaadak port - IF(NTXM.GT.0) THEN - DO I = 1,NTXM - DO J = 1,3,2 - IF(NINT(TMXMNM(J,I)).EQ.24) THEN - IF(TMXMNM(J+1,I).LT.BMISS) THEN - TMX = E06O29(TMXMNM(J+1,I)) - IF(TMX.LT.0) THEN - OB8(1) = 1000 + ABS(NINT(TMX)) - ELSE - OB8(1) = NINT(TMX) - END IF - CF8(1) = 81 + INT(J/2) - Q81(1) = ' ' - Q82(1) = ' ' - CALL S02O29(8,1,*9999) - END IF - ELSE IF(NINT(TMXMNM(J,I)).EQ.6) THEN - IF(TMXMNM(J+1,I).LT.BMISS) THEN - TMX = E06O29(TMXMNM(J+1,I)) - IF(TMX.LT.0) THEN - OB8(1) = 1000 + ABS(NINT(TMX)) - ELSE - OB8(1) = NINT(TMX) - END IF - CF8(1) = 83 + INT(J/2) - Q81(1) = ' ' - Q82(1) = ' ' - CALL S02O29(8,1,*9999) - END IF - END IF - ENDDO - ENDDO - END IF - END IF -cvvvvvdak port -cdak CALL UFBINT(LUNIT,PC1,1,1,IRET,'TP01') - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TP01');PC1=UFBINT_8 -caaaaadak port - IF(PC1.LT.10000) THEN - OB8(1) = E20O29(PC1) - CF8(1) = 85 - Q81(1) = ' ' - Q82(1) = ' ' - CALL S02O29(8,1,*9999) - END IF -cvvvvvdak port -cdak CALL UFBINT(LUNIT,DUS,1,1,IRET,'TOSS') - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TOSS');DUS=UFBINT_8 -caaaaadak port - IF(NINT(DUS).LT.1000) THEN - OB8(1) = NINT(98000. + DUS) - CF8(1) = 98 - Q81(1) = ' ' - Q82(1) = ' ' - CALL S02O29(8,1,*9999) - END IF - IF(WSPD1.LT.BMISS) THEN - OB8(1) = NINT(WSPD1*10.) - CF8(1) = 924 - Q81(1) = ' ' - Q82(1) = ' ' - CALL S02O29(8,1,*9999) - END IF - - CALL S03O29(OBS,SUBSET,*9999,*9998) - - RETURN - - 9999 CONTINUE - R04O29 = 999 - RETURN - - 9998 CONTINUE - print *,'IW3UNP29/R04O29: RPT with ID= ',SID,' TOSSED - ZERO ', - $ 'CAT.1-6,51,52 LVLS' - R04O29 = -9999 - KSKSFC =KSKSFC + 1 - RETURN - - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - FUNCTION R05O29(LUNIT,OBS) -C ---> formerly FUNCTION AIRCFT - - COMMON/IO29EE/POB(255),QOB(255),TOB(255),ZOB(255),DOB(255), - $ SOB(255),VSG(255),CLP(255),CLA(255),OB8(255), - $ CF8(255) - COMMON/IO29FF/PQM(255),QQM(255),TQM(255),ZQM(255),WQM(255), - $ QCP(255),QCA(255),Q81(255),Q82(255) - COMMON/IO29CC/SUBSET,IDAT10 - COMMON/IO29BB/KNDX,KSKACF(8),KSKUPA,KSKSFC,KSKSAT,KSKSMI - - CHARACTER*80 HDSTR,LVSTR,QMSTR,RCSTR,CRAWR - CHARACTER*8 SUBSET,SID,SIDO,SIDMOD,E35O29,RSV,RSV2,CCL,CRAW(1,255) - CHARACTER*1 PQM,QQM,TQM,ZQM,WQM,QCP,QCA,Q81,Q82,CTURB(0:14) -cvvvvvdak port - REAL(8) RID_8,RCL,UFBINT_8,RNS_8 - REAL(8) HDR_8(20),RCT_8(5,255),ARR_8(10,255),RAW_8(1,255) -caaaaadak port - DIMENSION OBS(*),HDR(20),RCT(5,255),ARR(10,255),RAW(1,255) - EQUIVALENCE (RID_8,SID),(RCL,CCL),(RAW_8,CRAW) - - SAVE - - DATA HDSTR/'RPID CLON CLAT HOUR MINU SECO '/ - DATA LVSTR/'PRLC TMDP TMDB WDIR WSPD '/ - DATA QMSTR/'QMPR QMAT QMDD QMGP QMWN '/ - DATA RCSTR/'RCHR RCMI RCTS '/ - - DATA BMISS /10E10 / - DATA CTURB/'0','1','2','3','0','1','2','3','0','1','2',4*'3'/ - -C CHECK IF THIS IS A PREPBUFR FILE -C -------------------------------- - - R05O29 = 99 -c#V#V#dak - future -cdak IF(SUBSET.EQ.'AIRCFT') R05O29 = PRPCFT(LUNIT,OBS) -cdak IF(SUBSET.EQ.'AIRCAR') R05O29 = PRPCFT(LUNIT,OBS) -caaaaadak - future - IF(R05O29.NE.99) RETURN - R05O29 = 0 - - CALL S05O29 - -C PUT THE HEADER INFORMATION INTO ON29 FORMAT -C ------------------------------------------- - -cvvvvvdak port -cdak CALL UFBINT(LUNIT,HDR,20, 1,IRET,HDSTR) - CALL UFBINT(LUNIT,HDR_8,20, 1,IRET,HDSTR);HDR(2:)=HDR_8(2:) - IF(IRET.EQ.0) SID = ' ' -cdak CALL UFBINT(LUNIT,RCT, 5,255,NRCT,RCSTR) - CALL UFBINT(LUNIT,RCT_8, 5,255,NRCT,RCSTR);RCT=RCT_8 -caaaaadak port - IF(HDR(5).GE.BMISS) HDR(5) = 0 - IF(HDR(6).GE.BMISS) HDR(6) = 0 - RCTIM = NINT(RCT(1,1))+NINT(RCT(2,1))/60. - RID_8 = HDR_8(1) - XOB = HDR(2) - YOB = HDR(3) - RHR = BMISS - IF(HDR(4).LT.BMISS) RHR = NINT(HDR(4)) + ((NINT(HDR(5)) * 60.) + - $ NINT(HDR(6)))/3600. - RCH = RCTIM - -C TRY TO FIND FIND THE FLIGHT LEVEL HEIGHT -C ---------------------------------------- - -cvvvvvdak port -cdak CALL UFBINT(LUNIT,HDR,20,1,IRET,'PSAL FLVL IALT HMSL PRLC') - CALL UFBINT(LUNIT,HDR_8,20,1,IRET,'PSAL FLVL IALT HMSL PRLC') - HDR=HDR_8 -caaaaadak port - ELEV = BMISS - IF(HDR(5).LT.BMISS) ELEV = E03O29(HDR(5)*.01) - IF(HDR(4).LT.BMISS) ELEV = HDR(4) -C FOR MDCARS ACARS DATA ONLY: -C UNCOMMENTING NEXT LINE WILL SET P-ALT TO REPORTED "IALT" VALUE -- -C IN THIS CASE, PREPDATA WILL LATER GET PRESS. VIA STD. ATMOS. FCN. -C COMMENTING NEXT LINE WILL USE REPORTED PRESSURE "PRLC" TO GET -C P-ALT VIA INVERSE STD. ATMOS. FCN. -- IN THIS CASE, PREPDATA WILL -C LATER RETURN THIS SAME PRESS. VIA STD. ATMOS. FCN. -cdak IF(HDR(3).LT.BMISS) ELEV = HDR(3) - IF(HDR(2).LT.BMISS) ELEV = HDR(2) + SIGN(0.0000001,HDR(2)) - IF(HDR(1).LT.BMISS) ELEV = HDR(1) + SIGN(0.0000001,HDR(1)) - ELV = ELEV - -C ACFT NAVIGATION SYSTEM STORED IN INSTR. TYPE LOCATION (AS WITH ON29) -C -------------------------------------------------------------------- - - ITP = 99 -cvvvvvdak port -cdak CALL UFBINT(LUNIT,RNS,1,1,IRET,'ACNS') - CALL UFBINT(LUNIT,RNS_8,1,1,IRET,'ACNS');RNS=RNS_8 -caaaaadak port - IF(RNS.LT.BMISS) THEN - IF(NINT(RNS).EQ.0) THEN - ITP = 97 - ELSE IF(NINT(RNS).EQ.1) THEN - ITP = 98 - END IF - END IF - - RTP = E33O29(SUBSET,SID) - - CALL UFBINT(LUNIT,RCL,1,1,IRET,'BORG') ! Effective 3/2002 - IF(IRET.EQ.0) THEN - CCL = ' ' - CALL UFBINT(LUNIT,RCL,1,1,IRET,'ICLI') ! Prior to 3/2002 - IF(IRET.EQ.0) CCL = ' ' - END IF -cvvvvv temporary? - IF(CCL(1:4).EQ.'KAWN') THEN - -C This will toss all Carswell/Tinker Aircraft reports - until Jack -C fixes the dup-check to properly remove the duplicate Carswell -C reports, we are better off removing them all since they are -C often of less quality than the non-Carswell AIREP reports -C RIGHT NOW WE ARE HAPPY WITH DUP-CHECKER'S HANDLING OF THESE, -C SO COMMENT THIS OUT - -cdak R05O29 = -9999 -cdak KSKACF(?) = KSKACF(?) + 1 -cdak RETURN - END IF -caaaaa temporary? - IF(SUBSET.EQ.'NC004003') THEN - -C ------------------------------------ -C ASDAR/AMDAR AIRCRAFT TYPE COME HERE -C ------------------------------------ - -cvvvvv temporary? -C Currently, we throw out any ASDAR/AMDAR reports with header "LFPW" - -C simply because they never appeared in NAS9000 ON29 AIRCFT data set -C (NOTE: These should all have ACID's that begin with "IT") -C (NOTE: These will not be removed from the new decoders, because -C they are apparently unique reports of reasonable -C quality. EMC just needs to test them in a parallel run -C to make sure prepacqc and the analysis handle them okay.) - -C NOTE: NO, NO DON'T THROW THEM OUT ANY MORE !!!!!! -C Keyser -- 6/13/97 - -CDAKCDAK if(ccl(1:4).eq.'LFPW') then -cppppp -cdak print *, 'IW3UNP29/R05O29: TOSS "LFPW" AMDAR with ID = ',SID, -cdak $ '; CCL = ',CCL(1:4) -cppppp -CDAKCDAK R05O29 = -9999 -CDAKCDAK kskacf(2) = kskacf(2) + 1 -CDAKCDAK return -CDAKCDAK end if -caaaaa temporary? - -C MODIFY REPORT ID AS WAS DONE IN OLD ON29 AIRCRAFT PACKER -C -------------------------------------------------------- - - CALL S06O29(SID,SIDMOD) - SIDO = SID - SID = SIDMOD - -C THE 25'TH (RESERVE) CHARACTER INDICATES PHASE OF FLIGHT -C THE 26'TH (RESERVE) CHARACTER INDICATES TEMPERATURE PRECISION -C THE 27'TH (RESERVE) CHARACTER INDICATES CARSWELL (NEVER HAPPENS) -C (NOTE: NAS9000 ONLY ASSIGNED HEADER "KAWN" AS CARSWELL, ALTHOUGH -C "PHWR" AND "EGWR" ARE ALSO APPARENTLY ALSO CARSWELL) - - RSV = '71 ' -cvvvvvdak port -cdak CALL UFBINT(LUNIT,POF,1,1,IRET,'POAF') - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'POAF');POF=UFBINT_8 - IF(POF.LT.BMISS) WRITE(RSV(1:1),'(I1)') NINT(POF) -cdak CALL UFBINT(LUNIT,PCT,1,1,IRET,'PCAT') - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'PCAT');PCT=UFBINT_8 -caaaaadak port - IF(NINT(PCT).GT.1) RSV(2:2) = '0' - IF(CCL(1:4).EQ.'KAWN') RSV(3:3) = 'C' - - ELSE IF(SUBSET.EQ.'NC004004') THEN - -C ------------------------------ -C ACARS AIRCRAFT TYPE COME HERE -C ------------------------------ - - CALL UFBINT(LUNIT,RID_8,1,1,IRET,'ACRN') - IF(IRET.EQ.0) SID = 'ACARS ' - KNDX = KNDX + 1 - RSV = '999 ' - - ELSE IF(SUBSET.EQ.'NC004001'.OR.SUBSET.EQ.'NC004002') THEN - -C ----------------------------------------- -C AIREP AND PIREP AIRCRAFT TYPES COME HERE -C ----------------------------------------- - -C MAY POSSIBLY NEED TO MODIFY THE RPID HERE -C ----------------------------------------- - - IF(SID(6:6).EQ.'Z') SID(6:6) = 'X' - IF(SID.EQ.'A '.OR.SID.EQ.' '.OR.SID(1:3).EQ.'ARP' - $ .OR.SID(1:3).EQ.'ARS') SID = 'AIRCFT ' - -cvvvvv temporary? -C Determined that Hickum AFB reports are much like Carswell - they have -C problems! They also are usually duplicates of either Carswell or -C non-Carswell reports. Apparently the front-end processing filters -C them out (according to B. Ballish). So, to make things match, -C we will do the same here. -C ACTUALLY, JEFF ATOR HAS REMOVED THESE FROM THE DECODER, SO WE -C SHOULD NEVER EVEN SEE THEM IN THE DATABASE, but it won't hurt -C anything to keep this in here. -C (NOTE: These all have headers of "PHWR") - - if(ccl(1:4).eq.'PHWR') then -cppppp -cdak print *, 'IW3UNP29/R05O29: TOSS "PHWR" AIREP with ID = ',SID, -cdak $ '; CCL = ',CCL(1:4) -cppppp - R05O29 = -9999 - kskacf(8) = kskacf(8) + 1 - return - end if -caaaaa temporary? - -cvvvvv temporary? -C 1) Carswell/Tinker AMDARS are processed as AIREP subtypes. -C Nearly all of them are duplicated as true non-Carswell AMDARS in -C the AMDAR subtype. The earlier version of the aircraft dup- -C checker could not remove such duplicates; the new verison now -C in operations can remove these. SO, WE HAVE COMMENTED THIS OUT. -C -C The Carswell AMDARS can be identified by the string " Sxyz" in -C the raw report (beyond byte 40), where y is 0,1, or 2. -C (NOTE: Apparently Carswell here applies to more headers than -C just "KAWN", so report header is not even checked.) - -C 2) Carswell/Tinker ACARS are processed as AIREP subtypes. -C These MAY duplicate true non-Carswell ACARS in the ACARS -C subtype. The NAS9000 decoder always excluded this type (no -C dup-checking was done). All of these will be removed here. -C The Carswell ACARS can be identified by the string " Sxyz" in -C the raw report (beyond byte 40), where y is 3 or greater. -C (NOTE: Apparently Carswell here applies to more headers than -C just "KAWN", so report header is not even checked.) - -cvvvvvdak port -cdak call ufbint(lunit,raw,1,255,nlev,'RRSTG') - call ufbint(lunit,raw_8,1,255,nlev,'RRSTG');raw=raw_8 -caaaaadak port - if(nlev.gt.5) then - ni = -7 - do mm = 6,nlev - ni = ni + 8 - crawr(ni:ni+7) = craw(1,mm) - if(ni+8.gt.80) go to 556 - enddo - 556 continue - do mm = 1,ni+7 - if(crawr(mm:mm+1).eq.' S') then - if((crawr(mm+2:mm+2).ge.'0'.and.crawr(mm+2:mm+2).le. - $ '9').or.crawr(mm+2:mm+2).eq.'/') then - if((crawr(mm+3:mm+3).ge.'0'.and.crawr(mm+3:mm+3) - $ .le.'9').or.crawr(mm+3:mm+3).eq.'/') then - if((crawr(mm+4:mm+4).ge.'0'.and. - $ crawr(mm+4:mm+4).le.'9').or.crawr(mm+4:mm+4) - $ .eq.'/') then -cvvvvvdak port -cppppp -cdak print *, 'IW3UNP29/R05O29: For ',SID,', raw_8(',ni+7,') = ', -cdak $ crawr(1:ni+7) -cppppp -caaaaadak port - if(crawr(mm+3:mm+3).lt.'3') then - -C THIS IS A CARSWELL/TINKER AMDAR REPORT --> THROW OUT -C (NOT ANYMORE, DUP-CHECKER IS HANDLING THESE OKAY NOW) -C ---------------------------------------------------- - -cppppp -cdak print *, 'IW3UNP29/R05O29: Found a Carswell AMDAR for ',SID, -cdak $ '; CCL = ',CCL(1:4) -cppppp -cdak R05O29 = -9999 -cdak KSKACF(3) = KSKACF(3) + 1 -cdak RETURN - else - -C THIS IS A CARSWELL/TINKER ACARS REPORT --> THROW OUT -C ---------------------------------------------------- - -cppppp -cdak print *, 'IW3UNP29/R05O29: Found a Carswell ACARS for ',SID, -cdak $ '; CCL = ',CCL(1:4) -cppppp - R05O29 = -9999 - KSKACF(4) = KSKACF(4) + 1 - RETURN - - end if - end if - end if - end iF - end if - if(mm+5.gt.ni+7) go to 557 - enddo - 557 continue - END IF -caaaaa temporary? - -C THE 25'TH (RESERVE) CHARACTER INDICATES 8'TH CHARACTER OF STATION ID -C THE 26'TH (RESERVE) CHARACTER INDICATES 7'TH CHARACTER OF STATION ID -C THE 27'TH (RESERVE) CHARACTER INDICATES CARSWELL -C (NOTE: NAS9000 ONLY ASSIGNED HEADER "KAWN" AS CARSWELL, ALTHOUGH -C "PHWR" AND "EGWR" ARE ALSO APPARENTLY ALSO CARSWELL) - - RSV = SID(8:8)//SID(7:7)//' ' - IF(CCL(1:4).EQ.'KAWN') RSV(3:3) = 'C' - - END IF - -C ----------------------------- -C ALL AIRCRAFT TYPES COME HERE -C ----------------------------- - -cvvvvvdak port -cdak CALL UFBINT(LUNIT,DGT,1,1,IRET,'DGOT') - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'DGOT');DGT=UFBINT_8 - -C PUT THE LEVEL DATA INTO ON29 UNITS -C ---------------------------------- - -cdak CALL UFBINT(LUNIT,ARR,10,255,NLEV,LVSTR) - CALL UFBINT(LUNIT,ARR_8,10,255,NLEV,LVSTR);ARR=ARR_8 -caaaaadak port - DO L=1,NLEV - -Cvvvvv temporary? -C Even though PREPDATA filters out any aircraft reports with a missing -C wind, or AIREP/PIREP and AMDAR reports below 100 and 2286 meters, -C respectively, it will be done here for now in order to help in -C the comparison between counts coming from the Cray dumps and the -C NAS9000 ON29 dumps (the NAS9000 ON29 maker filters these out). - -C NO, NO LET'S NOT FILTER HERE ANY MORE - LEAVE IT UP TO PREPDATA -C SINCE WE AREN'T COMPARING NAS9000 AND CRAY COUNTS ANY MORE -C Keyser -- 6/13/97 - -CDAKCDAK if(arr(4,1).ge.bmiss.or.arr(5,1).ge.bmiss) then -CDAKCDAK R05O29 = -9999 -CDAKCDAK kskacf(5) = kskacf(5) + 1 -CDAKCDAK return -CDAKCDAK end if -CDAKCDAK if(subset.eq.'NC004003'.and.elev.lt.2286.) then -CDAKCDAK R05O29 = -9999 -CDAKCDAK kskacf(6) = kskacf(6) + 1 -CDAKCDAK return -CDAKCDAK else if(subset.ne.'NC004004'.and.elev.lt.100.) then -CDAKCDAK R05O29 = -9999 -CDAKCDAK kskacf(7) = kskacf(7) + 1 -CDAKCDAK return -CDAKCDAK end if -caaaaa temporary? - - POB(L) = E01O29(ARR(1,L)) - QOB(L) = E07O29(ARR(2,L),ARR(3,L)) - TOB(L) = E06O29(ARR(3,L)) - ZOB(L) = ELEV - DOB(L) = E04O29(ARR(4,L),ARR(5,L)) - SOB(L) = E05O29(ARR(4,L),ARR(5,L)) - ENDDO - WSPD1 = ARR(5,1) - -cvvvvvdak port -cdak CALL UFBINT(LUNIT,ARR,10,255,NLEV,QMSTR) - CALL UFBINT(LUNIT,ARR_8,10,255,NLEV,QMSTR);ARR=ARR_8 -caaaaadak port - - IF(SUBSET.EQ.'NC004004') THEN - -C --------------------------------------------------------- -C ACARS AIRCRAFT TYPE COME HERE FOR QUALITY MARK ASSIGNMENT -C --------------------------------------------------------- - - DO L=1,NLEV - PQM(L) = E35O29(ARR(1,L)) - TQM(L) = E35O29(ARR(2,L)) - QQM(L) = E35O29(ARR(3,L)) - ZQM(L) = E35O29(ARR(4,L)) - WQM(L) = E35O29(ARR(5,L)) - ENDDO - -C DEFAULT Q.MARK FOR WIND: "A" -C ---------------------------- - - IF(NLEV.EQ.0.OR.ARR(5,1).GE.BMISS) WQM(1) = 'A' - - ELSE - -C -------------------------------------------------------------- -C ALL OTHER AIRCRAFT TYPES COME HERE FOR QUALITY MARK ASSIGNMENT -C -------------------------------------------------------------- - - DO L=1,NLEV - ARR(4,L) = 2 - -C IF KEEP FLAG ON WIND, ENTIRE REPORT GETS KEEP FLAG ('H' IN ZQM) -C -- unless.... -C IF PURGE FLAG ON WIND, ENTIRE REPORT GETS PURGE FLAG ('P' IN ZQM) -C IF PURGE FLAG ON TEMP, ENTIRE REPORT GETS PURGE FLAG ('P' IN ZQM) -C IF FAIL FLAG ON WIND, ENTIRE REPORT GETS FAIL FLAG ('F' IN ZQM) -C IF FAIL FLAG ON TEMP, ENTIRE REPORT GETS FAIL FLAG ('F' IN ZQM) -C ----------------------------------------------------------------- - - IF(ARR(5,L).EQ.0.AND.(ARR(2,L).LT.10.OR.ARR(2,L).GT.15))THEN - ARR(4,L) = 0 - ELSE IF(ARR(5,L).EQ.14.OR.ARR(2,L).EQ.14) THEN - ARR(4,L) = 14 - ELSE IF(ARR(5,L).EQ.13.OR.ARR(2,L).EQ.13) THEN - ARR(4,L) = 13 - END IF - PQM(L) = ' ' - TQM(L) = ' ' - QQM(L) = ' ' - ZQM(L) = E35O29(ARR(4,L)) - -C DEGREE OF TURBULENCE IS STORED IN MOISTURE Q.M. SLOT -C ---------------------------------------------------- - - IF(NINT(DGT).LT.15) QQM(L) = CTURB(NINT(DGT)) - ENDDO - -C DEFAULT Q.MARK FOR WIND: "C" -C ---------------------------- - - WQM(1) = 'C' - END IF - -C PUT THE UNPACKED ON29 REPORT INTO OBS -C ------------------------------------- - - RSV2 = ' ' - CALL S01O29(SID,XOB,YOB,RHR,RCH,RSV,RSV2,ELV,ITP,RTP) - CALL S02O29(6,1,*9999) - -C ------------------------------------------------------------------ -C MISC DATA GOES INTO CATEGORY 08 -C ------------------------------------------------------------------ -C CODE FIGURE 021 - REPORT SEQUENCE NUMBER -C CODE FIGURE 917 - CHARACTERS 1 AND 2 OF ACTUAL STATION IDENTIFICATION -C (CURRENTLY ONLY FOR ASDAR/AMDAR) -C CODE FIGURE 918 - CHARACTERS 3 AND 4 OF ACTUAL STATION IDENTIFICATION -C (CURRENTLY ONLY FOR ASDAR/AMDAR) -C CODE FIGURE 919 - CHARACTERS 5 AND 6 OF ACTUAL STATION IDENTIFICATION -C (CURRENTLY ONLY FOR ASDAR/AMDAR) -C CODE FIGURE 920 - CHARACTERS 7 AND 8 OF ACTUAL STATION IDENTIFICATION -C (CURRENTLY ONLY FOR ASDAR/AMDAR AND ACARS) -C CODE FIGURE 921 - OBSERVATION TIME TO NEAREST 1000'TH OF AN HOUR -C (CURRENTLY ONLY FOR ACARS) -C CODE FIGURE 922 - FIRST TWO CHARACTERS OF BULLETIN BEING MONITORED -C CODE FIGURE 923 - LAST TWO CHARACTERS OF BULLETIN BEING MONITORED -C CODE FIGURE 924 - WIND SPEED IN 0.01*M/S -C ------------------------------------------------------------------ - - IF(SUBSET.EQ.'NC004004') THEN - OB8(1) = KNDX - CF8(1) = 21 - Q81(1) = ' ' - Q82(1) = ' ' - CALL S02O29(8,1,*9999) - OB8(1) = 99999. - Q81(1) = SID(7:7) - Q82(1) = SID(8:8) - CF8(1) = 920 - CALL S02O29(8,1,*9999) - IF(RHR.LT.BMISS) THEN - OB8(1) = NINT((RHR*1000.)+0.0000001) - CF8(1) = 921 - Q81(1) = ' ' - Q82(1) = ' ' - CALL S02O29(8,1,*9999) - END IF - ELSE IF(SUBSET.EQ.'NC004003') THEN - DO KKK = 1,4 - OB8(KKK) = 99999. - Q81(KKK) = SIDO(2*KKK-1:2*KKK-1) - Q82(KKK) = SIDO(2*KKK:2*KKK) - CF8(KKK) = 916 + KKK - CALL S02O29(8,KKK,*9999) - ENDDO - END IF - IF(CCL.NE.' ') THEN - OB8(2) = 99999. - Q81(2) = CCL(1:1) - Q82(2) = CCL(2:2) - CF8(2) = 922 - CALL S02O29(8,2,*9999) - OB8(3) = 99999. - Q81(3) = CCL(3:3) - Q82(3) = CCL(4:4) - CF8(3) = 923 - CALL S02O29(8,3,*9999) - END IF - IF(WSPD1.LT.BMISS) THEN - OB8(4) = NINT(WSPD1*10.) - CF8(4) = 924 - Q81(4) = ' ' - Q82(4) = ' ' - CALL S02O29(8,4,*9999) - END IF - - CALL S03O29(OBS,SUBSET,*9999,*9998) - - RETURN - - 9999 CONTINUE - R05O29 = 999 - RETURN - - 9998 CONTINUE - print *,'IW3UNP29/R05O29: RPT with ID= ',SID,' TOSSED - ZERO ', - $ 'CAT.1-6,51,52 LVLS' - R05O29 = -9999 - KSKACF(1) = KSKACF(1) + 1 - RETURN - - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - FUNCTION R06O29(LUNIT,OBS) -C ---> formerly FUNCTION SATWND - - COMMON/IO29EE/POB(255),QOB(255),TOB(255),ZOB(255),DOB(255), - $ SOB(255),VSG(255),CLP(255),CLA(255),OB8(255), - $ CF8(255) - COMMON/IO29FF/PQM(255),QQM(255),TQM(255),ZQM(255),WQM(255), - $ QCP(255),QCA(255),Q81(255),Q82(255) - COMMON/IO29CC/SUBSET,IDAT10 - COMMON/IO29BB/KNDX,KSKACF(8),KSKUPA,KSKSFC,KSKSAT,KSKSMI - COMMON/IO29KK/KOUNT(499,18) - - CHARACTER*80 HDSTR,LVSTR,QMSTR,RCSTR - CHARACTER*8 SUBSET,SID,E35O29,RSV,RSV2 - CHARACTER*3 CINDX3 - CHARACTER*1 PQM,QQM,TQM,ZQM,WQM,QCP,QCA,Q81,Q82,CSAT(499), - $ CPRD(9),CINDX7,C7(26),CPROD(0:4),CPRDF(3) - INTEGER IPRDF(3) -cvvvvvdak port - REAL(8) RID_8,UFBINT_8 - REAL(8) HDR_8(20),RCT_8(5,255),ARR_8(10,255) -caaaaadak port - DIMENSION OBS(*),HDR(20),RCT(5,255),ARR(10,255) - EQUIVALENCE (RID_8,SID) - - SAVE - - DATA HDSTR/'RPID CLON CLAT HOUR MINU SAID '/ - DATA LVSTR/'PRLC TMDP TMDB WDIR WSPD '/ - DATA QMSTR/'QMPR QMAT QMDD QMGP SWQM '/ - DATA RCSTR/'RCHR RCMI RCTS '/ - - DATA BMISS /10E10 / - DATA CSAT /'A','B','C','D',45*'?','Z','W','X','Y','Z','W','X', - $ 'Y','Z','W',90*'?','R','O','P','Q','R','O','P','Q','R','O', - $ 339*'?','V'/ - DATA CPROD /'C','D','?','?','E'/ - DATA CPRDF /'C','B','V'/ - DATA IPRDF / 1 , 6 , 4 / - DATA CPRD /'C','V','I','W','P','T','L','Z','G'/ - DATA C7 /'A','B','C','D','E','F','G','H','I','J','K','L','M', - $ 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z'/ - -C CHECK IF THIS IS A PREPBUFR FILE -C -------------------------------- - - R06O29 = 99 -c#V#V#dak - future -cdak IF(SUBSET.EQ.'SATWND') R06O29 = PRPWND(LUNIT,OBS) -caaaaadak - future - IF(R06O29.NE.99) RETURN - R06O29 = 0 - - CALL S05O29 - -C TRY TO FIND FIND THE HEIGHT ASSIGNMENT -C -------------------------------------- - -cvvvvvdak port -cdak CALL UFBINT(LUNIT,HDR,20,1,IRET,'HGHT PRLC') - CALL UFBINT(LUNIT,HDR_8,20,1,IRET,'HGHT PRLC');HDR=HDR_8 -caaaaadak port - ELEV = BMISS - IF(HDR(2).LT.BMISS) ELEV = E03O29(HDR(2)*.01) - IF(HDR(1).LT.BMISS) ELEV = HDR(1) - -C PUT THE HEADER INFORMATION INTO ON29 FORMAT -C ------------------------------------------- - -cvvvvvdak port -cdak CALL UFBINT(LUNIT,HDR,20, 1,IRET,HDSTR) -cdak CALL UFBINT(LUNIT,RCT, 5,255,NRCT,RCSTR) - CALL UFBINT(LUNIT,HDR_8,20, 1,IRET,HDSTR);HDR(2:)=HDR_8(2:) - CALL UFBINT(LUNIT,RCT_8, 5,255,NRCT,RCSTR);RCT=RCT_8 -caaaaadak port - IF(HDR(5).GE.BMISS) HDR(5) = 0 - RCTIM = NINT(RCT(1,1))+NINT(RCT(2,1))/60. - RID_8 = HDR_8(1) - XOB = HDR(2) - YOB = HDR(3) - RHR = BMISS - IF(HDR(4).LT.BMISS) RHR = NINT(HDR(4))+NINT(HDR(5))/60. - RCH = RCTIM - RSV = '990 ' - -C THE 25'TH (RESERVE) CHARACTER IS THE CLOUD MASK/DEEP LAYER INDICATOR -C {=2 - CLOUD TOP (NORMAL CLOUD DRIFT), =1 - DEEP LAYER, -C =9 - INDICATOR MISSING, THUS REVERTS TO DEFAULT CLOUD TOP} -C (=9 FOR ALL BUT U.S. HIGH-DENSITY SATWND TYPES) -C -------------------------------------------------------------------- - -C THE 27'TH (RESERVE) CHARACTER INDICATES THE PRODUCER OF THE SATWND -C ------------------------------------------------------------------ - -C THE INSTRUMENT TYPE INDICATES THE PRODUCT TYPE -C ---------------------------------------------- - - ITP = 99 - -C REPROCESS THE STN. ID -C --------------------- - -C REPROCESSED CHAR 1 -----> GOES: JBUFR CHAR 1 -C -----> METEOSAT: SAT. NO. 52, 56 GET 'X' -C SAT. NO. 53, 57 GET 'Y' -C SAT. NO. 50, 54, 58 GET 'Z' -C SAT. NO. 51, 55, 59 GET 'W' -C -----> GMS(JA): SAT. NO. 152,156 GET 'P' -C SAT. NO. 153,157 GET 'Q' -C SAT. NO. 150,154,158 GET 'R' -C SAT. NO. 151,155,159 GET 'O' -C -----> INSAT: SAT. NO. 499 GET 'V' -C REPROCESSED CHAR 2 -----> GOES: RETURNED VALUE IN BUFR FOR 'SWPR' -C (PRODUCER) -C -----> OTHERS: SAT. PRODUCER -- ESA GET 'C' -C -- GMS GET 'D' -C -- INSAT GET 'E' -C REPROCESSED CHAR 6 -----> GOES: JBUFR CHAR 6 -C -----> OTHERS -- INFRA-RED CLOUD DRIFT GET 'C' -C -- VISIBLE CLOUD DRIFT GET 'B' -C -- WATER VAPOR GET 'V' -C REPROCESSED CHAR 3-5 ---> SEQUENTIAL SERIAL INDEX (001 - 999) -C (UNIQUE FOR EACH JBUFR CHAR 1/6 COMB.) -C REPROCESSED CHAR 7 -----> GROUP NUMBER FOR SERIAL INDEX IN -C REPROCESSED CHAR 3-5 (0 - 9, A - Z) -C REPROCESSED CHAR 8 -----> ALWAYS BLANK (' ') FOR NOW - - READ(SUBSET(8:8),'(I1)') INUM - IF(SID(1:1).GE.'A'.AND.SID(1:1).LE.'D') THEN -cvvvvvdak port -cdak CALL UFBINT(LUNIT,SWPR,1,1,IRET,'SWPR') - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SWPR');SWPR=UFBINT_8 -caaaaadak port - IF(NINT(SWPR).GT.0.AND.NINT(SWPR).LT.10) - $ WRITE(RSV(3:3),'(I1)') NINT(SWPR) - SID(2:2) = RSV(3:3) -cvvvvvdak port -cdak CALL UFBINT(LUNIT,SWTP,1,1,IRET,'SWTP') - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SWTP');SWTP=UFBINT_8 -caaaaadak port - IF(SWTP.LT.BMISS) ITP = NINT(SWTP) -cvvvvvdak port -cdak CALL UFBINT(LUNIT,SWDL,1,1,IRET,'SWDL') - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SWDL');SWDL=UFBINT_8 -caaaaadak port - IF(NINT(SWDL).GT.-1.AND.NINT(SWDL).LT.10) - $ WRITE(RSV(1:1),'(I1)') NINT(SWDL) - ELSE - SID = '????????' - IF(NINT(HDR(6)).LT.500) THEN - SID(1:1) = CSAT(NINT(HDR(6))) - SID(2:2) = CPROD(NINT(HDR(6))/100) - RSV(3:3) = SID(2:2) - END IF - IF(INUM.LT.4) THEN - SID(6:6) = CPRDF(INUM) - ITP = IPRDF(INUM) - END IF - END IF - CINDX3 = '???' - CINDX7 = '?' - IF(NINT(HDR(6)).LT.500.AND.ITP.LT.19) THEN - KOUNT(NINT(HDR(6)),ITP) = MIN(KOUNT(NINT(HDR(6)),ITP)+1,35999) - KOUNT3 = MOD(KOUNT(NINT(HDR(6)),ITP),1000) - KOUNT7 = INT(KOUNT(NINT(HDR(6)),ITP)/1000) - WRITE(CINDX3,'(I3.3)') KOUNT3 - IF(KOUNT7.LT.10) THEN - WRITE(CINDX7,'(I1.1)') KOUNT7 - ELSE - CINDX7 = C7(KOUNT7-9) - END IF - END IF - SID = SID(1:2)//CINDX3//SID(6:6)//CINDX7//' ' - - ELV = ELEV - RTP = E33O29(SUBSET,SID) - -C PUT THE LEVEL DATA INTO ON29 UNITS -C ---------------------------------- - -cvvvvvdak port -cdak CALL UFBINT(LUNIT,ARR,10,255,NLEV,LVSTR) - CALL UFBINT(LUNIT,ARR_8,10,255,NLEV,LVSTR);ARR=ARR_8 -caaaaadak port - DO L=1,NLEV - POB(L) = E01O29(ARR(1,L)) - -C GROSS CHECK ON PRESSURE -C ----------------------- - - IF(NINT(POB(L)).EQ.0) THEN - print *,'~~IW3UNP29/R06O29: RPT with ID= ',SID,' TOSSED - ', - $ 'PRES. IS ZERO MB' - R06O29 = -9999 - KSKSAT = KSKSAT + 1 - RETURN - END IF - - QOB(L) = E07O29(ARR(2,L),ARR(3,L)) - TOB(L) = E06O29(ARR(3,L)) - ZOB(L) = ELEV - DOB(L) = E04O29(ARR(4,L),ARR(5,L)) - SOB(L) = E05O29(ARR(4,L),ARR(5,L)) - ENDDO - WSPD1 = ARR(5,1) - -C DETERMINE QUALITY MARKERS -C ------------------------- - -cvvvvvdak port -cdak CALL UFBINT(LUNIT,ARR,10,255,NLEV,QMSTR) -cdak CALL UFBINT(LUNIT,RFFL,1,1,IRET,'RFFL') - CALL UFBINT(LUNIT,ARR_8,10,255,NLEV,QMSTR);ARR=ARR_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'RFFL');RFFL=UFBINT_8 -caaaavdak port - IF(RFFL.LT.BMISS.AND.(NINT(ARR(5,1)).EQ.2.OR.NINT(ARR(5,1)).GE. - $ BMISS)) THEN - IF(NINT(RFFL).GT.84) THEN - ARR(5,1) = 1 - ELSE IF(NINT(RFFL).GT.55) THEN - ARR(5,1) = 2 - ELSE IF(NINT(RFFL).GT.49) THEN - ARR(5,1) = 3 - ELSE - ARR(5,1) = 13 - END IF - END IF - - DO L=1,NLEV - WQM(L) = E35O29(ARR(5,L)) - - IF(WQM(L).EQ.'R'.OR.WQM(L).EQ.'P'.OR.WQM(L).EQ.'F') THEN - -C A REJECT, PURGE, OR FAIL FLAG ON WIND IS TRANSFERRED TO ALL VARIABLES -C --------------------------------------------------------------------- - - PQM(L) = WQM(L) - TQM(L) = WQM(L) - QQM(L) = WQM(L) - ZQM(L) = WQM(L) - - ELSE - - PQM(L) = E35O29(ARR(1,L)) - TQM(L) = E35O29(ARR(2,L)) - QQM(L) = E35O29(ARR(3,L)) - ZQM(L) = E35O29(ARR(4,L)) - - END IF - - ENDDO - -C PUT THE UNPACKED ON29 REPORT INTO OBS -C ------------------------------------- - - RSV2 = ' ' - CALL S01O29(SID,XOB,YOB,RHR,RCH,RSV,RSV2,ELV,ITP,RTP) - CALL S02O29(6,1,*9999) - -C --------------------------------------------------------------------- -C MISC DATA GOES INTO CATEGORY 08 -C --------------------------------------------------------------------- -C CODE FIGURE 013 - PRESSURE -C CODE FIGURE 920 - CHARACTERS 7 AND 8 OF ACTUAL STATION IDENTIFICATION -C (CURRENTLY ONLY APPLIES TO U.S. SATWND TYPES) -C CODE FIGURE 924 - WIND SPEED IN 0.01*M/S -C --------------------------------------------------------------------- -C --------------------------------------------------------------------- - - IF(POB(1).LT.BMISS) THEN - OB8(1) = NINT(POB(1)*0.1) - CF8(1) = 13 - Q81(1) = ' ' - Q82(1) = ' ' - CALL S02O29(8,1,*9999) - END IF - IF(SID(1:1).GE.'A'.AND.SID(1:1).LE.'D') THEN - OB8(1) = 99999. - Q81(1) = SID(7:7) - Q82(1) = SID(8:8) - CF8(1) = 920 - CALL S02O29(8,1,*9999) - END IF - IF(WSPD1.LT.BMISS) THEN - OB8(2) = NINT(WSPD1*10.) - CF8(2) = 924 - Q81(2) = ' ' - Q82(2) = ' ' - CALL S02O29(8,2,*9999) - END IF - - CALL S03O29(OBS,SUBSET,*9999,*9998) - - RETURN - - 9999 CONTINUE - R06O29 = 999 - RETURN - - 9998 CONTINUE - print *,'IW3UNP29/R06O29: RPT with ID= ',SID,' TOSSED - ZERO ', - $ 'CAT.1-6,51,52 LVLS' - R06O29 = -9999 - KSKSAT =KSKSAT + 1 - RETURN - - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - FUNCTION R07O29(LUNIT,OBS) -C ---> formerly FUNCTION SPSSMI - - COMMON/IO29EE/POB(255),QOB(255),TOB(255),ZOB(255),DOB(255), - $ SOB(255),VSG(255),CLP(255),CLA(255),OB8(255), - $ CF8(255) - COMMON/IO29FF/PQM(255),QQM(255),TQM(255),ZQM(255),WQM(255), - $ QCP(255),QCA(255),Q81(255),Q82(255) - COMMON/IO29CC/SUBSET,IDAT10 - COMMON/IO29BB/KNDX,KSKACF(8),KSKUPA,KSKSFC,KSKSAT,KSKSMI - - CHARACTER*80 HDSTR - CHARACTER*8 SUBSET,SID,RSV,RSV2 - CHARACTER*4 CSTDV - CHARACTER*1 PQM,QQM,TQM,ZQM,WQM,QCP,QCA,Q81,Q82,CRF -cvvvvvdak port - REAL(8) RID_8,UFBINT_8,HDR_8(20),TMBR_8(7),ADDP_8(5),PROD_8(2,2) -csaaaadak port - DIMENSION OBS(*),HDR(20),ADDP(5),PROD(2,2),TMBR(7) - - EQUIVALENCE (RID_8,SID) - - SAVE - - DATA HDSTR/'RPID CLON CLAT HOUR MINU SECO NMCT SAID '/ - - DATA BMISS /10E10 / - -C CHECK IF THIS IS A PREPBUFR FILE -C -------------------------------- - - R07O29 = 99 -c#V#V#dak - future -cdak IF(SUBSET.EQ.'SPSSMI') R07O29 = PRPSMI(LUNIT,OBS) -caaaaadak - future - IF(R07O29.NE.99) RETURN - R07O29 = 0 - - CALL S05O29 - -C PUT THE HEADER INFORMATION INTO ON29 FORMAT -C ------------------------------------------- - -cvvvvvdak port -cdak CALL UFBINT(LUNIT,HDR,20, 1,IRET,HDSTR) - CALL UFBINT(LUNIT,HDR_8,20, 1,IRET,HDSTR);HDR(2:)=HDR_8(2:) -caaaaadak port - IF(HDR(5).GE.BMISS) HDR(5) = 0 - IF(HDR(6).GE.BMISS) HDR(6) = 0 - RID_8 = HDR_8(1) - XOB = HDR(2) - YOB = HDR(3) - RHR = BMISS - IF(HDR(4).LT.BMISS) RHR = NINT(HDR(4)) + ((NINT(HDR(5)) * 60.) + - $ NINT(HDR(6)))/3600. - RCH = 99999. - ELV = 99999. - ITP = 99 - RTP = HDR(7) - -C CHECK ON VALUE FOR SATELLITE ID TO DETERMINE IF THIS IS A SUPEROB -C (SATELLITE ID IS MISSING FOR SUPEROBS) -C ----------------------------------------------------------------- - - ISUPOB = 1 - IF(HDR(8).LT.BMISS) ISUPOB = 0 - -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - STDV = BMISS - -C PUT THE SSM/I DATA INTO ON29 UNITS (WILL RETURN TO HEADER DATA LATER) -C ALL PROCESSING GOES INTO CATEGORY 08 -C --------------------------------------------------------------------- - - IF(RTP.EQ.68) THEN -C --------------------------------------------------------------------- -C ** 7-CHANNEL BRIGHTNESS TEMPERATURES -- REPORT TYPE 68 ** -C --------------------------------------------------------------------- -C CODE FIGURE 189 - 19 GHZ V BRIGHTNESS TEMPERATURE (DEG. K X 100) -C CODE FIGURE 190 - 19 GHZ H BRIGHTNESS TEMPERATURE (DEG. K X 100) -C CODE FIGURE 191 - 22 GHZ V BRIGHTNESS TEMPERATURE (DEG. K X 100) -C CODE FIGURE 192 - 37 GHZ V BRIGHTNESS TEMPERATURE (DEG. K X 100) -C CODE FIGURE 193 - 37 GHZ H BRIGHTNESS TEMPERATURE (DEG. K X 100) -C CODE FIGURE 194 - 85 GHZ V BRIGHTNESS TEMPERATURE (DEG. K X 100) -C CODE FIGURE 195 - 85 GHZ H BRIGHTNESS TEMPERATURE (DEG. K X 100) -C --------------------------------------------------------------------- - NLCAT8 = 7 -cvvvvvdak port -cdak CALL UFBINT(LUNIT,TMBR,1,7,NLEV,'TMBR') - CALL UFBINT(LUNIT,TMBR_8,1,7,NLEV,'TMBR');TMBR=TMBR_8 - DO NCHN = 1,7 -cdak OB8(NCHN) = MIN0(NINT(TMBR(NCHN)*100.),99999) - OB8(NCHN) = MIN(NINT(TMBR(NCHN)*100.),99999) -caaaaadak port - CF8(NCHN) = 188 + NCHN - ENDDO - ELSE IF(RTP.EQ.575) THEN -C --------------------------------------------------------------------- -C ** ADDITIONAL PRODUCTS -- REPORT TYPE 575 ** -C --------------------------------------------------------------------- -C CODE FIGURE 210 - SURFACE TAG (RANGE: 0,1,3-6) -C CODE FIGURE 211 - ICE CONCENTRATION (PERCENT) -C CODE FIGURE 212 - ICE AGE (RANGE: 0,1) -C CODE FIGURE 213 - ICE EDGE (RANGE: 0,1) -C CODE FIGURE 214 - CALCULATED SURFACE TYPE (RANGE: 1-20) -C --------------------------------------------------------------------- - NLCAT8 = 5 -cvvvvvdak port -cdak CALL UFBINT(LUNIT,ADDP,5,1,IRET,'SFTG ICON ICAG ICED SFTP') - CALL UFBINT(LUNIT,ADDP_8,5,1,IRET,'SFTG ICON ICAG ICED SFTP') - ADDP=ADDP_8 -caaaaadak port - DO NADD = 1,5 - IF(ADDP(NADD).LT.BMISS) THEN - OB8(NADD) = NINT(ADDP(NADD)) - CF8(NADD) = 209 + NADD - END IF - ENDDO - ELSE IF(RTP.EQ.571) THEN -C --------------------------------------------------------------------- -C ** OCEAN SURFACE WIND SPEED PRODUCT -- REPORT TYPE 571 ** -C --------------------------------------------------------------------- -C CODE FIGURE 196 - OCEANIC WIND SPEED (M/S * 10) -C (RAIN FLAG IN Q.M. BYTE 2) -C --------------------------------------------------------------------- - CF8(1) = 196 - ELV = 0 - NLCAT8 = 1 - IF(ISUPOB.EQ.1) THEN -cvvvvvdak port -cdak CALL UFBREP(LUNIT,PROD,2,2,IRET,'FOST WSOS') - CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST WSOS');PROD=PROD_8 -caaaaadak port - DO JJ = 1,2 - IF(PROD(1,JJ).EQ.4) THEN - OB8(1) = NINT(PROD(2,JJ)*10.) - ELSE IF(PROD(1,JJ).EQ.10) THEN - STDV = NINT(PROD(2,JJ)*100.) - END IF - ENDDO - ELSE -cvvvvvdak port -cdak CALL UFBINT(LUNIT,PRODN,1,1,IRET,'WSOS') - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'WSOS');PRODN=UFBINT_8 -caaaaadak port - OB8(1) = NINT(PRODN*10.) -cvvvvvdak port -cdak CALL UFBINT(LUNIT,RFLG,1,1,IRET,'RFLG') - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'RFLG');RFLG=UFBINT_8 -caaaaadak port - IF(RFLG.LT.BMISS) THEN - WRITE(CRF,'(I1.1)') NINT(RFLG) - Q82(1) = CRF - END IF - END IF - ELSE IF(RTP.EQ.65) THEN -C --------------------------------------------------------------------- -C ** OCEAN TOTAL PRECIPITABLE WATER PRODUCT -- REPORT TYPE 65 ** -C --------------------------------------------------------------------- -C CODE FIGURE 197 - TOTAL PRECIPITABLE WATER (MM * 10) -C (RAIN FLAG IN Q.M. BYTE 2) -C --------------------------------------------------------------------- - CF8(1) = 197 - ELV = 0 - NLCAT8 = 1 - IF(ISUPOB.EQ.1) THEN -cvvvvvdak port -cdak CALL UFBREP(LUNIT,PROD,2,2,IRET,'FOST PH2O') - CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST PH2O');PROD=PROD_8 -caaaaadak port - DO JJ = 1,2 - IF(PROD(1,JJ).EQ.4) THEN - OB8(1) = NINT(PROD(2,JJ)*10.) - ELSE IF(PROD(1,JJ).EQ.10) THEN - STDV = NINT(PROD(2,JJ)*100.) - END IF - ENDDO - ELSE -cvvvvvdak port -cdak CALL UFBINT(LUNIT,PRODN,1,1,IRET,'PH2O') - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'PH2O');PRODN=UFBINT_8 -caaaaadak port - OB8(1) = NINT(PRODN*10.) -cvvvvvdak port -cdak CALL UFBINT(LUNIT,RFLG,1,1,IRET,'RFLG') - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'RFLG');RFLG=UFBINT_8 -caaaaadak port - IF(RFLG.LT.BMISS) THEN - WRITE(CRF,'(I1)') NINT(RFLG) - Q82(1) = CRF - END IF - END IF - ELSE IF(RTP.EQ.66) THEN -C --------------------------------------------------------------------- -C ** LAND/OCEAN RAINFALL RATE -- REPORT TYPE 66 ** -C --------------------------------------------------------------------- -C CODE FIGURE 198 - RAINFALL RATE (MM/HR) -C --------------------------------------------------------------------- - CF8(1) = 198 - NLCAT8 = 1 - IF(ISUPOB.EQ.1) THEN -cvvvvvdak port -cdak CALL UFBREP(LUNIT,PROD,2,2,IRET,'FOST REQV') - CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST REQV');PROD=PROD_8 -caaaaadak port - DO JJ = 1,2 - IF(PROD(1,JJ).EQ.4) THEN - OB8(1) = NINT(PROD(2,JJ)*3600.) - ELSE IF(PROD(1,JJ).EQ.10) THEN - STDV = NINT(PROD(2,JJ)*36000.) - END IF - ENDDO - ELSE -cvvvvvdak port -cdak CALL UFBINT(LUNIT,PRODN,1,1,IRET,'REQV') - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'REQV');PRODN=UFBINT_8 -caaaaadak port - OB8(1) = NINT(PRODN*3600.) - END IF - ELSE IF(RTP.EQ.576) THEN -C --------------------------------------------------------------------- -C ** SURFACE TEMPERATURE -- REPORT TYPE 576 ** -C --------------------------------------------------------------------- -C CODE FIGURE 199 - SURFACE TEMPERATURE (DEGREES KELVIN) -C --------------------------------------------------------------------- - CF8(1) = 199 - NLCAT8 = 1 - IF(ISUPOB.EQ.1) THEN -cvvvvvdak port -cdak CALL UFBREP(LUNIT,PROD,2,2,IRET,'FOST TMSK') - CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST TMSK');PROD=PROD_8 -caaaaadak port - DO JJ = 1,2 - IF(PROD(1,JJ).EQ.4) THEN - OB8(1) = NINT(PROD(2,JJ)) - ELSE IF(PROD(1,JJ).EQ.10) THEN - STDV = NINT(PROD(2,JJ)*10.) - END IF - ENDDO - ELSE -cvvvvvdak port -cdak CALL UFBINT(LUNIT,PRODN,1,1,IRET,'TMSK') - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TMSK');PRODN=UFBINT_8 -caaaaadak port - OB8(1) = NINT(PRODN) - END IF - ELSE IF(RTP.EQ.69) THEN -C --------------------------------------------------------------------- -C ** OCEAN CLOUD WATER -- REPORT TYPE 69 ** -C --------------------------------------------------------------------- -C CODE FIGURE 200 - CLOUD WATER (MM * 100) -C --------------------------------------------------------------------- - CF8(1) = 200 - ELV = 0 - NLCAT8 = 1 - IF(ISUPOB.EQ.1) THEN -cvvvvvdak port -cdak CALL UFBREP(LUNIT,PROD,2,2,IRET,'FOST CH2O') - CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST CH2O');PROD=PROD_8 -caaaaadak port - DO JJ = 1,2 - IF(PROD(1,JJ).EQ.4) THEN - OB8(1) = NINT(PROD(2,JJ)*100.) - ELSE IF(PROD(1,JJ).EQ.10) THEN - STDV = NINT(PROD(2,JJ)*1000.) - END IF - ENDDO - ELSE -cvvvvvdak port -cdak CALL UFBINT(LUNIT,PRODN,1,1,IRET,'CH2O') - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'CH2O');PRODN=UFBINT_8 -caaaaadak port - OB8(1) = NINT(PRODN*100.) - END IF - ELSE IF(RTP.EQ.573) THEN -C --------------------------------------------------------------------- -C ** SOIL MOISTURE -- REPORT TYPE 573 ** -C --------------------------------------------------------------------- -C CODE FIGURE 201 - SOIL MOISTURE (MM) -C --------------------------------------------------------------------- - CF8(1) = 201 - NLCAT8 = 1 - IF(ISUPOB.EQ.1) THEN -cvvvvvdak port -cdak CALL UFBREP(LUNIT,PROD,2,2,IRET,'FOST SMOI') - CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST SMOI');PROD=PROD_8 -caaaaadak port - DO JJ = 1,2 - IF(PROD(1,JJ).EQ.4) THEN - OB8(1) = NINT(PROD(2,JJ)*1000.) - ELSE IF(PROD(1,JJ).EQ.10) THEN - STDV = NINT(PROD(2,JJ)*10000.) - END IF - ENDDO - ELSE -cvvvvvdak port -cdak CALL UFBINT(LUNIT,PRODN,1,1,IRET,'SMOI') - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SMOI');PRODN=UFBINT_8 -caaaaadak port - OB8(1) = NINT(PRODN*1000.) - END IF - ELSE IF(RTP.EQ.574) THEN -C --------------------------------------------------------------------- -C ** SNOW DEPTH -- REPORT TYPE 574 ** -C --------------------------------------------------------------------- -C CODE FIGURE 202 - SNOW DEPTH (MM) -C --------------------------------------------------------------------- - CF8(1) = 202 - NLCAT8 = 1 - IF(ISUPOB.EQ.1) THEN -cvvvvvdak port -cdak CALL UFBREP(LUNIT,PROD,2,2,IRET,'FOST SNDP') - CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST SNDP');PROD=PROD_8 -caaaaadak port - DO JJ = 1,2 - IF(PROD(1,JJ).EQ.4) THEN - OB8(1) = NINT(PROD(2,JJ)*1000.) - ELSE IF(PROD(1,JJ).EQ.10) THEN - STDV = NINT(PROD(2,JJ)*10000.) - END IF - ENDDO - ELSE -cvvvvvdak port -cdak CALL UFBINT(LUNIT,PRODN,1,1,IRET,'SNDP') - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SNDP');PRODN=UFBINT_8 -caaaaadak port - OB8(1) = NINT(PRODN*1000.) - END IF - END IF - -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -C FINISH PUTTING THE HEADER INFORMATION INTO ON29 FORMAT -C ------------------------------------------------------ - - RSV = '999 ' - RSV2 = ' ' - - IF(STDV.LT.BMISS) THEN - WRITE(CSTDV,'(I4.4)') NINT(STDV) - ELSE - CSTDV = '9999' - END IF - RSV2(3:4) = CSTDV(1:2) - RSV(1:2) = CSTDV(3:4) - -cvvvvvdak port -cdak CALL UFBINT(LUNIT,ACAV,1,1,IRET,'ACAV') - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'ACAV');ACAV=UFBINT_8 -caaaaadak port - IF(ACAV.LT.BMISS) THEN - WRITE(CSTDV(1:2),'(I2.2)') NINT(ACAV) - ELSE - CSTDV = '9999' - END IF - RSV2(1:2) = CSTDV(1:2) - - CALL S01O29(SID,XOB,YOB,RHR,RCH,RSV,RSV2,ELV,ITP,RTP) - - DO II = 1,NLCAT8 - IF(CF8(II).LT.BMISS) CALL S02O29(8,II,*9999) - ENDDO - -C PUT THE UNPACKED ON29 REPORT INTO OBS -C ------------------------------------- - - CALL S03O29(OBS,SUBSET,*9999,*9998) - - RETURN - 9999 CONTINUE - R07O29 = 999 - RETURN - 9998 CONTINUE - print *,'IW3UNP29/R07O29: RPT with ID= ',SID,' TOSSED - ZERO ', - $ 'CAT.1-6,8,51,52 LVLS' - R07O29 = -9999 - KSKSMI = KSKSMI + 1 - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: S06O29 MODIFIES AIRCRAFT ID -C PRGMMR: RAY CRAYTON ORG: W/NMC411 DATE: 1992-02-16 -C -C ABSTRACT: MODIFIES AMDAR REPORTS SO THAT LAST CHARACTER ENDS -C WITH 'Z'. -C -C PROGRAM HISTORY LOG: -C 1992-02-16 RAY CRAYTON -C -C USAGE: CALL S06O29(IDEN,ID) -C INPUT ARGUMENT LIST: -C IDEN - ACFT ID -C -C OUTPUT ARGUMENT LIST: -C ID - MODIFIED AIRCRAFT ID. -C -C REMARKS: -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP, CRAY, SGI -C -C$$$ - - SUBROUTINE S06O29(IDEN,ID) -C ---> formerly SUBROUTINE IDP - - CHARACTER*8 IDEN,ID - CHARACTER*6 ZEROES - CHARACTER*1 JCHAR - - SAVE - - DATA ZEROES/'000000'/ - - ID = ' ' - - L = INDEX(IDEN(1:8),' ') - IF(L.EQ.0) THEN - N = 8 - ELSE - N = L - 1 - IF(N.LT.1) THEN - ID = 'AMDARZ' - END IF - END IF - - IF(N.EQ.8) THEN - IF(IDEN(8:8).EQ.'Z') THEN - -C THE ID INDICATES IT IS AN 8-CHARACTER ASDAR REPORT. COMPRESS IT BY -C DELETING THE 6TH AND 7TH CHARACTER -C ------------------------------------------------------------------ - - ID = IDEN(1:5)//'Z' - GO TO 500 - END IF - END IF - - L = I05O29(IDEN(1:1),7,JCHAR) - - IF(L.EQ.0.OR.L.GT.6.OR.N.GT.6) THEN - -C UP THROUGH 6 CHARACTERS ARE LETTERS. CHANGE 6TH CHARACTER TO 'Z' -C --------------------------------------------------------------- - - IF(N.GE.5) THEN - ID = IDEN - ID(6:6) = 'Z' - ELSE - -C ZERO FILL AND ADD 'Z' TO MAKE 6 CHARAACTERS -C ------------------------------------------- - - ID = IDEN(1:N)//ZEROES(N+1:5)//'Z' - END IF - - ELSE IF(N.EQ.6) THEN - -C THE IDEN HAS 6 NUMERIC OR ALPHANUMERIC CHARACTERS -C ------------------------------------------------- - - IF(IDEN(6:6).EQ.'Z') THEN - ID = IDEN(1:6) - ELSE IF(L.GT.3) THEN - ID = IDEN(1:3)//IDEN(5:6)//'Z' - ELSE IF(L.EQ.1) THEN - ID = IDEN(2:6)//'Z' - ELSE - ID = IDEN(1:L-1)//IDEN(L+1:6)//'Z' - END IF - - ELSE IF(N.EQ.5) THEN - -C THE IDEN HAS 5 NUMERIC OR ALPHANUMERIC CHARACTERS -C ------------------------------------------------- - - ID = IDEN(1:5)//'Z' - ELSE - -C THE IDEN HAS 1-4 NUMERIC OR ALPHANUMERIC CHARACTERS -C --------------------------------------------------- - - IF(L.EQ.1) THEN - ID = ZEROES(1:5-N)//IDEN(1:N)//'Z' - ELSE - IF(N.LT.L) THEN - IDEN(1:6) = 'AMDARZ' - ELSE - ID = IDEN(1:L-1)// ZEROES(1:5-N)//IDEN(L:N)//'Z' - END IF - END IF - END IF - - 500 CONTINUE - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: I05O29 FINDS LOCATION OF NEXT NUMERIC -C PRGMMR: RAY CRAYTON ORG: W/NMC41 DATE: 1989-07-07 -C -C ABSTRACT: FINDS THE LOCATION OF THE NEXT NUMERIC CHARACTER -C IN A STRING OF CHARACTERS. -C -C PROGRAM HISTORY LOG: -C 1989-07-07 RAY CRAYTON -C -C USAGE: LOC=I05O29(STRING,NUM,CHAR) -C INPUT ARGUMENT LIST: -C STRING - CHARACTER ARRAY. -C NUM - NUMBER OF CHARACTERS TO SEARCH IN STRING. -C -C OUTPUT ARGUMENT LIST: -C I05O29 - INTEGER*4 LOCATION OF ALPHANUMERIC CHARACTER. -C = 0 IF NOT FOUND. -C CHAR - CHARACTER FOUND. -C -C REMARKS: NONE -C -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP, CRAY, SGI -C -C$$$ - FUNCTION I05O29(STRING,NUM,CHAR) -C ---> formerly FUNCTION IFIG - CHARACTER*1 STRING(1),CHAR - - SAVE - - DO I = 1,NUM - IF(STRING(I).GE.'0'.AND.STRING(I).LE.'9') THEN - I05O29 = I - CHAR = STRING(I) - GO TO 200 - END IF - ENDDO - I05O29 = 0 - CHAR = '?' - 200 CONTINUE - RETURN - END diff --git a/src/fim/FIMsrc/w3/ixgb.f b/src/fim/FIMsrc/w3/ixgb.f deleted file mode 100644 index 0645a3f..0000000 --- a/src/fim/FIMsrc/w3/ixgb.f +++ /dev/null @@ -1,155 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE IXGB(LUGB,LSKIP,LGRIB,NLEN,NNUM,MLEN,CBUF) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: IXGB MAKE INDEX RECORD -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 95-10-31 -C -C ABSTRACT: THIS SUBPROGRAM MAKES ONE INDEX RECORD. -C BYTE 001-004: BYTES TO SKIP IN DATA FILE BEFORE GRIB MESSAGE -C BYTE 005-008: BYTES TO SKIP IN MESSAGE BEFORE PDS -C BYTE 009-012: BYTES TO SKIP IN MESSAGE BEFORE GDS (0 IF NO GDS) -C BYTE 013-016: BYTES TO SKIP IN MESSAGE BEFORE BMS (0 IF NO BMS) -C BYTE 017-020: BYTES TO SKIP IN MESSAGE BEFORE BDS -C BYTE 021-024: BYTES TOTAL IN THE MESSAGE -C BYTE 025-025: GRIB VERSION NUMBER -C BYTE 026-053: PRODUCT DEFINITION SECTION (PDS) -C BYTE 054-095: GRID DEFINITION SECTION (GDS) (OR NULLS) -C BYTE 096-101: FIRST PART OF THE BIT MAP SECTION (BMS) (OR NULLS) -C BYTE 102-112: FIRST PART OF THE BINARY DATA SECTION (BDS) -C BYTE 113-172: (OPTIONAL) BYTES 41-100 OF THE PDS -C BYTE 173-184: (OPTIONAL) BYTES 29-40 OF THE PDS -C BYTE 185-320: (OPTIONAL) BYTES 43-178 OF THE GDS -C -C PROGRAM HISTORY LOG: -C 95-10-31 IREDELL -C 96-10-31 IREDELL AUGMENTED OPTIONAL DEFINITIONS TO BYTE 320 -C 2001-06-05 IREDELL APPLY LINUX PORT BY EBISUZAKI -C -C USAGE: CALL WRGI1R(LUGB,LSKIP,LGRIB,LUGI) -C INPUT ARGUMENTS: -C LUGB INTEGER LOGICAL UNIT OF INPUT GRIB FILE -C LSKIP INTEGER NUMBER OF BYTES TO SKIP BEFORE GRIB MESSAGE -C LGRIB INTEGER NUMBER OF BYTES IN GRIB MESSAGE -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C NNUM INTEGER INDEX RECORD NUMBER TO MAKE -C OUTPUT ARGUMENTS: -C MLEN INTEGER ACTUAL VALID LENGTH OF INDEX RECORD -C CBUF CHARACTER*1 (MBUF) BUFFER TO RECEIVE INDEX DATA -C -C SUBPROGRAMS CALLED: -C GBYTEC GET INTEGER DATA FROM BYTES -C SBYTEC STORE INTEGER DATA IN BYTES -C BAREAD BYTE-ADDRESSABLE READ -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - CHARACTER CBUF(*) - PARAMETER(LINDEX=112,MINDEX=320) - PARAMETER(IXSKP=0,IXSPD=4,IXSGD=8,IXSBM=12,IXSBD=16,IXLEN=20, - & IXVER=24,IXPDS=25,IXGDS=53,IXBMS=95,IXBDS=101, - & IXPDX=112,IXPDW=172,IXGDX=184) - PARAMETER(MXSKP=4,MXSPD=4,MXSGD=4,MXSBM=4,MXSBD=4,MXLEN=4, - & MXVER=1,MXPDS=28,MXGDS=42,MXBMS=6,MXBDS=11, - & MXPDX=60,MXPDW=12,MXGDX=136) - CHARACTER CBREAD(MINDEX),CINDEX(MINDEX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C INITIALIZE INDEX RECORD AND READ GRIB MESSAGE - MLEN=LINDEX - CINDEX=CHAR(0) - CALL SBYTEC(CINDEX,LSKIP,8*IXSKP,8*MXSKP) - CALL SBYTEC(CINDEX,LGRIB,8*IXLEN,8*MXLEN) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C PUT PDS IN INDEX RECORD - ISKPDS=8 - IBSKIP=LSKIP - IBREAD=ISKPDS+MXPDS - CALL BAREAD(LUGB,IBSKIP,IBREAD,LBREAD,CBREAD) - IF(LBREAD.NE.IBREAD) RETURN - CINDEX(IXVER+1)=CBREAD(8) - CALL SBYTEC(CINDEX,ISKPDS,8*IXSPD,8*MXSPD) - CALL GBYTEC(CBREAD,LENPDS,8*ISKPDS,8*3) - CALL GBYTEC(CBREAD,INCGDS,8*ISKPDS+8*7+0,1) - CALL GBYTEC(CBREAD,INCBMS,8*ISKPDS+8*7+1,1) - ILNPDS=MIN(LENPDS,MXPDS) - CINDEX(IXPDS+1:IXPDS+ILNPDS)=CBREAD(ISKPDS+1:ISKPDS+ILNPDS) - ISKTOT=ISKPDS+LENPDS -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C PUT PDS EXTENSION IN INDEX RECORD - IF(LENPDS.GT.MXPDS) THEN - ISKPDW=ISKPDS+MXPDS - ILNPDW=MIN(LENPDS-MXPDS,MXPDW) - IBSKIP=LSKIP+ISKPDW - IBREAD=ILNPDW - CALL BAREAD(LUGB,IBSKIP,IBREAD,LBREAD,CBREAD) - IF(LBREAD.NE.IBREAD) RETURN - CINDEX(IXPDW+1:IXPDW+ILNPDW)=CBREAD(1:ILNPDW) - ISKPDX=ISKPDS+(MXPDS+MXPDW) - ILNPDX=MIN(LENPDS-(MXPDS+MXPDW),MXPDX) - IBSKIP=LSKIP+ISKPDX - IBREAD=ILNPDX - CALL BAREAD(LUGB,IBSKIP,IBREAD,LBREAD,CBREAD) - IF(LBREAD.NE.IBREAD) RETURN - CINDEX(IXPDX+1:IXPDX+ILNPDX)=CBREAD(1:ILNPDX) - MLEN=MAX(MLEN,IXPDW+ILNPDW,IXPDX+ILNPDX) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C PUT GDS IN INDEX RECORD - IF(INCGDS.NE.0) THEN - ISKGDS=ISKTOT - IBSKIP=LSKIP+ISKGDS - IBREAD=MXGDS - CALL BAREAD(LUGB,IBSKIP,IBREAD,LBREAD,CBREAD) - IF(LBREAD.NE.IBREAD) RETURN - CALL SBYTEC(CINDEX,ISKGDS,8*IXSGD,8*MXSGD) - CALL GBYTEC(CBREAD,LENGDS,0,8*3) - ILNGDS=MIN(LENGDS,MXGDS) - CINDEX(IXGDS+1:IXGDS+ILNGDS)=CBREAD(1:ILNGDS) - ISKTOT=ISKGDS+LENGDS - IF(LENGDS.GT.MXGDS) THEN - ISKGDX=ISKGDS+MXGDS - ILNGDX=MIN(LENGDS-MXGDS,MXGDX) - IBSKIP=LSKIP+ISKGDX - IBREAD=ILNGDX - CALL BAREAD(LUGB,IBSKIP,IBREAD,LBREAD,CBREAD) - IF(LBREAD.NE.IBREAD) RETURN - CINDEX(IXGDX+1:IXGDX+ILNGDX)=CBREAD(1:ILNGDX) - MLEN=MAX(MLEN,IXGDX+ILNGDX) - ENDIF - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C PUT BMS IN INDEX RECORD - IF(INCBMS.NE.0) THEN - ISKBMS=ISKTOT - IBSKIP=LSKIP+ISKBMS - IBREAD=MXBMS - CALL BAREAD(LUGB,IBSKIP,IBREAD,LBREAD,CBREAD) - IF(LBREAD.NE.IBREAD) RETURN - CALL SBYTEC(CINDEX,ISKBMS,8*IXSBM,8*MXSBM) - CALL GBYTEC(CBREAD,LENBMS,0,8*3) - ILNBMS=MIN(LENBMS,MXBMS) - CINDEX(IXBMS+1:IXBMS+ILNBMS)=CBREAD(1:ILNBMS) - ISKTOT=ISKBMS+LENBMS - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C PUT BDS IN INDEX RECORD - ISKBDS=ISKTOT - IBSKIP=LSKIP+ISKBDS - IBREAD=MXBDS - CALL BAREAD(LUGB,IBSKIP,IBREAD,LBREAD,CBREAD) - IF(LBREAD.NE.IBREAD) RETURN - CALL SBYTEC(CINDEX,ISKBDS,8*IXSBD,8*MXSBD) - CALL GBYTEC(CBREAD,LENBDS,0,8*3) - ILNBDS=MIN(LENBDS,MXBDS) - CINDEX(IXBDS+1:IXBDS+ILNBDS)=CBREAD(1:ILNBDS) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C STORE INDEX RECORD - MLEN=MIN(MLEN,NLEN) - NSKIP=NLEN*(NNUM-1) - CBUF(NSKIP+1:NSKIP+MLEN)=CINDEX(1:MLEN) - CBUF(NSKIP+MLEN+1:NSKIP+NLEN)=CHAR(0) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/jdate.F90 b/src/fim/FIMsrc/w3/jdate.F90 deleted file mode 100644 index 3ab085c..0000000 --- a/src/fim/FIMsrc/w3/jdate.F90 +++ /dev/null @@ -1,10 +0,0 @@ -program jdate -implicit none -CHARACTER(len=12) :: yyyymmddhhmm -CHARACTER(len=9) :: JulianDate - -call getarg(1,yyyymmddhhmm) -call GetJdate(yyyymmddhhmm,JulianDate) -print'(A9,$)',JulianDate -stop -end program jdate diff --git a/src/fim/FIMsrc/w3/lengds.f b/src/fim/FIMsrc/w3/lengds.f deleted file mode 100644 index 051aed6..0000000 --- a/src/fim/FIMsrc/w3/lengds.f +++ /dev/null @@ -1,40 +0,0 @@ -C----------------------------------------------------------------------- - FUNCTION LENGDS(KGDS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: LENGDS RETURN THE LENGTH OF A GRID -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-07-19 -C -C ABSTRACT: GIVEN A GRID DESCRIPTION SECTION (IN W3FI63 FORMAT), -C RETURN ITS SIZE IN TERMS OF NUMBER OF DATA POINTS. -C -C PROGRAM HISTORY LOG: -C 96-07-19 IREDELL -C -C USAGE: CALL LENGDS(KGDS) -C INPUT ARGUMENTS: -C KGDS INTEGER (200) GDS PARAMETERS IN W3FI63 FORMAT -C OUTPUT ARGUMENTS: -C LENGDS INTEGER SIZE OF GRID -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN -C -C$$$ - INTEGER KGDS(200) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SPECIAL CASE OF STAGGERED ETA - IF(KGDS(1).EQ.201) THEN - LENGDS=KGDS(7)*KGDS(8)-KGDS(8)/2 -C SPECIAL CASE OF FILLED ETA - ELSEIF(KGDS(1).EQ.202) THEN - LENGDS=KGDS(7)*KGDS(8) -C SPECIAL CASE OF THINNED WAFS - ELSEIF(KGDS(19).EQ.0.AND.KGDS(20).NE.255) THEN - LENGDS=KGDS(21) -C GENERAL CASE - ELSE - LENGDS=KGDS(2)*KGDS(3) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/src/fim/FIMsrc/w3/makwmo.f b/src/fim/FIMsrc/w3/makwmo.f deleted file mode 100644 index dfcfcf2..0000000 --- a/src/fim/FIMsrc/w3/makwmo.f +++ /dev/null @@ -1,89 +0,0 @@ - SUBROUTINE MAKWMO (BULHED,IDAY,IHOUR,KWBX,HEADER) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: MAKWMO FORMAT THE WMO HEADER -C PRGMMR: FARLEY ORG: W/NMC42 DATE: 84-07-06 -C -C ABSTRACT: FORMS THE WMO HEADER FOR A GIVEN BULLETIN. -C -C PROGRAM HISTORY LOG: -C 84-07-06 FARLEY ORIGINAL AUTHOR -C 94-10-10 R.E.JONES CHANGES FOR CRAY -C 95-10-18 R.E.JONES ADD PARAMETER KWBX TO CALL -C 98-06-16 Gilbert Changed argument list to pass in day and hour -C instead of the old O.N. 84 date word. -C 2003-03-28 Gilbert Removed equivalences. -C -C USAGE: CALL MAKWMO(BULHED,IDAY,IHOUR,KWBX,HEADER) -C INPUT ARGUMENT LIST: -C BULHED - TTAAII BULLETIN HEADER FT10 -C IDAY - Day of Month -C IHOUR - Hour of Day. -C KWBX - 4 CHARACTERS (KWBC TO KWBQ) -C -C OUTPUT ARGUMENT LIST: -C HEADER - COMPLETE WMO HEADER IN ASCII -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM SP -C -C$$$ -C - CHARACTER * 6 BULHED - CHARACTER * 1 HEADER (*) - CHARACTER * 1 WMOHDR (21) - CHARACTER * 4 KWBX - CHARACTER * 2 CTEMP -C -C-------------------------------------------------------------------- -C -C$ 1. CREATE WMO HEADER. -C -C$ 1.1 CONVERT BULHED FROM EBCDIC TO ASCII. -C -C WRITE (6,FMT='('' MADE IT TO MAKWMO'')') -C - DO I = 1,6 - WMOHDR(I) = BULHED(I:I) - END DO - WMOHDR(7)=char(32) ! ASCII BLANK -C -C MOVE KWBX INTO WMO HEADER -C - DO I = 1,4 - WMOHDR(I+7) = KWBX(I:I) - END DO - WMOHDR(12)=char(32) ! ASCII BLANK -C -C$ 1.2 PICK OFF THE DAY OF MONTH (YY) -C$ AND CONVERT TO ASCII. -C - write(ctemp,fmt='(I2.2)') IDAY - WMOHDR(13)=ctemp(1:1) - WMOHDR(14)=ctemp(2:2) -C -C$ 1.3 PICK OFF THE HOUR(GG) AND CONVERT TO ASCII. -C - write(ctemp,fmt='(I2.2)') IHOUR - WMOHDR(15)=ctemp(1:1) - WMOHDR(16)=ctemp(2:2) -C -C 1.4 FIL IN REST OF HEADER -C - WMOHDR(17)=char(48) ! ASCII "0" - WMOHDR(18)=char(48) ! ASCII "0" - WMOHDR(19)=char(13) ! ASCII CR = '\r' - WMOHDR(20)=char(13) ! ASCII CR = '\r' - WMOHDR(21)=char(10) ! ASCII LF = '\n' -C -C-------------------------------------------------------------------- -C -C$ 2. MOVE WMOHDR TO OUTPUT FIELD. -C - DO 200 I = 1,21 - HEADER(I) = WMOHDR(I) - 200 CONTINUE -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/mersenne_twister.f b/src/fim/FIMsrc/w3/mersenne_twister.f deleted file mode 100644 index b5c69cb..0000000 --- a/src/fim/FIMsrc/w3/mersenne_twister.f +++ /dev/null @@ -1,498 +0,0 @@ -!$$$ Module Documentation Block -! -! Module: mersenne_twister Modern random number generator -! Prgmmr: Iredell Org: W/NX23 date: 2005-06-14 -! -! Abstract: This module calculates random numbers using the Mersenne twister. -! (It has been adapted to a Fortran 90 module from open source software. -! The comments from the original software are given below in the remarks.) -! The Mersenne twister (aka MT19937) is a state-of-the-art random number -! generator based on Mersenne primes and originally developed in 1997 by -! Matsumoto and Nishimura. It has a period before repeating of 2^19937-1, -! which certainly should be good enough for geophysical purposes. :-) -! Considering the algorithm's robustness, it runs fairly speedily. -! (Some timing statistics are given below in the remarks.) -! This adaptation uses the standard Fortran 90 random number interface, -! which can generate an arbitrary number of random numbers at one time. -! The random numbers generated are uniformly distributed between 0 and 1. -! The module also can generate random numbers from a Gaussian distribution -! with mean 0 and standard deviation 1, using a Numerical Recipes algorithm. -! The module also can generate uniformly random integer indices. -! There are also thread-safe versions of the generators in this adaptation, -! necessitating the passing of generator states which must be kept private. -! -! Program History Log: -! 2005-06-14 Mark Iredell -! -! Usage: -! The module can be compiled with 4-byte reals or with 8-byte reals, but -! 4-byte integers are required. The module should be endian-independent. -! The Fortran 90 interfaces random_seed and random_number are overloaded -! and can be used as in the standard by adding the appropriate use statement -! use mersenne_twister -! In the below use cases, harvest is a real array of arbitrary size, -! and iharvest is an integer array of arbitrary size. -! To generate uniformly distributed random numbers between 0 and 1, -! call random_number(harvest) -! To generate Gaussian distributed random numbers with 0 mean and 1 sigma, -! call random_gauss(harvest) -! To generate uniformly distributed random integer indices between 0 and n, -! call random_index(n,iharvest) -! In standard "saved" mode, the random number generator can be used without -! setting a seed. But to set a seed, only 1 non-zero integer is required, e.g. -! call random_setseed(4357) ! set default seed -! The full generator state can be set via the standard interface random_seed, -! but it is recommended to use this method only to restore saved states, e.g. -! call random_seed(size=lsave) ! get size of generator state seed array -! allocate isave(lsave) ! allocate seed array -! call random_seed(get=isave) ! fill seed array (then maybe save to disk) -! call random_seed(put=isave) ! restore state (after read from disk maybe) -! Locally kept generator states can also be saved in a seed array, e.g. -! type(random_stat):: stat -! call random_seed(get=isave,stat=stat) ! fill seed array -! call random_seed(put=isave,stat=stat) ! restore state -! To generate random numbers in a threaded region, the "thread-safe" mode -! must be used where generator states of type random_state are passed, e.g. -! type(random_stat):: stat(8) -! do i=1,8 ! threadable loop -! call random_setseed(7171*i,stat(i)) ! thread-safe call -! enddo -! do i=1,8 ! threadable loop -! call random_number(harvest,stat(i)) ! thread-safe call -! enddo -! do i=1,8 ! threadable loop -! call random_gauss(harvest,stat(i)) ! thread-safe call -! enddo -! do i=1,8 ! threadable loop -! call random_index(n,iharvest,stat(i))! thread-safe call -! enddo -! There is also a relatively inefficient "interactive" mode available, where -! setting seeds and generating random numbers are done in the same call. -! There is also a functional mode available, returning one value at a time. -! -! Public Defined Types: -! random_stat Generator state (private contents) -! -! Public Subprograms: -! random_seed determine size or put or get state -! size optional integer output size of seed array -! put optional integer(:) input seed array -! get optional integer(:) output seed array -! stat optional type(random_stat) (thread-safe mode) -! random_setseed set seed (thread-safe mode) -! inseed integer seed input -! stat type(random_stat) output -! random_setseed set seed (saved mode) -! inseed integer seed input -! random_number get mersenne twister random numbers (thread-safe mode) -! harvest real(:) numbers output -! stat type(random_stat) input -! random_number get mersenne twister random numbers (saved mode) -! harvest real(:) numbers output -! random_number get mersenne twister random numbers (interactive mode) -! harvest real(:) numbers output -! inseed integer seed input -! random_number_f get mersenne twister random number (functional mode) -! harvest real number output -! random_gauss get gaussian random numbers (thread-safe mode) -! harvest real(:) numbers output -! stat type(random_stat) input -! random_gauss get gaussian random numbers (saved mode) -! harvest real(:) numbers output -! random_gauss get gaussian random numbers (interactive mode) -! harvest real(:) numbers output -! inseed integer seed input -! random_gauss_f get gaussian random number (functional mode) -! harvest real number output -! random_index get random indices (thread-safe mode) -! imax integer maximum index input -! iharvest integer(:) numbers output -! stat type(random_stat) input -! random_index get random indices (saved mode) -! imax integer maximum index input -! iharvest integer(:) numbers output -! random_index get random indices (interactive mode) -! imax integer maximum index input -! iharvest integer(:) numbers output -! inseed integer seed input -! random_index_f get random index (functional mode) -! imax integer maximum index input -! iharvest integer number output -! -! Remarks: -! (1) Here are the comments in the original open source code: -! A C-program for MT19937: Real number version -! genrand() generates one pseudorandom real number (double) -! which is uniformly distributed on [0,1]-interval, for each -! call. sgenrand(seed) set initial values to the working area -! of 624 words. Before genrand(), sgenrand(seed) must be -! called once. (seed is any 32-bit integer except for 0). -! Integer generator is obtained by modifying two lines. -! Coded by Takuji Nishimura, considering the suggestions by -! Topher Cooper and Marc Rieffel in July-Aug. 1997. -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Library General Public -! License as published by the Free Software Foundation; either -! version 2 of the License, or (at your option) any later -! version. -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -! See the GNU Library General Public License for more details. -! You should have received a copy of the GNU Library General -! Public License along with this library; if not, write to the -! Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA -! 02111-1307 USA -! Copyright (C) 1997 Makoto Matsumoto and Takuji Nishimura. -! When you use this, send an email to: matumoto@math.keio.ac.jp -! with an appropriate reference to your work. -! Fortran translation by Hiroshi Takano. Jan. 13, 1999. -! -! (2) On a single IBM Power4 processor on the NCEP operational cluster (2005) -! each Mersenne twister random number takes less than 30 ns, about 3 times -! slower than the default random number generator, and each random number -! from a Gaussian distribution takes less than 150 ns. -! -! Attributes: -! Language: Fortran 90 -! -!$$$ - module mersenne_twister - private -! Public declarations - public random_stat - public random_seed - public random_setseed - public random_number - public random_number_f - public random_gauss - public random_gauss_f - public random_index - public random_index_f -! Parameters - integer,parameter:: n=624 - integer,parameter:: m=397 - integer,parameter:: mata=-1727483681 ! constant vector a - integer,parameter:: umask=-2147483648 ! most significant w-r bits - integer,parameter:: lmask =2147483647 ! least significant r bits - integer,parameter:: tmaskb=-1658038656 ! tempering parameter - integer,parameter:: tmaskc=-272236544 ! tempering parameter - integer,parameter:: mag01(0:1)=(/0,mata/) - integer,parameter:: iseed=4357 - integer,parameter:: nrest=n+6 -! Defined types - type random_stat - private - integer:: mti=n+1 - integer:: mt(0:n-1) - integer:: iset - real:: gset - end type -! Saved data - type(random_stat),save:: sstat -! Overloaded interfaces - interface random_setseed - module procedure random_setseed_s - module procedure random_setseed_t - end interface - interface random_number - module procedure random_number_i - module procedure random_number_s - module procedure random_number_t - end interface - interface random_gauss - module procedure random_gauss_i - module procedure random_gauss_s - module procedure random_gauss_t - end interface - interface random_index - module procedure random_index_i - module procedure random_index_s - module procedure random_index_t - end interface -! All the subprograms - contains -! Subprogram random_seed -! Sets and gets state; overloads Fortran 90 standard. - subroutine random_seed(size,put,get,stat) - implicit none - integer,intent(out),optional:: size - integer,intent(in),optional:: put(nrest) - integer,intent(out),optional:: get(nrest) - type(random_stat),intent(inout),optional:: stat - if(present(size)) then ! return size of seed array -! if(present(put).or.present(get))& -! call errmsg('RANDOM_SEED: more than one option set - some ignored') - size=nrest - elseif(present(put)) then ! restore from seed array -! if(present(get))& -! call errmsg('RANDOM_SEED: more than one option set - some ignored') - if(present(stat)) then - stat%mti=put(1) - stat%mt=put(2:n+1) - stat%iset=put(n+2) - stat%gset=transfer(put(n+3:nrest),stat%gset) - if(stat%mti.lt.0.or.stat%mti.gt.n.or.any(stat%mt.eq.0).or. - & stat%iset.lt.0.or.stat%iset.gt.1) then - call random_setseed_t(iseed,stat) -! call errmsg('RANDOM_SEED: invalid seeds put - default seeds used') - endif - else - sstat%mti=put(1) - sstat%mt=put(2:n+1) - sstat%iset=put(n+2) - sstat%gset=transfer(put(n+3:nrest),sstat%gset) - if(sstat%mti.lt.0.or.sstat%mti.gt.n.or.any(sstat%mt.eq.0) - & .or.sstat%iset.lt.0.or.sstat%iset.gt.1) then - call random_setseed_t(iseed,sstat) -! call errmsg('RANDOM_SEED: invalid seeds put - default seeds used') - endif - endif - elseif(present(get)) then ! save to seed array - if(present(stat)) then - if(stat%mti.eq.n+1) call random_setseed_t(iseed,stat) - get(1)=stat%mti - get(2:n+1)=stat%mt - get(n+2)=stat%iset - get(n+3:nrest)=transfer(stat%gset,get,nrest-(n+3)+1) - else - if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat) - get(1)=sstat%mti - get(2:n+1)=sstat%mt - get(n+2)=sstat%iset - get(n+3:nrest)=transfer(sstat%gset,get,nrest-(n+3)+1) - endif - else ! reset default seed - if(present(stat)) then - call random_setseed_t(iseed,stat) - else - call random_setseed_t(iseed,sstat) - endif - endif - end subroutine -! Subprogram random_setseed_s -! Sets seed in saved mode. - subroutine random_setseed_s(inseed) - implicit none - integer,intent(in):: inseed - call random_setseed_t(inseed,sstat) - end subroutine -! Subprogram random_setseed_t -! Sets seed in thread-safe mode. - subroutine random_setseed_t(inseed,stat) - implicit none - integer,intent(in):: inseed - type(random_stat),intent(out):: stat - integer ii,mti - ii=inseed - if(ii.eq.0) ii=iseed - stat%mti=n - stat%mt(0)=iand(ii,-1) - do mti=1,n-1 - stat%mt(mti)=iand(69069*stat%mt(mti-1),-1) - enddo - stat%iset=0 - stat%gset=0. - end subroutine -! Subprogram random_number_f -! Generates random numbers in functional mode. - function random_number_f() result(harvest) - implicit none - real:: harvest - real h(1) - if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat) - call random_number_t(h,sstat) - harvest=h(1) - end function -! Subprogram random_number_i -! Generates random numbers in interactive mode. - subroutine random_number_i(harvest,inseed) - implicit none - real,intent(out):: harvest(:) - integer,intent(in):: inseed - type(random_stat) stat - call random_setseed_t(inseed,stat) - call random_number_t(harvest,stat) - end subroutine -! Subprogram random_number_s -! Generates random numbers in saved mode; overloads Fortran 90 standard. - subroutine random_number_s(harvest) - implicit none - real,intent(out):: harvest(:) - if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat) - call random_number_t(harvest,sstat) - end subroutine -! Subprogram random_number_t -! Generates random numbers in thread-safe mode. - subroutine random_number_t(harvest,stat) - implicit none - real,intent(out):: harvest(:) - type(random_stat),intent(inout):: stat - integer j,kk,y - integer tshftu,tshfts,tshftt,tshftl - tshftu(y)=ishft(y,-11) - tshfts(y)=ishft(y,7) - tshftt(y)=ishft(y,15) - tshftl(y)=ishft(y,-18) - do j=1,size(harvest) - if(stat%mti.ge.n) then - do kk=0,n-m-1 - y=ior(iand(stat%mt(kk),umask),iand(stat%mt(kk+1),lmask)) - stat%mt(kk)=ieor(ieor(stat%mt(kk+m),ishft(y,-1)), - & mag01(iand(y,1))) - enddo - do kk=n-m,n-2 - y=ior(iand(stat%mt(kk),umask),iand(stat%mt(kk+1),lmask)) - stat%mt(kk)=ieor(ieor(stat%mt(kk+(m-n)),ishft(y,-1)), - & mag01(iand(y,1))) - enddo - y=ior(iand(stat%mt(n-1),umask),iand(stat%mt(0),lmask)) - stat%mt(n-1)=ieor(ieor(stat%mt(m-1),ishft(y,-1)), - & mag01(iand(y,1))) - stat%mti=0 - endif - y=stat%mt(stat%mti) - y=ieor(y,tshftu(y)) - y=ieor(y,iand(tshfts(y),tmaskb)) - y=ieor(y,iand(tshftt(y),tmaskc)) - y=ieor(y,tshftl(y)) - if(y.lt.0) then - harvest(j)=(real(y)+2.0**32)/(2.0**32-1.0) - else - harvest(j)=real(y)/(2.0**32-1.0) - endif - stat%mti=stat%mti+1 - enddo - end subroutine -! Subprogram random_gauss_f -! Generates Gaussian random numbers in functional mode. - function random_gauss_f() result(harvest) - implicit none - real:: harvest - real h(1) - if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat) - call random_gauss_t(h,sstat) - harvest=h(1) - end function -! Subprogram random_gauss_i -! Generates Gaussian random numbers in interactive mode. - subroutine random_gauss_i(harvest,inseed) - implicit none - real,intent(out):: harvest(:) - integer,intent(in):: inseed - type(random_stat) stat - call random_setseed_t(inseed,stat) - call random_gauss_t(harvest,stat) - end subroutine -! Subprogram random_gauss_s -! Generates Gaussian random numbers in saved mode. - subroutine random_gauss_s(harvest) - implicit none - real,intent(out):: harvest(:) - if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat) - call random_gauss_t(harvest,sstat) - end subroutine -! Subprogram random_gauss_t -! Generates Gaussian random numbers in thread-safe mode. - subroutine random_gauss_t(harvest,stat) - implicit none - real,intent(out):: harvest(:) - type(random_stat),intent(inout):: stat - integer mx,my,mz,j - real r2(2),r,g1,g2 - mz=size(harvest) - if(mz.le.0) return - mx=0 - if(stat%iset.eq.1) then - mx=1 - harvest(1)=stat%gset - stat%iset=0 - endif - my=(mz-mx)/2*2+mx - do - call random_number_t(harvest(mx+1:my),stat) - do j=mx,my-2,2 - call rgauss(harvest(j+1),harvest(j+2),r,g1,g2) - if(r.lt.1.) then - harvest(mx+1)=g1 - harvest(mx+2)=g2 - mx=mx+2 - endif - enddo - if(mx.eq.my) exit - enddo - if(my.lt.mz) then - do - call random_number_t(r2,stat) - call rgauss(r2(1),r2(2),r,g1,g2) - if(r.lt.1.) exit - enddo - harvest(mz)=g1 - stat%gset=g2 - stat%iset=1 - endif - contains -! Numerical Recipes algorithm to generate Gaussian random numbers. - subroutine rgauss(r1,r2,r,g1,g2) - real,intent(in):: r1,r2 - real,intent(out):: r,g1,g2 - real v1,v2,fac - v1=2.*r1-1. - v2=2.*r2-1. - r=v1**2+v2**2 - if(r.lt.1.) then - fac=sqrt(-2.*log(r)/r) - g1=v1*fac - g2=v2*fac - endif - end subroutine - end subroutine -! Subprogram random_index_f -! Generates random indices in functional mode. - function random_index_f(imax) result(iharvest) - implicit none - integer,intent(in):: imax - integer:: iharvest - integer ih(1) - if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat) - call random_index_t(imax,ih,sstat) - iharvest=ih(1) - end function -! Subprogram random_index_i -! Generates random indices in interactive mode. - subroutine random_index_i(imax,iharvest,inseed) - implicit none - integer,intent(in):: imax - integer,intent(out):: iharvest(:) - integer,intent(in):: inseed - type(random_stat) stat - call random_setseed_t(inseed,stat) - call random_index_t(imax,iharvest,stat) - end subroutine -! Subprogram random_index_s -! Generates random indices in saved mode. - subroutine random_index_s(imax,iharvest) - implicit none - integer,intent(in):: imax - integer,intent(out):: iharvest(:) - if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat) - call random_index_t(imax,iharvest,sstat) - end subroutine -! Subprogram random_index_t -! Generates random indices in thread-safe mode. - subroutine random_index_t(imax,iharvest,stat) - implicit none - integer,intent(in):: imax - integer,intent(out):: iharvest(:) - type(random_stat),intent(inout):: stat - integer,parameter:: mh=n - integer i1,i2,mz - real h(mh) - mz=size(iharvest) - do i1=1,mz,mh - i2=min((i1-1)+mh,mz) - call random_number_t(h(:i2-(i1-1)),stat) - iharvest(i1:i2)=max(ceiling(h(:i2-(i1-1))*imax),1) - enddo - end subroutine - end module diff --git a/src/fim/FIMsrc/w3/mkfldsep.f b/src/fim/FIMsrc/w3/mkfldsep.f deleted file mode 100644 index 706dd1b..0000000 --- a/src/fim/FIMsrc/w3/mkfldsep.f +++ /dev/null @@ -1,105 +0,0 @@ - subroutine mkfldsep(csep,iopt,lenin,lenbull,lenout) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: mkfldsep Makes TOC Flag Field Separator Block -C PRGMMR: Gilbert ORG: W/NP11 DATE: 2002-09-16 -C -C ABSTRACT: Generates a TOC Flag Field Separator Block used to separate -C WMO Bulletins within a transmission file to be ingested in TOC's -C FTP Input Service, which can be used to disseminate WMO buletins. -C ( see http://weather.gov/tg/ftpingest.html ) -C -C This routine can generate different flag field separator blocks -C depending on the value of variable iopt. -C -C Bulletin "Flag Field Separator" block - OPTION 1 (old) -C bytes 1 - 4 marker string (####) -C 5 - 7 block length [018 fixed value] -C 8 - 13 total length of bulletin in bytes [octets] -C (not including the flag field block) -C 14 - 17 marker string (####) -C 18 line Feed (ASCII "0A") -C -C Bulletin "Flag Field Separator" block - OPTION 1a (new) -C bytes 1 - 4 marker string (####) -C 5 - 7 block length (nnn) - value always greater than 018 -C 8 - 18 total length of bulletin in bytes [octets] -C (not including the flag field block) -C 19 - nnn-5 reserved for future use -C nnn-4 - nnn-1 marker string (####) -C nnn line Feed (ASCII "0A") -C -C Bulletin "Flag Field Separator" block - OPTION 2 (limited) -C bytes 1 - 4 marker string (****) -C 5 - 14 total length of bulletin in bytes [octets] -C (not including the flag field block) -C 15 - 18 marker string (****) -C 19 line Feed (ASCII "0A") -C -C -C PROGRAM HISTORY LOG: -C 2002-09-16 Gilbert ORIGINAL AUTHOR -C -C USAGE: call mkfldsep(csep,iopt,lenin,lenbull,lenout) -C INPUT ARGUMENT LIST: -C iopt Flag Field Separator block option: -C = 1: Separator block for use with alphanumeric bulletins. -C if lenin <= 18 and lenbull <= 999999, -C OPTION 1 block will be generated. -C if lenin > 18 or lenbull > 999999, -C OPTION 1a block will be generated. -C = 2: Separator block for use with GRIB/BUFR bulletins. -C lenin Desired length of the flag field separator block. -C ignored, if iopt=2. -C lenbull Integer length of the bulletin (in bytes) that will follow -C this separator block. -C -C OUTPUT ARGUMENT LIST: -C csep*(*) Character array containing the flag field separator. -C lenout Integer length of the flag field separator block. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM/SP -C -C$$$ -C - character*(*),intent(out) :: csep - integer,intent(in) :: iopt,lenin,lenbull - integer,intent(out) :: lenout -C - character(len=4),parameter :: cstar='****',clb='####' -C - if (iopt.eq.1) then - if ( lenin .le. 18 .and. lenbull .le. 999999 ) then - ! Create OPTION 1 separator block - csep(1:4)=clb - csep(5:7)='018' - write(csep(8:13),fmt='(I6.6)') lenbull - csep(14:17)=clb - csep(18:18)=char(10) - lenout=18 - else ! Create OPTION 1a separator block - nnn=lenin - if ( nnn.lt.23 ) nnn=23 - csep(1:4)=clb - write(csep(5:7),fmt='(I3.3)') nnn - write(csep(8:18),fmt='(I11.11)') lenbull - csep(19:nnn-5)='0' - csep(nnn-4:nnn-1)=clb - csep(nnn:nnn)=char(10) - lenout=nnn - endif - elseif (iopt.eq.2) then ! Create OPTION 2 separator block - csep(1:4)=cstar - write(csep(5:14),fmt='(I10.10)') lenbull - csep(15:18)=cstar - csep(19:19)=char(10) - lenout=19 - else - print *,"mkfldsep: Option ",iopt," not recognized." - csep(1:lenin)=' ' - endif -C - return - end diff --git a/src/fim/FIMsrc/w3/mova2i.f b/src/fim/FIMsrc/w3/mova2i.f deleted file mode 100644 index 97c34c2..0000000 --- a/src/fim/FIMsrc/w3/mova2i.f +++ /dev/null @@ -1,52 +0,0 @@ - Integer Function mova2i(a) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: mova2i Moves a bit string from a char*1 to int -C PRGMMR: Gilbert ORG: W/NP11 DATE: 98-12-15 -C -C ABSTRACT: This Function copies a bit string from a Character*1 variable -C to an integer variable. It is intended to replace the Fortran Intrinsic -C Function ICHAR, which only supports 0 <= ICHAR(a) <= 127 on the -C IBM SP. If "a" is greater than 127 in the collating sequence, -C ICHAR(a) does not return the expected bit value when the -qhot -C ( and therefore -qsmp) option is used when compiling. -C This function can be used for all values 0 <= ICHAR(a) <= 255 and -C will work with or without the -qhot compiler option. -C -C PROGRAM HISTORY LOG: -C 98-12-15 Gilbert -C 2001-06-11 Gilbert - added a step to fill an 8-byte character -C array with the same value so that the -C f90 transfer function is more predictable. -C All bytes will now contain the desired value. -C -C USAGE: I = mova2i(a) -C -C INPUT ARGUMENT : -C -C a - Character*1 variable that holds the bitstring to extract -C -C RETURN ARGUMENT : -C -C mova2i - Integer value of the bitstring in character a -C -C REMARKS: -C -C None -C -C ATTRIBUTES: -C LANGUAGE: IBM XL FORTRAN -C MACHINE: IBM SP -C -C$$$ -C - integer mold - character(len=1) a - character(len=1) ctemp(8) - - ctemp(1:8)=a -c mova2i=ishft(transfer(ctemp,mold),8-bit_size(mold)) - mova2i=iand(transfer(ctemp,mold),255) - - return - end diff --git a/src/fim/FIMsrc/w3/orders.f b/src/fim/FIMsrc/w3/orders.f deleted file mode 100644 index 38fe3f9..0000000 --- a/src/fim/FIMsrc/w3/orders.f +++ /dev/null @@ -1,276 +0,0 @@ -C$$$ SUBROUTINE DOCUMENTATION BLOCK -C . . . . -C SUBROUTINE: ORDERS A STABLE (RADIX) MULTIPURPOSE SORT ROUTINE -C PRGMMR: KEYSER ORG: NP22 DATE: 1999-06-03 -C -C ABSTRACT: -C ORDERS IS A FAST AND STABLE SORT ROUTINE SUITABLE FOR EFFICIENT, -C MULTIPLE-PASS SORTING ON VARIABLE LENGTH CHARACTERS, INTEGERS, OR -C REAL NUMBERS. THE ALGORITHM DERIVES FROM THE RADIX OR BUCKET SORT -C PROCEDURE. THE FORM OF THE ORDERS SUBROUTINE IS DEFINED BY A CRAY -C MAN PAGE. THE SORT WORKS BY COMPUTING FREQUENCY DISTRIBUTION OF THE -C SET OF SORT KEYS AND USING THAT AS A MAP OF THE REORDERED DATA. -C ORDERS REARRANGES INDEXES INSTEAD OF THE SORT KEYS, WHICH SIMPLIFIES -C MULTI-PASS RECORD SORTING. THE RADIX OF THE SORT DETERMINES HOW MANY -C "BUCKETS" THERE ARE IN THE FREQUENCY DISTRIBUTION ARRAY. THE LARGER -C THE RADIX THE MORE BUCKETS. THE SIMPLEST IS A ONE BIT RADIX, WHICH -C HAS TWO BUCKETS, AND REQUIRES AS MANY PASSES THROUGH THE KEYS AS -C THE KEYS HAVE BITS. A ONE BYTE RADIX REQUIRES LESS PASSES THROUGH -C THE DATA WITH MORE BUCKETS (256 TO BE EXACT). THE ONE BYTE RADIX -C IS IMPLEMENTED HERE. AN ADDITIONAL COMPLICATION IS THE FACT THAT -C RADIX SORT ONLY WORKS ON KEY SETS OF POSITIVE VALUES, SO THIS -C IMPLEMENTATION INCLUDES A BIASING OF THE (NUMERIC) KEYS BEFORE -C SORTING. TO SAVE SPACE THE KEYS THEMSELVES ARE ADJUSTED AND THEN -C READJUSTED BEFORE RETURNING. A SIMPLE EXAMPLE OF A ONE BIT RADIX -C SORT ON A LIST OF FOUR, FOUR BIT, NUMBERS IS DIAGRAMED BELOW TO -C ILLUSTRATE THE CONCEPT. -C -C----------------------------------------------------------------------- -C PASS1 > PASS2 > PASS3 > PASS4 > FINISHED -C----------------------------------------------------------------------- -C | | | | -C THE LIST 0011 0100 0100 1001 0011 -C 0101 0011 0101 0011 0100 -C 1001 0101 1001 0100 0101 -C 0100 1001 0011 0101 1001 -C----------------------------------------------------------------------- -C BUCKET 0 0100 0100 1001 0011 -C | 0101 0011 0100 -C | 1001 | 0101 -C----------------------------------------------------------------------- -C BUCKET 1 0011 0011 0100 1001 -C 0101 | 0101 | -C 1001 | | | -C----------------------------------------------------------------------- -C -C PROGRAM HISTORY LOG: -C 1998-02-21 J. WOOLLEN ORIGINAL VERSION FOR IMPLEMENTATION -C 1998-04-11 B. VUONG REPLACED OPERAND .AND. WITH INTRINSIC IAND -C 1999-06-03 D. KEYSER MODIFIED TO PORT TO IBM SP AND RUN IN 4 OR -C 8 BYTE STORAGE -C 1999-06-09 J. WOOLLEN ADDED POTENTIAL FOR FOUR OR EIGHT BYTE KEYS -C IN EITHER A FOUR OR EIGHT BYTE ENVIRONMENT -C -C USAGE: CALL ORDERS(IN,ISORT,IDATA,INDEX,N,M,I1,I2) -C -C INPUT ARGUMENTS: -C IN - INDICATOR OF KEY FORM AND INDEX STATE -C IN = 0 INITIALIZE INDEXES AND SORT CHARACTERS -C IN = 1 INITIALIZE INDEXES AND SORT INTEGERS -C IN = 2 INITIALIZE INDEXES AND SORT REAL NUMBERS -C IN = 10 SORT CHARACTERS WITH INDEXES AS IS -C IN = 11 SORT INTEGERS WITH INDEXES AS IS -C IN = 12 SORT REAL NUMBERS WITH INDEXES ASIS -C ISORT - WORK ARRAY WITH THE SAME DIMENSION AS IDATA -C IDATA - ARRAY OF SORT KEYS AS DESCRIBED BY IN -C INDEX - ARRAY OF INDEXES REPRESENTING THE SORTED IDATA -C N - DIMENSION OF ISORT, IDATA, AND INDEX -C M - OFFSET (IN KEY-WORDS) BETWEEN SUCCESSIVE MEMBERS OF IDATA -C I1 - BYTE LENGTH OF THE KEY-WORDS -C I2 - NOT USED; INCLUDED FOR COMPATABILITY WITH ORIGINAL CRAY -C ROUTINE -C -C OUTPUT ARGUMENTS: -C INDEX - ARRAY OF INDEXES REPRESENTING THE SORTED 'IDATA' -C -C SUBPROGRAMS CALLED: -C UNIQUE: - NONE -C LIBRARY: - NONE -C -C REMARKS: -C THE ONE BYTE RADIX METHOD WAS SELECTED FOR ORDERS BECAUSE IT -C OFFERS A GOOD RATIO OF MEMORY REQUIREMENT TO OPERATION COUNT -C FOR PRODUCING A SORT. BECAUSE OF RECURSIVE MANIPULATION OF INDEXES -C IN ONE OF THE LOOPS, THIS MAY ACTUALLY TAKE SLIGHTLY LONGER ON SOME -C VECTOR MACHINES THAN A (MORE WORK INTENSIVE) ONE BIT RADIX METHOD. -C IN GENERAL, THOUGH, THE ONE BYTE METHOD IS FASTER. ANY LARGER RADIX -C PRESENTS EXPONENTIALLY INCREASING MEMORY REQUIRED. NOTE THAT THE -C IMPLEMENTATION USES VERY LITTLE LOCAL DATA SPACE, AND ONLY MODEST -C USER-SUPPLIED MEMORY. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: INDEPENDENT -C -C$$$ -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - SUBROUTINE ORDERS(IN,ISORT,IDATA,INDEX,N,M,I1,I2) - - DIMENSION ISORT(N),INDEX(N) - INTEGER(8) IDATA(M,N),ICHEK,IBYT - REAL(8) SMAL,RCHEK - DIMENSION INDX(0:255),KNDX(0:255) - EQUIVALENCE (ICHEK,RCHEK) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - IF(I1.EQ.4) THEN - CALL ORDER4(IN,ISORT,IDATA,INDEX,N,M,I1,I2) - RETURN - ELSEIF(I1.NE.8) THEN - PRINT*,'ORDERS CALLED WITH ODD SIZED WORDS - DEFAULT 8 BYTE' - ENDIF - -C DISCERN THE VARIABLE TYPE OF THE INPUT ARRAY, AND MAYBE SET INDEXES -C ------------------------------------------------------------------- - - ITYPE = MOD(IN,10) - IF(IN.LT.10) THEN - DO I=1,N - INDEX(I) = I - ENDDO - ENDIF - -C COMPUTE A POSITIVE BIAS FOR INTEGER OR REAL NUMBERS -C --------------------------------------------------- - - IF(ITYPE.GT.0) THEN - SMAL = 1 - DO I=1,N - ICHEK = IDATA(1,I) - IF(ITYPE.EQ.1 .AND. ICHEK.LT.SMAL) SMAL = ICHEK - IF(ITYPE.EQ.2 .AND. RCHEK.LT.SMAL) SMAL = RCHEK - ENDDO - SMAL = 1-SMAL - DO I=1,N - ICHEK = IDATA(1,I) - IF(ITYPE.EQ.1) ICHEK = ICHEK+SMAL - IF(ITYPE.EQ.2) RCHEK = RCHEK+SMAL - IDATA(1,I) = ICHEK - ENDDO - ENDIF - -C SORT THE INPUT SET W/1BYTE RADIX - REARRANGE SORT LIST INDEXES ONLY -C ------------------------------------------------------------------- - - DO IBYT=0,I1-1 - - KNDX(0) = 1 - DO I=0,255 - INDX(I) = 0 - ENDDO - - DO I=1,N - JBYT = IAND(ISHFT(IDATA(1,INDEX(I)),-IBYT*8_8),255_8) - INDX(JBYT) = INDX(JBYT)+1 - ISORT(I) = INDEX(I) - ENDDO - - DO I=1,255 - KNDX(I) = KNDX(I-1)+INDX(I-1) - ENDDO - - DO I=1,N - JBYT = IAND(ISHFT(IDATA(1,ISORT(I)),-IBYT*8_8),255_8) - INDEX(KNDX(JBYT)) = ISORT(I) - KNDX(JBYT) = KNDX(JBYT)+1 - ENDDO - - ENDDO - -C UNBIAS THE INPUT ARRAY ON THE WAY OUT -C ------------------------------------- - - IF(ITYPE.GT.0) THEN - DO I=1,N - ICHEK = IDATA(1,I) - IF(ITYPE.EQ.1) ICHEK = ICHEK-SMAL - IF(ITYPE.EQ.2) RCHEK = RCHEK-SMAL - IDATA(1,I) = ICHEK - ENDDO - ENDIF - -C FINISHED! -C --------- - - RETURN - END -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - SUBROUTINE ORDER4(IN,ISORT,IDATA,INDEX,N,M,I1,I2) - - DIMENSION ISORT(N),INDEX(N) - INTEGER(4) IDATA(M,N),ICHEK,IBYT - REAL(4) SMAL,RCHEK - DIMENSION INDX(0:255),KNDX(0:255) - EQUIVALENCE (ICHEK,RCHEK) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C DISCERN THE VARIABLE TYPE OF THE INPUT ARRAY, AND MAYBE SET INDEXES -C ------------------------------------------------------------------- - - ITYPE = MOD(IN,10) - IF(IN.LT.10) THEN - DO I=1,N - INDEX(I) = I - ENDDO - ENDIF - -C COMPUTE A POSITIVE BIAS FOR INTEGER OR REAL NUMBERS -C --------------------------------------------------- - - IF(ITYPE.GT.0) THEN - SMAL = 1 - DO I=1,N - ICHEK = IDATA(1,I) - IF(ITYPE.EQ.1 .AND. ICHEK.LT.SMAL) SMAL = ICHEK - IF(ITYPE.EQ.2 .AND. RCHEK.LT.SMAL) SMAL = RCHEK - ENDDO - SMAL = 1-SMAL - DO I=1,N - ICHEK = IDATA(1,I) - IF(ITYPE.EQ.1) ICHEK = ICHEK+SMAL - IF(ITYPE.EQ.2) RCHEK = RCHEK+SMAL - IDATA(1,I) = ICHEK - ENDDO - ENDIF - -C SORT THE INPUT SET W/1BYTE RADIX - REARRANGE SORT LIST INDEXES ONLY -C ------------------------------------------------------------------- - - DO IBYT=0,I1-1 - - KNDX(0) = 1 - DO I=0,255 - INDX(I) = 0 - ENDDO - - DO I=1,N - JBYT = IAND(ISHFT(IDATA(1,INDEX(I)),-IBYT*8_4),255_4) - INDX(JBYT) = INDX(JBYT)+1 - ISORT(I) = INDEX(I) - ENDDO - - DO I=1,255 - KNDX(I) = KNDX(I-1)+INDX(I-1) - ENDDO - - DO I=1,N - JBYT = IAND(ISHFT(IDATA(1,ISORT(I)),-IBYT*8_4),255_4) - INDEX(KNDX(JBYT)) = ISORT(I) - KNDX(JBYT) = KNDX(JBYT)+1 - ENDDO - - ENDDO - -C UNBIAS THE INPUT ARRAY ON THE WAY OUT -C ------------------------------------- - - IF(ITYPE.GT.0) THEN - DO I=1,N - ICHEK = IDATA(1,I) - IF(ITYPE.EQ.1) ICHEK = ICHEK-SMAL - IF(ITYPE.EQ.2) RCHEK = RCHEK-SMAL - IDATA(1,I) = ICHEK - ENDDO - ENDIF - -C FINISHED! -C --------- - - RETURN - END diff --git a/src/fim/FIMsrc/w3/pdsens.f b/src/fim/FIMsrc/w3/pdsens.f deleted file mode 100644 index a506802..0000000 --- a/src/fim/FIMsrc/w3/pdsens.f +++ /dev/null @@ -1,76 +0,0 @@ -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: PDSENS.F PACKS GRIB PDS EXTENSION 41- FOR ENSEMBLE -C PRGMMR: RICHARD WOBUS ORG: W/NP20 DATE: 98-09-28 -C -C ABSTRACT: PACKS BRIB PDS EXTENSION STARTING ON BYTE 41 FOR ENSEMBLE -C FORECAST PRODUCTS. FOR FORMAT OF PDS EXTENSION, SEE NMC OFFICE NOTE 38 -C -C PROGRAM HISTORY LOG: -C 95-03-14 ZOLTAN TOTH AND MARK IREDELL -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 98-09-28 WOBUS CORRECTED MEMBER ENTRY, BLANK ALL UNUSED FIELDS -C 2001-06-05 IREDELL APPLY LINUX PORT BY EBISUZAKI -C -C USAGE: CALL PDSENS.F(KENS,KPROB,XPROB,KCLUST,KMEMBR,ILAST,MSGA) -C INPUT ARGUMENT LIST: -C KENS(5) - BYTES 41-45 (GENERAL SECTION, ALWAYS PRESENT.) -C KPROB(2) - BYTES 46-47 (PROBABILITY SECTION, PRESENT ONLY IF NEEDE -C XPROB(2) - BYTES 48-51&52-55 (PROBABILITY SECTION, IF NEEDED.) -C KCLUST(16)-BYTES 61-76 (CLUSTERING SECTION, IF NEEDED.) -C KMEMBR(80)-BYTES 77-86 (CLUSTER MEMBERSHIP SECTION, IF NEEDED.) -C ILAST - LAST BYTE TO BE PACKED (IF GREATER OR EQUAL TO FIRST BY -C IN ANY OF FOUR SECTIONS ABOVE, WHOLE SECTION IS PACKED. -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C MSGA - FULL PDS SECTION, INCLUDING NEW ENSEMBLE EXTENSION -C -C REMARKS: USE PDSEUP.F FOR UNPACKING PDS ENSEMBLE EXTENSION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ -C TESTING GRIB EXTENSION 41- PACKER AND UNPACKER SUBROUTINES -C -CFPP$ NOCONCUR R - SUBROUTINE PDSENS(KENS,KPROB,XPROB,KCLUST,KMEMBR,ILAST,MSGA) - INTEGER KENS(5),KPROB(2),KCLUST(16),KMEMBR(80) - DIMENSION XPROB(2) - CHARACTER*1 MSGA(100) - IF(ILAST.LT.41) THEN - GO TO 333 - ENDIF -C PACKING IS DONE IN FOUR SECTIONS ENDING AT BYTE IL - IF(ILAST.GE.41) IL=45 - IF(ILAST.GE.46) IL=55 - IF(ILAST.GE.61) IL=76 - IF(ILAST.GE.77) IL=86 - do i=42,il - CALL SBYTEC(MSGA, 0, i*8, 8) - enddo -C CHANGING THE NUMBER OF BYTES (FIRST THREE BYTES IN PDS) - CALL SBYTEC(MSGA, IL, 0,24) -C PACKING FIRST SECTION (GENERAL INTORMATION SECTION) - IF(IL.GE.45) CALL SBYTESC(MSGA,KENS,40*8,8,0,5) -C PACKING 2ND SECTION (PROBABILITY SECTION) - IF(IL.GE.55) THEN - CALL SBYTESC(MSGA,KPROB,45*8,8,0,2) - CALL W3FI01(LW) - CALL W3FI76(XPROB(1),IEXP,IMANT,8*LW) - CALL SBYTEC(MSGA,IEXP,47*8,8) - CALL SBYTEC(MSGA,IMANT,48*8,24) - CALL W3FI76(XPROB(2),IEXP,IMANT,8*LW) - CALL SBYTEC(MSGA,IEXP,51*8,8) - CALL SBYTEC(MSGA,IMANT,52*8,24) - ENDIF -C PACKING 3RD SECTION (CLUSTERING INFORMATION) - IF(IL.GE.76) CALL SBYTESC(MSGA,KCLUST,60*8,8,0,16) -C PACKING 4TH SECTION (CLUSTER MEMBERSHIP) - IF(IL.GE.86) CALL SBYTESC(MSGA,KMEMBR,76*8,1,0,80) -C - 333 CONTINUE - RETURN - END diff --git a/src/fim/FIMsrc/w3/pdseup.f b/src/fim/FIMsrc/w3/pdseup.f deleted file mode 100644 index 7127a25..0000000 --- a/src/fim/FIMsrc/w3/pdseup.f +++ /dev/null @@ -1,74 +0,0 @@ -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: PDSEUP.F UNPACKS GRIB PDS EXTENSION 41- FOR ENSEMBLE -C PRGMMR: RICHARD WOBUS ORG: W/NP20 DATE: 98-09-28 -C -C ABSTRACT: UNPACKS GRIB PDS EXTENSION STARTING ON BYTE 41 FOR ENSEMBLE -C FORECAST PRODUCTS. FOR FORMAT OF PDS EXTENSION, SEE NMC OFFICE NOTE 38 -C -C PROGRAM HISTORY LOG: -C 95-03-14 ZOLTAN TOTH AND MARK IREDELL -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 98-09-28 WOBUS CORRECTED MEMBER EXTRACTION -C 2001-06-05 IREDELL APPLY LINUX PORT BY EBISUZAKI -C -C USAGE: CALL PDSENS.F(KENS,KPROB,XPROB,KCLUST,KMEMBR,ILAST,MSGA) -C INPUT ARGUMENT LIST: -C ILAST - LAST BYTE TO BE UNPACKED (IF GREATER/EQUAL TO FIRST BYT -C IN ANY OF FOUR SECTIONS BELOW, WHOLE SECTION IS PACKED. -C MSGA - FULL PDS SECTION, INCLUDING NEW ENSEMBLE EXTENSION -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KENS(5) - BYTES 41-45 (GENERAL SECTION, ALWAYS PRESENT.) -C KPROB(2) - BYTES 46-47 (PROBABILITY SECTION, PRESENT ONLY IF NEEDE -C XPROB(2) - BYTES 48-51&52-55 (PROBABILITY SECTION, IF NEEDED.) -C KCLUST(16)-BYTES 61-76 (CLUSTERING SECTION, IF NEEDED.) -C KMEMBR(80)-BYTES 77-86 (CLUSTER MEMBERSHIP SECTION, IF NEEDED.) -C -C REMARKS: USE PDSENS.F FOR PACKING PDS ENSEMBLE EXTENSION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: CF77 FORTRAN -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ -C - SUBROUTINE PDSEUP(KENS,KPROB,XPROB,KCLUST,KMEMBR,ILAST,MSGA) - INTEGER KENS(5),KPROB(2),KCLUST(16),KMEMBR(80) - DIMENSION XPROB(2) - CHARACTER*1 MSGA(100) -C CHECKING TOTAL NUMBER OF BYTES IN PDS (IBYTES) - CALL GBYTEC(MSGA, IBYTES, 0,24) - IF(ILAST.GT.IBYTES) THEN -C ILAST=IBYTES - GO TO 333 - ENDIF - IF(ILAST.LT.41) THEN - GO TO 333 - ENDIF -C UNPACKING FIRST SECTION (GENERAL INFORMATION) - CALL GBYTESC(MSGA,KENS,40*8,8,0,5) -C UNPACKING 2ND SECTION (PROBABILITY SECTION) - IF(ILAST.GE.46) THEN - CALL GBYTESC(MSGA,KPROB,45*8,8,0,2) -C - CALL GBYTEC (MSGA,JSGN,47*8,1) - CALL GBYTEC (MSGA,JEXP,47*8+1,7) - CALL GBYTEC (MSGA,IFR,47*8+8,24) - XPROB(1)=(-1)**JSGN*IFR*16.**(JEXP-70) -C - CALL GBYTEC (MSGA,JSGN,51*8,1) - CALL GBYTEC (MSGA,JEXP,51*8+1,7) - CALL GBYTEC (MSGA,IFR,51*8+8,24) - XPROB(2)=(-1)**JSGN*IFR*16.**(JEXP-70) - ENDIF -C -C UNPACKING 3RD SECTION (CLUSTERING INFORMATION) - IF(ILAST.GE.61) CALL GBYTESC(MSGA,KCLUST,60*8,8,0,16) -C UNPACKING 4TH SECTION (CLUSTERMEMBERSHIP INFORMATION) - IF(ILAST.GE.77) CALL GBYTESC(MSGA,KMEMBR,76*8,1,0,80) -C - 333 CONTINUE - RETURN - END diff --git a/src/fim/FIMsrc/w3/putgb.f b/src/fim/FIMsrc/w3/putgb.f deleted file mode 100644 index b9366d0..0000000 --- a/src/fim/FIMsrc/w3/putgb.f +++ /dev/null @@ -1,202 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE PUTGB(LUGB,KF,KPDS,KGDS,LB,F,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: PUTGB PACKS AND WRITES A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: PACK AND WRITE A GRIB MESSAGE. -C THIS SUBPROGRAM IS NEARLY THE INVERSE OF GETGB. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C -C USAGE: CALL PUTGB(LUGB,KF,KPDS,KGDS,LB,F,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C KF INTEGER NUMBER OF DATA POINTS -C KPDS INTEGER (200) PDS PARAMETERS -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C KGDS INTEGER (200) GDS PARAMETERS -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C LB LOGICAL*1 (KF) BITMAP IF PRESENT -C F REAL (KF) DATA -C OUTPUT ARGUMENTS: -C IRET INTEGER RETURN CODE -C 0 ALL OK -C OTHER W3FI72 GRIB PACKER RETURN CODE -C -C SUBPROGRAMS CALLED: -C R63W72 MAP W3FI63 PARAMETERS ONTO W3FI72 PARAMETERS -C GETBIT GET NUMBER OF BITS AND ROUND DATA -C W3FI72 PACK GRIB -C WRYTE WRITE DATA -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER KPDS(200),KGDS(200) - LOGICAL*1 LB(KF) - REAL F(KF) - PARAMETER(MAXBIT=16) - INTEGER IBM(KF),IPDS(200),IGDS(200),IBDS(200) - REAL FR(KF) - CHARACTER PDS(400),GRIB(1000+KF*(MAXBIT+1)/8) -CWH CHARACTER PDS(400),GRIB(10000+KF*(MAXBIT+1)/8) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C GET W3FI72 PARAMETERS - CALL R63W72(KPDS,KGDS,IPDS,IGDS) - IBDS=0 - ICOMP=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COUNT VALID DATA - KBM=KF - IF(IPDS(7).NE.0) THEN - KBM=0 - DO I=1,KF - IF(LB(I)) THEN - IBM(I)=1 - KBM=KBM+1 - ELSE - IBM(I)=0 - ENDIF - ENDDO - IF(KBM.EQ.KF) IPDS(7)=0 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C GET NUMBER OF BITS AND ROUND DATA - IF(KBM.EQ.0) THEN - DO I=1,KF - FR(I)=0. - ENDDO - NBIT=0 - ELSE - CALL GETBIT(IPDS(7),0,IPDS(25),KF,IBM,F,FR,FMIN,FMAX,NBIT) - NBIT=MIN(NBIT,MAXBIT) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C PACK AND WRITE GRIB DATA - CALL W3FI72(0,FR,0,NBIT,0,IPDS,PDS, - & 1,255,IGDS,ICOMP,0,IBM,KF,IBDS, - & KFO,GRIB,LGRIB,IRET) - IF(IRET.EQ.0) CALL WRYTE(LUGB,LGRIB,GRIB) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/putgbe.f b/src/fim/FIMsrc/w3/putgbe.f deleted file mode 100644 index 57b7567..0000000 --- a/src/fim/FIMsrc/w3/putgbe.f +++ /dev/null @@ -1,213 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE PUTGBE(LUGB,KF,KPDS,KGDS,KENS,LB,F,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: PUTGBE PACKS AND WRITES A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: PACK AND WRITE A GRIB MESSAGE. -C THIS SUBPROGRAM IS NEARLY THE INVERSE OF GETGBE. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C -C USAGE: CALL PUTGBE(LUGB,KF,KPDS,KGDS,KENS,LB,F,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C KF INTEGER NUMBER OF DATA POINTS -C KPDS INTEGER (200) PDS PARAMETERS -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C KGDS INTEGER (200) GDS PARAMETERS -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C KENS INTEGER (200) ENSEMBLE PDS PARMS -C (1) - APPLICATION IDENTIFIER -C (2) - ENSEMBLE TYPE -C (3) - ENSEMBLE IDENTIFIER -C (4) - PRODUCT IDENTIFIER -C (5) - SMOOTHING FLAG -C LB LOGICAL*1 (KF) BITMAP IF PRESENT -C F REAL (KF) DATA -C OUTPUT ARGUMENTS: -C IRET INTEGER RETURN CODE -C 0 ALL OK -C OTHER W3FI72 GRIB PACKER RETURN CODE -C -C SUBPROGRAMS CALLED: -C R63W72 MAP W3FI63 PARAMETERS ONTO W3FI72 PARAMETERS -C GETBIT GET NUMBER OF BITS AND ROUND DATA -C W3FI72 PACK GRIB -C WRYTE WRITE DATA -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER KPDS(200),KGDS(200),KENS(200) - LOGICAL*1 LB(KF) - REAL F(KF) - PARAMETER(MAXBIT=16) - INTEGER IBM(KF),IPDS(200),IGDS(200),IBDS(200) - REAL FR(KF) - CHARACTER PDS(400),GRIB(1000+KF*(MAXBIT+1)/8) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C GET W3FI72 PARAMETERS - CALL R63W72(KPDS,KGDS,IPDS,IGDS) - IBDS=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COUNT VALID DATA - KBM=KF - IF(IPDS(7).NE.0) THEN - KBM=0 - DO I=1,KF - IF(LB(I)) THEN - IBM(I)=1 - KBM=KBM+1 - ELSE - IBM(I)=0 - ENDIF - ENDDO - IF(KBM.EQ.KF) IPDS(7)=0 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C GET NUMBER OF BITS AND ROUND DATA - IF(KBM.EQ.0) THEN - DO I=1,KF - FR(I)=0. - ENDDO - NBIT=0 - ELSE - CALL GETBIT(IPDS(7),0,IPDS(25),KF,IBM,F,FR,FMIN,FMAX,NBIT) - NBIT=MIN(NBIT,MAXBIT) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CREATE PRODUCT DEFINITION SECTION - CALL W3FI68(IPDS,PDS) - IF(IPDS(24).EQ.2) THEN - ILAST=45 - CALL PDSENS(KENS,KPROB,XPROB,KCLUST,KMEMBR,ILAST,PDS) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C PACK AND WRITE GRIB DATA - CALL W3FI72(0,FR,0,NBIT,1,IPDS,PDS, - & 1,255,IGDS,0,0,IBM,KF,IBDS, - & KFO,GRIB,LGRIB,IRET) - IF(IRET.EQ.0) CALL WRYTE(LUGB,LGRIB,GRIB) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/putgben.f b/src/fim/FIMsrc/w3/putgben.f deleted file mode 100644 index cdae860..0000000 --- a/src/fim/FIMsrc/w3/putgben.f +++ /dev/null @@ -1,223 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE PUTGBEN(LUGB,KF,KPDS,KGDS,KENS,IBS,NBITS,LB,F,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: PUTGBEN PACKS AND WRITES A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: PACK AND WRITE A GRIB MESSAGE. -C THIS SUBPROGRAM IS NEARLY THE INVERSE OF GETGBE. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 2001-03-16 IREDELL CORRECTED ARGUMENT LIST TO INCLUDE IBS -C -C USAGE: CALL PUTGBEN(LUGB,KF,KPDS,KGDS,KENS,IBS,NBITS,LB,F,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C KF INTEGER NUMBER OF DATA POINTS -C KPDS INTEGER (200) PDS PARAMETERS -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C KGDS INTEGER (200) GDS PARAMETERS -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C KENS INTEGER (200) ENSEMBLE PDS PARMS -C (1) - APPLICATION IDENTIFIER -C (2) - ENSEMBLE TYPE -C (3) - ENSEMBLE IDENTIFIER -C (4) - PRODUCT IDENTIFIER -C (5) - SMOOTHING FLAG -C IBS INTEGER BINARY SCALE FACTOR (0 TO IGNORE) -C NBITS INTEGER NUMBER OF BITS IN WHICH TO PACK (0 TO IGNORE) -C LB LOGICAL*1 (KF) BITMAP IF PRESENT -C F REAL (KF) DATA -C OUTPUT ARGUMENTS: -C IRET INTEGER RETURN CODE -C 0 ALL OK -C OTHER W3FI72 GRIB PACKER RETURN CODE -C -C SUBPROGRAMS CALLED: -C R63W72 MAP W3FI63 PARAMETERS ONTO W3FI72 PARAMETERS -C GETBIT GET NUMBER OF BITS AND ROUND DATA -C W3FI72 PACK GRIB -C WRYTE WRITE DATA -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER KPDS(200),KGDS(200),KENS(200) - LOGICAL*1 LB(KF) - REAL F(KF) - PARAMETER(MAXBIT=16) - INTEGER IBM(KF),IPDS(200),IGDS(200),IBDS(200) - REAL FR(KF) - CHARACTER PDS(400),GRIB(1000+KF*(MAXBIT+1)/8) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C GET W3FI72 PARAMETERS - CALL R63W72(KPDS,KGDS,IPDS,IGDS) - IBDS=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COUNT VALID DATA - KBM=KF - IF(IPDS(7).NE.0) THEN - KBM=0 - DO I=1,KF - IF(LB(I)) THEN - IBM(I)=1 - KBM=KBM+1 - ELSE - IBM(I)=0 - ENDIF - ENDDO - IF(KBM.EQ.KF) IPDS(7)=0 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C GET NUMBER OF BITS AND ROUND DATA - IF(NBITS.GT.0) THEN - DO I=1,KF - FR(I)=F(I) - ENDDO - NBIT=NBITS - ELSE - IF(KBM.EQ.0) THEN - DO I=1,KF - FR(I)=0. - ENDDO - NBIT=0 - ELSE - CALL GETBIT(IPDS(7),IBS,IPDS(25),KF,IBM,F,FR,FMIN,FMAX,NBIT) - NBIT=MIN(NBIT,MAXBIT) - ENDIF - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CREATE PRODUCT DEFINITION SECTION - CALL W3FI68(IPDS,PDS) - IF(IPDS(24).EQ.2) THEN - ILAST=45 - CALL PDSENS(KENS,KPROB,XPROB,KCLUST,KMEMBR,ILAST,PDS) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C PACK AND WRITE GRIB DATA - CALL W3FI72(0,FR,0,NBIT,1,IPDS,PDS, - & 1,255,IGDS,0,0,IBM,KF,IBDS, - & KFO,GRIB,LGRIB,IRET) - IF(IRET.EQ.0) CALL WRYTE(LUGB,LGRIB,GRIB) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/putgbens.f b/src/fim/FIMsrc/w3/putgbens.f deleted file mode 100644 index 6d01c13..0000000 --- a/src/fim/FIMsrc/w3/putgbens.f +++ /dev/null @@ -1,167 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE PUTGBENS(LUGB,KF,KPDS,KGDS,KENS,LB,F,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: PUTGBENS PACKS AND WRITES A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: PACK AND WRITE A GRIB MESSAGE. -C THIS SUBPROGRAM IS NEARLY THE INVERSE OF GETGBENS. -C THIS OBSOLESCENT VERSION HAS BEEN REPLACED BY PUTGBE. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C -C USAGE: CALL PUTGBENS(LUGB,KF,KPDS,KGDS,KENS,LB,F,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C KF INTEGER NUMBER OF DATA POINTS -C KPDS INTEGER (200) PDS PARAMETERS -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C KGDS INTEGER (200) GDS PARAMETERS -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C KENS INTEGER (200) ENSEMBLE PDS PARMS -C (1) - APPLICATION IDENTIFIER -C (2) - ENSEMBLE TYPE -C (3) - ENSEMBLE IDENTIFIER -C (4) - PRODUCT IDENTIFIER -C (5) - SMOOTHING FLAG -C LB LOGICAL*1 (KF) BITMAP IF PRESENT -C F REAL (KF) DATA -C OUTPUT ARGUMENTS: -C IRET INTEGER RETURN CODE -C 0 ALL OK -C OTHER W3FI72 GRIB PACKER RETURN CODE -C -C SUBPROGRAMS CALLED: -C PUTGBE PACK AND WRITE GRIB MESSAGE -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER KPDS(200),KGDS(200),KENS(200) - LOGICAL*1 LB(KF) - REAL F(KF) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - PRINT *,'PLEASE USE PUTGBE RATHER THAN PUTGBENS' - CALL PUTGBE(LUGB,KF,KPDS,KGDS,KENS,LB,F,IRET) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/putgbex.f b/src/fim/FIMsrc/w3/putgbex.f deleted file mode 100644 index f21413e..0000000 --- a/src/fim/FIMsrc/w3/putgbex.f +++ /dev/null @@ -1,222 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE PUTGBEX(LUGB,KF,KPDS,KGDS,KENS, - & KPROB,XPROB,KCLUST,KMEMBR,LB,F,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: PUTGBE PACKS AND WRITES A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: PACK AND WRITE A GRIB MESSAGE. -C THIS SUBPROGRAM IS NEARLY THE INVERSE OF GETGBE. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 97-02-11 Y.ZHU INCLUDED PROBABILITY AND CLUSTER ARGUMENTS -C -C USAGE: CALL PUTGBE(LUGB,KF,KPDS,KGDS,KENS, -C & KPROB,XPROB,KCLUST,KMEMBR,LB,F,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C KF INTEGER NUMBER OF DATA POINTS -C KPDS INTEGER (200) PDS PARAMETERS -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C KGDS INTEGER (200) GDS PARAMETERS -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C KENS INTEGER (200) ENSEMBLE PDS PARMS -C (1) - APPLICATION IDENTIFIER -C (2) - ENSEMBLE TYPE -C (3) - ENSEMBLE IDENTIFIER -C (4) - PRODUCT IDENTIFIER -C (5) - SMOOTHING FLAG -C KPROB INTEGER (2) PROBABILITY ENSEMBLE PARMS -C XPROB REAL (2) PROBABILITY ENSEMBLE PARMS -C KCLUST INTEGER (16) CLUSTER ENSEMBLE PARMS -C KMEMBR INTEGER (8) CLUSTER ENSEMBLE PARMS -C LB LOGICAL*1 (KF) BITMAP IF PRESENT -C F REAL (KF) DATA -C OUTPUT ARGUMENTS: -C IRET INTEGER RETURN CODE -C 0 ALL OK -C OTHER W3FI72 GRIB PACKER RETURN CODE -C -C SUBPROGRAMS CALLED: -C R63W72 MAP W3FI63 PARAMETERS ONTO W3FI72 PARAMETERS -C GETBIT GET NUMBER OF BITS AND ROUND DATA -C W3FI72 PACK GRIB -C WRYTE WRITE DATA -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER KPDS(200),KGDS(200),KENS(200) - INTEGER KPROB(2),KCLUST(16),KMEMBR(80) - REAL XPROB(2) - LOGICAL*1 LB(KF) - REAL F(KF) - PARAMETER(MAXBIT=16) - INTEGER IBM(KF),IPDS(200),IGDS(200),IBDS(200) - REAL FR(KF) - CHARACTER PDS(400),GRIB(1000+KF*(MAXBIT+1)/8) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C GET W3FI72 PARAMETERS - CALL R63W72(KPDS,KGDS,IPDS,IGDS) - IBDS=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COUNT VALID DATA - KBM=KF - IF(IPDS(7).NE.0) THEN - KBM=0 - DO I=1,KF - IF(LB(I)) THEN - IBM(I)=1 - KBM=KBM+1 - ELSE - IBM(I)=0 - ENDIF - ENDDO - IF(KBM.EQ.KF) IPDS(7)=0 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C GET NUMBER OF BITS AND ROUND DATA - IF(KBM.EQ.0) THEN - DO I=1,KF - FR(I)=0. - ENDDO - NBIT=0 - ELSE - CALL GETBIT(IPDS(7),0,IPDS(25),KF,IBM,F,FR,FMIN,FMAX,NBIT) - NBIT=MIN(NBIT,MAXBIT) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CREATE PRODUCT DEFINITION SECTION - CALL W3FI68(IPDS,PDS) - IF(IPDS(24).EQ.2) THEN - ILAST=86 - CALL PDSENS(KENS,KPROB,XPROB,KCLUST,KMEMBR,ILAST,PDS) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C PACK AND WRITE GRIB DATA - CALL W3FI72(0,FR,0,NBIT,1,IPDS,PDS, - & 1,255,IGDS,0,0,IBM,KF,IBDS, - & KFO,GRIB,LGRIB,IRET) - IF(IRET.EQ.0) CALL WRYTE(LUGB,LGRIB,GRIB) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/putgbn.f b/src/fim/FIMsrc/w3/putgbn.f deleted file mode 100644 index 671f110..0000000 --- a/src/fim/FIMsrc/w3/putgbn.f +++ /dev/null @@ -1,209 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE PUTGBN(LUGB,KF,KPDS,KGDS,IBS,NBITS,LB,F,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: PUTGBN PACKS AND WRITES A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: PACK AND WRITE A GRIB MESSAGE. -C THIS SUBPROGRAM IS NEARLY THE INVERSE OF GETGB. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C -C USAGE: CALL PUTGBN(LUGB,KF,KPDS,KGDS,NBITS,LB,F,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C KF INTEGER NUMBER OF DATA POINTS -C KPDS INTEGER (200) PDS PARAMETERS -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C KGDS INTEGER (200) GDS PARAMETERS -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C IBS INTEGER BINARY SCALE FACTOR (0 TO IGNORE) -C NBITS INTEGER NUMBER OF BITS IN WHICH TO PACK (0 TO IGNORE) -C LB LOGICAL*1 (KF) BITMAP IF PRESENT -C F REAL (KF) DATA -C OUTPUT ARGUMENTS: -C IRET INTEGER RETURN CODE -C 0 ALL OK -C OTHER W3FI72 GRIB PACKER RETURN CODE -C -C SUBPROGRAMS CALLED: -C R63W72 MAP W3FI63 PARAMETERS ONTO W3FI72 PARAMETERS -C GETBIT GET NUMBER OF BITS AND ROUND DATA -C W3FI72 PACK GRIB -C WRYTE WRITE DATA -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER KPDS(200),KGDS(200) - LOGICAL*1 LB(KF) - REAL F(KF) - PARAMETER(MAXBIT=16) - INTEGER IBM(KF),IPDS(200),IGDS(200),IBDS(200) - REAL FR(KF) - CHARACTER PDS(400),GRIB(1000+KF*(MAXBIT+1)/8) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C GET W3FI72 PARAMETERS - CALL R63W72(KPDS,KGDS,IPDS,IGDS) - IBDS=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COUNT VALID DATA - KBM=KF - IF(IPDS(7).NE.0) THEN - KBM=0 - DO I=1,KF - IF(LB(I)) THEN - IBM(I)=1 - KBM=KBM+1 - ELSE - IBM(I)=0 - ENDIF - ENDDO - IF(KBM.EQ.KF) IPDS(7)=0 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C GET NUMBER OF BITS AND ROUND DATA - IF(NBITS.GT.0) THEN - DO I=1,KF - FR(I)=F(I) - ENDDO - NBIT=NBITS - ELSE - IF(KBM.EQ.0) THEN - DO I=1,KF - FR(I)=0. - ENDDO - NBIT=0 - ELSE - CALL GETBIT(IPDS(7),IBS,IPDS(25),KF,IBM,F,FR,FMIN,FMAX,NBIT) - NBIT=MIN(NBIT,MAXBIT) - ENDIF - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C PACK AND WRITE GRIB DATA - CALL W3FI72(0,FR,0,NBIT,0,IPDS,PDS, - & 1,255,IGDS,0,0,IBM,KF,IBDS, - & KFO,GRIB,LGRIB,IRET) - IF(IRET.EQ.0) CALL WRYTE(LUGB,LGRIB,GRIB) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/q9ie32.f b/src/fim/FIMsrc/w3/q9ie32.f deleted file mode 100644 index 09596b4..0000000 --- a/src/fim/FIMsrc/w3/q9ie32.f +++ /dev/null @@ -1,139 +0,0 @@ - SUBROUTINE Q9IE32(A,B,N,ISTAT) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: Q9IE32 CONVERT IBM370 F.P. TO IEEE F.P. -C PRGMMR: R.E.JONES ORG: W/NMC42 DATE: 90-06-04 -C -C ABSTRACT: CONVERT IBM370 32 BIT FLOATING POINT NUMBERS TO IEEE -C 32 BIT TASK 754 FLOATING POINT NUMBERS. -C -C PROGRAM HISTORY LOG: -C 90-06-04 R.E.JONES CHANGE TO SUN FORTRAN 1.3 -C 90-07-14 R.E.JONES CHANGE ISHFT TO LSHIFT OR LRSHFT -C 91-03-09 R.E.JONES CHANGE TO SiliconGraphics FORTRAN -C 92-07-20 R.E.JONES CHANGE TO IBM AIX XL FORTRAN -C 95-11-15 R.E.JONES ADD SAVE STATEMENT -C 98-11-15 gilbert Specified 4-byte integers for IBM SP -C -C USAGE: CALL Q9IE32(A, B, N, ISTAT) -C INPUT ARGUMENT LIST: -C A - REAL*4 ARRAY OF IBM370 32 BIT FLOATING POINT NUMBERS -C N - NUMBER OF POINTS TO CONVERT -C -C OUTPUT ARGUMENT LIST: -C B - REAL*4 ARRAY OF IEEE 32 BIT FLOATING POINT NUMBERS -C ISTAT - NUMBER OF POINT GREATER THAN 10E+38, NUMBERS ARE SET TO -C IEEE INFINITY, ONE IS ADDED TO ISTAT. NUMBERS LESS THAN -C E-38 ARE SET TO ZERO , ONE IS NOT ADDED TO ISTAT. -C -C REMARKS: SEE IEEE TASK 754 STANDARD FLOATING POINT ARITHMETIC -C FOR MORE INFORMATION ABOUT IEEE F.P. -C -C ATTRIBUTES: -C LANGUAGE: IBM AIX XL FORTRAN Compiler/6000 -C MACHINE: IBM RS6000 model 530 -C -C$$$ -C - INTEGER(4) A(*) - INTEGER(4) B(*) - INTEGER(4) SIGN - INTEGER(4) INFIN,MASKFR,MASKSN,MASK21,MASK22,MASK23 - INTEGER(4) ITEMP,ISIGN,IEEEXP,K,LTEMP -C - SAVE -C - DATA INFIN /Z'7F800000'/ - DATA MASKFR/Z'007FFFFF'/ - DATA MASKSN/Z'7FFFFFFF'/ - DATA MASK21/Z'00200000'/ - DATA MASK22/Z'00400000'/ - DATA MASK23/Z'00800000'/ - DATA SIGN /Z'80000000'/ -C - IF (N.LT.1) THEN - ISTAT = -1 - RETURN - ENDIF -C - ISTAT = 0 -C - DO 40 I = 1,N - ISIGN = 0 - ITEMP = A(I) -C -C TEST SIGN BIT -C - IF (ITEMP.EQ.0) GO TO 30 -C - IF (ITEMP.LT.0) THEN -C - ISIGN = SIGN -C -C SET SIGN BIT TO ZERO -C - ITEMP = IAND(ITEMP,MASKSN) -C - END IF -C -C -C CONVERT IBM EXPONENT TO IEEE EXPONENT -C - IEEEXP = (ISHFT(ITEMP,-24_4) - 64_4) * 4 + 126 -C - K = 0 -C -C TEST BIT 23, 22, 21 -C ADD UP NUMBER OF ZERO BITS IN FRONT OF IBM370 FRACTION -C - IF (IAND(ITEMP,MASK23).NE.0) GO TO 10 - K = K + 1 - IF (IAND(ITEMP,MASK22).NE.0) GO TO 10 - K = K + 1 - IF (IAND(ITEMP,MASK21).NE.0) GO TO 10 - K = K + 1 -C - 10 CONTINUE -C -C SUBTRACT ZERO BITS FROM EXPONENT -C - IEEEXP = IEEEXP - K -C -C TEST FOR OVERFLOW -C - IF (IEEEXP.GT.254) GO TO 20 -C -C TEST FOR UNDERFLOW -C - IF (IEEEXP.LT.1) GO TO 30 -C -C SHIFT IEEE EXPONENT TO BITS 1 TO 8 -C - LTEMP = ISHFT(IEEEXP,23_4) -C -C SHIFT IBM370 FRACTION LEFT K BIT, AND OUT BITS 0 - 8 -C OR TOGETHER THE EXPONENT AND THE FRACTION -C OR IN SIGN BIT -C - B(I) = IOR(IOR(IAND(ISHFT(ITEMP,K),MASKFR),LTEMP),ISIGN) -C - GO TO 40 -C - 20 CONTINUE -C -C OVERFLOW , SET TO IEEE INFINITY, ADD 1 TO OVERFLOW COUNTER -C - ISTAT = ISTAT + 1 - B(I) = IOR(INFIN,ISIGN) - GO TO 40 -C - 30 CONTINUE -C -C UNDERFLOW , SET TO ZERO -C - B(I) = 0 -C - 40 CONTINUE -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/r63w72.f b/src/fim/FIMsrc/w3/r63w72.f deleted file mode 100644 index 4d52ab9..0000000 --- a/src/fim/FIMsrc/w3/r63w72.f +++ /dev/null @@ -1,125 +0,0 @@ - SUBROUTINE R63W72(KPDS,KGDS,IPDS,IGDS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: R63W72 CONVERT W3FI63 PARMS TO W3FI72 PARMS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: DETERMINES THE INTEGER PDS AND GDS PARAMETERS -C FOR THE GRIB1 PACKING ROUTINE W3FI72 GIVEN THE PARAMETERS -C RETURNED FROM THE GRIB1 UNPACKING ROUTINE W3FI63. -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C 96-05-03 MARK IREDELL CORRECTED SOME LEVEL TYPES AND -C SOME DATA REPRESENTATION TYPES -C 97-02-14 MARK IREDELL ONLY ALTERED IPDS(26:27) FOR EXTENDED PDS -C 98-06-01 CHRIS CARUSO Y2K FIX FOR YEAR OF CENTURY -C 2005-05-06 DIANE STOKES RECOGNIZE LEVEL 236 -C -C USAGE: CALL R63W72(KPDS,KGDS,IPDS,IGDS) -C -C INPUT ARGUMENT LIST: -C KPDS - INTEGER (200) PDS PARAMETERS FROM W3FI63 -C KGDS - INTEGER (200) GDS PARAMETERS FROM W3FI63 -C -C OUTPUT ARGUMENT LIST: -C IPDS - INTEGER (200) PDS PARAMETERS FOR W3FI72 -C IGDS - INTEGER (200) GDS PARAMETERS FOR W3FI72 -C -C REMARKS: KGDS AND IGDS EXTEND BEYOND THEIR DIMENSIONS HERE -C IF PL PARAMETERS ARE PRESENT. -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - DIMENSION KPDS(200),KGDS(200),IPDS(200),IGDS(200) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C DETERMINE PRODUCT DEFINITION SECTION (PDS) PARAMETERS - IF(KPDS(23).NE.2) THEN - IPDS(1)=28 ! LENGTH OF PDS - ELSE - IPDS(1)=45 ! LENGTH OF PDS - ENDIF - IPDS(2)=KPDS(19) ! PARAMETER TABLE VERSION - IPDS(3)=KPDS(1) ! ORIGINATING CENTER - IPDS(4)=KPDS(2) ! GENERATING MODEL - IPDS(5)=KPDS(3) ! GRID DEFINITION - IPDS(6)=MOD(KPDS(4)/128,2) ! GDS FLAG - IPDS(7)=MOD(KPDS(4)/64,2) ! BMS FLAG - IPDS(8)=KPDS(5) ! PARAMETER INDICATOR - IPDS(9)=KPDS(6) ! LEVEL TYPE - IF(KPDS(6).EQ.101.OR.KPDS(6).EQ.104.OR.KPDS(6).EQ.106.OR. - & KPDS(6).EQ.108.OR.KPDS(6).EQ.110.OR.KPDS(6).EQ.112.OR. - & KPDS(6).EQ.114.OR.KPDS(6).EQ.116.OR.KPDS(6).EQ.121.OR. - & KPDS(6).EQ.128.OR.KPDS(6).EQ.141.OR.KPDS(6).EQ.236) THEN - IPDS(10)=MOD(KPDS(7)/256,256) ! LEVEL VALUE 1 - IPDS(11)=MOD(KPDS(7),256) ! LEVEL VALUE 2 - ELSE - IPDS(10)=0 ! LEVEL VALUE 1 - IPDS(11)=KPDS(7) ! LEVEL VALUE 2 - ENDIF - IPDS(12)=KPDS(8) ! YEAR OF CENTURY - IPDS(13)=KPDS(9) ! MONTH - IPDS(14)=KPDS(10) ! DAY - IPDS(15)=KPDS(11) ! HOUR - IPDS(16)=KPDS(12) ! MINUTE - IPDS(17)=KPDS(13) ! FORECAST TIME UNIT - IPDS(18)=KPDS(14) ! TIME RANGE 1 - IPDS(19)=KPDS(15) ! TIME RANGE 2 - IPDS(20)=KPDS(16) ! TIME RANGE INDICATOR - IPDS(21)=KPDS(17) ! NUMBER IN AVERAGE - IPDS(22)=KPDS(20) ! NUMBER MISSING IN AVERAGE - IPDS(23)=KPDS(21) ! CENTURY - IPDS(24)=KPDS(23) ! SUBCENTER - IPDS(25)=KPDS(22) ! DECIMAL SCALING - IF(IPDS(1).GT.28) THEN - IPDS(26)=0 ! PDS BYTE 29 - IPDS(27)=0 ! PDS BYTE 30 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C DETERMINE GRID DEFINITION SECTION (GDS) PARAMETERS - IGDS(1)=KGDS(19) ! NUMBER OF VERTICAL COORDINATES - IGDS(2)=KGDS(20) ! VERTICAL COORDINATES - IGDS(3)=KGDS(1) ! DATA REPRESENTATION - IGDS(4)=KGDS(2) ! (UNIQUE TO REPRESENTATION) - IGDS(5)=KGDS(3) ! (UNIQUE TO REPRESENTATION) - IGDS(6)=KGDS(4) ! (UNIQUE TO REPRESENTATION) - IGDS(7)=KGDS(5) ! (UNIQUE TO REPRESENTATION) - IGDS(8)=KGDS(6) ! (UNIQUE TO REPRESENTATION) - IGDS(9)=KGDS(7) ! (UNIQUE TO REPRESENTATION) - IGDS(10)=KGDS(8) ! (UNIQUE TO REPRESENTATION) - IGDS(11)=KGDS(9) ! (UNIQUE TO REPRESENTATION) - IGDS(12)=KGDS(10) ! (UNIQUE TO REPRESENTATION) - IGDS(13)=KGDS(11) ! (UNIQUE TO REPRESENTATION) - IGDS(14)=KGDS(12) ! (UNIQUE TO REPRESENTATION) - IGDS(15)=KGDS(13) ! (UNIQUE TO REPRESENTATION) - IGDS(16)=KGDS(14) ! (UNIQUE TO REPRESENTATION) - IGDS(17)=KGDS(15) ! (UNIQUE TO REPRESENTATION) - IGDS(18)=KGDS(16) ! (UNIQUE TO REPRESENTATION) -C EXCEPTIONS FOR LATLON OR GAUSSIAN - IF(KGDS(1).EQ.0.OR.KGDS(1).EQ.4) THEN - IGDS(11)=KGDS(10) - IGDS(12)=KGDS(9) -C EXCEPTIONS FOR MERCATOR - ELSEIF(KGDS(1).EQ.1) THEN - IGDS(11)=KGDS(13) - IGDS(12)=KGDS(12) - IGDS(13)=KGDS(9) - IGDS(14)=KGDS(11) -C EXCEPTIONS FOR LAMBERT CONFORMAL - ELSEIF(KGDS(1).EQ.3) THEN - IGDS(15)=KGDS(12) - IGDS(16)=KGDS(13) - IGDS(17)=KGDS(14) - IGDS(18)=KGDS(15) - ENDIF -C EXTENSION FOR PL PARAMETERS - IF(KGDS(1).EQ.0.AND.KGDS(19).EQ.0.AND.KGDS(20).NE.255) THEN - DO J=1,KGDS(3) - IGDS(18+J)=KGDS(21+J) - ENDDO - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/sbyte.f b/src/fim/FIMsrc/w3/sbyte.f deleted file mode 100644 index d6b9181..0000000 --- a/src/fim/FIMsrc/w3/sbyte.f +++ /dev/null @@ -1,107 +0,0 @@ - SUBROUTINE SBYTE(IPACKD,IUNPKD,NOFF,NBITS) -C THIS PROGRAM WRITTEN BY..... -C DR. ROBERT C. GAMMILL, CONSULTANT -C NATIONAL CENTER FOR ATMOSPHERIC RESEARCH -C JULY 1972 -C -C THIS IS THE FORTRAN 32 bit VERSION OF SBYTE. -C Changes for SiliconGraphics IRIS-4D/25 -C SiliconGraphics 3.3 FORTRAN 77 -C MARCH 1991 RUSSELL E. JONES -C NATIONAL WEATHER SERVICE -C -C*********************************************************************** -C -C SUBROUTINE SBYTE (IPACKD,IUNPKD,NOFF,NBITS) -C -C PURPOSE GIVEN A BYTE, RIGHT-JUSTIFIED IN A WORD, TO -C PACK THE BYTE INTO A TARGET WORD OR ARRAY. -C BITS SURROUNDING THE BYTE IN THE TARGET -C AREA ARE UNCHANGED. -C -C USAGE CALL SBYTE (IPACKD,IUNPKD,NOFF,NBITS) -C -C ARGUMENTS -C ON INPUT IPACKD -C THE WORD OR ARRAY WHICH WILL CONTAIN THE -C PACKED BYTE. BYTE MAY CROSS WORD BOUNDARIES. -C -C IUNPKD -C THE WORD CONTAINING THE RIGHT-JUSTIFIED BYTE -C TO BE PACKED. -C -C NOFF -C THE NUMBER OF BITS TO SKIP, LEFT TO RIGHT, -C IN 'IPACKD' IN ORDER TO LOCATE WHERE THE -C BYTE IS TO BE PACKED. -C -C NBITS -C NUMBER OF BITS IN THE BYTE TO BE PACKED. -C MAXIMUM OF 64 BITS ON 64 BIT MACHINE, 32 -C BITS ON 32 BIT MACHINE. -C -C ON OUTPUT IPACKD -C WORD OR CONSECUTIVE WORDS CONTAINING THE -C REQUESTED BYTE. -C*********************************************************************** - - INTEGER IUNPKD - INTEGER IPACKD(*) - INTEGER MASKS(64) -C - SAVE -C - DATA IFIRST/1/ - IF(IFIRST.EQ.1) THEN - CALL W3FI01(LW) - NBITSW = 8 * LW - JSHIFT = -1 * NINT(ALOG(FLOAT(NBITSW)) / ALOG(2.0)) - MASKS(1) = 1 - DO I=2,NBITSW-1 - MASKS(I) = 2 * MASKS(I-1) + 1 - ENDDO - MASKS(NBITSW) = -1 - IFIRST = 0 - ENDIF -C -C NBITS MUST BE LESS THAN OR EQUAL TO NBITSW -C - ICON = NBITSW - NBITS - IF (ICON.LT.0) RETURN - MASK = MASKS(NBITS) -C -C INDEX TELLS HOW MANY WORDS INTO IOUT THE NEXT BYTE IS TO BE STORED. -C - INDEX = ISHFT(NOFF,JSHIFT) -C -C II TELLS HOW MANY BITS IN FROM THE LEFT SIDE OF THE WORD TO STORE IT. -C - II = MOD(NOFF,NBITSW) -C - J = IAND(MASK,IUNPKD) - MOVEL = ICON - II -C -C BYTE IS TO BE STORED IN MIDDLE OF WORD. SHIFT LEFT. -C - IF (MOVEL.GT.0) THEN - MSK = ISHFT(MASK,MOVEL) - IPACKD(INDEX+1) = IOR(IAND(NOT(MSK),IPACKD(INDEX+1)), - & ISHFT(J,MOVEL)) -C -C THE BYTE IS TO BE SPLIT ACROSS A WORD BREAK. -C - ELSE IF (MOVEL.LT.0) THEN - MSK = MASKS(NBITS+MOVEL) - IPACKD(INDEX+1) = IOR(IAND(NOT(MSK),IPACKD(INDEX+1)), - & ISHFT(J,MOVEL)) - ITEMP = IAND(MASKS(NBITSW+MOVEL),IPACKD(INDEX+2)) - IPACKD(INDEX+2) = IOR(ITEMP,ISHFT(J,NBITSW+MOVEL)) -C -C BYTE IS TO BE STORED RIGHT-ADJUSTED. -C - ELSE - IPACKD(INDEX+1) = IOR(IAND(NOT(MASK),IPACKD(INDEX+1)),J) - ENDIF -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/sbytes.f b/src/fim/FIMsrc/w3/sbytes.f deleted file mode 100644 index d5c501f..0000000 --- a/src/fim/FIMsrc/w3/sbytes.f +++ /dev/null @@ -1,138 +0,0 @@ - SUBROUTINE SBYTES(IPACKD,IUNPKD,NOFF,NBITS,ISKIP,ITER) -C THIS PROGRAM WRITTEN BY..... -C DR. ROBERT C. GAMMILL, CONSULTANT -C NATIONAL CENTER FOR ATMOSPHERIC RESEARCH -C JULY 1972 -C THIS IS THE FORTRAN VERSIONS OF SBYTES. -C -C Changes for SiliconGraphics IRIS-4D/25 -C SiliconGraphics 3.3 FORTRAN 77 -C March 1991 RUSSELL E. JONES -C NATIONAL WEATHER SERVICE -C -C*********************************************************************** -C -C SUBROUTINE SBYTE (IPACKD,IUNPKD,NOFF,NBITS,ISKIP,ITER) -C -C PURPOSE GIVEN A BYTE, RIGHT-JUSTIFIED IN A WORD, TO -C PACK THE BYTE INTO A TARGET WORD OR ARRAY. -C BITS SURROUNDING THE BYTE IN THE TARGET -C AREA ARE UNCHANGED. -C -C USAGE CALL SBYTE (IPACKD,IUNPKD,NOFF,NBITS) -C -C ARGUMENTS -C ON INPUT IPACKD -C THE WORD OR ARRAY WHICH WILL CONTAIN THE -C PACKED BYTE. BYTE MAY CROSS WORD BOUNDARIES. -C -C IUNPKD -C THE WORD CONTAINING THE RIGHT-JUSTIFIED BYTE -C TO BE PACKED. -C -C NOFF -C THE NUMBER OF BITS TO SKIP, LEFT TO RIGHT, -C IN 'IPACKD' IN ORDER TO LOCATE WHERE THE -C BYTE IS TO BE PACKED. -C -C NBITS -C NUMBER OF BITS IN THE BYTE TO BE PACKED. -C MAXIMUM OF 64 BITS ON 64 BIT MACHINE, 32 -C BITS ON 32 BIT MACHINE. -C -C ISKIP -C THE NUMBER OF BITS TO SKIP BETWEEN EACH BYTE -C IN 'IUNPKD' IN ORDER TO LOCATE THE NEXT BYTE -C TO BE PACKED. -C -C ITER -C THE NUMBER OF BYTES TO BE PACKED. -C -C ON OUTPUT IPACKD -C WORD OR CONSECUTIVE WORDS CONTAINING THE -C REQUESTED BYTE. -C -C*********************************************************************** - - INTEGER IUNPKD(*) - INTEGER IPACKD(*) - INTEGER MASKS(64) -C - SAVE -C - DATA IFIRST/1/ - IF(IFIRST.EQ.1) THEN - CALL W3FI01(LW) - NBITSW = 8 * LW - JSHIFT = -1 * NINT(ALOG(FLOAT(NBITSW)) / ALOG(2.0)) - MASKS(1) = 1 - DO I=2,NBITSW-1 - MASKS(I) = 2 * MASKS(I-1) + 1 - ENDDO - MASKS(NBITSW) = -1 - IFIRST = 0 - ENDIF -C -C NBITS MUST BE LESS THAN OR EQUAL TO NBITSW -C - ICON = NBITSW - NBITS - IF (ICON.LT.0) RETURN - MASK = MASKS(NBITS) -C -C INDEX TELLS HOW MANY WORDS INTO IOUT THE NEXT BYTE IS TO BE STORED. -C - INDEX = ISHFT(NOFF,JSHIFT) -C -C II TELLS HOW MANY BITS IN FROM THE LEFT SIDE OF THE WORD TO STORE IT. -C - II = MOD(NOFF,NBITSW) -C -C ISTEP IS THE DISTANCE IUNPKD BITS FROM ONE BYTE POSITION TO THE NEXT. -C - ISTEP = NBITS + ISKIP -C -C IWORDS TELLS HOW MANY WORDS TO SKIP FROM ONE BYTE TO THE NEXT. -C - IWORDS = ISTEP / NBITSW -C -C IBITS TELLS HOW MANY BITS TO SKIP AFTER SKIPPING IWORDS. -C - IBITS = MOD(ISTEP,NBITSW) -C - DO 10 I = 1,ITER - J = IAND(MASK,IUNPKD(I)) - MOVEL = ICON - II -C -C BYTE IS TO BE STORED IN MIDDLE OF WORD. SHIFT LEFT. -C - IF (MOVEL.GT.0) THEN - MSK = ISHFT(MASK,MOVEL) - IPACKD(INDEX+1) = IOR(IAND(NOT(MSK),IPACKD(INDEX+1)), - & ISHFT(J,MOVEL)) -C -C THE BYTE IS TO BE SPLIT ACROSS A WORD BREAK. -C - ELSE IF (MOVEL.LT.0) THEN - MSK = MASKS(NBITS+MOVEL) - IPACKD(INDEX+1) = IOR(IAND(NOT(MSK),IPACKD(INDEX+1)), - & ISHFT(J,MOVEL)) - ITEMP = IAND(MASKS(NBITSW+MOVEL),IPACKD(INDEX+2)) - IPACKD(INDEX+2) = IOR(ITEMP,ISHFT(J,NBITSW+MOVEL)) -C -C BYTE IS TO BE STORED RIGHT-ADJUSTED. -C - ELSE - IPACKD(INDEX+1) = IOR(IAND(NOT(MASK),IPACKD(INDEX+1)),J) - ENDIF -C - II = II + IBITS - INDEX = INDEX + IWORDS - IF (II.GE.NBITSW) THEN - II = II - NBITSW - INDEX = INDEX + 1 - ENDIF -C -10 CONTINUE -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/skgb.f b/src/fim/FIMsrc/w3/skgb.f deleted file mode 100644 index 080f2ab..0000000 --- a/src/fim/FIMsrc/w3/skgb.f +++ /dev/null @@ -1,77 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SKGB(LUGB,ISEEK,MSEEK,LSKIP,LGRIB) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SKGB SEARCH FOR NEXT GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 93-11-22 -C -C ABSTRACT: THIS SUBPROGRAM SEARCHES A FILE FOR THE NEXT GRIB 1 MESSAGE. -C A GRIB 1 MESSAGE IS IDENTIFIED BY ITS INDICATOR SECTION, I.E. -C AN 8-BYTE SEQUENCE WITH 'GRIB' IN BYTES 1-4 AND 1 IN BYTE 8. -C IF FOUND, THE LENGTH OF THE MESSAGE IS DECODED FROM BYTES 5-7. -C THE SEARCH IS DONE OVER A GIVEN SECTION OF THE FILE. -C THE SEARCH IS TERMINATED IF AN EOF OR I/O ERROR IS ENCOUNTERED. -C -C PROGRAM HISTORY LOG: -C 93-11-22 IREDELL -C 95-10-31 IREDELL ADD CALL TO BAREAD -C 97-03-14 IREDELL CHECK FOR '7777' -C 2001-06-05 IREDELL APPLY LINUX PORT BY EBISUZAKI -C -C USAGE: CALL SKGB(LUGB,ISEEK,MSEEK,LSKIP,LGRIB) -C INPUT ARGUMENTS: -C LUGB INTEGER LOGICAL UNIT OF INPUT GRIB FILE -C ISEEK INTEGER NUMBER OF BYTES TO SKIP BEFORE SEARCH -C MSEEK INTEGER MAXIMUM NUMBER OF BYTES TO SEARCH -C OUTPUT ARGUMENTS: -C LSKIP INTEGER NUMBER OF BYTES TO SKIP BEFORE MESSAGE -C LGRIB INTEGER NUMBER OF BYTES IN MESSAGE (0 IF NOT FOUND) -C -C SUBPROGRAMS CALLED: -C BAREAD BYTE-ADDRESSABLE READ -C GBYTEC GET INTEGER DATA FROM BYTES -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN -C -C$$$ - PARAMETER(LSEEK=128) - CHARACTER Z(LSEEK) - CHARACTER Z4(4) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - LGRIB=0 - KS=ISEEK - KN=MIN(LSEEK,MSEEK) - KZ=LSEEK -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C LOOP UNTIL GRIB MESSAGE IS FOUND - DOWHILE(LGRIB.EQ.0.AND.KN.GE.8.AND.KZ.EQ.LSEEK) -C READ PARTIAL SECTION - CALL BAREAD(LUGB,KS,KN,KZ,Z) - KM=KZ-8+1 - K=0 -C LOOK FOR 'GRIB...1' IN PARTIAL SECTION - DOWHILE(LGRIB.EQ.0.AND.K.LT.KM) - CALL GBYTEC(Z,I4,(K+0)*8,4*8) - CALL GBYTEC(Z,I1,(K+7)*8,1*8) - IF(I4.EQ.1196575042.AND.I1.EQ.1) THEN -C LOOK FOR '7777' AT END OF GRIB MESSAGE - CALL GBYTEC(Z,KG,(K+4)*8,3*8) - CALL BAREAD(LUGB,KS+K+KG-4,4,K4,Z4) - IF(K4.EQ.4) THEN - CALL GBYTE(Z4,I4,0,4*8) - IF(I4.EQ.926365495) THEN -C GRIB MESSAGE FOUND - LSKIP=KS+K - LGRIB=KG - ENDIF - ENDIF - ENDIF - K=K+1 - ENDDO - KS=KS+KM - KN=MIN(LSEEK,ISEEK+MSEEK-KS) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/src/fim/FIMsrc/w3/start.f b/src/fim/FIMsrc/w3/start.f deleted file mode 100644 index a7a490e..0000000 --- a/src/fim/FIMsrc/w3/start.f +++ /dev/null @@ -1,2 +0,0 @@ - subroutine start - end subroutine diff --git a/src/fim/FIMsrc/w3/summary.c.sav b/src/fim/FIMsrc/w3/summary.c.sav deleted file mode 100644 index 9fba8ce..0000000 --- a/src/fim/FIMsrc/w3/summary.c.sav +++ /dev/null @@ -1,465 +0,0 @@ -/*************************************************************** - -This code will make a system call to return various -useful parameters. When subroutine summary is called, a list -of system resource statistics is printed to stdout. - -Users need to place a call to start() at the beginning of the -section of code to be "measured" and a call to summary() at the end. - -Use as follows: - -call start() - do stuff -call summary() - -Jim Tuccillo August 1999 - -***************************************************************/ -#include -#include -#include -#include -#include -#include -#include -#include -#include - -/* #include "trace_mpif.h" */ - -FILE *fp; -int numtask, mypid; -int procid_0; -int profile, msglen; -int trace_flag; -double tcpu, twall, tbytes, f_bytes; -double tot_wall, final_wall, start_wall; -double cpu_comm, wall_comm; - -extern double rtc (); - -struct time_data { - double s_cpu; - double s_wall; - double f_cpu; - double f_wall; - double c_cpu; - double c_wall; - double c_bytes; - int c_calls; - int c_buckets[32]; - float c_sum[32]; - double b_cpu[32]; - double b_wall[32]; -}; - -struct time_data MPI_Allgather_data; -struct time_data MPI_Allgatherv_data; -struct time_data MPI_Allreduce_data; -struct time_data MPI_Alltoall_data; -struct time_data MPI_Alltoallv_data; -struct time_data MPI_Barrier_data; -struct time_data MPI_Bcast_data; -struct time_data MPI_Gather_data; -struct time_data MPI_Gatherv_data; -struct time_data MPI_Op_create_data; -struct time_data MPI_Op_free_data; -struct time_data MPI_Reduce_scatter_data; -struct time_data MPI_Reduce_data; -struct time_data MPI_Scan_data; -struct time_data MPI_Scatter_data; -struct time_data MPI_Scatterv_data; -struct time_data MPI_Attr_delete_data; -struct time_data MPI_Attr_get_data; -struct time_data MPI_Attr_put_data; -struct time_data MPI_Comm_compare_data; -struct time_data MPI_Comm_create_data; -struct time_data MPI_Comm_dup_data; -struct time_data MPI_Comm_free_data; -struct time_data MPI_Comm_group_data; -struct time_data MPI_Comm_rank_data; -struct time_data MPI_Comm_remote_group_data; -struct time_data MPI_Comm_remote_size_data; -struct time_data MPI_Comm_size_data; -struct time_data MPI_Comm_split_data; -struct time_data MPI_Comm_test_inter_data; -struct time_data MPI_Group_compare_data; -struct time_data MPI_Group_difference_data; -struct time_data MPI_Group_excl_data; -struct time_data MPI_Group_free_data; -struct time_data MPI_Group_incl_data; -struct time_data MPI_Group_intersection_data; -struct time_data MPI_Group_rank_data; -struct time_data MPI_Group_range_excl_data; -struct time_data MPI_Group_range_incl_data; -struct time_data MPI_Group_size_data; -struct time_data MPI_Group_translate_ranks_data; -struct time_data MPI_Group_union_data; -struct time_data MPI_Intercomm_create_data; -struct time_data MPI_Intercomm_merge_data; -struct time_data MPI_Keyval_create_data; -struct time_data MPI_Keyval_free_data; -struct time_data MPI_Abort_data; -struct time_data MPI_Error_class_data; -struct time_data MPI_Errhandler_create_data; -struct time_data MPI_Errhandler_free_data; -struct time_data MPI_Errhandler_get_data; -struct time_data MPI_Error_string_data; -struct time_data MPI_Errhandler_set_data; -struct time_data MPI_Get_processor_name_data; -struct time_data MPI_Initialized_data; -struct time_data MPI_Wtick_data; -struct time_data MPI_Wtime_data; -struct time_data MPI_Address_data; -struct time_data MPI_Bsend_data; -struct time_data MPI_Bsend_init_data; -struct time_data MPI_Buffer_attach_data; -struct time_data MPI_Buffer_detach_data; -struct time_data MPI_Cancel_data; -struct time_data MPI_Request_free_data; -struct time_data MPI_Recv_init_data; -struct time_data MPI_Send_init_data; -struct time_data MPI_Get_elements_data; -struct time_data MPI_Get_count_data; -struct time_data MPI_Ibsend_data; -struct time_data MPI_Iprobe_data; -struct time_data MPI_Irecv_data; -struct time_data MPI_Irsend_data; -struct time_data MPI_Isend_data; -struct time_data MPI_Issend_data; -struct time_data MPI_Pack_data; -struct time_data MPI_Pack_size_data; -struct time_data MPI_Probe_data; -struct time_data MPI_Recv_data; -struct time_data MPI_Rsend_data; -struct time_data MPI_Rsend_init_data; -struct time_data MPI_Send_data; -struct time_data MPI_Sendrecv_data; -struct time_data MPI_Sendrecv_replace_data; -struct time_data MPI_Ssend_data; -struct time_data MPI_Ssend_init_data; -struct time_data MPI_Start_data; -struct time_data MPI_Startall_data; -struct time_data MPI_Test_data; -struct time_data MPI_Testall_data; -struct time_data MPI_Testany_data; -struct time_data MPI_Test_cancelled_data; -struct time_data MPI_Testsome_data; -struct time_data MPI_Type_commit_data; -struct time_data MPI_Type_contiguous_data; -struct time_data MPI_Type_extent_data; -struct time_data MPI_Type_free_data; -struct time_data MPI_Type_hindexed_data; -struct time_data MPI_Type_hvector_data; -struct time_data MPI_Type_indexed_data; -struct time_data MPI_Type_lb_data; -struct time_data MPI_Type_size_data; -struct time_data MPI_Type_struct_data; -struct time_data MPI_Type_ub_data; -struct time_data MPI_Type_vector_data; -struct time_data MPI_Unpack_data; -struct time_data MPI_Wait_data; -struct time_data MPI_Waitall_data; -struct time_data MPI_Waitany_data; -struct time_data MPI_Waitsome_data; -struct time_data MPI_Cart_coords_data; -struct time_data MPI_Cart_create_data; -struct time_data MPI_Cart_get_data; -struct time_data MPI_Cart_map_data; -struct time_data MPI_Cart_rank_data; -struct time_data MPI_Cart_shift_data; -struct time_data MPI_Cart_sub_data; -struct time_data MPI_Cartdim_get_data; -struct time_data MPI_Dims_create_data; -struct time_data MPI_Graph_create_data; -struct time_data MPI_Graph_get_data; -struct time_data MPI_Graph_map_data; -struct time_data MPI_Graph_neighbors_data; -struct time_data MPI_Graph_neighbors_count_data; -struct time_data MPI_Graphdims_get_data; -struct time_data MPI_Topo_test_data; - - -int bucket (lng) - int lng; -{ - int i, j; - if (lng <= 0) {return(0);} - for (i=1, j=--lng; j>0; ++i) { - j = j>>1; - } - return (i); -} - - - -void elapse (timer) - double *timer; - -{ - -/* - - typedef struct { unsigned long tv_sec; - long tv_nsec; } timestruc; - - timestruc TimePointer; - int ret; - - ret = gettimer (TIMEOFDAY, &TimePointer); - if (ret != 0) { - printf ("getttimer FAILED!!!\n"); - printf ("ret = %d\n", ret); - return; - } - - - *timer = ((double) TimePointer.tv_sec) + (((double) TimePointer.tv_nsec) * ((double) 0.000000001)); - return; - -*/ - - *timer = rtc(); - -} - - -void cputim (usr, sys) - double *usr; - double *sys; - -{ - - double real; - typedef struct { int tms_utime; - int tms_stime; - int tms_cutime; - int tms_cstime; } tms; - - tms Time_buffer; - int ret; - - ret = times (&Time_buffer); - - real = ((double) ret) * 0.01; - - *usr = ((double) Time_buffer.tms_utime) * 0.01; - *sys = ((double) Time_buffer.tms_stime) * 0.01; - return; - -} - - -void start_timer (time) - struct time_data *time; - -{ - double user, sys; - double wall; - - cputim (&user, &sys); - elapse (&wall); - time->s_cpu = user + sys; - time->s_wall = wall; - - return; -} - -void end_timer (time) - struct time_data *time; - -{ - double user, sys; - double wall; - - cputim (&user, &sys); - elapse (&wall); - time->f_cpu = user + sys; - time->f_wall = wall; - time->c_cpu += time->f_cpu - time->s_cpu; - time->c_wall += time->f_wall - time->s_wall; - - return; -} - - - - -void resource () - -{ - - double usr, sys; - long data[14]; - - typedef struct { - int tv_sec; /* seconds */ - int tv_usec; /* microseconds */ - } timeval; - - double user, system; - int ret; - - struct rusage RU; - ret = getrusage (0, &RU); - - if (ret != 0) { - printf ("getrusage FAILED!!!\n"); - printf ("ret = %d\n", ret); - return; - } - - - user = ((double) RU.ru_utime.tv_sec) + (((double) RU.ru_utime.tv_usec) * ((double) 0.000001)); - system = ((double) RU.ru_stime.tv_sec) + (((double) RU.ru_stime.tv_usec) * ((double) 0.000001)); - - - printf("*****************RESOURCE STATISTICS*******************************\n\n"); - printf("The total amount of wall time = %f\n", tot_wall); - printf("The total amount of time in user mode = %f\n", user); - printf("The total amount of time in sys mode = %f\n", system); - printf("The maximum resident set size (KB) = %d\n", RU.ru_maxrss); - printf("Average shared memory use in text segment (KB*sec) = %d\n", RU.ru_ixrss); - printf("Average unshared memory use in data segment (KB*sec) = %d\n", RU.ru_idrss); - printf("Average unshared memory use in stack segment(KB*sec) = %d\n", RU.ru_isrss); - printf("Number of page faults without I/O activity = %d\n", RU.ru_minflt); - printf("Number of page faults with I/O activity = %d\n", RU.ru_majflt); - printf("Number of times process was swapped out = %d\n", RU.ru_nswap); - printf("Number of times filesystem performed INPUT = %d\n", RU.ru_inblock); - printf("Number of times filesystem performed OUTPUT = %d\n", RU.ru_oublock); - printf("Number of IPC messages sent = %d\n", RU.ru_msgsnd); - printf("Number of IPC messages received = %d\n", RU.ru_msgrcv); - printf("Number of Signals delivered = %d\n", RU.ru_nsignals); - printf("Number of Voluntary Context Switches = %d\n", RU.ru_nvcsw); - printf("Number of InVoluntary Context Switches = %d\n", RU.ru_nivcsw); - printf("*****************END OF RESOURCE STATISTICS*************************\n\n"); - - - usr = user; - sys = system; - data[0] = RU.ru_maxrss; - data[1] = RU.ru_ixrss; - data[2] = RU.ru_idrss; - data[3] = RU.ru_isrss; - data[4] = RU.ru_minflt; - data[5] = RU.ru_majflt; - data[6] = RU.ru_nswap; - data[7] = RU.ru_inblock; - data[8] = RU.ru_oublock; - data[9] = RU.ru_msgsnd; - data[10] = RU.ru_msgrcv; - data[11] = RU.ru_nsignals; - data[12] = RU.ru_nvcsw; - data[13] = RU.ru_nivcsw; - - return; - -} - - - - - -void print_timing (string, time) - char *string; - struct time_data *time; - -{ - - - if (time->c_calls > 0) { - fprintf (fp, "Information for %s: AVG. Length = %13.2f, CALLS = %d, WALL = %13.3f, CPU = %13.3f \n", - string, (double) (time->c_bytes) / (double) time->c_calls, time->c_calls, - time->c_wall, time->c_cpu); - } - - if (time->c_wall > 0.001 ) { - fprintf (fp, " %s: Total BYTES = %g, BW = %8.3f MBYTES/WALL SEC., BW = %8.3f MBYTES/CPU SEC.\n", - string, time->c_bytes, - ((double) time->c_bytes * 0.000001)/time->c_wall, - ((double) time->c_bytes * 0.000001)/time->c_cpu); - } - - twall += time->c_wall; - tcpu += time->c_cpu; - tbytes += time->c_bytes * 0.000001; - - /* Print the distribution of the message lengths */ - if (time->c_calls > 0) { - int i, j1, j2; - - j1 = 0; j2 = 0; - fprintf (fp, " AVG. Length # of Calls MB/WALL Sec. MB/CPU Sec. WALL Secs. CPU Secs. \n"); - if (time->c_buckets[0] >0) { - fprintf (fp, " %13.2f %13d %13.3f %13.3f %13.4f %13.4f \n", - time->c_sum[0]/(float)time->c_buckets[0], time->c_buckets[0], - ((double) time->c_sum[0] * 0.000001)/time->b_wall[0], - ((double) time->c_sum[0] * 0.000001)/time->b_cpu[0], - time->b_wall[0], time->b_cpu[0]); - } - time->c_buckets[3] = time->c_buckets[1] + time->c_buckets[2] + time->c_buckets[3]; - j1 = 1; j2 = 4; - for (i =3; i < 31; ++i) { - if (time->c_buckets[i] > 0) { - fprintf (fp, " %13.2f %13d %13.3f %13.3f %13.4f %13.4f \n", - time->c_sum[i]/(float)time->c_buckets[i], time->c_buckets[i], - ((double) time->c_sum[i] * 0.000001)/time->b_wall[i], - ((double) time->c_sum[i] * 0.000001)/time->b_cpu[i], - time->b_wall[i], time->b_cpu[i]); - } - j1 = j2 +1; - j2 = j2 + j2; - } - - fprintf (fp, "\n"); - - } - -} - -void summary( returnVal ) -int * returnVal; -{ - - double temp, temp1; - char trace_file[255], processor[8]; - -/* - MPI_Finalize - prototyping replacement for MPI_Finalize -*/ - - elapse(&final_wall); - tot_wall = final_wall - start_wall; - - - resource(); - - fclose (fp); - - - - - - - - - return; -} -void start() -{ - int stateid; - int Argc; - char **Argv; - - char *answer; - - - trace_flag=1; - - profile = 0; - elapse (&start_wall); - - return; -} - diff --git a/src/fim/FIMsrc/w3/summary.f b/src/fim/FIMsrc/w3/summary.f deleted file mode 100644 index 5d925c8..0000000 --- a/src/fim/FIMsrc/w3/summary.f +++ /dev/null @@ -1,2 +0,0 @@ - subroutine summary - end subroutine diff --git a/src/fim/FIMsrc/w3/w3ai00.f b/src/fim/FIMsrc/w3/w3ai00.f deleted file mode 100644 index 13ea0b3..0000000 --- a/src/fim/FIMsrc/w3/w3ai00.f +++ /dev/null @@ -1,505 +0,0 @@ - SUBROUTINE W3AI00(REAL8,PACK,LABEL) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3AI00 REAL ARRAY TO 16 BIT PACKED FORMAT -C AUTHOR: JONES,R.E. ORG: W342 DATE: 85-07-31 -C -C ABSTRACT: CONVERTS IEEE FLOATING POINT NUMBERS TO 16 BIT -C PACKED OFFICE NOTE 84 FORMAT. THE FLOATING POINT NUMBER ARE -C CONVERTED TO 16 BIT SIGNED SCALED INTEGERS. -C -C PROGRAM HISTORY LOG: -C 89-10-20 R.E.JONES CONVERT CYBER 205 VERSION OF W3AI00 TO CRAY -C 90-03-18 R.E.JONES CHANGE TO USE CRAY INTEGER*2 PACKER -C 90-10-11 R.E.JONES SPECIAL VERSION TO PACK GRIDS LARGER THAN -C 32743 WORDS. WILL DO OLD AND NEW VERSION. -C 91-02-16 R.E.JONES CHANGES SO EQUIVALENCE OF PACK AND REAL8 -C ARRAYS WILL WORK. -C 93-06-10 R.E.JONES CHANGES FOR ARRAY SIZE (512,512) 262144 WORDS. -C 98-03-10 B. VUONG REMOVE THE CDIR$ INTEGER=64 DIRECTIVE -C 98-11-18 Gilbert Changed to pack IEEE values for the IBM SP -C -C USAGE: CALL W3AI00 (REAL8, PACK, LABEL) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C REAL8 ARG LIST ARRAY OF CRAY FLOATING POINT NUMBERS -C LABEL ARG LIST SIX 8-BYTE INTEGER WORDS. -C MUST HAVE FIRST 8 OF 12 32 BIT -C WORD OFFICE NOTE 84 LABEL. WORD 6 MUST HAVE -C IN BITS 31-00 THE NUMBER OF REAL WORDS IN ARRAY -C REAL8 IF J IS GREATER THAN 32743. J IN BITS -C 15-0 OF THE 4TH ID WORD IS SET ZERO. -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C PACK ARG LIST PACKED OUTPUT ARRAY OF INTEGER WORDS OF -C SIZE 6 + (J+3)/4 , J = NO. POINTS IN LABEL -C (FROM WORD 4 BITS 15-00). -C LABEL WILL BE COPIED TO PACK WORDS 1-4. PACK -C WILL CONTAIN THE FOLLOWING IN WORDS 5-6 -C WORD 5 BITS 63-48 NUMBER OF BYTES IN WHOLE -C RECORD. WILL NOT BE -C CORRECT IF J > 32743. -C WORD 5 BITS 47-32 EXCLUSIVE-OR CHECKSUM BY 16 -C BIT WORDS OF WHOLE ARRAY PACK -C EXCLUDING CHECKSUM ITSELF. -C WORD 5 BITS 31-00 CENTER VALUE A = MEAN OF -C MAX AND MIN VALUES. -C CONVERTED TO IBM 32 -C FLOATING POINT NUMBER. -C WORD 6 BITS 63-48 ZERO. -C WORD 6 BITS 47-32 16 BIT SHIFT VALUE N. THE -C LEAST INTEGER SUCH THAT -C ABS(X-A)/2**N LT 1 FOR -C ALL X IN REAL8. LIMITED -C TO +-127. -C WORD 6 BITS 31-00 NUMBER OF WORDS IN REAL8 -C IF > 32743, RIGHT ADJUSTED -C IF <= 32743 SET ZERO. -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C IAND IOR BTEST SYSTEM -C -C REMARKS: PACK AND LABEL MAY BE EQUIVALENCED. N, THE NUMBER OF -C POINTS IN A GRID IS NOW IN 32 BIT ID WORD 12. -C -C ATTRIBUTES: -C LANGUAGE: IBM XL FORTRAN. -C MACHINE: IBM SP -C -C$$$ -C - REAL REAL8(*) - REAL XX(262144) -C - INTEGER(8) KK(262144) - INTEGER(8) LABEL(6) - INTEGER(8) PACK(*) - INTEGER(8) TPACK(6) - INTEGER(8) MASK16,MASK32,MASKN,IBYTES,IXOR - INTEGER(8) IB,N - REAL(8) B - REAL(4) X,A - real(4) rtemp(2) - integer(8) irtemp - equivalence (irtemp,rtemp(1)) -C - SAVE -C - EQUIVALENCE (B,IB) -C - DATA MASK16/X'000000000000FFFF'/ - DATA MASK32/X'00000000FFFFFFFF'/ - DATA MASKN /X'0000FFFF00000000'/ -C -C TRANSFER LABEL DATA TO WORDS 1-4. GET WORD COUNT, COMPUTE BYTES. -C - DO 10 I = 1,4 - TPACK(I) = LABEL(I) - 10 CONTINUE -C - TPACK(5) = 0 - TPACK(6) = 0 -C -C GET J, THE NUMBER OF WORDS IN A GRID, IF ZERO GET THE -C GET J FROM OFFICE NOTE 84 ID WORD 12. -C - J = IAND(MASK16,TPACK(4)) - IF (J.EQ.0) THEN - TPACK(6) = LABEL(6) - J = IAND(MASK32,TPACK(6)) - IF (J.EQ.0) THEN - PRINT *,' W3AI00: ERROR, NO. OF WORDS IN GRID = 0' - RETURN - ENDIF - IF (J.GT.262144) THEN - PRINT *,' W3AI00: ERROR, NO. OF WORDS IN GRID = ',J - PRINT *,' THERE IS A LIMIT OF 262144 WORDS.' - RETURN - ENDIF - ENDIF - M = J + 24 -C -C COMPUTE THE NUMBER OF 64 BIT INTEGER CRAY WORDS NEEDED FOR -C PACKED DATA. -C - IF (MOD(M,4).NE.0) THEN - IWORD = (M + 3) / 4 - ELSE - IWORD = M / 4 - ENDIF -C - IBYTES = M + M -C -C STORE NUMBER OF BYTES IN RECORD IN BITS 63-48 OF WORD 5. -C BITS ARE NUMBERED LEFT TO RIGHT 63 T0 00 -C - TPACK(5) = ISHFT(IBYTES,48_8) -C -C FIND MAX, MIN OF DATA, COMPUTE A AND N. -C - RMAX = REAL8(1) - RMIN = RMAX - DO 20 I = 2,J - RMAX = AMAX1(RMAX,REAL8(I)) - RMIN = AMIN1(RMIN,REAL8(I)) - 20 CONTINUE -C - A = 0.5 * (RMAX + RMIN) - X = RMAX - A - IF (RMAX.NE.RMIN) THEN -C CALL USDCTI(X,B,1,1,ISTAT) - CALL Q9E3I6(X,B,1,ISTAT) - IF (ISTAT.NE.0) PRINT *,' W3AI00-USDCTI OVERFLOW ERROR 1' - N = IAND(ISHFT(IB,-56_8),127_8) - N = 4 * (N - 64) - IF (BTEST(IB,55_8)) GO TO 30 - N = N - 1 - IF (BTEST(IB,54_8)) GO TO 30 - N = N - 1 - IF (BTEST(IB,53_8)) GO TO 30 - N = N - 1 - 30 CONTINUE - N = MAX(-127_8,MIN(127_8,N)) - ELSE -C -C FIELD IS ZERO OR A CONSTANT -C - N = 0 - ENDIF -C -C CONVERT AVERAGE VALUE FROM IEEE F.P. TO IBM370 32 BIT -C STORE IBM370 32 BIT F.P. AVG. VALUE IN BITS 31 - 00 OF WORD 5. -C -C CALL USSCTI(A,TPACK(5),5,1,ISTAT) - CALL Q9EI32(A,rtemp(2),1,ISTAT) - IF (ISTAT.NE.0) PRINT *,' W3AI00-USDCTI OVERFLOW ERROR 2' - TPACK(5)=IOR(TPACK(5),irtemp) -C -C STORE SCALING VALUE N IN BITS 47 - 32 OF WORD 6. -C - TPACK(6) = IOR(IAND(MASKN,ISHFT(N,32_8)),TPACK(6)) -C -C NOW PACK UP THE DATA, AND SCALE IT TO FIT AN INTEGER*2 WORD -C - TWON = 2.0 ** (15 - N) - DO 40 I = 1,J - XX(I) = (REAL8(I) - A) * TWON - KK(I) = XX(I) + SIGN(0.5,XX(I)) - IF (KK(I).GE.(-32767)) THEN - KK(I) = MIN(32767_8,KK(I)) - ELSE - KK(I) = -32767 - ENDIF - KK(I) = IAND(KK(I),MASK16) - 40 CONTINUE -C -C SHIFT THE INTEGER*2 DATA TO FIT 4 IN A 64 BIT WORD -C - LIM = (J / 4 ) * 4 - IREM = J - LIM - DO 50 I = 1,LIM,4 - KK(I) = ISHFT(KK(I), 48_8) - KK(I+1) = ISHFT(KK(I+1),32_8) - KK(I+2) = ISHFT(KK(I+2),16_8) - 50 CONTINUE -C -C SHIFT THE REMAINING 1, 2, OR 3 INTEGER*2 WORDS -C - IF (IREM.EQ.1) THEN - KK(LIM+1) = ISHFT(KK(LIM+1),48_8) - ENDIF -C - IF (IREM.EQ.2) THEN - KK(LIM+1) = ISHFT(KK(LIM+1),48_8) - KK(LIM+2) = ISHFT(KK(LIM+2),32_8) - ENDIF -C - IF (IREM.EQ.3) THEN - KK(LIM+1) = ISHFT(KK(LIM+1),48_8) - KK(LIM+2) = ISHFT(KK(LIM+2),32_8) - KK(LIM+3) = ISHFT(KK(LIM+3),16_8) - ENDIF -C -C PACK THE DATA BY USE OF IOR FOUR TO A WORD -C - II = 7 - DO 60 I = 1,LIM,4 - PACK(II) = IOR(IOR(IOR(KK(I),KK(I+1)),KK(I+2)),KK(I+3)) - II = II + 1 - 60 CONTINUE -C -C PACK THE LAST 1, 2, OR 3 INTEGER*2 WORDS -C - IF (IREM.EQ.1) THEN - PACK(IWORD) = KK(LIM+1) - ENDIF -C - IF (IREM.EQ.2) THEN - PACK(IWORD) = IOR(KK(I),KK(I+1)) - ENDIF -C - IF (IREM.EQ.3) THEN - PACK(IWORD) = IOR(IOR(KK(I),KK(I+1)),KK(I+2)) - ENDIF -C -C MOVE LABEL FROM TEMPORARY ARRAY TO PACK -C - DO 70 I = 1,6 - PACK(I) = TPACK(I) - 70 CONTINUE -C -C COMPUTE CHECKSUM AND STORE -C - IXOR = 0 -C -C COMPUTES A 64 BIT CHECKSUM 1ST -C - DO 80 I = 1,IWORD - IXOR = IEOR(IXOR,PACK(I)) - 80 CONTINUE -C -C COMPUTES A 32 BIT CHECKSUM 2ND -C - IXOR = IEOR(ISHFT(IXOR,-32_8),IAND(IXOR,MASK32)) -C -C COMPUTES A 16 BIT CHECKSUM 3RD -C - IXOR = IEOR(ISHFT(IXOR,-16_8),IAND(IXOR,MASK16)) -C -C STORE 16 BIT CHECK SUM OF RECORD IN BITS 47-32 OF WORD 5. -C - PACK(5) = IOR(ISHFT(IXOR,32_8),PACK(5)) -C - RETURN - END - - SUBROUTINE Q9EI32(A,B,N,ISTAT) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: Q9EI32 IEEE 32 BIT F.P. TO IBM370 F.P. -C PRGMMR: R.E.JONES ORG: W/NMC42 DATE: 90-06-04 -C -C ABSTRACT: CONVERT IEEE 32 BIT TASK 754 FLOATING POINT NUMBERS -C TO IBM370 32 BIT FLOATING POINT NUMBERS. -C -C PROGRAM HISTORY LOG: -C 90-06-04 R.E.JONES CONVERT TO SUN FORTRAN 1.3 -C 90-07-14 R.E.JONES CHANGE ISHFT TO LSHIFT OR LRSHFT -C 91-03-28 R.E.JONES CHANGE TO SiliconGraphics 3.3 FORTRAN 77 -C 92-07-20 R.E.JONES CHANGE TO IBM AIX XL FORTRAN -C 95-11-15 R.E.JONES ADD SAVE STATEMENT -C 98-11-18 Gilbert Specified 4-byte Integer values -C -C USAGE: CALL Q9EI32(A, B, N, ISTAT) -C INPUT ARGUMENT LIST: -C A - REAL*4 ARRAY OF IEEE 32 BIT FLOATING POINT NUMBERS -C N - NUMBER OF WORDS TO CONVERT TO IBM370 32 BIT F.P. -C -C OUTPUT ARGUMENT LIST: -C B - REAL*4 ARRAY OF IBM370 32 BIT FLOATING POINT NUMBERS -C ISTAT - 0 , ALL NUMBERS CONVERTED -C -1 , N IS LESS THAN ONE -C +K , K INFINITY OR NAN NUMBERS WERE FOUND -C -C REMARKS: SEE IEEE TASK 754 STANDARD FLOATING POINT ARITHMETIC FOR -C MORE INFORMATION ABOUT IEEE F.P. -C -C ATTRIBUTES: -C LANGUAGE: IBM AIX XL FORTRAN Compiler/6000 -C MACHINE: IBM RS6000 model 530 -C -C$$$ -C - INTEGER(4) A(*) - INTEGER(4) B(*) - INTEGER(4) SIGN,MASKFR,IBIT8,MASKSN,ITEMP,IBMEXP,IBX7 - INTEGER(4) ISIGN -C - SAVE -C - DATA MASKFR/Z'00FFFFFF'/ - DATA IBIT8 /Z'00800000'/ - DATA MASKSN/Z'7FFFFFFF'/ - DATA SIGN /Z'80000000'/ -C - IF (N.LT.1) THEN - ISTAT = -1 - RETURN - ENDIF -C - ISTAT = 0 -C - DO 30 I = 1,N -C -C SIGN BIT OFF -C - ISIGN = 0 - ITEMP = A(I) -C -C TEST SIGN BIT -C - IF (ITEMP.EQ.0) GO TO 20 -C - IF (ITEMP.LT.0) THEN -C -C SIGN BIT ON -C - ISIGN = SIGN -C -C TURN SIGN BIT OFF -C - ITEMP = IAND(ITEMP,MASKSN) -C - END IF -C - IBMEXP = ISHFT(ITEMP,-23_4) -C -C TEST FOR INDIFINITE OR NAN NUMBER -C - IF (IBMEXP.EQ.255) GO TO 10 -C -C TEST FOR ZERO EXPONENT AND FRACTION (UNDERFLOW) -C - IF (IBMEXP.EQ.0) GO TO 20 - IBMEXP = IBMEXP + 133 - IBX7 = IAND(3_4,IBMEXP) - IBMEXP = IEOR(IBMEXP,IBX7) - IBX7 = IEOR(3_4,IBX7) - ITEMP = IOR(ITEMP,IBIT8) - ITEMP = IOR(ISHFT(IBMEXP,22_4),ISHFT(IAND(ITEMP,MASKFR), - & -IBX7)) - B(I) = IOR(ITEMP,ISIGN) - GO TO 30 -C - 10 CONTINUE -C -C ADD 1 TO ISTAT FOR INDEFINITE OR NAN NUMBER -C - ISTAT = ISTAT + 1 -C - 20 CONTINUE - B(I) = 0 -C - 30 CONTINUE -C - RETURN - END - - SUBROUTINE Q9E3I6(A,B,N,ISTAT) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: Q9E3I6 IEEE 32 BIT F.P. TO IBM370 64 BIT F.P. -C PRGMMR: R.E.JONES ORG: W/NMC42 DATE: 92-08-02 -C -C ABSTRACT: CONVERT IEEE 32 BIT TASK 754 FLOATING POINT NUMBERS -C TO IBM370 64 BIT FLOATING POINT NUMBERS. -C -C PROGRAM HISTORY LOG: -C 92-08-02 R.E.JONES -C 95-11-15 R.E.JONES ADD SAVE STATEMENT -C -C USAGE: CALL Q9E3I6(A, B, N, ISTAT) -C INPUT ARGUMENT LIST: -C A - REAL*4 ARRAY OF IEEE 32 BIT FLOATING POINT NUMBERS -C N - NUMBER OF WORDS TO CONVERT TO IBM370 64 BIT F.P. -C -C OUTPUT ARGUMENT LIST: -C B - REAL*8 ARRAY OF IBM370 64 BIT FLOATING POINT NUMBERS -C ISTAT - 0 , ALL NUMBERS CONVERTED -C -1 , N IS LESS THAN ONE -C +K , K INFINITY OR NAN NUMBERS WERE FOUND -C -C REMARKS: SEE IEEE TASK 754 STANDARD FLOATING POINT ARITHMETIC FOR -C MORE INFORMATION ABOUT IEEE F.P. -C -C ATTRIBUTES: -C LANGUAGE: IBM AIX XL FORTRAN -C MACHINE: IBM RS/6000 model 530 -C -C$$$ -C - INTEGER(4) A(N) - INTEGER(4) B(2,N) - INTEGER(4) SIGN,MASKFR,IBIT8,MASKSN,ITEMP,IEEEXP - INTEGER(4) IBMEXP,IBX7,JTEMP,ISIGN -C - SAVE -C - DATA MASKFR/Z'00FFFFFF'/ - DATA IBIT8 /Z'00800000'/ - DATA MASKSN/Z'7FFFFFFF'/ - DATA SIGN /Z'80000000'/ -C - IF (N.LT.1) THEN - ISTAT = -1 - RETURN - ENDIF -C - ISTAT = 0 -C - DO 30 I = 1,N - ISIGN = 0 - ITEMP = A(I) -C -C TEST SIGN BIT -C - IF (ITEMP.EQ.0) GO TO 20 -C -C TEST FOR NEGATIVE NUMBERS -C - IF (ITEMP.LT.0) THEN -C -C SIGN BIT ON -C - ISIGN = SIGN -C -C TURN SIGN BIT OFF -C - ITEMP = IAND(ITEMP,MASKSN) -C - END IF -C -C GET IEEE EXPONENT -C - IEEEXP = ISHFT(ITEMP,-23_4) -C -C TEST FOR INDIFINITE OR NAN NUMBER -C - IF (IEEEXP.EQ.255) GO TO 10 -C -C TEST FOR ZERO EXPONENT AND FRACTION (UNDERFLOW) -C CONVERT IEEE EXPONENT (BASE 2) TO IBM EXPONENT -C (BASE 16) -C - IF (IEEEXP.EQ.0) GO TO 20 - IBMEXP = IEEEXP + 133 - IBX7 = IAND(3_4,IBMEXP) - IBMEXP = IEOR(IBMEXP,IBX7) - IBX7 = IEOR(3_4,IBX7) - ITEMP = IOR(ITEMP,IBIT8) - JTEMP = IOR(ISHFT(IBMEXP,22_4),ISHFT(IAND(ITEMP,MASKFR), - & -IBX7)) - B(1,I) = IOR(JTEMP,ISIGN) - B(2,I) = 0 - IF (IBX7.GT.0) B(2,I) = ISHFT(ITEMP,32_4-IBX7) - GO TO 30 -C - 10 CONTINUE -C ADD 1 TO ISTAT FOR INDEFINITE OR NAN NUMBER -C - ISTAT = ISTAT + 1 -C - 20 CONTINUE - B(1,I) = 0 - B(2,I) = 0 -C - 30 CONTINUE -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ai01.f b/src/fim/FIMsrc/w3/w3ai01.f deleted file mode 100644 index 8542394..0000000 --- a/src/fim/FIMsrc/w3/w3ai01.f +++ /dev/null @@ -1,120 +0,0 @@ - SUBROUTINE W3AI01(PACK,REAL8,LABEL) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3AI01 UNPACK RECORD INTO IEEE F.P. -C AUTHOR: JONES,R.E. ORG: W342 DATE: 89-10-17 -C -C ABSTRACT: UNPACKS A RECORD IN OFFICE NOTE 84 FORMAT AND CONVERT THE -C PACKED DATA TO IEEE REAL FLOATING POINT NUMBERS. THE -C OFFICE NOTE 84 DATA IS BIT FOR BIT THE SAME ON THE NAS-9050 AND -C THE CRAY. -C -C PROGRAM HISTORY LOG: -C 89-10-20 R.E.JONES -C 90-02-02 R.E.JONES CHANGE TO CRAY FUNCTION FOR INTEGER*2, F.P. -C 90-10-11 R.E.JONES SPECIAL VERSION OF W3AI01 TO UNPACK RECORDS -C PACKED BY BIG VERSION OF W3AI00. WILL DO -C OLD AND NEW VERSION. -C 91-03-19 R.E.JONES MAKE SPECIAL VERSION OF W3AI01 TO UNPACK -C BIG RECORDS THE OPERATIONAL VERSION. -C 93-06-10 R.E.JONES INCREACE ARRAY SIZE TO 262144 WORDS. -C 98-03-10 B. VUONG REMOVE THE CDIR$ INTEGER=64 DIRECTIVE -C 98-11-17 Gilbert Changed to unpack into IEEE reals for the IBM SP -C -C USAGE: CALL W3AI01 (PACK, REAL8, LABEL) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C PACK ARG LIST INTEGER ARRAY WITH DATA IN OFFICE NOTE 84 -C FORMAT TO BE UNPACKED. -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C REAL8 ARG LIST REAL ARRAY OF N WORDS. WHERE N IS GIVEN IN -C WORD 6 OF PACK. WORD 6 OF PACK MUST -C CONTAIN CENTER AND SCALING VALUES. -C LABEL ARG LIST SIX WORD INTEGER LABEL COPIED FROM PACK, 12 -C OFFICE NOTE 84 32 BIT ID'S THAT ARE STORED INTO -C six 64-bit words. -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C Q9IE32 W3LIB -C -C REMARKS: LABEL AND PACK MAY BE EQUIVALENCED. -C -C ATTRIBUTES: -C LANGUAGE: IBM XL FORTRAN -C MACHINE: IBM SP -C -C$$$ -C - REAL REAL8(*) -C - INTEGER(2) ITEMP(262144) - INTEGER(8) LABEL(6) - INTEGER(8) PACK(*) - INTEGER(8) MASK16 - INTEGER(8) MASK32 - integer(2) i2(4) - real(4) rtemp(2) - integer(8) ktemp,jtemp(65536) - equivalence (ktemp,rtemp(1),i2(1)) - equivalence (itemp(1),jtemp(1)) -C - SAVE -C - DATA MASK16/X'000000000000FFFF'/ - DATA MASK32/X'00000000FFFFFFFF'/ -C -C MOVE OFFICE NOTE 84 12 32 BIT ID'S INTO LABEL -C - DO 10 I = 1,6 - LABEL(I) = PACK(I) - 10 CONTINUE -C -C GET WORD COUNT, AVERAGE VALUE, SCALING FACTOR, J, A , N. -C - J = IAND(LABEL(4),MASK16) - IF (J.EQ.0) THEN - J = IAND(LABEL(6),MASK32) - IF (J.EQ.0) THEN - PRINT *,' W3AI01 ERROR, NUMBER OF WORDS IN GRID IS 0' - RETURN - ENDIF - IF (J.GT.262144) THEN - PRINT *,' W3AI01 ERROR, NUMBER OF WORDS IN GRID IS ',J - PRINT *,' THERE IS A LIMIT OF 262144' - RETURN - ENDIF - ENDIF -C -C CONVERT IBM 32 BIT MEAN VALUE TO IEEE F.P. NUMBER -C -C CALL USSCTC(LABEL(5),5,A,1) - ktemp=LABEL(5) - call q9ie32(rtemp(2),rtemp(1),1,istat) - A=rtemp(1) -C -C GET SCALING VALUE N, CAN BE NEGATIVE (INTEGER*2 TWO'S COMPL.) -C -C CALL USICTC(LABEL(6),3,N,1,2) - ktemp=LABEL(6) - n=i2(2) -C - TWON = 2.0 ** (N - 15) -C -C UNPACK, CONVERT TO REAL 64 BIT FLOATING POINT DATA -C -C CALL USICTC(PACK(7),1,ITEMP,J,2) - jtemp(1:65536)=pack(7:65542) -C - DO 20 I = 1,J - REAL8(I) = FLOAT(ITEMP(I)) * TWON + A - 20 CONTINUE -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ai08.f b/src/fim/FIMsrc/w3/w3ai08.f deleted file mode 100644 index f7b4de3..0000000 --- a/src/fim/FIMsrc/w3/w3ai08.f +++ /dev/null @@ -1,2848 +0,0 @@ - SUBROUTINE W3AI08(MSGA,KPDS,KGDS,KBMS,DATA,KPTR,KRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3AI08 UNPK GRIB FIELD TO GRIB GRID -C PRGMMR: BOSTELMAN ORG: NMC421 DATE:90-07-31 -C -C ABSTRACT: UNPACK A GRIB FIELD TO THE EXACT GRID SPECIFIED IN THE -C MESSAGE, ISOLATE THE BIT MAP AND MAKE THE VALUES OF THE PRODUCT -C DESCRIPTION SEC (PDS) AND THE GRID DESCRIPTION SEC (GDS) -C AVAILABLE IN RETURN ARRAYS. -C -C PROGRAM HISTORY LOG: -C 88-01-20 CAVANAUGH -C 90-05-11 CAVANAUGH TO ASSURE THAT ALL U.S. GRIDS IN THE -C GRIB DECODER COMPLY WITH SIZE CHANGES -C IN THE DECEMBER 1989 REVISIONS. -C 90-05-24 CAVANAUGH CORRECTS SEARCHING AN IMPROPER LOCATION -C FOR GRIB VERSION NUMBER IN GRIB MESSAGES. -C 90-07-15 BOSTELMAN MODIIFED SUB. AI084 SO THAT IT WILL TEST -C THE GRIB BDS BYTE SIZE TO DETERMINE WHAT -C ECMWF GRID ARRAY SIZE IS TO BE SPECIFIED. -C 90-09-14 R.E.JONES CHANGE'S FOR ANSI FORTRAN, AND PDS VERSION 1 -C 90-09-23 R.E.JONES CHANGE'S FOR CRAY CFT77 FORTRAN -C 90-12-05 R.E.JONES CHANGE'S FOR GRIB NOV. 21,1990 -C 02-10-15 VUONG REPLACED FUNCTION ICHAR WITH MOVA2I -C -C USAGE: CALL W3AI08(MSGA,KPDS,KGDS,KBMS,DATA,KPTR,KRET) -C INPUT ARGUMENT LIST: -C MSGA - GRIB FIELD - "GRIB" THRU "7777" CHAR*1 -C -C OUTPUT ARGUMENT LIST: -C DATA - ARRAY CONTAINING DATA ELEMENTS -C KPDS - ARRAY CONTAINING PDS ELEMENTS. (VERSION 0) -C (1) - ID OF CENTER -C (2) - MODEL IDENTIFICATION -C (3) - GRID IDENTIFICATION -C (4) - GDS/BMS FLAG -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING CENTURY -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - GRIB SPECIFICATION EDITION NUMBER -C KPDS - ARRAY CONTAINING PDS ELEMENTS. (VERSION 1) -C (1) - ID OF CENTER -C (2) - MODEL IDENTIFICATION -C (3) - GRID IDENTIFICATION -C (4) - GDS/BMS FLAG -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING CENTURY -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - TOTAL LENGTH OF GRIB MESSAGE (INCLUDING SECTION 0) -C KGDS - ARRAY CONTAINING GDS ELEMENTS. -C (1) - DATA REPRESENTATION TYPE -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUNDINAL DIRECTION OF INCREMENT -C (11) - SCANNING MODE FLAG -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESERVED -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LONGIT DIR INCREMENT -C (10) - LATIT DIR INCREMENT -C (11) - SCANNING MODE FLAG -C (12) - LATITUDE INTERSECTION -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESERVED -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C KBMS - BITMAP DESCRIBING LOCATION OF OUTPUT ELEMENTS. -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C (1) - UNUSED -C (2) - UNUSED -C (3) - LENGTH OF PDS -C (4) - LENGTH OF GDS -C (5) - LENGTH OF BMS -C (6) - LENGTH OF BDS -C (7) - VALUE OF CURRENT BYTE -C (8) - UNUSED -C (9) - GRIB START BYTE NR -C (10) - GRIB/GRID ELEMENT COUNT -C KRET - FLAG INDICATING QUALITY OF COMPLETION -C -C REMARKS: VALUES FOR RETURN FLAG (KRET) -C KRET = 0 - NORMAL RETURN, NO ERRORS -C = 1 - 'GRIB' NOT FOUND IN FIRST 100 CHARS -C = 2 - '7777' NOT IN CORRECT LOCATION -C = 3 - UNPACKED FIELD IS LARGER THAN 32768 -C = 4 - GDS/ GRID NOT ONE OF CURRENTLY ACCEPTED VALUES -C = 5 - GRID NOT CURRENTLY AVAIL FOR CENTER INDICATED -C = 8 - TEMP GDS INDICATED, BUT GDS FLAG IS OFF -C = 9 - GDS INDICATES SIZE MISMATCH WITH STD GRID -C =10 - INCORRECT CENTER INDICATOR -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C 4 AUG 1988 -C W3AI08 -C -C -C GRIB UNPACKING ROUTINE -C -C -C THIS ROUTINE WILL UNPACK A 'GRIB' FIELD TO THE EXACT GRID -C TYPE SPECIFIED IN THE MESSAGE, RETURN A BIT MAP AND MAKE THE -C VALUES OF THE PRODUCT DEFINITION SEC (PDS) AND THE GRID -C DESCRIPTION SEC (GDS) AVAILABLE IN RETURN ARRAYS. -C SEE "GRIB - THE WMO FORMAT FOR THE STORAGE OF WEATHER PRODUCT -C INFORMATION AND THE EXCHANGE OF WEATHER PRODUCT MESSAGES IN -C GRIDDED BINARY FORM" DATED JULY 1, 1988 BY JOHN D. STACKPOLE -C DOC, NOAA, NWS, NATIONAL METEOROLOGICAL CENTER. -C -C THE CALL TO THE GRIB UNPACKING ROUTINE IS AS FOLLOWS: -C -C CALL W3AI08(MSGA,KPDS,KGDS,LBMS,DATA,KPTR,KRET) -C -C INPUT: -C -C MSGA = CONTAINS THE GRIB MESSAGE TO BE UNPACKED. CHARACTERS -C "GRIB" MAY BEGIN ANYWHERE WITHIN FIRST 100 BYTES. -C -C OUTPUT: -C -C KPDS(100) INTEGER -C ARRAY TO CONTAIN THE ELEMENTS OF THE PRODUCT -C DEFINITION SEC . -C (VERSION 0) -C KPDS(1) - ID OF CENTER -C KPDS(2) - MODEL IDENTIFICATION (SEE "GRIB" TABLE 1) -C KPDS(3) - GRID IDENTIFICATION (SEE "GRIB" TABLE 2) -C KPDS(4) - GDS/BMS FLAG -C BIT DEFINITION -C 25 0 - GDS OMITTED -C 1 - GDS INCLUDED -C 26 0 - BMS OMITTED -C 1 - BMS INCLUDED -C NOTE:- LEFTMOST BIT = 1, -C RIGHTMOST BIT = 32 -C KPDS(5) - INDICATOR OF PARAMETER (SEE "GRIB" TABLE 5) -C KPDS(6) - TYPE OF LEVEL (SEE "GRIB" TABLES 6 & 7) -C KPDS(7) - HEIGHT,PRESSURE,ETC OF LEVEL -C KPDS(8) - YEAR OF CENTURY -C KPDS(9) - MONTH OF YEAR -C KPDS(10) - DAY OF MONTH -C KPDS(11) - HOUR OF DAY -C KPDS(12) - MINUTE OF HOUR -C KPDS(13) - INDICATOR OF FORECAST TIME UNIT (SEE "GRIB" -C TABLE 8) -C KPDS(14) - TIME 1 (SEE "GRIB" TABLE 8A) -C KPDS(15) - TIME 2 (SEE "GRIB" TABLE 8A) -C KPDS(16) - TIME RANGE INDICATOR (SEE "GRIB" TABLE 8A) -C KPDS(17) - NUMBER INCLUDED IN AVERAGE -C KPDS(18) - VERSION NR OF GRIB SPECIFICATION -C -C (VERSION 1) -C KPDS(1) - ID OF CENTER -C KPDS(2) - MODEL IDENTIFICATION (SEE "GRIB" TABLE 1) -C KPDS(3) - GRID IDENTIFICATION (SEE "GRIB" TABLE 2) -C KPDS(4) - GDS/BMS FLAG -C BIT DEFINITION -C 25 0 - GDS OMITTED -C 1 - GDS INCLUDED -C 26 0 - BMS OMITTED -C 1 - BMS INCLUDED -C NOTE:- LEFTMOST BIT = 1, -C RIGHTMOST BIT = 32 -C KPDS(5) - INDICATOR OF PARAMETER (SEE "GRIB" TABLE 5) -C KPDS(6) - TYPE OF LEVEL (SEE "GRIB" TABLES 6 & 7) -C KPDS(7) - HEIGHT,PRESSURE,ETC OF LEVEL -C KPDS(8) - YEAR INCLUDING CENTURY -C KPDS(9) - MONTH OF YEAR -C KPDS(10) - DAY OF MONTH -C KPDS(11) - HOUR OF DAY -C KPDS(12) - MINUTE OF HOUR -C KPDS(13) - INDICATOR OF FORECAST TIME UNIT (SEE "GRIB" -C TABLE 8) -C KPDS(14) - TIME 1 (SEE "GRIB" TABLE 8A) -C KPDS(15) - TIME 2 (SEE "GRIB" TABLE 8A) -C KPDS(16) - TIME RANGE INDICATOR (SEE "GRIB" TABLE 8A) -C KPDS(17) - NUMBER INCLUDED IN AVERAGE -C KPDS(18) - VERSION NR OF GRIB SPECIFICATION -C KPDS(19) - VERSION NR OF PARAMETER TABLE -C KPDS(20) - TOTAL LENGTH 0F GRIB MESSAGE -C (INCLUDING SECTION 0) -C KGDS(13) INTEGER -C ARRAY CONTAINING GDS ELEMENTS. -C -C KGDS(1) - DATA REPRESENTATION TYPE -C -C LATITUDE/LONGITUDE GRIDS (SEE "GRIB" TABLE 10) -C KGDS(2) - N(I) NUMBER OF POINTS ON LATITUDE -C CIRCLE -C KGDS(3) - N(J) NUMBER OF POINTS ON LONGITUDE -C CIRCLE -C KGDS(4) - LA(1) LATITUDE OF ORIGIN -C KGDS(5) - LO(1) LONGITUDE OF ORIGIN -C KGDS(6) - RESOLUTION FLAG -C BIT MEANING -C 25 0 - DIRECTION INCREMENTS NOT -C GIVEN -C 1 - DIRECTION INCREMENTS GIVEN -C KGDS(7) - LA(2) LATITUDE OF EXTREME POINT -C KGDS(8) - LO(2) LONGITUDE OF EXTREME POINT -C KGDS(9) - DI LONGITUDINAL DIRECTION INCREMENT -C KGDS(10) - REGULAR LAT/LON GRID -C DJ - LATITUDINAL DIRECTION -C INCREMENT -C GAUSSIAN GRID -C N - NUMBER OF LATITUDE CIRCLES -C BETWEEN A POLE AND THE EQUATOR -C KGDS(11) - SCANNING MODE FLAG -C BIT MEANING -C 25 0 - POINTS ALONG A LATITUDE -C SCAN FROM WEST TO EAST -C 1 - POINTS ALONG A LATITUDE -C SCAN FROM EAST TO WEST -C 26 0 - POINTS ALONG A MERIDIAN -C SCAN FROM NORTH TO SOUTH -C 1 - POINTS ALONG A MERIDIAN -C SCAN FROM SOUTH TO NORTH -C 27 0 - POINTS SCAN FIRST ALONG -C CIRCLES OF LATITUDE, THEN -C ALONG MERIDIANS -C (FORTRAN: (I,J)) -C 1 - POINTS SCAN FIRST ALONG -C MERIDIANS THEN ALONG -C CIRCLES OF LATITUDE -C (FORTRAN: (J,I)) -C -C POLAR STEREOGRAPHIC GRIDS (SEE GRIB TABLE 12) -C KGDS(2) - N(I) NR POINTS ALONG LAT CIRCLE -C KGDS(3) - N(J) NR POINTS ALONG LON CIRCLE -C KGDS(4) - LA(1) LATITUDE OF ORIGIN -C KGDS(5) - LO(1) LONGITUDE OF ORIGIN -C KGDS(6) - RESERVED -C KGDS(7) - LOV GRID ORIENTATION -C KGDS(8) - DX - X DIRECTION INCREMENT -C KGDS(9) - DY - Y DIRECTION INCREMENT -C KGDS(10) - PROJECTION CENTER FLAG -C KGDS(11) - SCANNING MODE -C -C SPHERICAL HARMONIC COEFFICIENTS (SEE "GRIB" TABLE 14) -C KGDS(2) - J PENTAGONAL RESOLUTION PARAMETER -C KGDS(3) - K PENTAGONAL RESOLUTION PARAMETER -C KGDS(4) - M PENTAGONAL RESOLUTION PARAMETER -C KGDS(5) - REPRESENTATION TYPE -C KGDS(6) - COEFFICIENT STORAGE MODE -C -C MERCATOR GRIDS -C KGDS(2) - N(I) NR POINTS ON LATITUDE CIRCLE -C KGDS(3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C KGDS(4) - LA(1) LATITUDE OF ORIGIN -C KGDS(5) - LO(1) LONGITUDE OF ORIGIN -C KGDS(6) - RESOLUTION FLAG -C KGDS(7) - LA(2) LATITUDE OF LAST GRID POINT -C KGDS(8) - LO(2) LONGITUDE OF LAST GRID POINT -C KGDS(9) - LONGIT DIR INCREMENT -C KGDS(10) - LATIT DIR INCREMENT -C KGDS(11) - SCANNING MODE FLAG -C KGDS(12) - LATITUDE INTERSECTION -C LAMBERT CONFORMAL GRIDS -C KGDS(2) - NX NR POINTS ALONG X-AXIS -C KGDS(3) - NY NR POINTS ALONG Y-AXIS -C KGDS(4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C KGDS(5) - LO1 LON OF ORIGIN (LOWER LEFT) -C KGDS(6) - RESERVED -C KGDS(7) - LOV - ORIENTATION OF GRID -C KGDS(8) - DX - X-DIR INCREMENT -C KGDS(9) - DY - Y-DIR INCREMENT -C KGDS(10) - PROJECTION CENTER FLAG -C KGDS(11) - SCANNING MODE FLAG -C KGDS(12) - LATIN 1 - FIRST LAT FROM POLE OF -C SECANT CONE INTERSECTION -C KGDS(13) - LATIN 2 - SECOND LAT FROM POLE OF -C SECANT CONE INTERSECTION -C -C LBMS(32768) LOGICAL -C ARRAY TO CONTAIN THE BIT MAP DESCRIBING THE -C PLACEMENT OF DATA IN THE OUTPUT ARRAY. IF A -C BIT MAP IS NOT INCLUDED IN THE SOURCE MESSAGE, -C ONE WILL BE GENERATED AUTOMATICALLY BY THE -C UNPACKING ROUTINE. -C -C -C DATA(32768) REAL -C THIS ARRAY WILL CONTAIN THE UNPACKED DATA POINTS. -C -C NOTE:- 32768 IS MAXIMUN FIELD SIZE ALLOWABLE -C -C KPTR(10) INTEGER -C ARRAY CONTAINING STORAGE FOR THE FOLLOWING -C PARAMETERS. -C -C (1) - UNUSED -C (2) - UNUSED -C (3) - LENGTH OF PDS (IN BYTES) -C (4) - LENGTH OF GDS (IN BYTES) -C (5) - LENGTH OF BMS (IN BYTES) -C (6) - LENGTH OF BDS (IN BYTES) -C (7) - USED BY UNPACKING ROUTINE -C (8) - NUMBER OF DATA POINTS FOR GRID -C (9) - "GRIB" CHARACTERS START IN BYTE NUMBER -C (10) - USED BY UNPACKING ROUTINE -C -C -C KRET INTEGER -C THIS VARIABLE WILL CONTAIN THE RETURN INDICATOR. -C -C 0 - NO ERRORS DETECTED. -C -C 1 - 'GRIB' NOT FOUND IN FIRST 100 -C CHARACTERS. -C -C 2 - '7777' NOT FOUND, EITHER MISSING OR -C TOTAL OF SEC COUNTS OF INDIVIDUAL -C SEC'S IS INCORRECT. -C -C 3 - UNPACKED FIELD IS LARGER THAN 32768. -C -C 4 - IN GDS, DATA REPRESENTATION TYPE -C NOT ONE OF THE CURRENTLY ACCEPTABLE -C VALUES. SEE "GRIB" TABLE 9. VALUE -C OF INCORRECT TYPE RETURNED IN KGDS(1). -C -C 5 - GRID INDICATED IN KPDS(3) IS NOT -C AVAILABLE FOR THE CENTER INDICATED IN -C KPDS(1) AND NO GDS SENT. -C -C 7 - VERSION INDICATED IN KPDS(18) HAS NOT -C YET BEEN INCLUDED IN THE DECODER. -C -C 8 - GRID IDENTIFICATION = 255 (NOT STANDARD -C GRID) BUT FLAG INDICATING PRESENCE OF -C GDS IS TURNED OFF. NO METHOD OF -C GENERATING PROPER GRID. -C -C 9 - PRODUCT OF KGDS(2) AND KGDS(3) DOES NOT -C MATCH STANDARD NUMBER OF POINTS FOR THIS -C GRID (FOR OTHER THAN SPECTRALS). THIS -C WILL OCCUR ONLY IF THE GRID. -C IDENTIFICATION, KPDS(3), AND A -C TRANSMITTED GDS ARE INCONSISTENT. -C -C 10 - CENTER INDICATOR WAS NOT ONE INDICATED -C IN "GRIB" TABLE 1. PLEASE CONTACT AD -C PRODUCTION MANAGEMENT BRANCH (W/NMC42) -C IF THIS ERROR IS ENCOUNTERED. -C -C -C -C LIST OF TEXT MESSAGES FROM CODE -C -C -C W3AI08/AI082 -C -C 'HAVE ENCOUNTERED A NEW GRID FOR NMC, PLEASE NOTIFY -C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH -C (W/NMC42)' -C -C 'HAVE ENCOUNTERED A NEW GRID FOR ECMWF, PLEASE NOTIFY -C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH -C (W/NMC42)' -C -C 'HAVE ENCOUNTERED A NEW GRID FOR U.K. METEOROLOGICAL -C OFFICE, BRACKNELL. PLEASE NOTIFY AUTOMATION DIVISION, -C PRODUCTION MANAGEMENT BRANCH (W/NMC42)' -C -C 'HAVE ENCOUNTERED A NEW GRID FOR FNOC, PLEASE NOTIFY -C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH -C (W/NMC42)' -C -C -C W3AI08/AI083 -C -C 'POLAR STEREO PROCESSING NOT AVAILABLE' * -C -C W3AI08/AI084 -C -C 'WARNING - BIT MAP MAY NOT BE ASSOCIATED WITH SPHERICAL -C COEFFICIENTS' -C -C -C W3AI08/AI087 -C -C 'NO CURRENT LISTING OF FNOC GRIDS' * -C -C -C * WILL BE AVAILABLE IN NEXT UPDATE -C *************************************************************** -C -C INCOMING MESSAGE HOLDER - CHARACTER*1 MSGA(*) -C BIT MAP - LOGICAL KBMS(*) -C -C ELEMENTS OF PRODUCT DESCRIPTION SEC (PDS) - INTEGER KPDS(*) -C ELEMENTS OF GRID DESCRIPTION SEC (PDS) - INTEGER KGDS(*) -C -C CONTAINER FOR GRIB GRID - REAL DATA(*) -C -C ARRAY OF POINTERS AND COUNTERS - INTEGER KPTR(*) -C -C ***************************************************************** -C 1.0 LOCATE BEGINNING OF 'GRIB' MESSAGE -C FIND 'GRIB' CHARACTERS -C 2.0 USE COUNTS IN EACH DESCRIPTION SEC TO DETERMINE -C IF '7777' IS IN PROPER PLACE. -C 3.0 PARSE PRODUCT DEFINITION SECTION. -C 4.0 PARSE GRID DESCRIPTION SEC (IF INCLUDED) -C 5.0 PARSE BIT MAP SEC (IF INCLUDED) -C 6.0 USING INFORMATION FROM PRODUCT DEFINITION, GRID -C DESCRIPTION, AND BIT MAP SECTIONS.. EXTRACT -C DATA AND PLACE INTO PROPER ARRAY. -C ******************************************************************* -C -C MAIN DRIVER -C -C ******************************************************************* - KPTR(10) = 0 -C SEE IF PROPER 'GRIB' KEY EXISTS, THEN -C USING SEC COUNTS, DETERMINE IF '7777' -C IS IN THE PROPER LOCATION -C - CALL AI081(MSGA,KPTR,KPDS,KRET) - IF (KRET.NE.0) GO TO 900 -C -C PARSE PARAMETERS FROM PRODUCT DESCRIPTION SECTION -C - IF (KPDS(18).EQ.0) THEN - CALL AI082(MSGA,KPTR,KPDS,KRET) - ELSE IF (KPDS(18).EQ.1) THEN - CALL AI082A(MSGA,KPTR,KPDS,KRET) - ELSE - PRINT *,'GRIB EDITION',KPDS(18),' NOT PROGRAMMED FOR' - KRET = 7 - GO TO 900 - END IF - IF (KRET.NE.0) GO TO 900 -C -C EXTRACT NEW GRID DESCRIPTION -C - CALL AI083(MSGA,KPTR,KPDS,KGDS,KRET) - IF (KRET.NE.0) GO TO 900 -C -C EXTRACT OR GENERATE BIT MAP -C - CALL AI084(MSGA,KPTR,KPDS,KGDS,KBMS,KRET) - IF (KRET.NE.0) GO TO 900 -C -C USING INFORMATION FROM PDS, BMS AND BIT DATA SEC , -C EXTRACT AND SAVE IN GRIB GRID, ALL DATA ENTRIES. -C - IF (KPDS(18).EQ.0) THEN - CALL AI085(MSGA,KPTR,KPDS,KBMS,DATA,KRET) - ELSE IF (KPDS(18).EQ.1) THEN - CALL AI085A(MSGA,KPTR,KPDS,KBMS,DATA,KRET) - ELSE - PRINT *,'AI085 NOT PROGRAMMED FOR VERSION NR',KPDS(18) - KRET = 7 - END IF -C - 900 RETURN - END - SUBROUTINE AI081(MSGA,KPTR,KPDS,KRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: AI081 FIND 'GRIB' CHARS & RESET POINTERS -C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 88-01-20 -C -C ABSTRACT: FIND 'GRIB; CHARACTERS AND SET POINTERS TO THE NEXT -C BYTE FOLLOWING 'GRIB'. IF THEY EXIST EXTRACT COUNTS FROM GDS AND -C BMS. EXTRACT COUNT FROM BDS. DETERMINE IF SUM OF COUNTS ACTUALLY -C PLACES TERMINATOR '7777' AT THE CORRECT LOCATION. -C -C PROGRAM HISTORY LOG: -C 88-01-20 CAVANAUGH -C 90-09-01 R.E.JONES CHANGE'S FOR ANSI FORTRAN -C 90-09-23 R.E.JONES CHANGE'S FOR CRAY CFT77 FORTRAN -C -C USAGE: CALL AI081(MSGA,KPTR,KPDS,KRET) -C INPUT ARGUMENT LIST: -C MSGA - GRIB FIELD - "GRIB" THRU "7777" -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C (1) - UNUSED -C (2) - UNUSED -C (3) - LENGTH OF PDS -C (4) - LENGTH OF GDS -C (5) - LENGTH OF BMS -C (6) - LENGTH OF BDS -C (7) - VALUE OF CURRENT BYTE -C (8) - UNUSED -C (9) - GRIB START BYTE -C (10) - GRIB/GRID ELEMENT COUNT -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KPDS - ARRAY CONTAINING PDS ELEMENTS. -C (1) - ID OF CENTER -C (2) - MODEL IDENTIFICATION -C (3) - GRID IDENTIFICATION -C (4) - GDS/BMS FLAG -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR OF CENTURY -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C KPTR - SEE INPUT LIST -C KRET - ERROR RETURN -C -C REMARKS: -C ERROR RETURNS -C KRET = 1 - NO 'GRIB' -C 2 - NO '7777' OR MISLOCATED (BY COUNTS) -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C -C INCOMING MESSAGE HOLDER - CHARACTER*1 MSGA(*) -C ARRAY OF POINTERS AND COUNTERS - INTEGER KPTR(*) -C PRODUCT DESCRIPTION SECTION DATA. - INTEGER KPDS(*) -C - INTEGER KRET -C -C DATA MASK40/Z00000040/ -C DATA MASK80/Z00000080/ -C - DATA MASK40/64/ - DATA MASK80/128/ -C -C ****************************************************************** - KRET = 0 -C ------------------- FIND 'GRIB' KEY - DO 100 I = 1, 105 - IF (MOVA2I(MSGA(I )).NE.71) GO TO 100 - IF (MOVA2I(MSGA(I+1)).NE.82) GO TO 100 - IF (MOVA2I(MSGA(I+2)).NE.73) GO TO 100 - IF (MOVA2I(MSGA(I+3)).NE.66) GO TO 100 - KPTR(9) = I - GO TO 200 - 100 CONTINUE - KRET = 1 - RETURN -C - 200 CONTINUE - IS = KPTR(9) -C ------------------- HAVE 'GRIB' KEY - KCNT = 0 -C --------------- EXTRACT COUNT FROM PDS OR GRIB - ISS = IS + 4 - DO 300 I = 0, 2 - KCNT = KCNT * 256 + MOVA2I(MSGA(I+ISS)) - 300 CONTINUE -C -C TEST FOR VERSION NUMBER OF PDS 0 OR 1 -C - IF (KCNT.EQ.24) THEN - KPTR(3) = KCNT - IGRIBL = 4 -C -C --------------- EDITION NR OF GRIB SPECIFICATION, VERSION 0 -C - KPDS(18) = MOVA2I(MSGA(ISS + 3)) - ELSE - IGRIBL = 8 - ISS = IS + IGRIBL -C --------------- EDITION NR OF GRIB SPECIFICATION, VERSION 1 - KPDS(18) = MOVA2I(MSGA(IS + 7)) -C -C --------------- PARAMETER TABLE VERSION NUMBER FOR INTERNATIONAL -C EXCHANGE (CURRENTLY NO. 1) -C - KPDS(19) = MOVA2I(MSGA(ISS + 3)) -C -C ---------------- SAVE TOTAL LENGTH OF MESSAGE (INCLUDING SECTION 0) -C - KPDS(20) = KCNT -C -C --------------- EXTRACT COUNT FROM PDS VERSION 1 -C - KCNT = 0 - DO 400 I = 0, 2 - KCNT = KCNT * 256 + MOVA2I(MSGA(I+ISS)) - 400 CONTINUE - KPTR(3) = KCNT - ENDIF -C -C --------------- GET GDS, BMS INDICATOR -C - KPDS(4) = MOVA2I(MSGA(ISS+7)) -C -C READY FOR NEXT SECTION -C - KPTR(4) = 0 - KPTR(5) = 0 - IF (IAND(KPDS(4),MASK80).EQ.0) GO TO 600 -C -C --------------- EXTRACT COUNT FROM GDS -C - ISS = KPTR(3) + IS + IGRIBL - KCNT = 0 - DO 500 I = 0, 2 - KCNT = KCNT * 256 + MOVA2I(MSGA(I+ISS)) - 500 CONTINUE - KPTR(4) = KCNT - 600 CONTINUE - IF (IAND(KPDS(4),MASK40).EQ.0) GO TO 800 -C -C ---------------- EXTRACT COUNT FROM BMS -C - ISS = KPTR(3) + KPTR(4) + IS + IGRIBL - KCNT = 0 - DO 700 I = 0, 2 - KCNT = KCNT * 256 + MOVA2I(MSGA(I+ISS)) - 700 CONTINUE - KPTR(5) = KCNT -C -C --------------- EXTRACT COUNT FROM BDS -C - 800 CONTINUE - KCNT = 0 - ISS = KPTR(3) + KPTR(4) + KPTR(5) + IS + IGRIBL - DO 900 I = 0, 2 - KCNT = KCNT * 256 + MOVA2I(MSGA(I+ISS)) - 900 CONTINUE - KPTR(6) = KCNT -C -C --------------- TEST FOR '7777' -C - ISS = KPTR(3) + KPTR(4) + KPTR(5) + KPTR(6) + IS + IGRIBL - KRET = 0 - DO 1000 I = 0, 3 - IF (MOVA2I(MSGA(I+ISS)).EQ.55) THEN - GO TO 1000 - ELSE - KRET = 2 - RETURN - END IF - 1000 CONTINUE - RETURN - END - SUBROUTINE AI082(MSGA,KPTR,KPDS,KRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: AI082 GATHER INFO FROM PGM DESC SECTION -C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 88-01-20 -C -C ABSTRACT: EXTRACT INFORMATION FROM THE PRODUCT DESCRIPTION -C SEC , AND GENERATE LABEL INFORMATION TO PERMIT STORAGE -C IN OFFICE NOTE 84 FORMAT. -C -C PROGRAM HISTORY LOG: -C 88-01-20 CAVANAUGH -C 90-09-01 R.E.JONES CHANGE'S FOR ANSI FORTRAN -C 90-09-23 R.E.JONES CHANGE'S FOR CRAY CFT77 FORTRAN -C 90-12-05 R.E.JONES CHANGE'S FOR GRIB NOV. 21,1990 -C -C USAGE: CALL AI082(MSGA,KPTR,KPDS,KRET) -C INPUT ARGUMENT LIST: -C MSGA - ARRAY CONTAINING GRIB MESSAGE -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C (1) - UNUSED -C (2) - UNUSED -C (3) - LENGTH OF PDS -C (4) - LENGTH OF GDS -C (5) - LENGTH OF BMS -C (6) - LENGTH OF PDS -C (7) - VALUE OF CURRENT BYTE -C (8) - UNUSED -C (9) - GRIB START BYTE NR -C (10) - GRIB/GRID ELEMENT COUNT -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KPDS - ARRAY CONTAINING PDS ELEMENTS. -C (1) - ID OF CENTER -C (2) - MODEL IDENTIFICATION -C (3) - GRID IDENTIFICATION -C (4) - GDS/BMS FLAG -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR OF CENTURY -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NUMBER OF GRIB SPEFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - TOTAL LENGTH OF GRIB MESSAGE (INCLUDING SECTION 0) -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C SEE INPUT LIST -C KRET - ERROR RETURN -C -C REMARKS: -C ERROR RETURN = 0 - NO ERRORS -C = 8 - TEMP GDS INDICATED, BUT NO GDS -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C -C INCOMING MESSAGE HOLDER - CHARACTER*1 MSGA(*) -C -C ARRAY OF POINTERS AND COUNTERS - INTEGER KPTR(*) -C PRODUCT DESCRIPTION SECTION ENTRIES - INTEGER KPDS(*) -C - INTEGER KRET -C -C -------------------- COLLECT PDS VALUES -C KPDS(1) - ID OF CENTER -C KPDS(2) - MODEL IDENTIFICATION -C KPDS(3) - GRID IDENTIFICATION -C KPDS(4) - GDS/BMS FLAG -C KPDS(5) - INDICATOR OF PARAMETER -C ----------- KPDS(6) - TYPE OF LEVEL - IS = KPTR(9) - ISS = IS + 8 - DO 200 I = 0, 5 - KPDS(I+1) = MOVA2I(MSGA(I+ISS)) - 200 CONTINUE - IF (KPDS(3).NE.255) GO TO 250 - IF (IAND(KPDS(4),128).NE.0) GO TO 250 - KRET = 8 - RETURN - 250 CONTINUE - ISS = IS + 14 - KPDS(7) = 0 - DO 300 I = 0, 1 - KPDS(7) = KPDS(7) * 256 + MOVA2I(MSGA(I+ISS)) - 300 CONTINUE -C ----------- KPDS(8) - YEAR OF CENTURY -C KPDS(9) - MONTH OF YEAR -C KPDS(10) - DAY OF MONTH -C KPDS(11) - HOUR OF DAY -C KPDS(12) - MINUTE OF HOUR -C KPDS(13) - INDICATOR OF FORECAST TIME UNIT -C KPDS(14) - TIME RANGE 1 -C KPDS(15) - TIME RANGE 2 -C ----------- KPDS(16) - TIME RANGE FLAG -C - ISS = IS + 16 - DO 400 I = 0, 7 - KPDS(I+8) = MOVA2I(MSGA(I+ISS)) - 400 CONTINUE -C ----------- KPDS(17) - NUMBER INCLUDED IN AVERAGE - ISS = IS + 25 - KPDS(17) = 0 - DO 500 I = 0, 1 - KPDS(17) = KPDS(17) * 256 + MOVA2I(MSGA(I+ISS)) - 500 CONTINUE -C -----------SKIP OVER SOURCE BYTE 24 -C ----------- TEST FOR NEW GRID - IF (IAND(KPDS(4),128).NE.0) THEN - IF (IAND(KPDS(4),64).NE.0) THEN - IF (KPDS(3).NE.255) THEN - IF (KPDS(1).EQ.7) THEN - IF (KPDS(3).GE.21.AND.KPDS(3).LE.26) THEN - ELSE IF (KPDS(3).EQ.50) THEN - ELSE IF (KPDS(3).GE.61.AND.KPDS(3).LE.64) THEN - ELSE IF (KPDS(3).EQ.70) THEN - ELSE IF (KPDS(3).GE.85.AND.KPDS(3).LE.86) THEN - ELSE IF (KPDS(3).GE.100.AND.KPDS(3).LE.103) THEN - ELSE IF (KPDS(3).GE.201.AND.KPDS(3).LE.214) THEN - ELSE - PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR', - * ' NMC' - PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION' - PRINT *,' PRODUCTION MANAGEMENT BRANCH' - PRINT *,' W/NMC42)' - END IF - ELSE IF (KPDS(1).EQ.98) THEN - IF (KPDS(3).GE.1.AND.KPDS(3).LE.16) THEN - ELSE - PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR', - * ' ECMWF' - PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION' - PRINT *,' PRODUCTION MANAGEMENT BRANCH' - PRINT *,' W/NMC42)' - END IF - ELSE IF (KPDS(1).EQ.74) THEN - IF (KPDS(3).GE.1.AND.KPDS(3).LE.12) THEN - ELSE IF (KPDS(3).GE.21.AND.KPDS(3).LE.26)THEN - ELSE IF (KPDS(3).GE.61.AND.KPDS(3).LE.64) THEN - ELSE IF (KPDS(3).EQ.70) THEN - ELSE - PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR', - * ' U.K. MET OFFICE, BRACKNELL' - PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION' - PRINT *,' PRODUCTION MANAGEMENT BRANCH' - PRINT *,' W/NMC42)' - END IF - ELSE IF (KPDS(1).EQ.58) THEN - IF (KPDS(3).GE.1.AND.KPDS(3).LE.12) THEN - ELSE - PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR', - * ' FNOC,' - PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION' - PRINT *,' PRODUCTION MANAGEMENT BRANCH' - PRINT *,' W/NMC42)' - END IF - END IF - END IF - END IF - END IF - RETURN - END - SUBROUTINE AI082A(MSGA,KPTR,KPDS,KRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: AI082A GATHER INFO FROM PGM DESC SECTION -C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 88-01-20 -C -C ABSTRACT: EXTRACT INFORMATION FROM THE PRODUCT DESCRIPTION SECTION -C (VERSION 1) -C -C PROGRAM HISTORY LOG: -C 89-11-20 CAVANAUGH -C 90-09-01 R.E.JONES CHANGE'S FOR ANSI FORTRAN -C 90-09-23 R.E.JONES CHANGE'S FOR CRAY CFT77 FORTRAN -C 90-12-05 R.E.JONES CHANGE'S FOR GRIB NOV. 21,1990 -C -C USAGE: CALL AI082A(MSGA,KPTR,KPDS,KRET) -C INPUT ARGUMENT LIST: -C MSGA - ARRAY CONTAINING GRIB MESSAGE -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C (1) - UNUSED -C (2) - UNUSED -C (3) - LENGTH OF PDS -C (4) - LENGTH OF GDS -C (5) - LENGTH OF BMS -C (6) - LENGTH OF PDS -C (7) - VALUE OF CURRENT BYTE -C (8) - UNUSED -C (9) - GRIB START BYTE NR -C (10) - GRIB/GRID ELEMENT COUNT -C -C OUTPUT ARGUMENT LIST: -C KPDS - ARRAY CONTAINING PDS ELEMENTS. -C (1) - ID OF CENTER -C (2) - MODEL IDENTIFICATION -C (3) - GRID IDENTIFICATION -C (4) - GDS/BMS FLAG -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR (INCLUDING CENTURY) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - TOTAL BYTE COUNT FOR SOURCE MESSAGE -C -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C SEE INPUT LIST -C KRET - ERROR RETURN -C -C REMARKS: -C SOURCE PDS STRUCTURE (VERSION 1) -C 1-3 - LENGTH OF PDS SECTION IN BYTES -C 4 - PARAMETER TABLE VERSION NO. FOR INTERNATIONAL -C EXCHANGE (CRRENTLY NO. 1) -C 5 - CENTER ID -C 6 - MODEL ID -C 7 - GRID ID -C 8 - FLAG FOR GDS/BMS -C 9 - INDICATOR FOR PARAMETER -C 10 - INDICATOR FOR TYPE OF LEVEL -C 11-12 - HEIGHT, PRESSURE OF LEVEL -C 13 - YEAR OF CENTURY -C 14 - MONTH -C 15 - DAY -C 16 - HOUR -C 17 - MINUTE -C 18 - FORECAST TIME UNIT -C 19 - P1 - PD OF TIME -C 20 - P2 - PD OF TIME -C 21 - TIME RANGE INDICATOR -C 22-23 - NUMBER IN AVERAGE -C 24 - NUMBER MISG FROM AVERAGES -C 25 - CENTURY -C 26 - INDICATOR OF PARAMETER IN LOCALLY RE-DEFINED -C PARAMETER TABLE. -C 27-28 - UNITS DECIMAL SCALE FACTOR (D) -C 29-40 - RESERVED: NEED NOT BE PRESENT -C 41-NN - NATIONAL USE -C . -C -C ERROR RETURN = 0 - NO ERRORS -C = 8 - TEMP GDS INDICATED, BUT NO GDS -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C -C INCOMING MESSAGE HOLDER - CHARACTER*1 MSGA(*) -C -C ARRAY OF POINTERS AND COUNTERS - INTEGER KPTR(*) -C PRODUCT DESCRIPTION SECTION ENTRIES - INTEGER KPDS(*) -C - INTEGER KRET -C - IS = KPTR(9) - IGRIBL = 8 -C -------------------- COLLECT PDS VALUES -C KPDS(1) - ID OF CENTER -C KPDS(2) - MODEL IDENTIFICATION -C KPDS(3) - GRID IDENTIFICATION -C KPDS(4) - GDS/BMS FLAG -C KPDS(5) - INDICATOR OF PARAMETER -C ----------- KPDS(6) - TYPE OF LEVEL - ISS = IS + IGRIBL + 4 - DO 200 I = 0, 5 - KPDS(I+1) = MOVA2I(MSGA(I+ISS)) - 200 CONTINUE - IF (KPDS(3).NE.255) GO TO 250 - IF (IAND(KPDS(4),128).NE.0) GO TO 250 - KRET = 8 - RETURN - 250 CONTINUE -C HEIGHT, PRESS OF LEVEL - ISS = IS + IGRIBL + 10 - KPDS(7) = 0 - DO 300 I = 0, 1 - KPDS(7) = KPDS(7) * 256 + MOVA2I(MSGA(I+ISS)) - 300 CONTINUE -C -C ----------- KPDS(8) - YEAR (INCLUDING CENTURY) -C - ISS = IS + IGRIBL + 12 - ICEN = IS + IGRIBL + 24 -C - KPDS(8) = MOVA2I(MSGA(ICEN)) * 100 + MOVA2I(MSGA(ISS)) -C -C KPDS(9) - MONTH OF YEAR -C KPDS(10) - DAY OF MONTH -C KPDS(11) - HOUR OF DAY -C KPDS(12) - MINUTE OF HOUR -C KPDS(13) - INDICATOR OF FORECAST TIME UNIT -C KPDS(14) - TIME RANGE 1 -C KPDS(15) - TIME RANGE 2 -C ----------- KPDS(16) - TIME RANGE FLAG -C - ISS = IS + IGRIBL + 13 - DO 400 I = 0, 7 - KPDS(I+9) = MOVA2I(MSGA(I+ISS)) - 400 CONTINUE -C ----------- KPDS(17) - NUMBER INCLUDED IN AVERAGE - ISS = IS + IGRIBL + 21 - KPDS(17) = 0 - DO 500 I = 0, 1 - KPDS(17) = KPDS(17) * 256 + MOVA2I(MSGA(I+ISS)) - 500 CONTINUE -C -----------SKIP OVER SOURCE BYTE 28 -C ----------- TEST FOR NEW GRID - IF (IAND(KPDS(4),128).NE.0) THEN - IF (IAND(KPDS(4),64).NE.0) THEN - IF (KPDS(3).NE.255) THEN - IF (KPDS(1).EQ.7) THEN - IF (KPDS(3).GE.21.AND.KPDS(3).LE.26)THEN - ELSE IF (KPDS(3).EQ.50) THEN - ELSE IF (KPDS(3).GE.61.AND.KPDS(3).LE.64) THEN - ELSE IF (KPDS(3).EQ.70) THEN - ELSE IF (KPDS(3).GE.85.AND.KPDS(3).LE.86) THEN - ELSE IF (KPDS(3).GE.100.AND.KPDS(3).LE.103) THEN - ELSE IF (KPDS(3).GE.201.AND.KPDS(3).LE.214) THEN - ELSE - PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR', - * ' NMC' - PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION' - PRINT *,' PRODUCTION MANAGEMENT BRANCH' - PRINT *,' W/NMC42)' - END IF - ELSE IF (KPDS(1).EQ.98) THEN - IF (KPDS(3).GE.1.AND.KPDS(3).LE.16) THEN - ELSE - PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR', - * ' ECMWF' - PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION' - PRINT *,' PRODUCTION MANAGEMENT BRANCH' - PRINT *,' W/NMC42)' - END IF - ELSE IF (KPDS(1).EQ.74) THEN - IF (KPDS(3).GE.1.AND.KPDS(3).LE.12) THEN - ELSE IF (KPDS(3).GE.21.AND.KPDS(3).LE.26)THEN - ELSE IF (KPDS(3).GE.61.AND.KPDS(3).LE.64) THEN - ELSE IF (KPDS(3).EQ.70) THEN - ELSE - PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR', - * ' U.K. MET OFFICE, BRACKNELL' - PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION' - PRINT *,' PRODUCTION MANAGEMENT BRANCH' - PRINT *,' W/NMC42)' - END IF - ELSE IF (KPDS(1).EQ.58) THEN - IF (KPDS(3).GE.1.AND.KPDS(3).LE.12) THEN - ELSE - PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR', - * ' FNOC,' - PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION' - PRINT *,' PRODUCTION MANAGEMENT BRANCH' - PRINT *,' W/NMC42)' - END IF - END IF - END IF - END IF - END IF - RETURN - END - SUBROUTINE AI083(MSGA,KPTR,KPDS,KGDS,KRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: AI083 EXTRACT INFO FROM GRIB-GDS -C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 88-01-20 -C -C ABSTRACT: EXTRACT INFORMATION ON UNLISTED GRID TO ALLOW -C CONVERSION TO OFFICE NOTE 84 FORMAT. -C -C PROGRAM HISTORY LOG: -C 88-01-20 CAVANAUGH -C 89-03-16 CAVANAUGH ADDED MERCATOR & LAMBERT CONFORMAL PROCESSING -C 89-07-12 CAVANAUGH CORRECTED CHANGE ENTERED 89-03-16 REORDERING -C PROCESSING FOR LAMBERT CONFORMAL AND MERCATOR -C GRIDS. -C 90-09-23 R.E.JONES CHANGE'S FOR CRAY CFT77 FORTRAN -C -C USAGE: CALL AI083(MSGA,KPTR,KPDS,KGDS,KRET) -C INPUT ARGUMENT LIST: -C MSGA - ARRAY CONTAINING GRIB MESSAGE -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C (1) - UNUSED -C (2) - UNUSED -C (3) - LENGTH OF PDS -C (4) - LENGTH OF GDS -C (5) - LENGTH OF BMS -C (6) - LENGTH OF BDS -C (7) - VALUE OF CURRENT BYTE -C (8) - UNUSED -C (9) - GRIB START BYTE NR -C (10) - GRIB/GRID ELEMENT COUNT -C KPDS - ARRAY CONTAINING PDS ELEMENTS. -C (1) - ID OF CENTER -C (2) - MODEL IDENTIFICATION -C (3) - GRID IDENTIFICATION -C (4) - GDS/BMS FLAG -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR OF CENTURY -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KGDS - ARRAY CONTAINING GDS ELEMENTS. -C (1) - DATA REPRESENTATION TYPE -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION OF INCREMENT -C (11) - SCANNING MODE FLAG -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESERVED -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LONGIT DIR INCREMENT -C (10) - LATIT DIR INCREMENT -C (11) - SCANNING MODE FLAG -C (12) - LATITUDE INTERSECTION -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESERVED -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C SEE INPUT LIST -C KRET - ERROR RETURN -C -C REMARKS: -C KRET = 0 -C = 4 - DATA REPRESENTATION TYPE NOT CURRENTLY ACCEPTABLE -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C ************************************************************ -C INCOMING MESSAGE HOLDER - CHARACTER*1 MSGA(*) -C -C ARRAY GDS ELEMENTS - INTEGER KGDS(*) -C ARRAY OF POINTERS AND COUNTERS - INTEGER KPTR(*) -C ARRAY OF PDS ELEMENTS - INTEGER KPDS(*) -C - INTEGER KRET -C -C DATA MSK80 /Z00000080/ -C - DATA MSK80 /128/ -C ******************************************************** -C IF FLAG IN PDS INDICATE THAT THERE IS NO GDS , -C RETURN IMMEDIATELY -C ************************************************************ - IF (IAND(KPDS(4),MSK80).EQ.0) GO TO 900 -C ------------------- BYTE 1-3 COUNT - IS = KPTR(9) - IF (KPDS(18).EQ.0) THEN - IGRIBL = 4 - ELSE - IGRIBL = 8 - ENDIF - ISS = IS + KPTR(3) + IGRIBL -C ------------------- BYTE 4 NUMBER OF UNUSED BITS AT END OF SEC -C ------------------- BYTE 5 RESERVED -C ------------------- BYTE 6 DATA REPRESENTATION TYPE - KGDS(1) = MOVA2I(MSGA(ISS+5)) -C ------------------- DIVERT TO PROCESS CORRECT TYPE - IF (KGDS(1).EQ.0) THEN - GO TO 1000 - ELSE IF (KGDS(1).EQ.1) THEN - GO TO 4000 - ELSE IF (KGDS(1).EQ.2.OR.KGDS(1).EQ.5) THEN - GO TO 2000 - ELSE IF (KGDS(1).EQ.3) THEN - GO TO 5000 - ELSE IF (KGDS(1).EQ.4) THEN - GO TO 1000 - ELSE IF (KGDS(1).EQ.50) THEN - GO TO 3000 - ELSE -C MARK AS GDS/ UNKNOWN DATA REPRESENTATION TYPE - KRET = 4 - GO TO 900 - END IF -C -C ------------------- LATITUDE/LONGITUDE GRIDS -C -C ------------------- BYTE 7-8 NR OF POINTS ALONG LATITUDE CIRCLE - 1000 KGDS(2) = 0 - DO 1005 I = 0, 1 - KGDS(2) = KGDS(2) * 256 + MOVA2I(MSGA(I+ISS+6)) - 1005 CONTINUE -C ------------------- BYTE 9-10 NR OF POINTS ALONG LONG MERIDIAN - KGDS(3) = 0 - DO 1010 I = 0, 1 - KGDS(3) = KGDS(3) * 256 + MOVA2I(MSGA(I+ISS+8)) - 1010 CONTINUE -C ------------------- BYTE 11-13 LATITUE OF ORIGIN - KGDS(4) = 0 - DO 1020 I = 0, 2 - KGDS(4) = KGDS(4) * 256 + MOVA2I(MSGA(I+ISS+10)) - 1020 CONTINUE - IF (IAND(KGDS(4),8388608).NE.0) THEN - KGDS(4) = IAND(KGDS(4),8388607) * (-1) - END IF -C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN - KGDS(5) = 0 - DO 1030 I = 0, 2 - KGDS(5) = KGDS(5) * 256 + MOVA2I(MSGA(I+ISS+13)) - 1030 CONTINUE - IF (IAND(KGDS(5),8388608).NE.0) THEN - KGDS(5) = - IAND(KGDS(5),8388607) - END IF -C ------------------- BYTE 17 RESOLUTION FLAG - KGDS(6) = MOVA2I(MSGA(ISS+16)) -C ------------------- BYTE 18-20 LATITUDE OF LAST GRID POINT - KGDS(7) = 0 - DO 1040 I = 0, 2 - KGDS(7) = KGDS(7) * 256 + MOVA2I(MSGA(I+ISS+17)) - 1040 CONTINUE - IF (IAND(KGDS(7),8388608).NE.0) THEN - KGDS(7) = - IAND(KGDS(7),8388607) - END IF -C ------------------- BYTE 21-23 LONGITUDE OF LAST GRID POINT - KGDS(8) = 0 - DO 1050 I = 0, 2 - KGDS(8) = KGDS(8) * 256 + MOVA2I(MSGA(I+ISS+20)) - 1050 CONTINUE - IF (IAND(KGDS(8),8388608).NE.0) THEN - KGDS(8) = - IAND(KGDS(8),8388607) - END IF -C ------------------- BYTE 24-25 LATITUDINAL DIR INCREMENT - KGDS(9) = 0 - DO 1060 I = 0, 1 - KGDS(9) = KGDS(9) * 256 + MOVA2I(MSGA(I+ISS+23)) - 1060 CONTINUE -C ------------------- BYTE 26-27 IF REGULAR LAT/LON GRID -C HAVE LONGIT DIR INCREMENT -C ELSE IF GAUSSIAN GRID -C HAVE NR OF LAT CIRCLES -C BETWEEN POLE AND EQUATOR - KGDS(10) = 0 - DO 1070 I = 0, 1 - KGDS(10) = KGDS(10) * 256 + MOVA2I(MSGA(I+ISS+25)) - 1070 CONTINUE -C ------------------- BYTE 28 SCANNING MODE FLAGS - KGDS(11) = MOVA2I(MSGA(ISS+27)) -C ------------------- BYTE 29-32 RESERVED -C ------------------- - GO TO 900 -C ------------------- -C ' POLAR STEREO PROCESSING ' -C -C ------------------- BYTE 7-8 NR OF POINTS ALONG X=AXIS - 2000 KGDS(2) = 0 - DO 2005 I = 0, 1 - KGDS(2) = KGDS(2) * 256 + MOVA2I(MSGA(I+ISS+6)) - 2005 CONTINUE -C ------------------- BYTE 9-10 NR OF POINTS ALONG Y-AXIS - KGDS(3) = 0 - DO 2010 I = 0, 1 - KGDS(3) = KGDS(3) * 256 + MOVA2I(MSGA(I+ISS+8)) - 2010 CONTINUE -C ------------------- BYTE 11-13 LATITUDE OF ORIGIN - KGDS(4) = 0 - DO 2020 I = 0, 2 - KGDS(4) = KGDS(4) * 256 + MOVA2I(MSGA(I+ISS+10)) - 2020 CONTINUE - IF (IAND(KGDS(4),8388608).NE.0) THEN - KGDS(4) = - IAND(KGDS(4),8388607) - END IF -C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN - KGDS(5) = 0 - DO 2030 I = 0, 2 - KGDS(5) = KGDS(5) * 256 + MOVA2I(MSGA(I+ISS+13)) - 2030 CONTINUE - IF (IAND(KGDS(5),8388608).NE.0) THEN - KGDS(5) = - IAND(KGDS(5),8388607) - END IF -C ------------------- BYTE 17 RESERVED - KGDS(6) = MOVA2I(MSGA(ISS+16)) -C ------------------- BYTE 18-20 LOV ORIENTATION OF THE GRID - KGDS(7) = 0 - DO 2040 I = 0, 2 - KGDS(7) = KGDS(7) * 256 + MOVA2I(MSGA(I+ISS+17)) - 2040 CONTINUE - IF (IAND(KGDS(7),8388608).NE.0) THEN - KGDS(7) = - IAND(KGDS(7),8388607) - END IF -C ------------------- BYTE 21-23 DX - THE X DIRECTION INCREMENT - KGDS(8) = 0 - DO 2050 I = 0, 2 - KGDS(8) = KGDS(8) * 256 + MOVA2I(MSGA(I+ISS+20)) - 2050 CONTINUE - IF (IAND(KGDS(8),8388608).NE.0) THEN - KGDS(8) = - IAND(KGDS(8),8388607) - END IF -C ------------------- BYTE 24-26 DY - THE Y DIRECTION INCREMENT - KGDS(9) = 0 - DO 2060 I = 0, 2 - KGDS(9) = KGDS(9) * 256 + MOVA2I(MSGA(I+ISS+23)) - 2060 CONTINUE - IF (IAND(KGDS(9),8388608).NE.0) THEN - KGDS(9) = - IAND(KGDS(9),8388607) - END IF -C ------------------- BYTE 27 PROJECTION CENTER FLAG - KGDS(10) = MOVA2I(MSGA(ISS+26)) -C ------------------- BYTE 28 SCANNING MODE - KGDS(11) = MOVA2I(MSGA(ISS+27)) -C ------------------- BYTE 29-32 RESERVED -C ------------------- - GO TO 900 -C -C ------------------- GRID DESCRIPTION FOR SPHERICAL HARMONIC COEFF. -C -C ------------------- BYTE 7-8 J PENTAGONAL RESOLUTION PARAMETER - 3000 KGDS(2) = 0 - DO 3010 I = 0, 1 - KGDS(2) = KGDS(2) * 256 + MOVA2I(MSGA(I+ISS+6)) - 3010 CONTINUE -C ------------------- BYTE 9-10 K PENTAGONAL RESOLUTION PARAMETER - KGDS(3) = 0 - DO 3020 I = 0, 1 - KGDS(3) = KGDS(3) * 256 + MOVA2I(MSGA(I+ISS+8)) - 3020 CONTINUE -C ------------------- BYTE 11-12 M PENTAGONAL RESOLUTION PARAMETER - KGDS(4) = 0 - DO 3030 I = 0, 1 - KGDS(4) = KGDS(4) * 256 + MOVA2I(MSGA(I+ISS+10)) - 3030 CONTINUE -C ------------------- BYTE 13 REPRESENTATION TYPE - KGDS(5) = MOVA2I(MSGA(ISS+12)) -C ------------------- BYTE 14 COEFFICIENT STORAGE MODE - KGDS(6) = MOVA2I(MSGA(ISS+13)) -C ------------------- EMPTY FIELDS - BYTES 15 - 32 - KRET = 0 - GO TO 900 -C ------------------- PROCESS MERCATOR GRIDS -C -C ------------------- BYTE 7-8 NR OF POINTS ALONG LATITUDE CIRCLE - 4000 KGDS(2) = 0 - DO 4005 I = 0, 1 - KGDS(2) = KGDS(2) * 256 + MOVA2I(MSGA(I+ISS+6)) - 4005 CONTINUE -C ------------------- BYTE 9-10 NR OF POINTS ALONG LONG MERIDIAN - KGDS(3) = 0 - DO 4010 I = 0, 1 - KGDS(3) = KGDS(3) * 256 + MOVA2I(MSGA(I+ISS+8)) - 4010 CONTINUE -C ------------------- BYTE 11-13 LATITUE OF ORIGIN - KGDS(4) = 0 - DO 4020 I = 0, 2 - KGDS(4) = KGDS(4) * 256 + MOVA2I(MSGA(I+ISS+10)) - 4020 CONTINUE - IF (IAND(KGDS(4),8388608).NE.0) THEN - KGDS(4) = - IAND(KGDS(4),8388607) - END IF -C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN - KGDS(5) = 0 - DO 4030 I = 0, 2 - KGDS(5) = KGDS(5) * 256 + MOVA2I(MSGA(I+ISS+13)) - 4030 CONTINUE - IF (IAND(KGDS(5),8388608).NE.0) THEN - KGDS(5) = - IAND(KGDS(5),8388607) - END IF -C ------------------- BYTE 17 RESOLUTION FLAG - KGDS(6) = MOVA2I(MSGA(ISS+16)) -C ------------------- BYTE 18-20 LATITUDE OF EXTREME POINT - KGDS(7) = 0 - DO 4040 I = 0, 2 - KGDS(7) = KGDS(7) * 256 + MOVA2I(MSGA(I+ISS+17)) - 4040 CONTINUE - IF (IAND(KGDS(7),8388608).NE.0) THEN - KGDS(7) = - IAND(KGDS(7),8388607) - END IF -C ------------------- BYTE 21-23 LONGITUDE OF EXTREME POINT - KGDS(8) = 0 - DO 4050 I = 0, 2 - KGDS(8) = KGDS(8) * 256 + MOVA2I(MSGA(I+ISS+20)) - 4050 CONTINUE - IF (IAND(KGDS(8),8388608).NE.0) THEN - KGDS(8) = - IAND(KGDS(8),8388607) - END IF -C ------------------- BYTE 24-25 LONGITUDE DIR INCREMENT - KGDS(9) = 0 - DO 4070 I = 0, 1 - KGDS(9) = KGDS(9) * 256 + MOVA2I(MSGA(I+ISS+23)) - 4070 CONTINUE - IF (IAND(KGDS(9),8388608).NE.0) THEN - KGDS(9) = - IAND(KGDS(9),32768) - END IF -C ------------------- BYTE 26-27 LATIT DIR INCREMENT - KGDS(10) = 0 - DO 4080 I = 0, 1 - KGDS(10) = KGDS(10) * 256 + MOVA2I(MSGA(I+ISS+25)) - 4080 CONTINUE - IF (IAND(KGDS(10),8388608).NE.0) THEN - KGDS(10) = - IAND(KGDS(10),32768) - END IF -C ------------------- BYTE 28 SCANNING MODE FLAGS - KGDS(11) = MOVA2I(MSGA(ISS+27)) -C ------------------- BYTE 29-31 INTERSECTION LATITUDE - KGDS(12) = 0 - DO 4060 I = 0, 2 - KGDS(12)= KGDS(12) * 256 + MOVA2I(MSGA(I+ISS+28)) - 4060 CONTINUE -C ------------------- BYTE 32 RESERVED -C ------------------- - GO TO 900 -C ------------------- PROCESS LAMBERT CONFORMAL -C -C ------------------- BYTE 7-8 NR OF POINTS ALONG X-AXIS - 5000 KGDS(2) = 0 - DO 5005 I = 0, 1 - KGDS(2) = KGDS(2) * 256 + MOVA2I(MSGA(I+ISS+6)) - 5005 CONTINUE -C ------------------- BYTE 9-10 NR OF POINTS ALONG Y-AXIS - KGDS(3) = 0 - DO 5010 I = 0, 1 - KGDS(3) = KGDS(3) * 256 + MOVA2I(MSGA(I+ISS+8)) - 5010 CONTINUE -C ------------------- BYTE 11-13 LATITUDE OF ORIGIN - KGDS(4) = 0 - DO 5020 I = 0, 2 - KGDS(4) = KGDS(4) * 256 + MOVA2I(MSGA(I+ISS+10)) - 5020 CONTINUE - IF (IAND(KGDS(4),8388608).NE.0) THEN - KGDS(4) = - IAND(KGDS(4),8388607) - END IF -C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN (LOWER LEFT) - KGDS(5) = 0 - DO 5030 I = 0, 2 - KGDS(5) = KGDS(5) * 256 + MOVA2I(MSGA(I+ISS+13)) - 5030 CONTINUE - IF (IAND(KGDS(5),8388608).NE.0) THEN - KGDS(5) = - IAND(KGDS(5),8388607) - END IF -C ------------------- BYTE 17 RESERVED -C KGDS(6) = -C ------------------- BYTE 18-20 LOV -ORIENTATION OF GRID - KGDS(7) = 0 - DO 5040 I = 0, 2 - KGDS(7) = KGDS(7) * 256 + MOVA2I(MSGA(I+ISS+17)) - 5040 CONTINUE - IF (IAND(KGDS(7),8388608).NE.0) THEN - KGDS(7) = - IAND(KGDS(7),8388607) - END IF -C ------------------- BYTE 21-23 DX - X-DIR INCREMENT - KGDS(8) = 0 - DO 5060 I = 0, 2 - KGDS(8) = KGDS(8) * 256 + MOVA2I(MSGA(I+ISS+20)) - 5060 CONTINUE -C ------------------- BYTE 24-26 DY - Y-DIR INCREMENT - KGDS(9) = 0 - DO 5070 I = 0, 2 - KGDS(9) = KGDS(9) * 256 + MOVA2I(MSGA(I+ISS+23)) - 5070 CONTINUE -C ------------------- BYTE 27 PROJECTION CENTER FLAG - KGDS(10) = MOVA2I(MSGA(ISS+26)) -C ------------------- BYTE 28 SCANNING MODE - KGDS(11) = MOVA2I(MSGA(ISS+27)) -C ------------------- BYTE 29-31 LATIN1 - 1ST LAT FROM POLE - KGDS(12) = 0 - DO 5050 I = 0, 2 - KGDS(12)= KGDS(12)* 256 + MOVA2I(MSGA(I+ISS+28)) - 5050 CONTINUE - IF (IAND(KGDS(12),8388608).NE.0) THEN - KGDS(12) = - IAND(KGDS(12),8388607) - END IF -C ------------------- BYTE 32-34 LATIN2 - 2ND LAT FROM POLE - KGDS(13) = 0 - DO 5055 I = 0, 2 - KGDS(13)= KGDS(13)* 256 + MOVA2I(MSGA(I+ISS+31)) - 5055 CONTINUE - IF (IAND(KGDS(13),8388608).NE.0) THEN - KGDS(13) = - IAND(KGDS(13),8388607) - END IF -C ------------------- - 900 CONTINUE - RETURN - END - SUBROUTINE AI084(MSGA,KPTR,KPDS,KGDS,KBMS,KRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: AI084 EXTRACT OR GENERATE BIT MAP FOR OUTPUT -C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 88-01-20 -C -C ABSTRACT: IF BIT MAP SEC IS AVAILABLE IN GRIB MESSAGE, EXTRACT -C FOR PROGRAM USE, OTHERWISE GENERATE AN APPROPRIATE BIT MAP. -C -C PROGRAM HISTORY LOG: -C 88-01-20 CAVANAUGH -C 89-02-24 CAVANAUGH INCREMENT OF POSITION IN BIT MAP WHEN BIT MAP -C WAS INCLUDED WAS HANDLED IMPROPERLY. -C CORRECTED THIS DATA. -C 89-07-12 CAVANAUGH ALTERED METHOD OF CALCULATING NR OF BITS -C IN A BIT MAP CONTAINED IN GRIB MESSAGE. -C 90-05-07 CAVANAUGH BRINGS ALL U.S. GRIDS TO -C REVISED VALUES AS OF DEC 89. -C 90-07-15 BOSTELMAN MODIIFED TO TEST -C THE GRIB BDS BYTE SIZE TO DETERMINE WHAT -C ECMWF GRID ARRAY SIZE IS TO BE SPECIFIED. -C 90-09-23 R.E.JONES CHANGE'S FOR CRAY CFT77 FORTRAN -C 90-12-05 R.E.JONES CHANGE'S FOR GRIB NOV. 21,1990 -C -C USAGE: CALL AI084(MSGA,KPTR,KPDS,KGDS,KBMS,KRET) -C INPUT ARGUMENT LIST: -C MSGA - BUFR MESSAGE -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C (1) - UNUSED -C (2) - UNUSED -C (3) - LENGTH OF PDS -C (4) - LENGTH OF GDS -C (5) - LENGTH OF BMS -C (6) - LENGTH OF BDS -C (7) - VALUE OF CURRENT BYTE -C (8) - UNUSED -C (9) - GRIB START BYTE NR -C (10) - GRIB/GRID ELEMENT COUNT -C KPDS - ARRAY CONTAINING PDS ELEMENTS. -C (1) - ID OF CENTER -C (2) - MODEL IDENTIFICATION -C (3) - GRID IDENTIFICATION -C (4) - GDS/BMS FLAG -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR OF CENTURY -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C -C OUTPUT ARGUMENT LIST: -C KBMS - BITMAP DESCRIBING LOCATION OF OUTPUT ELEMENTS. -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C SEE INPUT LIST -C KRET - ERROR RETURN -C -C REMARKS: -C KRET = 0 - NO ERROR -C = 5 - GRID NOT AVAIL FOR CENTER INDICATED -C =10 - INCORRECT CENTER INDICATOR -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C -C INCOMING MESSAGE HOLDER - CHARACTER*1 MSGA(*) -C -C BIT MAP - LOGICAL KBMS(*) -C -C ARRAY OF POINTERS AND COUNTERS - INTEGER KPTR(10) -C ARRAY OF POINTERS AND COUNTERS - INTEGER KPDS(20) - INTEGER KGDS(13) -C - INTEGER KRET - INTEGER MASK(8) -C ----------------------GRID 21 AND GRID 22 ARE THE SAME - LOGICAL GRD21( 1369) -C ----------------------GRID 23 AND GRID 24 ARE THE SAME - LOGICAL GRD23( 1369) - LOGICAL GRD25( 1368) - LOGICAL GRD26( 1368) -C ----------------------GRID 27 AND GRID 28 ARE THE SAME -C ----------------------GRID 29 AND GRID 30 ARE THE SAME -C ----------------------GRID 33 AND GRID 34 ARE THE SAME - LOGICAL GRD50(1188) -C -----------------------GRID 61 AND GRID 62 ARE THE SAME - LOGICAL GRD61( 4186) -C -----------------------GRID 63 AND GRID 64 ARE THE SAME - LOGICAL GRD63( 4186) -C - DATA GRD21 /1333*.TRUE.,36*.FALSE./ - DATA GRD23 /.TRUE.,36*.FALSE.,1332*.TRUE./ - DATA GRD25 /1297*.TRUE.,71*.FALSE./ - DATA GRD26 /.TRUE.,71*.FALSE.,1296*.TRUE./ - DATA GRD50/ -C LINE 1-4 - & 7*.FALSE.,22*.TRUE.,14*.FALSE.,22*.TRUE., - & 14*.FALSE.,22*.TRUE.,14*.FALSE.,22*.TRUE.,7*.FALSE., -C LINE 5-8 - & 6*.FALSE.,24*.TRUE.,12*.FALSE.,24*.TRUE., - & 12*.FALSE.,24*.TRUE.,12*.FALSE.,24*.TRUE.,6*.FALSE., -C LINE 9-12 - & 5*.FALSE.,26*.TRUE.,10*.FALSE.,26*.TRUE., - & 10*.FALSE.,26*.TRUE.,10*.FALSE.,26*.TRUE.,5*.FALSE., -C LINE 13-16 - & 4*.FALSE.,28*.TRUE., 8*.FALSE.,28*.TRUE., - & 8*.FALSE.,28*.TRUE., 8*.FALSE.,28*.TRUE.,4*.FALSE., -C LINE 17-20 - & 3*.FALSE.,30*.TRUE., 6*.FALSE.,30*.TRUE., - & 6*.FALSE.,30*.TRUE., 6*.FALSE.,30*.TRUE.,3*.FALSE., -C LINE 21-24 - & 2*.FALSE.,32*.TRUE., 4*.FALSE.,32*.TRUE., - & 4*.FALSE.,32*.TRUE., 4*.FALSE.,32*.TRUE.,2*.FALSE., -C LINE 25-28 - & .FALSE.,34*.TRUE., 2*.FALSE.,34*.TRUE., - & 2*.FALSE.,34*.TRUE., 2*.FALSE.,34*.TRUE., .FALSE., -C LINE 29-33 - & 180*.TRUE./ - DATA GRD61 /4096*.TRUE.,90*.FALSE./ - DATA GRD63 /.TRUE.,90*.FALSE.,4095*.TRUE./ - DATA MASK /128,64,32,16,8,4,2,1/ -C DATA MSK40 /Z00000040/ - DATA MSK40 /64/ -C - IS = KPTR(9) - IF (KPDS(18).EQ.0) THEN - IGRIBL = 4 - ELSE - IGRIBL = 8 - ENDIF - ISS = IS + KPTR(3) + KPTR(4) + IGRIBL -C ********************************************************** -C IF THE FLAG IN PDS INDICATES THAT THERE IS NO BMS, -C SET BIT MAP WITH ALL BITS ON -C ELSE -C RECOVER BIT MAP -C THEN RETURN -C ********************************************************** -C ---------------- NON-STANDARD GRID - IF (KPDS(3).EQ.255) THEN - J = KGDS(2) * KGDS(3) - KPTR(10) = J - DO 600 I = 1, J - KBMS(I) = .TRUE. - 600 CONTINUE - END IF - IF (IAND(KPDS(4),MSK40).EQ.0)THEN -C PRINT *,' NO BIT MAP',MSK40,KPDS(4) - GO TO 400 - ELSE - PRINT *,' HAVE A BIT MAP' - END IF -C ---------------- FLAG INDICATING PRESENCE OF BIT MAP IS ON - IF (KGDS(1).EQ.50) THEN - PRINT *,' W3AI08/AI084 WARNING - BIT MAP MAY NOT BE', - * ' ASSOCIATED WITH SPHERICAL COEFFICIENTS' - RETURN - ENDIF -C GET NUMBER OF UNUSED BITS - IUBITS = MOVA2I(MSGA(ISS+3)) -C SEE IF BIT MAP IS CONTAINED - KFLAG = 0 - DO 150 I = 0, 1 - KFLAG = KFLAG * 256 + MOVA2I(MSGA(I+ISS+4)) - 150 CONTINUE - PRINT *,'KFLAG=',KFLAG -C ----------------- IF KFLAG = 0 PICK UP NEW BIT MAP -C ELSE -C ------------------ USE PREDEFINED BIT MAP - MAXBYT = KPTR(5) - 6 - IF (KFLAG.EQ.0) THEN -C ------------------ UTILIZE BIT MAP FROM MESSAGE - II = 1 - DO 300 I = 1, MAXBYT - KCNT = MOVA2I(MSGA(I+ISS+6)) - DO 200 K = 1, 8 - IF (IAND(KCNT,MASK(K)).NE.0) THEN - KBMS(II) = .TRUE. - ELSE - KBMS(II) = .FALSE. - END IF - II = II + 1 - 200 CONTINUE - 300 CONTINUE - KPTR(10) = 8 * (KPTR(5) - 6) - IUBITS - GO TO 900 - ELSE - PRINT *,'KFLAG SAYS USE STD BIT MAP',KFLAG - END IF -C ---------------------- PREDEFINED BIT MAP IS INDICATED -C IF GRID NUMBER DOES NOT MATCH AN -C EXISTING GRID, SET KRET TO 5 AND -C ---------------------- RETURN. - 400 CONTINUE - KRET = 0 -C ---------------------- ECMWF MAP GRIDS - IF (KPDS(1).EQ.98) THEN - IF (KPDS(3).GE.1.AND.KPDS(3).LE.12) THEN - J = 1073 -C*** TEST FOR FULL HEMISPHERIC GRID **** - IF (KPTR(6) .GT. 2158) J= 1369 -C*** *** **** *** *** - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 1000 I = 1, J - KBMS(I) = .TRUE. - 1000 CONTINUE - ELSE IF (KPDS(3).GE.13.AND.KPDS(3).LE.16) THEN - J = 361 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 1013 I = 1, J - KBMS(I) = .TRUE. - 1013 CONTINUE - ELSE - KRET = 5 - RETURN - END IF -C ---------------------- U.K. MET OFFICE BRACKNELL - ELSE IF (KPDS(1).EQ.74) THEN - IF (KPDS(3).EQ.21.OR.KPDS(3).EQ.22) THEN -C ----- INT'L GRIDS 21, 22 - MAP SIZE 1369 - J = 1369 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 3021 I = 1, 1369 - KBMS(I) = GRD21(I) - 3021 CONTINUE - ELSE IF (KPDS(3).EQ.23.OR.KPDS(3).EQ.24) THEN -C ----- INT'L GRIDS 23, 24 - MAP SIZE 1369 - J = 1369 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 3023 I = 1, 1369 - KBMS(I) = GRD23(I) - 3023 CONTINUE - ELSE IF (KPDS(3).EQ.25) THEN -C ----- INT'L GRID 25 - MAP SIZE 1368 - J = 1368 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 3025 I = 1, 1368 - KBMS(I) = GRD25(I) - 3025 CONTINUE - ELSE IF (KPDS(3).EQ.26) THEN -C ----- INT'L GRID 26 - MAP SIZE 1368 - J = 1368 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 3026 I = 1, 1368 - KBMS(I) = GRD26(I) - 3026 CONTINUE - ELSE IF (KPDS(3).EQ.61.OR.KPDS(3).EQ.62) THEN -C ----- INT'L GRIDS 61, 62 - MAP SIZE 4186 - J = 4186 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 3061 I = 1, 4186 - KBMS(I) = GRD61(I) - 3061 CONTINUE - ELSE IF (KPDS(3).EQ.63.OR.KPDS(3).EQ.64) THEN -C ----- INT'L GRIDS 63, 64 - MAP SIZE 4186 - J = 4186 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 3063 I = 1, 4186 - KBMS(I) = GRD63(I) - 3063 CONTINUE - ELSE IF (KPDS(3).EQ.70) THEN -C ----- U.S. GRID 70 - MAP SIZE 16380 - J = 16380 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 3070 I = 1, J - KBMS(I) = .TRUE. - 3070 CONTINUE - ELSE - KRET = 5 - RETURN - END IF -C ---------------------- FNOC NAVY - ELSE IF (KPDS(1).EQ.58) THEN - PRINT *,' NO STANDARD FNOC GRID AT THIS TIME' - RETURN -C ---------------------- U.S. GRIDS - ELSE IF (KPDS(1).EQ.7) THEN - IF (KPDS(3).EQ.5) THEN -C ----- U.S. GRID 5 - MAP SIZE 3021 - J = 3021 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2005 I = 1, J - KBMS(I) = .TRUE. - 2005 CONTINUE - ELSE IF (KPDS(3).EQ.6) THEN -C ----- U.S. GRID 6 - MAP SIZE 2385 - J = 2385 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2006 I = 1, J - KBMS(I) = .TRUE. - 2006 CONTINUE - ELSE IF (KPDS(3).EQ.21.OR.KPDS(3).EQ.22) THEN -C ----- U.S. GRIDS 21, 22 - MAP SIZE 1369 - J = 1369 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2021 I = 1, 1369 - KBMS(I) = GRD21(I) - 2021 CONTINUE - ELSE IF (KPDS(3).EQ.23.OR.KPDS(3).EQ.24) THEN -C ----- U.S GRIDS 23, 24 - MAP SIZE 1369 - J = 1369 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2023 I = 1, 1369 - KBMS(I) = GRD23(I) - 2023 CONTINUE - ELSE IF (KPDS(3).EQ.25) THEN -C ----- U.S. GRID 25 - MAP SIZE 1368 - J = 1368 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2025 I = 1, 1368 - KBMS(I) = GRD25(I) - 2025 CONTINUE - ELSE IF (KPDS(3).EQ.26) THEN -C ----- U.S.GRID 26 - MAP SIZE 1368 - J = 1368 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2026 I = 1, 1368 - KBMS(I) = GRD26(I) - 2026 CONTINUE - ELSE IF (KPDS(3).EQ.27.OR.KPDS(3).EQ.28) THEN -C ----- U.S. GRIDS 27, 28 - MAP SIZE 4225 - J = 4225 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2027 I = 1, J - KBMS(I) = .TRUE. - 2027 CONTINUE - ELSE IF (KPDS(3).EQ.29.OR.KPDS(3).EQ.30)THEN -C ----- U.S. GRIDS 29,30 - MAP SIZE 5365 - J = 5365 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2029 I = 1, J - KBMS(I) = .TRUE. - 2029 CONTINUE - ELSE IF (KPDS(3).EQ.33.OR.KPDS(3).EQ.34) THEN -C ----- U.S GRID 33, 34 - MAP SIZE 8326 (181 X 46) - J = 8326 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2033 I = 1, J - KBMS(I) = .TRUE. - 2033 CONTINUE - ELSE IF (KPDS(3).EQ.50) THEN -C ----- U.S. GRID 50 - MAP SIZE 964 - J = 1188 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2050 I = 1, 1188 - KBMS(I) = GRD50(I) - 2050 CONTINUE - ELSE IF (KPDS(3).EQ.61.OR.KPDS(3).EQ.62) THEN -C ----- U.S. GRIDS 61, 62 - MAP SIZE 4186 - J = 4186 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2061 I = 1, 4186 - KBMS(I) = GRD61(I) - 2061 CONTINUE - ELSE IF (KPDS(3).EQ.63.OR.KPDS(3).EQ.64) THEN -C ----- U.S. GRIDS 63, 64 - MAP SIZE 4186 - J = 4186 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2063 I = 1, 4186 - KBMS(I) = GRD63(I) - 2063 CONTINUE - ELSE IF (KPDS(3).EQ.70) THEN -C ----- U.S. GRID 70 - MAP SIZE 16380 - J = 16380 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2070 I = 1, J - KBMS(I) = .TRUE. - 2070 CONTINUE - ELSE IF (KPDS(3).EQ.85.OR.KPDS(3).EQ.86) THEN -C ----- U.S. GRIDS 85, 86 - MAP SIZE 32400 (360 X 90) - J = 32400 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2085 I = 1, J - KBMS(I) = .TRUE. - 2085 CONTINUE - ELSE IF (KPDS(3).EQ.100) THEN -C ----- U.S. GRID 100 - MAP SIZE 6889 (83 X 83) - J = 6889 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 1100 I = 1, J - KBMS(I) = .TRUE. - 1100 CONTINUE - ELSE IF (KPDS(3).EQ.101) THEN -C ----- U.S. GRID 101 - MAP SIZE 10283 (113 X 91) - J = 10283 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2101 I = 1, J - KBMS(I) = .TRUE. - 2101 CONTINUE - ELSE IF (KPDS(3).EQ.102) THEN -C ----- U.S. GRID 102 - MAP SIZE 14375 (115 X 125) - J = 14375 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2102 I = 1, J - KBMS(I) = .TRUE. - 2102 CONTINUE - ELSE IF (KPDS(3).EQ.103) THEN -C ----- U.S. GRID 103 - MAP SIZE 3640 (65 X 56) - J = 3640 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2103 I = 1, J - KBMS(I) = .TRUE. - 2103 CONTINUE - ELSE IF (KPDS(3).GE.201.AND.KPDS(3).LE.214) THEN - IF (KPDS(3).EQ.201) J = 4225 - IF (KPDS(3).EQ.202) J = 2795 - IF (KPDS(3).EQ.203) J = 1755 - IF (KPDS(3).EQ.204) J = 5609 - IF (KPDS(3).EQ.205) J = 1755 - IF (KPDS(3).EQ.206) J = 2091 - IF (KPDS(3).EQ.207) J = 1715 - IF (KPDS(3).EQ.208) J = 625 - IF (KPDS(3).EQ.209) J = 8181 - IF (KPDS(3).EQ.210) J = 625 - IF (KPDS(3).EQ.211) J = 2915 - IF (KPDS(3).EQ.212) J = 4225 - IF (KPDS(3).EQ.213) J = 10965 - IF (KPDS(3).EQ.214) J = 6693 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2201 I = 1, J - KBMS(I) = .TRUE. - 2201 CONTINUE - ELSE - KRET = 5 - RETURN - END IF - ELSE - KRET = 10 - RETURN - END IF - 900 CONTINUE - RETURN - END - SUBROUTINE AI085(MSGA,KPTR,KPDS,KBMS,DATA,KRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: AI085 EXTRACT GRIB DATA ELEMENTS -C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 88-01-20 -C -C ABSTRACT: EXTRACT GRIB DATA AND PLACE INTO OUTPUT ARRY IN -C PROPER POSITION. -C -C PROGRAM HISTORY LOG: -C 88-01-20 CAVANAUGH -C 90-09-01 R.E.JONES CHANGE'S FOR ANSI FORTRAN -C 90-09-23 R.E.JONES CHANGE'S FOR CRAY CFT77 FORTRAN -C 90-12-05 R.E.JONES CHANGE'S FOR GRIB NOV. 21,1990 -C -C USAGE: CALL AI085(MSGA,KPTR,KPDS,KBMS,DATA,KRET) -C INPUT ARGUMENT LIST: -C MSGA - ARRAY CONTAINING GRIB MESSAGE -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C (1) - UNUSED -C (2) - UNUSED -C (3) - LENGTH OF PDS -C (4) - LENGTH OF GDS -C (5) - LENGTH OF BMS -C (6) - LENGTH OF BDS -C (7) - VALUE OF CURRENT BYTE -C (8) - UNUSED -C (9) - GRIB START BYTE NR -C (10) - GRIB/GRID ELEMENT COUNT -C KPDS - ARRAY CONTAINING PDS ELEMENTS. -C (1) - ID OF CENTER -C (2) - MODEL IDENTIFICATION -C (3) - GRID IDENTIFICATION -C (4) - GDS/BMS FLAG -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR OF CENTURY -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C KBMS - BITMAP DESCRIBING LOCATION OF OUTPUT ELEMENTS. -C -C OUTPUT ARGUMENT LIST: -C DATA - REAL ARRAY OF GRIDDED ELEMENTS IN GRIB MESSAGE. -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C SEE INPUT LIST -C KRET - ERROR RETURN -C -C REMARKS: -C ERROR RETURN -C 3 = UNPACKED FIELD IS LARGER THAN 32768 -C 6 = DOES NOT MATCH NR OF ENTRIES FOR THIS GRIB/GRID -C 7 = NUMBER OF BITS IN FILL TOO LARGE -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C ************************************************************* - CHARACTER*1 MSGA(*) - CHARACTER*1 KREF(8) - CHARACTER*1 KK(8) -C - LOGICAL KBMS(*) -C - INTEGER KPDS(*) - INTEGER KPTR(*) - INTEGER NRBITS - INTEGER KSAVE(105000) - INTEGER KSCALE -C - REAL DATA(*) - REAL REFNCE - REAL SCALE - REAL REALKK -C - LOGICAL IBM370 -C - EQUIVALENCE (REFNCE,KREF(1),IREF) - EQUIVALENCE (KK(1),REALKK,IKK) -C -C DATA MSK0F /Z0000000F/ -C DATA MSK80 /Z00000080/ -C DATA MSK40 /Z00000040/ -C - DATA MSK0F /15/ - DATA MSK80 /128/ - DATA MSK40 /64/ -C -C ************************************************************* - KRET = 0 - IS = KPTR(9) - ISS = IS + KPTR(3) + KPTR(4) + KPTR(5) + 4 -C BYTE 4 - KSPL = MOVA2I(MSGA(ISS+3)) -C POINT TO BYTE 5 OF BDS -C -C ------------- GET SCALE FACTOR -C - KSCALE = 0 - DO 100 I = 0, 1 - KSCALE = KSCALE * 256 + MOVA2I(MSGA(I+ISS+4)) - 100 CONTINUE - IF (IAND(KSCALE,32768).NE.0) THEN - KSCALE = - IAND(KSCALE,32767) - END IF - SCALE = 2.0**KSCALE -C -C ------------ GET REFERENCE VALUE -C - IREF = 0 - DO 200 I = 0, 3 - KREF(I+1) = MSGA(I+ISS+6) - 200 CONTINUE -C -C THE FLOATING POINT NUMBER IN THE REFERENCE VALUE IS AN IBM370 -C 32 BIT NUMBER, IF YOUR COMPUTER IS NOT AN IBM370 OR CLONE -C SET IBM370 TO .FALSE. SO THE NUMBER IS CONVERTED TO A F.P. -C NUMBER OF YOUR MACHINE TYPE. -C - IBM370 = .FALSE. -C - IF (.NOT.IBM370) THEN - KOFF = 0 -C GET 1 BIT SIGN - CALL GBYTE(IREF,ISGN,0,1) -C GET 7 BIT EXPONENT - CALL GBYTE(IREF,IEXP,1,7) -C GET 24 BIT FRACTION - CALL GBYTE(IREF,IFR,8,24) - IF (IFR.EQ.0.OR.IEXP.EQ.0) THEN - REFNCE = 0.0 - ELSE - REFNCE = FLOAT(IFR) * 16.0 ** (IEXP-64-6) - IF (ISGN.NE.0) REFNCE = - REFNCE - ENDIF - ENDIF -C -C ------------- NUMBER OF BITS SPECIFIED FOR EACH ENTRY -C - KBITS = MOVA2I(MSGA(ISS+10)) - KENTRY = KPTR(10) -C -C ------------- MAX SIZE CHECK -C - IF (KENTRY.GT.105000) THEN - KRET = 3 - RETURN - END IF - IF (KBITS.EQ.0) THEN -C -C -------------------- HAVE NO BDS ENTRIES, ALL ENTRIES = REFNCE -C - DO 210 I = 1, KENTRY - DATA(I) = 0.0 - IF (KBMS(I)) THEN - DATA(I) = REFNCE - END IF - 210 CONTINUE - GO TO 900 - END IF -C -C -------------------- -C CYCLE THRU BDS UNTIL HAVE USED ALL (SPECIFIED NUMBER) -C ENTRIES. -C -C ------------- UNUSED BITS IN DATA AREA -C - LESSBT = IAND(KSPL,MSK0F) -C -C ------------- NUMBER OF BYTES IN DATA AREA -C - NRBYTE = KPTR(6) - 11 -C -C ------------- TOTAL NR OF USABLE BITS -C - NRBITS = NRBYTE * 8 - LESSBT -C -C ------------- TOTAL NR OF ENTRIES -C - KENTRY = NRBITS / KBITS -C -C ------------- MAX SIZE CHECK -C - IF (KENTRY.GT.105000) THEN - KRET = 3 - RETURN - END IF -C - IBMS = IAND(KPDS(4),MSK40) -C -C -------------- CHECK TO SEE IF PROCESSING COEFFICIENTS -C IF YES, -C GO AND PROCESS AS SUCH -C ELSE -C CONTINUE PROCESSING -C - IF (IAND(KSPL,MSK80).EQ.0) THEN -C -C ------------- SET POINTERS -C -C XMOVEX MOVES THE DATA TO MAKE SURE IT IS ON A INTEGER WORD -C BOUNDARY, ON SOME COMPUTERS THIS DOES NOT HAVE TO BE DONE. -C (IBM PC, VAX) -C -C CALL XMOVEX(MSGB,MSGA(ISS+11),NRBYTE) -C ------------- UNPACK ALL FIELDS - KOFF = 0 -C -C THE BIT UNPACKER W3AI41 WILL CONSUME MOST OF THE CPU TIME -C CONVERTING THE GRIB DATA. FOR THE IBM370 WE HAVE AN -C ASSEMBLER AND FORTRAN VERSION. THE ASSMBLER VERSION WILL -C RUN TWO TO THREE TIMES FASTER. THE FORTRAN VERSION IS TO -C MAKE THE CODE MORE PORTABLE. FOR A VAX OR IBM PC WE HAVE -C ANOTHER VERSION, IT REVERSED THE ORDER OF THE BYTES IN -C AN INTEGER WORD. W3AI41 CAN BE REPLACED BY NCAR GBYTES -C BIT UNPACKER. NCAR HAS A LARGE NUMBER OF VERSIONS OF GBYTES -C IN FORTRAN AN ASSEMBLER FOR A NUMBER OF DIFFERENT BRANDS OF -C COMPUTERS. THEY ALSO HAVE A C VERSION. -C -C CALL W3AI41(MSGB,KSAVE,KBITS,KENTRY,KOFF) -C -C ALIGN CHARACTER ARRAY MSGA STARTING ADDRESS ON CRAY -C INTEGER WORD BOUNDARY -C - LLL = MOD(ISS+10,8) - NNN = 11 - LLL - KOFF = LLL * 8 - CALL GBYTES(MSGA(ISS+NNN),KSAVE,KOFF,KBITS,0,KENTRY) -C -C ------------- CORRECTLY PLACE ALL ENTRIES -C - II = 1 - KENTRY = KPTR(10) - DO 500 I = 1, KENTRY - IF (KBMS(I)) THEN - DATA(I) = REFNCE + FLOAT(KSAVE(II)) * SCALE - II = II + 1 - ELSE - DATA(I) = 0.0 - END IF - 500 CONTINUE - GO TO 900 - END IF -C -C ------------- PROCESS SPHERICAL HARMONIC COEFFICIENTS -C - IKK = 0 - DO 5500 I = 0, 3 - KK(I+1) = MSGA(I+ISS+11) - 5500 CONTINUE -C - IF (.NOT.IBM370) THEN - KOFF = 0 -C GET 1 BIT SIGN - CALL GBYTE(IKK,ISGN,0,1) -C GET 7 BIT EXPONENT - CALL GBYTE(IKK,IEXP,1,7) -C GET 24 BIT FRACTION - CALL GBYTE(IKK,IFR,8,24) - IF (IFR.EQ.0.OR.IEXP.EQ.0) THEN - REALKK = 0.0 - ELSE - REALKK = FLOAT(IFR) * 16.0 ** (IEXP-64-6) - IF (ISGN.NE.0) REALKK = - REALKK - ENDIF - ENDIF -C - DATA(1) = REALKK - KOFF = 0 -C CALL XMOVEX(MSGB,MSGA(ISS+15),NRBYTE) -C ------------- UNPACK ALL FIELDS -C -C CALL W3AI41(MSGB,KSAVE,KBITS,KENTRY,KOFF) -C -C ALIGN CHARACTER ARRAY MSGA STARTING ADDRESS ON CRAY -C INTEGER WORD BOUNDARY -C - LLL = MOD(ISS+14,8) - NNN = 15 - LLL - KOFF = LLL * 8 -C - CALL GBYTES(MSGA(ISS+NNN),KSAVE,KOFF,KBITS,0,KENTRY) -C -C -------------- - DO 6000 I = 1, KENTRY - DATA(I+1) = REFNCE + FLOAT(KSAVE(I)) * SCALE - 6000 CONTINUE - 900 CONTINUE - RETURN - END - SUBROUTINE AI085A(MSGA,KPTR,KPDS,KBMS,DATA,KRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: AI085A EXTRACT GRIB DATA (VER 1) ELEMENTS -C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 89-11-20 -C -C ABSTRACT: EXTRACT GRIB DATA (VERSION 1) AND PLACE INTO PROPER -C POSITION IN OUTPUT ARRAY. -C -C PROGRAM HISTORY LOG: -C 89-11-20 CAVANAUGH -C 90-09-01 R.E.JONES CHANGE'S FOR ANSI FORTRAN -C 90-09-23 R.E.JONES CHANGE'S FOR CRAY CFT77 FORTRAN -C 90-12-05 R.E.JONES CHANGE'S FOR GRIB NOV. 21,1990 -C -C USAGE: CALL AI085A (MSGA,KPTR,KPDS,KBMS,DATA,KRET) -C INPUT ARGUMENT LIST: -C MSGA - ARRAY CONTAINING GRIB MESSAGE -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C (1) - UNUSED -C (2) - UNUSED -C (3) - LENGTH OF PDS -C (4) - LENGTH OF GDS -C (5) - LENGTH OF BMS -C (6) - LENGTH OF BDS -C (7) - VALUE OF CURRENT BYTE -C (8) - UNUSED -C (9) - GRIB START BYTE NR -C (10) - GRIB/GRID ELEMENT COUNT -C KPDS - ARRAY CONTAINING PDS ELEMENTS. (VERSION 1) -C (1) - ID OF CENTER -C (2) - MODEL IDENTIFICATION -C (3) - GRID IDENTIFICATION -C (4) - GDS/BMS FLAG -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING CENTURY -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - TOTAL LENGTH OF GRIB MESSAGE (INCLUDING SECTION 0) -C KBMS - BITMAP DESCRIBING LOCATION OF OUTPUT ELEMENTS. -C -C OUTPUT ARGUMENT LIST: -C DATA - REAL ARRAY OF GRIDDED ELEMENTS IN GRIB MESSAGE. -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C SEE INPUT LIST -C KRET - ERROR RETURN -C -C REMARKS: -C STRUCTURE OF BINARY DATA SECTION (VERSION 1) -C 1-3 - LENGTH OF SECTION -C 4 - PACKING FLAGS -C 5-6 - SCALE FACTOR -C 7-10 - REFERENCE VALUE -C 11 - NUMBER OF BIT FOR EACH VALUE -C 12-N - DATA -C ERROR RETURN -C 3 = UNPACKED FIELD IS LARGER THAN 32768 -C 6 = DOES NOT MATCH NR OF ENTRIES FOR THIS GRIB/GRID -C 7 = NUMBER OF BITS IN FILL TOO LARGE -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C ************************************************************* - CHARACTER*1 MSGA(*) - CHARACTER*1 KREF(8) - CHARACTER*1 KK(8) -C - LOGICAL KBMS(*) -C - INTEGER KPDS(*) - INTEGER KPTR(*) - INTEGER NRBITS - INTEGER KSAVE(105000) - INTEGER KSCALE -C - REAL DATA(*) - REAL REFNCE - REAL SCALE - REAL REALKK -C - LOGICAL IBM370 -C - EQUIVALENCE (REFNCE,KREF(1),IREF) - EQUIVALENCE (KK(1),REALKK,IKK) -C -C DATA MSK0F /Z0000000F/ -C DATA MSK40 /Z00000040/ -C DATA MSK80 /Z00000080/ -C - DATA MSK0F /15/ - DATA MSK40 /64/ - DATA MSK80 /128/ -C -C ************************************************************* -C - KRET = 0 - IS = KPTR(9) - IGRIBL = 8 - ISS = IS + KPTR(3) + KPTR(4) + KPTR(5) + IGRIBL -C BYTE 4 - KSPL = MOVA2I(MSGA(ISS+3)) -C -C ------------- POINT TO BYTE 5 OF BDS -C -C ------------- GET SCALE FACTOR -C - KSCALE = 0 - DO 100 I = 0, 1 - KSCALE = KSCALE * 256 + MOVA2I(MSGA(I+ISS+4)) - 100 CONTINUE - IF (IAND(KSCALE,32768).NE.0) THEN - KSCALE = - IAND(KSCALE,32767) - END IF - SCALE = 2.0**KSCALE -C -C -------------------- DECIMAL SCALE EXPONENT -C - IDEC = IS + IGRIBL + 26 - JSCALE = 0 - DO 150 I = 0, 1 - JSCALE = JSCALE * 256 + MOVA2I(MSGA(I+IDEC)) - 150 CONTINUE -C IF HIGH ORDER BIT IS ON, HAVE NEGATIVE EXPONENT - IF (IAND(JSCALE,32768).NE.0) THEN - JSCALE = - IAND(JSCALE,32767) - END IF - ASCALE = 10.0 ** JSCALE -C -C ------------ GET REFERENCE VALUE -C - IREF = 0 - DO 200 I = 0, 3 - KREF(I+1) = MSGA(I+ISS+6) - 200 CONTINUE -C -C THE FLOATING POINT NUMBER IN THE REFERENCE VALUE IS AN IBM370 -C 32 BIT NUMBER, IF YOUR COMPUTER IS NOT AN IBM370 OR CLONE -C SET IBM370 TO .FALSE. SO THE NUMBER IS CONVERTED TO A F.P. -C NUMBER OF YOUR MACHINE TYPE. -C - IBM370 = .FALSE. -C - IF (.NOT.IBM370) THEN - KOFF = 0 -C GET 1 BIT SIGN - CALL GBYTE(IREF,ISGN,0,1) -C GET 7 BIT EXPONENT - CALL GBYTE(IREF,IEXP,1,7) -C GET 24 BIT FRACTION - CALL GBYTE(IREF,IFR,8,24) - IF (IFR.EQ.0.OR.IEXP.EQ.0) THEN - REFNCE = 0.0 - ELSE - REFNCE = FLOAT(IFR) * 16.0 ** (IEXP-64-6) - IF (ISGN.NE.0) REFNCE = - REFNCE - ENDIF - ENDIF -C -C ------------- NUMBER OF BITS SPECIFIED FOR EACH ENTRY -C - KBITS = MOVA2I(MSGA(ISS+10)) - KENTRY = KPTR(10) -C -C ------------- MAX SIZE CHECK -C - IF (KENTRY.GT.105000) THEN - KRET = 3 - RETURN - END IF -C - IF (KBITS.EQ.0) THEN -C -C -------------------- HAVE NO BDS ENTRIES, ALL ENTRIES = REFNCE -C - DO 210 I = 1, KENTRY - DATA(I) = 0.0 - IF (KBMS(I)) THEN - DATA(I) = REFNCE - END IF - 210 CONTINUE - GO TO 900 - END IF -C -C -------------------- -C CYCLE THRU BDS UNTIL HAVE USED ALL (SPECIFIED NUMBER) -C ENTRIES. -C -C ------------- UNUSED BITS IN DATA AREA -C - LESSBT = IAND(KSPL,MSK0F) -C -C ------------- NUMBER OF BYTES IN DATA AREA -C - NRBYTE = KPTR(6) - 11 -C -C ------------- TOTAL NR OF USABLE BITS -C - NRBITS = NRBYTE * 8 - LESSBT -C -C ------------- TOTAL NR OF ENTRIES -C - KENTRY = NRBITS / KBITS -C -C ------------- MAX SIZE CHECK -C - IF (KENTRY.GT.105000) THEN - KRET = 3 - RETURN - END IF - IBMS = IAND(KPDS(4),MSK40) -C -C -------------- CHECK TO SEE IF PROCESSING COEFFICIENTS -C IF YES, -C GO AND PROCESS AS SUCH -C ELSE -C CONTINUE PROCESSING - IF (IAND(KSPL,MSK80).EQ.0) THEN -C -C ------------- SET POINTERS -C -C REPLACE XMOVEX AND W3AI41 WITH GBYTES -C CALL XMOVEX(MSGB,MSGA(ISS+11),NRBYTE) -C -C ------------- UNPACK ALL FIELDS -C - KOFF = 0 -C CALL W3AI41(MSGB,KSAVE,KBITS,KENTRY,KOFF) -C -C THE BIT UNPACKER W3AI41 WILL CONSUME MOST OF THE CPU TIME -C CONVERTING THE GRIB DATA. FOR THE IBM370 WE HAVE AN -C ASSEMBLER AND FORTRAN VERSION. THE ASSMBLER VERSION WILL -C RUN TWO TO THREE TIMES FASTER. THE FORTRAN VERSION IS TO -C MAKE THE CODE MORE PORTABLE. FOR A VAX OR IBM PC WE HAVE -C ANOTHER VERSION, IT REVERSED THE ORDER OF THE BYTES IN -C AN INTEGER WORD. W3AI41 CAN BE REPLACED BY NCAR GBYTES -C BIT UNPACKER. NCAR HAS A LARGE NUMBER OF VERSIONS OF GBYTES -C IN FORTRAN AND ASSEMBLER FOR A NUMBER OF DIFFERENT BRANDS OF -C COMPUTERS. THEY ALSO HAVE A C VERSION. -C -C ALIGN CHARACTER ARRAY MSGA STARTING ADDRESS ON CRAY -C INTEGER WORD BOUNDARY -C - LLL = MOD(ISS+10,8) - NNN = 11 - LLL - KOFF = LLL * 8 -C - CALL GBYTES(MSGA(ISS+NNN),KSAVE,KOFF,KBITS,0,KENTRY) -C -C ------------- CORRECTLY PLACE ALL ENTRIES -C - II = 1 - KENTRY = KPTR(10) - DO 500 I = 1, KENTRY - IF (KBMS(I)) THEN -C MUST INCLUDE DECIMAL SCALE - DATA(I) = (REFNCE + FLOAT(KSAVE(II)) * SCALE) / ASCALE - II = II + 1 - ELSE - DATA(I) = 0.0 - END IF - 500 CONTINUE - GO TO 900 - END IF -C -C ------------- PROCESS SPHERICAL HARMONIC COEFFICIENTS -C - IKK = 0 - DO 5500 I = 0, 3 - KK(I+1) = MSGA(I+ISS+11) - 5500 CONTINUE -C - IF (.NOT.IBM370) THEN - KOFF = 0 -C GET 1 BIT SIGN - CALL GBYTE(IKK,ISGN,0,1) -C GET 7 BIT EXPONENT - CALL GBYTE(IKK,IEXP,1,7) -C GET 24 BIT FRACTION - CALL GBYTE(IKK,IFR,8,24) - IF (IFR.EQ.0.OR.IEXP.EQ.0) THEN - REALKK = 0.0 - ELSE - REALKK = FLOAT(IFR) * 16.0 ** (IEXP-64-6) - IF (ISGN.NE.0) REALKK = - REALKK - ENDIF - ENDIF -C - DATA(1) = REALKK - KOFF = 0 -C CALL XMOVEX(MSGB,MSGA(ISS+15),NRBYTE) -C -C ------------- UNPACK ALL FIELDS -C -C CALL W3AI41(MSGB,KSAVE,KBITS,KENTRY,KOFF) -C -------------- -C -C ALIGN CHARACTER ARRAY MSGA STARTING ADDRESS ON CRAY -C INTEGER WORD BOUNDARY -C - LLL = MOD(ISS+14,8) - NNN = 15 - LLL - KOFF = LLL * 8 -C - CALL GBYTES(MSGA(ISS+NNN),KSAVE,KOFF,KBITS,0,KENTRY) -C - DO 6000 I = 1, KENTRY - DATA(I+1) = REFNCE + FLOAT(KSAVE(I)) * SCALE - 6000 CONTINUE - 900 CONTINUE - RETURN - END - SUBROUTINE AI087(*,J,KPDS,KGDS,KRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: AI087 GRIB GRID/SIZE TEST -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-02-08 -C -C ABSTRACT: TO TEST WHEN GDS IS AVAILABLE TO SEE IF SIZE MISMATCH -C ON EXISTING GRIDS (BY CENTER) IS INDICATED -C -C PROGRAM HISTORY LOG: -C 88-02-08 CAVANAUGH -C 90-09-23 R.E.JONES CHANGE'S FOR CRAY CFT77 FORTRAN -C 90-12-05 R.E.JONES CHANGE'S FOR GRIB NOV. 21,1990 -C -C USAGE: CALL AI087(*,J,KPDS,KGDS,KRET) -C INPUT ARGUMENT LIST: -C J - SIZE FOR INDICATED GRID -C KPDS - -C KGDS - -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KRET - ERROR RETURN -C -C REMARKS: -C KRET - -C = 9 - GDS INDICATES SIZE MISMATCH WITH STD GRID -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ - INTEGER KPDS(20) - INTEGER KGDS(13) - INTEGER J - INTEGER I -C --------------------------------------- -C --------------------------------------- -C IF GDS NOT INDICATED, RETURN -C ---------------------------------------- - IF (IAND(KPDS(4),128).EQ.0) RETURN -C --------------------------------------- -C GDS IS INDICATED, PROCEED WITH TESTING -C --------------------------------------- - I = KGDS(2) * KGDS(3) -C --------------------------------------- -C TEST ECMWF CONTENT -C --------------------------------------- - IF (KPDS(1).EQ.98) THEN - KRET = 9 - IF (KPDS(3).GE.1.AND.KPDS(3).LE.16) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE - KRET = 5 - RETURN 1 - END IF -C --------------------------------------- -C U.K. MET OFFICE, BRACKNELL -C --------------------------------------- - ELSE IF (KPDS(1).EQ.74) THEN - KRET = 9 - IF (KPDS(3).GE.21.AND.KPDS(3).LE.24) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).EQ.25.OR.KPDS(3).EQ.26) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).GE.61.AND.KPDS(3).LE.64) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).EQ.70) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE - KRET = 5 - RETURN 1 - END IF -C --------------------------------------- -C NAVY - FNOC -C --------------------------------------- - ELSE IF (KPDS(1).EQ.58) THEN - PRINT *,' NO CURRENT LISTING OF NAVY GRIDS' - RETURN 1 -C --------------------------------------- -C U.S. GRIDS -C --------------------------------------- - ELSE IF (KPDS(1).EQ.7) THEN - KRET = 9 - IF (KPDS(3).EQ.5) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).EQ.6) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).GE.21.AND.KPDS(3).LE.24) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).EQ.25.OR.KPDS(3).EQ.26) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).EQ.27.OR.KPDS(3).EQ.28) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).EQ.29.OR.KPDS(3).EQ.30) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).EQ.33.OR.KPDS(3).EQ.34) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).EQ.50) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).GE.61.AND.KPDS(3).LE.64) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).EQ.70) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).EQ.85.OR.KPDS(3).EQ.86) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).EQ.100) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).EQ.101) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).EQ.102) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).EQ.103) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).GE.201.AND.KPDS(3).LE.214) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE - KRET = 5 - RETURN 1 - END IF - ELSE - KRET = 10 - RETURN 1 - END IF -C ------------------------------------ -C NORMAL EXIT -C ------------------------------------ - KRET = 0 - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ai15.f b/src/fim/FIMsrc/w3/w3ai15.f deleted file mode 100644 index b65cdf8..0000000 --- a/src/fim/FIMsrc/w3/w3ai15.f +++ /dev/null @@ -1,124 +0,0 @@ - SUBROUTINE W3AI15 (NBUFA,NBUFB,N1,N2,MINUS) -C$$$ SUBROUTINE DOCUMENTATION BLOCK CCC -C -C SUBR: W3AI15 - CONVERT INTEGERS TO ACSII (ALTERNATE TO ENCODE) -C AUTHOR: ALLARD, R. ORG: W342 DATE: JANUARY, 1974 -C -C ABSTRACT: CONVERTS A SET OF BINARY NUMBERS TO AN EQUIVALENT SET -C OF ASCII NUMBER FIELDS IN CORE. THIS IS AN ALTERNATE PROCEDURE -C TO THE USE OF THE 360/195 VERSION OF ENCODE. -C -C PROGRAM HISTORY LOG: -C 74-01-15 R.ALLARD -C 89-02-06 R.E.JONES CHANGE FROM ASSEMBLER TO FORTRAN -C THIS SUBROUTINE SHOULD BE REWRITTEN IM -C INTEL 8088 ASSEMBLY LANGUAGE -C 90-08-13 R.E.JONES CHANGE TO CRAY CFT77 FORTRAN -C -C USAGE: CALL W3AI15 (NBUFA,NBUFB,N1,N2,MINUS) -C -C INPUT: -C 'NBUFA' - INPUT ARRAY (INTEGER*4) -C ' N1' - NUMBER OF INTEGERS IN NBUFA TO BE CONVERTED -C ' N2' - DESIRED CHARACTER WIDTH OF ASCII NUMBER FIELD -C 'MINUS' - CHARACTER TO BE INSERTED IN THE HIGH ORDER POSITION -C OF A NEGATIVE NUMBER FIELD -C OUTPUT: -C 'NBUFB' - OUTPUT ARRAY (INTEGER*4) -C -C EXIT STATES: NONE -C -C EXTERNAL REFERENCES: NONE -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C -C NOTE 1. - IF N2 IS GREATER THAN 4, ALLOW TWO WORDS (EIGHT CHARACTERS) -C IN THE NBUFB ARRAY FOR EACH ASCII NUMBER FIELD. A NUMBER FIELD -C IS LEFT ADJUSTED WITH BLANK FILL TO THE RIGHT IF NEEDED. -C LIKEWISE, IF N2 IS LESS THAN 4, THE RESULT IS LEFT ADJUSTED -C WITH BLANK FILL TO THE RIGHT. -C -C NOTE 2. - N2 CAN BE SPECIFIED IN THE RANGE 1-8. AN EIGHT DIGIT POSI- -C TIVE INTEGER CAN BE CONVERTED OR A SEVEN DIGIT NEGATIVE INTEGER -C AND A SIGN. ZERO FILL IS USED FOR HIGH ORDER POSITIONS IN A -C NUMBER FIELD. THE USER SHOULD BE AWARE THAT W3AI15 DOES NOT -C VERIFY THAT THE VALUE OF N2 IS IN THE CORRECT RANGE. -C -C NOTE 3. - THE MINUS SIGN CAN BE INSERTED AS A LITERAL IN THE CALL -C SEQUENCE OR DEFINED IN A DATA STATEMENT. 1H- AND 1H+ ARE THE -C TWO MOST LIKELY NEGATIVE SIGNS. UNFORTUNATELY THE ASCII PLUS -C CHARACTER IS THE NEGATIVE SIGN REQUIRED IN MOST TRANSMISSIONS. -C THE MINUS SIGN WILL ALWAYS BE IN THE HIGH ORDER POSITION OF A -C NEGATIVE NUMBER FIELD. -C -C NOTE 4. - IF A NUMBER CONTAINS MORE DIGITS THAN THE N2 SPECIFICATION -C ALLOWS, THE EXCESS HIGH ORDER DIGITS ARE LOST. -C - INTEGER ATEMP - INTEGER BTEMP - INTEGER IDIV(8) - INTEGER NBUFA(*) - INTEGER NBUFB(*) -!JFM INTEGER ZERO(8) - INTEGER*8 ZERO(8) !JFM -C - CHARACTER*1 BLANK - CHARACTER*1 JTEMP(8) - CHARACTER*1 MINUS - CHARACTER*1 NUM(0:9) -C - LOGICAL ISIGN -C - EQUIVALENCE (BTEMP,JTEMP(1)) -C - DATA BLANK /' '/ - DATA IDIV /1,10,100,1000,10000,100000,1000000,10000000/ - DATA NUM /'0','1','2','3','4','5','6','7','8','9'/ - DATA ZERO /X'3020202020202020',X'3030202020202020', - & X'3030302020202020',X'3030303020202020', - & X'3030303030202020',X'3030303030302020', - & X'3030303030303020',X'3030303030303030'/ -C - DO 100 I = 1,N1 - IF (NBUFA(I).EQ.0) THEN - NBUFB(I) = ZERO(N2) - GO TO 100 - ENDIF - ATEMP = NBUFA(I) - ISIGN = .FALSE. - IF (ATEMP.LT.0) THEN - ISIGN = .TRUE. - ATEMP = IABS(ATEMP) - ENDIF - IF (.NOT.ISIGN) THEN - DO 10 J = 1,8 - IF (J.LE.N2) THEN - I1 = MOD(ATEMP/IDIV(N2-J+1),10) - JTEMP(J) = NUM(I1) - ELSE - JTEMP(J) = BLANK - ENDIF - 10 CONTINUE - - ELSE - - JTEMP(1) = MINUS - DO 20 J = 2,8 - IF (J.LE.N2) THEN - I1 = MOD(ATEMP/IDIV(N2-J+1),10) - JTEMP(J) = NUM(I1) - ELSE - JTEMP(J) = BLANK - ENDIF - 20 CONTINUE - ENDIF -C - NBUFB(I) = BTEMP -C - 100 CONTINUE - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ai18.f b/src/fim/FIMsrc/w3/w3ai18.f deleted file mode 100644 index 178c9c6..0000000 --- a/src/fim/FIMsrc/w3/w3ai18.f +++ /dev/null @@ -1,113 +0,0 @@ - SUBROUTINE W3AI18(ITEM,I1,I2,LINE,L,K,N) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3AI18 LINE BUILDER SUBROUTINE -C PRGMMR: ALLARD, R. ORG: W/NMC42 DATE: 74-02-01 -C -C ABSTRACT: BUILD A LINE OF INFORMATION COMPOSED OF USER SPECIFIED -C CHARACTER STRINGS. -C -C PROGRAM HISTORY LOG: -C 74-02-02 ROBERT ALLARD -C 84-07-05 R.E.JONES RECOMPILE -C 96-08-06 R.E.JONES CONVERT FROM IBM370 ASSEMBLER TO FORTRAN -C FOR THE CRAY, WORKSTATIONS, AND PC'S. -C -C USAGE: CALL W3AI18(ITEM, I1, I2, LINE, L, K, N) -C INPUT ARGUMENT LIST: -C ITEM - CHARACTER STRING TO BE ADDED TO LINE ARRAY -C I1 - NUMBER OF CHARACTER STRINGS TO BE ADDED TO LINE ARRAY -C I2 - NUMBER OF CHARACTERS PER STRING TO ADD TO LINE -C L - CHARACTER LENGTH OF LINE TO BE BUILT (2.LE.L.LE.256) -C K - NUMBER OF BLKANK CHARACTERS TO PRECEDE A CHARACTER -C STRING (0.LE.K.LE.256) -C N - POINTER SET EQUAL TO 0 WHEN BEGINNING A LINE -C -C OUTPUT ARGUMENT LIST: -C LINE - ARRAY IN WHICH CHARACTER STRING ARE PLACED WHILE -C BUILDING ALINE; MUST BE OF TYPE INTEGER -C N - CHARACTER COUNT, ERROR INDICATOR -C -C -C EXIT STATES: -C N = -1 CHARACTER STRING WILL NOT FIT IN THE LINE ARRAY; -C OTHERWISE, EACH TIME A CHACTER STRING IS ADDED -C TO THE LINE, N IS INCREMENTED BY (I2 + K) -C -C NOTE 1. - EACH CHARACTER STRING INCLUDED IN THE ITEM ARRAY MUST -C START ON A FULL WORD BOUNDARY AND BE EQUAL IN LENGTH. -C EACH SUCCESSIVE STRING MUST START ON THE NEST FULLWORD -C BOUNDARY FOLLOWING THE END OF THE PREVIOUS STRING. -C ON A CRAY THIS 8. -C -C NOTE 2. - THE DIMENSIONS OF THE ITEM ARRAY SHOULD BE AT LEAST THE -C VALUE OF (I1*(I2+J))/4, WHERE THE INTEGER J IS IN THE -C RANGE 0.LE.J.LE.3 AND THE SUM (I2+J) IS 4 OR A MULTIPLE -C OF 4. ON A CRAY THIS IS 8 OR A MULTIPLE OF 8. ON A CRAY -C (I1*(I2+J))/8, RANGE IS 0.LE.J.LE.7 -C -C NOTE 3. - THE MAXIMUM DIMENSION OF LINE IS 64 WORD OR 256 BYTES. -C ON A CRAY IT IS 32 WORDS OR 256 BYTES. -C -C NOTE 4. - THE USER SHOULD SET N = 0 EACH TIME A LINE IS STATED TO -C TELL W3AI18 TO FILL THE LINE ARRAY WITH BLANK CHARACTERS. -C EACH TIME A CHARACTER STRING IS ADDED TO THE LINE, THE -C VARIABLE (N) IS INCREMENTED BY (I2 + K). IF A CHARACTER -C STRING WILL NOT FIT IN THE LINE ARRAY, W3AI18 SETS N = -1 -C AND RETURNS TO THE USER. THE USER WILL NOT BE ABLE TO -C PROGRAM A RECOVERY PROCEDURE FOR THE LINE BEING FULL IF -C MORE THAN ONE CHARACTER STRING IS IN THE ITEM ARRAY. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916/256, J916/2048. -C -C$$$ -C - CHARACTER * (*) LINE - CHARACTER * (*) ITEM -C - SAVE -C -C TEST WORD LENGTH, LW WILL BE 4 OR 8 BYTES -C - CALL W3FI01(LW) -C -C BAIL OUT IF NEGATIVE -C - IF (N.LT.0) RETURN -C -C FILL LINE WITH BLANK CHAACTERS -C - IF (N.EQ.0) THEN - DO I = 1,L - LINE(I:I) = ' ' - END DO - END IF - IF (I1.EQ.1) THEN - J = 0 - IF ((I2+K+N).GT.L) GO TO 200 - LINE(K+N+1:K+N+I2) = ITEM(1:I2) - N = I2+K+N - RETURN - ELSE - JJ = MOD(I2, LW) - IF (JJ.EQ.0) THEN - J = 0 - ELSE - J = LW - JJ - END IF - IF ((I2+K+N).GT.L) GO TO 200 - LINE(K+N+1:K+N+I2) = ITEM(1:I2) - N = I2+K+N - DO I = 1,I1-1 - IF ((I2+K+N).GT.L) GO TO 200 - LINE(K+N+1:K+N+I2) = ITEM((I2+J)*I+1:(I2+J)*I+I2) - N = I2+K+N - END DO - RETURN - END IF - 200 CONTINUE - N = -1 - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ai19.f b/src/fim/FIMsrc/w3/w3ai19.f deleted file mode 100644 index f2654da..0000000 --- a/src/fim/FIMsrc/w3/w3ai19.f +++ /dev/null @@ -1,127 +0,0 @@ - SUBROUTINE W3AI19(LINE, L, NBLK, N, NEXT) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3AI19 LINE BLOCKER SUBROUTINE -C PRGMMR: BOB HOLLERN ORG: NCO/NP12 DATE: 97-04-15 -C -C ABSTRACT: FILLS A RECORD BLOCK WITH LOGICAL RECORDS OR LINES -C OF INFORMATION. -C -C PROGRAM HISTORY LOG: -C 74-02-01 BOB ALLARD, AUTHOR -C 90-09-15 R.E.JONES CONVERT FROM IBM370 ASSEMBLER TO MICROSOFT -C FORTRAN 5.0 -C 90-10-07 R.E.JONES CONVERT TO SUN FORTRAN 1.3 -C 91-07-20 R.E.JONES CONVERT TO SiliconGraphics 3.3 FORTRAN 77 -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C 94-04-22 R.E.JONES ADD XMOVEX AND XSTORE TO MOVE AND -C STORE CHARACTER DATA FASTER ON THE CRAY -C 97-04-15 Bob Hollern CORRECTED THE PROBLEM OF INIIALIZING NBLK -C TO @'S INSTEAD OF BLANKS -C -C USAGE: CALL W3AI19 (LINE, L, NBLK, N, NEXT) -C INPUT ARGUMENT LIST: -C LINE - ARRAY ADDRESS OF LOGICAL RECORD TO BE BLOCKED -C L - NUMBER OF CHARACTERS IN LINE TO BE BLOCKED -C N - MAXIMUM CHARACTER SIZE OF NBLK -C NEXT - FLAG, INITIALIZED TO 0 -C -C OUTPUT ARGUMENT LIST: -C NBLK - BLOCK FILLED WITH LOGICAL RECORDS -C NEXT - CHARACTER COUNT, ERROR INDICATOR -C -C EXIT STATES: -C NEXT = -1 LINE WILL NOT FIT INTO REMAINDER OF BLOCK; -C OTHERWISE, NEXT IS SET TO (NEXT + L) -C NEXT = -2 N IS ZERO OR LESS -C NEXT = -3 L IS ZERO OR LESS -C -C EXTERNAL REFERENCES: XMOVEX XSTORE -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256 -C -C$$$ -C -C METHOD: -C -C THE USER MUST SET NEXT = 0 EACH TIME NBLK IS TO BE FILLED WITH -C LOGICAL RECORDS. -C -C W3AI19 WILL THEN MOVE THE LINE OF INFORMATION INTO NBLK, STORE -C BLANK CHARACTERS IN THE REMAINDER OF THE BLOCK, AND SET NEXT = NEXT -C + L. -C -C EACH TIME W3AI19 IS ENTERED, ONE LINE IS BLOCKED AND NEXT INCRE- -C MENTED UNTIL A LINE WILL NOT FIT THE REMAINDER OF THE BLOCK. THEN -C W3AI19 WILL SET NEXT = -1 AS A FLAG FOR THE USER TO DISPOSE OF THE -C BLOCK. THE USER SHOULD BE AWARE THAT THE LAST LOGICAL RECORD WAS NOT -C BLOCKED. -C - INTEGER L - INTEGER N - INTEGER NEXT - INTEGER(8) WBLANK -C - CHARACTER * 1 LINE(*) - CHARACTER * 1 NBLK(*) - CHARACTER * 1 BLANK -C - SAVE -C - DATA WBLANK/Z'2020202020202020'/ -C -C TEST VALUE OF NEXT. -C - IF (NEXT.LT.0) THEN - RETURN -C -C TEST N FOR ZERO OR LESS -C - ELSE IF (N.LE.0) THEN - NEXT = -2 - RETURN -C -C TEST L FOR ZERO OR LESS -C - ELSE IF (L.LE.0) THEN - NEXT = -3 - RETURN -C -C TEST TO SEE IF LINE WILL FIT IN BLOCK. -C - ELSE IF ((L + NEXT).GT.N) THEN - NEXT = -1 - RETURN -C -C FILL BLOCK WITH BLANK CHARACTERS IF NEXT EQUAL ZERO. -C BLANK IS EBCDIC BLANK, 40 HEX, OR 64 DECIMAL -C - ELSE IF (NEXT.EQ.0) THEN - CALL W3FI01(LW) - IWORDS = N / LW - CALL XSTORE(NBLK,WBLANK,IWORDS) - IF (MOD(N,LW).NE.0) THEN - NWORDS = IWORDS * LW - IBYTES = N - NWORDS - DO I = 1,IBYTES - NBLK(NWORDS+I) = CHAR(32) - END DO - END IF - END IF -C -C MOVE LINE INTO BLOCK. -C -C DO 20 I = 1,L -C NBLK(I + NEXT) = LINE(I) -C20 CONTINUE - CALL XMOVEX(NBLK(NEXT+1),LINE,L) -C -C ADJUST VALUE OF NEXT. -C - NEXT = NEXT + L -C - RETURN -C - END diff --git a/src/fim/FIMsrc/w3/w3ai24.f b/src/fim/FIMsrc/w3/w3ai24.f deleted file mode 100644 index bea6da9..0000000 --- a/src/fim/FIMsrc/w3/w3ai24.f +++ /dev/null @@ -1,49 +0,0 @@ - LOGICAL FUNCTION W3AI24(STRING1, STRING2,LENGTH) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C FUNCT W3AI24 TEST FOR MATCH OF TWO STRINGS -C PRGMMR: LUKELIN ORG: NMC421 DATE:94-08-31 -C -C ABSTACT: TEST TWO STRINGS. -C IF ALL EQUAL; OTHERWISE .FALSE. -C -C PROGRAM HISTORY LOG: -C 94-08-31 LUKE LIN -C -C USAGE: II = W3AI24(STRING1,STRING2,LENGTH) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C STRING1 ARG LIST CHARACTER ARRAY TO MATCH WITH STRING2 -C STRING2 ARG LIST CHARACTER ARRAY TO MATCH WITH STRING1 -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C W3AI24 FUNCTION LOGICAL .TRUE. IF S1 AND S2 MATCH ON ALL CHAR., -C LOGICAL .FALSE. IF NOT MATCH ON ANY CHAR. -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN -C MACHINE: NAS -C -C$$$ -C - CHARACTER*1 STRING1(*) - CHARACTER*1 STRING2(*) - INTEGER*4 LENGTH -C - W3AI24 = .TRUE. -C - DO 10 I = 1,LENGTH - IF (STRING1(I).NE.STRING2(I)) GO TO 40 - 10 CONTINUE -C - RETURN -C - 40 CONTINUE - W3AI24 = .FALSE. - RETURN -C - END diff --git a/src/fim/FIMsrc/w3/w3ai38.f b/src/fim/FIMsrc/w3/w3ai38.f deleted file mode 100644 index b8e2f12..0000000 --- a/src/fim/FIMsrc/w3/w3ai38.f +++ /dev/null @@ -1,84 +0,0 @@ - SUBROUTINE W3AI38 (IE, NC ) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3AI38 EBCDIC TO ASCII -C PRGMMR: DESMARAIS ORG: W342 DATE: 82-11-29 -C -C ABSTRACT: CONVERT EBCDIC TO ASCII BY CHARACTER. -C THIS SUBROUTINE CAN BE REPLACED BY CRAY UTILITY SUBROUTINE -C USCCTC . SEE MANUAL SR-2079 PAGE 3-15. CRAY UTILITY TR -C CAN ALSO BE USED FOR ASCII, EBCDIC CONVERSION. SEE MANUAL SR-2079 -C PAGE 9-35. -C -C PROGRAM HISTORY LOG: -C 82-11-29 DESMARAIS -C 88-03-31 R.E.JONES CHANGE LOGIC SO IT WORKS LIKE A -C IBM370 TRANSLATE INSTRUCTION. -C 88-08-22 R.E.JONES CHANGES FOR MICROSOFT FORTRAN 4.10 -C 88-09-04 R.E.JONES CHANGE TABLES TO 128 CHARACTER SET -C 90-01-31 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C CRAY DOES NOT ALLOW CHAR*1 TO BE SET TO HEX -C 98-12-21 Gilbert Replaced Function ICHAR with mova2i. -C -C USAGE: CALL W3AI38 (IE, NC) -C INPUT ARGUMENT LIST: -C IE - CHARACTER*1 ARRAY OF EBCDIC DATA -C NC - INTEGER, CONTAINS CHARACTER COUNT TO CONVERT.... -C -C OUTPUT ARGUMENT LIST: -C IE - CHARACTER*1 ARRAY OF ASCII DATA -C -C REMARKS: SOFTWARE VERSION OF IBM370 TRANSLATE INSTRUCTION, BY -C CHANGING THE TWO TABLES WE COULD DO A 64, 96, 128 ASCII -C CHARACTER SET, CHANGE LOWER CASE TO UPPER, ETC. -C AEA CONVERTS DATA AT A RATE OF 1.5 MILLION CHARACTERS PER SEC. -C CRAY UTILITY USCCTI CONVERT ASCII TO IBM EBCDIC -C CRAY UTILITY USCCTC CONVERT IBM EBCDIC TO ASCII -C THEY CONVERT DATA AT A RATE OF 2.1 MILLION CHARACTERS PER SEC. -C CRAY UTILITY TR WILL ALSO DO A ASCII, EBCDIC CONVERSION. -C TR CONVERT DATA AT A RATE OF 5.4 MILLION CHARACTERS PER SEC. -C TR IS IN LIBRARY /USR/LIB/LIBCOS.A ADD TO SEGLDR CARD. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/864 -C -C$$$ -C - INTEGER(8) IASCII(32) -C - CHARACTER*1 IE(*) - CHARACTER*1 ASCII(0:255) -C - EQUIVALENCE (IASCII(1),ASCII(0)) -C -C*** ASCII CONTAINS ASCII CHARACTERS, AS PUNCHED ON IBM029 -C - DATA IASCII/ - & X'000102030009007F',X'0000000B0C0D0E0F', - & X'1011120000000000',X'1819000000000000', - & X'00001C000A001700',X'0000000000050607', - & X'00001600001E0004',X'000000001415001A', - & X'2000600000000000',X'0000602E3C282B00', - & X'2600000000000000',X'000021242A293B5E', - & X'2D2F000000000000',X'00007C2C255F3E3F', - & X'0000000000000000',X'00603A2340273D22', - & X'2061626364656667',X'6869202020202020', - & X'206A6B6C6D6E6F70',X'7172202020202020', - & X'207E737475767778',X'797A2020205B2020', - & X'0000000000000000',X'00000000005D0000', - & X'7B41424344454647',X'4849202020202020', - & X'7D4A4B4C4D4E4F50',X'5152202020202020', - & X'5C20535455565758',X'595A202020202020', - & X'3031323334353637',X'3839202020202020'/ -C - IF (NC .LE. 0) RETURN -C -C*** CONVERT STRING ... EBCDIC TO ASCII, NC CHARACTERS -C - DO 20 J = 1, NC - IE(J) = ASCII(mova2i(IE(J))) - 20 CONTINUE -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ai39.f b/src/fim/FIMsrc/w3/w3ai39.f deleted file mode 100644 index 266bd23..0000000 --- a/src/fim/FIMsrc/w3/w3ai39.f +++ /dev/null @@ -1,81 +0,0 @@ - SUBROUTINE W3AI39 (NFLD, N) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3AI39 TRANSLATE 'ASCII' FIELD TO 'EBCDIC' -C PRGMMR: DESMARAIS ORG: W342 DATE: 93-10-06 -C -C ABSTRACT: TRANSLATE AN 'ASCII' FIELD TO 'EBCDIC', ALL ALPHANUMERICS, -C SPECIAL CHARCATERS, FILL SCATTER, BROCKEN< CLEAR, OVERCAST, BELL, -C HT AND VT (FOR AFOS). SPACE, '6D' TO '5E' CONVERSION (HDROLOGY), -C CHANGERS WERE MADE TO W3AI38 TO GIVE REVERSE TABLE TRANSLATION -C -C PROGRAM HISTORY LOG: -C 93-10-06 R.E.JONES CONVERT IBM370 ASSEBLER VERSION TO FORTRAN -C 94-04-28 R.E.JONES CHANGES FOR CRAY -C 98-12-21 Gilbert Replaced Function ICHAR with mova2i. -C -C USAGE: CALL W3AI39 (NFLD,N) -C INPUT ARGUMENT LIST: -C NFLD - CHARACTER*1 ARRAY OF ASCII DATA -C N - INTEGER, CONTAINS CHARACTER COUNT TO CONVERT.... -C -C OUTPUT ARGUMENT LIST: -C NFLD - CHARACTER*1 ARRAY OF EBCDIC DATA -C -C REMARKS: SOFTWARE VERSION OF IBM370 TRANSLATE INSTRUCTION, BY -C CHANGING THE TABLE WE COULD DO A 64, 96, ASCII -C CHARACTER SET, CHANGE LOWER CASE TO UPPER, ETC. -C TR CONVERT DATA AT A RATE OF 5.4 MILLION CHARACTERS PER SEC. -C TR IS IN LIBRARY /USR/LIB/LIBCOS.A ADD TO SEGLDR CARD. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/864 -C -C$$$ -C - INTEGER(8) IEBCDC(32) -C - CHARACTER*1 NFLD(*) - CHARACTER*1 EBCDIC(0:255) -C - SAVE -C - EQUIVALENCE (IEBCDC(1),EBCDIC(0)) -C -C*** EBCDIC CONTAINS HEX. REPRESENTATION OF EBCDIC CHARACTERS -C -C DATA IEBCDC/ -C & X'00010203372D2E2F',X'1605250B0C0D0E0F', -C & X'101112003C3D3226',X'18193F2722003500', -C & X'405A7F7B5B6C507D',X'4D5D5C4E6B604B61', -C & X'F0F1F2F3F4F5F6F7',X'F8F97A5E4C7E6E6F', -C & X'7CC1C2C3C4C5C6C7',X'C8C9D1D2D3D4D5D6', -C & X'D7D8D9E2E3E4E5E6',X'E7E8E9ADE0BD5F6D', -C & X'7981828384858687',X'8889919293949596', -C & X'979899A2A3A4A5A6',X'A7A8A9C06AD0A107', -C & 16*X'4040404040404040'/ -C -C THIS TABLE IS THE SAME AS HDS ASSEMBLER VERSION -C - DATA IEBCDC/ - & X'007D006C000000E0',X'00657C66004C0000', - & X'0000000000000000',X'0000000000005B00', - & X'40D07F7B5000506E',X'4D5D5C4F6B604B61', - & X'F0F1F2F3F4F5F6F7',X'F8F90000007E00C0', - & X'64C1C2C3C4C5C6C7',X'C8C9D1D2D3D4D5D6', - & X'D7D8D9E2E3E4E5E6',X'E7E8E90062636D00', - & X'0000000000000000',X'0000000000000000', - & X'0000000000000000',X'000000000000005F', - & 16 * X'0000000000000000'/ -C - IF (N .LE. 0) RETURN -C -C*** CONVERT STRING ... ASCII TO EBCDIC, N CHARACTERS -C - DO 20 J = 1, N - NFLD(J) = EBCDIC(mova2i(NFLD(J))) - 20 CONTINUE -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ai40.f b/src/fim/FIMsrc/w3/w3ai40.f deleted file mode 100644 index 68a738d..0000000 --- a/src/fim/FIMsrc/w3/w3ai40.f +++ /dev/null @@ -1,101 +0,0 @@ - SUBROUTINE W3AI40(KFLD,KOUT,KLEN,KNUM,KOFF) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK *** -C . . . . -C SUBPROGRAM: W3AI41 CONSTANT SIZE BINARY STRING PACKER -C PRGMMR: ALLARD, R. ORG: W342 DATE: 80-04-01 -C -C -C ABSTRACT: PACKS CONSTANT SIZE BINARY STRINGS INTO AN ARRAY. THIS -C PACKING REPLACES BITS IN THE PART OF THE OUTPUT ARRAY INDICATED -C BY THE OFFSET VALUE. W3AI40 IS THE REVERSE OF W3AI41. (SEE W3AI32 -C TO PACK VARIABLE SIZE BINARY STRINGS.) -C -C PROGRAM HISTORY LOG: -C 80-04-01 R.ALLARD (ORIGINAL AUTHOR) ASMEMBLER LANGUAGE VERSION. -C 84-07-05 R.E.JONES RECOMPILED FOR NAS-9050 -C 89-11-04 R.E.JONES WROTE FORTRAN VERSION OF W3AI40 TO PACK -C CONSTANT SIZE BINARY STRINGS -C 89-11-05 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C 98-03-10 B. VUONG REMOVE THE CDIR$ INTEGER=64 DIRECTIVE -C -C USAGE: CALL W3AI40 (KFLD,KOUT,KLEN,KNUM,KOFF) -C -C INPUT: -C KFLD - INTEGER INPUT ARRAY OF RIGHT ADJUSTED STRINGS -C KLEN - INTEGER NUMBER OF BITS PER STRING (0 < KLEN < 33) -C KNUM - INTEGER NUMBER OF STRINGS IN 'KFLD' TO PACK -C KOFF - INTEGER NUMBER SPECIFYING THE BIT OFFSET OF THE -C FIRST OUTPUT STRING. THE OFFSET VALUE IS RESET TO -C INCLUDE THE LOW ORDER BIT OF THE LAST PACKED STRING -C OUTPUT: -C KOUT - INTEGER OUTPUT ARRAY TO HOLD PACKED STRING(S) -C -C EXIT STATES: -C ERROR - KOFF < 0 IF KLEN HAS AN ILLEGAL VALUE OR KNUM < 1 -C THEN KOUT HAS NO STRINGS STORED. -C -C EXTERNAL REFERENCES: NONE -C -C REMARKS: THIS SUBROUTINE SHOULD BE WRITTEN IN ASSEMBLER LANGUAGE. -C THE FORTRAN VERSION RUNS TWO OR THREE TIMES SLOWER THAN THE ASEMBLER -C VERSION. THE FORTRAN VERSION CAN BE CONVERTED TO RUN ON OTHER -C COMPUTERS WITH A FEW CHANGES. THE BIT MANIPULATION FUNCTIONS ARE THE -C SAME IN IBM370 VS FORTRAN 4.1, MICROSOFT FORTRAN 4.10, VAX FORTRAN. -C MOST MODERN FORTRAN COMPILER HAVE AND, OR, SHIFT FUNCTIONS. IF YOU -C ARE RUNNING ON A PC, VAX AND YOUR INPUT WAS MADE ON A IBM370, APOLLO -C SUN, H.P.. ETC. YOU MAY HAVE TO ADD MORE CODE TO REVERSE THE ORDER O -C BYTES IN AN INTEGER WORD. NCAR SBYTES CAN BE USED INSTEAD OF THIS -C SUBROUTINE. PLEASE USE NCAR SBYTES SUBROUTINE INSTEAD OF THIS -C SUBROUTINE. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - INTEGER KFLD(*) - INTEGER KOUT(*) - INTEGER BIT - INTEGER OFFSET - INTEGER WRD -C - DATA MASK /-1/ -C - OFFSET = KOFF - IF (OFFSET.LT.0) RETURN - IF (KLEN.GT.64.OR.KLEN.LT.1) THEN - KOFF = -1 - RETURN - ENDIF -C - IF (KNUM.LT.1) THEN - KOFF = -1 - RETURN - ENDIF -C - JCOUNT = 64 - KLEN - LENGTH = KLEN - MASKWD = ISHFT(MASK,JCOUNT) -C - DO 100 I = 1,KNUM - WRD = ISHFT(OFFSET,-6) + 1 - BIT = MOD(OFFSET,64) - MASK8 = NOT(ISHFT(MASKWD,-BIT)) - OFFSET = OFFSET + LENGTH - JTEMP = IAND(KOUT(WRD),MASK8) - NCOUNT = 64 - BIT - IF (NCOUNT.LT.LENGTH) THEN - MASK9 = NOT(ISHFT(MASKWD,NCOUNT)) - NTEMP = IAND(KOUT(WRD+1),MASK9) - ENDIF - ITEMP = ISHFT(ISHFT(KFLD(I),JCOUNT),-BIT) - KOUT(WRD) = IOR(ITEMP,JTEMP) - IF (NCOUNT.LT.LENGTH) THEN - ITEMP = ISHFT(KFLD(I),(JCOUNT+NCOUNT)) - KOUT(WRD+1) = IOR(ITEMP,NTEMP) - ENDIF - 100 CONTINUE - KOFF = OFFSET - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ai41.f b/src/fim/FIMsrc/w3/w3ai41.f deleted file mode 100644 index d26fcf9..0000000 --- a/src/fim/FIMsrc/w3/w3ai41.f +++ /dev/null @@ -1,90 +0,0 @@ - SUBROUTINE W3AI41(KFLD,KOUT,KLEN,KNUM,KOFF) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK *** -C . . . . -C SUBPROGRAM: W3AI41 CONSTANT SIZE BINARY STRING UNPACKER -C PRGMMR: ALLARD, R. ORG: W342 DATE: 80-04-01 -C -C ABSTRACT: UNPACK CONSECUTIVE BINARY STRINGS OF THE SAME SIZE FROM -C ONE USER SUPPLIED ARRAY AND STORE THEM IN THE SAME ORDER RIGHT -C ALIGNED IN ANOTHER ARRAY. W3AI41 IS THE REVERSE OF W3AI40. (SEE -C -C PROGRAM HISTORY LOG: -C 80-04-01 R.ALLARD (ORIGINAL AUTHOR) ASMEMBLER LANGUAGE VERSION. -C 84-07-05 R.E.JONES RECOMPILED FOR NAS-9050 -C 88-07-05 R.E.JONES WROTE FORTRAN VERSION OF W3AI41 TO UNPACK -C VARIABLE SIZE BINARY STRINGS, ADDED CODE TO -C REVERSE ORFER OF BYTES. -C 89-11-04 R.E.JONES CONVERT TO CRAF CFT77 FORTRAN -C 98-03-10 B. VUONG REMOVE THE CDIR$ INTEGER=64 DIRECTIVE -C -C USAGE: CALL W3AI41 (KFLD, KOUT, KLEN, KNUM, KOFF) -C -C INPUT: -C KFLD - INTEGER ARRAY CONTINING BINARY STRING(S) -C KLEN - INTEGER NUMBER OF BITS PER STRING (0 < KLEN < 65) -C KNUM - INTEGER NUMBER OF STRINGS TO UNPACK. THIS VALUE MUST -* NOT EXCEED THE DIMENSION OF 'KOUT'. -C KOFF - INTEGER NUMBER SPECIFYING THE BIT OFFSET OF THE -C FIRST STRING 'KFLD'. THE OFFSET VALUE IS RESET TO -C INCLUDE THE LOW ORDER BIT OF THE LAST STRING UNPACKED -C ('KOFF' > 0 ) -C OUTPUT: -C KOUT - INTEGER*4 ARRAY HOLDING UNPACKED STRING(S) -C -C EXIT STATES: -C ERROR - 'KOFF' < 0 IF 'KLEN' HAS AN ILLEGAL VALUE OR 'KNUM' < 1 -C THEN 'KOUT' HAS NO STRINGS STORED. -C -C EXTERNAL REFERENCES: NONE -C -C REMARKS: THIS SUBROUTINE SHOULD BE WRITTEN IN ASSEMBLER LANGUAGE. -C THE FORTRAN VERSION RUNS TWO OR THREE TIMES SLOWER THAN THE ASEMBLER -C VERSION. THE FORTRAN VERSION CAN BE CONVERTED TO RUN ON OTHER -C COMPUTERS WITH A FEW CHANGES. THE BIT MANIPULATION FUNCTIONS ARE THE -C SAME IN IBM370 VS FORTRAN 4.1, MICROSOFT FORTRAN 4.10, VAX FORTRAN. -C MOST MODERN FORTRAN COMPILER HAVE AND, OR, SHIFT FUNCTIONS. IF YOU -C ARE RUNNING ON A PC, VAX AND YOUR INPUT WAS MADE ON A IBM370, APOLLO -C SUN, H.P.. ETC. YOU MAY HAVE TO ADD MORE CODE TO REVERSE THE ORDER O -C BYTES IN AN INTEGER WORD. NCAR GBYTES CAN BE USED INSTEAD OF THIS -C SUBROUTINE. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - INTEGER KFLD(*) - INTEGER KOUT(*) - INTEGER BITSET - INTEGER OFFSET - INTEGER WRDSET -C - OFFSET = KOFF - IF (OFFSET.LT.0) RETURN - IF (KLEN.GT.64.OR.KLEN.LT.1) THEN - KOFF = -1 - RETURN - ENDIF -C - IF (KNUM.LT.1) THEN - KOFF = -1 - RETURN - ENDIF -C - JCOUNT = KLEN - 64 - LENGTH = KLEN -C - DO 100 I = 1,KNUM - WRDSET = ISHFT(OFFSET,-6) - BITSET = MOD(OFFSET,64) - ITEMP = KFLD(WRDSET+1) - NTEMP = KFLD(WRDSET+2) - ITEMP = ISHFT(ITEMP,BITSET) - NTEMP = ISHFT(NTEMP,BITSET-64) - KOUT(I) = ISHFT(IOR(ITEMP,NTEMP),JCOUNT) - OFFSET = OFFSET + LENGTH - 100 CONTINUE - KOFF = OFFSET - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3aq15.f b/src/fim/FIMsrc/w3/w3aq15.f deleted file mode 100644 index 0f423c9..0000000 --- a/src/fim/FIMsrc/w3/w3aq15.f +++ /dev/null @@ -1,66 +0,0 @@ - SUBROUTINE W3AQ15(ITIME, QDESCR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3AQ15 GMT TIME PACKER -C PRGMMR: R.E.JONES ORG: W/NMC421 DATE: 95-10-10 -C -C ABSTRACT: CONVERT 32 OR 64 BIT BINARY TIME (GMT) INTO A 16 BIT -C STRING AND STORE THESE 4 PACKED DECIMAL NUMBERS INTO BYTES -C 39 AND 40 OF THE OUTPUT ARRAY. -C -C PROGRAM HISTORY LOG: -C 83-12-12 B. STRUBLE (ORIGINAL AUTHOR) -C 84-07-06 R.E.JONES CHANGE TO IBM ASSEMBLER V 02 -C 95-10-16 R.E.JONES CHANGE TO FORTRAN FOR CRAY AND 32 BIT -C WORKSTATIONS -C -C USAGE: CALL W3AQ15(ITIME, QDESCR) -C INPUT ARGUMENT LIST: -C ITIME - INTEGER WORD CONTAINING TIME IN BINARY -C -C OUTPUT ARGUMENT LIST: -C QDESCR - ARRAY CONTAINING TRANSMISSION QUEUE DESCRIPTOR -C NOTE- TIME WILL BE PLACED IN 39 AND 40TH -C BYTE OF THIS ARRAY AS 4 (4 BIT) BCD. -C -C -C REMARKS: THE USER CAN OBTAIN THE CURRENT TIME IN GMT BY INVOCKING -C THE W3 LIBRARY ROUTINE W3FQ02 WHICH FILLS AN EIGHT WORD ARRAY -C WITH THE CURRENT DATE AND TIME. THE 5TH WORD FROM THIS ARRAY -C CONTAINS THE TIME WHICH CAN BE PASSED TO W3AQ15 AS THE -C INPUT PARAMETER-ITIME. -C -C -C EXAMPLE: -C -C INTEGER NTIME(8) -C CHARACTER * 80 QUEUE -C -C CALL W3FQ02(NTIME,0) -C CALL W3AQ15(NTIME(5),QUEUE) -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916/256, J916/2048. -C -C$$$ - INTEGER ITIME -C - CHARACTER * 80 QDESCR -C -C BYTES 39-40 HR/MIN TIME OF BULLETIN CREATION -C TWO BYTES AS 4 BIT BCD -C -C -C CONVERT INTO 4 BIT BCD -C - KA = ITIME / 1000 - KB = MOD(ITIME,1000) / 100 - KC = MOD(ITIME,100) / 10 - KD = MOD(ITIME,10) -C - QDESCR(39:39) = CHAR(KA * 16 + KB) - QDESCR(40:40) = CHAR(kC * 16 + KD) -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3as00.f b/src/fim/FIMsrc/w3/w3as00.f deleted file mode 100644 index 2618355..0000000 --- a/src/fim/FIMsrc/w3/w3as00.f +++ /dev/null @@ -1,315 +0,0 @@ - subroutine W3AS00(nch_parm,cparm,iret_parm) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3AS00 GET PARM FIELD FROM COMMAND-LINE -C PRGMMR: SHIMOMURA ORG: W/NMC41 DATE: 95-05-23 -C -C ABSTRACT: TO GET THE ONE COMMAND-LINE ARGUMENT WHICH STARTS WITH -C "PARM="; RETURNING THE PARM FIELD (WITHOUT THE KEYWORD "PARM=") -C AS A NULL-TERMINATED STRING IN THE CHARACTER STRING:CPARM. -C -C PROGRAM HISTORY LOG: -C 95-05-23 DAVID SHIMOMURA -C 98-03-10 B. VUONG REMOVE THE CDIR$ INTEGER=64 DIRECTIVE -C -C USAGE: CALL W3AS00(NCH_PARM, CPARM, iret_parm) -C 1 2 3 -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C (1.) NCH_PARM - NO. OF CHARACTERS IN THE PARM FIELD -C (2.) CPARM - C*(*) CPARM -- THE DESTINATION FOR THE PARMFIELD -C OBTAINED FROM THE COMMAND LINE; -C USER SHOULD DEFINE THE CHARACTER STRING FOR -C A SIZE .LE. 101-BYTES, WHICH WOULD BE -C BIG ENOUGH FOR THE 100-CHAR IBM LIMIT PLUS -C ONE EXTRA BYTE FOR MY NULL-TERMINATOR. -C -C (3.) iret_parm - RETURN CODE -C = 0; NORMAL RETURN -C = -1; ABNORMAL EXIT. THE USER HAS FAILED -C TO DEFINE THE CPARM DESTINATION -C AS A CHARACTER STRING. -C -C = +1; A WARNING: -C THE GIVEN ARG IN THE COMMAND LINE WAS -C TOO LONG TO FIT IN THE DESTINATION: CPARM, -C SO I HAVE TRUNCATED IT. -C -C = +2; A WARNING: NO ARGS AT ALL ON COMMAND LINE, -C SO I COULD NOT FETCH THE PARM FIELD. -C -C = +3; A WARNING: NO "PARM="-ARGUMENT EXISTS -C AMONG THE ARGS ON THE COMMAND LINE, -C SO I COULD NOT FETCH THE PARM FIELD. -C -C OUTPUT FILES: -C FT06F001 - SOME CHECKOUT PRINTOUT -C -C REMARKS: -C -C TO EMULATE THE IBM PARM FIELD, THE USER SHOULD KEY_IN ON THE -C COMMAND LINE: -C PARM='IN BETWEEN THE SINGLE_QUOTES IS THE PARM FIELD' -C WHAT IS RETURNED FROM W3AS00() FROM THE PARM= ARG IS -C THE PARM FIELD: WHICH STARTS WITH THE LOCATION BEYOND THE -C EQUAL_SIGN OF THE KEYWORD "PARM=", AND INCLUDES EVERYTHING -C WHICH WAS WITHIN THE BOUNDS OF THE SINGLE-QUOTE SIGNS. -C BUT THE QUOTE SIGNS THEMSELVES WILL DISAPPEAR; AND A NULL- -C TERMINATOR WILL BE ADDED. -C THE STARTING "PARM=" IS A KEY WORD FOR THE PARMS, AND SHOULD -C NOT BE USED TO START ANY OTHER ARGUMENT. -C -C CAUTION: I HAVE CHANGED THE CALL SEQUENCE BY ADDING A RETURN CODE -C -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN77 -C MACHINE: CRAY2 -C -C$$$ -C - integer kbytpwrd - parameter (kbytpwrd=8) - integer maxnbyt - parameter (maxnbyt=112) -C ... WHERE 112 CHARACTERS IS SIZE OF CWORK FOR 100 CHARACTERS -C ... WITHIN QUOTES + 'PARM=' + BACKSLASHES + LINEFEEDS - - integer maxnwrds - parameter (maxnwrds=maxnbyt/kbytpwrd) - -C ... call seq. args ... - INTEGER NCH_PARM - CHARACTER*(*) CPARM - integer iret_parm - -C -C ... FUNCTIONS ... - external lastch - integer lastch - external notrail - integer notrail -C ------------------------------------------------------------- - integer jwork(maxnwrds) - character*112 cwork - equivalence (jwork,cwork) - - integer(4) nargsinline,iargc,iar - integer nchars - integer lmt_txt - integer non_parm - - LOGICAL LPARMQQ - character*1 KLF - character*1 NULLCHR - character*1 lonech - -C . . . . . . . . S T A R T . . . . . . . . . . . . . . . . - - NULLCHR = char(0) - KLF = char(10) -C - iret_parm = 0 - non_parm = 0 - - LPARMQQ = .FALSE. - NCH_PARM = 0 - - lmt_dest = len(cparm) - write(6,103)lmt_dest - 103 format(1h ,'W3AS00: dimensioned size (in bytes) of dest strng=', - 1 I11) - if(lmt_dest .le. 0) then - write(6,105) - 105 format(1h ,'W3AS00:FAILED on undefined destination ', - 1 'character string: CPARM') - iret_parm = -1 - nch_parm = 0 - go to 999 - else if (lmt_dest .gt. 101) then - lmt_dest = 101 - endif - lmt_txt = lmt_dest - 1 - - cparm(1:lmt_dest) = ' ' - - narg_got = 0 -C - nargsinline = iargc() - - write(6,115) nargsinline - 115 format(1h ,'W3AS00: count of args found in command line =', I3) - - if(nargsinline .gt. 0) then -C ... to scan every argument, looking only for the Arg which -C ... starts with "PARM=" - do iar = 1,nargsinline - LPARMQQ = .FALSE. - - cwork(1:) = ' ' - - call getarg(iar,cwork) - - narg_got = narg_got + 1 - nchars = lastch(cwork) - - if(nchars .le. 0) then - write(6,125)iar - 125 format(1h ,'W3AS00:getarg() returned an empty arg for', - A ' no.',I3 ) - else -C ... SOME TEXT EXISTS IN THIS ARG ... -C ... DOES IT START WITH "PARM=" ??? - if((cwork(1:5) .EQ. 'PARM=') .OR. - 1 (cwork(1:5) .EQ. 'parm=') ) then - LPARMQQ = .TRUE. -C ... this arg is special case of PARM= -C ... which can include blanks, so cannot lastch() it ... - nchars = notrail(cwork) - endif -C ... iwdss = ((nchars-1)/kbytpwrd) + 1 -C ... where iwdss points to last word so I could hex dump -C ... that last word, to see if NULL is there -C ... There was no NULL; only blank fill. - IF(LPARMQQ) THEN -C ... FILTER OUT ANY BACKSLASH or LINE_FEED ... - ioutc = 0 - do inc = 6,nchars - if(ioutc .LT. lmt_txt) then - lonech = cwork(inc:inc) - if((lonech .EQ. '\\') .OR. - 1 (lonech .EQ. KLF)) then - else - ioutc = ioutc + 1 - cparm(ioutc:ioutc) = lonech - endif - else -C ... comes here if ioutc .GE. lmt_txt, -C ... so I cannot increment ioutc for this inc char -C ... so truncate the string at (1:ioutc) -C ... a warning be return-coded ... - iret_parm = +1 - go to 155 - endif - enddo - 155 continue - nch_parm = ioutc - np1 = nchars+1 - cparm(np1:np1) = NULLCHR - go to 999 -C ... jump out of DO when PARM has been processed ... - else -C ... this is .not. a PARM field, do nothing w/ those, - non_parm = non_parm + 1 - endif - - endif - enddo -C ... IF IT FALLS THRU BOTTOM OF DO, THEN IT DID NOT FIND -C ... THE PARM FIELD AMONG THE EXISTING ARGS - iret_parm = 3 - nch_parm = 0 - - ELSE -C ... COMES HERE IF nargsinline = 0, so there were no args at all - iret_parm = 2 - nch_parm = 0 - endif - go to 999 - - 999 continue - return - end - integer function lastch(str) -C ... lastch() ... to point to the last character of a character -C ... string -C ... String terminators are first BLANK or NULL character -C ... encountered. -C ... Caution: I will limit scan on LEN(str) -C so you must give me a character string. -C - - character*(*) str - - character*1 NULLCHR - character*1 BLANK -C - integer i - integer limit -C - NULLCHR = char(0) - BLANK = ' ' - limit = len(str) - i = 0 - do while(i .LT. limit .AND. str(i+1:i+1) .NE. NULLCHR - 1 .AND. str(i+1:i+1) .NE. BLANK) - i = i + 1 - enddo - - lastch = i - return - end - integer function notrail(str) -C ... mods for CRAY version 8-Dec-1994/dss -C -C ... notrail() ... to point to the last non-blank character of a -C ... character string (which can have leading -C blanks and intermediate blanks); but after -C ignoring all trailing blank characters. -C ... String terminators are last BLANK or first NULL -C ... character encountered. -C -C ... This differs from LASTCH() which stops on first -C ... BLANK encountered when scanning from the start; -C ... NOTRAIL() will scan backwards from the end of the -C ... string, skipping over trailing blanks, until the -C ... last non-blank character is hit. -C ... -C ... Caution: I will limit scan on LEN(str) -C so you must give me a character string. -C - - character*(*) str - - character*1 BLANK - parameter (BLANK = ' ') -C - integer i - integer limit - integer limitnl - character*1 NULLCHR -C - NULLCHR = char(0) - i = 0 - limitnl = 0 - limit = len(str) - if(limit .le. 0) go to 999 -C ... otherwise, at least one char len string ... - limitnl = index(str(1:limit),NULLCHR) - if(limitnl .le. 0) then -C ... no NULLCHR exists in str(1:limit) ... -C ... so go scan from limit - go to 300 - - else if(limitnl .eq. 1) then - go to 999 -C ... which jumped out w/ pointer=0 if NULL in first position - else -C ... a NULLCHR existed within str(1:limit); so -C ... I want to scan backwards from before that NULLCHR -C ... which is located at limitnl - limit = limitnl - 1 - endif - if(limit .le. 0) go to 999 - 300 continue -C ... otherwise, we have a string of at least one char to look at -C ... which has no NULLCHR in interval (1:limit) - i = limit - do while((i .GT. 0) .AND. (str(i:i) .EQ. BLANK)) - i = i - 1 - enddo - - 999 continue - notrail = i - return - end diff --git a/src/fim/FIMsrc/w3/w3ctzdat.f b/src/fim/FIMsrc/w3/w3ctzdat.f deleted file mode 100644 index 21010a3..0000000 --- a/src/fim/FIMsrc/w3/w3ctzdat.f +++ /dev/null @@ -1,63 +0,0 @@ -!----------------------------------------------------------------------- - subroutine w3ctzdat(ntz,idat,jdat) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: W3CTZDAT CHANGE THE TIME ZONE OF A DATE AND TIME -! AUTHOR: MARK IREDELL ORG: WP23 DATE: 98-01-05 -! -! ABSTRACT: THIS SUBPROGRAM CONVERTS AN NCEP ABSOLUTE DATE AND TIME -! TO ANOTHER TIME ZONE. -! -! PROGRAM HISTORY LOG: -! 98-01-05 MARK IREDELL -! -! USAGE: CALL W3CTZDAT(NTZ,IDAT,JDAT) -! -! INPUT VARIABLES: -! NTZ INTEGER NEW TIME ZONE DIFFERENTIAL FROM UTC -! IN SIGNED HH OR HHMM FORMAT -! (IF NTZ IS INVALID, NO CHANGE IS MADE.) -! IDAT INTEGER (8) NCEP ABSOLUTE DATE AND TIME -! (YEAR, MONTH, DAY, TIME ZONE, -! HOUR, MINUTE, SECOND, MILLISECOND) -! -! OUTPUT VARIABLES: -! JDAT INTEGER (8) NCEP ABSOLUTE DATE AND TIME -! (YEAR, MONTH, DAY, TIME ZONE, -! HOUR, MINUTE, SECOND, MILLISECOND) -! -! SUBPROGRAMS CALLED: -! IW3JDN COMPUTE JULIAN DAY NUMBER -! W3FS26 YEAR, MONTH, DAY FROM JULIAN DAY NUMBER -! W3REDDAT REDUCE A TIME INTERVAL TO A CANONICAL FORM -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! -!$$$ - integer idat(8),jdat(8) - real rinc1(5),rinc2(5) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! determine if the input time zone is in valid hh or hhmm format - if(ntz.gt.-24.and.ntz.lt.24) then - itz=ntz*100 - elseif(ntz.eq.mod(ntz/100,24)*100+mod(mod(ntz,100),60)/30*30) then - itz=ntz - else - itz=idat(4) - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! determine new time of day, putting into reduced form -! and possibly adjust the date as well - rinc1(1)=0 - rinc1(2)=idat(5)+itz/100-idat(4)/100 - rinc1(3)=idat(6)+mod(itz,100)-mod(idat(4),100) - rinc1(4)=idat(7) - rinc1(5)=idat(8) - call w3reddat(-1,rinc1,rinc2) - jldayn=iw3jdn(idat(1),idat(2),idat(3))+nint(rinc2(1)) - call w3fs26(jldayn,jdat(1),jdat(2),jdat(3),jdow,jdoy) - jdat(4)=itz - jdat(5:8)=nint(rinc2(2:5)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end diff --git a/src/fim/FIMsrc/w3/w3difdat.f b/src/fim/FIMsrc/w3/w3difdat.f deleted file mode 100644 index 1e76b6e..0000000 --- a/src/fim/FIMsrc/w3/w3difdat.f +++ /dev/null @@ -1,55 +0,0 @@ -!----------------------------------------------------------------------- - subroutine w3difdat(jdat,idat,it,rinc) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: W3DIFDAT RETURN A TIME INTERVAL BETWEEN TWO DATES -! AUTHOR: MARK IREDELL ORG: WP23 DATE: 98-01-05 -! -! ABSTRACT: THIS SUBPROGRAM RETURNS THE ELAPSED TIME INTERVAL FROM -! AN NCEP ABSOLUTE DATE AND TIME GIVEN IN THE SECOND ARGUMENT UNTIL -! AN NCEP ABSOLUTE DATE AND TIME GIVEN IN THE FIRST ARGUMENT. -! THE OUTPUT TIME INTERVAL IS IN ONE OF SEVEN CANONICAL FORMS -! OF THE NCEP RELATIVE TIME INTERVAL DATA STRUCTURE. -! -! PROGRAM HISTORY LOG: -! 98-01-05 MARK IREDELL -! -! USAGE: CALL W3DIFDAT(JDAT,IDAT,IT,RINC) -! -! INPUT VARIABLES: -! JDAT INTEGER (8) NCEP ABSOLUTE DATE AND TIME -! (YEAR, MONTH, DAY, TIME ZONE, -! HOUR, MINUTE, SECOND, MILLISECOND) -! IDAT INTEGER (8) NCEP ABSOLUTE DATE AND TIME -! (YEAR, MONTH, DAY, TIME ZONE, -! HOUR, MINUTE, SECOND, MILLISECOND) -! IT INTEGER RELATIVE TIME INTERVAL FORMAT TYPE -! (-1 FOR FIRST REDUCED TYPE (HOURS ALWAYS POSITIVE), -! 0 FOR SECOND REDUCED TYPE (HOURS CAN BE NEGATIVE), -! 1 FOR DAYS ONLY, 2 FOR HOURS ONLY, 3 FOR MINUTES ONLY, -! 4 FOR SECONDS ONLY, 5 FOR MILLISECONDS ONLY) -! -! OUTPUT VARIABLES: -! RINC REAL (5) NCEP RELATIVE TIME INTERVAL -! (DAYS, HOURS, MINUTES, SECONDS, MILLISECONDS) -! (TIME INTERVAL IS POSITIVE IF JDAT IS LATER THAN IDAT.) -! -! SUBPROGRAMS CALLED: -! IW3JDN COMPUTE JULIAN DAY NUMBER -! W3REDDAT REDUCE A TIME INTERVAL TO A CANONICAL FORM -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! -!$$$ - integer jdat(8),idat(8) - real rinc(5) - real rinc1(5) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! difference the days and time and put into canonical form - rinc1(1)=iw3jdn(jdat(1),jdat(2),jdat(3))- - & iw3jdn(idat(1),idat(2),idat(3)) - rinc1(2:5)=jdat(5:8)-idat(5:8) - call w3reddat(it,rinc1,rinc) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end diff --git a/src/fim/FIMsrc/w3/w3doxdat.f b/src/fim/FIMsrc/w3/w3doxdat.f deleted file mode 100644 index b36ad7c..0000000 --- a/src/fim/FIMsrc/w3/w3doxdat.f +++ /dev/null @@ -1,40 +0,0 @@ -!----------------------------------------------------------------------- - subroutine w3doxdat(idat,jdow,jdoy,jday) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: W3DOXDAT RETURN WEEK DAY, YEAR DAY, AND JULIAN DAY -! AUTHOR: MARK IREDELL ORG: WP23 DATE: 98-01-05 -! -! ABSTRACT: THIS SUBPROGRAM RETURNS THE INTEGER DAY OF WEEK, THE DAY -! OF YEAR, AND JULIAN DAY GIVEN AN NCEP ABSOLUTE DATE AND TIME. -! -! PROGRAM HISTORY LOG: -! 98-01-05 MARK IREDELL -! -! USAGE: CALL W3DOXDAT(IDAT,JDOW,JDOY,JDAY) -! -! INPUT VARIABLES: -! IDAT INTEGER (8) NCEP ABSOLUTE DATE AND TIME -! (YEAR, MONTH, DAY, TIME ZONE, -! HOUR, MINUTE, SECOND, MILLISECOND) -! -! OUTPUT VARIABLES: -! JDOW INTEGER DAY OF WEEK (1-7, WHERE 1 IS SUNDAY) -! JDOY INTEGER DAY OF YEAR (1-366, WHERE 1 IS JANUARY 1) -! JDAY INTEGER JULIAN DAY (DAY NUMBER FROM JAN. 1,4713 B.C.) -! -! SUBPROGRAMS CALLED: -! IW3JDN COMPUTE JULIAN DAY NUMBER -! W3FS26 YEAR, MONTH, DAY FROM JULIAN DAY NUMBER -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! -!$$$ - integer idat(8) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! get julian day and then get day of week and day of year - jday=iw3jdn(idat(1),idat(2),idat(3)) - call w3fs26(jday,jy,jm,jd,jdow,jdoy) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end diff --git a/src/fim/FIMsrc/w3/w3fa01.f b/src/fim/FIMsrc/w3/w3fa01.f deleted file mode 100644 index 215d26e..0000000 --- a/src/fim/FIMsrc/w3/w3fa01.f +++ /dev/null @@ -1,100 +0,0 @@ - SUBROUTINE W3FA01(P,T,RH,TD,PLCL,TLCL) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FA01 COMPUTE LIFTING CONDENDSATION LEVEL -C AUTHOR: HOWCROFT,J. ORG: W/NMC342 DATE: 79-07-01 -C -C ABSTRACT: GIVEN THE PRESSURE, TEMPERATURE AND RELATIVE HUMIDITY OF -C AN AIR PARCEL AT SOME POINT IN THE ATMOSPHERE, CALCULATE THE -C DEWPOINT TEMPERATURE AND THE PRESSURE AND TEMPERATURE OF THE -C LIFTING CONDENSATION LEVEL. -C -C PROGRAM HISTORY LOG: -C 79-07-01 J.HOWCROFT -C 89-01-24 R.E.JONES CHANGE TO MICROSOFT FORTRAN 4.10 -C 90-06-11 R.E.JONES CHANGE TO SUN FORTRAN 1.3 -C 91-03-29 R.E.JONES CONVERT TO SiliconGraphics FORTRAN -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C 95-09-25 R.E.JONES PUT IN CRAY W3 LIBRARY -C -C USAGE: CALL W3FA01(P,T,RH,TD,PLCL,TLCL) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C P ARG LIST PARCEL PRESSURE IN MILLIBARS -C T ARG LIST PARCEL TEMPERATURE IN DEGREES CELSIUS -C RH ARG LIST PARCEL RELATIVE HUMIDITY IN PERCENT -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C TD ARG LIST DEWPOINT TEMPERATURE IN DEGREES CELSIUS -C PLCL ARG LIST PRESSURE OF LCL IN MILLIBARS -C TLCL ARG LIST TEMPERATURE AT LCL IN DEGREES CELSIUS -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C ABS ALOG ALOG10 EXP SYSLIB -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916/256, J916/2048 -C -C$$$ -C - SAVE -C -C DEFINITION OF THE POTENTIAL TEMPERATURE -C - POTEMP(T,P) = (T+273.16)*((1000./P)**0.2857) -C -C TETENS FORMULA WITH NATURAL BASE -C - VAPRES(T) = 6.11*EXP((17.2694*T)/(T+237.3)) -C -C BEGIN -C - IF (RH.LT.100) GO TO 10 - PLCL = P - TLCL = T - TD = T - GO TO 40 -C -C CALCULATE DEW POINT FROM RH AND T -C - 10 CONTINUE - AR = ALOG(RH*0.01)/17.269 - TD = (-237.3*(AR+1.0)*T - AR*237.3**2)/(AR*T+237.3*(AR-1.0)) - E = VAPRES(TD) - W = (0.622*E)/(P-E) - THETA = POTEMP(T,P) -C -C DO STACKPOLE'S THING AS IN JOUR APPL MET, VOL 6, PP 464-467. -C - EPS = 0.1 - CGES = 0.5 -C -C CONSTANTS -35.86 = 237.30 - 273.16 -C 2048.7 = 273.16 * 7.50 -C - PGES = (((CGES*(-35.86)+2048.7)/(THETA*(7.5-CGES)))**3.5)*1000. -C -C START ITERATION. -C - 20 CONTINUE - CGES = ALOG10((PGES*W)/(6.11*(0.622+W))) - PLCL = (((CGES*(-35.86)+2048.7)/(THETA*(7.5-CGES)))**3.5)*1000. - IF (ABS(PLCL-PGES) .LT. EPS) GO TO 30 - PGES = PLCL - GO TO 20 -C - 30 CONTINUE - TLCL = (CGES * 237.3) / (7.5 - CGES) -C -C FALL THRU WITH P,T OF THE LIFTED CONDENSATION LEVEL. -C - 40 CONTINUE - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fa03.f b/src/fim/FIMsrc/w3/w3fa03.f deleted file mode 100644 index 1ad898d..0000000 --- a/src/fim/FIMsrc/w3/w3fa03.f +++ /dev/null @@ -1,82 +0,0 @@ - SUBROUTINE W3FA03(PRESS,HEIGHT,TEMP,THETA) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FA03 COMPUTE STANDARD HEIGHT, TEMP, AND POT TEMP -C PRGMMR: KEYSER ORG: W/NMC22 DATE: 92-06-29 -C -C ABSTRACT: COMPUTES THE STANDARD HEIGHT, TEMPERATURE, AND POTENTIAL -C TEMPERATURE GIVEN THE PRESSURE IN MILLIBARS ( > 8.68 MB ). FOR -C HEIGHT AND TEMPERATURE THE RESULTS DUPLICATE THE VALUES IN THE -C U.S. STANDARD ATMOSPHERE (L962), WHICH IS THE ICAO STANDARD -C ATMOSPHERE TO 54.7487 MB (20 KM) AND THE PROPOSED EXTENSION TO -C 8.68 MB (32 KM). FOR POTENTIAL TEMPERATURE A VALUE OF 2/7 IS -C USED FOR RD/CP. -C -C PROGRAM HISTORY LOG: -C 74-06-01 J. MCDONELL W345 -- ORIGINAL AUTHOR -C 84-06-01 R.E.JONES W342 -- CHANGE TO IBM VS FORTRAN -C 92-06-29 D. A. KEYSER W/NMC22 -- CONVERT TO CRAY CFT77 FORTRAN -C -C USAGE: CALL W3FA03(PRESS,HEIGHT,TEMP,THETA) -C INPUT ARGUMENT LIST: -C PRESS - PRESSURE IN MILLIBARS -C -C OUTPUT ARGUMENT LIST: -C HEIGHT - HEIGHT IN METERS -C TEMP - TEMPERATURE IN DEGREES KELVIN -C THETA - POTENTIAL TEMPERATURE IN DEGREES KELVIN -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C CRAY - ALOG -C -C -C REMARKS: NOT VALID FOR PRESSURES LESS THAN 8.68 MILLIBARS, DECLARE -C ALL PARAMETERS AS TYPE REAL. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - REAL M0 -C - SAVE -C - DATA G/9.80665/,RSTAR/8314.32/,M0/28.9644/,PISO/54.7487/, - $ ZISO/20000./,SALP/-.0010/,PZERO/1013.25/,T0/288.15/,ALP/.0065/, - $ PTROP/226.321/,TSTR/216.65/ -C - ROVCP = 2.0/7.0 - R = RSTAR/M0 - ROVG = R/G - FKT = ROVG * TSTR - AR = ALP * ROVG - PP0 = PZERO**AR - IF(PRESS.LT.PISO) GO TO 100 - IF(PRESS.GT.PTROP) GO TO 200 -C -C COMPUTE ISOTHERMAL CASES -C - HEIGHT = 11000.0 + (FKT * ALOG(PTROP/PRESS)) - TEMP = TSTR - GO TO 300 -C -C COMPUTE LAPSE RATE = -.0010 CASES -C - 100 CONTINUE - AR = SALP * ROVG - PP0 = PISO**AR - HEIGHT = ((TSTR/(PP0 * SALP )) * (PP0-(PRESS ** AR))) + ZISO - TEMP = TSTR - ((HEIGHT - ZISO) * SALP) - GO TO 300 -C - 200 CONTINUE - HEIGHT = (T0/(PP0 * ALP)) * (PP0 - (PRESS ** AR)) - TEMP = T0 - (HEIGHT * ALP) -C - 300 CONTINUE - THETA = TEMP * ((1000./PRESS)**ROVCP) - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fa03v.f b/src/fim/FIMsrc/w3/w3fa03v.f deleted file mode 100644 index ee66f07..0000000 --- a/src/fim/FIMsrc/w3/w3fa03v.f +++ /dev/null @@ -1,95 +0,0 @@ - SUBROUTINE W3FA03V(PRESS,HEIGHT,TEMP,THETA,N) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FA03V COMPUTE STANDARD HEIGHT, TEMP, AND POT TEMP -C PRGMMR: KEYSER ORG: W/NMC22 DATE: 92-06-29 -C -C ABSTRACT: COMPUTES THE STANDARD HEIGHT, TEMPERATURE, AND POTENTIAL -C TEMPERATURE GIVEN THE PRESSURE IN MILLIBARS ( > 8.68 MB ). FOR -C HEIGHT AND TEMPERATURE THE RESULTS DUPLICATE THE VALUES IN THE -C U.S. STANDARD ATMOSPHERE (L962), WHICH IS THE ICAO STANDARD -C ATMOSPHERE TO 54.7487 MB (20 KM) AND THE PROPOSED EXTENSION TO -C 8.68 MB (32 KM). FOR POTENTIAL TEMPERATURE A VALUE OF 2/7 IS -C USED FOR RD/CP. -C -C PROGRAM HISTORY LOG: -C 74-06-01 J. MCDONELL W345 -- ORIGINAL AUTHOR -C 84-06-01 R.E.JONES W342 -- CHANGE TO IBM VS FORTRAN -C 92-06-29 D. A. KEYSER W/NMC22 -- CONVERT TO CRAY CFT77 FORTRAN -C 94-09-13 R.E.JONES -- VECTORIZED VERSION TO DO ARRAY -C INSTEAD OF ONE WORD -C -C USAGE: CALL W3FA03V(PRESS,HEIGHT,TEMP,THETA,N) -C INPUT ARGUMENT LIST: -C PRESS - PRESSURE ARRAY IN MILLIBARS -C -C OUTPUT ARGUMENT LIST: -C HEIGHT - HEIGHT ARRAY IN METERS -C TEMP - TEMPERATURE ARRAY IN DEGREES KELVIN -C THETA - POTENTIAL TEMPERATURE ARRAY IN DEGREES KELVIN -C N - NUMBER OF POINTS IN ARRAY PRESS -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C CRAY - ALOG -C -C REMARKS: NOT VALID FOR PRESSURES LESS THAN 8.68 MILLIBARS, DECLARE -C ALL PARAMETERS AS TYPE REAL. -C -C WARNING: HEIGHT, TEMP, THETA ARE NOW ALL ARRAYS, YOU MUST -C HAVE ARRAYS OF SIZE N OR YOU WILL WIPE OUT MEMORY. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916/128, Y-MP8/864, Y-MP EL92/256 -C -C$$$ -C - REAL M0 - REAL HEIGHT(*) - REAL PRESS(*) - REAL TEMP(*) - REAL THETA(*) -C - SAVE -C - DATA G/9.80665/,RSTAR/8314.32/,M0/28.9644/,PISO/54.7487/, - $ ZISO/20000./,SALP/-.0010/,PZERO/1013.25/,T0/288.15/,ALP/.0065/, - $ PTROP/226.321/,TSTR/216.65/ -C - ROVCP = 2.0/7.0 - R = RSTAR/M0 - ROVG = R/G - FKT = ROVG * TSTR - AR = ALP * ROVG - PP0 = PZERO**AR - AR1 = SALP * ROVG - PP01 = PISO**AR1 -C - DO J = 1,N - IF (PRESS(J).LT.PISO) THEN -C -C COMPUTE LAPSE RATE = -.0010 CASES -C - HEIGHT(J) = ((TSTR/(PP01 * SALP )) * (PP01-(PRESS(J) ** AR1))) - & + ZISO - TEMP(J) = TSTR - ((HEIGHT(J) - ZISO) * SALP) -C - ELSE IF (PRESS(J).GT.PTROP) THEN -C - HEIGHT(J) = (T0/(PP0 * ALP)) * (PP0 - (PRESS(J) ** AR)) - TEMP(J) = T0 - (HEIGHT(J) * ALP) -C - ELSE -C -C COMPUTE ISOTHERMAL CASES -C - HEIGHT(J) = 11000.0 + (FKT * ALOG(PTROP/PRESS(J))) - TEMP(J) = TSTR -C - END IF - THETA(J) = TEMP(J) * ((1000./PRESS(J))**ROVCP) - END DO -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fa04.f b/src/fim/FIMsrc/w3/w3fa04.f deleted file mode 100644 index dde3c00..0000000 --- a/src/fim/FIMsrc/w3/w3fa04.f +++ /dev/null @@ -1,95 +0,0 @@ - SUBROUTINE W3FA04(HEIGHT,PRESS,TEMP,THETA) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FA04 COMPUTE STADARD PRESSURE, TEMP, POT TEMP -C AUTHOR: MCDONELL, J. ORG: W345 DATE: JUL 74 -C -C ABSTRACT: COMPUTES THE STANDARD PRESSURE, TEMPERATURE, AND POTEN- -C TIAL TEMPERATURE GIVEN THE HEIGHT IN METERS ( < 32 KM ). FOR -C THE PRESSURE AND TEMPERATURE THE RESULTS DUPLICATE THE VALUES IN -C THE U.S. STANDARD ATMOSPHERE (1962), WHICH IS THE ICAO STANDARD -C ATMOSPHERE TO 54.7487 MB (20 KM) AND THE PROPOSED EXTENSION TO -C 8.68 MB (32 KM). FOR POTENTIAL TEMPERATURE A VALUE OF 2/7 IS -C USED FOR RD/CP. -C -C PROGRAM HISTORY LOG: -C 74-06-01 J.MCDONELL -C 84-07-05 R.E.JONES CHANGE TO IBM VS FORTRAN -C 90-04-27 R.E.JONES CHANGE TO CRAY CFT77 FORTRAN -C -C USAGE: CALL W3FA04 (HEIGHT, PRESS, TEMP, THETA) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C HEIGHT ARG LIST HEIGHT IN METERS -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C PRESS ARG LIST STANDARD PRESSURE IN MILLIBARS -C TEMP ARG LIST TEMPERATURE IN DEGREES KELVIN -C THETA ARG LIST POTENTIAL TEMPERATURE IN DEGREES KELVIN -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C EXP SYSTEM -C -C REMARKS: NOT VALID FOR HEIGHTS GREATER THAN 32 KM. -C DECLARE ALL PARAMETERS AS TYPE REAL*4 -C -C ATTRIBUTES: -C LANGUAGE: INCLUDE VENDOR EXTENSIONS USED. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP/832 -C -C$$$ -C - REAL M0 -C - DATA - *G /9.80665/, - *RSTAR /8314.32/, - *M0 /28.9644/, - *PISO /54.7487/, - *ZISO /20000./, - *SALP /-.0010/, - *TSTR /216.65/, - *PTROP /226.321/, - *ALP /.0065/, - *T0 /288.15/, - *PZERO /1013.25/ -C - ROVCP = 2.0 / 7.0 - R = RSTAR/M0 - IF (HEIGHT.GT.ZISO) GO TO 100 - IF (HEIGHT.GT.11000.) GO TO 200 -C -C COMPUTE IN TROPOSPHERE -C - TEMP = T0 - HEIGHT * ALP - PRESS = PZERO * ((1.0 - ((ALP/T0) * HEIGHT)) ** (G/(ALP * R))) - GO TO 300 -C -C COMPUTE LAPSE RATE = -.0010 CASES -C - 100 CONTINUE - D = HEIGHT - ZISO - PRESS = PISO * ((1.-(( SALP /TSTR) * D )) ** (G/( SALP * R))) - TEMP = TSTR - D * SALP - GO TO 300 -C -C COMPUTE ISOTHERMAL CASES -C - 200 CONTINUE - D = EXP((HEIGHT - 11000.0) / ((R / G) * TSTR)) - PRESS = PTROP / D - TEMP = TSTR -C - 300 CONTINUE - THETA = TEMP * ((1000.0 / PRESS) ** ROVCP) - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fa06.f b/src/fim/FIMsrc/w3/w3fa06.f deleted file mode 100644 index b1ee15d..0000000 --- a/src/fim/FIMsrc/w3/w3fa06.f +++ /dev/null @@ -1,126 +0,0 @@ - SUBROUTINE W3FA06 (P,T,RH,T5,TLI) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FA06 CALCULATION OF THE LIFTED INDEX -C AUTHOR: HOWCROFT,J. ORG: W/NMC342 DATE: 78-07-01 -C -C ABSTRACT: GIVEN THE PRESSURE,TEMPERATURE AND RELATIVE HUMIDITY OF -C AN AIR PARCEL AT SOME POINT IN THE ATMOSPHERE, CALCULATE THE -C LIFTED INDEX OF THE PARCEL. LIFTED INDEX IS DEFINED AS THE -C TEMPERATURE DIFFERENCE BETWEEN THE OBSERVED 500MB TEMPERATURE AND -C THE SUPPOSED TEMPERATURE THAT THE PARCEL WOULD OBTAIN IF IT WERE -C LIFTED DRY-ADIABATICALLY TO SATURATION AND THEN MOVED MOIST -C ADIABATICALLY TO THE 500MB LEVEL. -C -C PROGRAM HISTORY LOG: -C 78-07-01 J.HOWCROFT -C 89-01-24 R.E.JONES CHANGE TO MICROSOFT FORTRAN 4.10 -C 90-06-08 R.E.JONES CHANGE TO SUN FORTRAN 1.3 -C 91-03-29 R.E.JONES CONVERT TO SiliconGraphics FORTRAN -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C 95-09-25 R.E.JONES PUT IN W3 LIBRARY ON CRAY -C -C USAGE: CALL W3FA06(P,T,RH,T5,TLI) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C P ARG LIST PARCEL PRESSURE IN MILLIBARS -C T ARG LIST PARCEL TEMPERATAURE IN DEGREES CELSIUS -C RH ARG LIST PARCEL RELATIVE HUMIDITY IN PERCENT -C T5 ARG LIST TEMPERATURE AT THE 500MB LEVEL IN DEG. CELSIUS -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C TLI ARG LIST LIFTED INDEX IN DEGREES CELSIUS -C TLI = 9.9999 ITERATION DIVERGES; -C RETURN TO USER PROGRAM -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C EXP ABS SIGN SYSLIB -C W3FA01 W3LIB -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916/256, J916/2048 -C -C$$$ -C - SAVE -C - DATA EPS /0.5/ - DATA KOUT / 6/ -C - 300 FORMAT (' *** ITERATION NOT CONVERGING IN W3FA06 ***') - 350 FORMAT (' INPUT PARAMS ARE:',4F15.8,/ - 1 ' CALCULATIONS ARE',7E15.8) -C - POTEMP(T,P) = (T+273.16)*((1000./P)**0.2857) -C - EEP(T,P,ES) = EXP((596.73-0.601*T)*((0.622*ES)/(P-ES)) - 1 / (0.24*(T+273.16))) -C - UNPOT(TE,P) = (((P/1000.)**0.2857)*TE)-273.16 -C - VAPRES(T) = 6.11*EXP(17.2694*T/(T+237.3)) -C - CALL W3FA01 (P,T,RH,TD,PLCL,TLCL) - IF (PLCL .GT. 500.) GO TO 30 - IF (PLCL .LT. 500.) GO TO 20 - TLI = T5 - TLCL - GO TO 80 - 20 CONTINUE -C LCL IS ABOVE THE 500MB LVL - TLI = T5 - UNPOT((POTEMP(TLCL,PLCL)),500.) - GO TO 80 - 30 CONTINUE -C USE STACKPOLE ALGORITHM (JAM VOL 6/1967 PP 464-7) TO FIND TGES -C SO THAT (TGES,500) IS ON SAME MOIST ADIABAT AS (TLCL,PLCL). - ES = VAPRES(TLCL) - THD = POTEMP(TLCL,(PLCL-ES)) - THETA = THD * EEP(TLCL,PLCL,ES) -C THETA IS THE PSEUDO-EQUIV POTENTIAL TEMP THRU (PLCL,TLCL). -C NOW FIND TEMP WHERE THETA INTERSECTS 500MB SFC. -C INITIALIZE FOR STACKPOLIAN ITERATION - TGES = T5 - DTT = 10. - PIIN = 1./(0.5**0.2857) - A = 0. - ISTP = 0 -C START ITERATION. - 40 CONTINUE - ISTP = ISTP + 1 - IF (ISTP .GT. 200) GO TO 50 - SVA = VAPRES(TGES) - AX = A - A = (TGES+273.16)*PIIN * EEP(TGES,500.,SVA) - THETA - IF (ABS(A) .LT. EPS) GO TO 70 - DTT = DTT * 0.5 - IF (A*AX.LT.0.0) DTT = -DTT - TP = TGES + DTT - SVA = VAPRES(TP) - AP = (TP+273.16)*PIIN * EEP(TP,500.,SVA) - THETA - IF (ABS(AP) .LT. EPS) GO TO 60 -C FIND NEXT ESTIMATE, DTT IS ADJUSTMENT FROM OLD TO NEW TGES. - DTT = A*DTT/(A-AP) - IF (ABS(DTT).LT.0.01) DTT = SIGN(0.01,DTT) - TGES = TGES + DTT - IF (TGES .GT. 50) TGES = 50. - GO TO 40 -C - 50 CONTINUE -C DISASTER SECTION - WRITE (KOUT,300) - WRITE (KOUT,350) P,T,RH,T5,THETA,AX,A,AP,TGES,TP,SVA - TLI = 9.9999 - GO TO 80 - 60 CONTINUE - TGES = TP - 70 CONTINUE - TLI = T5 - TGES - 80 CONTINUE - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fa09.f b/src/fim/FIMsrc/w3/w3fa09.f deleted file mode 100644 index 05bd046..0000000 --- a/src/fim/FIMsrc/w3/w3fa09.f +++ /dev/null @@ -1,71 +0,0 @@ - REAL FUNCTION W3FA09 (TK) -C$$$ SUBROUTINE DOCUMENTATION BLOCK *** -C -C SUBR: W3FA09 - TEMPERATURE TO SATURATION VAPOR PRESSURE -C AUTHOR: CHASE, P. ORG: W345 DATE: OCT 78 -C UPDATE: JONES, R.E. ORG: W342 DATE: 26 JUN 84 -C -C ABSTRACT: COMPUTES SATURATION VAPOR PRESSURE IN KILOPASCALS GIVEN -C TEMPERATAURE IN KELVINS. -C -C PROGRAM HISTORY LOG: -C 78-10-01 P.CHASE -C 84-06-26 R.E.JONES CHANGE TO IBM VS FORTRAN -C 84-06-26 R.E.JONES CHANGE TO MICROSOFT FORTRAN 4.10 -C 90-06-08 R.E.JONES CHANGE TO SUN FORTRAN 1.3 -C 91-03-29 R.E.JONES CONVERT TO SiliconGraphic FORTRAN -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C 95-09-25 R.E.JONES CHANGE TK TO CRAY 64 BIT REAL, CHANGE DOUBLE -C PRECISION TO CRAY 64 BIT REAL. -C -C USAGE: VP = W3FA09 (TK) -C -C INPUT: -C 'TK' - REAL*8 TEMPERATURE IN KELVINS. IF TK < 223.16, THE VALUE -C 223.16 WILL BE USED. IF TK > 323.16, THE VALUE 323.16 -C WILL BE USED AS THE ARGUMENT. 'TK' ITSELF IS UNCHANGED. -C OUTPUT: -C 'VP' - SATURATION VAPOR PRESSURE IN KILOPASCALS. -C 0.0063558 < VP < 12.3395 -C -C NOTES: W3FA09 MAY BE DECLARED REAL*8 SO THAT A REAL*8 VALUE IS -C RETURNED, BUT NO INCREASE IN ACCURACY IS IMPLIED. -C -C EXIT STATES: NONE -C -C EXTERNAL REFERENCES: NONE -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916/256, J916/2048 -C -C$$$ -C -C THE CHEBYSHEV COEFFICIENTS ARE IN ARRAY C, LOW-ORDER TERM FIRST. -C - REAL C(9) - REAL ARG,H0,H1,H2 -C - SAVE -C - DATA C / - & 0.313732865927E+01, 0.510038215244E+01, 0.277816535655E+01, - & 0.102673379933E+01, 0.254577145215E+00, 0.396055201295E-01, - & 0.292209288468E-02,-0.119497199712E-03,-0.352745603496E-04/ -C -C SCALE TK TO RANGE -2, +2 FOR SERIES EVALUATION. INITIALIZE TERMS. -C - ARG = -1.09264E1+4.0E-2*AMAX1(223.16,AMIN1(323.16,TK)) - H0 = 0.0 - H1 = 0.0 -C -C EVALUATE CHEBYSHEV POLYNOMIAL -C - DO 10 I=1,9 - H2 = H1 - H1 = H0 - H0 = ARG * H1 - H2 + C(10-I) - 10 CONTINUE - W3FA09 = 0.5 * (C(1) - H2 + H0) - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fa11.f b/src/fim/FIMsrc/w3/w3fa11.f deleted file mode 100644 index 31c7abb..0000000 --- a/src/fim/FIMsrc/w3/w3fa11.f +++ /dev/null @@ -1,65 +0,0 @@ - SUBROUTINE W3FA11 (EPS,JCAP) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FA11 COMPUTES COEFFICIENTS FOR USE IN W3FA12 -C AUTHOR: SELA,JOE ORG: W342 DATE: 80-10-28 -C -C ABSTRACT: SUBROUTINE COMPUTES DOUBLE PRECISION COEFFICIENTS -C USED IN GENERATING LEGENDRE POLYNOMIALS IN SUBR. W3FA12. -C ON A CRAY DOUBLE PRECISION IS CHANGED TO REAL, DSQRT TO SQRT. -C -C PROGRAM HISTORY LOG: -C 80-10-28 JOE SELA -C 84-06-01 R.E.JONES CHANGE TO IBM VS FORTRAN -C 93-04-12 R.E.JONES CHANGES FOR CRAY, DOUBLE PRECISION TO REAL -C -C USAGE: CALL W3FA11 (EPS,JCAP) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C JCAP ARG LIST ZONAL WAVE NUMBER THIRTY, ETC. -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C EPS ARG LIST REAL COEFFICIENTS USED IN -C COMPUTING LEGENDRE POLYNOMIALS. -C DIMENSION OF EPS IS (JCAP+2)*(JCAP+1) -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C SQRT SYSTEM -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN 77 -C MACHINE: CRAY Y-MP8/864 -C -C*** -C - REAL EPS(*) - REAL A -C - SAVE -C - JCAP1 = JCAP + 1 - JCAP2 = JCAP + 2 -C - DO 100 LL = 1,JCAP1 - L = LL - 1 - JLE = (LL-1) * JCAP2 -C - DO 100 INDE = 2,JCAP2 - N = L + INDE - 1 - A=(N*N-L*L)/(4.0*N*N-1.0) - EPS(JLE+INDE) = SQRT(A) - 100 CONTINUE -C - DO 200 LL = 1,JCAP1 - JLE = (LL-1) * JCAP2 - EPS(JLE+1) = 0.0 - 200 CONTINUE -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fa12.f b/src/fim/FIMsrc/w3/w3fa12.f deleted file mode 100644 index 040a1be..0000000 --- a/src/fim/FIMsrc/w3/w3fa12.f +++ /dev/null @@ -1,89 +0,0 @@ - SUBROUTINE W3FA12(PLN,COLRAD,JCAP,EPS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FA12 COMPUTES LEGENDRE POLYNOMIALS -C AUTHOR: SELA,JOE ORG: W323 DATE: 80-10-28 -C -C ABSTRACT: SUBROUTINE COMPUTES LEGENDRE POLYNOMIALS AT A -C GIVEN LATITUDE. -C -C PROGRAM HISTORY LOG: -C 80-10-20 JOE SELA -C 84-06-01 R.E.JONES CHANGE TO IBM VS FORTRAN -C 93-04-12 R.E.JONES CHANGES FOR CRAY, DOUBLE PRECISION TO REAL -C -C USAGE: CALL W3FA12 (PLN,COLRAD,JCAP,EPS) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C COLRAD ARG LIST COLATITUDE IN RADIANS OF DESIRED POINT. -C JCAP ARG LIST FOR RHOMBOIADAL TRUNCATION OF ZONAL WAVE -C EPS ARG LIST COEFF. USED IN RECURSION EQUATION. -C DIMENSION OF EPS IS (JCAP+2)*(JCAP+1) -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C PLN ARG LIST REAL LOCATIONS CONTAIN LEGENDRE -C POLNOMIALS , SIZE IS (JCAP+2)*(JCAP+1) -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C COS SIN SNGL SYSTEM -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/864 -C -C*** -C - REAL A - REAL B - REAL COLRAD - REAL COS2 - REAL EPS(*) - REAL FL - REAL PROD - REAL P1 - REAL P2 - REAL P3 - REAL SINLAT - REAL PLN(*) -C - SAVE -C - SINLAT = COS(COLRAD) - COS2 = 1.0 - SINLAT * SINLAT - PROD = 1.0 - A = 1.0 - B = 0.0 - JCAP1 = JCAP+1 - JCAP2 = JCAP+2 -C - DO 300 LL = 1,JCAP1 - L = LL - 1 - FL = L - JLE = L * JCAP2 - IF (L.EQ.0) GO TO 100 - A = A + 2.0 - B = B + 2.0 - PROD = PROD * COS2 * A / B - 100 CONTINUE - P1 = SQRT (0.5 * PROD) - PLN(JLE+1) = P1 - P2 = SQRT(2.0 * FL + 3.0) * SINLAT * P1 - PLN(JLE+2) = P2 -C - DO 200 N = 3,JCAP2 - LINDEX = JLE + N - P3 = (SINLAT*P2 - EPS(LINDEX-1)*P1)/EPS(LINDEX) - PLN(LINDEX) = P3 - P1 = P2 - P2 = P3 -200 CONTINUE -300 CONTINUE - RETURN -C - END diff --git a/src/fim/FIMsrc/w3/w3fa13.f b/src/fim/FIMsrc/w3/w3fa13.f deleted file mode 100644 index 3144577..0000000 --- a/src/fim/FIMsrc/w3/w3fa13.f +++ /dev/null @@ -1,94 +0,0 @@ - SUBROUTINE W3FA13(TRIGS,RCOS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FA13 COMPUTES TRIG FUNCTIONS -C AUTHOR: SELA, JOE ORG: W323 DATE: 80-11-21 -C -C ABSTRACT: COMPUTES TRIG FUNCTIONS USED IN 2.5 BY 2.5 LAT,LON -C MAPPING ROUTINES. W3FA13 MUST BE CALLED AT LEAST ONCE BEFORE -C CALLS TO W3FT08,W3FT09,W3FT10,W3FT11. -C -C PROGRAM HISTORY LOG: -C 80-11-21 JOE SELA -C 84-06-01 R.E.JONES CHANGE TO VS FORTRAN -C -C USAGE: CALL W3FA13(TRIGS,RCOS) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C N/A -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C TRIGS ARG LIST 216 TRIG VALUES, USED BY SUBROUTINE W3FA12. -C RCOS ARG LIST 37 COLATITUDES USED BY SUBROUTINES W3FT09,W3FT11 -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C IABS SIN COS SYSTEM -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN 77 -C MACHINE: CRAY Y-MP8/864 -C -C$$$ -C - REAL RCOS(*) - REAL TRIGS(*) -C - SAVE -C - DATA PI /3.14159265358979323846/ -C - N = 144 - MODE = 3 - DRAD = 2.5*PI/180. -C - DO 100 LAT = 2,37 - ARG = (LAT-1)*DRAD - RCOS(LAT) = 1./SIN(ARG) - 100 CONTINUE -C - RCOS(1) = 77777.777 - IMODE = IABS(MODE) - NN = N - IF (IMODE.GT.1.AND.IMODE.LT.6) NN = N/2 - ANGLE = 0.0 - DEL = (PI+PI)/FLOAT(NN) - L = NN+NN -C - DO 200 I = 1,L,2 - TRIGS(I) = COS(ANGLE) - TRIGS(I+1) = SIN(ANGLE) - ANGLE = ANGLE+DEL - 200 CONTINUE -C - IF (IMODE.EQ.1) RETURN - IF (IMODE.EQ.8) RETURN - ANGLE = 0.0 - DEL = 0.5*DEL - NH = (NN+1)/2 - L = NH+NH - LA = NN+NN -C - DO 300 I = 1,L,2 - TRIGS(LA+I) = COS(ANGLE) - TRIGS(LA+I+1) = SIN(ANGLE) - ANGLE = ANGLE+DEL - 300 CONTINUE -C - IF (IMODE.LE.3) RETURN - DEL = 0.5*DEL - ANGLE = DEL - LA = LA+NN -C - DO 400 I = 2,NN - TRIGS(LA+I) = 2.0*SIN(ANGLE) - ANGLE = ANGLE+DEL - 400 CONTINUE -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fb00.f b/src/fim/FIMsrc/w3/w3fb00.f deleted file mode 100644 index 4bcfe42..0000000 --- a/src/fim/FIMsrc/w3/w3fb00.f +++ /dev/null @@ -1,64 +0,0 @@ - SUBROUTINE W3FB00(ALAT,ALONG,XMESHL,XI,XJ) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FB00 LATITUDE, LONGITUDE TO I,J -C AUTHOR: HEERMANN,A. ORG: W345 DATE: 69-08-01 -C -C ABSTRACT: CONVERTS THE COORDINATES OF A LOCATION ON EARTH FROM THE -C NATURAL COORDINATE SYSTEM OF LATITUDE/LONGITUDE TO THE GRID (I,J) -C COORDINATE SYSTEM OVERLAID ON THE POLAR STEREOGRAPHIC MAP PRO- -C JECTION TRUE AT 60 N. A PREFERABLE, MORE FLEXIBLE SUBROUTINE TO -C USE IS W3FB04. W3FB00 IS THE REVERSE OF W3FB01. -C -C PROGRAM HISTORY LOG: -C 69-08-01 A. HEERMANN -C 90-08-31 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C -C USAGE: CALL W3FB00 (ALAT, ALONG, XMESHL, XI, XJ) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C ALAT ARG LIST LATITUDE IN DEG. (-20.0(S. HEMIS) ) ALAT ) 90.0) -C ALONG WEST LONGITUDE IN DEGREES -C XMESHL ARG LIST MESH LENGTH OF GRID IN KILOMETERS AT 60N -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C XI ARG LIST I OF THE POINT RELATIVE TO NORTH POLE -C XJ ARG LIST J OF THE POINT RELATIVE TO NORTH POLE -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C COS SIN SYSLIB -C -C REMARKS: THE GRID USED IN THIS SUBROUTINE HAS ITS ORIGIN (I=0,J=0) -C AT THE NORTH POLE, SO IF THE USER'S GRID HAS ITS ORIGIN AT A -C POINT OTHER THAN THE NORTH POLE, A TRANSLATION IS REQUIRED TO -C GET I AND J. THE SUBROUTINE GRID IS ORIENTED SO THAT LONGITUDE -C 80W IS PARALLEL TO THE GRIDLINES OF I=CONSTANT. THE RADIUS OF -C THE EARTH IS TAKEN TO BE 6371.2 KM. -C ALL PARAMETERS IN THE CALL STATEMENT MUST BE REAL -C THIS CODE WILL NOT VECTORIZE ON A CRAY. YOU WILL HAVE PUT -C IT LINE TO VECTORIZE IT. -C -C ATTRIBUTES: -C LANGUAGE: IBM370 VS FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - DATA RADPD /.01745329/ - DATA EARTHR/6371.2/ -C - RE = (EARTHR * 1.86603) / XMESHL - XLAT = ALAT * RADPD - SINL = SIN(XLAT) - WLONG = (ALONG + 100.0) * RADPD - R = (RE * COS(XLAT)) / (1. + SINL) - XI = R * SIN(WLONG) - XJ = R * COS(WLONG) - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fb01.f b/src/fim/FIMsrc/w3/w3fb01.f deleted file mode 100644 index dfcce60..0000000 --- a/src/fim/FIMsrc/w3/w3fb01.f +++ /dev/null @@ -1,77 +0,0 @@ - SUBROUTINE W3FB01(XI,XJ,XMESHL,ALAT,ALONG) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FB01 I,J TO LATITUDE, LONGITUDE -C AUTHOR: HEERMANN,A. ORG: W345 DATE: 69-08-01 -C -C ABSTRACT: CONVERTS THE COORDINATES OF A LOCATION FROM THE GRID(I,J) -C COORDINATE SYSTEM OVERLAID ON THE POLAR STEREOGRAPHIC MAP PRO- -C JECTION TRUE AT 60 N TO THE NATURAL COORDINATE SYSTEM OF LATITUDE -C /LONGITUDE ON THE EARTH. A PREFERABLE MORE FLEXIBLE SUBROUTINE TO -C USE IS W3FB05. W3FB01 IS THE REVERSE OF W3FB00. -C -C PROGRAM HISTORY LOG: -C 69-08-01 A. HEERMANN -C 90-08-31 R.E.JONES CHANGE TO CRAY CFT77 FORTRAN -C -C USAGE: CALL W3FB01 (XI, XJ, XMESHL, ALAT, ALONG) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C XI ARG LIST I OF THE POINT RELATIVE TO NORTH POLE -C XJ ARG LIST J OF THE POINT RELATIVE TO NORTH POLE -C XMESHL ARG LIST MESH LENGTH OF GRID IN KILOMETERS AT 60N -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C ALAT ARG LIST LATITUDE IN DEG. (-20.0(S. HEMIS) < ALAT < 90.0) -C ALONG ARG LIST WEST LONGITUDE IN DEGREES -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C ASIN ATAN2 SYSLIB -C -C REMARKS: THE GRID USED IN THIS SUBROUTINE HAS ITS ORIGIN (I=0,J=0) -C AT THE NORTH POLE, SO IF THE USER'S GRID HAS ITS ORIGIN AT A -C POINT OTHER THAN THE NORTH POLE, A TRANSLATION IS REQUIRED TO -C GET I AND J FOR INPUT INTO W3FB01. THE SUBROUTINE GRID IS -C ORIENTED SO THAT LONGITUDE 80W IS PARALLEL TO GRIDLINES OF -C I=CONSTANT. THE EARTH'S RADIUS IS TAKEN TO BE 6371.2 KM. -C ALL PARAMETERS IN THE CALL STATEMENT MUST BE REAL -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - DATA DEGPRD/57.2957795/ - DATA EARTHR/6371.2/ -C - GI2 = (1.86603 * EARTHR) / XMESHL - GI2 = GI2 * GI2 - R2 = XI * XI + XJ * XJ - IF (R2.NE.0.0) GO TO 100 - ALONG = 0.0 - ALAT = 90.0 - RETURN -C -100 CONTINUE - ALAT = ASIN((GI2-R2) / (GI2+R2)) * DEGPRD - XLONG = DEGPRD * ATAN2(XJ,XI) - IF (XLONG) 200,300,300 -C -200 CONTINUE - ALONG = -10.0 - XLONG - IF (ALONG.LT.0.0) ALONG = ALONG + 360.0 - GO TO 400 -C -300 CONTINUE - ALONG = 350.0 - XLONG -C -400 CONTINUE - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fb02.f b/src/fim/FIMsrc/w3/w3fb02.f deleted file mode 100644 index ca0b1b8..0000000 --- a/src/fim/FIMsrc/w3/w3fb02.f +++ /dev/null @@ -1,81 +0,0 @@ - SUBROUTINE W3FB02(ALAT, ALONG, XMESHL, XI, XJ) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FB02 CONVERT S. HEMISPHERE LAT/LON TO I AND J -C AUTHOR: JONES,R.E. ORG: W342 DATE: 85-09-13 -C -C ABSTRACT: COMPUTES I AND J COORDINATES FOR A LATITUDE/LONGITUDE -C POINT ON THE SOUTHERN HEMISPHERE POLAR STEREOGRAPHIC MAP -C PROJECTION. -C -C PROGRAM HISTORY LOG: -C 85-09-13 R.E.JONES CONVERT TO FORTRAN 77 -C 90-08-31 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C -C USAGE: CALL W3FB02 (ALAT, ALONG, XMESHL, XI, XJ) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C ALAT ARG LIST REAL*4 LATITUDE (S.H. LATITUDES ARE NEGATIVE) -C ALONG ARG LIST REAL*4 WEST LONGITUDE -C XMESHL ARG LIST REAL*4 GRID INTERVAL IN KM. -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C XI ARG LIST REAL*4 I COORDINATE -C XJ ARG LIST REAL*4 J COORDINATE -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C COS SIN SYSLIB -C -C -C EXIT STATES: * -C -C EXTERNAL REFERENCES: NONE -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C -C ...GIVEN ... ALAT SRN HEMI LATS ARE NEGATIVE VALUED -C ALONG IN DEGREES WEST LONGITUDE -C XMESHL= GRID INTERVAL IN KM, E.G., 381.0 KM -C ...TO COMPUTE XI,XJ FOR A PT ON THE SRN HEMI POLAR STEREOGRAPHIC -C ... PROJECTION, WITH 80W LONGITUDE VERTICAL AT THE TOP OF MAP, -C ... AND 100E LONGITUDE VERTICAL AT THE BOTTOM OF THE MAP. -C ...THE RESULTING XI AND XJ ARE RELATIVE TO (0,0) AT SOUTH POLE. -C - DATA ADDLNG/80.0/ -C -C ...WHICH IS DIFFERENCE BETWEEN 180 DEGREES AND VERTICAL MERIDIAN. -C ... THE VERTICAL BEING 100 WEST AFTER CHANGING THE SENSE -C - DATA TINY /0.00001/ - DATA EARTHR/6371.2/ - DATA CONVT /0.017453293/ -C -C ...WHICH CONVERTS DEGREES TO RADIANS -C - RE = (EARTHR * 1.86603) / XMESHL -C -C ...WHICH IS DISTANCE IN GRID INTERVALS FROM POLE TO EQUATOR -C - XLAT = -ALAT * CONVT -C -C ...WHERE NEGATIVE ALATS WERE GIVEN FOR SRN HEMI -C - WLONG = 360.0 - ALONG - WLONG = (WLONG + ADDLNG) * CONVT - R = (RE * COS(XLAT))/(1.0 + SIN(XLAT)) - XI = R * SIN(WLONG) - IF (ABS(XI) .LT. TINY) XI = 0.0 - XJ = R * COS (WLONG) - IF (ABS(XJ) .LT. TINY) XJ = 0.0 - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fb03.f b/src/fim/FIMsrc/w3/w3fb03.f deleted file mode 100644 index 2d4f867..0000000 --- a/src/fim/FIMsrc/w3/w3fb03.f +++ /dev/null @@ -1,73 +0,0 @@ - SUBROUTINE W3FB03(XI, XJ, XMESHL, TLAT, TLONG) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FB03 CONVERT I,J GRID COORDINATES TO LAT/LON -C AUTHOR: JONES,R.E. ORG: W342 DATE: 86-07-17 -C -C ABSTRACT: CONVERTS I,J GRID COORDINATES TO THE CORRESPONDING -C LATITUDE/LONGITUDE ON A SOUTHERN HEMISPHERE POLAR STEREOGRAPHIC -C MAP PROJECTION. -C -C PROGRAM HISTORY LOG. -C 86-07-17 R.E.JONES CONVERT TO FORTRAN 77 -C 90-08-31 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C -C USAGE: CALL W3FBO3 (XI, XJ, XMESHL, TLAT, TLONG) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C XI ARG LIST REAL I COORDINATE -C XJ ARG LIST REAL J COORDINATE -C XMESHL ARG LIST REAL GRID INTERVAL IN KM. -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C TLAT ARG LIST REAL S.H. LATITUDE -C TLONG ARG LIST REAL LONGITUDE -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C ASIN ATAN2 SYSLIB -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C -C ...GIVEN ... XI/XJ GRID COORDINATES OF A POINT RELATIVE -C ... TO (0,0) AT SOUTH POLE -C ...TO COMPUTE TLAT,TLONG ON THE SRN HEMI POLAR STEREO PROJECTION -C ...WITH 80W VERTICAL AT TOP OF THE MAP -C - DATA DEGPRD/57.2957795/ - DATA EARTHR/6371.2/ -C - RE = (EARTHR * 1.86603) / XMESHL - GI2 = RE * RE -C -C ...WHERE GI2 IS THE SQUARE OF DISTANCE IN GRID INTERVALS -C ... FROM POLE TO EQUATOR... -C - R2 = XI * XI + XJ * XJ - IF (R2 .NE. 0.0) THEN -C - XLONG = DEGPRD * ATAN2(XJ,XI) - TLONG = XLONG - 10.0 - IF (TLONG .LT. 0.0) TLONG = TLONG + 360.0 - TLAT = ASIN((GI2 - R2)/(GI2 + R2)) * DEGPRD - TLAT = -TLAT -C - ELSE - TLAT = -90.0 -C -C ...FOR SOUTH POLE... -C - TLONG = 0.0 - ENDIF -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fb04.f b/src/fim/FIMsrc/w3/w3fb04.f deleted file mode 100644 index 6dd5bed..0000000 --- a/src/fim/FIMsrc/w3/w3fb04.f +++ /dev/null @@ -1,81 +0,0 @@ - SUBROUTINE W3FB04(ALAT,ALONG,XMESHL,ORIENT,XI,XJ) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FB04 LATITUDE, LONGITUDE TO GRID COORDINATES -C AUTHOR: MCDONELL,J. ORG: W345 DATE: 86-07-17 -C -C ABSTRACT: CONVERTS THE COORDINATES OF A LOCATION ON EARTH FROM THE -C NATURAL COORDINATE SYSTEM OF LATITUDE/LONGITUDE TO THE GRID (I,J) -C COORDINATE SYSTEM OVERLAID ON A POLAR STEREOGRAPHIC MAP PRO- -C JECTION TRUE AT 60 DEGREES N OR S LATITUDE. W3FB04 IS THE REVERSE -C OF W3FB05. -C -C PROGRAM HISTORY LOG: -C 86-07-17 MCDONELL,J. -C 88-06-07 R.E.JONES CLEAN UP CODE, TAKE OUT GOTO, USE THEN, ELSE -C 89-11-02 R.E.JONES CHANGE TO CRAY CFT77 FORTRAN -C -C USAGE: CALL W3FB04 (ALAT, ALONG, XMESHL, ORIENT, XI, XJ) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C ALAT ARG LIST LATITUDE IN DEGREES (<0 IF SH) -C ALONG ARG LIST WEST LONGITUDE IN DEGREES -C XMESHL ARG LIST MESH LENGTH OF GRID IN KM AT 60 DEG LAT(<0 IF SH) -C (190.5 LFM GRID, 381.0 NH PE GRID,-381.0 SH PE GRID) -C ORIENT ARG LIST ORIENTATION WEST LONGITUDE OF THE GRID -C (105.0 LFM GRID, 80.0 NH PE GRID, 260.0 SH PE GRID) -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C XI ARG LIST I OF THE POINT RELATIVE TO NORTH OR SOUTH POLE -C XJ ARG LIST J OF THE POINT RELATIVE TO NORTH OR SOUTH POLE -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C COS SIN SYSLIB -C -C REMARKS: ALL PARAMETERS IN THE CALLING STATEMENT MUST BE -C REAL. THE RANGE OF ALLOWABLE LATITUDES IS FROM A POLE TO -C 30 DEGREES INTO THE OPPOSITE HEMISPHERE. -C THE GRID USED IN THIS SUBROUTINE HAS ITS ORIGIN (I=0,J=0) -C AT THE POLE IN EITHER HEMISPHERE, SO IF THE USER'S GRID HAS ITS -C ORIGIN AT A POINT OTHER THAN THE POLE, A TRANSLATION IS NEEDED -C TO GET I AND J. THE GRIDLINES OF I=CONSTANT ARE PARALLEL TO A -C LONGITUDE DESIGNATED BY THE USER. THE EARTH'S RADIUS IS TAKEN -C TO BE 6371.2 KM. -C -C WARNING: THIS CODE IS NOT VECTORIZED. TO VECTORIZE TAKE IT AND -C SUBROUTINE IT CALLS AND PU THEM IN LINE. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - DATA RADPD /.01745329/ - DATA EARTHR/6371.2/ -C - RE = (EARTHR * 1.86603) / XMESHL - XLAT = ALAT * RADPD -C - IF (XMESHL.GE.0.) THEN - WLONG = (ALONG + 180.0 - ORIENT) * RADPD - R = (RE * COS(XLAT)) / (1.0 + SIN(XLAT)) - XI = R * SIN(WLONG) - XJ = R * COS(WLONG) - ELSE - RE = -RE - XLAT = -XLAT - WLONG = (ALONG - ORIENT) * RADPD - R = (RE * COS(XLAT)) / (1.0 + SIN(XLAT)) - XI = R * SIN(WLONG) - XJ = -R * COS(WLONG) - ENDIF -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fb05.f b/src/fim/FIMsrc/w3/w3fb05.f deleted file mode 100644 index a633471..0000000 --- a/src/fim/FIMsrc/w3/w3fb05.f +++ /dev/null @@ -1,90 +0,0 @@ - SUBROUTINE W3FB05(XI,XJ,XMESHL,ORIENT,ALAT,ALONG) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FB05 GRID COORDINATES TO LATITUDE, LONGITUDE -C AUTHOR: JONES,R.E. ORG: W345 DATE: 86-07-17 -C -C ABSTRACT: CONVERTS THE COORDINATES OF A LOCATION FROM THE GRID(I,J) -C COORDINATE SYSTEM OVERLAID ON THE POLAR STEREOGRAPHIC MAP PROJEC- -C TION TRUE AT 60 DEGREES N OR S LATITUDE TO THE NATURAL COORDINATE -C SYSTEM OF LATITUDE/LONGITUDE ON THE EARTH. W3FB05 IS THE REVERSE -C OF W3FB04. -C -C PROGRAM HISTORY LOG: -C 86-07-17 R.E.JONES -C 89-11-01 R.E.JONES CHANGE TO CRAY CFT77 FORTRAN -C -C USAGE: CALL W3FB05 (XI, XJ, XMESHL, ORIENT, ALAT, ALONG) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C XI ARG LIST I OF THE POINT RELATIVE TO THE NORTH OR S. POLE -C XJ ARG LIST J OF THE POINT RELATIVE TO THE NORTH OR S. POLE -C XMESHL ARG LIST MESH LENGTH OF GRID IN KM AT 60 DEGREES(<0 IF SH) -C (190.5 LFM GRID, 381.0 NH PE GRID,-381.0 SH PE GRID) -C ORIENT ARG LIST ORIENTATION WEST LONGITUDE OF THE GRID -C (105.0 LFM GRID, 80.0 NH PE GRID, 260.0 SH PE GRID) -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C ALAT ARG LIST LATITUDE IN DEGREES (<0 IF SH) -C ALONG ARG LIST WEST LONGITUDE IN DEGREES -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C ASIN ATAN2 SYSLIB -C -C REMARKS: ALL PARAMETERS IN THE CALLING STATEMENT MUST BE -C REAL. THE RANGE OF ALLOWABLE LATITUDES IS FROM A POLE TO -C 30 DEGREES INTO THE OPPOSITE HEMISPHERE. -C THE GRID USED IN THIS SUBROUTINE HAS ITS ORIGIN (I=0,J=0) -C AT THE POLE, SO IF THE USER'S GRID HAS ITS ORIGIN AT A POINT -C OTHER THAN A POLE, A TRANSLATION IS REQUIRED TO GET I AND J FOR -C INPUT INTO W3FB05. THE SUBROUTINE GRID IS ORIENTED SO THAT -C GRIDLINES OF I=CONSTANT ARE PARALLEL TO A WEST LONGITUDE SUP- -C PLIED BY THE USER. THE EARTH'S RADIUS IS TAKEN TO BE 6371.2 KM. -C -C WARNING: THIS CODE WILL NOT VECTORIZE, IT IS NORMALY USED IN A -C DOUBLE DO LOOP WITH W3FT01, W3FT00, ETC. TO VECTORIZE IT, -C PUT IT IN LINE, PUT W3FT01, W3FT00, ETC. IN LINE. -C -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - DATA DEGPRD/57.2957795/ - DATA EARTHR/6371.2/ -C - GI2 = ((1.86603 * EARTHR) / (XMESHL))**2 - R2 = XI * XI + XJ * XJ -C - IF (R2.EQ.0.0) THEN - ALONG = 0.0 - ALAT = 90.0 - IF (XMESHL.LT.0.0) ALAT = -ALAT - RETURN - ELSE - ALAT = ASIN((GI2 - R2) / (GI2 + R2)) * DEGPRD - ANGLE = DEGPRD * ATAN2(XJ,XI) - IF (ANGLE.LT.0.0) ANGLE = ANGLE + 360.0 - ENDIF -C - IF (XMESHL.GE.0.0) THEN - ALONG = 270.0 + ORIENT - ANGLE -C - ELSE -C - ALONG = ANGLE + ORIENT - 270.0 - ALAT = -(ALAT) - ENDIF -C - IF (ALONG.LT.0.0) ALONG = ALONG + 360.0 - IF (ALONG.GE.360.0) ALONG = ALONG - 360.0 -C - RETURN -C - END diff --git a/src/fim/FIMsrc/w3/w3fb06.f b/src/fim/FIMsrc/w3/w3fb06.f deleted file mode 100644 index caf56b3..0000000 --- a/src/fim/FIMsrc/w3/w3fb06.f +++ /dev/null @@ -1,98 +0,0 @@ - SUBROUTINE W3FB06(ALAT,ALON,ALAT1,ALON1,DX,ALONV,XI,XJ) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FB06 LAT/LON TO POLA (I,J) FOR GRIB -C PRGMMR: STACKPOLE ORG: NMC42 DATE:88-04-05 -C -C ABSTRACT: CONVERTS THE COORDINATES OF A LOCATION ON EARTH GIVEN IN -C THE NATURAL COORDINATE SYSTEM OF LATITUDE/LONGITUDE TO A GRID -C COORDINATE SYSTEM OVERLAID ON A POLAR STEREOGRAPHIC MAP PRO- -C JECTION TRUE AT 60 DEGREES N OR S LATITUDE. W3FB06 IS THE REVERSE -C OF W3FB07. USES GRIB SPECIFICATION OF THE LOCATION OF THE GRID -C -C PROGRAM HISTORY LOG: -C 88-01-01 ORIGINAL AUTHOR: STACKPOLE, W/NMC42 -C 90-04-12 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C -C USAGE: CALL W3FB06 (ALAT,ALON,ALAT1,ALON1,DX,ALONV,XI,XJ) -C INPUT ARGUMENT LIST: -C ALAT - LATITUDE IN DEGREES (NEGATIVE IN SOUTHERN HEMIS) -C ALON - EAST LONGITUDE IN DEGREES, REAL*4 -C ALAT1 - LATITUDE OF LOWER LEFT POINT OF GRID (POINT (1,1)) -C ALON1 - LONGITUDE OF LOWER LEFT POINT OF GRID (POINT (1,1)) -C ALL REAL*4 -C DX - MESH LENGTH OF GRID IN METERS AT 60 DEG LAT -C MUST BE SET NEGATIVE IF USING -C SOUTHERN HEMISPHERE PROJECTION. -C 190500.0 LFM GRID, -C 381000.0 NH PE GRID, -381000.0 SH PE GRID, ETC. -C ALONV - THE ORIENTATION OF THE GRID. I.E., -C THE EAST LONGITUDE VALUE OF THE VERTICAL MERIDIAN -C WHICH IS PARALLEL TO THE Y-AXIS (OR COLUMNS OF -C OF THE GRID)ALONG WHICH LATITUDE INCREASES AS -C THE Y-COORDINATE INCREASES. REAL*4 -C FOR EXAMPLE: -C 255.0 FOR LFM GRID, -C 280.0 NH PE GRID, 100.0 SH PE GRID, ETC. -C -C OUTPUT ARGUMENT LIST: -C XI - I COORDINATE OF THE POINT SPECIFIED BY ALAT, ALON -C XJ - J COORDINATE OF THE POINT; BOTH REAL*4 -C -C REMARKS: FORMULAE AND NOTATION LOOSELY BASED ON HOKE, HAYES, -C AND RENNINGER'S "MAP PROJECTIONS AND GRID SYSTEMS...", MARCH 1981 -C AFGWC/TN-79/003 -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - DATA RERTH /6.3712E+6/, PI/3.1416/ - DATA SS60 /1.86603/ -C -C PRELIMINARY VARIABLES AND REDIFINITIONS -C -C H = 1 FOR NORTHERN HEMISPHERE; = -1 FOR SOUTHERN -C -C REFLON IS LONGITUDE UPON WHICH THE POSITIVE X-COORDINATE -C DRAWN THROUGH THE POLE AND TO THE RIGHT LIES -C ROTATED AROUND FROM ORIENTATION (Y-COORDINATE) LONGITUDE -C DIFFERENTLY IN EACH HEMISPHERE -C - IF (DX.LT.0) THEN - H = -1.0 - DXL = -DX - REFLON = ALONV - 90.0 - ELSE - H = 1.0 - DXL = DX - REFLON = ALONV - 270.0 - ENDIF -C - RADPD = PI / 180.0 - REBYDX = RERTH/DXL -C -C RADIUS TO LOWER LEFT HAND (LL) CORNER -C - ALA1 = ALAT1 * RADPD - RMLL = REBYDX * COS(ALA1) * SS60/(1. + H * SIN(ALA1)) -C -C USE LL POINT INFO TO LOCATE POLE POINT -C - ALO1 = (ALON1 - REFLON) * RADPD - POLEI = 1. - RMLL * COS(ALO1) - POLEJ = 1. - H * RMLL * SIN(ALO1) -C -C RADIUS TO DESIRED POINT AND THE I J TOO -C - ALA = ALAT * RADPD - RM = REBYDX * COS(ALA) * SS60/(1. + H * SIN(ALA)) -C - ALO = (ALON - REFLON) * RADPD - XI = POLEI + RM * COS(ALO) - XJ = POLEJ + H * RM * SIN(ALO) -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fb07.f b/src/fim/FIMsrc/w3/w3fb07.f deleted file mode 100644 index dbda94b..0000000 --- a/src/fim/FIMsrc/w3/w3fb07.f +++ /dev/null @@ -1,115 +0,0 @@ - SUBROUTINE W3FB07(XI,XJ,ALAT1,ALON1,DX,ALONV,ALAT,ALON) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FB07 GRID COORDS TO LAT/LON FOR GRIB -C PRGMMR: STACKPOLE ORG: NMC42 DATE:88-04-05 -C -C ABSTRACT: CONVERTS THE COORDINATES OF A LOCATION ON EARTH GIVEN IN A -C GRID COORDINATE SYSTEM OVERLAID ON A POLAR STEREOGRAPHIC MAP PRO- -C JECTION TRUE AT 60 DEGREES N OR S LATITUDE TO THE -C NATURAL COORDINATE SYSTEM OF LATITUDE/LONGITUDE -C W3FB07 IS THE REVERSE OF W3FB06. -C USES GRIB SPECIFICATION OF THE LOCATION OF THE GRID -C -C PROGRAM HISTORY LOG: -C 88-01-01 ORIGINAL AUTHOR: STACKPOLE, W/NMC42 -C 90-04-12 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C -C USAGE: CALL W3FB07(XI,XJ,ALAT1,ALON1,DX,ALONV,ALAT,ALON) -C INPUT ARGUMENT LIST: -C XI - I COORDINATE OF THE POINT REAL*4 -C XJ - J COORDINATE OF THE POINT REAL*4 -C ALAT1 - LATITUDE OF LOWER LEFT POINT OF GRID (POINT 1,1) -C LATITUDE <0 FOR SOUTHERN HEMISPHERE; REAL*4 -C ALON1 - LONGITUDE OF LOWER LEFT POINT OF GRID (POINT 1,1) -C EAST LONGITUDE USED THROUGHOUT; REAL*4 -C DX - MESH LENGTH OF GRID IN METERS AT 60 DEG LAT -C MUST BE SET NEGATIVE IF USING -C SOUTHERN HEMISPHERE PROJECTION; REAL*4 -C 190500.0 LFM GRID, -C 381000.0 NH PE GRID, -381000.0 SH PE GRID, ETC. -C ALONV - THE ORIENTATION OF THE GRID. I.E., -C THE EAST LONGITUDE VALUE OF THE VERTICAL MERIDIAN -C WHICH IS PARALLEL TO THE Y-AXIS (OR COLUMNS OF -C THE GRID) ALONG WHICH LATITUDE INCREASES AS -C THE Y-COORDINATE INCREASES. REAL*4 -C FOR EXAMPLE: -C 255.0 FOR LFM GRID, -C 280.0 NH PE GRID, 100.0 SH PE GRID, ETC. -C -C OUTPUT ARGUMENT LIST: -C ALAT - LATITUDE IN DEGREES (NEGATIVE IN SOUTHERN HEMI.) -C ALON - EAST LONGITUDE IN DEGREES, REAL*4 -C -C REMARKS: FORMULAE AND NOTATION LOOSELY BASED ON HOKE, HAYES, -C AND RENNINGER'S "MAP PROJECTIONS AND GRID SYSTEMS...", MARCH 1981 -C AFGWC/TN-79/003 -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - DATA RERTH /6.3712E+6/,PI/3.1416/ - DATA SS60 /1.86603/ -C -C PRELIMINARY VARIABLES AND REDIFINITIONS -C -C H = 1 FOR NORTHERN HEMISPHERE; = -1 FOR SOUTHERN -C -C REFLON IS LONGITUDE UPON WHICH THE POSITIVE X-COORDINATE -C DRAWN THROUGH THE POLE AND TO THE RIGHT LIES -C ROTATED AROUND FROM ORIENTATION (Y-COORDINATE) LONGITUDE -C DIFFERENTLY IN EACH HEMISPHERE -C - IF (DX.LT.0) THEN - H = -1.0 - DXL = -DX - REFLON = ALONV - 90.0 - ELSE - H = 1.0 - DXL = DX - REFLON = ALONV - 270.0 - ENDIF -C - RADPD = PI / 180.0 - DEGPRD = 180.0 / PI - REBYDX = RERTH / DXL -C -C RADIUS TO LOWER LEFT HAND (LL) CORNER -C - ALA1 = ALAT1 * RADPD - RMLL = REBYDX * COS(ALA1) * SS60/(1. + H * SIN(ALA1)) -C -C USE LL POINT INFO TO LOCATE POLE POINT -C - ALO1 = (ALON1 - REFLON) * RADPD - POLEI = 1. - RMLL * COS(ALO1) - POLEJ = 1. - H * RMLL * SIN(ALO1) -C -C RADIUS TO THE I,J POINT (IN GRID UNITS) -C - XX = XI - POLEI - YY = (XJ - POLEJ) * H - R2 = XX**2 + YY**2 -C -C NOW THE MAGIC FORMULAE -C - IF (R2.EQ.0) THEN - ALAT = H * 90. - ALON = REFLON - ELSE - GI2 = (REBYDX * SS60)**2 - ALAT = DEGPRD * H * ASIN((GI2 - R2)/(GI2 + R2)) - ARCCOS = ACOS(XX/SQRT(R2)) - IF (YY.GT.0) THEN - ALON = REFLON + DEGPRD * ARCCOS - ELSE - ALON = REFLON - DEGPRD * ARCCOS - ENDIF - ENDIF - IF (ALON.LT.0) ALON = ALON + 360. -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fb08.f b/src/fim/FIMsrc/w3/w3fb08.f deleted file mode 100644 index 4933494..0000000 --- a/src/fim/FIMsrc/w3/w3fb08.f +++ /dev/null @@ -1,65 +0,0 @@ - SUBROUTINE W3FB08(ALAT,ALON,ALAT1,ALON1,ALATIN,DX,XI,XJ) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FB08 LAT/LON TO MERC (I,J) FOR GRIB -C PRGMMR: STACKPOLE ORG: NMC42 DATE:88-04-05 -C -C ABSTRACT: CONVERTS A LOCATION ON EARTH GIVEN IN -C THE COORDINATE SYSTEM OF LATITUDE/LONGITUDE TO AN (I,J) -C COORDINATE SYSTEM OVERLAID ON A MERCATOR MAP PROJECTION -C W3FB08 IS THE REVERSE OF W3FB09 -C USES GRIB SPECIFICATION OF THE LOCATION OF THE GRID -C -C PROGRAM HISTORY LOG: -C 88-03-01 ORIGINAL AUTHOR: STACKPOLE, W/NMC42 -C 90-04-12 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C -C USAGE: CALL W3FB08 (ALAT,ALON,ALAT1,ALON1,ALATIN,DX,XI,XJ) -C INPUT ARGUMENT LIST: -C ALAT - LATITUDE IN DEGREES (NEGATIVE IN SOUTHERN HEMIS) -C ALON - EAST LONGITUDE IN DEGREES, REAL*4 -C ALAT1 - LATITUDE OF LOWER LEFT CORNER OF GRID (POINT (1,1)) -C ALON1 - LONGITUDE OF LOWER LEFT CORNER OF GRID (POINT (1,1)) -C ALL REAL*4 -C ALATIN - THE LATITUDE AT WHICH THE MERCATOR CYLINDER -C INTERSECTS THE EARTH -C DX - MESH LENGTH OF GRID IN METERS AT ALATIN -C -C OUTPUT ARGUMENT LIST: -C XI - I COORDINATE OF THE POINT SPECIFIED BY ALAT, ALON -C XJ - J COORDINATE OF THE POINT; BOTH REAL*4 -C -C REMARKS: FORMULAE AND NOTATION LOOSELY BASED ON HOKE, HAYES, -C AND RENNINGER'S "MAP PROJECTIONS AND GRID SYSTEMS...", MARCH 1981 -C AFGWC/TN-79/003 -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - DATA RERTH /6.3712E+6/, PI/3.1416/ -C -C PRELIMINARY VARIABLES AND REDIFINITIONS -C - RADPD = PI / 180.0 - DEGPR = 180.0 / PI - CLAIN = COS(RADPD*ALATIN) - DELLON = DX / (RERTH*CLAIN) -C -C GET DISTANCE FROM EQUATOR TO ORIGIN ALAT1 -C - DJEO = 0. - IF (ALAT1.NE.0.) - & DJEO = (ALOG(TAN(0.5*((ALAT1+90.0)*RADPD))))/DELLON -C -C NOW THE I AND J COORDINATES -C - XI = 1. + ((ALON - ALON1)/(DELLON*DEGPR)) - XJ = 1. + (ALOG(TAN(0.5*((ALAT + 90.) * RADPD))))/ - & DELLON - & - DJEO -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fb09.f b/src/fim/FIMsrc/w3/w3fb09.f deleted file mode 100644 index 9495e11..0000000 --- a/src/fim/FIMsrc/w3/w3fb09.f +++ /dev/null @@ -1,64 +0,0 @@ - SUBROUTINE W3FB09(XI,XJ,ALAT1,ALON1,ALATIN,DX,ALAT,ALON) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FB09 MERC (I,J) TO LAT/LON FOR GRIB -C PRGMMR: STACKPOLE ORG: NMC42 DATE:88-04-05 -C -C ABSTRACT: CONVERTS A LOCATION ON EARTH GIVEN IN -C AN I,J COORDINATE SYSTEM OVERLAID ON A MERCATOR MAP PROJECTION -C TO THE COORDINATE SYSTEM OF LATITUDE/LONGITUDE -C W3FB09 IS THE REVERSE OF W3FB08 -C USES GRIB SPECIFICATION OF THE LOCATION OF THE GRID -C -C PROGRAM HISTORY LOG: -C 88-03-01 ORIGINAL AUTHOR: STACKPOLE, W/NMC42 -C 90-04-12 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C -C USAGE: CALL W3FB09 (XI,XJ,ALAT1,ALON1,ALATIN,DX,ALAT,ALON) -C INPUT ARGUMENT LIST: -C XI - I COORDINATE OF THE POINT -C XJ - J COORDINATE OF THE POINT; BOTH REAL*4 -C ALAT1 - LATITUDE OF LOWER LEFT CORNER OF GRID (POINT (1,1)) -C ALON1 - LONGITUDE OF LOWER LEFT CORNER OF GRID (POINT (1,1)) -C ALL REAL*4 -C ALATIN - THE LATITUDE AT WHICH THE MERCATOR CYLINDER -C INTERSECTS THE EARTH -C DX - MESH LENGTH OF GRID IN METERS AT ALATIN -C -C OUTPUT ARGUMENT LIST: -C ALAT - LATITUDE IN DEGREES (NEGATIVE IN SOUTHERN HEMIS) -C ALON - EAST LONGITUDE IN DEGREES, REAL*4 -C - OF THE POINT SPECIFIED BY (I,J) -C -C REMARKS: FORMULAE AND NOTATION LOOSELY BASED ON HOKE, HAYES, -C AND RENNINGER'S "MAP PROJECTIONS AND GRID SYSTEMS...", MARCH 1981 -C AFGWC/TN-79/003 -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - DATA RERTH /6.3712E+6/, PI/3.1416/ -C -C PRELIMINARY VARIABLES AND REDIFINITIONS -C - RADPD = PI / 180.0 - DEGPR = 180.0 / PI - CLAIN = COS(RADPD*ALATIN) - DELLON = DX / (RERTH*CLAIN) -C -C GET DISTANCE FROM EQUATOR TO ORIGIN ALAT1 -C - DJEO = 0. - IF (ALAT1.NE.0.) - & DJEO = (ALOG(TAN(0.5*((ALAT1+90.0)*RADPD))))/DELLON -C -C NOW THE LAT AND LON -C - ALAT = 2.0*ATAN(EXP(DELLON*(DJEO + XJ-1.)))*DEGPR - 90.0 - ALON = (XI-1.) * DELLON * DEGPR + ALON1 -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fb10.f b/src/fim/FIMsrc/w3/w3fb10.f deleted file mode 100644 index 0e3b8e7..0000000 --- a/src/fim/FIMsrc/w3/w3fb10.f +++ /dev/null @@ -1,237 +0,0 @@ - SUBROUTINE W3FB10(DLAT1, DLON1, DLAT2, DLON2, BEARD, GCDKM) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FB10 LAT/LONG PAIR TO COMPASS BEARING, GCD -C PRGMMR: CHASE ORG: NMC421 DATE:88-10-26 -C -C ABSTRACT: GIVEN A PAIR OF POINTS (1) AND (2) GIVEN BY LATITUDE AND -C LONGITUDE, W3FB10 COMPUTES THE BEARING AND GREAT CIRCLE DISTANCE -C FROM POINT (1) TO POINT (2) ASSUMING A SPHERICAL EARTH. THE -C NORTH AND SOUTH POLES ARE SPECIAL CASES. IF LATITUDE OF POINT -C (1) IS WITHIN 1E-10 DEGREES OF THE NORTH POLE, BEARING IS THE -C NEGATIVE LONGITUDE OF POINT (2) BY CONVENTION. IF LATITUDE OF -C POINT (1) IS WITHIN 1E-10 DEGREES OF THE SOUTH POLE, BEARING IS -C THE LONGITUDE OF POINT (2) BY CONVENTION. IF POINT (2) IS WITHIN -C 1E-6 RADIANS OF THE ANTIPODE OF POINT (1), THE BEARING WILL BE -C SET TO ZERO. IF POINT (1) AND POINT (2) ARE WITHIN 1E-10 RADIANS -C OF EACH OTHER, BOTH BEARING AND DISTANCE WILL BE SET TO ZERO. -C -C PROGRAM HISTORY LOG: -C 88-08-29 CHASE, P. -C 88-09-23 CHASE, P. FIX DUMB SOUTH POLE ERROR -C 88-10-05 CHASE, P. FIX BEARING AMBIGUITY -C 90-04-12 R.E.JONES CONVERT TO CFT77 FORTRAN -C -C USAGE: CALL W3FB10(DLAT1, DLON1, DLAT2, DLON2, BEARD, GCDKM) -C -C INPUT ARGUMENT LIST: -C DLAT1 - REAL LATITUDE OF POINT (1) IN DEGREES NORTH. -C DLON1 - REAL LONGITUDE OF POINT (1) IN DEGREES EAST. -C DLAT2 - REAL LATITUDE OF POINT (2) IN DEGREES NORTH. -C DLON2 - REAL LONGITUDE OF POINT (2) IN DEGREES EAST. -C -C OUTPUT ARGUMENT LIST: -C BEARD - REAL BEARING OF POINT (2) FROM POINT (1) IN -C COMPASS DEGREES WITH NORTH = 0.0, VALUES FROM -C -180.0 TO +180.0 DEGREES. -C GCDKM - REAL GREAT CIRCLE DISTANCE FROM POINT (1) TO -C POINT (2) IN KILOMETERS. -C -C SUBPROGRAMS CALLED: NONE -C -C REMARKS: ACCORDING TO THE NMC HANDBOOK, THE EARTH'S RADIUS IS -C 6371.2 KILOMETERS. THIS IS WHAT WE USE, EVEN THOUGH THE VALUE -C RECOMMENDED BY THE SMITHSONIAN METEOROLOGICAL HANDBOOK IS -C 6371.221 KM. (I WOULDN'T WANT YOU TO THINK THAT I DIDN'T KNOW -C WHAT THE CORRECT VALUE WAS.) -C METHOD: THE POLES ARE SPECIAL CASES, AND HANDLED SEPARATELY. -C OTHERWISE, FROM SPHERICAL TRIGONOMETRY, THE LAW OF COSINES IS USED -C TO CALCULATE THE THIRD SIDE OF THE SPHERICAL TRIANGLE HAVING -C SIDES FROM THE POLE TO POINTS (1) AND (2) (THE COLATITUDES). -C THEN THE LAW OF SINES IS USED TO CALCULATE THE ANGLE AT POINT -C (1). A TEST IS APPLIED TO SEE WHETHER THE ARCSINE RESULT MAY BE -C BE USED AS SUCH, GIVING AN ACUTE ANGLE AS THE BEARING, OR WHETHER -C THE ARCSINE RESULT SHOULD BE SUBTRACTED FROM PI, GIVING AN OBTUSE -C ANGLE AS THE BEARING. THIS TEST IS DERIVED BY CONSTRUCTING A -C RIGHT SPHERICAL TRIANGLE USING THE POLE, POINT (2), AND THE -C MERIDIAN THROUGH POINT(1). THE LATITUDE OF THE RIGHT-ANGLED -C VERTEX THEN PROVIDES A TEST--IF LATITUDE (1) IS GREATER THAN THIS -C LATITUDE, THE BEARING ANGLE MUST BE OBTUSE, OTHERWISE ACUTE. -C IF THE TWO POINTS ARE WITHIN 1E-6 RADIANS OF EACH OTHER -C A FLAT EARTH IS ASSUMED, AND THE FOUR-QUADRANT ARCTANGENT -C FUNCTION IS USED TO FIND THE BEARING. THE Y-DISPLACEMENT IS -C THE DIFFERENCE IN LATITUDE AND THE X-DISPLACEMENT IS THE -C DIFFERENCE IN LONGITUDE TIMES COSINE LATITUDE, BOTH IN RADIANS. -C DISTANCE IS THEN THE DIAGONAL. -C FUNDAMENTAL TRIGONOMETRIC IDENTITIES ARE USED FREELY, SUCH -C AS THAT COS(X) = SIN(PI/2 - X), ETC. SEE ALMOST ANY MATHEMATICAL -C HANDBOOK, SUCH AS THE C.R.C. STANDARD MATH TABLES UNDER 'RELATIONS -C IN ANY SPHERICAL TRIANGLE', OR THE NATIONAL BUREAU OF STANDARDS -C 'HANDBOOK OF MATHEMATICAL FUNCTIONS' UNDER SECTION 4.3.149, -C FORMULAS FOR SOLUTION OF SPHERICAL TRIANGLES. -C DOUBLE PRECISION IS USED INTERNALLY BECAUSE OF THE WIDE -C RANGE OF GEOGRAPHIC VALUES THAT MAY BE USED. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C -C *** IMPLICIT TYPE DEFAULTS..... -C - IMPLICIT REAL (A-H,O-Z) -C -C *** CONSTANTS...... -C - REAL PI - REAL HALFPI - REAL DR - REAL RD - REAL TDEG, TRAD, TPOD, TFLT - REAL EARTHR - REAL WHOLCD, HALFCD, QUARCD -C -C *** VARIABLES...... -C - REAL RLAT1, RLAT2, COSLA1, COSLA2, SINLA1, SINLA2 - REAL DLOND, RLOND, COSLO, SINLO, SANGG, ABEAR - REAL YDISP, XDISP, DDLAT1, DDLAT2, DBANG - REAL DLAT1, DLAT2, DLON1, DLON2, BEARD, GCDKM -C -C *** CONVERT LATITUDES AND LONGITUDE DIFFERENCE TO RADIANS. -C - DATA PI /3.141592653589793238462643/ - DATA HALFPI/1.570796326794896619231322/ - DATA DR /0.017453292519943295769237/ - DATA RD /57.295779513082320876798155/ - DATA TDEG /1E-10/, TRAD/1E-10/, TPOD/1E-6/, TFLT/1E-6/ - DATA EARTHR/6371.2/ - DATA WHOLCD/360.0/, HALFCD/180.0/, QUARCD/90.0/ - - DDLAT1 = DLAT1 - DDLAT2 = DLAT2 - RLAT1 = DR * DDLAT1 - RLAT2 = DR * DDLAT2 - DLOND = DLON2 - DLON1 - IF (DLOND .GT. HALFCD) DLOND = DLOND - WHOLCD - IF (DLOND .LT. -HALFCD) DLOND = DLOND + WHOLCD - RLOND = DR * DLOND -C -C *** FIRST WE ATTACK THE CASES WHERE POINT 1 IS VERY CLOSE TO THE -C *** NORTH OR SOUTH POLES. -C *** HERE WE USE CONVENTIONAL VALUE FOR BEARING.. - LONG (2) AT THE -C *** NORTH POLE, AND + LONG (2) AT THE SOUTH POLE. -C - IF (ABS(DDLAT1-QUARCD) .LT. TDEG) THEN - IF (ABS(DDLAT2-QUARCD) .LT. TDEG) THEN - DBANG = 0.0 - SANGG = 0.0 - ELSE IF (ABS(DDLAT2+QUARCD) .LT. TDEG) THEN - DBANG = 0.0 - SANGG = PI - ELSE - DBANG = -DLON2 - SANGG = HALFPI - RLAT2 - ENDIF - ELSE IF (ABS(DDLAT1+QUARCD) .LT. TDEG) THEN - IF (ABS(DDLAT2-QUARCD) .LT. TDEG) THEN - DBANG = 0.0 - SANGG = PI - ELSE IF (ABS(DDLAT2+QUARCD) .LT. TDEG) THEN - DBANG = 0.0 - SANGG = 0.0 - ELSE - DBANG = +DLON2 - SANGG = HALFPI + RLAT2 - ENDIF -C -C *** NEXT WE ATTACK THE CASES WHERE POINT 2 IS VERY CLOSE TO THE -C *** NORTH OR SOUTH POLES. -C *** HERE BEARING IS SIMPLY 0 OR 180 DEGREES. -C - ELSE IF (ABS(DDLAT2-QUARCD) .LT. TDEG) THEN - DBANG = 0.0 - SANGG = HALFPI - RLAT1 - ELSE IF (ABS(DDLAT2+QUARCD) .LT. TDEG) THEN - DBANG = HALFCD - SANGG = HALFPI + RLAT1 -C -C *** THE CASE REMAINS THAT NEITHER POINT IS AT EITHER POLE. -C *** FIND COSINE AND SINE OF LATITUDES AND LONGITUDE DIFFERENCE -C *** SINCE THEY ARE USED IN MORE THAN ONE FORMULA. -C - ELSE - COSLA1 = COS(RLAT1) - SINLA1 = SIN(RLAT1) - COSLA2 = COS(RLAT2) - SINLA2 = SIN(RLAT2) - COSLO = COS(RLOND) - SINLO = SIN(RLOND) -C -C *** FOLLOWING IS FORMULA FOR GREAT CIRCLE SUBTENDED ANGLE BETWEEN -C *** POINTS IN RADIAN MEASURE. -C - SANGG = ACOS(SINLA1*SINLA2 + COSLA1*COSLA2*COSLO) -C -C *** IF THE GREAT CIRCLE SUBTENDED ANGLE IS VERY SMALL, FORCE BOTH -C *** BEARING AND DISTANCE TO BE ZERO. -C - IF (ABS(SANGG) .LT. TRAD) THEN - DBANG = 0.0 - SANGG = 0.0 -C -C *** IF THE GREAT CIRCLE SUBTENDED ANGLE IS JUST SMALL, ASSUME A -C *** FLAT EARTH AND CALCULATE Y- AND X-DISPLACEMENTS. THEN FIND -C *** BEARING USING THE ARCTANGENT FUNCTION AND DISTANCE USING THE -C *** SQUARE ROOT. -C - ELSE IF (ABS(SANGG) .LT. TFLT) THEN - YDISP = RLAT2-RLAT1 - XDISP = RLOND*COSLA2 - ABEAR = ATAN2(XDISP, YDISP) - DBANG = RD*ABEAR - SANGG = SQRT(YDISP**2 + XDISP**2) -C -C *** IF THE ANGLE IS RATHER CLOSE TO PI RADIANS, FORCE BEARING TO -C *** BE ZERO AND DISTANCE TO BE PI. -C *** THE TEST FOR 'CLOSE TO PI' IS MORE RELAXED THAN THE TEST FOR -C *** 'CLOSE TO ZERO' TO ALLOW FOR GREATER RELATIVE ERROR. -C - ELSE IF (ABS(SANGG-PI) .LT. TPOD) THEN - DBANG = 0.0 - SANGG = PI -C -C *** OTHERWISE COMPUTE THE PRINCIPAL VALUE OF THE BEARING ANGLE -C *** USING THE LAW OF SINES. THE DIVISION BY THE SINE FORCES US TO -C *** LIMIT THE DOMAIN OF THE ARCSINE TO (-1,1). -C - ELSE - ABEAR = ASIN(AMAX1(-1.0,AMIN1(+1.0,COSLA2*SINLO/ - & SIN(SANGG)))) -C -C *** IF THE LONGITUDE DIFFERENCE IS LESS THAN PI/2 IT IS NECESSARY -C *** TO CHECK WHETHER THE BEARING ANGLE IS ACUTE OR OBTUSE BY -C *** COMPARING LATITUDE (1) WITH THE LATITUDE OF THE GREAT CIRCLE -C *** THROUGH POINT (2) NORMAL TO MERIDIAN OF LONGITUDE (1). IF -C *** LATITUDE (1) IS GREATER, BEARING IS OBTUSE AND THE ACTUAL -C *** BEARING ANGLE IS THE SUPPLEMENT OF THE ANGLE CALCULATED ABOVE. -C - IF (0.0 .LE. COSLA1*SINLA2 .AND. COSLA1*SINLA2 .LE. - & COSLA2*SINLA1*COSLO .OR. COSLA1*SINLA2 .LE. 0.0 .AND. - & COSLA2*SINLA1*COSLO .GE. COSLA1*SINLA2) ABEAR = - & SIGN(PI,ABEAR) - ABEAR - DBANG = RD * ABEAR - ENDIF - ENDIF -C -C *** THIS FINISHES THE CASE WHERE POINTS ARE NOT AT THE POLES. -C *** NOW CONVERT BEARING TO DEGREES IN RANGE -180 TO +180 AND FIND -C *** GREAT CIRCLE DISTANCE IN KILOMETERS. -C - IF (DBANG .LE. -HALFCD) DBANG = DBANG + WHOLCD - IF (DBANG .GT. HALFCD) DBANG = DBANG - WHOLCD - GCDKM = EARTHR * SANGG - BEARD = DBANG - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fb11.f b/src/fim/FIMsrc/w3/w3fb11.f deleted file mode 100644 index 068d416..0000000 --- a/src/fim/FIMsrc/w3/w3fb11.f +++ /dev/null @@ -1,122 +0,0 @@ - SUBROUTINE W3FB11(ALAT,ELON,ALAT1,ELON1,DX,ELONV,ALATAN,XI,XJ) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FB11 LAT/LON TO LAMBERT(I,J) FOR GRIB -C PRGMMR: STACKPOLE ORG: NMC42 DATE:88-11-28 -C -C ABSTRACT: CONVERTS THE COORDINATES OF A LOCATION ON EARTH GIVEN IN -C THE NATURAL COORDINATE SYSTEM OF LATITUDE/LONGITUDE TO A GRID -C COORDINATE SYSTEM OVERLAID ON A LAMBERT CONFORMAL TANGENT CONE -C PROJECTION TRUE AT A GIVEN N OR S LATITUDE. W3FB11 IS THE REVERSE -C OF W3FB12. USES GRIB SPECIFICATION OF THE LOCATION OF THE GRID -C -C PROGRAM HISTORY LOG: -C 88-11-25 ORIGINAL AUTHOR: STACKPOLE, W/NMC42 -C 90-04-12 R.E.JONES CONVERT TO CFT77 FORTRAN -C 94-04-28 R.E.JONES ADD SAVE STATEMENT -C -C USAGE: CALL W3FB11 (ALAT,ELON,ALAT1,ELON1,DX,ELONV,ALATAN,XI,XJ) -C INPUT ARGUMENT LIST: -C ALAT - LATITUDE IN DEGREES (NEGATIVE IN SOUTHERN HEMIS) -C ELON - EAST LONGITUDE IN DEGREES, REAL*4 -C ALAT1 - LATITUDE OF LOWER LEFT POINT OF GRID (POINT (1,1)) -C ELON1 - LONGITUDE OF LOWER LEFT POINT OF GRID (POINT (1,1)) -C ALL REAL*4 -C DX - MESH LENGTH OF GRID IN METERS AT TANGENT LATITUDE -C ELONV - THE ORIENTATION OF THE GRID. I.E., -C THE EAST LONGITUDE VALUE OF THE VERTICAL MERIDIAN -C WHICH IS PARALLEL TO THE Y-AXIS (OR COLUMNS OF -C OF THE GRID) ALONG WHICH LATITUDE INCREASES AS -C THE Y-COORDINATE INCREASES. REAL*4 -C THIS IS ALSO THE MERIDIAN (ON THE BACK SIDE OF THE -C TANGENT CONE) ALONG WHICH THE CUT IS MADE TO LAY -C THE CONE FLAT. -C ALATAN - THE LATITUDE AT WHICH THE LAMBERT CONE IS TANGENT TO -C (TOUCHING) THE SPHERICAL EARTH. -C SET NEGATIVE TO INDICATE A -C SOUTHERN HEMISPHERE PROJECTION. -C -C OUTPUT ARGUMENT LIST: -C XI - I COORDINATE OF THE POINT SPECIFIED BY ALAT, ELON -C XJ - J COORDINATE OF THE POINT; BOTH REAL*4 -C -C REMARKS: FORMULAE AND NOTATION LOOSELY BASED ON HOKE, HAYES, -C AND RENNINGER'S "MAP PROJECTIONS AND GRID SYSTEMS...", MARCH 1981 -C AFGWC/TN-79/003 -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256 -C -C$$$ -C - SAVE -C - DATA RERTH /6.3712E+6/, PI/3.14159/ -C -C PRELIMINARY VARIABLES AND REDIFINITIONS -C -C H = 1 FOR NORTHERN HEMISPHERE; = -1 FOR SOUTHERN -C - IF (ALATAN.GT.0) THEN - H = 1. - ELSE - H = -1. - ENDIF -C - RADPD = PI / 180.0 - REBYDX = RERTH / DX - ALATN1 = ALATAN * RADPD - AN = H * SIN(ALATN1) - COSLTN = COS(ALATN1) -C -C MAKE SURE THAT INPUT LONGITUDES DO NOT PASS THROUGH -C THE CUT ZONE (FORBIDDEN TERRITORY) OF THE FLAT MAP -C AS MEASURED FROM THE VERTICAL (REFERENCE) LONGITUDE. -C - ELON1L = ELON1 - IF ((ELON1 - ELONV).GT.180.) - & ELON1L = ELON1 - 360. - IF ((ELON1 - ELONV).LT.(-180.)) - & ELON1L = ELON1 + 360. -C - ELONL = ELON - IF ((ELON - ELONV).GT.180.) - & ELONL = ELON - 360. - IF ((ELON - ELONV).LT.(-180.)) - & ELONL = ELON + 360. -C - ELONVR = ELONV * RADPD -C -C RADIUS TO LOWER LEFT HAND (LL) CORNER -C - ALA1 = ALAT1 * RADPD - RMLL = REBYDX * (((COSLTN)**(1.-AN))*(1.+AN)**AN) * - & (((COS(ALA1))/(1.+H*SIN(ALA1)))**AN)/AN -C -C USE LL POINT INFO TO LOCATE POLE POINT -C - ELO1 = ELON1L * RADPD - ARG = AN * (ELO1-ELONVR) - POLEI = 1. - H * RMLL * SIN(ARG) - POLEJ = 1. + RMLL * COS(ARG) -C -C RADIUS TO DESIRED POINT AND THE I J TOO -C - ALA = ALAT * RADPD - RM = REBYDX * ((COSLTN**(1.-AN))*(1.+AN)**AN) * - & (((COS(ALA))/(1.+H*SIN(ALA)))**AN)/AN -C - ELO = ELONL * RADPD - ARG = AN*(ELO-ELONVR) - XI = POLEI + H * RM * SIN(ARG) - XJ = POLEJ - RM * COS(ARG) -C -C IF COORDINATE LESS THAN 1 -C COMPENSATE FOR ORIGIN AT (1,1) -C - IF (XI.LT.1.) XI = XI - 1. - IF (XJ.LT.1.) XJ = XJ - 1. -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fb12.f b/src/fim/FIMsrc/w3/w3fb12.f deleted file mode 100644 index 951f6e0..0000000 --- a/src/fim/FIMsrc/w3/w3fb12.f +++ /dev/null @@ -1,174 +0,0 @@ - SUBROUTINE W3FB12(XI,XJ,ALAT1,ELON1,DX,ELONV,ALATAN,ALAT,ELON, - & IERR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FB12 LAMBERT(I,J) TO LAT/LON FOR GRIB -C PRGMMR: STACKPOLE ORG: NMC42 DATE:88-11-28 -C -C ABSTRACT: CONVERTS THE COORDINATES OF A LOCATION ON EARTH GIVEN IN A -C GRID COORDINATE SYSTEM OVERLAID ON A LAMBERT CONFORMAL TANGENT -C CONE PROJECTION TRUE AT A GIVEN N OR S LATITUDE TO THE -C NATURAL COORDINATE SYSTEM OF LATITUDE/LONGITUDE -C W3FB12 IS THE REVERSE OF W3FB11. -C USES GRIB SPECIFICATION OF THE LOCATION OF THE GRID -C -C PROGRAM HISTORY LOG: -C 88-11-25 ORIGINAL AUTHOR: STACKPOLE, W/NMC42 -C 90-04-12 R.E.JONES CONVERT TO CFT77 FORTRAN -C 94-04-28 R.E.JONES ADD SAVE STATEMENT -C -C USAGE: CALL W3FB12(XI,XJ,ALAT1,ELON1,DX,ELONV,ALATAN,ALAT,ELON,IERR, -C IERR) -C INPUT ARGUMENT LIST: -C XI - I COORDINATE OF THE POINT REAL*4 -C XJ - J COORDINATE OF THE POINT REAL*4 -C ALAT1 - LATITUDE OF LOWER LEFT POINT OF GRID (POINT 1,1) -C LATITUDE <0 FOR SOUTHERN HEMISPHERE; REAL*4 -C ELON1 - LONGITUDE OF LOWER LEFT POINT OF GRID (POINT 1,1) -C EAST LONGITUDE USED THROUGHOUT; REAL*4 -C DX - MESH LENGTH OF GRID IN METERS AT TANGENT LATITUDE -C ELONV - THE ORIENTATION OF THE GRID. I.E., -C THE EAST LONGITUDE VALUE OF THE VERTICAL MERIDIAN -C WHICH IS PARALLEL TO THE Y-AXIS (OR COLUMNS OF -C THE GRID) ALONG WHICH LATITUDE INCREASES AS -C THE Y-COORDINATE INCREASES. REAL*4 -C THIS IS ALSO THE MERIDIAN (ON THE OTHER SIDE OF THE -C TANGENT CONE) ALONG WHICH THE CUT IS MADE TO LAY -C THE CONE FLAT. -C ALATAN - THE LATITUDE AT WHICH THE LAMBERT CONE IS TANGENT TO -C (TOUCHES OR OSCULATES) THE SPHERICAL EARTH. -C SET NEGATIVE TO INDICATE A -C SOUTHERN HEMISPHERE PROJECTION; REAL*4 -C -C OUTPUT ARGUMENT LIST: -C ALAT - LATITUDE IN DEGREES (NEGATIVE IN SOUTHERN HEMI.) -C ELON - EAST LONGITUDE IN DEGREES, REAL*4 -C IERR - .EQ. 0 IF NO PROBLEM -C .GE. 1 IF THE REQUESTED XI,XJ POINT IS IN THE -C FORBIDDEN ZONE, I.E. OFF THE LAMBERT MAP -C IN THE OPEN SPACE WHERE THE CONE IS CUT. -C IF IERR.GE.1 THEN ALAT=999. AND ELON=999. -C -C REMARKS: FORMULAE AND NOTATION LOOSELY BASED ON HOKE, HAYES, -C AND RENNINGER'S "MAP PROJECTIONS AND GRID SYSTEMS...", MARCH 1981 -C AFGWC/TN-79/003 -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256 -C -C$$$ -C - LOGICAL NEWMAP -C - SAVE -C - DATA RERTH /6.3712E+6/, PI/3.14159/, OLDRML/99999./ -C -C PRELIMINARY VARIABLES AND REDIFINITIONS -C -C H = 1 FOR NORTHERN HEMISPHERE; = -1 FOR SOUTHERN -C - IF (ALATAN.GT.0) THEN - H = 1. - ELSE - H = -1. - ENDIF -C - PIBY2 = PI / 2.0 - RADPD = PI / 180.0 - DEGPRD = 1.0 / RADPD - REBYDX = RERTH / DX - ALATN1 = ALATAN * RADPD - AN = H * SIN(ALATN1) - COSLTN = COS(ALATN1) -C -C MAKE SURE THAT INPUT LONGITUDE DOES NOT PASS THROUGH -C THE CUT ZONE (FORBIDDEN TERRITORY) OF THE FLAT MAP -C AS MEASURED FROM THE VERTICAL (REFERENCE) LONGITUDE -C - ELON1L = ELON1 - IF ((ELON1-ELONV).GT.180.) - & ELON1L = ELON1 - 360. - IF ((ELON1-ELONV).LT.(-180.)) - & ELON1L = ELON1 + 360. -C - ELONVR = ELONV * RADPD -C -C RADIUS TO LOWER LEFT HAND (LL) CORNER -C - ALA1 = ALAT1 * RADPD - RMLL = REBYDX * ((COSLTN**(1.-AN))*(1.+AN)**AN) * - & (((COS(ALA1))/(1.+H*SIN(ALA1)))**AN)/AN -C -C USE RMLL TO TEST IF MAP AND GRID UNCHANGED FROM PREVIOUS -C CALL TO THIS CODE. THUS AVOID UNNEEDED RECOMPUTATIONS. -C - IF (RMLL.EQ.OLDRML) THEN - NEWMAP = .FALSE. - ELSE - NEWMAP = .TRUE. - OLDRML = RMLL -C -C USE LL POINT INFO TO LOCATE POLE POINT -C - ELO1 = ELON1L * RADPD - ARG = AN * (ELO1-ELONVR) - POLEI = 1. - H * RMLL * SIN(ARG) - POLEJ = 1. + RMLL * COS(ARG) - ENDIF -C -C RADIUS TO THE I,J POINT (IN GRID UNITS) -C YY REVERSED SO POSITIVE IS DOWN -C - XX = XI - POLEI - YY = POLEJ - XJ - R2 = XX**2 + YY**2 -C -C CHECK THAT THE REQUESTED I,J IS NOT IN THE FORBIDDEN ZONE -C YY MUST BE POSITIVE UP FOR THIS TEST -C - THETA = PI*(1.-AN) - BETA = ABS(ATAN2(XX,-YY)) - IERR = 0 - IF (BETA.LE.THETA) THEN - IERR = 1 - ALAT = 999. - ELON = 999. - IF (.NOT.NEWMAP) RETURN - ENDIF -C -C NOW THE MAGIC FORMULAE -C - IF (R2.EQ.0) THEN - ALAT = H * 90.0 - ELON = ELONV - ELSE -C -C FIRST THE LONGITUDE -C - ELON = ELONV + DEGPRD * ATAN2(H*XX,YY)/AN - ELON = AMOD(ELON+360., 360.) -C -C NOW THE LATITUDE -C RECALCULATE THE THING ONLY IF MAP IS NEW SINCE LAST TIME -C - IF (NEWMAP) THEN - ANINV = 1./AN - ANINV2 = ANINV/2. - THING = ((AN/REBYDX) ** ANINV)/ - & ((COSLTN**((1.-AN)*ANINV))*(1.+ AN)) - ENDIF - ALAT = H*(PIBY2 - 2.*ATAN(THING*(R2**ANINV2)))*DEGPRD - ENDIF -C -C FOLLOWING TO ASSURE ERROR VALUES IF FIRST TIME THRU -C IS OFF THE MAP -C - IF (IERR.NE.0) THEN - ALAT = 999. - ELON = 999. - IERR = 2 - ENDIF - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fc02.f b/src/fim/FIMsrc/w3/w3fc02.f deleted file mode 100644 index 3ba871c..0000000 --- a/src/fim/FIMsrc/w3/w3fc02.f +++ /dev/null @@ -1,78 +0,0 @@ - SUBROUTINE W3FC02(FFID,FFJD,FGU,FGV,DIR,SPD) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FC02 GRID U,V WIND COMPS. TO DIR. AND SPEED -C AUTHOR: STACKPOLE, J. ORG: W324 DATE: 81-12-30 -C -C ABSTRACT: GIVEN THE GRID-ORIENTED WIND COMPONENTS ON A NORTHERN -C HEMISPHERE POLAR STEREOGRAPHIC GRID POINT, COMPUTE THE DIRECTION -C AND SPEED OF THE WIND AT THAT POINT. INPUT WINDS AT THE NORTH -C POLE POINT ARE ASSUMED TO HAVE THEIR COMPONENTS FOLLOW THE WMO -C STANDARDS FOR REPORTING WINDS AT THE NORTH POLE. -C (SEE OFFICE NOTE 241 FOR WMO DEFINITION). OUTPUT DIRECTION -C WILL FOLLOW WMO CONVENTION. -C -C PROGRAM HISTORY LOG: -C 81-12-30 J.STACKPOLE -C 89-01-20 R.E.JONES CONVERT TO MICROSOFT FORTRAN 4.10 -C 90-06-11 R.E.JONES CONVERT TO SUN FORTRAN 1.3 -C 91-03-30 R.E.JONES CONVERT TO SiliconGRaphics FORTRAN -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C 95-08-09 R.E.JONES COMPILE ON CRAY -C -C USAGE: CALL W3FC02 (FFID, FFJD, FGU, FGV, DIR, SPD) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C FFID ARG LIST REAL*4 I(NORTH POLE) - I(POINT) -C FFJD ARG LIST REAL*4 J(NORTH POLE) - J(POINT) -C FGU ARG LIST REAL*4 GRID-ORIENTED U-COMPONENT -C FGV ARG LIST REAL*4 GRID-ORIENTED V-COMPONENT -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C DIR ARG LIST REAL*4 WIND DIRECTION, DEGREES -C SPD ARG LIST REAL*4 WIND SPEED -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C ABS ACOS ATAN2 SQRT SYSTEM -C -C WARNING: THIS JOB WILL NOT VECTORIZE ON A CRAY -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916/16256, J916/162048 -C -C$$$ -C - SAVE -C - SPD = SQRT(FGU * FGU + FGV * FGV) - IF (SPD.NE.0.) GO TO 1000 - FGU = 0. - FGV = 0. - GO TO 3000 - 1000 CONTINUE - DFP = SQRT(FFID * FFID + FFJD * FFJD) - IF (DFP.NE.0.) GO TO 2000 - XLAM = ACOS(FGU / SPD) - XLAM = XLAM * 57.29578 - IF (FGV.LT.0.) DIR = 170. + XLAM - IF ((FGV.GT.0.).AND.(XLAM.LT.170.)) DIR = 170. - XLAM - IF ((FGV.GT.0.).AND.(XLAM.GE.170.)) DIR = 530. - XLAM - IF ((ABS(FGV).LE.0.001).AND.(FGU.GT.0.)) DIR = 170. - IF ((ABS(FGV).LE.0.001).AND.(FGU.LT.0.)) DIR = 350. - GO TO 3000 - 2000 CONTINUE - CAL = FFJD / DFP - SAL = FFID / DFP - U = FGU * CAL - FGV * SAL - V = FGU * SAL + FGV * CAL - DIR = 57.29578 * ATAN2(U,V) + 180. - 3000 CONTINUE - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fc05.f b/src/fim/FIMsrc/w3/w3fc05.f deleted file mode 100644 index 807dbad..0000000 --- a/src/fim/FIMsrc/w3/w3fc05.f +++ /dev/null @@ -1,68 +0,0 @@ - SUBROUTINE W3FC05(U, V, DIR, SPD) 11260000 -C$$$ SUBPROGRAM DOCUMENTATION BLOCK 11270000 -C . . . . 11280000 -C SUBPROGRAM: W3FC05 EARTH U,V WIND COMPONENTS TO DIR AND SPD 11290000 -C PRGMMR: KEYSER ORG: W/NMC22 DATE: 92-10-21 11300000 -C 11310000 -C ABSTRACT: GIVEN THE TRUE (EARTH ORIENTED) WIND COMPONENTS 11320000 -C COMPUTE THE WIND DIRECTION AND SPEED. 11330000 -C INPUT WINDS AT THE POLE ARE ASSUMED TO FOLLOW THE WMO 11340000 -C CONVENTIONS, WITH THE OUTPUT DIRECTION COMPUTED IN ACCORDANCE 11350000 -C WITH WMO STANDARDS FOR REPORTING WINDS AT THE POLE. 11360000 -C (SEE OFFICE NOTE 241 FOR WMO DEFINITION.) 11370000 -C 11380000 -C PROGRAM HISTORY LOG: 11390000 -C 92-10-21 D.A.KEYSER ADDED 1.E-3 TO DIRECTION TO ALLOW TRUNCATION 11391000 -C TO NEAREST WHOLE DEGREE TO BE CORRECT 11391100 -C (KEEPS AGREEMENT BETWEEN CRAY & NAS VERSIONS) 11391200 -C 91-03-05 R.E.JONES CHANGES FOR CRAY CFT77 FORTRAN 11391300 -C 88-10-19 CHASE, P. ALLOW OUTPUT VALUES TO OVERLAY INPUT 11392000 -C 81-12-30 STACKPOLE, JOHN 11400000 -C 11430000 -C USAGE: CALL W3FC05 (U, V, DIR, SPD) 11440000 -C 11450000 -C INPUT ARGUMENT LIST: 11460000 -C U - REAL EARTH-ORIENTED U-COMPONENT 11470001 -C V - REAL EARTH-ORIENTED V-COMPONENT 11480001 -C 11490000 -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) 11500000 -C DIR - REAL WIND DIRECTION, DEGREES. VALUES WILL 11510001 -C BE FROM 0 TO 360 INCLUSIVE. 11520000 -C SPD - REAL WIND SPEED IN SAME UNITS AS INPUT 11530001 -C 11540000 -C INPUT FILES: NONE 11550000 -C 11560000 -C OUTPUT FILES: NONE 11570000 -C 11580000 -C SUBPROGRAMS CALLED: 11590000 -C LIBRARY: 11600000 -C COMMON - SQRT, ATAN2 11610000 -C 11620000 -C REMARKS: IF SPEED IS LESS THAN 1E-10 THEN DIRECTION WILL BE SET 11630000 -C TO ZERO. 11640000 -C 11650000 -C ATTRIBUTES: 11660000 -C LANGUAGE: CRAY CFT77 FORTRAN 11670000 -C MACHINE: CRAY Y-MP8/832 11680000 -C 11690000 -C$$$ 11700000 -C 11710000 -C VARIABLES..... 11720000 -C 11730000 - REAL U, V, DIR, SPD, XSPD 11740000 -C 11750000 -C CONSTANTS..... 11760000 -C 11770000 - DATA SPDTST/1.0E-10/ 11780000 - DATA RTOD /57.2957795/ 11790000 - DATA DCHALF/180.0/ 11800000 -C 11810000 - XSPD = SQRT(U * U + V * V) 11820000 - IF (XSPD .LT. SPDTST) THEN 11830000 - DIR = 0.0 11840000 - ELSE 11850000 - DIR = ATAN2(U,V) * RTOD + DCHALF + 1.E-3 11860000 - ENDIF 11870000 - SPD = XSPD 11880000 - RETURN 11890000 - END 11900000 diff --git a/src/fim/FIMsrc/w3/w3fc06.f b/src/fim/FIMsrc/w3/w3fc06.f deleted file mode 100644 index f11fd1a..0000000 --- a/src/fim/FIMsrc/w3/w3fc06.f +++ /dev/null @@ -1,53 +0,0 @@ - SUBROUTINE W3FC06(DIR,SPD,U,V) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FC06 WIND DIR AND SPD TO EARTH U,V COMPONENTS -C AUTHOR: STACKPOLE ORG: W324 DATE: 81-12-30 -C -C ABSTRACT: GIVEN THE WIND DIRECTION AND SPEED, -C COMPUTE EARTH-ORIENTED (TRUE) WIND COMPONENTS. -C INPUT DIRECTION AT THE POLE POINT -C MUST BE CONSISTENT WITH WMO CONVENTIONS, AND OUTPUT COMPONENTS -C WILL FOLLOW THOSE CONVENTIONS. -C (SEE OFFICE NOTE 241 FOR WMO DEFINITION.) -C -C PROGRAM HISTORY LOG: -C 81-12-30 J.STACKPOLE -C 91-03-06 R.E.JONES CHANGE TO CRAY CFT77 FORTRAN -C -C USAGE: CALL W3FC06 (DIR, SPD, U, V) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C DIR - REAL*4 - WIND DIRECTION, DEGREES -C SPD - REAL*4 - WIND SPEED, ANY UNITS -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C U - REAL*4 - EARTH-ORIENTED U-COMPONENT -C V - REAL*4 - EARTH-ORIENTED V-COMPONENT -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C SIN COS SYSTEM -C -C WARNING: THIS CODE WILL NOT VECTORIZE ON CRAY, YOU COULD -C PUT THE FOUR LINES IN YOUR CODE WITH A COUPLE OF -C DO LOOPS. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916-128, Y-MP8/864, Y-MP EL92/256 -C -C$$$ -C - XSPD = -SPD - DIRL = 0.0174533 * DIR - U = XSPD * SIN(DIRL) - V = XSPD * COS(DIRL) -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fc07.f b/src/fim/FIMsrc/w3/w3fc07.f deleted file mode 100644 index 2da9226..0000000 --- a/src/fim/FIMsrc/w3/w3fc07.f +++ /dev/null @@ -1,69 +0,0 @@ - SUBROUTINE W3FC07(FFID, FFJD, FGU, FGV, FU, FV) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FC07 GRID U-V TO EARTH U-V IN NORTH HEM. -C PRGMMR: CHASE ORG: NMC421 DATE:88-10-26 -C -C ABSTRACT: GIVEN THE GRID-ORIENTED WIND COMPONENTS ON A NORTHERN -C HEMISPHERE POLAR STEREOGRAPHIC GRID POINT, COMPUTE THE EARTH- -C ORIENTED WIND COMPONENTS AT THAT POINT. IF THE INPUT WINDS -C ARE AT THE NORTH POLE, THE OUTPUT COMPONENTS WILL BE MADE -C CONSISTENT WITH THE WMO STANDARDS FOR REPORTING WINDS AT THE -C NORTH POLE. (SEE OFFICE NOTE 241 FOR WMO DEFINITION.) -C -C PROGRAM HISTORY LOG: -C 81-12-30 STACKPOLE, J. D. -C 88-10-13 CHASE, P. ALLOW INPUT AND OUTPUT TO BE THE SAME -C 91-03-06 R.E.JONES CHANGE TO CRAY CFT77 FORTRAN -C -C USAGE: CALL W3FC07 (FFID, FFJD, FGU, FGV, FU, FV) -C -C INPUT ARGUMENT LIST: -C FFID - REAL I-DISPLACEMENT FROM POINT TO NORTH POLE -C FFJD - REAL J-DISPLACEMENT FROM POINT TO NORTH POLE -C FGU - REAL GRID-ORIENTED U-COMPONENT -C FGV - REAL GRID-ORIENTED V-COMPONENT -C -C OUTPUT ARGUMENT LIST: -C FU - REAL EARTH-ORIENTED U-COMPONENT, POSITIVE FROM WEST -C MAY REFERENCE THE SAME LOCATION AS FGU. -C FV - REAL EARTH-ORIENTED V-COMPONENT, POSITIVE FROM SOUTH -C MAY REFERENCE THE SAME LOCATION AS FGV. -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C COMMON - SQRT -C -C REMARKS: CALCULATE FFID AND FFJD AS FOLLOWS... -C FFID = REAL(IP - I) -C FFJD = REAL(JP - J) -C WHERE (IP,JP) IS THE GRID COORDINATES OF THE NORTH POLE AND -C (I,J) IS THE GRID COORDINATES OF THE POINT WHERE FGU AND FGV -C OCCUR. -C SEE W3FC11 FOR A SOUTHERN HEMISPHERE COMPANION SUBROUTINE. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256 -C -C$$$ -C - SAVE -C - DATA COS80 / 0.1736482 / - DATA SIN80 / 0.9848078 / - -C COS80 AND SIN80 ARE FOR WIND AT POLE -C (USED FOR CO-ORDINATE ROTATION TO EARTH ORIENTATION) - - DFP = SQRT(FFID * FFID + FFJD * FFJD) - IF (DFP .EQ. 0.0) THEN - XFU = -(FGU * COS80 + FGV * SIN80) - FV = -(FGV * COS80 - FGU * SIN80) - ELSE - XFU = (FGU * FFJD - FGV * FFID) / DFP - FV = (FGU * FFID + FGV * FFJD) / DFP - ENDIF - FU = XFU - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fc08.f b/src/fim/FIMsrc/w3/w3fc08.f deleted file mode 100644 index 454a9d5..0000000 --- a/src/fim/FIMsrc/w3/w3fc08.f +++ /dev/null @@ -1,74 +0,0 @@ - SUBROUTINE W3FC08(FFID, FFJD, FU, FV, FGU, FGV) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FC08 U-V COMPS FROM EARTH TO NORTH HEM GRID -C PRGMMR: CHASE ORG: NMC421 DATE:88-10-26 -C -C ABSTRACT: GIVEN THE EARTH-ORIENTED WIND COMPONENTS ON A NORTHERN -C HEMISPHERE POLAR STEREOGRAPHIC GRID POINT, COMPUTE THE GRID- -C ORIENTED COMPONENTS AT THAT POINT. INPUT WIND COMPONENTS AT THE -C NORTH POLE POINT ARE ASSUMED TO CONFORM TO -C THE 'WMO' STANDARDS FOR REPORTING WINDS AT THE NORTH POLE, WITH -C THE OUTPUT COMPONENTS COMPUTED RELATIVE TO THE X-Y AXES ON THE -C GRID. (SEE OFFICE NOTE 241 FOR WMO DEFINITION.) -C -C PROGRAM HISTORY LOG: -C 81-12-30 STACKPOLE, J. -C 88-10-18 CHASE, P. LET OUTPUT VARIABLES OVERLAY INPUT -C 91-03-06 R.E.JONES CHANGE TO CRAY CFT77 FORTRAN -C -C USAGE: CALL W3FC08 (FFID, FFJD, FU, FV, FGU, FGV) -C -C INPUT ARGUMENT LIST: -C FFID - REAL I-DISPLACEMENT FROM POINT TO NORTH POLE IN -C GRID UNITS -C FFJD - REAL J-DISPLACEMENT FROM POINT TO NORTH POLE IN -C GRID UNITS -C FU - REAL EARTH-ORIENTED U-COMPONENT, POSITIVE FROM WEST -C FV - REAL EARTH-ORIENTED V-COMPONENT, POSITIVE FROM EAST -C -C OUTPUT ARGUMENT LIST: -C FGU - REAL GRID-ORIENTED U-COMPONENT. MAY REFERENCE -C SAME LOCATION AS FU. -C FGV - REAL GRID-ORIENTED V-COMPONENT. MAY REFERENCE -C SAME LOCATION AS FV. -C -C INPUT FILES: NONE -C -C OUTPUT FILES: NONE -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C COMMON - SQRT -C -C REMARKS: FFID AND FFJD MAY BE CALCULATED AS FOLLOWS..... -C FFID = REAL(IP - I) -C FFJD = REAL(JP - J) -C WHERE (IP, JP) ARE THE GRID COORDINATES OF THE NORTH POLE AND -C (I,J) ARE THE GRID COORDINATES OF THE POINT. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256 -C -C$$$ -C - SAVE -C - DATA COS280/ 0.1736482 / - DATA SIN280/ -0.9848078 / -C -C COS280 AND SIN280 ARE FOR WIND AT POLE -C (USED FOR CO-ORDINATE ROTATION TO GRID ORIENTATION) -C - DFP = SQRT(FFID * FFID + FFJD * FFJD) - IF (DFP .EQ. 0.) THEN - XFGU = -(FU * COS280 + FV * SIN280) - FGV = -(FV * COS280 - FU * SIN280) - ELSE - XFGU = (FU * FFJD + FV * FFID) / DFP - FGV = (FV * FFJD - FU * FFID) / DFP - ENDIF - FGU = XFGU - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fi01.f b/src/fim/FIMsrc/w3/w3fi01.f deleted file mode 100644 index a4d87db..0000000 --- a/src/fim/FIMsrc/w3/w3fi01.f +++ /dev/null @@ -1,33 +0,0 @@ - SUBROUTINE W3FI01(LW) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI01 DETERMINES MACHINE WORD LENGTH IN BYTES -C PRGMMR: KEYSER ORG: W/NMC22 DATE: 06-29-92 -C -C ABSTRACT: DETERMINES THE NUMBER OF BYTES IN A FULL WORD FOR THE -C PARTICULAR MACHINE (IBM OR CRAY). -C -C PROGRAM HISTORY LOG: -C 92-01-10 R. KISTLER (W/NMC23) -C 92-05-22 D. A. KEYSER -- DOCBLOCKED/COMMENTED -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 2001-06-07 Gilbert Uses f90 standard routine bit_size to -C find integer word length -C -C USAGE: CALL W3FI01(LW) -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C LW - MACHINE WORD LENGTH IN BYTES -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ -C - INTEGER LW - LW=BIT_SIZE(LW) - LW=LW/8 - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fi02.f b/src/fim/FIMsrc/w3/w3fi02.f deleted file mode 100644 index 0568789..0000000 --- a/src/fim/FIMsrc/w3/w3fi02.f +++ /dev/null @@ -1,43 +0,0 @@ - SUBROUTINE W3FI02(IN,IDEST,NUM) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI02 TRANSFERS ARRAY FROM 16 TO 64 BIT WORDS -C PRGMMR: KEYSER ORG: W/NMC22 DATE: 06-29-92 -C -C ABSTRACT: TRANSFERS AN ARRAY OF NUMBERS FROM 16 BIT (IBM INTEGER*2) -C IBM HALF-WORDS TO DEFAULT INTEGERS. -C -C PROGRAM HISTORY LOG: -C 92-06-29 D. A. KEYSER (W/NMC22) -C 98-11-17 Gilbert Removed Cray references -C -C USAGE: CALL W3FI02(IN,IDEST,NUM) -C INPUT ARGUMENT LIST: -C IN - STARTING ADDRESS FOR ARRAY OF 16 BIT IBM HALF-WORDS -C NUM - NUMBER OF NUMBERS IN 'IN' TO TRANSFER. -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C IDEST - STARTING ADDRESS FOR ARRAY OF OUTPUT INTEGERS -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C NONE -C -C REMARKS: THIS IS THE INVERSE OF LIBRARY ROUTINE W3FI03. -C -C ATTRIBUTES: -C LANGUAGE: IBM XL FORTRAN -C MACHINE: IBM SP -C -C$$$ -C - INTEGER(2) IN(*) - INTEGER IDEST(*) -C - SAVE -C -C CALL USICTC(IN,1,IDEST,NUM,2) - IDEST(1:NUM)=IN(1:NUM) -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fi03.f b/src/fim/FIMsrc/w3/w3fi03.f deleted file mode 100644 index 2d99f8f..0000000 --- a/src/fim/FIMsrc/w3/w3fi03.f +++ /dev/null @@ -1,48 +0,0 @@ - SUBROUTINE W3FI03(IN,IDEST,NUM,IER) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI03 TRANSFERS DEFAULT INTEGERS TO 16 BIT INTS -C PRGMMR: KEYSER ORG: W/NMC22 DATE: 06-29-92 -C -C ABSTRACT: TRANSFERS AN ARRAY OF NUMBERS FROM DEFAULT INTEGER -C WORDS TO 16 BIT (IBM INTEGER*2) IBM HALF-WORDS. -C -C PROGRAM HISTORY LOG: -C 92-06-29 D. A. KEYSER (W/NMC22) -C 98-11-17 Gilbert Removed Cray references -C -C USAGE: CALL W3FI03(IN,IDEST,NUM,IER) -C INPUT ARGUMENT LIST: -C IN - STARTING ADDRESS FOR ARRAY OF DEFAULT INTEGERS -C NUM - NUMBER OF NUMBERS IN 'IN' TO TRANSFER. -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C IDEST - STARTING ADDRESS FOR ARRAY OF 16 BIT IBM HALF-WORDS -C IER - ERROR RETURN CODE AS FOLLOWS: -C IER = 0 - TRANSFER SUCCESSFUL, ALL NUMBERS -C - TRANSFERRED WITHOUT OVERFLOW -C IER = 1 - THE TRANSFER OF ONE OR MORE NUMBERS -C - RESULTED IN AN OVERFLOW -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C NONE -C -C REMARKS: THIS IS THE INVERSE OF LIBRARY ROUTINE W3FI02. -C -C ATTRIBUTES: -C LANGUAGE: IBM XL FORTRAN -C MACHINE: IBM SP -C -C$$$ -C - INTEGER(2) IDEST(*) - INTEGER IN(*) -C - SAVE -C -C CALL USICTI(IN,IDEST,1,NUM,2,IER) - IDEST(1:NUM)=IN(1:NUM) -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fi04.f b/src/fim/FIMsrc/w3/w3fi04.f deleted file mode 100644 index 72197da..0000000 --- a/src/fim/FIMsrc/w3/w3fi04.f +++ /dev/null @@ -1,122 +0,0 @@ - SUBROUTINE W3FI04(IENDN,ITYPEC,LW) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FI04 FIND WORD SIZE, ENDIAN, CHARACTER SET -C PRGMNR: JONES,R.E. ORG: W/NMC42 DATE: 94-10-07 -C -C ABSTRACT: SUBROUTINE COMPUTES WORD SIZE, THE TYPE OF CHARACTER -C SET, ASCII OR EBCDIC, AND IF THE COMPUTER IS BIG-ENDIAN, OR -C LITTLE-ENDIAN. -C -C PROGRAM HISTORY LOG: -C 94-10-07 R.E.JONES -C 98-07-08 Gilbert - Removed the Fortran SAVE Statement. -C The SAVE statement is not needed for this -C routine, and may have been causing errors -C using the f90 compiler under the 2.0 -C Programming Environment. -C 02-10-15 Vuong Replaced Function ICHAR with mova2i -C -C USAGE: CALL W3FI04 (IENDN, ITYPEC, LW) -C -C OUTPUT ARGUMENT LIST: -C IENDN - INTEGER FOR BIG-ENDIAN OR LITTLE-ENDIAN -C = 0 BIG-ENDIAN -C = 1 LITTLE-ENDIAN -C = 2 CANNOT COMPUTE -C ITYPEC - INTEGER FOR TYPE OF CHARACTER SET -C = 0 ASCII CHARACTER SET -C = 1 EBCDIC CHARACTER SET -C = 2 NOT ASCII OR EBCDIC -C LW - INTEGER FOR WORDS SIZE OF COMPUTER IN BYTES -C = 4 FOR 32 BIT COMPUTERS -C = 8 FOR 64 BIT COMPUTERS -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916/256, Y-MP8/64, Y-MP EL92/256, J916/2048 -C -C$$$ -C - INTEGER ITEST1 - INTEGER ITEST2 - INTEGER ITEST3 - INTEGER IENDN - INTEGER ITYPEC - INTEGER LW -C - CHARACTER * 8 CTEST1 - CHARACTER * 8 CTEST2 - CHARACTER * 1 CTEST3(8) - CHARACTER * 1 BLANK -C - EQUIVALENCE (CTEST1,ITEST1),(CTEST2,ITEST2) -C - EQUIVALENCE (ITEST3,CTEST3(1)) -C - DATA CTEST1/'12345678'/ - DATA ITEST3/Z'01020304'/ - DATA BLANK /' '/ -C -C SAVE -C -C TEST FOR TYPE OF CHARACTER SET -C BLANK IS 32 (20 HEX) IN ASCII, 64 (40 HEX) IN EBCDEC -C - IF (MOVA2I(BLANK).EQ.32) THEN - ITYPEC = 0 - ELSE IF (MOVA2I(BLANK).EQ.64) THEN -C -C COMPUTER IS PROBABLY AN IBM360, 370, OR 390 WITH -C A 32 BIT WORD SIZE, AND BIG-ENDIAN. -C - ITYPEC = 1 - ELSE - ITYPEC = 2 - END IF -C -C TEST FOR WORD SIZE, SET LW TO 4 FOR 32 BIT COMPUTER, -C 8 FOR FOR 64 BIT COMPUTERS -C - ITEST2 = ITEST1 - IF (CTEST1 .EQ. CTEST2) THEN -C -C COMPUTER MAY BE A CRAY, OR COULD BE DEC VAX ALPHA -C OR SGI WITH R4000, R4400, R8800 AFTER THEY CHANGE -C FORTRAN COMPILERS FOR 64 BIT INTEGER. -C - LW = 8 - ELSE - LW = 4 - ENDIF -C -C USING ITEST3 WITH Z'01020304' EQUIVALNCED TO CTEST3 -C ON A 32 BIT BIG-ENDIAN COMPUTER 03 IS IN THE 3RD -C BYTE OF A 4 BYTE WORD. ON A 32 BIT LITTLE-ENDIAN -C COMPUTER IT IS IN 2ND BYTE. -C ON A 64 BIT COMPUTER Z'01020304' IS RIGHT ADJUSTED IN -C A 64 BIT WORD, 03 IS IN THE 7TH BYTE. ON A LITTLE- -C ENDIAN 64 BIT COMPUTER IT IS IN THE 2ND BYTE. -C - IF (LW.EQ.4) THEN - IF (MOVA2I(CTEST3(3)).EQ.3) THEN - IENDN = 0 - ELSE IF (MOVA2I(CTEST3(3)).EQ.2) THEN - IENDN = 1 - ELSE - IENDN = 2 - END IF - ELSE IF (LW.EQ.8) THEN - IF (MOVA2I(CTEST3(7)).EQ.3) THEN - IENDN = 0 - ELSE IF (MOVA2I(CTEST3(2)).EQ.3) THEN - IENDN = 1 - ELSE - IENDN = 2 - END IF - ELSE - IENDN = 2 - END IF -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fi18.f b/src/fim/FIMsrc/w3/w3fi18.f deleted file mode 100644 index 5986228..0000000 --- a/src/fim/FIMsrc/w3/w3fi18.f +++ /dev/null @@ -1,59 +0,0 @@ - SUBROUTINE W3FI18(I,J,NW) -C$$$ SUBROUTINE DOCUMENTATION BLOCK *** -C -C SUBR: W3FI18 - NMC OCTAGON BOUNDARY FINDING SUBROUTINE -C AUTHOR: HOWCROFT, J. ORG: W342 DATE: OCT 73 -C UPDATE: JONES, R.E. ORG: W342 DATE: 02 JUL 84 -C -C ABSTRACT: RELATES THE I,J COORDINATE POINT IN A 65X65 GRID-POINT -C ARRAY AS BEING EITHER INSIDE, OUTSIDE, OR ON THE BOUNDARY OF THE -C NMC OCTAGON CENTERED IN THE 65X65 ARRAY. -C -C PROGRAM HISTORY LOG: -C 73-10-15 HOWCROFT,J. -C 84-07-02 R.E.JONES CONVERT TO FORTRAN 77 -C 89-02-02 R.E.JONES CONVERT TO MICROSOFT FORTRAN 4.10 -C 90-06-12 R.E.JONES CONVERT TO SUN FORTRAN 1.3 -C 91-03-16 R.E.JONES CONVERT TO SiliconGraphics 3.3 FORTRAN 77 -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C -C USAGE: CALL W3FI18 (I, J, NW) -C -C INPUT: -C ' I' - COORDINATE IDENTIFICATION OF A POINT IN THE 65X65 ARRAY -C ' J' - COORDINATE IDENTIFICATION OF A POINT IN THE 65X65 ARRAY -C OUTPUT: -C 'NW' - INTEGER RETURN CODE -C -C EXIT STATES: -C NW = -1 POINT IS OUTSIDE THE OCTAGON -C NW = 0 POINT IS ON THE OCTAGON BOUNDARY -C NW = +1 POINT IS INSIDE THE OCTAGON -C -C EXTERNAL REFERENCES: NONE -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916/256, J916/2048. -C -C$$$ -C - SAVE -C - K = I + J - M = I - J - IF (I.LT.10.OR.I.GT.56.OR.J.LT.8.OR.J.GT.58) GO TO 10 - IF (K.LT.32.OR.K.GT.100.OR.M.LT.-34.OR.M.GT.34) GO TO 10 - IF (I.EQ.10.OR.I.EQ.56.OR.J.EQ.8.OR.J.EQ.58) GO TO 20 - IF (K.EQ.32.OR.K.EQ.100.OR.M.EQ.-34.OR.M.EQ.34) GO TO 20 - NW = 1 - RETURN -C - 10 CONTINUE - NW = -1 - RETURN -C - 20 CONTINUE - NW = 0 - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fi19.f b/src/fim/FIMsrc/w3/w3fi19.f deleted file mode 100644 index cf1a61b..0000000 --- a/src/fim/FIMsrc/w3/w3fi19.f +++ /dev/null @@ -1,55 +0,0 @@ - SUBROUTINE W3FI19(I,J,NW) -C$$$ SUBROUTINE DOCUMENTATION BLOCK *** -C -C SUBR: W3FI19 - NMC RECTANGLE BOUNDARY FINDING SUBROUTINE -C AUTHOR: HOWCROFT, J. ORG: W342 DATE: OCT 83 -C UPDATE: JONES, R.E. ORG: W342 DATE: 02 JUL 84 -C -C ABSTRACT: RELATES THE I,J COORDINATE POINT IN A 65X65 GRID-POINT -C ARRAY AS BEING EITHER INSIDE, OUTSIDE, OR ON THE BOUNDARY OF THE -C 53X57 NMC RECTANGLE CENTERED IN THE 65X65 ARRAY. -C -C PROGRAM HISTORY LOG: -C 73-10-15 HOWCROFT,J. -C 84-07-02 R.E.JONES CONVERT TO FORTRAN 77 -C 89-02-02 R.E.JONES CONVERT TO MICROSOFT FORTRAN 4.10 -C 90-06-12 R.E.JONES CONVERT TO SUN FORTRAN 1.3 -C 91-03-16 R.E.JONES CONVERT to SiliconGraphics 3.3 FORTRAN 77 -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C -C USAGE: CALL W3FI19 (I, J, NW) -C -C INPUT: -C ' I' - COORDINATE IDENTIFICATION OF A POINT IN THE 65X65 ARRAY -C ' J' - COORDINATE IDENTIFICATION OF A POINT IN THE 65X65 ARRAY -C OUTPUT: -C 'NW' - INTEGER RETURN CODE -C -C EXIT STATES: -C NW = -1 POINT IS OUTSIDE THE RECTANGLE -C NW = 0 POINT IS ON THE RECTANGLE BOUNDARY -C NW = +1 POINT IS INSIDE THE RECTANGLE -C -C EXTERNAL REFERENCES: NONE -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916/256, J916/2048. -C -C$$$ -C - SAVE -C - IF (I.LT.7.OR.I.GT.59.OR.J.LT.5.OR.J.GT.61) GO TO 10 - IF (I.EQ.7.OR.I.EQ.59.OR.J.EQ.5.OR.J.EQ.61) GO TO 20 - NW = 1 - RETURN -C - 10 CONTINUE - NW = -1 - RETURN -C - 20 CONTINUE - NW = 0 - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fi20.f b/src/fim/FIMsrc/w3/w3fi20.f deleted file mode 100644 index fc2d499..0000000 --- a/src/fim/FIMsrc/w3/w3fi20.f +++ /dev/null @@ -1,74 +0,0 @@ - SUBROUTINE W3FI20(A,B) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FI20 CUT A 65 X 65 GRID TO A NMC 1977 POINT GRID -C AUTHOR: JONES, R.E. ORG: W342 DATE: 84-07-02 -C -C ABSTRACT: EXTRACTS THE NMC 1977 POINT OCTAGON GRID POINTS OUT OF -C A 65X65 (4225 POINT) ARRAY. -C -C PROGRAM HISTORY LOG: -C 73-06-15 R.E.JONES -C 84-07-02 R.E.JONES CONVERT TO VS FORTRAN -C 89-02-02 R.E.JONES CONVERT TO MICROSOFT FORTRAN 4.10 -C 90-08-22 R.E.JONES CONVERT TO SUN FORTRAN 1.3 -C 91-03-29 R.E.JONES CONVERT TO SiliconGraphics FORTRAN -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C -C USAGE: CALL W3FI20 (A,B) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C A ARG LIST REAL*4 (65 X 65 GRID, 4225 POINT) ARRAY -C GRID IS OFFICE NOTE 84 TYPE 27 OR 1B HEX -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C B ARG LIST 1977 POINT ARRAY (OCTAGON) OFFICE NOTE 84 TYPE -C 0 OR HEX 0. -C -C REMARKS: ARRAYS A AND B MAY BE THE SAME ARRAY OR BE EQUIVALENCED, -C IN WHICH CASE THE FIRST 1977 WORDS OF 'A' ARE WRITTEN OVER. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916/256, J916/2048. -C -C$$$ -C - REAL A(*) - REAL B(*) -C - INTEGER RB - INTEGER LBR(51) - INTEGER RBR(51) -C - SAVE -C - DATA LBR/479,543,607,671,735,799,863,927,991,1055,1119,1183,1247, - &1311,1375,1440,1505,1570,1635,1700,1765,1830,1895,1960,2025,2090, - &2155,2220,2285,2350,2415,2480,2545,2610,2675,2740,2805,2871,2937, - &3003,3069,3135,3201,3267,3333,3399,3465,3531,3597,3663,3729/ -C - DATA RBR/497,563,629,695,761,827,893,959,1025,1091,1157,1223,1289, - &1355,1421,1486,1551,1616,1681,1746,1811,1876,1941,2006,2071,2136, - &2201,2266,2331,2396,2461,2526,2591,2656,2721,2786,2851,2915,2979, - &3043,3107,3171,3235,3299,3363,3427,3491,3555,3619,3683,3747/ -C - N = 0 -C - DO 200 I = 1,51 - LB = LBR(I) - RB = RBR(I) -C - DO 100 J = LB,RB - N = N + 1 - B(N) = A(J) - 100 CONTINUE -C - 200 CONTINUE -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fi32.f b/src/fim/FIMsrc/w3/w3fi32.f deleted file mode 100644 index 8ee5f71..0000000 --- a/src/fim/FIMsrc/w3/w3fi32.f +++ /dev/null @@ -1,156 +0,0 @@ - SUBROUTINE W3FI32(LARRAY,KIDNT) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI32 PACK ID'S INTO OFFICE NOTE 84 FORMAT -C PRGMMR: NIEROW, A. ORG: W345 DATE: 86-02-07 -C -C ABSTRACT: CONVERTS AN ARRAY OF THE 27 DATA FIELD IDENTIFIERS INTO -C AN ARRAY OF THE FIRST 8 IDENTIFICATION WORDS OF THE FORMAT DE- -C SCRIBED IN NMC OFFICE NOTE 84 (89-06-15, PAGE-35). ON A CRAY -C THEY WILL FIT INTO FOUR 64 BIT INTEGER WORDS. -C -C PROGRAM HISTORY LOG: -C 86-02-07 A.NIEROW -C 89-10-24 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C 91-03-19 R.E.JONES CHANGES FOR BIG RECORDS -C 98-03-10 B. VUONG REMOVE THE CDIR$ INTEGER=64 DIRECTIVE -C 1999-03-15 Gilbert Specified 8-byte integer array explicitly -C -C USAGE: CALL W3FI32(LARRAY, KIDNT) -C INPUT ARGUMENT LIST: -C LARRAY - INTEGER ARRAY CONTAINING 27 DATA FIELD -C IDENTIFIERS (SEE O.N. 84) -C -C OUTPUT ARGUMENT LIST: -C KIDNT - INTEGER ARRAY OF 6 WORDS, 12 OFFICE NOTE 84 32 BIT -C WORDS, FIRST 4 WORDS ARE MADE BY W3FI32, IF YOU ARE -C USING PACKER W3AI00, IT WILL COMPUTE WORD 5 AND 6. -C (OFFICE NOTE 84 WORDS 9,10, 11 AND 12). IF J THE -C WORD COUNT IN WORD 27 OF LARRAY IS GREATER THAN -C 32743 THEN BITS 15-0 OF THE 4TH ID WORD ARE SET TO -C ZERO, J IS STORED IN BITS 31-0 OF THE 6TH ID WORD. -C ID WORD 5 IS SET ZERO, BIT 63-32 OF THE 6TH ID -C WORD ARE SET ZERO. NOTE: BIS ARE NUMBER LEFT TO -C RIGHT ON THE CRAY AS 63-0. -C -C OUTPUT FILES: -C UNIT6 - STANDARD FORTRAN PRINT FILE -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C BIT MANIPULATION - IAND, IOR ISHFT -C -C REMARKS: EXIT STATES PRINTED MESSAGES: -C IF ANY NUMBER N IN (LARRAY(I),I=1,27) IS ERRONEOUSLY LARGE: -C 'VALUE IN LARRAY(I)=N IS TOO LARGE TO PACK' -C IF ANY NUMBER N IN (LARRAY(I),I=1,27) IS ERRONEOUSLY NEGATIVE: -C 'VALUE IN LARRAY(I)=N SHOULD NOT BE NEGATIVE' -C IN EITHER OF THE ABOVE SITUATIONS, THAT PORTION OF THE PACKED -C WORD CORRESPONDING TO LARRAY(I) WILL BE SET TO BINARY ONES. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN INTEGER=64 -C MACHINE: CRAY Y-MP8/864 -C -C$$$ -C - INTEGER(8) LARRAY(27) - INTEGER(8) ITABLE(27) - INTEGER(8) KIDNT(*) - INTEGER(8) KX,MASK,MASK16,ISC,ITEMP8 -C - SAVE -C - DATA ITABLE/X'0000000000340C01',X'0000000000280C01', - & X'0000000000200801',X'00000000001C0401', - & X'0000000001081401',X'0000000001000801', - & X'00000000003C0402',X'0000000000340802', - & X'0000000000280C02',X'0000000000200802', - & X'00000000001C0402',X'0000000001081402', - & X'0000000001000802',X'0000000000380803', - & X'0000000000300803',X'0000000000280803', - & X'0000000000200803',X'00000000001C0403', - & X'0000000000100C03',X'0000000000001003', - & X'0000000000380804',X'0000000000300804', - & X'0000000000280804',X'0000000000200804', - & X'0000000000180804',X'0000000000100804', - & X'0000000000001004'/ - DATA KX /X'00000000FFFFFFFF'/ - DATA MASK /X'00000000000000FF'/ - DATA MASK16/X'FFFFFFFFFFFF0000'/ -C -C MAKE KIDNT = 0 -C - DO 10 I = 1,4 - KIDNT(I) = 0 - 10 CONTINUE -C - ISIGN = 0 -C - DO 90 I = 1,27 - ISC = ITABLE(I) - I1 = IAND(ISC,MASK) - I2 = IAND(ISHFT(ISC,-8_8), MASK) - I3 = IAND(ISHFT(ISC,-16_8),MASK) - I4 = IAND(ISHFT(ISC,-24_8),MASK) -C -C SIGN TEST -C - IV = LARRAY(I) - IF (IV.GE.0) GO TO 50 - IF (I4.NE.0) GO TO 30 - WRITE (6,20) I, IV - 20 FORMAT(/,1X,' W3FI32 - VALUE IN LARRAY(',I2,') =',I11, - & ' SHOULD NOT BE NEGATIVE',/) - GO TO 70 -C - 30 CONTINUE - IV = IABS(IV) - MSIGN = 1 - ISIGN = MSIGN - K = I2 / 4 -C - DO 40 M = 1,K - ISIGN = ISHFT(ISIGN,4) - 40 CONTINUE -C - ISIGN = ISHFT(ISIGN,-1) - IV = IOR(IV,ISIGN) -C - 50 CONTINUE -C -C MAG TEST -C - IF (ISHFT(IV,-I2).EQ.0) GO TO 80 - IF (LARRAY(27).GT.32743) GO TO 70 - PRINT 60, I , IV - 60 FORMAT(/,1X,' W3FI32 - VALUE IN LARRAY(',I2,') =',I11, - & ' IS TOO LARGE TO PACK',/) -C - 70 CONTINUE - IV = KX - IA = 32 - I2 - IV = ISHFT(IV,-IA) -C -C SHIFT -C - 80 CONTINUE - ITEMP=ISHFT(IV,I3) - ITEMP8=ITEMP - KIDNT(I1) = IOR(KIDNT(I1),ITEMP8) -C - 90 CONTINUE -C -C TEST FOR BIG RECORDS, STORE J THE WORD COUNT IN THE 6TH -C ID WORD IF GREATER THAN 32743. -C - IF (LARRAY(27).EQ.0) THEN - PRINT *,' W3FI32 - ERROR, WORD COUNT J = 0' - ELSE IF (LARRAY(27).GT.32743) THEN - KIDNT(4) = IAND(KIDNT(4),MASK16) - KIDNT(5) = 0 - KIDNT(6) = LARRAY(27) - END IF -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fi47.f b/src/fim/FIMsrc/w3/w3fi47.f deleted file mode 100644 index 50083f6..0000000 --- a/src/fim/FIMsrc/w3/w3fi47.f +++ /dev/null @@ -1,80 +0,0 @@ - SUBROUTINE W3FI47(ILABEL,NLABEL) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FI47 CONVERT LABEL TO OFF. NO. 85 FORMAT (CRAY) -C AUTHOR: JONES, R.E. ORG: W342 DATE: 85-07-31 -C -C ABSTRACT: CONVERTS A OFFICE NOTE 85 LABEL IN IBM370 FORMAT -C TO OFFICE NOTE 85 CRAY FORMAT. ALL EBCDIC CHARACTERS ARE -C CONVERTED TO ASCII. CONVERTS BINARY OR CODED LABEL. -C -C PROGRAM HISTORY LOG: -C 85-07-31 R.E.JONES -C 89-10-24 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C 02-10-15 VUONG REPLACED FUNCTION ICHAR WITH MOVA2I -C -C USAGE: CALL W3FI47(ILABEL,NLABEL) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C ILABEL ARG LIST 4 WORDS (32 BYTES) CHARACTERS ARE IN EBCDIC OR -C BINARY. -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C NLABEL ARG LIST 4 WORDS (32 BYTES), CHARACTERS ARE IN ASCII OR -C BINARY. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - CHARACTER*1 ILABEL(32) - CHARACTER*1 NLABEL(32) -C -C TEST FOR CODED LABEL, IF SO, CONVERT ALL CHARACTERS -C TEST FOR EBCDIC C, 195 IN DECIMAL -C - IF (MOVA2I(ILABEL(7)).EQ.195) THEN -C - CALL AEA(NLABEL(1),ILABEL(1),32) -C - ELSE -C -C BINARY LABEL, CONVERT BYTES 1-8, 21-30 TO ASCII -C - CALL AEA(NLABEL(1),ILABEL(1),8) -C -C MOVE BYTES 9 TO 20 -C - DO 10 I = 9,20 - NLABEL(I) = ILABEL(I) - 10 CONTINUE -C -C CONVERT WASHINGTON TO ASCII -C - CALL AEA(NLABEL(21),ILABEL(21),10) -C -C TEST BYTES 31 AND 32 FOR BINARY ZERO, IF NOT ZERO -C CONVERT TO ASCII -C - IF (MOVA2I(ILABEL(31)).EQ.0) THEN - NLABEL(31) = CHAR(0) - ELSE - CALL AEA(NLABEL(31),ILABEL(31),1) - ENDIF -C - IF (MOVA2I(ILABEL(32)).EQ.0) THEN - NLABEL(32) = CHAR(0) - ELSE - CALL AEA(NLABEL(32),ILABEL(32),1) - ENDIF -C - ENDIF -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fi48.f b/src/fim/FIMsrc/w3/w3fi48.f deleted file mode 100644 index 3925b08..0000000 --- a/src/fim/FIMsrc/w3/w3fi48.f +++ /dev/null @@ -1,84 +0,0 @@ - SUBROUTINE W3FI48(ILABEL,NLABEL) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FI48 CONVERT OFFICE NOTE 85 LABEL TO IBM -C AUTHOR: JONES, R.E. ORG: W342 DATE: 85-07-31 -C -C ABSTRACT: CONVERTS OFFICE NOTE 85 LABEL FROM THE CRAY -C FORMAT INTO A NAS-9050 LABEL. ALL ASCII CHARACTERS ARE -C CONVERTED INTO EBCDIC CHARACTERS. BINARY OR CODED LABELS -C CAN BE CONVERTED. -C -C PROGRAM HISTORY LOG: -C 85-07-31 R.E.JONES -C 89-10-24 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C 02-10-15 VUONG REPLACED FUNCTION ICHAR WITH MOVA2I -C -C USAGE: CALL W3FI48 (ILABEL, NLABEL) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C ILABEL ARG LIST 4 64 BIT WORDS OR 32 CHARACTERS -C CHARACTERS ARE IN ASCII OR BINARY. -C -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C NLABEL ARG LIST 4 64 BIT WORDS OR 32 CHARACTERS, -C CHARACTERS ARE IN EBCDIC OR BINARY. -C -C REMARKS: SEE OFFICE NOTE 85. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - CHARACTER*1 ILABEL(32) - CHARACTER*1 NLABEL(32) -C -C TEST FOR CODED LABEL, IF SO, CONVERT ALL CHARACTERS -C TEST FOR ASCII C, 67 IN DECIMAL -C - IF (MOVA2I(ILABEL(7)).EQ.67) THEN -C - CALL AEA(ILABEL(1),NLABEL(1),-32) -C - ELSE -C -C BINARY LABEL, CONVERT BYTES 1-8, 21-30 TO EBCDIC -C - CALL AEA (ILABEL(1),NLABEL(1),-8) -C -C MOVE BYTES 9 TO 20 -C - DO 10 I = 9,20 - NLABEL(I) = ILABEL(I) - 10 CONTINUE -C -C CONVERT WASHINGTON TO EBCDIC -C - CALL AEA (ILABEL(21),NLABEL(21),-10) -C -C TEST BYTES 31 AND 32 FOR BINARY ZERO, IF NOT ZERO -C CONVERT TO ASCII -C - IF (MOVA2I(ILABEL(31)).EQ.0) THEN - NLABEL(31) = CHAR(0) - ELSE - CALL AEA(ILABEL(31),NLABEL(31),-1) - ENDIF -C - IF (MOVA2I(ILABEL(32)).EQ.0) THEN - NLABEL(32) = CHAR(0) - ELSE - CALL AEA(ILABEL(32),NLABEL(32),-1) - ENDIF -C - ENDIF -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fi52.f b/src/fim/FIMsrc/w3/w3fi52.f deleted file mode 100644 index 6699793..0000000 --- a/src/fim/FIMsrc/w3/w3fi52.f +++ /dev/null @@ -1,355 +0,0 @@ - SUBROUTINE W3FI52(IDENT,CNST,IER) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FI52 COMPUTES SCALING CONSTANTS USED BY GRDPRT -C AUTHOR: STACKPOLE,J. ORG: W342 DATE: 85-12-03 -C AUTHOR: JONES,R.E. -C -C ABSTRACT: COMPUTES THE FOUR SCALING CONSTANTS USED BY GRDPRT, W3FP03, -C OR W3FP05 FROM THE 1ST 5 IDENTIFIER WORDS IN OFFICE NOTE 84 FORMAT. -C -C PROGRAM HISTORY LOG: -C 80-06-15 J. STACKPOLE -C 85-12-03 R.E.JONES MADE SUBROUTINE IN GENOUT INTO THIS SUBR. -C 89-07-07 R.E.JONES CONVERT TO MICROSOFT FORTRAN 4.10 -C 90-02-03 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C -C USAGE: CALL W3FI52(IDENT,CNST,IER) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C IDENT ARG LIST FIRST 5 ID'S IN OFFICE NOTE 84 FORMAT -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C CNST ARG LIST 4 CONSTANT'S USED BY GRDPRT,W3FP05, OR W3FP03 -C IER ARG LIST 0 = NORMAL RETURN -C 1 = ID'S IN IDENT ARE NOT IN O.N. 84 FORMAT -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C W3FI33 W3LIB -C -C ATTRIBUTES: -C LANGUAGE: MICROSOFT FORTRAN 4.10 OPTIMIZING COMPILER -C MACHINE: IBM PC, AT, PS/2, 386, CLONES. -C -C$$$ -C -CC SET DEFAULT VALUES FOR NMC FIELDS GRIDPRINTING -C - REAL CNST(4) -C - INTEGER IDENT(4) - INTEGER LABUNP(27) - INTEGER Q -C -C UPACK 8 OFFICE NOTE 84 ID'S INTO 27 PARTS -C - CALL W3FI33(IDENT,LABUNP) -C - ITYPEQ = LABUNP(1) - Q = ITYPEQ - ITYPES = LABUNP(2) - ITYPEC = LABUNP(5) - ISC = LABUNP(6) - IER = 0 - XLVL = ITYPEC - IF (ISC) 10,30,20 -C - 10 CONTINUE - ISC = -ISC -C -C DIVIDE BY WHOLE NUMBER RATHER THAN MULTIPLY BY FRACTION TO -C TO AVOID ROUND OF ERROR -C - XLVL = XLVL / (10.**ISC) - GO TO 30 -C - 20 CONTINUE - XLVL = XLVL * (10.**ISC) -C - 30 CONTINUE - ILVL = XLVL - IF (Q.NE.1.AND.Q.NE.2) GO TO 40 -C -C*** GEOPOTENTIAL METERS ............ -C - CNST(3) = 60. - IF (ILVL .LT. 500) CNST(3) = 120. - IF ((ITYPES .EQ. 129) .OR. (ITYPES .EQ. 130)) CNST(3) = 500. - CNST(1) = 0. - CNST(2) = 1. - CNST(4) = 0. - IF (CNST(3) .EQ. 500.) CNST(4) = 2. - RETURN -C - 40 CONTINUE - IF (Q.NE.8) GO TO 50 -C -C*** PRESSURE, MILLIBARS ............... -C - CNST(1) = 0. - CNST(2) = 1. - CNST(3) = 4. - CNST(4) = 0. -C -C*** IF SFC OR TROPOPAUSE PRESSURE .. -C - IF ((ITYPES .EQ. 129) .OR. (ITYPES .EQ. 130)) CNST(3) = 25. - RETURN -C - 50 CONTINUE - DO 60 I = 16,21 - IF (Q.EQ.I) GO TO 70 - 60 CONTINUE - GO TO 80 -C - 70 CONTINUE -C -C*** TEMPERATURES (DEG K) CONVERT TO DEG C, EXCEPT FOR POTENTIAL TEMP. -C - CNST(1) = -273.15 - CNST(2) = 1. - CNST(3) = 5. - CNST(4) = 0. - IF (ITYPEQ .EQ. 19) CNST(1) = 0. - RETURN -C - 80 CONTINUE - IF (Q.NE.40) GO TO 90 -C -C*** VERTICAL VELOCITY (MB/SEC) TO MICROBARS/SEC -C*** SIGN CHANGED SUCH THAT POSITIVE VALUES INDICATE UPWARD MOTION. -C - CNST(1) = 0. - CNST(2) = -1.E3 - CNST(3) = 2. - CNST(4) = 0. - RETURN -C - 90 CONTINUE - IF (Q.NE.41) GO TO 100 -C -C*** NET VERTICAL DISPLACEMENT ... MILLIBARS -C - CNST(1) = 0. - CNST(2) = 1. - CNST(3) = 10. - CNST(4) = 0. - RETURN -C - 100 CONTINUE - DO 110 I = 48,51 - IF (Q.EQ.I) GO TO 120 - 110 CONTINUE - GO TO 130 -C - 120 CONTINUE -C -C*** WIND SPEEDS M/SEC -C - CNST(1) = 0. - CNST(2) = 1. - CNST(3) = 10. - CNST(4) = 0. - RETURN -C - 130 CONTINUE - IF (Q.NE.52) GO TO 140 -C -C*** VERTICAL SPEED SHEAR(/ SEC)... TO BE CONVERTED TO KNOTS/1000 FT -C - CNST(1) = 0. - CNST(2) = 592.086 - CNST(3) = 2. - CNST(4) = 0. - RETURN -C - 140 CONTINUE - IF (Q.NE.53.AND.Q.NE.54) GO TO 150 -C -C*** DIVERGENT U AND V COMPONENTS M/SEC -C - CNST(1) = 0. - CNST(2) = 1. - CNST(3) = 2. - CNST(4) = 0. - RETURN -C - 150 CONTINUE - IF (Q.NE.72.AND.Q.NE.73) GO TO 160 -C -C*** VORTICITY (APPROX 10**-5) TIMES 10**6 /SEC -C - CNST(1) = 0. - CNST(2) = 1.E6 - CNST(3) = 40. - CNST(4) = 0. - RETURN -C - 160 CONTINUE - IF (Q.NE.74) GO TO 170 -C -C*** DIVERGENCE (/SEC) TIMES 10**6 -C - CNST(1) = 0. - CNST(2) = 1.E6 - CNST(3) = 20. - CNST(4) = 0. - RETURN -C - 170 CONTINUE - IF (Q.NE.80.AND.Q.NE.81) GO TO 180 -C -C*** STREAM FUNCTION OR VELOCITY POTENTIAL (M*M/SEC) CONVERTED TO M. -C*** CONVERT TO METERS. (M*M/SEC * FOG) -C - CNST(1) = 0. - CNST(2) = 1.03125E-4 / 9.8 - CNST(3) = 60. - CNST(4) = 0. - IF ((ILVL.LT.500) .AND. (ITYPEC .EQ. 0)) CNST(3) = 120. - RETURN -C - 180 CONTINUE - IF (Q.NE.88) GO TO 190 -C -C*** RELATIVE HUMIDITY ... PERCENT -C - CNST(1) = 0. - CNST(2) = 1. - CNST(3) = 10. - CNST(4) = 0. - RETURN -C - 190 CONTINUE - IF (Q.NE.89) GO TO 200 -C -C*** PRECIPITABLE WATER (KG/M*M) OR .1 GRAM/CM*CM OR MILLIMETERS/CM*CM -C*** CHANGE TO CENTI-INCHES/CM*CM -C - CNST(1) = 0. - CNST(2) = 3.937 - CNST(3) = 5. - CNST(4) = 0. - RETURN -C - 200 CONTINUE - IF (Q.NE.90) GO TO 210 -C -C*** ACCUMULATED PRECIPITATION (METERS) TO CENTI-INCHES, AT 1/2 IN. -C - CNST(1) = 0. - CNST(2) = 3937. - CNST(3) = 50. - CNST(4) = 0. - RETURN -C - 210 CONTINUE - IF (Q.NE.91.AND.Q.NE.92) GO TO 220 -C -C*** PROBABILITY ... PERCENT -C - CNST(1) = 0. - CNST(2) = 1. - CNST(3) = 10. - CNST(4) = 0. - RETURN -C - 220 CONTINUE - IF (Q.NE.93) GO TO 230 -C -C*** SNOW DEPTH (METERS) TO INCHES, AT INTERVALS OF 6 INCHES -C - CNST(1) = 0. - CNST(2) = 39.37 - CNST(3) = 6. - CNST(4) = 0. - RETURN -C - 230 CONTINUE - IF (Q.NE.112) GO TO 240 -C -C*** LIFTED INDEX ..(DEG K) TO DEG C. -C - CNST(1) = -273.15 - CNST(2) = 1. - CNST(3) = 2. - CNST(4) = 0. - RETURN -C - 240 CONTINUE - IF (Q.NE.120.AND.Q.NE.121) GO TO 250 -C -C*** WAVE COMPONENT OF GEOPOTENTIAL (GEOP M) -C - CNST(1) = 0. - CNST(2) = 1. - CNST(3) = 10. - CNST(4) = 0. - RETURN -C - 250 CONTINUE - IF (Q.NE.160) GO TO 260 -C -C*** DRAG COEFFICIENT DIMENSIONLESS TIMES 10**5 -C - CNST(1) = 0. - CNST(2) = 1.E5 - CNST(3) = 100. - CNST(4) = 0. - RETURN -C - 260 CONTINUE - IF (Q.NE.161) GO TO 270 -C -C*** LAND/SEA DIMENSIONLESS -C - CNST(1) = 0. - CNST(2) = 1. - CNST(3) = 1. - CNST(4) = .5 - RETURN -C - 270 CONTINUE - IF (Q.NE.169) GO TO 280 -C -C ALBIDO * 100. (DIMENSIONLESS) -C - CNST(1) = 0. - CNST(2) = 100. - CNST(3) = 5. - CNST(4) = 0. - RETURN -C - 280 CONTINUE - IF (ITYPEQ .EQ. 384) GO TO 290 - IF ((ITYPEQ .GE. 385) .AND. (ITYPEQ .LE. 387)) GO TO 300 -C -C*** NONE OF THE ABOVE .... -C - IER = 1 - RETURN -C -C*** OCEAN WATER TEMPERATURE (DEGREES K) -C - 290 CONTINUE - CNST(1) = 0. - CNST(2) = 1. - CNST(3) = 5. - CNST(4) = 0. - RETURN -C -C*** HEIGHT OF WIND DRIVEN OCEAN WAVES, SEA SWELLS, OR COMBINATION -C - 300 CONTINUE - CNST(1) = 0. - CNST(2) = 1. - CNST(3) = 2. - CNST(4) = 0. - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fi58.f b/src/fim/FIMsrc/w3/w3fi58.f deleted file mode 100644 index c55d7f4..0000000 --- a/src/fim/FIMsrc/w3/w3fi58.f +++ /dev/null @@ -1,124 +0,0 @@ - SUBROUTINE W3FI58(IFIELD,NPTS,NWORK,NPFLD,NBITS,LEN,KMIN,IERR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK *** -C . . . . -C SUBPROGRAM: W3FI58 - PACK POSITIVE DIFFERENCES IN LEAST BITS -C PRGMMR: ALLARD, R. ORG: NMC411 DATE: JULY 1987 -C -C ABSTRACT: CONVERTS AN ARRAY OF INTEGER NUMBERS INTO AN ARRAY OF -C POSITIVE DIFFERENCES (NUMBER(S) - MINIMUM VALUE) AND PACKS THE -C MAGNITUDE OF EACH DIFFERENCE RIGHT-ADJUSTED INTO THE LEAST -C NUMBER OF BITS THAT HOLDS THE LARGEST DIFFERENCE. -C -C PROGRAM HISTORY LOG: -C 87-09-02 ALLARD -C 88-10-02 R.E.JONES CONVERTED TO CDC CYBER 205 FTN200 FORTRAN -C 90-05-17 R.E.JONES CONVERTED TO CRAY CFT77 FORTRAN -C 90-05-18 R.E.JONES CHANGE NAME VBIMPK TO W3LIB NAME W3FI58 -C 96-05-14 IREDELL GENERALIZED COMPUTATION OF NBITS -C 98-06-30 EBISUZAKI LINUX PORT -C 07-08-30 N. WANG ADDED ERROR MESSAGE FOR DYNAMIC RANGE OVERFLOW. -C -C USAGE: CALL W3FI58(IFIELD,NPTS,NWORK,NPFLD,NBITS,LEN,KMIN,IERR) -C -C INPUT: -C -C IFIELD - ARRAY OF INTEGER DATA FOR PROCESSING -C NPTS - NUMBER OF DATA VALUES TO PROCESS IN IFIELD (AND NWORK) -C WHERE, NPTS > 0 -C -C OUTPUT: -C -C NWORK - WORK ARRAY WITH INTEGER DIFFERENCE -C NPFLD - ARRAY FOR PACKED DATA (character*1) -C (USER IS RESPONSIBLE FOR AN ADEQUATE DIMENSION.) -C NBITS - NUMBER OF BITS USED TO PACK DATA WHERE, 0 < NBITS < 32 -C (THE MAXIMUM DIFFERENCE WITHOUT OVERFLOW IS 2**31 -1) -C LEN - NUMBER OF PACKED BYTES IN NPFLD (SET TO 0 IF NO PACKING) -C WHERE, LEN = (NBITS * NPTS + 7) / 8 WITHOUT REMAINDER -C KMIN - MINIMUM VALUE (SUBTRACTED FROM EACH DATUM). IF THIS -C PACKED DATA IS BEING USED FOR GRIB DATA, THE -C PROGRAMER WILL HAVE TO CONVERT THE KMIN VALUE TO AN -C IBM370 32 BIT FLOATING POINT NUMBER. -C -C SUBPROGRAMS CALLED: -C -C W3LIB: SBYTES, SBYTE -C -C EXIT STATES: -C IERR = 0, NO ERROR, IERR = 1, DYNAMIC RANGE OVERFLOW. N. WANG, 07-08-30 -C -C NOTE: LEN = 0, NBITS = 0, AND NO PACKING PERFORMED IF -C -C (1) KMAX = KMIN (A CONSTANT FIELD) -C (2) NPTS < 1 (SEE INPUT ARGUMENT) -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - PARAMETER(ALOG2=0.69314718056) - INTEGER IFIELD(*) - CHARACTER*1 NPFLD(*) - INTEGER NWORK(*) -C - DATA KZERO / 0 / -C -C / / / / / / -C - IERR = 0 - LEN = 0 - NBITS = 0 - IF (NPTS.LE.0) GO TO 3000 -C -C FIND THE MAX-MIN VALUES IN INTEGER FIELD (IFIELD). -C - KMAX = IFIELD(1) - KMIN = KMAX - DO 1000 I = 2,NPTS - KMAX = MAX(KMAX,IFIELD(I)) - KMIN = MIN(KMIN,IFIELD(I)) - 1000 CONTINUE -C -C IF A CONSTANT FIELD, RETURN WITH NO PACKING AND 'LEN' AND 'NBITS' SET -C TO ZERO. -C - IF (KMAX.EQ.KMIN) GO TO 3000 -C -C DETERMINE LARGEST DIFFERENCE IN IFIELD AND FLOAT (BIGDIF). -C - BIGDIF = KMAX - KMIN - IF (BIGDIF < 0.0) THEN - PRINT*,'W3FI58: DYNAMIC RANGE OVERFLOW', KMAX, KMIN - IERR = 1 - RETURN - ENDIF - -C -C NBITS IS COMPUTED AS THE LEAST INTEGER SUCH THAT -C BIGDIF < 2**NBITS -C - NBITS=LOG(BIGDIF+0.5)/ALOG2+1 -C -C FORM DIFFERENCES IN NWORK ARRAY. -C - DO 2000 K = 1,NPTS - NWORK(K) = IFIELD(K) - KMIN - 2000 CONTINUE -C -C PACK EACH MAGNITUDE IN NBITS (NBITS = THE LEAST POWER OF 2 OR 'N') -C - LEN=(NBITS*NPTS-1)/8+1 - CALL SBYTESC(NPFLD,NWORK,0,NBITS,0,NPTS) -C -C ADD ZERO-BITS AT END OF PACKED DATA TO INSURE A BYTE BOUNDARY. -C - NOFF = NBITS * NPTS - NZERO=LEN*8-NOFF - IF(NZERO.GT.0) CALL SBYTEC(NPFLD,KZERO,NOFF,NZERO) -C - 3000 CONTINUE - RETURN -C - END diff --git a/src/fim/FIMsrc/w3/w3fi59.f b/src/fim/FIMsrc/w3/w3fi59.f deleted file mode 100644 index ac430d4..0000000 --- a/src/fim/FIMsrc/w3/w3fi59.f +++ /dev/null @@ -1,129 +0,0 @@ - SUBROUTINE W3FI59(FIELD,NPTS,NBITS,NWORK,NPFLD,ISCALE,LEN,RMIN) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI59 FORM AND PACK POSITIVE, SCALED DIFFERENCES -C PRGMMR: ALLARD, R. ORG: NMC41 DATE: 84-08-01 -C -C ABSTRACT: CONVERTS AN ARRAY OF SINGLE PRECISION REAL NUMBERS INTO -C AN ARRAY OF POSITIVE SCALED DIFFERENCES (NUMBER(S) - MINIMUM VALUE), -C IN INTEGER FORMAT AND PACKS THE ARGUMENT-SPECIFIED NUMBER OF -C SIGNIFICANT BITS FROM EACH DIFFERENCE. -C -C PROGRAM HISTORY LOG: -C 84-08-01 ALLARD ORIGINAL AUTHOR -C 90-05-17 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C 90-05-18 R.E.JONES CHANGE NAME PAKMAG TO W3LIB NAME W3FI59 -C 93-07-06 R.E.JONES ADD NINT TO DO LOOP 2000 SO NUMBERS ARE -C ROUNDED TO NEAREST INTEGER, NOT TRUNCATED. -C 94-01-05 IREDELL COMPUTATION OF ISCALE FIXED WITH RESPECT TO -C THE 93-07-06 CHANGE. -C 98-06-30 EBISUZAKI LINUX PORT -C -C USAGE: CALL W3FI59(FIELD,NPTS,NBITS,NWORK,NPFLD,ISCALE,LEN,RMIN) -C INPUT ARGUMENT LIST: -C FIELD - ARRAY OF FLOATING POINT DATA FOR PROCESSING (REAL) -C NPTS - NUMBER OF DATA VALUES TO PROCESS IN FIELD (AND NWORK) -C WHERE, NPTS > 0 -C NBITS - NUMBER OF SIGNIFICANT BITS OF PROCESSED DATA TO BE PACKED -C WHERE, 0 < NBITS < 32+1 -C -C OUTPUT ARGUMENT LIST: -C NWORK - ARRAY FOR INTEGER CONVERSION (INTEGER) -C IF PACKING PERFORMED (SEE NOTE BELOW), THE ARRAY WILL -C CONTAIN THE PRE-PACKED, RIGHT ADJUSTED, SCALED, INTEGER -C DIFFERENCES UPON RETURN TO THE USER. -C (THE USER MAY EQUIVALENCE FIELD AND NWORK. SAME SIZE.) -C NPFLD - ARRAY FOR PACKED DATA (character*1) -C (DIMENSION MUST BE AT LEAST (NBITS * NPTS) / 64 + 1 ) -C ISCALE- POWER OF 2 FOR RESTORING DATA, SUCH THAT -C DATUM = (DIFFERENCE * 2**ISCALE) + RMIN -C LEN - NUMBER OF PACKED BYTES IN NPFLD (SET TO 0 IF NO PACKING) -C WHERE, LEN = (NBITS * NPTS + 7) / 8 WITHOUT REMAINDER -C RMIN - MINIMUM VALUE (REFERENCE VALUE SUBTRACTED FROM INPUT DATA) -C THIS IS A CRAY FLOATING POINT NUMBER, IT WILL HAVE TO BE -C CONVERTED TO AN IBM370 32 BIT FLOATING POINT NUMBER AT -C SOME POINT IN YOUR PROGRAM IF YOU ARE PACKING GRIB DATA. -C -C REMARKS: LEN = 0 AND NO PACKING PERFORMED IF -C -C (1) RMAX = RMIN (A CONSTANT FIELD) -C (2) NBITS VALUE OUT OF RANGE (SEE INPUT ARGUMENT) -C (3) NPTS VALUE LESS THAN 1 (SEE INPUT ARGUMENT) -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916/256, Y-MP8/864, Y-MP EL92/256, J916/2048 -C -C$$$ -C NATURAL LOGARITHM OF 2 AND 0.5 PLUS NOMINAL SAFE EPSILON - PARAMETER(ALOG2=0.69314718056,HPEPS=0.500001) -C - REAL FIELD(*) -C - CHARACTER*1 NPFLD(*) - INTEGER NWORK(*) -C - DATA KZERO / 0 / -C -C / / / / / / -C - LEN = 0 - ISCALE = 0 - IF (NBITS.LE.0.OR.NBITS.GT.32) GO TO 3000 - IF (NPTS.LE.0) GO TO 3000 -C -C FIND THE MAX-MIN VALUES IN FIELD. -C - RMAX = FIELD(1) - RMIN = RMAX - DO 1000 K = 2,NPTS - RMAX = AMAX1(RMAX,FIELD(K)) - RMIN = AMIN1(RMIN,FIELD(K)) - 1000 CONTINUE -C -C IF A CONSTANT FIELD, RETURN WITH NO PACKING PERFORMED AND 'LEN' = 0. -C - IF (RMAX.EQ.RMIN) GO TO 3000 -C -C DETERMINE LARGEST DIFFERENCE IN FIELD (BIGDIF). -C - BIGDIF = RMAX - RMIN -C -C ISCALE IS THE POWER OF 2 REQUIRED TO RESTORE THE PACKED DATA. -C ISCALE IS COMPUTED AS THE LEAST INTEGER SUCH THAT -C BIGDIF*2**(-ISCALE) < 2**NBITS-0.5 -C IN ORDER TO ENSURE THAT THE PACKED INTEGERS (COMPUTED IN LOOP 2000 -C WITH THE NEAREST INTEGER FUNCTION) STAY LESS THAN 2**NBITS. -C - ISCALE=NINT(ALOG(BIGDIF/(2.**NBITS-0.5))/ALOG2+HPEPS) -C -C FORM DIFFERENCES, RESCALE, AND CONVERT TO INTEGER FORMAT. -C - TWON = 2.0 ** (-ISCALE) - DO 2000 K = 1,NPTS - NWORK(K) = NINT( (FIELD(K) - RMIN) * TWON ) - 2000 CONTINUE -C -C PACK THE MAGNITUDES (RIGHTMOST NBITS OF EACH WORD). -C - KOFF = 0 - ISKIP = 0 -C -C USE NCAR ARRAY BIT PACKER SBYTES (GBYTES PACKAGE) -C - CALL SBYTESC(NPFLD,NWORK,KOFF,NBITS,ISKIP,NPTS) -C -C ADD 7 ZERO-BITS AT END OF PACKED DATA TO INSURE BYTE BOUNDARY. -C USE NCAR WORD BIT PACKER SBYTE -C - NOFF = NBITS * NPTS - CALL SBYTEC(NPFLD,KZERO,NOFF,7) -C -C DETERMINE BYTE LENGTH (LEN) OF PACKED FIELD (NPFLD). -C - LEN = (NOFF + 7) / 8 -C - 3000 CONTINUE - RETURN -C - END diff --git a/src/fim/FIMsrc/w3/w3fi61.f b/src/fim/FIMsrc/w3/w3fi61.f deleted file mode 100644 index c998cdc..0000000 --- a/src/fim/FIMsrc/w3/w3fi61.f +++ /dev/null @@ -1,204 +0,0 @@ - SUBROUTINE W3FI61 (LOC,ICAT,AREG,IBCKUP,IDATYP,IERR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI61 BUILD 40 CHAR COMMUNICATIONS PREFIX -C PRGMMR: CAVANAUGH ORG: NMC421 DATE:91-07-24 -C -C ABSTRACT: USING INFORMATION FROM THE USER, BUILD A 40 CHARACTER -C COMMUNICATIONS PREFIX AND PLACE IN INDICATED LOCATION. -C -C PROGRAM HISTORY LOG: -C 91-06-21 CAVANAUGH -C 91-09-20 R.E.JONES CHANGES FOR SiliconGraphics 3.3 FORTRAN 77 -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C 94-04-28 R.E.JONES CHANGE FOR CRAY 64 BIT WORD SIZE AND -C FOR ASCII CHARACTER SET COMPUTERS -C 02-10-15 VUONG REPLACED FUNCTION ICHAR WITH MOVA2I -C -C USAGE: CALL W3FI61 (LOC,ICAT,AREG,IBCKUP,IDATYP,IERR) -C INPUT ARGUMENT LIST: -C ICAT - CATALOG NUMBER -C AREG - AFOS REGIONAL ADDRESSING FLAGS (6 POSITIONS) -C SELECT ANY OR ALL OF THE FOLLOWING. SELECTIONS -C WILL AUTOMATICALLY BE LEFT JUSTIFIED AND BLANK -C FILLED TO 6 POSITIONS. -C IF BULLETINS AND/OR MESSAGES ARE NOT TO BE ROUTED -C TO AFOS, THEN LEAVE THE FIELD FILLED WITH BLANKS. -C E - EASTERN REGION -C C - CENTRAL REGION -C W - WESTERN REGION -C S - SOUTHERN REGION -C A - ATLANTIC REGION -C P - PACIFIC REGION -C IERR - ERROR RETURN -C IBCKUP - BACKUP INDICATOR W/HEADER KEY -C 0 = NOT A BACKUP -C 1 = FD BACKUP -C 2 = DF BACKUP -C BACK UP IS ONLY PERMITTED FOR FD AND DF BULLETINS -C IDATYP - DATA TYPE INDICATOR -C 0 = EBCIDIC DATA -C 11 = BINARY DATA -C 12 = PSUEDO-ASCII DATA -C 3 = ASCII DATA -C -C OUTPUT ARGUMENT LIST: -C LOC - NAME OF THE ARRAY TO RECEIVE THE COMMUNICATIONS PREFIX -C -C REMARKS: ERROR RETURNS -C IERR = 0 NORMAL RETURN -C = 1 INCORRECT BACKUP FLAG -C = 2 A REGIONAL ADDRESSING FLAG IS -C NON-BLANK AND NON-STANDARD ENTRY -C = 3 DATA TYPE IS NON-STANDARD ENTRY -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256 -C -C$$$ - INTEGER LOC(*) - INTEGER ICAT,IBCKUP,IDATYP - INTEGER IERR,IHOLD -C - CHARACTER*6 AREG - CHARACTER*8 AHOLD - CHARACTER*6 ARGNL - CHARACTER*1 BLANK -C - LOGICAL IBM370 -C - EQUIVALENCE (IHOLD,AHOLD) -C - SAVE -C - DATA ARGNL /'ECWSAP'/ -C -C BLANK WILL BE 40 HEX OR DECIMAL 64 ON AN IBM370 TYPE -C COMPUTER, THIS IS THE EBCDIC CHARACTER SET. -C BLANK WILL BE 20 HEX OR DECIMAL 32 ON A COMPUTER WITH THE -C ASCII CHARACTER SET. THIS WILL BE USED TO TEST FOR CHARACTER -C SETS TO FIND IBM370 TYPE COMPUTER. -C - DATA BLANK /' '/ - DATA IBM370/.FALSE./ -C -C ---------------------------------------------------------------- -C -C TEST FOR CRAY 64 BIT COMPUTER, LW = 8 -C - CALL W3FI01(LW) -C -C TEST FOR EBCDIC CHARACTER SET -C - IF (MOVA2I(BLANK).EQ.64) THEN - IBM370 = .TRUE. - END IF -C - IERR = 0 - INOFST = 0 -C BYTE 1 SOH - START OF HEADER - CALL SBYTE (LOC,125,INOFST,8) - INOFST = INOFST + 8 -C BYTE 2 TRANSMISSION PRIORITY - CALL SBYTE (LOC,1,INOFST,8) - INOFST = INOFST + 8 -C BYTE 3-7 CATALOG NUMBER - IF (ICAT.GT.0) THEN - IF (LW.EQ.4) THEN - KK = ICAT / 10 - CALL W3AI15 (KK,IHOLD,1,4,'-') - IF (.NOT.IBM370) CALL W3AI39(IHOLD,4) - CALL SBYTE (LOC,IHOLD,INOFST,32) - INOFST = INOFST + 32 - KK = MOD(ICAT,10) - CALL W3AI15 (KK,IHOLD,1,4,'-') - IF (.NOT.IBM370) CALL W3AI39(IHOLD,4) - CALL SBYTE (LOC,IHOLD,INOFST,8) - INOFST = INOFST + 8 - ELSE - CALL W3AI15 (ICAT,IHOLD,1,8,'-') - IF (.NOT.IBM370) CALL W3AI39(IHOLD,8) - CALL SBYTE (LOC,IHOLD,INOFST,40) - INOFST = INOFST + 40 - END IF - ELSE - CALL SBYTE (LOC,-252645136,INOFST,32) - INOFST = INOFST + 32 - CALL SBYTE (LOC,240,INOFST,8) - INOFST = INOFST + 8 - END IF -C BYTE 8-9-10 BACK-UP FLAG FOR FD OR DF BULLETINS -C 0 = NOT A BACKUP -C 1 = FD -C 2 = DF - IF (IBCKUP.EQ.0) THEN -C NOT A BACKUP - CALL SBYTE (LOC,4210752,INOFST,24) - INOFST = INOFST + 24 - ELSE IF (IBCKUP.EQ.1) THEN -C BACKUP FOR FD - CALL SBYTE (LOC,12764868,INOFST,24) - INOFST = INOFST + 24 - ELSE IF (IBCKUP.EQ.2) THEN -C BACKUP FOR DF - CALL SBYTE (LOC,12764358,INOFST,24) - INOFST = INOFST + 24 - END IF -C BYTE 11 BLANK - CALL SBYTE (LOC,64,INOFST,8) - INOFST = INOFST + 8 -C BYTE 12 DATA TYPE - IF (IDATYP.EQ.0) THEN - ELSE IF (IDATYP.EQ.11) THEN - ELSE IF (IDATYP.EQ.12) THEN - ELSE IF (IDATYP.EQ.3) THEN - ELSE - IERR = 3 - RETURN - END IF - CALL SBYTE (LOC,IDATYP,INOFST,8) - INOFST = INOFST + 8 -C BYTES 13-18 AFOS REGIONAL ADDRESSING FLAGS - CALL SBYTE (LOC,1077952576,INOFST,32) - INOFST = INOFST + 32 - CALL SBYTE (LOC,1077952576,INOFST,16) - KRESET = INOFST + 16 - INOFST = INOFST - 32 - DO 1000 J = 1, 6 - DO 900 K = 1, 6 - IF (AREG(J:J).EQ.ARGNL(K:K)) THEN -C PRINT *,AREG(J:J),ARGNL(K:K),' MATCH' - IHOLD = 0 - IF (LW.EQ.4) THEN - AHOLD(4:4) = AREG(J:J) - IF (.NOT.IBM370) CALL W3AI39(IHOLD,4) - ELSE - AHOLD(8:8) = AREG(J:J) - CALL W3AI39(IHOLD,8) - END IF - CALL SBYTE (LOC,IHOLD,INOFST,8) - INOFST = INOFST + 8 - GO TO 1000 - ELSE IF (AREG(J:J).EQ.' ') THEN -C PRINT *,'BLANK SOURCE ' - GO TO 1000 - END IF - 900 CONTINUE - IERR = 2 - RETURN - 1000 CONTINUE - INOFST = KRESET -C BYTES 19-39 UNUSED (SET TO BLANK) - DO 1938 I = 1, 20, 4 - CALL SBYTE (LOC,1077952576,INOFST,32) - INOFST = INOFST + 32 - 1938 CONTINUE -C BYTE 39 MUST BE A BLANK - CALL SBYTE (LOC,64,INOFST,8) - INOFST = INOFST + 8 -C BYTE 40 MUST BE A BLANK - CALL SBYTE (LOC,64,INOFST,8) -C ---------------------------------------------------------------- - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fi62.f b/src/fim/FIMsrc/w3/w3fi62.f deleted file mode 100644 index 333f0fa..0000000 --- a/src/fim/FIMsrc/w3/w3fi62.f +++ /dev/null @@ -1,215 +0,0 @@ - SUBROUTINE W3FI62 (LOC,TTAAII,KARY,IERR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI62 BUILD 80-CHAR ON295 QUEUE DESCRIPTOR -C PRGMMR: CAVANAUGH ORG: NMC421 DATE:94-03-23 -C -C ABSTRACT: BUILD 80 CHARACTER QUEUE DESCRIPTOR USING INFORMATION -C SUPPLIED BY USER, PLACING THE COMPLETED QUEUE DESCRIPTOR IN THE -C LOCATION SPECIFIED BY THE USER. (BASED ON OFFICE NOTE 295). -C -C PROGRAM HISTORY LOG: -C 91-06-21 CAVANAUGH -C 94-03-08 CAVANAUGH MODIFIED TO ALLOW FOR BULLETIN SIZES THAT -C EXCEED 20000 BYTES -C 94-04-28 R.E.JONES CHANGE FOR CRAY 64 BIT WORD SIZE AND -C FOR ASCII CHARACTER SET COMPUTERS -C 96-01-29 R.E.JONES PRESET IERR TO ZERO -C 02-10-15 VUONG REPLACED FUNCTION ICHAR WITH MOVA2I -C -C USAGE: CALL W3FI62 (LOC,TTAAII,KARY,IERR) -C INPUT ARGUMENT LIST: -C TTAAII - FIRST 6 CHARACTERS OF WMO HEADER -C KARY - INTEGER ARRAY CONTAINING USER INFORMATION -C (1) = DAY OF MONTH -C (2) = HOUR OF DAY -C (3) = HOUR * 100 + MINUTE -C (4) = CATALOG NUMBER -C (5) = NUMBER OF 80 BYTE INCREMENTS -C (6) = NUMBER OF BYTES IN LAST INCREMENT -C (7) = TOTAL SIZE OF MESSAGE -C WMO HEADER + BODY OF MESSAGE IN BYTES -C (NOT INCLUDING QUEUE DESCRIPTOR) -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C LOC - LOCATION TO RECEIVE QUEUE DESCRIPTOR -C KARY - SEE INPUT ARGUMENT LIST -C IERR - ERROR RETURN -C -C SUBPROGRAMS CALLED: (LIST ALL CALLED FROM ANYWHERE IN CODES) -C LIBRARY: -C W3LIB - GBYTE W3FI01 W3AI15 -C -C REMARKS: IF TOTAL SIZE IS ENTERED (KARY(7)) THEN KARY(5) AND -C KARY(6) WILL BE CALCULATED. -C IF KARY(5) AND KARY(6) ARE PROVIDED THEN KARY(7) WILL -C BE IGNORED. -C -C WARNING: EQUIVALENCE ARRAY LOC TO INTEGER ARRAY SO IT STARTS ON -C A WORD BOUNDARY FOR SBYTE SUBROUTINE. -C -C ERROR RETURNS -C IERR = 1 TOTAL BYTE COUNT AND/OR 80 BYTE INCREMENT -C COUNT IS MISSING. ONE OR THE OTHER IS -C REQUIRED TO COMPLETE THE QUEUE DESCRIPTOR. -C IERR = 2 TOTAL SIZE TOO SMALL -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: HDS -C -C$$$ -C - INTEGER IHOLD(2) - INTEGER KARY(7),II,IERR -C - LOGICAL IBM370 -C - CHARACTER*6 TTAAII,AHOLD - CHARACTER*80 LOC - CHARACTER*1 BLANK -C - EQUIVALENCE (AHOLD,IHOLD) -C - SAVE -C -C BLANK WILL BE 40 HEX OR DECIMAL 64 ON AN IBM370 TYPE -C COMPUTER, THIS IS THE EBCDIC CHARACTER SET. -C BLANK WILL BE 20 HEX OR DECIMAL 32 ON A COMPUTER WITH THE -C ASCII CHARACTER SET. THIS WILL BE USED TO TEST FOR CHARACTER -C SETS TO FIND IBM370 TYPE COMPUTER. -C - DATA BLANK /' '/ -C ---------------------------------------------------------------- -C -C TEST FOR CRAY 64 BIT COMPUTER, LW = 8 -C - CALL W3FI01(LW) -C -C TEST FOR EBCDIC CHARACTER SET -C - IBM370 = .FALSE. - IF (MOVA2I(BLANK).EQ.64) THEN - IBM370 = .TRUE. - END IF -C - INOFST = 0 -C BYTES 1-16 'QUEUE DESCRIPTOR' - CALL SBYTE (LOC,-656095772,INOFST,32) - INOFST = INOFST + 32 - CALL SBYTE (LOC,-985611067,INOFST,32) - INOFST = INOFST + 32 - CALL SBYTE (LOC,-490481207,INOFST,32) - INOFST = INOFST + 32 - CALL SBYTE (LOC,-672934183,INOFST,32) - INOFST = INOFST + 32 -C BYTES 17-20 INTEGER ZEROES - CALL SBYTE (LOC,0,INOFST,32) - INOFST = INOFST + 32 -C IF TOTAL COUNT IS INCLUDED -C THEN WILL DETERMINE THE NUMBER OF -C 80 BYTE INCREMENTS AND WILL DETERMINE -C THE NUMBER OF BYTES IN THE LAST INCREMENT - IERR = 0 - IF (KARY(7).NE.0) THEN - IF (KARY(7).LT.35) THEN -C PRINT *,'LESS THAN MINIMUM SIZE' - IERR = 2 - RETURN - END IF - KARY(5) = KARY(7) / 80 - KARY(6) = MOD(KARY(7),80) - IF (KARY(6).EQ.0) THEN - KARY(6) = 80 - ELSE - KARY(5) = KARY(5) + 1 - END IF - ELSE - IF (KARY(5).LT.1) THEN - IERR = 1 - RETURN - END IF - END IF -C BYTE 21-22 NR OF 80 BYTE INCREMENTS - CALL SBYTE (LOC,KARY(5),INOFST,16) - INOFST = INOFST + 16 -C BYTE 23 NR OF BYTES IN LAST INCREMENT - CALL SBYTE (LOC,KARY(6),INOFST,8) - INOFST = INOFST + 8 -C BYTES 24-28 INTEGER ZEROES - CALL SBYTE (LOC,0,INOFST,32) - INOFST = INOFST + 32 - CALL SBYTE (LOC,0,INOFST,8) - INOFST = INOFST + 8 -C BYTES 29-34 6 CHAR BULLETIN NAME TTAAII - LOC(29:34) = TTAAII(1:6) -C -C IF ON ASCII COMPUTER, CONVERT LAST 6 CHARACTERS TO EBCDIC -C - IF (.NOT.IBM370) CALL W3AI39(LOC(29:29),6) -C - INOFST = INOFST + 48 -C BYTES 35-38 DAY OF MONTH AND UTC(Z) HRS -C DAY -C -C NOTE: W3AI15 WILL MAKE ASCII OR EBCDIC CHARACTERS -C DEPENDING ON WHAT TYPE OF COMPUTER IT IS ON -C - CALL W3AI15 (KARY(1),II,1,LW,'-') - CALL SBYTE (LOC,II,INOFST,16) - INOFST = INOFST + 16 -C HOURS - CALL W3AI15 (KARY(2),II,1,LW,'-') - CALL SBYTE (LOC,II,INOFST,16) -C -C IF ON ASCII COMPUTER, CONVERT LAST 4 CHARACTERS TO EBCDIC -C - IF (.NOT.IBM370) CALL W3AI39(LOC(35:35),4) - INOFST = INOFST + 16 -C BYTES 39-40 HR/MIN TIME OF BULLETIN CREATION -C TWO BYTES AS 4 BIT BCD - KA = KARY(3) / 1000 - KB = MOD(KARY(3),1000) / 100 - KC = MOD(KARY(3),100) / 10 - KD = MOD(KARY(3),10) - CALL SBYTE (LOC,KA,INOFST,4) - INOFST = INOFST + 4 - CALL SBYTE (LOC,KB,INOFST,4) - INOFST = INOFST + 4 - CALL SBYTE (LOC,KC,INOFST,4) - INOFST = INOFST + 4 - CALL SBYTE (LOC,KD,INOFST,4) - INOFST = INOFST + 4 -C BYTES 41-45 CATALOG NUMBER ELSE (SET TO 55555) - IF (KARY(4).GE.1.AND.KARY(4).LE.99999) THEN - CALL W3AI15 (KARY(4),IHOLD,1,8,'-') - IF (LW.EQ.4) THEN - CALL SBYTE (LOC,IHOLD(1),INOFST,8) - INOFST = INOFST + 8 - CALL SBYTE (LOC,IHOLD(2),INOFST,32) - INOFST = INOFST + 32 -C -C ON CRAY 64 BIT COMPUTER -C - ELSE - CALL SBYTE (LOC,IHOLD,INOFST,40) - INOFST = INOFST + 40 - END IF -C -C IF ON ASCII COMPUTER, CONVERT LAST 5 CHARACTERS TO EBCDIC -C - IF (.NOT.IBM370) CALL W3AI39(LOC(41:41),5) - ELSE - CALL SBYTE (LOC,-168430091,INOFST,32) - INOFST = INOFST + 32 - CALL SBYTE (LOC,245,INOFST,8) - INOFST = INOFST + 8 - END IF -C BYTES 46-80 INTEGER ZEROES - DO 4676 I = 1, 8 - CALL SBYTE (LOC,0,INOFST,32) - INOFST = INOFST + 32 - 4676 CONTINUE - CALL SBYTE (LOC,0,INOFST,24) - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fi63.f b/src/fim/FIMsrc/w3/w3fi63.f deleted file mode 100644 index e2ba533..0000000 --- a/src/fim/FIMsrc/w3/w3fi63.f +++ /dev/null @@ -1,3817 +0,0 @@ - SUBROUTINE W3FI63(MSGA,KPDS,KGDS,KBMS,DATA,KPTR,KRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI63 UNPK GRIB FIELD TO GRIB GRID -C PRGMMR: FARLEY ORG: NMC421 DATE:94-11-22 -C -C ABSTRACT: UNPACK A GRIB (EDITION 1) FIELD TO THE EXACT GRID -C SPECIFIED IN THE GRIB MESSAGE, ISOLATE THE BIT MAP, AND MAKE -C THE VALUES OF THE PRODUCT DESCRIPTON SECTION (PDS) AND THE -C GRID DESCRIPTION SECTION (GDS) AVAILABLE IN RETURN ARRAYS. -C -C WHEN DECODING IS COMPLETED, DATA AT EACH GRID POINT HAS BEEN -C RETURNED IN THE UNITS SPECIFIED IN THE GRIB MANUAL. -C -C PROGRAM HISTORY LOG: -C 91-09-13 CAVANAUGH -C 91-11-12 CAVANAUGH MODIFIED SIZE OF ECMWF GRIDS 5-8 -C 91-12-22 CAVANAUGH CORRECTED PROCESSING OF MERCATOR PROJECTIONS -C IN GRID DEFINITION SECTION (GDS) IN -C ROUTINE FI633 -C 92-08-05 CAVANAUGH CORRECTED MAXIMUM GRID SIZE TO ALLOW FOR -C ONE DEGREE BY ONE DEGREE GLOBAL GRIDS -C 92-08-27 CAVANAUGH CORRECTED TYPO ERROR, ADDED CODE TO COMPARE -C TOTAL BYTE SIZE FROM SECTION 0 WITH SUM OF -C SECTION SIZES. -C 92-10-21 CAVANAUGH CORRECTIONS WERE MADE (IN FI634) TO REDUCE -C PROCESSING TIME FOR INTERNATIONAL GRIDS. -C REMOVED A TYPOGRAPHICAL ERROR IN FI635. -C 93-01-07 CAVANAUGH CORRECTIONS WERE MADE (IN FI635) TO -C FACILITATE USE OF THESE ROUTINES ON A PC. -C A TYPOGRAPHICAL ERROR WAS ALSO CORRECTED -C 93-01-13 CAVANAUGH CORRECTIONS WERE MADE (IN FI632) TO -C PROPERLY HANDLE CONDITION WHEN -C TIME RANGE INDICATOR = 10. -C ADDED U.S.GRID 87. -C 93-02-04 CAVANAUGH ADDED U.S.GRIDS 85 AND 86 -C 93-02-26 CAVANAUGH ADDED GRIDS 2, 3, 37 THRU 44,AND -C GRIDS 55, 56, 90, 91, 92, AND 93 TO -C LIST OF U.S. GRIDS. -C 93-04-07 CAVANAUGH ADDED GRIDS 67 THRU 77 TO -C LIST OF U.S. GRIDS. -C 93-04-20 CAVANAUGH INCREASED MAX SIZE TO ACCOMODATE -C GAUSSIAN GRIDS. -C 93-05-26 CAVANAUGH CORRECTED GRID RANGE SELECTION IN FI634 -C FOR RANGES 67-71 & 75-77 -C 93-06-08 CAVANAUGH CORRECTED FI635 TO ACCEPT GRIB MESSAGES -C WITH SECOND ORDER PACKING. ADDED ROUTINE FI636 -C TO PROCESS MESSAGES WITH SECOND ORDER PACKING. -C 93-09-22 CAVANAUGH MODIFIED TO EXTRACT SUB-CENTER NUMBER FROM -C PDS BYTE 26 -C 93-10-13 CAVANAUGH MODIFIED FI634 TO CORRECT GRID SIZES FOR -C GRIDS 204 AND 208 -C 93-10-14 CAVANAUGH INCREASED SIZE OF KGDS TO INCLUDE ENTRIES FOR -C NUMBER OF POINTS IN GRID AND NUMBER OF WORDS -C IN EACH ROW -C 93-12-08 CAVANAUGH CORRECTED TEST FOR EDITION NUMBER INSTEAD -C OF VERSION NUMBER -C 93-12-15 CAVANAUGH MODIFIED SECOND ORDER POINTERS TO FIRST ORDER -C VALUES AND SECOND ORDER VALUES CORRECTLY -C IN ROUTINE FI636 -C 94-03-02 CAVANAUGH ADDED CALL TO W3FI83 WITHIN DECODER. USER -C NO LONGER NEEDS TO MAKE CALL TO THIS ROUTINE -C 94-04-22 CAVANAUGH MODIFIED FI635, FI636 TO PROCESS ROW BY ROW -C SECOND ORDER PACKING, ADDED SCALING CORRECTION -C TO FI635, AND CORRECTED TYPOGRAPHICAL ERRORS -C IN COMMENT FIELDS IN FI634 -C 94-05-17 CAVANAUGH CORRECTED ERROR IN FI633 TO EXTRACT RESOLUTION -C FOR LAMBERT-CONFORMAL GRIDS. ADDED CLARIFYING -C INFORMATION TO DOCBLOCK ENTRIES -C 94-05-25 CAVANAUGH ADDED CODE TO PROCESS COLUMN BY COLUMN AS WELL -C AS ROW BY ROW ORDERING OF SECOND ORDER DATA -C 94-06-27 CAVANAUGH ADDED PROCESSING FOR GRIDS 45, 94 AND 95. -C INCLUDES CONSTRUCTION OF SECOND ORDER BIT MAPS -C FOR THINNED GRIDS IN FI636. -C 94-07-08 CAVANAUGH COMMENTED OUT PRINT OUTS USED FOR DEBUGGING -C 94-09-08 CAVANAUGH ADDED GRIDS 220, 221, 223 FOR FNOC -C 94-11-10 FARLEY INCREASED MXSIZE FROM 72960 TO 260000 -C FOR .5 DEGREE SST ANALYSIS FIELDS -C 94-12-06 R.E.JONES CHANGES IN FI632 FOR PDS GREATER THAN 28 -C 95-02-14 R.E.JONES CORRECT IN FI633 FOR NAVY WAFS GRIB -C 95-03-20 M.BALDWIN FI633 MODIFICATION TO GET -C DATA REP TYPES [KGDS(1)] 201 AND 202 TO WORK. -C 95-04-10 E.ROGERS ADDED GRIDS 96 AND 97 FOR ETA MODEL IN FI634. -C 95-04-26 R.E.JONES FI636 CORECTION FOR 2ND ORDER COMPLEX -C UNPACKING. R -C 95-05-19 R.E.JONES ADDED GRID 215, 20 KM AWIPS GRID -C 95-07-06 R.E.JONES ADDED GAUSSIAN T62, T126 GRID 98, 126 -C 95-10-19 R.E.JONES ADDED GRID 216, 45 KM ETA AWIPS ALASKA GRID -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 96-03-07 R.E.JONES CONTINUE UNPACK WITH KRET ERROR 9 IN FI631. -C 96-08-19 R.E.JONES ADDED MERCATOR GRIDS 8 AND 53, AND GRID 196 -C 97-02-12 W BOSTELMAN CORRECTS ECMWF US GRID 2 PROCESSING -C 98-06-17 IREDELL REMOVED ALTERNATE RETURN IN FI637 -C 98-08-31 IREDELL ELIMINATED NEED FOR MXSIZE -C 98-09-02 Gilbert Corrected error in map size for U.S. Grid 92 -C 98-09-08 BALDWIN ADD DATA REP TYPE [KGDS(1)] 203 -C 01-03-08 ROGERS CHANGED ETA GRIDS 90-97, ADDED ETA GRIDS -C 194, 198. ADDED AWIPS GRIDS 241,242,243, -C 245, 246, 247, 248, AND 250 -C 01-03-19 VUONG ADDED AWIPS GRIDS 238,239,240, AND 244 -C 01-05-03 ROGERS ADDED GRID 249 (12KM FOR ALASKA) -C 01-10-10 ROGERS REDEFINED GRID 218 FOR 12 KM ETA -C REDEFINED GRID 192 FOR NEW 32-KM ETA GRID -C 02-03-27 VUONG ADDED RSAS GRID 88 AND AWIPS GRIDS 219, 220, -C 223, 224, 225, 226, 227, 228, 229, 230, 231, -C 232, 233, 234, 235, 251, AND 252 -C 02-08-06 ROGERS REDEFINED GRIDS 90-93,97,194,245-250 FOR THE -C 8KM HI-RES-WINDOW MODEL AND ADD AWIPS GRID 253 -C 2003-06-30 GILBERT SET NEW VALUES IN ARRAY KPTR TO PASS BACK ADDITIONAL -C PACKING INFO. -C KPTR(19) - BINARY SCALE FACTOR -C KPTR(20) - NUM BITS USED TO PACK EACH DATUM -C 2003-06-30 GILBERT ADDED GRIDS 145 and 146 for CMAQ -C and GRID 175 for AWIPS over GUAM. -C 2003-07-08 VUONG ADDED GRIDS 110, 127, 171, 172 AND MODIFIED GRID 170 -C 2004-09-02 VUONG ADDED AWIPS GRIDS 147, 148, 173 AND 254 -C 2005-01-04 COOKE ADDED AWIPS GRIDS 160 AND 161 -C 2005-03-03 VUONG MOVED GRID 170 TO GRID 174 AND ADD GRID 170 -C 2005-03-21 VUONG ADDED AWIPS GRID 130 -C 2005-10-11 VUONG ADDED AWIPS GRID 163 -C 2006-12-12 VUONG ADDED AWIPS GRID 120 -C -C USAGE: CALL W3FI63(MSGA,KPDS,KGDS,KBMS,DATA,KPTR,KRET) -C INPUT ARGUMENT LIST: -C MSGA - GRIB FIELD - "GRIB" THRU "7777" CHAR*1 -C (MESSAGE CAN BE PRECEDED BY JUNK CHARS) -C -C OUTPUT ARGUMENT LIST: -C DATA - ARRAY CONTAINING DATA ELEMENTS -C KPDS - ARRAY CONTAINING PDS ELEMENTS. (EDITION 1) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C (26-35) - RESERVED -C (36-N) - CONSECUTIVE BYTES EXTRACTED FROM PROGRAM -C DEFINITION SECTION (PDS) OF GRIB MESSAGE -C KGDS - ARRAY CONTAINING GDS ELEMENTS. -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C STAGGERED ARAKAWA ROTATED LAT/LON GRIDS (TYPE 203) -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF CENTER -C (8) - LO(2) LONGITUDE OF CENTER -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C KBMS - BITMAP DESCRIBING LOCATION OF OUTPUT ELEMENTS. -C (ALWAYS CONSTRUCTED) -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C (1) - TOTAL LENGTH OF GRIB MESSAGE -C (2) - LENGTH OF INDICATOR (SECTION 0) -C (3) - LENGTH OF PDS (SECTION 1) -C (4) - LENGTH OF GDS (SECTION 2) -C (5) - LENGTH OF BMS (SECTION 3) -C (6) - LENGTH OF BDS (SECTION 4) -C (7) - VALUE OF CURRENT BYTE -C (8) - BIT POINTER -C (9) - GRIB START BIT NR -C (10) - GRIB/GRID ELEMENT COUNT -C (11) - NR UNUSED BITS AT END OF SECTION 3 -C (12) - BIT MAP FLAG (COPY OF BMS OCTETS 5,6) -C (13) - NR UNUSED BITS AT END OF SECTION 2 -C (14) - BDS FLAGS (RIGHT ADJ COPY OF OCTET 4) -C (15) - NR UNUSED BITS AT END OF SECTION 4 -C (16) - RESERVED -C (17) - RESERVED -C (18) - RESERVED -C (19) - BINARY SCALE FACTOR -C (20) - NUM BITS USED TO PACK EACH DATUM -C KRET - FLAG INDICATING QUALITY OF COMPLETION -C -C REMARKS: WHEN DECODING IS COMPLETED, DATA AT EACH GRID POINT HAS BEEN -C RETURNED IN THE UNITS SPECIFIED IN THE GRIB MANUAL. -C -C VALUES FOR RETURN FLAG (KRET) -C KRET = 0 - NORMAL RETURN, NO ERRORS -C = 1 - 'GRIB' NOT FOUND IN FIRST 100 CHARS -C = 2 - '7777' NOT IN CORRECT LOCATION -C = 3 - UNPACKED FIELD IS LARGER THAN 260000 -C = 4 - GDS/ GRID NOT ONE OF CURRENTLY ACCEPTED VALUES -C = 5 - GRID NOT CURRENTLY AVAIL FOR CENTER INDICATED -C = 8 - TEMP GDS INDICATED, BUT GDS FLAG IS OFF -C = 9 - GDS INDICATES SIZE MISMATCH WITH STD GRID -C =10 - INCORRECT CENTER INDICATOR -C =11 - BINARY DATA SECTION (BDS) NOT COMPLETELY PROCESSED. -C PROGRAM IS NOT SET TO PROCESS FLAG COMBINATIONS -C SHOWN IN OCTETS 4 AND 14. -C =12 - BINARY DATA SECTION (BDS) NOT COMPLETELY PROCESSED. -C PROGRAM IS NOT SET TO PROCESS FLAG COMBINATIONS -C -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ -C 4 AUG 1988 -C W3FI63 -C -C -C GRIB UNPACKING ROUTINE -C -C -C THIS ROUTINE WILL UNPACK A 'GRIB' FIELD TO THE EXACT GRID -C TYPE SPECIFIED IN THE MESSAGE, RETURN A BIT MAP AND MAKE THE -C VALUES OF THE PRODUCT DEFINITION SEC (PDS) AND THE GRID -C DESCRIPTION SEC (GDS) AVAILABLE IN RETURN ARRAYS. -C SEE "GRIB - THE WMO FORMAT FOR THE STORAGE OF WEATHER PRODUCT -C INFORMATION AND THE EXCHANGE OF WEATHER PRODUCT MESSAGES IN -C GRIDDED BINARY FORM" DATED JULY 1, 1988 BY JOHN D. STACKPOLE -C DOC, NOAA, NWS, NATIONAL METEOROLOGICAL CENTER. -C -C THE CALL TO THE GRIB UNPACKING ROUTINE IS AS FOLLOWS: -C -C CALL W3FI63(MSGA,KPDS,KGDS,LBMS,DATA,KPTR,KRET) -C -C INPUT: -C -C MSGA = CONTAINS THE GRIB MESSAGE TO BE UNPACKED. CHARACTERS -C "GRIB" MAY BEGIN ANYWHERE WITHIN FIRST 100 BYTES. -C -C OUTPUT: -C -C KPDS(100) INTEGER*4 -C ARRAY TO CONTAIN THE ELEMENTS OF THE PRODUCT -C DEFINITION SEC . -C (VERSION 1) -C KPDS(1) - ID OF CENTER -C KPDS(2) - MODEL IDENTIFICATION (SEE "GRIB" TABLE 1) -C KPDS(3) - GRID IDENTIFICATION (SEE "GRIB" TABLE 2) -C KPDS(4) - GDS/BMS FLAG -C BIT DEFINITION -C 25 0 - GDS OMITTED -C 1 - GDS INCLUDED -C 26 0 - BMS OMITTED -C 1 - BMS INCLUDED -C NOTE:- LEFTMOST BIT = 1, -C RIGHTMOST BIT = 32 -C KPDS(5) - INDICATOR OF PARAMETER (SEE "GRIB" TABLE 5) -C KPDS(6) - TYPE OF LEVEL (SEE "GRIB" TABLES 6 & 7) -C KPDS(7) - HEIGHT,PRESSURE,ETC OF LEVEL -C KPDS(8) - YEAR INCLUDING CENTURY -C KPDS(9) - MONTH OF YEAR -C KPDS(10) - DAY OF MONTH -C KPDS(11) - HOUR OF DAY -C KPDS(12) - MINUTE OF HOUR -C KPDS(13) - INDICATOR OF FORECAST TIME UNIT (SEE "GRIB" -C TABLE 8) -C KPDS(14) - TIME 1 (SEE "GRIB" TABLE 8A) -C KPDS(15) - TIME 2 (SEE "GRIB" TABLE 8A) -C KPDS(16) - TIME RANGE INDICATOR (SEE "GRIB" TABLE 8A) -C KPDS(17) - NUMBER INCLUDED IN AVERAGE -C KPDS(18) - EDITION NR OF GRIB SPECIFICATION -C KPDS(19) - VERSION NR OF PARAMETER TABLE -C -C KGDS(13) INTEGER*4 -C ARRAY CONTAINING GDS ELEMENTS. -C -C KGDS(1) - DATA REPRESENTATION TYPE -C -C LATITUDE/LONGITUDE GRIDS (SEE "GRIB" TABLE 10) -C KGDS(2) - N(I) NUMBER OF POINTS ON LATITUDE -C CIRCLE -C KGDS(3) - N(J) NUMBER OF POINTS ON LONGITUDE -C CIRCLE -C KGDS(4) - LA(1) LATITUDE OF ORIGIN -C KGDS(5) - LO(1) LONGITUDE OF ORIGIN -C KGDS(6) - RESOLUTION FLAG -C BIT MEANING -C 25 0 - DIRECTION INCREMENTS NOT -C GIVEN -C 1 - DIRECTION INCREMENTS GIVEN -C KGDS(7) - LA(2) LATITUDE OF EXTREME POINT -C KGDS(8) - LO(2) LONGITUDE OF EXTREME POINT -C KGDS(9) - DI LONGITUDINAL DIRECTION INCREMENT -C KGDS(10) - REGULAR LAT/LON GRID -C DJ - LATITUDINAL DIRECTION -C INCREMENT -C GAUSSIAN GRID -C N - NUMBER OF LATITUDE CIRCLES -C BETWEEN A POLE AND THE EQUATOR -C KGDS(11) - SCANNING MODE FLAG -C BIT MEANING -C 25 0 - POINTS ALONG A LATITUDE -C SCAN FROM WEST TO EAST -C 1 - POINTS ALONG A LATITUDE -C SCAN FROM EAST TO WEST -C 26 0 - POINTS ALONG A MERIDIAN -C SCAN FROM NORTH TO SOUTH -C 1 - POINTS ALONG A MERIDIAN -C SCAN FROM SOUTH TO NORTH -C 27 0 - POINTS SCAN FIRST ALONG -C CIRCLES OF LATITUDE, THEN -C ALONG MERIDIANS -C (FORTRAN: (I,J)) -C 1 - POINTS SCAN FIRST ALONG -C MERIDIANS THEN ALONG -C CIRCLES OF LATITUDE -C (FORTRAN: (J,I)) -C -C POLAR STEREOGRAPHIC GRIDS (SEE GRIB TABLE 12) -C KGDS(2) - N(I) NR POINTS ALONG LAT CIRCLE -C KGDS(3) - N(J) NR POINTS ALONG LON CIRCLE -C KGDS(4) - LA(1) LATITUDE OF ORIGIN -C KGDS(5) - LO(1) LONGITUDE OF ORIGIN -C KGDS(6) - RESERVED -C KGDS(7) - LOV GRID ORIENTATION -C KGDS(8) - DX - X DIRECTION INCREMENT -C KGDS(9) - DY - Y DIRECTION INCREMENT -C KGDS(10) - PROJECTION CENTER FLAG -C KGDS(11) - SCANNING MODE -C -C SPHERICAL HARMONIC COEFFICIENTS (SEE "GRIB" TABLE 14) -C KGDS(2) - J PENTAGONAL RESOLUTION PARAMETER -C KGDS(3) - K PENTAGONAL RESOLUTION PARAMETER -C KGDS(4) - M PENTAGONAL RESOLUTION PARAMETER -C KGDS(5) - REPRESENTATION TYPE -C KGDS(6) - COEFFICIENT STORAGE MODE -C -C MERCATOR GRIDS -C KGDS(2) - N(I) NR POINTS ON LATITUDE CIRCLE -C KGDS(3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C KGDS(4) - LA(1) LATITUDE OF ORIGIN -C KGDS(5) - LO(1) LONGITUDE OF ORIGIN -C KGDS(6) - RESOLUTION FLAG -C KGDS(7) - LA(2) LATITUDE OF LAST GRID POINT -C KGDS(8) - LO(2) LONGITUDE OF LAST GRID POINT -C KGDS(9) - LATIN - LATITUDE OF PROJECTION INTERSECTION -C KGDS(10) - RESERVED -C KGDS(11) - SCANNING MODE FLAG -C KGDS(12) - LONGITUDINAL DIR GRID LENGTH -C KGDS(13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C KGDS(2) - NX NR POINTS ALONG X-AXIS -C KGDS(3) - NY NR POINTS ALONG Y-AXIS -C KGDS(4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C KGDS(5) - LO1 LON OF ORIGIN (LOWER LEFT) -C KGDS(6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C KGDS(7) - LOV - ORIENTATION OF GRID -C KGDS(8) - DX - X-DIR INCREMENT -C KGDS(9) - DY - Y-DIR INCREMENT -C KGDS(10) - PROJECTION CENTER FLAG -C KGDS(11) - SCANNING MODE FLAG -C KGDS(12) - LATIN 1 - FIRST LAT FROM POLE OF -C SECANT CONE INTERSECTION -C KGDS(13) - LATIN 2 - SECOND LAT FROM POLE OF -C SECANT CONE INTERSECTION -C -C LBMS(*) LOGICAL -C ARRAY TO CONTAIN THE BIT MAP DESCRIBING THE -C PLACEMENT OF DATA IN THE OUTPUT ARRAY. IF A -C BIT MAP IS NOT INCLUDED IN THE SOURCE MESSAGE, -C ONE WILL BE GENERATED AUTOMATICALLY BY THE -C UNPACKING ROUTINE. -C -C -C DATA(*) REAL*4 -C THIS ARRAY WILL CONTAIN THE UNPACKED DATA POINTS. -C -C NOTE:- 65160 IS MAXIMUN FIELD SIZE ALLOWABLE -C -C KPTR(10) INTEGER*4 -C ARRAY CONTAINING STORAGE FOR THE FOLLOWING -C PARAMETERS. -C -C (1) - UNUSED -C (2) - UNUSED -C (3) - LENGTH OF PDS (IN BYTES) -C (4) - LENGTH OF GDS (IN BYTES) -C (5) - LENGTH OF BMS (IN BYTES) -C (6) - LENGTH OF BDS (IN BYTES) -C (7) - USED BY UNPACKING ROUTINE -C (8) - NUMBER OF DATA POINTS FOR GRID -C (9) - "GRIB" CHARACTERS START IN BYTE NUMBER -C (10) - USED BY UNPACKING ROUTINE -C -C -C KRET INTEGER*4 -C THIS VARIABLE WILL CONTAIN THE RETURN INDICATOR. -C -C 0 - NO ERRORS DETECTED. -C -C 1 - 'GRIB' NOT FOUND IN FIRST 100 -C CHARACTERS. -C -C 2 - '7777' NOT FOUND, EITHER MISSING OR -C TOTAL OF SEC COUNTS OF INDIVIDUAL -C SECTIONS IS INCORRECT. -C -C 3 - UNPACKED FIELD IS LARGER THAN 65160. -C -C 4 - IN GDS, DATA REPRESENTATION TYPE -C NOT ONE OF THE CURRENTLY ACCEPTABLE -C VALUES. SEE "GRIB" TABLE 9. VALUE -C OF INCORRECT TYPE RETURNED IN KGDS(1). -C -C 5 - GRID INDICATED IN KPDS(3) IS NOT -C AVAILABLE FOR THE CENTER INDICATED IN -C KPDS(1) AND NO GDS SENT. -C -C 7 - EDITION INDICATED IN KPDS(18) HAS NOT -C YET BEEN INCLUDED IN THE DECODER. -C -C 8 - GRID IDENTIFICATION = 255 (NOT STANDARD -C GRID) BUT FLAG INDICATING PRESENCE OF -C GDS IS TURNED OFF. NO METHOD OF -C GENERATING PROPER GRID. -C -C 9 - PRODUCT OF KGDS(2) AND KGDS(3) DOES NOT -C MATCH STANDARD NUMBER OF POINTS FOR THIS -C GRID (FOR OTHER THAN SPECTRALS). THIS -C WILL OCCUR ONLY IF THE GRID. -C IDENTIFICATION, KPDS(3), AND A -C TRANSMITTED GDS ARE INCONSISTENT. -C -C 10 - CENTER INDICATOR WAS NOT ONE INDICATED -C IN "GRIB" TABLE 1. PLEASE CONTACT AD -C PRODUCTION MANAGEMENT BRANCH (W/NMC42) -C IF THIS ERROR IS ENCOUNTERED. -C -C 11 - BINARY DATA SECTION (BDS) NOT COMPLETELY -C PROCESSED. PROGRAM IS NOT SET TO PROCESS -C FLAG COMBINATIONS AS SHOWN IN -C OCTETS 4 AND 14. -C -C -C LIST OF TEXT MESSAGES FROM CODE -C -C -C W3FI63/FI632 -C -C 'HAVE ENCOUNTERED A NEW GRID FOR NMC, PLEASE NOTIFY -C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH -C (W/NMC42)' -C -C 'HAVE ENCOUNTERED A NEW GRID FOR ECMWF, PLEASE NOTIFY -C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH -C (W/NMC42)' -C -C 'HAVE ENCOUNTERED A NEW GRID FOR U.K. METEOROLOGICAL -C OFFICE, BRACKNELL. PLEASE NOTIFY AUTOMATION DIVISION, -C PRODUCTION MANAGEMENT BRANCH (W/NMC42)' -C -C 'HAVE ENCOUNTERED A NEW GRID FOR FNOC, PLEASE NOTIFY -C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH -C (W/NMC42)' -C -C -C W3FI63/FI633 -C -C 'POLAR STEREO PROCESSING NOT AVAILABLE' * -C -C W3FI63/FI634 -C -C 'WARNING - BIT MAP MAY NOT BE ASSOCIATED WITH SPHERICAL -C COEFFICIENTS' -C -C -C W3FI63/FI637 -C -C 'NO CURRENT LISTING OF FNOC GRIDS' * -C -C -C * WILL BE AVAILABLE IN NEXT UPDATE -C *************************************************************** -C -C INCOMING MESSAGE HOLDER - CHARACTER*1 MSGA(*) -C BIT MAP - LOGICAL*1 KBMS(*) -C -C ELEMENTS OF PRODUCT DESCRIPTION SEC (PDS) - INTEGER KPDS(*) -C ELEMENTS OF GRID DESCRIPTION SEC (PDS) - INTEGER KGDS(*) -C -C CONTAINER FOR GRIB GRID - REAL DATA(*) -C -C ARRAY OF POINTERS AND COUNTERS - INTEGER KPTR(*) -C -C ***************************************************************** - INTEGER KKK,JSGN,JEXP,IFR,NPTS - CHARACTER KK(8) - REAL REALKK,FVAL1,FDIFF1 - EQUIVALENCE (KK(1),KKK) -C ***************************************************************** -C 1.0 LOCATE BEGINNING OF 'GRIB' MESSAGE -C FIND 'GRIB' CHARACTERS -C 2.0 USE COUNTS IN EACH DESCRIPTION SEC TO DETERMINE -C IF '7777' IS IN PROPER PLACE. -C 3.0 PARSE PRODUCT DEFINITION SECTION. -C 4.0 PARSE GRID DESCRIPTION SEC (IF INCLUDED) -C 5.0 PARSE BIT MAP SEC (IF INCLUDED) -C 6.0 USING INFORMATION FROM PRODUCT DEFINITION, GRID -C DESCRIPTION, AND BIT MAP SECTIONS.. EXTRACT -C DATA AND PLACE INTO PROPER ARRAY. -C ******************************************************************* -C -C MAIN DRIVER -C -C ******************************************************************* - KPTR(10) = 0 -C SEE IF PROPER 'GRIB' KEY EXISTS, THEN -C USING SEC COUNTS, DETERMINE IF '7777' -C IS IN THE PROPER LOCATION -C - CALL FI631(MSGA,KPTR,KPDS,KRET) - IF(KRET.NE.0) THEN - GO TO 900 - END IF -C PRINT *,'FI631 KPTR',(KPTR(I),I=1,16) -C -C PARSE PARAMETERS FROM PRODUCT DESCRIPTION SECTION -C - CALL FI632(MSGA,KPTR,KPDS,KRET) - IF(KRET.NE.0) THEN - GO TO 900 - END IF -C PRINT *,'FI632 KPTR',(KPTR(I),I=1,16) -C -C IF AVAILABLE, EXTRACT NEW GRID DESCRIPTION -C - IF (IAND(KPDS(4),128).NE.0) THEN - CALL FI633(MSGA,KPTR,KGDS,KRET) - IF(KRET.NE.0) THEN - GO TO 900 - END IF -C PRINT *,'FI633 KPTR',(KPTR(I),I=1,16) - END IF -C -C EXTRACT OR GENERATE BIT MAP -C - CALL FI634(MSGA,KPTR,KPDS,KGDS,KBMS,KRET) - IF (KRET.NE.0) THEN - IF (KRET.NE.9) THEN - GO TO 900 - END IF - END IF -C PRINT *,'FI634 KPTR',(KPTR(I),I=1,16) -C -C USING INFORMATION FROM PDS, BMS AND BIT DATA SEC , -C EXTRACT AND SAVE IN GRIB GRID, ALL DATA ENTRIES. -C - IF (KPDS(18).EQ.1) THEN - CALL FI635(MSGA,KPTR,KPDS,KGDS,KBMS,DATA,KRET) - IF (KPTR(3).EQ.50) THEN -C -C PDS EQUAL 50 BYTES -C THEREFORE SOMETHING SPECIAL IS GOING ON -C -C IN THIS CASE 2ND DIFFERENCE PACKING -C NEEDS TO BE UNDONE. -C -C EXTRACT FIRST VALUE FROM BYTE 41-44 PDS -C KPTR(9) CONTAINS OFFSET TO START OF -C GRIB MESSAGE. -C EXTRACT FIRST FIRST-DIFFERENCE FROM BYTES 45-48 PDS -C -C AND EXTRACT SCALE FACTOR (E) TO UNDO 2**E -C THAT WAS APPLIED PRIOR TO 2ND ORDER PACKING -C AND PLACED IN PDS BYTES 49-51 -C FACTOR IS A SIGNED TWO BYTE INTEGER -C -C ALSO NEED THE DECIMAL SCALING FROM PDS(27-28) -C (AVAILABLE IN KPDS(22) FROM UNPACKER) -C TO UNDO THE DECIMAL SCALING APPLIED TO THE -C SECOND DIFFERENCES DURING UNPACKING. -C SECOND DIFFS ALWAYS PACKED WITH 0 DECIMAL SCALE -C BUT UNPACKER DOESNT KNOW THAT. -C -C CALL GBYTE (MSGA,FVAL1,KPTR(9)+384,32) -C -C NOTE INTEGERS, CHARACTERS AND EQUIVALENCES -C DEFINED ABOVE TO MAKE THIS KKK EXTRACTION -C WORK AND LINE UP ON WORD BOUNDARIES -C - CALL GBYTE (MSGA,KKK,KPTR(9)+384,32) -C -C THE NEXT CODE WILL CONVERT THE IBM370 FOATING POINT -C TO THE FLOATING POINT USED ON YOUR MACHINE. -C -C 1ST TEST TO SEE IN ON 32 OR 64 BIT WORD MACHINE -C LW = 4 OR 8; IF 8 MAY BE A CRAY -C - CALL W3FI01(LW) - IF (LW.EQ.4) THEN - CALL GBYTE (KK,JSGN,0,1) - CALL GBYTE (KK,JEXP,1,7) - CALL GBYTE (KK,IFR,8,24) - ELSE - CALL GBYTE (KK,JSGN,32,1) - CALL GBYTE (KK,JEXP,33,7) - CALL GBYTE (KK,IFR,40,24) - ENDIF -C - IF (IFR.EQ.0) THEN - REALKK = 0.0 - ELSE IF (JEXP.EQ.0.AND.IFR.EQ.0) THEN - REALKK = 0.0 - ELSE - REALKK = FLOAT(IFR) * 16.0 ** (JEXP - 64 - 6) - IF (JSGN.NE.0) REALKK = -REALKK - END IF - FVAL1 = REALKK -C -C CALL GBYTE (MSGA,FDIFF1,KPTR(9)+416,32) -C (REPLACED BY FOLLOWING EXTRACTION) -C - CALL GBYTE (MSGA,KKK,KPTR(9)+416,32) -C -C THE NEXT CODE WILL CONVERT THE IBM370 FOATING POINT -C TO THE FLOATING POINT USED ON YOUR MACHINE. -C -C 1ST TEST TO SEE IN ON 32 OR 64 BIT WORD MACHINE -C LW = 4 OR 8; IF 8 MAY BE A CRAY -C - CALL W3FI01(LW) - IF (LW.EQ.4) THEN - CALL GBYTE (KK,JSGN,0,1) - CALL GBYTE (KK,JEXP,1,7) - CALL GBYTE (KK,IFR,8,24) - ELSE - CALL GBYTE (KK,JSGN,32,1) - CALL GBYTE (KK,JEXP,33,7) - CALL GBYTE (KK,IFR,40,24) - ENDIF -C - IF (IFR.EQ.0) THEN - REALKK = 0.0 - ELSE IF (JEXP.EQ.0.AND.IFR.EQ.0) THEN - REALKK = 0.0 - ELSE - REALKK = FLOAT(IFR) * 16.0 ** (JEXP - 64 - 6) - IF (JSGN.NE.0) REALKK = -REALKK - END IF - FDIFF1 = REALKK -C - CALL GBYTE (MSGA,ISIGN,KPTR(9)+448,1) - CALL GBYTE (MSGA,ISCAL2,KPTR(9)+449,15) - IF(ISIGN.GT.0) THEN - ISCAL2 = - ISCAL2 - ENDIF -C PRINT *,'DELTA POINT 1-',FVAL1 -C PRINT *,'DELTA POINT 2-',FDIFF1 -C PRINT *,'DELTA POINT 3-',ISCAL2 - NPTS = KPTR(10) -C WRITE (6,FMT='('' 2ND DIFF POINTS IN FIELD = '',/, -C & 10(3X,10F12.2,/))') (DATA(I),I=1,NPTS) -C PRINT *,'DELTA POINT 4-',KPDS(22) - CALL W3FI83 (DATA,NPTS,FVAL1,FDIFF1, - & ISCAL2,KPDS(22),KPDS,KGDS) -C WRITE (6,FMT='('' 2ND DIFF EXPANDED POINTS IN FIELD = '', -C & /,10(3X,10F12.2,/))') (DATA(I),I=1,NPTS) -C WRITE (6,FMT='('' END OF ARRAY IN FIELD = '',/, -C & 10(3X,10F12.2,/))') (DATA(I),I=NPTS-5,NPTS) - END IF - ELSE -C PRINT *,'FI635 NOT PROGRAMMED FOR EDITION NR',KPDS(18) - KRET = 7 - END IF -C - 900 RETURN - END - SUBROUTINE FI631(MSGA,KPTR,KPDS,KRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI631 FIND 'GRIB' CHARS & RESET POINTERS -C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 91-09-13 -C -C ABSTRACT: FIND 'GRIB; CHARACTERS AND SET POINTERS TO THE NEXT -C BYTE FOLLOWING 'GRIB'. IF THEY EXIST EXTRACT COUNTS FROM GDS AND -C BMS. EXTRACT COUNT FROM BDS. DETERMINE IF SUM OF COUNTS ACTUALLY -C PLACES TERMINATOR '7777' AT THE CORRECT LOCATION. -C -C PROGRAM HISTORY LOG: -C 91-09-13 CAVANAUGH -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C -C USAGE: CALL FI631(MSGA,KPTR,KPDS,KRET) -C INPUT ARGUMENT LIST: -C MSGA - GRIB FIELD - "GRIB" THRU "7777" -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C (1) - TOTAL LENGTH OF GRIB MESSAGE -C (2) - LENGTH OF INDICATOR (SECTION 0) -C (3) - LENGTH OF PDS (SECTION 1) -C (4) - LENGTH OF GDS (SECTION 2) -C (5) - LENGTH OF BMS (SECTION 3) -C (6) - LENGTH OF BDS (SECTION 4) -C (7) - VALUE OF CURRENT BYTE -C (8) - BIT POINTER -C (9) - GRIB START BIT NR -C (10) - GRIB/GRID ELEMENT COUNT -C (11) - NR UNUSED BITS AT END OF SECTION 3 -C (12) - BIT MAP FLAG -C (13) - NR UNUSED BITS AT END OF SECTION 2 -C (14) - BDS FLAGS -C (15) - NR UNUSED BITS AT END OF SECTION 4 -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KPDS - ARRAY CONTAINING PDS ELEMENTS. -C (1) - ID OF CENTER -C (2) - MODEL IDENTIFICATION -C (3) - GRID IDENTIFICATION -C (4) - GDS/BMS FLAG -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR OF CENTURY -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C KPTR - SEE INPUT LIST -C KRET - ERROR RETURN -C -C REMARKS: -C ERROR RETURNS -C KRET = 1 - NO 'GRIB' -C 2 - NO '7777' OR MISLOCATED (BY COUNTS) -C -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: HDS9000 -C -C$$$ -C -C INCOMING MESSAGE HOLDER - CHARACTER*1 MSGA(*) -C ARRAY OF POINTERS AND COUNTERS - INTEGER KPTR(*) -C PRODUCT DESCRIPTION SECTION DATA. - INTEGER KPDS(*) -C - INTEGER KRET -C -C ****************************************************************** - KRET = 0 -C ------------------- FIND 'GRIB' KEY - DO 50 I = 0, 839, 8 - CALL GBYTE (MSGA,MGRIB,I,32) - IF (MGRIB.EQ.1196575042) THEN - KPTR(9) = I - GO TO 60 - END IF - 50 CONTINUE - KRET = 1 - RETURN - 60 CONTINUE -C -------------FOUND 'GRIB' -C SKIP GRIB CHARACTERS -C PRINT *,'FI631 GRIB AT',I - KPTR(8) = KPTR(9) + 32 - CALL GBYTE (MSGA,ITOTAL,KPTR(8),24) -C HAVE LIFTED WHAT MAY BE A MSG TOTAL BYTE COUNT - IPOINT = KPTR(9) + ITOTAL * 8 - 32 - CALL GBYTE (MSGA,I7777,IPOINT,32) - IF (I7777.EQ.926365495) THEN -C HAVE FOUND END OF MESSAGE '7777' IN PROPER LOCATION -C MARK AND PROCESS AS GRIB VERSION 1 OR HIGHER -C PRINT *,'FI631 7777 AT',IPOINT - KPTR(8) = KPTR(8) + 24 - KPTR(1) = ITOTAL - KPTR(2) = 8 - CALL GBYTE (MSGA,KPDS(18),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 - ELSE -C CANNOT FIND END OF GRIB EDITION 1 MESSAGE - KRET = 2 - RETURN - END IF -C ------------------- PROCESS SECTION 1 -C EXTRACT COUNT FROM PDS -C PRINT *,'START OF PDS',KPTR(8) - CALL GBYTE (MSGA,KPTR(3),KPTR(8),24) - LOOK = KPTR(8) + 56 -C EXTRACT GDS/BMS FLAG - CALL GBYTE (MSGA,KPDS(4),LOOK,8) - KPTR(8) = KPTR(8) + KPTR(3) * 8 -C PRINT *,'START OF GDS',KPTR(8) - IF (IAND(KPDS(4),128).NE.0) THEN -C EXTRACT COUNT FROM GDS - CALL GBYTE (MSGA,KPTR(4),KPTR(8),24) - KPTR(8) = KPTR(8) + KPTR(4) * 8 - ELSE - KPTR(4) = 0 - END IF -C PRINT *,'START OF BMS',KPTR(8) - IF (IAND(KPDS(4),64).NE.0) THEN -C EXTRACT COUNT FROM BMS - CALL GBYTE (MSGA,KPTR(5),KPTR(8),24) - ELSE - KPTR(5) = 0 - END IF - KPTR(8) = KPTR(8) + KPTR(5) * 8 -C PRINT *,'START OF BDS',KPTR(8) -C EXTRACT COUNT FROM BDS - CALL GBYTE (MSGA,KPTR(6),KPTR(8),24) -C --------------- TEST FOR '7777' -C PRINT *,(KPTR(KJ),KJ=1,10) - KPTR(8) = KPTR(8) + KPTR(6) * 8 -C EXTRACT FOUR BYTES FROM THIS LOCATION -C PRINT *,'FI631 LOOKING FOR 7777 AT',KPTR(8) - CALL GBYTE (MSGA,K7777,KPTR(8),32) - MATCH = KPTR(2) + KPTR(3) + KPTR(4) + KPTR(5) + KPTR(6) + 4 - IF (K7777.NE.926365495.OR.MATCH.NE.KPTR(1)) THEN - KRET = 2 - ELSE -C PRINT *,'FI631 7777 AT',KPTR(8) - IF (KPDS(18).EQ.0) THEN - KPTR(1) = KPTR(2) + KPTR(3) + KPTR(4) + KPTR(5) + - * KPTR(6) + 4 - END IF - END IF -C PRINT *,'KPTR',(KPTR(I),I=1,16) - RETURN - END - SUBROUTINE FI632(MSGA,KPTR,KPDS,KRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI632 GATHER INFO FROM PRODUCT DEFINITION SEC -C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 91-09-13 -C -C ABSTRACT: EXTRACT INFORMATION FROM THE PRODUCT DESCRIPTION -C SEC , AND GENERATE LABEL INFORMATION TO PERMIT STORAGE -C IN OFFICE NOTE 84 FORMAT. -C -C PROGRAM HISTORY LOG: -C 91-09-13 CAVANAUGH -C 93-12-08 CAVANAUGH CORRECTED TEST FOR EDITION NUMBER INSTEAD -C OF VERSION NUMBER -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 99-01-20 BALDWIN MODIFIED TO HANDLE GRID 237 -C -C USAGE: CALL FI632(MSGA,KPTR,KPDS,KRET) -C INPUT ARGUMENT LIST: -C MSGA - ARRAY CONTAINING GRIB MESSAGE -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C (1) - TOTAL LENGTH OF GRIB MESSAGE -C (2) - LENGTH OF INDICATOR (SECTION 0) -C (3) - LENGTH OF PDS (SECTION 1) -C (4) - LENGTH OF GDS (SECTION 2) -C (5) - LENGTH OF BMS (SECTION 3) -C (6) - LENGTH OF BDS (SECTION 4) -C (7) - VALUE OF CURRENT BYTE -C (8) - BIT POINTER -C (9) - GRIB START BIT NR -C (10) - GRIB/GRID ELEMENT COUNT -C (11) - NR UNUSED BITS AT END OF SECTION 3 -C (12) - BIT MAP FLAG -C (13) - NR UNUSED BITS AT END OF SECTION 2 -C (14) - BDS FLAGS -C (15) - NR UNUSED BITS AT END OF SECTION 4 -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KPDS - ARRAY CONTAINING PDS ELEMENTS. -C (1) - ID OF CENTER -C (2) - MODEL IDENTIFICATION -C (3) - GRID IDENTIFICATION -C (4) - GDS/BMS FLAG -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR OF CENTURY -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - -C (19) - -C (20) - NUMBER MISSING FROM AVGS/ACCUMULATIONS -C (21) - CENTURY -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C SEE INPUT LIST -C KRET - ERROR RETURN -C -C REMARKS: -C ERROR RETURN = 0 - NO ERRORS -C = 8 - TEMP GDS INDICATED, BUT NO GDS -C -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: HDS9000 -C -C$$$ -C -C INCOMING MESSAGE HOLDER - CHARACTER*1 MSGA(*) -C -C ARRAY OF POINTERS AND COUNTERS - INTEGER KPTR(*) -C PRODUCT DESCRIPTION SECTION ENTRIES - INTEGER KPDS(*) -C - INTEGER KRET -C ------------------- PROCESS SECTION 1 - KPTR(8) = KPTR(9) + KPTR(2) * 8 + 24 -C BYTE 4 -C PARAMETER TABLE VERSION NR - CALL GBYTE (MSGA,KPDS(19),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 5 IDENTIFICATION OF CENTER - CALL GBYTE (MSGA,KPDS(1),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 6 -C GET GENERATING PROCESS ID NR - CALL GBYTE (MSGA,KPDS(2),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 7 -C GRID DEFINITION - CALL GBYTE (MSGA,KPDS(3),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 8 -C GDS/BMS FLAGS -C CALL GBYTE (MSGA,KPDS(4),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 9 -C INDICATOR OF PARAMETER - CALL GBYTE (MSGA,KPDS(5),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 10 -C TYPE OF LEVEL - CALL GBYTE (MSGA,KPDS(6),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 11,12 -C HEIGHT/PRESSURE - CALL GBYTE (MSGA,KPDS(7),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C BYTE 13 -C YEAR OF CENTURY - CALL GBYTE (MSGA,KPDS(8),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 14 -C MONTH OF YEAR - CALL GBYTE (MSGA,KPDS(9),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 15 -C DAY OF MONTH - CALL GBYTE (MSGA,KPDS(10),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 16 -C HOUR OF DAY - CALL GBYTE (MSGA,KPDS(11),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 17 -C MINUTE - CALL GBYTE (MSGA,KPDS(12),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 18 -C INDICATOR TIME UNIT RANGE - CALL GBYTE (MSGA,KPDS(13),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 19 -C P1 - PERIOD OF TIME - CALL GBYTE (MSGA,KPDS(14),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 20 -C P2 - PERIOD OF TIME - CALL GBYTE (MSGA,KPDS(15),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 21 -C TIME RANGE INDICATOR - CALL GBYTE (MSGA,KPDS(16),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C -C IF TIME RANGE INDICATOR IS 10, P1 IS PACKED IN -C PDS BYTES 19-20 -C - IF (KPDS(16).EQ.10) THEN - KPDS(14) = KPDS(14) * 256 + KPDS(15) - KPDS(15) = 0 - END IF -C BYTE 22,23 -C NUMBER INCLUDED IN AVERAGE - CALL GBYTE (MSGA,KPDS(17),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C BYTE 24 -C NUMBER MISSING FROM AVERAGES/ACCUMULATIONS - CALL GBYTE (MSGA,KPDS(20),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 25 -C IDENTIFICATION OF CENTURY - CALL GBYTE (MSGA,KPDS(21),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 - IF (KPTR(3).GT.25) THEN -C BYTE 26 SUB CENTER NUMBER - CALL GBYTE (MSGA,KPDS(23),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 - IF (KPTR(3).GE.28) THEN -C BYTE 27-28 -C UNITS DECIMAL SCALE FACTOR - CALL GBYTE (MSGA,ISIGN,KPTR(8),1) - KPTR(8) = KPTR(8) + 1 - CALL GBYTE (MSGA,IDEC,KPTR(8),15) - KPTR(8) = KPTR(8) + 15 - IF (ISIGN.GT.0) THEN - KPDS(22) = - IDEC - ELSE - KPDS(22) = IDEC - END IF - ISIZ = KPTR(3) - 28 - IF (ISIZ.LE.12) THEN -C BYTE 29 - CALL GBYTE (MSGA,KPDS(24),KPTR(8)+8,8) -C BYTE 30 - CALL GBYTE (MSGA,KPDS(25),KPTR(8)+16,8) -C BYTES 31-40 CURRENTLY RESERVED FOR FUTURE USE - KPTR(8) = KPTR(8) + ISIZ * 8 - ELSE -C BYTE 29 - CALL GBYTE (MSGA,KPDS(24),KPTR(8)+8,8) -C BYTE 30 - CALL GBYTE (MSGA,KPDS(25),KPTR(8)+16,8) -C BYTES 31-40 CURRENTLY RESERVED FOR FUTURE USE - KPTR(8) = KPTR(8) + 12 * 8 -C BYTES 41 - N LOCAL USE DATA - CALL W3FI01(LW) - MWDBIT = LW * 8 - ISIZ = KPTR(3) - 40 - ITER = ISIZ / LW - IF (MOD(ISIZ,LW).NE.0) ITER = ITER + 1 - CALL GBYTES (MSGA,KPDS(36),KPTR(8),MWDBIT,0,ITER) - KPTR(8) = KPTR(8) + ISIZ * 8 - END IF - END IF - END IF -C ----------- TEST FOR NEW GRID - IF (IAND(KPDS(4),128).NE.0) THEN - IF (IAND(KPDS(4),64).NE.0) THEN - IF (KPDS(3).NE.255) THEN - IF (KPDS(3).GE.21.AND.KPDS(3).LE.26)THEN - RETURN - ELSE IF (KPDS(3).GE.37.AND.KPDS(3).LE.44)THEN - RETURN - ELSE IF (KPDS(3).GE.61.AND.KPDS(3).LE.64) THEN - RETURN - END IF - IF (KPDS(1).EQ.7) THEN - IF (KPDS(3).GE.2.AND.KPDS(3).LE.3) THEN - ELSE IF (KPDS(3).GE.5.AND.KPDS(3).LE.6) THEN - ELSE IF (KPDS(3).EQ.8) THEN - ELSE IF (KPDS(3).GE.27.AND.KPDS(3).LE.34) THEN - ELSE IF (KPDS(3).EQ.50) THEN - ELSE IF (KPDS(3).EQ.53) THEN - ELSE IF (KPDS(3).GE.70.AND.KPDS(3).LE.77) THEN - ELSE IF (KPDS(3).EQ.98) THEN - ELSE IF (KPDS(3).GE.100.AND.KPDS(3).LE.105) THEN - ELSE IF (KPDS(3).EQ.126) THEN - ELSE IF (KPDS(3).EQ.196) THEN - ELSE IF (KPDS(3).GE.201.AND.KPDS(3).LE.237) THEN - ELSE -C PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR', -C * ' NMC WITHOUT A GRID DESCRIPTION SECTION' -C PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION' -C PRINT *,' PRODUCTION MANAGEMENT BRANCH' -C PRINT *,' W/NMC42)' - END IF - ELSE IF (KPDS(1).EQ.98) THEN - IF (KPDS(3).GE.1.AND.KPDS(3).LE.16) THEN - ELSE -C PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR', -C * ' ECMWF WITHOUT A GRID DESCRIPTION SECTION' -C PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION' -C PRINT *,' PRODUCTION MANAGEMENT BRANCH' -C PRINT *,' W/NMC42)' - END IF - ELSE IF (KPDS(1).EQ.74) THEN - IF (KPDS(3).GE.1.AND.KPDS(3).LE.12) THEN - ELSE IF (KPDS(3).GE.21.AND.KPDS(3).LE.26)THEN - ELSE IF (KPDS(3).GE.61.AND.KPDS(3).LE.64) THEN - ELSE IF (KPDS(3).GE.70.AND.KPDS(3).LE.77) THEN - ELSE -C PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR', -C * ' U.K. MET OFFICE, BRACKNELL', -C * ' WITHOUT A GRID DESCRIPTION SECTION' -C PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION' -C PRINT *,' PRODUCTION MANAGEMENT BRANCH' -C PRINT *,' W/NMC42)' - END IF - ELSE IF (KPDS(1).EQ.58) THEN - IF (KPDS(3).GE.1.AND.KPDS(3).LE.12) THEN - ELSE -C PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR', -C * ' FNOC WITHOUT A GRID DESCRIPTION SECTION' -C PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION' -C PRINT *,' PRODUCTION MANAGEMENT BRANCH' -C PRINT *,' W/NMC42)' - END IF - END IF - END IF - END IF - END IF - RETURN - END - SUBROUTINE FI633(MSGA,KPTR,KGDS,KRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI633 EXTRACT INFO FROM GRIB-GDS -C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 91-09-13 -C -C ABSTRACT: EXTRACT INFORMATION ON UNLISTED GRID TO ALLOW -C CONVERSION TO OFFICE NOTE 84 FORMAT. -C -C PROGRAM HISTORY LOG: -C 91-09-13 CAVANAUGH -C 95-03-20 M.BALDWIN FI633 MODIFICATION TO GET -C DATA REP TYPES [KGDS(1)] 201 AND 202 TO WORK. -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 98-09-08 BALDWIN ADD DATA REP TYPE [KGDS(1)] 203 -C -C -C USAGE: CALL FI633(MSGA,KPTR,KGDS,KRET) -C INPUT ARGUMENT LIST: -C MSGA - ARRAY CONTAINING GRIB MESSAGE -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C (1) - TOTAL LENGTH OF GRIB MESSAGE -C (2) - LENGTH OF INDICATOR (SECTION 0) -C (3) - LENGTH OF PDS (SECTION 1) -C (4) - LENGTH OF GDS (SECTION 2) -C (5) - LENGTH OF BMS (SECTION 3) -C (6) - LENGTH OF BDS (SECTION 4) -C (7) - VALUE OF CURRENT BYTE -C (8) - BIT POINTER -C (9) - GRIB START BIT NR -C (10) - GRIB/GRID ELEMENT COUNT -C (11) - NR UNUSED BITS AT END OF SECTION 3 -C (12) - BIT MAP FLAG -C (13) - NR UNUSED BITS AT END OF SECTION 2 -C (14) - BDS FLAGS -C (15) - NR UNUSED BITS AT END OF SECTION 4 -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KGDS - ARRAY CONTAINING GDS ELEMENTS. -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESERVED -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIN - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C STAGGERED ARAKAWA ROTATED LAT/LON GRIDS (203) -C (2) - N(I) NR POINTS ON ROTATED LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON ROTATED LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG -C (7) - LA(2) LATITUDE OF CENTER -C (8) - LO(2) LONGITUDE OF CENTER -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C SEE INPUT LIST -C KRET - ERROR RETURN -C -C REMARKS: -C KRET = 0 -C = 4 - DATA REPRESENTATION TYPE NOT CURRENTLY ACCEPTABLE -C -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: HDS9000 -C -C$$$ -C ************************************************************ -C INCOMING MESSAGE HOLDER - CHARACTER*1 MSGA(*) -C -C ARRAY GDS ELEMENTS - INTEGER KGDS(*) -C ARRAY OF POINTERS AND COUNTERS - INTEGER KPTR(*) -C - INTEGER KRET -C --------------------------------------------------------------- - KRET = 0 -C PROCESS GRID DEFINITION SECTION (IF PRESENT) -C MAKE SURE BIT POINTER IS PROPERLY SET - KPTR(8) = KPTR(9) + (KPTR(2)*8) + (KPTR(3)*8) + 24 - NSAVE = KPTR(8) - 24 -C BYTE 4 -C NV - NR OF VERT COORD PARAMETERS - CALL GBYTE (MSGA,KGDS(19),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 5 -C PV - LOCATION - SEE FM92 MANUAL - CALL GBYTE (MSGA,KGDS(20),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 6 -C DATA REPRESENTATION TYPE - CALL GBYTE (MSGA,KGDS(1),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTES 7-32 ARE GRID DEFINITION DEPENDING ON -C DATA REPRESENTATION TYPE - IF (KGDS(1).EQ.0) THEN - GO TO 1000 - ELSE IF (KGDS(1).EQ.1) THEN - GO TO 4000 - ELSE IF (KGDS(1).EQ.2.OR.KGDS(1).EQ.5) THEN - GO TO 2000 - ELSE IF (KGDS(1).EQ.3) THEN - GO TO 5000 - ELSE IF (KGDS(1).EQ.4) THEN - GO TO 1000 -C ELSE IF (KGDS(1).EQ.10) THEN -C ELSE IF (KGDS(1).EQ.14) THEN -C ELSE IF (KGDS(1).EQ.20) THEN -C ELSE IF (KGDS(1).EQ.24) THEN -C ELSE IF (KGDS(1).EQ.30) THEN -C ELSE IF (KGDS(1).EQ.34) THEN - ELSE IF (KGDS(1).EQ.50) THEN - GO TO 3000 -C ELSE IF (KGDS(1).EQ.60) THEN -C ELSE IF (KGDS(1).EQ.70) THEN -C ELSE IF (KGDS(1).EQ.80) THEN - ELSE IF (KGDS(1).EQ.201.OR.KGDS(1).EQ.202.OR.KGDS(1).EQ.203) THEN - GO TO 1000 - ELSE -C MARK AS GDS/ UNKNOWN DATA REPRESENTATION TYPE - KRET = 4 - RETURN - END IF -C BYTE 33-N VERTICAL COORDINATE PARAMETERS -C ----------- -C BYTES 33-42 EXTENSIONS OF GRID DEFINITION FOR ROTATION -C OR STRETCHING OF THE COORDINATE SYSTEM OR -C LAMBERT CONFORMAL PROJECTION. -C BYTE 43-N VERTICAL COORDINATE PARAMETERS -C ----------- -C BYTES 33-52 EXTENSIONS OF GRID DEFINITION FOR STRETCHED -C AND ROTATED COORDINATE SYSTEM -C BYTE 53-N VERTICAL COORDINATE PARAMETERS -C ----------- -C ************************************************************ -C ------------------- LATITUDE/LONGITUDE GRIDS -C ------------------- ARAKAWA STAGGERED, SEMI-STAGGERED, OR FILLED -C ROTATED LAT/LON GRIDS -C -C ------------------- BYTE 7-8 NR OF POINTS ALONG LATITUDE CIRCLE - 1000 CONTINUE - CALL GBYTE (MSGA,KGDS(2),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C ------------------- BYTE 9-10 NR OF POINTS ALONG LONG MERIDIAN - CALL GBYTE (MSGA,KGDS(3),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C ------------------- BYTE 11-13 LATITUDE OF ORIGIN - CALL GBYTE (MSGA,KGDS(4),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(4),8388608).NE.0) THEN - KGDS(4) = IAND(KGDS(4),8388607) * (-1) - END IF -C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN - CALL GBYTE (MSGA,KGDS(5),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(5),8388608).NE.0) THEN - KGDS(5) = - IAND(KGDS(5),8388607) - END IF -C ------------------- BYTE 17 RESOLUTION FLAG - CALL GBYTE (MSGA,KGDS(6),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ------------------- BYTE 18-20 LATITUDE OF LAST GRID POINT - CALL GBYTE (MSGA,KGDS(7),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(7),8388608).NE.0) THEN - KGDS(7) = - IAND(KGDS(7),8388607) - END IF -C ------------------- BYTE 21-23 LONGITUDE OF LAST GRID POINT - CALL GBYTE (MSGA,KGDS(8),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(8),8388608).NE.0) THEN - KGDS(8) = - IAND(KGDS(8),8388607) - END IF -C ------------------- BYTE 24-25 LATITUDINAL DIR INCREMENT - CALL GBYTE (MSGA,KGDS(9),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C ------------------- BYTE 26-27 IF REGULAR LAT/LON GRID -C HAVE LONGIT DIR INCREMENT -C ELSE IF GAUSSIAN GRID -C HAVE NR OF LAT CIRCLES -C BETWEEN POLE AND EQUATOR - CALL GBYTE (MSGA,KGDS(10),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C ------------------- BYTE 28 SCANNING MODE FLAGS - CALL GBYTE (MSGA,KGDS(11),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ------------------- BYTE 29-32 RESERVED -C SKIP TO START OF BYTE 33 - CALL GBYTE (MSGA,KGDS(12),KPTR(8),32) - KPTR(8) = KPTR(8) + 32 -C ------------------- - GO TO 900 -C ****************************************************************** -C ' POLAR STEREO PROCESSING ' -C -C ------------------- BYTE 7-8 NR OF POINTS ALONG X=AXIS - 2000 CONTINUE - CALL GBYTE (MSGA,KGDS(2),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C ------------------- BYTE 9-10 NR OF POINTS ALONG Y-AXIS - CALL GBYTE (MSGA,KGDS(3),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C ------------------- BYTE 11-13 LATITUDE OF ORIGIN - CALL GBYTE (MSGA,KGDS(4),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(4),8388608).NE.0) THEN - KGDS(4) = - IAND(KGDS(4),8388607) - END IF -C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN - CALL GBYTE (MSGA,KGDS(5),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(5),8388608).NE.0) THEN - KGDS(5) = - IAND(KGDS(5),8388607) - END IF -C ------------------- BYTE 17 RESERVED - CALL GBYTE (MSGA,KGDS(6),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ------------------- BYTE 18-20 LOV ORIENTATION OF THE GRID - CALL GBYTE (MSGA,KGDS(7),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(7),8388608).NE.0) THEN - KGDS(7) = - IAND(KGDS(7),8388607) - END IF -C ------------------- BYTE 21-23 DX - THE X DIRECTION INCREMENT - CALL GBYTE (MSGA,KGDS(8),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(8),8388608).NE.0) THEN - KGDS(8) = - IAND(KGDS(8),8388607) - END IF -C ------------------- BYTE 24-26 DY - THE Y DIRECTION INCREMENT - CALL GBYTE (MSGA,KGDS(9),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(9),8388608).NE.0) THEN - KGDS(9) = - IAND(KGDS(9),8388607) - END IF -C ------------------- BYTE 27 PROJECTION CENTER FLAG - CALL GBYTE (MSGA,KGDS(10),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ------------------- BYTE 28 SCANNING MODE - CALL GBYTE (MSGA,KGDS(11),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ------------------- BYTE 29-32 RESERVED -C SKIP TO START OF BYTE 33 - CALL GBYTE (MSGA,KGDS(12),KPTR(8),32) - KPTR(8) = KPTR(8) + 32 -C -C ------------------- - GO TO 900 -C -C ****************************************************************** -C ------------------- GRID DESCRIPTION FOR SPHERICAL HARMONIC COEFF. -C -C ------------------- BYTE 7-8 J PENTAGONAL RESOLUTION PARAMETER - 3000 CONTINUE - CALL GBYTE (MSGA,KGDS(2),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C ------------------- BYTE 9-10 K PENTAGONAL RESOLUTION PARAMETER - CALL GBYTE (MSGA,KGDS(3),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C ------------------- BYTE 11-12 M PENTAGONAL RESOLUTION PARAMETER - CALL GBYTE (MSGA,KGDS(4),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C ------------------- BYTE 13 REPRESENTATION TYPE - CALL GBYTE (MSGA,KGDS(5),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ------------------- BYTE 14 COEFFICIENT STORAGE MODE - CALL GBYTE (MSGA,KGDS(6),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ------------------- EMPTY FIELDS - BYTES 15 - 32 -C SET TO START OF BYTE 33 - KPTR(8) = KPTR(8) + 18 * 8 - GO TO 900 -C ****************************************************************** -C PROCESS MERCATOR GRIDS -C -C ------------------- BYTE 7-8 NR OF POINTS ALONG LATITUDE CIRCLE - 4000 CONTINUE - CALL GBYTE (MSGA,KGDS(2),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C ------------------- BYTE 9-10 NR OF POINTS ALONG LONG MERIDIAN - CALL GBYTE (MSGA,KGDS(3),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C ------------------- BYTE 11-13 LATITUE OF ORIGIN - CALL GBYTE (MSGA,KGDS(4),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(4),8388608).NE.0) THEN - KGDS(4) = - IAND(KGDS(4),8388607) - END IF -C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN - CALL GBYTE (MSGA,KGDS(5),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(5),8388608).NE.0) THEN - KGDS(5) = - IAND(KGDS(5),8388607) - END IF -C ------------------- BYTE 17 RESOLUTION FLAG - CALL GBYTE (MSGA,KGDS(6),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ------------------- BYTE 18-20 LATITUDE OF EXTREME POINT - CALL GBYTE (MSGA,KGDS(7),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(7),8388608).NE.0) THEN - KGDS(7) = - IAND(KGDS(7),8388607) - END IF -C ------------------- BYTE 21-23 LONGITUDE OF EXTREME POINT - CALL GBYTE (MSGA,KGDS(8),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(8),8388608).NE.0) THEN - KGDS(8) = - IAND(KGDS(8),8388607) - END IF -C ------------------- BYTE 24-26 LATITUDE OF PROJECTION INTERSECTION - CALL GBYTE (MSGA,KGDS(9),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(9),8388608).NE.0) THEN - KGDS(9) = - IAND(KGDS(9),8388607) - END IF -C ------------------- BYTE 27 RESERVED - CALL GBYTE (MSGA,KGDS(10),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ------------------- BYTE 28 SCANNING MODE - CALL GBYTE (MSGA,KGDS(11),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ------------------- BYTE 29-31 LONGITUDINAL DIR INCREMENT - CALL GBYTE (MSGA,KGDS(12),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(12),8388608).NE.0) THEN - KGDS(12) = - IAND(KGDS(12),8388607) - END IF -C ------------------- BYTE 32-34 LATITUDINAL DIR INCREMENT - CALL GBYTE (MSGA,KGDS(13),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(13),8388608).NE.0) THEN - KGDS(13) = - IAND(KGDS(13),8388607) - END IF -C ------------------- BYTE 35-42 RESERVED -C SKIP TO START OF BYTE 43 - KPTR(8) = KPTR(8) + 8 * 8 -C ------------------- - GO TO 900 -C ****************************************************************** -C PROCESS LAMBERT CONFORMAL -C -C ------------------- BYTE 7-8 NR OF POINTS ALONG X-AXIS - 5000 CONTINUE - CALL GBYTE (MSGA,KGDS(2),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C ------------------- BYTE 9-10 NR OF POINTS ALONG Y-AXIS - CALL GBYTE (MSGA,KGDS(3),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C ------------------- BYTE 11-13 LATITUDE OF ORIGIN - CALL GBYTE (MSGA,KGDS(4),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(4),8388608).NE.0) THEN - KGDS(4) = - IAND(KGDS(4),8388607) - END IF -C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN (LOWER LEFT) - CALL GBYTE (MSGA,KGDS(5),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(5),8388608).NE.0) THEN - KGDS(5) = - IAND(KGDS(5),8388607) - END IF -C ------------------- BYTE 17 RESOLUTION - CALL GBYTE (MSGA,KGDS(6),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ------------------- BYTE 18-20 LOV -ORIENTATION OF GRID - CALL GBYTE (MSGA,KGDS(7),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(7),8388608).NE.0) THEN - KGDS(7) = - IAND(KGDS(7),8388607) - END IF -C ------------------- BYTE 21-23 DX - X-DIR INCREMENT - CALL GBYTE (MSGA,KGDS(8),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 -C ------------------- BYTE 24-26 DY - Y-DIR INCREMENT - CALL GBYTE (MSGA,KGDS(9),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 -C ------------------- BYTE 27 PROJECTION CENTER FLAG - CALL GBYTE (MSGA,KGDS(10),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ------------------- BYTE 28 SCANNING MODE - CALL GBYTE (MSGA,KGDS(11),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ------------------- BYTE 29-31 LATIN1 - 1ST LAT FROM POLE - CALL GBYTE (MSGA,KGDS(12),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(12),8388608).NE.0) THEN - KGDS(12) = - IAND(KGDS(12),8388607) - END IF -C ------------------- BYTE 32-34 LATIN2 - 2ND LAT FROM POLE - CALL GBYTE (MSGA,KGDS(13),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(13),8388608).NE.0) THEN - KGDS(13) = - IAND(KGDS(13),8388607) - END IF -C ------------------- BYTE 35-37 LATITUDE OF SOUTHERN POLE - CALL GBYTE (MSGA,KGDS(14),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(14),8388608).NE.0) THEN - KGDS(14) = - IAND(KGDS(14),8388607) - END IF -C ------------------- BYTE 38-40 LONGITUDE OF SOUTHERN POLE - CALL GBYTE (MSGA,KGDS(15),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(15),8388608).NE.0) THEN - KGDS(15) = - IAND(KGDS(15),8388607) - END IF -C ------------------- BYTE 41-42 RESERVED - CALL GBYTE (MSGA,KGDS(16),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C ------------------- - 900 CONTINUE -C -C MORE CODE FOR GRIDS WITH PL -C - IF (KGDS(19).EQ.0.OR.KGDS(19).EQ.255) THEN - IF (KGDS(20).NE.255) THEN - ISUM = 0 - KPTR(8) = NSAVE + (KGDS(20) - 1) * 8 - CALL GBYTES (MSGA,KGDS(22),KPTR(8),16,0,KGDS(3)) - DO 910 J = 1, KGDS(3) - ISUM = ISUM + KGDS(21+J) - 910 CONTINUE - KGDS(21) = ISUM - END IF - END IF - RETURN - END - SUBROUTINE FI634(MSGA,KPTR,KPDS,KGDS,KBMS,KRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI634 EXTRACT OR GENERATE BIT MAP FOR OUTPUT -C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 91-09-13 -C -C ABSTRACT: IF BIT MAP SEC IS AVAILABLE IN GRIB MESSAGE, EXTRACT -C FOR PROGRAM USE, OTHERWISE GENERATE AN APPROPRIATE BIT MAP. -C -C PROGRAM HISTORY LOG: -C 91-09-13 CAVANAUGH -C 91-11-12 CAVANAUGH MODIFIED SIZE OF ECMWF GRIDS 5 - 8. -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 97-02-12 W BOSTELMAN CORRECTS ECMWF US GRID 2 PROCESSING -C 97-09-19 IREDELL VECTORIZED BITMAP DECODER -C 98-09-02 GILBERT CORRECTED ERROR IN MAP SIZE FOR U.S. GRID 92 -C 98-09-08 BALDWIN ADD GRIDS 190,192 -C 99-01-20 BALDWIN ADD GRIDS 236,237 -C 01-10-02 ROGERS REDEFINED GRID #218 FOR 12 KM ETA -C REDEFINED GRID 192 FOR NEW 32-KM ETA GRID -C 2003-06-30 GILBERT ADDED GRIDS 145 and 146 for CMAQ -C and GRID 175 for AWIPS over GUAM. -C 2004-09-02 VUONG ADDED AWIPS GRIDS 147, 148, 173 AND 254 -C 2006-12-12 VUONG ADDED AWIPS GRIDS 120 -C -C USAGE: CALL FI634(MSGA,KPTR,KPDS,KGDS,KBMS,KRET) -C INPUT ARGUMENT LIST: -C MSGA - BUFR MESSAGE -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C (1) - TOTAL LENGTH OF GRIB MESSAGE -C (2) - LENGTH OF INDICATOR (SECTION 0) -C (3) - LENGTH OF PDS (SECTION 1) -C (4) - LENGTH OF GDS (SECTION 2) -C (5) - LENGTH OF BMS (SECTION 3) -C (6) - LENGTH OF BDS (SECTION 4) -C (7) - VALUE OF CURRENT BYTE -C (8) - BIT POINTER -C (9) - GRIB START BIT NR -C (10) - GRIB/GRID ELEMENT COUNT -C (11) - NR UNUSED BITS AT END OF SECTION 3 -C (12) - BIT MAP FLAG -C (13) - NR UNUSED BITS AT END OF SECTION 2 -C (14) - BDS FLAGS -C (15) - NR UNUSED BITS AT END OF SECTION 4 -C KPDS - ARRAY CONTAINING PDS ELEMENTS. -C (1) - ID OF CENTER -C (2) - MODEL IDENTIFICATION -C (3) - GRID IDENTIFICATION -C (4) - GDS/BMS FLAG -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR OF CENTURY -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C -C OUTPUT ARGUMENT LIST: -C KBMS - BITMAP DESCRIBING LOCATION OF OUTPUT ELEMENTS. -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C SEE INPUT LIST -C KRET - ERROR RETURN -C -C REMARKS: -C KRET = 0 - NO ERROR -C = 5 - GRID NOT AVAIL FOR CENTER INDICATED -C =10 - INCORRECT CENTER INDICATOR -C =12 - BYTES 5-6 ARE NOT ZERO IN BMS, PREDEFINED BIT MAP -C NOT PROVIDED BY THIS CENTER -C -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: HDS9000 -C -C$$$ -C -C INCOMING MESSAGE HOLDER - CHARACTER*1 MSGA(*) -C -C BIT MAP - LOGICAL*1 KBMS(*) -C -C ARRAY OF POINTERS AND COUNTERS - INTEGER KPTR(*) -C ARRAY OF POINTERS AND COUNTERS - INTEGER KPDS(*) - INTEGER KGDS(*) -C - INTEGER KRET - INTEGER MASK(8) -C ----------------------GRID 21 AND GRID 22 ARE THE SAME - LOGICAL*1 GRD21( 1369) -C ----------------------GRID 23 AND GRID 24 ARE THE SAME - LOGICAL*1 GRD23( 1369) - LOGICAL*1 GRD25( 1368) - LOGICAL*1 GRD26( 1368) -C ----------------------GRID 27 AND GRID 28 ARE THE SAME -C ----------------------GRID 29 AND GRID 30 ARE THE SAME -C ----------------------GRID 33 AND GRID 34 ARE THE SAME - LOGICAL*1 GRD50( 1188) -C -----------------------GRID 61 AND GRID 62 ARE THE SAME - LOGICAL*1 GRD61( 4186) -C -----------------------GRID 63 AND GRID 64 ARE THE SAME - LOGICAL*1 GRD63( 4186) -C LOGICAL*1 GRD70(16380)/16380*.TRUE./ -C ------------------------------------------------------------- - DATA GRD21 /1333*.TRUE.,36*.FALSE./ - DATA GRD23 /.TRUE.,36*.FALSE.,1332*.TRUE./ - DATA GRD25 /1297*.TRUE.,71*.FALSE./ - DATA GRD26 /.TRUE.,71*.FALSE.,1296*.TRUE./ - DATA GRD50/ -C LINE 1-4 - & 7*.FALSE.,22*.TRUE.,14*.FALSE.,22*.TRUE., - & 14*.FALSE.,22*.TRUE.,14*.FALSE.,22*.TRUE.,7*.FALSE., -C LINE 5-8 - & 6*.FALSE.,24*.TRUE.,12*.FALSE.,24*.TRUE., - & 12*.FALSE.,24*.TRUE.,12*.FALSE.,24*.TRUE.,6*.FALSE., -C LINE 9-12 - & 5*.FALSE.,26*.TRUE.,10*.FALSE.,26*.TRUE., - & 10*.FALSE.,26*.TRUE.,10*.FALSE.,26*.TRUE.,5*.FALSE., -C LINE 13-16 - & 4*.FALSE.,28*.TRUE., 8*.FALSE.,28*.TRUE., - & 8*.FALSE.,28*.TRUE., 8*.FALSE.,28*.TRUE.,4*.FALSE., -C LINE 17-20 - & 3*.FALSE.,30*.TRUE., 6*.FALSE.,30*.TRUE., - & 6*.FALSE.,30*.TRUE., 6*.FALSE.,30*.TRUE.,3*.FALSE., -C LINE 21-24 - & 2*.FALSE.,32*.TRUE., 4*.FALSE.,32*.TRUE., - & 4*.FALSE.,32*.TRUE., 4*.FALSE.,32*.TRUE.,2*.FALSE., -C LINE 25-28 - & .FALSE.,34*.TRUE., 2*.FALSE.,34*.TRUE., - & 2*.FALSE.,34*.TRUE., 2*.FALSE.,34*.TRUE., .FALSE., -C LINE 29-33 - & 180*.TRUE./ - DATA GRD61 /4096*.TRUE.,90*.FALSE./ - DATA GRD63 /.TRUE.,90*.FALSE.,4095*.TRUE./ - DATA MASK /128,64,32,16,8,4,2,1/ -C -C PRINT *,'FI634' - IF (IAND(KPDS(4),64).EQ.64) THEN -C -C SET UP BIT POINTER -C SECTION 0 SECTION 1 SECTION 2 - KPTR(8) = KPTR(9) + (KPTR(2)*8) + (KPTR(3)*8) + (KPTR(4)*8) + 24 -C -C BYTE 4 NUMBER OF UNUSED BITS AT END OF SECTION 3 -C - CALL GBYTE (MSGA,KPTR(11),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C -C BYTE 5,6 TABLE REFERENCE IF 0, BIT MAP FOLLOWS -C - CALL GBYTE (MSGA,KPTR(12),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C IF TABLE REFERENCE = 0, EXTRACT BIT MAP - IF (KPTR(12).EQ.0) THEN -C CALCULATE NR OF BITS IN BIT MAP - IBITS = (KPTR(5) - 6) * 8 - KPTR(11) - KPTR(10) = IBITS - IF (KPDS(3).EQ.21.OR.KPDS(3).EQ.22.OR.KPDS(3).EQ.25. - * OR.KPDS(3).EQ.61.OR.KPDS(3).EQ.62) THEN -C NORTHERN HEMISPHERE 21, 22, 25, 61, 62 - CALL FI634X(IBITS,KPTR(8),MSGA,KBMS) - IF (KPDS(3).EQ.25) THEN - KADD = 71 - ELSE IF (KPDS(3).EQ.61.OR.KPDS(3).EQ.62) THEN - KADD = 90 - ELSE - KADD = 36 - END IF - DO 25 I = 1, KADD - KBMS(I+IBITS) = .FALSE. - 25 CONTINUE - KPTR(10) = KPTR(10) + KADD - RETURN - ELSE IF (KPDS(3).EQ.23.OR.KPDS(3).EQ.24.OR.KPDS(3).EQ.26. - * OR.KPDS(3).EQ.63.OR.KPDS(3).EQ.64) THEN -C SOUTHERN HEMISPHERE 23, 24, 26, 63, 64 - CALL FI634X(IBITS,KPTR(8),MSGA,KBMS) - IF (KPDS(3).EQ.26) THEN - KADD = 72 - ELSE IF (KPDS(3).EQ.63.OR.KPDS(3).EQ.64) THEN - KADD = 91 - ELSE - KADD = 37 - END IF - DO 26 I = 1, KADD - KBMS(I+IBITS) = .FALSE. - 26 CONTINUE - KPTR(10) = KPTR(10) + KADD - 1 - RETURN - ELSE IF (KPDS(3).EQ.50) THEN - KPAD = 7 - KIN = 22 - KBITS = 0 - DO 55 I = 1, 7 - DO 54 J = 1, 4 - DO 51 K = 1, KPAD - KBITS = KBITS + 1 - KBMS(KBITS) = .FALSE. - 51 CONTINUE - CALL FI634X(KIN,KPTR(8),MSGA,KBMS(KBITS+1)) - KPTR(8)=KPTR(8)+KIN - KBITS=KBITS+KIN - DO 53 K = 1, KPAD - KBITS = KBITS + 1 - KBMS(KBITS) = .FALSE. - 53 CONTINUE - 54 CONTINUE - KIN = KIN + 2 - KPAD = KPAD - 1 - 55 CONTINUE - DO 57 II = 1, 5 - CALL FI634X(KIN,KPTR(8),MSGA,KBMS(KBITS+1)) - KPTR(8)=KPTR(8)+KIN - KBITS=KBITS+KIN - 57 CONTINUE - ELSE -C EXTRACT BIT MAP FROM BMS FOR OTHER GRIDS - CALL FI634X(IBITS,KPTR(8),MSGA,KBMS) - END IF - RETURN - ELSE -C PRINT *,'FI634-NO PREDEFINED BIT MAP PROVIDED BY THIS CENTER' - KRET = 12 - RETURN - END IF -C - END IF - KRET = 0 -C ------------------------------------------------------- -C PROCESS NON-STANDARD GRID -C ------------------------------------------------------- - IF (KPDS(3).EQ.255) THEN -C PRINT *,'NON STANDARD GRID, CENTER = ',KPDS(1) - J = KGDS(2) * KGDS(3) - KPTR(10) = J - DO 600 I = 1, J - KBMS(I) = .TRUE. - 600 CONTINUE - RETURN - END IF -C ------------------------------------------------------- -C CHECK INTERNATIONAL SET -C ------------------------------------------------------- - IF (KPDS(3).EQ.21.OR.KPDS(3).EQ.22) THEN -C ----- INT'L GRIDS 21, 22 - MAP SIZE 1369 - J = 1369 - KPTR(10) = J - CALL FI637(J,KPDS,KGDS,KRET) - IF(KRET.NE.0) GO TO 820 - DO 3021 I = 1, 1369 - KBMS(I) = GRD21(I) - 3021 CONTINUE - RETURN - ELSE IF (KPDS(3).EQ.23.OR.KPDS(3).EQ.24) THEN -C ----- INT'L GRIDS 23, 24 - MAP SIZE 1369 - J = 1369 - KPTR(10) = J - CALL FI637(J,KPDS,KGDS,KRET) - IF(KRET.NE.0) GO TO 820 - DO 3023 I = 1, 1369 - KBMS(I) = GRD23(I) - 3023 CONTINUE - RETURN - ELSE IF (KPDS(3).EQ.25) THEN -C ----- INT'L GRID 25 - MAP SIZE 1368 - J = 1368 - KPTR(10) = J - CALL FI637(J,KPDS,KGDS,KRET) - IF(KRET.NE.0) GO TO 820 - DO 3025 I = 1, 1368 - KBMS(I) = GRD25(I) - 3025 CONTINUE - RETURN - ELSE IF (KPDS(3).EQ.26) THEN -C ----- INT'L GRID 26 - MAP SIZE 1368 - J = 1368 - KPTR(10) = J - CALL FI637(J,KPDS,KGDS,KRET) - IF(KRET.NE.0) GO TO 820 - DO 3026 I = 1, 1368 - KBMS(I) = GRD26(I) - 3026 CONTINUE - RETURN - ELSE IF (KPDS(3).GE.37.AND.KPDS(3).LE.44) THEN -C ----- INT'L GRID 37-44 - MAP SIZE 3447 - J = 3447 - GO TO 800 - ELSE IF (KPDS(1).EQ.7.AND.KPDS(3).EQ.50) THEN -C ----- INT'L GRIDS 50 - MAP SIZE 964 - J = 1188 - KPTR(10) = J - CALL FI637(J,KPDS,KGDS,KRET) - IF(KRET.NE.0) GO TO 890 - DO 3050 I = 1, J - KBMS(I) = GRD50(I) - 3050 CONTINUE - RETURN - ELSE IF (KPDS(3).EQ.61.OR.KPDS(3).EQ.62) THEN -C ----- INT'L GRIDS 61, 62 - MAP SIZE 4186 - J = 4186 - KPTR(10) = J - CALL FI637(J,KPDS,KGDS,KRET) - IF(KRET.NE.0) GO TO 820 - DO 3061 I = 1, 4186 - KBMS(I) = GRD61(I) - 3061 CONTINUE - RETURN - ELSE IF (KPDS(3).EQ.63.OR.KPDS(3).EQ.64) THEN -C ----- INT'L GRIDS 63, 64 - MAP SIZE 4186 - J = 4186 - KPTR(10) = J - CALL FI637(J,KPDS,KGDS,KRET) - IF(KRET.NE.0) GO TO 820 - DO 3063 I = 1, 4186 - KBMS(I) = GRD63(I) - 3063 CONTINUE - RETURN - END IF -C ------------------------------------------------------- -C CHECK UNITED STATES SET -C ------------------------------------------------------- - IF (KPDS(1).EQ.7) THEN - IF (KPDS(3).LT.100) THEN - IF (KPDS(3).EQ.1) THEN -C ----- U.S. GRID 1 - MAP SIZE 1679 - J = 1679 - GO TO 800 - END IF - IF (KPDS(3).EQ.2) THEN -C ----- U.S. GRID 2 - MAP SIZE 10512 - J = 10512 - GO TO 800 - ELSE IF (KPDS(3).EQ.3) THEN -C ----- U.S. GRID 3 - MAP SIZE 65160 - J = 65160 - GO TO 800 - ELSE IF (KPDS(3).EQ.4) THEN -C ----- U.S. GRID 4 - MAP SIZE 259920 - J = 259920 - GO TO 800 - ELSE IF (KPDS(3).EQ.5) THEN -C ----- U.S. GRID 5 - MAP SIZE 3021 - J = 3021 - GO TO 800 - ELSE IF (KPDS(3).EQ.6) THEN -C ----- U.S. GRID 6 - MAP SIZE 2385 - J = 2385 - GO TO 800 - ELSE IF (KPDS(3).EQ.8) THEN -C ----- U.S. GRID 8 - MAP SIZE 5104 - J = 5104 - GO TO 800 - ELSE IF (KPDS(3).EQ.27.OR.KPDS(3).EQ.28) THEN -C ----- U.S. GRIDS 27, 28 - MAP SIZE 4225 - J = 4225 - GO TO 800 - ELSE IF (KPDS(3).EQ.29.OR.KPDS(3).EQ.30) THEN -C ----- U.S. GRIDS 29,30 - MAP SIZE 5365 - J = 5365 - GO TO 800 - ELSE IF (KPDS(3).EQ.33.OR.KPDS(3).EQ.34) THEN -C ----- U.S GRID 33, 34 - MAP SIZE 8326 - J = 8326 - GO TO 800 - ELSE IF (KPDS(3).GE.37.AND.KPDS(3).LE.44) THEN -C ----- U.S. GRID 37-44 - MAP SIZE 3447 - J = 3447 - GO TO 800 - ELSE IF (KPDS(3).EQ.45) THEN -C ----- U.S. GRID 45 - MAP SIZE 41760 - J = 41760 - GO TO 800 - ELSE IF (KPDS(3).EQ.53) THEN -C ----- U.S. GRID 53 - MAP SIZE 5967 - J = 5967 - GO TO 800 - ELSE IF (KPDS(3).EQ.55.OR.KPDS(3).EQ.56) THEN -C ----- U.S GRID 55, 56 - MAP SIZE 6177 - J = 6177 - GO TO 800 - ELSE IF (KPDS(3).GE.67.AND.KPDS(3).LE.71) THEN -C ----- U.S GRID 67-71 - MAP SIZE 13689 - J = 13689 - GO TO 800 - ELSE IF (KPDS(3).EQ.72) THEN -C ----- U.S GRID 72 - MAP SIZE 406 - J = 406 - GO TO 800 - ELSE IF (KPDS(3).EQ.73) THEN -C ----- U.S GRID 73 - MAP SIZE 13056 - J = 13056 - GO TO 800 - ELSE IF (KPDS(3).EQ.74) THEN -C ----- U.S GRID 74 - MAP SIZE 10800 - J = 10800 - GO TO 800 - ELSE IF (KPDS(3).GE.75.AND.KPDS(3).LE.77) THEN -C ----- U.S GRID 75-77 - MAP SIZE 12321 - J = 12321 - GO TO 800 - ELSE IF (KPDS(3).EQ.85.OR.KPDS(3).EQ.86) THEN -C ----- U.S GRID 85,86 - MAP SIZE 32400 - J = 32400 - GO TO 800 - ELSE IF (KPDS(3).EQ.87) THEN -C ----- U.S GRID 87 - MAP SIZE 5022 - J = 5022 - GO TO 800 - ELSE IF (KPDS(3).EQ.88) THEN -C ----- U.S GRID 88 - MAP SIZE 317840 - J = 317840 - GO TO 800 - ELSE IF (KPDS(3).EQ.90) THEN -C ----- U.S GRID 90 - MAP SIZE 111723 - J = 111723 - GO TO 800 - ELSE IF (KPDS(3).EQ.91) THEN -C ----- U.S GRID 91 - MAP SIZE 111723 - J = 111723 - GO TO 800 - ELSE IF (KPDS(3).EQ.92) THEN -C ----- U.S GRID 92 - MAP SIZE 111723 - J = 111723 - GO TO 800 - ELSE IF (KPDS(3).EQ.93) THEN -C ----- U.S GRID 93 - MAP SIZE 111723 - J = 111723 - GO TO 800 - ELSE IF (KPDS(3).EQ.94) THEN -C ----- U.S GRID 94 - MAP SIZE 196305 - J = 196305 - GO TO 800 - ELSE IF (KPDS(3).EQ.95) THEN -C ----- U.S GRID 95 - MAP SIZE 36062 - J = 36062 - GO TO 800 - ELSE IF (KPDS(3).EQ.96) THEN -C ----- U.S GRID 96 - MAP SIZE 646602 - J = 646602 - GO TO 800 - ELSE IF (KPDS(3).EQ.97) THEN -C ----- U.S GRID 97 - MAP SIZE 12727 - J = 12727 - GO TO 800 - ELSE IF (KPDS(3).EQ.98) THEN -C ----- U.S GRID 98 - MAP SIZE 18048 - J = 18048 - GO TO 800 - END IF - ELSE IF (KPDS(3).GE.100.AND.KPDS(3).LT.200) THEN - IF (KPDS(3).EQ.100) THEN -C ----- U.S. GRID 100 - MAP SIZE 6889 - J = 6889 - GO TO 800 - ELSE IF (KPDS(3).EQ.101) THEN -C ----- U.S. GRID 101 - MAP SIZE 10283 - J = 10283 - GO TO 800 - ELSE IF (KPDS(3).EQ.103) THEN -C ----- U.S. GRID 103 - MAP SIZE 3640 - J = 3640 - GO TO 800 - ELSE IF (KPDS(3).EQ.104) THEN -C ----- U.S. GRID 104 - MAP SIZE 16170 - J = 16170 - GO TO 800 - ELSE IF (KPDS(3).EQ.105) THEN -C ----- U.S. GRID 105 - MAP SIZE 6889 - J = 6889 - GO TO 800 - ELSE IF (KPDS(3).EQ.106) THEN -C ----- U.S. GRID 106 - MAP SIZE 19305 - J = 19305 - GO TO 800 - ELSE IF (KPDS(3).EQ.107) THEN -C ----- U.S. GRID 107 - MAP SIZE 11040 - J = 11040 - GO TO 800 - ELSE IF (KPDS(3).EQ.110) THEN -C ----- U.S. GRID 110 - MAP SIZE 103936 - J = 103936 - GO TO 800 - ELSE IF (KPDS(3).EQ.120) THEN -C ----- U.S. GRID 120 - MAP SIZE 2020800 - J = 2020800 - GO TO 800 - ELSE IF (KPDS(3).EQ.126) THEN -C ----- U.S. GRID 126 - MAP SIZE 72960 - J = 72960 - GO TO 800 - ELSE IF (KPDS(3).EQ.127) THEN -C ----- U.S. GRID 127 - MAP SIZE 294912 - J = 294912 - GO TO 800 - ELSE IF (KPDS(3).EQ.130) THEN -C ----- U.S. GRID 130 - MAP SIZE 151987 - J = 151987 - GO TO 800 - ELSE IF (KPDS(3).EQ.145) THEN -C ----- U.S. GRID 145 - MAP SIZE 24505 - J = 24505 - GO TO 800 - ELSE IF (KPDS(3).EQ.146) THEN -C ----- U.S. GRID 146 - MAP SIZE 23572 - J = 23572 - GO TO 800 - ELSE IF (KPDS(3).EQ.147) THEN -C ----- U.S. GRID 147 - MAP SIZE 69412 - J = 69412 - GO TO 800 - ELSE IF (KPDS(3).EQ.148) THEN -C ----- U.S. GRID 148 - MAP SIZE 117130 - J = 117130 - GO TO 800 - ELSE IF (KPDS(3).EQ.160) THEN -C ----- U.S. GRID 160 - MAP SIZE 28080 - J = 28080 - GO TO 800 - ELSE IF (KPDS(3).EQ.161) THEN -C ----- U.S. GRID 161 - MAP SIZE 13974 - J = 13974 - GO TO 800 - ELSE IF (KPDS(3).EQ.163) THEN -C ----- U.S. GRID 163 - MAP SIZE 727776 - J = 727776 - GO TO 800 - - ELSE IF (KPDS(3).EQ.170) THEN -C ----- U.S. GRID 170 - MAP SIZE 131072 - J = 131072 - GO TO 800 - ELSE IF (KPDS(3).EQ.171) THEN -C ----- U.S. GRID 171 - MAP SIZE 716100 - J = 716100 - GO TO 800 - ELSE IF (KPDS(3).EQ.172) THEN -C ----- U.S. GRID 172 - MAP SIZE 489900 - J = 489900 - GO TO 800 - ELSE IF (KPDS(3).EQ.173) THEN -C ----- U.S. GRID 173 - MAP SIZE 9331200 - J = 9331200 - GO TO 800 - ELSE IF (KPDS(3).EQ.174) THEN -C ----- U.S. GRID 174 - MAP SIZE 4147200 - J = 4147200 - GO TO 800 - ELSE IF (KPDS(3).EQ.175) THEN -C ----- U.S. GRID 175 - MAP SIZE 185704 - J = 185704 - GO TO 800 - ELSE IF (KPDS(3).EQ.190) THEN -C ----- U.S GRID 190 - MAP SIZE 12972 - J = 12972 - GO TO 800 - ELSE IF (KPDS(3).EQ.192) THEN -C ----- U.S GRID 192 - MAP SIZE 91719 - J = 91719 - GO TO 800 - ELSE IF (KPDS(3).EQ.194) THEN -C ----- U.S GRID 194 - MAP SIZE 12727 - J = 12727 - GO TO 800 - ELSE IF (KPDS(3).EQ.196) THEN -C ----- U.S. GRID 196 - MAP SIZE 45903 - J = 45903 - GO TO 800 - ELSE IF (KPDS(3).EQ.198) THEN -C ----- U.S. GRID 198 - MAP SIZE 41760 - J = 41760 - GO TO 800 - ELSE IF (IAND(KPDS(4),128).EQ.128) THEN -C ----- U.S. NON-STANDARD GRID - GO TO 895 - END IF - ELSE IF (KPDS(3).GE.200) THEN - IF (KPDS(3).EQ.201) THEN - J = 4225 - GO TO 800 - ELSE IF (KPDS(3).EQ.202) THEN - J = 2795 - GO TO 800 - ELSE IF (KPDS(3).EQ.203.OR.KPDS(3).EQ.205) THEN - J = 1755 - GO TO 800 - ELSE IF (KPDS(3).EQ.204) THEN - J = 6324 - GO TO 800 - ELSE IF (KPDS(3).EQ.206) THEN - J = 2091 - GO TO 800 - ELSE IF (KPDS(3).EQ.207) THEN - J = 1715 - GO TO 800 - ELSE IF (KPDS(3).EQ.208) THEN - J = 783 - GO TO 800 - ELSE IF (KPDS(3).EQ.209) THEN - J = 61325 - GO TO 800 - ELSE IF (KPDS(3).EQ.210) THEN - J = 625 - GO TO 800 - ELSE IF (KPDS(3).EQ.211) THEN - J = 6045 - GO TO 800 - ELSE IF (KPDS(3).EQ.212) THEN - J = 23865 - GO TO 800 - ELSE IF (KPDS(3).EQ.213) THEN - J = 10965 - GO TO 800 - ELSE IF (KPDS(3).EQ.214) THEN - J = 6693 - GO TO 800 - ELSE IF (KPDS(3).EQ.215) THEN - J = 94833 - GO TO 800 - ELSE IF (KPDS(3).EQ.216) THEN - J = 14873 - GO TO 800 - ELSE IF (KPDS(3).EQ.217) THEN - J = 59001 - GO TO 800 - ELSE IF (KPDS(3).EQ.218) THEN - J = 262792 - GO TO 800 - ELSE IF (KPDS(3).EQ.219) THEN - J = 179025 - GO TO 800 - ELSE IF (KPDS(3).EQ.220) THEN - J = 122475 - GO TO 800 - ELSE IF (KPDS(3).EQ.221) THEN - J = 96673 - GO TO 800 - ELSE IF (KPDS(3).EQ.222) THEN - J = 15456 - GO TO 800 - ELSE IF (KPDS(3).EQ.223) THEN - J = 16641 - GO TO 800 - ELSE IF (KPDS(3).EQ.224) THEN - J = 4225 - GO TO 800 - ELSE IF (KPDS(3).EQ.225) THEN - J = 24975 - GO TO 800 - ELSE IF (KPDS(3).EQ.226) THEN - J = 381029 - GO TO 800 - ELSE IF (KPDS(3).EQ.227) THEN - J = 1509825 - GO TO 800 - ELSE IF (KPDS(3).EQ.228) THEN - J = 10512 - GO TO 800 - ELSE IF (KPDS(3).EQ.229) THEN - J = 65160 - GO TO 800 - ELSE IF (KPDS(3).EQ.230) THEN - J = 259920 - GO TO 800 - ELSE IF (KPDS(3).EQ.231) THEN - J = 130320 - GO TO 800 - ELSE IF (KPDS(3).EQ.232) THEN - J = 32760 - GO TO 800 - ELSE IF (KPDS(3).EQ.233) THEN - J = 45216 - GO TO 800 - ELSE IF (KPDS(3).EQ.234) THEN - J = 16093 - GO TO 800 - ELSE IF (KPDS(3).EQ.235) THEN - J = 259200 - GO TO 800 - ELSE IF (KPDS(3).EQ.236) THEN - J = 17063 - GO TO 800 - ELSE IF (KPDS(3).EQ.237) THEN - J = 2538 - GO TO 800 - ELSE IF (KPDS(3).EQ.238) THEN - J = 55825 - GO TO 800 - ELSE IF (KPDS(3).EQ.239) THEN - J = 19065 - GO TO 800 - ELSE IF (KPDS(3).EQ.240) THEN - J = 987601 - GO TO 800 - ELSE IF (KPDS(3).EQ.241) THEN - J = 244305 - GO TO 800 - ELSE IF (KPDS(3).EQ.242) THEN - J = 235025 - GO TO 800 - ELSE IF (KPDS(3).EQ.243) THEN - J = 12726 - GO TO 800 - ELSE IF (KPDS(3).EQ.244) THEN - J = 55825 - GO TO 800 - ELSE IF (KPDS(3).EQ.245) THEN - J = 124992 - GO TO 800 - ELSE IF (KPDS(3).EQ.246) THEN - J = 123172 - GO TO 800 - ELSE IF (KPDS(3).EQ.247) THEN - J = 124992 - GO TO 800 - ELSE IF (KPDS(3).EQ.248) THEN - J = 13635 - GO TO 800 - ELSE IF (KPDS(3).EQ.249) THEN - J = 125881 - GO TO 800 - ELSE IF (KPDS(3).EQ.250) THEN - J = 13635 - GO TO 800 - ELSE IF (KPDS(3).EQ.251) THEN - J = 69720 - GO TO 800 - ELSE IF (KPDS(3).EQ.252) THEN - J = 67725 - GO TO 800 - ELSE IF (KPDS(3).EQ.253) THEN - J = 83552 - GO TO 800 - ELSE IF (KPDS(3).EQ.254) THEN - J = 110700 - GO TO 800 - ELSE IF (IAND(KPDS(4),128).EQ.128) THEN - GO TO 895 - END IF - KRET = 5 - RETURN - END IF - END IF -C ------------------------------------------------------- -C CHECK JAPAN METEOROLOGICAL AGENCY SET -C ------------------------------------------------------- - IF (KPDS(1).EQ.34) THEN - IF (IAND(KPDS(4),128).EQ.128) THEN -C PRINT *,'JMA MAP IS NOT PREDEFINED, THE GDS WILL' -C PRINT *,'BE USED TO UNPACK THE DATA, MAP = ',KPDS(3) - GO TO 900 - END IF - END IF -C ------------------------------------------------------- -C CHECK CANADIAN SET -C ------------------------------------------------------- - IF (KPDS(1).EQ.54) THEN - IF (IAND(KPDS(4),128).EQ.128) THEN -C PRINT *,'CANADIAN MAP IS NOT PREDEFINED, THE GDS WILL' -C PRINT *,'BE USED TO UNPACK THE DATA, MAP = ',KPDS(3) - GO TO 900 - END IF - END IF -C ------------------------------------------------------- -C CHECK FNOC SET -C ------------------------------------------------------- - IF (KPDS(1).EQ.58) THEN - IF (KPDS(3).EQ.220.OR.KPDS(3).EQ.221) THEN -C FNOC GRID 220, 221 - MAPSIZE 3969 (63 * 63) - J = 3969 - KPTR(10) = J - DO I = 1, J - KBMS(I) = .TRUE. - END DO - RETURN - END IF - IF (KPDS(3).EQ.223) THEN -C FNOC GRID 223 - MAPSIZE 10512 (73 * 144) - J = 10512 - KPTR(10) = J - DO I = 1, J - KBMS(I) = .TRUE. - END DO - RETURN - END IF - IF (IAND(KPDS(4),128).EQ.128) THEN -C PRINT *,'FNOC MAP IS NOT PREDEFINED, THE GDS WILL' -C PRINT *,'BE USED TO UNPACK THE DATA, MAP = ',KPDS(3) - GO TO 900 - END IF - END IF -C ------------------------------------------------------- -C CHECK UKMET SET -C ------------------------------------------------------- - IF (KPDS(1).EQ.74) THEN - IF (IAND(KPDS(4),128).EQ.128) THEN - GO TO 820 - END IF - END IF -C ------------------------------------------------------- -C CHECK ECMWF SET -C ------------------------------------------------------- - IF (KPDS(1).EQ.98) THEN - IF (KPDS(3).GE.1.AND.KPDS(3).LE.12) THEN - IF (KPDS(3).GE.5.AND.KPDS(3).LE.8) THEN - J = 1073 - ELSE - J = 1369 - END IF - KPTR(10) = J - CALL FI637(J,KPDS,KGDS,KRET) - IF(KRET.NE.0) GO TO 810 - KPTR(10) = J ! Reset For Modified J - DO 1000 I = 1, J - KBMS(I) = .TRUE. - 1000 CONTINUE - RETURN - ELSE IF (KPDS(3).GE.13.AND.KPDS(3).LE.16) THEN - J = 361 - KPTR(10) = J - CALL FI637(J,KPDS,KGDS,KRET) - IF(KRET.NE.0) GO TO 810 - DO 1013 I = 1, J - KBMS(I) = .TRUE. - 1013 CONTINUE - RETURN - ELSE IF (IAND(KPDS(4),128).EQ.128) THEN - GO TO 810 - ELSE - KRET = 5 - RETURN - END IF - ELSE -C PRINT *,'CENTER ',KPDS(1),' IS NOT DEFINED' - IF (IAND(KPDS(4),128).EQ.128) THEN -C PRINT *,'GDS WILL BE USED TO UNPACK THE DATA', -C * ' MAP = ',KPDS(3) - GO TO 900 - ELSE - KRET = 10 - RETURN - END IF - END IF -C ======================================= -C - 800 CONTINUE - KPTR(10) = J - CALL FI637 (J,KPDS,KGDS,KRET) - IF(KRET.NE.0) GO TO 801 - DO 2201 I = 1, J - KBMS(I) = .TRUE. - 2201 CONTINUE - RETURN - 801 CONTINUE -C -C ----- THE MAP HAS A GDS, BYTE 7 OF THE (PDS) THE GRID IDENTIFICATION -C ----- IS NOT 255, THE SIZE OF THE GRID IS NOT THE SAME AS THE -C ----- PREDEFINED SIZES OF THE U.S. GRIDS, OR KNOWN GRIDS OF THE -C ----- OF THE OTHER CENTERS. THE GRID CAN BE UNKNOWN, OR FROM AN -C ----- UNKNOWN CENTER, WE WILL USE THE INFORMATION IN THE GDS TO MAKE -C ----- A BIT MAP. -C - 810 CONTINUE -C PRINT *,'ECMWF PREDEFINED MAP SIZE DOES NOT MATCH, I WILL USE' - GO TO 895 -C - 820 CONTINUE -C PRINT *,'U.K. MET PREDEFINED MAP SIZE DOES NOT MATCH, I WILL USE' - GO TO 895 -C - 890 CONTINUE -C PRINT *,'PREDEFINED MAP SIZE DOES NOT MATCH, I WILL USE' - 895 CONTINUE -C PRINT *,'THE GDS TO UNPACK THE DATA, MAP TYPE = ',KPDS(3) -C - 900 CONTINUE - J = KGDS(2) * KGDS(3) -C AFOS AFOS AFOS SPECIAL CASE -C INVOLVES NEXT SINGLE STATEMENT ONLY - IF (KPDS(3).EQ.211) KRET = 0 - KPTR(10) = J - DO 2203 I = 1, J - KBMS(I) = .TRUE. - 2203 CONTINUE -C PRINT *,'EXIT FI634' - RETURN - END -C----------------------------------------------------------------------- - SUBROUTINE FI634X(NPTS,NSKP,MSGA,KBMS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI634X EXTRACT BIT MAP -C PRGMMR: IREDELL ORG: W/NP23 DATE: 91-09-19 -C -C ABSTRACT: EXTRACT THE PACKED BITMAP INTO A LOGICAL ARRAY. -C -C PROGRAM HISTORY LOG: -C 97-09-19 IREDELL VECTORIZED BITMAP DECODER -C -C USAGE: CALL FI634X(NPTS,NSKP,MSGA,KBMS) -C INPUT ARGUMENT LIST: -C NPTS - INTEGER NUMBER OF POINTS IN THE BITMAP FIELD -C NSKP - INTEGER NUMBER OF BITS TO SKIP IN GRIB MESSAGE -C MSGA - CHARACTER*1 GRIB MESSAGE -C -C OUTPUT ARGUMENT LIST: -C KBMS - LOGICAL*1 BITMAP -C -C REMARKS: -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY -C -C$$$ - CHARACTER*1 MSGA(*) - LOGICAL*1 KBMS(NPTS) - INTEGER ICHK(NPTS) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - CALL GBYTES(MSGA,ICHK,NSKP,1,0,NPTS) - KBMS=ICHK.NE.0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END - SUBROUTINE FI635(MSGA,KPTR,KPDS,KGDS,KBMS,DATA,KRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI635 EXTRACT GRIB DATA ELEMENTS FROM BDS -C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 91-09-13 -C -C ABSTRACT: EXTRACT GRIB DATA FROM BINARY DATA SECTION AND PLACE -C INTO OUTPUT ARRAY IN PROPER POSITION. -C -C PROGRAM HISTORY LOG: -C 91-09-13 CAVANAUGH -C 94-04-01 CAVANAUGH MODIFIED CODE TO INCLUDE DECIMAL SCALING WHEN -C CALCULATING THE VALUE OF DATA POINTS SPECIFIED -C AS BEING EQUAL TO THE REFERENCE VALUE -C 94-11-10 FARLEY INCREASED MXSIZE FROM 72960 TO 260000 -C FOR .5 DEGREE SST ANALYSIS FIELDS -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 98-08-31 IREDELL ELIMINATED NEED FOR MXSIZE -C -C USAGE: CALL FI635(MSGA,KPTR,KPDS,KGDS,KBMS,DATA,KRET) -C INPUT ARGUMENT LIST: -C MSGA - ARRAY CONTAINING GRIB MESSAGE -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C (1) - TOTAL LENGTH OF GRIB MESSAGE -C (2) - LENGTH OF INDICATOR (SECTION 0) -C (3) - LENGTH OF PDS (SECTION 1) -C (4) - LENGTH OF GDS (SECTION 2) -C (5) - LENGTH OF BMS (SECTION 3) -C (6) - LENGTH OF BDS (SECTION 4) -C (7) - VALUE OF CURRENT BYTE -C (8) - BIT POINTER -C (9) - GRIB START BIT NR -C (10) - GRIB/GRID ELEMENT COUNT -C (11) - NR UNUSED BITS AT END OF SECTION 3 -C (12) - BIT MAP FLAG -C (13) - NR UNUSED BITS AT END OF SECTION 2 -C (14) - BDS FLAGS -C (15) - NR UNUSED BITS AT END OF SECTION 4 -C (16) - RESERVED -C (17) - RESERVED -C (18) - RESERVED -C (19) - BINARY SCALE FACTOR -C (20) - NUM BITS USED TO PACK EACH DATUM -C KPDS - ARRAY CONTAINING PDS ELEMENTS. -C SEE INITIAL ROUTINE -C KBMS - BITMAP DESCRIBING LOCATION OF OUTPUT ELEMENTS. -C -C OUTPUT ARGUMENT LIST: -C KBDS - INFORMATION EXTRACTED FROM BINARY DATA SECTION -C KBDS(1) - N1 -C KBDS(2) - N2 -C KBDS(3) - P1 -C KBDS(4) - P2 -C KBDS(5) - BIT POINTER TO 2ND ORDER WIDTHS -C KBDS(6) - " " " " " BIT MAPS -C KBDS(7) - " " " FIRST ORDER VALUES -C KBDS(8) - " " " SECOND ORDER VALUES -C KBDS(9) - " " START OF BDS -C KBDS(10) - " " MAIN BIT MAP -C KBDS(11) - BINARY SCALING -C KBDS(12) - DECIMAL SCALING -C KBDS(13) - BIT WIDTH OF FIRST ORDER VALUES -C KBDS(14) - BIT MAP FLAG -C 0 = NO SECOND ORDER BIT MAP -C 1 = SECOND ORDER BIT MAP PRESENT -C KBDS(15) - SECOND ORDER BIT WIDTH -C KBDS(16) - CONSTANT / DIFFERENT WIDTHS -C 0 = CONSTANT WIDTHS -C 1 = DIFFERENT WIDTHS -C KBDS(17) - SINGLE DATUM / MATRIX -C 0 = SINGLE DATUM AT EACH GRID POINT -C 1 = MATRIX OF VALUES AT EACH GRID POINT -C (18-20)- UNUSED -C -C DATA - REAL*4 ARRAY OF GRIDDED ELEMENTS IN GRIB MESSAGE. -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C SEE INPUT LIST -C KRET - ERROR RETURN -C -C REMARKS: -C ERROR RETURN -C 3 = UNPACKED FIELD IS LARGER THAN 65160 -C 6 = DOES NOT MATCH NR OF ENTRIES FOR THIS GRIB/GRID -C 7 = NUMBER OF BITS IN FILL TOO LARGE -C -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: HDS9000 -C -C$$$ -C - CHARACTER*1 MSGA(*) - CHARACTER*1 KK(8) - CHARACTER*1 CKREF(8) -C - LOGICAL*1 KBMS(*) -C - INTEGER KPDS(*) - INTEGER KGDS(*) - INTEGER KBDS(20) - INTEGER KPTR(*) - INTEGER NRBITS - INTEGER KREF - INTEGER KKK - INTEGER,ALLOCATABLE:: KSAVE(:) - INTEGER KSCALE -C - REAL DATA(*) - REAL REFNCE - REAL SCALE - REAL REALKK -C - EQUIVALENCE (CKREF(1),KREF,REFNCE) - EQUIVALENCE (KK(1),KKK,REALKK) -C -C -C CHANGED HEX VALUES TO DECIMAL TO MAKE CODE MORE PORTABLE -C -C ************************************************************* -C PRINT *,'ENTER FI635' -C SET UP BIT POINTER - KPTR(8) = KPTR(9) + (KPTR(2)*8) + (KPTR(3)*8) + (KPTR(4)*8) - * + (KPTR(5)*8) + 24 -C ------------- EXTRACT FLAGS -C BYTE 4 - CALL GBYTE(MSGA,KPTR(14),KPTR(8),4) - KPTR(8) = KPTR(8) + 4 -C --------- NR OF UNUSED BITS IN SECTION 4 - CALL GBYTE(MSGA,KPTR(15),KPTR(8),4) - KPTR(8) = KPTR(8) + 4 - KEND = KPTR(9) + (KPTR(2)*8) + (KPTR(3)*8) + (KPTR(4)*8) - * + (KPTR(5)*8) + KPTR(6) * 8 - KPTR(15) -C ------------- GET SCALE FACTOR -C BYTES 5,6 -C CHECK SIGN - CALL GBYTE (MSGA,KSIGN,KPTR(8),1) - KPTR(8) = KPTR(8) + 1 -C GET ABSOLUTE SCALE VALUE - CALL GBYTE (MSGA,KSCALE,KPTR(8),15) - KPTR(8) = KPTR(8) + 15 - IF (KSIGN.GT.0) THEN - KSCALE = - KSCALE - END IF - SCALE = 2.0**KSCALE - KPTR(19)=KSCALE -C ------------ GET REFERENCE VALUE -C BYTES 7,10 - CALL GBYTE (MSGA,KREF,KPTR(8),32) - KPTR(8) = KPTR(8) + 32 -C -C THE NEXT CODE WILL CONVERT THE IBM370 FLOATING POINT -C TO THE FLOATING POINT USED ON YOUR COMPUTER. -C -C 1ST TEST TO SEE IN ON 32 OR 64 BIT WORD MACHINE -C LW = 4 OR 8; IF 8 MAY BE A CRAY -C - CALL W3FI01(LW) - IF (LW.EQ.4) THEN - CALL GBYTE (CKREF,JSGN,0,1) - CALL GBYTE (CKREF,JEXP,1,7) - CALL GBYTE (CKREF,IFR,8,24) - ELSE - CALL GBYTE (CKREF,JSGN,32,1) - CALL GBYTE (CKREF,JEXP,33,7) - CALL GBYTE (CKREF,IFR,40,24) - ENDIF -C PRINT *,109,JSGN,JEXP,IFR -C 109 FORMAT (' JSGN,JEXP,IFR = ',3(1X,Z8)) - IF (IFR.EQ.0) THEN - REFNCE = 0.0 - ELSE IF (JEXP.EQ.0.AND.IFR.EQ.0) THEN - REFNCE = 0.0 - ELSE - REFNCE = FLOAT(IFR) * 16.0 ** (JEXP - 64 - 6) - IF (JSGN.NE.0) REFNCE = - REFNCE - END IF -C PRINT *,'SCALE ',SCALE,' REF VAL ',KREF,REFNCE -C ------------- NUMBER OF BITS SPECIFIED FOR EACH ENTRY -C BYTE 11 - CALL GBYTE (MSGA,KBITS,KPTR(8),8) - KPTR(8) = KPTR(8) + 8 - KBDS(4) = KBITS -C KBDS(13) = KBITS - KPTR(20) = KBITS - IBYT12 = KPTR(8) -C ------------------ IF THERE ARE NO EXTENDED FLAGS PRESENT -C THIS IS WHERE DATA BEGINS AND AND THE PROCESSING -C INCLUDED IN THE FOLLOWING IF...END IF -C WILL BE SKIPPED -C PRINT *,'BASIC FLAGS =',KPTR(14) ,IAND(KPTR(14),1) - IF (IAND(KPTR(14),1).EQ.0) THEN -C PRINT *,'NO EXTENDED FLAGS' - ELSE -C BYTES 12,13 - CALL GBYTE (MSGA,KOCTET,KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C --------------------------- EXTENDED FLAGS -C BYTE 14 - CALL GBYTE (MSGA,KXFLAG,KPTR(8),8) -C PRINT *,'HAVE EXTENDED FLAGS',KXFLAG - KPTR(8) = KPTR(8) + 8 - IF (IAND(KXFLAG,16).EQ.0) THEN -C SECOND ORDER VALUES CONSTANT WIDTHS - KBDS(16) = 0 - ELSE -C SECOND ORDER VALUES DIFFERENT WIDTHS - KBDS(16) = 1 - END IF - IF (IAND (KXFLAG,32).EQ.0) THEN -C NO SECONDARY BIT MAP - KBDS(14) = 0 - ELSE -C HAVE SECONDARY BIT MAP - KBDS(14) = 1 - END IF - IF (IAND (KXFLAG,64).EQ.0) THEN -C SINGLE DATUM AT GRID POINT - KBDS(17) = 0 - ELSE -C MATRIX OF VALUES AT GRID POINT - KBDS(17) = 1 - END IF -C ---------------------- NR - FIRST DIMENSION (ROWS) OF EACH MATRIX -C BYTES 15,16 - CALL GBYTE (MSGA,NR,KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C ---------------------- NC - SECOND DIMENSION (COLS) OF EACH MATRIX -C BYTES 17,18 - CALL GBYTE (MSGA,NC,KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C ---------------------- NRV - FIRST DIM COORD VALS -C BYTE 19 - CALL GBYTE (MSGA,NRV,KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ---------------------- NC1 - NR COEFF'S OR VALUES -C BYTE 20 - CALL GBYTE (MSGA,NC1,KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ---------------------- NCV - SECOND DIM COORD OR VALUE -C BYTE 21 - CALL GBYTE (MSGA,NCV,KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ---------------------- NC2 - NR COEFF'S OR VALS -C BYTE 22 - CALL GBYTE (MSGA,NC2,KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ---------------------- KPHYS1 - FIRST DIM PHYSICAL SIGNIF -C BYTE 23 - CALL GBYTE (MSGA,KPHYS1,KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ---------------------- KPHYS2 - SECOND DIM PHYSICAL SIGNIF -C BYTE 24 - CALL GBYTE (MSGA,KPHYS2,KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTES 25-N - END IF - IF (KBITS.EQ.0) THEN -C HAVE NO BDS ENTRIES, ALL ENTRIES = REFNCE - SCAL10 = 10.0 ** KPDS(22) - SCAL10 = 1.0 / SCAL10 - REFN10 = REFNCE * SCAL10 - KENTRY = KPTR(10) - DO 210 I = 1, KENTRY - DATA(I) = 0.0 - IF (KBMS(I)) THEN - DATA(I) = REFN10 - END IF - 210 CONTINUE - GO TO 900 - END IF -C PRINT *,'KEND ',KEND,' KPTR(8) ',KPTR(8),'KBITS ',KBITS - KNR = (KEND - KPTR(8)) / KBITS -C PRINT *,'NUMBER OF ENTRIES IN DATA ARRAY',KNR -C -------------------- -C CYCLE THRU BDS UNTIL HAVE USED ALL (SPECIFIED NUMBER) -C ENTRIES. -C ------------- UNUSED BITS IN DATA AREA -C NUMBER OF BYTES IN DATA AREA - NRBYTE = KPTR(6) - 11 -C ------------- TOTAL NR OF USABLE BITS - NRBITS = NRBYTE * 8 - KPTR(15) -C ------------- TOTAL NR OF ENTRIES - KENTRY = NRBITS / KBITS -C ALLOCATE KSAVE - ALLOCATE(KSAVE(KENTRY)) -C -C IF (IAND(KPTR(14),2).EQ.0) THEN -C PRINT *,'SOURCE VALUES IN FLOATING POINT' -C ELSE -C PRINT *,'SOURCE VALUES IN INTEGER' -C END IF -C - IF (IAND(KPTR(14),8).EQ.0) THEN -C PRINT *,'PROCESSING GRID POINT DATA' - IF (IAND(KPTR(14),4).EQ.0) THEN -C PRINT *,' WITH SIMPLE PACKING' - IF (IAND(KPTR(14),1).EQ.0) THEN -C PRINT *,' WITH NO ADDITIONAL FLAGS' - GO TO 4000 - ELSE IF (IAND(KPTR(14),1).NE.0) THEN -C PRINT *,' WITH ADDITIONAL FLAGS',KXFLAG - IF (KBDS(17).EQ.0) THEN -C PRINT *,' SINGLE DATUM EACH GRID PT' - IF (KBDS(14).EQ.0) THEN -C PRINT *,' NO SEC BIT MAP' - IF (KBDS(16).EQ.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES CONSTANT WIDTH' - ELSE IF (KBDS(16).NE.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES DIFFERENT WIDTHS' - END IF - ELSE IF (KBDS(14).NE.0) THEN -C PRINT *,' SEC BIT MAP' - IF (KBDS(16).EQ.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES CONSTANT WIDTH' - ELSE IF (KBDS(16).NE.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES DIFFERENT WIDTHS' - END IF - END IF - ELSE IF (KBDS(17).NE.0) THEN -C PRINT *,' MATRIX OF VALS EACH PT' - IF (KBDS(14).EQ.0) THEN -C PRINT *,' NO SEC BIT MAP' - IF (KBDS(16).EQ.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES CONSTANT WIDTH' - ELSE IF (KBDS(16).NE.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES DIFFERENT WIDTHS' - END IF - ELSE IF (KBDS(14).NE.0) THEN -C PRINT *,' SEC BIT MAP' - IF (KBDS(16).EQ.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES CONSTANT WIDTH' - ELSE IF (KBDS(16).NE.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES DIFFERENT WIDTHS' - END IF - END IF - END IF - END IF - ELSE IF (IAND(KPTR(14),4).NE.0) THEN -C PRINT *,' WITH COMPLEX/SECOND ORDER PACKING' - IF (IAND(KPTR(14),1).EQ.0) THEN -C PRINT *,' WITH NO ADDITIONAL FLAGS' - ELSE IF (IAND(KPTR(14),1).NE.0) THEN -C PRINT *,' WITH ADDITIONAL FLAGS' - IF (KBDS(17).EQ.0) THEN -C PRINT *,' SINGLE DATUM AT EACH PT' - IF (KBDS(14).EQ.0) THEN -C PRINT *,' NO SEC BIT MAP' - IF (KBDS(16).EQ.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES CONSTANT WIDTH' - ELSE IF (KBDS(16).NE.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES DIFFERENT WIDTHS' - END IF -C ROW BY ROW - COL BY COL - CALL FI636 (DATA,MSGA,KBMS, - * REFNCE,KPTR,KPDS,KGDS) - GO TO 900 - ELSE IF (KBDS(14).NE.0) THEN -C PRINT *,' SEC BIT MAP' - IF (KBDS(16).EQ.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES CONSTANT WIDTH' - ELSE IF (KBDS(16).NE.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES DIFFERENT WIDTHS' - END IF - CALL FI636 (DATA,MSGA,KBMS, - * REFNCE,KPTR,KPDS,KGDS) - GO TO 900 - END IF - ELSE IF (KBDS(17).NE.0) THEN -C PRINT *,' MATRIX OF VALS EACH PT' - IF (KBDS(14).EQ.0) THEN -C PRINT *,' NO SEC BIT MAP' - IF (KBDS(16).EQ.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES CONSTANT WIDTH' - ELSE IF (KBDS(16).NE.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES DIFFERENT WIDTHS' - END IF - ELSE IF (KBDS(14).NE.0) THEN -C PRINT *,' SEC BIT MAP' - IF (KBDS(16).EQ.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES CONSTANT WIDTH' - ELSE IF (KBDS(16).NE.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES DIFFERENT WIDTHS' - END IF - END IF - END IF - END IF - END IF - ELSE IF (IAND(KPTR(14),8).NE.0) THEN -C PRINT *,'PROCESSING SPHERICAL HARMONIC COEFFICIENTS' - IF (IAND(KPTR(14),4).EQ.0) THEN -C PRINT *,' WITH SIMPLE PACKING' - IF (IAND(KPTR(14),1).EQ.0) THEN -C PRINT *,' WITH NO ADDITIONAL FLAGS' - GO TO 5000 - ELSE IF (IAND(KPTR(14),1).NE.0) THEN -C PRINT *,' WITH ADDITIONAL FLAGS' - IF (KBDS(17).EQ.0) THEN -C PRINT *,' SINGLE DATUM EACH GRID PT' - IF (KBDS(14).EQ.0) THEN -C PRINT *,' NO SEC BIT MAP' - IF (KBDS(16).EQ.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES CONSTANT WIDTH' - ELSE IF (KBDS(16).NE.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES DIFFERENT WIDTHS' - END IF - ELSE IF (KBDS(14).NE.0) THEN -C PRINT *,' SEC BIT MAP' - IF (KBDS(16).EQ.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES CONSTANT WIDTH' - ELSE IF (KBDS(16).NE.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES DIFFERENT WIDTHS' - END IF - END IF - ELSE IF (KBDS(17).NE.0) THEN -C PRINT *,' MATRIX OF VALS EACH PT' - IF (KBDS(14).EQ.0) THEN -C PRINT *,' NO SEC BIT MAP' - IF (KBDS(16).EQ.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES CONSTANT WIDTH' - ELSE IF (KBDS(16).NE.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES DIFFERENT WIDTHS' - END IF - ELSE IF (KBDS(14).NE.0) THEN -C PRINT *,' SEC BIT MAP' - IF (KBDS(16).EQ.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES CONSTANT WIDTH' - ELSE IF (KBDS(16).NE.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES DIFFERENT WIDTHS' - END IF - END IF - END IF - END IF - ELSE IF (IAND(KPTR(14),4).NE.0) THEN -C COMPLEX/SECOND ORDER PACKING -C PRINT *,' WITH COMPLEX/SECOND ORDER PACKING' - IF (IAND(KPTR(14),1).EQ.0) THEN -C PRINT *,' WITH NO ADDITIONAL FLAGS' - ELSE IF (IAND(KPTR(14),1).NE.0) THEN -C PRINT *,' WITH ADDITIONAL FLAGS' - IF (KBDS(17).EQ.0) THEN -C PRINT *,' SINGLE DATUM EACH GRID PT' - IF (KBDS(14).EQ.0) THEN -C PRINT *,' NO SEC BIT MAP' - IF (KBDS(16).EQ.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES CONSTANT WIDTH' - ELSE IF (KBDS(16).NE.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES DIFFERENT WIDTHS' - END IF - ELSE IF (KBDS(14).NE.0) THEN -C PRINT *,' SEC BIT MAP' - IF (KBDS(16).EQ.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES CONSTANT WIDTH' - ELSE IF (KBDS(16).NE.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES DIFFERENT WIDTHS' - END IF - END IF - ELSE IF (KBDS(17).NE.0) THEN -C PRINT *,' MATRIX OF VALS EACH PT' - IF (KBDS(14).EQ.0) THEN -C PRINT *,' NO SEC BIT MAP' - IF (KBDS(16).EQ.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES CONSTANT WIDTH' - ELSE IF (KBDS(16).NE.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES DIFFERENT WIDTHS' - END IF - ELSE IF (KBDS(14).NE.0) THEN -C PRINT *,' SEC BIT MAP' - IF (KBDS(16).EQ.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES CONSTANT WIDTH' - ELSE IF (KBDS(16).NE.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES DIFFERENT WIDTHS' - END IF - END IF - END IF - END IF - END IF - END IF - IF(ALLOCATED(KSAVE)) DEALLOCATE(KSAVE) -C PRINT *,' NOT PROCESSED - NOT PROCESSED - NOT PROCESSED' - KRET = 11 - RETURN - 4000 CONTINUE -C **************************************************************** -C -C GRID POINT DATA, SIMPLE PACKING, FLOATING POINT, NO ADDN'L FLAGS -C - SCAL10 = 10.0 ** KPDS(22) - SCAL10 = 1.0 / SCAL10 - IF (KPDS(3).EQ.23.OR.KPDS(3).EQ.24.OR.KPDS(3).EQ.26. - * OR.KPDS(3).EQ.63.OR.KPDS(3).EQ.64) THEN - IF (KPDS(3).EQ.26) THEN - KADD = 72 - ELSE IF (KPDS(3).EQ.63.OR.KPDS(3).EQ.64) THEN - KADD = 91 - ELSE - KADD = 37 - END IF - CALL GBYTES (MSGA,KSAVE,KPTR(8),KBITS,0,KNR) - KPTR(8) = KPTR(8) + KBITS * KNR - II = 1 - KENTRY = KPTR(10) - DO 4001 I = 1, KENTRY - IF (KBMS(I)) THEN - DATA(I) = (REFNCE+FLOAT(KSAVE(II))*SCALE)*SCAL10 - II = II + 1 - ELSE - DATA(I) = 0.0 - END IF - 4001 CONTINUE - DO 4002 I = 2, KADD - DATA(I) = DATA(1) - 4002 CONTINUE - ELSE IF (KPDS(3).EQ.21.OR.KPDS(3).EQ.22.OR.KPDS(3).EQ.25. - * OR.KPDS(3).EQ.61.OR.KPDS(3).EQ.62) THEN - CALL GBYTES (MSGA,KSAVE,KPTR(8),KBITS,0,KNR) - II = 1 - KENTRY = KPTR(10) - DO 4011 I = 1, KENTRY - IF (KBMS(I)) THEN - DATA(I) = (REFNCE + FLOAT(KSAVE(II)) * SCALE) * SCAL10 - II = II + 1 - ELSE - DATA(I) = 0.0 - END IF - 4011 CONTINUE - IF (KPDS(3).EQ.25) THEN - KADD = 71 - ELSE IF (KPDS(3).EQ.61.OR.KPDS(3).EQ.62) THEN - KADD = 90 - ELSE - KADD = 36 - END IF - LASTP = KENTRY - KADD - DO 4012 I = LASTP+1, KENTRY - DATA(I) = DATA(LASTP) - 4012 CONTINUE - ELSE - CALL GBYTES (MSGA,KSAVE,KPTR(8),KBITS,0,KNR) - II = 1 - KENTRY = KPTR(10) - DO 500 I = 1, KENTRY - IF (KBMS(I)) THEN - DATA(I) = (REFNCE + FLOAT(KSAVE(II)) * SCALE) * SCAL10 - II = II + 1 - ELSE - DATA(I) = 0.0 - END IF - 500 CONTINUE - END IF - GO TO 900 -C ------------- PROCESS SPHERICAL HARMONIC COEFFICIENTS, -C SIMPLE PACKING, FLOATING POINT, NO ADDN'L FLAGS - 5000 CONTINUE -C PRINT *,'CHECK POINT SPECTRAL COEFF' - KPTR(8) = IBYT12 - CALL GBYTE (MSGA,KKK,KPTR(8),32) - KPTR(8) = KPTR(8) + 32 -C -C THE NEXT CODE WILL CONVERT THE IBM370 FOATING POINT -C TO THE FLOATING POINT USED ON YOUR MACHINE. -C -C 1ST TEST TO SEE IN ON 32 OR 64 BIT WORD MACHINE -C LW = 4 OR 8; IF 8 MAY BE A CRAY -C - CALL W3FI01(LW) - IF (LW.EQ.4) THEN - CALL GBYTE (KK,JSGN,0,1) - CALL GBYTE (KK,JEXP,1,7) - CALL GBYTE (KK,IFR,8,24) - ELSE - CALL GBYTE (KK,JSGN,32,1) - CALL GBYTE (KK,JEXP,33,7) - CALL GBYTE (KK,IFR,40,24) - ENDIF -C - IF (IFR.EQ.0) THEN - REALKK = 0.0 - ELSE IF (JEXP.EQ.0.AND.IFR.EQ.0) THEN - REALKK = 0.0 - ELSE - REALKK = FLOAT(IFR) * 16.0 ** (JEXP - 64 - 6) - IF (JSGN.NE.0) REALKK = -REALKK - END IF - DATA(1) = REALKK - CALL GBYTES (MSGA,KSAVE,KPTR(8),KBITS,0,KNR) -C -------------- - DO 6000 I = 1, KENTRY - DATA(I+1) = REFNCE + FLOAT(KSAVE(I)) * SCALE - 6000 CONTINUE - 900 CONTINUE - IF(ALLOCATED(KSAVE)) DEALLOCATE(KSAVE) -C PRINT *,'EXIT FI635' - RETURN - END - SUBROUTINE FI636 (DATA,MSGA,KBMS,REFNCE,KPTR,KPDS,KGDS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI636 PROCESS SECOND ORDER PACKING -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 92-09-22 -C -C ABSTRACT: PROCESS SECOND ORDER PACKING FROM THE BINARY DATA SECTION -C (BDS) FOR SINGLE DATA ITEMS GRID POINT DATA -C -C PROGRAM HISTORY LOG: -C 93-06-08 CAVANAUGH -C 93-12-15 CAVANAUGH MODIFIED SECOND ORDER POINTERS TO FIRST ORDER -C VALUES AND SECOND ORDER VALUES CORRECTLY. -C 95-04-26 R.E.JONES FI636 CORECTION FOR 2ND ORDER COMPLEX -C UNPACKING. -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C -C USAGE: CALL FI636 (DATA,MSGA,KBMS,REFNCE,KPTR,KPDS,KGDS) -C INPUT ARGUMENT LIST: -C -C MSGA - ARRAY CONTAINING GRIB MESSAGE -C REFNCE - REFERENCE VALUE -C KPTR - WORK ARRAY -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C DATA - LOCATION OF OUTPUT ARRAY -C WORKING ARRAY -C KBDS(1) - N1 -C KBDS(2) - N2 -C KBDS(3) - P1 -C KBDS(4) - P2 -C KBDS(5) - BIT POINTER TO 2ND ORDER WIDTHS -C KBDS(6) - " " " " " BIT MAPS -C KBDS(7) - " " " FIRST ORDER VALUES -C KBDS(8) - " " " SECOND ORDER VALUES -C KBDS(9) - " " START OF BDS -C KBDS(10) - " " MAIN BIT MAP -C KBDS(11) - BINARY SCALING -C KBDS(12) - DECIMAL SCALING -C KBDS(13) - BIT WIDTH OF FIRST ORDER VALUES -C KBDS(14) - BIT MAP FLAG -C 0 = NO SECOND ORDER BIT MAP -C 1 = SECOND ORDER BIT MAP PRESENT -C KBDS(15) - SECOND ORDER BIT WIDTH -C KBDS(16) - CONSTANT / DIFFERENT WIDTHS -C 0 = CONSTANT WIDTHS -C 1 = DIFFERENT WIDTHS -C KBDS(17) - SINGLE DATUM / MATRIX -C 0 = SINGLE DATUM AT EACH GRID POINT -C 1 = MATRIX OF VALUES AT EACH GRID POINT -C (18-20)- UNUSED -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: HDS, CRAY -C -C$$$ - REAL DATA(*) - REAL REFN - REAL REFNCE -C - INTEGER KBDS(20) - INTEGER KPTR(*) - INTEGER JREF,BMAP2(12500) - INTEGER I,IBDS - INTEGER KBIT,IFOVAL,ISOVAL - INTEGER KPDS(*),KGDS(*) -C - LOGICAL*1 KBMS(*) -C - CHARACTER*1 MSGA(*) -C - EQUIVALENCE (JREF,REFN) -C ******************* SETUP ****************************** -C PRINT *,'ENTER FI636' -C START OF BMS (BIT POINTER) - DO I = 1,20 - KBDS(I) = 0 - END DO -C BYTE START OF BDS - IBDS = KPTR(2) + KPTR(3) + KPTR(4) + KPTR(5) -C PRINT *,'KPTR(2-5) ',KPTR(2),KPTR(3),KPTR(4),KPTR(5) -C BIT START OF BDS - JPTR = IBDS * 8 -C PRINT *,'JPTR ',JPTR - KBDS(9) = JPTR -C PRINT *,'START OF BDS ',KBDS(9) -C BINARY SCALE VALUE BDS BYTES 5-6 - CALL GBYTE (MSGA,ISIGN,JPTR+32,1) - CALL GBYTE (MSGA,KBDS(11),JPTR+33,15) - IF (ISIGN.GT.0) THEN - KBDS(11) = - KBDS(11) - END IF -C PRINT *,'BINARY SCALE VALUE =',KBDS(11) -C EXTRACT REFERENCE VALUE - CALL GBYTE(MSGA,JREF,JPTR+48,32) -C PRINT *,'DECODED REFERENCE VALUE =',REFN,REFNCE -C F O BIT WIDTH - CALL GBYTE(MSGA,KBDS(13),JPTR+80,8) - JPTR = JPTR + 88 -C AT START OF BDS BYTE 12 -C EXTRACT N1 - CALL GBYTE (MSGA,KBDS(1),JPTR,16) -C PRINT *,'N1 = ',KBDS(1) - JPTR = JPTR + 16 -C EXTENDED FLAGS - CALL GBYTE (MSGA,KFLAG,JPTR,8) -C ISOLATE BIT MAP FLAG - IF (IAND(KFLAG,32).NE.0) THEN - KBDS(14) = 1 - ELSE - KBDS(14) = 0 - END IF - IF (IAND(KFLAG,16).NE.0) THEN - KBDS(16) = 1 - ELSE - KBDS(16) = 0 - END IF - IF (IAND(KFLAG,64).NE.0) THEN - KBDS(17) = 1 - ELSE - KBDS(17) = 0 - END IF - JPTR = JPTR + 8 -C EXTRACT N2 - CALL GBYTE (MSGA,KBDS(2),JPTR,16) -C PRINT *,'N2 = ',KBDS(2) - JPTR = JPTR + 16 -C EXTRACT P1 - CALL GBYTE (MSGA,KBDS(3),JPTR,16) -C PRINT *,'P1 = ',KBDS(3) - JPTR = JPTR + 16 -C EXTRACT P2 - CALL GBYTE (MSGA,KBDS(4),JPTR,16) -C PRINT *,'P2 = ',KBDS(4) - JPTR = JPTR + 16 -C SKIP RESERVED BYTE - JPTR = JPTR + 8 -C START OF SECOND ORDER BIT WIDTHS - KBDS(5) = JPTR -C COMPUTE START OF SECONDARY BIT MAP - IF (KBDS(14).NE.0) THEN -C FOR INCLUDED SECONDARY BIT MAP - JPTR = JPTR + (KBDS(3) * 8) - KBDS(6) = JPTR - ELSE -C FOR CONSTRUCTED SECONDARY BIT MAP - KBDS(6) = 0 - END IF -C CREATE POINTER TO START OF FIRST ORDER VALUES - KBDS(7) = KBDS(9) + KBDS(1) * 8 - 8 -C PRINT *,'BIT POINTER TO START OF FOVALS',KBDS(7) -C CREATE POINTER TO START OF SECOND ORDER VALUES - KBDS(8) = KBDS(9) + KBDS(2) * 8 - 8 -C PRINT *,'BIT POINTER TO START OF SOVALS',KBDS(8) -C PRINT *,'KBDS( 1) - N1 ',KBDS( 1) -C PRINT *,'KBDS( 2) - N2 ',KBDS( 2) -C PRINT *,'KBDS( 3) - P1 ',KBDS( 3) -C PRINT *,'KBDS( 4) - P2 ',KBDS( 4) -C PRINT *,'KBDS( 5) - BIT PTR - 2ND ORDER WIDTHS ',KBDS( 5) -C PRINT *,'KBDS( 6) - " " " " BIT MAPS ',KBDS( 6) -C PRINT *,'KBDS( 7) - " " F O VALS ',KBDS( 7) -C PRINT *,'KBDS( 8) - " " S O VALS ',KBDS( 8) -C PRINT *,'KBDS( 9) - " " START OF BDS ',KBDS( 9) -C PRINT *,'KBDS(10) - " " MAIN BIT MAP ',KBDS(10) -C PRINT *,'KBDS(11) - BINARY SCALING ',KBDS(11) -C PRINT *,'KPDS(22) - DECIMAL SCALING ',KPDS(22) -C PRINT *,'KBDS(13) - FO BIT WIDTH ',KBDS(13) -C PRINT *,'KBDS(14) - 2ND ORDER BIT MAP FLAG ',KBDS(14) -C PRINT *,'KBDS(15) - 2ND ORDER BIT WIDTH ',KBDS(15) -C PRINT *,'KBDS(16) - CONSTANT/DIFFERENT WIDTHS ',KBDS(16) -C PRINT *,'KBDS(17) - SINGLE DATUM/MATRIX ',KBDS(17) -C PRINT *,'REFNCE VAL ',REFNCE -C ************************* PROCESS DATA ********************** - IJ = 0 -C ======================================================== - IF (KBDS(14).EQ.0) THEN -C NO BIT MAP, MUST CONSTRUCT ONE - IF (KGDS(2).EQ.65535) THEN - IF (KGDS(20).EQ.255) THEN -C PRINT *,'CANNOT BE USED HERE' - ELSE -C POINT TO PL - LP = KPTR(9) + KPTR(2)*8 + KPTR(3)*8 + KGDS(20)*8 - 8 -C PRINT *,'LP = ',LP - JT = 0 - DO 2000 JZ = 1, KGDS(3) -C GET NUMBER IN CURRENT ROW - CALL GBYTE (MSGA,NUMBER,LP,16) -C INCREMENT TO NEXT ROW NUMBER - LP = LP + 16 -C PRINT *,'NUMBER IN ROW',JZ,' = ',NUMBER - DO 1500 JQ = 1, NUMBER - IF (JQ.EQ.1) THEN - CALL SBYTE (BMAP2,1,JT,1) - ELSE - CALL SBYTE (BMAP2,0,JT,1) - END IF - JT = JT + 1 - 1500 CONTINUE - 2000 CONTINUE - END IF - ELSE - IF (IAND(KGDS(11),32).EQ.0) THEN -C ROW BY ROW -C PRINT *,' ROW BY ROW' - KOUT = KGDS(3) - KIN = KGDS(2) - ELSE -C COL BY COL -C PRINT *,' COL BY COL' - KIN = KGDS(3) - KOUT = KGDS(2) - END IF -C PRINT *,'KIN=',KIN,' KOUT= ',KOUT - DO 200 I = 1, KOUT - DO 150 J = 1, KIN - IF (J.EQ.1) THEN - CALL SBYTE (BMAP2,1,IJ,1) - ELSE - CALL SBYTE (BMAP2,0,IJ,1) - END IF - IJ = IJ + 1 - 150 CONTINUE - 200 CONTINUE - END IF - END IF -C ======================================================== -C PRINT 99,(BMAP2(J),J=1,110) -C99 FORMAT ( 10(1X,Z8.8)) -C CALL BINARY (BMAP2,2) -C FOR EACH GRID POINT ENTRY -C - SCALE2 = 2.0**KBDS(11) - SCAL10 = 10.0**KPDS(22) -C PRINT *,'SCALE VALUES - ',SCALE2,SCAL10 - DO 1000 I = 1, KPTR(10) -C GET NEXT MASTER BIT MAP BIT POSITION -C IF NEXT MASTER BIT MAP BIT POSITION IS 'ON' (1) - IF (KBMS(I)) THEN -C WRITE(6,900)I,KBMS(I) -C 900 FORMAT (1X,I4,3X,14HMAIN BIT IS ON,3X,L4) - IF (KBDS(14).NE.0) THEN - CALL GBYTE (MSGA,KBIT,KBDS(6),1) - ELSE - CALL GBYTE (BMAP2,KBIT,KBDS(6),1) - END IF -C PRINT *,'KBDS(6) =',KBDS(6),' KBIT =',KBIT - KBDS(6) = KBDS(6) + 1 - IF (KBIT.NE.0) THEN -C PRINT *,' SOB ON' -C GET NEXT FIRST ORDER PACKED VALUE - CALL GBYTE (MSGA,IFOVAL,KBDS(7),KBDS(13)) - KBDS(7) = KBDS(7) + KBDS(13) -C PRINT *,'FOVAL =',IFOVAL -C GET SECOND ORDER BIT WIDTH - CALL GBYTE (MSGA,KBDS(15),KBDS(5),8) - KBDS(5) = KBDS(5) + 8 -C PRINT *,KBDS(7)-KBDS(13),' FOVAL =',IFOVAL,' KBDS(5)=', -C * ,KBDS(5), 'ISOWID =',KBDS(15) - ELSE -C PRINT *,' SOB NOT ON' - END IF - ISOVAL = 0 - IF (KBDS(15).EQ.0) THEN -C IF SECOND ORDER BIT WIDTH = 0 -C THEN SECOND ORDER VALUE IS 0 -C SO CALCULATE DATA VALUE FOR THIS POINT -C DATA(I) = (REFNCE + (FLOAT(IFOVAL) * SCALE2)) / SCAL10 - ELSE - CALL GBYTE (MSGA,ISOVAL,KBDS(8),KBDS(15)) - KBDS(8) = KBDS(8) + KBDS(15) - END IF - DATA(I) = (REFNCE + (FLOAT(IFOVAL + ISOVAL) * - * SCALE2)) / SCAL10 -C PRINT *,I,DATA(I),REFNCE,IFOVAL,ISOVAL,SCALE2,SCAL10 - ELSE -C WRITE(6,901) I,KBMS(I) -C 901 FORMAT (1X,I4,3X,15HMAIN BIT NOT ON,3X,L4) - DATA(I) = 0.0 - END IF -C PRINT *,I,DATA(I),IFOVAL,ISOVAL,KBDS(5),KBDS(15) - 1000 CONTINUE -C ************************************************************** -C PRINT *,'EXIT FI636' - RETURN - END - SUBROUTINE FI637(J,KPDS,KGDS,KRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI637 GRIB GRID/SIZE TEST -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 91-09-13 -C -C ABSTRACT: TO TEST WHEN GDS IS AVAILABLE TO SEE IF SIZE MISMATCH -C ON EXISTING GRIDS (BY CENTER) IS INDICATED -C -C PROGRAM HISTORY LOG: -C 91-09-13 CAVANAUGH -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 97-02-12 W BOSTELMAN CORRECTS ECMWF US GRID 2 PROCESSING -C 98-06-17 IREDELL REMOVED ALTERNATE RETURN -C 99-01-20 BALDWIN MODIFY TO HANDLE GRID 237 -C -C USAGE: CALL FI637(J,KPDS,KGDS,KRET) -C INPUT ARGUMENT LIST: -C J - SIZE FOR INDICATED GRID -C KPDS - -C KGDS - -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C J - SIZE FOR INDICATED GRID MODIFIED FOR ECMWF-US 2 -C KRET - ERROR RETURN -C (A MISMATCH WAS DETECTED IF KRET IS NOT ZERO) -C -C REMARKS: -C KRET - -C = 9 - GDS INDICATES SIZE MISMATCH WITH STD GRID -C -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: HDS -C -C$$$ - INTEGER KPDS(*) - INTEGER KGDS(*) - INTEGER J - INTEGER I -C --------------------------------------- -C --------------------------------------- -C IF GDS NOT INDICATED, RETURN -C ---------------------------------------- - KRET=0 - IF (IAND(KPDS(4),128).EQ.0) RETURN -C --------------------------------------- -C GDS IS INDICATED, PROCEED WITH TESTING -C --------------------------------------- - IF (KGDS(2).EQ.65535) THEN - RETURN - END IF - KRET=1 - I = KGDS(2) * KGDS(3) -C --------------------------------------- -C INTERNATIONAL SET -C --------------------------------------- - IF (KPDS(3).GE.21.AND.KPDS(3).LE.26) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).GE.37.AND.KPDS(3).LE.44) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.50) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).GE.61.AND.KPDS(3).LE.64) THEN - IF (I.NE.J) THEN - RETURN - END IF -C --------------------------------------- -C TEST ECMWF CONTENT -C --------------------------------------- - ELSE IF (KPDS(1).EQ.98) THEN - KRET = 9 - IF (KPDS(3).GE.1.AND.KPDS(3).LE.16) THEN - IF (I.NE.J) THEN - IF (KPDS(3) .NE. 2) THEN - RETURN - ELSEIF (I .NE. 10512) THEN ! Test for US Grid 2 - RETURN - END IF - J = I ! Set to US Grid 2, 2.5 Global - END IF - ELSE - KRET = 5 - RETURN - END IF -C --------------------------------------- -C U.K. MET OFFICE, BRACKNELL -C --------------------------------------- - ELSE IF (KPDS(1).EQ.74) THEN - KRET = 9 - IF (KPDS(3).GE.25.AND.KPDS(3).LE.26) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE - KRET = 5 - RETURN - END IF -C --------------------------------------- -C CANADA -C --------------------------------------- - ELSE IF (KPDS(1).EQ.54) THEN -C PRINT *,' NO CURRENT LISTING OF CANADIAN GRIDS' - RETURN -C --------------------------------------- -C JAPAN METEOROLOGICAL AGENCY -C --------------------------------------- - ELSE IF (KPDS(1).EQ.34) THEN -C PRINT *,' NO CURRENT LISTING OF JMA GRIDS' - RETURN -C --------------------------------------- -C NAVY - FNOC -C --------------------------------------- - ELSE IF (KPDS(1).EQ.58) THEN - IF (KPDS(3).GE.37.AND.KPDS(3).LE.44) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).GE.220.AND.KPDS(3).LE.221) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.223) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE - KRET = 5 - RETURN - END IF -C --------------------------------------- -C U.S. GRIDS -C --------------------------------------- - ELSE IF (KPDS(1).EQ.7) THEN - KRET = 9 - IF (KPDS(3).GE.1.AND.KPDS(3).LE.6) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.8) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).GE.27.AND.KPDS(3).LE.30) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).GE.33.AND.KPDS(3).LE.34) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).GE.37.AND.KPDS(3).LE.44) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.53) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).GE.55.AND.KPDS(3).LE.56) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).GE.67.AND.KPDS(3).LE.77) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).GE.85.AND.KPDS(3).LE.88) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).GE.90.AND.KPDS(3).LE.98) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.100.OR.KPDS(3).EQ.101) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).GE.103.AND.KPDS(3).LE.107) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.110) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.120) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.126.OR.KPDS(3).EQ.127) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.130) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).GE.145.AND.KPDS(3).LE.148) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.160.OR.KPDS(3).EQ.161) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.163) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).GE.170.AND.KPDS(3).LE.175) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.190.OR.KPDS(3).EQ.192) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.194.OR.KPDS(3).EQ.196) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.198) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).GE.201.AND.KPDS(3).LE.254) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE - KRET = 5 - RETURN - END IF - ELSE - KRET = 10 - RETURN - END IF -C ------------------------------------ -C NORMAL EXIT -C ------------------------------------ - KRET = 0 - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fi64.f b/src/fim/FIMsrc/w3/w3fi64.f deleted file mode 100644 index 2c7f1ac..0000000 --- a/src/fim/FIMsrc/w3/w3fi64.f +++ /dev/null @@ -1,760 +0,0 @@ - SUBROUTINE W3FI64(COCBUF,LOCRPT,NEXT) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI64 NMC OFFICE NOTE 29 REPORT UNPACKER -C PRGMMR: KEYSER ORG: NMC22 DATE:92-08-06 -C -C ABSTRACT: UNPACKS AN ARRAY OF UPPER-AIR REPORTS THAT ARE PACKED IN -C THE FORMAT DESCRIBED BY NMC OFFICE NOTE 29, OR UNPACKS AN ARRAY -C OF SURFACE REPORTS THAT ARE PACKED IN THE FORMAT DESCRIBED BY NMC -C OFFICE NOTE 124. INPUT CHARACTER DATA ARE CONVERTED TO INTEGER, -C REAL OR CHARACTER TYPE AS SPECIFIED IN THE CATEGORY TABLES BELOW. -C MISSING INTEGER DATA ARE REPLACED WITH 99999, MISSING REAL DATA -C ARE REPLACED WITH 99999.0 AND MISSING CHARACTER DATA ARE REPLACED -C WITH BLANKS. THIS LIBRARY IS SIMILAR TO W3AI02 EXCEPT W3AI02 -C WAS WRITTEN IN ASSEMBLER AND COULD NOT HANDLE INTERNAL READ ERRORS -C (PROGRAM CALLING W3AI02 WOULD FAIL IN THIS CASE W/O EXPLANATION). -C -C PROGRAM HISTORY LOG: -C 90-01-?? L. MARX, UNIV. OF MD -- CONVERTED CODE FROM ASSEMBLER -C TO VS FORTRAN; EXPANDED ERROR RETURN CODES IN 'NEXT' -C 91-07-22 D. A. KEYSER, NMC22 -- USE SAME ARGUMENTS AS W3AI02; -C STREAMLINED CODE; DOCBLOCKED AND COMMENTED; DIAG- -C NOSTIC PRINT FOR ERRORS; ATTEMPTS TO SKIP TO NEXT -C REPORT IN SAME RECORD RATHER THAN EXITING RECORD -C 91-08-12 D. A. KEYSER, NMC22 -- SLIGHT CHANGES TO MAKE SUB- -C PROGRAM MORE PORTABLE; TEST FOR ABSENCE OF END- -C OF-RECORD INDICATOR, WILL GRACEFULLY EXIT RECORD -C 92-06-29 D. A. KEYSER W/NMC22 -- CONVERT TO CRAY CFT77 FORTRAN -C 92-08-06 D. A. KEYSER, NMC22 -- CORRECTED ERROR WHICH COULD -C LEAD TO THE LENGTH FOR A CONCATENATION OPERATOR -C BEING LESS THAN 1 WHEN AN INPUT PARAMETER SPANS -C ACROSS TWO 10-CHARACTER WORDS -C -C USAGE: CALL W3FI64(COCBUF,LOCRPT,NEXT) -C INPUT ARGUMENT LIST: -C COCBUF - CHARACTER*10 ARRAY CONTAINING A BLOCK OF PACKED -C - REPORTS IN NMC OFFICE NOTE 29/124 FORMAT. -C NEXT - MARKER INDICATING RELATIVE LOCATION (IN BYTES) OF -C - END OF LAST REPORT IN COCBUF. EXCEPTION: NEXT MUST -C - BE SET TO ZERO PRIOR TO UNPACKING THE FIRST REPORT OF -C - A NEW BLOCK OF REPORTS. SUBSEQUENTLY, THE VALUE OF -C - NEXT RETURNED BY THE PREVIOUS CALL TO W3FI64 SHOULD -C - BE USED AS INPUT. (SEE OUTPUT ARGUMENT LIST BELOW.) -C - IF NEXT IS NEGATIVE, W3FI64 WILL RETURN IMMEDIATELY -C - WITHOUT ACTION. -C -C OUTPUT ARGUMENT LIST: -C LOCRPT - ARRAY CONTAINING ONE UNPACKED REPORT WITH POINTERS -C - AND COUNTERS TO DIRECT THE USER. LOCRPT MUST BEGIN -C - ON A FULLWORD BOUNDARY. FORMAT IS MIXED, USER MUST -C - EQUIVALENCE REAL AND CHARACTER ARRAYS TO THIS ARRAY -C - (SEE BELOW AND REMARKS FOR CONTENT). -C *************************************************************** -C WORD CONTENT UNIT FORMAT -C ---- ---------------------- ------------------- --------- -C 1 LATITUDE 0.01 DEGREES REAL -C 2 LONGITUDE 0.01 DEGREES WEST REAL -C 3 UNUSED -C 4 OBSERVATION TIME 0.01 HOURS (UTC) REAL -C 5 RESERVED (3RD BYTE IS 4-CHARACTERS CHAR*8 -C ON29 "25'TH CHAR.; 4TH LEFT-JUSTIFIED -C BYTE IS ON29 "26'TH -C CHAR." (SEE ON29) -C 6 RESERVED (3RD BYTE IS 3-CHARACTERS CHAR*8 -C ON29 "27'TH CHAR. (SEE LEFT-JUSTIFIED -C ON29) -C 7 STATION ELEVATION METERS REAL -C 8 INSTRUMENT TYPE ON29 TABLE R.2 INTEGER -C 9 REPORT TYPE ON29 TABLE R.1 OR INTEGER -C ON124 TABLE S.3 -C 10 UNUNSED -C 11 STN. ID. (FIRST 4 CHAR.) 4-CHARACTERS CHAR*8 -C LEFT-JUSTIFIED -C 12 STN. ID. (LAST 2 CHAR.) 2-CHARACTERS CHAR*8 -C LEFT-JUSTIFIED -C -C 13 CATEGORY 1, NO. LEVELS COUNT INTEGER -C 14 CATEGORY 1, DATA INDEX COUNT INTEGER -C 15 CATEGORY 2, NO. LEVELS COUNT INTEGER -C 16 CATEGORY 2, DATA INDEX COUNT INTEGER -C 17 CATEGORY 3, NO. LEVELS COUNT INTEGER -C 18 CATEGORY 3, DATA INDEX COUNT INTEGER -C 19 CATEGORY 4, NO. LEVELS COUNT INTEGER -C 20 CATEGORY 4, DATA INDEX COUNT INTEGER -C 21 CATEGORY 5, NO. LEVELS COUNT INTEGER -C 22 CATEGORY 5, DATA INDEX COUNT INTEGER -C 23 CATEGORY 6, NO. LEVELS COUNT INTEGER -C 24 CATEGORY 6, DATA INDEX COUNT INTEGER -C 25 CATEGORY 7, NO. LEVELS COUNT INTEGER -C 26 CATEGORY 7, DATA INDEX COUNT INTEGER -C 27 CATEGORY 8, NO. LEVELS COUNT INTEGER -C 28 CATEGORY 8, DATA INDEX COUNT INTEGER -C 29 CATEGORY 51, NO. LEVELS COUNT INTEGER -C 30 CATEGORY 51, DATA INDEX COUNT INTEGER -C 31 CATEGORY 52, NO. LEVELS COUNT INTEGER -C 32 CATEGORY 52, DATA INDEX COUNT INTEGER -C 33 CATEGORY 9, NO. LEVELS COUNT INTEGER -C 34 CATEGORY 9, DATA INDEX COUNT INTEGER -C 35-42 ZEROED OUT - NOT USED INTEGER -C -C 43-END UNPACKED DATA GROUPS (SEE REMARKS) MIXED -C *************************************************************** -C -C NEXT - MARKER INDICATING RELATIVE LOCATION (IN BYTES) -C - OF END OF CURRENT REPORT IN COCBUF. NEXT WILL BE -C - SET TO -1 IF W3FI64 ENCOUNTERS STRING 'END RECORD' -C - IN PLACE OF THE NEXT REPORT. THIS IS THE END OF THE -C - BLOCK. NO UNPACKING TAKES PLACE. NEXT IS SET TO-2 -C - WHEN INTERNAL (LOGIC) ERRORS HAVE BEEN DETECTED. -C - NEXT IS SET TO -3 WHEN DATA COUNT CHECK FAILS. IN -C - BOTH OF THE LATTER CASES SOME DATA (E.G., HEADER -C - INFORMATION) MAY BE UNPACKED INTO LOCRPT. -C -C OUTPUT FILES: -C FT06F001 - PRINTOUT -C -C REMARKS: AFTER FIRST READING AND PROCESSING THE OFFICE NOTE 85 -C (FIRST) DATE RECORD, THE USER'S FORTRAN PROGRAM BEGINS A READ -C LOOP AS FOLLOWS.. FOR EACH ITERATION A BLOCKED INPUT REPORT IS -C READ INTO ARRAY COCBUF. NOW TEST THE FIRST TEN CHARACTERS IN -C COCBUF FOR THE STRING 'ENDOF FILE' (SIC). THIS STRING SIGNALS -C THE END OF INPUT. OTHERWISE, SET THE MARKER 'NEXT' TO ZERO AND -C BEGIN THE UNPACKING LOOP. -C EACH ITERATION OF THE UNPACKING LOOP CONSISTS OF A CALL TO -C W3FI64 WITH THE CURRENT VALUE OF 'NEXT'. IF 'NEXT' IS -1 UPON -C RETURNING FROM W3FI64, IT HAS REACHED THE END OF THE INPUT -C RECORD, AND THE USER'S PROGRAM SHOULD READ THE NEXT RECORD AS -C ABOVE. IF 'NEXT' IS -2 OR -3 UPON RETURNING, THERE IS A GRIEVOUS -C ERROR IN THE CURRENT PACKED INPUT RECORD, AND THE USER'S PROGRAM -C SHOULD PRINT IT FOR EXAMINATION BY AUTOMATION DIVISION PERSONNEL. -C IF 'NEXT' IS POSITIVE, THE OUTPUT STRUCTURE LOCRPT CONTAINS -C AN UNPACKED REPORT, AND THE USER'S PROGRAM SHOULD PROCESS IT AT -C THIS POINT, SUBSEQUENTLY REPEATING THE UNPACKING LOOP. -C -C EXAMPLE: -C CHARACTER*10 COCBUF(644) -C CHARACTER*8 COCRPT(1608) -C CHARACTER*3 CQUMAN(20) -C INTEGER LOCRPT(1608) -C REAL ROCRPT(1608),GEOMAN(20),TMPMAN(20),DPDMAN(20), -C $ WDRMAN(20),WSPMAN(20) -C EQUIVALENCE (COCRPT,LOCRPT,ROCRPT) -C .......... -C C READ AND PROCESS THE OFFICE NOTE 85 DATE RECORD -C .......... -C C --- BEGIN READ LOOP -C 10 CONTINUE -C READ (UNIT=INP, IOSTAT=IOS, NUM=NBUF) COCBUF -C IF(IOS .LT. 0) GO TO (END OF INPUT) -C IF(IOS .GT. 0) GO TO (INPUT ERROR) -C IF(NBUF .GT. 6432) GO TO (BUFFER OVERFLOW) -C IF(COCBUF(1).EQ.'ENDOF FILE') GO TO (END OF INPUT) -C NEXT = 0 -C C ------ BEGIN UNPACKING LOOP -C 20 CONTINUE -C CALL W3FI64(COCBUF, LOCRPT, NEXT) -C IF(NEXT .EQ. -1) GO TO 10 -C IF(NEXT .LT. -1) GO TO (OFFICE NOTE 29/124 ERROR) -C RLAT = 0.01 * ROCRPT(1) (LATITUDE) -C ..... ETC ..... -C C --- BEGIN CATEGORY 1 FETCH -- MANDATORY LEVEL DATA -C IF(LOCRPT(13) .GT. 0) THEN -C NLVLS = MIN(20,LOCRPT(13)) -C INDX = LOCRPT(14) -C DO 66 I = 1,NLVLS -C GEOMAN(I) = ROCRPT(INDX) -C TMPMAN(I) = 0.1 * ROCRPT(INDX+1) -C DPDMAN(I) = 0.1 * ROCRPT(INDX+2) -C WDRMAN(I) = ROCRPT(INDX+3) -C WSPMAN(I) = ROCRPT(INDX+4) -C CQUMAN(I) = COCRPT(INDX+5) -C INDX = INDX + 6 -C 66 CONTINUE -C END IF -C ..... ETC ..... -C GO TO 20 -C ............... -C -C DATA FROM THE ON29/124 RECORD IS UNPACKED INTO FIXED LOCATIONS -C IN WORDS 1-12 AND INTO INDEXED LOCATIONS IN WORD 43 AND -C FOLLOWING. STUDY ON29 APPENDIX C/ON124 APPENDIX S.2 CAREFULLY. -C EACH CATEGORY (OR GROUP OF FIELDS) IN THE PACKED REPORT HAS A -C CORRESPONDING LAYOUT IN LOCATIONS IN ARRAY LOCRPT THAT MAY BE -C FOUND BY USING THE CORRESPONDING INDEX AMOUNT FROM WORDS 14, 16, -C ..., 34, IN ARRAY LOCRPT. FOR INSTANCE, IF A REPORT CONTAINS -C ONE OR MORE PACKED CATEGORY 3 DATA GROUPS (WIND DATA AT VARIABLE -C PRESSURE LEVELS) THAT DATA WILL BE UNPACKED INTO BINARY AND -C AND CHARACTER FIELDS IN ONE OR MORE UNPACKED CATEGORY 3 DATA -C GROUPS AS DESCRIBED BELOW. THE NUMBER OF LEVELS WILL BE STORED -C IN WORD 17 AND THE INDEX IN FULLWORDS OF THE FIRST LEVEL OF -C UNPACKED DATA IN THE OUTPUT ARRAY WILL BE STORED IN WORD 18. -C THE SECOND LEVEL, IF ANY, WILL BE STORED BEGINNING FOUR WORDS -C FURTHER ON, AND SO FORTH UNTIL THE COUNT IN WORD 17 IS -C EXHAUSTED. THE FIELD LAYOUT IN EACH CATEGORY IS GIVEN BELOW... -C -C CATEGORY 1 - MANDATORY LEVEL DATA -C WORD PARAMETER UNITS FORMAT -C ---- --------- ----------------- ------------- -C 1 GEOPOTENTIAL METERS REAL -C 2 TEMPERATURE 0.1 DEGREES C REAL -C 3 DEWPOINT DEPRESSION 0.1 DEGREES C REAL -C 4 WIND DIRECTION DEGREES REAL -C 5 WIND SPEED KNOTS REAL -C 6 QUALITY MARKERS: EACH 1-CHARACTER CHAR*8 -C LEFT-JUSTIFIED -C GEOPOTENTIAL ON29 TABLE Q.A -C TEMPERATURE ON29 TABLE Q.A -C DEWPOINT DEPR. ON29 TABLE Q.C -C WIND ON29 TABLE Q.A -C -C CATEGORY 2 - TEMPERATURE AT VARIABLE PRESSURE -C WORD PARAMETER UNITS FORMAT -C ---- --------- ----------------- ------------- -C 1 PRESSURE 0.1 MILLIBARS REAL -C 2 TEMPERATURE 0.1 DEGREES C REAL -C 3 DEWPOINT DEPRESSION 0.1 DEGREES C REAL -C 4 QUALITY MARKERS: EACH 1-CHARACTER CHAR*8 -C LEFT-JUSTIFIED -C PRESSURE ON29 TABLE Q.B -C TEMPERATURE ON29 TABLE Q.A -C DEWPOINT DEPR. ON29 TABLE Q.C -C NOT USED BLANK -C -C CATEGORY 3 - WINDS AT VARIABLE PRESSURE -C WORD PARAMETER UNITS FORMAT -C ---- --------- ----------------- ------------- -C 1 PRESSURE 0.1 MILLIBARS REAL -C 2 WIND DIRECTION DEGREES REAL -C 3 WIND SPEED KNOTS REAL -C 4 QUALITY MARKERS: EACH 1-CHARACTER CHAR*8 -C LEFT-JUSTIFIED -C PRESSURE ON29 TABLE Q.B -C WIND ON29 TABLE Q.A -C NOT USED BLANK -C NOT USED BLANK -C -C CATEGORY 4 - WINDS AT VARIABLE HEIGHTS -C WORD PARAMETER UNITS FORMAT -C ---- --------- ----------------- ------------- -C 1 GEOPOTENTIAL METERS REAL -C 2 WIND DIRECTION DEGREES REAL -C 3 WIND SPEED KNOTS REAL -C 4 QUALITY MARKERS: EACH 1-CHARACTER CHAR*8 -C LEFT-JUSTIFIED -C GEOPOTENTIAL ON29 TABLE Q.B -C WIND ON29 TABLE Q.A -C NOT USED BLANK -C NOT USED BLANK -C -C CATEGORY 5 - TROPOPAUSE DATA -C WORD PARAMETER UNITS FORMAT -C ---- --------- ----------------- ------------- -C 1 GEOPOTENTIAL METERS REAL -C 2 TEMPERATURE 0.1 DEGREES C REAL -C 3 DEWPOINT DEPRESSION 0.1 DEGREES C REAL -C 4 WIND DIRECTION DEGREES REAL -C 5 WIND SPEED KNOTS REAL -C 6 QUALITY MARKERS: EACH 1-CHARACTER CHAR*8 -C LEFT-JUSTIFIED -C PRESSURE ON29 TABLE Q.B -C TEMPERATURE ON29 TABLE Q.A -C DEWPOINT DEPR. ON29 TABLE Q.C -C WIND ON29 TABLE Q.A -C -C CATEGORY 6 - CONSTANT-LEVEL DATA (AIRCRAFT, SAT. CLOUD-DRIFT) -C WORD PARAMETER UNITS FORMAT -C ---- --------- ----------------- ------------- -C 1 PRESSURE ALTITUDE METERS REAL -C 2 TEMPERATURE 0.1 DEGREES C REAL -C 3 DEWPOINT DEPRESSION 0.1 DEGREES C REAL -C 4 WIND DIRECTION DEGREES REAL -C 5 WIND SPEED KNOTS REAL -C 6 QUALITY MARKERS: EACH 1-CHARACTER CHAR*8 -C LEFT-JUSTIFIED -C PRESSURE ON29 TABLE Q.6 -C TEMPERATURE ON29 TABLE Q.6 -C DEWPOINT DEPR. ON29 TABLE Q.6 -C WIND ON29 TABLE Q.6C -C -C CATEGORY 7 - CLOUD COVER -C WORD PARAMETER UNITS FORMAT -C ---- --------- ----------------- ------------- -C 1 PRESSURE 0.1 MILLIBARS REAL -C 2 AMOUNT OF CLOUDS PER CENT REAL -C 3 QUALITY MARKERS: EACH 1-CHARACTER CHAR*8 -C LEFT-JUSTIFIED -C PRESSURE ON29 TABLE Q.7 -C CLOUD AMOUNT ON29 TABLE Q.7 -C NOT USED BLANK -C NOT USED BLANK -C -C CATEGORY 8 - ADDITIONAL DATA -C WORD PARAMETER UNITS FORMAT -C ---- --------- ----------------- ------------- -C 1 SPECIFIED IN ON29 VARIABLE REAL -C TABLE 101.1 OR -C ON124 TABLE SM.8A.1 -C 2 FORM OF ADD'L DATA CODE FIGURE FROM REAL -C ON29 TABLE 101 OR -C ON124 TABLE SM.8A -C 3 QUALITY MARKERS: EACH 1-CHARACTER CHAR*8 -C LEFT-JUSTIFIED -C VALUE 1 ON29 TABLE Q.8 OR -C ON124 TABLE SM.8B -C VALUE 2 ON29 TABLE Q.8A OR -C ON124 TABLE SM.8C -C NOT USED BLANK -C NOT USED BLANK -C -C CATEGORY 51 - SURFACE DATA -C WORD PARAMETER UNITS FORMAT -C ---- --------- ----------------- ------------- -C 1 SEA-LEVEL PRESSURE 0.1 MILLIBARS REAL -C 2 STATION PRESSURE 0.1 MILLIBARS REAL -C 3 WIND DIRECTION DEGREES REAL -C 4 WIND SPEED KNOTS REAL -C 5 AIR TEMPERATURE 0.1 DEGREES C REAL -C 6 DEWPOINT DEPRESSION 0.1 DEGREES C REAL -C 7 MAXIMUM TEMPERATURE 0.1 DEGREES C REAL -C 8 MINIMUM TEMPERATURE 0.1 DEGREES C REAL -C 9 QUALITY MARKERS: EACH 1-CHARACTER CHAR*8 -C LEFT-JUSTIFIED -C S-LEVEL PRESS. ON124 TABLE SM.51 -C STATION PRESS. ON124 TABLE SM.51 -C WIND ON124 TABLE SM.51 -C AIR TEMPERATURE ON124 TABLE SM.51 -C 10 QUALITY MARKERS: EACH 1-CHARACTER CHAR*8 -C LEFT-JUSTIFIED -C DEWPOINT DEPR. ON124 TABLE SM.51 -C NOT USED BLANK -C NOT USED BLANK -C NOT USED BLANK -C 11 HORIZ. VISIBILITY WMO CODE TABLE 4300 INTEGER -C 12 PRESENT WEATHER WMO CODE TABLE 4677 INTEGER -C 13 PAST WEATHER WMO CODE TABLE 4561 INTEGER -C 14 TOTAL CLOUD COVER N WMO CODE TABLE 2700 INTEGER -C 15 CLOUD COVER OF C/LN WMO CODE TABLE 2700 INTEGER -C 16 CLOUD TYPE OF C/L WMO CODE TABLE 0513 INTEGER -C 17 CLOUD HEIGHT OF C/L WMO CODE TABLE 1600 INTEGER -C 18 CLOUD TYPE OF C/M WMO CODE TABLE 0515 INTEGER -C 19 CLOUD TYPE OF C/H WMO CODE TABLE 0509 INTEGER -C 20 CHARACTERISTIC OF WMO CODE TABLE 0200 INTEGER -C 3-HR PRESS TENDENCY -C 21 AMT. PRESS TENDENCY 0.1 MILLIBARS REAL -C (50.0 WILL BE ADDED TO INDICATE 24-HR TENDENCY) -C -C CATEGORY 52 - ADDITIONAL SURFACE DATA -C WORD PARAMETER UNITS FORMAT -C ---- --------- ----------------- ------------- -C 1 6-HR PRECIPITATION 0.01 INCH INTEGER -C 2 SNOW DEPTH INCH INTEGER -C 3 24-HR PRECIPITATION 0.01 INCH INTEGER -C 4 DURATION OF PRECIP. NO. 6-HR PERIODS INTEGER -C 5 PERIOD OF WAVES SECONDS INTEGER -C 6 HEIGHT OF WAVES 0.5 METERS INTEGER -C 7 SWELL DIRECTION WMO CODE TABLE 0877 INTEGER -C 8 SWELL PERIOD SECONDS INTEGER -C 9 SWELL HEIGHT 0.5 METERS INTEGER -C 10 SEA SFC TEMPERATURE 0.1 DEGREES C INTEGER -C 11 SPECIAL PHEN, GEN'L INTEGER -C 12 SPECIAL PHEN, DET'L INTEGER -C 13 SHIP'S COURSE WMO CODE TABLE 0700 INTEGER -C 14 SHIP'S AVERAGE SPEED WMO CODE TABLE 4451 INTEGER -C 15 WATER EQUIVALENT OF 0.01 INCH INTEGER -C SNOW AND/OR ICE -C -C CATEGORY 9 - PLAIN LANGUAGE DATA (ALPHANUMERIC TEXT) -C WORD BYTES PARAMETER FORMAT -C ---- ----- --------------------------------------- -------- -C 1 1 INDICATOR OF CONTENT (ON124 TABLE SM.9) CHAR*8 -C (1 CHARACTER) -C 2-4 PLAIN LANGUAGE DATA, TEXT CHARACTERS 1-3 -C 4-8 NOT USED (BLANK) -C 2 1-4 PLAIN LANGUAGE DATA, TEXT CHARACTERS 4-7 CHAR*8 -C 4-8 NOT USED (BLANK) -C 3 1-4 PLAIN LANGUAGE DATA, TEXT CHARACTERS 8-11 CHAR*8 -C 4-8 NOT USED (BLANK) -C -C ONE REPORT MAY UNPACK INTO MORE THAN ONE CATEGORY HAVING -C MULTIPLE LEVELS. THE UNUSED PORTION OF LOCRPT IS NOT CLEARED. -C -C NOTE: ENTRY W3AI02 DUPLICATES PROCESSING IN W3FI64 SINCE NO -C ASSEMBLY LANGUAGE CODE IN CRAY W3LIB. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/864 -C -C$$$ -C - CHARACTER*12 HOLD - CHARACTER*10 COCBUF(*) - CHARACTER*7 CNINES - CHARACTER*4 COCRPT(10000),BLANK - CHARACTER*2 KAT(11) -C - INTEGER LOCRPT(*),KATGC(20,11),KATGL(20,11),KATL(11),KATO(11), - $ MOCRPT(5000) -C - REAL ROCRPT(5000) -C - EQUIVALENCE (ROCRPT,MOCRPT,COCRPT) -C - SAVE -C - DATA BLANK/' '/,CNINES/'9999999'/,IMSG/99999/,XMSG/99999./ - DATA KATL/6,4,4,4,6,6,3,3,1,20,15/,KATO/13,15,17,19,21,23,25,27, - $ 33,29,31/,IREC/2/ - DATA KAT/'01','02','03','04','05','06','07','08','09','51','52'/ - DATA KATGC/ 5*2,4,14*0, 3*2,4,16*0, 3*2,4,16*0, 3*2,4,16*0, - $ 5*2,4,14*0, 5*2,4,14*0, 2*2,4,17*0, 2*2,4,17*0, 4,19*0, - $ 8*2,4,10*1,2, 15*1,5*0/ - DATA KATGL/ 5,4,3*3,4,14*0, 5,4,2*3,16*0, 5,2*3,2,16*0, - $ 5,2*3,2,16*0, 5,4,3*3,4,14*0, 5,4,3*3,4,14*0, 5,3,2,17*0, - $ 5,3,2,17*0, 12,19*0, - $ 2*5,2*3,4,3,2*4,5,2*3,7*2,1,3, 4,3,4,1,5*2,4,2*2,1,2,7,5*0/ - DATA LWFLAG/0/ -C - ENTRY W3AI02(COCBUF,LOCRPT,NEXT) -C - IF (LWFLAG.EQ.0) THEN -C FIRST TIME CALLED, DETERMINE MACHINE WORD LG IN BYTES (=8 FOR CRAY) -C DEPENDING ON WORD SIZE LW2*I-LW1 INDEXES THRU COCRPT -C EITHER AS 1,2,3...I FOR LW = 4 OR -C AS 1,3,5..2*I-1 FOR LW = 8 <------ HERE -C NECESSITATED BY LEFT JUSTIFICATION OF EQUIVALENCE - CALL W3FI01(LW) - LW2 = LW/4 - LW1 = LW/8 - LWFLAG = 1 - END IF - 7000 CONTINUE - IF(NEXT.LT.0) RETURN - NEXTO = NEXT/10 - N = NEXT/10 + 1 -C - IF(COCBUF(N).EQ.'END RECORD'.OR.COCBUF(N).EQ.'XXXXXXXXXX') THEN -C HIT END-OF-RECORD; RETURN WITH NEXT = -1 - IF(COCBUF(N).EQ.'XXXXXXXXXX') PRINT 109, IREC - IREC = IREC + 1 - NEXT = -1 - RETURN - END IF -C INITIALIZE REPORT ID AS MISSING OR 0 FOR RESERVED WORDS - ROCRPT(1) = XMSG - ROCRPT(2) = XMSG - ROCRPT(3) = 0. - ROCRPT(4) = XMSG - COCRPT(LW2*5-LW1) = ' ' - COCRPT(LW2*6-LW1) = ' ' - ROCRPT(7) = XMSG - MOCRPT(8) = 99 - MOCRPT(9) = IMSG - MOCRPT(10) = 0. - COCRPT(LW2*11-LW1) = ' ' - COCRPT(LW2*12-LW1) = ' ' -C INITIALIZE CATEGORY WORD PAIRS AS ZEROES - DO 100 MB = 13,42 - MOCRPT(MB) = 0 - 100 CONTINUE -C WRITE OUT LATITUDE INTO WORD 1 (REAL) - M = 1 - IF(COCBUF(N)(1:5).NE.'99999') READ(COCBUF(N)(1:5),51) ROCRPT(M) -C WRITE OUT LONGITUDE INTO WORD 2 (REAL) - M = 2 - IF(COCBUF(N)(6:10).NE.'99999') READ(COCBUF(N)(6:10),51) ROCRPT(M) -C WORD 3 IS RESERVED (KEEP AS A REAL NUMBER OF 0.) -C WRITE OUT STATION ID TO WORDS 11 AND 12 (CHAR*8) -C (CHAR. 1-4 OF ID IN WORD 11, CHAR. 5-6 OF ID IN WORD 12, LEFT-JUSTIF.) - M = 11 - N = N + 1 - COCRPT(LW2*M-LW1) = COCBUF(N)(1:4) - M = 12 - COCRPT(LW2*M-LW1) = COCBUF(N)(5:6)//' ' -C WRITE OUT OBSERVATION TIME INTO WORD 4 (REAL) - M = 4 - IF(COCBUF(N)(7:10).NE.'9999') READ(COCBUF(N)(7:10),41) ROCRPT(M) -C WORD 5 IS RESERVED (CHAR*8) (4 CHARACTERS, LEFT-JUSTIF.) - M = 5 - N = N + 1 - COCRPT(LW2*M-LW1) = COCBUF(N)(3:6) -C WORD 6 IS RESERVED (CHAR*8) (3 CHARACTERS, LEFT-JUSTIF.) - M = 6 - COCRPT(LW2*M-LW1) = COCBUF(N)(1:2)//COCBUF(N)(7:7)//' ' -C WRITE OUT REPORT TYPE INTO WORD 9 (INTEGER) - M = 9 - READ(COCBUF(N)(8:10),30) MOCRPT(M) -C WRITE OUT STATION ELEVATION INTO WORD 7 (REAL) - N = N + 1 - M = 7 - IF(COCBUF(N)(1:5).NE.'99999') READ(COCBUF(N)(1:5),51) ROCRPT(M) -C WRITE OUT INSTRUMENT TYPE INTO WORD 8 (INTEGER) - M = 8 - IF(COCBUF(N)(6:7).NE.'99') READ(COCBUF(N)(6:7),20) MOCRPT(M) -C READ IN NWDS, THE TOTAL NO. OF 10-CHARACTER WORDS IN ENTIRE REPORT - READ(COCBUF(N)(8:10),30) NWDS -C 'MO' WILL BE STARTING LOCATION IN MOCRPT FOR THE DATA - MO = 43 - N = N + 1 - 700 CONTINUE - IF(COCBUF(N).EQ.'END REPORT') THEN -C----------------------------------------------------------------------- -C HAVE HIT THE END OF THE REPORT - IF(N-NEXTO.EQ.NWDS) THEN -C EVERYTHING LOOKS GOOD, RETURN WITH NEXT SET TO LAST BYTE IN REPORT - NEXT = N * 10 - ELSE -C PROBLEM, MAY EXIT WITH NEXT = -3 - NEXTX = -3 - PRINT 101, - & COCRPT(LW2*11-LW1),COCRPT(LW2*12-LW1)(1:2),N-NEXTO,NWDS - GO TO 99 - END IF - MWORDS = MO - 1 - DO 1001 I =1, MWORDS - LOCRPT(I) = MOCRPT(I) - 1001 CONTINUE - RETURN -C----------------------------------------------------------------------- - END IF -C READ IN NWDSC, THE RELATIVE POSITION IN RPT OF THE NEXT CATEGORY - READ(COCBUF(N)(3:5),30) NWDSC -C READ IN LVLS, THE NUMBER OF LEVELS IN THE CURRENT CATEGORY - READ(COCBUF(N)(6:7),20) LVLS -C DETERMINE THE CATEGORY NUMBER OF THE CURRENT CATEGORY - DO 800 NCAT = 1,11 - IF(COCBUF(N)(1:2).EQ.KAT(NCAT)) GO TO 1000 - 800 CONTINUE -C----------------------------------------------------------------------- -C PROBLEM, CAT. CODE IN INPUT NOT VALID; MAY EXIT WITH NEXT = -2 - NEXTX = -2 - PRINT 102, - $ COCRPT(LW2*11-LW1),COCRPT(LW2*12-LW1)(1:2),COCBUF(N)(1:2) - GO TO 99 -C----------------------------------------------------------------------- - 1000 CONTINUE -C 'M' IS THE WORD IN MOCRPT WHERE THE NO. OF LEVELS WILL BE WRITTEN - M = KATO(NCAT) -C WRITE THIS CATEGORY WORD PAIR OUT - MOCRPT(M) = LVLS - MOCRPT(M+1) = MO - N = N + 1 - I = 1 -C*********************************************************************** -C LOOP THROUGH ALL THE LEVELS IN THE CURRENT CATEGORY -C*********************************************************************** - DO 2000 L = 1,LVLS -C NDG IS NO. OF OUTPUT PARAMETERS PER LEVEL IN THIS CATEGORY - NDG = KATL(NCAT) -C----------------------------------------------------------------------- -C LOOP THROUGH ALL THE PARAMETERS IN THE CURRENT LEVEL -C----------------------------------------------------------------------- - DO 1800 K = 1,NDG -C 'LL' IS THE NUMBER OF INPUT CHARACTERS PER PARAMETER FOR THIS CATEGORY - LL = KATGL(K,NCAT) -C 'I' IS POINTER FOR BEGINNING BYTE IN C*10 WORD FOR NEXT PARAMETER -C 'J' IS POINTER FOR ENDING BYTE IN C*10 WORD FOR NEXT PARAMETER - J = I + LL - 1 - IF(J.GT.10) THEN -C COME HERE IF INPUT PARAMETER SPANS ACROSS TWO C*10 WORDS - HOLD(1:LL) = COCBUF(N)(I:10)//COCBUF(N+1)(1:J-10) - N = N + 1 - I = J - 9 - IF(I.GE.11) THEN - N = N + 1 - I = 1 - END IF - ELSE - HOLD(1:LL) = COCBUF(N)(I:J) - I = J + 1 - IF(I.GE.11) THEN - N = N + 1 - I = 1 - END IF - END IF -C KATGC IS AN INDICATOR FOR THE OUTPUT FORMAT OF EACH INPUT PARAMETER -C (=2 - REAL, =1 - INTEGER, =4 - CHARACTER*8) - IF(KATGC(K,NCAT).EQ.4) GO TO 1500 - IF(KATGC(K,NCAT).NE.1.AND.KATGC(K,NCAT).NE.2) THEN -C....................................................................... -C PROBLEM IN INTERNAL READ; MAY EXIT WITH NEXT = -2 - NEXTX = -2 - PRINT 104, COCRPT(LW2*11-LW1),COCRPT(LW2*12)(1:2) - GO TO 99 -C....................................................................... - END IF - IF(HOLD(1:LL).EQ.CNINES(1:LL)) THEN -C INPUT PARAMETER IS MISSING OR NOT APPLICABLE -- OUTPUT IT AS SUCH - IF(KATGC(K,NCAT).EQ.1) MOCRPT(MO) = IMSG - IF(KATGC(K,NCAT).EQ.2) ROCRPT(MO) = XMSG - GO TO 1750 - END IF - IF(LL.EQ.1) THEN -C INPUT PARAMETER CONSISTS OF ONE CHARACTER - IF(KATGC(K,NCAT).EQ.1) READ(HOLD(1:LL),10) MOCRPT(MO) - IF(KATGC(K,NCAT).EQ.2) READ(HOLD(1:LL),11) ROCRPT(MO) - ELSE IF(LL.EQ.2) THEN -C INPUT PARAMETER CONSISTS OF TWO CHARACTERS - IF(KATGC(K,NCAT).EQ.1) READ(HOLD(1:LL),20) MOCRPT(MO) - IF(KATGC(K,NCAT).EQ.2) READ(HOLD(1:LL),21) ROCRPT(MO) - ELSE IF(LL.EQ.3) THEN -C INPUT PARAMETER CONSISTS OF THREE CHARACTERS - IF(KATGC(K,NCAT).EQ.1) READ(HOLD(1:LL),30) MOCRPT(MO) - IF(KATGC(K,NCAT).EQ.2) READ(HOLD(1:LL),31) ROCRPT(MO) - ELSE IF(LL.EQ.4) THEN -C INPUT PARAMETER CONSISTS OF FOUR CHARACTERS - IF(KATGC(K,NCAT).EQ.1) READ(HOLD(1:LL),40) MOCRPT(MO) - IF(KATGC(K,NCAT).EQ.2) READ(HOLD(1:LL),41) ROCRPT(MO) - ELSE IF(LL.EQ.5) THEN -C INPUT PARAMETER CONSISTS OF FIVE CHARACTERS - IF(KATGC(K,NCAT).EQ.1) READ(HOLD(1:LL),50) MOCRPT(MO) - IF(KATGC(K,NCAT).EQ.2) READ(HOLD(1:LL),51) ROCRPT(MO) - ELSE IF(LL.EQ.6) THEN -C INPUT PARAMETER CONSISTS OF SIX CHARACTERS - IF(KATGC(K,NCAT).EQ.1) READ(HOLD(1:LL),60) MOCRPT(MO) - IF(KATGC(K,NCAT).EQ.2) READ(HOLD(1:LL),61) ROCRPT(MO) - ELSE IF(LL.EQ.7) THEN -C INPUT PARAMETER CONSISTS OF SEVEN CHARACTERS - IF(KATGC(K,NCAT).EQ.1) READ(HOLD(1:LL),70) MOCRPT(MO) - IF(KATGC(K,NCAT).EQ.2) READ(HOLD(1:LL),71) ROCRPT(MO) - ELSE -C....................................................................... -C INPUT PARAMETER CONSISTS OF MORE THAN SEVEN CHARACTERS (NOT PERMITTED) - NEXTX = -2 - PRINT 108, COCRPT(LW2*11-LW1),COCRPT(LW2*12-LW1)(1:2) - GO TO 99 -C....................................................................... - END IF - GO TO 1750 - 1500 CONTINUE -C....................................................................... -C OUTPUT CHARACTER (MARKER) PROCESSING COMES HERE - IF(LL.LT.4) THEN -C THERE ARE ONE, TWO OR THREE MARKERS IN THE INPUT WORD - COCRPT(LW2*MO-LW1)(1:4)=HOLD(1:LL)//BLANK(1:4-LL) - ELSE IF(LL.EQ.4) THEN -C THERE ARE FOUR MARKERS IN THE INPUT WORD - COCRPT(LW2*MO-LW1)(1:4) = HOLD(1:LL) - ELSE -C THERE ARE MORE THAN FOUR MARKERS IN THE INPUT WORD - IP = 1 - 1610 CONTINUE - JP = IP + 3 - IF(JP.LT.LL) THEN -C FILL FIRST FOUR MARKERS TO OUTPUT WORD - COCRPT(LW2*MO-LW1)(1:4) = HOLD(IP:JP) - MO = MO + 1 - IP = JP + 1 - GO TO 1610 - ELSE IF(JP.EQ.LL) THEN -C FILL FOUR REMAINING MARKERS TO NEXT OUTPUT WORD - COCRPT(LW2*MO-LW1)(1:4) = HOLD(IP:JP) - ELSE -C FILL ONE, TWO, OR THREE REMAINING MARKERS TO NEXT OUTPUT WORD - COCRPT(LW2*MO-LW1)(1:4) = HOLD(IP:LL)//BLANK(1:JP-LL) - END IF - END IF -C....................................................................... - 1750 CONTINUE - MO = MO + 1 - 1800 CONTINUE -C----------------------------------------------------------------------- - 2000 CONTINUE -C*********************************************************************** - IF(I.GT.1) N = N + 1 - IF(N-NEXTO.NE.NWDSC) THEN -C----------------------------------------------------------------------- -C PROBLEM, REL. LOCATION OF NEXT CAT. NOT WHAT'S EXPECTED; MAY EXIT -C WITH NEXT = -3 -C ERROR - RELATIVE LOCATION OF NEXT CATEGORY NOT WHAT'S EXPECTED - NEXTX = -3 - PRINT 105, COCRPT(LW2*11-LW1),COCRPT(LW2*12-LW1)(1:2), - $ KAT(NCAT),N-NEXTO-1, - $ NWDSC-1 - GO TO 99 -C----------------------------------------------------------------------- - END IF -C GO ON TO NEXT CATEGORY - GO TO 700 -C----------------------------------------------------------------------- -C ALL OF THE PROBLEM REPORTS END UP HERE -- ATTEMPT TO MOVE AHEAD TO -C NEXT REPORT, IF NOT POSSIBLE THEN EXIT WITH NEXT = -2 OR -3 MEANING -C THE REST OF THE RECORD IS BAD, GO ON TO NEXT RECORD - 99 CONTINUE - DO 98 I = 1,644 - N = N + 1 - IF(N.GT.644) GO TO 97 - IF(COCBUF(N).EQ.'END RECORD') GO TO 97 - IF(COCBUF(N).EQ.'END REPORT') THEN -C WE'VE MADE IT TO THE END OF THIS PROBLEM REPORT - START OVER WITH -C NEXT ONE - PRINT 106 - NEXT = N * 10 - GO TO 7000 - END IF - 98 CONTINUE - 97 CONTINUE -C COULDN'T GET TO THE END OF THIS PROBLEM REPORT - RETURN WITH ORIGINAL -C NEXT VALUE (-2 OR -3) MEANING USER MUST GO ON TO NEXT RECORD - NEXT = NEXTX - PRINT 107, NEXT - MWORDS = MO - 1 - DO 1002 I =1, MWORDS - LOCRPT(I) = MOCRPT(I) - 1002 CONTINUE - RETURN -C----------------------------------------------------------------------- - 10 FORMAT(I1) - 11 FORMAT(F1.0) - 20 FORMAT(I2) - 21 FORMAT(F2.0) - 30 FORMAT(I3) - 31 FORMAT(F3.0) - 40 FORMAT(I4) - 41 FORMAT(F4.0) - 50 FORMAT(I5) - 51 FORMAT(F5.0) - 60 FORMAT(I6) - 61 FORMAT(F6.0) - 70 FORMAT(I7) - 71 FORMAT(F7.0) - 101 FORMAT(/' *** W3FI64 ERROR- REPORT: ',A4,A2,'; ACTUAL NO. 10-CHAR' - $,' WORDS:',I10,' NOT EQUAL TO VALUE READ IN WITH REPORT:',I10/6X, - $ '- MAY BE DUE TO INTERNAL READ PROBLEM ASSOC. W/ EITHER ORIG. ', - $ 'PACKING OR TRANSFER OF FILE RESULTING IN UNPROCESSABLE INFO.'/6X - $,'- WILL ATTEMPT TO MOVE AHEAD TO NEXT REPORT, IF NOT POSSIBLE ', - $ 'WILL EXIT RECORD WITH NEXT = -3'/) - 102 FORMAT(/' *** W3FI64 ERROR- REPORT: ',A4,A2,'; PACKED CATEGORY ' - $,'CODE: ',A2,' IS NOT A VALID O.N. 29 CATEGORY'/6X, - $ '- MAY BE DUE TO INTERNAL READ PROBLEM ASSOC. W/ EITHER ORIG. ', - $ 'PACKING OR TRANSFER OF FILE RESULTING IN UNPROCESSABLE INFO.'/6X - $,'- WILL ATTEMPT TO MOVE AHEAD TO NEXT REPORT, IF NOT POSSIBLE ', - $ 'WILL EXIT RECORD WITH NEXT = -2'/) - 104 FORMAT(/' *** W3FI64 ERROR- REPORT: ',A4,A2,'; INTERNAL READ ', - $ 'PROBLEM'/6X,'- EITHER ORIGINAL PACKING OF FILE OR TRANSFER ', - $ 'OF FILE HAS RESULTED IN UNPROCESSABLE INFORMATION'/6X, - $ '- WILL ATTEMPT TO MOVE AHEAD TO NEXT REPORT, IF NOT POSSIBLE ', - $ 'WILL EXIT RECORD WITH NEXT = -2'/) - 105 FORMAT(/' *** W3FI64 ERROR- REPORT: ',A4,A2,'; ACTUAL NO. 10-CHAR' - $,' WORDS IN CAT. ',A2,',',I10,' .NE. TO VALUE READ IN WITH ', - $ 'REPORT:',I10/6X, - $ '- MAY BE DUE TO INTERNAL READ PROBLEM ASSOC. W/ EITHER ORIG. ', - $ 'PACKING OR TRANSFER OF FILE RESULTING IN UNPROCESSABLE INFO.'/6X - $,'- WILL ATTEMPT TO MOVE AHEAD TO NEXT REPORT, IF NOT POSSIBLE ', - $ 'WILL EXIT RECORD WITH NEXT = -3'/) - 106 FORMAT(/' +++ IT WAS POSSIBLE TO MOVE TO NEXT REPORT IN THIS ', - $ 'RECORD -- CONTINUE WITH THE UNPACKING OF THIS NEW REPORT'/) - 107 FORMAT(/' *** IT WAS NOT POSSIBLE TO MOVE TO NEXT REPORT IN THIS', - $ ' RECORD -- MUST EXIT THIS RECORD WITH NEXT =',I3/) - 108 FORMAT(/' *** W3FI64 ERROR- REPORT: ',A4,A2,'; AN INPUT ', - $ 'PARAMETER CONSISTS OF MORE THAN SEVEN CHARACTERS'/6X, - $ '- MAY BE DUE TO INTERNAL READ PROBLEM ASSOC. W/ EITHER ORIG. ', - $ 'PACKING OR TRANSFER OF FILE RESULTING IN UNPROCESSABLE INFO.'/6X - $,'- WILL ATTEMPT TO MOVE AHEAD TO NEXT REPORT, IF NOT POSSIBLE ', - $ 'WILL EXIT RECORD WITH NEXT = -2'/) - 109 FORMAT(/' *** W3FI64 ERROR- RECORD ',I4,' DOES NOT END WITH ', - $ '"END RECORD" BUT INSTEAD CONTAINS "X" FILLERS AFTER LAST ', - $ 'REPORT IN RECORD'/6X,'- WILL EXIT RECORD WITH NEXT = -1, NO ', - $ 'REPORTS SHOULD BE LOST'/) - END diff --git a/src/fim/FIMsrc/w3/w3fi65.f b/src/fim/FIMsrc/w3/w3fi65.f deleted file mode 100644 index 0eca69e..0000000 --- a/src/fim/FIMsrc/w3/w3fi65.f +++ /dev/null @@ -1,397 +0,0 @@ - SUBROUTINE W3FI65(LOCRPT,COCBUF) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI65 NMC OFFICE NOTE 29 REPORT PACKER -C PRGMMR: KEYSER ORG: NP22 DATE:1998-08-07 -C -C ABSTRACT: PACKS AN ARRAY OF UPPER-AIR REPORTS INTO THE FORMAT -C DESCRIBED BY NMC OFFICE NOTE 29, OR PACKS AN ARRAY OF SURFACE -C REPORTS INTO THE FORMAT DESCRIBED BY NMC OFFICE NOTE 124. INPUT -C INTEGER, REAL OR CHARACTER TYPE AS SPECIFIED IN THE CATEGORY -C TABLES IN THE WRITE-UP FOR W3FI64 (THE OFFICE NOTE 29 REPORT -C PACKER) ARE CONVERTED TO CHARACTER DATA. MISSING CHARACTER DATA -C ARE SPECIFIED AS STRINGS OF 9'S EXCEPT FOR THAT CONVERTED FROM -C INPUT CHARACTER TYPE WHICH ARE GENERALLY SPECIFIED AS BLANKS. -C THIS LIBRARY IS SIMILAR TO W3AI03 EXCEPT W3AI03 WAS WRITTEN IN -C ASSEMBLER. -C -C PROGRAM HISTORY LOG: -C 1990-01-?? L. MARX, UNIV. OF MD -- CONVERTED CODE FROM ASSEMBLER -C TO VS FORTRAN -C 1991-08-23 D. A. KEYSER, NMC22 -- USE SAME ARGUMENTS AS W3AI03; -C STREAMLINED CODE; DOCBLOCKED AND COMMENTED -C 1992-06-29 D. A. KEYSER W/NMC22 -- CONVERT TO CRAY CFT77 FORTRAN -C 1992-07-09 D. A. KEYSER, NMC22 -- CHECKS THE NUMBER OF CHARACTERS -C USED BY EACH VARIABLE PRIOR TO CONVERSION FROM -C INTEGER TO CHARACTER FORMAT; IF THIS NUMBER IS -C GREATER THAN THE NUMBER OF CHARACTERS ALLOCATED FOR -C THE VARIABLE THE VARIABLE IS PACKED AS "MISSING" -C (I.E., STORES AS ALL 9'S) -C 1993-06-28 D. A. KEYSER, NMC22 -- INITIALIZES NUMBER OF WORDS IN -C REPORT TO 42 IN CASE "STRANGE" REPORT WITH NO DATA -C IN ANY CATEGORY ENCOUNTERED (USED TO BE ZERO, BUT -C SUCH "STRANGE" REPORTS CAUSED CODE TO FAIL) -C 1993-12-22 D. A. KEYSER, NMC22 -- CORRECTED ERROR WHICH RESULTED -C IN STORAGE OF 0'S IN PLACE OF ACTUAL DATA IN A -C CATEGORY WHEN THAT CATEGORY WAS THE ONLY ONE WITH -C DATA -C 1998-08-07 D. A. KEYSER, NP22 -- FORTRAN 90-COMPLIANT - SPLIT AN -C IF STATEMENT INTO 2-PARTS TO PREVENT F90 FLOATING -C POINT EXCEPTION ERROR THAT CAN NOW OCCUR IN SOME -C CASES (DID NOT OCCUR IN F77) -C -C USAGE: CALL W3FI65(LOCRPT,COCBUF) -C INPUT ARGUMENT LIST: -C LOCRPT - INTEGER ARRAY CONTAINING ONE UNPACKED REPORT. -C - LOCRPT MUST BEGIN ON A FULLWORD BOUNDARY. FORMAT -C - IS MIXED, USER MUST EQUIVALENCE REAL AND CHARACTER -C - ARRAYS TO THIS ARRAY (SEE W3FI64 WRITE-UP FOR -C - CONTENT). -C -C OUTPUT ARGUMENT LIST: -C COCBUF - CHARACTER*10 ARRAY CONTAINING A PACKED REPORT IN -C - NMC OFFICE NOTE 29/124 FORMAT. -C -C -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - W3FI01 -C -C -C REMARKS: AFTER FIRST CREATING AND WRITING OUT THE OFFICE NOTE 85 -C (FIRST) DATE RECORD, THE USER'S FORTRAN PROGRAM BEGINS A PACKING -C LOOP AS FOLLOWS.. EACH ITERATION OF THE PACKING LOOP CONSISTS OF -C A CALL FIRST TO W3FI65 TO PACK THE REPORT INTO COCBUF, THEN A CALL -C TO W3FI66 WITH THE CURRENT VALUE OF 'NFLAG' (SET TO ZERO FOR FIRST -C CALL) TO BLOCK THE PACKED REPORT INTO A RECORD (SEE W3FI66 WRITE- -C UP). IF 'NFLAG' IS -1 UPON RETURNING FROM W3FI66, THE REMAINING -C PORTION OF THE RECORD IS NOT LARGE ENOUGH TO HOLD THE CURRENT -C PACKED REPORT. THE USER SHOULD WRITE OUT THE RECORD, SET 'NFLAG' -C TO ZERO, CALL W3FI66 TO WRITE THE PACKED REPORT TO THE BEGINNING -C OF THE NEXT RECORD, AND REPEAT THE PACKING LOOP. IF 'NFLAG' IS -C POSITIVE, A PACKED REPORT HAS BEEN BLOCKED INTO THE RECORD AND -C THE USER SHOULD CONTINUE THE PACKING LOOP. -C WHEN ALL REPORTS HAVE BEEN PACKED AND BLOCKED, THE USER -C SHOULD WRITE OUT THIS LAST RECORD (WHICH IS NOT FULL BUT CONTAINS -C FILL INFORMATION SUPPLIED BY W3FI66). ONE FINAL RECORD CONTAINING -C THE STRING 'ENDOF FILE' (SIC) FOLLOWED BY BLANK FILL MUST BE -C WRITTEN OUT TO SIGNAL THE END OF THE DATA SET. -C -C NOTE1: THE PACKED REPORT WILL HAVE THE CATEGORIES ORDERED AS -C FOLLOWS: 1, 2, 3, 4, 5, 6, 7, 51, 52, 8, 9. -C NOTE2: THE INPUT UNPACKED REPORT MUST BE IN THE FORMAT SPEC- -C IFIED IN THE W3FI64 OFFICE NOTE 29 REPORT UNPACKER WRITE-UP. -C NOTE3: THE UNUSED PORION OF COCBUF IS NOT CLEARED. -C -C NOTE: ENTRY W3AI03 DUPLICATES PROCESSING IN W3FI65 SINCE NO -C ASSEMBLY LANGUAGE CODE IN CRAY W3LIB. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: CRAY, SGI -C -C$$$ -C - CHARACTER*12 HOLD - CHARACTER*10 COCBUF(*),FILL - CHARACTER*7 CNINES - CHARACTER*4 COCRPT(10000) - CHARACTER*2 KAT(11) -C - INTEGER LOCRPT(*),KATL(11),KATO(11),KATGC(20,11),KATGL(20,11), - $ MOCRPT(5000),KATLL(11) -C - REAL ROCRPT(5000) -C - EQUIVALENCE (ROCRPT,MOCRPT,COCRPT) -C - SAVE -C - DATA KATL/6,4,4,4,6,6,3,20,15,3,1/,KATO/13,15,17,19,21,23,25,29, - $ 31,27,33/,IMSG/99999/,FILL/'XXXXXXXXXX'/,KAT/'01','02','03','04', - $'05','06','07','51','52','08','09'/,CNINES/'9999999'/,XMSG/99999./ - DATA KATGC/ 5*2,4,14*0, 3*2,4,16*0, 3*2,4,16*0, 3*2,4,16*0, - $ 5*2,4,14*0, 5*2,4,14*0, 2*2,4,17*0, 8*2,4,10*1,2, 15*1,5*0, - $ 2*2,4,17*0, 4,19*0/ - DATA KATGL/ 5,4,3*3,4,14*0, 5,4,2*3,16*0, 5,2*3,2,16*0, - $ 5,2*3,2,16*0, 5,4,3*3,4,14*0, 5,4,3*3,4,14*0, 5,3,2,17*0, - $ 2*5,2*3,4,3,2*4,5,2*3,7*2,1,3, - $ 4,3,4,1,5*2,4,2*2,1,2,7,5*0, 5,3,2,17*0, 12,19*0/ - DATA KATLL/6,4,4,4,6,6,3,21,15,3,3/ - DATA LWFLAG/0/ -C - ENTRY W3AI03(LOCRPT,COCBUF) -C - IF (LWFLAG.EQ.0) THEN -C FIRST TIME CALLED, DETERMINE MACHINE WORD LG IN BYTES (=8 FOR CRAY) -C DEPENDING ON WORD SIZE LW2*I-LW1 INDEXES THRU COCRPT -C EITHER AS 1,2,3...I FOR LW = 4 OR -C AS 1,3,5..2*I-1 FOR LW = 8 <------ HERE -C NECESSITATED BY LEFT JUSTIFICATION OF EQUIVALENCE - CALL W3FI01(LW) - LW2 = LW/4 - LW1 = LW/8 - LWFLAG = 1 - END IF - MI = 43 - KK = 0 - LVLS = 0 -C DETERMINE THE TRUE NUMBER OF BYTES IN THE INPUT REPORT - DO 100 NCAT = 1,11 - M = KATO(NCAT) - IF(LOCRPT(M+1).GE.MI) KK = NCAT - MI = MAX(MI,LOCRPT(M+1)) - 100 CONTINUE - IF(KK.GT.0) THEN - M = KATO(KK) - LVLS = LOCRPT(M) - END IF -cvvvvvy2k -cdak MBYTES = LW * ((MI - 1) + (LVLS * KATLL(KK))) - MWORDS = (MI - 1) + (LVLS * KATLL(KK)) -C TRANSFER LOCRPT TO MOCRPT IN ORDER TO EQUIVALENCE TO REAL AND CHAR. -cdak CALL XMOVEX(MOCRPT,LOCRPT,MBYTES) - MOCRPT(1:MWORDS) = LOCRPT(1:MWORDS) -caaaaay2k -C INITIALIZE REPORT ID AS MISSING OR NOT APPLICABLE - COCBUF(1) = '9999999999' - COCBUF(2)(7:10) = '9999' - COCBUF(3)(8:10) = '999' - COCBUF(4)(1:7) = '9999999' -C READ IN LATITUDE FROM WORD 1 (REAL) -C WRITE OUT IN FIRST 5 CHARACTERS OF WORD 1 (C*5) - M = 1 - N = 1 - IF(ROCRPT(M).LT.XMSG) THEN - IF(INT(ROCRPT(M)).GE.0) WRITE(COCBUF(N)(1:5),50)INT(ROCRPT(M)) - IF(INT(ROCRPT(M)).LT.0) WRITE(COCBUF(N)(1:5),55)INT(ROCRPT(M)) - END IF -C READ IN LONGITUDE FROM WORD 2 (REAL) -C WRITE OUT IN LAST 5 CHARACTERS OF WORD 1 (C*5) - M = 2 - IF(ROCRPT(M).LT.XMSG) THEN - IF(INT(ROCRPT(M)).GE.0) WRITE(COCBUF(N)(6:10),50)INT(ROCRPT(M)) - IF(INT(ROCRPT(M)).LT.0) WRITE(COCBUF(N)(6:10),55)INT(ROCRPT(M)) - END IF -C READ IN STATION ID FROM WORDS 11 AND 12 (C*8) -C (CHAR. 1-4 OF ID IN WORD 11, CHAR. 5-6 OF ID IN WORD 12, LEFT-JUSTIF.) -C WRITE OUT IN FIRST 6 CHARACTERS OF WORD 2 (C*6) - M = 11 - N = N + 1 - COCBUF(N)(1:6) = COCRPT(LW2*M-LW1)(1:4)// - $ COCRPT(LW2*(M+1)-LW1)(1:2) -C READ IN OBSERVATION TIME FROM WORD 4 (REAL) -C WRITE OUT IN LAST 4 CHARACTERS OF WORD 2 (C*4) - M = 4 - IF(ROCRPT(M).LT.XMSG) WRITE(COCBUF(N)(7:10),40) INT(ROCRPT(M)) -C READ IN RESERVED CHARACTERS FROM WORDS 5 AND 6 (C*8) -C (4 CHAR., LEFT-JUSTIF.) -C WRITE OUT IN FIRST 7 CHARACTERS OF WORD 3 (C*7) - M = 5 - N = N + 1 - COCBUF(N)(1:7) =COCRPT(LW2*(M+1)-LW1)(1:2)// - $ COCRPT(LW2*M-LW1)(1:4)//COCRPT(LW2*(M+1)-LW1)(3:3) -C READ IN OFFICE NOTE 29 REPORT TYPE FROM WORD 9 (INTEGER) -C WRITE OUT IN LAST 3 CHARACTERS OF WORD 3 (C*3) - M = 9 - IF(MOCRPT(M).LT.IMSG) WRITE(COCBUF(N)(8:10),30) MOCRPT(M) -C READ IN STATION ELEVATION FROM WORD 7 (REAL) -C WRITE OUT IN FIRST 5 CHARACTERS OF WORD 4 (C*4) - M = 7 - N = N + 1 - IF(ROCRPT(M).LT.XMSG) THEN - IF(INT(ROCRPT(M)).GE.0) WRITE(COCBUF(N)(1:5),50)INT(ROCRPT(M)) - IF(INT(ROCRPT(M)).LT.0) WRITE(COCBUF(N)(1:5),55)INT(ROCRPT(M)) - END IF -C READ IN INSTRUMENT TYPE FROM WORD 8 (INTEGER) -C WRITE OUT IN NEXT 2 CHARACTERS OF WORD 4 (C*2) - M = 8 - IF(MOCRPT(M).LT.99) WRITE(COCBUF(N)(6:7),20) MOCRPT(M) - NO = N - N = N + 1 -CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -C LOOP THROUGH ALL THE CATEGORIES WHICH HAVE VALID DATA -CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - DO 3000 NCAT = 1,11 -C 'M' IS THE WORD IN MOCRPT WHERE THE NO. OF LEVELS IS READ FROM - M = KATO(NCAT) - LVLS = MOCRPT(M) -C 'MI' IS THE STARTING LOCATION IN MOCRPT FOR READING DATA FROM THIS CAT - MI = MOCRPT(M+1) - IF(LVLS.EQ.0.OR.MI.EQ.0) GO TO 3000 -C CATEGORY WITH VALID CATEGORY ENCOUNTERED - WRITE OUT IN FIRST 2 -C CHARACTERS OF CATEGORY/COUNTER GROUP FOR THIS CATEGORY (C*2) - COCBUF(N)(1:2) = KAT(NCAT) -C NUMBER OF LEVELS WRITTEN OUT TO CHAR. 6 & 7 OF CAT/CNTR GROUP (C*2) - WRITE(COCBUF(N)(6:7),20) LVLS - NC = N - N = N + 1 -C NWDSC COUNTS THE NUMBER OF 10-CHAR. WORDS IN THIS CATEGORY - NWDSC = 1 - I = 1 -C*********************************************************************** -C LOOP THROUGH ALL THE LEVELS IN THE CURRENT CATEGORY -C*********************************************************************** - DO 2000 L = 1,LVLS -C NDG IS NO. OF INPUT PARAMETERS PER LEVEL IN THIS CATEGORY - NDG = KATL(NCAT) -C----------------------------------------------------------------------- -C LOOP THROUGH ALL THE PARAMETERS IN THE CURRENT LEVEL -C----------------------------------------------------------------------- - DO 1800 K = 1,NDG -C 'LL' IS THE NUMBER OF OUTPUT CHARACTERS PER PARAMETER FOR THIS CAT. - LL = KATGL(K,NCAT) -C KATGC IS AN INDICATOR FOR THE INPUT FORMAT OF EACH OUTPUT PARAMETER -C (=2 - REAL, =1 - INTEGER, =4 - CHARACTER*8) - IF(KATGC(K,NCAT).EQ.4) GO TO 1500 -C OUTPUT PARAMETER IS MISSING OR NOT APPLICABLE (BASED ON MISSING INPUT) - IF(KATGC(K,NCAT).EQ.1) THEN - IF(MOCRPT(MI).GE.IMSG) THEN - HOLD(1:LL) = CNINES(1:LL) -C SPECIAL CASE FOR INPUT PARAMETER 15, CAT. 52 -- MISSING IS '0099999' - IF(K.EQ.15.AND.NCAT.EQ.9) HOLD(1:7) = '0099999' - GO TO 1750 - END IF - ELSE IF(KATGC(K,NCAT).EQ.2) THEN - IF(ROCRPT(MI).GE.XMSG) THEN - HOLD(1:LL) = CNINES(1:LL) -C SPECIAL CASE FOR INPUT PARAMETER 15, CAT. 52 -- MISSING IS '0099999' - IF(K.EQ.15.AND.NCAT.EQ.9) HOLD(1:7) = '0099999' - GO TO 1750 - END IF - END IF - IVALUE = MOCRPT(MI) - IF(KATGC(K,NCAT).EQ.2) IVALUE = INT(ROCRPT(MI)) -C INITIALIZE ALL OUTPUT PARAMETERS HERE AS MISSING -C (WILL REMAIN MISSING IF "IVALUE" SOMEHOW WOULD FILL-UP TOO -C MANY CHARACTERS) - HOLD(1:LL) = CNINES(1:LL) - IF(LL.EQ.1) THEN -C OUTPUT PARAMETER CONSISTS OF ONE CHARACTER - IF(IVALUE.LE.9.AND.IVALUE.GE.0) - $ WRITE(HOLD(1:LL),10) IVALUE - ELSE IF(LL.EQ.2) THEN -C OUTPUT PARAMETER CONSISTS OF TWO CHARACTERS - IF(IVALUE.LE.99.AND.IVALUE.GE.-9) THEN - IF(IVALUE.GE.0) WRITE(HOLD(1:LL),20) IVALUE - IF(IVALUE.LT.0) WRITE(HOLD(1:LL),25) IVALUE - END IF - ELSE IF(LL.EQ.3) THEN -C OUTPUT PARAMETER CONSISTS OF THREE CHARACTERS - IF(IVALUE.LE.999.AND.IVALUE.GE.-99) THEN - IF(IVALUE.GE.0) WRITE(HOLD(1:LL),30) IVALUE - IF(IVALUE.LT.0) WRITE(HOLD(1:LL),35) IVALUE - END IF - ELSE IF(LL.EQ.4) THEN -C OUTPUT PARAMETER CONSISTS OF FOUR CHARACTERS - IF(IVALUE.LE.9999.AND.IVALUE.GE.-999) THEN - IF(IVALUE.GE.0) WRITE(HOLD(1:LL),40) IVALUE - IF(IVALUE.LT.0) WRITE(HOLD(1:LL),45) IVALUE - END IF - ELSE IF(LL.EQ.5) THEN -C OUTPUT PARAMETER CONSISTS OF FIVE CHARACTERS - IF(IVALUE.LE.99999.AND.IVALUE.GE.-9999) THEN - IF(IVALUE.GE.0) WRITE(HOLD(1:LL),50) IVALUE - IF(IVALUE.LT.0) WRITE(HOLD(1:LL),55) IVALUE - END IF - ELSE IF(LL.EQ.6) THEN -C OUTPUT PARAMETER CONSISTS OF SIX CHARACTERS - IF(IVALUE.LE.999999.AND.IVALUE.GE.-99999) THEN - IF(IVALUE.GE.0) WRITE(HOLD(1:LL),60) IVALUE - IF(IVALUE.LT.0) WRITE(HOLD(1:LL),65) IVALUE - END IF - ELSE IF(LL.EQ.7) THEN -C OUTPUT PARAMETER CONSISTS OF SEVEN CHARACTERS - IF(IVALUE.LE.9999999.AND.IVALUE.GE.-999999) THEN - IF(IVALUE.GE.0) WRITE(HOLD(1:LL),70) IVALUE - IF(IVALUE.LT.0) WRITE(HOLD(1:LL),75) IVALUE - END IF - END IF - GO TO 1750 - 1500 CONTINUE -C....................................................................... -C INPUT CHARACTER (MARKER) PROCESSING COMES HERE - IF(LL.LE.4) THEN -C THERE ARE BETWEEN ONE AND FOUR MARKERS IN OUTPUT PARAMETER - HOLD(1:LL) = COCRPT(LW2*MI-LW1)(1:LL) - ELSE -C THERE ARE MORE THAN FOUR MARKERS IN OUTPUT PARAMETER - IP = 1 - 1610 CONTINUE - JP = IP + 3 - IF(JP.LT.LL) THEN -C GET FIRST FOUR MARKERS FROM INPUT WORD - HOLD(IP:JP) = COCRPT(LW2*MI-LW1)(1:4) - MI = MI + 1 - IP = JP + 1 - GO TO 1610 - ELSE IF(JP.EQ.LL) THEN -C GET FOUR REMAINING MARKERS FROM NEXT INPUT WORD - HOLD(IP:JP) = COCRPT(LW2*MI-LW1)(1:4) - ELSE -C GET ONE, TWO, OR THREE REMAINING MARKERS FROM NEXT INPUT WORD - HOLD(IP:LL) = COCRPT(LW2*MI-LW1)(1:LL-JP+4) - END IF - END IF -C....................................................................... - 1750 CONTINUE -C 'I' IS POINTER FOR BEGINNING BYTE IN C*10 WORD FOR OUTPUT PARAMETER -C 'J' IS POINTER FOR ENDING BYTE IN C*10 WORD FOR OUTPUT PARAMETER - J = I + LL - 1 - IF(J.GT.10) THEN -C COME HERE IF OUTPUT PARAMETER SPANS ACROSS TWO C*10 WORDS - COCBUF(N)(I:10) = HOLD(1:11-I) - COCBUF(N+1)(1:J-10) = HOLD(12-I:LL) - N = N + 1 - NWDSC = NWDSC + 1 - I = J - 9 - ELSE - COCBUF(N)(I:J) = HOLD(1:LL) - I = J + 1 - IF(I.GE.11) THEN - N = N + 1 - NWDSC = NWDSC + 1 - I = 1 - END IF - END IF -C GO ON TO NEXT INPUT WORD IN THIS LEVEL - MI = MI + 1 - 1800 CONTINUE -C----------------------------------------------------------------------- - 2000 CONTINUE -C*********************************************************************** -C FILL REMAINING PART OF LAST OUTPUT WORD IN THIS CATEGORY WITH X'S - IF(I.GT.1) COCBUF(N)(I:10) = FILL(I:10) -C TOTAL NO. CHARACTERS IN CATEGORY (EXCL. FILLS) (NCHAR) WRITTEN OUT TO -C LAST 3 CHARACTERS OF CATEGORY/COUNTER GROUP (C*3) - NCHAR = ((NWDSC - 1) * 10) + I - 1 - WRITE(COCBUF(NC)(8:10),30) NCHAR - IF(I.GT.1) N = N + 1 -C RELATIVE POSITION IN REPORT OF NEXT CAT/CNTR GROUP (N) WRITTEN OUT TO -C CHAR. 3 - 5 OF CURRENT CATEGORY/COUNTER GROUP (C*3) - WRITE(COCBUF(NC)(3:5),30) N -C GO ON TO THE NEXT CATEGORY - 3000 CONTINUE -CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -C WRITE OUT THE TOTAL LENGTH OF THE REPORT -- NO. OF 10-CHARACTER WORDS -C -- (N) IN LAST THREE CHARACTERS OF WORD 4 (C*3) - WRITE(COCBUF(NO)(8:10),30) N -C WRITE OUT 'END REPORT' TO LOCATE THE END OF THIS REPORT IN THE BLOCK - COCBUF(N) = 'END REPORT' - RETURN - 10 FORMAT(I1.1) - 15 FORMAT(I1.0) - 20 FORMAT(I2.2) - 25 FORMAT(I2.1) - 30 FORMAT(I3.3) - 35 FORMAT(I3.2) - 40 FORMAT(I4.4) - 45 FORMAT(I4.3) - 50 FORMAT(I5.5) - 55 FORMAT(I5.4) - 60 FORMAT(I6.6) - 65 FORMAT(I6.5) - 70 FORMAT(I7.7) - 75 FORMAT(I7.6) - END diff --git a/src/fim/FIMsrc/w3/w3fi66.f b/src/fim/FIMsrc/w3/w3fi66.f deleted file mode 100644 index 7dd01a5..0000000 --- a/src/fim/FIMsrc/w3/w3fi66.f +++ /dev/null @@ -1,134 +0,0 @@ - SUBROUTINE W3FI66(COCBUF,COCBLK,NFLAG,NSIZE) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI66 OFFICE NOTE 29 REPORT BLOCKER -C PRGMMR: KEYSER ORG: NMC22 DATE:92-06-29 -C -C ABSTRACT: BLOCKS REPORTS WHICH HAVE BEEN PACKED INTO NMC OFFICE -C NOTE 29 CHARACTER FORMAT INTO FIXED-LENGTH RECORDS. A REPORT -C CANNOT SPAN TWO RECORDS; IF THERE IS NOT ENOUGH ROOM TO FIT -C THE CURRENT REPORT IN THE RECORD, THE SUBROUTINE RETURNS TO -C THE CALLING PROGRAM WITHOUT ANY MOVEMENT OF DATA. -C -C PROGRAM HISTORY LOG: -C 90-01-?? L. MARX, UNIV. OF MD -- CONVERTED CODE FROM ASSEMBLER -C TO VS FORTRAN; EXPANDED ERROR RETURN CODES IN 'NFLAG' -C 91-08-23 D. A. KEYSER, NMC22 -- USE SAME ARGUMENTS AS W3AI05; -C STREAMLINED CODE; DOCBLOCKED AND COMMENTED; DIAG- -C NOSTIC PRINT FOR ERRORS -C 92-06-29 D. A. KEYSER W/NMC22 -- CONVERT TO CRAY CFT77 FORTRAN -C -C USAGE: CALL W3FI66(COCBUF,COCBLK,NFLAG,NSIZE) -C INPUT ARGUMENT LIST: -C COCBUF - CHARACTER*10 ARRAY CONTAINING A SINGLE PACKED REPORT -C - IN OFFICE NOTE 29/124 FORMAT. -C COCBLK - CHARACTER*10 ARRAY HOLDING A BLOCK OF PACKED REPORTS -C - UP TO AND INCLUDING THE PREVIOUS ONE -C NFLAG - MARKER INDICATING RELATIVE LOCATION (IN BYTES) -C - OF END OF LAST REPORT IN COCBLK. EXCEPTION: -C - NFLAG MUST BE SET TO ZERO PRIOR TO BLOCKING THE FIRST -C - PACKED REPORT INTO A NEW BLOCK. SUBSEQUENTLY, THE -C - VALUE OF NFLAG RETURNED BY THE PREVIOUS CALL TO W3FI66 -C - SHOULD BE USED AS INPUT. (SEE OUTPUT ARGUMENT LIST -C - BELOW.) IF NFLAG IS NEGATIVE, W3FI66 WILL RETURN -C - IMMEDIATELY WITHOUT ACTION. -C NSIZE - MAXIMUM NUMBER OF CHARACTERS IN COCBLK ARRAY -C (SHOULD BE A MULTIPLE OF 4) -C -C OUTPUT ARGUMENT LIST: -C COCBLK - CHARACTER*10 ARRAY HOLDING A BLOCK OF PACKED REPORTS -C - UP TO AND INCLUDING THE CURRENT ONE -C NFLAG - MARKER INDICATING RELATIVE LOCATION (IN BYTES) -C - OF END OF CURRENT REPORT IN COCBLK. NFLAG -C - WILL BE SET TO -1 IF W3FI66 CANNOT FIT THE CURRENT -C - PACKED REPORT INTO THE REMAINDER OF THE BLOCK (I.E., -C - THE BLOCK IS FULL). NFLAG WILL NOT CHANGE FROM ITS -C - INPUT ARGUMENT VALUE IF THE STRING "END REPORT" IS -C - NOT FOUND AT THE END OF THE CURRENT REPORT. (CURRENT -C - PACKED REPORT HAS INVALID LENGTH AND IS NOT BLOCKED) -C -C OUTPUT FILES: -C FT06F001 - PRINTOUT -C -C REMARKS: THE USER MUST SET NFLAG TO ZERO EACH TIME THE ARRAY IS -C TO BE FILLED WITH PACKED REPORTS IN OFFICE NOTE 29/124 FORMAT. -C W3FI66 WILL THEN INSERT THE FIRST REPORT AND FILL THE REMAINDER -C OF THE OUTPUT ARRAY COCBLK WITH THE STRING 'END RECORD'. -C AN ATTEMPT IS MADE TO INSERT A REPORT IN THE OUTPUT ARRAY -C EACH TIME W3FI66 IS CALLED. IF THE REMAINING PORTION OF THE -C OUTPUT ARRAY IS NOT LARGE ENOUGH TO HOLD THE CURRENT REPORT, -C W3FI66 SETS NFLAG TO -1. THE USER SHOULD THEN OUTPUT THE -C BLOCKED RECORD, SET NFLAG TO ZERO, AND CALL W3FI66 AGAIN WITH -C THE SAME REPORT IN THE INPUT ARRAY. -C AFTER A GIVEN REPORT IS SUCCESSFULLY BLOCKED INTO COCBLK, -C W3FI66 SETS NFLAG AS A POINTER FOR THE NEXT REPORT TO BE BLOCKED. -C THIS POINTER IS A RELATIVE ADDRESS AND A CHARACTER COUNT. -C THE THREE CHARACTERS SPECIFYING THE LENGTH OF THE REPORT -C ARE CHECKED FOR VALID CHARACTER NUMBERS AND THE VALUE IS TESTED -C FOR POINTING TO THE END OF THE REPORT (STRING "END REPORT"). IF -C INVALID, THE REPORT IS NOT INSERTED INTO THE BLOCK AND THERE IS -C AN IMMEDIATE RETURN TO THE USER. IN THIS CASE, THE VALUE OF -C NFLAG DOES NOT CHANGE FROM ITS INPUT VALUE. -C -C NOTE: ENTRY W3AI05 DUPLICATES PROCESSING IN W3FI66 SINCE NO -C ASSEMBLY LANGUAGE CODE IN CRAY W3LIB. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - CHARACTER*10 COCBUF(*),COCBLK(*) -C - SAVE -C - ENTRY W3AI05(COCBUF,COCBLK,NFLAG,NSIZE) -C - IF (NFLAG.LT.0) THEN - PRINT 101 - RETURN - END IF -C N10WRD IS THE MAXIMUM NUMBER OF 10-CHARACTER WORDS AVAILABLE IN BLOCK - N10WRD = NSIZE/10 -C----------------------------------------------------------------------- - IF (NFLAG.EQ.0) THEN -C 1ST TIME INTO NEW BLOCK, INTIALIZE ALL 10-CHAR. WORDS AS 'END RECORD' - DO 25 M = 1,N10WRD - COCBLK(M) = 'END RECORD' - 25 CONTINUE - END IF -C----------------------------------------------------------------------- -C READ IN THE NUMBER OF 10-CHARACTER WORDS IN THIS REPORT (NWDS) - READ(COCBUF(4)(8:10),30) NWDS - 30 FORMAT(I3) -C NOW GET THE NUMBER OF CHARACTERS IN THIS REPORT (NCHARS) - NCHARS = NWDS * 10 -C N01BYT IS THE MAXIMUM NUMBER OF CHARACTERS AVAILABLE FOR DATA IN BLOCK - N01BYT = (N10WRD * 10) - 10 - IF (NFLAG+NCHARS.GT.N01BYT) THEN -C THE REMAINING PORTION OF THE BLOCK IS NOT LARGE ENOUGH TO HOLD THIS -C REPORT, RETURN WITH NFLAG = -1 - NFLAG = -1 - RETURN - END IF - IF (COCBUF(NWDS).NE.'END REPORT') THEN -C LAST 10-CHARACTER WORD IN REPORT IS NOT SET TO THE STRING "END REPORT" -C -- INVALID RPT LENGTH, NOTE THIS AND RETURN TO USER W/O BLOCKING RPT - PRINT 102, COCBUF(2)(1:6) - RETURN - END IF -C TRANSFER PACKED REPORT INTO BLOCK - DO 100 N = 1,NWDS - COCBLK((NFLAG/10)+N) = COCBUF(N) - 100 CONTINUE -C RESET NFLAG - NFLAG = NFLAG + (NWDS * 10) - RETURN - 101 FORMAT(/' *** W3FI66 ERROR- INPUT ARGUMENT "NEXT" (NFLAG) IS ', - $ 'LESS THAN ZERO - RECORD IS FULL, WRITE IT OUT AND START FILLING' - $,' A NEW RECORD WITH CURRENT REPORT'/) - 102 FORMAT(/' *** W3FI66 ERROR- REPORT: ',A6,' DOES NOT END WITH THE', - $ ' STRING "END REPORT" - INVALID REPORT LENGTH'/6X,'- CODE WILL ', - $ 'MOVE AHEAD TO NEXT REPORT WITHOUT BLOCKING THIS REPORT'/) - END diff --git a/src/fim/FIMsrc/w3/w3fi67.f b/src/fim/FIMsrc/w3/w3fi67.f deleted file mode 100644 index 11268bb..0000000 --- a/src/fim/FIMsrc/w3/w3fi67.f +++ /dev/null @@ -1,2808 +0,0 @@ - SUBROUTINE W3FI67(IPTR,IDENT,MSGA,ISTACK,MSTACK,KDATA,KNR,INDEX) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI67 BUFR MESSAGE DECODER -C PRGMMR: CAVANAUGH ORG: NMC421 DATE:93-04-21 -C -C ABSTRACT: THIS SET OF ROUTINES WILL DECODE A BUFR MESSAGE AND -C PLACE INFORMATION EXTRACTED FROM THE BUFR MESSAGE INTO SELECTED -C ARRAYS FOR THE USER. THOSE ARRAYS ARE DESCRIBED IN THE OUTPUT -C ARGUMENT LIST. THIS ROUTINE DOES NOT INCLUDE IFOD PROCESSING. -C -C PROGRAM HISTORY LOG: -C 88-08-31 CAVANAUGH -C 90-12-07 CAVANAUGH NOW UTILIZING GBYTE ROUTINES TO GATHER -C AND SEPARATE BIT FIELDS. THIS SHOULD IMPROVE -C (DECREASE) THE TIME IT TAKES TO DECODE ANY -C BUFR MESSAGE. HAVE ENTERED CODING THAT WILL -C PERMIT PROCESSING BUFR EDITIONS 1 AND 2. -C IMPROVED AND CORRECTED THE CONVERSION INTO -C IFOD FORMAT OF DECODED BUFR MESSAGES. -C 91-01-18 CAVANAUGH PROGRAM/ROUTINES MODIFIED TO PROPERLY HANDLE -C SERIAL PROFILER DATA. -C 91-04-04 CAVANAUGH MODIFIED TO HANDLE TEXT SUPPLIED THRU -C DESCRIPTOR 2 05 YYY. -C 91-04-17 CAVANAUGH ERRORS IN EXTRACTING AND SCALING DATA -C CORRECTED. IMPROVED HANDLING OF NESTED -C QUEUE DESCRIPTORS IS ADDED. -C 91-05-10 CAVANAUGH - ARRAY 'DATA' HAS BEEN ENLARGED TO REAL*8 -C TO BETTER CONTAIN VERY LARGE NUMBERS MORE -C ACCURATELY. THE PREIOUS SIZE REAL*4 COULD NOT -C CONTAIN SUFFICIENT SIGNIFICANT DIGITS. -C - CODING HAS BEEN INTRODUCED TO PROCESS NEW -C TABLE C DESCRIPTOR 2 06 YYY WHICH PERMITS IN -C LINE PROCESSING OF A LOCAL DESCRIPTOR EVEN IF -C THE DESCRIPTOR IS NOT CONTAINED IN THE USERS -C TABLE B. -C - A SECOND ROUTINE TO PROCESS IFOD MESSAGES -C (IFOD0) HAS BEEN REMOVED IN FAVOR OF THE -C IMPROVED PROCESSING OF THE ONE -C REMAINING (IFOD1). -C - NEW CODING HAS BEEN INTRODUCED TO PERMIT -C PROCESSING OF BUFR MESSAGES BASED ON BUFR -C EDITION UP TO AND INCLUDING EDITION 2. -C PLEASE NOTE INCREASED SIZE REQUIREMENTS -C FOR ARRAYS IDENT(20) AND IPTR(40). -C 91-07-26 CAVANAUGH - ADD ARRAY MTIME TO CALLING SEQUENCE TO -C PERMIT INCLUSION OF RECEIPT/TRANSFER TIMES -C TO IFOD MESSAGES. -C 91-09-25 CAVANAUGH - ALL PROCESSING OF DECODED BUFR DATA INTO -C IFOD (A LOCAL USE REFORMAT OF BUFR DATA) -C HAS BEEN ISOLATED FROM THIS SET OF ROUTINES. -C FOR THOSE INTERESTED IN THE IFOD FORM, -C SEE W3FL05 IN THE W3LIB ROUTINES. -C PROCESSING OF BUFR MESSAGES CONTAINING -C DELAYED REPLICATION HAS BEEN ALTERED SO THAT -C SINGLE SUBSETS (REPORTS) AND AND A MATCHING -C DESCRIPTOR LIST FOR THAT PARTICULAR SUBSET -C WILL BE PASSED TO THE USER WILL BE PASSED TO -C THE USER ONE AT A TIME TO ASSURE THAT EACH -C SUBSET CAN BE FULLY DEFINED WITH A MINIMUM -C OF REPROCESSING. -C PROCESSING OF ASSOCIATED FIELDS HAS BEEN -C TESTED WITH MESSAGES CONTAINING NON-COMPRESSED -C DATA. -C IN ORDER TO FACILITATE USER PROCESSING -C A MATCHING LIST OF SCALE FACTORS ARE INCLUDED -C WITH THE EXPANDED DESCRIPTOR LIST (MSTACK). -C 91-11-21 CAVANAUGH - PROCESSING OF DESCRIPTOR 2 03 YYY -C HAS CORRECTED TO AGREE WITH FM94 STANDARDS. -C 91-12-19 CAVANAUGH - CALLS TO FI6703 AND FI6704 HAVE BEEN -C CORRECTED TO AGREE CALLED PROGRAM ARGUMENT -C LIST. SOME ADDITIONAL ENTRIES HAVE BEEN -C INCLUDED FOR COMMUNICATING WITH DATA ACCESS -C ROUTINES. ADDITIONAL ERROR EXIT PROVIDED FOR -C THE CASE WHERE TABLE B IS DAMAGED. -C 92-01-24 CAVANAUGH - ROUTINES FI6701, FI6703 AND FI6704 -C HAVE BEEN MODIFIED TO HANDLE ASSOCIATED FIELDS -C ALL DESCRIPTORS ARE SET TO ECHO TO MSTACK(1,N) -C 92-05-21 CAVANAUGH - FURTHER EXPANSION OF INFORMATION COLLECTED -C FROM WITHIN UPPER AIR SOUNDINGS HAS PRODUCED -C THE NECESSITY TO EXPAND SOME OF THE PROCESSING -C AND OUTPUT ARRAYS. (SEE REMARKS BELOW) -C 92-06-29 CAVANAUGH - CORRECTED DESCRIPTOR DENOTING HEIGHT OF -C EACH WIND LEVEL FOR PROFILER CONVERSIONS. -C 92-07-23 CAVANAUGH - EXPANSION OF TABLE B REQUIRES ADJUSTMENT -C OF ARRAYS TO CONTAIN TABLE B VALUES NEEDED TO -C ASSIST IN THE DECODING PROCESS. -C ARRAYS CONTAINING DATA FROM TABLE B -C KDESC - DESCRIPTOR -C ANAME - DESCRIPTOR NAME -C AUNITS - UNITS FOR DESCRIPTOR -C MSCALE - SCALE FOR VALUE OF DESCRIPTOR -C MREF - REFERENCE VALUE FOR DESCRIPTOR -C MWIDTH - BIT WIDTH FOR VALUE OF DESCRIPTOR -C 92-09-09 CAVANAUGH - FIRST ENCOUNTER WITH OPERATOR DESCRIPTOR -C 2 05 YYY SHOWED ERROR IN DECODING. THAT ERROR -C IS CORRECTED WITH THIS IMPLEMENTATION. FURTHER -C TESTING OF UPPER AIR DATA HAS ENCOUNTERED -C THE CONDITION OF LARGE (MANY LEVEL) SOUNDINGS -C ARRAYS IN THE DECODER HAVE BEEN EXPANDED (AGAIN) -C TO ALLOW FOR THIS CONDITION. -C 92-10-02 CAVANAUGH - MODIFIED ROUTINE TO REFORMAT PROFILER DATA -C (FI6709) TO SHOW DESCRIPTORS, SCALE VALUE AND -C DATA IN PROPER ORDER. CORRECTED AN ERROR THAT -C PREVENTED USER FROM ASSIGNING THE SECOND DIMENSION -C OF KDATA(500,*). -C 92-10-20 CAVANAUGH - REMOVED ERROR THAT PREVENTED FULL -C IMPLEMENTATION OF PREVIOUS CORRECTIONS AND -C MADE CORRECTIONS TO TABLE B TO BRING IT UP TO -C DATE. CHANGES INCLUDE PROPER REFORMAT OF PROFILER -C DATA AND USER CAPABILITY FOR ASSIGNING SECOND -C DIMENSION OF KDATA ARRAY. -C 93-01-26 CAVANAUGH - ADDED ROUTINE FI6710 TO PERMIT REFORMATTING -C PROFILER DATA IN BUFR EDITION 2. -C -C USAGE: CALL W3FI67(IPTR,IDENT,MSGA,ISTACK,MSTACK,KDATA,KNR,INDEX) -C INPUT ARGUMENT LIST: -C MSGA - ARRAY CONTAINING SUPPOSED BUFR MESSAGE -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C ISTACK - ORIGINAL ARRAY OF DESCRIPTORS EXTRACTED FROM -C SOURCE BUFR MESSAGE. -C MSTACK(A,B)-LEVEL B - DESCRIPTOR NUMBER -C LEVEL A = 1 DESCRIPTOR -C = 2 10**N SCALING TO RETURN TO ORIGINAL VALUE -C IPTR - UTILITY ARRAY -C IPTR( 1)- ERROR RETURN -C IPTR( 2)- BYTE COUNT SECTION 1 -C IPTR( 3)- POINTER TO START OF SECTION 1 -C IPTR( 4)- BYTE COUNT SECTION 2 -C IPTR( 5)- POINTER TO START OF SECTION 2 -C IPTR( 6)- BYTE COUNT SECTION 3 -C IPTR( 7)- POINTER TO START OF SECTION 3 -C IPTR( 8)- BYTE COUNT SECTION 4 -C IPTR( 9)- POINTER TO START OF SECTION 4 -C IPTR(10)- START OF REQUESTED SUBSET, RESERVED FOR DAR -C IPTR(11)- CURRENT DESCRIPTOR PTR IN IWORK -C IPTR(12)- LAST DESCRIPTOR POS IN IWORK -C IPTR(13)- LAST DESCRIPTOR POS IN ISTACK -C IPTR(14)- NUMBER OF TABLE B ENTRIES -C IPTR(15)- REQUESTED SUBSET POINTER, RESERVED FOR DAR -C IPTR(16)- INDICATOR FOR EXISTANCE OF SECTION 2 -C IPTR(17)- NUMBER OF REPORTS PROCESSED -C IPTR(18)- ASCII/TEXT EVENT -C IPTR(19)- POINTER TO START OF BUFR MESSAGE -C IPTR(20)- NUMBER OF LINES FROM TABLE D -C IPTR(21)- TABLE B SWITCH -C IPTR(22)- TABLE D SWITCH -C IPTR(23)- CODE/FLAG TABLE SWITCH -C IPTR(24)- ADITIONAL WORDS ADDED BY TEXT INFO -C IPTR(25)- CURRENT BIT NUMBER -C IPTR(26)- DATA WIDTH CHANGE -C IPTR(27)- DATA SCALE CHANGE -C IPTR(28)- DATA REFERENCE VALUE CHANGE -C IPTR(29)- ADD DATA ASSOCIATED FIELD -C IPTR(30)- SIGNIFY CHARACTERS -C IPTR(31)- NUMBER OF EXPANDED DESCRIPTORS IN MSTACK -C IPTR(32)- CURRENT DESCRIPTOR SEGMENT F -C IPTR(33)- CURRENT DESCRIPTOR SEGMENT X -C IPTR(34)- CURRENT DESCRIPTOR SEGMENT Y -C IPTR(35)- UNUSED -C IPTR(36)- NEXT DESCRIPTOR MAY BE UNDECIPHERABLE -C IPTR(37)- UNUSED -C IPTR(38)- UNUSED -C IPTR(39)- DELAYED REPLICATION FLAG -C 0 - NO DELAYED REPLICATION -C 1 - MESSAGE CONTAINS DELAYED REPLICATION -C IPTR(40)- NUMBER OF CHARACTERS IN TEXT FOR CURR DESCRIPTOR -C IDENT - ARRAY CONTAINS MESSAGE INFORMATION EXTRACTED FROM -C BUFR MESSAGE - -C IDENT( 1)-EDITION NUMBER (BYTE 4, SECTION 1) -C IDENT( 2)-ORIGINATING CENTER (BYTES 5-6, SECTION 1) -C IDENT( 3)-UPDATE SEQUENCE (BYTE 7, SECTION 1) -C IDENT( 4)-OPTIONAL SECTION (BYTE 8, SECTION 1) -C IDENT( 5)-BUFR MESSAGE TYPE (BYTE 9, SECTION 1) -C 0 = SURFACE (LAND) -C 1 = SURFACE (SHIP) -C 2 = VERTICAL SOUNDINGS OTHER THAN SATELLITE -C 3 = VERTICAL SOUNDINGS (SATELLITE) -C 4 = SNGL LVL UPPER-AIR OTHER THAN SATELLITE -C 5 = SNGL LVL UPPER-AIR (SATELLITE) -C 6 = RADAR -C IDENT( 6)-BUFR MSG SUB-TYPE (BYTE 10, SECTION 1) -C TYPE SBTYP -C 2 7 = PROFILER -C IDENT( 7)- (BYTES 11-12, SECTION 1) -C IDENT( 8)-YEAR OF CENTURY (BYTE 13, SECTION 1) -C IDENT( 9)-MONTH OF YEAR (BYTE 14, SECTION 1) -C IDENT(10)-DAY OF MONTH (BYTE 15, SECTION 1) -C IDENT(11)-HOUR OF DAY (BYTE 16, SECTION 1) -C IDENT(12)-MINUTE OF HOUR (BYTE 17, SECTION 1) -C IDENT(13)-RSVD BY ADP CENTERS(BYTE 18, SECTION 1) -C IDENT(14)-NR OF DATA SUBSETS (BYTE 5-6, SECTION 3) -C IDENT(15)-OBSERVED FLAG (BYTE 7, BIT 1, SECTION 3) -C IDENT(16)-COMPRESSION FLAG (BYTE 7, BIT 2, SECTION 3) -C IDENT(17)-MASTER TABLE NUMBER(BYTE 4, SECTION 1, ED 2 OR GTR) -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C ARRAYS CONTAINING DATA FROM TABLE B -C ANAME - DESCRIPTOR NAME -C AUNITS - UNITS FOR DESCRIPTOR -C MSCALE - SCALE FOR VALUE OF DESCRIPTOR -C MREF - REFERENCE VALUE FOR DESCRIPTOR -C MWIDTH - BIT WIDTH FOR VALUE OF DESCRIPTOR -C INDEX - POINTER TO AVAILABLE SUBSET -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - GBYTE GBYTES -C -C REMARKS: ERROR RETURNS: -C IPTR(1) = 1 'BUFR' NOT FOUND IN FIRST 125 CHARACTERS -C = 2 '7777' NOT FOUND IN LOCATION DETERMINED BY -C BY USING COUNTS FOUND IN EACH SECTION. ONE OR -C MORE SECTIONS HAVE AN ERRONEOUS BYTE COUNT OR -C CHARACTERS '7777' ARE NOT IN TEST MESSAGE. -C = 3 MESSAGE CONTAINS A DESCRIPTOR WITH F=0 THAT DOES -C NOT EXIST IN TABLE B. -C = 4 MESSAGE CONTAINS A DESCRIPTOR WITH F=3 THAT DOES -C NOT EXIST IN TABLE D. -C = 5 MESSAGE CONTAINS A DESCRIPTOR WITH F=2 WITH THE -C VALUE OF X OUTSIDE THE RANGE 1-5. -C = 6 DESCRIPTOR ELEMENT INDICATED TO HAVE A FLAG VALUE -C DOES NOT HAVE AN ENTRY IN THE FLAG TABLE. -C (TO BE ACTIVATED) -C = 7 DESCRIPTOR INDICATED TO HAVE A CODE VALUE DOES -C NOT HAVE AN ENTRY IN THE CODE TABLE. -C (TO BE ACTIVATED) -C = 8 ERROR READING TABLE D -C = 9 ERROR READING TABLE B -C = 10 ERROR READING CODE/FLAG TABLE -C = 11 DESCRIPTOR 2 04 004 NOT FOLLOWED BY 0 31 021 -C = 12 DATA DESCRIPTOR OPERATOR QUALIFIER DOES NOT FOLLOW -C DELAYED REPLICATION DESCRIPTOR. -C = 13 BIT WIDTH ON ASCII CHARACTERS NOT A MULTIPLE OF 8 -C = 14 SUBSETS = 0, NO CONTENT BULLETIN -C = 20 EXCEEDED COUNT FOR DELAYED REPLICATION PASS -C = 21 EXCEEDED COUNT FOR NON-DELAYED REPLICATION PASS -C = 22 SECTION 1 COUNT EXCEEDS 10000 -C = 23 SECTION 2 COUNT EXCEEDS 10000 -C = 24 SECTION 3 COUNT EXCEEDS 10000 -C = 25 SECTION 4 COUNT EXCEEDS 10000 -C = 27 NON ZERO LOWEST ON TEXT DATA -C = 28 NBINC NOT NR OF CHARACTERS -C = 29 TABLE B APPEARS TO BE DAMAGED -C = 99 NO MORE SUBSETS (REPORTS) AVAILABLE IN CURRENT -C BUFR MESAGE -C = 400 NUMBER OF SUBSETS EXCEEDS CAPABILITY OF ROUTINE -C = 401 NUMBER OF PARAMETERS (AND ASSOCIATED FIELDS) -C EXCEEDS LIMITS OF THIS PROGRAM. -C = 500 VALUE FOR NBINC HAS BEEN FOUND THAT EXCEEDS -C STANDARD WIDTH PLUS ANY BIT WIDTH CHANGE. -C CHECK ALL BIT WIDTHS UP TO POINT OF ERROR. -C = 501 CORRECTED WIDTH FOR DESCRIPTOR IS 0 OR LESS -C -C ON THE INITIAL CALL TO W3FI67 WITH A BUFR MESSAGE THE ARGUMENT -C INDEX MUST BE SET TO ZERO (INDEX = 0). ON THE RETURN FROM W3FI67 -C 'INDEX' WILL BE SET TO THE NEXT AVAILABLE SUBSET/REPORT. WHEN -C THERE ARE NO MORE SUBSETS AVAILABLE A 99 ERR RETURN WILL OCCUR. -C -C IF THE ORIGINAL BUFR MESSAGE DOES NOT CONTAIN DELAYED REPLICATION -C THE BUFR MESSAGE WILL BE COMPLETELY DECODED AND 'INDEX' WILL POINT -C TO THE FIRST DECODED SUBSET. THE USERS WILL THEN HAVE THE OPTION -C OF INDEXING THROUGH THE SUBSETS ON THEIR OWN OR BY RECALLING THIS -C ROUTINE (WITHOUT RESETTING 'INDEX') TO HAVE THE ROUTINE DO THE -C INDEXING. -C -C IF THE ORIGINAL BUFR MESSAGE DOES CONTAIN DELAYED REPLICATION -C ONE SUBSET/REPORT WILL BE DECODED AT A TIME AND PASSED BACK TO -C THE USER. THIS IS NOT AN OPTION. -C -C ============================================= -C TO USE THIS ROUTINE -C -------------------------------- -C 1. READ IN BUFR MESSAGE -C 2. SET INDEX = 0 -C 3. CALL W3FI67( ) -C 4. IF (IPTR(1).EQ.99) THEN -C NO MORE SUBSETS -C EITHER GO TO 1 -C OR TERMINATE IN NO MORE BUFR MESSAGES -C END IF -C 5. IF (IPTR(1).NE.0) THEN -C ERROR CONDITION -C EITHER GO TO 1 -C OR TERMINATE IN NO MORE BUFR MESSAGES -C END IF -C 6. THE VALUE OF INDEX INDICATES THE ACTIVE SUBSET SO -C IF INTERESTED IN GENERATING AN IFOD MESSAGE -C CALL W3FL05 ( ) -C ELSE -C PROCESS DECODED INFORMATION AS REQUIRED -C END IF -C 7. GO TO 3 -C ============================================= -C THE ARRAYS TO CONTAIN THE OUTPUT INFORMATION ARE DEFINED -C AS FOLLOWS: -C KDATA(A,B) IS THE A DATA ENTRY (INTEGER VALUE) -C WHERE A IS THE MAXIMUM NUMBER OF REPORTS/SUBSETS -C (FOR THIS VERSION OF THE DECODER A=500) -C THAT MAY BE CONTAINED IN THE BUFR MESSAGE, AND -C WHERE B IS THE MAXIMUM NUMBER OF DESCRIPTOR -C COMBINATIONS THAT MAY BE PROCESSED. -C UPPER AIR DATA AND SOME SATELLITE DATA REQUIRE -C A VALUE FOR B OF 1600, BUT FOR MOST OTHER DATA -C A VALUE FOR B OF 500 WILL SUFFICE -C MSTACK(1,B) CONTAINS THE DESCRIPTOR THAT MATCHES THE -C DATA ENTRY -C MSTACK(2,B) IS THE SCALE (POWER OF 10) TO BE APPLIED TO -C THE DATA -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ -C - CHARACTER*40 ANAME(700) - CHARACTER*24 AUNITS(700) -C -C - INTEGER MSGA(*),KDATA(500,*) - INTEGER IPTR(*),MSTACK(2,*) - INTEGER IVALS(500),KNR(*) - INTEGER IDENT(*) - INTEGER KDESC(1600) - INTEGER ISTACK(*),IWORK(1600) - INTEGER MSCALE(700) - INTEGER MREF(700,3) - INTEGER MWIDTH(700) - INTEGER INDEX -C - CHARACTER*4 DIRID(2) -C - LOGICAL SEC2 -C - SAVE -C -C PRINT *,' W3FI67 DECODER' -C INITIALIZE ERROR RETURN - IPTR(1) = 0 - IF (INDEX.GT.0) THEN -C HAVE RE-ENTRY - INDEX = INDEX + 1 -C PRINT *,'RE-ENTRY LOOKING FOR SUBSET NR',INDEX - IF (INDEX.GT.IDENT(14)) THEN -C ALL SUBSETS PROCESSED - IPTR(1) = 99 - IPTR(39) = 0 - ELSE IF (INDEX.LE.IDENT(14)) THEN - IF (IPTR(39).NE.0) THEN - CALL FI6701(IPTR,IDENT,MSGA,ISTACK,IWORK,ANAME,KDATA, - * IVALS, - * MSTACK,AUNITS,KDESC,MWIDTH,MREF,MSCALE,KNR,INDEX) - END IF - END IF - RETURN - ELSE - INDEX = 1 -C PRINT *,'INITIAL ENTRY FOR THIS BUFR MESSAGE' - END IF - IPTR(39) = 0 -C FIND 'BUFR' IN FIRST 125 CHARACTERS - DO 1000 KNOFST = 0, 999, 8 - INOFST = KNOFST - CALL GBYTE (MSGA,IVALS,INOFST,8) - IF (IVALS(1).EQ.66) THEN - IPTR(19) = INOFST - INOFST = INOFST + 8 - CALL GBYTE (MSGA,IVALS,INOFST,24) - IF (IVALS(1).EQ.5588562) THEN -C PRINT *,'FOUND BUFR AT',IPTR(19) - INOFST = INOFST + 24 - GO TO 1500 - END IF - END IF - 1000 CONTINUE - PRINT *,'BUFR - START OF BUFR MESSAGE NOT FOUND' - IPTR(1) = 1 - RETURN - 1500 CONTINUE - IDENT(1) = 0 -C TEST FOR EDITION NUMBER -C ====================== - CALL GBYTE (MSGA,IDENT(1),INOFST+24,8) -C PRINT *,'THIS IS AN EDITION ',IDENT(1),' BUFR MESSAGE' - IF (IDENT(1).GE.2) THEN - CALL GBYTE (MSGA,IVALS,INOFST,24) - ITOTAL = IVALS(1) - KENDER = ITOTAL * 8 - 32 + IPTR(19) - CALL GBYTE (MSGA,ILAST,KENDER,32) - IF (ILAST.EQ.926365495) THEN -C PRINT *,'HAVE TOTAL COUNT FROM SEC 0',IVALS(1) - INOFST = INOFST + 32 - END IF - IPTR(3) = INOFST -C SECTION 1 COUNT - CALL GBYTE (MSGA,IVALS,INOFST,24) -C PRINT *,'SECTION 1 STARTS AT',INOFST,' SIZE',IVALS(1) - INOFST = INOFST + 24 - IPTR( 2) = IVALS(1) - IF (IVALS(1).GT.10000) THEN - IPTR(1) = 22 - RETURN - END IF -C GET BUFR MASTER TABLE - CALL GBYTE (MSGA,IVALS,INOFST,8) - INOFST = INOFST + 8 - IDENT(17) = IVALS(1) -C PRINT *,'BUFR MASTER TABLE NR',IDENT(17) - ELSE - IPTR(3) = INOFST -C SECTION 1 COUNT - CALL GBYTE (MSGA,IVALS,INOFST,24) -C PRINT *,'SECTION 1 STARTS AT',INOFST,' SIZE',IVALS(1) - INOFST = INOFST + 32 - IPTR( 2) = IVALS(1) - IF (IVALS(1).GT.10000) THEN - IPTR(1) = 22 - RETURN - END IF - END IF -C ====================== -C ORIGINATING CENTER - CALL GBYTE (MSGA,IVALS,INOFST,16) - INOFST = INOFST + 16 - IDENT(2) = IVALS(1) -C UPDATE SEQUENCE - CALL GBYTE (MSGA,IVALS,INOFST,8) - INOFST = INOFST + 8 - IDENT(3) = IVALS(1) -C OPTIONAL SECTION FLAG - CALL GBYTE (MSGA,IVALS,INOFST,1) - IDENT(4) = IVALS(1) - IF (IDENT(4).GT.0) THEN - SEC2 = .TRUE. - ELSE -C PRINT *,' NO OPTIONAL SECTION 2' - SEC2 = .FALSE. - END IF - INOFST = INOFST + 8 -C MESSAGE TYPE - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(5) = IVALS(1) - INOFST = INOFST + 8 -C MESSAGE SUB-TYPE - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(6) = IVALS(1) - INOFST = INOFST + 8 -C IF BUFR EDITION 0 OR 1 THEN -C NEXT 2 BYTES ARE BUFR TABLE VERSION -C ELSE -C BYTE 11 IS VER NR OF MASTER TABLE -C BYTE 12 IS VER NR OF LOCAL TABLE - IF (IDENT(1).LT.2) THEN - CALL GBYTE (MSGA,IVALS,INOFST,16) - IDENT(7) = IVALS(1) - INOFST = INOFST + 16 - ELSE -C BYTE 11 IS VER NR OF MASTER TABLE - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(18) = IVALS(1) - INOFST = INOFST + 8 -C BYTE 12 IS VER NR OF LOCAL TABLE - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(19) = IVALS(1) - INOFST = INOFST + 8 - - END IF -C YEAR OF CENTURY - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(8) = IVALS(1) - INOFST = INOFST + 8 -C MONTH - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(9) = IVALS(1) - INOFST = INOFST + 8 -C DAY - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(10) = IVALS(1) - INOFST = INOFST + 8 -C HOUR - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(11) = IVALS(1) - INOFST = INOFST + 8 -C MINUTE - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(12) = IVALS(1) -C RESET POINTER (INOFST) TO START OF -C NEXT SECTION -C (SECTION 2 OR SECTION 3) - INOFST = IPTR(3) + IPTR(2) * 8 - IPTR(4) = 0 - IPTR(5) = INOFST - IF (SEC2) THEN - IPTR(5) = INOFST -C SECTION 2 COUNT - CALL GBYTE (MSGA,IPTR(4),INOFST,24) - INOFST = INOFST + 32 -C PRINT *,'SECTION 2 STARTS AT',INOFST,' BYTES=',IPTR(4) - KENTRY = (IPTR(4) - 4) / 14 -C PRINT *,'SHOULD BE A MAX OF',KENTRY,' REPORTS' - IF (IDENT(2).EQ.7) THEN - DO 2000 I = 1, KENTRY - CALL GBYTE (MSGA,KDSPL ,INOFST,16) - INOFST = INOFST + 16 - CALL GBYTE (MSGA,LAT ,INOFST,16) - INOFST = INOFST + 16 - CALL GBYTE (MSGA,LON ,INOFST,16) - INOFST = INOFST + 16 - CALL GBYTE (MSGA,KDAHR ,INOFST,16) - INOFST = INOFST + 16 - CALL GBYTE (MSGA,DIRID(1),INOFST,32) - INOFST = INOFST + 32 - CALL GBYTE (MSGA,DIRID(2),INOFST,16) - INOFST = INOFST + 16 -C PRINT *,KDSPL,LAT,LON,KDAHR,DIRID(1),DIRID(2) - 2000 CONTINUE - END IF -C RESET POINTER (INOFST) TO START OF -C SECTION 3 - INOFST = IPTR(5) + IPTR(4) * 8 - END IF -C BIT OFFSET TO START OF SECTION 3 - IPTR( 7) = INOFST -C SECTION 3 COUNT - CALL GBYTE (MSGA,IPTR(6),INOFST,24) -C PRINT *,'SECTION 3 STARTS AT',INOFST,' BYTES=',IPTR(6) - INOFST = INOFST + 24 - IF (IPTR(6).GT.10000) THEN - IPTR(1) = 24 - RETURN - END IF - INOFST = INOFST + 8 -C NUMBER OF DATA SUBSETS - CALL GBYTE (MSGA,IDENT(14),INOFST,16) - IF (IDENT(14).GT.500) THEN - PRINT *,'THE NUMBER OF SUBSETS EXCEEDS THE CAPABILITY' - PRINT *,'OF THIS VERSION OF THE BUFR DECODER. ANOTHER ' - PRINT *,'VERSION MUST BE CONSTRUCTED TO HANDLE AT LEAST' - PRINT *,IDENT(14),'SUBSETS TO BE ABLE TO PROCESS THIS DATA' - IPTR(1) = 400 - RETURN - END IF - INOFST = INOFST + 16 -C OBSERVED DATA FLAG - CALL GBYTE (MSGA,IVALS,INOFST,1) - IDENT(15) = IVALS(1) - INOFST = INOFST + 1 -C COMPRESSED DATA FLAG - CALL GBYTE (MSGA,IVALS,INOFST,1) - IDENT(16) = IVALS(1) - INOFST = INOFST + 7 -C CALCULATE NUMBER OF DESCRIPTORS - NRDESC = (IPTR( 6) - 8) / 2 - IPTR(12) = NRDESC - IPTR(13) = NRDESC -C EXTRACT DESCRIPTORS - CALL GBYTES (MSGA,ISTACK,INOFST,16,0,NRDESC) -C PRINT *,'INITIAL DESCRIPTOR LIST OF',NRDESC,' DESCRIPTORS' - DO 10 L = 1, NRDESC - IWORK(L) = ISTACK(L) -C PRINT *,L,ISTACK(L) - 10 CONTINUE - IPTR(13) = NRDESC -C RESET POINTER TO START OF SECTION 4 - INOFST = IPTR(7) + IPTR(6) * 8 -C BIT OFFSET TO START OF SECTION 4 - IPTR( 9) = INOFST -C SECTION 4 COUNT - CALL GBYTE (MSGA,IVALS,INOFST,24) - IF (IVALS(1).GT.10000) THEN - IPTR(1) = 25 - RETURN - END IF -C PRINT *,'SECTION 4 STARTS AT',INOFST,' VALUE',IVALS(1) - IPTR( 8) = IVALS(1) - INOFST = INOFST + 32 -C SET FOR STARTING BIT OF DATA - IPTR(25) = INOFST -C FIND OUT IF '7777' TERMINATOR IS THERE - INOFST = IPTR(9) + IPTR(8) * 8 - CALL GBYTE (MSGA,IVALS,INOFST,32) -C PRINT *,'SECTION 5 STARTS AT',INOFST,' VALUE',IVALS(1) - IF (IVALS(1).NE.926365495) THEN - PRINT *,'BAD SECTION COUNT' - IPTR(1) = 2 - RETURN - ELSE - IPTR(1) = 0 - END IF - CALL FI6701(IPTR,IDENT,MSGA,ISTACK,IWORK,ANAME,KDATA,IVALS, - * MSTACK,AUNITS,KDESC,MWIDTH,MREF,MSCALE,KNR,INDEX) -C PRINT *,'HAVE RETURNED FROM FI6701' - IF (IPTR(1).NE.0) THEN - RETURN - END IF -C FURTHER PROCESSING REQUIRED FOR PROFILER DATA - IF (IDENT(5).EQ.2) THEN - IF (IDENT(6).EQ.7) THEN -C DO 151 I = 1, 40 -C IF (I.LE.20) THEN -C PRINT *,'IPTR(',I,')=',IPTR(I), -C * ' IDENT(',I,')= ',IDENT(I) -C ELSE -C PRINT *,'IPTR(',I,')=',IPTR(I) -C END IF -C 151 CONTINUE -C DO 153 I = 1, KNR(INDEX) -C PRINT *,I,MSTACK(1,I),MSTACK(2,I),KDATA(1,I),KDATA(2,I) -C 153 CONTINUE - PRINT *,'REFORMAT PROFILER DATA' - IF (IDENT(1).LT.2) THEN - CALL FI6709(IDENT,MSTACK,KDATA,IPTR) - ELSE - CALL FI6710(IDENT,MSTACK,KDATA,IPTR) - END IF - IF (IPTR(1).NE.0) THEN - RETURN - END IF -C DO 154 I = 1, KNR(INDEX) -C PRINT *,I,MSTACK(1,I),MSTACK(2,I),KDATA(1,I),KDATA(2,I) -C 154 CONTINUE - END IF - END IF - RETURN - END - SUBROUTINE FI6701(IPTR,IDENT,MSGA,ISTACK,IWORK,ANAME,KDATA,IVALS, - * MSTACK,AUNITS,KDESC,MWIDTH,MREF,MSCALE,KNR,INDEX) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI6701 DATA EXTRACTION -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01 -C -C ABSTRACT: CONTROL THE EXTRACTION OF DATA FROM SECTION 4 BASED ON -C DATA DESCRIPTORS. -C -C PROGRAM HISTORY LOG: -C 88-09-01 CAVANAUGH -C 91-01-18 CAVANAUGH CORRECTIONS TO PROPERLY HANDLE NON-COMPRESSED -C DATA. -C 91-09-23 CAVANAUGH CODING ADDED TO HANDLE SINGLE SUBSETS WITH -C DELAYED REPLICATION. -C 92-01-24 CAVANAUGH MODIFIED TO ECHO DESCRIPTORS TO MSTACK(1,N) -C -C USAGE: CALL FI6701(IPTR,IDENT,MSGA,ISTACK,IWORK,ANAME,KDATA, -C * MSTACK,AUNITS,KDESC,MWIDTH,MREF,MSCALE,KNR,INDEX) -C INPUT ARGUMENT LIST: -C IPTR - SEE W5FI67 ROUTINE DOCBLOCK -C IDENT - SEE W3FI67 ROUTINE DOCBLOCK -C MSGA - ARRAY CONTAINING BUFR MESSAGE -C ISTACK - ORIGINAL ARRAY OF DESCRIPTORS EXTRACTED FROM -C SOURCE BUFR MESSAGE. -C MSTACK - WORKING ARRAY OF DESCRIPTORS (EXPANDED)AND SCALING -C FACTOR -C KDESC - IMAGE OF CURRENT DESCRIPTOR -C INDEX - -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C IWORK - WORKING DESCRIPTOR LIST -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C ISTACK - SEE ABOVE -C ARRAYS CONTAINING DATA FROM TABLE B -C KDESC - SEE ABOVE -C ANAME - DESCRIPTOR NAME -C AUNITS - UNITS FOR DESCRIPTOR -C MSCALE - SCALE FOR VALUE OF DESCRIPTOR -C MREF - REFERENCE VALUE FOR DESCRIPTOR -C MWIDTH - BIT WIDTH FOR VALUE OF DESCRIPTOR -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - FI6702 FI6705 FI6706 FI6707 FI6708 -C -C REMARKS: ERROR RETURN: -C IPTR(1) = 8 ERROR READING TABLE B -C = 9 ERROR READING TABLE D -C = 11 ERROR OPENING TABLE B -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ - SAVE -C - CHARACTER*40 ANAME(*) - CHARACTER*24 AUNITS(*) -C - INTEGER MSGA(*),KDATA(500,*),IVALS(*) - INTEGER MSCALE(*),KNR(*) - INTEGER LX,LY,LL,J - INTEGER MREF(700,3) - INTEGER MWIDTH(*) - INTEGER IHOLD(33) - INTEGER ITBLD(500,11) - INTEGER IPTR(*) - INTEGER IDENT(*) - INTEGER KDESC(*) - INTEGER ISTACK(*),IWORK(*) - INTEGER MSTACK(2,*),KK - INTEGER JDESC - INTEGER INDEX - INTEGER ITEST(30) -C - DATA ITEST /1,3,7,15,31,63,127,255, - * 511,1023,2047,4095,8191,16383, - * 32767, 65535,131071,262143,524287, - * 1048575,2097151,4194303,8388607, - * 16777215,33554431,67108863,134217727, - * 268435455,536870911,1073741823/ -C -C PRINT *,' DECOLL FI6701' - IF (INDEX.GT.1) THEN - GO TO 1000 - END IF -C --------- DECOLL --------------- - IPTR(23) = 0 - IPTR(26) = 0 - IPTR(27) = 0 - IPTR(28) = 0 - IPTR(29) = 0 - IPTR(30) = 0 - IPTR(36) = 0 -C INITIALIZE OUTPUT AREA -C SET POINTER TO BEGINNING OF DATA -C SET BIT - IPTR(17) = 1 - 1000 CONTINUE -C IPTR(12) = IPTR(13) - LL = 0 - IPTR(11) = 1 - IF (IPTR(10).EQ.0) THEN -C RE-ENTRY POINT FOR MULTIPLE -C NON-COMPRESSED REPORTS - ELSE - INDEX = IPTR(15) - IPTR(17) = INDEX - IPTR(25) = IPTR(10) - IPTR(10) = 0 - IPTR(15) = 0 - END IF -C PRINT *,'FI6701 - RPT',IPTR(17),' STARTS AT',IPTR(25) - IPTR(24) = 0 - IPTR(31) = 0 -C POINTING AT NEXT AVAILABLE DESCRIPTOR - MM = 0 - IF (IPTR(21).EQ.0) THEN -C PRINT *,' READING TABLE B' - DO 150 I = 1, 700 - IPTR(21) = I - READ(UNIT=20,FMT=20,ERR=9999,END=175)MF, - * MX,MY, - * (ANAME(I)(K:K),K=1,40), - * (AUNITS(I)(K:K),K=1,24), - * MSCALE(I),MREF(I,1),MWIDTH(I) - 20 FORMAT(I1,I2,I3,40A1,24A1,I5,I15,1X,I4) - IF (MWIDTH(I).EQ.0) THEN - IPTR(1) = 29 - RETURN - END IF - MREF(I,2) = 0 - IPTR(14) = I - KDESC(I) = MF*16384 + MX*256 + MY -C PRINT *,I -C WRITE(6,21) MF,MX,MY,KDESC(I), -C * (ANAME(I)(K:K),K=1,40), -C * (AUNITS(I)(K:K),K=1,24), -C * MSCALE(I),MREF(I,1),MWIDTH(I) - 21 FORMAT(1X,I1,I2,I3,1X,I6,1X,40A1, - * 2X,24A1,2X,I5,2X,I15,1X,I4) - 150 CONTINUE - PRINT *,'HAVE READ LIMIT OF 700 TABLE B DESCRIPTORS' - PRINT *,'IF THERE ARE MORE THAT THAT, CORRECT READ LOOP' - 175 CONTINUE -C CLOSE(UNIT=20,STATUS='KEEP') - IPTR(21) = 1 - END IF -C DO WHILE MM <= 500 - 10 CONTINUE -C PROCESS THRU THE FOLLOWING -C DEPENDING UPON THE VALUE OF 'F' (LF) - MM = MM + 1 - 12 CONTINUE - IF (MM.GT.2000) THEN - GO TO 200 - END IF -C END OF CYCLE TEST (SERIAL/SEQUENTIAL) - IF (IPTR(11).GT.IPTR(12)) THEN -C PRINT *,' HAVE COMPLETED REPORT SEQUENCE' - IF (IDENT(16).NE.0) THEN -C PRINT *,' PROCESSING COMPRESSED REPORTS' -C REFORMAT DATA FROM DESCRIPTOR -C FORM TO USER FORM - RETURN - ELSE -C WRITE (6,1) -C 1 FORMAT (1H1) -C PRINT *,' PROCESSED SERIAL REPORT',IPTR(17),IPTR(25) - IPTR(17) = IPTR(17) + 1 - IF (IPTR(17).GT.IDENT(14)) THEN - IPTR(17) = IPTR(17) - 1 - GO TO 200 - END IF - DO 300 I = 1, IPTR(13) - IWORK(I) = ISTACK(I) - 300 CONTINUE -C RESET POINTERS - LL = 0 - IPTR(1) = 0 - IPTR(11) = 1 - IPTR(12) = IPTR(13) -C IS THIS LAST REPORT ? -C PRINT *,'READY',IPTR(39),INDEX - IF (IPTR(39).GT.0) THEN - IF (INDEX.GT.0) THEN -C PRINT *,'HERE IS SUBSET NR',INDEX - RETURN - END IF - END IF - GO TO 1000 - END IF - END IF - 14 CONTINUE -C GET NEXT DESCRIPTOR - CALL FI6708 (IPTR,IWORK,LF,LX,LY,JDESC) -C PRINT *,IPTR(11)-1,'JDESC= ',JDESC,' AND NEXT ', -C * IPTR(11),IWORK(IPTR(11)),IPTR(31) -C PRINT *,IPTR(11)-1,'DESCRIPTOR',JDESC,LF,LX,LY, -C * ' FOR LOC',IPTR(17),IPTR(25) - IF (IPTR(11).GT.1600) THEN - IPTR(1) = 401 - RETURN - END IF -C - KPRM = IPTR(31) + IPTR(24) - IF (KPRM.GT.1600) THEN - IF (KPRM.GT.KOLD) THEN - PRINT *,'EXCEEDED ARRAY SIZE',KPRM,IPTR(31), - * IPTR(24) - KOLD = KPRM - END IF - END IF -C REPLICATION PROCESSING - IF (LF.EQ.1) THEN -C ---------- F1 --------- - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - KDATA(IPTR(17),KPRM) = 0 -C PRINT *,'FI6701-1',KPRM,MSTACK(1,KPRM), -C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM) - CALL FI6705(IPTR,IDENT,MSGA,IWORK,LX,LY, - * KDATA,LL,KNR,MSTACK) - IF (IPTR(1).NE.0) THEN - RETURN - ELSE - GO TO 12 - END IF -C -C DATA DESCRIPTION OPERATORS - ELSE IF (LF.EQ.2)THEN - IF (LX.EQ.5) THEN - ELSE IF (LX.EQ.4) THEN - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - KDATA(IPTR(17),KPRM) = 0 -C PRINT *,'FI6701-2',KPRM,MSTACK(1,KPRM), -C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM) - END IF - CALL FI6706 (IPTR,LX,LY,IDENT,MSGA,KDATA,IVALS,MSTACK, - * MWIDTH,MREF,MSCALE,J,LL,KDESC,IWORK,JDESC) - IF (IPTR(1).NE.0) THEN - RETURN - END IF - GO TO 12 -C DESCRIPTOR SEQUENCE STRINGS - ELSE IF (LF.EQ.3) THEN -C PRINT *,'F3 SEQUENCE DESCRIPTOR' - IF (IPTR(22).EQ.0) THEN -C READ IN TABLE D, BUT JUST ONCE - IERR = 0 -C PRINT *,' READING TABLE D' - DO 50 I = 1, 500 - READ(21,15,ERR=9998,END=75 ) - * (IHOLD(J),J=1,33) - 15 FORMAT(11(I1,I2,I3,1X),3X) - IPTR(20) = I - DO 25 JJ = 1, 31, 3 - KK = (JJ/3) + 1 - ITBLD(I,KK) = IHOLD(JJ)*16384 + - * IHOLD(JJ+1)*256 + IHOLD(JJ+2) - IF (ITBLD(I,KK).EQ.0) THEN -C PRINT 16,(ITBLD(I,L),L=1,11) - GO TO 50 - END IF - 25 CONTINUE -C PRINT 16,(ITBLD(I,L),L=1,11) - 50 CONTINUE - 16 FORMAT(1X,11(I6,1X)) - 75 CONTINUE - CLOSE(UNIT=21,STATUS='KEEP') - IPTR(22) = 1 - ENDIF - CALL FI6707(IPTR,IWORK,ITBLD,JDESC) - IF (IPTR(1).GT.0) THEN - RETURN - END IF - GO TO 14 -C -C STANDARD DESCRIPTOR PROCESSING - ELSE -C PRINT *,'ENTRY',IPTR(31),JDESC,' AT',IPTR(25) - KPRM = IPTR(31) + IPTR(24) - CALL FI6702(IPTR,IDENT,MSGA,KDATA,KDESC,LL,MSTACK, - * AUNITS,MWIDTH,MREF,MSCALE,JDESC,IVALS,J) -C TURN OFF SKIP FLAG AFTER STD DESCRIPTOR - IPTR(36) = 0 - IF (IPTR(1).GT.0) THEN - RETURN - ELSE - IF (IDENT(16).EQ.0) THEN - KNR(IPTR(17)) = IPTR(31) - ELSE - DO 310 KJ = 1, 500 - KNR(KJ) = IPTR(31) - 310 CONTINUE - END IF - GO TO 10 - END IF - END IF -C END IF -C END DO WHILE - 200 CONTINUE - IF (IDENT(16).NE.0) THEN -C PRINT *,'RETURN WITH',IDENT(14),' COMPRESSED REPORTS' - ELSE -C PRINT *,'RETURN WITH',IPTR(17),' NON-COMPRESSED REPORTS' - END IF - RETURN - 9998 CONTINUE - PRINT *,' ERROR READING TABLE D' - IPTR(1) = 8 - RETURN - 9999 CONTINUE - PRINT *,' ERROR READING TABLE B' - IPTR(1) = 9 - RETURN - END -C ----------------------------------------------------- - SUBROUTINE FI6702(IPTR,IDENT,MSGA,KDATA,KDESC,LL,MSTACK,AUNITS, - * MWIDTH,MREF,MSCALE,JDESC,IVALS,J) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI6702 PROCESS STANDARD DESCRIPTOR -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01 -C -C ABSTRACT: PROCESS A STANDARD DESCRIPTOR (F = 0) AND STORE DATA -C IN OUTPUT ARRAY. -C -C PROGRAM HISTORY LOG: -C 88-09-01 CAVANAUGH -C 91-04-04 CAVANAUGH CHANGED TO PASS WIDTH OF TEXT FIELDS IN BYTES -C -C USAGE: CALL FI6702(IPTR,IDENT,MSGA,KDATA,KDESC,LL,MSTACK,AUNITS, -C MWIDTH,MREF,MSCALE,JDESC,IVALS,J) -C INPUT ARGUMENT LIST: -C IPTR - SEE W3FI67 ROUTINE DOCBLOCK -C IDENT - SEE W3FI67 ROUTINE DOCBLOCK -C MSGA - ARRAY CONTAINING BUFR MESSAGE -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C KDESC - IMAGE OF CURRENT DESCRIPTOR -C ANAME - LIST OF NAME OF DESCRIPTOR CONTENTS -C MSTACK - -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KDATA - SEE ABOVE -C KDESC - SEE ABOVE -C ARRAYS CONTAINING DATA FROM TABLE B -C AUNITS - UNITS FOR DESCRIPTOR -C MSCALE - SCALE FOR VALUE OF DESCRIPTOR -C MREF - REFERENCE VALUE FOR DESCRIPTOR -C MWIDTH - BIT WIDTH FOR VALUE OF DESCRIPTOR -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - FI6703 FI6704 -C -C REMARKS: ERROR RETURN: -C IPTR(1) = 3 - MESSAGE CONTAINS A DESCRIPTOR WITH F=0 -C THAT DOES NOT EXIST IN TABLE B. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ - SAVE -C TABLE B ENTRY - CHARACTER*24 ASKEY - CHARACTER*24 AUNITS(*) -C TABLE B ENTRY - INTEGER MSGA(*) - INTEGER IPTR(*) - INTEGER IDENT(*) - INTEGER J - INTEGER JDESC - INTEGER KDESC(*) - INTEGER MWIDTH(*),MSTACK(2,*),MSCALE(*) - INTEGER MREF(700,3),KDATA(500,*),IVALS(*) -C TABLE B ENTRY -C - DATA ASKEY /'CCITT IA5 '/ -C -C PRINT *,' FI6702 - STANDARD DESCRIPTOR PROCESSOR' -C GET A MATCH BETWEEN CURRENT -C DESCRIPTOR (JDESC) AND -C TABLE B ENTRY -C IF (KDESC(356).EQ.0) THEN -C PRINT *,'FI6702 - KDESC(356) WENT TO ZER0' -C IPTR(1) = 600 -C RETURN -C END IF - K = 1 - KK = IPTR(14) - IF (JDESC.GT.KDESC(KK)) THEN - K = KK + 1 - END IF - 10 CONTINUE - IF (K.GT.KK) THEN - IF (IPTR(36).NE.0) THEN -C HAVE SKIP FLAG - IF (IDENT(16).NE.0) THEN -C SKIP OVER COMPRESSED DATA -C LOWEST - IPTR(25) = IPTR(25) + IPTR(36) -C NBINC - CALL GBYTE (MSGA,IHOLD,IPTR(25),6) - IPTR(25) = IPTR(25) + 6 - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - DO 50 I = 1, IPTR(14) - KDATA(I,KPRM) = 99999 - 50 CONTINUE -C PROCESS DIFFERENCES - IF (IHOLD.NE.0) THEN - IBITS = IHOLD * IDENT(14) - IPTR(25) = IPTR(25) + IBITS - END IF - ELSE - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - KDATA(IPTR(17),KPRM) = 99999 -C SKIP OVER NON-COMPRESSED DATA -C PRINT *,'SKIP NON-COMPRESSED DATA' - IPTR(25) = IPTR(25) + IPTR(36) - END IF - RETURN - ELSE - PRINT *,'FI6702 - ERROR = 3' - PRINT *,JDESC,K,KK,J,KDESC(J) - PRINT *,' ' - PRINT *,'TABLE B' - DO 20 LL = 1, IPTR(14) - PRINT *,LL,KDESC(LL) - 20 CONTINUE - IPTR(1) = 3 - RETURN - END IF - ELSE - J = ((KK - K) / 2) + K - END IF - IF (JDESC.EQ.KDESC(K)) THEN - J = K - GO TO 15 - ELSE IF (JDESC.EQ.KDESC(KK))THEN - J = KK - GO TO 15 - ELSE IF (JDESC.LT.KDESC(J)) THEN - K = K + 1 - KK = J - 1 - GO TO 10 - ELSE IF (JDESC.GT.KDESC(J)) THEN - K = J + 1 - KK = KK - 1 - GO TO 10 - END IF - 15 CONTINUE -C HAVE A MATCH -C SET FLAG IF TEXT EVENT - IF (ASKEY(1:9).EQ.AUNITS(J)(1:9)) THEN - IPTR(18) = 1 - IPTR(40) = MWIDTH(J) / 8 - ELSE - IPTR(18) = 0 - END IF - IF (IDENT(16).NE.0) THEN -C COMPRESSED - CALL FI6703(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK, - * MWIDTH,MREF,MSCALE,J,JDESC) - IF (IPTR(1).NE.0) THEN - RETURN - END IF - ELSE -C NOT COMPRESSED - CALL FI6704(IPTR,MSGA,KDATA,IVALS,MSTACK, - * MWIDTH,MREF,MSCALE,J,LL,JDESC) - END IF - RETURN - END -C ----------------------------------------------------- - SUBROUTINE FI6703(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK, - * MWIDTH,MREF,MSCALE,J,JDESC) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI6703 PROCESS COMPRESSED DATA -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01 -C -C ABSTRACT: PROCESS COMPRESSED DATA AND PLACE INDIVIDUAL ELEMENTS -C INTO OUTPUT ARRAY. -C -C PROGRAM HISTORY LOG: -C 88-09-01 CAVANAUGH -C 91-04-04 CAVANAUGH TEXT HANDLING PORTION OF THIS ROUTINE -C MODIFIED TO HANLE WIDTH OF FIELDS IN BYTES. -C 91-04-17 CAVANAUGH TESTS SHOWED THAT THE SAME DATA IN COMPRESSED -C AND UNCOMPRESSED FORM GAVE DIFFERENT RESULTS. -C THIS HAS BEEN CORRECTED. -C 91-06-21 CAVANAUGH PROCESSING OF TEXT DATA HAS BEEN CHANGED TO -C PROVIDE EXACT REPRODUCTION OF ALL CHARACTERS. -C -C USAGE: CALL FI6703(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK, -C MWIDTH,MREF,MSCALE,J,JDESC) -C INPUT ARGUMENT LIST: -C IPTR - SEE W3FI67 ROUTINE DOCBLOCK -C IDENT - SEE W3FI67 ROUTINE DOCBLOCK -C MSGA - ARRAY CONTAINING BUFR MESSAGE,MSTACK, -C IVALS - ARRAY OF SINGLE PARAMETER VALUES -C J - -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C J - -C ARRAYS CONTAINING DATA FROM TABLE B -C MSCALE - SCALE FOR VALUE OF DESCRIPTOR -C MREF - REFERENCE VALUE FOR DESCRIPTOR -C MWIDTH - BIT WIDTH FOR VALUE OF DESCRIPTOR -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - GBYTE GBYTES W3AI39 -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ - SAVE -C - INTEGER MSGA(*),JDESC,MSTACK(2,*) - INTEGER IPTR(*),IVALS(*),KDATA(500,*) - INTEGER NRVALS,JWIDE,IDATA - INTEGER IDENT(*) - INTEGER MSCALE(*) - INTEGER MREF(700,3) - INTEGER J - INTEGER MWIDTH(*) - INTEGER KLOW(256) -C - LOGICAL TEXT -C - INTEGER MSK(28) -C -C - DATA MSK /1,3,7,15,31,63,127, -C 1 2 3 4 5 6 7 - * 255,511,1023,2047,4095, -C 8 9 10 11 12 - * 8191,16383,32767,65535, -C 13 14 15 16 - * 131071,262143,524287, -C 17 18 19 - * 1048575,2097151,4194303, -C 20 21 22 - * 8388607,16777215,33554431, -C 23 24 25 - * 67108863,134217727,268435455/ -C 26 27 28 -C -C PRINT *,' FI6703 COMPR J=',J,' MWIDTH(J) =',MWIDTH(J), -C * ' EXTRA BITS =',IPTR(26),' START AT',IPTR(25) - IF (IPTR(18).EQ.0) THEN - TEXT = .FALSE. - ELSE - TEXT = .TRUE. - END IF -C PRINT *,'DESCRIPTOR',KPRM - IF (.NOT.TEXT) THEN - IF (IPTR(29).GT.0) THEN -C WORKING WITH ASSOCIATED FIELDS HERE - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) -C GET LOWEST - CALL GBYTE (MSGA,LOWEST,IPTR(25),IPTR(29)) - IPTR(25) = IPTR(25) + IPTR(29) -C GET NBINC - CALL GBYTE (MSGA,NBINC,IPTR(25),6) - IPTR(25) = IPTR(25) + 6 -C EXTRACT DATA FOR ASSOCIATED FIELD - IF (NBINC.GT.0) THEN - CALL GBYTES (MSGA,IVALS,IPTR(25),NBINC,0,IPTR(14)) - IPTR(25) = IPTR(25) + NBINC * IPTR(14) - DO 50 I = 1, IPTR(14) - KDATA(I,KPRM) = IVALS(I) + LOWEST - IF (KDATA(I,KPRM).GE.MSK(NBINC)) THEN - KDATA(I,KPRM) = 999999 - END IF - 50 CONTINUE - ELSE - DO 51 I = 1, IPTR(14) - IF (LOWEST.GE.MSK(NBINC)) THEN - KDATA(I,KPRM) = 999999 - ELSE - KDATA(I,KPRM) = LOWEST - END IF - 51 CONTINUE - END IF - END IF -C SET PARAMETER -C ISOLATE STANDARD BIT WIDTH - JWIDE = MWIDTH(J) + IPTR(26) -C SINGLE VALUE FOR LOWEST - NRVALS = 1 -C LOWEST -C PRINT *,'PARAM',KPRM - CALL GBYTE (MSGA,LOWEST,IPTR(25),JWIDE) -C PRINT *,' LOWEST=',LOWEST,' AT BIT LOC ',IPTR(25) - IPTR(25) = IPTR(25) + JWIDE -C ISOLATE COMPRESSED BIT WIDTH - CALL GBYTE (MSGA,NBINC,IPTR(25),6) -C PRINT *,' NBINC=',NBINC,' AT BIT LOC',IPTR(25) - IF (IPTR(32).EQ.2.AND.IPTR(33).EQ.5) THEN - ELSE - IF (NBINC.GT.JWIDE) THEN -C PRINT *,'FOR DESCRIPTOR',JDESC -C PRINT *,J,'NBINC=',NBINC,' LOWEST=',LOWEST,' MWIDTH(J)=', -C * MWIDTH(J),' IPTR(26)=',IPTR(26),' AT BIT LOC',IPTR(25) -C DO 110 I = 1, KPRM -C WRITE (6,111)I,(KDATA(J,I),J=1,6) -C 110 CONTINUE - 111 FORMAT (1X,5HDATA ,I3,6(2X,I10)) - IPTR(1) = 500 -C RETURN - PRINT *,'NBINC CALLS FOR LARGER BIT WIDTH THAN TABLE', - * ' B PLUS WIDTH CHANGES' - END IF - END IF - IPTR(25) = IPTR(25) + 6 -C PRINT *,'LOWEST',LOWEST,' NBINC=',NBINC -C IF TEXT EVENT, PROCESS TEXT -C GET COMPRESSED VALUES -C PRINT *,'COMPRESSED VALUES - NONTEXT' - NRVALS = IDENT(14) - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - IF (NBINC.NE.0) THEN - CALL GBYTES (MSGA,IVALS,IPTR(25),NBINC,0,NRVALS) - IPTR(25) = IPTR(25) + NBINC * NRVALS -C RECALCULATE TO ORIGINAL VALUES - DO 100 I = 1, NRVALS -C PRINT *,IVALS(I),MSK(NBINC),NBINC - IF (IVALS(I).GE.MSK(NBINC)) THEN - KDATA(I,KPRM) = 999999 - ELSE - IF (MREF(J,2).EQ.0) THEN - KDATA(I,KPRM) = IVALS(I) + LOWEST + MREF(J,1) - ELSE - KDATA(I,KPRM) = IVALS(I) + LOWEST + MREF(J,3) - END IF - END IF - 100 CONTINUE -C PRINT *,I,JDESC,LOWEST,MREF(J,1),MREF(J,3) -C PRINT *,I,JDESC,(IVALS(K),K=1,8) - ELSE - IF (LOWEST.EQ.MSK(MWIDTH(J))) THEN - DO 105 I = 1, NRVALS - KDATA(I,KPRM) = 999999 - 105 CONTINUE - ELSE - IF (MREF(J,2).EQ.0) THEN - ICOMB = LOWEST + MREF(J,1) - ELSE - ICOMB = LOWEST + MREF(J,3) - END IF - DO 106 I = 1, NRVALS - KDATA(I,KPRM) = ICOMB - 106 CONTINUE - END IF - END IF -C PRINT *,'KPRM=',KPRM,' IPTR(25)=',IPTR(25) - MSTACK(1,KPRM) = JDESC - IF (IPTR(27).NE.0) THEN - MSTACK(2,KPRM) = IPTR(27) - ELSE - MSTACK(2,KPRM) = MSCALE(J) - END IF -C WRITE (6,80) (DATA(I,KPRM),I=1,10) -C 80 FORMAT(2X,10(F10.2,1X)) - ELSE IF (TEXT) THEN -C PRINT *,' FOUND TEXT MODE IN COMPRESSED DATA',IPTR(40) -C GET LOWEST -C PRINT *,' PICKED UP LOWEST',(KLOW(K),K=1,IPTR(40)) - DO 1906 K = 1, IPTR(40) - CALL GBYTE (MSGA,KLOW,IPTR(25),8) - IPTR(25) = IPTR(25) + 8 - IF (KLOW(K).NE.0) THEN - IPTR(1) = 27 - PRINT *,'NON-ZERO LOWEST ON TEXT DATA' - RETURN - END IF - 1906 CONTINUE -C GET NBINC - CALL GBYTE (MSGA,NBINC,IPTR(25),6) -C PRINT *,'NBINC =',NBINC - IPTR(25) = IPTR(25) + 6 - IF (NBINC.NE.IPTR(40)) THEN - IPTR(1) = 28 - PRINT *,'NBINC IS NOT THE NUMBER OF CHARACTERS',NBINC - RETURN - END IF -C FOR NUMBER OF OBSERVATIONS - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - ISTART = KPRM - I24 = IPTR(24) - DO 1900 N = 1, IDENT(14) - KPRM = ISTART - IPTR(24) = I24 - NBITS = IPTR(40) * 8 - 1700 CONTINUE -C PRINT *,N,IDENT(14),'KPRM-B=',KPRM,IPTR(24),NBITS - IF (NBITS.GT.32) THEN - CALL GBYTE (MSGA,IDATA,IPTR(25),32) - IPTR(25) = IPTR(25) + 32 - NBITS = NBITS - 32 -C CONVERTS ASCII TO EBCIDIC -C COMMENT OUT IF NOT IBM370 COMPUTER -C PRINT *,IDATA - CALL W3AI39 (IDATA,4) - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - KDATA(N,KPRM) = IDATA -C SET FOR NEXT PART - KPRM = KPRM + 1 - IPTR(24) = IPTR(24) + 1 -C PRINT 1701,1,KDATA(N,KPRM),N,KPRM,NBITS,IDATA - 1701 FORMAT (1X,I1,1X,6HKDATA=,A4,2X,I5,2X,I5,2X,I5,2X,I12) - GO TO 1700 - ELSE IF (NBITS.GT.0) THEN - CALL GBYTE (MSGA,IDATA,IPTR(25),NBITS) - IPTR(25) = IPTR(25) + NBITS - IBUF = (32 - NBITS) / 8 - IF (IBUF.GT.0) THEN - DO 1750 MP = 1, IBUF - IDATA = IDATA * 256 + 32 - 1750 CONTINUE - END IF -C CONVERTS ASCII TO EBCIDIC -C COMMENT OUT IF NOT IBM370 COMPUTER - CALL W3AI39 (IDATA,4) - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - KDATA(N,KPRM) = IDATA -C PRINT 1701,2,KDATA(N,KPRM),N,KPRM,NBITS - NBITS = 0 - END IF -C WRITE (6,1800)N,(KDATA(N,I),I=KPRS,KPRM) -C1800 FORMAT (2X,I4,2X,3A4) - 1900 CONTINUE - END IF - RETURN - END -C ----------------------------------------------------- - SUBROUTINE FI6704(IPTR,MSGA,KDATA,IVALS,MSTACK, - * MWIDTH,MREF,MSCALE,J,LL,JDESC) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI6704 PROCESS SERIAL DATA -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01 -C -C ABSTRACT: PROCESS DATA THAT IS NOT COMPRESSED -C -C PROGRAM HISTORY LOG: -C 88-09-01 CAVANAUGH -C 91-01-18 CAVANAUGH MODIFIED TO PROPERLY HANDLE NON-COMPRESSED -C DATA. -C 91-04-04 CAVANAUGH TEXT HANDLING PORTION OF THIS ROUTINE -C MODIFIED TO HANDLE FIELD WIDTH IN BYTES. -C 91-04-17 CAVANAUGH TESTS SHOWED THAT THE SAME DATA IN COMPRESSED -C AND UNCOMPRESSED FORM GAVE DIFFERENT RESULTS. -C THIS HAS BEEN CORRECTED. -C -C USAGE: CALL FI6704(IPTR,MSGA,KDATA,IVALS,MSTACK, -C MWIDTH,MREF,MSCALE,J,LL,JDESC) -C INPUT ARGUMENT LIST: -C IPTR - SEE W3FI67 ROUTINE DOCBLOCK -C MSGA - ARRAY CONTAINING BUFR MESSAGE -C IVALS - ARRAY OF SINGLE PARAMETER VALUES -C J - -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C IVALS - SEE ABOVE -C J - SEE ABOVE -C ARRAYS CONTAINING DATA FROM TABLE B -C MSCALE - SCALE FOR VALUE OF DESCRIPTOR -C MREF - REFERENCE VALUE FOR DESCRIPTOR -C MWIDTH - BIT WIDTH FOR VALUE OF DESCRIPTOR -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - GBYTE -C -C REMARKS: ERROR RETURN: -C IPTR(1) = 13 - BIT WIDTH ON ASCII CHARS NOT A MULTIPLE OF 8 -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ - SAVE -C - INTEGER MSGA(*) - INTEGER IPTR(*),MREF(700,3),MSCALE(*) - INTEGER MWIDTH(*),JDESC - INTEGER IVALS(*) - INTEGER LSTBLK(3) - INTEGER KDATA(500,*),MSTACK(2,*) - INTEGER J,LL - LOGICAL LKEY -C -C - INTEGER ITEST(30) - DATA ITEST /1,3,7,15,31,63,127,255, - * 511,1023,2047,4095,8191,16383, - * 32767, 65535,131071,262143,524287, - * 1048575,2097151,4194303,8388607, - * 16777215,33554431,67108863,134217727, - * 268435455,536870911,1073741823/ -C -C PRINT *,' FI6704 NOCMP',J,JDESC,MWIDTH(J),IPTR(26),IPTR(25) - IF ((IPTR(26)+MWIDTH(J)).LT.1) THEN - IPTR(1) = 501 - RETURN - END IF -C -------- NOCMP -------- -C ISOLATE BIT WIDTH - JWIDE = MWIDTH(J) + IPTR(26) -C IF NOT TEXT EVENT, PROCESS - IF (IPTR(18).NE.1) THEN -C IF ASSOCIATED FIELD SW ON - IF (IPTR(29).GT.0) THEN - IF (JDESC.NE.7957.AND.JDESC.NE.7937) THEN - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = 33792 + IPTR(29) - MSTACK(2,KPRM) = 0 - CALL GBYTE (MSGA,IVALS,IPTR(25),IPTR(29)) - IPTR(25) = IPTR(25) + IPTR(29) - KDATA(IPTR(17),KPRM) = IVALS(1) -C PRINT *,'FI6704-A',KPRM,MSTACK(1,KPRM), -C * MSTACK(2,KPRM),IPTR(17),KDATA(IPTR(17),KPRM) - END IF - END IF - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = JDESC - IF (IPTR(27).NE.0) THEN - MSTACK(2,KPRM) = IPTR(27) - ELSE - MSTACK(2,KPRM) = MSCALE(J) - END IF -C GET VALUES -C CALL TO GET DATA OF GIVEN BIT WIDTH - CALL GBYTE (MSGA,IVALS,IPTR(25),JWIDE) -C PRINT *,'DATA TO',IPTR(17),KPRM,IVALS(1),JWIDE,IPTR(25) - IPTR(25) = IPTR(25) + JWIDE -C RETURN WITH SINGLE VALUE - IF (IVALS(1).EQ.ITEST(JWIDE)) THEN - KDATA(IPTR(17),KPRM) = 999999 - ELSE - IF (MREF(J,2).EQ.0) THEN - KDATA(IPTR(17),KPRM) = IVALS(1) + MREF(J,1) - ELSE - KDATA(IPTR(17),KPRM) = IVALS(1) + MREF(J,3) - END IF - END IF -C PRINT *,'FI6704-B',KPRM,MSTACK(1,KPRM), -C * MSTACK(2,KPRM),IPTR(17),KDATA(IPTR(17),KPRM) -C IF(JDESC.EQ.2049) THEN -C PRINT *,'VERT SIG =',KDATA(IPTR(17),KPRM) -C END IF -C PRINT *,'FI6704 ',KPRM,MSTACK(1,KPRM), -C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM) - ELSE -C IF TEXT EVENT, PROCESS TEXT -C PRINT *,' FOUND TEXT MODE ****** NOT COMPRESSED *********' - NRCHRS = IPTR(40) - NRBITS = NRCHRS * 8 -C PRINT *,'CHARS =',NRCHRS,' BITS =',NRBITS - IPTR(31) = IPTR(31) + 1 - KANY = 0 - 1800 CONTINUE - KANY = KANY + 1 - IF (NRBITS.GT.32) THEN - CALL GBYTE (MSGA,IDATA,IPTR(25),32) -C PRINT 1801,KANY,IDATA,IPTR(17),KPRM -C1801 FORMAT (1X,I2,4X,Z8,2(4X,I4)) -C CONVERTS ASCII TO EBCIDIC -C COMMENT OUT IF NOT IBM370 COMPUTER - CALL W3AI39 (IDATA,4) - KPRM = IPTR(31) + IPTR(24) - KDATA(IPTR(17),KPRM) = IDATA - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 -C PRINT *,KPRM,MSTACK(1,KPRM),MSTACK(2,KPRM), -C * KDATA(IPTR(17),KPRM) - IPTR(25) = IPTR(25) + 32 - NRBITS = NRBITS - 32 - IPTR(24) = IPTR(24) + 1 - GO TO 1800 - ELSE IF (NRBITS.GT.0) THEN -C PRINT *,'LAST TEXT WORD' - CALL GBYTE (MSGA,IDATA,IPTR(25),NRBITS) - IPTR(25) = IPTR(25) + NRBITS -C CONVERTS ASCII TO EBCIDIC -C COMMENT OUT IF NOT IBM370 COMPUTER - CALL W3AI39 (IDATA,4) - KPRM = IPTR(31) + IPTR(24) - KSHFT = 32 - NRBITS - IF (KSHFT.GT.0) THEN - KTRY = KSHFT / 8 - DO 1722 LAK = 1, KTRY - IDATA = IDATA * 256 + 64 -C PRINT 1723,IDATA - 1723 FORMAT (12X,Z8) - 1722 CONTINUE - END IF - KDATA(IPTR(17),KPRM) = IDATA -C PRINT 1801,KANY,IDATA,KDATA(IPTR(17),KPRM),KPRM - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 -C PRINT *,KPRM,MSTACK(1,KPRM),MSTACK(2,KPRM), -C * KDATA(IPTR(17),KPRM) - END IF -C TURN OFF TEXT - IPTR(18) = 0 - END IF - RETURN - END -C ----------------------------------------------------- - SUBROUTINE FI6705(IPTR,IDENT,MSGA,IWORK,LX,LY, - * KDATA,LL,KNR,MSTACK) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI6705 PROCESS A REPLICATION DESCRIPTOR -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01 -C -C ABSTRACT: PROCESS A REPLICATION DESCRIPTOR, MUST EXTRACT NUMBER -C OF REPLICATIONS OF N DESCRIPTORS FROM THE DATA STREAM. -C -C PROGRAM HISTORY LOG: -C 88-09-01 CAVANAUGH -C YY-MM-DD MODIFIER2 DESCRIPTION OF CHANGE -C -C USAGE: CALL FI6705(IPTR,IDENT,MSGA,IWORK,LX,LY, -C * KDATA,LL,KNR,MSTACK) -C INPUT ARGUMENT LIST: -C IWORK - WORKING DESCRIPTOR LIST -C IPTR - SEE W3FI67 ROUTINE DOCBLOCK -C IDENT - SEE W3FI67 ROUTINE DOCBLOCK -C LX - X PORTION OF CURRENT DESCRIPTOR -C LY - Y PORTION OF CURRENT DESCRIPTOR -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C LX - SEE ABOVE -C LY - SEE ABOVE -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - GBYTES FI6708 -C -C REMARKS: ERROR RETURN: -C IPTR(1) = 12 DATA DESCRIPTOR QUALIFIER DOES NOT FOLLOW -C DELAYED REPLICATION DESCRIPTOR -C = 20 EXCEEDED COUNT FOR DELAYED REPLICATION PASS -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ - SAVE -C - INTEGER IPTR(*),KNR(*) - INTEGER ITEMP(1600),LL - INTEGER KTEMP(1600) - INTEGER KDATA(500,*) - INTEGER LX,MSTACK(2,*) - INTEGER LY - INTEGER MSGA(*),KVALS(500) - INTEGER IWORK(*) - INTEGER IDENT(*) -C -C PRINT *,' REPLICATION FI6705' -C DO 100 I = 1, IPTR(13) -C PRINT *,I,IWORK(I) -C 100 CONTINUE -C NUMBER OF DESCRIPTORS - NRSET = LX -C NUMBER OF REPLICATIONS - NRREPS = LY - ICURR = IPTR(11) - 1 - IPICK = IPTR(11) - 1 -C - IF (NRREPS.EQ.0) THEN - IPTR(39) = 1 -C SAVE PRIMARY DELAYED REPLICATION DESCRIPTOR -C IPTR(31) = IPTR(31) + 1 -C KPRM = IPTR(31) + IPTR(24) -C MSTACK(1,KPRM) = JDESC -C MSTACK(2,KPRM) = 0 -C KDATA(IPTR(17),KPRM) = 0 -C PRINT *,'FI6705-1',KPRM,MSTACK(1,KPRM), -C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM) -C DELAYED REPLICATION - MUST GET NUMBER OF -C REPLICATIONS FROM DATA. -C GET NEXT DESCRIPTOR - CALL FI6708(IPTR,IWORK,LF,LX,LY,JDESC) -C PRINT *,' DELAYED REPLICATION',LF,LX,LY,JDESC -C MUST BE DATA DESCRIPTION -C OPERATION QUALIFIER - IF (JDESC.EQ.7937.OR.JDESC.EQ.7947) THEN - JWIDE = 8 - ELSE IF (JDESC.EQ.7938.OR.JDESC.EQ.7948) THEN - JWIDE = 16 - ELSE - IPTR(1) = 12 - RETURN - END IF - -C SET SINGLE VALUE FOR SEQUENTIAL, -C MULTIPLE VALUES FOR COMPRESSED - IF (IDENT(16).EQ.0) THEN -C NON COMPRESSED - CALL GBYTE (MSGA,KVALS,IPTR(25),JWIDE) -C PRINT *,LF,LX,LY,JDESC,' NR OF REPLICATIONS',KVALS(1) - IPTR(25) = IPTR(25) + JWIDE - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - KDATA(IPTR(17),KPRM) = KVALS(1) - NRREPS = KVALS(1) -C PRINT *,'FI6705-2',KPRM,MSTACK(1,KPRM), -C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM) - ELSE - NRVALS = IDENT(14) - CALL GBYTES (MSGA,KVALS,IPTR(25),JWIDE,0,NRVALS) - IPTR(25) = IPTR(25) + JWIDE * NRVALS - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - KDATA(IPTR(17),KPRM) = KVALS(1) - DO 100 I = 1, NRVALS - KDATA(I,KPRM) = KVALS(I) - 100 CONTINUE - NRREPS = KVALS(1) - END IF - ELSE -C PRINT *,'NOT DELAYED REPLICATION' - END IF -C RESTRUCTURE WORKING STACK W/REPLICATIONS -C PRINT *,' SAVE OFF',NRSET,' DESCRIPTORS' -C PICK UP DESCRIPTORS TO BE REPLICATED - DO 1000 I = 1, NRSET - CALL FI6708(IPTR,IWORK,LF,LX,LY,JDESC) - ITEMP(I) = JDESC -C PRINT *,'REPLICATION ',I,ITEMP(I) - 1000 CONTINUE -C MOVE TRAILING DESCRIPTORS TO HOLD AREA - LAX = IPTR(12) - IPTR(11) + 1 -C PRINT *,LAX,' TRAILING DESCRIPTORS TO HOLD AREA',IPTR(11),IPTR(12) - DO 2000 I = 1, LAX - CALL FI6708(IPTR,IWORK,LF,LX,LY,JDESC) - KTEMP(I) = JDESC -C PRINT *,' ',I,KTEMP(I) - 2000 CONTINUE -C REPLICATIONS INTO ISTACK -C PRINT *,' MUST REPLICATE ',KX,' DESCRIPTORS',KY,' TIMES' -C PRINT *,'REPLICATIONS INTO STACK. LOC',ICURR - DO 4000 I = 1, NRREPS - DO 3000 J = 1, NRSET - IWORK(ICURR) = ITEMP(J) -C PRINT *,'FI6705 A',ICURR,IWORK(ICURR) - ICURR = ICURR + 1 - 3000 CONTINUE - 4000 CONTINUE -C PRINT *,' TO LOC',ICURR-1 -C RESTORE TRAILING DESCRIPTORS -C PRINT *,'TRAILING DESCRIPTORS INTO STACK. LOC',ICURR - DO 5000 I = 1, LAX - IWORK(ICURR) = KTEMP(I) -C PRINT *,'FI6705 B',ICURR,IWORK(ICURR) - ICURR = ICURR + 1 - 5000 CONTINUE - IPTR(12) = ICURR - 1 - IPTR(11) = IPICK - RETURN - END - SUBROUTINE FI6706 (IPTR,LX,LY,IDENT,MSGA,KDATA,IVALS,MSTACK, - * MWIDTH,MREF,MSCALE,J,LL,KDESC,IWORK,JDESC) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI6706 PROCESS OPERATOR DESCRIPTORS -C PRGMMR: CAVANAUGH ORG: W/NMCX42 DATE: 88-09-01 -C -C ABSTRACT: EXTRACT AND SAVE INDICATED CHANGE VALUES FOR USE -C UNTIL CHANGES ARE RESCINDED, OR EXTRACT TEXT STRINGS INDICATED -C THROUGH 2 05 YYY. -C -C PROGRAM HISTORY LOG: -C 88-09-01 CAVANAUGH -C 91-04-04 CAVANAUGH MODIFIED TO HANDLE DESCRIPTOR 2 05 YYY -C 91-05-10 CAVANAUGH CODING HAS BEEN ADDED TO PROCESS PROPOSED -C TABLE C DESCRIPTOR 2 06 YYY. -C 91-11-21 CAVANAUGH CODING HAS BEEN ADDED TO PROPERLY PROCESS -C TABLE C DESCRIPTOR 2 03 YYY, THE CHANGE -C TO NEW REFERENCE VALUE FOR SELECTED -C DESCRIPTORS. -C -C USAGE: CALL FI6706 (IPTR,LX,LY,IDENT,MSGA,KDATA,IVALS,MSTACK, -C * MWIDTH,MREF,MSCALE,J,LL,KDESC,IWORK,JDESC) -C INPUT ARGUMENT LIST: -C IPTR - SEE W3FI67 ROUTINE DOCBLOCK -C LX - X PORTION OF CURRENT DESCRIPTOR -C LY - Y PORTION OF CURRENT DESCRIPTOR -C -C OUTPUT ARGUMENT LIST: -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C ARRAYS CONTAINING DATA FROM TABLE B -C MSCALE - SCALE FOR VALUE OF DESCRIPTOR -C MREF - REFERENCE VALUE FOR DESCRIPTOR -C MWIDTH - BIT WIDTH FOR VALUE OF DESCRIPTOR -C -C REMARKS: ERROR RETURN: -C IPTR(1) = 5 - ERRONEOUS X VALUE IN DATA DESCRIPTOR OPERATOR -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ - SAVE - INTEGER IPTR(*),KDATA(500,*),IVALS(*) - INTEGER IDENT(*),IWORK(*) - INTEGER MSGA(*),MSTACK(2,*) - INTEGER MREF(700,3),KDESC(*) - INTEGER MSCALE(*),MWIDTH(*) - INTEGER J,JDESC - INTEGER LL - INTEGER LX - INTEGER LY -C -C PRINT *,' F2 - DATA DESCRIPTOR OPERATOR' - IF (LX.EQ.1) THEN -C CHANGE BIT WIDTH - IF (LY.EQ.0) THEN -C PRINT *,' RETURN TO NORMAL WIDTH' - IPTR(26) = 0 - ELSE -C PRINT *,' EXPAND WIDTH BY',LY-128,' BITS' - IPTR(26) = LY - 128 - END IF - ELSE IF (LX.EQ.2) THEN -C CHANGE SCALE - IF (LY.EQ.0) THEN -C RESET TO STANDARD SCALE - IPTR(27) = 0 - ELSE -C SET NEW SCALE - IPTR(27) = LY - 128 - END IF - ELSE IF (LX.EQ.3) THEN -C CHANGE REFERENCE VALUE -C FOR EACH OF THOSE DESCRIPTORS BETWEEN -C 2 03 YYY WHERE Y LT 255 AND -C 2 03 255, EXTRACT THE NEW REFERENCE -C VALUE (BIT WIDTH YYY) AND PLACE -C IN TERTIARY TABLE B REF VAL POSITION, -C SET FLAG IN SECONDARY REFVAL POSITION -C THOSE DESCRIPTORS DO NOT HAVE DATA -C ASSOCIATED WITH THEM, BUT ONLY -C IDENTIFY THE TABLE B ENTRIES THAT -C ARE GETTING NEW REFERENCE VALUES. - KYYY = LY - IF (KYYY.GT.0.AND.KYYY.LT.255) THEN -C START CYCLING THRU DESCRIPTORS UNTIL -C TERMINATE NEW REF VALS IS FOUND - 300 CONTINUE - CALL FI6708 (IPTR,IWORK,LF,LX,LY,JDESC) - IF (JDESC.EQ.33791) THEN -C IF 2 03 255 THEN RETURN - RETURN - ELSE -C FIND MATCHING TABLE B ENTRY - DO 500 LJ = 1, IPTR(14) - IF (JDESC.EQ.KDESC(LJ)) THEN -C TURN ON NEW REF VAL FLAG - MREF(LJ,2) = 1 -C INSERT NEW REF VAL - CALL GBYTE (MSGA,MREF(LJ,3),IPTR(25),KYYY) -C GO GET NEXT DESCRIPTOR - GO TO 300 - END IF - 500 CONTINUE -C MATCHING DESCRIPTOR NOT FOUND, ERROR ERROR - PRINT *,'2 03 YYY - MATCHING DESCRIPTOR NOT FOUND' - STOP 203 - END IF - ELSE IF (KYYY.EQ.0) THEN -C MUST TURN OFF ALL NEW -C REFERENCE VALUES - DO 400 I = 1, IPTR(14) - MREF(I,2) = 0 - 400 CONTINUE - END IF -C LX = 3 -C MUST BE CONCLUDED WITH Y=255 - ELSE IF (LX.EQ.4) THEN -C ASSOCIATED VALUES - IF (LY.EQ.0) THEN - IPTR(29) = 0 -C PRINT *,'RESET ASSOCIATED VALUES',IPTR(29) - ELSE - IPTR(29) = LY - IF (IWORK(IPTR(11)).NE.7957) THEN - PRINT *,'2 04 YYY NOT FOLLOWED BY 0 31 021' - IPTR(1) = 11 - END IF -C PRINT *,'SET ASSOCIATED VALUES',IPTR(29) - END IF - ELSE IF (LX.EQ.5) THEN -C PROCESS TEXT DATA - IPTR(40) = LY - IPTR(18) = 1 - IF (IDENT(16).EQ.0) THEN -C PRINT *,'2 05 YYY - TEXT - NONCOMPRESSED MODE' - CALL FI6704(IPTR,MSGA,KDATA,IVALS,MSTACK, - * MWIDTH,MREF,MSCALE,J,LL,JDESC) - ELSE -C PRINT *,'2 05 YYY - TEXT - COMPRESSED MODE' - CALL FI6703(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK, - * MWIDTH,MREF,MSCALE,J,JDESC) - IF (IPTR(1).NE.0) THEN - RETURN - END IF - ENDIF - IPTR(18) = 0 - ELSE IF (LX.EQ.6) THEN -C SKIP NEXT DESCRIPTOR -C SET TO PASS OVER DESCRIPTOR AND DATA -C IF DESCRIPTOR NOT IN TABLE B - IPTR(36) = LY -C PRINT *,'SET TO SKIP',LY,' BIT FIELD' - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = 34304 + LY - MSTACK(2,KPRM) = 0 - ELSE - IPTR(1) = 5 - ENDIF - RETURN - END - SUBROUTINE FI6707(IPTR,IWORK,ITBLD,JDESC) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI6707 PROCESS QUEUE DESCRIPTOR -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01 -C -C ABSTRACT: SUBSTITUTE DESCRIPTOR QUEUE FOR QUEUE DESCRIPTOR -C -C PROGRAM HISTORY LOG: -C 88-09-01 CAVANAUGH -C 91-04-17 CAVANAUGH IMPROVED HANDLING OF NESTED QUEUE DESCRIPTORS -C 91-05-28 CAVANAUGH IMPROVED HANDLING OF NESTED QUEUE DESCRIPTORS -C BASED ON TESTS WITH LIVE DATA. -C -C USAGE: CALL FI6707(IPTR,IWORK,ITBLD,JDESC) -C INPUT ARGUMENT LIST: -C IWORK - WORKING DESCRIPTOR LIST -C IPTR - SEE W3FI67 ROUTINE DOCBLOCK -C LAST - INDEX TO LAST DESCRIPTOR -C ITBLD - ARRAY CONTAINING DESCRIPTOR QUEUES -C JDESC - QUEUE DESCRIPTOR TO BE EXPANDED -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C ISTACK - SEE ABOVE -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - NONE -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ - SAVE -C - INTEGER IPTR(*),JDESC - INTEGER IWORK(*),IHOLD(1600) - INTEGER ITBLD(500,11) -C -C PRINT *,' FI6707 F3 ENTRY',IPTR(11),IPTR(12) -C SET FOR BINARY SEARCH IN TABLE D -C DO 2020 I = 1, IPTR(12) -C PRINT *,'ENTRY IWORK',I,IWORK(I) -C2020 CONTINUE - JLO = 1 - JHI = IPTR(20) -C PRINT *,'LOOKING FOR QUEUE DESCRIPTOR',JDESC - 10 CONTINUE - JMID = (JLO + JHI) / 2 -C PRINT *,JLO,ITBLD(JLO,1),JMID,ITBLD(JMID,1),JHI,ITBLD(JHI,1) -C - IF (JDESC.LT.ITBLD(JMID,1)) THEN - IF (JDESC.EQ.ITBLD(JLO,1)) THEN - JMID = JLO - GO TO 100 - ELSE - JLO = JLO + 1 - JHI = JMID - 1 - IF (JLO.GT.JMID) THEN - IPTR(1) = 4 - RETURN - END IF - GO TO 10 - END IF - ELSE IF (JDESC.GT.ITBLD(JMID,1)) THEN - IF (JDESC.EQ.ITBLD(JHI,1)) THEN - JMID = JHI - GO TO 100 - ELSE - JLO = JMID + 1 - JHI = JHI - 1 - IF (JLO.GT.JHI) THEN - IPTR(1) = 4 - RETURN - END IF - GO TO 10 - END IF - END IF - 100 CONTINUE -C HAVE TABLE D MATCH -C PRINT *,'D ',(ITBLD(JMID,LL),LL=1,11) -C PRINT *,'TABLE D TO IHOLD' - IK = 0 - JK = 0 - DO 200 KI = 2, 11 - IF (ITBLD(JMID,KI).NE.0) THEN - IK = IK + 1 - IHOLD(IK) = ITBLD(JMID,KI) -C PRINT *,IK,IHOLD(IK) - ELSE - GO TO 300 - END IF - 200 CONTINUE - 300 CONTINUE - KK = IPTR(11) - IF (KK.GT.IPTR(12)) THEN -C NOTHING MORE TO APPEND -C PRINT *,'NOTHING MORE TO APPEND' - ELSE -C APPEND TRAILING IWORK TO IHOLD -C PRINT *,'APPEND FROM ',KK,' TO',IPTR(12) - DO 500 I = KK, IPTR(12) - IK = IK + 1 - IHOLD(IK) = IWORK(I) - 500 CONTINUE - END IF -C RESET IHOLD TO IWORK -C PRINT *,' RESET IWORK STACK' - KK = IPTR(11) - 2 - DO 1000 I = 1, IK - KK = KK + 1 - IWORK(KK) = IHOLD(I) - 1000 CONTINUE - IPTR(12) = KK -C PRINT *,' FI6707 F3 EXIT ',IPTR(11),IPTR(12) -C DO 2000 I = 1, IPTR(12) -C PRINT *,'EXIT IWORK',I,IWORK(I) -C2000 CONTINUE -C RESET POINTERS - IPTR(11) = IPTR(11) - 1 - RETURN - END -C ----------------------------------------------------- - SUBROUTINE FI6708(IPTR,IWORK,LF,LX,LY,JDESC) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI6708 -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 89-01-17 -C -C ABSTRACT: -C -C PROGRAM HISTORY LOG: -C 88-09-01 CAVANAUGH -C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE -C -C USAGE: CALL FI6708(IPTR,IWORK,LF,LX,LY,JDESC) -C INPUT ARGUMENT LIST: -C IPTR - SEE W3FI67 ROUTINE DOCBLOCK -C IWORK - WORKING DESCRIPTOR LIST -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C IPTR - SEE ABOVE -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ - SAVE - INTEGER IPTR(*),IWORK(*),LF,LX,LY,JDESC -C -C PRINT *,' FI6708 NEW DESCRIPTOR PICKUP' - JDESC = IWORK(IPTR(11)) - LY = MOD(JDESC,256) - IPTR(34) = LY - LX = MOD((JDESC/256),64) - IPTR(33) = LX - LF = JDESC / 16384 - IPTR(32) = LF -C PRINT *,' CURRENT DESCRIPTOR BEING TESTED IS',LF,LX,LY - IPTR(11) = IPTR(11) + 1 - RETURN - END - SUBROUTINE FI6709(IDENT,MSTACK,KDATA,IPTR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI6709 REFORMAT PROFILER W HGT INCREMENTS -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 90-02-14 -C -C ABSTRACT: REFORMAT DECODED PROFILER DATA TO SHOW HEIGHTS INSTEAD OF -C HEIGHT INCREMENTS. -C -C PROGRAM HISTORY LOG: -C 90-02-14 CAVANAUGH -C -C USAGE: CALL FI6709(IDENT,MSTACK,KDATA,IPTR) -C INPUT ARGUMENT LIST: -C IDENT - ARRAY CONTAINS MESSAGE INFORMATION EXTRACTED FROM -C BUFR MESSAGE - -C IDENT( 1)-EDITION NUMBER (BYTE 4, SECTION 1) -C IDENT( 2)-ORIGINATING CENTER (BYTES 5-6, SECTION 1) -C IDENT( 3)-UPDATE SEQUENCE (BYTE 7, SECTION 1) -C IDENT( 4)- (BYTE 8, SECTION 1) -C IDENT( 5)-BUFR MESSAGE TYPE (BYTE 9, SECTION 1) -C IDENT( 6)-BUFR MSG SUB-TYPE (BYTE 10, SECTION 1) -C IDENT( 7)- (BYTES 11-12, SECTION 1) -C IDENT( 8)-YEAR OF CENTURY (BYTE 13, SECTION 1) -C IDENT( 9)-MONTH OF YEAR (BYTE 14, SECTION 1) -C IDENT(10)-DAY OF MONTH (BYTE 15, SECTION 1) -C IDENT(11)-HOUR OF DAY (BYTE 16, SECTION 1) -C IDENT(12)-MINUTE OF HOUR (BYTE 17, SECTION 1) -C IDENT(13)-RSVD BY ADP CENTERS(BYTE 18, SECTION 1) -C IDENT(14)-NR OF DATA SUBSETS (BYTE 5-6, SECTION 3) -C IDENT(15)-OBSERVED FLAG (BYTE 7, BIT 1, SECTION 3) -C IDENT(16)-COMPRESSION FLAG (BYTE 7, BIT 2, SECTION 3) -C MSTACK - WORKING DESCRIPTOR LIST AND SCALING FACTOR -C DATA - ARRAY CONTAINING DECODED REPORTS -C KSET2 - INTERIM DATA ARRAY -C KPROFL - INTERIM DESCRIPTOR ARRAY -C IPTR - SEE W3FI67 -C -C OUTPUT FILES: -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ - SAVE -C ---------------------------------------------------------------- -C - INTEGER ISW - INTEGER IDENT(*),KDATA(500,*) - INTEGER MSTACK(2,*),IPTR(*) - INTEGER KPROFL(500) - INTEGER KPROF2(500) - INTEGER KSET2(500) -C -C ---------------------------------------------------------- -C LOOP FOR NUMBER OF SUBSETS/REPORTS - DO 3000 I = 1, IDENT(14) -C INIT FOR DATA INPUT ARRAY - MK = 1 -C INIT FOR DESC OUTPUT ARRAY - JK = 0 -C LOCATION - ISW = 0 - DO 200 J = 1, 3 -C LATITUDE - IF (MSTACK(1,MK).EQ.1282) THEN - ISW = ISW + 1 - GO TO 100 -C LONGITUDE - ELSE IF (MSTACK(1,MK).EQ.1538) THEN - ISW = ISW + 2 - GO TO 100 -C HEIGHT ABOVE SEA LEVEL - ELSE IF (MSTACK(1,MK).EQ.1793) THEN - IHGT = KDATA(I,MK) - ISW = ISW + 4 - GO TO 100 - END IF - GO TO 200 - 100 CONTINUE - JK = JK + 1 -C SAVE DESCRIPTOR - KPROFL(JK) = MSTACK(1,MK) -C SAVE SCALE - KPROF2(JK) = MSTACK(2,MK) -C SAVE DATA - KSET2(JK) = KDATA(I,MK) - MK = MK + 1 - 200 CONTINUE - IF (ISW.NE.7) THEN - PRINT *,'LOCATION ERROR PROCESSING PROFILER' - IPTR(1) = 200 - RETURN - END IF -C TIME - ISW = 0 - DO 400 J = 1, 7 -C YEAR - IF (MSTACK(1,MK).EQ.1025) THEN - ISW = ISW + 1 - GO TO 300 -C MONTH - ELSE IF (MSTACK(1,MK).EQ.1026) THEN - ISW = ISW + 2 - GO TO 300 -C DAY - ELSE IF (MSTACK(1,MK).EQ.1027) THEN - ISW = ISW + 4 - GO TO 300 -C HOUR - ELSE IF (MSTACK(1,MK).EQ.1028) THEN - ISW = ISW + 8 - GO TO 300 -C MINUTE - ELSE IF (MSTACK(1,MK).EQ.1029) THEN - ISW = ISW + 16 - GO TO 300 -C TIME SIGNIFICANCE - ELSE IF (MSTACK(1,MK).EQ.2069) THEN - ISW = ISW + 32 - GO TO 300 - ELSE IF (MSTACK(1,MK).EQ.1049) THEN - ISW = ISW + 64 - GO TO 300 - END IF - GO TO 400 - 300 CONTINUE - JK = JK + 1 -C SAVE DESCRIPTOR - KPROFL(JK) = MSTACK(1,MK) -C SAVE SCALE - KPROF2(JK) = MSTACK(2,MK) -C SAVE DATA - KSET2(JK) = KDATA(I,MK) - MK = MK + 1 - 400 CONTINUE - IF (ISW.NE.127) THEN - PRINT *,'TIME ERROR PROCESSING PROFILER',ISW - IPTR(1) = 201 - RETURN - END IF -C SURFACE DATA - KRG = 0 - ISW = 0 - DO 600 J = 1, 10 -C WIND SPEED - IF (MSTACK(1,MK).EQ.2818) THEN - ISW = ISW + 1 - GO TO 500 -C WIND DIRECTION - ELSE IF (MSTACK(1,MK).EQ.2817) THEN - ISW = ISW + 2 - GO TO 500 -C PRESS REDUCED TO MSL - ELSE IF (MSTACK(1,MK).EQ.2611) THEN - ISW = ISW + 4 - GO TO 500 -C TEMPERATURE - ELSE IF (MSTACK(1,MK).EQ.3073) THEN - ISW = ISW + 8 - GO TO 500 -C RAINFALL RATE - ELSE IF (MSTACK(1,MK).EQ.3342) THEN - ISW = ISW + 16 - GO TO 500 -C RELATIVE HUMIDITY - ELSE IF (MSTACK(1,MK).EQ.3331) THEN - ISW = ISW + 32 - GO TO 500 -C 1ST RANGE GATE OFFSET - ELSE IF (MSTACK(1,MK).EQ.1982.OR. - * MSTACK(1,MK).EQ.1983) THEN -C CANNOT USE NORMAL PROCESSING FOR FIRST RANGE GATE, MUST SAVE -C VALUE FOR LATER USE - IF (MSTACK(1,MK).EQ.1983) THEN - IHGT = KDATA(I,MK) - MK = MK + 1 - KRG = 1 - ELSE - IF (KRG.EQ.0) THEN - INCRHT = KDATA(I,MK) - MK = MK + 1 - KRG = 1 -C PRINT *,'INITIAL INCR =',INCRHT - ELSE - LHGT = 500 + IHGT - KDATA(I,MK) - ISW = ISW + 64 -C PRINT *,'BASE HEIGHT=',LHGT,' INCR=',INCRHT - END IF - END IF -C MODE #1 - ELSE IF (MSTACK(1,MK).EQ.8128) THEN - ISW = ISW + 128 - GO TO 500 -C MODE #2 - ELSE IF (MSTACK(1,MK).EQ.8129) THEN - ISW = ISW + 256 - GO TO 500 - END IF - GO TO 600 - 500 CONTINUE -C SAVE DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = MSTACK(1,MK) -C SAVE SCALE - KPROF2(JK) = MSTACK(2,MK) -C SAVE DATA - KSET2(JK) = KDATA(I,MK) -C IF (I.EQ.1) THEN -C PRINT *,' ',JK,KPROFL(JK),KSET2(JK) -C END IF - MK = MK + 1 - 600 CONTINUE - 650 CONTINUE - IF (ISW.NE.511) THEN - PRINT *,'SURFACE ERROR PROCESSING PROFILER',ISW - IPTR(1) = 202 - RETURN - END IF -C 43 LEVELS - DO 2000 L = 1, 43 - 2020 CONTINUE - ISW = 0 -C HEIGHT INCREMENT - IF (MSTACK(1,MK).EQ.1982) THEN -C PRINT *,'NEW HEIGHT INCREMENT',KDATA(I,MK) - INCRHT = KDATA(I,MK) - MK = MK + 1 - IF (LHGT.LT.(9250+IHGT)) THEN - LHGT = IHGT + 500 - INCRHT - ELSE - LHGT = IHGT + 9250 - INCRHT - END IF - END IF -C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DATA -C AT THIS POINT - HEIGHT + INCREMENT + BASE VALUE - LHGT = LHGT + INCRHT -C PRINT *,'LEVEL ',L,LHGT - IF (L.EQ.37) THEN - LHGT = LHGT + INCRHT - END IF - JK = JK + 1 -C SAVE DESCRIPTOR - KPROFL(JK) = 1798 -C SAVE SCALE - KPROF2(JK) = 0 -C SAVE DATA - KSET2(JK) = LHGT -C IF (I.EQ.10) THEN -C PRINT *,' ' -C PRINT *,'HGT',JK,KPROFL(JK),KSET2(JK) -C END IF - ISW = 0 - DO 800 J = 1, 9 - 750 CONTINUE - IF (MSTACK(1,MK).EQ.1982) THEN - GO TO 2020 -C U VECTOR VALUE - ELSE IF (MSTACK(1,MK).EQ.3008) THEN - ISW = ISW + 1 - IF (KDATA(I,MK).GE.2047) THEN - VECTU = 32767 - ELSE - VECTU = KDATA(I,MK) - END IF - MK = MK + 1 - GO TO 800 -C V VECTOR VALUE - ELSE IF (MSTACK(1,MK).EQ.3009) THEN - ISW = ISW + 2 - IF (KDATA(I,MK).GE.2047) THEN - VECTV = 32767 - ELSE - VECTV = KDATA(I,MK) - END IF - MK = MK + 1 -C IF U VALUE IS ALSO AVAILABLE THEN GENERATE DDFFF -C DESCRIPTORS AND DATA - IF (IAND(ISW,1).NE.0) THEN - IF (VECTU.EQ.32767.OR.VECTV.EQ.32767) THEN -C SAVE DD DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = 2817 -C SAVE SCALE - KPROF2(JK) = 0 -C SAVE DD DATA - KSET2(JK) = 32767 -C SAVE FFF DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = 2818 -C SAVE SCALE - KPROF2(JK) = 1 -C SAVE FFF DATA - KSET2(JK) = 32767 - ELSE -C GENERATE DDFFF - CALL W3FC05 (VECTU,VECTV,DIR,SPD) - NDIR = DIR - SPD = SPD - NSPD = SPD -C PRINT *,' ',NDIR,NSPD -C SAVE DD DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = 2817 -C SAVE SCALE - KPROF2(JK) = 0 -C SAVE DD DATA - KSET2(JK) = DIR -C IF (I.EQ.1) THEN -C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK) -C END IF -C SAVE FFF DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = 2818 -C SAVE SCALE - KPROF2(JK) = 1 -C SAVE FFF DATA - KSET2(JK) = SPD -C IF (I.EQ.1) THEN -C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK) -C END IF - END IF - END IF - GO TO 800 -C W VECTOR VALUE - ELSE IF (MSTACK(1,MK).EQ.3010) THEN - ISW = ISW + 4 - GO TO 700 -C Q/C TEST RESULTS - ELSE IF (MSTACK(1,MK).EQ.8130) THEN - ISW = ISW + 8 - GO TO 700 -C U,V QUALITY IND - ELSE IF(IAND(ISW,16).EQ.0.AND.MSTACK(1,MK).EQ.2070) THEN - ISW = ISW + 16 - GO TO 700 -C W QUALITY IND - ELSE IF(IAND(ISW,32).EQ.0.AND.MSTACK(1,MK).EQ.2070) THEN - ISW = ISW + 32 - GO TO 700 -C SPECTRAL PEAK POWER - ELSE IF (MSTACK(1,MK).EQ.5568) THEN - ISW = ISW + 64 - GO TO 700 -C U,V VARIABILITY - ELSE IF (MSTACK(1,MK).EQ.3011) THEN - ISW = ISW + 128 - GO TO 700 -C W VARIABILITY - ELSE IF (MSTACK(1,MK).EQ.3013) THEN - ISW = ISW + 256 - GO TO 700 - ELSE IF ((MSTACK(1,MK)/16384).NE.0) THEN - MK = MK + 1 - GO TO 750 - END IF - GO TO 800 - 700 CONTINUE - JK = JK + 1 -C SAVE DESCRIPTOR - KPROFL(JK) = MSTACK(1,MK) -C SAVE SCALE - KPROF2(JK) = MSTACK(2,MK) -C SAVE DATA - KSET2(JK) = KDATA(I,MK) - MK = MK + 1 -C IF (I.EQ.1) THEN -C PRINT *,' ',JK,KPROFL(JK),KSET2(JK) -C END IF - 800 CONTINUE - 850 CONTINUE - IF (ISW.NE.511) THEN - PRINT *,'LEVEL ERROR PROCESSING PROFILER',ISW - IPTR(1) = 203 - RETURN - END IF - 2000 CONTINUE -C MOVE DATA BACK INTO KDATA ARRAY - DO 4000 LL = 1, JK - KDATA(I,LL) = KSET2(LL) - 4000 CONTINUE - 3000 CONTINUE -C PRINT *,'REBUILT ARRAY' - DO 5000 LL = 1, JK -C DESCRIPTOR - MSTACK(1,LL) = KPROFL(LL) -C SCALE - MSTACK(2,LL) = KPROF2(LL) -C PRINT *,LL,MSTACK(1,LL),(KDATA(I,LL),I=1,7) - 5000 CONTINUE -C MOVE REFORMATTED DESCRIPTORS TO MSTACK ARRAY - IPTR(31) = JK - RETURN - END - SUBROUTINE FI6710(IDENT,MSTACK,KDATA,IPTR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI6710 REFORMAT PROFILER EDITION 2 DATA -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-01-21 -C -C ABSTRACT: REFORMAT PROFILER DATA IN EDITION 2 -C -C PROGRAM HISTORY LOG: -C 93-01-27 CAVANAUGH -C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE -C -C USAGE: CALL FI6710(IDENT,MSTACK,KDATA,IPTR) -C INPUT ARGUMENT LIST: -C IDENT - ARRAY CONTAINS MESSAGE INFORMATION EXTRACTED FROM -C BUFR MESSAGE - -C IDENT( 1)-EDITION NUMBER (BYTE 4, SECTION 1) -C IDENT( 2)-ORIGINATING CENTER (BYTES 5-6, SECTION 1) -C IDENT( 3)-UPDATE SEQUENCE (BYTE 7, SECTION 1) -C IDENT( 4)- (BYTE 8, SECTION 1) -C IDENT( 5)-BUFR MESSAGE TYPE (BYTE 9, SECTION 1) -C IDENT( 6)-BUFR MSG SUB-TYPE (BYTE 10, SECTION 1) -C IDENT( 7)- (BYTES 11-12, SECTION 1) -C IDENT( 8)-YEAR OF CENTURY (BYTE 13, SECTION 1) -C IDENT( 9)-MONTH OF YEAR (BYTE 14, SECTION 1) -C IDENT(10)-DAY OF MONTH (BYTE 15, SECTION 1) -C IDENT(11)-HOUR OF DAY (BYTE 16, SECTION 1) -C IDENT(12)-MINUTE OF HOUR (BYTE 17, SECTION 1) -C IDENT(13)-RSVD BY ADP CENTERS(BYTE 18, SECTION 1) -C IDENT(14)-NR OF DATA SUBSETS (BYTE 5-6, SECTION 3) -C IDENT(15)-OBSERVED FLAG (BYTE 7, BIT 1, SECTION 3) -C IDENT(16)-COMPRESSION FLAG (BYTE 7, BIT 2, SECTION 3) -C MSTACK - WORKING DESCRIPTOR LIST AND SCALING FACTOR -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C KSET2 - INTERIM DATA ARRAY -C KPROFL - INTERIM DESCRIPTOR ARRAY -C IPTR - SEE W3FI67 -C -C OUTPUT FILES: -C -C REMARKS: -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ - INTEGER ISW - INTEGER IDENT(*),KDATA(500,1600) - INTEGER MSTACK(2,1600),IPTR(*) - INTEGER KPROFL(1600) - INTEGER KPROF2(1600) - INTEGER KSET2(1600) -C LOOP FOR NUMBER OF SUBSETS - DO 3000 I = 1, IDENT(14) - MK = 1 - JK = 0 - ISW = 0 - DO 200 J = 1, 5 - IF (MSTACK(1,MK).EQ.257) THEN -C BLOCK NUMBER - ISW = ISW + 1 - ELSE IF (MSTACK(1,MK).EQ.258) THEN -C STATION NUMBER - ISW = ISW + 2 - ELSE IF (MSTACK(1,MK).EQ.1282) THEN -C LATITUDE - ISW = ISW + 4 - ELSE IF (MSTACK(1,MK).EQ.1538) THEN -C LONGITUDE - ISW = ISW + 8 - ELSE IF (MSTACK(1,MK).EQ.1793) THEN -C HEIGHT OF STATION - ISW = ISW + 16 - IHGT = KDATA(I,MK) - ELSE - MK = MK + 1 - GO TO 200 - END IF - JK = JK + 1 - KPROFL(JK) = MSTACK(1,MK) - KPROF2(JK) = MSTACK(2,MK) - KSET2(JK) = KDATA(I,MK) -C PRINT *,JK,KPROFL(JK),KSET2(JK) - MK = MK + 1 - 200 CONTINUE -C PRINT *,'LOCATION ',ISW - IF (ISW.NE.31) THEN - PRINT *,'LOCATION ERROR PROCESSING PROFILER' - IPTR(10) = 200 - RETURN - END IF -C PROCESS TIME ELEMENTS - ISW = 0 - DO 400 J = 1, 7 - IF (MSTACK(1,MK).EQ.1025) THEN -C YEAR - ISW = ISW + 1 - ELSE IF (MSTACK(1,MK).EQ.1026) THEN -C MONTH - ISW = ISW + 2 - ELSE IF (MSTACK(1,MK).EQ.1027) THEN -C DAY - ISW = ISW + 4 - ELSE IF (MSTACK(1,MK).EQ.1028) THEN -C HOUR - ISW = ISW + 8 - ELSE IF (MSTACK(1,MK).EQ.1029) THEN -C MINUTE - ISW = ISW + 16 - ELSE IF (MSTACK(1,MK).EQ.2069) THEN -C TIME SIGNIFICANCE - ISW = ISW + 32 - ELSE IF (MSTACK(1,MK).EQ.1049) THEN -C TIME DISPLACEMENT - ISW = ISW + 64 - ELSE - MK = MK + 1 - GO TO 400 - END IF - JK = JK + 1 - KPROFL(JK) = MSTACK(1,MK) - KPROF2(JK) = MSTACK(2,MK) - KSET2(JK) = KDATA(I,MK) -C PRINT *,JK,KPROFL(JK),KSET2(JK) - MK = MK + 1 - 400 CONTINUE -C PRINT *,'TIME ',ISW - IF (ISW.NE.127) THEN - PRINT *,'TIME ERROR PROCESSING PROFILER' - IPTR(1) = 201 - RETURN - END IF -C SURFACE DATA - ISW = 0 -C PRINT *,'SURFACE' - DO 600 K = 1, 8 - IF (MSTACK(1,MK).EQ.2817) THEN - ISW = ISW + 1 - ELSE IF (MSTACK(1,MK).EQ.2818) THEN - ISW = ISW + 2 - ELSE IF (MSTACK(1,MK).EQ.2611) THEN - ISW = ISW + 4 - ELSE IF (MSTACK(1,MK).EQ.3073) THEN - ISW = ISW + 8 - ELSE IF (MSTACK(1,MK).EQ.3342) THEN - ISW = ISW + 16 - ELSE IF (MSTACK(1,MK).EQ.3331) THEN - ISW = ISW + 32 - ELSE IF (MSTACK(1,MK).EQ.1797) THEN - INCRHT = KDATA(I,MK) - ISW = ISW + 64 -C PRINT *,'INITIAL INCREMENT = ',INCRHT - MK = MK + 1 - GO TO 600 - ELSE IF (MSTACK(1,MK).EQ.6433) THEN - ISW = ISW + 128 - ELSE - MK = MK + 1 - GO TO 600 - END IF - JK = JK + 1 - KPROFL(JK) = MSTACK(1,MK) - KPROF2(JK) = MSTACK(2,MK) - KSET2(JK) = KDATA(I,MK) -C PRINT *,JK,KPROFL(JK),KSET2(JK) - MK = MK + 1 - 600 CONTINUE - IF (ISW.NE.255) THEN - PRINT *,'ERROR PROCESSING PROFILER' - IPTR(1) = 204 - RETURN - END IF - IF (MSTACK(1,MK).NE.1797) THEN - PRINT *,'ERROR PROCESSING HEIGHT INCREMENT IN PROFILER' - IPTR(1) = 205 - RETURN - END IF -C MUST SAVE THIS HEIGHT VALUE - LHGT = 500 + IHGT - KDATA(I,MK) -C PRINT *,'BASE HEIGHT = ',LHGT,' INCR = ',INCRHT - MK = MK + 1 -C PROCESS LEVEL DATA - DO 2000 L = 1, 43 - 2020 CONTINUE - ISW = 0 -C HEIGHT INCREMENT - IF (MSTACK(1,MK).EQ.1797) THEN - INCRHT = KDATA(I,MK) -C PRINT *,'NEW HEIGHT INCREMENT = ',INCRHT - MK = MK + 1 - IF (LHGT.LT.(9250+IHGT)) THEN - LHGT = LHGT + 500 - INCRHT - ELSE - LHGT = LHGT + 9250 -INCRHT - END IF - END IF -C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DA -C AT THIS POINT - LHGT = LHGT + INCRHT -C PRINT *,'LEVEL ',L,LHGT - IF (L.EQ.37) THEN - LHGT = LHGT + INCRHT - END IF - JK = JK + 1 -C SAVE DESCRIPTOR - KPROFL(JK) = 1798 -C SAVE SCALE - KPROF2(JK) = 0 -C SAVE DATA - KSET2(JK) = LHGT -C PRINT *,JK,KPROFL(JK),KSET2(JK) - ISW = 0 - ICON = 1 - DO 800 J = 1, 10 -750 CONTINUE - IF (MSTACK(1,MK).EQ.1797) THEN - GO TO 2020 - ELSE IF (MSTACK(1,MK).EQ.6432) THEN -C HI/LO MODE - ISW = ISW + 1 - ELSE IF (MSTACK(1,MK).EQ.6434) THEN -C Q/C TEST - ISW = ISW + 2 - ELSE IF (MSTACK(1,MK).EQ.2070) THEN - IF (ICON.EQ.1) THEN -C FIRST PASS - U,V CONSENSUS - ISW = ISW + 4 - ICON = ICON + 1 - ELSE -C SECOND PASS - W CONSENSUS - ISW = ISW + 64 - END IF - ELSE IF (MSTACK(1,MK).EQ.2819) THEN -C U VECTOR VALUE - ISW = ISW + 8 - IF (KDATA(I,MK).GE.2047) THEN - VECTU = 32767 - ELSE - VECTU = KDATA(I,MK) - END IF - MK = MK + 1 - GO TO 800 - ELSE IF (MSTACK(1,MK).EQ.2820) THEN -C V VECTOR VALUE - ISW = ISW + 16 - IF (KDATA(I,MK).GE.2047) THEN - VECTV = 32767 - ELSE - VECTV = KDATA(I,MK) - END IF - IF (IAND(ISW,1).NE.0) THEN - IF (VECTU.EQ.32767.OR.VECTV.EQ.32767) THEN -C SAVE DD DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = 2817 - KPROF2(JK) = 0 - KSET2(JK) = 32767 -C SAVE FFF DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = 2818 - KPROF2(JK) = 1 - KSET2(JK) = 32767 - ELSE - CALL W3FC05 (VECTU,VECTV,DIR,SPD) - NDIR = DIR - SPD = SPD - NSPD = SPD -C PRINT *,' ',NDIR,NSPD -C SAVE DD DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = 2817 - KPROF2(JK) = 0 - KSET2(JK) = NDIR -C IF (I.EQ.1) THEN -C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK) -C ENDIF -C SAVE FFF DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = 2818 - KPROF2(JK) = 1 - KSET2(JK) = NSPD -C IF (I.EQ.1) THEN -C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK) -C ENDIF - END IF - MK = MK + 1 - GO TO 800 - END IF - ELSE IF (MSTACK(1,MK).EQ.2866) THEN -C SPEED STD DEVIATION - ISW = ISW + 32 -C -- A CHANGE BY KEYSER : POWER DESC. BACK TO 5568 - ELSE IF (MSTACK(1,MK).EQ.5568) THEN -C SIGNAL POWER - ISW = ISW + 128 - ELSE IF (MSTACK(1,MK).EQ.2822) THEN -C W COMPONENT - ISW = ISW + 256 - ELSE IF (MSTACK(1,MK).EQ.2867) THEN -C VERT STD DEVIATION - ISW = ISW + 512 - ELSE - MK = MK + 1 - GO TO 750 - END IF - JK = JK + 1 -C SAVE DESCRIPTOR - KPROFL(JK) = MSTACK(1,MK) -C SAVE SCALE - KPROF2(JK) = MSTACK(2,MK) -C SAVE DATA - KSET2(JK) = KDATA(I,MK) - MK = MK + 1 -C PRINT *,' ',JK,KPROFL(JK),KSET2(JK) - 800 CONTINUE - 850 CONTINUE - IF (ISW.NE.1023) THEN - PRINT *,'LEVEL ERROR PROCESSING PROFILER',ISW - IPTR(1) = 202 - RETURN - END IF - 2000 CONTINUE - DO 4000 LL = 1,JK - KDATA(I,LL) = KSET2(LL) - 4000 CONTINUE - 3000 CONTINUE -C MOVE DATA BACK INTO KDATA ARRAY - DO 5000 LL = 1, JK -C DESCRIPTOR - MSTACK(1,LL) = KPROFL(LL) -C SCALE - MSTACK(2,LL) = KPROF2(LL) -C DATA -C PRINT *,LL,MSTACK(1,LL),MSTACK(2,LL),(KDATA(I,LL),I=1,4) - 5000 CONTINUE - IPTR(31) = JK - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fi68.f b/src/fim/FIMsrc/w3/w3fi68.f deleted file mode 100644 index c9ec273..0000000 --- a/src/fim/FIMsrc/w3/w3fi68.f +++ /dev/null @@ -1,178 +0,0 @@ - SUBROUTINE W3FI68 (ID, PDS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI68 CONVERT 25 WORD ARRAY TO GRIB PDS -C PRGMMR: R.E.JONES ORG: W/NMC42 DATE: 91-05-14 -C -C ABSTRACT: CONVERTS AN ARRAY OF 25, OR 27 INTEGER WORDS INTO A -C GRIB PRODUCT DEFINITION SECTION (PDS) OF 28 BYTES , OR 30 BYTES. -C IF PDS BYTES > 30, THEY ARE SET TO ZERO. -C -C PROGRAM HISTORY LOG: -C 91-05-08 R.E.JONES -C 92-09-25 R.E.JONES CHANGE TO 25 WORDS OF INPUT, LEVEL -C CAN BE IN TWO WORDS. (10,11) -C 93-01-08 R.E.JONES CHANGE FOR TIME RANGE INDICATOR IF 10, -C STORE TIME P1 IN PDS BYTES 19-20. -C 93-01-26 R.E.JONES CORRECTION FOR FIXED HEIGHT ABOVE -C GROUND LEVEL -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C 93-06-24 CAVANOUGH MODIFIED PROGRAM TO ALLOW FOR GENERATION -C OF PDS GREATER THAN 28 BYTES (THE DESIRED -C PDS SIZE IS IN ID(1). -C 93-09-30 FARLEY CHANGE TO ALLOW FOR SUBCENTER ID; PUT -C ID(24) INTO PDS(26). -C 93-10-12 R.E.JONES CHANGES FOR ON388 REV. OCT 9,1993, NEW -C LEVELS 125, 200, 201. -C 94-02-23 R.E.JONES TAKE OUT SBYTES, REPLACE WITH DO LOOP -C 94-04-14 R.E.JONES CHANGES FOR ON388 REV. MAR 24,1994, NEW -C LEVELS 115,116. -C 94-12-04 R.E.JONES CHANGE TO ADD ID WORDS 26, 27 FOR PDS -C BYTES 29 AND 30. -C 95-09-07 R.E.JONES CHANGE FOR NEW LEVEL 117, 119. -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 2003-02-25 IREDELL RECOGNIZE LEVEL TYPE 126 -C 2005-05-06 D.C.STOKES RECOGNIZE LEVEL TYPES 235, 237, 238 -C -C USAGE: CALL W3FI68 (ID, PDS) -C INPUT ARGUMENT LIST: -C ID - 25, 27 WORD INTEGER ARRAY -C OUTPUT ARGUMENT LIST: -C PDS - 28 30, OR GREATER CHARACTER PDS FOR EDITION 1 -C -C REMARKS: LAYOUT OF 'ID' ARRAY: -C ID(1) = NUMBER OF BYTES IN PRODUCT DEFINITION SECTION (PDS) -C ID(2) = PARAMETER TABLE VERSION NUMBER -C ID(3) = IDENTIFICATION OF ORIGINATING CENTER -C ID(4) = MODEL IDENTIFICATION (ALLOCATED BY ORIGINATING CENTER) -C ID(5) = GRID IDENTIFICATION -C ID(6) = 0 IF NO GDS SECTION, 1 IF GDS SECTION IS INCLUDED -C ID(7) = 0 IF NO BMS SECTION, 1 IF BMS SECTION IS INCLUDED -C ID(8) = INDICATOR OF PARAMETER AND UNITS (TABLE 2) -C ID(9) = INDICATOR OF TYPE OF LEVEL (TABLE 3) -C ID(10) = VALUE 1 OF LEVEL (0 FOR 1-100,102,103,105,107 -C 109,111,113,115,117,119,125,126,160,200,201, -C 235,237,238 -C LEVEL IS IN ID WORD 11) -C ID(11) = VALUE 2 OF LEVEL -C ID(12) = YEAR OF CENTURY -C ID(13) = MONTH OF YEAR -C ID(14) = DAY OF MONTH -C ID(15) = HOUR OF DAY -C ID(16) = MINUTE OF HOUR (IN MOST CASES SET TO 0) -C ID(17) = FCST TIME UNIT -C ID(18) = P1 PERIOD OF TIME -C ID(19) = P2 PERIOD OF TIME -C ID(20) = TIME RANGE INDICATOR -C ID(21) = NUMBER INCLUDED IN AVERAGE -C ID(22) = NUMBER MISSING FROM AVERAGES -C ID(23) = CENTURY (20, CHANGE TO 21 ON JAN. 1, 2001) -C ID(24) = SUBCENTER IDENTIFICATION -C ID(25) = SCALING POWER OF 10 -C ID(26) = FLAG BYTE, 8 ON/OFF FLAGS -C BIT NUMBER VALUE ID(26) DEFINITION -C 1 0 0 FULL FCST FIELD -C 1 128 FCST ERROR FIELD -C 2 0 0 ORIGINAL FCST FIELD -C 1 64 BIAS CORRECTED FCST FIELD -C 3 0 0 ORIGINAL RESOLUTION RETAINED -C 1 32 SMOOTHED FIELD -C NOTE: ID(26) CAN BE THE SUM OF BITS 1, 2, 3. -C BITS 4-8 NOT USED, SET TO ZERO -C IF ID(1) IS 28, YOU DO NOT NEED ID(26) AND ID(27). -C ID(27) = UNUSED, SET TO 0 SO PDS BYTE 30 IS SET TO ZERO. -C -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: SiliconGraphics 3.5 FORTRAN 77 -C MACHINE: SiliconGraphics IRIS-4D/25, 35, INDIGO, Indy -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916/256, J916/2048 -C -C$$$ -C - INTEGER ID(*) -C - CHARACTER * 1 PDS(*) -C - PDS(1) = CHAR(MOD(ID(1)/65536,256)) - PDS(2) = CHAR(MOD(ID(1)/256,256)) - PDS(3) = CHAR(MOD(ID(1),256)) - PDS(4) = CHAR(ID(2)) - PDS(5) = CHAR(ID(3)) - PDS(6) = CHAR(ID(4)) - PDS(7) = CHAR(ID(5)) - PDS(8) = CHAR(IOR(ISHFT(ID(6),7), - & ISHFT(ID(7),6))) - PDS(9) = CHAR(ID(8)) - PDS(10) = CHAR(ID(9)) - I9 = ID(9) -C -C TEST TYPE OF LEVEL TO SEE IF LEVEL IS IN TWO -C WORDS OR ONE -C - IF ((I9.GE.1.AND.I9.LE.100).OR.I9.EQ.102.OR. - & I9.EQ.103.OR.I9.EQ.105.OR.I9.EQ.107.OR. - & I9.EQ.109.OR.I9.EQ.111.OR.I9.EQ.113.OR. - & I9.EQ.115.OR.I9.EQ.117.OR.I9.EQ.119.OR. - & I9.EQ.125.OR.I9.EQ.126.OR.I9.EQ.160.OR. - & I9.EQ.200.OR.I9.EQ.201.OR.I9.EQ.235.OR. - & I9.EQ.237.OR.I9.EQ.238) THEN - LEVEL = ID(11) - IF (LEVEL.LT.0) THEN - LEVEL = - LEVEL - LEVEL = IOR(LEVEL,32768) - END IF - PDS(11) = CHAR(MOD(LEVEL/256,256)) - PDS(12) = CHAR(MOD(LEVEL,256)) - ELSE - PDS(11) = CHAR(ID(10)) - PDS(12) = CHAR(ID(11)) - END IF - PDS(13) = CHAR(ID(12)) - PDS(14) = CHAR(ID(13)) - PDS(15) = CHAR(ID(14)) - PDS(16) = CHAR(ID(15)) - PDS(17) = CHAR(ID(16)) - PDS(18) = CHAR(ID(17)) -C -C TEST TIME RANGE INDICATOR (PDS BYTE 21) FOR 10 -C IF SO PUT TIME P1 IN PDS BYTES 19-20. -C - IF (ID(20).EQ.10) THEN - PDS(19) = CHAR(MOD(ID(18)/256,256)) - PDS(20) = CHAR(MOD(ID(18),256)) - ELSE - PDS(19) = CHAR(ID(18)) - PDS(20) = CHAR(ID(19)) - END IF - PDS(21) = CHAR(ID(20)) - PDS(22) = CHAR(MOD(ID(21)/256,256)) - PDS(23) = CHAR(MOD(ID(21),256)) - PDS(24) = CHAR(ID(22)) - PDS(25) = CHAR(ID(23)) - PDS(26) = CHAR(ID(24)) - ISCALE = ID(25) - IF (ISCALE.LT.0) THEN - ISCALE = -ISCALE - ISCALE = IOR(ISCALE,32768) - END IF - PDS(27) = CHAR(MOD(ISCALE/256,256)) - PDS(28) = CHAR(MOD(ISCALE ,256)) - IF (ID(1).GT.28) THEN - PDS(29) = CHAR(ID(26)) - PDS(30) = CHAR(ID(27)) - END IF -C -C SET PDS 31-?? TO ZERO -C - IF (ID(1).GT.30) THEN - K = ID(1) - DO I = 31,K - PDS(I) = CHAR(00) - END DO - END IF -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fi69.f b/src/fim/FIMsrc/w3/w3fi69.f deleted file mode 100644 index 877867c..0000000 --- a/src/fim/FIMsrc/w3/w3fi69.f +++ /dev/null @@ -1,149 +0,0 @@ - SUBROUTINE W3FI69 (PDS, ID) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI69 CONVERT PDS TO 25, OR 27 WORD ARRAY -C PRGMMR: R.E.JONES ORG: W/NMC42 DATE: 91-05-14 -C -C ABSTRACT: CONVERTS AN EDITION 1 GRIB PRODUCE DEFINITION SECTION (PDS) -C TO A 25, OR 27 WORD INTEGER ARRAY. -C -C PROGRAM HISTORY LOG: -C 91-05-14 R.E.JONES -C 92-09-25 R.E.JONES CHANGE LEVEL TO USE ONE OR TWO WORDS -C 93-01-08 R.E.JONES CHANGE FOR TIME RANGE INDICATOR IF 10 -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C 93-10-21 R.E.JONES CHANGES FOR ON388 REV. OCT 9,1993, NEW -C LEVELS 125, 200, 201. -C 94-04-14 R.E.JONES CHANGES FOR ON388 REV. MAR 24,1994, NEW -C LEVELS 115, 116. -C 94-12-04 R.E.JONES CHANGES FOR 27 WORD INTEGER ARRAY IF -C PDS IS GREATER THAN 28 BYTES. -C 95-09-07 R.E.JONES CHANGES FOR LEVEL 117, 119. -C 98-12-21 Gilbert Replaced Function ICHAR with mova2i. -C -C USAGE: CALL W3FI69 (PDS, ID) -C INPUT ARGUMENT LIST: -C PDS - 28 TO 100 CHARACTER PRODUCT DEFINITION SECTION -C (PDS) -C OUTPUT ARGUMENT LIST: -C ID - 25, OR 27 WORD INTEGER ARRAY -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C LANGUAGE: SiliconGraphics 3.5 FORTRAN 77 -C MACHINE: SiliconGraphics IRIS-4D/25, 35, INDIGO, Indy -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916/256, J916/2048 -C -C$$$ -C - INTEGER ID(*) -C - CHARACTER * 1 PDS(*) -C - SAVE -C -C ID(1) = NUMBER OF BYTES IN PDS -C ID(2) = PARAMETER TABLE VERSION NUMBER -C ID(3) = IDENTIFICATION OF ORIGINATING CENTER -C ID(4) = MODEL IDENTIFICATION (ALLOCATED BY ORIGINATING CENTER) -C ID(5) = GRID IDENTIFICATION -C ID(6) = 0 IF NO GDS SECTION, 1 IF GDS SECTION IS INCLUDED -C ID(7) = 0 IF NO BMS SECTION, 1 IF BMS SECTION IS INCLUDED -C ID(8) = INDICATOR OF PARAMETER AND UNITS -C ID(9) = INDICATOR OF TYPE OF LEVEL OR LAYER -C ID(10) = LEVEL 1 -C ID(11) = LEVEL 2 -C ID(12) = YEAR OF CENTURY -C ID(13) = MONTH OF YEAR -C ID(14) = DAY OF MONTH -C ID(15) = HOUR OF DAY -C ID(16) = MINUTE OF HOUR (IN MOST CASES SET TO 0) -C ID(17) = FCST TIME UNIT -C ID(18) = P1 PERIOD OF TIME -C ID(19) = P2 PERIOD OF TIME -C ID(20) = TIME RANGE INDICATOR -C ID(21) = NUMBER INCLUDED IN AVERAGE -C ID(22) = NUMBER MISSING FROM AVERAGES OR ACCUMULATIONS -C ID(23) = CENTURY -C ID(24) = IDENTIFICATION OF SUB-CENTER (TABLE 0 - PART 2) -C ID(25) = SCALING POWER OF 10 -C ID(26) = FLAG BYTE, 8 ON/OFF FLAGS -C BIT NUMBER VALUE ID(26) DEFINITION -C 1 0 0 FULL FCST FIELD -C 1 128 FCST ERROR FIELD -C 2 0 0 ORIGINAL FCST FIELD -C 1 64 BIAS CORRECTED FCST FIELD -C 3 0 0 ORIGINAL RESOLUTION RETAINED -C 1 32 SMOOTHED FIELD -C NOTE: ID(26) CAN BE THE SUM OF BITS 1, 2, 3. -C BITS 4-8 NOT USED, SET TO ZERO. -C IF ID(1) IS 28, YOU DO NOT NEED ID(26) AND ID(27). -C ID(27) = UNUSED, SET TO 0 SO PDS BYTE 30 IS SET TO ZERO.$ -C - ID(1) = mova2i(PDS(1)) * 65536 + mova2i(PDS(2)) * 256 + - & mova2i(PDS(3)) - ID(2) = mova2i(PDS(4)) - ID(3) = mova2i(PDS(5)) - ID(4) = mova2i(PDS(6)) - ID(5) = mova2i(PDS(7)) - ID(6) = IAND(ISHFT(mova2i(PDS(8)),-7),1) - ID(7) = IAND(ISHFT(mova2i(PDS(8)),-6),1) - ID(8) = mova2i(PDS(9)) - ID(9) = mova2i(PDS(10)) - I9 = mova2i(PDS(10)) -C -C TEST ID(9) FOR 1-100, 102,103, 105, 107, 109, -C 111,113,115,117,119,160,200,201, IF TRUE, SET ID(10) TO 0, -C AND STORE 16 BIT VALUE (BYTES 11 & 12) THE LEVEL IN ID(11). -C - IF ((I9.GE.1.AND.I9.LE.100).OR.I9.EQ.102.OR. - & I9.EQ.103.OR.I9.EQ.105.OR.I9.EQ.107.OR. - & I9.EQ.109.OR.I9.EQ.111.OR.I9.EQ.113.OR. - & I9.EQ.115.OR.I9.EQ.117.OR.I9.EQ.119.OR. - & I9.EQ.125.OR.I9.EQ.160.OR.I9.EQ.200.OR. - & I9.EQ.201) THEN - LEVEL = mova2i(PDS(11)) * 256 + mova2i(PDS(12)) - IF (IAND(LEVEL,32768).NE.0) THEN - LEVEL = -IAND(LEVEL,32767) - END IF - ID(10) = 0 - ID(11) = LEVEL - ELSE - ID(10) = mova2i(PDS(11)) - ID(11) = mova2i(PDS(12)) - END IF - ID(12) = mova2i(PDS(13)) - ID(13) = mova2i(PDS(14)) - ID(14) = mova2i(PDS(15)) - ID(15) = mova2i(PDS(16)) - ID(16) = mova2i(PDS(17)) - ID(17) = mova2i(PDS(18)) - ID(18) = mova2i(PDS(19)) - ID(19) = mova2i(PDS(20)) - ID(20) = mova2i(PDS(21)) -C -C IF TIME RANGE IDICATOR IS 10, P1 IS PACKED INTO -C PDS BYTES 19-20. PUT THEM IN P1 AND SET P2 TO ZERO. -C - IF (ID(20).EQ.10) THEN - ID(18) = ID(18) * 256 + ID(19) - ID(19) = 0 - END IF - ID(21) = mova2i(PDS(22)) * 256 + mova2i(PDS(23)) - ID(22) = mova2i(PDS(24)) - ID(23) = mova2i(PDS(25)) - ID(24) = mova2i(PDS(26)) - ISCALE = mova2i(PDS(27)) * 256 + mova2i(PDS(28)) - IF (IAND(ISCALE,32768).NE.0) THEN - ISCALE = -IAND(ISCALE,32767) - END IF - ID(25) = ISCALE - IF (ID(1).GT.28) THEN - ID(26) = mova2i(PDS(29)) - ID(27) = mova2i(PDS(30)) - END IF -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fi70.f b/src/fim/FIMsrc/w3/w3fi70.f deleted file mode 100644 index cc6d3ee..0000000 --- a/src/fim/FIMsrc/w3/w3fi70.f +++ /dev/null @@ -1,855 +0,0 @@ - SUBROUTINE W3FI70(PDS,CNST,IER) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FI70 COMPUTES SCALING CONSTANTS USED BY GRDPRT -C AUTHOR: STACKPOLE,J. ORG: W342 DATE: 93-10-16 -C AUTHOR: JONES,R.E. -C -C ABSTRACT: COMPUTES THE FOUR SCALING CONSTANTS USED BY GRDPRT, W3FP03, -C OR W3FP05 FROM THE 28 BYTE (PDS) PRODUCT DEFINITION SECTION OF -C GRIB EDITION ONE. -C -C PROGRAM HISTORY LOG: -C 91-10-26 R.E.JONES -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C 93-08-08 R.E.JONES ADD 156 (CIN), 158 (TKE) TO TABLES -C 93-10-16 R.E.JONES CHANGES FOR O.N. 388 VER. OCT. 8,1993 -C -C USAGE: CALL W3FI70(PDS,CNST,IER) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C PDS ARG LIST 28 BYTE (PDS) GRIB PRODUCT DEFINITION SECTION -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C CNST ARG LIST 4 CONSTANT'S USED BY GRDPRT,W3FP05, OR W3FP03 -C IER ARG LIST 0 = NORMAL RETURN -C 1 = -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C W3FI69 W3LIB -C -C ATTRIBUTES: -C LANGUAGE: SiliconGraphics 3.5 FORTRAN 77 -C MACHINE: SiliconGraphics IRIS-4D/25, 35, INDIGO, Indy -C -C$$$ -C -C SET DEFAULT VALUES FOR NMC FIELDS GRID PRINTING -C - REAL CNST(4) -C - INTEGER ID(25) - INTEGER Q -C - CHARACTER * 1 PDS(28) -C - SAVE -C -C UNPACK 28 BYTE (PDS) INTO 25 INTEGER WORDS -C - CALL W3FI69(PDS,ID) -C - IER = 0 -C -C INDICATOR OF PARAMETER AND UNITS -C - Q = ID(8) -C -C INDICATOR OF LEVEL OR LAYERS -C - ITYPES = ID(9) - I9 = ID(9) -C -C HEIGHTS, PRESSURE, ETC. OF THE LEVEL OR LAYER -C - IF ((I9.GE.1.AND.I9.LE.100).OR.I9.EQ.102.OR. - & I9.EQ.103.OR.I9.EQ.105.OR.I9.EQ.107.OR. - & I9.EQ.109.OR.I9.EQ.111.OR.I9.EQ.113.OR. - & I9.EQ.125.OR.I9.EQ.160.OR.I9.EQ.200.OR. - & I9.EQ.201) THEN - ILVL = ID(11) - ELSE - ILVL = ID(10) - END IF - - IF (Q.EQ.1.OR.Q.EQ.2.OR.Q.EQ.26) THEN -C -C*** PRESSURE, PRESSURE REDUCED TO MSL, PRESSURE ANOMALY (Pa) -C - CNST(1) = 0.0 - CNST(2) = 0.01 - CNST(3) = 4.0 - CNST(4) = 0.0 -C*** IF SFC, TROPOPAUSE PRESSURE, SIGMA .. - IF (ITYPES.EQ.1.OR.ITYPES.EQ.6.OR.ITYPES.EQ.7)CNST(3)=25.0 - IF (ITYPES.EQ.107) CNST(3) = 25.0 -C - ELSE IF (Q.EQ.3) THEN -C -C*** PRESSURE TENDENCY (Pa/s) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 4.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.6) THEN -C -C*** GEOPOTENTIAL (m**2/s**2) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 4.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.7.OR.Q.EQ.8.OR.Q.EQ.27.OR.Q.EQ.222) THEN -C -C*** GEOPOTENTIAL, GEOPOTENTIAL HEIGHT, ANOMALY -C*** 5-WAVE GEOPOTENTIAL HEIGHT ............ -C - CNST(3) = 60. - IF (ILVL.LT.500) CNST(3) = 120. -C*** IF SFC OR TROPOPAUSE PRESSURE .. - IF ((ITYPES.EQ.1) .OR. (ITYPES.EQ.7)) CNST(3) = 500.0 - IF (ITYPES.EQ.107) CNST(3) = 500.0 - - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(4) = 0.0 - IF (CNST(3) .EQ. 500.) CNST(4) = 2.0 -C - ELSE IF (Q.EQ.11.OR.Q.EQ.12.OR.Q.EQ.13.OR.Q.EQ.14.OR. - & Q.EQ.15.OR.Q.EQ.16.OR.Q.EQ.17.OR.Q.EQ.18.OR. - & Q.EQ.25.OR.Q.EQ.85) THEN -C - -C*** TEMPERATURES (deg. K) -C*** VIRTUAL TEMPERATURE (deg. K) -C*** POTENTIAL TEMPERATURE (deg. K) -C*** PSEUDO-ADIABATIC POTENTIAL TEMPERATURE (deg. K) -C*** MAXIMUN TEMPERATURE (deg. K) -C*** MINUMUN TEMPERATURE (deg. K) -C*** DEW POINT TEMPERATURE (deg. K) -C*** DEW POINT DEPRESSION (OR DEFICIT) (deg. K) -C -C*** TEMP (DEG K) CONVERT TO DEG C, EXCEPT POTENTIAL TEMPERATURE -C -C CNST(1) = -273.15 - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 5.0 - CNST(4) = 0.0 - IF (Q.EQ.13) CNST(1) = 0.0 -C - ELSE IF (Q.EQ.19) THEN -C -C*** LAPSE RATE, deg. K/m ............... -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 4.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.21.OR.Q.EQ.22.OR.Q.EQ.23) THEN -C -C*** RADAR SPECTRA (1), (2), (3) ............... -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.28.OR.Q.EQ.29.OR.Q.EQ.30) THEN -C -C*** WAVE SPECTRA (1), (2), (3) ............... -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.31) THEN -C -C*** WIND DIRECTION (deg. true) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.32.OR.Q.EQ.33.OR.Q.EQ.34) THEN -C -C*** WIND SPEED, U-COMPONENT OF WIND, -C*** V-COMPONENT OF WIND m/s ------------------- -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - IF (ITYPES.EQ.1.AND.ILVL.EQ.0) CNST(3) = 3.0 - IF (ITYPES.EQ.107) CNST(3) = 3.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.35.OR.Q.EQ.36) THEN -C -C*** STREAM FUNCTION, VELOCITY POTENTIAL (m**2/s) -C*** STREAM FUNCTION OR VELOCITY POTENTIAL (m**2/s) CONVERTED TO M. -C*** CONVERT TO METERS. (M*M/SEC * FOG) -C - CNST(1) = 0. - CNST(2) = 1.03125E-4 / 9.8 - CNST(3) = 60. - CNST(4) = 0. -C - ELSE IF (Q.EQ.37) THEN -C -C*** MONTGOMERY STREAM FUNCTION (m**2/s**2) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 2.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.38) THEN -C -C*** SIGMA COORD. VERTICAL VELOCITY (/s) TO MICROBARS/SEC -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 2.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.39) THEN -C -C*** VERTICAL VELOCITY (Pa/s) TO MICROBARS/SEC -C*** SIGN CHANGED SUCH THAT POSITIVE VALUES INDICATE UPWARD MOTION. -C - CNST(1) = 0.0 - CNST(2) = -1.E1 - CNST(3) = 2.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.40) THEN -C -C*** GEOMETRIC VERTICAL VELOCITY -DZDT- (m/s) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.41.OR.Q.EQ.42.OR.Q.EQ.43.OR.Q.EQ.44.OR. - & Q.EQ.45.OR.Q.EQ.46) THEN -C -C*** ABSOLUTE VORTICITY -ABS-V (/s) -C*** ABSOLUTE DIVERGENCE -ABS-V (/s) -C*** RELATIVE VORTICITY -REL-V (/s) -C*** RELATIVE DIVERGENCE -REL-D (/s) -C*** VERTICAL U-COMPONENT SHEAR -VUCSH (/s) -C*** VERTICAL V-COMPONENT SHEAR -VVCSH (/s) -C - CNST(1) = 0.0 - CNST(2) = 1.0E+6 - CNST(3) = 40.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.47) THEN -C -C*** DIRECTION OF CURRENT -DIR-C (deg. true) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.48.OR.Q.EQ.49.OR.Q.EQ.50) THEN -C -C*** SPEED OF CURRENT (m/s) -C*** U AND V COMPONENTS OF CURRENT (m/s) -C - CNST(1) = 0. - CNST(2) = 1. - CNST(3) = 2. - CNST(4) = 0. -C - ELSE IF (Q.EQ.51.OR.Q.EQ.53) THEN -C -C*** SPECIFIC HUMIDITY SPF H (kg/kg) -C*** HUMIDITY MIXING RATIO MIXR (kg/kg) -C - CNST(1) = 0.0 - CNST(2) = 1.E+3 - CNST(3) = 2.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.52) THEN -C -C*** RELATIVE HUMIDITY R H (%) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 20.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.54.OR.Q.EQ.57.OR.Q.EQ.58) THEN -C -C*** PRECIPITABLE WATER (kg/m**2) OR .1 GRAM/CM*CM OR MILLIMETERS/CM*CM -C*** CHANGE TO CENTI-INCHES/CM*CM -C*** EVAPERATION -C*** CLOUD ICE (kg/m**2) -C - CNST(1) = 0.0 - CNST(2) = 3.937 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.55.OR.Q.EQ.56) THEN -C -C*** VAPOR PRESSURE VAPP, SATURATION DEFICIT SAT D (Pa) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.59) THEN -C -C*** PRECIPITATION RATE (kg/m**2/s) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 20.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.60) THEN -C -C*** THUNDERSTORM PROBABILITY (%) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 20.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.61.OR.Q.EQ.62.OR.Q.EQ.63.OR.Q.EQ.64.OR. - & Q.EQ.65) THEN -C -C*** TOTAL PRECIPITATION A PCP (kg/m**2) -C*** LARGE SCALE PRECIPITATION NCPCP (kg/m**2) -C*** CONVECTIVE PRECIPITATION ACPCP (kg/m**2) -C*** SNOWFALL RATE WATER EQUIVALENT SRWEQ (kg/m**2/s) -C*** WATER EQUIV. OF ACCUM. SNOW DEPTH WEASD (kg/m**2) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 2.0 - CNST(4) = 0.0 - - ELSE IF (Q.EQ.66) THEN -C -C*** SNOW DEPTH (METERS) (1 or 0) for snow or no snow -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 1.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.67.OR.Q.EQ.68.OR.Q.EQ.69.OR.Q.EQ.70) THEN -C -C*** MIXING LAYER DEPTH MIXHT (m) -C*** TRANSIENT THEMOCLINE DEPTH TTHDP (m) -C*** MAIN THERMOCLINE DEPTH MTHCD (m) -C*** MAIN THERMOCLINE ANOMALY MTHCA (m) -C - CNST(1) = 0.0 - CNST(2) = 39.37 - CNST(3) = 06.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.120.OR.Q.EQ.121) THEN -C -C*** WAVE COMPONENT OF GEOPOTENTIAL (GEOP M) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.71.OR.Q.EQ.72.OR.Q.EQ.73.OR.Q.EQ.74.OR. - & Q.EQ.75) THEN -C -C*** TOTAL CLOUD COVER T CDC (%) -C*** CONVECTIVE CLOUD COVER CDCON (%) -C*** LOW CLOUD COVER L CDC (%) -C*** MEDIUM CLOUD COVER M CDC (%) -C*** HIGH CLOUD COVER H CDC (%) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.76) THEN -C -C*** CLOUD WATER -C-WAT (kg/m**2) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.78) THEN -C -C*** CONVECTIVE SNOW -C-SNO (kg/m**2) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.79) THEN -C -C*** LARGE SCALE SNOW -LSSNO (kg/m**2) -C - CNST(1) = 0.0 - CNST(2) = 0.1 - CNST(3) = 500.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.80) THEN -C -C*** WATER TEMPERAUTER -WTMP- (deg. K) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 2.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.81) THEN -C -C*** LAND/SEA (1=LAND; 0=SEA) -C*** ICE CONCENTRATION (ICE=1; NO ICE=0) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 1.0 - CNST(4) = 0.5 -C - ELSE IF (Q.EQ.82.OR.Q.EQ.83.OR.Q.EQ.92.OR.Q.EQ.97) THEN -C -C*** DEVIATION OF SEA LEVEL FROM MEAN (m) -C*** SUFACE ROUGHNESS (m) -C*** ICE THICKNESS (m) -C*** ICE GROWTH (m) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 2.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.84) THEN -C -C*** ALBEDO (%) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.86) THEN -C -C*** SOIL MOISTURE CONTENT (kg/m**2) -SOILM -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.87) THEN -C -C*** VEGETATION -VEG- (%) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.88) THEN -C -C*** SALINITY -SALTY- (kg/kg) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.89) THEN -C -C*** DENSITY -DEN-- (kg/m**3) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.90) THEN -C -C*** WATER RUNOFF -WAT-R (kg/m**2) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.93) THEN -C -C*** DIRECTION OF ICE DRIFT -DICED (deg. true) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.94.OR.Q.EQ.95.OR.Q.EQ.96) THEN -C -C*** SPEED OF ICE DRIFT -SICED (m/s) -C*** U-COMPONENT OF ICE DRIFT -U-ICE (m/s) -C*** V-COMPONENT OF ICE DRIFT -V-ICE (m/s) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 2.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.98) THEN -C -C*** ICE DIVERGENCE -ICE D (/s) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.99) THEN -C -C*** SNO MELT -SNO- M (kg/m**2) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.100.OR.Q.EQ.102.OR.Q.EQ.105) THEN -C -C*** HEIGHT OF WIND DRIVEN OCEAN WAVES, SEA SWELLS, OR COMBINATION -C*** (m) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 1.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.101.OR.Q.EQ.104.OR.Q.EQ.107.OR.Q.EQ.109) THEN -C -C*** DIRECTION OF WIND WAVES, SWELLS WAVES, PRIMARY WAVE, SECONDARY -C*** WAVE (deg. true) -------------------- -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 20.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.103.OR.Q.EQ.106.OR.Q.EQ.108.OR.Q.EQ.110) THEN -C -C*** MEAN PERIOD OF WIND WAVES, SWELLS WAVES, PRIMARY WAVE, SECONDARY -C*** WAVE (s) -------------------- -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 2.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.111.OR.Q.EQ.112.OR.Q.EQ.113.OR.Q.EQ.114.OR. - & Q.EQ.115.OR.Q.EQ.116.OR.Q.EQ.117.OR.Q.EQ.121.OR. - & Q.EQ.122.OR.Q.EQ.123) THEN -C -C*** NET SHORTWAVE RADITION (SURFACE) -NSWRS w/m **2 -C*** NET LONGWAVE RADITION (SURFACE) -SHTFL w/m**2 -C*** NET SHORTWAVE RADITION (TOP OF ATOMS.) -NSWRT w/m**2 -C*** NET LONGWAVE RADITION (TOP OF ATOMS.) -NLWRT w/m**2 -C*** LONG WAVE RADITION -LWAVR w/m**2 -C*** SHORT WAVE RADITION -SWAVE w/m**2 -C*** GLOBAL RADITION -G-RAD w/m**2 -C*** LATENT HEAT FLUX -LHTFL w/m**2 -C*** SENSIBLE HEAT FLUX -SHTFL w/m**2 -C*** BOUNDARY LAYER DISSIPATION -BLYDP w/m**2 -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 5.0 - IF (Q.EQ.114) CNST(3) = 20.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.127) THEN -C -C IMAGE DATA -IMG-D -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.128) THEN -C -C Mean Sea Level Pressure -MSLSA (Pa) -C (Standard Atmosphere Reduction) -C - CNST(1) = 0.0 - CNST(2) = 0.01 - CNST(3) = 4.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.129) THEN -C -C Mean Sea Level Pressure -MSLMA (Pa) -C (Maps System Reduction) -C - CNST(1) = 0.0 - CNST(2) = 0.01 - CNST(3) = 4.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.130) THEN -C -C Mean Sea Level Pressure -MSLET (Pa) -C (ETA Model Reduction) -C - CNST(1) = 0.0 - CNST(2) = 0.01 - CNST(3) = 4.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.131.OR.Q.EQ.132.OR.Q.EQ.133.OR.Q.EQ.134) THEN -C -C*** SURFACE LIFTED INDEX ..(DEG K) -C*** BEST (4 LAYER) LIFTED INDEX ..(DEG K) -C*** K INDEX ..(DEG K) TO DEG C. -C*** SWEAT INDEX ..(DEG K) TO DEG C. -C - IF (Q.EQ.131.OR.Q.EQ.132) THEN - CNST(1) = 0.0 - ELSE - CNST(1) = -273.15 - END IF - CNST(2) = 1.0 - CNST(3) = 4.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.135) THEN -C -C*** HORIZONTIAL MOISTURE DIVERGENCE (KG/KG/S) -MCONV -C - CNST(1) = 0.0 - CNST(2) = 1.E+8 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.136) THEN -C -C*** VERTICAL SPEED SHEAR (1/SEC)... TO BE CONVERTED TO KNOTS/1000 FT -C - CNST(1) = 0.0 - CNST(2) = 592.086 - CNST(3) = 2.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.137) THEN -C -C*** 3-hr pressure tendency (TSLSA) (Pa/s) -C - CNST(1) = 0.0 - CNST(2) = 1000.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.156) THEN -C -C*** CONVECTIVE INHIBITION -CIN-- (J/kg) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.157) THEN -C -C*** CONVECTIVE AVAILABLE POTENTIAL ENERGY -CAPE- (J/kg) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 500.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.158) THEN -C -C*** TURBULENT KINETIC ENERGY -TKE-- (J/kg) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 100.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.175) THEN -C -C*** MODEL LAYER NUMBER (FROM BOTTOM UP) -SGLYR (non-dim) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 1.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.176) THEN -C -C*** LATITUDE (-90 TO +90) -NLAT- (deg) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.177) THEN -C -C*** EAST LATITUDE (0-360) -ELON- (deg) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.201) THEN -C -C*** ICE-FREE WATER SURFACE -ICWAT (%) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.204) THEN -C -C*** DOWNWARD SHORT WAVE RAD. FLUX -DSWRF (W/m**2) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.205) THEN -C -C*** DOWNWARD LONG WAVE RAD. FLUX -DLWRF (W/m**2) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.207) THEN -C -C*** MOISTURE AVAILABILITY -MSTAV (%) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.208) THEN -C -C*** EXCHANGE COEFFICIENT -SFEXC (kg/m**3)(m/s) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -CC - ELSE IF (Q.EQ.209) THEN -C -C*** NO. OF MIXED LAYERS NEXT TO SURFACE -MIXLY (integer) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.211) THEN -C -C*** UPWARD SHORT WAVE RAD. FLUX -USWRF (W/m**2) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.212) THEN -C -C*** UPWARD LONG WAVE RAD. FLUX -ULWRF (W/m**2) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.213) THEN -C -C*** AMOUNT OF NON-CONVECTIVE CLOUD -CDLYR (%) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.216) THEN -C -C*** TEMPERATURE TENDENCY BY ALL RADIATION -TTRAD (Deg. K/s) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.218) THEN -C -C*** PRECIP. INDEX (0.0-1.00) -PREIX (note will look like %) -C - CNST(1) = 0.0 - CNST(2) = 100.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C - ELSE IF (Q.EQ.220) THEN -C -C*** NATURAL LOG OF SURFACE PRESSURE -NLGSP ln(kPa) -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 10.0 - CNST(4) = 0.0 -C -C*** NONE OF THE ABOVE .... -C - ELSE -C -C SET DEFAULT VALUES -C - CNST(1) = 0.0 - CNST(2) = 1.0 - CNST(3) = 5.0 - CNST(4) = 0.0 - IER = 1 - END IF -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fi71.f b/src/fim/FIMsrc/w3/w3fi71.f deleted file mode 100644 index 50d85a2..0000000 --- a/src/fim/FIMsrc/w3/w3fi71.f +++ /dev/null @@ -1,1418 +0,0 @@ - SUBROUTINE W3FI71 (IGRID, IGDS, IERR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI71 MAKE ARRAY USED BY GRIB PACKER FOR GDS -C PRGMMR: R.E.JONES ORG: W/NMC42 DATE: 93-03-26 -C -C ABSTRACT: W3FI71 MAKES A 18, 37, 55, 64, OR 91 WORD INTEGER ARRAY -C USED BY W3FI72 GRIB PACKER TO MAKE THE GRID DESCRIPTION SECTION -C (GDS) - SECTION 2. -C -C PROGRAM HISTORY LOG: -C 92-02-21 R.E.JONES -C 92-07-01 M. FARLEY ADDED REMARKS FOR 'IGDS' ARRAY ELEMENTS. -C ADDED LAMBERT CONFORMAL GRIDS AND ENLARGED -C IDGS ARRAY FROM 14 TO 18 WORDS. -C 92-10-03 R.E.JONES ADDED CORRECTIONS TO AWIPS GRIB TABLES -C 92-10-16 R.E.JONES ADD GAUSSIAN GRID 126 TO TABLES -C 92-10-18 R.E.JONES CORRECTIONS TO LAMBERT CONFORMAL TABLES -C AND OTHER TABLES -C 92-10-19 R.E.JONES ADD GAUSSIAN GRID 98 TO TABLES -C 93-01-25 R.E.JONES ADD ON84 GRIDS 87, 106, 107 TO TABLES -C 93-03-10 R.E.JONES ADD ON84 GRIDS 1, 55, 56 TO TABLES -C 93-03-26 R.E.JONES ADD GRIB GRIDS 2, 3 TO TABLES -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C 93-06-15 R.E.JONES ADD GRIB GRIDS 37 TO 44 TO TABLES -C 93-09-29 R.E.JONES GAUSSIAN GRID DOCUMENT NOT CORRECT, -C W3FI74 WILL BE CHANGED TO AGREE WITH -C IT. GAUSSIAN GRID 98 TABLE HAS WRONG -C VALUE. -C 93-10-12 R.E.JONES CHANGES FOR ON388 REV. OCT 8,1993 FOR -C GRID 204, 208. -C 93-10-13 R.E.JONES CORRECTION FOR GRIDS 37-44, BYTES 7-8, -C 24-25 SET TO ALL BITS 1 FOR MISSING. -C 93-11-23 R.E.JONES ADD GRIDS 90-93 FOR ETA MODEL -C ADD GRID 4 FOR 720*361 .5 DEG. GRID -C 94-04-12 R.E.JONES CORRECTION FOR GRID 28 -C 94-06-01 R.E.JONES ADD GRID 45, 288*145 1.25 DEG. GRID -C 94-06-22 R.E.JONES ADD GRIDS 94, 95 FOR ETA MODEL -C 95-04-11 R.E.JONES ADD GRIDS 96, 97 FOR ETA MODEL -C 95-05-19 R.E.JONES ADD FROM 20 KM ETA MODEL AWIPS GRID 215 -C 95-10-19 R.E.JONES ADD FROM 20 KM ETA MODEL ALASKA GRID 216 -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 96-05-08 IREDELL CORRECT FIRST LATITUDE FOR GRIDS 27 AND 28 -C 96-07-02 R.E.JONES ADD FROM 10 KM ETA MODEL OLYMPIC GRID 218 -C 96-07-02 R.E.JONES ADD 196 FOR ETA MODEL -C 96-08-15 R.E.JONES ADD O.N. 84 GRID 8 AND 53 AS GRIB GRID 8 -C AND 53 -C 96-11-29 R.E.JONES CORRECTION TO TABLES FOR GRID 21-26, 61-64 -C 97-01-31 IREDELL CORRECT FIRST LATITUDE FOR GRID 30 -C 97-10-20 IREDELL CORRECT LAST LONGITUDE FOR GRID 98 -C 98-07-07 Gilbert Add grids 217 and 219 through 235 -C 98-09-21 BALDWIN ADD GRIDS 190, 192 FOR ETA MODEL -C 99-01-20 BALDWIN ADD GRIDS 236, 237 -C 99-08-18 IREDELL ADD GRID 170 -C 01-03-08 ROGERS CHANGED ETA GRIDS 90-97, ADDED ETA GRIDS -C 194, 198. ADDED AWIPS GRIDS 241,242,243, -C 245, 246, 247, 248, AND 250 -C 01-03-19 VUONG ADDED AWIPS GRIDS 238,239,240, AND 244 -C 01-04-02 VUONG CORRECT LAST LONGITUDE FOR GRID 225 -C 01-05-03 ROGERS ADDED GRID 249 -C 01-10-10 ROGERS REDEFINED 218 FOR 12-KM ETA -C REDEFINED GRID 192 FOR NEW 32-KM ETA GRID -C 02-03-27 VUONG ADDED RSAS GRID 88 AND AWIPS GRIDS 251 AND 252 -C 02-08-06 ROGERS REDEFINED GRIDS 90-93,97,194,245-250 FOR THE -C 8KM HI-RES-WINDOW MODEL AND ADD AWIPS GRID 253 -C 2003-06-30 GILBERT ADDED GRIDS 145 and 146 for CMAQ -C and GRID 175 for AWIPS over GUAM. -C 2003-07-08 VUONG CORRECTED LATITUDE FOR GRID 253 AND 170, ADD GRID -C 110, 127, 171 AND 172 -C 2004-08-05 VUONG CORRECTED LATITUDE FOR GRID 253 -C 2004-09-01 GILBERT Corrected the orientation and projection center flag -C for southern hemisphere grids 28, 172, 220 and 224 -C 2004-09-02 VUONG ADDED GRIDS 147, 148, 173 AND 254 -C 2005-01-04 COOKE Added grids 160, 161 and corrected longitude of orientation for grid 172 -C 2005-03-03 VUONG MOVED GRID 170 TO GRID 174 AND ADD GRID 170 -C 2005-03-21 VUONG ADDED GRIDS 130 -C 2005-09-12 VUONG ADDED GRIDS 163 -C 2006-10-27 VUONG CORRECTED X AND Y-DIRECTION GRID LENGTH FOR GRIDS 252 -C 2006-11-16 VUONG CHANGED THE LONGITUDE FROM NEGATIVE TO POSITIVE DEGREE FOR GRIDS 252 -C 2006-12-12 VUONG CHANGED DATA REPRESENTATION TYPE (OCTET 6) FROM 0 TO 1 FOR GRID 254 -C ADD GRID 120 (CURVILINEAR ORTHOGONAL GRID) -C 2006-12-27 VUONG CORRECTED THE LAT/LON DIRECTION INCREMENT FOR GRID 160 -C -C USAGE: CALL W3FI71 (IGRID, IGDS, IERR) -C INPUT ARGUMENT LIST: -C IGRID - GRIB GRID NUMBER, OR OFFICE NOTE 84 GRID NUMBER -C -C OUTPUT ARGUMENT LIST: -C IGDS - 18, 37, 55, 64, OR 91 WORD INTEGER ARRAY WITH -C INFORMATION TO MAKE A GRIB GRID DESCRIPTION SECTION. -C IERR - 0 CORRECT EXIT -C 1 GRID TYPE IN IGRID IS NOT IN TABLE -C -C REMARKS: -C 1) OFFICE NOTE GRID TYPE 26 IS 6 IN GRIB, 26 IS AN -C INTERNATIONAL EXCHANGE GRID. -C -C 2) VALUES RETURNED IN 18, 37, 55, 64, OR 91 WORD INTEGER ARRAY -C IGDS VARY DEPENDING ON GRID REPRESENTATION TYPE. -C -C LAT/LON GRID: -C IGDS( 1) = NUMBER OF VERTICAL COORDINATES -C IGDS( 2) = PV, PL OR 255 -C IGDS( 3) = DATA REPRESENTATION TYPE (CODE TABLE 6) -C IGDS( 4) = NO. OF POINTS ALONG A LATITUDE -C IGDS( 5) = NO. OF POINTS ALONG A LONGITUDE MERIDIAN -C IGDS( 6) = LATITUDE OF ORIGIN (SOUTH - IVE) -C IGDS( 7) = LONGITUDE OF ORIGIN (WEST -IVE) -C IGDS( 8) = RESOLUTION FLAG (CODE TABLE 7) -C IGDS( 9) = LATITUDE OF EXTREME POINT (SOUTH - IVE) -C IGDS(10) = LONGITUDE OF EXTREME POINT (WEST - IVE) -C IGDS(11) = LATITUDE INCREMENT -C IGDS(12) = LONGITUDE INCREMENT -C IGDS(13) = SCANNING MODE FLAGS (CODE TABLE 8) -C IGDS(14) = ... THROUGH ... -C IGDS(18) = ... NOT USED FOR THIS GRID -C IGDS(19) - IGDS(91) FOR GRIDS 37-44, NUMBER OF POINTS -C IN EACH OF 73 ROWS. -C -C GAUSSIAN GRID: -C IGDS( 1) = ... THROUGH ... -C IGDS(10) = ... SAME AS LAT/LON GRID -C IGDS(11) = NUMBER OF LATITUDE LINES BETWEEN A POLE -C AND THE EQUATOR -C IGDS(12) = LONGITUDE INCREMENT -C IGDS(13) = SCANNING MODE FLAGS (CODE TABLE 8) -C IGDS(14) = ... THROUGH ... -C IGDS(18) = ... NOT USED FOR THIS GRID -C -C SPHERICAL HARMONICS: -C IGDS( 1) = NUMBER OF VERTICAL COORDINATES -C IGDS( 2) = PV, PL OR 255 -C IGDS( 3) = DATA REPRESENTATION TYPE (CODE TABLE 6) -C IGDS( 4) = J - PENTAGONAL RESOLUTION PARAMETER -C IGDS( 5) = K - PENTAGONAL RESOLUTION PARAMETER -C IGDS( 6) = M - PENTAGONAL RESOLUTION PARAMETER -C IGDS( 7) = REPRESENTATION TYPE (CODE TABLE 9) -C IGDS( 8) = REPRESENTATION MODE (CODE TABLE 10) -C IGDS( 9) = ... THROUGH ... -C IGDS(18) = ... NOT USED FOR THIS GRID -C -C POLAR STEREOGRAPHIC: -C IGDS( 1) = NUMBER OF VERTICAL COORDINATES -C IGDS( 2) = PV, PL OR 255 -C IGDS( 3) = DATA REPRESENTATION TYPE (CODE TABLE 6) -C IGDS( 4) = NO. OF POINTS ALONG X-AXIS -C IGDS( 5) = NO. OF POINTS ALONG Y-AXIS -C IGDS( 6) = LATITUDE OF ORIGIN (SOUTH -IVE) -C IGDS( 7) = LONGITUTE OF ORIGIN (WEST -IVE) -C IGDS( 8) = RESOLUTION FLAG (CODE TABLE 7) -C IGDS( 9) = LONGITUDE OF MERIDIAN PARALLEL TO Y-AXIS -C IGDS(10) = X-DIRECTION GRID LENGTH (INCREMENT) -C IGDS(11) = Y-DIRECTION GRID LENGTH (INCREMENT) -C IGDS(12) = PROJECTION CENTER FLAG (0=NORTH POLE ON PLANE, -C 1=SOUTH POLE ON PLANE, -C IGDS(13) = SCANNING MODE FLAGS (CODE TABLE 8) -C IGDS(14) = ... THROUGH ... -C IGDS(18) = .. NOT USED FOR THIS GRID -C -C MERCATOR: -C IGDS( 1) = ... THROUGH ... -C IGDS(12) = ... SAME AS LAT/LON GRID -C IGDS(13) = LATITUDE AT WHICH PROJECTION CYLINDER -C INTERSECTS EARTH -C IGDS(14) = SCANNING MODE FLAGS -C IGDS(15) = ... THROUGH ... -C IGDS(18) = .. NOT USED FOR THIS GRID -C -C LAMBERT CONFORMAL: -C IGDS( 1) = NUMBER OF VERTICAL COORDINATES -C IGDS( 2) = PV, PL OR 255 -C IGDS( 3) = DATA REPRESENTATION TYPE (CODE TABLE 6) -C IGDS( 4) = NO. OF POINTS ALONG X-AXIS -C IGDS( 5) = NO. OF POINTS ALONG Y-AXIS -C IGDS( 6) = LATITUDE OF ORIGIN (SOUTH -IVE) -C IGDS( 7) = LONGITUTE OF ORIGIN (WEST -IVE) -C IGDS( 8) = RESOLUTION FLAG (CODE TABLE 7) -C IGDS( 9) = LONGITUDE OF MERIDIAN PARALLEL TO Y-AXIS -C IGDS(10) = X-DIRECTION GRID LENGTH (INCREMENT) -C IGDS(11) = Y-DIRECTION GRID LENGTH (INCREMENT) -C IGDS(12) = PROJECTION CENTER FLAG (0=NORTH POLE ON PLANE, -C 1=SOUTH POLE ON PLANE, -C IGDS(13) = SCANNING MODE FLAGS (CODE TABLE 8) -C IGDS(14) = NOT USED -C IGDS(15) = FIRST LATITUDE FROM THE POLE AT WHICH THE -C SECANT CONE CUTS THE SPERICAL EARTH -C IGDS(16) = SECOND LATITUDE ... -C IGDS(17) = LATITUDE OF SOUTH POLE (MILLIDEGREES) -C IGDS(18) = LONGITUDE OF SOUTH POLE (MILLIDEGREES) -C -C ARAKAWA SEMI-STAGGERED E-GRID ON ROTATED LAT/LON GRID -C IGDS( 1) = NUMBER OF VERTICAL COORDINATES -C IGDS( 2) = PV, PL OR 255 -C IGDS( 3) = DATA REPRESENTATION TYPE (CODE TABLE 6) [201] -C IGDS( 4) = NI - TOTAL NUMBER OF ACTUAL DATA POINTS -C INCLUDED ON GRID -C IGDS( 5) = NJ - DUMMY SECOND DIMENSION; SET=1 -C IGDS( 6) = LA1 - LATITUDE OF FIRST GRID POINT -C IGDS( 7) = LO1 - LONGITUDE OF FIRST GRID POINT -C IGDS( 8) = RESOLUTION AND COMPONENT FLAG (CODE TABLE 7) -C IGDS( 9) = LA2 - NUMBER OF MASS POINTS ALONG -C SOUTHERNMOST ROW OF GRID -C IGDS(10) = LO2 - NUMBER OF ROWS IN EACH COLUMN -C IGDS(11) = DI - LONGITUDINAL DIRECTION INCREMENT -C IGDS(12) = DJ - LATITUDINAL DIRECTION INCREMENT -C IGDS(13) = SCANNING MODE FLAGS (CODE TABLE 8) -C IGDS(14) = ... THROUGH ... -C IGDS(18) = ... NOT USED FOR THIS GRID (SET TO ZERO) -C -C ARAKAWA FILLED E-GRID ON ROTATED LAT/LON GRID -C IGDS( 1) = NUMBER OF VERTICAL COORDINATES -C IGDS( 2) = PV, PL OR 255 -C IGDS( 3) = DATA REPRESENTATION TYPE (CODE TABLE 6) [202] -C IGDS( 4) = NI - TOTAL NUMBER OF ACTUAL DATA POINTS -C INCLUDED ON GRID -C IGDS( 5) = NJ - DUMMY SECOND DIMENTION; SET=1 -C IGDS( 6) = LA1 - LATITUDE LATITUDE OF FIRST GRID POINT -C IGDS( 7) = LO1 - LONGITUDE OF FIRST GRID POINT -C IGDS( 8) = RESOLUTION AND COMPONENT FLAG (CODE TABLE 7) -C IGDS( 9) = LA2 - NUMBER OF (ZONAL) POINTS IN EACH ROW -C IGDS(10) = LO2 - NUMBER OF (MERIDIONAL) POINTS IN EACH -C COLUMN -C IGDS(11) = DI - LONGITUDINAL DIRECTION INCREMENT -C IGDS(12) = DJ - LATITUDINAL DIRECTION INCREMENT -C IGDS(13) = SCANNING MODE FLAGS (CODE TABLE 8) -C IGDS(14) = ... THROUGH ... -C IGDS(18) = ... NOT USED FOR THIS GRID -C -C ARAKAWA STAGGERED E-GRID ON ROTATED LAT/LON GRID -C IGDS( 1) = NUMBER OF VERTICAL COORDINATES -C IGDS( 2) = PV, PL OR 255 -C IGDS( 3) = DATA REPRESENTATION TYPE (CODE TABLE 6) [203] -C IGDS( 4) = NI - NUMBER OF DATA POINTS IN EACH ROW -C IGDS( 5) = NJ - NUMBER OF ROWS -C IGDS( 6) = LA1 - LATITUDE OF FIRST GRID POINT -C IGDS( 7) = LO1 - LONGITUDE OF FIRST GRID POINT -C IGDS( 8) = RESOLUTION AND COMPONENT FLAG (CODE TABLE 7) -C IGDS( 9) = LA2 - CENTRAL LATITUDE -C IGDS(10) = LO2 - CENTRAL LONGTITUDE -C IGDS(11) = DI - LONGITUDINAL DIRECTION INCREMENT -C IGDS(12) = DJ - LATITUDINAL DIRECTION INCREMENT -C IGDS(13) = SCANNING MODE FLAGS (CODE TABLE 8) -C IGDS(14) = ... THROUGH ... -C IGDS(18) = ... NOT USED FOR THIS GRID -C -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM SP -C -C$$$ -C - INTEGER IGRID - INTEGER IGDS (*) - INTEGER GRD1 (18) - INTEGER GRD2 (18) - INTEGER GRD3 (18) - INTEGER GRD4 (18) - INTEGER GRD5 (18) - INTEGER GRD6 (18) - INTEGER GRD8 (18) - INTEGER GRD21 (55) - INTEGER GRD22 (55) - INTEGER GRD23 (55) - INTEGER GRD24 (55) - INTEGER GRD25 (37) - INTEGER GRD26 (37) - INTEGER GRD27 (18) - INTEGER GRD28 (18) - INTEGER GRD29 (18) - INTEGER GRD30 (18) - INTEGER GRD33 (18) - INTEGER GRD34 (18) - INTEGER GRD37 (91) - INTEGER GRD38 (91) - INTEGER GRD39 (91) - INTEGER GRD40 (91) - INTEGER GRD41 (91) - INTEGER GRD42 (91) - INTEGER GRD43 (91) - INTEGER GRD44 (91) - INTEGER GRD45 (18) - INTEGER GRD53 (18) - INTEGER GRD55 (18) - INTEGER GRD56 (18) - INTEGER GRD61 (64) - INTEGER GRD62 (64) - INTEGER GRD63 (64) - INTEGER GRD64 (64) - INTEGER GRD85 (18) - INTEGER GRD86 (18) - INTEGER GRD87 (18) - INTEGER GRD88 (18) - INTEGER GRD90 (18) - INTEGER GRD91 (18) - INTEGER GRD92 (18) - INTEGER GRD93 (18) - INTEGER GRD94 (18) - INTEGER GRD95 (18) - INTEGER GRD96 (18) - INTEGER GRD97 (18) - INTEGER GRD98 (18) - INTEGER GRD100(18) - INTEGER GRD101(18) - INTEGER GRD103(18) - INTEGER GRD104(18) - INTEGER GRD105(18) - INTEGER GRD106(18) - INTEGER GRD107(18) - INTEGER GRD110(18) - INTEGER GRD120(18) - INTEGER GRD126(18) - INTEGER GRD127(18) - INTEGER GRD130(18) - INTEGER GRD145(18) - INTEGER GRD146(18) - INTEGER GRD147(18) - INTEGER GRD148(18) - INTEGER GRD160(18) - INTEGER GRD161(18) - INTEGER GRD163(18) - INTEGER GRD170(18) - INTEGER GRD171(18) - INTEGER GRD172(18) - INTEGER GRD173(18) - INTEGER GRD174(18) - INTEGER GRD175(18) - INTEGER GRD190(18) - INTEGER GRD192(18) - INTEGER GRD194(18) - INTEGER GRD196(18) - INTEGER GRD198(18) - INTEGER GRD201(18) - INTEGER GRD202(18) - INTEGER GRD203(18) - INTEGER GRD204(18) - INTEGER GRD205(18) - INTEGER GRD206(18) - INTEGER GRD207(18) - INTEGER GRD208(18) - INTEGER GRD209(18) - INTEGER GRD210(18) - INTEGER GRD211(18) - INTEGER GRD212(18) - INTEGER GRD213(18) - INTEGER GRD214(18) - INTEGER GRD215(18) - INTEGER GRD216(18) - INTEGER GRD217(18) - INTEGER GRD218(18) - INTEGER GRD219(18) - INTEGER GRD220(18) - INTEGER GRD221(18) - INTEGER GRD222(18) - INTEGER GRD223(18) - INTEGER GRD224(18) - INTEGER GRD225(18) - INTEGER GRD226(18) - INTEGER GRD227(18) - INTEGER GRD228(18) - INTEGER GRD229(18) - INTEGER GRD230(18) - INTEGER GRD231(18) - INTEGER GRD232(18) - INTEGER GRD233(18) - INTEGER GRD234(18) - INTEGER GRD235(18) - INTEGER GRD236(18) - INTEGER GRD237(18) - INTEGER GRD238(18) - INTEGER GRD239(18) - INTEGER GRD240(18) - INTEGER GRD241(18) - INTEGER GRD242(18) - INTEGER GRD243(18) - INTEGER GRD244(18) - INTEGER GRD245(18) - INTEGER GRD246(18) - INTEGER GRD247(18) - INTEGER GRD248(18) - INTEGER GRD249(18) - INTEGER GRD250(18) - INTEGER GRD251(18) - INTEGER GRD252(18) - INTEGER GRD253(18) - INTEGER GRD254(18) -C - DATA GRD1 / 0, 255, 1, 73, 23, -48090, 0, 128, 48090, - & 0, 513669,513669, 22500, 64, 0, 0, 0, 0/ - DATA GRD2 / 0, 255, 0, 144, 73, 90000, 0, 128, -90000, - & -2500, 2500, 2500, 0, 0, 0, 0, 0, 0/ - DATA GRD3 / 0, 255, 0, 360,181, 90000, 0, 128, -90000, - & -1000, 1000, 1000, 0, 0, 0, 0, 0, 0/ - DATA GRD4 / 0, 255, 0, 720,361, 90000, 0, 128, -90000, - & -500, 500, 500, 0, 0, 0, 0, 0, 0/ - DATA GRD5 / 0, 255, 5, 53, 57, 7647, -133443, 8, -105000, - & 190500, 190500, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD6 / 0, 255, 5, 53, 45, 7647, -133443, 8, -105000, - & 190500, 190500, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD8 / 0, 255, 1, 116, 44, -48670, 3104, 128, 61050, - & 0, 318830, 318830, 22500, 64, 0, 0, 0, 0/ - DATA GRD21 / 0, 33, 0,65535,37, 0, 0, 128, 90000, - & 180000, 2500, 5000, 64, 0, 0, 0, 0, 0, - & 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, - & 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, - & 37, 37, 37, 37, 37, 37, 1/ - DATA GRD22 / 0, 33, 0,65535,37, 0, -180000, 128, 90000, - & 0, 2500, 5000, 64, 0, 0, 0, 0, 0, - & 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, - & 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, - & 37, 37, 37, 37, 37, 37, 1/ - DATA GRD23 / 0, 33, 0,65535, 37, -90000, 0, 128, 0, - & 180000, 2500, 5000, 64, 0, 0, 0, 0, 0, - & 1, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, - & 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, - & 37, 37, 37, 37, 37, 37, 37/ - DATA GRD24 / 0, 33, 0,65535, 37, -90000, -180000, 128, 0, - & 0, 2500, 5000, 64, 0, 0, 0, 0, 0, - & 1, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, - & 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, - & 37, 37, 37, 37, 37, 37, 37/ - DATA GRD25 / 0, 33, 0,65535, 19, 0, 0, 128, 90000, - & 355000, 5000, 5000, 64, 0, 0, 0, 0, 0, - & 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, - & 72, 72, 72, 1/ - DATA GRD26 / 0, 33, 0,65535, 19, -90000, 0, 128, 0, - & 355000, 5000, 5000, 64, 0, 0, 0, 0, 0, - & 1, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, - & 72, 72, 72, 72/ - DATA GRD27 / 0, 255, 5, 65, 65, -20826, -125000, 8, -80000, - & 381000, 381000, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD28 / 0, 255, 5, 65, 65, 20826, 145000, 8, -80000, - & 381000, 381000,128, 64, 0, 0, 0, 0, 0/ - DATA GRD29 / 0, 255, 0, 145, 37, 0, 0, 128, 90000, - & 360000, 2500, 2500, 64, 0, 0, 0, 0, 0/ - DATA GRD30 / 0, 255, 0, 145, 37, -90000, 0, 128, 0, - & 360000, 2500, 2500, 64, 0, 0, 0, 0, 0/ - DATA GRD33 / 0, 255, 0, 181, 46, 0, 0, 128, 90000, - & 360000, 2000, 2000, 64, 0, 0, 0, 0, 0/ - DATA GRD34 / 0, 255, 0, 181, 46, -90000, 0, 128, 0, - & 360000, 2000, 2000, 64, 0, 0, 0, 0, 0/ - DATA GRD37 / 0, 33, 0,65535,73, 0, -30000, 128, 90000, - & 60000, 1250,65535, 64, 0, 0, 0, 0, 0, - & 73, 73, 73, 73, 73, 73, 73, 73, 72, 72, 72, 71, 71, 71, 70, - & 70, 69, 69, 68, 67, 67, 66, 65, 65, 64, 63, 62, 61, 60, 60, - & 59, 58, 57, 56, 55, 54, 52, 51, 50, 49, 48, 47, 45, 44, 43, - & 42, 40, 39, 38, 36, 35, 33, 32, 30, 29, 28, 26, 25, 23, 22, - & 20, 19, 17, 16, 14, 12, 11, 9, 8, 6, 5, 3, 2/ - DATA GRD38 / 0, 33, 0,65535,73, 0, 60000, 128, 90000, - & 150000, 1250,65535, 64, 0, 0, 0, 0, 0, - & 73, 73, 73, 73, 73, 73, 73, 73, 72, 72, 72, 71, 71, 71, 70, - & 70, 69, 69, 68, 67, 67, 66, 65, 65, 64, 63, 62, 61, 60, 60, - & 59, 58, 57, 56, 55, 54, 52, 51, 50, 49, 48, 47, 45, 44, 43, - & 42, 40, 39, 38, 36, 35, 33, 32, 30, 29, 28, 26, 25, 23, 22, - & 20, 19, 17, 16, 14, 12, 11, 9, 8, 6, 5, 3, 2/ - DATA GRD39 / 0, 33, 0,65535,73, 0, 150000, 128, 90000, - & -120000, 1250,65535, 64, 0, 0, 0, 0, 0, - & 73, 73, 73, 73, 73, 73, 73, 73, 72, 72, 72, 71, 71, 71, 70, - & 70, 69, 69, 68, 67, 67, 66, 65, 65, 64, 63, 62, 61, 60, 60, - & 59, 58, 57, 56, 55, 54, 52, 51, 50, 49, 48, 47, 45, 44, 43, - & 42, 40, 39, 38, 36, 35, 33, 32, 30, 29, 28, 26, 25, 23, 22, - & 20, 19, 17, 16, 14, 12, 11, 9, 8, 6, 5, 3, 2/ - DATA GRD40 / 0, 33, 0,65535,73, 0, -120000, 128, 90000, - & -30000, 1250,65535, 64, 0, 0, 0, 0, 0, - & 73, 73, 73, 73, 73, 73, 73, 73, 72, 72, 72, 71, 71, 71, 70, - & 70, 69, 69, 68, 67, 67, 66, 65, 65, 64, 63, 62, 61, 60, 60, - & 59, 58, 57, 56, 55, 54, 52, 51, 50, 49, 48, 47, 45, 44, 43, - & 42, 40, 39, 38, 36, 35, 33, 32, 30, 29, 28, 26, 25, 23, 22, - & 20, 19, 17, 16, 14, 12, 11, 9, 8, 6, 5, 3, 2/ - DATA GRD41 / 0, 33, 0,65535,73, -90000, -30000, 128, 0, - & 60000, 1250,65535, 64, 0, 0, 0, 0, 0, - & 2, 3, 5, 6, 8, 9, 11, 12, 14, 16, 17, 19, 20, 22, 23, - & 25, 26, 28, 29, 30, 32, 33, 35, 36, 38, 39, 40, 42, 43, 44, - & 45, 47, 48, 49, 50, 51, 52, 54, 55, 56, 57, 58, 59, 60, 60, - & 61, 62, 63, 64, 65, 65, 66, 67, 67, 68, 69, 69, 70, 70, 71, - & 71, 71, 72, 72, 72, 73, 73, 73, 73, 73, 73, 73, 73/ - DATA GRD42 / 0, 33, 0,65535,73, -90000, 60000, 128, 0, - & 150000, 1250,65535, 64, 0, 0, 0, 0, 0, - & 2, 3, 5, 6, 8, 9, 11, 12, 14, 16, 17, 19, 20, 22, 23, - & 25, 26, 28, 29, 30, 32, 33, 35, 36, 38, 39, 40, 42, 43, 44, - & 45, 47, 48, 49, 50, 51, 52, 54, 55, 56, 57, 58, 59, 60, 60, - & 61, 62, 63, 64, 65, 65, 66, 67, 67, 68, 69, 69, 70, 70, 71, - & 71, 71, 72, 72, 72, 73, 73, 73, 73, 73, 73, 73, 73/ - DATA GRD43 / 0, 33, 0,65535,73, -90000, 150000, 128, 0, - & -120000, 1250,65535, 64, 0, 0, 0, 0, 0, - & 2, 3, 5, 6, 8, 9, 11, 12, 14, 16, 17, 19, 20, 22, 23, - & 25, 26, 28, 29, 30, 32, 33, 35, 36, 38, 39, 40, 42, 43, 44, - & 45, 47, 48, 49, 50, 51, 52, 54, 55, 56, 57, 58, 59, 60, 60, - & 61, 62, 63, 64, 65, 65, 66, 67, 67, 68, 69, 69, 70, 70, 71, - & 71, 71, 72, 72, 72, 73, 73, 73, 73, 73, 73, 73, 73/ - DATA GRD44 / 0, 33, 0,65535,73, -90000, -120000, 128, 0, - & -30000, 1250,65535, 64, 0, 0, 0, 0, 0, - & 2, 3, 5, 6, 8, 9, 11, 12, 14, 16, 17, 19, 20, 22, 23, - & 25, 26, 28, 29, 30, 32, 33, 35, 36, 38, 39, 40, 42, 43, 44, - & 45, 47, 48, 49, 50, 51, 52, 54, 55, 56, 57, 58, 59, 60, 60, - & 61, 62, 63, 64, 65, 65, 66, 67, 67, 68, 69, 69, 70, 70, 71, - & 71, 71, 72, 72, 72, 73, 73, 73, 73, 73, 73, 73, 73/ - DATA GRD45 / 0, 255, 0, 288,145, 90000, 0, 128, -90000, - & -1250, 1250, 1250, 0, 0, 0, 0, 0, 0/ - DATA GRD53 / 0, 255, 1, 117, 51, -61050, 0, 128, 61050, - & 0, 318830, 318830, 22500, 64, 0, 0, 0, 0/ - DATA GRD55 / 0, 255, 5, 87, 71, -10947, -154289, 8, -105000, - & 254000, 254000, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD56 / 0, 255, 5, 87, 71, 7647, -133443, 8, -105000, - & 127000, 127000, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD61 / 0, 33, 0,65535, 46, 0, 0, 128, 90000, - & 180000, 2000, 2000, 64, 0, 0, 0, 0, 0, - & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, - & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, - & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, - & 1/ - DATA GRD62 / 0, 33, 0,65535, 46, 0, -180000, 128, 90000, - & 0, 2000, 2000, 64, 0, 0, 0, 0, 0, - & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, - & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, - & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, - & 1/ - DATA GRD63 / 0, 33, 0,65535, 46, 0, -90000, 128, 0, - & 180000, 2000, 2000, 64, 0, 0, 0, 0, 0, - & 1, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, - & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, - & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, - & 91/ - DATA GRD64 / 0, 33, 0,65535, 46, -90000, -180000, 128, 0, - & 0, 2000, 2000, 64, 0, 0, 0, 0, 0, - & 1, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, - & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, - & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, - & 91/ - DATA GRD85 / 0, 255, 0, 360, 90, 500, 500, 128, 89500, - & 359500, 1000, 1000, 64, 0, 0, 0, 0, 0/ - DATA GRD86 / 0, 255, 0, 360, 90, -89500, 500, 128, -500, - & 359500, 1000, 1000, 64, 0, 0, 0, 0, 0/ - DATA GRD87 / 0, 255, 5, 81, 62, 22876, -120491, 8, -105000, - & 68153, 68153, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD88 / 0, 255, 5, 580,548, 10000, -128000, 8, -105000, - & 15000, 15000, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD90 / 0, 255,203,223,501, 23060, -92570, 136, 37000, - & -80000, 53,53,64, 0, 0, 0, 0, 0/ - DATA GRD91 / 0, 255,203,223,501, 23060, -110570, 136, 37000, - & -98000, 53,53,64, 0, 0, 0, 0, 0/ - DATA GRD92 / 0, 255,203,223,501, 25986, -127871, 136, 40000, - & -115000, 53,53,64, 0, 0, 0, 0, 0/ - DATA GRD93 / 0, 255,203,223,501, 44232, -169996, 136, 63000, - & -150000, 67,66,64, 0, 0, 0, 0, 0/ - DATA GRD94 / 0, 255,203,345,569, -3441, -148799, 136, 50000, - & -111000, 154,141,64, 0, 0, 0, 0, 0/ - DATA GRD95 / 0, 255,203,146,247, 35222, -131741, 136, 44000, - & -240000, 67, 66,64, 0, 0, 0, 0, 0/ - DATA GRD96 / 0, 255,203,606,1067, -3441, -148799, 136, 50000, - & -111000, 88,75,64, 0, 0, 0, 0, 0/ - DATA GRD97 / 0, 255,203, 89,143, 14451, -71347, 136, 18000, - & -66500, 53, 53,64, 0, 0, 0, 0, 0/ - DATA GRD98 / 0, 255, 4, 192, 94, 88542, 0, 128, -88542, - & -1875, 47,1875, 0, 0, 0, 0, 0, 0/ - DATA GRD100/ 0, 255, 5, 83, 83, 17108, -129296, 8, -105000, - & 91452, 91452, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD101/ 0, 255, 5, 113, 91, 10528, -137146, 8, -105000, - & 91452, 91452, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD103/ 0, 255, 5, 65, 56, 22405, -121352, 8, -105000, - & 91452, 91452, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD104/ 0, 255, 5, 147,110, -268, -139475, 8, -105000, - & 90755, 90755, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD105/ 0, 255, 5, 83, 83, 17529, -129296, 8, -105000, - & 90755, 90755, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD106/ 0, 255, 5, 165,117, 17533, -129296, 8, -105000, - & 45373, 45373, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD107/ 0, 255, 5, 120, 92, 23438, -120168, 8, -105000, - & 45373, 45373, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD110/ 0, 255, 0, 464,224, 25063, -124938, 128, 52938, - & -67063, 125, 125, 64, 0, 0, 0, 0, 0/ - DATA GRD120/ 0, 255,203,1200,1648, 0, 0, 8, 0, - & 0, 0, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD126/ 0, 255, 4, 384,190, 89277, 0, 128, -89277, - & -938, 95, 938, 0, 0, 0, 0, 0, 0/ - DATA GRD127/ 0, 255, 4, 768,384, 89642, 0, 128, -89642, - & -469, 192, 469, 0, 0, 0, 0, 0, 0/ - DATA GRD130/ 0, 255, 3, 451,337, 16281, -126138, 8, -95000, - & 13545, 13545, 0, 64, 0, 25000, 25000, 0, 0/ - DATA GRD145/ 0, 255, 3, 169,145, 32174, -90159, 8, -79500, - & 12000, 12000, 0, 64, 0, 36000, 46000, 0, 0/ - DATA GRD146/ 0, 255, 3, 166,142, 32353, -89994, 8, -79500, - & 12000, 12000, 0, 64, 0, 36000, 46000, 0, 0/ - DATA GRD147/ 0, 255, 3, 268,259, 24595, -100998, 8, -97000, - & 12000, 12000, 0, 64, 0, 33000, 45000, 0, 0/ - DATA GRD148/ 0, 255, 3, 442,265, 21821, -120628, 8, -97000, - & 12000, 12000, 0, 64, 0, 33000, 45000, 0, 0/ - DATA GRD160/ 0, 255, 5, 180,156, 19132, -185837, 8, -150000, - & 47625, 47625, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD161/ 0, 255, 0, 137,102, 50750, 271750, 72, -250, - & -19750, 500,500, 0, 0, 0, 0, 0, 0/ - DATA GRD163/ 0, 255, 3,1008,722, 20600, -118300, 8, -95000, - & 5000, 5000, 0, 64, 0, 38000, 38000, 0, 0/ - DATA GRD170/ 0, 255, 4, 512, 256, 89463, 0, 128, -89463, - & -703, 128, 703, 0, 0, 0, 0, 0, 0/ - DATA GRD171/ 0, 255, 5, 770,930, 25009, -119560, 72, -80000, - & 12700, 12700, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD172/ 0, 255, 5, 690,710, -36900, -220194, 72, -260000, - & 12700, 12700, 128, 64, 0, 0, 0, 0, 0/ - DATA GRD173/ 0, 255, 0,4320,2160, 89958, 417, 128, 89958, - & 359958, 83, 83, 64, 0, 0, 0, 0, 0/ - DATA GRD174/ 0, 255, 4,2880,1440, 89938, 62, 72, -89938, - & -62, 125, 125,64, 0, 0, 0, 0, 0/ - DATA GRD175/ 0, 255, 0, 556,334, 0, 130000, 128, 30060, - & 180040, 90, 90, 64, 0, 0, 0, 0, 0/ - DATA GRD190 / 0, 255,203, 92,141, 182, -149887, 136, 52000, - & -111000, 577,538,64, 0, 0, 0, 0, 0/ - DATA GRD192 / 0, 255,203,237,387, -3441, -148799, 136, 50000, - & -111000, 225,207,64, 0, 0, 0, 0, 0/ - DATA GRD194 / 0, 255,203, 89,143, 16444, -162244, 136, 20250, - & -157350, 53, 53,64, 0, 0, 0, 0, 0/ - DATA GRD196/ 0, 255,201,45903,1, 23476, -96745, 136, 151, - & 305, 67, 66, 64, 0, 0, 0, 0, 0/ - DATA GRD198/ 0, 255,203,160,261, -3441, -148799, 136, 50000, - & -111000, 333,308,64, 0, 0, 0, 0, 0/ - DATA GRD201/ 0, 255, 5, 65, 65, -20826, -150000, 8, -105000, - & 381000, 381000, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD202/ 0, 255, 5, 65, 43, 7838, -141028, 8, -105000, - & 190500, 190500, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD203/ 0, 255, 5, 45, 39, 19132, -185837, 8, -150000, - & 190500, 190500, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD204/ 0, 255, 1, 93, 68, -25000, 110000, 128, 60644, - & -109129, 160000, 160000, 20000, 64, 0, 0, 0, 0/ - DATA GRD205/ 0, 255, 5, 45, 39, 616, -84904, 8, -60000, - & 190500, 190500, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD206/ 0, 255, 3, 51, 41, 22289, -117991, 8, - 95000, - & 81271, 81271, 0, 64, 0, 25000, 25000, 0, 0/ - DATA GRD207/ 0, 255, 5, 49, 35, 42085, -175641, 8, -150000, - & 95250, 95250, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD208/ 0, 255, 1, 29, 27, 9343, -167315, 128, 28092, - & -145878, 80000, 80000, 20000, 64, 0, 0, 0, 0/ - DATA GRD209/ 0, 255, 3, 275,223, -4850, -151100, 8, -111000, - & 44000, 44000, 0, 64, 0, 45000, 45000, 0, 0/ - DATA GRD210/ 0, 255, 1, 25, 25, 9000, -77000, 128, 26422, - & -58625, 80000, 80000, 20000, 64, 0, 0, 0, 0/ - DATA GRD211/ 0, 255, 3, 93, 65, 12190, -133459, 8, -95000, - & 81271, 81271, 0, 64, 0, 25000, 25000, 0, 0/ - DATA GRD212/ 0, 255, 3, 185,129, 12190, -133459, 8, -95000, - & 40635, 40635, 0, 64, 0, 25000, 25000, 0, 0/ - DATA GRD213/ 0, 255, 5, 129, 85, 7838, -141028, 8, -105000, - & 95250, 95250, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD214/ 0, 255, 5, 97, 69, 42085, -175641, 8, -150000, - & 47625, 47625, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD215/ 0, 255, 3, 369,257, 12190, -133459, 8, -95000, - & 20318, 20318, 0, 64, 0, 25000, 25000, 0, 0/ - DATA GRD216/ 0, 255, 5, 139,107, 30000, -173000, 8, -135000, - & 45000, 45000, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD217/ 0, 255, 5, 277,213, 30000, -173000, 8, -135000, - & 22500, 22500, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD218/ 0, 255, 3, 614,428, 12190, -133459, 8, -95000, - & 12191, 12191, 0, 64, 0, 25000, 25000, 0, 0/ - DATA GRD219/ 0, 255, 5, 385,465, 25008, -119559, 72, -80000, - & 25400, 25400, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD220/ 0, 255, 5, 345,355, -36889, -220194, 72, -80000, - & 25400, 25400, 128, 64, 0, 0, 0, 0, 0/ - DATA GRD221/ 0, 255, 3, 349,277, 1000, -145500, 8, -107000, - & 32463, 32463, 0, 64, 0, 50000, 50000, 0, 0/ - DATA GRD222/ 0, 255, 3, 138,112, -4850, -151100, 8, -111000, - & 88000, 88000, 0, 64, 0, 45000, 45000, 0, 0/ - DATA GRD223/ 0, 255, 5, 129,129, -20826, -150000, 8, -105000, - & 190500, 190500, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD224/ 0, 255, 5, 65, 65, 20826, 120000, 8, -105000, - & 381000, 381000, 128, 64, 0, 0, 0, 0, 0/ - DATA GRD225/ 0, 255, 1, 185,135, -25000, -250000, 128, 60640, - & -109129, 80000, 80000, 20000, 64, 0, 0, 0, 0/ - DATA GRD226/ 0, 255, 3, 737,513, 12190, -133459, 8, -95000, - & 10159, 10159, 0, 64, 0, 25000, 25000, 0, 0/ - DATA GRD227/ 0, 255, 3,1473,1025, 12190, -133459, 8, -95000, - & 5079, 5079, 0, 64, 0, 25000, 25000, 0, 0/ - DATA GRD228/ 0, 255, 0, 144, 73, 90000, 0, 128, -90000, - & -2500, 2500, 2500, 64, 0, 0, 0, 0, 0/ - DATA GRD229/ 0, 255, 0, 360,181, 90000, 0, 128, -90000, - & -1000, 1000, 1000, 64, 0, 0, 0, 0, 0/ - DATA GRD230/ 0, 255, 0, 720,361, 90000, 0, 128, -90000, - & -500, 500, 500, 64, 0, 0, 0, 0, 0/ - DATA GRD231/ 0, 255, 0, 720,181, 0, 0, 128, 90000, - & -500, 500, 500, 64, 0, 0, 0, 0, 0/ - DATA GRD232/ 0, 255, 0, 360, 91, 0, 0, 128, 90000, - & -1000, 1000, 1000, 64, 0, 0, 0, 0, 0/ - DATA GRD233/ 0, 255, 0, 288,157, 78000, 0, 128, -78000, - & -1250, 1250, 1000, 64, 0, 0, 0, 0, 0/ - DATA GRD234/ 0, 255, 0, 133,121, 15000, -98000, 128, -45000, - & -65000, 250, 250, 64, 0, 0, 0, 0, 0/ - DATA GRD235/ 0, 255, 0, 720,360, 89750, 250, 72, -89750, - & -250, 250, 1000, 64, 0, 0, 0, 0, 0/ - DATA GRD236/ 0, 255, 3, 151,113, 16281, 233862, 8, -95000, - & 40635, 40635, 0, 64, 0, 25000, 25000, 0, 0/ - DATA GRD237/ 0, 255, 3, 54, 47, 16201, 285720, 8, -107000, - & 32463, 32463, 0, 64, 0, 50000, 50000, 0, 0/ - DATA GRD238/ 0, 255, 0, 275, 203, 50750, 261750, 72, -205, - & -29750, 0, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD239/ 0, 255, 0, 155, 123, 75750, 159500, 72, 44750, - & -123500, 0, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD240/ 0, 255, 5, 1121, 881, 23098, -119036, 8, -105000, - & 47625, 47625, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD241/ 0, 255, 3, 549,445, -4850, -151100, 8, -111000, - & 22000, 22000, 0, 64, 0, 45000, 45000, 0, 0/ - DATA GRD242/ 0, 255, 5, 553,425, 30000, -173000, 8, -135000, - & 11250, 11250, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD243/ 0, 255, 0, 126,101, 10000, -170000, 128, 50000, - & -120000, 400, 400, 64, 0, 0, 0, 0, 0/ - DATA GRD244/ 0, 255, 0, 275, 203, 50750, 261750, 72, -205, - & -29750, 0, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD245/ 0, 255, 3, 336,372, 22980, -92840, 8, -80000, - & 8000, 8000, 0, 64, 0, 35000, 35000, 0, 0/ - DATA GRD246/ 0, 255, 3, 332,371, 25970, -127973, 8, -115000, - & 8000, 8000, 0, 64, 0, 40000, 40000, 0, 0/ - DATA GRD247/ 0, 255, 3, 336,372, 22980, -110840, 8, -98000, - & 8000, 8000, 0, 64, 0, 35000, 35000, 0, 0/ - DATA GRD248/ 0, 255, 0, 135,101, 14500, -71500, 128, 22000, - & -61450, 75, 75, 64, 0, 0, 0, 0, 0/ - DATA GRD249/ 0, 255, 5, 367,343, 45400, -171600, 8, -150000, - & 9868, 9868, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD250/ 0, 255, 0, 135,101, 16500, -162000, 128, 24000, - & -151950, 75, 75, 64, 0, 0, 0, 0, 0/ - DATA GRD251/ 0, 255, 0, 332,210, 26350, -83050, 128, 47250, - & -49950, 100, 100, 64, 0, 0, 0, 0, 0/ - DATA GRD252/ 0, 255, 3, 301,225, 16281, 233862, 8, 265000, - & 20318, 20318, 0, 64, 0, 25000, 25000, 0, 0/ - DATA GRD253/ 0, 255, 0, 373,224, 6050, -170250, 72, 4750, - & -77250, 75, 75, 64, 0, 0, 0, 0, 0/ - DATA GRD254/ 0, 255, 1, 369,300, -35000, -250000, 128, 60789, - & -109129, 40000,40000, 20000, 64, 0, 0, 0, 0/ -C - IERR = 0 -C - DO 1 I = 1,18 - IGDS(I) = 0 - 1 CONTINUE -C - IF (IGRID.GE.37.AND.IGRID.LE.44) THEN - DO 2 I = 19,91 - IGDS(I) = 0 - 2 CONTINUE - END IF -C - IF (IGRID.GE.21.AND.IGRID.LE.24) THEN - DO I = 19,55 - IGDS(I) = 0 - END DO - END IF -C - IF (IGRID.GE.25.AND.IGRID.LE.26) THEN - DO I = 19,37 - IGDS(I) = 0 - END DO - END IF -C - IF (IGRID.GE.61.AND.IGRID.LE.64) THEN - DO I = 19,64 - IGDS(I) = 0 - END DO - END IF -C - IF (IGRID.EQ.1) THEN - DO 3 I = 1,18 - IGDS(I) = GRD1(I) - 3 CONTINUE -C - ELSE IF (IGRID.EQ.2) THEN - DO 4 I = 1,18 - IGDS(I) = GRD2(I) - 4 CONTINUE -C - ELSE IF (IGRID.EQ.3) THEN - DO 5 I = 1,18 - IGDS(I) = GRD3(I) - 5 CONTINUE -C - ELSE IF (IGRID.EQ.4) THEN - DO 6 I = 1,18 - IGDS(I) = GRD4(I) - 6 CONTINUE -C - ELSE IF (IGRID.EQ.5) THEN - DO 10 I = 1,18 - IGDS(I) = GRD5(I) - 10 CONTINUE -C - ELSE IF (IGRID.EQ.6) THEN - DO 20 I = 1,18 - IGDS(I) = GRD6(I) - 20 CONTINUE -C - ELSE IF (IGRID.EQ.8) THEN - DO I = 1,18 - IGDS(I) = GRD8(I) - END DO -C - ELSE IF (IGRID.EQ.21) THEN - DO 30 I = 1,55 - IGDS(I) = GRD21(I) - 30 CONTINUE -C - ELSE IF (IGRID.EQ.22) THEN - DO 40 I = 1,55 - IGDS(I) = GRD22(I) - 40 CONTINUE -C - ELSE IF (IGRID.EQ.23) THEN - DO 50 I = 1,55 - IGDS(I) = GRD23(I) - 50 CONTINUE -C - ELSE IF (IGRID.EQ.24) THEN - DO 60 I = 1,55 - IGDS(I) = GRD24(I) - 60 CONTINUE -C - ELSE IF (IGRID.EQ.25) THEN - DO 70 I = 1,37 - IGDS(I) = GRD25(I) - 70 CONTINUE -C - ELSE IF (IGRID.EQ.26) THEN - DO 80 I = 1,37 - IGDS(I) = GRD26(I) - 80 CONTINUE -C - ELSE IF (IGRID.EQ.27) THEN - DO 90 I = 1,18 - IGDS(I) = GRD27(I) - 90 CONTINUE -C - ELSE IF (IGRID.EQ.28) THEN - DO 100 I = 1,18 - IGDS(I) = GRD28(I) - 100 CONTINUE -C - ELSE IF (IGRID.EQ.29) THEN - DO 110 I = 1,18 - IGDS(I) = GRD29(I) - 110 CONTINUE -C - ELSE IF (IGRID.EQ.30) THEN - DO 120 I = 1,18 - IGDS(I) = GRD30(I) - 120 CONTINUE -C - ELSE IF (IGRID.EQ.33) THEN - DO 130 I = 1,18 - IGDS(I) = GRD33(I) - 130 CONTINUE -C - ELSE IF (IGRID.EQ.34) THEN - DO 140 I = 1,18 - IGDS(I) = GRD34(I) - 140 CONTINUE -C - ELSE IF (IGRID.EQ.37) THEN - DO 141 I = 1,91 - IGDS(I) = GRD37(I) - 141 CONTINUE -C - ELSE IF (IGRID.EQ.38) THEN - DO 142 I = 1,91 - IGDS(I) = GRD38(I) - 142 CONTINUE -C - ELSE IF (IGRID.EQ.39) THEN - DO 143 I = 1,91 - IGDS(I) = GRD39(I) - 143 CONTINUE -C - ELSE IF (IGRID.EQ.40) THEN - DO 144 I = 1,91 - IGDS(I) = GRD40(I) - 144 CONTINUE -C - ELSE IF (IGRID.EQ.41) THEN - DO 145 I = 1,91 - IGDS(I) = GRD41(I) - 145 CONTINUE -C - ELSE IF (IGRID.EQ.42) THEN - DO 146 I = 1,91 - IGDS(I) = GRD42(I) - 146 CONTINUE -C - ELSE IF (IGRID.EQ.43) THEN - DO 147 I = 1,91 - IGDS(I) = GRD43(I) - 147 CONTINUE -C - ELSE IF (IGRID.EQ.44) THEN - DO 148 I = 1,91 - IGDS(I) = GRD44(I) - 148 CONTINUE -C - ELSE IF (IGRID.EQ.45) THEN - DO 149 I = 1,18 - IGDS(I) = GRD45(I) - 149 CONTINUE -C - ELSE IF (IGRID.EQ.53) THEN - DO I = 1,18 - IGDS(I) = GRD53(I) - END DO -C - ELSE IF (IGRID.EQ.55) THEN - DO 152 I = 1,18 - IGDS(I) = GRD55(I) - 152 CONTINUE -C - ELSE IF (IGRID.EQ.56) THEN - DO 154 I = 1,18 - IGDS(I) = GRD56(I) - 154 CONTINUE -C - ELSE IF (IGRID.EQ.61) THEN - DO 160 I = 1,64 - IGDS(I) = GRD61(I) - 160 CONTINUE -C - ELSE IF (IGRID.EQ.62) THEN - DO 170 I = 1,64 - IGDS(I) = GRD62(I) - 170 CONTINUE -C - ELSE IF (IGRID.EQ.63) THEN - DO 180 I = 1,64 - IGDS(I) = GRD63(I) - 180 CONTINUE -C - ELSE IF (IGRID.EQ.64) THEN - DO 190 I = 1,64 - IGDS(I) = GRD64(I) - 190 CONTINUE -C - ELSE IF (IGRID.EQ.85) THEN - DO 192 I = 1,18 - IGDS(I) = GRD85(I) - 192 CONTINUE -C - ELSE IF (IGRID.EQ.86) THEN - DO 194 I = 1,18 - IGDS(I) = GRD86(I) - 194 CONTINUE -C - ELSE IF (IGRID.EQ.87) THEN - DO 195 I = 1,18 - IGDS(I) = GRD87(I) - 195 CONTINUE -C - ELSE IF (IGRID.EQ.88) THEN - DO 2195 I = 1,18 - IGDS(I) = GRD88(I) -2195 CONTINUE -C - ELSE IF (IGRID.EQ.90) THEN - DO 196 I = 1,18 - IGDS(I) = GRD90(I) - 196 CONTINUE -C - ELSE IF (IGRID.EQ.91) THEN - DO 197 I = 1,18 - IGDS(I) = GRD91(I) - 197 CONTINUE -C - ELSE IF (IGRID.EQ.92) THEN - DO 198 I = 1,18 - IGDS(I) = GRD92(I) - 198 CONTINUE -C - ELSE IF (IGRID.EQ.93) THEN - DO 199 I = 1,18 - IGDS(I) = GRD93(I) - 199 CONTINUE -C - ELSE IF (IGRID.EQ.94) THEN - DO 200 I = 1,18 - IGDS(I) = GRD94(I) - 200 CONTINUE -C - ELSE IF (IGRID.EQ.95) THEN - DO 201 I = 1,18 - IGDS(I) = GRD95(I) - 201 CONTINUE -C - ELSE IF (IGRID.EQ.96) THEN - DO 202 I = 1,18 - IGDS(I) = GRD96(I) - 202 CONTINUE -C - ELSE IF (IGRID.EQ.97) THEN - DO 203 I = 1,18 - IGDS(I) = GRD97(I) - 203 CONTINUE -C - ELSE IF (IGRID.EQ.98) THEN - DO 204 I = 1,18 - IGDS(I) = GRD98(I) - 204 CONTINUE -C - ELSE IF (IGRID.EQ.100) THEN - DO 205 I = 1,18 - IGDS(I) = GRD100(I) - 205 CONTINUE -C - ELSE IF (IGRID.EQ.101) THEN - DO 210 I = 1,18 - IGDS(I) = GRD101(I) - 210 CONTINUE -C - ELSE IF (IGRID.EQ.103) THEN - DO 220 I = 1,18 - IGDS(I) = GRD103(I) - 220 CONTINUE -C - ELSE IF (IGRID.EQ.104) THEN - DO 230 I = 1,18 - IGDS(I) = GRD104(I) - 230 CONTINUE -C - ELSE IF (IGRID.EQ.105) THEN - DO 240 I = 1,18 - IGDS(I) = GRD105(I) - 240 CONTINUE -C - ELSE IF (IGRID.EQ.106) THEN - DO 242 I = 1,18 - IGDS(I) = GRD106(I) - 242 CONTINUE -C - ELSE IF (IGRID.EQ.107) THEN - DO 244 I = 1,18 - IGDS(I) = GRD107(I) - 244 CONTINUE -C - ELSE IF (IGRID.EQ.110) THEN - DO I = 1,18 - IGDS(I) = GRD110(I) - ENDDO -C - ELSE IF (IGRID.EQ.120) THEN - DO I = 1,18 - IGDS(I) = GRD120(I) - ENDDO -C - ELSE IF (IGRID.EQ.126) THEN - DO 245 I = 1,18 - IGDS(I) = GRD126(I) - 245 CONTINUE -C - ELSE IF (IGRID.EQ.127) THEN - DO I = 1,18 - IGDS(I) = GRD127(I) - ENDDO -C - ELSE IF (IGRID.EQ.130) THEN - DO I = 1,18 - IGDS(I) = GRD130(I) - ENDDO -C - ELSE IF (IGRID.EQ.145) THEN - DO I = 1,18 - IGDS(I) = GRD145(I) - ENDDO -C - ELSE IF (IGRID.EQ.146) THEN - DO I = 1,18 - IGDS(I) = GRD146(I) - ENDDO -C - ELSE IF (IGRID.EQ.147) THEN - DO I = 1,18 - IGDS(I) = GRD147(I) - ENDDO -C - ELSE IF (IGRID.EQ.148) THEN - DO I = 1,18 - IGDS(I) = GRD148(I) - ENDDO -C - ELSE IF (IGRID.EQ.160) THEN - DO I = 1,18 - IGDS(I) = GRD160(I) - ENDDO -C - ELSE IF (IGRID.EQ.161) THEN - DO I = 1,18 - IGDS(I) = GRD161(I) - ENDDO - ELSE IF (IGRID.EQ.163) THEN - DO I = 1,18 - IGDS(I) = GRD163(I) - ENDDO -C - ELSE IF (IGRID.EQ.170) THEN - DO I = 1,18 - IGDS(I) = GRD170(I) - ENDDO -C - ELSE IF (IGRID.EQ.171) THEN - DO I = 1,18 - IGDS(I) = GRD171(I) - ENDDO -C - ELSE IF (IGRID.EQ.172) THEN - DO I = 1,18 - IGDS(I) = GRD172(I) - ENDDO -C - ELSE IF (IGRID.EQ.173) THEN - DO I = 1,18 - IGDS(I) = GRD173(I) - ENDDO -C - ELSE IF (IGRID.EQ.174) THEN - DO I = 1,18 - IGDS(I) = GRD174(I) - ENDDO -C - ELSE IF (IGRID.EQ.175) THEN - DO I = 1,18 - IGDS(I) = GRD175(I) - ENDDO -C - ELSE IF (IGRID.EQ.190) THEN - DO 2190 I = 1,18 - IGDS(I) = GRD190(I) - 2190 CONTINUE -C - ELSE IF (IGRID.EQ.192) THEN - DO 2191 I = 1,18 - IGDS(I) = GRD192(I) - 2191 CONTINUE -C - ELSE IF (IGRID.EQ.194) THEN - DO 2192 I = 1,18 - IGDS(I) = GRD194(I) - 2192 CONTINUE -C - ELSE IF (IGRID.EQ.196) THEN - DO 249 I = 1,18 - IGDS(I) = GRD196(I) - 249 CONTINUE -C - ELSE IF (IGRID.EQ.198) THEN - DO 2490 I = 1,18 - IGDS(I) = GRD198(I) - 2490 CONTINUE -C - ELSE IF (IGRID.EQ.201) THEN - DO 250 I = 1,18 - IGDS(I) = GRD201(I) - 250 CONTINUE -C - ELSE IF (IGRID.EQ.202) THEN - DO 260 I = 1,18 - IGDS(I) = GRD202(I) - 260 CONTINUE -C - ELSE IF (IGRID.EQ.203) THEN - DO 270 I = 1,18 - IGDS(I) = GRD203(I) - 270 CONTINUE -C - ELSE IF (IGRID.EQ.204) THEN - DO 280 I = 1,18 - IGDS(I) = GRD204(I) - 280 CONTINUE -C - ELSE IF (IGRID.EQ.205) THEN - DO 290 I = 1,18 - IGDS(I) = GRD205(I) - 290 CONTINUE -C - ELSE IF (IGRID.EQ.206) THEN - DO 300 I = 1,18 - IGDS(I) = GRD206(I) - 300 CONTINUE -C - ELSE IF (IGRID.EQ.207) THEN - DO 310 I = 1,18 - IGDS(I) = GRD207(I) - 310 CONTINUE -C - ELSE IF (IGRID.EQ.208) THEN - DO 320 I = 1,18 - IGDS(I) = GRD208(I) - 320 CONTINUE -C - ELSE IF (IGRID.EQ.209) THEN - DO 330 I = 1,18 - IGDS(I) = GRD209(I) - 330 CONTINUE -C - ELSE IF (IGRID.EQ.210) THEN - DO 340 I = 1,18 - IGDS(I) = GRD210(I) - 340 CONTINUE -C - ELSE IF (IGRID.EQ.211) THEN - DO 350 I = 1,18 - IGDS(I) = GRD211(I) - 350 CONTINUE -C - ELSE IF (IGRID.EQ.212) THEN - DO 360 I = 1,18 - IGDS(I) = GRD212(I) - 360 CONTINUE -C - ELSE IF (IGRID.EQ.213) THEN - DO 370 I = 1,18 - IGDS(I) = GRD213(I) - 370 CONTINUE -C - ELSE IF (IGRID.EQ.214) THEN - DO 380 I = 1,18 - IGDS(I) = GRD214(I) - 380 CONTINUE -C - ELSE IF (IGRID.EQ.215) THEN - DO 390 I = 1,18 - IGDS(I) = GRD215(I) - 390 CONTINUE -C - ELSE IF (IGRID.EQ.216) THEN - DO 400 I = 1,18 - IGDS(I) = GRD216(I) - 400 CONTINUE -C - ELSE IF (IGRID.EQ.217) THEN - DO 401 I = 1,18 - IGDS(I) = GRD217(I) - 401 CONTINUE -C - ELSE IF (IGRID.EQ.218) THEN - DO 410 I = 1,18 - IGDS(I) = GRD218(I) - 410 CONTINUE -C - ELSE IF (IGRID.EQ.219) THEN - DO 411 I = 1,18 - IGDS(I) = GRD219(I) - 411 CONTINUE -C - ELSE IF (IGRID.EQ.220) THEN - DO 412 I = 1,18 - IGDS(I) = GRD220(I) - 412 CONTINUE -C - ELSE IF (IGRID.EQ.221) THEN - DO 413 I = 1,18 - IGDS(I) = GRD221(I) - 413 CONTINUE -C - ELSE IF (IGRID.EQ.222) THEN - DO 414 I = 1,18 - IGDS(I) = GRD222(I) - 414 CONTINUE -C - ELSE IF (IGRID.EQ.223) THEN - DO 415 I = 1,18 - IGDS(I) = GRD223(I) - 415 CONTINUE -C - ELSE IF (IGRID.EQ.224) THEN - DO 416 I = 1,18 - IGDS(I) = GRD224(I) - 416 CONTINUE -C - ELSE IF (IGRID.EQ.225) THEN - DO 417 I = 1,18 - IGDS(I) = GRD225(I) - 417 CONTINUE -C - ELSE IF (IGRID.EQ.226) THEN - DO 418 I = 1,18 - IGDS(I) = GRD226(I) - 418 CONTINUE -C - ELSE IF (IGRID.EQ.227) THEN - DO 419 I = 1,18 - IGDS(I) = GRD227(I) - 419 CONTINUE -C - ELSE IF (IGRID.EQ.228) THEN - DO 420 I = 1,18 - IGDS(I) = GRD228(I) - 420 CONTINUE -C - ELSE IF (IGRID.EQ.229) THEN - DO 421 I = 1,18 - IGDS(I) = GRD229(I) - 421 CONTINUE -C - ELSE IF (IGRID.EQ.230) THEN - DO 422 I = 1,18 - IGDS(I) = GRD230(I) - 422 CONTINUE -C - ELSE IF (IGRID.EQ.231) THEN - DO 423 I = 1,18 - IGDS(I) = GRD231(I) - 423 CONTINUE -C - ELSE IF (IGRID.EQ.232) THEN - DO 424 I = 1,18 - IGDS(I) = GRD232(I) - 424 CONTINUE -C - ELSE IF (IGRID.EQ.233) THEN - DO 425 I = 1,18 - IGDS(I) = GRD233(I) - 425 CONTINUE -C - ELSE IF (IGRID.EQ.234) THEN - DO 426 I = 1,18 - IGDS(I) = GRD234(I) - 426 CONTINUE -C - ELSE IF (IGRID.EQ.235) THEN - DO 427 I = 1,18 - IGDS(I) = GRD235(I) - 427 CONTINUE -C - ELSE IF (IGRID.EQ.236) THEN - DO 428 I = 1,18 - IGDS(I) = GRD236(I) - 428 CONTINUE -C - ELSE IF (IGRID.EQ.237) THEN - DO 429 I = 1,18 - IGDS(I) = GRD237(I) - 429 CONTINUE -C - ELSE IF (IGRID.EQ.238) THEN - DO I = 1,18 - IGDS(I) = GRD238(I) - END DO -C - ELSE IF (IGRID.EQ.239) THEN - DO I = 1,18 - IGDS(I) = GRD239(I) - END DO -C - ELSE IF (IGRID.EQ.240) THEN - DO I = 1,18 - IGDS(I) = GRD240(I) - END DO -C - ELSE IF (IGRID.EQ.241) THEN - DO 430 I = 1,18 - IGDS(I) = GRD241(I) - 430 CONTINUE -C - ELSE IF (IGRID.EQ.242) THEN - DO 431 I = 1,18 - IGDS(I) = GRD242(I) - 431 CONTINUE -C - ELSE IF (IGRID.EQ.243) THEN - DO 432 I = 1,18 - IGDS(I) = GRD243(I) - 432 CONTINUE -C - ELSE IF (IGRID.EQ.244) THEN - DO I = 1,18 - IGDS(I) = GRD244(I) - END DO -C - ELSE IF (IGRID.EQ.245) THEN - DO 433 I = 1,18 - IGDS(I) = GRD245(I) - 433 CONTINUE -C - ELSE IF (IGRID.EQ.246) THEN - DO 434 I = 1,18 - IGDS(I) = GRD246(I) - 434 CONTINUE -C - ELSE IF (IGRID.EQ.247) THEN - DO 435 I = 1,18 - IGDS(I) = GRD247(I) - 435 CONTINUE -C - ELSE IF (IGRID.EQ.248) THEN - DO 436 I = 1,18 - IGDS(I) = GRD248(I) - 436 CONTINUE -C - ELSE IF (IGRID.EQ.249) THEN - DO 437 I = 1,18 - IGDS(I) = GRD249(I) - 437 CONTINUE -C - ELSE IF (IGRID.EQ.250) THEN - DO 438 I = 1,18 - IGDS(I) = GRD250(I) - 438 CONTINUE -C - ELSE IF (IGRID.EQ.251) THEN - DO 439 I = 1,18 - IGDS(I) = GRD251(I) - 439 CONTINUE -C - ELSE IF (IGRID.EQ.252) THEN - DO 440 I = 1,18 - IGDS(I) = GRD252(I) - 440 CONTINUE - ELSE IF (IGRID.EQ.253) THEN - DO 441 I = 1,18 - IGDS(I) = GRD253(I) - 441 CONTINUE - ELSE IF (IGRID.EQ.254) THEN - DO 442 I = 1,18 - IGDS(I) = GRD254(I) - 442 CONTINUE -C - ELSE - IERR = 1 - ENDIF -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fi72.f b/src/fim/FIMsrc/w3/w3fi72.f deleted file mode 100644 index 042d83b..0000000 --- a/src/fim/FIMsrc/w3/w3fi72.f +++ /dev/null @@ -1,468 +0,0 @@ - SUBROUTINE W3FI72(ITYPE,FLD,IFLD,IBITL, - & IPFLAG,ID,PDS, - & IGFLAG,IGRID,IGDS,ICOMP, - & IBFLAG,IBMAP,IBLEN,IBDSFL, - & NPTS,KBUF,ITOT,JERR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI72 MAKE A COMPLETE GRIB MESSAGE -C PRGMMR: FARLEY ORG: NMC421 DATE:94-11-22 -C -C ABSTRACT: MAKES A COMPLETE GRIB MESSAGE FROM A USER SUPPLIED -C ARRAY OF FLOATING POINT OR INTEGER DATA. THE USER HAS THE -C OPTION OF SUPPLYING THE PDS OR AN INTEGER ARRAY THAT WILL BE -C USED TO CREATE A PDS (WITH W3FI68). THE USER MUST ALSO -C SUPPLY OTHER NECESSARY INFO; SEE USAGE SECTION BELOW. -C -C PROGRAM HISTORY LOG: -C 91-05-08 R.E.JONES -C 92-07-01 M. FARLEY ADDED GDS AND BMS LOGIC. PLACED EXISTING -C LOGIC FOR BDS IN A ROUTINE. -C 92-10-02 R.E.JONES ADD ERROR EXIT FOR W3FI73 -C 93-04-30 R.E.JONES REPLACE DO LOOPS TO MOVE CHARACTER DATA -C WITH XMOVEX, USE XSTORE TO ZERO CHARACTER -C ARRAY. MAKE CHANGE SO FLAT FIELD WILL PACK. -C 93-08-06 CAVANAUGH MODIFIED CALL TO W3FI75 -C 93-10-26 CAVANAUGH ADDED CODE TO RESTORE INPUT FIELD TO ORIGINAL -C VALUES IF D-SCALE NOT 0 -C 94-01-27 CAVANAUGH ADDED IGDS ARRAY IN CALL TO W3FI75 TO PROVIDE -C INFORMATION FOR BOUSTROPHEDONIC PROCESSING -C 94-03-03 CAVANAUGH INCREASED SIZE OF GDS ARRAY FOR THIN GRIDS -C 94-05-16 FARLEY CLEANED UP DOCUMENTATION -C 94-11-10 FARLEY INCREASED SIZE OF PFLD/IFLD ARRARYS FROM -C 100K TO 260K FOR .5 DEGREE SST ANAL FIELDS -C 94-12-04 R.E.JONES CHANGE DOCUMENT FOR IPFLAG. -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 98-05-19 Gilbert Increased array dimensions to handle grids -C of up to 500,000 grid points. -C 95-10-31 IREDELL GENERALIZED WORD SIZE -C 98-12-21 Gilbert Replaced Function ICHAR with mova2i. -C 99-02-01 Gilbert Changed the method of zeroing out array KBUF. -C the old method, using W3FI01 and XSTORE was -C incorrect with 4-byte integers and 8-byte reals. -C 2001-06-07 Gilbert Removed calls to xmovex. -C changed IPFLD from integer to character. -C -C USAGE: CALL W3FI72(ITYPE,FLD,IFLD,IBITL, -C & IPFLAG,ID,PDS, -C & IGFLAG,IGRID,IGDS,ICOMP, -C & IBFLAG,IBMAP,IBLEN,IBDSFL, -C & IBDSFL, -C & NPTS,KBUF,ITOT,JERR) -C -C INPUT ARGUMENT LIST: -C ITYPE - 0 = FLOATING POINT DATA SUPPLIED IN ARRAY 'FLD' -C 1 = INTEGER DATA SUPPLIED IN ARRAY 'IFLD' -C FLD - REAL ARRAY OF DATA (AT PROPER GRIDPOINTS) TO BE -C CONVERTED TO GRIB FORMAT IF ITYPE=0. -C SEE REMARKS #1 & 2. -C IFLD - INTEGER ARRAY OF DATA (AT PROPER GRIDPOINTS) TO BE -C CONVERTED TO GRIB FORMAT IF ITYPE=1. -C SEE REMARKS #1 & 2. -C IBITL - 0 = COMPUTER COMPUTES LENGTH FOR PACKING DATA FROM -C POWER OF 2 (NUMBER OF BITS) BEST FIT OF DATA -C USING 'VARIABLE' BIT PACKER W3FI58. -C 8, 12, ETC. COMPUTER RESCALES DATA TO FIT INTO THAT -C 'FIXED' NUMBER OF BITS USING W3FI59. -C SEE REMARKS #3. -C -C IPFLAG - 0 = MAKE PDS FROM USER SUPPLIED ARRAY (ID) -C 1 = USER SUPPLYING PDS -C NOTE: IF PDS IS GREATER THAN 30, USE IPLFAG=1. -C THE USER COULD CALL W3FI68 BEFORE HE CALLS -C W3FI72. THIS WOULD MAKE THE FIRST 30 BYTES OF -C THE PDS, USER THEN WOULD MAKE BYTES AFTER 30. -C ID - INTEGER ARRAY OF VALUES THAT W3FI68 WILL USE -C TO MAKE AN EDITION 1 PDS IF IPFLAG=0. (SEE THE -C DOCBLOCK FOR W3FI68 FOR LAYOUT OF ARRAY) -C PDS - CHARACTER ARRAY OF VALUES (VALID PDS SUPPLIED -C BY USER) IF IPFLAG=1. LENGTH MAY EXCEED 28 BYTES -C (CONTENTS OF BYTES BEYOND 28 ARE PASSED -C THROUGH UNCHANGED). -C -C IGFLAG - 0 = MAKE GDS BASED ON 'IGRID' VALUE. -C 1 = MAKE GDS FROM USER SUPPLIED INFO IN 'IGDS' -C AND 'IGRID' VALUE. -C SEE REMARKS #4. -C IGRID - # = GRID IDENTIFICATION (TABLE B) -C 255 = IF USER DEFINED GRID; IGDS MUST BE SUPPLIED -C AND IGFLAG MUST =1. -C IGDS - INTEGER ARRAY CONTAINING USER GDS INFO (SAME -C FORMAT AS SUPPLIED BY W3FI71 - SEE DOCKBLOCK FOR -C LAYOUT) IF IGFLAG=1. -C ICOMP - RESOLUTION AND COMPONENT FLAG FOR BIT 5 OF GDS(17) -C 0 = EARTH ORIENTED WINDS -C 1 = GRID ORIENTED WINDS -C -C IBFLAG - 0 = MAKE BIT MAP FROM USER SUPPLIED DATA -C # = BIT MAP PREDEFINED BY CENTER -C SEE REMARKS #5. -C IBMAP - INTEGER ARRAY CONTAINING BIT MAP -C IBLEN - LENGTH OF BIT MAP WILL BE USED TO VERIFY LENGTH -C OF FIELD (ERROR IF IT DOESN'T MATCH). -C -C IBDSFL - INTEGER ARRAY CONTAINING TABLE 11 FLAG INFO -C BDS OCTET 4: -C (1) 0 = GRID POINT DATA -C 1 = SPHERICAL HARMONIC COEFFICIENTS -C (2) 0 = SIMPLE PACKING -C 1 = SECOND ORDER PACKING -C (3) ... SAME VALUE AS 'ITYPE' -C 0 = ORIGINAL DATA WERE FLOATING POINT VALUES -C 1 = ORIGINAL DATA WERE INTEGER VALUES -C (4) 0 = NO ADDITIONAL FLAGS AT OCTET 14 -C 1 = OCTET 14 CONTAINS FLAG BITS 5-12 -C (5) 0 = RESERVED - ALWAYS SET TO 0 -C BYTE 6 OPTION 1 NOT AVAILABLE (AS OF 5-16-93) -C (6) 0 = SINGLE DATUM AT EACH GRID POINT -C 1 = MATRIX OF VALUES AT EACH GRID POINT -C BYTE 7 OPTION 0 WITH SECOND ORDER PACKING N/A (AS OF 5-16-93) -C (7) 0 = NO SECONDARY BIT MAPS -C 1 = SECONDARY BIT MAPS PRESENT -C (8) 0 = SECOND ORDER VALUES HAVE CONSTANT WIDTH -C 1 = SECOND ORDER VALUES HAVE DIFFERENT WIDTHS -C -C OUTPUT ARGUMENT LIST: -C NPTS - NUMBER OF GRIDPOINTS IN ARRAY FLD OR IFLD -C KBUF - ENTIRE GRIB MESSAGE ('GRIB' TO '7777') -C EQUIVALENCE TO INTEGER ARRAY TO MAKE SURE IT -C IS ON WORD BOUNARY. -C ITOT - TOTAL LENGTH OF GRIB MESSAGE IN BYTES -C JERR - = 0, COMPLETED MAKING GRIB FIELD WITHOUT ERROR -C 1, IPFLAG NOT 0 OR 1 -C 2, IGFLAG NOT 0 OR 1 -C 3, ERROR CONVERTING IEEE F.P. NUMBER TO IBM370 F.P. -C 4, W3FI71 ERROR/IGRID NOT DEFINED -C 5, W3FK74 ERROR/GRID REPRESENTATION TYPE NOT VALID -C 6, GRID TOO LARGE FOR PACKER DIMENSION ARRAYS -C SEE AUTOMATION DIVISION FOR REVISION! -C 7, LENGTH OF BIT MAP NOT EQUAL TO SIZE OF FLD/IFLD -C 8, W3FI73 ERROR, ALL VALUES IN IBMAP ARE ZERO -C 9, W3FI75 (W3FI58) ERROR, PACK ROUTINE DYNAMIC RANGE OVERFLOW. -C -C OUTPUT FILES: -C FT06F001 - STANDARD FORTRAN OUTPUT PRINT FILE -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - W3FI58, W3FI59, W3FI68, W3FI71, W3FI73, W3FI74 -C W3FI75, W3FI76 -C FORTRAN 90 INTRINSIC - BIT_SIZE -C -C REMARKS: -C 1) IF BIT MAP TO BE INCLUDED IN MESSAGE, NULL DATA SHOULD -C BE INCLUDED IN FLD OR IFLD. THIS ROUTINE WILL TAKE CARE -C OF 'DISCARDING' ANY NULL DATA BASED ON THE BIT MAP. -C 2) UNITS MUST BE THOSE IN GRIB DOCUMENTATION: NMC O.N. 388 -C OR WMO PUBLICATION 306. -C 3) IN EITHER CASE, INPUT NUMBERS WILL BE MULTIPLIED BY -C '10 TO THE NTH' POWER FOUND IN ID(25) OR PDS(27-28), -C THE D-SCALING FACTOR, PRIOR TO BINARY PACKING. -C 4) ALL NMC PRODUCED GRIB FIELDS WILL HAVE A GRID DEFINITION -C SECTION INCLUDED IN THE GRIB MESSAGE. ID(6) WILL BE -C SET TO '1'. -C - GDS WILL BE BUILT BASED ON GRID NUMBER (IGRID), UNLESS -C IGFLAG=1 (USER SUPPLYING IGDS). USER MUST STILL SUPPLY -C IGRID EVEN IF IGDS PROVIDED. -C 5) IF BIT MAP USED THEN ID(7) OR PDS(8) MUST INDICATE THE -C PRESENCE OF A BIT MAP. -C 6) ARRAY KBUF SHOULD BE EQUIVALENCED TO AN INTEGER VALUE OR -C ARRAY TO MAKE SURE IT IS ON A WORD BOUNDARY. -C 7) SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ -C - REAL FLD(*) -C - INTEGER IBDSFL(*) - INTEGER IBMAP(*) - INTEGER ID(*) - INTEGER IFLD(*) - INTEGER IGDS(*) - INTEGER IB(4) -C - CHARACTER * 1 BDS11(11) - CHARACTER * 1 KBUF(*) - CHARACTER * 1 PDS(*) - CHARACTER * 1 GDS(200) - CHARACTER(1),ALLOCATABLE:: BMS(:) - CHARACTER(1),ALLOCATABLE:: PFLD(:) - CHARACTER(1),ALLOCATABLE:: IPFLD(:) - CHARACTER * 1 SEVEN - CHARACTER * 1 ZERO - integer LENBDS -C -C -C ASCII REP OF /'G', 'R', 'I', 'B'/ -C - DATA IB / 71, 82, 73, 66/ -C - BDS11 = char(0) !JFM - IER = 0 - IBERR = 0 - JERR = 0 - IGRIBL = 8 - IPDSL = 0 - LENGDS = 0 - LENBMS = 0 - LENBDS = 0 - ITOSS = 0 -C -C$ 1.0 PRODUCT DEFINITION SECTION(PDS). -C -C SET ID(6) TO 1 ...OR... MODIFY PDS(8) ... -C REGARDLESS OF USER SPECIFICATION... -C NMC GRIB FIELDS WILL ALWAYS HAVE A GDS -C - IF (IPFLAG .EQ.0) THEN - ID(6) = 1 - CALL W3FI68(ID,PDS) - ELSE IF (IPFLAG .EQ. 1) THEN - IF (IAND(mova2i(PDS(8)),64) .EQ. 64) THEN -C BOTH GDS AND BMS - PDS(8) = CHAR(192) - ELSE IF (mova2i(PDS(8)) .EQ. 0) THEN -C GDS ONLY - PDS(8) = CHAR(128) - END IF - CONTINUE - ELSE -C PRINT *,' W3FI72 ERROR, IPFLAG IS NOT 0 OR 1 IPFLAG = ',IPFLAG - JERR = 1 - GO TO 900 - END IF -C -C GET LENGTH OF PDS -C - IPDSL = mova2i(PDS(1)) * 65536 + mova2i(PDS(2)) * 256 + - & mova2i(PDS(3)) -C -C$ 2.0 GRID DEFINITION SECTION (GDS). -C -C IF IGFLAG=1 THEN USER IS SUPPLYING THE IGDS INFORMATION -C - IF (IGFLAG .EQ. 0) THEN - CALL W3FI71(IGRID,IGDS,IGERR) - IF (IGERR .EQ. 1) THEN -C PRINT *,' W3FI71 ERROR, GRID TYPE NOT DEFINED...',IGRID - JERR = 4 - GO TO 900 - END IF - END IF - IF (IGFLAG .EQ. 0 .OR. IGFLAG .EQ.1) THEN - CALL W3FI74(IGDS,ICOMP,GDS,LENGDS,NPTS,IGERR) - IF (IGERR .EQ. 1) THEN -C PRINT *,' W3FI74 ERROR, GRID REP TYPE NOT VALID...',IGDS(3) - JERR = 5 - GO TO 900 - ELSE - END IF - ELSE -C PRINT *,' W3FI72 ERROR, IGFLAG IS NOT 0 OR 1 IGFLAG = ',IGFLAG - JERR = 2 - GO TO 900 - END IF -C -C$ 3.0 BIT MAP SECTION (BMS). -C -C SET ITOSS=1 IF BITMAP BEING USED. W3FI75 WILL TOSS DATA -C PRIOR TO PACKING. LATER CODING WILL BE NEEDED WHEN THE -C 'PREDEFINED' GRIDS ARE FINALLY 'DEFINED'. -C - IF (mova2i(PDS(8)) .EQ. 64 .OR. - & mova2i(PDS(8)) .EQ. 192) THEN - ITOSS = 1 - IF (IBFLAG .EQ. 0) THEN - IF (IBLEN .NE. NPTS) THEN -C PRINT *,' W3FI72 ERROR, IBLEN .NE. NPTS = ',IBLEN,NPTS - JERR = 7 - GO TO 900 - END IF -C - IF (MOD(IBLEN,16).NE.0) THEN -C NEED EVEN NUMBER OF OCTETS - NLEFT = 16 - MOD(IBLEN,16) - ALLOCATE(BMS(NPTS/8+2+6)) - ELSE - NLEFT = 0 - ALLOCATE(BMS(NPTS/8+6)) - END IF -C - CALL W3FI73(IBFLAG,IBMAP,IBLEN,BMS,LENBMS,IER) - IF (IER .NE. 0) THEN -C PRINT *,' W3FI73 ERROR, IBMAP VALUES ARE ALL ZERO' - JERR = 8 - GO TO 900 - END IF - ELSE -C PRINT *,' BIT MAP PREDEFINED BY CENTER, IBFLAG = ',IBFLAG - END IF - END IF -C -C$ 4.0 BINARY DATA SECTION (BDS). -C -C$ 4.1 SCALE THE DATA WITH D-SCALE FROM PDS(27-28) -C - JSCALE = mova2i(PDS(27)) * 256 + mova2i(PDS(28)) - IF (IAND(JSCALE,32768).NE.0) THEN - JSCALE = - IAND(JSCALE,32767) - END IF - SCALE = 10.0 ** JSCALE - IF (ITYPE .EQ. 0) THEN - DO 410 I = 1,NPTS - FLD(I) = FLD(I) * SCALE - 410 CONTINUE - ELSE - DO 411 I = 1,NPTS - IFLD(I) = NINT(FLOAT(IFLD(I)) * SCALE) - 411 CONTINUE - END IF -C -C$ 4.2 CALL W3FI75 TO PACK DATA AND MAKE BDS. -C - ALLOCATE(PFLD(NPTS*4)) -C -C Commented out the if test to prevent debugging (-C) to crash on the call to W3FI75 - JFM -CJFM IF(IBDSFL(2).NE.0) THEN - ALLOCATE(IPFLD(NPTS*4)) - IPFLD=char(0) -CJFM ENDIF -cJFM Initialized PFLD because it's passed to w3fi75.f to w3fi58.f to sbytes.f where it is used. - pfld = char(0) -C - CALL W3FI75(IBITL,ITYPE,ITOSS,FLD,IFLD,IBMAP,IBDSFL, - & NPTS,BDS11,IPFLD,PFLD,LEN,LENBDS,IBERR,PDS,IGDS) -C - IF (IBERR .EQ. 2) THEN - JERR = 9 - GO TO 900 - ENDIF - IF(IBDSFL(2).NE.0) THEN -C CALL XMOVEX(PFLD,IPFLD,NPTS*4) - do ii = 1, NPTS*4 - PFLD(ii) = IPFLD(ii) - enddo - DEALLOCATE(IPFLD) - ENDIF -C - IF (IBERR .EQ. 1) THEN - JERR = 3 - GO TO 900 - END IF -C 4.3 IF D-SCALE NOT 0, RESCALE INPUT FIELD TO -C ORIGINAL VALUE -C - IF (JSCALE.NE.0) THEN - DSCALE = 1.0 / SCALE - IF (ITYPE.EQ.0) THEN - DO 412 I = 1, NPTS - FLD(I) = FLD(I) * DSCALE - 412 CONTINUE - ELSE - DO 413 I = 1, NPTS - FLD(I) = NINT(FLOAT(IFLD(I)) * DSCALE) - 413 CONTINUE - END IF - END IF -C -C$ 5.0 OUTPUT SECTION. -C -C$ 5.1 ZERO OUT THE OUTPUT ARRAY KBUF. -C - ZERO = CHAR(00) - ITOT = IGRIBL + IPDSL + LENGDS + LENBMS + LENBDS + 4 -C PRINT *,'IGRIBL =',IGRIBL -C PRINT *,'IPDSL =',IPDSL -C PRINT *,'LENGDS =',LENGDS -C PRINT *,'LENBMS =',LENBMS -C PRINT *,'LENBDS =',LENBDS -C PRINT *,'ITOT =',ITOT - KBUF(1:ITOT)=ZERO -C -C$ 5.2 MOVE SECTION 0 - 'IS' INTO KBUF (8 BYTES). -C - ISTART = 0 - DO 520 I = 1,4 - KBUF(I) = CHAR(IB(I)) - 520 CONTINUE -C - KBUF(5) = CHAR(MOD(ITOT / 65536,256)) - KBUF(6) = CHAR(MOD(ITOT / 256,256)) - KBUF(7) = CHAR(MOD(ITOT ,256)) - KBUF(8) = CHAR(1) -C -C$ 5.3 MOVE SECTION 1 - 'PDS' INTO KBUF (28 BYTES). -C - ISTART = ISTART + IGRIBL - IF (IPDSL.GT.0) THEN -C CALL XMOVEX(KBUF(ISTART+1),PDS,IPDSL) - do ii = 1, IPDSL - KBUF(ISTART+ii) = PDS(ii) - enddo - ELSE -C PRINT *,'LENGTH OF PDS LESS OR EQUAL 0, IPDSL = ',IPDSL - END IF -C -C$ 5.4 MOVE SECTION 2 - 'GDS' INTO KBUF. -C - ISTART = ISTART + IPDSL - IF (LENGDS .GT. 0) THEN -C CALL XMOVEX(KBUF(ISTART+1),GDS,LENGDS) - do ii = 1, LENGDS - KBUF(ISTART+ii) = GDS(ii) - enddo - END IF -C -C$ 5.5 MOVE SECTION 3 - 'BMS' INTO KBUF. -C - ISTART = ISTART + LENGDS - IF (LENBMS .GT. 0) THEN -C CALL XMOVEX(KBUF(ISTART+1),BMS,LENBMS) - do ii = 1, LENBMS - KBUF(ISTART+ii) = BMS(ii) - enddo - END IF -C -C$ 5.6 MOVE SECTION 4 - 'BDS' INTO KBUF. -C -C$ MOVE THE FIRST 11 OCTETS OF THE BDS INTO KBUF. -C - ISTART = ISTART + LENBMS -C CALL XMOVEX(KBUF(ISTART+1),BDS11,11) -c JFM added MovChar so Lahey would not see arbitrary values in PFLD - call MovChar(KBUF(ISTART+1),BDS11,11) -c do ii = 1, 11 -c KBUF(ISTART+ii) = BDS11(ii) -c enddo -C -C$ MOVE THE PACKED DATA INTO THE KBUF -C - ISTART = ISTART + 11 - IF (LEN.GT.0) THEN -C CALL XMOVEX (KBUF(ISTART+1),PFLD,LEN) -c JFM added MovChar so Lahey would not see arbitrary values in PFLD - call MovChar(KBUF(ISTART+1),PFLD,LEN) -c do ii = 1, LEN -c KBUF(ISTART+ii) = PFLD(ii) -c enddo - END IF -C -C$ ADD '7777' TO END OFF KBUF -C NOTE THAT THESE 4 OCTETS NOT INCLUDED IN ACTUAL SIZE OF BDS. -C - SEVEN = CHAR(55) - ISTART = ITOT - 4 -C PRINT *,'ISTART =',ISTART -C PRINT *,'ITOT =',ITOT - DO 562 I = 1,4 - KBUF(ISTART+I) = SEVEN - 562 CONTINUE -C - 900 CONTINUE - IF(ALLOCATED(BMS)) DEALLOCATE(BMS) - IF(ALLOCATED(PFLD)) DEALLOCATE(PFLD) - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fi73.f b/src/fim/FIMsrc/w3/w3fi73.f deleted file mode 100644 index 629373c..0000000 --- a/src/fim/FIMsrc/w3/w3fi73.f +++ /dev/null @@ -1,100 +0,0 @@ - SUBROUTINE W3FI73 (IBFLAG,IBMAP,IBLEN,BMS,LENBMS,IER) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI73 CONSTRUCT GRIB BIT MAP SECTION (BMS) -C PRGMMR: FARLEY ORG: NMC421 DATE:92-11-16 -C -C ABSTRACT: THIS SUBROUTINE CONSTRUCTS A GRIB BIT MAP SECTION. -C -C PROGRAM HISTORY LOG: -C 92-07-01 M. FARLEY ORIGINAL AUTHOR -C 94-02-14 CAVANAUGH RECODED -C 98-06-30 EBISUZAKI LINUX PORT -C -C USAGE: CALL W3FI73 (IBFLAG, IBMAP, IBLEN, BMS, LENBMS, IER) -C INPUT ARGUMENT LIST: -C IBFLAG - 0, IF BIT MAP SUPPLIED BY USER -C - #, NUMBER OF PREDEFINED CENTER BIT MAP -C IBMAP - INTEGER ARRAY CONTAINING USER BIT MAP -C IBLEN - LENGTH OF BIT MAP -C -C OUTPUT ARGUMENT LIST: -C BMS - COMPLETED GRIB BIT MAP SECTION -C LENBMS - LENGTH OF BIT MAP SECTION -C IER - 0 NORMAL EXIT, 8 = IBMAP VALUES ARE ALL ZERO -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - SBYTE -C -C ATTRIBUTES: -C LANGUAGE: IBM370 VS FORTRAN 77, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916/256, CRAY J916/2048 -C -C$$$ -C - INTEGER IBMAP(*) - INTEGER LENBMS - INTEGER IBLEN - INTEGER IBFLAG -C - CHARACTER*1 BMS(*) -C - IER = 0 -C - IZ = 0 - DO 20 I = 1, IBLEN - IF (IBMAP(I).EQ.0) IZ = IZ + 1 - 20 CONTINUE - IF (IZ.EQ.IBLEN) THEN -C -C AT THIS POINT ALL BIT MAP POSITIONS ARE ZERO -C - IER = 8 - RETURN - END IF -C -C BIT MAP IS A COMBINATION OF ONES AND ZEROS -C OR BIT MAP ALL ONES -C -C CONSTRUCT BIT MAP FIELD OF BIT MAP SECTION -C - CALL SBYTESC(BMS,IBMAP,48,1,0,IBLEN) -C - IF (MOD(IBLEN,16).NE.0) THEN - NLEFT = 16 - MOD(IBLEN,16) - ELSE - NLEFT = 0 - END IF -C - NUM = 6 + (IBLEN+NLEFT) / 8 -C -C CONSTRUCT BMS FROM COLLECTED DATA -C -C SIZE INTO FIRST THREE BYTES -C - CALL SBYTEC(BMS,NUM,0,24) -C NUMBER OF FILL BITS INTO BYTE 4 - CALL SBYTEC(BMS,NLEFT,24,8) -C OCTET 5-6 TO CONTAIN INFO FROM IBFLAG - CALL SBYTEC(BMS,IBFLAG,32,16) -C -C BIT MAP MAY BE ALL ONES OR A COMBINATION -C OF ONES AND ZEROS -C -C ACTUAL BITS OF BIT MAP PLACED ALL READY -C -C INSTALL FILL POSITIONS IF NEEDED - IF (NLEFT.NE.0) THEN - NLEFT = 16 - NLEFT -C ZERO FILL POSITIONS - CALL SBYTEC(BMS,0,IBLEN+48,NLEFT) - END IF -C -C STORE NUM IN LENBMS (LENGTH OF BMS SECTION) -C - LENBMS = NUM -C PRINT *,'W3FI73 - BMS LEN =',NUM,LENBMS -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fi74.f b/src/fim/FIMsrc/w3/w3fi74.f deleted file mode 100644 index 8f0b1ad..0000000 --- a/src/fim/FIMsrc/w3/w3fi74.f +++ /dev/null @@ -1,412 +0,0 @@ - SUBROUTINE W3FI74 (IGDS,ICOMP,GDS,LENGDS,NPTS,IGERR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI74 CONSTRUCT GRID DEFINITION SECTION (GDS) -C PRGMMR: FARLEY ORG: W/NMC42 DATE: 93-08-24 -C -C ABSTRACT: THIS SUBROUTINE CONSTRUCTS A GRIB GRID DEFINITION -C SECTION. -C -C PROGRAM HISTORY LOG: -C 92-07-07 M. FARLEY ORIGINAL AUTHOR -C 92-10-16 R.E.JONES ADD CODE TO LAT/LON SECTION TO DO -C GAUSSIAN GRIDS. -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C 93-08-24 R.E.JONES CHANGES FOR GRIB GRIDS 37-44 -C 93-09-29 R.E.JONES CHANGES FOR GAUSSIAN GRID FOR DOCUMENT -C CHANGE IN W3FI71. -C 94-02-15 R.E.JONES CHANGES FOR ETA MODEL GRIDS 90-93 -C 95-04-20 R.E.JONES CHANGE 200 AND 201 TO 201 AND 202 -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 98-08-20 BALDWIN ADD TYPE 203 -C 07-08-30 N. WANG ADDED TYPE 12--ICOSAHEDRAL HEXAGONAL GRID -C -C -C USAGE: CALL W3FI74 (IGDS, ICOMP, GDS, LENGDS, NPTS, IGERR) -C INPUT ARGUMENT LIST: -C IGDS - INTEGER ARRAY SUPPLIED BY W3FI71 -C ICOMP - TABLE 7- RESOLUTION & COMPONENT FLAG (BIT 5) -C FOR GDS(17) WIND COMPONENTS -C -C OUTPUT ARGUMENT LIST: -C GDS - COMPLETED GRIB GRID DEFINITION SECTION -C LENGDS - LENGTH OF GDS -C NPTS - NUMBER OF POINTS IN GRID -C IGERR - 1, GRID REPRESENTATION TYPE NOT VALID -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN 77, IBM370 VS FORTRAN -C MACHINE: CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256, HDS -C -C$$$ -C - INTEGER IGDS (*) -C - CHARACTER*1 GDS (*) -C - ISUM = 0 - IGERR = 0 -C -C PRINT *,' ' -C PRINT *,'(W3FI74-IGDS = )' -C PRINT *,(IGDS(I),I=1,18) -C PRINT *,' ' -C -C COMPUTE LENGTH OF GDS IN OCTETS (OCTETS 1-3) -C LENGTH = 32 FOR LAT/LON, GNOMIC, GAUSIAN LAT/LON, -C POLAR STEREOGRAPHIC, SPHERICAL HARMONICS -C LENGTH = 42 FOR MERCATOR, LAMBERT, TANGENT CONE -C LENGTH = 178 FOR MERCATOR, LAMBERT, TANGENT CONE -C - IF (IGDS(3) .EQ. 0 .OR. IGDS(3) .EQ. 2 .OR. - & IGDS(3) .EQ. 4 .OR. IGDS(3) .EQ. 5 .OR. - & IGDS(3) .EQ. 50 .OR. IGDS(3) .EQ. 201.OR. - & IGDS(3) .EQ. 202.OR. IGDS(3) .EQ. 203.OR. - & IGDS(3) .EQ. 12) THEN - LENGDS = 32 -C -C CORRECTION FOR GRIDS 37-44 -C - IF (IGDS(3).EQ.0.AND.IGDS(1).EQ.0.AND.IGDS(2).NE. - & 255) THEN - LENGDS = IGDS(5) * 2 + 32 - ENDIF - ELSE IF (IGDS(3) .EQ. 1 .OR. IGDS(3) .EQ. 3 .OR. - & IGDS(3) .EQ. 13) THEN - LENGDS = 42 - ELSE - print*, 'IGDS(3)=',IGDS(3) -C PRINT *,' W3FI74 ERROR, GRID REPRESENTATION TYPE NOT VALID' - IGERR = 1 - RETURN - ENDIF -C -C PUT LENGTH OF GDS SECTION IN BYTES 1,2,3 -C - GDS(1) = CHAR(MOD(LENGDS/65536,256)) - GDS(2) = CHAR(MOD(LENGDS/ 256,256)) - GDS(3) = CHAR(MOD(LENGDS ,256)) -C -C OCTET 4 = NV, NUMBER OF VERTICAL COORDINATE PARAMETERS -C OCTET 5 = PV, PL OR 255 -C OCTET 6 = DATA REPRESENTATION TYPE (TABLE 6) -C - GDS(4) = CHAR(IGDS(1)) - GDS(5) = CHAR(IGDS(2)) - GDS(6) = CHAR(IGDS(3)) -C -C FILL OCTET THE REST OF THE GDS BASED ON DATA REPRESENTATION -C TYPE (TABLE 6) -C -C$$ -C PROCESS LAT/LON GRID TYPES OR GAUSSIAN GRID OR ARAKAWA -C STAGGERED, SEMI-STAGGERED, OR FILLED E-GRIDS -C - IF (IGDS(3).EQ.0.OR.IGDS(3).EQ.4.OR. - & IGDS(3).EQ.201.OR.IGDS(3).EQ.202.OR. - & IGDS(3).EQ.203) THEN - GDS( 7) = CHAR(MOD(IGDS(4)/256,256)) - GDS( 8) = CHAR(MOD(IGDS(4) ,256)) - GDS( 9) = CHAR(MOD(IGDS(5)/256,256)) - GDS(10) = CHAR(MOD(IGDS(5) ,256)) - LATO = IGDS(6) - IF (LATO .LT. 0) THEN - LATO = -LATO - LATO = IOR(LATO,8388608) - ENDIF - GDS(11) = CHAR(MOD(LATO/65536,256)) - GDS(12) = CHAR(MOD(LATO/ 256,256)) - GDS(13) = CHAR(MOD(LATO ,256)) - LONO = IGDS(7) - IF (LONO .LT. 0) THEN - LONO = -LONO - LONO = IOR(LONO,8388608) - ENDIF - GDS(14) = CHAR(MOD(LONO/65536,256)) - GDS(15) = CHAR(MOD(LONO/ 256,256)) - GDS(16) = CHAR(MOD(LONO ,256)) - LATEXT = IGDS(9) - IF (LATEXT .LT. 0) THEN - LATEXT = -LATEXT - LATEXT = IOR(LATEXT,8388608) - ENDIF - GDS(18) = CHAR(MOD(LATEXT/65536,256)) - GDS(19) = CHAR(MOD(LATEXT/ 256,256)) - GDS(20) = CHAR(MOD(LATEXT ,256)) - LONEXT = IGDS(10) - IF (LONEXT .LT. 0) THEN - LONEXT = -LONEXT - LONEXT = IOR(LONEXT,8388608) - ENDIF - GDS(21) = CHAR(MOD(LONEXT/65536,256)) - GDS(22) = CHAR(MOD(LONEXT/ 256,256)) - GDS(23) = CHAR(MOD(LONEXT ,256)) - IRES = IAND(IGDS(8),128) - IF (IGDS(3).EQ.201.OR.IGDS(3).EQ.202.OR.IGDS(3).EQ.203) THEN - GDS(24) = CHAR(MOD(IGDS(11)/256,256)) - GDS(25) = CHAR(MOD(IGDS(11) ,256)) - ELSE IF (IRES.EQ.0) THEN - GDS(24) = CHAR(255) - GDS(25) = CHAR(255) - ELSE - GDS(24) = CHAR(MOD(IGDS(12)/256,256)) - GDS(25) = CHAR(MOD(IGDS(12) ,256)) - END IF - IF (IGDS(3).EQ.4) THEN - GDS(26) = CHAR(MOD(IGDS(11)/256,256)) - GDS(27) = CHAR(MOD(IGDS(11) ,256)) - ELSE IF (IGDS(3).EQ.201.OR.IGDS(3).EQ.202.OR. - & IGDS(3).EQ.203) THEN - GDS(26) = CHAR(MOD(IGDS(12)/256,256)) - GDS(27) = CHAR(MOD(IGDS(12) ,256)) - ELSE IF (IRES.EQ.0) THEN - GDS(26) = CHAR(255) - GDS(27) = CHAR(255) - ELSE - GDS(26) = CHAR(MOD(IGDS(11)/256,256)) - GDS(27) = CHAR(MOD(IGDS(11) ,256)) - END IF - GDS(28) = CHAR(IGDS(13)) - GDS(29) = CHAR(0) - GDS(30) = CHAR(0) - GDS(31) = CHAR(0) - GDS(32) = CHAR(0) - IF (LENGDS.GT.32) THEN - ISUM = 0 - I = 19 - DO 10 J = 33,LENGDS,2 - ISUM = ISUM + IGDS(I) - GDS(J) = CHAR(MOD(IGDS(I)/256,256)) - GDS(J+1) = CHAR(MOD(IGDS(I) ,256)) - I = I + 1 - 10 CONTINUE - END IF -C -C$$ PROCESS ICOSAHEDRAL HEXAGONAL GRID TYPES -C ADDED ON 07-08-30, N. W. -C - ELSE IF (IGDS(3) .EQ. 12) THEN - GDS( 7) = CHAR(MOD(IGDS(4)/256,256)) - GDS( 8) = CHAR(MOD(IGDS(4) ,256)) - GDS( 9) = CHAR(MOD(IGDS(5)/256,256)) - GDS(10) = CHAR(MOD(IGDS(5) ,256)) - LATO = IGDS(6) - IF (LATO .LT. 0) THEN - LATO = -LATO - LATO = IOR(LATO,8388608) - ENDIF - GDS(11) = CHAR(MOD(LATO/65536,256)) - GDS(12) = CHAR(MOD(LATO/ 256,256)) - GDS(13) = CHAR(MOD(LATO ,256)) - LONO = IGDS(7) - IF (LONO .LT. 0) THEN - LONO = -LONO - LONO = IOR(LONO,8388608) - ENDIF - GDS(14) = CHAR(MOD(LONO/65536,256)) - GDS(15) = CHAR(MOD(LONO/ 256,256)) - GDS(16) = CHAR(MOD(LONO ,256)) - LATEXT = IGDS(9) - IF (LATEXT .LT. 0) THEN - LATEXT = -LATEXT - LATEXT = IOR(LATEXT,8388608) - ENDIF - GDS(18) = CHAR(MOD(LATEXT/65536,256)) - GDS(19) = CHAR(MOD(LATEXT/ 256,256)) - GDS(20) = CHAR(MOD(LATEXT ,256)) - LONEXT = IGDS(10) - IF (LONEXT .LT. 0) THEN - LONEXT = -LONEXT - LONEXT = IOR(LONEXT,8388608) - ENDIF - GDS(21) = CHAR(MOD(LONEXT/65536,256)) - GDS(22) = CHAR(MOD(LONEXT/ 256,256)) - GDS(23) = CHAR(MOD(LONEXT ,256)) -C Di, Dj --NOT GIVEN - GDS(24) = CHAR(255) - GDS(25) = CHAR(255) - GDS(26) = CHAR(255) - GDS(27) = CHAR(255) -C OCTET 28 -- CURVE TYPE, OCTET 29 -- GRID REFINEMENT LEVELS - GDS(28) = CHAR(IGDS(13)) - GDS(29) = CHAR(IGDS(14)) - GDS(30) = CHAR(0) - GDS(31) = CHAR(0) - GDS(32) = CHAR(0) -C -C$$ PROCESS MERCATOR GRID TYPES -C - ELSE IF (IGDS(3) .EQ. 1) THEN - GDS( 7) = CHAR(MOD(IGDS(4)/256,256)) - GDS( 8) = CHAR(MOD(IGDS(4) ,256)) - GDS( 9) = CHAR(MOD(IGDS(5)/256,256)) - GDS(10) = CHAR(MOD(IGDS(5) ,256)) - LATO = IGDS(6) - IF (LATO .LT. 0) THEN - LATO = -LATO - LATO = IOR(LATO,8388608) - ENDIF - GDS(11) = CHAR(MOD(LATO/65536,256)) - GDS(12) = CHAR(MOD(LATO/ 256,256)) - GDS(13) = CHAR(MOD(LATO ,256)) - LONO = IGDS(7) - IF (LONO .LT. 0) THEN - LONO = -LONO - LONO = IOR(LONO,8388608) - ENDIF - GDS(14) = CHAR(MOD(LONO/65536,256)) - GDS(15) = CHAR(MOD(LONO/ 256,256)) - GDS(16) = CHAR(MOD(LONO ,256)) - LATEXT = IGDS(9) - IF (LATEXT .LT. 0) THEN - LATEXT = -LATEXT - LATEXT = IOR(LATEXT,8388608) - ENDIF - GDS(18) = CHAR(MOD(LATEXT/65536,256)) - GDS(19) = CHAR(MOD(LATEXT/ 256,256)) - GDS(20) = CHAR(MOD(LATEXT ,256)) - LONEXT = IGDS(10) - IF (LONEXT .LT. 0) THEN - LONEXT = -LONEXT - LONEXT = IOR(LONEXT,8388608) - ENDIF - GDS(21) = CHAR(MOD(LONEXT/65536,256)) - GDS(22) = CHAR(MOD(LONEXT/ 256,256)) - GDS(23) = CHAR(MOD(LONEXT ,256)) - GDS(24) = CHAR(MOD(IGDS(13)/65536,256)) - GDS(25) = CHAR(MOD(IGDS(13)/ 256,256)) - GDS(26) = CHAR(MOD(IGDS(13) ,256)) - GDS(27) = CHAR(0) - GDS(28) = CHAR(IGDS(14)) - GDS(29) = CHAR(MOD(IGDS(12)/65536,256)) - GDS(30) = CHAR(MOD(IGDS(12)/ 256,256)) - GDS(31) = CHAR(MOD(IGDS(12) ,256)) - GDS(32) = CHAR(MOD(IGDS(11)/65536,256)) - GDS(33) = CHAR(MOD(IGDS(11)/ 256,256)) - GDS(34) = CHAR(MOD(IGDS(11) ,256)) - GDS(35) = CHAR(0) - GDS(36) = CHAR(0) - GDS(37) = CHAR(0) - GDS(38) = CHAR(0) - GDS(39) = CHAR(0) - GDS(40) = CHAR(0) - GDS(41) = CHAR(0) - GDS(42) = CHAR(0) -C$$ PROCESS LAMBERT CONFORMAL GRID TYPES - ELSE IF (IGDS(3) .EQ. 3) THEN - GDS( 7) = CHAR(MOD(IGDS(4)/256,256)) - GDS( 8) = CHAR(MOD(IGDS(4) ,256)) - GDS( 9) = CHAR(MOD(IGDS(5)/256,256)) - GDS(10) = CHAR(MOD(IGDS(5) ,256)) - LATO = IGDS(6) - IF (LATO .LT. 0) THEN - LATO = -LATO - LATO = IOR(LATO,8388608) - ENDIF - GDS(11) = CHAR(MOD(LATO/65536,256)) - GDS(12) = CHAR(MOD(LATO/ 256,256)) - GDS(13) = CHAR(MOD(LATO ,256)) - LONO = IGDS(7) - IF (LONO .LT. 0) THEN - LONO = -LONO - LONO = IOR(LONO,8388608) - ENDIF - GDS(14) = CHAR(MOD(LONO/65536,256)) - GDS(15) = CHAR(MOD(LONO/ 256,256)) - GDS(16) = CHAR(MOD(LONO ,256)) - LONM = IGDS(9) - IF (LONM .LT. 0) THEN - LONM = -LONM - LONM = IOR(LONM,8388608) - ENDIF - GDS(18) = CHAR(MOD(LONM/65536,256)) - GDS(19) = CHAR(MOD(LONM/ 256,256)) - GDS(20) = CHAR(MOD(LONM ,256)) - GDS(21) = CHAR(MOD(IGDS(10)/65536,256)) - GDS(22) = CHAR(MOD(IGDS(10)/ 256,256)) - GDS(23) = CHAR(MOD(IGDS(10) ,256)) - GDS(24) = CHAR(MOD(IGDS(11)/65536,256)) - GDS(25) = CHAR(MOD(IGDS(11)/ 256,256)) - GDS(26) = CHAR(MOD(IGDS(11) ,256)) - GDS(27) = CHAR(IGDS(12)) - GDS(28) = CHAR(IGDS(13)) - GDS(29) = CHAR(MOD(IGDS(15)/65536,256)) - GDS(30) = CHAR(MOD(IGDS(15)/ 256,256)) - GDS(31) = CHAR(MOD(IGDS(15) ,256)) - GDS(32) = CHAR(MOD(IGDS(16)/65536,256)) - GDS(33) = CHAR(MOD(IGDS(16)/ 256,256)) - GDS(34) = CHAR(MOD(IGDS(16) ,256)) - GDS(35) = CHAR(MOD(IGDS(17)/65536,256)) - GDS(36) = CHAR(MOD(IGDS(17)/ 256,256)) - GDS(37) = CHAR(MOD(IGDS(17) ,256)) - GDS(38) = CHAR(MOD(IGDS(18)/65536,256)) - GDS(39) = CHAR(MOD(IGDS(18)/ 256,256)) - GDS(40) = CHAR(MOD(IGDS(18) ,256)) - GDS(41) = CHAR(0) - GDS(42) = CHAR(0) -C$$ PROCESS POLAR STEREOGRAPHIC GRID TYPES - ELSE IF (IGDS(3) .EQ. 5) THEN - GDS( 7) = CHAR(MOD(IGDS(4)/256,256)) - GDS( 8) = CHAR(MOD(IGDS(4) ,256)) - GDS( 9) = CHAR(MOD(IGDS(5)/256,256)) - GDS(10) = CHAR(MOD(IGDS(5) ,256)) - LATO = IGDS(6) - IF (LATO .LT. 0) THEN - LATO = -LATO - LATO = IOR(LATO,8388608) - ENDIF - GDS(11) = CHAR(MOD(LATO/65536,256)) - GDS(12) = CHAR(MOD(LATO/ 256,256)) - GDS(13) = CHAR(MOD(LATO ,256)) - LONO = IGDS(7) - IF (LONO .LT. 0) THEN - LONO = -LONO - LONO = IOR(LONO,8388608) - ENDIF - GDS(14) = CHAR(MOD(LONO/65536,256)) - GDS(15) = CHAR(MOD(LONO/ 256,256)) - GDS(16) = CHAR(MOD(LONO ,256)) - LONM = IGDS(9) - IF (LONM .LT. 0) THEN - LONM = -LONM - LONM = IOR(LONM,8388608) - ENDIF - GDS(18) = CHAR(MOD(LONM/65536,256)) - GDS(19) = CHAR(MOD(LONM/ 256,256)) - GDS(20) = CHAR(MOD(LONM ,256)) - GDS(21) = CHAR(MOD(IGDS(10)/65536,256)) - GDS(22) = CHAR(MOD(IGDS(10)/ 256,256)) - GDS(23) = CHAR(MOD(IGDS(10) ,256)) - GDS(24) = CHAR(MOD(IGDS(11)/65536,256)) - GDS(25) = CHAR(MOD(IGDS(11)/ 256,256)) - GDS(26) = CHAR(MOD(IGDS(11) ,256)) - GDS(27) = CHAR(IGDS(12)) - GDS(28) = CHAR(IGDS(13)) - GDS(29) = CHAR(0) - GDS(30) = CHAR(0) - GDS(31) = CHAR(0) - GDS(32) = CHAR(0) - ENDIF -C PRINT 10,(GDS(IG),IG=1,32) -C10 FORMAT (' GDS= ',32(1X,Z2.2)) -C -C COMPUTE NUMBER OF POINTS IN GRID BY MULTIPLYING -C IGDS(4) AND IGDS(5) ... NEEDED FOR PACKER -C - IF (IGDS(3).EQ.0.AND.IGDS(1).EQ.0.AND.IGDS(2).NE. - & 255) THEN - NPTS = ISUM - ELSE - NPTS = IGDS(4) * IGDS(5) - ENDIF -C -C 'IOR' ICOMP-BIT 5 RESOLUTION & COMPONENT FLAG FOR WINDS -C WITH IGDS(8) INFO (REST OF RESOLUTION & COMPONENT FLAG DATA) -C - ITEMP = ISHFT(ICOMP,3) - GDS(17) = CHAR(IOR(IGDS(8),ITEMP)) -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fi75.f b/src/fim/FIMsrc/w3/w3fi75.f deleted file mode 100644 index ed17908..0000000 --- a/src/fim/FIMsrc/w3/w3fi75.f +++ /dev/null @@ -1,1637 +0,0 @@ - SUBROUTINE W3FI75 (IBITL,ITYPE,ITOSS,FLD,IFLD,IBMAP,IBDSFL, - & NPTS,BDS11,IPFLD,PFLD,LEN,LENBDS,IBERR,PDS,IGDS) !JFM -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI75 GRIB PACK DATA AND FORM BDS OCTETS(1-11) -C PRGMMR: FARLEY ORG: NMC421 DATE:94-11-22 -C -C ABSTRACT: THIS ROUTINE PACKS A GRIB FIELD AND FORMS OCTETS(1-11) -C OF THE BINARY DATA SECTION (BDS). -C -C PROGRAM HISTORY LOG: -C 92-07-10 M. FARLEY ORIGINAL AUTHOR -C 92-10-01 R.E.JONES CORRECTION FOR FIELD OF CONSTANT DATA -C 92-10-16 R.E.JONES GET RID OF ARRAYS FP AND INT -C 93-08-06 CAVANAUGH ADDED ROUTINES FI7501, FI7502, FI7503 -C TO ALLOW SECOND ORDER PACKING IN PDS. -C 93-07-21 STACKPOLE ASSORTED REPAIRS TO GET 2ND DIFF PACK IN -C 93-10-28 CAVANAUGH COMMENTED OUT NONOPERATIONAL PRINTS AND -C WRITE STATEMENTS -C 93-12-15 CAVANAUGH CORRECTED LOCATION OF START OF FIRST ORDER -C VALUES AND START OF SECOND ORDER VALUES TO -C REFLECT A BYTE LOCATION IN THE BDS INSTEAD -C OF AN OFFSET IN SUBROUTINE FI7501. -C 94-01-27 CAVANAUGH ADDED IGDS AS INPUT ARGUMENT TO THIS ROUTINE -C AND ADDED PDS AND IGDS ARRAYS TO THE CALL TO -C W3FI82 TO PROVIDE INFORMATION NEEDED FOR -C BOUSTROPHEDONIC PROCESSING. -C 94-05-25 CAVANAUGH SUBROUTINE FI7503 HAS BEEN ADDED TO PROVIDE -C FOR ROW BY ROW OR COLUMN BY COLUMN SECOND -C ORDER PACKING. THIS FEATURE CAN BE ACTIVATED -C BY SETTING IBDSFL(7) TO ZERO. -C 94-07-08 CAVANAUGH COMMENTED OUT PRINT STATEMENTS USED FOR DEBUG -C 94-11-22 FARLEY ENLARGED WORK ARRAYS TO HANDLE .5DEGREE GRIDS -C 95-06-01 R.E.JONES CORRECTION FOR NUMBER OF UNUSED BITS AT END -C OF SECTION 4, IN BDS BYTE 4, BITS 5-8. -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 2001-06-06 GILBERT CHanged gbyte/sbyte calls to refer to -C Wesley Ebisuzaki's endian independent -C versions gbytec/sbytec. -C Use f90 standard routine bit_size to get -C number of bits in an integer instead of w3fi01. -C -C USAGE: CALL W3FI75 (IBITL,ITYPE,ITOSS,FLD,IFLD,IBMAP,IBDSFL, -C & NPTS,BDS11,IPFLD,PFLD,LEN,LENBDS,IBERR,PDS,IGDS) -C INPUT ARGUMENT LIST: -C IBITL - 0, COMPUTER COMPUTES PACKING LENGTH FROM POWER -C OF 2 THAT BEST FITS THE DATA. -C 8, 12, ETC. COMPUTER RESCALES DATA TO FIT INTO -C SET NUMBER OF BITS. -C ITYPE - 0 = IF INPUT DATA IS FLOATING POINT (FLD) -C 1 = IF INPUT DATA IS INTEGER (IFLD) -C ITOSS - 0 = NO BIT MAP IS INCLUDED (DON'T TOSS DATA) -C 1 = TOSS NULL DATA ACCORDING TO IBMAP -C FLD - REAL ARRAY OF DATA TO BE PACKED IF ITYPE=0 -C IFLD - INTEGER ARRAY TO BE PACKED IF ITYPE=1 -C IBMAP - BIT MAP SUPPLIED FROM USER -C IBDSFL - INTEGER ARRAY CONTAINING TABLE 11 FLAG INFO -C BDS OCTET 4: -C (1) 0 = GRID POINT DATA -C 1 = SPHERICAL HARMONIC COEFFICIENTS -C (2) 0 = SIMPLE PACKING -C 1 = SECOND ORDER PACKING -C (3) 0 = ORIGINAL DATA WERE FLOATING POINT VALUES -C 1 = ORIGINAL DATA WERE INTEGER VALUES -C (4) 0 = NO ADDITIONAL FLAGS AT OCTET 14 -C 1 = OCTET 14 CONTAINS FLAG BITS 5-12 -C (5) 0 = RESERVED - ALWAYS SET TO 0 -C (6) 0 = SINGLE DATUM AT EACH GRID POINT -C 1 = MATRIX OF VALUES AT EACH GRID POINT -C (7) 0 = NO SECONDARY BIT MAPS -C 1 = SECONDARY BIT MAPS PRESENT -C (8) 0 = SECOND ORDER VALUES HAVE CONSTANT WIDTH -C 1 = SECOND ORDER VALUES HAVE DIFFERENT WIDTHS -C NPTS - NUMBER OF GRIDPOINTS IN ARRAY TO BE PACKED -C IGDS - ARRAY OF GDS INFORMATION -C -C OUTPUT ARGUMENT LIST: -C BDS11 - FIRST 11 OCTETS OF BDS -C PFLD - PACKED GRIB FIELD -C LEN - LENGTH OF PFLD -C LENBDS - LENGTH OF BDS -C IBERR - 1, ERROR CONVERTING IEEE F.P. NUMBER TO IBM370 F.P. -C - 2, W3FI58 DYNAMIC RANGE OVERFLOW. -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256 -C -C$$$ -C - REAL FLD(*) -C REAL FWORK(260000) -C -C FWORK CAN USE DYNAMIC ALLOCATION OF MEMORY ON CRAY -C - REAL FWORK(NPTS) - REAL RMIN,REFNCE -C - character(len=1) IPFLD(*) - INTEGER IBDSFL(*) - INTEGER IBMAP(*) - INTEGER IFLD(*),IGDS(*) -C INTEGER IWORK(260000) -C -C IWORK CAN USE DYNAMIC ALLOCATION OF MEMORY ON CRAY -C - INTEGER IWORK(NPTS) - integer LENBDS !JFM - integer LENBDSA(1) !JFM - integer nfill (1) !JFM - integer iscalea(1) !JFM - integer iexpa (1) !JFM - integer imanta (1) !JFM - integer nbitsa (1) !JFM -C - LOGICAL CONST -C - CHARACTER * 1 BDS11(11),PDS(*) - CHARACTER * 1 PFLD(*) -C -C 1.0 PACK THE FIELD. -C -C 1.1 TOSS DATA IF BITMAP BEING USED, -C MOVING 'DATA' TO WORK AREA... -C - CONST = .FALSE. - IBERR = 0 - IW = 0 -C - IF (ITOSS .EQ. 1) THEN - IF (ITYPE .EQ. 0) THEN - DO 110 IT=1,NPTS - IF (IBMAP(IT) .EQ. 1) THEN - IW = IW + 1 - FWORK(IW) = FLD(IT) - ENDIF - 110 CONTINUE - NPTS = IW - ELSE IF (ITYPE .EQ. 1) THEN - DO 111 IT=1,NPTS - IF (IBMAP(IT) .EQ. 1) THEN - IW = IW + 1 - IWORK(IW) = IFLD(IT) - ENDIF - 111 CONTINUE - NPTS = IW - ENDIF -C -C ELSE, JUST MOVE DATA TO WORK ARRAY -C - ELSE IF (ITOSS .EQ. 0) THEN - IF (ITYPE .EQ. 0) THEN - DO 112 IT=1,NPTS - FWORK(IT) = FLD(IT) - 112 CONTINUE - ELSE IF (ITYPE .EQ. 1) THEN - DO 113 IT=1,NPTS - IWORK(IT) = IFLD(IT) - 113 CONTINUE - ENDIF - ENDIF -C -C 1.2 CONVERT DATA IF NEEDED PRIOR TO PACKING. -C (INTEGER TO F.P. OR F.P. TO INTEGER) -C ITYPE = 0...FLOATING POINT DATA -C IBITL = 0...PACK IN LEAST # BITS...CONVERT TO INTEGER -C ITYPE = 1...INTEGER DATA -C IBITL > 0...PACK IN FIXED # BITS...CONVERT TO FLOATING POINT -C - IF (ITYPE .EQ. 0 .AND. IBITL .EQ. 0) THEN - DO 120 IF=1,NPTS - IWORK(IF) = NINT(FWORK(IF)) - 120 CONTINUE - ELSE IF (ITYPE .EQ. 1 .AND. IBITL .NE. 0) THEN - DO 123 IF=1,NPTS - FWORK(IF) = FLOAT(IWORK(IF)) - 123 CONTINUE - ENDIF -C -C 1.3 PACK THE DATA. -C - IF (IBDSFL(2).NE.0) THEN -C SECOND ORDER PACKING -C -C PRINT*,' DOING SECOND ORDER PACKING...' - IF (IBITL.EQ.0) THEN -C -C PRINT*,' AND VARIABLE BIT PACKING' -C -C WORKING WITH INTEGER VALUES -C SINCE DOING VARIABLE BIT PACKING -C - MAX = IWORK(1) - MIN = IWORK(1) - DO 300 I = 2, NPTS - IF (IWORK(I).LT.MIN) THEN - MIN = IWORK(I) - ELSE IF (IWORK(I).GT.MAX) THEN - MAX = IWORK(I) - END IF - 300 CONTINUE -C EXTRACT MINIMA - DO 400 I = 1, NPTS -C IF (IWORK(I).LT.0) THEN -C PRINT *,'MINIMA 400',I,IWORK(I),NPTS -C END IF - IWORK(I) = IWORK(I) - MIN - 400 CONTINUE - REFNCE = MIN - IDIFF = MAX - MIN -C PRINT *,'REFERENCE VALUE',REFNCE -C -C WRITE (6,FMT='('' MINIMA REMOVED = '',/, -C & 10(3X,10I10,/))') (IWORK(I),I=1,6) -C WRITE (6,FMT='('' END OF ARRAY = '',/, -C & 10(3X,10I10,/))') (IWORK(I),I=NPTS-5,NPTS) -C -C FIND BIT WIDTH OF IDIFF -C - CALL FI7505 (IDIFF,KWIDE) -C PRINT*,' BIT WIDTH FOR ORIGINAL DATA', KWIDE - ISCAL2 = 0 -C -C MULTIPLICATIVE SCALE FACTOR SET TO 1 -C IN ANTICIPATION OF POSSIBLE USE IN GLAHN 2DN DIFF -C - SCAL2 = 1. -C - ELSE -C -C PRINT*,' AND FIXED BIT PACKING, IBITL = ', IBITL -C FIXED BIT PACKING -C - LENGTH OF FIELD IN IBITL -C - MUST BE REAL DATA -C FLOATING POINT INPUT -C - RMAX = FWORK(1) - RMIN = FWORK(1) - DO 100 I = 2, NPTS - IF (FWORK(I).LT.RMIN) THEN - RMIN = FWORK(I) - ELSE IF (FWORK(I).GT.RMAX) THEN - RMAX = FWORK(I) - END IF - 100 CONTINUE - REFNCE = RMIN -C PRINT *,'100 REFERENCE',REFNCE -C EXTRACT MINIMA - DO 200 I = 1, NPTS - FWORK(I) = FWORK(I) - RMIN - 200 CONTINUE -C PRINT *,'REFERENCE VALUE',REFNCE -C WRITE (6,FMT='('' MINIMA REMOVED = '',/, -C & 10(3X,10F8.2,/))') (FWORK(I),I=1,6) -C WRITE (6,FMT='('' END OF ARRAY = '',/, -C & 10(3X,10F8.2,/))') (FWORK(I),I=NPTS-5,NPTS) -C FIND LARGEST DELTA - IDELT = NINT(RMAX - RMIN) -C DO BINARY SCALING -C FIND OUT WHAT BINARY SCALE FACTOR -C PERMITS CONTAINMENT OF -C LARGEST DELTA - CALL FI7505 (IDELT,IWIDE) -C -C BINARY SCALING -C - ISCAL2 = IWIDE - IBITL -C PRINT *,'SCALING NEEDED TO FIT =',ISCAL2 -C PRINT*,' RANGE OF = ',IDELT -C -C EXPAND DATA WITH BINARY SCALING -C CONVERT TO INTEGER - SCAL2 = 2.0**ISCAL2 - SCAL2 = 1./ SCAL2 - DO 600 I = 1, NPTS - IWORK(I) = NINT(FWORK(I) * SCAL2) - 600 CONTINUE - KWIDE = IBITL - END IF -C -C ***************************************************************** -C -C FOLLOWING IS FOR GLAHN SECOND DIFFERENCING -C NOT STANDARD GRIB -C -C TEST FOR SECOND DIFFERENCE PACKING -C BASED OF SIZE OF PDS - SIZE IN FIRST 3 BYTES -C - CALL GBYTEC(PDS,IPDSIZ,0,24) - IF (IPDSIZ.EQ.50) THEN -C PRINT*,' DO SECOND DIFFERENCE PACKING ' -C -C GLAHN PACKING TO 2ND DIFFS -C -C WRITE (6,FMT='('' CALL TO W3FI82 WITH = '',/, -C & 10(3X,10I6,/))') (IWORK(I),I=1,NPTS) -C - CALL W3FI82 (IWORK,FVAL1,FDIFF1,NPTS,PDS,IGDS) -C -C PRINT *,'GLAHN',FVAL1,FDIFF1 -C WRITE (6,FMT='('' OUT FROM W3FI82 WITH = '',/, -C & 10(3X,10I6,/))') (IWORK(I),I=1,NPTS) -C -C MUST NOW RE-REMOVE THE MINIMUM VALUE -C OF THE SECOND DIFFERENCES TO ASSURE -C ALL POSITIVE NUMBERS FOR SECOND ORDER GRIB PACKING -C -C ORIGINAL REFERENCE VALUE ADDED TO FIRST POINT -C VALUE FROM THE 2ND DIFF PACKER TO BE ADDED -C BACK IN WHEN THE 2ND DIFF VALUES ARE -C RECONSTRUCTED BACK TO THE BASIC VALUES -C -C ALSO, THE REFERENCE VALUE IS -C POWER-OF-TWO SCALED TO MATCH -C FVAL1. ALL OF THIS SCALING -C WILL BE REMOVED AFTER THE -C GLAHN SECOND DIFFERENCING IS UNDONE. -C THE SCALING FACTOR NEEDED TO DO THAT -C IS SAVED IN THE PDS AS A SIGNED POSITIVE -C TWO BYTE INTEGER -C -C THE SCALING FOR THE 2ND DIF PACKED -C VALUES IS PROPERLY SET TO ZERO -C - FVAL1 = FVAL1 + REFNCE*SCAL2 -C FIRST TEST TO SEE IF -C ON 32 OR 64 BIT COMPUTER -C CALL W3FI01(LW) - IF (bit_size(LW).EQ.32) THEN - CALL W3FI76 (FVAL1,IEXP,IMANT,32) - ELSE - CALL W3FI76 (FVAL1,IEXP,IMANT,64) - END IF - CALL SBYTEC(PDS,IEXP,320,8) - CALL SBYTEC(PDS,IMANT,328,24) -C - IF (bit_size(LW).EQ.32) THEN - CALL W3FI76 (FDIFF1,IEXP,IMANT,32) - ELSE - CALL W3FI76 (FDIFF1,IEXP,IMANT,64) - END IF - CALL SBYTEC(PDS,IEXP,352,8) - CALL SBYTEC(PDS,IMANT,360,24) -C -C TURN ISCAL2 INTO SIGNED POSITIVE INTEGER -C AND STORE IN TWO BYTES -C - IF(ISCAL2.GE.0) THEN - CALL SBYTEC(PDS,ISCAL2,384,16) - ELSE - CALL SBYTEC(PDS,1,384,1) - ISCAL2 = - ISCAL2 - CALL SBYTEC( PDS,ISCAL2,385,15) - ENDIF -C - MAX = IWORK(1) - MIN = IWORK(1) - DO 700 I = 2, NPTS - IF (IWORK(I).LT.MIN) THEN - MIN = IWORK(I) - ELSE IF (IWORK(I).GT.MAX) THEN - MAX = IWORK(I) - END IF - 700 CONTINUE -C EXTRACT MINIMA - DO 710 I = 1, NPTS - IWORK(I) = IWORK(I) - MIN - 710 CONTINUE - REFNCE = MIN -C PRINT *,'710 REFERENCE',REFNCE - ISCAL2 = 0 -C -C AND RESET VALUE OF KWIDE - THE BIT WIDTH -C FOR THE RANGE OF THE VALUES -C - IDIFF = MAX - MIN - CALL FI7505 (IDIFF,KWIDE) -C -C PRINT*,'BIT WIDTH (KWIDE) OF 2ND DIFFS', KWIDE -C -C **************************** END OF GLAHN PACKING ************ - ELSE IF (IBDSFL(2).EQ.1.AND.IBDSFL(7).EQ.0) THEN -C HAVE SECOND ORDER PACKING WITH NO SECOND ORDER -C BIT MAP. ERGO ROW BY ROW - COL BY COL - CALL FI7503 (IWORK,IPFLD,NPTS,IBDSFL,BDS11, - * LEN,LENBDS,PDS,REFNCE,ISCAL2,KWIDE,IGDS) - RETURN - END IF -C WRITE (6,FMT='('' CALL TO FI7501 WITH = '',/, -C & 10(3X,10I6,/))') (IWORK(I),I=1,NPTS) -C WRITE (6,FMT='('' END OF ARRAY = '',/, -C & 10(3X,10I6,/))') (IWORK(I),I=NPTS-5,NPTS) -C PRINT*,' REFNCE,ISCAL2, KWIDE AT CALL TO FI7501', -C & REFNCE, ISCAL2,KWIDE -C -C SECOND ORDER PACKING -C - CALL FI7501 (IWORK,IPFLD,NPTS,IBDSFL,BDS11, - * LEN,LENBDS,PDS,REFNCE,ISCAL2,KWIDE) -C -C BDS COMPLETELY ASSEMBLED IN FI7501 FOR SECOND ORDER -C PACKING. -C - ELSE -C SIMPLE PACKING -C -C PRINT*,' SIMPLE FIRST ORDER PACKING...' - IF (IBITL.EQ.0) THEN -C PRINT*,' WITH VARIABLE BIT LENGTH' -C -C WITH VARIABLE BIT LENGTH, ADJUSTED -C TO ACCOMMODATE LARGEST VALUE -C BINARY SCALING ALWAYS = 0 -C - CALL W3FI58(IWORK,NPTS,IWORK,PFLD,NBITS,LEN,KMIN,IERR) - IF (IERR == 1) THEN - IBERR = 2 - RETURN - ENDIF - RMIN = KMIN - REFNCE = RMIN - ISCALE = 0 -C PRINT*,' BIT LENGTH CAME OUT AT ...',NBITS -C -C SET CONST .TRUE. IF ALL VALUES ARE THE SAME -C - IF (LEN.EQ.0.AND.NBITS.EQ.0) CONST = .TRUE. -C - ELSE -C PRINT*,' FIXED BIT LENGTH, IBITL = ', IBITL -C -C FIXED BIT LENGTH PACKING (VARIABLE PRECISION) -C VALUES SCALED BY POWER OF 2 (ISCALE) TO -C FIT LARGEST VALUE INTO GIVEN BIT LENGTH (IBITL) -C - CALL W3FI59(FWORK,NPTS,IBITL,IWORK,PFLD,ISCALE,LEN,RMIN) - REFNCE = RMIN -C PRINT *,' SCALING NEEDED TO FIT IS ...', ISCALE - NBITS = IBITL -C -C SET CONST .TRUE. IF ALL VALUES ARE THE SAME -C - IF (LEN.EQ.0) THEN - CONST = .TRUE. - NBITS = 0 - END IF - END IF -C -C$ COMPUTE LENGTH OF BDS IN OCTETS -C - INUM = NPTS * NBITS + 88 -C PRINT *,'NUMBER OF BITS BEFORE FILL ADDED',INUM -C -C NUMBER OF FILL BITS - NFILL(1) = 0 - NLEFT = MOD(INUM,16) - IF (NLEFT.NE.0) THEN - INUM = INUM + 16 - NLEFT - NFILL(1) = 16 - NLEFT - END IF -C PRINT *,'NUMBER OF BITS AFTER FILL ADDED',INUM -C LENGTH OF BDS IN BYTES - LENBDS = INUM / 8 -C -C 2.0 FORM THE BINARY DATA SECTION (BDS). -C -C CONCANTENATE ALL FIELDS FOR BDS -C -C BYTES 1-3 - LENBDSA(1) = LENBDS - CALL SBYTEC (BDS11,LENBDSA(1),0,24) !JFM -C -C BYTE 4 -C FLAGS - CALL SBYTEC (BDS11,IBDSFL(1),24,1) - CALL SBYTEC (BDS11,IBDSFL(2),25,1) - CALL SBYTEC (BDS11,IBDSFL(3),26,1) - CALL SBYTEC (BDS11,IBDSFL(4),27,1) -C NR OF FILL BITS - CALL SBYTEC (BDS11,NFILL,28,4) -C -C$ FILL OCTETS 5-6 WITH THE SCALE FACTOR. -C -C BYTE 5-6 - IF (ISCALE.LT.0) THEN - CALL SBYTEC (BDS11,1,32,1) - ISCALE = - ISCALE - iscalea = iscale !JFM - CALL SBYTEC (BDS11,ISCALEa,33,15) !JFM - ELSE - iscalea = iscale !JFM - CALL SBYTEC (BDS11,ISCALEa,32,16) !JFM - END IF -C -C$ FILL OCTET 7-10 WITH THE REFERENCE VALUE -C CONVERT THE FLOATING POINT OF YOUR MACHINE TO IBM370 32 BIT -C FLOATING POINT NUMBER -C -C BYTE 7-10 -C REFERENCE VALUE -C FIRST TEST TO SEE IF -C ON 32 OR 64 BIT COMPUTER -C CALL W3FI01(LW) - IF (bit_size(LW).EQ.32) THEN - CALL W3FI76 (REFNCE,IEXP,IMANT,32) - ELSE - CALL W3FI76 (REFNCE,IEXP,IMANT,64) - END IF - iexpa (1) = iexp !JFM - imanta(1) = IMANT !JFM - CALL SBYTEC (BDS11,IEXPa ,48, 8) !JFM - CALL SBYTEC (BDS11,IMANTa,56,24) !JFM -C -C -C$ FILL OCTET 11 WITH THE NUMBER OF BITS. -C -C BYTE 11 - nbitsa(1) = nbits !JFM - CALL SBYTEC (BDS11,NBITSa,80,8) !JFM - END IF -C - RETURN - END - SUBROUTINE FI7501 (IWORK,IPFLD,NPTS,IBDSFL,BDS11, - * LEN,LENBDS,PDS,REFNCE,ISCAL2,KWIDE) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI7501 BDS SECOND ORDER PACKING -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-08-06 -C -C ABSTRACT: PERFORM SECONDARY PACKING ON GRID POINT DATA, -C GENERATING ALL BDS INFORMATION. -C -C PROGRAM HISTORY LOG: -C 93-08-06 CAVANAUGH -C 93-12-15 CAVANAUGH CORRECTED LOCATION OF START OF FIRST ORDER -C VALUES AND START OF SECOND ORDER VALUES TO -C REFLECT A BYTE LOCATION IN THE BDS INSTEAD -C OF AN OFFSET. -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C -C USAGE: CALL FI7501 (IWORK,IPFLD,NPTS,IBDSFL,BDS11, -C * LEN,LENBDS,PDS,REFNCE,ISCAL2,KWIDE) -C INPUT ARGUMENT LIST: -C IWORK - INTEGER SOURCE ARRAY -C NPTS - NUMBER OF POINTS IN IWORK -C IBDSFL - FLAGS -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C IPFLD - CONTAINS BDS FROM BYTE 12 ON -C BDS11 - CONTAINS FIRST 11 BYTES FOR BDS -C LEN - NUMBER OF BYTES FROM 12 ON -C LENBDS - TOTAL LENGTH OF BDS -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256 -C -C$$$ - CHARACTER*1 BDS11(*),PDS(*) -C - REAL REFNCE -C - INTEGER ISCAL2,KWIDE - INTEGER LENBDS - CHARACTER(len=1) IPFLD(*) - INTEGER LEN,KBDS(22) - INTEGER IWORK(*) -C OCTET NUMBER IN SECTION, FIRST ORDER PACKING -C INTEGER KBDS(12) -C FLAGS - INTEGER IBDSFL(*) -C EXTENDED FLAGS -C INTEGER KBDS(14) -C OCTET NUMBER FOR SECOND ORDER PACKING -C INTEGER KBDS(15) -C NUMBER OF FIRST ORDER VALUES -C INTEGER KBDS(17) -C NUMBER OF SECOND ORDER PACKED VALUES -C INTEGER KBDS(19) -C WIDTH OF SECOND ORDER PACKING - character(len=1) ISOWID(400000) -C SECONDARY BIT MAP - character(len=1) ISOBMP(65600) -C FIRST ORDER PACKED VALUES - character(len=1) IFOVAL(400000) -C SECOND ORDER PACKED VALUES - character(len=1) ISOVAL(800000) -C -C INTEGER KBDS(11) -C BIT WIDTH TABLE - INTEGER IBITS(31) -C - DATA IBITS/1,3,7,15,31,63,127,255,511,1023, - * 2047,4095,8191,16383,32767,65535,131072, - * 262143,524287,1048575,2097151,4194303, - * 8388607,16777215,33554431,67108863, - * 134217727,268435455,536870911, - * 1073741823,2147483647/ -C ---------------------------------- -C INITIALIZE ARRAYS - - DO I = 1, 400000 - IFOVAL(I) = char(0) - ISOWID(I) = char(0) - ENDDO -C - DO 101 I = 1, 65600 - ISOBMP(I) = char(0) - 101 CONTINUE - DO 102 I = 1, 800000 - ISOVAL(I) = char(0) - 102 CONTINUE -C INITIALIZE POINTERS -C SECONDARY BIT WIDTH POINTER - IWDPTR = 0 -C SECONDARY BIT MAP POINTER - IBMP2P = 0 -C FIRST ORDER VALUE POINTER - IFOPTR = 0 -C BYTE POINTER TO START OF 1ST ORDER VALUES - KBDS(12) = 0 -C BYTE POINTER TO START OF 2ND ORDER VALUES - KBDS(15) = 0 -C TO CONTAIN NUMBER OF FIRST ORDER VALUES - KBDS(17) = 0 -C TO CONTAIN NUMBER OF SECOND ORDER VALUES - KBDS(19) = 0 -C SECOND ORDER PACKED VALUE POINTER - ISOPTR = 0 -C ======================================================= -C -C DATA IS IN IWORK -C - KBDS(11) = KWIDE -C -C DATA PACKING -C - ITER = 0 - INEXT = 1 - ISTART = 1 -C ----------------------------------------------------------- - KOUNT = 0 -C DO 1 I = 1, NPTS, 10 -C PRINT *,I,(IWORK(K),K=I, I+9) -C 1 CONTINUE - 2000 CONTINUE - ITER = ITER + 1 -C PRINT *,'NEXT ITERATION STARTS AT',ISTART - IF (ISTART.GT.NPTS) THEN - GO TO 4000 - ELSE IF (ISTART.EQ.NPTS) THEN - KPTS = 1 - MXDIFF = 0 - GO TO 2200 - END IF -C -C LOOK FOR REPITITIONS OF A SINGLE VALUE - CALL FI7502 (IWORK,ISTART,NPTS,ISAME) - IF (ISAME.GE.15) THEN - KOUNT = KOUNT + 1 -C PRINT *,'FI7501 - FOUND IDENTICAL SET OF ',ISAME - MXDIFF = 0 - KPTS = ISAME - ELSE -C -C LOOK FOR SETS OF VALUES IN TREND SELECTED RANGE - CALL FI7513 (IWORK,ISTART,NPTS,NMAX,NMIN,INRNGE) -C PRINT *,'ISTART ',ISTART,' INRNGE',INRNGE,NMAX,NMIN - IEND = ISTART + INRNGE - 1 -C DO 2199 NM = ISTART, IEND, 10 -C PRINT *,' ',(IWORK(NM+JK),JK=0,9) -C2199 CONTINUE - MXDIFF = NMAX - NMIN - KPTS = INRNGE - END IF - 2200 CONTINUE -C PRINT *,' RANGE ',MXDIFF,' MAX',NMAX,' MIN',NMIN -C INCREMENT NUMBER OF FIRST ORDER VALUES - KBDS(17) = KBDS(17) + 1 -C ENTER FIRST ORDER VALUE - IF (MXDIFF.GT.0) THEN - DO 2220 LK = 0, KPTS-1 - IWORK(ISTART+LK) = IWORK(ISTART+LK) - NMIN - 2220 CONTINUE - CALL SBYTEC (IFOVAL,NMIN,IFOPTR,KBDS(11)) - ELSE - CALL SBYTEC (IFOVAL,IWORK(ISTART),IFOPTR,KBDS(11)) - END IF - IFOPTR = IFOPTR + KBDS(11) -C PROCESS SECOND ORDER BIT WIDTH - IF (MXDIFF.GT.0) THEN - DO 2330 KWIDE = 1, 31 - IF (MXDIFF.LE.IBITS(KWIDE)) THEN - GO TO 2331 - END IF - 2330 CONTINUE - 2331 CONTINUE - ELSE - KWIDE = 0 - END IF - CALL SBYTEC (ISOWID,KWIDE,IWDPTR,8) - IWDPTR = IWDPTR + 8 -C PRINT *,KWIDE,' IFOVAL=',NMIN,IWORK(ISTART),KPTS -C IF KWIDE NE 0, SAVE SECOND ORDER VALUE - IF (KWIDE.GT.0) THEN - CALL SBYTESC (ISOVAL,IWORK(ISTART),ISOPTR,KWIDE,0,KPTS) - ISOPTR = ISOPTR + KPTS * KWIDE - KBDS(19) = KBDS(19) + KPTS -C PRINT *,' SECOND ORDER VALUES' -C PRINT *,(IWORK(ISTART+I),I=0,KPTS-1) - END IF -C ADD TO SECOND ORDER BITMAP - CALL SBYTEC (ISOBMP,1,IBMP2P,1) - IBMP2P = IBMP2P + KPTS - ISTART = ISTART + KPTS - GO TO 2000 -C -------------------------------------------------------------- - 4000 CONTINUE -C PRINT *,'THERE WERE ',ITER,' SECOND ORDER GROUPS' -C PRINT *,'THERE WERE ',KOUNT,' STRINGS OF CONSTANTS' -C CONCANTENATE ALL FIELDS FOR BDS -C -C REMAINDER GOES INTO IPFLD - IPTR = 0 -C BYTES 12-13 -C VALUE FOR N1 -C LEAVE SPACE FOR THIS - IPTR = IPTR + 16 -C BYTE 14 -C EXTENDED FLAGS - CALL SBYTEC (IPFLD,IBDSFL(5),IPTR,1) - IPTR = IPTR + 1 - CALL SBYTEC (IPFLD,IBDSFL(6),IPTR,1) - IPTR = IPTR + 1 - CALL SBYTEC (IPFLD,IBDSFL(7),IPTR,1) - IPTR = IPTR + 1 - CALL SBYTEC (IPFLD,IBDSFL(8),IPTR,1) - IPTR = IPTR + 1 - CALL SBYTEC (IPFLD,IBDSFL(9),IPTR,1) - IPTR = IPTR + 1 - CALL SBYTEC (IPFLD,IBDSFL(10),IPTR,1) - IPTR = IPTR + 1 - CALL SBYTEC (IPFLD,IBDSFL(11),IPTR,1) - IPTR = IPTR + 1 - CALL SBYTEC (IPFLD,IBDSFL(12),IPTR,1) - IPTR = IPTR + 1 -C BYTES 15-16 -C SKIP OVER VALUE FOR N2 - IPTR = IPTR + 16 -C BYTES 17-18 -C P1 - CALL SBYTEC (IPFLD,KBDS(17),IPTR,16) - IPTR = IPTR + 16 -C BYTES 19-20 -C P2 - CALL SBYTEC (IPFLD,KBDS(19),IPTR,16) - IPTR = IPTR + 16 -C BYTE 21 - RESERVED LOCATION - CALL SBYTEC (IPFLD,0,IPTR,8) - IPTR = IPTR + 8 -C BYTES 22 - ? -C WIDTHS OF SECOND ORDER PACKING - IX = (IWDPTR + 32) / 32 -C CALL SBYTESC (IPFLD,ISOWID,IPTR,32,0,IX) - ijk=IWDPTR/8 - jst=(iptr/8)+1 - ipfld(jst:jst+ijk)=ISOWID(1:ijk) - IPTR = IPTR + IWDPTR -C SECONDARY BIT MAP - IJ = (IBMP2P + 32) / 32 -C CALL SBYTESC (IPFLD,ISOBMP,IPTR,32,0,IJ) - ijk=(IBMP2P/8)+1 - jst=(iptr/8)+1 - ipfld(jst:jst+ijk)=ISOBMP(1:ijk) - IPTR = IPTR + IBMP2P - IF (MOD(IPTR,8).NE.0) THEN - IPTR = IPTR + 8 - MOD(IPTR,8) - END IF -C DETERMINE LOCATION FOR START -C OF FIRST ORDER PACKED VALUES - KBDS(12) = IPTR / 8 + 12 -C STORE LOCATION - CALL SBYTEC (IPFLD,KBDS(12),0,16) -C MOVE IN FIRST ORDER PACKED VALUES - IPASS = (IFOPTR + 32) / 32 -C CALL SBYTESC (IPFLD,IFOVAL,IPTR,32,0,IPASS) - ijk=(IFOPTR/8)+1 - jst=(iptr/8)+1 - ipfld(jst:jst+ijk)=ifoval(1:ijk) - IPTR = IPTR + IFOPTR - IF (MOD(IPTR,8).NE.0) THEN - IPTR = IPTR + 8 - MOD(IPTR,8) - END IF -C PRINT *,'IFOPTR =',IFOPTR,' ISOPTR =',ISOPTR -C DETERMINE LOCATION FOR START -C OF SECOND ORDER VALUES - KBDS(15) = IPTR / 8 + 12 -C SAVE LOCATION OF SECOND ORDER VALUES - CALL SBYTEC (IPFLD,KBDS(15),24,16) -C MOVE IN SECOND ORDER PACKED VALUES - IX = (ISOPTR + 32) / 32 -c CALL SBYTESC (IPFLD,ISOVAL,IPTR,32,0,IX) - ijk=(ISOPTR/8)+1 - jst=(iptr/8)+1 - ipfld(jst:jst+ijk)=isoval(1:ijk) - IPTR = IPTR + ISOPTR - NLEFT = MOD(IPTR+88,16) - IF (NLEFT.NE.0) THEN - NLEFT = 16 - NLEFT - IPTR = IPTR + NLEFT - END IF -C COMPUTE LENGTH OF DATA PORTION - LEN = IPTR / 8 -C COMPUTE LENGTH OF BDS - LENBDS = LEN + 11 -C ----------------------------------- -C BYTES 1-3 -C THIS FUNCTION COMPLETED BELOW -C WHEN LENGTH OF BDS IS KNOWN - CALL SBYTEC (BDS11,LENBDS,0,24) -C BYTE 4 - CALL SBYTEC (BDS11,IBDSFL(1),24,1) - CALL SBYTEC (BDS11,IBDSFL(2),25,1) - CALL SBYTEC (BDS11,IBDSFL(3),26,1) - CALL SBYTEC (BDS11,IBDSFL(4),27,1) -C ENTER NUMBER OF FILL BITS - CALL SBYTEC (BDS11,NLEFT,28,4) -C BYTE 5-6 - IF (ISCAL2.LT.0) THEN - CALL SBYTEC (BDS11,1,32,1) - ISCAL2 = - ISCAL2 - ELSE - CALL SBYTEC (BDS11,0,32,1) - END IF - CALL SBYTEC (BDS11,ISCAL2,33,15) -C -C$ FILL OCTET 7-10 WITH THE REFERENCE VALUE -C CONVERT THE FLOATING POINT OF YOUR MACHINE TO IBM370 32 BIT -C FLOATING POINT NUMBER -C REFERENCE VALUE -C FIRST TEST TO SEE IF -C ON 32 OR 64 BIT COMPUTER -C CALL W3FI01(LW) - IF (bit_size(LW).EQ.32) THEN - CALL W3FI76 (REFNCE,IEXP,IMANT,32) - ELSE - CALL W3FI76 (REFNCE,IEXP,IMANT,64) - END IF - CALL SBYTEC (BDS11,IEXP,48,8) - CALL SBYTEC (BDS11,IMANT,56,24) -C -C BYTE 11 -C - CALL SBYTEC (BDS11,KBDS(11),80,8) -C - RETURN - END - SUBROUTINE FI7502 (IWORK,ISTART,NPTS,ISAME) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI7502 SECOND ORDER SAME VALUE COLLECTION -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-06-23 -C -C ABSTRACT: COLLECT SEQUENTIAL SAME VALUES FOR PROCESSING -C AS SECOND ORDER VALUE FOR GRIB MESSAGES. -C -C PROGRAM HISTORY LOG: -C 93-06-23 CAVANAUGH -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C -C USAGE: CALL FI7502 (IWORK,ISTART,NPTS,ISAME) -C INPUT ARGUMENT LIST: -C IWORK - ARRAY CONTAINING SOURCE DATA -C ISTART - STARTING LOCATION FOR THIS TEST -C NPTS - NUMBER OF POINTS IN IWORK -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C ISAME - NUMBER OF SEQUENTIAL POINTS HAVING THE SAME VALUE -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256 -C -C$$$ - INTEGER IWORK(*) - INTEGER ISTART - INTEGER ISAME - INTEGER K - INTEGER NPTS -C ------------------------------------------------------------- - ISAME = 0 - DO 100 K = ISTART, NPTS - IF (IWORK(K).NE.IWORK(ISTART)) THEN - RETURN - END IF - ISAME = ISAME + 1 - 100 CONTINUE - RETURN - END - SUBROUTINE FI7503 (IWORK,IPFLD,NPTS,IBDSFL,BDS11, - * LEN,LENBDS,PDS,REFNCE,ISCAL2,KWIDE,IGDS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI7501 ROW BY ROW, COL BY COL PACKING -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-05-20 -C -C ABSTRACT: PERFORM ROW BY ROW OR COLUMN BY COLUMN PACKING -C GENERATING ALL BDS INFORMATION. -C -C PROGRAM HISTORY LOG: -C 93-08-06 CAVANAUGH -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C -C USAGE: CALL FI7503 (IWORK,IPFLD,NPTS,IBDSFL,BDS11, -C * LEN,LENBDS,PDS,REFNCE,ISCAL2,KWIDE,IGDS) -C INPUT ARGUMENT LIST: -C IWORK - INTEGER SOURCE ARRAY -C NPTS - NUMBER OF POINTS IN IWORK -C IBDSFL - FLAGS -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C IPFLD - CONTAINS BDS FROM BYTE 12 ON -C BDS11 - CONTAINS FIRST 11 BYTES FOR BDS -C LEN - NUMBER OF BYTES FROM 12 ON -C LENBDS - TOTAL LENGTH OF BDS -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256 -C -C$$$ - CHARACTER*1 BDS11(*),PDS(*),IPFLD(*) -C - REAL REFNCE -C - INTEGER ISCAL2,KWIDE - INTEGER LENBDS - INTEGER IGDS(*) - INTEGER LEN,KBDS(22) - INTEGER IWORK(*) -C OCTET NUMBER IN SECTION, FIRST ORDER PACKING -C INTEGER KBDS(12) -C FLAGS - INTEGER IBDSFL(*) -C EXTENDED FLAGS -C INTEGER KBDS(14) -C OCTET NUMBER FOR SECOND ORDER PACKING -C INTEGER KBDS(15) -C NUMBER OF FIRST ORDER VALUES -C INTEGER KBDS(17) -C NUMBER OF SECOND ORDER PACKED VALUES -C INTEGER KBDS(19) -C WIDTH OF SECOND ORDER PACKING - character(len=1) ISOWID(400000) -C SECONDARY BIT MAP - character(len=1) ISOBMP(65600) -C FIRST ORDER PACKED VALUES - character(len=1) IFOVAL(400000) -C SECOND ORDER PACKED VALUES - character(len=1) ISOVAL(800000) -C -C INTEGER KBDS(11) -C ---------------------------------- -C INITIALIZE ARRAYS -C - DO I = 1, 400000 - IFOVAL(I) = char(0) - ISOWID(I) = char(0) - ENDDO -C - DO 101 I = 1, 65600 - ISOBMP(I) = char(0) - 101 CONTINUE - DO 102 I = 1, 800000 - ISOVAL(I) = char(0) - 102 CONTINUE -C INITIALIZE POINTERS -C SECONDARY BIT WIDTH POINTER - IWDPTR = 0 -C SECONDARY BIT MAP POINTER - IBMP2P = 0 -C FIRST ORDER VALUE POINTER - IFOPTR = 0 -C BYTE POINTER TO START OF 1ST ORDER VALUES - KBDS(12) = 0 -C BYTE POINTER TO START OF 2ND ORDER VALUES - KBDS(15) = 0 -C TO CONTAIN NUMBER OF FIRST ORDER VALUES - KBDS(17) = 0 -C TO CONTAIN NUMBER OF SECOND ORDER VALUES - KBDS(19) = 0 -C SECOND ORDER PACKED VALUE POINTER - ISOPTR = 0 -C ======================================================= -C BUILD SECOND ORDER BIT MAP IN EITHER -C ROW BY ROW OR COL BY COL FORMAT - IF (IAND(IGDS(13),32).NE.0) THEN -C COLUMN BY COLUMN - KOUT = IGDS(4) - KIN = IGDS(5) -C PRINT *,'COLUMN BY COLUMN',KOUT,KIN - ELSE -C ROW BY ROW - KOUT = IGDS(5) - KIN = IGDS(4) -C PRINT *,'ROW BY ROW',KOUT,KIN - END IF - KBDS(17) = KOUT - KBDS(19) = NPTS -C -C DO 4100 J = 1, NPTS, 53 -C WRITE (6,4101) (IWORK(K),K=J,J+52) - 4101 FORMAT (1X,25I4) -C PRINT *,' ' -C4100 CONTINUE -C -C INITIALIZE BIT MAP POINTER - IBMP2P = 0 -C CONSTRUCT WORKING BIT MAP - DO 2000 I = 1, KOUT - DO 1000 J = 1, KIN - IF (J.EQ.1) THEN - CALL SBYTEC (ISOBMP,1,IBMP2P,1) - ELSE - CALL SBYTEC (ISOBMP,0,IBMP2P,1) - END IF - IBMP2P = IBMP2P + 1 - 1000 CONTINUE - 2000 CONTINUE - LEN = IBMP2P / 32 + 1 -C CALL BINARY(ISOBMP,LEN) -C -C PROCESS OUTER LOOP OF ROW BY ROW OR COL BY COL -C - KPTR = 1 - KBDS(11) = KWIDE - DO 6000 I = 1, KOUT -C IN CURRENT ROW OR COL -C FIND FIRST ORDER VALUE - JPTR = KPTR - LOWEST = IWORK(JPTR) - DO 4000 J = 1, KIN - IF (IWORK(JPTR).LT.LOWEST) THEN - LOWEST = IWORK(JPTR) - END IF - JPTR = JPTR + 1 - 4000 CONTINUE -C SAVE FIRST ORDER VALUE - CALL SBYTEC (IFOVAL,LOWEST,IFOPTR,KWIDE) - IFOPTR = IFOPTR + KWIDE -C PRINT *,'FOVAL',I,LOWEST,KWIDE -C SUBTRACT FIRST ORDER VALUE FROM OTHER VALS -C GETTING SECOND ORDER VALUES - JPTR = KPTR - IBIG = IWORK(JPTR) - LOWEST - DO 4200 J = 1, KIN - IWORK(JPTR) = IWORK(JPTR) - LOWEST - IF (IWORK(JPTR).GT.IBIG) THEN - IBIG = IWORK(JPTR) - END IF - JPTR = JPTR + 1 - 4200 CONTINUE -C HOW MANY BITS TO CONTAIN LARGEST SECOND -C ORDER VALUE IN SEGMENT - CALL FI7505 (IBIG,NWIDE) -C SAVE BIT WIDTH - CALL SBYTEC (ISOWID,NWIDE,IWDPTR,8) - IWDPTR = IWDPTR + 8 -C PRINT *,I,'SOVAL',IBIG,' IN',NWIDE,' BITS' -C WRITE (6,4101) (IWORK(K),K=KPTR,KPTR+52) -C SAVE SECOND ORDER VALUES OF THIS SEGMENT - DO 5000 J = 0, KIN-1 - CALL SBYTEC (ISOVAL,IWORK(KPTR+J),ISOPTR,NWIDE) - ISOPTR = ISOPTR + NWIDE - 5000 CONTINUE - KPTR = KPTR + KIN - 6000 CONTINUE -C ======================================================= -C CONCANTENATE ALL FIELDS FOR BDS -C -C REMAINDER GOES INTO IPFLD - IPTR = 0 -C BYTES 12-13 -C VALUE FOR N1 -C LEAVE SPACE FOR THIS - IPTR = IPTR + 16 -C BYTE 14 -C EXTENDED FLAGS - CALL SBYTEC (IPFLD,IBDSFL(5),IPTR,1) - IPTR = IPTR + 1 - CALL SBYTEC (IPFLD,IBDSFL(6),IPTR,1) - IPTR = IPTR + 1 - CALL SBYTEC (IPFLD,IBDSFL(7),IPTR,1) - IPTR = IPTR + 1 - CALL SBYTEC (IPFLD,IBDSFL(8),IPTR,1) - IPTR = IPTR + 1 - CALL SBYTEC (IPFLD,IBDSFL(9),IPTR,1) - IPTR = IPTR + 1 - CALL SBYTEC (IPFLD,IBDSFL(10),IPTR,1) - IPTR = IPTR + 1 - CALL SBYTEC (IPFLD,IBDSFL(11),IPTR,1) - IPTR = IPTR + 1 - CALL SBYTEC (IPFLD,IBDSFL(12),IPTR,1) - IPTR = IPTR + 1 -C BYTES 15-16 -C SKIP OVER VALUE FOR N2 - IPTR = IPTR + 16 -C BYTES 17-18 -C P1 - CALL SBYTEC (IPFLD,KBDS(17),IPTR,16) - IPTR = IPTR + 16 -C BYTES 19-20 -C P2 - CALL SBYTEC (IPFLD,KBDS(19),IPTR,16) - IPTR = IPTR + 16 -C BYTE 21 - RESERVED LOCATION - CALL SBYTEC (IPFLD,0,IPTR,8) - IPTR = IPTR + 8 -C BYTES 22 - ? -C WIDTHS OF SECOND ORDER PACKING - IX = (IWDPTR + 32) / 32 -C CALL SBYTESC (IPFLD,ISOWID,IPTR,32,0,IX) - ijk=IWDPTR/8 - jst=(iptr/8)+1 - ipfld(jst:jst+ijk)=ISOWID(1:ijk) - IPTR = IPTR + IWDPTR -C PRINT *,'ISOWID',IWDPTR,IX -C CALL BINARY (ISOWID,IX) -C -C NO SECONDARY BIT MAP - -C DETERMINE LOCATION FOR START -C OF FIRST ORDER PACKED VALUES - KBDS(12) = IPTR / 8 + 12 -C STORE LOCATION - CALL SBYTEC (IPFLD,KBDS(12),0,16) -C MOVE IN FIRST ORDER PACKED VALUES - IPASS = (IFOPTR + 32) / 32 -c CALL SBYTESC (IPFLD,IFOVAL,IPTR,32,0,IPASS) - ijk=(IFOPTR/8)+1 - jst=(iptr/8)+1 - ipfld(jst:jst+ijk)=ifoval(1:ijk) - IPTR = IPTR + IFOPTR -C PRINT *,'IFOVAL',IFOPTR,IPASS,KWIDE -C CALL BINARY (IFOVAL,IPASS) - IF (MOD(IPTR,8).NE.0) THEN - IPTR = IPTR + 8 - MOD(IPTR,8) - END IF -C PRINT *,'IFOPTR =',IFOPTR,' ISOPTR =',ISOPTR -C DETERMINE LOCATION FOR START -C OF SECOND ORDER VALUES - KBDS(15) = IPTR / 8 + 12 -C SAVE LOCATION OF SECOND ORDER VALUES - CALL SBYTEC (IPFLD,KBDS(15),24,16) -C MOVE IN SECOND ORDER PACKED VALUES - IX = (ISOPTR + 32) / 32 -C CALL SBYTESC (IPFLD,ISOVAL,IPTR,32,0,IX) - ijk=(ISOPTR/8)+1 - jst=(iptr/8)+1 - ipfld(jst:jst+ijk)=isoval(1:ijk) - IPTR = IPTR + ISOPTR -C PRINT *,'ISOVAL',ISOPTR,IX -C CALL BINARY (ISOVAL,IX) - NLEFT = MOD(IPTR+88,16) - IF (NLEFT.NE.0) THEN - NLEFT = 16 - NLEFT - IPTR = IPTR + NLEFT - END IF -C COMPUTE LENGTH OF DATA PORTION - LEN = IPTR / 8 -C COMPUTE LENGTH OF BDS - LENBDS = LEN + 11 -C ----------------------------------- -C BYTES 1-3 -C THIS FUNCTION COMPLETED BELOW -C WHEN LENGTH OF BDS IS KNOWN - CALL SBYTEC (BDS11,LENBDS,0,24) -C BYTE 4 - CALL SBYTEC (BDS11,IBDSFL(1),24,1) - CALL SBYTEC (BDS11,IBDSFL(2),25,1) - CALL SBYTEC (BDS11,IBDSFL(3),26,1) - CALL SBYTEC (BDS11,IBDSFL(4),27,1) -C ENTER NUMBER OF FILL BITS - CALL SBYTEC (BDS11,NLEFT,28,4) -C BYTE 5-6 - IF (ISCAL2.LT.0) THEN - CALL SBYTEC (BDS11,1,32,1) - ISCAL2 = - ISCAL2 - ELSE - CALL SBYTEC (BDS11,0,32,1) - END IF - CALL SBYTEC (BDS11,ISCAL2,33,15) -C -C$ FILL OCTET 7-10 WITH THE REFERENCE VALUE -C CONVERT THE FLOATING POINT OF YOUR MACHINE TO IBM370 32 BIT -C FLOATING POINT NUMBER -C REFERENCE VALUE -C FIRST TEST TO SEE IF -C ON 32 OR 64 BIT COMPUTER -C CALL W3FI01(LW) - IF (bit_size(LW).EQ.32) THEN - CALL W3FI76 (REFNCE,IEXP,IMANT,32) - ELSE - CALL W3FI76 (REFNCE,IEXP,IMANT,64) - END IF - CALL SBYTEC (BDS11,IEXP,48,8) - CALL SBYTEC (BDS11,IMANT,56,24) -C -C BYTE 11 -C - CALL SBYTEC (BDS11,KBDS(11),80,8) -C - KLEN = LENBDS / 4 + 1 -C PRINT *,'BDS11 LISTING',4,LENBDS -C CALL BINARY (BDS11,4) -C PRINT *,'IPFLD LISTING' -C CALL BINARY (IPFLD,KLEN) - RETURN - END - SUBROUTINE FI7505 (N,NBITS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI7505 DETERMINE NUMBER OF BITS TO CONTAIN VALUE -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-06-23 -C -C ABSTRACT: CALCULATE NUMBER OF BITS TO CONTAIN VALUE N, WITH A -C MAXIMUM OF 32 BITS. -C -C PROGRAM HISTORY LOG: -C 93-06-23 CAVANAUGH -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C -C USAGE: CALL FI7505 (N,NBITS) -C INPUT ARGUMENT LIST: -C N - INTEGER VALUE -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C NBITS - NUMBER OF BITS TO CONTAIN N -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256 -C -C$$$ - INTEGER N,NBITS - INTEGER IBITS(31) -C - DATA IBITS/1,3,7,15,31,63,127,255,511,1023,2047, - * 4095,8191,16383,32767,65535,131071,262143, - * 524287,1048575,2097151,4194303,8388607, - * 16777215,33554431,67108863,134217727,268435455, - * 536870911,1073741823,2147483647/ -C ---------------------------------------------------------------- -C - DO 1000 NBITS = 1, 31 - IF (N.LE.IBITS(NBITS)) THEN - RETURN - END IF - 1000 CONTINUE - RETURN - END - SUBROUTINE FI7513 (IWORK,ISTART,NPTS,MAX,MIN,INRNGE) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI7513 SELECT BLOCK OF DATA FOR PACKING -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-01-21 -C -C ABSTRACT: SELECT A BLOCK OF DATA FOR PACKING -C -C PROGRAM HISTORY LOG: -C 94-01-21 CAVANAUGH -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C -C USAGE: CALL FI7513 (IWORK,ISTART,NPTS,MAX,MIN,INRNGE) -C INPUT ARGUMENT LIST: -C * - RETURN ADDRESS IF ENCOUNTER SET OF SAME VALUES -C IWORK - -C ISTART - -C NPTS - -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C MAX - -C MIN - -C INRNGE - -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256 -C -C$$$ - INTEGER IWORK(*),NPTS,ISTART,INRNGE,INRNGA,INRNGB - INTEGER MAX,MIN,MXVAL,MAXB,MINB,MXVALB - INTEGER IBITS(31) -C - DATA IBITS/1,3,7,15,31,63,127,255,511,1023,2047, - * 4095,8191,16383,32767,65535,131071,262143, - * 524287,1048575,2097151,4194303,8388607, - * 16777215,33554431,67108863,134217727,268435455, - * 536870911,1073741823,2147483647/ -C ---------------------------------------------------------------- -C IDENTIFY NEXT BLOCK OF DATA FOR PACKING AND -C RETURN TO CALLER -C ******************************************************************** - ISTRTA = ISTART -C -C GET BLOCK A - CALL FI7516 (IWORK,NPTS,INRNGA,ISTRTA, - * MAX,MIN,MXVAL,LWIDE) -C ******************************************************************** -C - ISTRTB = ISTRTA + INRNGA - 2000 CONTINUE -C IF HAVE PROCESSED ALL DATA, RETURN - IF (ISTRTB.GT.NPTS) THEN -C NO MORE DATA TO LOOK AT - INRNGE = INRNGA - RETURN - END IF -C GET BLOCK B - CALL FI7502 (IWORK,ISTRTB,NPTS,ISAME) - IF (ISAME.GE.15) THEN -C PRINT *,'BLOCK B HAS ALL IDENTICAL VALUES' -C PRINT *,'BLOCK A HAS INRNGE =',INRNGA -C BLOCK B CONTAINS ALL IDENTICAL VALUES - INRNGE = INRNGA -C EXIT WITH BLOCK A - RETURN - END IF -C GET BLOCK B -C - ISTRTB = ISTRTA + INRNGA - CALL FI7516 (IWORK,NPTS,INRNGB,ISTRTB, - * MAXB,MINB,MXVALB,LWIDEB) -C PRINT *,'BLOCK A',INRNGA,' BLOCK B',INRNGB -C ******************************************************************** -C PERFORM TREND ANALYSIS TO DETERMINE -C IF DATA COLLECTION CAN BE IMPROVED -C - KTRND = LWIDE - LWIDEB -C PRINT *,'TREND',LWIDE,LWIDEB - IF (KTRND.LE.0) THEN -C PRINT *,'BLOCK A - SMALLER, SHOULD EXTEND INTO BLOCK B' - MXVAL = IBITS(LWIDE) -C -C IF BLOCK A REQUIRES THE SAME OR FEWER BITS -C LOOK AHEAD -C AND GATHER THOSE DATA POINTS THAT CAN -C BE RETAINED IN BLOCK A -C BECAUSE THIS BLOCK OF DATA -C USES FEWER BITS -C - CALL FI7518 (IRET,IWORK,NPTS,ISTRTA,INRNGA,INRNGB, - * MAX,MIN,LWIDE,MXVAL) - IF(IRET.EQ.1) GO TO 8000 -C PRINT *,'18 INRNGA IS NOW ',INRNGA - IF (INRNGB.LT.20) THEN - RETURN - ELSE - GO TO 2000 - END IF - ELSE -C PRINT *,'BLOCK A - LARGER, B SHOULD EXTEND BACK INTO A' - MXVALB = IBITS(LWIDEB) -C -C IF BLOCK B REQUIRES FEWER BITS -C LOOK BACK -C SHORTEN BLOCK A BECAUSE NEXT BLOCK OF DATA -C USES FEWER BITS -C - CALL FI7517 (IRET,IWORK,NPTS,ISTRTB,INRNGA, - * MAXB,MINB,LWIDEB,MXVALB) - IF(IRET.EQ.1) GO TO 8000 -C PRINT *,'17 INRNGA IS NOW ',INRNGA - END IF -C -C PACK UP BLOCK A -C UPDATA POINTERS - 8000 CONTINUE - INRNGE = INRNGA -C GET NEXT BLOCK A - 9000 CONTINUE - RETURN - END - SUBROUTINE FI7516 (IWORK,NPTS,INRNG,ISTART,MAX,MIN,MXVAL,LWIDTH) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI7516 SCAN NUMBER OF POINTS -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-01-21 -C -C ABSTRACT: SCAN FORWARD FROM CURRENT POSITION. COLLECT POINTS AND -C DETERMINE MAXIMUM AND MINIMUM VALUES AND THE NUMBER -C OF POINTS THAT ARE INCLUDED. FORWARD SEARCH IS TERMINATED -C BY ENCOUNTERING A SET OF IDENTICAL VALUES, BY REACHING -C THE NUMBER OF POINTS SELECTED OR BY REACHING THE END -C OF DATA. -C -C PROGRAM HISTORY LOG: -C 94-01-21 CAVANAUGH -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C -C USAGE: CALL FI7516 (IWORK,NPTS,INRNG,ISTART,MAX,MIN,MXVAL,LWIDTH) -C INPUT ARGUMENT LIST: -C * - RETURN ADDRESS IF ENCOUNTER SET OF SAME VALUES -C IWORK - DATA ARRAY -C NPTS - NUMBER OF POINTS IN DATA ARRAY -C ISTART - STARTING LOCATION IN DATA -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C INRNG - NUMBER OF POINTS SELECTED -C MAX - MAXIMUM VALUE OF POINTS -C MIN - MINIMUM VALUE OF POINTS -C MXVAL - MAXIMUM VALUE THAT CAN BE CONTAINED IN LWIDTH BITS -C LWIDTH - NUMBER OF BITS TO CONTAIN MAX DIFF -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256 -C -C$$$ - INTEGER IWORK(*),NPTS,ISTART,INRNG,MAX,MIN,LWIDTH,MXVAL - INTEGER IBITS(31) -C - DATA IBITS/1,3,7,15,31,63,127,255,511,1023,2047, - * 4095,8191,16383,32767,65535,131071,262143, - * 524287,1048575,2097151,4194303,8388607, - * 16777215,33554431,67108863,134217727,268435455, - * 536870911,1073741823,2147483647/ -C ---------------------------------------------------------------- -C - INRNG = 1 - JQ = ISTART + 19 - MAX = IWORK(ISTART) - MIN = IWORK(ISTART) - DO 1000 I = ISTART+1, JQ - CALL FI7502 (IWORK,I,NPTS,ISAME) - IF (ISAME.GE.15) THEN - GO TO 5000 - END IF - INRNG = INRNG + 1 - IF (IWORK(I).GT.MAX) THEN - MAX = IWORK(I) - ELSE IF (IWORK(I).LT.MIN) THEN - MIN = IWORK(I) - END IF - 1000 CONTINUE - 5000 CONTINUE - KRNG = MAX - MIN -C - DO 9000 LWIDTH = 1, 31 - IF (KRNG.LE.IBITS(LWIDTH)) THEN -C PRINT *,'RETURNED',INRNG,' VALUES' - RETURN - END IF - 9000 CONTINUE - RETURN - END - SUBROUTINE FI7517 (IRET,IWORK,NPTS,ISTRTB,INRNGA, - * MAXB,MINB,MXVALB,LWIDEB) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI7517 SCAN BACKWARD -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-01-21 -C -C ABSTRACT: SCAN BACKWARDS UNTIL A VALUE EXCEEDS RANGE OF GROUP B -C THIS MAY SHORTEN GROUP A -C -C PROGRAM HISTORY LOG: -C 94-01-21 CAVANAUGH -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 98-06-17 IREDELL REMOVED ALTERNATE RETURN -C -C USAGE: CALL FI7517 (IRET,IWORK,NPTS,ISTRTB,INRNGA, -C * MAXB,MINB,MXVALB,LWIDEB) -C INPUT ARGUMENT LIST: -C IWORK - -C ISTRTB - -C NPTS - -C INRNGA - -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C IRET - -C JLAST - -C MAXB - -C MINB - -C LWIDTH - NUMBER OF BITS TO CONTAIN MAX DIFF -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256 -C -C$$$ - INTEGER IWORK(*),NPTS,ISTRTB,INRNGA - INTEGER MAXB,MINB,LWIDEB,MXVALB - INTEGER IBITS(31) -C - DATA IBITS/1,3,7,15,31,63,127,255,511,1023,2047, - * 4095,8191,16383,32767,65535,131071,262143, - * 524287,1048575,2097151,4194303,8388607, - * 16777215,33554431,67108863,134217727,268435455, - * 536870911,1073741823,2147483647/ -C ---------------------------------------------------------------- - IRET=0 -C PRINT *,' FI7517' - NPOS = ISTRTB - 1 - ITST = 0 - KSET = INRNGA -C - 1000 CONTINUE -C PRINT *,'TRY NPOS',NPOS,IWORK(NPOS),MAXB,MINB - ITST = ITST + 1 - IF (ITST.LE.KSET) THEN - IF (IWORK(NPOS).GT.MAXB) THEN - IF ((IWORK(NPOS)-MINB).GT.MXVALB) THEN -C PRINT *,'WENT OUT OF RANGE AT',NPOS - IRET=1 - RETURN - ELSE - MAXB = IWORK(NPOS) - END IF - ELSE IF (IWORK(NPOS).LT.MINB) THEN - IF ((MAXB-IWORK(NPOS)).GT.MXVALB) THEN -C PRINT *,'WENT OUT OF RANGE AT',NPOS - IRET=1 - RETURN - ELSE - MINB = IWORK(NPOS) - END IF - END IF - INRNGA = INRNGA - 1 - NPOS = NPOS - 1 - GO TO 1000 - END IF -C ---------------------------------------------------------------- -C - 9000 CONTINUE - RETURN - END - SUBROUTINE FI7518 (IRET,IWORK,NPTS,ISTRTA,INRNGA,INRNGB, - * MAXA,MINA,LWIDEA,MXVALA) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI7518 SCAN FORWARD -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-01-21 -C -C ABSTRACT: SCAN FORWARD FROM START OF BLOCK B TOWARDS END OF BLOCK B -C IF NEXT POINT UNDER TEST FORCES A LARGER MAXVALA THEN -C TERMINATE INDICATING LAST POINT TESTED FOR INCLUSION -C INTO BLOCK A. -C -C PROGRAM HISTORY LOG: -C 94-01-21 CAVANAUGH -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 98-06-17 IREDELL REMOVED ALTERNATE RETURN -C -C USAGE: CALL FI7518 (IRET,IWORK,NPTS,ISTRTA,INRNGA,INRNGB, -C * MAXA,MINA,LWIDEA,MXVALA) -C INPUT ARGUMENT LIST: -C IFLD - -C JSTART - -C NPTS - -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C IRET - -C JLAST - -C MAX - -C MIN - -C LWIDTH - NUMBER OF BITS TO CONTAIN MAX DIFF -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256 -C -C$$$ - INTEGER IWORK(*),NPTS,ISTRTA,INRNGA - INTEGER MAXA,MINA,LWIDEA,MXVALA - INTEGER IBITS(31) -C - DATA IBITS/1,3,7,15,31,63,127,255,511,1023,2047, - * 4095,8191,16383,32767,65535,131071,262143, - * 524287,1048575,2097151,4194303,8388607, - * 16777215,33554431,67108863,134217727,268435455, - * 536870911,1073741823,2147483647/ -C ---------------------------------------------------------------- - IRET=0 -C PRINT *,' FI7518' - NPOS = ISTRTA + INRNGA - ITST = 0 -C - 1000 CONTINUE - ITST = ITST + 1 - IF (ITST.LE.INRNGB) THEN -C PRINT *,'TRY NPOS',NPOS,IWORK(NPOS),MAXA,MINA - IF (IWORK(NPOS).GT.MAXA) THEN - IF ((IWORK(NPOS)-MINA).GT.MXVALA) THEN -C PRINT *,'FI7518A -',ITST,' RANGE EXCEEDS MAX' - IRET=1 - RETURN - ELSE - MAXA = IWORK(NPOS) - END IF - ELSE IF (IWORK(NPOS).LT.MINA) THEN - IF ((MAXA-IWORK(NPOS)).GT.MXVALA) THEN -C PRINT *,'FI7518B -',ITST,' RANGE EXCEEDS MAX' - IRET=1 - RETURN - ELSE - MINA = IWORK(NPOS) - END IF - END IF - INRNGA = INRNGA + 1 -C PRINT *,' ',ITST,INRNGA - NPOS = NPOS +1 - GO TO 1000 - END IF -C ---------------------------------------------------------------- - 9000 CONTINUE - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fi76.f b/src/fim/FIMsrc/w3/w3fi76.f deleted file mode 100644 index 2a1553f..0000000 --- a/src/fim/FIMsrc/w3/w3fi76.f +++ /dev/null @@ -1,131 +0,0 @@ - SUBROUTINE W3FI76(PVAL,KEXP,KMANT,KBITS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI76 CONVERT TO IBM370 FLOATING POINT -C PRGMMR: REJONES ORG: NMC421 DATE:92-11-16 -C -C ABSTRACT: CONVERTS FLOATING POINT NUMBER FROM MACHINE -C REPRESENTATION TO GRIB REPRESENTATION (IBM370 32 BIT F.P.). -C -C PROGRAM HISTORY LOG: -C 85-09-15 JOHN HENNESSY ECMWF -C 92-09-23 JONES R. E. CHANGE NAME, ADD DOC BLOCK -C 93-10-27 JONES,R. E. CHANGE TO AGREE WITH HENNESSY CHANGES -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 98-03-10 B. VUONG REMOVE THE CDIR$ INTEGER=64 DIRECTIVE -C -C USAGE: CALL W3FI76 (FVAL, KEXP, KMANT, NBITS) -C INPUT ARGUMENT LIST: -C PVAL - FLOATING POINT NUMBER TO BE CONVERTED -C KBITS - NUMBER OF BITS IN COMPUTER WORD (32 OR 64) -C -C OUTPUT ARGUMENT LIST: -C KEXP - 8 BIT SIGNED EXPONENT -C KMANT - 24 BIT MANTISSA (FRACTION) -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: IBM370 VS FORTRAN 77, CRAY CFT77 FORTRAN -C MACHINE: HDS 9000, CRAY Y-MP8/864< CRAY Y-MP EL2/256 -C -C$$$ -C -C******************************************************************** -C* -C* NAME : CONFP3 -C* -C* FUNCTION : CONVERT FLOATING POINT NUMBER FROM MACHINE -C* REPRESENTATION TO GRIB REPRESENTATION. -C* -C* INPUT : PVAL - FLOATING POINT NUMBER TO BE CONVERTED. -C* KBITS : KBITS - NUMBER OF BITS IN COMPUTER WORD -C* -C* OUTPUT : KEXP - 8 BIT SIGNED EXPONENT -C* KMANT - 24 BIT MANTISSA -C* PVAL - UNCHANGED. -C* -C* JOHN HENNESSY , ECMWF 18.06.91 -C* -C******************************************************************** -C -C -C IMPLICIT NONE -C - INTEGER IEXP - INTEGER ISIGN -C - INTEGER KBITS - INTEGER KEXP - INTEGER KMANT -C - REAL PVAL - REAL ZEPS - REAL ZREF -C -C TEST FOR FLOATING POINT ZERO -C - IF (PVAL.EQ.0.0) THEN - KEXP = 0 - KMANT = 0 - GO TO 900 - ENDIF -C -C SET ZEPS TO 1.0E-12 FOR 64 BIT COMPUTERS (CRAY) -C SET ZEPS TO 1.0E-8 FOR 32 BIT COMPUTERS -C - IF (KBITS.EQ.32) THEN - ZEPS = 1.0E-8 - ELSE - ZEPS = 1.0E-12 - ENDIF - ZREF = PVAL -C -C SIGN OF VALUE -C - ISIGN = 0 - IF (ZREF.LT.0.0) THEN - ISIGN = 128 - ZREF = - ZREF - ENDIF -C -C EXPONENT -C - IEXP = INT(ALOG(ZREF)*(1.0/ALOG(16.0))+64.0+1.0+ZEPS) -C - IF (IEXP.LT.0 ) IEXP = 0 - IF (IEXP.GT.127) IEXP = 127 -C -C MANTISSA -C -C CLOSEST NUMBER IN GRIB FORMAT TO ORIGINAL NUMBER -C (EQUAL TO, GREATER THAN OR LESS THAN ORIGINAL NUMBER). -C - KMANT = NINT (ZREF/16.0**(IEXP-70)) -C -C CHECK THAT MANTISSA VALUE DOES NOT EXCEED 24 BITS -C 16777215 = 2**24 - 1 -C - IF (KMANT.GT.16777215) THEN - IEXP = IEXP + 1 -C -C CLOSEST NUMBER IN GRIB FORMAT TO ORIGINAL NUMBER -C (EQUAL TO, GREATER THAN OR LESS THAN ORIGINAL NUMBER). -C - KMANT = NINT (ZREF/16.0**(IEXP-70)) -C -C CHECK MANTISSA VALUE DOES NOT EXCEED 24 BITS AGAIN -C - IF (KMANT.GT.16777215) THEN - PRINT *,'BAD MANTISSA VALUE FOR PVAL = ',PVAL - ENDIF - ENDIF -C -C ADD SIGN BIT TO EXPONENT. -C - KEXP = IEXP + ISIGN -C - 900 CONTINUE -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fi78.f b/src/fim/FIMsrc/w3/w3fi78.f deleted file mode 100644 index bcee3c0..0000000 --- a/src/fim/FIMsrc/w3/w3fi78.f +++ /dev/null @@ -1,2947 +0,0 @@ - SUBROUTINE W3FI78(IPTR,IDENT,MSGA,ISTACK,MSTACK,KDATA,KNR,INDEX, - * MAXR,MAXD,IUNITB,IUNITD) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI78 BUFR MESSAGE DECODER -C PRGMMR: CAVANAUGH ORG: NMC421 DATE:93-03-17 -C -C ABSTRACT: THIS SET OF ROUTINES WILL DECODE A BUFR MESSAGE AND -C PLACE INFORMATION EXTRACTED FROM THE BUFR MESSAGE INTO SELECTED -C ARRAYS FOR THE USER. THE ARRAY KDATA CAN NOW BE SIZED BY THE USER -C BY INDICATING THE MAXIMUM NUMBER OF SUBSTES AND THE MAXIMUM -C NUMBER OF DESCRIPTORS THAT ARE EXPECTED IN THE COURSE OF DECODING -C SELECTED INPUT DATA. THIS ALLOWS FOR REALISTIC SIZING OF KDATA -C AND THE MSTACK ARRAYS. THIS VERSION ALSO ALLOWS FOR THE INCLUSION -C OF THE UNIT NUMBERS FOR TABLES B AND D INTO THE -C ARGUMENT LIST. THIS ROUTINE DOES NOT INCLUDE IFOD PROCESSING. -C -C PROGRAM HISTORY LOG: -C 88-08-31 CAVANAUGH -C 90-12-07 CAVANAUGH NOW UTILIZING GBYTE ROUTINES TO GATHER -C AND SEPARATE BIT FIELDS. THIS SHOULD IMPROVE -C (DECREASE) THE TIME IT TAKES TO DECODE ANY -C BUFR MESSAGE. HAVE ENTERED CODING THAT WILL -C PERMIT PROCESSING BUFR EDITIONS 1 AND 2. -C IMPROVED AND CORRECTED THE CONVERSION INTO -C IFOD FORMAT OF DECODED BUFR MESSAGES. -C 91-01-18 CAVANAUGH PROGRAM/ROUTINES MODIFIED TO PROPERLY HANDLE -C SERIAL PROFILER DATA. -C 91-04-04 CAVANAUGH MODIFIED TO HANDLE TEXT SUPPLIED THRU -C DESCRIPTOR 2 05 YYY. -C 91-04-17 CAVANAUGH ERRORS IN EXTRACTING AND SCALING DATA -C CORRECTED. IMPROVED HANDLING OF NESTED -C QUEUE DESCRIPTORS IS ADDED. -C 91-05-10 CAVANAUGH - ARRAY 'DATA' HAS BEEN ENLARGED TO REAL*8 -C TO BETTER CONTAIN VERY LARGE NUMBERS MORE -C ACCURATELY. THE PREIOUS SIZE REAL*4 COULD NOT -C CONTAIN SUFFICIENT SIGNIFICANT DIGITS. -C - CODING HAS BEEN INTRODUCED TO PROCESS NEW -C TABLE C DESCRIPTOR 2 06 YYY WHICH PERMITS IN -C LINE PROCESSING OF A LOCAL DESCRIPTOR EVEN IF -C THE DESCRIPTOR IS NOT CONTAINED IN THE USERS -C TABLE B. -C - A SECOND ROUTINE TO PROCESS IFOD MESSAGES -C (IFOD0) HAS BEEN REMOVED IN FAVOR OF THE -C IMPROVED PROCESSING OF THE ONE -C REMAINING (IFOD1). -C - NEW CODING HAS BEEN INTRODUCED TO PERMIT -C PROCESSING OF BUFR MESSAGES BASED ON BUFR -C EDITION UP TO AND INCLUDING EDITION 2. -C PLEASE NOTE INCREASED SIZE REQUIREMENTS -C FOR ARRAYS IDENT(20) AND IPTR(40). -C 91-07-26 CAVANAUGH - ADD ARRAY MTIME TO CALLING SEQUENCE TO -C PERMIT INCLUSION OF RECEIPT/TRANSFER TIMES -C TO IFOD MESSAGES. -C 91-09-25 CAVANAUGH - ALL PROCESSING OF DECODED BUFR DATA INTO -C IFOD (A LOCAL USE REFORMAT OF BUFR DATA) -C HAS BEEN ISOLATED FROM THIS SET OF ROUTINES. -C FOR THOSE INTERESTED IN THE IFOD FORM, -C SEE W3FL05 IN THE W3LIB ROUTINES. -C PROCESSING OF BUFR MESSAGES CONTAINING -C DELAYED REPLICATION HAS BEEN ALTERED SO THAT -C SINGLE SUBSETS (REPORTS) AND AND A MATCHING -C DESCRIPTOR LIST FOR THAT PARTICULAR SUBSET -C WILL BE PASSED TO THE USER WILL BE PASSED TO -C THE USER ONE AT A TIME TO ASSURE THAT EACH -C SUBSET CAN BE FULLY DEFINED WITH A MINIMUM -C OF REPROCESSING. -C PROCESSING OF ASSOCIATED FIELDS HAS BEEN -C TESTED WITH MESSAGES CONTAINING NON-COMPRESSED -C DATA. -C IN ORDER TO FACILITATE USER PROCESSING -C A MATCHING LIST OF SCALE FACTORS ARE INCLUDED -C WITH THE EXPANDED DESCRIPTOR LIST (MSTACK). -C 91-11-21 CAVANAUGH - PROCESSING OF DESCRIPTOR 2 03 YYY -C HAS CORRECTED TO AGREE WITH FM94 STANDARDS. -C 91-12-19 CAVANAUGH - CALLS TO FI7803 AND FI7804 HAVE BEEN -C CORRECTED TO AGREE CALLED PROGRAM ARGUMENT -C LIST. SOME ADDITIONAL ENTRIES HAVE BEEN -C INCLUDED FOR COMMUNICATING WITH DATA ACCESS -C ROUTINES. ADDITIONAL ERROR EXIT PROVIDED FOR -C THE CASE WHERE TABLE B IS DAMAGED. -C 92-01-24 CAVANAUGH - ROUTINES FI7801, FI7803 AND FI7804 -C HAVE BEEN MODIFIED TO HANDLE ASSOCIATED FIELDS -C ALL DESCRIPTORS ARE SET TO ECHO TO MSTACK(1,N) -C 92-05-21 CAVANAUGH - FURTHER EXPANSION OF INFORMATION COLLECTED -C FROM WITHIN UPPER AIR SOUNDINGS HAS PRODUCED -C THE NECESSITY TO EXPAND SOME OF THE PROCESSING -C AND OUTPUT ARRAYS. (SEE REMARKS BELOW) -C 92-06-29 CAVANAUGH - CORRECTED DESCRIPTOR DENOTING HEIGHT OF -C EACH WIND LEVEL FOR PROFILER CONVERSIONS. -C 92-07-23 CAVANAUGH - EXPANSION OF TABLE B REQUIRES ADJUSTMENT -C OF ARRAYS TO CONTAIN TABLE B VALUES NEEDED TO -C ASSIST IN THE DECODING PROCESS. -C ARRAYS CONTAINING DATA FROM TABLE B -C KDESC - DESCRIPTOR -C ANAME - DESCRIPTOR NAME -C AUNITS - UNITS FOR DESCRIPTOR -C MSCALE - SCALE FOR VALUE OF DESCRIPTOR -C MREF - REFERENCE VALUE FOR DESCRIPTOR -C MWIDTH - BIT WIDTH FOR VALUE OF DESCRIPTOR -C 92-09-09 CAVANAUGH - FIRST ENCOUNTER WITH OPERATOR DESCRIPTOR -C 2 05 YYY SHOWED ERROR IN DECODING. THAT ERROR -C IS CORRECTED WITH THIS IMPLEMENTATION. FURTHER -C TESTING OF UPPER AIR DATA HAS ENCOUNTERED -C THE CONDITION OF LARGE (MANY LEVEL) SOUNDINGS -C ARRAYS IN THE DECODER HAVE BEEN EXPANDED (AGAIN) -C TO ALLOW FOR THIS CONDITION. -C 92-10-02 CAVANAUGH - MODIFIED ROUTINE TO REFORMAT PROFILER DATA -C (FI7809) TO SHOW DESCRIPTORS, SCALE VALUE AND -C DATA IN PROPER ORDER. CORRECTED AN ERROR THAT -C PREVENTED USER FROM ASSIGNING THE SECOND DIMENSION -C OF KDATA(500,*). -C 92-10-20 CAVANAUGH - REMOVED ERROR THAT PREVENTED FULL -C IMPLEMENTATION OF PREVIOUS CORRECTIONS AND -C MADE CORRECTIONS TO TABLE B TO BRING IT UP TO -C DATE. CHANGES INCLUDE PROPER REFORMAT OF PROFILER -C DATA AND USER CAPABILITY FOR ASSIGNING SECOND -C DIMENSION OF KDATA ARRAY. -C 92-12-09 CAVANAUGH - THANKS TO DENNIS KEYSER FOR THE SUGGESTIONS -C AND CODING, THIS IMPLEMENTATION WILL ALLOW THE -C INCLUSION OF UNIT NUMBERS FOR TABLES B & D, AND -C IN ADDITION ALLOWS FOR REALISTIC SIZING OF KDATA -C AND MSTACK ARRAYS BY THE USER. AS OF THIS -C IMPLEMENTATION, THE UPPER SIZE LIMIT FOR A BUFR -C MESSAGE ALLOWS FOR A MESSAGE SIZE GREATER THAN -C 10000 BYTES. -C 93-01-26 CAVANAUGH - SUBROUTINE FI7810 HAS BEEN ADDED TO PERMIT -C REFORMATTING OF PROFILER DATA IN EDITION 2. -C -C -C USAGE: CALL W3FI78(IPTR,IDENT,MSGA,ISTACK,MSTACK,KDATA,KNR,INDEX, -C MAXR,MAXD,IUNITB,IUNITD) -C -C INPUT ARGUMENT LIST: -C MSGA - ARRAY CONTAINING SUPPOSED BUFR MESSAGE -C SIZE IS DETERMINED BY USER, CAN BE GREATER -C THAN 10000 BYTES. -C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE -C CONTAINED IN A BUFR MESSAGE -C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT -C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE -C DATA REQUIRE A VALUE FOR MAXD OF 1600, BUT FOR MOST -C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE -C IUNITB - UNIT NUMBER OF DATA SET HOLDING TABLE B -C IUNITD - UNIT NUMBER OF DATA SET HOLDING TABLE D -C -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C ISTACK - ORIGINAL ARRAY OF DESCRIPTORS EXTRACTED FROM -C SOURCE BUFR MESSAGE. -C -C MSTACK(A,B)-LEVEL B - DESCRIPTOR NUMBER (LIMITED TO VALUE OF -C INPUT ARGUMENT MAXD) -C -C LEVEL A = 1 DESCRIPTOR -C = 2 10**N SCALING TO RETURN TO ORIGINAL VALUE -C IPTR - UTILITY ARRAY -C IPTR( 1)- ERROR RETURN -C IPTR( 2)- BYTE COUNT SECTION 1 -C IPTR( 3)- POINTER TO START OF SECTION 1 -C IPTR( 4)- BYTE COUNT SECTION 2 -C IPTR( 5)- POINTER TO START OF SECTION 2 -C IPTR( 6)- BYTE COUNT SECTION 3 -C IPTR( 7)- POINTER TO START OF SECTION 3 -C IPTR( 8)- BYTE COUNT SECTION 4 -C IPTR( 9)- POINTER TO START OF SECTION 4 -C IPTR(10)- START OF REQUESTED SUBSET, RESERVED FOR DAR -C IPTR(11)- CURRENT DESCRIPTOR PTR IN IWORK -C IPTR(12)- LAST DESCRIPTOR POS IN IWORK -C IPTR(13)- LAST DESCRIPTOR POS IN ISTACK -C IPTR(14)- NUMBER OF TABLE B ENTRIES -C IPTR(15)- REQUESTED SUBSET POINTER, RESERVED FOR DAR -C IPTR(16)- INDICATOR FOR EXISTANCE OF SECTION 2 -C IPTR(17)- NUMBER OF REPORTS PROCESSED -C IPTR(18)- ASCII/TEXT EVENT -C IPTR(19)- POINTER TO START OF BUFR MESSAGE -C IPTR(20)- NUMBER OF LINES FROM TABLE D -C IPTR(21)- TABLE B SWITCH -C IPTR(22)- TABLE D SWITCH -C IPTR(23)- CODE/FLAG TABLE SWITCH -C IPTR(24)- ADITIONAL WORDS ADDED BY TEXT INFO -C IPTR(25)- CURRENT BIT NUMBER -C IPTR(26)- DATA WIDTH CHANGE -C IPTR(27)- DATA SCALE CHANGE -C IPTR(28)- DATA REFERENCE VALUE CHANGE -C IPTR(29)- ADD DATA ASSOCIATED FIELD -C IPTR(30)- SIGNIFY CHARACTERS -C IPTR(31)- NUMBER OF EXPANDED DESCRIPTORS IN MSTACK -C IPTR(32)- CURRENT DESCRIPTOR SEGMENT F -C IPTR(33)- CURRENT DESCRIPTOR SEGMENT X -C IPTR(34)- CURRENT DESCRIPTOR SEGMENT Y -C IPTR(35)- UNUSED -C IPTR(36)- NEXT DESCRIPTOR MAY BE UNDECIPHERABLE -C IPTR(37)- UNUSED -C IPTR(38)- UNUSED -C IPTR(39)- DELAYED REPLICATION FLAG -C 0 - NO DELAYED REPLICATION -C 1 - MESSAGE CONTAINS DELAYED REPLICATION -C IPTR(40)- NUMBER OF CHARACTERS IN TEXT FOR CURR DESCRIPTOR -C IDENT - ARRAY CONTAINS MESSAGE INFORMATION EXTRACTED FROM -C BUFR MESSAGE - -C IDENT( 1)-EDITION NUMBER (BYTE 4, SECTION 1) -C IDENT( 2)-ORIGINATING CENTER (BYTES 5-6, SECTION 1) -C IDENT( 3)-UPDATE SEQUENCE (BYTE 7, SECTION 1) -C IDENT( 4)-OPTIONAL SECTION (BYTE 8, SECTION 1) -C IDENT( 5)-BUFR MESSAGE TYPE (BYTE 9, SECTION 1) -C 0 = SURFACE (LAND) -C 1 = SURFACE (SHIP) -C 2 = VERTICAL SOUNDINGS OTHER THAN SATELLITE -C 3 = VERTICAL SOUNDINGS (SATELLITE) -C 4 = SNGL LVL UPPER-AIR OTHER THAN SATELLITE -C 5 = SNGL LVL UPPER-AIR (SATELLITE) -C 6 = RADAR -C IDENT( 6)-BUFR MSG SUB-TYPE (BYTE 10, SECTION 1) -C TYPE SBTYP -C 2 7 = PROFILER -C IDENT( 7)- (BYTES 11-12, SECTION 1) -C IDENT( 8)-YEAR OF CENTURY (BYTE 13, SECTION 1) -C IDENT( 9)-MONTH OF YEAR (BYTE 14, SECTION 1) -C IDENT(10)-DAY OF MONTH (BYTE 15, SECTION 1) -C IDENT(11)-HOUR OF DAY (BYTE 16, SECTION 1) -C IDENT(12)-MINUTE OF HOUR (BYTE 17, SECTION 1) -C IDENT(13)-RSVD BY ADP CENTERS(BYTE 18, SECTION 1) -C IDENT(14)-NR OF DATA SUBSETS (BYTE 5-6, SECTION 3) -C IDENT(15)-OBSERVED FLAG (BYTE 7, BIT 1, SECTION 3) -C IDENT(16)-COMPRESSION FLAG (BYTE 7, BIT 2, SECTION 3) -C IDENT(17)-MASTER TABLE NUMBER(BYTE 4, SECTION 1, ED 2 OR GTR) -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C -C ARRAYS CONTAINING DATA FROM TABLE B -C ANAME - DESCRIPTOR NAME -C AUNITS - UNITS FOR DESCRIPTOR -C MSCALE - SCALE FOR VALUE OF DESCRIPTOR -C MREF - REFERENCE VALUE FOR DESCRIPTOR -C MWIDTH - BIT WIDTH FOR VALUE OF DESCRIPTOR -C INDEX - POINTER TO AVAILABLE SUBSET -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - GBYTE GBYTES -C -C REMARKS: ERROR RETURNS: -C IPTR(1) = 1 'BUFR' NOT FOUND IN FIRST 125 CHARACTERS -C = 2 '7777' NOT FOUND IN LOCATION DETERMINED BY -C BY USING COUNTS FOUND IN EACH SECTION. ONE OR -C MORE SECTIONS HAVE AN ERRONEOUS BYTE COUNT OR -C CHARACTERS '7777' ARE NOT IN TEST MESSAGE. -C = 3 MESSAGE CONTAINS A DESCRIPTOR WITH F=0 THAT DOES -C NOT EXIST IN TABLE B. -C = 4 MESSAGE CONTAINS A DESCRIPTOR WITH F=3 THAT DOES -C NOT EXIST IN TABLE D. -C = 5 MESSAGE CONTAINS A DESCRIPTOR WITH F=2 WITH THE -C VALUE OF X OUTSIDE THE RANGE 1-5. -C = 6 DESCRIPTOR ELEMENT INDICATED TO HAVE A FLAG VALUE -C DOES NOT HAVE AN ENTRY IN THE FLAG TABLE. -C (TO BE ACTIVATED) -C = 7 DESCRIPTOR INDICATED TO HAVE A CODE VALUE DOES -C NOT HAVE AN ENTRY IN THE CODE TABLE. -C (TO BE ACTIVATED) -C = 8 ERROR READING TABLE D -C = 9 ERROR READING TABLE B -C = 10 ERROR READING CODE/FLAG TABLE -C = 11 DESCRIPTOR 2 04 004 NOT FOLLOWED BY 0 31 021 -C = 12 DATA DESCRIPTOR OPERATOR QUALIFIER DOES NOT FOLLOW -C DELAYED REPLICATION DESCRIPTOR. -C = 13 BIT WIDTH ON ASCII CHARACTERS NOT A MULTIPLE OF 8 -C = 14 SUBSETS = 0, NO CONTENT BULLETIN -C = 20 EXCEEDED COUNT FOR DELAYED REPLICATION PASS -C = 21 EXCEEDED COUNT FOR NON-DELAYED REPLICATION PASS -C = 27 NON ZERO LOWEST ON TEXT DATA -C = 28 NBINC NOT NR OF CHARACTERS -C = 29 TABLE B APPEARS TO BE DAMAGED -C = 99 NO MORE SUBSETS (REPORTS) AVAILABLE IN CURRENT -C BUFR MESAGE -C -C = 400 NUMBER OF SUBSETS EXCEEDS THE VALUE OF INPUT -C ARGUMENT MAXR; MUST INCREASE MAXR TO VALUE OF -C IDENT(14) IN CALLING PROGRAM -C -C = 401 NUMBER OF PARAMETERS (AND ASSOCIATED FIELDS) -C EXCEEDS LIMITS OF THIS PROGRAM. -C = 500 VALUE FOR NBINC HAS BEEN FOUND THAT EXCEEDS -C STANDARD WIDTH PLUS ANY BIT WIDTH CHANGE. -C CHECK ALL BIT WIDTHS UP TO POINT OF ERROR. -C = 501 CORRECTED WIDTH FOR DESCRIPTOR IS 0 OR LESS -C -C ON THE INITIAL CALL TO W3FI78 WITH A BUFR MESSAGE THE ARGUMENT -C INDEX MUST BE SET TO ZERO (INDEX = 0). ON THE RETURN FROM W3FI78 -C 'INDEX' WILL BE SET TO THE NEXT AVAILABLE SUBSET/REPORT. WHEN -C THERE ARE NO MORE SUBSETS AVAILABLE A 99 ERR RETURN WILL OCCUR. -C -C IF THE ORIGINAL BUFR MESSAGE DOES NOT CONTAIN DELAYED REPLICATION -C THE BUFR MESSAGE WILL BE COMPLETELY DECODED AND 'INDEX' WILL POINT -C TO THE FIRST DECODED SUBSET. THE USERS WILL THEN HAVE THE OPTION -C OF INDEXING THROUGH THE SUBSETS ON THEIR OWN OR BY RECALLING THIS -C ROUTINE (WITHOUT RESETTING 'INDEX') TO HAVE THE ROUTINE DO THE -C INDEXING. -C -C IF THE ORIGINAL BUFR MESSAGE DOES CONTAIN DELAYED REPLICATION -C ONE SUBSET/REPORT WILL BE DECODED AT A TIME AND PASSED BACK TO -C THE USER. THIS IS NOT AN OPTION. -C -C ============================================= -C TO USE THIS ROUTINE -C -------------------------------- -C 1. READ IN BUFR MESSAGE -C 2. SET INDEX = 0 -C 3. CALL W3FI78( ) -C 4. IF (IPTR(1).EQ.99) THEN -C NO MORE SUBSETS -C EITHER GO TO 1 -C OR TERMINATE IN NO MORE BUFR MESSAGES -C END IF -C 5. IF (IPTR(1).NE.0) THEN -C ERROR CONDITION -C EITHER GO TO 1 -C OR TERMINATE IN NO MORE BUFR MESSAGES -C END IF -C 6. THE VALUE OF INDEX INDICATES THE ACTIVE SUBSET SO -C IF INTERESTED IN GENERATING AN IFOD MESSAGE -C CALL W3FL05 ( ) -C ELSE -C PROCESS DECODED INFORMATION AS REQUIRED -C END IF -C 7. GO TO 3 -C ============================================= -C THE ARRAYS TO CONTAIN THE OUTPUT INFORMATION ARE DEFINED -C AS FOLLOWS: -C -C KDATA(A,B) IS THE A DATA ENTRY (INTEGER VALUE) -C WHERE A IS THE MAXIMUM NUMBER OF REPORTS/SUBSETS -C THAT MAY BE CONTAINED IN THE BUFR MESSAGE (THIS -C IS NOW SET TO "MAXR" WHICH IS PASSED AS AN INPUT -C ARGUMENT TO W3FI78), AND WHERE B IS THE MAXIMUM -C NUMBER OF DESCRIPTOR COMBINATIONS THAT MAY -C BE PROCESSED (THIS IS NOW SET TO "MAXD" WHICH -C IS ALSO PASSED AS AN INPUT ARGUMENT TO W3FI78; -C UPPER AIR DATA AND SOME SATELLITE DATA REQUIRE -C A VALUE FOR MAXD OF 1600, BUT FOR MOST OTHER -C DATA A VALUE FOR MAXD OF 500 WILL SUFFICE) -C MSTACK(1,B) CONTAINS THE DESCRIPTOR THAT MATCHES THE -C DATA ENTRY (MAX. VALUE FOR B IS NOW "MAXD" -C WHICH IS PASSED AS AN INPUT ARGUMENT TO W3FI78) -C MSTACK(2,B) IS THE SCALE (POWER OF 10) TO BE APPLIED TO -C THE DATA (MAX. VALUE FOR B IS NOW "MAXD" -C WHICH IS PASSED AS AN INPUT ARGUMENT TO W3FI78) -C -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN 77 -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - CHARACTER*40 ANAME(700) - CHARACTER*24 AUNITS(700) -C -C -C - INTEGER MSGA(*) - INTEGER IPTR(*) - INTEGER KDATA(MAXR,MAXD) - INTEGER MSTACK(2,MAXD) -C - INTEGER IVALS(1000) - INTEGER KNR(MAXR) - INTEGER IDENT(*) - INTEGER KDESC(2000) - INTEGER ISTACK(*) - INTEGER IWORK(2000) - INTEGER MSCALE(700) - INTEGER MREF(700,3) - INTEGER MWIDTH(700) - INTEGER INDEX -C - CHARACTER*4 DIRID(2) -C - LOGICAL SEC2 -C - SAVE -C -C PRINT *,' W3FI78 DECODER' -C INITIALIZE ERROR RETURN - IPTR(1) = 0 - IF (INDEX.GT.0) THEN -C HAVE RE-ENTRY - INDEX = INDEX + 1 -C PRINT *,'RE-ENTRY LOOKING FOR SUBSET NR',INDEX - IF (INDEX.GT.IDENT(14)) THEN -C ALL SUBSETS PROCESSED - IPTR(1) = 99 - IPTR(39) = 0 - ELSE IF (INDEX.LE.IDENT(14)) THEN - IF (IPTR(39).NE.0) THEN - CALL FI7801(IPTR,IDENT,MSGA,ISTACK,IWORK,ANAME,KDATA, -C - * IVALS,MSTACK, - * AUNITS,KDESC,MWIDTH,MREF,MSCALE,KNR,INDEX,MAXR,MAXD, - * IUNITB,IUNITD) -C - END IF - END IF - RETURN - ELSE - INDEX = 1 -C PRINT *,'INITIAL ENTRY FOR THIS BUFR MESSAGE' - END IF - IPTR(39) = 0 -C FIND 'BUFR' IN FIRST 125 CHARACTERS - DO 1000 KNOFST = 0, 999, 8 - INOFST = KNOFST - CALL GBYTE (MSGA,IVALS,INOFST,8) - IF (IVALS(1).EQ.66) THEN - IPTR(19) = INOFST - INOFST = INOFST + 8 - CALL GBYTE (MSGA,IVALS,INOFST,24) - IF (IVALS(1).EQ.5588562) THEN -C PRINT *,'FOUND BUFR AT',IPTR(19) - INOFST = INOFST + 24 - GO TO 1500 - END IF - END IF - 1000 CONTINUE - PRINT *,'BUFR - START OF BUFR MESSAGE NOT FOUND' - IPTR(1) = 1 - RETURN - 1500 CONTINUE - IDENT(1) = 0 -C TEST FOR EDITION NUMBER -C ====================== - CALL GBYTE (MSGA,IDENT(1),INOFST+24,8) -C PRINT *,'THIS IS AN EDITION',IDENT(1),' BUFR MESSAGE' -C - IF (IDENT(1).GE.2) THEN -C GET TOTAL COUNT - CALL GBYTE (MSGA,IVALS,INOFST,24) - ITOTAL = IVALS(1) - KENDER = ITOTAL * 8 - 32 + IPTR(19) - CALL GBYTE (MSGA,ILAST,KENDER,32) -C IF (ILAST.EQ.926365495) THEN -C PRINT *,'HAVE TOTAL COUNT FROM SEC 0',IVALS(1) -C END IF - INOFST = INOFST + 32 -C GET SECTION 1 COUNT - IPTR(3) = INOFST - CALL GBYTE (MSGA,IVALS,INOFST,24) -C PRINT *,'SECTION 1 STARTS AT',INOFST,' SIZE',IVALS(1) - INOFST = INOFST + 24 - IPTR( 2) = IVALS(1) -C GET MASTER TABLE - CALL GBYTE (MSGA,IVALS,INOFST,8) - INOFST = INOFST + 8 - IDENT(17) = IVALS(1) -C PRINT *,'BUFR MASTER TABLE NR',IDENT(17) - ELSE - IPTR(3) = INOFST -C GET SECTION 1 COUNT - CALL GBYTE (MSGA,IVALS,INOFST,24) -C PRINT *,'SECTION 1 STARTS AT',INOFST,' SIZE',IVALS(1) - INOFST = INOFST + 32 - IPTR( 2) = IVALS(1) - END IF -C ====================== -C ORIGINATING CENTER - CALL GBYTE (MSGA,IVALS,INOFST,16) - INOFST = INOFST + 16 - IDENT(2) = IVALS(1) -C UPDATE SEQUENCE - CALL GBYTE (MSGA,IVALS,INOFST,8) - INOFST = INOFST + 8 - IDENT(3) = IVALS(1) -C OPTIONAL SECTION FLAG - CALL GBYTE (MSGA,IVALS,INOFST,1) - IDENT(4) = IVALS(1) - IF (IDENT(4).GT.0) THEN - SEC2 = .TRUE. - ELSE -C PRINT *,' NO OPTIONAL SECTION 2' - SEC2 = .FALSE. - END IF - INOFST = INOFST + 8 -C MESSAGE TYPE - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(5) = IVALS(1) - INOFST = INOFST + 8 -C MESSAGE SUB-TYPE - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(6) = IVALS(1) - INOFST = INOFST + 8 -C IF BUFR EDITION 0 OR 1 THEN -C NEXT 2 BYTES ARE BUFR TABLE VERSION -C ELSE -C BYTE 11 IS VER NR OF MASTER TABLE -C BYTE 12 IS VER NR OF LOCAL TABLE - IF (IDENT(1).LT.2) THEN - CALL GBYTE (MSGA,IVALS,INOFST,16) - IDENT(7) = IVALS(1) - INOFST = INOFST + 16 - ELSE -C BYTE 11 IS VER NR OF MASTER TABLE - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(18) = IVALS(1) - INOFST = INOFST + 8 -C BYTE 12 IS VER NR OF LOCAL TABLE - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(19) = IVALS(1) - INOFST = INOFST + 8 - - END IF -C YEAR OF CENTURY - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(8) = IVALS(1) - INOFST = INOFST + 8 -C MONTH - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(9) = IVALS(1) - INOFST = INOFST + 8 -C DAY -C PRINT *,'DAY AT ',INOFST - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(10) = IVALS(1) - INOFST = INOFST + 8 -C HOUR - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(11) = IVALS(1) - INOFST = INOFST + 8 -C MINUTE - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(12) = IVALS(1) -C RESET POINTER (INOFST) TO START OF -C NEXT SECTION -C (SECTION 2 OR SECTION 3) - INOFST = IPTR(3) + IPTR(2) * 8 - IPTR(4) = 0 - IPTR(5) = INOFST - IF (SEC2) THEN -C SECTION 2 COUNT - CALL GBYTE (MSGA,IPTR(4),INOFST,24) - INOFST = INOFST + 32 -C PRINT *,'SECTION 2 STARTS AT',INOFST,' BYTES=',IPTR(4) - KENTRY = (IPTR(4) - 4) / 14 -C PRINT *,'SHOULD BE A MAX OF',KENTRY,' REPORTS' - IF (IDENT(2).EQ.7) THEN - DO 2000 I = 1, KENTRY - CALL GBYTE (MSGA,KDSPL ,INOFST,16) - INOFST = INOFST + 16 - CALL GBYTE (MSGA,LAT ,INOFST,16) - INOFST = INOFST + 16 - CALL GBYTE (MSGA,LON ,INOFST,16) - INOFST = INOFST + 16 - CALL GBYTE (MSGA,KDAHR ,INOFST,16) - INOFST = INOFST + 16 - CALL GBYTE (MSGA,DIRID(1),INOFST,32) - INOFST = INOFST + 32 - CALL GBYTE (MSGA,DIRID(2),INOFST,16) - INOFST = INOFST + 16 -C PRINT *,KDSPL,LAT,LON,KDAHR,DIRID(1),DIRID(2) - 2000 CONTINUE - END IF -C RESET POINTER (INOFST) TO START OF -C SECTION 3 - INOFST = IPTR(5) + IPTR(4) * 8 - END IF -C BIT OFFSET TO START OF SECTION 3 - IPTR( 7) = INOFST -C SECTION 3 COUNT - CALL GBYTE (MSGA,IPTR(6),INOFST,24) -C PRINT *,'SECTION 3 STARTS AT',INOFST,' BYTES=',IPTR(6) - INOFST = INOFST + 24 -C SKIP RESERVED BYTE - INOFST = INOFST + 8 -C NUMBER OF DATA SUBSETS - CALL GBYTE (MSGA,IDENT(14),INOFST,16) -C - IF (IDENT(14).GT.MAXR) THEN - PRINT *,'THE NUMBER OF SUBSETS EXCEEDS THE MAXIMUM OF',MAXR - PRINT *,'PASSED INTO W3FI78; MAXR MUST BE INCREASED IN ' - PRINT *,'THE CALLING PROGRAM TO AT LEAST THE VALUE OF' - PRINT *,IDENT(14),'TO BE ABLE TO PROCESS THIS DATA' -C - IPTR(1) = 400 - RETURN - END IF - INOFST = INOFST + 16 -C OBSERVED DATA FLAG - CALL GBYTE (MSGA,IVALS,INOFST,1) - IDENT(15) = IVALS(1) - INOFST = INOFST + 1 -C COMPRESSED DATA FLAG - CALL GBYTE (MSGA,IVALS,INOFST,1) - IDENT(16) = IVALS(1) - INOFST = INOFST + 7 -C CALCULATE NUMBER OF DESCRIPTORS - NRDESC = (IPTR( 6) - 8) / 2 - IPTR(12) = NRDESC - IPTR(13) = NRDESC -C EXTRACT DESCRIPTORS - CALL GBYTES (MSGA,ISTACK,INOFST,16,0,NRDESC) -C PRINT *,'INITIAL DESCRIPTOR LIST OF',NRDESC,' DESCRIPTORS' - DO 10 L = 1, NRDESC - IWORK(L) = ISTACK(L) -C PRINT *,L,ISTACK(L) - 10 CONTINUE - IPTR(13) = NRDESC -C RESET POINTER TO START OF SECTION 4 - INOFST = IPTR(7) + IPTR(6) * 8 -C BIT OFFSET TO START OF SECTION 4 - IPTR( 9) = INOFST -C SECTION 4 COUNT - CALL GBYTE (MSGA,IVALS,INOFST,24) -C PRINT *,'SECTION 4 STARTS AT',INOFST,' VALUE',IVALS(1) - IPTR( 8) = IVALS(1) - INOFST = INOFST + 32 -C SET FOR STARTING BIT OF DATA - IPTR(25) = INOFST -C FIND OUT IF '7777' TERMINATOR IS THERE - INOFST = IPTR(9) + IPTR(8) * 8 - CALL GBYTE (MSGA,IVALS,INOFST,32) -C PRINT *,'SECTION 5 STARTS AT',INOFST,' VALUE',IVALS(1) - IF (IVALS(1).NE.926365495) THEN - PRINT *,'BAD SECTION COUNT' - IPTR(1) = 2 - RETURN - ELSE - IPTR(1) = 0 - END IF -C - CALL FI7801(IPTR,IDENT,MSGA,ISTACK,IWORK,ANAME,KDATA,IVALS,MSTACK, - * AUNITS,KDESC,MWIDTH,MREF,MSCALE,KNR,INDEX,MAXR,MAXD, - * IUNITB,IUNITD) -C -C PRINT *,'HAVE RETURNED FROM FI7801' -C IF (IPTR(1).NE.0) THEN -C RETURN -C END IF -C FURTHER PROCESSING REQUIRED FOR PROFILER DATA - IF (IDENT(5).EQ.2) THEN - IF (IDENT(6).EQ.7) THEN -C PRINT *,'BASIC PROFILER DATA' -C DO 153 I = 1, KNR(INDEX) -C PRINT *,I,MSTACK(1,I),MSTACK(2,I),KDATA(1,I),KDATA(2,I) -C 153 CONTINUE -C PRINT *,'REFORMAT PROFILER DATA' -C - IF (IDENT(1).LT.2) THEN - CALL FI7809(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD) - ELSE - CALL FI7810(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD) - END IF -C DO 151 I = 1, 40 -C IF (I.LE.20) THEN -C PRINT *,'IPTR(',I,')=',IPTR(I), -C * ' IDENT(',I,')= ',IDENT(I) -C ELSE -C PRINT *,'IPTR(',I,')=',IPTR(I) -C END IF -C 151 CONTINUE - IF (IPTR(1).NE.0) THEN - RETURN - END IF -C -C DO 154 I = 1, IPTR(31) -C PRINT *,I,MSTACK(1,I),MSTACK(2,I),KDATA(1,I),KDATA(2,I) -C 154 CONTINUE - END IF - END IF - RETURN - END - SUBROUTINE FI7801(IPTR,IDENT,MSGA,ISTACK,IWORK,ANAME,KDATA,IVALS, - * MSTACK,AUNITS,KDESC,MWIDTH,MREF,MSCALE,KNR,INDEX,MAXR,MAXD, - * IUNITB,IUNITD) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI7801 DATA EXTRACTION -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01 -C -C ABSTRACT: CONTROL THE EXTRACTION OF DATA FROM SECTION 4 BASED ON -C DATA DESCRIPTORS. -C -C PROGRAM HISTORY LOG: -C 88-09-01 CAVANAUGH -C 91-01-18 CAVANAUGH CORRECTIONS TO PROPERLY HANDLE NON-COMPRESSED -C DATA. -C 91-09-23 CAVANAUGH CODING ADDED TO HANDLE SINGLE SUBSETS WITH -C DELAYED REPLICATION. -C 92-01-24 CAVANAUGH MODIFIED TO ECHO DESCRIPTORS TO MSTACK(1,N) -C -C USAGE: CALL FI7801(IPTR,IDENT,MSGA,ISTACK,IWORK,ANAME,KDATA, -C * MSTACK,AUNITS,KDESC,MWIDTH,MREF,MSCALE,KNR,INDEX,MAXR,MAXD, -C * IUNITB,IUNITD) -C -C INPUT ARGUMENT LIST: -C IPTR - SEE W3FI78 ROUTINE DOCBLOCK -C IDENT - SEE W3FI78 ROUTINE DOCBLOCK -C MSGA - ARRAY CONTAINING BUFR MESSAGE -C ISTACK - ORIGINAL ARRAY OF DESCRIPTORS EXTRACTED FROM -C SOURCE BUFR MESSAGE. -C MSTACK - WORKING ARRAY OF DESCRIPTORS (EXPANDED)AND SCALING -C FACTOR -C KDESC - IMAGE OF CURRENT DESCRIPTOR -C INDEX - -C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE -C CONTAINED IN A BUFR MESSAGE -C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT -C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE -C DATA REQUIRE A VALUE FOR MAXD OF 1600, BUT FOR MOST -C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE -C IUNITB - UNIT NUMBER OF DATA SET HOLDING TABLE B -C IUNITD - UNIT NUMBER OF DATA SET HOLDING TABLE D -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C IWORK - WORKING DESCRIPTOR LIST -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C -C ISTACK - SEE ABOVE -C ARRAYS CONTAINING DATA FROM TABLE B -C KDESC - SEE ABOVE -C ANAME - DESCRIPTOR NAME -C AUNITS - UNITS FOR DESCRIPTOR -C MSCALE - SCALE FOR VALUE OF DESCRIPTOR -C MREF - REFERENCE VALUE FOR DESCRIPTOR -C MWIDTH - BIT WIDTH FOR VALUE OF DESCRIPTOR -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - FI7802 FI7805 FI7806 FI7807 FI7808 -C -C REMARKS: ERROR RETURN: -C IPTR(1) = 8 ERROR READING TABLE B -C = 9 ERROR READING TABLE D -C = 11 ERROR OPENING TABLE B -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN 77 -C MACHINE: CRAY Y-MP8/832 -C -C$$$ - SAVE -C - CHARACTER*40 ANAME(*) - CHARACTER*24 AUNITS(*) -C -C - INTEGER MSGA(*),KDATA(MAXR,MAXD),IVALS(*) -C - INTEGER MSCALE(*),KNR(MAXR) - INTEGER LX,LY,LL,J - INTEGER MREF(700,3) - INTEGER MWIDTH(*) - INTEGER IHOLD(33) - INTEGER ITBLD(500,11) - INTEGER IPTR(*) - INTEGER IDENT(*) - INTEGER KDESC(*) - INTEGER ISTACK(*),IWORK(*) -C - INTEGER MSTACK(2,MAXD),KK -C - INTEGER JDESC - INTEGER INDEX - INTEGER ITEST(30) -C - DATA ITEST /1,3,7,15,31,63,127,255, - * 511,1023,2047,4095,8191,16383, - * 32767, 65535,131071,262143,524287, - * 1048575,2097151,4194303,8388607, - * 16777215,33554431,67108863,134217727, - * 268435455,536870911,1073741823/ -C -C PRINT *,' DECOLL FI7801' - IF (INDEX.GT.1) THEN - GO TO 1000 - END IF -C --------- DECOLL --------------- - IPTR(23) = 0 - IPTR(26) = 0 - IPTR(27) = 0 - IPTR(28) = 0 - IPTR(29) = 0 - IPTR(30) = 0 - IPTR(36) = 0 -C INITIALIZE OUTPUT AREA -C SET POINTER TO BEGINNING OF DATA -C SET BIT - IPTR(17) = 1 - 1000 CONTINUE -C IPTR(12) = IPTR(13) - LL = 0 - IPTR(11) = 1 - IF (IPTR(10).EQ.0) THEN -C RE-ENTRY POINT FOR MULTIPLE -C NON-COMPRESSED REPORTS - ELSE - INDEX = IPTR(15) - IPTR(17) = INDEX - IPTR(25) = IPTR(10) - IPTR(10) = 0 - IPTR(15) = 0 - END IF -C PRINT *,'FI7801 - RPT',IPTR(17),' STARTS AT',IPTR(25) - IPTR(24) = 0 - IPTR(31) = 0 -C POINTING AT NEXT AVAILABLE DESCRIPTOR - MM = 0 - IF (IPTR(21).EQ.0) THEN -C PRINT *,' READING TABLE B' - DO 150 I = 1, 700 - IPTR(21) = I -C - READ(UNIT=IUNITB,FMT=20,ERR=9999,END=175)MF, - * MX,MY, - * (ANAME(I)(K:K),K=1,40), - * (AUNITS(I)(K:K),K=1,24), - * MSCALE(I),MREF(I,1),MWIDTH(I) - 20 FORMAT(I1,I2,I3,40A1,24A1,I5,I15,1X,I4) - IF (MWIDTH(I).EQ.0) THEN - IPTR(1) = 29 - RETURN - END IF - MREF(I,2) = 0 - IPTR(14) = I - KDESC(I) = MF*16384 + MX*256 + MY -C PRINT *,I -C WRITE(6,21) MF,MX,MY,KDESC(I), -C * (ANAME(I)(K:K),K=1,40), -C * (AUNITS(I)(K:K),K=1,24), -C * MSCALE(I),MREF(I,1),MWIDTH(I) - 21 FORMAT(1X,I1,I2,I3,1X,I6,1X,40A1, - * 2X,24A1,2X,I5,2X,I15,1X,I4) - 150 CONTINUE - PRINT *,'HAVE READ LIMIT OF 700 TABLE B DESCRIPTORS' - PRINT *,'IF THERE ARE MORE THAT THAT, CORRECT READ LOOP' - 175 CONTINUE -C -C CLOSE(UNIT=IUNITB,STATUS='KEEP') -C - IPTR(21) = 1 - END IF -C DO WHILE MM <= MAXD - 10 CONTINUE -C PROCESS THRU THE FOLLOWING -C DEPENDING UPON THE VALUE OF 'F' (LF) - MM = MM + 1 - 12 CONTINUE - IF (MM.GT.MAXD) THEN - GO TO 200 - END IF -C END OF CYCLE TEST (SERIAL/SEQUENTIAL) - IF (IPTR(11).GT.IPTR(12)) THEN -C PRINT *,' HAVE COMPLETED REPORT SEQUENCE' - IF (IDENT(16).NE.0) THEN -C PRINT *,' PROCESSING COMPRESSED REPORTS' -C REFORMAT DATA FROM DESCRIPTOR -C FORM TO USER FORM - RETURN - ELSE -C WRITE (6,1) -C 1 FORMAT (1H1) -C PRINT *,' PROCESSED SERIAL REPORT',IPTR(17),IPTR(25) - IPTR(17) = IPTR(17) + 1 - IF (IPTR(17).GT.IDENT(14)) THEN - IPTR(17) = IPTR(17) - 1 - GO TO 200 - END IF - DO 300 I = 1, IPTR(13) - IWORK(I) = ISTACK(I) - 300 CONTINUE -C RESET POINTERS - LL = 0 - IPTR(1) = 0 - IPTR(11) = 1 - IPTR(12) = IPTR(13) -C IS THIS LAST REPORT ? -C PRINT *,'READY',IPTR(39),INDEX - IF (IPTR(39).GT.0) THEN - IF (INDEX.GT.0) THEN -C PRINT *,'HERE IS SUBSET NR',INDEX - RETURN - END IF - END IF - GO TO 1000 - END IF - END IF - 14 CONTINUE -C GET NEXT DESCRIPTOR - CALL FI7808 (IPTR,IWORK,LF,LX,LY,JDESC,MAXD) -C PRINT *,IPTR(11)-1,'JDESC= ',JDESC,' AND NEXT ', -C * IPTR(11),IWORK(IPTR(11)),IPTR(31) -C PRINT *,IPTR(11)-1,'DESCRIPTOR',JDESC,LF,LX,LY, -C * ' FOR LOC',IPTR(17),IPTR(25) - IF (IPTR(11).GT.1600) THEN - IPTR(1) = 401 - RETURN - END IF -C - KPRM = IPTR(31) + IPTR(24) - IF (KPRM.GT.1600) THEN - IF (KPRM.GT.KOLD) THEN - PRINT *,'EXCEEDED ARRAY SIZE',KPRM,IPTR(31), - * IPTR(24) - KOLD = KPRM - END IF - END IF -C REPLICATION PROCESSING - IF (LF.EQ.1) THEN -C ---------- F1 --------- - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - KDATA(IPTR(17),KPRM) = 0 -C PRINT *,'FI7801-1',KPRM,MSTACK(1,KPRM), -C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM) - CALL FI7805(IPTR,IDENT,MSGA,IWORK,LX,LY, - * KDATA,LL,KNR,MSTACK,MAXR,MAXD) - IF (IPTR(1).NE.0) THEN - RETURN - ELSE - GO TO 12 - END IF -C -C DATA DESCRIPTION OPERATORS - ELSE IF (LF.EQ.2)THEN - IF (LX.EQ.5) THEN - ELSE IF (LX.EQ.4) THEN - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - KDATA(IPTR(17),KPRM) = 0 -C PRINT *,'FI7801-2',KPRM,MSTACK(1,KPRM), -C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM) - END IF - CALL FI7806 (IPTR,LX,LY,IDENT,MSGA,KDATA,IVALS,MSTACK, - * MWIDTH,MREF,MSCALE,J,LL,KDESC,IWORK,JDESC,MAXR,MAXD) - IF (IPTR(1).NE.0) THEN - RETURN - END IF - GO TO 12 -C DESCRIPTOR SEQUENCE STRINGS - ELSE IF (LF.EQ.3) THEN -C PRINT *,'F3 SEQUENCE DESCRIPTOR' - IF (IPTR(22).EQ.0) THEN -C READ IN TABLE D, BUT JUST ONCE - IERR = 0 -C PRINT *,' READING TABLE D' - DO 50 I = 1, 500 - READ(IUNITD,15,ERR=9998,END=75 ) - * (IHOLD(J),J=1,33) - 15 FORMAT(11(I1,I2,I3,1X),3X) - IPTR(20) = I - DO 25 JJ = 1, 31, 3 - KK = (JJ/3) + 1 - ITBLD(I,KK) = IHOLD(JJ)*16384 + - * IHOLD(JJ+1)*256 + IHOLD(JJ+2) - IF (ITBLD(I,KK).EQ.0) THEN -C PRINT 16,(ITBLD(I,L),L=1,11) - GO TO 50 - END IF - 25 CONTINUE -C PRINT 16,(ITBLD(I,L),L=1,11) - 50 CONTINUE - 16 FORMAT(1X,11(I6,1X)) - 75 CONTINUE - CLOSE(UNIT=IUNITD,STATUS='KEEP') - IPTR(22) = 1 - ENDIF - CALL FI7807(IPTR,IWORK,ITBLD,JDESC,MAXD) - IF (IPTR(1).GT.0) THEN - RETURN - END IF - GO TO 14 -C -C STANDARD DESCRIPTOR PROCESSING - ELSE -C PRINT *,'ENTRY',IPTR(31),JDESC,' AT',IPTR(25) - KPRM = IPTR(31) + IPTR(24) - CALL FI7802(IPTR,IDENT,MSGA,KDATA,KDESC,LL,MSTACK, - * AUNITS,MWIDTH,MREF,MSCALE,JDESC,IVALS,J,MAXR,MAXD) -C TURN OFF SKIP FLAG AFTER STD DESCRIPTOR - IPTR(36) = 0 - IF (IPTR(1).GT.0) THEN - RETURN - ELSE - IF (IDENT(16).EQ.0) THEN - KNR(IPTR(17)) = IPTR(31) - ELSE - DO 310 KJ = 1, MAXR - KNR(KJ) = IPTR(31) - 310 CONTINUE - END IF - GO TO 10 - END IF - END IF -C END IF -C END DO WHILE - 200 CONTINUE - IF (IDENT(16).NE.0) THEN -C PRINT *,'RETURN WITH',IDENT(14),' COMPRESSED REPORTS' - ELSE -C PRINT *,'RETURN WITH',IPTR(17),' NON-COMPRESSED REPORTS' - END IF - RETURN - 9998 CONTINUE - PRINT *,' ERROR READING TABLE D' - IPTR(1) = 8 - RETURN - 9999 CONTINUE - PRINT *,' ERROR READING TABLE B' - IPTR(1) = 9 - RETURN - END -C ----------------------------------------------------- - SUBROUTINE FI7802(IPTR,IDENT,MSGA,KDATA,KDESC,LL,MSTACK,AUNITS, - * MWIDTH,MREF,MSCALE,JDESC,IVALS,J,MAXR,MAXD) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI7802 PROCESS STANDARD DESCRIPTOR -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01 -C -C ABSTRACT: PROCESS A STANDARD DESCRIPTOR (F = 0) AND STORE DATA -C IN OUTPUT ARRAY. -C -C PROGRAM HISTORY LOG: -C 88-09-01 CAVANAUGH -C 91-04-04 CAVANAUGH CHANGED TO PASS WIDTH OF TEXT FIELDS IN BYTES -C -C USAGE: CALL FI7802(IPTR,IDENT,MSGA,KDATA,KDESC,LL,MSTACK,AUNITS, -C MWIDTH,MREF,MSCALE,JDESC,IVALS,J,MAXR,MAXD) -C INPUT ARGUMENT LIST: -C IPTR - SEE W3FI78 ROUTINE DOCBLOCK -C IDENT - SEE W3FI78 ROUTINE DOCBLOCK -C MSGA - ARRAY CONTAINING BUFR MESSAGE -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C KDESC - IMAGE OF CURRENT DESCRIPTOR -C ANAME - LIST OF NAME OF DESCRIPTOR CONTENTS -C MSTACK - -C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE -C CONTAINED IN A BUFR MESSAGE -C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT -C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE -C DATA REQUIRE A VALUE FOR MAXD OF 1600, BUT FOR MOST -C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KDATA - SEE ABOVE -C KDESC - SEE ABOVE -C ARRAYS CONTAINING DATA FROM TABLE B -C AUNITS - UNITS FOR DESCRIPTOR -C MSCALE - SCALE FOR VALUE OF DESCRIPTOR -C MREF - REFERENCE VALUE FOR DESCRIPTOR -C MWIDTH - BIT WIDTH FOR VALUE OF DESCRIPTOR -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - FI7803 FI7804 -C -C REMARKS: ERROR RETURN: -C IPTR(1) = 3 - MESSAGE CONTAINS A DESCRIPTOR WITH F=0 -C THAT DOES NOT EXIST IN TABLE B. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN 77 -C MACHINE: CRAY Y-MP8/832 -C -C$$$ - SAVE -C TABLE B ENTRY - CHARACTER*24 ASKEY - CHARACTER*24 AUNITS(*) -C TABLE B ENTRY - INTEGER MSGA(*) - INTEGER IPTR(*) - INTEGER IDENT(*) - INTEGER J - INTEGER JDESC - INTEGER KDESC(*) - INTEGER MWIDTH(*),MSTACK(2,MAXD),MSCALE(*) - INTEGER MREF(700,3),KDATA(MAXR,MAXD),IVALS(*) -C TABLE B ENTRY -C - DATA ASKEY /'CCITT IA5 '/ -C -C PRINT *,' FI7802 - STANDARD DESCRIPTOR PROCESSOR' -C GET A MATCH BETWEEN CURRENT -C DESCRIPTOR (JDESC) AND -C TABLE B ENTRY -C IF (KDESC(356).EQ.0) THEN -C PRINT *,'FI7802 - KDESC(356) WENT TO ZER0' -C IPTR(1) = 600 -C RETURN -C END IF - K = 1 - KK = IPTR(14) - IF (JDESC.GT.KDESC(KK)) THEN - K = KK + 1 - END IF - 10 CONTINUE - IF (K.GT.KK) THEN - IF (IPTR(36).NE.0) THEN -C HAVE SKIP FLAG - IF (IDENT(16).NE.0) THEN -C SKIP OVER COMPRESSED DATA -C LOWEST - IPTR(25) = IPTR(25) + IPTR(36) -C NBINC - CALL GBYTE (MSGA,IHOLD,IPTR(25),6) - IPTR(25) = IPTR(25) + 6 - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - DO 50 I = 1, IPTR(14) - KDATA(I,KPRM) = 99999 - 50 CONTINUE -C PROCESS DIFFERENCES - IF (IHOLD.NE.0) THEN - IBITS = IHOLD * IDENT(14) - IPTR(25) = IPTR(25) + IBITS - END IF - ELSE - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - KDATA(IPTR(17),KPRM) = 99999 -C SKIP OVER NON-COMPRESSED DATA -C PRINT *,'SKIP NON-COMPRESSED DATA' - IPTR(25) = IPTR(25) + IPTR(36) - END IF - RETURN - ELSE - PRINT *,'FI7802 - ERROR = 3' - PRINT *,JDESC,K,KK,J,KDESC(J) - PRINT *,' ' - PRINT *,'TABLE B' -C DO 20 LL = 1, IPTR(14) -C PRINT *,LL,KDESC(LL) -C 20 CONTINUE - IPTR(1) = 3 - RETURN - END IF - ELSE - J = ((KK - K) / 2) + K - END IF - IF (JDESC.EQ.KDESC(K)) THEN - J = K - GO TO 15 - ELSE IF (JDESC.EQ.KDESC(KK))THEN - J = KK - GO TO 15 - ELSE IF (JDESC.LT.KDESC(J)) THEN - K = K + 1 - KK = J - 1 - GO TO 10 - ELSE IF (JDESC.GT.KDESC(J)) THEN - K = J + 1 - KK = KK - 1 - GO TO 10 - END IF - 15 CONTINUE -C HAVE A MATCH -C SET FLAG IF TEXT EVENT - IF (ASKEY(1:9).EQ.AUNITS(J)(1:9)) THEN - IPTR(18) = 1 - IPTR(40) = MWIDTH(J) / 8 - ELSE - IPTR(18) = 0 - END IF - IF (IDENT(16).NE.0) THEN -C COMPRESSED - CALL FI7803(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK, - * MWIDTH,MREF,MSCALE,J,JDESC,MAXR,MAXD) - IF (IPTR(1).NE.0) THEN - RETURN - END IF - ELSE -C NOT COMPRESSED - CALL FI7804(IPTR,MSGA,KDATA,IVALS,MSTACK, - * MWIDTH,MREF,MSCALE,J,LL,JDESC,MAXR,MAXD) - END IF - RETURN - END -C ----------------------------------------------------- - SUBROUTINE FI7803(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK, - * MWIDTH,MREF,MSCALE,J,JDESC,MAXR,MAXD) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI7803 PROCESS COMPRESSED DATA -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01 -C -C ABSTRACT: PROCESS COMPRESSED DATA AND PLACE INDIVIDUAL ELEMENTS -C INTO OUTPUT ARRAY. -C -C PROGRAM HISTORY LOG: -C 88-09-01 CAVANAUGH -C 91-04-04 CAVANAUGH TEXT HANDLING PORTION OF THIS ROUTINE -C MODIFIED TO HANLE WIDTH OF FIELDS IN BYTES. -C 91-04-17 CAVANAUGH TESTS SHOWED THAT THE SAME DATA IN COMPRESSED -C AND UNCOMPRESSED FORM GAVE DIFFERENT RESULTS. -C THIS HAS BEEN CORRECTED. -C 91-06-21 CAVANAUGH PROCESSING OF TEXT DATA HAS BEEN CHANGED TO -C PROVIDE EXACT REPRODUCTION OF ALL CHARACTERS. -C -C USAGE: CALL FI7803(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK, -C MWIDTH,MREF,MSCALE,J,JDESC,MAXR,MAXD) -C INPUT ARGUMENT LIST: -C IPTR - SEE W3FI78 ROUTINE DOCBLOCK -C IDENT - SEE W3FI78 ROUTINE DOCBLOCK -C MSGA - ARRAY CONTAINING BUFR MESSAGE,MSTACK, -C IVALS - ARRAY OF SINGLE PARAMETER VALUES -C J - -C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE -C CONTAINED IN A BUFR MESSAGE -C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT -C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE -C DATA REQUIRE A VALUE FOR MAXD OF 1600, BUT FOR MOST -C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C J - -C ARRAYS CONTAINING DATA FROM TABLE B -C MSCALE - SCALE FOR VALUE OF DESCRIPTOR -C MREF - REFERENCE VALUE FOR DESCRIPTOR -C MWIDTH - BIT WIDTH FOR VALUE OF DESCRIPTOR -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - GBYTE GBYTES -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN 77 -C MACHINE: CRAY Y-MP8/832 -C -C$$$ - SAVE -C - INTEGER MSGA(*),JDESC,MSTACK(2,MAXD) - INTEGER IPTR(*),IVALS(*),KDATA(MAXR,MAXD) - INTEGER NRVALS,JWIDE,IDATA - INTEGER IDENT(*) - INTEGER MSCALE(*) - INTEGER MREF(700,3) - INTEGER J - INTEGER MWIDTH(*) - INTEGER KLOW(256) -C - LOGICAL TEXT -C - INTEGER MSK(28) -C -C - DATA MSK /1,3,7,15,31,63,127, -C 1 2 3 4 5 6 7 - * 255,511,1023,2047,4095, -C 8 9 10 11 12 - * 8191,16383,32767,65535, -C 13 14 15 16 - * 131071,262143,524287, -C 17 18 19 - * 1048575,2097151,4194303, -C 20 21 22 - * 8388607,16777215,33554431, -C 23 24 25 - * 67108863,134217727,268435455/ -C 26 27 28 -C -C PRINT *,' FI7803 COMPR J=',J,' MWIDTH(J) =',MWIDTH(J), -C * ' EXTRA BITS =',IPTR(26),' START AT',IPTR(25) - IF (IPTR(18).EQ.0) THEN - TEXT = .FALSE. - ELSE - TEXT = .TRUE. - END IF -C PRINT *,'DESCRIPTOR',KPRM - IF (.NOT.TEXT) THEN - IF (IPTR(29).GT.0) THEN -C WORKING WITH ASSOCIATED FIELDS HERE - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) -C GET LOWEST - CALL GBYTE (MSGA,LOWEST,IPTR(25),IPTR(29)) - IPTR(25) = IPTR(25) + IPTR(29) -C GET NBINC - CALL GBYTE (MSGA,NBINC,IPTR(25),6) - IPTR(25) = IPTR(25) + 6 -C EXTRACT DATA FOR ASSOCIATED FIELD - IF (NBINC.GT.0) THEN - CALL GBYTES (MSGA,IVALS,IPTR(25),NBINC,0,IPTR(14)) - IPTR(25) = IPTR(25) + NBINC * IPTR(14) - DO 50 I = 1, IPTR(14) - KDATA(I,KPRM) = IVALS(I) + LOWEST - IF (KDATA(I,KPRM).GE.MSK(NBINC)) THEN - KDATA(I,KPRM) = 999999 - END IF - 50 CONTINUE - ELSE - DO 51 I = 1, IPTR(14) - IF (LOWEST.GE.MSK(NBINC)) THEN - KDATA(I,KPRM) = 999999 - ELSE - KDATA(I,KPRM) = LOWEST - END IF - 51 CONTINUE - END IF - END IF -C SET PARAMETER -C ISOLATE STANDARD BIT WIDTH - JWIDE = MWIDTH(J) + IPTR(26) -C SINGLE VALUE FOR LOWEST - NRVALS = 1 -C LOWEST -C PRINT *,'PARAM',KPRM - CALL GBYTE (MSGA,LOWEST,IPTR(25),JWIDE) -C PRINT *,' LOWEST=',LOWEST,' AT BIT LOC ',IPTR(25) - IPTR(25) = IPTR(25) + JWIDE -C ISOLATE COMPRESSED BIT WIDTH - CALL GBYTE (MSGA,NBINC,IPTR(25),6) -C PRINT *,' NBINC=',NBINC,' AT BIT LOC',IPTR(25) - IF (IPTR(32).EQ.2.AND.IPTR(33).EQ.5) THEN - ELSE - IF (NBINC.GT.JWIDE) THEN -C PRINT *,'FOR DESCRIPTOR',JDESC -C PRINT *,J,'NBINC=',NBINC,' LOWEST=',LOWEST,' MWIDTH(J)=', -C * MWIDTH(J),' IPTR(26)=',IPTR(26),' AT BIT LOC',IPTR(25) -C DO 110 I = 1, KPRM -C WRITE (6,111)I,(KDATA(J,I),J=1,6) -C 110 CONTINUE - 111 FORMAT (1X,5HDATA ,I3,6(2X,I10)) - IPTR(1) = 500 -C RETURN - PRINT *,'NBINC CALLS FOR LARGER BIT WIDTH THAN TABLE', - * ' B PLUS WIDTH CHANGES' - END IF - END IF - IPTR(25) = IPTR(25) + 6 -C PRINT *,'LOWEST',LOWEST,' NBINC=',NBINC -C IF TEXT EVENT, PROCESS TEXT -C GET COMPRESSED VALUES -C PRINT *,'COMPRESSED VALUES - NONTEXT' - NRVALS = IDENT(14) - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - IF (NBINC.NE.0) THEN - CALL GBYTES (MSGA,IVALS,IPTR(25),NBINC,0,NRVALS) - IPTR(25) = IPTR(25) + NBINC * NRVALS -C RECALCULATE TO ORIGINAL VALUES - DO 100 I = 1, NRVALS -C PRINT *,IVALS(I),MSK(NBINC),NBINC - IF (IVALS(I).GE.MSK(NBINC)) THEN - KDATA(I,KPRM) = 999999 - ELSE - IF (MREF(J,2).EQ.0) THEN - KDATA(I,KPRM) = IVALS(I) + LOWEST + MREF(J,1) - ELSE - KDATA(I,KPRM) = IVALS(I) + LOWEST + MREF(J,3) - END IF - END IF - 100 CONTINUE -C PRINT *,I,JDESC,LOWEST,MREF(J,1),MREF(J,3) - ELSE - IF (LOWEST.EQ.MSK(MWIDTH(J))) THEN - DO 105 I = 1, NRVALS - KDATA(I,KPRM) = 999999 - 105 CONTINUE - ELSE - IF (MREF(J,2).EQ.0) THEN - ICOMB = LOWEST + MREF(J,1) - ELSE - ICOMB = LOWEST + MREF(J,3) - END IF - DO 106 I = 1, NRVALS - KDATA(I,KPRM) = ICOMB - 106 CONTINUE - END IF - END IF -C PRINT *,'KPRM=',KPRM,' IPTR(25)=',IPTR(25) - MSTACK(1,KPRM) = JDESC - IF (IPTR(27).NE.0) THEN - MSTACK(2,KPRM) = IPTR(27) - ELSE - MSTACK(2,KPRM) = MSCALE(J) - END IF -C WRITE (6,80) (DATA(I,KPRM),I=1,10) -C 80 FORMAT(2X,10(F10.2,1X)) - ELSE IF (TEXT) THEN -C PRINT *,' FOUND TEXT MODE IN COMPRESSED DATA',IPTR(40) -C GET LOWEST -C PRINT *,' PICKED UP LOWEST',(KLOW(K),K=1,IPTR(40)) - DO 1906 K = 1, IPTR(40) - CALL GBYTE (MSGA,KLOW,IPTR(25),8) - IPTR(25) = IPTR(25) + 8 - IF (KLOW(K).NE.0) THEN - IPTR(1) = 27 - PRINT *,'NON-ZERO LOWEST ON TEXT DATA' - RETURN - END IF - 1906 CONTINUE -C GET NBINC - CALL GBYTE (MSGA,NBINC,IPTR(25),6) -C PRINT *,'NBINC =',NBINC - IPTR(25) = IPTR(25) + 6 - IF (NBINC.NE.IPTR(40)) THEN - IPTR(1) = 28 - PRINT *,'NBINC IS NOT THE NUMBER OF CHARACTERS',NBINC - RETURN - END IF -C FOR NUMBER OF OBSERVATIONS - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - ISTART = KPRM - I24 = IPTR(24) - DO 1900 N = 1, IDENT(14) - KPRM = ISTART - IPTR(24) = I24 - NBITS = IPTR(40) * 8 - 1700 CONTINUE -C PRINT *,N,IDENT(14),'KPRM-B=',KPRM,IPTR(24),NBITS - IF (NBITS.GT.32) THEN - CALL GBYTE (MSGA,IDATA,IPTR(25),32) - IPTR(25) = IPTR(25) + 32 - NBITS = NBITS - 32 -C CONVERTS ASCII TO EBCIDIC -C COMMENT OUT IF NOT IBM370 COMPUTER -C PRINT *,IDATA -C CALL W3AI39 (IDATA,4) - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - KDATA(N,KPRM) = IDATA -C SET FOR NEXT PART - KPRM = KPRM + 1 - IPTR(24) = IPTR(24) + 1 -C PRINT 1701,1,KDATA(N,KPRM),N,KPRM,NBITS,IDATA - 1701 FORMAT (1X,I1,1X,6HKDATA=,A4,2X,I5,2X,I5,2X,I5,2X,I12) - GO TO 1700 - ELSE IF (NBITS.GT.0) THEN - CALL GBYTE (MSGA,IDATA,IPTR(25),NBITS) - IPTR(25) = IPTR(25) + NBITS - IBUF = (32 - NBITS) / 8 - IF (IBUF.GT.0) THEN - DO 1750 MP = 1, IBUF - IDATA = IDATA * 256 + 32 - 1750 CONTINUE - END IF -C CONVERTS ASCII TO EBCIDIC -C COMMENT OUT IF NOT IBM370 COMPUTER -C CALL W3AI39 (IDATA,4) - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - KDATA(N,KPRM) = IDATA -C PRINT 1701,2,KDATA(N,KPRM),N,KPRM,NBITS - NBITS = 0 - END IF -C WRITE (6,1800)N,(KDATA(N,I),I=KPRS,KPRM) -C1800 FORMAT (2X,I4,2X,3A4) - 1900 CONTINUE - END IF - RETURN - END -C ----------------------------------------------------- - SUBROUTINE FI7804(IPTR,MSGA,KDATA,IVALS,MSTACK, - * MWIDTH,MREF,MSCALE,J,LL,JDESC,MAXR,MAXD) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI7804 PROCESS SERIAL DATA -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01 -C -C ABSTRACT: PROCESS DATA THAT IS NOT COMPRESSED -C -C PROGRAM HISTORY LOG: -C 88-09-01 CAVANAUGH -C 91-01-18 CAVANAUGH MODIFIED TO PROPERLY HANDLE NON-COMPRESSED -C DATA. -C 91-04-04 CAVANAUGH TEXT HANDLING PORTION OF THIS ROUTINE -C MODIFIED TO HANDLE FIELD WIDTH IN BYTES. -C 91-04-17 CAVANAUGH TESTS SHOWED THAT THE SAME DATA IN COMPRESSED -C AND UNCOMPRESSED FORM GAVE DIFFERENT RESULTS. -C THIS HAS BEEN CORRECTED. -C -C USAGE: CALL FI7804(IPTR,MSGA,KDATA,IVALS,MSTACK, -C MWIDTH,MREF,MSCALE,J,LL,JDESC,MAXR,MAXD) -C INPUT ARGUMENT LIST: -C IPTR - SEE W3FI78 ROUTINE DOCBLOCK -C MSGA - ARRAY CONTAINING BUFR MESSAGE -C IVALS - ARRAY OF SINGLE PARAMETER VALUES -C J - -C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE -C CONTAINED IN A BUFR MESSAGE -C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT -C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE -C DATA REQUIRE A VALUE FOR MAXD OF 1600, BUT FOR MOST -C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C IVALS - SEE ABOVE -C J - SEE ABOVE -C ARRAYS CONTAINING DATA FROM TABLE B -C MSCALE - SCALE FOR VALUE OF DESCRIPTOR -C MREF - REFERENCE VALUE FOR DESCRIPTOR -C MWIDTH - BIT WIDTH FOR VALUE OF DESCRIPTOR -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - GBYTE -C -C REMARKS: ERROR RETURN: -C IPTR(1) = 13 - BIT WIDTH ON ASCII CHARS NOT A MULTIPLE OF 8 -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN 77 -C MACHINE: CRAY Y-MP8/832 -C -C$$$ - SAVE -C - INTEGER MSGA(*) - INTEGER IPTR(*),MREF(700,3),MSCALE(*) - INTEGER MWIDTH(*),JDESC - INTEGER IVALS(*) - INTEGER LSTBLK(3) - INTEGER KDATA(MAXR,MAXD),MSTACK(2,MAXD) - INTEGER J,LL - LOGICAL LKEY -C -C - INTEGER ITEST(30) - DATA ITEST /1,3,7,15,31,63,127,255, - * 511,1023,2047,4095,8191,16383, - * 32767, 65535,131071,262143,524287, - * 1048575,2097151,4194303,8388607, - * 16777215,33554431,67108863,134217727, - * 268435455,536870911,1073741823/ -C -C PRINT *,' FI7804 NOCMP',J,JDESC,MWIDTH(J),IPTR(26),IPTR(25) - IF ((IPTR(26)+MWIDTH(J)).LT.1) THEN - IPTR(1) = 501 - RETURN - END IF -C -------- NOCMP -------- -C ISOLATE BIT WIDTH - JWIDE = MWIDTH(J) + IPTR(26) -C IF NOT TEXT EVENT, PROCESS - IF (IPTR(18).NE.1) THEN -C IF ASSOCIATED FIELD SW ON - IF (IPTR(29).GT.0) THEN - IF (JDESC.NE.7957.AND.JDESC.NE.7937) THEN - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = 33792 + IPTR(29) - MSTACK(2,KPRM) = 0 - CALL GBYTE (MSGA,IVALS,IPTR(25),IPTR(29)) - IPTR(25) = IPTR(25) + IPTR(29) - KDATA(IPTR(17),KPRM) = IVALS(1) -C PRINT *,'FI7804-A',KPRM,MSTACK(1,KPRM), -C * MSTACK(2,KPRM),IPTR(17),KDATA(IPTR(17),KPRM) - END IF - END IF - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = JDESC - IF (IPTR(27).NE.0) THEN - MSTACK(2,KPRM) = IPTR(27) - ELSE - MSTACK(2,KPRM) = MSCALE(J) - END IF -C GET VALUES -C CALL TO GET DATA OF GIVEN BIT WIDTH - CALL GBYTE (MSGA,IVALS,IPTR(25),JWIDE) -C PRINT *,'DATA TO',IPTR(17),KPRM,IVALS(1),JWIDE,IPTR(25) - IPTR(25) = IPTR(25) + JWIDE -C RETURN WITH SINGLE VALUE - IF (IVALS(1).EQ.ITEST(JWIDE)) THEN - KDATA(IPTR(17),KPRM) = 999999 - ELSE - IF (MREF(J,2).EQ.0) THEN - KDATA(IPTR(17),KPRM) = IVALS(1) + MREF(J,1) - ELSE - KDATA(IPTR(17),KPRM) = IVALS(1) + MREF(J,3) - END IF - END IF -C PRINT *,'FI7804-B',KPRM,MSTACK(1,KPRM), -C * MSTACK(2,KPRM),IPTR(17),KDATA(IPTR(17),KPRM) -C IF(JDESC.EQ.2049) THEN -C PRINT *,'VERT SIG =',KDATA(IPTR(17),KPRM) -C END IF -C PRINT *,'FI7804 ',KPRM,MSTACK(1,KPRM), -C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM) - ELSE -C IF TEXT EVENT, PROCESS TEXT -C PRINT *,' FOUND TEXT MODE ****** NOT COMPRESSED *********' - NRCHRS = IPTR(40) - NRBITS = NRCHRS * 8 -C PRINT *,'CHARS =',NRCHRS,' BITS =',NRBITS - IPTR(31) = IPTR(31) + 1 - KANY = 0 - 1800 CONTINUE - KANY = KANY + 1 - IF (NRBITS.GT.32) THEN - CALL GBYTE (MSGA,IDATA,IPTR(25),32) -C PRINT 1801,KANY,IDATA,IPTR(17),KPRM -C1801 FORMAT (1X,I2,4X,Z8,2(4X,I4)) -C CONVERTS ASCII TO EBCIDIC -C COMMENT OUT IF NOT IBM370 COMPUTER -C CALL W3AI39 (IDATA,4) - KPRM = IPTR(31) + IPTR(24) - KDATA(IPTR(17),KPRM) = IDATA - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 -C PRINT *,KPRM,MSTACK(1,KPRM),MSTACK(2,KPRM), -C * KDATA(IPTR(17),KPRM) - IPTR(25) = IPTR(25) + 32 - NRBITS = NRBITS - 32 - IPTR(24) = IPTR(24) + 1 - GO TO 1800 - ELSE IF (NRBITS.GT.0) THEN -C PRINT *,'LAST TEXT WORD' - CALL GBYTE (MSGA,IDATA,IPTR(25),NRBITS) - IPTR(25) = IPTR(25) + NRBITS -C CONVERTS ASCII TO EBCIDIC -C COMMENT OUT IF NOT IBM370 COMPUTER -C CALL W3AI39 (IDATA,4) - KPRM = IPTR(31) + IPTR(24) - KSHFT = 32 - NRBITS - IF (KSHFT.GT.0) THEN - KTRY = KSHFT / 8 - DO 1722 LAK = 1, KTRY - IDATA = IDATA * 256 + 64 -C PRINT 1723,IDATA - 1723 FORMAT (12X,Z8) - 1722 CONTINUE - END IF - KDATA(IPTR(17),KPRM) = IDATA -C PRINT 1801,KANY,IDATA,KDATA(IPTR(17),KPRM),KPRM - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 -C PRINT *,KPRM,MSTACK(1,KPRM),MSTACK(2,KPRM), -C * KDATA(IPTR(17),KPRM) - END IF -C TURN OFF TEXT - IPTR(18) = 0 - END IF - RETURN - END -C ----------------------------------------------------- - SUBROUTINE FI7805(IPTR,IDENT,MSGA,IWORK,LX,LY, - * KDATA,LL,KNR,MSTACK,MAXR,MAXD) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI7805 PROCESS A REPLICATION DESCRIPTOR -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01 -C -C ABSTRACT: PROCESS A REPLICATION DESCRIPTOR, MUST EXTRACT NUMBER -C OF REPLICATIONS OF N DESCRIPTORS FROM THE DATA STREAM. -C -C PROGRAM HISTORY LOG: -C 88-09-01 CAVANAUGH -C YY-MM-DD MODIFIER2 DESCRIPTION OF CHANGE -C -C USAGE: CALL FI7805(IPTR,IDENT,MSGA,IWORK,LX,LY, -C * KDATA,LL,KNR,MSTACK,MAXR,MAXD) -C INPUT ARGUMENT LIST: -C IWORK - WORKING DESCRIPTOR LIST -C IPTR - SEE W3FI78 ROUTINE DOCBLOCK -C IDENT - SEE W3FI78 ROUTINE DOCBLOCK -C LX - X PORTION OF CURRENT DESCRIPTOR -C LY - Y PORTION OF CURRENT DESCRIPTOR -C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE -C CONTAINED IN A BUFR MESSAGE -C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT -C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE -C DATA REQUIRE A VALUE FOR MAXD OF 1600, BUT FOR MOST -C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C LX - SEE ABOVE -C LY - SEE ABOVE -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - GBYTES FI7808 -C -C REMARKS: ERROR RETURN: -C IPTR(1) = 12 DATA DESCRIPTOR QUALIFIER DOES NOT FOLLOW -C DELAYED REPLICATION DESCRIPTOR -C = 20 EXCEEDED COUNT FOR DELAYED REPLICATION PASS -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN 77 -C MACHINE: CRAY Y-MP8/832 -C -C$$$ - SAVE -C - INTEGER IPTR(*) - INTEGER KNR(MAXR) - INTEGER ITEMP(2000) - INTEGER LL - INTEGER KTEMP(2000) - INTEGER KDATA(MAXR,MAXD) - INTEGER LX,MSTACK(2,MAXD) - INTEGER LY - INTEGER MSGA(*) - INTEGER KVALS(1000) - INTEGER IWORK(MAXD) - INTEGER IDENT(*) -C -C PRINT *,' REPLICATION FI7805' -C DO 100 I = 1, IPTR(13) -C PRINT *,I,IWORK(I) -C 100 CONTINUE -C NUMBER OF DESCRIPTORS - NRSET = LX -C NUMBER OF REPLICATIONS - NRREPS = LY - ICURR = IPTR(11) - 1 - IPICK = IPTR(11) - 1 -C - IF (NRREPS.EQ.0) THEN - IPTR(39) = 1 -C SAVE PRIMARY DELAYED REPLICATION DESCRIPTOR -C IPTR(31) = IPTR(31) + 1 -C KPRM = IPTR(31) + IPTR(24) -C MSTACK(1,KPRM) = JDESC -C MSTACK(2,KPRM) = 0 -C KDATA(IPTR(17),KPRM) = 0 -C PRINT *,'FI7805-1',KPRM,MSTACK(1,KPRM), -C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM) -C DELAYED REPLICATION - MUST GET NUMBER OF -C REPLICATIONS FROM DATA. -C GET NEXT DESCRIPTOR - CALL FI7808(IPTR,IWORK,LF,LX,LY,JDESC,MAXD) -C PRINT *,' DELAYED REPLICATION',LF,LX,LY,JDESC -C MUST BE DATA DESCRIPTION -C OPERATION QUALIFIER - IF (JDESC.EQ.7937.OR.JDESC.EQ.7947) THEN - JWIDE = 8 - ELSE IF (JDESC.EQ.7938.OR.JDESC.EQ.7948) THEN - JWIDE = 16 - ELSE - IPTR(1) = 12 - RETURN - END IF - -C SET SINGLE VALUE FOR SEQUENTIAL, -C MULTIPLE VALUES FOR COMPRESSED - IF (IDENT(16).EQ.0) THEN -C NON COMPRESSED - CALL GBYTE (MSGA,KVALS,IPTR(25),JWIDE) -C PRINT *,LF,LX,LY,JDESC,' NR OF REPLICATIONS',KVALS(1) - IPTR(25) = IPTR(25) + JWIDE - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - KDATA(IPTR(17),KPRM) = KVALS(1) - NRREPS = KVALS(1) -C PRINT *,'FI7805-2',KPRM,MSTACK(1,KPRM), -C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM) - ELSE - NRVALS = IDENT(14) - CALL GBYTES (MSGA,KVALS,IPTR(25),JWIDE,0,NRVALS) - IPTR(25) = IPTR(25) + JWIDE * NRVALS - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - KDATA(IPTR(17),KPRM) = KVALS(1) - DO 100 I = 1, NRVALS - KDATA(I,KPRM) = KVALS(I) - 100 CONTINUE - NRREPS = KVALS(1) - END IF - ELSE -C PRINT *,'NOT DELAYED REPLICATION' - END IF -C RESTRUCTURE WORKING STACK W/REPLICATIONS -C PRINT *,' SAVE OFF',NRSET,' DESCRIPTORS' -C PICK UP DESCRIPTORS TO BE REPLICATED - DO 1000 I = 1, NRSET - CALL FI7808(IPTR,IWORK,LF,LX,LY,JDESC,MAXD) - ITEMP(I) = JDESC -C PRINT *,'REPLICATION ',I,ITEMP(I) - 1000 CONTINUE -C MOVE TRAILING DESCRIPTORS TO HOLD AREA - LAX = IPTR(12) - IPTR(11) + 1 -C PRINT *,LAX,' TRAILING DESCRIPTORS TO HOLD AREA',IPTR(11),IPTR(12) - DO 2000 I = 1, LAX - CALL FI7808(IPTR,IWORK,LF,LX,LY,JDESC,MAXD) - KTEMP(I) = JDESC -C PRINT *,' ',I,KTEMP(I) - 2000 CONTINUE -C REPLICATIONS INTO ISTACK -C PRINT *,' MUST REPLICATE ',KX,' DESCRIPTORS',KY,' TIMES' -C PRINT *,'REPLICATIONS INTO STACK. LOC',ICURR - DO 4000 I = 1, NRREPS - DO 3000 J = 1, NRSET - IWORK(ICURR) = ITEMP(J) -C PRINT *,'FI7805 A',ICURR,IWORK(ICURR) - ICURR = ICURR + 1 - 3000 CONTINUE - 4000 CONTINUE -C PRINT *,' TO LOC',ICURR-1 -C RESTORE TRAILING DESCRIPTORS -C PRINT *,'TRAILING DESCRIPTORS INTO STACK. LOC',ICURR - DO 5000 I = 1, LAX - IWORK(ICURR) = KTEMP(I) -C PRINT *,'FI7805 B',ICURR,IWORK(ICURR) - ICURR = ICURR + 1 - 5000 CONTINUE - IPTR(12) = ICURR - 1 - IPTR(11) = IPICK - RETURN - END - SUBROUTINE FI7806 (IPTR,LX,LY,IDENT,MSGA,KDATA,IVALS,MSTACK, - * MWIDTH,MREF,MSCALE,J,LL,KDESC,IWORK,JDESC,MAXR,MAXD) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI7806 PROCESS OPERATOR DESCRIPTORS -C PRGMMR: CAVANAUGH ORG: W/NMCX42 DATE: 88-09-01 -C -C ABSTRACT: EXTRACT AND SAVE INDICATED CHANGE VALUES FOR USE -C UNTIL CHANGES ARE RESCINDED, OR EXTRACT TEXT STRINGS INDICATED -C THROUGH 2 05 YYY. -C -C PROGRAM HISTORY LOG: -C 88-09-01 CAVANAUGH -C 91-04-04 CAVANAUGH MODIFIED TO HANDLE DESCRIPTOR 2 05 YYY -C 91-05-10 CAVANAUGH CODING HAS BEEN ADDED TO PROCESS PROPOSED -C TABLE C DESCRIPTOR 2 06 YYY. -C 91-11-21 CAVANAUGH CODING HAS BEEN ADDED TO PROPERLY PROCESS -C TABLE C DESCRIPTOR 2 03 YYY, THE CHANGE -C TO NEW REFERENCE VALUE FOR SELECTED -C DESCRIPTORS. -C -C USAGE: CALL FI7806 (IPTR,LX,LY,IDENT,MSGA,KDATA,IVALS,MSTACK, -C * MWIDTH,MREF,MSCALE,J,LL,KDESC,IWORK,JDESC,MAXR,MAXD) -C INPUT ARGUMENT LIST: -C IPTR - SEE W3FI78 ROUTINE DOCBLOCK -C LX - X PORTION OF CURRENT DESCRIPTOR -C LY - Y PORTION OF CURRENT DESCRIPTOR -C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE -C CONTAINED IN A BUFR MESSAGE -C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT -C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE -C DATA REQUIRE A VALUE FOR MAXD OF 1600, BUT FOR MOST -C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE -C -C OUTPUT ARGUMENT LIST: -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C ARRAYS CONTAINING DATA FROM TABLE B -C MSCALE - SCALE FOR VALUE OF DESCRIPTOR -C MREF - REFERENCE VALUE FOR DESCRIPTOR -C MWIDTH - BIT WIDTH FOR VALUE OF DESCRIPTOR -C -C REMARKS: ERROR RETURN: -C IPTR(1) = 5 - ERRONEOUS X VALUE IN DATA DESCRIPTOR OPERATOR -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN 77 -C MACHINE: CRAY Y-MP8/832 -C -C$$$ - SAVE - INTEGER IPTR(*),KDATA(MAXR,MAXD),IVALS(*) - INTEGER IDENT(*),IWORK(*) - INTEGER MSGA(*),MSTACK(2,MAXD) - INTEGER MREF(700,3),KDESC(*) - INTEGER MSCALE(*),MWIDTH(*) - INTEGER J,JDESC - INTEGER LL - INTEGER LX - INTEGER LY -C -C PRINT *,' F2 - DATA DESCRIPTOR OPERATOR' - IF (LX.EQ.1) THEN -C CHANGE BIT WIDTH - IF (LY.EQ.0) THEN -C PRINT *,' RETURN TO NORMAL WIDTH' - IPTR(26) = 0 - ELSE -C PRINT *,' EXPAND WIDTH BY',LY-128,' BITS' - IPTR(26) = LY - 128 - END IF - ELSE IF (LX.EQ.2) THEN -C CHANGE SCALE - IF (LY.EQ.0) THEN -C RESET TO STANDARD SCALE - IPTR(27) = 0 - ELSE -C SET NEW SCALE - IPTR(27) = LY - 128 - END IF - ELSE IF (LX.EQ.3) THEN -C CHANGE REFERENCE VALUE -C FOR EACH OF THOSE DESCRIPTORS BETWEEN -C 2 03 YYY WHERE Y LT 255 AND -C 2 03 255, EXTRACT THE NEW REFERENCE -C VALUE (BIT WIDTH YYY) AND PLACE -C IN TERTIARY TABLE B REF VAL POSITION, -C SET FLAG IN SECONDARY REFVAL POSITION -C THOSE DESCRIPTORS DO NOT HAVE DATA -C ASSOCIATED WITH THEM, BUT ONLY -C IDENTIFY THE TABLE B ENTRIES THAT -C ARE GETTING NEW REFERENCE VALUES. - KYYY = LY - IF (KYYY.GT.0.AND.KYYY.LT.255) THEN -C START CYCLING THRU DESCRIPTORS UNTIL -C TERMINATE NEW REF VALS IS FOUND - 300 CONTINUE - CALL FI7808 (IPTR,IWORK,LF,LX,LY,JDESC,MAXD) - IF (JDESC.EQ.33791) THEN -C IF 2 03 255 THEN RETURN - RETURN - ELSE -C FIND MATCHING TABLE B ENTRY - DO 500 LJ = 1, IPTR(14) - IF (JDESC.EQ.KDESC(LJ)) THEN -C TURN ON NEW REF VAL FLAG - MREF(LJ,2) = 1 -C INSERT NEW REF VAL - CALL GBYTE (MSGA,MREF(LJ,3),IPTR(25),KYYY) -C GO GET NEXT DESCRIPTOR - GO TO 300 - END IF - 500 CONTINUE -C MATCHING DESCRIPTOR NOT FOUND, ERROR ERROR - PRINT *,'2 03 YYY - MATCHING DESCRIPTOR NOT FOUND' - STOP 203 - END IF - ELSE IF (KYYY.EQ.0) THEN -C MUST TURN OFF ALL NEW -C REFERENCE VALUES - DO 400 I = 1, IPTR(14) - MREF(I,2) = 0 - 400 CONTINUE - END IF -C LX = 3 -C MUST BE CONCLUDED WITH Y=255 - ELSE IF (LX.EQ.4) THEN -C ASSOCIATED VALUES - IF (LY.EQ.0) THEN - IPTR(29) = 0 -C PRINT *,'RESET ASSOCIATED VALUES',IPTR(29) - ELSE - IPTR(29) = LY - IF (IWORK(IPTR(11)).NE.7957) THEN - PRINT *,'2 04 YYY NOT FOLLOWED BY 0 31 021' - IPTR(1) = 11 - END IF -C PRINT *,'SET ASSOCIATED VALUES',IPTR(29) - END IF - ELSE IF (LX.EQ.5) THEN -C PROCESS TEXT DATA - IPTR(40) = LY - IPTR(18) = 1 - IF (IDENT(16).EQ.0) THEN -C PRINT *,'2 05 YYY - TEXT - NONCOMPRESSED MODE' - CALL FI7804(IPTR,MSGA,KDATA,IVALS,MSTACK, - * MWIDTH,MREF,MSCALE,J,LL,JDESC,MAXR,MAXD) - ELSE -C PRINT *,'2 05 YYY - TEXT - COMPRESSED MODE' - CALL FI7803(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK, - * MWIDTH,MREF,MSCALE,J,JDESC,MAXR,MAXD) - IF (IPTR(1).NE.0) THEN - RETURN - END IF - ENDIF - IPTR(18) = 0 - ELSE IF (LX.EQ.6) THEN -C SKIP NEXT DESCRIPTOR -C SET TO PASS OVER DESCRIPTOR AND DATA -C IF DESCRIPTOR NOT IN TABLE B - IPTR(36) = LY -C PRINT *,'SET TO SKIP',LY,' BIT FIELD' - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = 34304 + LY - MSTACK(2,KPRM) = 0 - ELSE - IPTR(1) = 5 - ENDIF - RETURN - END - SUBROUTINE FI7807(IPTR,IWORK,ITBLD,JDESC,MAXD) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI7807 PROCESS QUEUE DESCRIPTOR -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01 -C -C ABSTRACT: SUBSTITUTE DESCRIPTOR QUEUE FOR QUEUE DESCRIPTOR -C -C PROGRAM HISTORY LOG: -C 88-09-01 CAVANAUGH -C 91-04-17 CAVANAUGH IMPROVED HANDLING OF NESTED QUEUE DESCRIPTORS -C 91-05-28 CAVANAUGH IMPROVED HANDLING OF NESTED QUEUE DESCRIPTORS -C BASED ON TESTS WITH LIVE DATA. -C -C USAGE: CALL FI7807(IPTR,IWORK,ITBLD,JDESC,MAXD) -C INPUT ARGUMENT LIST: -C IWORK - WORKING DESCRIPTOR LIST -C IPTR - SEE W3FI78 ROUTINE DOCBLOCK -C LAST - INDEX TO LAST DESCRIPTOR -C ITBLD - ARRAY CONTAINING DESCRIPTOR QUEUES -C JDESC - QUEUE DESCRIPTOR TO BE EXPANDED -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C ISTACK - SEE ABOVE -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - NONE -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN 77 -C MACHINE: CRAY Y-MP8/832 -C -C$$$ - SAVE -C - INTEGER IPTR(*),JDESC - INTEGER IWORK(*),IHOLD(2000) - INTEGER ITBLD(500,11) -C -C PRINT *,' FI7807 F3 ENTRY',IPTR(11),IPTR(12) -C SET FOR BINARY SEARCH IN TABLE D -C DO 2020 I = 1, IPTR(12) -C PRINT *,'ENTRY IWORK',I,IWORK(I) -C2020 CONTINUE - JLO = 1 - JHI = IPTR(20) -C PRINT *,'LOOKING FOR QUEUE DESCRIPTOR',JDESC - 10 CONTINUE - JMID = (JLO + JHI) / 2 -C PRINT *,JLO,ITBLD(JLO,1),JMID,ITBLD(JMID,1),JHI,ITBLD(JHI,1) -C - IF (JDESC.LT.ITBLD(JMID,1)) THEN - IF (JDESC.EQ.ITBLD(JLO,1)) THEN - JMID = JLO - GO TO 100 - ELSE - JLO = JLO + 1 - JHI = JMID - 1 - IF (JLO.GT.JMID) THEN - IPTR(1) = 4 - RETURN - END IF - GO TO 10 - END IF - ELSE IF (JDESC.GT.ITBLD(JMID,1)) THEN - IF (JDESC.EQ.ITBLD(JHI,1)) THEN - JMID = JHI - GO TO 100 - ELSE - JLO = JMID + 1 - JHI = JHI - 1 - IF (JLO.GT.JHI) THEN - IPTR(1) = 4 - RETURN - END IF - GO TO 10 - END IF - END IF - 100 CONTINUE -C HAVE TABLE D MATCH -C PRINT *,'D ',(ITBLD(JMID,LL),LL=1,11) -C PRINT *,'TABLE D TO IHOLD' - IK = 0 - JK = 0 - DO 200 KI = 2, 11 - IF (ITBLD(JMID,KI).NE.0) THEN - IK = IK + 1 - IHOLD(IK) = ITBLD(JMID,KI) -C PRINT *,IK,IHOLD(IK) - ELSE - GO TO 300 - END IF - 200 CONTINUE - 300 CONTINUE - KK = IPTR(11) - IF (KK.GT.IPTR(12)) THEN -C NOTHING MORE TO APPEND -C PRINT *,'NOTHING MORE TO APPEND' - ELSE -C APPEND TRAILING IWORK TO IHOLD -C PRINT *,'APPEND FROM ',KK,' TO',IPTR(12) - DO 500 I = KK, IPTR(12) - IK = IK + 1 - IHOLD(IK) = IWORK(I) - 500 CONTINUE - END IF -C RESET IHOLD TO IWORK -C PRINT *,' RESET IWORK STACK' - KK = IPTR(11) - 2 - DO 1000 I = 1, IK - KK = KK + 1 - IWORK(KK) = IHOLD(I) - 1000 CONTINUE - IPTR(12) = KK -C PRINT *,' FI7807 F3 EXIT ',IPTR(11),IPTR(12) -C DO 2000 I = 1, IPTR(12) -C PRINT *,'EXIT IWORK',I,IWORK(I) -C2000 CONTINUE -C RESET POINTERS - IPTR(11) = IPTR(11) - 1 - RETURN - END -C ----------------------------------------------------- - SUBROUTINE FI7808(IPTR,IWORK,LF,LX,LY,JDESC,MAXD) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI7808 -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 89-01-17 -C -C ABSTRACT: -C -C PROGRAM HISTORY LOG: -C 88-09-01 CAVANAUGH -C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE -C -C USAGE: CALL FI7808(IPTR,IWORK,LF,LX,LY,JDESC,MAXD) -C INPUT ARGUMENT LIST: -C IPTR - SEE W3FI78 ROUTINE DOCBLOCK -C IWORK - WORKING DESCRIPTOR LIST -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C IPTR - SEE ABOVE -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN 77 -C MACHINE: CRAY Y-MP8/832 -C -C$$$ - SAVE - INTEGER IPTR(*),IWORK(*),LF,LX,LY,JDESC -C -C PRINT *,' FI7808 NEW DESCRIPTOR PICKUP' - JDESC = IWORK(IPTR(11)) - LY = MOD(JDESC,256) - IPTR(34) = LY - LX = MOD((JDESC/256),64) - IPTR(33) = LX - LF = JDESC / 16384 - IPTR(32) = LF -C PRINT *,' CURRENT DESCRIPTOR BEING TESTED IS',LF,LX,LY - IPTR(11) = IPTR(11) + 1 - RETURN - END - SUBROUTINE FI7809(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI7809 REFORMAT PROFILER W HGT INCREMENTS -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 90-02-14 -C -C ABSTRACT: REFORMAT DECODED PROFILER DATA TO SHOW HEIGHTS INSTEAD OF -C HEIGHT INCREMENTS. -C -C PROGRAM HISTORY LOG: -C 90-02-14 CAVANAUGH -C -C USAGE: CALL FI7809(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD) -C INPUT ARGUMENT LIST: -C IDENT - ARRAY CONTAINS MESSAGE INFORMATION EXTRACTED FROM -C BUFR MESSAGE - -C IDENT( 1)-EDITION NUMBER (BYTE 4, SECTION 1) -C IDENT( 2)-ORIGINATING CENTER (BYTES 5-6, SECTION 1) -C IDENT( 3)-UPDATE SEQUENCE (BYTE 7, SECTION 1) -C IDENT( 4)- (BYTE 8, SECTION 1) -C IDENT( 5)-BUFR MESSAGE TYPE (BYTE 9, SECTION 1) -C IDENT( 6)-BUFR MSG SUB-TYPE (BYTE 10, SECTION 1) -C IDENT( 7)- (BYTES 11-12, SECTION 1) -C IDENT( 8)-YEAR OF CENTURY (BYTE 13, SECTION 1) -C IDENT( 9)-MONTH OF YEAR (BYTE 14, SECTION 1) -C IDENT(10)-DAY OF MONTH (BYTE 15, SECTION 1) -C IDENT(11)-HOUR OF DAY (BYTE 16, SECTION 1) -C IDENT(12)-MINUTE OF HOUR (BYTE 17, SECTION 1) -C IDENT(13)-RSVD BY ADP CENTERS(BYTE 18, SECTION 1) -C IDENT(14)-NR OF DATA SUBSETS (BYTE 5-6, SECTION 3) -C IDENT(15)-OBSERVED FLAG (BYTE 7, BIT 1, SECTION 3) -C IDENT(16)-COMPRESSION FLAG (BYTE 7, BIT 2, SECTION 3) -C MSTACK - WORKING DESCRIPTOR LIST AND SCALING FACTOR -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C KSET2 - INTERIM DATA ARRAY -C KPROFL - INTERIM DESCRIPTOR ARRAY -C IPTR - SEE W3FI78 -C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE -C CONTAINED IN A BUFR MESSAGE -C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT -C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE -C DATA REQUIRE A VALUE FOR MAXD OF 1600, BUT FOR MOST -C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE -C -C OUTPUT FILES: -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN 77 -C MACHINE: CRAY Y-MP8/832 -C -C$$$ - SAVE -C ---------------------------------------------------------------- -C - INTEGER ISW - INTEGER IDENT(*),KDATA(MAXR,MAXD) - INTEGER MSTACK(2,MAXD),IPTR(*) - INTEGER KPROFL(1600) - INTEGER KPROF2(1600) - INTEGER KSET2(1600) -C -C ---------------------------------------------------------- -C PRINT *,'FI7809' -C LOOP FOR NUMBER OF SUBSETS/REPORTS - DO 3000 I = 1, IDENT(14) -C INIT FOR DATA INPUT ARRAY - MK = 1 -C INIT FOR DESC OUTPUT ARRAY - JK = 0 -C LOCATION - ISW = 0 - DO 200 J = 1, 3 -C LATITUDE - IF (MSTACK(1,MK).EQ.1282) THEN - ISW = ISW + 1 - GO TO 100 -C LONGITUDE - ELSE IF (MSTACK(1,MK).EQ.1538) THEN - ISW = ISW + 2 - GO TO 100 -C HEIGHT ABOVE SEA LEVEL - ELSE IF (MSTACK(1,MK).EQ.1793) THEN - IHGT = KDATA(I,MK) - ISW = ISW + 4 - GO TO 100 - END IF - GO TO 200 - 100 CONTINUE - JK = JK + 1 -C SAVE DESCRIPTOR - KPROFL(JK) = MSTACK(1,MK) -C SAVE SCALE - KPROF2(JK) = MSTACK(2,MK) -C SAVE DATA - KSET2(JK) = KDATA(I,MK) - MK = MK + 1 - 200 CONTINUE - IF (ISW.NE.7) THEN - PRINT *,'LOCATION ERROR PROCESSING PROFILER' - IPTR(1) = 200 - RETURN - END IF -C TIME - ISW = 0 - DO 400 J = 1, 7 -C YEAR - IF (MSTACK(1,MK).EQ.1025) THEN - ISW = ISW + 1 - GO TO 300 -C MONTH - ELSE IF (MSTACK(1,MK).EQ.1026) THEN - ISW = ISW + 2 - GO TO 300 -C DAY - ELSE IF (MSTACK(1,MK).EQ.1027) THEN - ISW = ISW + 4 - GO TO 300 -C HOUR - ELSE IF (MSTACK(1,MK).EQ.1028) THEN - ISW = ISW + 8 - GO TO 300 -C MINUTE - ELSE IF (MSTACK(1,MK).EQ.1029) THEN - ISW = ISW + 16 - GO TO 300 -C TIME SIGNIFICANCE - ELSE IF (MSTACK(1,MK).EQ.2069) THEN - ISW = ISW + 32 - GO TO 300 - ELSE IF (MSTACK(1,MK).EQ.1049) THEN - ISW = ISW + 64 - GO TO 300 - END IF - GO TO 400 - 300 CONTINUE - JK = JK + 1 -C SAVE DESCRIPTOR - KPROFL(JK) = MSTACK(1,MK) -C SAVE SCALE - KPROF2(JK) = MSTACK(2,MK) -C SAVE DATA - KSET2(JK) = KDATA(I,MK) - MK = MK + 1 - 400 CONTINUE - IF (ISW.NE.127) THEN - PRINT *,'TIME ERROR PROCESSING PROFILER',ISW - IPTR(1) = 201 - RETURN - END IF -C SURFACE DATA - KRG = 0 - ISW = 0 - DO 600 J = 1, 10 -C WIND SPEED - IF (MSTACK(1,MK).EQ.2818) THEN - ISW = ISW + 1 - GO TO 500 -C WIND DIRECTION - ELSE IF (MSTACK(1,MK).EQ.2817) THEN - ISW = ISW + 2 - GO TO 500 -C PRESS REDUCED TO MSL - ELSE IF (MSTACK(1,MK).EQ.2611) THEN - ISW = ISW + 4 - GO TO 500 -C TEMPERATURE - ELSE IF (MSTACK(1,MK).EQ.3073) THEN - ISW = ISW + 8 - GO TO 500 -C RAINFALL RATE - ELSE IF (MSTACK(1,MK).EQ.3342) THEN - ISW = ISW + 16 - GO TO 500 -C RELATIVE HUMIDITY - ELSE IF (MSTACK(1,MK).EQ.3331) THEN - ISW = ISW + 32 - GO TO 500 -C 1ST RANGE GATE OFFSET - ELSE IF (MSTACK(1,MK).EQ.1982.OR. - * MSTACK(1,MK).EQ.1983) THEN -C CANNOT USE NORMAL PROCESSING FOR FIRST RANGE GATE, MUST SAVE -C VALUE FOR LATER USE - IF (MSTACK(1,MK).EQ.1983) THEN - IHGT = KDATA(I,MK) - MK = MK + 1 - KRG = 1 - ELSE - IF (KRG.EQ.0) THEN - INCRHT = KDATA(I,MK) - MK = MK + 1 - KRG = 1 -C PRINT *,'INITIAL INCR =',INCRHT - ELSE - LHGT = 500 + IHGT - KDATA(I,MK) - ISW = ISW + 64 -C PRINT *,'BASE HEIGHT=',LHGT,' INCR=',INCRHT - END IF - END IF -C MODE #1 - ELSE IF (MSTACK(1,MK).EQ.8128) THEN - ISW = ISW + 128 - GO TO 500 -C MODE #2 - ELSE IF (MSTACK(1,MK).EQ.8129) THEN - ISW = ISW + 256 - GO TO 500 - END IF - GO TO 600 - 500 CONTINUE -C SAVE DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = MSTACK(1,MK) -C SAVE SCALE - KPROF2(JK) = MSTACK(2,MK) -C SAVE DATA - KSET2(JK) = KDATA(I,MK) -C IF (I.EQ.1) THEN -C PRINT *,' ',JK,KPROFL(JK),KSET2(JK) -C END IF - MK = MK + 1 - 600 CONTINUE - 650 CONTINUE - IF (ISW.NE.511) THEN - PRINT *,'SURFACE ERROR PROCESSING PROFILER',ISW - IPTR(1) = 202 - RETURN - END IF -C 43 LEVELS - DO 2000 L = 1, 43 - 2020 CONTINUE - ISW = 0 -C HEIGHT INCREMENT - IF (MSTACK(1,MK).EQ.1982) THEN -C PRINT *,'NEW HEIGHT INCREMENT',KDATA(I,MK) - INCRHT = KDATA(I,MK) - MK = MK + 1 - IF (LHGT.LT.(9250+IHGT)) THEN - LHGT = IHGT + 500 - INCRHT - ELSE - LHGT = IHGT + 9250 - INCRHT - END IF - END IF -C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DATA -C AT THIS POINT - HEIGHT + INCREMENT + BASE VALUE - LHGT = LHGT + INCRHT -C PRINT *,'LEVEL ',L,LHGT - IF (L.EQ.37) THEN - LHGT = LHGT + INCRHT - END IF - JK = JK + 1 -C SAVE DESCRIPTOR - KPROFL(JK) = 1798 -C SAVE SCALE - KPROF2(JK) = 0 -C SAVE DATA - KSET2(JK) = LHGT -C IF (I.EQ.10) THEN -C PRINT *,' ' -C PRINT *,'HGT',JK,KPROFL(JK),KSET2(JK) -C END IF - ISW = 0 - DO 800 J = 1, 9 - 750 CONTINUE - IF (MSTACK(1,MK).EQ.1982) THEN - GO TO 2020 -C U VECTOR VALUE - ELSE IF (MSTACK(1,MK).EQ.3008) THEN - ISW = ISW + 1 - IF (KDATA(I,MK).GE.2047) THEN - VECTU = 32767 - ELSE - VECTU = KDATA(I,MK) - END IF - MK = MK + 1 - GO TO 800 -C V VECTOR VALUE - ELSE IF (MSTACK(1,MK).EQ.3009) THEN - ISW = ISW + 2 - IF (KDATA(I,MK).GE.2047) THEN - VECTV = 32767 - ELSE - VECTV = KDATA(I,MK) - END IF - MK = MK + 1 -C IF U VALUE IS ALSO AVAILABLE THEN GENERATE DDFFF -C DESCRIPTORS AND DATA - IF (IAND(ISW,1).NE.0) THEN - IF (VECTU.EQ.32767.OR.VECTV.EQ.32767) THEN -C SAVE DD DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = 2817 -C SAVE SCALE - KPROF2(JK) = 0 -C SAVE DD DATA - KSET2(JK) = 32767 -C SAVE FFF DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = 2818 -C SAVE SCALE - KPROF2(JK) = 1 -C SAVE FFF DATA - KSET2(JK) = 32767 - ELSE -C GENERATE DDFFF - CALL W3FC05 (VECTU,VECTV,DIR,SPD) - NDIR = DIR - SPD = SPD - NSPD = SPD -C PRINT *,' ',NDIR,NSPD -C SAVE DD DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = 2817 -C SAVE SCALE - KPROF2(JK) = 0 -C SAVE DD DATA - KSET2(JK) = DIR -C IF (I.EQ.1) THEN -C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK) -C END IF -C SAVE FFF DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = 2818 -C SAVE SCALE - KPROF2(JK) = 1 -C SAVE FFF DATA - KSET2(JK) = SPD -C IF (I.EQ.1) THEN -C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK) -C END IF - END IF - END IF - GO TO 800 -C W VECTOR VALUE - ELSE IF (MSTACK(1,MK).EQ.3010) THEN - ISW = ISW + 4 - GO TO 700 -C Q/C TEST RESULTS - ELSE IF (MSTACK(1,MK).EQ.8130) THEN - ISW = ISW + 8 - GO TO 700 -C U,V QUALITY IND - ELSE IF(IAND(ISW,16).EQ.0.AND.MSTACK(1,MK).EQ.2070) THEN - ISW = ISW + 16 - GO TO 700 -C W QUALITY IND - ELSE IF(IAND(ISW,32).EQ.0.AND.MSTACK(1,MK).EQ.2070) THEN - ISW = ISW + 32 - GO TO 700 -C SPECTRAL PEAK POWER - ELSE IF (MSTACK(1,MK).EQ.5568) THEN - ISW = ISW + 64 - GO TO 700 -C U,V VARIABILITY - ELSE IF (MSTACK(1,MK).EQ.3011) THEN - ISW = ISW + 128 - GO TO 700 -C W VARIABILITY - ELSE IF (MSTACK(1,MK).EQ.3013) THEN - ISW = ISW + 256 - GO TO 700 - ELSE IF ((MSTACK(1,MK)/16384).NE.0) THEN - MK = MK + 1 - GO TO 750 - END IF - GO TO 800 - 700 CONTINUE - JK = JK + 1 -C SAVE DESCRIPTOR - KPROFL(JK) = MSTACK(1,MK) -C SAVE SCALE - KPROF2(JK) = MSTACK(2,MK) -C SAVE DATA - KSET2(JK) = KDATA(I,MK) - MK = MK + 1 -C IF (I.EQ.1) THEN -C PRINT *,' ',JK,KPROFL(JK),KSET2(JK) -C END IF - 800 CONTINUE - 850 CONTINUE - IF (ISW.NE.511) THEN - PRINT *,'LEVEL ERROR PROCESSING PROFILER',ISW - IPTR(1) = 203 - RETURN - END IF - 2000 CONTINUE -C MOVE DATA BACK INTO KDATA ARRAY - DO 4000 LL = 1, JK - KDATA(I,LL) = KSET2(LL) - 4000 CONTINUE - 3000 CONTINUE -C PRINT *,'REBUILT ARRAY' - DO 5000 LL = 1, JK -C DESCRIPTOR - MSTACK(1,LL) = KPROFL(LL) -C SCALE - MSTACK(2,LL) = KPROF2(LL) -C PRINT *,LL,MSTACK(1,LL),(KDATA(I,LL),I=1,7) - 5000 CONTINUE -C MOVE REFORMATTED DESCRIPTORS TO MSTACK ARRAY - IPTR(31) = JK - RETURN - END - SUBROUTINE FI7810(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI7810 REFORMAT PROFILER EDITION 2 DATA -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-01-21 -C -C ABSTRACT: REFORMAT PROFILER DATA IN EDITION 2 -C -C PROGRAM HISTORY LOG: -C 93-01-27 CAVANAUGH -C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE -C -C USAGE: CALL FI7810(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD) -C INPUT ARGUMENT LIST: -C IDENT - ARRAY CONTAINS MESSAGE INFORMATION EXTRACTED FROM -C BUFR MESSAGE - -C IDENT( 1)-EDITION NUMBER (BYTE 4, SECTION 1) -C IDENT( 2)-ORIGINATING CENTER (BYTES 5-6, SECTION 1) -C IDENT( 3)-UPDATE SEQUENCE (BYTE 7, SECTION 1) -C IDENT( 4)- (BYTE 8, SECTION 1) -C IDENT( 5)-BUFR MESSAGE TYPE (BYTE 9, SECTION 1) -C IDENT( 6)-BUFR MSG SUB-TYPE (BYTE 10, SECTION 1) -C IDENT( 7)- (BYTES 11-12, SECTION 1) -C IDENT( 8)-YEAR OF CENTURY (BYTE 13, SECTION 1) -C IDENT( 9)-MONTH OF YEAR (BYTE 14, SECTION 1) -C IDENT(10)-DAY OF MONTH (BYTE 15, SECTION 1) -C IDENT(11)-HOUR OF DAY (BYTE 16, SECTION 1) -C IDENT(12)-MINUTE OF HOUR (BYTE 17, SECTION 1) -C IDENT(13)-RSVD BY ADP CENTERS(BYTE 18, SECTION 1) -C IDENT(14)-NR OF DATA SUBSETS (BYTE 5-6, SECTION 3) -C IDENT(15)-OBSERVED FLAG (BYTE 7, BIT 1, SECTION 3) -C IDENT(16)-COMPRESSION FLAG (BYTE 7, BIT 2, SECTION 3) -C MSTACK - WORKING DESCRIPTOR LIST AND SCALING FACTOR -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C KSET2 - INTERIM DATA ARRAY -C KPROFL - INTERIM DESCRIPTOR ARRAY -C IPTR - SEE W3FI78 -C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE -C CONTAINED IN A BUFR MESSAGE -C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT -C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE -C DATA REQUIRE A VALUE FOR MAXD OF 1600, BUT FOR MOST -C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE -C -C OUTPUT FILES: -C -C REMARKS: -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN 77 -C MACHINE: CRAY Y-MP8/832 -C -C$$$ - INTEGER ISW - INTEGER IDENT(*),KDATA(MAXR,MAXD) - INTEGER MSTACK(2,MAXD),IPTR(*) - INTEGER KPROFL(1600) - INTEGER KPROF2(1600) - INTEGER KSET2(1600) -C LOOP FOR NUMBER OF SUBSETS - DO 3000 I = 1, IDENT(14) - MK = 1 - JK = 0 - ISW = 0 -C PRINT *,'IDENTIFICATION' - DO 200 J = 1, 5 - IF (MSTACK(1,MK).EQ.257) THEN -C BLOCK NUMBER - ISW = ISW + 1 - ELSE IF (MSTACK(1,MK).EQ.258) THEN -C STATION NUMBER - ISW = ISW + 2 - ELSE IF (MSTACK(1,MK).EQ.1282) THEN -C LATITUDE - ISW = ISW + 4 - ELSE IF (MSTACK(1,MK).EQ.1538) THEN -C LONGITUDE - ISW = ISW + 8 - ELSE IF (MSTACK(1,MK).EQ.1793) THEN -C HEIGHT OF STATION - ISW = ISW + 16 - IHGT = KDATA(I,MK) - ELSE - MK = MK + 1 - GO TO 200 - END IF - JK = JK + 1 - KPROFL(JK) = MSTACK(1,MK) - KPROF2(JK) = MSTACK(2,MK) - KSET2(JK) = KDATA(I,MK) -C PRINT *,JK,KPROFL(JK),KSET2(JK) - MK = MK + 1 - 200 CONTINUE -C PRINT *,'LOCATION ',ISW - IF (ISW.NE.31) THEN - PRINT *,'LOCATION ERROR PROCESSING PROFILER' - IPTR(10) = 200 - RETURN - END IF -C PROCESS TIME ELEMENTS - ISW = 0 - DO 400 J = 1, 7 - IF (MSTACK(1,MK).EQ.1025) THEN -C YEAR - ISW = ISW + 1 - ELSE IF (MSTACK(1,MK).EQ.1026) THEN -C MONTH - ISW = ISW + 2 - ELSE IF (MSTACK(1,MK).EQ.1027) THEN -C DAY - ISW = ISW + 4 - ELSE IF (MSTACK(1,MK).EQ.1028) THEN -C HOUR - ISW = ISW + 8 - ELSE IF (MSTACK(1,MK).EQ.1029) THEN -C MINUTE - ISW = ISW + 16 - ELSE IF (MSTACK(1,MK).EQ.2069) THEN -C TIME SIGNIFICANCE - ISW = ISW + 32 - ELSE IF (MSTACK(1,MK).EQ.1049) THEN -C TIME DISPLACEMENT - ISW = ISW + 64 - ELSE - MK = MK + 1 - GO TO 400 - END IF - JK = JK + 1 - KPROFL(JK) = MSTACK(1,MK) - KPROF2(JK) = MSTACK(2,MK) - KSET2(JK) = KDATA(I,MK) -C PRINT *,JK,KPROFL(JK),KSET2(JK) - MK = MK + 1 - 400 CONTINUE -C PRINT *,'TIME ',ISW - IF (ISW.NE.127) THEN - PRINT *,'TIME ERROR PROCESSING PROFILER' - IPTR(1) = 201 - RETURN - END IF -C SURFACE DATA - ISW = 0 -C PRINT *,'SURFACE' - DO 600 K = 1, 8 -C PRINT *,MK,MSTACK(1,MK),JK,ISW - IF (MSTACK(1,MK).EQ.2817) THEN - ISW = ISW + 1 - ELSE IF (MSTACK(1,MK).EQ.2818) THEN - ISW = ISW + 2 - ELSE IF (MSTACK(1,MK).EQ.2611) THEN - ISW = ISW + 4 - ELSE IF (MSTACK(1,MK).EQ.3073) THEN - ISW = ISW + 8 - ELSE IF (MSTACK(1,MK).EQ.3342) THEN - ISW = ISW + 16 - ELSE IF (MSTACK(1,MK).EQ.3331) THEN - ISW = ISW + 32 - ELSE IF (MSTACK(1,MK).EQ.1797) THEN - INCRHT = KDATA(I,MK) - ISW = ISW + 64 -C PRINT *,'INITIAL INCREMENT = ',INCRHT - MK = MK + 1 -C PRINT *,JK,KPROFL(JK),KSET2(JK),' ISW=',ISW - GO TO 600 - ELSE IF (MSTACK(1,MK).EQ.6433) THEN - ISW = ISW + 128 - END IF - JK = JK + 1 - KPROFL(JK) = MSTACK(1,MK) - KPROF2(JK) = MSTACK(2,MK) - KSET2(JK) = KDATA(I,MK) -C PRINT *,JK,KPROFL(JK),KSET2(JK),'ISW=',ISW - MK = MK + 1 - 600 CONTINUE - IF (ISW.NE.255) THEN - PRINT *,'ERROR PROCESSING PROFILER',ISW - IPTR(1) = 204 - RETURN - END IF - IF (MSTACK(1,MK).NE.1797) THEN - PRINT *,'ERROR PROCESSING HEIGHT INCREMENT IN PROFILER' - IPTR(1) = 205 - RETURN - END IF -C MUST SAVE THIS HEIGHT VALUE - LHGT = 500 + IHGT - KDATA(I,MK) -C PRINT *,'BASE HEIGHT = ',LHGT,' INCR = ',INCRHT - MK = MK + 1 - IF (MSTACK(1,MK).GE.16384) THEN - MK = MK + 1 - END IF -C PROCESS LEVEL DATA -C PRINT *,'LEVEL DATA' - DO 2000 L = 1, 43 - 2020 CONTINUE -C PRINT *,'DESC',MK,MSTACK(1,MK),JK - ISW = 0 -C HEIGHT INCREMENT - IF (MSTACK(1,MK).EQ.1797) THEN - INCRHT = KDATA(I,MK) -C PRINT *,'NEW HEIGHT INCREMENT = ',INCRHT - MK = MK + 1 - IF (LHGT.LT.(9250+IHGT)) THEN - LHGT = IHGT + 500 - INCRHT - ELSE - LHGT = IHGT + 9250 -INCRHT - END IF - END IF -C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DA -C AT THIS POINT - LHGT = LHGT + INCRHT -C PRINT *,'LEVEL ',L,LHGT - IF (L.EQ.37) THEN - LHGT = LHGT + INCRHT - END IF - JK = JK + 1 -C SAVE DESCRIPTOR - KPROFL(JK) = 1798 -C SAVE SCALE - KPROF2(JK) = 0 -C SAVE DATA - KSET2(JK) = LHGT -C PRINT *,KPROFL(JK),KSET2(JK),JK - ISW = 0 - ICON = 1 - DO 800 J = 1, 10 -750 CONTINUE - IF (MSTACK(1,MK).EQ.1797) THEN - GO TO 2020 - ELSE IF (MSTACK(1,MK).EQ.6432) THEN -C HI/LO MODE - ISW = ISW + 1 - ELSE IF (MSTACK(1,MK).EQ.6434) THEN -C Q/C TEST - ISW = ISW + 2 - ELSE IF (MSTACK(1,MK).EQ.2070) THEN - IF (ICON.EQ.1) THEN -C FIRST PASS - U,V CONSENSUS - ISW = ISW + 4 - ICON = ICON + 1 - ELSE -C SECOND PASS - W CONSENSUS - ISW = ISW + 64 - END IF - ELSE IF (MSTACK(1,MK).EQ.2819) THEN -C U VECTOR VALUE - ISW = ISW + 8 - IF (KDATA(I,MK).GE.2047) THEN - VECTU = 32767 - ELSE - VECTU = KDATA(I,MK) - END IF - MK = MK + 1 - GO TO 800 - ELSE IF (MSTACK(1,MK).EQ.2820) THEN -C V VECTOR VALUE - ISW = ISW + 16 - IF (KDATA(I,MK).GE.2047) THEN - VECTV = 32767 - ELSE - VECTV = KDATA(I,MK) - END IF - IF (IAND(ISW,1).NE.0) THEN - IF (VECTU.EQ.32767.OR.VECTV.EQ.32767) THEN -C SAVE DD DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = 2817 - KPROF2(JK) = 0 - KSET2(JK) = 32767 -C SAVE FFF DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = 2818 - KPROF2(JK) = 1 - KSET2(JK) = 32767 - ELSE - CALL W3FC05 (VECTU,VECTV,DIR,SPD) - NDIR = DIR - SPD = SPD - NSPD = SPD -C PRINT *,' ',NDIR,NSPD -C SAVE DD DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = 2817 - KPROF2(JK) = 0 - KSET2(JK) = NDIR -C IF (I.EQ.1) THEN -C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK) -C ENDIF -C SAVE FFF DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = 2818 - KPROF2(JK) = 1 - KSET2(JK) = NSPD -C IF (I.EQ.1) THEN -C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK) -C ENDIF - END IF - MK = MK + 1 - GO TO 800 - END IF - ELSE IF (MSTACK(1,MK).EQ.2866) THEN -C SPEED STD DEVIATION - ISW = ISW + 32 -C -- A CHANGE BY KEYSER : POWER DESCR. BACK TO 5568 - ELSE IF (MSTACK(1,MK).EQ.5568) THEN -C SIGNAL POWER - ISW = ISW + 128 - ELSE IF (MSTACK(1,MK).EQ.2822) THEN -C W COMPONENT - ISW = ISW + 256 - ELSE IF (MSTACK(1,MK).EQ.2867) THEN -C VERT STD DEVIATION - ISW = ISW + 512 - ELSE - MK = MK + 1 - GO TO 750 - END IF - JK = JK + 1 -C SAVE DESCRIPTOR - KPROFL(JK) = MSTACK(1,MK) -C SAVE SCALE - KPROF2(JK) = MSTACK(2,MK) -C SAVE DATA - KSET2(JK) = KDATA(I,MK) - MK = MK + 1 -C PRINT *,L,'TEST ',JK,KPROFL(JK),KSET2(JK) - 800 CONTINUE - 850 CONTINUE - IF (ISW.NE.1023) THEN - PRINT *,'LEVEL ERROR PROCESSING PROFILER',ISW - IPTR(1) = 202 - RETURN - END IF - 2000 CONTINUE -C MOVE DATA BACK INTO KDATA ARRAY - DO 5000 LL = 1, JK -C DATA - KDATA(I,LL) = KSET2(LL) - 5000 CONTINUE - 3000 CONTINUE - DO 5005 LL = 1, JK -C DESCRIPTOR - MSTACK(1,LL) = KPROFL(LL) -C SCALE - MSTACK(2,LL) = KPROF2(LL) -C -- A CHANGE BY KEYSER : PRINT STATEMNT SHOULD BE HERE NOT IN 5000 LOOP -C PRINT *,LL,MSTACK(1,LL),MSTACK(2,LL),(KDATA(I,LL),I=1,4) - 5005 CONTINUE - IPTR(31) = JK - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fi81.f.sav b/src/fim/FIMsrc/w3/w3fi81.f.sav deleted file mode 100644 index 4b4cd18..0000000 --- a/src/fim/FIMsrc/w3/w3fi81.f.sav +++ /dev/null @@ -1,2300 +0,0 @@ - SUBROUTINE W3FI81(IUNIT0,IUNIT1,IUNIT2,IUBTBL,IUDTBL,IBUFTN,IERR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI81 READS 3 BUFR RTRVL FILES, REFORMATS DATA -C PRGMMR: BERT B. KATZ ORG: W/NMC23 DATE: 93-06-09 -C GENERAL -C SCIENCES CORP. -C -C ABSTRACT: READS AND UNPACKS THREE BUFR INTERACTIVE RETRIEVAL FILES : -C (1) TOVS 40-LEVEL AND RADIANCE DATA, (2) INTERACTIVE RETRIEVALS, AND -C (3) ANALYSIS INTERPOLATION. THE NECESSARY QUANTITIES ARE REARRANGED -C INTO THE FORMAT OF A NESDIS FORMATTED FILE, IN INTEGERS THE SIZE -C OF THE MACHINE'S WORD LENGTH. -C -C PROGRAM HISTORY LOG: -C 93-06-09 BERT B. KATZ -C 93-09-08 BERT B. KATZ -- SUPPLIED MISSING ANALYZED SURFACE PRESSURE -C FIELD AND ADDED "STABILITY DEPARTURE" -C QUANTITIES AS PER NESDIS REQUEST. -C 93-10-22 BERT B. KATZ -- CHANGED UNIVERSAL BUFR DESCRIPTOR 2080 -C TO LOCAL BUFR DESCRIPTOR 2280. -C 95-05-11 BERT B. KATZ -- CHANGED TO ALLOW PROCESSING OF RETRIEVALS -C FROM NOAA-14. -C -C -C USAGE : CALL W3FI81(IUNIT0,IUNIT1,IUNIT2,IUBTBL,IUDTBL,IBUFTN,IERR) -C INPUT ARGUMENT LIST: -C IUNIT0 - UNIT NUMBER OF INPUT FILE CONTAINING TOVS 40-LEVEL -C - RETRIEVALS AND RADIANCES IN BUFR FORMAT. -C IUNIT1 - UNIT NUMBER OF INPUT FILE CONTAINING INTERACTIVE -C - RETRIEVALS IN BUFR FORMAT. -C IUNIT2 - UNIT NUMBER OF INPUT FILE CONTAINING ANALYSIS -C - INTERPOLATION DATA IN BUFR FORMAT. -C IUBTBL - UNIT NUMBER OF INPUT FILE CONTAINING BUFR TABLE B. -C IUDTBL - UNIT NUMBER OF INPUT FILE CONTAINING BUFR TABLE D. -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C IBUFTN - CONTAINS THE CONTENTS OF A RECORD IN A NESDIS -C - FORMAT IN MACHINE WORD LENGTH INTEGERS. -C IERR - ERROR RETURN CODE (= 0 FOR NORMAL COMPLETION) -C - (= 3 FOR NORMAL END-OF-FILE ON ALL THREE FILES) -C - (= 1111 FOR BUFR DECODING ERROR ON TOVS 40-LEVEL FILE) -C - (= 2222 FOR BUFR DECODING ERROR ON TOVS 40-LEVEL FILE) -C - (= 3333 FOR BUFR DECODING ERROR ON TOVS 40-LEVEL FILE) -C - (= 4444 FOR BUFR DECODING ERROR ON INTER. RTRVL. FILE) -C - (= 5555 FOR BUFR DECODING ERROR ON INTER. RTRVL. FILE) -C - (= 6666 FOR BUFR DECODING ERROR ON INTER. RTRVL. FILE) -C - (= 7777 FOR BUFR DECODING ERROR ON ANALY. INTERP. FILE) -C - (= 8888 FOR BUFR DECODING ERROR ON ANALY. INTERP. FILE) -C - (=55555 FOR DATA MISMATCH BETWEEN THE THREE FILES) -C - (=66666 FOR DATA MISMATCH BETWEEN THE THREE FILES) -C - (=77777 FOR DATA MISMATCH BETWEEN THE THREE FILES) -C - (=88888 FOR DATA MISMATCH BETWEEN THE THREE FILES) -C - (=99999 FOR DATA MISMATCH BETWEEN THE THREE FILES) -C -C INPUT FILES: -C FT(IUNIT0)F001 -C - FILE CONTAINING TOVS 40-LEVEL RETRIEVAL AND RADIANCE -C - DATA IN BUFR FORM. -C FT(IUNIT1)F001 -C - FILE CONTAINING INTERACTIVE RETRIEVAL DATA IN -C - BUFR FORM. -C FT(IUNIT2)F001 -C - FILE CONTAINING ANALYSIS INTERPOLATION DATA IN -C - BUFR FORM. -C FT(IUBTBL)F001 -C - FILE CONTAINING BUFR TABLE B. -C FT(IUDTBL)F001 -C - FILE CONTAINING BUFR TABLE D. -C -C REMARKS: CALLS SUBROUTINE W3FI78 TO UNPACK BUFR DATA. -C CALLS SUBROUTINE FI8101 TO FILL COMMON BLOCK /FI80TV/ WITH -C LOCATION AND SCALING OF 40-LEVEL TOVS RETRIEVALS. -C CALLS SUBROUTINE FI8102 TO FILL COMMON BLOCK /FI80IA/ WITH -C LOCATION AND SCALING OF INTERACTIVE RETRIEVALS. -C CALLS SUBROUTINE FI8103 TO FILL COMMON BLOCK /FI80AN/ WITH -C LOCATION AND SCALING OF ANALYSIS INTERPOLATION DATA. -C CALLS SUBROUTINE FI8104 TO INTERPOLATE MODEL TEMPERATURES -C AND MIXING RATIOS TO TOVS 40 PRESSURE LEVELS. -C CALLS SUBROUTINE FI8105 TO GENERATE GEOPOTENTIAL HEIGHTS -C HYDROSTATICALLY FROM TEMPERATURES AND MIXING RATIOS -C INTERPOLATED FROM MODEL TO TOVS LEVELS IN SUBROUTINE -C FI8105. -C CALL SUBROUTINE FI8106 TO CALCULATE STABILITY DEPARTURES -C BETWEEN TOVS OPERATIONAL RETRIEVAL AND THE MODEL FIRST GUESS -C FOR 1000 MB - 700 MB LAYER AND 500 MB - 300 MB LAYER. -C -C ATTRIBUTES: -C LANGUAGE: VS FORTRAN, CFT77 -C MACHINE: HDS OR CRAY -C -C$$$ -C - PARAMETER (MXIRPT=50,MXIDSC=420) - PARAMETER (MXRPTR=30,MXDSCR=700) - PARAMETER (MXRPTA=100,MXDSCA=200) - PARAMETER (NMLO=28) - PARAMETER (NML=70,NUL=39) - SAVE IFIRST,INDEX0,INDEX1,INDEX2,IPTR0,IPTR1,IPTR2, - 1 IDENT0,IDENT1,IDENT2,KDATA0,KDATA1,KDATA2,IENFIL - REAL GEOOPR(40),TGES40(40),WGES40(40),GEOGES(40) - REAL TGES(NMLO),WGES(NMLO),PGES(NMLO) - INTEGER IPTR0(40) - INTEGER IDENT0(20) - INTEGER ISTCK0(MXIDSC) - INTEGER MSTCK0(2,MXIDSC) - INTEGER KDATA0(MXIRPT,MXIDSC) - INTEGER KNR0(MXIRPT) - INTEGER IPTR1(40) - INTEGER IDENT1(20) - INTEGER ISTCK1(MXDSCR) - INTEGER MSTCK1(2,MXDSCR) - INTEGER KDATA1(MXRPTR,MXDSCR) - INTEGER KNR1(MXRPTR) - INTEGER IPTR2(40) - INTEGER IDENT2(20) - INTEGER ISTCK2(MXDSCA) - INTEGER MSTCK2(2,MXDSCA) - INTEGER KDATA2(MXRPTA,MXDSCA) - INTEGER KNR2(MXRPTA) - INTEGER INDEX0,INDEX1,INDEX2 - INTEGER IFIRST -C -C - INTEGER IBUFTN(720) - INTEGER MSGA(2500) - CHARACTER*1 CMSGA(10000) - EQUIVALENCE (MSGA(1),CMSGA(1)) -C -C - COMMON /FI81TV/ LCSTII, LCSSBC, LCMBBX, - 1 LCINSI, LCRTMI, LCFLFI, - 2 LCYRI , LCMONI, LCDAYI, - 3 LCHRI , LCMINI, LCSECI, - 4 LCLSI , LCNDI , LCFGAP, - 5 LCDVHI, LCDVMI, LCDVSI, - 6 LCNMCI, LWNMCI, LCRTPI, - 7 LCLATI, IXLATI, LCLONI, IXLONI, - 8 LCSTUI, LCSSTA, LCST15, IXST15, - 9 LCSZAN, IXSZAN, LCLSZA, IXLSZA, - A LCSALB, IXSALB, LCSKNI, IXSKNI, - B LCH8FI, LCPLSI, IXPLSI, LCSFHI, IXSFHI, - C LCICOI, LCOZON, IXOZON, LCAVNS, IXAVNS, - D LCICTI, LCPTRI, IXPTRI, LCTTRI, IXTTRI - COMMON /FI81TV/ LCP40I(40), IXP40I(40), - 1 LCT40I(40), IXT40I(40), - 2 LCH40I(40), IXH40I(40), - 3 LCM40I(40), IXM40I(40), - 4 LCP4GI(40), IXP4GI(40), - 5 LCT4GI(40), IXT4GI(40), - 6 LCM4GI(40), IXM4GI(40), - 7 LCRADI(27), IXRADI(27), - 8 LCRDGI(27), IXRDGI(27) - COMMON /FI81IA/ LCSTIR , LCLSR , LCNDR , - 1 LCNMCR , LWNMCR , LCFCYC , - 2 LCINSR , LCRTMR , LCRTPR , - 3 LCDVHR , LCDVMR , LCDVSR , - 4 LCSTUR , LCICOR , LCFLFR , - 5 LCLATR , IXLATR , - 6 LCLONR , IXLONR , - 7 LCPTRR , IXPTRR , - 8 LCTTRR , IXTTRR , LCICTR , - 9 LCSKNT , IXSKNT , - A LCPLSR , IXPLSR , - B LCSFHF , IXSFHF , - C LCPSFF , IXPSFF , - D LCSKNF , IXSKNF , - E LCSKNR , IXSKNR , LCH8FR - COMMON /FI81IA/ LCRADF(27) , IXRADF(27) , - 1 LCRDFC(27) , IXRDFC(27) , - 2 LCSIGI(NMLO), IXSIGI(NMLO), - 3 LCTMPI(NMLO), IXTMPI(NMLO), - 4 LCRADR(27) , IXRADR(27) , - 5 LCRDRC(27) , IXRDRC(27) , - 6 LCSIGF(NMLO), IXSIGF(NMLO), - 7 LCTMPF(NMLO), IXTMPF(NMLO), - 8 LCMIXF(NMLO), IXMIXF(NMLO), - 9 LCSIGR(NML) , IXSIGR(NML) , - A LCTMPR(NML) , IXTMPR(NML) , - B LCMIXR(NML) , IXMIXR(NML) , - C LCP41I , IXP41I , - D LCT41I , IXT41I , - E LCM41I , IXM41I - COMMON /FI81AN/ LCSTIA , LCYRA , LCMONA , - 1 LCDAYA , LCHRA , LCMINA , - 2 LCLATA , IXLATA , - 3 LCLONA , IXLONA , - 4 LCPSFA , IXPSFA , - 5 LCSFHA , IXSFHA , - 6 LCNMCA , LWNMCA , - 7 LCSIGA(NMLO), IXSIGA(NMLO), - 8 LCTMPA(NMLO), IXTMPA(NMLO), - 9 LCMIXA(NMLO), IXMIXA(NMLO), - A LCRADA(27) , IXRADA(27) , - B LCRDAC(27) , IXRDAC(27) -C - REAL*8 TENS(-75:75) - REAL PTOVS(41) - INTEGER IDXHGT(18) - DATA (TENS(I),I=-75,-1,+1) - 1 /1.0D-75,1.0D-74,1.0D-73,1.0D-72,1.0D-71,1.0D-70,1.0D-69,1.0D-68, - 2 1.0D-67,1.0D-66,1.0D-65,1.0D-64,1.0D-63,1.0D-62,1.0D-61,1.0D-60, - 3 1.0D-59,1.0D-58,1.0D-57,1.0D-56,1.0D-55,1.0D-54,1.0D-53,1.0D-52, - 4 1.0D-51,1.0D-50,1.0D-49,1.0D-48,1.0D-47,1.0D-46,1.0D-45,1.0D-44, - 5 1.0D-43,1.0D-42,1.0D-41,1.0D-40,1.0D-39,1.0D-38,1.0D-37,1.0D-36, - 6 1.0D-35,1.0D-34,1.0D-33,1.0D-32,1.0D-31,1.0D-30,1.0D-29,1.0D-28, - 7 1.0D-27,1.0D-26,1.0D-25,1.0D-24,1.0D-23,1.0D-22,1.0D-21,1.0D-20, - 8 1.0D-19,1.0D-18,1.0D-17,1.0D-16,1.0D-15,1.0D-14,1.0D-13,1.0D-12, - 9 1.0D-11,1.0D-10,1.0D-09,1.0D-08,1.0D-07,1.0D-06,1.0D-05,1.0D-04, - A 1.0D-03,1.0D-02,1.0D-01/ - DATA (TENS(I),I=75,0,-1) - 1 /1.0D+75,1.0D+74,1.0D+73,1.0D+72,1.0D+71,1.0D+70,1.0D+69,1.0D+68, - 2 1.0D+67,1.0D+66,1.0D+65,1.0D+64,1.0D+63,1.0D+62,1.0D+61,1.0D+60, - 3 1.0D+59,1.0D+58,1.0D+57,1.0D+56,1.0D+55,1.0D+54,1.0D+53,1.0D+52, - 4 1.0D+51,1.0D+50,1.0D+49,1.0D+48,1.0D+47,1.0D+46,1.0D+45,1.0D+44, - 5 1.0D+43,1.0D+42,1.0D+41,1.0D+40,1.0D+39,1.0D+38,1.0D+37,1.0D+36, - 6 1.0D+35,1.0D+34,1.0D+33,1.0D+32,1.0D+31,1.0D+30,1.0D+29,1.0D+28, - 7 1.0D+27,1.0D+26,1.0D+25,1.0D+24,1.0D+23,1.0D+22,1.0D+21,1.0D+20, - 8 1.0D+19,1.0D+18,1.0D+17,1.0D+16,1.0D+15,1.0D+14,1.0D+13,1.0D+12, - 9 1.0D+11,1.0D+10,1.0D+09,1.0D+08,1.0D+07,1.0D+06,1.0D+05,1.0D+04, - A 1.0D+03,1.0D+02,1.0D+01,1.0 / - DATA PTOVS/0.1,0.2,0.5,1.,1.5,2.,3., - 1 4.,5.,7.,10.,15.,20.,25.,30., - 2 50.,60.,70.,85.,100.,115.,135., - 3 150.,200.,250.,300.,350.,400., - 4 430.,475.,500.,570.,620.,670., - 5 700.,780.,850.,920.,950.,1000.,1070./ - DATA IDXHGT/4,7,10,11,13,15,16,18,20,23,24,25,26,28,31,35,37,40/ -C - DATA IFIRST/0/ -C -C READ IN AND DECODE BUFR MESSAGE -C - IF(IFIRST.EQ.0) THEN - IENFIL = 0 - INDEX0 = 0 - INDEX1 = 0 - INDEX2 = 0 - ENDIF - IF(INDEX0.EQ.0) THEN - DO 2 I=1,40 - IPTR0(I) = 0 - 2 CONTINUE - DO 4 I=1,20 - IDENT0(I) = 0 - 4 CONTINUE - READ(IUNIT0,END=9970) CMSGA - REWIND IUBTBL - REWIND IUDTBL - ENDIF -C - 1000 CONTINUE - CALL W3FI78(IPTR0,IDENT0,MSGA,ISTCK0,MSTCK0,KDATA0,KNR0,INDEX0, - 1 MXIRPT,MXIDSC,IUBTBL,IUDTBL) - IF(IPTR0(1).EQ.99) THEN - INDEX0 = 0 - READ(IUNIT0,END=9970) CMSGA - GO TO 1000 - ENDIF -C -C CHECK FOR BUFR DECODING ERROR -C - IF(INDEX0.EQ.1) THEN - IF(IPTR0(1).NE.0) THEN - IERR = 1111 - RETURN - ENDIF -C -C CHECK FOR DELAYED REPLICATION -C - IF(IPTR0(39).NE.0) THEN - IERR = 2222 - RETURN - ENDIF - NRPTS = IDENT0(14) - NDESC = IPTR0(31) -C -C CHECK FOR NON-UNIFORM REPORTS -C - DO 10 I = 1 , NRPTS - IF(KNR0(I).NE.NDESC) THEN - IERR = 3333 - RETURN - ENDIF - 10 CONTINUE - NDESC = IPTR0(31) + IPTR0(24) - ENDIF -C - IF(IFIRST.EQ.0) THEN - CALL FI8101(MSTCK0,KDATA0,NDESC) - ENDIF - IF(INDEX1.EQ.0) THEN - DO 12 I=1,40 - IPTR1(I) = 0 - 12 CONTINUE - DO 14 I=1,20 - IDENT1(I) = 0 - 14 CONTINUE - READ(IUNIT1,END=9980) CMSGA - REWIND IUBTBL - REWIND IUDTBL - ENDIF -C - 1100 CONTINUE - CALL W3FI78(IPTR1,IDENT1,MSGA,ISTCK1,MSTCK1,KDATA1,KNR1,INDEX1, - 1 MXRPTR,MXDSCR,IUBTBL,IUDTBL) - IF(IPTR1(1).EQ.99) THEN - INDEX1 = 0 - READ(IUNIT1,END=9980) CMSGA - GO TO 1100 - ENDIF -C -C CHECK FOR BUFR DECODING ERROR -C - IF(INDEX1.EQ.1) THEN - IF(IPTR1(1).NE.0) THEN - IERR = 4444 - RETURN - ENDIF -C -C CHECK FOR DELAYED REPLICATION -C - IF(IPTR1(39).NE.0) THEN - IERR = 5555 - RETURN - ENDIF - NRPTS = IDENT1(14) - NDESC = IPTR1(31) -C -C CHECK FOR NON-UNIFORM REPORTS -C - DO 20 I = 1 , NRPTS - IF(KNR1(I).NE.NDESC) THEN - IERR = 6666 - RETURN - ENDIF - 20 CONTINUE - NDESC = IPTR1(31) + IPTR1(24) - ENDIF -C - IF(IFIRST.EQ.0) THEN - CALL FI8102(MSTCK1,KDATA1,NDESC) - ENDIF - IF(INDEX2.EQ.0) THEN - DO 22 I=1,40 - IPTR2(I) = 0 - 22 CONTINUE - DO 24 I=1,20 - IDENT2(I) = 0 - 24 CONTINUE - READ(IUNIT2,END=9990) CMSGA - REWIND IUBTBL - REWIND IUDTBL - ENDIF -C - 1200 CONTINUE - CALL W3FI78(IPTR2,IDENT2,MSGA,ISTCK2,MSTCK2,KDATA2,KNR2,INDEX2, - 1 MXRPTA,MXDSCA,IUBTBL,IUDTBL) - IF(IPTR2(1).EQ.99) THEN - INDEX2 = 0 - READ(IUNIT2,END=9990) CMSGA - GO TO 1200 - ENDIF -C -C CHECK FOR BUFR DECODING ERROR -C - IF(INDEX2.EQ.1) THEN - IF(IPTR2(1).NE.0) THEN - IERR = 7777 - RETURN - ENDIF -C -C CHECK FOR DELAYED REPLICATION -C - IF(IPTR2(39).NE.0) THEN - IERR = 8888 - RETURN - ENDIF - NRPTS = IDENT2(14) - NDESC = IPTR2(31) -C -C CHECK FOR NON-UNIFORM REPORTS -C - DO 30 I = 1 , NRPTS - IF(KNR2(I).NE.NDESC) THEN - IERR = 9999 - RETURN - ENDIF - 30 CONTINUE - NDESC = IPTR2(31) + IPTR2(24) - ENDIF -C - IF(IFIRST.EQ.0) THEN - CALL FI8103(MSTCK2,KDATA2,NDESC) - IFIRST = 1 - ENDIF -C - IF(LWNMCI.EQ.LWNMCR .AND. LWNMCR.EQ.LWNMCA) THEN - DO 1250 K = 1 , LWNMCR - IF(KDATA0(INDEX0,LCNMCI+K-1).NE.KDATA1(INDEX1,LCNMCR+K-1) .OR. - 1 KDATA1(INDEX1,LCNMCR+K-1).NE.KDATA2(INDEX2,LCNMCA+K-1)) - 2 THEN - IERR = 99999 - RETURN - ENDIF - 1250 CONTINUE - ELSE - IERR = 99999 - RETURN - ENDIF - IF(KDATA0(INDEX0,LCLATI).NE.KDATA1(INDEX1,LCLATR) .OR. - 1 KDATA1(INDEX1,LCLATR).NE.KDATA2(INDEX2,LCLATA) .OR. - 2 IXLATI.NE.IXLATR .OR. IXLATR.NE.IXLATA) THEN - IERR = 88888 - RETURN - ENDIF - IF(KDATA0(INDEX0,LCLONI).NE.KDATA1(INDEX1,LCLONR) .OR. - 1 KDATA1(INDEX1,LCLONR).NE.KDATA2(INDEX2,LCLONA) .OR. - 2 IXLONI.NE.IXLONR .OR. IXLONR.NE.IXLONA) THEN - IERR = 77777 - RETURN - ENDIF - IF(KDATA0(INDEX0,LCSTII).NE.KDATA1(INDEX1,LCSTIR) .OR. - 1 KDATA1(INDEX1,LCSTIR).NE.KDATA2(INDEX2,LCSTIA)) THEN - IERR = 66666 - RETURN - ENDIF - DO 1300 K = 1 , NMLO - IF(KDATA1(INDEX1,LCSIGF(K)).NE.KDATA2(INDEX2,LCSIGA(K)) .OR. - 1 IXSIGF(K).NE.IXSIGA(K)) THEN - IERR = 55555 - RETURN - ENDIF - 1300 CONTINUE - ISSBCT = KDATA0(INDEX0,LCSSBC) - IBUFTN(1) = ISSBCT / 1000 - ISATID = KDATA0(INDEX0,LCSTII) - IF(ISATID.EQ.203) THEN - IBUFTN(2) = 1 - IBUFTN(3) = 1 - ELSE IF(ISATID.EQ.204) THEN - IBUFTN(2) = 2 - IBUFTN(3) = 2 - ELSE IF(ISATID.EQ.205) THEN - IBUFTN(2) = 3 - IBUFTN(3) = 3 - ENDIF - IBUFTN(12) = MOD(ISSBCT,1000) - IBUFTN(13) = KDATA0(INDEX0,LCMBBX) - XLAT = KDATA0(INDEX0,LCLATI) * TENS(IXLATI) - IBUFTN(14) = 128.0 * XLAT + SIGN(0.5,XLAT) - IF(XLAT.GE.60.0) THEN - LATZON = 1 - ELSE IF(XLAT.GE.45.0) THEN - LATZON = 2 - ELSE IF(XLAT.GE.30.0) THEN - LATZON = 3 - ELSE IF(XLAT.GE.15.0) THEN - LATZON = 4 - ELSE IF(XLAT.GT.-15.0) THEN - LATZON = 5 - ELSE IF(XLAT.GT.-30.0) THEN - LATZON = 6 - ELSE IF(XLAT.GT.-45.0) THEN - LATZON = 7 - ELSE IF(XLAT.GT.-60.0) THEN - LATZON = 8 - ELSE - LATZON = 9 - ENDIF - XLON = KDATA0(INDEX0,LCLONI) * TENS(IXLONI) - IBUFTN(15) = 128.0 * XLON + SIGN(0.5,XLON) - IYR = MOD(KDATA0(INDEX0,LCYRI),100) - IBUFTN(16) = 100 * IYR + KDATA0(INDEX0,LCMONI) - IBUFTN(17) = 100 * KDATA0(INDEX0,LCDAYI) + KDATA0(INDEX0,LCHRI) - IBUFTN(18) = 100 * KDATA0(INDEX0,LCMINI) + KDATA0(INDEX0,LCSECI) - INSTRU = KDATA0(INDEX0,LCINSI) - IRETMT = KDATA0(INDEX0,LCRTMI) - IF(MOD(INSTRU,128).GE.64) THEN - ISSUFL = 1 - ELSE - ISSUFL = 0 - ENDIF - IF(INSTRU.GE.256) THEN - IF(INSTRU.GE.384) THEN - MCL3 = 1 - ELSE - MCL3 = 2 - ENDIF - IF(MOD(IRETMT,64).GE.32) THEN - MCL1 = 1 - MCL2 = 1 - ICLOUD = 110 + MCL3 - ELSE IF(MOD(IRETMT,64).GE.16) THEN - MCL1 = 2 - MCL2 = 1 - ICLOUD = 210 + MCL3 - ELSE IF(MOD(IRETMT,64).GE.8) THEN - MCL1 = 2 - MCL2 = 2 - ICLOUD = 220 + MCL3 - ENDIF - ELSE IF(INSTRU.GE.128) THEN - MCL1 = 0 - MCL2 = 0 - ICLOUD = 3 - ENDIF - IF(INSTRU.EQ.448) THEN - ICCFLG = 1 - ELSE IF(INSTRU.EQ.384) THEN - ICCFLG = 2 - ELSE IF(INSTRU.EQ.256) THEN - ICCFLG = 3 - ELSE IF(INSTRU.EQ.320) THEN - ICCFLG = 4 - ELSE IF(INSTRU.EQ.128) THEN - ICCFLG = 5 - ELSE IF(INSTRU.EQ.192) THEN - ICCFLG = 6 - ELSE IF(INSTRU.EQ.64) THEN - ICCFLG = 7 - ENDIF - IF(IRETMT.GE.64) THEN - METRET = 0 - ELSE IF(MOD(IRETMT,8).GE.4) THEN - METRET = 1 - ENDIF - PLST = 0.01 * KDATA0(INDEX0,LCPLSI) * TENS(IXPLSI) - DO 1500 L=1,40 - IF(ABS(PLST - PTOVS(L)).LT.0.1) LSTOVS = L - 1500 CONTINUE - LNDSEA = KDATA0(INDEX0,LCLSI) - NGTDAY = KDATA0(INDEX0,LCNDI) - IBUFTN(19) = 10000 * LNDSEA + - 1 1000 * NGTDAY + - 2 100 * METRET + - 3 LSTOVS - IF(KDATA0(INDEX0,LCICOI).EQ.20480) THEN - ICCO3 = 1 - ELSE IF(KDATA0(INDEX0,LCICOI).EQ.16384) THEN - ICCO3 = 2 - ELSE IF(KDATA0(INDEX0,LCICOI).EQ.12288) THEN - ICCO3 = 3 - ELSE IF(KDATA0(INDEX0,LCICOI).EQ.8192) THEN - ICCO3 = 4 - ELSE IF(KDATA0(INDEX0,LCICOI).EQ.0) THEN - ICCO3 = 0 - ENDIF - IF(KDATA0(INDEX0,LCICTI).EQ.262144) THEN - ICTROP = 1 - ELSE IF(KDATA0(INDEX0,LCICTI).EQ.131072) THEN - ICTROP = 2 - ENDIF - IF(METRET.EQ.0) THEN - ICCMVS = 0 - ELSE IF(ICCFLG.LE.3) THEN - IF(MCL1.GE.1 .AND. MCL2.EQ.1) THEN - ICCMVS = 1 - ELSE IF(MCL1.EQ.2 .AND. MCL2.EQ.2) THEN - IF(LNDSEA.EQ.1) THEN - ICCMVS = 2 - ELSE - ICCMVS = 3 - ENDIF - ENDIF - ELSE IF(ICCFLG.GE.5) THEN - IF(LNDSEA.EQ.1) THEN - ICCMVS = 4 - ELSE - ICCMVS = 5 - ENDIF - ELSE - ICCMVS = 6 - ENDIF - IBUFTN(20) = 10000 * KDATA0(INDEX0,LCSTUI) + - 1 100 * ICCMVS + - 2 10 * ICCO3 + - 3 ICTROP - IBUFTN(21) = 1000 * KDATA0(INDEX0,LCH8FI) + - 1 100 * ISSUFL + - 2 10 * LATZON + - 3 ICCFLG - IBUFTN(22) = ICLOUD - IF(LNDSEA.EQ.0) THEN - IPBIN = LATZON - ELSE IF(NGTDAY.EQ.1) THEN - IPBIN = LATZON + 9 - ELSE - IPBIN = LATZON + 18 - ENDIF - IBUFTN(23) = 10000 * KDATA0(INDEX0,LCSSTA) + - 1 1000 * KDATA0(INDEX0,LCFGAP) + - 2 10 * IPBIN + - 3 KDATA0(INDEX0,LCFLFI) - SZANG = KDATA0(INDEX0,LCSZAN) * TENS(IXSZAN) - IBUFTN(24) = 128.0 * SZANG + SIGN(0.5,SZANG) - SZALO = KDATA0(INDEX0,LCLSZA) * TENS(IXLSZA) - IBUFTN(25) = 128.0 * SZALO + SIGN(0.5,SZALO) - DO 1600 L = 1 , 40 - TEMP = KDATA0(INDEX0,LCT40I(L)) * TENS(IXT40I(L)) - IBUFTN(L+25) = 64.0 * TEMP + 0.5 - 1600 CONTINUE - IHGT = 0 - DO 1700 L = 1 , 40 - IF(KDATA0(INDEX0,LCH40I(L)).NE.999999) THEN - GEO = KDATA0(INDEX0,LCH40I(L)) * TENS(IXH40I(L)) - IHGT = IHGT + 1 - GEOOPR(IDXHGT(IHGT)) = GEO - IF(IHGT.LE.9) THEN - IBUFTN(IHGT+65) = 0.1 * GEO + 0.5 - ELSE - IBUFTN(IHGT+65) = GEO + 0.5 - ENDIF - ENDIF - 1700 CONTINUE - DO 1800 L = 1 , 15 - RATMIX = KDATA0(INDEX0,LCM40I(L+25)) * TENS(IXM40I(L+25)) - IBUFTN(L+83) = 256000.0 * RATMIX + 0.5 - 1800 CONTINUE - TEMP = KDATA0(INDEX0,LCTTRI) * TENS(IXTTRI) - IBUFTN(99) = 64.0 * TEMP + 0.5 - PRES = KDATA0(INDEX0,LCPTRI) * TENS(IXPTRI) - IBUFTN(100) = 0.01 * PRES + 0.5 - OZONE = KDATA0(INDEX0,LCOZON) * TENS(IXOZON) - IBUFTN(101) = OZONE + 0.5 - DO 1900 L = 1 , 19 - IF(KDATA0(INDEX0,LCRADI(L)).NE.999999) THEN - RAD = KDATA0(INDEX0,LCRADI(L)) * TENS(IXRADI(L)) - IBUFTN(L+101) = 64.0 * RAD + 0.5 - ELSE - IBUFTN(L+101) = 32767 - ENDIF - 1900 CONTINUE - IF(KDATA0(INDEX0,LCRADI(20)).NE.999999) THEN - RAD = KDATA0(INDEX0,LCRADI(20)) * TENS(IXRADI(20)) - IBUFTN(121) = 16.0 * RAD + 0.5 - ELSE - IBUFTN(121) = 32767 - ENDIF - DO 2000 L = 21 , 27 - IF(KDATA0(INDEX0,LCRADI(L)).NE.999999) THEN - RAD = KDATA0(INDEX0,LCRADI(L)) * TENS(IXRADI(L)) - IBUFTN(L+101) = 64.0 * RAD + 0.5 - ELSE - IBUFTN(L+101) = 32767 - ENDIF - 2000 CONTINUE - AVGNST = KDATA0(INDEX0,LCAVNS) * TENS(IXAVNS) - IBUFTN(142) = 1024.0 * AVGNST + 0.5 - IF(KDATA0(INDEX0,LCSALB).NE.999999) THEN - SFCALB = KDATA0(INDEX0,LCSALB) * TENS(IXSALB) - IBUFTN(143) = SFCALB + 0.5 - ELSE - IBUFTN(143) = -899 - ENDIF - SKINT = KDATA0(INDEX0,LCSKNI) * TENS(IXSKNI) - IBUFTN(144) = 64.0 * SKINT + 0.5 - SFCHGT = KDATA0(INDEX0,LCSFHI) * TENS(IXSFHI) - IBUFTN(145) = SFCHGT + 0.5 - SST15 = KDATA0(INDEX0,LCST15) * TENS(IXST15) - IBUFTN(166) = 64.0 * SST15 + 0.5 - DO 2100 L = 1 , 40 - TEMP = KDATA0(INDEX0,LCT4GI(L)) * TENS(IXT4GI(L)) - IBUFTN(L+167) = 64.0 * TEMP + 0.5 - 2100 CONTINUE - DO 2200 L = 1 , 15 - RATMIX = KDATA0(INDEX0,LCM4GI(L+25)) * TENS(IXM4GI(L+25)) - IBUFTN(L+207) = 256000.0 * RATMIX + 0.5 - 2200 CONTINUE - DO 2300 L = 1 , 19 - IF(KDATA0(INDEX0,LCRDGI(L)).NE.999999) THEN - RAD = KDATA0(INDEX0,LCRDGI(L)) * TENS(IXRDGI(L)) - IBUFTN(L+222) = 64.0 * RAD + 0.5 - ELSE - IBUFTN(L+222) = 32767 - ENDIF - 2300 CONTINUE - IF(KDATA0(INDEX0,LCRDGI(20)).NE.999999) THEN - RAD = KDATA0(INDEX0,LCRDGI(20)) * TENS(IXRDGI(20)) - IBUFTN(242) = 16.0 * RAD + 0.5 - ELSE - IBUFTN(242) = 32767 - ENDIF - DO 2400 L = 21 , 27 - IF(KDATA0(INDEX0,LCRDGI(L)).NE.999999) THEN - RAD = KDATA0(INDEX0,LCRDGI(L)) * TENS(IXRDGI(L)) - IBUFTN(L+222) = 64.0 * RAD + 0.5 - ELSE - IBUFTN(L+222) = 32767 - ENDIF - 2400 CONTINUE - TEMP = KDATA1(INDEX1,LCSKNT) * TENS(IXSKNT) - IBUFTN(251) = 64.0 * TEMP + 0.5 - XLAT = KDATA1(INDEX1,LCLATR) * TENS(IXLATR) - IBUFTN(252) = 128.0 * XLAT + SIGN(0.5,XLAT) - IF(XLAT.GE.60.0) THEN - LATZON = 1 - ELSE IF(XLAT.GE.45.0) THEN - LATZON = 2 - ELSE IF(XLAT.GE.30.0) THEN - LATZON = 3 - ELSE IF(XLAT.GE.15.0) THEN - LATZON = 4 - ELSE IF(XLAT.GT.-15.0) THEN - LATZON = 5 - ELSE IF(XLAT.GT.-30.0) THEN - LATZON = 6 - ELSE IF(XLAT.GT.-45.0) THEN - LATZON = 7 - ELSE IF(XLAT.GT.-60.0) THEN - LATZON = 8 - ELSE - LATZON = 9 - ENDIF - XLON = KDATA1(INDEX1,LCLONR) * TENS(IXLONR) - IBUFTN(253) = 128.0 * XLON + SIGN(0.5,XLON) - INSTRU = KDATA1(INDEX1,LCINSR) - IRETMT = KDATA1(INDEX1,LCRTMR) - IF(MOD(INSTRU,128).GE.64) THEN - ISSUFL = 1 - ELSE - ISSUFL = 0 - ENDIF - IF(INSTRU.GE.256) THEN - IF(INSTRU.GE.384) THEN - MCL3 = 1 - ELSE - MCL3 = 2 - ENDIF - IF(MOD(IRETMT,64).GE.32) THEN - MCL1 = 1 - MCL2 = 1 - ICLOUD = 110 + MCL3 - ELSE IF(MOD(IRETMT,64).GE.16) THEN - MCL1 = 2 - MCL2 = 1 - ICLOUD = 210 + MCL3 - ELSE IF(MOD(IRETMT,64).GE.8) THEN - MCL1 = 2 - MCL2 = 2 - ICLOUD = 220 + MCL3 - ENDIF - ELSE IF(INSTRU.GE.128) THEN - MCL1 = 0 - MCL2 = 0 - ICLOUD = 3 - ENDIF - IF(INSTRU.EQ.448) THEN - ICCFLG = 1 - ELSE IF(INSTRU.EQ.384) THEN - ICCFLG = 2 - ELSE IF(INSTRU.EQ.256) THEN - ICCFLG = 3 - ELSE IF(INSTRU.EQ.320) THEN - ICCFLG = 4 - ELSE IF(INSTRU.EQ.128) THEN - ICCFLG = 5 - ELSE IF(INSTRU.EQ.192) THEN - ICCFLG = 6 - ELSE IF(INSTRU.EQ.64) THEN - ICCFLG = 7 - ENDIF - IF(IRETMT.GE.64) THEN - METRET = 0 - ELSE IF(MOD(IRETMT,8).GE.4) THEN - METRET = 1 - ENDIF - LNDSEA = KDATA1(INDEX1,LCLSR) - NGTDAY = KDATA1(INDEX1,LCNDR) - PLST = 0.01 * KDATA1(INDEX1,LCPLSR) * TENS(IXPLSR) - DO 2500 L=1,40 - IF(ABS(PLST - PTOVS(L)).LT.0.1) LST = L - 2500 CONTINUE - IBUFTN(254) = 10000 * LNDSEA + - 1 1000 * NGTDAY + - 2 100 * METRET + - 3 LST - IF(METRET.EQ.0) THEN - ICCMVS = 0 - ELSE IF(ICCFLG.LE.3) THEN - IF(MCL1.GE.1 .AND. MCL2.EQ.1) THEN - ICCMVS = 1 - ELSE IF(MCL1.EQ.2 .AND. MCL2.EQ.2) THEN - IF(LNDSEA.EQ.1) THEN - ICCMVS = 2 - ELSE - ICCMVS = 3 - ENDIF - ENDIF - ELSE IF(ICCFLG.GE.5) THEN - IF(LNDSEA.EQ.1) THEN - ICCMVS = 4 - ELSE - ICCMVS = 5 - ENDIF - ELSE - ICCMVS = 6 - ENDIF - IF(KDATA1(INDEX1,LCICOR).EQ.20480) THEN - ICCO3 = 1 - ELSE IF(KDATA1(INDEX1,LCICOR).EQ.16384) THEN - ICCO3 = 2 - ELSE IF(KDATA1(INDEX1,LCICOR).EQ.12288) THEN - ICCO3 = 3 - ELSE IF(KDATA1(INDEX1,LCICOR).EQ.8192) THEN - ICCO3 = 4 - ELSE IF(KDATA1(INDEX1,LCICOR).EQ.0) THEN - ICCO3 = 0 - ENDIF - IF(KDATA1(INDEX1,LCICTR).EQ.262144) THEN - ICTROP = 1 - ELSE IF(KDATA1(INDEX1,LCICTR).EQ.131072) THEN - ICTROP = 2 - ENDIF - IBUFTN(255) = 10000 * KDATA1(INDEX1,LCSTUR) + - 1 100 * ICCMVS + - 2 10 * ICCO3 + - 3 ICTROP - IBUFTN(256) = 1000 * KDATA1(INDEX1,LCH8FR) + - 1 100 * ISSUFL + - 2 10 * LATZON + - 3 ICCFLG - TEMP = KDATA1(INDEX1,LCTTRR) * TENS(IXTTRR) - IBUFTN(257) = 64.0 * TEMP + 0.5 - PRES = KDATA1(INDEX1,LCPTRR) * TENS(IXPTRR) - IBUFTN(258) = 0.01 * PRES + 0.5 - DO 2600 L = 1 , 19 - IF(KDATA1(INDEX1,LCRADF(L)).NE.999999) THEN - RAD = KDATA1(INDEX1,LCRADF(L)) * TENS(IXRADF(L)) - IBUFTN(L+258) = 64.0 * RAD + 0.5 - ELSE - IBUFTN(L+258) = 32767 - ENDIF - 2600 CONTINUE - IF(KDATA1(INDEX1,LCRADF(20)).NE.999999) THEN - RAD = KDATA1(INDEX1,LCRADF(20)) * TENS(IXRADF(20)) - IBUFTN(278) = 16.0 * RAD + 0.5 - ELSE - IBUFTN(278) = 32767 - ENDIF - DO 2700 L = 21 , 27 - IF(KDATA1(INDEX1,LCRADF(L)).NE.999999) THEN - RAD = KDATA1(INDEX1,LCRADF(L)) * TENS(IXRADF(L)) - IBUFTN(L+258) = 64.0 * RAD + 0.5 - ELSE - IBUFTN(L+258) = 32767 - ENDIF - 2700 CONTINUE - DO 2800 L = 1 , 19 - IF(KDATA1(INDEX1,LCRDFC(L)).NE.999999) THEN - RAD = KDATA1(INDEX1,LCRDFC(L)) * TENS(IXRDFC(L)) - IBUFTN(L+285) = 64.0 * RAD + 0.5 - ELSE - IBUFTN(L+285) = 32767 - ENDIF - 2800 CONTINUE - IF(KDATA1(INDEX1,LCRDFC(20)).NE.999999) THEN - RAD = KDATA1(INDEX1,LCRDFC(20)) * TENS(IXRDFC(20)) - IBUFTN(305) = 16.0 * RAD + 0.5 - ELSE - IBUFTN(305) = 32767 - ENDIF - DO 2900 L = 21 , 27 - IF(KDATA1(INDEX1,LCRDFC(L)).NE.999999) THEN - RAD = KDATA1(INDEX1,LCRDFC(L)) * TENS(IXRDFC(L)) - IBUFTN(L+285) = 64.0 * RAD + 0.5 - ELSE - IBUFTN(L+285) = 32767 - ENDIF - 2900 CONTINUE - TEMP = KDATA1(INDEX1,LCSKNF) * TENS(IXSKNF) - IBUFTN(313) = 64.0 * TEMP + 0.5 - SKINT = KDATA1(INDEX1,LCSKNR) * TENS(IXSKNR) - IBUFTN(314) = 64.0 * SKINT + 0.5 - DO 3000 L = 1 , NMLO - TEMP = KDATA1(INDEX1,LCTMPI(L)) * TENS(IXTMPI(L)) - IBUFTN(L+314) = 64.0 * TEMP + 0.5 - 3000 CONTINUE - TEMP = KDATA1(INDEX1,LCT41I) * TENS(IXT41I) - IBUFTN(343) = 64.0 * TEMP + 0.5 - DO 3100 L = 1 , 19 - IF(KDATA1(INDEX1,LCRADR(L)).NE.999999) THEN - RAD = KDATA1(INDEX1,LCRADR(L)) * TENS(IXRADR(L)) - IBUFTN(L+343) = 64.0 * RAD + 0.5 - ELSE - IBUFTN(L+343) = 32767 - ENDIF - 3100 CONTINUE - IF(KDATA1(INDEX1,LCRADR(20)).NE.999999) THEN - RAD = KDATA1(INDEX1,LCRADR(20)) * TENS(IXRADR(20)) - IBUFTN(363) = 16.0 * RAD + 0.5 - ELSE - IBUFTN(363) = 32767 - ENDIF - DO 3200 L = 21 , 27 - IF(KDATA1(INDEX1,LCRADR(L)).NE.999999) THEN - RAD = KDATA1(INDEX1,LCRADR(L)) * TENS(IXRADR(L)) - IBUFTN(L+343) = 64.0 * RAD + 0.5 - ELSE - IBUFTN(L+343) = 32767 - ENDIF - 3200 CONTINUE - DO 3300 L = 1 , 19 - IF(KDATA1(INDEX1,LCRDRC(L)).NE.999999) THEN - RAD = KDATA1(INDEX1,LCRDRC(L)) * TENS(IXRDRC(L)) - IBUFTN(L+370) = 64.0 * RAD + 0.5 - ELSE - IBUFTN(L+370) = 32767 - ENDIF - 3300 CONTINUE - IF(KDATA1(INDEX1,LCRDRC(20)).NE.999999) THEN - RAD = KDATA1(INDEX1,LCRDRC(20)) * TENS(IXRDRC(20)) - IBUFTN(390) = 16.0 * RAD + 0.5 - ELSE - IBUFTN(390) = 32767 - ENDIF - DO 3400 L = 21 , 27 - IF(KDATA1(INDEX1,LCRDRC(L)).NE.999999) THEN - RAD = KDATA1(INDEX1,LCRDRC(L)) * TENS(IXRDRC(L)) - IBUFTN(L+370) = 64.0 * RAD + 0.5 - ELSE - IBUFTN(L+370) = 32767 - ENDIF - 3400 CONTINUE - IBUFTN(398) = KDATA1(INDEX1,LCFCYC) - SFCHGT = KDATA1(INDEX1,LCSFHF) * TENS(IXSFHF) - IBUFTN(399) = SFCHGT + SIGN(0.5,SFCHGT) - PSFGES = 0.01 * KDATA1(INDEX1,LCPSFF) * TENS(IXPSFF) - IBUFTN(400) = AINT(50.0 * PSFGES + 0.5) - 32000.0 - DO 3500 L = 1 , NMLO - TGES(L) = KDATA1(INDEX1,LCTMPF(L)) * TENS(IXTMPF(L)) - PGES(L) = KDATA1(INDEX1,LCSIGF(L)) * TENS(IXSIGF(L)) * PSFGES - IBUFTN(L+400) = 64.0 * TGES(L) + 0.5 - 3500 CONTINUE - DO 3600 L = 1 , NMLO - WGES(L) = 1000.0 * KDATA1(INDEX1,LCMIXF(L)) * TENS(IXMIXF(L)) - IBUFTN(L+428) = 256.0 * WGES(L) + 0.5 - 3600 CONTINUE - DO 3700 L = 1 , NML - TEMP = KDATA1(INDEX1,LCTMPR(L)) * TENS(IXTMPR(L)) - IBUFTN(L+456) = 64.0 * TEMP + 0.5 - 3700 CONTINUE - DO 3800 L = 1 , NUL - RATMIX = KDATA1(INDEX1,LCMIXR(NML-NUL+L)) * - 1 TENS(IXMIXR(NML-NUL+L)) - IBUFTN(L+526) = 256000.0 * RATMIX + 0.5 - 3800 CONTINUE - DO 3900 L = 1 , 19 - IF(KDATA2(INDEX2,LCRADA(L)).NE.999999) THEN - RAD = KDATA2(INDEX2,LCRADA(L)) * TENS(IXRADA(L)) - IBUFTN(L+566) = 64.0 * RAD + 0.5 - ELSE - IBUFTN(L+566) = 32767 - ENDIF - 3900 CONTINUE - IF(LSTOVS.EQ.40) THEN - CALL FI8104(PSFGES,PGES,TGES,WGES,PTOVS,TGES40,WGES40,NMLO) - CALL FI8105(PTOVS,TGES40,WGES40,GEOGES,NBUG) - CALL FI8106(PTOVS,GEOOPR,GEOGES,STDPTT,STDPLW,STDPUP,NBUG) - IBUFTN(130) = 512.0 * STDPLW + SIGN(0.5,STDPLW) - IBUFTN(131) = 512.0 * STDPUP + SIGN(0.5,STDPUP) - IBUFTN(132) = 512.0 * STDPTT + SIGN(0.5,STDPTT) - ELSE - IBUFTN(130) = 32767 - IBUFTN(131) = 32767 - IBUFTN(132) = 32767 - ENDIF - IF(KDATA2(INDEX2,LCRADA(20)).NE.999999) THEN - RAD = KDATA2(INDEX2,LCRADA(20)) * TENS(IXRADA(20)) - IBUFTN(586) = 16.0 * RAD + 0.5 - ELSE - IBUFTN(586) = 32767 - ENDIF - DO 4000 L = 21 , 27 - IF(KDATA2(INDEX2,LCRADA(L)).NE.999999) THEN - RAD = KDATA2(INDEX2,LCRADA(L)) * TENS(IXRADA(L)) - IBUFTN(L+566) = 64.0 * RAD + 0.5 - ELSE - IBUFTN(L+566) = 32767 - ENDIF - 4000 CONTINUE - DO 4100 L = 1 , 19 - IF(KDATA2(INDEX2,LCRDAC(L)).NE.999999) THEN - RAD = KDATA2(INDEX2,LCRDAC(L)) * TENS(IXRDAC(L)) - IBUFTN(L+593) = 64.0 * RAD + 0.5 - ELSE - IBUFTN(L+593) = 32767 - ENDIF - 4100 CONTINUE - IF(KDATA2(INDEX2,LCRDAC(20)).NE.999999) THEN - RAD = KDATA2(INDEX2,LCRDAC(20)) * TENS(IXRDAC(20)) - IBUFTN(613) = 16.0 * RAD + 0.5 - ELSE - IBUFTN(613) = 32767 - ENDIF - DO 4200 L = 21 , 27 - IF(KDATA2(INDEX2,LCRDAC(L)).NE.999999) THEN - RAD = KDATA2(INDEX2,LCRDAC(L)) * TENS(IXRDAC(L)) - IBUFTN(L+593) = 64.0 * RAD + 0.5 - ELSE - IBUFTN(L+593) = 32767 - ENDIF - 4200 CONTINUE - PRES = KDATA2(INDEX2,LCPSFA) * TENS(IXPSFA) - IBUFTN(621) = AINT(50.0 * (0.01 * PRES) + 0.5) - 32000.0 - DO 4300 L = 1 , NMLO - TEMP = KDATA2(INDEX2,LCTMPA(L)) * TENS(IXTMPA(L)) - IBUFTN(L+621) = 64.0 * TEMP + 0.5 - 4300 CONTINUE - DO 4400 L = 1 , NMLO - RATMIX = KDATA2(INDEX2,LCMIXA(L)) * TENS(IXMIXA(L)) - IBUFTN(L+649) = 256000.0 * RATMIX + 0.5 - 4400 CONTINUE - IBUFTN(678) = MOD(KDATA2(INDEX2,LCYRA),100) - IBUFTN(679) = KDATA2(INDEX2,LCMONA) - IBUFTN(680) = KDATA2(INDEX2,LCDAYA) - IBUFTN(681) = KDATA2(INDEX2,LCHRA) - IBUFTN(682) = KDATA2(INDEX2,LCMINA) - IERR = 0 - RETURN -C - 9970 CONTINUE - WRITE(6,1001) IUNIT0 - 1001 FORMAT(' END OF FILE ON UNIT ',I5) - IENFIL = IENFIL + 1 - IF(IENFIL.EQ.3) GO TO 99999 - ICOUNT = 0 - 9975 CONTINUE - READ(IUNIT1,END=9978) CMSGA - ICOUNT = ICOUNT + 1 - GO TO 9975 -C - 9978 CONTINUE - INDEX1 = 0 - WRITE(6,1002) ICOUNT,IUNIT1 - 1002 FORMAT(' THERE ARE ',I5,' EXCESS BUFR MESSAGES ON UNIT ',I3) - 9980 CONTINUE - WRITE(6,1001) IUNIT1 - IENFIL = IENFIL + 1 - IF(IENFIL.EQ.3) GO TO 99999 - ICOUNT = 0 - 9985 CONTINUE - READ(IUNIT2,END=9988) CMSGA - ICOUNT = ICOUNT + 1 - GO TO 9985 -C - 9988 CONTINUE - INDEX2 = 0 - WRITE(6,1002) ICOUNT,IUNIT2 - 9990 CONTINUE - WRITE(6,1001) IUNIT2 - IENFIL = IENFIL + 1 - IF(IENFIL.EQ.3) GO TO 99999 - ICOUNT = 0 - 9995 CONTINUE - READ(IUNIT0,END=9998) CMSGA - ICOUNT = ICOUNT + 1 - GO TO 9995 -C - 9998 CONTINUE - INDEX0 = 0 - WRITE(6,1002) ICOUNT,IUNIT0 - GO TO 9970 -C -99999 CONTINUE - IERR = 3 - RETURN - END - SUBROUTINE FI8101(MSTACK,KDATA,NDESC) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8101 GETS INFO TO UNPACK BUFR 40-LVL TOVS RTRVLS -C PRGMMR: BERT B. KATZ ORG: W/NMC23 DATE: 93-06-09 -C GENERAL -C SCIENCES CORP. -C -C ABSTRACT: USES BUFR DESCRIPTOR STACK AND DATA TO DETERMINE -C ARRAY LOCATIONS AND SCALING FOR TOVS 40-LEVEL RETRIEVAL -C QUANTITIES TO BE RETURNED TO W3FI81. -C -C PROGRAM HISTORY LOG: -C 93-06-09 BERT B. KATZ -C -C USAGE: CALL FI8101(MSTACK,KDATA,NDESC) -C INPUT ARGUMENT LIST: -C MSTACK - ARRAY CONTAINING BUFR DESCRIPTORS AND SCALING -C - FOR TOVS 40-LEVEL RETRIEVALS. -C KDATA - BUFR DATA IN INTEGER FORM. -C NDESC - NUMBER OF DESCRIPTORS IN ARRAY MSTACK. -C -C REMARKS: CALLED BY SUBROUTINE W3FI81. RETURNS OUTPUT THOUGH -C COMMON BLOCK /FI81TV/. -C -C ATTRIBUTES: -C LANGUAGE: VS FORTRAN, CFT77 -C MACHINE: HDS OR CRAY -C -C$$$ -C - PARAMETER (MXIRPT=50,MXIDSC=420) - PARAMETER (NMLO=28) - PARAMETER (NML=70) - INTEGER MSTACK(2,MXIDSC) - INTEGER KDATA(MXIRPT,MXIDSC) -C - COMMON /FI81TV/ LCSTII, LCSSBC, LCMBBX, - 1 LCINSI, LCRTMI, LCFLFI, - 2 LCYRI , LCMONI, LCDAYI, - 3 LCHRI , LCMINI, LCSECI, - 4 LCLSI , LCNDI , LCFGAP, - 5 LCDVHI, LCDVMI, LCDVSI, - 6 LCNMCI, LWNMCI, LCRTPI, - 7 LCLATI, IXLATI, LCLONI, IXLONI, - 8 LCSTUI, LCSSTA, LCST15, IXST15, - 9 LCSZAN, IXSZAN, LCLSZA, IXLSZA, - A LCSALB, IXSALB, LCSKNI, IXSKNI, - B LCH8FI, LCPLSI, IXPLSI, LCSFHI, IXSFHI, - C LCICOI, LCOZON, IXOZON, LCAVNS, IXAVNS, - D LCICTI, LCPTRI, IXPTRI, LCTTRI, IXTTRI - COMMON /FI81TV/ LCP40I(40), IXP40I(40), - 1 LCT40I(40), IXT40I(40), - 2 LCH40I(40), IXH40I(40), - 3 LCM40I(40), IXM40I(40), - 4 LCP4GI(40), IXP4GI(40), - 5 LCT4GI(40), IXT4GI(40), - 6 LCM4GI(40), IXM4GI(40), - 7 LCRADI(27), IXRADI(27), - 8 LCRDGI(27), IXRDGI(27) -C -C FIND LOCATIONS AND SCALING -C - I=0 - 15 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.263) THEN - LCSTII = I - ELSE IF(MSTACK(1,I).EQ.6932) THEN - LCSSBC = I - ELSE IF(MSTACK(1,I).EQ.6933) THEN - LCMBBX = I - ELSE IF(MSTACK(1,I).EQ.1025) THEN - LCYRI = I - ELSE IF(MSTACK(1,I).EQ.1026) THEN - LCMONI = I - ELSE IF(MSTACK(1,I).EQ.1027) THEN - LCDAYI = I - ELSE IF(MSTACK(1,I).EQ.1028) THEN - LCHRI = I - ELSE IF(MSTACK(1,I).EQ.1029) THEN - LCMINI = I - ELSE IF(MSTACK(1,I).EQ.1030) THEN - LCSECI = I - ELSE IF(MSTACK(1,I).EQ.1282) THEN - LCLATI = I - IXLATI = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.1538) THEN - LCLONI = I - IXLONI = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.2060) THEN - LCLSI = I - ELSE IF(MSTACK(1,I).EQ.2061) THEN - LCNDI = I - ELSE IF(MSTACK(1,I).EQ.533) THEN - LCINSI = I - ELSE IF(MSTACK(1,I).EQ.534) THEN - LCRTMI = I - ELSE IF(MSTACK(1,I).EQ.6438) THEN - LCFLFI = I - ELSE IF(MSTACK(1,I).EQ.6435) THEN - LCFGAP = I - ELSE IF(MSTACK(1,I).EQ.1814) THEN - LCSZAN = I - IXSZAN = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.1813) THEN - LCLSZA = I - IXLSZA = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.6436) THEN - LCAVNS = I - IXAVNS = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.451) THEN - IF(MSTACK(1,I-1).NE.451) THEN - NBITS = MSTACK(1,I-1) - 34304 - IF(NBITS.GT.0) THEN - LCNMCI = I - LBNMCI = NBITS / 8 - LWNMCI = (LBNMCI - 1) / 4 + 1 - ENDIF - ENDIF - ELSE IF(MSTACK(1,I).EQ.1048) THEN - LCDVHI = I - ELSE IF(MSTACK(1,I).EQ.1049) THEN - LCDVMI = I - ELSE IF(MSTACK(1,I).EQ.1050) THEN - LCDVSI = I - ELSE IF(MSTACK(1,I).EQ.14086) THEN - LCRTPI = I - ENDIF - IF(I.LT.NDESC) GO TO 15 -C - I=0 - 20 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.2051) THEN - IF(KDATA(1,I).EQ.7) THEN - 25 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.537) THEN - LCICOI = I - GO TO 25 - ELSE IF(MSTACK(1,I).EQ.3841) THEN - LCOZON = I - IXOZON = -MSTACK(2,I) - GO TO 25 - ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN - GO TO 25 - ELSE - I = I - 1 - ENDIF - ELSE IF(KDATA(1,I).EQ.8) THEN - 30 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.6430) THEN - LCSTUI = I - GO TO 30 - ELSE IF(MSTACK(1,I).EQ.6431) THEN - LCSSTA = I - GO TO 30 - ELSE IF(MSTACK(1,I).EQ.5673) THEN - LCST15 = I - IXST15 = -MSTACK(2,I) - GO TO 30 - ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN - GO TO 30 - ELSE - I = I - 1 - ENDIF - ELSE IF(KDATA(1,I).EQ.3) THEN - 35 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.537) THEN - LCICTI = I - GO TO 35 - ELSE IF(MSTACK(1,I).EQ.1796) THEN - LCPTRI = I - IXPTRI = -MSTACK(2,I) - GO TO 35 - ELSE IF(MSTACK(1,I).EQ.3073) THEN - LCTTRI = I - IXTTRI = -MSTACK(2,I) - GO TO 35 - ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN - GO TO 35 - ELSE - I = I - 1 - ENDIF - ELSE IF(KDATA(1,I).EQ.0) THEN - 40 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.1793) THEN - LCSFHI = I - IXSFHI = -MSTACK(2,I) - GO TO 40 - ELSE IF(MSTACK(1,I).EQ.2564) THEN - LCPLSI = I - IXPLSI = -MSTACK(2,I) - GO TO 40 - ELSE IF(MSTACK(1,I).EQ.3133) THEN - LCSKNI = I - IXSKNI = -MSTACK(2,I) - GO TO 40 - ELSE IF(MSTACK(1,I).EQ.6437) THEN - LCH8FI = I - GO TO 40 - ELSE IF(MSTACK(1,I).EQ.3603) THEN - LCSALB = I - IXSALB = -MSTACK(2,I) - GO TO 40 - ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN - GO TO 40 - ELSE - I = I - 1 - ENDIF - ENDIF - ELSE IF(MSTACK(1,I).EQ.2280) THEN - IF(KDATA(1,I).EQ.4096) THEN - I = I + 1 - KPROF = MSTACK(1,I) - 16384 - KREPL = MOD(KPROF,256) - KFLDS = KPROF / 256 - DO 45 K = 1 , KREPL - DO 45 J = 1 , KFLDS - I = I + 1 - IF(MSTACK(1,I).EQ.1796) THEN - LCP40I(K) = I - IXP40I(K) = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.3073) THEN - LCT40I(K) = I - IXT40I(K) = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.2563) THEN - LCH40I(K) = I - IXH40I(K) = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.3330) THEN - LCM40I(K) = I - IXM40I(K) = -MSTACK(2,I) - ENDIF - 45 CONTINUE - ELSE IF(KDATA(1,I).EQ.100 .OR. KDATA(1,I).EQ.98 .OR. - 1 KDATA(1,I).EQ.97) THEN - IF(KDATA(1,I).EQ.100) THEN - ISCHAN = 0 - ELSE IF(KDATA(1,I).EQ.98) THEN - ISCHAN = 20 - ELSE IF(KDATA(1,I).EQ.97) THEN - ISCHAN = 24 - ENDIF - 50 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.1322) THEN - ICHAN = ISCHAN + KDATA(1,I) - ICHINC = 0 - GO TO 50 - ELSE IF(MSTACK(1,I).EQ.1332) THEN - ICHINC = KDATA(1,I) - GO TO 50 - ELSE IF(MSTACK(1,I).GT.16384 .AND. - 1 MSTACK(1,I).LT.33024) THEN - KPROF = MSTACK(1,I) - 16384 - KREPL = MOD(KPROF,256) - KFLDS = KPROF / 256 - GO TO 50 - ELSE IF(MSTACK(1,I).EQ.3135) THEN - ICHAN = ICHAN + ICHINC - LCRADI(ICHAN) = I - IXRADI(ICHAN) = -MSTACK(2,I) - IF(ICHAN-ISCHAN.GE.KREPL*ICHINC) THEN - ISCHAN = 0 - ENDIF - GO TO 50 - ELSE IF(MSTACK(1,I).GE.33024) THEN - GO TO 50 - ELSE - I = I - 1 - ENDIF - ELSE IF(KDATA(1,I).EQ.4224) THEN - I = I + 1 - KPROF = MSTACK(1,I) - 16384 - KREPL = MOD(KPROF,256) - KFLDS = KPROF / 256 - DO 55 K = 1 , KREPL - DO 55 J = 1 , KFLDS - I = I + 1 - IF(MSTACK(1,I).EQ.1796) THEN - LCP4GI(K) = I - IXP4GI(K) = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.3073) THEN - LCT4GI(K) = I - IXT4GI(K) = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.3330) THEN - LCM4GI(K) = I - IXM4GI(K) = -MSTACK(2,I) - ENDIF - 55 CONTINUE - ELSE IF(KDATA(1,I).EQ.228 .OR. KDATA(1,I).EQ.226 .OR. - 1 KDATA(1,I).EQ.225) THEN - IF(KDATA(1,I).EQ.228) THEN - ISCHAN = 0 - ELSE IF(KDATA(1,I).EQ.226) THEN - ISCHAN = 20 - ELSE IF(KDATA(1,I).EQ.225) THEN - ISCHAN = 24 - ENDIF - 60 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.1322) THEN - ICHAN = ISCHAN + KDATA(1,I) - ICHINC = 0 - GO TO 60 - ELSE IF(MSTACK(1,I).EQ.1332) THEN - ICHINC = KDATA(1,I) - GO TO 60 - ELSE IF(MSTACK(1,I).GT.16384 .AND. - 1 MSTACK(1,I).LT.33024) THEN - KPROF = MSTACK(1,I) - 16384 - KREPL = MOD(KPROF,256) - KFLDS = KPROF / 256 - GO TO 60 - ELSE IF(MSTACK(1,I).EQ.3135) THEN - ICHAN = ICHAN + ICHINC - LCRDGI(ICHAN) = I - IXRDGI(ICHAN) = -MSTACK(2,I) - IF(ICHAN-ISCHAN.GE.KREPL*ICHINC) THEN - ISCHAN = 0 - ENDIF - GO TO 60 - ELSE IF(MSTACK(1,I).GE.33024) THEN - GO TO 60 - ELSE - I = I - 1 - ENDIF - ENDIF - ENDIF - IF(I.LT.NDESC) GO TO 20 -C - RETURN - END - SUBROUTINE FI8102(MSTACK,KDATA,NDESC) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8102 GETS INFO TO UNPACK BUFR INTERACTIVE RTRVLS -C PRGMMR: BERT B. KATZ ORG: W/NMC23 DATE: 93-06-09 -C GENERAL -C SCIENCES CORP. -C -C ABSTRACT: USES BUFR DESCRIPTOR STACK AND DATA TO DETERMINE -C ARRAY LOCATIONS AND SCALING FOR INTERACTIVE RETRIEVAL -C QUANTITIES TO BE RETURNED TO W3FI81. -C -C PROGRAM HISTORY LOG: -C 93-06-09 BERT B. KATZ -C -C USAGE: CALL FI8102(MSTACK,KDATA,NDESC) -C INPUT ARGUMENT LIST: -C MSTACK - ARRAY CONTAINING BUFR DESCRIPTORS AND SCALING -C - FOR INTERACTIVE RETRIEVALS. -C KDATA - BUFR DATA IN INTEGER FORM. -C NDESC - NUMBER OF DESCRIPTORS IN ARRAY MSTACK. -C -C REMARKS: CALLED BY SUBROUTINE W3FI81. RETURNS OUTPUT THOUGH -C COMMON BLOCK /FI81IA/. -C -C ATTRIBUTES: -C LANGUAGE: VS FORTRAN, CFT77 -C MACHINE: HDS OR CRAY -C -C$$$ -C - PARAMETER (MXRPTR=30,MXDSCR=700) - PARAMETER (NMLO=28) - PARAMETER (NML=70) - INTEGER MSTACK(2,MXDSCR) - INTEGER KDATA(MXRPTR,MXDSCR) -C - COMMON /FI81IA/ LCSTIR , LCLSR , LCNDR , - 1 LCNMCR , LWNMCR , LCFCYC , - 2 LCINSR , LCRTMR , LCRTPR , - 3 LCDVHR , LCDVMR , LCDVSR , - 4 LCSTUR , LCICOR , LCFLFR , - 5 LCLATR , IXLATR , - 6 LCLONR , IXLONR , - 7 LCPTRR , IXPTRR , - 8 LCTTRR , IXTTRR , LCICTR , - 9 LCSKNT , IXSKNT , - A LCPLSR , IXPLSR , - B LCSFHF , IXSFHF , - C LCPSFF , IXPSFF , - D LCSKNF , IXSKNF , - E LCSKNR , IXSKNR , LCH8FR - COMMON /FI81IA/ LCRADF(27) , IXRADF(27) , - 1 LCRDFC(27) , IXRDFC(27) , - 2 LCSIGI(NMLO), IXSIGI(NMLO), - 3 LCTMPI(NMLO), IXTMPI(NMLO), - 4 LCRADR(27) , IXRADR(27) , - 5 LCRDRC(27) , IXRDRC(27) , - 6 LCSIGF(NMLO), IXSIGF(NMLO), - 7 LCTMPF(NMLO), IXTMPF(NMLO), - 8 LCMIXF(NMLO), IXMIXF(NMLO), - 9 LCSIGR(NML) , IXSIGR(NML) , - A LCTMPR(NML) , IXTMPR(NML) , - B LCMIXR(NML) , IXMIXR(NML) , - C LCP41I , IXP41I , - D LCT41I , IXT41I , - E LCM41I , IXM41I -C -C FIND LOCATIONS AND SCALING -C - I=0 - 20 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.263) THEN - LCSTIR = I - ELSE IF(MSTACK(1,I).EQ.1282) THEN - LCLATR = I - IXLATR = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.1538) THEN - LCLONR = I - IXLONR = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.2060) THEN - LCLSR = I - ELSE IF(MSTACK(1,I).EQ.2061) THEN - LCNDR = I - ELSE IF(MSTACK(1,I).EQ.533) THEN - LCINSR = I - ELSE IF(MSTACK(1,I).EQ.534) THEN - LCRTMR = I - ELSE IF(MSTACK(1,I).EQ.6438) THEN - LCFLFR = I - ELSE IF(MSTACK(1,I).EQ.451) THEN - IF(MSTACK(1,I-1).NE.451) THEN - NBITS = MSTACK(1,I-1) - 34304 - IF(NBITS.GT.0) THEN - LCNMCR = I - LBNMCR = NBITS / 8 - LWNMCR = (LBNMCR - 1) / 4 + 1 - ENDIF - ENDIF - ELSE IF(MSTACK(1,I).EQ.1048) THEN - LCDVHR = I - ELSE IF(MSTACK(1,I).EQ.1049) THEN - LCDVMR = I - ELSE IF(MSTACK(1,I).EQ.1050) THEN - LCDVSR = I - ELSE IF(MSTACK(1,I).EQ.14086) THEN - LCRTPR = I - ENDIF - IF(MSTACK(1,I).EQ.2051) THEN - IF(KDATA(1,I).EQ.7) THEN - 25 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.537) THEN - LCICOR = I - GO TO 25 - ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN - GO TO 25 - ELSE - I = I - 1 - ENDIF - ELSE IF(KDATA(1,I).EQ.8) THEN - 30 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.6430) THEN - LCSTUR = I - GO TO 30 - ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN - GO TO 30 - ELSE - I = I - 1 - ENDIF - ELSE IF(KDATA(1,I).EQ.3) THEN - 35 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.537) THEN - LCICTR = I - GO TO 35 - ELSE IF(MSTACK(1,I).EQ.1796) THEN - LCPTRR = I - IXPTRR = -MSTACK(2,I) - GO TO 35 - ELSE IF(MSTACK(1,I).EQ.3073) THEN - LCTTRR = I - IXTTRR = -MSTACK(2,I) - GO TO 35 - ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN - GO TO 35 - ELSE - I = I - 1 - ENDIF - ELSE IF(KDATA(1,I).EQ.0) THEN - 40 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.2564) THEN - LCPLSR = I - IXPLSR = -MSTACK(2,I) - GO TO 40 - ELSE IF(MSTACK(1,I).EQ.3133) THEN - LCSKNT = I - IXSKNT = -MSTACK(2,I) - GO TO 40 - ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN - GO TO 40 - ELSE - I = I - 1 - ENDIF - ENDIF - ELSE IF(MSTACK(1,I).EQ.2280) THEN - IF(KDATA(1,I).EQ.16) THEN - 45 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.1793) THEN - LCSFHF = I - IXSFHF = -MSTACK(2,I) - GO TO 45 - ELSE IF(MSTACK(1,I).EQ.2564) THEN - LCPSFF = I - IXPSFF = -MSTACK(2,I) - GO TO 45 - ELSE IF(MSTACK(1,I).EQ.3133) THEN - LCSKNF = I - IXSKNF = -MSTACK(2,I) - GO TO 45 - ELSE IF(MSTACK(1,I).EQ.1219) THEN - LCFCYC = I - GO TO 45 - ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN - GO TO 45 - ELSE - I = I - 1 - ENDIF - ELSE IF(KDATA(1,I).EQ.2048) THEN - 50 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.3133) THEN - LCSKNR = I - IXSKNR = -MSTACK(2,I) - GO TO 50 - ELSE IF(MSTACK(1,I).EQ.6437) THEN - LCH8FR = I - GO TO 50 - ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN - GO TO 50 - ELSE - I = I - 1 - ENDIF - ELSE IF(KDATA(1,I).EQ.1076 .OR. KDATA(1,I).EQ.1074 .OR. - 1 KDATA(1,I).EQ.1073) THEN - IF(KDATA(1,I).EQ.1076) THEN - ISCHAN = 0 - ELSE IF(KDATA(1,I).EQ.1074) THEN - ISCHAN = 20 - ELSE IF(KDATA(1,I).EQ.1073) THEN - ISCHAN = 24 - ENDIF - 55 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.1322) THEN - ICHAN = ISCHAN + KDATA(1,I) - ICHINC = 0 - GO TO 55 - ELSE IF(MSTACK(1,I).EQ.1332) THEN - ICHINC = KDATA(1,I) - GO TO 55 - ELSE IF(MSTACK(1,I).GT.16384 .AND. - 1 MSTACK(1,I).LT.33024) THEN - KPROF = MSTACK(1,I) - 16384 - KREPL = MOD(KPROF,256) - KFLDS = KPROF / 256 - GO TO 55 - ELSE IF(MSTACK(1,I).EQ.3135) THEN - ICHAN = ICHAN + ICHINC - LCRADF(ICHAN) = I - IXRADF(ICHAN) = -MSTACK(2,I) - IF(ICHAN-ISCHAN.GE.KREPL*ICHINC) THEN - ISCHAN = 0 - ENDIF - GO TO 55 - ELSE IF(MSTACK(1,I).GE.33024) THEN - GO TO 55 - ELSE - I = I - 1 - ENDIF - ELSE IF(KDATA(1,I).EQ.1588 .OR. KDATA(1,I).EQ.1586 .OR. - 1 KDATA(1,I).EQ.1585) THEN - IF(KDATA(1,I).EQ.1588) THEN - ISCHAN = 0 - ELSE IF(KDATA(1,I).EQ.1586) THEN - ISCHAN = 20 - ELSE IF(KDATA(1,I).EQ.1585) THEN - ISCHAN = 24 - ENDIF - 60 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.1322) THEN - ICHAN = ISCHAN + KDATA(1,I) - ICHINC = 0 - GO TO 60 - ELSE IF(MSTACK(1,I).EQ.1332) THEN - ICHINC = KDATA(1,I) - GO TO 60 - ELSE IF(MSTACK(1,I).GT.16384 .AND. - 1 MSTACK(1,I).LT.33024) THEN - KPROF = MSTACK(1,I) - 16384 - KREPL = MOD(KPROF,256) - KFLDS = KPROF / 256 - GO TO 60 - ELSE IF(MSTACK(1,I).EQ.3135) THEN - ICHAN = ICHAN + ICHINC - LCRDFC(ICHAN) = I - IXRDFC(ICHAN) = -MSTACK(2,I) - IF(ICHAN-ISCHAN.GE.KREPL*ICHINC) THEN - ISCHAN = 0 - ENDIF - GO TO 60 - ELSE IF(MSTACK(1,I).GE.33024) THEN - GO TO 60 - ELSE - I = I - 1 - ENDIF - ELSE IF(KDATA(1,I).EQ.12288) THEN - I = I + 1 - KPROF = MSTACK(1,I) - 16384 - KREPL = MOD(KPROF,256) - KFLDS = KPROF / 256 - DO 65 K = 1 , KREPL - DO 65 J = 1 , KFLDS - I = I + 1 - IF(MSTACK(1,I).EQ.1330) THEN - LCSIGI(K) = I - IXSIGI(K) = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.3073) THEN - LCTMPI(K) = I - IXTMPI(K) = -MSTACK(2,I) - ENDIF - 65 CONTINUE - ELSE IF(KDATA(1,I).EQ.3108 .OR. KDATA(1,I).EQ.3106 .OR. - 1 KDATA(1,I).EQ.3105) THEN - IF(KDATA(1,I).EQ.3108) THEN - ISCHAN = 0 - ELSE IF(KDATA(1,I).EQ.3106) THEN - ISCHAN = 20 - ELSE IF(KDATA(1,I).EQ.3105) THEN - ISCHAN = 24 - ENDIF - 70 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.1322) THEN - ICHAN = ISCHAN + KDATA(1,I) - ICHINC = 0 - GO TO 70 - ELSE IF(MSTACK(1,I).EQ.1332) THEN - ICHINC = KDATA(1,I) - GO TO 70 - ELSE IF(MSTACK(1,I).GT.16384 .AND. - 1 MSTACK(1,I).LT.33024) THEN - KPROF = MSTACK(1,I) - 16384 - KREPL = MOD(KPROF,256) - KFLDS = KPROF / 256 - GO TO 70 - ELSE IF(MSTACK(1,I).EQ.3135) THEN - ICHAN = ICHAN + ICHINC - LCRADR(ICHAN) = I - IXRADR(ICHAN) = -MSTACK(2,I) - IF(ICHAN-ISCHAN.GE.KREPL*ICHINC) THEN - ISCHAN = 0 - ENDIF - GO TO 70 - ELSE IF(MSTACK(1,I).GE.33024) THEN - GO TO 70 - ELSE - I = I - 1 - ENDIF - ELSE IF(KDATA(1,I).EQ.3620 .OR. KDATA(1,I).EQ.3618 .OR. - 1 KDATA(1,I).EQ.3617) THEN - IF(KDATA(1,I).EQ.3620) THEN - ISCHAN = 0 - ELSE IF(KDATA(1,I).EQ.3618) THEN - ISCHAN = 20 - ELSE IF(KDATA(1,I).EQ.3617) THEN - ISCHAN = 24 - ENDIF - 80 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.1322) THEN - ICHAN = ISCHAN + KDATA(1,I) - ICHINC = 0 - GO TO 80 - ELSE IF(MSTACK(1,I).EQ.1332) THEN - ICHINC = KDATA(1,I) - GO TO 80 - ELSE IF(MSTACK(1,I).GT.16384 .AND. - 1 MSTACK(1,I).LT.33024) THEN - KPROF = MSTACK(1,I) - 16384 - KREPL = MOD(KPROF,256) - KFLDS = KPROF / 256 - GO TO 80 - ELSE IF(MSTACK(1,I).EQ.3135) THEN - ICHAN = ICHAN + ICHINC - LCRDRC(ICHAN) = I - IXRDRC(ICHAN) = -MSTACK(2,I) - IF(ICHAN-ISCHAN.GE.KREPL*ICHINC) THEN - ISCHAN = 0 - ENDIF - GO TO 80 - ELSE IF(MSTACK(1,I).GE.33024) THEN - GO TO 80 - ELSE - I = I - 1 - ENDIF - ELSE IF(KDATA(1,I).EQ.8208) THEN - I = I + 1 - KPROF = MSTACK(1,I) - 16384 - KREPL = MOD(KPROF,256) - KFLDS = KPROF / 256 - DO 85 K = 1 , KREPL - DO 85 J = 1 , KFLDS - I = I + 1 - IF(MSTACK(1,I).EQ.1330) THEN - LCSIGF(K) = I - IXSIGF(K) = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.3073) THEN - LCTMPF(K) = I - IXTMPF(K) = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.3330) THEN - LCMIXF(K) = I - IXMIXF(K) = -MSTACK(2,I) - ENDIF - 85 CONTINUE - ELSE IF(KDATA(1,I).EQ.10240) THEN - I = I + 1 - KPROF = MSTACK(1,I) - 16384 - KREPL = MOD(KPROF,256) - KFLDS = KPROF / 256 - DO 90 K = 1 , KREPL - DO 90 J = 1 , KFLDS - I = I + 1 - IF(MSTACK(1,I).EQ.1330) THEN - LCSIGR(K) = I - IXSIGR(K) = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.3073) THEN - LCTMPR(K) = I - IXTMPR(K) = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.3330) THEN - LCMIXR(K) = I - IXMIXR(K) = -MSTACK(2,I) - ENDIF - 90 CONTINUE - ELSE IF(KDATA(1,I).EQ.4096) THEN - I = I + 1 - KPROF = MSTACK(1,I) - 16384 - KREPL = MOD(KPROF,256) - KFLDS = KPROF / 256 - I = I + (KREPL - 1) * KFLDS - DO 95 J = 1 , KFLDS - I = I + 1 - IF(MSTACK(1,I).EQ.1796) THEN - LCP41I = I - IXP41I = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.3073) THEN - LCT41I = I - IXT41I = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.3330) THEN - LCM41I = I - IXM41I = -MSTACK(2,I) - ENDIF - 95 CONTINUE - ENDIF - ENDIF - IF(I.LT.NDESC) GO TO 20 -C - RETURN - END - SUBROUTINE FI8103(MSTACK,KDATA,NDESC) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8103 GETS INFO TO UNPACK BUFR ANALYSIS INTERP -C PRGMMR: BERT B. KATZ ORG: W/NMC23 DATE: 93-06-09 -C GENERAL -C SCIENCES CORP. -C -C ABSTRACT: USES BUFR DESCRIPTOR STACK AND DATA TO DETERMINE -C ARRAY LOCATIONS AND SCALING FOR ANALYSIS INTERPOLATION -C QUANTITIES TO BE RETURNED TO W3FI81. -C -C PROGRAM HISTORY LOG: -C 93-06-09 BERT B. KATZ -C -C USAGE: CALL FI8103(MSTACK,KDATA,NDESC) -C INPUT ARGUMENT LIST: -C MSTACK - ARRAY CONTAINING BUFR DESCRIPTORS AND SCALING -C - FOR ANALYSIS INTERPOLATION DATA. -C KDATA - BUFR DATA IN INTEGER FORM. -C NDESC - NUMBER OF DESCRIPTORS IN ARRAY MSTACK. -C -C REMARKS: CALLED BY SUBROUTINE W3FI81. RETURNS OUTPUT THOUGH -C COMMON BLOCK /FI81IA/. -C -C ATTRIBUTES: -C LANGUAGE: VS FORTRAN, CFT77 -C MACHINE: HDS OR CRAY -C -C$$$ -C - PARAMETER (MXRPTR=100,MXDSCR=200) - PARAMETER (NMLO=28) - PARAMETER (NML=70) - INTEGER MSTACK(2,MXDSCR) - INTEGER KDATA(MXRPTR,MXDSCR) -C - COMMON /FI81AN/ LCSTIA , LCYRA , LCMONA , - 1 LCDAYA , LCHRA , LCMINA , - 2 LCLATA , IXLATA , - 3 LCLONA , IXLONA , - 4 LCPSFA , IXPSFA , - 5 LCSFHA , IXSFHA , - 6 LCNMCA , LWNMCA , - 7 LCSIGA(NMLO), IXSIGA(NMLO), - 8 LCTMPA(NMLO), IXTMPA(NMLO), - 9 LCMIXA(NMLO), IXMIXA(NMLO), - A LCRADA(27) , IXRADA(27) , - B LCRDAC(27) , IXRDAC(27) -C -C FIND LOCATIONS AND SCALING -C - I=0 - 20 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.263) THEN - LCSTIA = I - ELSE IF(MSTACK(1,I).EQ.1282) THEN - LCLATA = I - IXLATA = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.1538) THEN - LCLONA = I - IXLONA = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.451) THEN - IF(MSTACK(1,I-1).NE.451) THEN - NBITS = MSTACK(1,I-1) - 34304 - IF(NBITS.GT.0) THEN - LCNMCA = I - LBNMCA = NBITS / 8 - LWNMCA = (LBNMCA - 1) / 4 + 1 - ENDIF - ENDIF - ELSE IF(MSTACK(1,I).EQ.2280) THEN - IF(KDATA(1,I).EQ.256) THEN - 30 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.1793) THEN - LCSFHA = I - IXSFHA = -MSTACK(2,I) - GO TO 30 - ELSE IF(MSTACK(1,I).EQ.2564) THEN - LCPSFA = I - IXPSFA = -MSTACK(2,I) - GO TO 30 - ELSE IF(MSTACK(1,I).EQ.1025) THEN - LCYRA = I - GO TO 30 - ELSE IF(MSTACK(1,I).EQ.1026) THEN - LCMONA = I - GO TO 30 - ELSE IF(MSTACK(1,I).EQ.1027) THEN - LCDAYA = I - GO TO 30 - ELSE IF(MSTACK(1,I).EQ.1028) THEN - LCHRA = I - GO TO 30 - ELSE IF(MSTACK(1,I).EQ.1029) THEN - LCMINA = I - GO TO 30 - ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN - GO TO 30 - ELSE - I = I - 1 - ENDIF - ELSE IF(KDATA(1,I).EQ.8448) THEN - I = I + 1 - KPROF = MSTACK(1,I) - 16384 - KREPL = MOD(KPROF,256) - KFLDS = KPROF / 256 - DO 40 K = 1 , KREPL - DO 40 J = 1 , KFLDS - I = I + 1 - IF(MSTACK(1,I).EQ.1330) THEN - LCSIGA(K) = I - IXSIGA(K) = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.3073) THEN - LCTMPA(K) = I - IXTMPA(K) = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.3330) THEN - LCMIXA(K) = I - IXMIXA(K) = -MSTACK(2,I) - ENDIF - 40 CONTINUE - ELSE IF(KDATA(1,I).EQ.1316 .OR. KDATA(1,I).EQ.1314 .OR. - 1 KDATA(1,I).EQ.1313) THEN - IF(KDATA(1,I).EQ.1316) THEN - ISCHAN = 0 - ELSE IF(KDATA(1,I).EQ.1314) THEN - ISCHAN = 20 - ELSE IF(KDATA(1,I).EQ.1313) THEN - ISCHAN = 24 - ENDIF - 50 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.1322) THEN - ICHAN = ISCHAN + KDATA(1,I) - ICHINC = 0 - GO TO 50 - ELSE IF(MSTACK(1,I).EQ.1332) THEN - ICHINC = KDATA(1,I) - GO TO 50 - ELSE IF(MSTACK(1,I).GT.16384 .AND. - 1 MSTACK(1,I).LT.33024) THEN - KPROF = MSTACK(1,I) - 16384 - KREPL = MOD(KPROF,256) - KFLDS = KPROF / 256 - GO TO 50 - ELSE IF(MSTACK(1,I).EQ.3135) THEN - ICHAN = ICHAN + ICHINC - LCRADA(ICHAN) = I - IXRADA(ICHAN) = -MSTACK(2,I) - IF(ICHAN-ISCHAN.GE.KREPL*ICHINC) THEN - ISCHAN = 0 - ENDIF - GO TO 50 - ELSE IF(MSTACK(1,I).GE.33024) THEN - GO TO 50 - ELSE - I = I - 1 - ENDIF - ELSE IF(KDATA(1,I).EQ.1828 .OR. KDATA(1,I).EQ.1826 .OR. - 1 KDATA(1,I).EQ.1825) THEN - IF(KDATA(1,I).EQ.1828) THEN - ISCHAN = 0 - ELSE IF(KDATA(1,I).EQ.1826) THEN - ISCHAN = 20 - ELSE IF(KDATA(1,I).EQ.1825) THEN - ISCHAN = 24 - ENDIF - 60 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.1322) THEN - ICHAN = ISCHAN + KDATA(1,I) - ICHINC = 0 - GO TO 60 - ELSE IF(MSTACK(1,I).EQ.1332) THEN - ICHINC = KDATA(1,I) - GO TO 60 - ELSE IF(MSTACK(1,I).GT.16384 .AND. - 1 MSTACK(1,I).LT.33024) THEN - KPROF = MSTACK(1,I) - 16384 - KREPL = MOD(KPROF,256) - KFLDS = KPROF / 256 - GO TO 60 - ELSE IF(MSTACK(1,I).EQ.3135) THEN - ICHAN = ICHAN + ICHINC - LCRDAC(ICHAN) = I - IXRDAC(ICHAN) = -MSTACK(2,I) - IF(ICHAN-ISCHAN.GE.KREPL*ICHINC) THEN - ISCHAN = 0 - ENDIF - GO TO 60 - ELSE IF(MSTACK(1,I).GE.33024) THEN - GO TO 60 - ELSE - I = I - 1 - ENDIF - ENDIF - ENDIF - IF(I.LT.NDESC) GO TO 20 -C - RETURN - END - SUBROUTINE FI8104(PSFC,PR,TP,WP,PTOV,TTOV,WTOV,NML) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8104 INTERPOLATES FROM MODEL TO TOVS LEVELS -C PRGMMR: BERT B. KATZ ORG: W/NMC23 DATE: 93-08-26 -C GENERAL -C SCIENCES CORP. -C -C ABSTRACT: USING INPUT RETRIEVAL-LEVEL PRESSURES, INTERPOLATES -C TEMPERATURE AND MIXING RATIO FROM MODEL LEVELS TO THE 40 TOVS -C LEVELS. -C -C PROGRAM HISTORY LOG: -C 91-05-13 M. GOLDBERG (NESDIS) -C 92-10-20 T. GARDNER (NESDIS) -C 93-08-26 BERT B. KATZ MODIFIED FOR NMC OPERATIONAL USE. -C -C -C USAGE: CALL FI8104(PSFC,PR,TP,WP,PTOV,TTOV,WTOV,NML) -C INPUT ARGUMENT LIST: -C PSFC - SURFACE PRESSURE (MB). -C PR - PRESSURE (MB) ON MODEL SIGMA LEVELS. -C TP - TEMPERATURE (DEG K) ON MODEL SIGMA LEVELS. -C WP - MIXING RATIO (G/KG) ON MODEL SIGMA LEVELS. -C PTOV - TOVS 40 PRESSURE LEVELS (MB). -C NML - NUMBER OF MODEL SIGMA LEVELS. -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C TTOV - TEMPERATURE (DEG K) ON 40 TOVS LEVELS. -C WTOV - MIXING RATIO (G/KG) ON 40 TOVS LEVELS. -C -C OUTPUT FILES: -C FT06F001 - USED FOR DEBUG PRINTOUT. -C -C ATTRIBUTES: -C LANGUAGE: VS FORTRAN, CFT77 -C MACHINE: HDS OR CRAY. -C -C$$$ -C -C - REAL PR(NML),TP(NML),WP(NML),PTOV(40),TTOV(40),WTOV(40) - REAL PX(29),TX(29),WX(29) -C -C -C REMEMBER THAT NML = NUMBER OF MODEL LEVELS -C - DO 100 I = 1,NML - PX(I) = PR(I) - TX(I) = TP(I) - WX(I) = WP(I) - 100 CONTINUE -C -C INVENT SURFACE QUANTITIES TO BOUND LOWER END FOR PURPOSE OF -C INTERPOLATION -C -C PRINT*,'PSFC=',PSFC -C PRINT*, 'PX=',PX - TX(NML+1)=TX(NML)+0.065*(1001.0-PSFC) - WX(NML+1)=WX(NML)*((1001.0/PX(NML))**(.005*PX(NML)-1.5)) - PX(NML+1)=1001.0 -C -C...MAKE SURE FOR CASES WHERE HIGHEST PRESS LEVEL IS BELOW HIGHEST -C...TOVS LEVEL THAT INTERP. WILL BE PERFORMED. -C - IF (PX(1) .GT. PTOV(1)) PX(1) = PTOV(1) -C -C...INTERPOLATE FORECAST TEMPERATURE AND WATER VAPOR PROFILES TO -C...THE 40 TOVS PRESSURE LEVELS. (FROM 1.0 MB TO 1000 MB) -C...INITIALIZE TTOV AND WTOV VECTORS WITH THE OPERATIONAL RETRIEVALS -C - DO 800 I = 1,40 -C -C...EXTRACT PRESSURE (MB) FOR TOVS LEVEL I. -C - PY = PTOV(I) -C -C...LOOP THROUGH THE MEAN PRESSURES OF EACH LAYER -C...TO DETERMINE IF THE PRESSURE, PY, AT EACH TOVS LEVEL I -C...LIES BETWEEN THEM. -C - DO 300 J=1,NML - DF1= PY - PX(J+1) - DF2= PY - PX(J) - IF(DF1.LE.0..AND.DF2.GE.0.) GO TO 350 - 300 CONTINUE -C -C...INTERPOLATE TEMPERATURE AND MOISTURE INFORMATION TO THE 40 TOVS -C...LEVELS USING THE FOLLOWING INTERPOLATION FORMULA WHICH IS LINEAR -C...WITH RESPECT TO THE NATURAL LOGARITHM OF PRESSURE. -C - 350 FAC = ALOG(PX(J)/PY) / ALOG(PX(J)/PX(J+1)) - TTOV(I) = TX(J) +(TX(J+1)-TX(J))*FAC - WTOV(I) = WX(J) +(WX(J+1)-WX(J))*FAC - 800 CONTINUE -C WRITE(6,*) ' TTOV=',TTOV -C WRITE(6,*) ' WTOV=',WTOV - RETURN - END - SUBROUTINE FI8105(PTOVS,TMP,WVMR,ZHGT,NBUG) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8105 GEO. HGT. FROM TOVS 40-LEVEL TEMP, RATMIX -C PRGMMR: BERT B. KATZ ORG: W/NMC23 DATE: 93-08-26 -C GENERAL -C SCIENCES CORP. -C -C ABSTRACT: CALCULATES GEOPOTENTIAL HEIGHTS HYDROSTATICALLY FROM TOVS -C 40-LEVEL RETRIEVAL. -C -C PROGRAM HISTORY LOG: -C 93-06-02 MIKE FERGUSON (NESDIS) -C 93-08-26 BERT B. KATZ MODIFIED FOR NMC OPERATIONAL USE. -C -C USAGE: CALL FI8105 (PTOVS,TMP,WVMR,ZHGT,NBUG) -C INPUT ARGUMENT LIST: -C PTOVS - TOVS 40 PRESSURE LEVELS (MB). -C TMP - 40-LEVEL TOVS RTRVL TEMPS (DEG K). -C WVMR - 40-LEVEL TOVS RTRVL MOISTURE (G/KG). -C NBUG - DEBUG FLAG. -C -C OUTPUT ARGUMENT LIST: -C ZHGT - GEOPOTENTIAL HEIGHTS (M) AT 40 TOVS LEVELS. -C -C REMARKS: USES COMMON TPRES. CALLS SUBROUTINE IATROP TO CALCULATE -C TROPOPAUSE PRESSURE AND TEMPERATURE VIA SPLINE FITTING TECHNIQUE. -C -C PARAMETERS- -C VARIABLE TYPE FUNCTION -C -------- ---- -------- -C CONS REAL GAS CONSTANT FOR DRY AIR -C (287 J/KG K) DIVIDED BY 2 * G -C (9.8M/S**2). -C ATTRIBUTES: -C LANGUAGE: VS FORTRAN, CFT77 -C MACHINE: HDS OR CRAY -C -C$$$ -C - REAL WVMR(40),TVIRT(40),ZHGT(40),PTOVS(40),TMP(40) - DATA CONS/-14.6435/ -C -C...INITIALIZE GEOP. HIEGHTS ARRAY -C -C PRINT *, 'NBUG IN FI8105 IS ',NBUG - DO 5 I = 1,40 - ZHGT(I) = 0.0 - 5 CONTINUE -C -C...COMPUTE VIRTUAL TEMPERATURES(DEGREES KELVIN). -C - DO 40 L = 1 , 40 - TVIRT(L) = TMP(L) + WVMR(L) / 6.0 - 40 CONTINUE -C7/20 IF(MOD(NBUG,100).EQ.0)THEN -C7/20 PRINT *, 'TEMPS INSIDE FI8105 ,1000,700,500,300 = ', -C7/20+TMP(40),TMP(35),TMP(31),TMP(26) -C7/20 PRINT *, 'V TEMPS INSIDE FI8105 ,1000,700,500,300 = ', -C7/20+TVIRT(40),TVIRT(35),TVIRT(31),TVIRT(26) -C7/20 ENDIF -C -C...COMPUTE GEOPOTENTIAL HEIGHTS (METERS) AT TOVS LEVELS. -C - DO 60 J = 2,40 - I = 40 + 1 - J - DLP = ALOG(PTOVS(I)/PTOVS(I+1)) - ZHGT(I) = ZHGT(I+1) + (TVIRT(I)+TVIRT(I+1)) * DLP * CONS - 60 CONTINUE -C7/20 IF(MOD(NBUG,100).EQ.0)THEN -C7/20 PRINT *, 'GEOPOTENTIALS INSIDE FI8105,1000,700,500,300 = ', -C7/20+ZHGT(40),ZHGT(35),ZHGT(31),ZHGT(26) -C7/20 ENDIF - RETURN - END - SUBROUTINE FI8106(PTOVS,TVGPHT,ZHT,STDPTT,STDPLW,STDPUP,NBUG) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8106 CALCULATES STABILITY DEPARTURES -C PRGMMR: BERT B. KATZ ORG: W/NMC23 DATE: 93-08-26 -C GENERAL -C SCIENCES CORP. -C -C ABSTRACT: USING INPUT GEOPOTENTIAL HEIGHTS FROM TWO SOURCES, -C CALCULATES LAYER-MEAN VIRTUAL TEMPERATURES FOR BOTH SOURCES -C AND THE DIFFERENCE IN STABILITY FOR THE 1000 MB - 700 MB LAYER, -C THE 500 MB - 300 MB LAYER, AND THE DIFFERENCE BETWEEN THESE TWO -C LAYERS. -C -C PROGRAM HISTORY LOG: -C 93-06-01 MIKE FERGUSON (NESDIS) -C 93-08-26 BERT B. KATZ MODIFIED FOR NMC OPERATIONAL USE. -C -C -C USAGE: CALL FI8106(PTOVS,TVGPHT,ZHT,STDPTT,STDPLW,STDPUP,NBUG) -C INPUT ARGUMENT LIST: -C PTOVS - TOVS 40 PRESSURE LEVELS (MB). -C TVGPHT - GEOPOTENTIAL HEIGHTS (M) FROM SOURCE 1. -C ZHT - GEOPOTENTIAL HEIGHTS (M) FROM SOURCE 2. -C NBUG - DEBUG FLAG. -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C STDPTT - STABILITY DEPARTURE BETWEEN SOURCE 1 AND SOURCE 2 : -C DIFFERENCE BETWEEN 1000 MB - 700 MB LAYER AND -C 500 MB - 300 MB LAYER. -C STDPLW - STABILITY DEPARTURE BETWEEN SOURCE 1 AND SOURCE 2 -C IN THE 1000 MB - 700 MB LAYER. -C STDPUP - STABILITY DEPARTURE BETWEEN SOURCE 1 AND SOURCE 2 -C IN THE 500 MB - 300 MB LAYER. -C -C OUTPUT FILES: -C FT06F001 - USED FOR DEBUG PRINTOUT. -C -C ATTRIBUTES: -C LANGUAGE: VS FORTRAN, CFT77 -C MACHINE: HDS OR CRAY -C -C$$$ -C - REAL PTOVS(40) - REAL ZHT(40),TVGPHT(40) -C - DATA CONS/-14.6435/ - DATA CONSTL/6.6890756E-02/ - DATA CONSTU/9.5786797E-02/ -C -C...INITIALIZE STABILITY DEPARTURE VALUES -C - STDPTT = -9999.9 - STDPLW = -9999.9 - STDPUP = -9999.9 -C PRINT *, 'NBUG IN FI8106 = ',NBUG -C -C...COMPUTE STABILITY DEPARTURE FOR 6-HOUR GUESS -C -C -C...COMPUTE STABILITY TERMS -C - RTUPDP = (TVGPHT(26) - TVGPHT(31)) * CONSTL - RTLWDP = (TVGPHT(35) - TVGPHT(40)) * CONSTU - RBUPDP = (ZHT(26) - ZHT(31)) * CONSTL - RBLWDP = (ZHT(35) - ZHT(40)) * CONSTU -C PRINT *, 'OPR RET 1000,700,500,300 GPH ',TVGPHT(40),TVGPHT(35), -C +TVGPHT(31),TVGPHT(26) -C PRINT *, 'GES 1000,700,500,300 GPH ',ZHT(40),ZHT(35), -C +ZHT(31),ZHT(26) -C -C RTSDP=RETRIEVAL TOTAL STABILITY DEPARTURE,RTLWDP=LOWER STABILITY -C RTUPDP=UPPER STABILITY -C -C -C...COMPUTE STABILITY DEPARTURES -C - STDPLW = RTLWDP - RBLWDP - STDPUP = RTUPDP - RBUPDP - STDPTT = STDPLW - STDPUP -C - 8000 RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fi81.f.save b/src/fim/FIMsrc/w3/w3fi81.f.save deleted file mode 100644 index dc1ddbb..0000000 --- a/src/fim/FIMsrc/w3/w3fi81.f.save +++ /dev/null @@ -1,2300 +0,0 @@ - SUBROUTINE W3FI81(IUNIT0,IUNIT1,IUNIT2,IUBTBL,IUDTBL,IBUFTN,IERR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI81 READS 3 BUFR RTRVL FILES, REFORMATS DATA -C PRGMMR: BERT B. KATZ ORG: W/NMC23 DATE: 93-06-09 -C GENERAL -C SCIENCES CORP. -C -C ABSTRACT: READS AND UNPACKS THREE BUFR INTERACTIVE RETRIEVAL FILES : -C (1) TOVS 40-LEVEL AND RADIANCE DATA, (2) INTERACTIVE RETRIEVALS, AND -C (3) ANALYSIS INTERPOLATION. THE NECESSARY QUANTITIES ARE REARRANGED -C INTO THE FORMAT OF A NESDIS FORMATTED FILE, IN INTEGERS THE SIZE -C OF THE MACHINE'S WORD LENGTH. -C -C PROGRAM HISTORY LOG: -C 93-06-09 BERT B. KATZ -C 93-09-08 BERT B. KATZ -- SUPPLIED MISSING ANALYZED SURFACE PRESSURE -C FIELD AND ADDED "STABILITY DEPARTURE" -C QUANTITIES AS PER NESDIS REQUEST. -C 93-10-22 BERT B. KATZ -- CHANGED UNIVERSAL BUFR DESCRIPTOR 2080 -C TO LOCAL BUFR DESCRIPTOR 2280. -C 95-05-11 BERT B. KATZ -- CHANGED TO ALLOW PROCESSING OF RETRIEVALS -C FROM NOAA-14. -C -C -C USAGE : CALL W3FI81(IUNIT0,IUNIT1,IUNIT2,IUBTBL,IUDTBL,IBUFTN,IERR) -C INPUT ARGUMENT LIST: -C IUNIT0 - UNIT NUMBER OF INPUT FILE CONTAINING TOVS 40-LEVEL -C - RETRIEVALS AND RADIANCES IN BUFR FORMAT. -C IUNIT1 - UNIT NUMBER OF INPUT FILE CONTAINING INTERACTIVE -C - RETRIEVALS IN BUFR FORMAT. -C IUNIT2 - UNIT NUMBER OF INPUT FILE CONTAINING ANALYSIS -C - INTERPOLATION DATA IN BUFR FORMAT. -C IUBTBL - UNIT NUMBER OF INPUT FILE CONTAINING BUFR TABLE B. -C IUDTBL - UNIT NUMBER OF INPUT FILE CONTAINING BUFR TABLE D. -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C IBUFTN - CONTAINS THE CONTENTS OF A RECORD IN A NESDIS -C - FORMAT IN MACHINE WORD LENGTH INTEGERS. -C IERR - ERROR RETURN CODE (= 0 FOR NORMAL COMPLETION) -C - (= 3 FOR NORMAL END-OF-FILE ON ALL THREE FILES) -C - (= 1111 FOR BUFR DECODING ERROR ON TOVS 40-LEVEL FILE) -C - (= 2222 FOR BUFR DECODING ERROR ON TOVS 40-LEVEL FILE) -C - (= 3333 FOR BUFR DECODING ERROR ON TOVS 40-LEVEL FILE) -C - (= 4444 FOR BUFR DECODING ERROR ON INTER. RTRVL. FILE) -C - (= 5555 FOR BUFR DECODING ERROR ON INTER. RTRVL. FILE) -C - (= 6666 FOR BUFR DECODING ERROR ON INTER. RTRVL. FILE) -C - (= 7777 FOR BUFR DECODING ERROR ON ANALY. INTERP. FILE) -C - (= 8888 FOR BUFR DECODING ERROR ON ANALY. INTERP. FILE) -C - (=55555 FOR DATA MISMATCH BETWEEN THE THREE FILES) -C - (=66666 FOR DATA MISMATCH BETWEEN THE THREE FILES) -C - (=77777 FOR DATA MISMATCH BETWEEN THE THREE FILES) -C - (=88888 FOR DATA MISMATCH BETWEEN THE THREE FILES) -C - (=99999 FOR DATA MISMATCH BETWEEN THE THREE FILES) -C -C INPUT FILES: -C FT(IUNIT0)F001 -C - FILE CONTAINING TOVS 40-LEVEL RETRIEVAL AND RADIANCE -C - DATA IN BUFR FORM. -C FT(IUNIT1)F001 -C - FILE CONTAINING INTERACTIVE RETRIEVAL DATA IN -C - BUFR FORM. -C FT(IUNIT2)F001 -C - FILE CONTAINING ANALYSIS INTERPOLATION DATA IN -C - BUFR FORM. -C FT(IUBTBL)F001 -C - FILE CONTAINING BUFR TABLE B. -C FT(IUDTBL)F001 -C - FILE CONTAINING BUFR TABLE D. -C -C REMARKS: CALLS SUBROUTINE W3FI78 TO UNPACK BUFR DATA. -C CALLS SUBROUTINE FI8101 TO FILL COMMON BLOCK /FI80TV/ WITH -C LOCATION AND SCALING OF 40-LEVEL TOVS RETRIEVALS. -C CALLS SUBROUTINE FI8102 TO FILL COMMON BLOCK /FI80IA/ WITH -C LOCATION AND SCALING OF INTERACTIVE RETRIEVALS. -C CALLS SUBROUTINE FI8103 TO FILL COMMON BLOCK /FI80AN/ WITH -C LOCATION AND SCALING OF ANALYSIS INTERPOLATION DATA. -C CALLS SUBROUTINE FI8104 TO INTERPOLATE MODEL TEMPERATURES -C AND MIXING RATIOS TO TOVS 40 PRESSURE LEVELS. -C CALLS SUBROUTINE FI8105 TO GENERATE GEOPOTENTIAL HEIGHTS -C HYDROSTATICALLY FROM TEMPERATURES AND MIXING RATIOS -C INTERPOLATED FROM MODEL TO TOVS LEVELS IN SUBROUTINE -C FI8105. -C CALL SUBROUTINE FI8106 TO CALCULATE STABILITY DEPARTURES -C BETWEEN TOVS OPERATIONAL RETRIEVAL AND THE MODEL FIRST GUESS -C FOR 1000 MB - 700 MB LAYER AND 500 MB - 300 MB LAYER. -C -C ATTRIBUTES: -C LANGUAGE: VS FORTRAN, CFT77 -C MACHINE: HDS OR CRAY -C -C$$$ -C - PARAMETER (MXIRPT=50,MXIDSC=420) - PARAMETER (MXRPTR=30,MXDSCR=700) - PARAMETER (MXRPTA=100,MXDSCA=200) - PARAMETER (NMLO=28) - PARAMETER (NML=70,NUL=39) - SAVE IFIRST,INDEX0,INDEX1,INDEX2,IPTR0,IPTR1,IPTR2, - 1 IDENT0,IDENT1,IDENT2,KDATA0,KDATA1,KDATA2,IENFIL - REAL GEOOPR(40),TGES40(40),WGES40(40),GEOGES(40) - REAL TGES(NMLO),WGES(NMLO),PGES(NMLO) - INTEGER IPTR0(40) - INTEGER IDENT0(20) - INTEGER ISTCK0(MXIDSC) - INTEGER MSTCK0(2,MXIDSC) - INTEGER KDATA0(MXIRPT,MXIDSC) - INTEGER KNR0(MXIRPT) - INTEGER IPTR1(40) - INTEGER IDENT1(20) - INTEGER ISTCK1(MXDSCR) - INTEGER MSTCK1(2,MXDSCR) - INTEGER KDATA1(MXRPTR,MXDSCR) - INTEGER KNR1(MXRPTR) - INTEGER IPTR2(40) - INTEGER IDENT2(20) - INTEGER ISTCK2(MXDSCA) - INTEGER MSTCK2(2,MXDSCA) - INTEGER KDATA2(MXRPTA,MXDSCA) - INTEGER KNR2(MXRPTA) - INTEGER INDEX0,INDEX1,INDEX2 - INTEGER IFIRST -C -C - INTEGER IBUFTN(720) - INTEGER MSGA(2500) - CHARACTER*1 CMSGA(10000) - EQUIVALENCE (MSGA(1),CMSGA(1)) -C -C - COMMON /FI81TV/ LCSTII, LCSSBC, LCMBBX, - 1 LCINSI, LCRTMI, LCFLFI, - 2 LCYRI , LCMONI, LCDAYI, - 3 LCHRI , LCMINI, LCSECI, - 4 LCLSI , LCNDI , LCFGAP, - 5 LCDVHI, LCDVMI, LCDVSI, - 6 LCNMCI, LWNMCI, LCRTPI, - 7 LCLATI, IXLATI, LCLONI, IXLONI, - 8 LCSTUI, LCSSTA, LCST15, IXST15, - 9 LCSZAN, IXSZAN, LCLSZA, IXLSZA, - A LCSALB, IXSALB, LCSKNI, IXSKNI, - B LCH8FI, LCPLSI, IXPLSI, LCSFHI, IXSFHI, - C LCICOI, LCOZON, IXOZON, LCAVNS, IXAVNS, - D LCICTI, LCPTRI, IXPTRI, LCTTRI, IXTTRI - COMMON /FI81TV/ LCP40I(40), IXP40I(40), - 1 LCT40I(40), IXT40I(40), - 2 LCH40I(40), IXH40I(40), - 3 LCM40I(40), IXM40I(40), - 4 LCP4GI(40), IXP4GI(40), - 5 LCT4GI(40), IXT4GI(40), - 6 LCM4GI(40), IXM4GI(40), - 7 LCRADI(27), IXRADI(27), - 8 LCRDGI(27), IXRDGI(27) - COMMON /FI81IA/ LCSTIR , LCLSR , LCNDR , - 1 LCNMCR , LWNMCR , LCFCYC , - 2 LCINSR , LCRTMR , LCRTPR , - 3 LCDVHR , LCDVMR , LCDVSR , - 4 LCSTUR , LCICOR , LCFLFR , - 5 LCLATR , IXLATR , - 6 LCLONR , IXLONR , - 7 LCPTRR , IXPTRR , - 8 LCTTRR , IXTTRR , LCICTR , - 9 LCSKNT , IXSKNT , - A LCPLSR , IXPLSR , - B LCSFHF , IXSFHF , - C LCPSFF , IXPSFF , - D LCSKNF , IXSKNF , - E LCSKNR , IXSKNR , LCH8FR - COMMON /FI81IA/ LCRADF(27) , IXRADF(27) , - 1 LCRDFC(27) , IXRDFC(27) , - 2 LCSIGI(NMLO), IXSIGI(NMLO), - 3 LCTMPI(NMLO), IXTMPI(NMLO), - 4 LCRADR(27) , IXRADR(27) , - 5 LCRDRC(27) , IXRDRC(27) , - 6 LCSIGF(NMLO), IXSIGF(NMLO), - 7 LCTMPF(NMLO), IXTMPF(NMLO), - 8 LCMIXF(NMLO), IXMIXF(NMLO), - 9 LCSIGR(NML) , IXSIGR(NML) , - A LCTMPR(NML) , IXTMPR(NML) , - B LCMIXR(NML) , IXMIXR(NML) , - C LCP41I , IXP41I , - D LCT41I , IXT41I , - E LCM41I , IXM41I - COMMON /FI81AN/ LCSTIA , LCYRA , LCMONA , - 1 LCDAYA , LCHRA , LCMINA , - 2 LCLATA , IXLATA , - 3 LCLONA , IXLONA , - 4 LCPSFA , IXPSFA , - 5 LCSFHA , IXSFHA , - 6 LCNMCA , LWNMCA , - 7 LCSIGA(NMLO), IXSIGA(NMLO), - 8 LCTMPA(NMLO), IXTMPA(NMLO), - 9 LCMIXA(NMLO), IXMIXA(NMLO), - A LCRADA(27) , IXRADA(27) , - B LCRDAC(27) , IXRDAC(27) -C - REAL TENS(-75:75) - REAL PTOVS(41) - INTEGER IDXHGT(18) - DATA (TENS(I),I=-75,-1,+1) - 1 /1.0E-75,1.0E-74,1.0E-73,1.0E-72,1.0E-71,1.0E-70,1.0E-69,1.0E-68, - 2 1.0E-67,1.0E-66,1.0E-65,1.0E-64,1.0E-63,1.0E-62,1.0E-61,1.0E-60, - 3 1.0E-59,1.0E-58,1.0E-57,1.0E-56,1.0E-55,1.0E-54,1.0E-53,1.0E-52, - 4 1.0E-51,1.0E-50,1.0E-49,1.0E-48,1.0E-47,1.0E-46,1.0E-45,1.0E-44, - 5 1.0E-43,1.0E-42,1.0E-41,1.0E-40,1.0E-39,1.0E-38,1.0E-37,1.0E-36, - 6 1.0E-35,1.0E-34,1.0E-33,1.0E-32,1.0E-31,1.0E-30,1.0E-29,1.0E-28, - 7 1.0E-27,1.0E-26,1.0E-25,1.0E-24,1.0E-23,1.0E-22,1.0E-21,1.0E-20, - 8 1.0E-19,1.0E-18,1.0E-17,1.0E-16,1.0E-15,1.0E-14,1.0E-13,1.0E-12, - 9 1.0E-11,1.0E-10,1.0E-09,1.0E-08,1.0E-07,1.0E-06,1.0E-05,1.0E-04, - A 1.0E-03,1.0E-02,1.0E-01/ - DATA (TENS(I),I=75,0,-1) - 1 /1.0E+75,1.0E+74,1.0E+73,1.0E+72,1.0E+71,1.0E+70,1.0E+69,1.0E+68, - 2 1.0E+67,1.0E+66,1.0E+65,1.0E+64,1.0E+63,1.0E+62,1.0E+61,1.0E+60, - 3 1.0E+59,1.0E+58,1.0E+57,1.0E+56,1.0E+55,1.0E+54,1.0E+53,1.0E+52, - 4 1.0E+51,1.0E+50,1.0E+49,1.0E+48,1.0E+47,1.0E+46,1.0E+45,1.0E+44, - 5 1.0E+43,1.0E+42,1.0E+41,1.0E+40,1.0E+39,1.0E+38,1.0E+37,1.0E+36, - 6 1.0E+35,1.0E+34,1.0E+33,1.0E+32,1.0E+31,1.0E+30,1.0E+29,1.0E+28, - 7 1.0E+27,1.0E+26,1.0E+25,1.0E+24,1.0E+23,1.0E+22,1.0E+21,1.0E+20, - 8 1.0E+19,1.0E+18,1.0E+17,1.0E+16,1.0E+15,1.0E+14,1.0E+13,1.0E+12, - 9 1.0E+11,1.0E+10,1.0E+09,1.0E+08,1.0E+07,1.0E+06,1.0E+05,1.0E+04, - A 1.0E+03,1.0E+02,1.0E+01,1.0 / - DATA PTOVS/0.1,0.2,0.5,1.,1.5,2.,3., - 1 4.,5.,7.,10.,15.,20.,25.,30., - 2 50.,60.,70.,85.,100.,115.,135., - 3 150.,200.,250.,300.,350.,400., - 4 430.,475.,500.,570.,620.,670., - 5 700.,780.,850.,920.,950.,1000.,1070./ - DATA IDXHGT/4,7,10,11,13,15,16,18,20,23,24,25,26,28,31,35,37,40/ -C - DATA IFIRST/0/ -C -C READ IN AND DECODE BUFR MESSAGE -C - IF(IFIRST.EQ.0) THEN - IENFIL = 0 - INDEX0 = 0 - INDEX1 = 0 - INDEX2 = 0 - ENDIF - IF(INDEX0.EQ.0) THEN - DO 2 I=1,40 - IPTR0(I) = 0 - 2 CONTINUE - DO 4 I=1,20 - IDENT0(I) = 0 - 4 CONTINUE - READ(IUNIT0,END=9970) CMSGA - REWIND IUBTBL - REWIND IUDTBL - ENDIF -C - 1000 CONTINUE - CALL W3FI78(IPTR0,IDENT0,MSGA,ISTCK0,MSTCK0,KDATA0,KNR0,INDEX0, - 1 MXIRPT,MXIDSC,IUBTBL,IUDTBL) - IF(IPTR0(1).EQ.99) THEN - INDEX0 = 0 - READ(IUNIT0,END=9970) CMSGA - GO TO 1000 - ENDIF -C -C CHECK FOR BUFR DECODING ERROR -C - IF(INDEX0.EQ.1) THEN - IF(IPTR0(1).NE.0) THEN - IERR = 1111 - RETURN - ENDIF -C -C CHECK FOR DELAYED REPLICATION -C - IF(IPTR0(39).NE.0) THEN - IERR = 2222 - RETURN - ENDIF - NRPTS = IDENT0(14) - NDESC = IPTR0(31) -C -C CHECK FOR NON-UNIFORM REPORTS -C - DO 10 I = 1 , NRPTS - IF(KNR0(I).NE.NDESC) THEN - IERR = 3333 - RETURN - ENDIF - 10 CONTINUE - NDESC = IPTR0(31) + IPTR0(24) - ENDIF -C - IF(IFIRST.EQ.0) THEN - CALL FI8101(MSTCK0,KDATA0,NDESC) - ENDIF - IF(INDEX1.EQ.0) THEN - DO 12 I=1,40 - IPTR1(I) = 0 - 12 CONTINUE - DO 14 I=1,20 - IDENT1(I) = 0 - 14 CONTINUE - READ(IUNIT1,END=9980) CMSGA - REWIND IUBTBL - REWIND IUDTBL - ENDIF -C - 1100 CONTINUE - CALL W3FI78(IPTR1,IDENT1,MSGA,ISTCK1,MSTCK1,KDATA1,KNR1,INDEX1, - 1 MXRPTR,MXDSCR,IUBTBL,IUDTBL) - IF(IPTR1(1).EQ.99) THEN - INDEX1 = 0 - READ(IUNIT1,END=9980) CMSGA - GO TO 1100 - ENDIF -C -C CHECK FOR BUFR DECODING ERROR -C - IF(INDEX1.EQ.1) THEN - IF(IPTR1(1).NE.0) THEN - IERR = 4444 - RETURN - ENDIF -C -C CHECK FOR DELAYED REPLICATION -C - IF(IPTR1(39).NE.0) THEN - IERR = 5555 - RETURN - ENDIF - NRPTS = IDENT1(14) - NDESC = IPTR1(31) -C -C CHECK FOR NON-UNIFORM REPORTS -C - DO 20 I = 1 , NRPTS - IF(KNR1(I).NE.NDESC) THEN - IERR = 6666 - RETURN - ENDIF - 20 CONTINUE - NDESC = IPTR1(31) + IPTR1(24) - ENDIF -C - IF(IFIRST.EQ.0) THEN - CALL FI8102(MSTCK1,KDATA1,NDESC) - ENDIF - IF(INDEX2.EQ.0) THEN - DO 22 I=1,40 - IPTR2(I) = 0 - 22 CONTINUE - DO 24 I=1,20 - IDENT2(I) = 0 - 24 CONTINUE - READ(IUNIT2,END=9990) CMSGA - REWIND IUBTBL - REWIND IUDTBL - ENDIF -C - 1200 CONTINUE - CALL W3FI78(IPTR2,IDENT2,MSGA,ISTCK2,MSTCK2,KDATA2,KNR2,INDEX2, - 1 MXRPTA,MXDSCA,IUBTBL,IUDTBL) - IF(IPTR2(1).EQ.99) THEN - INDEX2 = 0 - READ(IUNIT2,END=9990) CMSGA - GO TO 1200 - ENDIF -C -C CHECK FOR BUFR DECODING ERROR -C - IF(INDEX2.EQ.1) THEN - IF(IPTR2(1).NE.0) THEN - IERR = 7777 - RETURN - ENDIF -C -C CHECK FOR DELAYED REPLICATION -C - IF(IPTR2(39).NE.0) THEN - IERR = 8888 - RETURN - ENDIF - NRPTS = IDENT2(14) - NDESC = IPTR2(31) -C -C CHECK FOR NON-UNIFORM REPORTS -C - DO 30 I = 1 , NRPTS - IF(KNR2(I).NE.NDESC) THEN - IERR = 9999 - RETURN - ENDIF - 30 CONTINUE - NDESC = IPTR2(31) + IPTR2(24) - ENDIF -C - IF(IFIRST.EQ.0) THEN - CALL FI8103(MSTCK2,KDATA2,NDESC) - IFIRST = 1 - ENDIF -C - IF(LWNMCI.EQ.LWNMCR .AND. LWNMCR.EQ.LWNMCA) THEN - DO 1250 K = 1 , LWNMCR - IF(KDATA0(INDEX0,LCNMCI+K-1).NE.KDATA1(INDEX1,LCNMCR+K-1) .OR. - 1 KDATA1(INDEX1,LCNMCR+K-1).NE.KDATA2(INDEX2,LCNMCA+K-1)) - 2 THEN - IERR = 99999 - RETURN - ENDIF - 1250 CONTINUE - ELSE - IERR = 99999 - RETURN - ENDIF - IF(KDATA0(INDEX0,LCLATI).NE.KDATA1(INDEX1,LCLATR) .OR. - 1 KDATA1(INDEX1,LCLATR).NE.KDATA2(INDEX2,LCLATA) .OR. - 2 IXLATI.NE.IXLATR .OR. IXLATR.NE.IXLATA) THEN - IERR = 88888 - RETURN - ENDIF - IF(KDATA0(INDEX0,LCLONI).NE.KDATA1(INDEX1,LCLONR) .OR. - 1 KDATA1(INDEX1,LCLONR).NE.KDATA2(INDEX2,LCLONA) .OR. - 2 IXLONI.NE.IXLONR .OR. IXLONR.NE.IXLONA) THEN - IERR = 77777 - RETURN - ENDIF - IF(KDATA0(INDEX0,LCSTII).NE.KDATA1(INDEX1,LCSTIR) .OR. - 1 KDATA1(INDEX1,LCSTIR).NE.KDATA2(INDEX2,LCSTIA)) THEN - IERR = 66666 - RETURN - ENDIF - DO 1300 K = 1 , NMLO - IF(KDATA1(INDEX1,LCSIGF(K)).NE.KDATA2(INDEX2,LCSIGA(K)) .OR. - 1 IXSIGF(K).NE.IXSIGA(K)) THEN - IERR = 55555 - RETURN - ENDIF - 1300 CONTINUE - ISSBCT = KDATA0(INDEX0,LCSSBC) - IBUFTN(1) = ISSBCT / 1000 - ISATID = KDATA0(INDEX0,LCSTII) - IF(ISATID.EQ.203) THEN - IBUFTN(2) = 1 - IBUFTN(3) = 1 - ELSE IF(ISATID.EQ.204) THEN - IBUFTN(2) = 2 - IBUFTN(3) = 2 - ELSE IF(ISATID.EQ.205) THEN - IBUFTN(2) = 3 - IBUFTN(3) = 3 - ENDIF - IBUFTN(12) = MOD(ISSBCT,1000) - IBUFTN(13) = KDATA0(INDEX0,LCMBBX) - XLAT = KDATA0(INDEX0,LCLATI) * TENS(IXLATI) - IBUFTN(14) = 128.0 * XLAT + SIGN(0.5,XLAT) - IF(XLAT.GE.60.0) THEN - LATZON = 1 - ELSE IF(XLAT.GE.45.0) THEN - LATZON = 2 - ELSE IF(XLAT.GE.30.0) THEN - LATZON = 3 - ELSE IF(XLAT.GE.15.0) THEN - LATZON = 4 - ELSE IF(XLAT.GT.-15.0) THEN - LATZON = 5 - ELSE IF(XLAT.GT.-30.0) THEN - LATZON = 6 - ELSE IF(XLAT.GT.-45.0) THEN - LATZON = 7 - ELSE IF(XLAT.GT.-60.0) THEN - LATZON = 8 - ELSE - LATZON = 9 - ENDIF - XLON = KDATA0(INDEX0,LCLONI) * TENS(IXLONI) - IBUFTN(15) = 128.0 * XLON + SIGN(0.5,XLON) - IYR = MOD(KDATA0(INDEX0,LCYRI),100) - IBUFTN(16) = 100 * IYR + KDATA0(INDEX0,LCMONI) - IBUFTN(17) = 100 * KDATA0(INDEX0,LCDAYI) + KDATA0(INDEX0,LCHRI) - IBUFTN(18) = 100 * KDATA0(INDEX0,LCMINI) + KDATA0(INDEX0,LCSECI) - INSTRU = KDATA0(INDEX0,LCINSI) - IRETMT = KDATA0(INDEX0,LCRTMI) - IF(MOD(INSTRU,128).GE.64) THEN - ISSUFL = 1 - ELSE - ISSUFL = 0 - ENDIF - IF(INSTRU.GE.256) THEN - IF(INSTRU.GE.384) THEN - MCL3 = 1 - ELSE - MCL3 = 2 - ENDIF - IF(MOD(IRETMT,64).GE.32) THEN - MCL1 = 1 - MCL2 = 1 - ICLOUD = 110 + MCL3 - ELSE IF(MOD(IRETMT,64).GE.16) THEN - MCL1 = 2 - MCL2 = 1 - ICLOUD = 210 + MCL3 - ELSE IF(MOD(IRETMT,64).GE.8) THEN - MCL1 = 2 - MCL2 = 2 - ICLOUD = 220 + MCL3 - ENDIF - ELSE IF(INSTRU.GE.128) THEN - MCL1 = 0 - MCL2 = 0 - ICLOUD = 3 - ENDIF - IF(INSTRU.EQ.448) THEN - ICCFLG = 1 - ELSE IF(INSTRU.EQ.384) THEN - ICCFLG = 2 - ELSE IF(INSTRU.EQ.256) THEN - ICCFLG = 3 - ELSE IF(INSTRU.EQ.320) THEN - ICCFLG = 4 - ELSE IF(INSTRU.EQ.128) THEN - ICCFLG = 5 - ELSE IF(INSTRU.EQ.192) THEN - ICCFLG = 6 - ELSE IF(INSTRU.EQ.64) THEN - ICCFLG = 7 - ENDIF - IF(IRETMT.GE.64) THEN - METRET = 0 - ELSE IF(MOD(IRETMT,8).GE.4) THEN - METRET = 1 - ENDIF - PLST = 0.01 * KDATA0(INDEX0,LCPLSI) * TENS(IXPLSI) - DO 1500 L=1,40 - IF(ABS(PLST - PTOVS(L)).LT.0.1) LSTOVS = L - 1500 CONTINUE - LNDSEA = KDATA0(INDEX0,LCLSI) - NGTDAY = KDATA0(INDEX0,LCNDI) - IBUFTN(19) = 10000 * LNDSEA + - 1 1000 * NGTDAY + - 2 100 * METRET + - 3 LSTOVS - IF(KDATA0(INDEX0,LCICOI).EQ.20480) THEN - ICCO3 = 1 - ELSE IF(KDATA0(INDEX0,LCICOI).EQ.16384) THEN - ICCO3 = 2 - ELSE IF(KDATA0(INDEX0,LCICOI).EQ.12288) THEN - ICCO3 = 3 - ELSE IF(KDATA0(INDEX0,LCICOI).EQ.8192) THEN - ICCO3 = 4 - ELSE IF(KDATA0(INDEX0,LCICOI).EQ.0) THEN - ICCO3 = 0 - ENDIF - IF(KDATA0(INDEX0,LCICTI).EQ.262144) THEN - ICTROP = 1 - ELSE IF(KDATA0(INDEX0,LCICTI).EQ.131072) THEN - ICTROP = 2 - ENDIF - IF(METRET.EQ.0) THEN - ICCMVS = 0 - ELSE IF(ICCFLG.LE.3) THEN - IF(MCL1.GE.1 .AND. MCL2.EQ.1) THEN - ICCMVS = 1 - ELSE IF(MCL1.EQ.2 .AND. MCL2.EQ.2) THEN - IF(LNDSEA.EQ.1) THEN - ICCMVS = 2 - ELSE - ICCMVS = 3 - ENDIF - ENDIF - ELSE IF(ICCFLG.GE.5) THEN - IF(LNDSEA.EQ.1) THEN - ICCMVS = 4 - ELSE - ICCMVS = 5 - ENDIF - ELSE - ICCMVS = 6 - ENDIF - IBUFTN(20) = 10000 * KDATA0(INDEX0,LCSTUI) + - 1 100 * ICCMVS + - 2 10 * ICCO3 + - 3 ICTROP - IBUFTN(21) = 1000 * KDATA0(INDEX0,LCH8FI) + - 1 100 * ISSUFL + - 2 10 * LATZON + - 3 ICCFLG - IBUFTN(22) = ICLOUD - IF(LNDSEA.EQ.0) THEN - IPBIN = LATZON - ELSE IF(NGTDAY.EQ.1) THEN - IPBIN = LATZON + 9 - ELSE - IPBIN = LATZON + 18 - ENDIF - IBUFTN(23) = 10000 * KDATA0(INDEX0,LCSSTA) + - 1 1000 * KDATA0(INDEX0,LCFGAP) + - 2 10 * IPBIN + - 3 KDATA0(INDEX0,LCFLFI) - SZANG = KDATA0(INDEX0,LCSZAN) * TENS(IXSZAN) - IBUFTN(24) = 128.0 * SZANG + SIGN(0.5,SZANG) - SZALO = KDATA0(INDEX0,LCLSZA) * TENS(IXLSZA) - IBUFTN(25) = 128.0 * SZALO + SIGN(0.5,SZALO) - DO 1600 L = 1 , 40 - TEMP = KDATA0(INDEX0,LCT40I(L)) * TENS(IXT40I(L)) - IBUFTN(L+25) = 64.0 * TEMP + 0.5 - 1600 CONTINUE - IHGT = 0 - DO 1700 L = 1 , 40 - IF(KDATA0(INDEX0,LCH40I(L)).NE.999999) THEN - GEO = KDATA0(INDEX0,LCH40I(L)) * TENS(IXH40I(L)) - IHGT = IHGT + 1 - GEOOPR(IDXHGT(IHGT)) = GEO - IF(IHGT.LE.9) THEN - IBUFTN(IHGT+65) = 0.1 * GEO + 0.5 - ELSE - IBUFTN(IHGT+65) = GEO + 0.5 - ENDIF - ENDIF - 1700 CONTINUE - DO 1800 L = 1 , 15 - RATMIX = KDATA0(INDEX0,LCM40I(L+25)) * TENS(IXM40I(L+25)) - IBUFTN(L+83) = 256000.0 * RATMIX + 0.5 - 1800 CONTINUE - TEMP = KDATA0(INDEX0,LCTTRI) * TENS(IXTTRI) - IBUFTN(99) = 64.0 * TEMP + 0.5 - PRES = KDATA0(INDEX0,LCPTRI) * TENS(IXPTRI) - IBUFTN(100) = 0.01 * PRES + 0.5 - OZONE = KDATA0(INDEX0,LCOZON) * TENS(IXOZON) - IBUFTN(101) = OZONE + 0.5 - DO 1900 L = 1 , 19 - IF(KDATA0(INDEX0,LCRADI(L)).NE.999999) THEN - RAD = KDATA0(INDEX0,LCRADI(L)) * TENS(IXRADI(L)) - IBUFTN(L+101) = 64.0 * RAD + 0.5 - ELSE - IBUFTN(L+101) = 32767 - ENDIF - 1900 CONTINUE - IF(KDATA0(INDEX0,LCRADI(20)).NE.999999) THEN - RAD = KDATA0(INDEX0,LCRADI(20)) * TENS(IXRADI(20)) - IBUFTN(121) = 16.0 * RAD + 0.5 - ELSE - IBUFTN(121) = 32767 - ENDIF - DO 2000 L = 21 , 27 - IF(KDATA0(INDEX0,LCRADI(L)).NE.999999) THEN - RAD = KDATA0(INDEX0,LCRADI(L)) * TENS(IXRADI(L)) - IBUFTN(L+101) = 64.0 * RAD + 0.5 - ELSE - IBUFTN(L+101) = 32767 - ENDIF - 2000 CONTINUE - AVGNST = KDATA0(INDEX0,LCAVNS) * TENS(IXAVNS) - IBUFTN(142) = 1024.0 * AVGNST + 0.5 - IF(KDATA0(INDEX0,LCSALB).NE.999999) THEN - SFCALB = KDATA0(INDEX0,LCSALB) * TENS(IXSALB) - IBUFTN(143) = SFCALB + 0.5 - ELSE - IBUFTN(143) = -899 - ENDIF - SKINT = KDATA0(INDEX0,LCSKNI) * TENS(IXSKNI) - IBUFTN(144) = 64.0 * SKINT + 0.5 - SFCHGT = KDATA0(INDEX0,LCSFHI) * TENS(IXSFHI) - IBUFTN(145) = SFCHGT + 0.5 - SST15 = KDATA0(INDEX0,LCST15) * TENS(IXST15) - IBUFTN(166) = 64.0 * SST15 + 0.5 - DO 2100 L = 1 , 40 - TEMP = KDATA0(INDEX0,LCT4GI(L)) * TENS(IXT4GI(L)) - IBUFTN(L+167) = 64.0 * TEMP + 0.5 - 2100 CONTINUE - DO 2200 L = 1 , 15 - RATMIX = KDATA0(INDEX0,LCM4GI(L+25)) * TENS(IXM4GI(L+25)) - IBUFTN(L+207) = 256000.0 * RATMIX + 0.5 - 2200 CONTINUE - DO 2300 L = 1 , 19 - IF(KDATA0(INDEX0,LCRDGI(L)).NE.999999) THEN - RAD = KDATA0(INDEX0,LCRDGI(L)) * TENS(IXRDGI(L)) - IBUFTN(L+222) = 64.0 * RAD + 0.5 - ELSE - IBUFTN(L+222) = 32767 - ENDIF - 2300 CONTINUE - IF(KDATA0(INDEX0,LCRDGI(20)).NE.999999) THEN - RAD = KDATA0(INDEX0,LCRDGI(20)) * TENS(IXRDGI(20)) - IBUFTN(242) = 16.0 * RAD + 0.5 - ELSE - IBUFTN(242) = 32767 - ENDIF - DO 2400 L = 21 , 27 - IF(KDATA0(INDEX0,LCRDGI(L)).NE.999999) THEN - RAD = KDATA0(INDEX0,LCRDGI(L)) * TENS(IXRDGI(L)) - IBUFTN(L+222) = 64.0 * RAD + 0.5 - ELSE - IBUFTN(L+222) = 32767 - ENDIF - 2400 CONTINUE - TEMP = KDATA1(INDEX1,LCSKNT) * TENS(IXSKNT) - IBUFTN(251) = 64.0 * TEMP + 0.5 - XLAT = KDATA1(INDEX1,LCLATR) * TENS(IXLATR) - IBUFTN(252) = 128.0 * XLAT + SIGN(0.5,XLAT) - IF(XLAT.GE.60.0) THEN - LATZON = 1 - ELSE IF(XLAT.GE.45.0) THEN - LATZON = 2 - ELSE IF(XLAT.GE.30.0) THEN - LATZON = 3 - ELSE IF(XLAT.GE.15.0) THEN - LATZON = 4 - ELSE IF(XLAT.GT.-15.0) THEN - LATZON = 5 - ELSE IF(XLAT.GT.-30.0) THEN - LATZON = 6 - ELSE IF(XLAT.GT.-45.0) THEN - LATZON = 7 - ELSE IF(XLAT.GT.-60.0) THEN - LATZON = 8 - ELSE - LATZON = 9 - ENDIF - XLON = KDATA1(INDEX1,LCLONR) * TENS(IXLONR) - IBUFTN(253) = 128.0 * XLON + SIGN(0.5,XLON) - INSTRU = KDATA1(INDEX1,LCINSR) - IRETMT = KDATA1(INDEX1,LCRTMR) - IF(MOD(INSTRU,128).GE.64) THEN - ISSUFL = 1 - ELSE - ISSUFL = 0 - ENDIF - IF(INSTRU.GE.256) THEN - IF(INSTRU.GE.384) THEN - MCL3 = 1 - ELSE - MCL3 = 2 - ENDIF - IF(MOD(IRETMT,64).GE.32) THEN - MCL1 = 1 - MCL2 = 1 - ICLOUD = 110 + MCL3 - ELSE IF(MOD(IRETMT,64).GE.16) THEN - MCL1 = 2 - MCL2 = 1 - ICLOUD = 210 + MCL3 - ELSE IF(MOD(IRETMT,64).GE.8) THEN - MCL1 = 2 - MCL2 = 2 - ICLOUD = 220 + MCL3 - ENDIF - ELSE IF(INSTRU.GE.128) THEN - MCL1 = 0 - MCL2 = 0 - ICLOUD = 3 - ENDIF - IF(INSTRU.EQ.448) THEN - ICCFLG = 1 - ELSE IF(INSTRU.EQ.384) THEN - ICCFLG = 2 - ELSE IF(INSTRU.EQ.256) THEN - ICCFLG = 3 - ELSE IF(INSTRU.EQ.320) THEN - ICCFLG = 4 - ELSE IF(INSTRU.EQ.128) THEN - ICCFLG = 5 - ELSE IF(INSTRU.EQ.192) THEN - ICCFLG = 6 - ELSE IF(INSTRU.EQ.64) THEN - ICCFLG = 7 - ENDIF - IF(IRETMT.GE.64) THEN - METRET = 0 - ELSE IF(MOD(IRETMT,8).GE.4) THEN - METRET = 1 - ENDIF - LNDSEA = KDATA1(INDEX1,LCLSR) - NGTDAY = KDATA1(INDEX1,LCNDR) - PLST = 0.01 * KDATA1(INDEX1,LCPLSR) * TENS(IXPLSR) - DO 2500 L=1,40 - IF(ABS(PLST - PTOVS(L)).LT.0.1) LST = L - 2500 CONTINUE - IBUFTN(254) = 10000 * LNDSEA + - 1 1000 * NGTDAY + - 2 100 * METRET + - 3 LST - IF(METRET.EQ.0) THEN - ICCMVS = 0 - ELSE IF(ICCFLG.LE.3) THEN - IF(MCL1.GE.1 .AND. MCL2.EQ.1) THEN - ICCMVS = 1 - ELSE IF(MCL1.EQ.2 .AND. MCL2.EQ.2) THEN - IF(LNDSEA.EQ.1) THEN - ICCMVS = 2 - ELSE - ICCMVS = 3 - ENDIF - ENDIF - ELSE IF(ICCFLG.GE.5) THEN - IF(LNDSEA.EQ.1) THEN - ICCMVS = 4 - ELSE - ICCMVS = 5 - ENDIF - ELSE - ICCMVS = 6 - ENDIF - IF(KDATA1(INDEX1,LCICOR).EQ.20480) THEN - ICCO3 = 1 - ELSE IF(KDATA1(INDEX1,LCICOR).EQ.16384) THEN - ICCO3 = 2 - ELSE IF(KDATA1(INDEX1,LCICOR).EQ.12288) THEN - ICCO3 = 3 - ELSE IF(KDATA1(INDEX1,LCICOR).EQ.8192) THEN - ICCO3 = 4 - ELSE IF(KDATA1(INDEX1,LCICOR).EQ.0) THEN - ICCO3 = 0 - ENDIF - IF(KDATA1(INDEX1,LCICTR).EQ.262144) THEN - ICTROP = 1 - ELSE IF(KDATA1(INDEX1,LCICTR).EQ.131072) THEN - ICTROP = 2 - ENDIF - IBUFTN(255) = 10000 * KDATA1(INDEX1,LCSTUR) + - 1 100 * ICCMVS + - 2 10 * ICCO3 + - 3 ICTROP - IBUFTN(256) = 1000 * KDATA1(INDEX1,LCH8FR) + - 1 100 * ISSUFL + - 2 10 * LATZON + - 3 ICCFLG - TEMP = KDATA1(INDEX1,LCTTRR) * TENS(IXTTRR) - IBUFTN(257) = 64.0 * TEMP + 0.5 - PRES = KDATA1(INDEX1,LCPTRR) * TENS(IXPTRR) - IBUFTN(258) = 0.01 * PRES + 0.5 - DO 2600 L = 1 , 19 - IF(KDATA1(INDEX1,LCRADF(L)).NE.999999) THEN - RAD = KDATA1(INDEX1,LCRADF(L)) * TENS(IXRADF(L)) - IBUFTN(L+258) = 64.0 * RAD + 0.5 - ELSE - IBUFTN(L+258) = 32767 - ENDIF - 2600 CONTINUE - IF(KDATA1(INDEX1,LCRADF(20)).NE.999999) THEN - RAD = KDATA1(INDEX1,LCRADF(20)) * TENS(IXRADF(20)) - IBUFTN(278) = 16.0 * RAD + 0.5 - ELSE - IBUFTN(278) = 32767 - ENDIF - DO 2700 L = 21 , 27 - IF(KDATA1(INDEX1,LCRADF(L)).NE.999999) THEN - RAD = KDATA1(INDEX1,LCRADF(L)) * TENS(IXRADF(L)) - IBUFTN(L+258) = 64.0 * RAD + 0.5 - ELSE - IBUFTN(L+258) = 32767 - ENDIF - 2700 CONTINUE - DO 2800 L = 1 , 19 - IF(KDATA1(INDEX1,LCRDFC(L)).NE.999999) THEN - RAD = KDATA1(INDEX1,LCRDFC(L)) * TENS(IXRDFC(L)) - IBUFTN(L+285) = 64.0 * RAD + 0.5 - ELSE - IBUFTN(L+285) = 32767 - ENDIF - 2800 CONTINUE - IF(KDATA1(INDEX1,LCRDFC(20)).NE.999999) THEN - RAD = KDATA1(INDEX1,LCRDFC(20)) * TENS(IXRDFC(20)) - IBUFTN(305) = 16.0 * RAD + 0.5 - ELSE - IBUFTN(305) = 32767 - ENDIF - DO 2900 L = 21 , 27 - IF(KDATA1(INDEX1,LCRDFC(L)).NE.999999) THEN - RAD = KDATA1(INDEX1,LCRDFC(L)) * TENS(IXRDFC(L)) - IBUFTN(L+285) = 64.0 * RAD + 0.5 - ELSE - IBUFTN(L+285) = 32767 - ENDIF - 2900 CONTINUE - TEMP = KDATA1(INDEX1,LCSKNF) * TENS(IXSKNF) - IBUFTN(313) = 64.0 * TEMP + 0.5 - SKINT = KDATA1(INDEX1,LCSKNR) * TENS(IXSKNR) - IBUFTN(314) = 64.0 * SKINT + 0.5 - DO 3000 L = 1 , NMLO - TEMP = KDATA1(INDEX1,LCTMPI(L)) * TENS(IXTMPI(L)) - IBUFTN(L+314) = 64.0 * TEMP + 0.5 - 3000 CONTINUE - TEMP = KDATA1(INDEX1,LCT41I) * TENS(IXT41I) - IBUFTN(343) = 64.0 * TEMP + 0.5 - DO 3100 L = 1 , 19 - IF(KDATA1(INDEX1,LCRADR(L)).NE.999999) THEN - RAD = KDATA1(INDEX1,LCRADR(L)) * TENS(IXRADR(L)) - IBUFTN(L+343) = 64.0 * RAD + 0.5 - ELSE - IBUFTN(L+343) = 32767 - ENDIF - 3100 CONTINUE - IF(KDATA1(INDEX1,LCRADR(20)).NE.999999) THEN - RAD = KDATA1(INDEX1,LCRADR(20)) * TENS(IXRADR(20)) - IBUFTN(363) = 16.0 * RAD + 0.5 - ELSE - IBUFTN(363) = 32767 - ENDIF - DO 3200 L = 21 , 27 - IF(KDATA1(INDEX1,LCRADR(L)).NE.999999) THEN - RAD = KDATA1(INDEX1,LCRADR(L)) * TENS(IXRADR(L)) - IBUFTN(L+343) = 64.0 * RAD + 0.5 - ELSE - IBUFTN(L+343) = 32767 - ENDIF - 3200 CONTINUE - DO 3300 L = 1 , 19 - IF(KDATA1(INDEX1,LCRDRC(L)).NE.999999) THEN - RAD = KDATA1(INDEX1,LCRDRC(L)) * TENS(IXRDRC(L)) - IBUFTN(L+370) = 64.0 * RAD + 0.5 - ELSE - IBUFTN(L+370) = 32767 - ENDIF - 3300 CONTINUE - IF(KDATA1(INDEX1,LCRDRC(20)).NE.999999) THEN - RAD = KDATA1(INDEX1,LCRDRC(20)) * TENS(IXRDRC(20)) - IBUFTN(390) = 16.0 * RAD + 0.5 - ELSE - IBUFTN(390) = 32767 - ENDIF - DO 3400 L = 21 , 27 - IF(KDATA1(INDEX1,LCRDRC(L)).NE.999999) THEN - RAD = KDATA1(INDEX1,LCRDRC(L)) * TENS(IXRDRC(L)) - IBUFTN(L+370) = 64.0 * RAD + 0.5 - ELSE - IBUFTN(L+370) = 32767 - ENDIF - 3400 CONTINUE - IBUFTN(398) = KDATA1(INDEX1,LCFCYC) - SFCHGT = KDATA1(INDEX1,LCSFHF) * TENS(IXSFHF) - IBUFTN(399) = SFCHGT + SIGN(0.5,SFCHGT) - PSFGES = 0.01 * KDATA1(INDEX1,LCPSFF) * TENS(IXPSFF) - IBUFTN(400) = AINT(50.0 * PSFGES + 0.5) - 32000.0 - DO 3500 L = 1 , NMLO - TGES(L) = KDATA1(INDEX1,LCTMPF(L)) * TENS(IXTMPF(L)) - PGES(L) = KDATA1(INDEX1,LCSIGF(L)) * TENS(IXSIGF(L)) * PSFGES - IBUFTN(L+400) = 64.0 * TGES(L) + 0.5 - 3500 CONTINUE - DO 3600 L = 1 , NMLO - WGES(L) = 1000.0 * KDATA1(INDEX1,LCMIXF(L)) * TENS(IXMIXF(L)) - IBUFTN(L+428) = 256.0 * WGES(L) + 0.5 - 3600 CONTINUE - DO 3700 L = 1 , NML - TEMP = KDATA1(INDEX1,LCTMPR(L)) * TENS(IXTMPR(L)) - IBUFTN(L+456) = 64.0 * TEMP + 0.5 - 3700 CONTINUE - DO 3800 L = 1 , NUL - RATMIX = KDATA1(INDEX1,LCMIXR(NML-NUL+L)) * - 1 TENS(IXMIXR(NML-NUL+L)) - IBUFTN(L+526) = 256000.0 * RATMIX + 0.5 - 3800 CONTINUE - DO 3900 L = 1 , 19 - IF(KDATA2(INDEX2,LCRADA(L)).NE.999999) THEN - RAD = KDATA2(INDEX2,LCRADA(L)) * TENS(IXRADA(L)) - IBUFTN(L+566) = 64.0 * RAD + 0.5 - ELSE - IBUFTN(L+566) = 32767 - ENDIF - 3900 CONTINUE - IF(LSTOVS.EQ.40) THEN - CALL FI8104(PSFGES,PGES,TGES,WGES,PTOVS,TGES40,WGES40,NMLO) - CALL FI8105(PTOVS,TGES40,WGES40,GEOGES,NBUG) - CALL FI8106(PTOVS,GEOOPR,GEOGES,STDPTT,STDPLW,STDPUP,NBUG) - IBUFTN(130) = 512.0 * STDPLW + SIGN(0.5,STDPLW) - IBUFTN(131) = 512.0 * STDPUP + SIGN(0.5,STDPUP) - IBUFTN(132) = 512.0 * STDPTT + SIGN(0.5,STDPTT) - ELSE - IBUFTN(130) = 32767 - IBUFTN(131) = 32767 - IBUFTN(132) = 32767 - ENDIF - IF(KDATA2(INDEX2,LCRADA(20)).NE.999999) THEN - RAD = KDATA2(INDEX2,LCRADA(20)) * TENS(IXRADA(20)) - IBUFTN(586) = 16.0 * RAD + 0.5 - ELSE - IBUFTN(586) = 32767 - ENDIF - DO 4000 L = 21 , 27 - IF(KDATA2(INDEX2,LCRADA(L)).NE.999999) THEN - RAD = KDATA2(INDEX2,LCRADA(L)) * TENS(IXRADA(L)) - IBUFTN(L+566) = 64.0 * RAD + 0.5 - ELSE - IBUFTN(L+566) = 32767 - ENDIF - 4000 CONTINUE - DO 4100 L = 1 , 19 - IF(KDATA2(INDEX2,LCRDAC(L)).NE.999999) THEN - RAD = KDATA2(INDEX2,LCRDAC(L)) * TENS(IXRDAC(L)) - IBUFTN(L+593) = 64.0 * RAD + 0.5 - ELSE - IBUFTN(L+593) = 32767 - ENDIF - 4100 CONTINUE - IF(KDATA2(INDEX2,LCRDAC(20)).NE.999999) THEN - RAD = KDATA2(INDEX2,LCRDAC(20)) * TENS(IXRDAC(20)) - IBUFTN(613) = 16.0 * RAD + 0.5 - ELSE - IBUFTN(613) = 32767 - ENDIF - DO 4200 L = 21 , 27 - IF(KDATA2(INDEX2,LCRDAC(L)).NE.999999) THEN - RAD = KDATA2(INDEX2,LCRDAC(L)) * TENS(IXRDAC(L)) - IBUFTN(L+593) = 64.0 * RAD + 0.5 - ELSE - IBUFTN(L+593) = 32767 - ENDIF - 4200 CONTINUE - PRES = KDATA2(INDEX2,LCPSFA) * TENS(IXPSFA) - IBUFTN(621) = AINT(50.0 * (0.01 * PRES) + 0.5) - 32000.0 - DO 4300 L = 1 , NMLO - TEMP = KDATA2(INDEX2,LCTMPA(L)) * TENS(IXTMPA(L)) - IBUFTN(L+621) = 64.0 * TEMP + 0.5 - 4300 CONTINUE - DO 4400 L = 1 , NMLO - RATMIX = KDATA2(INDEX2,LCMIXA(L)) * TENS(IXMIXA(L)) - IBUFTN(L+649) = 256000.0 * RATMIX + 0.5 - 4400 CONTINUE - IBUFTN(678) = MOD(KDATA2(INDEX2,LCYRA),100) - IBUFTN(679) = KDATA2(INDEX2,LCMONA) - IBUFTN(680) = KDATA2(INDEX2,LCDAYA) - IBUFTN(681) = KDATA2(INDEX2,LCHRA) - IBUFTN(682) = KDATA2(INDEX2,LCMINA) - IERR = 0 - RETURN -C - 9970 CONTINUE - WRITE(6,1001) IUNIT0 - 1001 FORMAT(' END OF FILE ON UNIT ',I5) - IENFIL = IENFIL + 1 - IF(IENFIL.EQ.3) GO TO 99999 - ICOUNT = 0 - 9975 CONTINUE - READ(IUNIT1,END=9978) CMSGA - ICOUNT = ICOUNT + 1 - GO TO 9975 -C - 9978 CONTINUE - INDEX1 = 0 - WRITE(6,1002) ICOUNT,IUNIT1 - 1002 FORMAT(' THERE ARE ',I5,' EXCESS BUFR MESSAGES ON UNIT ',I3) - 9980 CONTINUE - WRITE(6,1001) IUNIT1 - IENFIL = IENFIL + 1 - IF(IENFIL.EQ.3) GO TO 99999 - ICOUNT = 0 - 9985 CONTINUE - READ(IUNIT2,END=9988) CMSGA - ICOUNT = ICOUNT + 1 - GO TO 9985 -C - 9988 CONTINUE - INDEX2 = 0 - WRITE(6,1002) ICOUNT,IUNIT2 - 9990 CONTINUE - WRITE(6,1001) IUNIT2 - IENFIL = IENFIL + 1 - IF(IENFIL.EQ.3) GO TO 99999 - ICOUNT = 0 - 9995 CONTINUE - READ(IUNIT0,END=9998) CMSGA - ICOUNT = ICOUNT + 1 - GO TO 9995 -C - 9998 CONTINUE - INDEX0 = 0 - WRITE(6,1002) ICOUNT,IUNIT0 - GO TO 9970 -C -99999 CONTINUE - IERR = 3 - RETURN - END - SUBROUTINE FI8101(MSTACK,KDATA,NDESC) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8101 GETS INFO TO UNPACK BUFR 40-LVL TOVS RTRVLS -C PRGMMR: BERT B. KATZ ORG: W/NMC23 DATE: 93-06-09 -C GENERAL -C SCIENCES CORP. -C -C ABSTRACT: USES BUFR DESCRIPTOR STACK AND DATA TO DETERMINE -C ARRAY LOCATIONS AND SCALING FOR TOVS 40-LEVEL RETRIEVAL -C QUANTITIES TO BE RETURNED TO W3FI81. -C -C PROGRAM HISTORY LOG: -C 93-06-09 BERT B. KATZ -C -C USAGE: CALL FI8101(MSTACK,KDATA,NDESC) -C INPUT ARGUMENT LIST: -C MSTACK - ARRAY CONTAINING BUFR DESCRIPTORS AND SCALING -C - FOR TOVS 40-LEVEL RETRIEVALS. -C KDATA - BUFR DATA IN INTEGER FORM. -C NDESC - NUMBER OF DESCRIPTORS IN ARRAY MSTACK. -C -C REMARKS: CALLED BY SUBROUTINE W3FI81. RETURNS OUTPUT THOUGH -C COMMON BLOCK /FI81TV/. -C -C ATTRIBUTES: -C LANGUAGE: VS FORTRAN, CFT77 -C MACHINE: HDS OR CRAY -C -C$$$ -C - PARAMETER (MXIRPT=50,MXIDSC=420) - PARAMETER (NMLO=28) - PARAMETER (NML=70) - INTEGER MSTACK(2,MXIDSC) - INTEGER KDATA(MXIRPT,MXIDSC) -C - COMMON /FI81TV/ LCSTII, LCSSBC, LCMBBX, - 1 LCINSI, LCRTMI, LCFLFI, - 2 LCYRI , LCMONI, LCDAYI, - 3 LCHRI , LCMINI, LCSECI, - 4 LCLSI , LCNDI , LCFGAP, - 5 LCDVHI, LCDVMI, LCDVSI, - 6 LCNMCI, LWNMCI, LCRTPI, - 7 LCLATI, IXLATI, LCLONI, IXLONI, - 8 LCSTUI, LCSSTA, LCST15, IXST15, - 9 LCSZAN, IXSZAN, LCLSZA, IXLSZA, - A LCSALB, IXSALB, LCSKNI, IXSKNI, - B LCH8FI, LCPLSI, IXPLSI, LCSFHI, IXSFHI, - C LCICOI, LCOZON, IXOZON, LCAVNS, IXAVNS, - D LCICTI, LCPTRI, IXPTRI, LCTTRI, IXTTRI - COMMON /FI81TV/ LCP40I(40), IXP40I(40), - 1 LCT40I(40), IXT40I(40), - 2 LCH40I(40), IXH40I(40), - 3 LCM40I(40), IXM40I(40), - 4 LCP4GI(40), IXP4GI(40), - 5 LCT4GI(40), IXT4GI(40), - 6 LCM4GI(40), IXM4GI(40), - 7 LCRADI(27), IXRADI(27), - 8 LCRDGI(27), IXRDGI(27) -C -C FIND LOCATIONS AND SCALING -C - I=0 - 15 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.263) THEN - LCSTII = I - ELSE IF(MSTACK(1,I).EQ.6932) THEN - LCSSBC = I - ELSE IF(MSTACK(1,I).EQ.6933) THEN - LCMBBX = I - ELSE IF(MSTACK(1,I).EQ.1025) THEN - LCYRI = I - ELSE IF(MSTACK(1,I).EQ.1026) THEN - LCMONI = I - ELSE IF(MSTACK(1,I).EQ.1027) THEN - LCDAYI = I - ELSE IF(MSTACK(1,I).EQ.1028) THEN - LCHRI = I - ELSE IF(MSTACK(1,I).EQ.1029) THEN - LCMINI = I - ELSE IF(MSTACK(1,I).EQ.1030) THEN - LCSECI = I - ELSE IF(MSTACK(1,I).EQ.1282) THEN - LCLATI = I - IXLATI = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.1538) THEN - LCLONI = I - IXLONI = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.2060) THEN - LCLSI = I - ELSE IF(MSTACK(1,I).EQ.2061) THEN - LCNDI = I - ELSE IF(MSTACK(1,I).EQ.533) THEN - LCINSI = I - ELSE IF(MSTACK(1,I).EQ.534) THEN - LCRTMI = I - ELSE IF(MSTACK(1,I).EQ.6438) THEN - LCFLFI = I - ELSE IF(MSTACK(1,I).EQ.6435) THEN - LCFGAP = I - ELSE IF(MSTACK(1,I).EQ.1814) THEN - LCSZAN = I - IXSZAN = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.1813) THEN - LCLSZA = I - IXLSZA = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.6436) THEN - LCAVNS = I - IXAVNS = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.451) THEN - IF(MSTACK(1,I-1).NE.451) THEN - NBITS = MSTACK(1,I-1) - 34304 - IF(NBITS.GT.0) THEN - LCNMCI = I - LBNMCI = NBITS / 8 - LWNMCI = (LBNMCI - 1) / 4 + 1 - ENDIF - ENDIF - ELSE IF(MSTACK(1,I).EQ.1048) THEN - LCDVHI = I - ELSE IF(MSTACK(1,I).EQ.1049) THEN - LCDVMI = I - ELSE IF(MSTACK(1,I).EQ.1050) THEN - LCDVSI = I - ELSE IF(MSTACK(1,I).EQ.14086) THEN - LCRTPI = I - ENDIF - IF(I.LT.NDESC) GO TO 15 -C - I=0 - 20 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.2051) THEN - IF(KDATA(1,I).EQ.7) THEN - 25 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.537) THEN - LCICOI = I - GO TO 25 - ELSE IF(MSTACK(1,I).EQ.3841) THEN - LCOZON = I - IXOZON = -MSTACK(2,I) - GO TO 25 - ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN - GO TO 25 - ELSE - I = I - 1 - ENDIF - ELSE IF(KDATA(1,I).EQ.8) THEN - 30 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.6430) THEN - LCSTUI = I - GO TO 30 - ELSE IF(MSTACK(1,I).EQ.6431) THEN - LCSSTA = I - GO TO 30 - ELSE IF(MSTACK(1,I).EQ.5673) THEN - LCST15 = I - IXST15 = -MSTACK(2,I) - GO TO 30 - ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN - GO TO 30 - ELSE - I = I - 1 - ENDIF - ELSE IF(KDATA(1,I).EQ.3) THEN - 35 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.537) THEN - LCICTI = I - GO TO 35 - ELSE IF(MSTACK(1,I).EQ.1796) THEN - LCPTRI = I - IXPTRI = -MSTACK(2,I) - GO TO 35 - ELSE IF(MSTACK(1,I).EQ.3073) THEN - LCTTRI = I - IXTTRI = -MSTACK(2,I) - GO TO 35 - ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN - GO TO 35 - ELSE - I = I - 1 - ENDIF - ELSE IF(KDATA(1,I).EQ.0) THEN - 40 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.1793) THEN - LCSFHI = I - IXSFHI = -MSTACK(2,I) - GO TO 40 - ELSE IF(MSTACK(1,I).EQ.2564) THEN - LCPLSI = I - IXPLSI = -MSTACK(2,I) - GO TO 40 - ELSE IF(MSTACK(1,I).EQ.3133) THEN - LCSKNI = I - IXSKNI = -MSTACK(2,I) - GO TO 40 - ELSE IF(MSTACK(1,I).EQ.6437) THEN - LCH8FI = I - GO TO 40 - ELSE IF(MSTACK(1,I).EQ.3603) THEN - LCSALB = I - IXSALB = -MSTACK(2,I) - GO TO 40 - ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN - GO TO 40 - ELSE - I = I - 1 - ENDIF - ENDIF - ELSE IF(MSTACK(1,I).EQ.2280) THEN - IF(KDATA(1,I).EQ.4096) THEN - I = I + 1 - KPROF = MSTACK(1,I) - 16384 - KREPL = MOD(KPROF,256) - KFLDS = KPROF / 256 - DO 45 K = 1 , KREPL - DO 45 J = 1 , KFLDS - I = I + 1 - IF(MSTACK(1,I).EQ.1796) THEN - LCP40I(K) = I - IXP40I(K) = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.3073) THEN - LCT40I(K) = I - IXT40I(K) = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.2563) THEN - LCH40I(K) = I - IXH40I(K) = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.3330) THEN - LCM40I(K) = I - IXM40I(K) = -MSTACK(2,I) - ENDIF - 45 CONTINUE - ELSE IF(KDATA(1,I).EQ.100 .OR. KDATA(1,I).EQ.98 .OR. - 1 KDATA(1,I).EQ.97) THEN - IF(KDATA(1,I).EQ.100) THEN - ISCHAN = 0 - ELSE IF(KDATA(1,I).EQ.98) THEN - ISCHAN = 20 - ELSE IF(KDATA(1,I).EQ.97) THEN - ISCHAN = 24 - ENDIF - 50 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.1322) THEN - ICHAN = ISCHAN + KDATA(1,I) - ICHINC = 0 - GO TO 50 - ELSE IF(MSTACK(1,I).EQ.1332) THEN - ICHINC = KDATA(1,I) - GO TO 50 - ELSE IF(MSTACK(1,I).GT.16384 .AND. - 1 MSTACK(1,I).LT.33024) THEN - KPROF = MSTACK(1,I) - 16384 - KREPL = MOD(KPROF,256) - KFLDS = KPROF / 256 - GO TO 50 - ELSE IF(MSTACK(1,I).EQ.3135) THEN - ICHAN = ICHAN + ICHINC - LCRADI(ICHAN) = I - IXRADI(ICHAN) = -MSTACK(2,I) - IF(ICHAN-ISCHAN.GE.KREPL*ICHINC) THEN - ISCHAN = 0 - ENDIF - GO TO 50 - ELSE IF(MSTACK(1,I).GE.33024) THEN - GO TO 50 - ELSE - I = I - 1 - ENDIF - ELSE IF(KDATA(1,I).EQ.4224) THEN - I = I + 1 - KPROF = MSTACK(1,I) - 16384 - KREPL = MOD(KPROF,256) - KFLDS = KPROF / 256 - DO 55 K = 1 , KREPL - DO 55 J = 1 , KFLDS - I = I + 1 - IF(MSTACK(1,I).EQ.1796) THEN - LCP4GI(K) = I - IXP4GI(K) = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.3073) THEN - LCT4GI(K) = I - IXT4GI(K) = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.3330) THEN - LCM4GI(K) = I - IXM4GI(K) = -MSTACK(2,I) - ENDIF - 55 CONTINUE - ELSE IF(KDATA(1,I).EQ.228 .OR. KDATA(1,I).EQ.226 .OR. - 1 KDATA(1,I).EQ.225) THEN - IF(KDATA(1,I).EQ.228) THEN - ISCHAN = 0 - ELSE IF(KDATA(1,I).EQ.226) THEN - ISCHAN = 20 - ELSE IF(KDATA(1,I).EQ.225) THEN - ISCHAN = 24 - ENDIF - 60 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.1322) THEN - ICHAN = ISCHAN + KDATA(1,I) - ICHINC = 0 - GO TO 60 - ELSE IF(MSTACK(1,I).EQ.1332) THEN - ICHINC = KDATA(1,I) - GO TO 60 - ELSE IF(MSTACK(1,I).GT.16384 .AND. - 1 MSTACK(1,I).LT.33024) THEN - KPROF = MSTACK(1,I) - 16384 - KREPL = MOD(KPROF,256) - KFLDS = KPROF / 256 - GO TO 60 - ELSE IF(MSTACK(1,I).EQ.3135) THEN - ICHAN = ICHAN + ICHINC - LCRDGI(ICHAN) = I - IXRDGI(ICHAN) = -MSTACK(2,I) - IF(ICHAN-ISCHAN.GE.KREPL*ICHINC) THEN - ISCHAN = 0 - ENDIF - GO TO 60 - ELSE IF(MSTACK(1,I).GE.33024) THEN - GO TO 60 - ELSE - I = I - 1 - ENDIF - ENDIF - ENDIF - IF(I.LT.NDESC) GO TO 20 -C - RETURN - END - SUBROUTINE FI8102(MSTACK,KDATA,NDESC) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8102 GETS INFO TO UNPACK BUFR INTERACTIVE RTRVLS -C PRGMMR: BERT B. KATZ ORG: W/NMC23 DATE: 93-06-09 -C GENERAL -C SCIENCES CORP. -C -C ABSTRACT: USES BUFR DESCRIPTOR STACK AND DATA TO DETERMINE -C ARRAY LOCATIONS AND SCALING FOR INTERACTIVE RETRIEVAL -C QUANTITIES TO BE RETURNED TO W3FI81. -C -C PROGRAM HISTORY LOG: -C 93-06-09 BERT B. KATZ -C -C USAGE: CALL FI8102(MSTACK,KDATA,NDESC) -C INPUT ARGUMENT LIST: -C MSTACK - ARRAY CONTAINING BUFR DESCRIPTORS AND SCALING -C - FOR INTERACTIVE RETRIEVALS. -C KDATA - BUFR DATA IN INTEGER FORM. -C NDESC - NUMBER OF DESCRIPTORS IN ARRAY MSTACK. -C -C REMARKS: CALLED BY SUBROUTINE W3FI81. RETURNS OUTPUT THOUGH -C COMMON BLOCK /FI81IA/. -C -C ATTRIBUTES: -C LANGUAGE: VS FORTRAN, CFT77 -C MACHINE: HDS OR CRAY -C -C$$$ -C - PARAMETER (MXRPTR=30,MXDSCR=700) - PARAMETER (NMLO=28) - PARAMETER (NML=70) - INTEGER MSTACK(2,MXDSCR) - INTEGER KDATA(MXRPTR,MXDSCR) -C - COMMON /FI81IA/ LCSTIR , LCLSR , LCNDR , - 1 LCNMCR , LWNMCR , LCFCYC , - 2 LCINSR , LCRTMR , LCRTPR , - 3 LCDVHR , LCDVMR , LCDVSR , - 4 LCSTUR , LCICOR , LCFLFR , - 5 LCLATR , IXLATR , - 6 LCLONR , IXLONR , - 7 LCPTRR , IXPTRR , - 8 LCTTRR , IXTTRR , LCICTR , - 9 LCSKNT , IXSKNT , - A LCPLSR , IXPLSR , - B LCSFHF , IXSFHF , - C LCPSFF , IXPSFF , - D LCSKNF , IXSKNF , - E LCSKNR , IXSKNR , LCH8FR - COMMON /FI81IA/ LCRADF(27) , IXRADF(27) , - 1 LCRDFC(27) , IXRDFC(27) , - 2 LCSIGI(NMLO), IXSIGI(NMLO), - 3 LCTMPI(NMLO), IXTMPI(NMLO), - 4 LCRADR(27) , IXRADR(27) , - 5 LCRDRC(27) , IXRDRC(27) , - 6 LCSIGF(NMLO), IXSIGF(NMLO), - 7 LCTMPF(NMLO), IXTMPF(NMLO), - 8 LCMIXF(NMLO), IXMIXF(NMLO), - 9 LCSIGR(NML) , IXSIGR(NML) , - A LCTMPR(NML) , IXTMPR(NML) , - B LCMIXR(NML) , IXMIXR(NML) , - C LCP41I , IXP41I , - D LCT41I , IXT41I , - E LCM41I , IXM41I -C -C FIND LOCATIONS AND SCALING -C - I=0 - 20 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.263) THEN - LCSTIR = I - ELSE IF(MSTACK(1,I).EQ.1282) THEN - LCLATR = I - IXLATR = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.1538) THEN - LCLONR = I - IXLONR = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.2060) THEN - LCLSR = I - ELSE IF(MSTACK(1,I).EQ.2061) THEN - LCNDR = I - ELSE IF(MSTACK(1,I).EQ.533) THEN - LCINSR = I - ELSE IF(MSTACK(1,I).EQ.534) THEN - LCRTMR = I - ELSE IF(MSTACK(1,I).EQ.6438) THEN - LCFLFR = I - ELSE IF(MSTACK(1,I).EQ.451) THEN - IF(MSTACK(1,I-1).NE.451) THEN - NBITS = MSTACK(1,I-1) - 34304 - IF(NBITS.GT.0) THEN - LCNMCR = I - LBNMCR = NBITS / 8 - LWNMCR = (LBNMCR - 1) / 4 + 1 - ENDIF - ENDIF - ELSE IF(MSTACK(1,I).EQ.1048) THEN - LCDVHR = I - ELSE IF(MSTACK(1,I).EQ.1049) THEN - LCDVMR = I - ELSE IF(MSTACK(1,I).EQ.1050) THEN - LCDVSR = I - ELSE IF(MSTACK(1,I).EQ.14086) THEN - LCRTPR = I - ENDIF - IF(MSTACK(1,I).EQ.2051) THEN - IF(KDATA(1,I).EQ.7) THEN - 25 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.537) THEN - LCICOR = I - GO TO 25 - ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN - GO TO 25 - ELSE - I = I - 1 - ENDIF - ELSE IF(KDATA(1,I).EQ.8) THEN - 30 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.6430) THEN - LCSTUR = I - GO TO 30 - ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN - GO TO 30 - ELSE - I = I - 1 - ENDIF - ELSE IF(KDATA(1,I).EQ.3) THEN - 35 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.537) THEN - LCICTR = I - GO TO 35 - ELSE IF(MSTACK(1,I).EQ.1796) THEN - LCPTRR = I - IXPTRR = -MSTACK(2,I) - GO TO 35 - ELSE IF(MSTACK(1,I).EQ.3073) THEN - LCTTRR = I - IXTTRR = -MSTACK(2,I) - GO TO 35 - ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN - GO TO 35 - ELSE - I = I - 1 - ENDIF - ELSE IF(KDATA(1,I).EQ.0) THEN - 40 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.2564) THEN - LCPLSR = I - IXPLSR = -MSTACK(2,I) - GO TO 40 - ELSE IF(MSTACK(1,I).EQ.3133) THEN - LCSKNT = I - IXSKNT = -MSTACK(2,I) - GO TO 40 - ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN - GO TO 40 - ELSE - I = I - 1 - ENDIF - ENDIF - ELSE IF(MSTACK(1,I).EQ.2280) THEN - IF(KDATA(1,I).EQ.16) THEN - 45 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.1793) THEN - LCSFHF = I - IXSFHF = -MSTACK(2,I) - GO TO 45 - ELSE IF(MSTACK(1,I).EQ.2564) THEN - LCPSFF = I - IXPSFF = -MSTACK(2,I) - GO TO 45 - ELSE IF(MSTACK(1,I).EQ.3133) THEN - LCSKNF = I - IXSKNF = -MSTACK(2,I) - GO TO 45 - ELSE IF(MSTACK(1,I).EQ.1219) THEN - LCFCYC = I - GO TO 45 - ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN - GO TO 45 - ELSE - I = I - 1 - ENDIF - ELSE IF(KDATA(1,I).EQ.2048) THEN - 50 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.3133) THEN - LCSKNR = I - IXSKNR = -MSTACK(2,I) - GO TO 50 - ELSE IF(MSTACK(1,I).EQ.6437) THEN - LCH8FR = I - GO TO 50 - ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN - GO TO 50 - ELSE - I = I - 1 - ENDIF - ELSE IF(KDATA(1,I).EQ.1076 .OR. KDATA(1,I).EQ.1074 .OR. - 1 KDATA(1,I).EQ.1073) THEN - IF(KDATA(1,I).EQ.1076) THEN - ISCHAN = 0 - ELSE IF(KDATA(1,I).EQ.1074) THEN - ISCHAN = 20 - ELSE IF(KDATA(1,I).EQ.1073) THEN - ISCHAN = 24 - ENDIF - 55 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.1322) THEN - ICHAN = ISCHAN + KDATA(1,I) - ICHINC = 0 - GO TO 55 - ELSE IF(MSTACK(1,I).EQ.1332) THEN - ICHINC = KDATA(1,I) - GO TO 55 - ELSE IF(MSTACK(1,I).GT.16384 .AND. - 1 MSTACK(1,I).LT.33024) THEN - KPROF = MSTACK(1,I) - 16384 - KREPL = MOD(KPROF,256) - KFLDS = KPROF / 256 - GO TO 55 - ELSE IF(MSTACK(1,I).EQ.3135) THEN - ICHAN = ICHAN + ICHINC - LCRADF(ICHAN) = I - IXRADF(ICHAN) = -MSTACK(2,I) - IF(ICHAN-ISCHAN.GE.KREPL*ICHINC) THEN - ISCHAN = 0 - ENDIF - GO TO 55 - ELSE IF(MSTACK(1,I).GE.33024) THEN - GO TO 55 - ELSE - I = I - 1 - ENDIF - ELSE IF(KDATA(1,I).EQ.1588 .OR. KDATA(1,I).EQ.1586 .OR. - 1 KDATA(1,I).EQ.1585) THEN - IF(KDATA(1,I).EQ.1588) THEN - ISCHAN = 0 - ELSE IF(KDATA(1,I).EQ.1586) THEN - ISCHAN = 20 - ELSE IF(KDATA(1,I).EQ.1585) THEN - ISCHAN = 24 - ENDIF - 60 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.1322) THEN - ICHAN = ISCHAN + KDATA(1,I) - ICHINC = 0 - GO TO 60 - ELSE IF(MSTACK(1,I).EQ.1332) THEN - ICHINC = KDATA(1,I) - GO TO 60 - ELSE IF(MSTACK(1,I).GT.16384 .AND. - 1 MSTACK(1,I).LT.33024) THEN - KPROF = MSTACK(1,I) - 16384 - KREPL = MOD(KPROF,256) - KFLDS = KPROF / 256 - GO TO 60 - ELSE IF(MSTACK(1,I).EQ.3135) THEN - ICHAN = ICHAN + ICHINC - LCRDFC(ICHAN) = I - IXRDFC(ICHAN) = -MSTACK(2,I) - IF(ICHAN-ISCHAN.GE.KREPL*ICHINC) THEN - ISCHAN = 0 - ENDIF - GO TO 60 - ELSE IF(MSTACK(1,I).GE.33024) THEN - GO TO 60 - ELSE - I = I - 1 - ENDIF - ELSE IF(KDATA(1,I).EQ.12288) THEN - I = I + 1 - KPROF = MSTACK(1,I) - 16384 - KREPL = MOD(KPROF,256) - KFLDS = KPROF / 256 - DO 65 K = 1 , KREPL - DO 65 J = 1 , KFLDS - I = I + 1 - IF(MSTACK(1,I).EQ.1330) THEN - LCSIGI(K) = I - IXSIGI(K) = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.3073) THEN - LCTMPI(K) = I - IXTMPI(K) = -MSTACK(2,I) - ENDIF - 65 CONTINUE - ELSE IF(KDATA(1,I).EQ.3108 .OR. KDATA(1,I).EQ.3106 .OR. - 1 KDATA(1,I).EQ.3105) THEN - IF(KDATA(1,I).EQ.3108) THEN - ISCHAN = 0 - ELSE IF(KDATA(1,I).EQ.3106) THEN - ISCHAN = 20 - ELSE IF(KDATA(1,I).EQ.3105) THEN - ISCHAN = 24 - ENDIF - 70 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.1322) THEN - ICHAN = ISCHAN + KDATA(1,I) - ICHINC = 0 - GO TO 70 - ELSE IF(MSTACK(1,I).EQ.1332) THEN - ICHINC = KDATA(1,I) - GO TO 70 - ELSE IF(MSTACK(1,I).GT.16384 .AND. - 1 MSTACK(1,I).LT.33024) THEN - KPROF = MSTACK(1,I) - 16384 - KREPL = MOD(KPROF,256) - KFLDS = KPROF / 256 - GO TO 70 - ELSE IF(MSTACK(1,I).EQ.3135) THEN - ICHAN = ICHAN + ICHINC - LCRADR(ICHAN) = I - IXRADR(ICHAN) = -MSTACK(2,I) - IF(ICHAN-ISCHAN.GE.KREPL*ICHINC) THEN - ISCHAN = 0 - ENDIF - GO TO 70 - ELSE IF(MSTACK(1,I).GE.33024) THEN - GO TO 70 - ELSE - I = I - 1 - ENDIF - ELSE IF(KDATA(1,I).EQ.3620 .OR. KDATA(1,I).EQ.3618 .OR. - 1 KDATA(1,I).EQ.3617) THEN - IF(KDATA(1,I).EQ.3620) THEN - ISCHAN = 0 - ELSE IF(KDATA(1,I).EQ.3618) THEN - ISCHAN = 20 - ELSE IF(KDATA(1,I).EQ.3617) THEN - ISCHAN = 24 - ENDIF - 80 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.1322) THEN - ICHAN = ISCHAN + KDATA(1,I) - ICHINC = 0 - GO TO 80 - ELSE IF(MSTACK(1,I).EQ.1332) THEN - ICHINC = KDATA(1,I) - GO TO 80 - ELSE IF(MSTACK(1,I).GT.16384 .AND. - 1 MSTACK(1,I).LT.33024) THEN - KPROF = MSTACK(1,I) - 16384 - KREPL = MOD(KPROF,256) - KFLDS = KPROF / 256 - GO TO 80 - ELSE IF(MSTACK(1,I).EQ.3135) THEN - ICHAN = ICHAN + ICHINC - LCRDRC(ICHAN) = I - IXRDRC(ICHAN) = -MSTACK(2,I) - IF(ICHAN-ISCHAN.GE.KREPL*ICHINC) THEN - ISCHAN = 0 - ENDIF - GO TO 80 - ELSE IF(MSTACK(1,I).GE.33024) THEN - GO TO 80 - ELSE - I = I - 1 - ENDIF - ELSE IF(KDATA(1,I).EQ.8208) THEN - I = I + 1 - KPROF = MSTACK(1,I) - 16384 - KREPL = MOD(KPROF,256) - KFLDS = KPROF / 256 - DO 85 K = 1 , KREPL - DO 85 J = 1 , KFLDS - I = I + 1 - IF(MSTACK(1,I).EQ.1330) THEN - LCSIGF(K) = I - IXSIGF(K) = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.3073) THEN - LCTMPF(K) = I - IXTMPF(K) = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.3330) THEN - LCMIXF(K) = I - IXMIXF(K) = -MSTACK(2,I) - ENDIF - 85 CONTINUE - ELSE IF(KDATA(1,I).EQ.10240) THEN - I = I + 1 - KPROF = MSTACK(1,I) - 16384 - KREPL = MOD(KPROF,256) - KFLDS = KPROF / 256 - DO 90 K = 1 , KREPL - DO 90 J = 1 , KFLDS - I = I + 1 - IF(MSTACK(1,I).EQ.1330) THEN - LCSIGR(K) = I - IXSIGR(K) = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.3073) THEN - LCTMPR(K) = I - IXTMPR(K) = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.3330) THEN - LCMIXR(K) = I - IXMIXR(K) = -MSTACK(2,I) - ENDIF - 90 CONTINUE - ELSE IF(KDATA(1,I).EQ.4096) THEN - I = I + 1 - KPROF = MSTACK(1,I) - 16384 - KREPL = MOD(KPROF,256) - KFLDS = KPROF / 256 - I = I + (KREPL - 1) * KFLDS - DO 95 J = 1 , KFLDS - I = I + 1 - IF(MSTACK(1,I).EQ.1796) THEN - LCP41I = I - IXP41I = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.3073) THEN - LCT41I = I - IXT41I = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.3330) THEN - LCM41I = I - IXM41I = -MSTACK(2,I) - ENDIF - 95 CONTINUE - ENDIF - ENDIF - IF(I.LT.NDESC) GO TO 20 -C - RETURN - END - SUBROUTINE FI8103(MSTACK,KDATA,NDESC) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8103 GETS INFO TO UNPACK BUFR ANALYSIS INTERP -C PRGMMR: BERT B. KATZ ORG: W/NMC23 DATE: 93-06-09 -C GENERAL -C SCIENCES CORP. -C -C ABSTRACT: USES BUFR DESCRIPTOR STACK AND DATA TO DETERMINE -C ARRAY LOCATIONS AND SCALING FOR ANALYSIS INTERPOLATION -C QUANTITIES TO BE RETURNED TO W3FI81. -C -C PROGRAM HISTORY LOG: -C 93-06-09 BERT B. KATZ -C -C USAGE: CALL FI8103(MSTACK,KDATA,NDESC) -C INPUT ARGUMENT LIST: -C MSTACK - ARRAY CONTAINING BUFR DESCRIPTORS AND SCALING -C - FOR ANALYSIS INTERPOLATION DATA. -C KDATA - BUFR DATA IN INTEGER FORM. -C NDESC - NUMBER OF DESCRIPTORS IN ARRAY MSTACK. -C -C REMARKS: CALLED BY SUBROUTINE W3FI81. RETURNS OUTPUT THOUGH -C COMMON BLOCK /FI81IA/. -C -C ATTRIBUTES: -C LANGUAGE: VS FORTRAN, CFT77 -C MACHINE: HDS OR CRAY -C -C$$$ -C - PARAMETER (MXRPTR=100,MXDSCR=200) - PARAMETER (NMLO=28) - PARAMETER (NML=70) - INTEGER MSTACK(2,MXDSCR) - INTEGER KDATA(MXRPTR,MXDSCR) -C - COMMON /FI81AN/ LCSTIA , LCYRA , LCMONA , - 1 LCDAYA , LCHRA , LCMINA , - 2 LCLATA , IXLATA , - 3 LCLONA , IXLONA , - 4 LCPSFA , IXPSFA , - 5 LCSFHA , IXSFHA , - 6 LCNMCA , LWNMCA , - 7 LCSIGA(NMLO), IXSIGA(NMLO), - 8 LCTMPA(NMLO), IXTMPA(NMLO), - 9 LCMIXA(NMLO), IXMIXA(NMLO), - A LCRADA(27) , IXRADA(27) , - B LCRDAC(27) , IXRDAC(27) -C -C FIND LOCATIONS AND SCALING -C - I=0 - 20 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.263) THEN - LCSTIA = I - ELSE IF(MSTACK(1,I).EQ.1282) THEN - LCLATA = I - IXLATA = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.1538) THEN - LCLONA = I - IXLONA = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.451) THEN - IF(MSTACK(1,I-1).NE.451) THEN - NBITS = MSTACK(1,I-1) - 34304 - IF(NBITS.GT.0) THEN - LCNMCA = I - LBNMCA = NBITS / 8 - LWNMCA = (LBNMCA - 1) / 4 + 1 - ENDIF - ENDIF - ELSE IF(MSTACK(1,I).EQ.2280) THEN - IF(KDATA(1,I).EQ.256) THEN - 30 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.1793) THEN - LCSFHA = I - IXSFHA = -MSTACK(2,I) - GO TO 30 - ELSE IF(MSTACK(1,I).EQ.2564) THEN - LCPSFA = I - IXPSFA = -MSTACK(2,I) - GO TO 30 - ELSE IF(MSTACK(1,I).EQ.1025) THEN - LCYRA = I - GO TO 30 - ELSE IF(MSTACK(1,I).EQ.1026) THEN - LCMONA = I - GO TO 30 - ELSE IF(MSTACK(1,I).EQ.1027) THEN - LCDAYA = I - GO TO 30 - ELSE IF(MSTACK(1,I).EQ.1028) THEN - LCHRA = I - GO TO 30 - ELSE IF(MSTACK(1,I).EQ.1029) THEN - LCMINA = I - GO TO 30 - ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN - GO TO 30 - ELSE - I = I - 1 - ENDIF - ELSE IF(KDATA(1,I).EQ.8448) THEN - I = I + 1 - KPROF = MSTACK(1,I) - 16384 - KREPL = MOD(KPROF,256) - KFLDS = KPROF / 256 - DO 40 K = 1 , KREPL - DO 40 J = 1 , KFLDS - I = I + 1 - IF(MSTACK(1,I).EQ.1330) THEN - LCSIGA(K) = I - IXSIGA(K) = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.3073) THEN - LCTMPA(K) = I - IXTMPA(K) = -MSTACK(2,I) - ELSE IF(MSTACK(1,I).EQ.3330) THEN - LCMIXA(K) = I - IXMIXA(K) = -MSTACK(2,I) - ENDIF - 40 CONTINUE - ELSE IF(KDATA(1,I).EQ.1316 .OR. KDATA(1,I).EQ.1314 .OR. - 1 KDATA(1,I).EQ.1313) THEN - IF(KDATA(1,I).EQ.1316) THEN - ISCHAN = 0 - ELSE IF(KDATA(1,I).EQ.1314) THEN - ISCHAN = 20 - ELSE IF(KDATA(1,I).EQ.1313) THEN - ISCHAN = 24 - ENDIF - 50 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.1322) THEN - ICHAN = ISCHAN + KDATA(1,I) - ICHINC = 0 - GO TO 50 - ELSE IF(MSTACK(1,I).EQ.1332) THEN - ICHINC = KDATA(1,I) - GO TO 50 - ELSE IF(MSTACK(1,I).GT.16384 .AND. - 1 MSTACK(1,I).LT.33024) THEN - KPROF = MSTACK(1,I) - 16384 - KREPL = MOD(KPROF,256) - KFLDS = KPROF / 256 - GO TO 50 - ELSE IF(MSTACK(1,I).EQ.3135) THEN - ICHAN = ICHAN + ICHINC - LCRADA(ICHAN) = I - IXRADA(ICHAN) = -MSTACK(2,I) - IF(ICHAN-ISCHAN.GE.KREPL*ICHINC) THEN - ISCHAN = 0 - ENDIF - GO TO 50 - ELSE IF(MSTACK(1,I).GE.33024) THEN - GO TO 50 - ELSE - I = I - 1 - ENDIF - ELSE IF(KDATA(1,I).EQ.1828 .OR. KDATA(1,I).EQ.1826 .OR. - 1 KDATA(1,I).EQ.1825) THEN - IF(KDATA(1,I).EQ.1828) THEN - ISCHAN = 0 - ELSE IF(KDATA(1,I).EQ.1826) THEN - ISCHAN = 20 - ELSE IF(KDATA(1,I).EQ.1825) THEN - ISCHAN = 24 - ENDIF - 60 CONTINUE - I = I + 1 - IF(MSTACK(1,I).EQ.1322) THEN - ICHAN = ISCHAN + KDATA(1,I) - ICHINC = 0 - GO TO 60 - ELSE IF(MSTACK(1,I).EQ.1332) THEN - ICHINC = KDATA(1,I) - GO TO 60 - ELSE IF(MSTACK(1,I).GT.16384 .AND. - 1 MSTACK(1,I).LT.33024) THEN - KPROF = MSTACK(1,I) - 16384 - KREPL = MOD(KPROF,256) - KFLDS = KPROF / 256 - GO TO 60 - ELSE IF(MSTACK(1,I).EQ.3135) THEN - ICHAN = ICHAN + ICHINC - LCRDAC(ICHAN) = I - IXRDAC(ICHAN) = -MSTACK(2,I) - IF(ICHAN-ISCHAN.GE.KREPL*ICHINC) THEN - ISCHAN = 0 - ENDIF - GO TO 60 - ELSE IF(MSTACK(1,I).GE.33024) THEN - GO TO 60 - ELSE - I = I - 1 - ENDIF - ENDIF - ENDIF - IF(I.LT.NDESC) GO TO 20 -C - RETURN - END - SUBROUTINE FI8104(PSFC,PR,TP,WP,PTOV,TTOV,WTOV,NML) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8104 INTERPOLATES FROM MODEL TO TOVS LEVELS -C PRGMMR: BERT B. KATZ ORG: W/NMC23 DATE: 93-08-26 -C GENERAL -C SCIENCES CORP. -C -C ABSTRACT: USING INPUT RETRIEVAL-LEVEL PRESSURES, INTERPOLATES -C TEMPERATURE AND MIXING RATIO FROM MODEL LEVELS TO THE 40 TOVS -C LEVELS. -C -C PROGRAM HISTORY LOG: -C 91-05-13 M. GOLDBERG (NESDIS) -C 92-10-20 T. GARDNER (NESDIS) -C 93-08-26 BERT B. KATZ MODIFIED FOR NMC OPERATIONAL USE. -C -C -C USAGE: CALL FI8104(PSFC,PR,TP,WP,PTOV,TTOV,WTOV,NML) -C INPUT ARGUMENT LIST: -C PSFC - SURFACE PRESSURE (MB). -C PR - PRESSURE (MB) ON MODEL SIGMA LEVELS. -C TP - TEMPERATURE (DEG K) ON MODEL SIGMA LEVELS. -C WP - MIXING RATIO (G/KG) ON MODEL SIGMA LEVELS. -C PTOV - TOVS 40 PRESSURE LEVELS (MB). -C NML - NUMBER OF MODEL SIGMA LEVELS. -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C TTOV - TEMPERATURE (DEG K) ON 40 TOVS LEVELS. -C WTOV - MIXING RATIO (G/KG) ON 40 TOVS LEVELS. -C -C OUTPUT FILES: -C FT06F001 - USED FOR DEBUG PRINTOUT. -C -C ATTRIBUTES: -C LANGUAGE: VS FORTRAN, CFT77 -C MACHINE: HDS OR CRAY. -C -C$$$ -C -C - REAL PR(NML),TP(NML),WP(NML),PTOV(40),TTOV(40),WTOV(40) - REAL PX(29),TX(29),WX(29) -C -C -C REMEMBER THAT NML = NUMBER OF MODEL LEVELS -C - DO 100 I = 1,NML - PX(I) = PR(I) - TX(I) = TP(I) - WX(I) = WP(I) - 100 CONTINUE -C -C INVENT SURFACE QUANTITIES TO BOUND LOWER END FOR PURPOSE OF -C INTERPOLATION -C -C PRINT*,'PSFC=',PSFC -C PRINT*, 'PX=',PX - TX(NML+1)=TX(NML)+0.065*(1001.0-PSFC) - WX(NML+1)=WX(NML)*((1001.0/PX(NML))**(.005*PX(NML)-1.5)) - PX(NML+1)=1001.0 -C -C...MAKE SURE FOR CASES WHERE HIGHEST PRESS LEVEL IS BELOW HIGHEST -C...TOVS LEVEL THAT INTERP. WILL BE PERFORMED. -C - IF (PX(1) .GT. PTOV(1)) PX(1) = PTOV(1) -C -C...INTERPOLATE FORECAST TEMPERATURE AND WATER VAPOR PROFILES TO -C...THE 40 TOVS PRESSURE LEVELS. (FROM 1.0 MB TO 1000 MB) -C...INITIALIZE TTOV AND WTOV VECTORS WITH THE OPERATIONAL RETRIEVALS -C - DO 800 I = 1,40 -C -C...EXTRACT PRESSURE (MB) FOR TOVS LEVEL I. -C - PY = PTOV(I) -C -C...LOOP THROUGH THE MEAN PRESSURES OF EACH LAYER -C...TO DETERMINE IF THE PRESSURE, PY, AT EACH TOVS LEVEL I -C...LIES BETWEEN THEM. -C - DO 300 J=1,NML - DF1= PY - PX(J+1) - DF2= PY - PX(J) - IF(DF1.LE.0..AND.DF2.GE.0.) GO TO 350 - 300 CONTINUE -C -C...INTERPOLATE TEMPERATURE AND MOISTURE INFORMATION TO THE 40 TOVS -C...LEVELS USING THE FOLLOWING INTERPOLATION FORMULA WHICH IS LINEAR -C...WITH RESPECT TO THE NATURAL LOGARITHM OF PRESSURE. -C - 350 FAC = ALOG(PX(J)/PY) / ALOG(PX(J)/PX(J+1)) - TTOV(I) = TX(J) +(TX(J+1)-TX(J))*FAC - WTOV(I) = WX(J) +(WX(J+1)-WX(J))*FAC - 800 CONTINUE -C WRITE(6,*) ' TTOV=',TTOV -C WRITE(6,*) ' WTOV=',WTOV - RETURN - END - SUBROUTINE FI8105(PTOVS,TMP,WVMR,ZHGT,NBUG) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8105 GEO. HGT. FROM TOVS 40-LEVEL TEMP, RATMIX -C PRGMMR: BERT B. KATZ ORG: W/NMC23 DATE: 93-08-26 -C GENERAL -C SCIENCES CORP. -C -C ABSTRACT: CALCULATES GEOPOTENTIAL HEIGHTS HYDROSTATICALLY FROM TOVS -C 40-LEVEL RETRIEVAL. -C -C PROGRAM HISTORY LOG: -C 93-06-02 MIKE FERGUSON (NESDIS) -C 93-08-26 BERT B. KATZ MODIFIED FOR NMC OPERATIONAL USE. -C -C USAGE: CALL FI8105 (PTOVS,TMP,WVMR,ZHGT,NBUG) -C INPUT ARGUMENT LIST: -C PTOVS - TOVS 40 PRESSURE LEVELS (MB). -C TMP - 40-LEVEL TOVS RTRVL TEMPS (DEG K). -C WVMR - 40-LEVEL TOVS RTRVL MOISTURE (G/KG). -C NBUG - DEBUG FLAG. -C -C OUTPUT ARGUMENT LIST: -C ZHGT - GEOPOTENTIAL HEIGHTS (M) AT 40 TOVS LEVELS. -C -C REMARKS: USES COMMON TPRES. CALLS SUBROUTINE IATROP TO CALCULATE -C TROPOPAUSE PRESSURE AND TEMPERATURE VIA SPLINE FITTING TECHNIQUE. -C -C PARAMETERS- -C VARIABLE TYPE FUNCTION -C -------- ---- -------- -C CONS REAL GAS CONSTANT FOR DRY AIR -C (287 J/KG K) DIVIDED BY 2 * G -C (9.8M/S**2). -C ATTRIBUTES: -C LANGUAGE: VS FORTRAN, CFT77 -C MACHINE: HDS OR CRAY -C -C$$$ -C - REAL WVMR(40),TVIRT(40),ZHGT(40),PTOVS(40),TMP(40) - DATA CONS/-14.6435/ -C -C...INITIALIZE GEOP. HIEGHTS ARRAY -C -C PRINT *, 'NBUG IN FI8105 IS ',NBUG - DO 5 I = 1,40 - ZHGT(I) = 0.0 - 5 CONTINUE -C -C...COMPUTE VIRTUAL TEMPERATURES(DEGREES KELVIN). -C - DO 40 L = 1 , 40 - TVIRT(L) = TMP(L) + WVMR(L) / 6.0 - 40 CONTINUE -C7/20 IF(MOD(NBUG,100).EQ.0)THEN -C7/20 PRINT *, 'TEMPS INSIDE FI8105 ,1000,700,500,300 = ', -C7/20+TMP(40),TMP(35),TMP(31),TMP(26) -C7/20 PRINT *, 'V TEMPS INSIDE FI8105 ,1000,700,500,300 = ', -C7/20+TVIRT(40),TVIRT(35),TVIRT(31),TVIRT(26) -C7/20 ENDIF -C -C...COMPUTE GEOPOTENTIAL HEIGHTS (METERS) AT TOVS LEVELS. -C - DO 60 J = 2,40 - I = 40 + 1 - J - DLP = ALOG(PTOVS(I)/PTOVS(I+1)) - ZHGT(I) = ZHGT(I+1) + (TVIRT(I)+TVIRT(I+1)) * DLP * CONS - 60 CONTINUE -C7/20 IF(MOD(NBUG,100).EQ.0)THEN -C7/20 PRINT *, 'GEOPOTENTIALS INSIDE FI8105,1000,700,500,300 = ', -C7/20+ZHGT(40),ZHGT(35),ZHGT(31),ZHGT(26) -C7/20 ENDIF - RETURN - END - SUBROUTINE FI8106(PTOVS,TVGPHT,ZHT,STDPTT,STDPLW,STDPUP,NBUG) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8106 CALCULATES STABILITY DEPARTURES -C PRGMMR: BERT B. KATZ ORG: W/NMC23 DATE: 93-08-26 -C GENERAL -C SCIENCES CORP. -C -C ABSTRACT: USING INPUT GEOPOTENTIAL HEIGHTS FROM TWO SOURCES, -C CALCULATES LAYER-MEAN VIRTUAL TEMPERATURES FOR BOTH SOURCES -C AND THE DIFFERENCE IN STABILITY FOR THE 1000 MB - 700 MB LAYER, -C THE 500 MB - 300 MB LAYER, AND THE DIFFERENCE BETWEEN THESE TWO -C LAYERS. -C -C PROGRAM HISTORY LOG: -C 93-06-01 MIKE FERGUSON (NESDIS) -C 93-08-26 BERT B. KATZ MODIFIED FOR NMC OPERATIONAL USE. -C -C -C USAGE: CALL FI8106(PTOVS,TVGPHT,ZHT,STDPTT,STDPLW,STDPUP,NBUG) -C INPUT ARGUMENT LIST: -C PTOVS - TOVS 40 PRESSURE LEVELS (MB). -C TVGPHT - GEOPOTENTIAL HEIGHTS (M) FROM SOURCE 1. -C ZHT - GEOPOTENTIAL HEIGHTS (M) FROM SOURCE 2. -C NBUG - DEBUG FLAG. -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C STDPTT - STABILITY DEPARTURE BETWEEN SOURCE 1 AND SOURCE 2 : -C DIFFERENCE BETWEEN 1000 MB - 700 MB LAYER AND -C 500 MB - 300 MB LAYER. -C STDPLW - STABILITY DEPARTURE BETWEEN SOURCE 1 AND SOURCE 2 -C IN THE 1000 MB - 700 MB LAYER. -C STDPUP - STABILITY DEPARTURE BETWEEN SOURCE 1 AND SOURCE 2 -C IN THE 500 MB - 300 MB LAYER. -C -C OUTPUT FILES: -C FT06F001 - USED FOR DEBUG PRINTOUT. -C -C ATTRIBUTES: -C LANGUAGE: VS FORTRAN, CFT77 -C MACHINE: HDS OR CRAY -C -C$$$ -C - REAL PTOVS(40) - REAL ZHT(40),TVGPHT(40) -C - DATA CONS/-14.6435/ - DATA CONSTL/6.6890756E-02/ - DATA CONSTU/9.5786797E-02/ -C -C...INITIALIZE STABILITY DEPARTURE VALUES -C - STDPTT = -9999.9 - STDPLW = -9999.9 - STDPUP = -9999.9 -C PRINT *, 'NBUG IN FI8106 = ',NBUG -C -C...COMPUTE STABILITY DEPARTURE FOR 6-HOUR GUESS -C -C -C...COMPUTE STABILITY TERMS -C - RTUPDP = (TVGPHT(26) - TVGPHT(31)) * CONSTL - RTLWDP = (TVGPHT(35) - TVGPHT(40)) * CONSTU - RBUPDP = (ZHT(26) - ZHT(31)) * CONSTL - RBLWDP = (ZHT(35) - ZHT(40)) * CONSTU -C PRINT *, 'OPR RET 1000,700,500,300 GPH ',TVGPHT(40),TVGPHT(35), -C +TVGPHT(31),TVGPHT(26) -C PRINT *, 'GES 1000,700,500,300 GPH ',ZHT(40),ZHT(35), -C +ZHT(31),ZHT(26) -C -C RTSDP=RETRIEVAL TOTAL STABILITY DEPARTURE,RTLWDP=LOWER STABILITY -C RTUPDP=UPPER STABILITY -C -C -C...COMPUTE STABILITY DEPARTURES -C - STDPLW = RTLWDP - RBLWDP - STDPUP = RTUPDP - RBUPDP - STDPTT = STDPLW - STDPUP -C - 8000 RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fi82.f b/src/fim/FIMsrc/w3/w3fi82.f deleted file mode 100644 index 56a5ccc..0000000 --- a/src/fim/FIMsrc/w3/w3fi82.f +++ /dev/null @@ -1,97 +0,0 @@ - SUBROUTINE W3FI82 (IFLD,FVAL1,FDIFF1,NPTS,PDS,IGDS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI82 CONVERT TO SECOND DIFF ARRAY -C PRGMMR: CAVANAUGH ORG: NMC421 DATE:93-08-18 -C -C ABSTRACT: ACCEPT AN INPUT ARRAY, CONVERT TO ARRAY OF SECOND -C DIFFERENCES. RETURN THE ORIGINAL FIRST VALUE AND THE FIRST -C FIRST-DIFFERENCE AS SEPARATE VALUES. ALIGN DATA IN -C BOUSTREPHEDONIC STYLE, (ALTERNATE ROW REVERSAL). -C -C PROGRAM HISTORY LOG: -C 93-07-14 CAVANAUGH -C 94-01-27 CAVANAUGH ADDED REVERSAL OF EVEN NUMBERED ROWS -C (BOUSTROPHEDONIC PROCESSING) -C 94-03-02 CAVANAUGH CORRECTED IMPROPER ORDERING OF EVEN -C NUMBERED ROWS -C 99-12-06 EBISUZAKI LINUX PORT -C -C USAGE: CALL W3FI82 (IFLD,FVAL1,FDIFF1,NPTS,PDS,IGDS) -C INPUT ARGUMENT LIST: -C IFLD - INTEGER INPUT ARRAY -C NPTS - NUMBER OF POINTS IN ARRAY -C IGDS(5) - NUMBER OF ROWS IN ARRAY -C IGDS(4) - NUMBER OF COLUMNS IN ARRAY -C PDS(8) - FLAG INDICATING PRESENCE OF GDS SECTION -C -C OUTPUT ARGUMENT LIST: -C IFLD - SECOND DIFFERENCED FIELD -C FVAL1 - FLOATING POINT ORIGINAL FIRST VALUE -C FDIFF1 - " " FIRST FIRST-DIFFERENCE -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C LANGUAGE: IBM370 VS FORTRAN 77, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256 -C -C$$$ -C - REAL FVAL1,FDIFF1 -C - INTEGER IFLD(*),NPTS,NBOUST(300),IGDS(*) -C - CHARACTER*1 PDS(*) -C -C --------------------------------------------- -C TEST FOR PRESENCE OF GDS -C -c looks like an error CALL GBYTE(PDS,IQQ,56,8) - call gbytec(PDS,IQQ,56,1) - IF (IQQ.NE.0) THEN - NROW = IGDS(5) - NCOL = IGDS(4) -C -C LAY OUT DATA BOUSTROPHEDONIC STYLE -C -C PRINT*, ' DATA SET UP BOUSTROPHEDON' -C - DO 210 I = 2, NROW, 2 -C -C REVERSE THE EVEN NUMBERED ROWS -C - DO 200 J = 1, NCOL - NPOS = I * NCOL - J + 1 - NBOUST(J) = IFLD(NPOS) - 200 CONTINUE - DO 201 J = 1, NCOL - NPOS = NCOL * (I-1) + J - IFLD(NPOS) = NBOUST(J) - 201 CONTINUE - 210 CONTINUE -C -C - END IF -C ================================================================= - DO 4000 I = NPTS, 2, -1 - IFLD(I) = IFLD(I) - IFLD(I-1) - 4000 CONTINUE - DO 5000 I = NPTS, 3, -1 - IFLD(I) = IFLD(I) - IFLD(I-1) - 5000 CONTINUE -C -C SPECIAL FOR GRIB -C FLOAT OUTPUT OF FIRST POINTS TO ANTICIPATE -C GRIB FLOATING POINT OUTPUT -C - FVAL1 = IFLD(1) - FDIFF1 = IFLD(2) -C -C SET FIRST TWO POINTS TO SECOND DIFF VALUE FOR BETTER PACKING -C - IFLD(1) = IFLD(3) - IFLD(2) = IFLD(3) -C ----------------------------------------------------------- - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fi83.f b/src/fim/FIMsrc/w3/w3fi83.f deleted file mode 100644 index 510c61e..0000000 --- a/src/fim/FIMsrc/w3/w3fi83.f +++ /dev/null @@ -1,108 +0,0 @@ - SUBROUTINE W3FI83 (DATA,NPTS,FVAL1,FDIFF1,ISCAL2, - * ISC10,KPDS,KGDS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI83 RESTORE DELTA PACKED DATA TO ORIGINAL -C PRGMMR: CAVANAUGH ORG: NMC421 DATE:93-08-18 -C -C ABSTRACT: RESTORE DELTA PACKED DATA TO ORIGINAL VALUES -C RESTORE FROM BOUSTREPHEDONIC ALIGNMENT -C -C PROGRAM HISTORY LOG: -C 93-07-14 CAVANAUGH -C 93-07-22 STACKPOLE ADDITIONS TO FIX SCALING -C 94-01-27 CAVANAUGH ADDED REVERSAL OF EVEN NUMBERED ROWS -C (BOUSTROPHEDONIC PROCESSING) TO RESTORE -C DATA TO ORIGINAL SEQUENCE. -C 94-03-02 CAVANAUGH CORRECTED REVERSAL OF EVEN NUMBERED ROWS -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C -C USAGE: CALL W3FI83(DATA,NPTS,FVAL1,FDIFF1,ISCAL2, -C * ISC10,KPDS,KGDS) -C INPUT ARGUMENT LIST: -C DATA - SECOND ORDER DIFFERENCES -C NPTS - NUMBER OF POINTS IN ARRAY -C FVAL1 - ORIGINAL FIRST ENTRY IN ARRAY -C FDIFF1 - ORIGINAL FIRST FIRST-DIFFERENCE -C ISCAL2 - POWER-OF-TWO EXPONENT FOR UNSCALING -C ISC10 - POWER-OF-TEN EXPONENT FOR UNSCALING -C KPDS - ARRAY OF INFORMATION FOR PDS -C KGDS - ARRAY OF INFORMATION FOR GDS -C -C OUTPUT ARGUMENT LIST: -C DATA - EXPANDED ORIGINAL DATA VALUES -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256 -C -C$$$ -C - REAL FVAL1,FDIFF1 - REAL DATA(*),BOUST(200) - INTEGER NPTS,NROW,NCOL,KPDS(*),KGDS(*),ISC10 -C --------------------------------------- -C -C REMOVE DECIMAL UN-SCALING INTRODUCED DURING UNPACKING -C - DSCAL = 10.0 ** ISC10 - IF (DSCAL.EQ.0.0) THEN - DO 50 I=1,NPTS - DATA(I) = 1.0 - 50 CONTINUE - ELSE IF (DSCAL.EQ.1.0) THEN - ELSE - DO 51 I=1,NPTS - DATA(I) = DATA(I) * DSCAL - 51 CONTINUE - END IF -C - DATA(1) = FVAL1 - DATA(2) = FDIFF1 - DO 200 J = 3,2,-1 - DO 100 K = J, NPTS - DATA(K) = DATA(K) + DATA(K-1) - 100 CONTINUE - 200 CONTINUE -C -C NOW REMOVE THE BINARY SCALING FROM THE RECONSTRUCTED FIELD -C AND THE DECIMAL SCALING TOO -C - IF (DSCAL.EQ.0) THEN - SCALE = 0.0 - ELSE - SCALE =(2.0**ISCAL2)/DSCAL - END IF - DO 300 I=1,NPTS - DATA(I) = DATA(I) * SCALE - 300 CONTINUE -C ========================================================== - IF (IAND(KPDS(4),128).NE.0) THEN - NROW = KGDS(3) - NCOL = KGDS(2) -C -C DATA LAID OUT BOUSTROPHEDONIC STYLE -C -C -C PRINT*, ' REVERSE BOUSTROPHEDON' - DO 210 I = 2, NROW, 2 -C -C REVERSE THE EVEN NUMBERED ROWS -C - DO 201 J = 1, NCOL - NPOS = I * NCOL - J + 1 - BOUST(J) = DATA(NPOS) - 201 CONTINUE - DO 202 J = 1, NCOL - NPOS = NCOL * (I-1) + J - DATA(NPOS) = BOUST(J) - 202 CONTINUE - 210 CONTINUE -C -C - END IF -C ================================================================= - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fi85.f b/src/fim/FIMsrc/w3/w3fi85.f deleted file mode 100644 index 80d3098..0000000 --- a/src/fim/FIMsrc/w3/w3fi85.f +++ /dev/null @@ -1,2680 +0,0 @@ - SUBROUTINE W3FI85(ISTEP,IUNITB,IUNITD,IBFSIZ,ISECT1,ISECT3, - * JIF,JDESC,NEWNR,IDATA,RDATA,ATEXT,KASSOC, - * KIF,KDESC,NRDESC,ISEC2D,ISEC2B, - * KDATA,KARY,KBUFR,IERRTN) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI85 GENERATE BUFR MESSAGE -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-12-03 -C -C ABSTRACT: USING INFORMATION AVAILABLE IN SUPPLIED ARRAYS, GENERATE -C A BUFR MESSAGE (WMO CODE FM94). THERE MAY BE A SECTION 2 -C INCLUDED IN THE BUFR MESSAGE IF THE USER FOLLOWS PROPER PROCEDURE. -C MESSAGES ARE CONSTRUCTED IN ACCORDANCE WITH BUFR EDITION 2. ENTRIES -C FOR SECTION 1 MUST BE PASSED TO THIS ROUTINE IN THE ISECT1 ARRAY. -C ENTRIES FOR SECTION 3 MUST BE PASSED TO THIS ROUTINE IN ISECT3. -C -C -C IN THE EVENT THAT THE USER REQUESTS A REDUCTION OF REPORTS -C IN A BUFR MESSAGE IF A PARTICULAR MESSAGE BECOMES OVERSIZED, THE -C POSSIBILITY EXISTS OF THE LAST BLOCK OF DATA PRODUCING AN OVERSIZED -C MESSAGE. THE USER MUST VERIFY THAT ISECT3(6) DOES IN FACT EQUAL -C ZERO TO ASSURE THAT ALL OF THE DATA HAS BEEN INCLUDED AS OUTPUT. -C -C PROGRAM HISTORY LOG: -C 93-09-29 CAVANAUGH -C 94-03-22 J. HOPPA - CORRECTED AN ERROR WHEN WRITING THE -C DESCRIPTORS INTO THE BUFR MESSAGE -C 94-03-31 J. HOPPA - ADDED THE SUBSET NUMBER TO THE PARAMETER LIST -C OF SUBROUTINE FI8501 -C 94-04-15 J. HOPPA - ADDED KBUFR TO THE PARAMETER LIST OF -C SUBROUTINE FI8502 -C 94-04-20 J. HOPPA - ADDED THE KDATA PARAMETER COUNTER TO THE -C PARAMETER LIST OF SUBROUTINE FI8501 -C 95-04-29 J. HOPPA - CHANGED NQ AND N TO KARY(2) -C - CHANGED JK TO KARY(11) -C - ADDED AN ASSIGNMENT TO KARY(2) SO HAVE -C SOMETHING TO PASS TO SUBROUTINES -C - DELETED JK AND LL FROM CALL TO FI8501 -C -C USAGE: CALL W3FI85(ISTEP,IUNITB,IUNITD,IBFSIZ,ISECT1,ISECT3, -C * JIF,JDESC,NEWNR,IDATA,RDATA,ATEXT,KASSOC, -C * KIF,KDESC,NRDESC,ISEC2D,ISEC2B, -C * KDATA,KARY,KBUFR,IERRTN) -C INPUT ARGUMENT LIST: -C ISTEP - KEY FOR SELECTION OF PROCESSING STEP -C 1 = PROCESS INTEGER/TEXT ARRAY INTO KDATA -C 2 = PROCESS REAL/TEXT ARRAY INTO KDATA -C 3 = CONSTRUCT BUFR MESSAGE -C IUNITB - UNIT NUMBER OF DEVICE CONTAINING TABLE B -C IUNITD - UNIT NUMBER OF DEVICE CONTAINING TABLE D -C IBFSIZ - SIZE IN BYTES OF BUFR MESSAGE ARRAY (KBUFR) -C SHOULD BE A MULTIPLE OF WORD SIZE. -C ISECT1 - CONTAINS INFORMATION TO ENTER INTO SECTION 1 -C ( 1) EDITION NUMBER -C ( 2) BUFR MASTER TABLE NUMBER -C 0 = METEOROLOGICAL -C OTHERS NOT YET DEFINED -C ( 3) ORIGINATING CENTER - SUBCENTER NUMBER -C ( 4) ORIGINATING CENTER NUMBER -C ( 5) UPDATE SEQUENCE NUMBER -C ( 6) OPTIONAL SECTION FLAG -C SHOULD BE SET TO ZERO UNLESS USER -C WRITE ADDITIONAL CODE TO ENTER LOCAL -C INFORMATION INTO SECTION 3 -C ( 7) BUFR MESSAGE TYPE -C ( 8) BUFR MESSAGE SUB_TYPE -C ( 9) MASTER TABLE VERSION NUMBER -C (10) LOCAL TABLE VERSION NUMBER -C (11) YEAR OF CENTURY - REPRESENTATIVE OF DATA -C (12) MONTH - REPRESENTATIVE OF DATA -C (13) DAY - REPRESENTATIVE OF DATA -C (14) HOUR - REPRESENTATIVE OF DATA -C (15) MINUTE - REPRESENTATIVE OF DATA -C (16)-(20) UNUSED -C -C ISECT3 - VALUES TO BE INSERTED INTO SECTION 3, AND -C TO CONTROL REPORT REDUCTION FOR OVERSIZED MESSAGES -C (1) NUMBER OF SUBSETS -C DEFINES THE NUMBER OF SUBSETS BEING PASSED TO THE -C ENCODER ROUTINE FOR INCLUSION INTO A BUFR MESSAGE. -C IF THE USER HAS SPECIFIED THE USE OF THE -C SUBSET/REPORT REDUCTION ACTIVATION SWITCH, THEN -C A PART OF THOSE SUBSETS MAY BE USED FOR THE CURRENT -C MESSAGE AND THE REMAINDER RETAINED FOR A -C SUBSEQUENT MESSAGE. -C (2) OBSERVED FLAG -C 0 = OBSERVED DATA -C 1 = OTHER DATA -C (3) COMPRESSED FLAG -C 0 = NONCOMPRESSED -C 1 = COMPRESSED -C (4) SUBSET/REPORT REDUCTION ACTIVATION SWITCH -C USED TO CONTROL THE NUMBER OF REPORTS ENTERED INTO -C A BUFR MESSAGE WHEN MAXIMUM MESSAGE SIZE IS EXCEEDED -C 0 = OPTION NOT ACTIVE -C 1 = OPTION IS ACTIVE. UNUSED SUBSETS WILL BE -C SHIFTED TO LOW ORDER POSITIONS OF ENTRY ARRAY. -C 2 = OPTION IS ACTIVE. UNUSED SUBSETS WILL REMAIN -C IN ENTRY POSITIONS. -C -C NOTE:- IF THIS FLAG IS SET TO ANY OTHER -C VALUES, PROGRAM WILL BE TERMINATED WITH AN -C ERROR CONDITION. -C (5) NUMBER OF REPORTS TO DECREMENT BY, IF OVERSIZED MESSAGE -C (MINIMUM VALUE = ONE). IF ZERO IS ENTERED, IT WILL -C BE REPLACED BY ONE. -C (6) NUMBER OF UNUSED REPORTS RETURNED TO USER -C (7) NUMBER OF REPORTS INCLUDED IN MESSAGE -C (8) NUMBER OF TABLE B ENTRIES AVAILABLE TO DECODER -C (9) NUMBER OF TABLE D ENTRIES AVAILABLE TO DECODER -C (10) TEXT INPUT FLAG -C 0 = ASCII INPUT -C 1 = EBCIDIC INPUT -C -C JIF - JDESC INPUT FORMAT FLAG -C 0 = F X Y -C 1 = DECIMAL FORMAT -C JDESC - LIST OF DESCRIPTORS TO GO INTO SECTION 3 -C EACH DESCRIPTOR = F * 16384 + X * 256 + Y -C THEY MAY OR MAY NOT BE AN EXACT MATCH OF THE -C WORKING DESCRIPTOR LIST IN KDESC. THIS SET OF -C DESCRIPTORS MAY CONTAIN SEQUENCE DESCRIPTORS TO -C PROVIDE ADDITIONAL COMPRESSION WITHIN THE BUFR -C MESSAGE. THERE MAY BE AS FEW AS ONE SEQUENCE -C DESCRIPTOR, OR AS MANY DESCRIPTORS AS THERE ARE -C IN KDESC. -C NEWNR - NR OF DESCRIPTORS IN JDESC -C IDATA - INTEGER ARRAY DIMENSIONED BY THE NUMBER OF -C DESCRIPTORS TO BE USED -C RDATA - REAL ARRAY DIMENSIONED BY THE NUMBER OF -C DESCRIPTORS TO BE USED -C ATEXT - ARRAY CONTAINING ALL TEXT DATA ASSOCIATED WITH A -C SPECIFIC REPORT. ALL DATA IDENTIFIED AS TEXT DATA MUST -C BE IN ASCII. -C KASSOC - INTEGER ARRAY DIMENSIONED BY THE NUMBER OF DESCRIPTORS -C TO BE USED, CONTAINING THE ASSOCIATED FIELD VALUES -C FOR ANY ENTRY IN THE DESCRIPTOR LIST. -C KIF - KDESC INPUT FORMAT FLAG -C 0 = F X Y -C 1 = DECIMAL FORMAT -C KDESC - LIST OF DESCRIPTORS TO GO INTO SECTION 3 -C FULLY EXPANDED SET OF WORKING DESCRIPTORS. THERE -C SHOULD BE AN ELEMENT DESCRIPTOR FOR EVERY DATA -C ENTRY, BUT THERE SHOULD BE -C NO SEQUENCE DESCRIPTORS -C NRDESC - NR OF DESCRIPTORS IN KDESC -C ISEC2D - DATA OR TEXT TO BE ENTERED INTO SECTION 2 -C ISEC2B - NUMBER OF BYTES OF DATA IN ISEC2D -C -C OUTPUT ARGUMENT LIST: -C KDATA - SOURCE DATA ARRAY . A 2-DIMENSION INTEGER ARRAY -C WHERE KDATA(SUBSET,PARAM) -C SUBSET = SUBSET NUMBER -C PARAM = PARAMETER NUMBER -C KARY - WORKING ARRAY FOR MESSAGE UNDER CONSTRUCTION -C (1) UNUSED -C (2) PARAMETER POINTER -C (3) MESSAGE BIT POINTER -C (4) DELAYED REPLICATION FLAG -C 0 = NO DELAYED REPLICATION -C 1 = CONTAINS DELAYED REPLICATION -C (5) BIT POINTER FOR START OF SECTION 4 -C (6) UNUSED -C (7) NR OF BITS FOR PARAMETER/DATA PACKING -C (8) TOTAL BITS FOR ASCII DATA -C (9) SCALE CHANGE VALUE -C (10) INDICATOR (USED IN W3FI85) -C 1 = NUMERIC DATA -C 2 = TEXT DATA -C (11) POINTER TO CURRENT POS IN KDESC -C (12) UNUSED -C (13) UNUSED -C (14) UNUSED -C (15) DATA TYPE -C (16) UNUSED -C (17) UNUSED -C (18) WORDS ADDED FOR TEXT OR ASSOCIATED FIELDS -C (19) LOCATION FOR TOTAL BYTE COUNT -C (20) SIZE OF SECTION 0 -C (21) SIZE OF SECTION 1 -C (22) SIZE OF SECTION 2 -C (23) SIZE OF SECTION 3 -C (24) SIZE OF SECTION 4 -C (25) SIZE OF SECTION 5 -C (26) NR BITS ADDED BY TABLE C OPERATOR -C (27) BIT WIDTH OF ASSOCIATED FIELD -C (28) JDESC INPUT FORM FLAG -C 0 = DESCRIPTOR IN F X Y FORM -C F IN JDESC(1,I) -C X IN JDESC(2,I) -C Y IN JDESC(3,I) -C 1 = DESCRIPTOR IN DECIMAL FORM IN JDESC(1,I) -C (29) KDESC INPUT FORM FLAG -C 0 = DESCRIPTOR IN F X Y FORM -C F IN KDESC(1,I) -C X IN KDESC(2,I) -C Y IN KDESC(3,I) -C 1 = DESCRIPTOR IN DECIMAL FORM IN KDESC(1,I) -C (30) BUFR MESSAGE TOTAL BYTE COUNT -C KBUFR - ARRAY TO CONTAIN COMPLETED BUFR MESSAGE -C IERRTN - ERROR RETURN FLAG -C KSEQ - WORKING ARRAY FOR TABLE D INITIAL SEARCH KEY -C KNUM - WORKING ARRAY FOR TABLE D NUMBER OF DESC'S IN SEQ -C KLIST - WORKING ARRAY FOR TABLE D SEQUENCES -C ANAME - TABLE B DESCRIPTOR NAMES -C AUNITS - TABLE B DESCRIPTOR UNITS -C LDESC - TABLE B DECIMAL EQUIV OF F X Y VALUES -C KSCALE - TABLE B STANDARD SCALE VALUES -C KFRVAL - TABLE B REFERENCE VALUES -C KRFVSW - TABLE B SWITCHES TO INDICATE IF HAVE NEW/OLD REF VAL -C NEWRFV - TABLE B NEW REFERENCE VALUES -C KWIDTH - ARRAY OF BIT WIDTHS FOR EACH ENTRY IN TABLE B -C -C REMARKS: -C IERRTN = 0 NORMAL RETURN, BUFR MESSAGE RESIDES IN KBUFR -C IF ISECT3(4)= 0, ALL REPORTS HAVE BEEN -C PROCESSED INTO A BUFR -C MESSAGE -C IF ISECT3(4)= 1, A BUFR MESSAGE HAS BEEN -C GENERATED WITH ALL OR PART OF -C THE DATA PASSED TO THIS -C ROUTINE. ISECT3(6) CONTAINS -C THE NUMBER OF REPORTS THAT -C WERE NOT USED BUT ARE BEING -C HELD FOR THE NEXT MESSAGE. -C = 1 BUFR MESSAGE CONSTRUCTION WAS HALTED -C BECAUSE CONTENTS EXCEEDED MAXIMUM SIZE -C (ONLY WHEN ISECT3(4) = 0) -C = 2 BUFR MESSAGE CONSTRUCTION WAS HALTED -C BECAUSE OF ENCOUNTER WITH A DESCRIPTOR -C NOT FOUND IN TABLE B. -C = 3 ROUTINE WAS CALLED WITH NO SUBSETS -C = 4 ERROR OCCURED WHILE READING TABLE B -C = 5 AN ATTEMPT WAS MADE TO EXPAND JDESC -C INTO KDESC, BUT A DESCRIPTOR INDICATING -C DELAYED REPLICATION WAS ENCOUNTERED -C = 6 ERROR OCCURED WHILE READING TABLE D -C = 7 DATA VALUE COULD NOT BE CONTAINED -C IN SPECIFIED BIT WIDTH -C = 8 DELAYED REPLICATION NOT PERMITTED -C IN COMPRESSED DATA FORMAT -C = 9 AN OPERATOR DESCRIPTOR 2 04 YYY OPENING -C AN ASSOCIATED FIELD (YYY NOT EQ ZERO) -C WAS NOT FOLLOWED BY THE DEFINING DESCRIPTOR -C 0 31 021 (7957 DECIMAL). -C = 10 DELAYED REPLICATION DESCRIPTOR WAS NOT -C FOLLOWED BY DESCRIPTOR FOR DELAYED -C REPLICATION FACTOR. -C 0 31 001 -C 0 31 002 -C 0 31 011 -C 0 31 012 -C = 11 ENCOUNTERED A REFERENCE VALUE THAT FORCED A -C DATA ELEMENT TO BECOME NEGATIVE -C = 12 NO MATCHING TABLE D ENTRY FOR SEQUENCE -C DESCRIPTOR. -C = 13 ENCOUNTERED A NON-ACCEPTABLE DATA ENTRY FLAG. -C ISECT3(6) SHOULD BE 0 OR 1. -C = 14 CONVERTING DESCRIPTORS FXY->DECIMAL, -C NUMBER TO CONVERT = 0 -C = 15 NO DESCRIPTORS SPECIFIED FOR SECTION 3 -C = 16 INCOMPLETE TABLE B, NUMBER OF DESCRIPTORS -C IN TABLE B DOES NOT MATCH NUMBER OF -C DESCRIPTORS NEEDED TO CONSTRUCT BUFR MESSAGE -C = 20 INCORRECT ENTRY OF REPLICATION OR SEQUENCE -C DESCRIPTOR IN LIST OF REFERENCE VALUE CHANGES -C = 21 INCORRECT OPERATOR DESCRIPTOR IN LIST OF -C REFERENCE VALUE CHANGES -C = 22 ATTEMPTING TO ENTER NEW REFERENCE VALUE INTO -C TABLE B, BUT DESCRIPTOR DOES NOT EXIST IN -C CURRENT MODIFIED TABLE B -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256 -C -C$$$ -C - REAL RDATA(*) -C - INTEGER IDATA(*),LOWEST,MAXVAL,JSTART - INTEGER KARY(*),MISG,LL - INTEGER KDESC(3,*),KASSOC(*) - INTEGER IBITS(32) - INTEGER ZEROS(255) - INTEGER INDEXB(16383) - CHARACTER*9 CCITT - CHARACTER*4 AHOLD(2) - CHARACTER*1 ATEXT(*) - LOGICAL*1 TEXT - LOGICAL*1 MSGFLG,DUPFLG -C ===================================== -C INFORMATION REQUIRED FOR CONSTRUCTION OF BUFR MESSAGE - INTEGER ISECT1(*) - INTEGER ISEC2B,ISEC2D(255) - INTEGER ISECT3(*) - INTEGER JDESC(3,*) - INTEGER NEWNR - INTEGER KDATA(500,*) - INTEGER KBUFR(*) -C ===================================== -C TABLE B INFORMATION - INTEGER LDESC(800),KT(800) - INTEGER KSCALE(800) - INTEGER KRFVAL(800),KRFVSW(800),NEWRFV(800) - INTEGER KWIDTH(800) - CHARACTER*40 ANAME(800) - CHARACTER*25 AUNITS(800) -C ===================================== -C TABLE D INFORMATION - INTEGER KSEQ(300),KNUM(300) - INTEGER KLIST(300,10) -C ===================================== - SAVE -C - DATA CCITT /'CCITT IA5'/ - DATA IBITS / 1, 3, 7, 15, - * 31, 63, 127, 255, - * 511, 1023, 2047, 4095, - * 8191, 16383, 32767, 65535, - * Z'0001FFFF',Z'0003FFFF',Z'0007FFFF',Z'000FFFFF', - * Z'001FFFFF',Z'003FFFFF',Z'007FFFFF',Z'00FFFFFF', - * Z'01FFFFFF',Z'03FFFFFF',Z'07FFFFFF',Z'0FFFFFFF', - * Z'1FFFFFFF',Z'3FFFFFFF',Z'7FFFFFFF',Z'FFFFFFFF'/ - DATA LL /0/ - DATA MISG /99999/ - DATA ZEROS /255*0/ -C ===================================== -C THERE MUST BE DESCRIPTORS IN JDESC -C AND A COUNT IN NEWNR -C ===================================== - IF (NEWNR.EQ.0) THEN - IERRTN = 15 - RETURN - END IF -C ===================================== -C IF INPUT FORM IS F X Y SEGMENTS THEN -C CONVERT INPUT FORM OF JDESC FROM FXY TO DECIMAL -C ===================================== - IF (JIF.EQ.0) THEN -C CONVERT TO DECIMAL - CALL FI8505(JIF,JDESC,NEWNR,IERRTN) - IF (IERRTN.NE.0) THEN - RETURN - END IF - END IF -C ===================================== -C IF PROCESSING DELAYED REPLICATION, MUST RELOAD -C KDESC FROM JDESC -C ===================================== - IF (KARY(4).NE.0) THEN - NRDESC = 0 - END IF -C ===================================== -C IF ONLY HAVE JDESC, NEWNR CREATE KDESC, NRDESC -C ===================================== -C IF ONLY HAVE JDESC, NEWNR CREATE KDESC, NRDESC - IF (NRDESC.EQ.0) THEN - DO 50 I = 1, NEWNR - KDESC(1,I) = JDESC(1,I) - 50 CONTINUE - NRDESC = NEWNR - KIF = 1 - ELSE IF (NRDESC.NE.0) THEN -C KDESC ALL READY EXISTS - IF (KIF.EQ.0) THEN -C CONVERT INPUT FORM OF KDESC FROM FXY TO DECIMAL - CALL FI8505(KIF,KDESC,NRDESC,IERRTN) - IF (IERRTN.NE.0) THEN - RETURN - END IF - END IF - END IF -C ===================================== -C READ IN TABLE B SUBSET, IF NOT ALL READY IN PLACE -C ===================================== - IF (ISECT3(8).EQ.0) THEN - CALL FI8512(IUNITB,ISECT3,KDESC,NRDESC,KARY,IERRTN, - * LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KWIDTH,KRFVSW, - * IUNITD,KSEQ,KNUM,KLIST,INDEXB) - IF (IERRTN.NE.0) GO TO 9000 - END IF -C ===================================== -C ROUTE TO SELECTED PROCESSING -C ===================================== - KSUB = ISECT3(1) - IF (ISTEP.EQ.1) THEN -C PROCESSING INTEGER DATA INPUT - CALL FI8508(ISTEP,IUNITB,IDATA,KDESC,NRDESC,ATEXT,KSUB,KARY, - * KDATA,LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KRFVSW,ISECT3, - * KWIDTH,KASSOC,IUNITD,KSEQ,KNUM,KLIST,IERRTN,INDEXB) - RETURN - ELSE IF (ISTEP.EQ.2) THEN -C PROCESSING REAL DATA INPUT - CALL FI8509(ISTEP,IUNITB,RDATA,KDESC,NRDESC,ATEXT,KSUB,KARY, - * KDATA,LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KRFVSW,ISECT3, - * KWIDTH,KASSOC,IUNITD,KSEQ,KNUM,KLIST,IERRTN,INDEXB) - RETURN - ELSE IF (ISTEP.NE.3) THEN - IERRTN = 20 - RETURN - END IF -C ===================================== -C IF INDICATING ZERO SUBSETS, HAVE AN ERROR CONDITION -C ===================================== - IF (ISECT3(1).LE.0) THEN - IERRTN = 3 - RETURN - END IF -C ===================================== -C SET FOR BUFR MESSAGE -C ===================================== -C -C CLEAR OUTPUT AREA -C BYTES IN EACH FULL WORD - KWORD = 4 -C -C GET NUMBER OF SUBSETS -C - MXRPTS = ISECT3(1) - ISECT3(7) = ISECT3(1) - ISECT3(6) = ISECT3(1) -C -C RE-START POINT FOR PACKING FEWER SUBSETS ? -C - 5 CONTINUE -C - KARY(18) = 0 - KARY(26) = 0 -C ===================================== -C ENTER 'BUFR' - SECTION 0 -C CONSTRUCT UNDER RULES OF EDITION 2 -C ===================================== - KARY(3) = 0 - NBUFR = 1112884818 - CALL SBYTE (KBUFR,NBUFR,KARY(3),32) - KARY(3) = KARY(3) + 32 -C SAVE POINTER FOR TOTAL BYTE COUNT -C IN MESSAGE - KARY(19) = KARY(3) - KARY(3) = KARY(3) + 24 -C SET EDITION NR IN PLACE - CALL SBYTE (KBUFR,2,KARY(3),8) - KARY(3) = KARY(3) + 8 - KARY(20) = 8 -C PRINT *,'SECTION 0' -C ===================================== -C COMPLETE ENTRIES FOR - SECTION 1 -C ===================================== -C ----- 1,3 SECTION COUNT - KARY(21) = 18 - CALL SBYTE (KBUFR,KARY(21),KARY(3),24) - KARY(3) = KARY(3) + 24 -C ----- 4 RESERVED - CALL SBYTE (KBUFR,0,KARY(3),8) - KARY(3) = KARY(3) + 8 -C ----- 5 ORIGINATING SUB-CENTER - CALL SBYTE (KBUFR,ISECT1(3),KARY(3),8) - KARY(3) = KARY(3) + 8 -C ----- 6 ORIGINATING CENTER - CALL SBYTE (KBUFR,ISECT1(4),KARY(3),8) - KARY(3) = KARY(3) + 8 -C ----- 7 UPDATE SEQUENCE NUMBER - CALL SBYTE (KBUFR,ISECT1(5),KARY(3),8) - KARY(3) = KARY(3) + 8 -C ----- 8 -C INDICATE NO SECTION 2 - CALL SBYTE (KBUFR,ISECT1(6),KARY(3),1) - KARY(3) = KARY(3) + 1 - CALL SBYTE (KBUFR,0,KARY(3),7) - KARY(3) = KARY(3) + 7 -C ----- 9 BUFR MESSAGE TYPE - CALL SBYTE (KBUFR,ISECT1(7),KARY(3),8) - KARY(3) = KARY(3) + 8 -C ----- 10 BUFR MESSAGE SUB-TYPE - CALL SBYTE (KBUFR,ISECT1(8),KARY(3),8) - KARY(3) = KARY(3) + 8 -C ----- 11 VERSION OF MASTER TABLE - CALL SBYTE (KBUFR,ISECT1(9),KARY(3),8) - KARY(3) = KARY(3) + 8 -C ----- 12 VERSION OF LOCAL TABLE - CALL SBYTE (KBUFR,ISECT1(10),KARY(3),8) - KARY(3) = KARY(3) + 8 -C ----- 13 YEAR - CALL SBYTE (KBUFR,ISECT1(11),KARY(3),8) - KARY(3) = KARY(3) + 8 -C ----- 14 MONTH - CALL SBYTE (KBUFR,ISECT1(12),KARY(3),8) - KARY(3) = KARY(3) + 8 -C ---- 15 DAY - CALL SBYTE (KBUFR,ISECT1(13),KARY(3),8) - KARY(3) = KARY(3) + 8 -C ----- 16 HOUR - CALL SBYTE (KBUFR,ISECT1(14),KARY(3),8) - KARY(3) = KARY(3) + 8 -C ----- 17 MINUTE - CALL SBYTE (KBUFR,ISECT1(15),KARY(3),8) - KARY(3) = KARY(3) + 8 -C ----- 18 FILL - CALL SBYTE (KBUFR,0,KARY(3),8) - KARY(3) = KARY(3) + 8 -C PRINT *,'SECTION 1' -C ===================================== -C SKIP - SECTION 2 -C ===================================== - IF (ISECT1(6).NE.0) THEN -C BUILD SECTION COUNT - KARY(22) = 4 + ISEC2B - IF (MOD(KARY(22),2).NE.0) KARY(22) = KARY(22) + 1 -C INSERT SECTION COUNT - CALL SBYTE (KBUFR,KARY(22),KARY(3),24) - KARY(3) = KARY(3) + 24 -C INSERT RESERVED POSITION - CALL SBYTE (KBUFR,0,KARY(3),8) - KARY(3) = KARY(3) + 8 -C INSERT SECTION 2 DATA - CALL SBYTES(KBUFR,ISEC2D,KARY(3),8,0,ISEC2B) - KARY(3) = KARY(3) + (ISEC2B * 8) - IF (MOD(ISEC2B,2).NE.0) THEN - CALL SBYTE (KBUFR,0,KARY(3),8) - KARY(3) = KARY(3) + 8 - END IF - ELSE - KARY(22) = 0 - END IF -C ===================================== -C MAKE PREPARATIONS FOR SECTION 3 DESCRIPTORS -C ===================================== - KARY(23) = 7 + NEWNR*2 + 1 -C SECTION 3 SIZE - CALL SBYTE (KBUFR,KARY(23),KARY(3),24) - KARY(3) = KARY(3) + 24 -C RESERVED BYTE - CALL SBYTE (KBUFR,0,KARY(3),8) - KARY(3) = KARY(3) + 8 -C NUMBER OF SUBSETS - CALL SBYTE (KBUFR,ISECT3(1),KARY(3),16) - KARY(3) = KARY(3) + 16 -C SET OBSERVED DATA SWITCH - CALL SBYTE (KBUFR,ISECT3(2),KARY(3),1) - KARY(3) = KARY(3) + 1 -C SET COMPRESSED DATA SWITCH - CALL SBYTE (KBUFR,ISECT3(3),KARY(3),1) - KARY(3) = KARY(3) + 1 - CALL SBYTE (KBUFR,0,KARY(3),6) - KARY(3) = KARY(3) + 6 -C ===================================== -C DESCRIPTORS - SECTION 3 -C ===================================== - DO 37 KH = 1, NEWNR -C PRINT *,'INSERTING',JDESC(1,KH),' INTO SECTION 3' - CALL SBYTE (KBUFR,JDESC(1,KH),KARY(3),16) - KARY(3) = KARY(3) + 16 - 37 CONTINUE -C FILL TO TWO BYTE BOUNDARY - CALL SBYTE (KBUFR,0,KARY(3),8) - KARY(3) = KARY(3) + 8 -C PRINT *,'SECTION 3' -C ===================================== -C INITIALIZE FOR - SECTION 4 -C ===================================== -C SAVE POINTER TO COUNT POSITION -C PRINT *,'START OF SECTION 4',KARY(3) - KARY(5) = KARY(3) - KARY(3) = KARY(3) + 24 - CALL SBYTE (KBUFR,0,KARY(3),8) - KARY(3) = KARY(3) + 8 -C SKIP TO FIRST DATA POSITION -C ===================================== -C BIT PATTERNS - SECTION 4 -C ===================================== - KEND4 = IBFSIZ * 8 - 32 -C PACK ALL DATA INTO BUFR MESSAGE -C - IF (ISECT3(3).EQ.0) THEN -C ********************************************** -C * * -C * PROCESS AS NON-COMPRESSED MESSAGE * -C * * -C ********************************************** - CALL FI8506(ISTEP,ISECT3,KARY,JDESC,NEWNR,KDESC,NRDESC, - * LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KWIDTH,KRFVSW,NEWRFV, - * KSEQ,KNUM,KLIST,IBFSIZ, - * KDATA,KBUFR,IERRTN,INDEXB) - IF (IERRTN.NE.0) THEN - IF (IERRTN.EQ.1) GO TO 5500 - RETURN - END IF - ELSE -C ********************************************** -C * * -C * PROCESS AS COMPRESSED MESSAGE * -C * * -C ********************************************** - KARY(18) = 0 -C MUST LOOK AT EVERY DESCRIPTOR IN KDESC - KARY(11) = 1 - 3000 CONTINUE - IF (KARY(11).GT.NRDESC) THEN - GO TO 5200 - ELSE -C DO 5000 JK = 1, NRDESC -C RE-ENTRY POINT FOR INSERTION OF -C REPLICATION OR SEQUENCES - 4000 CONTINUE -C ISOLATE TABLE - KFUNC = KDESC(1,KARY(11)) / 16384 -C ISOLATE CLASS - KCLASS = MOD(KDESC(1,KARY(11)),16384) / 256 - KSEG = MOD(KDESC(1,KARY(11)),256) - KARY(2) = KARY(11) + KARY(18) - IF (KFUNC.EQ.1) THEN -C DELAYED REPLICATION NOT ALLOWED -C IN COMPRESSED MESSAGE - IF (KSEG.EQ.0) THEN - IERRTN = 8 - RETURN - END IF -C REPLICATION DESCRIPTOR - CALL FI8501(KARY,ISTEP,KCLASS,KSEG,IDATA,RDATA, - * KDATA,LL,KDESC,NRDESC,IERRTN) -C GO TO 4000 - ELSE IF (KFUNC.EQ.2) THEN - CALL FI8502(*4000,KBUFR,KCLASS,KSEG, - * KDESC,NRDESC,I,ISTEP, - * KARY,KDATA,ISECT3,KRFVSW,NEWRFV,LDESC,IERRTN,INDEXB) - IF (IERRTN.NE.0) THEN - RETURN - END IF - GO TO 5000 - ELSE IF (KFUNC.EQ.3) THEN - CALL FI8503(KARY(11),KDESC,NRDESC, - * ISECT3,IUNITD,KSEQ,KNUM,KLIST,IERRTN) - IF (IERRTN.NE.0) THEN - RETURN - END IF - GO TO 4000 - END IF -C FALL THRU WITH ELEMENT DESCRIPTOR -C POINT TO CORRECT TABLE B ENTRY - L = INDEXB(KDESC(1,KARY(11))) - IF (L.LT.0) THEN - IERRTN = 2 -C PRINT *,'W3FI85 - IERRTN = 2' - RETURN - END IF -C - IF (AUNITS(L)(1:9).EQ.CCITT) THEN - TEXT = .TRUE. - ELSE - TEXT = .FALSE. - END IF - KARY(7) = KWIDTH(L) -C - IF (TEXT) THEN -C PROCESS TEXT DATA - KBZ = KARY(3) + (ISECT3(1) + 1) * KARY(7) + 6 - IF (KBZ.GT.KEND4) THEN - GO TO 5500 - END IF -C NBINC IS NUMBER OF CHARS - NBINC = KARY(7) / 8 -C LOWEST = 0 - CALL SBYTES(KBUFR,ZEROS,KARY(3),8,0,NBINC) - KARY(3) = KARY(3) + KARY(7) - CALL SBYTE (KBUFR,NBINC,KARY(3),6) - KARY(3) = KARY(3) + 6 -C HOW MANY FULL WORDS - NKPASS = KARY(7) / 32 -C HOW MANY BYTES IN PARTIAL WORD - KREM = MOD(KARY(7),32) -C KSKIP = KARY(7) - 32 - DO 4080 NSS = 1, ISECT3(1) -C POINT TO TEXT FOR THIS SUBSET - KARY(2) = KARY(11) + KARY(18) - IF (NKPASS.GE.1) THEN -C PROCESS TEXT IN A SUBSET - DO 4070 NPP = 1, NKPASS -C PROCESS FULL WORDS - IF (ISECT3(10).EQ.1) THEN - CALL W3AI38 (KDATA(NSS,KARY(2)),4) - END IF - CALL SBYTE (KBUFR,KDATA(NSS,KARY(2)), - * KARY(3),32) - KARY(3) = KARY(3) + 32 -C POINT TO NEXT DATA WORD FOR MORE TEXT - KARY(2) = KARY(2) + 1 - 4070 CONTINUE - END IF -C PROCESS PARTIALS - LESS THAN 4 BYTES - IF (KREM.GT.0) THEN - IF (ISECT3(10).EQ.1) THEN - CALL W3AI38 (KDATA(NSS,KARY(2)),4) - END IF - CALL SBYTE (KBUFR,KDATA(NSS,KARY(2)), - * KARY(3),KREM) - KARY(3) = KARY(3) + KREM - END IF - 4080 CONTINUE -C ADJUST EXTRA WORD COUNT - IF (KREM.GT.0) THEN - KARY(18) = KARY(18) + NKPASS - ELSE - KARY(18) = KARY(18) + NKPASS - 1 - END IF -C ------------------------------------------------------------- - GO TO 5000 - ELSE - KARY(2) = KARY(11) + KARY(18) - KARY(7) = KWIDTH(L) + KARY(26) -C -C NON TEXT/NUMERIC DATA -C -C PROCESS ASSOCIATED FIELD DATA - IF (KARY(27).GT.0.AND.KDESC(1,KARY(11)).NE.7957) THEN - DUPFLG = .TRUE. - DO 4130 J = 2, ISECT3(1) - IF (KDATA(J,KARY(2)).NE.KDATA(1,KARY(2)))THEN - DUPFLG = .FALSE. - GO TO 4131 - END IF - 4130 CONTINUE - 4131 CONTINUE - IF (DUPFLG) THEN -C ALL VALUES ARE EQUAL - KBZ = KARY(3) + KARY(7) + 6 - IF (KBZ.GT.KEND4) THEN - GO TO 5500 - END IF - NBINC = 0 -C ENTER COMMON VALUE - IF (KDATA(1,KARY(2)).EQ.MISG) THEN - CALL SBYTE(KBUFR,IBITS(KARY(7)), - * KARY(3),KARY(27)) - ELSE - CALL SBYTE(KBUFR,KDATA(1,KARY(2)), - * KARY(3),KARY(27)) - END IF - KARY(3) = KARY(3) + KARY(27) -C ENTER NBINC - CALL SBYTE (KBUFR,NBINC,KARY(3),6) - KARY(3) = KARY(3) + 6 - ELSE -C MIX OF MISSING AND VALUES -C GET LARGEST DIFFERENCE VALUE - MSGFLG = .FALSE. - DO 4132 J = 1, ISECT3(7) - IF (KDATA(J,KARY(2)).EQ.MISG) THEN - MSGFLG = .TRUE. - GO TO 4133 - END IF - 4132 CONTINUE - 4133 CONTINUE - DO 4134 J = 1, ISECT3(7) - IF (KDATA(J,KARY(2)).LT.IBITS(KARY(27)) - * .AND.KDATA(J,KARY(2)).GE.0.AND. - * KDATA(J,KARY(2)).NE.MISG) THEN - LOWEST = KDATA(J,KARY(2)) - MAXVAL = KDATA(J,KARY(2)) - JSTART = J + 1 - GO TO 4135 - END IF - 4134 CONTINUE - 4135 CONTINUE - DO 4136 J = JSTART, ISECT3(7) - IF (KDATA(J,KARY(2)).NE.MISG) THEN - IF (KDATA(J,KARY(2)).LT.LOWEST) THEN - LOWEST = KDATA(J,KARY(2)) - ELSE IF(KDATA(J,KARY(2)).GT.MAXVAL)THEN - MAXVAL = KDATA(J,KARY(2)) - END IF - END IF - 4136 CONTINUE - MXDIFF = MAXVAL - LOWEST -C FIND NBINC - MXBITS = KARY(27) - DO 4142 LJ = 1, MXBITS - NBINC = LJ - IF (MXDIFF.LT.IBITS(LJ)) THEN - GO TO 4143 - END IF - 4142 CONTINUE - 4143 CONTINUE - KBZ = KARY(3) + MXBITS + 6 + ISECT3(1) * NBINC - IF (KBZ.GT.KEND4) THEN - GO TO 5500 - END IF - IF (NBINC.GT.MXBITS) THEN - IERRTN = 3 - RETURN - END IF -C ENTER LOWEST - CALL SBYTE(KBUFR,LOWEST,KARY(3),MXBITS) - KARY(3) = KARY(3) + MXBITS - CALL SBYTE(KBUFR,NBINC,KARY(3),6) - KARY(3) = KARY(3) + 6 -C GET DIFFERENCE VALUES - IF (MSGFLG) THEN - DO 4144 M = 1, ISECT3(1) - IF (KDATA(M,KARY(2)).EQ.MISG) THEN - KT(M) = IBITS(NBINC) - ELSE - KT(M) = KDATA(M,KARY(2)) - LOWEST - END IF - 4144 CONTINUE - ELSE - DO 4146 M = 1, ISECT3(1) - KT(M) = KDATA(M,KARY(2)) - LOWEST - 4146 CONTINUE - END IF -C ENTER DATA VALUES - CALL SBYTES(KBUFR,KT,KARY(3),NBINC, - * 0,ISECT3(1)) - KARY(3) = KARY(3) + ISECT3(1) * NBINC - END IF - KARY(18) = KARY(18) + 1 - END IF -C --------------------------------------------------- -C STANDARD DATA -C --------------------------------------------------- - KARY(2) = KARY(11) + KARY(18) - MXBITS = KARY(7) + KARY(26) - DUPFLG = .TRUE. - DO 4030 J = 2, ISECT3(7) - IF (KDATA(J,KARY(2)).NE.KDATA(1,KARY(2))) THEN - DUPFLG = .FALSE. - GO TO 4031 - END IF - 4030 CONTINUE - 4031 CONTINUE - IF (DUPFLG) THEN -C ALL VALUES ARE EQUAL - KBZ = KARY(3) + KARY(7) + 6 - IF (KBZ.GT.KEND4) THEN - GO TO 5500 - END IF - NBINC = 0 -C ENTER COMMON VALUE - IF (KDATA(1,KARY(2)).EQ.MISG) THEN - CALL SBYTE(KBUFR,IBITS(MXBITS), - * KARY(3),MXBITS) - ELSE - CALL SBYTE(KBUFR,KDATA(1,KARY(2)), - * KARY(3),MXBITS) - END IF - KARY(3) = KARY(3) + KARY(7) -C ENTER NBINC - CALL SBYTE (KBUFR,NBINC,KARY(3),6) - KARY(3) = KARY(3) + 6 - ELSE -C MIX OF MISSING AND VALUES -C GET LARGEST DIFFERENCE VALUE - MSGFLG = .FALSE. - DO 4032 J = 1, ISECT3(7) - IF (KDATA(J,KARY(2)).EQ.MISG) THEN - MSGFLG = .TRUE. - GO TO 4033 - END IF - 4032 CONTINUE - 4033 CONTINUE - DO 4034 J = 1, ISECT3(7) - IF (KDATA(J,KARY(2)).NE.MISG) THEN - LOWEST = KDATA(J,KARY(2)) - MAXVAL = KDATA(J,KARY(2)) -C PRINT *,' ' -C PRINT *,'START VALUES',LOWEST,MAXVAL, -C * 'J=',J,' KARY(2)=',KARY(2) - GO TO 4035 - END IF - 4034 CONTINUE - 4035 CONTINUE - DO 4036 J = 1, ISECT3(1) - IF (KDATA(J,KARY(2)).NE.MISG) THEN - IF (KDATA(J,KARY(2)).LT.LOWEST) THEN - LOWEST = KDATA(J,KARY(2)) -C PRINT *,'NEW LOWEST=',LOWEST,J - ELSE IF (KDATA(J,KARY(2)).GT.MAXVAL) THEN - MAXVAL = KDATA(J,KARY(2)) -C PRINT *,'NEW MAXVAL=',MAXVAL,J - END IF - END IF - 4036 CONTINUE - MXDIFF = MAXVAL - LOWEST -C FIND NBINC - DO 4042 LJ = 1, MXBITS - NBINC = LJ - IF (MXDIFF.LT.IBITS(LJ)) GO TO 4043 - IF (NBINC.EQ.MXBITS) GO TO 4043 - 4042 CONTINUE - 4043 CONTINUE - KBZ = KARY(3) + MXBITS + 38 + ISECT3(1) * NBINC - IF (KBZ.GT.KEND4) THEN - GO TO 5500 - END IF -C PRINT 4444,KARY(11),KDESC(1,KARY(11)),LOWEST, -C * MAXVAL,MXDIFF,KARY(7),NBINC,ISECT3(1),ISECT3(7) -C4444 FORMAT(9(1X,I8)) -C ENTER LOWEST -C ADJUST WITH REFERENCE VALUE - IF (KRFVSW(L).EQ.0) THEN - JRV = KRFVAL(L) - ELSE - JRV = NEWRFV(L) - END IF - LVAL = LOWEST - JRV - CALL SBYTE(KBUFR,LVAL,KARY(3),MXBITS) - KARY(3) = KARY(3) + MXBITS - IF (NBINC.GT.MXBITS) THEN - IERRTN = 3 - RETURN - END IF - CALL SBYTE(KBUFR,NBINC,KARY(3),6) - KARY(3) = KARY(3) + 6 -C GET DIFFERENCE VALUES - IF (MSGFLG) THEN - DO 4044 M = 1, ISECT3(1) - IF (KDATA(M,KARY(2)).EQ.MISG) THEN - KT(M) = IBITS(NBINC) - ELSE - KT(M) = KDATA(M,KARY(2)) - LOWEST - END IF - 4044 CONTINUE - ELSE - DO 4046 M = 1, ISECT3(1) - KT(M) = KDATA(M,KARY(2)) - LOWEST - 4046 CONTINUE - END IF -C ENTER DATA VALUES - CALL SBYTES(KBUFR,KT,KARY(3),NBINC, - * 0,ISECT3(1)) - KARY(3) = KARY(3) + ISECT3(1) * NBINC - END IF - GO TO 5000 - END IF -C ------------------------------------------------------------- - 5000 CONTINUE - KARY(11) = KARY(11) + 1 - GO TO 3000 - ENDIF - 5200 CONTINUE - END IF - ISECT3(6) = 0 - GO TO 6000 - 5500 CONTINUE -C THE SEGMENT OF CODE BETWEEN STATEMENTS -C 5500-6000 ARE ACTIVATED IF AND WHEN THE -C MAXIMUM MESSAGE SIZE HAS BEEN EXCEEDED -C -C ARE WE REDUCING IF OVERSIZED ??? - IF (ISECT3(4).NE.0) THEN -C INCREMENT REDUCTION COUNT - ISECT3(6) = ISECT3(6) + ISECT3(5) -C REDUCE NUMBER TO INCLUDE - ISECT3(7) = ISECT3(1) - ISECT3(5) - ISECT3(1) = ISECT3(7) - PRINT *,'REDUCED BY ',ISECT3(5),' ON THIS PASS' - GO TO 5 - ELSE - IERRTN = 1 - RETURN - END IF - 6000 CONTINUE -C --------------------------------------------------------------- -C FILL IN SECTION 4 OCTET COUNT - NBUFR = MOD((KARY(3) - KARY(5)),16) -C MAY BE NECESSARY TO ADJUST COUNT - IF (NBUFR.NE.0) THEN - KARY(3) = KARY(3) + 16 - NBUFR - END IF - KARY(24) = (KARY(3) - KARY(5)) / 8 - CALL SBYTE (KBUFR,KARY(24),KARY(5),24) -C PRINT *,'SECTION 4' -C ===================================== -C ENDING KEY '7777' - SECTION 5 -C ===================================== - KARY(25) = 4 - NBUFR = 926365495 - CALL SBYTE (KBUFR,NBUFR,KARY(3),32) - KARY(3) = KARY(3) + 32 -C CONSTRUCT TOTAL BYTE COUNT FOR SECTION 0 - ITOTAL = KARY(3) / 8 - CALL SBYTE (KBUFR,ITOTAL,32,24) - KARY(30) = ITOTAL -C WRITE (6,8601) ITOTAL - 8601 FORMAT (1X,22HTHIS MESSAGE CONTAINS ,I10,6H BYTES) -C ======================================= -C KBUFR CONTAINS A COMPLETED MESSAGE - IF (ISECT3(4).NE.0.AND.ISECT3(5).NE.0) THEN -C ADJUST KDATA ARRAY - NR = MXRPTS - ISECT3(1) - ISECT3(7) = ISECT3(7) + 1 - DO 7500 I = 1, NR - DO 7000 J = 1, NRDESC - KDATA(I,J) = KDATA(ISECT3(7),J) - 7000 CONTINUE - ISECT3(7) = ISECT3(7) + 1 - 7500 CONTINUE - KARY(14) = NR - ELSE - ISECT3(7) = ISECT3(1) - END IF -C ======================================= - IERRTN = 0 - 9000 CONTINUE - RETURN - END - SUBROUTINE FI8501(KARY,ISTEP,KCLASS,KSEG,IDATA,RDATA, - * KDATA,NSUB,KDESC,NRDESC,IERRTN) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8501 PERFORM REPLICATION OF DESCRIPTORS -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-12-03 -C -C ABSTRACT: HAVE ENCOUNTERED A REPLICATION DESCRIPTOR . IT MAY INCLUDE -C DELAYED REPLICATION OR NOT. THAT DECISION SHOULD HAVE BEEN -C MADE PRIOR TO CALLING THIS ROUTINE. -C -C PROGRAM HISTORY LOG: -C 93-12-03 CAVANAUGH -C 94-03-25 HOPPA ADDED LINE TO INITIALIZE NXTPTR TO CORRECT -C AN ERROR IN THE STANDARD REPLICATION. -C 94-03-28 HOPPA CORRECTED AN ERROR IN THE STANDARD REPLICATION -C THAT WAS ADDING EXTRA ZEROS TO THE BUFR -C MESSAGE AFTER THE REPLICATED DATA. -C 94-03-31 HOPPA ADDED THE SUBSET NUMBER TO THE PARAMETER LIST. -C CORRECTED THE EQUATION FOR THE NUMBER OF -C REPLICATIONS WITH DELAYED REPLICATION. -C (ISTART AND K DON'T EXIST) -C 94-04-19 HOPPA SWITCHED THE VARIABLES NEXT AND NXTPRT -C 94-04-20 HOPPA ADDED THE KDATA PARAMETER COUNTER TO THE -C PARAMETER LIST. IN THE ASSIGNMENT OF NREPS -C WHEN HAVE DELAYED REPLICATION, CHANGED INDEX -C IN KDATA FROM N TO K. -C 94-04-29 HOPPA - REMOVED N AND K FROM THE INPUT LIST -C - CHANGED N TO KARY(11) AND K TO KARY(2) -C -C USAGE: CALL FI8501(KARY,ISTEP,KCLASS,KSEG,IDATA,RDATA, -C * KDATA,N,NSUB,KDESC,NRDESC,IERRTN) -C INPUT ARGUMENT LIST: -C ISTEP - -C KCLASS - -C KKSEG - -C IDATA - -C RDATA - -C KDATA - -C N - CURRENT POSITION IN DESCRIPTOR LIST -C NSUB - CURRENT SUBSET -C KDESC - LIST OF DESCRIPTORS -C NRDESC - NUMBER OF DESCRIPTORS IN KDESC -C -C OUTPUT ARGUMENT LIST: -C N - CURRENT POSITION IN DESCRIPTOR LIST -C KDESC - MODIFIED LIST OF DESCRIPTORS -C NRDESC - NEW NUMBER OF DESCRIPTORS IN KDESC -C IERRTN - ERROR RETURN VALUE -C -C REMARKS: -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256 -C -C$$$ -C - REAL RDATA(*) -C - INTEGER IDATA(*),NREPS,KARY(*) - INTEGER KCLASS,KSEG - INTEGER KDESC(3,*),NRDESC,KDATA(500,*) - INTEGER IERRTN - INTEGER ITAIL(1600) - INTEGER IHOLD(1600),ISTEP -C - SAVE -C -C TEST KFUNC FOR DESCRIPTOR TYPE -C DO REPLICATION -C **************************************************************** - IERRTN = 0 -C REPLICATION DESCRIPTOR -C STANDARD REPLICATION WILL SIMPLY -C BE PROCESSED FROM ITS DESCRIPTOR -C PARTS -C -C DELAYED REPLICATION DESCRIPTOR -C MUST BE FOLLOWED BY ONE OF THE -C DESCRIPTORS FOR A DELAYED -C REPLICATION FACTOR -C 0 31 001 (7937 DECIMAL) -C 0 31 002 (7938 DECIMAL) -C 0 31 011 (7947 DECIMAL) -C 0 31 012 (7948 DECIMAL) - IF (KSEG.NE.0) THEN -C HAVE NUMBER OF REPLICATIONS AS KSEG - NREPS = KSEG - IPUT = KARY(11) - NEXT = IPUT + 1 - NXTPTR = IPUT + 1 + KCLASS - ELSE IF (KSEG.EQ.0) THEN - IF (KDESC(1,KARY(11)+1).EQ.7937.OR. - * KDESC(1,KARY(11)+1).EQ.7938.OR. - * KDESC(1,KARY(11)+1).EQ.7947.OR. - * KDESC(1,KARY(11)+1).EQ.7948) THEN -C PRINT *,'HAVE DELAYED REPLICATION' - KARY(4) = 1 -C MOVE REPLICATION DEFINITION - KDESC(1,KARY(11)) = KDESC(1,KARY(11)+1) -C MUST DETERMINE HOW MANY REPLICATIONS - IF (ISTEP.EQ.1) THEN - NREPS = IDATA(KARY(11)) - ELSE IF (ISTEP.EQ.2) THEN - NREPS = RDATA(KARY(11)) - ELSE - NREPS = KDATA(NSUB,KARY(2)) - END IF - IPUT = KARY(11) + 1 - NXTPTR = IPUT + KCLASS + 1 - NEXT = IPUT + 1 -C POINT TO REPLICATION DESCRIPTOR - END IF - ELSE - IERRTN = 10 - RETURN - END IF -C EXTRACT DESCRIPTORS TO BE REPLICATED -C IF NREPS = 0, THIS LIST OF DESCRIPTORS IS NOT TO -C BE USED IN DEFINING THE DATA, -C OTHERWISE -C IT WILL BE USED TO DEFINE THE DATA - IF (NREPS.NE.0) THEN - DO 1000 IJ = 1, KCLASS - IHOLD(IJ) = KDESC(1,NEXT) - NEXT = NEXT + 1 - 1000 CONTINUE -C SKIP THE NUMBER OF DESCRIPTORS DEFINED BY KCLASS - END IF -C SAVE OFF TAIL OF DESC STREAM -C START AT FIRST POSITION OF TAIL - IGOT = 0 - DO 1100 IJ = NXTPTR, NRDESC - IGOT = IGOT + 1 - ITAIL(IGOT) = KDESC(1,IJ) - 1100 CONTINUE -C INSERT ALL REPLICATED DESC'S - IF (NREPS.NE.0) THEN - DO 1300 KR = 1, NREPS - DO 1200 KD = 1, KCLASS - KDESC(1,IPUT) = IHOLD(KD) - IPUT = IPUT + 1 - 1200 CONTINUE - 1300 CONTINUE - END IF -C RESTORE TAIL - DO 1400 ITL = 1, IGOT - KDESC(1,IPUT) = ITAIL(ITL) - IPUT = IPUT + 1 - 1400 CONTINUE -C -C RESET NUMBER OF DESCRIPTORS IN KDESC - NRDESC = IPUT - 1 -C **************************************************************** - RETURN - END - SUBROUTINE FI8502(*,KBUFR,KCLASS,KSEG,KDESC,NRDESC,I,ISTEP, - * KARY,KDATA,ISECT3,KRFVSW,NEWRFV,LDESC,IERRTN,INDEXB) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8502 PROCESS AN OPERATOR DESCRIPTOR -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-12-03 -C -C ABSTRACT: HAVE ENCOUNTERED AN OPERATOR DESCRIPTOR -C -C -C PROGRAM HISTORY LOG: -C 93-12-03 CAVANAUGH -C 94-04-15 J. HOPPA - ADDED KBUFR TO INPUT PARAMETER LIST. -C - ADDED BLOCK OF DATA TO CORRECTLY USE SBYTE -C WHEN WRITING A 205YYY DESCRIPTOR TO THE -C BUFR MESSAGE. -C THE PREVIOUS WAY DIDN'T WORK BECAUSE KDATA -C WAS GETTING INCREMETED BY THE KSUB VALUE, -C NOT THE PARAM VALUE. -C 94-04-29 J. HOPPA - CHANGED K TO KARY(2) -C - REMOVED A LINE THAT BECAME OBSOLETE WITH -C ABOVE CHANGE -C 94-05-18 J. HOPPA - ADDED A KARY(2) INCREMENT -C -C USAGE: CALL FI8502(*,KCLASS,KSEG,KDESC,NRDESC,I,ISTEP, -C * KARY,KDATA,ISECT3,KRFVSW,NEWRFV,LDESC,IERRTN,INDEXB) -C INPUT ARGUMENT LIST: -C KCLASS - -C KSEG - -C KDESC - -C NRDESC - -C I - -C ISTEP - -C KARY - -C -C OUTPUT ARGUMENT LIST: -C KDESC - -C NRDESC - -C KARY - -C IERRTN - ERROR RETURN VALUE -C -C REMARKS: -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256 -C -C$$$ -C - INTEGER KCLASS,KSEG,ZEROES(255) - INTEGER KRFVSW(*),NEWRFV(*),LDESC(*) - INTEGER I,KDESC(3,*),KDATA(500,*),ISECT3(*) - INTEGER NRDESC - INTEGER KARY(*) - INTEGER IERRTN - INTEGER NLEFT -C - SAVE -C - DATA ZEROES/255*0/ -C -C **************************************************************** - IERRTN = 0 -C OPERATOR DESCRIPTOR - IF (KCLASS.EQ.1) THEN -C BITS ADDED TO DESCRIPTOR WIDTH - IF (ISTEP.EQ.3) THEN - IF (KSEG.NE.0) THEN - KARY(26) = KSEG - 128 - ELSE - KARY(26) = 0 - END IF - END IF - ELSE IF (KCLASS.EQ.2) THEN -C NEW SCALE VALUE - IF (ISTEP.EQ.3) THEN - IF (KSEG.EQ.0) THEN - KARY(9) = 0 - ELSE - KARY(9) = KSEG - 128 - END IF - END IF - ELSE IF (KCLASS.EQ.3) THEN -C CHANGE REFERENCE VALUE -C MUST ACCEPT INTO OUTPUT THE -C REFERENCE VALUE CHANGE AND ACTIVATE -C THE CHANGE WHILE PROCESSING - IF (ISTEP.EQ.3) THEN -C HAVE OPERATOR DESCRIPTOR FOR REFERENCE VALUES - IF (KSEG.EQ.0) THEN - DO 100 IQ = 1, ISECT3(8) -C RESET ALL NEW REFERENCE VALUES - KRFVSW(IQ) = 0 - 100 CONTINUE - END IF - 200 CONTINUE -C GET NEXT DESCRIPTOR - KARY(11) = KARY(11) + 1 - IF (KDESC(1,KARY(11)).GT.16383) THEN -C NOT AN ELEMENT DESCRIPTOR - NFUNC = KDESC(1,KARY(11)) / 16384 - IF (NFUNC.EQ.1.OR.NFUNC.EQ.3) THEN - IERRTN = 20 - PRINT *,'INCORRECT ENTRY OF REPLICATION OR ', - * 'SEQUENCE DESCRIPTOR IN LIST OF ', - * 'REFERENCE VALUE CHANGES' - RETURN - END IF - NCLASS = (KDESC(1,KARY(11)) - NFUNC*16384) / 256 - IF (NCLASS.EQ.3) THEN - NSEG = MOD(KDESC(1,KARY(11)),256) - IF (NSEG.EQ.255) THEN - RETURN - END IF - END IF - IERRTN = 21 - PRINT *,'INCORRECT OPERATOR DESCRIPTOR ENTRY ', - * 'IN LIST OF REFERENCE VALUE CHANGES' - RETURN - END IF -C ELEMENT DESCRIPTOR W/NEW REFERENCE VALUE -C FIND MATCH FOR CURRENT DESCRIPTOR - IQ = INDEXB(KDESC(1,KARY(11))) - IF (IQ.LT.1) THEN - IERRTN = 22 - PRINT *,'ATTEMPTING TO ENTER NEW REFERENCE VALUE ', - * 'INTO TABLE B, BUT DESCRIPTOR DOES NOT EXIST IN ', - * 'CURRENT MODIFIED TABLE B' - RETURN - END IF - END IF - ELSE IF (KCLASS.EQ.4) THEN -C SET/RESET ASSOCIATED FIELD WIDTH - IF (ISTEP.EQ.3) THEN - KARY(27) = KSEG - END IF - ELSE IF (KCLASS.EQ.5) THEN -C SET TO PROCESS TEXT/ASCII DATA -C SET TO TEXT -C PROCESS TEXT - - KARY(2) = KARY(11) + KARY(18) - IF (ISTEP.EQ.3) THEN -C KSEG TELLS HOW MANY BYTES EACH ITERATION - IF (MOD(KSEG,4).NE.0) THEN - ITER = KSEG / 4 + 1 - ELSE - ITER = KSEG / 4 - END IF -C POINT AT CORRECT KDATA WORD - IF (ISECT3(3).NE.0) THEN -C COMPRESSED -C --------------------------------------------------- - CALL SBYTES(KBUFR,ZEROES,KARY(3),32,0,ITER) - KARY(3) = KARY(3) + KSEG * 8 -C - CALL SBYTE (KBUFR,KSEG*8,KARY(3),6) - KARY(3) = KARY(3) + 6 -C TEXT ENTRY BY SUBSET - DO 2000 M = 1, ISECT3(1) - JAY = KARY(3) -C NUMBER OF SUBSETS - DO 1950 KL = 1, ITER -C NUMBER OF WORDS - KK = KARY(2) + KL - 1 - IF (ISECT3(10).EQ.1) THEN - CALL W3AI38(KDATA(M,KK),4) - END IF - CALL SBYTE (KBUFR,KDATA(M,KK),JAY,32) - JAY = JAY + 32 - 1950 CONTINUE - KARY(3) = KARY(3) + KSEG * 8 - 2000 CONTINUE -C --------------------------------------------------- - ELSE -C NOT COMPRESSED - -C CALL SBYTE FOR EACH KDATA VALUE (4 CHARACTERS PER VALUE). -C AN ADDITIONAL CALL IS DONE IF HAVE A VALUE WITH LESS THAN -C 4 CHARACTERS. - NBIT = 32 - NLEFT = MOD(KSEG,4) - DO 3000 J=KARY(2),ITER+KARY(2)-1 - IF((J.EQ.(ITER+KARY(2)-1)).AND.(NLEFT.NE.0))THEN - NBIT = 8 * NLEFT - ENDIF - IF (ISECT3(10).NE.0) THEN - CALL W3AI38 (KDATA(I,J),4) - END IF - CALL SBYTE(KBUFR,KDATA(I,J),KARY(3),NBIT) - KARY(3) = KARY(3) + NBIT - 3000 CONTINUE - -C ADJUST FOR EXTRA WORDS - KARY(18) = KARY(18) + ITER - 1 - END IF - KARY(2) = KARY(2) + ITER - END IF - ELSE IF (KCLASS.EQ.6) THEN -C SET TO SKIP PROCESSING OF NEXT DESCRIPTOR -C IF IT IS NOT IN BUFR TABLE B -C DURING THE ENCODING PROCESS, THIS HAS NO MEANING -C ELIMINATE IN PROCESSING -C MOVE DESCRIPTOR LIST UP ONE POSITION AND RESTART -C PROCESSING AT SAME LOCATION. - KM = I - 1 - DO 9000 KL = I+1, NRDESC - KM = KM + 1 - KDESC(1,KM) = KDESC(1,KL) - 9000 CONTINUE - NRDESC = KM - RETURN 1 - END IF -C **************************************************************** - RETURN - END - SUBROUTINE FI8503(I,KDESC,NRDESC, - * ISECT3,IUNITD,KSEQ,KNUM,KLIST,IERRTN) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8503 EXPAND SEQUENCE DESCRIPTOR -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-12-03 -C -C ABSTRACT: HAVE ENCOUNTERED A SEQUENCE DESCRIPTOR. MUST PERFORM -C PROPER REPLACMENT OF DESCRIPTORS IN LINE. -C -C PROGRAM HISTORY LOG: -C 93-12-03 CAVANAUGH -C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE -C -C USAGE: CALL FI8503(I,KDESC,NRDESC, -C * ISECT3,IUNITD,KSEQ,KNUM,KLIST,IERRTN) -C INPUT ARGUMENT LIST: -C I - CURRENT POSITION IN DESCRIPTOR LIST -C KDESC - LIST OF DESCRIPTORS -C NRDESC - NUMBER OF DESCRIPTORS IN KDESC -C IUNITD - -C KSEQ - -C KNUM - -C KLIST - -C -C OUTPUT ARGUMENT LIST: -C I - CURRENT POSITION IN DESCRIPTOR LIST -C KDESC - MODIFIED LIST OF DESCRIPTORS -C NRDESC - NEW NUMBER OF DESCRIPTORS IN KDESC -C IERRTN - ERROR RETURN VALUE -C -C REMARKS: -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256 -C -C$$$ -C - INTEGER I - INTEGER KDESC(3,*) - INTEGER NRDESC - INTEGER ISECT3(*) - INTEGER IUNITD - INTEGER KSEQ(*) - INTEGER KNUM(*) - INTEGER KLIST(300,*) - INTEGER IERRTN - INTEGER ITAIL(1600) -C INTEGER IHOLD(200) -C - SAVE -C -C **************************************************************** - IERRTN = 0 -C READ IN TABLE D IF NEEDED - IF (ISECT3(9).EQ.0) THEN - CALL FI8513 (IUNITD,ISECT3,KSEQ, - * KNUM,KLIST,IERRTN) - IF (IERRTN.NE.0) THEN -C PRINT *,'EXIT FI8503A' - RETURN - END IF - END IF -C HAVE TABLE D -C -C FIND MATCHING SEQUENCE DESCRIPTOR - DO 100 L = 1, ISECT3(9) - IF (KDESC(1,I).EQ.KSEQ(L)) THEN -C JEN - DELETE NEXT PRINT LINE -C PRINT *,'FOUND ',KDESC(1,I) -C HAVE A MATCH - GO TO 200 - END IF - 100 CONTINUE - IERRTN = 12 - RETURN - 200 CONTINUE -C REPLACE SEQUENCE DESCRIPTOR WITH IN LINE SEQUENCE - IPUT = I -C SAVE TAIL - ISTART = I + 1 - KK = 0 - DO 400 IJ = ISTART, NRDESC - KK = KK + 1 - ITAIL(KK) = KDESC(1,IJ) - 400 CONTINUE -C INSERT SEQUENCE OF DESCRIPTORS AT -C CURRENT LOCATION - KL = 0 - DO 600 KQ = 1, KNUM(L) - KDESC(1,IPUT) = KLIST(L,KQ) - IPUT = IPUT + 1 - 600 CONTINUE - -C RESTORE TAIL - DO 800 KL = 1, KK - KDESC(1,IPUT) = ITAIL(KL) - IPUT = IPUT + 1 - 800 CONTINUE -C RESET NUMBER OF DESCRIPTORS IN KDESC - NRDESC = IPUT - 1 -C JEN - DELETE NEXT PRINT LINE -C PRINT *,' NRDESC IS ',NRDESC - -C RESET CURRENT POSITION & RETURN - RETURN - END - SUBROUTINE FI8505(MIF,MDESC,NR,IERRTN) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8505 CONVERT DESCRIPTORS FXY TO DECIMAL -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-12-03 -C -C ABSTRACT: CONSTRUCT DECIMAL DESCRIPTOR VALUES FROM F X AND Y SEGMENTS -C -C PROGRAM HISTORY LOG: -C 93-12-03 CAVANAUGH -C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE -C YY-MM-DD MODIFIER2 DESCRIPTION OF CHANGE -C -C USAGE: CALL FI8505(MIF,MDESC,NR,IERRTN) -C INPUT ARGUMENT LIST: -C MIF - INPUT FLAG -C MDESC - LIST OF DESCRIPTORS IN F X Y FORM -C NR - NUMBER OF DESCRIPTORS IN MDESC -C -C OUTPUT ARGUMENT LIST: -C MDESC - LIST OF DESCRIPTORS IN DECIMAL FORM -C IERRTN - ERROR RETURN VALUE -C -C REMARKS: -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256 -C -C$$$ -C - INTEGER MDESC(3,*), NR -C - SAVE -C - IF (NR.EQ.0) THEN - IERRTN = 14 - RETURN - END IF -C - DO 100 I = 1, NR - MDESC(1,I) = MDESC(1,I) * 16384 + MDESC(2,I) * 256 - * + MDESC(3,I) -C JEN - DELETE NEXT PRINT LINE -C PRINT *,MDESC(2,I),MDESC(3,I),' BECOMES ',MDESC(1,I) - 100 CONTINUE - MIF = 1 - RETURN - END - SUBROUTINE FI8506(ISTEP,ISECT3,KARY,JDESC,NEWNR,KDESC,NRDESC, - * LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KWIDTH,KRFVSW,NEWRFV, - * KSEQ,KNUM,KLIST,IBFSIZ, - * KDATA,KBUFR,IERRTN,INDEXB) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8506 PROCESS DATA IN NON-COMPRESSED FORMAT -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-12-03 -C -C ABSTRACT: PROCESS DATA INTO NON-COMPRESSED FORMAT FOR INCLUSION INTO -C SECTION 4 OF THE BUFR MESSAGE -C -C PROGRAM HISTORY LOG: -C 93-12-03 CAVANAUGH -C 94-03-24 J. HOPPA - CHANGED THE INNER LOOP FROM A DO LOOP TO A -C GOTO LOOP SO NRDESC ISN'T A SET VALUE. -C - CORRECTED A VALUE IN THE CALL TO FI8503. -C 94-03-31 J. HOPPA - CORRECTED AN ERROR IN SENDING THE SUBSET -C NUMBER RATHER THAN THE DESCRIPTOR NUMBER -C TO SUBROUTINE FI8501. -C - ADDED THE SUBSET NUMBER TO THE FI8501 -C PARAMETER LIST. -C 94-04015 J. HOPPA - ADDED LINE TO KEEP THE PARAMETER POINTER -C KARY(2) UP TO DATE. THIS VARIABLE IS USED -C IN SUBROUTINE FI8502. -C - ADDED KBUFR TO THE PARAMETER LIST IN THE CALL -C TO SUBROUTINE FI8502. -C - CORRECTED AN INFINITE LOOP WHEN HAVE AN -C OPERATOR DESCRIPTOR THAT WAS CAUSED BY -C A CORRECTION MADE 94-03-24 -C 94-04-20 J. HOPPA - ADDED K TO CALL TO SUBROUTINE W3FI01 -C 94-04-29 J. HOPPA - CHANGED N TO KARY(11) AND K TO KARY(2) -C - REMOVED K AND N FROM THE CALL TO FI8501 -C 94-05-03 J. HOPPA - ADDED AN INCREMENT TO KARY(11) TO PREVENT -C AND INFINITE LOOP WHEN HAVE A MISSING VALUE -C 94-05-18 J. HOPPA - CHANGED SO INCREMENTS KARY(2) AFTER EACH -C CALL TO SBYTE AND DELETED -C KARY(2) = KARY(11) + KARY(18) -C -C -C USAGE CALL FI8506(ISTEP,ISECT3,KARY,JDESC,NEWNR,KDESC,NRDESC, -C * LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KWIDTH,KRFVSW,NEWRFV, -C * KSEQ,KNUM,KLIST, -C * KDATA,KBUFR,IERRTN,INDEXB) -C -C INPUT ARGUMENT LIST: -C ISTEP - -C ISECT3 - -C KARY - -C JDESC - -C NEWNR - -C KDESC - -C NRDESC - -C LDESC - -C ANAME - -C AUNITS - -C KSCALE - -C KRFVAL - -C KWIDTH - -C KRFVSW - -C NEWRFV - -C KSEQ - -C KNUM - -C KLIST - -C -C OUTPUT ARGUMENT LIST: -C KDATA - -C KBUFR - -C IERRTN - -C -C REMARKS: -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256 -C -C$$$ -C -C ------------------------------------------------------------- - INTEGER ISTEP,INDEXB(*) - INTEGER KBUFR(*) - INTEGER ISECT3(*) - INTEGER KARY(*) - INTEGER NRDESC,NEWNR,KDESC(3,*),JDESC(3,*) - INTEGER KDATA(500,*) - INTEGER KRFVSW(*),KSCALE(*),KRFVAL(*),KWIDTH(*),NEWRFV(*) - INTEGER IERRTN - INTEGER LDESC(*) - INTEGER IBITS(32) - INTEGER MISG - INTEGER KSEQ(*),KNUM(*),KLIST(300,*) - CHARACTER*40 ANAME(*) - CHARACTER*25 AUNITS(*) - CHARACTER*9 CCITT - LOGICAL TEXT -C - SAVE -C ------------------------------------------------------------- - DATA IBITS / 1, 3, 7, 15, - * 31, 63, 127, 255, - * 511, 1023, 2047, 4095, - * 8191, 16383, 32767, 65535, - * Z'0001FFFF',Z'0003FFFF',Z'0007FFFF',Z'000FFFFF', - * Z'001FFFFF',Z'003FFFFF',Z'007FFFFF',Z'00FFFFFF', - * Z'01FFFFFF',Z'03FFFFFF',Z'07FFFFFF',Z'0FFFFFFF', - * Z'1FFFFFFF',Z'3FFFFFFF',Z'7FFFFFFF',Z'FFFFFFFF'/ - DATA CCITT /'CCITT IA5'/ - DATA MISG /99999/ -C ------------------------------------------------------------- - KEND = IBFSIZ * 8 - 32 -C ********************************************** -C * * -C * PROCESS AS NON-COMPRESSED MESSAGE * -C * * -C * I POINTS TO SUBSET * -C * N POINTS TO DESCRIPTOR * -C * K ADJUSTS N TO CORRECT DATA ENTRY * -C * * -C ********************************************** - DO 4500 I = 1, ISECT3(1) -C OUTER LOOP FOR EACH SUBSET -C DO UNTIL ALL DESCRIPTORS HAVE -C BEEN PROCESSED -C SET ADDED BIT FOR WIDTH TO 0 - KARY(26) = 0 -C SET ASSOCIATED FIELD WIDTH TO 0 - KARY(27) = 0 - KARY(18) = 0 -C IF MESSAGE CONTAINS DELAYED REPLICATION -C WE NEED TO EXPAND THE ORIGINAL DESCRIPTOR LIST -C TO MATCH THE INPUT DATA. -C START WITH JDESC - IF (KARY(4).NE.0) THEN - DO 100 M = 1, NEWNR - KDESC(1,M) = JDESC(1,M) - 100 CONTINUE - NRDESC = NEWNR - END IF - KARY(11) = 1 - KARY(2) = 1 - 4300 CONTINUE - IF(KARY(11).GT.NRDESC) GOTO 4305 -C INNER LOOP FOR PARAMETER - 4200 CONTINUE -C KARY(2) = KARY(11) + KARY(18) -C PRINT *,'LOOKING AT DESCRIPTOR',KARY(11), -C * KDESC(1,KARY(11)), -C * KARY(2),KDATA(I,KARY(2)) -C -C PROCESS ONE DESCRIPTOR AT A TIME -C -C ISOLATE TABLE -C - KFUNC = KDESC(1,KARY(11)) / 16384 -C ISOLATE CLASS - KCLASS = MOD(KDESC(1,KARY(11)),16384) / 256 - KSEG = MOD(KDESC(1,KARY(11)),256) - IF (KFUNC.EQ.1) THEN -C REPLICATION DESCRIPTOR - CALL FI8501(KARY,ISTEP,KCLASS,KSEG,IDATA,RDATA, - * KDATA,I,KDESC,NRDESC,IERRTN) - IF (IERRTN.NE.0) THEN - RETURN - END IF - GO TO 4200 - ELSE IF (KFUNC.EQ.2) THEN -C OPERATOR DESCRIPTOR - CALL FI8502(*4200,KBUFR,KCLASS,KSEG, - * KDESC,NRDESC,I,ISTEP, - * KARY,KDATA,ISECT3,KRFVSW,NEWRFV,LDESC,IERRTN,INDEXB) - IF (IERRTN.NE.0) THEN - RETURN - END IF - KARY(11) = KARY(11) + 1 - GO TO 4300 - ELSE IF (KFUNC.EQ.3) THEN -C SEQUENCE DESCRIPTOR - CALL FI8503(KARY(11),KDESC,NRDESC, - * ISECT3,IUNITD,KSEQ,KNUM,KLIST,IERRTN) - IF (IERRTN.NE.0) THEN - RETURN - END IF - GO TO 4200 - END IF -C FALL THRU WITH ELEMENT DESCRIPTOR -C FIND MATCHING TABLE B ENTRY - LK = INDEXB(KDESC(1,KARY(11))) - IF (LK.LT.1) THEN -C FALL THRU WITH NO MATCHING B ENTRY - PRINT *,'FI8506 3800',KARY(11),KDESC(1,KARY(11)), - * NRDESC,LK,LDESC(LK) - IERRTN = 2 - RETURN - END IF -C - IF (AUNITS(LK).EQ.CCITT) THEN - TEXT = .TRUE. - ELSE - TEXT = .FALSE. - END IF -C - IF (TEXT) THEN - JWIDE = KWIDTH(LK) - 3775 CONTINUE - IF (JWIDE.GT.32) THEN - IF(ISECT3(10).NE.0) THEN - CALL W3AI38 (KDATA(I,KARY(2)),4) - END IF - IF ((KARY(3)+32).GT.KEND) THEN - IERRTN = 1 - RETURN - END IF - CALL SBYTE (KBUFR,KDATA(I,KARY(2)),KARY(3),32) - KARY(3) = KARY(3) + 32 -C ADD A WORD HERE ONLY - KARY(18) = KARY(18) + 1 -C KARY(2) = KARY(11) + KARY(18) - KARY(2) = KARY(2) + 1 - JWIDE = JWIDE - 32 - GO TO 3775 - ELSE IF (JWIDE.EQ.32) THEN - IF(ISECT3(10).NE.0) THEN - CALL W3AI38 (KDATA(I,KARY(2)),4) - END IF - IF ((KARY(3)+32).GT.KEND) THEN - IERRTN = 1 - RETURN - END IF - CALL SBYTE (KBUFR,KDATA(I,KARY(2)),KARY(3),32) - KARY(3) = KARY(3) + 32 - KARY(2) = KARY(2) + 1 - JWIDE = JWIDE - 32 - ELSE IF (JWIDE.GT.0) THEN - IF(ISECT3(10).NE.0) THEN - CALL W3AI38 (KDATA(I,KARY(2)),4) - END IF - IF ((KARY(3)+JWIDE).GT.KEND) THEN - IERRTN = 1 - RETURN - END IF - CALL SBYTE (KBUFR,KDATA(I,KARY(2)),KARY(3),JWIDE) - KARY(3) = KARY(3) + JWIDE - KARY(2) = KARY(2) + 1 - END IF - ELSE -C NOT TEXT - IF (KARY(27).NE.0.AND.KDESC(1,KARY(11)).NE.7957) THEN -C ENTER ASSOCIATED FIELD - IF ((KARY(3)+KARY(27)).GT.KEND) THEN - IERRTN = 1 - RETURN - END IF - CALL SBYTE (KBUFR,KDATA(I,KARY(2)),KARY(3), - * KARY(27)) - KARY(3) = KARY(3) + KARY(27) - KARY(18) = KARY(18) + 1 -C KARY(2) = KARY(11) + KARY(18) - KARY(2) = KARY(2) + 1 - END IF -C - JWIDE = KWIDTH(LK) + KARY(26) - IF (KDATA(I,KARY(2)).EQ.MISG) THEN -C MISSING DATA, SET ALL BITS ON - IF ((KARY(3)+JWIDE).GT.KEND) THEN - IERRTN = 1 - RETURN - END IF - CALL SBYTE (KBUFR,IBITS(JWIDE),KARY(3),JWIDE) - KARY(3) = KARY(3) + JWIDE - KARY(2) = KARY(2) + 1 - KARY(11) = KARY(11) + 1 - GO TO 4300 - END IF -C CAN DATA BE CONTAINED IN SPECIFIED -C BIT WIDTH, IF NOT - ERROR - IF (KDATA(I,KARY(2)).GT.IBITS(JWIDE)) THEN - IERRTN = 1 - RETURN - END IF -C ADJUST WITH REFERENCE VALUE - IF (KRFVSW(LK).EQ.0) THEN - JRV = KRFVAL(LK) - ELSE - JRV = NEWRFV(LK) - END IF -C - KDATA(I,KARY(2)) = KDATA(I,KARY(2)) - JRV -C IF NEW VALUE IS NEGATIVE - ERROR - IF (KDATA(I,KARY(2)).LT.0) THEN - IERRTN = 11 - RETURN - END IF -C PACK DATA INTO OUTPUT ARRAY - IF ((KARY(3)+JWIDE).GT.KEND) THEN - IERRTN = 1 - RETURN - END IF - CALL SBYTE (KBUFR,KDATA(I,KARY(2)),KARY(3),JWIDE) - KARY(2) = KARY(2) + 1 - KARY(3) = KARY(3) + JWIDE - END IF - KARY(11) = KARY(11) + 1 - GOTO 4300 - 4305 CONTINUE -C RESET ALL REFERENCE VALUES TO ORIGINAL - DO 4310 LX = 1, ISECT3(8) - KRFVSW(LX) = 0 - 4310 CONTINUE - 4500 CONTINUE - RETURN - END - SUBROUTINE FI8508(ISTEP,IUNITB,IDATA,KDESC,NRDESC,ATEXT,KSUB,KARY, - * KDATA,LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KRFVSW,ISECT3, - * KWIDTH,KASSOC,IUNITD,KSEQ,KNUM,KLIST,IERRTN,INDEXB) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8508 COMBINE INTEGER/TEXT DATA -C PRGMMR: CAVANAUGH W/NMC42 DATE: 93-12-03 -C -C ABSTRACT: CONSTRUCT INTEGER SUBSET FROM REAL AND TEXT DATA -C -C PROGRAM HISTORY LOG: -C 93-12-03 CAVANAUGH -C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE -C 94-03-31 HOPPA ADDED KSUB TO FI8501 PARAMETER LIST. -C 94-04-18 HOPPA ADDED DUMMY VARIABLE IDUM TO FI8502 PARAMETER -C LIST. -C 94-04-20 HOPPA ADDED DUMMY VARIABLE LL TO FI8501 PARAMETER -C LIST. -C 94-04-29 HOPPA - CHANGED I TO KARY(11) -C - ADDED A KARY(2) ASSIGNMENT SO HAVE SOMETHING -C TO PASS TO SUBROUTINES ** TEST THIS ** -C - REMOVED I AND LL FROM CALL TO FI8501 -C 94-05-13 HOPPA - ADDED CODE TO CALCULATE KWORDS WHEN KFUNC=2 -C 94-05-18 HOPPA - DELETED KARY(2) ASSIGNMENT -C -C -C USAGE: CALL FI8508(ISTEP,IUNITB,IDATA,KDESC,NRDESC,ATEXT,KSUB,KARY, -C * KDATA,LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KRFVSW,ISECT3, -C * KWIDTH,KASSOC,IUNITD,KSEQ,KNUM,KLIST,IERRTN,INDEXB) -C INPUT ARGUMENT LIST: -C ISTEP - -C IUNITB - UNIT NUMBER OF DEVICE CONTAINING TABLE B -C IDATA - INTEGER WORKING ARRAY -C KDESC - EXPANDED DESCRIPTOR SET -C NRDESC - NUMBER OF DESCRIPTORS IN KDESC -C ATEXT - TEXT DATA FOR CCITT IA5 AND TEXT OPERATOR FIELDS -C KSUB - SUBSET NUMBER -C KARY - WORKING ARRAY -C ISECT3 - -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KDATA - ARRAY CONTAINING INTEGER SUBSETS -C LDESC - LIST OF TABLE B DESCRIPTORS (DECIMAL) -C ANAME - LIST OF DESCRIPTOR NAMES -C AUNITS - UNITS FOR EACH DESCRIPTOR -C KSCALE - BASE 10 SCALE FACTOR FOR EACH DESCRIPTOR -C KRFVAL - REFERENCE VALUE FOR EACH DESCRIPTOR -C KRFVSW - -C NEWRFV - -C KWIDTH - STANDARD BIT WIDTH TO CONTAIN EACH VALUE -C FOR SPECIFIC DESCRIPTOR -C KASSOC - -C IERRTN - ERROR RETURN FLAG -C -C -C REMARKS: -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256 -C -C$$$ -C TAKE EACH NON-TEXT ENTRY OF SECTION 2 -C ACCEPT IT -C -C TAKE EACH TEXT ENTRY -C INSERT INTO INTEGER ARRAY, -C ADDING FULL WORDS AS NECESSARY -C MAKE SURE ANY LAST WORD HAS TEXT DATA -C RIGHT JUSTIFIED -C --------------------------------------------------------------------- -C PASS BACK CONVERTED ENTRY TO LOCATION -C SPECIFIED BY USER -C -C REFERENCE VALUE WILL BE APPLIED DURING -C ENCODING OF MESSAGE -C --------------------------------------------------------------------- - INTEGER IUNITB,IUNITD,KSEQ(*),KNUM(*),KLIST(300,*) - INTEGER KDESC(3,*),NRDESC,KASSOC(*) - INTEGER IDATA(*),ISTEP - INTEGER KDATA(500,*) - INTEGER KARY(*),INDEXB(*) - INTEGER KSUB,K - INTEGER LDESC(*) - INTEGER IBITS(32) - INTEGER KSCALE(*) - INTEGER KRFVAL(*) - INTEGER KRFVSW(*) - INTEGER KWIDTH(*) - INTEGER MISG - INTEGER MPTR,ISECT3(*) - CHARACTER*1 ATEXT(*) - CHARACTER*1 AHOLD1(256) - INTEGER IHOLD4(64) - CHARACTER*25 AUNITS(*) - CHARACTER*25 CCITT - CHARACTER*40 ANAME(*) -C - SAVE -C - EQUIVALENCE (AHOLD1,IHOLD4) -C -C ===================================== - DATA CCITT /'CCITT IA5 '/ - DATA IBITS / 1, 3, 7, 15, - * 31, 63, 127, 255, - * 511, 1023, 2047, 4095, - * 8191, 16383, 32767, 65535, - * Z'0001FFFF',Z'0003FFFF',Z'0007FFFF',Z'000FFFFF', - * Z'001FFFFF',Z'003FFFFF',Z'007FFFFF',Z'00FFFFFF', - * Z'01FFFFFF',Z'03FFFFFF',Z'07FFFFFF',Z'0FFFFFFF', - * Z'1FFFFFFF',Z'3FFFFFFF',Z'7FFFFFFF',Z'FFFFFFFF'/ - DATA MISG /99999/ -C - IF (ISECT3(8).EQ.0) THEN - CALL FI8512(IUNITB,ISECT3,KDESC,NRDESC,KARY,IERRTN, - * LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KWIDTH,KRFVSW, - * IUNITD,KSEQ,KNUM,KLIST,INDEXB) - IF (IERRTN.NE.0) THEN - RETURN - END IF - END IF -C HAVE TABLE B AVAILABLE NOW -C -C LOOK AT EACH DATA ENTRY -C CONVERT NON TEXT -C MOVE TEXT -C - KPOS = 0 - MPTR = 0 - KARY(11) = 0 - 1000 CONTINUE - KARY(11) = KARY(11) + 1 - IF (KARY(11).GT.NRDESC) GO TO 1500 -C -C RE-ENTRY POINT FOR REPLICATION AND SEQUENCE DESCR'S -C - 500 CONTINUE - KFUNC = KDESC(1,KARY(11)) / 16384 - KL = KDESC(1,KARY(11)) - 16384 * KFUNC - KCLASS = KL / 256 - KSEG = MOD(KL,256) -C KARY(2) = KARY(11) + KARY(18) - IF (KFUNC.EQ.1) THEN -C REPLICATION DESCRIPTOR - CALL FI8501(KARY,ISTEP,KCLASS,KSEG,IDATA,RDATA, - * KDATA,KSUB,KDESC,NRDESC,IERRTN) - IF (IERRTN.NE.0) THEN - RETURN - END IF - GO TO 500 - ELSE IF (KFUNC.EQ.2) THEN - IF (KCLASS.EQ.5) THEN -C HANDLE TEXT OPERATORS -CC - KAVAIL = IDATA(KARY(11)) -C UNUSED POSITIONS IN LAST WORD - KREM = MOD(KAVAIL,4) - IF (KREM.NE.0) THEN - KWORDS = KAVAIL / 4 + 1 - ELSE - KWORDS = KAVAIL / 4 - END IF -CC - JWIDE = KSEG * 8 - GO TO 1200 - END IF - ELSE IF (KFUNC.EQ.3) THEN -C SEQUENCE DESCRIPTOR - ERROR - CALL FI8503(KARY(11),KDESC,NRDESC, - * ISECT3,IUNITD,KSEQ,KNUM,KLIST,IERRTN) - IF (IERRTN.NE.0) THEN - RETURN - END IF - GO TO 500 - ELSE -C -C FIND MATCHING DESCRIPTOR -C - K = INDEXB(KDESC(1,KARY(11))) - IF (K.LT.1) THEN - PRINT *,'FI8508-NOT FOUND',KARY(11),KDESC(1,KARY(11)), - * ISECT3(8),LDESC(K) - IERRTN = 2 - RETURN - END IF -C HAVE MATCHING DESCRIPTOR - 200 CONTINUE - IF (AUNITS(K)(1:9).NE.CCITT(1:9)) THEN - IF (KARY(27).NE.0) THEN - IF (KDESC(1,KARY(11)).LT.7937.OR. - * KDESC(1,KARY(11)).GT.8191) THEN -C ASSOC FLD FOR ALL BUT CLASS 31 - KPOS = KPOS + 1 - IF (KASSOC(KARY(11)).EQ.IBITS(KARY(27))) THEN - KDATA(KSUB,KPOS) = MISG - ELSE - KDATA(KSUB,KPOS) = KASSOC(KARY(11)) - END IF - END IF - END IF -C IF NOT MISSING DATA - IF (IDATA(KARY(11)).EQ.99999) THEN - KPOS = KPOS + 1 - KDATA(KSUB,KPOS) = MISG - ELSE -C PROCESS INTEGER VALUES - KPOS = KPOS + 1 - KDATA(KSUB,KPOS) = IDATA(KARY(11)) - END IF - ELSE -C PROCESS TEXT -C NUMBER OF BYTES REQUIRED BY TABLE B - KREQ = KWIDTH(K) / 8 -C NUMBER BYTES AVAILABLE IN ATEXT - KAVAIL = IDATA(KARY(11)) -C UNUSED POSITIONS IN LAST WORD - KREM = MOD(KAVAIL,4) - IF (KREM.NE.0) THEN - KWORDS = KAVAIL / 4 + 1 - ELSE - KWORDS = KAVAIL / 4 - END IF -C MOVE TEXT CHARACTERS TO KDATA - JWIDE = KWIDTH(K) - GO TO 1200 - END IF - END IF - GO TO 1000 - 1200 CONTINUE - 300 CONTINUE - NPTR = MPTR - DO 400 IJ = 1, KWORDS - KPOS = KPOS + 1 - CALL GBYTE(ATEXT,KDATA(KSUB,KPOS),NPTR,32) - NPTR = NPTR + 32 - 400 CONTINUE - MPTR = MPTR + JWIDE - GO TO 1000 - 1500 CONTINUE - RETURN - END - SUBROUTINE FI8509(ISTEP,IUNITB,RDATA,KDESC,NRDESC,ATEXT,KSUB,KARY, - * KDATA,LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KRFVSW,ISECT3, - * KWIDTH,KASSOC,IUNITD,KSEQ,KNUM,KLIST,IERRTN,INDEXB) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8509 CONVERT REAL/TEXT INPUT TO INTEGER -C PRGMMR: CAVANAUGH W/NMC42 DATE: 93-12-03 -C -C ABSTRACT: CONSTRUCT INTEGER SUBSET FROM REAL AND TEXT DATA -C -C PROGRAM HISTORY LOG: -C 93-12-03 CAVANAUGH -C 94-03-31 HOPPA ADDED KSUB TO THE FI8501 PARAMETER LIST. -C 94-04-18 HOPPA ADDED DUMMY VARIABLE IDUM TO FI8502 PARAMETER -C LIST. -C 94-04-20 HOPPA ADDED DUMMY VARIABLE LL TO FI8501 PARAMETER -C LIST. -C 94-04-29 HOPPA - CHANGED I TO KARY(11) -C - ADDED A KARY(2) ASSIGNMENT SO HAVE SOMETHING -C TO PASS TO SUBROUTINES ** TEST THIS ** -C - REMOVED I AND LL FROM CALL TO FI8501 -C 94-05-18 HOPPA - DELETED KARY(2) ASSIGNMENT -C -C USAGE: CALL FI8509(ISTEP,IUNITB,RDATA,KDESC,NRDESC,ATEXT,KSUB,KARY, -C * KDATA,LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KRFVSW,ISECT3, -C * KWIDTH,KASSOC,IUNITD,KSEQ,KNUM,KLIST,IERRTN,INDEXB) -C INPUT ARGUMENT LIST: -C IUNITB - UNIT NUMBER OF DEVICE CONTAINING TABLE B -C RDATA - REAL WORKING ARRAY -C KDESC - EXPANDED DESCRIPTOR SET -C NRDESC - NUMBER OF DESCRIPTORS IN KDESC -C ATEXT - TEXT DATA FOR CCITT IA5 AND TEXT OPERATOR FIELDS -C KSUB - SUBSET NUMBER -C KARY - WORKING ARRAY -C ISECT3 - -C IUNITD - -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KDATA - ARRAY CONTAINING INTEGER SUBSETS -C LDESC - LIST OF TABLE B DESCRIPTORS (DECIMAL) -C ANAME - LIST OF DESCRIPTOR NAMES -C AUNITS - UNITS FOR EACH DESCRIPTOR -C KSCALE - BASE 10 SCALE FACTOR FOR EACH DESCRIPTOR -C KRFVAL - REFERENCE VALUE FOR EACH DESCRIPTOR -C KRFVSW - -C NEWRFV - -C KASSOC - -C KWIDTH - STANDARD BIT WIDTH TO CONTAIN EACH VALUE -C FOR SPECIFIC DESCRIPTOR -C IERRTN - ERROR RETURN FLAG -C KSEG - -C KNUM - -C KLIST - -C -C REMARKS: -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256 -C -C$$$ -C TAKE EACH NON-TEXT ENTRY OF SECTION 2 -C SCALE IT -C ROUND IT -C CONVERT TO INTEGER -C -C TAKE EACH TEXT ENTRY -C INSERT INTO INTEGER ARRAY, -C ADDING FULL WORDS AS NECESSARY -C MAKE SURE ANY LAST WORD HAS TEXT DATA -C RIGHT JUSTIFIED -C PASS BACK CONVERTED ENTRY TO LOCATION -C SPECIFIED BY USER -C -C REFERENCE VALUE WILL BE APPLIED DURING -C ENCODING OF MESSAGE -C --------------------------------------------------------------------- - REAL RDATA(*) - INTEGER IUNITB,IUNITD,KSEQ(*),KNUM(*),KLIST(300,*) - INTEGER IBITS(32),INDEXB(*) - INTEGER KDESC(3,*),ISTEP - INTEGER KDATA(500,*) - INTEGER KASSOC(*) - INTEGER KARY(*) - INTEGER KSUB,K - INTEGER LDESC(*) - INTEGER NRDESC - INTEGER IERRTN - INTEGER KSCALE(*) - INTEGER KRFVAL(*) - INTEGER KRFVSW(*) - INTEGER KWIDTH(*) - INTEGER MPTR,ISECT3(*) - INTEGER MISG - CHARACTER*1 AHOLD1(256) - INTEGER IHOLD4(64) - CHARACTER*1 ATEXT(*) - CHARACTER*25 AUNITS(*) - CHARACTER*25 CCITT - CHARACTER*40 ANAME(*) -C - SAVE -C ===================================== - EQUIVALENCE (AHOLD1,IHOLD4) -C - DATA IBITS/ 1, 3, 7, 15, - * 31, 63, 127, 255, - * 511, 1023, 2047, 4095, - * 8191, 16383, 32767, 65535, - * Z'0001FFFF',Z'0003FFFF',Z'0007FFFF',Z'000FFFFF', - * Z'001FFFFF',Z'003FFFFF',Z'007FFFFF',Z'00FFFFFF', - * Z'01FFFFFF',Z'03FFFFFF',Z'07FFFFFF',Z'0FFFFFFF', - * Z'1FFFFFFF',Z'3FFFFFFF',Z'7FFFFFFF',Z'FFFFFFFF'/ -C - DATA CCITT /'CCITT IA5 '/ - DATA MISG /99999/ -C ===================================== -C - IF (ISECT3(8).EQ.0) THEN - CALL FI8512(IUNITB,ISECT3,KDESC,NRDESC,KARY,IERRTN, - * LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KWIDTH,KRFVSW, - * IUNITD,KSEQ,KNUM,KLIST,INDEXB) - IF (IERRTN.NE.0) THEN - RETURN - END IF - END IF -C HAVE TABLE B AVAILABLE NOW -C -C LOOK AT EACH DATA ENTRY -C CONVERT NON TEXT -C MOVE TEXT -C - KPOS = 0 - MPTR = 0 - KARY(11) = 0 - 1000 CONTINUE - KARY(11) = KARY(11) + 1 - IF (KARY(11).GT.NRDESC) GO TO 1500 -C RE-ENRY POINT FOR REPLICATION AND -C SEQUENCE DESCRIPTORS - 500 CONTINUE - KFUNC = KDESC(1,KARY(11)) / 16384 - KL = KDESC(1,KARY(11)) - 16384 * KFUNC - KCLASS = KL / 256 - KSEG = MOD(KL,256) -C KARY(2) = KARY(11) + KARY(18) - IF (KFUNC.EQ.1) THEN -C REPLICATION DESCRIPTOR - CALL FI8501(KARY,ISTEP,KCLASS,KSEG,IDATA,RDATA, - * KDATA,KSUB,KDESC,NRDESC,IERRTN) - IF (IERRTN.NE.0) THEN - RETURN - END IF - GO TO 500 - ELSE IF (KFUNC.EQ.2) THEN -C HANDLE OPERATORS - IF (KCLASS.EQ.5) THEN -C NUMBER BYTES AVAILABLE IN ATEXT - KAVAIL = RDATA(KARY(11)) -C UNUSED POSITIONS IN LAST WORD - KREM = MOD(KAVAIL,4) - IF (KREM.NE.0) THEN - KWORDS = KAVAIL / 4 + 1 - ELSE - KWORDS = KAVAIL / 4 - END IF - JWIDE = KSEG * 8 - GO TO 1200 - ELSE IF (KCLASS.EQ.2) THEN - IF (KSEG.EQ.0) THEN - KARY(9) = 0 - ELSE - KARY(9) = KSEG - 128 - END IF - GO TO 1200 - END IF - ELSE IF (KFUNC.EQ.3) THEN -C SEQUENCE DESCRIPTOR - ERROR - CALL FI8503(KDESC,NRDESC, - * ISECT3,IUNITD,KSEQ,KNUM,KLIST,IERRTN) - IF (IERRTN.NE.0) THEN - RETURN - END IF - GO TO 500 - ELSE -C -C FIND MATCHING DESCRIPTOR -C - K = INDEXB(KDESC(1,KARY(11))) - IF (K.LT.1) THEN - IERRTN = 2 -C PRINT *,'FI8509 - IERRTN = 2' - RETURN - END IF -C HAVE MATCHING DESCRIPTOR - 200 CONTINUE - IF (AUNITS(K)(1:9).NE.CCITT(1:9)) THEN - IF (KARY(27).NE.0) THEN - IF (KDESC(1,KARY(11)).LT.7937.OR. - * KDESC(1,KARY(11)).GT.8191) THEN -C ASSOC FLD FOR ALL BUT CLASS 31 - KPOS = KPOS + 1 - IF (KASSOC(KARY(11)).EQ.IBITS(KARY(27))) THEN - KDATA(KSUB,KPOS) = MISG - ELSE - KDATA(KSUB,KPOS) = KASSOC(KARY(11)) - END IF - END IF - END IF -C IF NOT MISSING DATA - IF (RDATA(KARY(11)).EQ.99999.) THEN - KPOS = KPOS + 1 - KDATA(KSUB,KPOS) = MISG - ELSE -C PROCESS REAL VALUES - IF (KSCALE(K).NE.0) THEN -C SCALING ALLOWING FOR CHANGE SCALE - SCALE = 10. **(IABS(KSCALE(K)) + KARY(9)) - IF (KSCALE(K).LT.0) THEN - RDATA(KARY(11)) = RDATA(KARY(11)) / SCALE - ELSE - RDATA(KARY(11)) = RDATA(KARY(11)) * SCALE - END IF - END IF -C PERFORM ROUNDING - RDATA(KARY(11)) = RDATA(KARY(11)) + - * SIGN(0.5,RDATA(KARY(11))) -C CONVERT TO INTEGER - KPOS = KPOS + 1 - KDATA(KSUB,KPOS) = RDATA(KARY(11)) -C - END IF - ELSE -C PROCESS TEXT -C NUMBER OF BYTES REQUIRED BY TABLE B - KREQ = KWIDTH(K) / 8 -C NUMBER BYTES AVAILABLE IN ATEXT - KAVAIL = RDATA(KARY(11)) -C UNUSED POSITIONS IN LAST WORD - KREM = MOD(KAVAIL,4) - IF (KREM.NE.0) THEN - KWORDS = KAVAIL / 4 + 1 - ELSE - KWORDS = KAVAIL / 4 - END IF -C MOVE TEXT CHARACTERS TO KDATA - JWIDE = KWIDTH(K) - GO TO 1200 - END IF - END IF - GO TO 1000 - 1200 CONTINUE - 300 CONTINUE - NPTR = MPTR - DO 400 IJ = 1, KWORDS - KPOS = KPOS + 1 - CALL GBYTE(ATEXT,KDATA(KSUB,KPOS),NPTR,32) - NPTR = NPTR + 32 - 400 CONTINUE - MPTR = MPTR + JWIDE - GO TO 1000 - 1500 CONTINUE -C DO 2000 I = 1, KPOS -C2000 CONTINUE - RETURN - END - SUBROUTINE FI8511(ISECT3,KARY,JIF,JDESC,NEWNR, - * KIF,KDESC,NRDESC,IERRTN) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8511 REBUILD KDESC FROM JDESC -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-12-03 -C -C ABSTRACT: CONSTRUCT WORKING DESCRIPTOR LIST FROM LIST OF DESCRIPTORS -C IN SECTION 3. -C -C PROGRAM HISTORY LOG: -C 93-12-03 CAVANAUGH -C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE -C -C USAGE: CALL FI8511(ISECT3,KARY,JIF,JDESC,NEWNR, -C * KIF,KDESC,NRDESC,IERRTN) -C INPUT ARGUMENT LIST: -C IUNITD - UNIT NUMBER OF TABLE D -C ISECT3 - -C KARY - UTILITY - ARRAY SEE MAIN ROUTINE -C JIF - DESCRIPTOR INPUT FORM FLAG -C JDESC - LIST OF DESCRIPTORS FOR SECTION 3 -C NEWNR - NUMBER OF DESCRIPTORS IN JDESC -C KSEQ - SEQUENCE DESCRIPTOR KEY -C KNUM - NR OF DESCRIPTORS IN SEQUENCE -C KLIST - LIST OF DESCRIPTORS IN SEQUENCE -C -C OUTPUT ARGUMENT LIST: -C KIF - DESCRIPTOR FORM -C KDESC - WORKING LIST OF DESCRIPTORS -C NRDESC - NUMBER OF DESCRIPTORS IN KDESC -C IERRTN - ERROR RETURN -C IERRTN = 0 NORMAL RETURN -C IERRTN = 5 FOUND DELAYED REPLICATION DURING -C EXPANSION -C -C REMARKS: -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256 -C -C$$$ -C - INTEGER JDESC(3,*), NEWNR, KDESC(3,*), NRDESC - INTEGER KARY(*),IERRTN,KIF,JIF - INTEGER ISECT3(*) -C - SAVE -C - IF (NEWNR.EQ.0) THEN - IERRTN = 3 - RETURN - END IF -C - NRDESC = NEWNR - IF (JIF.EQ.0) THEN - JIF = 1 - DO 90 I = 1, NEWNR - KDESC(1,I) = JDESC(1,I)*16384 + JDESC(2,I)*256 + JDESC(3,I) - JDESC(1,I) = JDESC(1,I)*16384 + JDESC(2,I)*256 + JDESC(3,I) - 90 CONTINUE - ELSE - DO 100 I = 1, NEWNR - KDESC(1,I) = JDESC(1,I) - 100 CONTINUE - NRDESC = NEWNR - END IF - KIF = 1 - 9000 CONTINUE - RETURN - END - SUBROUTINE FI8512(IUNITB,ISECT3,KDESC,NRDESC,KARY,IERRTN, - * LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KWIDTH,KRFVSW, - * IUNITD,KSEQ,KNUM,KLIST,INDEXB) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8512 READ IN TABLE B -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-12-03 -C -C ABSTRACT: READ IN TAILORED SET OF TABLE B DESCRIPTORS -C -C PROGRAM HISTORY LOG: -C 93-12-03 CAVANAUGH -C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE -C 94-04-18 HOPPA AN ERROR HAS BEEN CORRECTED TO PREVENT LATER -C SEARCHING TABLE B IF THERE ARE ONLY OPERATOR -C DESCRIPTORS IN THE DESCRIPTOR LIST. -C 94-05-17 HOPPA CHANGED THE LOOP FOR EXPANDING SEQUENCE -C DESCRIPTORS FROM A DO LOOP TO A GOTO LOOP -C -C USAGE: CALL FI8512(IUNITB,ISECT3,KDESC,NRDESC,KARY,IERRTN, -C * LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KWIDTH,KRFVSW, -C * IUNITD,KSEQ,KNUM,KLIST,INDEXB) -C INPUT ARGUMENT LIST: -C IUNITB - UNIT WHERE TABLE B ENTRIES RESIDE -C KDESC - WORKING DESCRIPTOR LIST -C NRDESC - NUMBER OF DESCRIPTORS IN KDESC -C IUNITD - UNIT WHERE TABLE D ENTRIES RESIDE -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KARY - -C IERRTN - -C LDESC - DESCRIPTORS IN TABLE B (DECIMAL VALUES) -C ANAME - ARRAY CONTAINING NAMES OF DESCRIPTORS -C AUNITS - ARRAY CONTAINING UNITS OF DESCRIPTORS -C KSCALE - SCALE VALUES FOR EACH DESCRIPTOR -C KRFVAL - REFERENCE VALUES FOR EACH DESCRIPTOR -C WIDTH - BIT WIDTH OF EACH DESCRIPTOR -C KRFVSW - NEW REFERENCE VALUE SWITCH -C KSEQ - SEQUENCE DESCRIPTOR -C KNUM - NUMBER OF DESCRIPTORS IN SEQUENCE -C KLIST - SEQUENCE OF DESCRIPTORS -C -C REMARKS: -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256 -C -C$$$ -C - INTEGER KARY(*),LDESC(*),KSCALE(*),KRFVAL(*),KWIDTH(*) - INTEGER KDESC(3,*), NRDESC, IUNITB, IERRTN, KRFVSW(*) - INTEGER ISECT3(*),KEY(3,1600),INDEXB(*) - INTEGER IUNITD,KSEQ(*),KNUM(*),KLIST(300,*) - CHARACTER*40 ANAME(*) - CHARACTER*25 AUNITS(*) -C - INTEGER MDESC(800),MR,I,J -C - SAVE -C -C =================================================================== - IERRTN = 0 - DO 100 I = 1, 30 - KARY(I) = 0 - 100 CONTINUE -C INITIALIZE DESCRIPTOR POINTERS TO MISSING - DO 105 I = 1, 16383 - INDEXB(I) = -1 - 105 CONTINUE -C -C =================================================================== -C MAKE A COPY OF THE DESCRIPTOR LIST -C ELIMINATING REPLICATION/OPERATORS - J = 0 - DO 110 I = 1, NRDESC - IF (KDESC(1,I).GE.49152.OR.KDESC(1,I).LT.16384) THEN - J = J + 1 - KEY(1,J) = KDESC(1,I) - END IF - 110 CONTINUE - KCNT = J -C =================================================================== -C REPLACE ALL SEQUENCE DESCRIPTORS -C JEN - FIXED NEXT BLOCK -C DO 300 I = 1, KCNT - I = 1 - 300 IF(I.LE.KCNT)THEN - 200 CONTINUE - IF (KEY(1,I).GE.49152) THEN - CALL FI8503(I,KEY,KCNT, - * ISECT3,IUNITD,KSEQ,KNUM,KLIST,IERRTN) - IF (IERRTN.NE.0) THEN - RETURN - END IF - GO TO 200 - END IF - I=I+1 - GOTO 300 - ENDIF -C 300 CONTINUE -C =================================================================== -C ISOLATE SINGLE COPIES OF DESCRIPTORS - MR = 1 -C THE FOLLOWING LINE IS TO PREVENT LATER SEARCHING TABLE B WHEN -C HAVE ONLY OPERATOR DESCRIPTORS - IF(KCNT.EQ.0) GOTO 9000 - MDESC(MR) = KEY(1,1) - DO 500 I = 2, KCNT - DO 400 J = 1, MR - IF (KEY(1,I).EQ.MDESC(J)) THEN - GO TO 500 - END IF - 400 CONTINUE - MR = MR + 1 - MDESC(MR) = KEY(1,I) - 500 CONTINUE -C =================================================================== -C SORT INTO ASCENDING ORDER -C READ IN MATCHING ENTRIES FROM TABLE B - DO 700 KCUR = 1, MR - NEXT = KCUR + 1 - IF (NEXT.LE.MR) THEN - DO 600 LR = NEXT, MR - IF (MDESC(KCUR).GT.MDESC(LR)) THEN - IHOLD = MDESC(LR) - MDESC(LR) = MDESC(KCUR) - MDESC(KCUR) = IHOLD - END IF - 600 CONTINUE - END IF - 700 CONTINUE -C =================================================================== - REWIND IUNITB -C -C READ IN A MODIFIED TABLE B - -C MODIFIED TABLE B CONTAINS ONLY -C THOSE DESCRIPTORS ASSOCIATED WITH -C CURRENT DATA. -C - KTRY = 0 - DO 1500 NRTBLB = 1, MR - 1000 CONTINUE - 1001 FORMAT (I1,I2,I3,A40,A25,I4,8X,I7,I5) - READ (IUNITB,1001,END=2000,ERR=8000)KF,KX,KY,ANAME(NRTBLB), - * AUNITS(NRTBLB),KSCALE(NRTBLB),KRFVAL(NRTBLB),KWIDTH(NRTBLB) - KRFVSW(NRTBLB) = 0 - LDESC(NRTBLB) = KX*256 + KY -C - IF (LDESC(NRTBLB).EQ.MDESC(NRTBLB)) THEN -C PRINT *,'1001',NRTBLB,LDESC(NRTBLB) -C PRINT *,LDESC(NRTBLB),ANAME(NRTBLB),KSCALE(NRTBLB), -C * KRFVAL(NRTBLB),KWIDTH(NRTBLB) - KTRY = KTRY + 1 - INDEXB(LDESC(NRTBLB)) = KTRY -C PRINT *,'INDEX(',LDESC(NRTBLB),' = ',KTRY - ELSE IF (LDESC(NRTBLB).GT.MDESC(NRTBLB)) THEN -C PRINT *,'FI8512 - IERRTN=2' - IERRTN = 2 - RETURN - ELSE - GO TO 1000 - END IF - 1500 CONTINUE - IF (KTRY.NE.MR) THEN - PRINT *,'DO NOT HAVE A COMPLETE SET OF TABLE B ENTRIES' - IERRTN = 2 - RETURN - END IF -C DO 1998 I = 1, 16383, 30 -C WRITE (6,1999) (INDEXB(I+J),J=0,23) -C1998 CONTINUE -C1999 FORMAT(30(1X,I3)) -C - 2000 CONTINUE - IERRTN = 0 - ISECT3(8) = MR - GO TO 9000 - 8000 CONTINUE - IERRTN = 4 - 9000 CONTINUE - RETURN - END - SUBROUTINE FI8513 (IUNITD,ISECT3,KSEQ,KNUM,KLIST,IERRTN) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8513 READ IN TABLE D -C PRGMMR: CAVANAUGH W/NMC42 DATE: 93-12-03 -C -C ABSTRACT: READ IN TABLE D -C -C PROGRAM HISTORY LOG: -C 93-12-03 CAVANAUGH -C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE -C -C USAGE: CALL FI8513 (IUNITD,ISECT3,KSEQ,KNUM,KLIST,IERRTN) -C INPUT ARGUMENT LIST: -C IUNITD - UNIT NUMBER OF INPUT DEVICE -C KARY - WORK ARRAY -C -C OUTPUT ARGUMENT LIST: -C KSEQ - KEY FOR SEQUENCE DESCRIPTORS -C KNUM - NUMBER IF DESCRIPTORS IN LIST -C KLIST - DESCRIPTORS LIST -C IERRTN - ERROR RETURN FLAG -C -C REMARKS: -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256 -C -C$$$ -C - INTEGER IUNITD, ISECT3(*) - INTEGER KSEQ(*),KNUM(*),KLIST(300,*) - INTEGER KKF(10),KKX(10),KKY(10),KF,KX,KY -C - SAVE -C - REWIND IUNITD - J = 0 - IERRTN = 0 - 1000 CONTINUE - READ (IUNITD,1001,END=9000,ERR=8000)KF,KX,KY, - * KKF(1),KKX(1),KKY(1), - * KKF(2),KKX(2),KKY(2), - * KKF(3),KKX(3),KKY(3), - * KKF(4),KKX(4),KKY(4), - * KKF(5),KKX(5),KKY(5), - * KKF(6),KKX(6),KKY(6), - * KKF(7),KKX(7),KKY(7), - * KKF(8),KKX(8),KKY(8), - * KKF(9),KKX(9),KKY(9), - * KKF(10),KKX(10),KKY(10) - 1001 FORMAT (11(I1,I2,I3,1X),3X) - J = J + 1 -C BUILD SEQUENCE KEY - KSEQ(J) = 16384*KF + 256*KX + KY - DO 2000 LM = 1, 10 -C BUILD KLIST - KLIST(J,LM) = 16384*KKF(LM) + 256*KKX(LM) + KKY(LM) - IF(KLIST(J,LM).NE.0) THEN - KNUM(J) = LM - END IF - 2000 CONTINUE - GO TO 1000 - 8000 CONTINUE - IERRTN = 6 - 9000 CONTINUE - ISECT3(9) = J - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fi88.f b/src/fim/FIMsrc/w3/w3fi88.f deleted file mode 100644 index 72cde8b..0000000 --- a/src/fim/FIMsrc/w3/w3fi88.f +++ /dev/null @@ -1,4750 +0,0 @@ - SUBROUTINE W3FI88(IPTR,IDENT,MSGA,ISTACK,MSTACK,KDATA,KNR,INDEX, - * LDATA,LSTACK,MAXR,MAXD,IUNITB,IUNITD) -C -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI88 BUFR MESSAGE DECODER -C PRGMMR: KEYSER ORG: NP22 DATE: 2001-02-01 -C -C ABSTRACT: THIS SET OF ROUTINES WILL DECODE A BUFR MESSAGE AND -C PLACE INFORMATION EXTRACTED FROM THE BUFR MESSAGE INTO SELECTED -C ARRAYS FOR THE USER. THE ARRAY KDATA CAN NOW BE SIZED BY THE USER -C BY INDICATING THE MAXIMUM NUMBER OF SUBSETS AND THE MAXIMUM -C NUMBER OF DESCRIPTORS THAT ARE EXPECTED IN THE COURSE OF DECODING -C SELECTED INPUT DATA. THIS ALLOWS FOR REALISTIC SIZING OF KDATA -C AND THE MSTACK ARRAYS. THIS VERSION ALSO ALLOWS FOR THE INCLUSION -C OF THE UNIT NUMBERS FOR TABLES B AND D INTO THE -C ARGUMENT LIST. THIS ROUTINE DOES NOT INCLUDE IFOD PROCESSING. -C -C PROGRAM HISTORY LOG: -C 1988-08-31 CAVANAUGH -C 1990-12-07 CAVANAUGH NOW UTILIZING GBYTE ROUTINES TO GATHER -C AND SEPARATE BIT FIELDS. THIS SHOULD IMPROVE -C (DECREASE) THE TIME IT TAKES TO DECODE ANY -C BUFR MESSAGE. HAVE ENTERED CODING THAT WILL -C PERMIT PROCESSING BUFR EDITIONS 1 AND 2. -C IMPROVED AND CORRECTED THE CONVERSION INTO -C IFOD FORMAT OF DECODED BUFR MESSAGES. -C 1991-01-18 CAVANAUGH PROGRAM/ROUTINES MODIFIED TO PROPERLY HANDLE -C SERIAL PROFILER DATA. -C 1991-04-04 CAVANAUGH MODIFIED TO HANDLE TEXT SUPPLIED THRU -C DESCRIPTOR 2 05 YYY. -C 1991-04-17 CAVANAUGH ERRORS IN EXTRACTING AND SCALING DATA -C CORRECTED. IMPROVED HANDLING OF NESTED -C QUEUE DESCRIPTORS IS ADDED. -C 1991-05-10 CAVANAUGH - ARRAY 'DATA' HAS BEEN ENLARGED TO REAL*8 -C TO BETTER CONTAIN VERY LARGE NUMBERS MORE -C ACCURATELY. THE PREIOUS SIZE REAL*4 COULD NOT -C CONTAIN SUFFICIENT SIGNIFICANT DIGITS. -C - CODING HAS BEEN INTRODUCED TO PROCESS NEW -C TABLE C DESCRIPTOR 2 06 YYY WHICH PERMITS IN -C LINE PROCESSING OF A LOCAL DESCRIPTOR EVEN IF -C THE DESCRIPTOR IS NOT CONTAINED IN THE USERS -C TABLE B. -C - A SECOND ROUTINE TO PROCESS IFOD MESSAGES -C (IFOD0) HAS BEEN REMOVED IN FAVOR OF THE -C IMPROVED PROCESSING OF THE ONE -C REMAINING (IFOD1). -C - NEW CODING HAS BEEN INTRODUCED TO PERMIT -C PROCESSING OF BUFR MESSAGES BASED ON BUFR -C EDITION UP TO AND INCLUDING EDITION 2. -C PLEASE NOTE INCREASED SIZE REQUIREMENTS -C FOR ARRAYS IDENT(20) AND IPTR(40). -C 1991-07-26 CAVANAUGH - ADD ARRAY MTIME TO CALLING SEQUENCE TO -C PERMIT INCLUSION OF RECEIPT/TRANSFER TIMES -C TO IFOD MESSAGES. -C 1991-09-25 CAVANAUGH - ALL PROCESSING OF DECODED BUFR DATA INTO -C IFOD (A LOCAL USE REFORMAT OF BUFR DATA) -C HAS BEEN ISOLATED FROM THIS SET OF ROUTINES. -C FOR THOSE INTERESTED IN THE IFOD FORM, -C SEE W3FL05 IN THE W3LIB ROUTINES. -C PROCESSING OF BUFR MESSAGES CONTAINING -C DELAYED REPLICATION HAS BEEN ALTERED SO THAT -C SINGLE SUBSETS (REPORTS) AND AND A MATCHING -C DESCRIPTOR LIST FOR THAT PARTICULAR SUBSET -C WILL BE PASSED TO THE USER WILL BE PASSED TO -C THE USER ONE AT A TIME TO ASSURE THAT EACH -C SUBSET CAN BE FULLY DEFINED WITH A MINIMUM -C OF REPROCESSING. -C PROCESSING OF ASSOCIATED FIELDS HAS BEEN -C TESTED WITH MESSAGES CONTAINING NON-COMPRESSED -C DATA. -C IN ORDER TO FACILITATE USER PROCESSING -C A MATCHING LIST OF SCALE FACTORS ARE INCLUDED -C WITH THE EXPANDED DESCRIPTOR LIST (MSTACK). -C 1991-11-21 CAVANAUGH - PROCESSING OF DESCRIPTOR 2 03 YYY -C HAS CORRECTED TO AGREE WITH FM94 STANDARDS. -C 1991-12-19 CAVANAUGH - CALLS TO FI8803 AND FI8804 HAVE BEEN -C CORRECTED TO AGREE CALLED PROGRAM ARGUMENT -C LIST. SOME ADDITIONAL ENTRIES HAVE BEEN -C INCLUDED FOR COMMUNICATING WITH DATA ACCESS -C ROUTINES. ADDITIONAL ERROR EXIT PROVIDED FOR -C THE CASE WHERE TABLE B IS DAMAGED. -C 1992-01-24 CAVANAUGH - ROUTINES FI8801, FI8803 AND FI8804 -C HAVE BEEN MODIFIED TO HANDLE ASSOCIATED FIELDS -C ALL DESCRIPTORS ARE SET TO ECHO TO MSTACK(1,N) -C 1992-05-21 CAVANAUGH - FURTHER EXPANSION OF INFORMATION COLLECTED -C FROM WITHIN UPPER AIR SOUNDINGS HAS PRODUCED -C THE NECESSITY TO EXPAND SOME OF THE PROCESSING -C AND OUTPUT ARRAYS. (SEE REMARKS BELOW) -C 1992-06-29 CAVANAUGH - CORRECTED DESCRIPTOR DENOTING HEIGHT OF -C EACH WIND LEVEL FOR PROFILER CONVERSIONS. -C 1992-07-23 CAVANAUGH - EXPANSION OF TABLE B REQUIRES ADJUSTMENT -C OF ARRAYS TO CONTAIN TABLE B VALUES NEEDED TO -C ASSIST IN THE DECODING PROCESS. -C ARRAYS CONTAINING DATA FROM TABLE B -C KFXY1 - DESCRIPTOR -C ANAME1 - DESCRIPTOR NAME -C AUNIT1 - UNITS FOR DESCRIPTOR -C ISCAL1 - SCALE FOR VALUE OF DESCRIPTOR -C IRFVL1 - REFERENCE VALUE FOR DESCRIPTOR -C IWIDE1 - BIT WIDTH FOR VALUE OF DESCRIPTOR -C 1992-09-09 CAVANAUGH - FIRST ENCOUNTER WITH OPERATOR DESCRIPTOR -C 2 05 YYY SHOWED ERROR IN DECODING. THAT ERROR -C IS CORRECTED WITH THIS IMPLEMENTATION. FURTHER -C TESTING OF UPPER AIR DATA HAS ENCOUNTERED -C THE CONDITION OF LARGE (MANY LEVEL) SOUNDINGS -C ARRAYS IN THE DECODER HAVE BEEN EXPANDED (AGAIN) -C TO ALLOW FOR THIS CONDITION. -C 1992-10-02 CAVANAUGH - MODIFIED ROUTINE TO REFORMAT PROFILER DATA -C (FI8809) TO SHOW DESCRIPTORS, SCALE VALUE AND -C DATA IN PROPER ORDER. CORRECTED AN ERROR THAT -C PREVENTED USER FROM ASSIGNING THE SECOND DIMENSION -C OF KDATA(500,*). -C 1992-10-20 CAVANAUGH - REMOVED ERROR THAT PREVENTED FULL -C IMPLEMENTATION OF PREVIOUS CORRECTIONS AND -C MADE CORRECTIONS TO TABLE B TO BRING IT UP TO -C DATE. CHANGES INCLUDE PROPER REFORMAT OF PROFILER -C DATA AND USER CAPABILITY FOR ASSIGNING SECOND -C DIMENSION OF KDATA ARRAY. -C 1992-12-09 CAVANAUGH - THANKS TO DENNIS KEYSER FOR THE SUGGESTIONS -C AND CODING, THIS IMPLEMENTATION WILL ALLOW THE -C INCLUSION OF UNIT NUMBERS FOR TABLES B & D, AND -C IN ADDITION ALLOWS FOR REALISTIC SIZING OF KDATA -C AND MSTACK ARRAYS BY THE USER. AS OF THIS -C IMPLEMENTATION, THE UPPER SIZE LIMIT FOR A BUFR -C MESSAGE ALLOWS FOR A MESSAGE SIZE GREATER THAN -C 15000 BYTES. -C 1993-01-26 CAVANAUGH - ROUTINE FI8810 HAS BEEN ADDED TO PERMIT -C REFORMATTING OF PROFILER DATA IN EDITION 2. -C 1993-05-13 CAVANAUGH - ROUTINE FI8811 HAS BEEN ADDED TO PERMIT -C PROCESSING OF RUN-LINE ENCODING. THIS PROVIDES FOR -C THE HANDLING OF DATA FOR GRAPHICS PRODUCTS. -C PLEASE NOTE THE ADDITION OF TWO ARGUMENTS IN THE -C CALLING SEQUENCE. -C 1993-12-01 CAVANAUGH - ROUTINE FI8803 TO CORRECT HANDLING OF -C ASSOCIATED FIELDS AND ARRAYS ASSOCIATED WITH -C TABLE B ENTRIES ENLARGED TO HANDLE LARGER TABLE B -C 1994-05-25 CAVANAUGH - ROUTINES HAVE BEEN MODIFIED TO CONSTRUCT A -C MODIFIED TABLE B I.E., IT IS TAILORED TO CONTAIN O -C THOSE DESCRIPTORS THAT WILL BE USED TO DECODE -C DATA IN CURRENT AND SUBSEQUENT BUFR MESSAGES. -C TABLE B AND TABLE D DESCRIPTORS WILL BE ISOLATED -C AND MERGED WITH THE MAIN TABLES FOR USE WITH -C FOLLOWING BUFR MESSAGES. -C THE DESCRIPTORS INDICATING THE REPLICATION OF -C DESCRIPTORS AND DATA ARE ACTIVATED WITH THIS -C IMPLEMENTATION. -C 1994-08-30 CAVANAUGH - ADDED STATEMENTS THAT WILL ALLOW USE OF -C THESE ROUTINES DIRECTLY ON THE CRAY WITH NO -C MODIFICATION. HANDLING OD TABLE D ENTRIES HAS BEEN -C MODIFIED TO PREVENT LOSS OF ANCILLARY ENTRIES. -C CODING HAS BEEN ADDED TO ALLOW PROCESSING ON -C EITHER AN 8 BYTE WORD OR 4 BYTE WORD MACHINE. -C -C FOR THOSE USERS OF THE BUFR DECODER THAT ARE -C PROCESSING SETS OF BUFR MESSAGES THAT INCLUDE -C TYPE 11 MESSAGES, CODING HAS BEEN ADDED TO ALLOW -C THE RECOVERY OF THE ADDED OR MODIFIED TABLE B -C ENTRIES BY WRITING THEM TO A DISK FILE AVAILABLE -C TO THE USER. THIS IS ACCOMPLISHED WITH NO CHANGE -C TO THE CALLING SEQUENCE. TABLE B ENTRIES WILL BE -C DESIGNATED AS FOLLOWS: -C -C IUNITB - IS THE UNIT NUMBER FOR THE MASTER -C TABLE B. -C IUNITB+1 - WILL BE THE UNIT NUMBER FOR THE -C TABLE B ENTRIES THAT ARE TO BE USED -C IN THE DECODING OF SUBSEQUENT MESSAGES. -C THIS DEVICE WILL BE FORMATTED THE SAME -C THE DISK FILE ON IUNITB. -C -C 1995-06-07 KEYSER- CORRECTED AN ERROR WHICH REQUIRED INPUT -C ARGUMENT "MAXD" TO BE NEARLY TWICE AS LARGE AS -C NEEDED FOR DECODING WIND PROFILER REPORTS (LIMIT -C UPPER BOUND FOR "IWORK" ARRAY WAS SET TO "MAXD", -C NOW IT IS SET TO 15000). ALSO, A CORRECTION WAS -C MADE IN THE WIND PROFILER PROCESSING TO PREVENT -C UNNECESSARY LOOPING WHEN ALL REQUESTED -C DESCRIPTORS ARE MISSING. ALSO CORRECTED AN -C ERROR WHICH RESULTED IN RETURNED SCALE IN -C "MSTACK(2, ..)" ALWAYS BEING SET TO ZERO FOR -C COMPRESSED DATA. -C 1996-02-15 CAVANAUGH- MODIFIED IDENTIFICATION OF ASCII/EBCDIC -C MACHINE. MODIFIED HANDLING OF TABLE B TO PERMIT -C FASTER PROCESSING OF MULTIPLE MESSAGES WITH -C CHANGING DATA TYPES AND/OR SUBTYPES. -C 1996-04-02 CAVANAUGH- DEACTIVATED EXTRANEOUS WRITE STATEMENT. -C ENLARGED ARRAYS FOR TABLE B ENTRIES TO CONTAIN -C UP TO 1300 ENTRIES IN PREPARATION FOR NEW -C ADDITIONS TO TABLE B. -C 2001-02-01 KEYSER- THE TABLE B FILE WILL NOW BE READ WHENEVER THE -C INPUT ARGUMENT "IUNITB" (TABLE B UNIT NUMBER) -C CHANGES FROM ITS VALUE IN THE PREVIOUS CALL TO -C THIS ROUTINE (NORMALLY IT IS ONLY READ THE -C FIRST TIME THIS ROUTINE IS CALLED) -C 2002-10-15 VUONG REPLACED FUNCTION ICHAR WITH MOVA2I -C -C -C USAGE: CALL W3FI88(IPTR,IDENT,MSGA,ISTACK,MSTACK,KDATA,KNR,INDEX, -C LDATA,LSTACK,MAXR,MAXD,IUNITB,IUNITD) -C -C INPUT ARGUMENT LIST: -C MSGA - ARRAY CONTAINING SUPPOSED BUFR MESSAGE -C SIZE IS DETERMINED BY USER, CAN BE GREATER -C THAN 15000 BYTES. -C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE -C CONTAINED IN A BUFR MESSAGE -C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT -C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE -C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST -C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE -C IUNITB - UNIT NUMBER OF DATA SET HOLDING TABLE B, THIS IS THE -C NUMBER OF A PAIR OF DATA SETS -C IUNITB+1 - UNIT NUMBER FOR A DATASET TO CONTAIN TABLE B ENTRIES -C FROM MASTER TABLE B AND TABLE B ENTRIES EXTRACTED -C FROM TYPE 11 BUFR MESSAGES THAT WERE USED TO DECODE -C CURRENT BUFR MESSAGES. -C IUNITD - UNIT NUMBER OF DATA SET HOLDING TABLE D -C -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C ISTACK - ORIGINAL ARRAY OF DESCRIPTORS EXTRACTED FROM -C SOURCE BUFR MESSAGE. -C -C MSTACK(A,B)-LEVEL B - DESCRIPTOR NUMBER (LIMITED TO VALUE OF -C INPUT ARGUMENT MAXD) -C -C LEVEL A = 1 DESCRIPTOR -C = 2 10**N SCALING TO RETURN TO ORIGINAL VALUE -C IPTR - UTILITY ARRAY (SHOULD HAVE AT LAST 42 ENTRIES) -C IPTR( 1)- ERROR RETURN -C IPTR( 2)- BYTE COUNT SECTION 1 -C IPTR( 3)- POINTER TO START OF SECTION 1 -C IPTR( 4)- BYTE COUNT SECTION 2 -C IPTR( 5)- POINTER TO START OF SECTION 2 -C IPTR( 6)- BYTE COUNT SECTION 3 -C IPTR( 7)- POINTER TO START OF SECTION 3 -C IPTR( 8)- BYTE COUNT SECTION 4 -C IPTR( 9)- POINTER TO START OF SECTION 4 -C IPTR(10)- START OF REQUESTED SUBSET, RESERVED FOR DAR -C IPTR(11)- CURRENT DESCRIPTOR PTR IN IWORK -C IPTR(12)- LAST DESCRIPTOR POS IN IWORK -C IPTR(13)- LAST DESCRIPTOR POS IN ISTACK -C IPTR(14)- NUMBER OF MASTER TABLE B ENTRIES -C IPTR(15)- REQUESTED SUBSET POINTER, RESERVED FOR DAR -C IPTR(16)- INDICATOR FOR EXISTANCE OF SECTION 2 -C IPTR(17)- NUMBER OF REPORTS PROCESSED -C IPTR(18)- ASCII/TEXT EVENT -C IPTR(19)- POINTER TO START OF BUFR MESSAGE -C IPTR(20)- NUMBER OF ENTRIES FROM TABLE D -C IPTR(21)- NR TABLE B ENTRIES -C IPTR(22)- NR TABLE B ENTRIES FROM CURRENT MESSAGE -C IPTR(23)- CODE/FLAG TABLE SWITCH -C IPTR(24)- ADITIONAL WORDS ADDED BY TEXT INFO -C IPTR(25)- CURRENT BIT NUMBER -C IPTR(26)- DATA WIDTH CHANGE - ADD TO TABLE B WIDTH -C IPTR(27)- DATA SCALE CHANGE - MODIFIES TABLE B SCALE -C IPTR(28)- DATA REFERENCE VALUE CHANGE - ????????? -C IPTR(29)- ADD DATA ASSOCIATED FIELD -C IPTR(30)- SIGNIFY CHARACTERS -C IPTR(31)- NUMBER OF EXPANDED DESCRIPTORS IN MSTACK -C IPTR(32)- CURRENT DESCRIPTOR SEGMENT F -C IPTR(33)- CURRENT DESCRIPTOR SEGMENT X -C IPTR(34)- CURRENT DESCRIPTOR SEGMENT Y -C IPTR(35)- DATA/DESCRIPTOR REPLICATION IN PROGRESS -C 0 = NO -C 1 = YES -C IPTR(36)- NEXT DESCRIPTOR MAY BE UNDECIPHERABLE -C IPTR(37)- MACHINE TEXT TYPE FLAG -C 0 = EBCIDIC -C 1 = ASCII -C IPTR(38)- DATA/DESCRIPTOR REPLICATION FLAG -C 0 - DOES NOT EXIST IN CURRENT MESSAGE -C 1 - EXISTS IN CURRENT MESSAGE -C IPTR(39)- DELAYED REPLICATION FLAG -C 0 - NO DELAYED REPLICATION -C 1 - MESSAGE CONTAINS DELAYED REPLICATION -C IPTR(40)- NUMBER OF CHARACTERS IN TEXT FOR CURR DESCRIPTOR -C IPTR(41)- NUMBER OF ANCILLARY TABLE B ENTRIES -C IPTR(42)- NUMBER OF ANCILLARY TABLE D ENTRIES -C IPTR(43)- NUMBER OF ADDED TABLE B ENTRIES ENCOUNTERED WHILE -C PROCESSING A BUFR MESSAGE. THESE ENTRIES ONLY -C EXIST DURNG PROCESSING OF CURRENT BUFR MESSAGE -C IPTR(44)- BITS PER WORD -C IPTR(45)- BYTES PER WORD -C IDENT - ARRAY CONTAINS MESSAGE INFORMATION EXTRACTED FROM -C BUFR MESSAGE - -C IDENT(1) -EDITION NUMBER (BYTE 4, SECTION 1) -C IDENT(2) -ORIGINATING CENTER (BYTES 5-6, SECTION 1) -C IDENT(3) -UPDATE SEQUENCE (BYTE 7, SECTION 1) -C IDENT(4) -OPTIONAL SECTION (BYTE 8, SECTION 1) -C IDENT(5) -BUFR MESSAGE TYPE (BYTE 9, SECTION 1) -C 0 = SURFACE DATA (LAND) -C 1 = SURFACE DATA (SHIP) -C 2 = VERTICAL SOUNDINGS (OTHER THAN SATELLITE) -C 3 = VERTICAL SOUNDINGS (SATELLITE) -C 4 = SINGLE LVL UPPER-AIR DATA(OTHER THAN SATELLITE) -C 5 = SINGLE LEVEL UPPER-AIR DATA (SATELLITE) -C 6 = RADAR DATA -C 7 = SYNOPTIC FEATURES -C 8 = PHYSICAL/CHEMICAL CONSTITUENTS -C 9 = DISPERSAL AND TRANSPORT -C 10 = RADIOLOGICAL DATA -C 11 = BUFR TABLES (COMPLETE, REPLACEMENT OR UPDATE) -C 12 = SURFACE DATA (SATELLITE) -C 21 = RADIANCES (SATELLITE MEASURED) -C 31 = OCEANOGRAPHIC DATA -C IDENT(6) -BUFR MSG SUB-TYPE (BYTE 10, SECTION 1) -C TYPE SBTYP -C 2 7 = PROFILER -C IDENT(7) - (BYTES 11-12, SECTION 1) -C IDENT(8) -YEAR OF CENTURY (BYTE 13, SECTION 1) -C IDENT(9) -MONTH OF YEAR (BYTE 14, SECTION 1) -C IDENT(10)-DAY OF MONTH (BYTE 15, SECTION 1) -C IDENT(11)-HOUR OF DAY (BYTE 16, SECTION 1) -C IDENT(12)-MINUTE OF HOUR (BYTE 17, SECTION 1) -C IDENT(13)-RSVD BY ADP CENTERS(BYTE 18, SECTION 1) -C IDENT(14)-NR OF DATA SUBSETS (BYTE 5-6, SECTION 3) -C IDENT(15)-OBSERVED FLAG (BYTE 7, BIT 1, SECTION 3) -C IDENT(16)-COMPRESSION FLAG (BYTE 7, BIT 2, SECTION 3) -C IDENT(17)-MASTER TABLE NUMBER(BYTE 4, SECTION 1, ED 2 OR GTR) -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C INDEX - POINTER TO AVAILABLE SUBSET -C -C =========================================================== -C ARRAYS CONTAINING DATA FROM TABLE B -C NEW - BASE ARRAYS CONTAINING DATA FROM TABLE B -C KFXY1 - DECIMAL DESCRIPTOR VALUE OF F X Y VALUES -C ANAME1 - DESCRIPTOR NAME -C AUNIT1 - UNITS FOR DESCRIPTOR -C ISCAL1 - SCALE FOR VALUE OF DESCRIPTOR -C IRFVL1 - REFERENCE VALUE FOR DESCRIPTOR -C IWIDE1 - BIT WIDTH FOR VALUE OF DESCRIPTOR -C =========================================================== -C NEW - ANCILLARY ARRAYS CONTAINING DATA FROM TABLE B -C CONTAINING TABLE B ENTRIES EXTRACTED -C FROM TYPE 11 BUFR MESSAGES -C KFXY2 - DECIMAL DESCRIPTOR VALUE OF F X Y VALUES -C ANAME2 - DESCRIPTOR NAME -C AUNIT2 - UNITS FOR DESCRIPTOR -C ISCAL2 - SCALE FOR VALUE OF DESCRIPTOR -C IRFVL2 - REFERENCE VALUE FOR DESCRIPTOR -C IWIDE2 - BIT WIDTH FOR VALUE OF DESCRIPTOR -C =========================================================== -C NEW - ADDED ARRAYS CONTAINING DATA FROM TABLE B -C CONTAINING TABLE B ENTRIES EXTRACTED -C FROM NON-TYPE 11 BUFR MESSAGES -C THESE EXIST FOR THE LIFE OF CURRENT BUFR MESSAGE -C KFXY3 - DECIMAL DESCRIPTOR VALUE OF F X Y VALUES -C ANAME3 - DESCRIPTOR NAME -C AUNIT3 - UNITS FOR DESCRIPTOR -C ISCAL3 - SCALE FOR VALUE OF DESCRIPTOR -C IRFVL3 - REFERENCE VALUE FOR DESCRIPTOR -C IWIDE3 - BIT WIDTH FOR VALUE OF DESCRIPTOR -C =========================================================== -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C UNIQUE - FI8801 FI8802 FI8803 FI8804 FI8805 FI8806 -C FI8807 FI8808 FI8809 FI8810 FI8811 FI8812 -C FI8813 FI8814 FI8815 FI8820 -C W3LIB - W3AI39 W3FC05 GBYTE GBYTES -C -C REMARKS: ERROR RETURNS: -C IPTR(1) = 1 'BUFR' NOT FOUND IN FIRST 125 CHARACTERS -C = 2 '7777' NOT FOUND IN LOCATION DETERMINED BY -C BY USING COUNTS FOUND IN EACH SECTION. ONE OR -C MORE SECTIONS HAVE AN ERRONEOUS BYTE COUNT OR -C CHARACTERS '7777' ARE NOT IN TEST MESSAGE. -C = 3 MESSAGE CONTAINS A DESCRIPTOR WITH F=0 THAT DOES -C NOT EXIST IN TABLE B. -C = 4 MESSAGE CONTAINS A DESCRIPTOR WITH F=3 THAT DOES -C NOT EXIST IN TABLE D. -C = 5 MESSAGE CONTAINS A DESCRIPTOR WITH F=2 WITH THE -C VALUE OF X OUTSIDE THE RANGE 1-6. -C = 6 DESCRIPTOR ELEMENT INDICATED TO HAVE A FLAG VALUE -C DOES NOT HAVE AN ENTRY IN THE FLAG TABLE. -C (TO BE ACTIVATED) -C = 7 DESCRIPTOR INDICATED TO HAVE A CODE VALUE DOES -C NOT HAVE AN ENTRY IN THE CODE TABLE. -C (TO BE ACTIVATED) -C = 8 ERROR READING TABLE D -C = 9 ERROR READING TABLE B -C = 10 ERROR READING CODE/FLAG TABLE -C = 11 DESCRIPTOR 2 04 004 NOT FOLLOWED BY 0 31 021 -C = 12 DATA DESCRIPTOR OPERATOR QUALIFIER DOES NOT FOLLOW -C DELAYED REPLICATION DESCRIPTOR. -C = 13 BIT WIDTH ON ASCII CHARACTERS NOT A MULTIPLE OF 8 -C = 14 SUBSETS = 0, NO CONTENT BULLETIN -C = 20 EXCEEDED COUNT FOR DELAYED REPLICATION PASS -C = 21 EXCEEDED COUNT FOR NON-DELAYED REPLICATION PASS -C = 22 EXCEEDED COMBINED BIT WIDTH, BIT WIDTH > 32 -C = 23 NO ELEMENT DESCRIPTORS FOLLOWING 2 03 YYY -C = 27 NON ZERO LOWEST ON TEXT DATA -C = 28 NBINC NOT NR OF CHARACTERS -C = 29 TABLE B APPEARS TO BE DAMAGED -C = 30 TABLE D ENTRY WITH MORE THAN 18 IN SEQUENCE -C BEING ENTERED FROM TYPE 11 MESSAGE -C = 99 NO MORE SUBSETS (REPORTS) AVAILABLE IN CURRENT -C BUFR MESAGE -C -C = 400 NUMBER OF SUBSETS EXCEEDS THE VALUE OF INPUT -C ARGUMENT MAXR; MUST INCREASE MAXR TO VALUE OF -C IDENT(14) IN CALLING PROGRAM -C -C = 401 NUMBER OF PARAMETERS (AND ASSOCIATED FIELDS) -C EXCEEDS LIMITS OF THIS PROGRAM. -C = 500 VALUE FOR NBINC HAS BEEN FOUND THAT EXCEEDS -C STANDARD WIDTH PLUS ANY BIT WIDTH CHANGE. -C CHECK ALL BIT WIDTHS UP TO POINT OF ERROR. -C = 501 CORRECTED WIDTH FOR DESCRIPTOR IS 0 OR LESS -C = 888 NON-NUMERIC CHARACTER IN CONVERSION REQUEST -C = 890 CLASS 0 ELEMENT DESCRIPTOR W/WIDTH OF 0 -C -C ON THE INITIAL CALL TO W3FI88 WITH A BUFR MESSAGE THE ARGUMENT -C INDEX MUST BE SET TO ZERO (INDEX = 0). ON THE RETURN FROM W3FI88 -C 'INDEX' WILL BE SET TO THE NEXT AVAILABLE SUBSET/REPORT. WHEN -C THERE ARE NO MORE SUBSETS AVAILABLE A 99 ERR RETURN WILL OCCUR. -C -C IF THE ORIGINAL BUFR MESSAGE DOES NOT CONTAIN DELAYED REPLICATION -C THE BUFR MESSAGE WILL BE COMPLETELY DECODED AND 'INDEX' WILL POINT -C TO THE FIRST DECODED SUBSET. THE USERS WILL THEN HAVE THE OPTION -C OF INDEXING THROUGH THE SUBSETS ON THEIR OWN OR BY RECALLING THIS -C ROUTINE (WITHOUT RESETTING 'INDEX') TO HAVE THE ROUTINE DO THE -C INDEXING. -C -C IF THE ORIGINAL BUFR MESSAGE DOES CONTAIN DELAYED REPLICATION -C ONE SUBSET/REPORT WILL BE DECODED AT A TIME AND PASSED BACK TO -C THE USER. THIS IS NOT AN OPTION. -C -C ============================================= -C TO USE THIS ROUTINE -C ============================================= -C THE ARRAYS TO CONTAIN THE OUTPUT INFORMATION ARE DEFINED -C AS FOLLOWS: -C -C KDATA(A,B) IS THE A DATA ENTRY (INTEGER VALUE) -C WHERE A IS THE MAXIMUM NUMBER OF REPORTS/SUBSETS -C THAT MAY BE CONTAINED IN THE BUFR MESSAGE (THIS -C IS NOW SET TO "MAXR" WHICH IS PASSED AS AN INPUT -C ARGUMENT TO W3FI88), AND WHERE B IS THE MAXIMUM -C NUMBER OF DESCRIPTOR COMBINATIONS THAT MAY -C BE PROCESSED (THIS IS NOW SET TO "MAXD" WHICH -C IS ALSO PASSED AS AN INPUT ARGUMENT TO W3FI88; -C UPPER AIR DATA AND SOME SATELLITE DATA REQUIRE -C A VALUE FOR MAXD OF 1700, BUT FOR MOST OTHER -C DATA A VALUE FOR MAXD OF 500 WILL SUFFICE) -C MSTACK(1,B) CONTAINS THE DESCRIPTOR THAT MATCHES THE -C DATA ENTRY (MAX. VALUE FOR B IS NOW "MAXD" -C WHICH IS PASSED AS AN INPUT ARGUMENT TO W3FI88) -C MSTACK(2,B) IS THE SCALE (POWER OF 10) TO BE APPLIED TO -C THE DATA (MAX. VALUE FOR B IS NOW "MAXD" -C WHICH IS PASSED AS AN INPUT ARGUMENT TO W3FI88) -C -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ -C -C -C THE MEMORY REQUIREMENTS FOR LSTACK AND LDATA ARE USED WITH -C RUN-LINE CODING PROVIDING FOR THE HANDLING OF DATA FOR -C GRAPHICS. I.E., RADAR DISPLAYS. IF THE DECODING PROCESS WILL -C NOT BE USED TO PROCESS THOSE TYPE OF MESSAGES, THEN THE -C VARIABLE SIZES FOR THE ARRAYS CAN BE MINIMIZED. -C IF THE DECODING PROCESS WILL BE USED TO DECODE THOSE MESSAGE -C TYPES, THEN MAXD MUST REFLECT THE MAXIMUM NUMBER OF -C DESCRIPTORS (FULLY EXPANDED LIST) TO BE EXPECTED IN THE -C MESSAGE. -C - INTEGER LDATA(MAXD) - INTEGER LSTACK(2,MAXD) -C - INTEGER MSGA(*) - INTEGER IPTR(*),KPTRB(16384),KPTRD(16384) - INTEGER KDATA(MAXR,MAXD) - INTEGER MSTACK(2,MAXD) -C - INTEGER IVALS(1000) - INTEGER KNR(MAXR) - INTEGER IDENT(*) - INTEGER ISTACK(*),IOLD11 -cdak KEYSER fix 02/02/2001 VVVVV - INTEGER IOLDTB -cdak KEYSER fix 02/02/2001 AAAAA - INTEGER IWORK(15000) - INTEGER INDEX -C - INTEGER IIII - CHARACTER*1 BLANK - CHARACTER*4 DIRID(2) -C - LOGICAL SEC2 -C .................................................. -C -C NEW BASE TABLE B -C MAY BE A COMBINATION OF MASTER TABLE B -C AND ANCILLARY TABLE B -C - INTEGER KFXY1(1300),ISCAL1(1300) - INTEGER IRFVL1(3,1300),IWIDE1(1300) - CHARACTER*40 ANAME1(1300) - CHARACTER*24 AUNIT1(1300) -C .................................................. -C -C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE -C - INTEGER KFXY2(200),ISCAL2(200),IRFVL2(200),IWIDE2(200) - CHARACTER*64 ANAME2(200) - CHARACTER*24 AUNIT2(200) -C .................................................. -C -C NEW ADDED TABLE B FROM NON-TYPE 11 BUFR MESSAGE -C -C INTEGER KFXY3(200),ISCAL3(200),IRFVL3(200),IWIDE3(200) -C CHARACTER*64 ANAME3(200) -C CHARACTER*24 AUNIT3(200) -C .................................................. -C -C NEW BASE TABLE D -C - INTEGER ITBLD(20,400) -C .................................................. -C -C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE -C - INTEGER ITBLD2(20,50) -C .................................................. -C - SAVE - -cdak KEYSER fix 02/02/2001 VVVVV - DATA IOLD11/0/ - DATA IOLDTB/-99/ -cdak KEYSER fix 02/02/2001 AAAAA -C - CALL W3FI01(LW) - IPTR(45) = LW - IPTR(44) = LW * 8 -C - BLANK = ' ' - IF (MOVA2I(BLANK).EQ.32) THEN - IPTR(37) = 1 -C PRINT *,'ASCII MACHINE' - ELSE - IPTR(37) = 0 -C PRINT *,'EBCDIC MACHINE' - END IF -C -C PRINT *,' W3FI88 DECODER' -C INITIALIZE ERROR RETURN - IPTR(1) = 0 - IF (INDEX.GT.0) THEN -C HAVE RE-ENTRY - INDEX = INDEX + 1 -C PRINT *,'RE-ENTRY LOOKING FOR SUBSET NR',INDEX - IF (INDEX.GT.IDENT(14)) THEN -C ALL SUBSETS PROCESSED - IPTR(1) = 99 - IPTR(38) = 0 - IPTR(39) = 0 - ELSE IF (INDEX.LE.IDENT(14)) THEN - IF (IPTR(39).NE.0) THEN - DO 3000 J =1, IPTR(13) - IWORK(J) = ISTACK(J) - 3000 CONTINUE - IPTR(12) = IPTR(13) - CALL FI8801(IPTR,IDENT,MSGA,ISTACK,IWORK,KDATA,IVALS, - * MSTACK,KNR,INDEX,MAXR,MAXD, - * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,IRF1SW,INEWVL, - * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2, - * KFXY3,ANAME3,AUNIT3,ISCAL3,IRFVL3,IWIDE3, - * IUNITB,IUNITD,ITBLD,ITBLD2,KPTRB,KPTRD) -C - END IF - END IF - RETURN - ELSE - INDEX = 1 -C PRINT *,'INITIAL ENTRY FOR THIS BUFR MESSAGE' - END IF - IPTR(39) = 0 -C FIND 'BUFR' IN FIRST 125 CHARACTERS - DO 1000 KNOFST = 0, 999, 8 - INOFST = KNOFST - CALL GBYTE (MSGA,IVALS,INOFST,8) - IF (IVALS(1).EQ.66) THEN - IPTR(19) = INOFST - INOFST = INOFST + 8 - CALL GBYTE (MSGA,IVALS,INOFST,24) - IF (IVALS(1).EQ.5588562) THEN -C PRINT *,'FOUND BUFR AT',IPTR(19) - INOFST = INOFST + 24 - GO TO 1500 - END IF - END IF - 1000 CONTINUE - PRINT *,'BUFR - START OF BUFR MESSAGE NOT FOUND' - IPTR(1) = 1 - RETURN - 1500 CONTINUE - IDENT(1) = 0 -C TEST FOR EDITION NUMBER -C ====================== - CALL GBYTE (MSGA,IDENT(1),INOFST+24,8) -C PRINT *,'THIS IS AN EDITION',IDENT(1),' BUFR MESSAGE' -C - IF (IDENT(1).GE.2) THEN -C GET TOTAL COUNT - CALL GBYTE (MSGA,IVALS,INOFST,24) - ITOTAL = IVALS(1) - KENDER = ITOTAL * 8 - 32 + IPTR(19) - CALL GBYTE (MSGA,ILAST,KENDER,32) -C IF (ILAST.EQ.926365495) THEN -C PRINT *,'HAVE TOTAL COUNT FROM SEC 0',IVALS(1) -C END IF - INOFST = INOFST + 32 -C GET SECTION 1 COUNT - IPTR(3) = INOFST - CALL GBYTE (MSGA,IVALS,INOFST,24) -C PRINT *,'SECTION 1 STARTS AT',INOFST,' SIZE',IVALS(1) - INOFST = INOFST + 24 - IPTR( 2) = IVALS(1) -C GET MASTER TABLE - CALL GBYTE (MSGA,IVALS,INOFST,8) - INOFST = INOFST + 8 - IDENT(17) = IVALS(1) -C PRINT *,'BUFR MASTER TABLE NR',IDENT(17) - ELSE - IPTR(3) = INOFST -C GET SECTION 1 COUNT - CALL GBYTE (MSGA,IVALS,INOFST,24) -C PRINT *,'SECTION 1 STARTS AT',INOFST,' SIZE',IVALS(1) - INOFST = INOFST + 32 - IPTR( 2) = IVALS(1) - END IF -C ====================== -C ORIGINATING CENTER - CALL GBYTE (MSGA,IVALS,INOFST,16) - INOFST = INOFST + 16 - IDENT(2) = IVALS(1) -C UPDATE SEQUENCE - CALL GBYTE (MSGA,IVALS,INOFST,8) - INOFST = INOFST + 8 - IDENT(3) = IVALS(1) -C OPTIONAL SECTION FLAG - CALL GBYTE (MSGA,IVALS,INOFST,1) - IDENT(4) = IVALS(1) - IF (IDENT(4).GT.0) THEN - SEC2 = .TRUE. - ELSE -C PRINT *,' NO OPTIONAL SECTION 2' - SEC2 = .FALSE. - END IF - INOFST = INOFST + 8 -C MESSAGE TYPE - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(5) = IVALS(1) - INOFST = INOFST + 8 -C MESSAGE SUBTYPE - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(6) = IVALS(1) - INOFST = INOFST + 8 -cdak KEYSER fix 02/02/2001 VVVVV - IF (IUNITB.NE.IOLDTB) THEN -C IF HAVE A CHANGE IN TABLE B UNIT NUMBER , READ TABLE B - IF(IOLDTB.NE.-99) PRINT *, 'W3FI88 - NEW TABLE B UNIT NUMBER' - IOLDTB = IUNITB - IPTR(14) = 0 - IPTR(21) = 0 - END IF -cdak KEYSER fix 02/02/2001 AAAAA -C IF HAVE CHANGE IN DATA TYPE , RESET TABLE B - IF (IOLD11.EQ.11) THEN - IOLD11 = IDENT(5) - IOLDSB = IDENT(6) -C JUST CONTINUE PROCESSING - ELSE IF (IOLD11.NE.11) THEN - IF (IDENT(5).EQ.11) THEN - IOLD11 = IDENT(5) - IPTR(21) = 0 - ELSE IF (IDENT(5).NE.IOLD11) THEN - IOLD11 = IDENT(5) - IPTR(21) = 0 - ELSE IF (IDENT(5).EQ.IOLD11) THEN -C IF HAVE A CHANGE IN SUBTYPE, RESET TABLE B - IF (IOLDSB.NE.IDENT(6)) THEN - IOLDSB = IDENT(6) - IPTR(21) = 0 -C ELSE IF - END IF - END IF - END IF -C IF BUFR EDITION 0 OR 1 THEN -C NEXT 2 BYTES ARE BUFR TABLE VERSION -C ELSE -C BYTE 11 IS VER NR OF MASTER TABLE -C BYTE 12 IS VER NR OF LOCAL TABLE - IF (IDENT(1).LT.2) THEN - CALL GBYTE (MSGA,IVALS,INOFST,16) - IDENT(7) = IVALS(1) - INOFST = INOFST + 16 - ELSE -C BYTE 11 IS VER NR OF MASTER TABLE - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(18) = IVALS(1) - INOFST = INOFST + 8 -C BYTE 12 IS VER NR OF LOCAL TABLE - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(19) = IVALS(1) - INOFST = INOFST + 8 - - END IF -C YEAR OF CENTURY - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(8) = IVALS(1) - INOFST = INOFST + 8 -C MONTH - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(9) = IVALS(1) - INOFST = INOFST + 8 -C DAY -C PRINT *,'DAY AT ',INOFST - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(10) = IVALS(1) - INOFST = INOFST + 8 -C HOUR - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(11) = IVALS(1) - INOFST = INOFST + 8 -C MINUTE - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(12) = IVALS(1) -C RESET POINTER (INOFST) TO START OF -C NEXT SECTION -C (SECTION 2 OR SECTION 3) - INOFST = IPTR(3) + IPTR(2) * 8 - IPTR(4) = 0 - IPTR(5) = INOFST - IF (SEC2) THEN -C SECTION 2 COUNT - CALL GBYTE (MSGA,IPTR(4),INOFST,24) - INOFST = INOFST + 32 -C PRINT *,'SECTION 2 STARTS AT',INOFST,' BYTES=',IPTR(4) - KENTRY = (IPTR(4) - 4) / 14 -C PRINT *,'SHOULD BE A MAX OF',KENTRY,' REPORTS' - IF (IDENT(2).EQ.7) THEN - DO 2000 I = 1, KENTRY - CALL GBYTE (MSGA,KDSPL ,INOFST,16) - INOFST = INOFST + 16 - CALL GBYTE (MSGA,LAT ,INOFST,16) - INOFST = INOFST + 16 - CALL GBYTE (MSGA,LON ,INOFST,16) - INOFST = INOFST + 16 - CALL GBYTE (MSGA,KDAHR ,INOFST,16) - INOFST = INOFST + 16 - CALL GBYTE (MSGA,DIRID(1),INOFST,32) - INOFST = INOFST + 32 - CALL GBYTE (MSGA,DIRID(2),INOFST,16) - INOFST = INOFST + 16 -C PRINT *,KDSPL,LAT,LON,KDAHR,DIRID(1),DIRID(2) - 2000 CONTINUE - END IF -C RESET POINTER (INOFST) TO START OF -C SECTION 3 - INOFST = IPTR(5) + IPTR(4) * 8 - END IF -C BIT OFFSET TO START OF SECTION 3 - IPTR( 7) = INOFST -C SECTION 3 COUNT - CALL GBYTE (MSGA,IPTR(6),INOFST,24) -C PRINT *,'SECTION 3 STARTS AT',INOFST,' BYTES=',IPTR(6) - INOFST = INOFST + 24 -C SKIP RESERVED BYTE - INOFST = INOFST + 8 -C NUMBER OF DATA SUBSETS - CALL GBYTE (MSGA,IDENT(14),INOFST,16) -C - IF (IDENT(14).GT.MAXR) THEN - PRINT *,'THE NUMBER OF SUBSETS EXCEEDS THE MAXIMUM OF',MAXR - PRINT *,'PASSED INTO W3FI88; MAXR MUST BE INCREASED IN ' - PRINT *,'THE CALLING PROGRAM TO AT LEAST THE VALUE OF' - PRINT *,IDENT(14),'TO BE ABLE TO PROCESS THIS DATA' -C - IPTR(1) = 400 - RETURN - END IF - INOFST = INOFST + 16 -C OBSERVED DATA FLAG - CALL GBYTE (MSGA,IVALS,INOFST,1) - IDENT(15) = IVALS(1) - INOFST = INOFST + 1 -C COMPRESSED DATA FLAG - CALL GBYTE (MSGA,IVALS,INOFST,1) - IDENT(16) = IVALS(1) - INOFST = INOFST + 7 -C CALCULATE NUMBER OF DESCRIPTORS - NRDESC = (IPTR( 6) - 8) / 2 - IPTR(12) = NRDESC - IPTR(13) = NRDESC -C EXTRACT DESCRIPTORS - CALL GBYTES (MSGA,ISTACK,INOFST,16,0,NRDESC) -C PRINT *,'INITIAL DESCRIPTOR LIST OF',NRDESC,' DESCRIPTORS' - DO 10 L = 1, NRDESC - IWORK(L) = ISTACK(L) -C PRINT *,L,ISTACK(L) - 10 CONTINUE - IPTR(13) = NRDESC -C =============================================================== -C -C CONSTRUCT A TABLE B TO MATCH THE -C LIST OF DESCRIPTORS FOR THIS MESSAGE -C - IF (IPTR(21).EQ.0) THEN - PRINT *,'W3FI88- TABLE B NOT YET ENTERED' - CALL FI8812(IPTR,IUNITB,IUNITD,ISTACK,NRDESC,KPTRB,KPTRD, - * IRF1SW,NEWREF,ITBLD,ITBLD2, - * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1, - * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2) - ELSE -C PRINT *,'W3FI88- TABLE B ALL READY IN PLACE' - IF (IPTR(41).NE.0) THEN -C PRINT *,'MERGE',IPTR(41),' ENTRIES INTO TABLE B' -C CALL FI8818(IPTR,KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1, -C * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2,KPTRB) - END IF - END IF - IF (IPTR(1).NE.0) RETURN -C ================================================================ -C RESET POINTER TO START OF SECTION 4 - INOFST = IPTR(7) + IPTR(6) * 8 -C BIT OFFSET TO START OF SECTION 4 - IPTR( 9) = INOFST -C SECTION 4 COUNT - CALL GBYTE (MSGA,IVALS,INOFST,24) -C PRINT *,'SECTION 4 STARTS AT',INOFST,' VALUE',IVALS(1) - IPTR( 8) = IVALS(1) - INOFST = INOFST + 32 -C SET FOR STARTING BIT OF DATA - IPTR(25) = INOFST -C FIND OUT IF '7777' TERMINATOR IS THERE - INOFST = IPTR(9) + IPTR(8) * 8 - CALL GBYTE (MSGA,IVALS,INOFST,32) -C PRINT *,'SECTION 5 STARTS AT',INOFST,' VALUE',IVALS(1) - IF (IVALS(1).NE.926365495) THEN - PRINT *,'BAD SECTION COUNT' - IPTR(1) = 2 - RETURN - ELSE - IPTR(1) = 0 - END IF -C - CALL FI8801(IPTR,IDENT,MSGA,ISTACK,IWORK,KDATA,IVALS, - * MSTACK,KNR,INDEX,MAXR,MAXD, - * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,IRF1SW,INEWVL, - * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2, - * KFXY3,ANAME3,AUNIT3,ISCAL3,IRFVL3,IWIDE3, - * IUNITB,IUNITD,ITBLD,ITBLD2,KPTRB,KPTRD) -C -C PRINT *,'HAVE RETURNED FROM FI8801' - IF (IPTR(1).NE.0) THEN - RETURN - END IF -C FURTHER PROCESSING REQUIRED FOR PROFILER DATA - IF (IDENT(5).EQ.2) THEN - IF (IDENT(6).EQ.7) THEN -C PRINT *,'REFORMAT PROFILER DATA' -C -C DO 7151 I = 1, 40 -C IF (I.LE.20) THEN -C PRINT *,'IPTR(',I,')=',IPTR(I), -C * ' IDENT(',I,')= ',IDENT(I) -C ELSE -C PRINT *,'IPTR(',I,')=',IPTR(I) -C END IF -C7151 CONTINUE -C DO 152 I = 1, IPTR(31) -C PRINT *,MSTACK(1,I),MSTACK(2,I),(KDATA(J,I),J=1,5) -C 152 CONTINUE - IF (IDENT(1).LT.2) THEN - CALL FI8809(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD) - ELSE - CALL FI8810(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD) - END IF -C DO 151 I = 1, 40 -C IF (I.LE.20) THEN -C PRINT *,'IPTR(',I,')=',IPTR(I), -C * ' IDENT(',I,')= ',IDENT(I) -C ELSE -C PRINT *,'IPTR(',I,')=',IPTR(I) -C END IF -C 151 CONTINUE - IF (IPTR(1).NE.0) THEN - RETURN - END IF -C -C DO 154 I = 1, IPTR(31) -C PRINT *,I,MSTACK(1,I),MSTACK(2,I),KDATA(1,I),KDATA(2,I) -C 154 CONTINUE - END IF - END IF -C IF DATA/DESCRIPTOR REPLICATION FLAG IS ON, -C MUST COMPLETE EXPANSION OF DATA AND -C DESCRIPTORS. - IF (IPTR(38).EQ.1) THEN - CALL FI8811(IPTR,IDENT,MSTACK,KDATA,KNR, - * LDATA,LSTACK,MAXD,MAXR) - END IF -C -C IF HAVE A LIST OF TABLE ENTRIES FROM -C A BUFR MESSAGE TYPE 11 -C PRINT OUT THE ENTRIES -C - IF (IDENT(5).EQ.11) THEN -C DO 100 I = 1, IPTR(31)+IPTR(24) -C PRINT *,I,MSTACK(1,I),(KDATA(J,I),J=1,4) -C 100 CONTINUE - CALL FI8813 (IPTR,MAXR,MAXD,MSTACK,KDATA,IDENT,KPTRD,KPTRB, - * ITBLD,ANAME1,AUNIT1,KFXY1,ISCAL1,IRFVL1,IWIDE1,IUNITB) - END IF - RETURN - END - SUBROUTINE FI8801(IPTR,IDENT,MSGA,ISTACK,IWORK,KDATA,IVALS, - * MSTACK,KNR,INDEX,MAXR,MAXD, - * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,IRF1SW,INEWVL, - * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2, - * KFXY3,ANAME3,AUNIT3,ISCAL3,IRFVL3,IWIDE3, - * IUNITB,IUNITD,ITBLD,ITBLD2,KPTRB,KPTRD) -C -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8801 DATA EXTRACTION -C PRGMMR: KEYSER ORG: NP22 DATE: 1995-06-07 -C -C ABSTRACT: CONTROL THE EXTRACTION OF DATA FROM SECTION 4 BASED ON -C DATA DESCRIPTORS. -C -C PROGRAM HISTORY LOG: -C 1988-09-01 CAVANAUGH -C 1991-01-18 CAVANAUGH CORRECTIONS TO PROPERLY HANDLE NON-COMPRESSED -C DATA. -C 1991-09-23 CAVANAUGH CODING ADDED TO HANDLE SINGLE SUBSETS WITH -C DELAYED REPLICATION. -C 1992-01-24 CAVANAUGH MODIFIED TO ECHO DESCRIPTORS TO MSTACK(1,N) -C 1995-06-07 KEYSER CORRECTED AN ERROR WHICH REQUIRED INPUT -C ARGUMENT "MAXD" TO BE NEARLY TWICE AS LARGE -C AS NEEDED FOR DECODING WIND PROFILER REPORTS -C (LIMIT UPPER BOUND FOR "IWORK" ARRAY WAS SET -C TO "MAXD", NOW IT IS SET TO 15000) -C -C USAGE: CALL FI8801(IPTR,IDENT,MSGA,ISTACK,IWORK,KDATA,IVALS, -C * MSTACK,KNR,INDEX,MAXR,MAXD, -C * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,IRF1SW,INEWVL, -C * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2, -C * KFXY3,ANAME3,AUNIT3,ISCAL3,IRFVL3,IWIDE3, -C * IUNITB,IUNITD,ITBLD,ITBLD2,KPTRB) -C -C INPUT ARGUMENT LIST: -C IPTR - SEE W3FI88 ROUTINE DOCBLOCK -C IDENT - SEE W3FI88 ROUTINE DOCBLOCK -C MSGA - ARRAY CONTAINING BUFR MESSAGE -C ISTACK - ORIGINAL ARRAY OF DESCRIPTORS EXTRACTED FROM -C SOURCE BUFR MESSAGE. -C MSTACK - WORKING ARRAY OF DESCRIPTORS (EXPANDED)AND SCALING -C FACTOR -C KFXY1 - IMAGE OF CURRENT DESCRIPTOR -C INDEX - -C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE -C CONTAINED IN A BUFR MESSAGE -C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT -C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE -C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST -C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE -C IUNITB - UNIT NUMBER OF DATA SET HOLDING TABLE B -C IUNITD - UNIT NUMBER OF DATA SET HOLDING TABLE D -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C IWORK - WORKING DESCRIPTOR LIST -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C -C ISTACK - SEE ABOVE -C ARRAYS CONTAINING DATA FROM TABLE B -C KFXY1 - SEE ABOVE -C ANAME1 - DESCRIPTOR NAME -C AUNIT1 - UNITS FOR DESCRIPTOR -C ISCAL1 - SCALE FOR VALUE OF DESCRIPTOR -C IRFVL1 - REFERENCE VALUE FOR DESCRIPTOR -C IWIDE1 - BIT WIDTH FOR VALUE OF DESCRIPTOR -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - FI8802 FI8805 FI8806 FI8807 FI8808 -C -C REMARKS: ERROR RETURN: -C IPTR(1) = 8 ERROR READING TABLE B -C = 9 ERROR READING TABLE D -C = 11 ERROR OPENING TABLE B -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ -C .................................................. -C -C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE -C - INTEGER KFXY2(*),ISCAL2(*),IRFVL2(*),IWIDE2(*) - CHARACTER*64 ANAME2(*) - CHARACTER*24 AUNIT2(*) -C .................................................. -C -C NEW ADDED TABLE B FROM NON-TYPE 11 BUFR MESSAGE -C - INTEGER KFXY3(200),ISCAL3(200),IRFVL3(200),IWIDE3(200) - CHARACTER*64 ANAME3(200) - CHARACTER*24 AUNIT3(200) -C .................................................. -C -C NEW BASE TABLE B -C MAY BE A COMBINATION OF MASTER TABLE B -C AND ANCILLARY TABLE B -C - INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*) - CHARACTER*40 ANAME1(*) - CHARACTER*24 AUNIT1(*) -C .................................................. -C -C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE -C - INTEGER ITBLD2(20,*) -C .................................................. -C -C NEW BASE TABLE D -C - INTEGER ITBLD(20,*) -C .................................................. -C -C - INTEGER MAXD, MAXR -C - INTEGER MSGA(*),KDATA(MAXR,MAXD),IVALS(*) -C - INTEGER KNR(MAXR) - INTEGER LX,LY,LL,J -C INTEGER IHOLD(33) - INTEGER IPTR(*),KPTRB(*),KPTRD(*) - INTEGER IDENT(*) - INTEGER ISTACK(*),IWORK(*) -C - INTEGER MSTACK(2,MAXD) -C - INTEGER JDESC - INTEGER INDEX -C - SAVE -C -C PRINT *,' DECOLL FI8801' - IF (INDEX.GT.1) THEN - GO TO 1000 - END IF -C --------- DECOLL --------------- - IPTR(23) = 0 - IPTR(26) = 0 - IPTR(27) = 0 - IPTR(28) = 0 - IPTR(29) = 0 - IPTR(30) = 0 - IPTR(36) = 0 -C INITIALIZE OUTPUT AREA -C SET POINTER TO BEGINNING OF DATA -C SET BIT - IPTR(17) = 1 - 1000 CONTINUE -C IPTR(12) = IPTR(13) - LL = 0 - IPTR(11) = 1 - IF (IPTR(10).EQ.0) THEN -C RE-ENTRY POINT FOR MULTIPLE -C NON-COMPRESSED REPORTS - ELSE - INDEX = IPTR(15) - IPTR(17) = INDEX - IPTR(25) = IPTR(10) - IPTR(10) = 0 - IPTR(15) = 0 - END IF -C PRINT *,'FI8801 - RPT',IPTR(17),' STARTS AT',IPTR(25) - IPTR(24) = 0 - IPTR(31) = 0 -C POINTING AT NEXT AVAILABLE DESCRIPTOR - MM = 0 - IF (IPTR(21).EQ.0) THEN - NRDESC = IPTR(13) - CALL FI8812(IPTR,IUNITB,IUNITD,ISTACK,NRDESC,KPTRB,KPTRD, - * IRF1SW,NEWREF,ITBLD,ITBLD2, - * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1, - * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2) - END IF - 10 CONTINUE -C PROCESS THRU THE FOLLOWING -C DEPENDING UPON THE VALUE OF 'F' (LF) - MM = MM + 1 - 12 CONTINUE - IF (MM.GT.MAXD) THEN - GO TO 200 - END IF -C END OF CYCLE TEST (SERIAL/SEQUENTIAL) - IF (IPTR(11).GT.IPTR(12)) THEN -C PRINT *,' HAVE COMPLETED REPORT SEQUENCE' - IF (IDENT(16).NE.0) THEN -C PRINT *,' PROCESSING COMPRESSED REPORTS' -C REFORMAT DATA FROM DESCRIPTOR -C FORM TO USER FORM - RETURN - ELSE -C WRITE (6,1) -C 1 FORMAT (1H1) -C PRINT *,' PROCESSED SERIAL REPORT',IPTR(17),IPTR(25) - IPTR(17) = IPTR(17) + 1 - IF (IPTR(17).GT.IDENT(14)) THEN - IPTR(17) = IPTR(17) - 1 - GO TO 200 - END IF - DO 300 I = 1, IPTR(13) - IWORK(I) = ISTACK(I) - 300 CONTINUE -C RESET POINTERS - LL = 0 - IPTR(1) = 0 - IPTR(11) = 1 - IPTR(12) = IPTR(13) -C IS THIS LAST REPORT ? -C PRINT *,'READY',IPTR(39),INDEX - IF (IPTR(39).GT.0) THEN - IF (INDEX.GT.0) THEN -C PRINT *,'HERE IS SUBSET NR',INDEX - RETURN - END IF - END IF - GO TO 1000 - END IF - END IF - 14 CONTINUE -C GET NEXT DESCRIPTOR - CALL FI8808 (IPTR,IWORK,LF,LX,LY,JDESC) -C PRINT *,IPTR(11)-1,'JDESC= ',JDESC,' AND NEXT ', -C * IPTR(11),IWORK(IPTR(11)),IPTR(31) -C PRINT *,IPTR(11)-1,'DESCRIPTOR',JDESC,LF,LX,LY, -C * ' FOR LOC',IPTR(17),IPTR(25) -CVVVVVCHANGE#2 FIX BY KEYSER -- 12/06/1994 -C NOTE: THIS FIX NEEDED BECAUSE IWORK ARRAY DOES NOT HAVE TO BE -C LIMITED TO SIZE OF "MAXD" -- WASTES SPACE BECAUSE "MAXD" -C MUST BECOME OVER TWICE AS LARGE AS NEEDED FOR PROFILERS -C IN ORDER TO AVOID SATISFYING THIS BELOW IF TEST -CDAK IF (IPTR(11).GT.MAXD) THEN - IF (IPTR(11).GT.15000) THEN -CAAAAACHANGE#2 FIX BY KEYSER -- 12/06/1994 - IPTR(1) = 401 - RETURN - END IF -C - KPRM = IPTR(31) + IPTR(24) - IF (KPRM.GT.MAXD) THEN - IF (KPRM.GT.KOLD) THEN - PRINT *,'EXCEEDED ARRAY SIZE',KPRM,IPTR(31), - * IPTR(24) - KOLD = KPRM - END IF - END IF -C REPLICATION PROCESSING - IF (LF.EQ.1) THEN -C ---------- F1 --------- - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - KDATA(IPTR(17),KPRM) = 0 -C PRINT *,'FI8801-1',KPRM,MSTACK(1,KPRM), -C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM) - CALL FI8805(IPTR,IDENT,MSGA,IWORK,LX,LY, - * KDATA,LL,KNR,MSTACK,MAXR,MAXD) -C * KDATA,LL,KNR,MSTACK,MAXR,MAXD) - IF (IPTR(1).NE.0) THEN - RETURN - ELSE - GO TO 12 - END IF -C -C DATA DESCRIPTION OPERATORS - ELSE IF (LF.EQ.2)THEN - IF (LX.EQ.4) THEN - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - KDATA(IPTR(17),KPRM) = 0 -C PRINT *,'FI8801-2',KPRM,MSTACK(1,KPRM), -C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM) - END IF - CALL FI8806 (IPTR,LX,LY,IDENT,MSGA,KDATA,IVALS,MSTACK, - * IWIDE1,IRFVL1,ISCAL1,J,LL,KFXY1,IWORK,JDESC,MAXR,MAXD, - * KPTRB) - IF (IPTR(1).NE.0) THEN - RETURN - END IF - GO TO 12 -C DESCRIPTOR SEQUENCE STRINGS - ELSE IF (LF.EQ.3) THEN -C PRINT *,'F3 SEQUENCE DESCRIPTOR' -C READ IN TABLE D, BUT JUST ONCE - IF (IPTR(20).EQ.0) THEN - CALL FI8820 (ITBLD,IUNITD,IPTR,ITBLD2,KPTRD) - IF (IPTR(1).GT.0) THEN - RETURN - END IF -C ELSE -C IF (IPTR(42).NE.0) THEN -C PRINT *,'MERGE',IPTR(42),' ENTRIES INTO TABLE D' -C CALL FI8819(IPTR,ITBLD,ITBLD2,KPTRD) -C END IF - END IF - CALL FI8807(IPTR,IWORK,ITBLD,ITBLD2,JDESC,KPTRD) - IF (IPTR(1).GT.0) THEN - RETURN - END IF - GO TO 14 -C -C ELEMENT DESCRIPTOR PROCESSING -C - ELSE - KPRM = IPTR(31) + IPTR(24) - CALL FI8802(IPTR,IDENT,MSGA,KDATA,KFXY1,LL,MSTACK, - * AUNIT1,IWIDE1,IRFVL1,ISCAL1,JDESC,IVALS,J,MAXR,MAXD, - * KPTRB) -C TURN OFF SKIP FLAG AFTER STD DESCRIPTOR - IPTR(36) = 0 - IF (IPTR(1).GT.0) THEN - RETURN - ELSE -C -C IF ENCOUNTER CLASS 0 DESCRIPTOR -C NOT CONTAINED WITHIN A BUFR -C MESSAGE OF TYPE 11, THEN COLLECT -C ALL TABLE B ENTRIES FOR USE ON -C CURRENT BUFR MESSAGE -C - IF (JDESC.LE.20.AND.JDESC.GE.10) THEN - IF (IDENT(5).NE.11) THEN -C COLLECT TABLE B ENTRIES - CALL FI8815(IPTR,IDENT,JDESC,KDATA, - * KFXY3,MAXR,MAXD,ANAME3,AUNIT3, - * ISCAL3,IRFVL3,IWIDE3, - * KEYSET,IBFLAG,IERR) - IF (IERR.NE.0) THEN - END IF - IF (IAND(IBFLAG,16).NE.0) THEN - IF (IAND(IBFLAG,8).NE.0) THEN - IF (IAND(IBFLAG,4).NE.0) THEN - IF (IAND(IBFLAG,2).NE.0) THEN - IF (IAND(IBFLAG,1).NE.0) THEN -C HAVE A COMPLETE TABLE B ENTRY - IPTR(43) = IPTR(43) + IDENT(14) - KEYSET = 0 - IBFLAG = 0 - GO TO 1000 - END IF - END IF - END IF - END IF - END IF - END IF - END IF - IF (IDENT(16).EQ.0) THEN - KNR(IPTR(17)) = IPTR(31) - ELSE - DO 310 KJ = 1, MAXR - KNR(KJ) = IPTR(31) - 310 CONTINUE - END IF - GO TO 10 - END IF - END IF -C END IF -C END DO WHILE - 200 CONTINUE -C IF (IDENT(16).NE.0) THEN -C PRINT *,'RETURN WITH',IDENT(14),' COMPRESSED REPORTS' -C ELSE -C PRINT *,'RETURN WITH',IPTR(17),' NON-COMPRESSED REPORTS' -C END IF - RETURN - END - SUBROUTINE FI8802(IPTR,IDENT,MSGA,KDATA,KFXY1,LL,MSTACK,AUNIT1, - * IWIDE1,IRFVL1,ISCAL1,JDESC,IVALS,J,MAXR,MAXD,KPTRB) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8802 PROCESS ELEMENT DESCRIPTOR -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01 -C -C ABSTRACT: PROCESS AN ELEMENT DESCRIPTOR (F = 0) AND STORE DATA -C IN OUTPUT ARRAY. -C -C PROGRAM HISTORY LOG: -C 88-09-01 CAVANAUGH -C 91-04-04 CAVANAUGH CHANGED TO PASS WIDTH OF TEXT FIELDS IN BYTES -C -C USAGE: CALL FI8802(IPTR,IDENT,MSGA,KDATA,KFXY1,LL,MSTACK,AUNIT1, -C IWIDE1,IRFVL1,ISCAL1,JDESC,IVALS,J,MAXR,MAXD,KPTRB) -C INPUT ARGUMENT LIST: -C IPTR - SEE W3FI88 ROUTINE DOCBLOCK -C IDENT - SEE W3FI88 ROUTINE DOCBLOCK -C MSGA - ARRAY CONTAINING BUFR MESSAGE -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C KFXY1 - IMAGE OF CURRENT DESCRIPTOR -C ANAME1 - LIST OF NAME OF DESCRIPTOR CONTENTS -C MSTACK - -C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE -C CONTAINED IN A BUFR MESSAGE -C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT -C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE -C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST -C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KDATA - SEE ABOVE -C KFXY1 - SEE ABOVE -C ARRAYS CONTAINING DATA FROM TABLE B -C AUNIT1 - UNITS FOR DESCRIPTOR -C ISCAL1 - SCALE FOR VALUE OF DESCRIPTOR -C IRFVL1 - REFERENCE VALUE FOR DESCRIPTOR -C IWIDE1 - BIT WIDTH FOR VALUE OF DESCRIPTOR -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - FI8803 FI8804 -C -C REMARKS: ERROR RETURN: -C IPTR(1) = 3 - MESSAGE CONTAINS A DESCRIPTOR WITH F=0 -C THAT DOES NOT EXIST IN TABLE B. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ -C TABLE B ENTRY - CHARACTER*24 ASKEY - INTEGER MSGA(*) - INTEGER IPTR(*) - INTEGER KPTRB(*) - INTEGER IDENT(*) - INTEGER J - INTEGER JDESC - INTEGER MSTACK(2,MAXD) - INTEGER KDATA(MAXR,MAXD),IVALS(*) -C .................................................. -C -C NEW BASE TABLE B -C MAY BE A COMBINATION OF MASTER TABLE B -C AND ANCILLARY TABLE B -C - INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*) -C CHARACTER*40 ANAME1(*) - CHARACTER*24 AUNIT1(*) -C .................................................. - SAVE -C - DATA ASKEY /'CCITT IA5 '/ -C -C PRINT *,' FI8802 - ELEMENT DESCRIPTOR ',JDESC,KPTRB(JDESC) -C FIND TABLE B ENTRY - J = KPTRB(JDESC) -C HAVE A MATCH -C SET FLAG IF TEXT EVENT -C PRINT *,'ASKEY=',ASKEY,'AUNIT1(',J,')=',AUNIT1(J),JDESC - IF (ASKEY(1:9).EQ.AUNIT1(J)(1:9)) THEN - IPTR(18) = 1 - IPTR(40) = IWIDE1(J) / 8 - ELSE - IPTR(18) = 0 - END IF -C PRINT *,'FI8802 - BIT WIDTH =',IWIDE1(J),IPTR(18),' FOR',JDESC - IF (IDENT(16).NE.0) THEN -C COMPRESSED - CALL FI8803(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK, - * IWIDE1,IRFVL1,ISCAL1,J,JDESC,MAXR,MAXD) -C IF (IPTR(1).NE.0) THEN -C RETURN -C END IF - ELSE -C NOT COMPRESSED -C PRINT *,' FROM FI8802',J - CALL FI8804(IPTR,MSGA,KDATA,IVALS,MSTACK, - * IWIDE1,IRFVL1,ISCAL1,J,LL,JDESC,MAXR,MAXD) -C IF (IPTR(1).NE.0) THEN -C RETURN -C END IF - END IF - RETURN - END -C ----------------------------------------------------- - SUBROUTINE FI8803(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK, - * IWIDE1,IRFVL1,ISCAL1,J,JDESC,MAXR,MAXD) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8803 PROCESS COMPRESSED DATA -C PRGMMR: KEYSER ORG: NP22 DATE: 1995-06-07 -C -C ABSTRACT: PROCESS COMPRESSED DATA AND PLACE INDIVIDUAL ELEMENTS -C INTO OUTPUT ARRAY. -C -C PROGRAM HISTORY LOG: -C 1988-09-01 CAVANAUGH -C 1991-04-04 CAVANAUGH TEXT HANDLING PORTION OF THIS ROUTINE -C MODIFIED TO HANLE WIDTH OF FIELDS IN BYTES. -C 1991-04-17 CAVANAUGH TESTS SHOWED THAT THE SAME DATA IN COMPRESSED -C AND UNCOMPRESSED FORM GAVE DIFFERENT RESULTS. -C THIS HAS BEEN CORRECTED. -C 1991-06-21 CAVANAUGH PROCESSING OF TEXT DATA HAS BEEN CHANGED TO -C PROVIDE EXACT REPRODUCTION OF ALL CHARACTERS. -C 1994-04-11 CAVANAUGH CORRECTED PROCESSING OF DATA WHEN ALL VALUES -C THE SAME (NBINC = 0). CORRECTED TEST OF LOWEST -C VALUE AGAINST PROPER BIT MASK. -C 1995-06-07 KEYSER CORRECTED AN ERROR WHICH RESULTED IN -C RETURNED SCALE IN "MSTACK(2, ..)" ALWAYS -C BEING SET TO ZERO FOR COMPRESSED DATA. ALSO, -C SCALE CHANGES WERE NOT BEING RECOGNIZED. -C -C USAGE: CALL FI8803(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK, -C IWIDE1,IRFVL1,ISCAL1,J,JDESC,MAXR,MAXD) -C INPUT ARGUMENT LIST: -C IPTR - SEE W3FI88 ROUTINE DOCBLOCK -C IDENT - SEE W3FI88 ROUTINE DOCBLOCK -C MSGA - ARRAY CONTAINING BUFR MESSAGE,MSTACK, -C IVALS - ARRAY OF SINGLE PARAMETER VALUES -C J - -C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE -C CONTAINED IN A BUFR MESSAGE -C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT -C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE -C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST -C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C J - -C ARRAYS CONTAINING DATA FROM TABLE B -C ISCAL1 - SCALE FOR VALUE OF DESCRIPTOR -C IRFVL1 - REFERENCE VALUE FOR DESCRIPTOR -C IWIDE1 - BIT WIDTH FOR VALUE OF DESCRIPTOR -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - GBYTE GBYTES W3AI39 -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ -C -C .................................................. -C -C NEW BASE TABLE B -C MAY BE A COMBINATION OF MASTER TABLE B -C AND ANCILLARY TABLE B -C -C INTEGER KFXY1(*) - INTEGER ISCAL1(*) - INTEGER IRFVL1(3,*) - INTEGER IWIDE1(*) -C CHARACTER*40 ANAME1(*) -C CHARACTER*24 AUNIT1(*) -C .................................................. - INTEGER MAXD,MAXR - INTEGER MSGA(*),JDESC,MSTACK(2,MAXD) - INTEGER IPTR(*),IVALS(*),KDATA(MAXR,MAXD) - INTEGER NRVALS,JWIDE,IDATA - INTEGER IDENT(*) - INTEGER J - INTEGER KLOW(256) -C - LOGICAL TEXT -C - INTEGER MSK(32) -C - SAVE -C - DATA MSK /1, 3, 7, 15, 31, 63, 127, -C 1 2 3 4 5 6 7 - * 255, 511, 1023, 2047, 4095, -C 8 9 10 11 12 - * 8191, 16383, 32767, 65535, -C 13 14 15 16 - * 131071, 262143, 524287, -C 17 18 19 - * 1048575, 2097151, 4194303, -C 20 21 22 - * 8388607, 16777215, 33554431, -C 23 24 25 - * 67108863, 134217727, 268435455, -C 26 27 28 - * 536870911, 1073741823, 2147483647,-1 / -C 29 30 31 32 - CALL W3FI01(LW) - MWDBIT = IPTR(44) - IF (IPTR(45).EQ.8) THEN - I = 2147483647 - MSK(32) = I + I + 1 - END IF -C -C PRINT *,' FI8803 COMPR J=',J,' IWIDE1(J) =',IWIDE1(J), -C * ' EXTRA BITS =',IPTR(26),' START AT',IPTR(25) - IF (IPTR(18).EQ.0) THEN - TEXT = .FALSE. - ELSE - TEXT = .TRUE. - END IF -C PRINT *,'DESCRIPTOR',KPRM,JDESC - IF (.NOT.TEXT) THEN - IF (IPTR(29).GT.0.AND.JDESC.NE.7957) THEN -C PRINT *,'ASSOCIATED FIELD AT',IPTR(25) -C WORKING WITH ASSOCIATED FIELDS HERE - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) -C GET LOWEST - CALL GBYTE (MSGA,LOWEST,IPTR(25),IPTR(29)) - IPTR(25) = IPTR(25) + IPTR(29) -C GET NBINC - CALL GBYTE (MSGA,NBINC,IPTR(25),6) - IPTR(25) = IPTR(25) + 6 -C PRINT *,'LOWEST=',LOWEST,' NBINC=',NBINC - IF (NBINC.GT.32) THEN - IPTR(1) = 22 - RETURN - END IF -C EXTRACT DATA FOR ASSOCIATED FIELD - IF (NBINC.GT.0) THEN - CALL GBYTES (MSGA,IVALS,IPTR(25),NBINC,0,IPTR(21)) - IPTR(25) = IPTR(25) + NBINC * IPTR(21) - DO 50 I = 1, IDENT(14) - KDATA(I,KPRM) = IVALS(I) + LOWEST - IF (NBINC.EQ.32) THEN - IF (KDATA(I,KPRM).EQ.MSK(NBINC)) THEN - KDATA(I,KPRM) = 999999 - END IF - ELSE IF (KDATA(I,KPRM).GE.MSK(NBINC)) THEN - KDATA(I,KPRM) = 999999 - END IF - 50 CONTINUE - ELSE - DO 51 I = 1, IDENT(14) - KDATA(I,KPRM) = LOWEST - IF (NBINC.EQ.32) THEN - IF (LOWEST.EQ.MSK(32)) THEN - KDATA(I,KPRM) = 999999 - END IF - ELSE IF(LOWEST.GE.MSK(NBINC)) THEN - KDATA(I,KPRM) = 999999 - END IF - 51 CONTINUE - END IF - END IF -C SET PARAMETER -C ISOLATE COMBINED BIT WIDTH - JWIDE = IWIDE1(J) + IPTR(26) -C - IF (JWIDE.GT.32) THEN -C TOO MANY BITS IN COMBINED -C BIT WIDTH - PRINT *,'ERR 22 - HAVE EXCEEDED COMBINED BIT WIDTH' - IPTR(1) = 22 - RETURN - END IF -C SINGLE VALUE FOR LOWEST - NRVALS = 1 -C LOWEST -C PRINT *,'PARAM',KPRM - CALL GBYTE (MSGA,LOWEST,IPTR(25),JWIDE) -C PRINT *,' LOWEST=',LOWEST,' AT BIT LOC ',IPTR(25) - IPTR(25) = IPTR(25) + JWIDE -C ISOLATE COMPRESSED BIT WIDTH - CALL GBYTE (MSGA,NBINC,IPTR(25),6) -C PRINT *,' NBINC=',NBINC,' AT BIT LOC',IPTR(25) - IF (NBINC.GT.32) THEN -C NBINC TOO LARGE - IPTR(1) = 22 - RETURN - END IF - IF (IPTR(32).EQ.2.AND.IPTR(33).EQ.5) THEN - ELSE - IF (NBINC.GT.JWIDE) THEN -C PRINT *,'FOR DESCRIPTOR',JDESC -C PRINT *,J,'NBINC=',NBINC,' LOWEST=',LOWEST,' IWIDE1(J)=', -C * IWIDE1(J),' IPTR(26)=',IPTR(26),' AT BIT LOC',IPTR(25) -C DO 110 I = 1, KPRM -C WRITE (6,111)I,(KDATA(J,I),J=1,6) -C 110 CONTINUE -C 111 FORMAT (1X,5HDATA ,I3,6(2X,I10)) - IPTR(1) = 500 - PRINT *,'NBINC CALLS FOR LARGER BIT WIDTH THAN TABLE', - * ' B PLUS WIDTH CHANGES' - END IF - END IF - IPTR(25) = IPTR(25) + 6 -C PRINT *,'LOWEST',LOWEST,' NBINC=',NBINC -C IF TEXT EVENT, PROCESS TEXT -C GET COMPRESSED VALUES -C PRINT *,'COMPRESSED VALUES - NONTEXT' - NRVALS = IDENT(14) - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - IF (NBINC.NE.0) THEN - CALL GBYTES (MSGA,IVALS,IPTR(25),NBINC,0,NRVALS) - IPTR(25) = IPTR(25) + NBINC * NRVALS -C RECALCULATE TO ORIGINAL VALUES - DO 100 I = 1, NRVALS -C PRINT *,IVALS(I),MSK(NBINC),NBINC - IF (IVALS(I).GE.MSK(NBINC)) THEN - KDATA(I,KPRM) = 999999 - ELSE - IF (IRFVL1(2,J).EQ.0) THEN - JRV = IRFVL1(1,J) - ELSE - JRV = IRFVL1(3,J) - END IF - KDATA(I,KPRM) = IVALS(I) + LOWEST + JRV - END IF - 100 CONTINUE -C PRINT *,I,JDESC,LOWEST,IRFVL1(1,J),IRFVL1(3,J) - ELSE - IF (LOWEST.EQ.MSK(JWIDE)) THEN - DO 105 I = 1, NRVALS - KDATA(I,KPRM) = 999999 - 105 CONTINUE - ELSE - IF (IRFVL1(2,J).EQ.0) THEN - JRV = IRFVL1(1,J) - ELSE - JRV = IRFVL1(3,J) - END IF - ICOMB = LOWEST + JRV - DO 106 I = 1, NRVALS - KDATA(I,KPRM) = ICOMB - 106 CONTINUE - END IF - END IF -C PRINT *,'KPRM=',KPRM,' IPTR(25)=',IPTR(25) - MSTACK(1,KPRM) = JDESC -C WRITE (6,80) (KDATA(I,KPRM),I=1,10) - 80 FORMAT(2X,10(F10.2,1X)) -CVVVVVCHANGE#3 FIX BY KEYSER -- 12/06/1994 -C NOTE: THIS FIX NEEDED BECAUSE THE RETURNED SCALE IN MSTACK(2,..) -C WAS ALWAYS '0' FOR COMPRESSED DATA, INCL. CHANGED SCALES) - MSTACK(2,KPRM) = ISCAL1(J) + IPTR(27) -CAAAAACHANGE#3 FIX BY KEYSER -- 12/06/1994 - ELSE IF (TEXT) THEN -C PRINT *,' FOUND TEXT MODE IN COMPRESSED DATA',IPTR(40) -C GET LOWEST -C PRINT *,' PICKED UP LOWEST',(KLOW(K),K=1,IPTR(40)) - DO 1906 K = 1, IPTR(40) - CALL GBYTE (MSGA,KLOW,IPTR(25),8) - IPTR(25) = IPTR(25) + 8 - IF (KLOW(K).NE.0) THEN - IPTR(1) = 27 - PRINT *,'NON-ZERO LOWEST ON TEXT DATA' - RETURN - END IF - 1906 CONTINUE -C PRINT *,'TEXT - LOWEST = 0' -C GET NBINC - CALL GBYTE (MSGA,NBINC,IPTR(25),6) - IPTR(25) = IPTR(25) + 6 - IF (NBINC.NE.IPTR(40)) THEN - IPTR(1) = 28 - PRINT *,'NBINC IS NOT THE NUMBER OF CHARACTERS',NBINC - RETURN - END IF -C PRINT *,'TEXT NBINC =',NBINC -C FOR NUMBER OF OBSERVATIONS - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - ISTART = KPRM - I24 = IPTR(24) - DO 1900 N = 1, IDENT(14) - KPRM = ISTART - IPTR(24) = I24 - NBITS = IPTR(40) * 8 - 1700 CONTINUE -C PRINT *,N,IDENT(14),'KPRM-B=',KPRM,IPTR(24),NBITS - IF (NBITS.GT.MWDBIT) THEN - CALL GBYTE (MSGA,IDATA,IPTR(25),MWDBIT) - IPTR(25) = IPTR(25) + MWDBIT - NBITS = NBITS - MWDBIT - IF (IPTR(37).EQ.0) THEN -C CONVERTS ASCII TO EBCIDIC - CALL W3AI39 (IDATA,LW) - END IF - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - KDATA(N,KPRM) = IDATA -C PRINT *,'TEXT ',N,KPRM,KDATA(N,KPRM) -C SET FOR NEXT PART - KPRM = KPRM + 1 - IPTR(24) = IPTR(24) + 1 -C PRINT 1701,1,KDATA(N,KPRM),N,KPRM,NBITS,IDATA -C1701 FORMAT (1X,I1,1X,6HKDATA=,A4,2X,I5,2X,I5,2X,I5,2X,I12) - GO TO 1700 - ELSE IF (NBITS.GT.0) THEN - CALL GBYTE (MSGA,IDATA,IPTR(25),NBITS) - IPTR(25) = IPTR(25) + NBITS - IBUF = (IPTR(44) - NBITS) / 8 - IF (IBUF.GT.0) THEN - DO 1750 MP = 1, IBUF - IDATA = IDATA * 256 + 32 - 1750 CONTINUE - END IF -C CONVERTS ASCII TO EBCIDIC - IF (IPTR(37).EQ.0) THEN - CALL W3AI39 (IDATA,LW) - END IF - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - KDATA(N,KPRM) = IDATA -C PRINT *,'TEXT ',N,KPRM,KDATA(N,KPRM) -C PRINT 1701,2,KDATA(N,KPRM),N,KPRM,NBITS - NBITS = 0 - END IF -C WRITE (6,1800)N,(KDATA(N,I),I=KPRS,KPRM) -C1800 FORMAT (2X,I4,2X,3A4) - 1900 CONTINUE - END IF - RETURN - END -C ----------------------------------------------------- - SUBROUTINE FI8804(IPTR,MSGA,KDATA,IVALS,MSTACK, - * IWIDE1,IRFVL1,ISCAL1,J,LL,JDESC,MAXR,MAXD) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8804 PROCESS SERIAL DATA -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01 -C -C ABSTRACT: PROCESS DATA THAT IS NOT COMPRESSED -C -C PROGRAM HISTORY LOG: -C 88-09-01 CAVANAUGH -C 91-01-18 CAVANAUGH MODIFIED TO PROPERLY HANDLE NON-COMPRESSED -C DATA. -C 91-04-04 CAVANAUGH TEXT HANDLING PORTION OF THIS ROUTINE -C MODIFIED TO HANDLE FIELD WIDTH IN BYTES. -C 91-04-17 CAVANAUGH TESTS SHOWED THAT THE SAME DATA IN COMPRESSED -C AND UNCOMPRESSED FORM GAVE DIFFERENT RESULTS. -C THIS HAS BEEN CORRECTED. -C -C USAGE: CALL FI8804(IPTR,MSGA,KDATA,IVALS,MSTACK, -C IWIDE1,IRFVL1,ISCAL1,J,LL,JDESC,MAXR,MAXD) -C INPUT ARGUMENT LIST: -C IPTR - SEE W3FI88 ROUTINE DOCBLOCK -C MSGA - ARRAY CONTAINING BUFR MESSAGE -C IVALS - ARRAY OF SINGLE PARAMETER VALUES -C J - -C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE -C CONTAINED IN A BUFR MESSAGE -C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT -C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE -C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST -C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C IVALS - SEE ABOVE -C J - SEE ABOVE -C ARRAYS CONTAINING DATA FROM TABLE B -C ISCAL1 - SCALE FOR VALUE OF DESCRIPTOR -C IRFVL1 - REFERENCE VALUE FOR DESCRIPTOR -C IWIDE1 - BIT WIDTH FOR VALUE OF DESCRIPTOR -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - GBYTE -C -C REMARKS: ERROR RETURN: -C IPTR(1) = 13 - BIT WIDTH ON ASCII CHARS NOT A MULTIPLE OF 8 -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ -C .................................................. -C -C NEW BASE TABLE B -C MAY BE A COMBINATION OF MASTER TABLE B -C AND ANCILLARY TABLE B -C -C INTEGER KFXY1(*) - INTEGER ISCAL1(*) - INTEGER IRFVL1(3,*) - INTEGER IWIDE1(*) -C CHARACTER*40 ANAME1(*) -C CHARACTER*24 AUNIT1(*) -C .................................................. -C - INTEGER MSGA(*),MAXD,MAXR - INTEGER IPTR(*) - INTEGER JDESC - INTEGER IVALS(*) -C INTEGER LSTBLK(3) - INTEGER KDATA(MAXR,MAXD),MSTACK(2,MAXD) - INTEGER J,LL -C LOGICAL LKEY -C -C - INTEGER ITEST(32) -C - SAVE -C - DATA ITEST /1,3,7,15,31,63,127,255, - * 511,1023,2047,4095,8191,16383, - * 32767, 65535,131071,262143,524287, - * 1048575,2097151,4194303,8388607, - * 16777215,33554431,67108863,134217727, - * 268435455,536870911,1073741823, - * 2147483647,-1/ -C - MWDBIT = IPTR(44) - IF (IPTR(45).NE.4) THEN - I = 2147483647 - ITEST(32) = I + I + 1 - END IF -C -C PRINT *,' FI8804 NOCMP',J,JDESC,IWIDE1(J),IPTR(26),IPTR(25) -C -------- NOCMP -------- -C IF NOT TEXT EVENT, PROCESS - IF (IPTR(18).EQ.0) THEN -C PRINT *,' NOT TEXT' - IF ((IPTR(26)+IWIDE1(J)).LT.1) THEN -C PRINT *,' FI8804 NOCMP',J,JDESC,IWIDE1(J),IPTR(26),IPTR(25) - IPTR(1) = 501 - RETURN - END IF -C ISOLATE BIT WIDTH - JWIDE = IWIDE1(J) + IPTR(26) -C IF ASSOCIATED FIELD SW ON - IF (IPTR(29).GT.0) THEN - IF (JDESC.NE.7957.AND.JDESC.NE.7937) THEN - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = 33792 + IPTR(29) - MSTACK(2,KPRM) = 0 - CALL GBYTE (MSGA,IVALS,IPTR(25),IPTR(29)) - IPTR(25) = IPTR(25) + IPTR(29) - KDATA(IPTR(17),KPRM) = IVALS(1) -C PRINT *,'FI8804-A',KPRM,MSTACK(1,KPRM), -C * MSTACK(2,KPRM),IPTR(17),KDATA(IPTR(17),KPRM) - END IF - END IF - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = JDESC -C IF (IPTR(27).NE.0) THEN -C MSTACK(2,KPRM) = IPTR(27) -C ELSE - MSTACK(2,KPRM) = ISCAL1(J) + IPTR(27) -C END IF -C GET VALUES -C CALL TO GET DATA OF GIVEN BIT WIDTH - CALL GBYTE (MSGA,IVALS,IPTR(25),JWIDE) -C PRINT *,'DATA TO',IPTR(17),KPRM,IVALS(1),JWIDE,IPTR(25) - IPTR(25) = IPTR(25) + JWIDE -C RETURN WITH SINGLE VALUE - IF (IRFVL1(2,J).EQ.0) THEN - JRV = IRFVL1(1,J) - ELSE - JRV = IRFVL1(3,J) - END IF - IF (JWIDE.EQ.32) THEN - IF (IVALS(1).EQ.ITEST(JWIDE)) THEN - KDATA(IPTR(17),KPRM) = 999999 - ELSE - KDATA(IPTR(17),KPRM) = IVALS(1) + JRV - END IF - ELSE IF (IVALS(1).GE.ITEST(JWIDE)) THEN - KDATA(IPTR(17),KPRM) = 999999 - ELSE - KDATA(IPTR(17),KPRM) = IVALS(1) + JRV - END IF -C PRINT *,'FI8804-B',KPRM,MSTACK(1,KPRM), -C * MSTACK(2,KPRM),IPTR(17),KDATA(IPTR(17),KPRM) -C IF(JDESC.EQ.2049) THEN -C PRINT *,'VERT SIG =',KDATA(IPTR(17),KPRM) -C END IF -C PRINT *,'FI8804 ',KPRM,MSTACK(1,KPRM), -C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM) - ELSE -C PRINT *,' TEXT' -C PRINT *,' FOUND TEXT MODE ****** NOT COMPRESSED *********' - JWIDE = IPTR(40) * 8 -C PRINT *,' WIDTH =',JWIDE,IPTR(40) - NRCHRS = IPTR(40) - NRBITS = JWIDE -C PRINT *,' CHARS =',NRCHRS,' BITS =',NRBITS - IPTR(31) = IPTR(31) + 1 - KANY = 0 - 1800 CONTINUE - KANY = KANY + 1 -C PRINT *,' NR BITS THIS PASS',NRBITS - IF (NRBITS.GT.MWDBIT) THEN - CALL GBYTE (MSGA,IDATA,IPTR(25),MWDBIT) -C PRINT 1801,KANY,IDATA,IPTR(17),KPRM,NRBITS - 1801 FORMAT (1X,I2,4X,Z8,2(4X,I4)) -C CONVERTS ASCII TO EBCIDIC -C COMMENT OUT IF NOT IBM370 COMPUTER - IF (IPTR(37).EQ.0) THEN - CALL W3AI39 (IDATA,IPTR(45)) - END IF - KPRM = IPTR(31) + IPTR(24) - KDATA(IPTR(17),KPRM) = IDATA - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 -C PRINT *,'BODY ',KPRM,MSTACK(1,KPRM),MSTACK(2,KPRM), -C * KDATA(IPTR(17),KPRM) - IPTR(25) = IPTR(25) + MWDBIT - NRBITS = NRBITS - MWDBIT - IPTR(24) = IPTR(24) + 1 - GO TO 1800 - ELSE IF (NRBITS.GT.0) THEN - CALL GBYTE (MSGA,IDATA,IPTR(25),NRBITS) - IPTR(25) = IPTR(25) + NRBITS -C CONVERTS ASCII TO EBCIDIC -C COMMENT OUT IF NOT IBM370 COMPUTER - IF (IPTR(37).EQ.0) THEN - CALL W3AI39 (IDATA,IPTR(45)) - END IF - KPRM = IPTR(31) + IPTR(24) - KSHFT = MWDBIT - NRBITS - IF (KSHFT.GT.0) THEN - KTRY = KSHFT / 8 - DO 1722 LAK = 1, KTRY - IF (IPTR(37).EQ.0) THEN - IDATA = IDATA * 256 + 64 - ELSE - IDATA = IDATA * 256 + 32 - END IF -C PRINT 1723,IDATA -C1723 FORMAT (12X,Z8) - 1722 CONTINUE - END IF - KDATA(IPTR(17),KPRM) = IDATA -C PRINT 1801,KANY,IDATA,KDATA(IPTR(17),KPRM),KPRM - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 -C PRINT *,'TAIL ',KPRM,MSTACK(1,KPRM), -C * KDATA(IPTR(17),KPRM) - END IF - END IF - RETURN - END -C ----------------------------------------------------- - SUBROUTINE FI8805(IPTR,IDENT,MSGA,IWORK,LX,LY, - * KDATA,LL,KNR,MSTACK,MAXR,MAXD) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8805 PROCESS A REPLICATION DESCRIPTOR -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01 -C -C ABSTRACT: PROCESS A REPLICATION DESCRIPTOR, MUST EXTRACT NUMBER -C OF REPLICATIONS OF N DESCRIPTORS FROM THE DATA STREAM. -C -C PROGRAM HISTORY LOG: -C 88-09-01 CAVANAUGH -C YY-MM-DD MODIFIER2 DESCRIPTION OF CHANGE -C -C USAGE: CALL FI8805(IPTR,IDENT,MSGA,IWORK,LX,LY, -C * KDATA,LL,KNR,MSTACK,MAXR,MAXD) -C INPUT ARGUMENT LIST: -C IWORK - WORKING DESCRIPTOR LIST -C IPTR - SEE W3FI88 ROUTINE DOCBLOCK -C IDENT - SEE W3FI88 ROUTINE DOCBLOCK -C LX - X PORTION OF CURRENT DESCRIPTOR -C LY - Y PORTION OF CURRENT DESCRIPTOR -C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE -C CONTAINED IN A BUFR MESSAGE -C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT -C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE -C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST -C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C LX - SEE ABOVE -C LY - SEE ABOVE -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - GBYTES FI8808 -C -C REMARKS: ERROR RETURN: -C IPTR(1) = 12 DATA DESCRIPTOR QUALIFIER DOES NOT FOLLOW -C DELAYED REPLICATION DESCRIPTOR -C = 20 EXCEEDED COUNT FOR DELAYED REPLICATION PASS -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ -C - INTEGER IPTR(*) - INTEGER KNR(MAXR) - INTEGER ITEMP(2000) - INTEGER LL - INTEGER KTEMP(2000) - INTEGER KDATA(MAXR,MAXD) - INTEGER LX,MSTACK(2,MAXD) - INTEGER LY - INTEGER MSGA(*) - INTEGER KVALS(1300) -CVVVVVCHANGE#2 FIX BY KEYSER -- 12/06/1994 -C NOTE: THIS FIX JUST CLEANS UP CODE SINCE IWORK ARRAY IS EARLIER -C DEFINED AS 15000 WORDS - INTEGER IWORK(*) -CDAK INTEGER IWORK(MAXD) -CAAAAACHANGE#2 FIX BY KEYSER -- 12/06/1994 - INTEGER IDENT(*) -C - SAVE -C -C PRINT *,' REPLICATION FI8805' -C DO 7100 I = 1, IPTR(13) -C PRINT *,I,IWORK(I) -C7100 CONTINUE -C NUMBER OF DESCRIPTORS - NRSET = LX -C NUMBER OF REPLICATIONS - NRREPS = LY - ICURR = IPTR(11) - 1 - IPICK = IPTR(11) - 1 -C - IF (NRREPS.EQ.0) THEN - IPTR(39) = 1 -C SAVE PRIMARY DELAYED REPLICATION DESCRIPTOR -C IPTR(31) = IPTR(31) + 1 -C KPRM = IPTR(31) + IPTR(24) -C MSTACK(1,KPRM) = JDESC -C MSTACK(2,KPRM) = 0 -C KDATA(IPTR(17),KPRM) = 0 -C PRINT *,'FI8805-1',KPRM,MSTACK(1,KPRM), -C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM) -C DELAYED REPLICATION - MUST GET NUMBER OF -C REPLICATIONS FROM DATA. -C GET NEXT DESCRIPTOR - CALL FI8808(IPTR,IWORK,LF,LX,LY,JDESC) -C PRINT *,' DELAYED REPLICATION',LF,LX,LY,JDESC -C MUST BE DATA DESCRIPTION -C OPERATION QUALIFIER - IF (JDESC.EQ.7937.OR.JDESC.EQ.7947) THEN - JWIDE = 8 - ELSE IF (JDESC.EQ.7938.OR.JDESC.EQ.7948) THEN - JWIDE = 16 - ELSE IF (JDESC.EQ.7936) THEN - JWIDE = 1 - ELSE - IPTR(1) = 12 - RETURN - END IF -C THIS IF BLOCK IS SET TO HANDLE -C DATA/DESCRIPTOR REPLICATION - IF (JDESC.EQ.7947.OR.JDESC.EQ.7948) THEN -C SET DATA/DESCRIPTOR REPLICATION FLAG = ON - IPTR(38) = 1 -C SAVE AS NEXT ENTRY IN KDATA, MSTACK - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - CALL GBYTE (MSGA,KVALS,IPTR(25),JWIDE) - IPTR(25) = IPTR(25) + JWIDE - KDATA(IPTR(17),KPRM) = KVALS(1) - RETURN - END IF - -C SET SINGLE VALUE FOR SEQUENTIAL, -C MULTIPLE VALUES FOR COMPRESSED - IF (IDENT(16).EQ.0) THEN - -C NON COMPRESSED - CALL GBYTE (MSGA,KVALS,IPTR(25),JWIDE) -C PRINT *,LF,LX,LY,JDESC,' NR OF REPLICATIONS',KVALS(1) - IPTR(25) = IPTR(25) + JWIDE - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - KDATA(IPTR(17),KPRM) = KVALS(1) - NRREPS = KVALS(1) -C PRINT *,'FI8805-2',KPRM,MSTACK(1,KPRM), -C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM) - ELSE - NRVALS = IDENT(14) - CALL GBYTES (MSGA,KVALS,IPTR(25),JWIDE,0,NRVALS) - IPTR(25) = IPTR(25) + JWIDE * NRVALS - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - KDATA(IPTR(17),KPRM) = KVALS(1) - DO 100 I = 1, NRVALS - KDATA(I,KPRM) = KVALS(I) - 100 CONTINUE - NRREPS = KVALS(1) - END IF - ELSE -C PRINT *,'NOT DELAYED REPLICATION' - END IF -C RESTRUCTURE WORKING STACK W/REPLICATIONS - IF (NRREPS.EQ.0) THEN -C PRINT *,'RESTRUCTURING - NO REPLICATION' - IPTR(11) = IPICK + NRSET + 2 - GO TO 9999 - END IF -C PRINT *,' SAVE OFF',NRSET,' DESCRIPTORS' -C PICK UP DESCRIPTORS TO BE REPLICATED - DO 1000 I = 1, NRSET - CALL FI8808(IPTR,IWORK,LF,LX,LY,JDESC) - ITEMP(I) = JDESC -C PRINT *,'REPLICATION ',I,ITEMP(I) - 1000 CONTINUE -C MOVE TRAILING DESCRIPTORS TO HOLD AREA - LAX = IPTR(12) - IPTR(11) + 1 -C PRINT *,LAX,' TRAILING DESCRIPTORS TO HOLD AREA',IPTR(11),IPTR(12) - DO 2000 I = 1, LAX - CALL FI8808(IPTR,IWORK,LF,LX,LY,JDESC) - KTEMP(I) = JDESC -C PRINT *,' ',I,KTEMP(I) - 2000 CONTINUE -C REPLICATIONS INTO ISTACK -C PRINT *,' MUST REPLICATE ',KX,' DESCRIPTORS',KY,' TIMES' -C PRINT *,'REPLICATIONS INTO STACK. LOC',ICURR - DO 4000 I = 1, NRREPS - DO 3000 J = 1, NRSET - IWORK(ICURR) = ITEMP(J) -C PRINT *,'FI8805 A',ICURR,IWORK(ICURR) - ICURR = ICURR + 1 - 3000 CONTINUE - 4000 CONTINUE -C PRINT *,' TO LOC',ICURR-1 -C RESTORE TRAILING DESCRIPTORS -C PRINT *,'TRAILING DESCRIPTORS INTO STACK. LOC',ICURR - DO 5000 I = 1, LAX - IWORK(ICURR) = KTEMP(I) -C PRINT *,'FI8805 B',ICURR,IWORK(ICURR) - ICURR = ICURR + 1 - 5000 CONTINUE - IPTR(12) = ICURR - 1 - IPTR(11) = IPICK - 9999 CONTINUE -C DO 5500 I = 1, IPTR(12) -C PRINT *,'FI8805 B',I,IWORK(I),IPTR(11) -C5500 CONTINUE - RETURN - END - SUBROUTINE FI8806 (IPTR,LX,LY,IDENT,MSGA,KDATA,IVALS,MSTACK, - * IWIDE1,IRFVL1,ISCAL1,J,LL,KFXY1,IWORK,JDESC,MAXR,MAXD,KPTRB) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8806 PROCESS OPERATOR DESCRIPTORS -C PRGMMR: CAVANAUGH ORG: W/NMCX42 DATE: 88-09-01 -C -C ABSTRACT: EXTRACT AND SAVE INDICATED CHANGE VALUES FOR USE -C UNTIL CHANGES ARE RESCINDED, OR EXTRACT TEXT STRINGS INDICATED -C THROUGH 2 05 YYY. -C -C PROGRAM HISTORY LOG: -C 88-09-01 CAVANAUGH -C 91-04-04 CAVANAUGH MODIFIED TO HANDLE DESCRIPTOR 2 05 YYY -C 91-05-10 CAVANAUGH CODING HAS BEEN ADDED TO PROCESS PROPERLY -C TABLE C DESCRIPTOR 2 06 YYY. -C 91-11-21 CAVANAUGH CODING HAS BEEN ADDED TO PROPERLY PROCESS -C TABLE C DESCRIPTOR 2 03 YYY, THE CHANGE -C TO NEW REFERENCE VALUE FOR SELECTED -C DESCRIPTORS. -C -C USAGE: CALL FI8806 (IPTR,LX,LY,IDENT,MSGA,KDATA,IVALS,MSTACK, -C * IWIDE1,IRFVL1,ISCAL1,J,LL,KFXY1,IWORK,JDESC,MAXR,MAXD,KPTRB) -C INPUT ARGUMENT LIST: -C IPTR - SEE W3FI88 ROUTINE DOCBLOCK -C LX - X PORTION OF CURRENT DESCRIPTOR -C LY - Y PORTION OF CURRENT DESCRIPTOR -C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE -C CONTAINED IN A BUFR MESSAGE -C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT -C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE -C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST -C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE -C -C OUTPUT ARGUMENT LIST: -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C ARRAYS CONTAINING DATA FROM TABLE B -C ISCAL1 - SCALE FOR VALUE OF DESCRIPTOR -C IRFVL1 - REFERENCE VALUE FOR DESCRIPTOR -C IWIDE1 - BIT WIDTH FOR VALUE OF DESCRIPTOR -C -C REMARKS: ERROR RETURN: -C IPTR(1) = 5 - ERRONEOUS X VALUE IN DATA DESCRIPTOR OPERATOR -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ -C .................................................. -C -C NEW BASE TABLE B -C MAY BE A COMBINATION OF MASTER TABLE B -C AND ANCILLARY TABLE B -C - INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*) -C CHARACTER*40 ANAME1(*) -C CHARACTER*24 AUNIT1(*) -C .................................................. - INTEGER IPTR(*),KDATA(MAXR,MAXD),IVALS(*) - INTEGER IDENT(*),IWORK(*),KPTRB(*) - INTEGER MSGA(*),MSTACK(2,MAXD) - INTEGER J,JDESC - INTEGER LL - INTEGER LX - INTEGER LY -C - SAVE -C -C PRINT *,' F2 - DATA DESCRIPTOR OPERATOR' - IF (LX.EQ.1) THEN -C CHANGE BIT WIDTH - IF (LY.EQ.0) THEN -C PRINT *,' RETURN TO NORMAL WIDTH' - IPTR(26) = 0 - ELSE -C PRINT *,' EXPAND WIDTH BY',LY-128,' BITS' - IPTR(26) = LY - 128 - END IF - ELSE IF (LX.EQ.2) THEN -C CHANGE SCALE - IF (LY.EQ.0) THEN -C RESET TO STANDARD SCALE - IPTR(27) = 0 - ELSE -C SET NEW SCALE - IPTR(27) = LY - 128 - END IF - ELSE IF (LX.EQ.3) THEN -C CHANGE REFERENCE VALUE -C FOR EACH OF THOSE DESCRIPTORS BETWEEN -C 2 03 YYY WHERE Y LT 255 AND -C 2 03 255, EXTRACT THE NEW REFERENCE -C VALUE (BIT WIDTH YYY) AND PLACE -C IN TERTIARY TABLE B REF VAL POSITION, -C SET FLAG IN SECONDARY REFVAL POSITION -C THOSE DESCRIPTORS DO NOT HAVE DATA -C ASSOCIATED WITH THEM, BUT ONLY -C IDENTIFY THE TABLE B ENTRIES THAT -C ARE GETTING NEW REFERENCE VALUES. - KYYY = LY - IF (KYYY.GT.0.AND.KYYY.LT.255) THEN -C START CYCLING THRU DESCRIPTORS UNTIL -C TERMINATE NEW REF VALS IS FOUND - 300 CONTINUE - CALL FI8808 (IPTR,IWORK,LF,LX,LY,JDESC) - IF (JDESC.EQ.33791) THEN -C IF 2 03 255 THEN RETURN - RETURN - END IF -C FIND MATCHING TABLE B ENTRY - LJ = KPTRB(JDESC) - IF (LJ.LT.1) THEN -C MATCHING DESCRIPTOR NOT FOUND, ERROR ERROR - PRINT *,'2 03 YYY - MATCHING DESCRIPTOR NOT FOUND' - IPTR(1) = 23 - RETURN - END IF -C TURN ON SWITCH - IRFVL1(2,LJ) = 1 -C INSERT NEW REFERENCE VALUE - CALL GBYTE (MSGA,IRFVL1(3,LJ),IPTR(25),KYYY) - GO TO 300 - ELSE IF (KYYY.EQ.0) THEN -C MUST TURN OFF ALL NEW -C REFERENCE VALUES - DO 400 I = 1, IPTR(21) - IRFVL1(2,I) = 0 - 400 CONTINUE - END IF -C LX = 3 -C MUST BE CONCLUDED WITH Y=255 - ELSE IF (LX.EQ.4) THEN -C ASSOCIATED VALUES - IF (LY.EQ.0) THEN - IPTR(29) = 0 -C PRINT *,'RESET ASSOCIATED VALUES',IPTR(29) - ELSE - IPTR(29) = LY - IF (IWORK(IPTR(11)).NE.7957) THEN - PRINT *,'2 04 YYY NOT FOLLOWED BY 0 31 021' - IPTR(1) = 11 - END IF -C PRINT *,'SET ASSOCIATED VALUES',IPTR(29) - END IF - ELSE IF (LX.EQ.5) THEN - MWDBIT = IPTR(44) -C PROCESS TEXT DATA - IPTR(40) = LY - IPTR(18) = 1 - J = KPTRB(JDESC) - IF (IDENT(16).EQ.0) THEN -C PRINT *,'FROM FI8806 - 2 05 YYY - NONCOMPRESSED TEXT',J - CALL FI8804(IPTR,MSGA,KDATA,IVALS,MSTACK, - * IWIDE1,IRFVL1,ISCAL1,J,LL,JDESC,MAXR,MAXD) - ELSE -C PRINT *,'2 05 YYY - TEXT - COMPRESSED MODE YYY=',LY -C PRINT *,'TEXT - LOWEST = 0' - IPTR(25) = IPTR(25) + IPTR(40) * 8 -C GET NBINC -C CALL GBYTE (MSGA,NBINC,IPTR(25),6) - IPTR(25) = IPTR(25) + 6 - NBINC = IPTR(40) -C PRINT *,'TEXT NBINC =',NBINC,IPTR(40) -C FOR NUMBER OF OBSERVATIONS - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - ISTART = KPRM - DO 1900 N = 1, IDENT(14) - KPRM = ISTART - NBITS = IPTR(40) * 8 - 1700 CONTINUE -C PRINT *,'1700',KDATA(N,KPRM),N,KPRM,NBITS - IF (NBITS.GT.MWDBIT) THEN - CALL GBYTE (MSGA,IDATA,IPTR(25),MWDBIT) - IPTR(25) = IPTR(25) + MWDBIT - NBITS = NBITS - MWDBIT -C CONVERTS ASCII TO EBCIDIC -C COMMENT OUT IF NOT IBM370 COMPUTER - IF (IPTR(37).EQ.0) THEN - CALL W3AI39 (IDATA,IPTR(45)) - END IF - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - KDATA(N,KPRM) = IDATA -C PRINT *,'TEXT ',N,KPRM,KDATA(N,KPRM) -C SET FOR NEXT PART - KPRM = KPRM + 1 -C PRINT 1701,1,KDATA(N,KPRM),N,KPRM,NBITS,IDATA -C1701 FORMAT (1X,I1,1X,6HKDATA=,A4,2X,I5,2X,I5,2X,I5,2X, -C * I10) - GO TO 1700 - ELSE IF (NBITS.EQ.MWDBIT) THEN - CALL GBYTE (MSGA,IDATA,IPTR(25),MWDBIT) - IPTR(25) = IPTR(25) + MWDBIT - NBITS = NBITS - MWDBIT -C CONVERTS ASCII TO EBCIDIC -C COMMENT OUT IF NOT IBM370 COMPUTER - IF (IPTR(37).EQ.0) THEN - CALL W3AI39 (IDATA,IPTR(45)) - END IF - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - KDATA(N,KPRM) = IDATA -C PRINT *,'TEXT ',N,KPRM,KDATA(N,KPRM) -C SET FOR NEXT PART - KPRM = KPRM + 1 -C PRINT 1701,1,KDATA(N,KPRM),N,KPRM,NBITS,IDATA - ELSE IF (NBITS.GT.0) THEN - CALL GBYTE (MSGA,IDATA,IPTR(25),NBITS) - IPTR(25) = IPTR(25) + NBITS - IBUF = (MWDBIT - NBITS) / 8 - IF (IBUF.GT.0) THEN - DO 1750 MP = 1, IBUF - IDATA = IDATA * 256 + 32 - 1750 CONTINUE - END IF -C CONVERTS ASCII TO EBCIDIC -C COMMENT OUT IF NOT IBM370 COMPUTER - IF (IPTR(37).EQ.0) THEN - CALL W3AI39 (IDATA,IPTR(45)) - END IF - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - KDATA(N,KPRM) = IDATA -C PRINT *,'TEXT ',N,KPRM,KDATA(N,KPRM) -C PRINT 1701,2,KDATA(N,KPRM),N,KPRM,NBITS - END IF -C WRITE (6,1800)N,(KDATA(N,I),I=KPRS,KPRM) -C1800 FORMAT (2X,I4,2X,3A4) - 1900 CONTINUE - - IPTR(24) = IPTR(24) + IPTR(40) / 4 - 1 - IF (MOD(IPTR(40),4).NE.0) IPTR(24) = IPTR(24) + 1 - END IF - IPTR(18) = 0 -C --------------------------- - ELSE IF (LX.EQ.6) THEN -C SKIP NEXT DESCRIPTOR -C SET TO PASS OVER DESCRIPTOR AND DATA -C IF DESCRIPTOR NOT IN TABLE B - IPTR(36) = LY -C PRINT *,'SET TO SKIP',LY,' BIT FIELD' - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = 34304 + LY - MSTACK(2,KPRM) = 0 - ELSE - IPTR(1) = 5 - ENDIF - RETURN - END - SUBROUTINE FI8807(IPTR,IWORK,ITBLD,ITBLD2,JDESC,KPTRD) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8807 PROCESS QUEUE DESCRIPTOR -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01 -C -C ABSTRACT: SUBSTITUTE DESCRIPTOR QUEUE FOR QUEUE DESCRIPTOR -C -C PROGRAM HISTORY LOG: -C 88-09-01 CAVANAUGH -C 91-04-17 CAVANAUGH IMPROVED HANDLING OF NESTED QUEUE DESCRIPTORS -C 91-05-28 CAVANAUGH IMPROVED HANDLING OF NESTED QUEUE DESCRIPTORS -C BASED ON TESTS WITH LIVE DATA. -C -C USAGE: CALL FI8807(IPTR,IWORK,ITBLD,ITBLD2,JDESC,KPTRD) -C INPUT ARGUMENT LIST: -C IWORK - WORKING DESCRIPTOR LIST -C IPTR - SEE W3FI88 ROUTINE DOCBLOCK -C LAST - INDEX TO LAST DESCRIPTOR -C ITBLD - ARRAY CONTAINING DESCRIPTOR QUEUES -C JDESC - QUEUE DESCRIPTOR TO BE EXPANDED -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C ISTACK - SEE ABOVE -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - NONE -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ -C .................................................. -C -C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE -C - INTEGER ITBLD2(20,*) -C .................................................. -C -C NEW BASE TABLE D -C - INTEGER ITBLD(20,*) -C .................................................. -C - INTEGER IPTR(*),JDESC,KPTRD(*) - INTEGER IWORK(*),IHOLD(15000) -C - SAVE -C PRINT *,' FI8807 F3 ENTRY',IPTR(11),IPTR(12) -C SET FOR BINARY SEARCH IN TABLE D - JLO = 1 - JHI = IPTR(20) -C PRINT *,'LOOKING FOR QUEUE DESCRIPTOR',JDESC,IPTR(11),IPTR(12) -C - JMID = KPTRD(MOD(JDESC,16384)) - IF (JMID.LT.0) THEN - IPTR(1) = 4 - RETURN - END IF -C HAVE TABLE D MATCH -C PRINT *,'D ',(ITBLD(LL,JMID),LL=1,20) -C PRINT *,'TABLE D TO IHOLD' - IK = 0 - JK = 0 - DO 200 KI = 2, 20 - IF (ITBLD(KI,JMID).NE.0) THEN - IK = IK + 1 - IHOLD(IK) = ITBLD(KI,JMID) -C PRINT *,IK,IHOLD(IK) - ELSE - GO TO 300 - END IF - 200 CONTINUE - 300 CONTINUE - KK = IPTR(11) - IF (KK.GT.IPTR(12)) THEN -C NOTHING MORE TO APPEND -C PRINT *,'NOTHING MORE TO APPEND' - ELSE -C APPEND TRAILING IWORK TO IHOLD -C PRINT *,'APPEND FROM ',KK,' TO',IPTR(12) - DO 500 I = KK, IPTR(12) - IK = IK + 1 - IHOLD(IK) = IWORK(I) - 500 CONTINUE - END IF -C RESET IHOLD TO IWORK -C PRINT *,' RESET IWORK STACK' - KK = IPTR(11) - 2 - DO 1000 I = 1, IK - KK = KK + 1 - IWORK(KK) = IHOLD(I) - 1000 CONTINUE - IPTR(12) = KK -C PRINT *,' FI8807 F3 EXIT ',IPTR(11),IPTR(12) -C DO 2000 I = 1, IPTR(12) -C PRINT *,'EXIT IWORK',I,IWORK(I) -C2000 CONTINUE -C RESET POINTERS - IPTR(11) = IPTR(11) - 1 - RETURN - END -C ----------------------------------------------------- - SUBROUTINE FI8808(IPTR,IWORK,LF,LX,LY,JDESC) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8808 -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 89-01-17 -C -C ABSTRACT: -C -C PROGRAM HISTORY LOG: -C 88-09-01 CAVANAUGH -C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE -C -C USAGE: CALL FI8808(IPTR,IWORK,LF,LX,LY,JDESC) -C INPUT ARGUMENT LIST: -C IPTR - SEE W3FI88 ROUTINE DOCBLOCK -C IWORK - WORKING DESCRIPTOR LIST -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C IPTR - SEE ABOVE -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ - INTEGER IPTR(*),IWORK(*),LF,LX,LY,JDESC - SAVE -C -C PRINT *,' FI8808 NEW DESCRIPTOR PICKUP' - JDESC = IWORK(IPTR(11)) - LY = MOD(JDESC,256) - IPTR(34) = LY - LX = MOD((JDESC/256),64) - IPTR(33) = LX - LF = JDESC / 16384 - IPTR(32) = LF -C PRINT *,' TEST DESCRIPTOR',LF,LX,LY,' AT',IPTR(11) - IPTR(11) = IPTR(11) + 1 - RETURN - END - SUBROUTINE FI8809(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8809 REFORMAT PROFILER W HGT INCREMENTS -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 90-02-14 -C -C ABSTRACT: REFORMAT DECODED PROFILER DATA TO SHOW HEIGHTS INSTEAD OF -C HEIGHT INCREMENTS. -C -C PROGRAM HISTORY LOG: -C 90-02-14 CAVANAUGH -C -C USAGE: CALL FI8809(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD) -C INPUT ARGUMENT LIST: -C IDENT - ARRAY CONTAINS MESSAGE INFORMATION EXTRACTED FROM -C BUFR MESSAGE - -C IDENT(1) -EDITION NUMBER (BYTE 4, SECTION 1) -C IDENT(2) -ORIGINATING CENTER (BYTES 5-6, SECTION 1) -C IDENT(3) -UPDATE SEQUENCE (BYTE 7, SECTION 1) -C IDENT(4) - (BYTE 8, SECTION 1) -C IDENT(5) -BUFR MESSAGE TYPE (BYTE 9, SECTION 1) -C IDENT(6) -BUFR MSG SUB-TYPE (BYTE 10, SECTION 1) -C IDENT(7) - (BYTES 11-12, SECTION 1) -C IDENT(8) -YEAR OF CENTURY (BYTE 13, SECTION 1) -C IDENT(9) -MONTH OF YEAR (BYTE 14, SECTION 1) -C IDENT(10)-DAY OF MONTH (BYTE 15, SECTION 1) -C IDENT(11)-HOUR OF DAY (BYTE 16, SECTION 1) -C IDENT(12)-MINUTE OF HOUR (BYTE 17, SECTION 1) -C IDENT(13)-RSVD BY ADP CENTERS(BYTE 18, SECTION 1) -C IDENT(14)-NR OF DATA SUBSETS (BYTE 5-6, SECTION 3) -C IDENT(15)-OBSERVED FLAG (BYTE 7, BIT 1, SECTION 3) -C IDENT(16)-COMPRESSION FLAG (BYTE 7, BIT 2, SECTION 3) -C MSTACK - WORKING DESCRIPTOR LIST AND SCALING FACTOR -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C KSET2 - INTERIM DATA ARRAY -C KPROFL - INTERIM DESCRIPTOR ARRAY -C IPTR - SEE W3FI88 -C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE -C CONTAINED IN A BUFR MESSAGE -C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT -C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE -C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST -C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE -C -C OUTPUT FILES: -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ -C ---------------------------------------------------------------- -C - INTEGER ISW - INTEGER IDENT(*),KDATA(MAXR,MAXD) - INTEGER MSTACK(2,MAXD),IPTR(*) - INTEGER KPROFL(1700) - INTEGER KPROF2(1700) - INTEGER KSET2(1700) -C -C ---------------------------------------------------------- - SAVE -C PRINT *,'FI8809' -C LOOP FOR NUMBER OF SUBSETS/REPORTS - DO 3000 I = 1, IDENT(14) -C INIT FOR DATA INPUT ARRAY - MK = 1 -C INIT FOR DESC OUTPUT ARRAY - JK = 0 -C LOCATION - ISW = 0 - DO 200 J = 1, 3 -C LATITUDE - IF (MSTACK(1,MK).EQ.1282) THEN - ISW = ISW + 1 - GO TO 100 -C LONGITUDE - ELSE IF (MSTACK(1,MK).EQ.1538) THEN - ISW = ISW + 2 - GO TO 100 -C HEIGHT ABOVE SEA LEVEL - ELSE IF (MSTACK(1,MK).EQ.1793) THEN - IHGT = KDATA(I,MK) - ISW = ISW + 4 - GO TO 100 - END IF - GO TO 200 - 100 CONTINUE - JK = JK + 1 -C SAVE DESCRIPTOR - KPROFL(JK) = MSTACK(1,MK) -C SAVE SCALE - KPROF2(JK) = MSTACK(2,MK) -C SAVE DATA - KSET2(JK) = KDATA(I,MK) - MK = MK + 1 - 200 CONTINUE - IF (ISW.NE.7) THEN - PRINT *,'LOCATION ERROR PROCESSING PROFILER' - IPTR(1) = 200 - RETURN - END IF -C TIME - ISW = 0 - DO 400 J = 1, 7 -C YEAR - IF (MSTACK(1,MK).EQ.1025) THEN - ISW = ISW + 1 - GO TO 300 -C MONTH - ELSE IF (MSTACK(1,MK).EQ.1026) THEN - ISW = ISW + 2 - GO TO 300 -C DAY - ELSE IF (MSTACK(1,MK).EQ.1027) THEN - ISW = ISW + 4 - GO TO 300 -C HOUR - ELSE IF (MSTACK(1,MK).EQ.1028) THEN - ISW = ISW + 8 - GO TO 300 -C MINUTE - ELSE IF (MSTACK(1,MK).EQ.1029) THEN - ISW = ISW + 16 - GO TO 300 -C TIME SIGNIFICANCE - ELSE IF (MSTACK(1,MK).EQ.2069) THEN - ISW = ISW + 32 - GO TO 300 - ELSE IF (MSTACK(1,MK).EQ.1049) THEN - ISW = ISW + 64 - GO TO 300 - END IF - GO TO 400 - 300 CONTINUE - JK = JK + 1 -C SAVE DESCRIPTOR - KPROFL(JK) = MSTACK(1,MK) -C SAVE SCALE - KPROF2(JK) = MSTACK(2,MK) -C SAVE DATA - KSET2(JK) = KDATA(I,MK) - MK = MK + 1 - 400 CONTINUE - IF (ISW.NE.127) THEN - PRINT *,'TIME ERROR PROCESSING PROFILER',ISW - IPTR(1) = 201 - RETURN - END IF -C SURFACE DATA - KRG = 0 - ISW = 0 - DO 600 J = 1, 10 -C WIND SPEED - IF (MSTACK(1,MK).EQ.2818) THEN - ISW = ISW + 1 - GO TO 500 -C WIND DIRECTION - ELSE IF (MSTACK(1,MK).EQ.2817) THEN - ISW = ISW + 2 - GO TO 500 -C PRESS REDUCED TO MSL - ELSE IF (MSTACK(1,MK).EQ.2611) THEN - ISW = ISW + 4 - GO TO 500 -C TEMPERATURE - ELSE IF (MSTACK(1,MK).EQ.3073) THEN - ISW = ISW + 8 - GO TO 500 -C RAINFALL RATE - ELSE IF (MSTACK(1,MK).EQ.3342) THEN - ISW = ISW + 16 - GO TO 500 -C RELATIVE HUMIDITY - ELSE IF (MSTACK(1,MK).EQ.3331) THEN - ISW = ISW + 32 - GO TO 500 -C 1ST RANGE GATE OFFSET - ELSE IF (MSTACK(1,MK).EQ.1982.OR. - * MSTACK(1,MK).EQ.1983) THEN -C CANNOT USE NORMAL PROCESSING FOR FIRST RANGE GATE, MUST SAVE -C VALUE FOR LATER USE - IF (MSTACK(1,MK).EQ.1983) THEN - IHGT = KDATA(I,MK) - MK = MK + 1 - KRG = 1 - ELSE - IF (KRG.EQ.0) THEN - INCRHT = KDATA(I,MK) - MK = MK + 1 - KRG = 1 -C PRINT *,'INITIAL INCR =',INCRHT - ELSE - LHGT = 500 + IHGT - KDATA(I,MK) - ISW = ISW + 64 -C PRINT *,'BASE HEIGHT=',LHGT,' INCR=',INCRHT - END IF - END IF -C MODE #1 - ELSE IF (MSTACK(1,MK).EQ.8128) THEN - ISW = ISW + 128 - GO TO 500 -C MODE #2 - ELSE IF (MSTACK(1,MK).EQ.8129) THEN - ISW = ISW + 256 - GO TO 500 - END IF - GO TO 600 - 500 CONTINUE -C SAVE DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = MSTACK(1,MK) -C SAVE SCALE - KPROF2(JK) = MSTACK(2,MK) -C SAVE DATA - KSET2(JK) = KDATA(I,MK) -C IF (I.EQ.1) THEN -C PRINT *,' ',JK,KPROFL(JK),KSET2(JK) -C END IF - MK = MK + 1 - 600 CONTINUE - IF (ISW.NE.511) THEN - PRINT *,'SURFACE ERROR PROCESSING PROFILER',ISW - IPTR(1) = 202 - RETURN - END IF -C 43 LEVELS - DO 2000 L = 1, 43 - 2020 CONTINUE - ISW = 0 -C HEIGHT INCREMENT - IF (MSTACK(1,MK).EQ.1982) THEN -C PRINT *,'NEW HEIGHT INCREMENT',KDATA(I,MK) - INCRHT = KDATA(I,MK) - MK = MK + 1 - IF (LHGT.LT.(9250+IHGT)) THEN - LHGT = IHGT + 500 - INCRHT - ELSE - LHGT = IHGT + 9250 - INCRHT - END IF - END IF -C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DATA -C AT THIS POINT - HEIGHT + INCREMENT + BASE VALUE - LHGT = LHGT + INCRHT -C PRINT *,'LEVEL ',L,LHGT - IF (L.EQ.37) THEN - LHGT = LHGT + INCRHT - END IF - JK = JK + 1 -C SAVE DESCRIPTOR - KPROFL(JK) = 1798 -C SAVE SCALE - KPROF2(JK) = 0 -C SAVE DATA - KSET2(JK) = LHGT -C IF (I.EQ.10) THEN -C PRINT *,' ' -C PRINT *,'HGT',JK,KPROFL(JK),KSET2(JK) -C END IF - ISW = 0 - DO 800 J = 1, 9 - 750 CONTINUE - IF (MSTACK(1,MK).EQ.1982) THEN - GO TO 2020 -C U VECTOR VALUE - ELSE IF (MSTACK(1,MK).EQ.3008) THEN - ISW = ISW + 1 - IF (KDATA(I,MK).GE.2047) THEN - VECTU = 32767 - ELSE - VECTU = KDATA(I,MK) - END IF - MK = MK + 1 - GO TO 800 -C V VECTOR VALUE - ELSE IF (MSTACK(1,MK).EQ.3009) THEN - ISW = ISW + 2 - IF (KDATA(I,MK).GE.2047) THEN - VECTV = 32767 - ELSE - VECTV = KDATA(I,MK) - END IF - MK = MK + 1 -C IF U VALUE IS ALSO AVAILABLE THEN GENERATE DDFFF -C DESCRIPTORS AND DATA - IF (IAND(ISW,1).NE.0) THEN - IF (VECTU.EQ.32767.OR.VECTV.EQ.32767) THEN -C SAVE DD DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = 2817 -C SAVE SCALE - KPROF2(JK) = 0 -C SAVE DD DATA - KSET2(JK) = 32767 -C SAVE FFF DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = 2818 -C SAVE SCALE - KPROF2(JK) = 1 -C SAVE FFF DATA - KSET2(JK) = 32767 - ELSE -C GENERATE DDFFF - CALL W3FC05 (VECTU,VECTV,DIR,SPD) - NDIR = DIR - SPD = SPD - NSPD = SPD -C PRINT *,' ',NDIR,NSPD -C SAVE DD DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = 2817 -C SAVE SCALE - KPROF2(JK) = 0 -C SAVE DD DATA - KSET2(JK) = DIR -C IF (I.EQ.1) THEN -C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK) -C END IF -C SAVE FFF DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = 2818 -C SAVE SCALE - KPROF2(JK) = 1 -C SAVE FFF DATA - KSET2(JK) = SPD -C IF (I.EQ.1) THEN -C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK) -C END IF - END IF - END IF - GO TO 800 -C W VECTOR VALUE - ELSE IF (MSTACK(1,MK).EQ.3010) THEN - ISW = ISW + 4 - GO TO 700 -C Q/C TEST RESULTS - ELSE IF (MSTACK(1,MK).EQ.8130) THEN - ISW = ISW + 8 - GO TO 700 -C U,V QUALITY IND - ELSE IF(IAND(ISW,16).EQ.0.AND.MSTACK(1,MK).EQ.2070) THEN - ISW = ISW + 16 - GO TO 700 -C W QUALITY IND - ELSE IF(IAND(ISW,32).EQ.0.AND.MSTACK(1,MK).EQ.2070) THEN - ISW = ISW + 32 - GO TO 700 -C SPECTRAL PEAK POWER - ELSE IF (MSTACK(1,MK).EQ.5568) THEN - ISW = ISW + 64 - GO TO 700 -C U,V VARIABILITY - ELSE IF (MSTACK(1,MK).EQ.3011) THEN - ISW = ISW + 128 - GO TO 700 -C W VARIABILITY - ELSE IF (MSTACK(1,MK).EQ.3013) THEN - ISW = ISW + 256 - GO TO 700 - ELSE IF ((MSTACK(1,MK)/16384).NE.0) THEN - MK = MK + 1 - GO TO 750 - END IF - GO TO 800 - 700 CONTINUE - JK = JK + 1 -C SAVE DESCRIPTOR - KPROFL(JK) = MSTACK(1,MK) -C SAVE SCALE - KPROF2(JK) = MSTACK(2,MK) -C SAVE DATA - KSET2(JK) = KDATA(I,MK) - MK = MK + 1 -C IF (I.EQ.1) THEN -C PRINT *,' ',JK,KPROFL(JK),KSET2(JK) -C END IF - 800 CONTINUE - IF (ISW.NE.511) THEN - PRINT *,'LEVEL ERROR PROCESSING PROFILER',ISW - IPTR(1) = 203 - RETURN - END IF - 2000 CONTINUE -C MOVE DATA BACK INTO KDATA ARRAY - DO 4000 LL = 1, JK - KDATA(I,LL) = KSET2(LL) - 4000 CONTINUE - 3000 CONTINUE -C PRINT *,'REBUILT ARRAY' - DO 5000 LL = 1, JK -C DESCRIPTOR - MSTACK(1,LL) = KPROFL(LL) -C SCALE - MSTACK(2,LL) = KPROF2(LL) -C PRINT *,LL,MSTACK(1,LL),(KDATA(I,LL),I=1,7) - 5000 CONTINUE -C MOVE REFORMATTED DESCRIPTORS TO MSTACK ARRAY - IPTR(31) = JK - RETURN - END - SUBROUTINE FI8810(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8810 REFORMAT PROFILER EDITION 2 DATA -C PRGMMR: KEYSER ORG: NP22 DATE: 1995-06-07 -C -C ABSTRACT: REFORMAT PROFILER DATA IN EDITION 2 -C -C PROGRAM HISTORY LOG: -C 1993-01-27 CAVANAUGH -C 1995-06-07 KEYSER A CORRECTION WAS MADE TO PREVENT -C UNNECESSARY LOOPING WHEN ALL REQUESTED -C DESCRIPTORS ARE MISSING. -C -C USAGE: CALL FI8810(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD) -C INPUT ARGUMENT LIST: -C IDENT - ARRAY CONTAINS MESSAGE INFORMATION EXTRACTED FROM -C BUFR MESSAGE - -C IDENT(1) -EDITION NUMBER (BYTE 4, SECTION 1) -C IDENT(2) -ORIGINATING CENTER (BYTES 5-6, SECTION 1) -C IDENT(3) -UPDATE SEQUENCE (BYTE 7, SECTION 1) -C IDENT(4) - (BYTE 8, SECTION 1) -C IDENT(5) -BUFR MESSAGE TYPE (BYTE 9, SECTION 1) -C IDENT(6) -BUFR MSG SUB-TYPE (BYTE 10, SECTION 1) -C IDENT(7) - (BYTES 11-12, SECTION 1) -C IDENT(8) -YEAR OF CENTURY (BYTE 13, SECTION 1) -C IDENT(9) -MONTH OF YEAR (BYTE 14, SECTION 1) -C IDENT(10)-DAY OF MONTH (BYTE 15, SECTION 1) -C IDENT(11)-HOUR OF DAY (BYTE 16, SECTION 1) -C IDENT(12)-MINUTE OF HOUR (BYTE 17, SECTION 1) -C IDENT(13)-RSVD BY ADP CENTERS(BYTE 18, SECTION 1) -C IDENT(14)-NR OF DATA SUBSETS (BYTE 5-6, SECTION 3) -C IDENT(15)-OBSERVED FLAG (BYTE 7, BIT 1, SECTION 3) -C IDENT(16)-COMPRESSION FLAG (BYTE 7, BIT 2, SECTION 3) -C MSTACK - WORKING DESCRIPTOR LIST AND SCALING FACTOR -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C KSET2 - INTERIM DATA ARRAY -C KPROFL - INTERIM DESCRIPTOR ARRAY -C IPTR - SEE W3FI88 -C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE -C CONTAINED IN A BUFR MESSAGE -C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT -C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE -C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST -C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE -C -C OUTPUT FILES: -C -C REMARKS: -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ - INTEGER ISW - INTEGER IDENT(*),KDATA(MAXR,MAXD) - INTEGER MSTACK(2,MAXD),IPTR(*) - INTEGER KPROFL(1700) - INTEGER KPROF2(1700) - INTEGER KSET2(1700) -C - SAVE -C LOOP FOR NUMBER OF SUBSETS - DO 3000 I = 1, IDENT(14) - MK = 1 - JK = 0 - ISW = 0 -C PRINT *,'IDENTIFICATION' - DO 200 J = 1, 5 - IF (MSTACK(1,MK).EQ.257) THEN -C BLOCK NUMBER - ISW = ISW + 1 - ELSE IF (MSTACK(1,MK).EQ.258) THEN -C STATION NUMBER - ISW = ISW + 2 - ELSE IF (MSTACK(1,MK).EQ.1282) THEN -C LATITUDE - ISW = ISW + 4 - ELSE IF (MSTACK(1,MK).EQ.1538) THEN -C LONGITUDE - ISW = ISW + 8 - ELSE IF (MSTACK(1,MK).EQ.1793) THEN -C HEIGHT OF STATION - ISW = ISW + 16 - IHGT = KDATA(I,MK) - ELSE - MK = MK + 1 - GO TO 200 - END IF - JK = JK + 1 - KPROFL(JK) = MSTACK(1,MK) - KPROF2(JK) = MSTACK(2,MK) - KSET2(JK) = KDATA(I,MK) -C PRINT *,JK,KPROFL(JK),KSET2(JK) - MK = MK + 1 - 200 CONTINUE -C PRINT *,'LOCATION ',ISW - IF (ISW.NE.31) THEN - PRINT *,'LOCATION ERROR PROCESSING PROFILER' - IPTR(10) = 200 - RETURN - END IF -C PROCESS TIME ELEMENTS - ISW = 0 - DO 400 J = 1, 7 - IF (MSTACK(1,MK).EQ.1025) THEN -C YEAR - ISW = ISW + 1 - ELSE IF (MSTACK(1,MK).EQ.1026) THEN -C MONTH - ISW = ISW + 2 - ELSE IF (MSTACK(1,MK).EQ.1027) THEN -C DAY - ISW = ISW + 4 - ELSE IF (MSTACK(1,MK).EQ.1028) THEN -C HOUR - ISW = ISW + 8 - ELSE IF (MSTACK(1,MK).EQ.1029) THEN -C MINUTE - ISW = ISW + 16 - ELSE IF (MSTACK(1,MK).EQ.2069) THEN -C TIME SIGNIFICANCE - ISW = ISW + 32 - ELSE IF (MSTACK(1,MK).EQ.1049) THEN -C TIME DISPLACEMENT - ISW = ISW + 64 - ELSE - MK = MK + 1 - GO TO 400 - END IF - JK = JK + 1 - KPROFL(JK) = MSTACK(1,MK) - KPROF2(JK) = MSTACK(2,MK) - KSET2(JK) = KDATA(I,MK) -C PRINT *,JK,KPROFL(JK),KSET2(JK) - MK = MK + 1 - 400 CONTINUE -C PRINT *,'TIME ',ISW - IF (ISW.NE.127) THEN - PRINT *,'TIME ERROR PROCESSING PROFILER' - IPTR(1) = 201 - RETURN - END IF -C SURFACE DATA - ISW = 0 -C PRINT *,'SURFACE' - DO 600 K = 1, 8 -C PRINT *,MK,MSTACK(1,MK),JK,ISW - IF (MSTACK(1,MK).EQ.2817) THEN - ISW = ISW + 1 - ELSE IF (MSTACK(1,MK).EQ.2818) THEN - ISW = ISW + 2 - ELSE IF (MSTACK(1,MK).EQ.2611) THEN - ISW = ISW + 4 - ELSE IF (MSTACK(1,MK).EQ.3073) THEN - ISW = ISW + 8 - ELSE IF (MSTACK(1,MK).EQ.3342) THEN - ISW = ISW + 16 - ELSE IF (MSTACK(1,MK).EQ.3331) THEN - ISW = ISW + 32 - ELSE IF (MSTACK(1,MK).EQ.1797) THEN - INCRHT = KDATA(I,MK) - ISW = ISW + 64 -C PRINT *,'INITIAL INCREMENT = ',INCRHT - MK = MK + 1 -C PRINT *,JK,KPROFL(JK),KSET2(JK),' ISW=',ISW - GO TO 600 - ELSE IF (MSTACK(1,MK).EQ.6433) THEN - ISW = ISW + 128 - END IF - JK = JK + 1 - KPROFL(JK) = MSTACK(1,MK) - KPROF2(JK) = MSTACK(2,MK) - KSET2(JK) = KDATA(I,MK) -C PRINT *,JK,KPROFL(JK),KSET2(JK),'ISW=',ISW - MK = MK + 1 - 600 CONTINUE - IF (ISW.NE.255) THEN - PRINT *,'ERROR PROCESSING PROFILER',ISW - IPTR(1) = 204 - RETURN - END IF - IF (MSTACK(1,MK).NE.1797) THEN - PRINT *,'ERROR PROCESSING HEIGHT INCREMENT IN PROFILER' - IPTR(1) = 205 - RETURN - END IF -C MUST SAVE THIS HEIGHT VALUE - LHGT = 500 + IHGT - KDATA(I,MK) -C PRINT *,'BASE HEIGHT = ',LHGT,' INCR = ',INCRHT - MK = MK + 1 - IF (MSTACK(1,MK).GE.16384) THEN - MK = MK + 1 - END IF -C PROCESS LEVEL DATA -C PRINT *,'LEVEL DATA' - DO 2000 L = 1, 43 - 2020 CONTINUE -C PRINT *,'DESC',MK,MSTACK(1,MK),JK - ISW = 0 -C HEIGHT INCREMENT - IF (MSTACK(1,MK).EQ.1797) THEN - INCRHT = KDATA(I,MK) -C PRINT *,'NEW HEIGHT INCREMENT = ',INCRHT - MK = MK + 1 -C IF (LHGT.LT.(9250+IHGT)) THEN -C LHGT = IHGT + 500 - INCRHT -C ELSE -C LHGT = IHGT + 9250 -INCRHT -C END IF - END IF -C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DA -C AT THIS POINT - LHGT = LHGT + INCRHT -C PRINT *,'LEVEL ',L,LHGT -C IF (L.EQ.37) THEN -C LHGT = LHGT + INCRHT -C END IF - JK = JK + 1 -C SAVE DESCRIPTOR - KPROFL(JK) = 1798 -C SAVE SCALE - KPROF2(JK) = 0 -C SAVE DATA - KSET2(JK) = LHGT -C PRINT *,KPROFL(JK),KSET2(JK),JK - ISW = 0 - ICON = 1 - DO 800 J = 1, 10 -750 CONTINUE - IF (MSTACK(1,MK).EQ.1797) THEN - GO TO 2020 - ELSE IF (MSTACK(1,MK).EQ.6432) THEN -C HI/LO MODE - ISW = ISW + 1 - ELSE IF (MSTACK(1,MK).EQ.6434) THEN -C Q/C TEST - ISW = ISW + 2 - ELSE IF (MSTACK(1,MK).EQ.2070) THEN - IF (ICON.EQ.1) THEN -C FIRST PASS - U,V CONSENSUS - ISW = ISW + 4 - ICON = ICON + 1 - ELSE -C SECOND PASS - W CONSENSUS - ISW = ISW + 64 - END IF - ELSE IF (MSTACK(1,MK).EQ.2819) THEN -C U VECTOR VALUE - ISW = ISW + 8 - IF (KDATA(I,MK).GE.2047) THEN - VECTU = 32767 - ELSE - VECTU = KDATA(I,MK) - END IF - MK = MK + 1 - GO TO 800 - ELSE IF (MSTACK(1,MK).EQ.2820) THEN -C V VECTOR VALUE - ISW = ISW + 16 - IF (KDATA(I,MK).GE.2047) THEN - VECTV = 32767 - ELSE - VECTV = KDATA(I,MK) - END IF - IF (IAND(ISW,1).NE.0) THEN - IF (VECTU.EQ.32767.OR.VECTV.EQ.32767) THEN -C SAVE DD DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = 2817 - KPROF2(JK) = 0 - KSET2(JK) = 32767 -C SAVE FFF DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = 2818 - KPROF2(JK) = 1 - KSET2(JK) = 32767 - ELSE - CALL W3FC05 (VECTU,VECTV,DIR,SPD) - NDIR = DIR - SPD = SPD - NSPD = SPD -C PRINT *,' ',NDIR,NSPD -C SAVE DD DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = 2817 - KPROF2(JK) = 0 - KSET2(JK) = NDIR -C IF (I.EQ.1) THEN -C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK) -C ENDIF -C SAVE FFF DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = 2818 - KPROF2(JK) = 1 - KSET2(JK) = NSPD -C IF (I.EQ.1) THEN -C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK) -C ENDIF - END IF - MK = MK + 1 - GO TO 800 - END IF - ELSE IF (MSTACK(1,MK).EQ.2866) THEN -C SPEED STD DEVIATION - ISW = ISW + 32 -C -- A CHANGE BY KEYSER : POWER DESCR. BACK TO 5568 - ELSE IF (MSTACK(1,MK).EQ.5568) THEN -C SIGNAL POWER - ISW = ISW + 128 - ELSE IF (MSTACK(1,MK).EQ.2822) THEN -C W COMPONENT - ISW = ISW + 256 - ELSE IF (MSTACK(1,MK).EQ.2867) THEN -C VERT STD DEVIATION - ISW = ISW + 512 -CVVVVVCHANGE#1 FIX BY KEYSER -- 12/06/1994 -C NOTE: THIS FIX PREVENTS UNNECESSARY LOOPING WHEN ALL REQ. DESCR. -C ARE MISSING. WOULD GO INTO INFINITE LOOP EXCEPT EVENTUALLY -C MSTACK ARRAY SIZE IS EXCEEDED AND GET FORTRAN ERROR INTERRUPT -CDAK ELSE - ELSE IF ((MSTACK(1,MK)/16384).NE.0) THEN -CAAAAACHANGE#1 FIX BY KEYSER -- 12/06/1994 - MK = MK + 1 - GO TO 750 - END IF - JK = JK + 1 -C SAVE DESCRIPTOR - KPROFL(JK) = MSTACK(1,MK) -C SAVE SCALE - KPROF2(JK) = MSTACK(2,MK) -C SAVE DATA - KSET2(JK) = KDATA(I,MK) - MK = MK + 1 -C PRINT *,L,'TEST ',JK,KPROFL(JK),KSET2(JK) - 800 CONTINUE - IF (ISW.NE.1023) THEN - PRINT *,'LEVEL ERROR PROCESSING PROFILER',ISW - IPTR(1) = 202 - RETURN - END IF - 2000 CONTINUE -C MOVE DATA BACK INTO KDATA ARRAY - DO 5000 LL = 1, JK -C DATA - KDATA(I,LL) = KSET2(LL) - 5000 CONTINUE - 3000 CONTINUE - DO 5005 LL = 1, JK -C DESCRIPTOR - MSTACK(1,LL) = KPROFL(LL) -C SCALE - MSTACK(2,LL) = KPROF2(LL) -C -- A CHANGE BY KEYSER : PRINT STATEMNT SHOULD BE HERE NOT IN 5000 LOOP -C PRINT *,LL,MSTACK(1,LL),MSTACK(2,LL),(KDATA(I,LL),I=1,4) - 5005 CONTINUE - IPTR(31) = JK - RETURN - END - SUBROUTINE FI8811(IPTR,IDENT,MSTACK,KDATA,KNR, - * LDATA,LSTACK,MAXD,MAXR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8811 EXPAND DATA/DESCRIPTOR REPLICATION -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-05-12 -C -C ABSTRACT: EXPAND DATA AND DESCRIPTOR STRINGS -C -C PROGRAM HISTORY LOG: -C 93-05-12 CAVANAUGH -C YY-MM-DD MODIFIER2 DESCRIPTION OF CHANGE -C -C USAGE: CALL FI8811(IPTR,IDENT,MSTACK,KDATA,KNR, -C * LDATA,LSTACK,MAXD,MAXR) -C INPUT ARGUMENT LIST: -C IPTR - SEE W3FI88 ROUTINE DOCBLOCK -C IDENT - SEE W3FI88 ROUTINE DOCBLOCK -C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE -C CONTAINED IN A BUFR MESSAGE -C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT -C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE -C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST -C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C MSTACK - LIST OF DESCRIPTORS AND SCALE VALUES -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C MSTACK - LIST OF DESCRIPTORS AND SCALE VALUES -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - -C -C REMARKS: ERROR RETURN: -C IPTR(1) = -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ - INTEGER IPTR(*) - INTEGER KNR(MAXR) - INTEGER KDATA(MAXR,MAXD),LDATA(MAXD) - INTEGER MSTACK(2,MAXD),LSTACK(2,MAXD) - INTEGER IDENT(*) -C - SAVE -C -C PRINT *,' DATA/DESCRIPTOR REPLICATION ' - DO 1000 I = 1, KNR(1) -C IF NOT REPLICATION DESCRIPTOR - IF ((MSTACK(1,I)/16384).NE.1) THEN - GO TO 1000 - END IF -C IF DELAYED REPLICATION DESCRIPTOR - IF (MOD(MSTACK(1,I),256).EQ.0) THEN -C SAVE KX VALUE (NR DESC'S TO REPLICATE) - KX = MOD((MSTACK(1,I)/256),64) -C IF NEXT DESC IS NOT 7947 OR 7948 -C (I.E., 0 31 011 OR 0 31 012) - IF (MSTACK(1,I+1).NE.7947.AND.MSTACK(1,I+1).NE.7948) THEN -C SKIP IT - GO TO 1000 - END IF -C GET NR REPS FROM KDATA - NRREPS = KDATA(1,I+1) - LAST = I + 1 + KX -C SAVE OFF TRAILING DESCS AND DATA - KTRAIL = KNR(1) - I - 1 - KX - DO 100 L = 1, KTRAIL - NX = I + L + KX + 1 - LDATA(L) = KDATA(1,NX) - LSTACK(1,L) = MSTACK(1,NX) - LSTACK(2,L) = MSTACK(2,NX) - 100 CONTINUE -C INSERT FX DESCS/DATA NR REPS TIMES - LAST = I + 1 - DO 400 J = 1, NRREPS - NX = I + 2 - DO 300 K = 1, KX - LAST = LAST + 1 - KDATA(1,LAST) = KDATA(1,NX) - MSTACK(1,LAST) = MSTACK(1,NX) - MSTACK(2,LAST) = MSTACK(2,NX) - NX = NX + 1 - 300 CONTINUE - - 400 CONTINUE -C RESTORE TRAILING DATA/DESCS - DO 500 L = 1, KTRAIL - LAST = LAST + 1 - KDATA(1,LAST) = LDATA(L) - MSTACK(1,LAST) = LSTACK(1,L) - MSTACK(2,LAST) = LSTACK(2,L) - 500 CONTINUE -C RESET KNR(1) - KNR(1) = LAST - END IF - 1000 CONTINUE - RETURN - END - SUBROUTINE FI8812(IPTR,IUNITB,IUNITD,ISTACK,NRDESC,KPTRB,KPTRD, - * IRF1SW,NEWREF,ITBLD,ITBLD2, - * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1, - * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8812 BUILD TABLE B SUBSET BASED ON BUFR SEC 3 -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-12-23 -C -C ABSTRACT: BUILD A SUBSET OF TABLE B ENTRIES THAT CORRESPOND TO -C THE DESCRIPTORS NEEDED FOR THIS MESSAGE -C -C PROGRAM HISTORY LOG: -C 93-05-12 CAVANAUGH -C YY-MM-DD MODIFIER2 DESCRIPTION OF CHANGE -C -C USAGE: CALL FI8812(IPTR,IUNITB,IUNITD,ISTACK,NRDESC,KPTRB,KPTRD, -C * IRF1SW,NEWREF,ITBLD,ITBLD2, -C * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1, -C * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2) -C INPUT ARGUMENT LIST: -C IPTR - SEE W3FI88 ROUTINE DOCBLOCK -C IDENT - SEE W3FI88 ROUTINE DOCBLOCK -C ISTACK - LIST OF DESCRIPTORS AND SCALE VALUES -C IUNITB - -C IUNITD - -C ISTACK - -C NRDESC - -C KFXY2 - -C ANAME2 - -C AUNIT2 - -C ISCAL2 - -C IRFVL2 - -C IWIDE2 - -C IRF1SW - -C NEWREF - -C ITBLD2 - -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C MSTACK - LIST OF DESCRIPTORS AND SCALE VALUES -C KFXY1 - -C ANAME1 - -C AUNIT1 - -C ISCAL1 - -C IRFVL1 - -C IWIDE1 - -C ITBLD - -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - -C -C REMARKS: ERROR RETURN: -C IPTR(1) = -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ -C .................................................. -C -C NEW BASE TABLE B -C MAY BE A COMBINATION OF MASTER TABLE B -C AND ANCILLARY TABLE B -C - INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*) - CHARACTER*40 ANAME1(*) - CHARACTER*24 AUNIT1(*) -C .................................................. -C -C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE -C - INTEGER KFXY2(*),ISCAL2(*),IRFVL2(*),IWIDE2(*) - CHARACTER*64 ANAME2(*) - CHARACTER*24 AUNIT2(*) -C .................................................. -C -C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE -C - INTEGER ITBLD2(20,*) -C .................................................. -C -C NEW BASE TABLE D -C - INTEGER ITBLD(20,*) -C .................................................. - INTEGER IPTR(*),ISTACK(*),NRDESC,NWLIST(200) - INTEGER NEWREF(*),KPTRB(*),KPTRD(*) - INTEGER IUNITB,IUNITD,ICOPY(20000),NRCOPY,IELEM,IPOS - CHARACTER*64 AHLD64 - CHARACTER*24 AHLD24 -C - SAVE -C -C SCAN AND DISCARD REPLICATION AND OPERATOR DESCRIPTORS -C REPLACING SEQUENCE DESCRIPTORS WITH THEIR CORRESPONDING -C SET OF DESCRIPTORS ALSO ELIMINATING DUPLICATES. -C -C----------------------------------------------------------- -C PRINT *,'ENTER FI8812' -C - DO 10 I = 1, 16384 - KPTRB(I) = -1 - 10 CONTINUE -C -C -C - IF (IPTR(14).NE.0) THEN - DO I = 1, IPTR(14) - KPTRB(KFXY1(I)) = I - ENDDO - GO TO 9000 - END IF -C -C READ IN TABLE B - PRINT *,'FI8812 - READING TABLE B' - REWIND IUNITB - I = 1 - 4000 CONTINUE -C - READ(UNIT=IUNITB,FMT=20,ERR=9999,END=9000)MF, - * MX,MY, - * (ANAME1(I)(K:K),K=1,40), - * (AUNIT1(I)(K:K),K=1,24), - * ISCAL1(I),IRFVL1(1,I),IWIDE1(I) - 20 FORMAT(I1,I2,I3,40A1,24A1,I5,I15,1X,I4) - KFXY1(I) = MF*16384 + MX*256 + MY -C PRINT *,MF,MX,MY,KFXY1(I) - 5000 CONTINUE - KPTRB(KFXY1(I)) = I - IPTR(14) = I -C PRINT *,I -C WRITE(6,21) MF,MX,MY,KFXY1(I), -C * (ANAME1(I)(K:K),K=1,40), -C * (AUNIT1(I)(K:K),K=1,24), -C * ISCAL1(I),IRFVL1(1,I),IWIDE1(I) - 21 FORMAT(1X,I1,I2,I3,1X,I6,1X,40A1, - * 2X,24A1,2X,I5,2X,I15,1X,I4) - I = I + 1 - GO TO 4000 -C ====================================================== - 9999 CONTINUE -C ERROR READING TABLE B - PRINT *,'FI8812 - ERROR READING TABLE B - RECORD ',I - IPTR(1) = 9 - 9000 CONTINUE - IPTR(21) = IPTR(14) -C PRINT *,'EXIT FI8812 - IPTR(21) =',IPTR(21),' IPTR(1) =',IPTR(1) - RETURN - END - SUBROUTINE FI8813 (IPTR,MAXR,MAXD,MSTACK,KDATA,IDENT,KPTRD,KPTRB, - * ITBLD,ANAME1,AUNIT1,KFXY1,ISCAL1,IRFVL1,IWIDE1,IUNITB) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8813 EXTRACT TABLE A, TABLE B, TABLE D ENTRIES -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-03-04 -C -C ABSTRACT: EXTRACT TABLE A, TABLE B, TABLE D ENTRIES FROM A -C DECODED BUFR MESSAGE. -C -C PROGRAM HISTORY LOG: -C 94-03-04 CAVANAUGH -C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE -C -C USAGE: CALL FI8813 (IPTR,MAXR,MAXD,MSTACK,KDATA,IDENT,KPTRD, -C * KPTRB,ITBLD,ANAME1,AUNIT1,KFXY1,ISCAL1,IRFVL1,IWIDE1,IUNITB) -C INPUT ARGUMENT LIST: -C IPTR -C MAXR -C MAXD -C MSTACK -C KDATA -C IDENT -C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS, -C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE. -C -C OUTPUT ARGUMENT LIST: -C IUNITB -C ITBLD1 -C ANAME1 -C AUNIT1 -C KFXY1 -C ISCAL1 -C IRFVL1 -C IWIDE1 -C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE. -C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN -C ERRFLAG - EVEN IF MANY LINES ARE NEEDED -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS -C MACHINE: NAS, CYBER, WHATEVER -C -C$$$ -C .................................................. -C -C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE -C - INTEGER KFXY1(*),ISCAL1(*),IRFVL1(*),IWIDE1(*) - CHARACTER*40 ANAME1(*) - CHARACTER*24 AUNIT1(*) -C .................................................. -C -C TABLE D -C - INTEGER ITBLD(20,*) -C .................................................. - CHARACTER*32 SPACES - CHARACTER*8 ASCCHR - CHARACTER*32 AAAA -C - INTEGER I1(20),I2(20),I3(20),KPTRB(*) - INTEGER IPTR(*),MAXR,MAXD,MSTACK(2,MAXD) - INTEGER IXA, IXB, IXD, KDATA(MAXR,MAXD) - INTEGER IEXTRA,KPTRD(*) - INTEGER KEYSET,ISCSGN(200),IRFSGN(200) - INTEGER IDENT(*),IHOLD,JHOLD(8),IUNITB - EQUIVALENCE (IHOLD,ASCCHR),(JHOLD,AAAA) - SAVE - DATA SPACES/' '/ - DATA IEXTRA/0/ - DATA KEYSET/0/ - -C ============================================================== -C PRINT *,'FI8813',IPTR(41),IPTR(42),IPTR(31),IPTR(21) -C BUILD SPACE CONSTANT -C INITIALIZE ENTRY COUNTS - IXA = 0 -C NUMBER IN TABLE B - IXB = IPTR(21) -C -C -C SET FOR COMPRESSED OR NON COMPRESSED -C PROCESSING -C -C PRINT *,'FI8813 - 2',IDENT(16),IDENT(14) - IF (IDENT(16).EQ.0) THEN - JK = 1 - ELSE - JK = IDENT(14) - END IF -C PRINT *,'FI8813 - 3, JK=',JK -C -C -C START PROCESSING ENTRIES -C PRINT *,'START PROCESSING ENTRIES' -C -C DO 995 I = 1, IPTR(31) -C IF (IPTR(45).EQ.4) THEN -C PRINT 9958,I,MSTACK(1,I),KDATA(1,I),KDATA(1,I) -C9958 FORMAT (1X,I5,2X,I5,2X,Z8,2X,A4) -C ELSE -C PRINT 9959,I,MSTACK(1,I),KDATA(1,I),KDATA(1,I) -C9959 FORMAT (1X,I5,2X,I5,2X,Z16,2X,A8) -C END IF -C 995 CONTINUE -C PRINT *,' ' - I = 0 - IEXTRA = 0 - 1000 CONTINUE -C -C SET POINTER TO CORRECT DATA POSITION -C I IS THE NUMBER OF DESCRIPTORS -C IEXTRA IS THE NUMBER OF WORDS ADDED -C FOR TEXT DATA -C - I = I + 1 - IF (I.GT.IPTR(31)) THEN -C RETURN IF COMPLETED SEARCH - GO TO 9000 - END IF - KLK = I + IEXTRA -C PRINT *,'ENTRY',KLK,I,IPTR(31),IEXTRA,MSTACK(1,KLK) -C -C IF TABLE A ENTRY OR EDITION NUMBER -C OR IF DESCRIPTOR IS NOT IN CLASS 0 -C SKIP OVER -C - IF (MSTACK(1,KLK).EQ.1) THEN -C PRINT *,'A ENTRY' - GO TO 1000 - ELSE IF (MSTACK(1,KLK).EQ.2) THEN -C PRINT *,'A ENTRY LINE 1' - IEXTRA = IEXTRA + 32 / IPTR(45) - 1 - GO TO 1000 - ELSE IF (MSTACK(1,KLK).EQ.3) THEN -C PRINT *,'A ENTRY LINE 2' - IEXTRA = IEXTRA + 32 / IPTR(45) - 1 - GO TO 1000 - ELSE IF (MSTACK(1,KLK).GE.34048.AND.MSTACK(1,KLK).LE.34303) THEN - LY = MOD(MSTACK(1,KLK),256) -C PRINT *,'CLASS C - HAVE',LY,' BYTES OF TEXT' - IF (MOD(LY,IPTR(45)).EQ.0) THEN - IWDS = LY / IPTR(45) - ELSE - IWDS = LY / IPTR(45) + 1 - END IF - IEXTRA = IEXTRA + IWDS - 1 - GO TO 1000 - ELSE IF (MSTACK(1,KLK).LT.10.OR.MSTACK(1,KLK).GT.255) THEN -C PRINT *,MSTACK(1,KLK),' NOT CLASS 0' - GO TO 1000 - END IF -C -C MUST FIND F X Y KEY FOR TABLE B -C OR TABLE D ENTRY -C - IZ = 1 - KEYSET = 0 - 10 CONTINUE - IF (I.GT.IPTR(31)) THEN - GO TO 9000 - END IF - KLK = I + IEXTRA - IF (MSTACK(1,KLK).GE.34048.AND.MSTACK(1,KLK).LE.34303) THEN - LY = MOD(MSTACK(1,KLK),256) -C PRINT *,'TABLE C - HAVE',LY,' TEXT BYTES' - IF (MOD(LY,4).EQ.0) THEN - IWDS = LY / IPTR(45) - ELSE - IWDS = LY / IPTR(45) + 1 - END IF - IEXTRA = IEXTRA + IWDS - 1 - I = I + 1 - GO TO 10 - ELSE IF (MSTACK(1,KLK)/16384.NE.0) THEN - IF (MOD(MSTACK(1,KLK),256).EQ.0) THEN - I = I + 1 - END IF - I = I + 1 - GO TO 10 - END IF - IF (MSTACK(1,KLK).GE.10.AND.MSTACK(1,KLK).LE.12) THEN -C PRINT *,'FIND KEY' -C -C MUST INCLUDE PROCESSING FOR COMPRESSED DATA -C -C BUILD DESCRIPTOR SEGMENT -C - IF (MSTACK(1,KLK).EQ.10) THEN - CALL FI8814 (KDATA(IZ,KLK),1,MF,IERR,IPTR) -C PRINT *,'F =',MF,KDATA(IZ,KLK),IPTR(31),I,IEXTRA - KEYSET = IOR(KEYSET,4) - ELSE IF (MSTACK(1,KLK).EQ.11) THEN - CALL FI8814 (KDATA(IZ,KLK),2,MX,IERR,IPTR) -C PRINT *,'X =',MX,KDATA(IZ1,KLK) - KEYSET = IOR(KEYSET,2) - ELSE IF (MSTACK(1,KLK).EQ.12) THEN - CALL FI8814 (KDATA(IZ,KLK),3,MY,IERR,IPTR) -C PRINT *,'Y =',MY,KDATA(IZ,KLK) - KEYSET = IOR(KEYSET,1) - END IF -C PRINT *,' KEYSET =',KEYSET - I = I + 1 - GO TO 10 - END IF - IF (KEYSET.EQ.7) THEN -C PRINT *,'HAVE KEY DESCRIPTOR',MF,MX,MY -C -C TEST NEXT DESCRIPTOR FOR TABLE B -C OR TABLE D ENTRY, PROCESS ACCORDINGLY -C - KLK = I + IEXTRA -C PRINT *,'DESC ',MSTACK(1,KLK),KLK,I,IEXTRA,KDATA(1,KLK) - IF (MSTACK(1,KLK).EQ.30) THEN - IXD = IPTR(20) + 1 - ITBLD(1,IXD) =16384 * MF + 256 * MX + MY -C PRINT *,'SEQUENCE DESCRIPTOR',MF,MX,MY,ITBLD(1,IXD) - GO TO 300 - ELSE IF (MSTACK(1,KLK).GE.13.AND.MSTACK(1,KLK).LE.20) THEN - KFXY1(IXB+IZ) = 16384 * MF + 256 * MX + MY -C PRINT *,'ELEMENT DESCRIPTOR',MF,MX,MY,KFXY1(IXB+IZ),IXB+IZ - KPTRB(KFXY1(IXB+IZ)) = IXB+IZ - GO TO 200 - ELSE - END IF -C I = I + 1 -C IF (I.GT.IPTR(31)) THEN -C GO TO 9000 -C END IF -C GO TO 10 - END IF - GO TO 1000 -C ================================================================== - 200 CONTINUE - IBFLAG = 1 - 20 CONTINUE - KLK = I + IEXTRA -C PRINT *,'ZZZ',KLK,I,IEXTRA,MSTACK(1,KLK),KDATA(IZ,KLK) - IF (MSTACK(1,KLK).LT.13.OR.MSTACK(1,KLK).GT.20) THEN - PRINT *,'IMPROPER SEQUENCE OF DESCRIPTORS IN LIST' -C =============================================================== - ELSE IF (MSTACK(1,KLK).EQ.13) THEN -C PRINT *,'13 NAME',KLK -C -C ELEMENT NAME PART 1 - 32 BYTES -C FOR THIS PARAMETER - JJ = IEXTRA - DO 21 LL = 1, 32, IPTR(45) - LLL = LL + IPTR(45) - 1 - KQK = I + JJ - IHOLD = KDATA(IZ,KQK) - IF (IPTR(37).EQ.0) THEN -C CALL W3AI39 (IDATA,IPTR(45)) - END IF - ANAME1(IXB+IZ)(LL:LLL) = ASCCHR - JJ = JJ + 1 - 21 CONTINUE - IEXTRA = IEXTRA + (32 / IPTR(45)) - 1 - IBFLAG = IOR(IBFLAG,64) -C =============================================================== - ELSE IF (MSTACK(1,KLK).EQ.14) THEN -C PRINT *,'14 NAME2',KLK -C -C ELEMENT NAME PART 2 - 32 BYTES -C -C FOR THIS PARAMETER - JJ = IEXTRA - DO 22 LL = 33, 64, IPTR(45) - LLL = LL + IPTR(45) - 1 - KQK = I + JJ - IHOLD = KDATA(IZ,KQK) - IF (IPTR(37).EQ.0) THEN -C CALL W3AI39 (ASCCHR,IPTR(45)) - END IF - ANAME1(IXB+IZ)(LL:LLL) = ASCCHR - JJ = JJ + 1 - 22 CONTINUE - IEXTRA = IEXTRA + (32 / IPTR(45)) - 1 - IBFLAG = IOR(IBFLAG,32) -C =============================================================== - ELSE IF (MSTACK(1,KLK).EQ.15) THEN -C PRINT *,'15 UNITS',KLK -C -C UNITS NAME - 24 BYTES -C -C FOR THIS PARAMETER - JJ = IEXTRA - DO 23 LL = 1, 24, IPTR(45) - LLL = LL + IPTR(45) - 1 - KQK = I + JJ - IHOLD = KDATA(IZ,KQK) - IF (IPTR(37).EQ.0) THEN -C CALL W3AI39 (ASCCHR,IPTR(45)) - END IF - AUNIT1(IXB+IZ)(LL:LLL) = ASCCHR - JJ = JJ + 1 - 23 CONTINUE - IEXTRA = IEXTRA + (24 / IPTR(45)) - 1 - IBFLAG = IOR(IBFLAG,16) -C =============================================================== - ELSE IF (MSTACK(1,KLK).EQ.16) THEN -C PRINT *,'16 SCALE SIGN' -C -C SCALE SIGN - 1 BYTE -C 0 = POS, 1 = NEG - IHOLD = KDATA(IZ,KLK) - KLK = I + IEXTRA - IF (INDEX(ASCCHR,'-').EQ.0) THEN - ISCSGN(IZ) = 1 - ELSE - ISCSGN(IZ) = -1 - END IF -C =============================================================== - ELSE IF (MSTACK(1,KLK).EQ.17) THEN -C PRINT *,'17 SCALE',KLK -C -C SCALE - 3 BYTES -C - KLK = I + IEXTRA - CALL FI8814(KDATA(IZ,KLK),3,ISCAL1(IXB+IZ),IERR,IPTR) - IF (IERR.NE.0) THEN - PRINT *,'NON-NUMERIC CHAR - CANNOT CONVERT' - IPTR(1) = 888 - GO TO 9000 - END IF - ISCAL1(IXB+IZ) = ISCAL1(IXB+IZ) * ISCSGN(IZ) - IBFLAG = IOR(IBFLAG,8) -C =============================================================== - ELSE IF (MSTACK(1,KLK).EQ.18) THEN -C PRINT *,'18 REFERENCE SCALE',KLK -C -C REFERENCE SIGN - 1 BYTE -C 0 = POS, 1 = NEG -C - KLK = I + IEXTRA - IHOLD = KDATA(IZ,KLK) - IF (INDEX(ASCCHR,'-').EQ.0) THEN - IRFSGN(IZ) = 1 - ELSE - IRFSGN(IZ) = -1 - END IF -C =============================================================== - ELSE IF (MSTACK(1,KLK).EQ.19) THEN -C PRINT *,'19 REFERENCE VALUE',KLK -C -C REFERENCE VALUE - 10 BYTES/ 3 WDS -C - JJ = IEXTRA - KQK = I + JJ - KM = 0 - DO 26 LL = 1, 12, IPTR(45) - KQK = I + JJ - KM = KM + 1 - JHOLD(KM) = KDATA(IZ,KQK) - JJ = JJ + 1 - 26 CONTINUE - CALL FI8814(AAAA,10,IRFVL1(IXB+IZ),IERR,IPTR) - IF (IERR.NE.0) THEN - PRINT *,'NON-NUMERIC CHARACTER-CANNOT CONVERT' - IPTR(1) = 888 - GO TO 9000 - END IF - IRFVL1(IXB+IZ) = IRFVL1(IXB+IZ) * IRFSGN(IZ) - IEXTRA = IEXTRA + 10 / IPTR(45) -C DO 261 IZ = 1, JK -C PRINT *,'RFVAL',IXB+IZ,JK,IRFVL1(IXB+IZ) -C 261 CONTINUE - IBFLAG = IOR(IBFLAG,4) -C =============================================================== - ELSE -C PRINT *,'20 WIDTH',KLK -C -C ELEMENT DATA WIDTH - 3 BYTES -C -C DO 27 LL = 1, 24, IPTR(45) - KLK = I + IEXTRA -C DO 270 IZ = 1, JK - CALL FI8814(KDATA(IZ,KLK),3,IWIDE1(IXB+IZ),IERR,IPTR) - IF (IERR.NE.0) THEN - PRINT *,'NON-NUMERIC CHAR - CANNOT CONVERT' - IPTR(1) = 888 - GO TO 9000 - END IF - IF (IWIDE1(IXB+IZ).LT.1) THEN - IPTR(1) = 890 -C PRINT *,'CLASS 0 DESCRIPTOR, WIDTH=0',KFXY1(IXB+IZ) - GO TO 9000 - END IF -C 270 CONTINUE -C 27 CONTINUE - IBFLAG = IOR(IBFLAG,2) - END IF -C NO, IT ISN'T -C -C IF THERE ARE ENOUGH OF THE ELEMENTS -C NECESSARY TO ACCEPT A TABLE B ENTRY -C -C PRINT *,' IBFLAG =',IBFLAG - IF (IBFLAG.EQ.127) THEN -C PRINT *,'COMPLETE TABLE B ENTRY' -C HAVE A COMPLETE TABLE B ENTRY - IXB = IXB + 1 -C PRINT *,'B',IXB,JK,KFXY1(IXB),ANAME1(IXB) -C PRINT *,' ',AUNIT1(IXB),ISCAL1(IXB), -C * IRFVL1(IXB),IWIDE1(IXB) - IPTR(21) = IXB - GO TO 1000 - END IF - I = I + 1 -C -C CHECK NEXT DESCRIPTOR -C - IF (I.GT.IPTR(31)) THEN -C RETURN IF COMPLETED SEARCH - GO TO 9000 - END IF - GO TO 20 -C ================================================================== - 300 CONTINUE - ISEQ = 0 - IJK = IPTR(20) + 1 -C PRINT *,'SEQUENCE DESCRIPTOR',MF,MX,MY,ITBLD(1,IXD),' FOR',IJK - 30 CONTINUE - KLK = I + IEXTRA -C PRINT *,'HAVE A SEQUENCE DESCRIPTOR',KLK,KDATA(IZ,KLK) - IF (MSTACK(1,KLK).EQ.30) THEN -C FROM TEXT FIELD (6 BYTES/2 WDS) -C STRIP OUT NEXT DESCRIPTOR IN SEQUENCE -C -C F - EXTRACT AND CONVERT TO DECIMAL - JJ = IEXTRA - KK = 0 - DO 351 LL = 1, 6, IPTR(45) - KQK = I + JJ - KK = KK + 1 - JHOLD(KK) = KDATA(1,KQK) - JJ = JJ + 1 - IF (LL.GT.1) IEXTRA = IEXTRA + 1 - 351 CONTINUE -C PRINT 349,KDATA(1,KQK) - 349 FORMAT (6X,Z24) -C CONVERT TO INTEGER - CALL FI8814(AAAA,6,IHOLD,IERR,IPTR) -C PRINT *,' ',IHOLD - IF (IERR.NE.0) THEN - PRINT *,'NON NUMERIC CHARACTER FOUND IN F X Y' - IPTR(1) = 888 - GO TO 9000 - END IF -C CONSTRUCT SEQUENCE DESCRIPTOR - IFF = IHOLD / 100000 - IXX = MOD((IHOLD/1300),100) - IYY = MOD(IHOLD,1300) -C INSERT IN PROPER SEQUENCE - ITBLD(ISEQ+2,IJK) = 16384 * IFF + 256 * IXX + IYY -C PRINT *,' SEQUENCE',IZ,AAAA,IHOLD,ITBLD(ISEQ+2,IJK), -C * IFF,IXX,IYY - ISEQ = ISEQ + 1 - IF (ISEQ.GT.18) THEN - IPTR(1) = 30 - RETURN - END IF -C SET TO LOOK AT NEXT DESCRIPTOR - I = I + 1 -C IF (IPTR(45).LT.6) THEN -C IEXTRA = IEXTRA + 1 -C END IF - GO TO 30 - ELSE -C NEXT DESCRIPTOR IS NOT A SEQUENCE DESCRIPTOR - IF (ISEQ.GE.1) THEN -C HAVE COMPLETE TABLE D ENTRY - IPTR(20) = IPTR(20) + 1 -C PRINT *,' INTO LOCATION ',IPTR(20) - LZ = ITBLD(1,IJK) - MZ = MOD(LZ,16384) - KPTRD(MZ) = IJK - I = I - 1 - END IF - END IF -C GO TEST NEXT DESCRIPTOR - GO TO 1000 -C ================================================================== - 9000 CONTINUE -C PRINT *,IPTR(21),' ENTRIES IN ANCILLARY TABLE B' -C PRINT *,IPTR(20),' ENTRIES IN ANCILLARY TABLE D' -C DO 9050 L = 1, 16384 -C IF (KPTRD(L).GT.0) PRINT *,' D',L+32768, KPTRD(L) -C9050 CONTINUE -C IF (I.GE.IPTR(31)) THEN -C -C FILE FOR MODIFIED TABLE B OUTPUT - NUMNUT = IUNITB + 1 - REWIND NUMNUT -C -C PRINT *,' HERE IS THE NEW TABLE B',IPTR(21) - DO 2000 KB = 1, IPTR(21) - JF = KFXY1(KB) / 16384 - JX = MOD((KFXY1(KB) / 256),64) - JY = MOD(KFXY1(KB),256) -C WRITE (6,2001)JF,JX,JY,ANAME1(KB), -C * AUNIT1(KB),ISCAL1(KB),IRFVL1(KB),IWIDE1(KB) - WRITE (NUMNUT,5000)JF,JX,JY,ANAME1(KB)(1:40), - * AUNIT1(KB)(1:24),ISCAL1(KB),IRFVL1(KB),IWIDE1(KB) - 5000 FORMAT(I1,I2,I3,A40,A24,I5,I15,I5) - 2000 CONTINUE - 2001 FORMAT (1X,I1,1X,I2,1X,I3,2X,A40,3X,A24,2X,I5,2X,I12, - * 2X,I4) -C - ENDFILE NUMNUT -C - IF (IPTR(20).NE.0) THEN -C PRINT OUT TABLE -C PRINT *,' HERE IS THE UPGRADED TABLE D' -C DO 3000 KB = 1, IPTR(20) -C PRINT 3001,KB,(ITBLD(K,KB),K=1,15) -C3000 CONTINUE -C3001 FORMAT (16(1X,I5)) - END IF -C EXIT ROUTINE, ALL DONE WITH PASS -C END IF - RETURN - END - SUBROUTINE FI8814 (ASCCHR,NPOS,NEWVAL,IERR,IPTR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8814 CONVERT TEXT TO INTEGER -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-03-04 -C -C ABSTRACT: CONVERT TEXT CHARACTERS TO INTEGER VALUE -C -C PROGRAM HISTORY LOG: -C 94-03-04 CAVANAUGH -C YY-MM-DD MODIFIER2 DESCRIPTION OF CHANGE -C -C USAGE: CALL FI8814 (ASCCHR,NPOS,NEWVAL,IERR,IPTR) -C INPUT ARGUMENT LIST: -C ASCCHR - -C NPOS - -C NEWVAL - -C IERR - -C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS, -C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE. -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE. -C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN -C ERRFLAG - EVEN IF MANY LINES ARE NEEDED -C -C INPUT FILES: (DELETE IF NO INPUT FILES IN SUBPROGRAM) -C DDNAME1 - GENERIC NAME & CONTENT -C -C OUTPUT FILES: (DELETE IF NO OUTPUT FILES IN SUBPROGRAM) -C DDNAME2 - GENERIC NAME & CONTENT AS ABOVE -C FT06F001 - INCLUDE IF ANY PRINTOUT -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS -C MACHINE: NAS, CYBER, WHATEVER -C -C$$$ - INTEGER IERR, IHOLD, IPTR(*) - CHARACTER*8 AHOLD - CHARACTER*64 ASCCHR - EQUIVALENCE (IHOLD,AHOLD) - - SAVE -C ---------------------------------------------------------- - IERR = 0 - NEWVAL = 0 - IFLAG = 0 -C - DO 1000 I = 1, NPOS - IHOLD = 0 - AHOLD(IPTR(45):IPTR(45)) = ASCCHR(I:I) - IF (IPTR(37).EQ.1) THEN - IF (IHOLD.EQ.32) THEN - IF (IFLAG.EQ.0) GO TO 1000 - GO TO 2000 - ELSE IF (IHOLD.LT.48.OR.IHOLD.GT.57) THEN -C PRINT*,' ASCII IHOLD =',IHOLD - IERR = 1 - RETURN - ELSE - IFLAG = 1 - NEWVAL = NEWVAL * 10 + IHOLD - 48 - END IF - ELSE - IF (IHOLD.EQ.64) THEN - IF (IFLAG.EQ.0) GO TO 1000 - GO TO 2000 - ELSE IF (IHOLD.LT.240.OR.IHOLD.GT.249) THEN -C PRINT*,' EBCIDIC IHOLD =',IHOLD - IERR = 1 - RETURN - ELSE - IFLAG = 1 - NEWVAL = NEWVAL * 10 + IHOLD - 240 - END IF - END IF - 1000 CONTINUE - 2000 CONTINUE - RETURN - END - SUBROUTINE FI8815(IPTR,IDENT,JDESC,KDATA,KFXY3,MAXR,MAXD, - * ANAME3,AUNIT3, - * ISCAL3,IRFVL3,IWIDE3, - * KEYSET,IBFLAG,IERR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8815 EXTRACT TABLE A, TABLE B, TABLE D ENTRIES -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-03-04 -C -C ABSTRACT: EXTRACT TABLE A, TABLE B, ENTRIES FROM ACTIVE BUFR MESSAGE -C TO BE RETAINED FOR USE DURING THE DECODING OF ACTIVE BUFR MESSAGE. -C THESE WILL BE DISCARDED WHEN DECODING OF CURRENT MESSAGE IS COMPLETE -C -C PROGRAM HISTORY LOG: -C 94-03-04 CAVANAUGH -C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE -C -C USAGE: CALL FI8815(IPTR,IDENT,JDESC,KDATA,KFXY3,MAXR,MAXD, -C * ANAME3,AUNIT3, -C * ISCAL3,IRFVL3,IWIDE3, -C * KEYSET,IBFLAG,IERR) -C INPUT ARGUMENT LIST: -C IPTR - -C MAXR - -C MAXD - -C MSTACK - -C KDATA - -C IDENT - -C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS, -C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE. -C -C OUTPUT ARGUMENT LIST: -C ANAME3 - -C AUNIT3 - -C KFXY3 - -C ISCAL3 - -C IRFVL3 - -C IWIDE3 - -C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE. -C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN -C ERRFLAG - EVEN IF MANY LINES ARE NEEDED -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS -C MACHINE: NAS, CYBER -C -C$$$ - CHARACTER*64 ANAME3(*),SPACES - CHARACTER*24 AUNIT3(*) -C - INTEGER IPTR(*),MAXR,MAXD,JDESC - INTEGER IXA, IXB, IXD, KDATA(MAXR,MAXD) - INTEGER IEXTRA - INTEGER KEYSET - INTEGER KFXY3(*),IDENT(*) - INTEGER ISCAL3(*),ISCSGN(150) - INTEGER IRFVL3(*),IRFSGN(150) - INTEGER IWIDE3(*) - - SAVE -C ============================================================== -C PRINT *,'FI8815' - IEXTRA = 0 -C BUILD SPACE CONSTANT - DO 1 I = 1, 64 - SPACES(I:I) = ' ' - 1 CONTINUE -C INITIALIZE ENTRY COUNTS - IXA = 0 - IXB = 0 - IXD = 0 -C -C SET FOR COMPRESSED OR NON COMPRESSED -C PROCESSING -C - IF (IDENT(16).EQ.0) THEN - JK = 1 - ELSE - JK = IDENT(14) - END IF -C -C CLEAR NECESSARY ENTRIES -C - DO 2 IY = 1, JK -C -C CLEAR NEXT TABLE B ENTRY -C - KFXY3(IXB+IY) = 0 - ANAME3(IXB+IY)(1:64) = SPACES(1:64) - AUNIT3(IXB+IY)(1:24) = SPACES(1:24) - ISCAL3(IXB+IY) = 0 - IRFVL3(IXB+IY) = 0 - IWIDE3(IXB+IY) = 0 - ISCSGN(IY) = 1 - IRFSGN(IY) = 1 - 2 CONTINUE -C -C START PROCESSING ENTRIES -C - I = 0 - 1000 CONTINUE -C -C SET POINTER TO CORRECT DATA POSITION -C - K = I + IEXTRA -C -C MUST FIND F X Y KEY FOR TABLE B -C OR TABLE D ENTRY -C - IF (JDESC.GE.10.AND.JDESC.LE.12) THEN - 10 CONTINUE -C -C BUILD DESCRIPTOR SEGMENT -C - DO 20 LY = 1,JK - IF (JDESC.EQ.10) THEN - KFXY3(IXB+LY) = KDATA(K,1) * 16384 + KFXY3(IXB+LY) - KEYSET = IOR(KEYSET,4) - I = I + 1 - GO TO 10 - ELSE IF (JDESC.EQ.11) THEN - KFXY3(IXB+LY) = KDATA(K,1) * 256 + KFXY3(IXB+LY) - KEYSET = IOR(KEYSET,2) - I = I + 1 - GO TO 10 - ELSE IF (JDESC.EQ.12) THEN - KFXY3(IXB+LY) = KDATA(K,1) + KFXY3(IXB+LY) - KEYSET = IOR(KEYSET,1) - END IF - 20 CONTINUE -C ================================================================== - ELSE IF (JDESC.GE.13.AND.JDESC.LE.20) THEN - DO 250 IZ = 1, JK - IF (JDESC.EQ.13) THEN -C -C ELEMENT NAME PART 1 - 32 BYTES/8 WDS -C - CALL GBYTES (ANAME3(IXB+IZ),KDATA(K,IZ),0,32,0,8) - IBFLAG = IOR(IBFLAG,16) - ELSE IF (JDESC.EQ.14) THEN -C -C ELEMENT NAME PART 2 - 32 BYTES/8 WDS -C - CALL GBYTES(ANAME3(IXB+IZ)(33:33),KDATA(K,IZ),0,32,0,8) - ELSE IF (JDESC.EQ.15) THEN -C -C UNITS NAME - 24 BYTES/6 WDS -C - CALL GBYTES (AUNIT3(IXB+IZ)(1:1),KDATA(K,IZ),0,32,0,6) - IBFLAG = IOR(IBFLAG,8) - ELSE IF (JDESC.EQ.16) THEN -C -C UNITS SCALE SIGN - 1 BYTE/ 1 WD -C 0 = POS, 1 = NEG - IF (KDATA(K,1).NE.48) THEN - ISCSGN(IZ) = -1 - ELSE - ISCSGN(IZ) = 1 - END IF - ELSE IF (JDESC.EQ.17) THEN -C -C UNITS SCALE - 3 BYTES/ 1 WD -C - CALL FI8814(KDATA(K,IZ),3,ISCAL3(IXB+IZ),IERR,IPTR) - IF (IERR.NE.0) THEN - PRINT *,'NON-NUMERIC CHARACTER - CANNOT CONVERT' - IPTR(1) = 888 - RETURN - END IF - IBFLAG = IOR(IBFLAG,4) - ELSE IF (JDESC.EQ.18) THEN -C -C UNITS REFERENCE SIGN - 1 BYTE/ 1 WD -C 0 = POS, 1 = NEG -C - IF (KDATA(K,1).EQ.48) THEN - IRFSGN(IZ) = 1 - ELSE - IRFSGN(IZ) = -1 - END IF - ELSE IF (JDESC.EQ.19) THEN -C -C UNITS REFERENCE VALUE - 10 BYTES/ 3 WDS -C - CALL FI8814(KDATA(K,IZ),10,IRFVL3(IXB+IZ),IERR,IPTR) - IF (IERR.NE.0) THEN - PRINT *,'NON-NUMERIC CHARACTER-CANNOT CONVERT' - IPTR(1) = 888 - RETURN - END IF - IBFLAG = IOR(IBFLAG,2) - ELSE -C -C ELEMENT DATA WIDTH - 3 BYTES/ 1 WD -C - CALL FI8814(KDATA(K,1),3,IWIDE3(IXB+1),IERR,IPTR) - IF (IERR.NE.0) THEN - PRINT *,'NON-NUMERIC CHARACTER-CANNOT CONVERT' - IPTR(1) = 888 - RETURN - END IF - IBFLAG = IOR(IBFLAG,1) - END IF - 250 CONTINUE - END IF -C ================================================================== - 9000 RETURN - END - SUBROUTINE FI8818(IPTR, - * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1, - * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2, - * KPTRB) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8818 MERGE ANCILLARY & STANDARD B ENTRIES -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: YY-MM-DD -C -C ABSTRACT: START ABSTRACT HERE AND INDENT TO COLUMN 5 ON THE -C FOLLOWING LINES. SEE NMC HANDBOOK SECTION 3.1.1. FOR DETAILS -C -C PROGRAM HISTORY LOG: -C YY-MM-DD CAVANAUGH -C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE -C -C USAGE: CALL FI8818(IPTR, -C * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1, -C * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2,KPTRB) -C INPUT ARGUMENT LIST: -C IPTR - -C KFXY1 - -C ANAME1 - -C AUNIT1 - -C ISCAL1 - -C IRFVL1 - -C IWIDE1 - -C KFXY2 - -C ANAME2 - -C AUNIT2 - -C ISCAL2 - -C IRFVL2 - -C IWIDE2 - -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C IPTR - -C KFXY1 - -C ANAME1 - -C AUNIT1 - -C ISCAL1 - -C IRFVL1 - -C IWIDE1 - -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS -C MACHINE: NAS, CYBER, WHATEVER -C -C$$$ -C .................................................. -C -C NEW BASE TABLE B -C MAY BE A COMBINATION OF MASTER TABLE B -C AND ANCILLARY TABLE B -C - INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*) - CHARACTER*40 ANAME1(*) - CHARACTER*24 AUNIT1(*) -C .................................................. -C -C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE -C - INTEGER KFXY2(*),ISCAL2(*),IRFVL2(*),IWIDE2(*) - CHARACTER*64 ANAME2(*) - CHARACTER*24 AUNIT2(*) -C .................................................. - INTEGER IPTR(*),KPTRB(*) - - SAVE -C -C SET UP POINTERS -C PRINT *,'FI8818-A',IPTR(21),IPTR(41) - KAB = 1 - KB = 1 - 1000 CONTINUE -C PRINT *,KB,KAB,KFXY1(KB),KFXY2(KAB),IPTR(21) - IF (KB.GT.IPTR(21)) THEN -C NO MORE MASTER ENTRIES -C PRINT *,'NO MORE MASTER ENTRIES' - IF (KAB.GT.IPTR(41)) THEN - GO TO 5000 - END IF -C APPEND ANCILLARY ENTRY - GO TO 2000 - ELSE IF (KB.LE.IPTR(21)) THEN -C HAVE MORE MASTER ENTRIES - IF (KAB.GT.IPTR(41)) THEN -C NO MORE ANCILLARY ENTRIES - GO TO 5000 - END IF - IF (KFXY2(KAB).EQ.KFXY1(KB)) THEN -C REPLACE MASTER ENTRY - GO TO 3000 - ELSE IF (KFXY2(KAB).LT.KFXY1(KB)) THEN -C INSERT ANCILLARY ENTRY - GO TO 2000 - ELSE IF (KFXY2(KAB).GT.KFXY1(KB)) THEN -C SKIP MASTER ENTRY - KB = KB + 1 - END IF - END IF - GO TO 1000 - 2000 CONTINUE - IPTR(21) = IPTR(21) + 1 - KPTRB(KFXY2(KAB)) = IPTR(21) -C APPEND ANCILLARY ENTRY - KFXY1(IPTR(21)) = KFXY2(KAB) - ANAME1(IPTR(21))(1:40) = ANAME2(KAB)(1:40) - AUNIT1(IPTR(21)) = AUNIT2(KAB) - ISCAL1(IPTR(21)) = ISCAL2(KAB) - IRFVL1(1,IPTR(21)) = IRFVL2(KAB) - IWIDE1(IPTR(21)) = IWIDE2(KAB) -C PRINT *,IPTR(21),KFXY1(IPTR(21)),' APPENDED' - KAB = KAB + 1 - GO TO 1000 - 3000 CONTINUE -C REPLACE MASTER ENTRY - KFXY1(KB) = KFXY2(KAB) - ANAME1(KB) = ANAME2(KAB)(1:40) - AUNIT1(KB) = AUNIT2(KAB) - ISCAL1(KB) = ISCAL2(KAB) - IRFVL1(1,KB) = IRFVL2(KAB) - IWIDE1(KB) = IWIDE2(KAB) -C PRINT *,KB,KFXY1(KB),'REPLACED',IWIDE1(KB) - KAB = KAB + 1 - KB = KB + 1 - GO TO 1000 - 5000 CONTINUE - IPTR(41) = 0 -C PROCESSING COMPLETE -C PRINT *,'FI8818-B',IPTR(21),IPTR(41) -C DO 6000 I = 1, IPTR(21) -C PRINT *,'FI8818-C',I,KFXY1(I),IWIDE1(I) -C6000 CONTINUE - RETURN - END - SUBROUTINE FI8819(IPTR,ITBLD,ITBLD2,KPTRD) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8819 MERGE ANCILLARY & MASTER TABLE D -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: YY-MM-DD -C -C ABSTRACT: MERGE TABLE D ENTRIES WITH THE ENTRIES FROM THE STANDARD -C TABLE D. ASSURE THAT ENTRIES ARE SEQUENTIAL. -C -C PROGRAM HISTORY LOG: -C YY-MM-DD CAVANAUGH -C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE -C -C USAGE: CALL FI8819(IPTR,ITBLD,ITBLD2,KPTRD) -C INPUT ARGUMENT LIST: -C IPTR - -C ITBLD - -C ITBLD2 - -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C IPTR - -C ITBLD - -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS, CYBER -C -C$$$ -C .................................................. -C -C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE -C - INTEGER ITBLD2(20,*) -C .................................................. -C -C NEW BASE TABLE D -C - INTEGER ITBLD(20,*) -C .................................................. - INTEGER IPTR(*),KPTRD(*) - - SAVE -C PRINT *,'FI8819-A',IPTR(20),IPTR(42) -C SET UP POINTERS - DO 1000 I = 1, IPTR(42) - IPTR(20) = IPTR(20) + 1 - DO 500 J = 1, 20 - ITBLD(J,IPTR(20)) = ITBLD2(J,I) - MPTRD = MOD(ITBLD(J,IPTR(20)),16384) - KPTRD(MPTRD) = IPTR(20) - 500 CONTINUE - 1000 CONTINUE -C ======================================================= - IPTR(42) = 0 -C PRINT *,'MERGED TABLE D -- FI8819-B',IPTR(20),IPTR(42) -C DO 6000 I = 1, IPTR(20) -C WRITE (6,6001)I,(ITBLD(J,I),J=1,20) -C6001 FORMAT(15(1X,I5)) -C6000 CONTINUE - RETURN - END - SUBROUTINE FI8820 (ITBLD,IUNITD,IPTR,ITBLD2,KPTRD) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8820 READ IN BUFR TABLE D -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-05-06 -C -C ABSTRACT: READ IN BUFR TABLE D -C -C PROGRAM HISTORY LOG: -C 93-05-06 CAVANAUGH -C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE -C -C USAGE: CALL FI8820 (ITBLD,IUNITD,IPTR,ITBLD2,KPTRD) -C INPUT ARGUMENT LIST: -C IUNITD - UNIT NUMBER FOR TABLE D INPUT -C IPTR - ARRAY OF WORKING VALUES -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C ITBLD - ARRAY TO CONTAIN TABLE D -C -C REMARKS: -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ -C .................................................. -C -C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE -C - INTEGER ITBLD2(20,*) -C .................................................. -C -C NEW BASE TABLE D -C - INTEGER ITBLD(20,*) -C .................................................. -C - INTEGER IHOLD(33),IPTR(*),KPTRD(*) - LOGICAL MORE - - SAVE -C - MORE = .TRUE. - I = 0 -C -C READ IN TABLE D, BUT JUST ONCE -C PRINT *,'TABLE D SWITCH=',IPTR(20),' ANCILLARY D SW=',IPTR(42) - IF (IPTR(20).EQ.0) THEN - DO 1000 MM = 1, 16384 - KPTRD(MM) = -1 - 1000 CONTINUE - IERR = 0 - PRINT *,'FI8820 - READING TABLE D' - KEY = 0 - 100 CONTINUE -C READ NEXT TABLE D ENTRY - READ(IUNITD,15,ERR=9998,END=9000)(IHOLD(M),M=1,33) - 15 FORMAT(11(I1,I2,I3,1X),3X) -C BUILD KEY FROM MASTER D ENTRY -C INSERT NEW MASTER INTO TABLE B - I = I + 1 - IPTR(20) = IPTR(20) + 1 - DO 25 JJ = 1, 41, 3 - KK = (JJ/3) + 1 - IF (JJ.LE.31) THEN - ITBLD(KK,I) = IHOLD(JJ)*16384 + - * IHOLD(JJ+1)*256 + IHOLD(JJ+2) - IF (ITBLD(KK,I).LT.1.OR.ITBLD(KK,I).GT.65535) THEN - ITBLD(KK,I) = 0 - GO TO 25 - END IF - ELSE - ITBLD(KK,I) = 0 - END IF - 25 CONTINUE - MPTRD = MOD(ITBLD(1,I),16384) - KPTRD(MPTRD) = I - 50 CONTINUE -C WRITE (6,51)I,(ITBLD(L,I),L=1,15) - 51 FORMAT (7H TABLED,16(1X,I5)) - GO TO 100 - ELSE -C PRINT *,'TABLE D IS IN PLACE' - END IF - GO TO 9999 - 9000 CONTINUE - CLOSE(UNIT=IUNITD,STATUS='KEEP') - GO TO 9999 - 9998 CONTINUE - IPTR(1) = 8 -C - 9999 CONTINUE -C PRINT *,'THERE ARE',IPTR(20),' ENTRIES IN TABLE D' - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fi92.f b/src/fim/FIMsrc/w3/w3fi92.f deleted file mode 100644 index ac1f9cc..0000000 --- a/src/fim/FIMsrc/w3/w3fi92.f +++ /dev/null @@ -1,216 +0,0 @@ - SUBROUTINE W3FI92 (LOC,TTAAII,KARY,KWBX,IERR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI92 BUILD 80-CHAR ON295 GRIB QUEUE DESCRIPTOR -C PRGMMR: CAVANAUGH ORG: NMC421 DATE:95-01-31 -C -C ABSTRACT: BUILD 80 CHARACTER QUEUE DESCRIPTOR USING INFORMATION -C SUPPLIED BY USER, PLACING THE COMPLETED QUEUE DESCRIPTOR IN THE -C LOCATION SPECIFIED BY THE USER. (BASED ON OFFICE NOTE 295). -C NOTE - THIS IS A MODIFIED VERSION OF W3FI62 WHICH ADDS THE -C 'KWBX' PARAMETER. THIS VALUE WILL NOW BE ADDED TO -C BYTES 35-38 FOR ALL GRIB PRODUCTS. -C QUEUE DESCIPTORS FOR NON-GRIB PRODUCTS WILL CONTINUE -C TO BE GENERATYED BY W3FI62. -C -C PROGRAM HISTORY LOG: -C 91-06-21 CAVANAUGH -C 94-03-08 CAVANAUGH MODIFIED TO ALLOW FOR BULLETIN SIZES THAT -C EXCEED 20000 BYTES -C 94-04-28 R.E.JONES CHANGE FOR CRAY 64 BIT WORD SIZE AND -C FOR ASCII CHARACTER SET COMPUTERS -C 95-10-16 J.SMITH MODIFIED VERSION OF W3FI62 TO ADD 'KWBX' -C TO BYTES 35-38 OF QUEUE DESCRIPTOR. -C 96-01-29 R.E.JONES PRESET IERR TO ZERO. -C 02-10-15 VUONG REPLACED FUNCTION ICHAR WITH MOVA2I -C -C USAGE: CALL W3FI92 (LOC,TTAAII,KARY,KWBX,IERR) -C INPUT ARGUMENT LIST: -C TTAAII - FIRST 6 CHARACTERS OF WMO HEADER -C KARY - INTEGER ARRAY CONTAINING USER INFORMATION -C (1) = DAY OF MONTH -C (2) = HOUR OF DAY -C (3) = HOUR * 100 + MINUTE -C (4) = CATALOG NUMBER -C (5) = NUMBER OF 80 BYTE INCREMENTS -C (6) = NUMBER OF BYTES IN LAST INCREMENT -C (7) = TOTAL SIZE OF MESSAGE -C WMO HEADER + BODY OF MESSAGE IN BYTES -C (NOT INCLUDING QUEUE DESCRIPTOR) -C KWBX - = 4 CHARACTERS, REPRESENTING TH FCST MODEL -C THAT THE BULLETIN WAS DERIVED FROM. -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C LOC - LOCATION TO RECEIVE QUEUE DESCRIPTOR -C KARY - SEE INPUT ARGUMENT LIST -C IERR - ERROR RETURN -C -C SUBPROGRAMS CALLED: (LIST ALL CALLED FROM ANYWHERE IN CODES) -C LIBRARY: -C W3LIB - GBYTE W3FI01 W3AI15 W3AI39 -C -C REMARKS: IF TOTAL SIZE IS ENTERED (KARY(7)) THEN KARY(5) AND -C KARY(6) WILL BE CALCULATED. -C IF KARY(5) AND KARY(6) ARE PROVIDED THEN KARY(7) WILL -C BE IGNORED. -C -C WARNING: EQUIVALENCE ARRAY LOC TO INTEGER ARRAY SO IT STARTS ON -C A WORD BOUNDARY FOR SBYTE SUBROUTINE. -C -C ERROR RETURNS -C IERR = 1 TOTAL BYTE COUNT AND/OR 80 BYTE INCREMENT -C COUNT IS MISSING. ONE OR THE OTHER IS -C REQUIRED TO COMPLETE THE QUEUE DESCRIPTOR. -C IERR = 2 TOTAL SIZE TOO SMALL -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: HDS -C -C$$$ -C - INTEGER IHOLD(2) - INTEGER KARY(7),IERR -C - LOGICAL IBM370 -C - CHARACTER*6 TTAAII,AHOLD - CHARACTER*80 LOC - CHARACTER*1 BLANK - CHARACTER*4 KWBX -C - EQUIVALENCE (AHOLD,IHOLD) -C - SAVE -C -C BLANK WILL BE 40 HEX OR DECIMAL 64 ON AN IBM370 TYPE -C COMPUTER, THIS IS THE EBCDIC CHARACTER SET. -C BLANK WILL BE 20 HEX OR DECIMAL 32 ON A COMPUTER WITH THE -C ASCII CHARACTER SET. THIS WILL BE USED TO TEST FOR CHARACTER -C SETS TO FIND IBM370 TYPE COMPUTER. -C - DATA BLANK /' '/ -C ---------------------------------------------------------------- -C -C TEST FOR CRAY 64 BIT COMPUTER, LW = 8 -C - CALL W3FI01(LW) -C -C TEST FOR EBCDIC CHARACTER SET -C - IBM370 = .FALSE. - IF (MOVA2I(BLANK).EQ.64) THEN - IBM370 = .TRUE. - END IF -C - INOFST = 0 -C BYTES 1-16 'QUEUE DESCRIPTOR' - CALL SBYTE (LOC,-656095772,INOFST,32) - INOFST = INOFST + 32 - CALL SBYTE (LOC,-985611067,INOFST,32) - INOFST = INOFST + 32 - CALL SBYTE (LOC,-490481207,INOFST,32) - INOFST = INOFST + 32 - CALL SBYTE (LOC,-672934183,INOFST,32) - INOFST = INOFST + 32 -C BYTES 17-20 INTEGER ZEROES - CALL SBYTE (LOC,0,INOFST,32) - INOFST = INOFST + 32 -C IF TOTAL COUNT IS INCLUDED -C THEN WILL DETERMINE THE NUMBER OF -C 80 BYTE INCREMENTS AND WILL DETERMINE -C THE NUMBER OF BYTES IN THE LAST INCREMENT - IERR = 0 - IF (KARY(7).NE.0) THEN - IF (KARY(7).LT.35) THEN -C PRINT *,'LESS THAN MINIMUM SIZE' - IERR = 2 - RETURN - END IF - KARY(5) = KARY(7) / 80 - KARY(6) = MOD(KARY(7),80) - IF (KARY(6).EQ.0) THEN - KARY(6) = 80 - ELSE - KARY(5) = KARY(5) + 1 - END IF - ELSE - IF (KARY(5).LT.1) THEN - IERR = 1 - RETURN - END IF - END IF -C BYTE 21-22 NR OF 80 BYTE INCREMENTS - CALL SBYTE (LOC,KARY(5),INOFST,16) - INOFST = INOFST + 16 -C BYTE 23 NR OF BYTES IN LAST INCREMENT - CALL SBYTE (LOC,KARY(6),INOFST,8) - INOFST = INOFST + 8 -C BYTES 24-28 INTEGER ZEROES - CALL SBYTE (LOC,0,INOFST,32) - INOFST = INOFST + 32 - CALL SBYTE (LOC,0,INOFST,8) - INOFST = INOFST + 8 -C BYTES 29-34 6 CHAR BULLETIN NAME TTAAII - LOC(29:34) = TTAAII(1:6) -C -C IF ON ASCII COMPUTER, CONVERT LAST 6 CHARACTERS TO EBCDIC -C - IF (.NOT.IBM370) CALL W3AI39(LOC(29:29),6) -C - INOFST = INOFST + 48 -C BYTES 35-38 KWBX -C - LOC(35:38) = KWBX(1:4) -C -C IF ON ASCII COMPUTER, CONVERT LAST 4 CHARACTERS TO EBCDIC -C - IF (.NOT.IBM370) CALL W3AI39(LOC(35:35),4) - INOFST = INOFST + 32 -C BYTES 39-40 HR/MIN TIME OF BULLETIN CREATION -C TWO BYTES AS 4 BIT BCD - KA = KARY(3) / 1000 - KB = MOD(KARY(3),1000) / 100 - KC = MOD(KARY(3),100) / 10 - KD = MOD(KARY(3),10) - CALL SBYTE (LOC,KA,INOFST,4) - INOFST = INOFST + 4 - CALL SBYTE (LOC,KB,INOFST,4) - INOFST = INOFST + 4 - CALL SBYTE (LOC,KC,INOFST,4) - INOFST = INOFST + 4 - CALL SBYTE (LOC,KD,INOFST,4) - INOFST = INOFST + 4 -C BYTES 41-45 CATALOG NUMBER ELSE (SET TO 55555) - IF (KARY(4).GE.1.AND.KARY(4).LE.99999) THEN - CALL W3AI15 (KARY(4),IHOLD,1,8,'-') - IF (LW.EQ.4) THEN - CALL SBYTE (LOC,IHOLD(1),INOFST,8) - INOFST = INOFST + 8 - CALL SBYTE (LOC,IHOLD(2),INOFST,32) - INOFST = INOFST + 32 -C -C ON CRAY 64 BIT COMPUTER -C - ELSE - CALL SBYTE (LOC,IHOLD,INOFST,40) - INOFST = INOFST + 40 - END IF -C -C IF ON ASCII COMPUTER, CONVERT LAST 5 CHARACTERS TO EBCDIC -C - IF (.NOT.IBM370) CALL W3AI39(LOC(41:41),5) - ELSE - CALL SBYTE (LOC,-168430091,INOFST,32) - INOFST = INOFST + 32 - CALL SBYTE (LOC,245,INOFST,8) - INOFST = INOFST + 8 - END IF -C BYTES 46-80 INTEGER ZEROES - DO 4676 I = 1, 8 - CALL SBYTE (LOC,0,INOFST,32) - INOFST = INOFST + 32 - 4676 CONTINUE - CALL SBYTE (LOC,0,INOFST,24) - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fm07.f b/src/fim/FIMsrc/w3/w3fm07.f deleted file mode 100644 index f5a92e0..0000000 --- a/src/fim/FIMsrc/w3/w3fm07.f +++ /dev/null @@ -1,120 +0,0 @@ - SUBROUTINE W3FM07(FIN,FOUT,CWORK,GAMMA,NCOL,NROW) -C$$$ SUBROUTINE DOCUMENTATION BLOCK *** -C -C SUBR: W3FM07 - NINE-POINT SMOOTHER FOR RECTANGULAR GRIDS -C AUTHOR: CHASE, P. ORG: W345 DATE: APR 75 -C -C ABSTRACT: SMOOTHS DATA ON A RECTANGULAR GRID USING A NINE-POINT -C SMOOTHING OPERATOR. -C -C PROGRAM HISTORY LOG: -C 75-04-01 P.CHASE -C 84-07-01 R.E.JONES CHANGE TO IBM VS FORTRAN -C 91-04-24 R.E.JONES CHANGE TO CRAY CFT77 FORTRAN -C -C USAGE: CALL W3FM07 (FIN, FOUT, CWORK, GAMMA, NCOL, NROW) -C -C INPUT: -C ' FIN' - REAL SIZE(NCOL*NROW) ARRAY OF DATA TO BE SMOOTHED -C ' CWORK' - REAL SIZE(2*NCOL*(NROW+2)) WORK ARRAY -C ' GAMMA' - COMPLEX SMOOTHING PARAMETER. THE IMAGINARY PART MUST -C BE POSITIVE. -C ' NCOL' - INTEGER NUMBER OF COLUMNS IN THE GRID -C ' NROW' - INTEGER NUMBER OF ROWS IN THE GRID -C OUTPUT: -C ' FOUT' - REAL SIZE(NCOL*NROW) ARRAY OF SMOOTHED DATA. MAY -C BE THE SAME ARRAY AS 'FIN' OR OVERLAP IT IN ANY -C FASHION. -C -C EXIT STATES: NONE -C -C EXTERNAL REFERENCES: NONE -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - REAL FIN(NCOL,NROW) - REAL FOUT(NCOL,NROW) -C - COMPLEX CWORK(NCOL,*),GAMMA,GAMMX,GAMA,GAMB,GAMC -C - GAMMX = GAMMA - XSWTCH = AIMAG(GAMMX) - NCOLM = NCOL-1 - NROWM = NROW-1 -C -C INITIALIZE WORK ARRAY. WORK ARRAY STARTS UP TWO ROWS SO IT CAN SMOOTH -C DOWNWARD WITHOUT OVERLAP OF SMOOTHED AND UNSMOOTHED DATA -C - DO 10 J = 1,NROW - DO 10 I = 1,NCOL - CWORK(I,J+2) = CMPLX(FIN(I,J),0.) - 10 CONTINUE - IF (XSWTCH .EQ. 0.) GO TO 30 - DO 20 J = 1,NROW,NROWM - JJ = J+ISIGN(1,NROWM-J) - DO 20 I = 1,NCOL,NCOLM - II = I+ISIGN(1,NCOLM-I) - CWORK(I,J+2) = CMPLX(FIN(I,JJ)+FIN(II,J)-FIN(II,JJ),0.) - 20 CONTINUE -C -C SET SMOOTHING OPERATORS -C - 30 GAMA = 0.50 * GAMMX * (1.0 - GAMMX) - GAMB = 0.25 * GAMMX * GAMMX - GAMC = 0.50 * GAMMX -C -C SMOOTH WORK ARRAY, PUTTING SMOOTHED POINTS DOWN TWO ROWS -C - CWORK(1,1) = CWORK(1,3) - CWORK(NCOL,1) = CWORK(NCOL,3) - DO 40 I = 2,NCOLM - CWORK(I,1) = CWORK(I,3)+GAMC*(CWORK(I-1,3)-2.*CWORK(I,3)+ - & CWORK(I+1,3)) - 40 CONTINUE - DO 60 J = 2,NROWM - DO 50 I = 1,NCOL,NCOLM - CWORK(I,J) = CWORK(I,J+2)+GAMC*(CWORK(I,J+1)-2.*CWORK(I,J+2)+ - & CWORK(I,J+3)) - 50 CONTINUE - DO 60 I = 2,NCOLM - CWORK(I,J) = CWORK(I,J+2)+GAMA*(CWORK(I+1,J+2)+CWORK(I-1,J+2)+ - & CWORK(I,J+1)+CWORK(I,J+3)-4.*CWORK(I,J+2))+GAMB*(CWORK(I-1,J+1)+ - & CWORK(I+1,J+1)+CWORK(I-1,J+3)+CWORK(I+1,J+3)-4.*CWORK(I,J+2)) - 60 CONTINUE - CWORK(1,NROW) = CWORK(1,NROW+2) - CWORK(NCOL,NROW) = CWORK(NCOL,NROW+2) - DO 70 I = 2,NCOLM - CWORK(I,NROW) = CWORK(I,NROW+2)+GAMC*(CWORK(I-1,NROW+2)-2.* - & CWORK(I,NROW+2)+CWORK(I+1,NROW+2)) - 70 CONTINUE -C -C IF IMAGINARY PART OF SMOOTHING PARAMETER IS NOT POSITIVE, DONE -C - IF (XSWTCH .LE. 0.) GO TO 90 -C -C OTHERWISE MOVE WORK ARRAY BACK UP TWO ROWS -C - DO 80 JJ=1,NROW - J = NROW+1-JJ - DO 80 I=1,NCOL - CWORK(I,J+2) = CWORK(I,J) - 80 CONTINUE -C -C SET SMOOTHING PARAMETER FOR CONJUGATE PASS AND GO DO IT -C - GAMMX = CONJG(GAMMX) - XSWTCH = AIMAG(GAMMX) - GO TO 30 -C -C DONE. OUTPUT SMOOTH ARRAY -C - 90 DO 100 J = 1,NROW - DO 100 I = 1,NCOL - FOUT(I,J) = REAL(CWORK(I,J)) - 100 CONTINUE - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fm08.f b/src/fim/FIMsrc/w3/w3fm08.f deleted file mode 100644 index 09e5596..0000000 --- a/src/fim/FIMsrc/w3/w3fm08.f +++ /dev/null @@ -1,64 +0,0 @@ - SUBROUTINE W3FM08 (A,Z,LI,LJ) -C$$$ SUBROUTINE DOCUMENTATION BLOCK *** -C SUBR: W3FM08 - NINE POINT SMOOTHER/DESMOOTHER -C AUTHOR: HOWCROFT, J. ORG: W342 DATE: 71-02-01 -C -C ABSTRACT: NINE POINT SMOOTHER/DESMOOTHER. SMOOTHER PASS USES AN -C EQUIVALENT LINEAR SMOOTHER WITH STENCIL (.25 .5 .25) AND THE -C DESMOOTHER USES STENCIL (-.25 1.5 -.25). TWO GRID INTERVAL WAVES -C ARE ANNIHILATED, FOUR GRID INTERVAL WAVES HAVE A .75 RESPONSE. -C -C PROGRAM HISTORY LOG: -C 71-02-01 J.HOWCROFT -C 84-07-01 R.E.JONES CHANGE TO IBM VS FORTRAN -C 94-07-27 R.E.JONES CHANGE TO CRAY CFT77 FORTRAN -C -C USAGE: CALL W3FM08 (A,Z,LI,LJ) -C -C INPUT: -C ' A' - REAL SIZE (LI,LJ) ARRAY TO HOLD FIELD TO BE SMOOTHED -C ' Z' - REAL SIZE (LI,LJ) WORK AREA -C 'LI' - INTEGER NUMBER OF COLUMNS -C 'LJ' - INTEGER NUMBER OF ROWS -C OUTPUT: -C ' A' - ARRAY HOLDING SMOOTHED FIELD -C -C EXIT STATES: NONE -C -C EXTERNAL REFERENCES: NONE -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916-128, Y-MP8/864, Y-MP EL92/256 -C -C$$$ -C - REAL A(LI,LJ) - REAL Z(LI,LJ) -C - SAVE -C - LI1 = LI - 1 - LJ1 = LJ - 1 - DO 1 J=2,LJ1 - DO 1 I=2,LI1 - CRUX = A(I-1,J-1) + A(I+1,J-1) + A(I+1,J+1) + A(I-1,J+1) - PLUS = A(I,J-1) + A(I,J+1) + A(I-1,J) + A(I+1,J) - Z(I,J) = 0.25 * A(I,J) + .125 * PLUS + .0625 * CRUX - 1 CONTINUE - DO 2 I=1,LI - Z(I,1) = A(I,1) - Z(I,LJ) = A(I,LJ) - 2 CONTINUE - DO 3 J=1,LJ - Z(1,J) = A(1,J) - Z(LI,J) = A(LI,J) - 3 CONTINUE - DO 4 J=2,LJ1 - DO 4 I=2,LI1 - CRUX = Z(I-1,J-1) + Z(I+1,J-1) + Z(I+1,J+1) + Z(I-1,J+1) - PLUS = Z(I,J-1) + Z(I,J+1) + Z(I-1,J) + Z(I+1,J) - A(I,J) = 2.25 * Z(I,J) - .375 * PLUS + .0625 * CRUX - 4 CONTINUE - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fp04.f b/src/fim/FIMsrc/w3/w3fp04.f deleted file mode 100644 index fcb972c..0000000 --- a/src/fim/FIMsrc/w3/w3fp04.f +++ /dev/null @@ -1,476 +0,0 @@ - SUBROUTINE W3FP04(IFLD,ALAT,ALON,TITLE,IDIM,CMIL,CMIR, - & CMJB,CMJT,INUM,XFAC,IERR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FP04 PRINT ARRAY OF DATA POINTS AT LAT/LON POINTS -C AUTHOR: HORODECK, J. ORG: W324 DATE: 85-07-31 -C -C ABSTRACT: GIVEN AN ARRAY OF METEOROLOGICAL DATA AND CORRESPONDING -C LATITUDE/LONGITUDE POSITION FOR EACH DATA POINT, THESE DATA -C VALUES ARE PRINTED AT THEIR APPROXIMATE LATITUDE/LONGITUDE -C POSITIONS ON A POLAR STEREOGRAPHIC PROJECTION. -C -C PROGRAM HISTORY LOG: -C 80-01-15 J. HORODECK -C 85-07-31 R.E.JONES CHANGE TO CDC FORTRAN 200 -C 90-08-15 R.E.JONES CHANGE TO CRAY CFT77 FORTRAN -C -C USAGE: CALL W3FP04(IFLD,ALAT,ALON,TITLE,IDIM,CMIL,CMIR,CMJB,CMJT, -C INUM,XFAC,IERR) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C IFLD ARG LIST REAL OR INTEGER FULLWORD ARRAY OF DATA POINTS -C ALAT ARG LIST REAL ARRAY OF LATITUDE POSITIONS (>0 FOR NH, -C <0 FOR SH) FOR THE DATA TO BE PLOTTED -C ALON ARG LIST REAL ARRAY OF LONGITUDES (WEST OF GREENWICH) -C TITLE ARG LIST INTEGER SIZE 10 ALPHANUMERIC ARRAY OF -C CHARACTERS FOR TITLE TO BE WRITTEN ON PRINTOUT -C IDIM ARG LIST INTEGER NUMBER OF DATA VALUES TO PLOT (SIZE OF -C ARRAYS IFLD, ALAT AND ALON) -C CMIL ARG LIST REAL LEFT SIDE OF GRID - MINIMUM COARSE MESH -C I COORDINATE (MINIMUM VALUE OF 1.0) -C CMIR ARG LIST REAL RIGHT SIDE OF GRID - MAXIMUM COARSE MESH -C I COORDINATE (MAXIMUM VALUE OF 65.0) -C CMJB ARG LIST REAL BOTTOM OF GRID - MINIMUM COARSE MESH -C J COORDINATE (MINIMUM VALUE OF 1.0) -C CMJT ARG LIST REAL TOP OF GRID - MAXIMUM COARSE MESH J -C COORDINATE (MAXIMUM VALUE OF 65.0) -C INUM ARG LIST INTEGER THREE DIGIT NUMBER FOR THE FOLLOWING: -C HUNDREDS DIGIT = TYPE OF DATA -C 1 = FIXED POINT -C 2 = FLOATING POINT -C 3 = ALPHANUMERIC -C TENS DIGIT = HEMISPHERIC REFERENCE -C 0 = NORTHERN HEMISPHERE -C 1 = SOUTHERN HEMISPHERE -C UNITS DIGIT = NUMBER OF CHARACTERS TO PLOT -C MINIMUM = 1 CHARACTER -C MAXIMUM = 4 CHARACTERS -C XFAC ARG LIST REAL MAP SCALE FACTOR (DESIRED MAP SCALE = XFAC -C * 1:30,000,000 (STANDARD NMC 65X65 GRID SCALE)) -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C TAPE6 PRINTED MAP WHEN EXECUTION IS SUCCESSFUL -C IERR ARG LIST INTEGER RETURN CODE -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C W3FB04 W3FB05 W3AI15 W3LIB -C -C RESTRICTIONS: BECAUSE THIS CODE COULD PRODUCE CONSIDERABLE OUTPUT -C THE SUBSET OF THE NMC 65X65 GRID WHICH CAN BE PRINTED IS A -C FUNCTION OF THE MAP SCALE FACTOR, E.G. FOR XFAC=5 THE MAXIMUM -C RANGE OF I AND J IS 27.0, FOR XFAC=2 THE RANGE IS 64.0. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - REAL ALAT(IDIM), ALON(IDIM) -C - INTEGER IFLD(IDIM), TITLE(10) - INTEGER LINE(24), IL(17), IR(17), IJU(20), IJL(20) -C - LOGICAL A -C -C - CHARACTER*1 KH(120,77), MEAN(4), KB, KM, KP, LC, - & KK(5,77,20), DATA(4), L1, L2, L3, - & IPOLE(4), KN, KS - CHARACTER*4 L24, L116 - CHARACTER*8 IFMTT - CHARACTER*24 FMT1 - CHARACTER*28 FMT2 - CHARACTER*24 FMT4 -C - EQUIVALENCE (MEAN(1),IMEAN), (DATA(1),LFLD) - EQUIVALENCE (RFIELD,IFIELD) - EQUIVALENCE (IFMTT,IFMT) -C - DATA JJAA /116/ - DATA JJBB / 77/ - DATA FMT1 /"(6X, ('+',I , X),//) "/ - DATA FMT2 /"(' +',I3,1X, A1,' +',I3) "/ - DATA FMT4 /"(//, 6X, ('+',I , X))"/ - DATA KB /' '/, KM/'-'/, KP/'+'/, LC/'X'/ - DATA L1/'1'/, L2/'2'/, L3/'3'/, L24/' 24'/, L116/' 116'/ - DATA IPOLE/'P','O','L','E'/, KN/'N'/, KS/'S'/ -C - 1001 FORMAT('1',16X,'PANEL #',I2,' OF ',I2,4X,10A8,/,/) - 1003 FORMAT(6X,116A1) - 2001 FORMAT(///,20X,'UPPER LEFT CORNER--LAT =',F6.2,' LON =',F7.2,'W' - & , 3X,'UPPER RIGHT CORNER--LAT =',F6.2,' LON =',F7.2,'W') - 2002 FORMAT(20X,'LOWER LEFT CORNER--LAT =',F6.2,' LON =',F7.2,'W' - & , 3X,'LOWER RIGHT CORNER--LAT =',F6.2,' LON =',F7.2,'W') - 2003 FORMAT(/,/, 16X, 'PANEL #', I2, ' OF ', I2, 4X, 10A8) - 9001 FORMAT(/,5X,'CMIL = ',F8.1,' CMIR = ',F8.1,' HIGH AND LOW' - & ,' VALUES REVERSED......RETURN......') - 9002 FORMAT(/,5X,'CMJB = ',F8.1,' CMJT = ',F8.1,' HIGH AND LOW' - & ,' VALUES REVERSED......RETURN......') - 9003 FORMAT(/,5X,F8.1,' IS ILLEGAL VALUE FOR LOW I. IT IS NOW 1.0') - 9004 FORMAT(/,5X,F8.1,' IS ILLEGAL VALUE FOR HIGH I. IT IS NOW 65.0') - 9005 FORMAT(/,5X,F8.1,' IS ILLEGAL VALUE FOR LOW J. IT IS NOW 1.0') - 9006 FORMAT(/,5X,F8.1,' IS ILLEGAL VALUE FOR HIGH J. IT IS NOW 65.0') - 9007 FORMAT(/,5X,'REQUESTED NUMBER OF CHARACTERS TO PLOT(',I2,' )IS' - & ,' NOT ALLOWED. FOUR(4) IS MAXIMUM. THATS ALL YOU GET') - 9008 FORMAT(/,5X,'REQUESTED SUBSET OF 65X65 GRID CANNOT CURRENTLY ' - & ,'BE PLOTTED WITH MAP SCALE FACTOR',F5.1,/5X,'IF PLOT ' - & ,'IS NECESSARY, CONTACT JOHN M. HORODECK,ESQ. NMC/DD' - & ,'/SEB FOR ASSISTANCE') - 9009 FORMAT(/,5X,I4,' IS INVALID HEMISPHERIC REFERENCE' - & , '......RETURN......') - 9010 FORMAT(/,5X,'HUNDREDS DIGIT OF INUM(INUM =',I4,') IS' - & , ' INVALID......RETURN......') -C -C TEST I,J VALUES FOR RANGE AND ORDER -C - IF (CMIR.GT.CMIL) GO TO 1 - IERR = 1 - PRINT 9001, CMIL, CMIR - RETURN - 1 CONTINUE - IF (CMJT.GT.CMJB) GO TO 2 - IERR = 1 - PRINT 9002, CMJB, CMJT - RETURN - 2 CONTINUE - IF (CMIL.GE.1.0) GO TO 3 - PRINT 9003, CMIL - CMIL = 1.0 - 3 CONTINUE - IF (CMIR.LE.65.0) GO TO 4 - PRINT 9004, CMIR - CMIR = 65.0 - 4 CONTINUE - IF (CMJB.GE.1.0) GO TO 5 - PRINT 9005, CMJB - CMJB = 1.0 - 5 CONTINUE - IF (CMJT.LE.65.0) GO TO 6 - PRINT 9006, CMJT - CMJT = 65.0 - 6 CONTINUE -C -C CALCULATE VARIOUS LIMITS -C - LNUM = MOD(INUM,10) - NREF = (MOD(INUM,100))/10 -C -C TEST FOR INCORRECT ARGUMENTS PASSED -C - IF (LNUM.LE.4) GO TO 7 - PRINT 9007, LNUM - LNUM = 4 - 7 CONTINUE - IF (NREF.LE.1) GO TO 8 - IERR = 1 - PRINT 9009, NREF - RETURN - 8 CONTINUE - IF ((INUM/100).LE.3) GO TO 81 - IERR = 1 - PRINT 9010, INUM - RETURN - 81 CONTINUE -C - LNUMP1 = LNUM + 1 - I1 = (CMIL-1.0)*XFAC + 1.0 - I2 = (CMIR-1.0)*XFAC + 1.0 - J1 = (CMJB-1.0)*XFAC + 1.0 - J2 = (CMJT-1.0)*XFAC + 1.0 -C -C WILL THIS PLOT BE TOO LARGE? -C - IF (((I2-I1).LT.139).AND.((J2-J1).LT.139)) GO TO 9 - IERR = 1 - PRINT 9008, XFAC - RETURN - 9 CONTINUE -C - OFFI = I1 - 1 - OFFJ = J1 - 1 - JJA = (I2-I1)*5 + 1 - JJB = (J2-J1)*4 + 1 - JJAM1 = JJA - 1 - JJBBM1 = JJBB - 1 - JJAAM1 = JJAA - 1 - JJAAPN = JJAA + LNUM - IBEGIN = LNUMP1 + 1 - IPAGE = (JJAM1/JJAA) + 1 - JPAGE = (JJB/JJBB) + 1 - XMESH = 381.0/XFAC - XIP = 32.0*XFAC + 1.0 - XJP = 32.0*XFAC + 1.0 - IIXIP = (XIP-OFFI)*5 - 4 - JJXJP = (XJP-OFFJ)*4 - 3 -C -C PLOT DATA ONE PANEL AT A TIME IN SECTIONS -C - DO 150 NX=1,IPAGE - A = .FALSE. -C -C SET LIMITS OF I TO BE PRINTED -C - IL(NX) = I1 + (23*(NX-1)) - IF (NX.NE.IPAGE) IR(NX) = I1 + (23*NX) - IF (NX.EQ.IPAGE) IR(NX) = I2 - IMAX = IR(NX) - OFFI - IMIN = IL(NX) - OFFI - M = 0 -C -C FILL ARRAY WITH VALUES OF I TO BE PRINTED AT TOP OF PAGE -C - DO 10 I = IMIN,IMAX - M = M + 1 - LINE(M) = I - 10 CONTINUE -C -C CALCULATE WIDTH OF PANEL IN INTEGERS AND -C CHARACTERS FROM WHICH DETERMINE FORMAT -C FIELD COUNT AND CONVERT BINARY TO ASCII -C -C PRINT TOP LINE OF I -C - LA = (IMAX-IMIN) + 1 - MMM = (LA*5) - 4 - IF (LA.EQ.24) GO TO 13 - CALL W3AI15(LA,IFMT,1,4,KP) - FMT1(5:8) = IFMTT(1:4) - FMT4(9:12) = IFMTT(1:4) - CALL W3AI15(MMM,IFMT,1,4,KP) - FMT2(13:16) = IFMTT(1:4) - GO TO 16 - 13 CONTINUE - FMT1(5:8) = L24 - FMT2(13:16) = L116 - FMT4(9:12) = L24 - 16 CONTINUE - IF (LA.LT.100) GO TO 19 - FMT1(15:15) = L3 - FMT1(17:17) = L1 - FMT4(19:19) = L3 - FMT4(21:21) = L1 - GO TO 22 - 19 CONTINUE - FMT1(15:15) = L2 - FMT1(17:17) = L2 - FMT4(19:19) = L2 - FMT4(21:21) = L2 - 22 CONTINUE - PRINT 1001, NX, IPAGE, TITLE - WRITE(6,FMT1) (LINE(N), N=1,LA) -C -C PREPARE TO PRINT SECTIONS OF EACH PANEL -C - DO 140 JNX=1,JPAGE -C -C SET LIMITS OF J TO BE PRINTED -C - IJU(JNX) = J2 - (19*(JNX-1)) - IF (JNX.NE.JPAGE) IJL(JNX) = J2 - (19*JNX) - IF (JNX.EQ.JPAGE) IJL(JNX) = J1 - JMAX = IJU(JNX) - OFFJ - JMIN = IJL(JNX) - OFFJ - JU = JJB - (4*JMAX-3) - JL = JJB - (4*JMIN-3) - NNN = (JMAX-JMIN)*4 + 1 -C -C FILL CHARACTER ARRAY WITH BLANKS AND PUT X MARKERS IN CORNERS -C IF FIRST PANEL BLANK ENTIRE AREA, -C OTHERWISE TRANSFER FIRST INUM I BYTES TO LARGE ARRAY -C AND BLANK REMAINING ARRAY -C - DO 37 J=1,JJBB - IF (NX.NE.1) GO TO 31 - DO 28 I=1,JJAAPN - KH(I,J) = KB - 28 CONTINUE - GO TO 37 - 31 CONTINUE - DO 32 I=1,LNUMP1 - KH(I,J) = KK(I,J,JNX) - 32 CONTINUE - DO 34 I=IBEGIN,JJAAPN - KH(I,J) = KB - 34 CONTINUE - 37 CONTINUE - IF (JNX.NE.1) GO TO 40 - KH(1,JJBB) = LC - KH(MMM,JJBB) = LC - 200 CONTINUE - 40 CONTINUE - IF (JNX.NE.JPAGE) GO TO 50 - KH(1,1) = LC - KH(MMM,1) = LC - 50 CONTINUE -C -C LOOP TO PUT DATA IN CHARACTER ARRAY -C - DO 110 I=1,IDIM -C -C TEST FOR BAD GEOGRAPHY -C - IF ((ABS(ALAT(I)).GT.90.).OR.(ALON(I).LT.0.0).OR.(ALON - A (I).GT.360.0)) GO TO 90 -C -C CHANGE LAT,LON TO I,J -C - IF (NREF.EQ.0) GO TO 51 - CALL W3FB04(ALAT(I),ALON(I),-XMESH,260.0,DELI,DELJ) - GO TO 52 - 51 CONTINUE - CALL W3FB04(ALAT(I),ALON(I),XMESH,80.0,DELI,DELJ) - 52 CONTINUE - XI = XIP + DELI - XJ = XJP + DELJ -C -C POSITION I,J COORDINATES IN CHARACTER ARRAY AND TEST -C IF VALUES RETURNED ARE WITHIN LIMITS OF MAP AND WITHIN SECTIONS -C - II = 1.0 + (XI-OFFI-0.9001)*5.0 - JJ = 1.0 + (XJ-OFFJ-0.8751)*4.0 - IW = (JJAAM1*(NX-1)) + 1 - IX = (JJAAM1*NX) + 1 - IY = JJB - (JJBBM1*(JNX-1)) - IF (JNX.NE.JPAGE) IZ = JJB - (JJBBM1*JNX) - IF (JNX.EQ.JPAGE) IZ = 1 - IF ((II.LT.1).OR.(II.GT.JJA)) GO TO 100 - IF ((JJ.LT.1).OR.(JJ.GT.JJB)) GO TO 100 - IF ((II.LT.IW).OR.(II.GT.IX)) GO TO 100 - IF ((JJ.GT.IY).OR.(JJ.LT.IZ)) GO TO 100 -C -C WRITE N+POLE IF IN THIS SECTION -C - IF (.NOT.((IIXIP.GE.IW.AND.IIXIP.LE.IX).AND. - A (JJXJP.LE.IY.AND.JJXJP.GE.IZ))) GO TO 56 - IIXXP = IIXIP - (JJAAM1*(NX-1)) - JJXXP = JJXJP - (IZ-1) - IF (NREF.EQ.0) KH(IIXXP-1,JJXXP) = KN - IF (NREF.EQ.1) KH(IIXXP-1,JJXXP) = KS - KH(IIXXP,JJXXP) = KP - DO 53 L=1,4 - KH(IIXXP+L,JJXXP) = IPOLE(L) - 53 CONTINUE - 56 CONTINUE -C -C CONVERT CHARACTER ARRAY COORDINATES FROM -C TOTAL MAP VALUES TO SECTION VALUES -C - II = II - (JJAAM1*(NX-1)) - IF (JNX.NE.JPAGE) JJ = JJ - (IZ-1) -C -C IF SPACE IS OCCUPIED SKIP THIS STATION -C - JNUM = LNUM + 1 - DO 70 IK=1,JNUM - IN = IK - 1 - IF (KH(II+IN,JJ).EQ.KB) GO TO 60 - GO TO 110 - 60 CONTINUE - 70 CONTINUE -C -C PLACE VALUE TO BE PLOTTED IN CHARACTER ARRAY -C - IFIELD = IFLD(I) -C -C TEST FOR TYPE OF DATA -C - IF ((INUM/100).EQ.3) GO TO 82 - IF ((INUM/100).EQ.1) GO TO 73 - JFLD = RFIELD - GO TO 76 - 73 CONTINUE - JFLD = IFIELD - 76 CONTINUE -C -C IF ORIGINALLY FIXED POINT OR HAS BEEN CONVERTED -C FROM FLOATING POINT TO FIXED POINT -C - IF ((JFLD/10000).GE.1) JFLD = MOD(JFLD,10000) - IIABS = IABS(JFLD) - CALL W3AI15(IIABS,IMEAN,1,LNUM,KP) - IF (JFLD.LT.0) KH(II,JJ) = KM - IF (JFLD.GE.0) KH(II,JJ) = KP - DO 79 IA=1,LNUM - KH(II+IA,JJ) = MEAN(IA) - 79 CONTINUE - GO TO 110 - 82 CONTINUE -C -C FOR ALPHANUMERIC DATA -C - LFLD = IFLD(I) - KH(II,JJ) = KP - DO 85 IQ=1,LNUM - KH(II+IQ,JJ) = DATA(IQ) - 85 CONTINUE - 90 CONTINUE - 100 CONTINUE - 110 CONTINUE - JJN = 0 -C -C PRINT JTH ROW AND VALUES OF J -C - DO 130 J=JU,JL,4 - JN = NNN - (4*JJN) - IF (A) GO TO 115 - JX = (JJB-J)/4 + 1 - WRITE(6,FMT2) JX, (KH(I,JN), I=1,MMM), JX - 115 CONTINUE - JJN = JJN + 1 - IF (JN.NE.1) GO TO 118 -C -C SAVE LAST INUM BYTES OF I -C - DO 117 L=1,JJBB - DO 116 I=116,JJAAPN - IA = I - 115 - KK(IA,L,JNX) = KH(I,L) - 116 CONTINUE - 117 CONTINUE - A = .TRUE. - GO TO 140 - 118 CONTINUE - DO 120 IM=1,3 - JN = JN - 1 - PRINT 1003, (KH(I,JN), I=1,MMM) - 120 CONTINUE - A = .FALSE. - 130 CONTINUE - 140 CONTINUE - WRITE(6,FMT4) (LINE(N), N=1,LA) -C -C CALCULATE AND PRINT LAT/LON AT CORNERS -C - AL = IL(NX) - AR = IR(NX) - XI1 = ((AL-1.0)/XFAC + 1.0) - 33.0 - XI2 = ((AR-1.0)/XFAC + 1.0) - 33.0 - XJ1 = CMJB - 33.0 - XJ2 = CMJT - 33.0 - IF (NREF.EQ.0) GO TO 142 - CALL W3FB05(XI1,XJ1,-XMESH,260.0,ALAT1,ALON1) - CALL W3FB05(XI1,XJ2,-XMESH,260.0,ALAT2,ALON2) - CALL W3FB05(XI2,XJ2,-XMESH,260.0,ALAT3,ALON3) - CALL W3FB05(XI2,XJ1,-XMESH,260.0,ALAT4,ALON4) - GO TO 144 - 142 CONTINUE - CALL W3FB05(XI1,XJ1,XMESH,80.0,ALAT1,ALON1) - CALL W3FB05(XI1,XJ2,XMESH,80.0,ALAT2,ALON2) - CALL W3FB05(XI2,XJ2,XMESH,80.0,ALAT3,ALON3) - CALL W3FB05(XI2,XJ1,XMESH,80.0,ALAT4,ALON4) - 144 CONTINUE - PRINT 2001, ALAT2, ALON2, ALAT3, ALON3 - PRINT 2002, ALAT1, ALON1, ALAT4, ALON4 - PRINT 2003, NX, IPAGE, TITLE - 150 CONTINUE - IERR = 0 - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fp05.f b/src/fim/FIMsrc/w3/w3fp05.f deleted file mode 100644 index e9ac63b..0000000 --- a/src/fim/FIMsrc/w3/w3fp05.f +++ /dev/null @@ -1,614 +0,0 @@ - SUBROUTINE W3FP05(RDATA,KTBL,CNST,TITLE,KRECT,KCONTR,LINEV,IWIDTH) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FP05 PRINTER CONTOUR SUBROUTINE -C AUTHOR: R.E.JONES ORG: W342 DATE: 85-07-31 -C -C ABSTRACT: PRINTS A TWO-DIMENSIONAL GRID OF ANY SHAPE, WITH -C CONTOURING, IF DESIRED. GRID VALUES ARE SCALED ACCORDING TO -C TO CONSTANTS SPECIFIED BY THE PROGRAMER, ROUNDED, AND PRINTED -C AS 4,3, OR 2 DIGIT INTEGERS WITH SIGN, THE SIGN MARKING THE -C GRID POSITION OF THE PRINTED NUMBER. IF CONTOURING IS REQUESTED, -C BESSEL'S INTERPOLATION FORMULA IS USED TO OPTAIN THE CONTOUR LINES. -C CONTOURS ARE INDICATED BY ALPHABETIC CHARACTERS RANGING FROM A TO -C H OR NUMERIC CHARACTERS FROM 0 TO 9. CONTOUR ORIGIN AND INTERVAL -C ARE SPECIFIED BY THE PROGRAMMER IN TERMS OF PRINTED VALUES. -C -C PROGRAM HISTORY LOG: -C 89-10-13 R.E.JONES -C 92-05-02 R.E.JONES ADD SAVE -C -C USAGE: CALL W3FP05 (RDATA,KTBL,CNST,TITLE,KRECT,KCONTR,LINEV,IWIDTH) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C RDATA ARG LIST REAL ARRAY OF GRID DATA TO BE PRINTED. -C KTBL ARG LIST INTEGER ARRAY WITH SHAPE OF ARRAY. -C CNST ARG LIST REAL ARRAY OF FOUR ELEMENTS, USED IN -C SCALING FOR PRINTING AND CONTOURING. -C TITLE ARG LIST IS A ARRAY OF 132 CHARACTERS OR LESS OF -C HOLLERITH DATA, 1ST CHAR. MUST BE BLANK. -C PRINTED AT BOTTOM OF THE MAP. -C KRECT ARG LIST 1 IF GRID IS RECTANGULAR, 0 OTHERWISE. -C KCONTR ARG LIST 1 FOR CONTOURING , 0 OTHERWISE. -C LINEV ARG LIST 0 IS FOR 6 LINES PER VERTICAL INCH, -C NON-ZERO 8 LINES PER VERTICAL INCH. -C IWIDTH ARG LIST NUMBER OF CHARACTERS IN PRINT LINE, -C 132 IS STANDARD PRINTER. -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C TAPE6 MAPS ON STANDARD FORTRAN PRINT FILE -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C ABS IABS MIN0 MOD SYSTEM -C -C REMARKS: NORMAL SUBROUTINE RETURN, UNLESS NUMBER OF ROWS -C IS GREATER THAN 200, PRINTS ERROR MESSAGE AND EXITS. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CTF77 FORTRAN -C MACHINE: CRAY Y-MP/832 -C -C$$$ -C - REAL CNST(4) - REAL RDATA(1) - REAL RWA(28) - REAL RWB(28) - REAL RWC(28) - REAL RWD(28) - REAL VDJA(29) - REAL VDJB(28) - REAL VDJC(28) -C - INTEGER KALFA(16) - INTEGER KALPH(20) - INTEGER KHTBL(10) - INTEGER KLINE(126) - INTEGER KLINES(132) - INTEGER KNUMB(20) - INTEGER KRLOC(200) - INTEGER KTBL(407) - INTEGER OUTPUT - INTEGER PAGNL - INTEGER PAGNR - INTEGER PAGN3 - INTEGER PCCNT - INTEGER PCFST - INTEGER PGCNT - INTEGER PGCNTA - INTEGER PGFST - INTEGER PGFSTA - INTEGER PGMAX -C - LOGICAL DONE - LOGICAL LCNTR - LOGICAL RECT -C - CHARACTER*1 TITLE(*) -C - EQUIVALENCE (CRMX,VDJA(29)) - EQUIVALENCE (KLINE(1),KLINES(8)) - EQUIVALENCE (VDJC(1),RWA(1)) -C -C ... THE VAULUE CRMX IS MACHINE DEPENDENT, IT SHOULD BE -C ... SET TO A VALUE A LITTLE LESS THAN THE LARGEST POSITIVE -C ... FLOATING POINT NUMBER FOR THE COMPUTER. -C - SAVE -C -C DATA CRMX /10.E70/ JFM commented out and set to HUGE below - DATA KALFA/ - A 1HA,1H ,1HB,1H ,1HC,1H ,1HD,1H ,1HE,1H ,1HF, - B 1H ,1HG,1H ,1HH,1H / - DATA KHASTR/1H*/ - DATA KHBLNK/1H / - DATA KHDOLR/1H$/ - DATA KHMNS /1H-/ - DATA KHPLUS/1H+/ - DATA KHRSTR/1H1/ - DATA KHTBL /1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/ -C -C ... LIMNRW IS LIMIT ON NUMBER OF ROWS ALLOWED -C ... AND IS DIMENSION OF KRLOC ... -C - DATA LIMNRW/200/ - DATA KNUMB /1H0,1H ,1H1,1H ,1H2,1H ,1H3,1H ,1H4,1H , - 1 1H5,1H ,1H6,1H ,1H7,1H ,1H8,1H ,1H9,1H / - DATA OUTPUT/6/ - DATA R5 /.2/ - DATA R50 /.02/ -C - 8000 FORMAT (1H0,10X,44HERROR FROM W3FP05 ... NUMBER OF ROWS IN YOUR, - 1 9H ARRAY = ,I4,24H WHICH EXCEEDS LIMIT OF ,I4) - 8100 FORMAT (1HT) - 8200 FORMAT (1HS) - 8300 FORMAT (1H /1H /1H ) - 8400 FORMAT (1H /1H ) - 8500 FORMAT (132A1) - 8600 FORMAT (132A1) -C -C COMPUTE VALUES FOR PRINTER WIDTH -C - CRMX = huge(CRMX) !JFM - IF (IWIDTH.GE.132.OR.IWIDTH.LE.0) PGMAX = 25 - IF (IWIDTH.GE.1.AND.IWIDTH.LE.22) PGMAX = 3 - IF (IWIDTH.GT.22.AND.IWIDTH.LT.132) PGMAX = (IWIDTH-7)/5 - PAGN3 = PGMAX + 3 - LW = PGMAX * 5 + 7 - VDJA(PAGN3 + 1) = CRMX - MXPG = PGMAX * 5 + 7 -C - IF (LINEV .EQ. 0) GO TO 100 -C ...OTHERWISE LINEV IS NON-ZERO, SO 8 LINES/INCH IS DESIRED... - LINATE = 1 - R4 = 0.250 - R32 = 0.03125 - CON2 = 10.0 - NBTWN = 3 - GO TO 200 -C - 100 CONTINUE - LINATE = 2 - R4 = 0.33333333 - R32 = 1.0/18.0 - CON2 = 6.0 - NBTWN = 2 -C - 200 CONTINUE - PGCNTA = 0 - PGFSTA = 0 - RECT = .FALSE. - DONE = .FALSE. - KZ = 0 - KZA = 1000 - A = CNST(1) - KCA = 2*(1-KRECT) -C TO SET NO. OF DIGITS TO BE PRINTED -C WHICH IS A FUNCTION OF THE TENS POSITION IN KCONTR - NODIG = IABS(KCONTR/10) - NODIG = 3 - NODIG -C WHERE C(NODIG) + 1 IS NO. OF DIGITS TO BE PRINTED - IF (NODIG.LT.1 .OR. NODIG.GT.3) NODIG = 3 -C ANY OUT-OF-RANGE WILL GET 4 DIGITS - LCNTR = .FALSE. - NCONQ = IABS(MOD(KCONTR,10)) - IF (NCONQ .EQ. 0) GO TO 400 - IF (NCONQ .LE. 2) GO TO 300 -C OTHERWISE RESET NCONQ - NCONQ = 0 - GO TO 400 - 300 CONTINUE - LCNTR = .TRUE. -C WITH NCONQ=1 FOR LETTERS,AND =2 FOR NUMBERS IN CONTOUR BANDS - 400 CONTINUE - IF (NCONQ .EQ. 2) GO TO 600 -C OTHERWISE SET AS LETTERS -C - KCOW = 16 - DO 500 J = 1,KCOW - KALPH(J) = KALFA(J) - 500 CONTINUE - GO TO 800 -C - 600 CONTINUE - KCOW = 20 - DO 700 J = 1,KCOW - KALPH(J) = KNUMB(J) - 700 CONTINUE -C -800 CONTINUE - RADJ = 4 * KCOW - KD=1 -C *** SET UP TABLE OF INDICES CORRESPONDING TO FIRST ITEM IN EACH ROW -C *** THIS IS KRLOC -C *** PICK OUT SIZE AND ROW NUMBER OF LARGEST ROW (KCMX AND KCLMX) -C *** KZA LEFT-JUSTIFIES MAP IF ALL ROWS HAVE COMMON MINIMAL OFFSET - IF (KTBL(1 ).EQ.(-1)) GO TO 1100 -C *** ONE-DIMENSIONAL FORM - KTF=3 - KZA=0 - IMIN = KTBL(2) - JMAX = KTBL(3)+KTBL(1)-1 - NRWS = KTBL(1) - IF (NRWS .GT. LIMNRW) GO TO 1200 - KC = KCA * (NRWS-1) + 1 -C - DO 1000 J = 1,NRWS - K = NRWS-J+1 - KRLOC(K) = KD - IF (KTBL(KC+4)+KTBL(KC+3).LE.KZ ) GO TO 900 - KCLMX = K - IMAX = KTBL(KC+4)+KTBL(KC+3) - KZ = IMAX - KCMX = KRLOC(K)+KTBL(KC+4) - 900 CONTINUE - KD = KD+KTBL(KC+4) - KC = KC-KCA - 1000 CONTINUE - GO TO 1600 -C *** TWO-DIMENSIONAL FORM -C *** THE TWO-DIMENSIONAL FORM IS COMPILER-DEPENDENT -C *** IT DEPENDS ON THE TWO-DIMENSIONAL ARRAY BEING STORED COLUMN-WISE -C *** THAT IS, WITH THE FIRST INDEX VARYING THE FASTEST - 1100 CONTINUE - IMIN = KTBL(6) - JMIN = KTBL(7) - NRWS = KTBL(5) - IF (NRWS .LE. LIMNRW) GO TO 1300 -C ... ELSE, NRWS EXCEEDS LIMIT ALLOWED ... - 1200 CONTINUE - WRITE (OUTPUT,8000) NRWS,LIMNRW - GO TO 7400 -C - 1300 CONTINUE - JMAX = KTBL(7) +KTBL(5)-1 - KC = 1 - DO 1500 J = 1,NRWS - KRLOC(J) = KTBL(2)*(KTBL(4)-J)+KTBL(KC+7)+1 - IF (KTBL(KC+7)+KTBL(KC+8).LE.KZ) GO TO 1400 - IMAX = KTBL(KC+7)+KTBL(KC+8) - KZ = IMAX - KCMX = KRLOC(J)+KTBL(KC+8) - KCLMX = J - 1400 CONTINUE - IF (KTBL(KC+7).LT.KZA) KZA = KTBL(KC+7) - KC = KC + KCA - 1500 CONTINUE - IMAX = IMAX-KZA - KTF = 7 - 1600 CONTINUE - PAGNL = 0 - PAGNR = PGMAX - IF (.NOT.LCNTR) GO TO 1700 - ADC = (CNST(1)-CNST(4))/CNST(3)+RADJ - BC = CNST(2)/CNST(3) -C *** PRINT I-LABELS ACROSS TOP OF MAP - 1700 CONTINUE -C *** WHICH PREPARES CDC512 PRINTER FOR 8 LINES PER INCH - IF (LINATE.EQ.1) WRITE (OUTPUT,8100) -C ...WHICH PREPARES PRINTER FOR 6 LINES PER INCH - IF (LINATE.EQ.2) WRITE (OUTPUT,8200) - KLINES(1) = KHRSTR - ASSIGN 1800 TO KBR - GO TO 6900 -C - 1800 CONTINUE - IF (.NOT.LCNTR) GO TO 2000 -C *** INITIALIZE CONTOUR WORKING AREA - DO 1900 J=1,PAGN3 - RWC(J)=CRMX - RWD(J)=CRMX - 1900 CONTINUE -C *** SET UP CONTOUR DATA AND PAGE LIMITERS FOR FIRST TWO ROWS -C - 2000 CONTINUE - KRA = 1 - KC = KTF+1 - ASSIGN 2100 TO KBR - GO TO 5900 -C - 2100 CONTINUE - KRA = 2 - KC = KC+KCA - ASSIGN 2200 TO KBR - GO TO 5900 -C - 2200 CONTINUE - KR = 0 -C *** TEST IF THIS IS LAST PAGE - IF (IMAX.GT.PGMAX-1) GO TO 2300 - LMR = IMAX*5 + 2 - DONE = .TRUE. -C *** DO LEFT J-LABELS - 2300 CONTINUE - JCURR = JMAX -C - 2400 CONTINUE - KR = KR + 1 - KRA = KR+2 - KC = KC+KCA - KTA = MOD(JCURR,10) - KTB = MOD(JCURR,100)/10 - KTC = MOD(JCURR,1000)/100 - IF (KR .EQ. 1 .OR. (.NOT. LCNTR)) GO TO 2500 - GO TO 2600 - 2500 CONTINUE - IF (LINATE.EQ.1) WRITE (OUTPUT,8300) - IF (LINATE.EQ.2) WRITE (OUTPUT,8400) - 2600 CONTINUE - KLINES(2) = KHPLUS - KLINES(1) = KHBLNK - IF (JCURR.LT.0) KLINES(2)=KHMNS - KTA=IABS(KTA) - KTB=IABS(KTB) - KTC = IABS(KTC) - IF (KTC .EQ. 0) GO TO 2700 - KLINES(3) = KHTBL(KTC+1) - KLINES(4) = KHTBL(KTB+1) - KLINES(5) = KHTBL(KTA+1) - GO TO 2800 -C - 2700 CONTINUE - KLINES(3) = KHTBL(KTB+1) - KLINES(4) = KHTBL(KTA+1) - KLINES(5) = KHBLNK -C - 2800 CONTINUE - DO 2900 J = 6,MXPG - KLINES(J) = KHBLNK - 2900 CONTINUE - IF (.NOT.DONE) GO TO 3000 -C *** DO RIGHT J-LABELS IF LAST PAGE OF MAP - KLINE(LMR) = KLINES(2) - KLINE(LMR+1) = KLINES(3) - KLINE(LMR+2) = KLINES(4) - KLINE(LMR+3) = KLINES(5) -C *** FETCH AND CONVERT GRID VALUES TO A1 FORMAT FOR WHOLE LINE - 3000 CONTINUE - KRX = KRLOC(KR) - KLX = 5*PGFST+1 - IF (PGCNT.EQ.0) GO TO 4000 - DO 3800 KK = 1,PGCNT - TEMP = RDATA(KRX)*CNST(2)+A - KTEMP = ABS(TEMP)+.5 - KLINE(KLX) = KHPLUS - IF (TEMP.LT.0.0) KLINE(KLX) = KHMNS - GO TO (3300,3200,3100),NODIG - 3100 CONTINUE - KTA = MOD(KTEMP,10000)/1000 -C - 3200 CONTINUE - KTB = MOD(KTEMP,1000)/100 -C - 3300 CONTINUE - KTC = MOD(KTEMP,100)/10 - KTD = MOD(KTEMP,10) - GO TO (3400,3500,3600),NODIG - 3400 CONTINUE - KLINE(KLX+1) = KHTBL(KTC+1) - KLINE(KLX+2) = KHTBL(KTD+1) - GO TO 3700 - 3500 CONTINUE - KLINE(KLX+1) = KHTBL(KTB+1) - KLINE(KLX+2) = KHTBL(KTC+1) - KLINE(KLX+3) = KHTBL(KTD+1) - GO TO 3700 - 3600 CONTINUE - KLINE(KLX+1) = KHTBL(KTA+1) - KLINE(KLX+2) = KHTBL(KTB+1) - KLINE(KLX+3) = KHTBL(KTC+1) - KLINE(KLX+4) = KHTBL(KTD+1) - 3700 CONTINUE - KLX = KLX + 5 - KRX = KRX+1 - 3800 CONTINUE -C *** FOLLOWING CHECKS FOR POLE POINT AND INSERTS PROPER CHARACTER. - IF (JCURR.NE.0) GO TO 4000 - IF (IMIN.LT.(-25).OR.IMIN.GT.0) GO TO 4000 - KX = -IMIN - IF (KX.LT.PGFST.AND.KX.GT.PGCNT+PGFST) GO TO 4000 - KX = 5*KX - IF (KLINE(KX+1).EQ.KHMNS) GO TO 3900 - KLINE(KX) = KHDOLR - GO TO 4000 - 3900 CONTINUE - KLINE(KX+1) = KHASTR -C *** PRINT LINE OF MAP DATA - 4000 CONTINUE - WRITE (OUTPUT,8500) (KLINES(II),II=1,MXPG) - KRLOC(KR) = KRX - JCURR = JCURR - 1 -C *** TEST BOTTOM OF MAP - IF (KR.EQ.NRWS) GO TO 5700 -C *** SET UP CONTOUR DATA AND PAGE LIMITERS FOR NEXT ROW - ASSIGN 4100 TO KBR - GO TO 5900 -C - 4100 CONTINUE - IF (.NOT.LCNTR) GO TO 2400 -C *** DO CONTOURING - DO 4200 JJ=1,MXPG - KLINES(JJ)=KHBLNK - 4200 CONTINUE -C *** VERTICAL INTERPOLATIONS - DO 4700 KK = 1,PAGN3 - IF (RWB(KK).LT.CRMX.AND.RWC(KK).LT.CRMX) GO TO 4300 - VDJB(KK) = CRMX - VDJC(KK) = CRMX - GO TO 4600 - 4300 CONTINUE - IF (RWA(KK).LT.CRMX.AND.RWD(KK).LT.CRMX) GO TO 4400 - VDJC(KK) = 0. - GO TO 4500 - 4400 CONTINUE - VDJC(KK) = R32*(RWA(KK)+RWD(KK)-RWB(KK)-RWC(KK)) - 4500 CONTINUE - VDJB(KK) = R4*(RWC(KK)-RWB(KK)-CON2*VDJC(KK)) - 4600 CONTINUE - VDJA(KK)=RWB(KK) - 4700 CONTINUE -C ...DO 2 OR 3 ROWS OF CONTOURING BETWEEN GRID ROWS... - DO 5600 LL = 1,NBTWN - DO 4800 KK = 1,PAGN3 - VDJB(KK) = VDJC(KK) + VDJB(KK) - VDJA(KK) = VDJB(KK) + VDJA(KK) - 4800 CONTINUE -C ...WHERE VDJA HAS THE INTERPOLATED VALUE FOR THIS INTER-ROW -C *** HORIZONTAL INTERPOLATIONS - HDC = 0.0 - IF (VDJA(1).GE.CRMX) GO TO 4900 - HDC = R50*(VDJA(4)+VDJA(1)-VDJA(2)-VDJA(3)) - 4900 CONTINUE - KXB = 0 - DO 5200 KK = 1,PGMAX - IF (VDJA(KK+1).GE.CRMX) GO TO 5100 - HDA = VDJA(KK+1) - IF (VDJA(KK+2).GE.CRMX) GO TO 5500 - IF (VDJA(KK+3).GE.CRMX) HDC = 0. - HDB = R5*(VDJA(KK+2)-VDJA(KK+1)-15.*HDC) -C *** COMPUTE AND STORE CONTOUR CHARACTERS, 5 PER POINT - KHDA=HDA - KDB = IABS(MOD(KHDA,KCOW)) - KLINE(KXB+1) = KALPH(KDB+1) - DO 5000 JJ=2,5 - HDB = HDB+HDC - HDA = HDA+HDB - KHDA = HDA - KDB = IABS(MOD(KHDA,KCOW)) - KXA = KXB+JJ - KLINE(KXA) = KALPH(KDB+1) - 5000 CONTINUE - HDC = R50*(VDJA(KK+4)+VDJA(KK+1)-VDJA(KK+2)-VDJA(KK+3)) - IF (VDJA(KK+4).GE.CRMX) HDC = 0. - 5100 CONTINUE - KXB = KXB+5 - 5200 CONTINUE - 5300 CONTINUE - WRITE (OUTPUT,8500) (KLINES(II),II=1,MXPG) - DO 5400 KK = 1,MXPG - KLINES(KK) = KHBLNK - 5400 CONTINUE - GO TO 5600 -C - 5500 CONTINUE - KHDA = HDA - KDB = IABS(MOD(KHDA,KCOW)) - KLINE(KXB+1) = KALPH(KDB+1) - GO TO 5300 - 5600 CONTINUE - GO TO 2400 -C - 5700 CONTINUE - IF (LINATE.EQ.1) WRITE (OUTPUT,8300) - IF (LINATE.EQ.2) WRITE (OUTPUT,8400) - KLINES(1) = KHBLNK -C *** PRINT I-LABELS ACROSS BOTTOM OF PAGE - ASSIGN 5800 TO KBR - GO TO 6900 -C - 5800 CONTINUE - IF (LINATE.EQ.1) WRITE (OUTPUT,8300) - IF (LINATE.EQ.2) WRITE (OUTPUT,8400) -C *** PRINT TITLE - WRITE (OUTPUT,8600) (TITLE(II),II=1,LW) -C *** TEST END OF MAP - IF (KRLOC(KCLMX).EQ.KCMX) RETURN -C *** ADJUST PAGE LINE BOUNDARIES -C - IF (IMAX.GT.PGMAX)IMAX = IMAX-PGMAX - IMIN = KA - PAGNL = PAGNL + PGMAX - PAGNR = PAGNR + PGMAX - GO TO 1700 -C *** ROUTINE TO PRE-STORE ROWS FOR CONTOURING AND COMPUTE LINE LIMITERS -C - 5900 CONTINUE - PGFST = PGFSTA - PGCNT = PGCNTA - IF (KRA.GT.NRWS) GO TO 6800 - KRFST = KTBL(KC)-KZA - KRCNT = KTBL(KC+1) - KFX = KRLOC(KRA) - IF (RECT) GO TO 6100 - IF (KRFST-PAGNL.LE.(-1)) GO TO 6400 - PCFST = KRFST-PAGNL+1 - IF (PCFST.GE.PAGN3) GO TO 6700 - PGFSTA = PCFST-1 - PCCNT = MIN0(PAGNR-KRFST+2,KRCNT) - IF (PGFSTA.EQ.0) GO TO 6600 - PGCNTA = MIN0(PAGNR-KRFST,KRCNT) - IF (PGCNTA.GT.0) GO TO 6000 - PGCNTA = 0 - GO TO 6100 - 6000 CONTINUE - RECT = KRECT.EQ.1.AND.PGCNTA.LE.KRCNT - 6100 CONTINUE - IF (.NOT.LCNTR) GO TO KBR,(1800,2100,2200,4100,5800) - DO 6200 KK = 1,PAGN3 - RWA(KK) = RWB(KK) - RWB(KK) = RWC(KK) - RWC(KK) = RWD(KK) - RWD(KK) = CRMX - 6200 CONTINUE -C - IF (PCCNT.EQ.0) GO TO KBR,(1800,2100,2200,4100,5800) - KPC = PCFST+1 - KPD = PCCNT - DO 6300 KK = 1,PCCNT - RWD(KPC) = RDATA(KFX)*BC+ADC - KFX = KFX+1 - KPC = KPC + 1 - 6300 CONTINUE - GO TO KBR,(1800,2100,2200,4100,5800) -C - 6400 CONTINUE - PCFST = 0 - PGFSTA = 0 - KFX = KFX-1 - PCCNT = KRFST+KRCNT-PAGNL+1 - IF (PCCNT.LT.PAGN3) GO TO 6500 - PCCNT = PAGN3 - PGCNTA = PGMAX - GO TO 6100 - 6500 CONTINUE - IF (PCCNT.GT.0) GO TO 6600 - PGCNTA = 0 - PCCNT = 0 - GO TO 6100 -C - 6600 CONTINUE - PGCNTA = MIN0(PGMAX,KRCNT+KRFST-PAGNL) - GO TO 6100 -C - 6700 CONTINUE - PGCNTA = 0 - 6800 CONTINUE - PCCNT = 0 - GO TO 6100 -C -C *** ROUTINE TO PRINT I-LABELS -C - 6900 CONTINUE - DO 7000 KK = 2,MXPG - KLINES(KK) = KHBLNK - 7000 CONTINUE -C -C - KK = 1 - KA = IMIN - LBL = MIN0(IMAX,PGMAX) -C - DO 7300 JJ = 1,LBL - KLINE(KK) = KHPLUS - IF (KA.LT.0) KLINE(KK) = KHMNS - KTA = IABS(MOD(KA,100))/10 - KTB = IABS(MOD(KA,10)) - KTC = IABS(MOD(KA,1000))/100 - IF (KTC .EQ. 0) GO TO 7100 - KLINE(KK+1) = KHTBL(KTC+1) - KLINE(KK+2) = KHTBL(KTA+1) - KLINE(KK+3) = KHTBL(KTB+1) - GO TO 7200 -C - 7100 CONTINUE - KLINE(KK+1) = KHTBL(KTA+1) - KLINE(KK+2) = KHTBL(KTB+1) -C - 7200 CONTINUE - KK = KK + 5 - KA = KA+1 - 7300 CONTINUE -C - WRITE (OUTPUT,8500) (KLINES(II),II=1,MXPG) -C - GO TO KBR,(1800,2100,2200,4100,5800) -C - 7400 RETURN -C - END diff --git a/src/fim/FIMsrc/w3/w3fp06.f b/src/fim/FIMsrc/w3/w3fp06.f deleted file mode 100644 index 00fb826..0000000 --- a/src/fim/FIMsrc/w3/w3fp06.f +++ /dev/null @@ -1,1163 +0,0 @@ - SUBROUTINE W3FP06(ID,KTITLE,N) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FP06 NMC TITLE SUBROUTINE -C AUTHOR: JONES,R.E. ORG: W342 DATE: 86-12-03 -C -C ABSTRACT: PROVIDES A TITLE FOR DATA FIELDS FORMULATED ACCORDING TO -C NMC O.N. 84. THE EXTRACTED INFORMATION IS CONVERTED INTO UP TO -C 81 WORDS AND STORED AT A USER PROVIDED LOCATION. -C -C PROGRAM HISTORY LOG: -C 88-11-28 R.E.JONES -C 90-02-12 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C 91-04-26 R.E.JONES ADD Q TYPE 23, 136, 137, 71, 159, 75, 118, -C 119, 24 TO TABLES, CHANGES FOR BIG RECORDS. -C 93-02-23 R.E.JONES ADD Q TYPE 157 & 158 (CORE & TKE) TO TABLES -C -C USAGE: CALL W3FP06 (ARG1, ARG2, N) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C ARG1 ARG LIST 12 WORD FIELD LABEL DESCRIBING THE DATA (6 -C INTEGER WORDS) OFFICE NOTE 84 -C N ARG LIST INTEGER NUMBER OF LINES OF OUTPUT DESIRED -C = 1 FIRST 88 CHAR. THE ABBREVIATED TITLE -C (LINE 1 STARTS AT ARG2(1)) -C = 2 FIRST 216 CHAR. DECIMAL VALUES OF THE -C PARAMETERS -C = 3 ALL 324 CHAR., HEXIDECIMAL DUMP OF THE 12 -C WORD FIELD LABEL (LINE 3 CHAR. 221 -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C ARG2 ARG LIST CHARACTER*324 SIZE ARRAY TO CONTAIN -C THE TITLE IN ACSII -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C LINE01 LINE02 LINE03 VALUE1 UNIQUE -C INTERNAL (WRITE) AND SHIFT SYSTEM -C -C REMARKS: SEE NMC O.N. 84 FOR DATA FIELD ABBREVIATIONS -C -C ATTRIBUTES: -C LANGUAGE: IBM XL FORTRAN -C MACHINE: IBM SP -C -C$$$ -C - INTEGER(8) ID(6) - INTEGER(4) MASK(8) -C - CHARACTER * 324 KTITLE -C - DATA MASK(1)/X'0000000F'/ - DATA MASK(2)/X'000000FF'/ - DATA MASK(3)/X'00000FFF'/ - DATA MASK(4)/X'0000FFFF'/ - DATA MASK(5)/X'000FFFFF'/ - DATA MASK(6)/X'00FFFFFF'/ - DATA MASK(7)/X'0FFFFFFF'/ - DATA MASK(8)/X'FFFFFFFF'/ -C - CALL LINE01(ID,MASK,KTITLE) - IF (N.GT.1) GO TO 10 - RETURN -C - 10 CONTINUE - CALL LINE02(ID,MASK,KTITLE) - IF (N.GT.2) GO TO 20 - RETURN -C - 20 CONTINUE - CALL LINE03(ID,KTITLE) - RETURN - END - SUBROUTINE LINE01(ID,MASK,KTITLE) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: LINE01 CREATES THE FIRST LINE OF TITLE -C AUTHOR: JONES,R.E. ORG: W342 DATE: 86-12-03 -C -C ABSTRACT: CREATES THE FIST LINE OF THE TITLE FROM THE ID WORDS. -C CALL BY W3FP06 TO MAKE 1ST LINE OF TITLE. WORDS 1 TO 22. -C -C PROGRAM HISTORY LOG: -C 88-09-02 R.E.JONES -C 93-02-23 R.E.JONES ADD Q TYPE 157 & 158 (CORE & TKE) TO TABLES -C -C USAGE: CALL LINE01(ID,MASK,KTITLE) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C ID ARG LIST ID WORDS (6 INTEGER WORDS) OFFICE NOTE 84 -C MASK ARG LIST MASK FOR UNPACKING ID WORDS (8 INTEGER WORDS) -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C KTITLE ARG LIST CHARACTER *324 ARRAY -C TAPE6 ERROR MESSAGES -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C AND SHIFT SYSLIB -C VALUE1 CLIMO SETCL UNIQUE -C -C ATTRIBUTES: -C LANGUAGE: IBM XL FORTRAN -C MACHINE: IBM SP -C -C$$$ -C -C CREATES THE FIRST 22 WORDS OF TITLER -C - INTEGER(8) ID(6) - INTEGER(4) MASK(8) - INTEGER(4) SHFMSK(17) -C - CHARACTER * 4 UNIT - CHARACTER * 4 UNIT1 - CHARACTER * 4 DAYS - CHARACTER * 5 FOR - CHARACTER * 5 FOR1 - CHARACTER * 1 DASH - CHARACTER * 8 KNAME(9) - CHARACTER * 8 KNAME1(3) - CHARACTER * 324 KTITLE - CHARACTER * 8 KWRITE(3) - CHARACTER * 8 INUM1 - CHARACTER * 8 INUM2 - CHARACTER * 6 QNAME1 - CHARACTER * 6 QNAME2 - CHARACTER * 6 QNAME3 - CHARACTER * 2 DN - CHARACTER * 6 QNAME(166) - CHARACTER * 6 QWRITE - CHARACTER * 4 SNAME(18) - CHARACTER * 20 VUNIT(2) - CHARACTER * 7 AFTER - CHARACTER * 7 AFTBEF -C - INTEGER KK(3) - INTEGER LL(166) - INTEGER JKEEP(17) - INTEGER JLIST(17) - INTEGER C1,C2,E1,E2,S1,S2,Q,M,G - INTEGER YY,MM,DD,HH,F1,F2,JT,JN -C -C IDWORDS: MASK CONTROL (INTEGER) -C - DATA SHFMSK( 1)/X'20020100'/ - DATA SHFMSK( 2)/X'28020400'/ - DATA SHFMSK( 3)/X'30020400'/ - DATA SHFMSK( 4)/X'38020400'/ - DATA SHFMSK( 5)/X'08050100'/ - DATA SHFMSK( 6)/X'00020100'/ - DATA SHFMSK( 7)/X'08050200'/ - DATA SHFMSK( 8)/X'00020200'/ - DATA SHFMSK( 9)/X'3C010200'/ - DATA SHFMSK(10)/X'28030100'/ - DATA SHFMSK(11)/X'28030200'/ - DATA SHFMSK(12)/X'34030100'/ - DATA SHFMSK(13)/X'20020400'/ - DATA SHFMSK(14)/X'30020400'/ - DATA SHFMSK(15)/X'1C010100'/ - DATA SHFMSK(16)/X'1C010200'/ - DATA SHFMSK(17)/X'20020200'/ -C -C REFERENCE TABLE FOR SNAME. -C - DATA JLIST(1)/1/ - DATA JLIST(2)/2/ - DATA JLIST(3)/6/ - DATA JLIST(4)/7/ - DATA JLIST(5)/8/ - DATA JLIST(6)/16/ - DATA JLIST(7)/19/ - DATA JLIST(8)/128/ - DATA JLIST(9)/129/ - DATA JLIST(10)/130/ - DATA JLIST(11)/144/ - DATA JLIST(12)/145/ - DATA JLIST(13)/146/ - DATA JLIST(14)/147/ - DATA JLIST(15)/148/ - DATA JLIST(16)/131/ - DATA JLIST(17)/132/ -C -C SNAME TABLE. -C - DATA SNAME( 1)/' GPM'/ - DATA SNAME( 2)/' PA '/ - DATA SNAME( 3)/' M '/ - DATA SNAME( 4)/' M '/ - DATA SNAME( 5)/' MB '/ - DATA SNAME( 6)/' DEG'/ - DATA SNAME( 7)/' POT'/ - DATA SNAME( 8)/' MSL'/ - DATA SNAME( 9)/' SFC'/ - DATA SNAME(10)/' TRO'/ - DATA SNAME(11)/' BDY'/ - DATA SNAME(12)/' TRS'/ - DATA SNAME(13)/' STS'/ - DATA SNAME(14)/' QCP'/ - DATA SNAME(15)/' SIG'/ - DATA SNAME(16)/'MWSL'/ - DATA SNAME(17)/'PLYR'/ - DATA SNAME(18)/' '/ -C -C REFERENCE TABLE FOR QNAME. -C - DATA LL( 1)/ 1/ - DATA LL( 2)/ 2/ - DATA LL( 3)/ 6/ - DATA LL( 4)/ 8/ - DATA LL( 5)/ 16/ - DATA LL( 6)/ 17/ - DATA LL( 7)/ 18/ - DATA LL( 8)/ 19/ - DATA LL( 9)/ 20/ - DATA LL(10)/ 21/ - DATA LL(11)/ 40/ - DATA LL(12)/ 41/ - DATA LL(13)/ 42/ - DATA LL(14)/ 43/ - DATA LL(15)/ 44/ - DATA LL(16)/ 48/ - DATA LL(17)/ 49/ - DATA LL(18)/ 50/ - DATA LL(19)/ 51/ - DATA LL(20)/ 52/ - DATA LL(21)/ 53/ - DATA LL(22)/ 54/ - DATA LL(23)/ 55/ - DATA LL(24)/ 56/ - DATA LL(25)/ 57/ - DATA LL(26)/ 58/ - DATA LL(27)/ 59/ - DATA LL(28)/ 60/ - DATA LL(29)/ 72/ - DATA LL(30)/ 73/ - DATA LL(31)/ 74/ - DATA LL(32)/ 80/ - DATA LL(33)/ 81/ - DATA LL(34)/ 88/ - DATA LL(35)/ 89/ - DATA LL(36)/ 90/ - DATA LL(37)/ 91/ - DATA LL(38)/ 92/ - DATA LL(39)/ 93/ - DATA LL(40)/ 94/ - DATA LL(41)/ 95/ - DATA LL(42)/ 96/ - DATA LL(43)/112/ - DATA LL(44)/113/ - DATA LL(45)/114/ - DATA LL(46)/115/ - DATA LL(47)/120/ - DATA LL(48)/121/ - DATA LL(49)/160/ - DATA LL(50)/161/ - DATA LL(51)/162/ - DATA LL(52)/163/ - DATA LL(53)/164/ - DATA LL(54)/165/ - DATA LL(55)/166/ - DATA LL(56)/167/ - DATA LL(57)/168/ - DATA LL(58)/169/ - DATA LL(59)/170/ - DATA LL(60)/171/ - DATA LL(61)/176/ - DATA LL(62)/177/ - DATA LL(63)/178/ - DATA LL(64)/184/ - DATA LL(65)/185/ - DATA LL(66)/186/ - DATA LL(67)/187/ - DATA LL(68)/188/ - DATA LL(69)/384/ - DATA LL(70)/385/ - DATA LL(71)/386/ - DATA LL(72)/387/ - DATA LL(73)/388/ - DATA LL(74)/389/ - DATA LL(75)/390/ - DATA LL(76)/391/ - DATA LL(77)/ 97/ - DATA LL(78)/ 98/ - DATA LL(79)/ 99/ - DATA LL(80)/100/ - DATA LL(81)/101/ - DATA LL(82)/102/ - DATA LL(83)/103/ - DATA LL(84)/172/ - DATA LL(85)/200/ - DATA LL(86)/201/ - DATA LL(87)/202/ - DATA LL(88)/203/ - DATA LL(89)/392/ - DATA LL(90)/ 7/ - DATA LL(91)/ 61/ - DATA LL(92)/104/ - DATA LL(93)/173/ - DATA LL(94)/174/ - DATA LL(95)/175/ - DATA LL(96)/304/ - DATA LL(97)/305/ - DATA LL(98)/400/ - DATA LL(99)/401/ - DATA LL(100)/402/ - DATA LL(101)/403/ - DATA LL(102)/404/ - DATA LL(103)/405/ - DATA LL(104)/ 9/ - DATA LL(105)/105/ - DATA LL(106)/116/ - DATA LL(107)/106/ - DATA LL(108)/107/ - DATA LL(109)/108/ - DATA LL(110)/179/ - DATA LL(111)/180/ - DATA LL(112)/181/ - DATA LL(113)/182/ - DATA LL(114)/183/ - DATA LL(115)/189/ - DATA LL(116)/190/ - DATA LL(117)/191/ - DATA LL(118)/192/ - DATA LL(119)/193/ - DATA LL(120)/194/ - DATA LL(121)/195/ - DATA LL(122)/196/ - DATA LL(123)/197/ - DATA LL(124)/198/ - DATA LL(125)/199/ - DATA LL(126)/204/ - DATA LL(127)/210/ - DATA LL(128)/211/ - DATA LL(129)/212/ - DATA LL(130)/213/ - DATA LL(131)/214/ - DATA LL(132)/215/ - DATA LL(133)/216/ - DATA LL(134)/117/ - DATA LL(135)/209/ - DATA LL(136)/ 22/ - DATA LL(137)/ 62/ - DATA LL(138)/ 63/ - DATA LL(139)/ 82/ - DATA LL(140)/ 83/ - DATA LL(141)/ 84/ - DATA LL(142)/ 85/ - DATA LL(143)/205/ - DATA LL(144)/206/ - DATA LL(145)/207/ - DATA LL(146)/208/ - DATA LL(147)/217/ - DATA LL(148)/109/ - DATA LL(149)/110/ - DATA LL(150)/111/ - DATA LL(151)/86/ - DATA LL(152)/87/ - DATA LL(153)/218/ - DATA LL(154)/133/ - DATA LL(155)/134/ - DATA LL(156)/135/ - DATA LL(157)/23/ - DATA LL(158)/136/ - DATA LL(159)/137/ - DATA LL(160)/71/ - DATA LL(161)/159/ - DATA LL(162)/75/ - DATA LL(163)/157/ - DATA LL(164)/119/ - DATA LL(165)/24/ - DATA LL(166)/158/ -C -C QNAME TABLE: CHARACTER*6 -C - DATA QNAME( 1)/' HGT '/ - DATA QNAME( 2)/' P ALT'/ - DATA QNAME( 3)/' DIST '/ - DATA QNAME( 4)/' PRES '/ - DATA QNAME( 5)/' TMP '/ - DATA QNAME( 6)/' DPT '/ - DATA QNAME( 7)/' DEPR '/ - DATA QNAME( 8)/' POT '/ - DATA QNAME( 9)/' T MAX'/ - DATA QNAME(10)/' T MIN'/ - DATA QNAME(11)/' V VEL'/ - DATA QNAME(12)/' NETVD'/ - DATA QNAME(13)/' DZDT '/ - DATA QNAME(14)/' OROW '/ - DATA QNAME(15)/' FRCVV'/ - DATA QNAME(16)/' U GRD'/ - DATA QNAME(17)/' V GRD'/ - DATA QNAME(18)/' WIND '/ - DATA QNAME(19)/' T WND'/ - DATA QNAME(20)/' VW SH'/ - DATA QNAME(21)/' U DIV'/ - DATA QNAME(22)/' V DIV'/ - DATA QNAME(23)/' WDIR '/ - DATA QNAME(24)/' WWND '/ - DATA QNAME(25)/' SWND '/ - DATA QNAME(26)/' RATS '/ - DATA QNAME(27)/' VECW '/ - DATA QNAME(28)/' SFAC '/ - DATA QNAME(29)/' ABS V'/ - DATA QNAME(30)/' REL V'/ - DATA QNAME(31)/' DIV '/ - DATA QNAME(32)/' STRM '/ - DATA QNAME(33)/' V POT'/ - DATA QNAME(34)/' R H '/ - DATA QNAME(35)/' P WAT'/ - DATA QNAME(36)/' A PCP'/ - DATA QNAME(37)/' P O P'/ - DATA QNAME(38)/' P O Z'/ - DATA QNAME(39)/' SNO D'/ - DATA QNAME(40)/' ACPCP'/ - DATA QNAME(41)/' SPF H'/ - DATA QNAME(42)/' L H2O'/ - DATA QNAME(43)/' LFT X'/ - DATA QNAME(44)/' TOTOS'/ - DATA QNAME(45)/' K X '/ - DATA QNAME(46)/' C INS'/ - DATA QNAME(47)/' L WAV'/ - DATA QNAME(48)/' S WAV'/ - DATA QNAME(49)/' DRAG '/ - DATA QNAME(50)/' LAND '/ - DATA QNAME(51)/' KFACT'/ - DATA QNAME(52)/' 10TSL'/ - DATA QNAME(53)/' 7TSL '/ - DATA QNAME(54)/' RCPOP'/ - DATA QNAME(55)/' RCMT '/ - DATA QNAME(56)/' RCMP '/ - DATA QNAME(57)/' ORTHP'/ - DATA QNAME(58)/' ALBDO'/ - DATA QNAME(59)/' ENFLX'/ - DATA QNAME(60)/' TTHTG'/ - DATA QNAME(61)/' LAT '/ - DATA QNAME(62)/' LON '/ - DATA QNAME(63)/' RADIC'/ - DATA QNAME(64)/' PROB '/ - DATA QNAME(65)/' CPROB'/ - DATA QNAME(66)/' USTAR'/ - DATA QNAME(67)/' TSTAR'/ - DATA QNAME(68)/' MIXHT'/ - DATA QNAME(69)/' WTMP '/ - DATA QNAME(70)/' WVHGT'/ - DATA QNAME(71)/' SWELL'/ - DATA QNAME(72)/' WVSWL'/ - DATA QNAME(73)/' WVPER'/ - DATA QNAME(74)/' WVDIR'/ - DATA QNAME(75)/' SWPER'/ - DATA QNAME(76)/' SWDIR'/ - DATA QNAME(77)/' RRATE'/ - DATA QNAME(78)/' TSTM '/ - DATA QNAME(79)/' CSVR '/ - DATA QNAME(80)/' CTDR '/ - DATA QNAME(81)/' MIXR '/ - DATA QNAME(82)/' PSVR '/ - DATA QNAME(83)/' MCONV'/ - DATA QNAME(84)/' ENRGY'/ - DATA QNAME(85)/' RDNCE'/ - DATA QNAME(86)/' BRTMP'/ - DATA QNAME(87)/' TCOZ '/ - DATA QNAME(88)/' OZMR '/ - DATA QNAME(89)/' ICWAT'/ - DATA QNAME(90)/' DEPTH'/ - DATA QNAME(91)/' GUST '/ - DATA QNAME(92)/' VAPP '/ - DATA QNAME(93)/' TOTHF'/ - DATA QNAME(94)/' SPEHF'/ - DATA QNAME(95)/' SORAD'/ - DATA QNAME(96)/' UOGRD'/ - DATA QNAME(97)/' VOGRD'/ - DATA QNAME(98)/' HTSGW'/ - DATA QNAME(99)/' PERPW'/ - DATA QNAME(100)/' DIRPW'/ - DATA QNAME(101)/' PERSW'/ - DATA QNAME(102)/' DIRSW'/ - DATA QNAME(103)/' WCAPS'/ - DATA QNAME(104)/' PTEND'/ - DATA QNAME(105)/' NCPCP'/ - DATA QNAME(106)/' 4LFTX'/ - DATA QNAME(107)/' ICEAC'/ - DATA QNAME(108)/' NPRAT'/ - DATA QNAME(109)/' CPRAT'/ - DATA QNAME(110)/'CEILHT'/ - DATA QNAME(111)/' VISIB'/ - DATA QNAME(112)/'LIQPCP'/ - DATA QNAME(113)/'FREPCP'/ - DATA QNAME(114)/'FROPCP'/ - DATA QNAME(115)/' MIXLY'/ - DATA QNAME(116)/' DLRFL'/ - DATA QNAME(117)/' ULRFL'/ - DATA QNAME(118)/' DSRFL'/ - DATA QNAME(119)/' USRFL'/ - DATA QNAME(120)/' UTHFL'/ - DATA QNAME(121)/' UTWFL'/ - DATA QNAME(122)/' TTLWR'/ - DATA QNAME(123)/' TTSWR'/ - DATA QNAME(124)/' TTRAD'/ - DATA QNAME(125)/' MSTAV'/ - DATA QNAME(126)/' SWABS'/ - DATA QNAME(127)/' CDLYR'/ - DATA QNAME(128)/' CDCON'/ - DATA QNAME(129)/' PBCLY'/ - DATA QNAME(130)/' PTCLY'/ - DATA QNAME(131)/' PBCON'/ - DATA QNAME(132)/' PTCON'/ - DATA QNAME(133)/' SFEXC'/ - DATA QNAME(134)/' A EVP'/ - DATA QNAME(135)/' STCOF'/ - DATA QNAME(136)/' TSOIL'/ - DATA QNAME(137)/'D DUDT'/ - DATA QNAME(138)/'D DVDT'/ - DATA QNAME(139)/' U STR'/ - DATA QNAME(140)/' V STR'/ - DATA QNAME(141)/' TUVRD'/ - DATA QNAME(142)/' TVVRD'/ - DATA QNAME(143)/' TTLRG'/ - DATA QNAME(144)/' TTSHL'/ - DATA QNAME(145)/' TTDEP'/ - DATA QNAME(146)/' TTVDF'/ - DATA QNAME(147)/' ZSTAR'/ - DATA QNAME(148)/' TQDEP'/ - DATA QNAME(149)/' TQSHL'/ - DATA QNAME(150)/' TQVDF'/ - DATA QNAME(151)/'XGWSTR'/ - DATA QNAME(152)/'YGWSTR'/ - DATA QNAME(153)/' STDZG'/ - DATA QNAME(154)/' A LEV'/ - DATA QNAME(155)/' T AIL'/ - DATA QNAME(156)/' B AIL'/ - DATA QNAME(157)/' EPOT '/ - DATA QNAME(158)/' MSLSA'/ - DATA QNAME(159)/' MSLMA'/ - DATA QNAME(160)/'MGSTRM'/ - DATA QNAME(161)/' CONDP'/ - DATA QNAME(162)/' POT V'/ - DATA QNAME(163)/' CAPE '/ - DATA QNAME(164)/' CIN '/ - DATA QNAME(165)/' VTMP '/ - DATA QNAME(166)/' TKE '/ -C -C REFERENCE TABLE FOR G (GENERATING PROGRAM NAME) -C - DATA KK(1)/57/ - DATA KK(2)/58/ - DATA KK(3)/59/ -C -C G TABLE (GENERATING PROGRM NAME): -C - DATA KNAME/' ECMWF', ' READING', ',UK. ', - & ' FNOC', ' MONTERE', 'Y, CA. ', - & ' AFGWC ', 'OFFUTT A', 'FB, NB. '/ - DATA KNAME1/' WMC N','MC WASHI', 'NGTON '/ -C - DATA AFTER /' AFTER '/ - DATA DN /'DN'/ - DATA QNAME1/' THCK '/ - DATA QNAME2/' THKDN'/ - DATA QNAME3/' PRSDN'/ -C - DATA VUNIT(1)/' 0-HR FCST VALID AT '/ - DATA VUNIT(2)/' ANALYSIS VALID AT '/ - DATA UNIT1 /' HRS'/ - DATA DAYS /' DYS'/ - DATA FOR1 /' FOR '/ - DATA DASH /'-'/ -C - 200 FORMAT ( ' ',A7,A4,' ',A7) - 210 FORMAT ( A4,1X,A6,A5,F4.1,A4,A7, - & I2.2,A1,I2.2,A1,I2.2,1X,I2.2,'Z',3A8) - 220 FORMAT ( 13X,A7) - 230 FORMAT ( ' Q IS AN ILLEGAL OFFICE NOTE 84 DATA TYPE, Q = ', - & I5,35X) - 240 FORMAT ( A4,1X,A6,A20, - & I2.2,A1,I2.2,A1,I2.2,1X,I2.2,'Z',3A8) -C -C$ 1. UNPACK ID WORDS. -C - DO 10 N = 1,17 - ITEMP = 0 - KTEMP = 0 - ITEMP = SHFMSK(N) - NSHIFT = IAND(ISHFT(ITEMP,-24),255) - NMASK = IAND(ISHFT(ITEMP,-16),255) - NID = IAND(ISHFT(ITEMP,-8),255) - ITEMP = MASK(NMASK) - KTEMP = ID(NID) - JKEEP(N) = IAND(ITEMP,ISHFT(KTEMP,-NSHIFT)) - 10 CONTINUE -C - F1 = JKEEP(1) - DD = JKEEP(2) - MM = JKEEP(3) - YY = JKEEP(4) - C1 = JKEEP(5) - E1 = JKEEP(6) - C2 = JKEEP(7) - E2 = JKEEP(8) - M = JKEEP(9) - S1 = JKEEP(10) - S2 = JKEEP(11) - Q = JKEEP(12) - HH = JKEEP(13) - G = JKEEP(14) - JT = JKEEP(15) - JN = JKEEP(16) - F2 = JKEEP(17) -C - KS = IAND(ISHFT(ID(3),-40_8),255_8) -C -C 2. FIND WHICH PARAMETER (Q) IS INDICATED BE THE ID WORDS. -C - DO 20 N = 1,166 - NN = N - IF (Q.EQ.LL(N)) GO TO 30 - 20 CONTINUE -C -C CAN NOT FIND A LEGAL Q - GO TO 170 -C - 30 CONTINUE - UNIT(1:4) = UNIT1(1:4) - FOR(1:5) = FOR1(1:5) - AFTBEF(1:7) = AFTER(1:7) -C - IF (E1.GT.128) E1 = -(JKEEP(6)-128) - IF (E2.GT.128) E2 = -(JKEEP(8)-128) -C -C$ 3. FIND WHICH SURFACE IS INDICATED BY THE ID WORDS -C$ AS BEING THE FIRST SURFACE. -C - DO 40 I = 1,17 - IF (S1.EQ.JLIST(I)) THEN - K1 = I - GO TO 50 - ENDIF - 40 CONTINUE - K1 = 18 -C - 50 CONTINUE -C -C$ 4. BEGIN PROCESSING OF A ONE-SURFACE TITLE -C - IF (M.EQ.0.OR.M.EQ.8) THEN - K2 = K1 - CALL VALUE1(S1,C1,E1,INUM1) - WRITE (KTITLE(1:20),220) INUM1 - GO TO 80 - ENDIF -C -C$ 5. FIND WHICH SURFACE IS INDICATED BY THE ID WORDS -C$ AS BEING THE SECOND SURFACE. -C - DO 60 I = 1,17 - IF (S2.EQ.JLIST(I)) THEN - K2 = I - GO TO 70 - ENDIF - 60 CONTINUE - K2 = 18 -C - 70 CONTINUE -C -C$ 6. BEGIN PROCESSING OF A TWO-SURFACE TITLE -C - CALL VALUE1(S1,C1,E1,INUM1) - CALL VALUE1(S2,C2,E2,INUM2) - WRITE (KTITLE(1:20),200) INUM1 , SNAME(K1) , INUM2 -C - 80 CONTINUE - QWRITE = QNAME(NN) -C - IF (Q.EQ.1 .AND. M.EQ.1.AND. S1.EQ.8) QWRITE = QNAME1 - IF (Q.EQ.1 .AND. M.EQ.1.AND. S1.EQ.8.AND.KS.EQ.2) QWRITE = QNAME2 - IF (Q.EQ.8 .AND. S1.EQ.128.AND.KS.EQ.2) QWRITE = QNAME3 - IF (JT.EQ.6) QWRITE(5:6) = DN(1:2) -C -C$ 7. SET DATE/TIME FIELDS -C -C$ A. CHECK IF F1 AND F2 ARE IN HRS, HALF DAYS OR DAYS. -C - RF1 = F1 - RF2 = F2 -C -C B: IF F1 IN HALF DAYS: CONVERT TO HOURS -C - IF (JN.EQ.15.OR.JT.EQ.7) THEN - RF1 = RF1 * 12.0 - RF2 = RF2 * 12.0 - ENDIF -C -C C: IF F1 IN DAYS: CONVERT TO HOURS -C - IF (JT.EQ.10) THEN - RF1 = RF1 * 24.0 - RF2 = RF2 * 24.0 - ENDIF -C -C D: CONVERT HOURS TO DAYS IF HOURS GREATER THAN 72 -C - IF (JT.NE.6) THEN - IF (RF1.GT.72.0.OR.RF2.GT.72.0) THEN - RF1 = RF1 / 24.0 - RF2 = RF2 / 24.0 - UNIT(1:4) = DAYS(1:4) - ENDIF - ENDIF -C - IF (JT.EQ.6) THEN - IF (F1.GT.127) THEN - F1 = AND(F1,127) - F1 = -F1 - ENDIF - CF1 = F1 - CF2 = F2 - CALL CLIMO(CF1,CF2,UNIT,FOR,AFTBEF) - RF1 = CF1 - CALL SETCL(CF2,UNIT,KTITLE) - ENDIF -C -C$ 8. SET GENERATING PROGRAM NAME -C - DO 110 K = 1,3 - IF (G.EQ.KK(K)) GO TO 130 - 110 CONTINUE -C - DO 120 L = 1,3 - KWRITE(L) = KNAME1(L) - 120 CONTINUE - GO TO 150 -C - 130 CONTINUE - DO 140 L = 1,3 - KWRITE(L) = KNAME( 3*(K-1) + L) - 140 CONTINUE -C -C$ 9. ENCODE THE TITLE LINE -C -C$ 9.1 DISTINGUISH BETWEEN ANALYSIS AND ZERO FORECASTS -C AND 'REAL' FORECASTS -C - 150 CONTINUE - IF (F1.NE.0) GO TO 160 - IF (G.EQ.19.OR.G.EQ.22.OR.G.EQ.43.OR.G.EQ.44.OR.G.EQ.49.OR. - & G.EQ.55.OR.G.EQ.56.OR.G.EQ.64) THEN - III = 2 - IF (M.EQ.8.OR.M.EQ.9.OR.M.EQ.10) III = 1 - ELSE - III = 1 - ENDIF -C - WRITE (KTITLE(21:88),240) SNAME(K2), QWRITE, VUNIT(III), - & YY, DASH, MM, DASH, DD, HH, (KWRITE(L),L=1,3) - RETURN -C - 160 CONTINUE - WRITE (KTITLE(21:88),210) SNAME(K2), QWRITE, FOR, RF1, UNIT, - & AFTBEF, YY, DASH, MM, DASH, DD, HH, (KWRITE(L),L=1,3) - RETURN -C - 170 CONTINUE - WRITE (KTITLE(1:88),230) Q - RETURN - END - SUBROUTINE VALUE1(S,C,E,NUM) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: VALUE1 CREATES VALUE1 OF SURFACE FROM IDS -C AUTHOR: JONES,R.E. ORG: W342 DATE: 86-12-03 -C -C ABSTRACT: CREATES THE NUMERICAL VALUE FOR THE SURFACE -C TO BE BUILT INTO THE FIRST LINE OF THE TITLE. -C -C PROGRAM HISTORY LOG: -C 88-11-28 R.E.JONES -C 89-11-01 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C -C USAGE: CALL VALUE1(S,C,E,NUM) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C S ARG LIST INTEGER NUMBER OF SURFACE -C C,E NUMERICAL VALUE OF THE SURFACE -C SURFACE = S * 10 ** E -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C NUM ARG LIST 7 CHARACTER VALUE OF THE SURFACE FOR THE TITLE -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C INTERNAL (WRITE) SYSLIB -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - INTEGER C - INTEGER E - INTEGER S -C - CHARACTER*8 JNUM - CHARACTER*8 KNUM - CHARACTER*7 LTEMP - CHARACTER*8 NUM - CHARACTER*1 POINT - CHARACTER*1 ZERO -C - DATA JNUM /' 0.0000 '/ - DATA KNUM /' '/ - DATA POINT /'.'/ - DATA ZERO /'0'/ -C - 101 FORMAT ( I6,' ') -C - IF (S.GE.128.AND.S.LE.132) GO TO 110 - IF (C.EQ.0) GO TO 100 - WRITE (LTEMP(1:7),101) C - J = E + 6 - K = J + 1 - IF (J.EQ.0) GO TO 90 - NUM(1:J) = LTEMP(1:J) -C - 90 CONTINUE - NUM(K:K) = POINT - NUM(K+1:8) = LTEMP(K:7) - IF (J.EQ.0) NUM(2:2) = ZERO - GO TO 150 -C - 100 CONTINUE - NUM = JNUM - GO TO 150 -C - 110 CONTINUE - NUM = KNUM -C - 150 CONTINUE -C - RETURN - END - SUBROUTINE LINE02(ID,MASK,KTITLE) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: LINE02 CREATES THE SECOND LINE OF TITLE -C AUTHOR: JONES,R.E. ORG: W342 DATE: 86-12-03 -C -C ABSTRACT: CREATES THE SECOND LINE OF THE TITLE FROM THE ID WORDS. -C CALLED BY W3FP06. WORDS 23 TO 54. -C -C PROGRAM HISTORY LOG: -C 88-11-28 R.E.JONES -C 89-11-01 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C 91-03-01 R.E.JONES CHANGES FOR BIG RECORDS -C -C USAGE: CALL LINE02(ID,MASK,KTITLE) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C ID ARG LIST ID WORDS (6 INTEGER WORDS) OFFICE NOTE 84 -C MASK ARG LIST MASK FOR UNPACKING ID WORDS (8 WORDS) -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C KTITLE ARG LIST TITLE CHARACTER*324 -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C INTERNAL (WRITE) SHIFT AND SYSLIB -C q9ie32 W3LIB -C -C ATTRIBUTES: -C LANGUAGE: IBM XL FORTRAN -C MACHINE: IBM SP -C -C$$$ -C - INTEGER(8) ID(6) - INTEGER(8) IKEEP(17) - INTEGER(4) MASK(8) - INTEGER(8) MASK32,MASKN - INTEGER(4) SHFMSK(17) - integer(8) irtemp - real(4) rtemp(2) - equivalence (irtemp,rtemp(1)) -C - CHARACTER * 324 KTITLE -C -C IDWORDS: MASK CONTROL (INTEGER) -C - DATA MASKN /X'FFFFFFFFFFFF0000'/ - DATA MASK32/X'00000000FFFFFFFF'/ - DATA SHFMSK( 1)/X'3C010200'/ - DATA SHFMSK( 2)/X'1C010100'/ - DATA SHFMSK( 3)/X'1C010200'/ - DATA SHFMSK( 4)/X'20020100'/ - DATA SHFMSK( 5)/X'20020200'/ - DATA SHFMSK( 6)/X'38020300'/ - DATA SHFMSK( 7)/X'30020300'/ - DATA SHFMSK( 8)/X'28020300'/ - DATA SHFMSK( 9)/X'20020300'/ - DATA SHFMSK(10)/X'3C010300'/ - DATA SHFMSK(11)/X'18020400'/ - DATA SHFMSK(12)/X'10020400'/ - DATA SHFMSK(13)/X'00040400'/ - DATA SHFMSK(14)/X'30040500'/ - DATA SHFMSK(15)/X'00040500'/ - DATA SHFMSK(16)/X'00080500'/ - DATA SHFMSK(17)/X'20040600'/ -C - 100 FORMAT(' M=',I2,' T=',I2,' N=',I2,' F1=',I3,' F2=',I3,' CD=',I3, - 1' CM=',I3,' KS=',I3,' K=',I3,' GES=',I2,' R=',I3,' G=',I3, - 2' J=',I5,' B=',I5,' Z=',I5,' A=',E15.8,' N=',I5,' ') -C -C UNPACK ID WORDS. -C - DO 10 N = 1,17 - ITEMP = SHFMSK(N) - NSHIFT = IAND(ISHFT(ITEMP,-24),255) - NMASK = IAND(ISHFT(ITEMP,-16),255) - NID = IAND(ISHFT(ITEMP,-8),255) - JTEMP = MASK(NMASK) - KTEMP = ID(NID) - IKEEP(N) = IAND(JTEMP,ISHFT(KTEMP,-NSHIFT)) - 10 CONTINUE -C -C CONVERT IBM 32 BIT F.P. NUMBER TO IEEE F.P. NUMBER -C -C CALL USSCTC(ID(5),5,A,1) - irtemp=ID(5) - call q9ie32(rtemp(2),rtemp(1),1,istat) - a=rtemp(1) -C -C CONVERT 16 BIT SIGNED INTEGER INTO A 64 BIT INTEGER. -C - IF (BTEST(IKEEP(17),15_8)) THEN - IKEEP(17) = IOR(IKEEP(17),MASKN) - ENDIF -C -C TEST FOR BIG RECORD -C - IF (IKEEP(13).EQ.0) THEN - IKEEP(13) = IAND(ID(6),MASK32) - END IF -C - WRITE (KTITLE(89:216),100) (IKEEP(I),I=1,15) , A , IKEEP(17) - RETURN - END - SUBROUTINE LINE03(ID,KTITLE) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: LINE03 CREATES THE THIRD LINE OF TITLE -C AUTHOR: JONES,R.E ORG: W342 DATE: 86-12-03 -C -C ABSTRACT: CREATES THE THIRD LINE OF THE TITLE FROM THE ID WORDS. -C CALLED BY W3FP06 TO CREATE WORDS 55 TO 81 OF THE TITLE. -C -C PROGRAM HISTORY LOG: -C 88-11-28 R.E.JONES -C 90-02-03 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C -C USAGE: CALL LINE03(ID,KTITLE) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C ID ARG LIST ID WORDS (6 INTEGER) OFFICE NOTE 84 -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C KTITLE ARG LIST CHARACTER*324 ARRAY -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C INTERNAL (WRITE) SYSLIB -C -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - INTEGER(8) ID(6) - INTEGER(8) MASK32 - INTEGER ID84(12) -C - CHARACTER * 324 KTITLE -C - DATA MASK32/X'00000000FFFFFFFF'/ -C -C FORTRAN INTERNAL WRITE STATEMENT REPLACES ENCODE -C - 100 FORMAT ( 12(1X,Z8)) -C - DO 10 J = 1,11,2 - ID84(J) = ISHFT(ID(J/2+1),-32_8) - ID84(J+1) = IAND(ID(J/2+1),MASK32) - 10 CONTINUE -C - WRITE (KTITLE(217:324),100) (ID84(I),I=1,12) - RETURN - END - SUBROUTINE CLIMO(CF1,CF2,UNIT,FOR,AFTBEF) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: CLIMO SETS TIME-AVERAGED TITLES -C AUTHOR: JONES,R.E. ORG: W342 DATE: 86-12-03 -C -C ABSTRACT: FILLS IN THE FIRST THIRTEEN CHARACTERS IN THE TITLE -C TO MAKE THE TITLE A TIME-AVERAGED TITLE. -C -C PROGRAM HISTORY LOG: -C 88-11-28 R.E.JONES -C 89-11-01 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C -C USAGE: CALL CLIMO(CF1,CF2,UNIT,FOR) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C CF1 ARG LIST FORECAST PERIOD LENGTH -C CF2 ARG LIST LENGTH OF THE AVERAGE -C UNIT ARG LIST ORIGINALLY SET TO ' HRS' -C FOR ARG LIST ORIGINALLY SET TO ' FOR ' -C AFTBEF ARG LIST ORIGINALLY SET TO ' AFTER ' -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C UNIT ARG LIST SET TO ' DYS' IF NECESSARY -C FOR ARG LIST SET TO ' CTR ' -C AFTBEF ARG LIST SET TO ' BEFOR ' IF NECESSARY -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - REAL CF1 - REAL CF2 -C - CHARACTER*7 AFTBEF - CHARACTER*7 BEFOR - CHARACTER*5 FOR - CHARACTER*5 FOR1 - CHARACTER*4 UNIT - CHARACTER*4 UNIT1 - CHARACTER*4 UNIT2 -C - DATA BEFOR /' BEFOR '/ - DATA FOR1 /' CTR '/ - DATA UNIT1 /' DYS'/ - DATA UNIT2 /' HRS'/ -C -C SET FOR TO ' CTR ' -C - FOR(1:5) = FOR1(1:5) -C -C DIFFERENCE = CENTERDAY - RUNDATE = F1 + 2 DAYS -C CHANGE CF1 TO HOURS, ADD 48 HOURS -C - DIFF = CF1 * 12.0 + 48.0 -C -C IF DIFF NEGATIVE, SET AFTBEF TO ' BEFOR ' -C - IF (DIFF.LT.0.0) AFTBEF(1:7) = BEFOR(1:7) -C - CF2 = CF2 * 12.0 -C - IF (ABS(DIFF).LE.72.0) THEN - CF1 = ABS(DIFF) - CF2 = CF2 / 24.0 -C -C SET UNIT TO ' HRS ' -C - UNIT(1:4) = UNIT2(1:4) - GO TO 100 - ENDIF -C - CF1 = ABS(DIFF / 24.0 ) - CF2 = CF2 / 24.0 -C -C SET UNIT TO ' DYS ' -C - UNIT(1:4) = UNIT1(1:4) -C - 100 CONTINUE - RETURN - END - SUBROUTINE SETCL(CF2,UNIT,KTITLE) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SETCL ENCODES TIME-AVERAGED TITLE -C AUTHOR: JONES,R.E. ORG: W342 DATE: 86-12-03 -C -C ABSTRACT: ENCODES THE FIRST THIRTEEN CHARACTERS IN THE TITLE -C TO MAKE THE TITLE A TIME-AVERAGED TITLE. -C -C PROGRAM HISTORY LOG: -C 88-11-28 R.E.JONES -C 89-11-01 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C -C USAGE: CALL CLIMO(F2,UNIT,KTITLE) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C CF2 ARG LIST LENGTH OF THE FORECAST PERIOD -C UNIT ARG LIST UNITS FOR CF2 -C KTITLE ARG LIST TITLE TO BE MODIFIED -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C KTITLE ARG LIST TITLE WITH THE TIME-AVERAGED INCLUDED -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - CHARACTER*324 KTITLE - CHARACTER*13 BLANK - CHARACTER*4 UNIT - CHARACTER*4 DUNIT - CHARACTER*4 HUNIT -C - DATA BLANK /' '/ - DATA DUNIT /'-DAY'/ - DATA HUNIT /'-HR '/ -C - 100 FORMAT (1X, F4.1, A4, ' AVG' ) -C - KTITLE(1:13) = BLANK(1:13) -C - WRITE (KTITLE(1:13),100) CF2 , DUNIT(1:4) -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fp10.f b/src/fim/FIMsrc/w3/w3fp10.f deleted file mode 100644 index 4ec7cb1..0000000 --- a/src/fim/FIMsrc/w3/w3fp10.f +++ /dev/null @@ -1,714 +0,0 @@ - SUBROUTINE W3FP10(RDATA,KTBL,CNST,TITLE,KRECT,KCONTR, - & LINEV,IWIDTH) -C$$$ SUBROUTINE DOCUMENTATION BLOCK *** -C -C SUBROUTINE: W3FP10 PRINTER CONTOUR SUBROUTINE -C PRGMMR: JONES ORG: NMC421 DATE:89-09-13 -C -C ABSTRACT: PRINTS A TWO-DIMENSIONAL GRID OF ANY SHAPE, WITH -C CONTOURING, IF DESIRED. GRID VALUES ARE SCALED ACCORDING TO -C TO CONSTANTS SPECIFIED BY THE PROGRAMER, ROUNDED, AND PRINTED -C AS 4,3, OR 2 DIGIT INTEGERS WITH SIGN, THE SIGN MARKING THE -C GRID POSITION OF THE PRINTED NUMBER. IF CONTOURING IS REQUESTED, -C BESSEL'S INTERPOLATION FORMULA IS USED TO OPTAIN THE CONTOUR LINES. -C CONTOURS ARE INDICATED BY ALPHABETIC CHARACTERS RANGING FROM A TO -C H OR NUMERIC CHARACTERS FROM 0 TO 9. CONTOUR ORIGIN AND INTERVAL -C ARE SPECIFIED BY THE PROGRAMMER IN TERMS OF PRINTED VALUES. -C -C PROGRAM HISTORY LOG: -C 89-09-08 R.E.JONES -C 92-05-02 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN, ADD SAVE. -C -C USAGE: CALL W3FP10 (RDATA,KTBL,CNST,TITLE,KRECT,KCONTR,LINEV,IWIDTH) -C INPUT ARGUMENTS: RDATA = REAL ARRAY OF GRID DATA TO BE PRINTED. -C KTBL = INTEGER ARRAY WITH SHAPE OF ARRAY. -C CNST = REAL ARRAY OF FOUR ELEMENTS, USED IN -C SCALING FOR PRINTING AND CONTOURING. -C TITLE = IS A ARRAY OF 132 CHARACTERS OR LESS OF -C HOLLERITH DATA, 1ST CHAR. MUST BE BLANK. -C PRINTED AT BOTTOM OF THE MAP. -C KRECT = 1 IF GRID IS RECTANGULAR, 0 OTHERWISE. -C KCONTR = 1 FOR CONTOURING , 0 OTHERWISE. -C LINEV = 0 IS FOR 6 LINES PER VERTICAL INCH, -C NON-ZERO 8 LINES PER VERTICAL INCH. -C IWIDTH = NUMBER OF CHARACTERS IN PRINT LINE, -C 132 IS STANDARD PRINTER. -C -C INPUT FILES: NONE -C -C -C OUTPUT ARGUMENTS: NONE -C -C OUTPUT FILES: STANDARD FORTRAN PRINT FILE -C -C -C RETURN CONDITIONS: NORMAL SUBROUTINE RETURN, UNLESS NUMBER -C OF ROWS IS GREATER THAN 200, PRINTS ERROR -C MESSAGE AND EXITS. -C -C SUBPROGRAMS CALLED: -C UNIQUE : NONE -C -C LIBRARY: MIN0 , FORTRAN FUNCTION , RETURNS SMALLER VALUE -C IABS , MOD -C -C REMARKS: SPECIAL VERSION OF W3FP05, 1ST POINT IS UPPER LEFT HAND -C CORNER. WRITTEN ON REQUEST OF PETER CHASE BECAUSE SOME -C GRIB FIELDS CAN START WITH THE UPPER LEFT HAND CORNER -C AS THE 1ST POINT OF A GRID. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - REAL CNST(4) - REAL RDATA(*) - REAL RWA(28) - REAL RWB(28) - REAL RWC(28) - REAL RWD(28) - REAL VDJA(29) - REAL VDJB(28) - REAL VDJC(28) -C - INTEGER TITLE(33) - INTEGER KRLOC(200) - INTEGER KTBL(*) - INTEGER OUTPUT - INTEGER PAGNL - INTEGER PAGNR - INTEGER PAGN3 - INTEGER PCCNT - INTEGER PCFST - INTEGER PGCNT - INTEGER PGCNTA - INTEGER PGFST - INTEGER PGFSTA - INTEGER PGMAX -C - LOGICAL DONE - LOGICAL LCNTR - LOGICAL RECT -C - CHARACTER*1 KALFA(16) - CHARACTER*1 KALPH(20) - CHARACTER*1 KHASTR - CHARACTER*1 KHBLNK - CHARACTER*1 KHDOLR - CHARACTER*1 KHMNS - CHARACTER*1 KHPLUS - CHARACTER*1 KHRSTR - CHARACTER*1 KHTBL(10) - CHARACTER*1 KLINE(126) - CHARACTER*1 KLINES(132) - CHARACTER*1 KNUMB(20) -C - EQUIVALENCE (CRMX,VDJA(29)) - EQUIVALENCE (KLINE(1),KLINES(8)) - EQUIVALENCE (VDJC(1),RWA(1)) -C -C ... THE VALUE CRMX IS MACHINE DEPENDENT, IT SHOULD BE -C ... SET TO A VALUE A LITTLE LESS THAN THE LARGEST POSITIVE -C ... FLOATING POINT NUMBER FOR THE COMPUTER. -C - SAVE -C -C DATA CRMX /10.E70/ JFM commented out and set to HUGE below - DATA KALFA /'A',' ','B',' ','C',' ','D',' ','E',' ','F', - & ' ','G',' ','H',' '/ - DATA KHASTR/'*'/ - DATA KHBLNK/' '/ - DATA KHDOLR/'$'/ - DATA KHMNS /'-'/ - DATA KHPLUS/'+'/ - DATA KHRSTR/'1'/ - DATA KHTBL /'0','1','2','3','4','5','6','7','8','9'/ -C -C ... LIMNRW IS LIMIT ON NUMBER OF ROWS ALLOWED -C ... AND IS DIMENSION OF KRLOC ... -C - DATA LIMNRW/200/ - DATA KNUMB /'0',' ','1',' ','2',' ','3',' ','4',' ', - & '5',' ','6',' ','7',' ','8',' ','9',' '/ - DATA OUTPUT/6/ - DATA R5 /.2/ - DATA R50 /.02/ -C - 8000 FORMAT (1H0,10X,44HERROR FROM W3FP10 ... NUMBER OF ROWS IN YOUR, - & 9H ARRAY = ,I4,24H WHICH EXCEEDS LIMIT OF ,I4) - 8100 FORMAT ( 1HT) - 8200 FORMAT ( 1HS) - 8300 FORMAT ( 1H ,/,1H ,/,1H ) - 8400 FORMAT ( 1H ,/,1H ) - 8500 FORMAT ( 132A1) - 8600 FORMAT ( 33A4) -C -C COMPUTE VALUES FOR PRINTER WIDTH -C - CRMX = huge(CRMX) !JFM - IF (IWIDTH.GE.132.OR.IWIDTH.LE.0) PGMAX = 25 - IF (IWIDTH.GE.1.AND.IWIDTH.LE.22) PGMAX = 3 - IF (IWIDTH.GT.22.AND.IWIDTH.LT.132) PGMAX = (IWIDTH-7) / 5 - LW = (PGMAX * 5 + 7) / 4 - PAGN3 = PGMAX + 3 - VDJA(PAGN3+1) = CRMX - MXPG = PGMAX * 5 + 7 -C - IF (LINEV .NE. 0) THEN -C -C ...OTHERWISE LINEV IS NON-ZERO, SO 8 LINES/INCH IS DESIRED... -C - LINATE = 1 - R4 = 0.250 - R32 = 0.03125 - CON2 = 10.0 - NBTWN = 3 -C - ELSE -C - LINATE = 2 - R4 = 0.33333333 - R32 = 1.0 / 18.0 - CON2 = 6.0 - NBTWN = 2 - ENDIF -C - PGCNTA = 0 - PGFSTA = 0 - RECT = .FALSE. - DONE = .FALSE. - KZ = 0 - KZA = 1000 - A = CNST(1) - KCA = 2 * (1 - KRECT) -C -C TO SET NO. OF DIGITS TO BE PRINTED -C WHICH IS A FUNCTION OF THE TENS POSITION IN KCONTR -C - NODIG = IABS(KCONTR/10) - NODIG = 3 - NODIG -C -C WHERE C(NODIG) + 1 IS NO. OF DIGITS TO BE PRINTED -C - IF (NODIG.LT.1 .OR. NODIG.GT.3) NODIG = 3 -C -C ANY OUT-OF-RANGE WILL GET 4 DIGITS -C - LCNTR = .FALSE. - NCONQ = IABS(MOD(KCONTR,10)) - IF (NCONQ .EQ. 0) GO TO 400 - IF (NCONQ .LE. 2) GO TO 300 -C -C OTHERWISE RESET NCONQ -C - NCONQ = 0 - GO TO 400 -C - 300 CONTINUE - LCNTR = .TRUE. -C -C WITH NCONQ = 1 FOR LETTERS,AND = 2 FOR NUMBERS IN CONTOUR BANDS -C - 400 CONTINUE - IF (NCONQ .NE. 2) THEN -C -C OTHERWISE SET AS LETTERS -C - KCOW = 16 - DO 500 J = 1,KCOW - KALPH(J) = KALFA(J) - 500 CONTINUE -C - ELSE -C - KCOW = 20 - DO 700 J = 1,KCOW - KALPH(J) = KNUMB(J) - 700 CONTINUE -C - ENDIF -C - RADJ = 4 * KCOW - KD = 1 -C -C *** SET UP TABLE OF INDICES CORRESPONDING TO FIRST ITEM IN EACH ROW -C *** THIS IS KRLOC -C *** PICK OUT SIZE AND ROW NUMBER OF LARGEST ROW (KCMX AND KCLMX) -C *** KZA LEFT-JUSTIFIES MAP IF ALL ROWS HAVE COMMON MINIMAL OFFSET -C - IF (KTBL(1 ).NE.(-1)) THEN -C -C *** ONE-DIMENSIONAL FORM -C - KTF = 3 - KZA = 0 - IMIN = KTBL(2) - JMIN = KTBL(3) - JMAX = KTBL(3) + KTBL(1) - 1 - NRWS = KTBL(1) - IF (NRWS .GT. LIMNRW) THEN - WRITE (OUTPUT,8000) NRWS , LIMNRW - RETURN - ENDIF - KC = 1 -C - DO 1000 J = 1,NRWS - KRLOC(J) = KD - IF (KTBL(KC+4) + KTBL(KC+3).LE.KZ ) GO TO 900 - KCLMX = J - IMAX = KTBL(KC+4) + KTBL(KC+3) - KZ = IMAX - KCMX = KRLOC(J) + KTBL(KC+4) - 900 CONTINUE - KD = KD + KTBL(KC+4) - KC = KC + KCA - 1000 CONTINUE -C - ELSE -C -C *** TWO-DIMENSIONAL FORM -C *** THE TWO-DIMENSIONAL FORM IS COMPILER-DEPENDENT -C *** IT DEPENDS ON THE TWO-DIMENSIONAL ARRAY BEING STORED COLUMN-WISE -C *** THAT IS, WITH THE FIRST INDEX VARYING THE FASTEST -C - IMIN = KTBL(6) - JMIN = KTBL(7) - NRWS = KTBL(5) - IF (NRWS .GT. LIMNRW) THEN - WRITE (OUTPUT,8000) NRWS , LIMNRW - RETURN - ENDIF -C - JMAX = KTBL(7) + KTBL(5) -1 - KC = 1 - DO 1500 J = 1,NRWS - KRLOC(J) = KTBL(2) * (KTBL(4)-NRWS+J-1) + KTBL(KC+7) + 1 - IF (KTBL(KC+7) + KTBL(KC+8).LE.KZ) GO TO 1400 - IMAX = KTBL(KC+7) + KTBL(KC+8) - KZ = IMAX - KCMX = KRLOC(J) + KTBL(KC+8) - KCLMX = J - 1400 CONTINUE - IF (KTBL(KC+7).LT.KZA) KZA = KTBL(KC+7) - KC = KC + KCA - 1500 CONTINUE - IMAX = IMAX - KZA - KTF = 7 - ENDIF -C - PAGNL = 0 - PAGNR = PGMAX - IF (.NOT.LCNTR) GO TO 1700 - ADC = (CNST(1) - CNST(4)) / CNST(3) + RADJ - BC = CNST(2) / CNST(3) -C -C *** PRINT I-LABELS ACROSS TOP OF MAP -C - 1700 CONTINUE -C -C *** WHICH PREPARES CDC512 PRINTER FOR 8 LINES PER INCH -C - IF (LINATE.EQ.1) WRITE (OUTPUT,8100) -C -C ...WHICH PREPARES PRINTER FOR 6 LINES PER INCH -C - IF (LINATE.EQ.2) WRITE (OUTPUT,8200) - KLINES(1) = KHRSTR - KBR = 1 - GO TO 6900 -C - 1800 CONTINUE - IF (.NOT.LCNTR) GO TO 2000 -C -C *** INITIALIZE CONTOUR WORKING AREA -C - DO 1900 J = 1,PAGN3 - RWC(J) = CRMX - RWD(J) = CRMX - 1900 CONTINUE -C -C *** SET UP CONTOUR DATA AND PAGE LIMITERS FOR FIRST TWO ROWS -C - 2000 CONTINUE - KRA = 1 - KC = KTF + 1 - KBR = 2 - GO TO 5900 -C - 2100 CONTINUE - KRA = 2 - KC = KC + KCA - KBR = 3 - GO TO 5900 -C - 2200 CONTINUE - KR = 0 -C -C *** TEST IF THIS IS LAST PAGE -C - IF (IMAX.GT.PGMAX-1) GO TO 2300 - LMR = IMAX * 5 + 2 - DONE = .TRUE. -C -C *** DO LEFT J-LABELS -C - 2300 CONTINUE - JCURR = JMIN -C - 2400 CONTINUE - KR = KR + 1 - KRA = KR + 2 - KC = KC + KCA - KTA = MOD(JCURR,10) - KTB = MOD(JCURR,100)/10 - KTC = MOD(JCURR,1000)/100 - IF (KR .EQ. 1 .OR. (.NOT. LCNTR)) GO TO 2500 - GO TO 2600 -C - 2500 CONTINUE - IF (LINATE.EQ.1) WRITE (OUTPUT,8300) - IF (LINATE.EQ.2) WRITE (OUTPUT,8400) -C - 2600 CONTINUE - KLINES(2) = KHPLUS - KLINES(1) = KHBLNK - IF (JCURR.LT.0) KLINES(2) = KHMNS - KTA = IABS(KTA) - KTB = IABS(KTB) - KTC = IABS(KTC) - IF (KTC .EQ. 0) GO TO 2700 - KLINES(3) = KHTBL(KTC+1) - KLINES(4) = KHTBL(KTB+1) - KLINES(5) = KHTBL(KTA+1) - GO TO 2800 -C - 2700 CONTINUE - KLINES(3) = KHTBL(KTB+1) - KLINES(4) = KHTBL(KTA+1) - KLINES(5) = KHBLNK -C - 2800 CONTINUE - DO 2900 J = 6,MXPG - KLINES(J) = KHBLNK - 2900 CONTINUE - IF (.NOT.DONE) GO TO 3000 -C -C *** DO RIGHT J-LABELS IF LAST PAGE OF MAP -C - KLINE(LMR) = KLINES(2) - KLINE(LMR+1) = KLINES(3) - KLINE(LMR+2) = KLINES(4) - KLINE(LMR+3) = KLINES(5) -C -C *** FETCH AND CONVERT GRID VALUES TO A1 FORMAT FOR WHOLE LINE -C - 3000 CONTINUE - KRX = KRLOC(KR) - KLX = 5 * PGFST + 1 - IF (PGCNT.EQ.0) GO TO 4000 - DO 3800 KK = 1,PGCNT - TEMP = RDATA(KRX) * CNST(2) + A - KTEMP = ABS(TEMP) + 0.5 - KLINE(KLX) = KHPLUS - IF (TEMP.LT.0.0) KLINE(KLX) = KHMNS - GO TO (3300,3200,3100),NODIG - 3100 CONTINUE - KTA = MOD(KTEMP,10000)/1000 -C - 3200 CONTINUE - KTB = MOD(KTEMP,1000)/100 -C - 3300 CONTINUE - KTC = MOD(KTEMP,100)/10 - KTD = MOD(KTEMP,10) - GO TO (3400,3500,3600),NODIG -C - 3400 CONTINUE - KLINE(KLX+1) = KHTBL(KTC+1) - KLINE(KLX+2) = KHTBL(KTD+1) - GO TO 3700 -C - 3500 CONTINUE - KLINE(KLX+1) = KHTBL(KTB+1) - KLINE(KLX+2) = KHTBL(KTC+1) - KLINE(KLX+3) = KHTBL(KTD+1) - GO TO 3700 -C - 3600 CONTINUE - KLINE(KLX+1) = KHTBL(KTA+1) - KLINE(KLX+2) = KHTBL(KTB+1) - KLINE(KLX+3) = KHTBL(KTC+1) - KLINE(KLX+4) = KHTBL(KTD+1) -C - 3700 CONTINUE - KLX = KLX + 5 - KRX = KRX + 1 - 3800 CONTINUE -C -C *** FOLLOWING CHECKS FOR POLE POINT AND INSERTS PROPER CHARACTER. -C - IF (JCURR.NE.0) GO TO 4000 - IF (IMIN.LT.(-25).OR.IMIN.GT.0) GO TO 4000 - KX = -IMIN - IF (KX.LT.PGFST.AND.KX.GT.PGCNT+PGFST) GO TO 4000 - KX = 5 * KX - IF (KLINE(KX+1).EQ.KHMNS) GO TO 3900 - KLINE(KX) = KHDOLR - GO TO 4000 -C - 3900 CONTINUE - KLINE(KX+1) = KHASTR -C -C *** PRINT LINE OF MAP DATA -C - 4000 CONTINUE - WRITE (OUTPUT,8500) (KLINES(II),II=1,MXPG) - KRLOC(KR) = KRX - JCURR = JCURR + 1 -C JCURR = JCURR + JRWMP -C -C *** TEST BOTTOM OF MAP -C - IF (KR.EQ.NRWS) GO TO 5700 -C -C *** SET UP CONTOUR DATA AND PAGE LIMITERS FOR NEXT ROW -C - KBR = 4 - GO TO 5900 -C - 4100 CONTINUE - IF (.NOT.LCNTR) GO TO 2400 -C -C *** DO CONTOURING -C - DO 4200 JJ = 1,MXPG - KLINES(JJ) = KHBLNK - 4200 CONTINUE -C -C *** VERTICAL INTERPOLATIONS -C - DO 4700 KK = 1,PAGN3 - IF (RWB(KK).LT.CRMX.AND.RWC(KK).LT.CRMX) GO TO 4300 - VDJB(KK) = CRMX - VDJC(KK) = CRMX - GO TO 4600 -C - 4300 CONTINUE - IF (RWA(KK).LT.CRMX.AND.RWD(KK).LT.CRMX) GO TO 4400 - VDJC(KK) = 0. - GO TO 4500 -C - 4400 CONTINUE - VDJC(KK) = R32*(RWA(KK)+RWD(KK)-RWB(KK)-RWC(KK)) -C - 4500 CONTINUE - VDJB(KK) = R4*(RWC(KK)-RWB(KK)-CON2*VDJC(KK)) -C - 4600 CONTINUE - VDJA(KK)=RWB(KK) -C - 4700 CONTINUE -C -C ...DO 2 OR 3 ROWS OF CONTOURING BETWEEN GRID ROWS... -C - DO 5600 LL = 1,NBTWN - DO 4800 KK = 1,PAGN3 - VDJB(KK) = VDJC(KK) + VDJB(KK) - VDJA(KK) = VDJB(KK) + VDJA(KK) - 4800 CONTINUE -C -C ...WHERE VDJA HAS THE INTERPOLATED VALUE FOR THIS INTER-ROW -C *** HORIZONTAL INTERPOLATIONS -C - HDC = 0.0 - IF (VDJA(1).GE.CRMX) GO TO 4900 - HDC = R50*(VDJA(4)+VDJA(1)-VDJA(2)-VDJA(3)) -C - 4900 CONTINUE - KXB = 0 - DO 5200 KK = 1,PGMAX - IF (VDJA(KK+1).GE.CRMX) GO TO 5100 - HDA = VDJA(KK+1) - IF (VDJA(KK+2).GE.CRMX) GO TO 5500 - IF (VDJA(KK+3).GE.CRMX) HDC = 0.0 - HDB = R5 * (VDJA(KK+2) - VDJA(KK+1) - 15.0 * HDC) -C -C *** COMPUTE AND STORE CONTOUR CHARACTERS, 5 PER POINT -C - KHDA = HDA - KDB = IABS(MOD(KHDA,KCOW)) - KLINE(KXB+1) = KALPH(KDB+1) - DO 5000 JJ = 2,5 - HDB = HDB + HDC - HDA = HDA + HDB - KHDA = HDA - KDB = IABS(MOD(KHDA,KCOW)) - KXA = KXB + JJ - KLINE(KXA) = KALPH(KDB+1) - 5000 CONTINUE - HDC = R50*(VDJA(KK+4)+VDJA(KK+1)-VDJA(KK+2)-VDJA(KK+3)) - IF (VDJA(KK+4).GE.CRMX) HDC = 0.0 -C - 5100 CONTINUE - KXB = KXB + 5 -C - 5200 CONTINUE -C - 5300 CONTINUE - WRITE (OUTPUT,8500) (KLINES(II),II=1,MXPG) - DO 5400 KK = 1,MXPG - KLINES(KK) = KHBLNK - 5400 CONTINUE - GO TO 5600 -C - 5500 CONTINUE - KHDA = HDA - KDB = IABS(MOD(KHDA,KCOW)) - KLINE(KXB+1) = KALPH(KDB+1) - GO TO 5300 -C - 5600 CONTINUE - GO TO 2400 -C - 5700 CONTINUE - IF (LINATE.EQ.1) WRITE (OUTPUT,8300) - IF (LINATE.EQ.2) WRITE (OUTPUT,8400) - KLINES(1) = KHBLNK -C -C *** PRINT I-LABELS ACROSS BOTTOM OF PAGE -C - KBR = 5 - GO TO 6900 -C - 5800 CONTINUE - IF (LINATE.EQ.1) WRITE (OUTPUT,8300) - IF (LINATE.EQ.2) WRITE (OUTPUT,8400) -C -C *** PRINT TITLE -C - WRITE (OUTPUT,8600) (TITLE(II),II=1,LW) -C -C *** TEST END OF MAP -C - IF (KRLOC(KCLMX).EQ.KCMX) RETURN -C -C *** ADJUST PAGE LINE BOUNDARIES -C - IF (IMAX.GT.PGMAX) IMAX = IMAX - PGMAX - IMIN = KA - PAGNL = PAGNL + PGMAX - PAGNR = PAGNR + PGMAX - GO TO 1700 -C -C *** ROUTINE TO PRE-STORE ROWS FOR CONTOURING AND COMPUTE LINE LIMITERS -C - 5900 CONTINUE - PGFST = PGFSTA - PGCNT = PGCNTA - IF (KRA.GT.NRWS) GO TO 6800 - KRFST = KTBL(KC) - KZA - KRCNT = KTBL(KC+1) - KFX = KRLOC(KRA) - IF (RECT) GO TO 6100 - IF (KRFST-PAGNL.LE.(-1)) GO TO 6400 - PCFST = KRFST - PAGNL + 1 - IF (PCFST.GE.PAGN3) GO TO 6700 - PGFSTA = PCFST-1 - PCCNT = MIN0(PAGNR-KRFST+2,KRCNT) - IF (PGFSTA.EQ.0) GO TO 6600 - PGCNTA = MIN0(PAGNR-KRFST,KRCNT) - IF (PGCNTA.GT.0) GO TO 6000 - PGCNTA = 0 - GO TO 6100 -C - 6000 CONTINUE - RECT = KRECT.EQ.1.AND.PGCNTA.LE.KRCNT -C - 6100 CONTINUE - IF (.NOT.LCNTR) GO TO (1800,2100,2200,4100,5800) KBR - DO 6200 KK = 1,PAGN3 - RWA(KK) = RWB(KK) - RWB(KK) = RWC(KK) - RWC(KK) = RWD(KK) - RWD(KK) = CRMX - 6200 CONTINUE -C - IF (PCCNT.EQ.0) GO TO (1800,2100,2200,4100,5800) KBR - KPC = PCFST + 1 - DO 6300 KK = 1,PCCNT - RWD(KPC) = RDATA(KFX) * BC + ADC - KFX = KFX + 1 - KPC = KPC + 1 - 6300 CONTINUE - GO TO (1800,2100,2200,4100,5800) KBR -C - 6400 CONTINUE - PCFST = 0 - PGFSTA = 0 - KFX = KFX - 1 - PCCNT = KRFST + KRCNT - PAGNL + 1 - IF (PCCNT.LT.PAGN3) GO TO 6500 - PCCNT = PAGN3 - PGCNTA = PGMAX - GO TO 6100 -C - 6500 CONTINUE - IF (PCCNT.GT.0) GO TO 6600 - PGCNTA = 0 - PCCNT = 0 - GO TO 6100 -C - 6600 CONTINUE - PGCNTA = MIN0(PGMAX,KRCNT+KRFST-PAGNL) - GO TO 6100 -C - 6700 CONTINUE - PGCNTA = 0 -C - 6800 CONTINUE - PCCNT = 0 - GO TO 6100 -C -C *** ROUTINE TO PRINT I-LABELS -C - 6900 CONTINUE - DO 7000 KK = 2,MXPG - KLINES(KK) = KHBLNK - 7000 CONTINUE -C - KK = 1 - KA = IMIN - LBL = MIN0(IMAX,PGMAX) -C - DO 7300 JJ = 1,LBL - KLINE(KK) = KHPLUS - IF (KA.LT.0) KLINE(KK) = KHMNS - KTA = IABS(MOD(KA,100)) / 10 - KTB = IABS(MOD(KA,10)) - KTC = IABS(MOD(KA,1000)) / 100 - IF (KTC .EQ. 0) GO TO 7100 - KLINE(KK+1) = KHTBL(KTC+1) - KLINE(KK+2) = KHTBL(KTA+1) - KLINE(KK+3) = KHTBL(KTB+1) - GO TO 7200 -C - 7100 CONTINUE - KLINE(KK+1) = KHTBL(KTA+1) - KLINE(KK+2) = KHTBL(KTB+1) -C - 7200 CONTINUE - KK = KK + 5 - KA = KA + 1 -C - 7300 CONTINUE -C - WRITE (OUTPUT,8500) (KLINES(II),II=1,MXPG) -C - GO TO (1800,2100,2200,4100,5800) KBR -C - 7400 CONTINUE - RETURN -C - END diff --git a/src/fim/FIMsrc/w3/w3fp11.f b/src/fim/FIMsrc/w3/w3fp11.f deleted file mode 100644 index 27aa3bf..0000000 --- a/src/fim/FIMsrc/w3/w3fp11.f +++ /dev/null @@ -1,762 +0,0 @@ - SUBROUTINE W3FP11 (IPDS0, IPDS, TITL, IERR) -C SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FP11 ONE-LINE GRIB TITLER FROM PDS SECTION -C PRGMMR: MCCLEES ORG: NMC421 DATE:88-02-02 -C -C ABSTRACT: CONVERTS GRIB FORMATTED PRODUCT DEFINITION SECTION VERSION -C 1 TO A ONE LINE READABLE TITLE. GRIB SECTION 0 IS ALSO TESTED TO -C VERIFY THAT GRIB DATA IS BEING DECIPHERED. -C -C PROGRAM HISTORY LOG: -C 91-06-19 R.E.JONES -C 92-05-29 R.E.JONES ADD WATER TEMP TO TABLES -C 93-01-19 R.E.JONES ADD MONTGOMARY STREAM FUNCTION TO TABLES -C ADD CODE FOR SURFACE VALUE 113. -C ADD CONDENSATION PRESSURE TO TABLES -C 93-02-19 R.E.JONES ADD CAPE AND TKE (157 & 158) TO TABLES -C 93-02-24 R.E.JONES ADD GRIB TYPE PMSLE (130) TO TABLES -C 93-03-26 R.E.JONES ADD GRIB TYPE SGLYR (175) TO TABLES -C 93-03-27 R.E.JONES CHANGES FOR REVISED O.N.388 MAR. 3,1993 -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C 93-04-16 R.E.JONES ADD GRIB TYPE LAT, LON (176,177) TO TABLES -C 93-04-25 R.E.JONES ADD GRIB TYPE 204, 205, 211, 212, 218 -C 93-05-18 R.E.JONES ADD TEST FOR MODEL 70 -C 93-06-26 R.E.JONES ADD GRIB TYPE 128, 129, TAKE OUT TEST FOR -C MODEL 86. -C 93-08-07 R.E.JONES ADD GRIB TYPE 156 (CIN), 150 (CBMZW), -C 151 (CBTZW), 152 (CBTMW) TO TABLES. -C 93-10-14 R.E.JONES CHANGE FOR O.N. 388 REV. OCT. 8,1993 -C 93-10-29 R.E.JONES CHANGE FOR 'L CDC' 'M CDC' 'H CDC' -C 93-10-14 R.E.JONES CHANGE FOR O.N. 388 REV. NOV. 19,1993 -C 94-02-05 R.E.JONES CHANGE FOR O.N. 388 REV. DEC. 14,1993 -C ADD MODEL NUMBER 86 AND 87. -C 94-03-24 R.E.JONES ADD GRIB TYPE 24 (TOTO3), 206 (UVPI) -C 94-06-04 R.E.JONES CHANGE UVPI TO UVI -C 94-06-16 R.E.JONES ADD GRIB TYPE 144,145,146,147,148,149 -C SOILW,PEVPR,CWORK,U-GWD,V-GWD,PV TO TABLES. -C 94-06-22 R.E.JONES ADD NCAR (60) TO CENTERS -C 94-07-25 R.E.JONES CORRECTION FOR 71, 72, 213 (T CDC), (CDCON), -C (CDLYR) -C 94-10-27 R.E.JONES ADD GRIB TYPE 191 (PROB), 192 (PROBN), ADD -C TEST FOR MODEL 90, 91, 92, 93, ADD SUB -C CENTER 2. -C 95-02-09 R.E.JONES CORRECTION FOR CENTURY FOR FNOC -C 95-04-11 R.E.JONES CORRECTION FOR LMH AND LMV -C 95-06-20 R.E.JONES ADD GRIB TYPE 189 (VSTM), 190 (HLCY), 193 -C (POP), 194 (CPOFP), 195 (CPOZP), 196 -C (USTM), 197 (VSTM) TO TABLES. -C 95-08-07 R.E.JONES ADD GRIB TYPE 153 (CLWMR), 154 (O3MR), 221 -C (HPBL), 237 (O3TOT). -C 95-09-07 R.E.JONES TAKE OUT GRIB TYPE 24 (TOTO3), CHANGE TO -C GRIB TYPE 10 (TOZNE). ADD LEVEL 117, -C POTENTIAL VORTITICITY (pv) LEVEL, ADD ETA -C LEVEL 119, ADD 120 LAYER BETWWEN TWO ETA -C LEVELS. CHANGE NAME OF LEVEL 107 TO (SIGL), -C CHANGE NAME OF LEVEL 108 TO (SIGY). -C 95-09-26 R.E.JONES ADD LEVEL 204 (HTFL) HIGHEST TROPSPHERE -C FREEZING LEVEL. -C 95-10-19 R.E.JONES CHANGE SOME OF THE LEVEL ABREVIATIONS. -C 95-12-13 R.E.JONES ADD 8 SUB-CENTERS TO TABLES -C 96-03-04 R.E.JONES CHANGES FOR O.N. 388 JAN 2, 1996 -C 96-03-22 R.E.JONES CHANGE SCUSF TO CSUSF -C 96-10-01 IREDELL RECOGNIZE FORECAST TIME UNITS 1 TO 12 -C AND CORRECT FOR YEAR 2000 -C 96-10-31 R.E.JONES CHANGE ARRAY AND TABLE FOR ICS1 TO 10. -C 96-10-01 IREDELL ALLOW PARAMETER TABLE VERSION UP TO 127 -C 98-05-26 Gilbert ADDED 17 NEW PARAMETERS ( GRIB TABLE 2 ) -C ADDED 6 NEW SPECIAL LEVELS FOR CLOUDS -C ADDED SUBCENTER 11 (TDL) UNDER CENTER 7 (NCEP) -C 98-12-21 Gilbert REPLACED FUNCTION ICHAR WITH MOVA2I. -C 01-01-05 VUONG ADD LEVEL 247 (EHLT) EQUILIBRIUM LEVEL -C 02-05-01 VUONG CHANGES FOR O.N. 388 MAR 21, 2002 -C 02-03-25 VUONG ADD GRIB TABLE VERSION 129 AND 130 -C 03-07-02 Gilbert Added 5 new params to Table version 129 -C 04-14-04 VUONG ADD GRIB TABLE VERSION 131 AND ADDED 12 -C NEW PARAMETER TO TABLE VERSION 129 -C 04-08-09 VUONG ADD PARAMETER (THFLX) TO TABLE VERSION 129 -C 05-02-08 COOKE CORRECTED ENTRY FOR FREEZING RAIN, CRFZR TO -C CFRZR IN THE HHNAM1 ARRAY -C 06-08-11 VUONG ADD LEVELS (235,236,237,238,240,245) AND ADDED -C NEW PARAMETERS TO TABLE VERSION 129 AND ADDED -C ONE PARAMETER 154 TO TABLE VERSION 130 AND -C ADDED TABLE VERSION 128 -C -C USAGE: CALL W3FP11 (IPDS0, IPDS, TITL, IERR ) -C INPUT ARGUMENT LIST: -C IPDS0 - GRIB SECTION 0 READ AS CHARACTER*8 -C IPDS - GRIB PDS SECTION READ AS CHARACTER*28 -C -C OUTPUT ARGUMENT LIST: -C TITL - CHARACTER*86 OUTPUT PRINT LINE -C IERR 0 - COMPLETED SATISFACTORILY -C 1 - GRIB SECTION 0, CAN NOT FIND 'GRIB' -C 2 - GRIB IS NOT VERSION 1 -C 3 - LENGTH OF PDS SECTION IS LESS THAN 28 -C 4 - COULD NOT MATCH TYPE INDICATOR -C 5 - COULD NOT MATCH TYPE LEVEL -C 6 - COULD NOT INTERPRET ORIGINATOR OF CODE -C 7 - COULD NOT INTERPRET SUB CENTER 7 ORIGINATOR OF CODE -C 8 - COULD NOT INTERPRET SUB CENTER 9 ORIGINATOR OF CODE -C 9 - PARAMETER TABLE VERSION NOT 1 OR 2 -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM RS/6000 -C - INTEGER CENTER(15) - INTEGER SCNTR1(15) - INTEGER SCNTR2(14) - INTEGER FCSTIM - INTEGER HH(252) - INTEGER HH1(105) - INTEGER HH2(105) - INTEGER HH3(42) - INTEGER HH128(50) - INTEGER HH129(69) - INTEGER HH130(75) - INTEGER HH131(241) - INTEGER HHH(71) - INTEGER IERR - INTEGER P1 - INTEGER P2 - INTEGER TIMERG -C - CHARACTER * 6 HHNAM(252) - CHARACTER * 6 HHNAM1(105) - CHARACTER * 6 HHNAM2(105) - CHARACTER * 6 HHNAM3(42) - CHARACTER * 6 HHNAM128(50) - CHARACTER * 6 HHNAM129(69) - CHARACTER * 6 HHNAM130(75) - CHARACTER * 6 HHNAM131(241) - CHARACTER * 4 HHHNAM(71) - CHARACTER * (*) IPDS - CHARACTER * 8 IPDS0 - CHARACTER * 28 IDPDS - CHARACTER * 4 GRIB - CHARACTER * 28 KNAM1(15) - CHARACTER * 28 KNAM2(16) - CHARACTER * 28 KNAM3(14) - CHARACTER * 3 MONTH(12) - CHARACTER * 4 TIMUN(12) - CHARACTER * 2 TIMUN1(12) - CHARACTER * 86 TITL -C - EQUIVALENCE (HH(1),HH1(1)) - EQUIVALENCE (HH(106),HH2(1)) - EQUIVALENCE (HH(211),HH3(1)) - EQUIVALENCE (HHNAM(1),HHNAM1(1)) - EQUIVALENCE (HHNAM(106),HHNAM2(1)) - EQUIVALENCE (HHNAM(211),HHNAM3(1)) -C - SAVE -C - DATA CENTER/ 7, 8, 9, 34, 52, 54, 57, - & 58, 59, 60, 74, 85, 97, 98, - & 99/ -C -C TABLE 3 TYPE AND VALUE OF LEVELS (PDS OCTETS 10, 11 AND 12) -C - DATA HHH / 1, 2, 3, 4, 5, 6, 7, - & 8, 9, 20, 100, 101, 102, 103, - & 104, 105, 106, 107, 108, 109, 110, - & 111, 112, 113, 114, 115, 116, 117, - & 119, 120, 121, 125, 126, 128, 141, - & 160, 200, 201, 204, 212, 213, 214, - & 222, 223, 224, 232, 233, 234, 209, - & 210, 211, 242, 243, 244, 246, 247, - & 206, 207, 248, 249, 251, 252, 235, - & 236, 237, 238, 215, 220, 239, 240, - & 245/ - DATA HHHNAM/'SFC ','CBL ','CTL ','0DEG','ADCL','MWSL','TRO ', - & 'NTAT','SEAB','TMPL','ISBL','ISBY','MSL ','GPML', - & 'GPMY','HTGL','HTGY','SIGL','SIGY','HYBL','HYBY', - & 'DBLL','DBLY','THEL','THEY','SPDL','SPDY','PVL ', - & 'ETAL','ETAY','IBYH','HGLH','ISBP','SGYH','IBYM', - & 'DBSL','EATM','EOCN','HTFL','LCBL','LCTL','LCY ', - & 'MCBL','MCTL','MCY ','HCBL','HCTL','HCY ','BCBL', - & 'BCTL','BCY ','CCBL','CCTL','CCY ','MTHE','EHLT', - & 'GCBL','GCTL','SCBL','SCTL','DCBL','DCTL','OITL', - & 'OLYR','OBML','OBIL','CEIL','PBLR','S26C','OMXL', - & 'LLTW'/ -C -C GRIB TABLE VERSION 2 (PDS OCTET 4 = 2) -C - DATA HH1 / - & 1, 2, 3, 5, 6, 7, 8, - & 9, 10, 11, 12, 13, 14, 15, - & 16, 17, 18, 19, 20, 21, 22, - & 23, 24, 25, 26, 27, 28, 29, - & 30, 31, 32, 33, 34, 35, 36, - & 37, 38, 39, 40, 41, 42, 43, - & 44, 45, 46, 47, 48, 49, 50, - & 51, 52, 53, 54, 55, 56, 57, - & 58, 59, 60, 61, 62, 63, 64, - & 65, 66, 67, 68, 69, 70, 71, - & 72, 73, 74, 75, 76, 77, 78, - & 79, 80, 81, 82, 83, 84, 85, - & 86, 87, 88, 89, 90, 91, 92, - & 93, 94, 95, 96, 97, 98, 99, - & 100, 101, 102, 103, 104, 105, 106/ - DATA HH2 / - & 107, 108, 109, 110, 111, 112, 113, - & 114, 115, 116, 117, 121, 122, 123, - & 124, 125, 126, 127, 128, 129, 130, - & 131, 132, 133, 134, 135, 136, 137, - & 138, 139, 140, 141, 142, 143, 144, - & 145, 146, 147, 148, 149, 150, 151, - & 152, 153, 154, 155, 156, 157, 158, - & 159, 160, 161, 162, 163, 164, 165, - & 166, 167, 168, 169, 172, 173, 174, - & 175, 176, 177, 181, 182, 183, 184, - & 189, 190, 191, 192, 193, 194, 195, - & 196, 197, 201, 204, 205, 206, 207, - & 208, 209, 211, 212, 213, 214, 215, - & 216, 217, 218, 219, 220 ,221, 222, - & 223, 226, 227, 228, 229, 231, 232/ - DATA HH3 / - & 233, 234, 235, 237, 238, 239, 241, - & 242, 243, 244, 245, 246, 247, 248, - & 249, 250, 251, 252, 253, 254, 255, - & 4, 118, 119, 120, 170, 171, 178, - & 179, 185, 186, 187, 198, 199, 200, - & 224, 225, 230, 180, 202, 210, 240/ - DATA HHNAM1/ - &' PRES ',' PRMSL',' PTEND',' ICAHT',' GP ',' HGT ',' DIST ', - &' HSTDV',' TOZNE',' TMP ',' VTMP ',' POT ',' EPOT ',' T MAX', - &' T MIN',' DPT ',' DEPR ',' LAPR ',' VIS ',' RDSP1',' RDSP2', - &' RDSP3',' PLI ',' TMP A',' PRESA',' GP A ',' WVSP1',' WVSP2', - &' WVSP3',' WDIR ',' WIND ',' U GRD',' V GRD',' STRM ',' V POT', - &' MNTSF',' SGCVV',' V VEL',' DZDT ',' ABS V',' ABS D',' REL V', - &' REL D',' VUCSH',' VVCSH',' DIR C',' SP C ',' UOGRD',' VOGRD', - &' SPF H',' R H ',' MIXR ',' P WAT',' VAPP ',' SAT D',' EVP ', - &' C ICE',' PRATE',' TSTM ',' A PCP',' NCPCP',' ACPCP',' SRWEQ', - &' WEASD',' SNO D',' MIXHT',' TTHDP',' MTHD ',' MTH A',' T CDC', - &' CDCON',' L CDC',' M CDC',' H CDC',' C WAT',' BLI ',' SNO C', - &' SNO L',' WTMP ',' LAND ',' DSL M',' SFC R',' ALBDO',' TSOIL', - &' SOILM',' VEG ',' SALTY',' DEN ',' WATR ',' ICE C',' ICETK', - &' DICED',' SICED',' U ICE',' V ICE',' ICE G',' ICE D',' SNO M', - &' HTSGW',' WVDIR',' WVHGT',' WVPER',' SWDIR',' SWELL',' SWPER'/ - DATA HHNAM2/ - &' DIRPW',' PERPW',' DIRSW',' PERSW',' NSWRS',' NLWRS',' NSWRT', - &' NLWRT',' LWAVR',' SWAVR',' G RAD',' LHTFL',' SHTFL',' BLYDP', - &' U FLX',' V FLX',' WMIXE',' IMG D',' MSLSA',' MSLMA',' MSLET', - &' LFT X',' 4LFTX',' K X ',' S X ',' MCONV',' VW SH',' TSLSA', - &' BVF2 ',' PV MW',' CRAIN',' CFRZR',' CICEP',' CSNOW',' SOILW', - &' PEVPR',' CWORK',' U-GWD',' V-GWD',' PV ',' COVMZ',' COVTZ', - &' COVTM',' CLWMR',' O3MR ',' GFLUX',' CIN ',' CAPE ',' TKE ', - &' CONDP',' CSUSF',' CSDSF',' CSULF',' CSDLF',' CFNSF',' CFNLF', - &' VBDSF',' VDDSF',' NBDSF',' NDDSF',' M FLX',' LMH ',' LMV ', - &' MLYNO',' NLAT ',' ELON ',' LPS X',' LPS Y',' HGT X',' HGT Y', - &' VPTMP',' HLCY ',' PROB ',' PROBN',' POP ',' CPOFP',' CPOZP', - &' USTM ',' VSTM ',' ICWAT',' DSWRF',' DLWRF',' UVI ',' MSTAV', - &' SFEXC',' MIXLY',' USWRF',' ULWRF',' CDLYR',' CPRAT',' TTDIA', - &' TTRAD',' TTPHY',' PREIX',' TSD1D',' NLGSP',' HPBL ',' 5WAVH', - &' CNWAT',' BMIXL',' AMIXL',' PEVAP',' SNOHF',' MFLUX',' DTRF '/ - DATA HHNAM3/ - &' UTRF ',' BGRUN',' SSRUN',' O3TOT',' SNOWC',' SNO T',' LRGHR', - &' CNVHR',' CNVMR',' SHAHR',' SHAMR',' VDFHR',' VDFUA',' VDFVA', - &' VDFMR',' SWHR ',' LWHR ',' CD ',' FRICV',' RI ',' MISS ', - &' PVORT',' BRTMP',' LWRAD',' SWRAD',' RWMR ',' SNMR ',' ICMR ', - &' GRMR ',' TURB ',' ICNG ',' LTNG ',' NCIP ',' EVBS ',' EVCW ', - &' SOTYP',' VGTYP',' 5WAVA',' GUST ',' CWDI ',' TRANS',' COVTW'/ -C -C GRIB TABLE VERSION 128 (PDS OCTET 4 = 128) -C ( OCEANGRAPHIC PARAMETER ) -C - DATA HH128/ - & 128, 129, 130, 131, 132, 135, 136, - & 137, 138, 139, 140, 141, 142, 143, - & 146, 147, 148, 149, 150, 155, 156, - & 157, 158, 159, 160, 161, 165, 170, - & 171, 172, 173, 175, 176, 177, 178, - & 179, 180, 181, 182, 183, 184, 185, - & 186, 187, 188, 190, 192, 193, 194, - & 254/ - DATA HHNAM128/ - &' ',' ',' ',' ',' ',' ',' ', - &' ',' ',' ',' ',' ',' ',' ', - &' ',' ',' ',' ',' ',' ',' ', - &' ',' ',' ',' ',' ',' ',' ', - &' ',' ',' ',' TMIX ',' ',' ',' ', - &' ',' ASHFL',' ASSFL',' BOTLD',' UBARO',' VBARO',' INTFD', - &' WTMPC',' SALIN',' EMNP ',' KENG ',' LAYTH',' SSTT ',' SSST ', - &' '/ -C -C GRIB TABLE VERSION 129 (PDS OCTET 4 = 129) -C - DATA HH129/ - & 128, 129, 131, 132, 133, 134, 135, - & 136, 137, 138, 139, 140, 141, 142, - & 143, 144, 145, 146, 147, 148, 149, - & 150, 151, 152, 153, 154, 155, 156, - & 157, 158, 159, 160, 161, 162, 163, - & 164, 165, 166, 167, 168, 169, 170, - & 171, 172, 173, 174, 175, 176, 177, - & 178, 180, 181, 182, 183, 184, 190, - & 191, 194, 195, 196, 197, 198, 199, - & 200, 201, 202, 210, 211, 212/ - DATA HHNAM129/ - &' PAOT ',' PAOP ',' FRAIN',' FICE ',' FRIME',' CUEFI',' TCOND', - &' TCOLW',' TCOLI',' TCOLR',' TCOLS',' TCOLC',' PLPL ',' HLPL ', - &' CEMS ',' COPD ',' PSIZ ',' TCWAT',' TCICE',' WDIF ',' WSTP ', - &' PTAN ',' PTNN ',' PTBN ',' PPAN ',' PPNN ',' PPBN ',' PMTC ', - &' PMTF ',' AETMP',' AEDPT',' AESPH',' AEUWD',' AEVWD',' LPMTF', - &' LIPMF',' REFZR',' REFZI',' REFZC',' TCLSW',' TCOLM',' ELRDI', - &' TSEC ',' TSECA',' NUM ',' AEPRS',' ICSEV',' ICPRB',' LAVNI', - &' HAVNI',' OZCON',' OZCAT',' VEDH ',' SIGV ',' EWGT ',' USCT ', - &' VSCT ',' TCHP ',' DBSS ',' ODHA ',' OHC ',' SSHG ',' SLTFL', - &' DUVB ',' CDUVB',' THFLX',' REFO ',' REFD ',' REFC '/ -C -C GRIB TABLE VERSION 130 (PDS OCTET 4 = 130) -C ( FOR LAND MODELING AND LAND DATA ASSIMILATION ) -C - DATA HH130/ - & 144, 145, 146, 147, 148, 149, 150, - & 151, 152, 154, 155, 156, 157, 158, - & 159, 160, 161, 162, 163, 164, 165, - & 166, 167, 168, 169, 170, 171, 172, - & 176, 177, 178, 179, 180, 181, 182, - & 183, 184, 187, 188, 198, 199, 200, - & 203, 204, 205, 207, 208, 210, 211, - & 212, 219, 220, 222, 223, 224, 225, - & 226, 227, 228, 229, 230, 231, 234, - & 235, 238, 239, 240, 246, 247, 248, - & 249, 252, 253, 254, 255/ - DATA HHNAM130/ - &' SOILW',' PEVPR',' VEGT ',' BARET',' AVSFT',' RADT ',' SSTOR', - &' LSOIL',' EWATR',' LSPA ',' GFLUX',' CIN ',' CAPE ',' TKE ', - &'MXSALB',' SOILL',' ASNOW',' ARAIN',' GWREC',' QREC ',' SNOWT', - &' VBDSF',' VDDSF',' NBDSF',' NDDSF','SNFALB',' RLYRS',' M FLX', - &' NLAT ',' ELON ','FLDCAP',' ACOND',' SNOAG',' CCOND',' LAI ', - &' SFCRH',' SALBD',' NDVI ',' DRIP ',' SBSNO',' EVBS ',' EVCW ', - &' RSMIN',' DSWRF',' DLWRF',' MSTAV',' SFEXC',' TRANS',' USWRF', - &' ULWRF',' WILT ',' FLDCP',' SLTYP',' CNWAT',' SOTYP',' VGTYP', - &' BMIXL',' AMIXL',' PEVAP',' SNOHF',' SMREF',' SMDRY',' BGRUN', - &' SSRUN',' SNOWC',' SNOT ',' POROS',' RCS ',' RCT ',' RCQ ', - &' RCSOL',' CD ',' FRICV',' RI ',' MISS '/ -C -C GRIB TABLE VERSION 131 (PDS OCTET 4 = 131) -C - DATA HH131/ - & 1, 2, 3, 4, 5, 6, 7, - & 8, 9, 10, 11, 12, 13, 14, - & 15, 16, 17, 18, 19, 20, 21, - & 22, 23, 24, 25, 26, 27, 28, - & 29, 30, 31, 32, 33, 34, 35, - & 36, 37, 38, 39, 40, 41, 42, - & 43, 44, 45, 46, 47, 48, 49, - & 50, 51, 52, 53, 54, 55, 56, - & 57, 58, 59, 60, 61, 62, 63, - & 64, 65, 66, 67, 68, 69, 70, - & 71, 72, 73, 74, 75, 76, 77, - & 78, 79, 80, 81, 82, 83, 84, - & 85, 86, 87, 88, 89, 90, 91, - & 92, 93, 94, 95, 96, 97, 98, - & 99, 100, 101, 102, 103, 104, 105, - & 106, 107, 108, 109, 110, 111, 112, - & 113, 114, 115, 116, 117, 118, 119, - & 120, 121, 122, 123, 124, 125, 126, - & 127, 128, 130, 131, 132, 134, 135, - & 136, 139, 140, 141, 142, 143, 144, - & 145, 146, 147, 148, 149, 150, 151, - & 152, 153, 155, 156, 157, 158, 159, - & 160, 161, 162, 163, 164, 165, 166, - & 167, 168, 169, 170, 171, 172, 173, - & 174, 175, 176, 177, 178, 179, 180, - & 181, 182, 183, 184, 187, 188, 189, - & 190, 191, 192, 194, 196, 197, 198, - & 199, 200, 202, 203, 204, 205, 206, - & 207, 208, 210, 211, 212, 213, 214, - & 216, 218, 219, 220, 221, 222, 223, - & 224, 225, 226, 227, 228, 229, 230, - & 231, 232, 233, 234, 235, 237, 238, - & 239, 240, 241, 242, 243, 244, 245, - & 246, 247, 248, 249, 250, 251, 252, - & 253, 254, 255/ - DATA HHNAM131/ - &' PRES ',' PRMSL',' PTEND',' PVORT',' ICAHT',' GP ',' HGT ', - &' DIST ',' HSTDV',' TOZNE',' TMP ',' VTMP ',' POT ',' EPOT ', - &' TMAX ',' TMIN ',' DPT ',' DEPR ',' LAPR ',' VIS ',' RDSP1', - &' RDSP2',' RDSP3',' PLI ',' TMPA ',' PRESA',' GPA ',' WVSP1', - &' WVSP2',' WVSP3',' WDIR ',' WIND ',' UGRD ',' VGRD ',' STRM ', - &' VPOT ',' MNTSF',' SGVCC',' VVEL ',' DZDT ',' ABSV ',' ABSD ', - &' RELV ',' RELD ',' VUCSH',' VVCSH',' DIRC ',' SPC ',' UOGRD', - &' VOGRD',' SPFH ',' RH ',' MIXR ',' PWAT ',' VAPP ',' SATD ', - &' EVP ',' CICE ',' PRATE',' TSTM ',' APCP ',' NCPCP',' ACPCP', - &' SRWEQ',' WEASD',' SNOD ',' MIXHT',' TTHDP',' MTHD ',' MTHA ', - &' TCDC ',' CDCON',' LCDC ',' MCDC ',' HCDC ',' CWAT ',' BLI ', - &' SNOC ',' SNOL ',' WTMP ',' LAND ',' DSLM ',' SFCR ',' ALBDO', - &' TSOIL',' SOILM',' VEG ',' SALTY',' DEN ',' WATR ',' ICEC ', - &' ICETK',' DICED',' SICED',' UICE ',' VICE ',' ICEG ',' ICED ', - &' SNOM ',' HTSGW',' WVDIR',' WVHGT',' WVPER',' SWDIR',' SWELL', - &' SWPER',' DIRPW',' PERPW',' DIRSW',' PERSW',' NSWRS',' NLWRS', - &' NSWRT',' NLWRT',' LWAVR',' SWAVR',' GRAD ',' BRTMP',' LWRAD', - &' SWRAT',' LHTFL',' SHTFL',' BLYDP',' UFLX ',' VFLX ',' WMIXE', - &' IMGD ',' MSLSA',' MSLET',' LFTX ',' 4LFTX',' PRESN',' MCONV', - &' VWSH ',' PVMW ',' CRAIN',' CFRZR',' CICEP',' CSNOW',' SOILW', - &' PEVPR',' VEGT ',' BARET',' AVSFT',' RADT ',' SSTOR',' LSOIL', - &' EWATR',' CLWMR',' GFLUX',' CIN ',' CAPE ',' TKE ','MXSALB', - &' SOILL',' ASNOW',' ARAIN',' GWREC',' QREC ',' SNOWT',' VBDSF', - &' VDDSF',' NBDSF',' NDDSF','SNFALB',' RLYRS',' FLX ',' LMH ', - &' LMV ',' MLYNO',' NLAT ',' ELON ',' ICMR ',' ACOND',' SNOAG', - &' CCOND',' LAI ',' SFCRH',' SALBD',' NDVI ',' DRIP ',' LANDN', - &' HLCY ',' NLATN',' ELONN',' CPOFP',' USTM ',' VSTM ',' SBSNO', - &' EVBS ',' EVCW ',' APCPN',' RSMIN',' DSWRF',' DLWRF','ACPCPN', - &' MSTAV',' SFEXC',' TRANS',' USWRF',' ULWRF',' CDLYR',' CPRAT', - &' TTRAD',' HGTN ',' WILT ',' FLDCP',' HPBL ',' SLTYP',' CNWAT', - &' SOTYP',' VGTYP',' BMIXL',' AMIXL',' PEVAP',' SNOHF',' SMREF', - &' SMDRY',' WVINC',' WCINC',' BGRUN',' SSRUN','MVCONV',' SNOWC', - &' SNOT ',' POROS','WCCONV','WVUFLX','WVVFLX','WCUFLX','WCVFLX', - &' RCS ',' RCT ',' RCQ ',' RCSOL',' SWHR ',' LWHR ',' CD ', - &' FRICV',' RI ',' MISS '/ - -C -C ONE LINE CHANGE FOR HDS (IBM370) (ASCII NAME GRIB IN HEX) -C -C DATA GRIB /Z47524942/ -C -C ONE LINE CHANGE FOR CRAY AND WORKSTATIONS -C - DATA GRIB /'GRIB'/ -C -C TABLE O (PDS OCTET 5) NATIONAL/INTERNATIONAL -C ORIGINATING CENTERS -C - DATA KNAM1 / - & ' WMC/NMC WASHINGTON. ',' NWS TELECOMMS GATEWAY', - & ' US FIELD STATIONS ',' JAPANESE MA TOKYO ', - & ' NAT. HURR. C. MIAMI ',' CANADIAN MC MONTREAL ', - & ' U.S.A.F. GWC ',' FNOC MONTEREY, CA. ', - & ' NOAA FCST SYS LAB ',' NCAR, BOULDER CO. ', - & ' U.K MET BRACKNELL ',' FRENCH WS TOULOUSE ', - & ' EUROPEAN SPACE AGENCY',' EUROPEAN CENTER MRF. ', - & ' DEBILT NETHERLANDS '/ -C -C TABLE C (PDS OCTET 26) NATIONAL SUB-CENTERS -C - DATA KNAM2 / - & ' NCEP RE-ANALYSIS PRO.',' NCEP ENSEMBLE PRODUCT', - & ' NCEP CENTRAL OPS. ',' ENV. MODELING CENTER ', - & ' HYDRO. PRED. CENTER ',' OCEAN PRED. CENTER ', - & ' CLIMATE PRED. CENTER ',' AVN. WEATHER CENTER ', - & ' STORM PRED. CENTER ',' TROPICAL PRED. CENTER', - & ' NWS TECH. DEV. LAB. ',' NESDIS OFF. RES. APP.', - & ' FAA ',' NWS MET. DEV. LAB. ', - & ' NARR PROJECT ',' SPACE ENV. CENTER '/ - DATA KNAM3 / - & ' ABRFC TULSA, OK ',' AKRFC ANCHORAGE, AK ', - & ' CBRFC SALT LAKE, UT ',' CNRFC SACRAMENTO, CA', - & ' LMRFC SLIDEL, LA. ',' MARFC STATE CO., PA ', - & ' MBRFC KANSAS CITY MO',' NCRFC MINNEAPOLIS MN', - & ' NERFC HARTFORD, CT. ',' NWRFC PORTLAND, OR ', - & ' OHRFC CINCINNATI, OH',' SERFC ATLANTA, GA ', - & ' WGRFC FORT WORTH, TX',' OUN NORMAN OK WFO '/ - DATA MONTH /'JAN','FEB','MAR','APR','MAY','JUN', - & 'JUL','AUG','SEP','OCT','NOV','DEC'/ - DATA SCNTR1/ 1, 2, 3, 4, 5, 6, 7, - & 8, 9, 10, 11, 12, 13, 14, - & 15/ - DATA SCNTR2/ 150, 151, 152, 153, 154, 155, 156, - & 157, 158, 159, 160, 161, 162, 170/ - DATA TIMUN /'HRS.','DAYS','MOS.','YRS.','DECS','NORM','CENS', - & 2*'----','3HRS','6HRS','HDYS'/ - DATA TIMUN1/'HR','DY','MO','YR','DC','NO','CN', - & 2*'--','3H','6H','HD'/ -C -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C -C 1.0 INITIALIZATION - NO. OF ENTRIES IN INDCATOR PARM. -C - NO. OF ENTRIES IN TYPE LEVEL -C - NO. OF ENTRIES IN CNTR PROD. DTA. -C - NO. OF ENTRIES IN SUB CNTR1 PROD. DTA. -C - NO. OF ENTRIES IN SUB CNTR2 PROD. DTA. -C - IQ = 252 - IS = 71 - IC = 15 - IH1 = 69 - IH2 = 75 - IH3 = 241 - IH4 = 50 - ICS1 = 16 - ICS2 = 14 - IERR = 0 -C - TITL(1:30) = ' ' - TITL(31:60) = ' ' - TITL(61:86) = ' ' -C -C --------------------------------------------------------------------- -C$ 2.0 TEST SECTION 0 FOR ASCII 'GRIB' -C - IF (GRIB(1:4) .NE. IPDS0(1:4)) THEN - IERR = 1 - RETURN - ENDIF -C -C TEST SECTION 0 FOR GRIB VERSION 1 -C - IF (MOVA2I(IPDS0(8:8)).NE.1) THEN - IERR = 2 - RETURN - END IF -C -C TEST THE LENGTH OF THE PDS (SECTION 1) -C - LENPDS = MOVA2I(IPDS(1:1)) * 65536 + MOVA2I(IPDS(2:2)) * 256 + - & MOVA2I(IPDS(3:3)) - IF (LENPDS.GE.28) THEN - IDPDS(1:28) = IPDS(1:28) - ELSE - IERR = 3 - RETURN - ENDIF -C -C TEST PDS (OCTET 4) FOR PARAMETER TABLE VERSION -C NUMBER 1 OR 2 OR 128, 129 OR 130 OR 131 -C - IVER = MOVA2I(IDPDS(4:4)) - IF (IVER.GT.131) THEN - IERR = 9 - RETURN - END IF -C -C 4.0 FIND THE INDICATOR AND TYPE LEVELS -C - IQQ = MOVA2I (IDPDS(9:9)) - IF (IVER.EQ.128) THEN - DO K = 1, IH4 - IF (IQQ .EQ. HH128(K)) THEN - TITL(21:27) = HHNAM128(K) - GO TO 150 - END IF - END DO - ELSE IF (IVER.EQ.129) THEN - DO K = 1, IH1 - IF (IQQ .EQ. HH129(K)) THEN - TITL(21:27) = HHNAM129(K) - GO TO 150 - END IF - END DO - ELSE IF (IVER.EQ.130) THEN - DO K = 1, IH2 - IF (IQQ .EQ. HH130(K)) THEN - TITL(21:27) = HHNAM130(K) - GO TO 150 - END IF - END DO - ELSE IF (IVER.EQ.131) THEN - DO K = 1, IH3 - IF (IQQ .EQ. HH131(K)) THEN - TITL(21:27) = HHNAM131(K) - GO TO 150 - END IF - END DO - ELSE - DO II = 1,IQ - IF (IQQ .EQ. HH(II)) GO TO 100 - END DO - IF (IQQ.EQ.77.AND.IVER.EQ.1) GO TO 100 - IF (IQQ.EQ.24) GO TO 100 - IERR = 4 - RETURN - END IF -C - 100 CONTINUE - IF (IQQ .NE. 77 .AND. IQQ .NE. 24) THEN - TITL(21:27) = HHNAM(II) - ELSE IF (IQQ .EQ. 77) THEN - TITL(21:27) = ' CONDP ' -C -C TAKE OUT AFTER ALL PROGRAMS ARE CHANGED THAT USE 24 -C FOR TOTAL OZONE. -C - ELSE IF (IQQ .EQ. 24) THEN - TITL(21:27) = ' TOTO3 ' - END IF - IF (IQQ.EQ.137.AND.IVER.EQ.1) TITL(21:27) = ' VISIB ' - 150 CONTINUE - ISS = MOVA2I (IDPDS(10:10)) -C -C CORRECTION FOR 'NLAT' 'ELON' 'L CDC' 'M CDC', 'H CDC', -C 'T CDC' -C - IF (ISS.EQ.0.AND.(IQQ.EQ.176.OR.IQQ.EQ.177. - & OR.IQQ.EQ.71.OR.IQQ.EQ.73.OR.IQQ.EQ.74. - & OR.IQQ.EQ.72.OR.IQQ.EQ.75.OR.IQQ.EQ.213. - & OR.IQQ.EQ.173.OR.IQQ.EQ.174)) THEN - GO TO 300 - END IF - DO JJ = 1,IS - IF (ISS .EQ. HHH(JJ)) GO TO 200 - END DO - IERR = 5 - RETURN -C - 200 CONTINUE - IF (ISS.EQ.4.OR.ISS.EQ.5.OR.ISS.EQ.20.OR.ISS.EQ.100.OR. - & ISS.EQ.103.OR.ISS.EQ.105.OR.ISS.EQ.107.OR.ISS.EQ.109.OR. - & ISS.EQ.111.OR.ISS.EQ.113.OR.ISS.EQ.115.OR.ISS.EQ.117.OR. - & ISS.EQ.119.OR.ISS.EQ.125.OR.ISS.EQ.126.OR.ISS.EQ.160.OR. - & ISS.EQ.236)THEN - TITL(16:20) = HHHNAM(JJ) - LEVEL = MOVA2I(IDPDS(11:11)) * 256 + MOVA2I(IDPDS(12:12)) - IF (ISS.EQ.107.OR.ISS.EQ.119) THEN - ALEVEL = FLOAT(LEVEL) / 10000.0 - WRITE (TITL(9:15),FMT='(F6.4)') ALEVEL - ELSE IF (ISS.EQ.5) THEN -C DO NOTHING - ELSE - WRITE (TITL(11:15),FMT='(I4)') LEVEL - END IF - ELSE IF (ISS.EQ.1.OR.ISS.EQ.6.OR.ISS.EQ.7.OR.ISS.EQ.8.OR. - & ISS.EQ.9 .OR.ISS.EQ.102.OR.ISS.EQ.200.OR.ISS.EQ.201.OR. - & ISS.EQ.204.OR.ISS.EQ.212.OR.ISS.EQ.213.OR.ISS.EQ.214.OR. - & ISS.EQ.222.OR.ISS.EQ.223.OR.ISS.EQ.224.OR.ISS.EQ.232.OR. - & ISS.EQ.233.OR.ISS.EQ.234.OR.ISS.EQ.209.OR.ISS.EQ.210.OR. - & ISS.EQ.211.OR.ISS.EQ.242.OR.ISS.EQ.243.OR.ISS.EQ.244.OR. - & ISS.EQ.245.OR.ISS.EQ.235.OR.ISS.EQ.237.OR.ISS.EQ.238.OR. - & ISS.EQ.246.OR.ISS.EQ.247.OR.ISS.EQ.206.OR.ISS.EQ.207.OR. - & ISS.EQ.248.OR.ISS.EQ.249.OR.ISS.EQ.251.OR.ISS.EQ.252) THEN - TITL(16:20) = HHHNAM(JJ) - TITL(1:4) = ' ' - TITL(11:15) = ' ' - ELSE IF (ISS.EQ.101.OR.ISS.EQ.104.OR.ISS.EQ.106.OR.ISS.EQ.108. - & OR.ISS.EQ.110.OR.ISS.EQ.112.OR.ISS.EQ.114.OR.ISS.EQ.116.OR. - & ISS.EQ.120.OR.ISS.EQ.121.OR.ISS.EQ.128.OR.ISS.EQ.141) THEN - TITL(6:11) = HHHNAM(JJ) - TITL(16:20) = HHHNAM(JJ) - ITEMP = MOVA2I(IDPDS(11:11)) - WRITE (UNIT=TITL(1:4),FMT='(I4)') ITEMP - JTEMP = MOVA2I(IDPDS(12:12)) - WRITE (UNIT=TITL(11:15),FMT='(I4)') JTEMP - END IF -C -C 5.0 INSERT THE YEAR,DAY,MONTH AND TIME -C - 300 CONTINUE - IHR = MOVA2I (IDPDS(16:16)) - IDAY = MOVA2I (IDPDS(15:15)) - IMON = MOVA2I (IDPDS(14:14)) - IYR = MOVA2I (IDPDS(13:13)) - ICEN = MOVA2I (IDPDS(25:25)) -C -C SUBTRACT 1 FROM CENTURY TO MAKE 4 DIGIT YEAR -C - ICEN = ICEN - 1 -C - IYR = ICEN * 100 + IYR - WRITE (UNIT=TITL(59:62),FMT='(I4)') IYR - WRITE (UNIT=TITL(52:53),FMT='(I2)') IDAY - WRITE (UNIT=TITL(38:49),FMT='(A6,I2.2,A2)') 'AFTER ',IHR,'Z ' - TITL(55:57) = MONTH(IMON) - FCSTIM = MOVA2I (IDPDS(18:18)) - TITL(34:36) = TIMUN(FCSTIM) - P1 = MOVA2I(IDPDS(19:19)) - P2 = MOVA2I(IDPDS(20:20)) - TIMERG = MOVA2I(IDPDS(21:21)) - IF (TIMERG.EQ.10) THEN - P1 = P1 * 256 + P2 - P2 = 0 - END IF -C -C ADD CORRECTION IF BYTE 21 (TIME RANGE) IS 2 -C - IF (TIMERG.EQ.2) THEN - TITL(4:20) = TITL(11:27) - TITL(21:21) = ' ' - WRITE (UNIT=TITL(22:24),FMT='(I3)') P1 - TITL(25:28) = ' TO ' - WRITE (UNIT=TITL(29:32),FMT='(I3)') P2 -C -C PRECIP AMOUNTS -C - ELSE IF (TIMERG.EQ.4) THEN - WRITE (UNIT=TITL(29:32),FMT='(I3)') P2 - MTEMP = P2 - P1 - WRITE (UNIT=TITL(2:4),FMT='(I3)') MTEMP - TITL(6:7) = TIMUN1(FCSTIM) - TITL(8:12) = ' ACUM' -C -C AVERAGE -C - ELSE IF (TIMERG.EQ.3) THEN - WRITE (UNIT=TITL(29:32),FMT='(I3)') P2 - MTEMP = P2 - P1 - WRITE (UNIT=TITL(2:4),FMT='(I3)') MTEMP - TITL(6:7) = TIMUN1(FCSTIM) - TITL(8:12) = ' AVG' - ELSE - WRITE (UNIT=TITL(29:32),FMT='(I3)') P1 - ENDIF -C -C TEST FOR ANALYSIS (MAKE CORRECTION IF MODEL IS ANALYSIS) -C - IF (TIMERG.EQ.0.AND.P1.EQ.0) THEN - TITL(29:42) = ' ANALYSIS VT ' - MODEL = MOVA2I(IDPDS(6:6)) - IF (MODEL.EQ.10.OR.MODEL.EQ.39.OR.MODEL.EQ.45.OR. - & MODEL.EQ.53.OR.MODEL.EQ.68.OR.MODEL.EQ.69.OR. - & MODEL.EQ.70.OR.MODEL.EQ.73.OR.MODEL.EQ.74.OR. - & MODEL.EQ.75.OR.MODEL.EQ.76.OR.MODEL.EQ.77.OR. - & MODEL.EQ.78.OR.MODEL.EQ.79.OR.MODEL.EQ.80.OR. - & MODEL.EQ.83.OR.MODEL.EQ.84.OR.MODEL.EQ.85.OR. - & MODEL.EQ.86.OR.MODEL.EQ.87.OR.MODEL.EQ.88.OR. - & MODEL.EQ.90.OR.MODEL.EQ.91.OR.MODEL.EQ.92.OR. - & MODEL.EQ.105.OR.MODEL.EQ.110.OR.MODEL.EQ.150.OR. - & MODEL.EQ.151) THEN - TITL(29:42) = ' 00-HR FCST ' - ENDIF - ENDIF -C -C TEST FOR 00-HR FCST (INITIALIZED ANALYSIS) -C - IF (TIMERG.EQ.1.AND.P1.EQ.0) THEN - TITL(29:42) = ' 00-HR FCST ' - ENDIF -C -C$ 3.0 FIND WHO GENERATED THE CODE -C$ CHECK FOR SUB-CENTERS -C - IGENC = MOVA2I (IDPDS(5:5)) - ISUBC = MOVA2I (IDPDS(26:26)) -C -C TEST FOR SUB-CENTERS WHEN CENTER IS 7 -C - - IF (ISUBC.NE.0.AND.IGENC.EQ.7) THEN - DO J = 1,ICS1 - IF (ISUBC .EQ. SCNTR1(J)) THEN - TITL(63:86) = KNAM2(J) - RETURN - END IF - END DO - IERR = 7 - END IF -C -C TEST FOR SUB-CENTERS WHEN CENTER IS 9 -C - IF (ISUBC.NE.0.AND.IGENC.EQ.9) THEN - DO J = 1,ICS2 - IF (ISUBC .EQ. SCNTR2(J)) THEN - TITL(63:86) = KNAM3(J) - RETURN - END IF - END DO - IERR = 8 - END IF -C -C TEST TO SEE IF CENTER IN TABLES -C - DO I = 1,IC - IF (IGENC .EQ. CENTER(I)) THEN - TITL(63:86) = KNAM1(I) - RETURN - END IF - END DO -C - IERR = 6 - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fp12.f b/src/fim/FIMsrc/w3/w3fp12.f deleted file mode 100644 index e08021a..0000000 --- a/src/fim/FIMsrc/w3/w3fp12.f +++ /dev/null @@ -1,612 +0,0 @@ - SUBROUTINE W3FP12(ID8, IFLAG, IDPDS, ICENT, ISCALE, IER) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FP12 CREATES THE PRODUCT DEFINITION SECTION -C PRGMMR: MCCLEES ORG: NMC421 DATE:92-01-14 -C -C ABSTRACT: FORMATS THE PRODUCT DEFINITION SECTION ACCORDING TO THE -C SPECIFICATIONS SET BY WMO. USING O.N. 84 ID'S (1ST 8 WORDS) -C AS THE INPUT DATA. NEW SUBROUTINE CORRESPONDS TO THE REVISION -C #1 OF THE WMO GRIB STANDARDS MADE MARCH 15, 1991. -C -C PROGRAM HISTORY LOG: -C 91-07-30 MCCLEES,A.J. NEW SUBROUTINE WHICH FORMATS THE PDS -C SECTION FROM THE O.N. 84 ID'S FROM THE GRIB -C EDITION 1 DATED MARCH 15, 1991. -C -C 92-01-06 MCCLEES,A.J. DELETE PARAMATER 202 (ACCUMULATED EVAP) -C AND MAKE PARAMETER 57 (EVAPORATION) THE -C EQUIVALENT OF O.N.84 117. -C 92-11-02 R.E.JONES CORRECTION AT SAME LEVEL AS W3FP12 IN -C V77W3LIB ON HDS 92-09-30 -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C 93-04-16 R.E.JONES ADD 176, 177 LAT, LON TO TABLES -C 93-08-03 R.E.JONES ADD 156 (CIN), 204 (DSWRF), 205 (DLWRF) -C 211 (USWRF), 212 (ULWRF) TO TABLES -C 95-02-07 R.E.JONES CHANGE PDS BYTE 4, VERSION NUMBER TO 2. -C 95-07-14 R.E.JONES CORRECTION FOR SFC LFT X -C 98-03-10 B. VUONG REMOVE THE CDIR$ INTEGER=64 DIRECTIVE -C 98-12-21 Gilbert Replaced Function ICHAR with mova2i. -C 99-02-15 B. FACEY REPLACE W3FS04 WITH W3MOVDAT. -C 1999-03-15 Gilbert Specified 8-byte integer array explicitly for ID8 -C 99-03-22 B. FACEY REMOVE THE DATE RECALCULATION FOR MEAN -C CHARTS. THIS INCLUDES THE PREVIOUS -C CHANGE TO W3MOVDAT. -C -C USAGE: CALL W3FP12 (ID8, IFLAG, IDPDS, ICENT, ISCALE, IER) -C INPUT ARGUMENT LIST: -C ID8 - FIRST 8 ID WORKDS (O.N.84) INTEGER*4 -C ICENT - CENTURY, 2 DIGITS, FOR 1991 IT IS 20. -C IFLAG - INDICATION OF INCLUSION OR OMISSION OF GRID DEFINITION -C AND/OR BIT MAP CODE CHARACTER*1 -C ISCALE - 10 SCALER INTEGER*4 -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C IDPDS - GRIB PRODUCT DEFINITION SECTION CHARACTER*1 (28) -C IER = 0 COMPLETED SMOOTHLY -C = 1 INDICATOR PARAMETER N.A. TO GRIB -C = 2 LEVEL INDICATOR N.A. TO GRIB -C = 3 TIME RANGE N.A. TO GRIB NOTATION -C = 4 LAYERS OR LEVELS N.A. TO GRIB -C OUTPUT FILES: -C FT06F001 - SELF-EXPLANATORY ERROR MESSAGES -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ -C - INTEGER E1 - INTEGER E2 - INTEGER F1 - INTEGER F2 - DATA F1/0/, F2/0/ - INTEGER HH (163) - INTEGER(8) ID8 ( 4) - INTEGER(8) IDWK ( 4) - INTEGER(8) MSK1,MSK2,MSK3,MSK4,MSK5,MSK6,MSK7 - INTEGER ISIGN - INTEGER ISCALE - INTEGER ICENT - INTEGER LL (163) - INTEGER L - INTEGER M - INTEGER N - INTEGER Q - INTEGER S1 - INTEGER T - DATA T/0/ -C - CHARACTER*1 IDPDS (28) - CHARACTER*1 IFLAG - CHARACTER*1 IHOLD ( 8) - CHARACTER*1 IPDS1 ( 8) - CHARACTER*1 KDATE ( 8) - CHARACTER*1 LIDWK (32) -C - EQUIVALENCE (IDWK(1),LIDWK(1)) - EQUIVALENCE (L,IPDS1(1)) - EQUIVALENCE (NBYTES,IHOLD(1)) - EQUIVALENCE (JDATE,KDATE(1)) - REAL RINC(5) - INTEGER NDATE(8), MDATE(8) -C - DATA LL / 8, 8, 9, 255, 255, 255, 1, 6, 255, 255, - & 16, 24, 19, 23, 20, 21, 17, 18, 255, 180, - & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, - & 55, 50, 48, 56, 49, 57, 80, 81, 71, 255, - & 40, 42, 72, 74, 73, 255, 255, 255, 255, 255, - & 304, 305, 95, 88, 101, 89, 104, 255, 117, 255, - & 97, 98, 90, 105, 94, 255, 255, 93, 188, 255, - & 255, 255, 255, 211, 255, 255, 255, 255, 255, 255, - & 255, 384, 161, 255, 255, 169, 22, 255, 255, 255, - & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, - & 255, 400, 389, 385, 388, 391, 386, 390, 402, 401, - & 404, 403, 204, 255, 255, 255, 255, 255, 255, 255, - & 255, 255, 195, 194, 255, 255, 255, 255, 255, 255, - & 255, 255, 112, 116, 114, 255, 103, 52, 255, 255, - & 255, 255, 119, 157, 158, 159, 255, 176, 177, 392, - & 192, 190, 199, 216, 189, 193, 191, 210, 198, 255, - & 255, 1, 255/ - DATA HH / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, - & 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, - & 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, - & 31, 32, 33, 33, 34, 34, 35, 36, 37, 38, - & 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, - & 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, - & 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, - & 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, - & 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, - & 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, - & 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, - & 109, 110, 111, 112, 113, 114, 115, 116, 117, 118, - & 119, 120, 121, 122, 123, 124, 125, 126, 127, 128, - & 129, 130, 131, 132, 133, 134, 135, 136, 137, 150, - & 151, 152, 156, 157, 158, 159, 175, 176, 177, 201, - & 204, 205, 207, 208, 209, 211, 212, 213, 216, 218, - & 220, 222, 255/ -C DATA MSK1 /Z'00000FFF'/, -C & MSK2 /Z'0FFFFF00'/, -C & MSK3 /Z'0000007F'/, -C & MSK4 /Z'00000080'/, -C & MSK5 /Z'F0000000'/, -C & MSK6 /Z'00000200'/, -C & MSK7 /Z'000000FF'/ -C CHANGE HEX TO DECIMAL TO MAKE SUBROUTINE MORE PORTABLE - DATA MSK1 /4095/, - & MSK2 /268435200/, - & MSK3 /127/, - & MSK4 /128/, - & MSK5 /Z'00000000F0000000'/ - & MSK6 /512/, - & MSK7 /255/ -C -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C -C$ 1.0 INITIALIZATION - NO. OF ENTRIES IN INDCATOR PARM. -C$ - NO. OF ENTRIES IN TYPE LEVEL -C - IQ = 163 -C -C$ 1.1 COPY O.N. 84 ID'S INTO WORK SPACE -C - DO 100 N = 1,4 - IDWK(N) = ID8(N) - 100 CONTINUE -C --------------------------------------------------------------------- -C 2.0 NO. OF OCTETS IN THE PDS IN THE FIRST 3 -C$ 2.1 SET CNTR ID, DATA TYPE, GRID DEF AND FLAG -C - NBYTES = 28 - IDPDS(1) = IHOLD(6) - IDPDS(2) = IHOLD(7) - IDPDS(3) = IHOLD(8) - IDPDS(4) = CHAR(2) - IDPDS(5) = CHAR(7) - IDPDS(6) = LIDWK(30) - JSCALE = ISCALE - IF (JSCALE.LT.0) THEN - JSCALE = -JSCALE - IDPDS(27) = CHAR(128) - IDPDS(28) = CHAR(JSCALE) - ELSE - IDPDS(27) = CHAR(0) - IDPDS(28) = CHAR(JSCALE) - END IF -C - IF (LIDWK(30) .EQ. CHAR (69)) THEN - IF (LIDWK(29) .EQ. CHAR(3)) THEN - IDPDS(6) = CHAR(68) - ELSE IF (LIDWK(29) .EQ. CHAR(4)) THEN - IDPDS(6) = CHAR(69) - ENDIF - ENDIF - IF (LIDWK(30) .EQ. CHAR (78)) THEN - IF (LIDWK(29) .EQ. CHAR(3)) THEN - IDPDS(6) = CHAR(77) - ELSE IF (LIDWK(29) .EQ. CHAR(4)) THEN - IDPDS(6) = CHAR(78) - ENDIF - ENDIF - IDPDS(7) = LIDWK(20) - IF (LIDWK(20) .EQ. CHAR (26)) IDPDS(7) = CHAR(6) - IDPDS(8) = IFLAG - IDPDS(24) = CHAR(0) - IDPDS(26) = CHAR(0) -C--------------------------------------------------------------------- -C -C$ 3.0 FORM INDICATOR PARAMETER -C - Q = ISHFT(IDWK(1),-52_8) - DO 300 I = 1,IQ - II = I - IF (Q .EQ. LL(I)) GO TO 310 - 300 CONTINUE -C - IER = 1 - PRINT 320, IER, Q, ID8 - 320 FORMAT (' W3FP12 (320) - IER = ',I2,', Q = ',I3,/, - & ' OFFICE NOTE 84 PARAMETER N.A. IN GRIB', - & /,1X,4(Z16,' ')) - RETURN -C - 310 I = II - S1 = IAND(ISHFT(IDWK(1),-40_8),MSK1) - C1 = ISHFT(IAND(IDWK(1),MSK2),-8_8) - ISIG1 = IAND(IDWK(1),MSK4) - E1 = IAND(IDWK(1),MSK3) - IF (ISIG1 .NE. 0) E1 = -E1 - M = ISHFT(IAND(ISHFT(IDWK(2),-32_8),MSK5),-28_8) - N = ISHFT(IAND(IDWK(2),MSK5),-28_8) - KS = ISHFT(IAND(ISHFT(IDWK(3),-32_8),MSK6),-8_8) - IF (M.NE.0) THEN - C2 = ISHFT(IAND(IDWK(2),MSK2),-8_8) - ISIG2 = IAND(IDWK(2),MSK4) - E2 = IAND(IDWK(2),MSK3) - IF (ISIG2 .NE. 0) E2 = -E2 - ENDIF - IDPDS(9) = CHAR(HH(I)) -C -C N IS A SPECIAL TEST FOR WAVE HGTS, M AND KS ARE SPECIAL FOR -C ACCUMULATED PRECIP -C - IF (N .EQ. 5 .AND. Q .EQ. 1) THEN - IDPDS(9) = CHAR (222) - ENDIF - IF (KS .EQ. 2) THEN - IF (M .EQ. 0 .AND. Q .EQ. 8) THEN - IDPDS(9) = CHAR (211) - END IF -C - IF (M .EQ. 0 .AND. Q .EQ. 1) THEN - IDPDS(9) = CHAR (210) - ENDIF -C - IF (M .EQ. 1 .AND. Q .EQ. 1) THEN - IER = 1 - PRINT 330, IER, ID8 - 330 FORMAT (' W3FP12 (330) - IER =',I2,/, - & ' OFFICE NOTE 84 PARAMETER N.A. IN GRIB', - & /,1X,4(Z16,' ')) - RETURN - ENDIF - ENDIF -C -C$ 4.0 DETERMINE IF LAYERS OR LEVEL AND FORM TYPE -C -C ......... M = THE M MARKER FROM O.N.84 CHECK ABOVE -C ......... S1 = S1 TYPE OF SURFACE -C - IF (M .EQ. 0) THEN - IF (S1.EQ.0.AND.(Q.EQ.176.OR.Q.EQ.177)) THEN - IDPDS(10) = CHAR(0) - IDPDS(11) = CHAR(0) - IDPDS(12) = CHAR(0) -C - ELSE IF (S1 .EQ. 8) THEN - IDPDS(10) = CHAR (100) - L = C1 * (10. ** E1) + .5 - IDPDS(11) = IPDS1(7) - IDPDS(12) = IPDS1(8) -C - ELSE IF (S1 .EQ. 1) THEN - IDPDS(10) = CHAR (103) - L = C1 * (10. ** E1) + .5 - IDPDS(11) = IPDS1(7) - IDPDS(12) = IPDS1(8) -C - ELSE IF (S1 .EQ. 6) THEN - IDPDS(10) = CHAR (105) - L = C1 * (10. ** E1) + .5 - IDPDS(11) = IPDS1(7) - IDPDS(12) = IPDS1(8) -C - ELSE IF (S1 .EQ. 7) THEN - IDPDS(10) = CHAR (111) -C CONVERT FROM METERS TO CENTIMETERS - IF (ISIG1 .NE. 0) E1 = E1 + 2 - L = C1 * (10. ** E1) + .5 - IDPDS(11) = IPDS1(7) - IDPDS(12) = IPDS1(8) -C - ELSE IF (S1.EQ.148 .OR. S1 .EQ. 144 .OR. S1 .EQ. 145) THEN - IDPDS(10) = CHAR (107) - L = (C1 * (10. ** E1) * 10**4) + .5 - IDPDS(11) = IPDS1(7) - IDPDS(12) = IPDS1(8) -C - ELSE IF (S1 .EQ. 16) THEN - L = C1 * (10. ** E1) + .5 - IF (L .EQ. 273) THEN - IDPDS(10) = CHAR (4) - IDPDS(11) = CHAR (0) - IDPDS(12) = CHAR (0) - ELSE - IER = 2 - PRINT 410, IER, S1, ID8 - RETURN - ENDIF -C - ELSE IF (S1 .EQ. 19) THEN - L = C1 * (10. ** E1) + .5 - IDPDS(10) = CHAR (113) - IDPDS(11) = IPDS1(7) - IDPDS(12) = IPDS1(8) -C -C SET LEVEL AND PARAMETER FOR MSL PRESSURE -C - ELSE IF (S1 .EQ. 128) THEN - IF (Q.EQ.8) THEN - IDPDS(9) = CHAR(2) - END IF - IDPDS(10) = CHAR (102) - IDPDS(11) = CHAR (0) - IDPDS(12) = CHAR (0) -C - ELSE IF (S1 .EQ. 129) THEN - IDPDS(10) = CHAR (1) - IDPDS(11) = CHAR (0) - IDPDS(12) = CHAR (0) -C - ELSE IF (S1 .EQ. 130) THEN - IDPDS(10) = CHAR (7) - IDPDS(11) = CHAR (0) - IDPDS(12) = CHAR (0) -C - ELSE IF (S1 .EQ. 131) THEN - IDPDS(10) = CHAR (6) - IDPDS(11) = CHAR (0) - IDPDS(12) = CHAR (0) -C - ELSE IF (S1 .EQ. 133) THEN - IDPDS(10) = CHAR (1) - IDPDS(11) = CHAR (0) - IDPDS(12) = CHAR (0) -C - ELSE IF (S1 .EQ. 136) THEN - IF (Q.EQ.8) THEN - IF (T.EQ.2.AND.F1.EQ.0.AND.F2.EQ.3) THEN - IDPDS(9) = CHAR (137) - ELSE - IDPDS(9) = CHAR (128) - END IF - END IF - IDPDS(10) = CHAR (102) - IDPDS(11) = CHAR (0) - IDPDS(12) = CHAR (0) -C - ELSE IF (S1 .EQ. 137) THEN - IF (Q.EQ.8) THEN - IDPDS(9) = CHAR (129) - END IF - IDPDS(10) = CHAR (102) - IDPDS(11) = CHAR (0) - IDPDS(12) = CHAR (0) -C - ELSE IF (S1 .EQ. 138) THEN - IF (Q.EQ.8) THEN - IDPDS(9) = CHAR (130) - END IF - IDPDS(10) = CHAR (102) - IDPDS(11) = CHAR (0) - IDPDS(12) = CHAR (0) -C - ELSE - IER = 2 - PRINT 410, IER, S1, ID8 - 410 FORMAT (' W3FP12 (410) - IER = ',I2,', S1 = ',I5,/, - & ' SURFACE TYPE N.A. IN GRIB',/,' ID8 = ', - & 4(Z16,' ')) - RETURN - ENDIF -C - ELSE IF (M .EQ. 1) THEN - IF ((S1 .EQ. 8) .AND. (Q .EQ. 1)) THEN - IDPDS(9) = CHAR(101) - IDPDS(10) = CHAR(101) - JJJ = ((C1 * 10. ** E1) * .1) + .5 - IDPDS(11) = CHAR(JJJ) - KKK = ((C2 * 10. ** E2) * .1) + .5 - IDPDS(12) = CHAR(KKK) - END IF -C - ELSE IF (M .EQ. 2) THEN - IF (S1 .EQ. 8) THEN - IDPDS(10) = CHAR(101) - JJJ = ((C1 * 10. ** E1) * .1) + .5 - IDPDS(11) = CHAR(JJJ) - KKK = ((C2 * 10. ** E2) * .1) + .5 - IDPDS(12) = CHAR(KKK) - IF (IDPDS(9) .EQ. CHAR(131)) IDPDS(12) = CHAR(100) -C - ELSE IF (S1 .EQ. 1) THEN - IDPDS(10) = CHAR(104) - JJJ = ((C1 * 10. ** E1) * .1) + .5 - IDPDS(11) = CHAR(JJJ) - KKK = ((C2 * 10. ** E2) * .1) + .5 - IDPDS(12) = CHAR(KKK) -C - ELSE IF (S1 .EQ. 6) THEN - IDPDS(10) = CHAR(106) - JJJ = ((C1 * 10. ** E1) * .1) + .5 - IDPDS(11) = CHAR(JJJ) - KKK = ((C2 * 10. ** E2) * .1) + .5 - IDPDS(12) = CHAR(KKK) -C - ELSE IF (S1.EQ.148 .OR. S1 .EQ. 144 .OR. S1 .EQ. 145) THEN - IDPDS(10) = CHAR(108) - JJJ = ((C1 * 10. ** E1) * 10**2) + .5 - IDPDS(11) = CHAR(JJJ) - KKK = ((C2 * 10. ** E2) * 10**2) + .5 - IDPDS(12) = CHAR(KKK) -C - ELSE - IER = 2 - PRINT 420, IER, S1, ID8 - 420 FORMAT (' W3FP12 (420) - IER = ',I2,', S1 = ',I5,/, - & ' SURFACE LAYERS N.A. IN GRIB', - & /,' ID8= ',4(Z16,' ')) - RETURN - ENDIF - ELSE IF (M .GT. 2) THEN - IER = 4 - PRINT 500, IER, M, ID8 - 500 FORMAT ('W3FP12 (500) - IER = ',I2,', M = ',/, - & ' THE M FROM O.N. 84 N.A. IN GRIB', - & /,' ID8 = ',4(Z16,' ')) - RETURN - ENDIF -C -C$ 6.0 DATE - YR.,MO,DA,& INITIAL HR AND CENTURY -C - IDPDS(13) = LIDWK(25) - IDPDS(14) = LIDWK(26) - IDPDS(15) = LIDWK(27) - IDPDS(16) = LIDWK(28) - IDPDS(17) = CHAR(0) - IDPDS(25) = CHAR(ICENT) -C--------------------------------------------------------------------- -C -C$ OCTET (17) N.A. FROM O.N. 84 DATA -C -C$ 7.0 INDICATOR OF TIME UNIT, TIME RANGE 1 AND 2, AND TIME -C RANGE FLAG -C - T = ISHFT((IAND(IDWK(1),MSK5)),-28_8) - F1 = IAND(ISHFT(IDWK(1),-32_8),MSK7) - F2 = IAND(ISHFT(IDWK(2),-32_8),MSK7) - IF (T .EQ. 0) THEN - IDPDS(18) = CHAR (1) - IDPDS(19) = CHAR (F1) - IDPDS(20) = CHAR (0) - IDPDS(21) = CHAR (0) - IDPDS(22) = CHAR (0) - IDPDS(23) = CHAR (0) -C - ELSE IF (T .EQ. 1) THEN - PRINT 710, T, ID8 - IER = 3 - RETURN -C - ELSE IF (T .EQ. 2) THEN - IF (mova2i(IDPDS(9)).NE.137) THEN - PRINT 710, T, ID8 - IER = 3 - RETURN - END IF -C - ELSE IF (T .EQ. 3) THEN - IF (Q .EQ. 89 .OR. Q .EQ. 90 .OR. Q .EQ. 94 - & .OR. Q .EQ. 105) THEN -C - IDPDS(18) = CHAR (1) -C CORRECTION FOR 00 HR FCST - ITEMP = F1 - F2 - IF (ITEMP.LT.0) ITEMP = 0 -C IDPDS(19) = CHAR (F1 - F2) - IDPDS(19) = CHAR (ITEMP) - IDPDS(20) = CHAR (F1) - IDPDS(21) = CHAR (4) - IDPDS(22) = CHAR (0) - IDPDS(23) = CHAR (0) -C - ELSE - IDPDS(18) = CHAR (1) -C CORRECTION FOR 00 HR FCST - ITEMP = F1 - F2 - IF (ITEMP.LT.0) ITEMP = 0 -C IDPDS(19) = CHAR (F1 - F2) - IDPDS(19) = CHAR (ITEMP) - IDPDS(20) = CHAR (F1) - IDPDS(21) = CHAR (5) - IDPDS(22) = CHAR (0) - IDPDS(23) = CHAR (0) - END IF -C - ELSE IF (T .EQ. 4) THEN -C - IF (F1 .EQ. 0 .AND. F2 .NE. 0) THEN - IDPDS(18) = CHAR (4) - IDPDS(19) = CHAR (0) - IDPDS(20) = CHAR (1) - IDPDS(21) = CHAR (124) - L = F2 - IDPDS(22) = IPDS1(7) - IDPDS(23) = IPDS1(8) -C - ELSE IF (F1 .NE. 0 .AND. F2 .EQ. 0) THEN - IDPDS(18) = CHAR (2) - IDPDS(19) = CHAR (0) - IDPDS(20) = CHAR (1) - IDPDS(21) = CHAR (124) - L = F1 - IDPDS(22) = IPDS1(7) - IDPDS(23) = IPDS1(8) -C - ENDIF -C - ELSE IF (T .EQ. 5) THEN - IDPDS(18) = CHAR (1) -C CORRECTION FOR 00 HR FCST - ITEMP = F1 - F2 - IF (ITEMP.LT.0) ITEMP = 0 -C IDPDS(19) = CHAR (F1 - F2) - IDPDS(19) = CHAR (ITEMP) - IDPDS(20) = CHAR (F1) - IDPDS(21) = CHAR (2) - IDPDS(22) = CHAR (0) - IDPDS(23) = CHAR (0) -C - ELSE IF (T .EQ. 6) THEN - JSIGN = IAND(ISHFT(IDWK(1),-32_8),MSK4) - JSIGO = IAND(ISHFT(IDWK(2),-32_8),MSK4) - F1 = IAND(ISHFT(IDWK(1),-32_8),MSK3) - F2 = IAND(ISHFT(IDWK(2),-32_8),MSK3) - IF (JSIGN .NE. 0) F1 = -F1 - IF (JSIGO .NE. 0) F2 = -F2 - IDPDS(18) = CHAR (1) -C****CALCULATE NEW DATE BASED ON THE BEGINNING OF THE DATA IN MEAN -C INCR = (F1) -C IF (INCR.LT.0) THEN -C RINC=0 -C RINC(2)=INCR -C PRINT *, 'INCR=',INCR -C CALL W3FS04 (IDWK(4),JDATE,INCR,IERR) -C IYR=ICHAR(LIDWK(25)) -C PRINT *, 'IYR = ', IYR -C IF(IYR.LT.20)THEN -C MDATE(1)=2000+IYR -C ELSE -C MDATE(1)=1900+IYR -C ENDIF -C MDATE(2) = ICHAR(LIDWK(26)) -C MDATE(3) = ICHAR(LIDWK(27)) -C MDATE(4) = ICHAR(LIDWK(28)) -C PRINT *, 'CHANGE DATE BY - ', RINC(2) -C CALL W3MOVDAT(RINC,MDATE,NDATE) -C PRINT *,'NEW DATE =',NDATE(1),NDATE(2),NDATE(3),NDATE(5) -C IYEAR = MOD(NDATE(1),100) -C LIDWK(25) = CHAR(IYEAR) -C LIDWK(26) = CHAR(NDATE(2)) -C LIDWK(27) = CHAR(NDATE(3)) -C LIDWK(28) = CHAR(NDATE(4)) -C END IF - IDPDS(13) = LIDWK(25) - IDPDS(14) = LIDWK(26) - IDPDS(15) = LIDWK(27) - IDPDS(16) = LIDWK(28) - IF (F1.LT.0) THEN - IDPDS(19) = CHAR (0) - IDPDS(21) = CHAR (123) - ELSE - NF1 = F1 * 12 - IDPDS(19) = CHAR (NF1) - IDPDS(21) = CHAR (113) - END IF - IDPDS(20) = CHAR (24) -C*****THE NUMBER OF CASES AVERAGED IS ASSUMING ONE TIME A DAY -C L = (F2/2) + 1 -C***THE ABOVE CALCULATION WOULD BE CORR. IF ID8(3) WERE CORR. - L = (F2+1) / 2 - IDPDS(22) = IPDS1(7) - IDPDS(23) = IPDS1(8) -C - ELSE IF (T .EQ. 7) THEN - PRINT 710, T, ID8 - IER = 3 - RETURN -C - ELSE IF (T .EQ. 10) THEN - PRINT 710, T, ID8 - IER = 3 - RETURN -C - 710 FORMAT (' W3FP12 (710) - NOT APPLICABLE (YET) TO GRIB. ', - & ', T = ',I2,/, - & ' O.N. 84 IDS ARE ',/, - & 1X,4(Z16,' ')) -C - ENDIF - IER = 0 - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fp13.f b/src/fim/FIMsrc/w3/w3fp13.f deleted file mode 100644 index 69d28f0..0000000 --- a/src/fim/FIMsrc/w3/w3fp13.f +++ /dev/null @@ -1,920 +0,0 @@ - SUBROUTINE W3FP13 (GRIB, PDS, ID8, IERR ) -C$$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FP13 CONVERT GRIB PDS EDITION 1 TO O.N. 84 ID -C PRGMMR: MCCLEES ORG: NMC421 DATE:91-10-07 -C -C ABSTRACT: CONVERTS GRIB VERSION 1 FORMATTED PRODUCT DEFINITION -C SECTION TO AN OFFICE NOTE 84 ID LABEL. FORMATS ALL THAT IS APPLI- -C CABLE IN THE FIRST 8 WORDS OF O.N. 84. (CAUTION ****SEE REMARKS) -C -C PROGRAM HISTORY LOG: -C 91-10-07 ORIGINAL AUTHOR MCCLEES, A. J. -C 92-01-06 R.E.JONES CONVERT TO SiliconGraphics 3.3 FORTRAN 77 -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C 94-04-17 R.E.JONES COMPLETE REWRITE TO USE SBYTE, MAKE CODE -C PORTABLE, UPGRADE TO ON388, MAR 24,1994 -C 94-05-05 R.E.JONES CORRECTION IN TWO TABLES -C 96-08-02 R.E.JONES ERROR USING T MARKER -C 96-09-03 R.E.JONES ADD MERCATOR GRIDS 8 AND 53 TO TABLES -C 99-02-15 B. FACEY REPLACE W3FS04 WITH W3MOVDAT. -C 02-10-15 VUONG REPLACED FUNCTION ICHAR WITH MOVA2I -C -C USAGE: CALL W3FP13 (GRIB, PDS, ID8, IERR ) -C INPUT ARGUMENT LIST: -C GRIB - GRIB SECTION 0 READ AS CHARACTER*8 -C PDS - GRIB PDS SECTION 1 READ AS CHARACTER*1 PDS(*) -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C ID8 - 12 INTEGER*4 FORMATTED O.N. 84 ID. -C 6 INTEGER 64 BIT WORDS ON CRAY -C IERR 0 - COMPLETED SATISFACTORILY -C 1 - GRIB BLOCK 0 NOT CORRECT -C 2 - LENGTH OF PDS NOT CORRECT -C 3 - COULD NOT MATCH TYPE INDICATOR -C 4 - GRID TYPE NOT IN TABLES -C 5 - COULD NOT MATCH TYPE LEVEL -C 6 - COULD NOT INTERPRET ORIGINATOR OF CODE -C SUBPROGRAMS CALLED: -C SPECIAL: INDEX, MOVA2I, CHAR, IOR, IAND, ISHFT -C -C LIBRARY: -C W3LIB: W3MOVDAT, W3FI69, W3FI01 -C -C REMARKS: SOME OF THE ID'S WILL NOT BE EXACT TO THE O.N. 84 -C FOR LOCATING FIELD ON THE DATASET. THESE DIFFERENCES -C ARE MAINLY DUE TO TRUNCATION ERRORS WITH LAYERS. -C FOR EXAMPLE: .18019 SIG .47191 SIG R H FOR 36.O HRS -C WILL CONVERT TO: .18000 SIG .47000 SIG R H FOR 36.0 HRS -C !!!!!!!THE ABOVE ID'S NOW FORCED TO BE EXACT!!!!!!!!! -C IF J THE WORD COUNT IS GREATER THEN 32743, J IS STORED -C IN THE 12TH ID WORD. BITS 16-31 OF THE 8TH ID WORD ARE -C SET TO ZERO. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C$$$ -C - INTEGER HH (255) - INTEGER HH1 (127) - INTEGER HH2 (128) - INTEGER LL (255) - INTEGER LL1 (127) - INTEGER LL2 (128) - INTEGER ICXG2 (9) - INTEGER ICXGB2 (9) - INTEGER ICXG1 (7) - INTEGER ICXGB1 (7) -C - INTEGER C1 - INTEGER C2 - INTEGER E1 - INTEGER E2 - INTEGER FTU - INTEGER F1 - INTEGER F2 - INTEGER ID (25) - INTEGER ID8 (12) - INTEGER IDATE - INTEGER JDATE - INTEGER IGEN ( 4) - INTEGER NGRD (34) - INTEGER NPTS (34) - INTEGER P1 - INTEGER P2 - INTEGER S1 -C INTEGER S2 - INTEGER T - INTEGER TR -C - CHARACTER * 8 GRIB - CHARACTER * 8 IGRIB - REAL RINC(5) - INTEGER NDATE(8), MDATE(8) - CHARACTER * 1 IWORK ( 8) - CHARACTER * 1 JWORK ( 8) - CHARACTER * 1 PDS ( *) -C - SAVE -C - EQUIVALENCE (HH(1),HH1(1)) - EQUIVALENCE (HH(128),HH2(1)) - EQUIVALENCE (LL(1),LL1(1)) - EQUIVALENCE (LL(128),LL2(1)) - EQUIVALENCE (IDATE,IWORK(1)) - EQUIVALENCE (JDATE,JWORK(1)) -C - DATA HH1 / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, - & 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, - & 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, - & 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, - & 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, - & 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, - & 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, - & 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, - & 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, - & 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, - & 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, - & 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, - & 121, 122, 123, 124, 125, 126, 127/ - DATA HH2 / 128, 129, 130, - & 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, - & 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, - & 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, - & 161, 162, 163, 164, 165, 166, 167, 168, 169, 170, - & 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, - & 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, - & 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, - & 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, - & 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, - & 221, 222, 223, 224, 225, 226, 227, 228, 229, 230, - & 231, 232, 233, 234, 235, 236, 237, 238, 239, 240, - & 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, - & 251, 252, 253, 254, 255/ -C - DATA IGEN / 7, 58, 66, 98/ -C -C ########### NUMBERS FORCED AFTER CONVERTING FROM GRIB LAYER. -C ICXG2 1.0000, .98230, .96470, -C .85000, .84368, .47191, -C .18017, .81573, .25011 -C ################# -C - DATA ICXG2 /Z'00002710', Z'00017FB6', Z'000178D6', - A Z'00014C08', Z'00014990', Z'0000B857', - A Z'00004663', Z'00013EA5', Z'000061B3'/ -C -C ########### NUMBERS CALCULATED BY GRIB LAYER. -C ICXGB2 1.00000, .98000, .96000, -C .85000, .84000, .47000, -C .18000, .82000, .25000 -C ################# -C - DATA ICXGB2/Z'00002710', Z'00017ED0', Z'00017700', - A Z'00014C00', Z'00014820', Z'0000B798', - A Z'00004650', Z'00014050', Z'000061A8'/ -C -C ########### NUMBERS FORCED AFTER CONVERTING FROM GRIB SINGLE. -C ICXG1 .98230, .89671, .78483 -C .94316, .84367, .999.00, .25011 -C ################# -C - DATA ICXG1 /Z'00017FB6', Z'00015E47', Z'00013293', - A Z'0001706C', Z'0001498F', Z'0000863C', Z'000061B3'/ -C -C ########### NUMBERS CALCULATED BY GRIB LAYER. -C ICXGB1 .98230, .89670, .78480 -C .94320, .84370, 998.00, .25000 -C ################# -C - DATA ICXGB1/Z'00017FB6', Z'00015E46', Z'00013290', - A Z'00017070', Z'00014992', Z'000185D8', Z'000061A8'/ -C - DATA LL1 / 8, 8, 9, 255, 255, 255, 1, 6, 255, 255, - & 16, 24, 19, 23, 20, 21, 17, 18, 255, 180, - & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, - & 55, 50, 48, 49, 80, 81, 71, 255, 40, 42, - & 72, 74, 73, 255, 255, 255, 255, 255, 304, 305, - & 95, 88, 101, 89, 104, 255, 117, 255, 97, 98, - & 90, 105, 94, 255, 255, 93, 188, 255, 255, 255, - & 255, 211, 255, 255, 255, 255, 255, 255, 255, 384, - & 161, 255, 255, 169, 22, 255, 255, 255, 255, 255, - & 255, 255, 255, 255, 255, 255, 255, 255, 255, 400, - & 389, 385, 388, 391, 386, 390, 402, 401, 404, 403, - & 204, 255, 255, 255, 255, 255, 255, 255, 255, 255, - & 195, 194, 255, 255, 255, 255, 255/ - DATA LL2 / 255, 255, 255, - & 112, 116, 114, 255, 103, 52, 255, 255, 255, 255, - & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, - & 255, 255, 255, 255, 255, 119, 157, 158, 159, 255, - & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, - & 255, 255, 255, 255, 255, 176, 177, 255, 255, 255, - & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, - & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, - & 392, 255, 255, 192, 190, 255, 199, 216, 189, 255, - & 193, 191, 210, 107, 255, 198, 255, 255, 255, 255, - & 255, 1, 255, 255, 255, 255, 255, 255, 255, 255, - & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, - & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, - & 255, 160, 255, 255, 255/ -C - DATA NPTS / 1679, 259920, 3021, 2385, 5104, 4225, - & 4225, 5365, 5365, 8326, 8326, - & 5967, 6177, 6177, 12321, 12321, 12321, - & 32400, 32400, 5022, 12902, 25803, - & 24162, 48232, 18048, 6889, 10283, - & 3640, 16170, 6889, 19305, 11040, - & 72960, 6693/ -C - DATA NGRD / 1, 4, 5, 6, 8, 27, - & 28, 29, 30, 33, 34, - & 53, 55, 56, 75, 76, 77, - & 85, 86, 87, 90, 91, - & 92, 93, 98, 100, 101, - & 103, 104, 105, 106, 107, - & 126, 214/ -C -C DATA MSK1 /Z0000FFFF/, -C & MSK2 /Z00000080/, -C & MSK3 /Z00000000/, -C & MSK4 /Z00000200/ -C CHANGE HEX TO DECIMAL TO MAKE SUBROUTINE MORE PORTABLE -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - DATA MSK1 /65535/, - & MSK2 /128/, - & MSK3 /0/, - & MSK4 /512/ -C -C MAKE SECTION 0, PUT 'GRIB' IN ASCII -C - IGRIB(1:1) = CHAR(71) - IGRIB(2:2) = CHAR(82) - IGRIB(3:3) = CHAR(73) - IGRIB(4:4) = CHAR(66) - IGRIB(5:5) = CHAR(0) - IGRIB(6:6) = CHAR(0) - IGRIB(7:7) = CHAR(0) - IGRIB(8:8) = CHAR(1) -C -C CONVERT PDS INTO 25 INTEGER NUMBERS -C - CALL W3FI69(PDS,ID) -C -C ID(1) = NUMBER OF BYTES IN PDS -C ID(2) = PARAMETER TABLE VERSION NUMBER -C ID(3) = IDENTIFICATION OF ORIGINATING CENTER -C ID(4) = MODEL IDENTIFICATION (ALLOCATED BY ORIGINATING CENTER) -C ID(5) = GRID IDENTIFICATION -C ID(6) = 0 IF NO GDS SECTION, 1 IF GDS SECTION IS INCLUDED -C ID(7) = 0 IF NO BMS SECTION, 1 IF BMS SECTION IS INCLUDED -C ID(8) = INDICATOR OF PARAMETER AND UNITS -C ID(9) = INDICATOR OF TYPE OF LEVEL OR LAYER -C ID(10) = LEVEL 1 -C ID(11) = LEVEL 2 -C ID(12) = YEAR OF CENTURY -C ID(13) = MONTH OF YEAR -C ID(14) = DAY OF MONTH -C ID(15) = HOUR OF DAY -C ID(16) = MINUTE OF HOUR (IN MOST CASES SET TO 0) -C ID(17) = FCST TIME UNIT -C ID(18) = P1 PERIOD OF TIME -C ID(19) = P2 PERIOD OF TIME -C ID(20) = TIME RANGE INDICATOR -C ID(21) = NUMBER INCLUDED IN AVERAGE -C ID(22) = NUMBER MISSING FROM AVERAGES OR ACCUMULATIONS -C ID(23) = CENTURY -C ID(24) = IDENTIFICATION OF SUB-CENTER (TABLE 0 - PART 2) -C ID(25) = SCALING POWER OF 10 -C -C THE 1ST 8 32 BIT WORDS WITH THE OFFICE NOTE 84 ID'S ARE -C IN 27 PARTS, SBYTE IS USED WITH BIT COUNTS TO MAKE THIS -C DATA. THIS MAKE IT WORD SIZE INDEPENDENT, AND MAKES THIS -C SUBROUTINE PORTABLE. TABLE WITH STARTING BITS IS NEXT. -C THE STARTING BIT AND NO. OF BITS IS USED AS THE 3RD AND -C 4TH PARAMETER FOR SBYTE. READ GBYTES DOCUMENT FROM NCAR -C FOR INFORMATION ABOUT SBYTE. SEE PAGE 38, FIGURE 1, IN -C OFFICE NOTE 84. -C -C NO. NAME STARTING BIT NO. OF BITS -C ----------------------------------------- -C 1 Q 0 12 -C 2 S1 12 12 -C 3 F1 24 8 -C 4 T 32 4 -C 5 C1 36 20 -C 6 E1 56 8 -C 7 M 64 4 -C 8 X 68 8 -C 9 S2 76 12 -C 10 F2 88 8 -C 11 N 96 4 -C 12 C2 100 20 -C 13 E2 120 8 -C 14 CD 128 8 -C 15 CM 136 8 -C 16 KS 144 8 -C 17 K 152 8 -C 18 GES 160 4 -C 19 164 12 -C 20 NW 176 16 -C 21 YY 192 8 -C 22 MM 200 8 -C 23 DD 208 8 -C 24 II 216 8 -C 25 R 224 8 -C 26 G 232 8 -C 27 J 240 16 -C OR 27 J 352 32 J > 32743 -C---------------------------------------------- -C -C$ 1.0 INITIALIZATION - NO. OF ENTRIES IN INDCATOR PARM. -C$ - NO. OF ENTRIES IN TYPE LEVEL -C$ - NO. OF ENTRIES IN CNTR PROD. DTA. -C$ - INITIAL ZEROS IN O.N. 84 LABEL -C - IQ = 255 - IC = 4 - IN = 34 -C -C TEST FOR 32 OR 64 BIT COMPUTER (CRAY) -C - CALL W3FI01(LW) - IF (LW.EQ.4) THEN - NWORDS = 12 - ELSE - NWORDS = 6 - END IF -C -C ZERO OUTPUT ARRAY -C - DO N = 1,NWORDS - ID8(N) = 0 - END DO -C -C --------------------------------------------------------------------- -C$ 2.0 VERIFY GRIB IN SECTION 0 -C - IF (.NOT. GRIB(1:4) .EQ. IGRIB(1:4)) THEN - IERR = 1 - RETURN - END IF -C -C 2.1 VERIFY THE NO. OF OCTETS IN THE PDS -C - IF (ID(1).NE.28) THEN - IERR = 2 - PRINT *,'IERR = ',IERR,',LENGTH OF PDS = ',ID(1) - RETURN - END IF -C -C$ 3.0 GENERATING MODEL, TYPE GRID, AND NO. OF GRID PTS. -C -C IF CENTER NOT U.S., STORE CENTER IN G MARKER -C IF CENTER U.S. STORE MODEL NO. IN G MARKER -C - IF (ID(3) .NE. 7) THEN - CALL SBYTE(ID8,ID(3),232,8) - ELSE - CALL SBYTE(ID8,ID(4),232,8) - END IF -C - DO KK = 1,IN - IF (ID(5) .EQ. NGRD(KK)) THEN - IGRDPT = NPTS(KK) - IF (ID(5) .EQ. 6) ID(5) = 26 - CALL SBYTE(ID8,ID(5),152,8) - IF (IGRDPT.LE.32743) THEN - CALL SBYTE(ID8,IGRDPT,240,16) - ELSE - CALL SBYTE(ID8,IGRDPT,352,32) - END IF - GO TO 350 - END IF - END DO - IERR = 4 - PRINT *,'IERR = ',IERR,',GRID TYPE = ',ID(5) - RETURN -C - 350 CONTINUE -C -C COMPUTE R MARKER FROM MODEL NUMBERS FOR U.S. CENTER -C -C (ERL) run - IF (ID(3).EQ.7) THEN - IF (ID(4).EQ.19.OR.ID(4).EQ.53.OR.ID(4).EQ.83.OR. - & ID(4).EQ.84.OR.ID(4).EQ.85) THEN - CALL SBYTE(ID8,0,224,8) -C (NMC) run - ELSE IF (ID(4).EQ.25) THEN - CALL SBYTE(ID8,1,224,8) -C (RGL) run - ELSE IF (ID(4).EQ.39.OR.ID(4).EQ.64) THEN - CALL SBYTE(ID8,2,224,8) -C (AVN) run - ELSE IF (ID(4).EQ.10.OR.ID(4).EQ.42.OR. - & ID(4).EQ.68.OR.ID(4).EQ.73.OR. - & ID(4).EQ.74.OR.ID(4).EQ.75.OR. - & ID(4).EQ.77.OR.ID(4).EQ.81.OR. - & ID(4).EQ.88) THEN - CALL SBYTE(ID8,3,224,8) -C (MRF) run - ELSE IF (ID(4).EQ.69.OR.ID(4).EQ.76.OR. - & ID(4).EQ.78.OR.ID(4).EQ.79.OR. - & ID(4).EQ.80.oR.ID(4).EQ.87) THEN - CALL SBYTE(ID8,4,224,8) -C (FNL) run - ELSE IF (ID(4).EQ.43.OR.ID(4).EQ.44.OR. - & ID(4).EQ.82) THEN - CALL SBYTE(ID8,5,224,8) -C (HCN) run - ELSE IF ( ID(4).EQ.70) THEN - CALL SBYTE(ID8,6,224,8) -C (RUC) run - ELSE IF ( ID(4).EQ.86) THEN - CALL SBYTE(ID8,7,224,8) -C Not applicable, set to 255 - ELSE - CALL SBYTE(ID8,255,224,8) - END IF - END IF -C -C$ 4.0 FORM TYPE DATA PARAMETER -C - DO II = 1,IQ - III = II - IF (ID(8) .EQ. HH(II)) THEN - IF (LL(II).NE.255) GO TO 410 - PRINT *,'PDS PARAMETER HAS NO OFFICE NOTE 84 Q TYPE' - PRINT *,'PDS BYTE 9 PARAMETER = ',ID(8) - IERR = 3 - RETURN - END IF - END DO - IERR = 3 - PRINT *,'PDS BYTE 9, PARAMETER = ',ID(8) - RETURN -C - 410 CONTINUE -C -C Q DATA TYPE, BITS 1-12 -C - CALL SBYTE(ID8,LL(III),0,12) -C -C TEST FOR 32 OR 64 BIT COMPUTER (CRAY) -C - IF (LW.EQ.4) THEN - IF (ID(8) .EQ. 211) ID8(5) = IOR (ID8(5),MSK4) - IF (ID(8) .EQ. 210) ID8(5) = IOR (ID8(5),MSK4) - ELSE - IF (ID(8) .EQ. 211) ID8(3) = IOR (ID8(3),ISHFT(MSK4,32)) - IF (ID(8) .EQ. 210) ID8(3) = IOR (ID8(3),ISHFT(MSK4,32)) - END IF -C -C$ 5.0 FORM TYPE LEVEL -C - IF (ID(9) .EQ. 100) THEN - M = 0 - S1 = 8 - CALL SBYTE(ID8,S1,12,12) - CALL SBYTE(ID8,M,64,4) - LEVEL = ID(11) - IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN - E1 = 4 - ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN - E1 = 3 - ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN - E1 = 2 - ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN - E1 = 1 - END IF - C1 = LEVEL * 10 ** E1 - CALL SBYTE(ID8,C1,36,20) - E1 = IOR(E1,MSK2) - CALL SBYTE(ID8,E1,56,8) -C - ELSE IF (ID(9) .EQ. 103) THEN - M = 0 - S1 = 1 - CALL SBYTE(ID8,S1,12,12) - CALL SBYTE(ID8,M,64,4) - LEVEL = ID(11) - IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN - E1 = 4 - ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN - E1 = 3 - ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN - E1 = 2 - ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN - E1 = 1 - END IF - C1 = LEVEL * 10 ** E1 - CALL SBYTE(ID8,C1,36,20) - E1 = IOR(E1,MSK2) - CALL SBYTE(ID8,E1,56,8) -C - ELSE IF (ID(9) .EQ. 105) THEN - M = 0 - S1 = 6 - CALL SBYTE(ID8,S1,12,12) - CALL SBYTE(ID8,M,64,4) - LEVEL = ID(11) - IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN - E1 = 4 - ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN - E1 = 3 - ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN - E1 = 2 - ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN - E1 = 1 - END IF - C1 = LEVEL * 10 ** E1 - CALL SBYTE(ID8,C1,36,20) - E1 = IOR(E1,MSK2) - CALL SBYTE(ID8,E1,56,8) -C - ELSE IF (ID(9) .EQ. 111) THEN - M = 0 - S1 = 7 - CALL SBYTE(ID8,S1,12,12) - CALL SBYTE(ID8,M,64,4) - LEVEL = ID(11) - IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN - E1 = 4 - ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN - E1 = 3 - ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN - E1 = 2 - ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN - E1 = 1 - END IF - C1 = LEVEL * 10 ** E1 - CALL SBYTE(ID8,C1,36,20) -C XXXXXXX SCALE FROM CENTIMETERS TO METERS. XXXXXXXXXX - E1 = IOR(E1,MSK2) - E1 = E1 + 2 - IF (C1 .EQ. 0) THEN - E1 = 0 - END IF - CALL SBYTE(ID8,E1,56,8) -C - ELSE IF (ID(9) .EQ. 107) THEN - M = 0 - S1 = 148 - CALL SBYTE(ID8,S1,12,12) - CALL SBYTE(ID8,M,64,4) - LEVEL = ID(11) - IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN - E1 = 4 - ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN - E1 = 3 - ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN - E1 = 2 - ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN - E1 = 1 - ELSE - E1 = 0 - END IF - C1 = LEVEL * 10 ** E1 - DO ISI = 1,7 - IF (C1 .EQ. ICXGB1(ISI)) THEN - C1 = ICXG1(ISI) - END IF - END DO - CALL SBYTE(ID8,C1,36,20) -C***********SCALING OF .0001 TAKEN INTO ACCOUNT - E1 = E1 + 4 - E1 = IOR(E1,MSK2) - IF (C1 .EQ. 0) THEN - E1 = 0 - END IF - CALL SBYTE(ID8,E1,56,8) -C - ELSE IF (ID(9) .EQ. 4) THEN - M = 0 - S1 = 16 - CALL SBYTE(ID8,S1,12,12) - CALL SBYTE(ID8,M,64,4) -C LEVEL = ID(11) -C******* CONSTANT VALUE OF 273.16 WILL HAVE TO BE INSERTED -C LEVEL = IAND (IPDS(3),MSK1) -C IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN -C E1 = 4 -C ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN -C E1 = 3 -C ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN -C E1 = 2 -C ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN -C E1 = 1 -C END IF - E1 = 2 - C1 = (273.16 * 10 ** E1) + .5 - CALL SBYTE(ID8,C1,36,20) - E1 = IOR(E1,MSK2) - CALL SBYTE(ID8,E1,56,8) -C*************SPECIAL CASES ********************* - ELSE IF (ID(9) .EQ. 102) THEN - M = 0 - S1 = 128 - CALL SBYTE(ID8,S1,12,12) - CALL SBYTE(ID8,0,64,32) -C - ELSE IF (ID(9) .EQ. 1) THEN - M = 0 - S1 = 129 -C***** S1 = 133 ALSO POSSIBILITY - CALL SBYTE(ID8,S1,12,12) - CALL SBYTE(ID8,0,64,32) -C - ELSE IF (ID(9) .EQ. 7) THEN - M = 0 - S1 = 130 - CALL SBYTE(ID8,S1,12,12) - CALL SBYTE(ID8,0,64,32) -C - ELSE IF (ID(9) .EQ. 6) THEN - M = 0 - S1 = 131 - CALL SBYTE(ID8,S1,12,12) - CALL SBYTE(ID8,0,64,32) -C - ELSE IF (ID(9) .EQ. 101) THEN - M = 2 - S1 = 8 - CALL SBYTE(ID8,S1,12,12) - CALL SBYTE(ID8,M,64,4) - CALL SBYTE(ID8,S1,76,12) - LEVEL = ID(10) - LEVEL = (LEVEL * .1) * 10 ** 2 - IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN - E1 = 4 - ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN - E1 = 3 - ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN - E1 = 2 - ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN - E1 = 1 - END IF - C1 = LEVEL * 10 ** E1 - CALL SBYTE(ID8,C1,36,20) - E1 = IOR(E1,MSK2) - CALL SBYTE(ID8,E1,56,8) - LEVEL2 = ID(11) - LEVEL2 = (LEVEL2 * .1) * 10 ** 2 - IF (LEVEL2 .GE. 1 .AND. LEVEL2 .LE. 9) THEN - E2 = 4 - ELSE IF (LEVEL2 .GE. 10 .AND. LEVEL2 .LE. 99) THEN - E2 = 3 - ELSE IF (LEVEL2 .GE. 100 .AND. LEVEL2 .LE. 999) THEN - E2 = 2 - ELSE IF (LEVEL2 .GE. 1000 .AND. LEVEL2 .LE. 9999) THEN - E2 = 1 - END IF - C2 = LEVEL2 * 10 ** E2 - CALL SBYTE(ID8,C2,100,20) - IF (C2 .EQ. 0) E2 = 0 - E2 = IOR(E2,MSK2) - CALL SBYTE(ID8,E2,120,8) -C - ELSE IF (ID(9) .EQ. 104) THEN - M = 2 - S1 = 1 - CALL SBYTE(ID8,S1,12,12) - CALL SBYTE(ID8,M,64,4) - CALL SBYTE(ID8,S1,76,12) - LEVEL = ID(10) - LEVEL = (LEVEL * .1) * 10 ** 2 - IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN - E1 = 4 - ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN - E1 = 3 - ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN - E1 = 2 - ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN - E1 = 1 - END IF - C1 = LEVEL * 10 ** E1 - CALL SBYTE(ID8,C1,36,20) - E1 = IOR(E1,MSK2) - CALL SBYTE(ID8,E1,56,8) - LEVEL2 = ID(11) - LEVEL2 = (LEVEL2 * .1) * 10 ** 2 - IF (LEVEL2 .GE. 1 .AND. LEVEL2 .LE. 9) THEN - E2 = 4 - ELSE IF (LEVEL2 .GE. 10 .AND. LEVEL2 .LE. 99) THEN - E2 = 3 - ELSE IF (LEVEL2 .GE. 100 .AND. LEVEL2 .LE. 999) THEN - E2 = 2 - ELSE IF (LEVEL2 .GE. 1000 .AND. LEVEL2 .LE. 9999) THEN - E2 = 1 - END IF - C2 = LEVEL2 * 10 ** E2 - CALL SBYTE(ID8,C2,100,20) - E2 = IOR(E2,MSK2) - CALL SBYTE(ID8,E2,120,8) -C - ELSE IF (ID(9) .EQ. 106) THEN - M = 2 - S1 = 6 - CALL SBYTE(ID8,S1,12,12) - CALL SBYTE(ID8,M,64,4) - CALL SBYTE(ID8,S1,76,12) - LEVEL = ID(10) - LEVEL = (LEVEL * .1) * 10**2 - IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN - E1 = 4 - ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN - E1 = 3 - ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN - E1 = 2 - ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN - E1 = 1 - END IF - C1 = LEVEL * 10 ** E1 - CALL SBYTE(ID8,C1,36,20) - E1 = IOR(E1,MSK2) - CALL SBYTE(ID8,E1,56,8) - LEVEL2 = ID(10) - LEVEL2 = (LEVEL2 * .1) * 10 ** 2 - IF (LEVEL2 .GE. 1 .AND. LEVEL2 .LE. 9) THEN - E2 = 4 - ELSE IF (LEVEL2 .GE. 10 .AND. LEVEL2 .LE. 99) THEN - E2 = 3 - ELSE IF (LEVEL2 .GE. 100 .AND. LEVEL2 .LE. 999) THEN - E2 = 2 - ELSE IF (LEVEL2 .GE. 1000 .AND. LEVEL2 .LE. 9999) THEN - E2 = 1 - END IF - C2 = LEVEL2 * 10 ** E2 - CALL SBYTE(ID8,C2,100,20) - E2 = IOR(E2,MSK2) - CALL SBYTE(ID8,E2,120,8) -C - ELSE IF (ID(9) .EQ. 108) THEN - M = 2 - S1 = 148 -C**** S1 = 144 ALSO POSSIBILITY -C**** S1 = 145 ALSO POSSIBILITY - CALL SBYTE(ID8,S1,12,12) - CALL SBYTE(ID8,M,64,4) - CALL SBYTE(ID8,S1,76,12) - LEVEL = ID(10) - LEVEL = LEVEL - IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN - E1 = 4 - ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN - E1 = 3 - ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN - E1 = 2 - ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN - E1 = 1 - END IF - C1 = LEVEL * (10 ** E1) - DO ISI = 1,9 - IF (C1 .EQ. ICXGB2(ISI)) THEN - C1 = ICXG2(ISI) - END IF - END DO - CALL SBYTE(ID8,C1,36,20) - IF (C1 .EQ. 0) THEN - E1 = 0 - CALL SBYTE(ID8,E1,56,8) - GO TO 700 - END IF -C*****TAKE SCALING INTO ACCOUNT .01 - E1 = E1 + 2 - E1 = IOR(E1,MSK2) - CALL SBYTE(ID8,E1,56,8) -C - 700 CONTINUE - LEVEL2 = ID(11) - LEVEL2 = LEVEL2 - IF (LEVEL2 .GE. 1 .AND. LEVEL2 .LE. 9) THEN - E2 = 4 - ELSE IF (LEVEL2 .GE. 10 .AND. LEVEL2 .LE. 99) THEN - E2 = 3 - ELSE IF (LEVEL2 .GE. 100 .AND. LEVEL2 .LE. 999) THEN - E2 = 2 - ELSE IF (LEVEL2 .GE. 1000 .AND. LEVEL2 .LE. 9999) THEN - E2 = 1 - END IF - C2 = LEVEL2 * 10 ** E2 - DO ISI = 1,9 - IF (C2 .EQ. ICXGB2(ISI)) THEN - C2 = ICXG2(ISI) - END IF - END DO - CALL SBYTE(ID8,C2,100,20) - E2 = IOR(E2,MSK2) - CALL SBYTE(ID8,E2,120,8) -C*******TAKE SCALING INTO ACCOUNT .01 - E2 = E2 + 2 - E2 = IOR(E2,MSK2) - CALL SBYTE(ID8,E2,120,8) -C - END IF -C 5.1 FORCAST TIMES ,PLUS THE T MARKER AND CM FIELD -C - TR = ID(20) - IF (TR .EQ. 0) THEN - P1 = ID(18) - CALL SBYTE(ID8,ID(18),24,8) - ELSE IF (TR .EQ. 4) THEN - P2 = ID(19) - CALL SBYTE(ID8,P2,24,8) - P1 = ID(18) - CALL SBYTE(ID8,(P2 - P1),88,8) - T = 3 - CALL SBYTE(ID8,T,32,4) - ELSE IF (TR .EQ. 5) THEN - P2 = ID(19) - CALL SBYTE(ID8,P2,24,8) - P1 = ID(18) - CALL SBYTE(ID8,(P2 - P1),88,8) - T = 3 - CALL SBYTE(ID8,T,32,4) -C - ELSE IF (TR .EQ. 124) THEN - FTU = ID(17) - IF (FTU .EQ. 2) THEN - F1 = ID(21) - CALL SBYTE(ID8,F1,24,8) - T = 4 - CALL SBYTE(ID8,T,32,4) - ELSE IF (FTU .EQ. 4) THEN - F2 = ID(21) - CALL SBYTE(ID8,F2,88,8) - T = 4 - CALL SBYTE(ID8,T,32,4) - END IF -C - ELSE IF (TR .EQ.123) THEN - F1 = 3 - F1 = IOR(F1,MSK2) - CALL SBYTE(ID8,F1,24,8) - F2 = 5 * 2 - CALL SBYTE(ID8,F2,88,8) - T = 6 - CALL SBYTE(ID8,T,32,4) - RINC = 0.0 - RINC(2) = 36.0 - IYR=MOVA2I(PDS(13)) - PRINT *, 'IYR = ', IYR - IF(IYR.LT.20)THEN - MDATE(1)=2000+IYR - ELSE - MDATE(1)=1900+IYR - ENDIF - MDATE(2) = MOVA2I(PDS(14)) - MDATE(3) = MOVA2I(PDS(15)) - MDATE(5) = MOVA2I(PDS(16)) -C PRINT *, 'OLD DATE = ', MDATE(1), MDATE(2), MDATE(3), MDATE(5) -C PRINT *, 'CHANGE DATE BY - ', RINC(2) - CALL W3MOVDAT(RINC,MDATE,NDATE) -C PRINT *, 'NEW DATE = ', NDATE(1), NDATE(2), NDATE(3), NDATE(5) -C CALL W3FS04 (IDATE,JDATE,3,IERR) - IYEAR = MOD(NDATE(1),100) - JWORK(1) = CHAR(IYEAR) - JWORK(2) = CHAR(NDATE(2)) - JWORK(3) = CHAR(NDATE(3)) - JWORK(4) = CHAR(NDATE(5)) - IDATE = JDATE - GO TO 710 -C - ELSE IF (TR .EQ.3) THEN - P1 = ID(18) - P2 = ID(19) - F1 = P1 / 12 - CALL SBYTE(ID8,F1,24,8) -C -C ***** NAVG IS IN BITES 22 23 ***** -C USING BITE 23 ONLY ******* -C FIX LATER ****************************************** -C -C NAVG = MOVA2I(PDS(23)) - F2 = (P2 - P1) / 12 - CALL SBYTE(ID8,F2,88,8) - T = 6 - CALL SBYTE(ID8,T,32,4) - RINC = 0.0 - RINC(2) = -36.0 - IYR=MOVA2I(PDS(13)) - PRINT *, 'IYR = ', IYR - IF(IYR.LT.20)THEN - MDATE(1)=2000+IYR - ELSE - MDATE(1)=1900+IYR - ENDIF - MDATE(2) = MOVA2I(PDS(14)) - MDATE(3) = MOVA2I(PDS(15)) - MDATE(5) = MOVA2I(PDS(16)) -C PRINT *, 'OLD DATE = ', MDATE(1), MDATE(2), MDATE(3), MDATE(5) -C PRINT *, 'CHANGE DATE BY - ', RINC(2) - CALL W3MOVDAT(RINC,MDATE,NDATE) -C PRINT *, 'NEW DATE = ', NDATE(1), NDATE(2), NDATE(3), NDATE(5) -C CALL W3FS04 (IDATE,JDATE,-3,IERR) - IYEAR = MOD(NDATE(1),100) - JWORK(1) = CHAR(IYEAR) - JWORK(2) = CHAR(NDATE(2)) - JWORK(3) = CHAR(NDATE(3)) - JWORK(4) = CHAR(NDATE(5)) - IDATE = JDATE - GO TO 710 - END IF -C -C$ 7.0 TRANSFER THE DATE -C - IWORK(1) = PDS(13) - IWORK(2) = PDS(14) - IWORK(3) = PDS(15) - IWORK(4) = PDS(16) -C - 710 CONTINUE -C -C TEST FOR 64 BIT COMPUTER (CRAY) -C - IF (LW.EQ.8) IDATE = ISHFT(IDATE,-32) - CALL SBYTE(ID8,IDATE,192,32) -C - IERR = 0 - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fq07.f b/src/fim/FIMsrc/w3/w3fq07.f deleted file mode 100644 index b53783b..0000000 --- a/src/fim/FIMsrc/w3/w3fq07.f +++ /dev/null @@ -1,498 +0,0 @@ - SUBROUTINE W3FQ07(LPARM,NUMBYT,OUTFIL,CARDFIL,KRTN) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FQ07 SENDS FAX,VARIAN,AFOS,AWIPS, MAPS & BULLS -C PRGMMR: HENRICHSEN ORG: W/NP12 DATE: 97-01-09 -C -C ABSTRACT: SETS UP THE ARGUEMENTS FOR SUB DBN_ALERT -C WHICH POSTS TRANSMISSION AVAILABILITY TO VARIOUS STATFILES. -C THE INPUT KEY WORDS FOR W3FQ07 MAY BE READ IN VIA THE PARM FIELD -C OR FROM A DATA CARD SEE REMARKS FOR EXAMPLES. -C -C -C PROGRAM HISTORY LOG: -C 97-01-09 ORGIONAL AUTHOR HENRICHSEN -C -C USAGE: CALL W3FQ07(LPARM, NUMBYT, OUTFIL, CARDFIL, KRTN) -C INPUT ARGUMENT LIST: -C LPARM - CHARACTER*1 100 BYTE ARRAY CONTAINING ASCII -C FLAGS AND KEY WORDS. -C NUMBYT - INTEGER NUMBER OF BYTES OF ASCII DATA IN LPARM. -C OUTFIL - INTEGER UNIT NUMBER OF FILE TO POST TO THE -C TELECOMMUNICATIONS GATEWAY COMPUTER SYSTEM. -C CARDFIL - INTEGER UNIT NUMBER OF FILE TO READ TO GET DATA -C CONTROL CARD IN LUE OF PARM. THIS IS ONLY NECESSARY -C WHEN PARM(5:5) = 'A'. -C OUTPUT ARGUMENT LIST: -C KRTN - SEE RETURN CONDITIONS. -C -C RETURN CONDITIONS: -C KRTN = 0 GOOD RETURN, FILE POSTED FOR TRANSMISSION -C KRTN = 1 GOOD RETURN, FILE NOT POSTED FOR TRANSMISSION -C TEST FLAG WAS ON IE K=TEST OR THERE WAS AN "N" -C THE 1ST BYTE OF THE INPUT DATA CARD. -C KRTN = 2 BAD RETURN, POSTING NOT ATTEMPTED, THE "K" KEY -C WAS MISSING. -C KRTN = 3 BAD RETURN, POSTING NOT ATTEMPTED, PARM LESS THAN -C THAN 6 BYTES. -C KRTN = 4 BAD RETURN, CARD READER EMPTY. -C KRTN = 5 BAD RETURN, ERROR RETURN FROM SUB DBN_ALERT. -C -C INPUT FILES: -C FTNNF001 - FILE THAT CONTAINS THE DATA TO SEND. -C WHERE 'NN' CAN BE ANY NUMBER FROM 01 TO 99 -C EXCEPT 5 OR 6. THIS FILE MUST BE ASSIGNED WITH U:NN. -C FTXXF001 - INPUT CARDS, ONLY NECESSARY IF LPARM(3-6) ='CARD'. -C A SAMPLE DATA CARD IS: -C M=FT24F001,K=AFOS -C (ALL ON ONE CARD STARTING IN COL 1). -C IF COL 1 = 'N' THEN THE DATA SET IS NOT POSTED -C TO THE MONITIOR,IE., W3FQ07 WILL RETURN TO CALLING -C PROGRAM WITH OUT SENDING THE PRODUCT. -C (XX HAS DEFAULT OF 05. HOWEVER THIS NUMBER CAN -C BE ANY UNIT NUMBER YOU WISH. -C -C OUTPUT FILES: -C FT06F001 - PRINT FILE. -C -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C COMMON - CONSOL DBN_ALERT - -C -C REMARKS: THE KEY WORDS THAT ARE PASSED TO SUB IN LPARM MAY -C BE IN ANY ORDER IN THE LPARM ARRAY OR DATA CARD. -C THERE IS ONE KEY WORD THAT IS MANDATORY. -C THEY ARE: -C K=KKKKKKK -C -C -C WHERE KKKKKKKK IS UP TO A 24 BYTE ASCII KEYWORD LEFT-JUSTIFIED -C WHICH IDENTIFIES WHAT DBNET IS TO DO WITH THE INPUT DATA FILE. -C -C 'KKKKKKKK' IS GENERALLY A KEYWORD SUCH AS: -C 'FAXX', 'TRAN','AFOS','AWIP' BUT MAY BE: -C ANY ONE OF THESE type-keys. -C -C type-keys FUNCTIONS -C -C AFOS, Posts AFOS utf map file to CRAY OSO'S statusfile. -C AWIP, Posts AWIPS map file to CRAY OSO'S statusfile. -C FAXX, Posts nmc6bit map file to CRAY OSO'S statusfile. -C GRIB, Posts wmo grib file to CRAY OSO'S statusfile. -C TRAN, Posts wmo bulletin file to CRAY OSO'S statusfile. -C XTRN, Posts xtrn file to CRAY OSO'S statusfile. -C IG_DATA_ipsa1, Sends data file to the intergraph ipsa1. -C IG_DATA_ipsa2, Sends data file to the intergraph ipsa2. -C IG_DATA_lzr_srv1, Sends data file to the intergraph lzr_srv1. -C IG_PLTF_ipsa1, Sends AFOS plot file to the intergraph ipsa1. -C IG_PLTF_ipsa2, Sends AFOS plot file to the intergraph ipsa2. -C IG_PLTF_lzr_srv1, Sends AFOS plot file to the intergraph lzr_srv1. -C IG_6BIT_lzr_srv1, Sends nmc6bit file to the intergraph lzr_srv1. -C TPC_6BIT_nhc-hp13, Sends nmc6bit file to nhc-hp13 at TPC. -C OSO_IG_6BIT_lzr_srv1, Posts nmc6bit file to CRAY OSO'S -C statusfile and then Sends nmc6bit file -C to the intergraph lzr_srv1. -C OSO_TPC_6BIT_nhc-hp13, Posts nmc6bit file to CRAY OSO'S -C statusfile and then Sends nmc6bit file -C to nhc-hp13 at TPC. -C -C WHERE OUTFIL IS THE FILE NUMBER CONTAING THE DATA. -C A SAMPLE: -C M=PETERS,K=FAXX WHERE A ',' OR A ' ' TERMINATES THE KEY WORD. -C WHERE A COMMA OR BLANK TERMINATES THE KEY WORD. -C -C THE M= IS AN OPTIONAL KEY WORD. THE 'M' KEY WORD IS THE MODEL NAME -C IF IF MISSING THE "MISSING" IS USED OTHER WISE IT MAY BY ANY -C 24 BYTE ASCII STRING. -C A SAMPLE: -C M=AVN,K=AFOS, -C WHERE A COMMA OR BLANK TERMINATES THE KEY WORD. -C -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN 77 . -C MACHINE: CRAY -C -C$$$ -C -C - CHARACTER*(*) LPARM -C - CHARACTER*80 BLNK80 - CHARACTER*80 FILNAM - CHARACTER*80 OUTXT - CHARACTER*80 STRING - -C - CHARACTER*55 CHTEST - DATA CHTEST - 1/'THIS WAS A TEST, PRODUCTS NOT POSTED FOR TRANSMISSION.:'/ -C '1234567890123456789012345678901234567890123456789012345 -C - CHARACTER*52 NOTSNT - DATA NOTSNT - 1 /'** FILE NOT POSTED FOR TRANSMISSION AVAILABILITY **:'/ -C '1234567890123456789012345678901234567890123456789012'/ -C - - CHARACTER*52 MESAG1 - DATA MESAG1 - 1 /'FILE NOT POSTED FOR TRANSMISSION, FOUND BYPASS FLAG:'/ -C 1 /'1234567890123456789012345678901234567890123456789012/ - CHARACTER*56 MESAG2 - DATA MESAG2 - 1 /'FILE NOT POSTED FOR TRANSMISSION, "K" KEY FLAG MISSINGS:'/ -C 1 /'12345678901234567890123456789012345678901234567890123456 - CHARACTER*46 MESAG3 - DATA MESAG3 - 1 /'ERROR W3FQ07, LESS THAN 6 BYTES IN PARM FIELD:'/ -C 1 /'12345678901234567890123456789012345678901234567890123456'/ - - CHARACTER*55 MESAG4 - DATA MESAG4 - 1 /'ERROR W3FQ07, CARD FILE EMPTY. CHECK JCL CARD FIILE :'/ - CHARACTER*42 MESAG5 - DATA MESAG5 - 1 /'ERROR RETURN FROM SUB DBN_ALERT,RETURN= :'/ -C 1 /'12345678901234567890123456789012345678901234567890123456'/ -C - CHARACTER*40 BLNK40 - DATA BLNK40 - 1 /' '/ - CHARACTER*24 BUFFER - DATA BUFFER/' '/ - CHARACTER*24 JOBNAM - DATA JOBNAM/'UNKOWN '/ -C - CHARACTER*12 CTEXT - CHARACTER*4 CPLMIZ - DATA CPLMIZ /'L999'/ -C - CHARACTER*04 LTRS - DATA LTRS /'K=M='/ -C - CHARACTER*24 BLANK - DATA BLANK /' '/ - - CHARACTER*24 IFAXX - DATA IFAXX /'FAXX '/ - - CHARACTER*24 KEYWRD - CHARACTER*24 MODNAM -C - CHARACTER*4 AWIP - DATA AWIP /'AWIP'/ - CHARACTER*4 IFAX - DATA IFAX /'FAX '/ - -C - CHARACTER*1 IQUOT -C - DATA INUNIT /5/ - INTEGER CARDFIL - INTEGER OUTFIL -!JFM INTEGER_4 NK,NM,NJ,NF,KRET4 - INTEGER NK,NM,NJ,NF,KRET4 !JFM -C - - LOGICAL*1 BYPASS - LOGICAL*1 GOTFLN - LOGICAL*1 GOTKEY - LOGICAL*1 GOTMOD - LOGICAL*1 GOTJOB - LOGICAL*1 LCARDS - LOGICAL*1 KPRINT -C - IQUOT = CHAR(27) - BLNK80 = BLNK40//BLNK40 -C -C - WRITE(6,FMT='('' USING W3FQ07 CRAY VERSION 97.008 08:40.'')') -C -C . . . PICKUP PARAMETERS. -C -C . . . CHECK TO SEE IF BYTE COUNT LESS THAN 6 IF SO PRODUCT NOT SENT. -C - IF(NUMBYT.LT.6) THEN -C -C . . . BYTE COUNT LESS THAN 6. -C - KRTN = 3 - WRITE(6,FMT='('' W3FQ07: '',A)') NOTSNT(1:52) - WRITE(6,FMT='('' W3FQ07: '',A)') MESAG3(1:46) - CALL CONSOL(NOTSNT) - CALL CONSOL(MESAG3) - ELSE - -C -C . . . BYTE COUNT GREATER THAN OR EQUAL TO 6, -C . . . START TO PROCESS FLAGS -C -C - LCARDS = .FALSE. - GOTKEY = .FALSE. - GOTMOD = .FALSE. - GOTJOB = .FALSE. - GOTFLN = .FALSE. - - IF(LPARM(5:5).EQ.'A') LCARDS = .TRUE. -C -C . . . . FILL KEYS WITH BLANKS. -C - IF(LCARDS)THEN -C - NUMBYT = 80 -C -C . . . BLANK OUT LPARM............................. -C - LPARM(1:NUMBYT) = BLNK80(1:NUMBYT) -C -C . . . READ DATA CARD TO GET DATA KEYWORDS TO SEND. -C -C CHECK TO SEE IF CARDFIL IS GOOD -C - IF(CARDFIL.GT.0)THEN - ELSE - CARDFIL = INUNIT - ENDIF - WRITE(6,FMT='('' W3FQ07: READING CARD FROM UNIT '', - 1 I4)') CARDFIL - READ(CARDFIL,FMT='(80A1)',END=940) - 1 (LPARM(I:I),I=1,NUMBYT) -C - WRITE(6,FMT='('' W3FQ07: PARM='', - 1 A)')LPARM(1:NUMBYT) -C -C CHECK TO SEE IF INTERFACE OFF FLAG IS SET.... -C . . . . IF THERE IS AN 'N' IN THE 1ST COL OF DATA CARD CALL TO -C DBN_ALERT WILL BE BYPASSED. -C - IF(LPARM(1:1).EQ.'N') BYPASS = .TRUE. -C -C -C CHECK TO SEE IF EXTRA PRINT FLAG IS SET.... -C . . . . IF THERE IS AN 'P' IN THE 1ST COL OF DATA CARD -C TURN ON 'KPRNT' FLAG. -C - KPRINT = .FALSE. - IF(LPARM(1:1).EQ.'P') KPRINT = .TRUE. - ENDIF - IF(KPRINT)THEN - WRITE(6,FMT='('' PARM='',A)') LPARM(1:NUMBYT) - ENDIF -C - IF(BYPASS)THEN - WRITE(6,FMT='(1H0,A)')MESAG1(1:52) - KRTN = 7 - CALL CONSOL(MESAG1) - ELSE - IF(.NOT.LCARDS) - 1 WRITE(6,FMT='('' PARM='',A)') LPARM(1:NUMBYT) - NUM = 0 - DO 840 LK = 1,10,2 -C - DO 820 MM = 1,NUMBYT -C - NEXT = MM+1 - IF(LPARM(MM:NEXT).EQ.LTRS(LK:LK+1))THEN - KSTART = NEXT + 1 - LOC = NEXT + 1 -C WRITE(6,FMT='('' FOUND'',A,'' AT LOC '',I3, -C 1 '' AND WILL START SEARCHING AT'',I4,'' IN ARRAY '', -C 2 ''OF LENGHT'',I4)')LPARM(MM:NEXT),MM,KSTART,NUMBYT -C - LLOC = 0 - DO 8010 NI = KSTART,NUMBYT - LOC = NI - IF(LPARM(NI:NI).EQ.',')THEN - ELSE IF(LPARM(NI:NI).EQ.IQUOT)THEN - ELSE IF(LPARM(NI:NI).EQ.' ')THEN - ELSE - LLOC = NI - GO TO 8010 - ENDIF - GO TO 8015 -8010 CONTINUE - WRITE(6,FMT='('' I FELL THROUGH LOOP WITH LOC='',I4, - 1 '' WITH LLOC='',I4,'' & KSTART='',I4, - 2 '' NUMBYT='',I4,'' THEREFORE ADD "1" TO LOC'')') - 3 LOC,LLOC,KSTART,NUMBYT - IF(LLOC.EQ.KSTART) LOC = LLOC + 1 -8015 CONTINUE - IF(LOC.GT.KSTART) THEN -C -C HAVE A FLAG LOAD IT INTO PROPER WORD -C -C IF(KPRINT) THEN - WRITE(6,FMT='('' FOUND THE KEY WORD: '',A, - 1 '' AT LOCATION '',I2,'' IN LPARM ARRAY.'',/)') - 2 LPARM(KSTART:LLOC),KSTART -C ENDIF - IF(LK.EQ.1) THEN - - KEYWRD = LPARM(KSTART:LLOC) - NK = LLOC - KSTART+1 - GOTKEY = .TRUE. - NUM = NUM + 1 - ELSE IF(LK.EQ.3) THEN - MODNAM = LPARM(KSTART:LLOC) - NM = LLOC - KSTART+1 - GOTMOD = .TRUE. - NUM = NUM + 1 - ENDIF - ELSE - GO TO 820 - ENDIF - ELSE -C GO SEARCH SOME MORE. - GO TO 820 - ENDIF -C - GOTO 840 - 820 CONTINUE -C - 840 CONTINUE - NUMGOD = 2 -C - IF(NUM.LT.NUMGOD) THEN -C -C DID NOT FIND A MATCH OF A KEY LETTER CHECK TO SEE WHICH -C ONE IT WAS. -C - IF(GOTKEY)THEN - MODNAM(1:8) = 'MISSGING' - NM = 8 - GOTMOD = .TRUE. - ELSE - KRTN = 2 - WRITE(6,FMT='('' W3FQ07: '',A)') NOTSNT(1:52) - WRITE(6,FMT='('' W3FQ07: '',A)') MESAG2(1:46) -C - CALL CONSOL(NOTSNT) - CALL CONSOL(MESAG2) - GO TO 900 - ENDIF - ENDIF -C -C - WRITE(6,FMT='('' PARM='',A)') LPARM(1:NUMBYT) - WRITE(6,FMT='('' MODNAM='',A,'' KEYWRD='',A, - 1 /)')MODNAM(1:NM),KEYWRD(1:NK) -C -C -C CHECK TO SEE IF FIRST 4 BYTES OF KEYWRD = FAX . -C IF IT DOES, CHANGE IT TO FAXX . -C - IF(KEYWRD(1:NK).EQ.'FAX')THEN - KEYWRD(1:4) = 'FAXX' - NK = 4 - ENDIF - IF(KEYWRD(1:NK).EQ.'TEST')THEN - BYPASS = .TRUE. - WRITE(6,FMT='('' W3FQ07: BYPASS FLAG ON, '', - 1 ''SKIP POSTING FILE.'',/)') - GO TO 900 - ENDIF -C -C MUST NOW I MUST GET THE JOB NAME AND UNIT NAME FOR -C CALL TO DBN_ALERT. -C -C . . . READ IN JOBNAME - JCHARS = GETENV('QSUB_REQNAME',BUFFER) - NJ = 0 - IF(BUFFER(1:8).EQ.' ')THEN - JOBNAM(1:8) = 'MSG_JOBNM' - NJ = 8 - ELSE - DO II =1,8 - IF(BUFFER(II:II).NE.' ')THEN - NJ = NJ + 1 - JOBNAM(NJ:NJ) = BUFFER(II:II) - ENDIF - ENDDO - ENDIF -C - WRITE(6,FMT='('' W3FQ07: JOB NAME JOBNAM= :'',A, - 1 ''!'')') JOBNAM(1:24) - WRITE(6,FMT='('' W3FQ07: JOB NAME= '',A, - 1 '' NJ='',I3)') JOBNAM(1:NJ),NJ -C -C . . . READ IN FILE NAME -C - KRTN = 0 - - CALL ASNQUNIT(OUTFIL,STRING,ISTAT) - WRITE(6,FMT='('' W3FQ07:OUTFIL NAME= '', - 1 A,'' ISTAT='',I4)')STRING(1:80),ISTAT -C SEARCH FOR LENGHT OF FILE NAME. -C - KRET = ISTAT - IF(KRET.EQ.0) THEN - ISTRT = 0 - DO I = 1,80 - IF(ISTRT.EQ.0)THEN - IF(STRING(I:I).EQ.'/')THEN - ISTRT = I - ENDIF - ELSE - IF(STRING(I:I).EQ.' ')THEN - IEND = I - GOTO 775 - ENDIF - ENDIF - ENDDO - 775 NF = IEND - ISTRT - OUTXT(1:NF) = STRING(ISTRT:IEND) - WRITE(6,FMT='('' W3FQ07: OUTXT= '', - 1 A,'' NF='',I3)')OUTXT(1:NF),NF -C - WRITE(6,FMT='('' W3FQ07: CALLING DBN_ALERT WITH'', - 1 '' :'',A,'' NK='',I2,'' '',A,'' NM='',I2,'' '', - 2 A,'' NJ='',I2,'' '',A,'' NF='',I3)')KEYWRD(1:NK), - 3 NK,MODNAM(1:NM),NM,JOBNAM(1:NJ),NJ,OUTXT(1:NF),NF - - CALL DBN_ALERT(KEYWRD,NK,MODNAM,NM,JOBNAM,NJ, - 1 OUTXT,NF,KRET4) - KRET=KRET4 -C - ENDIF - IF(KRET.EQ.0) THEN -C COMES HERE FOR NORMAL STOP. -C - FILNAM(1:8) = 'POSTING ' - FILNAM(9:9+NK-1) = KEYWRD(1:NK) - JLOC = 9 + NK - FILNAM(JLOC:JLOC+6) = ' FILE ' - LOC = JLOC + 6 - FILNAM(LOC+1:LOC+1+NF) = OUTXT(1:NF) - JOC = LOC + NF + 1 - FILNAM(JOC:JOC) = ':' - WRITE(6,FMT='('' W3FQ07: KRET='',I4,'' THEREFORE '', - 1 A)')KRET,FILNAM(1:JOC) - CALL CONSOL(FILNAM) - ELSE - KRTN = 5 - CALL INT2CH(KRET,CTEXT,2,CPLMIZ) - MESAG5(40:41) = CTEXT(1:2) - WRITE(6,FMT='('' W3FQ07: '', - 1 A)')MESAG5(1:42) - CALL CONSOL(NOTSNT) - CALL CONSOL(MESAG5) - ENDIF -C - 900 CONTINUE - ENDIF - GO TO 1000 - 940 CONTINUE - CALL INT2CH(CARDFIL,CTEXT,2,CPLMIZ) - MESAG4(53:54) = CTEXT(1:2) - CALL CONSOL(NOTSNT) - CALL CONSOL(MESAG4) - WRITE(6,FMT='('' W3FQ07: '',A)') NOTSNT - WRITE(6,FMT='('' W3FQ07: '',A)') MESAG4 - KRTN = 4 - ENDIF -1000 RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fs13.f b/src/fim/FIMsrc/w3/w3fs13.f deleted file mode 100644 index 8d1fd0e..0000000 --- a/src/fim/FIMsrc/w3/w3fs13.f +++ /dev/null @@ -1,52 +0,0 @@ - SUBROUTINE W3FS13(IYR,IMO,IDA,JDY) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FS13 YEAR, MONTH, AND DAY TO DAY OF YEAR -C AUTHOR: CHASE, P. ORG: W345 DATE: 85-07-31 -C -C ABSTRACT: CONVERTS YEAR, MONTH AND DAY TO DAY OF YEAR. -C -C PROGRAM HISTORY LOG: -C 85-07-31 R.E.JONES -C 89-11-02 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C -C USAGE: CALL W3FS13(IYR, IMO, IDA, JDY) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C IYR ARG LIST INTEGER YEAR OF CENTURY, 00-99 OR YEAR OF ERA, -C 1901-2099 -C IMO ARG LIST INTEGER MONTH OF YEAR, 1-12 -C IDA ARG LIST INTEGER DAY OF MONTH, 1-31 -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C JDY ARG LIST INTEGER DAY OF YEAR, 1-366 -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C IAND SYSTEM -C -C REMARKS: THIS PROCEDURE IS VALID ONLY FROM THE YEARS 1901-2099 -C INCLUSIVE. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - INTEGER JTABLE(24) -C - DATA JTABLE/0,0,31,31,60,59,91,90,121,120,152,151, - & 182,181,213,212,244,243,274,273,305,304,335,334/ -C - ISET = 0 - IF (IAND(IYR,3).EQ.0) ISET = 1 - I = IMO * 2 - ISET - JDY = JTABLE(I) + IDA - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fs15.f b/src/fim/FIMsrc/w3/w3fs15.f deleted file mode 100644 index a6ad152..0000000 --- a/src/fim/FIMsrc/w3/w3fs15.f +++ /dev/null @@ -1,212 +0,0 @@ - SUBROUTINE W3FS15(IDATE,JTAU,NDATE) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FS15 UPDATING OFFICE NOTE 85 DATE/TIME WORD -C PRGMMR: REJONES ORG: NMC421 DATE: 89-08-23 -C -C ABSTRACT: UPDATES OR BACKDATES A FULLWORD DATE/TIME WORD (O.N. 84) -C BY A SPECIFIED NUMBER OF HOURS. -C -C PROGRAM HISTORY LOG: -C ??-??-?? R.ALLARD -C 87-02-19 R.E.JONES CLEAN UP CODE -C 87-02-19 R.E.JONES CHANGE TO MICROSOFT FORTRAN 4.10 -C 89-05-12 R.E.JONES CORRECT ORDER OF BYTES IN DATE WORD FOR PC -C 89-08-04 R.E.JONES CLEAN UP CODE, GET RID OF ASSIGN, CORRECTION -C FOR MEMORY SET TO INDEFINITE. -C 89-10-25 R.E.JONES CHANGE TO CRAY CFT77 FORTRAN -C 95-11-15 R.E.JONES ADD SAVE STATEMENT -C 02-10-15 VUONG REPLACED FUNCTION ICHAR WITH MOVA2I -C -C USAGE: CALL W3FS15 (IDATE, JTAU, NDATE) -C INPUT ARGUMENT LIST: -C IDATE - PACKED BINARY DATE/TIME AS FOLLOWS: -C BYTE 1 IS YEAR OF CENTURY 00-99 -C BYTE 2 IS MONTH 01-12 -C BYTE 3 IS DAY OF MONTH 01-31 -C BYTE 4 IS HOUR 00-23 -C SUBROUTINE TAKES ADVANTAGE OF FORTRAN ADDRESS -C PASSING, IDATE AND NDATE MAY BE -C A CHARACTER*1 ARRAY OF FOUR, THE LEFT 32 -C BITS OF 64 BIT INTEGER WORD. AN OFFICE NOTE 85 -C LABEL CAN BE STORED IN -C 4 INTEGER WORDS. -C IF INTEGER THE 2ND WORD IS USED. OUTPUT -C IS STORED IN LEFT 32 BITS. FOR A OFFICE NOTE 84 -C LABEL THE 7TH WORD IS IN THE 4TH CRAY 64 BIT -C INTEGER, THE LEFT 32 BITS. -C JTAU - INTEGER NUMBER OF HOURS TO UPDATE (IF POSITIVE) -C OR BACKDATE (IF NEGATIVE) -C -C OUTPUT ARGUMENT LIST: -C NDATE - NEW DATE/TIME WORD RETURNED IN THE -C SAME FORMAT AS 'IDATE'. 'NDATE' AND 'IDATE' MAY -C BE THE SAME VARIABLE. -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - NONE -C -C RESTRICTIONS: THIS ROUTINE IS VALID ONLY FOR THE 20TH CENTURY. -C -C NOTES: THE FORMAT OF THE DATE/TIME WORD IS THE SAME AS THE -C SEVENTH WORD OF THE PACKED DATA FIELD LABEL (SEE O.N. 84) AND -C THE THIRD WORD OF A BINARY DATA SET LABEL (SEE O.N. 85). -C -C EXIT STATES: -C AN ERROR FOUND BY OUT OF RANGE TESTS ON THE GIVEN DATE/TIME -C INFORMATION WILL BE INDICATED BY RETURNING A BINARY ZERO WORD -C IN 'NDATE'. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - INTEGER ITABYR(13) - INTEGER LPTB(13) - INTEGER NOLPTB(13) -C - CHARACTER*1 IDATE(4) - CHARACTER*1 NDATE(4) -C - SAVE -C - DATA LPTB /0000,0744,1440,2184,2904,3648,4368,5112, - & 5856,6576,7320,8040,8784/ - DATA NOLPTB/0000,0744,1416,2160,2880,3624,4344,5088, - & 5832,6552,7296,8016,8760/ - DATA ICENTY/1900/ -C -C ...WHERE ICENTY IS FOR THE 20TH CENTURY ASSUMED FOR THE GIVEN -C ... YEAR WITHIN THE CENTURY -C - IYR = MOVA2I(IDATE(1)) - IMONTH = MOVA2I(IDATE(2)) - IDAY = MOVA2I(IDATE(3)) - IHOUR = MOVA2I(IDATE(4)) -C - IF (IYR .GT. 99) GO TO 1600 - IF (IMONTH .LE. 0) GO TO 1600 - IF (IMONTH .GT. 12) GO TO 1600 - IF (IDAY .LE. 0) GO TO 1600 - IF (IDAY .GT. 31) GO TO 1600 - IF (IHOUR .LT. 0) GO TO 1600 - IF (IHOUR .GT. 24) GO TO 1600 - IF (JTAU .NE. 0) GO TO 100 -C - NDATE(1) = IDATE(1) - NDATE(2) = IDATE(2) - NDATE(3) = IDATE(3) - NDATE(4) = IDATE(4) - RETURN -C - 100 CONTINUE - JAHR = IYR + ICENTY - KABUL = 1 - GO TO 900 -C -C ...WHERE 900 IS SUBROUTINE TO INITIALIZE ITABYR -C ...AND RETURN THRU KABUL -C - 200 CONTINUE - IHRYR = IHOUR + 24 * (IDAY - 1) + ITABYR(IMONTH) - IHRYR2 = IHRYR + JTAU -C -C ...TO TEST FOR BACKDATED INTO PREVIOUS YEAR... -C - 300 CONTINUE - IF (IHRYR2 .LT. 0) GO TO 700 -C - DO 400 M = 2,13 - IF (IHRYR2 .LT. ITABYR(M)) GO TO 600 - 400 CONTINUE -C -C ...IF IT FALLS THRU LOOP TO HERE, IT IS INTO NEXT YEAR... -C - JAHR = JAHR + 1 - IHRYR2 = IHRYR2 - ITABYR(13) - KABUL = 2 - GO TO 900 -C - 600 CONTINUE - MONAT = M - 1 - IHRMO = IHRYR2 - ITABYR(MONAT) - NODAYS = IHRMO / 24 - ITAG = NODAYS + 1 - IUHR = IHRMO - NODAYS * 24 - GO TO 1500 -C -C ...ALL FINISHED. RETURN TO CALLING PROGRAM....................... -C ...COMES TO 700 IF NEG TOTAL HRS. BACK UP INTO PREVIOUS YEAR -C - 700 CONTINUE - JAHR = JAHR - 1 - KABUL = 3 - GO TO 900 -C -C ...WHICH IS CALL TO INITIALIZE ITABYR AND RETURN THRU KABUL -C - 800 CONTINUE - IHRYR2 = ITABYR(13) + IHRYR2 - GO TO 300 -C -C ...SUBROUTINE INITYR... -C ...CALLED BY GO TO 900 AFTER ASSIGNING RETURN NO. TO KABUL... -C ...ITABYR HAS MONTHLY ACCUMULATING TOTAL HRS REL TO BEGIN OF YR. -C ...DEPENDS ON WHETHER JAHR IS LEAP YEAR OR NOT. -C - 900 CONTINUE - IQUOT = JAHR / 4 - IRMNDR = JAHR - 4 * IQUOT - IF (IRMNDR .NE. 0) GO TO 1000 -C -C ...WAS MODULO 4, SO MOST LIKELY A LEAP YEAR, -C - IQUOT = JAHR / 100 - IRMNDR = JAHR - 100 * IQUOT - IF (IRMNDR .NE. 0) GO TO 1200 -C -C ...COMES THIS WAY IF A CENTURY YEAR... -C - IQUOT = JAHR / 400 - IRMNDR = JAHR - 400 * IQUOT - IF (IRMNDR .EQ. 0) GO TO 1200 -C -C ...COMES TO 1000 IF NOT A LEAP YEAR... -C - 1000 CONTINUE - DO 1100 I = 1,13 - ITABYR(I) = NOLPTB(I) - 1100 CONTINUE - GO TO 1400 -C -C ...COMES TO 1200 IF LEAP YEAR -C - 1200 CONTINUE - DO 1300 I = 1,13 - ITABYR(I) = LPTB(I) - 1300 CONTINUE -C - 1400 CONTINUE - GO TO (200,300,800) KABUL -C - 1500 CONTINUE - JAHR = MOD(JAHR,100) - NDATE(1) = CHAR(JAHR) - NDATE(2) = CHAR(MONAT) - NDATE(3) = CHAR(ITAG) - NDATE(4) = CHAR(IUHR) - RETURN -C - 1600 CONTINUE - NDATE(1) = CHAR(0) - NDATE(2) = CHAR(0) - NDATE(3) = CHAR(0) - NDATE(4) = CHAR(0) -C -C ...WHICH FLAGS AN ERROR CONDITION ... -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fs21.f b/src/fim/FIMsrc/w3/w3fs21.f deleted file mode 100644 index 3593d6f..0000000 --- a/src/fim/FIMsrc/w3/w3fs21.f +++ /dev/null @@ -1,77 +0,0 @@ - SUBROUTINE W3FS21(IDATE, NMIN) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FS21 NUMBER OF MINUTES SINCE JAN 1, 1978 -C PRGMMR: REJONES ORG: NMC421 DATE: 89-07-17 -C -C ABSTRACT: CALCULATES THE NUMBER OF MINUTES SINCE 0000, -C 1 JANUARY 1978. -C -C PROGRAM HISTORY LOG: -C 84-06-21 A. DESMARAIS -C 89-07-14 R.E.JONES CONVERT TO CYBER 205 FORTRAN 200, -C CHANGE LOGIC SO IT WILL WORK IN -C 21 CENTURY. -C 89-11-02 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C -C USAGE: CALL W3FS21 (IDATE, NMIN) -C INPUT ARGUMENT LIST: -C IDATE - INTEGER SIZE 5 ARRAY CONTAINING YEAR OF CENTURY, -C MONTH, DAY, HOUR AND MINUTE. IDATE(1) MAY BE -C A TWO DIGIT YEAR OR 4. IF 2 DIGITS AND GE THAN 78 -C 1900 IS ADDED TO IT. IF LT 78 THEN 2000 IS ADDED -C TO IT. IF 4 DIGITS THE SUBROUTINE WILL WORK -C CORRECTLY TO THE YEAR 3300 A.D. -C -C OUTPUT ARGUMENT LIST: -C NMIN - INTEGER NUMBER OF MINUTES SINCE 1 JANUARY 1978 -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - IW3JDN -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - INTEGER IDATE(5) - INTEGER NMIN - INTEGER JDN78 -C - DATA JDN78 / 2443510 / -C -C*** IDATE(1) YEAR OF CENTURY -C*** IDATE(2) MONTH OF YEAR -C*** IDATE(3) DAY OF MONTH -C*** IDATE(4) HOUR OF DAY -C*** IDATE(5) MINUTE OF HOUR -C - NMIN = 0 -C - IYEAR = IDATE(1) -C - IF (IYEAR.LE.99) THEN - IF (IYEAR.LT.78) THEN - IYEAR = IYEAR + 2000 - ELSE - IYEAR = IYEAR + 1900 - ENDIF - ENDIF -C -C COMPUTE JULIAN DAY NUMBER FROM YEAR, MONTH, DAY -C - IJDN = IW3JDN(IYEAR,IDATE(2),IDATE(3)) -C -C SUBTRACT JULIAN DAY NUMBER OF JAN 1,1978 TO GET THE -C NUMBER OF DAYS BETWEEN DATES -C - NDAYS = IJDN - JDN78 -C -C*** NUMBER OF MINUTES -C - NMIN = NDAYS * 1440 + IDATE(4) * 60 + IDATE(5) -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3fs26.f b/src/fim/FIMsrc/w3/w3fs26.f deleted file mode 100644 index bad845d..0000000 --- a/src/fim/FIMsrc/w3/w3fs26.f +++ /dev/null @@ -1,87 +0,0 @@ - SUBROUTINE W3FS26(JLDAYN,IYEAR,MONTH,IDAY,IDAYWK,IDAYYR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FS26 YEAR, MONTH, DAY FROM JULIAN DAY NUMBER -C AUTHOR: JONES,R.E. ORG: W342 DATE: 87-03-29 -C -C ABSTRACT: COMPUTES YEAR (4 DIGITS), MONTH, DAY, DAY OF WEEK, DAY -C OF YEAR FROM JULIAN DAY NUMBER. THIS SUBROUTINE WILL WORK -C FROM 1583 A.D. TO 3300 A.D. -C -C PROGRAM HISTORY LOG: -C 87-03-29 R.E.JONES -C 89-10-25 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C -C USAGE: CALL W3FS26(JLDAYN,IYEAR,MONTH,IDAY,IDAYWK,IDAYYR) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C JLDAYN ARG LIST INTEGER JULIAN DAY NUMBER -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C IYEAR ARG LIST INTEGER YEAR (4 DIGITS) -C MONTH ARG LIST INTEGER MONTH -C IDAY ARG LIST INTEGER DAY -C IDAYWK ARG LIST INTEGER DAY OF WEEK (1 IS SUNDAY, 7 IS SAT) -C IDAYYR ARG LIST INTEGER DAY OF YEAR (1 TO 366) -C -C REMARKS: A JULIAN DAY NUMBER CAN BE COMPUTED BY USING ONE OF THE -C FOLLOWING STATEMENT FUNCTIONS. A DAY OF WEEK CAN BE COMPUTED -C FROM THE JULIAN DAY NUMBER. A DAY OF YEAR CAN BE COMPUTED FROM -C A JULIAN DAY NUMBER AND YEAR. -C -C IYEAR (4 DIGITS) -C -C JDN(IYEAR,MONTH,IDAY) = IDAY - 32075 -C & + 1461 * (IYEAR + 4800 + (MONTH - 14) / 12) / 4 -C & + 367 * (MONTH - 2 - (MONTH -14) / 12 * 12) / 12 -C & - 3 * ((IYEAR + 4900 + (MONTH - 14) / 12) / 100) / 4 -C -C IYR (4 DIGITS) , IDYR(1-366) DAY OF YEAR -C -C JULIAN(IYR,IDYR) = -31739 + 1461 * (IYR + 4799) / 4 -C & -3 * ((IYR + 4899) / 100) / 4 + IDYR -C -C DAY OF WEEK FROM JULIAN DAY NUMBER, 1 IS SUNDAY, 7 IS SATURDAY. -C -C JDAYWK(JLDAYN) = MOD((JLDAYN + 1),7) + 1 -C -C DAY OF YEAR FROM JULIAN DAY NUMBER AND 4 DIGIT YEAR. -C -C JDAYYR(JLDAYN,IYEAR) = JLDAYN - -C & (-31739+1461*(IYEAR+4799)/4-3*((IYEAR+4899)/100)/4) -C -C THE FIRST FUNCTION WAS IN A LETTER TO THE EDITOR COMMUNICATIONS -C OF THE ACM VOLUME 11 / NUMBER 10 / OCTOBER, 1968. THE 2ND -C FUNCTION WAS DERIVED FROM THE FIRST. THIS SUBROUTINE WAS ALSO -C INCLUDED IN THE SAME LETTER. JULIAN DAY NUMBER 1 IS -C JAN 1,4713 B.C. A JULIAN DAY NUMBER CAN BE USED TO REPLACE A -C DAY OF CENTURY, THIS WILL TAKE CARE OF THE DATE PROBLEM IN -C THE YEAR 2000, OR REDUCE PROGRAM CHANGES TO ONE LINE CHANGE -C OF 1900 TO 2000. JULIAN DAY NUMBERS CAN BE USED FOR FINDING -C RECORD NUMBERS IN AN ARCHIVE OR DAY OF WEEK, OR DAY OF YEAR. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/864 -C -C$$$ -C - L = JLDAYN + 68569 - N = 4 * L / 146097 - L = L - (146097 * N + 3) / 4 - I = 4000 * (L + 1) / 1461001 - L = L - 1461 * I / 4 + 31 - J = 80 * L / 2447 - IDAY = L - 2447 * J / 80 - L = J / 11 - MONTH = J + 2 - 12 * L - IYEAR = 100 * (N - 49) + I + L - IDAYWK = MOD((JLDAYN + 1),7) + 1 - IDAYYR = JLDAYN - - & (-31739 +1461 * (IYEAR+4799) / 4 - 3 * ((IYEAR+4899)/100)/4) - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft00.f b/src/fim/FIMsrc/w3/w3ft00.f deleted file mode 100644 index e36edf3..0000000 --- a/src/fim/FIMsrc/w3/w3ft00.f +++ /dev/null @@ -1,171 +0,0 @@ - SUBROUTINE W3FT00(FLD,B,IA,JA,IB,JB,CIP,CJP,FIPB,FJPB,SC,ARG,LIN) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FT00 DATA FIELD TRANFORMATION SUBROUTINE -C AUTHOR: MCDONELL, J. ORG: W345 DATE: SEPTEMBER, 1974 -C HOWCROFT, J. -C UPDATE: JONES,R.E. ORG: W342 DATE: 27 JUN 84 -C -C ABSTRACT: TRANSFORMS DATA CONTAINED IN A GRID ARRAY BY TRANSLATION, -C ROTATION ABOUT A COMMON POINT AND DILATATION TO A NEW GRID ARRAY. -C -C PROGRAM HISTORY LOG: -C 74-09-01 J.MCDONELL -C 84-06-27 R.E.JONES CHANGE TO IBM VS FORTRAN -C -C USAGE: CALL W3FT00 (FA,FB,IA,JA,IB,JB,AIP,AJP,BIP,BJP,SC,ARG,LIN) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C FA ARG LIST REAL ORIGIONAL FIELD DIMENSIONED (IA,IJ) -C IA ARG LIST INTEGER I-DIMENSION OF THE INPUT ARRAY FA -C JA ARG LIST INTEGER J-DIMENSION OF THE INPUT ARRAY FA -C IB ARG LIST INTEGER I-DIMENSION OF THE OUTPUT ARRAY FB -C JB ARG LIST INTEGER J-DIMENSION OF THE OUTPUT ARRAY FB -C AIP ARG LIST REAL COMMON POINT I-COORDINATE OF THE ORIGIONAL -C FIELD ASSUMING A RIGHT HAND CARTESIAN COORDINATE -C SYSTEM. THE POINT NEED NOT BE IN EITHER GRID AND -C CAN HAVE FRACTIONAL INDICES). -C AJP ARG LIST REAL COMMON POINT J-COORDINATE AS AIP ABOVE -C BIP ARG LIST REAL COMMON POINT I-COORDINATE FOR TRANSFORMED -C GRID -C BJP ARG LIST REAL COMMON POINT J-COORDINATE FOR TRANSFORMED -C GRID -C SC ARG LIST REAL SCALE CHANGE (DILATION) EXPRESSED AS -C A RATIO OF THE TRANSFORMED TO THE ORIGIONAL FIELD -C ARG ARG LIST REAL DEGREE MEASURE OF THE ANGLE REQUIRED TO -C ROTATE THE J-ROW OF THE ORIGIONAL GRID INTO -C COINCIDENCE WITH THE NEW GRID. (+ COUNTER- -C CLOCKWISE, - CLOCKWISE) -C LIN ARG LIST INTEGER INTERPOLATION METHOD SWITCH -C .EQ. 1 BILINEAR INTERPOLATION -C .NE. 1 BIQUADRATIC INTERPOLATION -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C FB ARG LIST REAL TRANSFORMED FIELD DIMENSIONED (IB,JB) -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C SIN COS SYSTEM -C -C REMARKS: IN GENERAL 'FA' AND 'FB' CANNOT BE EQUIVALENCED -C ALTHOUGH THERE ARE SITUATIONS IN WHICH IT WOULD BE SAFE TO DO -C SO. CARE SHOULD BE TAKEN THAT ALL OF THE NEW GRID POINTS LIE -C WITHIN THE ORIGIONAL GRID, NO ERROR CHECKS ARE MADE. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - REAL B(IB,JB) - REAL ERAS(4) - REAL FLD(IA,JA) -C - EQUIVALENCE (CI,STI), (CJ,STJ) -C - THETA = ARG * (3.14159 / 180.0) - SINT = SIN (THETA) - COST = COS (THETA) -C - DO 180 JN = 1,JB - FJN = JN - FJ = FJN - FJPB - DO 180 IN = 1,IB - FIN = IN - FI = FIN - FIPB - IOFF = 0 - JOFF = 0 - KQUAD = 0 - CI = CIP + SC * (FI * COST - FJ * SINT) - CJ = CJP + SC * (FI * SINT + FJ * COST) - IM = CI - JM = CJ - IF ((IM - 1).GT.0) GO TO 20 - IF ((IM - 1).EQ.0) GO TO 40 - II = 1 - IOFF = 1 - GO TO 50 -C - 20 CONTINUE - IF ((IA - IM - 1).GT.0) GO TO 50 - IF ((IA - IM - 1).EQ.0) GO TO 40 - II = IA - IOFF = 1 - GO TO 50 -C - 40 CONTINUE - KQUAD = 5 -C - 50 CONTINUE - IF ((JM - 1).GT.0) GO TO 70 - IF ((JM - 1).EQ.0) GO TO 90 - JJ = 1 - JOFF = 1 - GO TO 100 -C - 70 CONTINUE - IF ((JA - JM - 1).GT.0) GO TO 100 - IF ((JA - JM - 1).EQ.0) GO TO 90 - JJ = JA - JOFF = 1 - GO TO 100 -C - 90 CONTINUE - KQUAD = 5 -C - 100 CONTINUE - IF ((IOFF + JOFF) .EQ. 0) GO TO 120 - IF ((IOFF + JOFF) .EQ. 2) GO TO 110 - IF (IOFF .EQ. 1) JJ = CJ - IF (JOFF .EQ. 1) II = CI -C - 110 CONTINUE - B(IN,JN) = FLD(II,JJ) - GO TO 180 -C - 120 CONTINUE - I = STI - J = STJ - FIX = I - XDELI = STI - FIX - FJX = J - XDELJ = STJ - FJX - IF ((KQUAD - 5).EQ.0) GO TO 140 -C - IF ((LIN-1).NE.0) GO TO 150 -C - 140 CONTINUE - ERAS(1) = FLD(I,J) - ERAS(4) = FLD(I,J+1) - ERAS(2) = ERAS(1) + (FLD(I+1,J) - ERAS(1)) * XDELI - ERAS(3) = ERAS(4) + (FLD(I+1,J+1) - ERAS(4)) * XDELI - DI = ERAS(2) + (ERAS(3) - ERAS(2)) * XDELJ - GO TO 170 -C - 150 CONTINUE - XI2TM = XDELI * (XDELI - 1.0) * 0.25 - XJ2TM = XDELJ * (XDELJ - 1.0) * 0.25 - J1 = J - 1 -C - DO 160 K = 1,4 - ERAS(K) = (FLD(I+1,J1) - FLD(I,J1)) * XDELI + FLD(I,J1) + - & (FLD(I-1,J1) - FLD(I,J1) - FLD(I+1,J1) + FLD(I+2,J1)) * XI2TM - J1 = J1 + 1 - 160 CONTINUE -C - DI = ERAS(2) + (ERAS(3) - ERAS(2)) * XDELJ + (ERAS(1) - - & ERAS(2) - ERAS(3) + ERAS(4)) * XJ2TM -C - 170 CONTINUE - B(IN,JN) = DI -C - 180 CONTINUE -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft01.f b/src/fim/FIMsrc/w3/w3ft01.f deleted file mode 100644 index 5671704..0000000 --- a/src/fim/FIMsrc/w3/w3ft01.f +++ /dev/null @@ -1,177 +0,0 @@ - SUBROUTINE W3FT01(STI,STJ,FLD,HI,II,JJ,NCYCLK,LIN) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FT01 INTERPOLATE VALUES IN A DATA FIELD -C AUTHOR: MCDONELL, J. ORG: W345 DATE: 84-06-27 -C UPDATE: JONES,R.E. ORG: W342 DATE: 87-03-19 -C -C ABSTRACT: FOR A GIVEN GRID COORDINATE IN A DATA ARRAY, ESTIMATES -C A DATA VALUE FOR THAT POINT USING EITHER A LINEAR OR QUADRATIC -C INTERPOLATION METHOD. -C -C PROGRAM HISTORY LOG: -C 84-06-27 J.MCDONELL -C 89-11-01 R.E.JONES CHANGE TO CRAY CFT77 FORTRAN -C -C USAGE: CALL W3FT01 (STI, STJ, FLD, HI, II, JJ, NCYCLK, LIN) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C STI ARG LIST REAL*4 I GRID COORDINATE OF THE POINT FOR WHICH -C AN INTERPOLATED VALUE IS DESIRED -C STJ ARG LIST REAL*4 J GRID COORDINATE OF THE POINT FOR WHICH -C AN INTERPOLATED VALUE IS DESIRED -C FLD ARG LIST REAL*4 SIZE(II,JJ) DATA FIELD -C II ARG LIST INTEGER*4 NUMBER OF COLUMNS IN 'FLD' -C JJ ARG LIST INTEGER*4 NUMBER OF ROWS IN 'FLD' -C NCYCLK ARG LIST INTEGER*4 CODE TO SPECIFY IF GRID IS CYCLIC OR -C NOT: -C = 0 NON-CYCLIC IN II, NON-CYCLIC IN JJ -C = 1 CYCLIC IN II, NON-CYCLIC IN JJ -C = 2 CYCLIC IN JJ, NON-CYCLIC IN II -C = 3 CYCLIC IN II, CYCLIC IN JJ -C LIN ARG LIST INTEGER*4 CODE SPECIFYING INTERPOLATION METHOD: -C = 1 LINEAR INTERPOLATION -C .NE.1 QUADRATIC INTERPOLATION -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C HI ARG LIST REAL*4 DATA FIELD VALUE AT (STI,STJ) OBTAINED -C BY INTERPOLATION. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - REAL ERAS(4) - REAL FLD(II,JJ) - REAL JY(4) -C - I = STI - J = STJ - FI = I - FJ = J - XDELI = STI - FI - XDELJ = STJ - FJ - IP2 = I + 2 - IM1 = I - 1 - IP1 = I + 1 - JY(4) = J + 2 - JY(1) = J - 1 - JY(3) = J + 1 - JY(2) = J - XI2TM = 0.0 - XJ2TM = 0.0 - IF (LIN.NE.1) THEN - XI2TM = XDELI * (XDELI - 1.0) * 0.25 - XJ2TM = XDELJ * (XDELJ - 1.0) * 0.25 - ENDIF - IF ((I.LT.2).OR.(J.LT.2)) GO TO 10 - IF ((I.GT.II-3).OR.(J.GT.JJ-3)) GO TO 10 -C -C QUADRATIC (LINEAR TOO) OK W/O FURTHER ADO SO GO TO 170 -C - GO TO 170 -C - 10 CONTINUE - ICYCLK = 0 - JCYCLK = 0 - IF (NCYCLK) 20,120,20 -C - 20 CONTINUE - IF (NCYCLK / 2 .NE. 0) JCYCLK = 1 - IF (NCYCLK .NE. 2) ICYCLK = 1 - IF (ICYCLK) 30,70,30 -C - 30 CONTINUE - IF (I.EQ.1) GO TO 40 - IF (I.EQ.(II-1)) GO TO 50 - IP2 = I + 2 - IM1 = I - 1 - GO TO 60 -C - 40 CONTINUE - IP2 = 3 - IM1 = II - 1 - GO TO 60 -C - 50 CONTINUE - IP2 = 2 - IM1 = II - 2 -C - 60 CONTINUE - IP1 = I + 1 -C - 70 CONTINUE - IF (JCYCLK) 80,120,80 -C - 80 CONTINUE - IF (J.EQ.1) GO TO 90 - IF (J.EQ.(JJ-1)) GO TO 100 - JY(4) = J + 2 - JY(1) = J - 1 - GO TO 110 -C - 90 CONTINUE - JY(4) = 3 - JY(1) = JJ - 1 - GO TO 110 -C - 100 CONTINUE - JY(4) = 2 - JY(1) = JJ - 2 -C - 110 CONTINUE - JY(3) = J + 1 - JY(2) = J -C - 120 CONTINUE - IF (LIN.EQ.1) GO TO 160 - IF (ICYCLK) 140,130,140 -C - 130 CONTINUE - IF ((I.LT.2).OR.(I.GE.(II-1))) XI2TM = 0.0 -C - 140 CONTINUE - IF (JCYCLK) 160,150,160 -C - 150 CONTINUE - IF ((J.LT.2).OR.(J.GE.(JJ-1))) XJ2TM = 0.0 -C - 160 CONTINUE -C -C.....DO NOT ALLOW POINT OFF GRID,CYCLIC OR NOT -C - IF (I.LT.1) I = 1 - IF (IP1.LT.1) IP1 = 1 - IF (IP2.LT.1) IP2 = 1 - IF (IM1.LT.1) IM1 = 1 -C -C.....DO NOT ALLOW POINT OFF GRID,CYCLIC OR NOT -C - IF (I.GT.II) I = II - IF (IP1.GT.II) IP1 = II - IF (IP2.GT.II) IP2 = II - IF (IM1.GT.II) IM1 = II -C - 170 CONTINUE - DO 180 K = 1,4 - J1 = JY(K) -C -C.....DO NOT ALLOW POINT OFF GRID,CYCLIC OR NOT -C - IF (J1.LT.1) J1 = 1 - IF (J1.GT.JJ) J1 = JJ - ERAS(K) = (FLD(IP1,J1) - FLD(I,J1)) * XDELI + FLD(I,J1) + - & (FLD(IM1,J1) - FLD(I,J1) - FLD(IP1,J1) + FLD(IP2,J1)) * XI2TM - 180 CONTINUE -C - HI = ERAS(2) + (ERAS(3) - ERAS(2)) * XDELJ + (ERAS(1) - - & ERAS(2) - ERAS(3) + ERAS(4)) * XJ2TM -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft02.f b/src/fim/FIMsrc/w3/w3ft02.f deleted file mode 100644 index 6dfd63a..0000000 --- a/src/fim/FIMsrc/w3/w3ft02.f +++ /dev/null @@ -1,217 +0,0 @@ - SUBROUTINE W3FT02 (RAIN, IMAX, JMAX, PI, PJ, AMOUNT) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FT02 INTERPOLATE PRECIPITATION TO SPECIFIC POINT -C PRGMMR: HIRANO ORG: NMC24 DATE:96-06-23 -C -C ABSTRACT: INTERPOLATE, USING A FANCY NON-LINEAR METHOD, -C GRIDDED QUANTITATIVE PRECIPITATION FORECASTS TO A SPECIFIC -C INTERIOR POINT. ONE POINT (E.G. AN OBSERVATION STATION) -C PER CALL TO W3FT02. -C -C PROGRAM HISTORY LOG: -C 79-08-05 R.HIRANO -C 96-06-23 farley converted to cray fortran 77 -C -C USAGE: CALL W3FT02(RAIN, IMAX, JMAX, PI, PJ, AMOUNT) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C RAIN ARG LIST REAL*4 GRID FIELD OF (FORECAST) PRECIPITATION -C IMAX ARG LIST INTEGER*4 I-DIMENSION OF RAIN FIELD -C JMAX ARG LIST INTEGER *4 J-DIMENSION OF RAIN FIELD -C PI ARG LIST REAL*4 I-COORDINATE OF INTERPOLATION POINT -C PJ ARG LIST REAL*4 J-COORDINATE OF INTERPOLATION POINT -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C AMOUNT ARG LIST REAL*4 AMOUNT OF PRECIP INTERPOLATED TO PI,PJ -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C AMAX1 SYSTEM -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN -C MACHINE: NAS-9050, 9070 -C -C NO WRITEUP AVAILABLE. SEE PROGRAMMER FOR ADDITIONAL INFORMATION. -C -C$$$ -C -C INTERPOLATE PRECIPITATION FROM RAIN FIELD -C TO INTERNAL POINT (PI,PJ). RESULT IN AMOUNT -C - real RAIN(IMAX,JMAX) -C -C CHECK FOR INTERPOLATION POINT OUTSIDE GRID -C - AMOUNT = 0. - IF(PI.LE.1.OR.PI.GE.IMAX) GO TO 150 - IF(PJ.LE.1.OR.PJ.GE.JMAX) GO TO 150 -C -C SET UP RAIN AMMOUNTS AT CORNERS OF BOX SURROUNDING POINT (PI,PJ -C -C R2 R4 -C -C (PI,PJ) -C -C R1 R3 -C - I=PI - J=PJ - R1=RAIN(I ,J ) - R2=RAIN(I ,J+1) - R3=RAIN(I+1,J ) - R4=RAIN(I+1,J+1) -C -C CHECK FOR NO RAIN AT ALL -C - IF(AMAX1(R1,R2,R3,R4).LE.0.) GO TO 150 -C -C GOT SOME -- FIND APPROPRIATE SECTOR AND SECTION -C OF THE GRID BOX IN WHICH THE STATION IS LOCATED -C - AI = PI-I - AJ=PJ-J - X = 0.5 -C -C MEANINOF IC FOR SECTORS (K=1) OR SECTIONS (K=2) -C -C 2 4 -C -C 1 3 -C -C ALSO REFERENCED AS -C -C TOP DIAGONAL / T D -C / -C NEAR RIGHT / N R -C - DO 1 K=1,2 - IF(AI.GT.X) GO TO 2 - IF(AJ.GT.X) GO TO 4 - IC = 1 - GO TO 10 - 4 CONTINUE - IC = 2 - GO TO 10 - 2 CONTINUE - IF(AJ.GT.X) GO TO 6 - IC = 3 - GO TO 10 - 6 CONTINUE - IC = 4 - 10 CONTINUE - IF(K.NE.1) GO TO 16 -C -C SET UP SECTORS THIS BUSINESS IN EFFECT ROTATES THE SECTORS -C FOR CONVENIENCE IN LATER INTERPOLATIONS -C - GO TO (11, 12, 13, 14), IC - 11 CONTINUE - R = R1 - RT = R2 - RR = R3 - RD = R4 - GO TO 15 - 12 CONTINUE - R = R2 - RT = R1 - RR = R4 - RD = R3 - AJ = 1. - AJ - GO TO 15 - 13 CONTINUE - R = R3 - RT = R4 - RR = R1 - RD = R2 - AI = 1. - AI - GO TO 15 - 14 CONTINUE - R = R4 - RT = R3 - RR = R2 - RD = R1 - AI = 1. - AI - AJ = 1. - AJ - 15 CONTINUE -C -C IF NO RAIN IN CORNER SECTTOR WHERE STATION IS - QUIT -C - IF(R.LE.0.) GO TO 150 - X = 0.5 * X - 16 CONTINUE - 1 CONTINUE -C -C INTERPOLATE TO STATION IN EASY (NON-CORNER) SECTIONS -C - GO TO (21, 22, 23, 24), IC - 21 CONTINUE - AMOUNT = R - GO TO 150 - 22 CONTINUE - RC = RT - RX = AJ - GO TO 120 - 23 CONTINUE - RC = RR - RX = AI - 120 CONTINUE - IF(RC.GT. 0.) GO TO 130 - AMOUNT = R - R*(RX-X)/X - GO TO 150 - 130 CONTINUE - AMOUNT = R + (0.5*(R+RC)-R)*(RX-X)/X - GO TO 150 - 24 CONTINUE -C -C CORNER (CENTER OF BOX) SECTION -C - AA = AMAX1(RR, RT, RD) - IF(AA.GT.0.) GO TO 30 - RS = 0. - RU = 0. - RD = 0. - GO TO 37 - 30 CONTINUE - IF(RR.GT.0.) GO TO 32 - RS = 0. - RRD = 0. - 33 CONTINUE - IF(RT.GT.0.) GO TO 34 - RU = 0. - RTD = 0. - GO TO 35 - 34 CONTINUE - RU = 0.5 * (R+RT) - IF(RD.GT.0.) GO TO 36 - RTD = 0. - GO TO 35 - 36 CONTINUE - RTD = 0.5 * (RT + RD) - GO TO 35 - 32 CONTINUE - RS = 0.5 * (R+RR) - IF(RD.GT.0.) GO TO 38 - RRD = 0. - GO TO 33 - 38 CONTINUE - RRD = 0.5 * (RD + RR) - GO TO 33 - 35 CONTINUE - RD = 0.25 * (RS + RU + RTD + RRD) - IF(RS.LE.0. .AND. RTD.LE.0.) RD = 0. - IF(RU.LE.0..AND.RRD.LE.0.) RD=0. - RU = RU + (RD-RU) * (AI-X)/X - 37 CONTINUE - R = R + (RS-R) * (AI-X)/X - AMOUNT = R + (RU-R) * (AJ-X)/X - 150 CONTINUE - RETURN -C - END diff --git a/src/fim/FIMsrc/w3/w3ft03.f b/src/fim/FIMsrc/w3/w3ft03.f deleted file mode 100644 index ac2e6c7..0000000 --- a/src/fim/FIMsrc/w3/w3ft03.f +++ /dev/null @@ -1,92 +0,0 @@ - SUBROUTINE W3FT03(FL,HI,STI,STJ,MAXI,MAXJ,ITYPE) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FT03 A POINT INTERPOLATER -C AUTHOR: HOWCROFT, J. ORG: W342 DATE: 79-02-15 -C -C ABSTRACT: DO EITHER BILINEAR OR BIQUADRATIC INTERPOLATION FOR A -C POINT WITHIN A TWO-DIMENSIONAL DATA ARRAY. -C -C PROGRAM HISTORY LOG: -C 79-02-15 J.HOWCROFT -C 89-01-25 R.E.JONES CHANGE TO MICROSOFT FORTRAN 4.10 -C 90-06-12 R.E.JONES CHANGE TO SUN FORTRAN 1.3 -C 91-03-30 R.E.JONES CONVERT TO SiliconGraphics FORTRAN -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C 96-07-01 R.E.JONES COMPILE ON CRAY -C -C USAGE: CALL W3FT03(FL,HI,STI,STJ,MAXI,MAXJ,KQUAD) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C FL ARG LIST REAL*4 TWO-DIMENSIONAL CARTESIAN ARRAY OF DATA -C MAXI ARG LIST INTEGER*4 I-DIMENSION OF FL -C MAXJ ARG LIST INTEGER*4 J-DIMENSION OF FL -C STI ARG LIST REAL*4 I-COORDINATE TO WHICH A VALUE IS TO BE -C INTERPOLATED -C STJ ARG LIST REAL*4 J-COORDINATE TO WHICH A VALUE IS TO BE -C INTERPOLATED -C KQUAD ARG LIST INTEGER*4 INTERPOLATION METHOD: -C IF = 2, BIQUADRATIC INTERPOLATION IS DONE, -C IF = ANY OTHER VALUE, DO BILINEAR. -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C HI ARG LIST REAL*4 INTERPOLATED OUTPUT VALUE -C -C REMARKS: NO ERROR CHECKS ARE MADE. IT IS LEFT FOR THE USER TO -C DETERMINE THAT THE POINT FOR WHICH INTERPOLATION IS DESIRED -C LIES WITHIN THE GRID. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916/256, CRAY J916/2048 -C -C$$$ -C - REAL FL(MAXI,MAXJ) - REAL E (4) -C - SAVE -C - I = STI - J = STJ - DI = I - DJ = J - DI = STI - DI - DJ = STJ - DJ -C - HI = 0. -C TEST FOR POINT OFF GRID. - IF (I.LT.1 .OR. I.GT.MAXI) GO TO 300 - IF (J.LT.1 .OR. J.GT.MAXJ) GO TO 300 - IF (ITYPE .NE. 2) GO TO 100 -C DO BILINEAR IF POINT IS BETWEEN ULTIMATE AND -C PENULTIMATE ROWS, WHERE BIQUAD NOT POSSIBLE. - IF (I.LT.2 .OR. I.GT.(MAXI-1)) GO TO 100 - IF (J.LT.2 .OR. J.GT.(MAXJ-1)) GO TO 100 - GO TO 200 -C -C BILINEAR. - 100 CONTINUE - HI = FL(I ,J )*(1.-DI)*(1.-DJ) + FL(I+1,J )*DI*(1.-DJ) - & + FL(I ,J+1)*(1.-DI)*DJ + FL(I+1,J+1)*DI*DJ - GO TO 300 -C - 200 CONTINUE -C BIQUADRATIC. - DI2 = DI*(DI-1.)*.25 - DJ2 = DJ*(DJ-1.)*.25 - J1 = J - 1 - DO 250 K=1,4 - E(K) = FL(I ,J1)*(1.-DI-DI2) + FL(I+1,J1)*(DI-DI2) - & + (FL(I-1,J1) + FL(I+2,J1))*DI2 - J1 = J1 + 1 - 250 CONTINUE - HI = E(2)*(1.-DJ-DJ2) + E(3)*(DJ-DJ2) + (E(1) + E(4))*DJ2 -C - 300 CONTINUE - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft05.f b/src/fim/FIMsrc/w3/w3ft05.f deleted file mode 100644 index 7fda2f5..0000000 --- a/src/fim/FIMsrc/w3/w3ft05.f +++ /dev/null @@ -1,248 +0,0 @@ - SUBROUTINE W3FT05(ALOLA,APOLA,W1,W2,LINEAR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FT05 CONVERT (145,37) TO (65,65) N. HEMI. GRID -C AUTHOR: JONES,R.E. ORG: W342 DATE: 85-04-08 -C -C ABSTRACT: CONVERT A NORTHERN HEMISPHERE 2.5 DEGREE LAT.,LON. 145 BY -C 37 GRID TO A POLAR STEREOGRAPHIC 65 BY 65 GRID. THE POLAR -C STEREOGRAPHIC MAP PROJECTION IS TRUE AT 60 DEG. N. , THE MESH -C LENGTH IS 381 KM. AND THE ORIENTION IS 80 DEG. W. -C -C PROGRAM HISTORY LOG: -C 85-04-08 R.E.JONES -C 91-07-30 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C 92-05-02 R.E.JONES ADD SAVE -C -C USAGE: CALL W3FT05(ALOLA,APOLA,W1,W2,LINEAR) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C ALOLA ARG LIST 145*37 GRID 2.5 LAT,LON GRID N. HEMI. -C 5365 POINT GRID IS TYPE 29 OR 1D HEX O.N. 84 -C LINEAR ARG LIST 1 LINEAR INTERPOLATION , NE.1 BIQUADRATIC -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C APOLA ARG LIST 65*65 GRID OF NORTHERN HEMI. -C 4225 POINT GRID IS TYPE 27 OR 1B HEX O.N. 84 -C W1 ARG LIST 65*65 SCRATCH FIELD -C W2 ARG LIST 65*65 SCRATCH FIELD -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C ASIN ATAN2 SYSTEM -C -C REMARKS: -C -C 1. W1 AND W2 ARE USED TO STORE SETS OF CONSTANTS WHICH ARE -C REUSABLE FOR REPEATED CALLS TO THE SUBROUTINE. IF THEY ARE -C OVER WRITTEN BY THE USER, A WARNING MESSAGE WILL BE PRINTED -C AND W1 AND W2 WILL BE RECOMPUTED. -C -C 2. WIND COMPONENTS ARE NOT ROTATED TO THE 65*65 GRID ORIENTATION -C AFTER INTERPOLATION. YOU MAY USE W3FC08 TO DO THIS. -C -C 3. THE GRID POINTS VALUES ON THE EQUATOR HAVE BEEN EXTRAPOLATED -C OUTWARD TO ALL THE GRID POINTS OUTSIDE THE EQUATOR ON THE 65*65 -C GRID (ABOUT 1100 POINTS). -C -C 4. YOU SHOULD USE THE CRAY VECTORIZED VERSION W3FT05V ON THE CRAY -C IT HAS 3 PARAMETERS IN THE CALL, RUNS ABOUT 10 TIMES FASTER. USES -C MORE MEMORY. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - REAL ALOLA(145,37) - REAL APOLA(4225) - REAL ERAS(4) - REAL SAVEW1(10) - REAL SAVEW2(10) - REAL W1(4225) - REAL W2(4225) -C - INTEGER JY(4) - INTEGER OUT -C - LOGICAL LIN -C - SAVE -C - DATA DEGPRD/57.2957795/ - DATA EARTHR/6371.2/ - DATA ISWT /0/ - DATA OUT /6/ -C - 4000 FORMAT ( 52H *** WARNING , W1 OR W2 SCRATCH FILES OVER WRITTEN ,, - & 43H I WILL RESTORE THEM , BURNING UP CPU TIME,, - & 14H IN W3FT05 ***) -C - LIN = .FALSE. - IF (LINEAR.EQ.1) LIN = .TRUE. -C - IF (ISWT.EQ.0) GO TO 300 -C -C TEST W1 AND W2 TO SEE IF THEY WERE WRITTEN OVER -C - DO 100 KK=1,10 - IF (SAVEW1(KK).NE.W1(KK)) GO TO 200 - IF (SAVEW2(KK).NE.W2(KK)) GO TO 200 - 100 CONTINUE - GOTO 1000 -C - 200 CONTINUE - WRITE (OUT,4000) -C - 300 CONTINUE - DEG = 2.5 - NN = 0 - XMESH = 381.0 - GI2 = (1.86603*EARTHR) / XMESH - GI2 = GI2 * GI2 -C -C DO LOOP 800 PUTS SUBROUTINE W3FB01 IN LINE -C - DO 800 J = 1,65 - XJ = J - 33 - XJ2 = XJ * XJ - DO 800 I=1,65 - XI = I - 33 - R2 = XI*XI + XJ2 - IF (R2.NE.0.0) GO TO 400 - WLON = 0.0 - XLAT = 90.0 - GO TO 700 - 400 CONTINUE - XLONG = DEGPRD * ATAN2(XJ,XI) - IF (XLONG.GE.0.0) GO TO 500 - WLON = -10.0 - XLONG - IF (WLON.LT.0.0) WLON = WLON + 360.0 - GO TO 600 -C - 500 CONTINUE - WLON = 350.0 - XLONG - 600 CONTINUE - XLAT = ASIN((GI2-R2)/(GI2+R2))*DEGPRD - 700 CONTINUE - IF (WLON.GT.360.0) WLON = WLON - 360.0 - IF (WLON.LT.0.0) WLON = WLON + 360.0 - NN = NN + 1 - W1(NN) = ( 360.0 - WLON ) / DEG + 1.0 - W2(NN) = XLAT / DEG + 1.0 - 800 CONTINUE -C - DO 900 KK = 1,10 - SAVEW1(KK) = W1(KK) - SAVEW2(KK) = W2(KK) - 900 CONTINUE -C - ISWT = 1 -C - 1000 CONTINUE -C - DO 2100 KK = 1,4225 - I = W1(KK) - J = W2(KK) - FI = I - FJ = J - XDELI = W1(KK) - FI - XDELJ = W2(KK) - FJ - IP1 = I + 1 - JY(3) = J + 1 - JY(2) = J - IF (LIN) GO TO 1100 - IP2 = I + 2 - IM1 = I - 1 - JY(4) = J + 2 - JY(1) = J - 1 - XI2TM = XDELI * (XDELI-1.) * 0.25 - XJ2TM = XDELJ * (XDELJ-1.) * 0.25 -C - 1100 CONTINUE - IF ((I.LT.2).OR.(J.LT.2)) GO TO 1200 - IF ((I.GT.142).OR.(J.GT.34)) GO TO 1200 -C -C QUADRATIC (LINEAR TOO) OK W/O FURTHER ADO SO GO TO 1700 -C - GO TO 1700 -C - 1200 CONTINUE - IF (I.EQ.1) GO TO 1300 - IF (I.EQ.144) GO TO 1400 - IP2 = I + 2 - IM1 = I - 1 - GO TO 1500 -C - 1300 CONTINUE - IP2 = 3 - IM1 = 144 - GO TO 1500 -C - 1400 CONTINUE - IP2 = 2 - IM1 = 143 -C - 1500 CONTINUE - IP1 = I + 1 - IF (LIN) GO TO 1600 - IF ((J.LT.2).OR.(J.GE.36)) XJ2TM=0. -C.....DO NOT ALLOW POINT OFF GRID - IF (IP2.LT.1) IP2 = 1 - IF (IM1.LT.1) IM1 = 1 - IF (IP2.GT.145) IP2 = 145 - IF (IM1.GT.145) IM1 = 145 -C - 1600 CONTINUE -C.....DO NOT ALLOW POINT OFF GRID - IF (I.LT.1) I = 1 - IF (IP1.LT.1) IP1 = 1 - IF (I.GT.145) I = 145 - IF (IP1.GT.145) IP1 = 145 -C - 1700 CONTINUE - IF (.NOT.LIN) GO TO 1900 -C -C LINEAR INTERPLOATION -C - DO 1800 K = 2,3 - J1 = JY(K) - IF (J1.LT.1) J1 = 1 - IF (J1.GT.37) J1 = 37 - ERAS(K) = (ALOLA(IP1,J1) - ALOLA(I,J1)) * XDELI + ALOLA(I,J1) - 1800 CONTINUE -C - APOLA(KK) = ERAS(2) + (ERAS(3) - ERAS(2)) * XDELJ - GO TO 2100 -C - 1900 CONTINUE -C -C QUADRATIC INTERPOLATION -C - DO 2000 K = 1,4 - J1 = JY(K) -C.....DO NOT ALLOW POINT OFF GRID - IF (J1.LT.1) J1 = 1 - IF (J1.GT.37) J1 = 37 - ERAS(K) = (ALOLA(IP1,J1)-ALOLA(I,J1))*XDELI+ALOLA(I,J1)+ - & (ALOLA(IM1,J1)-ALOLA(I,J1)-ALOLA(IP1,J1)+ - & ALOLA(IP2,J1))*XI2TM - 2000 CONTINUE -C - APOLA(KK) = ERAS(2)+(ERAS(3)-ERAS(2))*XDELJ+(ERAS(1)- - & ERAS(2)-ERAS(3)+ERAS(4)) * XJ2TM -C - 2100 CONTINUE -C -C SET POLE POINT , WMO STANDARD FOR U OR V -C - APOLA(2113) = ALOLA(73,37) -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft05v.f b/src/fim/FIMsrc/w3/w3ft05v.f deleted file mode 100644 index 65f566d..0000000 --- a/src/fim/FIMsrc/w3/w3ft05v.f +++ /dev/null @@ -1,273 +0,0 @@ - SUBROUTINE W3FT05V(ALOLA,APOLA,INTERP) -C$$$ SUBROUTINE DOCUMENTATION BLOCK *** -C -C SUBROUTINE: W3FT05V CONVERT (145,37) GRID TO (65,65) N. HEMI. GRID -C AUTHOR: JONES,R.E. ORG: W342 DATE: 85-04-10 -C -C ABSTRACT: CONVERT A NORTHERN HEMISPHERE 2.5 DEGREE LAT.,LON. 145 BY -C 37 GRID TO A POLAR STEREOGRAPHIC 65 BY 65 GRID. THE POLAR -C STEREOGRAPHIC MAP PROJECTION IS TRUE AT 60 DEG. N. , THE MESH -C LENGTH IS 381 KM. AND THE ORIENTION IS 80 DEG. W. -C -C PROGRAM HISTORY LOG: -C 85-04-10 R.E.JONES VECTORIZED VERSION OF W3FT05 -C 89-10-21 R.E.JONES CHANGES TO INCREASE SPEED -C 91-07-25 R.E.JONES CHANGE TO CRAY CFT77 FORTRAN -C -C USAGE: CALL W3FT05V(ALOLA,APOLA,INTERP) -C -C INPUT ARGUMENTS: ALOLA - 145*37 GID 2.5 LAT,LON GRID N. HEMISPHERE -C 5365 POINT GRID IS O.N. 84 TYPE 29 OR 1D HEX -C INTERP - 1 LINEAR INTERPOLATION , NE.1 BIQUADRATIC -C -C INPUT FILES: NONE -C -C OUTPUT ARGUMENTS: APOLA - 65*65 GRID OF NORTHERN HEMISPHERE. -C 4225 POINT GRID IS O.N.84 TYPE 27 OR 1B HEX -C -C OUTPUT FILES: ERROR MESSAGE TO FORTRAN OUTPUT FILE -C -C WARNINGS: -C -C 1. W1 AND W2 ARE USED TO STORE SETS OF CONSTANTS WHICH ARE -C REUSABLE FOR REPEATED CALLS TO THE SUBROUTINE. -C -C 2. WIND COMPONENTS ARE NOT ROTATED TO THE 65*65 GRID ORIENTATION -C AFTER INTERPOLATION. YOU MAY USE W3FC08 TO DO THIS. -C -C 3. THE GRID POINTS VALUES ON THE EQUATOR HAVE BEEN EXTRAPOLATED -C OUTWARD TO ALL THE GRID POINTS OUTSIDE THE EQUATOR ON THE 65*65 -C GRID (ABOUT 1100 POINTS). -C -C RETURN CONDITIONS: NORMAL SUBROUTINE EXIT -C -C SUBPROGRAMS CALLED: -C UNIQUE : NONE -C -C LIBRARY: ASIN , ATAN2 -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/864 -C -C$$$ -C - REAL R2(4225), WLON(4225) - REAL XLAT(4225), XI(65,65), XJ(65,65) - REAL XII(4225), XJJ(4225), ANGLE(4225) - REAL ALOLA(145,37), APOLA(4225), ERAS(4225,4) - REAL W1(4225), W2(4225) - REAL XDELI(4225), XDELJ(4225) - REAL XI2TM(4225), XJ2TM(4225) -C - INTEGER IV(4225), JV(4225), JY(4225,4) - INTEGER IM1(4225), IP1(4225), IP2(4225) -C - LOGICAL LIN -C - SAVE -C - EQUIVALENCE (XI(1,1),XII(1)),(XJ(1,1),XJJ(1)) -C - DATA DEGPRD/57.2957795/ - DATA EARTHR/6371.2/ - DATA INTRPO/99/ - DATA ISWT /0/ -C - LIN = .FALSE. - IF (INTERP.EQ.1) LIN = .TRUE. -C - IF (ISWT.EQ.1) GO TO 900 -C - ORIENT = 80.0 - DEG = 2.5 - XMESH = 381.0 - GI2 = (1.86603 * EARTHR) / XMESH - GI2 = GI2 * GI2 -C -C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB01 IN LINE -C - DO 100 J = 1,65 - XJ1 = J - 33 - DO 100 I = 1,65 - XI(I,J) = I - 33 - XJ(I,J) = XJ1 - 100 CONTINUE -C - DO 200 KK = 1,4225 - R2(KK) = XJJ(KK) * XJJ(KK) + XII(KK) * XII(KK) - XLAT(KK) = DEGPRD * - & ASIN((GI2 - R2(KK)) / (GI2 + R2(KK))) - 200 CONTINUE -C - XII(2113) = 1.0 - DO 300 KK = 1,4225 - ANGLE(KK) = DEGPRD * ATAN2(XJJ(KK),XII(KK)) - 300 CONTINUE -C - DO 400 KK = 1,4225 - IF (ANGLE(KK).LT.0.0) ANGLE(KK) = ANGLE(KK) + 360.0 - 400 CONTINUE -C - DO 500 KK = 1,4225 - WLON(KK) = 270.0 + ORIENT - ANGLE(KK) - 500 CONTINUE -C - DO 600 KK = 1,4225 - IF (WLON(KK).LT.0.0) WLON(KK) = WLON(KK) + 360.0 - 600 CONTINUE -C - DO 700 KK = 1,4225 - IF (WLON(KK).GE.360.0) WLON(KK) = WLON(KK) - 360.0 - 700 CONTINUE -C - XLAT(2113) = 90.0 - WLON(2113) = 0.0 -C - DO 800 KK = 1,4225 - W1(KK) = (360.0 - WLON(KK)) / DEG + 1.0 - W2(KK) = XLAT(KK) / DEG + 1.0 - 800 CONTINUE -C - ISWT = 1 - INTRPO = INTERP - GO TO 1000 -C -C AFTER THE 1ST CALL TO W3FT05V TEST INTERP, IF IT HAS -C CHANGED RECOMPUTE SOME CONSTANTS -C - 900 CONTINUE - IF (INTERP.EQ.INTRPO) GO TO 2100 - INTRPO = INTERP -C - 1000 CONTINUE - DO 1100 K = 1,4225 - IV(K) = W1(K) - JV(K) = W2(K) - XDELI(K) = W1(K) - IV(K) - XDELJ(K) = W2(K) - JV(K) - IP1(K) = IV(K) + 1 - JY(K,3) = JV(K) + 1 - JY(K,2) = JV(K) - 1100 CONTINUE -C - IF (LIN) GO TO 1400 -C - DO 1200 K = 1,4225 - IP2(K) = IV(K) + 2 - IM1(K) = IV(K) - 1 - JY(K,1) = JV(K) - 1 - JY(K,4) = JV(K) + 2 - XI2TM(K) = XDELI(K) * (XDELI(K) - 1.0) * .25 - XJ2TM(K) = XDELJ(K) * (XDELJ(K) - 1.0) * .25 - 1200 CONTINUE -C - DO 1300 KK = 1,4225 - IF (IV(KK).EQ.1) THEN - IP2(KK) = 3 - IM1(KK) = 144 - ELSE IF (IV(KK).EQ.144) THEN - IP2(KK) = 2 - IM1(KK) = 143 - ENDIF - 1300 CONTINUE -C - 1400 CONTINUE -C - IF (LIN) GO TO 1700 -C - DO 1500 KK = 1,4225 - IF (JV(KK).LT.2.OR.JV(KK).GT.35) XJ2TM(KK) = 0.0 - 1500 CONTINUE -C - DO 1600 KK = 1,4225 - IF (IP2(KK).LT.1) IP2(KK) = 1 - IF (IM1(KK).LT.1) IM1(KK) = 1 - IF (IP2(KK).GT.145) IP2(KK) = 145 - IF (IM1(KK).GT.145) IM1(KK) = 145 - 1600 CONTINUE -C - 1700 CONTINUE - DO 1800 KK = 1,4225 - IF (IV(KK).LT.1) IV(KK) = 1 - IF (IP1(KK).LT.1) IP1(KK) = 1 - IF (IV(KK).GT.145) IV(KK) = 145 - IF (IP1(KK).GT.145) IP1(KK) = 145 - 1800 CONTINUE -C -C LINEAR INTERPOLATION -C - DO 1900 KK = 1,4225 - IF (JY(KK,2).LT.1) JY(KK,2) = 1 - IF (JY(KK,2).GT.37) JY(KK,2) = 37 - IF (JY(KK,3).LT.1) JY(KK,3) = 1 - IF (JY(KK,3).GT.37) JY(KK,3) = 37 - 1900 CONTINUE -C - IF (.NOT.LIN) THEN - DO 2000 KK = 1,4225 - IF (JY(KK,1).LT.1) JY(KK,1) = 1 - IF (JY(KK,1).GT.37) JY(KK,1) = 37 - IF (JY(KK,4).LT.1) JY(KK,4) = 1 - IF (JY(KK,4).GT.37) JY(KK,4) = 37 - 2000 CONTINUE - ENDIF -C - 2100 CONTINUE - IF (LIN) THEN -C -C LINEAR INTERPOLATION -C - DO 2200 KK = 1,4225 - ERAS(KK,2) = (ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) - ERAS(KK,3) = (ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) - 2200 CONTINUE -C - DO 2300 KK = 1,4225 - APOLA(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) - 2300 CONTINUE -C - ELSE -C -C QUADRATIC INTERPOLATION -C - DO 2400 KK = 1,4225 - ERAS(KK,1)=(ALOLA(IP1(KK),JY(KK,1))-ALOLA(IV(KK),JY(KK,1))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,1)) + - & ( ALOLA(IM1(KK),JY(KK,1)) - ALOLA(IV(KK),JY(KK,1)) - & - ALOLA(IP1(KK),JY(KK,1))+ALOLA(IP2(KK),JY(KK,1))) - & * XI2TM(KK) - ERAS(KK,2)=(ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) + - & ( ALOLA(IM1(KK),JY(KK,2)) - ALOLA(IV(KK),JY(KK,2)) - & - ALOLA(IP1(KK),JY(KK,2))+ALOLA(IP2(KK),JY(KK,2))) - & * XI2TM(KK) - ERAS(KK,3)=(ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) + - & ( ALOLA(IM1(KK),JY(KK,3)) - ALOLA(IV(KK),JY(KK,3)) - & - ALOLA(IP1(KK),JY(KK,3))+ALOLA(IP2(KK),JY(KK,3))) - & * XI2TM(KK) - ERAS(KK,4)=(ALOLA(IP1(KK),JY(KK,4))-ALOLA(IV(KK),JY(KK,4))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,4)) + - & ( ALOLA(IM1(KK),JY(KK,4)) - ALOLA(IV(KK),JY(KK,4)) - & - ALOLA(IP1(KK),JY(KK,4))+ALOLA(IP2(KK),JY(KK,4))) - & * XI2TM(KK) - 2400 CONTINUE -C - DO 2500 KK = 1,4225 - APOLA(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) + (ERAS(KK,1) - ERAS(KK,2) - & - ERAS(KK,3) + ERAS(KK,4)) * XJ2TM(KK) - 2500 CONTINUE -C - ENDIF -C -C SET POLE POINT , WMO STANDARD FOR U OR V -C - APOLA(2113) = ALOLA(73,37) -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft06.f b/src/fim/FIMsrc/w3/w3ft06.f deleted file mode 100644 index c75a247..0000000 --- a/src/fim/FIMsrc/w3/w3ft06.f +++ /dev/null @@ -1,242 +0,0 @@ - SUBROUTINE W3FT06(ALOLA,APOLA,W1,W2,LINEAR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FT06 CONVERT (145,37) TO (65,65) S. HEMI. GRID -C AUTHOR: JONES,R.E. ORG: W342 DATE: 84-06-18 -C -C ABSTRACT: CONVERT A SOUTHERN HEMISPHERE 2.5 DEGREE LAT.,LON. 145 BY -C 37 GRID TO A POLAR STEREOGRAPHIC 65 BY 65 GRID. THE POLAR -C STEREOGRAPHIC MAP PROJECTION IS TRUE AT 60 DEG. S. , THE MESH -C LENGTH IS 381 KM. AND THE ORIENTION IS 260 DEG. W.(100E) . -C -C PROGRAM HISTORY LOG: -C 84-06-18 R.E.JONES -C 91-07-30 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C 92-05-02 R.E.JONES ADD SAVE -C -C USAGE: CALL W3FT06(ALOLA,APOLA,W1,W2,LINEAR) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C ALOLA ARG LIST 145*37 DEG 2.5 LAT,LON GRID S. HEMI. -C 5365 POINT GRID IS TYPE 30 OR 1E HEX O.N. 84 -C LINEAR ARG LIST 1 LINEAR INTERPOLATION , NE.1 BIQUADRATIC -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C APOLA ARG LIST 65*65 GRID OF SOUTHERN HEMI. -C 4225 POINT GRID IS TYPE 28 OR 1C HEX O.N. 84 -C W1 ARG LIST 65*65 SCRATCH FIELD -C W2 ARG LIST 65*65 SCRATCH FIELD -C FT06F001 ERROR MESSAGE -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C ASIN ATAN2 SYSTEM -C -C REMARKS: -C -C 1. W1 AND W2 ARE USED TO STORE SETS OF CONSTANTS WHICH ARE -C REUSABLE FOR REPEATED CALLS TO THE SUBROUTINE. IF THEY ARE -C OVER WRITTEN BY THE USER, A WARNING MESSAGE WILL BE PRINTED -C AND W1 AND W2 WILL BE RECOMPUTED. -C -C 2. WIND COMPONENTS ARE NOT ROTATED TO THE 65*65 GRID ORIENTATION -C AFTER INTERPOLATION. YOU MAY USE W3FC10 TO DO THIS. -C -C 3. THE GRID POINTS VALUES ON THE EQUATOR HAVE BEEN EXTRAPOLATED -C OUTWARD TO ALL THE GRID POINTS OUTSIDE THE EQUATOR ON THE 65*65 -C GRID (ABOUT 1100 POINTS). -C -C 4. YOU SHOULD USE THE CRAY VECTORIZED VERION W3FT06V ON THE CRAY -C IT HAS 3 PARAMETERS IN THE CALL, RUNS ABOUT TIMES FASTER, USES -C MORE MEMORY. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/864 -C -C$$$ -C - REAL ALOLA(145,37) - REAL APOLA(4225) - REAL ERAS(4) - REAL SAVEW1(10) - REAL SAVEW2(10) - REAL W1(4225) - REAL W2(4225) -C - INTEGER JY(4) - INTEGER OUT -C - LOGICAL LIN -C - SAVE -C - DATA DEGPRD/57.2957795/ - DATA EARTHR/6371.2/ - DATA ISWT /0/ - DATA OUT /6/ -C - 4000 FORMAT ( 52H *** WARNING , W1 OR W2 SCRATCH FILES OVER WRITTEN ,, - & 43H I WILL RESTORE THEM , BURNING UP CPU TIME,, - & 14H IN W3FT06 ***) -C - LIN = .FALSE. - IF (LINEAR.EQ.1) LIN = .TRUE. - IF (ISWT.EQ.0) GO TO 300 -C -C TEST TO SEE IF W1 OR W2 WAS WRITTEN OVER -C - DO 100 KK=1,10 - IF (SAVEW1(KK).NE.W1(KK)) GO TO 200 - IF (SAVEW2(KK).NE.W2(KK)) GO TO 200 - 100 CONTINUE - GO TO 800 -C - 200 CONTINUE - WRITE (OUT,4000) -C - 300 CONTINUE - DEG = 2.5 - NN = 0 - XMESH = 381.0 - GI2 = (1.86603*EARTHR) / XMESH - GI2 = GI2 * GI2 -C -C DO LOOP 600 PUTS SUBROUTINE W3FB03 IN LINE -C - DO 600 J=1,65 - XJ = J - 33 - XJ2 = XJ * XJ - DO 600 I=1,65 - XI = I - 33 - R2 = XI*XI + XJ2 - IF (R2.NE.0.0) GO TO 400 - WLON = 0.0 - XLAT = -90.0 - GO TO 500 - 400 CONTINUE - XLONG = DEGPRD * ATAN2(XJ,XI) - WLON = XLONG -10.0 - IF (WLON.LT.0.0) WLON = WLON + 360.0 - XLAT = ASIN((GI2-R2)/(GI2+R2))*DEGPRD - XLAT = -XLAT - 500 CONTINUE - XLAT = XLAT + 90.0 - IF (WLON.GT.360.0) WLON = WLON - 360.0 - IF (WLON.LT.0.0) WLON = WLON + 360.0 - NN = NN + 1 - W1(NN) = ( 360.0 - WLON ) / DEG + 1.0 - W2(NN) = XLAT / DEG + 1.0 - 600 CONTINUE -C - DO 700 KK=1,10 - SAVEW1(KK)=W1(KK) - SAVEW2(KK)=W2(KK) - 700 CONTINUE -C - ISWT = 1 -C - 800 CONTINUE -C - DO 1900 KK=1,4225 - I = W1(KK) - J = W2(KK) - FI = I - FJ = J - XDELI = W1(KK) - FI - XDELJ = W2(KK) - FJ - IP1 = I + 1 - JY(3) = J + 1 - JY(2) = J - IF (LIN) GO TO 900 - IP2 = I + 2 - IM1 = I - 1 - JY(4) = J + 2 - JY(1) = J - 1 - XI2TM = XDELI*(XDELI-1.)*.25 - XJ2TM = XDELJ*(XDELJ-1.)*.25 - 900 CONTINUE - IF ((I.LT.2).OR.(J.LT.2)) GO TO 1000 - IF ((I.GT.142).OR.(J.GT.34)) GO TO 1000 -C QUADRATIC (LINEAR TOO) OK W/O FURTHER ADO SO GO TO 1500 - GO TO 1500 -C - 1000 CONTINUE - IF (I.EQ.1) GO TO 1100 - IF (I.EQ.144) GO TO 1200 - IP2 = I+2 - IM1 = I-1 - GO TO 1300 -C - 1100 CONTINUE - IP2 = 3 - IM1 = 144 - GO TO 1300 -C - 1200 CONTINUE - IP2 = 2 - IM1 = 143 -C - 1300 CONTINUE - IP1 = I + 1 - IF (LIN) GO TO 1400 - IF ((J.LT.2).OR.(J.GE.36)) XJ2TM=0. -C.....DO NOT ALLOW POINT OFF GRID,CYCLIC OR NOT - IF (IP2.LT.1) IP2 = 1 - IF (IM1.LT.1) IM1 = 1 - IF (IP2.GT.145) IP2 = 145 - IF (IM1.GT.145) IM1 = 145 -C - 1400 CONTINUE -C.....DO NOT ALLOW POINT OFF GRID,CYCLIC OR NOT - IF (I.LT.1) I = 1 - IF (IP1.LT.1) IP1 = 1 - IF (I.GT.145) I = 145 - IF (IP1.GT.145) IP1 = 145 -C - 1500 CONTINUE -C - IF (.NOT.LIN) GO TO 1700 -C -C LINEAR INTERPOLATION -C - DO 1600 K = 2,3 - J1 = JY(K) - IF (J1.LT.1) J1=1 - IF (J1.GT.37) J1=37 - ERAS(K) = (ALOLA(IP1,J1) - ALOLA(I,J1)) * XDELI + ALOLA(I,J1) - 1600 CONTINUE -C - APOLA(KK) = ERAS(2) + (ERAS(3) - ERAS(2)) * XDELJ - GO TO 1900 -C - 1700 CONTINUE -C -C QUADRATIC INTERPOLATION -C - DO 1800 K = 1,4 - J1 = JY(K) -C.....DO NOT ALLOW POINT OFF GRID,CYCLIC OR NOT - IF (J1.LT.1) J1=1 - IF (J1.GT.37) J1=37 - ERAS(K)=(ALOLA(IP1,J1)-ALOLA(I,J1))*XDELI+ALOLA(I,J1)+ - & (ALOLA(IM1,J1)-ALOLA(I,J1)-ALOLA(IP1,J1)+ - & ALOLA(IP2,J1))*XI2TM - 1800 CONTINUE -C - APOLA(KK) = ERAS(2)+(ERAS(3)-ERAS(2))*XDELJ+(ERAS(1)- - & ERAS(2)-ERAS(3)+ERAS(4))*XJ2TM -C - 1900 CONTINUE -C -C SET POLE POINT, WMO STANDARD FOR U OR V -C - APOLA(2113) = ALOLA(73,1) -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft06v.f b/src/fim/FIMsrc/w3/w3ft06v.f deleted file mode 100644 index 7af5497..0000000 --- a/src/fim/FIMsrc/w3/w3ft06v.f +++ /dev/null @@ -1,273 +0,0 @@ - SUBROUTINE W3FT06V(ALOLA,APOLA,INTERP) -C$$$ SUBROUTINE DOCUMENTATION BLOCK *** -C -C SUBROUTINE: W3FT06V CONVERT (145,37) GRID TO (65,65) S. HEMI. GRID -C AUTHOR: JONES,R.E. ORG: W342 DATE: 85-04-10 -C -C ABSTRACT: CONVERT A SOUTHERN HEMISPHERE 2.5 DEGREE LAT.,LON. 145 BY -C 37 GRID TO A POLAR STEREOGRAPHIC 65 BY 65 GRID. THE POLAR -C STEREOGRAPHIC MAP PROJECTION IS TRUE AT 60 DEG. S. , THE MESH -C LENGTH IS 381 KM. AND THE ORIENTION IS 260 DEG. W. -C -C PROGRAM HISTORY LOG: -C 85-04-10 R.E.JONES VECTORIZED VERSION OF W3FT05 -C 89-10-21 R.E.JONES CHANGES TO INCREASE SPEED -C 91-07-24 R.E.JONES CHANGE TO CRAY CFT77 FORTRAN -C 93-05-31 R.E.JONES RECOMPILE SO LINEAR INTERPOLATION WORKS -C -C USAGE: CALL W3FT06V(ALOLA,APOLA,INTERP) -C -C INPUT ARGUMENTS: ALOLA - 145*37 GID 2.5 LAT,LON GRID S. HEMISHERE -C 5365 POINT GRID IS O.N.84 TYPE 30 OR 1E HEX -C INTERP - 1 LINEAR INTERPOLATION , NE.1 BIQUADRATIC -C -C INPUT FILES: NONE -C -C OUTPUT ARGUMENTS: APOLA - 65*65 GRID OF NORTHERN HEMI. -C 4225 POINT GRID IS O.N.84 TYPE 28 OR 1C HEX -C -C OUTPUT FILES: ERROR MESSAGE TO FORTRAN OUTPUT FILE -C -C WARNINGS: -C -C 1. W1 AND W2 ARE USED TO STORE SETS OF CONSTANTS WHICH ARE -C REUSABLE FOR REPEATED CALLS TO THE SUBROUTINE. -C -C 2. WIND COMPONENTS ARE NOT ROTATED TO THE 65*65 GRID ORIENTATION -C AFTER INTERPOLATION. YOU MAY USE W3FC10 TO DO THIS. -C -C 3. THE GRID POINTS VALUES ON THE EQUATOR HAVE BEEN EXTRAPOLATED -C OUTWARD TO ALL THE GRID POINTS OUTSIDE THE EQUATOR ON THE 65*65 -C GRID (ABOUT 1100 POINTS). -C -C RETURN CONDITIONS: NORMAL SUBROUTINE EXIT -C -C SUBPROGRAMS CALLED: -C UNIQUE : NONE -C -C LIBRARY: ASIN , ATAN2 -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/864 -C -C$$$ -C - REAL R2(4225), WLON(4225) - REAL XLAT(4225), XI(65,65), XJ(65,65) - REAL XII(4225), XJJ(4225), ANGLE(4225) - REAL ALOLA(145,37), APOLA(4225), ERAS(4225,4) - REAL W1(4225), W2(4225) - REAL XDELI(4225), XDELJ(4225) - REAL XI2TM(4225), XJ2TM(4225) -C - INTEGER IV(4225), JV(4225), JY(4225,4) - INTEGER IM1(4225), IP1(4225), IP2(4225) -C - LOGICAL LIN -C - SAVE -C - EQUIVALENCE (XI(1,1),XII(1)),(XJ(1,1),XJJ(1)) -C - DATA DEGPRD/57.2957795/ - DATA EARTHR/6371.2/ - DATA INTRPO/99/ - DATA ISWT /0/ -C - LIN = .FALSE. - IF (INTERP.EQ.1) LIN = .TRUE. - IF (ISWT.EQ.1) GO TO 900 -C - ORIENT = 260.0 - DEG = 2.5 - XMESH = 381.0 - GI2 = (1.86603 * EARTHR) / XMESH - GI2 = GI2 * GI2 -C -C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB03 IN LINE -C - DO 100 J = 1,65 - XJ1 = J - 33 - DO 100 I = 1,65 - XI(I,J) = I - 33 - XJ(I,J) = XJ1 - 100 CONTINUE -C - DO 200 KK = 1,4225 - R2(KK) = XJJ(KK) * XJJ(KK) + XII(KK) * XII(KK) - XLAT(KK) = -DEGPRD * - & ASIN((GI2 - R2(KK)) / (GI2 + R2(KK))) - 200 CONTINUE -C - XII(2113) = 1.0 - DO 300 KK = 1,4225 - ANGLE(KK) = DEGPRD * ATAN2(XJJ(KK),XII(KK)) - 300 CONTINUE -C - DO 400 KK = 1,4225 - IF (ANGLE(KK).LT.0.0) ANGLE(KK) = ANGLE(KK) + 360.0 - 400 CONTINUE -C - DO 500 KK = 1,4225 - WLON(KK) = ANGLE(KK) + ORIENT - 270.0 - 500 CONTINUE -C - DO 600 KK = 1,4225 - IF (WLON(KK).GE.360.0) WLON(KK) = WLON(KK) - 360.0 - 600 CONTINUE -C - DO 700 KK = 1,4225 - IF (WLON(KK).LT.0.0) WLON(KK) = WLON(KK) + 360.0 - 700 CONTINUE -C - XLAT(2113) = -90.0 - WLON(2113) = 0.0 -C - DO 800 KK = 1,4225 - W1(KK) = (360.0 - WLON(KK)) / DEG + 1.0 - W2(KK) = (XLAT(KK) + 90.0) / DEG + 1.0 - 800 CONTINUE -C - ISWT = 1 - INTRPO = INTERP - GO TO 1000 -C -C AFTER THE 1ST CALL TO W3FT05 TEST INTERP, IF IT HAS -C CHANGED RECOMPUTE SOME CONSTANTS -C - 900 CONTINUE - IF (INTERP.EQ.INTRPO) GO TO 2100 - INTRPO = INTERP -C - 1000 CONTINUE - DO 1100 K = 1,4225 - IV(K) = W1(K) - JV(K) = W2(K) - XDELI(K) = W1(K) - IV(K) - XDELJ(K) = W2(K) - JV(K) - IP1(K) = IV(K) + 1 - JY(K,3) = JV(K) + 1 - JY(K,2) = JV(K) - 1100 CONTINUE -C - IF (LIN) GO TO 1400 -C - DO 1200 K = 1,4225 - IP2(K) = IV(K) + 2 - IM1(K) = IV(K) - 1 - JY(K,1) = JV(K) - 1 - JY(K,4) = JV(K) + 2 - XI2TM(K) = XDELI(K) * (XDELI(K) - 1.0) * .25 - XJ2TM(K) = XDELJ(K) * (XDELJ(K) - 1.0) * .25 - 1200 CONTINUE -C - DO 1300 KK = 1,4225 - IF (IV(KK).EQ.1) THEN - IP2(KK) = 3 - IM1(KK) = 144 - ELSE IF (IV(KK).EQ.144) THEN - IP2(KK) = 2 - IM1(KK) = 143 - ENDIF - 1300 CONTINUE -C - 1400 CONTINUE -C - IF (LIN) GO TO 1700 -C - DO 1500 KK = 1,4225 - IF (JV(KK).LT.2.OR.JV(KK).GT.35) XJ2TM(KK) = 0.0 - 1500 CONTINUE -C - DO 1600 KK = 1,4225 - IF (IP2(KK).LT.1) IP2(KK) = 1 - IF (IM1(KK).LT.1) IM1(KK) = 1 - IF (IP2(KK).GT.145) IP2(KK) = 145 - IF (IM1(KK).GT.145) IM1(KK) = 145 - 1600 CONTINUE -C - 1700 CONTINUE - DO 1800 KK = 1,4225 - IF (IV(KK).LT.1) IV(KK) = 1 - IF (IP1(KK).LT.1) IP1(KK) = 1 - IF (IV(KK).GT.145) IV(KK) = 145 - IF (IP1(KK).GT.145) IP1(KK) = 145 - 1800 CONTINUE -C -C LINEAR INTERPOLATION -C - DO 1900 KK = 1,4225 - IF (JY(KK,2).LT.1) JY(KK,2) = 1 - IF (JY(KK,2).GT.37) JY(KK,2) = 37 - IF (JY(KK,3).LT.1) JY(KK,3) = 1 - IF (JY(KK,3).GT.37) JY(KK,3) = 37 - 1900 CONTINUE -C - IF (.NOT.LIN) THEN - DO 2000 KK = 1,4225 - IF (JY(KK,1).LT.1) JY(KK,1) = 1 - IF (JY(KK,1).GT.37) JY(KK,1) = 37 - IF (JY(KK,4).LT.1) JY(KK,4) = 1 - IF (JY(KK,4).GT.37) JY(KK,4) = 37 - 2000 CONTINUE - ENDIF -C - 2100 CONTINUE - IF (LIN) THEN -C -C LINEAR INTERPOLATION -C - DO 2200 KK = 1,4225 - ERAS(KK,2) = (ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) - ERAS(KK,3) = (ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) - 2200 CONTINUE -C - DO 2300 KK = 1,4225 - APOLA(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) - 2300 CONTINUE -C - ELSE -C -C QUADRATIC INTERPOLATION -C - DO 2400 KK = 1,4225 - ERAS(KK,1)=(ALOLA(IP1(KK),JY(KK,1))-ALOLA(IV(KK),JY(KK,1))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,1)) + - & ( ALOLA(IM1(KK),JY(KK,1)) - ALOLA(IV(KK),JY(KK,1)) - & - ALOLA(IP1(KK),JY(KK,1))+ALOLA(IP2(KK),JY(KK,1))) - & * XI2TM(KK) - ERAS(KK,2)=(ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) + - & ( ALOLA(IM1(KK),JY(KK,2)) - ALOLA(IV(KK),JY(KK,2)) - & - ALOLA(IP1(KK),JY(KK,2))+ALOLA(IP2(KK),JY(KK,2))) - & * XI2TM(KK) - ERAS(KK,3)=(ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) + - & ( ALOLA(IM1(KK),JY(KK,3)) - ALOLA(IV(KK),JY(KK,3)) - & - ALOLA(IP1(KK),JY(KK,3))+ALOLA(IP2(KK),JY(KK,3))) - & * XI2TM(KK) - ERAS(KK,4)=(ALOLA(IP1(KK),JY(KK,4))-ALOLA(IV(KK),JY(KK,4))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,4)) + - & ( ALOLA(IM1(KK),JY(KK,4)) - ALOLA(IV(KK),JY(KK,4)) - & - ALOLA(IP1(KK),JY(KK,4))+ALOLA(IP2(KK),JY(KK,4))) - & * XI2TM(KK) - 2400 CONTINUE -C - DO 2500 KK = 1,4225 - APOLA(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) + (ERAS(KK,1) - ERAS(KK,2) - & - ERAS(KK,3) + ERAS(KK,4)) * XJ2TM(KK) - 2500 CONTINUE -C - ENDIF -C -C SET POLE POINT , WMO STANDARD FOR U OR V -C - APOLA(2113) = ALOLA(73,1) -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft07.f b/src/fim/FIMsrc/w3/w3ft07.f deleted file mode 100644 index 53f09a7..0000000 --- a/src/fim/FIMsrc/w3/w3ft07.f +++ /dev/null @@ -1,232 +0,0 @@ - SUBROUTINE W3FT07(FLDA,IA,JA,AIPOLE,AJPOLE,BIPOLE,BJPOLE, - A DSCALE,ANGLE,LINEAR,LDEFQQ,DEFALT,FLDB,IB,JB) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FT07 TRANSFORM GRIDPOINT FLD BY INTERPOLATION -C PRGMMR: LIN ORG: NMC412 DATE:93-03-24 -C -C ABSTRACT: TRANSFORMS DATA CONTAINED IN A GIVEN GRID ARRAY -C BY TRANSLATION, ROTATION ABOUT A COMMON POINT AND DILATATION -C IN ORDER TO CREATE A NEW GRID ARRAY ACCORDING TO SPECS. -C -C PROGRAM HISTORY LOG: -C 74-09-01 ORIGINAL AUTHOR(S): J. MCDONELL, J.HOWCROFT -C 84-06-27 R.E.JONES CHANGE TO IBM VS FORTRAN -C 89-01-24 R.E.JONES CHANGE TO MICROSOFT FORTRAN 4.10 -C 89-03-31 R.E.JONES CHANGE TO VAX-11 FORTRAN -C 93-03-16 D. SHIMOMURA -- RENAMED FROM W3FT00() TO W3FT07() -C IN ORDER TO MAKE MINOR MODS WHILE DOING F77. -C CHANGES TO CALL SEQUENCE; CHANGES TO VRBL NAMES; -C ADDED COMMENTS. -C -C ... 1 2 3 4 5 6 7 8 -C USAGE: CALL W3FT07(FLDA,IA,JA,AIPOLE,AJPOLE,BIPOLE,BJPOLE,DSCALE, -C ANGLE,LINEAR,LDEFQQ,DEFALT,FLDB,IB,JB) -C 9 10 11 12 13 14 15 -C INPUT ARGUMENT LIST: -C FLDA(IA,JA) - REAL*4 ORIGINAL SOURCE GRID-POINT DATA FIELD -C AIPOLE,AJPOLE - REAL*4 COMMON POINT I- AND J-COORDINATES OF THE -C ORIGINAL FIELD, ASSUMING A RIGHT-HAND CARTESIAN -C COORDINATE SYSTEM. THE POINT NEED NOT BE INSIDE -C THE BOUNDS OF EITHER GRID -C AND CAN HAVE FRACTIONAL VALUES. -C COMMON POINT ABOUT WHICH TO ROTATE THE GRIDPOINTS -C BIPOLE,BJPOLE - REAL*4 COMMON POINT I- AND J-COORDINATES FOR -C TRANSFORMED DESTINATION GRID -C DSCALE - REAL*4 SCALE-CHANGE (DILATION) EXPRESSED AS -C A RATIO OF THE TRANSFORMED FIELD TO THE ORIGINAL -C FIELD -C DSCALE = GRDLENKM(DESTINATION) / GRDLENKM(SOURCE) -C -C ANGLE - REAL*4 DEGREE MEASURE OF THE ANGLE REQUIRED TO -C ROTATE THE J-ROW OF THE ORIGINAL GRID INTO -C COINCIDENCE WITH THE NEW GRID. (+ COUNTER- -C CLOCKWISE, - CLOCKWISE) -C ANGLE = VERTLONW(SOURCE) - VERTLONW(DESTINATION) -C -C LINEAR - LOGICAL*4 INTERPOLATION-METHOD SELECTION SWITCH: -C .TRUE. BI-LINEAR INTERPOLATION -C .FALSE. BI-QUADRATIC INTERPOLATION -C -C LDEFQQ - LOGICAL*4 DEFAULT-VALUE SWITCH: -C IF .TRUE. THEN -C USE DEFAULT-VALUE FOR DESTINATION POINT -C OUT-OF-BOUNDS OF GIVEN GRID; -C ELSE -C EXTRAPOLATE COARSELY FROM NEARBY BNDRY POINT -C -C DEFALT - REAL*4 THE DEFAULT-VALUE TO USE IF LDEFQQ = .TRUE. -C -C OUTPUT ARGUMENT LIST: -C FLDB(IB,JB) - REAL*4 RESULTING TRANSFORMED DESTINATION FIELD -C -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C IN GENERAL 'FLDA' AND 'FLDB' CANNOT BE EQUIVALENCED -C ALTHOUGH THERE ARE SITUATIONS IN WHICH IT WOULD BE SAFE TO DO -C SO. CARE SHOULD BE TAKEN THAT ALL OF THE NEW GRID POINTS LIE -C WITHIN THE ORIGINAL GRID, NO ERROR CHECKS ARE MADE. -C -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN 77 -C MACHINE: CRAY Y-MP8/864 -C -C$$$ -C - REAL FLDA(IA,JA) - REAL AIPOLE,AJPOLE - REAL BIPOLE,BJPOLE - REAL DSCALE - REAL ANGLE - REAL DEFALT - REAL FLDB(IB,JB) - REAL ERAS(4) - REAL TINY -C - LOGICAL LINEAR - LOGICAL LDEFQQ -C - SAVE -C - DATA TINY / 0.001 / -C -C ... WHERE TINY IS IN UNITS OF 1.0 = 1 GRID INTERVAL -C -C . . . . . S T A R T . . . . . . . . . . . . . . . . . . . -C - THETA = ANGLE * (3.14159/180.) - SINT = SIN (THETA) - COST = COS (THETA) -C -C ... WE WILL SCAN ALONG THE J-ROW OF THE DESTINATION GRID ... - DO 288 JN = 1,JB - BRELJ = FLOAT(JN) - BJPOLE -C - DO 277 IN = 1,IB - BRELI = FLOAT(IN) - BIPOLE - STI = AIPOLE + DSCALE*(BRELI*COST - BRELJ*SINT) - STJ = AJPOLE + DSCALE*(BRELI*SINT + BRELJ*COST) - IM = STI - JM = STJ -C -C ... THE PT(STI,STJ) IS THE LOCATION OF THE FLDB(IN,JN) -C ... IN FLDA,S COORDINATE SYSTEM -C ... IS THIS POINT LOCATED OUTSIDE FLDA? -C ... ON THE BOUNDARY LINE OF FLDA? -C ... ON THE FIRST INTERIOR GRIDPOINT OF FLDA? -C ... GOOD INSIDER, AT LEAST 2 INTERIOR GRIDS INSIDE? - IOFF = 0 - JOFF = 0 - KQUAD = 0 -C - IF (IM .LT. 1) THEN -C ... LOCATED OUTSIDE OF FLDA, OFF LEFT SIDE ... - II = 1 - IOFF = 1 - ELSE IF (IM .EQ. 1) THEN -C ... LOCATED ON BOUNDARY OF FLDA, ON LEFT EDGE ... - KQUAD = 5 - ELSE -C ...( IM .GT. 1) ... LOCATED TO RIGHT OF LEFT-EDGE ... - IF ((IA-IM) .LT. 1) THEN -C ... LOCATED OUTSIDE OF OR EXACTLY ON RIGHT EDGE OF FLDA .. - II = IA - IOFF = 1 - ELSE IF ((IA-IM) .EQ. 1) THEN -C ... LOCATED ON FIRST INTERIOR PT WITHIN RIGHT EDGE OF FLDA - KQUAD = 5 - ELSE -C ... (IA-IM) IS .GT. 1) ...GOOD INTERIOR, AT LEAST 2 INSIDE - ENDIF - ENDIF -C -C . . . . . . . . . . . . . . . -C - IF (JM .LT. 1) THEN -C ... LOCATED OUTSIDE OF FLDA, OFF BOTTOM ... - JJ = 1 - JOFF = 1 - ELSE IF (JM .EQ. 1) THEN -C ... LOCATED ON BOUNDARY OF FLDA, ON BOTTOM EDGE ... - KQUAD = 5 - ELSE -C ...( JM .GT. 1) ... LOCATED ABOVE BOTTOM EDGE ... - IF ((JA-JM) .LT. 1) THEN -C ... LOCATED OUTSIDE OF OR EXACTLY ON TOP EDGE OF FLDA .. - JJ = JA - JOFF = 1 - ELSE IF ((JA-JM) .EQ. 1) THEN -C ... LOCATED ON FIRST INTERIOR PT WITHIN TOP EDGE OF FLDA - KQUAD = 5 - ELSE -C ... ((JA-JM) .GT. 1) ...GOOD INTERIOR, AT LEAST 2 INSIDE - ENDIF - ENDIF -C - IF ((IOFF + JOFF) .EQ. 0) THEN - GO TO 244 - ELSE IF ((IOFF + JOFF) .EQ. 2) THEN - GO TO 233 - ENDIF -C - IF (IOFF .EQ. 1) THEN - JJ = STJ - ENDIF - IF (JOFF .EQ. 1) THEN - II = STI - ENDIF - 233 CONTINUE - IF (LDEFQQ) THEN - FLDB(IN,JN) = DEFALT - ELSE - FLDB(IN,JN) = FLDA(II,JJ) - ENDIF - GO TO 277 -C -C . . . . . . . . . . . . . -C - 244 CONTINUE - I = STI - J = STJ - XDELI = STI - FLOAT(I) - XDELJ = STJ - FLOAT(J) -C - IF ((ABS(XDELI) .LT. TINY) .AND. (ABS(XDELJ) .LT. TINY)) THEN -C ... THIS POINT IS RIGHT AT A GRIDPOINT. NO INTERP NECESSARY - FLDB(IN,JN) = FLDA(I,J) - GO TO 277 - ENDIF -C - IF ((KQUAD .EQ. 5) .OR. (LINEAR)) THEN -C ... PERFORM BI-LINEAR INTERP ... - ERAS(1) = FLDA(I,J) - ERAS(4) = FLDA(I,J+1) - ERAS(2) = ERAS(1) + XDELI*(FLDA(I+1,J) - ERAS(1)) - ERAS(3) = ERAS(4) + XDELI*(FLDA(I+1,J+1) - ERAS(4)) - DI = ERAS(2) + XDELJ*(ERAS(3) - ERAS(2)) - GO TO 266 -C - ELSE -C ... PERFORM BI-QUADRATIC INTERP ... - XI2TM = XDELI * (XDELI-1.) * 0.25 - XJ2TM = XDELJ * (XDELJ-1.) * 0.25 - J1 = J - 1 - DO 255 K=1,4 - ERAS(K)=(FLDA(I+1,J1)-FLDA(I,J1))*XDELI+FLDA(I,J1)+ - A (FLDA(I-1,J1)-FLDA(I,J1)-FLDA(I+1,J1)+FLDA(I+2,J1))*XI2TM - J1 = J1 + 1 - 255 CONTINUE -C - DI = ERAS(2) + XDELJ*(ERAS(3)-ERAS(2)) + - A XJ2TM*(ERAS(4)-ERAS(3)-ERAS(2)+ERAS(1)) - GO TO 266 - ENDIF -C - 266 CONTINUE - FLDB(IN,JN) = DI - 277 CONTINUE - 288 CONTINUE -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft08.f b/src/fim/FIMsrc/w3/w3ft08.f deleted file mode 100644 index eccd3c9..0000000 --- a/src/fim/FIMsrc/w3/w3ft08.f +++ /dev/null @@ -1,99 +0,0 @@ - SUBROUTINE W3FT08(FLN,GN,PLN,EPS,FL,WORK,TRIGS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FT08 COMPUTES 2.5 X 2.5 N. HEMI. GRID-SCALER -C AUTHOR: SELA,JOE ORG: W323 DATE: 80-11-21 -C -C ABSTRACT: COMPUTES 2.5 X 2.5 N. HEMI. GRID OF 145 X 37 POINTS -C FROM SPECTRAL COEFFICIENTS IN A RHOMBOIDAL 30 RESOLUTION -C REPRESENTING A SCALER FIELD. -C -C PROGRAM HISTORY LOG: -C -C 88-06-20 JOE SELA -C 88-06-20 R.E.JONES CHANGE TO MICROSOFT FORTRAN 4.10 -C 90-06-12 R.E.JONES CHANGE TO SUN FORTRAN 1.3 -C 91-03-30 R.E.JONES CONVERT TO SiliconGraphics FORTRAN -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C 93-07-22 R.E.JONES CHANGE DOUBLE PRECISION TO REAL FOR CRAY -C -C USAGE: CALL W3FT08(FLN,GN,PLN,EPS,FL,WORK,TRIGS) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C FLN ARG LIST 961 COMPLEX COEFF. -C PLN ARG LIST 992 REAL SPACE FOR LEGENDRE POLYNOMIALS. -C EPS ARG LIST 992 REAL SPACE FOR -C COEFFS. USED IN COMPUTING PLN. -C FL ARG LIST 31 COMPLEX SPACE FOR FOURIER COEFF. -C WORK ARG LIST 144 REAL WORK SPACE FOR SUBR. W3FT12 -C TRIGS ARG LIST 216 PRECOMPUTED TRIG FUNCS. USED -C IN W3FT12, COMPUTED BY W3FA13 -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C GN ARG LIST (145,37) GRID VALUES. -C 5365 POINT GRID IS TYPE 29 OR 1D HEX O.N. 84 -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C AIMAG CMPLX REAL SYSTEM -C W3FA12 W3FT12 W3LIB -C -C WARNING: THIS SUBROUTINE WAS OPTIMIZED TO RUN IN A SMALL AMOUNT OF -C MEMORY, IT IS NOT OPTIMIZED FOR SPEED, 70 PERCENT OF THE TIME IS -C USED BY SUBROUTINE W3FA12 COMPUTING THE LEGENDRE POLYNOMIALS. SINCE -C THE LEGENDRE POLYNOMIALS ARE CONSTANT THEY NEED TO BE COMPUTED -C ONLY ONCE IN A PROGRAM. BY MOVING W3FA12 TO THE MAIN PROGRAM AND -C COMPUTING PLN AS A (32,31,37) ARRAY AND CHANGING THIS SUBROUTINE -C TO USE PLN AS A THREE DIMENSION ARRAY YOU CAN CUT THE RUNNING TIME -C 70 PERCENT. W3FT38 HAS THESE IMPROVEMENTS. -C -C ATTRIBUTES: -C LANGUAGE: CFT77 FORTRAN 77 -C MACHINE: CRAY Y-MP8/864, CRAY Y-MP EL2/128 -C -C$$$ -C - COMPLEX FL( 31 ) - COMPLEX FLN( 31 , 31 ) -C - REAL COLRA - REAL EPS(992) - REAL GN(145,37) - REAL PLN( 32 , 31 ) - REAL TRIGS(216) - REAL WORK(144) -C - SAVE -C - DATA PI /3.14159265/ -C - DRAD = 2.5 * PI / 180.0 -C - DO 400 LAT = 1,37 - LATN = 38 - LAT - COLRA = (LAT - 1) * DRAD - CALL W3FA12(PLN,COLRA, 30 ,EPS) -C - DO 100 L = 1, 31 - FL(L) = (0.,0.) - 100 CONTINUE -C - DO 300 L = 1, 31 - DO 200 I = 1, 31 - FL(L) = FL(L) + CMPLX(PLN(I,L) * REAL(FLN(I,L)) , - & PLN(I,L) * AIMAG(FLN(I,L)) ) - 200 CONTINUE -C - 300 CONTINUE -C - CALL W3FT12(FL,WORK,GN(1,LATN),TRIGS) -C - 400 CONTINUE -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft09.f b/src/fim/FIMsrc/w3/w3ft09.f deleted file mode 100644 index adcd28b..0000000 --- a/src/fim/FIMsrc/w3/w3ft09.f +++ /dev/null @@ -1,111 +0,0 @@ - SUBROUTINE W3FT09(VLN,GN,PLN,EPS,FL,WORK,TRIGS,RCOS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FT09 COMPUTES 2.5X2.5 N. HEMI. GRID-VECTOR -C AUTHOR: SELA,JOE ORG: W323 DATE: 84-06-27 -C -C ABSTRACT: COMPUTES 2.5 X 2.5 N. HEMI. GRID OF 145 X 37 POINTS -C FROM SPECTRAL COEFFICIENTS IN A RHOMBOIDAL 30 RESOLUTION -C REPRESENTING A VECTOR FIELD. -C -C PROGRAM HISTORY LOG: -C 80-10-21 JOE SELA -C 81-06-15 R.E.JONES ADD DOC BLOCK, CLEAN UP SOURCE -C 89-01-25 R.E.JONES CHANGE TO MICROSOFT FORTRAN 4.10 -C 90-06-12 R.E.JONES CHANGE TO SUN FORTRAN 1.3 -C 91-03-30 R.E.JONES CONVERT TO SiliconGraphics FORTRAN -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C 93-07-22 R.E.JONES CHANGE DOUBLE PRECISION TO REAL FOR CRAY -C -C USAGE: CALL W3FT09(VLN,GN,PLN,EPS,FL,WORK,TRIGS,RCOS) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C VLN ARG LIST 992 COMPLEX COEFF. -C PLN ARG LIST 992 SPACE FOR LEGENDRE POLYNOMIALS. -C EPS ARG LIST 992 REAL SPACE FOR -C COEFFS. USED IN COMPUTING PLN. -C FL ARG LIST 31 COMPLEX SPACE FOR FOURIER COEFF. -C WORK ARG LIST 144 WORK SPACE FOR SUBR. W3FT12 -C TRIGS ARG LIST 216 PRECOMPUTED TRIG FUNCS. USED -C IN W3FT12, COMPUTED BY W3FA13 -C RCOS ARG LIST 37 RECIPROCAL COSINE LATITUDES OF -C 2.5 X 2.5 GRID MUST BE COMPUTED BEFORE -C FIRST CALL TO W3FT11 USING SR W3FA13. -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C GN ARG LIST (145,37) GRID VALUES. -C 5365 POINT GRID IS TYPE 29 OR 1D O.N. 84 -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C AIMAG CMPLX REAL SYSTEM -C W3FA12 W3FT12 W3LIB -C -C WARNING: THIS SUBROUTINE WAS OPTIMIZED TO RUN IN A SMALL AMOUNT OF -C MEMORY, IT IS NOT OPTIMIZED FOR SPEED, 70 PERCENT OF THE TIME IS -C USED BY SUBROUTINE W3FA12 COMPUTING THE LEGENDRE POLYNOMIALS. SINCE -C THE LEGENDRE POLYNOMIALS ARE CONSTANT THEY NEED TO BE COMPUTED -C ONLY ONCE IN A PROGRAM. BY MOVING W3FA12 TO THE MAIN PROGRAM AND -C COMPUTING PLN AS A (32,31,37) ARRAY AND CHANGING THIS SUBROUTINE -C TO USE PLN AS A THREE DIMENSION ARRAY YOU CAN CUT THE RUNNING TIME -C 70 PERCENT. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/864, CRAY Y-MP EL2/128 -C -C$$$ -C - COMPLEX FL( 31 ) - COMPLEX VLN( 32 , 31 ) -C - REAL COLRA - REAL EPS(992) - REAL GN(145,37) - REAL PLN( 32 , 31 ) - REAL RCOS(37) - REAL TRIGS(216) - REAL WORK(144) -C - SAVE -C - DATA PI /3.14159265/ -C - DRAD = 2.5 * PI / 180.0 -C - DO 400 LAT = 2,37 - LATN = 38 - LAT - COLRA = (LAT - 1) * DRAD - CALL W3FA12(PLN,COLRA, 30 ,EPS) -C - DO 100 L = 1, 31 - FL(L) = (0.,0.) - 100 CONTINUE -C - DO 300 L = 1, 31 -C - DO 200 I = 1, 32 - FL(L) = FL(L) + CMPLX(PLN(I,L) * REAL(VLN(I,L)), - & PLN(I,L) * AIMAG(VLN(I,L)) ) - 200 CONTINUE -C - FL(L)=CMPLX(REAL(FL(L))*RCOS(LAT),AIMAG(FL(L))*RCOS(LAT)) - 300 CONTINUE -C - CALL W3FT12(FL,WORK,GN(1,LATN),TRIGS) -C - 400 CONTINUE -C -C*** POLE ROW=CLOSEST LATITUDE ROW -C - DO 500 I = 1,145 - GN(I,37) = GN(I,36) - 500 CONTINUE -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft10.f b/src/fim/FIMsrc/w3/w3ft10.f deleted file mode 100644 index fb8ee53..0000000 --- a/src/fim/FIMsrc/w3/w3ft10.f +++ /dev/null @@ -1,103 +0,0 @@ - SUBROUTINE W3FT10(FLN,GN,PLN,EPS,FL,WORK,TRIGS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FT10 COMPUTES 2.5 X 2.5 S. HEMI. GRID-SCALER -C AUTHOR: JONES,R.E. ORG: W323 DATE: 84-06-28 -C -C ABSTRACT: COMPUTES 2.5 X 2.5 S. HEMI. GRID OF 145 X 37 POINTS -C FROM SPECTRAL COEFFICIENTS IN A RHOMBOIDAL 30 RESOLUTION -C REPRESENTING A SCALER FIELD. -C -C PROGRAM HISTORY LOG: -C 80-10-21 JOE SELA -C 84-06-28 R.E.JONES CHANGE TO IBM VS FORTRAN -C 89-01-25 R.E.JONES CHANGE TO MICROSOFT FORTRAN 4.10 -C 90-06-12 R.E.JONES CHANGE TO SUN FORTRAN 1.3 -C 91-03-30 R.E.JONES CONVERT TO SiliconGraphics FORTRAN -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C 93-07-22 R.E.JONES CHANGE DOUBLE PRECISION TO REAL FOR CRAY -C -C USAGE: CALL W3FT10(FLN,GN,PLN,EPS,FL,WORK,TRIGS) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C FLN ARG LIST 961 COMPLEX COEFF. -C PLN ARG LIST 992 REAL SPACE FOR LEGENDRE POLYNOMIALS. -C EPS ARG LIST 992 REAL SPACE FOR -C COEFFS. USED IN COMPUTING PLN. -C FL ARG LIST 31 COMPLEX SPACE FOR FOURIER COEFF. -C WORK ARG LIST 144 REAL WORK SPACE FOR SUBR. W3FT12 -C TRIGS ARG LIST 216 PRECOMPUTED TRIG FUNCS. USED -C IN W3FT12, COMPUTED BY W3FA13 -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C GN ARG LIST (145,37) GRID VALUES. -C 5365 POINT GRID IS TYPE 30 OR 1E O.N. 84 -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C AIMAG CMPLX REAL SYSTEM -C W3FA12 W3FT12 W3LIB -C -C WARNING: THIS SUBROUTINE WAS OPTIMIZED TO RUN IN A SMALL AMOUNT OF -C MEMORY, IT IS NOT OPTIMIZED FOR SPEED, 70 PERCENT OF THE TIME IS -C USED BY SUBROUTINE W3FA12 COMPUTING THE LEGENDRE POLYNOMIALS. SINCE -C THE LEGENDRE POLYNOMIALS ARE CONSTANT THEY NEED TO BE COMPUTED -C ONLY ONCE IN A PROGRAM. BY MOVING W3FA12 TO THE MAIN PROGRAM AND -C COMPUTING PLN AS A (32,31,37) ARRAY AND CHANGING THIS SUBROUTINE -C TO USE PLN AS A THREE DIMENSION ARRAY YOU CAN CUT THE RUNNING TIME -C 70 PERCENT. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/864, CRAY Y-MP EL2/128 -C -C$$$ -C - COMPLEX FL( 31 ) - COMPLEX FLN( 31 , 31 ) -C - REAL COLRA - REAL EPS( 992) - REAL GN(145,37) - REAL PLN( 32 , 31 ) - REAL TRIGS(216) - REAL WORK(144) -C - SAVE -C - DATA PI /3.14159265/ -C - DRAD = 2.5 * PI / 180.0 -C - DO 400 LAT = 1,37 - COLRA = (LAT-1) * DRAD - CALL W3FA12(PLN,COLRA, 30 ,EPS) -C - DO 100 L = 1, 31 - FL(L) = (0.,0.) - 100 CONTINUE -C - DO 300 L = 1, 31 - I = 1 - FL(L) = FL(L)+CMPLX(PLN(I,L) * REAL(FLN(I,L)) , - & PLN(I,L) * AIMAG(FLN(I,L)) ) -C - DO 200 I = 2, 30 ,2 - FL(L) = FL(L)-CMPLX(PLN(I,L) * REAL(FLN(I,L)) , - & PLN(I,L) * AIMAG(FLN(I,L)) ) - FL(L) = FL(L)+CMPLX(PLN(I+1,L) * REAL(FLN(I+1,L)), - & PLN(I+1,L) * AIMAG(FLN(I+1,L))) - 200 CONTINUE -C - 300 CONTINUE -C - CALL W3FT12(FL,WORK,GN(1,LAT ),TRIGS) - 400 CONTINUE -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft11.f b/src/fim/FIMsrc/w3/w3ft11.f deleted file mode 100644 index 7f99bed..0000000 --- a/src/fim/FIMsrc/w3/w3ft11.f +++ /dev/null @@ -1,112 +0,0 @@ - SUBROUTINE W3FT11(VLN,GN,PLN,EPS,FL,WORK,TRIGS,RCOS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FT11 COMPUTES 2.5X2.5 S. HEMI. GRID VECTOR -C AUTHOR: SELA,JOE ORG: W323 DATE: 80-11-20 -C -C ABSTRACT: COMPUTES 2.5 X 2.5 S. HEMI. GRID OF 145 X 37 POINTS -C FROM SPECTRAL COEFFICIENTS IN A RHOMBOIDAL 30 RESOLUTION -C REPRESENTING A VECTOR FIELD. -C -C PROGRAM HISTORY LOG: -C 80-11-20 JOE SELA -C 84-06-15 R.E.JONES CHANGE TO IBM VS FORTRAN -C 89-01-25 R.E.JONES CHANGE TO MICROSOFT FORTRAN 4.10 -C 90-06-12 R.E.JONES CHANGE TO SUN FORTRAN 1.3 -C 91-03-30 R.E.JONES CONVERT TO SiliconGraphics FORTRAN -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C 93-07-22 R.E.JONES CHANGE DOUBLE PRECISION TO REAL FOR CRAY -C -C USAGE: CALL W3FT11(VLN,GN,PLN,EPS,FL,WORK,TRIGS,RCOS) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C VLN ARG LIST 992 COMPLEX COEFF. -C PLN ARG LIST 992 REAL SPACE FOR LEGENDRE POLYNOMIALS. -C EPS ARG LIST 992 REAL SPACE FOR -C COEFFS. USED IN COMPUTING PLN. -C FL ARG LIST 31 COMPLEX SPACE FOR FOURIER COEFF. -C WORK ARG LIST 144 REAL WORK SPACE FOR SUBR. W3FT12 -C TRIGS ARG LIST 216 PRECOMPUTED TRIG FUNCS. USED -C IN W3FT12, COMPUTED BY W3FA13 -C RCOS ARG LIST 37 RECIPROCAL COSINE LATITUDES OF -C 2.5 X 2.5 GRID MUST BE COMPUTED BEFORE -C FIRST CALL TO W3FT11 USING SUBR. W3FA13. -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C GN ARG LIST (145,37) GRID VALUES. -C 5365 POINT GRID IS TYPE 30 OR 1E HEX O.N. 84 -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C AIMAG CMPLX REAL SYSTEM -C W3FA12 W3FT12 W3LIB -C -C WARNING: THIS SUBROUTINE WAS OPTIMIZED TO RUN IN A SMALL AMOUNT OF -C MEMORY, IT IS NOT OPTIMIZED FOR SPEED, 70 PERCENT OF THE TIME IS -C USED BY SUBROUTINE W3FA12 COMPUTING THE LEGENDRE POLYNOMIALS. SINCE -C THE LEGENDRE POLYNOMIALS ARE CONSTANT THEY NEED TO BE COMPUTED -C ONLY ONCE IN A PROGRAM. BY MOVING W3FA12 TO THE MAIN PROGRAM AND -C COMPUTING PLN AS A (32,31,37) ARRAY AND CHANGING THIS SUBROUTINE -C TO USE PLN AS A THREE DIMENSION ARRAY YOU CAN CUT THE RUNNING TIME -C 70 PERCENT. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/864, CRAY Y-MP EL2/128 -C -C$$$ -C - COMPLEX FL( 31 ) - COMPLEX VLN( 32 , 31 ) -C - REAL COLRA - REAL EPS( 992 ) - REAL GN(145,37) - REAL PLN( 32 , 31 ) - REAL RCOS(37) - REAL TRIGS(216) - REAL WORK(144) -C - SAVE -C - DATA PI /3.14159265/ -C - DRAD = 2.5 * PI / 180.0 -C - DO 400 LAT = 2,37 - COLRA = (LAT-1) * DRAD - CALL W3FA12(PLN,COLRA, 30 ,EPS) -C - DO 100 L = 1, 31 - FL(L) = (0.,0.) - 100 CONTINUE -C - DO 300 L = 1, 31 -C - DO 200 I = 1, 31 ,2 - FL(L) = FL(L)+CMPLX(PLN(I,L) * REAL(VLN(I,L)) , - & PLN(I,L) * AIMAG(VLN(I,L)) ) - FL(L) = FL(L)-CMPLX(PLN(I+1,L) * REAL(VLN(I+1,L)), - & PLN(I+1,L) * AIMAG(VLN(I+1,L))) - 200 CONTINUE -C - FL(L) = CMPLX(REAL(FL(L))*RCOS(LAT),AIMAG(FL(L))*RCOS(LAT)) -C - 300 CONTINUE -C - CALL W3FT12(FL,WORK,GN(1,LAT ),TRIGS) -C - 400 CONTINUE -C -C*** POLE ROW = CLOSEST LATITUDE ROW -C - DO 500 I = 1,145 - GN(I,1) = GN(I,2) - 500 CONTINUE - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft12.f b/src/fim/FIMsrc/w3/w3ft12.f deleted file mode 100644 index 43eba24..0000000 --- a/src/fim/FIMsrc/w3/w3ft12.f +++ /dev/null @@ -1,238 +0,0 @@ - SUBROUTINE W3FT12(COEF,WORK,GRID,TRIGS) 00010000 -C$$$ SUBPROGRAM DOCUMENTATION BLOCK 00020000 -C 00030000 -C SUBPROGRAM: W3FT12 FAST FOURIER FOR 2.5 DEGREE GRID 00040000 -C AUTHOR: SELA,JOE ORG: W323 DATE: 80-11-21 00050000 -C 00060000 -C ABSTRACT: FAST FOURIER TO COMPUTE 145 GRID VALUES AT DESIRED 00070000 -C LATITUDE FROM 31 COMPLEX FOURIER COEFFICIENTS. THIS SUBROUTINE 00080000 -C IS SPECIAL PURPOSE FOR CONVERTING COEFFICIENTS TO A 2.5 DEGREE 00090000 -C LAT,LON GRID. 00100000 -C 00110000 -C PROGRAM HISTORY LOG: 00120000 -C 80-11-21 JOE SELA 00130000 -C 84-06-21 R.E.JONES CHANGE TO IBM VS FORTRAN 00140000 -C 93-04-12 R.E.JONES CHANGE TO CRAY CFT77 FORTRAN 00150000 -C 00160000 -C USAGE: CALL W3FT12(COEF,WORK,GRID,TRIGS) 00170000 -C 00180000 -C INPUT VARIABLES: 00190000 -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES 00200000 -C ------ --------- ----------------------------------------------- 00210000 -C COEF ARG LIST 31 COMPLEX FOURIER COEFFICIENTS. 00220000 -C TRIGS ARG LIST 216 TRIG FUNCTIONS ASSUMED PRECOMPUTED 00230000 -C BY W3FA13 BEFORE FIRST CALL TO W3FT12. 00240000 -C WORK ARG LIST 144 REAL WORK SPACE 00250000 -C 00260000 -C OUTPUT VARIABLES: 00270000 -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES 00280000 -C ------ --------- ----------------------------------------------- 00290000 -C GRID ARG LIST 145 GRID VALUES, GRID(1)=GRID(145) 00300000 -C 00310000 -C ATTRIBUTES: 00320000 -C LANGUAGE: CRAY CFT77 FORTRAN 77 00330000 -C MACHINE: CRAY C916-128, Y-MP8/864, Y-MP EL92/256 00340002 -C 00350000 -C$$$ 00360000 -C 00370000 - REAL COEF( 62 ) 00380000 - REAL GRID(145) 00390000 - REAL TRIGS(216) 00400000 - REAL WORK(144) 00410000 -C 00411003 - SAVE 00412003 -C 00420000 - DATA SIN60/0.866025403784437/ 00430000 -C 00440000 - GRID(1) = COEF(1) 00450000 - GRID(2) = COEF(1) 00460000 - K = 147 00470000 - J = 143 00480000 - DO 100 I=3, 61 ,2 00490000 - TEMP = COEF(I)*TRIGS(K+1) - COEF(I+1)*TRIGS(K) 00500000 - GRID(I) = COEF(I) - TEMP 00510000 - GRID(J) = COEF(I) + TEMP 00520000 - TEMP = COEF(I)*TRIGS(K) + COEF(I+1)*TRIGS(K+1) 00530000 - GRID(I+1) = TEMP - COEF(I+1) 00540000 - GRID(J+1) = TEMP + COEF(I+1) 00550000 - K = K + 2 00560000 - J = J - 2 00570000 -100 CONTINUE 00580000 - DO 110 I= 63 , 84 00590000 - GRID(I) = 0.0 00600000 -110 CONTINUE 00610000 -C 00620000 - A0 = GRID(1) + GRID(73) 00630000 - A2 = GRID(1) - GRID(73) 00640000 - B0 = GRID(2) + GRID(74) 00650000 - B2 = GRID(2) - GRID(74) 00660000 - A1 = GRID(37) + GRID(109) 00670000 - A3 = GRID(37) - GRID(109) 00680000 - B1 = GRID(38) + GRID(110) 00690000 - B3 = GRID(38) - GRID(110) 00700000 - WORK(1) = A0 + A1 00710000 - WORK(5) = A0 - A1 00720000 - WORK(2) = B0 + B1 00730000 - WORK(6) = B0 - B1 00740000 - WORK(3) = A2 - B3 00750000 - WORK(7) = A2 + B3 00760000 - WORK(4) = B2 + A3 00770000 - WORK(8) = B2 - A3 00780000 - KB = 3 00790000 - KC = 5 00800000 - KD = 7 00810000 - J = 75 00820000 - K = 39 00830000 - L = 111 00840000 - M = 9 00850000 - DO 300 I=3,35,2 00860000 - A0 = GRID(I) + GRID(J) 00870000 - A2 = GRID(I) - GRID(J) 00880000 - B0 = GRID(I+1) + GRID(J+1) 00890000 - B2 = GRID(I+1) - GRID(J+1) 00900000 - A1 = GRID(K) + GRID(L) 00910000 - A3 = GRID(K) - GRID(L) 00920000 - B1 = GRID(K+1) + GRID(L+1) 00930000 - B3 = GRID(K+1) - GRID(L+1) 00940000 - WORK(M ) = A0 + A1 00950000 - WORK(M+4) = A0 - A1 00960000 - WORK(M+1) = B0 + B1 00970000 - WORK(M+5) = B0 - B1 00980000 - WORK(M+2) = A2 - B3 00990000 - WORK(M+6) = A2 + B3 01000000 - WORK(M+3) = B2 + A3 01010000 - WORK(M+7) = B2 - A3 01020000 - TEMP = WORK(M+2)*TRIGS(KB) - WORK(M+3)*TRIGS(KB+1) 01030000 - WORK(M+3) = WORK(M+2)*TRIGS(KB+1) + WORK(M+3)*TRIGS(KB) 01040000 - WORK(M+2) = TEMP 01050000 - TEMP = WORK(M+4)*TRIGS(KC) - WORK(M+5)*TRIGS(KC+1) 01060000 - WORK(M+5) = WORK(M+4)*TRIGS(KC+1) + WORK(M+5)*TRIGS(KC) 01070000 - WORK(M+4) = TEMP 01080000 - TEMP = WORK(M+6)*TRIGS(KD) - WORK(M+7)*TRIGS(KD+1) 01090000 - WORK(M+7) = WORK(M+6)*TRIGS(KD+1) + WORK(M+7)*TRIGS(KD) 01100000 - WORK(M+6) = TEMP 01110000 - J = J + 2 01120000 - K = K + 2 01130000 - L = L + 2 01140000 - KB = KB + 2 01150000 - KC = KC + 4 01160000 - KD = KD + 6 01170000 - M = M + 8 01180000 -300 CONTINUE 01190000 -C 01200000 - I = 1 01210000 - J = 1 01220000 - K = 73 01230000 - DO 440 L=1,4 01240000 - GRID(I) = WORK(J) + WORK(K) 01250000 - GRID(I+8) = WORK(J) - WORK(K) 01260000 - GRID(I+1) = WORK(J+1) + WORK(K+1) 01270000 - GRID(I+9) = WORK(J+1) - WORK(K+1) 01280000 - I = I + 2 01290000 - J = J + 2 01300000 - K = K + 2 01310000 -440 CONTINUE 01320000 - DO 500 KB=9,65,8 01330000 - I = I + 8 01340000 - DO 460 L=1,4 01350000 - GRID(I) = WORK(J) + WORK(K) 01360000 - GRID(I+8) = WORK(J) - WORK(K) 01370000 - GRID(I+1) = WORK(J+1) + WORK(K+1) 01380000 - GRID(I+9) = WORK(J+1) - WORK(K+1) 01390000 - TEMP = GRID(I+8)*TRIGS(KB) - GRID(I+9)*TRIGS(KB+1) 01400000 - GRID(I+9) = GRID(I+8)*TRIGS(KB+1) + GRID(I+9)*TRIGS(KB) 01410000 - GRID(I+8) = TEMP 01420000 - I = I + 2 01430000 - J = J + 2 01440000 - K = K + 2 01450000 -460 CONTINUE 01460000 -500 CONTINUE 01470000 -C 01480000 - I = 1 01490000 - L = 1 01500000 - KC = 1 01510000 - J = 49 01520000 - K = 97 01530000 - M = 17 01540000 - N = 33 01550000 - DO 660 LL=1,8 01560000 - A1 = GRID(J) + GRID(K) 01570000 - A3 = SIN60*(GRID(J)-GRID(K)) 01580000 - B1 = GRID(J+1) + GRID(K+1) 01590000 - B3 = SIN60*(GRID(J+1)-GRID(K+1)) 01600000 - WORK(L) = GRID(I) + A1 01610000 - A2 = GRID(I) - 0.5*A1 01620000 - WORK(L+1) = GRID(I+1) + B1 01630000 - B2 = GRID(I+1) - 0.5*B1 01640000 - WORK(N) = A2 + B3 01650000 - WORK(M) = A2 - B3 01660000 - WORK(M+1) = B2 + A3 01670000 - WORK(N+1) = B2 - A3 01680000 - I = I + 2 01690000 - J = J + 2 01700000 - K = K + 2 01710000 - L = L + 2 01720000 - M = M + 2 01730000 - N = N + 2 01740000 -660 CONTINUE 01750000 - DO 700 KB=17,33,16 01760000 - L = L + 32 01770000 - M = M + 32 01780000 - N = N + 32 01790000 - KC = KC + 32 01800000 - DO 680 LL=1,8 01810000 - A1 = GRID(J) + GRID(K) 01820000 - A3 = SIN60*(GRID(J)-GRID(K)) 01830000 - B1 = GRID(J+1) + GRID(K+1) 01840000 - B3 = SIN60*(GRID(J+1)-GRID(K+1)) 01850000 - WORK(L) = GRID(I) + A1 01860000 - A2 = GRID(I) - 0.5*A1 01870000 - WORK(L+1) = GRID(I+1) + B1 01880000 - B2 = GRID(I+1) - 0.5*B1 01890000 - WORK(N) = A2 + B3 01900000 - WORK(M) = A2 - B3 01910000 - WORK(M+1) = B2 + A3 01920000 - WORK(N+1) = B2 - A3 01930000 - TEMP = WORK(M)*TRIGS(KB) - WORK(M+1)*TRIGS(KB+1) 01940000 - WORK(M+1) = WORK(M)*TRIGS(KB+1) + WORK(M+1)*TRIGS(KB) 01950000 - WORK(M) = TEMP 01960000 - TEMP = WORK(N)*TRIGS(KC) - WORK(N+1)*TRIGS(KC+1) 01970000 - WORK(N+1) = WORK(N)*TRIGS(KC+1) + WORK(N+1)*TRIGS(KC) 01980000 - WORK(N) = TEMP 01990000 - I = I + 2 02000000 - J = J + 2 02010000 - K = K + 2 02020000 - L = L + 2 02030000 - M = M + 2 02040000 - N = N + 2 02050000 -680 CONTINUE 02060000 -700 CONTINUE 02070000 -C 02080000 - J = 49 02090000 - K = 97 02100000 - L = 144 02110000 - M = 96 02120000 - N = 48 02130000 - DO 900 I=1,47,2 02140000 - A1 = WORK(J) + WORK(K) 02150000 - A3 = SIN60 * (WORK(J)-WORK(K)) 02160000 - B3 = SIN60 * (WORK(J+1)-WORK(K+1)) 02170000 - B1 = WORK(J+1) + WORK(K+1) 02180000 - GRID(L+1) = WORK(I) + A1 02190000 - A2 = WORK(I) - 0.5*A1 02200000 - B2 = WORK(I+1) - 0.5*B1 02210000 - GRID(L) = WORK(I+1) + B1 02220000 - GRID(N+1) = A2 + B3 02230000 - GRID(M+1) = A2 - B3 02240000 - GRID(M) = B2 + A3 02250000 - GRID(N) = B2 - A3 02260000 - J = J + 2 02270000 - K = K + 2 02280000 - L = L - 2 02290000 - M = M - 2 02300000 - N = N - 2 02310000 -900 CONTINUE 02320000 - GRID(1) = GRID(145) 02330000 -C 02340000 - RETURN 02350000 - END 02360000 diff --git a/src/fim/FIMsrc/w3/w3ft16.f b/src/fim/FIMsrc/w3/w3ft16.f deleted file mode 100644 index 5818b22..0000000 --- a/src/fim/FIMsrc/w3/w3ft16.f +++ /dev/null @@ -1,221 +0,0 @@ - SUBROUTINE W3FT16(ALOLA,BTHIN,INTERP) -C$$$ SUBROUTINE DOCUMENTATION BLOCK *** -C -C SUBROUTINE: W3FT16 CONVERT (95,91) GRID TO (3447) GRID -C AUTHOR: JONES,R.E. ORG: W342 DATE: 94-05-03 -C -C ABSTRACT: CONVERT A NORTHERN HEMISPHERE 1.0 DEGREE LAT.,LON. 95 BY -C 91 GRID TO A WAFS 1.25 DEGREE THINNED 3447 POINT GRID. -C -C PROGRAM HISTORY LOG: -C 94-05-03 R.E.JONES -C -C USAGE: CALL W3FT16(ALOLA,BTHIN,INTERP) -C -C INPUT ARGUMENTS: ALOLA - 95 * 91 GRID 1.0 DEG. LAT,LON GRID -C NORTHERN HEMISPHERE 8645 POINT GRID. -C INTERP - 1 LINEAR INTERPOLATION , NE.1 BIQUADRATIC -C -C INPUT FILES: NONE -C -C OUTPUT ARGUMENTS: BTHIN - 3447 POINT THINNED GRID OF N. HEMISPERE -C 3447 GRID IS FOR GRIB GRIDS 37-40. -C -C OUTPUT FILES: ERROR MESSAGE TO FORTRAN OUTPUT FILE -C -C WARNINGS: -C -C 1. W1 AND W2 ARE USED TO STORE SETS OF CONSTANTS WHICH ARE -C REUSABLE FOR REPEATED CALLS TO THE SUBROUTINE. 10 OTHER ARRAYS -C ARE SAVED AND REUSED ON THE NEXT CALL. -C -C RETURN CONDITIONS: NORMAL SUBROUTINE EXIT -C -C SUBPROGRAMS CALLED: -C UNIQUE : NONE -C -C LIBRARY: -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916-128, cRAY Y-MP8/864, CRAY Y-MP EL2/256 -C -C$$$ -C - PARAMETER (NPTS=3447) -C - REAL SEP(73) - REAL ALOLA(95,91), BTHIN(NPTS), ERAS(NPTS,4) - REAL W1(NPTS), W2(NPTS) - REAL XDELI(NPTS), XDELJ(NPTS) - REAL XI2TM(NPTS), XJ2TM(NPTS) -C - INTEGER NPT(73) - INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4) - INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS) -C - LOGICAL LIN -C - SAVE -C - DATA INTRPO/99/ - DATA ISWT /0/ -C -C GRID POINT SEPARATION -C - DATA SEP /1.250, 1.250, 1.250, 1.250, 1.250, 1.250, - & 1.250, 1.250, 1.268, 1.268, 1.268, 1.286, - & 1.286, 1.286, 1.304, 1.304, 1.324, 1.324, - & 1.343, 1.364, 1.364, 1.385, 1.406, 1.406, - & 1.429, 1.452, 1.475, 1.500, 1.525, 1.525, - & 1.552, 1.579, 1.607, 1.636, 1.667, 1.698, - & 1.765, 1.800, 1.837, 1.875, 1.915, 1.957, - & 2.045, 2.093, 2.143, 2.195, 2.308, 2.368, - & 2.432, 2.571, 2.647, 2.813, 2.903, 3.103, - & 3.214, 3.333, 3.600, 3.750, 4.091, 4.286, - & 4.737, 5.000, 5.625, 6.000, 6.923, 8.182, - & 9.000,11.250,12.857,18.000,22.500,45.000, - & 90.000/ -C -C NUMBER OF POINTS ALONG LAT CIRCLE FOR ONE OCTANT -C - DATA NPT / 73, 73, 73, 73, 73, 73, - & 73, 73, 72, 72, 72, 71, - & 71, 71, 70, 70, 69, 69, - & 68, 67, 67, 66, 65, 65, - & 64, 63, 62, 61, 60, 60, - & 59, 58, 57, 56, 55, 54, - & 52, 51, 50, 49, 48, 47, - & 45, 44, 43, 42, 40, 39, - & 38, 36, 35, 33, 32, 30, - & 29, 28, 26, 25, 23, 22, - & 20, 19, 17, 16, 14, 12, - & 11, 9, 8, 6, 5, 3, - & 2/ -C - LIN = .FALSE. - IF (INTERP.EQ.1) LIN = .TRUE. -C - IF (ISWT.EQ.1) GO TO 900 -C - IJOUT = 0 - DO 200 J = 1,73 - XJOU = (J-1) * 1.25 + 1.0 - II = NPT(J) - RDGLAT = SEP(J) - DO 100 I = 1,II - IJOUT = IJOUT + 1 - W1(IJOUT) = (I-1) * RDGLAT + 3.0 - W2(IJOUT) = XJOU - 100 CONTINUE - 200 CONTINUE -C - ISWT = 1 - INTRPO = INTERP - GO TO 1000 -C -C AFTER THE 1ST CALL TO W3FT16 TEST INTERP, IF IT HAS -C CHANGED RECOMPUTE SOME CONSTANTS -C - 900 CONTINUE - IF (INTERP.EQ.INTRPO) GO TO 2100 - INTRPO = INTERP -C - 1000 CONTINUE - DO 1100 K = 1,NPTS - IV(K) = W1(K) - JV(K) = W2(K) - XDELI(K) = W1(K) - IV(K) - XDELJ(K) = W2(K) - JV(K) - IP1(K) = IV(K) + 1 - JY(K,3) = JV(K) + 1 - JY(K,2) = JV(K) - 1100 CONTINUE -C - IF (LIN) GO TO 1400 -C - DO 1200 K = 1,NPTS - IP2(K) = IV(K) + 2 - IM1(K) = IV(K) - 1 - JY(K,1) = JV(K) - 1 - JY(K,4) = JV(K) + 2 - XI2TM(K) = XDELI(K) * (XDELI(K) - 1.0) * .25 - XJ2TM(K) = XDELJ(K) * (XDELJ(K) - 1.0) * .25 - 1200 CONTINUE -C - 1400 CONTINUE -C - IF (LIN) GO TO 1700 -C - DO 1500 KK = 1,NPTS - IF (JV(KK).LT.2.OR.JV(KK).GE.90) XJ2TM(KK) = 0.0 - 1500 CONTINUE -C -C LINEAR INTERPOLATION -C - 1700 CONTINUE - DO 1900 KK = 1,NPTS - IF (JY(KK,3).GT.91) JY(KK,3) = 91 - 1900 CONTINUE -C - IF (.NOT.LIN) THEN - DO 2000 KK = 1,NPTS - IF (JY(KK,1).LT.1) JY(KK,1) = 1 - IF (JY(KK,4).GT.91) JY(KK,4) = 91 - 2000 CONTINUE - ENDIF -C - 2100 CONTINUE - IF (LIN) THEN -C -C LINEAR INTERPOLATION -C - DO 2200 KK = 1,NPTS - ERAS(KK,2) = (ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) - ERAS(KK,3) = (ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) - 2200 CONTINUE -C - DO 2300 KK = 1,NPTS - BTHIN(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) - 2300 CONTINUE -C - ELSE -C -C QUADRATIC INTERPOLATION -C - DO 2400 KK = 1,NPTS - ERAS(KK,1)=(ALOLA(IP1(KK),JY(KK,1))-ALOLA(IV(KK),JY(KK,1))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,1)) + - & ( ALOLA(IM1(KK),JY(KK,1)) - ALOLA(IV(KK),JY(KK,1)) - & - ALOLA(IP1(KK),JY(KK,1))+ALOLA(IP2(KK),JY(KK,1))) - & * XI2TM(KK) - ERAS(KK,2)=(ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) + - & ( ALOLA(IM1(KK),JY(KK,2)) - ALOLA(IV(KK),JY(KK,2)) - & - ALOLA(IP1(KK),JY(KK,2))+ALOLA(IP2(KK),JY(KK,2))) - & * XI2TM(KK) - ERAS(KK,3)=(ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) + - & ( ALOLA(IM1(KK),JY(KK,3)) - ALOLA(IV(KK),JY(KK,3)) - & - ALOLA(IP1(KK),JY(KK,3))+ALOLA(IP2(KK),JY(KK,3))) - & * XI2TM(KK) - ERAS(KK,4)=(ALOLA(IP1(KK),JY(KK,4))-ALOLA(IV(KK),JY(KK,4))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,4)) + - & ( ALOLA(IM1(KK),JY(KK,4)) - ALOLA(IV(KK),JY(KK,4)) - & - ALOLA(IP1(KK),JY(KK,4))+ALOLA(IP2(KK),JY(KK,4))) - & * XI2TM(KK) - 2400 CONTINUE -C - DO 2500 KK = 1,NPTS - BTHIN(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) + (ERAS(KK,1) - ERAS(KK,2) - & - ERAS(KK,3) + ERAS(KK,4)) * XJ2TM(KK) - 2500 CONTINUE -C - ENDIF -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft17.f b/src/fim/FIMsrc/w3/w3ft17.f deleted file mode 100644 index 2522c95..0000000 --- a/src/fim/FIMsrc/w3/w3ft17.f +++ /dev/null @@ -1,222 +0,0 @@ - SUBROUTINE W3FT17(ALOLA,BTHIN,INTERP) -C$$$ SUBROUTINE DOCUMENTATION BLOCK *** -C -C SUBROUTINE: W3FT17 CONVERT (95,91) GRID TO (3447) GRID -C AUTHOR: JONES,R.E. ORG: W342 DATE: 94-05-03 -C -C ABSTRACT: CONVERT A SOUTHERN HEMISPHERE 1.0 DEGREE LAT.,LON. 95 BY -C 91 GRID TO A WAFS 1.25 DEGREE THINNED 3447 POINT GRID. -C -C PROGRAM HISTORY LOG: -C 94-05-03 R.E.JONES -C -C USAGE: CALL W3FT17(ALOLA,BTHIN,INTERP) -C -C INPUT ARGUMENTS: ALOLA - 95 * 91 GRID 1.0 DEG. LAT,LON GRID -C SOUTHERN HEMISPHERE 8645 POINT GRID. -C INTERP - 1 LINEAR INTERPOLATION , NE.1 BIQUADRATIC -C -C INPUT FILES: NONE -C -C OUTPUT ARGUMENTS: BTHIN - 3447 POINT THINNED GRID OF S. HEMISPERE -C 3447 GRID IS FOR GRIB GRIDS 41-44. -C -C OUTPUT FILES: ERROR MESSAGE TO FORTRAN OUTPUT FILE -C -C WARNINGS: -C -C 1. W1 AND W2 ARE USED TO STORE SETS OF CONSTANTS WHICH ARE -C REUSABLE FOR REPEATED CALLS TO THE SUBROUTINE. 10 OTHER ARRAYS -C ARE SAVED AND REUSED ON THE NEXT CALL. -C -C RETURN CONDITIONS: NORMAL SUBROUTINE EXIT -C -C SUBPROGRAMS CALLED: -C UNIQUE : NONE -C -C LIBRARY: -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916-128, cRAY Y-MP8/864, CRAY Y-MP EL2/256 -C -C$$$ -C - PARAMETER (NPTS=3447) -C - REAL SEP(73) - REAL ALOLA(95,91), BTHIN(NPTS), ERAS(NPTS,4) - REAL W1(NPTS), W2(NPTS) - REAL XDELI(NPTS), XDELJ(NPTS) - REAL XI2TM(NPTS), XJ2TM(NPTS) -C - INTEGER NPT(73) - INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4) - INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS) -C - LOGICAL LIN -C - SAVE -C - DATA INTRPO/99/ - DATA ISWT /0/ -C -C GRID POINT SEPARATION -C - DATA SEP /1.250, 1.250, 1.250, 1.250, 1.250, 1.250, - & 1.250, 1.250, 1.268, 1.268, 1.268, 1.286, - & 1.286, 1.286, 1.304, 1.304, 1.324, 1.324, - & 1.343, 1.364, 1.364, 1.385, 1.406, 1.406, - & 1.429, 1.452, 1.475, 1.500, 1.525, 1.525, - & 1.552, 1.579, 1.607, 1.636, 1.667, 1.698, - & 1.765, 1.800, 1.837, 1.875, 1.915, 1.957, - & 2.045, 2.093, 2.143, 2.195, 2.308, 2.368, - & 2.432, 2.571, 2.647, 2.813, 2.903, 3.103, - & 3.214, 3.333, 3.600, 3.750, 4.091, 4.286, - & 4.737, 5.000, 5.625, 6.000, 6.923, 8.182, - & 9.000,11.250,12.857,18.000,22.500,45.000, - & 90.000/ -C -C NUMBER OF POINTS ALONG LAT CIRCLE FOR ONE OCTANT -C - DATA NPT / 73, 73, 73, 73, 73, 73, - & 73, 73, 72, 72, 72, 71, - & 71, 71, 70, 70, 69, 69, - & 68, 67, 67, 66, 65, 65, - & 64, 63, 62, 61, 60, 60, - & 59, 58, 57, 56, 55, 54, - & 52, 51, 50, 49, 48, 47, - & 45, 44, 43, 42, 40, 39, - & 38, 36, 35, 33, 32, 30, - & 29, 28, 26, 25, 23, 22, - & 20, 19, 17, 16, 14, 12, - & 11, 9, 8, 6, 5, 3, - & 2/ -C - LIN = .FALSE. - IF (INTERP.EQ.1) LIN = .TRUE. -C - IF (ISWT.EQ.1) GO TO 900 -C - IJOUT = 0 - DO 200 J = 1,73 - XJOU = (J-1) * 1.25 + 1.0 - II = NPT(74-J) - RDGLAT = SEP(74-J) - DO 100 I = 1,II - IJOUT = IJOUT + 1 - W1(IJOUT) = (I-1) * RDGLAT + 3.0 - W2(IJOUT) = XJOU - 100 CONTINUE - 200 CONTINUE -C - ISWT = 1 - INTRPO = INTERP - GO TO 1000 -C -C AFTER THE 1ST CALL TO W3FT17 TEST INTERP, IF IT HAS -C CHANGED RECOMPUTE SOME CONSTANTS -C - 900 CONTINUE - IF (INTERP.EQ.INTRPO) GO TO 2100 - INTRPO = INTERP -C - 1000 CONTINUE - DO 1100 K = 1,NPTS - IV(K) = W1(K) - JV(K) = W2(K) - XDELI(K) = W1(K) - IV(K) - XDELJ(K) = W2(K) - JV(K) - IP1(K) = IV(K) + 1 - JY(K,3) = JV(K) + 1 - JY(K,2) = JV(K) - 1100 CONTINUE -C - IF (LIN) GO TO 1400 -C - DO 1200 K = 1,NPTS - IP2(K) = IV(K) + 2 - IM1(K) = IV(K) - 1 - JY(K,1) = JV(K) - 1 - JY(K,4) = JV(K) + 2 - XI2TM(K) = XDELI(K) * (XDELI(K) - 1.0) * .25 - XJ2TM(K) = XDELJ(K) * (XDELJ(K) - 1.0) * .25 - 1200 CONTINUE -C - 1400 CONTINUE -C - IF (LIN) GO TO 1700 -C - DO 1500 KK = 1,NPTS - IF (JV(KK).LT.2.OR.JV(KK).GE.90) XJ2TM(KK) = 0.0 - 1500 CONTINUE -C - 1700 CONTINUE -C -C LINEAR INTERPOLATION -C - DO 1900 KK = 1,NPTS - IF (JY(KK,3).GT.91) JY(KK,3) = 91 - 1900 CONTINUE -C - IF (.NOT.LIN) THEN - DO 2000 KK = 1,NPTS - IF (JY(KK,1).LT.1) JY(KK,1) = 1 - IF (JY(KK,4).GT.91) JY(KK,4) = 91 - 2000 CONTINUE - ENDIF -C - 2100 CONTINUE - IF (LIN) THEN -C -C LINEAR INTERPOLATION -C - DO 2200 KK = 1,NPTS - ERAS(KK,2) = (ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) - ERAS(KK,3) = (ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) - 2200 CONTINUE -C - DO 2300 KK = 1,NPTS - BTHIN(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) - 2300 CONTINUE -C - ELSE -C -C QUADRATIC INTERPOLATION -C - DO 2400 KK = 1,NPTS - ERAS(KK,1)=(ALOLA(IP1(KK),JY(KK,1))-ALOLA(IV(KK),JY(KK,1))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,1)) + - & ( ALOLA(IM1(KK),JY(KK,1)) - ALOLA(IV(KK),JY(KK,1)) - & - ALOLA(IP1(KK),JY(KK,1))+ALOLA(IP2(KK),JY(KK,1))) - & * XI2TM(KK) - ERAS(KK,2)=(ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) + - & ( ALOLA(IM1(KK),JY(KK,2)) - ALOLA(IV(KK),JY(KK,2)) - & - ALOLA(IP1(KK),JY(KK,2))+ALOLA(IP2(KK),JY(KK,2))) - & * XI2TM(KK) - ERAS(KK,3)=(ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) + - & ( ALOLA(IM1(KK),JY(KK,3)) - ALOLA(IV(KK),JY(KK,3)) - & - ALOLA(IP1(KK),JY(KK,3))+ALOLA(IP2(KK),JY(KK,3))) - & * XI2TM(KK) - ERAS(KK,4)=(ALOLA(IP1(KK),JY(KK,4))-ALOLA(IV(KK),JY(KK,4))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,4)) + - & ( ALOLA(IM1(KK),JY(KK,4)) - ALOLA(IV(KK),JY(KK,4)) - & - ALOLA(IP1(KK),JY(KK,4))+ALOLA(IP2(KK),JY(KK,4))) - & * XI2TM(KK) - 2400 CONTINUE -C - DO 2500 KK = 1,NPTS - BTHIN(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) + (ERAS(KK,1) - ERAS(KK,2) - & - ERAS(KK,3) + ERAS(KK,4)) * XJ2TM(KK) - 2500 CONTINUE -C - ENDIF -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft201.f b/src/fim/FIMsrc/w3/w3ft201.f deleted file mode 100644 index d09f768..0000000 --- a/src/fim/FIMsrc/w3/w3ft201.f +++ /dev/null @@ -1,270 +0,0 @@ - SUBROUTINE W3FT201(ALOLA,APOLA,INTERP) -C$$$ SUBROUTINE DOCUMENTATION BLOCK *** -C -C SUBROUTINE: W3FT201 CONVERT (361,181) GRID TO (65,65) N. HEMI. GRID -C AUTHOR: JONES,R.E. ORG: W342 DATE: 94-09-11 -C -C ABSTRACT: CONVERT A GLOBAL 1.0 DEGREE LAT.,LON. 361 BY -C 181 GRID TO A POLAR STEREOGRAPHIC 65 BY 65 GRID. THE POLAR -C STEREOGRAPHIC MAP PROJECTION IS TRUE AT 60 DEG. N. , THE MESH -C LENGTH IS 381 KM. AND THE ORIENTION IS 105 DEG. W. THIS IS THE -C SAME AS W3FT43V EXCEPT THE ORIENTION IS 105 DEG. W. -C -C PROGRAM HISTORY LOG: -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C -C USAGE: CALL W3FT201(ALOLA,APOLA,INTERP) -C -C INPUT ARGUMENTS: ALOLA - 361*181 GRID 1.0 DEG. LAT,LON GRID -C 65341 POINT GRID. 360 * 181 ONE DEGREE -C GRIB GRID 3 WAS FLIPPED, GREENWISH ADDED -C TO RIGHT SIDE TO MAKE 361 * 181. -C INTERP - 1 LINEAR INTERPOLATION , NE.1 BIQUADRATIC -C -C INPUT FILES: NONE -C -C OUTPUT ARGUMENTS: APOLA - 65*65 GRID OF NORTHERN HEMISPHERE. -C 4225 POINT GRID IS AWIPS GRID TYPE 201 -C -C OUTPUT FILES: ERROR MESSAGE TO FORTRAN OUTPUT FILE -C -C WARNINGS: -C -C 1. W1 AND W2 ARE USED TO STORE SETS OF CONSTANTS WHICH ARE -C REUSABLE FOR REPEATED CALLS TO THE SUBROUTINE. -C -C 2. WIND COMPONENTS ARE NOT ROTATED TO THE 65*65 GRID ORIENTATION -C AFTER INTERPOLATION. YOU MAY USE W3FC08 TO DO THIS. -C -C 3. ALL POINTS BELOW EQUATOR ARE ON THIS GRID. -C -C RETURN CONDITIONS: NORMAL SUBROUTINE EXIT -C -C SUBPROGRAMS CALLED: -C UNIQUE : NONE -C -C LIBRARY: ASIN , ATAN2 -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256 -C -C$$$ -C - PARAMETER (NPTS=4225,II=65,JJ=65) - PARAMETER (ORIENT=105.0,IPOLE=33,JPOLE=33) - PARAMETER (XMESH=381.0) -C - REAL R2(NPTS), WLON(NPTS) - REAL XLAT(NPTS), XI(II,JJ), XJ(II,JJ) - REAL XII(NPTS), XJJ(NPTS), ANGLE(NPTS) - REAL ALOLA(361,181), APOLA(NPTS), ERAS(NPTS,4) - REAL W1(NPTS), W2(NPTS) - REAL XDELI(NPTS), XDELJ(NPTS) - REAL XI2TM(NPTS), XJ2TM(NPTS) -C - INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4) - INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS) -C - LOGICAL LIN -C - SAVE -C - EQUIVALENCE (XI(1,1),XII(1)),(XJ(1,1),XJJ(1)) -C - DATA DEGPRD/57.2957795/ - DATA EARTHR/6371.2/ - DATA INTRPO/99/ - DATA ISWT /0/ -C - LIN = .FALSE. - IF (INTERP.EQ.1) LIN = .TRUE. -C - IF (ISWT.EQ.1) GO TO 900 -C - DEG = 1.0 - GI2 = (1.86603 * EARTHR) / XMESH - GI2 = GI2 * GI2 -C -C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB01 IN LINE -C - DO 100 J = 1,JJ - XJ1 = J - JPOLE - DO 100 I = 1,II - XI(I,J) = I - IPOLE - XJ(I,J) = XJ1 - 100 CONTINUE -C - DO 200 KK = 1,NPTS - R2(KK) = XJJ(KK) * XJJ(KK) + XII(KK) * XII(KK) - XLAT(KK) = DEGPRD * - & ASIN((GI2 - R2(KK)) / (GI2 + R2(KK))) - 200 CONTINUE -C - XII(2113) = 1.0 - DO 300 KK = 1,NPTS - ANGLE(KK) = DEGPRD * ATAN2(XJJ(KK),XII(KK)) - 300 CONTINUE -C - DO 400 KK = 1,NPTS - IF (ANGLE(KK).LT.0.0) ANGLE(KK) = ANGLE(KK) + 360.0 - 400 CONTINUE -C - DO 500 KK = 1,NPTS - WLON(KK) = 270.0 + ORIENT - ANGLE(KK) - 500 CONTINUE -C - DO 600 KK = 1,NPTS - IF (WLON(KK).LT.0.0) WLON(KK) = WLON(KK) + 360.0 - 600 CONTINUE -C - DO 700 KK = 1,NPTS - IF (WLON(KK).GE.360.0) WLON(KK) = WLON(KK) - 360.0 - 700 CONTINUE -C - XLAT(2113) = 90.0 - WLON(2113) = 0.0 -C - DO 800 KK = 1,NPTS - W1(KK) = (360.0 - WLON(KK)) / DEG + 1.0 - W2(KK) = XLAT(KK) / DEG + 91.0 - 800 CONTINUE -C - ISWT = 1 - INTRPO = INTERP - GO TO 1000 -C -C AFTER THE 1ST CALL TO W3FT201 TEST INTERP, IF IT HAS -C CHANGED RECOMPUTE SOME CONSTANTS -C - 900 CONTINUE - IF (INTERP.EQ.INTRPO) GO TO 2100 - INTRPO = INTERP -C - 1000 CONTINUE - DO 1100 K = 1,NPTS - IV(K) = W1(K) - JV(K) = W2(K) - XDELI(K) = W1(K) - IV(K) - XDELJ(K) = W2(K) - JV(K) - IP1(K) = IV(K) + 1 - JY(K,3) = JV(K) + 1 - JY(K,2) = JV(K) - 1100 CONTINUE -C - IF (LIN) GO TO 1400 -C - DO 1200 K = 1,NPTS - IP2(K) = IV(K) + 2 - IM1(K) = IV(K) - 1 - JY(K,1) = JV(K) - 1 - JY(K,4) = JV(K) + 2 - XI2TM(K) = XDELI(K) * (XDELI(K) - 1.0) * .25 - XJ2TM(K) = XDELJ(K) * (XDELJ(K) - 1.0) * .25 - 1200 CONTINUE -C - DO 1300 KK = 1,NPTS - IF (IV(KK).EQ.1) THEN - IP2(KK) = 3 - IM1(KK) = 360 - ELSE IF (IV(KK).EQ.360) THEN - IP2(KK) = 2 - IM1(KK) = 359 - ENDIF - 1300 CONTINUE -C - 1400 CONTINUE -C - IF (LIN) GO TO 1700 -C - DO 1500 KK = 1,NPTS - IF (JV(KK).GE.180) XJ2TM(KK) = 0.0 - 1500 CONTINUE -C - DO 1600 KK = 1,NPTS - IF (IP2(KK).LT.1) IP2(KK) = 1 - IF (IM1(KK).LT.1) IM1(KK) = 1 - IF (IP2(KK).GT.361) IP2(KK) = 361 - IF (IM1(KK).GT.361) IM1(KK) = 361 - 1600 CONTINUE -C - 1700 CONTINUE - DO 1800 KK = 1,NPTS - IF (IV(KK).LT.1) IV(KK) = 1 - IF (IP1(KK).LT.1) IP1(KK) = 1 - IF (IV(KK).GT.361) IV(KK) = 361 - IF (IP1(KK).GT.361) IP1(KK) = 361 - 1800 CONTINUE -C -C LINEAR INTERPOLATION -C - DO 1900 KK = 1,NPTS - IF (JY(KK,2).GT.181) JY(KK,2) = 181 - IF (JY(KK,3).GT.181) JY(KK,3) = 181 - 1900 CONTINUE -C - IF (.NOT.LIN) THEN - DO 2000 KK = 1,NPTS - IF (JY(KK,1).GT.181) JY(KK,1) = 181 - IF (JY(KK,4).GT.181) JY(KK,4) = 181 - 2000 CONTINUE - ENDIF -C - 2100 CONTINUE - IF (LIN) THEN -C -C LINEAR INTERPOLATION -C - DO 2200 KK = 1,NPTS - ERAS(KK,2) = (ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) - ERAS(KK,3) = (ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) - 2200 CONTINUE -C - DO 2300 KK = 1,NPTS - APOLA(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) - 2300 CONTINUE -C - ELSE -C -C QUADRATIC INTERPOLATION -C - DO 2400 KK = 1,NPTS - ERAS(KK,1)=(ALOLA(IP1(KK),JY(KK,1))-ALOLA(IV(KK),JY(KK,1))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,1)) + - & ( ALOLA(IM1(KK),JY(KK,1)) - ALOLA(IV(KK),JY(KK,1)) - & - ALOLA(IP1(KK),JY(KK,1))+ALOLA(IP2(KK),JY(KK,1))) - & * XI2TM(KK) - ERAS(KK,2)=(ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) + - & ( ALOLA(IM1(KK),JY(KK,2)) - ALOLA(IV(KK),JY(KK,2)) - & - ALOLA(IP1(KK),JY(KK,2))+ALOLA(IP2(KK),JY(KK,2))) - & * XI2TM(KK) - ERAS(KK,3)=(ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) + - & ( ALOLA(IM1(KK),JY(KK,3)) - ALOLA(IV(KK),JY(KK,3)) - & - ALOLA(IP1(KK),JY(KK,3))+ALOLA(IP2(KK),JY(KK,3))) - & * XI2TM(KK) - ERAS(KK,4)=(ALOLA(IP1(KK),JY(KK,4))-ALOLA(IV(KK),JY(KK,4))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,4)) + - & ( ALOLA(IM1(KK),JY(KK,4)) - ALOLA(IV(KK),JY(KK,4)) - & - ALOLA(IP1(KK),JY(KK,4))+ALOLA(IP2(KK),JY(KK,4))) - & * XI2TM(KK) - 2400 CONTINUE -C - DO 2500 KK = 1,NPTS - APOLA(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) + (ERAS(KK,1) - ERAS(KK,2) - & - ERAS(KK,3) + ERAS(KK,4)) * XJ2TM(KK) - 2500 CONTINUE -C - ENDIF -C -C SET POLE POINT , WMO STANDARD FOR U OR V -C - APOLA(2113) = ALOLA(181,181) -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft202.f b/src/fim/FIMsrc/w3/w3ft202.f deleted file mode 100644 index be7a6df..0000000 --- a/src/fim/FIMsrc/w3/w3ft202.f +++ /dev/null @@ -1,214 +0,0 @@ - SUBROUTINE W3FT202(ALOLA,APOLA,INTERP) -C$$$ SUBROUTINE DOCUMENTATION BLOCK *** -C -C SUBROUTINE: W3FT202 CONVERT (361,91) GRID TO (65,43) N. HEMI. GRID -C AUTHOR: JONES,R.E. ORG: W342 DATE: 94-05-18 -C -C ABSTRACT: CONVERT A NORTHERN HEMISPHERE 1.0 DEGREE LAT.,LON. 361 BY -C 91 GRID TO A POLAR STEREOGRAPHIC 65 BY 43 GRID. THE POLAR -C STEREOGRAPHIC MAP PROJECTION IS TRUE AT 60 DEG. N. , THE MESH -C LENGTH IS 190.5 KM. AND THE ORIENTION IS 105 DEG. W. -C -C PROGRAM HISTORY LOG: -C 94-05-18 R.E.JONES -C -C USAGE: CALL W3FT202(ALOLA,APOLA,INTERP) -C -C INPUT ARGUMENTS: ALOLA - 361*91 GRID 1.0 LAT,LON GRID N. HEMISPHERE -C 32851 POINT GRID IS O.N. 84 TYPE ?? OR ?? HEX -C INTERP - 1 LINEAR INTERPOLATION , NE.1 BIQUADRATIC -C -C INPUT FILES: NONE -C -C OUTPUT ARGUMENTS: APOLA - 65*43 GRID OF NORTHERN HEMISPHERE. -C 2795 POINT GRID IS AWIPS GRID TYPE 202 -C -C OUTPUT FILES: ERROR MESSAGE TO FORTRAN OUTPUT FILE -C -C WARNINGS: -C -C 1. W1 AND W2 ARE USED TO STORE SETS OF CONSTANTS WHICH ARE -C REUSABLE FOR REPEATED CALLS TO THE SUBROUTINE. -C -C 2. WIND COMPONENTS ARE NOT ROTATED TO THE 65*43 GRID ORIENTATION -C AFTER INTERPOLATION. YOU MAY USE W3FC08 TO DO THIS. -C -C 3. THE GRID POINTS VALUES ON THE EQUATOR HAVE BEEN EXTRAPOLATED -C OUTWARD TO ALL THE GRID POINTS OUTSIDE THE EQUATOR ON THE 65*43 -C GRID (ABOUT 1100 POINTS). -C -C RETURN CONDITIONS: NORMAL SUBROUTINE EXIT -C -C SUBPROGRAMS CALLED: -C UNIQUE : NONE -C -C LIBRARY: ASIN , ATAN2 -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256 -C -C$$$ -C - PARAMETER (NPTS=2795,II=65,JJ=43) - PARAMETER (ORIENT=105.0,IPOLE=33,JPOLE=45) - PARAMETER (XMESH=190.5) -C - REAL R2(NPTS), WLON(NPTS) - REAL XLAT(NPTS), XI(II,JJ), XJ(II,JJ) - REAL XII(NPTS), XJJ(NPTS), ANGLE(NPTS) - REAL ALOLA(361,91), APOLA(NPTS), ERAS(NPTS,4) - REAL W1(NPTS), W2(NPTS) - REAL XDELI(NPTS), XDELJ(NPTS) - REAL XI2TM(NPTS), XJ2TM(NPTS) -C - INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4) - INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS) -C - LOGICAL LIN -C - SAVE -C - EQUIVALENCE (XI(1,1),XII(1)),(XJ(1,1),XJJ(1)) -C - DATA DEGPRD/57.2957795/ - DATA EARTHR/6371.2/ - DATA INTRPO/99/ - DATA ISWT /0/ -C - LIN = .FALSE. - IF (INTERP.EQ.1) LIN = .TRUE. -C - IF (ISWT.EQ.1) GO TO 900 -C - DEG = 1.0 - GI2 = (1.86603 * EARTHR) / XMESH - GI2 = GI2 * GI2 -C -C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB01 IN LINE -C - DO 100 J = 1,JJ - XJ1 = J - JPOLE - DO 100 I = 1,II - XI(I,J) = I - IPOLE - XJ(I,J) = XJ1 - 100 CONTINUE -C - DO 200 KK = 1,NPTS - R2(KK) = XJJ(KK) * XJJ(KK) + XII(KK) * XII(KK) - XLAT(KK) = DEGPRD * - & ASIN((GI2 - R2(KK)) / (GI2 + R2(KK))) - 200 CONTINUE -C - DO 300 KK = 1,NPTS - ANGLE(KK) = DEGPRD * ATAN2(XJJ(KK),XII(KK)) - 300 CONTINUE -C - DO 400 KK = 1,NPTS - IF (ANGLE(KK).LT.0.0) ANGLE(KK) = ANGLE(KK) + 360.0 - 400 CONTINUE -C - DO 500 KK = 1,NPTS - WLON(KK) = 270.0 + ORIENT - ANGLE(KK) - 500 CONTINUE -C - DO 600 KK = 1,NPTS - IF (WLON(KK).LT.0.0) WLON(KK) = WLON(KK) + 360.0 - 600 CONTINUE -C - DO 700 KK = 1,NPTS - IF (WLON(KK).GE.360.0) WLON(KK) = WLON(KK) - 360.0 - 700 CONTINUE -C - DO 800 KK = 1,NPTS - W1(KK) = (360.0 - WLON(KK)) / DEG + 1.0 - W2(KK) = XLAT(KK) / DEG + 1.0 - 800 CONTINUE -C - ISWT = 1 - INTRPO = INTERP - GO TO 1000 -C -C AFTER THE 1ST CALL TO W3FT202 TEST INTERP, IF IT HAS -C CHANGED RECOMPUTE SOME CONSTANTS -C - 900 CONTINUE - IF (INTERP.EQ.INTRPO) GO TO 2100 - INTRPO = INTERP -C - 1000 CONTINUE - DO 1100 K = 1,NPTS - IV(K) = W1(K) - JV(K) = W2(K) - XDELI(K) = W1(K) - IV(K) - XDELJ(K) = W2(K) - JV(K) - IP1(K) = IV(K) + 1 - JY(K,3) = JV(K) + 1 - JY(K,2) = JV(K) - 1100 CONTINUE -C - IF (LIN) GO TO 2100 -C - DO 1200 K = 1,NPTS - IP2(K) = IV(K) + 2 - IM1(K) = IV(K) - 1 - JY(K,1) = JV(K) - 1 - JY(K,4) = JV(K) + 2 - XI2TM(K) = XDELI(K) * (XDELI(K) - 1.0) * .25 - XJ2TM(K) = XDELJ(K) * (XDELJ(K) - 1.0) * .25 - 1200 CONTINUE -C - 2100 CONTINUE - IF (LIN) THEN -C -C LINEAR INTERPOLATION -C - DO 2200 KK = 1,NPTS - ERAS(KK,2) = (ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) - ERAS(KK,3) = (ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) - 2200 CONTINUE -C - DO 2300 KK = 1,NPTS - APOLA(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) - 2300 CONTINUE -C - ELSE -C -C QUADRATIC INTERPOLATION -C - DO 2400 KK = 1,NPTS - ERAS(KK,1)=(ALOLA(IP1(KK),JY(KK,1))-ALOLA(IV(KK),JY(KK,1))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,1)) + - & ( ALOLA(IM1(KK),JY(KK,1)) - ALOLA(IV(KK),JY(KK,1)) - & - ALOLA(IP1(KK),JY(KK,1))+ALOLA(IP2(KK),JY(KK,1))) - & * XI2TM(KK) - ERAS(KK,2)=(ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) + - & ( ALOLA(IM1(KK),JY(KK,2)) - ALOLA(IV(KK),JY(KK,2)) - & - ALOLA(IP1(KK),JY(KK,2))+ALOLA(IP2(KK),JY(KK,2))) - & * XI2TM(KK) - ERAS(KK,3)=(ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) + - & ( ALOLA(IM1(KK),JY(KK,3)) - ALOLA(IV(KK),JY(KK,3)) - & - ALOLA(IP1(KK),JY(KK,3))+ALOLA(IP2(KK),JY(KK,3))) - & * XI2TM(KK) - ERAS(KK,4)=(ALOLA(IP1(KK),JY(KK,4))-ALOLA(IV(KK),JY(KK,4))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,4)) + - & ( ALOLA(IM1(KK),JY(KK,4)) - ALOLA(IV(KK),JY(KK,4)) - & - ALOLA(IP1(KK),JY(KK,4))+ALOLA(IP2(KK),JY(KK,4))) - & * XI2TM(KK) - 2400 CONTINUE -C - DO 2500 KK = 1,NPTS - APOLA(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) + (ERAS(KK,1) - ERAS(KK,2) - & - ERAS(KK,3) + ERAS(KK,4)) * XJ2TM(KK) - 2500 CONTINUE -C - ENDIF -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft203.f b/src/fim/FIMsrc/w3/w3ft203.f deleted file mode 100644 index 8c13d9b..0000000 --- a/src/fim/FIMsrc/w3/w3ft203.f +++ /dev/null @@ -1,269 +0,0 @@ - SUBROUTINE W3FT203(ALOLA,APOLA,INTERP) -C$$$ SUBROUTINE DOCUMENTATION BLOCK *** -C -C SUBROUTINE: W3FT203 CONVERT (361,91) GRID TO (45,39) N. HEMI. GRID -C AUTHOR: JONES,R.E. ORG: W342 DATE: 94-05-18 -C -C ABSTRACT: CONVERT A NORTHERN HEMISPHERE 1.0 DEGREE LAT.,LON. 361 BY -C 91 GRID TO A POLAR STEREOGRAPHIC 45 BY 39 GRID. THE POLAR -C STEREOGRAPHIC MAP PROJECTION IS TRUE AT 60 DEG. N. , THE MESH -C LENGTH IS 190.5 KM. AND THE ORIENTION IS 150 DEG. W. -C -C PROGRAM HISTORY LOG: -C 94-05-18 R.E.JONES -C -C USAGE: CALL W3FT203(ALOLA,APOLA,INTERP) -C -C INPUT ARGUMENTS: ALOLA - 361*91 GRID 1.0 LAT,LON GRID N. HEMISPHERE -C 32851 POINT GRID IS O.N. 84 TYPE ?? OR ?? HEX -C INTERP - 1 LINEAR INTERPOLATION , NE.1 BIQUADRATIC -C -C INPUT FILES: NONE -C -C OUTPUT ARGUMENTS: APOLA - 45*39 GRID OF NORTHERN HEMISPHERE. -C 1755 POINT GRID IS AWIPS GRID TYPE 203 -C -C OUTPUT FILES: ERROR MESSAGE TO FORTRAN OUTPUT FILE -C -C WARNINGS: -C -C 1. W1 AND W2 ARE USED TO STORE SETS OF CONSTANTS WHICH ARE -C REUSABLE FOR REPEATED CALLS TO THE SUBROUTINE. -C -C 2. WIND COMPONENTS ARE NOT ROTATED TO THE 45*39 GRID ORIENTATION -C AFTER INTERPOLATION. YOU MAY USE W3FC08 TO DO THIS. -C -C RETURN CONDITIONS: NORMAL SUBROUTINE EXIT -C -C SUBPROGRAMS CALLED: -C UNIQUE : NONE -C -C LIBRARY: ASIN , ATAN2 -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL92/256 -C -C$$$ -C - PARAMETER (NPTS=1755,II=45,JJ=39) - PARAMETER (ORIENT=150.0,IPOLE=27,JPOLE=37) - PARAMETER (XMESH=190.5) -C - REAL R2(NPTS), WLON(NPTS) - REAL XLAT(NPTS), XI(II,JJ), XJ(II,JJ) - REAL XII(NPTS), XJJ(NPTS), ANGLE(NPTS) - REAL ALOLA(361,91), APOLA(NPTS), ERAS(NPTS,4) - REAL W1(NPTS), W2(NPTS) - REAL XDELI(NPTS), XDELJ(NPTS) - REAL XI2TM(NPTS), XJ2TM(NPTS) -C - INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4) - INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS) -C - LOGICAL LIN -C - SAVE -C - EQUIVALENCE (XI(1,1),XII(1)),(XJ(1,1),XJJ(1)) -C - DATA DEGPRD/57.2957795/ - DATA EARTHR/6371.2/ - DATA INTRPO/99/ - DATA ISWT /0/ -C - LIN = .FALSE. - IF (INTERP.EQ.1) LIN = .TRUE. -C - IF (ISWT.EQ.1) GO TO 900 -C - DEG = 1.0 - GI2 = (1.86603 * EARTHR) / XMESH - GI2 = GI2 * GI2 -C -C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB01 IN LINE -C - DO 100 J = 1,JJ - XJ1 = J - JPOLE - DO 100 I = 1,II - XI(I,J) = I - IPOLE - XJ(I,J) = XJ1 - 100 CONTINUE -C - DO 200 KK = 1,NPTS - R2(KK) = XJJ(KK) * XJJ(KK) + XII(KK) * XII(KK) - XLAT(KK) = DEGPRD * - & ASIN((GI2 - R2(KK)) / (GI2 + R2(KK))) - 200 CONTINUE -C - XII(1647) = 1.0 - DO 300 KK = 1,NPTS - ANGLE(KK) = DEGPRD * ATAN2(XJJ(KK),XII(KK)) - 300 CONTINUE -C - DO 400 KK = 1,NPTS - IF (ANGLE(KK).LT.0.0) ANGLE(KK) = ANGLE(KK) + 360.0 - 400 CONTINUE -C - DO 500 KK = 1,NPTS - WLON(KK) = 270.0 + ORIENT - ANGLE(KK) - 500 CONTINUE -C - DO 600 KK = 1,NPTS - IF (WLON(KK).LT.0.0) WLON(KK) = WLON(KK) + 360.0 - 600 CONTINUE -C - DO 700 KK = 1,NPTS - IF (WLON(KK).GE.360.0) WLON(KK) = WLON(KK) - 360.0 - 700 CONTINUE -C - XLAT(1647) = 90.0 - WLON(1647) = 0.0 -C - DO 800 KK = 1,NPTS - W1(KK) = (360.0 - WLON(KK)) / DEG + 1.0 - W2(KK) = XLAT(KK) / DEG + 1.0 - 800 CONTINUE -C - ISWT = 1 - INTRPO = INTERP - GO TO 1000 -C -C AFTER THE 1ST CALL TO W3FT203 TEST INTERP, IF IT HAS -C CHANGED RECOMPUTE SOME CONSTANTS -C - 900 CONTINUE - IF (INTERP.EQ.INTRPO) GO TO 2100 - INTRPO = INTERP -C - 1000 CONTINUE - DO 1100 K = 1,NPTS - IV(K) = W1(K) - JV(K) = W2(K) - XDELI(K) = W1(K) - IV(K) - XDELJ(K) = W2(K) - JV(K) - IP1(K) = IV(K) + 1 - JY(K,3) = JV(K) + 1 - JY(K,2) = JV(K) - 1100 CONTINUE -C - IF (LIN) GO TO 1400 -C - DO 1200 K = 1,NPTS - IP2(K) = IV(K) + 2 - IM1(K) = IV(K) - 1 - JY(K,1) = JV(K) - 1 - JY(K,4) = JV(K) + 2 - XI2TM(K) = XDELI(K) * (XDELI(K) - 1.0) * .25 - XJ2TM(K) = XDELJ(K) * (XDELJ(K) - 1.0) * .25 - 1200 CONTINUE -C - DO 1300 KK = 1,NPTS - IF (IV(KK).EQ.1) THEN - IP2(KK) = 3 - IM1(KK) = 360 - ELSE IF (IV(KK).EQ.360) THEN - IP2(KK) = 2 - IM1(KK) = 359 - ENDIF - 1300 CONTINUE -C - 1400 CONTINUE -C - IF (LIN) GO TO 1700 -C - DO 1500 KK = 1,NPTS - IF (JV(KK).LT.2.OR.JV(KK).GT.89) XJ2TM(KK) = 0.0 - 1500 CONTINUE -C - DO 1600 KK = 1,NPTS - IF (IP2(KK).LT.1) IP2(KK) = 1 - IF (IM1(KK).LT.1) IM1(KK) = 1 - IF (IP2(KK).GT.361) IP2(KK) = 361 - IF (IM1(KK).GT.361) IM1(KK) = 361 - 1600 CONTINUE -C - 1700 CONTINUE - DO 1800 KK = 1,NPTS - IF (IV(KK).LT.1) IV(KK) = 1 - IF (IP1(KK).LT.1) IP1(KK) = 1 - IF (IV(KK).GT.361) IV(KK) = 361 - IF (IP1(KK).GT.361) IP1(KK) = 361 - 1800 CONTINUE -C -C LINEAR INTERPOLATION -C - DO 1900 KK = 1,NPTS - IF (JY(KK,2).LT.1) JY(KK,2) = 1 - IF (JY(KK,2).GT.91) JY(KK,2) = 91 - IF (JY(KK,3).LT.1) JY(KK,3) = 1 - IF (JY(KK,3).GT.91) JY(KK,3) = 91 - 1900 CONTINUE -C - IF (.NOT.LIN) THEN - DO 2000 KK = 1,NPTS - IF (JY(KK,1).LT.1) JY(KK,1) = 1 - IF (JY(KK,1).GT.91) JY(KK,1) = 91 - IF (JY(KK,4).LT.1) JY(KK,4) = 1 - IF (JY(KK,4).GT.91) JY(KK,4) = 91 - 2000 CONTINUE - ENDIF -C - 2100 CONTINUE - IF (LIN) THEN -C -C LINEAR INTERPOLATION -C - DO 2200 KK = 1,NPTS - ERAS(KK,2) = (ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) - ERAS(KK,3) = (ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) - 2200 CONTINUE -C - DO 2300 KK = 1,NPTS - APOLA(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) - 2300 CONTINUE -C - ELSE -C -C QUADRATIC INTERPOLATION -C - DO 2400 KK = 1,NPTS - ERAS(KK,1)=(ALOLA(IP1(KK),JY(KK,1))-ALOLA(IV(KK),JY(KK,1))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,1)) + - & ( ALOLA(IM1(KK),JY(KK,1)) - ALOLA(IV(KK),JY(KK,1)) - & - ALOLA(IP1(KK),JY(KK,1))+ALOLA(IP2(KK),JY(KK,1))) - & * XI2TM(KK) - ERAS(KK,2)=(ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) + - & ( ALOLA(IM1(KK),JY(KK,2)) - ALOLA(IV(KK),JY(KK,2)) - & - ALOLA(IP1(KK),JY(KK,2))+ALOLA(IP2(KK),JY(KK,2))) - & * XI2TM(KK) - ERAS(KK,3)=(ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) + - & ( ALOLA(IM1(KK),JY(KK,3)) - ALOLA(IV(KK),JY(KK,3)) - & - ALOLA(IP1(KK),JY(KK,3))+ALOLA(IP2(KK),JY(KK,3))) - & * XI2TM(KK) - ERAS(KK,4)=(ALOLA(IP1(KK),JY(KK,4))-ALOLA(IV(KK),JY(KK,4))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,4)) + - & ( ALOLA(IM1(KK),JY(KK,4)) - ALOLA(IV(KK),JY(KK,4)) - & - ALOLA(IP1(KK),JY(KK,4))+ALOLA(IP2(KK),JY(KK,4))) - & * XI2TM(KK) - 2400 CONTINUE -C - DO 2500 KK = 1,NPTS - APOLA(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) + (ERAS(KK,1) - ERAS(KK,2) - & - ERAS(KK,3) + ERAS(KK,4)) * XJ2TM(KK) - 2500 CONTINUE -C -C SET POLE POINT , WMO STANDARD FOR U OR V -C - APOLA(1647) = ALOLA(181,91) -C - ENDIF -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft204.f b/src/fim/FIMsrc/w3/w3ft204.f deleted file mode 100644 index e6e9ad7..0000000 --- a/src/fim/FIMsrc/w3/w3ft204.f +++ /dev/null @@ -1,198 +0,0 @@ - SUBROUTINE W3FT204(ALOLA,AMERC,INTERP) -C$$$ SUBROUTINE DOCUMENTATION BLOCK *** -C -C SUBROUTINE: W3FT204 CONVERT (361,181) GRID TO (93,68) MERCATOR GRID -C AUTHOR: JONES,R.E. ORG: W342 DATE: 94-05-18 -C -C ABSTRACT: CONVERT A N. S. HEMISPHERE 1.0 DEGREE LAT.,LON. 361 BY -C 181 GRID TO A NATIONAL - HAWAII (MERCATOR) 93*68 AWIPS 204 -C GRID. -C -C PROGRAM HISTORY LOG: -C 94-05-18 R.E.JONES -C -C USAGE: CALL W3FT204(ALOLA,AMERC,INTERP) -C -C INPUT ARGUMENTS: ALOLA - 361*181 GRID 1.0 DEG. LAT,LON GRID N. HEMI. -C 65341 POINT GRID. 360 * 181 ONE DEGREE -C GRIB GRID 3 WAS FLIPPED, GREENWISH ADDED -C TO RIGHT SIDE. -C INTERP - 1 LINEAR INTERPOLATION , NE.1 BIQUADRATIC -C -C INPUT FILES: NONE -C -C OUTPUT ARGUMENTS: AMERC - 93*68 GRID NATIONAL - HAWAII (MERCATOR) -C 6324 POINT GRID IS AWIPS GRID TYPE 204 -C -C OUTPUT FILES: ERROR MESSAGE TO FORTRAN OUTPUT FILE -C -C WARNINGS: -C -C 1. W1 AND W2 ARE USED TO STORE SETS OF CONSTANTS WHICH ARE -C REUSABLE FOR REPEATED CALLS TO THE SUBROUTINE. 20 OTHER ARRAY -C ARE SAVED AND REUSED ON THE NEXT CALL. -C -C RETURN CONDITIONS: NORMAL SUBROUTINE EXIT -C -C SUBPROGRAMS CALLED: -C UNIQUE : NONE -C -C LIBRARY: ASIN , ATAN2 -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL92/256 -C -C$$$ -C - PARAMETER (NPTS=6324,II=93,JJ=68) - PARAMETER (ALATIN=20.000) - PARAMETER (PI=3.1416) - PARAMETER (DX=160000.0) - PARAMETER (ALAT1=-25.000) - PARAMETER (ALON1=110.000) -C - REAL WLON(NPTS), XLAT(NPTS) - REAL XI(II,JJ), XJ(II,JJ) - REAL XII(NPTS), XJJ(NPTS) - REAL ALOLA(361,181), AMERC(NPTS), ERAS(NPTS,4) - REAL W1(NPTS), W2(NPTS) - REAL XDELI(NPTS), XDELJ(NPTS) - REAL XI2TM(NPTS), XJ2TM(NPTS) -C - INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4) - INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS) -C - LOGICAL LIN -C - SAVE -C - EQUIVALENCE (XI(1,1),XII(1)),(XJ(1,1),XJJ(1)) -C -C DATA DEGPR /57.2957795/ - DATA RERTH /6.3712E+6/ - DATA INTRPO/99/ - DATA ISWT /0/ -C - RADPD = PI / 180.0 - DEGPR = 180.0 / PI - CLAIN = COS(RADPD * ALATIN) - DELLON = DX / (RERTH * CLAIN) - DJEO = (ALOG(TAN(0.5*((ALAT1+90.0)*RADPD))))/DELLON -C - LIN = .FALSE. - IF (INTERP.EQ.1) LIN = .TRUE. -C - IF (ISWT.EQ.1) GO TO 900 -C - DEG = 1.0 -C -C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB09 IN LINE -C - DO 100 J = 1,JJ - DO 100 I = 1,II - XI(I,J) = I - XJ(I,J) = J - 100 CONTINUE -C - DO 200 KK = 1,NPTS - XLAT(KK) = 2.0*ATAN(EXP(DELLON*(DJEO + XJJ(KK)-1.))) - & * DEGPR - 90.0 - 200 CONTINUE -C - DO 300 KK = 1,NPTS - WLON(KK) = (XII(KK) -1.0) * DELLON * DEGPR + ALON1 - 300 CONTINUE -C - DO 400 KK = 1,NPTS - W1(KK) = WLON(KK) + 1.0 - W2(KK) = XLAT(KK) + 91.0 - 400 CONTINUE -C - ISWT = 1 - INTRPO = INTERP - GO TO 1000 -C -C AFTER THE 1ST CALL TO W3FT204 TEST INTERP, IF IT HAS -C CHANGED RECOMPUTE SOME CONSTANTS -C - 900 CONTINUE - IF (INTERP.EQ.INTRPO) GO TO 2100 - INTRPO = INTERP -C - 1000 CONTINUE - DO 1100 K = 1,NPTS - IV(K) = W1(K) - JV(K) = W2(K) - XDELI(K) = W1(K) - IV(K) - XDELJ(K) = W2(K) - JV(K) - IP1(K) = IV(K) + 1 - JY(K,3) = JV(K) + 1 - JY(K,2) = JV(K) - 1100 CONTINUE -C - IF (LIN) GO TO 2100 -C - DO 1200 K = 1,NPTS - IP2(K) = IV(K) + 2 - IM1(K) = IV(K) - 1 - JY(K,1) = JV(K) - 1 - JY(K,4) = JV(K) + 2 - XI2TM(K) = XDELI(K) * (XDELI(K) - 1.0) * .25 - XJ2TM(K) = XDELJ(K) * (XDELJ(K) - 1.0) * .25 - 1200 CONTINUE -C - 2100 CONTINUE - IF (LIN) THEN -C -C LINEAR INTERPOLATION -C - DO 2200 KK = 1,NPTS - ERAS(KK,2) = (ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) - ERAS(KK,3) = (ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) - 2200 CONTINUE -C - DO 2300 KK = 1,NPTS - AMERC(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) - 2300 CONTINUE -C - ELSE -C -C QUADRATIC INTERPOLATION -C - DO 2400 KK = 1,NPTS - ERAS(KK,1)=(ALOLA(IP1(KK),JY(KK,1))-ALOLA(IV(KK),JY(KK,1))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,1)) + - & ( ALOLA(IM1(KK),JY(KK,1)) - ALOLA(IV(KK),JY(KK,1)) - & - ALOLA(IP1(KK),JY(KK,1))+ALOLA(IP2(KK),JY(KK,1))) - & * XI2TM(KK) - ERAS(KK,2)=(ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) + - & ( ALOLA(IM1(KK),JY(KK,2)) - ALOLA(IV(KK),JY(KK,2)) - & - ALOLA(IP1(KK),JY(KK,2))+ALOLA(IP2(KK),JY(KK,2))) - & * XI2TM(KK) - ERAS(KK,3)=(ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) + - & ( ALOLA(IM1(KK),JY(KK,3)) - ALOLA(IV(KK),JY(KK,3)) - & - ALOLA(IP1(KK),JY(KK,3))+ALOLA(IP2(KK),JY(KK,3))) - & * XI2TM(KK) - ERAS(KK,4)=(ALOLA(IP1(KK),JY(KK,4))-ALOLA(IV(KK),JY(KK,4))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,4)) + - & ( ALOLA(IM1(KK),JY(KK,4)) - ALOLA(IV(KK),JY(KK,4)) - & - ALOLA(IP1(KK),JY(KK,4))+ALOLA(IP2(KK),JY(KK,4))) - & * XI2TM(KK) - 2400 CONTINUE -C - DO 2500 KK = 1,NPTS - AMERC(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) + (ERAS(KK,1) - ERAS(KK,2) - & - ERAS(KK,3) + ERAS(KK,4)) * XJ2TM(KK) - 2500 CONTINUE -C - ENDIF -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft205.f b/src/fim/FIMsrc/w3/w3ft205.f deleted file mode 100644 index 043ea30..0000000 --- a/src/fim/FIMsrc/w3/w3ft205.f +++ /dev/null @@ -1,232 +0,0 @@ - SUBROUTINE W3FT205(ALOLA,APOLA,INTERP) -C$$$ SUBROUTINE DOCUMENTATION BLOCK *** -C -C SUBROUTINE: W3FT205 CONVERT (361,91) GRID TO (45,39) N. HEMI. GRID -C AUTHOR: JONES,R.E. ORG: W342 DATE: 93-10-19 -C -C ABSTRACT: CONVERT A NORTHERN HEMISPHERE 1.0 DEGREE LAT.,LON. 361 BY -C 91 GRID TO A POLAR STEREOGRAPHIC 45 BY 39 GRID. THE POLAR -C STEREOGRAPHIC MAP PROJECTION IS TRUE AT 60 DEG. N. , THE MESH -C LENGTH IS 190.5 KM. AND THE ORIENTION IS 60 DEG. W. POLE -C POINT IS AT (I,J) = (27,57). NEW MAP IS AWIPS MAP 205. -C -C PROGRAM HISTORY LOG: -C 93-10-19 R.E.JONES -C -C USAGE: CALL W3FT205(ALOLA,APOLA,INTERP) -C -C INPUT ARGUMENTS: ALOLA - 361*91 GRID 1.0 LAT,LON GRID N. HEMISPHERE -C 32851 POINT GRID. 360 * 181 ONE DEGREE -C GRIB GRID 3 WAS FLIPPED, GREENWISH ADDED -C TO RIGH SIDE AND CUT TO 361 * 91. -C INTERP - 1 LINEAR INTERPOLATION , NE.1 BIQUADRATIC -C -C INPUT FILES: NONE -C -C OUTPUT ARGUMENTS: APOLA - 45*39 GRID OF NORTHERN HEMISPHERE. -C 1755 POINT GRID IS AWIPS GRID TYPE 205 -C -C OUTPUT FILES: ERROR MESSAGE TO FORTRAN OUTPUT FILE -C -C WARNINGS: -C -C 1. W1 AND W2 ARE USED TO STORE SETS OF CONSTANTS WHICH ARE -C REUSABLE FOR REPEATED CALLS TO THE SUBROUTINE. -C -C 2. WIND COMPONENTS ARE NOT ROTATED TO THE 45*39 GRID ORIENTATION -C AFTER INTERPOLATION. YOU MAY USE W3FC08 TO DO THIS. -C -C RETURN CONDITIONS: NORMAL SUBROUTINE EXIT -C -C SUBPROGRAMS CALLED: -C UNIQUE : NONE -C -C LIBRARY: ASIN , ATAN2 -C -C ATTRIBUTES: -C LANGUAGE: SiliconGraphics 3.5 FORTRAN 77 -C MACHINE: SiliconGraphics IRIS-4D/25, 35, INDIGO, Indy -C -C$$$ -C - PARAMETER (NPTS=1755,II=45,JJ=39) - PARAMETER (ORIENT=60.0,IPOLE=27,JPOLE=57) - PARAMETER (XMESH=190.5) -C - REAL R2(NPTS), WLON(NPTS) - REAL XLAT(NPTS), XI(II,JJ), XJ(II,JJ) - REAL XII(NPTS), XJJ(NPTS), ANGLE(NPTS) - REAL ALOLA(361,91), APOLA(NPTS), ERAS(NPTS,4) - REAL W1(NPTS), W2(NPTS) - REAL XDELI(NPTS), XDELJ(NPTS) - REAL XI2TM(NPTS), XJ2TM(NPTS) -C - INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4) - INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS) -C - LOGICAL LIN -C - SAVE -C - EQUIVALENCE (XI(1,1),XII(1)),(XJ(1,1),XJJ(1)) -C - DATA DEGPRD/57.2957795/ - DATA EARTHR/6371.2/ - DATA INTRPO/99/ - DATA ISWT /0/ -C - LIN = .FALSE. - IF (INTERP.EQ.1) LIN = .TRUE. -C - IF (ISWT.EQ.1) GO TO 900 -C - DEG = 1.0 - GI2 = (1.86603 * EARTHR) / XMESH - GI2 = GI2 * GI2 -C -C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB05 IN LINE -C - DO 100 J = 1,JJ - XJ1 = J - JPOLE - DO 100 I = 1,II - XI(I,J) = I - IPOLE - XJ(I,J) = XJ1 - 100 CONTINUE -C - DO 200 KK = 1,NPTS - R2(KK) = XJJ(KK) * XJJ(KK) + XII(KK) * XII(KK) - XLAT(KK) = DEGPRD * - & ASIN((GI2 - R2(KK)) / (GI2 + R2(KK))) - 200 CONTINUE -C - XII(1647) = 1.0 - DO 300 KK = 1,NPTS - ANGLE(KK) = DEGPRD * ATAN2(XJJ(KK),XII(KK)) - 300 CONTINUE -C - DO 400 KK = 1,NPTS - IF (ANGLE(KK).LT.0.0) ANGLE(KK) = ANGLE(KK) + 360.0 - 400 CONTINUE -C - DO 500 KK = 1,NPTS - WLON(KK) = 270.0 + ORIENT - ANGLE(KK) - 500 CONTINUE -C - DO 600 KK = 1,NPTS - IF (WLON(KK).LT.0.0) WLON(KK) = WLON(KK) + 360.0 - 600 CONTINUE -C - DO 700 KK = 1,NPTS - IF (WLON(KK).GE.360.0) WLON(KK) = WLON(KK) - 360.0 - 700 CONTINUE -C - DO 800 KK = 1,NPTS - W1(KK) = (360.0 - WLON(KK)) / DEG + 1.0 - W2(KK) = XLAT(KK) / DEG + 1.0 - 800 CONTINUE -C - ISWT = 1 - INTRPO = INTERP - GO TO 1000 -C -C AFTER THE 1ST CALL TO W3FT203 TEST INTERP, IF IT HAS -C CHANGED RECOMPUTE SOME CONSTANTS -C - 900 CONTINUE - IF (INTERP.EQ.INTRPO) GO TO 2100 - INTRPO = INTERP -C - 1000 CONTINUE - DO 1100 K = 1,NPTS - IV(K) = W1(K) - JV(K) = W2(K) - XDELI(K) = W1(K) - IV(K) - XDELJ(K) = W2(K) - JV(K) - IP1(K) = IV(K) + 1 - JY(K,3) = JV(K) + 1 - JY(K,2) = JV(K) - 1100 CONTINUE -C - IF (LIN) GO TO 1400 -C - DO 1200 K = 1,NPTS - IP2(K) = IV(K) + 2 - IM1(K) = IV(K) - 1 - JY(K,1) = JV(K) - 1 - JY(K,4) = JV(K) + 2 - XI2TM(K) = XDELI(K) * (XDELI(K) - 1.0) * .25 - XJ2TM(K) = XDELJ(K) * (XDELJ(K) - 1.0) * .25 - 1200 CONTINUE -C - 1400 CONTINUE -C - IF (LIN) GO TO 1700 -C - DO 1500 KK = 1,NPTS - IF (JV(KK).LT.2.OR.JV(KK).GT.89) XJ2TM(KK) = 0.0 - 1500 CONTINUE -C - 1700 CONTINUE -C - IF (.NOT.LIN) THEN - DO 2000 KK = 1,NPTS - IF (JY(KK,1).LT.1) JY(KK,1) = 1 - 2000 CONTINUE - ENDIF -C - 2100 CONTINUE - IF (LIN) THEN -C -C LINEAR INTERPOLATION -C - DO 2200 KK = 1,NPTS - ERAS(KK,2) = (ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) - ERAS(KK,3) = (ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) - 2200 CONTINUE -C - DO 2300 KK = 1,NPTS - APOLA(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) - 2300 CONTINUE -C - ELSE -C -C QUADRATIC INTERPOLATION -C - DO 2400 KK = 1,NPTS - ERAS(KK,1)=(ALOLA(IP1(KK),JY(KK,1))-ALOLA(IV(KK),JY(KK,1))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,1)) + - & ( ALOLA(IM1(KK),JY(KK,1)) - ALOLA(IV(KK),JY(KK,1)) - & - ALOLA(IP1(KK),JY(KK,1))+ALOLA(IP2(KK),JY(KK,1))) - & * XI2TM(KK) - ERAS(KK,2)=(ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) + - & ( ALOLA(IM1(KK),JY(KK,2)) - ALOLA(IV(KK),JY(KK,2)) - & - ALOLA(IP1(KK),JY(KK,2))+ALOLA(IP2(KK),JY(KK,2))) - & * XI2TM(KK) - ERAS(KK,3)=(ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) + - & ( ALOLA(IM1(KK),JY(KK,3)) - ALOLA(IV(KK),JY(KK,3)) - & - ALOLA(IP1(KK),JY(KK,3))+ALOLA(IP2(KK),JY(KK,3))) - & * XI2TM(KK) - ERAS(KK,4)=(ALOLA(IP1(KK),JY(KK,4))-ALOLA(IV(KK),JY(KK,4))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,4)) + - & ( ALOLA(IM1(KK),JY(KK,4)) - ALOLA(IV(KK),JY(KK,4)) - & - ALOLA(IP1(KK),JY(KK,4))+ALOLA(IP2(KK),JY(KK,4))) - & * XI2TM(KK) - 2400 CONTINUE -C - DO 2500 KK = 1,NPTS - APOLA(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) + (ERAS(KK,1) - ERAS(KK,2) - & - ERAS(KK,3) + ERAS(KK,4)) * XJ2TM(KK) - 2500 CONTINUE -C -C NO POLE POINT -C - ENDIF -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft206.f b/src/fim/FIMsrc/w3/w3ft206.f deleted file mode 100644 index b9054f9..0000000 --- a/src/fim/FIMsrc/w3/w3ft206.f +++ /dev/null @@ -1,180 +0,0 @@ - SUBROUTINE W3FT206(ALOLA,ALAMB,INTERP) -C$$$ SUBROUTINE DOCUMENTATION BLOCK *** -C -C SUBROUTINE: W3FT206 CONVERT (361,91) GRID TO (51,41) LAMBERT GRID -C AUTHOR: JONES,R.E. ORG: W342 DATE: 94-05-18 -C -C ABSTRACT: CONVERT A NORTHERN HEMISPHERE 1.0 DEGREE LAT.,LON. 361 BY -C 91 GRID TO A LAMBERT CONFORMAL 51 BY 41 AWIPS GRIB 206. -C -C PROGRAM HISTORY LOG: -C 94-05-18 R.E.JONES -C -C USAGE: CALL W3FT206(ALOLA,ALAMB,INTERP) -C -C INPUT ARGUMENTS: ALOLA - 361*91 GRID 1.0 DEG. LAT,LON GRID N. HEMI. -C 32851 POINT GRID. 360 * 181 ONE DEGREE -C GRIB GRID 3 WAS FLIPPED, GREENWISH ADDED -C TO RIGHT SIDE AND CUT TO 361 * 91. -C INTERP - 1 LINEAR INTERPOLATION , NE.1 BIQUADRATIC -C -C INPUT FILES: NONE -C -C OUTPUT ARGUMENTS: ALAMB - 51*41 REGIONAL - CENTRAL US MARD -C (LAMBERT CONFORMAL). 2091 POINT GRID -C IS AWIPS GRID TYPE 206 -C -C OUTPUT FILES: ERROR MESSAGE TO FORTRAN OUTPUT FILE -C -C WARNINGS: -C -C 1. W1 AND W2 ARE USED TO STORE SETS OF CONSTANTS WHICH ARE -C REUSABLE FOR REPEATED CALLS TO THE SUBROUTINE. 11 OTHER ARRAY -C ARE SAVED AND REUSED ON THE NEXT CALL. -C -C 2. WIND COMPONENTS ARE NOT ROTATED TO THE 51*41 GRID ORIENTATION -C AFTER INTERPOLATION. YOU MAY USE W3FC08 TO DO THIS. -C -C RETURN CONDITIONS: NORMAL SUBROUTINE EXIT -C -C SUBPROGRAMS CALLED: -C UNIQUE : NONE -C -C LIBRARY: W3FB12 -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256 -C -C$$$ -C - PARAMETER (NPTS=2091,II=51,JJ=41) - PARAMETER (ALATAN=25.000) - PARAMETER (PI=3.1416) - PARAMETER (DX=81270.500) - PARAMETER (ALAT1=22.289) - PARAMETER (ELON1=242.00962) - PARAMETER (ELONV=265.000) - PARAMETER (III=361,JJJ=91) -C - REAL ALOLA(III,JJJ) - REAL ALAMB(NPTS) - REAL W1(NPTS), W2(NPTS), ERAS(NPTS,4) - REAL XDELI(NPTS), XDELJ(NPTS) - REAL XI2TM(NPTS), XJ2TM(NPTS) -C - INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4) - INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS) -C - LOGICAL LIN -C - SAVE -C - DATA ISWT /0/ - DATA INTRPO/99/ -C - LIN = .FALSE. - IF (INTERP.EQ.1) LIN = .TRUE. -C - IF (ISWT.EQ.1) GO TO 900 -c print *,'iswt = ',iswt - N = 0 - DO J = 1,JJ - DO I = 1,II - XJ = J - XI = I - CALL W3FB12(XI,XJ,ALAT1,ELON1,DX,ELONV,ALATAN,ALAT, - & ELON,IERR) - N = N + 1 - W1(N) = ELON + 1.0 - W2(N) = ALAT + 1.0 - END DO - END DO -C - ISWT = 1 - INTRPO = INTERP - GO TO 1000 -C -C AFTER THE 1ST CALL TO W3FT206 TEST INTERP, IF IT HAS -C CHANGED RECOMPUTE SOME CONSTANTS -C - 900 CONTINUE - IF (INTERP.EQ.INTRPO) GO TO 2100 - INTRPO = INTERP -C - 1000 CONTINUE - DO 1100 K = 1,NPTS - IV(K) = W1(K) - JV(K) = W2(K) - XDELI(K) = W1(K) - IV(K) - XDELJ(K) = W2(K) - JV(K) - IP1(K) = IV(K) + 1 - JY(K,3) = JV(K) + 1 - JY(K,2) = JV(K) - 1100 CONTINUE -C - IF (LIN) GO TO 2100 -C - DO 1200 K = 1,NPTS - IP2(K) = IV(K) + 2 - IM1(K) = IV(K) - 1 - JY(K,1) = JV(K) - 1 - JY(K,4) = JV(K) + 2 - XI2TM(K) = XDELI(K) * (XDELI(K) - 1.0) * .25 - XJ2TM(K) = XDELJ(K) * (XDELJ(K) - 1.0) * .25 - 1200 CONTINUE -C - 2100 CONTINUE - IF (LIN) THEN -C -C LINEAR INTERPOLATION -C - DO 2200 KK = 1,NPTS - ERAS(KK,2) = (ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) - ERAS(KK,3) = (ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) - 2200 CONTINUE -C - DO 2300 KK = 1,NPTS - ALAMB(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) - 2300 CONTINUE -C - ELSE -C -C QUADRATIC INTERPOLATION -C - DO 2400 KK = 1,NPTS - ERAS(KK,1)=(ALOLA(IP1(KK),JY(KK,1))-ALOLA(IV(KK),JY(KK,1))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,1)) + - & ( ALOLA(IM1(KK),JY(KK,1)) - ALOLA(IV(KK),JY(KK,1)) - & - ALOLA(IP1(KK),JY(KK,1))+ALOLA(IP2(KK),JY(KK,1))) - & * XI2TM(KK) - ERAS(KK,2)=(ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) + - & ( ALOLA(IM1(KK),JY(KK,2)) - ALOLA(IV(KK),JY(KK,2)) - & - ALOLA(IP1(KK),JY(KK,2))+ALOLA(IP2(KK),JY(KK,2))) - & * XI2TM(KK) - ERAS(KK,3)=(ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) + - & ( ALOLA(IM1(KK),JY(KK,3)) - ALOLA(IV(KK),JY(KK,3)) - & - ALOLA(IP1(KK),JY(KK,3))+ALOLA(IP2(KK),JY(KK,3))) - & * XI2TM(KK) - ERAS(KK,4)=(ALOLA(IP1(KK),JY(KK,4))-ALOLA(IV(KK),JY(KK,4))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,4)) + - & ( ALOLA(IM1(KK),JY(KK,4)) - ALOLA(IV(KK),JY(KK,4)) - & - ALOLA(IP1(KK),JY(KK,4))+ALOLA(IP2(KK),JY(KK,4))) - & * XI2TM(KK) - 2400 CONTINUE -C - DO 2500 KK = 1,NPTS - ALAMB(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) + (ERAS(KK,1) - ERAS(KK,2) - & - ERAS(KK,3) + ERAS(KK,4)) * XJ2TM(KK) - 2500 CONTINUE -C - ENDIF -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft207.f b/src/fim/FIMsrc/w3/w3ft207.f deleted file mode 100644 index 4ce069d..0000000 --- a/src/fim/FIMsrc/w3/w3ft207.f +++ /dev/null @@ -1,264 +0,0 @@ - SUBROUTINE W3FT207(ALOLA,APOLA,INTERP) -C$$$ SUBROUTINE DOCUMENTATION BLOCK *** -C -C SUBROUTINE: W3FT207 CONVERT (361,91) GRID TO (49,35) N. HEMI. GRID -C AUTHOR: JONES,R.E. ORG: W342 DATE: 93-10-19 -C -C ABSTRACT: CONVERT A NORTHERN HEMISPHERE 1.0 DEGREE LAT.,LON. 361 BY -C 91 GRID TO A POLAR STEREOGRAPHIC 49 BY 35 GRID. THE POLAR -C STEREOGRAPHIC MAP PROJECTION IS TRUE AT 60 DEG. N. , THE MESH -C LENGTH IS 95.25 KM. AND THE ORIENTION IS 150 DEG. W. -C AWIPS GRID 207 REGIONAL - ALASKA. -C -C PROGRAM HISTORY LOG: -C 93-10-19 R.E.JONES -C -C USAGE: CALL W3FT207(ALOLA,APOLA,INTERP) -C -C INPUT ARGUMENTS: ALOLA - 361*91 GRID 1.0 DEG. LAT,LON GRID N. HEMI. -C 32851 POINT GRID. 360 * 181 ONE DEGREE -C GRIB GRID 3 WAS FLIPPED, GREENWISH ADDED -C TO RIGHT SIDE AND CUT TO 361 * 91. -C INTERP - 1 LINEAR INTERPOLATION , NE.1 BIQUADRATIC -C -C INPUT FILES: NONE -C -C OUTPUT ARGUMENTS: APOLA - 49*35 GRID OF NORTHERN HEMISPHERE. -C 1715 POINT GRID IS AWIPS GRID TYPE 207 -C -C OUTPUT FILES: ERROR MESSAGE TO FORTRAN OUTPUT FILE -C -C WARNINGS: -C -C 1. W1 AND W2 ARE USED TO STORE SETS OF CONSTANTS WHICH ARE -C REUSABLE FOR REPEATED CALLS TO THE SUBROUTINE. -C -C 2. WIND COMPONENTS ARE NOT ROTATED TO THE 49*35 GRID ORIENTATION -C AFTER INTERPOLATION. YOU MAY USE W3FC08 TO DO THIS. -C -C RETURN CONDITIONS: NORMAL SUBROUTINE EXIT -C -C SUBPROGRAMS CALLED: -C UNIQUE : NONE -C -C LIBRARY: ASIN , ATAN2 -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916/128, Y-MP8/864, Y-MP EL92/256 -C -C$$$ -C - PARAMETER (NPTS=1715,II=49,JJ=35) - PARAMETER (ORIENT=150.0,IPOLE=25,JPOLE=51) - PARAMETER (XMESH=95.250) -C - REAL R2(NPTS), WLON(NPTS) - REAL XLAT(NPTS), XI(II,JJ), XJ(II,JJ) - REAL XII(NPTS), XJJ(NPTS), ANGLE(NPTS) - REAL ALOLA(361,91), APOLA(NPTS), ERAS(NPTS,4) - REAL W1(NPTS), W2(NPTS) - REAL XDELI(NPTS), XDELJ(NPTS) - REAL XI2TM(NPTS), XJ2TM(NPTS) -C - INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4) - INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS) -C - LOGICAL LIN -C - SAVE -C - EQUIVALENCE (XI(1,1),XII(1)),(XJ(1,1),XJJ(1)) -C - DATA DEGPRD/57.2957795/ - DATA EARTHR/6371.2/ - DATA INTRPO/99/ - DATA ISWT /0/ -C - LIN = .FALSE. - IF (INTERP.EQ.1) LIN = .TRUE. -C - IF (ISWT.EQ.1) GO TO 900 -C - DEG = 1.0 - GI2 = (1.86603 * EARTHR) / XMESH - GI2 = GI2 * GI2 -C -C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB05 IN LINE -C - DO 100 J = 1,JJ - XJ1 = J - JPOLE - DO 100 I = 1,II - XI(I,J) = I - IPOLE - XJ(I,J) = XJ1 - 100 CONTINUE -C - DO 200 KK = 1,NPTS - R2(KK) = XJJ(KK) * XJJ(KK) + XII(KK) * XII(KK) - XLAT(KK) = DEGPRD * - & ASIN((GI2 - R2(KK)) / (GI2 + R2(KK))) - 200 CONTINUE -C - DO 300 KK = 1,NPTS - ANGLE(KK) = DEGPRD * ATAN2(XJJ(KK),XII(KK)) - 300 CONTINUE -C - DO 400 KK = 1,NPTS - IF (ANGLE(KK).LT.0.0) ANGLE(KK) = ANGLE(KK) + 360.0 - 400 CONTINUE -C - DO 500 KK = 1,NPTS - WLON(KK) = 270.0 + ORIENT - ANGLE(KK) - 500 CONTINUE -C - DO 600 KK = 1,NPTS - IF (WLON(KK).LT.0.0) WLON(KK) = WLON(KK) + 360.0 - 600 CONTINUE -C - DO 700 KK = 1,NPTS - IF (WLON(KK).GE.360.0) WLON(KK) = WLON(KK) - 360.0 - 700 CONTINUE -C - DO 800 KK = 1,NPTS - W1(KK) = (360.0 - WLON(KK)) / DEG + 1.0 - W2(KK) = XLAT(KK) / DEG + 1.0 - 800 CONTINUE -C - ISWT = 1 - INTRPO = INTERP - GO TO 1000 -C -C AFTER THE 1ST CALL TO W3FT207 TEST INTERP, IF IT HAS -C CHANGED RECOMPUTE SOME CONSTANTS -C - 900 CONTINUE - IF (INTERP.EQ.INTRPO) GO TO 2100 - INTRPO = INTERP -C - 1000 CONTINUE - DO 1100 K = 1,NPTS - IV(K) = W1(K) - JV(K) = W2(K) - XDELI(K) = W1(K) - IV(K) - XDELJ(K) = W2(K) - JV(K) - IP1(K) = IV(K) + 1 - JY(K,3) = JV(K) + 1 - JY(K,2) = JV(K) - 1100 CONTINUE -C - IF (LIN) GO TO 1400 -C - DO 1200 K = 1,NPTS - IP2(K) = IV(K) + 2 - IM1(K) = IV(K) - 1 - JY(K,1) = JV(K) - 1 - JY(K,4) = JV(K) + 2 - XI2TM(K) = XDELI(K) * (XDELI(K) - 1.0) * .25 - XJ2TM(K) = XDELJ(K) * (XDELJ(K) - 1.0) * .25 - 1200 CONTINUE -C - DO 1300 KK = 1,NPTS - IF (IV(KK).EQ.1) THEN - IP2(KK) = 3 - IM1(KK) = 360 - ELSE IF (IV(KK).EQ.360) THEN - IP2(KK) = 2 - IM1(KK) = 359 - ENDIF - 1300 CONTINUE -C - 1400 CONTINUE -C - IF (LIN) GO TO 1700 -C - DO 1500 KK = 1,NPTS - IF (JV(KK).LT.2.OR.JV(KK).GT.89) XJ2TM(KK) = 0.0 - 1500 CONTINUE -C - DO 1600 KK = 1,NPTS - IF (IP2(KK).LT.1) IP2(KK) = 1 - IF (IM1(KK).LT.1) IM1(KK) = 1 - IF (IP2(KK).GT.361) IP2(KK) = 361 - IF (IM1(KK).GT.361) IM1(KK) = 361 - 1600 CONTINUE -C - 1700 CONTINUE - DO 1800 KK = 1,NPTS - IF (IV(KK).LT.1) IV(KK) = 1 - IF (IP1(KK).LT.1) IP1(KK) = 1 - IF (IV(KK).GT.361) IV(KK) = 361 - IF (IP1(KK).GT.361) IP1(KK) = 361 - 1800 CONTINUE -C -C LINEAR INTERPOLATION -C - DO 1900 KK = 1,NPTS - IF (JY(KK,2).LT.1) JY(KK,2) = 1 - IF (JY(KK,2).GT.91) JY(KK,2) = 91 - IF (JY(KK,3).LT.1) JY(KK,3) = 1 - IF (JY(KK,3).GT.91) JY(KK,3) = 91 - 1900 CONTINUE -C - IF (.NOT.LIN) THEN - DO 2000 KK = 1,NPTS - IF (JY(KK,1).LT.1) JY(KK,1) = 1 - IF (JY(KK,1).GT.91) JY(KK,1) = 91 - IF (JY(KK,4).LT.1) JY(KK,4) = 1 - IF (JY(KK,4).GT.91) JY(KK,4) = 91 - 2000 CONTINUE - ENDIF -C - 2100 CONTINUE - IF (LIN) THEN -C -C LINEAR INTERPOLATION -C - DO 2200 KK = 1,NPTS - ERAS(KK,2) = (ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) - ERAS(KK,3) = (ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) - 2200 CONTINUE -C - DO 2300 KK = 1,NPTS - APOLA(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) - 2300 CONTINUE -C - ELSE -C -C QUADRATIC INTERPOLATION -C - DO 2400 KK = 1,NPTS - ERAS(KK,1)=(ALOLA(IP1(KK),JY(KK,1))-ALOLA(IV(KK),JY(KK,1))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,1)) + - & ( ALOLA(IM1(KK),JY(KK,1)) - ALOLA(IV(KK),JY(KK,1)) - & - ALOLA(IP1(KK),JY(KK,1))+ALOLA(IP2(KK),JY(KK,1))) - & * XI2TM(KK) - ERAS(KK,2)=(ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) + - & ( ALOLA(IM1(KK),JY(KK,2)) - ALOLA(IV(KK),JY(KK,2)) - & - ALOLA(IP1(KK),JY(KK,2))+ALOLA(IP2(KK),JY(KK,2))) - & * XI2TM(KK) - ERAS(KK,3)=(ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) + - & ( ALOLA(IM1(KK),JY(KK,3)) - ALOLA(IV(KK),JY(KK,3)) - & - ALOLA(IP1(KK),JY(KK,3))+ALOLA(IP2(KK),JY(KK,3))) - & * XI2TM(KK) - ERAS(KK,4)=(ALOLA(IP1(KK),JY(KK,4))-ALOLA(IV(KK),JY(KK,4))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,4)) + - & ( ALOLA(IM1(KK),JY(KK,4)) - ALOLA(IV(KK),JY(KK,4)) - & - ALOLA(IP1(KK),JY(KK,4))+ALOLA(IP2(KK),JY(KK,4))) - & * XI2TM(KK) - 2400 CONTINUE -C - DO 2500 KK = 1,NPTS - APOLA(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) + (ERAS(KK,1) - ERAS(KK,2) - & - ERAS(KK,3) + ERAS(KK,4)) * XJ2TM(KK) - 2500 CONTINUE -C - ENDIF -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft208.f b/src/fim/FIMsrc/w3/w3ft208.f deleted file mode 100644 index 8cbc18e..0000000 --- a/src/fim/FIMsrc/w3/w3ft208.f +++ /dev/null @@ -1,198 +0,0 @@ - SUBROUTINE W3FT208(ALOLA,AMERC,INTERP) -C$$$ SUBROUTINE DOCUMENTATION BLOCK *** -C -C SUBROUTINE: W3FT208 CONVERT (361,91) GRID TO (29,27) MERCATOR GRID -C AUTHOR: JONES,R.E. ORG: W342 DATE: 93-10-19 -C -C ABSTRACT: CONVERT A NORTHERN HEMISPHERE 1.0 DEGREE LAT.,LON. 361 BY -C 91 GRID TO A REGIONAL - HAWAII (MERCATOR) 29*27 AWIPS 208 -C GRID. -C -C PROGRAM HISTORY LOG: -C 93-10-19 R.E.JONES -C -C USAGE: CALL W3FT208(ALOLA,AMERC,INTERP) -C -C INPUT ARGUMENTS: ALOLA - 361*91 GRID 1.0 DEG. LAT,LON GRID N. HEMI. -C 32851 POINT GRID. 360 * 181 ONE DEGREE -C GRIB GRID 3 WAS FLIPPED, GREENWISH ADDED -C TO RIGHT SIDE AND CUT TO 361 * 91. -C INTERP - 1 LINEAR INTERPOLATION , NE.1 BIQUADRATIC -C -C INPUT FILES: NONE -C -C OUTPUT ARGUMENTS: AMERC - 29*27 GRID OF NORTHERN MERCATOR -C 783 POINT GRID IS AWIPS GRID TYPE 208 -C -C OUTPUT FILES: ERROR MESSAGE TO FORTRAN OUTPUT FILE -C -C WARNINGS: -C -C 1. W1 AND W2 ARE USED TO STORE SETS OF CONSTANTS WHICH ARE -C REUSABLE FOR REPEATED CALLS TO THE SUBROUTINE. 20 OTHER ARRAY -C ARE SAVED AND REUSED ON THE NEXT CALL. -C -C RETURN CONDITIONS: NORMAL SUBROUTINE EXIT -C -C SUBPROGRAMS CALLED: -C UNIQUE : NONE -C -C LIBRARY: ASIN , ATAN2 -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256 -C -C$$$ -C - PARAMETER (NPTS=783,II=29,JJ=27) - PARAMETER (ALATIN=20.000) - PARAMETER (PI=3.1416) - PARAMETER (DX=80000.0) - PARAMETER (ALAT1=9.343) - PARAMETER (ALON1=192.685) -C - REAL WLON(NPTS), XLAT(NPTS) - REAL XI(II,JJ), XJ(II,JJ) - REAL XII(NPTS), XJJ(NPTS) - REAL ALOLA(361,91), AMERC(NPTS), ERAS(NPTS,4) - REAL W1(NPTS), W2(NPTS) - REAL XDELI(NPTS), XDELJ(NPTS) - REAL XI2TM(NPTS), XJ2TM(NPTS) -C - INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4) - INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS) -C - LOGICAL LIN -C - SAVE -C - EQUIVALENCE (XI(1,1),XII(1)),(XJ(1,1),XJJ(1)) -C -C DATA DEGPR /57.2957795/ - DATA RERTH /6.3712E+6/ - DATA INTRPO/99/ - DATA ISWT /0/ -C - DEGPR = 180.0 / PI - RADPD = PI / 180.0 - CLAIN = COS(RADPD * ALATIN) - DELLON = DX / (RERTH * CLAIN) - DJEO = (ALOG(TAN(0.5*((ALAT1+90.0)*RADPD))))/DELLON -C - LIN = .FALSE. - IF (INTERP.EQ.1) LIN = .TRUE. -C - IF (ISWT.EQ.1) GO TO 900 -C - DEG = 1.0 -C -C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB09 IN LINE -C - DO 100 J = 1,JJ - DO 100 I = 1,II - XI(I,J) = I - XJ(I,J) = J - 100 CONTINUE -C - DO 200 KK = 1,NPTS - XLAT(KK) = 2.0*ATAN(EXP(DELLON*(DJEO + XJJ(KK)-1.))) - & * DEGPR - 90.0 - 200 CONTINUE -C - DO 300 KK = 1,NPTS - WLON(KK) = (XII(KK) -1.0) * DELLON * DEGPR + ALON1 - 300 CONTINUE -C - DO 400 KK = 1,NPTS - W1(KK) = WLON(KK) + 1.0 - W2(KK) = XLAT(KK) + 1.0 - 400 CONTINUE -C - ISWT = 1 - INTRPO = INTERP - GO TO 1000 -C -C AFTER THE 1ST CALL TO W3FT208 TEST INTERP, IF IT HAS -C CHANGED RECOMPUTE SOME CONSTANTS -C - 900 CONTINUE - IF (INTERP.EQ.INTRPO) GO TO 2100 - INTRPO = INTERP -C - 1000 CONTINUE - DO 1100 K = 1,NPTS - IV(K) = W1(K) - JV(K) = W2(K) - XDELI(K) = W1(K) - IV(K) - XDELJ(K) = W2(K) - JV(K) - IP1(K) = IV(K) + 1 - JY(K,3) = JV(K) + 1 - JY(K,2) = JV(K) - 1100 CONTINUE -C - IF (.NOT.LIN) THEN - DO 1200 K = 1,NPTS - IP2(K) = IV(K) + 2 - IM1(K) = IV(K) - 1 - JY(K,1) = JV(K) - 1 - JY(K,4) = JV(K) + 2 - XI2TM(K) = XDELI(K) * (XDELI(K) - 1.0) * .25 - XJ2TM(K) = XDELJ(K) * (XDELJ(K) - 1.0) * .25 - 1200 CONTINUE - END IF -C - 2100 CONTINUE - IF (LIN) THEN -C -C LINEAR INTERPOLATION -C - DO 2200 KK = 1,NPTS - ERAS(KK,2) = (ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) - ERAS(KK,3) = (ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) - 2200 CONTINUE -C - DO 2300 KK = 1,NPTS - AMERC(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) - 2300 CONTINUE -C - ELSE -C -C BI-QUADRATIC INTERPOLATION -C - DO 2400 KK = 1,NPTS - ERAS(KK,1)=(ALOLA(IP1(KK),JY(KK,1))-ALOLA(IV(KK),JY(KK,1))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,1)) + - & ( ALOLA(IM1(KK),JY(KK,1)) - ALOLA(IV(KK),JY(KK,1)) - & - ALOLA(IP1(KK),JY(KK,1))+ALOLA(IP2(KK),JY(KK,1))) - & * XI2TM(KK) - ERAS(KK,2)=(ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) + - & ( ALOLA(IM1(KK),JY(KK,2)) - ALOLA(IV(KK),JY(KK,2)) - & - ALOLA(IP1(KK),JY(KK,2))+ALOLA(IP2(KK),JY(KK,2))) - & * XI2TM(KK) - ERAS(KK,3)=(ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) + - & ( ALOLA(IM1(KK),JY(KK,3)) - ALOLA(IV(KK),JY(KK,3)) - & - ALOLA(IP1(KK),JY(KK,3))+ALOLA(IP2(KK),JY(KK,3))) - & * XI2TM(KK) - ERAS(KK,4)=(ALOLA(IP1(KK),JY(KK,4))-ALOLA(IV(KK),JY(KK,4))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,4)) + - & ( ALOLA(IM1(KK),JY(KK,4)) - ALOLA(IV(KK),JY(KK,4)) - & - ALOLA(IP1(KK),JY(KK,4))+ALOLA(IP2(KK),JY(KK,4))) - & * XI2TM(KK) - 2400 CONTINUE -C - DO 2500 KK = 1,NPTS - AMERC(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) + (ERAS(KK,1) - ERAS(KK,2) - & - ERAS(KK,3) + ERAS(KK,4)) * XJ2TM(KK) - 2500 CONTINUE -C - ENDIF -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft209.f b/src/fim/FIMsrc/w3/w3ft209.f deleted file mode 100644 index 3ff0372..0000000 --- a/src/fim/FIMsrc/w3/w3ft209.f +++ /dev/null @@ -1,182 +0,0 @@ - SUBROUTINE W3FT209(ALOLA,ALAMB,INTERP) -C$$$ SUBROUTINE DOCUMENTATION BLOCK *** -C -C SUBROUTINE: W3FT209 CONVERT (361,91) GRID TO (101,81) LAMBERT GRID -C AUTHOR: JONES,R.E. ORG: W342 DATE: 94-05-18 -C -C ABSTRACT: CONVERT A NORTHERN HEMISPHERE 1.0 DEGREE LAT.,LON. 361 BY -C 91 GRID TO A LAMBERT CONFORMAL 101 BY 81 AWIPS GRIB 209. -C -C PROGRAM HISTORY LOG: -C 94-05-18 R.E.JONES -C -C USAGE: CALL W3FT209(ALOLA,ALAMB,INTERP) -C -C INPUT ARGUMENTS: ALOLA - 361*91 GRID 1.0 DEG. LAT,LON GRID N. HEMI. -C 32851 POINT GRID. 360 * 181 ONE DEGREE -C GRIB GRID 3 WAS FLIPPED, GREENWISH ADDED -C TO RIGHT SIDE AND CUT TO 361 * 91. -C INTERP - 1 LINEAR INTERPOLATION , NE.1 BIQUADRATIC -C -C INPUT FILES: NONE -C -C OUTPUT ARGUMENTS: ALAMB - 101*81 REGIONAL - CENTRAL US MARD -C DOUBLE RES. -C (LAMBERT CONFORMAL). 8181 POINT GRID -C IS AWIPS GRID TYPE 209 -C -C OUTPUT FILES: ERROR MESSAGE TO FORTRAN OUTPUT FILE -C -C WARNINGS: -C -C 1. W1 AND W2 ARE USED TO STORE SETS OF CONSTANTS WHICH ARE -C REUSABLE FOR REPEATED CALLS TO THE SUBROUTINE. 11 OTHER ARRAY -C ARE SAVED AND REUSED ON THE NEXT CALL. -C -C 2. WIND COMPONENTS ARE NOT ROTATED TO THE 101*81 GRID ORIENTATION -C AFTER INTERPOLATION. YOU MAY USE W3FC08 TO DO THIS. -C -C RETURN CONDITIONS: NORMAL SUBROUTINE EXIT -C -C SUBPROGRAMS CALLED: -C UNIQUE : NONE -C -C LIBRARY: W3FB12 -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL92/256 -C -C$$$ -C -C - PARAMETER (NPTS=8181,II=101,JJ=81) - PARAMETER (ALATAN=25.000) - PARAMETER (PI=3.1416) - PARAMETER (DX=40635.250) - PARAMETER (ALAT1=22.289) - PARAMETER (ELON1=242.00962) - PARAMETER (ELONV=265.000) - PARAMETER (III=361,JJJ=91) -C - REAL ALOLA(III,JJJ) - REAL ALAMB(NPTS) - REAL W1(NPTS), W2(NPTS), ERAS(NPTS,4) - REAL XDELI(NPTS), XDELJ(NPTS) - REAL XI2TM(NPTS), XJ2TM(NPTS) -C - INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4) - INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS) -C - LOGICAL LIN -C - SAVE -C - DATA ISWT /0/ - DATA INTRPO/99/ -C - LIN = .FALSE. - IF (INTERP.EQ.1) LIN = .TRUE. -C - IF (ISWT.EQ.1) GO TO 900 -c print *,'iswt = ',iswt - N = 0 - DO J = 1,JJ - DO I = 1,II - XJ = J - XI = I - CALL W3FB12(XI,XJ,ALAT1,ELON1,DX,ELONV,ALATAN,ALAT, - & ELON,IERR) - N = N + 1 - W1(N) = ELON + 1.0 - W2(N) = ALAT + 1.0 - END DO - END DO -C - ISWT = 1 - INTRPO = INTERP - GO TO 1000 -C -C AFTER THE 1ST CALL TO W3FT209 TEST INTERP, IF IT HAS -C CHANGED RECOMPUTE SOME CONSTANTS -C - 900 CONTINUE - IF (INTERP.EQ.INTRPO) GO TO 2100 - INTRPO = INTERP -C - 1000 CONTINUE - DO 1100 K = 1,NPTS - IV(K) = W1(K) - JV(K) = W2(K) - XDELI(K) = W1(K) - IV(K) - XDELJ(K) = W2(K) - JV(K) - IP1(K) = IV(K) + 1 - JY(K,3) = JV(K) + 1 - JY(K,2) = JV(K) - 1100 CONTINUE -C - IF (LIN) GO TO 2100 -C - DO 1200 K = 1,NPTS - IP2(K) = IV(K) + 2 - IM1(K) = IV(K) - 1 - JY(K,1) = JV(K) - 1 - JY(K,4) = JV(K) + 2 - XI2TM(K) = XDELI(K) * (XDELI(K) - 1.0) * .25 - XJ2TM(K) = XDELJ(K) * (XDELJ(K) - 1.0) * .25 - 1200 CONTINUE -C - 2100 CONTINUE - IF (LIN) THEN -C -C LINEAR INTERPOLATION -C - DO 2200 KK = 1,NPTS - ERAS(KK,2) = (ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) - ERAS(KK,3) = (ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) - 2200 CONTINUE -C - DO 2300 KK = 1,NPTS - ALAMB(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) - 2300 CONTINUE -C - ELSE -C -C QUADRATIC INTERPOLATION -C - DO 2400 KK = 1,NPTS - ERAS(KK,1)=(ALOLA(IP1(KK),JY(KK,1))-ALOLA(IV(KK),JY(KK,1))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,1)) + - & ( ALOLA(IM1(KK),JY(KK,1)) - ALOLA(IV(KK),JY(KK,1)) - & - ALOLA(IP1(KK),JY(KK,1))+ALOLA(IP2(KK),JY(KK,1))) - & * XI2TM(KK) - ERAS(KK,2)=(ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) + - & ( ALOLA(IM1(KK),JY(KK,2)) - ALOLA(IV(KK),JY(KK,2)) - & - ALOLA(IP1(KK),JY(KK,2))+ALOLA(IP2(KK),JY(KK,2))) - & * XI2TM(KK) - ERAS(KK,3)=(ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) + - & ( ALOLA(IM1(KK),JY(KK,3)) - ALOLA(IV(KK),JY(KK,3)) - & - ALOLA(IP1(KK),JY(KK,3))+ALOLA(IP2(KK),JY(KK,3))) - & * XI2TM(KK) - ERAS(KK,4)=(ALOLA(IP1(KK),JY(KK,4))-ALOLA(IV(KK),JY(KK,4))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,4)) + - & ( ALOLA(IM1(KK),JY(KK,4)) - ALOLA(IV(KK),JY(KK,4)) - & - ALOLA(IP1(KK),JY(KK,4))+ALOLA(IP2(KK),JY(KK,4))) - & * XI2TM(KK) - 2400 CONTINUE -C - DO 2500 KK = 1,NPTS - ALAMB(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) + (ERAS(KK,1) - ERAS(KK,2) - & - ERAS(KK,3) + ERAS(KK,4)) * XJ2TM(KK) - 2500 CONTINUE -C - ENDIF -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft21.f b/src/fim/FIMsrc/w3/w3ft21.f deleted file mode 100644 index b80182c..0000000 --- a/src/fim/FIMsrc/w3/w3ft21.f +++ /dev/null @@ -1,105 +0,0 @@ - SUBROUTINE W3FT21(FLN,GN,PLN,EPS,FL,WORK,TRIGS,L1,L2,I2) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FT21 COMPUTES 2.5 X 2.5 N. HEMI. GRID-SCALER -C AUTHOR: JONES,R.E. ORG: W342 DATE: 81-11-19 -C -C ABSTRACT: COMPUTES 2.5 X 2.5 N. HEMI. GRID OF 145 X 37 POINTS -C FROM SPECTRAL COEFFICIENTS IN A RHOMBOIDAL 30 RESOLUTION -C REPRESENTING A SCALAR FIELD. SPECIAL VERSION OF W3FT08 WHICH -C GIVES PROGRAMMER MORE CONTROL OF HOW MANY WAVES ARE SUMMED -C AND HOW MANY POINTS IN EACH WAVE. A PROGRAMMER CAN SIMULATE -C 24-MODE, 12-MODE, ETC. -C -C PROGRAM HISTORY LOG: -C 81-11-19 R.E.JONES -C 84-06-01 R.E.JONES CHANGE TO IBM VS FORTRAN -C -C USAGE: CALL W3FT21(FLN,GN,PLN,EPS,FL,WORK,TRIGS,L1,L2,I2) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C FLN ARG LIST 961 COMPLEX COEFF. -C PLN ARG LIST 992 REAL SPACE FOR LEGENDRE POLYNOMIALS -C EPS ARG LIST 992 REAL SPACE FOR -C COEFFS. USED IN COMPUTING PLN. -C FL ARG LIST 31 COMPLEX SPACE FOR FOURIER COEFF. -C WORK ARG LIST 144 REAL WORK SPACE FOR SUBR. W3FT12 -C TRIGS ARG LIST 216 PRECOMPUTED TRIG FUNCS, USED -C IN W3FT12, COMPUTED BY W3FA13 -C L1 ARG LIST STARTING WAVE NUMBER -C L2 ARG LIST ENDING WAVE NUMBER -C I2 ARG LIST MODE OF SPECTRAL COEFFICIENTS -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C GN ARG LIST (145,37) GRID VALUES. -C 5365 POINT GRID IS TYPE 29 OR 1D HEX O.N. 84 -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C AIMAG CMPLX REAL SYSLIB -C W3FA12 W3FT12 W3LIB -C -C WARNING: THIS SUBROUTINE WAS OPTIMIZED TO RUN IN A SMALL AMOUNT OF -C MEMORY, IT IS NOT OPTIMIZED FOR SPEED, 70 PERCENT OF THE TIME IS -C USED BY SUBROUTINE W3FA12 COMPUTING THE LEGENDRE POLYNOMIALS. SINCE -C THE LEGENDRE POLYNOMIALS ARE CONSTANT THEY NEED TO BE COMPUTED -C ONLY ONCE IN A PROGRAM. BY MOVING W3FA12 TO THE MAIN PROGRAM AND -C COMPUTING PLN AS A (32,31,37) ARRAY AND CHANGING THIS SUBROUTINE -C TO USE PLN AS A THREE DIMENSION ARRAY YOU CAN CUT THE RUNNING TIME -C 70 PERCENT. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916, Y-MP8/64, Y-MP EL92/256 -C -C$$$ -C - COMPLEX FL (31) - COMPLEX FLN (31,31) -C - REAL COLRA - REAL EPS (992) -C - REAL GN (145,37) - REAL PLN (32,31) - REAL TRIGS (216) - REAL WORK (144) -C - SAVE -C - DATA PI /3.14159265/ -C - DRAD = 2.5 * PI / 180.0 -C - K1 = L1 + 1 - K2 = L2 + 1 - M2 = I2 + 1 -C - DO 400 LAT = 1,37 - LATN = 38 - LAT - COLRA = (LAT-1) * DRAD - CALL W3FA12 (PLN, COLRA, 30 ,EPS) -C - DO 100 L = 1, 31 - FL(L) = (0.,0.) - 100 CONTINUE -C - DO 300 L = K1 , K2 - DO 200 I = 1 , M2 - FL(L) = FL(L) + CMPLX(PLN(I,L) * REAL(FLN(I,L)) , - & PLN(I,L) * AIMAG(FLN(I,L)) ) - 200 CONTINUE -C - 300 CONTINUE -C - CALL W3FT12(FL,WORK,GN(1,LATN),TRIGS) -C - 400 CONTINUE -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft210.f b/src/fim/FIMsrc/w3/w3ft210.f deleted file mode 100644 index 2cfdc41..0000000 --- a/src/fim/FIMsrc/w3/w3ft210.f +++ /dev/null @@ -1,197 +0,0 @@ - SUBROUTINE W3FT210(ALOLA,AMERC,INTERP) -C$$$ SUBROUTINE DOCUMENTATION BLOCK *** -C -C SUBROUTINE: W3FT210 CONVERT (361,91) GRID TO (25,25) MERCATOR GRID -C AUTHOR: JONES,R.E. ORG: W342 DATE: 93-10-19 -C -C ABSTRACT: CONVERT A NORTHERN HEMISPHERE 1.0 DEGREE LAT.,LON. 361 BY -C 91 GRID TO A REGIONAL - PUERTO RICO (MERCATOR) 25*25 AWIPS 210 -C GRID. -C -C PROGRAM HISTORY LOG: -C 93-10-19 R.E.JONES -C -C USAGE: CALL W3FT210(ALOLA,AMERC,INTERP) -C -C INPUT ARGUMENTS: ALOLA - 361*91 GRID 1.0 DEG. LAT,LON GRID N. HEMI. -C 32851 POINT GRID. 360 * 181 ONE DEGREE -C GRIB GRID 3 WAS FLIPPED, GREENWISH ADDED -C TO RIGHT SIDE AND CUT TO 361 * 91. -C INTERP - 1 LINEAR INTERPOLATION , NE.1 BIQUADRATIC -C -C INPUT FILES: NONE -C -C OUTPUT ARGUMENTS: AMERC - 25*25 GRID OF NORTHERN MERCATOR -C 625 POINT GRID IS AWIPS GRID TYPE 210 -C -C OUTPUT FILES: ERROR MESSAGE TO FORTRAN OUTPUT FILE -C -C WARNINGS: -C -C 1. W1 AND W2 ARE USED TO STORE SETS OF CONSTANTS WHICH ARE -C REUSABLE FOR REPEATED CALLS TO THE SUBROUTINE. 20 OTHER ARRAY -C ARE SAVED AND REUSED ON THE NEXT CALL. -C -C RETURN CONDITIONS: NORMAL SUBROUTINE EXIT -C -C SUBPROGRAMS CALLED: -C UNIQUE : NONE -C -C LIBRARY: ASIN , ATAN2 -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256 -C -C$$$ -C - PARAMETER (NPTS=625,II=25,JJ=25) - PARAMETER (ALATIN=20.000) - PARAMETER (PI=3.1416) - PARAMETER (DX=80000.0) - PARAMETER (ALAT1=9.000) - PARAMETER (ALON1=283.000) -C - REAL R2(NPTS), WLON(NPTS) - REAL XLAT(NPTS), XI(II,JJ), XJ(II,JJ) - REAL XII(NPTS), XJJ(NPTS), ANGLE(NPTS) - REAL ALOLA(361,91), AMERC(NPTS), ERAS(NPTS,4) - REAL W1(NPTS), W2(NPTS) - REAL XDELI(NPTS), XDELJ(NPTS) - REAL XI2TM(NPTS), XJ2TM(NPTS) -C - INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4) - INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS) -C - LOGICAL LIN -C - SAVE -C - EQUIVALENCE (XI(1,1),XII(1)),(XJ(1,1),XJJ(1)) -C -C DATA DEGPR /57.2957795/ - DATA RERTH /6.3712E+6/ - DATA INTRPO/99/ - DATA ISWT /0/ -C - DEGPR = 180.0 / PI - RADPD = PI / 180.0 - CLAIN = COS(RADPD * ALATIN) - DELLON = DX / (RERTH * CLAIN) - DJEO = (ALOG(TAN(0.5*((ALAT1+90.0)*RADPD))))/DELLON - LIN = .FALSE. - IF (INTERP.EQ.1) LIN = .TRUE. -C - IF (ISWT.EQ.1) GO TO 900 -C - DEG = 1.0 -C -C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB09 IN LINE -C - DO 100 J = 1,JJ - DO 100 I = 1,II - XI(I,J) = I - XJ(I,J) = J - 100 CONTINUE -C - DO 200 KK = 1,NPTS - XLAT(KK) = 2.0*ATAN(EXP(DELLON*(DJEO + XJJ(KK)-1.))) - & * DEGPR - 90.0 - 200 CONTINUE -C - DO 300 KK = 1,NPTS - WLON(KK) = (XII(KK) -1.0) * DELLON * DEGPR + ALON1 - 300 CONTINUE -C - DO 400 KK = 1,NPTS - W1(KK) = WLON(KK) + 1.0 - W2(KK) = XLAT(KK) + 1.0 - 400 CONTINUE -C - ISWT = 1 - INTRPO = INTERP - GO TO 1000 -C -C AFTER THE 1ST CALL TO W3FT210 TEST INTERP, IF IT HAS -C CHANGED RECOMPUTE SOME CONSTANTS -C - 900 CONTINUE - IF (INTERP.EQ.INTRPO) GO TO 2100 - INTRPO = INTERP -C - 1000 CONTINUE - DO 1100 K = 1,NPTS - IV(K) = W1(K) - JV(K) = W2(K) - XDELI(K) = W1(K) - IV(K) - XDELJ(K) = W2(K) - JV(K) - IP1(K) = IV(K) + 1 - JY(K,3) = JV(K) + 1 - JY(K,2) = JV(K) - 1100 CONTINUE -C - IF (.NOT.LIN) THEN - DO 1200 K = 1,NPTS - IP2(K) = IV(K) + 2 - IM1(K) = IV(K) - 1 - JY(K,1) = JV(K) - 1 - JY(K,4) = JV(K) + 2 - XI2TM(K) = XDELI(K) * (XDELI(K) - 1.0) * .25 - XJ2TM(K) = XDELJ(K) * (XDELJ(K) - 1.0) * .25 - 1200 CONTINUE - END IF -C - 2100 CONTINUE - IF (LIN) THEN -C -C LINEAR INTERPOLATION -C - DO 2200 KK = 1,NPTS - ERAS(KK,2) = (ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) - ERAS(KK,3) = (ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) - 2200 CONTINUE -C - DO 2300 KK = 1,NPTS - AMERC(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) - 2300 CONTINUE -C - ELSE -C -C QUADRATIC INTERPOLATION -C - DO 2400 KK = 1,NPTS - ERAS(KK,1)=(ALOLA(IP1(KK),JY(KK,1))-ALOLA(IV(KK),JY(KK,1))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,1)) + - & ( ALOLA(IM1(KK),JY(KK,1)) - ALOLA(IV(KK),JY(KK,1)) - & - ALOLA(IP1(KK),JY(KK,1))+ALOLA(IP2(KK),JY(KK,1))) - & * XI2TM(KK) - ERAS(KK,2)=(ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) + - & ( ALOLA(IM1(KK),JY(KK,2)) - ALOLA(IV(KK),JY(KK,2)) - & - ALOLA(IP1(KK),JY(KK,2))+ALOLA(IP2(KK),JY(KK,2))) - & * XI2TM(KK) - ERAS(KK,3)=(ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) + - & ( ALOLA(IM1(KK),JY(KK,3)) - ALOLA(IV(KK),JY(KK,3)) - & - ALOLA(IP1(KK),JY(KK,3))+ALOLA(IP2(KK),JY(KK,3))) - & * XI2TM(KK) - ERAS(KK,4)=(ALOLA(IP1(KK),JY(KK,4))-ALOLA(IV(KK),JY(KK,4))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,4)) + - & ( ALOLA(IM1(KK),JY(KK,4)) - ALOLA(IV(KK),JY(KK,4)) - & - ALOLA(IP1(KK),JY(KK,4))+ALOLA(IP2(KK),JY(KK,4))) - & * XI2TM(KK) - 2400 CONTINUE -C - DO 2500 KK = 1,NPTS - AMERC(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) + (ERAS(KK,1) - ERAS(KK,2) - & - ERAS(KK,3) + ERAS(KK,4)) * XJ2TM(KK) - 2500 CONTINUE -C - ENDIF -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft211.f b/src/fim/FIMsrc/w3/w3ft211.f deleted file mode 100644 index b21426c..0000000 --- a/src/fim/FIMsrc/w3/w3ft211.f +++ /dev/null @@ -1,181 +0,0 @@ - SUBROUTINE W3FT211(ALOLA,ALAMB,INTERP) -C$$$ SUBROUTINE DOCUMENTATION BLOCK *** -C -C SUBROUTINE: W3FT211 CONVERT (361,91) GRID TO (93,65) LAMBERT GRID -C AUTHOR: JONES,R.E. ORG: W342 DATE: 94-05-18 -C -C ABSTRACT: CONVERT A NORTHERN HEMISPHERE 1.0 DEGREE LAT.,LON. 361 BY -C 91 GRID TO A LAMBERT CONFORMAL 93 BY 65 AWIPS GRIB 211. -C -C PROGRAM HISTORY LOG: -C 94-05-18 R.E.JONES -C -C USAGE: CALL W3FT211(ALOLA,ALAMB,INTERP) -C -C INPUT ARGUMENTS: ALOLA - 361*91 GRID 1.0 DEG. LAT,LON GRID N. HEMI. -C 32851 POINT GRID. 360 * 181 ONE DEGREE -C GRIB GRID 3 WAS FLIPPED, GREENWISH ADDED -C TO RIGHT SIDE AND CUT TO 361 * 91. -C INTERP - 1 LINEAR INTERPOLATION , NE.1 BIQUADRATIC -C -C INPUT FILES: NONE -C -C OUTPUT ARGUMENTS: ALAMB - 93*65 REGIONAL - CONUS -C (LAMBERT CONFORMAL). 6045 POINT GRID -C IS AWIPS GRID TYPE 211 -C -C OUTPUT FILES: ERROR MESSAGE TO FORTRAN OUTPUT FILE -C -C WARNINGS: -C -C 1. W1 AND W2 ARE USED TO STORE SETS OF CONSTANTS WHICH ARE -C REUSABLE FOR REPEATED CALLS TO THE SUBROUTINE. 11 OTHER ARRAY -C ARE SAVED AND REUSED ON THE NEXT CALL. -C -C 2. WIND COMPONENTS ARE NOT ROTATED TO THE 93*65 GRID ORIENTATION -C AFTER INTERPOLATION. YOU MAY USE W3FC08 TO DO THIS. -C -C RETURN CONDITIONS: NORMAL SUBROUTINE EXIT -C -C SUBPROGRAMS CALLED: -C UNIQUE : NONE -C -C LIBRARY: W3FB12 -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256 -C -C$$$ -C -C - PARAMETER (NPTS=6045,II=93,JJ=65) - PARAMETER (ALATAN=25.000) - PARAMETER (PI=3.1416) - PARAMETER (DX=81270.500) - PARAMETER (ALAT1=12.190) - PARAMETER (ELON1=226.541) - PARAMETER (ELONV=265.000) - PARAMETER (III=361,JJJ=91) -C - REAL ALOLA(III,JJJ) - REAL ALAMB(NPTS) - REAL W1(NPTS), W2(NPTS), ERAS(NPTS,4) - REAL XDELI(NPTS), XDELJ(NPTS) - REAL XI2TM(NPTS), XJ2TM(NPTS) -C - INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4) - INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS) -C - LOGICAL LIN -C - SAVE -C - DATA ISWT /0/ - DATA INTRPO/99/ -C - LIN = .FALSE. - IF (INTERP.EQ.1) LIN = .TRUE. -C - IF (ISWT.EQ.1) GO TO 900 -c print *,'iswt = ',iswt - N = 0 - DO J = 1,JJ - DO I = 1,II - XJ = J - XI = I - CALL W3FB12(XI,XJ,ALAT1,ELON1,DX,ELONV,ALATAN,ALAT, - & ELON,IERR) - N = N + 1 - W1(N) = ELON + 1.0 - W2(N) = ALAT + 1.0 - END DO - END DO -C - ISWT = 1 - INTRPO = INTERP - GO TO 1000 -C -C AFTER THE 1ST CALL TO W3FT211 TEST INTERP, IF IT HAS -C CHANGED RECOMPUTE SOME CONSTANTS -C - 900 CONTINUE - IF (INTERP.EQ.INTRPO) GO TO 2100 - INTRPO = INTERP -C - 1000 CONTINUE - DO 1100 K = 1,NPTS - IV(K) = W1(K) - JV(K) = W2(K) - XDELI(K) = W1(K) - IV(K) - XDELJ(K) = W2(K) - JV(K) - IP1(K) = IV(K) + 1 - JY(K,3) = JV(K) + 1 - JY(K,2) = JV(K) - 1100 CONTINUE -C - IF (LIN) GO TO 2100 -C - DO 1200 K = 1,NPTS - IP2(K) = IV(K) + 2 - IM1(K) = IV(K) - 1 - JY(K,1) = JV(K) - 1 - JY(K,4) = JV(K) + 2 - XI2TM(K) = XDELI(K) * (XDELI(K) - 1.0) * .25 - XJ2TM(K) = XDELJ(K) * (XDELJ(K) - 1.0) * .25 - 1200 CONTINUE -C - 2100 CONTINUE - IF (LIN) THEN -C -C LINEAR INTERPOLATION -C - DO 2200 KK = 1,NPTS - ERAS(KK,2) = (ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) - ERAS(KK,3) = (ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) - 2200 CONTINUE -C - DO 2300 KK = 1,NPTS - ALAMB(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) - 2300 CONTINUE -C - ELSE -C -C QUADRATIC INTERPOLATION -C - DO 2400 KK = 1,NPTS - ERAS(KK,1)=(ALOLA(IP1(KK),JY(KK,1))-ALOLA(IV(KK),JY(KK,1))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,1)) + - & ( ALOLA(IM1(KK),JY(KK,1)) - ALOLA(IV(KK),JY(KK,1)) - & - ALOLA(IP1(KK),JY(KK,1))+ALOLA(IP2(KK),JY(KK,1))) - & * XI2TM(KK) - ERAS(KK,2)=(ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) + - & ( ALOLA(IM1(KK),JY(KK,2)) - ALOLA(IV(KK),JY(KK,2)) - & - ALOLA(IP1(KK),JY(KK,2))+ALOLA(IP2(KK),JY(KK,2))) - & * XI2TM(KK) - ERAS(KK,3)=(ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) + - & ( ALOLA(IM1(KK),JY(KK,3)) - ALOLA(IV(KK),JY(KK,3)) - & - ALOLA(IP1(KK),JY(KK,3))+ALOLA(IP2(KK),JY(KK,3))) - & * XI2TM(KK) - ERAS(KK,4)=(ALOLA(IP1(KK),JY(KK,4))-ALOLA(IV(KK),JY(KK,4))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,4)) + - & ( ALOLA(IM1(KK),JY(KK,4)) - ALOLA(IV(KK),JY(KK,4)) - & - ALOLA(IP1(KK),JY(KK,4))+ALOLA(IP2(KK),JY(KK,4))) - & * XI2TM(KK) - 2400 CONTINUE -C - DO 2500 KK = 1,NPTS - ALAMB(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) + (ERAS(KK,1) - ERAS(KK,2) - & - ERAS(KK,3) + ERAS(KK,4)) * XJ2TM(KK) - 2500 CONTINUE -C - ENDIF -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft212.f b/src/fim/FIMsrc/w3/w3ft212.f deleted file mode 100644 index 497e8a4..0000000 --- a/src/fim/FIMsrc/w3/w3ft212.f +++ /dev/null @@ -1,182 +0,0 @@ - SUBROUTINE W3FT212(ALOLA,ALAMB,INTERP) -C$$$ SUBROUTINE DOCUMENTATION BLOCK *** -C -C SUBROUTINE: W3FT212 CONVERT (361,91) GRID TO (185,129) LAMBERT GRID -C AUTHOR: JONES,R.E. ORG: W342 DATE: 94-05-18 -C -C ABSTRACT: CONVERT A NORTHERN HEMISPHERE 1.0 DEGREE LAT.,LON. 361 BY -C 91 GRID TO A LAMBERT CONFORMAL 185 BY 129 AWIPS GRIB 212. -C -C PROGRAM HISTORY LOG: -C 94-05-18 R.E.JONES -C -C USAGE: CALL W3FT212(ALOLA,ALAMB,INTERP) -C -C INPUT ARGUMENTS: ALOLA - 361*91 GRID 1.0 DEG. LAT,LON GRID N. HEMI. -C 32851 POINT GRID. 360 * 181 ONE DEGREE -C GRIB GRID 3 WAS FLIPPED, GREENWISH ADDED -C TO RIGHT SIDE AND CUT TO 361 * 91. -C INTERP - 1 LINEAR INTERPOLATION , NE.1 BIQUADRATIC -C -C INPUT FILES: NONE -C -C OUTPUT ARGUMENTS: ALAMB - 185*129 REGIONAL - CONUS -C DOUBLE RESOLUTION -C (LAMBERT CONFORMAL). 23865 POINT GRID -C IS AWIPS GRID TYPE 212 -C -C OUTPUT FILES: ERROR MESSAGE TO FORTRAN OUTPUT FILE -C -C WARNINGS: -C -C 1. W1 AND W2 ARE USED TO STORE SETS OF CONSTANTS WHICH ARE -C REUSABLE FOR REPEATED CALLS TO THE SUBROUTINE. 11 OTHER ARRAY -C ARE SAVED AND REUSED ON THE NEXT CALL. -C -C 2. WIND COMPONENTS ARE NOT ROTATED TO THE 185*129 GRID ORIENTATION -C AFTER INTERPOLATION. YOU MAY USE W3FC08 TO DO THIS. -C -C RETURN CONDITIONS: NORMAL SUBROUTINE EXIT -C -C SUBPROGRAMS CALLED: -C UNIQUE : NONE -C -C LIBRARY: W3FB12 -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256 -C -C$$$ -C -C - PARAMETER (NPTS=23865,II=185,JJ=129) - PARAMETER (ALATAN=25.000) - PARAMETER (PI=3.1416) - PARAMETER (DX=40635.250) - PARAMETER (ALAT1=12.190) - PARAMETER (ELON1=226.541) - PARAMETER (ELONV=265.000) - PARAMETER (III=361,JJJ=91) -C - REAL ALOLA(III,JJJ) - REAL ALAMB(NPTS) - REAL W1(NPTS), W2(NPTS), ERAS(NPTS,4) - REAL XDELI(NPTS), XDELJ(NPTS) - REAL XI2TM(NPTS), XJ2TM(NPTS) -C - INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4) - INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS) -C - LOGICAL LIN -C - SAVE -C - DATA ISWT /0/ - DATA INTRPO/99/ -C - LIN = .FALSE. - IF (INTERP.EQ.1) LIN = .TRUE. -C - IF (ISWT.EQ.1) GO TO 900 -c print *,'iswt = ',iswt - N = 0 - DO J = 1,JJ - DO I = 1,II - XJ = J - XI = I - CALL W3FB12(XI,XJ,ALAT1,ELON1,DX,ELONV,ALATAN,ALAT, - & ELON,IERR) - N = N + 1 - W1(N) = ELON + 1.0 - W2(N) = ALAT + 1.0 - END DO - END DO -C - ISWT = 1 - INTRPO = INTERP - GO TO 1000 -C -C AFTER THE 1ST CALL TO W3FT212 TEST INTERP, IF IT HAS -C CHANGED RECOMPUTE SOME CONSTANTS -C - 900 CONTINUE - IF (INTERP.EQ.INTRPO) GO TO 2100 - INTRPO = INTERP -C - 1000 CONTINUE - DO 1100 K = 1,NPTS - IV(K) = W1(K) - JV(K) = W2(K) - XDELI(K) = W1(K) - IV(K) - XDELJ(K) = W2(K) - JV(K) - IP1(K) = IV(K) + 1 - JY(K,3) = JV(K) + 1 - JY(K,2) = JV(K) - 1100 CONTINUE -C - IF (LIN) GO TO 2100 -C - DO 1200 K = 1,NPTS - IP2(K) = IV(K) + 2 - IM1(K) = IV(K) - 1 - JY(K,1) = JV(K) - 1 - JY(K,4) = JV(K) + 2 - XI2TM(K) = XDELI(K) * (XDELI(K) - 1.0) * .25 - XJ2TM(K) = XDELJ(K) * (XDELJ(K) - 1.0) * .25 - 1200 CONTINUE -C - 2100 CONTINUE - IF (LIN) THEN -C -C LINEAR INTERPOLATION -C - DO 2200 KK = 1,NPTS - ERAS(KK,2) = (ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) - ERAS(KK,3) = (ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) - 2200 CONTINUE -C - DO 2300 KK = 1,NPTS - ALAMB(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) - 2300 CONTINUE -C - ELSE -C -C QUADRATIC INTERPOLATION -C - DO 2400 KK = 1,NPTS - ERAS(KK,1)=(ALOLA(IP1(KK),JY(KK,1))-ALOLA(IV(KK),JY(KK,1))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,1)) + - & ( ALOLA(IM1(KK),JY(KK,1)) - ALOLA(IV(KK),JY(KK,1)) - & - ALOLA(IP1(KK),JY(KK,1))+ALOLA(IP2(KK),JY(KK,1))) - & * XI2TM(KK) - ERAS(KK,2)=(ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) + - & ( ALOLA(IM1(KK),JY(KK,2)) - ALOLA(IV(KK),JY(KK,2)) - & - ALOLA(IP1(KK),JY(KK,2))+ALOLA(IP2(KK),JY(KK,2))) - & * XI2TM(KK) - ERAS(KK,3)=(ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) + - & ( ALOLA(IM1(KK),JY(KK,3)) - ALOLA(IV(KK),JY(KK,3)) - & - ALOLA(IP1(KK),JY(KK,3))+ALOLA(IP2(KK),JY(KK,3))) - & * XI2TM(KK) - ERAS(KK,4)=(ALOLA(IP1(KK),JY(KK,4))-ALOLA(IV(KK),JY(KK,4))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,4)) + - & ( ALOLA(IM1(KK),JY(KK,4)) - ALOLA(IV(KK),JY(KK,4)) - & - ALOLA(IP1(KK),JY(KK,4))+ALOLA(IP2(KK),JY(KK,4))) - & * XI2TM(KK) - 2400 CONTINUE -C - DO 2500 KK = 1,NPTS - ALAMB(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) + (ERAS(KK,1) - ERAS(KK,2) - & - ERAS(KK,3) + ERAS(KK,4)) * XJ2TM(KK) - 2500 CONTINUE -C - ENDIF -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft213.f b/src/fim/FIMsrc/w3/w3ft213.f deleted file mode 100644 index 06bdf62..0000000 --- a/src/fim/FIMsrc/w3/w3ft213.f +++ /dev/null @@ -1,264 +0,0 @@ - SUBROUTINE W3FT213(ALOLA,APOLA,INTERP) -C$$$ SUBROUTINE DOCUMENTATION BLOCK *** -C -C SUBROUTINE: W3FT48V CONVERT (361,91) GRID TO (129,85) N. HEMI. GRID -C AUTHOR: JONES,R.E. ORG: W342 DATE: 93-10-23 -C -C ABSTRACT: CONVERT A NORTHERN HEMISPHERE 1.0 DEGREE LAT.,LON. 361 BY -C 91 GRID TO A POLAR STEREOGRAPHIC 129 BY 85 GRID. THE POLAR -C STEREOGRAPHIC MAP PROJECTION IS TRUE AT 60 DEG. N. , THE MESH -C LENGTH IS 95.25 KM. AND THE ORIENTION IS 105 DEG. W. -C AWIPS GRID 213 NATIONAL - CONUS - DOUBLE RESOLUTION -C -C PROGRAM HISTORY LOG: -C 93-10-23 R.E.JONES -C -C USAGE: CALL W3FT213(ALOLA,APOLA,INTERP) -C -C INPUT ARGUMENTS: ALOLA - 361*91 GRID 1.0 DEG. LAT,LON GRID N. HEMI. -C 32851 POINT GRID. 360 * 181 ONE DEGREE -C GRIB GRID 3 WAS FLIPPED, GREENWISH ADDED -C TO RIGHT SIDE AND CUT TO 361 * 91. -C INTERP - 1 LINEAR INTERPOLATION , NE.1 BIQUADRATIC -C -C INPUT FILES: NONE -C -C OUTPUT ARGUMENTS: APOLA - 129*85 GRID OF NORTHERN HEMISPHERE. -C 10965 POINT GRID IS AWIPS GRID TYPE 213 -C -C OUTPUT FILES: ERROR MESSAGE TO FORTRAN OUTPUT FILE -C -C WARNINGS: -C -C 1. W1 AND W2 ARE USED TO STORE SETS OF CONSTANTS WHICH ARE -C REUSABLE FOR REPEATED CALLS TO THE SUBROUTINE. -C -C 2. WIND COMPONENTS ARE NOT ROTATED TO THE 129*85 GRID ORIENTATION -C AFTER INTERPOLATION. YOU MAY USE W3FC08 TO DO THIS. -C -C RETURN CONDITIONS: NORMAL SUBROUTINE EXIT -C -C SUBPROGRAMS CALLED: -C UNIQUE : NONE -C -C LIBRARY: ASIN , ATAN2 -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256 -C -C$$$ -C - PARAMETER (NPTS=10965,II=129,JJ=85) - PARAMETER (ORIENT=105.0,IPOLE=65,JPOLE=89) - PARAMETER (XMESH=95.250) -C - REAL R2(NPTS), WLON(NPTS) - REAL XLAT(NPTS), XI(II,JJ), XJ(II,JJ) - REAL XII(NPTS), XJJ(NPTS), ANGLE(NPTS) - REAL ALOLA(361,91), APOLA(NPTS), ERAS(NPTS,4) - REAL W1(NPTS), W2(NPTS) - REAL XDELI(NPTS), XDELJ(NPTS) - REAL XI2TM(NPTS), XJ2TM(NPTS) -C - INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4) - INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS) -C - LOGICAL LIN -C - SAVE -C - EQUIVALENCE (XI(1,1),XII(1)),(XJ(1,1),XJJ(1)) -C - DATA DEGPRD/57.2957795/ - DATA EARTHR/6371.2/ - DATA INTRPO/99/ - DATA ISWT /0/ -C - LIN = .FALSE. - IF (INTERP.EQ.1) LIN = .TRUE. -C - IF (ISWT.EQ.1) GO TO 900 -C - DEG = 1.0 - GI2 = (1.86603 * EARTHR) / XMESH - GI2 = GI2 * GI2 -C -C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB05 IN LINE -C - DO 100 J = 1,JJ - XJ1 = J - JPOLE - DO 100 I = 1,II - XI(I,J) = I - IPOLE - XJ(I,J) = XJ1 - 100 CONTINUE -C - DO 200 KK = 1,NPTS - R2(KK) = XJJ(KK) * XJJ(KK) + XII(KK) * XII(KK) - XLAT(KK) = DEGPRD * - & ASIN((GI2 - R2(KK)) / (GI2 + R2(KK))) - 200 CONTINUE -C - DO 300 KK = 1,NPTS - ANGLE(KK) = DEGPRD * ATAN2(XJJ(KK),XII(KK)) - 300 CONTINUE -C - DO 400 KK = 1,NPTS - IF (ANGLE(KK).LT.0.0) ANGLE(KK) = ANGLE(KK) + 360.0 - 400 CONTINUE -C - DO 500 KK = 1,NPTS - WLON(KK) = 270.0 + ORIENT - ANGLE(KK) - 500 CONTINUE -C - DO 600 KK = 1,NPTS - IF (WLON(KK).LT.0.0) WLON(KK) = WLON(KK) + 360.0 - 600 CONTINUE -C - DO 700 KK = 1,NPTS - IF (WLON(KK).GE.360.0) WLON(KK) = WLON(KK) - 360.0 - 700 CONTINUE -C - DO 800 KK = 1,NPTS - W1(KK) = (360.0 - WLON(KK)) / DEG + 1.0 - W2(KK) = XLAT(KK) / DEG + 1.0 - 800 CONTINUE -C - ISWT = 1 - INTRPO = INTERP - GO TO 1000 -C -C AFTER THE 1ST CALL TO W3FT213 TEST INTERP, IF IT HAS -C CHANGED RECOMPUTE SOME CONSTANTS -C - 900 CONTINUE - IF (INTERP.EQ.INTRPO) GO TO 2100 - INTRPO = INTERP -C - 1000 CONTINUE - DO 1100 K = 1,NPTS - IV(K) = W1(K) - JV(K) = W2(K) - XDELI(K) = W1(K) - IV(K) - XDELJ(K) = W2(K) - JV(K) - IP1(K) = IV(K) + 1 - JY(K,3) = JV(K) + 1 - JY(K,2) = JV(K) - 1100 CONTINUE -C - IF (LIN) GO TO 1400 -C - DO 1200 K = 1,NPTS - IP2(K) = IV(K) + 2 - IM1(K) = IV(K) - 1 - JY(K,1) = JV(K) - 1 - JY(K,4) = JV(K) + 2 - XI2TM(K) = XDELI(K) * (XDELI(K) - 1.0) * .25 - XJ2TM(K) = XDELJ(K) * (XDELJ(K) - 1.0) * .25 - 1200 CONTINUE -C - DO 1300 KK = 1,NPTS - IF (IV(KK).EQ.1) THEN - IP2(KK) = 3 - IM1(KK) = 360 - ELSE IF (IV(KK).EQ.360) THEN - IP2(KK) = 2 - IM1(KK) = 359 - ENDIF - 1300 CONTINUE -C - 1400 CONTINUE -C - IF (LIN) GO TO 1700 -C - DO 1500 KK = 1,NPTS - IF (JV(KK).LT.2.OR.JV(KK).GT.89) XJ2TM(KK) = 0.0 - 1500 CONTINUE -C - DO 1600 KK = 1,NPTS - IF (IP2(KK).LT.1) IP2(KK) = 1 - IF (IM1(KK).LT.1) IM1(KK) = 1 - IF (IP2(KK).GT.361) IP2(KK) = 361 - IF (IM1(KK).GT.361) IM1(KK) = 361 - 1600 CONTINUE -C - 1700 CONTINUE - DO 1800 KK = 1,NPTS - IF (IV(KK).LT.1) IV(KK) = 1 - IF (IP1(KK).LT.1) IP1(KK) = 1 - IF (IV(KK).GT.361) IV(KK) = 361 - IF (IP1(KK).GT.361) IP1(KK) = 361 - 1800 CONTINUE -C -C LINEAR INTERPOLATION -C - DO 1900 KK = 1,NPTS - IF (JY(KK,2).LT.1) JY(KK,2) = 1 - IF (JY(KK,2).GT.91) JY(KK,2) = 91 - IF (JY(KK,3).LT.1) JY(KK,3) = 1 - IF (JY(KK,3).GT.91) JY(KK,3) = 91 - 1900 CONTINUE -C - IF (.NOT.LIN) THEN - DO 2000 KK = 1,NPTS - IF (JY(KK,1).LT.1) JY(KK,1) = 1 - IF (JY(KK,1).GT.91) JY(KK,1) = 91 - IF (JY(KK,4).LT.1) JY(KK,4) = 1 - IF (JY(KK,4).GT.91) JY(KK,4) = 91 - 2000 CONTINUE - ENDIF -C - 2100 CONTINUE - IF (LIN) THEN -C -C LINEAR INTERPOLATION -C - DO 2200 KK = 1,NPTS - ERAS(KK,2) = (ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) - ERAS(KK,3) = (ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) - 2200 CONTINUE -C - DO 2300 KK = 1,NPTS - APOLA(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) - 2300 CONTINUE -C - ELSE -C -C QUADRATIC INTERPOLATION -C - DO 2400 KK = 1,NPTS - ERAS(KK,1)=(ALOLA(IP1(KK),JY(KK,1))-ALOLA(IV(KK),JY(KK,1))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,1)) + - & ( ALOLA(IM1(KK),JY(KK,1)) - ALOLA(IV(KK),JY(KK,1)) - & - ALOLA(IP1(KK),JY(KK,1))+ALOLA(IP2(KK),JY(KK,1))) - & * XI2TM(KK) - ERAS(KK,2)=(ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) + - & ( ALOLA(IM1(KK),JY(KK,2)) - ALOLA(IV(KK),JY(KK,2)) - & - ALOLA(IP1(KK),JY(KK,2))+ALOLA(IP2(KK),JY(KK,2))) - & * XI2TM(KK) - ERAS(KK,3)=(ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) + - & ( ALOLA(IM1(KK),JY(KK,3)) - ALOLA(IV(KK),JY(KK,3)) - & - ALOLA(IP1(KK),JY(KK,3))+ALOLA(IP2(KK),JY(KK,3))) - & * XI2TM(KK) - ERAS(KK,4)=(ALOLA(IP1(KK),JY(KK,4))-ALOLA(IV(KK),JY(KK,4))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,4)) + - & ( ALOLA(IM1(KK),JY(KK,4)) - ALOLA(IV(KK),JY(KK,4)) - & - ALOLA(IP1(KK),JY(KK,4))+ALOLA(IP2(KK),JY(KK,4))) - & * XI2TM(KK) - 2400 CONTINUE -C - DO 2500 KK = 1,NPTS - APOLA(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) + (ERAS(KK,1) - ERAS(KK,2) - & - ERAS(KK,3) + ERAS(KK,4)) * XJ2TM(KK) - 2500 CONTINUE -C - ENDIF -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft214.f b/src/fim/FIMsrc/w3/w3ft214.f deleted file mode 100644 index ec467bd..0000000 --- a/src/fim/FIMsrc/w3/w3ft214.f +++ /dev/null @@ -1,264 +0,0 @@ - SUBROUTINE W3FT214(ALOLA,APOLA,INTERP) -C$$$ SUBROUTINE DOCUMENTATION BLOCK *** -C -C SUBROUTINE: W3FT214 CONVERT (361,91) GRID TO (97,69) N. HEMI. GRID -C AUTHOR: JONES,R.E. ORG: W342 DATE: 93-10-19 -C -C ABSTRACT: CONVERT A NORTHERN HEMISPHERE 1.0 DEGREE LAT.,LON. 361 BY -C 91 GRID TO A POLAR STEREOGRAPHIC 97 BY 69 GRID. THE POLAR -C STEREOGRAPHIC MAP PROJECTION IS TRUE AT 60 DEG. N. , THE MESH -C LENGTH IS 47.625 KM. AND THE ORIENTION IS 150 DEG. W. -C AWIPS GRID 214 REGIONAL - ALASKA - DOUBLE RESOLUTION -C -C PROGRAM HISTORY LOG: -C 93-10-19 R.E.JONES -C -C USAGE: CALL W3FT214(ALOLA,APOLA,INTERP) -C -C INPUT ARGUMENTS: ALOLA - 361*91 GRID 1.0 DEG. LAT,LON GRID N. HEMI. -C 32851 POINT GRID. 360 * 181 ONE DEGREE -C GRIB GRID 3 WAS FLIPPED, GREENWISH ADDED -C TO RIGHT SIDE AND CUT TO 361 * 91. -C INTERP - 1 LINEAR INTERPOLATION , NE.1 BIQUADRATIC -C -C INPUT FILES: NONE -C -C OUTPUT ARGUMENTS: APOLA - 97*69 GRID OF NORTHERN HEMISPHERE. -C 6693 POINT GRID IS AWIPS GRID TYPE 214 -C -C OUTPUT FILES: ERROR MESSAGE TO FORTRAN OUTPUT FILE -C -C WARNINGS: -C -C 1. W1 AND W2 ARE USED TO STORE SETS OF CONSTANTS WHICH ARE -C REUSABLE FOR REPEATED CALLS TO THE SUBROUTINE. -C -C 2. WIND COMPONENTS ARE NOT ROTATED TO THE 97*69 GRID ORIENTATION -C AFTER INTERPOLATION. YOU MAY USE W3FC08 TO DO THIS. -C -C RETURN CONDITIONS: NORMAL SUBROUTINE EXIT -C -C SUBPROGRAMS CALLED: -C UNIQUE : NONE -C -C LIBRARY: ASIN , ATAN2 -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916/128, Y-MP8/864, Y-MP EL92/256 -C -C$$$ -C - PARAMETER (NPTS=6693,II=97,JJ=69) - PARAMETER (ORIENT=150.0,IPOLE=49,JPOLE=101) - PARAMETER (XMESH=47.625) -C - REAL R2(NPTS), WLON(NPTS) - REAL XLAT(NPTS), XI(II,JJ), XJ(II,JJ) - REAL XII(NPTS), XJJ(NPTS), ANGLE(NPTS) - REAL ALOLA(361,91), APOLA(NPTS), ERAS(NPTS,4) - REAL W1(NPTS), W2(NPTS) - REAL XDELI(NPTS), XDELJ(NPTS) - REAL XI2TM(NPTS), XJ2TM(NPTS) -C - INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4) - INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS) -C - LOGICAL LIN -C - SAVE -C - EQUIVALENCE (XI(1,1),XII(1)),(XJ(1,1),XJJ(1)) -C - DATA DEGPRD/57.2957795/ - DATA EARTHR/6371.2/ - DATA INTRPO/99/ - DATA ISWT /0/ -C - LIN = .FALSE. - IF (INTERP.EQ.1) LIN = .TRUE. -C - IF (ISWT.EQ.1) GO TO 900 -C - DEG = 1.0 - GI2 = (1.86603 * EARTHR) / XMESH - GI2 = GI2 * GI2 -C -C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB05 IN LINE -C - DO 100 J = 1,JJ - XJ1 = J - JPOLE - DO 100 I = 1,II - XI(I,J) = I - IPOLE - XJ(I,J) = XJ1 - 100 CONTINUE -C - DO 200 KK = 1,NPTS - R2(KK) = XJJ(KK) * XJJ(KK) + XII(KK) * XII(KK) - XLAT(KK) = DEGPRD * - & ASIN((GI2 - R2(KK)) / (GI2 + R2(KK))) - 200 CONTINUE -C - DO 300 KK = 1,NPTS - ANGLE(KK) = DEGPRD * ATAN2(XJJ(KK),XII(KK)) - 300 CONTINUE -C - DO 400 KK = 1,NPTS - IF (ANGLE(KK).LT.0.0) ANGLE(KK) = ANGLE(KK) + 360.0 - 400 CONTINUE -C - DO 500 KK = 1,NPTS - WLON(KK) = 270.0 + ORIENT - ANGLE(KK) - 500 CONTINUE -C - DO 600 KK = 1,NPTS - IF (WLON(KK).LT.0.0) WLON(KK) = WLON(KK) + 360.0 - 600 CONTINUE -C - DO 700 KK = 1,NPTS - IF (WLON(KK).GE.360.0) WLON(KK) = WLON(KK) - 360.0 - 700 CONTINUE -C - DO 800 KK = 1,NPTS - W1(KK) = (360.0 - WLON(KK)) / DEG + 1.0 - W2(KK) = XLAT(KK) / DEG + 1.0 - 800 CONTINUE -C - ISWT = 1 - INTRPO = INTERP - GO TO 1000 -C -C AFTER THE 1ST CALL TO W3FT214 TEST INTERP, IF IT HAS -C CHANGED RECOMPUTE SOME CONSTANTS -C - 900 CONTINUE - IF (INTERP.EQ.INTRPO) GO TO 2100 - INTRPO = INTERP -C - 1000 CONTINUE - DO 1100 K = 1,NPTS - IV(K) = W1(K) - JV(K) = W2(K) - XDELI(K) = W1(K) - IV(K) - XDELJ(K) = W2(K) - JV(K) - IP1(K) = IV(K) + 1 - JY(K,3) = JV(K) + 1 - JY(K,2) = JV(K) - 1100 CONTINUE -C - IF (LIN) GO TO 1400 -C - DO 1200 K = 1,NPTS - IP2(K) = IV(K) + 2 - IM1(K) = IV(K) - 1 - JY(K,1) = JV(K) - 1 - JY(K,4) = JV(K) + 2 - XI2TM(K) = XDELI(K) * (XDELI(K) - 1.0) * .25 - XJ2TM(K) = XDELJ(K) * (XDELJ(K) - 1.0) * .25 - 1200 CONTINUE -C - DO 1300 KK = 1,NPTS - IF (IV(KK).EQ.1) THEN - IP2(KK) = 3 - IM1(KK) = 360 - ELSE IF (IV(KK).EQ.360) THEN - IP2(KK) = 2 - IM1(KK) = 359 - ENDIF - 1300 CONTINUE -C - 1400 CONTINUE -C - IF (LIN) GO TO 1700 -C - DO 1500 KK = 1,NPTS - IF (JV(KK).LT.2.OR.JV(KK).GT.89) XJ2TM(KK) = 0.0 - 1500 CONTINUE -C - DO 1600 KK = 1,NPTS - IF (IP2(KK).LT.1) IP2(KK) = 1 - IF (IM1(KK).LT.1) IM1(KK) = 1 - IF (IP2(KK).GT.361) IP2(KK) = 361 - IF (IM1(KK).GT.361) IM1(KK) = 361 - 1600 CONTINUE -C - 1700 CONTINUE - DO 1800 KK = 1,NPTS - IF (IV(KK).LT.1) IV(KK) = 1 - IF (IP1(KK).LT.1) IP1(KK) = 1 - IF (IV(KK).GT.361) IV(KK) = 361 - IF (IP1(KK).GT.361) IP1(KK) = 361 - 1800 CONTINUE -C -C LINEAR INTERPOLATION -C - DO 1900 KK = 1,NPTS - IF (JY(KK,2).LT.1) JY(KK,2) = 1 - IF (JY(KK,2).GT.91) JY(KK,2) = 91 - IF (JY(KK,3).LT.1) JY(KK,3) = 1 - IF (JY(KK,3).GT.91) JY(KK,3) = 91 - 1900 CONTINUE -C - IF (.NOT.LIN) THEN - DO 2000 KK = 1,NPTS - IF (JY(KK,1).LT.1) JY(KK,1) = 1 - IF (JY(KK,1).GT.91) JY(KK,1) = 91 - IF (JY(KK,4).LT.1) JY(KK,4) = 1 - IF (JY(KK,4).GT.91) JY(KK,4) = 91 - 2000 CONTINUE - ENDIF -C - 2100 CONTINUE - IF (LIN) THEN -C -C LINEAR INTERPOLATION -C - DO 2200 KK = 1,NPTS - ERAS(KK,2) = (ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) - ERAS(KK,3) = (ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) - 2200 CONTINUE -C - DO 2300 KK = 1,NPTS - APOLA(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) - 2300 CONTINUE -C - ELSE -C -C QUADRATIC INTERPOLATION -C - DO 2400 KK = 1,NPTS - ERAS(KK,1)=(ALOLA(IP1(KK),JY(KK,1))-ALOLA(IV(KK),JY(KK,1))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,1)) + - & ( ALOLA(IM1(KK),JY(KK,1)) - ALOLA(IV(KK),JY(KK,1)) - & - ALOLA(IP1(KK),JY(KK,1))+ALOLA(IP2(KK),JY(KK,1))) - & * XI2TM(KK) - ERAS(KK,2)=(ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) + - & ( ALOLA(IM1(KK),JY(KK,2)) - ALOLA(IV(KK),JY(KK,2)) - & - ALOLA(IP1(KK),JY(KK,2))+ALOLA(IP2(KK),JY(KK,2))) - & * XI2TM(KK) - ERAS(KK,3)=(ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) + - & ( ALOLA(IM1(KK),JY(KK,3)) - ALOLA(IV(KK),JY(KK,3)) - & - ALOLA(IP1(KK),JY(KK,3))+ALOLA(IP2(KK),JY(KK,3))) - & * XI2TM(KK) - ERAS(KK,4)=(ALOLA(IP1(KK),JY(KK,4))-ALOLA(IV(KK),JY(KK,4))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,4)) + - & ( ALOLA(IM1(KK),JY(KK,4)) - ALOLA(IV(KK),JY(KK,4)) - & - ALOLA(IP1(KK),JY(KK,4))+ALOLA(IP2(KK),JY(KK,4))) - & * XI2TM(KK) - 2400 CONTINUE -C - DO 2500 KK = 1,NPTS - APOLA(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) + (ERAS(KK,1) - ERAS(KK,2) - & - ERAS(KK,3) + ERAS(KK,4)) * XJ2TM(KK) - 2500 CONTINUE -C - ENDIF -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft26.f b/src/fim/FIMsrc/w3/w3ft26.f deleted file mode 100644 index a66a208..0000000 --- a/src/fim/FIMsrc/w3/w3ft26.f +++ /dev/null @@ -1,129 +0,0 @@ - SUBROUTINE W3FT26 (MAPNUM,FLD,HI,IGPTS,NSTOP) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FT26 CREATES WAFS 1.25X1.25 THINNED GRIDS -C PRGMMR: FARLEY ORG: W/NMC42 DATE: 93-04-28 -C -C ABSTRACT: CONVERTS A 360X181 1-DEGREE GRID INTO A NH OR SH -C 360X91 1-DEGREE GRID. THIS NH/SH GRID IS FLIPPED FOR GRIB -C PURPOSES AND THEN CONVERTED TO THE DESIRED 1.25 DEGREE -C WAFS (QUADRANT) THINNED GRID. -C -C PROGRAM HISTORY LOG: -C 93-04-28 FARLEY ORIGINAL AUTHOR -C 94-04-01 R.E.JONES CORRECTIONS FOR 1 DEG. DISPLACEMENT -C OF GRIDS AND ERROR IN FLIPPING OF -C SOUTHERN HEMISPHERE. -C 94-05-05 R.E.JONES REPLACE SUBR. W3FT01 WITH W3FT16 AND W3FT17. -C 94-06-04 R.E.JONES CHANGE SUBROUTINE NAME FROM WFSTRP TO W3FT26 -C -C USAGE: CALL W3FT26 (MAPNUM,FLD,HI,IGPTS,NSTOP) -C INPUT ARGUMENT LIST: -C MAPNUM - NUMBER OF GRID, 37 TO 44 -C FLD - NORTHERN OR SOUTHERN HEM. SPECTRAL FIELD -C -C OUTPUT ARGUMENT LIST: -C HI - INTERPOLATED WAFS FIELD (3447 POINTS) -C IGPTS - NUMBER OF POINTS IN INTERPOLATED FIELD -C NSTOP - 24, WHEN MAPNUM .NE. 37 THRU 44 -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - W3FT16, W3FT17 -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256 -C -C$$$ -C - REAL FLD (360,181) - REAL HALF (360,91) - REAL HI (3447) - REAL QUAD (95,91) -C - INTEGER IGPTS - INTEGER MAPNUM - INTEGER NSTOP -C - SAVE -C -C PRINT *,' MADE IT TO W3FT26' - NSTOP = 0 -C -C$ 1.0 CUT FULL GRID TO DESIRED HEMISPHERE. -C -C$ 1.1 EXTRACT THE NORTHERN HEMISPHERE AND FLIP IT. -C - IF (MAPNUM .EQ. 37 .OR. MAPNUM .EQ. 38 .OR. - & MAPNUM .EQ. 39 .OR. MAPNUM .EQ. 40) THEN - DO J=1,91 - DO I=1,360 - HALF(I,91-J+1) = FLD(I,J) - END DO - END DO -C -C$ 1.2 EXTRACT THE SOUTHERN HEMISPHERE AND FLIP IT. -C - ELSE IF (MAPNUM .EQ. 41 .OR. MAPNUM .EQ. 42 .OR. - & MAPNUM .EQ. 43 .OR. MAPNUM .EQ. 44) THEN - DO J=91,181 - DO I=1,360 - HALF(I,181-J+1) = FLD(I,J) - END DO - END DO - ENDIF -C -C$ 2.0 SELECT THE QUADRANT DESIRED. -C - IF (MAPNUM .EQ. 37 .OR. MAPNUM .EQ. 41) THEN - DO 372 J = 1,91 - DO 370 I = 329,360 - QUAD(I-328,J) = HALF(I,J) - 370 CONTINUE - DO 371 I = 1,63 - QUAD(I+32,J) = HALF(I,J) - 371 CONTINUE - 372 CONTINUE -C - ELSE IF (MAPNUM .EQ. 38 .OR. MAPNUM .EQ. 42) THEN - DO 381 J = 1,91 - DO 380 I = 59,153 - QUAD(I-58,J) = HALF(I,J) - 380 CONTINUE - 381 CONTINUE -C - ELSE IF (MAPNUM .EQ. 39 .OR. MAPNUM .EQ. 43) THEN - DO 391 J = 1,91 - DO 390 I = 149,243 - QUAD(I-148,J) = HALF(I,J) - 390 CONTINUE - 391 CONTINUE -C - ELSE IF (MAPNUM .EQ. 40 .OR. MAPNUM .EQ. 44) THEN - DO 401 J = 1,91 - DO 400 I = 239,333 - QUAD(I-238,J) = HALF(I,J) - 400 CONTINUE - 401 CONTINUE -C - ELSE - PRINT *,' W3FT26 - MAP NOT TYPE 37-44' - IGPTS = 0 - NSTOP = 24 - RETURN - ENDIF -C - INTERP = 0 -C - IF (MAPNUM .EQ. 37 .OR. MAPNUM .EQ. 38 .OR. - & MAPNUM .EQ. 39 .OR. MAPNUM .EQ. 40) THEN - CALL W3FT16(QUAD,HI,INTERP) - ELSE - CALL W3FT17(QUAD,HI,INTERP) - ENDIF -C - IGPTS = 3447 -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft32.f b/src/fim/FIMsrc/w3/w3ft32.f deleted file mode 100644 index 7614b84..0000000 --- a/src/fim/FIMsrc/w3/w3ft32.f +++ /dev/null @@ -1,1235 +0,0 @@ - SUBROUTINE W3FT32(FIELD, MAPIN, DATA, MAPOUT, INTERP, IER) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK *** -C -C SUBPROGRAM: W3FT32 GENERAL INTERPOLATOR BETWEEN NMC FLDS -C PRGMMR: KEYSER ORG: NMC22 DATE:93-02-17 -C -C ABSTRACT: INTERPOLATE SCALAR QUANTITY FROM ANY GIVEN NMC -C FIELD (IN OFFICE NOTE 84) TO ANY OTHER FIELD. CAN DO BILINEARLY -C OR BIQUADRATICALLY. WILL NOT ROTATE WIND COMPONENTS. -C INPUT AND OUTPUT FIELDS ARE REAL*4 UNPACKED -C -C PROGRAM HISTORY LOG: -C 74-06-15 JOHN STACKPOLE -C 87-07-15 B. CAVANAUGH ADD GRID TYPE 100, 101 TO TABLES. -C 90-08-08 J. STACKPOLE CORRECT ROTATION ERROR WRT 100, 101 -C 90-08-31 R.E. JONES CHANGE NAME FROM POLATE TO W3FT32 -C 93-01-26 D. A. KEYSER ADDED GRID TYPES 87, 105, 106, 107 TO -C TABLES (AS BOTH INPUT AND OUTPUT). -C -C USAGE: CALL W3FT32(FIELD, MAPIN, DATA, MAPOUT, INTERP, IER) -C INPUT ARGUMENTS: -C FIELD - REAL*4 - TWO DIMENSIONAL ARRAY. -C MAPIN - INTEGER*4 - NMC MAP NUMBER (K) FOR GIVEN INPUT FIELD. -C MAPOUT - INTEGER*4 - NMC MAP NUMBER (K) FOR WANTED OUTPUT FIELD. -C INTERP - INTEGER*4 - SET INTERPOLATION METHOD: -C EQ 1 - LINEAR -C NE 1 - BIQUADRATIC -C INPUT FILES: NONE -C -C OUTPUT ARGUMENTS: -C DATA - REAL*4 - ARRAY TO HOLD OUTPUT MAP (UNPACKED). -C IER - INTEGER*4 - COMPLETION CONDITION FLAG -C -C OUTPUT FILES: NONE -C -C -C RETURN CONDITIONS: -C IER = 0 - NO DIFFICULTIES -C 1 - MAPIN NOT RECOGNIZED -C 2 - MAPOUT NOT RECOGNIZED -C 3 - PARTICULAR POLA MAPOUT NOT RECOGNIZED -C 4 - PARTICULAR LOLA MAPOUT NOT RECOGNIZED -C 5 - PARTICULAR LOLA MAPIN NOT RECOGNIZED -C 6 - PARTICULAR POLA MAPOUT NOT RECOGNIZED -C 7 - PARTICULAR LOLA MAPIN NOT RECOGNIZED -C 8 - PARTICULAR LOLA MAPOUT NOT RECOGNIZED -C THESE FLAGS ARE SET AT VARIOUS TEST LOCATIONS -C PLEASE REFER TO THE CODE LISTING FOR DETAILS -C -C SUBPROGRAMS CALLED: -C UNIQUE : NONE -C -C LIBRARY: W3FB01, W3FB02, W3FB03, W3FB04, W3FT00, W3FT01 -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/864 -C -C INFORMATION: SEE COMMENT CARDS FOLLOWING FOR MORE DETAIL -C INCLUDING RECIPES FOR ADDING MORE INPUT AND -C OUTPUT MAPS AS THE NEED ARISES. -C$$$ -C -C INTERPOLATE INFORMATION FROM FIELD (MAP TYPE K = MAPIN) -C TO DATA (MAP TYPE K = MAPOUT) -C INTERP SETS INTERPOLATION METHOD -C = 1 BILINEAR, OTHERWISE BIQUADRATIC -C - REAL DATA(*), FIELD(*) -C -C RESTRICTION AND RULES: -C -C AT PRESENT W3FT32 WILL ACCEPT ONLY THE FOLLOWING TYPES -C POLAR STEREOGRAPHIC -C K = 5 & 26 (LFM ANL & FCST RESPECTIVELY) -C 27 & 28 (65X65) -C 25 (53X57 SOUTHERN HEMISPHERE) -C 49 (129X129 NH; 190.5 KM) -C 50 (129X129 SH; 190.5 KM) -C 55 (87X71 NH; LFM ORIENT; 254 KM) -C 56 (87X71 NA; LFM ORIENT; 174 KM) -C 60 (57X57 ENLARGED LFM 'VLFM') -C 87 (81X62 MAPS ANAL/FCST GRID; 68.153 KM) -C 100 (83X83 NGM C-GRID; 91.452) -C 101 (113X91 NGM BIG C-GRID; 91.452) -C 105 (83X83 NGM SUPER C-GRID SUBSET; 90.75464 KM) -C 106 (165X117 HI RESOLUTION GRID; 45.37732 KM) -C 107 (120X92 HI RESOLUTION GRID SUBSET; 45.37732 KM) -C -C LONGITUDE/LATITUDE: ('LOLA') -C K = 29 & 30 (145X37) -C 33 & 34 (181X46) -C 45 & 46 (97X25 - 3.75 DEG LOLA) -C 21 & 22 (73X19 - 5 DEG LOLA) -C 21 & 22 (73X19 - 5 DEG LOLA) -C -C WILL OUTPUT: -C POLAR STEREO: -C K = 5 (53X57) LFM -C 25 (53X57 SOUTH HEMISPHERE) -C 26 (53X45) LFM -C 27 & 28 (65X65) -C 49 (129X129 NH POLA) (1/2 BEDIENT MESH;ORIENTED 80W) -C 50 (129X129 SH POLA) (1/2 BEDIENT MESH;ORINETED 80W) -C 51 (129X129 NH POLA) (SAME MESHL; ORIENTED AT 105W) -C 55 (NH 87X71 254 KM, LFM ORIENT) -C 56 (NA 87X71 127 KM, LFM ORIENT) -C 60 (57X57 ENLARGED LFM 'VLFM') -C 87 (81X62 MAPS ANAL/FCST GRID; 68.153 KM) -C 100 (83X83 NGM C-GRID) -C 101 (113X91 NGM BIG C-GRID) -C 105 (83X83 NGM SUPER C-GRID SUBSET; 90.75464 KM) -C 106 (165X117 HI RESOLUTION GRID; 45.37732 KM) -C 107 (120X92 HI RESOLUTION GRID SUBSET; 45.37732 KM) -C 400 (39X39 1:40MIL 80 DEG VERTICAL POLA) -C 401 (25X35 1:20MIL U.S. SECTION ROTATED) -C 402 (97X97 1-20MIL N.H. POLA ROTATED TO 105W VERT) -C 403 (97X97 1-20MIL S.H. POLA UNROTATED 80W TOP VERT) -C LOLA: -C K = 29 & 30 (145X37) -C 33 & 34 (181X46) -C 45 & 46 (97X25 - 3.75 DEG LOLA) -C 500 & 501 US SECTIONAL NEP 36 & 45 -C -C FEEL FREE, GENTLE READER, TO AUGMENT THE LIST AS YOU WISH -C AND HERE IS A RECIPE FOR ADDING A NEW OUTPUT GRID -C (POLA IN THIS CASE, BUT I AM SURE YOU CAN DRAW THE ANALOGY) -C STEP1 -C PUT NEW NUMBER IN COMMENT ABOVE -C STEP 2 -C ADD IT TO MAPOUT LIST NEAR STMT 30 -C STEP 3 -C ADD SET OF PARAMETERS AT STMT 2000 (FOR POLA) -C STEP4 -C ADD SET OF PARAMETERS AT STMT 6000 (FOR POLA) -C -C HERE TOO IS A RECIPE FOR ADDING A NEW (POLA) INPUT GRID -C -C STEP 1: -C PUT NEW NUMBER IN COMMENT ABOVE -C STEP2: -C ADD NUMBER TO IF(MAPIN.. ) TEST BELOW -C STEP 3: -C ADD INPUT MAP CHARACTERISTICS AT STMT 1000 -C STEP 4: -C DITTO AT STMT 3000 -C - LOGICAL LOLAIN, POLAIN, LOLAOU, POLAOU -C - SAVE -C -C BEGIN HERE - SET ERROR RETURN TO O.K. -C - IER = 0 -C -C DETERMINE WHETHER INPUT GRID IS LOLA OR POLA -C -C THIS LIST CAN BE AUGMENTED ONLY AT THE COST OF A LOT OF -C WORK ELSEWHERE IN THE PROGRAM -C HAVE AT IT IF YOU WANT OTHER MAPS -C -C POLA MAPS -C - IF (MAPIN.EQ. 5) GO TO 10 - IF (MAPIN.EQ.25) GO TO 10 - IF (MAPIN.EQ.26) GO TO 10 - IF (MAPIN.EQ.27) GO TO 10 - IF (MAPIN.EQ.28) GO TO 10 - IF (MAPIN.EQ.49) GO TO 10 - IF (MAPIN.EQ.50) GO TO 10 - IF (MAPIN.EQ.51) GO TO 10 - IF (MAPIN.EQ.55) GO TO 10 - IF (MAPIN.EQ.56) GO TO 10 - IF (MAPIN.EQ.60) GO TO 10 - IF (MAPIN.EQ.87) GO TO 10 - IF (MAPIN.EQ.100) GO TO 10 - IF (MAPIN.EQ.101) GO TO 10 - IF (MAPIN.EQ.105) GO TO 10 - IF (MAPIN.EQ.106) GO TO 10 - IF (MAPIN.EQ.107) GO TO 10 -C -C LOLA MAPS -C - IF (MAPIN.EQ.21) GO TO 20 - IF (MAPIN.EQ.22) GO TO 20 - IF (MAPIN.EQ.29) GO TO 20 - IF (MAPIN.EQ.30) GO TO 20 - IF (MAPIN.EQ.33) GO TO 20 - IF (MAPIN.EQ.34) GO TO 20 - IF (MAPIN.EQ.45) GO TO 20 - IF (MAPIN.EQ.46) GO TO 20 -C -C IF NO MATCH - ERROR -C - IER = 1 - RETURN -C -C SET LOGICAL FLAGS -C - 10 LOLAIN = .FALSE. - POLAIN = .TRUE. - GO TO 30 -C - 20 LOLAIN = .TRUE. - POLAIN = .FALSE. -C -C DITTO FOR OUTPUT MAP TYPE -C -C POLA MAPS -C - 30 IF (MAPOUT.EQ. 5) GO TO 40 - IF (MAPOUT.EQ.25) GO TO 40 - IF (MAPOUT.EQ.26) GO TO 40 - IF (MAPOUT.EQ.27) GO TO 40 - IF (MAPOUT.EQ.28) GO TO 40 - IF (MAPOUT.EQ.49) GO TO 40 - IF (MAPOUT.EQ.50) GO TO 40 - IF (MAPOUT.EQ.51) GO TO 40 - IF (MAPOUT.EQ.55) GO TO 40 - IF (MAPOUT.EQ.56) GO TO 40 - IF (MAPOUT.EQ.60) GO TO 40 - IF (MAPOUT.EQ.87) GO TO 40 - IF (MAPOUT.EQ.100) GO TO 40 - IF (MAPOUT.EQ.101) GO TO 40 - IF (MAPOUT.EQ.105) GO TO 40 - IF (MAPOUT.EQ.106) GO TO 40 - IF (MAPOUT.EQ.107) GO TO 40 - IF (MAPOUT.EQ.400) GO TO 40 - IF (MAPOUT.EQ.401) GO TO 40 - IF (MAPOUT.EQ.402) GO TO 40 - IF (MAPOUT.EQ.403) GO TO 40 -C -C LOLA MAPS -C - IF (MAPOUT.EQ.21) GO TO 50 - IF (MAPOUT.EQ.22) GO TO 50 - IF (MAPOUT.EQ.29) GO TO 50 - IF (MAPOUT.EQ.30) GO TO 50 - IF (MAPOUT.EQ.33) GO TO 50 - IF (MAPOUT.EQ.34) GO TO 50 - IF (MAPOUT.EQ.45) GO TO 50 - IF (MAPOUT.EQ.46) GO TO 50 - IF (MAPOUT.EQ.500) GO TO 50 - IF (MAPOUT.EQ.501) GO TO 50 -C -C NO MATCH - ERROR -C - IER = 2 - RETURN -C -C SET LOGICAL FLAGS -C - 40 LOLAOU = .FALSE. - POLAOU = .TRUE. - GO TO 60 -C - 50 LOLAOU = .TRUE. - POLAOU = .FALSE. -C -C GO TO DIFFERENT SECTIONS FOR IN/OUT OPTIONS -C - 60 IF (POLAIN) GO TO 1000 - IF (LOLAIN) GO TO 5000 -C -C ################################################################## -C ################################################################## -C -C THIS SECTION FOR POLAR STEREOGRAPHIC INPUT MAPS -C -C SUBDIVIDED FOR OUTPUT TYPE -C - 1000 IF (LOLAOU) GO TO 3000 -C -C POLAR STEREO TO POLAR STEREO -C USE HOWCROFTS FIELD TRANSFORMER -C ORIENT IS DEGREES OF ROTATION FROM NMC STANDARD -C (80 DEG CENTER VERTIVAL) TO INPUT GRID (POSITIVE ANTICLOCKWISE) -C - IF (MAPIN.EQ. 5) GO TO 1005 - IF (MAPIN.EQ.25) GO TO 1025 - IF (MAPIN.EQ.26) GO TO 1026 - IF (MAPIN.EQ.27) GO TO 1027 - IF (MAPIN.EQ.28) GO TO 1027 - IF (MAPIN.EQ.49) GO TO 1049 - IF (MAPIN.EQ.50) GO TO 1049 - IF (MAPIN.EQ.51) GO TO 1051 - IF (MAPIN.EQ.55) GO TO 1055 - IF (MAPIN.EQ.56) GO TO 1056 - IF (MAPIN.EQ.60) GO TO 1060 - IF (MAPIN.EQ.87) GO TO 1087 - IF (MAPIN.EQ.100) GO TO 1100 - IF (MAPIN.EQ.101) GO TO 1101 - IF (MAPIN.EQ.105) GO TO 1105 - IF (MAPIN.EQ.106) GO TO 1106 - IF (MAPIN.EQ.107) GO TO 1107 - IER = 1 - RETURN -C - 1005 IMAXIN =53 - JMAXIN = 57 - COMIIN = 27. - COMJIN = 49. - ORIENT = -25. - XMESH = 190.5 - GO TO 2000 -C - 1025 IMAXIN = 53 - JMAXIN = 57 - COMIIN = 27. - COMJIN = 29. - ORIENT = 0. - XMESH = 381. - GO TO 2000 -C - 1026 IMAXIN = 53 - JMAXIN = 45 - COMIIN = 27. - COMJIN = 49. - ORIENT = -25. - XMESH = 190.5 - GO TO 2000 -C - 1027 IMAXIN = 65 - JMAXIN = 65 - COMIIN = 33. - COMJIN = 33. - ORIENT = 0. - XMESH = 381. - GO TO 2000 -C - 1049 IMAXIN = 129 - JMAXIN = 129 - COMIIN = 65. - COMJIN = 65. - ORIENT = 0. - XMESH = 190.5 - GOTO 2000 -C - 1051 IMAXIN = 129 - JMAXIN = 129 - COMIIN = 65. - COMJIN = 65. - ORIENT = -25. - XMESH = 190.5 - GOTO 2000 -C - 1055 IMAXIN = 87 - JMAXIN = 71 - COMIIN = 44. - COMJIN = 38. - ORIENT = -25. - XMESH = 254. - GOTO 2000 -C - 1056 IMAXIN = 87 - JMAXIN = 71 - COMIIN = 40. - COMJIN = 73. - ORIENT = -25. - XMESH = 127. - GOTO 2000 -C - 1060 IMAXIN= 57 - JMAXIN = 57 - COMIIN = 29. - COMJIN = 49. - ORIENT = -25. - XMESH = 190.5 - GO TO 2000 -C - 1087 IMAXIN= 81 - JMAXIN = 62 - COMIIN = 31.91 - COMJIN = 112.53 - ORIENT = -25. - XMESH = 68.153 - GO TO 2000 -C - 1100 IMAXIN = 83 - JMAXIN = 83 - COMIIN = 40.5 - COMJIN = 88.5 - ORIENT = -25. - XMESH = 91.452 - GO TO 2000 -C - 1101 IMAXIN = 113 - JMAXIN = 91 - COMIIN = 58.5 - COMJIN = 92.5 - ORIENT = -25. - XMESH = 91.452 - GO TO 2000 -C - 1105 IMAXIN = 83 - JMAXIN = 83 - COMIIN = 40.5 - COMJIN = 88.5 - ORIENT = -25. - XMESH = 90.75464 - GO TO 2000 -C - 1106 IMAXIN = 165 - JMAXIN = 117 - COMIIN = 80.0 - COMJIN = 176.0 - ORIENT = -25. - XMESH = 45.37732 - GO TO 2000 -C - 1107 IMAXIN = 120 - JMAXIN = 92 - COMIIN = 46.0 - COMJIN = 167.0 - ORIENT = -25. - XMESH = 45.37732 - GO TO 2000 -C -C SELECT I, J, DILATION, ROTATION, AND COMMON POINT (POLE) OUTPUT -C DILATE = XMESHOUT / XMESHIN -C IN THE FOLLOWING, ROT IS THE ROTATION FROM THE INPUT TO -C THE OUTPUT GRID - NOT THE ORIENTATION OF THE OUT-GRID -C - 2000 IF (MAPOUT.EQ. 5) GO TO 2005 - IF (MAPOUT.EQ.25) GO TO 2025 - IF (MAPOUT.EQ.26) GO TO 2026 - IF (MAPOUT.EQ.27) GO TO 2027 - IF (MAPOUT.EQ.28) GO TO 2027 - IF (MAPOUT.EQ.49) GO TO 2049 - IF (MAPOUT.EQ.50) GO TO 2049 - IF (MAPOUT.EQ.51) GO TO 2051 - IF (MAPOUT.EQ.55) GO TO 2055 - IF (MAPOUT.EQ.56) GO TO 2056 - IF (MAPOUT.EQ.60) GO TO 2060 - IF (MAPOUT.EQ.87) GO TO 2087 - IF (MAPOUT.EQ.100) GO TO 2100 - IF (MAPOUT.EQ.101) GO TO 2101 - IF (MAPOUT.EQ.105) GO TO 2105 - IF (MAPOUT.EQ.106) GO TO 2106 - IF (MAPOUT.EQ.107) GO TO 2107 - IF (MAPOUT.EQ.400) GO TO 2400 - IF (MAPOUT.EQ.401) GO TO 2401 - IF (MAPOUT.EQ.402) GO TO 2402 - IF (MAPOUT.EQ.403) GO TO 2403 - IER = 3 - RETURN -C - 2005 IMAXOU = 53 - JMAXOU = 57 - DILAT = 190.5/XMESH - ROT = -25. - ORIENT - COMIOU = 27. - COMJOU = 49. - GO TO 2700 -C - 2025 IMAXOU = 53 - JMAXOU = 57 - DILAT = 381./XMESH - ROT = 0. - ORIENT - COMIOU = 27. - COMJOU = 29. - GO TO 2700 -C - 2026 IMAXOU = 53 - JMAXOU = 45 - DILAT = 190.5/XMESH - ROT = -25. - ORIENT - COMIOU = 27. - COMJOU = 49. - GO TO 2700 -C - 2027 IMAXOU = 65 - JMAXOU = 65 - DILAT = 381./XMESH - ROT = 0. - ORIENT - COMIOU = 33. - COMJOU = 33. - GO TO 2700 -C - 2049 IMAXOU = 129 - JMAXOU = 129 - DILAT = 190.5/XMESH - ROT = 0. - ORIENT - COMIOU = 65. - COMJOU = 65. - GOTO 2700 -C - 2051 IMAXOU = 129 - JMAXOU = 129 - DILAT = 190.5/XMESH - ROT = -25. - ORIENT - COMIOU = 65. - COMJOU = 65. - GOTO 2700 -C - 2055 IMAXOU = 87 - JMAXOU = 71 - DILAT = 254./XMESH - ROT = -25. - ORIENT - COMIOU = 44. - COMJOU = 38. - GOTO 2700 -C - 2056 IMAXOU = 87 - JMAXOU = 71 - DILAT = 127./XMESH - ROT = -25. - ORIENT - COMIOU = 40. - COMJOU = 73. - GOTO 2700 -C - 2060 IMAXOU = 57 - JMAXOU = 57 - DILAT = 190.5/XMESH - ROT = -25. - ORIENT - COMIOU = 29. - COMJOU = 49. - GO TO 2700 -C - 2087 IMAXOU = 81 - JMAXOU = 62 - DILAT = 68.153/XMESH - ROT = -25. - ORIENT - COMIOU = 31.91 - COMJOU = 112.53 - GO TO 2700 -C - 2100 IMAXOU = 83 - JMAXOU = 83 - DILAT = 91.452/XMESH - ROT = -25. - ORIENT - COMIOU = 40.5 - COMJOU = 88.5 - GO TO 2700 -C - 2101 IMAXOU = 113 - JMAXOU = 91 - DILAT = 91.452/XMESH - ROT = -25. - ORIENT - COMIOU = 58.5 - COMJOU = 92.5 - GO TO 2700 -C - 2105 IMAXOU = 83 - JMAXOU = 83 - DILAT = 90.75464/XMESH - ROT = -25. - ORIENT - COMIOU = 40.5 - COMJOU = 88.5 - GO TO 2700 -C - 2106 IMAXOU = 165 - JMAXOU = 117 - DILAT = 45.37732/XMESH - ROT = -25. - ORIENT - COMIOU = 80.0 - COMJOU = 176.0 - GO TO 2700 -C - 2107 IMAXOU = 120 - JMAXOU = 92 - DILAT = 45.37732/XMESH - ROT = -25. - ORIENT - COMIOU = 46.0 - COMJOU = 167.0 - GO TO 2700 -C - 2400 IMAXOU = 39 - JMAXOU = 39 - DILAT = 508./ XMESH - ROT = 0. - ORIENT - COMIOU = 20. - COMJOU = 20. - GO TO 2700 -C - 2401 IMAXOU = 25 - JMAXOU = 35 - DILAT = 254./XMESH - ROT = -25. + 90. - ORIENT - COMIOU =31.75 - COMJOU = 18. - GO TO 2700 -C - 2402 IMAXOU = 97 - JMAXOU = 97 - DILAT = 254./XMESH - ROT = -25. - ORIENT - COMIOU = 49. - COMJOU = 49. - GOTO 2700 -C - 2403 IMAXOU = 97 - JMAXOU = 97 - DILAT = 254./XMESH - ROT = 0. - ORIENT - COMIOU = 49. - COMJOU = 49. - GOTO 2700 -C - 2700 CALL W3FT00 - 1 (FIELD, DATA, IMAXIN, JMAXIN, IMAXOU, JMAXOU, - 2 COMIIN, COMJIN, COMIOU, COMJOU, - 3 DILAT, ROT, INTERP) - RETURN -C -C ################################################################## -C -C HERE FOR POLAR STEREO TO LO/LA -C - 3000 IF (MAPIN.EQ. 5) GO TO 3005 - IF (MAPIN.EQ.25) GO TO 3025 - IF (MAPIN.EQ.26) GO TO 3026 - IF (MAPIN.EQ.27) GO TO 3027 - IF (MAPIN.EQ.28) GO TO 3027 - IF (MAPIN.EQ.49) GO TO 3049 - IF (MAPIN.EQ.50) GO TO 3049 - IF (MAPIN.EQ.51) GO TO 3051 - IF (MAPIN.EQ.55) GO TO 3055 - IF (MAPIN.EQ.56) GO TO 3056 - IF (MAPIN.EQ.60) GO TO 3060 - IF (MAPIN.EQ.87) GO TO 3087 - IF (MAPIN.EQ.100) GO TO 3100 - IF (MAPIN.EQ.101) GO TO 3101 - IF (MAPIN.EQ.105) GO TO 3105 - IF (MAPIN.EQ.106) GO TO 3106 - IF (MAPIN.EQ.107) GO TO 3107 -C - 3005 XMESH = 190.5 - IMAXIN = 53 - JMAXIN = 57 - NTHSTH = 1 - POLEI = 27. - POLEJ = 49. - ORIENT = 105. - GO TO 4000 -C - 3025 XMESH = 381. - IMAXIN = 53 - JMAXIN = 57 - NTHSTH = 2 - POLEI = 27. - POLEJ = 29. - GO TO 4000 -C - 3026 XMESH = 190.5 - IMAXIN = 53 - JMAXIN = 45 - NTHSTH = 1 - POLEI = 27. - POLEJ = 49. - ORIENT = 105. - GO TO 4000 -C - 3027 XMESH = 381. - IMAXIN = 65 - JMAXIN = 65 - NTHSTH = 1 - IF (MAPIN.EQ.28) NTHSTH = 2 - POLEI = 33. - POLEJ = 33. - ORIENT = 80. - GO TO 4000 -C - 3049 XMESH = 190.5 - IMAXIN = 129 - JMAXIN = 129 - NTHSTH = 1 - IF (MAPIN.EQ.50) NTHSTH=2 - POLEI = 65. - POLEJ = 65. - ORIENT = 80. - GOTO 4000 -C - 3051 XMESH = 190.5 - IMAXIN = 129 - JMAXIN = 129 - NTHSTH = 1 - POLEI = 65. - POLEJ = 65. - ORIENT = 105. - GOTO 4000 -C - 3055 XMESH = 254. - IMAXIN = 87 - JMAXIN = 71 - NTHSTH = 1 - POLEI = 44. - POLEJ = 38. - ORIENT = 105. - GOTO 4000 -C - 3056 XMESH = 127. - IMAXIN = 87 - JMAXIN = 71 - NTHSTH = 1 - POLEI = 40. - POLEJ = 73. - ORIENT = 105. - GOTO 4000 -C - 3060 XMESH = 190.5 - IMAXIN = 57 - JMAXIN = 57 - NTHSTH = 1 - POLEI = 29. - POLEJ = 49. - ORIENT = 105. - GO TO 4000 -C - 3087 XMESH = 68.153 - IMAXIN = 81 - JMAXIN = 62 - NTHSTH = 1 - POLEI = 31.91 - POLEJ = 112.53 - ORIENT = 105. - GO TO 4000 -C - 3100 XMESH = 91.452 - IMAXIN = 83 - JMAXIN = 83 - NTHSTH = 1 - POLEI = 40.5 - POLEJ = 88.5 - ORIENT = 105. - GO TO 4000 -C - 3101 XMESH = 91.452 - IMAXIN = 113 - JMAXIN = 91 - NTHSTH = 1 - POLEI = 58.5 - POLEJ = 92.5 - ORIENT = 105. - GO TO 4000 -C - 3105 XMESH = 90.75464 - IMAXIN = 83 - JMAXIN = 83 - NTHSTH = 1 - POLEI = 40.5 - POLEJ = 88.5 - ORIENT = 105. - GO TO 4000 -C - 3106 XMESH = 45.37732 - IMAXIN = 165 - JMAXIN = 117 - NTHSTH = 1 - POLEI = 80.0 - POLEJ = 176.0 - ORIENT = 105. - GO TO 4000 -C - 3107 XMESH = 45.37732 - IMAXIN = 120 - JMAXIN = 92 - NTHSTH = 1 - POLEI = 46.0 - POLEJ = 167.0 - ORIENT = 105. - GO TO 4000 -C -C SELECT OUTPUT LO/LA VARIATIONS -C - 4000 IF (MAPOUT.EQ.21) GO TO 4021 - IF (MAPOUT.EQ.22) GO TO 4021 - IF (MAPOUT.EQ.29) GO TO 4029 - IF (MAPOUT.EQ.30) GO TO 4029 - IF (MAPOUT.EQ.33) GO TO 4033 - IF (MAPOUT.EQ.34) GO TO 4033 - IF (MAPOUT.EQ.45) GO TO 4045 - IF (MAPOUT.EQ.46) GO TO 4045 - IF (MAPOUT.EQ.500) GO TO 4500 - IF (MAPOUT.EQ.501) GO TO 4501 - IER = 4 - RETURN -C - 4021 IMINOU = 1 - JMINOU = 1 - IMAXOU = 73 - JMAXOU = 19 - DEG = 5.0 - GO TO 4700 -C - 4029 IMINOU = 1 - IMAXOU = 145 - JMINOU = 1 - JMAXOU = 37 - DEG = 2.5 - GO TO 4700 -C - 4033 IMINOU = 1 - IMAXOU = 181 - JMINOU = 1 - JMAXOU = 46 - DEG = 2.0 - GO TO 4700 -C - 4045 IMINOU = 1 - IMAXOU = 97 - JMINOU = 1 - JMAXOU = 25 - DEG = 3.75 - GOTO 4700 -C - 4500 IMINOU = 93 - IMAXOU = 117 - JMINOU = 1 - JMAXOU = 37 - DEG = 2.5 - GO TO 4700 -C - 4501 IMINOU = 116 - IMAXOU = 140 - JMINOU = 1 - JMAXOU = 46 - DEG = 2.0 - GO TO 4700 -C -C FIND INPUT POLA I,J FOR DESIRED LOLA OUTPUT POINTS -C - 4700 IJOUT = 0 - DO 4740 J = JMINOU, JMAXOU - XLAT = (J-1) * DEG - IF (NTHSTH.EQ.2) XLAT = XLAT - 90. - DO 4740 I = IMINOU, IMAXOU - ELON = (I-1) * DEG - WLON = AMOD(360. - ELON, 360.) - GO TO (4710, 4720), NTHSTH - 4710 CALL W3FB04(XLAT, WLON, XMESH, ORIENT, XI, XJ) - GO TO 4730 - 4720 CALL W3FB02(XLAT, WLON, XMESH, XI, XJ) - 4730 XIIN = XI + POLEI - XJIN = XJ + POLEJ -C -C MACDONALDS SUPER GENERAL INTERPOLATOR -C IN WHICH D = FIELD(XIIN, XJIN) -C - CALL W3FT01 - 1 (XIIN, XJIN, FIELD, D, IMAXIN, JMAXIN, 0, INTERP) - IJOUT = IJOUT + 1 - DATA(IJOUT) = D - 4740 CONTINUE - RETURN -C -C ################################################################## -C ################################################################## -C -C THIS SECTION FOR LOLA INPUT MAP -C -C SELCT OUTPUT TYPE -C - 5000 IF (LOLAOU) GO TO 7000 -C -C LOLA TO POLA -C SELECT INPUT INFO -C (THIS PATTERN CAN BE USED WITH POLA INPUT, TOO - TRY IT -C - IF (MAPIN.EQ.21) GO TO 5021 - IF (MAPIN.EQ.22) GO TO 5021 - IF (MAPIN.EQ.29) GO TO 5029 - IF (MAPIN.EQ.30) GO TO 5029 - IF (MAPIN.EQ.33) GO TO 5033 - IF (MAPIN.EQ.34) GO TO 5033 - IF (MAPIN.EQ.45) GO TO 5045 - IF (MAPIN.EQ.46) GO TO 5045 - IER = 5 - RETURN -C - 5021 IMAXIN = 73 - JMAXIN = 19 - DEG = 5.0 - NTHSTH = 1 - IF (MAPIN.EQ.22) NTHSTH = 2 - GO TO 6000 -C - 5029 IMAXIN = 145 - JMAXIN = 37 - DEG = 2.5 - NTHSTH = 1 - IF (MAPIN.EQ.30) NTHSTH = 2 - GO TO 6000 -C - 5033 IMAXIN = 181 - JMAXIN = 46 - DEG = 2.0 - NTHSTH = 1 - IF (MAPIN.EQ.34) NTHSTH = 2 - GO TO 6000 -C - 5045 IMAXIN = 97 - JMAXIN = 25 - DEG = 3.75 - NTHSTH = 1 - IF (MAPIN.EQ.46) NTHSTH = 2 - GOTO 6000 -C -C SELECT OUTPUT POLA VARIETY -C ROT INDICATES HOW MANY DEGREES THE POLA GRID IS TO BE ROTATED -C (POSITIVE COUNTER-CLOCKWISE) FROM THE NMC 'STANDARD' -C OF 80 DEG WEST AT THE BOTTOM (OR TOP IF SOUTHERN HEMISPHERE) -C - 6000 IF (MAPOUT.EQ. 5) GO TO 6005 - IF (MAPOUT.EQ.25) GO TO 6025 - IF (MAPOUT.EQ.26) GO TO 6026 - IF (MAPOUT.EQ.27) GO TO 6027 - IF (MAPOUT.EQ.28) GO TO 6027 - IF (MAPOUT.EQ.49) GO TO 6049 - IF (MAPOUT.EQ.50) GO TO 6049 - IF (MAPOUT.EQ.51) GO TO 6051 - IF (MAPOUT.EQ.55) GO TO 6055 - IF (MAPOUT.EQ.56) GO TO 6056 - IF (MAPOUT.EQ.60) GO TO 6060 - IF (MAPOUT.EQ.87) GO TO 6087 - IF (MAPOUT.EQ.100) GO TO 6100 - IF (MAPOUT.EQ.101) GO TO 6101 - IF (MAPOUT.EQ.105) GO TO 6105 - IF (MAPOUT.EQ.106) GO TO 6106 - IF (MAPOUT.EQ.107) GO TO 6107 - IF (MAPOUT.EQ.400) GO TO 6400 - IF (MAPOUT.EQ.401) GO TO 6401 - IF (MAPOUT.EQ.402) GO TO 6402 - IF (MAPOUT.EQ.403) GO TO 6403 - IER = 6 - RETURN -C - 6005 IMAXOU = 53 - JMAXOU = 57 - XMESH = 190.5 - ROT = -25. - POLEI = 27. - POLEJ = 49. - GO TO 6700 -C - 6025 IMAXOU = 53 - JMAXOU = 57 - XMESH = 381. - ROT = 0. - POLEI = 27. - POLEJ = 29. - GO TO 6700 -C - 6026 IMAXOU = 53 - JMAXOU = 45 - XMESH = 190.5 - ROT = -25. - POLEI = 27. - POLEJ = 49. - GO TO 6700 -C - 6027 IMAXOU = 65 - JMAXOU = 65 - XMESH = 381. - ROT = 0. - POLEI = 33. - POLEJ = 33. - GO TO 6700 -C - 6049 IMAXOU = 129 - JMAXOU = 129 - XMESH = 190.5 - ROT = 0. - POLEI = 65. - POLEJ = 65. - GOTO 6700 -C - 6051 IMAXOU = 129 - JMAXOU = 129 - XMESH = 190.5 - ROT = -25. - POLEI = 65. - POLEJ = 65. - GOTO 6700 -C - 6055 IMAXOU = 87 - JMAXOU = 71 - XMESH = 254. - ROT = -25. - POLEI = 44. - POLEJ = 38. - GOTO 6700 -C - 6056 IMAXOU = 87 - JMAXOU = 71 - XMESH = 127. - ROT = -25. - POLEI = 40. - POLEJ = 73. - GOTO 6700 -C - 6060 IMAXOU = 57 - JMAXOU = 57 - XMESH = 190.5 - ROT = -25. - POLEI = 29. - POLEJ = 49. - GO TO 6700 -C - 6087 IMAXOU = 81 - JMAXOU = 62 - XMESH = 68.153 - ROT = -25. - POLEI = 31.91 - POLEJ = 112.53 - GO TO 6700 -C - 6100 IMAXOU = 83 - JMAXOU = 83 - XMESH = 91.452 - ROT = -25. - POLEI = 40.5 - POLEJ = 88.5 - GO TO 6700 -C - 6101 IMAXOU = 113 - JMAXOU = 91 - XMESH = 91.452 - ROT = -25. - POLEI = 58.5 - POLEJ = 92.5 - GO TO 6700 -C - 6105 IMAXOU = 83 - JMAXOU = 83 - XMESH = 90.75464 - ROT = -25. - POLEI = 40.5 - POLEJ = 88.5 - GO TO 6700 -C - 6106 IMAXOU = 165 - JMAXOU = 117 - XMESH = 45.37732 - ROT = -25. - POLEI = 80.0 - POLEJ = 176.0 - GO TO 6700 -C - 6107 IMAXOU = 120 - JMAXOU = 92 - XMESH = 45.37732 - ROT = -25. - POLEI = 46.0 - POLEJ = 167.0 - GO TO 6700 -C - 6400 IMAXOU = 39 - JMAXOU = 39 - XMESH = 508. - ROT = 0. - POLEI = 20. - POLEJ = 20. - GO TO 6700 -C -C THIS ONE GETS SPECIAL TREATMENT BECAUSE WE ARE -C INTERCHANGING ROWS AND COLUMNS FOR GRIDPRINT AFTER INTERPOLATION -C (ACTUALLY IT IS DONE ALL AT ONCE) -C - 6401 IMAXOU = 25 - JMAXOU = 35 - XMESH = 254. - ROT = -25. - POLEI = 18. - POLEJ = 31.75 -C - IJOUT = 0 - DO 64011 J=1,JMAXOU - XI = JMAXOU - J + 1 - XXI = XI - POLEI - DO 64011 I = 1,IMAXOU - XJ = I - XXJ = XJ - POLEJ - CALL W3FB01(XXI, XXJ, XMESH, XLAT, WLON) - WLON = WLON - ROT - IF (WLON.GT.360.) WLON = WLON - 360. - IF (WLON.LT.0.) WLON = WLON + 360. - XIIN = (360.-WLON)/DEG + 1. - XJIN = XLAT/DEG + 1. - CALL W3FT01 - 1 (XIIN, XJIN, FIELD, D, IMAXIN, JMAXIN, 1, INTERP) - IJOUT = IJOUT + 1 - DATA(IJOUT) = D -64011 CONTINUE - RETURN -C - 6402 IMAXOU = 97 - JMAXOU = 97 - XMESH = 254. - ROT = -25. - POLEI = 49. - POLEJ = 49. - GOTO 6700 -C - 6403 IMAXOU = 97 - JMAXOU = 97 - XMESH = 254. - ROT = 0. - POLEI = 49. - POLEJ = 49. - GOTO 6700 -C -C FIND INPUT LOLA I,J FOR DESIRED POLA OUTPUT POINTS -C - 6700 IJOUT = 0 - DO 6740 J=1,JMAXOU - XJ = J - POLEJ - DO 6740 I=1,IMAXOU - XI = I - POLEI - GOTO (6710, 6720), NTHSTH - 6710 CALL W3FB01(XI, XJ, XMESH, XLAT, WLON) - WLON = WLON - ROT - GO TO 6730 - 6720 CALL W3FB03(XI, XJ, XMESH, XLAT, WLON) - WLON = WLON + ROT - XLAT = XLAT + 90. - 6730 IF (WLON.GT.360.) WLON = WLON - 360. - IF (WLON.LT.0.) WLON = WLON + 360. - XIIN = (360.-WLON)/DEG + 1. - XJIN = XLAT/DEG + 1. - CALL W3FT01 - 1 (XIIN, XJIN, FIELD, D, IMAXIN, JMAXIN, 1, INTERP) - IJOUT = IJOUT + 1 - DATA(IJOUT) = D - 6740 CONTINUE - RETURN -C -C ################################################################## -C -C LOLA TO LOLA -C -C SELECT INPUT GRID INFO -C - 7000 IF (MAPIN.EQ.21) GO TO 7021 - IF (MAPIN.EQ.22) GO TO 7021 - IF (MAPIN.EQ.29) GO TO 7029 - IF (MAPIN.EQ.30) GO TO 7029 - IF (MAPIN.EQ.33) GO TO 7033 - IF (MAPIN.EQ.34) GO TO 7033 - IF (MAPIN.EQ.45) GOTO 7045 - IF (MAPIN.EQ.46) GOTO 7045 - IER = 7 - RETURN -C - 7021 IMAXIN = 73 - JMAXIN = 19 - DEGIN = 5.0 - GO TO 8000 -C - 7029 IMAXIN = 145 - JMAXIN = 37 - DEGIN = 2.5 - GO TO 8000 -C - 7033 IMAXIN = 181 - JMAXIN = 46 - DEGIN = 2.0 - GO TO 8000 -C - 7045 IMAXIN = 97 - JMAXIN = 25 - DEGIN = 3.75 - GOTO 8000 -C -C SELECT OUTPUT LOLA GRID -C - 8000 IF (MAPOUT.EQ.21) GO TO 8021 - IF (MAPOUT.EQ.22) GO TO 8021 - IF (MAPOUT.EQ.29) GO TO 8029 - IF (MAPOUT.EQ.30) GO TO 8029 - IF (MAPOUT.EQ.33) GO TO 8033 - IF (MAPOUT.EQ.34) GO TO 8033 - IF (MAPOUT.EQ.45) GO TO 8045 - IF (MAPOUT.EQ.46) GO TO 8045 - IF (MAPOUT.EQ.500) GO TO 8500 - IF (MAPOUT.EQ.501) GO TO 8501 - IER = 8 - RETURN -C - 8021 IMINOU = 1 - IMAXOU = 73 - JMINOU = 1 - JMAXOU = 19 - DEGOU = 5. - GO TO 8700 -C - 8029 IMINOU = 1 - IMAXOU = 145 - JMINOU = 1 - JMAXOU = 37 - DEGOU = 2.5 - GO TO 8700 -C - 8033 IMINOU = 1 - IMAXOU = 181 - JMINOU = 1 - JMAXOU = 46 - DEGOU = 2.0 - GO TO 8700 -C - 8045 IMINOU = 1 - IMAXOU = 97 - JMINOU = 1 - JMAXOU = 25 - DEGOU = 3.75 - GOTO 8700 -C - 8500 IMINOU = 93 - IMAXOU = 117 - JMINOU = 1 - JMAXOU = 37 - DEGOU = 2.5 - GO TO 8700 -C - 8501 IMINOU = 116 - IMAXOU = 140 - JMINOU = 1 - JMAXOU = 46 - DEGOU = 2.0 - GO TO 8700 -C - 8700 IJOUT = 0 - RDEG = DEGOU/DEGIN - DO 8710 J=JMINOU, JMAXOU - XJIN = (J-1)*RDEG + 1. - DO 8710 I=IMINOU, IMAXOU - XIIN = (I-1)*RDEG + 1. - CALL W3FT01 - 1 (XIIN, XJIN, FIELD, D, IMAXIN, JMAXIN, 1, INTERP) - IJOUT = IJOUT + 1 - DATA(IJOUT) = D - 8710 CONTINUE - RETURN -C - END diff --git a/src/fim/FIMsrc/w3/w3ft33.f b/src/fim/FIMsrc/w3/w3ft33.f deleted file mode 100644 index 1c49852..0000000 --- a/src/fim/FIMsrc/w3/w3ft33.f +++ /dev/null @@ -1,146 +0,0 @@ - SUBROUTINE W3FT33(AIN,OUT,NSFLAG) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FT33 THICKEN THINNED WAFS GRIB GRID 37-44 -C PRGMMR: RALPH PETTERSON ORG: W/NMCXX DATE: 94-11-13 -C -C ABSTRACT: SUBROUTINE THICKENS ONE THINNED WAFS GRIB GRID TO A -C REAL ARRAY OF 5329 NUMBERS (73,73) 1.25 DEGREE GRID. -C -C PROGRAM HISTORY LOG: -C 94-??-?? RALPH PETERSON -C 94-11-07 R.E.JONES ADD DOC BLOCK, CHANGE CALL TO 3 -C PARAMETERS. REPLACE COS WITH TABLE -C LOOKUP. -C 95-06-02 RALPH PETERSON CHANGES TO CORRECT MISS-POSITION -C BETWEEN + OR - 8.75 N/S. -C 95-06-03 R.E.JONES CHANGES SO 8 ROWS WITH 73 VALUES -C ARE NOT THICKENED, 10% FASTER. -C -C USAGE: CALL W3FT33(AIN, OUT, NSFLAG) -C INPUT ARGUMENT LIST: -C AIN - REAL 3447 WORD ARRAY WITH UNPACKED THINNED WAFS -C GRIB TYPE 37-44. -C NSFLAG - INTEGER = 1 AIN IS WAFS GRIB GRID 37-40 N. HEMI. -C = -1 AIN IS WAFS GRIB GRID 41-44 S. HEMI. -C -C OUTPUT ARGUMENT LIST: -C OUT - REAL (73,73) WORD ARRAY WITH THICKENED WAFS GRIB -C GRID 37-44. -C -C REMARKS: THE POLE POINT FOR U AND V WIND COMPONENTS WILL HAVE ONLY -C ONE POINT. IF YOU NEED THE POLE ROW CORRECTED SEE PAGE 9 SECTION -C 1 IN OFFICE NOTE 388. YOU NEED BOTH U AND V TO MAKE THE -C CORRECTION. -C -C ATTRIBUTES: -C LANGUAGE: SiliconGraphics 5.2 FORTRAN 77 -C MACHINE: SiliconGraphics IRIS-4D/25, 35, INDIGO, Indy -C -C$$$ -C - PARAMETER (NX=73,NY=73) - PARAMETER (NIN=3447) -C - REAL AIN(*) - REAL OUT(NX,NY) -C - INTEGER IPOINT(NX) -C - SAVE -C - DATA IPOINT/ - & 73, 73, 73, 73, 73, 73, 73, 73, 72, 72, 72, 71, 71, 71, 70, - & 70, 69, 69, 68, 67, 67, 66, 65, 65, 64, 63, 62, 61, 60, 60, - & 59, 58, 57, 56, 55, 54, 52, 51, 50, 49, 48, 47, 45, 44, 43, - & 42, 40, 39, 38, 36, 35, 33, 32, 30, 29, 28, 26, 25, 23, 22, - & 20, 19, 17, 16, 14, 12, 11, 9, 8, 6, 5, 3, 2/ -C - NXM = NX - 1 - FNXM = FLOAT(NXM) -C -C TEST FOR GRIDS (37-40) -C - IF (NSFLAG.GT.0) THEN -C -C DO NOT THICKEN 8 ROWS WITH 73 VALUES, MOVE DATA -C TO OUT ARRAY. GRIDS (37-40) N. -C - IS = 0 - DO J = 1,8 - DO I = 1,NX - IS = IS + 1 - OUT(I,J) = AIN(IS) - END DO - END DO -C - IE = NX * 8 - DO J = 9,NY - NPOINT = IPOINT(J) - IS = IE + 1 - IE = IS + NPOINT - 1 - DPTS = (FLOAT(NPOINT)-1.) / FNXM - PW = 1.0 - PE = PW + DPTS - OUT(1,J) = AIN(IS) - VALW = AIN(IS) - VALE = AIN(IS+1) - DVAL = (VALE-VALW) - DO I = 2,NXM - WGHT = PE -FLOAT(IFIX(PE)) - OUT(I,J) = VALW + WGHT * DVAL - PW = PE - PE = PE + DPTS - IF (IFIX(PW).NE.IFIX(PE)) THEN - IS = IS + 1 - VALW = VALE - VALE = AIN(IS+1) - DVAL = (VALE - VALW) - END IF - END DO - OUT(NX,J) = AIN(IE) - END DO -C - ELSE -C -C DO NOT THICKEN 8 ROWS WITH 73 VALUES, MOVE DATA -C TO OUT ARRAY. GRIDS (41-44) S. -C - IS = NIN - (8 * NX) - DO J = 66,NY - DO I = 1,NX - IS = IS + 1 - OUT(I,J) = AIN(IS) - END DO - END DO -C - IE = 0 - DO J = 1,65 - NPOINT = IPOINT(74-J) - IS = IE + 1 - IE = IS + NPOINT - 1 - DPTS = (FLOAT(NPOINT)-1.) / FNXM - PW = 1.0 - PE = PW + DPTS - OUT(1,J) = AIN(IS) - VALW = AIN(IS) - VALE = AIN(IS+1) - DVAL = (VALE-VALW) - DO I = 2,NXM - WGHT = PE -FLOAT(IFIX(PE)) - OUT(I,J) = VALW + WGHT * DVAL - PW = PE - PE = PE + DPTS - IF (IFIX(PW).NE.IFIX(PE)) THEN - IS = IS + 1 - VALW = VALE - VALE = AIN(IS+1) - DVAL = (VALE - VALW) - END IF - END DO - OUT(NX,J) = AIN(IE) - END DO - END IF -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft38.f b/src/fim/FIMsrc/w3/w3ft38.f deleted file mode 100644 index a75a0e4..0000000 --- a/src/fim/FIMsrc/w3/w3ft38.f +++ /dev/null @@ -1,105 +0,0 @@ - SUBROUTINE W3FT38(FLN,GN,PLN,FL,WORK,TRIGS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FT38 COMPUTES 2.5 X 2.5 N. HEMI. GRID-SCALER -C AUTHOR: R.E.JONES ORG: W323 DATE: 93-07-23 -C -C ABSTRACT: COMPUTES 2.5 X 2.5 N. HEMI. GRID OF 145 X 37 POINTS -C FROM SPECTRAL COEFFICIENTS IN A RHOMBOIDAL 30 RESOLUTION -C REPRESENTING A SCALER FIELD. -C -C PROGRAM HISTORY LOG: -C 93-07-23 R.E.JONES NEW VERSION OF W3FT08, TAKES OUT W3FA12 -C MAKES PLN 3 DIMENSIONS, PLN IS COMPUTED -C ONE TIME IN MAIN PROGRAM, TRADES MEMORY -C FOR MORE SPEED. W3FA12 USED 70% OF CPU TIME. -C -C USAGE: CALL W3FT38(FLN,GN,PLN,FL,WORK,TRIGS) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C FLN ARG LIST 961 COMPLEX COEFF. -C PLN ARG LIST (32,31,37) REAL SPACE WITH LEGENDRE POLYNOMIALS -C COMPUTED BY W3FA12. -C FL ARG LIST 31 COMPLEX SPACE FOR FOURIER COEFF. -C WORK ARG LIST 144 REAL WORK SPACE FOR SUBR. W3FT12 -C TRIGS ARG LIST 216 PRECOMPUTED TRIG FUNCS. USED -C IN W3FT12, COMPUTED BY W3FA13 -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C GN ARG LIST (145,37) GRID VALUES. -C 5365 POINT GRID IS TYPE 29 OR 1D HEX O.N. 84 -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C AIMAG CMPLX REAL SYSTEM -C W3FT12 W3LIB -C -C WARNING: W3FT08 WAS OPTIMIZED TO RUN IN A SMALL AMOUNT OF -C MEMORY, IT WAS NOT OPTIMIZED FOR SPEED, 70 PERCENT OF THE TIME WAS -C USED BY SUBROUTINE W3FA12 COMPUTING THE LEGENDRE POLYNOMIALS. SINCE -C THE LEGENDRE POLYNOMIALS ARE CONSTANT THEY NEED TO BE COMPUTED -C ONLY ONCE IN A PROGRAM. BY MOVING W3FA12 TO THE MAIN PROGRAM AND -C COMPUTING PLN AS A (32,31,37) ARRAY AND CHANGING THIS SUBROUTINE -C TO USE PLN AS A THREE DIMENSION ARRAY THE RUNNING TIME WAS CUT -C 70 PERCENT. ADD FOLLOWING CODE TO MAIN PROGRAM TO COMPUTE EPS, PLN, -C TRIGS, AND RCOS ONE TIME IN PROGRAM. -C -C DOUBLE PRECISION EPS(992) (REAL ON CRAY) -C DOUBLE PRECISION COLRA (REAL ON CRAY) -C -C REAL PLN( 32, 31, 37 ) -C REAL RCOS(37) -C REAL TRIGS(216) -C -C DATA PI /3.14159265/ -C -C DRAD = 2.5 * PI / 180.0 -C CALL W3FA11(EPS,30) -C CALL W3FA13(TRIGS,RCOS) -C DO LAT = 1,37 -C COLRA = (LAT - 1) * DRAD -C CALL W3FA12 (PLN(1,1,LAT), COLRA, 30, EPS) -C END DO -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/864, CRAY Y-MP EL2/128 -C -C$$$ -C - COMPLEX FL( 31 ) - COMPLEX FLN( 31 , 31 ) -C - REAL GN(145,37) - REAL PLN( 32, 31, 37 ) - REAL TRIGS(216) - REAL WORK(144) -C - SAVE -C - DO 400 LAT = 1,37 - LATN = 38 - LAT -C - DO 100 L = 1, 31 - FL(L) = (0.,0.) - 100 CONTINUE -C - DO 300 L = 1, 31 - DO 200 I = 1, 31 - FL(L) = FL(L) + CMPLX(PLN(I,L,LAT) * REAL(FLN(I,L)) , - & PLN(I,L,LAT) * AIMAG(FLN(I,L)) ) - 200 CONTINUE -C - 300 CONTINUE -C - CALL W3FT12(FL,WORK,GN(1,LATN),TRIGS) -C - 400 CONTINUE -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft39.f b/src/fim/FIMsrc/w3/w3ft39.f deleted file mode 100644 index b42fb27..0000000 --- a/src/fim/FIMsrc/w3/w3ft39.f +++ /dev/null @@ -1,117 +0,0 @@ - SUBROUTINE W3FT39(VLN,GN,PLN,FL,WORK,TRIGS,RCOS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FT39 COMPUTES 2.5X2.5 N. HEMI. GRID-VECTOR -C AUTHOR: R.E.JONES ORG: W323 DATE: 84-06-27 -C -C ABSTRACT: COMPUTES 2.5 X 2.5 N. HEMI. GRID OF 145 X 37 POINTS -C FROM SPECTRAL COEFFICIENTS IN A RHOMBOIDAL 30 RESOLUTION -C REPRESENTING A VECTOR FIELD. -C -C PROGRAM HISTORY LOG: -C 93-07-23 R.E.JONES NEW VERSION OF W3FT09, TAKES OUT W3FA12 -C MAKES PLN 3 DIMENSIONS, PLN IS COMPUTED -C ONE TIME IN MAIN PROGRAM, TRADES MEMORY -C FOR MORE SPEED. W3FA12 USED 70% OF CPU TIME. -C -C USAGE: CALL W3FT39(VLN,GN,PLN,FL,WORK,TRIGS,RCOS) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C VLN ARG LIST 992 COMPLEX COEFF. -C PLN ARG LIST (32,31,37) REAL SPACE WITH LEGENDRE POLYNOMIALS -C COMPUTED BY W3FA12. -C FL ARG LIST 31 COMPLEX SPACE FOR FOURIER COEFF. -C WORK ARG LIST 144 WORK SPACE FOR SUBR. W3FT12 -C TRIGS ARG LIST 216 PRECOMPUTED TRIG FUNCS. USED -C IN W3FT12, COMPUTED BY W3FA13 -C RCOS ARG LIST 37 RECIPROCAL COSINE LATITUDES OF -C 2.5 X 2.5 GRID MUST BE COMPUTED BEFORE -C FIRST CALL TO W3FT11 USING SR W3FA13. -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C GN ARG LIST (145,37) GRID VALUES. -C 5365 POINT GRID IS TYPE 29 OR 1D O.N. 84 -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C AIMAG CMPLX REAL SYSTEM -C W3FT12 W3LIB -C -C WARNING: W3FT09 WAS OPTIMIZED TO RUN IN A SMALL AMOUNT OF -C MEMORY, IT WAS NOT OPTIMIZED FOR SPEED, 70 PERCENT OF THE TIME WAS -C USED BY SUBROUTINE W3FA12 COMPUTING THE LEGENDRE POLYNOMIALS. SINCE -C THE LEGENDRE POLYNOMIALS ARE CONSTANT THEY NEED TO BE COMPUTED -C ONLY ONCE IN A PROGRAM. BY MOVING W3FA12 TO THE MAIN PROGRAM AND -C COMPUTING PLN AS A (32,31,37) ARRAY AND CHANGING THIS SUBROUTINE -C TO USE PLN AS A THREE DIMENSION ARRAY THE RUNNING TIME WAS CUT -C 70 PERCENT. ADD FOLLOWING CODE TO MAIN PROGRAM TO COMPUTE EPS, PLN, -C TRIGS, AND RCOS ONE TIME IN PROGRAM. -C -C DOUBLE PRECISION EPS(992) -C DOUBLE PRECISION COLRA -C -C REAL PLN( 32, 31, 37 ) -C REAL RCOS(37) -C REAL TRIGS(216) -C -C DATA PI /3.14159265/ -C -C DRAD = 2.5 * PI / 180.0 -C CALL W3FA11(EPS,30) -C CALL W3FA13(TRIGS,RCOS) -C DO LAT = 1,37 -C COLRA = (LAT - 1) * DRAD -C CALL W3FA12 (PLN(1,1,LAT), COLRA, 30, EPS) -C END DO -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/864, CRAY Y-MP EL2/128 -C -C$$$ -C - COMPLEX FL( 31 ) - COMPLEX VLN( 32 , 31 ) -C - REAL GN(145,37) - REAL PLN( 32, 31, 37 ) - REAL RCOS(37) - REAL TRIGS(216) - REAL WORK(144) -C - SAVE -C - DO 400 LAT = 2,37 - LATN = 38 - LAT -C - DO 100 L = 1, 31 - FL(L) = (0.,0.) - 100 CONTINUE -C - DO 300 L = 1, 31 -C - DO 200 I = 1, 32 - FL(L) = FL(L) + CMPLX(PLN(I,L,LAT) * REAL(VLN(I,L)), - & PLN(I,L,LAT) * AIMAG(VLN(I,L)) ) - 200 CONTINUE -C - FL(L)=CMPLX(REAL(FL(L))*RCOS(LAT),AIMAG(FL(L))*RCOS(LAT)) - 300 CONTINUE -C - CALL W3FT12(FL,WORK,GN(1,LATN),TRIGS) -C - 400 CONTINUE -C -C*** POLE ROW=CLOSEST LATITUDE ROW -C - DO 500 I = 1,145 - GN(I,37) = GN(I,36) - 500 CONTINUE -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft40.f b/src/fim/FIMsrc/w3/w3ft40.f deleted file mode 100644 index 3ea4887..0000000 --- a/src/fim/FIMsrc/w3/w3ft40.f +++ /dev/null @@ -1,109 +0,0 @@ - SUBROUTINE W3FT40(FLN,GN,PLN,FL,WORK,TRIGS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FT40 COMPUTES 2.5 X 2.5 S. HEMI. GRID-SCALER -C AUTHOR: JONES,R.E. ORG: W323 DATE: 93-07-23 -C -C ABSTRACT: COMPUTES 2.5 X 2.5 S. HEMI. GRID OF 145 X 37 POINTS -C FROM SPECTRAL COEFFICIENTS IN A RHOMBOIDAL 30 RESOLUTION -C REPRESENTING A SCALER FIELD. -C -C PROGRAM HISTORY LOG: -C 93-07-23 R.E.JONES NEW VERSION OF W3FT10, TAKES OUT W3FA12 -C MAKES PLN 3 DIMENSIONS, PLN IS COMPUTED -C ONE TIME IN MAIN PROGRAM, TRADES MEMORY -C FOR MORE SPEED. W3FA12 USED 70% OF CPU TIME. -C -C USAGE: CALL W3FT40(FLN,GN,PLN,FL,WORK,TRIGS) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C FLN ARG LIST 961 COMPLEX COEFF. -C PLN ARG LIST (32,31,37) REAL SPACE WITH LEGENDRE POLYNOMIALS -C COMPUTED BY W3FA12. -C FL ARG LIST 31 COMPLEX SPACE FOR FOURIER COEFF. -C WORK ARG LIST 144 REAL WORK SPACE FOR SUBR. W3FT12 -C TRIGS ARG LIST 216 PRECOMPUTED TRIG FUNCS. USED -C IN W3FT12, COMPUTED BY W3FA13 -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C GN ARG LIST (145,37) GRID VALUES. -C 5365 POINT GRID IS TYPE 30 OR 1E O.N. 84 -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C AIMAG CMPLX REAL SYSTEM -C W3FT12 W3LIB -C -C WARNING: W3FT10 WAS OPTIMIZED TO RUN IN A SMALL AMOUNT OF -C MEMORY, IT WAS NOT OPTIMIZED FOR SPEED, 70 PERCENT OF THE TIME WAS -C USED BY SUBROUTINE W3FA12 COMPUTING THE LEGENDRE POLYNOMIALS. SINCE -C THE LEGENDRE POLYNOMIALS ARE CONSTANT THEY NEED TO BE COMPUTED -C ONLY ONCE IN A PROGRAM. BY MOVING W3FA12 TO THE MAIN PROGRAM AND -C COMPUTING PLN AS A (32,31,37) ARRAY AND CHANGING THIS SUBROUTINE -C TO USE PLN AS A THREE DIMENSION ARRAY THE RUNNING TIME WAS CUT -C 70 PERCENT. ADD FOLLOWING CODE TO MAIN PROGRAM TO COMPUTE EPS, PLN, -C TRIGS, AND RCOS ONE TIME IN PROGRAM. -C -C DOUBLE PRECISION EPS(992) [CHANGE TO REAL ON CRAY] -C DOUBLE PRECISION COLRA [CHANGE TO REAL ON CRAY] -C -C REAL PLN( 32, 31, 37 ) -C REAL RCOS(37) -C REAL TRIGS(216) -C -C DATA PI /3.14159265/ -C -C DRAD = 2.5 * PI / 180.0 -C CALL W3FA11(EPS,30) -C CALL W3FA13(TRIGS,RCOS) -C DO LAT = 1,37 -C COLRA = (LAT - 1) * DRAD -C CALL W3FA12 (PLN(1,1,LAT), COLRA, 30, EPS) -C END DOC -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/864, CRAY Y-MP EL2/128 -C -C$$$ -C - COMPLEX FL( 31 ) - COMPLEX FLN( 31 , 31 ) -C - REAL GN(145,37) - REAL PLN( 32, 31, 37 ) - REAL TRIGS(216) - REAL WORK(144) -C - SAVE -C - DO 400 LAT = 1,37 -C - DO 100 L = 1, 31 - FL(L) = (0.,0.) - 100 CONTINUE -C - DO 300 L = 1, 31 - I = 1 - FL(L) = FL(L)+CMPLX(PLN(I,L,LAT) * REAL(FLN(I,L)) , - & PLN(I,L,LAT) * AIMAG(FLN(I,L)) ) -C - DO 200 I = 2, 30 ,2 - FL(L) = FL(L)-CMPLX(PLN(I,L,LAT) * REAL(FLN(I,L)) , - & PLN(I,L,LAT) * AIMAG(FLN(I,L)) ) - FL(L) = FL(L)+CMPLX(PLN(I+1,L,LAT) * REAL(FLN(I+1,L)), - & PLN(I+1,L,LAT) * AIMAG(FLN(I+1,L))) - 200 CONTINUE -C - 300 CONTINUE -C - CALL W3FT12(FL,WORK,GN(1,LAT ),TRIGS) - 400 CONTINUE -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft41.f b/src/fim/FIMsrc/w3/w3ft41.f deleted file mode 100644 index 782cec3..0000000 --- a/src/fim/FIMsrc/w3/w3ft41.f +++ /dev/null @@ -1,118 +0,0 @@ - SUBROUTINE W3FT41(VLN,GN,PLN,FL,WORK,TRIGS,RCOS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FT41 COMPUTES 2.5X2.5 S. HEMI. GRID VECTOR -C AUTHOR: R.E.JONES ORG: W323 DATE: 80-11-20 -C -C ABSTRACT: COMPUTES 2.5 X 2.5 S. HEMI. GRID OF 145 X 37 POINTS -C FROM SPECTRAL COEFFICIENTS IN A RHOMBOIDAL 30 RESOLUTION -C REPRESENTING A VECTOR FIELD. -C -C PROGRAM HISTORY LOG: -C 93-07-23 R.E.JONES NEW VERSION OF W3FT11, TAKES OUT W3FA12 -C MAKES PLN 3 DIMENSIONS, PLN IS COMPUTED -C ONE TIME IN MAIN PROGRAM, TRADES MEMORY -C FOR MORE SPEED. W3FA12 USED 70% OF CPU TIME. -C -C USAGE: CALL W3FT41(VLN,GN,PLN,FL,WORK,TRIGS,RCOS) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C VLN ARG LIST 992 COMPLEX COEFF. -C PLN ARG LIST (32,31,37) REAL SPACE WITH LEGENDRE POLYNOMIALS -C COMPUTED BY W3FA12. -C FL ARG LIST 31 COMPLEX SPACE FOR FOURIER COEFF. -C WORK ARG LIST 144 REAL WORK SPACE FOR SUBR. W3FT12 -C TRIGS ARG LIST 216 PRECOMPUTED TRIG FUNCS. USED -C IN W3FT12, COMPUTED BY W3FA13 -C RCOS ARG LIST 37 RECIPROCAL COSINE LATITUDES OF -C 2.5 X 2.5 GRID MUST BE COMPUTED BEFORE -C FIRST CALL TO W3FT11 USING SUBR. W3FA13. -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C GN ARG LIST (145,37) GRID VALUES. -C 5365 POINT GRID IS TYPE 30 OR 1E HEX O.N. 84 -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C AIMAG CMPLX REAL SYSTEM -C W3FT12 W3LIB -C -C WARNING: W3FT11 WAS OPTIMIZED TO RUN IN A SMALL AMOUNT OF -C MEMORY, IT WAS NOT OPTIMIZED FOR SPEED, 70 PERCENT OF THE TIME WAS -C USED BY SUBROUTINE W3FA12 COMPUTING THE LEGENDRE POLYNOMIALS. SINCE -C THE LEGENDRE POLYNOMIALS ARE CONSTANT THEY NEED TO BE COMPUTED -C ONLY ONCE IN A PROGRAM. BY MOVING W3FA12 TO THE MAIN PROGRAM AND -C COMPUTING PLN AS A (32,31,37) ARRAY AND CHANGING THIS SUBROUTINE -C TO USE PLN AS A THREE DIMENSION ARRAY THE RUNNING TIME WAS CUT -C 70 PERCENT. ADD FOLLOWING CODE TO MAIN PROGRAM TO COMPUTE EPS, PLN, -C TRIGS, AND RCOS ONE TIME IN PROGRAM. -C -C DOUBLE PRECISION EPS(992) -C DOUBLE PRECISION COLRA -C -C REAL PLN( 32, 31, 37 ) -C REAL RCOS(37) -C REAL TRIGS(216) -C -C DATA PI /3.14159265/ -C -C DRAD = 2.5 * PI / 180.0 -C CALL W3FA11(EPS,30) -C CALL W3FA13(TRIGS,RCOS) -C DO LAT = 1,37 -C COLRA = (LAT - 1) * DRAD -C CALL W3FA12 (PLN(1,1,LAT), COLRA, 30, EPS) -C END DO -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/864, CRAY Y-MP EL2/128 -C -C$$$ -C - COMPLEX FL( 31 ) - COMPLEX VLN( 32 , 31 ) -C - REAL GN(145,37) - REAL PLN( 32, 31, 37 ) - REAL RCOS(37) - REAL TRIGS(216) - REAL WORK(144) -C - SAVE -C - DO 400 LAT = 2,37 -C - DO 100 L = 1, 31 - FL(L) = (0.,0.) - 100 CONTINUE -C - DO 300 L = 1, 31 -C - DO 200 I = 1, 31 ,2 - FL(L) = FL(L)+CMPLX(PLN(I,L,LAT) * REAL(VLN(I,L)) , - & PLN(I,L,LAT) * AIMAG(VLN(I,L)) ) - FL(L) = FL(L)-CMPLX(PLN(I+1,L,LAT) * REAL(VLN(I+1,L)), - & PLN(I+1,L,LAT) * AIMAG(VLN(I+1,L))) - 200 CONTINUE -C - FL(L) = CMPLX(REAL(FL(L))*RCOS(LAT),AIMAG(FL(L))*RCOS(LAT)) -C - 300 CONTINUE -C - CALL W3FT12(FL,WORK,GN(1,LAT ),TRIGS) -C - 400 CONTINUE -C -C*** POLE ROW = CLOSEST LATITUDE ROW -C - DO 500 I = 1,145 - GN(I,1) = GN(I,2) - 500 CONTINUE - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3ft43v.f b/src/fim/FIMsrc/w3/w3ft43v.f deleted file mode 100644 index 3dd236e..0000000 --- a/src/fim/FIMsrc/w3/w3ft43v.f +++ /dev/null @@ -1,270 +0,0 @@ - SUBROUTINE W3FT43V(ALOLA,APOLA,INTERP) -C$$$ SUBROUTINE DOCUMENTATION BLOCK *** -C -C SUBROUTINE: W3FT43V CONVERT (361,181) GRID TO (65,65) N. HEMI. GRID -C AUTHOR: JONES,R.E. ORG: W342 DATE: 93-10-19 -C -C ABSTRACT: CONVERT A GLOBAL 1.0 DEGREE LAT.,LON. 361 BY -C 181 GRID TO A POLAR STEREOGRAPHIC 65 BY 65 GRID. THE POLAR -C STEREOGRAPHIC MAP PROJECTION IS TRUE AT 60 DEG. N. , THE MESH -C LENGTH IS 381 KM. AND THE ORIENTION IS 80 DEG. W. -C -C PROGRAM HISTORY LOG: -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C -C USAGE: CALL W3FT43V(ALOLA,APOLA,INTERP) -C -C INPUT ARGUMENTS: ALOLA - 361*181 GRID 1.0 DEG. LAT,LON GRID N. HEMI. -C 65341 POINT GRID. 360 * 181 ONE DEGREE -C GRIB GRID 3 WAS FLIPPED, GREENWISH ADDED -C TO RIGHT SIDE TO MAKE 361 * 181. -C INTERP - 1 LINEAR INTERPOLATION , NE.1 BIQUADRATIC -C -C INPUT FILES: NONE -C -C OUTPUT ARGUMENTS: APOLA - 65*65 GRID OF NORTHERN HEMISPHERE. -C 4225 POINT GRID IS O.N.84 TYPE 27 OR 1B HEX -C -C OUTPUT FILES: ERROR MESSAGE TO FORTRAN OUTPUT FILE -C -C WARNINGS: -C -C 1. W1 AND W2 ARE USED TO STORE SETS OF CONSTANTS WHICH ARE -C REUSABLE FOR REPEATED CALLS TO THE SUBROUTINE. 20 OTHER ARRAYS -C ARE SAVED AND REUSED ON THE NEXT CALLS TO THE SUBROUTINE. -C -C 2. WIND COMPONENTS ARE NOT ROTATED TO THE 65*65 GRID ORIENTATION -C AFTER INTERPOLATION. YOU MAY USE W3FC08 TO DO THIS. -C -C 3. THE ABOUT 1100 POINTS BELOW THE EQUATOR WILL BE IN THIS MAP. -C -C RETURN CONDITIONS: NORMAL SUBROUTINE EXIT -C -C SUBPROGRAMS CALLED: -C UNIQUE : NONE -C -C LIBRARY: ASIN , ATAN2 -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916/256, Y-MP8/864, Y-MP EL92/256, J916/2048 -C -C$$$ -C - PARAMETER (NPTS=4225,II=65,JJ=65) - PARAMETER (ORIENT=80.0,IPOLE=33,JPOLE=33) - PARAMETER (XMESH=381.0) -C - REAL R2(NPTS), WLON(NPTS) - REAL XLAT(NPTS), XI(II,JJ), XJ(II,JJ) - REAL XII(NPTS), XJJ(NPTS), ANGLE(NPTS) - REAL ALOLA(361,181), APOLA(NPTS), ERAS(NPTS,4) - REAL W1(NPTS), W2(NPTS) - REAL XDELI(NPTS), XDELJ(NPTS) - REAL XI2TM(NPTS), XJ2TM(NPTS) -C - INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4) - INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS) -C - LOGICAL LIN -C - SAVE -C - EQUIVALENCE (XI(1,1),XII(1)),(XJ(1,1),XJJ(1)) -C - DATA DEGPRD/57.2957795/ - DATA EARTHR/6371.2/ - DATA INTRPO/99/ - DATA ISWT /0/ -C - LIN = .FALSE. - IF (INTERP.EQ.1) LIN = .TRUE. -C - IF (ISWT.EQ.1) GO TO 900 -C - DEG = 1.0 - GI2 = (1.86603 * EARTHR) / XMESH - GI2 = GI2 * GI2 -C -C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB05 IN LINE -C - DO 100 J = 1,JJ - XJ1 = J - JPOLE - DO 100 I = 1,II - XI(I,J) = I - IPOLE - XJ(I,J) = XJ1 - 100 CONTINUE -C - DO 200 KK = 1,NPTS - R2(KK) = XJJ(KK) * XJJ(KK) + XII(KK) * XII(KK) - XLAT(KK) = DEGPRD * - & ASIN((GI2 - R2(KK)) / (GI2 + R2(KK))) - 200 CONTINUE -C - XII(2113) = 1.0 - DO 300 KK = 1,NPTS - ANGLE(KK) = DEGPRD * ATAN2(XJJ(KK),XII(KK)) - 300 CONTINUE -C - DO 400 KK = 1,NPTS - IF (ANGLE(KK).LT.0.0) ANGLE(KK) = ANGLE(KK) + 360.0 - 400 CONTINUE -C - DO 500 KK = 1,NPTS - WLON(KK) = 270.0 + ORIENT - ANGLE(KK) - 500 CONTINUE -C - DO 600 KK = 1,NPTS - IF (WLON(KK).LT.0.0) WLON(KK) = WLON(KK) + 360.0 - 600 CONTINUE -C - DO 700 KK = 1,NPTS - IF (WLON(KK).GE.360.0) WLON(KK) = WLON(KK) - 360.0 - 700 CONTINUE -C - XLAT(2113) = 90.0 - WLON(2113) = 0.0 -C - DO 800 KK = 1,NPTS - W1(KK) = (360.0 - WLON(KK)) / DEG + 1.0 - W2(KK) = XLAT(KK) / DEG + 91.0 - 800 CONTINUE -C - ISWT = 1 - INTRPO = INTERP - GO TO 1000 -C -C AFTER THE 1ST CALL TO W3FT43V TEST INTERP, IF IT HAS -C CHANGED RECOMPUTE SOME CONSTANTS -C - 900 CONTINUE - IF (INTERP.EQ.INTRPO) GO TO 2100 - INTRPO = INTERP -C - 1000 CONTINUE - DO 1100 K = 1,NPTS - IV(K) = W1(K) - JV(K) = W2(K) - XDELI(K) = W1(K) - IV(K) - XDELJ(K) = W2(K) - JV(K) - IP1(K) = IV(K) + 1 - JY(K,3) = JV(K) + 1 - JY(K,2) = JV(K) - 1100 CONTINUE -C - IF (LIN) GO TO 1400 -C - DO 1200 K = 1,NPTS - IP2(K) = IV(K) + 2 - IM1(K) = IV(K) - 1 - JY(K,1) = JV(K) - 1 - JY(K,4) = JV(K) + 2 - XI2TM(K) = XDELI(K) * (XDELI(K) - 1.0) * .25 - XJ2TM(K) = XDELJ(K) * (XDELJ(K) - 1.0) * .25 - 1200 CONTINUE -C - DO 1300 KK = 1,NPTS - IF (IV(KK).EQ.1) THEN - IP2(KK) = 3 - IM1(KK) = 360 - ELSE IF (IV(KK).EQ.360) THEN - IP2(KK) = 2 - IM1(KK) = 359 - ENDIF - 1300 CONTINUE -C - 1400 CONTINUE -C - IF (LIN) GO TO 1700 -C - DO 1500 KK = 1,NPTS - IF (JV(KK).GE.180) XJ2TM(KK) = 0.0 - 1500 CONTINUE -C - DO 1600 KK = 1,NPTS - IF (IP2(KK).LT.1) IP2(KK) = 1 - IF (IM1(KK).LT.1) IM1(KK) = 1 - IF (IP2(KK).GT.361) IP2(KK) = 361 - IF (IM1(KK).GT.361) IM1(KK) = 361 - 1600 CONTINUE -C - 1700 CONTINUE - DO 1800 KK = 1,NPTS - IF (IV(KK).LT.1) IV(KK) = 1 - IF (IP1(KK).LT.1) IP1(KK) = 1 - IF (IV(KK).GT.361) IV(KK) = 361 - IF (IP1(KK).GT.361) IP1(KK) = 361 - 1800 CONTINUE -C -C LINEAR INTERPOLATION -C - DO 1900 KK = 1,NPTS - IF (JY(KK,2).GT.181) JY(KK,2) = 181 - IF (JY(KK,3).GT.181) JY(KK,3) = 181 - 1900 CONTINUE -C - IF (.NOT.LIN) THEN - DO 2000 KK = 1,NPTS - IF (JY(KK,1).GT.181) JY(KK,1) = 181 - IF (JY(KK,4).GT.181) JY(KK,4) = 181 - 2000 CONTINUE - ENDIF -C - 2100 CONTINUE - IF (LIN) THEN -C -C LINEAR INTERPOLATION -C - DO 2200 KK = 1,NPTS - ERAS(KK,2) = (ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) - ERAS(KK,3) = (ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) - 2200 CONTINUE -C - DO 2300 KK = 1,NPTS - APOLA(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) - 2300 CONTINUE -C - ELSE -C -C QUADRATIC INTERPOLATION -C - DO 2400 KK = 1,NPTS - ERAS(KK,1)=(ALOLA(IP1(KK),JY(KK,1))-ALOLA(IV(KK),JY(KK,1))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,1)) + - & ( ALOLA(IM1(KK),JY(KK,1)) - ALOLA(IV(KK),JY(KK,1)) - & - ALOLA(IP1(KK),JY(KK,1))+ALOLA(IP2(KK),JY(KK,1))) - & * XI2TM(KK) - ERAS(KK,2)=(ALOLA(IP1(KK),JY(KK,2))-ALOLA(IV(KK),JY(KK,2))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,2)) + - & ( ALOLA(IM1(KK),JY(KK,2)) - ALOLA(IV(KK),JY(KK,2)) - & - ALOLA(IP1(KK),JY(KK,2))+ALOLA(IP2(KK),JY(KK,2))) - & * XI2TM(KK) - ERAS(KK,3)=(ALOLA(IP1(KK),JY(KK,3))-ALOLA(IV(KK),JY(KK,3))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,3)) + - & ( ALOLA(IM1(KK),JY(KK,3)) - ALOLA(IV(KK),JY(KK,3)) - & - ALOLA(IP1(KK),JY(KK,3))+ALOLA(IP2(KK),JY(KK,3))) - & * XI2TM(KK) - ERAS(KK,4)=(ALOLA(IP1(KK),JY(KK,4))-ALOLA(IV(KK),JY(KK,4))) - & * XDELI(KK) + ALOLA(IV(KK),JY(KK,4)) + - & ( ALOLA(IM1(KK),JY(KK,4)) - ALOLA(IV(KK),JY(KK,4)) - & - ALOLA(IP1(KK),JY(KK,4))+ALOLA(IP2(KK),JY(KK,4))) - & * XI2TM(KK) - 2400 CONTINUE -C - DO 2500 KK = 1,NPTS - APOLA(KK) = ERAS(KK,2) + (ERAS(KK,3) - ERAS(KK,2)) - & * XDELJ(KK) + (ERAS(KK,1) - ERAS(KK,2) - & - ERAS(KK,3) + ERAS(KK,4)) * XJ2TM(KK) - 2500 CONTINUE -C - ENDIF -C -C SET POLE POINT , WMO STANDARD FOR U OR V -C - APOLA(2113) = ALOLA(181,181) -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3locdat.f b/src/fim/FIMsrc/w3/w3locdat.f deleted file mode 100644 index d88094e..0000000 --- a/src/fim/FIMsrc/w3/w3locdat.f +++ /dev/null @@ -1,43 +0,0 @@ -!----------------------------------------------------------------------- - subroutine w3locdat(idat) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: W3LOCDAT RETURN THE LOCAL DATE AND TIME -! AUTHOR: MARK IREDELL ORG: WP23 DATE: 98-01-05 -! -! ABSTRACT: THIS SUBPROGRAM RETURNS THE LOCAL DATE AND TIME -! IN THE NCEP ABSOLUTE DATE AND TIME DATA STRUCTURE. -! -! PROGRAM HISTORY LOG: -! 98-01-05 MARK IREDELL -! 1999-04-28 Gilbert - added a patch to check for the proper -! UTC offset. Needed until the IBM bug -! in date_and_time is fixed. The patch -! can then be removed. See comments in -! the section blocked with "&&&&&&&&&&&". -! 1999-08-12 Gilbert - Changed so that czone variable is saved -! and the system call is only done for -! first invocation of this routine. -! -! USAGE: CALL W3LOCDAT(IDAT) -! -! OUTPUT VARIABLES: -! IDAT INTEGER (8) NCEP ABSOLUTE DATE AND TIME -! (YEAR, MONTH, DAY, TIME ZONE, -! HOUR, MINUTE, SECOND, MILLISECOND) -! -! SUBPROGRAMS CALLED: -! DATE_AND_TIME FORTRAN 90 SYSTEM DATE INTRINSIC -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! -!$$$ - integer idat(8) - character cdate*8,ctime*10,czone*5 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! get local date and time but use the character time zone - call date_and_time(cdate,ctime,czone,idat) - read(czone,'(i5)') idat(4) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end diff --git a/src/fim/FIMsrc/w3/w3log.f b/src/fim/FIMsrc/w3/w3log.f deleted file mode 100644 index fe4fa70..0000000 --- a/src/fim/FIMsrc/w3/w3log.f +++ /dev/null @@ -1,2 +0,0 @@ - subroutine w3log - end diff --git a/src/fim/FIMsrc/w3/w3miscan.f b/src/fim/FIMsrc/w3/w3miscan.f deleted file mode 100644 index 38d984d..0000000 --- a/src/fim/FIMsrc/w3/w3miscan.f +++ /dev/null @@ -1,1854 +0,0 @@ -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3MISCAN READS 1 SSM/I SCAN LINE FROM BUFR D-SET -C PRGMMR: KEYSER ORG: NP22 DATE: 2004-09-12 -C -C ABSTRACT: READS ONE SSM/I SCAN LINE (64 RETRIEVALS) FROM THE NCEP -C BUFR SSM/I DUMP FILE. EACH SCAN IS TIME CHECKED AGAINST THE -C USER-REQUESTED TIME WINDOW AND SATELLITE ID COMBINATIONS. WHEN A -C VALID SCAN IS READ THE PROGRAM RETURNS TO THE CALLING PROGRAM. -C THE USER MUST PASS IN THE TYPE OF THE INPUT SSM/I DUMP FILE, -C EITHER DERIVED PRODUCTS (REGARDLESS OF SOURCE) OR BRIGHTNESS -C TEMPERATURES (7-CHANNELS). IF THE LATTER IS CHOSEN, THE USER -C HAS THE FURTHER OPTION OF PROCESSING, IN ADDITION TO THE -C BRIGHTNESS TEMPERATURES, IN-LINE CALCULATION OF WIND SPEED -C PRODUCT VIA THE GOODBERLET ALGORITHM, AND/OR IN-LINE CALCULATION -C OF BOTH WIND SPEED AND TOTAL COLUMN PRECIPITABLE WATER (TPW) -C PRODUCTS USING THE NEURAL NET 3 ALGORITHM. IF THE WIND SPEED -C OR TPW IS CALCULATED HERE (EITHER ALGORITHM), THIS SUBROUTINE -C WILL CHECK FOR BRIGHTNESS TEMPERATURES OUTSIDE OF A PRESET RANGE -C AND WILL RETURN A MISSING WIND SPEED/TPW IF ANY B. TEMP IS -C UNREASONABLE. ALSO, FOR CALCULATED WIND SPEEDS AND TPW, THIS -C PROGRAM WILL CHECK TO SEE IF THE B. TEMPS ARE OVER LAND OR ICE, -C AND IF THEY ARE IT WILL ALSO RETURN MISSING VALUES SINCE THESE -C DATA ARE VALID ONLY OVER OCEAN. -C -C PROGRAM HISTORY LOG: -C 1996-07-30 D. A. KEYSER -- ORIGINAL AUTHOR - SUBROUTINE IS A -C MODIFIED VERSION OF W3LIB W3FI86 WHICH READ ONE SCAN -C LINE FROM THE 30-ORBIT SHARED PROCESSING DATA SETS -C 1997-05-22 D. A. KEYSER -- CRISIS FIX TO ACCOUNT FOR CLON NOW -C RETURNED FROM BUFR AS -180 TO 0 (WEST) OR 0 TO 180 -C (EAST), USED TO RETURN AS 0 TO 360 EAST WHICH WAS NOT -C THE BUFR STANDARD -C 1998-01-28 D. A. KEYSER -- REPLACED NEURAL NET 2 ALGORITHM WHICH -C CALCULATED ONLY WIND SPEED PRODUCT WITH NEURAL NET 3 -C ALGORITHM WHICH CALCULATES BOTH WIND SPEED AND TOTAL -C PRECIPITABLE WATER PRODUCTS (AMONG OTHERS) BUT, UNLIKE -C NN2, DOES NOT RETURN A RAIN FLAG VALUE (IT DOES SET -C ALL RETRIEVALS TO MISSING THAT FAIL RAIN FLAG AND ICE -C CONTAMINATION TESTS) -C 1998-03-30 D. A. KEYSER -- MODIFIED TO HANDLE NEURAL NET 3 SSM/I -C PRODUCTS INPUT IN A PRODUCTS BUFR DATA DUMP FILE; NOW -C PRINTS OUT NUMBER OF SCANS PROCESSED BY SATELLITE -C NUMBER IN FINAL SUMMARY -C 1998-10-23 D. A. KEYSER -- SUBROUTINE NOW Y2K AND FORTRAN 90 -C COMPLIANT -C 1999-02-18 D. A. KEYSER -- MODIFIED TO COMPILE AND RUN PROPERLY -C ON IBM-SP -C 2000-06-08 D. A. KEYSER -- CORRECTED MNEMONIC FOR RAIN RATE TO -C "REQV" (WAS "PRER" FOR SOME UNKNOWN REASON) -C 2001-01-03 D. A. KEYSER -- CHANGED UNITS OF RETURNED RAIN RATE -C FROM WHOLE MM/HR TO 10**6 MM/SEC, CHANGED UNITS OF -C RETURNED SURFACE TEMP FROM WHOLE KELVIN TO 10**2 -C KELVIN (TO INCR. PRECISION TO THAT ORIG. IN INPUT BUFR -C FILE) -C 2004-09-12 D. A. KEYSER -- NOW DECODES SEA-SURFACE TEMPERATURE IF -C VALID INTO SAME LOCATION AS SURFACE TEMPERATURE, QUANTITY -C IS SURFACE TEMPERATURE IF SURFACE TAG IS NOT 5, OTHERWISE -C QUANTITY IS SEA-SURFACE TEMPERATURE (NCEP PRODUCTS DATA -C DUMP FILE NOW CONTAINS SST); CHECKS TO SEE IF OLD OR NEW -C VERSION OF MNEMONIC TABLE bufrtab.012 IS BEING USED HERE -C (OLD VERSION HAD "PH2O" INSTEAD OF "TPWT", "SNDP" INSTEAD -C OF "TOSD", "WSOS" INSTEAD OF "WSPD" AND "CH2O" INSTEAD OF -C THE SEQUENCE "METFET VILWC METFET"), AND DECODES USING -C WHICHEVER MNEMONICS ARE FOUND {NOTE: A FURTHER -C REQUIREMENT FOR "VILWC" IS THAT THE FIRST "METFET" -C (METEOROLOGICAL FEATURE) IN THE SEQUENCE MUST BE 12 -C (=CLOUD), ELSE CLOUD WATER SET TO MISSING, REGARDLESS OF -C "VILWC" VALUE} -C -C USAGE: CALL W3MISCAN(INDTA,INLSF,INGBI,INGBD,LSAT,LPROD,LBRIT, -C $ NNALG,GBALG,KDATE,LDATE,IGNRTM,IBUFTN,IER) -C INPUT ARGUMENT LIST: -C INDTA - UNIT NUMBER OF NCEP BUFR SSM/I DUMP DATA SET -C INLSF - UNIT NUMBER OF DIRECT ACCESS NESDIS LAND/SEA FILE -C - (VALID ONLY IF LBRIT AND EITHER NNALG OR GBALG TRUE) -C INGBI - UNIT NUMBER OF GRIB INDEX FILE FOR GRIB FILE -C - CONTAINING GLOBAL 1-DEGREE SEA-SURFACE TEMP FIELD -C - (VALID ONLY IF LBRIT AND EITHER NNALG OR GBALG TRUE) -C INGBD - UNIT NUMBER OF GRIB FILE CONTAINING GLOBAL 1-DEGREE -C - SEA-SURFACE TEMP FIELD (VALID ONLY IF LBRIT AND EITHER -C - NNALG OR GBALG TRUE) -C LSAT - 10-WORD LOGICAL ARRAY (240:249) INDICATING WHICH -C SATELLITE IDS SHOULD BE PROCESSED (SEE REMARKS) -C LPROD - LOGICAL INDICATING IF THE INPUT BUFR FILE CONTAINS -C - PRODUCTS (REGARDLESS OF SOURCE) - IN THIS CASE ONE OR -C - MORE AVAILABLE PRODUCTS CAN BE PROCESSED AND RETURNED -C LBRIT - LOGICAL INDICATING IF THE INPUT BUFR FILE CONTAINS -C - BRIGHTNESS TEMPERATURES - IN THIS CASE B. TEMPS ARE -C - PROCESSED AND RETURNED ALONG WITH, IF REQUESTED, IN- -C - LINE GENERATED PRODUCTS FROM ONE OR BOTH ALGORITHMS -C - (SEE NEXT TWO SWITCHES) -C THE FOLLOWING TWO SWITCHES APPLY ONLY IF LBRIT IS TRUE ----- -C NNALG - LOGICAL INDICATING IF THE SUBROUTINE SHOULD -C - CALCULATE AND RETURN SSM/I WIND SPEED AND TPW -C - VIA THE NEURAL NET 3 ALGORITHM (NOTE: B O T H -C - WIND SPEED AND TPW ARE RETURNED HERE) -C GBALG - LOGICAL INDICATING IF THE SUBROUTINE SHOULD -C - CALCULATE AND RETURN SSM/I WIND SPEED VIA THE -C - GOODBERLET ALGORITHM -C -C KDATE - REQUESTED EARLIEST YEAR(YYYY), MONTH, DAY, HOUR, -C - MIN FOR ACCEPTING SCANS -C LDATE - REQUESTED LATEST YEAR(YYYY), MONTH, DAY, HOUR, -C - MIN FOR ACCEPTING SCANS -C IGNRTM - SWITCH TO INDICATE WHETHER SCANS SHOULD BE TIME- -C - CHECKED (= 0) OR NOT TIME CHECKED (=1) {IF =1, ALL -C - SCANS READ IN ARE PROCESSED REGARDLESS OF THEIR TIME. -C - THE INPUT ARGUMENTS "KDATE" AND "LDATE" (EARLIEST AND -C - LATEST DATE FOR PROCESSING DATA) ARE IGNORED IN THE -C - TIME CHECKING FOR SCANS. (NOTE: THE EARLIEST AND -C - LATEST DATES SHOULD STILL BE SPECIFIED TO THE -C - "EXPECTED" TIME RANGE, BUT THEY WILL NOT BE USED FOR -C - TIME CHECKING IN THIS CASE)} -C -C OUTPUT ARGUMENT LIST: -C IBUFTN - OUTPUT BUFFER HOLDING DATA FOR A SCAN (1737 WORDS - -C - SEE REMARKS FOR FORMAT. SOME WORDS MAY BE MISSING -C - DEPENDING UPON LPROD, LBRIT, NNALG AND GBALG -C IER - ERROR RETURN CODE (SEE REMARKS) -C -C INPUT FILES: -C UNIT AA - (WHERE AA IS EQUAL TO INPUT ARGUMENT 'INDTA') NCEP -C - BUFR SSM/I DUMP DATA SET HOLDING SCANS (SEE REMARKS -C - REGARDING ASSIGN) -C UNIT BB - (WHERE BB IS EQUAL TO INPUT ARGUMENT 'INLSF') -C - DIRECT ACCESS NESDIS LAND/SEA FILE (SEE REMARKS -C - REGARDING ASSIGN) (VALID ONLY IF LBRIT AND EITHER -C - NNALG OR GBALG TRUE) -C UNIT CC - (WHERE CC IS EQUAL TO INPUT ARGUMENT 'INGBI') GRIB -C - INDEX FILE FOR GRIB FILE CONTAINING GLOBAL 1-DEGREE -C - SEA-SURFACE TEMPERATURE FIELD (SEE REMARKS -C - REGARDING CREATION AND ASSIGN) (VALID ONLY IF LBRIT -C - AND EITHER NNALG OR GBALG TRUE) -C UNIT DD - (WHERE DD IS EQUAL TO INPUT ARGUMENT 'INGBD') -C - UNBLOCKED GRIB FILE CONTAINING GLOBAL 1-DEGREE SEA- -C - SURFACE TEMPERATURE FIELD (SEE REMARKS REGARDING -C - ASSIGN) (VALID ONLY IF LBRIT AND EITHER NNALG OR -C - GBALG TRUE) -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C SUBPROGRAMS CALLED: -C UNIQUE: - MISC01 RISC02 RISC03 MISC04 MISC05 -C - MISC06 MISC10 -C LIBRARY: -C IBM - GETENV -C BALIB: - BAOPER BACLOSE -C W3LIB: - W3FI04 W3MOVDAT W3DIFDAT GBYTE GETGB -C BUFRLIB: - DATELEN DUMPBF OPENBF READMG READSB -C - UFBINT UFBREP -C -C REMARKS: RETURN CODE IER CAN HAVE THE FOLLOWING VALUES: -C IER = 0 SUCCESSFUL RETURN OF SCAN -C IER = 1 ALL SCANS HAVE BEEN READ, ALL DONE -C IER = 2 ABNORMAL RETURN - INPUT BUFR FILE IN UNIT -C 'INDTA' IS EITHER EMPTY (NULL) OR IS NOT BUFR -C IER = 3 ABNORMAL RETURN - REQUESTED EARLIEST AND -C LATEST DATES ARE BACKWARDS -C IER = 4 ABNORMAL RETURN - ERROR OPENING RANDOM -C ACCESS FILE HOLDING LAND/SEA TAGS -C IER = 5 ABNORMAL RETURN - THE NUMBER OF DECODED -C "LEVELS" IS NOT WHAT IS EXPECTED -C IER = 6 ABNORMAL RETURN - SEA-SURFACE TEMPERATURE -C NOT FOUND IN GRIB INDEX FILE - ERROR RETURNED -C FROM GRIB DECODER GETGB IS 96 -C IER = 7 ABNORMAL RETURN - SEA-SURFACE TEMPERATURE -C GRIB MESSAGE HAS A DATE THAT IS EITHER: -C 1) MORE THAN 7-DAYS PRIOR TO THE EARLIEST -C REQUESTED DATE OR 2) MORE THAN 7-DAYS AFTER -C THE LATEST REQUESTED DATE -C IER = 8 ABNORMAL RETURN - BYTE-ADDRESSABLE READ ERROR -C FOR GRIB FILE CONTAINING SEA-SURFACE -C TEMPERATURE FIELD - ERROR RETURNED FROM GRIB -C DECODER GETGB IS 97-99 -C IER = 9 ABNORMAL RETURN - ERROR RETURNED FROM GRIB -C DECODER - GETGB - FOR SEA-SURFACE -C TEMPERATURE FIELD - > 0 BUT NOT 96-99 -CC -C INPUT ARGUMENT LSAT IS SET-UP AS FOLLOWS: -C -C LSAT(X) = TRUE -- PROCESS SCANS FROM SATELLITE ID X (WHERE X -C IS CODE FIGURE FROM BUFR CODE TABLE 0-01-007) -C LSAT(X) = FALSE - DO NOT PROCESS SCANS FROM SATELLITE ID X -C -C X = 240 IS F-7 DMSP SATELLITE (THIS SATELLITE IS -C NO LONGER AVAILABLE) -C X = 241 IS F-8 DMSP SATELLITE (THIS SATELLITE IS -C NO LONGER AVAILABLE) -C X = 242 IS F-9 DMSP SATELLITE (THIS SATELLITE IS -C NO LONGER AVAILABLE) -C X = 243 IS F-10 DMSP SATELLITE (THIS SATELLITE IS -C NO LONGER AVAILABLE) -C X = 244 IS F-11 DMSP SATELLITE (THIS IS AVAILABLE -C AS OF 8/96 BUT IS NOT CONSIDERED TO BE AN -C OPERATIONAL DMSP SSM/I SATELLITE) -C X = 245 IS F-12 DMSP SATELLITE (THIS SATELLITE IS -C NO LONGER AVAILABLE) -C X = 246 IS F-13 DMSP SATELLITE (THIS IS AVAILABLE -C AND IS CONSIDERED TO BE AN OPERATIONAL -C ODD DMSP SSM/I SATELLITE AS OF 8/1996) -C X = 247 IS F-14 DMSP SATELLITE (THIS IS AVAILABLE -C AS OF 5/97 BUT IS NOT CONSIDERED TO BE AN -C OPERATIONAL DMSP SSM/I SATELLITE) -C X = 248 IS F-15 DMSP SATELLITE (THIS IS AVAILABLE -C AS OF 2/2000 AND IS CONSIDERED TO BE AN -C OPERATIONAL ODD DMSP SSM/I SATELLITE AS OF -C 2/2000) -C X = 249 IS RESERVED FOR A FUTURE DMSP SATELLITE -C -C NOTE: HERE "EVEN" MEANS VALUE IN IBUFTN(1) IS AN ODD NUMBER -C WHILE "ODD" MEANS VALUE IN IBUFTN(1) IS AN EVEN NUMBER -CC -C -C CONTENTS OF ARRAY 'IBUFTN' HOLDING ONE COMPLETE SCAN (64 INDIVIDUAL -C RETRIEVLAS (1737 WORDS) -C -C =====> ALWAYS RETURNED: -C -C WORD CONTENTS -C ---- -------- -C 1 SATELLITE ID (244 IS F-11; 246 IS F-13; 247 IS F-14; -C 248 IS F-15) -C 2 4-DIGIT YEAR FOR SCAN -C 3 2-DIGIT MONTH OF YEAR FOR SCAN -C 4 2-DIGIT DAY OF MONTH FOR SCAN -C 5 2-DIGIT HOUR OF DAY FOR SCAN -C 6 2-DIGIT MINUTE OF HOUR FOR SCAN -C 7 2-DIGIT SECOND OF MINUTE FOR SCAN -C 8 SCAN NUMBER IN ORBIT -C 9 ORBIT NUMBER FOR SCAN -C -C 10 RETRIEVAL #1 LATITUDE (*100 DEGREES: + N, - S) -C 11 RETRIEVAL #1 LONGITUDE (*100 DEGREES EAST) -C 12 RETRIEVAL #1 POSITION NUMBER -C 13 RETRIEVAL #1 SURFACE TAG (CODE FIGURE) -C -C =====> FOR LPROD = TRUE {INPUT PRODUCTS FILE: NOTE ALL PRODUCTS -C BELOW EXCEPT SEA-SURFACE TEMPERATURE ARE AVAILABLE IN THE -C FNOC "OPERATIONAL" PRODUCTS DATA DUMP; MOST NCEP PRODUCTS -C DATA DUMPS CONTAIN ONLY WIND SPEED, TOTAL PRECIPITABLE -C WATER, CLOUD WATER AND SEA-SURFACE TEMPERATURE (ALL OVER -C OCEAN ONLY)}: -C -C 14 RETRIEVAL #1 CLOUD WATER (*100 KILOGRAM/METER**2) -C 15 RETRIEVAL #1 RAIN RATE (*1000000 MILLIMETERS/SECOND) -C 16 RETRIEVAL #1 WIND SPEED (*10 METERS/SECOND) -C 17 RETRIEVAL #1 SOIL MOISTURE (MILLIMETERS) -C 18 RETRIEVAL #1 SEA-ICE CONCENTRATION (PER CENT) -C 19 RETRIEVAL #1 SEA-ICE AGE (CODE FIGURE) -C 20 RETRIEVAL #1 ICE EDGE (CODE FIGURE) -C 21 RETRIEVAL #1 TOTAL PRECIP. WATER (*10 MILLIMETERS) -C 22 RETRIEVAL #1 SURFACE TEMP (*100 K) IF NOT OVER OCEAN -C -- OR -- -C 22 RETRIEVAL #1 SEA-SURFACE TEMP (*100 K) IF OVER OCEAN -C 23 RETRIEVAL #1 SNOW DEPTH (MILLIMETERS) -C 24 RETRIEVAL #1 RAIN FLAG (CODE FIGURE) -C 25 RETRIEVAL #1 CALCULATED SURFACE TYPE (CODE FIGURE) -C -C =====> FOR LBRIT = TRUE (INPUT BRIGHTNESS TEMPERATURE FILE): -C -C 26 RETRIEVAL #1 19 GHZ V BRIGHTNESS TEMP (*100 DEG. K) -C 27 RETRIEVAL #1 19 GHZ H BRIGHTNESS TEMP (*100 DEG. K) -C 28 RETRIEVAL #1 22 GHZ V BRIGHTNESS TEMP (*100 DEG. K) -C 29 RETRIEVAL #1 37 GHZ V BRIGHTNESS TEMP (*100 DEG. K) -C 30 RETRIEVAL #1 37 GHZ H BRIGHTNESS TEMP (*100 DEG. K) -C 31 RETRIEVAL #1 85 GHZ V BRIGHTNESS TEMP (*100 DEG. K) -C 32 RETRIEVAL #1 85 GHZ H BRIGHTNESS TEMP (*100 DEG. K) -C -C =====> FOR LBRIT = TRUE AND NNALG = TRUE (INPUT BRIGHTNESS -C TEMPERATURE FILE): -C -C 33 RETRIEVAL #1 NEURAL NET 3 ALGORITHM WIND SPEED -C (GENERATED IN-LINE) (*10 METERS/SECOND) -C 34 RETRIEVAL #1 NEURAL NET 3 ALGORITHM TOTAL PRECIP. -C WATER (GENERATED IN-LINE) (*10 MILLIMETERS) -C -C =====> FOR LBRIT = TRUE AND GBALG = TRUE (INPUT BRIGHTNESS -C TEMPERATURE FILE): -C -C 35 RETRIEVAL #1 GOODBERLET ALGORITHM WIND SPEED -C (GENERATED IN-LINE) (*10 METERS/SECOND) -C 36 RETRIEVAL #1 GOODBERLET ALGORITHM RAIN FLAG -C (CODE FIGURE) -C -C 37-1737 REPEAT 10-36 FOR 63 MORE RETRIEVALS -C -C (NOTE: ALL MISSING DATA OR DATA NOT SELECTED BY -C CALLING PROGRAM ARE SET TO 99999) -C -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - - SUBROUTINE W3MISCAN(INDTA,INLSF,INGBI,INGBD,LSAT,LPROD,LBRIT, - $ NNALG,GBALG,KDATE,LDATE,IGNRTM,IBUFTN,IER) - - LOGICAL LPROD,LBRIT,NNALG,GBALG,LSAT(240:249) - - CHARACTER*1 CDUMMY - CHARACTER*2 ATXT(2) - CHARACTER*8 SUBSET - CHARACTER*20 RHDER,PROD2,BRITE - CHARACTER*46 SHDER,PROD1 - - REAL SHDR(9),RHDR(4,64),PROD(13,64),BRIT(2,448),RINC(5), - $ METFET(64) - - REAL(8) SHDR_8(9),RHDR_8(4,64),PROD_8(13,64),BRIT_8(2,448), - $ UFBINT_8(64) - - INTEGER IBUFTN(1737),KDATA(7),KDATE(5),LDATE(5),LBTER(7), - $ KSPSAT(239:249),KNTSAT(239:249),IFLAG(64),KDAT(8),LDAT(8), - $ MDAT(8),ICDATE(5),IDDATE(5) - - COMMON/MISCCC/SSTDAT(360,180) - COMMON/MISCEE/LFLAG,LICEC - - SAVE - - DATA SHDER /'SAID YEAR MNTH DAYS HOUR MINU SECO SCNN ORBN '/ - DATA RHDER /'CLAT CLON POSN SFTG '/ - DATA PROD1 /'VILWC REQV WSPD SMOI ICON ICAG ICED TPWT TMSK '/ - DATA PROD2 /'TOSD RFLG SFTP SST1 '/ - DATA BRITE /'CHNM TMBR '/ - DATA ATXT /'NN','GB'/ - DATA IMSG /99999/,KNTSCN/0/,KNTTIM/0/,LAERR/0/, - $ LOERR/0/,LBTER/7*0/,ITIMES/0/,NLR/0/,NIR/0/,DMAX/-99999./, - $ DMIN/99999./,KSPSAT/11*0/,KNTSAT/11*0/,ILFLG/0/,BMISS/10.0E10/ - - IF(ITIMES.EQ.0) THEN - -C*********************************************************************** -C FIRST CALL INTO SUBROUTINE DO A FEW THINGS ..... - ITIMES = 1 - LFLAG = 0 - LICEC = 0 - PRINT 65, INDTA - 65 FORMAT(//' ---> W3MISCAN: Y2K/F90 VERSION 09/12/2004: ', - $ 'PROCESSING SSM/I DATA FROM BUFR DATA SET READ FROM UNIT ', - $ I4/) - IF(LPROD) PRINT 66 - 66 FORMAT(//' ===> WILL READ FROM BUFR PRODUCTS DATA DUMP ', - $ 'FILE (EITHER FNOC OR NCEP) AND PROCESS ONE OR MORE SSM/I ', - $ 'PRODUCTS'//) - IF(LBRIT) THEN - PRINT 167 - 167 FORMAT(//' ===> WILL READ FROM BUFR BRIGHTNESS ', - $ 'TEMPERATURE DATA DUMP FILE AND PROCESS BRIGHTNESS ', - $ 'TEMPERATURES'//) - IF(NNALG) PRINT 169 - 169 FORMAT(' ===> IN ADDITION, WILL PERFORM IN-LINE ', - $ 'CALCULATION OF NEURAL NETWORK 3 WIND SPEED AND TOTAL ', - $ 'PRECIPITABLE WATER AND PROCESS THESE'/) - IF(GBALG) PRINT 170 - 170 FORMAT(' ===> IN ADDITION, WILL PERFORM IN-LINE ', - $ 'CALCULATION OF GOODBERLET WIND SPEED AND PROCESS THESE'/) - END IF - IF(IGNRTM.EQ.1) PRINT 704 - 704 FORMAT(' W3MISCAN: INPUT ARGUMENT "IGNRTM" IS SET TO 1 -- NO ', - $ 'TIME CHECKS WILL BE PERFORMED ON SCANS - ALL SCANS READ IN ', - $ 'ARE PROCESSED'/) - - PRINT 104, KDATE,LDATE - 104 FORMAT(' W3MISCAN: REQUESTED EARLIEST DATE:',I7,4I5/ - $ ' REQUESTED LATEST DATE:',I7,4I5) - - KDAT = 0 - KDAT(1:3) = KDATE(1:3) - KDAT(5:6) = KDATE(4:5) - LDAT = 0 - LDAT(1:3) = LDATE(1:3) - LDAT(5:6) = LDATE(4:5) - -C DO REQUESTED EARLIEST AND LATEST DATES MAKE SENSE? - - CALL W3DIFDAT(LDAT,KDAT,3,RINC) - IF(RINC(3).LT.0) THEN -C....................................................................... - PRINT 103 - 103 FORMAT(' ##W3MISCAN: REQUESTED EARLIEST AND LATEST DATES ', - $ 'ARE BACKWARDS!! - IER = 3'/) - IER = 3 - RETURN -C....................................................................... - END IF - -C DETERMINE MACHINE WORD LENGTH IN BYTES AND TYPE OF CHARACTER SET -C {ASCII(ICHTP=0) OR EBCDIC(ICHTP=1)} - - CALL W3FI04(IENDN,ICHTP,LW) - PRINT 2213, LW, ICHTP, IENDN - 2213 FORMAT(/' ---> W3MISCAN: CALL TO W3FI04 RETURNS: LW = ',I3, - $ ', ICHTP = ',I3,', IENDN = ',I3/) - - CALL DATELEN(10) - - CALL DUMPBF(INDTA,ICDATE,IDDATE) -cppppp - print *,'CENTER DATE (ICDATE) = ',icdate - print *,'DUMP DATE (IDDATE) = ',iddate -cppppp - -C COME HERE IF CENTER DATE COULD NOT BE READ FROM FIRST DUMMY MESSAGE -C - RETURN WITH IRET = 2 - - IF(ICDATE(1).LE.0) GO TO 998 - -C COME HERE IF DUMP DATE COULD NOT BE READ FROM SECOND DUMMY MESSAGE -C - RETURN WITH IRET = 2 - - IF(IDDATE(1).LE.0) GO TO 998 - IF(ICDATE(1).LT.100) THEN - -C IF 2-DIGIT YEAR RETURNED IN ICDATE(1), MUST USE "WINDOWING" TECHNIQUE -C TO CREATE A 4-DIGIT YEAR - -C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS -C CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT -C Y2K COMPLIANT (BUFRLIB DOES THE WINDOWING HERE) - - PRINT *, '##W3MISCAN - THE FOLLOWING SHOULD NEVER ', - $ 'HAPPEN!!!!!' - PRINT *, '##W3MISCAN - 2-DIGIT YEAR IN ICDATE(1) RETURNED ', - $ 'FROM DUMPBF (ICDATE IS: ',ICDATE,') - USE WINDOWING ', - $ 'TECHNIQUE TO OBTAIN 4-DIGIT YEAR' - IF(ICDATE(1).GT.20) THEN - ICDATE(1) = 1900 + ICDATE(1) - ELSE - ICDATE(1) = 2000 + ICDATE(1) - ENDIF - PRINT *, '##W3MISCAN - CORRECTED ICDATE(1) WITH 4-DIGIT ', - $ 'YEAR, ICDATE NOW IS: ',ICDATE - ENDIF - - IF(IDDATE(1).LT.100) THEN - -C IF 2-DIGIT YEAR RETURNED IN IDDATE(1), MUST USE "WINDOWING" TECHNIQUE -C TO CREATE A 4-DIGIT YEAR - -C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS -C CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT -C Y2K COMPLIANT (BUFRLIB DOES THE WINDOWING HERE) - - PRINT *, '##W3MISCAN - THE FOLLOWING SHOULD NEVER ', - $ 'HAPPEN!!!!!' - PRINT *, '##W3MISCAN - 2-DIGIT YEAR IN IDDATE(1) RETURNED ', - $ 'FROM DUMPBF (IDDATE IS: ',IDDATE,') - USE WINDOWING ', - $ 'TECHNIQUE TO OBTAIN 4-DIGIT YEAR' - IF(IDDATE(1).GT.20) THEN - IDDATE(1) = 1900 + IDDATE(1) - ELSE - IDDATE(1) = 2000 + IDDATE(1) - ENDIF - PRINT *, '##W3MISCAN - CORRECTED IDDATE(1) WITH 4-DIGIT ', - $ 'YEAR, IDDATE NOW IS: ',IDDATE - END IF - -C OPEN BUFR FILE - READ IN DICTIONARY MESSAGES (TABLE A, B, D ENTRIES) - - CALL OPENBF(INDTA,'IN',INDTA) - - print *, ' ' - print *, 'OPEN NCEP BUFR SSM/I DUMP FILE' - print *, ' ' - -C Check to see if the old (pre 9/2004) version of the mnemonic -C table is being used here (had "PH2O" instead of "TPWT", -C "SNDP" instead of "TOSD", "WSOS" instead of "WSPD") -C ------------------------------------------------------------ - - CALL STATUS(INDTA,LUN,IDUMMY1,IDUMMY2) - CALL NEMTAB(LUN,'PH2O',IDUMMY1,CDUMMY,IRET_PH2O) - CALL NEMTAB(LUN,'SNDP',IDUMMY1,CDUMMY,IRET_SNDP) - CALL NEMTAB(LUN,'WSOS',IDUMMY1,CDUMMY,IRET_WSOS) - CALL NEMTAB(LUN,'CH2O',IDUMMY1,CDUMMY,IRET_CH2O) - - IF(LBRIT.AND.(NNALG.OR.GBALG)) THEN - -C----------------------------------------------------------------------- -C IF IN-LINE CALC. OF WIND SPEED FROM GOODBERLET ALG. OR -C IN-LINE CALCULATION OF WIND SPEED AND TPW FROM NEURAL NET 3 ALG. -C FIRST CALL TO THIS SUBROUTINE WILL READ IN SEA-SURFACE TEMPERATURE -C FIELD AS A CHECK FOR ICE LIMITS -C WILL ALSO OPEN DIRECT ACCESS NESDIS LAND SEA FILE -C----------------------------------------------------------------------- - - CALL MISC06(INGBI,INGBD,KDATE,LDATE,*993,*994,*995,*996) - PRINT 67, INLSF - 67 FORMAT(//4X,'** W3MISCAN: OPEN R. ACCESS NESDIS LAND/SEA ', - $ 'FILE IN UNIT ',I2/) - OPEN(UNIT=INLSF,ERR=997,ACCESS='DIRECT',IOSTAT=IERR,RECL=10980) - END IF - -C READ THE FIRST BUFR MESSAGE IN THE BUFR FILE - - CALL READMG(INDTA,SUBSET,IBDATE,IRET) - - print *, 'READ FIRST BUFR MESSAGE: SUBSET = ',SUBSET, - $ '; IBDATE = ',IBDATE,'; IRET = ',IRET - - IF(IRET.NE.0) GO TO 998 - -C*********************************************************************** - - END IF - - 30 CONTINUE - -C TIME TO DECODE NEXT SUBSET (SCAN) OUT OF BUFR MESSAGE - - IBUFTN = IMSG - CALL READSB(INDTA,IRET) - IF(IRET.NE.0) THEN - -C ALL SUBSETS OUT OF THIS MESSAGE READ, TIME TO MOVE ON TO NEXT MESSAGE - - CALL READMG(INDTA,SUBSET,IBDATE,IRET) - - print *, 'READ NEXT BUFR MESSAGE: SUBSET = ',SUBSET, - $ '; IBDATE = ',IBDATE,'; IRET = ',IRET - - IF(IRET.NE.0) THEN -c....................................................................... - -C NON-ZERO IRET IN READMG MEANS ALL BUFR MESSAGES IN FILE HAVE BEEN READ -C - ALL FINISHED, NO OTHER SCANS W/I DESIRED TIME RANGE -- SET IER TO 1 -C AND RETURN TO CALLING PROGRAM - - PRINT 124, KNTSCN - 124 FORMAT(/' W3MISCAN: +++++ ALL VALID SCANS UNPACKED AND ', - $ 'RETURNED FROM THIS NCEP BUFR SSM/I DUMP FILE'//34X, - $ '** W3MISCAN: SUMMARY **'//35X,'TOTAL NUMBER OF SCANS ', - $ 'PROCESSED AND RETURNED',11X,I7) - DO JJ = 239,249 - IF(KNTSAT(JJ).GT.0) THEN - PRINT 294, JJ,KNTSAT(JJ) - 294 FORMAT(35X,'......NO. OF SCANS PROCESSED AND ', - $ 'RETURNED FROM SAT',I4,':',I7) - END IF - END DO - DO JJ = 239,249 - IF(KSPSAT(JJ).GT.0) THEN - II = JJ - IF(JJ.EQ.239) II = 1 - PRINT 224, II,KSPSAT(JJ) - 224 FORMAT(35X,'NO. OF SCANS SKIPPED DUE TO BEING FROM ', - $ 'NON-REQ SAT',I4,':',I7) - END IF - END DO - PRINT 194, KNTTIM - 194 FORMAT(35X,'NUMBER OF SCANS SKIPPED DUE TO BEING OUTSIDE ', - $ 'TIME INT.:',I7) - PRINT 324, LAERR,LOERR - 324 FORMAT( - $/35X,'NUMBER OF RETRIEVALS WITH LATITUDE OUT OF RANGE: ',I7/ - $ 35X,'NUMBER OF RETRIEVALS WITH LONGITUDE OUT OF RANGE: ',I7) - IF(LBRIT) THEN - IF(NNALG.OR.GBALG) PRINT 780, LBTER,NLR,NIR - 780 FORMAT( - $ 35X,'NUMBER OF RETRIEVALS W/ ERROR IN 19 GHZ V BRIGHT. TEMP:',I7/ - $ 35X,'NUMBER OF RETRIEVALS W/ ERROR IN 19 GHZ H BRIGHT. TEMP:',I7/ - $ 35X,'NUMBER OF RETRIEVALS W/ ERROR IN 22 GHZ V BRIGHT. TEMP:',I7/ - $ 35X,'NUMBER OF RETRIEVALS W/ ERROR IN 37 GHZ V BRIGHT. TEMP:',I7/ - $ 35X,'NUMBER OF RETRIEVALS W/ ERROR IN 37 GHZ H BRIGHT. TEMP:',I7/ - $ 35X,'NUMBER OF RETRIEVALS W/ ERROR IN 85 GHZ V BRIGHT. TEMP:',I7/ - $ 35X,'NUMBER OF RETRIEVALS W/ ERROR IN 85 GHZ H BRIGHT. TEMP:',I7/ - $ 35X,'NUMBER OF RETRIEVALS REJECTED DUE TO BEING OVER LAND: ',I7/ - $ 35X,'NUMBER OF RETRIEVALS REJECTED DUE TO BEING OVER ICE: ',I7) - IF(NNALG) PRINT 781, LFLAG,LICEC - 781 FORMAT( - $ 35X,'NUMBER OF NN3 RETR. REJECTED DUE TO FAILING RAIN FLAG: ',I7/ - $ 35X,'NUMBER OF NN3 RETR. REJECTED DUE TO ICE CONTAMINATION: ',I7) - IF(NNALG.OR.GBALG) PRINT 782, DMAX,DMIN - 782 FORMAT(/' ** FOR SEA-SFC TEMP AT ALL RETRIEVAL LOCATIONS: FIELD', - $ ' MAX =',F8.3,' DEG K, FIELD MIN =',F8.3,' DEG K'/) - END IF - IER = 1 - RETURN -C....................................................................... - END IF - - GO TO 30 - END IF - -C*********************************************************************** -C COME HERE FOR BOTH PRODUCTS AND BRIGHTNESS TEMPERATURES -C*********************************************************************** - SHDR = BMISS - CALL UFBINT(INDTA,SHDR_8,09,1,NLEV,SHDER) ; SHDR = SHDR_8 - ILFLG = 1 - IF(NLEV.NE.1) GO TO 999 - -C STORE THE SCAN'S SATELLITE ID IN WORD 1 -C STORE SCAN'S YEAR (YYYY), MONTH, DAY, HOUR, MIN, SEC INTO WORDS 2-7 -C STORE THE SCAN NUMBER IN WORD 8 -C STORE THE SCAN'S ORBIT NUMBER IN WORD 9 - - IBUFTN(1:9) = MIN(IMSG,NINT(SHDR(1:9))) - -C CHECK TO SEE IF SCAN IS FROM REQUESTED SATELLITE ID - - IF(IBUFTN(1).LT.240.OR.IBUFTN(1).GT.249) THEN - PRINT 523, (IBUFTN(II),II=1,9) - KSPSAT(239) = KSPSAT(239) + 1 - GO TO 30 - END IF - IF(.NOT.LSAT(IBUFTN(1))) THEN -CDAK PRINT 523, (IBUFTN(II),II=1,9) - 523 FORMAT(' ##W3MISCAN: SCAN NOT FROM REQ. SAT. ID -SAT. ID',I4, - $ ', SCAN TIME:',6I4,', SCAN',I6,', ORBIT',I8,'-GO TO NEXT SCAN') - KSPSAT(IBUFTN(1)) = KSPSAT(IBUFTN(1)) + 1 - GO TO 30 - END IF - - IF(IGNRTM.EQ.0) THEN - -C TIME CHECK THIS SCAN IF USER REQUESTS SUCH - - MDAT = 0 - MDAT(1:3) = IBUFTN(2:4) - MDAT(5:7) = IBUFTN(5:7) - CALL W3DIFDAT(KDAT,MDAT,4,RINC) - KSEC = RINC(4) - CALL W3DIFDAT(LDAT,MDAT,4,RINC) - LSEC = RINC(4) - IF(KSEC.GT.0.OR.LSEC.LT.0) THEN - -C TIME CHECK FOR SCAN FAILED: GO ON TO NEXT SCAN - -CDAK PRINT 123, (IBUFTN(II),II=2,9) - 123 FORMAT(' ##W3MISCAN: SCAN NOT IN REQUESTED TIME WINDOW-', - $ 'SCAN TIME:',6I5,' SCAN',I6,', ORBIT',I8,' - GO TO NEXT SCAN') - KNTTIM = KNTTIM + 1 - GO TO 30 - END IF - END IF - RHDR = BMISS - CALL UFBINT(INDTA,RHDR_8,04,64,NLEV,RHDER) ; RHDR = RHDR_8 - ILFLG = 2 - IF(NLEV.NE.64) GO TO 999 - IFLAG = 0 - DO IRT = 1,64 - -C THIS ROUTINE EXPECTS LONGITUDE TO BE 0-360 E; BUFR NOW RETURNS -180-0 -C FOR WEST AND 0-180 FOR EAST - - IF(RHDR(2,IRT).LT.0.0) RHDR(2,IRT) = RHDR(2,IRT) + 360. -C----------------------------------------------------------------------- -C LOOP THROUGH THE 64 RETRIEVALS IN A SCAN -C----------------------------------------------------------------------- -C STORE THE LATITUDE (*100 DEGREES; + : NORTH, - : SOUTH) - IF(NINT(RHDR(1,IRT)*100.).GE.-9000.AND.NINT(RHDR(1,IRT)*100.) - $ .LE.9000) THEN - IBUFTN((27*IRT)-17) = NINT(RHDR(1,IRT)*100.) - ELSE - -C....................................................................... - -C BAD LATITUDE - - LAERR = LAERR + 1 - PRINT 777, IRT,IBUFTN(8),IBUFTN(9),NINT(RHDR(1,IRT)*100.) - 777 FORMAT(' ##W3MISCAN: BAD LAT: RETR.',I3,', SCAN',I6, - $ ', ORBIT',I8,'; INPUT LAT=',I7,' - ALL DATA IN THIS ', - $ 'RETRIEVAL SET TO MISSING') - IFLAG(IRT) = 1 -C....................................................................... - - END IF - -C STORE THE LONGITUDE (*100 DEGREES EAST) - - IF(NINT(RHDR(2,IRT)*100.).GE.0.AND.NINT(RHDR(2,IRT)*100.).LE. - $ 36000) THEN - IF(IFLAG(IRT).EQ.0) - $ IBUFTN((27*IRT)-16) = NINT(RHDR(2,IRT)*100.) - ELSE - -C....................................................................... - -C BAD LONGITUDE - - LOERR = LOERR + 1 - PRINT 778, IRT,IBUFTN(8),IBUFTN(9),NINT(RHDR(2,IRT)*100.) - 778 FORMAT(' ##W3MISCAN: BAD LON: RETR.',I3,', SCAN',I6, - $ ', ORBIT',I8,'; INPUT LON=',I7,' - ALL DATA IN THIS ', - $ 'RETRIEVAL SET TO MISSING') - IFLAG(IRT) = 1 -C....................................................................... - - END IF - IF(IFLAG(IRT).NE.0) GO TO 110 - -C STORE THE POSITION NUMBER - - IBUFTN((27*IRT)-15) = MIN(IMSG,NINT(RHDR(3,IRT))) - -C STORE THE SURFACE TAG (0-6) - - IBUFTN((27*IRT)-14) = MIN(IMSG,NINT(RHDR(4,IRT))) - 110 CONTINUE -C----------------------------------------------------------------------- - END DO - - IF(LPROD) THEN -C*********************************************************************** -C COME HERE TO PROCESS PRODUCTS FROM INPUT SSM/I PRODUCTS FILE -C*********************************************************************** - - PROD = BMISS - CALL UFBINT(INDTA,PROD_8,13,64,NLEV,PROD1//PROD2) - UFBINT_8 = BMISS - IF(IRET_PH2O.GT.0) THEN ! Prior to 9/2004 - CALL UFBINT(INDTA,UFBINT_8,1,64,NLEV,'PH2O') - PROD_8(8,:) = UFBINT_8(:) - END IF - UFBINT_8 = BMISS - IF(IRET_SNDP.GT.0) THEN ! Prior to 9/2004 - CALL UFBINT(INDTA,UFBINT_8,1,64,NLEV,'SNDP') - PROD_8(10,:) = UFBINT_8(:) - END IF - UFBINT_8 = BMISS - IF(IRET_WSOS.GT.0) THEN ! Prior to 9/2004 - CALL UFBINT(INDTA,UFBINT_8,1,64,NLEV,'WSOS') - PROD_8(3,:) = UFBINT_8(:) - END IF - UFBINT_8 = BMISS - IF(IRET_CH2O.GT.0) THEN ! Prior to 9/2004 - CALL UFBINT(INDTA,UFBINT_8,1,64,NLEV,'CH2O') - PROD_8(1,:) = UFBINT_8(:) - ELSE - CALL UFBINT(INDTA,UFBINT_8,1,64,NLEV,'METFET') - METFET = UFBINT_8 - DO IRT = 1,64 - IF(NINT(METFET(IRT)).NE.12) PROD_8(1,IRT) = BMISS - END DO - END IF - - PROD=PROD_8 - ILFLG = 3 - IF(NLEV.EQ.0) THEN - PRINT 797, IBUFTN(8),IBUFTN(9) - 797 FORMAT(' ##W3MISCAN: PRODUCTS REQ. BUT SCAN',I6,', ORBIT', - $ I8,' DOES NOT CONTAIN PRODUCT DATA - CONTINUE PROCESSING ', - $ 'SCAN (B.TEMPS REQ.?)') - GO TO 900 - ELSE IF(NLEV.NE.64) THEN - GO TO 999 - END IF - DO IRT = 1,64 -C----------------------------------------------------------------------- -C LOOP THROUGH THE 64 RETRIEVALS IN A SCAN -C----------------------------------------------------------------------- - IF(IFLAG(IRT).NE.0) GO TO 111 - -C STORE THE CLOUD WATER (*100 KG/M**2) IF AVAILABLE - - IF(NINT(PROD(01,IRT)).LT.IMSG) - $ IBUFTN((27*IRT)-13) = NINT(PROD(01,IRT)*100.) - -C STORE THE RAIN RATE (*1000000 KG/((M**2)*SEC)) IF AVAILABLE -C (THIS IS ALSO RAIN RATE (*1000000 MM/SEC)) - - IF(NINT(PROD(02,IRT)).LT.IMSG) - $ IBUFTN((27*IRT)-12) = NINT(PROD(02,IRT)*1000000.) - -C STORE THE WIND SPEED (*10 M/SEC) IF AVAILABLE - - IBUFTN((27*IRT)-11) = MIN(IMSG,NINT(PROD(03,IRT)*10.)) - -C STORE THE SOIL MOISTURE (MM) IF AVAILABLE - - IF(NINT(PROD(04,IRT)).LT.IMSG) - $ IBUFTN((27*IRT)-10) = NINT(PROD(04,IRT)*1000.) - -C STORE THE SEA ICE CONCENTRATION (PERCENT) IF AVAILABLE - - IBUFTN((27*IRT)-09) = MIN(IMSG,NINT(PROD(05,IRT))) - -C STORE THE SEA ICE AGE (0,1) IF AVAILABLE - - IBUFTN((27*IRT)-08) = MIN(IMSG,NINT(PROD(06,IRT))) - -C STORE THE ICE EDGE (0,1) IF AVAILABLE - - IBUFTN((27*IRT)-07) = MIN(IMSG,NINT(PROD(07,IRT))) - -C STORE THE WATER VAPOR (*10 KG/M**2) IF AVAILABLE -C (THIS IS ALSO TOTAL PRECIPITABLE WATER SCALED AS *10 MM) - - IBUFTN((27*IRT)-06) = MIN(IMSG,NINT(PROD(08,IRT)*10.)) - - IF(IBUFTN((27*IRT)-14).NE.5) THEN - -C STORE THE SURFACE TEMPERATURE (*100 DEGREES KELVIN) IF AVAILABLE -C (NOTE: SURFACE TAG MUST NOT BE 5) - - IBUFTN((27*IRT)-05) = MIN(IMSG,NINT(PROD(09,IRT)*100.)) - - ELSE - -C STORE THE SEA-SURFACE TEMPERATURE (*100 DEGREES KELVIN) IF AVAILABLE -C (NOTE: SURFACE TAG MUST BE 5) - - IBUFTN((27*IRT)-05) = MIN(IMSG,NINT(PROD(13,IRT)*100.)) - - END IF - -C STORE THE SNOW DEPTH (MM) IF AVAILABLE - - IF(NINT(PROD(10,IRT)).LT.IMSG) - $ IBUFTN((27*IRT)-04) = NINT(PROD(10,IRT)*1000.) - -C STORE THE RAIN FLAG (0-3) IF AVAILABLE - - IBUFTN((27*IRT)-03) = MIN(IMSG,NINT(PROD(11,IRT))) - -C STORE THE CALCULATED SURFACE TYPE (1-20) IF AVAILABLE - - IBUFTN((27*IRT)-02) = MIN(IMSG,NINT(PROD(12,IRT))) - 111 CONTINUE -C----------------------------------------------------------------------- - END DO - END IF - 900 CONTINUE - - IF(LBRIT) THEN -C*********************************************************************** -C COME HERE TO PROCESS BRIGHTNESS TEMPERATURES FROM INPUT SSM/I -C BRIGHTNESS TEMPERATURE FILE -C AND POSSIBLY FOR IN-LINE CALC. OF WIND SPEED VIA GOODBERLET ALG. -C AND POSSIBLY FOR IN-LINE CALC. OF WIND SPEED AND TPW VIA N. NET 3 ALG. -C*********************************************************************** - - BRIT = BMISS - CALL UFBREP(INDTA,BRIT_8,2,448,NLEV,BRITE) ; BRIT = BRIT_8 - ILFLG = 4 - IF(NLEV.EQ.0) THEN - PRINT 798, IBUFTN(8),IBUFTN(9) - 798 FORMAT(' ##W3MISCAN: B. TEMPS REQ. BUT SCAN',I6,', ORBIT', - $ I8,' DOES NOT CONTAIN B. TEMP DATA - DONE PROCESSING THIS', - $ ' SCAN') - GO TO 901 - ELSE IF(NLEV.NE.448) THEN - GO TO 999 - END IF - DO IRT = 1,64 -C----------------------------------------------------------------------- -C LOOP THROUGH THE 64 RETRIEVALS IN A SCAN -C----------------------------------------------------------------------- - IF(IFLAG(IRT).NE.0) GO TO 112 - -C STORE THE 7 BRIGHTNESS TEMPS (*100 DEGREES KELVIN) -C -- CHANNELS ARE IN THIS ORDER FOR A PARTICULAR RETRIEVAL: -C 19 GHZ V, 19 GHZ H, 22 GHZ V, 37 GHZ V, 37 GHZ H, 85 GHZ V, 85 GHZ H - - IGOOD = 0 - MINDX = (IRT * 7) - 6 - DO LCH = MINDX,MINDX+6 - ICHNN = NINT(BRIT(1,LCH)) - IF(ICHNN.GT.7) GO TO 79 - IF(NINT(BRIT(2,LCH)).LT.IMSG) THEN - IBUFTN((27*IRT)-02+ICHNN) = NINT(BRIT(2,LCH)*100.) - IGOOD = 1 - END IF - 79 CONTINUE - END DO - - IF(NNALG.OR.GBALG) THEN - KDATA = IMSG - IF(IGOOD.EQ.1) THEN -C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COME HERE FOR IN-LINE CALC. OF WIND SPEED VIA GOODBERLET ALG. AND/OR -C FOR IN-LINE CALC. OF WIND SPEED AND TPW VIA NEURAL NET 3 ALG. -C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C GET LAND/SEA TAG AND CHECK FOR LAT/LON OVER LAND OR ICE - - BALON=REAL(MOD(IBUFTN((27*IRT)-16)+18000,36000)-18000)/100. - IALON = MOD(36000-IBUFTN((27*IRT)-16),36000) - IX = 361. - REAL(IALON)/100. - JY = 91 - NINT(REAL(IBUFTN((27*IRT)-17))/100. + 0.50) - DMIN = MIN(DMIN,SSTDAT(IX,JY)) - DMAX = MAX(DMAX,SSTDAT(IX,JY)) - CALL MISC04(INLSF,REAL(IBUFTN((27*IRT)-17))/100.,BALON,LSTAG) - -C ..... REJECT IF OVER LAND (USE LAND/SEA TAG HERE) - - IF(LSTAG.NE.0) THEN - NLR = NLR + 1 - GO TO 112 - END IF - -C ..... REJECT IF OVER ICE (USE SEA-SURFACE TEMPERATURE HERE) - - IF(SSTDAT(IX,JY).LE.272.96) THEN - NIR = NIR + 1 - GO TO 112 - END IF - - KDATA = IBUFTN((27*IRT)-01:(27*IRT)+05) - DO IT = 1,7 - IF((IT.NE.2.AND.KDATA(IT).LT.10000).OR. - $ (IT.EQ.2.AND.KDATA(IT).LT. 8000)) THEN - LBTER(IT) = LBTER(IT) + 1 - PRINT 779,IT,IBUFTN(8),IBUFTN(9),KDATA - 779 FORMAT(' ##W3MISCAN: BT, CHN',I2,' BAD: SCAN',I6,', ORBIT',I8, - $ '; BT:',7I6,'-CANNOT CALC. PRODS VIA ALG.') - GO TO 112 - END IF - END DO - -C CALL SUBR. MISC01 TO INITIATE IN-LINE PRODUCT CALCULATION - - CALL MISC01(NNALG,GBALG,KDATA,SWNN,TPWNN,SWGB,NRFGB) - - IF(NNALG) THEN -CDAK IF(MOD(KNTSCN,100).EQ.0) PRINT 6021, ATXT(1),SWNN, -CDAK $ TPWNN,REAL(KDATA(1))/100.,(REAL(KDATA(KKK))/100., -CDAK $ KKK=3,5),(REAL(KDATA(4)-KDATA(5)))/100. - 6021 FORMAT(' W3MISCAN: ',A2,' SPD',F6.1,' TPW',F6.1,' TB19V',F6.1, - $ ' TB22V',F6.1,' TB37V',F6.1,' TB37H',F6.1,' TD37',F5.1) - -C STORE THE CALCULATED NEURAL NET 3 WIND SPEED (*10 M/SEC) - - IBUFTN((27*IRT)+6) = MIN(IMSG,NINT(SWNN*10.)) - -C STORE THE CALCULATED NEURAL NET 3 TPW (*10 MILLIMETERS) - - IBUFTN((27*IRT)+7) = MIN(IMSG,NINT(TPWNN*10.)) - END IF - - IF(GBALG) THEN -CDAK IF(MOD(KNTSCN,100).EQ.0) PRINT 602, ATXT(2),NRFGB, -CDAK $ SWGB,REAL(KDATA(1))/100.,(REAL(KDATA(KKK))/100., -CDAK $ KKK=3,5),(REAL(KDATA(4)-KDATA(5)))/100. - 602 FORMAT(' W3MISCAN: ',A2,' RF, SPD',I2,F6.1,' TB19V',F6.1, - $ ' TB22V',F6.1,' TB37V',F6.1,' TB37H',F6.1,' TD37',F5.1) - -C STORE THE CALCULATED GOODBERLET WIND SPEED (*10 M/SEC) - - IBUFTN((27*IRT)+8) = MIN(IMSG,NINT(SWGB*10.)) - -C STORE THE GOODBERLET RAIN FLAG (0-3) - - IBUFTN((27*IRT)+9) = MIN(IMSG,NRFGB) - END IF - -C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ELSE - -C...................................................................... - -C PROBLEM - CAN'T CALCULATE PRODUCTS VIA ANY ALG., ALL B.TEMPS MISSING - - PRINT 879, IBUFTN(8),IBUFTN(9),KDATA - 879 FORMAT(' ##W3MISCAN: ALL B.TMPS MSSNG: SCAN',I6,', ', - $ 'ORBIT',I8,'; BT:',7I6,'-CANNOT CALC PRODS VIA ALG.') -C...................................................................... - - END IF - END IF - - 112 CONTINUE -C----------------------------------------------------------------------- - END DO - END IF -C*********************************************************************** - 901 CONTINUE - -C RETURN TO CALLING PROGRAM - IER = 0 SCAN SUCCESSFULLY READ - - KNTSCN = KNTSCN + 1 - KNTSAT(IBUFTN(1)) = KNTSAT(IBUFTN(1)) + 1 - IER = 0 - RETURN - -C....................................................................... - 993 CONTINUE - -C PROBLEM: SEA-SURFACE TEMPERATURE NOT FOUND IN GRIB INDEX FILE - ERROR -C RETURNED FROM GRIB DECODER GETGB IS 96 - SET IER = 6 & RETURN - - PRINT 2008, INGBI - 2008 FORMAT(/' ##W3MISCAN: SEA-SURFACE TEMPERATURE NOT FOUND IN GRIB ', - $ 'INDEX FILE IN UNIT ',I2,' - IER = 6'/) - IER = 6 - RETURN - -C....................................................................... - 994 CONTINUE - -C PROBLEM: SEA-SURFACE TEMPERATURE GRIB MESSAGE HAS A DATE THAT IS -C EITHER: 1) MORE THAN 7-DAYS PRIOR TO THE EARLIEST REQ. DATE -C (INPUT ARG. "KDATE") OR 2) MORE THAN 7-DAYS AFTER THE LATEST -C REQ. DATE (INPUT ARG. "LDATE") - SET IER = 7 AND RETURN - - PRINT 2009 - 2009 FORMAT(' SST GRIB MSG HAS DATE WHICH IS EITHER 7-DAYS', - $ ' PRIOR TO EARLIEST REQ. DATE'/14X,'OR 7-DAYS LATER THAN LATEST', - $ ' REQ. DATE - IER = 7'/) - IER = 7 - RETURN - -C....................................................................... - 995 CONTINUE - -C PROBLEM: BYTE-ADDRESSABLE READ ERROR FOR GRIB FILE CONTAINING SEA- -C SURFACE TEMPERATURE FIELD - ERROR RETURNED FROM GRIB DECODER -C GETGB IS 97-99 - SET IER = 8 AND RETURN - - PRINT 2010 - 2010 FORMAT(' BYTE-ADDRESSABLE READ ERROR FOR GRIB FILE ', - $ 'CONTAINING SEA-SURFACE TEMPERATURE FIELD - IER = 8'/) - IER = 8 - RETURN - -C....................................................................... - 996 CONTINUE - -C PROBLEM: ERROR RETURNED FROM GRIB DECODER - GETGB - FOR SEA-SURFACE -C TEMPERATURE FIELD - > 0 BUT NOT 96-99 - SET IER = 9 & RETURN - - PRINT 2011 - 2011 FORMAT(' - IER = 9'/) - IER = 9 - RETURN - -C....................................................................... - 997 CONTINUE - -C PROBLEM: ERROR OPENING R. ACCESS FILE HOLDING LAND/SEA TAGS - SET IER -C = 4 AND RETURN - - PRINT 2012, IERR,INLSF - 2012 FORMAT(/' ##W3MISCAN: ERROR OPENING R. ACCESS LAND/SEA FILE IN ', - $ 'UNIT ',I2,' -- IOSTAT =',I5,' -- NO SCANS PROCESSED - IER = 4'/) - IER = 4 - RETURN - -C....................................................................... - 998 CONTINUE - -C PROBLEM: THE INPUT DATA SET IS EITHER EMPTY (NULL), NOT BUFR, OR -C CONTAINS NO DATA MESSAGES - SET IER = 2 AND RETURN - - PRINT 14, INDTA - 14 FORMAT(/' ##W3MISCAN: SSM-I DATA SET IN UNIT',I3,' IS EITHER ', - $'EMPTY (NULL), NOT BUFR, OR CONTAINS NO DATA MESSAGES - IER = 2'/) - IER = 2 - RETURN - -C....................................................................... - 999 CONTINUE - -C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED - SET -C IER = 5 AND RETURN - - PRINT 217, NLEV,ILFLG - 217 FORMAT(/' ##W3MISCAN: THE NUMBER OF DECODED "LEVELS" (=',I5,') ', - $ 'IS NOT WHAT IS EXPECTED (ILFLG=',I1,') - IER = 5'/) - IER = 5 - RETURN - -C....................................................................... - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: MISC01 PREPARES FOR IN-LINE CALUCLATION OF PRODS -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1998-01-28 -C -C ABSTRACT: BASED ON INPUT 7-CHANNEL SSM/I BRIGHTNESS TEMPERATURES, -C DETERMINES THE RAIN FLAG CATEGORY FOR WIND SPEED PRODUCT FOR THE -C GOODBERLET ALGORITHM. THEN CALLS THE APPROPRIATE FUNCTION TO -C CALCULATE EITHER THE WIND SPEED PRODUCT FOR THE GOODBERLET -C ALGORITHM (IF REQUESTED) OR THE WIND SPEED AND TPW PRODUCTS FOR -C THE NEURAL NET 3 ALGORITHM (IF REQUESTED). -C -C PROGRAM HISTORY LOG: -C ????-??-?? W. GEMMILL (W/NMC21) -- ORIGINAL AUTHOR -C 1995-01-04 D. A. KEYSER -- INCORPORATED INTO W3MISCAN AND -C STREAMLINED CODE -C 1996-05-07 D. A. KEYSER (NP22) -- IN-LINE NEURAL NETWORK 1 ALGORITM -C REPLACED BY NEURAL NETWORK 2 ALGORITHM -C 1996-07-30 D. A. KEYSER (NP22) -- CAN NOW PROCESS WIND SPEED FROM -C BOTH ALGORITHMS IF DESIRED -C 1998-01-28 D. A. KEYSER (NP22) -- REPLACED NEURAL NET 2 ALGORITHM -C WHICH CALCULATED ONLY WIND SPEED PRODUCT WITH NEURAL NET 3 -C ALGORITHM WHICH CALCULATES BOTH WIND SPEED AND TOTAL -C PRECIPITABLE WATER PRODUCTS (AMONG OTHERS) BUT, UNLIKE NN2, -C DOES NOT RETURN A RAIN FLAG VALUE (IT DOES SET ALL RETRIEVALS -C TO MISSING THAT FAIL RAIN FLAG AND ICE CONTAMINATION TESTS) -C -C USAGE: CALL MISC01(NNALG,GBALG,KDATA,SWNN,TPWNN,SWGB,NRFGB) -C INPUT ARGUMENT LIST: -C NNALG - PROCESS WIND SPEED AND TPW VIA NEURAL NET 3 ALGORITHM -C - IF TRUE -C GBALG - PROCESS WIND SPEED VIA GOODBERLET ALGORITHM IF TRUE -C KDATA - 7-WORD ARRAY CONTAINING 7 CHANNELS OF BRIGHTNESS -C - TEMPERATURE (KELVIN X 100) -C -C OUTPUT ARGUMENT LIST: -C SWNN - CALCULATED WIND SPEED BASED ON NEURAL NET 3 ALGORITHM -C - (METERS/SECOND) -C TPWNN - CALCULATED TOTAL COLUMN PRECIPITABLE WATER BASED ON -C - NEURAL NET 3 ALGORITHM (MILLIMETERS) -C SWGB - CALCULATED WIND SPEED BASED ON GOODBERLET ALGORITH -C - (METERS/SECOND) -C NRFGB - RAIN FLAG CATEGORY FOR CALCULATED WIND SPEED FROM -C - GOODBERLET ALGORITHM -C -C REMARKS: IF AN ALGORITHM IS NOT CHOSEN, THE OUTPUT PRODUCTS ARE SET -C TO VALUES OF 99999. FOR THAT ALGORITHM AND, FOR THE GOODBERLET -C ALGORITHM ONLY, THE RAIN FLAG IS SET TO 99999. CALLED BY -C SUBROUTINE W3MISCAN. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE MISC01(NNALG,GBALG,KDATA,SWNN,TPWNN,SWGB,NRFGB) - LOGICAL NNALG,GBALG - REAL BTA(4),BTAA(7) - INTEGER KDATA(7) - - COMMON/MISCEE/LFLAG,LICEC - - SAVE - - SWNN = 99999. - TPWNN = 99999. - SWGB = 99999. - NRFGB = 99999 - - TB19V = REAL(KDATA(1))/100. - TB19H = REAL(KDATA(2))/100. - TB22V = REAL(KDATA(3))/100. - TB37V = REAL(KDATA(4))/100. - TB37H = REAL(KDATA(5))/100. - TB85V = REAL(KDATA(6))/100. - TB85H = REAL(KDATA(7))/100. - TD37 = TB37V - TB37H - - IF(NNALG) THEN -C COMPUTE WIND SPEED FROM NEURAL NET 2 ALGORITHM (1995) -C (no longer a possibility - subr. expects dim. of 5 on BTAA) -cdak NRFNN = 1 -cdak IF(TB19H.LE.185.0.AND.TB37H.LE.210.0.AND.TB19V.LT.TB37V) -cdak $ NRFNN = 0 -cdak BTAA(1) = TB19V -cdak BTAA(2) = TB22V -cdak BTAA(3) = TB37V -cdak BTAA(4) = TB37H -cdak BTAA(5) = TB85V -cdak SWNN = RISC02xx(BTAA) - -C COMPUTE WIND SPEED AND TPW FROM NEURAL NET 3 ALGORITHM (1997) - BTAA(1) = TB19V - BTAA(2) = TB19H - BTAA(3) = TB22V - BTAA(4) = TB37V - BTAA(5) = TB37H - BTAA(6) = TB85V - BTAA(7) = TB85H - SWNN = RISC02(BTAA,TPWNN,LQWNN,SSTNN,JERR) - IF(JERR.EQ.1) LFLAG = LFLAG + 1 - IF(JERR.EQ.2) LICEC = LICEC + 1 - END IF - - IF(GBALG) THEN -C COMPUTE WIND SPEED FROM GOODBERLET ALGORITHM - NRFGB = 0 - IF(TD37.LE.50.0.OR.TB19H.GE.165.0) THEN - IF(TD37.LE.50.0.OR.TB19H.GE.165.0) NRFGB = 1 - IF(TD37.LE.37.0) NRFGB = 2 - IF(TD37.LE.30.0) NRFGB = 3 - END IF - BTA(1) = TB19V - BTA(2) = TB22V - BTA(3) = TB37V - BTA(4) = TB37H - SWGB = RISC03(BTA) - END IF - - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: RISC02 CALC. SSM/I PRODS FROM NEURAL NET 3 ALG. -C PRGMMR: V. KRASNOPOLSKY ORG: NP20 DATE: 1997-02-02 -C -C ABSTRACT: THIS RETRIEVAL ALGORITHM IS A NEURAL NETWORK IMPLEMENTATION -C OF THE SSM/I TRANSFER FUNCTION. IT RETRIEVES THE WIND SPEED (W) -C AT THE HEIGHT 20 METERS, COLUMNAR WATER VAPOR (V), COLUMNAR LIQUID -C WATER (L) AND SST. THE NN WAS TRAINED USING BACK-PROPAGATION -C ALGORITHM. TRANSFER FUNCTION IS DESCRIBED AND COMPARED WITH -C CAL/VAL AND OTHER ALGORITHMS IN OMB TECHNICAL NOTE NO. 137. SEE -C REMARKS FOR DETAILED INFO ON THIS ALGORITHM. THIS IS AN IMPROVED -C VERSION OF THE EARLIER NEURAL NETWORK 2 ALGORITHM. -C -C PROGRAM HISTORY LOG: -C 1997-02-02 V. KRASNOPOLSKY -- ORIGINAL AUTHOR -C -C USAGE: XX = RISC02(XT,V,L,SST,JERR) -C INPUT ARGUMENT LIST: -C XT - 7-WORD ARRAY CONTAINING BRIGHTNESS TEMPERATURE IN THE -C - ORDER: T19V (WORD 1), T19H (WORD 2), T22V (WORD 3), -C - T37V (WORD 4), T37H (WORD 5), T85V (WORD 6), T85H -C - (WORD 7) (ALL IN KELVIN) -C -C OUTPUT ARGUMENT LIST: -C V - COLUMNAR WATER VAPOR (TOTAL PRECIP. WATER) (MM) -C L - COLUMNAR LIQUID WATER (MM) -C SST - SEA SURFACE TEMPERATURE (DEG. C) -C XX - WIND SPEED (METERS/SECOND) AT THE HEIGHT OF 20 METERS -C JERR - ERROR RETURN CODE: -C = 0 -- GOOD RETRIEVALS -C = 1 -- RETRIEVALS COULD NOT BE MADE DUE TO ONE OR -C MORE BRIGHTNESS TEMPERATURES OUT OF RANGE -C (I.E, FAILED THE RAIN FLAG TEST) -C = 2 -- RETRIEVALS COULD NOT BE MADE DUE TO ICE -C CONTAMINATION -C {FOR EITHER 1 OR 2 ABOVE, ALL RETRIEVALS SET TO -C 99999. (MISSING)} -C -C REMARKS: FUNCTION, CALLED BY SUBROUTINE MISC01. -C -C Description of training and test data set: -C ------------------------------------------ -C The training set consists of 3460 matchups which were received -C from two sources: -C 1. 3187 F11/SSMI/buoy matchups were filtered out from a -C preliminary version of the new NRL database which was -C kindly provided by G. Poe (NRL). Maximum available wind -C speed is 24 m/s. -C 2. 273 F11/SSMI/OWS matchups were filtered out from two -C datasets collected by high latitude OWS LIMA and MIKE. -C These data sets were kindly provided by D. Kilham -C (University of Bristol). Maximum available wind speed -C is 26.4 m/s. -C -C Satellite data are collocated with both buoy and OWS data in -C space within 15 km and in time within 15 min. -C -C The test data set has the same structure, the same number of -C matchups and maximum buoy wind speed. -C -C Description of retrieval flags: -C ------------------------------- -C Retrieval flags by Stogryn et al. are used. The algorithm -C produces retrievals under CLEAR + CLOUDY conditions, that is -C if: -C -C T37V - T37H > 50. => CLEAR condition -C or -C T37V - T37H =< 50.| -C T19H =< 185. and | -C T37H =< 210. and | => CLOUDY conditions -C T19V < T37V | -C -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - FUNCTION RISC02(XT,V,L,SST,JERR) - PARAMETER (IOUT =4) - LOGICAL LQ1,LQ2,LQ3,LQ4 - REAL XT(7),Y(IOUT),V,L,SST - EQUIVALENCE (Y(1),SPN) - - JERR = 0 - -C -------- Retrieval flag (Stogryn) ------------------------- - -C T19H =< 185 - - LQ1 = (XT(2).LE.185.) - -C T37H =< 210 - - LQ2 = (XT(5).LE.210.) - -C T19V < T37V - - LQ3 = (XT(1).LT.XT(4)) - -C T37V - T37H =< 50. - - LQ4 = ((XT(4) - XT(5)).LE.50.) - LQ1 = (LQ1.AND.LQ2.AND.LQ3) - IF(.NOT.LQ1.AND.LQ4) THEN - SPN = 99999. - V = 99999. - L = 99999. - SST = 99999. - JERR = 1 - GO TO 111 - END IF - -C --------------- Call NN ---------------------- - -C NN WIND SPEED - - CALL MISC10(XT,Y) - V = Y(2) - L = Y(3) - SST = Y(4) - -C --------- Remove negative values ---------------------------- - - IF(SPN.LT.0.0) SPN = 0.0 - IF(SST.LT.0.0) SST = 0.0 - IF(V .LT.0.0) V = 0.0 - -C ------ Remove ice contamination ------------------------------------ - - ICE = 0 - SI85 = -174.4 + (0.715 * XT(1)) + (2.439 * XT(3)) - (0.00504 * - $ XT(3) * XT(3)) - XT(6) - TT = 44. + (0.85 * XT(1)) - IF(SI85.GE.10.) THEN - IF(XT(3).LE.TT) ICE = 1 - IF((XT(3).GT.264.).AND.((XT(3)-XT(1)).LT.2.)) ICE = 1 - END IF - IF(ICE.EQ.1) THEN - SPN = 99999. - V = 99999. - L = 99999. - SST = 99999. - JERR = 2 - END IF - - 111 CONTINUE - - RISC02 = SPN - - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: MISC10 CALC. SSM/I PRODS FROM NEURAL NET 3 ALG. -C PRGMMR: V. KRASNOPOLSKY ORG: NP20 DATE: 1996-07-15 -C -C ABSTRACT: THIS NN CALCULATES W (IN M/S), V (IN MM), L (IN MM), AND -C SST (IN DEG C). THIS NN WAS TRAINED ON BLENDED F11 DATA SET -C (SSMI/BUOY MATCHUPS PLUS SSMI/OWS MATCHUPS 15 KM X 15 MIN) UNDER -C CLEAR + CLOUDY CONDITIONS. -C -C PROGRAM HISTORY LOG: -C 1996-07-15 V. KRASNOPOLSKY -- ORIGINAL AUTHOR -C -C USAGE: CALL MISC10(X,Y) -C INPUT ARGUMENT LIST: -C X - 5-WORD ARRAY CONTAINING BRIGHTNESS TEMPERATURE IN THE -C - ORDER: T19V (WORD 1), T19H (WORD 2), T22V (WORD 3), -C - T37V (WORD 4), T37H (WORD 5) (ALL IN KELVIN) -C -C OUTPUT ARGUMENT LIST: -C Y - 4-WORD ARRAY CONTAINING CALCULATED PRODUCTS IN THE -C - ORDER: WIND SPEED (M/S) (WORD 1), COLUMNAR WATER -C - VAPOR (TOTAL PRECIP. WATER) (MM) (WORD 2), COLUMNAR -C - LIQUID WATER (MM) (WORD 3), SEA SURFACE TEMPERATURE -C - (DEG. C) (WORD 4) -C -C REMARKS: CALLED BY SUBROUTINE RISC02. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE MISC10(X,Y) - INTEGER HID,OUT - -C IN IS THE NUMBER OF NN INPUTS, HID IS THE NUMBER OF HIDDEN NODES, -C OUT IS THE NUMBER OF OUTPUTS - - PARAMETER (IN =5, HID =12, OUT =4) - DIMENSION X(IN),Y(OUT),W1(IN,HID),W2(HID,OUT),B1(HID),B2(OUT), - $ O1(IN),X2(HID),O2(HID),X3(OUT),O3(OUT),A(OUT),B(OUT) - -C W1 HOLDS INPUT WEIGHTS - - DATA ((W1(I,J),J = 1,HID),I = 1,IN)/ - $-0.0435901, 0.0614709,-0.0453639,-0.0161106,-0.0271382, 0.0229015, - $-0.0650678, 0.0704302, 0.0383939, 0.0773921, 0.0661954,-0.0643473, - $-0.0108528,-0.0283174,-0.0308437,-0.0199316,-0.0131226, 0.0107767, - $ 0.0234265,-0.0291637, 0.0140943, .00567931,-.00931768, - $-.00860661, 0.0159747,-0.0749903,-0.0503523, 0.0524172, 0.0195771, - $ 0.0302056, 0.0331725, 0.0326714,-0.0291429, 0.0180438, 0.0281923, - $-0.0269554, 0.102836, 0.0591511, 0.134313, -0.0109854,-0.0786303, - $ 0.0117111, 0.0231543,-0.0205603,-0.0382944,-0.0342049, - $ 0.00052407,0.110301, -0.0404777, 0.0428816, 0.0878070, 0.0168326, - $ 0.0196183, 0.0293995, 0.00954805,-.00716287,0.0269475, - $-0.0418217,-0.0165812, 0.0291809/ - -C W2 HOLDS HIDDEN WEIGHTS - - DATA ((W2(I,J),J = 1,OUT),I = 1,HID)/ - $-0.827004, -0.169961,-0.230296, -0.311201, -0.243296, 0.00454425, - $ 0.950679, 1.09296, 0.0842604, 0.0140775, 1.80508, -0.198263, - $-0.0678487, 0.428192, 0.827626, 0.253772, 0.112026, 0.00563793, - $-1.28161, -0.169509, 0.0019085,-0.137136, -0.334738, 0.224899, - $-0.189678, 0.626459,-0.204658, -0.885417, -0.148720, 0.122903, - $ 0.650024, 0.715758, 0.735026, -0.123308, -0.387411,-0.140137, - $ 0.229058, 0.244314,-1.08613, -0.294565, -0.192568, 0.608760, - $-0.753586, 0.897605, 0.0322991,-0.178470, 0.0807701, - $-0.781417/ - -C B1 HOLDS HIDDEN BIASES - - DATA (B1(I), I=1,HID)/ - $ -9.92116,-10.3103,-17.2536, -5.26287, 17.7729,-20.4812, - $ -4.80869,-11.5222, 0.592880,-4.89773,-17.3294, -7.74136/ - -C B2 HOLDS OUTPUT BIAS - - DATA (B2(I), I=1,OUT)/-0.882873,-0.0120802,-3.19400,1.00314/ - -C A(OUT), B(OUT) HOLD TRANSFORMATION COEFFICIENTS - - DATA (A(I), I=1,OUT)/18.1286,31.8210,0.198863,37.1250/ - DATA (B(I), I=1,OUT)/13.7100,32.0980,0.198863,-5.82500/ - -C INITIALIZE - - O1 = X - -C START NEURAL NETWORK - -C - INITIALIZE X2 - - DO I = 1,HID - X2(I) = 0. - DO J = 1,IN - X2(I) = X2(I) + (O1(J) * W1(J,I)) - END DO - X2(I) = X2(I) + B1(I) - O2(I) = TANH(X2(I)) - END DO - -C - INITIALIZE X3 - - DO K = 1,OUT - X3(K) = 0. - DO J = 1,HID - X3(K) = X3(K) + (W2(J,K) * O2(J)) - END DO - - X3(K) = X3(K) + B2(K) - -C --- CALCULATE O3 - - O3(K) = TANH(X3(K)) - Y(K) = (A(K) * O3(K)) + B(K) - END DO - - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: RISC02xx CALC. WSPD FROM NEURAL NET 2 ALGORITHM -C PRGMMR: V. KRASNOPOLSKY ORG: NP20 DATE: 1996-05-07 -C -C ABSTRACT: CALCULATES A SINGLE NEURAL NETWORK OUTPUT FOR WIND SPEED. -C THE NETWORK WAS TRAINED ON THE WHOLE DATA SET WITHOUT ANY -C SEPARATION INTO SUBSETS. IT GIVES RMS = 1.64 M/S FOR TRAINING SET -C AND 1.65 M/S FOR TESTING SET. THIS IS AN IMPROVED VERSION OF THE -C EARLIER NEURAL NETWORK 1 ALGORITHM. -C -C PROGRAM HISTORY LOG: -C 1994-03-20 V. KRASNOPOLSKY -- ORIGINAL AUTHOR -C 1995-05-07 V. KRASNOPOLSKY -- REPLACED WITH NEURAL NET 2 ALGORITHM -C -C USAGE: XX = RISC02xx(X) -C INPUT ARGUMENT LIST: -C X - 5-WORD ARRAY CONTAINING BRIGHTNESS TEMPERATURE IN THE -C - ORDER: T19V (WORD 1), T22V (WORD 2), T37V (WORD 3), -C - T37H (WORD 4), T85V (WORD 5) (ALL IN KELVIN) -C -C OUTPUT ARGUMENT LIST: -C XX - WIND SPEED (METERS/SECOND) -C -C REMARKS: FUNCTION, NO LONGER CALLED BY THIS PROGRAM. IT IS HERE -C SIMPLY TO SAVE NEURAL NET 2 ALGORITHM FOR POSSIBLE LATER USE -C (HAS BEEN REPLACED BY NEURAL NET 3 ALGORITHM, SEE SUBR. RISC02 -C AND MISC10). -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - FUNCTION RISC02xx(X) - INTEGER HID -C IN IS THE NUMBER OF B. TEMP. CHNLS, HID IS THE NUMBER OF HIDDEN NODES - PARAMETER (IN =5, HID =2) - DIMENSION X(IN),W1(IN,HID),W2(HID),B1(HID),O1(IN),X2(HID),O2(HID) - - SAVE - -C W1 HOLDS INPUT WEIGHTS - DATA ((W1(I,J),J=1,HID),I=1,IN)/ - $ 4.402388E-02, 2.648334E-02, 6.361322E-04,-1.766535E-02, - $ 7.876555E-03,-7.387260E-02,-2.656543E-03, 2.957161E-02, - $-1.181134E-02, 4.520317E-03/ -C W2 HOLDS HIDDEN WEIGHTS - DATA (W2(I),I=1,HID)/8.705661E-01,1.430968/ -C B1 HOLDS HIDDEN BIASES - DATA (B1(I),I=1,HID)/-6.436114,8.799655/ -C B2 HOLDS OUTPUT BIAS -C AY AND BY HOLD OUTPUT TRANSFORMATION COEFFICIENTS - DATA B2/-0.736255/,AY/16.7833/,BY/11.08/ - O1 = X -C INITIALIZE - X3 = 0. - DO I = 1, HID - O2(I) = 0. - X2(I) = 0. - DO J = 1,IN - X2(I) = X2(I) + (O1(J) * W1(J,I)) - END DO - X2(I) = X2(I) + B1(I) - O2(I) = TANH(X2(I)) - X3 = X3 + (O2(I)* W2(I)) - END DO - X3 = X3 + B2 - O3 = TANH(X3) - RISC02xx = (AY * O3) + BY - RISC02xx = MAX(RISC02xx,0.0) -C BIAS CORRECTION - BIAS = 0.5 + 0.004*((RISC02xx-10.)**3)*(1.-EXP(-0.5*RISC02xx)) - RISC02xx = RISC02xx + BIAS - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: RISC03 CALC. W.SPD FROM B TEMP.- GOODBERLET ALG -C PRGMMR: W. GEMMILL ORG: NP21 DATE: 1994-08-15 -C -C ABSTRACT: CALCULATES A SINGLE GOODBERLET OUTPUT FOR WIND SPEED. -C THIS IS A LINEAR REGRESSION ALGORITHM FROM 1989. -C -C PROGRAM HISTORY LOG: -C 1994-08-15 W. GEMMILL -- ORIGINAL AUTHOR -C -C USAGE: XX = RISC03(X) -C INPUT ARGUMENT LIST: -C X - 4-WORD ARRAY CONTAINING BRIGHTNESS TEMPERATURE IN THE -C - ORDER: T19V (WORD 1), T22V (WORD 2), T37V (WORD 3), -C - T37H (WORD 4) (ALL IN KELVIN) -C -C OUTPUT ARGUMENT LIST: -C XX - WIND SPEED (METERS/SECOND) -C -C REMARKS: FUNCTION, CALLED BY SUBROUTINE MISC01. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - FUNCTION RISC03(X) - DIMENSION X(4) - - SAVE - - RISC03 = 147.90 + (1.0969 * X(1)) - (0.4555 * X(2)) - - $ (1.76 * X(3)) + (0.7860 * X(4)) - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: MISC04 RETURNS LAND/SEA TAG FOR GIVEN LAT/LON -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1995-01-04 -C -C ABSTRACT: FINDS AND RETURNS THE LOW RESOLUTION LAND/SEA TAG NEAREST -C TO THE REQUESTED LATITUDE AND LONGITUDE. -C -C PROGRAM HISTORY LOG: -C 1978-01-20 J. K. KALINOWSKI (S11213) -- ORIGINAL AUTHOR -C 1978-10-03 J. K. KALINOWSKI (S1214) -- CHANGES UNKNOWN -C 1985-03-01 N. DIGIROLAMO (SSAI) -- CONVERSION TO VS FORTRAN -C 1995-01-04 D. A. KEYSER -- INCORPORATED INTO W3MISCAN AND -C STREAMLINED CODE -C -C USAGE: CALL MISC04(INLSF,BLAT,BLNG,LSTAG) -C INPUT ARGUMENT LIST: -C INLSF - UNIT NUMBER OF DIRECT ACCESS NESDIS LAND/SEA FILE -C BLAT - LATITUDE (WHOLE DEGREES: RANGE IS 0. TO +90. NORTH, -C - 0. TO -90. SOUTH) -C BLNG - LONGITUDE (WHOLE DEGREES: RANGE IS 0. TO +179.99 EAST, -C - 0. TO -180. WEST) -C -C OUTPUT ARGUMENT LIST: -C LSTAG - LAND/SEA TAG {=0 - SEA; =1 - LAND; =2 - COASTAL -C - INTERFACE (HIGHER RESOLUTION TAGS ARE AVAILABLE); -C - =3 - COASTAL INTERFACE (NO HIGHER RESOLUTION TAGS -C - EXIST)} -C -C REMARKS: CALLED BY SUBROUTINE W3MISCAN. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE MISC04(INLSF,BLAT,BLNG,LSTAG) - CHARACTER*1 LPUT - REAL RGS(3) -C LPUT CONTAINS A REGION OF LAND/SEA TAGS (RETURNED FROM CALL TO MISC05) - COMMON/MISCDD/LPUT(21960) - - SAVE - -C RGS IS ARRAY HOLDING SOUTHERN BOUNDARIES OF EACH LAND/SEA TAG REGION - DATA RGS/-85.,-30.,25./,NUMRGL/0/,IFLAG/0/ -C INITIALIZE LAND/SEA TAG AS 1 (OVER LAND) - LSTAG = 1 -C FIND NEAREST POINT OF A HALF-DEGREE (LAT,LONG) GRID -C ..ALAT IS LATITUDE TO THE NEAREST HALF-DEGREE - ALAT = INT((BLAT+SIGN(.25,BLAT))/.5) * .5 -C ..ALNG IS LONGITUDE TO THE NEAREST HALF-DEGREE - ALNG = INT((BLNG+SIGN(.25,BLNG))/.5) * .5 - IF(NINT(ALNG*10.).EQ.1800) ALNG = -180. -C IDENTIFY DATABASE REGION IN WHICH TO FIND CORRECT TAG - NUMRGN = 1 - IF(IABS(NINT(ALAT*10)).GT.850) THEN - RETURN - ELSE IF(NINT(ALAT*10).GT.275) THEN - NUMRGN = 3 - ELSE IF(NINT(ALAT*10.).GE.-275) THEN - NUMRGN = 2 - END IF - IF(NUMRGN.NE.NUMRGL.OR.IFLAG.EQ.1) THEN - NUMRGL = NUMRGN - CALL MISC05(INLSF,NUMRGN,*99) - END IF -C FIND THE BYTE & BIT PAIR W/I DATA BASE REGION CONTAINING DESIRED TAG - TRM1 = ((ALAT - RGS(NUMRGN)) * 1440.) + 360. - LSTPT = TRM1 + (2. * ALNG) -C ..NBYTE IS THE BYTE IN LPUT CONTAINING THE TAG - NBYTE = (180 * 8) + (LSTPT/4 * 8) - NSHFT = (2 * (MOD(LSTPT,4) + 1)) - 2 -C PULL OUT THE TAG - CALL GBYTE(LPUT,LSTAG,NBYTE+NSHFT,2) - IFLAG = 0 - RETURN -C----------------------------------------------------------------------- - 99 CONTINUE -C COME HERE IF LAND/SEA TAG COULD NOT BE RETURNED FROM SUBR. W3MISCAN -C (IN THIS CASE IT WILL REMAIN SET TO 1 INDICATING OVER LAND) - IFLAG = 1 - RETURN -C----------------------------------------------------------------------- - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: MISC05 READS 2 RECORDS FROM LAND/SEA TAG DTABASE -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1995-01-04 -C -C ABSTRACT: READS TWO RECORDS FROM A LOW RESOLUTION LAND/SEA DATABASE -C AND STORES INTO COMMON. -C -C PROGRAM HISTORY LOG: -C 1978-01-20 J. K. KALINOWSKI (S11213) -- ORIGINAL AUTHOR -C 1995-01-04 D. A. KEYSER -- INCORPORATED INTO W3MISCAN AND -C STREAMLINED CODE; MODIFIED TO BE MACHINE INDEPENDENT THRU -C USE OF STANDARD FORTRAN DIRECT ACCESS READ -C -C USAGE: CALL MISC05(INLSF,NUMRGN) -C INPUT ARGUMENT LIST: -C INLSF - UNIT NUMBER OF DIRECT ACCESS NESDIS LAND/SEA FILE -C NUMRGN - THE REGION (1,2 OR 3) OF THE DATABASE TO BE ACCESSED -C - (DEPENDENT ON LATITUDE BAND) -C -C INPUT FILES: -C UNIT AA - (WHERE AA IS EQUAL TO INPUT ARGUMENT 'INLSF') -C - DIRECT ACCESS NESDIS LAND/SEA FILE -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY SUBROUTNE MISC04. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE MISC05(INLSF,NUMRGN,*) - CHARACTER*1 LPUT - -C LPUT CONTAINS A REGION OF LAND/SEA TAGS (COMPRISED OF 2 RECORDS FROM -C LAND/SEA FILE) -- 180 BYTES OF DOCUMENTATION FOLLOWED BY 21780 BYTES -C OF LAND/SEA TAGS - - COMMON/MISCDD/LPUT(21960) - - SAVE - - NREC = (2 * NUMRGN) - 1 - READ(INLSF,REC=NREC,ERR=10) (LPUT(II),II=1,10980) - NREC = NREC + 1 - READ(INLSF,REC=NREC,ERR=10) (LPUT(II),II=10981,21960) - RETURN -C----------------------------------------------------------------------- - 10 CONTINUE -C ERROR READING IN A RECORD FROM LAND-SEA FILE -- RETURN (TAG WILL BE -C SET TO 1 MEANING OVER LAND IN THIS CASE) - PRINT 1000, NREC,INLSF - 1000 FORMAT(' ##W3MISCAN/MISC05: ERROR READING IN LAND-SEA DATA ', - $ 'RECORD',I7,' IN UNIT ',I2,' -- SET TAG TO LAND'/) - RETURN 1 -C----------------------------------------------------------------------- - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: MISC06 READS IN NH AND SH 1-DEG. SEA-SFC TEMPS. -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2000-02-18 -C -C ABSTRACT: READS IN GLOBAL SEA-SURFACE TEMPERATURE FIELD ON A ONE- -C DEGREE GRID FROM GRIB FILE. -C -C PROGRAM HISTORY LOG: -C ????-??-?? W. GEMMILL (NP21) -- ORIGINAL AUTHOR -C 1995-01-04 D. A. KEYSER -- INCORPORATED INTO W3MISCAN AND -C STREAMLINED CODE; CONVERTED SST INPUT FILE FROM VSAM/ON84 TO -C GRIB TO ALLOW CODE COMPILE AND RUN ON THE CRAY MACHINES. -C 2000-02-18 D. A. KEYSER -- MODIFIED TO CALL W3LIB ROUTINE "GETGB", -C THIS ALLOWS CODE TO COMPILE AND RUN PROPERLY ON IBM-SP -C -C USAGE: CALL MISC06(INGBI,INGBD,IDAT1,IDAT2,*,*,*,*) -C INPUT ARGUMENT LIST: -C INGBI - UNIT NUMBER OF GRIB INDEX FILE FOR GRIB FILE -C - CONTAINING GLOBAL 1-DEGREE SEA-SURFACE TEMP FIELD -C INGBD - UNIT NUMBER OF GRIB FILE CONTAINING GLOBAL 1-DEGREE -C - SEA-SURFACE TEMP FIELD -C IDAT1 - REQUESTED EARLIEST YEAR(YYYY), MONTH, DAY, HOUR, MIN -C IDAT2 - REQUESTED LATEST YEAR(YYYY), MONTH, DAY, HOUR, MIN -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY SUBROUTINE W3MISCAN. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE MISC06(INGBI,INGBD,IDAT1,IDAT2,*,*,*,*) - PARAMETER (MAXPTS=360*180) - LOGICAL*1 LBMS(360,180) - INTEGER KPDS(200),KGDS(200),LPDS(200),LGDS(200),IDAT1(5), - $ IDAT2(5),JDAT1(8),JDAT2(8),KDAT(8),LDAT(8),MDATE(8) - REAL RINC(5) - CHARACTER*11 ENVVAR - CHARACTER*80 FILEB,FILEI - COMMON/MISCCC/SSTDAT(360,180) - - SAVE - - ENVVAR='XLFUNIT_ ' - WRITE(ENVVAR(9:10),FMT='(I2)') INGBD - CALL GETENV(ENVVAR,FILEB) - ENVVAR='XLFUNIT_ ' - WRITE(ENVVAR(9:10),FMT='(I2)') INGBI - CALL GETENV(ENVVAR,FILEI) - CALL BAOPENR(INGBD,FILEB,IRET1) -ccccc PRINT *,'SAGT: ',INGBD,FILEB,IRET1 - CALL BAOPENR(INGBI,FILEI,IRET2) -ccccc PRINT *,'SAGT: ',INGBI,FILEI,IRET2 - - KPDS = -1 - KGDS = -1 - N = -1 - KPDS(5) = 11 - KPDS(6) = 1 - KPDS(7) = 0 - KPDS(8) = -1 - KPDS(9) = -1 - KPDS(10) = -1 - PRINT 68, INGBD - 68 FORMAT(//4X,'** W3MISCAN/MISC06: READ IN "CURRENT" SEA-SURFACE ', - $ 'TEMPERATURE DATA FROM GRIB MESSAGE IN UNIT',I3) - CALL GETGB(INGBD,INGBI,MAXPTS,0,KPDS,KGDS,KF,K,LPDS,LGDS,LBMS, - $ SSTDAT,IRET) -C....................................................................... -C ABNORMAL RETURN IF PROBLEM WITH SST IN GRIB FILE - IF(IRET.NE.0) THEN - WRITE(6,*)' ERROR READING SST USING GETGB. IRET = ',IRET - IF (IRET.EQ.96) RETURN 1 - IF (IRET.EQ.97) RETURN 3 - IF (IRET.EQ.98) RETURN 3 - IF (IRET.EQ.99) RETURN 3 - RETURN 4 - ENDIF -C....................................................................... -C READ SUCCESSFUL - JDAT1 = 0 - JDAT2 = 0 - JDAT1(1:3) = IDAT1(1:3) - JDAT1(5:6) = IDAT1(4:5) - JDAT2(1:3) = IDAT2(1:3) - JDAT2(5:6) = IDAT2(4:5) - MDATE = 0 - MDATE(1) = ((LPDS(21) - 1) * 100) + LPDS(8) - MDATE(2:3) = LPDS(9:10) - MDATE(5:6) = LPDS(11:12) - CALL W3MOVDAT((/-7.,0.,0.,0.,0./),JDAT1,KDAT) - CALL W3MOVDAT((/ 7.,0.,0.,0.,0./),JDAT2,LDAT) -cppppp - print *, '** W3MISCAN/MISCO6: SST GRIB FILE MUST HAVE DATE ', - $ 'BETWEEN ',(kdat(iii),iii=1,3),(kdat(iii),iii=5,6),' AND ', - $ (ldat(iii),iii=1,3),(ldat(iii),iii=5,6) - print *, ' RETURNED FROM GRIB FILE IS YEAR ', - $ 'OF CENTURY = ',lpds(8),' AND CENTURY = ',lpds(21) - print *, ' CALULATED 4-DIGIT YEAR IS = ', - $ mdate(1) -cppppp - CALL W3DIFDAT(KDAT,MDATE,3,RINC) - KMIN = RINC(3) - CALL W3DIFDAT(LDAT,MDATE,3,RINC) - LMIN = RINC(3) - IF(KMIN.GT.0.OR.LMIN.LT.0) THEN -C....................................................................... -C COME HERE IF SST GRIB MSG HAS A DATE THAT IS EITHER: 1) MORE THAN 7- -C DAYS PRIOR TO THE EARLIEST REQ. DATE (INPUT ARG. "IDAT1" TO W3MISCAN) -C OR 2) MORE THAN 7-DAYS AFTER THE LATEST REQ. DATE (INPUT ARG. -C "IDAT2" TO W3MISCAN) - PRINT 27, (MDATE(III),III=1,3),(MDATE(III),III=5,6) - 27 FORMAT(/' ##W3MISCAN/MISC06: SST GRIB MSG HAS DATE:',I5,4I3, - $ ' - AS A RESULT......') - RETURN 2 -C....................................................................... - END IF - PRINT 60, (MDATE(III),III=1,3),(MDATE(III),III=5,6) - 60 FORMAT(/4X,'** W3MISCAN/MISC06: SEA-SFC TEMP SUCCESSFULLY READ ', - $ 'IN FROM GRIB FILE, DATE IS: ',I5,4I3/) - RETURN - - CALL BACLOSE(INGBI,IRET) - CALL BACLOSE(INGBD,IRET) - - END diff --git a/src/fim/FIMsrc/w3/w3movdat.f b/src/fim/FIMsrc/w3/w3movdat.f deleted file mode 100644 index 16cbade..0000000 --- a/src/fim/FIMsrc/w3/w3movdat.f +++ /dev/null @@ -1,53 +0,0 @@ -!----------------------------------------------------------------------- - subroutine w3movdat(rinc,idat,jdat) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: W3MOVDAT RETURN A DATE FROM A TIME INTERVAL AND DATE -! AUTHOR: MARK IREDELL ORG: WP23 DATE: 98-01-05 -! -! ABSTRACT: THIS SUBPROGRAM RETURNS THE DATE AND TIME THAT IS A GIVEN -! NCEP RELATIVE TIME INTERVAL FROM AN NCEP ABSOLUTE DATE AND TIME. -! THE OUTPUT IS IN THE NCEP ABSOLUTE DATE AND TIME DATA STRUCTURE. -! -! PROGRAM HISTORY LOG: -! 98-01-05 MARK IREDELL -! -! USAGE: CALL W3MOVDAT(RINC,IDAT,JDAT) -! -! INPUT VARIABLES: -! RINC REAL (5) NCEP RELATIVE TIME INTERVAL -! (DAYS, HOURS, MINUTES, SECONDS, MILLISECONDS) -! IDAT INTEGER (8) NCEP ABSOLUTE DATE AND TIME -! (YEAR, MONTH, DAY, TIME ZONE, -! HOUR, MINUTE, SECOND, MILLISECOND) -! -! OUTPUT VARIABLES: -! JDAT INTEGER (8) NCEP ABSOLUTE DATE AND TIME -! (YEAR, MONTH, DAY, TIME ZONE, -! HOUR, MINUTE, SECOND, MILLISECOND) -! (JDAT IS LATER THAN IDAT IF TIME INTERVAL IS POSITIVE.) -! -! SUBPROGRAMS CALLED: -! IW3JDN COMPUTE JULIAN DAY NUMBER -! W3FS26 YEAR, MONTH, DAY FROM JULIAN DAY NUMBER -! W3REDDAT REDUCE A TIME INTERVAL TO A CANONICAL FORM -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! -!$$$ - real rinc(5) - integer idat(8),jdat(8) - real rinc1(5),rinc2(5) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! add the interval to the input time of day and put into reduced form -! and then compute new date using julian day arithmetic. - rinc1(1)=rinc(1) - rinc1(2:5)=rinc(2:5)+idat(5:8) - call w3reddat(-1,rinc1,rinc2) - jldayn=iw3jdn(idat(1),idat(2),idat(3))+nint(rinc2(1)) - call w3fs26(jldayn,jdat(1),jdat(2),jdat(3),jdow,jdoy) - jdat(4)=idat(4) - jdat(5:8)=nint(rinc2(2:5)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end diff --git a/src/fim/FIMsrc/w3/w3nogds.f b/src/fim/FIMsrc/w3/w3nogds.f deleted file mode 100644 index ee5ca6a..0000000 --- a/src/fim/FIMsrc/w3/w3nogds.f +++ /dev/null @@ -1,446 +0,0 @@ - SUBROUTINE W3NOGDS(ITYPE,FLD,IFLD,IBITL, - & IPFLAG,ID,PDS, - & IGFLAG,IGRID,IGDS,ICOMP, - & IBFLAG,IBMAP,IBLEN,IBDSFL, - & NPTS,KBUF,ITOT,JERR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3NOGDS MAKE A COMPLETE GRIB MESSAGE -C PRGMMR: FARLEY ORG: NMC421 DATE:94-11-22 -C -C ABSTRACT: MAKES A COMPLETE GRIB MESSAGE FROM A USER SUPPLIED -C ARRAY OF FLOATING POINT OR INTEGER DATA. THE USER HAS THE -C OPTION OF SUPPLYING THE PDS OR AN INTEGER ARRAY THAT WILL BE -C USED TO CREATE A PDS (WITH W3FI68). THE USER MUST ALSO -C SUPPLY OTHER NECESSARY INFO; SEE USAGE SECTION BELOW. -C -C PROGRAM HISTORY LOG: -C 97-02-24 M. FARLEY MODIFIED W3FI72 - this routine allows for -C NO GDS (errors in W3FI71 for GRIB grids -C 21-26, 61-64 forced the need for this routine). -C 98-06-24 Gilbert Added number of gridpoint values for grids -C 61-64, needed when igflag=2 ( no gds ). -C 98-12-21 Gilbert Replaced Function ICHAR with mova2i. -C -C USAGE: CALL W3NOGDS(ITYPE,FLD,IFLD,IBITL, -C & IPFLAG,ID,PDS, -C & IGFLAG,IGRID,IGDS,ICOMP, -C & IBFLAG,IBMAP,IBLEN,IBDSFL, -C & IBDSFL, -C & NPTS,KBUF,ITOT,JERR) -C -C INPUT ARGUMENT LIST: -C ITYPE - 0 = FLOATING POINT DATA SUPPLIED IN ARRAY 'FLD' -C 1 = INTEGER DATA SUPPLIED IN ARRAY 'IFLD' -C FLD - REAL ARRAY OF DATA (AT PROPER GRIDPOINTS) TO BE -C CONVERTED TO GRIB FORMAT IF ITYPE=0. -C SEE REMARKS #1 & 2. -C IFLD - INTEGER ARRAY OF DATA (AT PROPER GRIDPOINTS) TO BE -C CONVERTED TO GRIB FORMAT IF ITYPE=1. -C SEE REMARKS #1 & 2. -C IBITL - 0 = COMPUTER COMPUTES LENGTH FOR PACKING DATA FROM -C POWER OF 2 (NUMBER OF BITS) BEST FIT OF DATA -C USING 'VARIABLE' BIT PACKER W3FI58. -C 8, 12, ETC. COMPUTER RESCALES DATA TO FIT INTO THAT -C 'FIXED' NUMBER OF BITS USING W3FI59. -C SEE REMARKS #3. -C -C IPFLAG - 0 = MAKE PDS FROM USER SUPPLIED ARRAY (ID) -C 1 = USER SUPPLYING PDS -C NOTE: IF PDS IS GREATER THAN 30, USE IPLFAG=1. -C THE USER COULD CALL W3FI68 BEFORE HE CALLS -C W3NOGDS. THIS WOULD MAKE THE FIRST 30 BYTES OF -C THE PDS, USER THEN WOULD MAKE BYTES AFTER 30. -C ID - INTEGER ARRAY OF VALUES THAT W3FI68 WILL USE -C TO MAKE AN EDITION 1 PDS IF IPFLAG=0. (SEE THE -C DOCBLOCK FOR W3FI68 FOR LAYOUT OF ARRAY) -C PDS - CHARACTER ARRAY OF VALUES (VALID PDS SUPPLIED -C BY USER) IF IPFLAG=1. LENGTH MAY EXCEED 28 BYTES -C (CONTENTS OF BYTES BEYOND 28 ARE PASSED -C THROUGH UNCHANGED). -C -C IGFLAG - 0 = MAKE GDS BASED ON 'IGRID' VALUE. -C 1 = MAKE GDS FROM USER SUPPLIED INFO IN 'IGDS' -C AND 'IGRID' VALUE. -C SEE REMARKS #4. -C 2 = NO GDS WILL BE INCLUDED...for international grids -C *** THIS IS AN EXCEPTION TO REMARKS #4!!!! -C IGRID - # = GRID IDENTIFICATION (TABLE B) -C 255 = IF USER DEFINED GRID; IGDS MUST BE SUPPLIED -C AND IGFLAG MUST =1. -C IGDS - INTEGER ARRAY CONTAINING USER GDS INFO (SAME -C FORMAT AS SUPPLIED BY W3FI71 - SEE DOCKBLOCK FOR -C LAYOUT) IF IGFLAG=1. -C ICOMP - RESOLUTION AND COMPONENT FLAG FOR BIT 5 OF GDS(17) -C 0 = EARTH ORIENTED WINDS -C 1 = GRID ORIENTED WINDS -C -C IBFLAG - 0 = MAKE BIT MAP FROM USER SUPPLIED DATA -C # = BIT MAP PREDEFINED BY CENTER -C SEE REMARKS #5. -C IBMAP - INTEGER ARRAY CONTAINING BIT MAP -C IBLEN - LENGTH OF BIT MAP WILL BE USED TO VERIFY LENGTH -C OF FIELD (ERROR IF IT DOESN'T MATCH). -C -C IBDSFL - INTEGER ARRAY CONTAINING TABLE 11 FLAG INFO -C BDS OCTET 4: -C (1) 0 = GRID POINT DATA -C 1 = SPHERICAL HARMONIC COEFFICIENTS -C (2) 0 = SIMPLE PACKING -C 1 = SECOND ORDER PACKING -C (3) ... SAME VALUE AS 'ITYPE' -C 0 = ORIGINAL DATA WERE FLOATING POINT VALUES -C 1 = ORIGINAL DATA WERE INTEGER VALUES -C (4) 0 = NO ADDITIONAL FLAGS AT OCTET 14 -C 1 = OCTET 14 CONTAINS FLAG BITS 5-12 -C (5) 0 = RESERVED - ALWAYS SET TO 0 -C BYTE 6 OPTION 1 NOT AVAILABLE (AS OF 5-16-93) -C (6) 0 = SINGLE DATUM AT EACH GRID POINT -C 1 = MATRIX OF VALUES AT EACH GRID POINT -C BYTE 7 OPTION 0 WITH SECOND ORDER PACKING N/A (AS OF 5-16-93) -C (7) 0 = NO SECONDARY BIT MAPS -C 1 = SECONDARY BIT MAPS PRESENT -C (8) 0 = SECOND ORDER VALUES HAVE CONSTANT WIDTH -C 1 = SECOND ORDER VALUES HAVE DIFFERENT WIDTHS -C -C OUTPUT ARGUMENT LIST: -C NPTS - NUMBER OF GRIDPOINTS IN ARRAY FLD OR IFLD -C KBUF - ENTIRE GRIB MESSAGE ('GRIB' TO '7777') -C EQUIVALENCE TO INTEGER ARRAY TO MAKE SURE IT -C IS ON WORD BOUNARY. -C ITOT - TOTAL LENGTH OF GRIB MESSAGE IN BYTES -C JERR - = 0, COMPLETED MAKING GRIB FIELD WITHOUT ERROR -C 1, IPFLAG NOT 0 OR 1 -C 2, IGFLAG NOT 0 OR 1 OR 2 -C 3, ERROR CONVERTING IEEE F.P. NUMBER TO IBM370 F.P. -C 4, W3FI71 ERROR/IGRID NOT DEFINED -C 5, W3FK74 ERROR/GRID REPRESENTATION TYPE NOT VALID -C 6, GRID TOO LARGE FOR PACKER DIMENSION ARRAYS -C SEE AUTOMATION DIVISION FOR REVISION! -C 7, LENGTH OF BIT MAP NOT EQUAL TO SIZE OF FLD/IFLD -C 8, W3FI73 ERROR, ALL VALUES IN IBMAP ARE ZERO -C -C OUTPUT FILES: -C FT06F001 - STANDARD FORTRAN OUTPUT PRINT FILE -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - W3FI58, W3FI59, W3FI68, W3FI71, W3FI73, W3FI74 -C W3FI75, W3FI76, W3FI01 -C -C REMARKS: -C 1) IF BIT MAP TO BE INCLUDED IN MESSAGE, NULL DATA SHOULD -C BE INCLUDED IN FLD OR IFLD. THIS ROUTINE WILL TAKE CARE -C OF 'DISCARDING' ANY NULL DATA BASED ON THE BIT MAP. -C 2) UNITS MUST BE THOSE IN GRIB DOCUMENTATION: NMC O.N. 388 -C OR WMO PUBLICATION 306. -C 3) IN EITHER CASE, INPUT NUMBERS WILL BE MULTIPLIED BY -C '10 TO THE NTH' POWER FOUND IN ID(25) OR PDS(27-28), -C THE D-SCALING FACTOR, PRIOR TO BINARY PACKING. -C 4) ALL NMC PRODUCED GRIB FIELDS WILL HAVE A GRID DEFINITION -C SECTION INCLUDED IN THE GRIB MESSAGE. ID(6) WILL BE -C SET TO '1'. -C - GDS WILL BE BUILT BASED ON GRID NUMBER (IGRID), UNLESS -C IGFLAG=1 (USER SUPPLYING IGDS). USER MUST STILL SUPPLY -C IGRID EVEN IF IGDS PROVIDED. -C 5) IF BIT MAP USED THEN ID(7) OR PDS(8) MUST INDICATE THE -C PRESENCE OF A BIT MAP. -C 6) ARRAY KBUF SHOULD BE EQUIVALENCED TO AN INTEGER VALUE OR -C ARRAY TO MAKE SURE IT IS ON A WORD BOUNDARY. -C 7) SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916/256, Y-MP8/864, Y-MP EL92/256, J916/2048 -C -C$$$ -C - PARAMETER (MXSIZE=260000) -C ALLOW UP TO 24 BITS PER POINT - PARAMETER (MXSIZ3=MXSIZE*3) - PARAMETER (MXSIZB=MXSIZE/8+6) -C FOR 64 BIT CRAY - PARAMETER (MXSIZI=MXSIZ3/8) -C FOR 32 BIT WORKSTATIONS AND HDS -C PARAMETER (MXSIZI=MXSIZ3/4) -C - REAL FLD(*) -C - INTEGER IBDSFL(*) - INTEGER IBMAP(*) - INTEGER ID(*) - INTEGER IFLD(*) - INTEGER IGDS(*) - INTEGER IPFLD(MXSIZI) - INTEGER IB(4) -C - CHARACTER * 1 BDS11(11) - CHARACTER * 1 KBUF(*) - CHARACTER * 1 PDS(*) - CHARACTER * 1 GDS(200) - CHARACTER * 1 BMS(MXSIZB) - CHARACTER * 1 PFLD(MXSIZ3) - CHARACTER * 1 SEVEN - CHARACTER * 1 ZERO -C - EQUIVALENCE (IPFLD(1),PFLD(1)) - EQUIVALENCE (BDS11(1),IDUMMY) -C -C ASCII REP OF /'G', 'R', 'I', 'B'/ -C - DATA IB / 71, 82, 73, 66/ -C - IER = 0 - IBERR = 0 - JERR = 0 - IGRIBL = 8 - IPDSL = 0 - LENGDS = 0 - LENBMS = 0 - LENBDS = 0 - ITOSS = 0 -C -C$ 1.0 PRODUCT DEFINITION SECTION(PDS). -C -C SET ID(6) TO 1 ...OR... MODIFY PDS(8) ... -C REGARDLESS OF USER SPECIFICATION... -C NMC GRIB FIELDS WILL ALWAYS HAVE A GDS -C ***** exception for international GRIB GRIDS 21-26, 61-64 -C ***** which will NOT contain a GDS until subroutine W3FI71 is fixed! -C - IF (IPFLAG .EQ.0) THEN - ID(6) = 1 - if (igflag .eq. 2) then - id(6) = 0 - endif - CALL W3FI68(ID,PDS) - ELSE IF (IPFLAG .EQ. 1) THEN - IF (IAND(mova2i(PDS(8)),64) .EQ. 64) THEN -C BOTH GDS AND BMS - PDS(8) = CHAR(192) - ELSE IF (mova2i(PDS(8)) .EQ. 0) THEN -C GDS ONLY - PDS(8) = CHAR(128) - END IF - CONTINUE - ELSE -C PRINT *,' W3NOGDS ERROR, IPFLAG IS NOT 0 OR 1 IPFLAG = ',IPFLAG - JERR = 1 - GO TO 900 - END IF -C -C GET LENGTH OF PDS -C - IPDSL = mova2i(PDS(1)) * 65536 + mova2i(PDS(2)) * 256 + - & mova2i(PDS(3)) -C -C$ 2.0 GRID DEFINITION SECTION (GDS). -C -C IF IGFLAG=1 THEN USER IS SUPPLYING THE IGDS INFORMATION -C IF IGFLAG=2 THEN USER doesn't want a GDS and this section -C will be skipped...LENGDS=0 -C - IF (IGFLAG .EQ. 0) THEN - CALL W3FI71(IGRID,IGDS,IGERR) - IF (IGERR .EQ. 1) THEN -C PRINT *,' W3FI71 ERROR, GRID TYPE NOT DEFINED...',IGRID - JERR = 4 - GO TO 900 - END IF - END IF - IF (IGFLAG .EQ. 0 .OR. IGFLAG .EQ.1) THEN - CALL W3FI74(IGDS,ICOMP,GDS,LENGDS,NPTS,IGERR) - IF (IGERR .EQ. 1) THEN -C PRINT *,' W3FI74 ERROR, GRID REP TYPE NOT VALID...',IGDS(3) - JERR = 5 - GO TO 900 - ELSE - END IF - IF (NPTS .GT. MXSIZE) THEN -C PRINT *,' W3NOGDS ERROR, GRID TOO LARGE FOR PACKER ARRAY', -C & ' DIMENSIONS' - JERR = 6 - GO TO 900 - END IF - else if (igflag .eq. 2) then - lengds = 0 - if (igrid.eq.21) then - npts=1333 - else if (igrid.eq.22) then - npts=1333 - else if (igrid.eq.23) then - npts=1333 - else if (igrid.eq.24) then - npts=1333 - else if (igrid.eq.25) then - npts=1297 - else if (igrid.eq.26) then - npts=1297 - else if ((igrid.ge.61).and.(igrid.le.64)) then - npts=4096 - end if - ELSE -C PRINT *,' W3NOGDS ERROR, IGFLAG IS NOT 0-2 IGFLAG = ',IGFLAG - GO TO 900 - END IF -C -C$ 3.0 BIT MAP SECTION (BMS). -C -C SET ITOSS=1 IF BITMAP BEING USED. W3FI75 WILL TOSS DATA -C PRIOR TO PACKING. LATER CODING WILL BE NEEDED WHEN THE -C 'PREDEFINED' GRIDS ARE FINALLY 'DEFINED'. -C - IF (mova2i(PDS(8)) .EQ. 64 .OR. - & mova2i(PDS(8)) .EQ. 192) THEN - ITOSS = 1 - IF (IBFLAG .EQ. 0) THEN - IF (IBLEN .NE. NPTS) THEN -C PRINT *,' W3NOGDS ERROR, IBLEN .NE. NPTS = ',IBLEN,NPTS - JERR = 7 - GO TO 900 - END IF - CALL W3FI73(IBFLAG,IBMAP,IBLEN,BMS,LENBMS,IER) - IF (IER .NE. 0) THEN -C PRINT *,' W3FI73 ERROR, IBMAP VALUES ARE ALL ZERO' - JERR = 8 - GO TO 900 - END IF - ELSE -C PRINT *,' BIT MAP PREDEFINED BY CENTER, IBFLAG = ',IBFLAG - END IF - END IF -C -C$ 4.0 BINARY DATA SECTION (BDS). -C -C$ 4.1 SCALE THE DATA WITH D-SCALE FROM PDS(27-28) -C - JSCALE = mova2i(PDS(27)) * 256 + mova2i(PDS(28)) - IF (IAND(JSCALE,32768).NE.0) THEN - JSCALE = - IAND(JSCALE,32767) - END IF - SCALE = 10.0 ** JSCALE - IF (ITYPE .EQ. 0) THEN - DO 410 I = 1,NPTS - FLD(I) = FLD(I) * SCALE - 410 CONTINUE - ELSE - DO 411 I = 1,NPTS - IFLD(I) = NINT(FLOAT(IFLD(I)) * SCALE) - 411 CONTINUE - END IF -C -C$ 4.2 CALL W3FI75 TO PACK DATA AND MAKE BDS. -C - CALL W3FI75(IBITL,ITYPE,ITOSS,FLD,IFLD,IBMAP,IBDSFL, - & NPTS,BDS11,IPFLD,PFLD,LEN,LENBDS,IBERR,PDS,IGDS) - IF (IBERR .EQ. 1) THEN - JERR = 3 - GO TO 900 - END IF -C 4.3 IF D-SCALE NOT 0, RESCALE INPUT FIELD TO -C ORIGINAL VALUE -C - IF (JSCALE.NE.0) THEN - DSCALE = 1.0 / SCALE - IF (ITYPE.EQ.0) THEN - DO 412 I = 1, NPTS - FLD(I) = FLD(I) * DSCALE - 412 CONTINUE - ELSE - DO 413 I = 1, NPTS - FLD(I) = NINT(FLOAT(IFLD(I)) * DSCALE) - 413 CONTINUE - END IF - END IF -C -C$ 5.0 OUTPUT SECTION. -C -C$ 5.1 ZERO OUT THE OUTPUT ARRAY KBUF. -C - ZERO = CHAR(00) - ITOT = IGRIBL + IPDSL + LENGDS + LENBMS + LENBDS + 4 -C PRINT *,'IGRIBL =',IGRIBL -C PRINT *,'IPDSL =',IPDSL -C PRINT *,'LENGDS =',LENGDS -C PRINT *,'LENBMS =',LENBMS -C PRINT *,'LENBDS =',LENBDS -C PRINT *,'ITOT =',ITOT -C -C KBUF MUST BE ON A WORD BOUNDRY, EQUIVALENCE TO AN -C INTEGER ARRAY IN THE MAIN PROGRAM TO MAKE SURE IT IS. -C THIS IS BOTH COMPUTER AND COMPILER DEPENDENT, W3FI01 -C IS USED TO FILL OUT IF THE COMPUTER IS A 64 BIT OR -C 32 BIT WORD SIZE COMPUTER. LW IS SET TO 4 FOR 32 BIT -C COMPUTER, 8 FOR 64 BIT COMPUTER. -C - CALL W3FI01(LW) - IWORDS = ITOT / LW - CALL XSTORE(KBUF,0,IWORDS) - IF (MOD(ITOT,LW).NE.0) THEN - IBYTES = ITOT - IWORDS * LW - DO 510 I = 1,IBYTES - KBUF(IWORDS * LW + I) = ZERO - 510 CONTINUE - END IF -C -C$ 5.2 MOVE SECTION 0 - 'IS' INTO KBUF (8 BYTES). -C - ISTART = 0 - DO 520 I = 1,4 - KBUF(I) = CHAR(IB(I)) - 520 CONTINUE -C - KBUF(5) = CHAR(MOD(ITOT / 65536,256)) - KBUF(6) = CHAR(MOD(ITOT / 256,256)) - KBUF(7) = CHAR(MOD(ITOT ,256)) - KBUF(8) = CHAR(1) -C -C$ 5.3 MOVE SECTION 1 - 'PDS' INTO KBUF (28 BYTES). -C - ISTART = ISTART + IGRIBL - IF (IPDSL.GT.0) THEN - CALL XMOVEX(KBUF(ISTART+1),PDS,IPDSL) - ELSE -C PRINT *,'LENGTH OF PDS LESS OR EQUAL 0, IPDSL = ',IPDSL - END IF -C -C$ 5.4 MOVE SECTION 2 - 'GDS' INTO KBUF. -C - ISTART = ISTART + IPDSL - IF (LENGDS .GT. 0) THEN - CALL XMOVEX(KBUF(ISTART+1),GDS,LENGDS) - END IF -C -C$ 5.5 MOVE SECTION 3 - 'BMS' INTO KBUF. -C - ISTART = ISTART + LENGDS - IF (LENBMS .GT. 0) THEN - CALL XMOVEX(KBUF(ISTART+1),BMS,LENBMS) - END IF -C -C$ 5.6 MOVE SECTION 4 - 'BDS' INTO KBUF. -C -C$ MOVE THE FIRST 11 OCTETS OF THE BDS INTO KBUF. -C - ISTART = ISTART + LENBMS - CALL XMOVEX(KBUF(ISTART+1),BDS11,11) -C -C$ MOVE THE PACKED DATA INTO THE KBUF -C - ISTART = ISTART + 11 - IF (LEN.GT.0) THEN - CALL XMOVEX(KBUF(ISTART+1),PFLD,LEN) - END IF -C -C$ ADD '7777' TO END OFF KBUF -C NOTE THAT THESE 4 OCTETS NOT INCLUDED IN ACTUAL SIZE OF BDS. -C - SEVEN = CHAR(55) - ISTART = ITOT - 4 - DO 562 I = 1,4 - KBUF(ISTART+I) = SEVEN - 562 CONTINUE -C - 900 CONTINUE - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3pradat.f b/src/fim/FIMsrc/w3/w3pradat.f deleted file mode 100644 index d89c1e1..0000000 --- a/src/fim/FIMsrc/w3/w3pradat.f +++ /dev/null @@ -1,78 +0,0 @@ -!----------------------------------------------------------------------- - subroutine w3pradat(idat,cdat) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: W3PRADAT FORMAT A DATE AND TIME INTO CHARACTERS -! AUTHOR: MARK IREDELL ORG: WP23 DATE: 98-01-05 -! -! ABSTRACT: THIS SUBPROGRAM FORMS VARIOUS CHARACTER STRINGS USEFUL -! IN DESCRIBING AN NCEP ABSOLUTE DATE AND TIME. -! -! PROGRAM HISTORY LOG: -! 98-01-05 MARK IREDELL -! -! USAGE: CALL W3PRADAT(IDAT,CDAT) -! -! INPUT VARIABLES: -! IDAT INTEGER (8) NCEP ABSOLUTE DATE AND TIME -! (YEAR, MONTH, DAY, TIME ZONE, -! HOUR, MINUTE, SECOND, MILLISECOND) -! -! OUTPUT VARIABLES: -! CDAT CHARACTER*10 (8) STRINGS DESCRIBING DATE AND TIME -! (CDAT(1) IS THE NAME OF THE DAY OF THE WEEK; -! CDAT(2) IS THE NAME OF THE MONTH; -! CDAT(3) IS THE DAY OF MONTH, YEAR; -! CDAT(4) IS THE DATE IN YYYY-MM-DD FORMAT; -! CDAT(5) IS THE DATE IN YYYY.DOY FORMAT; -! CDAT(6) IS THE TIME IN HH:MM:SS FORMAT; -! CDAT(7) IS THE MILLISECONDS IN .XXX FORMAT; -! CDAT(8) IS THE TIME ZONE.) -! -! SUBPROGRAMS CALLED: -! IW3JDN COMPUTE JULIAN DAY NUMBER -! W3FS26 YEAR, MONTH, DAY FROM JULIAN DAY NUMBER -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! -!$$$ - integer idat(8) - character*(*) cdat(8) - character*10 ctmp(8) - character*10 cmon(12) - data cmon/'January ','February ','March ', - & 'April ','May ','June ', - & 'July ','August ','September ', - & 'October ','November ','December '/ - character*10 cdow(7) - data cdow/'Sunday ','Monday ','Tuesday ', - & 'Wednesday ','Thursday ','Friday ', - & 'Saturday '/ -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! get day of week and day of year, convert day of week and month -! to english names, write other formats of date and time, and -! write time zone differential in one of three ways. - jldayn=iw3jdn(idat(1),idat(2),idat(3)) - call w3fs26(jldayn,jy,jm,jd,jdow,jdoy) - ctmp(1)=cdow(jdow) - ctmp(2)='********' - if(idat(2).ge.1.and.idat(2).le.12) ctmp(2)=cmon(idat(2)) - write(ctmp(3),'(i2,", ",i4)') idat(3),idat(1) - write(ctmp(4),'(i4,"-",i2.2,"-",i2.2)') idat(1),idat(2),idat(3) - write(ctmp(5),'(i4,".",i3.3)') idat(1),jdoy - write(ctmp(6),'(i2.2,":",i2.2,":",i2.2)') idat(5),idat(6),idat(7) - write(ctmp(7),'(".",i3.3)') idat(8) - if(idat(4).eq.0) then - write(ctmp(8),'("UTC")') - elseif(mod(idat(4),100).eq.0) then - kh=idat(4)/100 - write(ctmp(8),'("UTC",sp,i3.2,"h")') kh - else - kh=idat(4)/100 - km=abs(mod(idat(4),100)) - write(ctmp(8),'("UTC",sp,i3.2,"h",ss,i2.2,"m")') kh,km - endif - cdat=ctmp -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end diff --git a/src/fim/FIMsrc/w3/w3prrdat.f b/src/fim/FIMsrc/w3/w3prrdat.f deleted file mode 100644 index e45bec0..0000000 --- a/src/fim/FIMsrc/w3/w3prrdat.f +++ /dev/null @@ -1,61 +0,0 @@ -!----------------------------------------------------------------------- - subroutine w3prrdat(rinc,cinc) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: W3PRRDAT FORMAT A TIME INTERVAL INTO CHARACTERS -! AUTHOR: MARK IREDELL ORG: WP23 DATE: 98-01-05 -! -! ABSTRACT: THIS SUBPROGRAM FORMS VARIOUS CHARACTER STRINGS USEFUL -! IN DESCRIBING AN NCEP RELATIVE TIME INTERVAL. -! -! PROGRAM HISTORY LOG: -! 98-01-05 MARK IREDELL -! -! USAGE: CALL W3PRRDAT(RINC,CINC) -! -! INPUT VARIABLES: -! RINC REAL (5) NCEP RELATIVE TIME INTERVAL -! (DAYS, HOURS, MINUTES, SECONDS, MILLISECONDS) -! -! OUTPUT VARIABLES: -! CINC CHARACTER*10 (8) STRINGS DESCRIBING TIME INTERVAL -! (CINC(1) IS THE SIGNED INTEGER NUMBER OF DAYS; -! CINC(2) IS THE TIME IN HH:MM:SS FORMAT; -! CINC(3) IS THE MILLISECONDS IN .XXX FORMAT; -! CINC(4) IS THE SIGNED REAL NUMBER OF DAYS; -! CINC(5) IS THE SIGNED REAL NUMBER OF HOURS; -! CINC(6) IS THE SIGNED REAL NUMBER OF MINUTES; -! CINC(7) IS THE SIGNED REAL NUMBER OF SECONDS; -! CINC(8) IS THE SIGNED REAL NUMBER OF MILLISECONDS.) -! -! SUBPROGRAMS CALLED: -! W3REDDAT REDUCE A TIME INTERVAL TO A CANONICAL FORM -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! -!$$$ - real rinc(5) - real rinc2(5) - character*(*) cinc(8) - character*10 ctmp(8) - character*5 c -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! reduce date to second form but write sign only for days, -! and write in units of days, hours, minutes, second and milliseconds. - c='DHMSm' - call w3reddat(0,rinc,rinc2) - if(rinc2(1).ge.0) then - write(ctmp(1),'("+",i6)') nint(rinc2(1)) - else - write(ctmp(1),'("-",i6)') -nint(rinc2(1)) - endif - write(ctmp(2),'(i2.2,":",i2.2,":",i2.2)') abs(nint(rinc2(2:4))) - write(ctmp(3),'(".",i3.3)') abs(nint(rinc2(5))) - do it=1,5 - call w3reddat(it,rinc,rinc2) - write(ctmp(3+it),'(sp,g9.3,a1)') rinc2(it),c(it:it) - enddo - cinc=ctmp -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end diff --git a/src/fim/FIMsrc/w3/w3reddat.f b/src/fim/FIMsrc/w3/w3reddat.f deleted file mode 100644 index cbfd06f..0000000 --- a/src/fim/FIMsrc/w3/w3reddat.f +++ /dev/null @@ -1,144 +0,0 @@ - subroutine w3reddat(it,rinc,dinc) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: W3REDDAT REDUCE A TIME INTERVAL TO A CANONICAL FORM -! AUTHOR: MARK IREDELL ORG: WP23 DATE: 98-01-05 -! -! ABSTRACT: THIS SUBPROGRAM REDUCES AN NCEP RELATIVE TIME INTERVAL -! INTO ONE OF SEVEN CANONICAL FORMS, DEPENDING ON THE INPUT IT VALUE. -! -! First reduced format type (IT=-1): -! RINC(1) is an arbitrary integer. -! RINC(2) is an integer between 00 and 23, inclusive. -! RINC(3) is an integer between 00 and 59, inclusive. -! RINC(4) is an integer between 00 and 59, inclusive. -! RINC(5) is an integer between 000 and 999, inclusive. -! If RINC(1) is negative, then the time interval is negative. -! -! Second reduced format type (IT=0): -! If the time interval is not negative, then the format is: -! RINC(1) is zero or a positive integer. -! RINC(2) is an integer between 00 and 23, inclusive. -! RINC(3) is an integer between 00 and 59, inclusive. -! RINC(4) is an integer between 00 and 59, inclusive. -! RINC(5) is an integer between 000 and 999, inclusive. -! Otherwise if the time interval is negative, then the format is: -! RINC(1) is zero or a negative integer. -! RINC(2) is an integer between 00 and -23, inclusive. -! RINC(3) is an integer between 00 and -59, inclusive. -! RINC(4) is an integer between 00 and -59, inclusive. -! RINC(5) is an integer between 000 and -999, inclusive. -! -! Days format type (IT=1): -! RINC(1) is arbitrary. -! RINC(2) is zero. -! RINC(3) is zero. -! RINC(4) is zero. -! RINC(5) is zero. -! -! Hours format type (IT=2): -! RINC(1) is zero. -! RINC(2) is arbitrary. -! RINC(3) is zero. -! RINC(4) is zero. -! RINC(5) is zero. -! (This format should not express time intervals longer than 300 years.) -! -! Minutes format type (IT=3): -! RINC(1) is zero. -! RINC(2) is zero. -! RINC(3) is arbitrary. -! RINC(4) is zero. -! RINC(5) is zero. -! (This format should not express time intervals longer than five years.) -! -! Seconds format type (IT=4): -! RINC(1) is zero. -! RINC(2) is zero. -! RINC(3) is zero. -! RINC(4) is arbitrary. -! RINC(5) is zero. -! (This format should not express time intervals longer than one month.) -! -! Milliseconds format type (IT=5): -! RINC(1) is zero. -! RINC(2) is zero. -! RINC(3) is zero. -! RINC(4) is zero. -! RINC(5) is arbitrary. -! (This format should not express time intervals longer than one hour.) -! -! PROGRAM HISTORY LOG: -! 98-01-05 MARK IREDELL -! -! USAGE: CALL W3REDDAT(IT,RINC,DINC) -! -! INPUT VARIABLES: -! IT INTEGER RELATIVE TIME INTERVAL FORMAT TYPE -! (-1 FOR FIRST REDUCED TYPE (HOURS ALWAYS POSITIVE), -! 0 FOR SECOND REDUCED TYPE (HOURS CAN BE NEGATIVE), -! 1 FOR DAYS ONLY, 2 FOR HOURS ONLY, 3 FOR MINUTES ONLY, -! 4 FOR SECONDS ONLY, 5 FOR MILLISECONDS ONLY) -! RINC REAL (5) NCEP RELATIVE TIME INTERVAL -! (DAYS, HOURS, MINUTES, SECONDS, MILLISECONDS) -! -! OUTPUT VARIABLES: -! DINC REAL (5) NCEP RELATIVE TIME INTERVAL -! (DAYS, HOURS, MINUTES, SECONDS, MILLISECONDS) -! -! SUBPROGRAMS CALLED: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! -!$$$ - real rinc(5),dinc(5) -! parameters for number of units in a day -! and number of milliseconds in a unit -! and number of next smaller units in a unit, respectively - integer,dimension(5),parameter:: itd=(/1,24,1440,86400,86400000/), - & itm=(/86400000,3600000,60000,1000,1/) -! & itm=itd(5)/itd -! integer,dimension(4),parameter:: itn=itd(2:5)/itd(1:4) - integer,dimension(4),parameter:: itn=(/24,60,60,1000/) - integer,parameter:: np=16 - integer iinc(4),jinc(5),kinc(5) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! first reduce to the first reduced form - iinc=floor(rinc(1:4)) -! convert all positive fractional parts to milliseconds -! and determine canonical milliseconds - jinc(5)=nint(dot_product(rinc(1:4)-iinc,real(itm(1:4)))+rinc(5)) - kinc(5)=modulo(jinc(5),itn(4)) -! convert remainder to seconds and determine canonical seconds - jinc(4)=iinc(4)+(jinc(5)-kinc(5))/itn(4) - kinc(4)=modulo(jinc(4),itn(3)) -! convert remainder to minutes and determine canonical minutes - jinc(3)=iinc(3)+(jinc(4)-kinc(4))/itn(3) - kinc(3)=modulo(jinc(3),itn(2)) -! convert remainder to hours and determine canonical hours - jinc(2)=iinc(2)+(jinc(3)-kinc(3))/itn(2) - kinc(2)=modulo(jinc(2),itn(1)) -! convert remainder to days and compute milliseconds of the day - kinc(1)=iinc(1)+(jinc(2)-kinc(2))/itn(1) - ms=dot_product(kinc(2:5),itm(2:5)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! next reduce to either single value canonical form -! or to one of the two reduced forms - if(it.ge.1.and.it.le.5) then -! ensure that exact multiples of 1./np are expressed exactly -! (other fractions may have precision errors) - rp=(np*ms)/itm(it)+mod(np*ms,itm(it))/real(itm(it)) - dinc=0 - dinc(it)=real(kinc(1))*itd(it)+rp/np - else -! the reduced form is done except the second reduced form is modified -! for negative time intervals with fractional days - dinc=kinc - if(it.eq.0.and.kinc(1).lt.0.and.ms.gt.0) then - dinc(1)=dinc(1)+1 - dinc(2:5)=mod(ms-itm(1),itm(1:4))/itm(2:5) - endif - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end diff --git a/src/fim/FIMsrc/w3/w3tagb.f b/src/fim/FIMsrc/w3/w3tagb.f deleted file mode 100644 index a3d77f1..0000000 --- a/src/fim/FIMsrc/w3/w3tagb.f +++ /dev/null @@ -1,119 +0,0 @@ - SUBROUTINE W3TAGB(PROG,KYR,JD,LF,ORG) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3TAGB OPERATIONAL JOB IDENTIFIER -C PRGMMR: FARLEY ORG: NP11 DATE: 1998-03-17 -C -C ABSTRACT: PRINTS IDENTIFYING INFORMATION FOR OPERATIONAL -C codes. CALLED AT THE BEGINNING OF A code, W3TAGB PRINTS -C THE program NAME, THE YEAR AND JULIAN DAY OF ITS -C COMPILATION, AND THE RESPONSIBLE ORGANIZATION. ON A 2ND -C LINE IT PRINTS THE STARTING DATE-TIME. CALLED AT THE -C END OF A JOB, entry routine, W3TAGE PRINTS A LINE WITH THE -C ENDING DATE-TIME AND A 2ND LINE STATING THE program name -C AND THAT IT HAS ENDED. -C -C PROGRAM HISTORY LOG: -C 85-10-29 J.NEWELL -C 89-10-20 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C 91-03-01 R.E.JONES ADD MACHINE NAME TO ENDING LINE -C 92-12-02 R.E.JONES ADD START-ENDING TIME-DATE -C 93-11-16 R.E.JONES ADD DAY OF YEAR, DAY OF WEEK, AND JULIAN DAY -C NUMBER. -C 97-12-24 M.FARLEY PRINT STATEMENTS MODIFIED FOR 4-DIGIT YR -C 98-03-17 M.FARLEY REPLACED DATIMX WITH CALLS TO W3LOCDAT/W3DOXDAT -C 99-01-29 B. VUONG CONVERTED TO IBM RS/6000 SP -C -C 99-06-17 A. Spruill ADJUSTED THE SIZE OF PROGRAM NAME TO ACCOMMODATE -C THE 20 CHARACTER NAME CONVENTION ON THE IBM SP. -C 1999-08-24 Gilbert added call to START() in W3TAGB and a call -C to SUMMARY() in W3TAGE to print out a -C resource summary list for the program using -C W3TAGs. -C -C USAGE: CALL W3TAGB(PROG, KYR, JD, LF, ORG) -C CALL W3TAGE(PROG) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C PROG ARG LIST PROGRAM NAME CHARACTER*1 -C KYR ARG LIST YEAR OF COMPILATION INTEGER -C JD ARG LIST JULIAN DAY OF COMPILATION INTEGER -C LF ARG LIST HUNDRETHS OF JULIAN DAY OF COMPILATION -C INTEGER (RANGE IS 0 TO 99 INCLUSIVE) -C ORG ARG LIST ORGANIZATION CODE (SUCH AS WD42) -C CHARACTER*1 -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ---------------------------------------------------------------- -C DDATE PRINT YEAR AND JULIAN DAY (NEAREST HUNDRETH) -C FILE OF COMPILATION REAL -C -C SUBPROGRAMS CALLED: CLOCK, DATE -C -C REMARKS: FULL WORD USED IN ORDER TO HAVE AT LEAST -C SEVEN DECIMAL DIGITS ACCURACY FOR VALUE OF DDATE. -C SUBPROGRAM CLOCK AND DATE MAY DIFFER FOR EACH TYPE -C COMPUTER. YOU MAY HAVE TO CHANGE THEM FOR ANOTHER -C TYPE OF COMPUTER. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ -C - CHARACTER *(*) PROG,ORG - CHARACTER * 3 JMON(12) - CHARACTER * 3 DAYW(7) -C - INTEGER IDAT(8), JDOW, JDOY, JDAY -C - SAVE -C - DATA DAYW/'SUN','MON','TUE','WEN','THU','FRI','SAT'/ - DATA JMON /'JAN','FEB','MAR','APR','MAY','JUN', - & 'JUL','AUG','SEP','OCT','NOV','DEC'/ -C - CALL START() - - DYR = KYR - DYR = 1.0E+03 * DYR - DJD = JD - DLF = LF - DLF = 1.0E-02 * DLF - DDATE = DYR + DJD + DLF - PRINT 600 - 600 FORMAT(//,10('* . * . ')) - PRINT 601, PROG, DDATE, ORG - 601 FORMAT(5X,'PROGRAM ',A,' HAS BEGUN. COMPILED ',F10.2, - & 5X, 'ORG: ',A) -C - CALL W3LOCDAT(IDAT) - CALL W3DOXDAT(IDAT,JDOW,JDOY,JDAY) - PRINT 602, JMON(IDAT(2)),IDAT(3),IDAT(1),IDAT(5),IDAT(6), - & IDAT(7),IDAT(8),JDOY,DAYW(JDOW),JDAY - 602 FORMAT(5X,'STARTING DATE-TIME ',A3,1X,I2.2,',', - & I4.4,2X,2(I2.2,':'),I2.2,'.',I3.3,2X,I3,2X,A3,2X,I8,//) - RETURN -C - ENTRY W3TAGE(PROG) -C - CALL W3LOCDAT(IDAT) - CALL W3DOXDAT(IDAT,JDOW,JDOY,JDAY) - PRINT 603, JMON(IDAT(2)),IDAT(3),IDAT(1),IDAT(5),IDAT(6), - & IDAT(7),IDAT(8),JDOY,DAYW(JDOW),JDAY - 603 FORMAT(//,5X,'ENDING DATE-TIME ',A3,1X,I2.2,',', - & I4.4,2X,2(I2.2,':'),I2.2,'.',I3.3,2X,I3,2X,A3,2X,I8) - PRINT 604, PROG - 604 FORMAT(5X,'PROGRAM ',A,' HAS ENDED. IBM RS/6000 SP') -C 604 FORMAT(5X,'PROGRAM ',A,' HAS ENDED. CRAY J916/2048') -C 604 FORMAT(5X,'PROGRAM ',A,' HAS ENDED. CRAY Y-MP EL2/256') - PRINT 605 - 605 FORMAT(10('* . * . ')) - - CALL SUMMARY() -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3trnarg.f b/src/fim/FIMsrc/w3/w3trnarg.f deleted file mode 100644 index 7a97df5..0000000 --- a/src/fim/FIMsrc/w3/w3trnarg.f +++ /dev/null @@ -1,172 +0,0 @@ - SUBROUTINE W3TRNARG(SUBDIR,LSUBDR,TANKID,LTNKID,APPCHR,LAPCHR, - 1 TLFLAG,IYMDHB,IYMDHE,IERR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3TRNARG TRANSLATES ARG LINE FROM STANDARD INPUT -C PRGMMR: KEYSER ORG: NP22 DATE: 2002-02-11 -C -C ABSTRACT: READS ARGUMENT LINES FROM STANDARD INPUT AND OBTAINS , -C SUBDIRECTORY, BUFR TANKNAME, CHARACTERS TO APPEND FOR ADDING -C AN ORBIT, AND OPTIONS FOR LIMITING THE TIME WINDOW. -C -C PROGRAM HISTORY LOG: -C 1996-09-03 B. KATZ -- ORIGINAL AUTHOR -C 1998-11-27 B. KATZ -- CHANGES FOR Y2K AND FORTRAN 90 COMPLIANCE -C 2002-02-11 D. KEYSER -- IF "TLFLAG" IS NOT SPECIFIED, IT DEFAULTS -C TO "NOTIMLIM" RATHER THAN "TIMLIM" AND -C GROSS TIME LIMITS WILL NOT BE CALCULATED -C AND RETURNED IN "IYMDHB" AND "IYMDHE" -C -C USAGE: CALL W3TRNARG(SUBDIR,LSUBDR,TANKID,LTNKID,APPCHR,LAPCHR, -C TLFLAG,IYMDHB,IYMDHE,IERR) -C OUTPUT ARGUMENT LIST: -C SUBDIR - NAME OF SUB-DIRECTORY INCLUDING BUFR DATA TYPE WHERE -C BUFR DATA TANK IS LOCATED. -C LSUBDR - NUMBER OF CHARACTERS IN 'SUBDIR'. -C TANKID - NAME OF FILE INCLUDING BUFR DATA SUB-TYPE CONTAINING -C BUFR DATA TANK. -C LTNKID - NUMBER OF CHARACTERS IN 'TANKID'. -C APPCHR - CHARACTERS TO BE APPENDED TO 'TANKID' GIVING A -C UNIQUELY NAMED FILE TO CONTAIN THE ORIGINAL TANK -C WITH ONE ORBIT APPENDED TO IT. -C LAPCHR - NUMBER OF CHARACTERS IN 'APPCHR'. -C TLFLAG - 8 CHARACTER FLAG INDICATING WHETHER TIME ACCEPTANCE -C CHECKS ATRE TO BE PERFORMED. -C = 'TIMLIM ' : PERFORM TIME ACCEPTANCE CHECKS. -C = 'NOTIMLIM' : DO NOT PERFORM TIME ACCEPTANCE CHECKS. -C JDATE AND KDATE ARE DISREGARDED. -C IYMDHB - START OF TIME ACCEPTANCE WINDOW, IN FORM YYYYMMDDHH. -C IYMDHE - END OF TIME ACCEPTANCE WINDOW, IN FORM YYYYMMDDHH. -C -C INPUT FILES : -C UNIT 05 - STANDARD INPUT FOR PASSING IN ARGUMENTS. ARGUMENTS -C (FOR LIST-DIRECTED I/O) ARE AS FOLLOWS : -C RECORD 1 - (1) SUBDIRECTORY. CONTAINS BUFR DATA TYPE -C (2) TANKFILE. CONTAINS BUFR DATA SUB-TYPE -C (3) APPEND CHARACTERS. APPENDED TO TANKFILE -C TO GIVE UNIQUE OUTPUT FILE NAME. -C (4) DATE IN YYYYMMDDHH FORMAT. -C NEXT THREE RECORDS ARE OPTIONAL : -C RECORD 2 - (1) TIME LIMIT FLAG. MAY BE EITHER -C 'TIMLIM ' OR 'NOTIMLIM'. SEE -C DESCRIPTION OF 'TLFLAG' ABOVE. -C (DEFAULT IS 'NOTIMLIM') -C RECORD 3 - (1) HOURS BEFORE CURRENT TIME. -C RECORD 4 - (1) HOURS AFTER CURRENT TIME. -C IF 'TIMLIM ' IS SPECIFIED IN RECORD 2, THE -C QUANTITIES IN RECORDS 3 AND 4 ARE USED TO -C COMPUTE THE LIMITS OF THE TIME ACCEPTANCE WINDOW. -C IF RECORDS 3 AND 4 ARE OMITTED, THE VALUES -C DEFAULT TO -48 (48 HOURS BEFORE CURRENT TIME) -C AND +12 (12 HOURS AFTER CURRENT TIME). -C IF 'NOTIMLIM ' IS SPECIFIED IN RECORD 2, THEN -C THESE QUANTITIES ARE NOT USED REGARDLESS OF WHETHER -C OR NOT THEY WERE SPECIFIED. -C -C SUBPROGRAMS CALLED : -C W3LIB - W3MOVDAT -C -C REMARKS: -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - CHARACTER*(*) SUBDIR,TANKID,APPCHR,TLFLAG - INTEGER IDATIN(8),IDTOUT(8) - REAL TIMINC(5) - READ(5,*,END=9999) SUBDIR,TANKID,APPCHR,IYMDH - MSUBDR = LEN(SUBDIR) - DO LSUBDR=0,MSUBDR-1 - IF(SUBDIR(LSUBDR+1:LSUBDR+1).EQ.' ') GO TO 10 - ENDDO - LSUBDR = MSUBDR - 10 CONTINUE - IF(LSUBDR.LT.4) THEN - WRITE(6,'(1X,I2,'' CHARACTERS IN SUBDIRECTORY ARGUMENT'', - 1 '' AT LEAST 4 CHARACTERS ARE REQUIRED'')') LSUBDR - IERR = 2 - RETURN - ENDIF - MTNKID = LEN(TANKID) - DO LTNKID=0,MTNKID-1 - IF(TANKID(LTNKID+1:LTNKID+1).EQ.' ') GO TO 20 - ENDDO - LTNKID = MTNKID - 20 CONTINUE - IF(LTNKID.LT.4) THEN - WRITE(6,'(1X,I2,'' CHARACTERS IN TANKFILE ARGUMENT'', - 1 '' AT LEAST 4 CHARACTERS ARE REQUIRED'')') LTNKID - IERR = 2 - RETURN - ENDIF - MAPCHR = LEN(APPCHR) - DO LAPCHR=0,MAPCHR-1 - IF(APPCHR(LAPCHR+1:LAPCHR+1).EQ.' ') GO TO 30 - ENDDO - LAPCHR = MAPCHR - 30 CONTINUE - TLFLAG = 'NOTIMLIM' ! The default is to NOT perform time checks - READ(5,*,END=40) TLFLAG - 40 CONTINUE - IF(TLFLAG(1:6).NE.'TIMLIM') THEN - TLFLAG = 'NOTIMLIM' - PRINT 123, IYMDH,SUBDIR(1:LSUBDR),TANKID(1:LTNKID) - 123 FORMAT(/'RUN ON ',I10/'WRITE TO ',A,'/',A/'GROSS TIME LIMIT ', - 1 'CHECKS ARE NOT PERFORMED HERE - SUBSEQUENT PROGRAM ', - 1 'BUFR_TRANJB WILL TAKE CARE OF THIS'/) - IYMDHB = 0000000000 - IYMDHE = 2100000000 - IERR = 0 - RETURN - ENDIF - TLFLAG(7:8) = ' ' - READ(5,*,END=60) IHRBEF - GO TO 70 - 60 CONTINUE - IHRBEF = -48 - IHRAFT = 12 - GO TO 100 - 70 CONTINUE - READ(5,*,END=80) IHRAFT - GO TO 90 - 80 CONTINUE - IHRAFT = 12 - GO TO 100 - 90 CONTINUE - IF(IHRBEF.GT.0 .AND. IHRAFT.LT.0) THEN - ITEMP = IHRBEF - IHRBEF = IHRAFT - IHRAFT = ITEMP - ELSE IF(IHRBEF.GT.0) THEN - IHRBEF = -1 * IHRBEF - ENDIF - 100 CONTINUE - IDATIN(1) = IYMDH / 1000000 - IDATIN(2) = MOD(IYMDH,1000000) / 10000 - IDATIN(3) = MOD(IYMDH,10000) / 100 - IDATIN(4) = 0 - IDATIN(5) = MOD(IYMDH,100) - IDATIN(6:8) = 0 - TIMINC(1) = 0.0 - TIMINC(2) = FLOAT(IHRBEF) - TIMINC(3:5) = 0.0 - CALL W3MOVDAT(TIMINC,IDATIN,IDTOUT) - IYMDHB = ((IDTOUT(1) * 100 + IDTOUT(2)) * 100 + IDTOUT(3)) * - 1 100 + IDTOUT(5) - TIMINC(2) = FLOAT(IHRAFT) - CALL W3MOVDAT(TIMINC,IDATIN,IDTOUT) - IYMDHE = ((IDTOUT(1) * 100 + IDTOUT(2)) * 100 + IDTOUT(3)) * - 1 100 + IDTOUT(5) - PRINT 124, IYMDH,SUBDIR(1:LSUBDR),TANKID(1:LTNKID),IYMDHB,IYMDHE - 124 FORMAT(/'RUN ON ',I10/'WRITE TO ',A,'/',A/'ACCEPT BETWEEN ',I10, - 1 ' AND ',I10/) - IERR = 0 - RETURN - 9999 CONTINUE - WRITE(6,'('' INSUFFICIENT NO. OF ARGUMENTS TO BUFR '', - 1 ''TRANSLATION PROCEDURE - AT LEAST 4 ARE NEEDED'')') - IERR = 1 - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3unpk77.f b/src/fim/FIMsrc/w3/w3unpk77.f deleted file mode 100644 index e8e2669..0000000 --- a/src/fim/FIMsrc/w3/w3unpk77.f +++ /dev/null @@ -1,2580 +0,0 @@ -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3UNPK77 DECODES SINGLE REPORT FROM BUFR MESSAGES -C PRGMMR: KEYSER ORG: NP22 DATE: 2002-03-05 -C -C ABSTRACT: THIS SUBROUTINE DECODES A SINGLE REPORT FROM BUFR MESSAGES -C IN A JBUFR-TYPE DATA FILE. CURRENTLY WIND PROFILER, NEXRAD (VAD) -C WIND AND GOES SOUNDING/RADIANCE DATA TYPES ARE VALID. REPORT IS -C RETURNED IN QUASI-OFFICE NOTE 29 UNPACKED FORMAT (SEE REMARKS 4.). -C -C PROGRAM HISTORY LOG: -C 1996-12-16 KEYSER -- ORIGINAL AUTHOR (BASED ON W3LIB ROUTINE W3FI77) -C 1997-06-02 KEYSER -- ADDED NEXRAD (VAD) WIND DATA TYPE -C 1997-06-16 KEYSER -- ADDED GOES SOUNDING/RADIANCE DATA TYPE -C 1997-09-18 KEYSER -- ADDED INSTRUMENT DATA USED IN PROCESSING, -C SOLAR ZENITH ANGLE, AND SATELLITE ZENITH ANGLE -C TO LIST OF PARAMETERS RETURNED FROM GOES -C SOUNDING/RADIANCE DATA TYPE -C 1998-07-09 KEYSER -- MODIFIED WIND PROFILER CAT. 11 (HEIGHT, HORIZ. -C SIGNIFICANCE, VERT. SIGNIFICANCE) TO ACCOUNT -C FOR UPDATES TO BUFRTABLE MNEMONICS IN /dcom; -C CHANGED CHAR. 6 OF GOES STNID TO BE UNIQUE FOR -C TWO DIFFERENT EVEN OR ODD SATELLITE ID'S -C (EVERY OTHER EVEN OR ODD SAT. ID NOW GETS SAME -C CHAR. 6 TAG) -C 1998-08-19 KEYSER -- SUBROUTINE NOW Y2K AND FORTRAN 90 COMPLIANT -C 1999-03-16 KEYSER -- INCORPORATED BOB KISTLER'S CHANGES NEEDED -C TO PORT THE CODE TO THE IBM SP -C 1999-05-17 KEYSER -- MADE CHANGES NECESSARY TO PORT THIS ROUTINE TO -C THE IBM SP -C 1999-09-26 KEYSER -- CHANGES TO MAKE CODE MORE PORTABLE -C 2002-03-05 KEYSER -- ACCOUNTS FOR CHANGES IN INPUT PROFLR (WIND -C PROFILER) BUFR DUMP FILE AFTER 3/2002: CAT. 10 -C SURFACE DATA NOW ALL MISSING (MNEMONICS "PMSL", -C "WDIR1","WSPD1", "TMDB", "REHU", "REQV" NO -C LONGER AVAILABLE); CAT. 11 MNEMONICS "ACAVH", -C "ACAVV", "SPP0", AND "NPHL" NO LONGER -C AVAILABLE; HEADER MNEMONIC "NPSM" IS NO LONGER -C AVAILABLE, HEADER MNEMONIC "TPSE" REPLACES -C "TPMI" (AVG. TIME IN MINUTES STILL OUTPUT); -C NUMBER OF UPPER-AIR LEVELS INCR. FROM 43 TO UP -C TO 64 (SIZE OF OUTPUT "RDATA" ARRAY INCR. FROM -C 600 TO 1200 TO ACCOUNT FOR THIS) (WILL STILL -C WORK PROPERLY FOR INPUT PROFLR DUMP FILES PRIOR -C TO 3/2002) -C -C -C USAGE: CALL W3UNPK77(IDATE,IHE,IHL,LUNIT,RDATA,IRET) -C INPUT ARGUMENT LIST: -C IDATE - 4-WORD ARRAY HOLDING "CENTRAL" DATE TO PROCESS -C - (YYYY, MM, DD, HH) -C IHE - NUMBER OF WHOLE HOURS RELATIVE TO "IDATE" FOR DATE OF -C - EARLIEST BUFR MESSAGE THAT IS TO BE DECODED; EARLIEST -C - DATE IS "IDATE" + "IHE" HOURS (IF "IHE" IS POSITIVE, -C - LATEST MESSAGE DATE IS AFTER "IDATE"; IF "IHE" IS -C - NEGATIVE LATEST MESSAGE DATE IS PRIOR TO "IDATE") -C - EXAMPLE: IF IHE=1, THEN EARLIEST DATE IS 1-HR AFTER -C - IDATE; IF IHE=-3, THEN EARLIEST DATE IS 3-HR PRIOR -C - TO IDATE -C IHL - NUMBER OF WHOLE HOURS RELATIVE TO "IDATE" FOR DATE OF -C - LATEST BUFR MESSAGE THAT IS TO BE DECODED; LATEST -C - DATE IS "IDATE" + ("IHL" HOURS PLUS 59 MIN) IF "IHL" -C - IS POSITIVE (LATEST MESSAGE DATE IS AFTER "IDATE"), -C - AND "IDATE" + ("IHL"+1 HOURS MINUS 1 MIN) IF "IHL" -C - IS NEGATIVE (LATEST MESSAGE DATE IS PRIOR TO "IDATE") -C - EXAMPLE: IF IHL=3, THEN LATEST DATE IS 3-HR 59-MIN -C - AFTER IDATE; IF IHL=-2, THEN LATEST DATE IS 1-HR 1-MIN -C - PRIOR TO IDATE -C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE -C IRET - CONTROLS DEGREE OF UNIT 6 PRINTOUT (.GE. 0 -LIMITED -C - PRINTOUT; = -1 SOME ADDITIONAL DIAGNOSTIC PRINTOUT; -C = .LT. -1 -EXTENSIVE PRINTOUT) (SEE REMARKS 3.) -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C RDATA - SINGLE REPORT RETURNED AN A QUASI-OFFICE NOTE 29 -C - UNPACKED FORMAT (SEE REMARKS 4.) (MINIMUM SIZE IS -C - 1200 WORDS) -C IRET - RETURN CODE AS FOLLOWS: -C IRET = 0 ---> REPORT SUCCESSFULLY RETURNED -C IRET > 0 ---> NO REPORT RETURNED DUE TO: -C = 1 ---> ALL REPORTS READ IN, END -C = 2 ---> LAT AND/OR LON DATA MISSING -C = 3 ---> RESERVED -C = 4 ---> SOME/ALL DATE INFORMATION MISSING -C = 5 ---> NO DATA LEVELS PROCESSED (ALL LEVELS ARE MISSING) -C = 6 ---> NUMBER OF LEVELS IN REPORT HEADER IS NOT 1 -C = 7 ---> NUMBER OF LEVELS IN ANOTHER SINGLE LEVEL SEQUENCE -C IS NOT 1 -C -C INPUT FILES: -C UNIT AA - (WHERE AA IS LUNIT ABOVE) FILE HOLDING THE DATA -C - IN THE FORM OF BUFR MESSAGES -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C SUBPROGRAMS CALLED: -C UNIQUE - UNPK7701 UNPK7702 UNPK7703 UNPK7704 UNPK7705 -C - UNPK7706 UNPK7707 UNPK7708 UNPK7709 -C LIBRARY: -C W3LIB - W3FI04 W3MOVDAT W3DIFDAT ERREXIT -C BUFRLIB - DATELEN DUMPBF OPENBF READMG UFBCNT -C - READSB UFBINT CLOSBF -C -C REMARKS: 1) A CONDITION CODE (STOP) OF 15 WILL OCCUR IF THE INPUT -C DATES FOR START AND/OR STOP TIME ARE SPECIFIED INCORRECTLY. -C 2) A CONDITION CODE (STOP) OF 22 WILL OCCUR IF THE -C CHARACTERS ON THIS MACHINE ARE NEITHER ASCII NOR EBCDIC. -C 3) THE INPUT ARGUMENT "IRET" SHOULD BE SET PRIOR TO EACH -C CALL TO THIS SUBROUTINE. -C -C *************************************************************** -C 4) -C BELOW IS THE FORMAT OF AN UNPACKED REPORT IN OUTPUT ARRAY RDATA -C (EACH WORD REPRESENTS A FULL-WORD ACCORDING TO THE MACHINE) -C N O T E : THIS IS THE SAME FORMAT AS FOR W3LIB ROUTINE W3FI77 -C EXCEPT WHERE NOTED -C *************************************************************** -C -CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -C FORMAT FOR WIND PROFILER REPORTS -CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -C HEADER -C WORD CONTENT UNIT FORMAT -C ---- ---------------------- ------------------- --------- -C 1 LATITUDE 0.01 DEGREES REAL -C 2 LONGITUDE 0.01 DEGREES WEST REAL -C 3 TIME SIGNIFICANCE (BUFR CODE TABLE "0 08 021") INTEGER -C 4 OBSERVATION TIME 0.01 HOURS (UTC) REAL -cvvvvvdak port -C 5 YEAR/MONTH 4-CHAR. 'YYMM' CHARACTER -caaaaadak port -C LEFT-JUSTIFIED -C 6 DAY/HOUR 4-CHARACTERS 'DDHH' CHARACTER -C 7 STATION ELEVATION METERS REAL -C 8 SUBMODE/EDITION NO. (SM X 10) + ED. NO. INTEGER -C (ED. NO.=2, CONSTANT; SEE &,~) -C 9 REPORT TYPE 71 (CONSTANT) INTEGER -C 10 AVERAGING TIME MINUTES INTEGER -C (NEGATIVE MEANS PRIOR TO OBS. TIME) -C 11 STN. ID. (FIRST 4 CHAR.) 4-CHARACTERS CHARACTER -C LEFT-JUSTIFIED -C 12 STN. ID. (LAST 2 CHAR.) 2-CHARACTERS CHARACTER -C LEFT-JUSTIFIED -C -C 13-34 ZEROED OUT - NOT USED INTEGER -C 35 CATEGORY 10, NO. LEVELS COUNT INTEGER -C 36 CATEGORY 10, DATA INDEX COUNT INTEGER -C 37 CATEGORY 11, NO. LEVELS COUNT INTEGER -C 38 CATEGORY 11, DATA INDEX COUNT INTEGER -C 39-42 ZEROED OUT - NOT USED INTEGER -C -C 43-END UNPACKED DATA GROUPS (FOLLOWS) REAL -C -C CATEGORY 10 - WIND PROFILER SFC DATA (EACH LEVEL, SEE WORD 35 ABOVE) -C WORD PARAMETER UNITS FORMAT -C ---- --------- ----------------- ------------- -C(SEE @)1 SEA-LEVEL PRESSURE 0.1 MILLIBARS REAL -C(SEE *)2 STATION PRESSURE 0.1 MILLIBARS REAL -C(SEE @)3 HORIZ. WIND DIR. DEGREES REAL -C(SEE @)4 HORIZ. WIND SPEED 0.1 M/S REAL -C(SEE @)5 AIR TEMPERATURE 0.1 DEGREES K REAL -C(SEE @)6 RELATIVE HUMIDITY PERCENT REAL -C(SEE @)7 RAINFALL RATE 0.0000001 M/S REAL -C -C CATEGORY 11 - WIND PROFILER UPPER-AIR DATA (FIRST LEVEL IS SURFACE) -C (EACH LEVEL, SEE WORD 37 ABOVE) -C WORD PARAMETER UNITS FORMAT -C ---- --------- ----------------- ------------- -C 1 HEIGHT ABOVE SEA-LVL METERS REAL -C 2 HORIZ. WIND DIR. DEGREES REAL -C 3 HORIZ. WIND SPEED 0.1 M/S REAL -C 4 QUALITY CODE (SEE %) INTEGER -C 5 VERT. WIND COMP. (W) 0.01 M/S REAL -C(SEE @)6 HORIZ. CONSENSUS NO. (SEE $) INTEGER -C(SEE @)7 VERT. CONSENSUS NO. (SEE $) INTEGER -C(SEE @)8 SPECTRAL PEAK POWER DB REAL -C 9 HORIZ. WIND SPEED 0.1 M/S REAL -C STANDARD DEVIATION 0.1 M/S REAL -C 10 VERT. WIND COMPONENT 0.1 M/S REAL -C STANDARD DEVIATION 0.1 M/S REAL -C(SEE @)11 MODE (SEE #) INTEGER -C -C *- ALWAYS MISSING -C &- THIS IS A CHANGE FROM FORMAT IN W3LIB ROUTINE W3FI77 -C %- 0 - MEDIAN AND SHEAR CHECKS BOTH PASSED -C 2 - MEDIAN AND SHEAR CHECK RESULTS INCONCLUSIVE -C 4 - MEDIAN CHECK PASSED; SHEAR CHECK FAILED -C 8 - MEDIAN CHECK FAILED; SHEAR CHECK PASSED -C 12 - MEDIAN AND SHEAR CHECKS BOTH FAILED -C $- NO. OF INDIVIDUAL 6-MINUTE AVERAGE MEASUREMENTS THAT WERE -C INCLUDED IN FINAL ESTIMATE OF AVERAGED WIND (RANGE: 0, 2-10) -C (BASED ON A ONE-HOUR AVERAGE) -C #- 1 - DATA FROM LOW MODE -C 2 - DATA FROM HIGH MODE -C 3 - MISSING -C @- THIS PARAMETER IS NO LONGER AVAILABLE AFTER 3/2002 AND IS SET -C TO MISSING (99999 FOR INTEGER OR 99999. FOR REAL) -C ~- SUBMODE IS NO LONGER AVAILABLE AFTER 3/2002 AND IS SET TO 3 -C (ITS MISSING VALUE) -C -CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -C FORMAT FOR GOES SOUNDING/RADIANCE REPORTS -CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -C HEADER -C WORD CONTENT UNIT FORMAT -C ---- ---------------------- ------------------- --------- -C 1 LATITUDE 0.01 DEGREES REAL -C 2 LONGITUDE 0.01 DEGREES WEST REAL -C 3 FIELD OF VIEW NUMBER NUMERIC INTEGER -C 4 OBSERVATION TIME 0.01 HOURS (UTC) REAL -cvvvvvdak port -C 5 YEAR/MONTH 4-CHAR. 'YYMM' CHARACTER -caaaaadak port -C LEFT-JUSTIFIED -C 6 DAY/HOUR 4-CHARACTERS 'DDHH' CHARACTER -C 7 STATION ELEVATION METERS REAL -C 8 PROCESS. TECHNIQUE (=21-CLEAR; INTEGER -C 8 PROCESS. TECHNIQUE =23-CLOUD-CORRECTED) -C 9 REPORT TYPE 61 (CONSTANT) INTEGER -C 10 QUALITY FLAG (BUFR CODE TABLE "0 33 002") INTEGER -C 11 STN. ID. (FIRST 4 CHAR.) 4-CHARACTERS CHARACTER -C LEFT-JUSTIFIED -C 12 STN. ID. (LAST 2 CHAR.) 2-CHARACTERS CHARACTER -C LEFT-JUSTIFIED (SEE %) -C -C 13-26 ZEROED OUT - NOT USED -C 27 CATEGORY 08, NO. LEVELS COUNT INTEGER -C 28 CATEGORY 08, DATA INDEX COUNT INTEGER -C 29-38 ZEROED OUT - NOT USED -C 39 CATEGORY 12, NO. LEVELS COUNT INTEGER -C 40 CATEGORY 12, DATA INDEX COUNT INTEGER -C 41 CATEGORY 13, NO. LEVELS COUNT INTEGER -C 42 CATEGORY 13, DATA INDEX COUNT INTEGER -C -C 43-END UNPACKED DATA GROUPS (FOLLOWS) REAL -C -C CATEGORY 12 - SATELLITE SOUNDING LEVEL DATA (FIRST LEVEL IS SURFACE; -C EACH LEVEL, SEE 39 ABOVE) -C WORD PARAMETER UNITS FORMAT -C ---- --------- ----------------- ------------- -C 1 PRESSURE 0.1 MILLIBARS REAL -C 2 GEOPOTENTIAL METERS REAL -C 3 TEMPERATURE 0.1 DEGREES C REAL -C 4 DEWPOINT TEMPERATURE 0.1 DEGREES C REAL -C 5 NOT USED SET TO MISSING REAL -C 6 NOT USED SET TO MISSING REAL -C 7 QUALITY MARKERS 4-CHARACTERS CHARACTER -C LEFT-JUSTIFIED (SEE &) -C -C CATEGORY 13 - SATELLITE RADIANCE "LEVEL" DATA (EACH "LEVEL", SEE -C 41 ABOVE) -C WORD PARAMETER UNITS FORMAT -C ---- --------- ----------------- ------------- -C 1 CHANNEL NUMBER NUMERIC INTEGER -C 2 BRIGHTNESS TEMP. 0.01 DEG. KELVIN REAL -C 3 QUALITY MARKERS 4-CHARACTERS CHARACTER -C LEFT-JUSTIFIED (SEE &&) -C -C CATEGORY 08 - ADDITIONAL (MISCELLANEOUS) DATA (EACH LEVEL, SEE @ -C BELOW) -C WORD PARAMETER UNITS FORMAT -C ---- --------- ----------------- ------------- -C 1 VARIABLE SEE @ BELOW REAL -C 2 CODE FIGURE SEE @ BELOW REAL -C 3 MARKERS 2-CHARACTERS CHARACTER -C LEFT-JUSTIFIED (SEE #) -C -C %- SIXTH CHARACTER OF STATION ID IS A TAGGED AS FOLLOWS: -C "I" - GOES-EVEN-1 (252, 256, ...) SAT. , CLEAR COLUMN RETR. -C "J" - GOES-EVEN-1 (252, 256, ...) SAT. , CLD-CORRECTED RETR. - -C "L" - GOES-ODD-1 (253, 257, ...) SAT. , CLEAR COLUMN RETR. -C "M" - GOES-ODD-1 (253, 257, ...) SAT. , CLD-CORRECTED RETR. - -C "O" - GOES-EVEN-2 (254, 258, ...) SAT. , CLEAR COLUMN RETR. -C "P" - GOES-EVEN-2 (254, 258, ...) SAT. , CLD-CORRECTED RETR. - -C "Q" - GOES-ODD-2 (251, 255, ...) SAT. , CLEAR COLUMN RETR. -C "R" - GOES-ODD-2 (251, 255, ...) SAT. , CLD-CORRECTED RETR. - -C "?" - EITHER SATELLITE AND/OR RETRIEVAL TYPE UNKNOWN - -C &- FIRST CHARACTER IS Q.M. FOR GEOPOTENTIAL -C SECOND CHARACTER IS Q.M. FOR TEMPERATURE -C THIRD CHARACTER IS Q.M. FOR DEWPOINT TEMPERATURE -C FOURTH CHARACTER IS NOT USED -C " " - INDICATES DATA NOT SUSPECT -C "Q" - INDICATES DATA ARE SUSPECT -C "F" - INDICATES DATA ARE BAD -C &&- FIRST CHARACTER IS Q.M. FOR BRIGHTNESS TEMPERATURE -C SECOND-FOURTH CHARACTERS ARE NOT USED -C " " - INDICATES DATA NOT SUSPECT -C "Q" - INDICATES DATA ARE SUSPECT -C "F" - INDICATES DATA ARE BAD -C @- NUMBER OF "LEVELS" FROM WORD 27. MAXIMUM IS 12, AND ARE ORDERED -C AS FOLLOWS (IF A DATUM ARE MISSING THAT LEVEL NOT STORED) -C 1 - LIFTED INDEX ---------- .01 DEG. KELVIN -- C. FIG. 250. -C 2 - TOTAL PRECIP. WATER -- .01 MILLIMETERS -- C. FIG. 251. -C 3 - 1. TO .9 SIGMA P.WATER- .01 MILLIMETERS -- C. FIG. 252. -C 4 - .9 TO .7 SIGMA P.WATER- .01 MILLIMETERS -- C. FIG. 253. -C 5 - .7 TO .3 SIGMA P.WATER- .01 MILLIMETERS -- C. FIG. 254. -C 6 - SKIN TEMPERATURE ----- .01 DEG. KELVIN -- C. FIG. 255. -C 7 - CLOUD TOP TEMPERATURE- .01 DEG. KELVIN -- C. FIG. 256. -C 8 - CLOUD TOP PRESSURE --- .1 MILLIBARS ----- C. FIG. 257. -C 9 - CLOUD AMOUNT (BUFR TBL. C.T. 0-20-011) -- C. FIG. 258. -C 10 - INSTR. DATA USED IN PROC. -C (BUFR TBL. C.T. 0-02-021) -- C. FIG. 259. -C 11 - SOLAR ZENITH ANGLE --- .01 DEGREE ------- C. FIG. 260. -C 12 - SAT. ZENITH ANGLE ---- .01 DEGREE ------- C. FIG. 261. -C #- FIRST CHARACTER IS Q.M. FOR THE DATUM -C " " - INDICATES DATA NOT SUSPECT -C "Q" - INDICATES DATA ARE SUSPECT -C "F" - INDICATES DATA ARE BAD -C SECOND CHARACTER IS NOT USED -C -CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -C FORMAT FOR NEXRAD (VAD) WIND REPORTS -CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -C HEADER -C WORD CONTENT UNIT FORMAT -C ---- ---------------------- ------------------- --------- -C 1 LATITUDE 0.01 DEGREES REAL -C 2 LONGITUDE 0.01 DEGREES WEST REAL -C 3 ** RESERVED ** SET TO 99999 INTEGER -C 4 OBSERVATION TIME 0.01 HOURS (UTC) REAL -cvvvvvdak port -C 5 YEAR/MONTH 4-CHAR. 'YYMM' CHARACTER -caaaaadak port -C LEFT-JUSTIFIED -C 6 DAY/HOUR 4-CHARACTERS 'DDHH' CHARACTER -C 7 STATION ELEVATION METERS REAL -C 8 ** RESERVED ** SET TO 99999 INTEGER -C -C 9 REPORT TYPE 72 (CONSTANT) INTEGER -C 10 ** RESERVED ** SET TO 99999 INTEGER -C 11 STN. ID. (FIRST 4 CHAR.) 4-CHARACTERS CHARACTER -C LEFT-JUSTIFIED -C 12 STN. ID. (LAST 2 CHAR.) 2-CHARACTERS CHARACTER -C LEFT-JUSTIFIED -C -C 13-18 ZEROED OUT - NOT USED INTEGER -C 19 CATEGORY 04, NO. LEVELS COUNT INTEGER -C 20 CATEGORY 04, DATA INDEX COUNT INTEGER -C 21-42 ZEROED OUT - NOT USED INTEGER -C -C 43-END UNPACKED DATA GROUPS (FOLLOWS) REAL -C -C CATEGORY 04 - UPPER-AIR WINDS-BY-HEIGHT DATA(FIRST LEVEL IS SURFACE) -C (EACH LEVEL, SEE WORD 19 ABOVE) -C WORD PARAMETER UNITS FORMAT -C ---- --------- ----------------- ------------- -C 1 HEIGHT ABOVE SEA-LVL METERS REAL -C 2 HORIZ. WIND DIR. DEGREES REAL -C 3 HORIZ. WIND SPEED 0.1 M/S (SEE *) REAL -C 4 QUALITY MARKERS 4-CHARACTERS CHARACTER -C LEFT-JUSTIFIED (SEE %) -C -C *- UNITS HERE DIFFER FROM THOSE IN TRUE UNPACKED OFFICE NOTE 29 -C (WHERE UNITS ARE KNOTS) -C %- THE FIRST THREE CHARACTERS ARE ALWAYS BLANK, THE FOURTH -C CHARACTER IS A "CONFIDENCE LEVEL" WHICH IS RELATED TO THE ROOT- -C MEAN-SQUARE VECTOR ERROR FOR THE HORIZONTAL WIND. IT IS -C DEFINED AS FOLLOWS: -C 'A' = RMS OF 1.9 KNOTS -C 'B' = RMS OF 3.9 KNOTS -C 'C' = RMS OF 5.8 KNOTS -C 'D' = RMS OF 7.8 KNOTS -C 'E' = RMS OF 9.7 KNOTS -C 'F' = RMS OF 11.7 KNOTS -C 'G' = RMS > 13.6 KNOTS -CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -C -C FOR ALL REPORT TYPES, MISSING VALUES ARE: -C 99999. FOR REAL -C 99999 FOR INTEGER -C 9'S FOR CHARACTERS IN WORD 5, 6 OF HEADER -C BLANK FOR CHARACTERS IN WORD 11, 12 OF HEADER -C AND FOR CHARACTERS IN ANY CATEGORY LEVEL -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP, CRAY, SGI -C -C$$$ - SUBROUTINE W3UNPK77(IDATE,IHE,IHL,LUNIT,RDATA,IRET) - CHARACTER*4 CBUFR - INTEGER IDATE(4),LSDATE(4),jdate(8),IDATA(1200) - dimension rinc(5) - REAL RDATA(*),RDATX(1200) - COMMON /PK77BB/kdate(8),ldate(8),IPRINT - COMMON /PK77CC/INDEX - COMMON /PK77DD/LSHE,LSHL,ICDATE(5),IDDATE(5) - COMMON /PK77FF/IFOV(3),KNTSAT(250:260) - - SAVE - - EQUIVALENCE (RDATX,IDATA) - DATA ITM/0/,LUNITL/-99/,KOUNT/0/ - IPRINT = 0 - IF(IRET.LT.0) IPRINT = IABS(IRET) - IRET = 0 - IF(ITM.EQ.0) THEN -C----------------------------------------------------------------------- - -C FIRST AND ONLY TIME INTO THIS SUBROUTINE DO A FEW THINGS.... - - ITM = 1 - IFOV = 0 - KNTSAT = 0 -C DETERMINE MACHINE WORD LENGTH IN BYTES (=8 FOR CRAY) AND TYPE OF -C CHARACTER SET {ASCII(ICHTP=0) OR EBCDIC(ICHTP=1)} - CALL W3FI04(IENDN,ICHTP,LW) - PRINT 2213, LW, ICHTP, IENDN - 2213 FORMAT(/' ---> W3UNPK77: CALL TO W3FI04 RETURNS: LW = ',I3, - $ ', ICHTP = ',I3,', IENDN = ',I3/) - IF(ICHTP.GT.1) THEN -C CHARACTERS ON THIS MACHINE ARE NEITHER ASCII OR EBCDIC!! -- STOP 22 - PRINT 217 - 217 FORMAT(' *** W3UNPK77 ERROR: CHARACTERS ON THIS MACHINE ', - $ 'ARE NEITHER ASCII NOR EBCDIC - STOP 22'/) - CALL ERREXIT(22) - END IF -C----------------------------------------------------------------------- - END IF - IF(LUNIT.NE.LUNITL) THEN -C----------------------------------------------------------------------- - -C IF THE INPUT DATA UNIT NUMBER ARGUMENT IS DIFFERENT THAT THE LAST TIME -C THIS SUBR. WAS CALLED, PRINT NEW HEADER, SET JRET = 1 - - LUNITL = LUNIT - JRET = 1 - PRINT 101, LUNIT - 101 FORMAT(//' ---> W3UNPK77: VERSION 03/05/2002: JBUFR DATA SET ', - $ 'READ FROM UNIT ',I4/) -C----------------------------------------------------------------------- - ELSE - -C FOR SUBSEQUENT TIMES INTO THIS SUBR. W/ SAME LUNIT AS LAST TIME, -C TEST INPUT DATE & HR RANGE ARGUMENTS AGAINST THEIR VALUES THE LAST -C TIME SUBR. CALLED -- IF THEY ARE DIFFERENT, SET JRET = 1 (ELSE -C JRET = 0), WILL TEST JRET SOON - - JRET = 1 - DO I = 4,1,-1 - IF(IDATE(I).NE.LSDATE(I)) GO TO 88 - ENDDO - IF(IHE.NE.LSHE.OR.IHL.NE.LSHL) GO TO 88 - JRET = 0 - 88 CONTINUE -C----------------------------------------------------------------------- - END IF - IF(JRET.EQ.1) THEN - PRINT 6680 - 6680 FORMAT(/' JRET = 1 - REWIND DATA FILE & SET-UP TO DO DATE CHECK'/) -C----------------------------------------------------------------------- - -C COME HERE IF FIRST CALL TO SUBROUTINE OR IF INPUT DATA UNIT NUMBER OR -C IF INPUT DATE/TIME OR RANGE IN TIME HAS BEEN CHANGED FROM LAST CALL - -C CLOSE BUFR DATA SET (IN CASE OPEN FROM PREVIOUS RUN) -C REWIND INPUT BUFR DATA SET, GET CENTER TIME AND DUMP TIME, -C OPEN BUFR DATA SET - -C SET-UP TO DETERMINE IF BUFR MESSAGE IS WITHIN REQUESTED DATES - -C (ALSO SET INDEX=0, FORCES BUFR MSG TO BE READ BEFORE RPTS ARE DECODED) - -C----------------------------------------------------------------------- - - CALL CLOSBF(LUNIT) - - REWIND LUNIT - - READ(LUNIT,END=9999,ERR=9999) CBUFR - IF(CBUFR.NE.'BUFR') GO TO 9999 - - call datelen(10) - - CALL DUMPBF(LUNIT,ICDATE,IDDATE) -cppppp - print *,'CENTER DATE (ICDATE) = ',icdate - print *,'DUMP DATE (IDDATE) = ',iddate -cppppp - - if(icdate(1).le.0) then -C COME HERE IF CENTER DATE COULD NOT BE READ FROM FIRST DUMMY MESSAGE -C - RETURN WITH IRET = 1 - print *, ' *** W3UNPK77 ERROR: CENTER DATE COULD NOT BE ', - $ 'OBTAINED FROM INPUT FILE ON UNIT ',lunit - go to 9998 - end if - if(iddate(1).le.0) then -C COME HERE IF DUMP DATE COULD NOT BE READ FROM SECOND DUMMY MESSAGE -C - RETURN WITH IRET = 1 - print *, ' *** W3UNPK77 ERROR: DUMP DATE COULD NOT BE ', - $ 'OBTAINED FROM INPUT FILE ON UNIT ',lunit - go to 9998 - end if - IF(ICDATE(1).LT.100) THEN - -C If 2-digit year returned in ICDATE(1), must use "windowing" technique -C to create a 4-digit year - -C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS -C CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT -C Y2K COMPLIANT (BUFRLIB DOES THE WINDOWING HERE) - - PRINT *, '##W3UNPK77 - THE FOLLOWING SHOULD NEVER ', - $ 'HAPPEN!!!!!' - PRINT *, '##W3UNPK77 - 2-DIGIT YEAR IN ICDATE(1) ', - $ 'RETURNED FROM DUMPBF (ICDATE IS: ',ICDATE,') - USE ', - $ 'WINDOWING TECHNIQUE TO OBTAIN 4-DIGIT YEAR' - IF(ICDATE(1).GT.20) THEN - ICDATE(1) = 1900 + ICDATE(1) - ELSE - ICDATE(1) = 2000 + ICDATE(1) - ENDIF - PRINT *, '##WW3UNPK77 - CORRECTED ICDATE(1) WITH 4-DIGIT ', - $ 'YEAR, ICDATE NOW IS: ',ICDATE - ENDIF - - IF(IDDATE(1).LT.100) THEN - -C If 2-digit year returned in IDDATE(1), must use "windowing" technique -C to create a 4-digit year - -C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS -C CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT -C Y2K COMPLIANT (BUFRLIB DOES THE WINDOWING HERE) - - PRINT *, '##W3UNPK77 - THE FOLLOWING SHOULD NEVER ', - $ 'HAPPEN!!!!!' - PRINT *, '##W3UNPK77 - 2-DIGIT YEAR IN IDDATE(1) ', - $ 'RETURNED FROM DUMPBF (IDDATE IS: ',IDDATE,') - USE ', - $ 'WINDOWING TECHNIQUE TO OBTAIN 4-DIGIT YEAR' - IF(IDDATE(1).GT.20) THEN - IDDATE(1) = 1900 + IDDATE(1) - ELSE - IDDATE(1) = 2000 + IDDATE(1) - ENDIF - PRINT *, '##W3UNPK77 - CORRECTED IDDATE(1) WITH 4-DIGIT ', - $ 'YEAR, IDDATE NOW IS: ',IDDATE - END IF - -C OPEN BUFR FILE - READ IN DICTIONARY MESSAGES (TABLE A, B, D ENTRIES) - - CALL OPENBF(LUNIT,'IN',LUNIT) - PRINT 100, LUNIT - 100 FORMAT(/5X,'===> BUFR DATA SET IN UNIT',I3,' SUCCESSFULLY ', - $ 'OPENED FOR INPUT; DCTNY MESSAGES CONTAIN BUFR TABLES A,B,D'/) - INDEX = 0 - KOUNT = 0 - jdate(1:3) = idate(1:3) - jdate(4) = 0 - jdate(5) = idate(4) - jdate(6:8) = 0 - PRINT 6681, IDATE - 6681 FORMAT(/' %%% REQUESTED "CENTRAL" DATE IS :',I5,3I3,' 0'/) -C DETERMINE EARLIEST DATE FOR ACCEPTING BUFR MESSAGES FOR DECODING - call w3movdat((/0.,real(ihe),0.,0.,0./),jdate,kdate) - print 6682, (kdate(i),i=1,3),kdate(5),kdate(6) - 6682 FORMAT(/' --> EARLIEST DATE FOR ACCEPTING BUFR MSGS IS:',I5,4I3/) -C DETERMINE LATEST DATE FOR ACCEPTING BUFR MESSAGES FOR DECODING - if(ihl.ge.0) then - xminl = (ihl * 60) + 59 - else - xminl = ((ihl + 1) * 60) - 1 - end if - call w3movdat((/0.,0.,xminl,0.,0./),jdate,ldate) - print 6683, (ldate(i),i=1,3),ldate(5),ldate(6) - 6683 FORMAT(/' --> LATEST DATE FOR ACCEPTING BUFR MSGS IS:',I5,4I3/) - call w3difdat(ldate,kdate,3,rinc) - IF(rinc(3).LT.0) THEN - PRINT 104 - 104 FORMAT(' *** W3UNPK77 ERROR: DATES SPECIFIED INCORRECTLY -', - $ ' STOP 15'/) - CALL ERREXIT(15) - END IF -C----------------------------------------------------------------------- - END IF -C SUBR. UNPK7701 RETURNS A SINGLE DECODED REPORT FROM BUFR MESSAGE - CALL UNPK7701(LUNIT,ITP,IRET) -C IRET=1 MEANS ALL DATA HAVE BEEN DECODED FOR SPECIFIED TIME PERIOD -C (REWIND DATA FILE AND RETURN W/ IRET=1) -C IRET.GE.2 MEANS REPORT NOT RETURNED DUE TO ERROR IN DECODING (RETURN) -C (ACTUALLY IRET.GE.2 CURRENTLY CANNOT HAPPEN OUT OF UNPK7701) - IF(IRET.GE.1) THEN - IF(IRET.EQ.1) THEN - REWIND LUNIT - IF(ITP.EQ.2) THEN - PRINT 8101, IFOV - 8101 FORMAT(/' ---> W3UNPK77: SUMMARY OF GOES REPORT COUNTS GROUPED', - $ ' BY F-O-V NO. (PRIOR TO ANY FILTERING BY CALLING PROGRAM)'/15X, - $ '# WITH F-O-V NO. 00 TO 02:',I6,' - GET "BAD" Q.MARK'/15X, - $ '# WITH F-O-V NO. 03 TO 09:',I6,' - GET "SUSPECT" Q.MARK'/15X, - $ '# WITH F-O-V NO. 10 TO 25:',I6,' - GET "NEUTRAL" Q.MARK'/20X, - $ '(NOTE: RADIANCES ALWAYS HAVE NEUTRAL Q.MARK)'/) - PRINT 8102 - 8102 FORMAT(/' ---> W3UNPK77: SUMMARY OF GOES REPORT COUNTS GROUPED', - $ ' BY SATELLITE ID (PRIOR TO ANY FILTERING BY CALLING PROGRAM)'/) - DO IDSAT = 250,259 - IF(KNTSAT(IDSAT).GT.0) PRINT 8103, IDSAT,KNTSAT(IDSAT) - ENDDO - 8103 FORMAT(15X,'NUMBER FROM SAT. ID',I4,4X,':',I6) - IF(KNTSAT(260).GT.0) PRINT 8104 - 8104 FORMAT(15X,'NUMBER FROM UNKNOWN SAT. ID:',I6) - PRINT 8105 - 8105 FORMAT(/) - END IF - END IF - GO TO 99 - END IF - KOUNT = KOUNT + 1 -C INITIALIZE THE OUTPUT ON29 ARRAY - CALL UNPK7702(RDATA,ITP) - IF(ITP.EQ.1) THEN -C----------------------------------------------------------------------- -C THE FOLLOWING PERTAINS TO WIND PROFILER REPORTS -C----------------------------------------------------------------------- -C STORE THE HEADER INFORMATION INTO ON29 FORMAT - CALL UNPK7703(LUNIT,RDATA,IRET) -C IRET.GE.2 MEANS RPT NOT RETURNED DUE TO MSG DATA IN HDR (RETURN) - IF(IRET.GE.2) GO TO 99 -C STORE THE SURFACE DATA INTO ON29 FORMAT (CATEGORY 10) - CALL UNPK7704(LUNIT,RDATA) -C STORE THE UPPER-AIR DATA INTO ON29 FORMAT (CATEGORY 11) - CALL UNPK7705(LUNIT,RDATA) - RDATX(1:1200) = RDATA(1:1200) - IF(IDATA(35)+IDATA(37).EQ.0) IRET = 5 - ELSE IF(ITP.EQ.2) THEN -C----------------------------------------------------------------------- -C THE FOLLOWING PERTAINS TO GOES SOUNDING/RADIANCE REPORTS -C----------------------------------------------------------------------- -C STORE THE HEADER INFORMATION INTO ON29 FORMAT - CALL UNPK7708(LUNIT,RDATA,KOUNT,IRET) -C IRET.GE.2 MEANS RPT NOT RETURNED DUE TO MSG DATA IN HDR (RETURN) - IF(IRET.GE.2) GO TO 99 -C STORE THE UPPER-AIR DATA/RADIANCE INTO ON29 FORMAT (CATEGORY 12, 13) - CALL UNPK7709(LUNIT,RDATA,IRET) - ELSE IF(ITP.EQ.3) THEN -C----------------------------------------------------------------------- -C THE FOLLOWING PERTAINS TO NEXRAD (VAD) WIND REPORTS -C----------------------------------------------------------------------- -C STORE THE HEADER INFORMATION INTO ON29 FORMAT - CALL UNPK7706(LUNIT,RDATA,IRET) -C IRET.GE.2 MEANS RPT NOT RETURNED DUE TO MSG DATA IN HDR (RETURN) - IF(IRET.GE.2) GO TO 99 -C STORE THE UPPER-AIR DATA INTO ON29 FORMAT (CATEGORY 4) - CALL UNPK7707(LUNIT,RDATA,IRET) -C----------------------------------------------------------------------- - END IF - 99 CONTINUE -C PRIOR TO RETURNING SAVE INPUT DATE & HR RANGE ARGUMENTS FROM THIS CALL - lsdate = idate - LSHE = IHE - LSHL = IHL - RETURN -C----------------------------------------------------------------------- - 9999 CONTINUE -C COME HERE IF NULL OR NON-BUFR FILE IS INPUT - RETURN WITH IRET = 1 - PRINT *, ' *** W3UNPK77 ERROR: INPUT FILE IN UNIT ',LUNIT,' IS ', - $ 'EITHER A NULL OR NON-BUFR FILE' - 9998 continue - REWIND LUNIT - IRET = 1 - lsdate = idate - LSHE = IHE - LSHL = IHL - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: UNPK7701 READS A SINGLE REPORT OUT OF BUFR DATASET -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1996-12-16 -C -C ABSTRACT: CALLS BUFRLIB ROUTINES TO READ IN A BUFR MESSAGE AND THEN -C READ A SINGLE REPORT (SUBSET) OUT OF THE MESSAGE. -C -C PROGRAM HISTORY LOG: -C 1996-12-16 D. A. KEYSER NP22 - ORIGINAL AUTHOR -C -C USAGE: CALL UNPK7701(LUNIT,ITP,IRET) -C INPUT ARGUMENT LIST: -C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C ITP - THE TYPE OF REPORT THAT HAS BEEN DECODED {=1 - -C - WIND PROFILER, =2 - GOES SNDG, =3 - NEXRAD(VAD) WIND} -C IRET - RETURN CODE AS DESCRIBED IN W3UNPK77 DOCBLOCK -C -C INPUT FILES: -C UNIT AA - (WHERE AA IS LUNIT ABOVE) FILE HOLDING THE DATA -C - IN THE FORM OF BUFR MESSAGES -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY SUBROUTINE W3UNPK77. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP, CRAY, SGI -C -C$$$ - SUBROUTINE UNPK7701(LUNIT,ITP,IRET) - CHARACTER*8 SUBSET - integer mdate(4),ndate(8) - dimension rinc(5) - COMMON /PK77BB/kdate(8),ldate(8),IPRINT - COMMON /PK77CC/INDEX - COMMON /PK77DD/LSHE,LSHL,ICDATE(5),IDDATE(5) - - SAVE - - DATA IREC/0/ - - 10 CONTINUE -C======================================================================= - IF(INDEX.EQ.0) THEN - -C READ IN NEXT BUFR MESSAGE - - CALL READMG(LUNIT,SUBSET,IBDATE,JRET) - IF(JRET.NE.0) THEN -C----------------------------------------------------------------------- - PRINT 101 - 101 FORMAT(' ---> W3UNPK77: ALL BUFR MESSAGES READ IN AND DECODED'/) - IRET = 1 - RETURN -C----------------------------------------------------------------------- - END IF - if(ibdate.lt.100000000) then -c If input BUFR file does not return messages with a 4-digit year, -c something is wrong (even non-compliant BUFR messages should -c construct a 4-digit year as long as datelen(10) has been called - print *, '##W3UNP777/UNPK7701 - A 10-digit Sect. 1 BUFR ', - $ 'message date was not returned in unit ',lunit,' - ', - $ 'problem with BUFR file - ier = 1' - iret = 1 - return - end if - CALL UFBCNT(LUNIT,IREC,ISUB) - MDATE(1) = IBDATE/1000000 - MDATE(2) = MOD((IBDATE/10000),100) - MDATE(3) = MOD((IBDATE/100),100) - MDATE(4) = MOD(IBDATE,100) -C ALL JBUFR MESSAGES CURRENTLY HAVE "00" FOR MINUTES IN SECTION 1 - ndate(1:3) = mdate(1:3) - ndate(4) = 0 - ndate(5) = mdate(4) - ndate(6:8) = 0 - IF(IPRINT.GE.1) THEN - PRINT *,'HAVE SUCCESSFULLY READ IN A BUFR MESSAGE' - PRINT 103 - 103 FORMAT(' BUFR FOUND BEGINNING AT BYTE 1 OF MESSAGE') - PRINT 105, IREC,MDATE,SUBSET - 105 FORMAT(8X,'HAVE READ IN A BUFR MESSAGE NO.',I3,', DATE: ', - $ I6,3I4,' 0; TABLE A ENTRY = ',A8,' AND EDIT. NO. = 2'/) - END IF - IF(SUBSET.EQ.'NC002007') THEN - IF(IPRINT.GE.1) PRINT *, 'THIS MESSAGE CONTAINS WIND ', - $ 'PROFILER REPORTS' - ITP = 1 - ELSE IF(SUBSET.EQ.'NC002008') THEN - IF(IPRINT.GE.1) PRINT *, 'THIS MESSAGE CONTAINS NEXRAD ', - $ '(VAD) WIND REPORTS' - ITP = 3 - ELSE IF(SUBSET.EQ.'NC003001') THEN - IF(IPRINT.GE.1) PRINT *, 'THIS MESSAGE CONTAINS GOES ', - $ 'SOUNDING/RADIANCE REPORTS' - ITP = 2 - ELSE - PRINT 107, IREC - 107 FORMAT(' *** W3UNPK77 WARNING: BUFR MESSAGE NO.',I3,' CONTAINS ', - $ 'REPORTS THAT CANNOT BE DECODED BY W3UNPK77, TRY READING NEXT ', - $ 'MSG'/) - INDEX = 0 - GO TO 10 - END IF - call w3difdat(kdate,ndate,3,rinc) - kmin = rinc(3) - call w3difdat(ldate,ndate,3,rinc) - lmin = rinc(3) -C CHECK DATE OF MESSAGE AGAINST SPECIFIED TIME RANGES - if((kmin.gt.0.or.lmin.lt.0).AND.IREC.GT.2) then - PRINT 106, IREC,MDATE - 106 FORMAT(' BUFR MESSAGE NO.',I3,' WITH DATE:',I5,3I3,' 0 NOT W/I', - $ ' REQ. TIME RANGE, TRY READING NEXT MSG'/) - INDEX = 0 - GO TO 10 - END IF - END IF -C======================================================================= -C READ NEXT SUBSET (REPORT) IN MESSAGE - - IF(IPRINT.GT.1) PRINT *,'CALL READSB' - CALL READSB(LUNIT,JRET) - IF(IPRINT.GT.1) PRINT *,'BACK FROM READSB' - IF(JRET.NE.0) THEN - IF(INDEX.GT.0) THEN - -C ALL SUBSETS IN THIS MESSAGE PROCESSED, READ IN NEXT MESSAGE (IF ALL -C MESSAGES READ IN NO MORE DATA TO PROCESS) - - IF(IPRINT.GT.1) PRINT *, 'ALL REPORTS IN THIS MESSAGE ', - $ 'DECODED, GO ON TO NEXT MESSAGE' - ELSE - -C THERE WERE NO SUBSETS FOUND IN THIS BUFR MESSAGE, GOOD CHANCE IT IS -C ONE OF TWO DUMMY MESSAGES AT TOP OF FILE INDICATING CENTER TIME AND -C DATA DUMP TIME ONLY; READ IN NEXT MESSAGE - - IF(IREC.EQ.1) THEN - PRINT 4567, ICDATE - 4567 FORMAT(/'===> BUFR MESSAGE NO. 1 IS A DUMMY MESSAGE CONTAINING ', - $ 'ONLY CENTER DATE (',I5,4I3,') - NO DATA - GO ON TO NEXT ', - $ 'MESSAGE'/) - ELSE IF(IREC.EQ.2) THEN - PRINT 4568, IDDATE - 4568 FORMAT(/'===> BUFR MESSAGE NO. 2 IS A DUMMY MESSAGE CONTAINING ', - $ 'ONLY DUMP DATE (',I5,4I3,') - NO DATA - GO ON TO NEXT ', - $ 'MESSAGE'/) - ELSE - PRINT 4569, IREC,MDATE - 4569 FORMAT(/'===> BUFR MESSAGE NO.',I3,' (DATE:',I5,3I3,' 0) ', - $ 'CONTAINS ZERO REPORTS FOR SOME UNEXPLAINED REASON - GO ON TO ', - $ 'NEXT MESSAGE'/) - END IF - END IF - INDEX = 0 - GO TO 10 - END IF -C----------------------------------------------------------------------- - IF(IPRINT.GT.1) PRINT *, 'READY TO PROCESS NEW DECODED REPORT' -C*********************************************************************** -C A SINGLE REPORT HAS BEEN SUCCESSFULLY DECODED -C*********************************************************************** - INDEX = INDEX + 1 - IF(IPRINT.GE.1) PRINT *, 'WORKING WITH SUBSET NUMBER ',INDEX - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: UNPK7702 INITIALIZES THE OUTPUT ARRAY FOR A REPORT -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1996-12-16 -C -C ABSTRACT: INITIALIZES THE OUTPUT ARRAY WHICH HOLDS A SINGLE REPORT -C IN THE QUASI-OFFICE NOTE 29 UNPACKED FORMAT TO ALL MISSING. -C -C PROGRAM HISTORY LOG: -C 1996-12-16 D. A. KEYSER NP22 - ORIGINAL AUTHOR -C -C USAGE: CALL UNPK7702(RDATA,ITP) -C INPUT ARGUMENT LIST: -C ITP - THE TYPE OF REPORT THAT HAS BEEN DECODED {=1 - -C - WIND PROFILER, =2 - GOES SNDG, =3 - NEXRAD(VAD) WIND} -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C RDATA - SINGLE REPORT RETURNED AN A QUASI-OFFICE NOTE 29 -C UNPACKED FORMAT; ALL DATA ARE MISSING -C -C REMARKS: CALLED BY SUBROUTINE W3UNPK77. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP, CRAY, SGI -C -C$$$ - SUBROUTINE UNPK7702(RDATA,ITP) - REAL RDATA(*),RDATX(1200) - INTEGER IDATA(1200),IRTYP(3) - CHARACTER*8 COB -C - SAVE -C - EQUIVALENCE (RDATX,IDATA),(COB,IOB) - DATA XMSG/99999./,IMSG/99999/,IRTYP/71,61,72/ - RDATX(1) = XMSG - RDATX(2) = XMSG - IDATA(3) = IMSG - RDATX(4) = XMSG - COB = '999999 ' - IDATA(5) = IOB - COB = '9999 ' - IDATA(6) = IOB - RDATX(7) = XMSG - IDATA(8) = IMSG - IDATA(9) = IRTYP(ITP) - IDATA(10) = IMSG - COB = ' ' - IDATA(11) = IOB - IDATA(12) = IOB -C -C ALL TYPES -- LOAD ZEROS INTO THE DEFINING WORD PAIRS -C - IDATA(13:42) = 0 -C -C ALL TYPES -- LOAD MISSINGS INTO THE DATA PORTION -C - RDATX(43:1200) = XMSG - IF(ITP.EQ.1) THEN -C -C PROFILER -- LOAD INTEGER MISSING WHERE APPROPRIATE -C (Current limit of 104 Cat. 11 levels) -C - IDATA(53:1200:11) = IMSG - IDATA(55:1200:11) = IMSG - IDATA(56:1200:11) = IMSG - IDATA(60:1200:11) = IMSG - ELSE IF(ITP.EQ.2) THEN -C -C GOES -- LOAD DEFAULT OF BLANK CHARACTERS INTO CAT. 12 -C LEVEL QUALITY MARKERS -C (Current limit of 50 Cat. 12 levels) -C (could be expanded if need be) -C - IDATA(49:392:7) = IOB -C -C GOES -- LOAD DEFAULT OF BLANK CHARACTER INTO FIRST CAT. 08 -C LEVEL QUALITY MARKER -C (Current limit of 9 Cat. 08 levels) -C (could be expanded if need be) -C - IDATA(395:419:3) = IOB -C GOES -- LOAD INTEGER MISSING INTO CAT. 13 LEVEL CHANNEL NUMBER -C -- LOAD DEFAULT OF BLANK CHARACTER INTO CAT. 13 LEVEL -C QUALITY MARKER -C (Current limit of 60 Cat. 13 levels) -C (could be expanded if need be) -C - IDATA(420:599:3) = IMSG - IDATA(422:599:3) = IOB - ELSE IF(ITP.EQ.3) THEN -C -C VADWND -- LOAD DEFAULT OF BLANK CHARACTER INTO HGHT CAT. 04 -C LEVEL QUALITY MARKER -C (Current limit of 70 Cat. 04 levels) -C (could be expanded if need be) -C - IDATA(46:1200:4) = IOB - END IF - RDATA(1:1200) = RDATX(1:1200) - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: UNPK7703 FILLS IN HEADER IN O-PUT ARRAY - PFLR RPT -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-03-05 -C -C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN -C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE -C HEADER DATA FOR WIND PROFILER REPORT. HEADER IS THEN FILLED INTO -C THE OUTPUT ARRAY WHICH HOLDS A SINGLE WIND PROFILER REPORT IN THE -C QUASI-OFFICE NOTE 29 UNPACKED FORMAT. -C -C PROGRAM HISTORY LOG: -C 1996-12-16 D. A. KEYSER NP22 - ORIGINAL AUTHOR -C 2002-03-05 KEYSER -- ACCOUNTS FOR CHANGES IN INPUT PROFLR (WIND -C PROFILER) BUFR DUMP FILE AFTER 3/2002: MNEMONIC -C "NPSM" IS NO LONGER AVAILABLE, MNEMONIC "TPSE" -C REPLACES "TPMI" (AVG. TIME IN MINUTES STILL -C OUTPUT) (WILL STILL WORK PROPERLY FOR INPUT -C PROFLR DUMP FILES PRIOR TO 3/2002) -C -C USAGE: CALL UNPK7703(LUNIT,RDATA,IRET) -C INPUT ARGUMENT LIST: -C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE -C RDATA - SINGLE WIND PROFILER REPORT IN A QUASI-OFFICE NOTE 29 -C - UNPACKED FORMAT WITH ALL DATA INITIALIZED AS MISSING -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C RDATA - SINGLE WIND PROFILER REPORT IN A QUASI-OFFICE NOTE 29 -C - UNPACKED FORMAT WITH HEADER INFORMATION FILLED IN -C - (ALL OTHER DATA REMAINS MISSING) -C IRET - RETURN CODE AS DESCRIBED IN W3UNPK77 DOCBLOCK -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY SUBROUTINE W3UNPK77. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP, CRAY, SGI -C -C$$$ - SUBROUTINE UNPK7703(LUNIT,RDATA,IRET) - CHARACTER*6 STNID - CHARACTER*8 COB - CHARACTER*35 HDR1,HDR2 - INTEGER IDATA(1200) - REAL(8) HDR_8(16) - REAL HDR(16),RDATA(*),RDATX(1200) - COMMON /PK77BB/kdate(8),ldate(8),IPRINT - - SAVE - - EQUIVALENCE (RDATX,IDATA),(COB,IOB) - DATA XMSG/99999./,IMSG/99999/ - DATA HDR1/'CLAT CLON TSIG SELV NPSM TPSE WMOB '/ - DATA HDR2/'WMOS YEAR MNTH DAYS HOUR MINU TPMI '/ - RDATX(1:1200) = RDATA(1:1200) - HDR_8 = 10.0E10 - CALL UFBINT(LUNIT,HDR_8,16,1,NLEV,HDR1//HDR2);HDR=HDR_8 - IF(NLEV.NE.1) THEN -C....................................................................... -C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED -- -C SET IRET = 6 AND RETURN - PRINT 217, NLEV - 217 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',I5,') ', - $ 'IS NOT WHAT IS EXPECTED (1) - IRET = 6'/) - IRET = 6 - RETURN -C....................................................................... - END IF - -C LATITUDE (STORED AS REAL) - - M = 1 - IF(IPRINT.GT.1) PRINT 199, HDR(1),M - 199 FORMAT(5X,'HDR HERE IS: ',F17.4,'; INDEX IS: ',I3) - IF(HDR(1).LT.XMSG) THEN - RDATX(1) = NINT(HDR(1) * 100.) - NNNNN = 1 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) - 198 FORMAT(5X,'DATA(',I5,') STORED AS: ',F10.2) - ELSE - IRET = 2 - PRINT 102 - 102 FORMAT(' *** W3UNPK77 ERROR: LAT MISSING FOR WIND PROFILER ', - $ 'REPORT'/) - RETURN - END IF - -C LONGITUDE (STORED AS REAL) - - M = 2 - IF(IPRINT.GT.1) PRINT 199, HDR(2),M - IF(HDR(2).LT.XMSG) THEN - RDATX(2) = NINT(MOD((36000.-(HDR(2)*100.)),36000.)) - NNNNN = 2 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) - ELSE - IRET = 2 - PRINT 104 - 104 FORMAT(' *** W3UNPK77 ERROR: LON MISSING FOR WIND PROFILER ', - $ 'REPORT'/) - RETURN - END IF - -C TIME SIGNIFICANCE (STORED AS INTEGER) - - M = 3 - IF(IPRINT.GT.1) PRINT 199, HDR(3),M - IF(HDR(3).LT.XMSG) IDATA(3) = NINT(HDR(3)) - NNNNN = 3 - IF(IPRINT.GT.1) PRINT 197, NNNNN,IDATA(NNNNN) - 197 FORMAT(5X,'IDATA(',I5,') STORED AS: ',I10) - -C STATION ELEVATION (FROM REPORTED STN. HGHT; STORED IN OUTPUT) -C (STORED AS REAL) - - M = 4 - IF(IPRINT.GT.1) PRINT 199, HDR(4),M - IF(HDR(4).LT.XMSG) RDATX(7) = NINT(HDR(4)) - NNNNN = 7 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) - -C SUBMODE INFORMATION -C EDITION NUMBER (ALWAYS = 2) -C (PACKED AS SUBMODE TIMES 10 PLUS EDITION NUMBER - INTEGER) -C {NOTE: After 3/2002, the submode information is no longer -C available and is stored as missing (3).} - - M = 5 - IEDTN = 2 - IDATA(8) = (3 * 10) + IEDTN - IF(IPRINT.GT.1) PRINT 199, HDR(5),M - IF(HDR(5).LT.XMSG) IDATA(8) = (NINT(HDR(5)) * 10) + IEDTN - NNNNN = 8 - IF(IPRINT.GT.1) PRINT 197, NNNNN,IDATA(NNNNN) - -C AVERAGING TIME (STORED AS INTEGER) -C (NOTE: Prior to 3/2002, this is decoded in minutes, after -C 3/2002 this is decoded in seconds - in either case -C it is stored in minutes) - - M = 6 - IF(IPRINT.GT.1) PRINT 199, HDR(6),M - IF(IPRINT.GT.1) PRINT 199, HDR(14),M - IF(HDR(6).LT.XMSG) THEN - IDATA(10) = NINT(HDR(6)/60.) - ELSE IF(HDR(14).LT.XMSG) THEN - IDATA(10) = NINT(HDR(14)) - END IF - NNNNN = 10 - IF(IPRINT.GT.1) PRINT 197, NNNNN,IDATA(NNNNN) -C----------------------------------------------------------------------- - -C STATION IDENTIFICATION (STORED AS CHARACTER) -C (OBTAINED FROM ENCODED WMO BLOCK/STN NUMBERS) - - STNID = ' ' - -C WMO BLOCK NUMBER (STORED AS CHARACTER) - - M = 7 - IF(IPRINT.GT.1) PRINT 199, HDR(7),M - IF(HDR(7).LT.XMSG) WRITE(STNID(1:2),'(I2.2)') NINT(HDR(7)) - -C WMO STATION NUMBER (STORED AS CHARACTER) - - M = 8 - IF(IPRINT.GT.1) PRINT 199, HDR(8),M - IF(HDR(8).LT.XMSG) WRITE(STNID(3:5),'(I3.3)') NINT(HDR(8)) - COB(1:4) = STNID(1:4) - IDATA(11) = IOB - NNNNN = 11 - IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4) - 196 FORMAT(5X,'IDATA(',I5,') STORED IN CHARACTER AS: "',A4,'"') - COB(1:4) = STNID(5:6)//' ' - IDATA(12) = IOB - NNNNN = 12 - IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4) - -cvvvvvdak port -C LOAD THE YEAR/MONTH (STORED AS CHARACTER IN FORM YYMM) -caaaaadak port - - M = 9 - IF(IPRINT.GT.1) PRINT 199, HDR(9),M - IYEAR = IMSG - IF(HDR(9).LT.XMSG) IYEAR = NINT(HDR(9)) - M = 10 - IF(IPRINT.GT.1) PRINT 199, HDR(10),M - IF(HDR(10).LT.XMSG.AND.IYEAR.LT.IMSG) THEN -cvvvvvdak port - IYEAR = MOD(IYEAR,100) -caaaaadak port - IYEAR = NINT(HDR(10)) + (IYEAR * 100) -cvvvvvdak port -cdak WRITE(COB,'(I6.6,2X)') IYEAR - WRITE(COB,'(I4.4,4X)') IYEAR -caaaaadak port - IDATA(5) = IOB - NNNNN = 5 - IF(IPRINT.GT.1) PRINT 9196, NNNNN,COB(1:6) - 9196 FORMAT(5X,'IDATA(',I5,') STORED IN CHARACTER AS: "',A6,'"') - ELSE - GO TO 30 - END IF - -C LOAD THE DAY/HOUR (STORED AS CHARACTER IN FORM DDHH) -C AND THE OBSERVATION TIME (STORED AS REAL) - - M = 11 - IF(IPRINT.GT.1) PRINT 199, HDR(11),M - IDAY = IMSG - IF(HDR(11).LT.XMSG) IDAY = NINT(HDR(11)) - M = 12 - IF(IPRINT.GT.1) PRINT 199, HDR(12),M - IF(HDR(12).LT.XMSG.AND.IDAY.LT.IMSG) THEN - IHRT = NINT(HDR(12)) - M = 13 - IF(IPRINT.GT.1) PRINT 199, HDR(13),M - IF(HDR(13).GE.XMSG) GO TO 30 - RMNT = HDR(13) - RDATX(4) = NINT((IHRT * 100.) + (RMNT * 100.)/60.) - NNNNN = 4 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) - IHRT = IHRT + (IDAY * 100) - WRITE(COB(1:4),'(I4.4)') IHRT - IDATA(6) = IOB - NNNNN = 6 - IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4) - ELSE - GO TO 30 - END IF - RDATA(1:1200) = RDATX(1:1200) - RETURN - 30 CONTINUE - IRET = 4 - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: UNPK7704 FILLS CAT.10 INTO O-PUT ARRAY - PFLR RPT -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-03-05 -C -C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN -C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE -C SURFACE DATA FOR WIND PROFILER REPORT. SURFACE DATA ARE THEN -C FILLED INTO THE OUTPUT ARRAY AS CATEGORY 10. THE OUPUT ARRAY -C HOLDS A SINGLE WIND PROFILER REPORT IN THE QUASI-OFFICE NOTE 29 -C UNPACKED FORMAT. -C -C PROGRAM HISTORY LOG: -C 1996-12-16 D. A. KEYSER NP22 - ORIGINAL AUTHOR -C 2002-03-05 KEYSER -- ACCOUNTS FOR CHANGES IN INPUT PROFLR (WIND -C PROFILER) BUFR DUMP FILE AFTER 3/2002: SURFACE -C DATA NOW ALL MISSING (MNEMONICS "PMSL", -C "WDIR1","WSPD1", "TMDB", "REHU", "REQV" NO -C LONGER AVAILABLE) (WILL STILL WORK PROPERLY FOR -C INPUT PROFLR DUMP FILES PRIOR TO 3/2002) -C -C USAGE: CALL UNPK7704(LUNIT,RDATA) -C INPUT ARGUMENT LIST: -C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE -C RDATA - SINGLE WIND PROFILER REPORT IN A QUASI-OFFICE NOTE 29 -C - UNPACKED FORMAT WITH ONLY HEADER INFORMATION FILLED -C - IN (ALL OTHER DATA REMAINS MISSING) -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C RDATA - SINGLE WIND PROFILER REPORT IN A QUASI-OFFICE NOTE 29 -C - UNPACKED FORMAT WITH SURFACE INFORMATION FILLED IN -C - (AS WELL AS THE HEADER; ALL OTHER DATA REMAINS -C - MISSING) -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY SUBROUTINE W3UNPKB7. AFTER 3/2002, THERE IS -C NO SURFACE DATA AVAILABLE. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP, CRAY, SGI -C -C$$$ - SUBROUTINE UNPK7704(LUNIT,RDATA) - CHARACTER*40 SRFC - INTEGER IDATA(1200) - REAL(8) SFC_8(8) - REAL SFC(8),RDATA(*),RDATX(1200) - COMMON /PK77BB/kdate(8),ldate(8),IPRINT - - SAVE - - EQUIVALENCE (RDATX,IDATA) - DATA XMSG/99999./ - DATA SRFC/'PMSL WDIR1 WSPD1 TMDB REHU REQV '/ - RDATX(1:1200) = RDATA(1:1200) - SFC_8 = 10.0E10 - CALL UFBINT(LUNIT,SFC_8,8,1,NLEV,SRFC);SFC=SFC_8 - IF(NLEV.NE.1) THEN -C....................................................................... -C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED -- - PRINT 217, NLEV - 217 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',I5,') ', - $ 'IS NOT WHAT IS EXPECTED (1) - NO SFC DATA PROCESSED'/) - GO TO 99 -C....................................................................... - END IF - -C MSL PRESSURE (STORED AS REAL) - - M = 1 - IF(IPRINT.GT.1) PRINT 199, SFC(1),M - 199 FORMAT(5X,'SFC HERE IS: ',F17.4,'; INDEX IS: ',I3) - IF((SFC(1)*0.1).LT.XMSG) RDATX(43) = NINT(SFC(1) * 0.1) - NNNNN = 43 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(43) - 198 FORMAT(5X,'RDATA(',I5,') STORED AS: ',F10.2) - -C SURFACE HORIZONTAL WIND DIRECTION (STORED AS REAL) - - M = 2 - IF(IPRINT.GT.1) PRINT 199, SFC(2),M - IF(SFC(2).LT.XMSG) RDATX(43+2) = NINT(SFC(2)) - NNNNN = 43 + 2 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(43+2) - -C SURFACE HORIZONTAL WIND SPEED (STORED AS REAL) - - M = 3 - IF(IPRINT.GT.1) PRINT 199, SFC(3),M - IF(SFC(3).LT.XMSG) RDATX(43+3) = NINT(SFC(3) * 10.) - NNNNN = 43 + 3 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(43+3) - -C SURFACE TEMPERATURE (STORED AS REAL) - - M = 4 - IF(IPRINT.GT.1) PRINT 199, SFC(4),M - IF(SFC(4).LT.XMSG) RDATX(43+4) = NINT(SFC(4) * 10.) - NNNNN = 43 + 4 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(43+4) - -C RELATIVE HUMIDITY (STORED AS REAL) - - M = 5 - IF(IPRINT.GT.1) PRINT 199, SFC(5),M - IF(SFC(5).LT.XMSG) RDATX(43+5) = NINT(SFC(5)) - NNNNN = 43 + 5 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(43+5) - -C RAINFALL RATE (STORED AS REAL) - - M = 6 - IF(IPRINT.GT.1) PRINT 199, SFC(6),M - IF(SFC(6).LT.XMSG) RDATX(43+6) = NINT(SFC(6) * 1.E7) - NNNNN = 43 + 6 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(43+6) - -C SET CATEGORY COUNTERS FOR SURFACE DATA - - IDATA(35) = 1 - IDATA(36) = 43 - 99 CONTINUE - IF(IPRINT.GT.1) PRINT *, 'IDATA(35)=',IDATA(35),'; IDATA(36)=', - $ IDATA(36) - RDATA(1:1200) = RDATX(1:1200) - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: UNPK7705 FILLS CAT.11 INTO O-PUT ARRAY - PFLR RPT -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-03-05 -C -C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN -C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE -C UPPER-AIR DATA FOR WIND PROFILER REPORT. UPPER-AIR DATA ARE THEN -C FILLED INTO THE OUTPUT ARRAY AS CATEGORY 11. THE OUPUT ARRAY -C HOLDS A SINGLE WIND PROFILER REPORT IN THE QUASI-OFFICE NOTE 29 -C UNPACKED FORMAT. -C -C PROGRAM HISTORY LOG: -C 1996-12-16 D. A. KEYSER NP22 - ORIGINAL AUTHOR -C 1998-07-09 KEYSER -- MODIFIED WIND PROFILER CAT. 11 (HEIGHT, HORIZ. -C SIGNIFICANCE, VERT. SIGNIFICANCE) PROCESSING -C TO ACCOUNT FOR UPDATES TO BUFRTABLE MNEMONICS -C IN /dcom -C 2002-03-05 KEYSER -- ACCOUNTS FOR CHANGES IN INPUT PROFLR (WIND -C PROFILER) BUFR DUMP FILE AFTER 3/2002: -C MNEMONICS "ACAVH", "ACAVV", "SPP0", AND "NPHL" -C NO LONGER AVAILABLE; (WILL STILL WORK PROPERLY -C FOR INPUT PROFLR DUMP FILES PRIOR TO 3/2002) -C -C USAGE: CALL UNPK7705(LUNIT,RDATA) -C INPUT ARGUMENT LIST: -C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE -C RDATA - SINGLE WIND PROFILER REPORT IN A QUASI-OFFICE NOTE 29 -C - UNPACKED FORMAT WITH ONLY HEADER AND SURFACE -C - INFORMATION FILLED IN (UPPER-AIR DATA MISSING) -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C RDATA - SINGLE WIND PROFILER REPORT IN A QUASI-OFFICE NOTE 29 -C - UNPACKED FORMAT WITH UPPER-AIR INFORMATION FILLED -C - IN (ALL DATA FOR REPORT NOW FILLED) -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY SUBROUTINE W3UNPK77. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP, CRAY, SGI -C -C$$$ - SUBROUTINE UNPK7705(LUNIT,RDATA) - CHARACTER*31 UAIR1,UAIR2 - CHARACTER*16 UAIR3 - INTEGER IDATA(1200) - REAL(8) UAIR_8(16,255) - REAL UAIR(16,255),RDATA(*),RDATX(1200) - COMMON /PK77BB/kdate(8),ldate(8),IPRINT - - SAVE - - EQUIVALENCE (RDATX,IDATA) - DATA XMSG/99999./ - DATA UAIR1/'HEIT WDIR WSPD NPQC WCMP ACAVH '/ - DATA UAIR2/'ACAVV SPP0 SDHS SDVS NPHL '/ - DATA UAIR3/'HAST ACAV1 ACAV2'/ - RDATX(1:1200) = RDATA(1:1200) - NSFC = 0 - ILVL = 0 - ILC = 0 -C FIRST UPPER-AIR LEVEL IS THE SURFACE INFORMATION - IF(IPRINT.GT.1) PRINT 1078, ILC,ILVL - 1078 FORMAT(' ATTEMPTING 1ST (SFC) LVL WITH ILC =',I5,'; NO. LEVELS ', - $ 'PROCESSED TO NOW =',I5) - RDATX(50+ILC) = RDATX(7) - IF(IPRINT.GT.1) PRINT 198, 50+ILC,RDATX(50+ILC) - 198 FORMAT(5X,'RDATA(',I5,') STORED AS: ',F10.2) - IF(RDATX(50+ILC).LT.XMSG) NSFC = 1 - IF(IDATA(35).GE.1) THEN - RDATX(50+ILC+1) = RDATX(IDATA(36)+2) - RDATX(50+ILC+2) = RDATX(IDATA(36)+3) - END IF - IF(IPRINT.GT.1) PRINT 198, 50+ILC+1,RDATX(50+ILC+1) - IF(RDATX(50+ILC+1).LT.XMSG) NSFC = 1 - IF(IPRINT.GT.1) PRINT 198, 50+ILC+2,RDATX(50+ILC+2) - IF(RDATX(50+ILC+2).LT.XMSG) NSFC = 1 - ILVL = ILVL + 1 - ILC = ILC + 11 - IF(IPRINT.GT.1) PRINT *,'HAVE COMPLETED LEVEL ',ILVL,' WITH ', - $ 'NSFC=',NSFC,'; GOING INTO NEXT LEVEL WITH ILC=',ILC - UAIR_8 = 10.0E10 - CALL UFBINT(LUNIT,UAIR_8,16,255,NLEV,UAIR1//UAIR2//UAIR3) - UAIR=UAIR_8 - IF(NLEV.EQ.0) THEN -C....................................................................... -C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO -- - IF(NSFC.EQ.0) THEN -C ... NO UPPER AIR DATA PROCESSED - PRINT 217 - 217 FORMAT(/' ##W3UNPK77: NO UPPER-AIR DATA PROCESSED FOR THIS', - $ ' REPORT -- NLEV = 0 AND NSFC = 0'/) - GO TO 99 - ELSE -C ... ONLY FIRST (SURFACE) UPPER AIR LEVEL DATA PROCESSED - PRINT 218 - 218 FORMAT(/' ##W3UNPK77: NO UPPER-AIR DATA ABOVE FIRST (SURFACE) ', - $ 'LEVEL PROCESSED FOR THIS REPORT -- NLEV = 0 AND NSFC > 0'/) - GO TO 98 - END IF -C....................................................................... - END IF - IF(IPRINT.GT.1) PRINT 1068, NLEV - 1068 FORMAT(' THIS REPORT CONTAINS ',I3,' LEVELS OF DATA (NOT ', - $ 'INCLUDING BOTTOM -SURFACE- LEVEL)') - DO I = 1,NLEV - IF(IPRINT.GT.1) PRINT 1079, ILC,ILVL - 1079 FORMAT(' ATTEMPTING NEW LEVEL WITH ILC =',I5,'; NO. LEVELS ', - $ 'PROCESSED TO NOW =',I5) - -C HEIGHT ABOVE SEA-LEVEL (STORED AS REAL) -C (NOTE: At one time, possibly even now, the height above sea -C level was erroneously stored under mnemonic "HAST" -C when it should have been stored under mnemonic "HEIT". -C ("HAST" is defined as the height above the station.) -C Will test first for valid data in "HEIT" - if missing, -C then will use data in "HAST" - this will allow this -C routine to transition w/o change when the fix is made.) - - IF(UAIR(1,I).LT.XMSG) THEN - M = 1 - IF(IPRINT.GT.1) PRINT 199, UAIR(1,I),M - 199 FORMAT(5X,'UAIR HERE IS: ',F17.4,'; INDEX IS: ',I3) - RDATX(50+ILC) = NINT(UAIR(1,I)) - ELSE - M = 12 - IF(IPRINT.GT.1) PRINT 199, UAIR(12,I),M - IF(UAIR(12,I).LT.XMSG) RDATX(50+ILC) = NINT(UAIR(12,I)) - END IF - IF(IPRINT.GT.1) PRINT 198, 50+ILC,RDATX(50+ILC) - ILVL = ILVL + 1 - -C HORIZONTAL WIND DIRECTION (STORED AS REAL) - - M = 2 - IF(IPRINT.GT.1) PRINT 199, UAIR(2,I),M - IF(UAIR(2,I).LT.XMSG) RDATX(50+ILC+1) = NINT(UAIR(2,I)) - IF(IPRINT.GT.1) PRINT 198, 50+ILC+1,RDATX(50+ILC+1) - -C HORIZONTAL WIND SPEED (STORED AS REAL) - - M = 3 - IF(IPRINT.GT.1) PRINT 199, UAIR(3,I),M - IF(UAIR(3,I).LT.XMSG) RDATX(50+ILC+2) =NINT(UAIR(3,I) * 10.) - IF(IPRINT.GT.1) PRINT 198, 50+ILC+2,RDATX(50+ILC+2) - -C QUALITY CODE (STORED AS INTEGER) - - M = 4 - IF(IPRINT.GT.1) PRINT 199, UAIR(4,I),M - IF(UAIR(4,I).LT.XMSG) IDATA(50+ILC+3) = NINT(UAIR(4,I)) - IF(IPRINT.GT.1) PRINT 197, 50+ILC+3,IDATA(50+ILC+3) - 197 FORMAT(5X,'IDATA(',I5,') STORED AS: ',I10) - -C VERTICAL WIND COMPONENT (W) (STORED AS REAL) - - M = 5 - IF(IPRINT.GT.1) PRINT 199, UAIR(5,I),M - IF(UAIR(5,I).LT.XMSG) RDATX(50+ILC+4) = NINT(UAIR(5,I) * 100.) - IF(IPRINT.GT.1) PRINT 198, 50+ILC+4,RDATX(50+ILC+4) - -C HORIZONTAL CONSENSUS NUMBER (STORED AS INTEGER) -C (NOTE: Prior to 2/18/1999, the horizonal consensus number was -C stored under mnemonic "ACAV1". -C From 2/18/1999 through 3/2002, the horizontal consensus -C number was stored under mnemonic "ACAVH". -C After 3/2002, the horizontal consensus number is no -C longer stored. -C Will test first for valid data in "ACAVH" - if missing, -C then will test for data in "ACAV1" - this will allow -C this routine to work properly with historical data.) - - IF(IPRINT.GT.1) PRINT 199, UAIR(6,I),M - IF(IPRINT.GT.1) PRINT 199, UAIR(13,I),M - IF(UAIR(6,I).LT.XMSG) THEN - M = 6 - IDATA(50+ILC+5) = NINT(UAIR(6,I)) - ELSE - M = 13 - IF(UAIR(13,I).LT.XMSG) IDATA(50+ILC+5) = NINT(UAIR(13,I)) - END IF - IF(IPRINT.GT.1) PRINT 197, 50+ILC+5,IDATA(50+ILC+5) - -C VERTICAL CONSENSUS NUMBER (STORED AS INTEGER) -C (NOTE: Prior to 2/18/1999, the vertical consensus number was -C stored under mnemonic "ACAV2". -C From 2/18/1999 through 3/2002, the vertical consensus -C number was stored under mnemonic "ACAVV". -C After 3/2002, the vertical consensus number is no -C longer stored. -C Will test first for valid data in "ACAVV" - if missing, -C then will test for data in "ACAV2" - this will allow -C this routine to work properly with historical data.) - - IF(IPRINT.GT.1) PRINT 199, UAIR(7,I),M - IF(IPRINT.GT.1) PRINT 199, UAIR(14,I),M - IF(UAIR(7,I).LT.XMSG) THEN - M = 7 - IDATA(50+ILC+6) = NINT(UAIR(7,I)) - ELSE - M = 14 - IF(UAIR(14,I).LT.XMSG) IDATA(50+ILC+6) = NINT(UAIR(14,I)) - END IF - IF(IPRINT.GT.1) PRINT 197, 50+ILC+6,IDATA(50+ILC+6) - -C SPECTRAL PEAK POWER (STORED AS REAL) -C (NOTE: After 3/2002, the spectral peak power is no longer -C stored.) - - M = 8 - IF(IPRINT.GT.1) PRINT 199, UAIR(8,I),M - IF(UAIR(8,I).LT.XMSG) RDATX(50+ILC+7) = NINT(UAIR(8,I)) - IF(IPRINT.GT.1) PRINT 198, 50+ILC+7,RDATX(50+ILC+7) - -C HORIZONTAL WIND SPEED STANDARD DEVIATION (STORED AS REAL) - - M = 9 - IF(IPRINT.GT.1) PRINT 199, UAIR(9,I),M - IF(UAIR(9,I).LT.XMSG) RDATX(50+ILC+8)=NINT(UAIR(9,I) * 10.) - IF(IPRINT.GT.1) PRINT 198, 50+ILC+8,RDATX(50+ILC+8) - -C VERTICAL WIND COMPONENT STANDARD DEVIATION (STORED AS REAL) - - M = 10 - IF(IPRINT.GT.1) PRINT 199, UAIR(10,I),M - IF(UAIR(10,I).LT.XMSG) RDATX(50+ILC+9) =NINT(UAIR(10,I) * 10.) - IF(IPRINT.GT.1) PRINT 198, 50+ILC+9,RDATX(50+ILC+9) - -C MODE INFORMATION (STORED AS INTEGER) -C (NOTE: After 3/2002, the mode information is no longer stored.) - - M = 11 - IF(IPRINT.GT.1) PRINT 199, UAIR(11,I),M - IF(UAIR(11,I).LT.XMSG) IDATA(50+ILC+10) = NINT(UAIR(11,I)) - IF(IPRINT.GT.1) PRINT 197, 50+ILC+10,IDATA(50+ILC+10) -C....................................................................... - ILC = ILC + 11 - IF(IPRINT.GT.1) PRINT *,'HAVE COMPLETED LEVEL ',ILVL, - $ '; GOING INTO NEXT LEVEL WITH ILC=',ILC - ENDDO - -C SET CATEGORY COUNTERS FOR UPPER-AIR DATA - - 98 CONTINUE - IDATA(37) = ILVL - IDATA(38) = 50 - 99 CONTINUE - IF(IPRINT.GT.1) PRINT *, 'NSFC=',NSFC,'; IDATA(37)=',IDATA(37), - $ '; IDATA(38)=',IDATA(38) - RDATA(1:1200) = RDATX(1:1200) - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: UNPK7706 FILLS IN HEADER IN O-PUT ARRAY - VADW RPT -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1997-06-02 -C -C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN -C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE -C HEADER DATA FOR NEXRAD (VAD) WIND REPORT. HEADER IS THEN FILLED -C INTO THE OUTPUT ARRAY WHICH HOLDS A SINGLE VAD WIND REPORT IN THE -C QUASI-OFFICE NOTE 29 UNPACKED FORMAT. -C -C PROGRAM HISTORY LOG: -C 1997-06-02 D. A. KEYSER NP22 - ORIGINAL AUTHOR -C -C USAGE: CALL UNPK7706(LUNIT,RDATA,IRET) -C INPUT ARGUMENT LIST: -C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE -C RDATA - SINGLE NEXRAD (VAD) REPORT IN A QUASI-OFFICE NOTE 29 -C - UNPACKED FORMAT WITH ALL DATA INITIALIZED AS MISSING -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C RDATA - SINGLE NEXRAD (VAD) REPORT IN A QUASI-OFFICE NOTE 29 -C - UNPACKED FORMAT WITH HEADER INFORMATION FILLED IN -C - (ALL OTHER DATA REMAINS MISSING) -C IRET - RETURN CODE AS DESCRIBED IN W3UNPK77 DOCBLOCK -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY SUBROUTINE W3UNPK77. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP, CRAY, SGI -C -C$$$ - SUBROUTINE UNPK7706(LUNIT,RDATA,IRET) - CHARACTER*8 STNID,COB - CHARACTER*45 HDR1 - INTEGER IDATA(1200) - REAL(8) HDR_8(9) - REAL HDR(9),RDATA(*),RDATX(1200) - COMMON /PK77BB/kdate(8),ldate(8),IPRINT - - SAVE - - EQUIVALENCE (RDATX,IDATA),(STNID,HDR_8(4)),(COB,IOB) - DATA XMSG/99999./,IMSG/99999/ - DATA HDR1/'CLAT CLON SELV RPID YEAR MNTH DAYS HOUR MINU '/ - RDATX(1:1200) = RDATA(1:1200) - HDR_8 = 10.0E10 - CALL UFBINT(LUNIT,HDR_8,9,1,NLEV,HDR1);HDR=HDR_8 - IF(NLEV.NE.1) THEN -C....................................................................... -C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED -- -C SET IRET = 6 AND RETURN - PRINT 217, NLEV - 217 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',I5,') ', - $ 'IS NOT WHAT IS EXPECTED (1) - IRET = 6'/) - IRET = 6 - RETURN -C....................................................................... - END IF - -C LATITUDE (STORED AS REAL) - - M = 1 - IF(IPRINT.GT.1) PRINT 199, HDR(1),M - 199 FORMAT(5X,'HDR HERE IS: ',F17.4,'; INDEX IS: ',I3) - IF(HDR(1).LT.XMSG) THEN - RDATX(1) = NINT(HDR(1) * 100.) - NNNNN = 1 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) - 198 FORMAT(5X,'RDATA(',I5,') STORED AS: ',F10.2) - ELSE - IRET = 2 - PRINT 102 - 102 FORMAT(' *** W3UNPK77 ERROR: LAT MISSING FOR VAD WIND REPORT'/) - RETURN - END IF - -C LONGITUDE (STORED AS REAL) - - M = 2 - IF(IPRINT.GT.1) PRINT 199, HDR(2),M - IF(HDR(2).LT.XMSG) THEN - RDATX(2) = NINT(MOD((36000.-(HDR(2)*100.)),36000.)) - NNNNN = 2 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) - ELSE - IRET = 2 - PRINT 104 - 104 FORMAT(' *** W3UNPK77 ERROR: LON MISSING FOR VAD WIND REPORT'/) - RETURN - END IF - -C STATION ELEVATION (FROM REPORTED STN. HGHT; STORED IN OUTPUT) -C (STORED AS REAL) - - M = 3 - IF(IPRINT.GT.1) PRINT 199, HDR(3),M - IF(HDR(3).LT.XMSG) RDATX(7) = NINT(HDR(3)) - NNNNN = 7 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) - -C STATION IDENTIFICATION (STORED AS CHARACTER) -C ('99'//LAST 3-CHARACTERS OF PRODUCT SOURCE ID//' ') - - M = 4 - IF(IPRINT.GT.1) PRINT 299, STNID,M - 299 FORMAT(5X,'HDR HERE IS: ',9X,A8,'; INDEX IS: ',I3) - COB(1:4) = '99'//STNID(2:3) - IDATA(11) = IOB - NNNNN = 11 - IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4) - 196 FORMAT(5X,'IDATA(',I5,') STORED IN CHARACTER AS: "',A4,'"') - COB(1:4) = STNID(4:4)//' ' - IDATA(12) = IOB - NNNNN = 12 - IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4) - -cvvvvvdak port -C LOAD THE YEAR/MONTH (STORED AS CHARACTER IN FORM YYMM) -caaaaadak port - - M = 5 - IF(IPRINT.GT.1) PRINT 199, HDR(5),M - IYEAR = IMSG - IF(HDR(5).LT.XMSG) IYEAR = NINT(HDR(5)) - M = 6 - IF(IPRINT.GT.1) PRINT 199, HDR(6),M - IF(HDR(6).LT.XMSG.AND.IYEAR.LT.IMSG) THEN -cvvvvvdak port - IYEAR = MOD(IYEAR,100) -caaaaadak port - IYEAR = NINT(HDR(6)) + (IYEAR * 100) -cvvvvvdak port -cdak WRITE(COB,'(I6.6,2X)') IYEAR - WRITE(COB,'(I4.4,4X)') IYEAR -caaaaadak port - IDATA(5) = IOB - NNNNN = 5 - IF(IPRINT.GT.1) PRINT 9196, NNNNN,COB(1:6) - 9196 FORMAT(5X,'IDATA(',I5,') STORED IN CHARACTER AS: "',A6,'"') - ELSE - GO TO 30 - END IF - -C LOAD THE DAY/HOUR (STORED AS CHARACTER IN FORM DDHH) -C AND THE OBSERVATION TIME (STORED AS REAL) - - M = 7 - IF(IPRINT.GT.1) PRINT 199, HDR(7),M - IDAY = IMSG - IF(HDR(7).LT.XMSG) IDAY = NINT(HDR(7)) - M = 8 - IF(IPRINT.GT.1) PRINT 199, HDR(8),M - IF(HDR(8).LT.XMSG.AND.IDAY.LT.IMSG) THEN - IHRT = NINT(HDR(8)) - M = 9 - IF(IPRINT.GT.1) PRINT 199, HDR(9),M - IF(HDR(9).GE.XMSG) GO TO 30 - RMNT = HDR(9) - RDATX(4) = NINT((IHRT * 100.) + (RMNT * 100.)/60.) - NNNNN = 4 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) - IHRT = IHRT + (IDAY * 100) - WRITE(COB(1:4),'(I4.4)') IHRT - IDATA(6) = IOB - NNNNN = 6 - IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4) - ELSE - GO TO 30 - END IF - RDATA(1:1200) = RDATX(1:1200) - RETURN - 30 CONTINUE - IRET = 4 - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: UNPK7707 FILLS CAT. 4 INTO O-PUT ARRAY - VADW RPT -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1997-06-02 -C -C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN -C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE -C UPPER-AIR DATA FOR NEXRAD (VAD) WIND REPORT. UPPER-AIR DATA ARE -C THEN FILLED INTO THE OUTPUT ARRAY AS CATEGORY 4. THE OUPUT ARRAY -C HOLDS A SINGLE VAD WIND REPORT IN THE QUASI-OFFICE NOTE 29 -C UNPACKED FORMAT. -C -C PROGRAM HISTORY LOG: -C 1997-06-02 D. A. KEYSER NP22 - ORIGINAL AUTHOR -C -C USAGE: CALL UNPK7707(LUNIT,RDATA,IRET) -C INPUT ARGUMENT LIST: -C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE -C RDATA - SINGLE NEXRAD (VAD) REPORT IN A QUASI-OFFICE NOTE 29 -C - UNPACKED FORMAT WITH ONLY HEADER INFORMATION FILLED -C - IN (CATEGORY 4 DATA MISSING) -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C RDATA - SINGLE NEXRAD (VAD) REPORT IN A QUASI-OFFICE NOTE 29 -C - UNPACKED FORMAT WITH CATEGORY 4 INFORMATION FILLED IN -C - (ALL DATA FOR REPORT NOW FILLED) -C IRET - RETURN CODE AS DESCRIBED IN W3UNPK77 DOCBLOCK -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY SUBROUTINE W3UNPK77. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP, CRAY, SGI -C -C$$$ - SUBROUTINE UNPK7707(LUNIT,RDATA,IRET) - CHARACTER*1 CRMS(0:12) - CHARACTER*8 COB - CHARACTER*25 UAIR1 - INTEGER IDATA(1200) - REAL(8) UAIR_8(5,255) - REAL UAIR(5,255),RDATA(*),RDATX(1200) - COMMON /PK77BB/kdate(8),ldate(8),IPRINT - - SAVE - - EQUIVALENCE (RDATX,IDATA),(COB,IOB) - DATA XMSG/99999./ - DATA UAIR1/'HEIT WDIR WSPD RMSW QMWN '/ - DATA CRMS/' ','A',' ','B',' ','C',' ','D',' ','E',' ','F',' '/ - RDATX(1:1200) = RDATA(1:1200) - NSFC = 0 - ILVL = 0 - ILC = 0 -C FIRST CATEGORY 4 LEVEL UPPER-AIR LEVEL CONTAINS ONLY HEIGHT (ELEV) - IF(IPRINT.GT.1) PRINT 1078, ILC,ILVL - 1078 FORMAT(' ATTEMPTING 1ST (SFC) LVL WITH ILC =',I5,'; NO. LEVELS ', - $ 'PROCESSED TO NOW =',I5) - RDATX(43+ILC) = RDATX(7) - IF(IPRINT.GT.1) PRINT 198, 43+ILC,RDATX(43+ILC) - 198 FORMAT(5X,'RDATA(',I5,') STORED AS: ',F10.2) - IF(RDATX(43+ILC).LT.XMSG) NSFC = 1 -C NOTE: The following was added because of a problem on the sgi-ha -C platform related to equivalencing character and non-character -C -- for now the addition of these two lines will set the quality -C mark for sfc. cat . 4 level to the correct value of " " -C rather than to "9999" - Mary McCann notified SGI of this -C problem on 08-21-1998 - cob = ' ' - idata(43+ilc+3) = iob - ILVL = ILVL + 1 - ILC = ILC + 4 - IF(IPRINT.GT.1) PRINT *,'HAVE COMPLETED LEVEL ',ILVL,' WITH ', - $ 'NSFC=',NSFC,'; GOING INTO NEXT LEVEL WITH ILC=',ILC - UAIR_8 = 10.0E10 - CALL UFBINT(LUNIT,UAIR_8,5,255,NLEV,UAIR1);UAIR=UAIR_8 - IF(NLEV.EQ.0) THEN -C....................................................................... -C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO -- - IF(NSFC.EQ.0) THEN -C ... NO UPPER AIR DATA PROCESSED - PRINT 217 - 217 FORMAT(/' ##W3UNPK77: NO UPPER-AIR DATA PROCESSED FOR THIS', - $ ' REPORT -- NLEV = 0 AND NSFC = 0'/) - GO TO 99 - ELSE -C ... ONLY FIRST (SURFACE) UPPER AIR LEVEL DATA PROCESSED - PRINT 218 - 218 FORMAT(/' ##W3UNPK77: NO UPPER-AIR DATA ABOVE FIRST (SURFACE) ', - $ 'LEVEL PROCESSED FOR THIS REPORT -- NLEV = 0 AND NSFC > 0'/) - GO TO 98 - END IF -C....................................................................... - END IF - IF(IPRINT.GT.1) PRINT 1068, NLEV - 1068 FORMAT(' THIS REPORT CONTAINS ',I3,' LEVELS OF DATA (NOT ', - $ 'INCLUDING BOTTOM -SURFACE- LEVEL)') - DO I = 1,NLEV - IF(IPRINT.GT.1) PRINT 1079, ILC,ILVL - 1079 FORMAT(' ATTEMPTING NEW LEVEL WITH ILC =',I5,'; NO. LEVELS ', - $ 'PROCESSED TO NOW =',I5) - -C HEIGHT ABOVE SEA-LEVEL (STORED AS REAL) - - M = 1 - IF(IPRINT.GT.1) PRINT 199, UAIR(1,I),M - 199 FORMAT(5X,'UAIR HERE IS: ',F17.4,'; INDEX IS: ',I3) - IF(UAIR(1,I).LT.XMSG) THEN - RDATX(43+ILC) = NINT(UAIR(1,I)) - -C ... WE HAVE A VALID CATEGORY 4 LEVEL -- THERE IS A VALID HEIGHT - - ILVL = ILVL + 1 - ELSE - -C ... WE DO NOT HAVE A VALID CATEGORY 4 LEVEL -- THERE IS NO VALID -C HEIGHT GO ON TO NEXT INPUT LEVEL - - IF(IPRINT.GT.1) PRINT *, 'HEIGHT MISSING ON INPUT ', - $ ' LEVEL ',I,', ALL OTHER DATA SET TO MSG ON THIS LEVEL' - GO TO 10 - END IF - IF(IPRINT.GT.1) PRINT 198, 43+ILC,RDATX(43+ILC) - -C HORIZONTAL WIND DIRECTION (STORED AS REAL) - - M = 2 - IF(IPRINT.GT.1) PRINT 199, UAIR(2,I),M - IF(UAIR(2,I).LT.XMSG) RDATX(43+ILC+1) = NINT(UAIR(2,I)) - IF(IPRINT.GT.1) PRINT 198, 43+ILC+1,RDATX(43+ILC+1) - -C HORIZONTAL WIND SPEED (STORED AS REAL) (OUTPUT STORED -C AS METERS/SECOND TIMES TEN, NOT IN KNOTS AS ON29 WOULD -C INDICATE FOR CAT. 4 WIND SPEED) - - M = 3 - IF(IPRINT.GT.1) PRINT 199, UAIR(3,I),M - IF(UAIR(3,I).LT.XMSG) RDATX(43+ILC+2) =NINT(UAIR(3,I) * 10.) - IF(IPRINT.GT.1) PRINT 198, 43+ILC+2,RDATX(43+ILC+2) - -C CONFIDENCE LEVEL (BASED ON RMS VECTOR WIND ERROR) -C (NOTE: CONVERTED TO ORIGINAL LETTER INDICATOR AND PACKED -C IN BYTE 4 OF CATEGORY 4 QUALITY MARKER LOCATION -- SEE -C W3UNPK77 DOCBLOCK REMARKS 5. FOR UNPACKED VAD WIND REPORT -C LAYOUT FOR VALUES - - M = 4 - IF(IPRINT.GT.1) PRINT 199, UAIR(4,I),M - IF(UAIR(4,I).LT.XMSG) THEN - -C ... CONVERT FROM M/S TO KNOTS - -CDAKCDAK KRMS = INT(1.93333 * UAIR(4,I)) - KRMS = INT(1.9425 * UAIR(4,I)) - COB = ' ' - IF(KRMS.LT.13) THEN - COB(4:4) = CRMS(KRMS) - ELSE - COB(4:4) = 'G' - END IF - IDATA(43+ILC+3) = IOB - END IF - IF(IPRINT.GT.1) PRINT 196, 43+ILC+3,COB(1:4) - 196 FORMAT(5X,'IDATA(',I5,') STORED IN CHARACTER AS: "',A4,'"') - -C ON29 WIND QUALITY MARKER (CURRENTLY NOT STORED) - - M = 5 - IF(IPRINT.GT.1) PRINT 199, UAIR(5,I),M -C....................................................................... - ILC = ILC + 4 - IF(IPRINT.GT.1) PRINT *,'HAVE COMPLETED LEVEL ',ILVL, - $ '; GOING INTO NEXT LEVEL WITH ILC=',ILC - - 10 CONTINUE - ENDDO - -C SET CATEGORY COUNTERS FOR UPPER-AIR DATA - - 98 CONTINUE - IDATA(19) = ILVL - 99 CONTINUE - IF(IDATA(19).EQ.0) THEN - IDATA(20) = 0 - IRET = 5 - ELSE - IDATA(20) = 43 - END IF - IF(IPRINT.GT.1) PRINT *, 'NSFC=',NSFC,'; IDATA(37)=',IDATA(37), - $ '; IDATA(38)=',IDATA(38) - RDATA(1:1200) = RDATX(1:1200) - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: UNPK7708 FILLS IN HEADER IN O-PUT ARRAY - GOES SND -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1998-07-09 -C -C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN -C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE -C HEADER DATA FOR GOES SOUNDING REPORT. HEADER IS THEN FILLED INTO -C THE OUTPUT ARRAY WHICH HOLDS A SINGLE GOES SOUNDING REPORT IN THE -C QUASI-OFFICE NOTE 29 UNPACKED FORMAT. -C -C PROGRAM HISTORY LOG: -C 1997-06-05 D. A. KEYSER NP22 - ORIGINAL AUTHOR -C 1998-07-09 KEYSER -- CHANGED CHAR. 6 OF GOES STNID TO BE UNIQUE FOR -C TWO DIFFERENT EVEN OR ODD SATELLITE ID'S -C (EVERY OTHER EVEN OR ODD SAT. ID NOW GETS SAME -C CHAR. 6 TAG) -C -C USAGE: CALL UNPK7708(LUNIT,RDATA,KOUNT,IRET) -C INPUT ARGUMENT LIST: -C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE -C RDATA - SINGLE GOES SNDG REPORT IN A QUASI-OFFICE NOTE 29 -C - UNPACKED FORMAT WITH ALL DATA INITIALIZED AS MISSING -C KOUNT - NUMBER OF REPORTS PROCESSED INCLUDING THIS ONE -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C RDATA - SINGLE GOES SNDG REPORT IN A QUASI-OFFICE NOTE 29 -C - UNPACKED FORMAT WITH HEADER INFORMATION FILLED IN -C - (ALL OTHER DATA REMAINS MISSING) -C IRET - RETURN CODE AS DESCRIBED IN W3UNPK77 DOCBLOCK -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY SUBROUTINE W3UNPK77. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP, CRAY, SGI -C -C$$$ - SUBROUTINE UNPK7708(LUNIT,RDATA,KOUNT,IRET) - CHARACTER*1 C6TAG(3,0:3) - CHARACTER*8 STNID,COB - CHARACTER*35 HDR1,HDR2 - INTEGER IDATA(1200) - REAL(8) HDR_8(12) - REAL HDR(12),RDATA(*),RDATX(1200) - COMMON /PK77BB/kdate(8),ldate(8),IPRINT - COMMON /PK77FF/IFOV(3),KNTSAT(250:260) - - SAVE - - EQUIVALENCE (RDATX,IDATA),(COB,IOB) - DATA XMSG/99999./,IMSG/99999/ - DATA HDR1/'CLAT CLON ACAV GSDP QMRK SAID YEAR '/ - DATA HDR2/'MNTH DAYS HOUR MINU SECO '/ - - -C CURRENT LIST OF SATELLITE IDENTIFIERS (BUFR C.F. 0-01-007) -C ----------------------------------------------------------- - -C GOES 6 -- 250 GOES 9 -- 253 GOES 12 -- 256 -C GOES 7 -- 251 GOES 10 -- 254 GOES 13 -- 257 -C GOES 8 -- 252 GOES 11 -- 255 GOES 14 -- 258 - -C IDSAT = -- EVEN1 -- --- ODD1 -- -- EVEN2 -- --- ODD2 -- -C Sat. No. - 252,256,... 253,257,... 250,254,... 251,255,... -C IRTYP = CLR COR UNKN CLR COR UNKN CLR COR UNKN CLR COR UNKN -C --- --- ---- --- --- ---- --- --- ---- --- --- ---- - - DATA C6TAG/'I','J','?', 'L','M','?', 'O','P','?', 'Q','R','?' / - - RDATX(1:1200) = RDATA(1:1200) - HDR_8 = 10.0E10 - CALL UFBINT(LUNIT,HDR_8,12,1,NLEV,HDR1//HDR2);HDR=HDR_8 - IF(NLEV.NE.1) THEN -C....................................................................... -C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED -- -C SET IRET = 6 AND RETURN - PRINT 217, NLEV - 217 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',I5,') ', - $ 'IS NOT WHAT IS EXPECTED (1) - IRET = 6'/) - IRET = 6 - RETURN -C....................................................................... - END IF - -C LATITUDE (STORED AS REAL) - - M = 1 - IF(IPRINT.GT.1) PRINT 199, HDR(1),M - 199 FORMAT(5X,'HDR HERE IS: ',F17.4,'; INDEX IS: ',I3) - IF(HDR(1).LT.XMSG) THEN - RDATX(1) = NINT(HDR(1) * 100.) - NNNNN = 1 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) - 198 FORMAT(5X,'RDATA(',I5,') STORED AS: ',F10.2) - ELSE - IRET = 2 - PRINT 102 - 102 FORMAT(' *** W3UNPK77 ERROR: LAT MISSING FOR GOES SOUNDING'/) - RETURN - END IF - -C LONGITUDE (STORED AS REAL) - - M = 2 - IF(IPRINT.GT.1) PRINT 199, HDR(2),M - IF(HDR(2).LT.XMSG) THEN - RDATX(2) = NINT(MOD((36000.-(HDR(2)*100.)),36000.)) - NNNNN = 2 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) - ELSE - IRET = 2 - PRINT 104 - 104 FORMAT(' *** W3UNPK77 ERROR: LON MISSING FOR GOES SOUNDING'/) - RETURN - END IF - -C NUMBER OF FIELDS OF VIEW - SAMPLE SIZE (STORED AS INTEGER) - - M = 3 - IF(IPRINT.GT.1) PRINT 199, HDR(3),M - IF(HDR(3).LT.XMSG) IDATA(3) = NINT(HDR(3)) - NNNNN = 3 - IF(IPRINT.GT.1) PRINT 197, NNNNN,IDATA(NNNNN) - 197 FORMAT(5X,'IDATA(',I5,') STORED AS: ',I10) - -C STATION ELEVATION (FROM HEIGHT OF FIRST -SURFACE- LEVEL) -C (STORED AS REAL) -- STORED IN SUBROUTINE UNPK7709 - - -C RETRIEVAL TYPE (GEOSTATIONARY SATELLITE DATA-PROCESSING -C TECHNIQUE USED) (STORED AS INTEGER) - - M = 4 - IF(IPRINT.GT.1) PRINT 199, HDR(4),M - IF(HDR(4).LT.XMSG) IDATA(8) = NINT(HDR(4)) - IRTYP = 3 - IF(IDATA(8).EQ.21) THEN - IRTYP = 1 - ELSE IF(IDATA(8).EQ.23) THEN - IRTYP = 2 - END IF - NNNNN = 8 - IF(IPRINT.GT.1) PRINT 197, NNNNN,IDATA(NNNNN) - -C PRODUCT QUALITY BIT FLAGS - QUALITY INFO. (STORED AS INTEGER) - - M = 5 - IF(IPRINT.GT.1) PRINT 199, HDR(5),M - IF(HDR(5).LT.XMSG) IDATA(10) = NINT(HDR(5)) - NNNNN = 10 - IF(IPRINT.GT.1) PRINT 197, NNNNN,IDATA(NNNNN) - -C STATION IDENTIFICATION (STORED AS CHARACTER) -C (FIRST 5-CHARACTERS OBTAINED FROM 5-DIGIT COUNT NUMBER, -C 6'TH CHARACTER OBTAINED FROM SAT. ID/RETRIEVAL TYPE TAG) - - WRITE(STNID(1:5),'(I5.5)') MIN(KOUNT,99999) - -C DECODE THE SATELLITE ID - - M = 6 - IDSAT = 2 - IF(IPRINT.GT.1) PRINT 199, HDR(6),M - IF(HDR(6).LT.XMSG) THEN - IDSAT = MOD(NINT(HDR(6)),4) - IF(NINT(HDR(6)).GT.249.AND.NINT(HDR(6)).LT.260) THEN - KNTSAT(NINT(HDR(6))) = KNTSAT(NINT(HDR(6))) + 1 - ELSE - KNTSAT(260) = KNTSAT(260) + 1 - END IF - END IF - IF(IPRINT.GT.1) PRINT 2197, IDSAT,IRTYP - 2197 FORMAT(5X,'IDSAT IS: ',I10,', IRTYP IS: ',I10) - STNID(6:6) = C6TAG(IRTYP,IDSAT) - COB(1:4) = STNID(1:4) - IDATA(11) = IOB - NNNNN = 11 - IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4) - 196 FORMAT(5X,'IDATA(',I5,') STORED IN CHARACTER AS: "',A4,'"') - COB(1:4) = STNID(5:6)//' ' - IDATA(12) = IOB - NNNNN = 12 - IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4) - -cvvvvvdak port -C LOAD THE YEAR/MONTH (STORED AS CHARACTER IN FORM YYMM) -caaaaadak port - - M = 7 - IF(IPRINT.GT.1) PRINT 199, HDR(7),M - IYEAR = IMSG - IF(HDR(7).LT.XMSG) IYEAR = NINT(HDR(7)) - M = 8 - IF(IPRINT.GT.1) PRINT 199, HDR(8),M - IF(HDR(8).LT.XMSG.AND.IYEAR.LT.IMSG) THEN -cvvvvvdak port - IYEAR = MOD(IYEAR,100) -caaaaadak port - IYEAR = NINT(HDR(8)) + (IYEAR * 100) -cvvvvvdak port -cdak WRITE(COB,'(I6.6,2X)') IYEAR - WRITE(COB,'(I4.4,4X)') IYEAR -caaaaadak port - IDATA(5) = IOB - NNNNN = 5 - IF(IPRINT.GT.1) PRINT 9196, NNNNN,COB(1:6) - 9196 FORMAT(5X,'IDATA(',I5,') STORED IN CHARACTER AS: "',A6,'"') - ELSE - GO TO 30 - END IF - -C LOAD THE DAY/HOUR (STORED AS CHARACTER IN FORM DDHH) -C AND THE OBSERVATION TIME (STORED AS REAL) - - M = 9 - IF(IPRINT.GT.1) PRINT 199, HDR(9),M - M = 10 - IF(IPRINT.GT.1) PRINT 199, HDR(10),M - IF(HDR(10).LT.XMSG.AND.HDR(9).LT.IMSG) THEN - M = 11 - IF(IPRINT.GT.1) PRINT 199, HDR(11),M - IF(HDR(11).GE.XMSG) GO TO 30 - M = 12 - IF(IPRINT.GT.1) PRINT 199, HDR(12),M - IF(HDR(12).GE.XMSG) GO TO 30 - RDATX(4) = NINT(((HDR(10) + ((HDR(11) * 60.) + HDR(12))/3600.) - $ * 100.) + 0.0000000001) - NNNNN = 4 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) - IDAYHR = NINT(HDR(10)) + (NINT(HDR(9)) * 100) - WRITE(COB(1:4),'(I4.4)') IDAYHR - IDATA(6) = IOB - NNNNN = 6 - IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4) - ELSE - GO TO 30 - END IF - RDATA(1:1200) = RDATX(1:1200) - RETURN - 30 CONTINUE - IRET = 4 - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: UNPK7709 FILLS CAT. 12,8 TO O-PUT ARRAY -GOES SNDG -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1997-06-05 -C -C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN -C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE -C UPPER-AIR (SOUNDING) AND ADDITIONAL DATA FOR GOES SOUNDING. UPPER- -C AIR DATA ARE THEN FILLED INTO THE OUTPUT ARRAY AS CATEGORY 12 -C (SATELLITE SOUNDING) AND ADDITIONAL DATA ARE FILLED AS CATEGORY 8. -C THE OUPUT ARRAY HOLDS A SINGLE GOES SOUNDING IN THE QUASI-OFFICE -C NOTE 29 UNPACKED FORMAT. -C -C PROGRAM HISTORY LOG: -C 1997-06-05 D. A. KEYSER NP22 - ORIGINAL AUTHOR -C -C USAGE: CALL UNPK7709(LUNIT,RDATA,IRET) -C INPUT ARGUMENT LIST: -C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE -C RDATA - SINGLE GOES SNDG REPORT IN A QUASI-OFFICE NOTE 29 -C - UNPACKED FORMAT WITH ONLY HEADER INFORMATION FILLED -C - IN (CATEGORY 12 AND 8 DATA MISSING) -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C RDATA - SINGLE GOES SNDG REPORT IN A QUASI-OFFICE NOTE 29 -C - UNPACKED FORMAT WITH CATEGORY 12 AND 8 INFORMATION -C - FILLED IN (ALL DATA FOR REPORT NOW FILLED) -C IRET - RETURN CODE AS DESCRIBED IN W3UNPK77 DOCBLOCK -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY SUBROUTINE W3UNPK77. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP, CRAY, SGI -C -C$$$ - SUBROUTINE UNPK7709(LUNIT,RDATA,IRET) - CHARACTER*1 CQMFLG - CHARACTER*8 COB - CHARACTER*37 CAT8A,CAT8B - CHARACTER*48 UAIR1,RAD1 - INTEGER IDATA(1200),ICDFG(12) - REAL(8) UAIR_8(4,255),CAT8_8(12),RTCSF_8,RAD_8(2,255) - REAL UAIR(4,255),CAT8(12),RDATA(*),RDATX(1200),SC8(12),RAD(2,255) - COMMON /PK77BB/kdate(8),ldate(8),IPRINT - COMMON /PK77FF/IFOV(3),KNTSAT(250:260) - - SAVE - - EQUIVALENCE (RDATX,IDATA),(COB,IOB) - DATA XMSG/99999./,YMSG/99999.8/ - DATA UAIR1/'PRLC HGHT TMDB TMDP '/ - DATA RAD1 /'CHNM TMBR '/ - DATA CAT8A/'GLFTI PH2O PH2O19 PH2O97 PH2O73 TMSK '/ - DATA CAT8B/'GCDTT CDTP CLAM SIDU SOEL ELEV '/ - DATA ICDFG/ 50 , 51 , 52 , 53 , 54 , 55 , 56 ,57 ,58,59, 60 , 61 / - DATA SC8/100.,100.,100.,100.,100.,100.,100.,10.,1.,1.,100.,100./ - RDATX(1:1200) = RDATA(1:1200) - -C ALL NON-RADIANCE DATA WILL BE Q.C.'D ACCORDING TO NUMBER OF FIELDS-OF- -C VIEW FOR RETRIEVAL: 0-2 --> BAD, 3-9 --> SUSPECT, 10-25 OR MISSING -C --> NEUTRAL - - CQMFLG = ' ' - IF(IDATA(3).LT.3) THEN - CQMFLG = 'F' - IFOV(1) = IFOV(1) + 1 - ELSE IF(IDATA(3).LT.10.OR.IDATA(10).EQ.1) THEN - CQMFLG = 'Q' - IF(IDATA(3).LT.10) IFOV(2) = IFOV(2) + 1 - END IF - IF(IDATA(3).GT.9) IFOV(3) = IFOV(3) + 1 - -C*********************************************************************** -C FILL CATEGORY 12 PART OF OUTPUT -C*********************************************************************** - - ILVL = 0 - ILC = 0 - UAIR_8 = 10.0E10 - CALL UFBINT(LUNIT,UAIR_8,4,255,NLEV,UAIR1);UAIR=UAIR_8 - IF(NLEV.EQ.0) THEN -C....................................................................... -C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO -- - PRINT 217 - 217 FORMAT(/' ##W3UNPK77: NO UPPER-AIR (SOUNDING) DATA PROCESSED ', - $ 'FOR THIS REPORT -- NLEV = 0'/) - GO TO 98 - ELSE IF(NLEV.GT.50) THEN -C....................................................................... -C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS GREATER THAN LIMIT OF 50 -- - PRINT 218 - 218 FORMAT(/' ##W3UNPK77: NO UPPER-AIR (SOUNDING) DATA PROCESSED ', - $ 'FOR THIS REPORT -- NLEV > 50'/) - GO TO 98 -C....................................................................... - END IF - IF(IPRINT.GT.1) PRINT 1068, NLEV - 1068 FORMAT(' THIS REPORT CONTAINS',I4,' INPUT LEVELS OF SOUNDING ', - $ 'DATA') - DO I = 1,NLEV - IF(IPRINT.GT.1) PRINT 1079, I,ILC,ILVL - 1079 FORMAT(' ATTEMPTING NEW CAT. 12 INPUT LEVEL NUMBER',I4,' WITH ', - $ 'ILC =',I5,'; NO. LEVELS PROCESSED TO NOW =',I5) - -C LEVEL PRESSURE (STORED AS REAL) - - M = 1 - IF(IPRINT.GT.1) PRINT 199, UAIR(1,I),M - 199 FORMAT(5X,'UAIR HERE IS: ',F17.4,'; INDEX IS: ',I3) - IF(I.EQ.1) THEN - PSFC = UAIR(1,I) * 0.1 - ELSE IF(UAIR(1,I)*0.1.GE.YMSG) THEN -C WE DO NOT HAVE A VALID CATEGORY 12 LEVEL -- THERE IS NO VALID PRESSURE -C -- GO ON TO NEXT INPUT LEVEL (IF SFC LEVEL MSG, CONTINUE PROCESSING) - IF(IPRINT.GT.1) PRINT *, 'PRESSURE MISSING ON INPUT', - $ ' LEVEL ',I,', SKIP THE PROCESSING OF THIS LEVEL' - GO TO 10 - ELSE IF(UAIR(1,I)*0.1.GE.PSFC) THEN -C WE DO NOT HAVE A VALID CATEGORY 12 LEVEL -- THE INPUT LEVEL PRESSURE -C IS BELOW THE SURFACE PRESSURE -- GO ON TO THE NEXT INPUT LEVEL - IF(IPRINT.GT.1) PRINT *,'PRESSURE ON INPUT LEVEL ',I, - $ ' IS BELOW GROUND, SKIP THE PROCESSING OF THIS LEVEL' - GO TO 10 - END IF - -C WE HAVE A VALID CATEGORY 12 LEVEL -- THERE IS A VALID PRESSURE - - IF(UAIR(1,I)*0.1.LT.XMSG) RDATX(43+ILC) = NINT(UAIR(1,I)*0.1) - ILVL = ILVL + 1 - IF(IPRINT.GT.1) PRINT 198, 43+ILC,RDATX(43+ILC) - 198 FORMAT(5X,'RDATA(',I5,') STORED AS: ',F10.2) - -C GEOPOTENTIAL HEIGHT (STORED AS REAL) - - M = 2 - IF(IPRINT.GT.1) PRINT 199, UAIR(2,I),M - IF(UAIR(2,I).LT.XMSG) RDATX(43+ILC+1) = NINT(UAIR(2,I)) - IF(IPRINT.GT.1) PRINT 198, 43+ILC+1,RDATX(43+ILC+1) - IF(I.EQ.1) THEN - IF(IPRINT.GT.1) PRINT *, 'THIS IS SURFACE LEVEL, SO ', - $ 'STORE HEIGHT ALSO AS ELEVATION IN HEADER' - IF(UAIR(2,1).LT.XMSG) RDATX(7) = NINT(UAIR(2,1)) - NNNNN = 7 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) - END IF - -C TEMPERATURE (STORED AS REAL) - - M = 3 - IF(IPRINT.GT.1) PRINT 199, UAIR(3,I),M - ITMP = NINT(UAIR(3,I)*100.) - IF(UAIR(3,I).LT.XMSG) - $ RDATX(43+ILC+2) = NINT((ITMP - 27315) * 0.1) - IF(IPRINT.GT.1) PRINT 198, 43+ILC+2,RDATX(43+ILC+2) - -C DEWPOINT TEMPERATURE (STORED AS REAL) - - M = 4 - IF(IPRINT.GT.1) PRINT 199, UAIR(4,I),M - ITMP = NINT(UAIR(4,I)*100.) - IF(UAIR(4,I).LT.XMSG) - $ RDATX(43+ILC+3) = NINT((ITMP - 27315) * 0.1) - IF(IPRINT.GT.1) PRINT 198, 43+ILC+3,RDATX(43+ILC+3) - -C QUALITY MARKERS (STORED AS CHARACTER) - - COB = CQMFLG//CQMFLG//CQMFLG//' ' - IDATA(43+ILC+6) = IOB - IF(IPRINT.GT.1) PRINT 196, 43+ILC+6,COB(1:4) - 196 FORMAT(5X,'IDATA(',I5,') STORED IN CHARACTER AS: "',A4,'"') -C....................................................................... - ILC = ILC + 7 - IF(I+1.LE.NLEV.AND.IPRINT.GT.1) PRINT *,'HAVE COMPLETED ', - $ 'LEVEL ',ILVL,'; GOING INTO NEXT LEVEL WITH ILC=',ILC - - 10 CONTINUE - ENDDO - -C SET CATEGORY COUNTERS FOR CATEGORY 12 (SOUNDING) DATA - - IDATA(39) = ILVL - 98 CONTINUE - IF(IPRINT.GT.1) PRINT *, IDATA(39),' CAT. 12 LEVELS PROCESSED' - IF(IDATA(39).GT.0) IDATA(40) = 43 - -C*********************************************************************** -C FILL CATEGORY 8 PART OF OUTPUT -C WILL ATTEMPT TO FILL 12 "LEVELS" -C LVL 1- LIFTED INDEX (DEG. K X 100 - RELATIVE) -------- CODE FIG. 250. -C LVL 2- TOTAL COLUMN PRECIPITABLE WATER (MM X 100) ---- CODE FIG. 251. -C LVL 3- 1. TO .9 SIGMA LAYER PRECIP. WATER (MM X 100) - CODE FIG. 252. -C LVL 4- .9 TO .7 SIGMA LAYER PRECIP. WATER (MM X 100) - CODE FIG. 253. -C LVL 5- .7 TO .3 SIGMA LAYER PRECIP. WATER (MM X 100) - CODE FIG. 254. -C LVL 6- SKIN TEMPERATURE (DEG. K X 100) --------------- CODE FIG. 255. -C LVL 7- CLOUD TOP TEMPERATURE (DEG. K X 100) ---------- CODE FIG. 256. -C LVL 8- CLOUD TOP PRESSURE (MB X 10) ------------------ CODE FIG. 257. -C LVL 9- CLOUD AMOUNT (C. FIG. BUFR TABLE 0-20-011) ---- CODE FIG. 258. -C LVL 10- INSTR. DATA USED IN PROC. -C (C. FIG. BUFR TABLE 0-02-021) --- CODE FIG. 259. -C LVL 11- SOLAR ZENITH ANGLE (SOLAR ELEV) (DEG. X 100) -- CODE FIG. 260. -C LVL 12- SATELLITE ZENITH ANGLE (ELEV) (DEG. X 100) --- CODE FIG. 261. -C -C IF DATA ONE ANY LEVEL ARE MISSING, THAT LEVEL IS NOT PROCESSED -C*********************************************************************** - - ILVL = 0 - ILC = 0 - CAT8_8 = 10.0E10 - CALL UFBINT(LUNIT,CAT8_8,12,1,NLEV8,CAT8A//CAT8B);CAT8=CAT8_8 - IF(NLEV8.NE.1) THEN - IF(NLEV8.EQ.0) THEN -C....................................................................... -C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO -- - PRINT 318 - 318 FORMAT(/' ##W3UNPK77: NO ADDITIONAL (CAT. 8) DATA PROCESSED FOR ', - $ 'THIS REPORT -- NLEV8 = 0'/) - GO TO 99 -C....................................................................... - ELSE -C....................................................................... -C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED -- -C SET IRET = 7 AND RETURN - PRINT 219, NLEV8 - 219 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',I5,') ', - $ 'IS NOT WHAT IS EXPECTED (1) - IRET = 7'/) - IRET = 7 - RETURN -C....................................................................... - END IF - END IF - -C THE TEMPERATURE CHANNEL SELECTION FLAG WILL BE USED LATER TO -C DETERMINE Q. MARK FOR SKIN TEMPERATURE (IF 0 - OK, OTHERWISE - BAD) - - RTCSF_8 = 10.0E10 - CALL UFBINT(LUNIT,RTCSF_8,1,1,NLEV0,'TCSF');RTCSF=RTCSF_8 - ITCSF = 1 - M = 1 - IF(IPRINT.GT.1) PRINT 299, RTCSF,M - 299 FORMAT(5X,'RTCSF HERE IS: ',F17.4,'; INDEX IS: ',I3) - IF(RTCSF.LT.XMSG) ITCSF = NINT(RTCSF) - IF(IPRINT.GT.1) PRINT 1798, ITCSF - 1798 FORMAT(5X,'ITCSF IS: ',I10) - -C LOOP THROUGH THE 12 POSSIBLE ADDITIONAL DATA - - DO M = 1,12 - IF(IPRINT.GT.1) PRINT 6079, M,ILC,ILVL - 6079 FORMAT(' ATTEMPTING MISCEL. INPUT',I5,' WITH ILC =',I5,'; NO. ', - $ 'OUTPUT CAT. 8 LVLS PROCESSED TO NOW =',I5) - IF(IPRINT.GT.1) PRINT 399, CAT8(M),M - 399 FORMAT(5X,'CAT8 HERE IS: ',F17.4,'; INDEX IS: ',I3) - IF(CAT8(M).LT.XMSG) THEN - -C WE HAVE A VALID CATEGORY 8 "LEVEL" - - ILVL = ILVL + 1 - -C STORE THE DATUM IN WORD 1 OF THE CAT. 8 LEVEL - - RDATX(393+ILC) = NINT(CAT8(M) * SC8(M)) - IF(IPRINT.GT.1) PRINT 198, 393+ILC,RDATX(393+ILC) - -C STORE THE CAT. 8 CODE FIGURE IN WORD 2 OF THE CAT. 8 LEVEL - - RDATX(393+ILC+1) = REAL(200+ICDFG(M)) - IF(IPRINT.GT.1) PRINT 198, 393+ILC+1,RDATX(393+ILC+1) - -C STORE THE QUALITY MARKER IN BYTE 1 OF WORD 3 OF THE CAT. 8 LEVEL - - COB = CQMFLG//' ' - -C IF THIS DATUM IS SKIN TEMPERATURE AND THE TEMPERATURE CHANNEL -C SELECTION FLAG IS BAD (.NE. 0), SET QUALITY MARKER TO "F" - - IF(M.EQ.6.AND.ITCSF.NE.0) COB(1:1) = 'F' - IDATA(393+ILC+2) = IOB - IF(IPRINT.GT.1) PRINT 196, 393+ILC+2,COB(1:4) - ILC = ILC + 3 - IF(M.LT.12.AND.IPRINT.GT.1) PRINT *,'HAVE COMPLETED OUTPUT', - $ ' LVL',ILVL,'; GOING INTO NEXT INPUT DATUM WITH ILC=',ILC - ELSE - IF(IPRINT.GT.1) PRINT *, 'DATUM MISSING ON INPUT ',M, - $ ', GO ON TO NEXT INPUT DATUM (NO. LVLS PROCESSED SO ', - $ 'FAR=',ILVL,'; ILC=',ILC,')' - END IF - ENDDO - -C SET CATEGORY COUNTERS FOR CATEGORY 8 (ADDITIONAL) DATA - - IDATA(27) = ILVL - 99 CONTINUE - IF(IPRINT.GT.1) PRINT *, IDATA(27),' CAT. 08 LEVELS PROCESSED' - IF(IDATA(27).GT.0) IDATA(28) = 393 - -C*********************************************************************** -C FILL CATEGORY 13 PART OF OUTPUT (RADIANCES) -C*********************************************************************** - - ILVL = 0 - ILC = 0 - RAD_8 = 10.0E10 - CALL UFBINT(LUNIT,RAD_8,2,255,NLEV13,RAD1);RAD=RAD_8 - IF(NLEV13.EQ.0) THEN -C....................................................................... -C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO -- - PRINT 417 - 417 FORMAT(/' ##W3UNPK77: NO RADIANCE DATA PROCESSED FOR THIS ', - $ 'REPORT -- NLEV13 = 0'/) - GO TO 100 - ELSE IF(NLEV13.GT.60) THEN -C....................................................................... -C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS GREATER THAN LIMIT OF 60 -- - PRINT 418 - 418 FORMAT(/' ##W3UNPK77: NO RADIANCE DATA PROCESSED FOR THIS ', - $ 'REPORT -- NLEV13 > 60'/) - GO TO 100 -C....................................................................... - END IF - IF(IPRINT.GT.1) PRINT 2068, NLEV13 - 2068 FORMAT(' THIS REPORT CONTAINS',I4,' INPUT LEVELS (CHANNELS) OF ', - $ 'RADIANCE DATA') - DO I = 1,NLEV13 - IF(IPRINT.GT.1) PRINT 2079, I,ILC,ILVL - 2079 FORMAT(' ATTEMPTING NEW CAT. 13 INPUT "LEVEL" NUMBER',I4,' WITH ', - $ 'ILC =',I5,'; NO. LEVELS (CHANNELS) PROCESSED TO NOW =',I5) - -C CHANNEL NUMBER (STORED AS INTEGER) - - M = 1 - IF(IPRINT.GT.1) PRINT 499, RAD(1,I),M - 499 FORMAT(5X,'RAD HERE IS: ',F17.4,'; INDEX IS: ',I3) - IF(RAD(1,I).GE.YMSG) THEN -C WE DO NOT HAVE A VALID CATEGORY 13 LEVEL -- THERE IS NO VALID CHANNEL -C NUMBER -- GO ON TO NEXT INPUT LEVEL - IF(IPRINT.GT.1) PRINT *, 'CHANNEL NUMBER MISSING ON INPUT', - $ ' LEVEL ',I,', SKIP THE PROCESSING OF THIS LEVEL' - GO TO 210 - END IF - -C WE HAVE A VALID CATEGORY 13 LEVEL -- THERE IS A VALID CHANNEL NUMBER - - IDATA(429+ILC) = NINT(RAD(1,I)) - ILVL = ILVL + 1 - IF(IPRINT.GT.1) PRINT 197, 429+ILC,IDATA(429+ILC) - 197 FORMAT(5X,'IDATA(',I5,') STORED AS: ',I10) - -C BRIGHTNESS TEMPERATURE (STORED AS REAL) - - M = 2 - IF(IPRINT.GT.1) PRINT 499, RAD(2,I),M - IF(RAD(2,I).LT.XMSG) RDATX(429+ILC+1) = NINT(RAD(2,I) * 100.) - IF(IPRINT.GT.1) PRINT 198, 429+ILC+1,RDATX(429+ILC+1) - -C QUALITY MARKERS (STORED AS CHARACTER) - - COB = ' ' - IDATA(429+ILC+2) = IOB - IF(IPRINT.GT.1) PRINT 196, 429+ILC+2,COB(1:4) -C....................................................................... - ILC = ILC + 3 - IF(I+1.LE.NLEV13.AND.IPRINT.GT.1) PRINT *,'HAVE COMPLETED ', - $ 'LEVEL ',ILVL,'; GOING INTO NEXT LEVEL WITH ILC=',ILC - - 210 CONTINUE - ENDDO - -C SET CATEGORY COUNTERS FOR CATEGORY 13 (RADIANCE) DATA - - IDATA(41) = ILVL - 100 CONTINUE - IF(IPRINT.GT.1) PRINT *, IDATA(41),' CAT. 13 LEVELS PROCESSED' - IF(IDATA(41).GT.0) IDATA(42) = 429 - - IF(IDATA(27)+IDATA(39)+IDATA(41).EQ.0) IRET = 5 - - IF(IPRINT.GT.1) PRINT *,'IDATA(39)=',IDATA(39),'; IDATA(40)=', - $ IDATA(40),'; IDATA(27)=',IDATA(27),'; IDATA(28)=',IDATA(28), - $ '; IDATA(41)=',IDATA(41),'; IDATA(42)=',IDATA(42) - - RDATA(1:1200) = RDATX(1:1200) - RETURN - END diff --git a/src/fim/FIMsrc/w3/w3utcdat.f b/src/fim/FIMsrc/w3/w3utcdat.f deleted file mode 100644 index 600f573..0000000 --- a/src/fim/FIMsrc/w3/w3utcdat.f +++ /dev/null @@ -1,67 +0,0 @@ -!----------------------------------------------------------------------- - subroutine w3utcdat(idat) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: W3UTCDAT RETURN THE UTC DATE AND TIME -! AUTHOR: MARK IREDELL ORG: WP23 DATE: 98-01-05 -! -! ABSTRACT: THIS SUBPROGRAM RETURNS THE UTC (GREENWICH) DATE AND TIME -! IN THE NCEP ABSOLUTE DATE AND TIME DATA STRUCTURE. -! -! PROGRAM HISTORY LOG: -! 98-01-05 MARK IREDELL -! 1999-04-28 Gilbert - added a patch to check for the proper -! UTC offset. Needed until the IBM bug -! in date_and_time is fixed. The patch -! can then be removed. See comments in -! the section blocked with "&&&&&&&&&&&". -! 1999-08-12 Gilbert - Changed so that czone variable is saved -! and the system call is only done for -! first invocation of this routine. -! -! USAGE: CALL W3UTCDAT(IDAT) -! -! OUTPUT VARIABLES: -! IDAT INTEGER (8) NCEP ABSOLUTE DATE AND TIME -! (YEAR, MONTH, DAY, TIME ZONE, -! HOUR, MINUTE, SECOND, MILLISECOND) -! -! SUBPROGRAMS CALLED: -! DATE_AND_TIME FORTRAN 90 SYSTEM DATE INTRINSIC -! IW3JDN COMPUTE JULIAN DAY NUMBER -! W3FS26 YEAR, MONTH, DAY FROM JULIAN DAY NUMBER -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! -!$$$ - integer idat(8) - character cdate*8,ctime*10,czone*5 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! get local date and time but use the character time zone - call date_and_time(cdate,ctime,czone,idat) - read(czone,'(i5)') idat(4) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! convert to hours and minutes to UTC time -! and possibly adjust the date as well - idat(6)=idat(6)-mod(idat(4),100) - idat(5)=idat(5)-idat(4)/100 - idat(4)=0 - if(idat(6).lt.00) then - idat(6)=idat(6)+60 - idat(5)=idat(5)-1 - elseif(idat(6).ge.60) then - idat(6)=idat(6)-60 - idat(5)=idat(5)+1 - endif - if(idat(5).lt.00) then - idat(5)=idat(5)+24 - jldayn=iw3jdn(idat(1),idat(2),idat(3))-1 - call w3fs26(jldayn,idat(1),idat(2),idat(3),idaywk,idayyr) - elseif(idat(5).ge.24) then - idat(5)=idat(5)-24 - jldayn=iw3jdn(idat(1),idat(2),idat(3))+1 - call w3fs26(jldayn,idat(1),idat(2),idat(3),idaywk,idayyr) - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end diff --git a/src/fim/FIMsrc/w3/w3valdat.f b/src/fim/FIMsrc/w3/w3valdat.f deleted file mode 100644 index 6fa99f3..0000000 --- a/src/fim/FIMsrc/w3/w3valdat.f +++ /dev/null @@ -1,50 +0,0 @@ -!----------------------------------------------------------------------- - logical function w3valdat(idat) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: W3VALDAT DETERMINE THE VALIDITY OF A DATE AND TIME -! AUTHOR: MARK IREDELL ORG: WP23 DATE: 98-01-05 -! -! ABSTRACT: THIS LOGICAL FUNCTION RETURNS TRUE IF THE INPUT IS A VALID -! NCEP ABSOLUTE DATE AND TIME. -! -! PROGRAM HISTORY LOG: -! 98-01-05 MARK IREDELL -! -! USAGE: ...=W3VALDAT(IDAT) -! -! INPUT VARIABLES: -! IDAT INTEGER (8) NCEP ABSOLUTE DATE AND TIME -! (YEAR, MONTH, DAY, TIME ZONE, -! HOUR, MINUTE, SECOND, MILLISECOND) -! -! OUTPUT VARIABLES: -! W3VALDAT LOGICAL TRUE IF IDAT IS A VALID NCEP DATE AND TIME -! -! SUBPROGRAMS CALLED: -! IW3JDN COMPUTE JULIAN DAY NUMBER -! W3FS26 YEAR, MONTH, DAY FROM JULIAN DAY NUMBER -! W3REDDAT REDUCE A TIME INTERVAL TO A CANONICAL FORM -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! -!$$$ - integer idat(8) - real rinc1(5),rinc2(5) - integer jdat(8) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! essentially move the date and time by a zero time interval -! and see if the same date and time is returned - rinc1(1)=0 - rinc1(2:5)=idat(5:8) - call w3reddat(-1,rinc1,rinc2) - jldayn=iw3jdn(idat(1),idat(2),idat(3))+nint(rinc2(1)) - call w3fs26(jldayn,jdat(1),jdat(2),jdat(3),jdow,jdoy) -! the time zone is valid if it is in signed hhmm format -! with hh between -23 and 23 and mm equal to 00 or 30 - jdat(4)=mod(idat(4)/100,24)*100+mod(mod(idat(4),100),60)/30*30 - jdat(5:8)=nint(rinc2(2:5)) - w3valdat=all(idat.eq.jdat) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end diff --git a/src/fim/FIMsrc/w3/w3ymdh4.f b/src/fim/FIMsrc/w3/w3ymdh4.f deleted file mode 100644 index 44a0f78..0000000 --- a/src/fim/FIMsrc/w3/w3ymdh4.f +++ /dev/null @@ -1,119 +0,0 @@ - SUBROUTINE W3YMDH4 (IDATE,IYEAR,MONTH,IDAY,IHOUR,NN) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3YMDH4 4-BYTE DATE WORD UNPACKER AND PACKER -C AUTHOR: Brill,K.F. ORG: NP/22 DATE: 98-07-29 -C -C ABSTRACT: OBTAINS THE COMPONENTS OF THE NMC DATE WORD (NCEP Y2K -C COMPLIANT FORM), OR GIVEN ITS COMPONENTS, FORMS AN NMC TYPE DATE -C WORD. THE PACKING IS DONE USING BASE 32. -C -C If the first byte of IDATE is less than 101, then the old -C Office Note 84 packing is assumed. A four-digit year is -C always returned. To pack the "old" way, pass in a 2-digit -C year. -C -C This program will work for the years ranging from A.D. 101 -C through 79359. -C -C On unpacking, years less than or equal to 100 are returned -C as follows: -C -C 0-50 2000--2050 -C 51-100 1951--2000 -C -C -C PROGRAM HISTORY LOG: -C 98-07-29 K.F.BRILL -C 1999-03-15 Gilbert - Removed Call to W3FS11 and put its -C processing inline. W3FS11 was deleted -C from the W3LIB. -C -C USAGE: CALL W3YMDH4 (IDATE, IYEAR, MONTH, IDAY, IHOUR, NN) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C IDATE ARG LIST LEFT 4 BYTES OF INTEGER 64 BIT WORD, OR CAN BE -C CHARACTER*1 IDATE(4) OR CHARACTER*4 IDATE. -C IYEAR ARG LIST INTEGER YEAR (4 DIGITS or 2 DIGITS for ON84) -C MONTH ARG LIST INTEGER MONTH -C IDAY ARG LIST INTEGER DAY -C IHOUR ARG LIST INTEGER HOUR -C NN ARG LIST INTEGER CODE: -C .EQ. 0 PACK IYEAR, MONTH, IDAY, IHOUR INTO IDATE -C .NE. 0 UNPACK IDATE INTO IYEAR, MONTH, IDAY, IHOUR -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C IDATE ARG LIST LEFT 4 BYTES OF INTEGER 64 BIT WORD, OR CAN BE -C CHARACTER*1 IDATE(4) OR CHARACTER*4 IDATE. -C IYEAR ARG LIST INTEGER YEAR (4 DIGITS) -C MONTH ARG LIST INTEGER MONTH -C IDAY ARG LIST INTEGER DAY -C IHOUR ARG LIST INTEGER HOUR -C -C SUBROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C CHAR F90 -C MOVA2I W3 -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT90 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - CHARACTER IDATE(4) -C - IF (NN.NE.0) THEN -C - ITEMP = MOVA2I(IDATE(1)) - IF ( ITEMP .lt. 101 ) THEN - IYEAR = MOVA2I(IDATE(1)) - MONTH = MOVA2I(IDATE(2)) - IDAY = MOVA2I(IDATE(3)) - IHOUR = MOVA2I(IDATE(4)) - IF(IYEAR.LE.100) IYEAR=2050-MOD(2050-IYEAR,100) - RETURN - END IF - ITEMP = ITEMP - 101 - ITEMP = ITEMP * 256 + MOVA2I(IDATE(2)) - ITEMP = ITEMP * 256 + MOVA2I(IDATE(3)) - ITEMP = ITEMP * 256 + MOVA2I(IDATE(4)) - IHOUR = MOD ( ITEMP, 32 ) - ITEMP = ITEMP / 32 - IDAY = MOD ( ITEMP, 32 ) - ITEMP = ITEMP / 32 - MONTH = MOD ( ITEMP, 32 ) - IYEAR = ITEMP / 32 -C - ELSE -C - ITEMP = IYEAR - IF ( ITEMP .lt. 101 ) THEN - IDATE(1) = CHAR(IYEAR) - IDATE(2) = CHAR(MONTH) - IDATE(3) = CHAR(IDAY) - IDATE(4) = CHAR(IHOUR) - RETURN - END IF - ITEMP = ITEMP * 32 + MONTH - ITEMP = ITEMP * 32 + IDAY - ITEMP = ITEMP * 32 + IHOUR -C* - IDATE(4)=CHAR(MOD(ITEMP,256)) - ITEMP = ITEMP / 256 - IDATE(3)=CHAR(MOD(ITEMP,256)) - ITEMP = ITEMP / 256 - IDATE(2)=CHAR(MOD(ITEMP,256)) - ITEMP = ITEMP / 256 - ITEMP = ITEMP + 101 - IDATE(1)=CHAR(ITEMP) -C - ENDIF -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/xdopen.f b/src/fim/FIMsrc/w3/xdopen.f deleted file mode 100644 index 9726e8e..0000000 --- a/src/fim/FIMsrc/w3/xdopen.f +++ /dev/null @@ -1,59 +0,0 @@ - SUBROUTINE XDOPEN -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: XDOPEN DUMMY SUBROUTINE -C PRGMMR: KEYSER ORG: W/NMC22 DATE: 07-02-92 -C -C ABSTRACT: THIS SUBROUTINE AND THE CORRESPONDING ENTRIES: "ERRSET", -C "XDCHEK", "XDCLOS", "XDWRIT", "XDREAD", AND "XDFORM" ARE PLACED -C HERE TO ALLOW CALLING ROUTINES WHICH RESIDE ON BOTH THE NAS AND -C THE CRAY TO COMPILE. THESE SUBROUTINES PERFORM NAS-SPECIFIC -C FUNCTIONS, BUT HAVE NO CORRESPONDING FUNCTION ON THE CRAY. THERE- -C FORE THIS SUBROUTINE IS A "DUMMY". FT06 PRINT IS PROVIDED TO -C ALERT THE USER THAT THE CALL TO THE SUBROUTINE RESULTS IN AN -C IMMEDIATE RETURN WITH NO FUNCTION. -C -C PROGRAM HISTORY LOG: -C 92-07-02 D. A. KEYSER (W/NMC22) -C -C USAGE: CALL XDOPEN -C -C REMARKS: NONE. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - CHARACTER*6 ROUTIN(7) -C - DATA ROUTIN/'XDOPEN','ERRSET','XDCHEK','XDCLOS','XDWRIT', - $ 'XDREAD','XDFORM'/ -C - ICALL = 1 - GO TO 99 - ENTRY ERRSET - ICALL = 2 - GO TO 99 - ENTRY XDCHEK - ICALL = 3 - GO TO 99 - ENTRY XDCLOS - ICALL = 4 - GO TO 99 - ENTRY XDWRIT - ICALL = 5 - GO TO 99 - ENTRY XDREAD - ICALL = 6 - GO TO 99 - ENTRY XDFORM - ICALL = 7 - 99 CONTINUE - PRINT 1, ROUTIN(ICALL) - 1 FORMAT(/2X,'%%%% SUBR. ',A6,' HAS NO FCN ON THE CRAY, BUT IS ', - $ 'PROVIDED TO ALLOW CODES TO COMPILE ON THE NAS & CRAY; RETURN ', - $ 'TO CALLING PGM'//) - RETURN - END diff --git a/src/fim/FIMsrc/w3/xmovex.f b/src/fim/FIMsrc/w3/xmovex.f deleted file mode 100644 index 9763d26..0000000 --- a/src/fim/FIMsrc/w3/xmovex.f +++ /dev/null @@ -1,19 +0,0 @@ - SUBROUTINE XMOVEX(OUT,IN,IBYTES) -C -C THIS SUBROUTINE MAY NOT BE NEEDED, ITS WAS IN -C ASSEMBLER LANGUAGE TO MOVE DATA, IT RAN ABOUT THREE -C TIMES FASTER THAN A FORTAN DO LOOP, IT WAS USED TO -C MAKE SURE THE DATA TO BE UNPACKED WAS ON A WORD BOUNDARY, -C THIS MAY NOT BE NEEDED ON SOME BRANDS OF COMPUTERS. -C - CHARACTER*1 OUT(*) - CHARACTER*1 IN(*) -C - INTEGER IBYTES -C - DO 100 I = 1,IBYTES - OUT(I) = IN(I) - 100 CONTINUE -C - RETURN - END diff --git a/src/fim/FIMsrc/w3/xstore.f b/src/fim/FIMsrc/w3/xstore.f deleted file mode 100644 index a23b1f8..0000000 --- a/src/fim/FIMsrc/w3/xstore.f +++ /dev/null @@ -1,44 +0,0 @@ - SUBROUTINE XSTORE(COUT,CON,MWORDS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: XSTORE STORES A CONSTANT VALUE INTO AN ARRAY -C PRGMMR: KEYSER ORG: W/NMC22 DATE: 07-02-92 -C -C ABSTRACT: STORES AN 8-BYTE (FULLWORD) VALUE THROUGH CONSECUTIVE -C STORAGE LOCATIONS. (MOVING IS ACCOMPLISHED WITH A DO LOOP.) -C -C PROGRAM HISTORY LOG: -C 92-07-02 D. A. KEYSER (W/NMC22) -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C -C USAGE: CALL XSTORE(COUT,CON,MWORDS) -C INPUT ARGUMENT LIST: -C CON - CONSTANT TO BE STORED INTO "MWORDS" CONSECUTIVE -C FULLWORDS BEGINNING WITH "COUT" ARRAY -C MWORDS - NUMBER OF FULLWORDS IN "COUT" ARRAY TO STORE "CON"; -C MUST BE .GT. ZERO (NOT CHECKED FOR THIS) -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C COUT - STARTING ADDRESS FOR ARRAY OF "MWORDS" FULLWORDS -C SET TO THE CONTENTS OF THE VALUE "CON" -C -C REMARKS: THE VERSION OF THIS SUBROUTINE ON THE HDS COMMON LIBRARY -C IS NAS-SPECIFIC SUBR. WRITTEN IN ASSEMBLY LANG. TO ALLOW FAST -C COMPUTATION TIME. SUBR. PLACED IN CRAY W3LIB TO ALLOW CODES TO -C COMPILE ON BOTH THE HDS AND CRAY MACHINES. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/864 -C -C$$$ -C - DIMENSION COUT(*) -C - DO 1000 I = 1,MWORDS - COUT(I) = CON -1000 CONTINUE -C - RETURN - END diff --git a/src/fim/Makefile.am b/src/fim/Makefile.am deleted file mode 100644 index fe97263..0000000 --- a/src/fim/Makefile.am +++ /dev/null @@ -1,14 +0,0 @@ -noinst_LIBRARIES = libfim.a - -libfim_a_SOURCES = fim_grid_comp_stub.F90 - -libfim_a_FCFLAGS = - -.PHONY: clean-modules - -clean-modules: - -test -z "$(FC_MODEXT)" || rm -f *.$(FC_MODEXT) - -clean-local: clean-modules - -# dependencies diff --git a/src/fim/Makefile.in b/src/fim/Makefile.in deleted file mode 100644 index 233a307..0000000 --- a/src/fim/Makefile.in +++ /dev/null @@ -1,589 +0,0 @@ -# Makefile.in generated by automake 1.13.4 from Makefile.am. -# @configure_input@ - -# Copyright (C) 1994-2013 Free Software Foundation, Inc. - -# This Makefile.in is free software; the Free Software Foundation -# gives unlimited permission to copy and/or distribute it, -# with or without modifications, as long as this notice is preserved. - -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY, to the extent permitted by law; without -# even the implied warranty of MERCHANTABILITY or FITNESS FOR A -# PARTICULAR PURPOSE. - -@SET_MAKE@ - -VPATH = @srcdir@ -am__is_gnu_make = test -n '$(MAKEFILE_LIST)' && test -n '$(MAKELEVEL)' -am__make_running_with_option = \ - case $${target_option-} in \ - ?) ;; \ - *) echo "am__make_running_with_option: internal error: invalid" \ - "target option '$${target_option-}' specified" >&2; \ - exit 1;; \ - esac; \ - has_opt=no; \ - sane_makeflags=$$MAKEFLAGS; \ - if $(am__is_gnu_make); then \ - sane_makeflags=$$MFLAGS; \ - else \ - case $$MAKEFLAGS in \ - *\\[\ \ ]*) \ - bs=\\; \ - sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \ - | sed "s/$$bs$$bs[$$bs $$bs ]*//g"`;; \ - esac; \ - fi; \ - skip_next=no; \ - strip_trailopt () \ - { \ - flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \ - }; \ - for flg in $$sane_makeflags; do \ - test $$skip_next = yes && { skip_next=no; continue; }; \ - case $$flg in \ - *=*|--*) continue;; \ - -*I) strip_trailopt 'I'; skip_next=yes;; \ - -*I?*) strip_trailopt 'I';; \ - -*O) strip_trailopt 'O'; skip_next=yes;; \ - -*O?*) strip_trailopt 'O';; \ - -*l) strip_trailopt 'l'; skip_next=yes;; \ - -*l?*) strip_trailopt 'l';; \ - -[dEDm]) skip_next=yes;; \ - -[JT]) skip_next=yes;; \ - esac; \ - case $$flg in \ - *$$target_option*) has_opt=yes; break;; \ - esac; \ - done; \ - test $$has_opt = yes -am__make_dryrun = (target_option=n; $(am__make_running_with_option)) -am__make_keepgoing = (target_option=k; $(am__make_running_with_option)) -pkgdatadir = $(datadir)/@PACKAGE@ -pkgincludedir = $(includedir)/@PACKAGE@ -pkglibdir = $(libdir)/@PACKAGE@ -pkglibexecdir = $(libexecdir)/@PACKAGE@ -am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd -install_sh_DATA = $(install_sh) -c -m 644 -install_sh_PROGRAM = $(install_sh) -c -install_sh_SCRIPT = $(install_sh) -c -INSTALL_HEADER = $(INSTALL_DATA) -transform = $(program_transform_name) -NORMAL_INSTALL = : -PRE_INSTALL = : -POST_INSTALL = : -NORMAL_UNINSTALL = : -PRE_UNINSTALL = : -POST_UNINSTALL = : -build_triplet = @build@ -host_triplet = @host@ -subdir = src/fim -DIST_COMMON = $(srcdir)/Makefile.in $(srcdir)/Makefile.am -ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 -am__aclocal_m4_deps = $(top_srcdir)/m4/ax_blas.m4 \ - $(top_srcdir)/m4/ax_check_compile_flags.m4 \ - $(top_srcdir)/m4/ax_compiler_vendor.m4 \ - $(top_srcdir)/m4/ax_fortran_utils.m4 \ - $(top_srcdir)/m4/ax_lib_comio.m4 \ - $(top_srcdir)/m4/ax_lib_esmf.m4 \ - $(top_srcdir)/m4/ax_lib_nemsio.m4 \ - $(top_srcdir)/m4/ax_lib_netcdf4.m4 $(top_srcdir)/configure.ac -am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ - $(ACLOCAL_M4) -mkinstalldirs = $(install_sh) -d -CONFIG_CLEAN_FILES = -CONFIG_CLEAN_VPATH_FILES = -LIBRARIES = $(noinst_LIBRARIES) -ARFLAGS = cru -AM_V_AR = $(am__v_AR_@AM_V@) -am__v_AR_ = $(am__v_AR_@AM_DEFAULT_V@) -am__v_AR_0 = @echo " AR " $@; -am__v_AR_1 = -libfim_a_AR = $(AR) $(ARFLAGS) -libfim_a_LIBADD = -am_libfim_a_OBJECTS = libfim_a-fim_grid_comp_stub.$(OBJEXT) -libfim_a_OBJECTS = $(am_libfim_a_OBJECTS) -AM_V_P = $(am__v_P_@AM_V@) -am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) -am__v_P_0 = false -am__v_P_1 = : -AM_V_GEN = $(am__v_GEN_@AM_V@) -am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@) -am__v_GEN_0 = @echo " GEN " $@; -am__v_GEN_1 = -AM_V_at = $(am__v_at_@AM_V@) -am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) -am__v_at_0 = @ -am__v_at_1 = -DEFAULT_INCLUDES = -I.@am__isrc@ -AM_V_lt = $(am__v_lt_@AM_V@) -am__v_lt_ = $(am__v_lt_@AM_DEFAULT_V@) -am__v_lt_0 = --silent -am__v_lt_1 = -PPFCCOMPILE = $(FC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) \ - $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_FCFLAGS) $(FCFLAGS) -AM_V_PPFC = $(am__v_PPFC_@AM_V@) -am__v_PPFC_ = $(am__v_PPFC_@AM_DEFAULT_V@) -am__v_PPFC_0 = @echo " PPFC " $@; -am__v_PPFC_1 = -FCLD = $(FC) -FCLINK = $(FCLD) $(AM_FCFLAGS) $(FCFLAGS) $(AM_LDFLAGS) $(LDFLAGS) -o \ - $@ -AM_V_FCLD = $(am__v_FCLD_@AM_V@) -am__v_FCLD_ = $(am__v_FCLD_@AM_DEFAULT_V@) -am__v_FCLD_0 = @echo " FCLD " $@; -am__v_FCLD_1 = -SOURCES = $(libfim_a_SOURCES) -DIST_SOURCES = $(libfim_a_SOURCES) -am__can_run_installinfo = \ - case $$AM_UPDATE_INFO_DIR in \ - n|no|NO) false;; \ - *) (install-info --version) >/dev/null 2>&1;; \ - esac -am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) $(LISP) -# Read a list of newline-separated strings from the standard input, -# and print each of them once, without duplicates. Input order is -# *not* preserved. -am__uniquify_input = $(AWK) '\ - BEGIN { nonempty = 0; } \ - { items[$$0] = 1; nonempty = 1; } \ - END { if (nonempty) { for (i in items) print i; }; } \ -' -# Make sure the list of sources is unique. This is necessary because, -# e.g., the same source file might be shared among _SOURCES variables -# for different programs/libraries. -am__define_uniq_tagged_files = \ - list='$(am__tagged_files)'; \ - unique=`for i in $$list; do \ - if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ - done | $(am__uniquify_input)` -ETAGS = etags -CTAGS = ctags -DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) -ACLOCAL = @ACLOCAL@ -AMTAR = @AMTAR@ -AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ -AR = @AR@ -AUTOCONF = @AUTOCONF@ -AUTOHEADER = @AUTOHEADER@ -AUTOMAKE = @AUTOMAKE@ -AWK = @AWK@ -BLAS_LIBS = @BLAS_LIBS@ -CC = @CC@ -CCDEPMODE = @CCDEPMODE@ -CFLAGS = @CFLAGS@ -COMIO_CONFIG = @COMIO_CONFIG@ -COMIO_FC = @COMIO_FC@ -COMIO_FFLAGS = @COMIO_FFLAGS@ -COMIO_FLIBS = @COMIO_FLIBS@ -COMIO_LDFLAGS = @COMIO_LDFLAGS@ -COMIO_VERSION = @COMIO_VERSION@ -CPP = @CPP@ -CPPFLAGS = @CPPFLAGS@ -CYGPATH_W = @CYGPATH_W@ -DEFS = @DEFS@ -DEFS_PHYS = @DEFS_PHYS@ -DEPDIR = @DEPDIR@ -ECHO_C = @ECHO_C@ -ECHO_N = @ECHO_N@ -ECHO_T = @ECHO_T@ -EGREP = @EGREP@ -ESMFMKFILE = @ESMFMKFILE@ -ESMF_FC = @ESMF_FC@ -ESMF_FCFLAGS = @ESMF_FCFLAGS@ -ESMF_FLIBS = @ESMF_FLIBS@ -ESMF_LDFLAGS = @ESMF_LDFLAGS@ -ESMF_LIBS = @ESMF_LIBS@ -EXEEXT = @EXEEXT@ -F77 = @F77@ -FC = @FC@ -FCFLAGS = @FCFLAGS@ -FCFLAGS_F = @FCFLAGS_F@ -FCFLAGS_F90 = @FCFLAGS_F90@ -FCFLAGS_FIXED = @FCFLAGS_FIXED@ -FCFLAGS_FREE = @FCFLAGS_FREE@ -FCFLAGS_f = @FCFLAGS_f@ -FCLIBS = @FCLIBS@ -FC_AUTODOUBLE = @FC_AUTODOUBLE@ -FC_DEFINE = @FC_DEFINE@ -FC_LINE_LENGTH = @FC_LINE_LENGTH@ -FC_MODEXT = @FC_MODEXT@ -FC_MODINC = @FC_MODINC@ -FFLAGS = @FFLAGS@ -GREP = @GREP@ -INSTALL = @INSTALL@ -INSTALL_DATA = @INSTALL_DATA@ -INSTALL_PROGRAM = @INSTALL_PROGRAM@ -INSTALL_SCRIPT = @INSTALL_SCRIPT@ -INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ -LDFLAGS = @LDFLAGS@ -LIBOBJS = @LIBOBJS@ -LIBS = @LIBS@ -LTLIBOBJS = @LTLIBOBJS@ -MAINT = @MAINT@ -MAKEINFO = @MAKEINFO@ -MKDIR_P = @MKDIR_P@ -NC_CONFIG = @NC_CONFIG@ -NEMSIO_FCFLAGS = @NEMSIO_FCFLAGS@ -NEMSIO_FLIBS = @NEMSIO_FLIBS@ -NEMSIO_LDFLAGS = @NEMSIO_LDFLAGS@ -NEMSIO_LIBS = @NEMSIO_LIBS@ -NEMSIO_VERSION = @NEMSIO_VERSION@ -NETCDF4_CC = @NETCDF4_CC@ -NETCDF4_CFLAGS = @NETCDF4_CFLAGS@ -NETCDF4_FC = @NETCDF4_FC@ -NETCDF4_FFLAGS = @NETCDF4_FFLAGS@ -NETCDF4_FLIBS = @NETCDF4_FLIBS@ -NETCDF4_LDFLAGS = @NETCDF4_LDFLAGS@ -NETCDF4_LIBS = @NETCDF4_LIBS@ -NETCDF4_VERSION = @NETCDF4_VERSION@ -OBJEXT = @OBJEXT@ -OPENMP_FCFLAGS = @OPENMP_FCFLAGS@ -PACKAGE = @PACKAGE@ -PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ -PACKAGE_NAME = @PACKAGE_NAME@ -PACKAGE_STRING = @PACKAGE_STRING@ -PACKAGE_TARNAME = @PACKAGE_TARNAME@ -PACKAGE_URL = @PACKAGE_URL@ -PACKAGE_VERSION = @PACKAGE_VERSION@ -PATH_SEPARATOR = @PATH_SEPARATOR@ -RANLIB = @RANLIB@ -SED = @SED@ -SET_MAKE = @SET_MAKE@ -SHELL = @SHELL@ -STRIP = @STRIP@ -VERSION = @VERSION@ -WAM_DEP_LINK_OBJS = @WAM_DEP_LINK_OBJS@ -WAM_DEP_SHRD_LIBS = @WAM_DEP_SHRD_LIBS@ -WAM_DEP_SHRD_PATH = @WAM_DEP_SHRD_PATH@ -abs_builddir = @abs_builddir@ -abs_srcdir = @abs_srcdir@ -abs_top_builddir = @abs_top_builddir@ -abs_top_srcdir = @abs_top_srcdir@ -ac_ct_AR = @ac_ct_AR@ -ac_ct_CC = @ac_ct_CC@ -ac_ct_F77 = @ac_ct_F77@ -ac_ct_FC = @ac_ct_FC@ -ac_empty = @ac_empty@ -am__include = @am__include@ -am__leading_dot = @am__leading_dot@ -am__quote = @am__quote@ -am__tar = @am__tar@ -am__untar = @am__untar@ -bindir = @bindir@ -build = @build@ -build_alias = @build_alias@ -build_cpu = @build_cpu@ -build_os = @build_os@ -build_vendor = @build_vendor@ -builddir = @builddir@ -datadir = @datadir@ -datarootdir = @datarootdir@ -docdir = @docdir@ -dvidir = @dvidir@ -exec_prefix = @exec_prefix@ -host = @host@ -host_alias = @host_alias@ -host_cpu = @host_cpu@ -host_os = @host_os@ -host_vendor = @host_vendor@ -htmldir = @htmldir@ -includedir = @includedir@ -infodir = @infodir@ -install_sh = @install_sh@ -libdir = @libdir@ -libexecdir = @libexecdir@ -localedir = @localedir@ -localstatedir = @localstatedir@ -mandir = @mandir@ -mkdir_p = @mkdir_p@ -oldincludedir = @oldincludedir@ -pdfdir = @pdfdir@ -prefix = @prefix@ -program_transform_name = @program_transform_name@ -psdir = @psdir@ -sbindir = @sbindir@ -sharedstatedir = @sharedstatedir@ -srcdir = @srcdir@ -sysconfdir = @sysconfdir@ -target_alias = @target_alias@ -top_build_prefix = @top_build_prefix@ -top_builddir = @top_builddir@ -top_srcdir = @top_srcdir@ -noinst_LIBRARIES = libfim.a -libfim_a_SOURCES = fim_grid_comp_stub.F90 -libfim_a_FCFLAGS = -all: all-am - -.SUFFIXES: -.SUFFIXES: .F90 .o .obj -$(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps) - @for dep in $?; do \ - case '$(am__configure_deps)' in \ - *$$dep*) \ - ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \ - && { if test -f $@; then exit 0; else break; fi; }; \ - exit 1;; \ - esac; \ - done; \ - echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu src/fim/Makefile'; \ - $(am__cd) $(top_srcdir) && \ - $(AUTOMAKE) --gnu src/fim/Makefile -.PRECIOUS: Makefile -Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status - @case '$?' in \ - *config.status*) \ - cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ - *) \ - echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \ - cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \ - esac; - -$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) - cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh - -$(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) - cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh -$(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps) - cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh -$(am__aclocal_m4_deps): - -clean-noinstLIBRARIES: - -test -z "$(noinst_LIBRARIES)" || rm -f $(noinst_LIBRARIES) - -libfim.a: $(libfim_a_OBJECTS) $(libfim_a_DEPENDENCIES) $(EXTRA_libfim_a_DEPENDENCIES) - $(AM_V_at)-rm -f libfim.a - $(AM_V_AR)$(libfim_a_AR) libfim.a $(libfim_a_OBJECTS) $(libfim_a_LIBADD) - $(AM_V_at)$(RANLIB) libfim.a - -mostlyclean-compile: - -rm -f *.$(OBJEXT) - -distclean-compile: - -rm -f *.tab.c - -.F90.o: - $(AM_V_PPFC)$(PPFCCOMPILE) -c -o $@ $< - -.F90.obj: - $(AM_V_PPFC)$(PPFCCOMPILE) -c -o $@ `$(CYGPATH_W) '$<'` - -libfim_a-fim_grid_comp_stub.o: fim_grid_comp_stub.F90 - $(AM_V_PPFC)$(FC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(libfim_a_FCFLAGS) $(FCFLAGS) -c -o libfim_a-fim_grid_comp_stub.o `test -f 'fim_grid_comp_stub.F90' || echo '$(srcdir)/'`fim_grid_comp_stub.F90 - -libfim_a-fim_grid_comp_stub.obj: fim_grid_comp_stub.F90 - $(AM_V_PPFC)$(FC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(libfim_a_FCFLAGS) $(FCFLAGS) -c -o libfim_a-fim_grid_comp_stub.obj `if test -f 'fim_grid_comp_stub.F90'; then $(CYGPATH_W) 'fim_grid_comp_stub.F90'; else $(CYGPATH_W) '$(srcdir)/fim_grid_comp_stub.F90'; fi` - -ID: $(am__tagged_files) - $(am__define_uniq_tagged_files); mkid -fID $$unique -tags: tags-am -TAGS: tags - -tags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) - set x; \ - here=`pwd`; \ - $(am__define_uniq_tagged_files); \ - shift; \ - if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \ - test -n "$$unique" || unique=$$empty_fix; \ - if test $$# -gt 0; then \ - $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ - "$$@" $$unique; \ - else \ - $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ - $$unique; \ - fi; \ - fi -ctags: ctags-am - -CTAGS: ctags -ctags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) - $(am__define_uniq_tagged_files); \ - test -z "$(CTAGS_ARGS)$$unique" \ - || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ - $$unique - -GTAGS: - here=`$(am__cd) $(top_builddir) && pwd` \ - && $(am__cd) $(top_srcdir) \ - && gtags -i $(GTAGS_ARGS) "$$here" -cscopelist: cscopelist-am - -cscopelist-am: $(am__tagged_files) - list='$(am__tagged_files)'; \ - case "$(srcdir)" in \ - [\\/]* | ?:[\\/]*) sdir="$(srcdir)" ;; \ - *) sdir=$(subdir)/$(srcdir) ;; \ - esac; \ - for i in $$list; do \ - if test -f "$$i"; then \ - echo "$(subdir)/$$i"; \ - else \ - echo "$$sdir/$$i"; \ - fi; \ - done >> $(top_builddir)/cscope.files - -distclean-tags: - -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags - -distdir: $(DISTFILES) - @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ - topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ - list='$(DISTFILES)'; \ - dist_files=`for file in $$list; do echo $$file; done | \ - sed -e "s|^$$srcdirstrip/||;t" \ - -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ - case $$dist_files in \ - */*) $(MKDIR_P) `echo "$$dist_files" | \ - sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ - sort -u` ;; \ - esac; \ - for file in $$dist_files; do \ - if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ - if test -d $$d/$$file; then \ - dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ - if test -d "$(distdir)/$$file"; then \ - find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ - fi; \ - if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ - cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ - find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ - fi; \ - cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ - else \ - test -f "$(distdir)/$$file" \ - || cp -p $$d/$$file "$(distdir)/$$file" \ - || exit 1; \ - fi; \ - done -check-am: all-am -check: check-am -all-am: Makefile $(LIBRARIES) -installdirs: -install: install-am -install-exec: install-exec-am -install-data: install-data-am -uninstall: uninstall-am - -install-am: all-am - @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am - -installcheck: installcheck-am -install-strip: - if test -z '$(STRIP)'; then \ - $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ - install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ - install; \ - else \ - $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ - install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ - "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \ - fi -mostlyclean-generic: - -clean-generic: - -distclean-generic: - -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) - -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) - -maintainer-clean-generic: - @echo "This command is intended for maintainers to use" - @echo "it deletes files that may require special tools to rebuild." -clean: clean-am - -clean-am: clean-generic clean-local clean-noinstLIBRARIES \ - mostlyclean-am - -distclean: distclean-am - -rm -f Makefile -distclean-am: clean-am distclean-compile distclean-generic \ - distclean-tags - -dvi: dvi-am - -dvi-am: - -html: html-am - -html-am: - -info: info-am - -info-am: - -install-data-am: - -install-dvi: install-dvi-am - -install-dvi-am: - -install-exec-am: - -install-html: install-html-am - -install-html-am: - -install-info: install-info-am - -install-info-am: - -install-man: - -install-pdf: install-pdf-am - -install-pdf-am: - -install-ps: install-ps-am - -install-ps-am: - -installcheck-am: - -maintainer-clean: maintainer-clean-am - -rm -f Makefile -maintainer-clean-am: distclean-am maintainer-clean-generic - -mostlyclean: mostlyclean-am - -mostlyclean-am: mostlyclean-compile mostlyclean-generic - -pdf: pdf-am - -pdf-am: - -ps: ps-am - -ps-am: - -uninstall-am: - -.MAKE: install-am install-strip - -.PHONY: CTAGS GTAGS TAGS all all-am check check-am clean clean-generic \ - clean-local clean-noinstLIBRARIES cscopelist-am ctags ctags-am \ - distclean distclean-compile distclean-generic distclean-tags \ - distdir dvi dvi-am html html-am info info-am install \ - install-am install-data install-data-am install-dvi \ - install-dvi-am install-exec install-exec-am install-html \ - install-html-am install-info install-info-am install-man \ - install-pdf install-pdf-am install-ps install-ps-am \ - install-strip installcheck installcheck-am installdirs \ - maintainer-clean maintainer-clean-generic mostlyclean \ - mostlyclean-compile mostlyclean-generic pdf pdf-am ps ps-am \ - tags tags-am uninstall uninstall-am - - -.PHONY: clean-modules - -clean-modules: - -test -z "$(FC_MODEXT)" || rm -f *.$(FC_MODEXT) - -clean-local: clean-modules - -# dependencies - -# Tell versions [3.59,3.63) of GNU make to not export all variables. -# Otherwise a system limit (for SysV at least) may be exceeded. -.NOEXPORT: diff --git a/src/fim/diffsrc.ksh b/src/fim/diffsrc.ksh deleted file mode 100755 index 99273a3..0000000 --- a/src/fim/diffsrc.ksh +++ /dev/null @@ -1,18 +0,0 @@ -#!/bin/ksh - -#diffcmd=xxdiff -diffcmd=diff - -#fimsrcnems=/export/Tasks/FIMtoNEMSrepo/FIM_r1710_WORK/FIMsrc/fim/framework/nems -#fimsrcnems=FIMsrc/fim/framework/nems -fimsrcnems=/export/Tasks/FIMtoNEMSrepo/FIM_r1911/FIMsrc/fim/framework/nems - -echo "Compare $fimsrcnems with ." - -$diffcmd ${fimsrcnems}/fim_grid_comp.F90 fim_grid_comp.F90 -$diffcmd ${fimsrcnems}/fim_internal_state.F90 fim_internal_state.F90 -$diffcmd ${fimsrcnems}/module_DYNAMICS_GRID_COMP.F90 module_DYNAMICS_GRID_COMP.F90 -$diffcmd ${fimsrcnems}/module_PHYSICS_GRID_COMP.F90 module_PHYSICS_GRID_COMP.F90 -$diffcmd ${fimsrcnems}/module_FIM_INTEGRATE.F90 module_FIM_INTEGRATE.F90 -$diffcmd ${fimsrcnems}/module_DYN_PHY_CPL_COMP.F90 module_DYN_PHY_CPL_COMP.F90 - diff --git a/src/fim/fim_grid_comp.F90 b/src/fim/fim_grid_comp.F90 deleted file mode 100644 index 71eb751..0000000 --- a/src/fim/fim_grid_comp.F90 +++ /dev/null @@ -1,664 +0,0 @@ - MODULE module_FIM_GRID_COMP - - USE ESMF - USE MODULE_FIM_INTERNAL_STATE ,ONLY: FIM_INTERNAL_STATE & - ,WRAP_FIM_INTERNAL_STATE - USE MODULE_FIM_INTEGRATE ,ONLY: FIM_INTEGRATE -!TBH: USE MODULE_ERR_MSG ,ONLY: ERR_MSG,SET_IPRINT - USE MODULE_ERR_MSG ,ONLY: ERR_MSG - USE MODULE_DYNAMICS_GRID_COMP ,ONLY: DYN_REGISTER - USE MODULE_PHYSICS_GRID_COMP ,ONLY: PHY_REGISTER - USE MODULE_DYN_PHY_CPL_COMP ,ONLY: DYN_PHY_CPL_REGISTER - - IMPLICIT NONE - - PRIVATE - PUBLIC :: FIM_REGISTER - - TYPE(FIM_INTERNAL_STATE),POINTER,SAVE :: FIM_INT_STATE - TYPE(WRAP_FIM_INTERNAL_STATE) ,SAVE :: WRAP - - - CONTAINS - - SUBROUTINE FIM_REGISTER(FIM_GRID_COMP,RC_REG) - TYPE(ESMF_GridComp),INTENT(INOUT) :: FIM_GRID_COMP - INTEGER ,INTENT(OUT) :: RC_REG - - INTEGER :: RC - -! write(0,*) " FIM_REGISTER" - -!----------------------------------------------------------------------- -!*** Register the fim initialize subroutine. Since it is just one -!*** subroutine, use esmf_singlephase. The second argument is -!*** a pre-defined subroutine type, such as ESMF_SETINIT, ESMF_SETRUN, -!*** or ESMF_SETFINAL. -!----------------------------------------------------------------------- - - CALL ESMF_GridCompSetEntryPoint(FIM_GRID_COMP ,ESMF_SETINIT ,FIM_INITIALIZE ,ESMF_SINGLEPHASE ,RC) - CALL ERR_MSG (RC, 'set fim initialize entry point', RC_REG) - -!----------------------------------------------------------------------- -!*** Register the Run step of the FIM component. -!----------------------------------------------------------------------- - - CALL ESMF_GridCompSetEntryPoint(FIM_GRID_COMP ,ESMF_SETRUN ,FIM_RUN ,ESMF_SINGLEPHASE ,RC) - CALL ERR_MSG (RC, 'set fim run entry point', RC_REG) - -!----------------------------------------------------------------------- -!*** Register the FIM FINALIZE subroutine. -!----------------------------------------------------------------------- - - CALL ESMF_GridCompSetEntryPoint(FIM_GRID_COMP ,ESMF_SETFINAL ,FIM_FINALIZE ,ESMF_SINGLEPHASE ,RC) - CALL ERR_MSG (RC, 'set fim finalize entry point', RC_REG) - -! write(0,*) " END OF FIM_REGISTER" - - END SUBROUTINE FIM_REGISTER - - - SUBROUTINE FIM_INITIALIZE(FIM_GRID_COMP ,IMP_STATE ,EXP_STATE ,CLOCK_ATM ,RC_INIT) - - ! TODO: move logical flags to internal state - use module_core_setup,only: core_setup_fim,iam_fim_task,iam_write_task - use module_fim_dyn_init,only:dyn_init - - TYPE(ESMF_GridComp),INTENT(INOUT) :: FIM_GRID_COMP - TYPE(ESMF_State) ,INTENT(INOUT) :: IMP_STATE - TYPE(ESMF_State) ,INTENT(INOUT) :: EXP_STATE - TYPE(ESMF_Clock) ,INTENT(INOUT) :: CLOCK_ATM - INTEGER ,INTENT(OUT) :: RC_INIT - - INTEGER :: RC - TYPE(ESMF_Config) :: CF - - type(esmf_vm),save :: vm_global, vm_local ! the esmf virtual machine. - type(esmf_time) :: currtime ! the esmf current time. - type(esmf_time) :: starttime ! the esmf start time. - type(esmf_timeinterval) :: timestep - - ! note that this is just a reference so no "save" is needed - type(esmf_grid) :: grid_fim ! FIM grid, created by DYN, used by PHY and - ! FIM components - - integer :: total_tasks - integer :: mype_global - integer :: timestep_sec_whole - integer :: timestep_sec_numerator - integer :: timestep_sec_denominator - - integer :: nfhout, nfmout, nfsout, nsout - real :: deltim - integer :: MPI_COMM_FIM ! MPI communicator for this FIM component - integer :: ppp__status - logical :: iprint_lcl - character(128) :: comp_name - - -! write(0,*) " FIM_INITIALIZE" - RC_INIT = ESMF_SUCCESS - -! Start SMS. Every build of NEMS.x with FIM must use SMS. -! Normally this code is created via SMS directive, but PPP is -! not run on this file. - CALL sms_start(ppp__status) - IF (ppp__status.NE.0) THEN - ! Follow NMM template from Tom Black for non-ESMF error-abort - write(0,*) "ERROR IN FIM_INITIALIZE: sms_start FAILED" - CALL ESMF_Finalize(RC=RC,endflag=ESMF_END_ABORT) - ENDIF -! -!----------------------------------------------------------------------- -!*** Allocate the FIM component's internal state, point at it, -!*** and attach it to the FIM component. -!----------------------------------------------------------------------- -! - ALLOCATE(FIM_INT_STATE,stat=RC) - WRAP%FIM_INT_STATE=>FIM_INT_STATE - -!JR This call stuffs "wrap" into "fim_grid_comp" for later retrieval - CALL ESMF_GridCompSetInternalState(FIM_GRID_COMP ,WRAP ,RC) - CALL ERR_MSG (RC, 'ESMF_GridCompSetInternalState', RC_INIT) - -! -!----------------------------------------------------------------------- -!*** For the moment, use a direct copy of the ATM Clock. -!----------------------------------------------------------------------- -! -!JR This should probably use ESMF's copy constructor method instead - fim_int_state%clock_fim = clock_atm - -!TBH: This bit is useful for debugging - call esmf_gridcompget (gridcomp=fim_grid_comp, name=comp_name, rc=rc) - call err_msg (rc, 'get name of fim_grid_comp', rc_init) -!JR print *,'DEBUG: name of fim_grid_comp is [',TRIM(comp_name),']' - -!----------------------------------------------------------------------- -!*** Attach the configure file to the FIM component. -!----------------------------------------------------------------------- - CF=ESMF_ConfigCreate(rc=RC) -!TODO: hard-coded 'fim.configure' is not DRY, work with NCEP to fix this - CALL ESMF_ConfigLoadFile(config=CF ,filename='fim.configure' ,rc=RC) - CALL ERR_MSG (rc, 'load configure file fim.configure into configure object', rc_init) - CALL ESMF_GridCompSet(gridcomp=FIM_GRID_COMP, config=CF, rc=RC) - CALL ERR_MSG (rc, 'attach configure object to fim component', rc_init) - -! -!----------------------------------------------------------------------- -!*** Set verbostiy of err_msg prints -!TODO: move this setting up into MAIN_NEMS.F90, work with NCEP -!TBH: Temporarily removed this until we can merge set_iprint() into -!TBH: nems repository. -!----------------------------------------------------------------------- -! -!TBH call esmf_configgetattribute (config=cf, value=iprint_lcl, label='iprint:', rc=rc) -!TBH call err_msg (rc, "extract iprint information from fim config file", rc_init) -!TBH call set_iprint(iprint_lcl) -! -!----------------------------------------------------------------------- -!*** Retrieve the VM from the FIM component. -!----------------------------------------------------------------------- -! - call esmf_gridcompget (gridcomp=fim_grid_comp, vm=vm_local, rc=rc) - call err_msg (rc, "retrieve the cf and vm from fim component", rc_init) -!----------------------------------------------------------------------- -!*** Retrieve global VM then the total number of tasks for -!*** then entire system. -!----------------------------------------------------------------------- - call esmf_vmgetglobal (vm=vm_global, rc=rc) - call err_msg (rc, "retrieve global vm_global for fim", rc_init) - - call esmf_vmget (vm=vm_global, pecount=total_tasks, localpet=mype_global, rc=rc) - call err_msg (rc, "fim_initialize: obtain global mpi task id from vm_global", rc_init) -!JR print *,'DEBUG: mype_global = ',mype_global - call esmf_vmget (vm=vm_local, localpet=fim_int_state%mype, rc=rc) - call err_msg (rc, "fim_initialize: obtain local mpi task id from vm_local", rc_init) -!JR print *,'DEBUG: fim_int_state%mype = ',fim_int_state%mype -!----------------------------------------------------------------------- -!*** Extract fundamental timestep information from the config file. -!----------------------------------------------------------------------- - call esmf_configgetattribute (config=cf, value=timestep_sec_whole, label ='dt_int:', rc=rc) - call esmf_configgetattribute (config=cf, value=timestep_sec_numerator, label ='dt_num:', rc=rc) - call esmf_configgetattribute (config=cf, value =timestep_sec_denominator, label ='dt_den:', rc=rc) - call err_msg (rc, "extract timestep information from fim config file", rc_init) -!----------------------------------------------------------------------- -!*** Establish the timestep for the FIM Clock. -!----------------------------------------------------------------------- - call esmf_timeintervalset (timeinterval=timestep, s=timestep_sec_whole, sn=timestep_sec_numerator, & - sd=timestep_sec_denominator, rc=rc) - call esmf_clockset (clock=fim_int_state%clock_fim, timestep = timestep, rc=rc) - call err_msg (rc, "set time step interval in fim clock", rc_init) - -!TBH: Note that DYN, PHY, and CPL must currently live on the same -!TBH: MPI tasks via the use of "petlist=fim_int_state%petlist_fcst" -!TBH: during ESMF_*CompCreate() calls. - -! -!----------------------------------------------------------------------- -!*** SEGREGATE THE FORECAST TASKS FROM THE QUILT/WRITE TASKS. -!*** VIA CALL TO core_setup_fim WHICH RETURNS PETLISTS. -!----------------------------------------------------------------------- -! - CALL ESMF_VMGet(vm=vm_local,mpiCommunicator=MPI_COMM_FIM,rc=RC) - call err_msg (rc, "extract mpiCommunicator from vm_local", rc_init) - -#ifdef MANUALGPTL - ret = gptlstart ('core_setup_fim') -#endif - -! Split VM between compute and write tasks via petlists. -! core_setup_fim() allocates and initializes the petlists. -! NOTE: Executable SMS directives must not be placed before -! NOTE: this call! - CALL core_setup_fim(MPI_COMM_FIM,fim_int_state%petlist_fcst, & - fim_int_state%petlist_write) -#ifdef MANUALGPTL - ret = gptlstop ('core_setup_fim') -#endif - -!----------------------------------------------------------------------- -!*** Will the Write components with asynchronous quilting be used? -!----------------------------------------------------------------------- -!TBH call esmf_configgetattribute (config=cf, & ! the fim config object -!TBH value =fim_int_state%quilting, & ! the quilting flag -!TBH label ='quilting:', & ! give label's value to the previous variable -!TBH rc =rc) -!TBH call err_msg (rc, "extract quilting flag from fim config file", rc_init) - -! Note: At the moment, the 'quilting' field in the config file is ignored in -! Note: favor of FIMnamelist settings read by core_setup_fim. -!TODO: Reconcile 'quilting' field and FIM write task settings. - if (size(fim_int_state%petlist_write) > 0) then - fim_int_state%quilting = .true. - else - fim_int_state%quilting = .false. - endif - -!TODO: Connect fim_int_state%quilting to creation of NEMS write components. -!TODO: FIM write tasks are not yet ESMF components. Per UMIG discussion -!TODO: with Mark Iredell during UMIG meeting on 1/14/2011, it is more -!TODO: important to get write tasks working with NEMSIO before encapsulating -!TODO: them as components. - -!----------------------------------------------------------------------- -!*** Establish the frequency of forecast output. -!TODO: Reconcile FIMnamelist and config file here -!----------------------------------------------------------------------- - call esmf_configgetattribute (config=cf, value=nfhout, label ='nfhout:', rc=rc) - call err_msg (rc, "extract nfhout from fim config file", rc_init) - call esmf_configgetattribute (config=cf, value=nsout, label ='nsout:', rc=rc) - call err_msg (rc, "extract nsout from fim config file", rc_init) - call esmf_configgetattribute (config=cf, value =deltim, label ='deltim:', rc=rc) - call err_msg (rc, "extract history output interval from fim config file", rc_init) - call esmf_timeintervalset (fim_int_state%timeinterval_fim_output, h=nfhout, m=nfmout, & - s=nfsout, rc=rc) - call err_msg (rc, "set fim history output interval", rc_init) -!----------------------------------------------------------------------- -!*** Extract the start time from the clock. -!----------------------------------------------------------------------- - call esmf_clockget (clock=fim_int_state%clock_fim, starttime=starttime, rc=rc) - call err_msg (rc, "fim_atm_init: start time from fim clock", rc_init) - currtime = starttime -!----------------------------------------------------------------------- -!*** No need to extract the RESTART flag from the configure file: FIM currently has no restart capability -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** Create the Dynamics gridded subcomponent. -! all tasks must participate in component creation even if they do -! not participate in a component -!----------------------------------------------------------------------- - fim_int_state%gc_fim_dyn = esmf_gridcompcreate (name="dynamics component", & - configfile='fim.configure', & - petlist=fim_int_state%petlist_fcst, & - rc=rc) - call err_msg (rc, "create the fim dynamics component", rc_init) - -!----------------------------------------------------------------------- -!*** Always create the Physics gridded subcomponent. -!----------------------------------------------------------------------- - fim_int_state%gc_fim_phy = esmf_gridcompcreate (name ="physics component", & - configfile='fim.configure', & - petlist =fim_int_state%petlist_fcst, & - rc =rc) - call err_msg (rc, "create the fim physics component", rc_init) -!----------------------------------------------------------------------- -!*** Create the Dynamics-Physics coupler subcomponent. -!----------------------------------------------------------------------- - fim_int_state%gc_fim_cpl = esmf_cplcompcreate (name="coupler component", & - petlist=fim_int_state%petlist_fcst, & - rc =rc) - call err_msg (rc, "create the fim dynamics-physics coupler component", rc_init) - -! all tasks must participate in setservices calls even if they do -! not participate in a component (ESMF refdoc 15.3.8) -!*** Register the Initialize, Run, and Finalize steps for created components - call esmf_gridcompsetservices (fim_int_state%gc_fim_dyn, dyn_register, rc) - call err_msg (rc, "register fim dynamics init, run, finalize", rc_init) - call esmf_gridcompsetservices (fim_int_state%gc_fim_phy, phy_register, rc) - call err_msg (rc, "register physics init, run, finalize", rc_init) - call esmf_cplcompsetservices (fim_int_state%gc_fim_cpl, dyn_phy_cpl_register, rc) - call err_msg (rc, "register the dyn-phy coupler's init, run, finalize", rc_init) - -!----------------------------------------------------------------------- -!*** Create empty Import and Export states for the Dynamics component -!----------------------------------------------------------------------- - fim_int_state%IMP_fim_DYN = ESMF_StateCreate (statename="FIM dynamics import", & - statetype=esmf_state_import, & - rc =RC) - call err_msg (rc, "create empty import state for fim dynamics", rc_init) - fim_int_state%exp_fim_DYN = ESMF_StateCreate (statename="FIM dynamics export", & - statetype=esmf_state_export, & - rc =RC) - call err_msg (rc, "create empty export state for fim dynamics", rc_init) -!---------------------------------------------------------------------------------- -! Add the FIM dynamics states as the nested states into the FIM parent states. -!---------------------------------------------------------------------------------- - call esmf_stateadd (imp_state, fim_int_state%imp_fim_dyn, rc) - call esmf_stateadd (exp_state, fim_int_state%exp_fim_dyn, rc) -!JR I don't know what cpl_flag does, so copy from GFS for now - fim_int_state%cpl_flag = esmf_false - call esmf_attributeset (fim_int_state%imp_fim_dyn, 'cpl_flag', fim_int_state%cpl_flag, rc) - call err_msg (rc, "fim set cpl_flag", rc_init) -!------------------------------------------------------------------------ -!*** Create empty Import and Export states for the Physics subcomponent. -! Note that statenames are used by CPL_RUN() to determine direction of -! coupling (DYN->PHY or PHY->DYN). Any changes must be matched by -! equivalent changes in CPL_RUN(). -!------------------------------------------------------------------------ - fim_int_state%imp_fim_phy = esmf_statecreate (statename="FIM physics import", & - statetype=esmf_state_import, & - rc =rc) - call err_msg (rc, "create empty import state for fim physics", rc_init) - fim_int_state%exp_fim_phy = esmf_statecreate (statename="FIM physics export", & - statetype=esmf_state_export, & - rc =rc) - call err_msg (rc, "create empty export state for fim physics", rc_init) - -!----------------------------------------------------------------------- -!*** Setup the Write component(s) (which may run without quilting). -!JR Keep this: FIM will require mods vs GFS -!----------------------------------------------------------------------- -! -!JR write(0,*)'before write_setup_fim, allocate,write_groups=', fim_int_state%write_groups -! allocate (fim_int_state%wrt_comps(fim_int_state%write_groups)) -!JR Comment out for now -!JR call write_setup_fim (fim_grid_comp, fim_int_state%wrt_comps, fim_int_state%exp_fim_dyn, & -!JR fim_int_state%exp_fim_phy, fim_int_state%imp_fim_wrt, fim_int_state%exp_fim_wrt) - -!----------------------------------------------------------------------- -!*** Execute the Initialize steps for the gridded subcomponents. -!*** These are the Initialize subroutines specified in the -!*** Register routines called in ESMF_GridCompSetServices above. -! Note: Only tasks listed in the petlist during component creation -! Note: participate in the esmf_gridcompinitialize (etc.) calls. -! Note: For example, the write tasks return immediately from the calls -! Note: to esmf_gridcompinitialize for fim_int_state%gc_fim_??? below. -!----------------------------------------------------------------------- - -! TODO: Make sure that parent does *not* set an ESMF_Grid in the FIM component! -! TODO: Per Gerhard we will need to call esmf_gridcompget() to grab the attached -! TODO: ESMF_Grid and then call ESMF_GridValidate() on it. Unfortunately at the -! TODO: moment, ESMF regards calling of ESMF_GridValidate() on an un-initialized -! TODO: ESMF_Grid as an error! Straighten this out later. - -! TODO: Make DYN set lat & lon values in the ESMF_Grid and make PHY extract -! TODO: them, then eliminate passing of lat/lon arrays during CPL INIT. -! TODO: Ultimately we'll want to modify the NEMS GFS PHY component to accept -! TODO: and ESMF_Grid from its parent, at least optionally, and extract lat/lon -! TODO: from it. Tom Black agrees with this approach. -! TODO: See module_DYN_PHY_CPL_COMP.F90::CPL_INITIALIZE() for a long-winded -! TODO: explanation. - -!-------------- -!*** DYNAMICS -!-------------- - ! DYN initialize creates the FIM ESMF_Grid and attaches it to - ! fim_int_state%gc_fim_dyn. This delegation is appropriate since - ! the design and implementation of DYN is intimately related to - ! the grid. The PHY and FIM components just use this grid. Note - ! that because of this dependence, DYN initialize must be called - ! before PHY initialize. - ! Note also that DYN is responsible for destroying the grid. -!TBH: This is what the ESMF_GridCompInitialize() call does, but do *not* -!TBH: call it directly because ESMF_GridCompInitialize() has needed -!TBH: side-effects. -!TBH call dyn_initialize (fim_int_state%gc_fim_dyn, & -!TBH fim_int_state%imp_fim_dyn, & -!TBH fim_int_state%exp_fim_dyn, & -!TBH fim_int_state%clock_fim, & -!TBH rc) - call esmf_gridcompinitialize (fim_int_state%gc_fim_dyn, & - importstate=fim_int_state%imp_fim_dyn, & - exportstate=fim_int_state%exp_fim_dyn, & - clock =fim_int_state%clock_fim, & - phase =esmf_singlephase, & - rc =rc) - call err_msg (rc, "initialize fim dynamics component", rc_init) - - ! extract ESMF_Grid from fim_int_state%gc_fim_dyn and set in - ! fim_int_state%gc_fim_phy and fim_grid_comp - ! it is only safe to do this on the FIM compute tasks - if (iam_fim_task) then - ! grab FIM grid from DYN - call esmf_gridcompget(fim_int_state%gc_fim_dyn, grid=grid_fim, rc=rc) - CALL err_msg(rc, "extract FIM grid from DYN component", rc_init) - ! is this a good grid? - call esmf_gridvalidate(grid=grid_fim, rc=rc) - CALL err_msg(RC,"validate FIM grid",rc_init) - ! attach grid to FIM component - call esmf_gridcompset(fim_grid_comp, grid=grid_fim, rc=rc) - call err_msg (rc, "attach FIM grid to FIM component", rc_init) - ! attach grid to PHY component - call esmf_gridcompset(fim_int_state%gc_fim_phy, grid=grid_fim, rc=rc) - call err_msg (rc, "attach grid to fim physics component", rc_init) - endif - -!------------- -!*** PHYSICS -!------------- -!TBH: This is what the ESMF_GridCompInitialize() call does, but do *not* -!TBH: call it directly because ESMF_GridCompInitialize() has needed -!TBH: side-effects. -!TBH call phy_initialize (fim_int_state%gc_fim_phy, fim_int_state%imp_fim_phy, & -!TBH fim_int_state%exp_fim_phy, fim_int_state%clock_fim, rc) - call esmf_gridcompinitialize (fim_int_state%gc_fim_phy, & - importstate=fim_int_state%imp_fim_phy, & - exportstate=fim_int_state%exp_fim_phy, & - clock =fim_int_state%clock_fim, & - phase =esmf_singlephase, & - rc =rc) - call err_msg (rc, "initialize fim physics component", rc_init) - -!-------------- -!*** DYN-PHY COUPLER COMPONENT -!-------------- -!TBH: This is what the ESMF_CplCompInitialize() call does, but do *not* -!TBH: call it directly because ESMF_CplCompInitialize() has needed -!TBH: side-effects. -!TBH call cpl_initialize (fim_int_state%gc_fim_cpl, fim_int_state%exp_fim_dyn, & -!TBH fim_int_state%imp_fim_phy, fim_int_state%clock_fim, rc) - call esmf_cplcompinitialize (cplcomp =fim_int_state%gc_fim_cpl, & - importstate=fim_int_state%exp_fim_dyn, & - exportstate=fim_int_state%imp_fim_phy, & - clock =fim_int_state%clock_fim, & - rc =rc) - call err_msg (rc, "initialize dyn-phy coupler", rc_init) - - !TBH: Recall that the above call to - !TBH: esmf_gridcompinitialize (fim_int_state%gc_fim_dyn ... ) is a NOOP - !TBH: on write tasks because gc_fim_dyn was created with a "petlist" - !TBH: optional argument that excluded the write tasks from participation - !TBH: in this DYN components method calls. See for example the above - !TBH: call to: - !TBH: fim_int_state%gc_fim_dyn = esmf_gridcompcreate (...) - ! TODO: move this into FIM write component - if (iam_write_task) then - call dyn_init(.false.) - endif - -! write(0,*) " END OF FIM_INITIALIZE" - END SUBROUTINE FIM_INITIALIZE - - - SUBROUTINE FIM_RUN(FIM_GRID_COMP ,IMP_STATE ,EXP_STATE ,CLOCK_ATM ,RC_RUN) - - ! TODO: move these to internal state - use module_core_setup,only: iam_fim_task,iam_write_task - ! TODO: move this into FIM write component - use icosio,only:icosio_run - - TYPE(ESMF_GridComp),INTENT(INOUT) :: FIM_GRID_COMP - TYPE(ESMF_State) ,INTENT(INOUT) :: IMP_STATE - TYPE(ESMF_State) ,INTENT(INOUT) :: EXP_STATE - TYPE(ESMF_Clock) ,INTENT(INOUT) :: CLOCK_ATM - INTEGER ,INTENT(OUT) :: RC_RUN - -!--------------------- -!*** Local variables -!--------------------- -! - type(esmf_config) :: cf - integer :: rc ! error signal variables. - type(esmf_timeinterval) :: runduration ! the forecast length - type(esmf_timeinterval) :: timestep ! the fundamental timestep - type(esmf_time) :: currtime ! the esmf current time. - type(esmf_time) :: starttime ! the esmf start time. - -! write(0,*) " FIM_RUN" - RC_RUN=ESMF_SUCCESS - - if (iam_fim_task) then - ! compute tasks execute this branch - -!----------------------------------------------------------------------- -!*** For the moment, use a direct copy of the ATM Clock. -!JR This isn't good -!----------------------------------------------------------------------- -! - fim_int_state%clock_fim = clock_atm -!----------------------------------------------------------------------- -!*** Extract the fundamental time information from the Clock. -!----------------------------------------------------------------------- - call esmf_clockget (clock =fim_int_state%clock_fim, & ! the esmf clock - timestep =timestep, & ! the model's timestep length - starttime =starttime, & ! the forecast start time - currtime =currtime, & ! the clock's current time - runduration =runduration, & ! the length of the forecast - rc =rc) - call err_msg (rc, "retrieve fim timestep from the atm clock", rc_run) -!----------------------------------------------------------------------- -!*** Extract the configure file from the ATM component. -!*** GFS needed DFI info here but FIM doesn't -!----------------------------------------------------------------------- - call esmf_gridcompget (gridcomp=fim_grid_comp, config=cf, rc=rc) -!----------------------------------------------------------------------- -!*** Execute the FIM forecast runstream. -!----------------------------------------------------------------------- - call fim_integrate (fim_int_state%gc_fim_dyn, & - fim_int_state%gc_fim_phy, & - fim_int_state%gc_fim_cpl, & - fim_int_state%imp_fim_dyn, & - fim_int_state%exp_fim_dyn, & - fim_int_state%imp_fim_phy, & - fim_int_state%exp_fim_phy, & - fim_int_state%clock_fim, & - rc_run) - - else if (iam_write_task) then - ! TODO: move this into FIM write component - ! write tasks execute this branch, if present -! -!----------------------------------------------------------------------- -!*** Call the run method for the optional write tasks. -!----------------------------------------------------------------------- -! - call icosio_run - - endif - - ! do-nothing tasks just print along with the others -! write(0,*) " END OF FIM_RUN" - END SUBROUTINE FIM_RUN - - - SUBROUTINE FIM_FINALIZE(FIM_GRID_COMP ,IMP_STATE ,EXP_STATE ,CLOCK_ATM ,RC_FINALIZE) - - ! TODO: move to internal state - use module_core_setup,only: iam_fim_task - - TYPE(ESMF_GridComp),INTENT(INOUT) :: FIM_GRID_COMP - TYPE(ESMF_State) ,INTENT(INOUT) :: IMP_STATE - TYPE(ESMF_State) ,INTENT(INOUT) :: EXP_STATE - TYPE(ESMF_Clock) ,INTENT(INOUT) :: CLOCK_ATM - INTEGER ,INTENT(OUT) :: RC_FINALIZE - -!----------------------------------------------------------------------- -!*** LOCAL VARIABLES -!----------------------------------------------------------------------- -! - type(esmf_config) :: cf ! config object - integer :: i,j - integer :: rc,rc_final ! the final error signal variables. - TYPE(ESMF_VM) :: VM - -! write(0,*) " FIM_FINALIZE" - RC_FINALIZE=ESMF_SUCCESS - - rc = esmf_success - rc_final = esmf_success - -!----------------------------------------------------------------------- -!*** For the moment, use a direct copy of the ATM Clock. -!JR Fix this -!----------------------------------------------------------------------- -! - fim_int_state%clock_fim = clock_atm - - call esmf_gridcompget (gridcomp=fim_grid_comp, config=cf, rc=rc) - call err_msg (rc, "Retrieve Config Object from FIM Component", rc_final) - -!----------------------------------------------------------------------- -!*** Finalize each of the subcomponents. -!----------------------------------------------------------------------- -! -if (iam_fim_task) then -!----------------------------- -!*** DYNAMICS-PHYSICS COUPLER -!----------------------------- - call esmf_cplcompfinalize (fim_int_state%gc_fim_cpl, & - importstate=fim_int_state%exp_fim_dyn, & - exportstate=fim_int_state%imp_fim_phy, & - clock =fim_int_state%clock_fim, & - rc =rc) - call err_msg (rc, "finalize dynamics-physics coupler", rc_final) -!-------------- -!*** Dynamics -!-------------- - call esmf_gridcompfinalize (fim_int_state%gc_fim_dyn, & - importstate=fim_int_state%imp_fim_dyn, & - exportstate=fim_int_state%exp_fim_dyn, & - clock =fim_int_state%clock_fim, & - rc =rc) - call err_msg (rc, "finalize dynamics component", rc_final) -!-------------- -!*** Physics -!-------------- - call esmf_gridcompfinalize (fim_int_state%gc_fim_phy, & - importstate=fim_int_state%imp_fim_phy, & - exportstate=fim_int_state%exp_fim_phy, & - clock =fim_int_state%clock_fim, & - rc =rc) - call err_msg (rc, "finalize physics component", rc_final) -endif - - ! ensure that "write" and "do-nothing" tasks do not race ahead and - ! destroy components before other tasks are ready - CALL ESMF_VMGetCurrent(vm=VM,rc=RC) - call err_msg (rc, "FIM_FINALIZE: get current vm", rc_final) - CALL ESMF_VMBarrier(vm=VM,rc=RC) - call err_msg (rc, "FIM_FINALIZE: barrier on current vm", rc_final) - -!----------------------------------------------------------------------- -!*** DESTROY ALL STATES. -!----------------------------------------------------------------------- - call esmf_statedestroy (fim_int_state%imp_fim_dyn, rc=rc) - call esmf_statedestroy (fim_int_state%exp_fim_dyn, rc=rc) - call esmf_statedestroy (state=fim_int_state%imp_fim_phy, rc=rc) - call esmf_statedestroy (state=fim_int_state%exp_fim_phy, rc=rc) -!----------------------------------------------------------------------- -!*** IF QUILTING WAS SELECTED FOR THE GENERATION OF OUTPUT, -!*** FINALIZE AND DESTROY OBJECTS RELATED TO THE WRITE COMPONENTS. -!----------------------------------------------------------------------- - if (fim_int_state%quilting) then -!JR turn this off until quilting is implemented -!JR call write_destroy_fim (fim_grid_comp, fim_int_state%wrt_comps, fim_int_state%imp_fim_wrt, & -!JR fim_int_state%exp_fim_wrt, fim_int_state%clock_fim) - end if - -!----------------------------------------------------------------------- -!*** DESTROY ALL SUBCOMPONENTS. -!----------------------------------------------------------------------- - call esmf_gridcompdestroy (fim_int_state%gc_fim_dyn, rc=rc) - call err_msg (rc, "Destroy Dynamics Component", rc_final) -!------------- -!*** PHYSICS -!------------- - call esmf_gridcompdestroy (fim_int_state%gc_fim_phy, rc=rc) - call err_msg (rc, "destroy physics component", rc_final) -!------------------------------ -!*** DYNAMICS-PHYSICS COUPLER -!------------------------------ - call esmf_cplcompdestroy (fim_int_state%gc_fim_cpl, rc=rc) - call err_msg (rc, "destroy dynamics-physics coupler", rc_final) - -!TODO: make sure all allocated bits of fim_int_state are deallocated -! deallocate other components of fim_int_state - deallocate(fim_int_state%petlist_fcst) - deallocate(fim_int_state%petlist_write) - - rc_finalize = rc_final -! write(0,*) " END OF FIM_FINALIZE" - END SUBROUTINE FIM_FINALIZE - - END MODULE module_FIM_GRID_COMP diff --git a/src/fim/fim_grid_comp_stub.F90 b/src/fim/fim_grid_comp_stub.F90 deleted file mode 100644 index 6fdb1d5..0000000 --- a/src/fim/fim_grid_comp_stub.F90 +++ /dev/null @@ -1,89 +0,0 @@ -! 05/11/2011 Weiyu Yang Modified for using the ESMF 5.2.0r_beta_snapshot_07. -! 02/09/2012 Weiyu Yang Modified for using the ESMF 5.2.0rp1 library. -!------------------------------------------------------------------------------- -!#include "../../ESMFVersionDefine.h" - - MODULE module_FIM_GRID_COMP - - USE ESMF - - IMPLICIT NONE - - PRIVATE - PUBLIC :: FIM_REGISTER - - INTEGER :: DUMMY - - CONTAINS - -!####################################################################### - - SUBROUTINE FIM_REGISTER(FIM_GRID_COMP,RC_REG) - TYPE(ESMF_GridComp) :: FIM_GRID_COMP - INTEGER ,INTENT(OUT) :: RC_REG - - INTEGER :: RC - - write(0,*) " FIM_REGISTER" - - - CALL ESMF_GridCompSetEntryPoint(FIM_GRID_COMP ,ESMF_METHOD_INITIALIZE ,FIM_INITIALIZE ,rc=RC) - CALL ESMF_GridCompSetEntryPoint(FIM_GRID_COMP ,ESMF_METHOD_RUN, FIM_RUN, rc=RC) - CALL ESMF_GridCompSetEntryPoint(FIM_GRID_COMP ,ESMF_METHOD_FINALIZE, FIM_FINALIZE ,rc=RC) - - RC_REG = ESMF_SUCCESS - write(0,*) " END OF FIM_REGISTER" - - END SUBROUTINE FIM_REGISTER - -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - - SUBROUTINE FIM_INITIALIZE(FIM_GRID_COMP ,IMP_STATE ,EXP_STATE ,CLOCK_FIM ,RC_INIT) - - TYPE(ESMF_GridComp) :: FIM_GRID_COMP - TYPE(ESMF_State) :: IMP_STATE - TYPE(ESMF_State) :: EXP_STATE - TYPE(ESMF_Clock) :: CLOCK_FIM - INTEGER ,INTENT(OUT) :: RC_INIT - - write(0,*) " FIM_INITIALIZE stub" - RC_INIT = ESMF_SUCCESS - write(0,*) " END OF FIM_INITIALIZE stub" - - END SUBROUTINE FIM_INITIALIZE - -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - - SUBROUTINE FIM_RUN(FIM_GRID_COMP ,IMP_STATE ,EXP_STATE ,CLOCK_FIM ,RC_RUN) - - TYPE(ESMF_GridComp) :: FIM_GRID_COMP - TYPE(ESMF_State) :: IMP_STATE - TYPE(ESMF_State) :: EXP_STATE - TYPE(ESMF_Clock) :: CLOCK_FIM - INTEGER ,INTENT(OUT) :: RC_RUN - - write(0,*) " FIM_RUN stub" - RC_RUN=ESMF_SUCCESS - write(0,*) " END OF FIM_RUN stub" - - END SUBROUTINE FIM_RUN - -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - - SUBROUTINE FIM_FINALIZE(FIM_GRID_COMP ,IMP_STATE ,EXP_STATE ,CLOCK_FIM ,RC_FINALIZE) - - TYPE(ESMF_GridComp) :: FIM_GRID_COMP - TYPE(ESMF_State) :: IMP_STATE - TYPE(ESMF_State) :: EXP_STATE - TYPE(ESMF_Clock) :: CLOCK_FIM - INTEGER ,INTENT(OUT) :: RC_FINALIZE - - write(0,*) " FIM_FINALIZE stub" - RC_FINALIZE=ESMF_SUCCESS - write(0,*) " END OF FIM_FINALIZE stub" - - END SUBROUTINE FIM_FINALIZE - -!####################################################################### - - END MODULE module_FIM_GRID_COMP diff --git a/src/fim/fim_internal_state.F90 b/src/fim/fim_internal_state.F90 deleted file mode 100644 index 97f812d..0000000 --- a/src/fim/fim_internal_state.F90 +++ /dev/null @@ -1,45 +0,0 @@ - MODULE module_FIM_INTERNAL_STATE - - USE ESMF - - IMPLICIT NONE - - PRIVATE - PUBLIC :: FIM_INTERNAL_STATE,WRAP_FIM_INTERNAL_STATE - - TYPE FIM_INTERNAL_STATE - - type(esmf_gridcomp) :: gc_fim_dyn - type(esmf_gridcomp) :: gc_fim_phy - type(esmf_state ) :: imp_fim_dyn - type(esmf_state ) :: exp_fim_dyn !<-- import/export states for fim dynamics - type(esmf_state ) :: imp_fim_phy - type(esmf_state ) :: exp_fim_phy !<-- import/export states for fim physics -! type(esmf_state ) :: imp_fim_wrt -! type(esmf_state ) :: exp_fim_wrt !<-- import/export states for fim write - type(esmf_clock ) :: clock_fim - type(esmf_logical) :: cpl_flag -! type(esmf_logical) :: chemistry_on !<-- is chemistry active? - type(esmf_cplcomp) :: gc_fim_cpl - integer :: mype !<-- each mpi task id -! integer :: write_group_ready_to_go !<-- the write group to use - logical :: quilting !<-- is asynchronous quilting specified? - type(esmf_logical) :: physics_on !<-- is physics active? -! type(esmf_gridcomp), pointer :: wrt_comps(:) - type(esmf_timeinterval) :: timeinterval_fim_output !<-- time interval between fim history output - - ! Task ID list of fcst tasks (for Dyn, Phy, and Cpl components) - ! Task IDs are based on FIM component local VM - integer, pointer :: petlist_fcst(:) - ! Task ID list of all write tasks - ! Task IDs are based on FIM component local VM - integer, pointer :: petlist_write(:) - - END TYPE FIM_INTERNAL_STATE - - TYPE WRAP_FIM_INTERNAL_STATE - TYPE(FIM_INTERNAL_STATE),POINTER :: FIM_INT_STATE - END TYPE WRAP_FIM_INTERNAL_STATE - - END MODULE module_FIM_INTERNAL_STATE - diff --git a/src/fim/module_DYNAMICS_GRID_COMP.F90 b/src/fim/module_DYNAMICS_GRID_COMP.F90 deleted file mode 100644 index 6ff8391..0000000 --- a/src/fim/module_DYNAMICS_GRID_COMP.F90 +++ /dev/null @@ -1,1302 +0,0 @@ -!TODO: DRY out all of this code. Follow NMM "array object" approach -!TODO: developed by Tom Black and I (TBH - we called it the "ownership" -!TODO: proposal) and implemented within NEMS-NMMB by Dusan Jovic. -!----------------------------------------------------------------------- -! - MODULE MODULE_DYNAMICS_GRID_COMP -! -!----------------------------------------------------------------------- -! -!*** THIS MODULE HOLDS THE DYNAMICS REGISTER, INIT, RUN, AND FINALIZE -!*** ROUTINES. THEY ARE CALLED FROM THE FIM GRIDDED COMPONENT -!*** (FIM INITIALIZE CALLS DYNAMICS INITIALIZE, ETC.). -! -!----------------------------------------------------------------------- -! - USE ESMF -! - USE MODULE_ERR_MSG,ONLY: ERR_MSG,MESSAGE_CHECK -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -#ifdef MANUALGPTL -#include - integer :: ret -#endif - -! TODO: put this in "dyn_internal_state" - TYPE(ESMF_Grid), SAVE :: GRID_FIM_DYN !<-- The ESMF GRID for FIM "nip" dimension - -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: DYN_REGISTER -! -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE DYN_REGISTER(DYN_GRID_COMP,RC_REG) -! -!----------------------------------------------------------------------- -!*** REGISTER THE DYNAMICS COMPONENT'S INITIALIZE, RUN, AND FINALIZE -!*** SUBROUTINE NAMES. -!----------------------------------------------------------------------- -! - TYPE(ESMF_GridComp),INTENT(INOUT) :: DYN_GRID_COMP !<-- The Dynamics gridded component -! - INTEGER,INTENT(OUT) :: RC_REG !<-- Return code for Dyn register -! -!----------------------------------------------------------------------- -!*** LOCAL VARIABLES -!----------------------------------------------------------------------- -! - INTEGER :: RC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC_REG=ESMF_SUCCESS !<-- Initialize error signal variable - -!----------------------------------------------------------------------- -!*** REGISTER THE DYNAMICS INITIALIZE SUBROUTINE. SINCE IT IS JUST ONE -!*** SUBROUTINE, USE ESMF_SINGLEPHASE. THE SECOND ARGUMENT IS -!*** A PRE-DEFINED SUBROUTINE TYPE, SUCH AS ESMF_SETINIT, ESMF_SETRUN, -!*** OR ESMF_SETFINAL. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for Dynamics Initialize" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -#ifdef MANUALGPTL - ret = gptlstart ('ESMF_GridCompSetEntryPoint:dyn_initialize') -#endif - CALL ESMF_GridCompSetEntryPoint(DYN_GRID_COMP & !<-- The gridded component - ,ESMF_SETINIT & !<-- Predefined subroutine type - ,DYN_INITIALIZE & !<-- User's subroutineName - ,ESMF_SINGLEPHASE & !<-- phase - ,RC) -#ifdef MANUALGPTL - ret = gptlstop ('ESMF_GridCompSetEntryPoint:dyn_initialize') -#endif -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** REGISTER THE DYNAMICS RUN SUBROUTINE. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for Dynamics Run" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -#ifdef MANUALGPTL - ret = gptlstart ('ESMF_GridCompSetEntryPoint:dyn_run') -#endif - CALL ESMF_GridCompSetEntryPoint(DYN_GRID_COMP & !<-- gridcomp - ,ESMF_SETRUN & !<-- subroutineType - ,DYN_RUN & !<-- user's subroutineName - ,ESMF_SINGLEPHASE & !<-- phase - ,RC) -#ifdef MANUALGPTL - ret = gptlstop ('ESMF_GridCompSetEntryPoint:dyn_run') -#endif -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** REGISTER THE DYNAMICS FINALIZE SUBROUTINE. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for Dynamics Finalize" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSetEntryPoint(DYN_GRID_COMP & !<-- gridcomp - ,ESMF_SETFINAL & !<-- subroutineType - ,DYN_FINALIZE & !<-- user's subroutineName - ,ESMF_SINGLEPHASE & !<-- phase - ,RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** CHECK THE ERROR SIGNAL VARIABLE. -!----------------------------------------------------------------------- -! - IF(RC_REG==ESMF_SUCCESS)THEN -! WRITE(0,*)" DYN_REGISTER SUCCEEDED" - ELSE - WRITE(0,*)" DYN_REGISTER FAILED" - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE DYN_REGISTER -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE DYN_INITIALIZE(DYN_GRID_COMP & - ,IMP_STATE,EXP_STATE & - ,CLOCK_FIM & - ,RC_INIT) -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** CARRY OUT ALL NECESSARY SETUPS FOR THE MODEL DYNAMICS. -! This includes creating the FIM ESMF_Grid and attaching it to dyn_grid_comp. -!----------------------------------------------------------------------- -! - use module_control,only: nip,nvl - USE module_fim_dyn_init ,only: DYN_INITIALIZE_FIM => dyn_init - use module_variables,only: us3d,vs3d,pr3d,tr3d,ws3d - use module_sfc_variables,only: rn2d,rc2d,ts2d,us2d,hf2d,qf2d, & - sheleg2d, canopy2d, hice2d, fice2d, & - st3d, sm3d, sw2d, lw2d, t2m2d, q2m2d, & - slmsk2d, hprm2d, flxlwtoa2d -! -!----------------------------------------------------------------------- -!*** ARGUMENT VARIABLES. -!----------------------------------------------------------------------- -! - TYPE(ESMF_GridComp),INTENT(INOUT) :: DYN_GRID_COMP !<-- The Dynamics gridded component - TYPE(ESMF_State), INTENT(INOUT) :: IMP_STATE !<-- The Dynamics Initialize step's import state - TYPE(ESMF_State), INTENT(INOUT) :: EXP_STATE !<-- The Dynamics Initialize step's export state - TYPE(ESMF_Clock), INTENT(IN) :: CLOCK_FIM !<-- The FIM's ESMF Clock -! - INTEGER, INTENT(OUT) :: RC_INIT -! -!----------------------------------------------------------------------- -!*** LOCAL VARIABLES -!----------------------------------------------------------------------- -! - ! temporary field object -! TYPE(ESMF_Field) :: TMP_FIELD - TYPE(ESMF_DistGrid) :: DISTGRID - TYPE(ESMF_Array) :: TMP_ARRAY - type(esmf_vm),save :: vm_local ! TODO: is SAVE needed? - INTEGER :: NUM_PES_FCST,mype - INTEGER :: RC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** INITIALIZE THE ERROR SIGNAL VARIABLES. -!----------------------------------------------------------------------- -! -#ifdef MANUALGPTL - ret = gptlstart ('dyn_initialize') -#endif - - RC =ESMF_SUCCESS - RC_INIT=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** PRIMARY INITIALIZATION OF SCALARS/ARRAYS. -!*** Also sets up SMS decomposition. -!----------------------------------------------------------------------- -! -#ifdef MANUALGPTL - ret = gptlstart ('dyn_init') -#endif - CALL DYN_INITIALIZE_FIM(.false.) -#ifdef MANUALGPTL - ret = gptlstop ('dyn_init') -#endif -! -!----------------------------------------------------------------------- -!*** CREATE THE ESMF GRID. -!----------------------------------------------------------------------- -! Create ESMF_Grid and attach it to dyn_grid_comp. -!TBH: For FIM grid creation the ESMF_Grid is currently a dummy. This -!TBH: routine creates a bogus grid and distributes it across the -!TBH: correct number of FIM compute tasks. It then attaches it to -!TBH: dyn_grid_comp. -! TODO: Match decomposition to SMS. -! TODO: Load lat-lon into this grid for later extraction by PHY, -! TODO: may have to defer this to newer ESMF version! -!----------------------------------------------------------------------- -! -#ifdef MANUALGPTL - ret = gptlstart ('ESMF_gridcreate') -#endif -!TODO: Match decomposition to SMS via new args passed out of -!TODO: DYN_INITIALIZE_FIM. -!TODO: Replace with a real icos constructor once we switch to a version -!TODO: of ESMF that supports it. -!TODO: Load lat-lon into this grid for later extraction by PHY, -!TODO: may have to defer this to newer ESMF version! - - call esmf_gridcompget(gridcomp=dyn_grid_comp, vm=vm_local, rc=rc) - CALL err_msg(RC,"DYN_INITIALIZE: get local vm",rc_init) - call esmf_vmget(vm=vm_local, pecount=NUM_PES_FCST, localpet=mype,& - rc=rc) - CALL err_msg(RC,"DYN_INITIALIZE: get NUM_PES_FCST",rc_init) - -!TODO: Add deBlockList to specify start and end indicies for each MPI task, -!TODO: need NUM_PES_FCST for deBlockList(0:NUM_PES_FCST-1) ... - ! Create "1D" ESMF_DistGrid per ESMF Reference Manual section 26.2.1 - DISTGRID=ESMF_DistGridCreate(minIndex=(/1/),maxIndex=(/nip/), & - rc=rc_init) - CALL err_msg(RC,"DYN_INITIALIZE: create DISTGRID",rc_init) - - ! Create "1D" ESMF_Grid from ESMF_DistGrid - GRID_FIM_DYN=ESMF_GridCreate(name="FIM_GRID",distgrid=DISTGRID, & - rc=rc_init) - CALL err_msg(RC,"DYN_INITIALIZE: create GRID from DISTGRID", & - rc_init) -#ifdef MANUALGPTL - ret = gptlstop ('ESMF_gridcreate') -#endif - - call esmf_gridvalidate(grid=GRID_FIM_DYN, rc=RC) - CALL ERR_MSG(RC,"DYN_INITIALIZE: Validate new GRID",RC_INIT) - -!TODO: Add guard to prevent memory leak if parent has already attached -!TODO: an ESMF_Grid to dyn_grid_comp. - ! attach ESMF_Grid to ESMF_GridComp - call esmf_gridcompset(dyn_grid_comp, grid=grid_fim_dyn, & - rc=rc) - CALL err_msg(rc, "attach FIM grid to DYN component", & - rc_init) -! -!----------------------------------------------------------------------- -!*** Attach FIM fields in the internal state -!*** to the esmf import and export states. -!TBH: I use GFS naming conventions, *not* NMMB conventions. As -!TBH: of NEMS r3038 they do indeed differ, by case at least! -!TBH: Creation of unique ESMF_Field objects for import and export -!TBH: states should require little additional memory since the pointers -!TBH: to Fortran arrays are shared. This approach makes object deletion -!TBH: easier. -!------------------------------------------------------- - -!TODO: Implement esmf_sta_list to allow config control of coupling once -!TODO: this settles down between NMMB and GFS in NEMS. - -!TODO: Need to add gridToFieldMap to ESMF_FieldCreate() to address -!TODO: differences between 2D and 3D arrays. At present this is -!TODO: irrelevant since we do not use ESMF to do any re-grid or -!TODO: re-dist operations. This must be fixed before we use these -!TODO: ESMF features. - -! -! pr3d -! - MESSAGE_CHECK="Create pr3d array for import state" - ! create the ESMF_Field -!TBH: Note that the following call to ESMF_FieldCreate() yields the -!TBH: stunningly informative error code 540 which maps to string -!TBH: "Not valid" in ESMC_ErrMsgs.C. Backed off to ESMF_ArrayCreate(). -!TODO: Switch back to ESMF_FieldCreate() since future NEMS will use -!TODO: ESMF_Fields. -! TMP_FIELD=ESMF_FieldCreate(grid =grid_fim_dyn & -! ,farray =pr3d & -! ,distgridToArrayMap=(/2/) & -! ,name ='pr3d' & -! ,rc =RC) -#ifdef MANUALGPTL - ret = gptlstart ('esmf_arraycreate') -#endif - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =pr3d & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='pr3d' & - ,rc =RC) -#ifdef MANUALGPTL - ret = gptlstop ('esmf_arraycreate') -#endif - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add pr3d array to import state" -#ifdef MANUALGPTL - ret = gptlstart ('esmf_stateadd') -#endif - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) -#ifdef MANUALGPTL - ret = gptlstop ('esmf_stateadd') -#endif - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create pr3d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =pr3d & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='pr3d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add pr3d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! us3d -! - MESSAGE_CHECK="Create us3d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =us3d & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='us3d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add us3d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create us3d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =us3d & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='us3d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add us3d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! vs3d -! - MESSAGE_CHECK="Create vs3d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =vs3d & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='vs3d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add vs3d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create vs3d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =vs3d & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='vs3d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add vs3d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! ws3d -! - MESSAGE_CHECK="Create ws3d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =ws3d & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='ws3d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add ws3d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create ws3d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =ws3d & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='ws3d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add ws3d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! tr3d -! - MESSAGE_CHECK="Create tr3d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =tr3d & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='tr3d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add tr3d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create tr3d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =tr3d & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='tr3d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add tr3d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! rn2d -! - MESSAGE_CHECK="Create rn2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =rn2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='rn2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add rn2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create rn2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =rn2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='rn2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add rn2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! rc2d -! - MESSAGE_CHECK="Create rc2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =rc2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='rc2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add rc2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create rc2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =rc2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='rc2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add rc2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! ts2d -! - MESSAGE_CHECK="Create ts2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =ts2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='ts2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add ts2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create ts2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =ts2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='ts2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add ts2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! us2d -! - MESSAGE_CHECK="Create us2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =us2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='us2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add us2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create us2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =us2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='us2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add us2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! hf2d -! - MESSAGE_CHECK="Create hf2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =hf2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='hf2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add hf2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create hf2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =hf2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='hf2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add hf2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! qf2d -! - MESSAGE_CHECK="Create qf2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =qf2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='qf2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add qf2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create qf2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =qf2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='qf2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add qf2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! sheleg2d -! - MESSAGE_CHECK="Create sheleg2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =sheleg2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='sheleg2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add sheleg2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create sheleg2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =sheleg2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='sheleg2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add sheleg2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! canopy2d -! - MESSAGE_CHECK="Create canopy2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =canopy2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='canopy2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add canopy2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create canopy2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =canopy2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='canopy2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add canopy2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! hice2d -! - MESSAGE_CHECK="Create hice2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =hice2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='hice2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add hice2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create hice2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =hice2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='hice2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add hice2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! fice2d -! - MESSAGE_CHECK="Create fice2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =fice2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='fice2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add fice2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create fice2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =fice2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='fice2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add fice2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! st3d -! - MESSAGE_CHECK="Create st3d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =st3d & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='st3d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add st3d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create st3d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =st3d & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='st3d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add st3d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! sm3d -! - MESSAGE_CHECK="Create sm3d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =sm3d & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='sm3d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add sm3d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create sm3d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =sm3d & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='sm3d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add sm3d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! sw2d -! - MESSAGE_CHECK="Create sw2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =sw2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='sw2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add sw2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create sw2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =sw2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='sw2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add sw2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! lw2d -! - MESSAGE_CHECK="Create lw2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =lw2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='lw2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add lw2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create lw2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =lw2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='lw2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add lw2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! t2m2d -! - MESSAGE_CHECK="Create t2m2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =t2m2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='t2m2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add t2m2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create t2m2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =t2m2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='t2m2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add t2m2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! q2m2d -! - MESSAGE_CHECK="Create q2m2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =q2m2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='q2m2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add q2m2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create q2m2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =q2m2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='q2m2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add q2m2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! slmsk2d -! - MESSAGE_CHECK="Create slmsk2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =slmsk2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='slmsk2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add slmsk2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create slmsk2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =slmsk2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='slmsk2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add slmsk2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! -! hprm2d -! - MESSAGE_CHECK="Create hprm2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =hprm2d & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='hprm2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add hprm2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create hprm2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =hprm2d & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='hprm2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add hprm2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - -! -! flxlwtoa2d -! - MESSAGE_CHECK="Create flxlwtoa2d array for import state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =flxlwtoa2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='flxlwtoa2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add flxlwtoa2d array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="Create flxlwtoa2d array for export state" - ! create the ESMF_Field - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =flxlwtoa2d & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='flxlwtoa2d' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add flxlwtoa2d array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - -!TBH: validate states - MESSAGE_CHECK="DYN_INITIALIZE: Validate import state" - call ESMF_StateValidate(state=IMP_STATE,rc=rc) - IF(RC==ESMF_SUCCESS)THEN -!JR WRITE(0,*)'DYN INITIALIZE import state valid' - ENDIF - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="DYN_INITIALIZE: Validate export state" - call ESMF_StateValidate(state=EXP_STATE,rc=rc) - IF(RC==ESMF_SUCCESS)THEN -!JR WRITE(0,*)'DYN INITIALIZE export state valid' - ENDIF - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - -! - IF(RC_INIT==ESMF_SUCCESS)THEN -! WRITE(0,*)'DYN INITIALIZE STEP SUCCEEDED' - ELSE - WRITE(0,*)'DYN INITIALIZE STEP FAILED RC_INIT=',RC_INIT - ENDIF -! -!----------------------------------------------------------------------- -! -#ifdef MANUALGPTL - ret = gptlstop ('dyn_initialize') -#endif - END SUBROUTINE DYN_INITIALIZE -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE DYN_RUN(DYN_GRID_COMP & - ,IMP_STATE,EXP_STATE & - ,CLOCK_FIM & - ,RC_RUN) -! -!----------------------------------------------------------------------- -!*** THE INTEGRATION OF THE MODEL DYNAMICS IS DONE -!*** THROUGH THIS ROUTINE. -!----------------------------------------------------------------------- -! - USE module_fim_dyn_run ,only: DYN_RUN_FIM => dyn_run -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -!*** ARGUMENT VARIABLES -!----------------------------------------------------------------------- -! - TYPE(ESMF_GridComp),INTENT(INOUT) :: DYN_GRID_COMP !<-- The Dynamics gridded component - TYPE(ESMF_State) ,INTENT(INOUT) :: IMP_STATE !<-- The Dynamics import state - TYPE(ESMF_State) ,INTENT(INOUT) :: EXP_STATE !<-- The Dynamics export state - TYPE(ESMF_Clock) ,INTENT(IN) :: CLOCK_FIM !<-- The FIM's ESMF Clock -! - INTEGER ,INTENT(OUT) :: RC_RUN -! -!----------------------------------------------------------------------- -!*** LOCAL VARIABLES -!----------------------------------------------------------------------- -! - INTEGER :: NTIMESTEP,RC -! - INTEGER(KIND=ESMF_KIND_I8) :: NTIMESTEP_ESMF -! - INTEGER :: its -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -#ifdef MANUALGPTL - ret = gptlstart ('dyn_run') -#endif - RC_RUN=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** EXTRACT THE TIMESTEP COUNT FROM THE CLOCK. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Retrieve Timestep from FIM Clock in Dynamics Run" - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock =CLOCK_FIM & !<-- The ESMF clock - ,advanceCount=NTIMESTEP_ESMF & !<-- The number of times the clock has been advanced - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NTIMESTEP=NTIMESTEP_ESMF -! -! NOTE: Pointers in import and export states point to internal state as -! NOTE: set up in the init phase, consistent with future plans for NEMS. -! NOTE: So wrap%int_state is not needed here at present, nor are explicit -! NOTE: transfers between internal and import/export states. -!TODO: adjust as plans evolve - -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** THE MAIN DYNAMICS INTEGRATION LOOP. -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - its = NTIMESTEP + 1 - CALL DYN_RUN_FIM (its) -! -!----------------------------------------------------------------------- -! - RC=0 -! - IF(RC_RUN==ESMF_SUCCESS)THEN -! WRITE(0,*)'DYN RUN STEP SUCCEEDED' - ELSE - WRITE(0,*)'DYN RUN STEP FAILED RC_RUN=',RC_RUN - ENDIF -! -!----------------------------------------------------------------------- -! -#ifdef MANUALGPTL - ret = gptlstop ('dyn_run') -#endif - END SUBROUTINE DYN_RUN -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE DYN_FINALIZE(DYN_GRID_COMP & - ,IMP_STATE_WRITE & - ,EXP_STATE_WRITE & - ,CLOCK_FIM & - ,RCFINAL) -! -!----------------------------------------------------------------------- -!*** FINALIZE THE DYNAMICS COMPONENT. -!----------------------------------------------------------------------- -! - USE module_fim_dyn_finalize ,only: DYN_FINALIZE_FIM => dyn_finalize -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -!*** ARGUMENT VARIABLES -!----------------------------------------------------------------------- -! - TYPE(ESMF_GridComp),INTENT(INOUT) :: DYN_GRID_COMP !<-- The Dynamics gridded component - TYPE(ESMF_State) ,INTENT(INOUT) :: IMP_STATE_WRITE !<-- The Dynamics import state - TYPE(ESMF_State), INTENT(INOUT) :: EXP_STATE_WRITE !<-- The Dynamics export state - TYPE(ESMF_Clock) ,INTENT(INOUT) :: CLOCK_FIM !<-- The FIM component's ESMF Clock. -! - INTEGER ,INTENT(OUT) :: RCFINAL -! -!----------------------------------------------------------------------- -!*** LOCAL VARIABLES -!----------------------------------------------------------------------- -! - INTEGER :: RC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RCFINAL=ESMF_SUCCESS -! - CALL DYN_FINALIZE_FIM -! - ! destroy the grid created during DYN_INITIALIZE - call ESMF_GridDestroy(GRID_FIM_DYN,rc=rc) - CALL ERR_MSG(RC,"DYN_FINALIZE: destroy GRID_FIM_DYN",RCFINAL) -! -!----------------------------------------------------------------------- -! - END SUBROUTINE DYN_FINALIZE - - - END MODULE MODULE_DYNAMICS_GRID_COMP - diff --git a/src/fim/module_DYN_PHY_CPL_COMP.F90 b/src/fim/module_DYN_PHY_CPL_COMP.F90 deleted file mode 100644 index 1781387..0000000 --- a/src/fim/module_DYN_PHY_CPL_COMP.F90 +++ /dev/null @@ -1,1224 +0,0 @@ -!JR Copied from fimlatest -!TODO: DRY out all of this code. Initial NEMS was not DRY. We can be. -!----------------------------------------------------------------------- -! - MODULE MODULE_DYN_PHY_CPL_COMP -! -!----------------------------------------------------------------------- -! -!*** THIS MODULE HOLDS THE COUPLER'S REGISTER, INIT, RUN, AND FINALIZE -!*** ROUTINES. THEY ARE CALLED FROM THE FIM GRIDDED COMPONENT -!*** IN module_FIM_GRID_COMP.F90. -! -!*** THE COUPLER PROVIDES 2-WAY COUPLING BETWEEN THE DYNAMICS AND -!*** PHYSICS GRIDDED COMPONENTS BY TRANSFERING THEIR EXPORT AND -!*** IMPORT STATES BETWEEN THE TWO. -! -!----------------------------------------------------------------------- -! - USE ESMF -! - USE MODULE_ERR_MSG,ONLY: ERR_MSG,MESSAGE_CHECK -!JR module_nems_share doesn't seem to exist anymore. Comment out since we may go to GPTL anyway -!JR USE MODULE_NEMS_SHARE,ONLY : TIMEF - USE MACHINE ,only: kind_evod,kind_phys,kind_rad -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: DYN_PHY_CPL_REGISTER - public :: cpl_initialize !JR Make this public so can call directly -! -!----------------------------------------------------------------------- -! - REAL*8 :: btim0 - REAL*8, PUBLIC :: cpl_dyn_phy_tim -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- - -! Pointers to arrays to be coupled. These pointers are set to point to -! fields in corresponding states prior to use. - -!----------------------------------------------------------------------- -! FIM import state -!----------------------------------------------------------------------- -real,pointer :: fim_imp_us3d(:,:) ! FIM zonal wind (m/s), layer -real,pointer :: fim_imp_vs3d(:,:) ! FIM meridional wind (m/s), layer -real,pointer :: fim_imp_tr3d(:,:,:) ! FIM tracers -real,pointer :: fim_imp_rn2d(:) ! FIM accumulated total precipitation/rainfall -real,pointer :: fim_imp_rc2d(:) ! FIM accumulated convective precipitation/rainfall -real,pointer :: fim_imp_ts2d(:) ! FIM skin temperature -real,pointer :: fim_imp_us2d(:) ! FIM friction velocity/equivalent momentum flux -real,pointer :: fim_imp_hf2d(:) ! FIM sensible heat flux -real,pointer :: fim_imp_qf2d(:) ! FIM water vapor/equivalent latent heat flux -real,pointer :: fim_imp_sheleg2d(:) -real,pointer :: fim_imp_canopy2d(:) -real,pointer :: fim_imp_hice2d(:) -real,pointer :: fim_imp_fice2d(:) -real,pointer :: fim_imp_st3d(:,:) ! FIM soil temperature -real,pointer :: fim_imp_sm3d(:,:) ! FIM soil moisture -real,pointer :: fim_imp_sw2d(:) ! FIM downward short-wave radiation flux -real,pointer :: fim_imp_lw2d(:) ! FIM downward long-wave radiation flux -real,pointer :: fim_imp_t2m2d(:) ! FIM 2-meter temp. -real,pointer :: fim_imp_q2m2d(:) ! FIM 2-meter spfh -real,pointer :: fim_imp_slmsk2d(:) -real,pointer :: fim_imp_hprm2d(:,:) ! FIM soil temperature -real,pointer :: fim_imp_flxlwtoa2d(:) -!----------------------------------------------------------------------- -! FIM export state -!----------------------------------------------------------------------- -real,pointer :: fim_exp_pr3d(:,:) ! FIM pressure (pascal) -real,pointer :: fim_exp_us3d(:,:) ! FIM zonal wind (m/s), layer -real,pointer :: fim_exp_vs3d(:,:) ! FIM meridional wind (m/s), layer -real,pointer :: fim_exp_ws3d(:,:) ! FIM vertical wind (m/s), layer -real,pointer :: fim_exp_tr3d(:,:,:) ! FIM tracers -!----------------------------------------------------------------------- -! GFS import state -!----------------------------------------------------------------------- -real(kind=kind_evod) ,pointer :: gfs_imp_ps(:) -real(kind=kind_evod) ,pointer :: gfs_imp_dp(:,:) -real(kind=kind_evod) ,pointer :: gfs_imp_p(:,:) -real(kind=kind_evod) ,pointer :: gfs_imp_u(:,:) -real(kind=kind_evod) ,pointer :: gfs_imp_v(:,:) -real(kind=kind_evod) ,pointer :: gfs_imp_dpdt(:,:) -real(kind=kind_evod) ,pointer :: gfs_imp_q(:,:) -real(kind=kind_evod) ,pointer :: gfs_imp_oz(:,:) -real(kind=kind_evod) ,pointer :: gfs_imp_cld(:,:) -real(kind=kind_evod) ,pointer :: gfs_imp_t(:,:) -!----------------------------------------------------------------------- -! GFS export state -!----------------------------------------------------------------------- -real(kind=kind_evod) ,pointer :: gfs_exp_p(:,:) -real(kind=kind_evod) ,pointer :: gfs_exp_u(:,:) -real(kind=kind_evod) ,pointer :: gfs_exp_v(:,:) -real(kind=kind_evod) ,pointer :: gfs_exp_q(:,:) -real(kind=kind_evod) ,pointer :: gfs_exp_cld(:,:) -real(kind=kind_evod) ,pointer :: gfs_exp_t(:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_geshem(:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_rainc(:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_tsea(:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_uustar(:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_hflx(:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_evap(:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_sheleg(:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_canopy(:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_hice(:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_fice(:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_stc(:,:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_smc(:,:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_sfcdsw(:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_sfcdlw(:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_t2m(:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_q2m(:,:) -real(kind=kind_phys) ,pointer :: gfs_exp_slmsk(:,:) -real(kind=kind_rad) ,pointer :: gfs_exp_hprime(:,:,:) -real(kind=kind_rad) ,pointer :: gfs_exp_fluxr(:,:,:) - -!----------------------------------------------------------------------- - - CONTAINS -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE DYN_PHY_CPL_REGISTER(CPL_COMP,IRC_REG) -! -!----------------------------------------------------------------------- -!*** REGISTER THE COUPLER COMPONENT'S INITIALIZE, RUN, AND FINALIZE -!*** ROUTINES. -!----------------------------------------------------------------------- -! - TYPE(ESMF_CplComp),INTENT(INOUT) :: CPL_COMP ! Coupler component -! - INTEGER,INTENT(OUT) :: IRC_REG ! Return code for register -! -!----------------------------------------------------------------------- -!*** LOCAL VARIABLES -!----------------------------------------------------------------------- -! - INTEGER :: IRC=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - IRC_REG=ESMF_SUCCESS ! The error signal variable - -!----------------------------------------------------------------------- -!*** REGISTER THE COUPLER INITIALIZE SUBROUTINE. SINCE IT IS JUST ONE -!*** SUBROUTINE, USE ESMF_SINGLEPHASE. THE SECOND ARGUMENT IS -!*** A PRE-DEFINED SUBROUTINE TYPE, SUCH AS ESMF_SETINIT, ESMF_SETRUN, -!*** OR ESMF_SETFINAL. -!----------------------------------------------------------------------- -! - CALL ESMF_LogWrite("Set Entry Point for Coupler Initialize" & - ,ESMF_LOG_INFO,RC=IRC) -! - CALL ESMF_CplCompSetEntryPoint(CPL_COMP & !<-- cplcomp - ,ESMF_SETINIT & !<-- subroutineType - ,CPL_INITIALIZE & !<-- user's subroutineName - ,ESMF_SINGLEPHASE & !<-- phase - ,IRC) -! - IF(ESMF_LogMsgFoundError(IRC,"Set Entry Point for Coupler Initialize"))THEN - IRC_REG=ESMF_FAILURE - WRITE(0,*)'Error Setting the Entry Point for Coupler Initialize, RC =',IRC - IRC=ESMF_SUCCESS - ENDIF -! -!----------------------------------------------------------------------- -!*** REGISTER THE COUPLER RUN SUBROUTINE. -!----------------------------------------------------------------------- -! - CALL ESMF_LogWrite("Set Entry Point for Coupler Run" & - ,ESMF_LOG_INFO,RC=IRC) -! - CALL ESMF_CplCompSetEntryPoint(CPL_COMP & !<-- cplcomp - ,ESMF_SETRUN & !<-- subroutineType - ,CPL_RUN & !<-- user's subroutineName - ,ESMF_SINGLEPHASE & !<-- phase - ,IRC) -! - IF(ESMF_LogMsgFoundError(IRC,"Set Entry Point for Coupler Run"))THEN - IRC_REG=ESMF_FAILURE - WRITE(0,*)'Error Setting the Entry Point for Coupler Run, RC =',IRC - IRC=ESMF_SUCCESS - ENDIF -! -!----------------------------------------------------------------------- -!*** REGISTER THE COUPLER FINALIZE SUBROUTINE. -!----------------------------------------------------------------------- -! - CALL ESMF_LogWrite("Set Entry Point for Coupler Finalize" & - ,ESMF_LOG_INFO,RC=IRC) -! - CALL ESMF_CplCompSetEntryPoint(CPL_COMP & !<-- cplcomp - ,ESMF_SETFINAL & !<-- subroutineType - ,CPL_FINALIZE & !<-- user's subroutineName - ,ESMF_SINGLEPHASE & !<-- phase - ,IRC) -! - IF(ESMF_LogMsgFoundError(IRC,"Set Entry Point for Coupler Finalize"))THEN - IRC_REG=ESMF_FAILURE - WRITE(0,*)'Error Setting the Entry Point for Coupler Finalize, RC =',IRC - ENDIF -! -!----------------------------------------------------------------------- -!*** CHECK THE ERROR SIGNAL VARIABLE. -!----------------------------------------------------------------------- -! - IF(IRC_REG==ESMF_SUCCESS)THEN -! WRITE(0,*)" COUPLER_REGISTER SUCCEEDED" - ELSE - WRITE(0,*)" COUPLER_REGISTER FAILED" - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE DYN_PHY_CPL_REGISTER -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE CPL_INITIALIZE(CPL_COMP,IMP_STATE,EXP_STATE,CLOCK & - ,IRC_CPL) -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** SET UP THE COUPLER. -!----------------------------------------------------------------------- -! - ! FIM dynamics + GFS physics - USE module_fim_cpl_init ,only: CPL_INITIALIZE_FIM_GFS => cpl_init -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -!*** ARGUMENT VARIABLES. -!----------------------------------------------------------------------- -! - TYPE(ESMF_CplComp),INTENT(INOUT) :: CPL_COMP - TYPE(ESMF_State), INTENT(INOUT) :: IMP_STATE - TYPE(ESMF_State), INTENT(INOUT) :: EXP_STATE - TYPE(ESMF_Clock), INTENT(IN) :: CLOCK -! - INTEGER, INTENT(OUT) :: IRC_CPL -! -!----------------------------------------------------------------------- -!*** LOCAL VARIABLES -!----------------------------------------------------------------------- -! - INTEGER :: IRCFINAL -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - cpl_dyn_phy_tim=0. -!----------------------------------------------------------------------- -!*** INITIALIZE THE ERROR SIGNAL VARIABLES. -!----------------------------------------------------------------------- -! - IRCFINAL=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** INITIALIZE THE PHYSICS SCHEMES. -!----------------------------------------------------------------------- -! -!TODO: Note that the latest FIM does delegate creation of the ESMF_Grid to -!TODO: the DYN component. This grid is then used by the FIM and PHY -!TODO: components. However, coordinates are not set in the ESMF_Grid so -!TODO: we still need a better approach for handling lat/lon. -!TODO: -!TODO: We appear to have three cases of interest for handling lat,lon during -!TODO: component initialization: -!TODO: A) PHY runs on the same lat,lon grid as DYN and FIM. ATM also uses -!TODO: this grid (i.e. for coupling with OCN, etc.). -!TODO: B) PHY and DYN run on independent grids. ATM/FIM and DYN share -!TODO: the same grid. -!TODO: C) PHY and DYN run on independent grids. ATM/FIM and PHY share -!TODO: the same grid. -!TODO: NMMB and FIM use case "A". GFS also uses "A" for the physical-space -!TODO: grid. Spectral grids appear to be handled internally to GFS DYN. -!TODO: "B" and "C" are impractical due to the excessive cost of re-gridding -!TODO: full 3D arrays every time step. -!TODO: -!TODO: For FIM, we'd like to have the option of using case "A" with the NCEP -!TODO: GFS physics component. That way we could grab the latest GFS PHY -!TODO: component and hook it up without going into -!TODO: gfs_phy_initialize()->gfs_physics_initialize()->fix_fields()-> -!TODO: LONLAT_PARA() and inserting our own lat,lon computation (or performing -!TODO: some other ugly hackery.) It would make it easier to swap GFS PHY -!TODO: between GFS DYN and FIM DYN. -!TODO: -!TODO: Logic of ESMF_Grid creation in the FIM component now proceeds as -!TODO: follows: -!TODO: 1) The ATM component does not attach an ESMF_Grid to the FIM -!TODO: component. -!TODO: 2) The FIM component does not attach an ESMF_Grid to the DYN -!TODO: component. -!TODO: 3) The DYN component creates an ESMF_Grid and attaches it to -!TODO: itself. DYN does *not* yet fill in lat,lon coordinates. -!TODO: 4) The FIM extracts the ESMF_Grid from the DYN component after -!TODO: dyn_initialize() and attaches it to itself and to the PHY -!TODO: component. -!TODO: 5) The ATM component does not yet use the ESMF_Grid available -!TODO: via the FIM component. -!TODO: -!TODO: Since this pattern is not yet implemented in NEMS, we pass lat,lon -!TODO: from FIM DYN to PHY in cpl_init.F90 via cpl_init_dyn_to_phy(). We -!TODO: need to extend step #3 to include initialization of ESMF_Grid -!TODO: coordinates to pass lat/lon via the ESMF_Grid instead of via -!TODO: ESMF_State objects. Also, step #5 needs to be addressed in the -!TODO: NCEP code to allow ATM to use the ESMF_Grid attached to the -!TODO: FIM/NMMB/GFS component. -!TODO: -!TODO: Also there is a desire to write some of the PHY variables to the FIM -!TODO: history output stream during the first (0h) write. This is currently -!TODO: handled by passing these fields from PHY to DYN via a call to -!TODO: cpl_init_phy_to_dyn(). Future NEMS I/O component(s) may allow this -!TODO: to be handled in another way. -!TODO: - CALL CPL_INITIALIZE_FIM_GFS -! -!----------------------------------------------------------------------- -! - IF(IRCFINAL==ESMF_SUCCESS)THEN -! WRITE(0,*)"CPL INITIALIZE STEP SUCCEEDED" - ELSE - WRITE(0,*)"CPL INITIALIZE STEP FAILED" - ENDIF -! - IRC_CPL=IRCFINAL -! -!----------------------------------------------------------------------- -! - END SUBROUTINE CPL_INITIALIZE -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE CPL_RUN(CPL_COMP,IMP_STATE,EXP_STATE,CLOCK,IRC_CPL) -! -!----------------------------------------------------------------------- -!*** RUN THE COUPLER TO TRANSFER DATA BETWEEN THE GRIDDED COMPONENTS. -!----------------------------------------------------------------------- -! - ! FIM dynamics + GFS physics - USE module_fim_cpl_run ,only: CPL_DYN_TO_PHY, CPL_PHY_TO_DYN - -!TODO: REMOVE THIS use-association! Refactor or replace with ESMF_Alarms - use module_control ,only: nts,CallPhysics - -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -!*** ARGUMENT VARIABLES -!----------------------------------------------------------------------- -! - TYPE(ESMF_CplComp),INTENT(INOUT) :: CPL_COMP - TYPE(ESMF_State), INTENT(INOUT) :: IMP_STATE - TYPE(ESMF_State), INTENT(INOUT) :: EXP_STATE - TYPE(ESMF_Clock), INTENT(IN) :: CLOCK -! - INTEGER, INTENT(OUT) :: IRC_CPL -! -!----------------------------------------------------------------------- -!*** LOCAL VARIABLES -!----------------------------------------------------------------------- -! - INTEGER :: IRCFINAL - INTEGER :: NTIMESTEP,RC - INTEGER(KIND=ESMF_KIND_I8) :: NTIMESTEP_ESMF - INTEGER :: its - character(esmf_maxstr) :: import_statename - character(esmf_maxstr) :: export_statename - ! temporary field object -! TYPE(ESMF_Field) :: TMP_FIELD - TYPE(ESMF_Array) :: TMP_ARRAY -! -! TYPE(ESMF_RouteHandle) :: ROUTEHANDLE -! -!----------------------------------------------------------------------- -!*********************************************************************** -! -!JR btim0=timef() -!----------------------------------------------------------------------- -!*** INITIALIZE THE ERROR SIGNAL VARIABLES. -!----------------------------------------------------------------------- -! - IRCFINAL=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** EXTRACT THE TIMESTEP COUNT FROM THE CLOCK. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Retrieve Timestep from FIM Clock in Physics Run" - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock =CLOCK & !<-- The ESMF clock - ,advanceCount=NTIMESTEP_ESMF & !<-- The number of times the clock has been advanced - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NTIMESTEP=NTIMESTEP_ESMF -! -!----------------------------------------------------------------------- -!*** COUPLE from DYN->PHY or PHY->DYN -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** determine the direction of the transfer by extracting -!*** the statename from the import state. -!----------------------------------------------------------------------- -! - call esmf_logwrite("retrieve state name in coupler" & - ,esmf_log_info,rc=rc) -! - call esmf_stateget(imp_state & - ,name =import_statename & - ,rc =rc) - call esmf_stateget(exp_state & - ,name =export_statename & - ,rc =rc) -! -! print *,'CPL_RUN: move data from(',trim(import_statename), ') to (', & -! trim(export_statename), ')' -! - its = NTIMESTEP + 1 -!TODO: Replace all of this "its" stuff with ESMF_Alarms. -!TODO: Then eliminate dependence on nts and CallPhysics. -!TODO: Note that GFS has no concept of not calling physics every time step! -!TODO: OR, shove "if" statements down into CPL_DYN_TO_PHY and CPL_PHY_TO_DYN - if (its <= nts ) then - !TODO: Eliminate duplication by encapsulating this logic - if(mod(its,CallPhysics)==0.or.its==1) then ! Do physics - ! Note that state names are set in fim_initialize() - if ( (trim(import_statename).eq.'FIM dynamics export') .and. & - (trim(export_statename).eq.'FIM physics import') ) then -! -! extract pointers from ESMF_States and stuff in fim_* and gfs_* pointers -! - MESSAGE_CHECK="Get pr3d array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='pr3d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get pr3d pointer from imported array" -!TBH: Note that the following calls with named parameters causes ifort to -!TBH: complain whine that "There is no matching specific subroutine for -!TBH: this generic subroutine call." Removing the first three dummy -!TBH: argument named makes ifort happy. -! CALL ESMF_FieldGet(field =TMP_FIELD & -! ,localDe=0 & -! ,farrayPtr=fim_exp_pr3d & -! ,rc =RC) -!TBH: Futher note that ESMF_Field did not work for reasons not yet known. -!TBH: (See comments in module_DYNAMICS_GRID_COMP.F90 and -!TBH: module_PHYSICS_GRID_COMP.F90). Switched to ESMF_Array until this -!TBH: problem is resolved. -! CALL ESMF_FieldGet(TMP_FIELD,0,fim_exp_pr3d,rc=RC) -!TODO: Switch back to ESMF_Field since future NEMS will use ESMF_Fields. - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_exp_pr3d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get us3d array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='us3d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get us3d pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_exp_us3d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get vs3d array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='vs3d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get vs3d pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_exp_vs3d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get ws3d array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='ws3d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get ws3d pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_exp_ws3d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get tr3d array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='tr3d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get tr3d pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_exp_tr3d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get ps array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='ps' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get ps pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_imp_ps,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get t array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='t' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get t pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_imp_t,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get u array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='u' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get u pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_imp_u,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get v array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='v' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get v pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_imp_v,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get q array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='shum' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get q pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_imp_q,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get oz array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='oz' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get oz pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_imp_oz,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get cld array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='cld' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get cld pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_imp_cld,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get p array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='p' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get p pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_imp_p,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get dp array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='dp' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get dp pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_imp_dp,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get dpdt array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='dpdt' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get dpdt pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_imp_dpdt,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - ! couple from dynamics to physics - CALL CPL_DYN_TO_PHY(its, & - ! IN args - fim_exp_pr3d, fim_exp_us3d, fim_exp_vs3d, fim_exp_ws3d, & - fim_exp_tr3d, & - ! OUT args - gfs_imp_ps, gfs_imp_dp, gfs_imp_p, gfs_imp_u, gfs_imp_v, & - gfs_imp_dpdt, gfs_imp_q, gfs_imp_oz, gfs_imp_cld, & - gfs_imp_t) - else if ( (trim(import_statename).eq.'FIM physics export') .and. & - (trim(export_statename).eq.'FIM dynamics import') ) then -! -! extract pointers from ESMF_States and stuff in fim_* and gfs_* pointers -! - MESSAGE_CHECK="Get p array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='p' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get p pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_p,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get u array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='u' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get u pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_u,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get v array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='v' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get v pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_v,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get q array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='shum' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get q pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_q,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get cld array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='cld' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get cld pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_cld,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get t array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='t' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get t pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_t,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get geshem array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='geshem' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get geshem pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_geshem,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get rainc array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='rainc' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get rainc pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_rainc,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get tsea array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='tsea' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get tsea pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_tsea,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get uustar array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='uustar' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get uustar pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_uustar,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get hflx array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='hflx' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get hflx pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_hflx,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get evap array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='evap' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get evap pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_evap,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get sheleg array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='sheleg' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get sheleg pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_sheleg,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get canopy array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='canopy' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get canopy pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_canopy,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get hice array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='hice' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get hice pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_hice,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get fice array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='fice' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get fice pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_fice,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get stc array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='stc' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get stc pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_stc,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get smc array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='smc' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get smc pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_smc,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get sfcdsw array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='sfcdsw' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get sfcdsw pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_sfcdsw,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get sfcdlw array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='sfcdlw' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get sfcdlw pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_sfcdlw,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get t2m array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='t2m' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get t2m pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_t2m,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get q2m array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='q2m' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get q2m pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_q2m,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get slmsk array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='slmsk' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get slmsk pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_slmsk,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get hprime array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='hprime' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get hprime pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_hprime,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get fluxr array from import state" - CALL ESMF_StateGet(state =IMP_STATE & - ,itemName ='fluxr' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get fluxr pointer from imported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,gfs_exp_fluxr,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - - MESSAGE_CHECK="Get us3d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='us3d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get us3d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_us3d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get vs3d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='vs3d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get vs3d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_vs3d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get tr3d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='tr3d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get tr3d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_tr3d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get rn2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='rn2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get rn2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_rn2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get rc2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='rc2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get rc2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_rc2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get ts2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='ts2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get ts2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_ts2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get us2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='us2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get us2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_us2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get hf2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='hf2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get hf2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_hf2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get qf2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='qf2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get qf2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_qf2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get sheleg2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='sheleg2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get sheleg2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_sheleg2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get canopy2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='canopy2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get canopy2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_canopy2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get hice2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='hice2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get hice2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_hice2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get fice2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='fice2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get fice2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_fice2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get st3d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='st3d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get st3d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_st3d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get sm3d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='sm3d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get sm3d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_sm3d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get sw2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='sw2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get sw2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_sw2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get lw2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='lw2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get lw2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_lw2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get t2m2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='t2m2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get t2m2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_t2m2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get q2m2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='q2m2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get q2m2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_q2m2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get slmsk2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='slmsk2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get slmsk2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_slmsk2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get hprm2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='hprm2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get hprm2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_hprm2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - MESSAGE_CHECK="Get flxlwtoa2d array from export state" - CALL ESMF_StateGet(state =EXP_STATE & - ,itemName ='flxlwtoa2d' & - ,array =TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - MESSAGE_CHECK="Get flxlwtoa2d pointer from exported array" - CALL ESMF_ArrayGet(TMP_ARRAY,0,fim_imp_flxlwtoa2d,rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,IRCFINAL) - - ! couple from physics to dynamics - CALL CPL_PHY_TO_DYN(its, & - ! IN args - gfs_exp_p, gfs_exp_u , gfs_exp_v, & - gfs_exp_q, gfs_exp_cld, gfs_exp_t, & - ! these GFS PHY fields are passed to FIM DYN for - ! output and diagnostics only. - gfs_exp_geshem, gfs_exp_rainc, & - gfs_exp_tsea, gfs_exp_uustar, & - gfs_exp_hflx, gfs_exp_evap, & - gfs_exp_sheleg, gfs_exp_canopy, & - gfs_exp_hice, gfs_exp_fice, & - gfs_exp_stc, gfs_exp_smc, & - gfs_exp_sfcdsw, gfs_exp_sfcdlw, & - gfs_exp_t2m, gfs_exp_q2m, & - gfs_exp_slmsk, gfs_exp_hprime, & - gfs_exp_fluxr, & - ! OUT args - fim_imp_us3d, fim_imp_vs3d, & - fim_imp_tr3d, & - fim_imp_rn2d, fim_imp_rc2d, & - fim_imp_ts2d, fim_imp_us2d, & - fim_imp_hf2d, fim_imp_qf2d, & - fim_imp_sheleg2d, fim_imp_canopy2d, & - fim_imp_hice2d, fim_imp_fice2d, & - fim_imp_st3d, fim_imp_sm3d, & - fim_imp_sw2d, fim_imp_lw2d, & - fim_imp_t2m2d, fim_imp_q2m2d, & - fim_imp_slmsk2d, fim_imp_hprm2d, & - fim_imp_flxlwtoa2d ) - else - WRITE(0,*)"ERROR: UNEXPECTED STATE NAME IN CPL_RUN" - IRCFINAL = esmf_failure - endif - - endif ! CallPhysics - - endif -! - IF(IRCFINAL==ESMF_SUCCESS)THEN -! WRITE(0,*)"CPL RUN STEP SUCCEEDED" - ELSE - WRITE(0,*)"CPL RUN STEP FAILED" - ENDIF -! - IRC_CPL=IRCFINAL -! -!JR cpl_dyn_phy_tim=cpl_dyn_phy_tim+timef()-btim0 -! -!----------------------------------------------------------------------- -! - END SUBROUTINE CPL_RUN -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE CPL_FINALIZE(CPL_COMP,IMP_STATE,EXP_STATE,CLOCK,IRC_CPL) -! -!----------------------------------------------------------------------- -!*** FINALIZE THE COUPLER. -!----------------------------------------------------------------------- -! - ! FIM dynamics + GFS physics - USE module_fim_cpl_finalize ,only: CPL_FINALIZE_FIM_GFS => cpl_finalize -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -!*** ARGUMENT VARIABLES. -!----------------------------------------------------------------------- -! - TYPE(ESMF_CplComp),INTENT(INOUT) :: CPL_COMP - TYPE(ESMF_State), INTENT(INOUT) :: IMP_STATE - TYPE(ESMF_State), INTENT(INOUT) :: EXP_STATE - TYPE(ESMF_Clock), INTENT(IN) :: CLOCK -! - INTEGER, INTENT(OUT) :: IRC_CPL -! -!----------------------------------------------------------------------- -!*** LOCAL VARIABLES -!----------------------------------------------------------------------- -! - INTEGER :: IRCFINAL -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - IRCFINAL=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** FINALIZE THE PHYSICS COMPONENT. -!----------------------------------------------------------------------- -! - CALL CPL_FINALIZE_FIM_GFS -! -!----------------------------------------------------------------------- -! - IF(IRCFINAL==ESMF_SUCCESS)THEN -! WRITE(0,*)"CPL FINALIZE STEP SUCCEEDED" - ELSE - WRITE(0,*)"CPL FINALIZE STEP FAILED" - ENDIF -! - IRC_CPL=IRCFINAL -! -!----------------------------------------------------------------------- -! - END SUBROUTINE CPL_FINALIZE -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! - END MODULE MODULE_DYN_PHY_CPL_COMP -! -!----------------------------------------------------------------------- diff --git a/src/fim/module_FIM_INTEGRATE.F90 b/src/fim/module_FIM_INTEGRATE.F90 deleted file mode 100644 index 827a2c2..0000000 --- a/src/fim/module_FIM_INTEGRATE.F90 +++ /dev/null @@ -1,157 +0,0 @@ -module module_FIM_INTEGRATE - use ESMF - use module_err_msg - - ! TODO: move this to internal state - use module_core_setup ,only: use_write_tasks - ! TODO: not sure if this needs to move - use icosio,only:icosio_end_frame - - implicit none - private - - public :: fim_integrate - -CONTAINS - -! only FIM compute tasks execute this routine - subroutine fim_integrate (gc_fim_dyn, & - gc_fim_phy, & - gc_fim_cpl, & - imp_fim_dyn, & - exp_fim_dyn, & - imp_fim_phy, & - exp_fim_phy, & - clock_fim, & - rc_integrate) - - type(esmf_gridcomp), intent(inout) :: gc_fim_dyn - type(esmf_gridcomp), intent(inout) :: gc_fim_phy - type(esmf_cplcomp), intent(inout) :: gc_fim_cpl - type(esmf_state), intent(inout) :: imp_fim_dyn - type(esmf_state), intent(inout) :: exp_fim_dyn - type(esmf_state), intent(inout) :: imp_fim_phy - type(esmf_state), intent(inout) :: exp_fim_phy - type(esmf_clock), intent(inout) :: clock_fim - integer, intent( out) :: rc_integrate -! -! Local variables -! - integer :: rc - integer(esmf_kind_i8) :: ntimestep_esmf - integer :: ntimestep - type(esmf_timeinterval) :: timestep - type(esmf_time) :: stoptime, newstoptime - - ! Run the clock one more time step (i.e. stop after its=nts+1), then - ! back up one step to mimic run.F90. - ! * set stoptime = stoptime+dt - ! * run "integrate" loop - ! * set ESMF_MODE_REVERSE - ! * advance backwards one time step - ! * set ESMF_MODE_FORWARD - ! * reset stoptime to its original value - !NOTE: This hackery works around the fact that the original - !NOTE: FIM run.F90 executes one extra time step in which the - !NOTE: dynamics component finishes its final computations. This - !NOTE: was required by early versions of NEMS which did not - !NOTE: allow multiple run phases. See run.F90 for a very - !NOTE: detailed discussion of this issue. - !NOTE: This complexity could be avoided if we allowed a 2-phase - !NOTE: run method for the DYN component -- and run.F90 would - !NOTE: also be simplified. However, interoperability with other - !NOTE: components would be more difficult due to potential - !NOTE: mismatches in numbers of phases. - - call esmf_clockget (clock=clock_fim, stoptime=stoptime, rc=rc) - call err_msg (rc,'esmf_clockget(stoptime)', rc_integrate) - call esmf_clockget (clock=clock_fim, timestep=timestep, rc=rc) - call err_msg (rc,'esmf_clockget(timestep)', rc_integrate) - newstoptime = stoptime + timestep - call esmf_clockset(clock=clock_fim, stoptime=newstoptime, rc=rc) - call err_msg (rc,'esmf_clockset(newstoptime)', rc_integrate) - - integrate: do while (.not. esmf_clockisstoptime (clock_fim, rc=rc)) - call err_msg (rc,'esmf_clockisstoptime', rc_integrate) -! -!----------------------------------------------------------------------- -!*** Execute the Run step of the Dynamics component. -!----------------------------------------------------------------------- -! - call esmf_logwrite("execute fim dynamics", esmf_log_info, rc=rc) - call esmf_gridcomprun (gridcomp =gc_fim_dyn, & - importstate=imp_fim_dyn, & - exportstate=exp_fim_dyn, & - clock =clock_fim, & - rc =rc) - call err_msg (rc,'execute fim dynamics', rc_integrate) -! -!----------------------------------------------------------------------- -!*** Bring export data from the Dynamics into the coupler -!*** and export it to the Physics. -!----------------------------------------------------------------------- -! - call esmf_logwrite ("couple dyn_exp-to-phy_imp", esmf_log_info, rc=rc) - call esmf_cplcomprun (cplcomp =gc_fim_cpl, & - importstate=exp_fim_dyn, & - exportstate=imp_fim_phy, & - clock =clock_fim, & - rc =rc) - call err_msg (rc,'couple dyn_exp-to-phy_imp', rc_integrate) -! -!----------------------------------------------------------------------- -!*** Execute the Run step of the Physics Component. -!----------------------------------------------------------------------- -! - call esmf_logwrite ("execute physics", esmf_log_info, rc=rc) - call esmf_gridcomprun (gridcomp =gc_fim_phy, & - importstate=imp_fim_phy, & - exportstate=exp_fim_phy, & - clock =clock_fim, & - rc =rc) - call err_msg (rc, 'execute physics', rc_integrate) -! -!----------------------------------------------------------------------- -!*** Bring export data from the Physics into the coupler -!*** and export it to the Dynamics. -!----------------------------------------------------------------------- -! - call esmf_logwrite ("couple phy_exp-to-dyn_imp", esmf_log_info, rc=rc) - call esmf_cplcomprun (cplcomp =gc_fim_cpl, & - importstate=exp_fim_phy, & - exportstate=imp_fim_dyn, & - clock =clock_fim, & - rc =rc) - call err_msg (rc, 'couple phy_exp-to-dyn_imp', rc_integrate) -! -!----------------------------------------------------------------------- -!*** Flush buffered output to write tasks and/or clear list of files -!*** written to during this output frame. -!----------------------------------------------------------------------- -! - call esmf_clockget (clock=clock_fim,advancecount=ntimestep_esmf,rc=rc) - call err_msg (rc, 'get time step from clock', rc_integrate) - ntimestep = ntimestep_esmf - call icosio_end_frame(ntimestep) -! -!----------------------------------------------------------------------- -!*** Advance clock to next time step. -!----------------------------------------------------------------------- -! - call esmf_clockadvance (clock=clock_fim, rc=rc) - call err_msg (rc, 'advance clock', rc_integrate) - - end do integrate ! time step loop - - ! reset clock to state expected by caller upon return - call esmf_clockset(clock=clock_fim, direction=ESMF_MODE_REVERSE, rc=rc) - call err_msg (rc,'esmf_clockset(ESMF_MODE_REVERSE)', rc_integrate) - call esmf_clockadvance(clock=clock_fim, rc=rc) - call err_msg (rc,'esmf_clockadvance(one step backwards)', rc_integrate) - call esmf_clockset(clock=clock_fim, direction=ESMF_MODE_FORWARD, rc=rc) - call err_msg (rc,'esmf_clockset(ESMF_MODE_FORWARD)', rc_integrate) - call esmf_clockset(clock=clock_fim, stoptime=stoptime, rc=rc) - call err_msg (rc,'esmf_clockset(restore original stoptime)', rc_integrate) - - end subroutine fim_integrate -end module module_FIM_INTEGRATE diff --git a/src/fim/module_PHYSICS_GRID_COMP.F90 b/src/fim/module_PHYSICS_GRID_COMP.F90 deleted file mode 100644 index 893eb77..0000000 --- a/src/fim/module_PHYSICS_GRID_COMP.F90 +++ /dev/null @@ -1,1544 +0,0 @@ -!JR copied from fimlatest -!TODO: DRY out all of this code. Initial NEMS was not DRY. We can be. -!----------------------------------------------------------------------- -! - MODULE MODULE_PHYSICS_GRID_COMP -! -!----------------------------------------------------------------------- -! -!*** THIS MODULE HOLDS THE PHYSICS REGISTER, INIT, RUN, AND FINALIZE -!*** ROUTINES. THEY ARE CALLED FROM THE MAIN GRIDDED COMPONENT -!*** (ATM INITIALIZE CALLS PHYSICS INITIALIZE, ETC.) -!*** IN MODULE_ATM_GRID_COMP.F. -! -!----------------------------------------------------------------------- -! - USE ESMF -! - USE MODULE_ERR_MSG,ONLY: ERR_MSG,MESSAGE_CHECK -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: PHY_REGISTER -! -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE PHY_REGISTER(GRID_COMP,RC_REG) -! -!----------------------------------------------------------------------- -!*** REGISTER THE PHYSICS COMPONENT'S INITIALIZE, RUN, AND FINALIZE -!*** ROUTINES. -!----------------------------------------------------------------------- -! - TYPE(ESMF_GridComp),INTENT(INOUT) :: GRID_COMP !<-- The Physics Gridded Component -! - INTEGER,INTENT(OUT) :: RC_REG !<-- Return code for Register -! -!----------------------------------------------------------------------- -!*** LOCAL VARIABLES -!----------------------------------------------------------------------- -! - INTEGER :: RC=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC_REG=ESMF_SUCCESS !<-- Initialize error signal variable - -!----------------------------------------------------------------------- -!*** REGISTER THE PHYSICS INITIALIZE SUBROUTINE. SINCE IT IS JUST ONE -!*** SUBROUTINE, USE ESMF_SINGLEPHASE. THE SECOND ARGUMENT IS -!*** A PRE-DEFINED SUBROUTINE TYPE, SUCH AS ESMF_SETINIT, ESMF_SETRUN, -!*** OR ESMF_SETFINAL. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for Physics Initialize" - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSetEntryPoint(GRID_COMP & !<-- Physics gridcomp - ,ESMF_SETINIT & !<-- Subroutine type - ,PHY_INITIALIZE & !<-- User's subroutine name - ,ESMF_SINGLEPHASE & !<-- Phase - ,RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** REGISTER THE PHYSICS RUN SUBROUTINE. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for Physics Run" - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSetEntryPoint(GRID_COMP & !<-- Physics gridcomp - ,ESMF_SETRUN & !<-- Subroutine type - ,PHY_RUN & !<-- User's subroutine name - ,ESMF_SINGLEPHASE & !<-- Phase - ,RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** REGISTER THE PHYSICS FINALIZE SUBROUTINE. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for Physics Finalize" - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSetEntryPoint(GRID_COMP & !<-- Physics gridcomp - ,ESMF_SETFINAL & !<-- Subroutine type - ,PHY_FINALIZE & !<-- User's subroutine name - ,ESMF_SINGLEPHASE & !<-- Phase - ,RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** CHECK THE ERROR SIGNAL VARIABLE. -!----------------------------------------------------------------------- -! - IF(RC_REG==ESMF_SUCCESS)THEN -! WRITE(0,*)' PHY_REGISTER SUCCEEDED' - ELSE - WRITE(0,*)' PHY_REGISTER FAILED RC_REG=',RC_REG - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PHY_REGISTER -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE PHY_INITIALIZE(GRID_COMP & - ,IMP_STATE,EXP_STATE & - ,CLOCK_ATM & - ,RC_INIT) -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** SET UP THE MODEL PHYSICS. -!----------------------------------------------------------------------- -! - USE module_fim_phy_init ,only: PHY_INITIALIZE_FIM => phy_init - USE gfs_physics_internal_state_mod, only: & - gfs_physics_internal_state, & - gis_phy, & - WRAP_INTERNAL_STATE => gfs_phy_wrap -! -!----------------------------------------------------------------------- -!*** ARGUMENT VARIABLES. -!----------------------------------------------------------------------- -! - TYPE(ESMF_GridComp),INTENT(INOUT) :: GRID_COMP !<-- The Physics gridded component - TYPE(ESMF_State), INTENT(INOUT) :: IMP_STATE !<-- The Physics Initialize step's import state - TYPE(ESMF_State), INTENT(INOUT) :: EXP_STATE !<-- The Physics Initialize step's export state - TYPE(ESMF_Clock), INTENT(IN) :: CLOCK_ATM !<-- The ATM's ESMF Clock -! - INTEGER, INTENT(OUT) :: RC_INIT -! -!----------------------------------------------------------------------- -!*** LOCAL VARIABLES -!----------------------------------------------------------------------- -!*** WRAP_INTERNAL_STATE IS DEFINED IN THE INTERNAL STATE MODULE. -!----------------------------------------------------------------------- -! - TYPE(WRAP_INTERNAL_STATE) :: WRAP !<-- This wrap is a derived type which contains - ! only a pointer to the internal state. It is needed - ! for using different architectures or compilers. -! -! TYPE(ESMF_Field) :: TMP_FIELD - TYPE(ESMF_Grid) :: GRID - TYPE(ESMF_DistGrid) :: DISTGRID - TYPE(ESMF_Array) :: TMP_ARRAY - INTEGER :: RC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** INITIALIZE THE ERROR SIGNAL VARIABLES. -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RC_INIT=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** INITIALIZE THE PHYSICS SCHEMES. -!----------------------------------------------------------------------- -! -! Allocate internal state and set up initial values for some fields. -! - CALL PHY_INITIALIZE_FIM -! -!----------------------------------------------------------------------- -!*** ATTACH THE INTERNAL STATE TO THE PHYSICS GRIDDED COMPONENT. -!----------------------------------------------------------------------- -! - WRAP%INT_STATE=>gis_phy -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK= & - "Attach Physics Internal State to the Gridded Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSetInternalState(GRID_COMP & !<-- Physics gridcomp - ,WRAP & !<-- Data pointer to internal state - ,RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - - MESSAGE_CHECK="PHY: Extract GRID from GRID_COMP" - call esmf_gridcompget(GRID_COMP, grid = GRID, rc = RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - - call esmf_gridvalidate(grid=GRID, rc=rc) - CALL ERR_MSG(RC,'PHY: validate GRID',RC_INIT) - - MESSAGE_CHECK="PHY: Extract DISTGRID from GRID" - CALL ESMF_GridGet(grid=GRID, distgrid=DISTGRID, rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - - call esmf_distgridvalidate(distgrid=DISTGRID, rc=rc) - CALL ERR_MSG(RC,'PHY: validate DISTGRID',RC_INIT) - -! Set flags to enable import/export of each field, hard-coded for the moment -!TODO: Read these from a config file as in GFS, adapting -!TODO: gfs_physics_getcf_mod.f - gis_phy%esmf_sta_list%idate1_import = 0 - gis_phy%esmf_sta_list%idate1_export = 0 - gis_phy%esmf_sta_list%z_import = 0 - gis_phy%esmf_sta_list%z_export = 0 - gis_phy%esmf_sta_list%ps_import = 1 - gis_phy%esmf_sta_list%ps_export = 1 - gis_phy%esmf_sta_list%temp_import = 1 - gis_phy%esmf_sta_list%temp_export = 1 - gis_phy%esmf_sta_list%u_import = 1 - gis_phy%esmf_sta_list%u_export = 1 - gis_phy%esmf_sta_list%v_import = 1 - gis_phy%esmf_sta_list%v_export = 1 - gis_phy%esmf_sta_list%q_import = 1 - gis_phy%esmf_sta_list%q_export = 1 - gis_phy%esmf_sta_list%oz_import = 1 - gis_phy%esmf_sta_list%oz_export = 1 - gis_phy%esmf_sta_list%cld_import = 1 - gis_phy%esmf_sta_list%cld_export = 1 - gis_phy%esmf_sta_list%p_import = 1 - gis_phy%esmf_sta_list%p_export = 1 - gis_phy%esmf_sta_list%dp_import = 1 - gis_phy%esmf_sta_list%dp_export = 1 - gis_phy%esmf_sta_list%dpdt_import = 1 - gis_phy%esmf_sta_list%dpdt_export = 1 - -!----------------------------------------------------------------------- -!*** Attach gfs fields in the internal state -!*** to the esmf import and export states. -!TBH: I use GFS naming conventions, *not* NMMB conventions. As -!TBH: of NEMS r3038 they do indeed differ, by case at least! -!TBH: Creation of unique ESMF_Field objects for import and export -!TBH: states should require little additional memory since the pointers -!TBH: to Fortran arrays are shared. This approach makes object deletion -!TBH: easier. -!------------------------------------------------------- - - MESSAGE_CHECK= & - "initial internal state to esmf import and export states" - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) - - IF (gis_phy%esmf_sta_list%idate1_import == 1) THEN - WRITE(0,*)' PHY_INITIALIZE import of idate1 not supported' - RC_INIT = ESMF_FAILURE - RETURN - ENDIF - IF (gis_phy%esmf_sta_list%idate1_export == 1) THEN - WRITE(0,*)' PHY_INITIALIZE export of idate1 not supported' - RC_INIT = ESMF_FAILURE - RETURN - ENDIF - IF (gis_phy%esmf_sta_list%z_import == 1) THEN - WRITE(0,*)' PHY_INITIALIZE import of z not supported' - RC_INIT = ESMF_FAILURE - RETURN - ENDIF - IF (gis_phy%esmf_sta_list%z_export == 1) THEN - WRITE(0,*)' PHY_INITIALIZE export of z not supported' - RC_INIT = ESMF_FAILURE - RETURN - ENDIF - -!TODO: Need to add gridToFieldMap to ESMF_FieldCreate() to address -!TODO: differences between 2D and 3D arrays. At present this is -!TODO: irrelevant since we do not use ESMF to do any re-grid or -!TODO: re-dist operations. This must be fixed before we use these -!TODO: ESMF features. - - IF (gis_phy%esmf_sta_list%ps_import == 1) THEN - MESSAGE_CHECK="Create ps array for import state" -!TBH: Note that the following call to ESMF_FieldCreate() yields the -!TBH: stunningly informative error code 540 which maps to string -!TBH: "Not valid" in ESMC_ErrMsgs.C. Backed off to ESMF_ArrayCreate(). -!TODO: Switch back to ESMF_FieldCreate() since future NEMS will use -!TODO: ESMF_Fields. -! TMP_FIELD=ESMF_FieldCreate(grid =GRID & -! ,farray =gis_phy%ps & -! ,distgridToArrayMap=(/1/) & -! ,name ='ps' & -! ,rc =RC) - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%ps & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='ps' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add ps array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - IF (gis_phy%esmf_sta_list%ps_export == 1) THEN - MESSAGE_CHECK="Create ps array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%ps & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='ps' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add ps array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - - IF (gis_phy%esmf_sta_list%temp_import == 1) THEN - MESSAGE_CHECK="Create t array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%t & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='t' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add t array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - IF (gis_phy%esmf_sta_list%temp_export == 1) THEN - MESSAGE_CHECK="Create t array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%t & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='t' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add t array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - - IF (gis_phy%esmf_sta_list%u_import == 1) THEN - MESSAGE_CHECK="Create u array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%u & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='u' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add u array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - IF (gis_phy%esmf_sta_list%u_export == 1) THEN - MESSAGE_CHECK="Create u array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%u & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='u' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add u array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - - IF (gis_phy%esmf_sta_list%v_import == 1) THEN - MESSAGE_CHECK="Create v array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%v & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='v' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add v array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - IF (gis_phy%esmf_sta_list%v_export == 1) THEN - MESSAGE_CHECK="Create v array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%v & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='v' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add v array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - - IF (gis_phy%esmf_sta_list%q_import == 1) THEN - MESSAGE_CHECK="Create q array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%q & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='shum' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add q array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - IF (gis_phy%esmf_sta_list%q_export == 1) THEN - MESSAGE_CHECK="Create q array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%q & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='shum' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add q array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - - IF (gis_phy%esmf_sta_list%oz_import == 1) THEN - MESSAGE_CHECK="Create oz array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%oz & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='oz' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add oz array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - IF (gis_phy%esmf_sta_list%oz_export == 1) THEN - MESSAGE_CHECK="Create oz array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%oz & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='oz' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add oz array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - - IF (gis_phy%esmf_sta_list%cld_import == 1) THEN - MESSAGE_CHECK="Create cld array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%cld & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='cld' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add cld array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - IF (gis_phy%esmf_sta_list%cld_export == 1) THEN - MESSAGE_CHECK="Create cld array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%cld & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='cld' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add cld array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - - IF (gis_phy%esmf_sta_list%p_import == 1) THEN - MESSAGE_CHECK="Create p array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%p & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='p' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add p array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - IF (gis_phy%esmf_sta_list%p_export == 1) THEN - MESSAGE_CHECK="Create p array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%p & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='p' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add p array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - - IF (gis_phy%esmf_sta_list%dp_import == 1) THEN - MESSAGE_CHECK="Create dp array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%dp & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='dp' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add dp array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - IF (gis_phy%esmf_sta_list%dp_export == 1) THEN - MESSAGE_CHECK="Create dp array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%dp & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='dp' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add dp array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - - IF (gis_phy%esmf_sta_list%dpdt_import == 1) THEN - MESSAGE_CHECK="Create dpdt array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%dpdt & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='dpdt' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add dpdt array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - IF (gis_phy%esmf_sta_list%dpdt_export == 1) THEN - MESSAGE_CHECK="Create dpdt array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%dpdt & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='dpdt' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add dpdt array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -!TBH: New arrays needed by FIM DYN component. -!TODO: Need to reach agreement with NCEP about exporting these arrays from -!TODO: GFS PHY component for use by FIM diagnostics. -! IF (gis_phy%esmf_sta_list%geshem_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create geshem array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%flx_fld%GESHEM & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='geshem' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add geshem array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%geshem_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create geshem array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%flx_fld%GESHEM & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='geshem' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add geshem array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%rainc_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create rainc array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%flx_fld%RAINC & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='rainc' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add rainc array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%rainc_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create rainc array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%flx_fld%RAINC & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='rainc' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add rainc array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%tsea_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create tsea array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%TSEA & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='tsea' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add tsea array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%tsea_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create tsea array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%TSEA & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='tsea' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add tsea array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%uustar_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create uustar array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%UUSTAR & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='uustar' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add uustar array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%uustar_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create uustar array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%UUSTAR & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='uustar' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add uustar array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%hflx_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create hflx array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%flx_fld%HFLX & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='hflx' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add hflx array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%hflx_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create hflx array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%flx_fld%HFLX & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='hflx' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add hflx array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%evap_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create evap array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%flx_fld%EVAP & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='evap' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add evap array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%evap_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create evap array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%flx_fld%EVAP & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='evap' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add evap array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%sheleg_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create sheleg array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%SHELEG & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='sheleg' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add sheleg array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%sheleg_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create sheleg array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%SHELEG & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='sheleg' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add sheleg array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%canopy_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create canopy array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%CANOPY & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='canopy' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add canopy array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%canopy_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create canopy array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%CANOPY & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='canopy' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add canopy array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%hice_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create hice array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%HICE & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='hice' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add hice array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%hice_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create hice array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%HICE & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='hice' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add hice array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%fice_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create fice array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%FICE & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='fice' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add fice array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%fice_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create fice array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%FICE & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='fice' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add fice array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%stc_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create stc array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%STC & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='stc' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add stc array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%stc_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create stc array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%STC & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='stc' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add stc array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%smc_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create smc array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%SMC & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='smc' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add smc array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%smc_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create smc array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%SMC & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='smc' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add smc array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%sfcdsw_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create sfcdsw array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%flx_fld%SFCDSW & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='sfcdsw' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add sfcdsw array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%sfcdsw_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create sfcdsw array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%flx_fld%SFCDSW & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='sfcdsw' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add sfcdsw array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%sfcdlw_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create sfcdlw array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%flx_fld%SFCDLW & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='sfcdlw' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add sfcdlw array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%sfcdlw_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create sfcdlw array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%flx_fld%SFCDLW & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='sfcdlw' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add sfcdlw array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%t2m_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create t2m array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%T2M & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='t2m' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add t2m array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%t2m_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create t2m array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%T2M & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='t2m' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add t2m array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%q2m_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create q2m array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%Q2M & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='q2m' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add q2m array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%q2m_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create q2m array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%Q2M & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='q2m' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add q2m array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%slmsk_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create slmsk array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%SLMSK & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='slmsk' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add slmsk array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%slmsk_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create slmsk array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%sfc_fld%SLMSK & - ,distgridToArrayMap=(/1/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='slmsk' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add slmsk array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%hprime_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create hprime array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%hprime & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='hprime' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add hprime array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%hprime_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create hprime array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%hprime & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='hprime' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add hprime array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -! IF (gis_phy%esmf_sta_list%fluxr_import == 1) THEN - IF (.FALSE.) THEN - MESSAGE_CHECK="Create fluxr array for import state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%fluxr & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='fluxr' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add fluxr array to import state" - CALL ESMF_StateAdd(state=IMP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF -! IF (gis_phy%esmf_sta_list%fluxr_export == 1) THEN - IF (.TRUE.) THEN - MESSAGE_CHECK="Create fluxr array for export state" - ! create the ESMF_Array - TMP_ARRAY=ESMF_ArrayCreate(distgrid =DISTGRID & - ,farray =gis_phy%fluxr & - ,distgridToArrayMap=(/2/) & - ,indexflag=ESMF_INDEX_GLOBAL & - ,name ='fluxr' & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ! attach array to state - MESSAGE_CHECK="Add fluxr array to export state" - CALL ESMF_StateAdd(state=EXP_STATE & - ,array=TMP_ARRAY & - ,rc =RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - ENDIF - -!TBH: validate states - MESSAGE_CHECK="PHY_INITIALIZE: Validate import state" - call ESMF_StateValidate(state=IMP_STATE,rc=rc) - IF(RC==ESMF_SUCCESS)THEN -!JR WRITE(0,*)'PHY INITIALIZE import state valid' - ENDIF - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - MESSAGE_CHECK="PHY_INITIALIZE: Validate export state" - call ESMF_StateValidate(state=EXP_STATE,rc=rc) - IF(RC==ESMF_SUCCESS)THEN -!JR WRITE(0,*)'PHY INITIALIZE export state valid' - ENDIF - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - -! -!----------------------------------------------------------------------- -! - RC_INIT = RC - IF(RC_INIT==ESMF_SUCCESS)THEN -! WRITE(0,*)'PHY INITIALIZE STEP SUCCEEDED' - ELSE - WRITE(0,*)'PHY INITIALIZE STEP FAILED RC_INIT=',RC_INIT - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PHY_INITIALIZE -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE PHY_RUN(GRID_COMP & - ,IMP_STATE,EXP_STATE & - ,CLOCK_ATM & - ,RC_RUN) -! -!----------------------------------------------------------------------- -!*** THE INTEGRATION OF THE MODEL PHYSICS IS DONE -!*** THROUGH THIS ROUTINE. -!----------------------------------------------------------------------- -! - USE module_fim_phy_run ,only: PHY_RUN_FIM => phy_run -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -!*** ARGUMENT VARIABLES -!----------------------------------------------------------------------- -! - TYPE(ESMF_GridComp),INTENT(INOUT) :: GRID_COMP !<-- The Physics gridded component - TYPE(ESMF_State) ,INTENT(INOUT) :: IMP_STATE !<-- The Physics import state - TYPE(ESMF_State) ,INTENT(INOUT) :: EXP_STATE !<-- The Physics export state - TYPE(ESMF_Clock) ,INTENT(IN) :: CLOCK_ATM !<-- The ATM's ESMF Clock -! - INTEGER ,INTENT(OUT) :: RC_RUN -! -!----------------------------------------------------------------------- -!*** LOCAL VARIABLES -!----------------------------------------------------------------------- -! - INTEGER :: NTIMESTEP,RC -! - INTEGER(KIND=ESMF_KIND_I8) :: NTIMESTEP_ESMF -! - INTEGER :: its -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC_RUN=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** EXTRACT THE TIMESTEP COUNT FROM THE CLOCK. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Retrieve Timestep from ATM Clock in Physics Run" - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock =CLOCK_ATM & !<-- The ESMF clock - ,advanceCount=NTIMESTEP_ESMF & !<-- The number of times the clock has been advanced - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NTIMESTEP=NTIMESTEP_ESMF -! -! NOTE: Pointers in import and export states point to internal state as -! NOTE: set up in the init phase, consistent with future plans for NEMS. -! NOTE: So wrap%int_state is not needed here at present, nor are explicit -! NOTE: transfers between internal and import/export states. -!TODO: adjust as plans evolve - -!----------------------------------------------------------------------- -!*** CALL THE INDIVIDUAL PHYSICAL PROCESSES -!----------------------------------------------------------------------- -! - its = NTIMESTEP + 1 - CALL PHY_RUN_FIM (its) -! - RC_RUN=RC -! -!----------------------------------------------------------------------- -! - IF(RC_RUN==ESMF_SUCCESS)THEN -! WRITE(0,*)'PHY RUN STEP SUCCEEDED' - ELSE - WRITE(0,*)'PHY RUN STEP FAILED RC_RUN=',RC_RUN - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PHY_RUN -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE PHY_FINALIZE(GRID_COMP & - ,IMP_STATE,EXP_STATE & - ,CLOCK_ATM & - ,RC_FINAL) -! -!----------------------------------------------------------------------- -!*** FINALIZE THE PHYSICS COMPONENT. -!----------------------------------------------------------------------- -! - USE module_fim_phy_finalize ,only: PHY_FINALIZE_FIM => phy_finalize -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -!*** ARGUMENT VARIABLES -!----------------------------------------------------------------------- -! - TYPE(ESMF_GridComp),INTENT(INOUT) :: GRID_COMP !<-- The Physics gridded component - TYPE(ESMF_State) ,INTENT(INOUT) :: IMP_STATE !<-- The Physics import state - TYPE(ESMF_State) ,INTENT(INOUT) :: EXP_STATE !<-- The Physics export state - TYPE(ESMF_Clock) ,INTENT(IN) :: CLOCK_ATM !<-- The ATM's ESMF Clock -! - INTEGER ,INTENT(OUT) :: RC_FINAL -! -!----------------------------------------------------------------------- -!*** LOCAL VARIABLES -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC_FINAL=ESMF_SUCCESS -! - CALL PHY_FINALIZE_FIM -! -! WRITE(0,*)' Physics Completed Normally.' -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PHY_FINALIZE -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - END MODULE MODULE_PHYSICS_GRID_COMP -! -!----------------------------------------------------------------------- diff --git a/src/gsm/dyn/do_dynamics_one_loop.f b/src/gsm/dyn/do_dynamics_one_loop.f index 35d3605..77812eb 100644 --- a/src/gsm/dyn/do_dynamics_one_loop.f +++ b/src/gsm/dyn/do_dynamics_one_loop.f @@ -127,7 +127,6 @@ SUBROUTINE do_dynamics_one_loop(deltim,kdt,PHOUR, REAL(KIND=kind_mpi) coef00m(LEVS,ntrac) ! temp. ozone clwater REAL(KIND=kind_evod) coef00(LEVS,ntrac) ! temp. ozone clwater INTEGER INDLSEV,JBASEV - INTEGER INDLSOD,JBASOD c idea-related changes c Introduced arrays cvd00 and cvd00m (global mean temperature,h2o,o3,cld, @@ -141,7 +140,7 @@ SUBROUTINE do_dynamics_one_loop(deltim,kdt,PHOUR, integer lon_dim,lons_lat,node,nvcn integer iblk,njeff,lon,stp integer , parameter :: ngptcd = 12 - include 'function2' + include 'function_indlsev' LOGICAL LSOUT,ex_out LOGICAL start_step,reset_step,end_step,dfiend_step LOGICAL restart_step diff --git a/src/gsm/dyn/do_dynamics_two_loop.f b/src/gsm/dyn/do_dynamics_two_loop.f index e3b95fa..9b6f890 100644 --- a/src/gsm/dyn/do_dynamics_two_loop.f +++ b/src/gsm/dyn/do_dynamics_two_loop.f @@ -159,7 +159,7 @@ SUBROUTINE do_dynamics_two_loop(deltim,kdt,PHOUR, integer iblk,njeff,lon,item,jtem,ktem,ltem,stp &, ngptcd,mtem,ntem ! integer , parameter :: ngptcd = 12 - include 'function2' + include 'function_indlsev' LOGICAL LSOUT,ex_out LOGICAL start_step,reset_step,end_step LOGICAL restart_step,dfiend_step diff --git a/src/gsm/dyn/filter1eo.f b/src/gsm/dyn/filter1eo.f index 65792d5..89749bb 100644 --- a/src/gsm/dyn/filter1eo.f +++ b/src/gsm/dyn/filter1eo.f @@ -62,8 +62,6 @@ subroutine filter1eo cc integer indlsev,jbasev integer indlsod,jbasod -cc - include 'function2' cc cc CALL countperf(0,13,0.) diff --git a/src/gsm/dyn/filter1eo_noq.f b/src/gsm/dyn/filter1eo_noq.f index fa7f57d..2480219 100755 --- a/src/gsm/dyn/filter1eo_noq.f +++ b/src/gsm/dyn/filter1eo_noq.f @@ -57,8 +57,6 @@ subroutine filter1eo_noq cc integer indlsev,jbasev integer indlsod,jbasod -cc - include 'function2' cc cc CALL countperf(0,13,0.) diff --git a/src/gsm/dyn/filter2eo.f b/src/gsm/dyn/filter2eo.f index 4e9f464..8f6d1f1 100644 --- a/src/gsm/dyn/filter2eo.f +++ b/src/gsm/dyn/filter2eo.f @@ -62,8 +62,6 @@ subroutine filter2eo cc integer indlsev,jbasev integer indlsod,jbasod -cc - include 'function2' cc cc CALL countperf(0,13,0.) diff --git a/src/gsm/dyn/filter2eo_noq.f b/src/gsm/dyn/filter2eo_noq.f index 2bb16be..cb44cd2 100755 --- a/src/gsm/dyn/filter2eo_noq.f +++ b/src/gsm/dyn/filter2eo_noq.f @@ -58,8 +58,6 @@ subroutine filter2eo_noq cc integer indlsev,jbasev integer indlsod,jbasod -cc - include 'function2' cc cc CALL countperf(0,13,0.) diff --git a/src/gsm/dyn/filtereo.f b/src/gsm/dyn/filtereo.f index 4f8642a..f9b2ec0 100644 --- a/src/gsm/dyn/filtereo.f +++ b/src/gsm/dyn/filtereo.f @@ -63,8 +63,6 @@ subroutine filtereo cc integer indlsev,jbasev integer indlsod,jbasod -cc - include 'function2' cc cc CALL countperf(0,13,0.) diff --git a/src/gsm/dyn/filtereo_noq.f b/src/gsm/dyn/filtereo_noq.f index ffa8911..6d6440e 100755 --- a/src/gsm/dyn/filtereo_noq.f +++ b/src/gsm/dyn/filtereo_noq.f @@ -60,8 +60,6 @@ subroutine filtereo_noq cc integer indlsev,jbasev integer indlsod,jbasod -cc - include 'function2' cc cc CALL countperf(0,13,0.) diff --git a/src/gsm/dyn/get_topo_grid_grad.f b/src/gsm/dyn/get_topo_grid_grad.f index 234b902..1715de9 100755 --- a/src/gsm/dyn/get_topo_grid_grad.f +++ b/src/gsm/dyn/get_topo_grid_grad.f @@ -63,9 +63,6 @@ subroutine get_topo_grid_grad(cosf1, &, indlsev,jbasev,indev,indev1,indev2 &, indlsod,jbasod,indod,indod1,indod2 -! include 'function2' - include 'function_indlsev' - include 'function_indlsod' ! -------------------------------------------------------------------- diff --git a/src/gsm/dyn/grid_to_spect.f b/src/gsm/dyn/grid_to_spect.f index 25321f3..6e7ca7d 100644 --- a/src/gsm/dyn/grid_to_spect.f +++ b/src/gsm/dyn/grid_to_spect.f @@ -68,8 +68,6 @@ subroutine grid_to_spect ! &, qmin=1.0e-10 ! ! real(kind=kind_evod) ga2, tem -! - INCLUDE 'function2' ! !-------------------------------------------------------------------- ! diff --git a/src/gsm/dyn/grid_to_spect_inp.f b/src/gsm/dyn/grid_to_spect_inp.f index eb9cd80..2ce51ac 100644 --- a/src/gsm/dyn/grid_to_spect_inp.f +++ b/src/gsm/dyn/grid_to_spect_inp.f @@ -96,8 +96,6 @@ subroutine grid_to_spect_inp(zsg,psg,uug,vvg,ttg,rqg,dpg &, qmin=1.0e-10 ! real(kind=kind_evod) ga2, tem -! - INCLUDE 'function2' ! !-------------------------------------------------------------------- ! diff --git a/src/gsm/dyn/grid_to_spect_inp_1.f b/src/gsm/dyn/grid_to_spect_inp_1.f index f0e2102..c6e2dcf 100644 --- a/src/gsm/dyn/grid_to_spect_inp_1.f +++ b/src/gsm/dyn/grid_to_spect_inp_1.f @@ -106,8 +106,6 @@ subroutine grid_to_spect_inp_1 ! real(kind=kind_evod) ga2, tem ! - INCLUDE 'function2' - ! !-------------------------------------------------------------------- ! diff --git a/src/gsm/dyn/grid_to_spect_inp_slg.f b/src/gsm/dyn/grid_to_spect_inp_slg.f index 079d8fe..c2b19c5 100644 --- a/src/gsm/dyn/grid_to_spect_inp_slg.f +++ b/src/gsm/dyn/grid_to_spect_inp_slg.f @@ -98,8 +98,6 @@ subroutine grid_to_spect_inp_slg real(kind=kind_evod), parameter :: cons_0=0.0, cons_24=24.0 &, cons_99=99.0, cons_1p0d9=1.0E9 &, qmin=1.0e-10 -! - INCLUDE 'function2' ! !-------------------------------------------------------------------- ! diff --git a/src/gsm/dyn/grid_to_spect_rqt.f b/src/gsm/dyn/grid_to_spect_rqt.f index e29df5e..f7ceb8b 100644 --- a/src/gsm/dyn/grid_to_spect_rqt.f +++ b/src/gsm/dyn/grid_to_spect_rqt.f @@ -60,8 +60,6 @@ subroutine grid_to_spect_rqt !timers______________________________________________________--- real*8 rtc ,timer1,timer2 !timers______________________________________________________--- -! - INCLUDE 'function2' ! !-------------------------------------------------------------------- ! diff --git a/src/gsm/dyn/grid_to_spect_slg.f b/src/gsm/dyn/grid_to_spect_slg.f index eda2cb1..5c88e4e 100644 --- a/src/gsm/dyn/grid_to_spect_slg.f +++ b/src/gsm/dyn/grid_to_spect_slg.f @@ -59,8 +59,6 @@ subroutine grid_to_spect_slg(anl_gr_a_1,anl_gr_a_2 ! &, qmin=1.0e-10 ! ! real(kind=kind_evod) ga2, tem -! - INCLUDE 'function2' ! !-------------------------------------------------------------------- ! diff --git a/src/gsm/dyn/impadj_hyb.locl_gc.f b/src/gsm/dyn/impadj_hyb.locl_gc.f index 9dd7e3a..b177c6b 100644 --- a/src/gsm/dyn/impadj_hyb.locl_gc.f +++ b/src/gsm/dyn/impadj_hyb.locl_gc.f @@ -18,7 +18,7 @@ subroutine impadje_hyb_gc(de,te,qe,xe,ye,ze, integer indev,indev1,indev2,l,locl,n integer indlsev,jbasev integer indlsod,jbasod - include 'function2' + include 'function_indlsev' real(kind=kind_evod) cons0 !constant ! print *,' enter impadje_hyb.locl_gc_fd ' ! hmhj @@ -137,7 +137,7 @@ subroutine impadjo_hyb_gc(do,to,qo,xo,yo,zo, integer indod,indod1,indod2,l,locl,n integer indlsev,jbasev integer indlsod,jbasod - include 'function2' + include 'function_indlsod' real(kind=kind_evod) cons0 !constant ! print *,' enter impadjo_hyb.locl_gc_fd ' ! hmhj diff --git a/src/gsm/dyn/indlmod.f b/src/gsm/dyn/indlmod.f new file mode 100644 index 0000000..de070dd --- /dev/null +++ b/src/gsm/dyn/indlmod.f @@ -0,0 +1,15 @@ +! input forcing parameter module + module indlmod + + implicit none + + contains + + subroutine get_indl(jba, n, l, indlsev) + integer, intent(in) :: jba, n, l + integer, intent(out) :: indl + + indl = jba + (n-l)/2 + 1 + end subroutine get_indl + + end module indlmod diff --git a/src/gsm/dyn/sicdif_hyb.f b/src/gsm/dyn/sicdif_hyb.f index 9bf1098..a13a1a9 100644 --- a/src/gsm/dyn/sicdif_hyb.f +++ b/src/gsm/dyn/sicdif_hyb.f @@ -24,9 +24,8 @@ subroutine sicdife_hyb(de,te,qe,xe,ye,ze,de_n,te_n,qe_n, real(kind=kind_evod) svhybdt, u1, u2 integer indlsev,jbasev integer indlsod,jbasod - include 'function2' real(kind=kind_evod) cons0,cons1,cons2 !constant - + include 'function_indlsev' ! print *,' enter sicdife_hyb_fd ' ! hmhj cons0 = 0.d0 !constant @@ -329,7 +328,7 @@ subroutine sicdifo_hyb(do,to,qo,xo,yo,zo,do_n,to_n,qo_n, real(kind=kind_evod) svhybdt, u1, u2 integer indlsev,jbasev integer indlsod,jbasod - include 'function2' + include 'function_indlsod' real(kind=kind_evod) cons0,cons1,cons2 !constant ! print *,' enter sicdifo_hyb_fd ' ! hmhj diff --git a/src/gsm/dyn/sicdif_hyb_gc.f b/src/gsm/dyn/sicdif_hyb_gc.f index c0fc773..ec62f1a 100644 --- a/src/gsm/dyn/sicdif_hyb_gc.f +++ b/src/gsm/dyn/sicdif_hyb_gc.f @@ -24,9 +24,8 @@ subroutine sicdife_hyb_gc(de,te,qe,xe,ye,ze,de_n,te_n,qe_n, real(kind=kind_evod) svhybdt, u1, u2 integer indlsev,jbasev integer indlsod,jbasod - include 'function2' real(kind=kind_evod) cons0,cons1,cons2 !constant - + include 'function_indlsev' ! print *,' enter sicdife_hyb_gc_fd ' ! hmhj cons0 = 0.d0 !constant @@ -335,7 +334,7 @@ subroutine sicdifo_hyb_gc(do,to,qo,xo,yo,zo,do_n,to_n,qo_n, real(kind=kind_evod) svhybdt, u1, u2 integer indlsev,jbasev integer indlsod,jbasod - include 'function2' + include 'function_indlsod' real(kind=kind_evod) cons0,cons1,cons2 !constant ! print *,' enter sicdifo_hyb_gc_fd ' ! hmhj diff --git a/src/gsm/dyn/sicdif_hyb_gcdp.f b/src/gsm/dyn/sicdif_hyb_gcdp.f index 3b3560d..b39c44f 100755 --- a/src/gsm/dyn/sicdif_hyb_gcdp.f +++ b/src/gsm/dyn/sicdif_hyb_gcdp.f @@ -31,9 +31,8 @@ subroutine sicdife_hyb_gcdp(de,te,qe,xe,ye,ze,de_n,te_n,qe_n, real(kind=kind_evod) u1, u2 integer indlsev,jbasev integer indlsod,jbasod - include 'function2' real(kind=kind_evod) cons0,cons1,cons2 !constant - + include 'function_indlsev' ! print *,' enter sicdife_hyb_gcdp ' ! hmhj cons0 = 0.d0 !constant @@ -395,7 +394,7 @@ subroutine sicdifo_hyb_gcdp(do,to,qo,xo,yo,zo,do_n,to_n,qo_n, real(kind=kind_evod) u1, u2 integer indlsev,jbasev integer indlsod,jbasod - include 'function2' + include 'function_indlsod' real(kind=kind_evod) cons0,cons1,cons2 !constant ! print *,' enter sicdifo_hyb_gc_fd ' ! hmhj diff --git a/src/gsm/dyn/sicdif_hyb_slg.f b/src/gsm/dyn/sicdif_hyb_slg.f index b1ac2e6..2bf9a8c 100755 --- a/src/gsm/dyn/sicdif_hyb_slg.f +++ b/src/gsm/dyn/sicdif_hyb_slg.f @@ -18,8 +18,8 @@ subroutine sicdife_hyb_slg(xe,ye,ze,dt_half,ue,ve, integer ndexev(len_trie_ls) integer i,indev,indev1,indev2,j,k,l,locl,n integer indlsev,jbasev - include 'function_indlsev' real(kind=kind_evod) cons0,cons1,cons2 !constant + include 'function_indlsev' cons0 = 0.d0 !constant cons1 = 1.d0 !constant cons2 = 2.d0 !constant diff --git a/src/gsm/dyn/sicdif_sig.f b/src/gsm/dyn/sicdif_sig.f index 53598f5..73c2d96 100644 --- a/src/gsm/dyn/sicdif_sig.f +++ b/src/gsm/dyn/sicdif_sig.f @@ -23,9 +23,8 @@ subroutine sicdife_sig(de,te,qe,xe,ye,ze,am,bm,tov,sv,dt,ue,ve, real(kind=kind_evod) svdt, u1, u2 integer indlsev,jbasev integer indlsod,jbasod - include 'function2' real(kind=kind_evod) cons0,cons1,cons2 !constant - + include 'function_indlsev' cons0 = 0.d0 !constant cons1 = 1.d0 !constant cons2 = 2.d0 !constant @@ -341,7 +340,7 @@ subroutine sicdifo_sig(do,to,qo,xo,yo,zo,am,bm,tov,sv,dt,uo,vo, real(kind=kind_evod) svdt, u1, u2 integer indlsev,jbasev integer indlsod,jbasod - include 'function2' + include 'function_indlsod' real(kind=kind_evod) cons0,cons1,cons2 !constant cons0 = 0.d0 !constant cons1 = 1.d0 !constant diff --git a/src/gsm/dyn/treadeo.io_iau.f b/src/gsm/dyn/treadeo.io_iau.f index e17f46b..8268d93 100755 --- a/src/gsm/dyn/treadeo.io_iau.f +++ b/src/gsm/dyn/treadeo.io_iau.f @@ -107,8 +107,6 @@ SUBROUTINE TREADEO_IAU(IDATE,grid_gr, real(kind=kind_evod) teref(levp1),ck5p(levp1) ! hmhj - INCLUDE 'function2' -!! !! if (semilag) then lon1=lon_dim_a diff --git a/src/gsm/dyn/treadeo_nemsio_iau.f b/src/gsm/dyn/treadeo_nemsio_iau.f index 77b1bde..8098d18 100644 --- a/src/gsm/dyn/treadeo_nemsio_iau.f +++ b/src/gsm/dyn/treadeo_nemsio_iau.f @@ -80,8 +80,6 @@ subroutine treadeo_nemsio_iau(cfile,IDATE ! real(8) timef,stime,etime ! - INTEGER INDLSEV,JBASEV,INDLSOD,JBASOD - INCLUDE 'function2' !------------------------------------------------------------------------ ! Input file is in grid-point space - use gfs_io package ! diff --git a/src/gsm/phys/Makefile.am b/src/gsm/phys/Makefile.am index c20c536..4947868 100644 --- a/src/gsm/phys/Makefile.am +++ b/src/gsm/phys/Makefile.am @@ -11,7 +11,7 @@ libgfsphys_a_SOURCES = aoicpl_prep.f compns_physics.f coordinate_def.f \ lon_lat_para.f mod_state.f mpi_def.f mpi_quit.f namelist_physics_def.f \ para_fixio_w.f para_nst_w.f read_fix.f reduce_lons_grid_module.f \ resol_def.f setlats.f setlats_r_slg.f sortrx.f vert_def.f wrt3d.f \ - wrt3d_hyb.f wrtout_physics.f function_indlsev function_indlsod + wrt3d_hyb.f wrtout_physics.f libgfsphysf_a_FFLAGS = -I $(top_srcdir)/include \ $(FC_MODINC) ../libutil $(FC_MODINC) ../dyn $(FC_MODINC) ../../phys $(FC_MODINC) ../../share @@ -67,7 +67,7 @@ libgfsphys_a-gbphys_adv_hyb_gc.$(OBJEXT) : libgfsphys_a-coordinate_def.$(OBJEXT) libgfsphys_a-gbphys_adv_hyb_gc_h.$(OBJEXT) : libgfsphys_a-coordinate_def.$(OBJEXT) libgfsphys_a-resol_def.$(OBJEXT) libgfsphys_a-gcycle.$(OBJEXT) : libgfsphys_a-namelist_physics_def.$(OBJEXT) \ libgfsphys_a-resol_def.$(OBJEXT) libgfsphysf_a-gfs_physics_sfc_flx_mod.$(OBJEXT) -libgfsphys_a-getcon_physics.$(OBJEXT) : function_indlsev function_indlsod libgfsphys_a-namelist_physics_def.$(OBJEXT) \ +libgfsphys_a-getcon_physics.$(OBJEXT) : libgfsphys_a-namelist_physics_def.$(OBJEXT) \ libgfsphys_a-resol_def.$(OBJEXT) libgfsphys_a-layout1.$(OBJEXT) libgfsphys_a-gg_def.$(OBJEXT) libgfsphys_a-get_lats_node_shuff_r_fix.$(OBJEXT) : libgfsphys_a-resol_def.$(OBJEXT) libgfsphys_a-layout1.$(OBJEXT) libgfsphys_a-GFS_simple_scatter.$(OBJEXT) : libgfsphys_a-resol_def.$(OBJEXT) libgfsphys_a-layout1.$(OBJEXT) diff --git a/src/gsm/phys/Makefile.in b/src/gsm/phys/Makefile.in index 2ad4f9d..e694c9e 100644 --- a/src/gsm/phys/Makefile.in +++ b/src/gsm/phys/Makefile.in @@ -387,7 +387,7 @@ libgfsphys_a_SOURCES = aoicpl_prep.f compns_physics.f coordinate_def.f \ lon_lat_para.f mod_state.f mpi_def.f mpi_quit.f namelist_physics_def.f \ para_fixio_w.f para_nst_w.f read_fix.f reduce_lons_grid_module.f \ resol_def.f setlats.f setlats_r_slg.f sortrx.f vert_def.f wrt3d.f \ - wrt3d_hyb.f wrtout_physics.f function_indlsev function_indlsod + wrt3d_hyb.f wrtout_physics.f libgfsphysf_a_FFLAGS = -I $(top_srcdir)/include $(FC_MODINC) \ ../libutil $(FC_MODINC) ../dyn $(FC_MODINC) ../../phys \ @@ -1110,7 +1110,7 @@ libgfsphys_a-gbphys_adv_hyb_gc.$(OBJEXT) : libgfsphys_a-coordinate_def.$(OBJEXT) libgfsphys_a-gbphys_adv_hyb_gc_h.$(OBJEXT) : libgfsphys_a-coordinate_def.$(OBJEXT) libgfsphys_a-resol_def.$(OBJEXT) libgfsphys_a-gcycle.$(OBJEXT) : libgfsphys_a-namelist_physics_def.$(OBJEXT) \ libgfsphys_a-resol_def.$(OBJEXT) libgfsphysf_a-gfs_physics_sfc_flx_mod.$(OBJEXT) -libgfsphys_a-getcon_physics.$(OBJEXT) : function_indlsev function_indlsod libgfsphys_a-namelist_physics_def.$(OBJEXT) \ +libgfsphys_a-getcon_physics.$(OBJEXT) : libgfsphys_a-namelist_physics_def.$(OBJEXT) \ libgfsphys_a-resol_def.$(OBJEXT) libgfsphys_a-layout1.$(OBJEXT) libgfsphys_a-gg_def.$(OBJEXT) libgfsphys_a-get_lats_node_shuff_r_fix.$(OBJEXT) : libgfsphys_a-resol_def.$(OBJEXT) libgfsphys_a-layout1.$(OBJEXT) libgfsphys_a-GFS_simple_scatter.$(OBJEXT) : libgfsphys_a-resol_def.$(OBJEXT) libgfsphys_a-layout1.$(OBJEXT) diff --git a/src/gsm/phys/function2 b/src/gsm/phys/function2 deleted file mode 100644 index f332823..0000000 --- a/src/gsm/phys/function2 +++ /dev/null @@ -1,5 +0,0 @@ -!cc - indlsev(n,l) = jbasev + (n-l)/2 + 1 -!cc - indlsod(n,l) = jbasod + (n-l)/2 + 1 -!cc diff --git a/src/gsm/phys/function_indlsev b/src/gsm/phys/function_indlsev deleted file mode 100755 index 94e605c..0000000 --- a/src/gsm/phys/function_indlsev +++ /dev/null @@ -1,3 +0,0 @@ -!cc - indlsev(n,l) = jbasev + (n-l)/2 + 1 -!cc diff --git a/src/gsm/phys/function_indlsod b/src/gsm/phys/function_indlsod deleted file mode 100755 index 16c4e79..0000000 --- a/src/gsm/phys/function_indlsod +++ /dev/null @@ -1,3 +0,0 @@ -!cc - indlsod(n,l) = jbasod + (n-l)/2 + 1 -!cc diff --git a/src/gsm/phys/getcon_physics.f b/src/gsm/phys/getcon_physics.f index f15424d..6bfd22b 100644 --- a/src/gsm/phys/getcon_physics.f +++ b/src/gsm/phys/getcon_physics.f @@ -39,14 +39,11 @@ subroutine getcon_physics(n3,n4, integer iprint,locl,node,nodesio integer len_trie_ls_nod, len_trio_ls_nod ! - integer indlsev,jbasev,indlsod,jbasod + integer jbasev,jbasod ! integer gl_lats_index integer global_time_sort_index_r(latr) integer nodes_tmp -! - include 'function_indlsev' - include 'function_indlsod' ! real(kind=kind_evod) global_time_r(latr) ! diff --git a/src/gsm/phys/indlmod.f b/src/gsm/phys/indlmod.f new file mode 100644 index 0000000..428624a --- /dev/null +++ b/src/gsm/phys/indlmod.f @@ -0,0 +1,9 @@ +! input forcing parameter module + module indlmod + + implicit none + + integer indlsev, indlsod + + + end module indlmod diff --git a/src/nmm/Makefile.am b/src/nmm/Makefile.am deleted file mode 100644 index a993290..0000000 --- a/src/nmm/Makefile.am +++ /dev/null @@ -1,14 +0,0 @@ -noinst_LIBRARIES = libnmm.a - -libnmm_a_SOURCES = module_NMM_GRID_COMP_stub.F90 - -libnmm_a_FCFLAGS = - -.PHONY: clean-modules - -clean-modules: - -test -z "$(FC_MODEXT)" || rm -f *.$(FC_MODEXT) - -clean-local: clean-modules - -# dependencies diff --git a/src/nmm/Makefile.in b/src/nmm/Makefile.in deleted file mode 100644 index 503770d..0000000 --- a/src/nmm/Makefile.in +++ /dev/null @@ -1,589 +0,0 @@ -# Makefile.in generated by automake 1.13.4 from Makefile.am. -# @configure_input@ - -# Copyright (C) 1994-2013 Free Software Foundation, Inc. - -# This Makefile.in is free software; the Free Software Foundation -# gives unlimited permission to copy and/or distribute it, -# with or without modifications, as long as this notice is preserved. - -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY, to the extent permitted by law; without -# even the implied warranty of MERCHANTABILITY or FITNESS FOR A -# PARTICULAR PURPOSE. - -@SET_MAKE@ - -VPATH = @srcdir@ -am__is_gnu_make = test -n '$(MAKEFILE_LIST)' && test -n '$(MAKELEVEL)' -am__make_running_with_option = \ - case $${target_option-} in \ - ?) ;; \ - *) echo "am__make_running_with_option: internal error: invalid" \ - "target option '$${target_option-}' specified" >&2; \ - exit 1;; \ - esac; \ - has_opt=no; \ - sane_makeflags=$$MAKEFLAGS; \ - if $(am__is_gnu_make); then \ - sane_makeflags=$$MFLAGS; \ - else \ - case $$MAKEFLAGS in \ - *\\[\ \ ]*) \ - bs=\\; \ - sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \ - | sed "s/$$bs$$bs[$$bs $$bs ]*//g"`;; \ - esac; \ - fi; \ - skip_next=no; \ - strip_trailopt () \ - { \ - flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \ - }; \ - for flg in $$sane_makeflags; do \ - test $$skip_next = yes && { skip_next=no; continue; }; \ - case $$flg in \ - *=*|--*) continue;; \ - -*I) strip_trailopt 'I'; skip_next=yes;; \ - -*I?*) strip_trailopt 'I';; \ - -*O) strip_trailopt 'O'; skip_next=yes;; \ - -*O?*) strip_trailopt 'O';; \ - -*l) strip_trailopt 'l'; skip_next=yes;; \ - -*l?*) strip_trailopt 'l';; \ - -[dEDm]) skip_next=yes;; \ - -[JT]) skip_next=yes;; \ - esac; \ - case $$flg in \ - *$$target_option*) has_opt=yes; break;; \ - esac; \ - done; \ - test $$has_opt = yes -am__make_dryrun = (target_option=n; $(am__make_running_with_option)) -am__make_keepgoing = (target_option=k; $(am__make_running_with_option)) -pkgdatadir = $(datadir)/@PACKAGE@ -pkgincludedir = $(includedir)/@PACKAGE@ -pkglibdir = $(libdir)/@PACKAGE@ -pkglibexecdir = $(libexecdir)/@PACKAGE@ -am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd -install_sh_DATA = $(install_sh) -c -m 644 -install_sh_PROGRAM = $(install_sh) -c -install_sh_SCRIPT = $(install_sh) -c -INSTALL_HEADER = $(INSTALL_DATA) -transform = $(program_transform_name) -NORMAL_INSTALL = : -PRE_INSTALL = : -POST_INSTALL = : -NORMAL_UNINSTALL = : -PRE_UNINSTALL = : -POST_UNINSTALL = : -build_triplet = @build@ -host_triplet = @host@ -subdir = src/nmm -DIST_COMMON = $(srcdir)/Makefile.in $(srcdir)/Makefile.am -ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 -am__aclocal_m4_deps = $(top_srcdir)/m4/ax_blas.m4 \ - $(top_srcdir)/m4/ax_check_compile_flags.m4 \ - $(top_srcdir)/m4/ax_compiler_vendor.m4 \ - $(top_srcdir)/m4/ax_fortran_utils.m4 \ - $(top_srcdir)/m4/ax_lib_comio.m4 \ - $(top_srcdir)/m4/ax_lib_esmf.m4 \ - $(top_srcdir)/m4/ax_lib_nemsio.m4 \ - $(top_srcdir)/m4/ax_lib_netcdf4.m4 $(top_srcdir)/configure.ac -am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ - $(ACLOCAL_M4) -mkinstalldirs = $(install_sh) -d -CONFIG_CLEAN_FILES = -CONFIG_CLEAN_VPATH_FILES = -LIBRARIES = $(noinst_LIBRARIES) -ARFLAGS = cru -AM_V_AR = $(am__v_AR_@AM_V@) -am__v_AR_ = $(am__v_AR_@AM_DEFAULT_V@) -am__v_AR_0 = @echo " AR " $@; -am__v_AR_1 = -libnmm_a_AR = $(AR) $(ARFLAGS) -libnmm_a_LIBADD = -am_libnmm_a_OBJECTS = libnmm_a-module_NMM_GRID_COMP_stub.$(OBJEXT) -libnmm_a_OBJECTS = $(am_libnmm_a_OBJECTS) -AM_V_P = $(am__v_P_@AM_V@) -am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) -am__v_P_0 = false -am__v_P_1 = : -AM_V_GEN = $(am__v_GEN_@AM_V@) -am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@) -am__v_GEN_0 = @echo " GEN " $@; -am__v_GEN_1 = -AM_V_at = $(am__v_at_@AM_V@) -am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) -am__v_at_0 = @ -am__v_at_1 = -DEFAULT_INCLUDES = -I.@am__isrc@ -AM_V_lt = $(am__v_lt_@AM_V@) -am__v_lt_ = $(am__v_lt_@AM_DEFAULT_V@) -am__v_lt_0 = --silent -am__v_lt_1 = -PPFCCOMPILE = $(FC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) \ - $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_FCFLAGS) $(FCFLAGS) -AM_V_PPFC = $(am__v_PPFC_@AM_V@) -am__v_PPFC_ = $(am__v_PPFC_@AM_DEFAULT_V@) -am__v_PPFC_0 = @echo " PPFC " $@; -am__v_PPFC_1 = -FCLD = $(FC) -FCLINK = $(FCLD) $(AM_FCFLAGS) $(FCFLAGS) $(AM_LDFLAGS) $(LDFLAGS) -o \ - $@ -AM_V_FCLD = $(am__v_FCLD_@AM_V@) -am__v_FCLD_ = $(am__v_FCLD_@AM_DEFAULT_V@) -am__v_FCLD_0 = @echo " FCLD " $@; -am__v_FCLD_1 = -SOURCES = $(libnmm_a_SOURCES) -DIST_SOURCES = $(libnmm_a_SOURCES) -am__can_run_installinfo = \ - case $$AM_UPDATE_INFO_DIR in \ - n|no|NO) false;; \ - *) (install-info --version) >/dev/null 2>&1;; \ - esac -am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) $(LISP) -# Read a list of newline-separated strings from the standard input, -# and print each of them once, without duplicates. Input order is -# *not* preserved. -am__uniquify_input = $(AWK) '\ - BEGIN { nonempty = 0; } \ - { items[$$0] = 1; nonempty = 1; } \ - END { if (nonempty) { for (i in items) print i; }; } \ -' -# Make sure the list of sources is unique. This is necessary because, -# e.g., the same source file might be shared among _SOURCES variables -# for different programs/libraries. -am__define_uniq_tagged_files = \ - list='$(am__tagged_files)'; \ - unique=`for i in $$list; do \ - if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ - done | $(am__uniquify_input)` -ETAGS = etags -CTAGS = ctags -DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) -ACLOCAL = @ACLOCAL@ -AMTAR = @AMTAR@ -AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ -AR = @AR@ -AUTOCONF = @AUTOCONF@ -AUTOHEADER = @AUTOHEADER@ -AUTOMAKE = @AUTOMAKE@ -AWK = @AWK@ -BLAS_LIBS = @BLAS_LIBS@ -CC = @CC@ -CCDEPMODE = @CCDEPMODE@ -CFLAGS = @CFLAGS@ -COMIO_CONFIG = @COMIO_CONFIG@ -COMIO_FC = @COMIO_FC@ -COMIO_FFLAGS = @COMIO_FFLAGS@ -COMIO_FLIBS = @COMIO_FLIBS@ -COMIO_LDFLAGS = @COMIO_LDFLAGS@ -COMIO_VERSION = @COMIO_VERSION@ -CPP = @CPP@ -CPPFLAGS = @CPPFLAGS@ -CYGPATH_W = @CYGPATH_W@ -DEFS = @DEFS@ -DEFS_PHYS = @DEFS_PHYS@ -DEPDIR = @DEPDIR@ -ECHO_C = @ECHO_C@ -ECHO_N = @ECHO_N@ -ECHO_T = @ECHO_T@ -EGREP = @EGREP@ -ESMFMKFILE = @ESMFMKFILE@ -ESMF_FC = @ESMF_FC@ -ESMF_FCFLAGS = @ESMF_FCFLAGS@ -ESMF_FLIBS = @ESMF_FLIBS@ -ESMF_LDFLAGS = @ESMF_LDFLAGS@ -ESMF_LIBS = @ESMF_LIBS@ -EXEEXT = @EXEEXT@ -F77 = @F77@ -FC = @FC@ -FCFLAGS = @FCFLAGS@ -FCFLAGS_F = @FCFLAGS_F@ -FCFLAGS_F90 = @FCFLAGS_F90@ -FCFLAGS_FIXED = @FCFLAGS_FIXED@ -FCFLAGS_FREE = @FCFLAGS_FREE@ -FCFLAGS_f = @FCFLAGS_f@ -FCLIBS = @FCLIBS@ -FC_AUTODOUBLE = @FC_AUTODOUBLE@ -FC_DEFINE = @FC_DEFINE@ -FC_LINE_LENGTH = @FC_LINE_LENGTH@ -FC_MODEXT = @FC_MODEXT@ -FC_MODINC = @FC_MODINC@ -FFLAGS = @FFLAGS@ -GREP = @GREP@ -INSTALL = @INSTALL@ -INSTALL_DATA = @INSTALL_DATA@ -INSTALL_PROGRAM = @INSTALL_PROGRAM@ -INSTALL_SCRIPT = @INSTALL_SCRIPT@ -INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ -LDFLAGS = @LDFLAGS@ -LIBOBJS = @LIBOBJS@ -LIBS = @LIBS@ -LTLIBOBJS = @LTLIBOBJS@ -MAINT = @MAINT@ -MAKEINFO = @MAKEINFO@ -MKDIR_P = @MKDIR_P@ -NC_CONFIG = @NC_CONFIG@ -NEMSIO_FCFLAGS = @NEMSIO_FCFLAGS@ -NEMSIO_FLIBS = @NEMSIO_FLIBS@ -NEMSIO_LDFLAGS = @NEMSIO_LDFLAGS@ -NEMSIO_LIBS = @NEMSIO_LIBS@ -NEMSIO_VERSION = @NEMSIO_VERSION@ -NETCDF4_CC = @NETCDF4_CC@ -NETCDF4_CFLAGS = @NETCDF4_CFLAGS@ -NETCDF4_FC = @NETCDF4_FC@ -NETCDF4_FFLAGS = @NETCDF4_FFLAGS@ -NETCDF4_FLIBS = @NETCDF4_FLIBS@ -NETCDF4_LDFLAGS = @NETCDF4_LDFLAGS@ -NETCDF4_LIBS = @NETCDF4_LIBS@ -NETCDF4_VERSION = @NETCDF4_VERSION@ -OBJEXT = @OBJEXT@ -OPENMP_FCFLAGS = @OPENMP_FCFLAGS@ -PACKAGE = @PACKAGE@ -PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ -PACKAGE_NAME = @PACKAGE_NAME@ -PACKAGE_STRING = @PACKAGE_STRING@ -PACKAGE_TARNAME = @PACKAGE_TARNAME@ -PACKAGE_URL = @PACKAGE_URL@ -PACKAGE_VERSION = @PACKAGE_VERSION@ -PATH_SEPARATOR = @PATH_SEPARATOR@ -RANLIB = @RANLIB@ -SED = @SED@ -SET_MAKE = @SET_MAKE@ -SHELL = @SHELL@ -STRIP = @STRIP@ -VERSION = @VERSION@ -WAM_DEP_LINK_OBJS = @WAM_DEP_LINK_OBJS@ -WAM_DEP_SHRD_LIBS = @WAM_DEP_SHRD_LIBS@ -WAM_DEP_SHRD_PATH = @WAM_DEP_SHRD_PATH@ -abs_builddir = @abs_builddir@ -abs_srcdir = @abs_srcdir@ -abs_top_builddir = @abs_top_builddir@ -abs_top_srcdir = @abs_top_srcdir@ -ac_ct_AR = @ac_ct_AR@ -ac_ct_CC = @ac_ct_CC@ -ac_ct_F77 = @ac_ct_F77@ -ac_ct_FC = @ac_ct_FC@ -ac_empty = @ac_empty@ -am__include = @am__include@ -am__leading_dot = @am__leading_dot@ -am__quote = @am__quote@ -am__tar = @am__tar@ -am__untar = @am__untar@ -bindir = @bindir@ -build = @build@ -build_alias = @build_alias@ -build_cpu = @build_cpu@ -build_os = @build_os@ -build_vendor = @build_vendor@ -builddir = @builddir@ -datadir = @datadir@ -datarootdir = @datarootdir@ -docdir = @docdir@ -dvidir = @dvidir@ -exec_prefix = @exec_prefix@ -host = @host@ -host_alias = @host_alias@ -host_cpu = @host_cpu@ -host_os = @host_os@ -host_vendor = @host_vendor@ -htmldir = @htmldir@ -includedir = @includedir@ -infodir = @infodir@ -install_sh = @install_sh@ -libdir = @libdir@ -libexecdir = @libexecdir@ -localedir = @localedir@ -localstatedir = @localstatedir@ -mandir = @mandir@ -mkdir_p = @mkdir_p@ -oldincludedir = @oldincludedir@ -pdfdir = @pdfdir@ -prefix = @prefix@ -program_transform_name = @program_transform_name@ -psdir = @psdir@ -sbindir = @sbindir@ -sharedstatedir = @sharedstatedir@ -srcdir = @srcdir@ -sysconfdir = @sysconfdir@ -target_alias = @target_alias@ -top_build_prefix = @top_build_prefix@ -top_builddir = @top_builddir@ -top_srcdir = @top_srcdir@ -noinst_LIBRARIES = libnmm.a -libnmm_a_SOURCES = module_NMM_GRID_COMP_stub.F90 -libnmm_a_FCFLAGS = -all: all-am - -.SUFFIXES: -.SUFFIXES: .F90 .o .obj -$(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps) - @for dep in $?; do \ - case '$(am__configure_deps)' in \ - *$$dep*) \ - ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \ - && { if test -f $@; then exit 0; else break; fi; }; \ - exit 1;; \ - esac; \ - done; \ - echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu src/nmm/Makefile'; \ - $(am__cd) $(top_srcdir) && \ - $(AUTOMAKE) --gnu src/nmm/Makefile -.PRECIOUS: Makefile -Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status - @case '$?' in \ - *config.status*) \ - cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ - *) \ - echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \ - cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \ - esac; - -$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) - cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh - -$(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) - cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh -$(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps) - cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh -$(am__aclocal_m4_deps): - -clean-noinstLIBRARIES: - -test -z "$(noinst_LIBRARIES)" || rm -f $(noinst_LIBRARIES) - -libnmm.a: $(libnmm_a_OBJECTS) $(libnmm_a_DEPENDENCIES) $(EXTRA_libnmm_a_DEPENDENCIES) - $(AM_V_at)-rm -f libnmm.a - $(AM_V_AR)$(libnmm_a_AR) libnmm.a $(libnmm_a_OBJECTS) $(libnmm_a_LIBADD) - $(AM_V_at)$(RANLIB) libnmm.a - -mostlyclean-compile: - -rm -f *.$(OBJEXT) - -distclean-compile: - -rm -f *.tab.c - -.F90.o: - $(AM_V_PPFC)$(PPFCCOMPILE) -c -o $@ $< - -.F90.obj: - $(AM_V_PPFC)$(PPFCCOMPILE) -c -o $@ `$(CYGPATH_W) '$<'` - -libnmm_a-module_NMM_GRID_COMP_stub.o: module_NMM_GRID_COMP_stub.F90 - $(AM_V_PPFC)$(FC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(libnmm_a_FCFLAGS) $(FCFLAGS) -c -o libnmm_a-module_NMM_GRID_COMP_stub.o `test -f 'module_NMM_GRID_COMP_stub.F90' || echo '$(srcdir)/'`module_NMM_GRID_COMP_stub.F90 - -libnmm_a-module_NMM_GRID_COMP_stub.obj: module_NMM_GRID_COMP_stub.F90 - $(AM_V_PPFC)$(FC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(libnmm_a_FCFLAGS) $(FCFLAGS) -c -o libnmm_a-module_NMM_GRID_COMP_stub.obj `if test -f 'module_NMM_GRID_COMP_stub.F90'; then $(CYGPATH_W) 'module_NMM_GRID_COMP_stub.F90'; else $(CYGPATH_W) '$(srcdir)/module_NMM_GRID_COMP_stub.F90'; fi` - -ID: $(am__tagged_files) - $(am__define_uniq_tagged_files); mkid -fID $$unique -tags: tags-am -TAGS: tags - -tags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) - set x; \ - here=`pwd`; \ - $(am__define_uniq_tagged_files); \ - shift; \ - if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \ - test -n "$$unique" || unique=$$empty_fix; \ - if test $$# -gt 0; then \ - $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ - "$$@" $$unique; \ - else \ - $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ - $$unique; \ - fi; \ - fi -ctags: ctags-am - -CTAGS: ctags -ctags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) - $(am__define_uniq_tagged_files); \ - test -z "$(CTAGS_ARGS)$$unique" \ - || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ - $$unique - -GTAGS: - here=`$(am__cd) $(top_builddir) && pwd` \ - && $(am__cd) $(top_srcdir) \ - && gtags -i $(GTAGS_ARGS) "$$here" -cscopelist: cscopelist-am - -cscopelist-am: $(am__tagged_files) - list='$(am__tagged_files)'; \ - case "$(srcdir)" in \ - [\\/]* | ?:[\\/]*) sdir="$(srcdir)" ;; \ - *) sdir=$(subdir)/$(srcdir) ;; \ - esac; \ - for i in $$list; do \ - if test -f "$$i"; then \ - echo "$(subdir)/$$i"; \ - else \ - echo "$$sdir/$$i"; \ - fi; \ - done >> $(top_builddir)/cscope.files - -distclean-tags: - -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags - -distdir: $(DISTFILES) - @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ - topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ - list='$(DISTFILES)'; \ - dist_files=`for file in $$list; do echo $$file; done | \ - sed -e "s|^$$srcdirstrip/||;t" \ - -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ - case $$dist_files in \ - */*) $(MKDIR_P) `echo "$$dist_files" | \ - sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ - sort -u` ;; \ - esac; \ - for file in $$dist_files; do \ - if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ - if test -d $$d/$$file; then \ - dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ - if test -d "$(distdir)/$$file"; then \ - find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ - fi; \ - if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ - cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ - find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ - fi; \ - cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ - else \ - test -f "$(distdir)/$$file" \ - || cp -p $$d/$$file "$(distdir)/$$file" \ - || exit 1; \ - fi; \ - done -check-am: all-am -check: check-am -all-am: Makefile $(LIBRARIES) -installdirs: -install: install-am -install-exec: install-exec-am -install-data: install-data-am -uninstall: uninstall-am - -install-am: all-am - @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am - -installcheck: installcheck-am -install-strip: - if test -z '$(STRIP)'; then \ - $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ - install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ - install; \ - else \ - $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ - install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ - "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \ - fi -mostlyclean-generic: - -clean-generic: - -distclean-generic: - -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) - -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) - -maintainer-clean-generic: - @echo "This command is intended for maintainers to use" - @echo "it deletes files that may require special tools to rebuild." -clean: clean-am - -clean-am: clean-generic clean-local clean-noinstLIBRARIES \ - mostlyclean-am - -distclean: distclean-am - -rm -f Makefile -distclean-am: clean-am distclean-compile distclean-generic \ - distclean-tags - -dvi: dvi-am - -dvi-am: - -html: html-am - -html-am: - -info: info-am - -info-am: - -install-data-am: - -install-dvi: install-dvi-am - -install-dvi-am: - -install-exec-am: - -install-html: install-html-am - -install-html-am: - -install-info: install-info-am - -install-info-am: - -install-man: - -install-pdf: install-pdf-am - -install-pdf-am: - -install-ps: install-ps-am - -install-ps-am: - -installcheck-am: - -maintainer-clean: maintainer-clean-am - -rm -f Makefile -maintainer-clean-am: distclean-am maintainer-clean-generic - -mostlyclean: mostlyclean-am - -mostlyclean-am: mostlyclean-compile mostlyclean-generic - -pdf: pdf-am - -pdf-am: - -ps: ps-am - -ps-am: - -uninstall-am: - -.MAKE: install-am install-strip - -.PHONY: CTAGS GTAGS TAGS all all-am check check-am clean clean-generic \ - clean-local clean-noinstLIBRARIES cscopelist-am ctags ctags-am \ - distclean distclean-compile distclean-generic distclean-tags \ - distdir dvi dvi-am html html-am info info-am install \ - install-am install-data install-data-am install-dvi \ - install-dvi-am install-exec install-exec-am install-html \ - install-html-am install-info install-info-am install-man \ - install-pdf install-pdf-am install-ps install-ps-am \ - install-strip installcheck installcheck-am installdirs \ - maintainer-clean maintainer-clean-generic mostlyclean \ - mostlyclean-compile mostlyclean-generic pdf pdf-am ps ps-am \ - tags tags-am uninstall uninstall-am - - -.PHONY: clean-modules - -clean-modules: - -test -z "$(FC_MODEXT)" || rm -f *.$(FC_MODEXT) - -clean-local: clean-modules - -# dependencies - -# Tell versions [3.59,3.63) of GNU make to not export all variables. -# Otherwise a system limit (for SysV at least) may be exceeded. -.NOEXPORT: diff --git a/src/nmm/module_BGRID_INTERP.F90 b/src/nmm/module_BGRID_INTERP.F90 deleted file mode 100644 index 83d6dfc..0000000 --- a/src/nmm/module_BGRID_INTERP.F90 +++ /dev/null @@ -1,691 +0,0 @@ -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - MODULE MODULE_BGRID_INTERP -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: V_TO_H_BGRID & - ,H_TO_V_BGRID -! -!----------------------------------------------------------------------- -! - REAL :: BC_DUMMY=0. !<-- User-specified value for boundary mass points - ! in regional mode -! - interface V_TO_H_BGRID - module procedure V_TO_H_BGRID2D - module procedure V_TO_H_BGRID3D - end interface V_TO_H_BGRID -! - interface H_TO_V_BGRID - module procedure H_TO_V_BGRID2D - module procedure H_TO_V_BGRID3D - end interface H_TO_V_BGRID -! -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE V_TO_H_BGRID2D(V_VALUE,IM,JM,GLOBAL,H_VALUE,V_SAVE) -! -!----------------------------------------------------------------------- -!*** PERFORM 4-POINT AVERAGING OF QUANTITIES ON B-GRID VELOCITY POINTS -!*** TO MASS POINTS. -! -!*** FOR THE REGIONAL MODE THE USER MUST SPECIFY THE DUMMY VALUE -!*** ON THE OUTPUT BOUNDARY SINCE INTERPOLATION IS NOT VALID THERE. -!*** THAT VALUE IS "BC_DUMMY" IN THE SPECIFICATION SECTION OF -!*** THIS MODULE. -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! -!---------- -!*** Input -!---------- -! - INTEGER ,INTENT(IN) :: IM & !<-- Full west-east array dimension - ,JM !<-- Full south-north array dimension -! - REAL,DIMENSION(1:IM,1:JM),INTENT(IN) :: V_VALUE !<-- Input values on velocity points -! - LOGICAL ,INTENT(IN) :: GLOBAL !<-- Logical flag: True=>Global; False=>Regional -! -!----------- -!*** Output -!----------- -! - REAL,DIMENSION(1:IM,1:JM),INTENT(OUT) :: H_VALUE !<-- Output values on mass (H) points - REAL,DIMENSION(:,:),POINTER,INTENT(INOUT),OPTIONAL :: V_SAVE !<-- Original values on boundary V points -!local vars - INTEGER lm - real,dimension(:,:,:),allocatable :: tmp -! - LM=1 - allocate(tmp(1:IM,1:JM,1)) - call V_TO_H_BGRID3D(reshape(v_value,(/IM,JM,1/)),IM,JM,LM,GLOBAL, & - tmp,v_save) - H_VALUE(1:IM,1:JM)=TMP(1:IM,1:JM,1) - deallocate(tmp) -! -!----------------------------------------------------------------------- -! - END SUBROUTINE V_TO_H_BGRID2D -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE V_TO_H_BGRID3D(V_VALUE,IM,JM,LM,GLOBAL,H_VALUE,V_SAVE) -! -!----------------------------------------------------------------------- -!*** PERFORM 4-POINT AVERAGING OF QUANTITIES ON B-GRID VELOCITY POINTS -!*** TO MASS POINTS. -! -!*** FOR THE REGIONAL MODE THE USER MUST SPECIFY THE DUMMY VALUE -!*** ON THE OUTPUT BOUNDARY SINCE INTERPOLATION IS NOT VALID THERE. -!*** THAT VALUE IS "BC_DUMMY" IN THE SPECIFICATION SECTION OF -!*** THIS MODULE. -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! -!---------- -!*** Input -!---------- -! - INTEGER ,INTENT(IN) :: IM & !<-- Full west-east array dimension - ,JM & !<-- Full south-north array dimension - ,LM !<-- Number of model layers -! - REAL,DIMENSION(1:IM,1:JM,1:LM),INTENT(IN) :: V_VALUE !<-- Input values on velocity points -! - LOGICAL ,INTENT(IN) :: GLOBAL !<-- Logical flag: True=>Global; False=>Regional -! -!----------- -!*** Output -!----------- -! - REAL,DIMENSION(1:IM,1:JM,1:LM),INTENT(OUT) :: H_VALUE !<-- Output values on mass (H) points - REAL,DIMENSION(:,:),POINTER,INTENT(INOUT),OPTIONAL :: V_SAVE !<-- Original values on boundary V points -! -!---------- -!*** Local -!---------- -! - INTEGER :: I,J,L,N -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** LAYOUT IN I -!----------------------------------------------------------------------- -! -! | -! |<---- Integration western boundary -! | -! -! H(1) H(2) H(3) -! -! V(1) V(2) V(3) -! -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! -! V(IM-3) V(IM-2) V(IM-1) V(IM) -! -! H(IM-2) H(IM-1) H(IM) -! -! | -! Integration eastern boundary ---->| -! | -! -!----------------------------------------------------------------------- -!*** LAYOUT IN J -! -!*** MASS POINTS ACROSS THE POLE FROM EACH OTHER HAVE EQUAL VALUES. -!*** VELOCITY POINTS ACROSS THE POLE FROM EACH OTHER HAVE EQUAL -!*** VALUES OF OPPOSITE SIGN. -!*** THE LOCATION ACROSS THE POLE FROM "I" IS "I_A=I+(IM-3)/2". -!*** IF I_A > IM THEN I_A=I_A-IM+3. -!*** IM IS ALWAYS ODD. -! -!*** THE SOUTH POLE COINCIDES WITH H POINTS AT J=2. -!*** H POINTS AT J=1 REFLECT "ACROSS THE POLE" VALUES FOR J=2. -!*** THE NORTH POLE COINCIDES WITH H POINTS AT J=JM-1. -!*** H POINTS AT J=JM REFLECT "ACROSS THE POLE" VALUES FOR J=JM-1. -! -!*** -!----------------------------------------------------------------------- -! -! J=JM V V V <--- Phantom row; set equal to V at J=JM-1. -! -! J=JM H H H H <--- 1 row "north" of pole reflects 1 row south -! -! J=JM-1 V V V <--- Negative reflection of V across the pole at J=JM-2 -! -! J=JM-1 H H H H <--- NORTH POLE -! -! J=JM-2 V V V -! -! J=JM-2 H H H H <--- 1 row south of pole -! -! + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -! -! J=3 H H H H <--- 1 row north of pole -! -! J=2 V V V -! -! J=2 H H H H <--- SOUTH POLE -! -! J=1 V V V <--- Negative reflection of V accross the pole at J=2 -! -! J=1 H H H H <--- 1 row "south" of pole reflects 1 row north -! -! -!----------------------------------------------------------------------- -!*** PERFORM THE INTERPOLATION ON THE INTERNAL REGION OF THE -!*** OUTPUT ARRAY. IT IS APPLICABLE TO BOTH REGIONAL AND -!*** GLOBAL MODES. -!----------------------------------------------------------------------- -! - DO L=1,LM - DO J=2,JM-1 - DO I=2,IM-1 -! - H_VALUE(I,J,L)=0.25*(V_VALUE(I-1,J-1,L) & - +V_VALUE(I-1,J ,L) & - +V_VALUE(I ,J-1,L) & - +V_VALUE(I ,J ,L) ) -! - ENDDO - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** FOR GLOBAL MODE THE OVERLAP VALUES ON VELOCITY POINTS WILL BE -!*** USED TO INTERPOLATE TO THE BOUNDARY MASS POINTS. -!----------------------------------------------------------------------- -! - layers: DO L=1,LM -! - mode: IF(GLOBAL)THEN -! -!-------------------------- -!*** West/East Boundaries -!-------------------------- -! -!*** General Case -! - DO J=3,JM-2 !<-- From 1 row north of S. Pole to 1 row south of N. Pole -! - H_VALUE( 1,J,L)=0.25*(V_VALUE(IM-3,J-1,L) & !<-- West - +V_VALUE(IM-2,J-1,L) & - +V_VALUE(IM-3,J ,L) & - +V_VALUE(IM-2,J ,L) ) -! - H_VALUE(IM,J,L)=0.25*(V_VALUE(2,J-1,L) & !<-- East - +V_VALUE(3,J-1,L) & - +V_VALUE(2,J ,L) & - +V_VALUE(3,J ,L) ) -! - ENDDO -! -!*** One row south of South Pole reflects one row north of pole. -! - H_VALUE( 1,1,L)=H_VALUE( 1,3,L) !<-- West - H_VALUE(IM,1,L)=H_VALUE(IM,3,L) !<-- East -! -!*** H value at S. Pole averages V values to the north and -!*** the "south" which are the same. -! - H_VALUE(1,2,L)=0.25*(V_VALUE(IM-3,2,L) & !<-- West - +V_VALUE(IM-2,2,L) & - +V_VALUE(IM-3,2,L) & - +V_VALUE(IM-2,2,L) ) -! - H_VALUE(IM,2,L)=0.25*(V_VALUE(2,2,L) & !<-- East - +V_VALUE(3,2,L) & - +V_VALUE(2,2,L) & - +V_VALUE(3,2,L) ) -! -!*** H value at N. Pole averages V values to the south and -!*** the "north" which are the same. -! - H_VALUE(1,JM-1,L)=0.25*(V_VALUE(IM-3,JM-2,L) & !<-- West - +V_VALUE(IM-2,JM-2,L) & - +V_VALUE(IM-3,JM-2,L) & - +V_VALUE(IM-2,JM-2,L) ) -! - H_VALUE(IM,JM-1,L)=0.25*(V_VALUE(2,JM-2,L) & !<-- East - +V_VALUE(3,JM-2,L) & - +V_VALUE(2,JM-2,L) & - +V_VALUE(3,JM-2,L) ) -! -!*** One row north of North Pole reflects one row south of pole. -! - H_VALUE( 1,JM,L)=H_VALUE( 1,JM-2,L) !<-- West - H_VALUE(IM,JM,L)=H_VALUE(IM,JM-2,L) !<-- East -! -!---------------------------- -!*** South/North Boundaries -!---------------------------- -! - DO I=1,IM - H_VALUE(I, 1,L)=H_VALUE(I, 3,L) !<-- South - H_VALUE(I,JM,L)=H_VALUE(I,JM-2,L) !<-- North - ENDDO -! -!----------------------------------------------------------------------- -!*** FOR REGIONAL MODE JUST USE THE DUMMY VALUE FOR BOUNDARY POINTS. -!----------------------------------------------------------------------- -! - ELSE mode -! -!---------------------------- -!*** South/North Boundaries -!---------------------------- -! - DO I=1,IM - H_VALUE(I, 1,L)=BC_DUMMY - H_VALUE(I,JM,L)=BC_DUMMY - ENDDO -! -!-------------------------- -!*** West/East Boundaries -!-------------------------- -! - DO J=2,JM-1 - H_VALUE( 1,J,L)=BC_DUMMY - H_VALUE(IM,J,L)=BC_DUMMY - ENDDO -! -!----------------------------------------------------------------------- -! - ENDIF mode -! - ENDDO layers -! -!----------------------------------------------------------------------- -!*** IN THE REGIONAL MODE THE BOUNDARY VALUES ON VELOCITY POINTS -!*** WILL NOT BE RETRIEVABLE THROUGH REVERSE INTERPOLATION OF -!*** THESE VALUES ON MASS POINTS SINCE THE BOUNDARY MASS POINTS -!*** DO NOT HAVE ACTUAL VALUES. -!*** THEREFORE THE FOLLOWING SECTION SAVES THE BOUNDARY VELOCITY -!*** POINT VALUES THAT CAN THEN BE USED TO COMPLETE THE VELOCITY -!*** ARRAY AFTER A REVERSE INTERPOLATION IS DONE. -! -!*** ALL VELOCITY POINT VALUES AT I=IM and J=JM ARE MEANINGLESS -!*** BECAUSE THEY ARE OUTSIDE THE INTEGRATION DOMAIN. -!----------------------------------------------------------------------- -! -!jw save: IF(.NOT.GLOBAL)THEN - save: IF(.NOT.GLOBAL .and. present(v_save) )THEN -! - DO L=1,LM -! - N=0 -! -!-------------------- -!*** South Boundary -!-------------------- -! - DO I=1,IM-1 - N=N+1 - V_SAVE(N,L)=V_VALUE(I,1,L) - ENDDO -! -!-------------------- -!*** North Boundary -!-------------------- -! - DO I=1,IM-1 - N=N+1 - V_SAVE(N,L)=V_VALUE(I,JM-1,L) !<-- Northernmost V points in integration domain - ENDDO -! -!-------------------- -!*** West Boundary -!-------------------- -! - DO J=2,JM-1 - N=N+1 - V_SAVE(N,L)=V_VALUE(1,J,L) - ENDDO -! -!-------------------- -!*** East Boundary -!-------------------- -! - DO J=2,JM-1 - N=N+1 - V_SAVE(N,L)=V_VALUE(IM-1,J,L) !<-- Easternmost V points in integration domain - ENDDO -! -!----------------------------------------------------------------------- -! - ENDDO -! - ENDIF save -! -!----------------------------------------------------------------------- -! - END SUBROUTINE V_TO_H_BGRID3D -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE H_TO_V_BGRID2D(H_VALUE,IM,JM,GLOBAL,V_SAVE,V_VALUE) -! -!----------------------------------------------------------------------- -!*** PERFORM 4-POINT AVERAGING OF QUANTITIES ON B-GRID MASS POINTS -!*** TO VELOCITY POINTS. THIS ROUTINE IS INTENDED FOR USE IN -!*** INTERPOLATING VELOCITY VALUES BACK TO V POINTS AFTER HAVING -!*** BEEN INTERPOLATED ONTO H POINTS. THE INPUT POINTER V_SAVE -!*** IS USED TO RECOVER THE VELOCITY VALUES ON THE BOUNDARY V POINTS -!*** WHEN IN REGIONAL MODE BECAUSE THEY CANNOT BE RECOVERED -!*** BY THE INTERPOLATION FROM H POINTS GIVEN THAT BOUNDARY H POINTS -!*** IN REGIONAL MODE COULD NOT BE OBTAINED BY INTERPOLATIONS FROM -!*** THE V POINTS. -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! -!---------- -!*** Input -!---------- -! - INTEGER ,INTENT(IN) :: IM & !<-- Full west-east array dimension - ,JM !<-- Full south-north array dimension -! - REAL,DIMENSION(1:IM,1:JM),INTENT(IN) :: H_VALUE !<-- Input values on mass points - REAL,DIMENSION(:,:),POINTER ,INTENT(IN) :: V_SAVE !<-- Saved values on boundary velocity points -! - LOGICAL ,INTENT(IN) :: GLOBAL !<-- Logical flag: True=>Global; False=>Regional -! -!----------- -!*** Output -!----------- -! - REAL,DIMENSION(1:IM,1:JM),INTENT(OUT) :: V_VALUE !<-- Output values on mass (V) points -! -!---------- - INTEGER LM - real,dimension(:,:,:),allocatable :: tmp -! -!---------- - LM=1 - allocate(tmp(1:IM,1:JM,1)) - call H_TO_V_BGRID3D(reshape(H_VALUE,(/IM,JM,1/)),IM,JM,LM,GLOBAL, & - V_SAVE, tmp ) - V_VALUE(1:IM,1:JM)=tmp(1:IM,1:JM,1) - deallocate(tmp) -! -!----------------------------------------------------------------------- -! - END SUBROUTINE H_TO_V_BGRID2D -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE H_TO_V_BGRID3D(H_VALUE,IM,JM,LM,GLOBAL,V_SAVE,V_VALUE) -! -!----------------------------------------------------------------------- -!*** PERFORM 4-POINT AVERAGING OF QUANTITIES ON B-GRID MASS POINTS -!*** TO VELOCITY POINTS. THIS ROUTINE IS INTENDED FOR USE IN -!*** INTERPOLATING VELOCITY VALUES BACK TO V POINTS AFTER HAVING -!*** BEEN INTERPOLATED ONTO H POINTS. THE INPUT POINTER V_SAVE -!*** IS USED TO RECOVER THE VELOCITY VALUES ON THE BOUNDARY V POINTS -!*** WHEN IN REGIONAL MODE BECAUSE THEY CANNOT BE RECOVERED -!*** BY THE INTERPOLATION FROM H POINTS GIVEN THAT BOUNDARY H POINTS -!*** IN REGIONAL MODE COULD NOT BE OBTAINED BY INTERPOLATIONS FROM -!*** THE V POINTS. -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! -!---------- -!*** Input -!---------- -! - INTEGER ,INTENT(IN) :: IM & !<-- Full west-east array dimension - ,JM & !<-- Full south-north array dimension - ,LM !<-- Number of model layers -! - REAL,DIMENSION(1:IM,1:JM,1:LM),INTENT(IN) :: H_VALUE !<-- Input values on mass points - REAL,DIMENSION(:,:),POINTER ,INTENT(IN) :: V_SAVE !<-- Saved values on boundary velocity points -! - LOGICAL ,INTENT(IN) :: GLOBAL !<-- Logical flag: True=>Global; False=>Regional -! -!----------- -!*** Output -!----------- -! - REAL,DIMENSION(1:IM,1:JM,1:LM),INTENT(OUT) :: V_VALUE !<-- Output values on mass (V) points -! -!---------- -!*** Local -!---------- -! - INTEGER :: I,J,L,N -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!*** NOTE THE NATURE OF THE BOUNDARY OVERLAP FOR THE GLOBAL MODE. -! -!*** H(1) and H(IM-2) COINCIDE. -!*** H(2) and H(IM-1) COINCIDE. -!*** H(3) and H(IM) COINCIDE. -! -!----------------------------------------------------------------------- -! -! | -! |<---- Integration western boundary for H -! | -! -! | -! |<---- Integration western boundary for V -! | -! -! V(1) V(2) V(3) -! -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! -! V(IM-3) V(IM-2) V(IM-1) V(IM) -! -! | -! Integration eastern boundary for V ---->| -! | -! -! | -! Integration eastern boundary for H ---->| -! | -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -! J=JM V V V -! -! J=JM H H H H <--- 1 row "north" of pole -! is 1 row south. -! J=JM-1 V V V -! -! J=JM-1 H H H H <--- North Pole: Integration boundary for H -! -! J=JM-2 V V V <--- Integration boundary for V -! -! J=JM-2 H H H H <--- 1 row south of pole -! -! + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -! -! J=3 H H H H <--- 1 row north of pole -! -! J=2 V V V <--- Integration boundary for V -! -! J=2 H H H H <--- South Pole: Integration boundary for H -! -! J=1 V V V <--- Reflection of J=2 -! -! J=1 H H H H <--- 1 row "south" of pole -! is 1 row north. -! -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** PERFORM THE INTERPOLATION ON THE INTERNAL REGION OF THE -!*** OUTPUT ARRAY. IT IS APPLICABLE TO BOTH REGIONAL AND -!*** GLOBAL MODES. -!*** WE CANNOT REACH IM-1 AND JM-1 ON V POINTS BECAUSE VALUES -!*** AT IM AND JM ON H POINTS CANNOT BE COMPUTED FROM V POINTS -!*** WHEN IN REGIONAL MODE. -!----------------------------------------------------------------------- -! - DO L=1,LM - DO J=2,JM-2 - DO I=2,IM-2 -! - V_VALUE(I,J,L)=0.25*(H_VALUE(I ,J ,L) & - +H_VALUE(I+1,J ,L) & - +H_VALUE(I ,J+1,L) & - +H_VALUE(I+1,J+1,L) ) -! - ENDDO - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** FOR GLOBAL MODE THE OVERLAP VALUES ON VELOCITY POINTS WILL BE -!*** USED TO INTERPOLATE TO THE BOUNDARY MASS POINTS. -!----------------------------------------------------------------------- -! - layers: DO L=1,LM -! - mode: IF(GLOBAL)THEN -! -!-------------------------- -!*** West/East Boundaries -!-------------------------- -! - DO J=1,JM-1 -! - V_VALUE( 1,J,L)=0.25*(H_VALUE(1,J ,L) & !<-- West - +H_VALUE(2,J ,L) & - +H_VALUE(1,J+1,L) & - +H_VALUE(2,J+1,L) ) -! - V_VALUE(IM-1,J,L)=0.25*(H_VALUE(2,J ,L) & !<-- East - 1 - +H_VALUE(3,J ,L) & - +H_VALUE(2,J+1,L) & - +H_VALUE(3,J+1,L) ) -! - V_VALUE(IM,J,L)=0.25*(H_VALUE(3,J ,L) & !<-- East - +H_VALUE(4,J ,L) & - +H_VALUE(3,J+1,L) & - +H_VALUE(4,J+1,L) ) -! - ENDDO -! -!---------------------------- -!*** South/North Boundaries -!---------------------------- -! - DO I=1,IM-1 - V_VALUE(I, 1,L)=V_VALUE(I, 2,L) !<-- South - V_VALUE(I,JM-1,L)=V_VALUE(I,JM-2,L) !<-- North-1 reflected around North Pole - V_VALUE(I,JM ,L)=V_VALUE(I,JM ,L) !<-- North reflected around North Pole - ENDDO -! -!----------------------------------------------------------------------- -!*** FOR REGIONAL MODE USE THE SAVED ORIGINAL BOUNDARY VALUES -!*** SINCE THOSE BOUNDARY VALUES CANNOT BE OBTAINED THROUGH -!*** INTEPOLATION FROM THE H POINTS. -!----------------------------------------------------------------------- -! - ELSE mode -! -!-------------------- -!*** South Boundary -!-------------------- -! - N=0 -! - DO I=1,IM-1 - V_VALUE(I, 1,L)=V_SAVE(N,L) - ENDDO -! -!---------------------------- -!*** North Boundary -!---------------------------- -! - DO I=1,IM-1 - V_VALUE(I,JM-1,L)=V_SAVE(N,L) !<-- Northernmost V points in integration - ENDDO -! -!-------------------------- -!*** West Boundary -!-------------------------- -! - DO J=2,JM-1 - V_VALUE( 1,J,L)=V_SAVE(N,L) - ENDDO -! -!-------------------------- -!*** East Boundary -!-------------------------- -! - DO J=2,JM-1 - V_VALUE(IM-1,J,L)=V_SAVE(N,L) !<-- Easternmost V points in integration - ENDDO -! -!----------------------------------------------------------------------- -!*** ZERO OUT PHANTOM LOCATIONS. -!----------------------------------------------------------------------- -! - DO J=1,JM - V_VALUE(IM,J,L)=0. - ENDDO -! - DO I=1,IM - V_VALUE(I,JM,L)=0. - ENDDO -! -!----------------------------------------------------------------------- -! - ENDIF mode -! - ENDDO layers -! -!----------------------------------------------------------------------- -!*** ALL VELOCITY POINT VALUES AT I=IM and J=JM ARE MEANINGLESS -!*** BECAUSE THEY ARE OUTSIDE THE INTEGRATION DOMAIN. -!----------------------------------------------------------------------- -! - END SUBROUTINE H_TO_V_BGRID3D -! -!----------------------------------------------------------------------- -! - END MODULE MODULE_BGRID_INTERP -! -!----------------------------------------------------------------------- diff --git a/src/nmm/module_CLOCKTIMES.F90 b/src/nmm/module_CLOCKTIMES.F90 deleted file mode 100644 index c82d4eb..0000000 --- a/src/nmm/module_CLOCKTIMES.F90 +++ /dev/null @@ -1,323 +0,0 @@ -!----------------------------------------------------------------------- -! - MODULE MODULE_CLOCKTIMES -! -!----------------------------------------------------------------------- -! -!*** List the clocktime counters for the various parts of -!*** the integration and print them as desired. -! -!----------------------------------------------------------------------- -! - USE MODULE_KINDS -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: INTEGRATION_TIMERS & - ,PRINT_CLOCKTIMES & - ,TIMERS & - ,cbcst_tim,pbcst_tim -! -!----------------------------------------------------------------------- -! - TYPE INTEGRATION_TIMERS -! - REAL(kind=KDBL) :: total_integ_tim,totalsum_tim -! - REAL(kind=KDBL) :: solver_dyn_tim,solver_phy_tim -! - REAL(kind=KDBL) :: adv1_tim,adv2_tim,bocoh_tim,bocov_tim & - ,cdwdt_tim,cdzdt_tim,consts_tim & - ,ddamp_tim,dht_tim & - ,exch_dyn,exch_phy & - ,exch_tim & - ,fftfhn_tim,fftfwn_tim & - ,hdiff_tim,mono_tim & - ,pdtsdt_tim,pgforce_tim,poavhn_tim & - ,polehn_tim,polewn_tim & - ,prefft_tim,presmud_tim & - ,solver_init_tim & - ,swaphn_tim,swapwn_tim & - ,updatet_tim & - ,updateuv_tim & - ,updates_tim & - ,vsound_tim,vtoa_tim -! - REAL(kind=KDBL) :: adjppt_tim,cucnvc_tim & - ,gsmdrive_tim,h_to_v_tim,gfs_phy_tim & - ,phy_sum_tim & - ,pole_swap_tim,radiation_tim,rdtemp_tim & - ,turbl_tim & - ,cltend_tim,rfupdate_tim,tqadjust_tim -! - REAL(kind=KDBL) :: domain_run_1 & - ,domain_run_2 & - ,domain_run_3 & - ,pc_cpl_run_cpl1 & - ,pc_cpl_run_cpl2 & - ,pc_cpl_run_cpl3 & - ,pc_cpl_run_cpl4 & - ,pc_cpl_run_cpl5 & - ,cpl1_recv_tim & - ,cpl2_send_tim & - ,cpl2_comp_tim & - ,cpl2_wait_tim & - ,parent_bookkeep_moving_tim & - ,parent_update_moving_tim & - ,t0_recv_move_tim & - ,read_moving_child_topo_tim & - ,barrier_move_tim,pscd_tim,pscd1_tim & - ,pscd2_tim,pscd3_tim,pscd4_tim - -! -!----------------------------------------------------------------------- -!*** Associated with moving nests -!----------------------------------------------------------------------- -! - REAL(kind=KDBL) :: update_interior_from_nest_tim & - ,update_interior_from_parent_tim -! - END TYPE INTEGRATION_TIMERS -! -!----------------------------------------------------------------------- -! - TYPE(INTEGRATION_TIMERS),DIMENSION(:),ALLOCATABLE,TARGET :: TIMERS !<-- Timers for each domain -! - REAL(kind=KDBL),DIMENSION(99) :: cbcst_tim,pbcst_tim -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -! - SUBROUTINE PRINT_CLOCKTIMES(NTIMESTEP & - ,MY_DOMAIN_ID & - ,MYPE & - ,NPE_PRINT & - ,TIMERS_DOMAIN) -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: NTIMESTEP & !<-- Forecast timestep - ,MY_DOMAIN_ID & !<-- The domain's ID - ,MYPE & !<-- The task ID - ,NPE_PRINT !<-- ID of task providing clocktime diagnostics -! - TYPE(INTEGRATION_TIMERS),TARGET,INTENT(INOUT) :: TIMERS_DOMAIN !<-- Assorted clocktime timers for current domain -! -!--------------------- -!*** Local variables -!--------------------- -! - TYPE(INTEGRATION_TIMERS),POINTER :: TD -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - TD=>TIMERS_DOMAIN !<-- Abbreviate name of this domain's timers -! -!----------------------------------------------------------------------- -! - td%totalsum_tim=td%adv1_tim & - +td%bocoh_tim & - +td%bocov_tim & - +td%cdwdt_tim & - +td%cdzdt_tim & - +td%dht_tim & - +td%ddamp_tim & - +td%exch_dyn & - +td%fftfhn_tim & - +td%fftfwn_tim & - +td%hdiff_tim & - +td%pdtsdt_tim & - +td%pgforce_tim & - +td%poavhn_tim & - +td%polehn_tim & - +td%polewn_tim & - +td%swaphn_tim & - +td%swapwn_tim & - +td%updatet_tim & - +td%updateuv_tim & - +td%updates_tim & - +td%vsound_tim & - +td%vtoa_tim -! - td%totalsum_tim=td%totalsum_tim & - +td%cucnvc_tim & - +td%exch_phy & - +td%gsmdrive_tim & - +td%h_to_v_tim & - +td%pole_swap_tim & - +td%radiation_tim & - +td%rdtemp_tim & - +td%turbl_tim & - +td%cltend_tim & - +td%rfupdate_tim & - +td%tqadjust_tim -! - td%totalsum_tim=td%totalsum_tim & - +td%solver_init_tim -! -!----------------------------------------------------------------------- -!*** The designated MPI task writes clocktimes for its work. -!----------------------------------------------------------------------- -! - IF(MYPE==NPE_PRINT)THEN -! - write(0,*)' ' - write(0,FMT='(" Clocktimes for domain #",I2.2)') my_domain_id -! - write(0,FMT='(" ntsd= ",I6," total_integration_tim= ",g12.5)') ntimestep,td%total_integ_tim -! - write(0,FMT='(" solver_init= ",g12.5," pct= ",f7.2)') td%solver_init_tim & - ,td%solver_init_tim/td%total_integ_tim*100. - write(0,FMT='(" consts= ",g12.5," pct= ",f7.2)') td%consts_tim & - ,td%consts_tim/td%total_integ_tim*100. -! - write(0,*)' DYNAMICS' -! - write(0,FMT='(" solver_dyn_total= ",g12.5," pct= ",f7.2)') td%solver_dyn_tim & - ,td%solver_dyn_tim/td%total_integ_tim*100. - write(0,FMT='(" solver_dyn_w/o_exch= ",g12.5," pct= ",f7.2)') td%solver_dyn_tim-td%exch_dyn & - ,(td%solver_dyn_tim-td%exch_dyn)/td%total_integ_tim*100. - write(0,FMT='(" pgforce= ",g12.5," pct= ",f7.2)') td%pgforce_tim & - ,td%pgforce_tim/td%total_integ_tim*100. - write(0,FMT='(" dht= ",g12.5," pct= ",f7.2)') td%dht_tim & - ,td%dht_tim/td%total_integ_tim*100. - write(0,FMT='(" ddamp= ",g12.5," pct= ",f7.2)') td%ddamp_tim & - ,td%ddamp_tim/td%total_integ_tim*100. - write(0,FMT='(" pdtsdt= ",g12.5," pct= ",f7.2)') td%pdtsdt_tim & - ,td%pdtsdt_tim/td%total_integ_tim*100. - write(0,FMT='(" vtoa= ",g12.5," pct= ",f7.2)') td%vtoa_tim & - ,td%vtoa_tim/td%total_integ_tim*100. - write(0,FMT='(" adv1= ",g12.5," pct= ",f7.2)') td%adv1_tim & - ,td%adv1_tim/td%total_integ_tim*100. -! - if(td%adv2_tim/=0.)then - write(0,FMT='(" adv2= ",g12.5," pct= ",f7.2)') td%adv2_tim & - ,td%adv2_tim/td%total_integ_tim*100. - endif -! - if(td%mono_tim/=0.)then - write(0,FMT='(" mono= ",g12.5," pct= ",f7.2)') td%mono_tim & - ,td%mono_tim/td%total_integ_tim*100. - endif -! - write(0,FMT='(" cdzdt= ",g12.5," pct= ",f7.2)') td%cdzdt_tim & - ,td%cdzdt_tim/td%total_integ_tim*100. - write(0,FMT='(" cdwdt= ",g12.5," pct= ",f7.2)') td%cdwdt_tim & - ,td%cdwdt_tim/td%total_integ_tim*100. - write(0,FMT='(" vsound= ",g12.5," pct= ",f7.2)') td%vsound_tim & - ,td%vsound_tim/td%total_integ_tim*100. - write(0,FMT='(" hdiff= ",g12.5," pct= ",f7.2)') td%hdiff_tim & - ,td%hdiff_tim/td%total_integ_tim*100. - write(0,FMT='(" bocoh= ",g12.5," pct= ",f7.2)') td%bocoh_tim & - ,td%bocoh_tim/td%total_integ_tim*100. - write(0,FMT='(" bocov= ",g12.5," pct= ",f7.2)') td%bocov_tim & - ,td%bocov_tim/td%total_integ_tim*100. - write(0,FMT='(" updatet= ",g12.5," pct= ",f7.2)') td%updatet_tim & - ,td%updatet_tim/td%total_integ_tim*100. - write(0,FMT='(" updateuv= ",g12.5," pct= ",f7.2)') td%updateuv_tim & - ,td%updateuv_tim/td%total_integ_tim*100. - write(0,FMT='(" updates= ",g12.5," pct= ",f7.2)') td%updates_tim & - ,td%updates_tim/td%total_integ_tim*100. - - if(td%prefft_tim/=0.)then - write(0,FMT='(" prefft= ",g12.5," pct= ",f7.2)') td%prefft_tim & - ,td%prefft_tim/td%total_integ_tim*100. - write(0,FMT='(" fftfhn= ",g12.5," pct= ",f7.2)') td%fftfhn_tim & - ,td%fftfhn_tim/td%total_integ_tim*100. - write(0,FMT='(" fftfwn= ",g12.5," pct= ",f7.2)') td%fftfwn_tim & - ,td%fftfwn_tim/td%total_integ_tim*100. - write(0,FMT='(" polewn= ",g12.5," pct= ",f7.2)') td%polewn_tim & - ,td%polewn_tim/td%total_integ_tim*100. - write(0,FMT='(" poavhn= ",g12.5," pct= ",f7.2)') td%poavhn_tim & - ,td%poavhn_tim/td%total_integ_tim*100. - endif -! - if(td%presmud_tim/=0.)then - write(0,FMT='(" presmud= ",g12.5," pct= ",f7.2)') td%presmud_tim & - ,td%presmud_tim/td%total_integ_tim*100. - endif - write(0,*)' PHYSICS ' -! - write(0,FMT='(" solver_phy_total= ",g12.5," pct= ",f7.2)') td%solver_phy_tim & - ,td%solver_phy_tim/td%total_integ_tim*100. - write(0,FMT='(" solver_phy_w/o_exch= ",g12.5," pct= ",f7.2)') td%solver_phy_tim-td%exch_phy & - ,(td%solver_phy_tim-td%exch_phy)/td%total_integ_tim*100. - write(0,FMT='(" cucnvc= ",g12.5," pct= ",f7.2)') td%cucnvc_tim & - ,td%cucnvc_tim/td%total_integ_tim*100. - write(0,FMT='(" gsmdrive= ",g12.5," pct= ",f7.2)') td%gsmdrive_tim & - ,td%gsmdrive_tim/td%total_integ_tim*100. - write(0,FMT='(" cltend= ",g12.5," pct= ",f7.2)') td%cltend_tim & - ,td%cltend_tim/td%total_integ_tim*100. - write(0,FMT='(" rime_factor_update= ",g12.5," pct= ",f7.2)') td%rfupdate_tim & - ,td%rfupdate_tim/td%total_integ_tim*100. - write(0,FMT='(" tqadjust= ",g12.5," pct= ",f7.2)') td%tqadjust_tim & - ,td%tqadjust_tim/td%total_integ_tim*100. - write(0,FMT='(" radiation= ",g12.5," pct= ",f7.2)') td%radiation_tim & - ,td%radiation_tim/td%total_integ_tim*100. - write(0,FMT='(" rdtemp= ",g12.5," pct= ",f7.2)') td%rdtemp_tim & - ,td%rdtemp_tim/td%total_integ_tim*100. - write(0,FMT='(" turbl= ",g12.5," pct= ",f7.2)') td%turbl_tim & - ,td%turbl_tim/td%total_integ_tim*100. - write(0,FMT='(" h_to_v= ",g12.5," pct= ",f7.2)') td%h_to_v_tim & - ,td%h_to_v_tim/td%total_integ_tim*100. -! - if(td%pole_swap_tim/=0.)then - write(0,FMT='(" pole_swap= ",g12.5," pct= ",f7.2)') td%pole_swap_tim & - ,td%pole_swap_tim/td%total_integ_tim*100. - endif -! - write(0,*)' EXCHANGE TIMES ' -! - write(0,FMT='(" exch_dyn= ",g12.5," pct= ",f7.2)') td%exch_dyn & - ,td%exch_dyn/td%total_integ_tim*100. -! - write(0,FMT='(" exch_phy= ",g12.5," pct= ",f7.2)') td%exch_phy & - ,td%exch_phy/td%total_integ_tim*100. -! - td%exch_tim=td%exch_dyn+td%exch_phy - write(0,FMT='(" exch_tim= ",g12.5," pct= ",f7.2)') td%exch_tim & - ,td%exch_tim/td%total_integ_tim*100. -! - if(td%swaphn_tim/=0.)then - write(0,FMT='(" swaphn= ",g12.5," pct= ",f7.2)') td%swaphn_tim & - ,td%swaphn_tim/td%total_integ_tim*100. - endif -! - if(td%swapwn_tim/=0.)then - write(0,FMT='(" swapwn= ",g12.5," pct= ",f7.2)') td%swapwn_tim & - ,td%swapwn_tim/td%total_integ_tim*100. - endif -! - if(td%polehn_tim/=0.)then - write(0,FMT='(" polehn= ",g12.5," pct= ",f7.2)') td%polehn_tim & - ,td%polehn_tim/td%total_integ_tim*100. - endif -! - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PRINT_CLOCKTIMES -! -!----------------------------------------------------------------------- -! - END MODULE MODULE_CLOCKTIMES -! -!----------------------------------------------------------------------- diff --git a/src/nmm/module_CONSTANTS.F90 b/src/nmm/module_CONSTANTS.F90 deleted file mode 100644 index c03a007..0000000 --- a/src/nmm/module_CONSTANTS.F90 +++ /dev/null @@ -1,68 +0,0 @@ -!----------------------------------------------------------------------- -! - module module_constants -! -!----------------------------------------------------------------------- -! - use module_kinds -! -!----------------------------------------------------------------------- - implicit none -!----------------------------------------------------------------------- -!*** Physical constants -!----------------------------------------------------------------------- -real(kind=kfpt),parameter:: & - a=6376000. & ! radius of earth -,a2=17.2693882 & ! saturation spec. humidity formula coeff. -,a3=273.15 & ! saturation spec. humidity formula coeff. -,a4=35.86 & ! saturation spec. humidity formula coeff. -,cp=1004.6 & ! spec. heat for dry air at constant pressure -,elwv=2.501e6 & ! latent heat, liquid/vapor -,eliv=2.850e6 & ! latent heat, ice/vapor -,eliwv=2.683e6 & ! latent heat, mix ice/water - vapor -,elivw=2.72e6 & ! another one -,eliw=3.50e5 & ! latent heat of fusion from WRF -,epsilon=1.e-15 & -!! ,epsq2=0.02 & ! floor value for 2tke -,epsq=1.e-12 & ! floor value for specific humidity (kg/kg) -,g=9.8060226 & ! gravity -,pi=3.141592653589793 & ! ludolf number -,pihf=0.5*pi & ! pi/2 -,pq0=379.90516 & ! water vapor pressure for tetens formula -,r=287.04 & ! gas constant for dry air -,r_d=287.04 & ! gas constant for dry air -,r_v=461.6 & ! gas constant for water vapor -,cv=cp-r_d & -,cpv=4.*r_v & -,ep_1=r_v/r_d-1. & -,ep_2=r/r_v & -,cice=2106. & -,cliq=4190. & -,psat=610.78 & -,rhoair0=1.28 & -,rhowater=1000. & ! density of water (kg/m3) -,rhosnow=100. & -,p608=r_v/r-1. & ! factor for water vapor in virtual temperature -,svpt0=273.15 & -,ti0=271.15 & ! water temperature below sea ice -,tiw=273.15 & ! melting point -,twom=.00014584 & ! 2 x angular velocity of earth -,cappa=r/cp & ! kappa -,dtr=pi/180. & ! factor converting degrees to radians -,rlag=14.8125 & -,stbolt=5.67051E-8 & ! Stefan-Boltzmann constant -,dbzmin=-20. & ! Minimum radar reflectivity (dBZ) -,xlf=3.50E5 & -,xlv=2.5E6 -!----------------------------------------------------------------------- -!*** Soil layers -!----------------------------------------------------------------------- -integer(kind=kint),parameter :: & - kmsc=6 & ! max # of LSM layers -,ksnoc=1 & ! number of snow layers in LSM scheme -,nosnoc=kmsc-ksnoc & ! # of soil layers without sno -,nwetc=nosnoc-1 ! # of soil layers with soil moisture -! - end module module_constants -! -!----------------------------------------------------------------------- diff --git a/src/nmm/module_CONTROL.F90 b/src/nmm/module_CONTROL.F90 deleted file mode 100644 index dfd15e3..0000000 --- a/src/nmm/module_CONTROL.F90 +++ /dev/null @@ -1,2318 +0,0 @@ - - module module_control -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -! -use mpi -! -use module_kinds -use module_exchange -use module_constants -use module_derived_types,only: bc_h_all,bc_v_all -! -!----------------------------------------------------------------------- -! - implicit none -! -!----------------------------------------------------------------------- -! - integer(kind=kint),parameter :: num_domains_max=99 -! -!----------------------------------------------------------------------- -! - public NMMB_Finalize - public grid_consts - public num_domains_max -! -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -!---look-up tables------------------------------------------------------ -!----------------------------------------------------------------------- -integer(kind=kint),parameter :: & - itb=201 & ! convection tables, dimension 1 -,jtb=601 & ! convection tables, dimension 2 -,kexm=10001 & ! size of exponentiation table -,kztm=10001 ! size of surface layer stability function table - -real(kind=kfpt),parameter :: & - ph=105000. & ! upper bound of pressure range -,thh=350. & ! upper bound of potential temperature range -,thl=200. ! upper bound of potential temperature range - -integer(kind=kint):: & - kexm2 & ! internal points of exponentiation table -,kztm2 ! internal pts. of the stability function table - -real(kind=kfpt) :: & - dex & ! exponentiation table step -,dzeta1 & ! sea table z/L step -,dzeta2 & ! land table z/L step -,fh01 & ! prandtl number for sea stability functions -,fh02 & ! prandtl number for land stability functions -,pl & ! lower bound of pressure range -,rdp & ! scaling factor for pressure -,rdq & ! scaling factor for humidity -,rdth & ! scaling factor for potential temperature -,rdthe & ! scaling factor for equivalent pot. temperature -,rdex & ! exponentiation table scaling factor -,xmax & ! upper bound for exponent in the table -,xmin & ! lower bound for exponent in the table -,ztmax1 & ! upper bound for z/L for sea stab. functions -,ztmin1 & ! lower bound for z/L for sea stab. functions -,ztmax2 & ! upper bound for z/L for land stab. functions -,ztmin2 ! lower bound for z/L for land stab. functions - -real(kind=kfpt),dimension(1:itb):: & - sthe & ! range for equivalent potential temperature -,the0 ! base for equivalent potential temperature - -real(kind=kfpt),dimension(1:jtb):: & - qs0 & ! base for saturation specific humidity -,sqs ! range for saturation specific humidity - -real(kind=kfpt),dimension(1:kexm):: & - expf ! exponentiation table - -real(kind=kfpt),dimension(1:kztm):: & - psih1 & ! sea heat stability function -,psim1 & ! sea momentum stability function -,psih2 & ! land heat stability function -,psim2 ! land momentum stability function - -real(kind=kfpt),dimension(1:itb,1:jtb):: & - ptbl ! saturation pressure table - -real(kind=kfpt),dimension(1:jtb,1:itb):: & - ttbl ! temperature table -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -!---miscellaneous control parameters------------------------------------ -!----------------------------------------------------------------------- -character(64):: & - infile - -logical(kind=klog):: & - readbc & ! read regional boundary conditions -,runbc ! boundary data ready, start run - -integer(kind=kint):: & - ihr & ! current forecast hour -,ihrbc & ! boundary condition hour -,ihrstbc & ! boundary conditions starting time -,nbc ! boundary data logical unit - -integer(kind=kint),dimension(1:3):: & - idatbc(3) ! date of boundary data, day, month, year - -real(kind=kfpt):: & - bofac ! amplification of diffusion along bndrs. - -integer(kind=kint):: & - lnsbc ! # of boundary lines with enhanced diffusion -! -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! - contains -! -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - subroutine consts & - (global & - ,dt & - ,smag2,codamp,wcor & - ,pt & - ,tph0d,tlm0d & - ,sbd,wbd & - ,dphd,dlmd & - ,dxh,rdxh & - ,dxv,rdxv & - ,dyh,rdyh & - ,dyv,rdyv & - ,ddv,rddv & - ,ddmpu,ddmpv & - ,ef4t,wpdar & - ,fcp,fdiv & - ,curv,f & - ,fad,fah & - ,dare,rare & - ,glat,glon & - ,glat_sw,glon_sw & - ,vlat,vlon & - ,hdacx,hdacy & - ,hdacvx,hdacvy & - ,lnsh,lnsad & - ,adv_standard,adv_upstream & - ,e_bdy,n_bdy,s_bdy,w_bdy & - ,nboco,tboco & - ,my_domain_id,mype & - ,its,ite,jts,jte & - ,ims,ime,jms,jme & - ,ids,ide,jds,jde ) -! -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -! - implicit none -! -!----------------------------------------------------------------------- -integer(kind=kint),intent(in) :: & - ids,ide,jds,jde & -,ims,ime,jms,jme & -,its,ite,jts,jte & -,lnsh & -,my_domain_id & -,mype - -integer(kind=kint),intent(out) :: & - lnsad & -,nboco - -real(kind=kfpt),intent(in) :: & - codamp & ! divergence damping coefficient -,dt & ! fundamental dynamics timestep (sec) -,dlmd & ! grid increment, delta lambda, degrees -,dphd & ! grid increment, delta phi, degrees -,pt & ! Pressure at top of domain (Pa) -,sbd & ! degrees from center of domain to southern boundary -,smag2 & ! Smagorinsky coefficient for 2nd order diffusion -,tlm0d & -,tph0d & -,wbd & ! degrees from center of domain to western boundary -,wcor - -real(kind=kfpt),intent(out) :: & - ddmpv & -,dyh & -,dyv & -,ef4t & -,glat_sw & ! geographic latitude (radians) of domain's SW corner -,glon_sw & ! geographic longitude (radians) of domain's SW corner (positive east) -,rdyh & -,rdyv & -,tboco - -real(kind=kfpt),dimension(jds:jde),intent(out) :: & - curv & -,dare & -,ddmpu & -,ddv & -,dxh & -,dxv & -,fad & -,fah & -,fcp & -,fdiv & -,rare & -,rddv & -,rdxh & -,rdxv & -,wpdar - -real(kind=kfpt),dimension(ims:ime,jms:jme),intent(out) :: & - f & -,glat & -,glon & -,vlat & -,vlon & -,hdacx & -,hdacy & -,hdacvx & -,hdacvy - -logical(kind=klog),intent(in) :: & - global ! global forecast if true - -logical(kind=klog),intent(out) :: & - adv_standard & ! is task in standard advec region? -,adv_upstream & ! is task in upstream advec region? -,e_bdy & ! is task on domain's eastern boundary? -,n_bdy & ! is task on domain's northern boundary? -,s_bdy & ! is task on domain's southern boundary? -,w_bdy ! is task on domain's western boundary? -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- - if(global) then -!----------------------------------------------------------------------- -!---global branch------------------------------------------------------- -!----------------------------------------------------------------------- -! - lnsbc=lnsh - bofac=0. -! - lnsad=0 -!----------------------------------------------------------------------- - else -!----------------------------------------------------------------------- -!---regional branch----------------------------------------------------- -!----------------------------------------------------------------------- -! - lnsbc=lnsh - bofac=4. -! - lnsad=lnsh+2 -!----------------------------------------------------------------------- - endif -!----------------------------------------------------------------------- - adv_upstream=.false. -!!! if(jtsjde-1-lnsad.or. & -!!! itside-1-lnsad)then - if(jts=jde-1-lnsad.or. & - its=ide-1-lnsad)then - adv_upstream=.true. - endif -! - adv_standard=.false. - if(jte>=jds+1+lnsad.and.jts<=jde-1-lnsad.and. & - ite>=ids+1+lnsad.and.its<=ide-1-lnsad)then - adv_standard=.true. - endif -!----------------------------------------------------------------------- - if(.not.global.and.my_domain_id==1)then - ihrbc=0 - write(infile,'(a,i4.4)')'boco.',ihrbc - nbc=18 - open(unit=nbc,file=infile,status='old',form='unformatted') - read (nbc) runbc,idatbc,ihrstbc,tboco -! write(0,*) 'runbc: ', runbc -! write(0,*) 'idatbc: ', idatbc -! write(0,*) 'ihrstbc: ', ihrstbc -! write(0,*) 'tboco: ', tboco - rewind nbc - close(unit=nbc) - if(mype==0)then - write(0,*)'*** Read tboco in CONSTS from ',infile - endif - nboco=nint(tboco/dt) - endif -! -!----------------------------------------------------------------------- -!---derived vertical grid constants------------------------------------- -!----------------------------------------------------------------------- - ef4t=0.5*dt/cp -! -!----------------------------------------------------------------------- -!-------------grid related arrays--------------------------------------- -!----------------------------------------------------------------------- -! - call grid_consts(global & - ,dt,smag2,codamp,wcor & - ,tph0d,tlm0d & - ,sbd,wbd & - ,dphd,dlmd & - ,dxh,rdxh & - ,dxv,rdxv & - ,dyh,rdyh & - ,dyv,rdyv & - ,ddv,rddv & - ,ddmpu,ddmpv & - ,wpdar & - ,fcp,fdiv & - ,curv,f & - ,fad,fah & - ,dare,rare & - ,glat,glon & - ,glat_sw,glon_sw & - ,vlat,vlon & - ,hdacx,hdacy & - ,hdacvx,hdacvy & - ,e_bdy,n_bdy,s_bdy,w_bdy & - ,its,ite,jts,jte & - ,ims,ime,jms,jme & - ,ids,ide,jds,jde ) -! -!----------------------------------------------------------------------- -!-------------look-up tables-------------------------------------------- -!----------------------------------------------------------------------- -! - call exptbl -! -!----------------------------------------------------------------------- - pl=max(pt,1000.) - call tablep - call tablet -!----------------------------------------------------------------------- - call psitbl -!----------------------------------------------------------------------- -! - end subroutine consts -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - subroutine grid_consts & - ( global & - ,dt,smag2,codamp,wcor & - ,tph0d,tlm0d & - ,sbd,wbd & - ,dphd,dlmd & - ,dxh,rdxh & - ,dxv,rdxv & - ,dyh,rdyh & - ,dyv,rdyv & - ,ddv,rddv & - ,ddmpu,ddmpv & - ,wpdar & - ,fcp,fdiv & - ,curv,f & - ,fad,fah & - ,dare,rare & - ,glat,glon & - ,glat_sw,glon_sw & - ,vlat,vlon & - ,hdacx,hdacy & - ,hdacvx,hdacvy & - ,e_bdy,n_bdy,s_bdy,w_bdy & - ,its,ite,jts,jte & - ,ims,ime,jms,jme & - ,ids,ide,jds,jde ) -! -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -! - implicit none -! -!----------------------------------------------------------------------- -integer(kind=kint),intent(in) :: & - its & ! starting integration index in i -,ite & ! ending integration index in i -,ims & ! starting memory index in i -,ime & ! ending memory index in i -,ids & ! starting domain index in i -,ide & ! ending domain index in i -,jts & ! starting integration index in j -,jte & ! ending integration index in j -,jms & ! starting memory index in j -,jme & ! ending memory index in j -,jds & ! starting domain index in j -,jde ! ending domain index in j - -real(kind=kfpt),intent(in) :: & - codamp & ! divergence damping coefficient -,dt & ! fundamental dynamics timestep (sec) -,sbd & ! degrees from center of domain to southern boundary -,smag2 & ! Smagorinsky coefficient for 2nd order diffusion -,tlm0d & -,tph0d & -,wbd & ! degrees from center of domain to western boundary -,dlmd & ! grid increment, delta lambda, degrees -,dphd & ! grid increment, delta phi, degrees -,wcor - -real(kind=kfpt),intent(out) :: & - ddmpv & -,dyh & -,dyv & -,glat_sw & ! geographic latitude (radians) of domain's SW corner -,glon_sw & ! geographic longitude (radians) of domain's SW corner (positive east) -,rdyh & -,rdyv - -real(kind=kfpt),dimension(jds:jde),intent(out) :: & - curv & -,dare & -,ddmpu & -,ddv & -,dxh & -,dxv & -,fad & -,fah & -,fcp & -,fdiv & -,rare & -,rddv & -,rdxh & -,rdxv & -,wpdar - -real(kind=kfpt),dimension(ims:ime,jms:jme),intent(out) :: & - f & -,glat & -,glon & -,vlat & -,vlon & -,hdacx & -,hdacy & -,hdacvx & -,hdacvy - -logical(kind=klog),intent(in) :: & - global ! global forecast if true - -logical(kind=klog),intent(inout) :: & - e_bdy & ! is task on domain's eastern boundary? -,n_bdy & ! is task on domain's northern boundary? -,s_bdy & ! is task on domain's southern boundary? -,w_bdy ! is task on domain's western boundary? - -! -!----------------------------------------------------------------------- -!--local variables------------------------------------------------------ -!----------------------------------------------------------------------- -! - -integer(kind=kint):: & - i & ! index in x direction -,i_hi & ! max i loop limit (cannot be > ide) -,i_lo & ! min i loop limit (cannot be < ids) -,j & ! index in y direction -,j_hi & ! max j loop limit (cannot be > jde) -,j_lo ! min j loop limit (cannot be < jds) - -real(kind=kfpt),save :: & - eps=1.e-5 - -real(kind=kfpt):: & - acdt & ! diffusion coefficient parameter -,alm & ! lambda -,anum & ! numerator -,aph & ! phi -,arg & ! -,ave & ! average -,cddamp & ! divergence damping factor -,coac & ! nonlinear diffusion coefficient -,ctlm & ! temporary -,ctph & ! temporary -,ctph0 & ! cos(tph0) -,denom & ! denominator -,dlm & ! grid size, delta lambda, radians -,dph & ! grid size, delta phi, degrees -,fpole & ! factor to modify polar area -,rdlm & ! 1 / delta lambda -,rdph & ! 1 / delta phi -,relm & ! temporary -,sb & ! radians from center to southern boundary -,sph & ! temporary -,stlm & ! temporary -,stph & ! temporary -,stph0 & ! sin(tph0) -,tlm & ! rotated lambda -,tlm_base & ! temporary -,tph & ! rotated phi -,tph_base & ! temporary -,tpv & ! rotated phi, v points -,tph0 & ! radians grid rotated in phi direction -,wb ! radians from center to western boundary - -real(kind=kfpt),dimension(jds:jde):: & - hdacxj & -,hdacyj & -,hdacvxj & -,hdacvyj - -!----------------------------------------------------------------------- -!*** Because subdomains that lie along the global domain boundary -!*** may have haloes that extend beyond the global limits, create -!*** limits here that keep loops from reaching beyond those -!*** global limits. -!----------------------------------------------------------------------- -! - i_lo=max(ims,ids) - i_hi=min(ime,ide) - j_lo=max(jms,jds) - j_hi=min(jme,jde) -! -!----------------------------------------------------------------------- -!---to be read from a namelist in the future---------------------------- -!----------------------------------------------------------------------- -! - coac=smag2*smag2 !second order -! -!----------------------------------------------------------------------- -!---derived physical constants------------------------------------------ -!----------------------------------------------------------------------- -! - acdt=coac*dt - cddamp=codamp*dt -! -!----------------------------------------------------------------------- -!*** Each task identifies whether or not it is adjacent to a boundary -!*** of the full domain. -!----------------------------------------------------------------------- -! - w_bdy=(its==ids) ! This task is on the western boundary - e_bdy=(ite==ide) ! This task is on the eastern boundary - s_bdy=(jts==jds) ! This task is on the southern boundary - n_bdy=(jte==jde) ! This task is on the northern boundary -! -!----------------------------------------------------------------------- -!--------------derived geometrical constants---------------------------- -!----------------------------------------------------------------------- -! - tph0=tph0d*dtr - wb=wbd*dtr - sb=sbd*dtr - dlm=dlmd*dtr - dph=dphd*dtr - rdlm=1./dlm - rdph=1./dph -! - stph0=sin(tph0) - ctph0=cos(tph0) -!----------------------------------------------------------------------- -!---derived horizontal grid constants----------------------------------- -!----------------------------------------------------------------------- - dyh=a*dph - dyv=a*dph - rdyh=1./dyh - rdyv=1./dyv -!----------------------------------------------------------------------- - do j=jds,jde - dxh(j)=0. - rdxh(j)=0. - dare(j)=0. - rare(j)=0. - wpdar(j)=0. - fah(j)=0. - fcp(j)=0. - fdiv(j)=0. - dxv(j)=0. - rdxv(j)=0. - curv(j)=0. - fad(j)=0. - ddmpu(j)=0. - hdacxj(j)=0. - hdacyj(j)=0. - hdacvxj(j)=0. - hdacvyj(j)=0. - enddo -!----------------------------------------------------------------------- -! - global_regional_setup: if(global) then -! -!----------------------------------------------------------------------- -!---global branch------------------------------------------------------- -!----------------------------------------------------------------------- - tph=sb-dph - fpole=4.0 -!----------------------------------------------------------------------- -!----south pole--------------------------------------------------------- -!----------------------------------------------------------------------- - tph=tph+dph - tpv=tph+dph*0.5 - dxh(jds+1)=0. - dxv(jds+1)=a*dlm*cos(tpv) - ddmpv=cddamp*dyv/(2.*dyv) -! - rdxh(jds+1)=0. - rdxv(jds+1)=1./dxv(jds+1) - dare(jds+1)=dxv(jds+1)*dyv*0.5*fpole !for ghost area - rare(jds+1)=1./dare(jds+1) - wpdar(jds+1)=-wcor*(dyh)**2 & - /(dt*dxv(jds+1)*dyv*0.5*fpole)/100000.00 - curv(jds+1)=tan(tpv)/a - fad(jds+1)=-dt/(3.*dxv(jds+1)*dyv*2.*2.) - fah(jds+1)=-dt/(3.*dxv(jds+1)*dyv*0.5*fpole) - fcp(jds+1)= dt/(3.*dxv(jds+1)*dyv*0.5*cp*fpole) - fdiv(jds+1)=2./(3.*dxv(jds+1)*dyv*0.5*fpole) -! - hdacxj(jds+1)=0. - hdacyj(jds+1)=acdt*dyh**2 & - /(4.*dxv(jds+1)*dyv*0.5*fpole) - hdacvxj(jds+1)=acdt*dyv**2 & - /(4.*dxv(jds+1)*dyv) - hdacvyj(jds+1)=acdt*dyv**2 & - /(4.*dxv(jds+1)*dyv) -! -! ddmpu(jds+1)=cddamp*dxv(jds+1)/(2.*dxv(jds+1)) - ddmpu(jds+1)=cddamp*dyv/(2.*dxv(jds+1)) -!----------------------------------------------------------------------- -!-------------between the poles----------------------------------------- -!----------------------------------------------------------------------- - do j=jds+2,jde-2 - tph=sb+(j-jds-1)*dph - tpv=tph+dph*0.5 - dxh(j)=a*dlm*cos(tph) - dxv(j)=a*dlm*cos(tpv) - rdxh(j)=1./dxh(j) - rdxv(j)=1./dxv(j) - dare(j)=dxh(j)*dyh - rare(j)=1./dare(j) - wpdar(j)=-wcor*(dyh)**2 & - /(dt*dxh(j)*dyh)/100000.00 - curv(j)=tan(tpv)/a - fad(j)=-dt/(3.*dxv(j)*dyv*2.*2.) - fah(j)=-dt/(3.*dxh(j)*dyh) - fcp(j)= dt/(3.*dxh(j)*dyh*cp) - fdiv(j)=2./(3.*dxh(j)*dyh) -! - hdacxj(j)= acdt*dyh*max(dxh(j),dyh)/(4.*dxh(j)*dyh) - hdacyj(j)= acdt*dyh*max(dxh(j),dyh)/(4.*dxh(j)*dyh) - hdacvxj(j)=acdt*dyv*max(dxv(j),dyv)/(4.*dxv(j)*dyv) - hdacvyj(j)=acdt*dyv*max(dxv(j),dyv)/(4.*dxv(j)*dyv) -! -! ddmpu(j)=cddamp*dxv(j)/(2.*dxv(j)) - ddmpu(j)=cddamp*dyv/(2.*dxv(j)) - enddo -!----------------------------------------------------------------------- -!-------------ghost line beyond the south pole---------------------------- -!----------------------------------------------------------------------- - dxh(jds)=dxh(jds+2) - dxv(jds)=dxv(jds+1) - rdxh(jds)=rdxh(jds+2) - rdxv(jds)=rdxv(jds+1) - dare(jds)=dare(jds+2) - rare(jds)=rare(jds+2) - wpdar(jds)=wpdar(jds+2) - curv(jds)=curv(jds+1) - fad(jds)=fad(jds+1) - fah(jds)=fah(jds+2) - fcp(jds)=fcp(jds+2) - fdiv(jds)=fdiv(jds+2) - hdacxj(jds)=hdacxj(jds+2) - hdacyj(jds)=hdacyj(jds+2) - hdacvxj(jds)=hdacvxj(jds+1) - hdacvyj(jds)=hdacvyj(jds+1) - ddmpu(jds)=ddmpu(jds+1) -!----------------------------------------------------------------------- -!-------------north pole------------------------------------------------ -!----------------------------------------------------------------------- - tph=tph+dph - tpv=tph+dph*0.5 - dxh(jde-1)=0. - rdxh(jde-1)=0. - dare(jde-1)=dxv(jde-2)*dyv*0.5*fpole - rare(jde-1)=1./dare(jde-1) - wpdar(jde-1)=-wcor*(dyh)**2 & - /(dt*dxv(jde-2)*dyv*0.5*fpole)/100000.00 - fah(jde-1)=-dt/(3.*dxv(jde-2)*dyv*0.5*fpole) - fcp(jde-1)= dt/(3.*dxv(jde-2)*dyv*0.5*fpole*cp) - fdiv(jde-1)=2./(3.*dxv(jde-2)*dyv*0.5*fpole) - hdacxj(jde-1)=0. - hdacyj(jde-1)=acdt*dyh**2 & - /(4.*dxv(jde-2)*dyv*0.5*fpole) -!----------------------------------------------------------------------- -!-------------ghost line beyond north pole------------------------------ -!----------------------------------------------------------------------- - dxh(jde)=dxh(jde-2) - dxv(jde-1)=dxv(jde-2) - dxv(jde)=dxv(jde-2) - rdxh(jde)=rdxh(jde-2) - rdxv(jde-1)=rdxv(jde-2) - rdxv(jde)=rdxv(jde-2) - dare(jde)=dare(jde-2) - rare(jde)=rare(jde-2) - wpdar(jde)=wpdar(jde-2) - curv(jde-1)=curv(jde-2) - curv(jde)=curv(jde-2) - fad(jde-1)=fad(jde-2) - fad(jde)=fad(jde-2) - fah(jde)=fah(jde-2) - fcp(jde)=fcp(jde-2) - fdiv(jde)=fdiv(jde-2) - hdacxj(jde)=hdacxj(jde-2) - hdacyj(jde)=hdacyj(jde-2) - hdacvxj(jde-1)=hdacvxj(jde-2) - hdacvyj(jde-1)=hdacvyj(jde-2) - hdacvxj(jde)=hdacvxj(jde-2) - hdacvyj(jde)=hdacvyj(jde-2) - ddmpu(jde-1)=ddmpu(jde-2) - ddmpu(jde)=ddmpu(jde-2) -!----------------------------------------------------------------------- -!-------------averaging over height latitudes for accuracy-------------- -!----------------------------------------------------------------------- - do j=jds,jde/2 - ave=(dxh(j)+dxh(jde+1-j))*0.5 - dxh(j)=ave - dxh(jde+1-j)=ave - ave=(rdxh(j)+rdxh(jde+1-j))*0.5 - rdxh(j)=ave - rdxh(jde+1-j)=ave - ave=(dare(j)+dare(jde+1-j))*0.5 - dare(j)=ave - dare(jde+1-j)=ave - ave=(rare(j)+rare(jde+1-j))*0.5 - rare(j)=ave - rare(jde+1-j)=ave - ave=(wpdar(j)+wpdar(jde+1-j))*0.5 - wpdar(j)=ave - wpdar(jde+1-j)=ave - ave=(fah(j)+fah(jde+1-j))*0.5 - fah(j)=ave - fah(jde+1-j)=ave - ave=(fcp(j)+fcp(jde+1-j))*0.5 - fcp(j)=ave - fcp(jde+1-j)=ave - ave=(fdiv(j)+fdiv(jde+1-j))*0.5 - fdiv(j)=ave - fdiv(jde+1-j)=ave - ave=(hdacxj(j)+hdacxj(jde+1-j))*0.5 - hdacxj(j)=ave - hdacxj(jde+1-j)=ave - ave=(hdacyj(j)+hdacyj(jde+1-j))*0.5 - hdacyj(j)=ave - hdacyj(jde+1-j)=ave - enddo -!----------------------------------------------------------------------- -!-------------averaging over wind latitudes for accuracy--------------- -!----------------------------------------------------------------------- - do j=jds,(jde-1)/2 - ave=(dxv(j)+dxv(jde-j))*0.5 - dxv(j)=ave - dxv(jde-j)=ave - ave=(rdxv(j)+rdxv(jde-j))*0.5 - rdxv(j)=ave - rdxv(jde-j)=ave - ave=(fad(j)+fad(jde-j))*0.5 - fad(j)=ave - fad(jde-j)=ave - ave=(hdacvxj(j)+hdacvxj(jde-j))*0.5 - hdacvxj(j)=ave - hdacvxj(jde-j)=ave - ave=(hdacvyj(j)+hdacvyj(jde-j))*0.5 - hdacvyj(j)=ave - hdacvyj(jde-j)=ave - ave=(ddmpu(j)+ddmpu(jde-j))*0.5 - ddmpu(j)=ave - ddmpu(jde-j)=ave - enddo -!----------------------------------------------------------------------- -!-------------diagonal distances at v points---------------------------- -!----------------------------------------------------------------------- - if(s_bdy)then - ddv(jds+1)=dyv - ddv(jds)=ddv(jds+1) - rddv(jds+1)=1./ddv(jds+1) - rddv(jds)=rddv(jds+1) - endif -! - do j=max(jms,jds+2),min(jme,jde-3) - ddv(j)=sqrt(dxv(j)**2+dyv**2) - rddv(j)=1./ddv(j) - enddo -! - if(n_bdy)then - ddv(jde-2)=dyv - ddv(jde-1)=ddv(jde-2) - rddv(jde-2)=1./ddv(jde-2) - rddv(jde-1)=rddv(jde-2) - endif -!----------------------------------------------------------------------- -!-------------defining the diffusion coefficient inside the domain------ -!----------------------------------------------------------------------- -! do j=jms,jme -! do i=ims,ime - do j=j_lo,j_hi - do i=i_lo,i_hi - hdacx(i,j)=hdacxj(j) - hdacy(i,j)=hdacyj(j) - hdacvx(i,j)=hdacvxj(j) - hdacvy(i,j)=hdacvyj(j) - enddo - enddo -!----------------------------------------------------------------------- -!-------------coriolis parameter in tll system-------------------------- -!----------------------------------------------------------------------- - tph_base=sb-dph-dph*.5 -! do j=jms,jme - do j=j_lo,j_hi - tph=tph_base+(j-jds+1)*dph - stph=sin(tph) - ctph=cos(tph) -! - tlm_base=wb-dlm-dlm*0.5 -! do i=ims,ime - do i=i_lo,i_hi - tlm=tlm_base+(i-ids+1)*dlm - f(i,j)=twom*(ctph0*stph+stph0*ctph*cos(tlm)) - enddo - enddo -!----------------------------------------------------------------------- -!--------------latitudes and longitudes of h points in radians---------- -!----------------------------------------------------------------------- -! tph_base=sb-dph-dph -! do j=j_lo,j_hi -! tlm_base=wb-dlm-dlm -! tph=tph_base+(j-jds+1)*dph -! stph=sin(tph) -! ctph=cos(tph) -! do i=i_lo,i_hi -! tlm=tlm_base+(i-ids+1)*dlm -! stlm=sin(tlm) -! ctlm=cos(tlm) -! sph=ctph0*stph+stph0*ctph*ctlm -! aph=asin(sph) -! glat(i,j)=aph -! anum=ctph*stlm -! denom=(ctlm*ctph-stph0*sph)/ctph0 -! relm=atan2(anum,denom) -! alm=relm+tlm0d*dtr -! if(alm> pi) alm=alm-pi-pi -! if(alm< -pi) alm=alm+pi+pi -! glon(i,j)=alm -! enddo -! enddo - tph_base=sb-dph-dph - do j=j_lo,j_hi - tlm_base=wb-dlm-dlm - aph=tph_base+(j-jds+1)*dph - do i=i_lo,i_hi - alm=tlm_base+(i-ids+1)*dlm - if(alm> pi)then - if(i<=ite-2)then - alm=alm-pi-pi - else - alm=pi+(i-ite+1)*dlm - endif - endif - if(alm<-pi)then - if(i>=its+2)then - alm=alm+pi+pi - else - alm=-pi+(i-its-1)*dlm - endif - endif - glat(i,j)=aph - glon(i,j)=alm - enddo - enddo -! -!*** Repeat the preceding loop for the offset V points -! - tph_base=sb-dph-0.5*dph - do j=j_lo,j_hi - tlm_base=wb-dlm-0.5*dlm - aph=tph_base+(j-jds+1)*dph - do i=i_lo,i_hi - alm=tlm_base+(i-ids+1)*dlm - if(alm> pi) alm=alm-pi-pi - if(alm<-pi) alm=alm+pi+pi - vlat(i,j)=aph - vlon(i,j)=alm - enddo - enddo -! -!----------------------------------------------------------------------- -!*** Save the geographic lat/lon (radians) of this domain's SW corner. -!----------------------------------------------------------------------- -! - arg=sin(sb)*ctph0+cos(sb)*stph0*cos(wb) - arg=min(arg,1.) - arg=max(arg,-1.) - glat_sw=asin(arg) -! - arg=(cos(sb)*cos(wb))/(cos(glat_sw)*ctph0) & - -tan(glat_sw)*tan(tph0d*dtr) - arg=min(arg,1.) - arg=max(arg,-1.) - glon_sw=tlm0d*dtr+sign(1.,wb)*acos(arg) -! -!----------------------------------------------------------------------- - else !regional -!----------------------------------------------------------------------- -! -!---regional branch----------------------------------------------------- -! -!----------------------------------------------------------------------- -!-------------between the poles----------------------------------------- -!----------------------------------------------------------------------- -! - ddmpv=cddamp*dyv/(2.*dyv) -! - do j=jds,jde - tph=sb+(j-jds)*dph - tpv=tph+dph*0.5 - dxh(j)=a*dlm*cos(tph) - dxv(j)=a*dlm*cos(tpv) - rdxh(j)=1./dxh(j) - rdxv(j)=1./dxv(j) - dare(j)=dxh(j)*dyh - rare(j)=1./dare(j) - wpdar(j)=-wcor*(dyh)**2 & - /(dt*dxh(j)*dyh)/100000.00 - curv(j)=tan(tpv)/a - fad(j)=-dt/(3.*dxv(j)*dyv*2.*2.) - fah(j)=-dt/(3.*dxh(j)*dyh) - fcp(j)= dt/(3.*dxh(j)*dyh*cp) - fdiv(j)=2./(3.*dxh(j)*dyh) -! - hdacxj(j)= acdt*dyh*max(dxh(j),dyh)/(4.*dxh(j)*dyh) - hdacyj(j)= acdt*dyh*max(dxh(j),dyh)/(4.*dxh(j)*dyh) - hdacvxj(j)=acdt*dyv*max(dxv(j),dyv)/(4.*dxv(j)*dyv) - hdacvyj(j)=acdt*dyv*max(dxv(j),dyv)/(4.*dxv(j)*dyv) -! -! ddmpu(j)=cddamp*dxv(j)/(2.*dxv(j)) - ddmpu(j)=cddamp*dyv/(2.*dxv(j)) - enddo -!----------------------------------------------------------------------- -!-------------diagonal distances at v points---------------------------- -!----------------------------------------------------------------------- - do j=jds,jde - ddv(j)=sqrt(dxv(j)**2+dyv**2) - rddv(j)=1./ddv(j) - enddo -!----------------------------------------------------------------------- -!---defining the diffusion coefficient inside the domain---------------- -!----------------------------------------------------------------------- -! do j=jms,jme -! do i=ims,ime - do j=j_lo,j_hi - do i=i_lo,i_hi - hdacx(i,j)=hdacxj(j) - hdacy(i,j)=hdacyj(j) - hdacvx(i,j)=hdacvxj(j) - hdacvy(i,j)=hdacvyj(j) - enddo - enddo -!----------------------------------------------------------------------- -!---enhancing diffusion along boundaries-------------------------------- -!----------------------------------------------------------------------- - if(lnsbc>=2)then -! - if(s_bdy)then - do j=jts+1,jts-1+lnsbc - do i=max(its,ids+1),min(ite,ide-1) - hdacx(i,j)=hdacxj(j)*bofac - hdacy(i,j)=hdacyj(j)*bofac - enddo - enddo - endif -! - if(n_bdy)then - do j=jte+1-lnsbc,jte-1 - do i=max(its,ids+1),min(ite,ide-1) - hdacx(i,j)=hdacxj(j)*bofac - hdacy(i,j)=hdacyj(j)*bofac - enddo - enddo - endif -! - endif -! - if(w_bdy)then - do j=max(jts,jds+lnsbc),min(jte,jde-lnsbc) - do i=its+1,its-1+lnsbc - hdacx(i,j)=hdacxj(j)*bofac - hdacy(i,j)=hdacyj(j)*bofac - enddo - enddo - endif -! - if(e_bdy)then - do j=max(jts,jds+lnsbc),min(jte,jde-lnsbc) - do i=ite+1-lnsbc,ite-1 - hdacx(i,j)=hdacxj(j)*bofac - hdacy(i,j)=hdacyj(j)*bofac - enddo - enddo - endif -! -!----------------------------------------------------------------------- - if(s_bdy)then - do j=jts+1,jts-1+lnsbc - do i=max(its,ids+1),min(ite,ide-2) - hdacvx(i,j)=hdacvxj(j)*bofac - hdacvy(i,j)=hdacvyj(j)*bofac - enddo - enddo - endif -! - if(n_bdy)then - do j=jte-lnsbc,jte-2 - do i=max(its,ids+1),min(ite,ide-2) - hdacvx(i,j)=hdacvxj(j)*bofac - hdacvy(i,j)=hdacvyj(j)*bofac - enddo - enddo - endif -! - if(w_bdy)then - do j=max(jts,jds+lnsbc),min(jte,jde-1-lnsbc) - do i=its+1,its-1+lnsbc - hdacvx(i,j)=hdacvxj(j)*bofac - hdacvy(i,j)=hdacvyj(j)*bofac - enddo - enddo - endif -! - if(e_bdy)then - do j=max(jts,jds+lnsbc),min(jte,jde-1-lnsbc) - do i=ite-lnsbc,ite-2 - hdacvx(i,j)=hdacvxj(j)*bofac - hdacvy(i,j)=hdacvyj(j)*bofac - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!-------------coriolis parameter in tll system-------------------------- -!----------------------------------------------------------------------- - - tph_base=sb-dph*.5 -! - do j=jts,jte - tph=tph_base+(j-jds+1)*dph - stph=sin(tph) - ctph=cos(tph) -! - tlm_base=wb-dlm*0.5 - do i=its,ite - tlm=tlm_base+(i-ids+1)*dlm - f(i,j)=twom*(ctph0*stph+stph0*ctph*cos(tlm)) - enddo - enddo -!----------------------------------------------------------------------- -!--------------latitudes and longitudes of h points in radians---------- -!----------------------------------------------------------------------- - tph_base=sb-dph -! write(0,*) 'sb,dph: ', sb, dph -! write(0,*) 'wb,dlm: ', wb, dlm -! - do j=j_lo,j_hi - tph=tph_base+(j-jds+1)*dph - stph=sin(tph) - ctph=cos(tph) -! - tlm_base=wb-dlm - do i=i_lo,i_hi - tlm=tlm_base+(i-ids+1)*dlm - stlm=sin(tlm) - ctlm=cos(tlm) - sph=ctph0*stph+stph0*ctph*ctlm - aph=asin(sph) - glat(i,j)=aph - anum=ctph*stlm - denom=(ctlm*ctph-stph0*sph)/ctph0 - relm=atan2(anum,denom) - alm=relm+tlm0d*dtr - if(alm> pi) alm=alm-pi-pi - if(alm< -pi) alm=alm+pi+pi - glon(i,j)=alm - enddo - enddo -! -!*** Repeat preceding loop for V lat/lon offset -! - tph_base=sb-0.5*dph -! - do j=jts,jte - tph=tph_base+(j-jds+1)*dph - stph=sin(tph) - ctph=cos(tph) -! - tlm_base=wb-0.5*dlm - do i=its,ite - tlm=tlm_base+(i-ids+1)*dlm - stlm=sin(tlm) - ctlm=cos(tlm) - sph=ctph0*stph+stph0*ctph*ctlm - aph=asin(sph) - vlat(i,j)=aph - anum=ctph*stlm - denom=(ctlm*ctph-stph0*sph)/ctph0 - relm=atan2(anum,denom) - alm=relm+tlm0d*dtr - if(alm> pi) alm=alm-pi-pi - if(alm< -pi) alm=alm+pi+pi - vlon(i,j)=alm - enddo - enddo -! -!----------------------------------------------------------------------- -!*** Save the geographic lat/lon (radians) of this domain's SW corner. -!----------------------------------------------------------------------- -! - arg=sin(sb)*ctph0+cos(sb)*stph0*cos(wb) - arg=min(arg,1.) - arg=max(arg,-1.) - glat_sw=asin(arg) -! - arg=(cos(sb)*cos(wb))/(cos(glat_sw)*ctph0) & - -tan(glat_sw)*tan(tph0d*dtr) - arg=min(arg,1.) - arg=max(arg,-1.) - glon_sw=tlm0d*dtr+sign(1.,wb)*acos(arg) -! -!----------------------------------------------------------------------- -! - endif global_regional_setup - - end subroutine grid_consts - -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- - subroutine boundary_init & - (its,ite,jts,jte,lm & - ,ims,ime,jms,jme & - ,ids,ide,jds,jde & - ,lnsh,lnsv & - ,nvars_2d_h,nvars_3d_h,nvars_4d_h & - ,nvars_2d_v,nvars_3d_v & - ,bnd_vars_h & - ,bnd_vars_v & - ) -! -!----------------------------------------------------------------------- -!*** Initialize boundary variable arrays for nested domains. -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- - -!------------------------ -!*** Argument variables -!------------------------ - -integer(kind=kint),intent(in) :: & - ids & -,ide & -,ims & -,ime & -,its & -,ite & -,jds & -,jde & -,jms & -,jme & -,jts & -,jte & -,lm & -,lnsh & -,lnsv - -integer(kind=kint),intent(in) :: & - nvars_2d_h & -,nvars_3d_h & -,nvars_4d_h & -,nvars_2d_v & -,nvars_3d_v - -type(bc_h_all),intent(inout) :: bnd_vars_h - -type(bc_v_all),intent(inout) :: bnd_vars_v - -!--------------------- -!*** Local variables -!--------------------- - -integer(kind=kint) :: & - i & -,j & -,k & -,l & -,l1 & -,l2 & -,n & -,nv - -real(kind=kfpt),dimension(:,:),pointer :: var2d -real(kind=kfpt),dimension(:,:,:),pointer :: bnd2d,var3d -real(kind=kfpt),dimension(:,:,:,:),pointer :: bnd3d,var4d -real(kind=kfpt),dimension(:,:,:,:,:),pointer :: bnd4d - -logical(kind=klog) :: & - e_bdy & -,n_bdy & -,s_bdy & -,w_bdy - -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - w_bdy=(its==ids) ! This task is on the western boundary - e_bdy=(ite==ide) ! This task is on the eastern boundary - s_bdy=(jts==jds) ! This task is on the southern boundary - n_bdy=(jte==jde) ! This task is on the northern boundary -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** South -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -! - if(s_bdy)then -! -!----------------------------------------------------------------------- -! -!------------------------ -!*** 2-d h variables -!------------------------ -! - if(nvars_2d_h>0)then -! - do nv=1,nvars_2d_h -! - bnd2d=>bnd_vars_h%var_2d(nv)%south - var2d=>bnd_vars_h%var_2d(nv)%full_var -! - n=0 - do j=1,lnsh - n=n+1 - do i=ims,ime - bnd2d(i,j,1)=var2d(i,jds-1+n) - enddo - enddo -! - enddo -! - endif -! -!------------------------ -!*** 3-d h variables -!------------------------ -! - if(nvars_3d_h>0)then -! - do nv=1,nvars_3d_h -! - bnd3d=>bnd_vars_h%var_3d(nv)%south - var3d=>bnd_vars_h%var_3d(nv)%full_var -! - do k=1,lm - n=0 - do j=1,lnsh - n=n+1 - do i=ims,ime - bnd3d(i,j,k,1)=var3d(i,jds-1+n,k) - enddo - enddo - enddo -! - enddo -! - endif -! -!------------------------ -!*** 4-d h variables -!------------------------ -! - if(nvars_4d_h>0)then -! - do nv=1,nvars_4d_h -! - bnd4d=>bnd_vars_h%var_4d(nv)%south - var4d=>bnd_vars_h%var_4d(nv)%full_var -! - l1=lbound(bnd_vars_h%var_4d(nv)%full_var,4) - l2=ubound(bnd_vars_h%var_4d(nv)%full_var,4) - do l=l1,l2 - do k=1,lm - n=0 - do j=1,lnsh - n=n+1 - do i=ims,ime - bnd4d(i,j,k,l,1)=var4d(i,jds-1+n,k,l) - enddo - enddo - enddo - enddo -! - enddo -! - endif -! -!------------------------ -!*** 2-d v variables -!------------------------ -! - if(nvars_2d_v>0)then -! - do nv=1,nvars_2d_v -! - bnd2d=>bnd_vars_v%var_2d(nv)%south - var2d=>bnd_vars_v%var_2d(nv)%full_var -! - n=0 - do j=1,lnsv - n=n+1 - do i=ims,ime - bnd2d(i,j,1)=var2d(i,jds-1+n) - enddo - enddo -! - enddo -! - endif -! -!------------------------ -!*** 3-d v variables -!------------------------ -! - if(nvars_3d_v>0)then -! - do nv=1,nvars_3d_v -! - bnd3d=>bnd_vars_v%var_3d(nv)%south - var3d=>bnd_vars_v%var_3d(nv)%full_var -! - do k=1,lm - n=0 - do j=1,lnsv - n=n+1 - do i=ims,ime - bnd3d(i,j,k,1)=var3d(i,jds-1+n,k) - enddo - enddo - enddo -! - enddo -! - endif -! - endif -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** North -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - if(n_bdy)then -! -!------------------------ -!*** 2-d h variables -!------------------------ -! - if(nvars_2d_h>0)then -! - do nv=1,nvars_2d_h -! - bnd2d=>bnd_vars_h%var_2d(nv)%north - var2d=>bnd_vars_h%var_2d(nv)%full_var -! - n=0 - do j=1,lnsh - n=n+1 - do i=ims,ime - bnd2d(i,j,1)=var2d(i,jde-lnsh+n) - enddo - enddo -! - enddo -! - endif -! -!------------------------ -!*** 3-d h variables -!------------------------ -! - if(nvars_3d_h>0)then -! - do nv=1,nvars_3d_h -! - bnd3d=>bnd_vars_h%var_3d(nv)%north - var3d=>bnd_vars_h%var_3d(nv)%full_var -! - do k=1,lm - n=0 - do j=1,lnsh - n=n+1 - do i=ims,ime - bnd3d(i,j,k,1)=var3d(i,jde-lnsh+n,k) - enddo - enddo - enddo -! - enddo -! - endif -! -!------------------------ -!*** 4-d h variables -!------------------------ -! - if(nvars_4d_h>0)then -! - do nv=1,nvars_4d_h -! - bnd4d=>bnd_vars_h%var_4d(nv)%north - var4d=>bnd_vars_h%var_4d(nv)%full_var -! - l1=lbound(bnd_vars_h%var_4d(nv)%full_var,4) - l2=ubound(bnd_vars_h%var_4d(nv)%full_var,4) - do l=l1,l2 - do k=1,lm - n=0 - do j=1,lnsh - n=n+1 - do i=ims,ime - bnd4d(i,j,k,l,1)=var4d(i,jde-lnsh+n,k,l) - enddo - enddo - enddo - enddo -! - enddo -! - endif -! -!------------------------ -!*** 2-d v variables -!------------------------ -! - if(nvars_2d_v>0)then -! - do nv=1,nvars_2d_v -! - bnd2d=>bnd_vars_v%var_2d(nv)%north - var2d=>bnd_vars_v%var_2d(nv)%full_var -! - n=0 - do j=1,lnsv - n=n+1 - do i=ims,ime - bnd2d(i,j,1)=var2d(i,jde-1-lnsv+n) - enddo - enddo -! - enddo -! - endif -! -!------------------------ -!*** 3-d v variables -!------------------------ -! - if(nvars_3d_v>0)then -! - do nv=1,nvars_3d_v -! - bnd3d=>bnd_vars_v%var_3d(nv)%north - var3d=>bnd_vars_v%var_3d(nv)%full_var -! - do k=1,lm - n=0 - do j=1,lnsv - n=n+1 - do i=ims,ime - bnd3d(i,j,k,1)=var3d(i,jde-1-lnsv+n,k) - enddo - enddo - enddo -! - enddo -! - endif -! - endif -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** West -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - if(w_bdy)then -! -!------------------------ -!*** 2-d h variables -!------------------------ -! - if(nvars_2d_h>0)then -! - do nv=1,nvars_2d_h -! - bnd2d=>bnd_vars_h%var_2d(nv)%west - var2d=>bnd_vars_h%var_2d(nv)%full_var -! - do j=jms,jme - n=0 - do i=1,lnsh - n=n+1 - bnd2d(i,j,1)=var2d(ids-1+n,j) - enddo - enddo -! - enddo -! - endif -! -!------------------------ -!*** 3-d h variables -!------------------------ -! - if(nvars_3d_h>0)then -! - do nv=1,nvars_3d_h -! - bnd3d=>bnd_vars_h%var_3d(nv)%west - var3d=>bnd_vars_h%var_3d(nv)%full_var -! - do k=1,lm - do j=jms,jme - n=0 - do i=1,lnsh - n=n+1 - bnd3d(i,j,k,1)=var3d(ids-1+n,j,k) - enddo - enddo - enddo -! - enddo -! - endif -! -!------------------------ -!*** 4-d h variables -!------------------------ -! - if(nvars_4d_h>0)then -! - do nv=1,nvars_4d_h -! - bnd4d=>bnd_vars_h%var_4d(nv)%west - var4d=>bnd_vars_h%var_4d(nv)%full_var -! - l1=lbound(bnd_vars_h%var_4d(nv)%full_var,4) - l2=ubound(bnd_vars_h%var_4d(nv)%full_var,4) - do l=l1,l2 - do k=1,lm - do j=jms,jme - n=0 - do i=1,lnsh - n=n+1 - bnd4d(i,j,k,l,1)=var4d(ids-1+n,j,k,l) - enddo - enddo - enddo - enddo -! - enddo -! - endif -! -!------------------------ -!*** 2-d v variables -!------------------------ -! - if(nvars_2d_v>0)then -! - do nv=1,nvars_2d_v -! - bnd2d=>bnd_vars_v%var_2d(nv)%west - var2d=>bnd_vars_v%var_2d(nv)%full_var -! - do j=jms,jme - n=0 - do i=1,lnsv - n=n+1 - bnd2d(i,j,1)=var2d(ids-1+n,j) - enddo - enddo -! - enddo -! - endif -! -!------------------------ -!*** 3-d v variables -!------------------------ -! - if(nvars_3d_v>0)then -! - do nv=1,nvars_3d_v -! - bnd3d=>bnd_vars_v%var_3d(nv)%west - var3d=>bnd_vars_v%var_3d(nv)%full_var -! - do k=1,lm - do j=jms,jme - n=0 - do i=1,lnsv - n=n+1 - bnd3d(i,j,k,1)=var3d(ids-1+n,j,k) - enddo - enddo - enddo -! - enddo -! - endif -! - endif -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** East -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - if(e_bdy)then -! -!------------------------ -!*** 2-d h variables -!------------------------ -! - if(nvars_2d_h>0)then -! - do nv=1,nvars_2d_h -! - bnd2d=>bnd_vars_h%var_2d(nv)%east - var2d=>bnd_vars_h%var_2d(nv)%full_var -! - do j=jms,jme - n=0 - do i=1,lnsh - n=n+1 - bnd2d(i,j,1)=var2d(ide-lnsh+n,j) - enddo - enddo -! - enddo -! - endif -! -!------------------------ -!*** 3-d h variables -!------------------------ -! - if(nvars_3d_h>0)then -! - do nv=1,nvars_3d_h -! - bnd3d=>bnd_vars_h%var_3d(nv)%east - var3d=>bnd_vars_h%var_3d(nv)%full_var -! - do k=1,lm - do j=jms,jme - n=0 - do i=1,lnsh - n=n+1 - bnd3d(i,j,k,1)=var3d(ide-lnsh+n,j,k) - enddo - enddo - enddo -! - enddo -! - endif -! -!------------------------ -!*** 4-d h variables -!------------------------ -! - if(nvars_4d_h>0)then -! - do nv=1,nvars_4d_h -! - bnd4d=>bnd_vars_h%var_4d(nv)%east - var4d=>bnd_vars_h%var_4d(nv)%full_var -! - l1=lbound(bnd_vars_h%var_4d(nv)%full_var,4) - l2=ubound(bnd_vars_h%var_4d(nv)%full_var,4) - do l=l1,l2 - do k=1,lm - do j=jms,jme - n=0 - do i=1,lnsh - n=n+1 - bnd4d(i,j,k,l,1)=var4d(ids-1+n,j,k,l) - enddo - enddo - enddo - enddo -! - enddo -! - endif -! -!------------------------ -!*** 2-d v variables -!------------------------ -! - if(nvars_2d_v>0)then -! - do nv=1,nvars_2d_v -! - bnd2d=>bnd_vars_v%var_2d(nv)%east - var2d=>bnd_vars_v%var_2d(nv)%full_var -! - do j=jms,jme - n=0 - do i=1,lnsv - n=n+1 - bnd2d(i,j,1)=var2d(ide-1-lnsv+n,j) - enddo - enddo -! - enddo -! - endif -! -!------------------------ -!*** 3-d v variables -!------------------------ -! - if(nvars_3d_v>0)then -! - do nv=1,nvars_3d_v -! - bnd3d=>bnd_vars_v%var_3d(nv)%east - var3d=>bnd_vars_v%var_3d(nv)%full_var -! - do k=1,lm - do j=jms,jme - n=0 - do i=1,lnsv - n=n+1 - bnd3d(i,j,k,1)=var3d(ide-1-lnsv+n,j,k) - enddo - enddo - enddo -! - enddo -! - endif -! - endif -! -!----------------------------------------------------------------------- -! - end subroutine boundary_init -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - subroutine exptbl -! ****************************************************************** -! * * -! * exponential function table * -! * responsible person: z.janjic * -! * * -! ****************************************************************** -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -! - implicit none -! -!----------------------------------------------------------------------- -!--local variables------------------------------------------------------ -!----------------------------------------------------------------------- -integer(kind=kint):: & - k ! index - -real(kind=kfpt):: & - x & ! argument -,xrng ! argument range -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- - xmax= 30. - xmin=-30. -! - kexm2=kexm-2 - xrng=xmax-xmin -! - dex=xrng/(kexm-1) - rdex=1./dex -!--------------function definition loop--------------------------------- - x=xmin-dex - do k=1,kexm - x=x+dex - expf(k)=exp(x) - enddo -!----------------------------------------------------------------------- -! - end subroutine exptbl -! -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -! - function zjexp(x) -! ****************************************************************** -! * * -! * exponential function table * -! * responsible person: z.janjic * -! * * -! ****************************************************************** -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -! - implicit none -! -!----------------------------------------------------------------------- -real(kind=kfpt):: & - zjexp - -!----------------------------------------------------------------------- -!--local variables------------------------------------------------------ -!----------------------------------------------------------------------- -integer(kind=kint):: & - k ! index - -real(kind=kfpt):: & - ak & ! position in table -,x ! argument -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- - ak=(x-xmin)*rdex - k=int(ak) - k=max(k,0) - k=min(k,kexm2) -! - zjexp=(expf(k+2)-expf(k+1))*(ak-real(k))+expf(k+1) -!----------------------------------------------------------------------- -! - end function zjexp -! -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -! - subroutine tablep -! ****************************************************************** -! * * -! * generates the table for finding pressure from * -! * saturation specific humidity and potential temperature * -! * * -! ****************************************************************** -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -! - implicit none -! -!----------------------------------------------------------------------- -real(kind=kfpt),parameter:: & - eps=1.e-10 -!----------------------------------------------------------------------- -!--local variables------------------------------------------------------ -!----------------------------------------------------------------------- -integer(kind=kint):: & - kth & ! index -,kp ! index - -real(kind=kfpt):: & - ape & ! exner function -,dth & ! potential temperature step -,dp & ! pressure step -,dqs & ! saturation specific humidity step -,p & ! pressure -,qs0k & ! base value for saturation humidity -,sqsk & ! saturation spec. humidity range -,th ! potential temperature - -real(kind=kfpt),dimension(1:itb):: & - app & ! temporary -,aqp & ! temporary -,pnew & ! new pressures -,pold & ! old pressure -,qsnew & ! new saturation spec. humidity -,qsold & ! old saturation spec. humidity -,y2p ! temporary -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- - dth=(thh-thl)/real(jtb-1) - dp=(ph-pl)/real(itb-1) - rdth=1./dth -!----------------------------------------------------------------------- - th=thl-dth - do kth=1,jtb - th=th+dth - p=pl-dp - do kp=1,itb - p=p+dp - ape=(100000./p)**cappa - qsold(kp)=pq0/p*exp(a2*(th-a3*ape)/(th-a4*ape)) - pold(kp)=p - enddo -! - qs0k=qsold(1) - sqsk=qsold(itb)-qsold(1) - qsold(1)=0. - qsold(itb)=1. -! - do kp=2,itb-1 - qsold(kp)=(qsold(kp)-qs0k)/sqsk -!wwwwwwwwwwwwww fix due to 32 bit precision limitation wwwwwwwwwwwwwwwww - if((qsold(kp)-qsold(kp-1)).lt.eps) then - qsold(kp)=qsold(kp-1)+eps - endif -!mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm - enddo -! - qs0(kth)=qs0k - sqs(kth)=sqsk -! - qsnew(1)=0. - qsnew(itb)=1. - dqs=1./real(itb-1) - rdq=1./dqs -! - do kp=2,itb-1 - qsnew(kp)=qsnew(kp-1)+dqs - enddo -! - y2p(1)=0. - y2p(itb)=0. -! - call spline(jtb,itb,qsold,pold,y2p,itb,qsnew,pnew,app,aqp) -! - do kp=1,itb - ptbl(kp,kth)=pnew(kp) - enddo -!----------------------------------------------------------------------- - enddo -!----------------------------------------------------------------------- -! - end subroutine tablep -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - subroutine tablet -! ****************************************************************** -! * * -! * generates the table for finding temperature from * -! * pressure and equivalent potential temperature * -! * * -! ****************************************************************** -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -! - implicit none -! -!----------------------------------------------------------------------- -real(kind=kfpt),parameter:: & - eps=1.e-10 -!----------------------------------------------------------------------- -!--local variables------------------------------------------------------ -!----------------------------------------------------------------------- -integer(kind=kint):: & - kth & ! index -,kp ! index - -real(kind=kfpt):: & - ape & ! exner function -,dth & ! potential temperature step -,dp & ! pressure step -,dthe & ! equivalent pot. temperature step -,p & ! pressure -,qs & ! saturation specific humidity -,the0k & ! base value for equivalent pot. temperature -,sthek & ! equivalent pot. temperature range -,th ! potential temperature - -real(kind=kfpt),dimension(1:jtb):: & - apt & ! temporary -,aqt & ! temporary -,tnew & ! new temperature -,told & ! old temperature -,thenew & ! new equivalent potential temperature -,theold & ! old equivalent potential temperature -,y2t ! temporary -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- - dth=(thh-thl)/real(jtb-1) - dp=(ph-pl)/real(itb-1) - rdp=1./dp -!----------------------------------------------------------------------- - p=pl-dp - do kp=1,itb - p=p+dp - th=thl-dth - do kth=1,jtb - th=th+dth - ape=(100000./p)**cappa - qs=pq0/p*exp(a2*(th-a3*ape)/(th-a4*ape)) - told(kth)=th/ape - theold(kth)=th*exp(eliwv*qs/(cp*told(kth))) - enddo -! - the0k=theold(1) - sthek=theold(jtb)-theold(1) - theold(1)=0. - theold(jtb)=1. -! - do kth=2,jtb-1 - theold(kth)=(theold(kth)-the0k)/sthek -!wwwwwwwwwwwwww fix due to 32 bit precision limitation wwwwwwwwwwwwwwwww - if((theold(kth)-theold(kth-1)).lt.eps) then - theold(kth)=theold(kth-1)+eps - endif -!mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm - enddo -! - the0(kp)=the0k - sthe(kp)=sthek -! - thenew(1)=0. - thenew(jtb)=1. - dthe=1./real(jtb-1) - rdthe=1./dthe -! - do kth=2,jtb-1 - thenew(kth)=thenew(kth-1)+dthe - enddo -! - y2t(1)=0. - y2t(jtb)=0. -! - call spline(jtb,jtb,theold,told,y2t,jtb,thenew,tnew,apt,aqt) -! - do kth=1,jtb - ttbl(kth,kp)=tnew(kth) - enddo -!----------------------------------------------------------------------- - enddo -!----------------------------------------------------------------------- -! - end subroutine tablet -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - subroutine spline(jtb,nold,xold,yold,y2,nnew,xnew,ynew,p,q) -! ****************************************************************** -! * * -! * this is a one-dimensional cubic spline fitting routine * -! * programed for a small scalar machine. * -! * * -! * programer: z. janjic, yugoslav fed. hydromet. inst., beograd * -! * * -! * * -! * * -! * nold - number of given values of the function. must be ge 3. * -! * xold - locations of the points at which the values of the * -! * function are given. must be in ascending order. * -! * yold - the given values of the function at the points xold. * -! * y2 - the second derivatives at the points xold. if natural * -! * spline is fitted y2(1)=0. and y2(nold)=0. must be * -! * specified. * -! * nnew - number of values of the function to be calculated. * -! * xnew - locations of the points at which the values of the * -! * function are calculated. xnew(k) must be ge xold(1) * -! * and le xold(nold). * -! * ynew - the values of the function to be calculated. * -! * p, q - auxiliary vectors of the length nold-2. * -! * * -! ****************************************************************** -!----------------------------------------------------------------------- -! - integer,intent(in) :: jtb,nnew,nold -! - real,dimension(jtb),intent(in) :: xnew,xold,yold - real,dimension(jtb),intent(inout) :: p,q,y2 - real,dimension(jtb),intent(out) :: ynew -! - integer :: k,k1,k2,kold,noldm1 -! - real :: ak,bk,ck,den,dx,dxc,dxl,dxr,dydxl,dydxr & - ,rdx,rtdxc,x,xk,xsq,y2k,y2kp1 -! -!----------------------------------------------------------------------- - noldm1=nold-1 -! - dxl=xold(2)-xold(1) - dxr=xold(3)-xold(2) - dydxl=(yold(2)-yold(1))/dxl - dydxr=(yold(3)-yold(2))/dxr - rtdxc=.5/(dxl+dxr) -! - p(1)= rtdxc*(6.*(dydxr-dydxl)-dxl*y2(1)) - q(1)=-rtdxc*dxr -! - if(nold.eq.3) go to 700 -!----------------------------------------------------------------------- - k=3 -! - 100 dxl=dxr - dydxl=dydxr - dxr=xold(k+1)-xold(k) - dydxr=(yold(k+1)-yold(k))/dxr - dxc=dxl+dxr - den=1./(dxl*q(k-2)+dxc+dxc) -! - p(k-1)= den*(6.*(dydxr-dydxl)-dxl*p(k-2)) - q(k-1)=-den*dxr -! - k=k+1 - if(k.lt.nold) go to 100 -!----------------------------------------------------------------------- - 700 k=noldm1 -! - 200 y2(k)=p(k-1)+q(k-1)*y2(k+1) -! - k=k-1 - if(k.gt.1) go to 200 -!----------------------------------------------------------------------- - k1=1 -! - 300 xk=xnew(k1) -! - do 400 k2=2,nold - if(xold(k2).le.xk) go to 400 - kold=k2-1 - go to 450 - 400 continue - ynew(k1)=yold(nold) - go to 600 -! - 450 if(k1.eq.1) go to 500 - if(k.eq.kold) go to 550 -! - 500 k=kold -! - y2k=y2(k) - y2kp1=y2(k+1) - dx=xold(k+1)-xold(k) - rdx=1./dx -! - ak=.1666667*rdx*(y2kp1-y2k) - bk=.5*y2k - ck=rdx*(yold(k+1)-yold(k))-.1666667*dx*(y2kp1+y2k+y2k) -! - 550 x=xk-xold(k) - xsq=x*x -! - ynew(k1)=ak*xsq*x+bk*xsq+ck*x+yold(k) -! - 600 k1=k1+1 - if(k1.le.nnew) go to 300 -!----------------------------------------------------------------------- -! - endsubroutine spline -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - subroutine psitbl -! ****************************************************************** -! * * -! * surface layer integral functions * -! * responsible person: z.janjic * -! * * -! ****************************************************************** -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -! - implicit none -! -!----------------------------------------------------------------------- -real(kind=kfpt),parameter:: & - eps=0.000001 -!--local variables------------------------------------------------------ -integer(kind=kint):: & - k ! index - -real(kind=kfpt):: & - x & ! temporary -,zeta1 & ! z/L, sea -,zeta2 & ! z/L, land -,zrng1 & ! z/L range, sea -,zrng2 ! z/L range, land -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- - kztm2=kztm-2 -! - fh01=1. - fh02=1. -! - ztmin1=-5.0 - ztmax1= 1.0 -! - ztmin2=-5.0 - ztmax2= 1.0 -! - zrng1=ztmax1-ztmin1 - zrng2=ztmax2-ztmin2 -! - dzeta1=zrng1/(kztm-1) - dzeta2=zrng2/(kztm-1) -!--------------function definition loop--------------------------------- - zeta1=ztmin1 - zeta2=ztmin2 - do k=1,kztm -!--------------unstable range------------------------------------------- - if(zeta1.lt.0.)then -!--------------paulson 1970 functions----------------------------------- - x=sqrt(sqrt(1.-16.*zeta1)) - psim1(k)=-2.*log((x+1.)/2.)-log((x*x+1.)/2.)+2.*atan(x)-pihf - psih1(k)=-2.*log((x*x+1.)/2.) -!--------------stable range--------------------------------------------- - else -!--------------holtslag and de bruin 1988------------------------------- - psim1(k)=0.7*zeta1+0.75*zeta1*(6.-0.35*zeta1)*exp(-0.35*zeta1) - psih1(k)=0.7*zeta1+0.75*zeta1*(6.-0.35*zeta1)*exp(-0.35*zeta1) -!----------------------------------------------------------------------- - endif -!--------------unstable range------------------------------------------- - if(zeta2.lt.0.)then -!--------------paulson 1970 functions----------------------------------- - x=sqrt(sqrt(1.-16.*zeta2)) - psim2(k)=-2.*log((x+1.)/2.)-log((x*x+1.)/2.)+2.*atan(x)-pihf - psih2(k)=-2.*log((x*x+1.)/2.) -!--------------stable range--------------------------------------------- - else -!--------------holtslag and de bruin 1988------------------------------- - psim2(k)=0.7*zeta2+0.75*zeta2*(6.-0.35*zeta2)*exp(-0.35*zeta2) - psih2(k)=0.7*zeta2+0.75*zeta2*(6.-0.35*zeta2)*exp(-0.35*zeta2) -!----------------------------------------------------------------------- - endif -!----------------------------------------------------------------------- - if(k.eq.kztm)then - ztmax1=zeta1 - ztmax2=zeta2 - endif -! - zeta1=zeta1+dzeta1 - zeta2=zeta2+dzeta2 -!----------------------------------------------------------------------- - enddo -!----------------------------------------------------------------------- - ztmax1=ztmax1-eps - ztmax2=ztmax2-eps -!----------------------------------------------------------------------- -! - endsubroutine psitbl -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - FUNCTION TIMEF() -! -!----------------------------------------------------------------------- -! - REAL*8 TIMEF - INTEGER(kind=KINT) :: IC,IR - - TIMEF=MPI_Wtime() -! -!----------------------------------------------------------------------- -! - END FUNCTION TIMEF -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - subroutine NMMB_Finalize - integer irc - CALL MPI_Finalize(irc) - stop 911 -! - end subroutine NMMB_Finalize -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - end module module_control -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- diff --git a/src/nmm/module_CONVECTION.F90 b/src/nmm/module_CONVECTION.F90 deleted file mode 100644 index cfe6ce2..0000000 --- a/src/nmm/module_CONVECTION.F90 +++ /dev/null @@ -1,675 +0,0 @@ -!----------------------------------------------------------------------- -! - MODULE MODULE_CONVECTION -! -!----------------------------------------------------------------------- -! -!*** THE CONVECTION DRIVERS AND PACKAGES -! -!----------------------------------------------------------------------- -! - USE MODULE_KINDS -! - USE MODULE_CONTROL,ONLY : NMMB_FINALIZE - - USE MODULE_CU_BMJ - USE MODULE_CU_SAS - USE MODULE_CU_SASHUR - USE MODULE_CU_SCALE -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: CUCNVC - PUBLIC :: BMJSCHEME, SASSCHEME, SASHURSCHEME, SCALECUSCHEME -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** THE CONVECTION OPTIONS -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - INTEGER(KIND=KINT),PARAMETER :: KFETASCHEME=1 & - ,BMJSCHEME=2 & - ,GDSCHEME=3 & - ,SASSCHEME=4 & - ,SASHURSCHEME=84 & - ,SCALECUSCHEME=94 -! -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- - SUBROUTINE CUCNVC(NTSD,DT,NCNVC,NRADS,NRADL,MINUTES_HISTORY & - ,ENTRAIN,NEWALL,NEWSWAP,NEWUPUP,NODEEP & - ,FRES,FR,FSL,FSS & - ,DYH,RESTRT,HYDRO & - ,CLDEFI & - ,F_ICE,F_RAIN & - ,QC,QR,QI,QS,QG & - ,F_QC,F_QR,F_QI,F_QS,F_QG & - ,DSG2,SGML2,SG2,PDSG1,PSGML1,PSG1 & - ,dxh & - ,PT,PD,T,Q,CWM,TCUCN & - ,OMGALF,U,V & - ,FIS,W0AVG & - ,PREC,ACPREC,CUPREC,ACPREC_TOT,CUPPT,CPRATE & - ,CNVBOT,CNVTOP,SM,LPBL & - ,HTOP,HTOPD,HTOPS & - ,HBOT,HBOTD,HBOTS & - ,AVCNVC,ACUTIM & - ,RSWIN,RSWOUT & - ,CONVECTION,CU_PHYSICS,MICROPHYSICS & -!!!! added for SAS - ,SICE,QWBS,TWBS,PBLH,DUDT_PHY,DVDT_PHY & -!!! -!!! added for SAS-hurricane - ,MOMMIX,PGCON,SAS_MASS_FLUX & ! hwrf,namelist - ,SHALCONV,SHAL_PGCON & !hwrf,namelist - ,W_TOT,PSGDT & ! test w from omgalf vs W_tot -!! - ,A2,A3,A4,CAPPA,CP,ELIV,ELWV,EPSQ,G & - ,P608,PQ0,R_D,TIW & - ,IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE & - ,ITS_B1,ITE_B1,JTS_B1,JTE_B1 & - ) -!*********************************************************************** -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: CUCNVC CONVECTIVE PRECIPITATION OUTER DRIVER -! PRGRMMR: BLACK ORG: W/NP22 DATE: 02-03-21 -! -! ABSTRACT: -! CUCVNC DRIVES THE WRF CONVECTION SCHEMES -! -! PROGRAM HISTORY LOG: -! 02-03-21 BLACK - ORIGINATOR -! 04-11-18 BLACK - THREADED -! 06-10-11 BLACK - BUILT INTO UMO PHYSICS COMPONENT -! 08-08 JANJIC - Synchronize WATER array and Q. -! 10-10-26 WEIGUO WANG - add GFS SAS convection -! 14-06-19 WEIGUO WANG - add hurricane SAS (moved from hwrf) -! 16-08-29 WEIGUO WANG - add scale-aware convection schemes -! USAGE: CALL CUCNVC FROM PHY_RUN -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE : IBM -!$$$ -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- - character(99),intent(in):: & - convection,microphysics -! - logical(kind=klog),intent(in):: & - hydro,restrt & - ,entrain,newall,newswap,newupup,nodeep & - ,f_qc,f_qr,f_qi,f_qs,f_qg -! - integer(kind=kint),intent(in):: & - cu_physics & - ,ids,ide,jds,jde,lm & - ,ims,ime,jms,jme & - ,its,ite,jts,jte & - ,its_b1,ite_b1,jts_b1,jte_b1 & - ,ncnvc,minutes_history & - ,nrads,nradl,ntsd -! - integer(kind=kint),dimension(ims:ime,jms:jme),intent(in):: & - lpbl -! - real(kind=kfpt),intent(in):: & - a2,a3,a4,cappa,cp,dt,dyh,eliv,elwv,epsq & - ,fres,fr,fsl,fss,g,p608,pq0,pt,r_d,tiw -! - real(kind=kfpt),dimension(1:lm),intent(in):: & - dsg2,pdsg1,psgml1,sgml2 -! - real(kind=kfpt),dimension(1:lm+1),intent(in):: & - psg1,sg2 -! - real(kind=kfpt),dimension(jds:jde),intent(in):: & - dxh -! - real(kind=kfpt),dimension(ims:ime,jms:jme),intent(in):: & - fis,pd & - ,rswin,rswout,sm -! - real(kind=kfpt),dimension(ims:ime,jms:jme),intent(inout):: & - acprec,cldefi & - ,acprec_tot & - ,cnvbot,cnvtop & - ,cuppt,cuprec & - ,hbot,htop & - ,hbotd,htopd & - ,hbots,htops & - ,prec,cprate & - ,acutim,avcnvc !<-- were scalars -! - real(kind=kfpt),dimension(ims:ime,jms:jme),intent(in):: & - sice,qwbs,twbs,pblh !fOR SAS - - REAL(kind=kfpt), OPTIONAL, INTENT(IN) :: & - PGCON,sas_mass_flux,shal_pgcon,mommix,shalconv !sashur -!! INTEGER(kind=kint), OPTIONAL, INTENT(IN) :: shalconv !sashur - real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(in)::W_TOT - real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm-1),intent(in)::PSGDT !vertical mass flux -! - real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(in):: & - omgalf,u,v -! - real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(out):: & - dudt_phy,dvdt_phy -! - real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(inout):: & - q,t & - ,f_ice & - ,f_rain & - ,cwm & - ,tcucn -! - real(kind=kfpt),dimension(ims:ime,1:lm+1,jms:jme),intent(inout):: & - w0avg -! - REAL(KIND=KFPT),DIMENSION(:,:,:),POINTER,INTENT(INOUT) :: & - & QC,QI,QR,QS,QG -!----------------------------------------------------------------------- -!*** LOCAL VARIABLES -!----------------------------------------------------------------------- -! - logical(kind=klog):: & - restart,warm_rain,F_QGr -! - logical(kind=klog),dimension(ims:ime,jms:jme):: & - cu_act_flag -! - integer(kind=kint):: & - i,j & - ,k & - ,mnto & - ,n,ncubot,ncutop,n_timstps_output -! - integer(kind=kint),dimension(ims:ime,jms:jme):: & - KPBL,LBOT,LTOP -! - real(kind=kfpt):: & - cf_hi,dtcnvc,dtdt,fice,frain,g_inv & - ,pcpcol,pdsl,ql,ql_k,rdtcnvc & - ,QCW,QCI,QRain,QSnow,QGraup & - ,tl -! - REAL(kind=kfpt),DIMENSION(IMS:IME,JMS:JME):: & - CUBOT,CUTOP,NCA & - ,RAINC,RAINCV,SFCZ,XLAND -! - REAL(kind=kfpt),DIMENSION(IMS:IME,JMS:JME,1:LM):: & - DZ,PHMID,exner & - ,th,rr & - ,RQCCUTEN,RQRCUTEN & - ,RQICUTEN,RQSCUTEN & - ,RQCUTEN,RTHCUTEN & - ,RQGCUTEN & - ,u_phy,v_phy - - REAL(kind=kfpt),DIMENSION(IMS:IME,JMS:JME,1:LM+1):: & - PHINT -!----------------------------------------------------------------------- -!*** For temperature change check only. -!----------------------------------------------------------------------- -!zj REAL(kind=kfpt) :: DTEMP_CHECK=1.0 - REAL(kind=kfpt) :: TCHANGE -!----------------------------------------------------------------------- -!*********************************************************************** -! -!----------------------------------------------------------------------- -!*** RESET THE HBOT/HTOP CONVECTIVE CLOUD BOTTOM (BASE) AND TOP ARRAYS -!*** USED IN RADIATION. THEY STORE THE MAXIMUM VERTICAL LIMITS OF -!*** CONVECTIVE CLOUD BETWEEN RADIATION CALLS. THESE ARRAYS ARE OUT -!*** OF THE WRF PHYSICS AND THUS THEIR VALUES INCREASE UPWARD. -!*** CUPPT IS THE ACCUMULATED CONVECTIVE PRECIPITATION BETWEEN -!*** RADIATION CALLS. -!----------------------------------------------------------------------- -! - IF(MOD(NTSD,NRADS)==0.OR.MOD(NTSD,NRADL)==0)THEN - DO J=JMS,JME - DO I=IMS,IME - HTOP(I,J)=0. - HBOT(I,J)=REAL(LM+1) - CUPPT(I,J)=0. - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- - IF(MOD(NTSD,NCNVC)/=0.AND.CONVECTION=='bmj')RETURN - IF(MOD(NTSD,NCNVC)/=0.AND.CONVECTION=='sas')RETURN - IF(MOD(NTSD,NCNVC)/=0.AND.CONVECTION=='sashur')RETURN - IF(MOD(NTSD,NCNVC)/=0.AND.CONVECTION=='scalecu')RETURN -!----------------------------------------------------------------------- -! - RESTART=RESTRT -! -!----------------------------------------------------------------------- -! - IF(MICROPHYSICS=='fer' .OR. MICROPHYSICS=='fer_hires') THEN - F_QGr=.FALSE. - ELSE - F_QGr=F_QG - ENDIF - IF(CONVECTION=='kf')THEN -! - IF(.NOT.RESTART.AND.NTSD==0)THEN -!jaa!zj$omp parallel do & -!jaa!zj$omp& private(i,j,k) - DO J=JTS,JTE - DO K=1,LM+1 - DO I=ITS,ITE - W0AVG(I,K,J)=0. - ENDDO - ENDDO - ENDDO - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** GENERAL PREPARATION -!----------------------------------------------------------------------- -! -!-- AVCNVC,ACUTIM were scalars but changed to 2D arrays to allow for updates in ESMF -! - DO J=JTS,JTE - DO I=ITS,ITE - AVCNVC(I,J)=AVCNVC(I,J)+1. - ACUTIM(I,J)=ACUTIM(I,J)+1. - ENDDO - ENDDO -! - DTCNVC=NCNVC*DT - RDTCNVC=1./DTCNVC - G_INV=1./G -! -!....................................................................... -!zj$omp parallel do & -!zj$omp& private(j,i,k,pdsl,ql,tl) -!....................................................................... - DO J=JTS,JTE - DO I=ITS,ITE -! - PDSL=PD(I,J) - RAINCV(I,J)=0. - RAINC(I,J)=0. - PHINT(I,J,LM+1)=SG2(LM+1)*PDSL+PSG1(LM+1) - XLAND(I,J)=SM(I,J)+1. - NCA(I,J)=0. - SFCZ(I,J)=FIS(I,J)*G_INV -! - CUTOP(I,J)=999. - CUBOT(I,J)=999. -! -!*** LPBL IS THE MODEL LAYER CONTAINING THE PBL TOP -!*** COUNTING DOWNWARD FROM THE TOP OF THE DOMAIN -!*** SO KPBL IS THE SAME LAYER COUNTING UPWARD FROM -!*** THE GROUND. -! - KPBL(I,J)=LPBL(I,J) -! -!----------------------------------------------------------------------- -!*** FILL VERTICAL WORKING ARRAYS. -!----------------------------------------------------------------------- -! - DO K=1,LM -! - PHINT(I,J,K)=SG2(K)*PDSL+PSG1(K) !zj - PHMID(I,J,K)=SGML2(K)*PDSL+PSGML1(K) - - QL=MAX(Q(I,J,K),EPSQ) - TL=T(I,J,K) - RR(I,J,K)=PHMID(I,J,K)/(R_D*TL*(.608*ql+1.)) - T(I,J,K)=TL -! - EXNER(I,J,K)=(PHMID(I,J,K)*1.E-5)**CAPPA - TH(I,J,K)=TL/EXNER(I,J,K) -! - ENDDO - ENDDO - ENDDO -!....................................................................... -!zj$omp end parallel do -!....................................................................... -! -!----------------------------------------------------------------------- -!*** Compute velocity components at mass points. -!----------------------------------------------------------------------- -! -!....................................................................... -!zj$omp parallel do & -!zj$omp& private(j,i,k) -!....................................................................... - do k=1,lm - do j=jms,jme - do i=ims,ime - u_phy(i,j,k)=0. - v_phy(i,j,k)=0. -! - RTHCUTEN(I,J,K)=0. - RQCUTEN(I,J,K)=0. - RQCCUTEN(I,J,K)=0. - RQRCUTEN(I,J,K)=0. - RQICUTEN(I,J,K)=0. - RQSCUTEN(I,J,K)=0. - RQGCUTEN(I,J,K)=0. - dudt_phy(i,j,k)=0. - dvdt_phy(i,j,k)=0. - enddo - enddo -! - do j=jts_b1,jte_b1 - do i=its_b1,ite_b1 - u_phy(i,j,k)=(u(i,j ,k)+u(i-1,j ,k) & - +u(i,j-1,k)+u(i-1,j-1,k))*0.25 - v_phy(i,j,k)=(v(i,j ,k)+v(i-1,j ,k) & - +v(i,j-1,k)+v(i-1,j-1,k))*0.25 - ENDDO - ENDDO - ENDDO -!....................................................................... -!zj$omp end parallel do -!....................................................................... -!----------------------------------------------------------------------- -!....................................................................... -!zj$omp parallel do & -!zj$omp private(i,j,k,ql_k) -!....................................................................... - DO J=JTS,JTE - DO I=ITS,ITE - DZ(I,J,LM)=T(I,J,LM)*(.608*Q(I,J,LM)+1.)*R_D & - *(PHINT(I,J,LM+1)-PHINT(I,J,LM)) & - /(PHMID(I,J,LM)*G) - ENDDO -! - DO K=LM-1,1,-1 - DO I=ITS,ITE - QL_K=MAX(Q(I,J,K),EPSQ) - DZ(I,J,K)=T(I,J,K)*(.608*QL_K+1.)*R_D & - *(PHINT(I,J,K+1)-PHINT(I,J,K)) & - /(PHMID(I,J,K)*G) - ENDDO - ENDDO -! - ENDDO -!....................................................................... -!zj$omp end parallel do -!....................................................................... -! -!write(0,*)'A2,A3,A4,cappa,CP,ELIV,ELWV,EPSQ,p608,PQ0,R_D,TIW' & -!,A2,A3,A4,cappa,CP,ELIV,ELWV,EPSQ,p608,PQ0,R_D,TIW - -! -!----------------------------------------------------------------------- -! -!*** SINGLE-COLUMN CONVECTION -! -!----------------------------------------------------------------------- - IF (CU_PHYSICS /= 0) THEN - - cps_select: SELECT CASE(cu_physics) - - CASE (BMJSCHEME) - - call bmjdrv( & - ids,ide,jds,jde & - ,ims,ime,jms,jme & - ,its,ite,jts,jte,lm & - ,its_b1,ite_b1,jts_b1,jte_b1 & - ,entrain,newall,newswap,newupup,nodeep & - ,a2,a3,a4,cappa,cp,eliv,elwv,epsq,g & - ,p608,pq0,r_d,tiw & - ,fres,fr,fsl,fss & - ,dt,dyh,ntsd,ncnvc & - ,raincv,cutop,cubot,dxh,kpbl & - ,th,t,q,u_phy,v_phy,dudt_phy,dvdt_phy & - ,phint,phmid,exner & - ,cldefi,xland,cu_act_flag & - ! optional - ,rthcuten,rqcuten & - ) -!----------------------------------------------------------------------- - CASE (SASSCHEME) - call sasdrv( & - ims,ime,jms,jme & - ,its,ite,jts,jte,lm & - ,dt,ntsd,ncnvc & - ,th,t,sice,omgalf,twbs,qwbs,pblh,u_phy,v_phy & !zj orig u&v - ,q,qc,qr,qi,qs,qg & - ,f_qc,f_qr,f_qi,f_qs,F_QGr & - ,phint,phmid,exner,rr,dz & - ,xland,cu_act_flag & - ,psgdt & - ,raincv,cutop,cubot & - ,dudt_phy,dvdt_phy & - ! optional - ,rthcuten, rqcuten & - ,rqccuten, rqrcuten & - ,rqicuten, rqscuten & - ,rqgcuten & - ) -!! 2014-06-19 -!! Weiguo Wang added SAS version from HWRF - CASE (SASHURSCHEME) - call sasdrv_hur( & - ims,ime,jms,jme & - ,its,ite,jts,jte,lm & - ,dt,ntsd,ncnvc & - ,th,t,sice,omgalf,twbs,qwbs,pblh,u_phy,v_phy & !zj orig u&v - ,q,qc,qr,qi,qs,qg & - ,f_qc,f_qr,f_qi,f_qs,F_QGr & - ,phint,phmid,exner,rr,dz & - ,xland,cu_act_flag & - ,MOMMIX,PGCON,SAS_MASS_FLUX & ! hwrf,namelist - ,SHALCONV,SHAL_PGCON & ! hwrf,namelist - ,W_TOT,PSGDT & -! ,PRATEC & ! hwrf, useful?? - ,raincv,cutop,cubot & - ,dudt_phy,dvdt_phy & - ! optional - ,rthcuten, rqcuten & - ,rqccuten, rqrcuten & - ,rqicuten, rqscuten & - ,rqgcuten & - ) -!!2014-06-19 -!!2016-08-29 -!! Weiguo Wang added scale-aware SAS version, same as HWRF - CASE (SCALECUSCHEME) - call scalecudrv( & - ids,jde & - ,ims,ime,jms,jme & - ,its,ite,jts,jte,lm & - ,dt,ntsd,ncnvc & - ,th,t,sice,omgalf,twbs,qwbs,pblh,u_phy,v_phy & !zj orig u&v - ,q,qc,qr,qi,qs,qg & - ,f_qc,f_qr,f_qi,f_qs,F_QGr & - ,phint,phmid,exner,rr,dz & - ,xland,cu_act_flag & - ,dxh, dyh & - ,MOMMIX,PGCON,SAS_MASS_FLUX & ! hwrf,namelist - ,SHALCONV,SHAL_PGCON & ! hwrf,namelist - ,W_TOT,PSGDT & -! ,PRATEC & ! hwrf, useful?? - ,raincv,cutop,cubot & - ,dudt_phy,dvdt_phy & - ! optional - ,rthcuten, rqcuten & - ,rqccuten, rqrcuten & - ,rqicuten, rqscuten & - ,rqgcuten & - ) -!!2016-08-29 - CASE DEFAULT - - WRITE( 0 , * ) 'The cumulus option does not exist: cu_physics = ', cu_physics - - END SELECT cps_select - - END IF -! -!----------------------------------------------------------------------- -! -!*** CNVTOP/CNVBOT HOLD THE MAXIMUM VERTICAL LIMITS OF CONVECTIVE CLOUD -!*** BETWEEN HISTORY OUTPUT TIMES. HBOTS/HTOPS STORE SIMILIAR INFORMATION -!*** FOR SHALLOW (NONPRECIPITATING) CONVECTION, AND HBOTD/HTOPD ARE FOR -!*** DEEP (PRECIPITATING) CONVECTION. -! - CF_HI=REAL(MINUTES_HISTORY)/60. - N_TIMSTPS_OUTPUT=NINT(3600.*CF_HI/DT) - MNTO=MOD(NTSD,N_TIMSTPS_OUTPUT) -! - IF(MNTO>0.AND.MNTO<=NCNVC)THEN - DO J=JTS,JTE - DO I=ITS,ITE - CNVBOT(I,J)=REAL(LM+1.) - CNVTOP(I,J)=0. - HBOTD(I,J)=REAL(LM+1.) - HTOPD(I,J)=0. - HBOTS(I,J)=REAL(LM+1.) - HTOPS(I,J)=0. - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!....................................................................... -!zj$omp parallel do & -!zj$omp& private(j,k,i,dtdt,tchange,pcpcol,ncubot,ncutop,QCW,QRain,QCI,QSnow,QGraup) -!....................................................................... -!----------------------------------------------------------------------- - do j=jts_b1,jte_b1 - do i=its_b1,ite_b1 -!----------------------------------------------------------------------- -! -!*** UPDATE TEMPERATURE, SPECIFIC HUMIDITY, AND HEATING. -! - DO K=1,LM -! -!*** RTHCUTEN IN BMJDRV IS DTDT OVER exner. -! - DTDT=RTHCUTEN(I,J,K)*exner(I,J,K) - T(I,J,K)=T(I,J,K)+DTDT*DTCNVC - Q(I,J,K)=Q(I,J,K)+RQCUTEN(I,J,K)*DTCNVC - TCUCN(I,J,K)=TCUCN(I,J,K)+DTDT - -!!! WANG, 11-2-2010 SAS convection; modified on 11-20-2014 by BSF -sas_test: IF(CONVECTION=='sas') THEN - QC(I,J,K)=QC(I,J,K)+DTCNVC*RQCCUTEN(I,J,K) - QCW=QC(I,J,K) - QRain=0. - QCI=0. - QSnow=0. - QGraup=0. - IF(F_QR) THEN - QR(I,J,K)=QR(I,J,K)+DTCNVC*RQRCUTEN(I,J,K) - QRain=QR(I,J,K) - ENDIF - IF(F_QI) THEN - QI(I,J,K)=QI(I,J,K)+DTCNVC*RQICUTEN(I,J,K) - QCI=QI(I,J,K) - ENDIF - IF(F_QS) THEN - QS(I,J,K)=QS(I,J,K)+DTCNVC*RQSCUTEN(I,J,K) - QSnow=QS(I,J,K) - ENDIF - IF(F_QGr) THEN - QG(I,J,K)=QG(I,J,K)+DTCNVC*RQGCUTEN(I,J,K) - QGraup=QG(I,J,K) - ENDIF -!-- Couple CWM, F_ice, & F_rain arrays - CWM(I,J,K)=QCW+QRain+QCI+QSnow+QGraup - F_ICE(I,J,K)=0. - F_RAIN(I,J,K)=0. - IF(CWM(I,J,K)>EPSQ) F_ICE(I,J,K)=(QCI+QSnow+QGraup)/CWM(I,J,K) - IF(QRain>EPSQ) F_RAIN(I,J,K)=QRain/(QCW+QRain) - ENDIF sas_test -!!! wang, 11-2-2010; modified on 11-20-2014 by BSF -! -!zj TCHANGE=DTDT*DTCNVC -!zj IF(ABS(TCHANGE)>DTEMP_CHECK)THEN -!zj WRITE(0,*)'BIG T CHANGE BY CONVECTION:',TCHANGE,' at (',I,',',J,',',K,')' -!zj ENDIF -! - ENDDO - -!write(0,*),'t',(rthcuten(i,j,k),k=1,lm) -!write(0,*),'q',(rqcuten(i,j,k),k=1,lm) -!write(0,*),'u',(dudt_phy(i,j,k),k=1,lm) -!write(0,*),'v',(dvdt_phy(i,j,k),k=1,lm) -!write(0,*),'exner',(exner(i,j,k),k=1,lm) - - -! -!*** UPDATE PRECIPITATION -! - PCPCOL=RAINCV(I,J)*1.E-3*NCNVC - PREC(I,J)=PREC(I,J)+PCPCOL - ACPREC(I,J)=ACPREC(I,J)+PCPCOL - ACPREC_TOT(I,J)=ACPREC_TOT(I,J)+PCPCOL - CUPREC(I,J)=CUPREC(I,J)+PCPCOL - CUPPT(I,J)=CUPPT(I,J)+PCPCOL - CPRATE(I,J)=PCPCOL -! -!*** SAVE CLOUD TOP AND BOTTOM FOR RADIATION (HTOP/HBOT) AND -!*** FOR OUTPUT (CNVTOP/CNVBOT, HTOPS/HBOTS, HTOPD/HBOTD) ARRAYS. -!*** MUST BE TREATED SEPARATELY FROM EACH OTHER. -! - NCUTOP=NINT(CUTOP(I,J)) - NCUBOT=NINT(CUBOT(I,J)) -! - IF(NCUTOP>1.AND.NCUTOP0.)THEN - HTOPD(I,J)=MAX(CUTOP(I,J),HTOPD(I,J)) - ELSE - HTOPS(I,J)=MAX(CUTOP(I,J),HTOPS(I,J)) - ENDIF - ENDIF - IF(NCUBOT>0.AND.NCUBOT0.)THEN - HBOTD(I,J)=MIN(CUBOT(I,J),HBOTD(I,J)) - ELSE - HBOTS(I,J)=MIN(CUBOT(I,J),HBOTS(I,J)) - ENDIF - ENDIF -! - ENDDO - ENDDO -!....................................................................... -!zj$omp end parallel do -!....................................................................... -! -!----------------------------------------------------------------------- -! - END SUBROUTINE CUCNVC -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - END MODULE MODULE_CONVECTION -! -!----------------------------------------------------------------------- diff --git a/src/nmm/module_DERIVED_TYPES.F90 b/src/nmm/module_DERIVED_TYPES.F90 deleted file mode 100644 index 432186c..0000000 --- a/src/nmm/module_DERIVED_TYPES.F90 +++ /dev/null @@ -1,278 +0,0 @@ -!----------------------------------------------------------------------- -! - MODULE MODULE_DERIVED_TYPES -! -!----------------------------------------------------------------------- -! -!*** This module contains various derived datatypes used in -!*** the NMM-B nesting. -! -!----------------------------------------------------------------------- -! -! PROGRAM HISTORY LOG: -! -! 2013-11-08 Black - Created -! -!----------------------------------------------------------------------- -! -! USAGE: -! -!----------------------------------------------------------------------- -! - USE ESMF -! - USE module_KINDS -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: BC_H & - ,BC_V & - ,BC_H_ALL & - ,BC_V_ALL & - ,BNDS_2D & - ,CHILD_UPDATE_LINK & - ,COMMS_FAMILY & - ,CTASK_LIMITS & - ,DOMAIN_DATA & - ,FILT_4D & - ,HANDLE_CHILD_LIMITS & - ,HANDLE_CHILD_TOPO_S & - ,HANDLE_CHILD_TOPO_N & - ,HANDLE_CHILD_TOPO_W & - ,HANDLE_CHILD_TOPO_E & - ,HANDLE_I_SW & - ,HANDLE_J_SW & - ,HANDLE_PACKET_S_H & - ,HANDLE_PACKET_S_V & - ,HANDLE_PACKET_N_H & - ,HANDLE_PACKET_N_V & - ,HANDLE_PACKET_W_H & - ,HANDLE_PACKET_W_V & - ,HANDLE_PACKET_E_H & - ,HANDLE_PACKET_E_V & - ,HANDLE_PARENT_DOM_LIMITS & - ,HANDLE_PARENT_ITE & - ,HANDLE_PARENT_ITS & - ,HANDLE_PARENT_JTE & - ,HANDLE_PARENT_JTS & - ,INFO_SEND & - ,INTEGER_DATA & - ,INTEGER_DATA_2D & - ,INTERIOR_DATA_FROM_PARENT & - ,MIXED_DATA & - ,MIXED_DATA_TASKS & - ,MULTIDATA & - ,PTASK_LIMITS & - ,REAL_DATA & - ,REAL_DATA_2D & - ,REAL_DATA_TASKS & - ,REAL_VBLS_3D -! -!----------------------------------------------------------------------- -! - TYPE MIXED_DATA - INTEGER(kind=KINT),DIMENSION(:),POINTER :: DATA_INTEGER - REAL(kind=KFPT),DIMENSION(:),POINTER :: DATA_REAL - END TYPE MIXED_DATA -! - TYPE MIXED_DATA_TASKS - TYPE(MIXED_DATA),DIMENSION(:),POINTER :: TASKS - END TYPE MIXED_DATA_TASKS -! - TYPE INTEGER_DATA - INTEGER(kind=KINT),DIMENSION(:),POINTER :: DATA - END TYPE INTEGER_DATA -! - TYPE INTEGER_DATA_2D - INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: DATA - END TYPE INTEGER_DATA_2D -! - TYPE REAL_DATA - REAL(kind=KFPT),DIMENSION(:),POINTER :: DATA - END TYPE REAL_DATA -! - TYPE REAL_DATA_2D - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: DATA - END TYPE REAL_DATA_2D -! - TYPE REAL_VBLS_3D - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: VBL - END TYPE REAL_VBLS_3D -! - TYPE REAL_DATA_TASKS - TYPE(REAL_DATA),DIMENSION(:),POINTER :: TASKS - END TYPE REAL_DATA_TASKS -! - TYPE MULTIDATA - TYPE(REAL_DATA_TASKS),DIMENSION(:),POINTER :: CHILD - END TYPE MULTIDATA -! - TYPE BNDS_2D - INTEGER(kind=KINT) :: LBND1 - INTEGER(kind=KINT) :: UBND1 - INTEGER(kind=KINT) :: LBND2 - INTEGER(kind=KINT) :: UBND2 - END TYPE BNDS_2D -! - TYPE :: INTERIOR_DATA_FROM_PARENT - INTEGER(kind=KINT) :: ID - INTEGER(kind=KINT) :: NPTS - INTEGER(kind=KINT),DIMENSION(1:2) :: ISTART - INTEGER(kind=KINT),DIMENSION(1:2) :: IEND - INTEGER(kind=KINT),DIMENSION(1:2) :: JSTART - INTEGER(kind=KINT),DIMENSION(1:2) :: JEND - END TYPE INTERIOR_DATA_FROM_PARENT -! - TYPE :: CHILD_UPDATE_LINK - INTEGER(kind=KINT),POINTER :: TASK_ID - INTEGER(kind=KINT),POINTER :: NUM_PTS_UPDATE_HZ - INTEGER(kind=KINT),DIMENSION(:),POINTER :: IL - INTEGER(kind=KINT),DIMENSION(:),POINTER :: JL - TYPE(CHILD_UPDATE_LINK),POINTER :: NEXT_LINK - END TYPE CHILD_UPDATE_LINK -! - TYPE :: COMMS_FAMILY - INTEGER(kind=KINT) :: TO_PARENT - INTEGER(kind=KINT) :: TO_FCST_TASKS - INTEGER(kind=KINT),DIMENSION(:),POINTER :: TO_CHILDREN - END TYPE COMMS_FAMILY -! - TYPE :: DOMAIN_DATA - TYPE(INTEGER_DATA),DIMENSION(:),POINTER :: CHILDREN - END TYPE DOMAIN_DATA -! - TYPE :: DOMAIN_DATA_2 - TYPE(INTEGER_DATA_2D),DIMENSION(:),POINTER :: CHILDREN - END TYPE DOMAIN_DATA_2 -! - TYPE :: DOMAIN_LIMITS - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: ITS - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: ITE - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: JTS - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: JTE - END TYPE DOMAIN_LIMITS -! - TYPE :: TASK_LIMITS - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: ITS - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: ITE - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: JTS - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: JTE - END TYPE TASK_LIMITS -! - TYPE :: BC_INFO - TYPE(CHILD_INFO),DIMENSION(:),POINTER :: CHILDREN - END TYPE BC_INFO -! - TYPE CHILD_INFO - INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: INFO - END TYPE CHILD_INFO -! - TYPE BC_2D - REAL(kind=KFPT),DIMENSION(:,:),ALLOCATABLE :: SIDE - END TYPE BC_2D -! - TYPE BC_3D - REAL(kind=KFPT),DIMENSION(:,:,:),ALLOCATABLE :: SIDE - END TYPE BC_3D -! - TYPE BC_4D - REAL(kind=KFPT),DIMENSION(:,:,:,:),ALLOCATABLE :: SIDE - END TYPE BC_4D -! - TYPE BC_H - TYPE(BC_2D),DIMENSION(:),ALLOCATABLE :: VAR_2D - TYPE(BC_3D),DIMENSION(:),ALLOCATABLE :: VAR_3D - TYPE(BC_4D),DIMENSION(:),ALLOCATABLE :: VAR_4D - END TYPE BC_H -! - TYPE BC_V - TYPE(BC_2D),DIMENSION(:),ALLOCATABLE :: VAR_2D - TYPE(BC_3D),DIMENSION(:),ALLOCATABLE :: VAR_3D - END TYPE BC_V -! - TYPE BC_2D_ALL - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: SOUTH & - ,NORTH & - ,WEST & - ,EAST - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: FULL_VAR - END TYPE BC_2D_ALL -! - TYPE BC_3D_ALL - REAL(kind=KFPT),DIMENSION(:,:,:,:),POINTER :: SOUTH & - ,NORTH & - ,WEST & - ,EAST - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: FULL_VAR - END TYPE BC_3D_ALL -! - TYPE BC_4D_ALL - REAL(kind=KFPT),DIMENSION(:,:,:,:,:),POINTER :: SOUTH & - ,NORTH & - ,WEST & - ,EAST - REAL(kind=KFPT),DIMENSION(:,:,:,:),POINTER :: FULL_VAR - END TYPE BC_4D_ALL -! - TYPE BC_H_ALL - TYPE(BC_2D_ALL),DIMENSION(:),ALLOCATABLE :: VAR_2D - TYPE(BC_3D_ALL),DIMENSION(:),ALLOCATABLE :: VAR_3D - TYPE(BC_4D_ALL),DIMENSION(:),ALLOCATABLE :: VAR_4D - END TYPE BC_H_ALL -! - TYPE BC_V_ALL - TYPE(BC_2D_ALL),DIMENSION(:),ALLOCATABLE :: VAR_2D - TYPE(BC_3D_ALL),DIMENSION(:),ALLOCATABLE :: VAR_3D - END TYPE BC_V_ALL -! - TYPE FILT_4D - REAL(kind=KFPT),DIMENSION(:,:,:,:,:),ALLOCATABLE :: BASE - END TYPE FILT_4D -! -!----------------------------------------------------------------------- -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: HANDLE_I_SW & - ,HANDLE_J_SW -! - TYPE(INTEGER_DATA),DIMENSION(:),ALLOCATABLE :: HANDLE_PARENT_DOM_LIMITS !<-- Request handle for ISSend of parent domain limits -! - TYPE(INTEGER_DATA),DIMENSION(:),POINTER :: HANDLE_PARENT_ITE & !<-- Request handles for ISSends - ,HANDLE_PARENT_ITS & ! of each parent task's - ,HANDLE_PARENT_JTE & !<-- integration limits to children. - ,HANDLE_PARENT_JTS -! - TYPE(CHILD_UPDATE_LINK),POINTER,SAVE :: TAIL -! - TYPE(DOMAIN_DATA),DIMENSION(:),POINTER,SAVE :: HANDLE_CHILD_LIMITS & !<-- Request handles for parents' IRecvs if child task limits -! - ,HANDLE_CHILD_TOPO_S & !<-- Request handles for parents' IRecvs of child bndry topo - ,HANDLE_CHILD_TOPO_N & ! - ,HANDLE_CHILD_TOPO_W & ! - ,HANDLE_CHILD_TOPO_E !<-- -! - TYPE(DOMAIN_DATA),DIMENSION(:),POINTER,SAVE :: HANDLE_PACKET_S_H & !<-- Request handles for parents' ISends of bndry info packets - ,HANDLE_PACKET_S_V & ! - ,HANDLE_PACKET_N_H & ! - ,HANDLE_PACKET_N_V & ! - ,HANDLE_PACKET_W_H & ! - ,HANDLE_PACKET_W_V & ! - ,HANDLE_PACKET_E_H & ! - ,HANDLE_PACKET_E_V !<-- -! - TYPE(TASK_LIMITS),DIMENSION(:),ALLOCATABLE,SAVE :: PTASK_LIMITS !<-- I,J limits on parent task subdomains -! - TYPE(DOMAIN_DATA_2),DIMENSION(:),POINTER,SAVE :: CTASK_LIMITS !<-- For limits of parents' children's tasks' subdomains -! - TYPE(BC_INFO),DIMENSION(:),POINTER,SAVE :: INFO_SEND !<-- Parent info to children about which BC updates -! -!----------------------------------------------------------------------- -! - END MODULE MODULE_DERIVED_TYPES -! -!----------------------------------------------------------------------- diff --git a/src/nmm/module_DIAGNOSE.F90 b/src/nmm/module_DIAGNOSE.F90 deleted file mode 100644 index 1d7bd25..0000000 --- a/src/nmm/module_DIAGNOSE.F90 +++ /dev/null @@ -1,3001 +0,0 @@ - !---------------------------------------------------------------------- -! - MODULE MODULE_DIAGNOSE -! -!---------------------------------------------------------------------- -! - USE MPI - - USE MODULE_KINDS - USE MODULE_CONSTANTS, ONLY : R_D,R_V,CPV,CP,G,CLIQ,PSAT,P608 & - & ,XLV,TIW,EPSQ,DBZmin - IMPLICIT NONE -! - REAL, PRIVATE, PARAMETER :: Cice=1.634e13 & !-- For dry ice (T<0C) - , Cwet=1./.189 & !-- Wet ice spheres at >=0C (Smith, JCAM, 1984, p. 1259, eq. 10) - , Cboth=Cice*Cwet & !-- Rain + wet ice at >0C - , CU_A=300, CU_B=1.4 & !-- For convective precipitation reflectivity - , TFRZ=TIW, TTP=TIW+0.01, Zmin=0.01 & - , EPSILON=R_D/R_V, ONE_MINUS_EPSILON=1.-EPSILON & - , R_FACTOR=1./EPSILON-1., CP_FACTOR=CPV/CP-1., RCP=R_D/CP & - , P00_INV=1.E-5, XA=(CLIQ-CPV)/R_V, XB=XA+XLV/(R_V*TTP) -! -! -!---------------------------------------------------------------------- -! - CONTAINS -! -!---------------------------------------------------------------------- -!###################################################################### -!---------------------------------------------------------------------- - SUBROUTINE NWR(INT_STATE,ARRAY,KK,FIELD,NTSD & - ,MYPE,NPES,MPI_COMM_COMP & - ,IDS,IDE,JDS,JDE & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE & - ,DOMAIN_ID ) -!---------------------------------------------------------------------- -!********************************************************************** -!---------------------------------------------------------------------- - USE NEMSIO_MODULE - USE MODULE_SOLVER_INTERNAL_STATE,ONLY: SOLVER_INTERNAL_STATE - IMPLICIT NONE -!---------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(SOLVER_INTERNAL_STATE),POINTER :: INT_STATE - INTEGER(KIND=KINT),INTENT(IN) :: IDS,IDE,JDS,JDE & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE & - ,KK,MPI_COMM_COMP,MYPE,NPES,NTSD -! - REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME,KK),INTENT(IN) :: ARRAY -! - CHARACTER(*),INTENT(IN) :: FIELD -! - INTEGER(kind=KINT),INTENT(IN),OPTIONAL :: DOMAIN_ID -! -!-------------------- -!*** Local Variables -!-------------------- -! - INTEGER :: IUNIT=23 -! - INTEGER,DIMENSION(MPI_STATUS_SIZE) :: JSTAT - INTEGER,DIMENSION(MPI_STATUS_SIZE,4) :: STATUS_ARRAY - INTEGER(KIND=KINT),DIMENSION(2) :: IM_REM,JM_REM,IT_REM,JT_REM -! - INTEGER(KIND=KINT) :: I,IENDX,IER,IPE,IRECV,IRTN,ISEND & - ,J,K,N,NLEN,NSIZE - INTEGER(KIND=KINT) :: ITS_REM,ITE_REM,JTS_REM,JTE_REM -! - REAL(KIND=KFPT),DIMENSION(IDS:IDE,JDS:JDE) :: TWRITE - REAL(KIND=KFPT),ALLOCATABLE,DIMENSION(:) :: VALUES - CHARACTER(2) :: DOM_ID - CHARACTER(5) :: TIMESTEP - CHARACTER(6) :: FMT - CHARACTER(128) :: FILENAME -! - TYPE(NEMSIO_GFILE) :: NEMSIOFILE - INTEGER :: IRET - INTEGER :: NREC, FIELDSIZE - REAL(KIND=KFPT),ALLOCATABLE,DIMENSION(:) :: TMP,GLAT1D,GLON1D - CHARACTER(16),DIMENSION(:),ALLOCATABLE :: RECNAME,RECLEVTYP - INTEGER, DIMENSION(:),ALLOCATABLE :: RECLEV - - INTEGER :: NMETAVARI, NMETAVARR, NMETAVARL - CHARACTER(16),DIMENSION(:),ALLOCATABLE :: VARINAME & - ,VARRNAME & - ,VARLNAME - INTEGER,DIMENSION(:),ALLOCATABLE :: VARIVAL - REAL,DIMENSION(:),ALLOCATABLE :: VARRVAL - LOGICAL,DIMENSION(:),ALLOCATABLE :: VARLVAL - INTEGER :: IDATE(7) -! -!---------------------------------------------------------------------- -!********************************************************************** -!---------------------------------------------------------------------- -! - FMT='(I5.5)' - NLEN=5 - WRITE(TIMESTEP,FMT)NTSD -! - IF(PRESENT(DOMAIN_ID))THEN - FMT='(I2.2)' - WRITE(DOM_ID,FMT)DOMAIN_ID - FILENAME='dump_'//FIELD//'_'//'D'//DOM_ID//'_'//TIMESTEP(1:NLEN) - ELSE - FILENAME='dump_'//FIELD//'_'//TIMESTEP(1:NLEN) - ENDIF -! - IF(MYPE==0)THEN - CALL NEMSIO_INIT(IRET=IRET) - - IDATE=0 - IDATE(1)=int_state%IDAT(3) - IDATE(2)=int_state%IDAT(2) - IDATE(3)=int_state%IDAT(1) - IDATE(4)=int_state%IHRST - IDATE(7)=100 - - NMETAVARI=2 - NMETAVARR=4 - NMETAVARL=1 - - ALLOCATE(VARINAME(NMETAVARI)) - ALLOCATE(VARRNAME(NMETAVARR)) - ALLOCATE(VARLNAME(NMETAVARL)) - - ALLOCATE(VARIVAL(NMETAVARI)) - ALLOCATE(VARRVAL(NMETAVARR)) - ALLOCATE(VARLVAL(NMETAVARL)) - - VARINAME(1)='IM' ; VARIVAL(1)=IDE - VARINAME(2)='JM' ; VARIVAL(2)=JDE - - VARRNAME(1)='TLM0D' ; VARRVAL(1)=INT_STATE%TLM0D - VARRNAME(2)='TPH0D' ; VARRVAL(2)=INT_STATE%TPH0D - VARRNAME(3)='DPHD' ; VARRVAL(3)=INT_STATE%DPHD - VARRNAME(4)='DLMD' ; VARRVAL(4)=INT_STATE%DLMD - - VARLNAME(1)='GLOBAL' ; VARLVAL(1)=INT_STATE%GLOBAL - - - NREC=KK - ALLOCATE(RECNAME(NREC),RECLEVTYP(NREC),RECLEV(NREC)) - FIELDSIZE=IDE*JDE - ALLOCATE(TMP(FIELDSIZE)) - ALLOCATE(GLAT1D(FIELDSIZE),GLON1D(FIELDSIZE)) - GLAT1D=0.0 - GLON1D=0.0 - GLAT1D(1)=int_state%GLAT(1,1) - GLON1D(1)=int_state%GLON(1,1) - - RECNAME(:) = FIELD - RECLEVTYP(:) = 'mid layer' - RECLEV(:) = (/ ( K , K=1,KK) /) - - CALL NEMSIO_OPEN(NEMSIOFILE,trim(FILENAME),'write',iret, & - modelname="NMMB", gdatatype="bin4", idate=IDATE, & - dimx=IDE,dimy=JDE,dimz=KK,nframe=0, & - nmeta=12,nrec=nrec,lon=glon1d,lat=glat1d, & - extrameta=.true., & - nmetavari=NMETAVARI, & - nmetavarr=NMETAVARR, & - nmetavarl=NMETAVARL, & - variname=VARINAME, & - varrname=VARRNAME, & - varlname=VARLNAME, & - varival=VARIVAL, & - varrval=VARRVAL, & - varlval=VARLVAL, & - recname=RECNAME,reclevtyp=RECLEVTYP,reclev=RECLEV) - - if (iret/=0) then - write(0,*)' NEMSIO_OPEN iret /= 0 ',iret - endif - END IF -! -!---------------------------------------------------------------------- - DO 500 K=1,KK -!---------------------------------------------------------------------- -! - IF(MYPE==0)THEN - DO J=JTS,JTE - DO I=ITS,ITE - TWRITE(I,J)=ARRAY(I,J,K) - ENDDO - ENDDO -! - DO IPE=1,NPES-1 - CALL MPI_RECV(IT_REM,2,MPI_INTEGER,IPE,IPE & - ,MPI_COMM_COMP,JSTAT,IRECV) - CALL MPI_RECV(JT_REM,2,MPI_INTEGER,IPE,IPE & - ,MPI_COMM_COMP,JSTAT,IRECV) -! - ITS_REM=IT_REM(1) - ITE_REM=IT_REM(2) - JTS_REM=JT_REM(1) - JTE_REM=JT_REM(2) -! - NSIZE=(ITE_REM-ITS_REM+1)*(JTE_REM-JTS_REM+1) - ALLOCATE(VALUES(1:NSIZE)) -! - CALL MPI_RECV(VALUES,NSIZE,MPI_REAL,IPE,IPE & - ,MPI_COMM_COMP,JSTAT,IRECV) - N=0 - DO J=JTS_REM,JTE_REM - DO I=ITS_REM,ITE_REM - N=N+1 - TWRITE(I,J)=VALUES(N) - ENDDO - ENDDO -! - DEALLOCATE(VALUES) -! - ENDDO - - TMP=RESHAPE(TWRITE,(/FIELDSIZE/)) - CALL NEMSIO_WRITEREC(NEMSIOFILE,K,TMP,IRET=IRET) - if (iret/=0) then - write(0,*)' NEMSIO_WRITEREC iret /= 0 ',iret - endif -! -!---------------------------------------------------------------------- - ELSE -! - NSIZE=(ITE-ITS+1)*(JTE-JTS+1) - ALLOCATE(VALUES(1:NSIZE)) -! - N=0 - DO J=JTS,JTE - DO I=ITS,ITE - N=N+1 - VALUES(N)=ARRAY(I,J,K) - ENDDO - ENDDO -! - IT_REM(1)=ITS - IT_REM(2)=ITE - JT_REM(1)=JTS - JT_REM(2)=JTE -! - CALL MPI_SEND(IT_REM,2,MPI_INTEGER,0,MYPE & - ,MPI_COMM_COMP,ISEND) - CALL MPI_SEND(JT_REM,2,MPI_INTEGER,0,MYPE & - ,MPI_COMM_COMP,ISEND) -! - CALL MPI_SEND(VALUES,NSIZE,MPI_REAL,0,MYPE & - ,MPI_COMM_COMP,ISEND) -! - DEALLOCATE(VALUES) -! - ENDIF -!---------------------------------------------------------------------- -! - CALL MPI_BARRIER(MPI_COMM_COMP,IRTN) -! -! -!---------------------------------------------------------------------- -! - 500 CONTINUE -! -!---------------------------------------------------------------------- -! - IF(MYPE==0)THEN - DEALLOCATE(TMP) - CALL NEMSIO_CLOSE(NEMSIOFILE) - CALL NEMSIO_FINALIZE() - END IF -! -!---------------------------------------------------------------------- -! - END SUBROUTINE NWR -! -!---------------------------------------------------------------------- -!###################################################################### -!---------------------------------------------------------------------- - SUBROUTINE TWR(ARRAY,KK,FIELD,NTSD,MYPE,NPES,MPI_COMM_COMP & - ,IDS,IDE,JDS,JDE & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE & - ,DOMAIN_ID ) -!---------------------------------------------------------------------- -!********************************************************************** -!---------------------------------------------------------------------- - IMPLICIT NONE -!---------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(KIND=KINT),INTENT(IN) :: IDS,IDE,JDS,JDE & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE & - ,KK,MPI_COMM_COMP,MYPE,NPES,NTSD -! - REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME,KK),INTENT(IN) :: ARRAY -! - CHARACTER(*),INTENT(IN) :: FIELD -! - INTEGER(kind=KINT),INTENT(IN),OPTIONAL :: DOMAIN_ID -! -!-------------------- -!*** Local Variables -!-------------------- -! - INTEGER :: IUNIT=23 -! - INTEGER,DIMENSION(MPI_STATUS_SIZE) :: JSTAT - INTEGER,DIMENSION(MPI_STATUS_SIZE,4) :: STATUS_ARRAY - INTEGER(KIND=KINT),DIMENSION(2) :: IM_REM,JM_REM,IT_REM,JT_REM -! - INTEGER(KIND=KINT) :: I,IENDX,IER,IPE,IRECV,IRTN,ISEND & - ,J,K,N,NLEN,NSIZE - INTEGER(KIND=KINT) :: ITS_REM,ITE_REM,JTS_REM,JTE_REM -! - REAL(KIND=KFPT),DIMENSION(IDS:IDE,JDS:JDE) :: TWRITE - REAL(KIND=KFPT),ALLOCATABLE,DIMENSION(:) :: VALUES - CHARACTER(2) :: DOM_ID - CHARACTER(5) :: TIMESTEP - CHARACTER(6) :: FMT - CHARACTER(15) :: FILENAME -! -!---------------------------------------------------------------------- -!********************************************************************** -!---------------------------------------------------------------------- -! - IF(NTSD<=9)THEN - FMT='(I1.1)' - NLEN=1 - ELSEIF(NTSD<=99)THEN - FMT='(I2.2)' - NLEN=2 - ELSEIF(NTSD<=999)THEN - FMT='(I3.3)' - NLEN=3 - ELSEIF(NTSD<=9999)THEN - FMT='(I4.4)' - NLEN=4 - ELSEIF(NTSD<=99999)THEN - FMT='(I5.5)' - NLEN=5 - ENDIF - WRITE(TIMESTEP,FMT)NTSD -! - IF(PRESENT(DOMAIN_ID))THEN - FMT='(I2.2)' - WRITE(DOM_ID,FMT)DOMAIN_ID - FILENAME=FIELD//'_'//'D'//DOM_ID//'_'//TIMESTEP(1:NLEN) - ELSE - FILENAME=FIELD//'_'//TIMESTEP(1:NLEN) - ENDIF -! - IF(MYPE==0)THEN - CLOSE(IUNIT) - OPEN(UNIT=IUNIT,FILE=FILENAME,FORM='UNFORMATTED' & - ,STATUS='REPLACE',IOSTAT=IER) - ENDIF -! -!---------------------------------------------------------------------- - DO 500 K=1,KK -!---------------------------------------------------------------------- -! - IF(MYPE==0)THEN - DO J=JTS,JTE - DO I=ITS,ITE - TWRITE(I,J)=ARRAY(I,J,K) - ENDDO - ENDDO -! - DO IPE=1,NPES-1 - CALL MPI_RECV(IT_REM,2,MPI_INTEGER,IPE,IPE & - ,MPI_COMM_COMP,JSTAT,IRECV) - CALL MPI_RECV(JT_REM,2,MPI_INTEGER,IPE,IPE & - ,MPI_COMM_COMP,JSTAT,IRECV) -! - ITS_REM=IT_REM(1) - ITE_REM=IT_REM(2) - JTS_REM=JT_REM(1) - JTE_REM=JT_REM(2) -! - NSIZE=(ITE_REM-ITS_REM+1)*(JTE_REM-JTS_REM+1) - ALLOCATE(VALUES(1:NSIZE)) -! - CALL MPI_RECV(VALUES,NSIZE,MPI_REAL,IPE,IPE & - ,MPI_COMM_COMP,JSTAT,IRECV) - N=0 - DO J=JTS_REM,JTE_REM - DO I=ITS_REM,ITE_REM - N=N+1 - TWRITE(I,J)=VALUES(N) - ENDDO - ENDDO -! - DEALLOCATE(VALUES) -! - ENDDO -! -!---------------------------------------------------------------------- - ELSE -! - NSIZE=(ITE-ITS+1)*(JTE-JTS+1) - ALLOCATE(VALUES(1:NSIZE)) -! - N=0 - DO J=JTS,JTE - DO I=ITS,ITE - N=N+1 - VALUES(N)=ARRAY(I,J,K) - ENDDO - ENDDO -! - IT_REM(1)=ITS - IT_REM(2)=ITE - JT_REM(1)=JTS - JT_REM(2)=JTE -! - CALL MPI_SEND(IT_REM,2,MPI_INTEGER,0,MYPE & - ,MPI_COMM_COMP,ISEND) - CALL MPI_SEND(JT_REM,2,MPI_INTEGER,0,MYPE & - ,MPI_COMM_COMP,ISEND) -! - CALL MPI_SEND(VALUES,NSIZE,MPI_REAL,0,MYPE & - ,MPI_COMM_COMP,ISEND) -! - DEALLOCATE(VALUES) -! - ENDIF -!---------------------------------------------------------------------- -! - CALL MPI_BARRIER(MPI_COMM_COMP,IRTN) -! - IF(MYPE==0)THEN -! - DO J=JDS,JDE - IENDX=IDE - WRITE(IUNIT)(TWRITE(I,J),I=IDS,IENDX) - ENDDO -! - ENDIF -! -!---------------------------------------------------------------------- - 500 CONTINUE -! - IF(MYPE==0)CLOSE(IUNIT) -!---------------------------------------------------------------------- -! - END SUBROUTINE TWR -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!---------------------------------------------------------------------- - SUBROUTINE VWR(ARRAY,KK,FIELD,NTSD,MYPE,NPES,MPI_COMM_COMP & - ,IDS,IDE,JDS,JDE & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE & - ,DOMAIN_ID ) -!---------------------------------------------------------------------- -!********************************************************************** -!---------------------------------------------------------------------- - IMPLICIT NONE -!---------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(KIND=KINT),INTENT(IN) :: IDS,IDE,JDS,JDE & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE & - ,KK,MPI_COMM_COMP,MYPE,NPES,NTSD -! - REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME,KK),INTENT(IN) :: ARRAY -! - CHARACTER(*),INTENT(IN) :: FIELD -! - INTEGER(kind=KINT),INTENT(IN),OPTIONAL :: DOMAIN_ID -! -!-------------------- -!*** Local Variables -!-------------------- -! - INTEGER :: IUNIT=23 -! - INTEGER,DIMENSION(MPI_STATUS_SIZE) :: JSTAT - INTEGER,DIMENSION(MPI_STATUS_SIZE,4) :: STATUS_ARRAY - INTEGER(KIND=KINT),DIMENSION(2) :: IM_REM,JM_REM,IT_REM,JT_REM -! - INTEGER(KIND=KINT) :: I,IENDX,IER,IPE,IRECV,IRTN,ISEND & - ,J,K,N,NLEN,NSIZE - INTEGER(KIND=KINT) :: ITS_REM,ITE_REM,JTS_REM,JTE_REM -! - REAL(KIND=KFPT),DIMENSION(IDS:IDE,JDS:JDE) :: TWRITE - REAL(KIND=KFPT),ALLOCATABLE,DIMENSION(:) :: VALUES - CHARACTER(2) :: DOM_ID - CHARACTER(5) :: TIMESTEP - CHARACTER(6) :: FMT - CHARACTER(15) :: FILENAME -!---------------------------------------------------------------------- -!********************************************************************** -!---------------------------------------------------------------------- -! - IF(NTSD<=9)THEN - FMT='(I1.1)' - NLEN=1 - ELSEIF(NTSD<=99)THEN - FMT='(I2.2)' - NLEN=2 - ELSEIF(NTSD<=999)THEN - FMT='(I3.3)' - NLEN=3 - ELSEIF(NTSD<=9999)THEN - FMT='(I4.4)' - NLEN=4 - ELSEIF(NTSD<=99999)THEN - FMT='(I5.5)' - NLEN=5 - ENDIF - WRITE(TIMESTEP,FMT)NTSD -! - IF(PRESENT(DOMAIN_ID))THEN - FMT='(I2.2)' - WRITE(DOM_ID,FMT)DOMAIN_ID - FILENAME=FIELD//'_'//'D'//DOM_ID//'_'//TIMESTEP(1:NLEN) - ELSE - FILENAME=FIELD//'_'//TIMESTEP(1:NLEN) - ENDIF -! - IF(MYPE==0)THEN - CLOSE(IUNIT) - OPEN(UNIT=IUNIT,FILE=FILENAME,FORM='UNFORMATTED',IOSTAT=IER) - ENDIF -! -!---------------------------------------------------------------------- - DO 500 K=1,KK -!---------------------------------------------------------------------- -! - IF(MYPE==0)THEN - DO J=JTS,JTE - DO I=ITS,ITE - TWRITE(I,J)=ARRAY(I,J,K) - ENDDO - ENDDO -! - DO IPE=1,NPES-1 - CALL MPI_RECV(IT_REM,2,MPI_INTEGER,IPE,IPE & - ,MPI_COMM_COMP,JSTAT,IRECV) - CALL MPI_RECV(JT_REM,2,MPI_INTEGER,IPE,IPE & - ,MPI_COMM_COMP,JSTAT,IRECV) -! - ITS_REM=IT_REM(1) - ITE_REM=IT_REM(2) - JTS_REM=JT_REM(1) - JTE_REM=JT_REM(2) -! - NSIZE=(ITE_REM-ITS_REM+1)*(JTE_REM-JTS_REM+1) - ALLOCATE(VALUES(1:NSIZE)) -! - CALL MPI_RECV(VALUES,NSIZE,MPI_REAL,IPE,IPE & - ,MPI_COMM_COMP,JSTAT,IRECV) - N=0 - DO J=JTS_REM,JTE_REM - DO I=ITS_REM,ITE_REM - N=N+1 - TWRITE(I,J)=VALUES(N) - ENDDO - ENDDO -! - DEALLOCATE(VALUES) -! - ENDDO -! -!---------------------------------------------------------------------- - ELSE -! - NSIZE=(ITE-ITS+1)*(JTE-JTS+1) - ALLOCATE(VALUES(1:NSIZE)) -! - N=0 - DO J=JTS,JTE - DO I=ITS,ITE - N=N+1 - VALUES(N)=ARRAY(I,J,K) - ENDDO - ENDDO -! - IT_REM(1)=ITS - IT_REM(2)=ITE - JT_REM(1)=JTS - JT_REM(2)=JTE -! - CALL MPI_SEND(IT_REM,2,MPI_INTEGER,0,MYPE & - ,MPI_COMM_COMP,ISEND) - CALL MPI_SEND(JT_REM,2,MPI_INTEGER,0,MYPE & - ,MPI_COMM_COMP,ISEND) -! - CALL MPI_SEND(VALUES,NSIZE,MPI_REAL,0,MYPE & - ,MPI_COMM_COMP,ISEND) -! - DEALLOCATE(VALUES) -! - ENDIF -!---------------------------------------------------------------------- -! - CALL MPI_BARRIER(MPI_COMM_COMP,IRTN) -! - IF(MYPE==0)THEN -! - DO J=JDS,JDE-1 - IENDX=IDE-1 - WRITE(IUNIT)(TWRITE(I,J),I=IDS,IENDX) - ENDDO -! - ENDIF -! -!---------------------------------------------------------------------- -! - 500 CONTINUE -! - IF(MYPE==0)CLOSE(IUNIT) -! -!---------------------------------------------------------------------- -! - END SUBROUTINE VWR -! -!---------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!---------------------------------------------------------------------- - SUBROUTINE LAT_LON_BNDS(ARRAY1,ARRAY2,MYPE,NPES,MPI_COMM_COMP & - ,IDS,IDE,JDS,JDE & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE & - ,DOMAIN_ID ) -!---------------------------------------------------------------------- -!********************************************************************** -!---------------------------------------------------------------------- - IMPLICIT NONE -!---------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(KIND=KINT),INTENT(IN) :: IDS,IDE,JDS,JDE & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE & - ,MPI_COMM_COMP,MYPE,NPES -! - REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: ARRAY1,ARRAY2 -! - INTEGER(kind=KINT),INTENT(IN),OPTIONAL :: DOMAIN_ID -! -!-------------------- -!*** Local Variables -!-------------------- -! - INTEGER :: IUNIT=176 -! - INTEGER,DIMENSION(MPI_STATUS_SIZE) :: JSTAT - INTEGER,DIMENSION(MPI_STATUS_SIZE,4) :: STATUS_ARRAY - INTEGER(KIND=KINT),DIMENSION(2) :: IM_REM,JM_REM,IT_REM,JT_REM -! - INTEGER(KIND=KINT) :: I,IENDX,IER,IPE,IRECV,IRTN,ISEND & - ,J,K,N,NLEN,NSIZE - INTEGER(KIND=KINT) :: ITS_REM,ITE_REM,JTS_REM,JTE_REM -! - REAL(KIND=KFPT):: MINLAT,MAXLAT,MINLON,MAXLON - REAL(KIND=KFPT),DIMENSION(IDS:IDE,JDS:JDE) :: TWRITE - REAL(KIND=KFPT),ALLOCATABLE,DIMENSION(:) :: VALUES - CHARACTER(2) :: DOM_ID - CHARACTER(6) :: FMT - CHARACTER(15) :: FILENAME -! -!---------------------------------------------------------------------- -!********************************************************************** -!---------------------------------------------------------------------- -! - FMT='(I2.2)' - WRITE(DOM_ID,FMT)DOMAIN_ID - FILENAME='lat_lon_bnds_'//DOM_ID -! - IF(MYPE==0)THEN - CLOSE(IUNIT) - OPEN(UNIT=IUNIT,FILE=FILENAME,FORM='UNFORMATTED') - ENDIF -! -!---------------------------------------------------------------------- - DO K=1,2 -!---------------------------------------------------------------------- -! - DO J=JDS,JDE - DO I=IDS,IDE - TWRITE(I,J)=0. - ENDDO - ENDDO -! - IF(MYPE==0)THEN - DO J=JTS,JTE - DO I=ITS,ITE - TWRITE(I,J)=0. - IF(K==1) THEN - TWRITE(I,J)=ARRAY1(I,J) - ELSE - TWRITE(I,J)=ARRAY2(I,J) - ENDIF - ENDDO - ENDDO -! - DO IPE=1,NPES-1 - CALL MPI_RECV(IT_REM,2,MPI_INTEGER,IPE,IPE & - ,MPI_COMM_COMP,JSTAT,IRECV) - CALL MPI_RECV(JT_REM,2,MPI_INTEGER,IPE,IPE & - ,MPI_COMM_COMP,JSTAT,IRECV) -! - ITS_REM=IT_REM(1) - ITE_REM=IT_REM(2) - JTS_REM=JT_REM(1) - JTE_REM=JT_REM(2) -! - NSIZE=(ITE_REM-ITS_REM+1)*(JTE_REM-JTS_REM+1) - ALLOCATE(VALUES(1:NSIZE)) -! - CALL MPI_RECV(VALUES,NSIZE,MPI_REAL,IPE,IPE & - ,MPI_COMM_COMP,JSTAT,IRECV) - N=0 - DO J=JTS_REM,JTE_REM - DO I=ITS_REM,ITE_REM - N=N+1 - TWRITE(I,J)=VALUES(N) - ENDDO - ENDDO -! - DEALLOCATE(VALUES) -! - ENDDO -! -!---------------------------------------------------------------------- - ELSE -! - NSIZE=(ITE-ITS+1)*(JTE-JTS+1) - ALLOCATE(VALUES(1:NSIZE)) -! - N=0 - DO J=JTS,JTE - DO I=ITS,ITE - N=N+1 - IF(K==1) THEN - VALUES(N)=ARRAY1(I,J) - ELSE - VALUES(N)=ARRAY2(I,J) - ENDIF - ENDDO - ENDDO -! - IT_REM(1)=ITS - IT_REM(2)=ITE - JT_REM(1)=JTS - JT_REM(2)=JTE -! - CALL MPI_SEND(IT_REM,2,MPI_INTEGER,0,MYPE & - ,MPI_COMM_COMP,ISEND) - CALL MPI_SEND(JT_REM,2,MPI_INTEGER,0,MYPE & - ,MPI_COMM_COMP,ISEND) -! - CALL MPI_SEND(VALUES,NSIZE,MPI_REAL,0,MYPE & - ,MPI_COMM_COMP,ISEND) -! - DEALLOCATE(VALUES) -! - ENDIF -!---------------------------------------------------------------------- -! - CALL MPI_BARRIER(MPI_COMM_COMP,IRTN) -! - IF(MYPE==0)THEN -! - IF(K==1) THEN - minlat=minval(TWRITE) - maxlat=maxval(TWRITE) - ELSE - minlon=minval(TWRITE) - maxlon=maxval(TWRITE) - ENDIF -! - ENDIF -! -!---------------------------------------------------------------------- - ENDDO -! - IF(MYPE==0)THEN - WRITE(IUNIT)minlat,maxlat,minlon,maxlon - CLOSE(IUNIT) - ENDIF -!---------------------------------------------------------------------- -! - END SUBROUTINE LAT_LON_BNDS -! -!----------------------------------------------------------------------- -!###################################################################### -!---------------------------------------------------------------------- - SUBROUTINE HMAXMIN(ARRAY,KK,FIELD,NTSD,MYPE,NPES,MPI_COMM_COMP & - ,IDS,IDE,JDS,JDE & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE & - ,DOMAIN_ID ) -!---------------------------------------------------------------------- -!********************************************************************** -!---------------------------------------------------------------------- - IMPLICIT NONE -!---------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(KIND=KINT),INTENT(IN) :: IDS,IDE,JDS,JDE & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE & - ,KK,MPI_COMM_COMP,MYPE,NPES,NTSD -! - REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME,KK),INTENT(IN) :: ARRAY -! - CHARACTER(*),INTENT(IN) :: FIELD -! - INTEGER(kind=KINT),INTENT(IN),OPTIONAL :: DOMAIN_ID -! -!-------------------- -!*** Local Variables -!-------------------- -! - INTEGER :: IUNIT=23 -! - INTEGER,DIMENSION(MPI_STATUS_SIZE) :: JSTAT - INTEGER,DIMENSION(MPI_STATUS_SIZE,4) :: STATUS_ARRAY - INTEGER(KIND=KINT),DIMENSION(2) :: IM_REM,JM_REM,IT_REM,JT_REM -! - INTEGER(KIND=KINT) :: I,IENDX,IER,IPE,IRECV,IRTN,ISEND & - ,J,K,N,NSIZE - INTEGER(kind=KINT) :: IMAX,IMIN,JMAX,JMIN - INTEGER(KIND=KINT) :: ITS_REM,ITE_REM,JTS_REM,JTE_REM -! - REAL(KIND=KFPT),DIMENSION(IDS:IDE,JDS:JDE) :: ARRAY_FULL - REAL(KIND=KFPT),ALLOCATABLE,DIMENSION(:) :: VALUES - REAL(kind=KFPT) :: VALMAX,VALMIN -! -!---------------------------------------------------------------------- -!********************************************************************** -!---------------------------------------------------------------------- -! - IF(MYPE==0)THEN - WRITE(0,*)' ' - WRITE(0,11101)FIELD,NTSD,DOMAIN_ID -11101 FORMAT(' For ',A,' at timestep ',I4,' on domain #',I2) - ENDIF -! -!---------------------------------------------------------------------- - DO 500 K=1,KK -!---------------------------------------------------------------------- -! - IF(MYPE==0)THEN - DO J=JTS,JTE - DO I=ITS,ITE - ARRAY_FULL(I,J)=ARRAY(I,J,K) - ENDDO - ENDDO -! - DO IPE=1,NPES-1 - CALL MPI_RECV(IT_REM,2,MPI_INTEGER,IPE,IPE & - ,MPI_COMM_COMP,JSTAT,IRECV) - CALL MPI_RECV(JT_REM,2,MPI_INTEGER,IPE,IPE & - ,MPI_COMM_COMP,JSTAT,IRECV) -! - ITS_REM=IT_REM(1) - ITE_REM=IT_REM(2) - JTS_REM=JT_REM(1) - JTE_REM=JT_REM(2) -! - NSIZE=(ITE_REM-ITS_REM+1)*(JTE_REM-JTS_REM+1) - ALLOCATE(VALUES(1:NSIZE)) -! - CALL MPI_RECV(VALUES,NSIZE,MPI_REAL,IPE,IPE & - ,MPI_COMM_COMP,JSTAT,IRECV) - N=0 - DO J=JTS_REM,JTE_REM - DO I=ITS_REM,ITE_REM - N=N+1 - ARRAY_FULL(I,J)=VALUES(N) - ENDDO - ENDDO -! - DEALLOCATE(VALUES) -! - ENDDO -! -!---------------------------------------------------------------------- - ELSE -! - NSIZE=(ITE-ITS+1)*(JTE-JTS+1) - ALLOCATE(VALUES(1:NSIZE)) -! - N=0 - DO J=JTS,JTE - DO I=ITS,ITE - N=N+1 - VALUES(N)=ARRAY(I,J,K) - ENDDO - ENDDO -! - IT_REM(1)=ITS - IT_REM(2)=ITE - JT_REM(1)=JTS - JT_REM(2)=JTE -! - CALL MPI_SEND(IT_REM,2,MPI_INTEGER,0,MYPE & - ,MPI_COMM_COMP,ISEND) - CALL MPI_SEND(JT_REM,2,MPI_INTEGER,0,MYPE & - ,MPI_COMM_COMP,ISEND) -! - CALL MPI_SEND(VALUES,NSIZE,MPI_REAL,0,MYPE & - ,MPI_COMM_COMP,ISEND) -! - DEALLOCATE(VALUES) -! - ENDIF -!---------------------------------------------------------------------- -! - CALL MPI_BARRIER(MPI_COMM_COMP,IRTN) -! - IF(MYPE==0)THEN -! - VALMAX=-1.E9 - IMAX=0 - JMAX=0 - VALMIN= 1.E9 - IMIN=0 - JMIN=0 -! - DO J=JDS,JDE-1 - DO I=IDS,IDE-1 - IF(ARRAY_FULL(I,J)>VALMAX)THEN - VALMAX=ARRAY_FULL(I,J) - IMAX=I - JMAX=J - ENDIF - IF(ARRAY_FULL(I,J)VALMAX)THEN - VALMAX=ARRAY_FULL(I,J) - IMAX=I - JMAX=J - ENDIF - IF(ARRAY_FULL(I,J)0.) CUREFL=CU_A*CUPRATE**CU_B - ZFRZ=Z(I,J,LM) -! - culoop: IF (CUREFL>0. .AND. NINT(HTOP(I,J)) > 0) THEN - vloop2: DO L=1,LM - IF (T(I,J,L) >= TFRZ) THEN - ZFRZ=Z(I,J,L) - EXIT vloop2 - ENDIF - ENDDO vloop2 -! - LCTOP=NINT(HTOP(I,J)) - ZCTOP=Z(I,J,LCTOP) - Z1KM=ZINTSFC(I,J)+1000. - FCTR=0. -vloop3: IF (ZCTOP >= Z1KM) THEN - DELZ=Z1KM-ZFRZ - IF (DELZ <= 0.) THEN - FCTR=1. !-- Below the highest freezing level - ELSE -! -!--- Reduce convective radar reflectivity above freezing level -! - CUREFL_I=-2./MAX(1000.,ZCTOP-ZFRZ) - FCTR=10.**(CUREFL_I*DELZ) - ENDIF - ENDIF vloop3 - CUREFL=FCTR*CUREFL - ENDIF culoop -! - DO LL=1,2 - IF (C1D(LL) .GE. 1.e-12 .OR. CUREFL .GT. 0.) then - CALL CALMICT(P1D(LL),T1D(LL),Q1D(LL),C1D(LL), & - FI1D(LL),FR1D(LL),FS1D(LL),CUREFL, & - DBZ1(LL), I, J, Ilook, Jlook, MY_DOMAIN_ID) - ELSE - DBZ1(LL)=-20. - ENDIF - ENDDO - FACT=(1000.+ZINTSFC(I,J)-ZMIDloc)/(ZMIDloc-ZMIDP1) - DBZ1avg=DBZ1(2)+(DBZ1(2)-DBZ1(1))*FACT - REFDMAX(I,J)=max(REFDMAX(I,J),DBZ1avg) - ENDDO - ENDDO - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - DO L=1,LM - DO J=JTS,JTE - DO I=ITS,ITE - IF (L >= UPINDX(I,J)) THEN - UPVVELMAX(I,J)=max(UPVVELMAX(I,J),W(I,J,L)) - DNVVELMAX(I,J)=min(DNVVELMAX(I,J),W(I,J,L)) - ENDIF - ENDDO - ENDDO - ENDDO -! - DO J=JTS,JTE - DO I=ITS,ITE - TLMAX(I,J)=MAX(TLMAX(I,J),T(I,J,LM)) !<--- Hourly max lowest layer T - TLMIN(I,J)=MIN(TLMIN(I,J),T(I,J,LM)) !<--- Hourly min lowest layer T - IF (NTSD > 0) THEN - CAPPA_MOIST=RCP*(1.+QSHLTR(I,J)*R_FACTOR)/(1.+QSHLTR(I,J)*CP_FACTOR) - T02=TSHLTR(I,J)*(P00_INV*PSHLTR(I,J))**CAPPA_MOIST - T02MAX(I,J)=MAX(T02MAX(I,J),T02) !<--- Hourly max 2m T - T02MIN(I,J)=MIN(T02MIN(I,J),T02) !<--- Hourly min 2m T -! - VAPOR_PRESS=PSHLTR(I,J)*QSHLTR(I,J)/ & - (EPSILON+QSHLTR(I,J)*ONE_MINUS_EPSILON) -!- FPVS0 - saturation w/r/t liquid water at all temperatures for RH w/r/t water - SAT_VAPOR_PRESS=1.E3*FPVS0(T02) - RH02=MIN(VAPOR_PRESS/SAT_VAPOR_PRESS,0.99) -! - RH02MAX(I,J)=MAX(RH02MAX(I,J),RH02) !<--- Hourly max shelter RH - RH02MIN(I,J)=MIN(RH02MIN(I,J),RH02) !<--- Hourly min shelter RH -! - MAGW2=(U10(I,J)**2.+V10(I,J)**2.) - IF (MAGW2 .gt. SPD10MAX(I,J)) THEN - U10MAX(I,J)=U10(I,J) !<--- U assoc with Hrly max 10m wind speed - V10MAX(I,J)=V10(I,J) !<--- V assoc with Hrly max 10m wind speed - SPD10MAX(I,J)=MAGW2 - ENDIF - ENDIF - ENDDO - ENDDO - - CALL CALC_UPHLCY(U,V,W,Z,ZINTSFC,UPHLMAX,DXH,DYH & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE,IDE,JDE,LM) - - NCOUNT=NCOUNT+1 - DO J=JTS,JTE - DO I=ITS,ITE - TERM=-0.273133/T2(I,J) - P10(I,J)=PSHLTR(I,J)*exp(TERM) - T10(I,J)=TH10(I,J)*(P10(I,J)/1.e5)**RCP - T10AVG(I,J)=T10AVG(I,J)*(NCOUNT-1)+T10(I,J) - T10AVG(I,J)=T10AVG(I,J)/NCOUNT - PSFCAVG(I,J)=PSFCAVG(I,J)*(NCOUNT-1)+PINT(I,J,LM+1) - PSFCAVG(I,J)=PSFCAVG(I,J)/NCOUNT - AKHSAVG(I,J)=AKHSAVG(I,J)*(NCOUNT-1)+AKHS(I,J) - AKHSAVG(I,J)=AKHSAVG(I,J)/NCOUNT - AKMSAVG(I,J)=AKMSAVG(I,J)*(NCOUNT-1)+AKMS(I,J) - AKMSAVG(I,J)=AKMSAVG(I,J)/NCOUNT - IF (SNO(I,J) > 0.) THEN - SNOAVG(I,J)=SNOAVG(I,J)*(NCOUNT-1)+1 - ELSE - SNOAVG(I,J)=SNOAVG(I,J)*(NCOUNT-1) - ENDIF - SNOAVG(I,J)=SNOAVG(I,J)/NCOUNT - ENDDO - ENDDO - -!-- Maximum precipitation rate (total, frozen) - - DO J=JTS,JTE - DO I=ITS,ITE - PRATEMAX(I,J)=MAX(PRATEMAX(I,J),RDTPHS*PREC(I,J) ) - FPRATEMAX(I,J)=MAX(FPRATEMAX(I,J),RDTPHS*SR(I,J)*PREC(I,J) ) - ENDDO - ENDDO - - END SUBROUTINE MAX_FIELDS -! -!---------------------------------------------------------------------- - SUBROUTINE CALC_UPHLCY(U,V,W,Z,ZINTSFC,UPHLMAX,DX,DY & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE,IDE,JDE,LM) - - INTEGER, INTENT(IN) :: IMS,IME,JMS,JME,ITS,ITE - INTEGER, INTENT(IN) :: JTS,JTE,IDE,JDE,LM - REAL,INTENT(IN) :: U(IMS:IME,JMS:JME,LM) - REAL,INTENT(IN) :: V(IMS:IME,JMS:JME,LM) - REAL,INTENT(IN) :: W(IMS:IME,JMS:JME,LM) - REAL,INTENT(IN) :: Z(IMS:IME,JMS:JME,LM) - REAL,INTENT(IN) :: ZINTSFC(IMS:IME,JMS:JME) - REAL,INTENT(INOUT) :: UPHLMAX(IMS:IME,JMS:JME) - REAL,INTENT(IN) :: DX(1:JDE),DY - -! local variables - - REAL :: UPHL (IMS:IME,JMS:JME) - INTEGER :: I,J,L - REAL :: R2DX,R2DY,DZ,ZMIDLOC - REAL :: RD2,RDY,RDX - REAL :: DUDY,DVDX,VM1,VM2,UM1,UM2 - - REAL, PARAMETER:: HLOWER=2000. - REAL, PARAMETER:: HUPPER=5000. - - do J=JMS,JME - do I=IMS,IME - UPHL(I,J)=0. - enddo - enddo - - R2DY=1./(2.*DY) - RDY=2.*R2DY - J_LOOP: DO J=MAX(JTS,2),MIN(JTE,JDE-1) - - IF (DX(J) .LT. 0.1) THEN - CYCLE J_LOOP - ENDIF - - R2DX=1./(2.*DX(J)) - RDX=2.*R2DX - DO I=MAX(ITS,2),MIN(ITE,IDE-1) - L_LOOP: DO L=1,LM-1 - ZMIDLOC=Z(I,J,L) - IF ( (ZMIDLOC - ZINTSFC(I,J)) .ge. HLOWER .AND. & - (ZMIDLOC - ZINTSFC(I,J)) .le. HUPPER ) THEN - DZ=(Z(I,J,L)-Z(I,J,L+1)) -! -!* ANY DOWNWARD MOTION IN 2-5 km LAYER KILLS COMPUTATION AND -!* SETS RESULTANT UPDRAFT HELICTY TO ZERO -! - IF (W(I,J,L) .lt. 0) THEN - UPHL(I,J)=0. - EXIT l_loop - ENDIF - - VM1=0.5*(V(I, J,L)+V(I, J-1,L)) - VM2=0.5*(V(I-1,J,L)+V(I-1,J-1,L)) - DVDX=(VM1-VM2)*RDX - UM1=0.5*(U(I-1, J,L)+U(I,J ,L)) - UM2=0.5*(U(I-1,J-1,L)+U(I,J-1,L)) - DUDY=(UM1-UM2)*RDY - UPHL(I,J)=UPHL(I,J)+(DVDX-DUDY)*W(I,J,L)*DZ - ENDIF - ENDDO L_LOOP - UPHLMAX(I,J)=MAX(UPHL(I,J),UPHLMAX(I,J)) - ENDDO - ENDDO J_LOOP - - END SUBROUTINE CALC_UPHLCY -! -!---------------------------------------------------------------------- -! - SUBROUTINE MAX_FIELDS_HR(T,Q,U & - ,V,CW & - ,F_RAIN,F_ICE & - ,F_RIMEF & - ,Z,W,REFL_10CM & - ,PINT,PD,PREC & - ,CPRATE,HTOP & - ,T2,U10,V10 & - ,PSHLTR,TSHLTR,QSHLTR & - ,SGML2,PSGML1 & - ,REFDMAX,PRATEMAX & - ,FPRATEMAX,SR & - ,UPVVELMAX,DNVVELMAX & - ,TLMAX,TLMIN & - ,T02MAX,T02MIN & - ,RH02MAX,RH02MIN & - ,U10MAX,V10MAX,TH10,T10 & - ,SPD10MAX,T10AVG,PSFCAVG & - ,AKHS,AKMS & - ,AKHSAVG,AKMSAVG & - ,SNO,SNOAVG & - ,UPHLMAX & - ,DT,NPHS,NTSD & - ,DXH,DYH & - ,FIS & - ,ITS,ITE,JTS,JTE & - ,IMS,IME,JMS,JME & - ,IDE,JDE & - ,ITS_B1,ITE_B1 & - ,JTS_B1,JTE_B1 & - ,LM,NCOUNT,FIRST_NMM & - ,MY_DOMAIN_ID ) - - USE MODULE_MP_FER_HIRES, ONLY : FERRIER_INIT_HR, FPVS0 - - IMPLICIT NONE - - INTEGER,INTENT(IN) :: ITS,ITE,JTS,JTE,IMS,IME,JMS,JME,LM,NTSD - INTEGER,INTENT(IN) :: ITS_B1,ITE_B1,JTS_B1,JTE_B1 - INTEGER,INTENT(IN) :: IDE,JDE,NPHS - INTEGER,INTENT(IN) :: MY_DOMAIN_ID - - REAL, DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(IN) :: T, Q, U, V, CW & - ,F_RAIN,F_ICE,F_RIMEF & - ,W,Z,REFL_10CM - - REAL,DIMENSION(IMS:IME,JMS:JME,1:LM+1),INTENT(IN) :: PINT - - REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: PD,PREC,CPRATE,HTOP & - ,T2,U10,V10 & - ,PSHLTR,TSHLTR,QSHLTR & - ,TH10,AKHS & - ,AKMS,SNO,FIS,SR - - REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT):: REFDMAX,PRATEMAX & - ,FPRATEMAX & - ,UPVVELMAX,DNVVELMAX & - ,TLMAX,TLMIN & - ,T02MAX,T02MIN & - ,RH02MAX,RH02MIN & - ,U10MAX,V10MAX & - ,SPD10MAX,T10AVG,PSFCAVG & - ,UPHLMAX,T10,AKHSAVG & - ,AKMSAVG,SNOAVG - - REAL, INTENT(IN) :: DYH, DXH(1:JDE) - LOGICAL,INTENT(INOUT) :: FIRST_NMM - REAL, INTENT(IN) :: SGML2(LM),PSGML1(LM), DT - - INTEGER :: UPINDX(IMS:IME,JMS:JME) - REAL, DIMENSION(IMS:IME,JMS:JME) :: P10 - - REAL, DIMENSION(IMS:IME,JMS:JME) :: ZINTSFC - REAL, DIMENSION(IMS:IME,JMS:JME,LM) :: PMID - - REAL :: PLOW, PUP,WGTa,WGTb,ZMIDloc,ZMIDP1 - REAL :: P1Da,P1Db,P1D(2) - REAL :: T1Da,T1Db,T1D(2),fact - REAL :: Q1Da,Q1Db,Q1D(2) - REAL :: C1Da,C1Db,C1D(2) - REAL :: FR1Da,FR1Db,FR1D(2) - REAL :: FI1Da,FI1Db,FI1D(2) - REAL :: FS1Da,FS1Db,FS1D(2),DBZ1(2),REFL - - REAL :: CUPRATE,CUREFL,CUREFL_I,ZFRZ,DBZ1avg,FCTR,DELZ,Z1KM,ZCTOP - REAL :: T02, RH02, TERM - REAL,SAVE :: CAPPA_MOIST, VAPOR_PRESS, SAT_VAPOR_PRESS - REAL, SAVE:: DTPHS, RDTPHS - REAL :: MAGW2 - - INTEGER :: LCTOP - INTEGER :: I,J,L,NCOUNT,LL, RC, Ilook,Jlook - - -!*** COMPUTE AND SAVE THE FACTORS IN R AND CP TO ACCOUNT FOR -!*** WATER VAPOR IN THE AIR. -!*** -!*** RECALL: R = Rd * (1. + Q * (1./EPSILON - 1.)) -!*** CP = CPd * (1. + Q * (CPv/CPd - 1.)) - - Ilook=99 - Jlook=275 - - DTPHS=DT*NPHS - RDTPHS=3.6e6/DTPHS - - DO L=1,LM - DO J=JTS,JTE - DO I=ITS,ITE - PMID(I,J,L)=PSGML1(L)+SGML2(L)*PD(I,J) - ENDDO - ENDDO - ENDDO -! - DO J=JTS,JTE - DO I=ITS,ITE - ZINTSFC(I,J)=FIS(I,J)/g - ENDDO - ENDDO -! -! WON'T BOTHER TO REBUILD HEIGHTS AS IS DONE IN POST. -! THE NONHYDROSTATIC MID-LAYER Z VALUES MATCH CLOSELY ENOUGH -! AT 1000 m AGL -! - DO J=JTS,JTE - DO I=ITS,ITE - L_LOOP: DO L=1,LM-1 - PLOW= PMID(I,J,L+1) - PUP= PMID(I,J,L) - IF (PLOW .ge. 40000. .and. PUP .le. 40000.) THEN - UPINDX(I,J)=L - exit L_LOOP - ENDIF - ENDDO L_LOOP - ENDDO - ENDDO -! -!xxx DO J=JTS,JTE -!xxx DO I=ITS,ITE - DO J=JTS_B1,JTE_B1 - DO I=ITS_B1,ITE_B1 - vloop: DO L=8,LM-1 - IF ( (Z(I,J,L+1)-ZINTSFC(I,J)) .LE. 1000. & - .AND.(Z(I,J,L)-ZINTSFC(I,J)) .GE. 1000.) THEN - ZMIDP1=Z(I,J,L) - ZMIDloc=Z(I,J,L+1) - P1D(1)=PMID(I,J,L) - P1D(2)=PMID(I,J,L+1) - T1D(1)=T(I,J,L) - T1D(2)=T(I,J,L+1) - Q1D(1)=Q(I,J,L) - Q1D(2)=Q(I,J,L+1) - DBZ1(1)=REFL_10CM(I,J,L) !- dBZ (not Z) values - DBZ1(2)=REFL_10CM(I,J,L+1) !- dBZ values - EXIT vloop - ENDIF - ENDDO vloop -! -!!! INITIAL CUREFL VALUE WITHOUT REDUCTION ABOVE FREEZING LEVEL -! - CUREFL=0. - IF (CPRATE(I,J)>0.) THEN - CUPRATE=RDTPHS*CPRATE(I,J) - CUREFL=CU_A*CUPRATE**CU_B - ENDIF -! -!-- Ignore convective vertical profile effects when the freezing -! level is below 1000 m AGL, approximate using the surface value -! - DO LL=1,2 - REFL=0. - IF (DBZ1(LL)>DBZmin) REFL=10.**(0.1*DBZ1(LL)) - DBZ1(LL)=CUREFL+REFL !- in Z units - ENDDO -!-- Vertical interpolation of Z (units of mm**6/m**3) - FACT=(1000.+ZINTSFC(I,J)-ZMIDloc)/(ZMIDloc-ZMIDP1) - DBZ1avg=DBZ1(2)+(DBZ1(2)-DBZ1(1))*FACT -!-- Convert to dBZ (10*logZ) as the last step - IF (DBZ1avg>ZMIN) THEN - DBZ1avg=10.*ALOG10(DBZ1avg) - ELSE - DBZ1avg=DBZmin - ENDIF - REFDMAX(I,J)=max(REFDMAX(I,J),DBZ1avg) - ENDDO - ENDDO - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - DO L=1,LM - DO J=JTS,JTE - DO I=ITS,ITE - IF (L >= UPINDX(I,J)) THEN - UPVVELMAX(I,J)=max(UPVVELMAX(I,J),W(I,J,L)) - DNVVELMAX(I,J)=min(DNVVELMAX(I,J),W(I,J,L)) - ENDIF - ENDDO - ENDDO - ENDDO -! - DO J=JTS,JTE - DO I=ITS,ITE - TLMAX(I,J)=MAX(TLMAX(I,J),T(I,J,LM)) !<--- Hourly max lowest layer T - TLMIN(I,J)=MIN(TLMIN(I,J),T(I,J,LM)) !<--- Hourly min lowest layer T - IF (NTSD > 0) THEN - CAPPA_MOIST=RCP*(1.+QSHLTR(I,J)*R_FACTOR)/(1.+QSHLTR(I,J)*CP_FACTOR) - T02=TSHLTR(I,J)*(P00_INV*PSHLTR(I,J))**CAPPA_MOIST - T02MAX(I,J)=MAX(T02MAX(I,J),T02) !<--- Hourly max 2m T - T02MIN(I,J)=MIN(T02MIN(I,J),T02) !<--- Hourly min 2m T -! - VAPOR_PRESS=PSHLTR(I,J)*QSHLTR(I,J)/ & - (EPSILON+QSHLTR(I,J)*ONE_MINUS_EPSILON) -!- FPVS0 - saturation w/r/t liquid water at all temperatures - SAT_VAPOR_PRESS=1.E3*FPVS0(T02) - RH02=MIN(VAPOR_PRESS/SAT_VAPOR_PRESS,0.99) -! - RH02MAX(I,J)=MAX(RH02MAX(I,J),RH02) !<--- Hourly max shelter RH - RH02MIN(I,J)=MIN(RH02MIN(I,J),RH02) !<--- Hourly min shelter RH -! - MAGW2=(U10(I,J)**2.+V10(I,J)**2.) - IF (MAGW2 .gt. SPD10MAX(I,J)) THEN - U10MAX(I,J)=U10(I,J) !<--- U assoc with Hrly max 10m wind speed - V10MAX(I,J)=V10(I,J) !<--- V assoc with Hrly max 10m wind speed - SPD10MAX(I,J)=MAGW2 - ENDIF - ENDIF - ENDDO - ENDDO - - CALL CALC_UPHLCY(U,V,W,Z,ZINTSFC,UPHLMAX,DXH,DYH & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE,IDE,JDE,LM) - - NCOUNT=NCOUNT+1 - DO J=JTS,JTE - DO I=ITS,ITE - TERM=-0.273133/T2(I,J) - P10(I,J)=PSHLTR(I,J)*exp(TERM) - T10(I,J)=TH10(I,J)*(P10(I,J)/1.e5)**RCP - T10AVG(I,J)=T10AVG(I,J)*(NCOUNT-1)+T10(I,J) - T10AVG(I,J)=T10AVG(I,J)/NCOUNT - PSFCAVG(I,J)=PSFCAVG(I,J)*(NCOUNT-1)+PINT(I,J,LM+1) - PSFCAVG(I,J)=PSFCAVG(I,J)/NCOUNT - AKHSAVG(I,J)=AKHSAVG(I,J)*(NCOUNT-1)+AKHS(I,J) - AKHSAVG(I,J)=AKHSAVG(I,J)/NCOUNT - AKMSAVG(I,J)=AKMSAVG(I,J)*(NCOUNT-1)+AKMS(I,J) - AKMSAVG(I,J)=AKMSAVG(I,J)/NCOUNT - IF (SNO(I,J) > 0.) THEN - SNOAVG(I,J)=SNOAVG(I,J)*(NCOUNT-1)+1 - ELSE - SNOAVG(I,J)=SNOAVG(I,J)*(NCOUNT-1) - ENDIF - SNOAVG(I,J)=SNOAVG(I,J)/NCOUNT - ENDDO - ENDDO - -!-- Maximum precipitation rate (total, frozen) - - DO J=JTS,JTE - DO I=ITS,ITE - PRATEMAX(I,J)=MAX(PRATEMAX(I,J),RDTPHS*PREC(I,J) ) - FPRATEMAX(I,J)=MAX(FPRATEMAX(I,J),RDTPHS*SR(I,J)*PREC(I,J) ) - ENDDO - ENDDO - - END SUBROUTINE MAX_FIELDS_HR - -!---------------------------------------------------------------------- -! -!---------------------------------------------------------------------- -! - - SUBROUTINE MAX_FIELDS_w6(T,Q,U,V,Z,W & - ,QR,QS,QG,PINT,PD,PREC & - ,CPRATE,HTOP & - ,T2,U10,V10 & - ,PSHLTR,TSHLTR,QSHLTR & - ,SGML2,PSGML1 & - ,REFDMAX,PRATEMAX & - ,FPRATEMAX,SR & - ,UPVVELMAX,DNVVELMAX & - ,TLMAX,TLMIN & - ,T02MAX,T02MIN & - ,RH02MAX,RH02MIN & - ,U10MAX,V10MAX,TH10,T10 & - ,SPD10MAX,T10AVG,PSFCAVG & - ,AKHS,AKMS & - ,AKHSAVG,AKMSAVG & - ,SNO,SNOAVG & - ,UPHLMAX & - ,DT,NPHS,NTSD & - ,DXH,DYH & - ,FIS & - ,ITS,ITE,JTS,JTE & - ,IMS,IME,JMS,JME & - ,IDE,JDE & - ,ITS_B1,ITE_B1 & - ,JTS_B1,JTE_B1 & - ,LM & - ,NCOUNT,FIRST_NMM & - ,MY_DOMAIN_ID) - - IMPLICIT NONE - - INTEGER,INTENT(IN) :: ITS,ITE,JTS,JTE,IMS,IME,JMS,JME,LM,NTSD - INTEGER,INTENT(IN) :: ITS_B1,ITE_B1,JTS_B1,JTE_B1 - INTEGER,INTENT(IN) :: IDE,JDE,NPHS - INTEGER,INTENT(IN) :: MY_DOMAIN_ID - - REAL, DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(IN) :: T,Q,U,V,Z,W - - REAL,DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(INOUT) :: QR,QS,QG - - REAL,DIMENSION(IMS:IME,JMS:JME,1:LM+1),INTENT(IN) :: PINT - - REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: PD,PREC,CPRATE,HTOP & - ,T2,U10,V10 & - ,PSHLTR,TSHLTR,QSHLTR & - ,TH10,AKHS & - ,AKMS,SNO,FIS,SR - - REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT):: REFDMAX,PRATEMAX & - ,FPRATEMAX & - ,UPVVELMAX,DNVVELMAX & - ,TLMAX,TLMIN & - ,T02MAX,T02MIN & - ,RH02MAX,RH02MIN & - ,U10MAX,V10MAX & - ,SPD10MAX,T10AVG,PSFCAVG & - ,UPHLMAX,T10,AKHSAVG & - ,AKMSAVG,SNOAVG - - REAL, INTENT(IN) :: DYH, DXH(1:JDE) - LOGICAL,INTENT(INOUT) :: FIRST_NMM - REAL, INTENT(IN) :: SGML2(LM),PSGML1(LM), DT - - INTEGER :: UPINDX(IMS:IME,JMS:JME) - REAL, DIMENSION(IMS:IME,JMS:JME) :: P10 - - REAL, DIMENSION(IMS:IME,JMS:JME) :: ZINTSFC - REAL, DIMENSION(IMS:IME,JMS:JME,LM) :: PMID - - REAL :: PLOW, PUP,WGTa,WGTb,ZMIDloc,ZMIDP1 - REAL :: P1Da,P1Db,P1D(2) - REAL :: T1Da,T1Db,T1D(2),fact - REAL :: Q1Da,Q1Db,Q1D(2) - REAL :: QQR(2),QQS(2),QQG(2),QPCP,DENS,N0S - REAL :: DBZR,DBZS,DBZG,DBZ1(2) - REAL, PARAMETER :: N0S0=2.E6,N0Smax=1.E11,ALPHA=0.12 & - ,N0G=4.E6,RHOS=100.,RHOG=500.,ZRADR=3.631E9 & - ,DBZmin=-20. - - REAL :: CUPRATE, CUREFL, CUREFL_I, ZFRZ, DBZ1avg, FCTR, DELZ - REAL :: T02, RH02, TERM, TREF - REAL,SAVE :: CAPPA_MOIST, VAPOR_PRESS, SAT_VAPOR_PRESS - REAL, SAVE:: DTPHS, RDTPHS, ZRADS,ZRADG,ZMIN - REAL :: MAGW2 - - INTEGER :: LCTOP - INTEGER :: I,J,L,NCOUNT,LL, RC, Ilook,Jlook - - -!*** COMPUTE AND SAVE THE FACTORS IN R AND CP TO ACCOUNT FOR -!*** WATER VAPOR IN THE AIR. -!*** -!*** RECALL: R = Rd * (1. + Q * (1./EPSILON - 1.)) -!*** CP = CPd * (1. + Q * (CPv/CPd - 1.)) - - Ilook=99 - Jlook=275 - - DTPHS=DT*NPHS - RDTPHS=3.6e6/DTPHS -!-- For calculating radar reflectivity - ZRADS=2.17555E13*RHOS**0.25 - ZRADG=2.17555E13*RHOG**0.25/N0G**0.75 - ZMIN=10.**(0.1*DBZmin) - - DO L=1,LM - DO J=JTS,JTE - DO I=ITS,ITE - PMID(I,J,L)=PSGML1(L)+SGML2(L)*PD(I,J) - ENDDO - ENDDO - ENDDO -! - DO J=JTS,JTE - DO I=ITS,ITE - ZINTSFC(I,J)=FIS(I,J)/g - ENDDO - ENDDO -! -! WON'T BOTHER TO REBUILD HEIGHTS AS IS DONE IN POST. -! THE NONHYDROSTATIC MID-LAYER Z VALUES MATCH CLOSELY ENOUGH -! AT 1000 m AGL -! - DO J=JTS,JTE - DO I=ITS,ITE - L_LOOP: DO L=1,LM-1 - PLOW= PMID(I,J,L+1) - PUP= PMID(I,J,L) - IF (PLOW .ge. 40000. .and. PUP .le. 40000.) THEN - UPINDX(I,J)=L - exit L_LOOP - ENDIF - ENDDO L_LOOP - ENDDO - ENDDO -! -!! DO J=JTS,JTE -!! DO I=ITS,ITE - DO J=JTS_B1,JTE_B1 - DO I=ITS_B1,ITE_B1 - vloop: DO L=8,LM-1 - IF ( (Z(I,J,L+1)-ZINTSFC(I,J)) .LE. 1000. & - .AND.(Z(I,J,L)-ZINTSFC(I,J)) .GE. 1000.) THEN - ZMIDP1=Z(I,J,L) - ZMIDloc=Z(I,J,L+1) - P1D(1)=PMID(I,J,L) - P1D(2)=PMID(I,J,L+1) - T1D(1)=T(I,J,L) - T1D(2)=T(I,J,L+1) - Q1D(1)=Q(I,J,L) - Q1D(2)=Q(I,J,L+1) - QQR(1)=QR(I,J,L) - QQR(2)=QR(I,J,L+1) - QQS(1)=QS(I,J,L) - QQS(2)=QS(I,J,L+1) - QQG(1)=QG(I,J,L) - QQG(2)=QG(I,J,L+1) - EXIT vloop - ENDIF - ENDDO vloop -! -!!! INITIAL CUREFL VALUE WITHOUT REDUCTION ABOVE FREEZING LEVEL -! - CUPRATE=RDTPHS*CPRATE(I,J) - CUREFL=0. - IF (CUPRATE>0.) CUREFL=CU_A*CUPRATE**CU_B -! -!-- Ignore convective vertical profile effects when the freezing -! level is below 1000 m AGL, approximate using the surface value -! - DO LL=1,2 - DBZ1(LL)=CUREFL - QPCP=QQR(LL)+QQS(LL)+QQG(LL) -!-- A higher threshold can be used for calculating radar reflectivities -! above DBZmin=-20 dBZ; note the DBZ arrays below are actually in -! Z units of mm**6/m**3 - IF (QPCP>1.E-8) THEN - DBZR=0. - DBZS=0. - DBZG=0. - DENS=P1D(LL)/(R_D*T1D(LL)*(Q1D(LL)*P608+1.0)) - IF(QQR(LL)>1.E-8) DBZR=ZRADR*((QQR(LL)*DENS)**1.75) - IF(QQS(LL)>1.E-8) THEN - N0S=N0S0*MAX(1., EXP(ALPHA*(TIW-T1D(LL) ) ) ) - N0S=MIN(N0S, N0Smax) - DBZS=ZRADS*((QQS(LL)*DENS)**1.75)/N0S**0.75 - ENDIF - IF(QQG(LL)>1.E-8) DBZG=ZRADG*((QQG(LL)*DENS)**1.75) - DBZ1(LL)=DBZ1(LL)+DBZR+DBZS+DBZG - ENDIF - ENDDO -!-- Vertical interpolation of Z (units of mm**6/m**3) - FACT=(1000.+ZINTSFC(I,J)-ZMIDloc)/(ZMIDloc-ZMIDP1) - DBZ1avg=DBZ1(2)+(DBZ1(2)-DBZ1(1))*FACT -!-- Convert to dBZ (10*logZ) as the last step - IF (DBZ1avg>ZMIN) THEN - DBZ1avg=10.*ALOG10(DBZ1avg) - ELSE - DBZ1avg=DBZmin - ENDIF - REFDMAX(I,J)=max(REFDMAX(I,J),DBZ1avg) - ENDDO - ENDDO - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - DO L=1,LM - DO J=JTS,JTE - DO I=ITS,ITE - IF (L >= UPINDX(I,J)) THEN - UPVVELMAX(I,J)=max(UPVVELMAX(I,J),W(I,J,L)) - DNVVELMAX(I,J)=min(DNVVELMAX(I,J),W(I,J,L)) - ENDIF - ENDDO - ENDDO - ENDDO -! - DO J=JTS,JTE - DO I=ITS,ITE - TLMAX(I,J)=MAX(TLMAX(I,J),T(I,J,LM)) !<--- Hourly max lowest layer T - TLMIN(I,J)=MIN(TLMIN(I,J),T(I,J,LM)) !<--- Hourly min lowest layer T - IF (NTSD > 0) THEN - CAPPA_MOIST=RCP*(1.+QSHLTR(I,J)*R_FACTOR)/(1.+QSHLTR(I,J)*CP_FACTOR) - T02=TSHLTR(I,J)*(P00_INV*PSHLTR(I,J))**CAPPA_MOIST - T02MAX(I,J)=MAX(T02MAX(I,J),T02) !<--- Hourly max 2m T - T02MIN(I,J)=MIN(T02MIN(I,J),T02) !<--- Hourly min 2m T -! - VAPOR_PRESS=PSHLTR(I,J)*QSHLTR(I,J)/ & - (EPSILON+QSHLTR(I,J)*ONE_MINUS_EPSILON) - -!-- Adapted from WSM6 code: - TREF=TTP/T02 - SAT_VAPOR_PRESS=PSAT*EXP(LOG(TREF)*(XA))*EXP(XB*(1.-TREF)) - - RH02=MIN(VAPOR_PRESS/SAT_VAPOR_PRESS,0.99) -! - RH02MAX(I,J)=MAX(RH02MAX(I,J),RH02) !<--- Hourly max shelter RH - RH02MIN(I,J)=MIN(RH02MIN(I,J),RH02) !<--- Hourly min shelter RH -! - MAGW2=(U10(I,J)**2.+V10(I,J)**2.) - IF (MAGW2 .gt. SPD10MAX(I,J)) THEN - U10MAX(I,J)=U10(I,J) !<--- U assoc with Hrly max 10m wind speed - V10MAX(I,J)=V10(I,J) !<--- V assoc with Hrly max 10m wind speed - SPD10MAX(I,J)=MAGW2 - ENDIF - ENDIF - ENDDO - ENDDO - - CALL CALC_UPHLCY(U,V,W,Z,ZINTSFC,UPHLMAX,DXH,DYH & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE,IDE,JDE,LM) - - NCOUNT=NCOUNT+1 - DO J=JTS,JTE - DO I=ITS,ITE - TERM=-0.273133/T2(I,J) - P10(I,J)=PSHLTR(I,J)*exp(TERM) - T10(I,J)=TH10(I,J)*(P10(I,J)/1.e5)**RCP - T10AVG(I,J)=T10AVG(I,J)*(NCOUNT-1)+T10(I,J) - T10AVG(I,J)=T10AVG(I,J)/NCOUNT - PSFCAVG(I,J)=PSFCAVG(I,J)*(NCOUNT-1)+PINT(I,J,LM+1) - PSFCAVG(I,J)=PSFCAVG(I,J)/NCOUNT - AKHSAVG(I,J)=AKHSAVG(I,J)*(NCOUNT-1)+AKHS(I,J) - AKHSAVG(I,J)=AKHSAVG(I,J)/NCOUNT - AKMSAVG(I,J)=AKMSAVG(I,J)*(NCOUNT-1)+AKMS(I,J) - AKMSAVG(I,J)=AKMSAVG(I,J)/NCOUNT - IF (SNO(I,J) > 0.) THEN - SNOAVG(I,J)=SNOAVG(I,J)*(NCOUNT-1)+1 - ELSE - SNOAVG(I,J)=SNOAVG(I,J)*(NCOUNT-1) - ENDIF - SNOAVG(I,J)=SNOAVG(I,J)/NCOUNT - ENDDO - ENDDO - -!-- Maximum precipitation rate (total, frozen) - - DO J=JTS,JTE - DO I=ITS,ITE - PRATEMAX(I,J)=MAX(PRATEMAX(I,J),RDTPHS*PREC(I,J) ) - FPRATEMAX(I,J)=MAX(FPRATEMAX(I,J),RDTPHS*SR(I,J)*PREC(I,J) ) - ENDDO - ENDDO - - END SUBROUTINE MAX_FIELDS_W6 -! -!---------------------------------------------------------------------- -! -!---------------------------------------------------------------------- -! - - SUBROUTINE MAX_FIELDS_THO(T,Q,U,V,Z,W & - ,REFL_10CM,PINT,PD,PREC & - ,CPRATE,HTOP & - ,T2,U10,V10 & - ,PSHLTR,TSHLTR,QSHLTR & - ,SGML2,PSGML1 & - ,REFDMAX,PRATEMAX & - ,FPRATEMAX,SR & - ,UPVVELMAX,DNVVELMAX & - ,TLMAX,TLMIN & - ,T02MAX,T02MIN & - ,RH02MAX,RH02MIN & - ,U10MAX,V10MAX,TH10,T10 & - ,SPD10MAX,T10AVG,PSFCAVG & - ,AKHS,AKMS & - ,AKHSAVG,AKMSAVG & - ,SNO,SNOAVG & - ,UPHLMAX & - ,DT,NPHS,NTSD & - ,DXH,DYH & - ,FIS & - ,ITS,ITE,JTS,JTE & - ,IMS,IME,JMS,JME & - ,IDE,JDE & - ,ITS_B1,ITE_B1 & - ,JTS_B1,JTE_B1 & - ,LM & - ,NCOUNT,FIRST_NMM & - ,MY_DOMAIN_ID) - - USE MODULE_MP_THOMPSON, ONLY : RSLF - - IMPLICIT NONE - - INTEGER,INTENT(IN) :: ITS,ITE,JTS,JTE,IMS,IME,JMS,JME,LM,NTSD - INTEGER,INTENT(IN) :: ITS_B1,ITE_B1,JTS_B1,JTE_B1 - INTEGER,INTENT(IN) :: IDE,JDE,NPHS - INTEGER,INTENT(IN) :: MY_DOMAIN_ID - - REAL, DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(IN) :: T,Q,U,V,Z,W - - REAL,DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(IN) :: REFL_10CM - - REAL,DIMENSION(IMS:IME,JMS:JME,1:LM+1),INTENT(IN) :: PINT - - REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: PD,PREC,CPRATE,HTOP & - ,T2,U10,V10 & - ,PSHLTR,TSHLTR,QSHLTR & - ,TH10,AKHS & - ,AKMS,SNO,FIS,SR - - REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT):: REFDMAX,PRATEMAX & - ,FPRATEMAX & - ,UPVVELMAX,DNVVELMAX & - ,TLMAX,TLMIN & - ,T02MAX,T02MIN & - ,RH02MAX,RH02MIN & - ,U10MAX,V10MAX & - ,SPD10MAX,T10AVG,PSFCAVG & - ,UPHLMAX,T10,AKHSAVG & - ,AKMSAVG,SNOAVG - - REAL, INTENT(IN) :: DYH, DXH(1:JDE) - LOGICAL,INTENT(INOUT) :: FIRST_NMM - REAL, INTENT(IN) :: SGML2(LM),PSGML1(LM), DT - - INTEGER :: UPINDX(IMS:IME,JMS:JME) - REAL, DIMENSION(IMS:IME,JMS:JME) :: P10 - - REAL, DIMENSION(IMS:IME,JMS:JME) :: ZINTSFC - REAL, DIMENSION(IMS:IME,JMS:JME,LM) :: PMID - - REAL :: PLOW, PUP,WGTa,WGTb,ZMIDloc,ZMIDP1 - REAL :: P1Da,P1Db,P1D(2) - REAL :: T1Da,T1Db,T1D(2),fact - REAL :: Q1Da,Q1Db,Q1D(2) - REAL :: QQR(2),QQS(2),QQG(2),QPCP,DENS,N0S - REAL :: REFL,DBZ1(2) - REAL, PARAMETER :: N0S0=2.E6,N0Smax=1.E11,ALPHA=0.12 & - ,N0G=4.E6,RHOS=100.,RHOG=500.,ZRADR=3.631E9 & - ,DBZmin=-20. - - REAL :: CUPRATE, CUREFL, CUREFL_I, ZFRZ, DBZ1avg, FCTR, DELZ - REAL :: T02, RH02, TERM, TREF - REAL,SAVE :: CAPPA_MOIST, QVSHLTR, QVSAT - REAL, SAVE:: DTPHS, RDTPHS, ZRADS,ZRADG,ZMIN - REAL :: MAGW2 - - INTEGER :: LCTOP - INTEGER :: I,J,L,NCOUNT,LL, RC, Ilook,Jlook - - -!*** COMPUTE AND SAVE THE FACTORS IN R AND CP TO ACCOUNT FOR -!*** WATER VAPOR IN THE AIR. -!*** -!*** RECALL: R = Rd * (1. + Q * (1./EPSILON - 1.)) -!*** CP = CPd * (1. + Q * (CPv/CPd - 1.)) - - Ilook=99 - Jlook=275 - - DTPHS=DT*NPHS - RDTPHS=3.6e6/DTPHS -!-- For calculating radar reflectivity - ZMIN=10.**(0.1*DBZmin) - - DO L=1,LM - DO J=JTS,JTE - DO I=ITS,ITE - PMID(I,J,L)=PSGML1(L)+SGML2(L)*PD(I,J) - ENDDO - ENDDO - ENDDO -! - DO J=JTS,JTE - DO I=ITS,ITE - ZINTSFC(I,J)=FIS(I,J)/g - ENDDO - ENDDO -! -! WON'T BOTHER TO REBUILD HEIGHTS AS IS DONE IN POST. -! THE NONHYDROSTATIC MID-LAYER Z VALUES MATCH CLOSELY ENOUGH -! AT 1000 m AGL -! - DO J=JTS,JTE - DO I=ITS,ITE - L_LOOP: DO L=1,LM-1 - PLOW= PMID(I,J,L+1) - PUP= PMID(I,J,L) - IF (PLOW .ge. 40000. .and. PUP .le. 40000.) THEN - UPINDX(I,J)=L - exit L_LOOP - ENDIF - ENDDO L_LOOP - ENDDO - ENDDO -! -!! DO J=JTS,JTE -!! DO I=ITS,ITE - DO J=JTS_B1,JTE_B1 - DO I=ITS_B1,ITE_B1 - vloop: DO L=8,LM-1 - IF ( (Z(I,J,L+1)-ZINTSFC(I,J)) .LE. 1000. & - .AND.(Z(I,J,L)-ZINTSFC(I,J)) .GE. 1000.) THEN - ZMIDP1=Z(I,J,L) - ZMIDloc=Z(I,J,L+1) - P1D(1)=PMID(I,J,L) - P1D(2)=PMID(I,J,L+1) - T1D(1)=T(I,J,L) - T1D(2)=T(I,J,L+1) - Q1D(1)=Q(I,J,L) - Q1D(2)=Q(I,J,L+1) - DBZ1(1)=REFL_10CM(I,J,L) !- dBZ (not Z) values - DBZ1(2)=REFL_10CM(I,J,L+1) !- dBZ values - EXIT vloop - ENDIF - ENDDO vloop -! -!!! INITIAL CUREFL VALUE WITHOUT REDUCTION ABOVE FREEZING LEVEL -! - CUREFL=0. - IF (CPRATE(I,J)>0.) THEN - CUPRATE=RDTPHS*CPRATE(I,J) - CUREFL=CU_A*CUPRATE**CU_B - ENDIF -! -!-- Ignore convective vertical profile effects when the freezing -! level is below 1000 m AGL, approximate using the surface value -! - DO LL=1,2 - REFL=0. - IF (DBZ1(LL)>DBZmin) REFL=10.**(0.1*DBZ1(LL)) - DBZ1(LL)=CUREFL+REFL !- in Z units - ENDDO -!-- Vertical interpolation of Z (units of mm**6/m**3) - FACT=(1000.+ZINTSFC(I,J)-ZMIDloc)/(ZMIDloc-ZMIDP1) - DBZ1avg=DBZ1(2)+(DBZ1(2)-DBZ1(1))*FACT -!-- Convert to dBZ (10*logZ) as the last step - IF (DBZ1avg>ZMIN) THEN - DBZ1avg=10.*ALOG10(DBZ1avg) - ELSE - DBZ1avg=DBZmin - ENDIF - REFDMAX(I,J)=max(REFDMAX(I,J),DBZ1avg) - ENDDO - ENDDO - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - DO L=1,LM - DO J=JTS,JTE - DO I=ITS,ITE - IF (L >= UPINDX(I,J)) THEN - UPVVELMAX(I,J)=max(UPVVELMAX(I,J),W(I,J,L)) - DNVVELMAX(I,J)=min(DNVVELMAX(I,J),W(I,J,L)) - ENDIF - ENDDO - ENDDO - ENDDO -! - DO J=JTS,JTE - DO I=ITS,ITE - TLMAX(I,J)=MAX(TLMAX(I,J),T(I,J,LM)) !<--- Hourly max lowest layer T - TLMIN(I,J)=MIN(TLMIN(I,J),T(I,J,LM)) !<--- Hourly min lowest layer T - IF (NTSD > 0) THEN - CAPPA_MOIST=RCP*(1.+QSHLTR(I,J)*R_FACTOR)/(1.+QSHLTR(I,J)*CP_FACTOR) - T02=TSHLTR(I,J)*(P00_INV*PSHLTR(I,J))**CAPPA_MOIST - T02MAX(I,J)=MAX(T02MAX(I,J),T02) !<--- Hourly max 2m T - T02MIN(I,J)=MIN(T02MIN(I,J),T02) !<--- Hourly min 2m T -! - QVSHLTR=QSHLTR(I,J)/(1.-QSHLTR(I,J)) !<-- 2-m water vapor mixing ratio -! -!-- Adapted from Thompson code: -! - TREF=T02-273.15 - QVSAT=RSLF(PSHLTR(I,J),TREF) -! - RH02=MIN(QVSHLTR/QVSAT,0.99) -! - RH02MAX(I,J)=MAX(RH02MAX(I,J),RH02) !<--- Hourly max shelter RH - RH02MIN(I,J)=MIN(RH02MIN(I,J),RH02) !<--- Hourly min shelter RH -! - MAGW2=(U10(I,J)**2.+V10(I,J)**2.) - IF (MAGW2 .gt. SPD10MAX(I,J)) THEN - U10MAX(I,J)=U10(I,J) !<--- U assoc with Hrly max 10m wind speed - V10MAX(I,J)=V10(I,J) !<--- V assoc with Hrly max 10m wind speed - SPD10MAX(I,J)=MAGW2 - ENDIF - ENDIF - ENDDO - ENDDO - - CALL CALC_UPHLCY(U,V,W,Z,ZINTSFC,UPHLMAX,DXH,DYH & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE,IDE,JDE,LM) - - NCOUNT=NCOUNT+1 - DO J=JTS,JTE - DO I=ITS,ITE - TERM=-0.273133/T2(I,J) - P10(I,J)=PSHLTR(I,J)*exp(TERM) - T10(I,J)=TH10(I,J)*(P10(I,J)/1.e5)**RCP - T10AVG(I,J)=T10AVG(I,J)*(NCOUNT-1)+T10(I,J) - T10AVG(I,J)=T10AVG(I,J)/NCOUNT - PSFCAVG(I,J)=PSFCAVG(I,J)*(NCOUNT-1)+PINT(I,J,LM+1) - PSFCAVG(I,J)=PSFCAVG(I,J)/NCOUNT - AKHSAVG(I,J)=AKHSAVG(I,J)*(NCOUNT-1)+AKHS(I,J) - AKHSAVG(I,J)=AKHSAVG(I,J)/NCOUNT - AKMSAVG(I,J)=AKMSAVG(I,J)*(NCOUNT-1)+AKMS(I,J) - AKMSAVG(I,J)=AKMSAVG(I,J)/NCOUNT - IF (SNO(I,J) > 0.) THEN - SNOAVG(I,J)=SNOAVG(I,J)*(NCOUNT-1)+1 - ELSE - SNOAVG(I,J)=SNOAVG(I,J)*(NCOUNT-1) - ENDIF - SNOAVG(I,J)=SNOAVG(I,J)/NCOUNT - ENDDO - ENDDO - -!-- Maximum precipitation rate (total, frozen) - - DO J=JTS,JTE - DO I=ITS,ITE - PRATEMAX(I,J)=MAX(PRATEMAX(I,J),RDTPHS*PREC(I,J) ) - FPRATEMAX(I,J)=MAX(FPRATEMAX(I,J),RDTPHS*SR(I,J)*PREC(I,J) ) - ENDDO - ENDDO - - END SUBROUTINE MAX_FIELDS_THO -! -!---------------------------------------------------------------------- -! - END MODULE MODULE_DIAGNOSE -! -!---------------------------------------------------------------------- diff --git a/src/nmm/module_DIGITAL_FILTER_NMM.F90 b/src/nmm/module_DIGITAL_FILTER_NMM.F90 deleted file mode 100644 index 2b3e5ba..0000000 --- a/src/nmm/module_DIGITAL_FILTER_NMM.F90 +++ /dev/null @@ -1,806 +0,0 @@ -#define ESMF_ERR_ABORT(rc) if (ESMF_LogFoundError(rc, msg="Aborting NMMB", line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) -!----------------------------------------------------------------------- -! - MODULE module_DIGITAL_FILTER_NMM -! -!----------------------------------------------------------------------- -! -! a generic digital filter for any model under ESMF -! -!----------------------------------------------------------------------- -! March 2007 Hann-Ming Henry Juang -! February 2008 Weiyu Yang, updated to use the ESMF 3.1.0 library. -! February 2011 Weiyu Yang, Updated to use both the ESMF 4.0.0rp2 library, -! ESMF 5 library and the the ESMF 3.1.0rp2 library. -! May 2011 Weiyu Yang, Modified for using the ESMF 5.2.0r_beta_snapshot_07. -! September2011 Weiyu Yang, Modified for using the ESMF 5.2.0r library. -! July 2012 T Black, Modified for generational task usage. -!---------------------------------------------------------------------------- -! - USE ESMF - use module_kinds - use module_exchange,only: halo_exch - - implicit none - - private - - public :: digital_filter_dyn_init_nmm, & - digital_filter_dyn_sum_nmm, & - digital_filter_dyn_average_nmm, & - digital_filter_phy_init_nmm, & - digital_filter_phy_save_nmm, & - digital_filter_phy_restore_nmm - -! --------- -! dynamics -! --------- - character(20), allocatable, save :: name_save_2d(:) - character(20), allocatable, save :: name_save_3d(:) - -! --------- -! physics -! --------- - character(20), allocatable, save :: name_save_2d_phys(:) - character(20), allocatable, save :: name_save_3d_phys(:) - - contains - -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- - subroutine digital_filter_dyn_init_nmm(filt_bundle & - ,ndfistep & - ,dt_int,dt_num,dt_den & - ,its,ite,jts,jte,lm & - ,tot_rank_2d & - ,tot_rank_3d & - ,kstep,nstep & - ,totalsum & - ,dolph_wgts & - ,array_save_2d & - ,array_save_3d ) -!----------------------------------------------------------------------- -! - type(ESMF_FieldBundle),intent(inout) :: filt_bundle - integer(kind=kint), intent(in) :: ndfistep - integer(kind=kint), intent(in) :: dt_int,dt_num,dt_den - integer(kind=kint), intent(in) :: its,ite,jts,jte,lm -! - integer(kind=kint), intent(out) :: kstep,nstep - integer(kind=kint), intent(out) :: tot_rank_2d & - ,tot_rank_3d -! - real(kind=kfpt), dimension(:), pointer, intent(inout) :: dolph_wgts - real(kind=kfpt), dimension(:,:,:), pointer, intent(inout) :: array_save_2d - real(kind=kfpt), dimension(:,:,:,:), pointer, intent(inout) :: array_save_3d -! - real(kind=kfpt), intent(out) :: totalsum -! - integer(kind=kint) :: tmp_rank - integer(kind=kint) :: istat,rc,n,NUM_FIELDS - character(20) :: field_name - real(kind=kfpt) :: taus, dt - type(ESMF_Field) :: tmpfield -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- - nstep = ndfistep - kstep = - nstep -1 - - if (associated(dolph_wgts)) deallocate(dolph_wgts) - allocate(dolph_wgts(-nstep:nstep),stat=istat) - if(istat/=0)then - write(0,*)' DIGITAL_FILTER_DYN_INIT_NMM failed to allocate dolph_wgts stat=',istat - write(0,*)' Aborting!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT,rc=RC); ESMF_ERR_ABORT(RC) - endif - - dt=float(dt_int)+float(dt_num)/float(dt_den) - -! hardwiring cutoff frequency based on length of filtering window - - taus=float(2*ndfistep)*dt -! - CALL dolph(dt,taus,nstep,dolph_wgts) -! - -! Retrieve the dynamical fields to be filtered from the bundle - - CALL ESMF_FieldBundleGet(FIELDBUNDLE = FILT_BUNDLE & !<-- The ESMF Bundle of arrays to be filtered - ,fieldCount = NUM_FIELDS & !<-- # of Fields in the Bundle - ,rc = RC); ESMF_ERR_ABORT(RC) - - tot_rank_2d=0 - tot_rank_3d=0 - - if (.not. allocated(name_save_2d)) & - allocate(name_save_2d(NUM_FIELDS)) - - if (.not. allocated(name_save_3d)) & - allocate(name_save_3d(NUM_FIELDS)) - - DO N=1,NUM_FIELDS - - CALL ESMF_FieldBundleGet(FIELDBUNDLE = FILT_BUNDLE & !<-- The ESMF Bundle of arrays to be filtered - ,fieldIndex = N & - ,field = tmpfield & - ,rc = RC); ESMF_ERR_ABORT(RC) - - CALL ESMF_FieldGet(field=tmpfield, name=field_name, dimCount=tmp_rank, rc=rc); ESMF_ERR_ABORT(RC) -! - IF (tmp_rank == 2) THEN - tot_rank_2d=tot_rank_2d+1 - name_save_2d(tot_rank_2d)=field_name - ENDIF -! - IF (tmp_rank == 3) THEN - tot_rank_3d=tot_rank_3d+1 - name_save_3d(tot_rank_3d)=field_name - ENDIF -! - ENDDO -! - IF (tot_rank_2d > 0 .and. .not. associated(array_save_2d)) THEN - allocate(array_save_2d(ITS:ITE,JTS:JTE,tot_rank_2d),stat=istat) - if(istat/=0)then - write(0,*)' DIGITAL_FILTER_DYN_INIT_NMM failed to allocate array_save_2d stat=',istat - write(0,*)' Aborting!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT,rc=RC); ESMF_ERR_ABORT(RC) - endif - array_save_2d=0. - ENDIF -! - IF (tot_rank_3d > 0 .and. .not. associated(array_save_3d)) THEN - allocate(array_save_3d(ITS:ITE,JTS:JTE,LM+1,tot_rank_3d),stat=istat) - if(istat/=0)then - write(0,*)' DIGITAL_FILTER_DYN_INIT_NMM failed to allocate array_save_3d stat=',istat - write(0,*)' Aborting!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT,rc=RC); ESMF_ERR_ABORT(RC) - endif - array_save_3d=0. - ENDIF -! - totalsum=0. -! -!----------------------------------------------------------------------- -! - end subroutine digital_filter_dyn_init_nmm - -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- - subroutine digital_filter_dyn_sum_nmm(filt_bundle & - ,mean_on & - ,its,ite,jts,jte,lm & - ,tot_rank_2d & - ,tot_rank_3d & - ,kstep,nstep & - ,totalsum & - ,dolph_wgts & - ,array_save_2d & - ,array_save_3d ) -!----------------------------------------------------------------------- - - type(ESMF_FieldBundle),intent(inout) :: filt_bundle - integer(kind=kint),intent(in) :: mean_on,nstep - integer(kind=kint),intent(in) :: its,ite,jts,jte,lm - integer(kind=kint), intent(in) :: tot_rank_2d,tot_rank_3d -! - integer(kind=kint),intent(inout) :: kstep -! - real(kind=kfpt), dimension(:), pointer, intent(in) :: dolph_wgts -! - real(kind=kfpt), intent(inout) :: totalsum -! - real(kind=kfpt), dimension(:,:,:), pointer, intent(inout) :: array_save_2d - real(kind=kfpt), dimension(:,:,:,:), pointer, intent(inout) :: array_save_3d -! - integer(kind=kint) :: i,j,l,n,rc,LDIM - real(kind=kfpt) :: digfil,prod,sx,wx - real(kind=kfpt),dimension(:,:) ,pointer :: hold_2d - real(kind=kfpt),dimension(:,:,:) ,pointer :: hold_3d - logical :: dolph -! - type(ESMF_Field) :: hold_field -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - rc =esmf_success -! - kstep = kstep + 1 - -!----------------------------------------------------------------------- -! Future task: make this dolph switch logical a configure file item -!----------------------------------------------------------------------- - - dolph=.true. - - IF (dolph) THEN - digfil=dolph_wgts(kstep) - - ELSE - sx = acos(-1.)*kstep/nstep - wx = acos(-1.)*kstep/(nstep+1) - if( kstep/=0)then - digfil = sin(wx)/wx*sin(sx)/sx - else - digfil=1. - endif - - if(mean_on>0)then - digfil=1. - endif - - ENDIF -! - totalsum = totalsum + digfil -! - if(tot_rank_2d>0) then - do n=1,tot_rank_2d - NULLIFY(HOLD_2D) - - CALL ESMF_FieldBundleGet(FIELDBUNDLE = FILT_BUNDLE & !<-- The ESMF Bundle of arrays to be filtered - ,fieldName = name_save_2d(N) & - ,field = HOLD_FIELD & - ,rc = RC); ESMF_ERR_ABORT(RC) - - CALL ESMF_FieldGet(field = HOLD_FIELD & !<-- Field that holds the data pointer - ,localDe = 0 & - ,farrayPtr = HOLD_2D & !<-- Put the pointer here - ,rc = RC); ESMF_ERR_ABORT(RC) - - do j=jts,jte - do i=its,ite - array_save_2d(i,j,n)=array_save_2d(i,j,n)+digfil*hold_2d(i,j) - enddo - enddo - enddo - endif -! - if(tot_rank_3d>0)then - do n=1,tot_rank_3d - NULLIFY(HOLD_3D) - - CALL ESMF_FieldBundleGet(FIELDBUNDLE = FILT_BUNDLE & !<-- The ESMF Bundle of arrays to be filtered - ,fieldName = name_save_3d(N) & - ,field = HOLD_FIELD & - ,rc = RC); ESMF_ERR_ABORT(RC) - - CALL ESMF_FieldGet(field = HOLD_FIELD & !<-- Field that holds the data pointer - ,localDe = 0 & - ,farrayPtr = HOLD_3D & !<-- Put the pointer here - ,rc = RC); ESMF_ERR_ABORT(RC) - - LDIM=size(HOLD_3D,dim=3) - - do l=1,LDIM - do j=jts,jte - do i=its,ite - array_save_3d(i,j,l,n)=array_save_3d(i,j,l,n)+digfil*hold_3d(i,j,l) - enddo - enddo - enddo - enddo - endif -! -!----------------------------------------------------------------------- -! - end subroutine digital_filter_dyn_sum_nmm - -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- - subroutine digital_filter_dyn_average_nmm(filt_bundle & - ,its,ite,jts,jte,lm & - ,tot_rank_2d & - ,tot_rank_3d & - ,kstep,nstep & - ,totalsum & - ,array_save_2d & - ,array_save_3d ) -! -!----------------------------------------------------------------------- -! - TYPE(ESMF_FieldBundle),INTENT(INOUT) :: FILT_BUNDLE - INTEGER(kind=KINT),INTENT(IN) :: ITS,ITE,JTS,JTE,LM -! - INTEGER(kind=KINT),INTENT(INOUT) :: TOT_RANK_2D & - ,TOT_RANK_3D -! - INTEGER(kind=KINT),INTENT(OUT) :: KSTEP,NSTEP -! - REAL(kind=KFPT),INTENT(IN) :: TOTALSUM -! - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER,INTENT(INOUT) :: ARRAY_SAVE_2D - REAL(kind=KFPT),DIMENSION(:,:,:,:),POINTER,INTENT(INOUT) :: ARRAY_SAVE_3D -! - INTEGER(KIND=KINT) :: I,J,L,N,RC,LDIM - REAL(KIND=KFPT),DIMENSION(:,:) ,POINTER :: HOLD_2D - REAL(KIND=KFPT),DIMENSION(:,:,:) ,POINTER :: HOLD_3D -! - CHARACTER(20) :: FIELD_NAME -! - TYPE(ESMF_Field) :: HOLD_FIELD -! - REAL(KIND=KFPT) :: totalsumi -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS -! - totalsumi = 1.0 / totalsum - - IF (tot_rank_2d > 0) THEN - DO N=1,tot_rank_2d - DO J=JTS,JTE - DO I=ITS,ITE - array_save_2d(I,J,N)=totalsumi*array_save_2d(I,J,N) - ENDDO - ENDDO - ENDDO - ENDIF -! - IF (tot_rank_3d > 0) THEN - DO N=1,tot_rank_3d - FIELD_NAME=name_save_3d(N) - - IF (FIELD_NAME == 'PINT') THEN - LDIM=LM+1 - ELSE - LDIM=LM - ENDIF - - DO L=1,LDIM - DO J=JTS,JTE - DO I=ITS,ITE - array_save_3d(I,J,L,N)=totalsumi*array_save_3d(I,J,L,N) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF (tot_rank_2d > 0) THEN - DO N=1,tot_rank_2d - NULLIFY(HOLD_2D) - - CALL ESMF_FieldBundleGet(FIELDBUNDLE = FILT_BUNDLE & !<-- The ESMF Bundle of arrays to be filtered - ,fieldName = name_save_2d(N) & - ,field = HOLD_FIELD & - ,rc = RC); ESMF_ERR_ABORT(RC) - - CALL ESMF_FieldGet(field = HOLD_FIELD & !<-- Field that holds the data pointer - ,localDe = 0 & - ,farrayPtr = HOLD_2D & !<-- Put the pointer here - ,rc = RC); ESMF_ERR_ABORT(RC) - - DO J=JTS,JTE - DO I=ITS,ITE - HOLD_2D(I,J)=array_save_2d(I,J,N) - ENDDO - ENDDO - - CALL HALO_EXCH(hold_2d,1,2,2) - ENDDO - ENDIF -! - IF (tot_rank_3d > 0) THEN - DO N=1,tot_rank_3d - NULLIFY(HOLD_3D) - - CALL ESMF_FieldBundleGet(FIELDBUNDLE = FILT_BUNDLE & !<-- The ESMF Bundle of arrays to be filtered - ,fieldName = name_save_3d(N) & - ,field = HOLD_FIELD & - ,rc = RC); ESMF_ERR_ABORT(RC) - - CALL ESMF_FieldGet(field = HOLD_FIELD & !<-- Field that holds the data pointer - ,localDe = 0 & - ,farrayPtr = HOLD_3D & !<-- Put the pointer here - ,rc = RC); ESMF_ERR_ABORT(RC) - - LDIM=size(HOLD_3D,dim=3) - - DO L=1,LDIM - DO J=JTS,JTE - DO I=ITS,ITE - HOLD_3D(I,J,L)=array_save_3d(I,J,L,N) - ENDDO - ENDDO - ENDDO - - CALL HALO_EXCH(hold_3d,LDIM,2,2) - ENDDO - ENDIF -! - IF (tot_rank_2d > 0) THEN - deallocate(array_save_2d) - ENDIF - - IF (tot_rank_3d > 0) THEN - deallocate(array_save_3d) - ENDIF - - tot_rank_2d=0 - tot_rank_3d=0 - kstep=0 - nstep=0 - -!----------------------------------------------------------------------- - end subroutine digital_filter_dyn_average_nmm -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- - subroutine digital_filter_phy_init_nmm(filt_bundle & - ,its,ite,jts,jte,lm & - ,tot_rank_2d_phys & - ,tot_rank_3d_phys & - ,array_save_2d_phys & - ,array_save_3d_phys ) -!----------------------------------------------------------------------- - TYPE(ESMF_FieldBundle),INTENT(INOUT) :: FILT_BUNDLE - INTEGER(kind=KINT),INTENT(IN) :: ITS,ITE,JTS,JTE,LM -! - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER,INTENT(INOUT) :: ARRAY_SAVE_2D_PHYS - REAL(kind=KFPT),DIMENSION(:,:,:,:),POINTER,INTENT(INOUT) :: ARRAY_SAVE_3D_PHYS -! - INTEGER(kind=KINT),INTENT(OUT) :: TOT_RANK_2D_PHYS & - ,TOT_RANK_3D_PHYS -! - TYPE(ESMF_Field) :: tmpfield - integer :: istat, rc, NUM_FIELDS, n, tmp_rank - character(len=20) :: field_name -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- - -! Retrieve the dynamical fields to be filtered from the bundle - - CALL ESMF_FieldBundleGet(FIELDBUNDLE = FILT_BUNDLE & !<-- The ESMF Bundle of arrays to be filtered - ,fieldCount = NUM_FIELDS & !<-- # of Fields in the Bundle - ,rc = RC); ESMF_ERR_ABORT(RC) -! - tot_rank_2d_phys=0 - tot_rank_3d_phys=0 - - if (.not. allocated(name_save_2d_phys)) & - allocate(name_save_2d_phys(NUM_FIELDS)) - - if (.not. allocated(name_save_3d_phys)) & - allocate(name_save_3d_phys(NUM_FIELDS)) - - DO N=1,NUM_FIELDS - - CALL ESMF_FieldBundleGet(FIELDBUNDLE = FILT_BUNDLE & !<-- The ESMF Bundle of arrays to be filtered - ,fieldindex = N & - ,field = tmpfield & - ,rc = RC); ESMF_ERR_ABORT(RC) - - CALL ESMF_FieldGet(field=tmpfield, name=field_name, dimCount=tmp_rank, rc=rc); ESMF_ERR_ABORT(RC) -! - IF (tmp_rank == 2) THEN - tot_rank_2d_phys=tot_rank_2d_phys+1 - name_save_2d_phys(tot_rank_2d_phys)=field_name - ENDIF -! - IF (tmp_rank == 3) THEN - tot_rank_3d_phys=tot_rank_3d_phys+1 - name_save_3d_phys(tot_rank_3d_phys)=field_name - ENDIF -! - ENDDO -! - IF (tot_rank_2d_phys > 0 .and. .not. associated(array_save_2d_phys)) THEN - allocate(array_save_2d_phys(ITS:ITE,JTS:JTE,tot_rank_2d_phys),stat=istat) - if(istat/=0)then - write(0,*)' DIGITAL_FILTER_PHY_INIT_NMM failed to allocate array_save_2d_phys stat=',istat - write(0,*)' Aborting!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT,rc=RC); ESMF_ERR_ABORT(RC) - endif - array_save_2d_phys=0. - ENDIF -! - IF (tot_rank_3d_phys > 0 .and. .not. associated(array_save_3d_phys)) THEN - allocate(array_save_3d_phys(ITS:ITE,JTS:JTE,LM,tot_rank_3d_phys),stat=istat) - if(istat/=0)then - write(0,*)' DIGITAL_FILTER_PHY_INIT_NMM failed to allocate array_save_3d_phys stat=',istat - write(0,*)' Aborting!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT,rc=RC); ESMF_ERR_ABORT(RC) - endif - array_save_3d_phys=0. - ENDIF -! -!----------------------------------------------------------------------- -! - end subroutine digital_filter_phy_init_nmm - -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- - subroutine digital_filter_phy_save_nmm(filt_bundle & - ,its,ite,jts,jte & - ,tot_rank_2d_phys & - ,tot_rank_3d_phys & - ,array_save_2d_phys & - ,array_save_3d_phys ) -! -!----------------------------------------------------------------------- -! - TYPE(ESMF_FieldBundle),INTENT(INOUT) :: FILT_BUNDLE - INTEGER(kind=KINT),INTENT(IN) :: ITS,ITE,JTS,JTE - INTEGER(kind=KINT),INTENT(IN) :: TOT_RANK_2D_PHYS & - ,TOT_RANK_3D_PHYS -! - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER,INTENT(INOUT) :: ARRAY_SAVE_2D_PHYS - REAL(kind=KFPT),DIMENSION(:,:,:,:),POINTER,INTENT(INOUT) :: ARRAY_SAVE_3D_PHYS -! - TYPE(ESMF_Field) :: HOLD_FIELD - integer :: n, rc, i,j,l, LDIM - REAL(KIND=KFPT),DIMENSION(:,:) ,POINTER :: HOLD_2D - REAL(KIND=KFPT),DIMENSION(:,:,:) ,POINTER :: HOLD_3D -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - if(tot_rank_2d_phys>0) then - do n=1,tot_rank_2d_phys - nullify(hold_2d) - - CALL ESMF_FieldBundleGet(FIELDBUNDLE = FILT_BUNDLE & !<-- The ESMF Bundle of arrays to be filtered - ,fieldName = name_save_2d_phys(N) & - ,field = HOLD_FIELD & - ,rc = RC); ESMF_ERR_ABORT(RC) - - CALL ESMF_FieldGet(field = HOLD_FIELD & !<-- Field that holds the data pointer - ,localDe = 0 & - ,farrayPtr = HOLD_2D & !<-- Put the pointer here - ,rc = RC); ESMF_ERR_ABORT(RC) - - do j=jts,jte - do i=its,ite - array_save_2d_phys(i,j,n)=hold_2d(i,j) - enddo - enddo - - enddo - endif - - if(tot_rank_3d_phys>0)then - do n=1,tot_rank_3d_phys - nullify(hold_3d) - - CALL ESMF_FieldBundleGet(FIELDBUNDLE = FILT_BUNDLE & !<-- The ESMF Bundle of arrays to be filtered - ,fieldName = name_save_3d_phys(N) & - ,field = HOLD_FIELD & - ,rc = RC); ESMF_ERR_ABORT(RC) - - CALL ESMF_FieldGet(field = HOLD_FIELD & !<-- Field that holds the data pointer - ,localDe = 0 & - ,farrayPtr = HOLD_3D & !<-- Put the pointer here - ,rc = RC); ESMF_ERR_ABORT(RC) - - LDIM=size(HOLD_3D,dim=3) - - do l=1, LDIM - do j=jts,jte - do i=its,ite - array_save_3d_phys(i,j,l,n)=hold_3d(i,j,l) - enddo - enddo - enddo - enddo -! - endif -! -!----------------------------------------------------------------------- -! - end subroutine digital_filter_phy_save_nmm - -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- - subroutine digital_filter_phy_restore_nmm( FILT_BUNDLE & - ,its,ite,jts,jte & - ,tot_rank_2d_phys & - ,tot_rank_3d_phys & - ,array_save_2d_phys & - ,array_save_3d_phys ) -! -!----------------------------------------------------------------------- -! - TYPE(ESMF_FieldBundle),INTENT(INOUT) :: FILT_BUNDLE - INTEGER(kind=KINT),INTENT(IN) :: ITS,ITE,JTS,JTE - INTEGER(kind=KINT),INTENT(IN) :: TOT_RANK_2D_PHYS & - ,TOT_RANK_3D_PHYS -! - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER,INTENT(INOUT) :: ARRAY_SAVE_2D_PHYS - REAL(kind=KFPT),DIMENSION(:,:,:,:),POINTER,INTENT(INOUT) :: ARRAY_SAVE_3D_PHYS -! - TYPE(ESMF_Field) :: HOLD_FIELD - INTEGER(KIND=KINT) :: I,J,L,N,RC,LDIM - REAL(KIND=KFPT),DIMENSION(:,:) ,POINTER :: HOLD_2D - REAL(KIND=KFPT),DIMENSION(:,:,:) ,POINTER :: HOLD_3D -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - IF (tot_rank_2d_phys > 0) THEN - DO N=1,tot_rank_2d_phys - NULLIFY(HOLD_2D) - - CALL ESMF_FieldBundleGet(FIELDBUNDLE = FILT_BUNDLE & !<-- The ESMF Bundle of arrays to be filtered - ,fieldName = name_save_2d_phys(N) & - ,field = HOLD_FIELD & - ,rc = rc); ESMF_ERR_ABORT(RC) - - CALL ESMF_FieldGet(field = HOLD_FIELD & !<-- Field that holds the data pointer - ,localDe = 0 & - ,farrayPtr = HOLD_2D & !<-- Put the pointer here - ,rc = RC); ESMF_ERR_ABORT(RC) - - DO J=JTS,JTE - DO I=ITS,ITE - HOLD_2D(I,J)=array_save_2d_phys(I,J,N) - ENDDO - ENDDO - - CALL HALO_EXCH(HOLD_2D,1,2,2) - - ENDDO - ENDIF - - IF (tot_rank_3d_phys > 0) THEN - DO N=1,tot_rank_3d_phys - NULLIFY(HOLD_3D) - - CALL ESMF_FieldBundleGet(FIELDBUNDLE = FILT_BUNDLE & !<-- The ESMF Bundle of arrays to be filtered - ,fieldName = name_save_3d_phys(N) & - ,field = HOLD_FIELD & - ,rc = rc); ESMF_ERR_ABORT(RC) - - CALL ESMF_FieldGet(field = HOLD_FIELD & !<-- Field that holds the data pointer - ,localDe = 0 & - ,farrayPtr = HOLD_3D & !<-- Put the pointer here - ,rc = RC); ESMF_ERR_ABORT(RC) -! - LDIM=size(HOLD_3D,dim=3) -! - DO L=1,LDIM - DO J=JTS,JTE - DO I=ITS,ITE - HOLD_3D(I,J,L)=array_save_3d_phys(I,J,L,N) - ENDDO - ENDDO - ENDDO - - CALL HALO_EXCH(HOLD_3D,LDIM,2,2) - - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -! - end subroutine digital_filter_phy_restore_nmm - -!----------------------------------------------------------------------- - - SUBROUTINE dolph(deltat, taus, m, window) - -! calculation of dolph-chebyshev window or, for short, -! dolph window, using the expression in the reference: -! -! antoniou, andreas, 1993: digital filters: analysis, -! design and applications. mcgraw-hill, inc., 689pp. -! -! the dolph window is optimal in the following sense: -! for a given main-lobe width, the stop-band attenuation -! is minimal; for a given stop-band level, the main-lobe -! width is minimal. - - IMPLICIT NONE - - ! Arguments - INTEGER, INTENT(IN) :: m - REAL, DIMENSION(0:2*M), INTENT(OUT) :: window - REAL, INTENT(IN) :: deltat, taus - - ! local data - integer, PARAMETER :: NMAX = 5000 - REAL, dimension(0:NMAX) :: t, w, time - real, dimension(0:2*nmax) :: w2 - INTEGER :: NPRPE=0 ! no of pe - - real :: pi, thetas, x0, term1, term2, rr, r,db, sum, arg, sumw - integer :: n, nm1, i, nt - - PI = 4*ATAN(1.D0) - -! print *, 'in dfcoef, deltat = ', deltat, 'taus=',taus - - N = 2*M+1 - NM1 = N-1 - - THETAS = 2*PI*ABS(DELTAT/TAUS) - X0 = 1/COS(THETAS/2) - TERM1 = (X0 + SQRT(X0**2-1))**(FLOAT(N-1)) - TERM2 = (X0 - SQRT(X0**2-1))**(FLOAT(N-1)) - RR = 0.5*(TERM1+TERM2) - R = 1/RR - DB = 20*LOG10(R) - - -! WRITE(0,'(1X,''DOLPH: M,N='',2I8)')M,N -! WRITE(0,'(1X,''DOLPH: THETAS (STOP-BAND EDGE)='',F10.3)')THETAS -! WRITE(0,'(1X,''DOLPH: R,DB='',2F10.3)')R, DB - - DO NT=0,M - SUM = 1 - DO I=1,M - ARG = X0*COS(I*PI/N) - CALL CHEBY(T,NM1,ARG) - TERM1 = T(NM1) - TERM2 = COS(2*NT*PI*I/N) - SUM = SUM + R*2*TERM1*TERM2 - ENDDO - W(NT) = SUM/N - TIME(NT) = NT - ENDDO -! fill in the negative-time values by symmetry. - DO NT=0,M - W2(M+NT) = W(NT) - W2(M-NT) = W(NT) - ENDDO - -! fill up the array for return - SUMW = 0. - DO NT=0,2*M - SUMW = SUMW + W2(NT) - ENDDO -! WRITE(0,'(1X,''DOLPH: SUM OF WEIGHTS W2='',F10.4)')SUMW - - DO NT=0,2*M - WINDOW(NT) = W2(NT) - ENDDO - - RETURN - - END SUBROUTINE dolph - - - SUBROUTINE cheby(t, n, x) - -! calculate all chebyshev polynomials up to order n -! for the argument value x. - -! reference: numerical recipes, page 184, recurrence -! t_n(x) = 2xt_{n-1}(x) - t_{n-2}(x) , n>=2. - - IMPLICIT NONE - - ! Arguments - INTEGER, INTENT(IN) :: n - REAL, INTENT(IN) :: x - REAL, DIMENSION(0:N) :: t - - integer :: nn - - T(0) = 1 - T(1) = X - IF(N.LT.2) RETURN - DO NN=2,N - T(NN) = 2*X*T(NN-1) - T(NN-2) - ENDDO - - RETURN - - END SUBROUTINE cheby - - end module module_digital_filter_nmm -! -!----------------------------------------------------------------------- - diff --git a/src/nmm/module_DM_PARALLEL.F90 b/src/nmm/module_DM_PARALLEL.F90 deleted file mode 100644 index 59f3b1d..0000000 --- a/src/nmm/module_DM_PARALLEL.F90 +++ /dev/null @@ -1,1981 +0,0 @@ -!----------------------------------------------------------------------- - module module_dm_parallel -!----------------------------------------------------------------------- -! -!*** This module contains all codes directly related to distributed -!*** memory issues except for halo exchange although note that the -!*** halo widths must be set here. -! -!----------------------------------------------------------------------- -! - use mpi -! - use module_kinds -! -!----------------------------------------------------------------------- -! - implicit none -! -!----------------------------------------------------------------------- -!---domain decomposition info------------------------------------------- -!----------------------------------------------------------------------- -! -integer(kind=kint),parameter :: & -! - ihalo=3 & ! halo width in I direction -,jhalo=3 & ! halo width in J direction -! -!*** Hardwire to 100 the maximum number of server groups allowed. -!*** This is far greater than should ever be needed. -! -,max_groups=100 & ! max number of quilt server groups -! -!*** For now, set the number of threads here to 1. -!*** Clearly, this must be reconciled before actually using threading. -! -,num_tiles=1 ! number of threads -! -!----------------------------------------------------------------------- -integer(kind=kint) :: & - ide & ! ending data index, x direction -,ids & ! starting data index, x direction -,ims & ! the starting memory I for each task -,ime & ! the ending memory I for each task -,its & ! the starting integration I for each task -,ite & ! the ending integration I for each task -,jde & ! ending data index, y direction -,jds & ! starting data index, y direction -,jms & ! the starting memory J for each task -,jme & ! the ending memory J for each task -,jts & ! the starting integration J for each task -,jte & ! the ending integration J for each task -,lm & ! the number of atmospheric model layers -,mpi_comm_comp & ! local mpi communicator -,mpi_comm_inter & ! intercommunicator for the quilt/write tasks -,mype_share & ! my task ID to be seen by any USEs -,npes & ! total number of forecast tasks after SETUP_SERVERS -! -,num_pts_max ! max points in any task's subdomain -! -integer(kind=kint) :: & - its_b1 & ! its AND 1 point from global boundary -,its_b2 & ! its AND 2 points from global boundary -,its_h1 & ! its AND 1 point into halo -,its_h2 & ! its AND 2 points into halo -,its_b1_h1 & ! its AND _b1 AND _h1 -,its_b1_h2 & ! its AND _b1 AND _h2 -,ite_b1 & ! ite AND 1 point from global boundary -,ite_b2 & ! ite AND 2 points from global boundary -,ite_h1 & ! ite AND 1 point into halo -,ite_h2 & ! ite AND 2 points into halo -,ite_b1_h1 & ! ite AND _b1 AND _h1 -,ite_b1_h2 & ! ite AND _b1 AND _h2 -,jts_b1 & ! jts AND 1 point from global boundary -,jts_b2 & ! jts AND 2 points from global boundary -,jts_h1 & ! jts AND 1 point into halo -,jts_h2 & ! jts AND 2 points into halo -,jts_b1_h1 & ! jts AND _b1 AND _h1 -,jts_b1_h2 & ! jts AND _b1 AND _h2 -,jte_b1 & ! jte AND 1 point from global boundary -,jte_b2 & ! jte AND 2 points from global boundary -,jte_h1 & ! jte AND 1 point into halo -,jte_h2 & ! jte AND 2 points into halo -,jte_b1_h1 & ! jte AND _b1 AND _h1 -,jte_b1_h2 ! jte AND _b1 AND _h2 -! -integer(kind=kint) :: & - ide_m1 & -,ide_m2 & -,ids_p1 & -,jde_m1 & -,jde_m2 & -,jds_p1 -integer(kind=kint),dimension(8) :: & - my_neb ! my task's eight neighbors -! -integer(kind=kint),dimension(max_groups) :: & - mpi_intercomm_array & ! intercommunicators for the integration tasks -,num_serv_per_grp ! number of tasks in each group -! -integer(kind=kint),allocatable,dimension(:) :: & - local_iend & -,local_istart & -,local_jend & -,local_jstart -! -integer :: mpi_intra -!----------------------------------------------------------------------- -! - contains -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - subroutine setup_servers(mype,inpes,jnpes,npes & - ,ngroups_write,write_tasks_per_group & - ,mpi_intra,quilting) -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!*** SETUP_SERVERS splits the communicator between integration -!*** and output tasks. -! -!----------------------------------------------------------------------- -! -! input argument list: -! mype - The fsct/quilt task rank in the domain intracommunicator. -! inpes - Number of mpi tasks in the X direction -! jnpes - Number of mpi tasks in the Y direction -! npes - Total number of mpi tasks provided to the job. As input -! to SETUP_SERVERS it includes the forecast tasks plus all -! write tasks in all groups of write tasks. npes must at least -! equal the product of inpes*jnpes otherwise the integration -! cannot proceed. The difference between the product npes_fcst -! and npes is the number of mpi tasks that are available -! for i/o serving. This can be zero, in which case output will -! write a direct access file that can be separately quilted. -! In order to skip the separate quilting step, make sure that -! the number of mpi tasks that the code is initiated with is at -! least one greater than npes_fcst. -! Later in the routine, npes is reset to the number of fcst tasks. -! ngroups_write - Number of groups of write tasks. -! mpi_intra - The domain intracommunicator. -! write_tasks_per_group - # of write tasks per write group -! -!----------------------------------------------------------------------- -!*** Argument variables. -!----------------------------------------------------------------------- -! - integer(kind=kint),intent(in) :: & - mype & ! each task's ID -,inpes & ! number of compute tasks in X direction -,jnpes & ! number of compute tasks in Y direction -,ngroups_write & ! number of groups of write tasks -,write_tasks_per_group & ! number of groups of write tasks per group -,mpi_intra ! global communicator -! - logical(kind=klog),intent(in) :: & -quilting ! has output via quilting been specified? -! - integer(kind=kint),intent(inout) :: & - npes ! total number of tasks provided - ! then converted to the number of fcst tasks -!----------------------------------------------------------------------- -!*** Local variables. -!----------------------------------------------------------------------- -! - integer(kind=kint) :: comdup,i,icc,icolor,iendq,iendxx,ierr & - ,igroup,igroup_x,iqserver,iquilt_group & - ,iss,issl & - ,istaq,istaxx,iworld,iworld_minus,ixx,jj,kk & - ,lead_remote,npes_fcst,one -! - integer(kind=kint),allocatable,dimension(:) :: irank -! - logical :: include_mype -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! -!*** Let npes_fcst be the product of inpes and jnpes (namelist variables). -!*** This is the number of mpi tasks the executable has been built for. -!*** npes, returned from mpi_comm_size, must be at least this size -!*** otherwise the integration cannot proceed. The difference between -!*** npes_fcst and npes is the number of mpi tasks that are available -!*** for quilt/write serving. This can be zero, in which case output will -!*** write a direct access file that can be separately quilted. -!*** In order to skip the separate quilting step, make sure that -!*** the number of mpi tasks that the code is initiated with is at -!*** least one greater than npes_fcst. -! -!----------------------------------------------------------------------- -! -!!! mype=mype_share - npes_fcst=inpes*jnpes - mpi_comm_comp=mpi_intra !<-- Set mpi_comm_comp to the global communicator -! - if(.not.quilting)then - return !<-- If no output then nothing else to do. - endif -! -!----------------------------------------------------------------------- -! -!*** At this point npes is the total number of mpi tasks. We will -!*** reset this at the end of the subroutine to the number of mpi -!*** tasks that are working on the model integration. -! -!*** First, however, we need to make sure that a sufficient number -!*** of mpi tasks have been initiated. If not, we will stop. -! -!----------------------------------------------------------------------- -!*** Compare the total number of MPI tasks (npes) to the number -!*** specified for the forecast integration (npes_fcst=inpes*jnpes). -!*** Obviously the total number cannot be less than the number -!*** used for the forecast. -!----------------------------------------------------------------------- -! - if(npes100)then - write(0,*)' ***** IQUILT_GROUP IS GREATER THAN 100' - write(0,*)' ***** DO YOU REALLY WANT THIS ?' - write(0,*)' ***** IF SO THEN INCREASE SIZE IN mpp.h' - write(0,*)' ***** ALSO, CHANGE IF CHECK IN SETUP_SERVERS' - write(0,*)' ***** RESETTING THE NUMBER OF SERVER GROUPS TO 100' - write(0,*)' ***** WE ARE CONTINUING .... ' - iquilt_group=max_groups - endif -! - if(mype==0)then - write(0,*)' Number of Server Groups: ',iquilt_group - endif -!----------------------------------------------------------------------- -! -!*** Compute the number of quilt tasks per group. -!*** All mpi tasks beyond npes_fcst will be quilt tasks. -!*** If the number of tasks is not equally divisible by -!*** the number of groups of tasks then some groups may have -!*** more tasks then others. This is fine. -!*** Note that we require at least one task per group. -!*** We may need to reduce the number of groups if -!*** it exceeds the number of tasks. -! -!----------------------------------------------------------------------- -!!!! iqserver=npes-npes_fcst !<-- Total # of quilt tasks in all groups -! iqserver=ngroups_read*read_tasks_per_group & !<-- Total # of quilt tasks in all groups -! +ngroups_write*write_tasks_per_group - iqserver=ngroups_write*write_tasks_per_group !<-- Total # of quilt tasks in all groups -! - if(iqserver==0)then - if(mype==0)then - write(0,*)' *** You specified 0 Write tasks ' - write(0,*)' *** Output will write a direct access file' - endif - iquilt_group=0 - endif -! - if(iquilt_group>iqserver)then - iquilt_group=iqserver - write(0,*)' ***** NOT ENOUGH WRITE/QUILT TASKS' - write(0,*)' ***** WE NEED TO REDUCE THE NUMBER OF WRITE GROUPS' - write(0,*)' ***** NUMBER OF GROUPS IS ',iquilt_group - endif -! - do i=0,iquilt_group-1 -!!!! call para_range(one,iqserver,iquilt_group,i,istaq,iendq) -!!!! num_serv_per_grp(i+1)=iendq-istaq+1 !<-- Store the # of tasks per group - num_serv_per_grp(i+1)=write_tasks_per_group !<-- Store the # of tasks per group - if(mype==0)then - write(0,*)' Number of tasks for Group ',i+1,' is ',num_serv_per_grp(i+1) - endif - enddo -! -!----------------------------------------------------------------------- -!*** If there are more tasks executing this job that there are -!*** forecast tasks plus all quilt tasks then warn the user!!!! -!----------------------------------------------------------------------- -! - if(npes>npes_fcst+iqserver)then -! write(0,*)' ABORTING IN SETUP_SERVERS' - write(0,*)' MORE TASKS ARE EXECUTING THIS JOB THAN' & - ,' THERE ARE FORECAST TASKS PLUS QUILT TASKS' - write(0,*)' npes=',npes,' npes_fcst=',npes_fcst,' iqserver=',iqserver -! call mpi_abort(mpi_intra,1,ierr) - endif -! -!----------------------------------------------------------------------- -!*** Set up the "color" for mpi_comm_split. -!*** Those tasks which will do model integration will be color 0. -!*** The quilt tasks will have the color of the group number to -!*** which they will belong. -!----------------------------------------------------------------------- -! - if(mype=istaxx.and.mype<=iendxx)then - icolor=i - endif - istaxx=iendxx+1 - enddo - endif -! -!----------------------------------------------------------------------- -!*** Split the communicator - The new intracommunicator for all tasks -!*** is mpi_comm_comp. mpi_comm_world (mpi_intra) is still available but it -!*** refers to all the mpi tasks (model integration AND quilt tasks). -!----------------------------------------------------------------------- -! - call mpi_comm_dup(mpi_intra,comdup,ierr) - call mpi_comm_split(comdup,icolor,mype,mpi_comm_comp,ierr) -! -!----------------------------------------------------------------------- -!*** At this point we have a new communicator, mpi_comm_comp, -!*** that can be used by the forecast tasks and the quilt tasks -!*** for their internal communications. On to the intercommunicators ... -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Now we must create the intercommunicators for use between the mpi -!*** tasks doing the model integration and the mpi tasks for each -!*** quilt group. The first step is to exclude the tasks that do not -!*** belong. We will do this for each quilt group by excluding the -!*** tasks from all of the other quilt groups. -!----------------------------------------------------------------------- -! - allocate(irank(iqserver)) !<-- Dimension irank to the total # of quilt tasks -! - if(iqserver>0)then - do i=1,iqserver - irank(i)=-1 !<-- Initialize irank to meaningless values - enddo - endif -! - ixx=npes_fcst !<-- Let ixx be the # of forecast tasks -! -!----------------------------------------------------------------------- -! - inter_comm : do i=1,iquilt_group !<-- Create intercommunicators between the set of fcst tasks - ! and each quilt group individually. -!----------------------------------------------------------------------- -! - include_mype=.true. -! - if(mypentasks_per_group -! -! output argument list: -! jrow_first - the first row of forecast tasks to send history -! data to this write task -! jrow_last - the last row of forecast tasks to send history -! data to this write task -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - integer(kind=kint),intent(in) :: & - jnpes & - ,n_write_task & - ,ntasks_per_group -! - integer(kind=kint),intent(out) :: & - jrow_first & - ,jrow_last -! -!----------------------------------------------------------------------- -!*** Local variables -!----------------------------------------------------------------------- -! - integer(kind=kint) :: & - iadd & - ,n_remain & - ,ntask & - ,num_base -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - num_base=jnpes/ntasks_per_group - n_remain=jnpes-ntasks_per_group*num_base - jrow_last=0 -! - iadd=1 - do ntask=1,n_write_task - if(ntask>n_remain)iadd=0 - jrow_first=jrow_last+1 - jrow_last=jrow_first+num_base+iadd-1 - enddo -! -!----------------------------------------------------------------------- -! - end subroutine para_range -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - subroutine decomp & -! - (mype,inpes,jnpes,npes_fcst,im,jm,lmx,global,ijcount) -! -!----------------------------------------------------------------------- -! -!*** DECOMP specifies the domain decomposition. -! -!----------------------------------------------------------------------- -! - implicit none -! -!----------------------------------------------------------------------- -!*** Argument variables. -!----------------------------------------------------------------------- -! - integer(kind=kint),intent(in) :: im & - ,jm & - ,lmx & - ,inpes & - ,jnpes & - ,mype & - ,npes_fcst -! - logical,intent(in) :: global -! - integer(kind=kint),dimension(2),intent(in) :: ijcount -! -!----------------------------------------------------------------------- -!*** Local variables. -!----------------------------------------------------------------------- -! - integer(kind=kint) :: i & - ,i_add & - ,icol & - ,iend & - ,ierr & - ,iguess & - ,ipe & - ,irecv & - ,iremain & - ,irtn & - ,isend & - ,istart & - ,istat & - ,j & - ,j_add & - ,jend & - ,jguess & - ,jremain & - ,jrow & - ,jstart & - ,k2 & - ,l_remain & - ,lyr_frac & - ,my_e & - ,my_n & - ,my_ne & - ,my_nw & - ,my_s & - ,my_se & - ,my_sw & - ,my_w & - ,myi & - ,myj & - ,n & - ,npe & - ,num_pts -! - integer(kind=kint),dimension(4) :: limits -! - integer(kind=kint),dimension(mpi_status_size) :: jstat -! - integer(kind=kint),allocatable,dimension(:,:) :: ijcount_all & - ,itemp -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -!*** LMX is the number of model layers sent to this routine from the -!*** MAIN_GRID_COMP module where it was retrieved from the config file. -!*** The variable LM is available to all other modules from this one. -!*** Give LM the value of LMX so that any other module may use it. -!----------------------------------------------------------------------- -! - lm=lmx -! -!----------------------------------------------------------------------- -! - mype_share=mype ! The gather/scatter routines and other parallel - ! routines will get mype from here and thus - ! remain ESMF-neutral themselves -! -!----------------------------------------------------------------------- -!*** -!*** Compute the index limits within each MPI task. -!*** We will divide the number of points in the I and J directions -!*** evenly and then give as many of the initial tasks in each -!*** direction single additional points until any remainders are -!*** used up. -!*** The task IDs will start with 0 in the lower left corner and -!*** increase in the I direction and then in the J direction. -!*** -!----------------------------------------------------------------------- -!*** The full dimensions of the integration domain. -!----------------------------------------------------------------------- -! - if(global)then - ids=1 - ide=im+2 - jds=1 - jde=jm+2 - else - ids=1 - ide=im - jds=1 - jde=jm - endif -! -!----------------------------------------------------------------------- -!*** Find the remainders of points in each direction that will be -!*** incrementally added to each of the final tasks in each direction. -!----------------------------------------------------------------------- -! - iguess=(ide-ids+1)/inpes - iremain=(ide-ids+1)-iguess*inpes - jguess=(jde-jds+1)/jnpes - jremain=(jde-jds+1)-jguess*jnpes -! -!----------------------------------------------------------------------- -!*** Let every task know where all other tasks start and end -!*** on the full grid. -!*** Each task will save its own start/end values. -!----------------------------------------------------------------------- -! - if(allocated(local_istart))then - deallocate(local_istart) - deallocate(local_iend) - deallocate(local_jstart) - deallocate(local_jend) - endif -! - npes=npes_fcst - allocate(local_istart(0:npes-1),stat=istat) - allocate(local_iend(0:npes-1),stat=istat) - allocate(local_jstart(0:npes-1),stat=istat) - allocate(local_jend(0:npes-1),stat=istat) -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - if(mype==0)then - if(allocated(ijcount_all))then - deallocate(ijcount_all) - endif -! - allocate(ijcount_all(2,0:npes-1),stat=istat) - ijcount_all(1,0)=ijcount(1) - ijcount_all(2,0)=ijcount(2) - local_istart(0)=ids - local_iend(0)=ids+ijcount(1)-1 - local_jstart(0)=jds - local_jend(0)=jds+ijcount(2)-1 -! - do npe=1,npes-1 - call mpi_recv(ijcount_all(1,npe),2,mpi_integer,npe,npe & - ,mpi_comm_comp,jstat,irecv) -! -!----------------------------------------------------------------------- -!*** Find the start and end I values on this task's -!*** primary integration region (inside the haloes). -!----------------------------------------------------------------------- -! - icol=mod(npe,inpes)+1 - if(icol==1)then - local_istart(npe)=ids - else - local_istart(npe)=local_istart(npe-1)+ijcount_all(1,npe-1) - endif - local_iend(npe)=local_istart(npe)+ijcount_all(1,npe)-1 -! -!----------------------------------------------------------------------- -!*** Find the start and end J values on this task's -!*** primary integration region (inside the haloes). -!----------------------------------------------------------------------- -! - jrow=npe/inpes+1 - if(jrow==1)then - local_jstart(npe)=jds - else - local_jstart(npe)=local_jstart(npe-inpes)+ijcount_all(2,npe-inpes) - endif - local_jend(npe)=local_jstart(npe)+ijcount_all(2,npe)-1 - enddo -! - else - call mpi_send(ijcount,2,mpi_integer,0,mype,mpi_comm_comp,isend) - endif -! - call mpi_bcast(local_istart,npes,mpi_integer,0,mpi_comm_comp,ierr) - call mpi_bcast(local_iend,npes,mpi_integer,0,mpi_comm_comp,ierr) - call mpi_bcast(local_jstart,npes,mpi_integer,0,mpi_comm_comp,ierr) - call mpi_bcast(local_jend,npes,mpi_integer,0,mpi_comm_comp,ierr) -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!----------------------------------------------------------------------- -! - local_ij: do npe=0,npes-1 -! - if(mype==npe)then - its=local_istart(npe) - ite=local_iend(npe) - jts=local_jstart(npe) - jte=local_jend(npe) -! write(0,*)' after bcast its=',its,' ite=',ite,' jts=',jts,' jte=',jte - endif -! - enddo local_ij -! -!----------------------------------------------------------------------- -!*** The memory or storage dimensions include the halo. -!----------------------------------------------------------------------- -! -! ims=max(its-ihalo,ids) -! ime=min(ite+ihalo,ide) -! jms=max(jts-jhalo,jds) -! jme=min(jte+jhalo,jde) - ims=its-ihalo - ime=ite+ihalo - jms=jts-jhalo - jme=jte+jhalo -! -!----------------------------------------------------------------------- -!*** Additional loop limits regarding global boundary and haloes. -!*** If "_bN" is appended to a start/end limit then that means -!*** that the MPI tasks along the global boundary must stay N -!*** points away from that boundary. -!*** If "_hN" is appended to a start/end limit then that means -!*** that each task will compute N points into the halo unless -!*** being blocked by the global boundary. -!----------------------------------------------------------------------- -! - ids_p1=max(its,ids+1) - ide_m1=min(ite,ide-1) - ide_m2=min(ite,ide-2) - jds_p1=max(jts,jds+1) - jde_m1=min(jte,jde-1) - jde_m2=min(jte,jde-2) -! - its_b1=max(its,ids+1) - ite_b1=min(ite,ide-1) - its_b2=max(its,ids+2) - ite_b2=min(ite,ide-2) - jts_b1=max(jts,jds+1) - jte_b1=min(jte,jde-1) - jts_b2=max(jts,jds+2) - jte_b2=min(jte,jde-2) -! - its_h1=max(its-1,ids) - ite_h1=min(ite+1,ide) - its_h2=max(its-2,ids) - ite_h2=min(ite+2,ide) - jts_h1=max(jts-1,jds) - jte_h1=min(jte+1,jde) - jts_h2=max(jts-2,jds) - jte_h2=min(jte+2,jde) -! - its_b1_h1=max(its-1,ids+1) - ite_b1_h1=min(ite+1,ide-1) - ite_b1_h2=min(ite+2,ide-1) - jts_b1_h1=max(jts-1,jds+1) - jte_b1_h1=min(jte+1,jde-1) - jte_b1_h2=min(jte+2,jde-1) -! - if(mype==0)then - write(0,*)' ids=',ids,' ide=',ide,' jds=',jds,' jde=',jde - endif -! - do npe=0,npes-1 - if(mype==npe)then -!!! write(0,*)' PE=',mype - write(0,*)' inpes=',inpes,' jnpes=',jnpes - write(0,*)' its=',its,' ite=',ite,' jts=',jts,' jte=',jte - write(0,*)' ims=',ims,' ime=',ime,' jms=',jms,' jme=',jme - write(0,*)' ids=',ids,' ide=',ide,' jds=',jds,' jde=',jde - endif - call mpi_barrier(mpi_comm_comp,irtn) - enddo -!----------------------------------------------------------------------- -!*** Find the maximum horizontal size of each task's subdomain -!*** since task 0 will need that in subroutine DSTRB. -!----------------------------------------------------------------------- -! - num_pts_max=0 -! - if(mype==0)then - do ipe=1,npes-1 - call mpi_recv(limits,4,mpi_integer,ipe,ipe,mpi_comm_comp & - &, jstat,irecv) -! - istart=limits(1) - iend=limits(2) - jstart=limits(3) - jend=limits(4) -! - num_pts=(iend-istart+1)*(jend-jstart+1) - if(num_pts>num_pts_max)then - num_pts_max=num_pts - endif - enddo -! - else -! - limits(1)=its - limits(2)=ite - limits(3)=jts - limits(4)=jte -! - call mpi_send(limits,4,mpi_integer,0,mype,mpi_comm_comp,isend) - endif -! -!----------------------------------------------------------------------- -!*** Let each task determine who its eight neighbors are because we -!*** will need to know that for the halo exchanges. The direction -!*** to each neighbor will be designated by the following integers: -! -!*** north: 1 -!*** east: 2 -!*** south: 3 -!*** west: 4 -!*** northeast: 5 -!*** southeast: 6 -!*** southwest: 7 -!*** northwest: 8 -! -!*** If a task has no neighbor in a particular direction because of -!*** the presence of the global domain boundary then that element -!*** of my_neb is set to -1. -!----------------------------------------------------------------------- -! - if(allocated(itemp))then - deallocate(itemp) - endif -! - allocate(itemp(inpes,jnpes),stat=istat) - ipe=0 -! - do j=1,jnpes - do i=1,inpes - itemp(i,j)=ipe - if(ipe==mype)then - myi=i - myj=j - endif - ipe=ipe+1 - enddo - enddo -! - my_n=-1 - if(myj+1<=jnpes)my_n=itemp(myi,myj+1) -! - my_e=-1 - if(myi+1<=inpes)my_e=itemp(myi+1,myj) -! - my_s=-1 - if(myj-1>=1)my_s=itemp(myi,myj-1) -! - my_w=-1 - if(myi-1>=1)my_w=itemp(myi-1,myj) -! - my_ne=-1 - if((myi+1<=inpes).and.(myj+1<=jnpes)) & - my_ne=itemp(myi+1,myj+1) -! - my_se=-1 - if((myi+1<=inpes).and.(myj-1>=1)) & - my_se=itemp(myi+1,myj-1) -! - my_sw=-1 - if((myi-1>=1).and.(myj-1>=1)) & - my_sw=itemp(myi-1,myj-1) -! - my_nw=-1 - if((myi-1>=1).and.(myj+1<=jnpes)) & - my_nw=itemp(myi-1,myj+1) -! - my_neb(1)=my_n - my_neb(2)=my_e - my_neb(3)=my_s - my_neb(4)=my_w - my_neb(5)=my_ne - my_neb(6)=my_se - my_neb(7)=my_sw - my_neb(8)=my_nw -! - deallocate(itemp) -! -!!! write(0,*)' Exiting DECOMP' -!!! write(0,*)' its=',its,' ite=',ite,' jts=',jts,' jte=',jte -!!! write(0,*)' ims=',ims,' ime=',ime,' jms=',jms,' jme=',jme -!----------------------------------------------------------------------- -! - end subroutine decomp -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- - subroutine dstrb & - (arrayg,arrayl,lgs,lge,lls,lle,l1,mype,mpi_comm_comp) -!----------------------------------------------------------------------- -! DSTRB distributes the elements of real global array arrayg to the -! real local array arrayl. -!----------------------------------------------------------------------- -! input argument list: -! arrayg - global array -! lgs - starting vertical index of global array -! lge - ending vertical index of global array -! lls - starting vertical index of local array -! lle - ending vertical index of local array -! l1 - vertical level of arrayl being filled in this call -! (used only when lge=1 and lle>1, i.e. when the global -! array is actually just one level of a multi_level -! array) -! mype - task rank -! mpi_comm_comp - the local intracommunicator -! -! output argument list: -! arrayl - local array -! -!----------------------------------------------------------------------- -! - implicit none -! -!----------------------------------------------------------------------- -!*** -!*** argument variables -!*** - integer(kind=kint),intent(in) :: l1,lge,lgs,lle,lls -! - integer(kind=kint),intent(in) :: mype,mpi_comm_comp -! - real(kind=kfpt),dimension(ids:ide,jds:jde,lgs:lge),intent(in) :: & - arrayg - real(kind=kfpt),dimension(ims:ime,jms:jme,lls:lle),intent(out) :: & - arrayl -! -!----------------------------------------------------------------------- -!*** -!*** local variables -!*** -! - integer(kind=kint) :: i,iend,ipe,irecv,irtn,isend,istart,j,jend & - ,jstart,knt,l,numvals - integer,dimension(4) :: limits - integer,dimension(mpi_status_size) :: jstat -! - real(kind=kfpt),allocatable,dimension(:) :: arrayx -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -!*** Task 0 fills its own local domain then parcels out all the other -!*** pieces to the other tasks. -!----------------------------------------------------------------------- -! - tasks : if(mype==0)then -! - if(lge==lgs)then - do j=jts,jte - do i=its,ite - arrayl(i,j,l1)=arrayg(i,j,lgs) - enddo - enddo -! - else -! - do l=lgs,lge - do j=jts,jte - do i=its,ite - arrayl(i,j,l)=arrayg(i,j,l) - enddo - enddo - enddo - endif -! -!*** Task 0 creates an array to hold all the values from the other -!*** tasks' pieces of the global array and then sends those pieces -!*** out to the appropriate tasks. -! - numvals=num_pts_max*(lge-lgs+1) - allocate(arrayx(numvals),stat=i) -! - do ipe=1,npes-1 -! - call mpi_recv(limits,4,mpi_integer,ipe,ipe,mpi_comm_comp & - ,jstat,irecv) -! - istart=limits(1) - iend=limits(2) - jstart=limits(3) - jend=limits(4) - knt=0 -! - do l=lgs,lge - do j=jstart,jend - do i=istart,iend - knt=knt+1 - arrayx(knt)=arrayg(i,j,l) - enddo - enddo - enddo -! - call mpi_send(arrayx,knt,mpi_real,ipe,ipe,mpi_comm_comp,isend) -! - enddo -! - deallocate(arrayx) -! -!----------------------------------------------------------------------- -!*** All other tasks tell task 0 what their horizontal limits are and -!*** receive their piece of the global array from task 0. -!----------------------------------------------------------------------- -! - else -! - limits(1)=its - limits(2)=ite - limits(3)=jts - limits(4)=jte -! - call mpi_send(limits,4,mpi_integer,0,mype,mpi_comm_comp,isend) -! - knt=(ite-its+1)*(jte-jts+1)*(lge-lgs+1) - allocate(arrayx(knt),stat=i) -! - call mpi_recv(arrayx,knt,mpi_real,0,mype,mpi_comm_comp & - ,jstat,irecv) -! - knt=0 - if(lge==lgs)then - do j=jts,jte - do i=its,ite - knt=knt+1 - arrayl(i,j,l1)=arrayx(knt) - enddo - enddo - else - do l=lgs,lge - do j=jts,jte - do i=its,ite - knt=knt+1 - arrayl(i,j,l)=arrayx(knt) - enddo - enddo - enddo - endif -! - deallocate(arrayx) -! -!----------------------------------------------------------------------- -! - endif tasks -! -!----------------------------------------------------------------------- - call mpi_barrier(mpi_comm_comp,irtn) -!----------------------------------------------------------------------- -! - end subroutine dstrb -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- - subroutine idstrb & - (iarrayg,iarrayl,mype,mpi_comm_comp) -!----------------------------------------------------------------------- -! IDSTRB distributes the elements of integer global array iarrayg -! to the integer local array iarrayl. -!----------------------------------------------------------------------- -! input argument list: -! iarrayg - global array -! -! output argument list: -! iarrayl - local array -! -!----------------------------------------------------------------------- -! - implicit none -! -!----------------------------------------------------------------------- -!*** -!*** argument variables -!*** - integer(kind=kint),intent(in) :: mype,mpi_comm_comp -! - integer(kind=kint),dimension(ids:ide,jds:jde),intent(in) :: & - iarrayg - integer(kind=kint),dimension(ims:ime,jms:jme),intent(out) :: & - iarrayl -!----------------------------------------------------------------------- -!*** -!*** local variables -!*** -! - integer(kind=kint) :: i,iend,ipe,irecv,irtn,isend,istart,j,jend & -!xxx ,jstart,knt,l,mype,numvals - ,jstart,knt,l,numvals - integer,dimension(4) :: limits - integer,dimension(mpi_status_size) :: jstat -! - integer(kind=kint),allocatable,dimension(:) :: iarrayx -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!*** Initialize the output array. -! - do j=jms,jme - do i=ims,ime - iarrayl(i,j)=0. - enddo - enddo -! -!----------------------------------------------------------------------- -!*** Task 0 fills its own local domain then parcels out all the other -!*** pieces to the other tasks. -!----------------------------------------------------------------------- -! - tasks : if(mype==0)then -! - do j=jts,jte - do i=its,ite - iarrayl(i,j)=iarrayg(i,j) - enddo - enddo -! -!*** Task 0 creates an array to hold all the values from the other -!*** tasks' pieces of the global array and then sends those pieces -!*** out to the appropriate tasks. -! - numvals=num_pts_max - allocate(iarrayx(numvals),stat=i) -! - do ipe=1,npes-1 -! - call mpi_recv(limits,4,mpi_integer,ipe,ipe,mpi_comm_comp & - ,jstat,irecv) -! - istart=limits(1) - iend=limits(2) - jstart=limits(3) - jend=limits(4) - knt=0 -! - do j=jstart,jend - do i=istart,iend - knt=knt+1 - iarrayx(knt)=iarrayg(i,j) - enddo - enddo -! - call mpi_send(iarrayx,knt,mpi_integer,ipe,ipe,mpi_comm_comp & - ,isend) -! - enddo -! - deallocate(iarrayx) -! -!----------------------------------------------------------------------- -!*** All other tasks tell task 0 what their horizontal limits are and -!*** receive their piece of the global array from task 0. -!----------------------------------------------------------------------- -! - else -! - limits(1)=its - limits(2)=ite - limits(3)=jts - limits(4)=jte -! - call mpi_send(limits,4,mpi_integer,0,mype,mpi_comm_comp,isend) -! - knt=(ite-its+1)*(jte-jts+1) - allocate(iarrayx(knt),stat=i) -! - call mpi_recv(iarrayx,knt,mpi_integer,0,mype,mpi_comm_comp & - ,jstat,irecv) -! - knt=0 - do j=jts,jte - do i=its,ite - knt=knt+1 - iarrayl(i,j)=iarrayx(knt) - enddo - enddo -! - deallocate(iarrayx) -! -!----------------------------------------------------------------------- -! - endif tasks -! -!----------------------------------------------------------------------- - call mpi_barrier(mpi_comm_comp,irtn) -!----------------------------------------------------------------------- -! - end subroutine idstrb -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- - subroutine dstrb_soil & - (arrayg,arrayl,lgs,lge,lls,lle) -!----------------------------------------------------------------------- -! DSTRB distributes the elements of real global array arrayg to the -! real local array arrayl. -!----------------------------------------------------------------------- -! input argument list: -! arrayg - global soil array -! lgs - starting vertical index of global array -! lge - ending vertical index of global array -! lls - starting vertical index of local array -! lle - ending vertical index of local array -! -! output argument list: -! arrayl - local soil array -! -!----------------------------------------------------------------------- -! - implicit none -! -!----------------------------------------------------------------------- -!*** -!*** argument variables -!*** - integer(kind=kint),intent(in) :: lge,lgs,lle,lls -! - real(kind=kfpt),dimension(lgs:lge,ids:ide,jds:jde),intent(in) :: & - arrayg - real(kind=kfpt),dimension(lls:lle,ims:ime,jms:jme),intent(out) :: & - arrayl -!----------------------------------------------------------------------- -!*** -!*** local variables -!*** -! - integer(kind=kint) :: i,iend,ipe,irecv,irtn,isend,istart,j,jend & - ,jstart,knt,l,mype,numvals - integer,dimension(4) :: limits - integer,dimension(mpi_status_size) :: jstat -! - real(kind=kfpt),allocatable,dimension(:) :: arrayx -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - mype=mype_share -! -!*** Initialize the output array. -! - do j=jms,jme - do i=ims,ime - do l=lls,lle - arrayl(l,i,j)=0. - enddo - enddo - enddo -! -!----------------------------------------------------------------------- -!*** Task 0 fills its own local domain then parcels out all the other -!*** pieces to the other tasks. -!----------------------------------------------------------------------- -! - tasks : if(mype==0)then -! - do j=jts,jte - do i=its,ite - do l=lgs,lge - arrayl(l,i,j)=arrayg(l,i,j) - enddo - enddo - enddo -! -!*** Task 0 creates an array to hold all the values from the other -!*** tasks' pieces of the global array and then sends those pieces -!*** out to the appropriate tasks. -! - numvals=num_pts_max*(lge-lgs+1) - allocate(arrayx(numvals),stat=i) -! - do ipe=1,npes-1 -! - call mpi_recv(limits,4,mpi_integer,ipe,ipe,mpi_comm_comp & - ,jstat,irecv) -! - istart=limits(1) - iend=limits(2) - jstart=limits(3) - jend=limits(4) - knt=0 -! - do j=jstart,jend - do i=istart,iend - do l=lgs,lge - knt=knt+1 - arrayx(knt)=arrayg(l,i,j) - enddo - enddo - enddo -! - call mpi_send(arrayx,knt,mpi_real,ipe,ipe,mpi_comm_comp,isend) -! - enddo -! - deallocate(arrayx) -! -!----------------------------------------------------------------------- -!*** All other tasks tell task 0 what their horizontal limits are and -!*** receive their piece of the global array from task 0. -!----------------------------------------------------------------------- -! - else -! - limits(1)=its - limits(2)=ite - limits(3)=jts - limits(4)=jte -! - call mpi_send(limits,4,mpi_integer,0,mype,mpi_comm_comp,isend) -! - knt=(ite-its+1)*(jte-jts+1)*(lge-lgs+1) - allocate(arrayx(knt),stat=i) -! - call mpi_recv(arrayx,knt,mpi_real,0,mype,mpi_comm_comp & - ,jstat,irecv) -! - knt=0 - do j=jts,jte - do i=its,ite - do l=lgs,lge - knt=knt+1 - arrayl(l,i,j)=arrayx(knt) - enddo - enddo - enddo -! - deallocate(arrayx) -! -!----------------------------------------------------------------------- -! - endif tasks -! -!----------------------------------------------------------------------- - call mpi_barrier(mpi_comm_comp,irtn) -!----------------------------------------------------------------------- -! - end subroutine dstrb_soil -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- - subroutine gather_layers & - (field,lm,npes,msize_dummy_fft & - ,lm_fft,k1_fft,k2_fft & - ,local_istart,local_iend & - ,local_jstart,local_jend & - ,jstart_fft,jend_fft & - ,my_jrow_start,my_jrow_end & - ,ipe_start,ipe_end & - ,my_domain_has_fft_lats & - ,mype,mpi_comm_comp & - ,its,ite,ims,ime,ids,ide,jts,jte,jms,jme & - ,array_lyrs) -!----------------------------------------------------------------------- -!*** GATHER_LAYERS distributes all the elements of field between layers -!*** k1 and k2 inclusive to the appropriate task for subsequent -!*** application of FFTs. -!----------------------------------------------------------------------- -! - implicit none -! -!----------------------------------------------------------------------- -! -integer(kind=kint),intent(in) :: & - its & -,ite & -,ims & -,ime & -,ids & -,ide & -,jts & -,jte & -,jms & -,jme -! -integer(kind=kint),intent(in) :: & - ipe_end & -,ipe_start & -,jstart_fft & -,jend_fft & -,lm & -,lm_fft & -,mpi_comm_comp & -,msize_dummy_fft & -,mype & -,npes -! -integer(kind=kint),dimension(0:npes-1),intent(in) :: & - k1_fft & -,k2_fft & -,local_iend & -,local_istart & -,local_jend & -,local_jstart & -,my_jrow_start & -,my_jrow_end -! -real(kind=kfpt),dimension(ims:ime,jms:jme,lm),intent(in) :: & - field -! -real(kind=kfpt),dimension(ids:ide,jstart_fft:jend_fft,1:lm_fft),intent(out) :: & - array_lyrs -! -logical(kind=klog),dimension(0:npes-1),intent(in) :: & - my_domain_has_fft_lats -! -!----------------------------------------------------------------------- -!*** Local Variables -!----------------------------------------------------------------------- -! -integer(kind=kint) :: & - i & -,i_extent & -,iend & -,ierr & -,istart & -,j & -,j_extent & -,jend_fft_local & -,jstart_fft_local & -,k & -,k1 & -,k2 & -,k_extent & -!!!,mype & -,n & -,nbuf & -,npe -! -integer(kind=kint),dimension(mpi_status_size) :: jstat -integer(kind=kint),dimension(:),allocatable,target,save :: handle -! -real(kind=kfpt),dimension(:),allocatable,save :: & - dummy_recv -real(kind=kfpt),dimension(:,:),allocatable,save :: & - dummy_send -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Handles are needed for the mpi_waits associated with mpi_isend. -!*** Allocate the handle array and initialize it. -!----------------------------------------------------------------------- -! - if(.not.allocated(handle))then - allocate(handle(0:npes-1)) - do n=0,npes-1 - handle(n)=mpi_request_null - enddo - allocate(dummy_recv(msize_dummy_fft)) - if(my_domain_has_fft_lats(mype))then - allocate(dummy_send(msize_dummy_fft,ipe_start:ipe_end)) - endif - endif -! -!----------------------------------------------------------------------- -!*** Each task is responsible for multiple full layers (the entire -!*** horizontal expanse of points in a given model layer in a given -!*** hemisphere that are on latitude circles where FFTs are applied), -!*** a single layer, or even a partial layer if there are more MPI -!*** compute tasks than there are layers (by the definition above, -!*** there are 2*LM layers). -!*** Each task must gather full latitude circles for its designated -!*** layers and rows and send to the other tasks its pieces of the -!*** latitude circles they need for the model layers they will be -!*** handling. -! -!*** k1_fft and k2_fft provide the vertical limits for each task's -!*** group of model layers. -! -!*** We gather into array array_lyrs which will hold full latitude -!*** circles of data in each task's own set of assigned model layers. -! -!----------------------------------------------------------------------- -!*** Compute the number of words sent by mype to everyone else. -!*** A task will send only if it has FFT latitude circles -!*** within a receiving task's designated region for computing FFTs. -!*** The sender uses the receiver's K extent, its own I extent, -!*** and the J extent for which its subdomain has FFT latitudes. -!----------------------------------------------------------------------- -! - if(my_domain_has_fft_lats(mype))then -! - send_to_npe: do npe=ipe_start,ipe_end !<--- Send subsets of my FFT points to all - ! other tasks in this hemisphere. -! - nbuf=0 !<--- This counts the words we are inserting - ! into the send buffer. - jstart_fft_local=max(jts,my_jrow_start(npe)) - jend_fft_local=min(jte,my_jrow_end(npe)) -! - if(jstart_fft_local<=jend_fft_local)then -! - k1=k1_fft(npe) - k2=k2_fft(npe) - do k=k1,k2 - do j=jstart_fft_local,jend_fft_local - do i=its,ite - nbuf=nbuf+1 !<-- This counts words going to all tasks. - dummy_send(nbuf,npe)=field(i,j,k) - enddo - enddo - enddo -! -! call mpi_issend(dummy_send(1,npe),nbuf,mpi_real, & - call mpi_isend(dummy_send(1,npe),nbuf,mpi_real, & - npe,mype,mpi_comm_comp, & - handle(npe),ierr) -! - endif -! - enddo send_to_npe -! - endif - -!----------------------------------------------------------------------- -!*** Compute the number of words received by mype from everyone. -!*** Only those tasks containing FFT latitude circles will be -!*** sending more than zero words. -!*** The receiver uses its K extent, the sender's full I extent, -!*** and the sender's J extent over which its subdomain has -!*** FFT latitude circles. -!*** Everyone receives since FFT work is shared by all. -! -!------------------------------------------------------------------------ -!*** Loop through the tasks in each hemisphere from which mype receives. -!------------------------------------------------------------------------ -! -!*** We need to specify which points each task will receive from tasks with FFT latitudes. -! - k1=k1_fft(mype) - k2=k2_fft(mype) - k_extent=k2-k1+1 -! - recv_from_npe: do npe=ipe_start,ipe_end !<--- Tasks with FFT lats in this task's - ! hemisphere will send -! - from_senders: if(my_domain_has_fft_lats(npe))then - jstart_fft_local=max(local_jstart(npe),my_jrow_start(mype)) - jend_fft_local=min(local_jend(npe),my_jrow_end(mype)) - j_extent=jend_fft_local-jstart_fft_local+1 - if(j_extent<=0)cycle - istart=local_istart(npe) - iend=local_iend(npe) - i_extent=iend-istart+1 - n=j_extent*k_extent*i_extent !<--- Total # of 3-D FFT points coming from remote - ! task -! -!----------------------------------------------------------------------- -!*** Receive data only from tasks with FFT latitudes -!----------------------------------------------------------------------- -! - call mpi_recv(dummy_recv,n,mpi_real & - ,npe,npe & - ,mpi_comm_comp & - ,jstat & - ,ierr) -! -!----------------------------------------------------------------------- -!*** Fill in the working array. -!*** Use the horizontal domain information from each source task that -!*** contained the original pieces of FFT circles since what we are -!*** doing here is combining all those pieces for particular layers -!*** into full circles. -!----------------------------------------------------------------------- -! -! - nbuf=0 !<--- This counts the words we are receiving from the recv buffer. -! - n=0 - do k=k1,k2 - n=n+1 - do j=jstart_fft_local,jend_fft_local - do i=istart,iend - nbuf=nbuf+1 - array_lyrs(i,j,n)=dummy_recv(nbuf) - enddo - enddo - enddo -! - endif from_senders -! - enddo recv_from_npe -! -!----------------------------------------------------------------------- -!*** Clear the ISend request handles. -!----------------------------------------------------------------------- -! - if(my_domain_has_fft_lats(mype))then -! - do npe=ipe_start,ipe_end - call mpi_wait(handle(npe),jstat,ierr) - enddo -! - endif -! -!----------------------------------------------------------------------- -! - end subroutine gather_layers -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- - subroutine scatter_layers & - (array_lyrs,lm,npes,msize_dummy_fft & - ,lm_fft,k1_fft,k2_fft & - ,local_istart,local_iend & - ,local_jstart,local_jend & - ,jstart_fft,jend_fft & - ,my_jrow_start,my_jrow_end & - ,ipe_start,ipe_end & - ,my_domain_has_fft_lats & - ,mype,mpi_comm_comp & - ,its,ite,ims,ime,ids,ide,jts,jte,jms,jme & - ,field) -!----------------------------------------------------------------------- -!*** SCATTER_LAYERS distributes the elements of array_lyrs between -!*** layers k1 and k2 inclusive to the appropriate tasks that actually -!*** own the FFT latitude rows. -!----------------------------------------------------------------------- -! - implicit none -! -!----------------------------------------------------------------------- -! -integer(kind=kint),intent(in) :: & - its & -,ite & -,ims & -,ime & -,ids & -,ide & -,jts & -,jte & -,jms & -,jme -! -integer(kind=kint),intent(in) :: & - ipe_end & -,ipe_start & -,jstart_fft & -,jend_fft & -,lm & -,lm_fft & -,mpi_comm_comp & -,msize_dummy_fft & -,mype & -,npes -! -integer(kind=kint),dimension(0:npes-1),intent(in) :: & - k1_fft & -,k2_fft & -,local_iend & -,local_istart & -,local_jend & -,local_jstart & -,my_jrow_start & -,my_jrow_end -! -real(kind=kfpt),dimension(ids:ide,jstart_fft:jend_fft,1:lm_fft),intent(in) :: & - array_lyrs -! -real(kind=kfpt),dimension(ims:ime,jms:jme,lm),intent(out) :: & - field -! -logical(kind=klog),dimension(0:npes-1),intent(in) :: & - my_domain_has_fft_lats -! -!----------------------------------------------------------------------- -!*** Local Variables -!----------------------------------------------------------------------- -! -integer(kind=kint) :: & - i & -,i_extent & -,iend & -,ierr & -,iprod & -,istart & -,j & -,j_extent & -,jend_fft_local & -,jstart_fft_local & -,k & -,k_extent & -,k1 & -,k2 & -!!!,mype & -,n & -,ncount_recv & -,nbuf & -,nn & -,npe -! -integer(kind=kint),dimension(mpi_status_size) :: jstat -integer(kind=kint),dimension(:),allocatable,target,save :: handle -! -real(kind=kfpt),dimension(:),allocatable,save :: & - dummy_recv -real(kind=kfpt),dimension(:,:),allocatable,save :: & - dummy_send -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!xxx mype=mype_share -! -!----------------------------------------------------------------------- -!*** Handles are needed for the mpi_waits associated with mpi_isend. -!*** Allocate the handle array and initialize it. -!----------------------------------------------------------------------- -! - if(.not.allocated(handle))then - allocate(handle(0:npes-1)) - do n=0,npes-1 - handle(n)=mpi_request_null - enddo -! - allocate(dummy_recv(msize_dummy_fft)) - allocate(dummy_send(msize_dummy_fft,ipe_start:ipe_end)) - endif -! -!----------------------------------------------------------------------- -!*** Each task holds full latitude circles of data within its own -!*** subset of model layers that it was assigned. We want to -!*** redistribute the data back to individual tasks whose domains -!*** actually contain the particular points. -! -!*** k1_fft and k2_fft provide the vertical limits for each task's -!*** group of model layers that it will use for FFT computation. -!*** In the general case, these layers and the points in them will -!*** come from other tasks. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Compute the number of words sent by mype to everyone. A task -!*** will only send to tasks that have FFT latitude circles that -!*** were specified to be handled by the sending task. -!*** The sender uses its own K extent and the receiver's I extent -!*** and the receiver's J extent that spans the appropriate -!*** FFT latitude rows computed by the sender. -!----------------------------------------------------------------------- -! - k1=k1_fft(mype) - k2=k2_fft(mype) - k_extent=k2-k1+1 -! - send_to_npe: do npe=ipe_start,ipe_end !<-- Tasks with FFT lats in this task's - ! hemisphere will receive -! - if(my_domain_has_fft_lats(npe))then !<--- Send back to only those tasks with FFT - ! lats in this hemisphere - istart=local_istart(npe) - iend=local_iend(npe) - i_extent=iend-istart+1 - jstart_fft_local=max(local_jstart(npe),my_jrow_start(mype)) - jend_fft_local=min(local_jend(npe),my_jrow_end(mype)) - j_extent=jend_fft_local-jstart_fft_local+1 -! - nn=0 !<--- Counter for number of words sent to - ! each task - if(j_extent>0)then -! - n=0 - nbuf=0 !<--- Counter for number of words inserted - ! into send buffer -! - do k=k1,k2 - n=n+1 - do j=jstart_fft_local,jend_fft_local - do i=istart,iend - nn=nn+1 - nbuf=nbuf+1 - dummy_send(nbuf,npe)=array_lyrs(i,j,n) - enddo - enddo - enddo -! -! call mpi_issend(dummy_send(1,npe),nbuf,mpi_real & - call mpi_isend(dummy_send(1,npe),nbuf,mpi_real & - ,npe,npe,mpi_comm_comp & - ,handle(npe),ierr) - endif -! - endif -! - enddo send_to_npe -! -!----------------------------------------------------------------------- -!*** Each task with FFT latitudes now fills in its output array. -!*** The data received from remote tasks is sized to the remote -!*** tasks' FFT computation layers and the local tasks' I extent -!*** and J extent that lie within FFT latitudes. -!----------------------------------------------------------------------- -! - if(my_domain_has_fft_lats(mype))then -! -!----------------------------------------------------------------------- -! - i_extent=ite-its+1 -! - recv_from_npe: do npe=ipe_start,ipe_end !<--- Tasks with FFT lats recv from - ! evryone in the hemisphere - ! who has computed any FFTs within - ! this task's FFT lats. - jstart_fft_local=max(jts,my_jrow_start(npe)) - jend_fft_local=min(jte,my_jrow_end(npe)) - if(jstart_fft_local>jend_fft_local)cycle - j_extent=jend_fft_local-jstart_fft_local+1 -! - iprod=max(i_extent*j_extent,0) -! - k1=k1_fft(npe) - k2=k2_fft(npe) - k_extent=k2-k1+1 -! - ncount_recv=iprod*k_extent !<-- # of words to receive from task npe -! - nbuf=0 !<--- Counter for words in recv buffer -! - call mpi_recv(dummy_recv,ncount_recv,mpi_real & - ,npe,mype & - ,mpi_comm_comp & - ,jstat & - ,ierr) -! - do k=k1,k2 - do j=jstart_fft_local,jend_fft_local - do i=its,ite - nbuf=nbuf+1 - field(i,j,k)=dummy_recv(nbuf) - enddo - enddo - enddo -! - enddo recv_from_npe -! - endif -! -!----------------------------------------------------------------------- -!*** Clear the ISend request handles. -!----------------------------------------------------------------------- -! - do npe=ipe_start,ipe_end -! - if(my_domain_has_fft_lats(npe))then !<--- Send back to only those tasks with FFT - call mpi_wait(handle(npe),jstat,ierr) - endif -! - enddo -! -!----------------------------------------------------------------------- -! - end subroutine scatter_layers -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! -!=============================================================== -! From Jim Abeles. -! Block partition the loop bounds (lb...ub) -> (i1...i2). -! The number of tasks is ntasks; taskid = 0, 1, ..., ntasks-1. -! The first nt1 tasks get a chunk one bigger than the rest. -! The counts and displacements arrays range from 1 to ntasks. -!=============================================================== -! - subroutine looplimits(taskid, ntasks, lb, ub, i1, i2) - implicit none - integer taskid, ntasks, lb, ub, i1, i2 - integer chunk, nwork, nt1, nt2 - integer itask, netdisp - integer counts(ntasks), displacements(ntasks) - - nwork = ub - lb + 1 - chunk = nwork/ntasks - nt1 = nwork - ntasks*chunk - nt2 = ntasks - nt1 - - netdisp = lb - do itask = 1, nt1 - counts(itask) = chunk + 1 - displacements(itask) = netdisp - netdisp = min(ub,netdisp+chunk+1) - end do - do itask = nt1 + 1 , ntasks - counts(itask) = chunk - displacements(itask) = netdisp - netdisp = min(ub,netdisp+chunk) - end do - - i1 = displacements(taskid+1) - i2 = min(ub,i1+counts(taskid+1)-1) - - return - end subroutine looplimits -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - end module module_dm_parallel -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- diff --git a/src/nmm/module_DOMAIN_GRID_COMP.F90 b/src/nmm/module_DOMAIN_GRID_COMP.F90 deleted file mode 100644 index 3a53ba1..0000000 --- a/src/nmm/module_DOMAIN_GRID_COMP.F90 +++ /dev/null @@ -1,11142 +0,0 @@ -!----------------------------------------------------------------------- -! - MODULE module_DOMAIN_GRID_COMP -! -!----------------------------------------------------------------------- -! -!*** This is the Domain gridded component module. -!*** It will set up Solver subcomponents -!*** and run their Initialize, Run, and Finalize routines. -! -!----------------------------------------------------------------------- -! -! PROGRAM HISTORY LOG: -! 2007- Black - Modified from Wei-yu's version -! 2007-11-20 Black/Henderson - Created an ESMF Clock for the -! ATM Component independent of -! the Main Clock. -! 2007-12-11 Black - Generalized for easier use by any dynamics core. -! 2008-08 Colon - Added conditional checks multiple dynamics cores. -! 2008-10-14 Vasic - Added restart Alarm. -! 2009-08-03 Black - Merging with nesting. -! 2009-08-12 Black - Fixed logic for Physics export when direction of -! integration switches from backward to forward. -! 2009-10-05 Wang - Added GFS ensemble member name and output data at -! every nsout timesteps. -! 2010-03-24 Black - Converted to Domain component for NMM-B only. -! 2010-11-03 Pyle - Revised for digital filters. -! 2010-12-16 Pyle - Change to nemsio library -! 2011-02 Yang - Updated to use both the ESMF 4.0.0rp2 library, -! ESMF 5 series library and the the -! ESMF 3.1.0rp2 library. -! 2011-05-11 Yang - Modified for using the ESMF 5.2.0r_beta_snapshot_07. -! 2011-07-16 Black - Moving nest capability. -! 2012-02-08 Yang - Modified for using the ESMF 5.2.0rp1 library. -! 2012-07-20 Black - Revised for generational task usage. -! 2016-07 Black - Modifications for ocean coupling - -! -! USAGE: Domain gridded component parts called from subroutines within -! module_NMM_GRID_COMP.F90. -! -!----------------------------------------------------------------------- -! - USE MPI - USE ESMF - USE netcdf -! - USE MODULE_KINDS -! - USE MODULE_CONSTANTS,ONLY : A,CP,G,P608,PI,TWOM -! - USE MODULE_DERIVED_TYPES,ONLY: BC_H_ALL,BC_V_ALL,MIXED_DATA -! - USE MODULE_DOMAIN_INTERNAL_STATE,ONLY: DOMAIN_INTERNAL_STATE & - ,WRAP_DOMAIN_INTERNAL_STATE - - USE MODULE_SOLVER_GRID_COMP,ONLY: SOLVER_REGISTER -! - USE MODULE_DM_PARALLEL,ONLY : IDS,IDE,JDS,JDE & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE & - ,IHALO,JHALO & - ,MPI_COMM_COMP & - ,MY_NEB -! - USE MODULE_CONTROL,ONLY: BOUNDARY_INIT & - ,GRID_CONSTS & - ,NUM_DOMAINS_MAX & - ,TIMEF -! - USE MODULE_DOMAIN_NUOPC_SET,ONLY: DOMAIN_DESCRIPTORS & - ,DUMP_DOMAIN_DESCRIPTOR & - ,NMMB_CreateDomainFields & - ,NMMB_CreateRouteHandle & - ,NMMB_GridCreate & - ,NMMB_GridUpdate & - ,ROTANGLE_CELLAREA_SEAMASK -! - USE MODULE_DIAGNOSE,ONLY: FIELD_STATS - USE NEMSIO_MODULE -! - USE MODULE_ERROR_MSG,ONLY: ERR_MSG,MESSAGE_CHECK -! - USE MODULE_VARS,ONLY: FIND_VAR_INDX & - ,TKR_I0D,TKR_I1D & - ,TKR_R0D,TKR_R1D & - ,VAR -! - USE MODULE_SOLVER_INTERNAL_STATE,ONLY: SOLVER_INTERNAL_STATE & - ,WRAP_SOLVER_INT_STATE -! - USE MODULE_NESTING,ONLY: CHECK & - ,LATLON_TO_IJ & - ,INTERNAL_DATA_TO_DOMAIN & - ,PARENT_TO_CHILD_INIT_NMM & - ,SUFFIX_MOVE & - ,SUFFIX_NESTBC & - ,SUFFIX_TWOWAY -! - USE MODULE_OUTPUT,ONLY: POINT_OUTPUT -! - USE MODULE_CLOCKTIMES,ONLY : TIMERS -! -!----------------------------------------------------------------------- -!*** List other modules with non-generic routines used by DOMAIN. -!----------------------------------------------------------------------- -! - USE MODULE_WRITE_ROUTINES ,ONLY: WRITE_INIT,WRITE_ASYNC !<-- These are routines used only when asynchronous - USE MODULE_WRITE_GRID_COMP,ONLY: WRITE_SETUP & ! quilting is specified by the user in the - ,WRITE_DESTROY ! configure file for history output. -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: DOMAIN_REGISTER,MY_DOMAIN_ID -! -!----------------------------------------------------------------------- -! - INTEGER(kind=KINT),SAVE :: N8=8 -! - INTEGER(kind=KINT) :: INPES & !<-- Forecast tasks in I on this domain's grid - ,JNPES & !<-- Forecast tasks in J on this domain's grid - ,LM & !<-- # of model layers - ,MYPE & !<-- Each MPI task ID - ,NPE_PRINT & - ,NLAYRS & !<-- Number of model layers - ,NTIMESTEP & !<-- Integration timestep - ,NUM_TRACERS_CHEM & !<-- Number of chemistry tracer variables - ,WRITE_GROUP_READY_TO_GO !<-- The write group to use -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE,SAVE :: COMM_FCST_TASKS !<-- Hold the intracommunicator for each domain's fcst tasks. -! - REAL(kind=DOUBLE) :: D2R,D_ONE,D_180,PI_LOC -! - REAL(kind=KFPT),SAVE :: ATM_OCN_CPL_INT=-999. !<-- The atmos-ocean coupling interval (sec) -! - REAL(kind=KFPT),SAVE :: SBD_1,TPH0D_1,TLM0D_1,WBD_1 !<-- SW corner & center (degrees) of upper parent -! - LOGICAL(kind=KLOG) :: QUILTING & !<-- Is asynchronous quilting specified? - ,WRITE_LAST_RESTART & !<-- Write last restart file? - ,RESTARTED_RUN !<-- Restarted run logical flag -! - TYPE(ESMF_VM),SAVE :: VM,VM_LOCAL !<-- The ESMF virtual machine. -! - TYPE(DOMAIN_INTERNAL_STATE),POINTER :: DOMAIN_INT_STATE !<-- Any given Domain internal state -! - TYPE(DOMAIN_INTERNAL_STATE),DIMENSION(:),POINTER,SAVE :: & - DOMAIN_INT_STATE_ALL !<-- The NMM Domain internal state pointer -! - TYPE(WRAP_DOMAIN_INTERNAL_STATE),SAVE :: WRAP !<-- The F90 wrap of the NMM Domain internal state -! - TYPE(SOLVER_INTERNAL_STATE),POINTER :: SOLVER_INT_STATE -! - TYPE(ESMF_Time),SAVE :: DFITIME & - ,HALFDFITIME -! - TYPE(ESMF_TimeInterval),SAVE :: HALFDFIINTVAL !<-- The ESMF time interval for filtering -! - TYPE(ESMF_Config),SAVE :: CF_ATMOS !<-- The atmos configure file - TYPE(ESMF_Config),DIMENSION(99),SAVE :: CF !<-- The configure objects for all NMM domains -! - LOGICAL(kind=KLOG) :: PHYSICS_ON !<-- Is physics active? -! -!----------------------------------------------------------------------- -! -!--------------------- -!*** For NMM Nesting -!--------------------- -! - INTEGER(kind=KINT),SAVE :: COMM_FULL_DOMAIN & !<-- Communicator for ALL tasks on domain to be split - ,COMM_MY_DOMAIN & !<-- Each domain's local intracommunicator - ,IM_1 & !<-- I dimension of uppermost parent domain - ,I_SHIFT_CHILD & !<-- Nest's shift in I in the nest's grid space - ,JM_1 & !<-- J dimension of uppermost parent domain - ,J_SHIFT_CHILD & !<-- Nest's shift in J in the nest's grid space - ,MY_DOMAIN_ID & !<-- Domain IDs; begin with uppermost parent=1 - ,NROWS_P_UPD_E & !<-- # of footprint E bndry rows using parent updates - ,NROWS_P_UPD_N & !<-- # of footprint N bndry rows using parent updates - ,NROWS_P_UPD_S & !<-- # of footprint S bndry rows using parent updates - ,NROWS_P_UPD_W & !<-- # of footprint W bndry rows using parent updates - ,NUM_CHILDREN & !<-- Number of (1st generation) children within a domain - ,NUM_FIELDS_MOVE_2D_H_I & !<-- # of 2-D integer H variables updated for moving nests - ,NUM_FIELDS_MOVE_2D_H_R & !<-- # of 2-D real H variables updated for moving nests - ,NUM_FIELDS_MOVE_3D_H & !<-- Number of 3-D H variables updated for moving nests - ,NUM_LEVELS_MOVE_3D_H & !<-- Number of 2-D levels in all 3-D H update variables - ,NUM_FIELDS_MOVE_2D_V & !<-- Number of 2-D V variables updated for moving nests - ,NUM_FIELDS_MOVE_3D_V & !<-- Number of 3-D V variables updated for moving nests - ,NUM_LEVELS_MOVE_3D_V & !<-- Number of 2-D levels in all 3-D V update variables - ,PARENT_CHILD_SPACE_RATIO & !<-- Ratio of parent's space increment to the nest's - ,PARENT_CHILD_TIME_RATIO !<-- # of child timesteps per parent timestep -! - INTEGER(kind=KINT),PARAMETER :: N_PTS_SEARCH_WIDTH=50 !<-- Search this far east/west/south/north from problem - ! point to fix moving nest sfc-type conflicts. -! - INTEGER(kind=KINT),PARAMETER :: N_PTS_SEARCH= & !<-- Search this many surrounding pts to fix moving nest - (2*N_PTS_SEARCH_WIDTH+1) & ! conflicts in sfc-type - *(2*N_PTS_SEARCH_WIDTH+1) -! - INTEGER(kind=KINT),DIMENSION(1:N_PTS_SEARCH),SAVE :: I_SEARCH_INC & !<-- I increment to search pt when fixing moving nest conflicts - ,J_SEARCH_INC !<-- J increment to search pt when fixing moving nest conflicts -! - INTEGER(kind=KINT),DIMENSION(:),POINTER,SAVE :: MY_CHILDREN_ID !<-- A parent's children's domain IDs -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: NTIMESTEP_CHILD_MOVES -! - REAL(kind=KFPT),SAVE :: EPS=1.E-4 -! - REAL(kind=KFPT),SAVE :: ACDT & !<-- A divergence damping coefficient - ,CDDAMP & !<-- Divergence damping coefficient - ,DEG_TO_RAD & !<-- To convert from degrees to radians - ,DLM & !<-- Nest grid increment in X (radians) - ,DPH & !<-- Nest grid increment in Y (radians) - ,DT_REAL & !<-- The dynamical timestep (s) - ,RECIP_DPH_1,RECIP_DLM_1 & !<-- Reciprocals of upper parent grid increments (radians) - ,SB_1,WB_1 & !<-- Rotated S/W bndries of upper parent grid (radians, N/E) - ,TLM0 & !<-- Central longitude of domain (radians) - ,TPH0 & !<-- Central latitude of domain (radians) - ,TPH0_1,TLM0_1 & !<-- Central lat/lon of upper parent domain (radians, N/E) - ,WCOR -! - LOGICAL(kind=KLOG),SAVE :: DOMAIN_MOVES & !<-- Does my nested domain move? - ,GLOBAL_TOP_PARENT !<-- Is the uppermost parent a global domain? -! - LOGICAL(kind=KLOG) :: I_AM_A_NEST & !<-- Is the domain a nest? - ,INPUT_READY & !<-- If a nest, does its input file already exist? - ,MY_DOMAIN_MOVES !<-- Does this domain move? -! - CHARACTER(len=7) :: SFC_CONFLICT -! - TYPE :: DIST - REAL(kind=KFPT) :: VALUE - INTEGER(kind=KINT) :: I_INC - INTEGER(kind=KINT) :: J_INC - TYPE(DIST),POINTER :: NEXT_VALUE - END TYPE -! - TYPE(DIST),DIMENSION(:),POINTER,SAVE :: LARGEX,SMALLX -! -!--------------------------------- -!*** For determining clocktimes. -!--------------------------------- -! - REAL(kind=KDBL) :: btim,btim0 -! -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE DOMAIN_REGISTER(DOMAIN_GRID_COMP,RC_REG) -! -!----------------------------------------------------------------------- -!*** Register the Domain component's Initialize, Run, and Finalize -!*** routines. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_GridComp) :: DOMAIN_GRID_COMP !<-- Domain gridded component -! - INTEGER,INTENT(OUT) :: RC_REG !<-- Return code for register -! -!----------------------------------------------------------------------- -!*** Local Variables -!----------------------------------------------------------------------- -! - INTEGER :: RC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS ! Error signal variable - RC_REG=ESMF_SUCCESS ! Error signal variable -! -!----------------------------------------------------------------------- -!*** Register the Domain Initialize subroutine. Since it is just one -!*** subroutine, use ESMF_SINGLEPHASE. The second argument is -!*** a pre-defined subroutine type, such as ESMF_SETINIT, ESMF_SETRUN, -!*** or ESMF_SETFINAL. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create/Load the Configure Object" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - -! - CALL ESMF_GridCompSetEntryPoint(DOMAIN_GRID_COMP & !<-- Domain gridded component - ,ESMF_METHOD_INITIALIZE & !<-- Subroutine type (Initialize) - ,DOMAIN_INITIALIZE & !<-- User's subroutine name - ,phase=1 & - ,rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Register the Run step of the Domain component. -!*** The NMM needs three phases of Run. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set 1st Entry Point for the Domain Run Step" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSetEntryPoint(DOMAIN_GRID_COMP & !<-- The Domain component - ,ESMF_METHOD_RUN & !<-- Subroutine type (Run) - ,DOMAIN_RUN & !<-- The user's subroutine name for primary integration - ,phase=1 & - ,rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set 2nd Entry Point for the Domain Run Step" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSetEntryPoint(DOMAIN_GRID_COMP & !<-- The Domain component - ,ESMF_METHOD_RUN & !<-- Subroutine type (Run) - ,NMM_FILTERING & !<-- Routine to govern digital filtering each timestep - ,phase=2 & - ,rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set 3rd Entry Point for the Domain Run Step" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSetEntryPoint(DOMAIN_GRID_COMP & !<-- The Domain component - ,ESMF_METHOD_RUN & !<-- Subroutine type (Run) - ,CALL_WRITE_ASYNC & !<-- Routine to call asynchronous output - ,phase=3 & - ,rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Register the Domain Finalize subroutine. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for Domain Finalize" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSetEntryPoint(DOMAIN_GRID_COMP & !<-- The Domain component - ,ESMF_METHOD_FINALIZE & !<-- Subroutine type (Finalize) - ,DOMAIN_FINALIZE & !<-- User's subroutine name - ,phase=1 & - ,rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Check the error signal variable and print out the result. -!----------------------------------------------------------------------- -! - IF(RC_REG==ESMF_SUCCESS)THEN -! WRITE(0,*)' DOMAIN_REGISTER succeeded' - ELSE - WRITE(0,*)' DOMAIN_REGISTER failed RC_REG=',RC_REG - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE DOMAIN_REGISTER -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE DOMAIN_INITIALIZE(DOMAIN_GRID_COMP & - ,IMP_STATE & - ,EXP_STATE & - ,CLOCK_DOMAIN & - ,RC_INIT) -! -!----------------------------------------------------------------------- -!*** This routine sets up fundamental aspects of the model run. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_GridComp) :: DOMAIN_GRID_COMP !<-- The Domain component -! - TYPE(ESMF_State) :: IMP_STATE & !<-- The Domain component's import state - ,EXP_STATE !<-- The Domain component's export state - - TYPE(ESMF_Clock) :: CLOCK_DOMAIN !<-- The ESMF Clock from the NMM component. -! - INTEGER,INTENT(OUT) :: RC_INIT !<-- Return code for Initialize step -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: CONFIG_ID,FILT_METHOD_CHILD & - ,I,ISTAT,J,LB,LNSH,LNSV & - ,MAX_DOMAINS,N,NLEV_H,NLEV_V & - ,NFCST,NPHS,NTSD,NUM_DOMAINS,NUM_FIELDS & - ,NUM_PES_FCST,NV & - ,NVARS_BC_2D_H,NVARS_BC_3D_H,NVARS_BC_4D_H & - ,NVARS_BC_2D_V,NVARS_BC_3D_V & - ,NVARS_NESTBC_H,NVARS_NESTBC_V & - ,SFC_FILE_RATIO,UB,UBOUND_VARS,NTRACK -! - INTEGER(kind=KINT) :: IYEAR_FCST & !<-- Current year from restart file - ,IMONTH_FCST & !<-- Current month from restart file - ,IDAY_FCST & !<-- Current day from restart file - ,IHOUR_FCST & !<-- Current hour from restart file - ,IMINUTE_FCST & !<-- Current minute from restart file - ,ISECOND_FCST !<-- Current second from restart file -! - INTEGER(kind=KINT) :: DT_INT,DT_DEN,DT_NUM & !<-- Integer,fractional parts of timestep - ,NHOURS_CLOCKTIME !<-- Hours between clocktime prints - - INTEGER(kind=KINT) :: FILT_DT_INT,FILT_DT_DEN,FILT_DT_NUM & !<-- Integer,fractional parts of timestep used - ,FILT_METHOD ! by the digital filter, plus the method -! - INTEGER(kind=KINT) :: IHI,ILO,JHI,JLO -! - INTEGER(kind=KINT) :: I_PAR_STA, J_PAR_STA & - ,LAST_STEP_MOVED,NEXT_MOVE_TIMESTEP & - ,TRACKER_IFIX,TRACKER_JFIX -! - INTEGER(kind=KINT) :: IERR,IRTN,RC -! - INTEGER(ESMF_KIND_I8) :: NTSD_START !<-- Timestep count (>0 for restarted runs) -! - INTEGER(kind=KINT),DIMENSION(2) :: STORM_CENTER -! - INTEGER(kind=KINT),DIMENSION(7) :: FCSTDATE -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: DOMAIN_ID_TO_RANK !<-- Associate configure file IDs with domains -! - REAL(kind=KFPT) :: CODAMP & - ,DLMD,DPHD & !<-- Current second from restart file - ,DPH_1,DLM_1 & - ,SECOND_FCST & !<-- Current second from restart file - ,SMAG2 & !<-- Smagorinsky constant - ,TLM0D & !<-- Central longitude of uppermost parent (degrees) - ,TPH0D !<-- Central latitude of uppermost parent (degrees) -! - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: SEA_MASK=>NULL() -! - LOGICAL(kind=KLOG),SAVE :: ALLOC_FLAG=.FALSE. -! - LOGICAL(kind=KLOG) :: CALL_BUILD_MOVE_BUNDLE & - ,CFILE_EXIST & - ,I_AM_ACTIVE & - ,INPUT_READY_MY_CHILD & - ,NEMSIO_INPUT & - ,OPENED -! - LOGICAL(kind=KLOG) :: I_AM_A_FCST_TASK & - ,I_AM_A_PARENT -! - LOGICAL(kind=KLOG),DIMENSION(:),ALLOCATABLE :: CHILD_ACTIVE -! - CHARACTER(2) :: INT_TO_CHAR - CHARACTER(5) :: NEST_MODE - CHARACTER(6) :: FMT='(I2.2)' - CHARACTER(64) :: RESTART_FILENAME - CHARACTER(99) :: BUNDLE_NAME & - ,CONFIG_FILE_NAME & - ,FIELD_NAME -! - TYPE(ESMF_Time) :: CURRTIME & !<-- The ESMF current time. - ,STARTTIME !<-- The ESMF start time. -! - TYPE(ESMF_Grid) :: GRID_DOMAIN !<-- The ESMF GRID for the integration attached to - ! the NMM Domain component. - TYPE(ESMF_Grid) :: GRID_SOLVER !<-- The ESMF GRID for the integration attached to - ! the NMM Solver gridded component. - TYPE(ESMF_Field) :: HOLD_FIELD -! - TYPE(ESMF_State) :: IMP_STATE_WRITE -! - TYPE(NEMSIO_GFILE) :: GFILE -! - TYPE(WRAP_SOLVER_INT_STATE) :: WRAP_SOLVER -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RC_INIT=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** Initialize timing variables. -!----------------------------------------------------------------------- -! - btim0=timef() -! -!----------------------------------------------------------------------- -!*** Take the domain count and this domain's ID from the -!*** import state. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Domain Count from Domain Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The Domain import state - ,name ='NUM_DOMAINS' & !<-- Name of the domain count - ,value =NUM_DOMAINS & !<-- The # of domains - ,defaultValue=1 & !<-- The default value - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Domain_Initialize: Extract Domain ID from Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The Domain import state - ,name ='DOMAIN_ID' & !<-- Name of the attribute to extract - ,value =MY_DOMAIN_ID & !<-- The ID of this domain - ,defaultValue=1 & !<-- The default value - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Initialize timers for this domain. -!----------------------------------------------------------------------- -! - IF(.NOT.ALLOCATED(TIMERS) ) ALLOCATE(TIMERS(1:NUM_DOMAINS)) - timers(my_domain_id)%total_integ_tim=0. - timers(my_domain_id)%update_interior_from_nest_tim =0. - timers(my_domain_id)%update_interior_from_parent_tim=0. -! -!----------------------------------------------------------------------- -!*** To allow a given MPI task to lie on more than one domain -!*** the domain's internal state will be an element of an array -!*** so that each internal state is unique. -!*** It might be more straight forward to allocate the domain -!*** internal state array alongside the creation of the domain -!*** components themselves but that takes place in the Init step -!*** of the NMM component and we do not want the Domain internal -!*** state module to be visible there. -!----------------------------------------------------------------------- -! - IF(.NOT.ALLOC_FLAG)THEN - ALLOCATE(DOMAIN_INT_STATE_ALL(1:NUM_DOMAINS),stat=RC) - IF(RC/=0)THEN - WRITE(0,*)' Failed to allocate DOMAIN_INT_STATE_ALL array rc=',RC - ENDIF - ALLOC_FLAG=.TRUE. - ENDIF -! - wrap%DOMAIN_INT_STATE=>DOMAIN_INT_STATE_ALL(MY_DOMAIN_ID) - DOMAIN_INT_STATE =>DOMAIN_INT_STATE_ALL(MY_DOMAIN_ID) -! -!----------------------------------------------------------------------- -!*** Attach the Domain internal state to the Domain component. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Attach Domain Internal State to Gridded Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSetInternalState(DOMAIN_GRID_COMP & !<-- The Domain gridded component - ,WRAP & !<-- Pointer to the Domain internal state - ,RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Retrieve the VM (Virtual Machine) of the Domain component. -!*** Call ESMF_GridCompGet to retrieve the VM anywhere you need it. -!*** We need VM now to obtain the MPI task IDs and the local MPI -!*** communicator. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="DOMAIN_INIT: Retrieve VM from Domain Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGet(gridcomp=DOMAIN_GRID_COMP & !<-- The Domain component - ,vm =VM & !<-- Get the Virtual Machine from the Domain component - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="DOMAIN_INIT: Obtain Task IDs and Communicator" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_VMGet(vm =VM & !<-- The virtual machine - ,localpet =MYPE & !<-- Each MPI task ID - ,mpiCommunicator=COMM_MY_DOMAIN & !<-- This domain's intracommunicator - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Extract the maximum number of domains from the import state. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract MAX_DOMAINS from Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The Domain import state - ,name ='MAX_DOMAINS' & !<-- Name of the attribute to extract - ,value =MAX_DOMAINS & !<-- Maximum # of domains - ,defaultValue=1 & !<-- The default value - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Extract the configure file IDs associated with each domain. -!----------------------------------------------------------------------- -! - ALLOCATE(DOMAIN_ID_TO_RANK(1:MAX_DOMAINS),stat=ISTAT) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Association of Configure Files with Domains" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The Domain import state - ,name ='DOMAIN_ID_TO_RANK' & !<-- Name of the attribute to extract - ,itemCount =MAX_DOMAINS & !<-- Name of the attribute to extract - ,valueList =DOMAIN_ID_TO_RANK & !<-- The ID of this domain - ,defaultvalueList=[1] & !<-- The default valueList - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Now we can load configure files for all domains into memory. -!*** The file name of the uppermost domain is 'configure_file_01' -!*** and is identical to the primary file called 'configure_file' -!*** which is needed in some early parts of the setup. -!----------------------------------------------------------------------- -! - DO N=1,MAX_DOMAINS !<-- The number of config files cannot exceed 99 -! - CONFIG_ID=DOMAIN_ID_TO_RANK(N) - WRITE(INT_TO_CHAR,FMT)CONFIG_ID - CONFIG_FILE_NAME='configure_file_'//INT_TO_CHAR !<-- Prepare the config file names -! - CFILE_EXIST=.FALSE. - INQUIRE(file=CONFIG_FILE_NAME,exist=CFILE_EXIST) -! - IF(CFILE_EXIST)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create the Nest Configure Object" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CF(N)=ESMF_ConfigCreate(rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load the Nest Configure Object" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigLoadFile(config =CF(N) & - ,filename=CONFIG_FILE_NAME & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ELSE -! - EXIT -! - ENDIF -! - ENDDO -! - DEALLOCATE(DOMAIN_ID_TO_RANK) -! -!----------------------------------------------------------------------- -!*** If the atmosphere is coupled to an ocean then the -!*** atm.configure file holds the coupling time interval. -!*** Extract it so we know when to update the atmosphere's -!*** SST in DOMAIN_RUN. -!----------------------------------------------------------------------- -! - CONFIG_FILE_NAME='atmos.configure' !<-- The config file name - CFILE_EXIST=.FALSE. - INQUIRE(file=CONFIG_FILE_NAME,exist=CFILE_EXIST) -! - IF(CFILE_EXIST)THEN -! - CF_ATMOS=ESMF_ConfigCreate(rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load the Nest Configure Object" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigLoadFile(config =CF_ATMOS & - ,filename=CONFIG_FILE_NAME & - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Atmos-Ocean Coupling Interval from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF_ATMOS & !<-- The config object - ,value =ATM_OCN_CPL_INT & !<-- The atm-ocean coupling interval (sec) - ,label ='atm_coupling_interval_sec:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Shall we write last time step restart file? -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Write_last_restart Flag from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The config object - ,value =WRITE_LAST_RESTART & !<-- The quilting flag - ,label ='write_last_restart:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - domain_int_state%WRITE_LAST_RESTART=WRITE_LAST_RESTART !<-- Save this for the write_async -! -! -!----------------------------------------------------------------------- -!*** Will the Write components with asynchronous quilting be used? -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Quilting Flag from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The config object - ,value =QUILTING & !<-- The quilting flag - ,label ='quilting:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - domain_int_state%QUILTING=QUILTING !<-- Save this for the Run step -! -!----------------------------------------------------------------------- -!*** Initialize the flag indicating if the first history output has -!*** been written out. -!----------------------------------------------------------------------- -! - domain_int_state%WROTE_1ST_HIST=.FALSE. -! -!----------------------------------------------------------------------- -!*** The task layout on this domain. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract MPI Task Layout in Domain Init" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The config object - ,value =INPES & !<-- The # of forecast tasks in I - ,label ='inpes:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The config object - ,value =JNPES & !<-- The # of forecast tasks in J - ,label ='jnpes:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Extract the physics call frequency from the configure file. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract NPHS in Domain Init" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The config object - ,value =NPHS & !<-- The physics call frequency - ,label ='nphs:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert NPHS into the Domain export state" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The config object - ,name ='NPHS' & !<-- The name in the export state - ,value=NPHS & !<-- The physics call frequency - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!----------------------------------------------------------------------- -!*** Extract the domain boundary blending width. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract LNSH,LNSV in Domain Init" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The config object - ,value =LNSH & !<-- Domain bndry blending width for H points - ,label ='lnsh:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The config object - ,value =LNSV & !<-- Domain bndry blending width for V points - ,label ='lnsv:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Extract this Domain component's Nest/Not-a-Nest flag -!*** from the import state. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Nest/Not-a-Nest Flag from Domain Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The Domain import state - ,name ='I-Am-A-Nest Flag' & !<-- Name of the attribute to extract - ,value =I_AM_A_NEST & !<-- The flag indicating if this domain is a nest - ,defaultValue=.false. & !<-- The default value - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Save the nest flag in the Domain's internal state so it can be -!*** referred to in the Run step. -!----------------------------------------------------------------------- -! - domain_int_state%I_AM_A_NEST=I_AM_A_NEST -! -!----------------------------------------------------------------------- -!*** Extract the ratio of the parent timestep to the child's if -!*** this domain is a nest. -!*** Also extract the flag indicating whether or not the nest's -!*** input file has already been generated by NPS. -!----------------------------------------------------------------------- -! - IF(I_AM_A_NEST)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Parent-Child Time Ratio from Domain Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Domain import state - ,name ='Parent-Child Time Ratio' & !<-- Name of Attribute - ,value=PARENT_CHILD_TIME_RATIO & !<-- Ratio of this domain's parent's timestep to its own - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Input Ready Flag from Configure File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The config object - ,value =INPUT_READY & !<-- The variable filled (does nest input file exist? - ,label ='input_ready:' & !<-- The input datafile for this domain does or does not exist - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Parent-Child Space Ratio from Configure File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The config object - ,value =PARENT_CHILD_SPACE_RATIO & !<-- The variable filled (child grid increment / parent's) - ,label ='parent_child_space_ratio:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** The nest must know whether or not it moves. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Move Flag From Nest Configure Files" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- This domain's configure object - ,value =MY_DOMAIN_MOVES & !<-- Does this domain move? - ,label ='my_domain_moves:' & !<-- The label in the configure file - ,rc =rc) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - domain_int_state%MY_DOMAIN_MOVES=MY_DOMAIN_MOVES -! -!----------------------------------------------------------------------- -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Does this forecast use 2-way exchange? -!----------------------------------------------------------------------- -! - NEST_MODE=' ' -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract 2-way Flag From Nest Configure Files" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- This domain's configure object - ,value =NEST_MODE & !<-- Is there 2-way exchange from child to parent? - ,label ='nest_mode:' & !<-- The label in the configure file - ,rc =rc) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Extract the start time from the clock. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="DOMAIN_INIT: Start Time from Domain Clock" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock =CLOCK_DOMAIN & !<-- The ESMF Clock of this domain - ,startTime=STARTTIME & !<-- The simulation start time - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CURRTIME=STARTTIME - NTSD_START=0 -! -!----------------------------------------------------------------------- -!*** Extract the NEMSIO_INPUT flag from the configure file. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract NEMSIO Flag from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The config object - ,value =NEMSIO_INPUT & !<-- The input datafile does or does not have NEMSIO metadata - ,label ='nemsio_input:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Extract the RESTART flag from the configure file. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Restart Flag from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The config object - ,value =RESTARTED_RUN & !<-- True => restart; False => cold start - ,label ='restart:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - domain_int_state%RESTARTED_RUN=RESTARTED_RUN -! - domain_int_state%RESTARTED_RUN_FIRST=.TRUE. !<-- Prepare for the initial output for a restarted run. -! -!----------------------------------------------------------------------- -!*** If this is a restarted run then read: -!*** (1) The forecast time that the file was written. -!*** (2) The forecast timestep at which the file was written. -!----------------------------------------------------------------------- -! - NTSD_START=0 -! - restart: IF(RESTARTED_RUN)THEN !<-- If this is a restarted run, set the current time -! - WRITE(INT_TO_CHAR,FMT)MY_DOMAIN_ID -! -!---------------------------------------------------------------------- -!*** Read the restart data from either pure binary or NEMSIO file. -!----------------------------------------------------------------------- -! - input: IF(NEMSIO_INPUT)THEN -! - CALL NEMSIO_INIT() -! - RESTART_FILENAME='restart_file_'//INT_TO_CHAR//'_nemsio' - CALL NEMSIO_OPEN(GFILE,RESTART_FILENAME,'read',iret=IRTN) - IF(IRTN/=0)THEN - WRITE(0,*)' Unable to open nemsio file ' & - ,TRIM(RESTART_FILENAME),' in DOMAIN_INITIALIZE' - WRITE(0,*)' ABORTING!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT & - ,rc =RC) - ENDIF -! - CALL NEMSIO_GETHEADVAR(GFILE,'FCSTDATE',FCSTDATE,iret=irtn) -! - IYEAR_FCST =FCSTDATE(1) - IMONTH_FCST =FCSTDATE(2) - IDAY_FCST =FCSTDATE(3) - IHOUR_FCST =FCSTDATE(4) - IMINUTE_FCST=FCSTDATE(5) - SECOND_FCST =0. -! - IF(FCSTDATE(7)/=0)THEN - SECOND_FCST=FCSTDATE(6)/(FCSTDATE(7)*1.) - ENDIF -! - CALL NEMSIO_GETHEADVAR(gfile,'NTIMESTEP',NTSD,iret=irtn) - - CALL NEMSIO_CLOSE(GFILE,iret=IERR) -! - ELSE !<-- Pure binary input -! - select_unit: DO N=51,59 - INQUIRE(N,OPENED=OPENED) - IF(.NOT.OPENED)THEN - NFCST=N - EXIT select_unit - ENDIF - ENDDO select_unit -! - RESTART_FILENAME='restart_file_'//INT_TO_CHAR - OPEN(unit=NFCST,file=RESTART_FILENAME,status='old' & - ,form='unformatted',iostat=IRTN) - IF(IRTN/=0)THEN - WRITE(0,*)' Unable to open pure binary file ' & - ,TRIM(RESTART_FILENAME),' in DOMAIN_INITIALIZE' - WRITE(0,*)' ABORTING!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT & - ,rc =RC) - ENDIF -! - READ(NFCST) IYEAR_FCST !<-- Read time form restart file - READ(NFCST) IMONTH_FCST ! - READ(NFCST) IDAY_FCST ! - READ(NFCST) IHOUR_FCST ! - READ(NFCST) IMINUTE_FCST ! - READ(NFCST) SECOND_FCST !<-- -! - READ(NFCST) NTSD !<-- Read timestep from restart file -! - CLOSE(NFCST) -! - ENDIF input -! -!----------------------------------------------------------------------- -! - ISECOND_FCST=NINT(SECOND_FCST) !<-- ESMF clock needs integer seconds - NTSD_START=NTSD -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="RESTART: Set the Current Time of the Forecast" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeSet(time=CURRTIME & !<-- Current time of the forecast (ESMF) - ,yy =IYEAR_FCST & !<-- Year from restart file - ,mm =IMONTH_FCST & !<-- Month from restart file - ,dd =IDAY_FCST & !<-- Day from restart file - ,h =IHOUR_FCST & !<-- Hour from restart file - ,m =IMINUTE_FCST & !<-- Minute from restart file - ,s =ISECOND_FCST & !<-- Second from restart file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- - ENDIF restart -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** With data from above set the local ESMF Clock -!*** to its correct time and timestep. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set the Current Time on the Domain Clock" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockSet(clock =CLOCK_DOMAIN & !<-- The Domain Component's Clock - ,currtime =CURRTIME & !<-- Current time of simulation - ,advanceCount=NTSD_START & !<-- Timestep at this current time - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Create the time interval for printing clocktimes used by model -!*** sections. Read in forecast time interval for clocktime output -!*** as well as the selected task ID that will provide the clocktimes. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Read Fcst Interval for Clocktime Output" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The configure object - ,value =NHOURS_CLOCKTIME & !<-- Fill this variable - ,label ='nhours_clocktime:' & !<-- Give the variable this label's value from the config file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Read MPI Task ID That Provides Clocktime Output" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The configure object - ,value =NPE_PRINT & !<-- Fill this variable - ,label ='npe_print:' & !<-- Give the variable this label's value from the config file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** How many tracer species are there? -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="DOMAIN_Init: Extract # of tracers from Config file" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The config object - ,value =NUM_TRACERS_CHEM & !<-- The variable filled (number of chemical tracers) - ,label ='num_tracers_chem:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** Model-specific routines must be invoked in order to establish -!*** the ESMF Grid. The different integration grids necessitate -!*** different ways of setting up both the parallelism for -!*** distributed memory runs and the ESMF Grid itself. -!*** When the parallelism is constructed, the local domain limits -!*** need to be inserted into the Domain component's internal state -!*** if quilting is to be used. See 'IF(QUILTING)THEN' below. -!----------------------------------------------------------------------- -! - WRITE(0,*)' ' - WRITE(0,11110)MY_DOMAIN_ID -11110 format(' DOMAIN_SETUP my_domain_id=',i2) - CALL DOMAIN_SETUP(MYPE & - ,COMM_MY_DOMAIN & - ,QUILTING & - ,CF(MY_DOMAIN_ID) & - ,DOMAIN_GRID_COMP & - ,DOMAIN_INT_STATE & - ,GRID_DOMAIN ) -! -!----------------------------------------------------------------------- -!*** Save the intracommunicator for this domain's forecast tasks -!*** since it is used each timestep in DOMAIN_RUN. -!----------------------------------------------------------------------- -! - IF(.NOT.ALLOCATED(COMM_FCST_TASKS))THEN - ALLOCATE(COMM_FCST_TASKS(1:NUM_DOMAINS)) - ENDIF -! - COMM_FCST_TASKS(MY_DOMAIN_ID)=MPI_COMM_COMP -! -!----------------------------------------------------------------------- -!*** Attach the NMM-specific ESMF Grid to the Domain component. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Attach the NMM ESMF Grid to the Domain Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSet(gridcomp=DOMAIN_GRID_COMP & !<-- The Domain component - ,grid =GRID_DOMAIN & !<-- Attach the ESMF grid to the Domain component - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** Create the Solver gridded subcomponent. -!*** Register the Initialize, Run, and Finalize steps for it. -!*** Since there is only a single integration grid, give the -!*** Solver the Domain component's grid. -!*** Note that this subcomponent is part of the Domain component's -!*** internal state. This will be convenient if we need to reach -!*** the Solver component via the Domain component such as happens -!*** when Write components are established. -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!--------------------------------- -!*** Create the Solver component -!--------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create the NMM Solver Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - domain_int_state%SOLVER_GRID_COMP=ESMF_GridCompCreate( & - name ="Solver component" & !<-- Name of the new Solver gridded component - ,config =CF(MY_DOMAIN_ID) & !<-- Attach this configure file to the component - ,petList=domain_int_state%PETLIST_FCST & !<-- The LOCAL forecast task IDs - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!------------------------------------------------ -!*** Register the Init, Run, and Finalize steps -!------------------------------------------------ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Register the NMM Solver Init, Run, Finalize" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSetServices(domain_int_state%SOLVER_GRID_COMP & ! <-- The Solver gridded component - ,SOLVER_REGISTER & ! <-- The user's subroutineName for Register - ,rc = RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!---------------------------------------------------- -!*** Attach the ESMF Grid to the Solver component -!---------------------------------------------------- -! - GRID_SOLVER=GRID_DOMAIN !<-- The Solver grid is the same as the Domain grid -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Attach the ESMF Grid to the Solver Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSet(gridcomp=domain_int_state%SOLVER_GRID_COMP & !<-- The Solver component - ,grid =GRID_SOLVER & !<-- The Solver ESMF grid - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Create empty import and export states for the Solver component. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create Empty Import/Export States for the Solver" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - domain_int_state%IMP_STATE_SOLVER=ESMF_StateCreate( & - name ="Solver Import" & !<-- The Solver import state name - ,stateintent=ESMF_STATEINTENT_IMPORT & - ,rc =RC) -! - domain_int_state%EXP_STATE_SOLVER=ESMF_StateCreate( & - name ="Solver Export" & !<-- The Solver export state name - ,stateintent=ESMF_STATEINTENT_EXPORT & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Extract the flag from the Domain import state indicating if the -!*** user wants physics to be active. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Physics Flag from Domain Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & - ,name ='PHYSICS_ON' & - ,value =PHYSICS_ON & - ,defaultValue=.true. & - ,rc =rc) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Add fundamental domain characteristics to the Solver's -!*** import state that will be needed by that component. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Domain Dimensions to the Solver Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=domain_int_state%IMP_STATE_SOLVER & !<-- The Solver component import state - ,name ='ITS' & !<-- Use this name inside the state - ,value=ITS & !<-- The scalar being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state=domain_int_state%IMP_STATE_SOLVER & !<-- The Solver component import state - ,name ='ITE' & !<-- Use this name inside the state - ,value=ITE & !<-- The scalar being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state=domain_int_state%IMP_STATE_SOLVER & !<-- The Solver component import state - ,name ='JTS' & !<-- Use this name inside the state - ,value=JTS & !<-- The scalar being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state=domain_int_state%IMP_STATE_SOLVER & !<-- The Solver component import state - ,name ='JTE' & !<-- Use this name inside the state - ,value=JTE & !<-- The scalar being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state=domain_int_state%IMP_STATE_SOLVER & !<-- The Solver component import state - ,name ='IMS' & !<-- Use this name inside the state - ,value=IMS & !<-- The scalar being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state=domain_int_state%IMP_STATE_SOLVER & !<-- The Solver component import state - ,name ='IME' & !<-- Use this name inside the state - ,value=IME & !<-- The scalar being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state=domain_int_state%IMP_STATE_SOLVER & !<-- The Solver component import state - ,name ='JMS' & !<-- Use this name inside the state - ,value=JMS & !<-- The scalar being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state=domain_int_state%IMP_STATE_SOLVER & !<-- The Solver component import state - ,name ='JME' & !<-- Use this name inside the state - ,value=JME & !<-- The scalar being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state=domain_int_state%IMP_STATE_SOLVER & !<-- The Solver component import state - ,name ='IDS' & !<-- Use this name inside the state - ,value=IDS & !<-- The scalar being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state=domain_int_state%IMP_STATE_SOLVER & !<-- The Solver component import state - ,name ='IDE' & !<-- Use this name inside the state - ,value=IDE & !<-- The scalar being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state=domain_int_state%IMP_STATE_SOLVER & !<-- The Solver component import state - ,name ='JDS' & !<-- Use this name inside the state - ,value=JDS & !<-- The scalar being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state=domain_int_state%IMP_STATE_SOLVER & !<-- The Solver component import state - ,name ='JDE' & !<-- Use this name inside the state - ,value=JDE & !<-- The scalar being inserted into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Halo Widths to Solver Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=domain_int_state%IMP_STATE_SOLVER & !<-- The Solver component import state - ,name ='IHALO' & !<-- Use this name inside the state - ,value=IHALO & !<-- The scalar being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state=domain_int_state%IMP_STATE_SOLVER & !<-- The Solver component import state - ,name ='JHALO' & !<-- Use this name inside the state - ,value=JHALO & !<-- The scalar being inserted into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Fcst/Quilt Intracomms to the Solver Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=domain_int_state%IMP_STATE_SOLVER & !<-- The Solver component import state - ,name ='Fcst/Quilt Intracommunicators' & !<-- Use this name inside the state - ,value=MPI_COMM_COMP & !<-- The scalar being inserted into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Domain ID to the Solver Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=domain_int_state%IMP_STATE_SOLVER & !<-- The Solver component import state - ,name ='DOMAIN_ID' & !<-- Use this name inside the state - ,value=MY_DOMAIN_ID & !<-- The scalar being inserted into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Task Neighbors to the Solver Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state =domain_int_state%IMP_STATE_SOLVER & !<-- The Solver component import state - ,name ='MY_NEB' & !<-- Use this name inside the state - ,itemCount=N8 & !<-- # of items in Attribute - ,valueList=MY_NEB & !<-- The scalar being inserted into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Task Neighbors to the Domain Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state =EXP_STATE & !<-- The Domain component export state - ,name ='MY_NEB' & !<-- Use this name inside the state - ,itemCount=N8 & !<-- # of items in Attribute - ,valueList=MY_NEB & !<-- The scalar being inserted into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!------------------------------------------------------------------------ -!*** Insert the flag indicating if the Domain component is a nest. -!*** The Solver component needs to know this regarding BC's in -!*** order to properly compute fundamental aspects of the -!*** nested grids. -!------------------------------------------------------------------------ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="DOMAIN_INIT: Add Nest Flag to the Solver Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=domain_int_state%IMP_STATE_SOLVER & !<-- The Solver component import state - ,name ='I-Am-A-Nest Flag' & !<-- Use this name inside the state - ,value=I_AM_A_NEST & !<-- The logical being inserted into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!------------------------------------------------------------------------ -!*** Is the uppermost parent on a global domain? We must know this -!*** for moving nests' reading the external surface files that span -!*** that domain. -!------------------------------------------------------------------------ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Is Domain #1 Global?" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(1) & !<-- The config object of domain #1 - ,value =GLOBAL_TOP_PARENT & !<-- The variable filled - ,label ='global:' & !<-- True--> uppermost parent is on a global domain. - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!------------------------------------------------------------------------ -!*** Add the transformed lat/lon (degrees) of the SW corner of domain #1 -!*** domain #1 and the geographic lat/lon of its center to the Solver -!*** import state. That information will be used if this is a restarted -!*** run containing moving nests in order to precisely determine the -!*** location of those nests. -!------------------------------------------------------------------------ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Southern/Western Boundary of Uppermost Domain" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(1) & !<-- The config object of domain #1 - ,value =SBD_1 & !<-- The variable filled - ,label ='sbd:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF(1) & !<-- The config object of domain #1 - ,value =WBD_1 & !<-- The variable filled - ,label ='wbd:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="DOMAIN_INIT: Add SW Corner of Domain #1 to Solver Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=domain_int_state%IMP_STATE_SOLVER & !<-- The Solver component import state - ,name ='SBD_1' & !<-- Attribute's name - ,value=SBD_1 & !<-- Transformed lat (degrees) of domain #1's south bndry - ,rc =RC) -! - CALL ESMF_AttributeSet(state=domain_int_state%IMP_STATE_SOLVER & !<-- The Solver component import state - ,name ='WBD_1' & !<-- Attribute's name - ,value=WBD_1 & !<-- Transformed lon (degrees) of domain #1's west bndry - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Central Lat/Lon of Uppermost Domain" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(1) & !<-- The config object of domain #1 - ,value =TPH0D_1 & !<-- Geographic lat (degrees) of center of domain #1 - ,label ='tph0d:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF(1) & !<-- The config object of domain #1 - ,value =TLM0D_1 & !<-- Geographic lon (degrees) of center of domain #1 - ,label ='tlm0d:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="DOMAIN_INIT: Add Center of Domain #1 to Solver Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=domain_int_state%IMP_STATE_SOLVER & !<-- The Solver component import state - ,name ='TPH0D_1' & !<-- Attribute's name - ,value=TPH0D_1 & !<-- Geographic lat (degrees) of domain #1's center - ,rc =RC) -! - CALL ESMF_AttributeSet(state=domain_int_state%IMP_STATE_SOLVER & !<-- The Solver component import state - ,name ='TLM0D_1' & !<-- Attribute's name - ,value=TLM0D_1 & !<-- Geographic lon (degrees) of domain #1's center - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!------------------------------------------------------------------------ -!*** Add the local domain index limits to the Solver import state -!*** on the compute tasks. -!------------------------------------------------------------------------ -! - NUM_PES_FCST=INPES*JNPES -! - IF(MYPEwrap_solver%INT_STATE -! -!----------------------------------------------------------------------- -! - LM=solver_int_state%LM !<-- We need LM later in the routine. -! -!----------------------------------------------------------------------- -!*** Tell the Solver whether quilting was selected. -!----------------------------------------------------------------------- -! -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Parents update the boundaries of their children every parent -!*** timestep. The nest boundary variables in the Solver internal -!*** state that are updated are selected by the user. -!----------------------------------------------------------------------- -! - bc_variables: IF(MYPE0)THEN - ALLOCATE(solver_int_state%LBND_4D(1:NVARS_BC_4D_H)) - ALLOCATE(solver_int_state%UBND_4D(1:NVARS_BC_4D_H)) - DO NV=1,NVARS_BC_4D_H - LB=LBOUND(solver_int_state%BND_VARS_H%VAR_4D(NV)%FULL_VAR,4) - solver_int_state%LBND_4D(NV)=LB - UB=UBOUND(solver_int_state%BND_VARS_H%VAR_4D(NV)%FULL_VAR,4) - solver_int_state%UBND_4D(NV)=UB - ENDDO -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert Lower Bnds of 4-D H-pt Nest Bndry Vbls into the Domain Exp State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state =EXP_STATE & !<-- The Domain component export state - ,name ='LBND_4D' & !<-- Use this name inside the state - ,itemCount=NVARS_BC_4D_H & !<-- # of items in Attribute - ,valueList=solver_int_state%LBND_4D & !<-- Lower bnds of 4-D H-pt boundary variablesmport state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert Upper Bnds of 4-D H-pt Nest Bndry Vbls into the Domain Exp State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state =EXP_STATE & !<-- The Domain component export state - ,name ='UBND_4D' & !<-- Use this name inside the state - ,itemCount=NVARS_BC_4D_H & !<-- # of items in Attribute - ,valueList=solver_int_state%UBND_4D & !<-- Upper bnds of 4-D H-pt boundary variables - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Fill the Solver's boundary objects with values from the full -!*** arrays in the Solver internal state. -!----------------------------------------------------------------------- -! - IF(.NOT.solver_int_state%RESTART)THEN -! - CALL BOUNDARY_INIT(ITS,ITE,JTS,JTE,LM & - ,IMS,IME,JMS,JME & - ,IDS,IDE,JDS,JDE & - ,solver_int_state%LNSH & - ,solver_int_state%LNSV & -! - ,solver_int_state%NVARS_BC_2D_H & - ,solver_int_state%NVARS_BC_3D_H & - ,solver_int_state%NVARS_BC_4D_H & - ,solver_int_state%NVARS_BC_2D_V & - ,solver_int_state%NVARS_BC_3D_V & -! - ,solver_int_state%BND_VARS_H & - ,solver_int_state%BND_VARS_V & -! - ) - ENDIF -! -!----------------------------------------------------------------------- -!*** The restart output file must contain the boundary array data -!*** .... BUT: -!*** (1) They must be passed from the Solver to the Write -!*** component and since they are not on the ESMF Grid -!*** they must be passed as 1-D Attributes. -!*** (2) We do not want to waste clocktime inserting these -!*** BC winds into the 1-D arrays every timestep when -!*** they are only needed at restart output times -!*** so we must inform the Solver when to fill those -!*** arrays. -! -!*** The 1-D arrays are placed into the Write component's import -!*** state in SAVE_BC_DATA called during SOLVER_RUN. They are -!*** unloaded in WRT_RUN and sent to the lead forecast task to -!*** assemble into a full-domain 1-D datastring that can be sent -!*** to the lead write task for insertion into the restart file. -!----------------------------------------------------------------------- -! - solver_int_state%NSTEPS_BC_RESTART=NINT((solver_int_state%MINUTES_RESTART*60) & !<-- Timestep frequency for BC data insertion into - /solver_int_state%DT) ! 1-D local datastrings -! - LNSH=solver_int_state%LNSH - LNSV=solver_int_state%LNSV -! -! IF(JTS==JDS)THEN !<-- South boundary tasks - solver_int_state%NUM_WORDS_BC_SOUTH=(solver_int_state%NLEV_H*LNSH & - +solver_int_state%NLEV_V*LNSV) & - *2*(ITE-ITS+1) - ALLOCATE(solver_int_state%RST_BC_DATA_SOUTH(1:solver_int_state%NUM_WORDS_BC_SOUTH)) - DO N=1,solver_int_state%NUM_WORDS_BC_SOUTH - solver_int_state%RST_BC_DATA_SOUTH(N)=0. - ENDDO -! ENDIF -! -! IF(JTE==JDE)THEN !<-- North boundary tasks - solver_int_state%NUM_WORDS_BC_NORTH=(solver_int_state%NLEV_H*LNSH & - +solver_int_state%NLEV_V*LNSV) & - *2*(ITE-ITS+1) - ALLOCATE(solver_int_state%RST_BC_DATA_NORTH(1:solver_int_state%NUM_WORDS_BC_NORTH)) - DO N=1,solver_int_state%NUM_WORDS_BC_NORTH - solver_int_state%RST_BC_DATA_NORTH(N)=0. - ENDDO -! ENDIF -! -! IF(ITS==IDS)THEN !<-- West boundary tasks - solver_int_state%NUM_WORDS_BC_WEST=(solver_int_state%NLEV_H*LNSH & - +solver_int_state%NLEV_V*LNSV) & - *2*(JTE-JTS+1) - ALLOCATE(solver_int_state%RST_BC_DATA_WEST(1:solver_int_state%NUM_WORDS_BC_WEST)) - DO N=1,solver_int_state%NUM_WORDS_BC_WEST - solver_int_state%RST_BC_DATA_WEST(N)=0. - ENDDO -! ENDIF -! -! IF(ITE==IDE)THEN !<-- East boundary tasks - solver_int_state%NUM_WORDS_BC_EAST=(solver_int_state%NLEV_H*LNSH & - +solver_int_state%NLEV_V*LNSV) & - *2*(JTE-JTS+1) - ALLOCATE(solver_int_state%RST_BC_DATA_EAST(1:solver_int_state%NUM_WORDS_BC_EAST)) - DO N=1,solver_int_state%NUM_WORDS_BC_EAST - solver_int_state%RST_BC_DATA_EAST(N)=0. - ENDDO -! ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF bc_variables -! -!----------------------------------------------------------------------- -!*** All compute tasks will now insert history and restart pointers -!*** from the Solver internal state into the Write component's -!*** import state. This makes the output variables available to -!*** the Write component. -!----------------------------------------------------------------------- -! - IF(MYPE=domain_int_state%NUM_PES_FCST)THEN -! - I_AM_A_FCST_TASK=.FALSE. -! - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Add some key variables to the Domain export state. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Fcst-or-Write Task Flag to the Domain Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Domain component export state - ,name ='Fcst-or-Write Flag' & !<-- Use this name inside the state - ,value=I_AM_A_FCST_TASK & !<-- The logical being inserted into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add NUM_PES_FCST to the Domain Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Domain component export state - ,name ='NUM_PES_FCST' & !<-- Use this name inside the state - ,value=domain_int_state%NUM_PES_FCST & !<-- The value being set - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Fcst Task Intracomm to Domain Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Domain component export state - ,name ='Comm Fcst Tasks' & !<-- Use this name inside the state - ,value=MPI_COMM_COMP & !<-- This domain's intracomm for fcst tasks - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Now extract number of children on this Domain component's domain. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Number of Children from Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The Domain import state - ,name ='NUM_CHILDREN' & !<-- Name of the attribute to extract - ,value =NUM_CHILDREN & !<-- Put the Attribute here - ,defaultValue=0 & !<-- The default value - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** If this domain has children then retrieve their domain IDs. -!*** They are needed for various aspects of initialization and -!*** integration. -!----------------------------------------------------------------------- -! - IF(NUM_CHILDREN>0)THEN -! - ALLOCATE(MY_CHILDREN_ID(1:NUM_CHILDREN),stat=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Children's IDs from Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The Domain import state - ,name ='CHILD_IDs' & !<-- Name of the attribute to extract - ,itemCount=NUM_CHILDREN & !<-- # of items in the Attribute - ,valueList=MY_CHILDREN_ID & !<-- Put the Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! -!----------------------------------------------------------------------- -!*** With the Solver internal state available set the location of -!*** the SW corner of this domain if it is a nest. This provides -!*** the corner location values to the Write (output) components -!*** and therefore must precede the creation of those components -!*** which immediately follows. -! -!*** If the input file was generated by NPS or this is a restarted -!*** run then the value of the SW corner has already been placed into -!*** the Solver internal state. If this is a free forecast without -!*** a pre-generated input file then read the SW corner location -!*** from the configure file. -!----------------------------------------------------------------------- -! - IF(I_AM_A_FCST_TASK.AND.I_AM_A_NEST)THEN -! - IF(.NOT.INPUT_READY.AND..NOT.RESTARTED_RUN)THEN !<-- If so then must get values from configure file. -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Domain Init: Child Gets SW Corner Point from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The nest domain's config object - ,value =I_PAR_STA & !<-- The variable filled (parent I of nest SW corner) - ,label ='i_parent_start:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The nest domain's config object - ,value =J_PAR_STA & !<-- The variable filled (parent J of nest SW corner) - ,label ='j_parent_start:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - solver_int_state%I_PAR_STA = I_PAR_STA - solver_int_state%J_PAR_STA = J_PAR_STA -! - NEXT_MOVE_TIMESTEP=-999 - solver_int_state%NMTS=NEXT_MOVE_TIMESTEP - solver_int_state%LAST_STEP_MOVED=0 -! - ELSE !<-- If so values were read from input or restart file. -! - I_PAR_STA=solver_int_state%I_PAR_STA - J_PAR_STA=solver_int_state%J_PAR_STA - NEXT_MOVE_TIMESTEP=solver_int_state%NMTS -! - TRACKER_IFIX=solver_int_state%TRACKER_IFIX - TRACKER_JFIX=solver_int_state%TRACKER_JFIX - STORM_CENTER(1)=solver_int_state%TRACKER_IFIX - STORM_CENTER(2)=solver_int_state%TRACKER_JFIX -! - IF(INPUT_READY.AND..NOT.RESTARTED_RUN)THEN - solver_int_state%LAST_STEP_MOVED=0 -! - ENDIF -! - LAST_STEP_MOVED=solver_int_state%LAST_STEP_MOVED -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Transfer the domain's SW corner and next move timestep to the -!*** Domain export state. These values are dummies if not relevant. -!*** The values are obtained directly from the Solver internal state -!*** if this is a restarted run since they were read from the restart -!*** file in that case. -!----------------------------------------------------------------------- - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert SW corner of Nest into Domain Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Domain export state - ,name ='I_PAR_STA' & !<-- Name of the attribute to extract - ,value=I_PAR_STA & !<-- Put the Attribute here - ,rc =RC) -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Domain export state - ,name ='J_PAR_STA' & !<-- Name of the attribute to extract - ,value=J_PAR_STA & !<-- Put the Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert NTRACK flag into the Domain Export State." -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(ASSOCIATED(solver_int_state%NTRACK))THEN - NTRACK=solver_int_state%NTRACK - ELSE - NTRACK=-99 - ENDIF -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Domain export state - ,name ='NTRACK' & !<-- Name of the attribute to extract - ,value=NTRACK & !<-- Put the Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert Next Move Timestep into Domain Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Domain export state - ,name ='NEXT_MOVE_TIMESTEP' & !<-- Name of the attribute to extract - ,value=NEXT_MOVE_TIMESTEP & !<-- Put the Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert Last Move Timestep into Domain Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Domain export state - ,name ='LAST_STEP_MOVED' & !<-- Name of the attribute to extract - ,value=LAST_STEP_MOVED & !<-- Put the Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert Storm Center into Domain Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Domain export state - ,name ='Storm Center' & !<-- Name of the attribute to extract - ,itemCount=2 & !<-- Number of items in the array - ,valueList=STORM_CENTER & !<-- Put the Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! -!----------------------------------------------------------------------- -! -!*** If the current component/domain is the parent of nests then: -! -!*** (1) Extract the arrays from the Solver export state that -!*** is required for the children's boundaries and insert -!*** them into the Domain export state since ultimately -!*** they must be available to the parent in the -!*** Parent-Child Coupler. -! -!*** (2) Check to see if the children have input data ready for them. -!*** If not, do simple nearest neighbor and bilinear interpolation -!*** from the parent's grid to the children's. Write out that -!*** interpolated data into files that are waiting for the children -!*** when they recursively execute DOMAIN_INITIALIZE themselves. -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - I_AM_A_PARENT=.FALSE. -! -!----------------------------------------------------------------------- -! - fcst_tasks_init: IF(I_AM_A_FCST_TASK)THEN -! -!----------------------------------------------------------------------- -!*** Extract fundamental meteorological variables from the Solver -!*** export state. Insert them into the Domain export state so that -!*** NMM_INITIALIZE can take them and send them to the Parent-Child -!*** coupler. Only the forecast tasks participate in doing this -!*** since the Write tasks never loaded data into the Solver export -!*** state. -!----------------------------------------------------------------------- -! - CALL INTERNAL_DATA_TO_DOMAIN(domain_int_state%EXP_STATE_SOLVER & !<-- The Solver export state - ,EXP_STATE & !<-- The Domain export state - ,NLAYRS ) !<-- # of model layers -! -!----------------------------------------------------------------------- -!*** If there are moving nests then the Parent-Child coupler will -!*** need pointers to all the required Solver arrays that must be -!*** updated after a nest moves. Create ESMF Bundles to hold those -!*** pointers then insert the designated pointers from the internal -!*** state into the Bundles (one for H-pt variables and one for -!*** V-pt variables). These Bundles simply remain empty if there -!*** are no moving nests. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Create the empty Move Bundles. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create the Move Bundles" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - BUNDLE_NAME='Move_Bundle H' -! - domain_int_state%MOVE_BUNDLE_H=ESMF_FieldBundleCreate(name=BUNDLE_NAME & !<-- The H-pt Bundle's name - ,rc =RC) -! - BUNDLE_NAME='Move_Bundle V' -! - domain_int_state%MOVE_BUNDLE_V=ESMF_FieldBundleCreate(name=BUNDLE_NAME & !<-- The V-pt Bundle's name - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NUM_FIELDS_MOVE_2D_H_I=0 - NUM_FIELDS_MOVE_2D_H_R=0 - NUM_FIELDS_MOVE_3D_H=0 - NUM_FIELDS_MOVE_2D_V=0 - NUM_FIELDS_MOVE_3D_V=0 -! - NUM_LEVELS_MOVE_3D_H=0 - NUM_LEVELS_MOVE_3D_V=0 -! -!----------------------------------------------------------------------- -!*** Fill the Bundles with the variables to be shifted after nests -!*** move. All moving domains and parents of moving domains must -!*** fill the Move Bundles. -!----------------------------------------------------------------------- -! - CALL_BUILD_MOVE_BUNDLE=.FALSE. -! -!----------------------------------------------------------------------- -!*** Does this domain have any moving children? -!----------------------------------------------------------------------- -! - IF(NUM_CHILDREN>0)THEN -! - child_loop: DO N=1,NUM_CHILDREN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract the Child's Flag Indicating Movability" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_CHILDREN_ID(N)) & !<-- The child's config object - ,value =DOMAIN_MOVES & !<-- The variable filled (will the child move?) - ,label ='my_domain_moves:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(DOMAIN_MOVES)THEN !<-- If true then child N moves. -! - CALL_BUILD_MOVE_BUNDLE=.TRUE. - EXIT child_loop -! - ENDIF -! - ENDDO child_loop -! - ENDIF -! -!----------------------------------------------------------------------- -! - IF(MY_DOMAIN_MOVES)THEN -! - CALL_BUILD_MOVE_BUNDLE=.TRUE. -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Now build the Move Bundles if any children move or if the parent -!*** itself moves. -!----------------------------------------------------------------------- -! - IF(CALL_BUILD_MOVE_BUNDLE)THEN -! - UBOUND_VARS=SIZE(solver_int_state%VARS) -! - CALL BUILD_MOVE_BUNDLE(GRID_DOMAIN & !<-- Add Solver variables to H and V Move Bundles - ,UBOUND_VARS & - ,solver_int_state%VARS & - ,domain_int_state%MOVE_BUNDLE_H & - ,NUM_FIELDS_MOVE_2D_H_I & - ,NUM_FIELDS_MOVE_2D_H_R & - ,NUM_FIELDS_MOVE_3D_H & - ,NUM_LEVELS_MOVE_3D_H & - ,domain_int_state%MOVE_BUNDLE_V & - ,NUM_FIELDS_MOVE_2D_V & - ,NUM_FIELDS_MOVE_3D_V & - ,NUM_LEVELS_MOVE_3D_V & - ) -! -! CALL ESMF_FieldBundlePrint(domain_int_state%MOVE_BUNDLE_H) -! CALL ESMF_FieldBundlePrint(domain_int_state%MOVE_BUNDLE_V) -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Since the parents will also update some of the moving nests' -!*** interior points, the Bundles will be moved into the Parent-Child -!*** coupler import state in subroutine PARENT_CHILD_COUPLER_SETUP. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert Move Bundles into Domain Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateAddReplace( EXP_STATE & !<-- The Domain export state - ,(/domain_int_state%MOVE_BUNDLE_H/) & !<-- Insert H-point MOVE_BUNDLE into the state - ,rc =RC) -! - CALL ESMF_StateAddReplace( EXP_STATE & !<-- The Domain export state - ,(/domain_int_state%MOVE_BUNDLE_V/) & !<-- Insert V-point MOVE_BUNDLE into the state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** What is the ratio of the uppermost parent's grid increment to -!*** this moving nest's? That ratio is needed as part of the unique -!*** name of external files that contain nest-resolution data spanning -!*** the upper parent's domain that the nest reads directly. -! -!*** At the same time the moving nests must know the lateral -!*** dimensions of the uppermost parent domain so that they can -!*** properly read those external files which span that domain. -!----------------------------------------------------------------------- -! - i_move: IF(MY_DOMAIN_MOVES)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Moving Child's Sfc File Ratio" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- This domain's configure object - ,value =SFC_FILE_RATIO & !<-- Ratio of upper parent's grid increment to this nest's - ,label ='ratio_sfc_files:' & !<-- The variable read from the configure file - ,rc =RC) -! - domain_int_state%SFC_FILE_RATIO=SFC_FILE_RATIO -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Uppermost Parent Dimensions" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(1) & !<-- The uppermost domain's configure object - ,value =IM_1 & !<-- # of that domain's gridpoints in I direction - ,label ='im:' & !<-- The variable read from the configure file - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF(1) & !<-- The uppermost domain's configure object - ,value =JM_1 & !<-- # of that domain's gridpoints in J direction - ,label ='jm:' & !<-- The variable read from the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Compute some values needed by moving nests for reading their -!*** full-resolution data that spans the uppermost parent. -!----------------------------------------------------------------------- -! - D_ONE=1. - D_180=180. - PI_LOC=DACOS(-D_ONE) - D2R=PI_LOC/D_180 -! - TPH0_1=TPH0D_1*D2R !<-- Central geo lat of domain (radians, positive north) - TLM0_1=TLM0D_1*D2R !<-- Central geo lon of domain (radians, positive east) - WB_1=WBD_1*D2R !<-- Rotated lon of west boundary (radians, positive east) - SB_1=SBD_1*D2R !<-- Rotated lat of south boundary (radians, positive north) -! - DPH_1=-2.*SB_1/(JM_1-1) !<-- Uppermost parent's grid increment in J (radians) - DLM_1=-2.*WB_1/(IM_1-1) !<-- Uppermost parent's grid increment in I (radians) -! - RECIP_DPH_1=1./DPH_1 - RECIP_DLM_1=1./DLM_1 -! -!----------------------------------------------------------------------- -!*** When a parent sends interior update data to a moving child then -!*** at coastlines a parent may send data valid for water/land to a -!*** point on the child that is land/water on the child's sea mask. -!*** The user sets a configure flag to select one of two options to -!*** handle this situation. In the general case the value 'nearest' -!*** is selected. Then when a conflict point is encountered the -!*** given child task searches on its subdomain for the nearest point -!*** to the conflict point that has the same sfc type (water or land) -!*** and uses that point's sfc values for the conflict point. If no -!*** other point with the same sfc type can be found on the subdomain -!*** then a dummy value is assigned. Note that this can lead to -!*** different answers when different task layouts are used. The -!*** other choice is 'dummy'. When the user chooses that option then -!*** children automatically always set values at conflict points to -!*** dummy values. Points on the earth will thus always have dummy -!*** values with 'dummy' whereas with 'nearest' the values at conflict -!*** points will likely have appropriate values during most of the -!*** time those locations lie within the moving child domain. If -!*** identical answers are required for different task layouts then -!*** 'dummy' must be used. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract SFC_CONFLICT from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- This domain's configure object - ,value =SFC_CONFLICT & !<-- Flag for handling parent-child sfc-type conflicts - ,label ='sfc_conflict:' & !<-- The variable read from the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - domain_int_state%SFC_CONFLICT=SFC_CONFLICT -! - IF(SFC_CONFLICT=='nearest')THEN -! -!----------------------------------------------------------------------- -!*** Generate the I,J increments needed to search for neighboring -!*** points to fix values at moving nest points where land points -!*** receive water point values from the parent and vice versa. -!*** Create empty objects for sorting distances between points on -!*** moving nests for patching mismatches between parent and child -!*** water and land points in 2-way exchange. -!----------------------------------------------------------------------- -! - IF(.NOT.ASSOCIATED(SMALLX))THEN - ALLOCATE(SMALLX(1:NUM_DOMAINS)) - ALLOCATE(LARGEX(1:NUM_DOMAINS)) - ENDIF -! - CALL SEARCH_INIT -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract the nest grid increments for later use. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract DPHD and DLMD from Solver Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=domain_int_state%EXP_STATE_SOLVER & !<-- The Solver export state - ,name ='DPHD' & !<-- Name of the Attribute to extract - ,value=DPHD & !<-- Angular grid increment in X (degrees) - ,rc =RC) -! - CALL ESMF_AttributeGet(state=domain_int_state%EXP_STATE_SOLVER & !<-- The Solver export state - ,name ='DLMD' & !<-- Name of the Attribute to extract - ,value=DLMD & !<-- Angular grid increment in Y (degrees) - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DEG_TO_RAD=PI_LOC/180. - DPH=DPHD*DEG_TO_RAD - DLM=DLMD*DEG_TO_RAD -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract TPH0D and TLM0D from Solver Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=domain_int_state%EXP_STATE_SOLVER & !<-- The Solver export state - ,name ='TPH0D' & !<-- Name of the Attribute to extract - ,value=TPH0D & !<-- Central latitude (degrees) of rotated system - ,rc =RC) -! - CALL ESMF_AttributeGet(state=domain_int_state%EXP_STATE_SOLVER & !<-- The Solver export state - ,name ='TLM0D' & !<-- Name of the Attribute to extract - ,value=TLM0D & !<-- Central longitude (degrees) of rotated system - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - TPH0=TPH0D*DEG_TO_RAD - TLM0=TLM0D*DEG_TO_RAD -! -!----------------------------------------------------------------------- -!*** Moving nests explicitly compute the lat/lon in their parent -!*** update regions following each move as well as the HDAC variables -!*** that are directly dependent upon the lat/lon. The Smagorinsky -!*** constant supplied by the user in the configure file is needed -!*** for the HDAC computation so extract it now. The fundamental -!*** dynamical timestep length is also needed for this purpose as -!*** are grid constants. -!*** (Note: DOMAIN_RUN extracts the timestep during the integration -!*** but that is after its sign may have changed if digital -!*** filtering is being used.) -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Moving Child's Smagorinsky Constant" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- This domain's configure object - ,value =SMAG2 & !<-- Smagorinsky constant - ,label ='smag2:' & !<-- The variable read from the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Moving Child's WCOR Constant" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- This domain's configure object - ,value =WCOR & - ,label ='wcor:' & !<-- The variable read from the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract CODAMP from Configure File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- This domain's configure object - ,value =CODAMP & !<-- Divergence damping coefficient - ,label ='codamp:' & !<-- The variable read from the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Moving Child's Fundamental Timestep" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- This domain's configure object - ,value =DT_INT & !<-- Integer part of time step. - ,label ='dt_int:' & !<-- The variable read from the configure file - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- This domain's configure object - ,value =DT_NUM & !<-- Numerator of fractional part of time step. - ,label ='dt_num:' & !<-- The variable read from the configure file - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- This domain's configure object - ,value =DT_DEN & !<-- Denominator of fractional part of time step. - ,label ='dt_den:' & !<-- The variable read from the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DT_REAL=REAL(DT_INT)+REAL(DT_NUM)/REAL(DT_DEN) -! - ACDT =SMAG2*SMAG2*DT_REAL - CDDAMP=CODAMP*DT_REAL -! -!----------------------------------------------------------------------- -!*** Due to the nature of the B-grid and the computations within -!*** the NMM-B, locations corresponding to a minimum of the outer -!*** two rows of the pre-move footprint of the nest domain cannot -!*** use intra- or inter-task updates and instead must be updated -!*** by the parent. Read in configure variables that specify the -!*** number of rows on each side of the nest's pre-move footprint -!*** for which the parent will provide update data after the nest -!*** moves. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract # of Rows Parent Will Update" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- This domain's configure object - ,value =NROWS_P_UPD_W & !<-- # of rows parent will update on west bndry - ,label ='nrows_p_upd_w:' & !<-- The variable read from the configure file - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- This domain's configure object - ,value =NROWS_P_UPD_E & !<-- # of rows parent will update on east bndry - ,label ='nrows_p_upd_e:' & !<-- The variable read from the configure file - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- This domain's configure object - ,value =NROWS_P_UPD_S & !<-- # of rows parent will update on south bndry - ,label ='nrows_p_upd_s:' & !<-- The variable read from the configure file - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- This domain's configure object - ,value =NROWS_P_UPD_N & !<-- # of rows parent will update on north bndry - ,label ='nrows_p_upd_n:' & !<-- The variable read from the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Due to the complexities of the parent's updating of the child -!*** for nest motion that is due east, west, south, or north -!*** task subdomains cannot be too thin. Stop the run if they are. -!----------------------------------------------------------------------- -! - IF(IHALO>ITE-ITS+1-NROWS_P_UPD_W.OR. & - IHALO>ITE-ITS+1-NROWS_P_UPD_E.OR. & - JHALO>JTE-JTS+1-NROWS_P_UPD_S.OR. & - JHALO>JTE-JTS+1-NROWS_P_UPD_N )THEN - WRITE(0,*)' Task subdomains cannot be narrower than ' - WRITE(0,*)' the width of the halo plus the width of ' - WRITE(0,*)' the parent update region on the outer ' - WRITE(0,*)' edge of a nest pre-move footprint.' - WRITE(0,11111)IHALO,JHALO - WRITE(0,*)' The width of the parent update region on the ' - WRITE(0,*)' south, north, west, and east side of a moving ' - WRITE(0,*)' nest pre-move footprint are:' - WRITE(0,11112)NROWS_P_UPD_S,NROWS_P_UPD_N & - ,NROWS_P_UPD_W,NROWS_P_UPD_E - WRITE(0,11113)ITE-ITS+1,JTE-JTS+1 - WRITE(0,*)' The user must reset the domain decomposition.' - WRITE(0,*)' Aborting!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) -11111 FORMAT(' The halo width in I is ',I2,' and in J is ',I2) -11112 FORMAT(4(1X,I2)) -11113 FORMAT(' The subdomain widths in I and J are ',I4,1X,I4) - ENDIF -! -!----------------------------------------------------------------------- -!*** Initialize the handle used in ISSends of intertask data when -!*** a moving domain shifts. -!----------------------------------------------------------------------- -! - DO N=1,9 - domain_int_state%HANDLE_SEND_INTER_INT(N) =MPI_REQUEST_NULL - domain_int_state%HANDLE_SEND_INTER_REAL(N)=MPI_REQUEST_NULL - ENDDO -! -!----------------------------------------------------------------------- -! - ENDIF i_move -! -!----------------------------------------------------------------------- -!*** If there is 2-way exchange from the children to the parents -!*** then the Parent-Child coupler will need pointers to all the -!*** required Solver arrays that are updated on the parents by the -!*** children each parent timestep. Create an ESMF Bundle to hold -!*** those pointers then insert the desgnated pointers from the -!*** Solver component's internal state into the Bundle. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Does this forecast use 2-way exchange? -!----------------------------------------------------------------------- -! - NEST_MODE=' ' -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract 2-way Flag From Nest Configure Files" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- This domain's configure object - ,value =NEST_MODE & !<-- Is there 2-way exchange from child to parent? - ,label ='nest_mode:' & !<-- The label in the configure file - ,rc =rc) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Create the 2-way exchange Bundle. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create the 2-way Exchange Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - BUNDLE_NAME='Bundle_2way' -! - domain_int_state%BUNDLE_2WAY=ESMF_FieldBundleCreate(name=BUNDLE_NAME & !<-- The 2-way Bundle's name - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Now build the 2-way Bundle if 2-way exchange has been specified -!*** in the configure files. -!----------------------------------------------------------------------- -! - IF(NEST_MODE=='2-way')THEN -! - UBOUND_VARS=SIZE(solver_int_state%VARS) -! - CALL BUILD_2WAY_BUNDLE(GRID_DOMAIN & !<-- Add Solver int state variables to 2-way Bundle - ,LM & - ,UBOUND_VARS & - ,solver_int_state%VARS & - ,domain_int_state%BUNDLE_2WAY & - ) -! - ENDIF -! -!----------------------------------------------------------------------- -!*** The 2-way exchange itself takes place in the Parent-Child coupler -!*** so insert the 2-way Bundle into the Domain component's export -!*** state in order to transfer it to the P-C coupler import state -!*** in subroutine PARENT_CHILD_COUPLER_SETUP. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert 2-way Bundle into Domain Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateAddReplace( EXP_STATE & !<-- The Domain export state - ,(/domain_int_state%BUNDLE_2WAY/) & !<-- Insert BUNDLE of 2-way vbls into the state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - ENDIF fcst_tasks_init -! -!----------------------------------------------------------------------- -! - child_init_block: IF(NUM_CHILDREN>0)THEN !<-- Only parents participate -! -!----------------------------------------------------------------------- -! - I_AM_A_PARENT=.TRUE. -! -!----------------------------------------------------------------------- -!*** Initialize the children's data directly from the parent if -!*** there are no pre-processed input files ready for them. -!*** Files will be written for the children to read in as usual. -!*** Only parent tasks participate. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - child_init_loop: DO N=1,NUM_CHILDREN !<-- Loop through the children -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Children's Input Flag from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_CHILDREN_ID(N)) & !<-- The config object - ,value =INPUT_READY_MY_CHILD & !<-- Child's flag for existence of its input file - ,label ='input_ready:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(.NOT.INPUT_READY_MY_CHILD)THEN !<-- INPUT_READY=false -> This child has no input file - ! so parent will generate input. - CALL PARENT_TO_CHILD_INIT_NMM(MYPE & !<-- This task's rank (in) - ,CF & !<-- Array of configure files (in) - ,MY_DOMAIN_ID & !<-- Each domain's ID (in) - ,MY_CHILDREN_ID(N) & !<-- The child's domain ID - ,domain_int_state%SOLVER_GRID_COMP & !<-- The parent's Solver Component (inout) - ,COMM_MY_DOMAIN ) !<-- Each domain's intracommunicator -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO child_init_loop -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Send the next move timestep of the moving children to the -!*** Parent-Child coupler. If this is a restarted run then the -!*** values are were read from the restart file in Solver Init. -!----------------------------------------------------------------------- -! - IF(I_AM_A_FCST_TASK)THEN -! - NTIMESTEP_CHILD_MOVES=>solver_int_state%NTSCM -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Initialize Next Timestep Children Move in Domain Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state =IMP_STATE & !<-- The Domain import state - ,name ='NEXT_TIMESTEP_CHILD_MOVES' & !<-- Name of the attribute to insert - ,itemCount=NUM_DOMAINS_MAX & !<-- Number of items in the array - ,valueList=NTIMESTEP_CHILD_MOVES & !<-- Put the Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert Next Timestep Children Move into Domain Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state =EXP_STATE & !<-- The Domain export state - ,name ='NEXT_TIMESTEP_CHILD_MOVES' & !<-- Name of the attribute to extract - ,itemCount=NUM_DOMAINS_MAX & !<-- Number of items in the array - ,valueList=NTIMESTEP_CHILD_MOVES & !<-- Put the Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF child_init_block -! -!----------------------------------------------------------------------- -!*** For moving nests there are external files with nest-resolution -!*** sfc data spanning the uppermost parent. If the parent generated -!*** the nest's initial conditions from its own then replace the -!*** values in those nest arrays with data from the external files. -!----------------------------------------------------------------------- -! - IF(MY_DOMAIN_MOVES & - .AND. & - I_AM_A_FCST_TASK & - .AND. & - .NOT.INPUT_READY)THEN -! - CALL RESET_SFC_VARS(domain_int_state%SFC_FILE_RATIO & - ,solver_int_state%GLAT & - ,solver_int_state%GLON & - ,domain_int_state%MOVE_BUNDLE_H) -! - CALL RESET_SFC_VARS(domain_int_state%SFC_FILE_RATIO & - ,solver_int_state%GLAT & - ,solver_int_state%GLON & - ,domain_int_state%MOVE_BUNDLE_V) -! -!----------------------------------------------------------------------- -!*** Now the nest's sea mask array contains the nest-resolution -!*** data from the external file. That means the nest's sea mask -!*** is at nest resolution while other land/sea variables were -!*** simply interpolated from the parent domain so near coastlines -!*** some points in those variables will not agree with the nest's -!*** sea mask. Therefore call the same routine that must be called -!*** after every move of the nest during the integration that will -!*** force various land/water variables to agree with the nest's -!*** sea mask. -!----------------------------------------------------------------------- -! - FIELD_NAME='SM-move' -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Seamask Field from Move Bundle H" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=domain_int_state%MOVE_BUNDLE_H & !<-- Bundle holding the H arrays for move updates - ,fieldName =FIELD_NAME & !<-- Name of the seamask Field in the Bundle - ,field =HOLD_FIELD & !<-- Field containing the seamask - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Seamask Array from Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,localDe =0 & - ,farrayPtr=SEA_MASK & !<-- Dummy 2-D array with Field's Real data - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ILO=LBOUND(SEA_MASK,1) - IHI=UBOUND(SEA_MASK,1) - JLO=LBOUND(SEA_MASK,2) - JHI=UBOUND(SEA_MASK,2) -! - NUM_FIELDS=NUM_FIELDS_MOVE_2D_H_I & - +NUM_FIELDS_MOVE_2D_H_R & - +NUM_FIELDS_MOVE_3D_H -! - CALL FIX_SFC(domain_int_state%MOVE_BUNDLE_H & - ,NUM_FIELDS & - ,SEA_MASK & - ,ILO,IHI,JLO,JHI & - ,ILO,IHI,JLO,JHI) -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Insert into the Domain export state the flag indicating if the -!*** current domain is a parent. The Domain Driver wants to know this -!*** since most Parent-Child work can be ignored by domains with -!*** no children. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Parent/Not-a-Parent Flag to the Domain Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Domain component export state - ,name ='I-Am-A-Parent Flag' & !<-- Use this name inside the state - ,value=I_AM_A_PARENT & !<-- The logical being inserted into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - domain_int_state%I_AM_A_PARENT=I_AM_A_PARENT -! -!----------------------------------------------------------------------- -!*** Initialize some variables used in NMM_INTEGRATE. -!----------------------------------------------------------------------- -! - domain_int_state%FIRST_PASS=.TRUE. !<-- Note the first time NMM_INTEGRATE is entered. - domain_int_state%TS_INITIALIZED=.FALSE. !<-- Note whether time series variables are initialized. - domain_int_state%KOUNT_TIMESTEPS=0 !<-- Timestep counter -! - domain_int_state%RECV_ALL_CHILD_DATA=.FALSE. !<-- Parent has recvd 2-way data from all children - domain_int_state%ALLCLEAR_FROM_PARENT=.FALSE. !<-- Child told that parent has recvd all 2-way data -! -!----------------------------------------------------------------------- -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- This domain's configure object - ,value =FILT_METHOD & !<-- The filter method - ,label ='filter_method:' & !<-- The variable read from the configure file - ,rc =RC) -! -!----------------------------------------------------------------------- -! - IF(I_AM_A_FCST_TASK)THEN -! - IF(NUM_CHILDREN>0)THEN - ALLOCATE(CHILD_ACTIVE(1:NUM_CHILDREN)) - ENDIF -! -!----------------------------------------------------------------------- -!*** Create and fill the Filter Bundles. Since the current task -!*** might lie on more than one domain if the user selects 2-way -!*** nesting there needs to be a unique bundle for each of those -!*** domains. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Filter Method beofre Creating Filter Bundles" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- This domain's configure object - ,value =FILT_METHOD & !<-- The filter method - ,label ='filter_method:' & !<-- The variable read from the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF (FILT_METHOD > 0) THEN -! - domain_int_state%FILT_BUNDLE_FILTER=ESMF_FieldBundleCreate(name='Filt_Bundle Filter' & !<-- The Bundle's name - ,rc =RC) -! - domain_int_state%FILT_BUNDLE_RESTORE=ESMF_FieldBundleCreate(name='Filt_Bundle Restore' & !<-- The Bundle's name - ,rc =RC) -! - UBOUND_VARS=SIZE(solver_int_state%VARS) -! - CALL BUILD_FILT_BUNDLE(GRID_DOMAIN & - ,UBOUND_VARS & - ,solver_int_state%VARS & - ,domain_int_state%FILT_BUNDLE_FILTER & - ,domain_int_state%NUM_FIELDS_FILTER_2D & - ,domain_int_state%NUM_FIELDS_FILTER_3D & - ,domain_int_state%FILT_BUNDLE_RESTORE & - ,domain_int_state%NUM_FIELDS_RESTORE_2D & - ,domain_int_state%NUM_FIELDS_RESTORE_3D & - ,RESTARTED_RUN) - -! - domain_int_state%FIRST_FILTER=.TRUE. -! - NULLIFY(domain_int_state%DOLPH_WGTS) - NULLIFY(domain_int_state%SAVE_2D) - NULLIFY(domain_int_state%SAVE_3D) - NULLIFY(domain_int_state%SAVE_2D_PHYS) - NULLIFY(domain_int_state%SAVE_3D_PHYS) -! -!----------------------------------------------------------------------- -!*** We want to be able to run the digital filter on a group of -!*** parents and children where some of the children are not -!*** active in the filtering. When the free forecast begins then -!*** all domains will be active. Set flags in the Domain export -!*** state indicating if a domain will be inactive if the digital -!*** filter runs as well as if any of its children will not be -!*** active. -!----------------------------------------------------------------------- -! - I_AM_ACTIVE=.TRUE. -! - IF(NUM_CHILDREN>0)THEN -! - DO N=1,NUM_CHILDREN !<-- Loop through the children -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Children's DFI method from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_CHILDREN_ID(N)) & !<-- The child's config object - ,value =FILT_METHOD_CHILD & !<-- Child's digital filter methodigital filter method - ,label ='filter_method:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(FILT_METHOD_CHILD>0)THEN - CHILD_ACTIVE(N)=.TRUE. - ELSE - CHILD_ACTIVE(N)=.FALSE. - ENDIF -! - ENDDO -! - ENDIF -! -!----------------------------------------------------------------------- -! - ELSEIF(FILT_METHOD==0)THEN -! - I_AM_ACTIVE=.FALSE. -! - IF(NUM_CHILDREN>0)THEN - DO N=1,NUM_CHILDREN - CHILD_ACTIVE(N)=.FALSE. !<-- Children can run DFI only if their parent does. - ENDDO - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add DFI flag for this domain into Domain export state" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Domain component export state - ,name ='I Am Active' & !<-- Use this name inside the state - ,value=I_AM_ACTIVE & !<-- The logical being inserted into the export state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(NUM_CHILDREN>0)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert child DFI flags into Domain Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state =EXP_STATE & !<-- The Domain export state - ,name ='Child Active' & !<-- Name of the attribute to insert - ,itemCount=NUM_CHILDREN & !<-- Number of items in the array - ,valueList=CHILD_ACTIVE & !<-- Insert this attribute. - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DEALLOCATE(CHILD_ACTIVE) -! - ENDIF -! - ENDIF -! - IF(ASSOCIATED(MY_CHILDREN_ID))THEN - DEALLOCATE(MY_CHILDREN_ID) - ENDIF -! -!----------------------------------------------------------------------- -!*** Coupled runs will use counters for accumulating export fields. -!*** Initialize those counters. -!----------------------------------------------------------------------- -! - domain_int_state%KOUNT_NPRECIP=0 - domain_int_state%KOUNT_NPHS =0 -! -!----------------------------------------------------------------------- -! - timers(my_domain_id)%total_integ_tim=(timef()-btim0) -! -!----------------------------------------------------------------------- -! - IF(RC_INIT==ESMF_SUCCESS)THEN -! WRITE(0,*)'DOMAIN INITIALIZE step succeeded' - ELSE - WRITE(0,*)'DOMAIN INITIALIZE step failed RC_INIT=',RC_INIT - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE DOMAIN_INITIALIZE -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE DOMAIN_RUN(DOMAIN_GRID_COMP & - ,IMP_STATE & - ,EXP_STATE & - ,CLOCK_DOMAIN & - ,RC_RUN) -! -!----------------------------------------------------------------------- -!*** The Run step of the Domain component for the NMM. -!*** The forecast tasks execute a single timestep in the Run step -!*** of the NMM-B Solver. That is the Run subroutine specified -!*** in the Solver Register routine and is called SOLVER_RUN. -!----------------------------------------------------------------------- -! - USE MODULE_NESTING,ONLY: BOUNDARY_DATA_STATE_TO_STATE -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_GridComp) :: DOMAIN_GRID_COMP !<-- The Domain gridded component -! - TYPE(ESMF_State) :: IMP_STATE & !<-- The Domain component's import state - ,EXP_STATE !<-- The Domain component's export state -! - TYPE(ESMF_Clock) :: CLOCK_DOMAIN !<-- The Domain ESMF Clock -! - INTEGER,INTENT(OUT) :: RC_RUN !<-- Return code for the Run step -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(ESMF_KIND_I4) :: INTEGER_DT,NEXT_MOVE_TIMESTEP & - ,NUMERATOR_DT,IDENOMINATOR_DT -! - INTEGER(kind=ESMF_KIND_I8) :: NTIMESTEP_ESMF !<-- The current forecast timestep -! - INTEGER(kind=KINT) :: I,I_INC,ITE,ITS & - ,J,J_INC,JTE,JTS -! - INTEGER(kind=KINT) :: I_SW_PARENT_NEW,J_SW_PARENT_NEW -! - INTEGER(kind=KINT) :: FILTER_METHOD,HDIFF_ON,IERR,J_CENTER & - ,LAST_STEP_MOVED,RC,NC,YY,MM,DD,H,M,S -! - INTEGER(kind=KINT),DIMENSION(2) :: STORM_CENTER -! - INTEGER(kind=KINT),DIMENSION(1:NUM_DOMAINS_MAX) :: NTIMESTEPCHILD_MOVES -! - REAL(kind=KFPT) :: DLM,DPH,GLATX,GLONX,RAD2DEG,TLATX,TLONX,X,Y,Z -! - REAL(kind=KFPT),DIMENSION(1:2) :: SW_X -! - REAL(kind=KDBL),DIMENSION(:,:),POINTER :: GLAT_DBL,GLON_DBL & - ,VLAT_DBL,VLON_DBL -! - LOGICAL(kind=KLOG) :: E_BDY,N_BDY,S_BDY,W_BDY !<-- Are tasks on a domain boundary? - LOGICAL(kind=KLOG) :: DIG_FILTER,FREE_FORECAST & - ,I_AM_ACTIVE,MOVE_NOW & - ,MOVED_THIS_TIMESTEP -! - REAL(kind=KFPT) :: DT,NPRECIP_STEP,NPHS_STEP,RECIP_KOUNT,RECIP_NPRECIP -! - TYPE(ESMF_TimeInterval) :: DT_ESMF - TYPE(ESMF_Time) :: CURRTIME -! - TYPE(ESMF_Config) :: CF -! - TYPE(WRAP_SOLVER_INT_STATE) :: WRAP_SOLVER -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - btim0=timef() -! - RC =ESMF_SUCCESS - RC_RUN=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** What is this domain's ID? -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Domain_Run: Extract Domain ID from Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The Domain import state - ,name ='DOMAIN_ID' & !<-- Name of the attribute to extract - ,value =MY_DOMAIN_ID & !<-- The ID of this domain - ,defaultValue=1 & !<-- The default value - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Extract this domain's Virtual Machine so we can distinguish -!*** its MPI task specifications from those of other domains that -!*** the current task may also lie on. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="DOMAIN_RUN: Retrieve VM from Domain component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGet(gridcomp=DOMAIN_GRID_COMP & !<-- The Domain component - ,vm =VM & !<-- Get the Virtual Machine from the Domain component - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** What is this task's rank in this domain's set of tasks? -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="DOMAIN_RUN: Obtain Task IDs" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_VMGet(vm =VM & !<-- The virtual machine - ,localpet =MYPE & !<-- Each MPI task ID - ,mpiCommunicator=COMM_MY_DOMAIN & !<-- This domain's intracommunicator - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Extract this domain's internal state so we can access -!*** its variables. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="DOMAIN_RUN: Extract the Domain's internal state" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGetInternalState(DOMAIN_GRID_COMP & !<-- The Domain component - ,WRAP & !<-- The F90 wrap of the domain's internal state - ,RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DOMAIN_INT_STATE=>wrap%DOMAIN_INT_STATE !<-- The domain's internal state -! -!----------------------------------------------------------------------- -!*** Extract the timestep from the Clock so that we know the direction -!*** of the integration. We skip all aspects of physics if the time -!*** step is negative. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="DOMAIN_Run: Extract the ESMF Timestep" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock =CLOCK_DOMAIN & - ,timeStep =DT_ESMF & - ,currTime =CURRTIME & - ,advanceCount=NTIMESTEP_ESMF & !<-- # of times the clock has advanced - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeGet(time=CURRTIME,mm=MM,dd=DD,h=H,m=M,s=S,rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="DOMAIN_Run: Extract Components of the Timestep" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeIntervalGet(timeinterval=DT_ESMF & !<-- the ESMF timestep - ,s =INTEGER_DT & !<-- the integer part of the timestep in seconds - ,sN =NUMERATOR_DT & !<-- the numerator of the fractional second - ,sD =IDENOMINATOR_DT & !<-- the denominator of the fractional second - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - NTIMESTEP=NTIMESTEP_ESMF -! - MOVED_THIS_TIMESTEP=.FALSE. -! -!----------------------------------------------------------------------- -! - fcst_pes: IF(MYPEwrap_solver%INT_STATE -! -!----------------------------------------------------------------------- -!*** Determine if forecast tasks are on the domain boundary. -!----------------------------------------------------------------------- -! - S_BDY=(solver_int_state%JTS==solver_int_state%JDS) ! This task is on the southern boundary - N_BDY=(solver_int_state%JTE==solver_int_state%JDE) ! This task is on the northern boundary - W_BDY=(solver_int_state%ITS==solver_int_state%IDS) ! This task is on the western boundary - E_BDY=(solver_int_state%ITE==solver_int_state%IDE) ! This task is on the eastern boundary -! -!----------------------------------------------------------------------- -!*** If this is a nested run then we need to consider two things: -!*** (1) For all nests new boundary data must be moved from the -!*** Domain import state to the Solver import state every -!*** N timesteps where N is the number of the nest's timesteps -!*** within one timestep of its parent. This is done before -!*** the Run step of the Solver is executed in order that -!*** the nests have correct boundary conditions for integrating -!*** through the next N timesteps. -!*** (2) If this is a moving nest and it has just moved then it -!*** updates those of its interior points that still lie -!*** within the footprint of its domain's pre-move location. -!*** These are the points that are NOT updated by its parent. -!*** Then it must also incorporate any interior update data -!*** that was sent to it by its parent that lie outside of -!*** the nest domain's pre-move footprint. -!----------------------------------------------------------------------- -! - nests: IF(domain_int_state%I_AM_A_NEST)THEN -! - IF(FREE_FORECAST.OR.(DIG_FILTER.AND.I_AM_ACTIVE))THEN - CALL BOUNDARY_DATA_STATE_TO_STATE(s_bdy =S_BDY & !<-- This task lies on a south boundary? - ,n_bdy =N_BDY & !<-- This task lies on a north boundary? - ,w_bdy =W_BDY & !<-- This task lies on a west boundary? - ,e_bdy =E_BDY & !<-- This task lies on an east boundary? - ,clock =CLOCK_DOMAIN & !<-- The Domain Clock - ,nest =domain_int_state%I_AM_A_NEST & !<-- The nest flag (yes or no) - ,ratio =PARENT_CHILD_TIME_RATIO & !<-- # of child timesteps per parent timestep - ,state_in =IMP_STATE & !<-- Domain component's import state - ,state_out=domain_int_state%IMP_STATE_SOLVER) !<-- The Solver import state - ENDIF -! -!----------------------------------------------------------------------- -! - domain_moves: IF(domain_int_state%MY_DOMAIN_MOVES)THEN !<-- Select the moving nests -! -!----------------------------------------------------------------------- -!*** If a nest is moving in its next timestep then update the -!*** SW corner location in the Solver internal state now at the -!*** end of the preceding timestep. This is necessary for the -!*** correct location to be in place if a restart file is to be -!*** written that is valid for the beginning of the next timestep. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="DOMAIN_RUN: Get NEXT_MOVE_TIMESTEP from Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- Domain component's import state - ,name ='NEXT_MOVE_TIMESTEP' & !<-- Extract Attribute with this name - ,value=NEXT_MOVE_TIMESTEP & !<-- When does this nest move again? - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - solver_int_state%NMTS=NEXT_MOVE_TIMESTEP !<-- Save in the Solver internal state -! - IF(NTIMESTEP==NEXT_MOVE_TIMESTEP-1)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Domain_Run: Get I_SHIFT,J_SHIFT from Domain Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Domain import state - ,name ='I_SHIFT' & !<-- Get Attribute with this name - ,value=I_SHIFT_CHILD & !<-- Motion of the nest in I on its grid - ,rc =RC ) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Domain import state - ,name ='J_SHIFT' & !<-- Get Attribute with this name - ,value=J_SHIFT_CHILD & !<-- Motion of the nest in J on its grid - ,rc =RC ) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Domain import state - ,name ='LAST_STEP_MOVED' & !<-- Get Attribute with this name - ,value=LAST_STEP_MOVED & !<-- Motion of the nest in J on its grid - ,rc =RC ) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - solver_int_state%LAST_STEP_MOVED=LAST_STEP_MOVED -! - ENDIF -! -!----------------------------------------------------------------------- -!*** We need to update the Solver internal state's values for the -!*** 'new' location of the nest's SW corner every timestep to -!*** also include those cases where the parent shifts when the -!*** nest does not or else the restart file will be incorrect. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Domain_Run: Get I_SW_PARENT_NEW,J_SW_PARENT_NEW from Domain Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Domain import state - ,name ='I_SW_PARENT_NEW' & !<-- Get Attribute with this name - ,value=I_SW_PARENT_NEW & !<-- Motion of the nest in I on its grid - ,rc =RC ) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Domain import state - ,name ='J_SW_PARENT_NEW' & !<-- Get Attribute with this name - ,value=J_SW_PARENT_NEW & !<-- Motion of the nest in J on its grid - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(I_SW_PARENT_NEW>-999999)THEN -! - solver_int_state%I_PAR_STA=I_SW_PARENT_NEW -! - solver_int_state%J_PAR_STA=J_SW_PARENT_NEW -! - ENDIF -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="DOMAIN_RUN: Get the MOVE_NOW Flag from Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- Domain component's import state - ,name ='MOVE_NOW' & !<-- Extract Attribute with this name - ,value=MOVE_NOW & !<-- Is the child moving right now? - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="DOMAIN_RUN: Add MOVE_NOW Flag to the Solver Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=domain_int_state%IMP_STATE_SOLVER & !<-- The Solver component import state - ,name ='MOVE_NOW' & !<-- Use this name inside the state - ,value=MOVE_NOW & !<-- Did this nest move this timestep? - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - moving_now: IF(MOVE_NOW)THEN !<-- Select moving nests that move this timestep -! -!----------------------------------------------------------------------- -!*** What are the nest's new transformed lat/lon of its south and -!*** west boundaries following the move? -!----------------------------------------------------------------------- -! - MOVED_THIS_TIMESTEP=.TRUE. -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Domain_Run: Get I_SHIFT,J_SHIFT from Domain Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Domain import state - ,name ='I_SHIFT' & !<-- Get Attribute with this name - ,value=I_SHIFT_CHILD & !<-- Motion of the nest in I on its grid - ,rc =RC ) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Domain import state - ,name ='J_SHIFT' & !<-- Get Attribute with this name - ,value=J_SHIFT_CHILD & !<-- Motion of the nest in J on its grid - ,rc =RC ) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** What are the transformed lat/lon of the nest's SW corner at -!*** the new nest location? -!----------------------------------------------------------------------- -! - IF(MYPE==0)THEN -! - D_ONE=1. - D_180=180. - PI_LOC=DACOS(-D_ONE) - D2R=PI_LOC/D_180 -! - TPH0_1=TPH0D_1*D2R !<-- The central lat/lon of domain #1 is the center - TLM0_1=TLM0D_1*D2R ! for all grid-associated nests -! - ITS=solver_int_state%ITS - JTS=solver_int_state%JTS - GLATX=solver_int_state%GLAT(ITS,JTS) !<-- Geographic lat (radians) of nest's pre-move SW corner - GLONX=solver_int_state%GLON(ITS,JTS) !<-- Geographic lon (radians) of nest's pre-move SW corner -! - X=COS(TPH0_1)*COS(GLATX)*COS(GLONX-TLM0_1)+SIN(TPH0_1)*SIN(GLATX) - Y=COS(GLATX)*SIN(GLONX-TLM0_1) - Z=-SIN(TPH0_1)*COS(GLATX)*COS(GLONX-TLM0_1)+COS(TPH0_1)*SIN(GLATX) -! - TLATX=ATAN(Z/SQRT(X*X+Y*Y)) !<-- Transformed lat (radians) of nest's pre-move SW corner - TLONX=ATAN(Y/X) !<-- Transformed lon (radians) of nest's pre-move SW corner - IF(X<0)TLONX=TLONX+PI -! - SB_1=SBD_1*D2R !<-- Transformed lat (radians) of domain #1's S bndry - WB_1=WBD_1*D2R !<-- Transformed lon (radians) of domain #1's W bndry -! - DPH=solver_int_state%DPHD*D2R !<-- Nest's angular grid increment in J (radians) - DLM=solver_int_state%DLMD*D2R !<-- Nest's angular grid increment in I (radians) -! - TLATX=TLATX+J_SHIFT_CHILD*DPH !<-- Transformed lat (radians) of nest's post-move SW corner - TLONX=TLONX+I_SHIFT_CHILD*DLM !<-- Transformed lon (radians) of nest's post-move SW corner -! - I_INC=NINT((TLONX-WB_1)/DLM) !<-- Nest grid increments (integer) between west/south - J_INC=NINT((TLATX-SB_1)/DPH) ! boundaries of the nest and domain #1. -! - SW_X(1)=(SB_1+J_INC*DPH)/D2R !<-- Transformed lat (degrees) of nest domain's S bndry - SW_X(2)=(WB_1+I_INC*DLM)/D2R !<-- Transformed lon (degrees) of nest domain's S bndry -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Local task 0 shares the transformed lat/lon of the nest domain's -!*** south and west boundaries with all other fcst tasks. -!----------------------------------------------------------------------- -! - CALL MPI_BCAST(SW_X & - ,2 & - ,MPI_REAL & - ,0 & - ,COMM_FCST_TASKS(MY_DOMAIN_ID) & - ,IERR ) -! - solver_int_state%SBD=SW_X(1) - solver_int_state%WBD=SW_X(2) -! -!----------------------------------------------------------------------- -!*** Update quantities that are directly related to the nest's grid. -!----------------------------------------------------------------------- -! - CALL GRID_CONSTS(solver_int_state%GLOBAL & - ,solver_int_state%DT & - ,solver_int_state%SMAG2 & - ,solver_int_state%CODAMP,solver_int_state%WCOR & - ,solver_int_state%TPH0D,solver_int_state%TLM0D & - ,solver_int_state%SBD,solver_int_state%WBD & - ,solver_int_state%DPHD,solver_int_state%DLMD & - ,solver_int_state%DXH,solver_int_state%RDXH & - ,solver_int_state%DXV,solver_int_state%RDXV & - ,solver_int_state%DYH,solver_int_state%RDYH & - ,solver_int_state%DYV,solver_int_state%RDYV & - ,solver_int_state%DDV,solver_int_state%RDDV & - ,solver_int_state%DDMPU,solver_int_state%DDMPV & - ,solver_int_state%WPDAR & - ,solver_int_state%FCP,solver_int_state%FDIV & - ,solver_int_state%CURV,solver_int_state%F & - ,solver_int_state%FAD,solver_int_state%FAH & - ,solver_int_state%DARE,solver_int_state%RARE & - ,solver_int_state%GLAT,solver_int_state%GLON & - ,solver_int_state%GLAT_SW,solver_int_state%GLON_SW & - ,solver_int_state%VLAT,solver_int_state%VLON & - ,solver_int_state%HDACX,solver_int_state%HDACY & - ,solver_int_state%HDACVX,solver_int_state%HDACVY & - ,solver_int_state%E_BDY,solver_int_state%N_BDY & - ,solver_int_state%S_BDY,solver_int_state%W_BDY & - ,solver_int_state%ITS,solver_int_state%ITE & - ,solver_int_state%JTS,solver_int_state%JTE & - ,solver_int_state%IMS,solver_int_state%IME & - ,solver_int_state%JMS,solver_int_state%JME & - ,solver_int_state%IDS,solver_int_state%IDE & - ,solver_int_state%JDS,solver_int_state%JDE ) -! -!----------------------------------------------------------------------- -!*** Update all nest points that remain inside of its domain's -!*** pre-move footprint. -!----------------------------------------------------------------------- -! - btim=timef() -! - CALL UPDATE_INTERIOR_FROM_NEST(IMP_STATE & !<-- Domain import state (for nest's I_SHIFT and J_SHIFT) - ,domain_int_state%MOVE_BUNDLE_H & !<-- The Bundle of pointers to update H variables - ,NUM_FIELDS_MOVE_2D_H_I & !<-- Total # of 2-D integer H Fields in the Bundle - ,NUM_FIELDS_MOVE_2D_H_R & !<-- Total # of 2-D real H Fields in the Bundle - ,NUM_FIELDS_MOVE_3D_H & !<-- Total # of 3-D H Fields in the Bundle - ,NUM_LEVELS_MOVE_3D_H & !<-- Total # of 2-D levels in all 3-D H update arrays - ,domain_int_state%MOVE_BUNDLE_V & !<-- The Bundle of pointers to update V variables - ,NUM_FIELDS_MOVE_2D_V & !<-- Total # of 2-D V Fields in the Bundle - ,NUM_FIELDS_MOVE_3D_V & !<-- Total # of 3-D V Fields in the Bundle - ,NUM_LEVELS_MOVE_3D_V & !<-- Total # of 2-D levels in all 3-D V update arrays - ,solver_int_state%INPES & !<-- # of tasks in east-west on this domain - ,solver_int_state%JNPES & !<-- # of tasks in north-south on this domain - ,solver_int_state%ITS & !<-- Starting integration index in I - ,solver_int_state%ITE & !<-- Ending integration index in I - ,solver_int_state%JTS & !<-- Starting integration index in J - ,solver_int_state%JTE & !<-- Ending integration index in J - ,solver_int_state%IMS & !<-- Starting memory index in I - ,solver_int_state%IME & !<-- Ending memory index in I - ,solver_int_state%JMS & !<-- Starting memory index in J - ,solver_int_state%JME & !<-- Ending memory index in J - ,solver_int_state%IDS & !<-- Starting domain index in I - ,solver_int_state%IDE & !<-- Ending domain index in I - ,solver_int_state%JDS & !<-- Starting domain index in J - ,solver_int_state%JDE & !<-- Ending domain index in J - ) -! - timers(my_domain_id)%update_interior_from_nest_tim= & - timers(my_domain_id)%update_interior_from_nest_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Update all nest points that have moved outside of its domain's -!*** pre-move footprint. -!----------------------------------------------------------------------- -! - btim=timef() -! - CALL UPDATE_INTERIOR_FROM_PARENT(IMP_STATE & !<-- The Domain import state - ,domain_int_state%SFC_FILE_RATIO & !<-- Ratio of upper parent grid increment to this domain's - ,domain_int_state%MOVE_BUNDLE_H & !<-- The Bundle of pointers to update H variables - ,NUM_FIELDS_MOVE_2D_H_I & !<-- Total # of 2-D integer H Fields in the Bundle - ,NUM_FIELDS_MOVE_2D_H_R & !<-- Total # of 2-D real H Fields in the Bundle - ,NUM_FIELDS_MOVE_3D_H & !<-- Total # of 3-D H Fields in the Bundle - ,domain_int_state%MOVE_BUNDLE_V & !<-- The Bundle of pointers to update V variables - ,NUM_FIELDS_MOVE_2D_V & !<-- Total # of 2-D V Fields in the Bundle - ,NUM_FIELDS_MOVE_3D_V & !<-- Total # of 3-D V Fields in the Bundle - ,solver_int_state%GLAT & !<-- This domain's geographic latitude (radians) - ,solver_int_state%GLON & !<-- This domain's geographic longitude (radians) - ,solver_int_state%ITS & !<-- Starting integration index in I - ,solver_int_state%ITE & !<-- Ending integration index in I - ,solver_int_state%JTS & !<-- Starting integration index in J - ,solver_int_state%JTE & !<-- Ending integration index in J - ,solver_int_state%IMS & !<-- Starting memory index in I - ,solver_int_state%IME & !<-- Ending memory index in I - ,solver_int_state%JMS & !<-- Starting memory index in J - ,solver_int_state%JME ) !<-- Ending memory index in J -! - timers(my_domain_id)%update_interior_from_parent_tim= & - timers(my_domain_id)%update_interior_from_parent_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="DOMAIN_RUN: Reset the MOVE_NOW Flag to False" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - MOVE_NOW=.FALSE. -! - CALL ESMF_AttributeSet(state=IMP_STATE & !<-- Domain component's import state - ,name ='MOVE_NOW' & !<-- Set Attribute with this name - ,value=MOVE_NOW & !<-- Value is reset to false - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - ENDIF moving_now -! -!----------------------------------------------------------------------- -! - ENDIF domain_moves -! -!----------------------------------------------------------------------- -! - ENDIF nests -! -!----------------------------------------------------------------------- -!*** Parents update the next timesteps their children move for the -!*** Solver internal state in case it is needed for restart output. -!----------------------------------------------------------------------- -! - IF(domain_int_state%I_AM_A_PARENT)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="DOMAIN_RUN: Get NTIMESTEP_CHILD_MOVES from Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- Domain component's import state - ,name ='NEXT_TIMESTEP_CHILD_MOVES' & !<-- Extract Attribute with this name - ,valueList=NTIMESTEP_CHILD_MOVES & !<-- When do the children move again? - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - solver_int_state%NTSCM=NTIMESTEP_CHILD_MOVES !<-- Save in the Solver internal state -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Set the filter method in the Solver internal state with the -!*** value put into the Domain import state during NMM_RUN. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Filter method from import state" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The Domain import state - ,name ='Filter_Method' & !<-- Name of the attribute to extract - ,value =FILTER_METHOD & !<-- The scalar being extracted from the import state - ,defaultValue=0 & !<-- The default value - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - solver_int_state%FILTER_METHOD=FILTER_METHOD -! -!----------------------------------------------------------------------- -!*** If this is a coupling timestep then update the fields in the -!*** Solver internal state with the imported fields in the Domain -!*** internal state that are connected to the NMM-B cap. -!----------------------------------------------------------------------- -! - DT=solver_int_state%DT -! - IF(ATM_OCN_CPL_INT>0)THEN - IF(MOD(NTIMESTEP*DT,ATM_OCN_CPL_INT)0.5)THEN - IF(domain_int_state%SST_COUPLED(I,J)>265. & - .AND. & - domain_int_state%SST_COUPLED(I,J)<325.)THEN - solver_int_state%SST(I,J)=domain_int_state%SST_COUPLED(I,J) !<-- Insert imported SST (K) into the Solver internal state - ENDIF - ENDIf - ENDDO - ENDDO -! - ENDIF - ENDIF -! -!----------------------------------------------------------------------- -!*** We are now ready to execute the Run step of the Solver component. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Execute the Run Step for the Solver" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! call print_memory() -! - CALL ESMF_GridCompRun(gridcomp =domain_int_state%SOLVER_GRID_COMP & !<-- The Solver component - ,importState=domain_int_state%IMP_STATE_SOLVER & !<-- The Solver import state - ,exportState=domain_int_state%EXP_STATE_SOLVER & !<-- The Solver export state - ,clock =CLOCK_DOMAIN & !<-- The Domain Clock - ,rc =RC) -! -! call print_memory() -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** If this is a coupled run then prepare the export fields. -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - export: IF(ATM_OCN_CPL_INT>0)THEN !<-- If true then this is a coupled run. -! -!----------------------------------------------------------------------- -!*** Accumulate those fields to be exported from the atmosphere for -!*** which mean values through the coupling interval are needed. -!*** If a new accumulation period is starting then first zero out -!*** the accumulation arrays. -!----------------------------------------------------------------------- -! -!----------------------------------------- -!*** Accumulate at the physics interval. -!----------------------------------------- -! - IF(MOD(NTIMESTEP,solver_int_state%NPHS)==0)THEN - IF(domain_int_state%KOUNT_NPHS==0)THEN - DO J=solver_int_state%JTS,solver_int_state%JTE - DO I=solver_int_state%ITS,solver_int_state%ITE - domain_int_state%MEAN_ZONAL_MOM_FLX_COUPLED(I,J)=0. - domain_int_state%MEAN_MERID_MOM_FLX_COUPLED(I,J)=0. - ENDDO - ENDDO - ENDIF -! - domain_int_state%KOUNT_NPHS=domain_int_state%KOUNT_NPHS+1 -! - DO J=solver_int_state%JTS,solver_int_state%JTE - DO I=solver_int_state%ITS,solver_int_state%ITE -! - domain_int_state%MEAN_ZONAL_MOM_FLX_COUPLED(I,J)= & !<-- Zonal momentum flx (Pa) - domain_int_state%MEAN_ZONAL_MOM_FLX_COUPLED(I,J)+solver_int_state%TAUX(I,J) -! - domain_int_state%MEAN_MERID_MOM_FLX_COUPLED(I,J)= & !<-- Meridional momentum flx (Pa) - domain_int_state%MEAN_MERID_MOM_FLX_COUPLED(I,J)+solver_int_state%TAUY(I,J) -! - ENDDO - ENDDO -! - ENDIF -! -!----------------------------------------------- -!*** Accumulate at the precipitation interval. -!----------------------------------------------- -! - IF(MOD(NTIMESTEP,solver_int_state%NPRECIP)==0)THEN -! - IF(domain_int_state%KOUNT_NPRECIP==0)THEN - DO J=solver_int_state%JTS,solver_int_state%JTE - DO I=solver_int_state%ITS,solver_int_state%ITE - domain_int_state%MEAN_PREC_RATE_COUPLED(I,J)=0. - ENDDO - ENDDO - ENDIF -! - domain_int_state%KOUNT_NPRECIP=domain_int_state%KOUNT_NPRECIP+1 - RECIP_NPRECIP=1./REAL(solver_int_state%NPRECIP*solver_int_state%DT) -! - DO J=solver_int_state%JTS,solver_int_state%JTE - DO I=solver_int_state%ITS,solver_int_state%ITE - domain_int_state%MEAN_PREC_RATE_COUPLED(I,J)= & !<-- Precipitation rate (kg m-2 s-1) - domain_int_state%MEAN_PREC_RATE_COUPLED(I,J)+solver_int_state%PREC(I,J) & - *1.E3*RECIP_NPRECIP - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Now prepare the instantaneous fields to be exported if this is -!*** at the end of the coupling interval. NTIMESTEP+1 is used for -!*** the arithmetic since we at the END of the current timestep, -!*** i.e., at the end of timestep 0 we have traversed 1 timestep. -!----------------------------------------------------------------------- -! - IF(MOD((NTIMESTEP+1)*solver_int_state%DT-EPS,ATM_OCN_CPL_INT)0 & - .AND. & - (NTIMESTEP==0 & - .OR. & - MOD(NTIMESTEP+1,solver_int_state%NTRACK*solver_int_state%NPHS)==0))THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="DOMAIN_RUN: Set the storm center location." -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - STORM_CENTER(1)=solver_int_state%TRACKER_IFIX - STORM_CENTER(2)=solver_int_state%TRACKER_JFIX -! - CALL ESMF_AttributeSet(state =EXP_STATE & !<-- Domain component's export state - ,name ='Storm Center' & !<-- Set Attribute with this name - ,itemCount=2 & !<-- Two words in the Attribute - ,valueList=STORM_CENTER & !<-- Load these Attribute values - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Update ESMF Grid, Fields, and regrid interpolation weights -!*** following a nest's shift for coupled runs. All the domain's -!*** compute tasks and write tasks need to participate. -!----------------------------------------------------------------------- -! - IF(ATM_OCN_CPL_INT>0)THEN !<-- If true then this is a coupled run. -! -!----------------------------------------------------------------------- -!*** Write tasks do not know anything about domain motion yet they -!*** must participate in these ESMF updates when the nest shifts. -!*** The lead compute task therefore must inform the write tasks -!*** (via a broadcast) whether or not motion just occurred. -!----------------------------------------------------------------------- -! - CALL MPI_BCAST(MOVED_THIS_TIMESTEP & !<-- Did the nest just shift? - ,1 & !<-- The signal is 1 word - ,MPI_LOGICAL & !<-- The signal is logical - ,0 & !<-- Broadcast from the lead compute task - ,COMM_MY_DOMAIN & !<-- Intracommunicator for all tasks on this domain. - ,IERR ) -! - IF(MOVED_THIS_TIMESTEP)THEN -! -!----------------------------------------------------------------------- -!*** Update the moving nest's wind rotation angle, cell areas, -!*** and sea mask in the DOMAIN_DESCRIPTORS object. Transfer -!*** post-shift values to the ESMF Grid. -!----------------------------------------------------------------------- -! - ITS=solver_int_state%ITS - ITE=solver_int_state%ITE - JTS=solver_int_state%JTS - JTE=solver_int_state%JTE -! - CALL ROTANGLE_CELLAREA_SEAMASK(SOLVER_INT_STATE & - ,ITS,ITE,JTS,JTE & - ,DOMAIN_DESCRIPTORS(MY_DOMAIN_ID)%ROT_ANGLE & - ,DOMAIN_DESCRIPTORS(MY_DOMAIN_ID)%CELL_AREA & - ,DOMAIN_DESCRIPTORS(MY_DOMAIN_ID)%SEA_MASK ) -! - ALLOCATE(GLAT_DBL(ITS:ITE,JTS:JTE)) - ALLOCATE(GLON_DBL(ITS:ITE,JTS:JTE)) - ALLOCATE(VLAT_DBL(ITS:ITE,JTS:JTE)) - ALLOCATE(VLON_DBL(ITS:ITE,JTS:JTE)) -! - RAD2DEG = 180._kdbl/ACOS(-1._kdbl) - DO J=JTS,JTE - DO I=ITS,ITE - GLAT_DBL(I,J)=solver_int_state%GLAT(I,J)*RAD2DEG - GLON_DBL(I,J)=solver_int_state%GLON(I,J)*RAD2DEG - VLAT_DBL(I,J)=solver_int_state%VLAT(I,J)*RAD2DEG - VLON_DBL(I,J)=solver_int_state%VLON(I,J)*RAD2DEG - ENDDO - ENDDO -! - CALL NMMB_GridUpdate(MY_DOMAIN_ID & - ,DOMAIN_DESCRIPTORS & - ,DOMAIN_DESCRIPTORS(MY_DOMAIN_ID)%CELL_AREA & - ,DOMAIN_DESCRIPTORS(MY_DOMAIN_ID)%SEA_MASK & - ,GLON_DBL & - ,GLAT_DBL & - ,VLON_DBL & - ,VLAT_DBL & - ,RC ) -! - DEALLOCATE(GLAT_DBL) - DEALLOCATE(GLON_DBL) - DEALLOCATE(VLAT_DBL) - DEALLOCATE(VLON_DBL) -! - MOVED_THIS_TIMESTEP=.FALSE. -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF fcst_pes -! -!----------------------------------------------------------------------- -! - timers(my_domain_id)%total_integ_tim=timers(my_domain_id)%total_integ_tim+(timef()-btim0) -! -!----------------------------------------------------------------------- -!*** The final error signal information. -!----------------------------------------------------------------------- -! - IF(RC_RUN==ESMF_SUCCESS)THEN -! WRITE(0,*)'DOMAIN RUN step succeeded' - ELSE - WRITE(0,*)'DOMAIN RUN step failed RC_RUN=',RC_RUN - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE DOMAIN_RUN -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE DOMAIN_FINALIZE(DOMAIN_GRID_COMP & - ,IMP_STATE & - ,EXP_STATE & - ,CLOCK_DOMAIN & - ,RC_FINALIZE) -! -!----------------------------------------------------------------------- -!*** This routine Finalizes the Domain gridded component. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_GridComp) :: DOMAIN_GRID_COMP !<-- The Domain gridded component -! - TYPE(ESMF_State) :: IMP_STATE & !<-- The Domain finalize step's import state - ,EXP_STATE !<-- The Domain finalize step's export state -! - TYPE(ESMF_Clock) :: CLOCK_DOMAIN !<-- The Domain ESMF Clock -! - INTEGER,INTENT(OUT) :: RC_FINALIZE !<-- Return code for the Finalize step -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER :: I,J - INTEGER :: RC ! The final error signal variables. -! - CHARACTER(50):: MODE -! - LOGICAL(kind=KLOG) :: PHYSICS_ON -! - TYPE(ESMF_Config) :: CF !<-- The config object -! - TYPE(WRAP_DOMAIN_INTERNAL_STATE) :: WRAP !<-- The F90 wrap of the Domain internal state -! - TYPE(DOMAIN_INTERNAL_STATE),POINTER :: DOMAIN_INT_STATE !<-- The Domain internal state pointer -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RC_FINALIZE=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** Retrieve the config object CF from the Domain component. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Retrieve Config Object from Domain Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGet(gridcomp=DOMAIN_GRID_COMP & !<-- The Domain component - ,config =CF & !<-- The config object (~namelist) - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINALIZE) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Extract the diabatic/adiabatic flag from the configure file. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Retrieve Adiabatic Flag from Config Object" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & - ,value =MODE & - ,label ='adiabatic:' & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINALIZE) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - IF(TRIM(MODE)=='TRUE')THEN - PHYSICS_ON=.FALSE. - WRITE(0,*)' Finalize without physics coupling. ' - ELSE - PHYSICS_ON=.TRUE. - WRITE(0,*)' Finalize with physics coupling. ' - ENDIF -! -!----------------------------------------------------------------------- -!*** Retrieve the Domain component's internal state. -!----------------------------------------------------------------------- -! - CALL ESMF_GridCompGetInternalState(DOMAIN_GRID_COMP & !<-- The Domain component - ,WRAP & !<-- The F90 wrap of the Domain internal state - ,RC) -! - DOMAIN_INT_STATE=>wrap%DOMAIN_INT_STATE -! -!----------------------------------------------------------------------- -!*** Finalize the Solver subcomponent. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Finalize the Solver Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompFinalize(gridcomp =domain_int_state%SOLVER_GRID_COMP & - ,importState=domain_int_state%IMP_STATE_SOLVER & - ,exportState=domain_int_state%EXP_STATE_SOLVER & - ,clock =CLOCK_DOMAIN & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -!ratko CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINALIZE) -! - FIX later - RC=ESMF_SUCCESS - RC_FINALIZE=ESMF_SUCCESS -!ratko -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Destroy all States. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Destroy States" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateDestroy(state=domain_int_state%IMP_STATE_SOLVER & - ,rc =RC) -! - CALL ESMF_StateDestroy(state=domain_int_state%EXP_STATE_SOLVER & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINALIZE) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** If quilting was selected for the generation of output, -!*** finalize and destroy objects related to the Write components. -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - IF(domain_int_state%QUILTING)THEN - CALL WRITE_DESTROY(DOMAIN_GRID_COMP & - ,DOMAIN_INT_STATE & - ,CLOCK_DOMAIN) - ENDIF -! -!----------------------------------------------------------------------- -!*** Destroy the Domain Clock. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Destroy Domain Clock" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockDestroy(clock=CLOCK_DOMAIN & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINALIZE) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Destroy all subcomponents. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Destroy the Solver Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompDestroy(gridcomp=domain_int_state%SOLVER_GRID_COMP & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINALIZE) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** The final error signal information. -!----------------------------------------------------------------------- -! - IF(RC_FINALIZE==ESMF_SUCCESS)THEN - WRITE(0,*)'DOMAIN FINALIZE step succeeded' - ELSE - WRITE(0,*)'DOMAIN FINALIZE step failed' - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE DOMAIN_FINALIZE -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE DOMAIN_SETUP(MYPE_IN & - ,MPI_INTRA & - ,QUILTING & - ,CF & - ,DOMAIN_GRID_COMP & - ,DOMAIN_INT_STATE & - ,GRID_DOMAIN) -! -!----------------------------------------------------------------------- -!*** This routine contains NMM-specific code for the Domain component: -!*** (1) Setting up distributed memory parallelism in the NMM; -!*** (2) Creating the ESMF Grid for the Domain components; -!*** (3) Sharing local subdomain index limits among tasks. -!----------------------------------------------------------------------- -! - USE module_DOMAIN_INTERNAL_STATE -! - USE module_DM_PARALLEL,ONLY : DECOMP & - ,LOCAL_ISTART,LOCAL_IEND & - ,LOCAL_JSTART,LOCAL_JEND & - ,SETUP_SERVERS -! - USE module_KINDS -! -!------------------------ -!*** Argument variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: MYPE_IN & !<-- Each MPI task's rank - ,MPI_INTRA !<-- The communicator with the domain's fcst and quilt tasks. -! - LOGICAL(kind=KLOG),INTENT(IN) :: QUILTING !<-- Has output via quilt tasks been specified? -! - TYPE(ESMF_Config),INTENT(INOUT) :: CF !<-- This domain's configure object -! - TYPE(ESMF_GridComp),INTENT(INOUT) :: DOMAIN_GRID_COMP !<-- The Domain component -! - TYPE(DOMAIN_INTERNAL_STATE),INTENT(INOUT) :: DOMAIN_INT_STATE !<-- The Domain Internal State -! - TYPE(ESMF_Grid),INTENT(OUT) :: GRID_DOMAIN !<-- The ESMF Grid for the NMM integration grid -! -!--------------------- -!*** Local variables -!--------------------- -! - INTEGER(kind=KINT) :: I,IERR,J,K,N,NUM_PES,RC,RC_DOMAIN -! - INTEGER(kind=KINT) :: IM,JM & !<-- Horizontal dimensions of the full integration grid - ,INPES,JNPES & !<-- MPI tasks in I and J directions - ,LM & !<-- Number of atmospheric model layers - ,MPI_INTRA_B & !<-- The MPI intra-communicator - ,MYPE & !<-- My MPI task ID - ,NUM_PES_FCST & !<-- Number of MPI tasks applied to the forecast - ,NUM_PES_TOT & !<-- Total # of MPI tasks in the job - ,WRITE_GROUPS & !<-- Number of groups of write tasks - ,WRITE_TASKS_PER_GROUP !<-- #of tasks in each write group -! - INTEGER(kind=KINT),DIMENSION(2) :: I1 & !<-- # of I and J points in each fcst task's subdomain - ,MIN,MAX & !<-- Set start/end of each Grid dimension - ,NCOUNTS !<-- Array with I/J limits of MPI task subdomains -! - CHARACTER(50) :: MODE !<-- Flag for global or regional run -! - LOGICAL(kind=KLOG) :: GLOBAL !<-- .TRUE. => global ; .FALSE. => regional -! - TYPE(ESMF_VM) :: VM !<-- The ESMF virtual machine. -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - MYPE=MYPE_IN -! -!----------------------------------------------------------------------- -!*** Set up parameters for MPI communications on this domain's grid. -!----------------------------------------------------------------------- -! - CALL MPI_COMM_SIZE(MPI_INTRA,NUM_PES_TOT,IERR) -! - NUM_PES=NUM_PES_TOT -! -!----------------------------------------------------------------------- -!*** Establish the task layout including the Write tasks. -!*** The MPI communicator was provided as input and -!*** the forecast tasks in the I and J directions are -!*** extracted from a configure file. -!*** Give those to SETUP_SERVERS which will split the -!*** communicator between Forecast and Quilt/Write tasks. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_SETUP: Get INPES/JNPES from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL MPI_COMM_DUP(MPI_INTRA,MPI_INTRA_B,RC) !<-- Use a duplicate of the communicator for safety -! - CALL ESMF_ConfigGetAttribute(config=CF & - ,value =INPES & !<-- # of fcst tasks in I direction - ,label ='inpes:' & - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF & - ,value =JNPES & !<-- # of fcst tasks in J direction - ,label ='jnpes:' & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_DOMAIN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Set up Quilt/Write task specifications. -!*** First retrieve the task and group counts from the config file. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_SETUP: Get Write Task/Group Info from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(CF & !<-- The configure file - ,WRITE_GROUPS & !<-- Number of write groups from config file - ,label ='write_groups:' & - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(CF & !<-- The configure file - ,WRITE_TASKS_PER_GROUP & !<-- Number of write tasks per group from config file - ,label ='write_tasks_per_group:' & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_DOMAIN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Segregate the Forecast tasks from the Quilt/Write tasks. -!----------------------------------------------------------------------- -! - CALL SETUP_SERVERS(MYPE,INPES,JNPES,NUM_PES & - ,WRITE_GROUPS,WRITE_TASKS_PER_GROUP & - ,MPI_INTRA_B,QUILTING) -! -!*** -!*** NOTE: At this point, NUM_PES is the number of Forecast tasks only. -!*** -!----------------------------------------------------------------------- -! - NUM_PES_FCST=INPES*JNPES !<-- Number of forecast tasks - domain_int_state%NUM_PES_FCST=NUM_PES_FCST !<-- Save this for DOMAIN's Run step -! -!----------------------------------------------------------------------- -!*** Allocate and fill the task list that holds the IDs of -!*** the Forecast tasks. -!----------------------------------------------------------------------- -! - ALLOCATE(domain_int_state%PETLIST_FCST(NUM_PES_FCST)) !<-- Task IDs of the forecast tasks -! - DO N=0,NUM_PES_FCST-1 - domain_int_state%PETLIST_FCST(N+1)=N !<-- Collect just the forecast task IDs - ENDDO -! -!----------------------------------------------------------------------- -!*** Retrieve the VM (Virtual Machine) of the Domain component. -!*** We need VM now to set up the DE layout. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_SETUP: Retrieve VM from Domain Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGet(gridcomp=DOMAIN_GRID_COMP & !<-- The Domain component - ,vm =VM & !<-- The ESMF Virtual Machine - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_DOMAIN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Create DE layout based on the I tasks by J tasks specified in -!*** the config file. -!*** This refers only to Forecast tasks. -!----------------------------------------------------------------------- -! -!d IF(MYPEwrap%DOMAIN_INT_STATE -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** What are the start time and the current time? -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_FILTERING: Extract StartTime,CurrentTime" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock =CLOCK_DOMAIN & - ,startTime=STARTTIME & - ,currTime =CURRTIME & - ,timeStep =DT_ESMF & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FILT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_FILTERING: Get Actual Timestep from ESMF Variable" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeIntervalGet(timeinterval=DT_ESMF & !<-- the ESMF timestep - ,s =INTEGER_DT & !<-- the integer part of the timestep in seconds - ,sN =NUMERATOR_DT & !<-- the numerator of the fractional second - ,sD =IDENOMINATOR_DT & !<-- the denominator of the fractional second - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FILT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** What is the Clock direction? -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_FILTERING: Extract Clock Direction." -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- Extract the direction of the Clock from the import state - ,name ='Clock_Direction' & - ,value=CLOCK_DIRECTION & - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FILT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_FILTERING: Extract Mean_On Flag from Imp State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- Extract MEAN_ON flag from import state - ,name ='MEAN_ON' & - ,value=MEAN_ON & - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FILT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_FILTERING: Extract Filter Method from Imp State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<- Extract FILTER_METHOD flag from import state - ,name ='Filter_Method' & - ,value=FILTER_METHOD & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FILT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - fcst_tasks: IF(MYPEwrap_solver%INT_STATE -! -!----------------------- -!*** The initial stage -!----------------------- -! - IF(CURRTIME==STARTTIME .and. domain_int_state%FIRST_FILTER)THEN - domain_int_state%FIRST_FILTER=.FALSE. - CALL DIGITAL_FILTER_PHY_INIT_NMM(domain_int_state%FILT_BUNDLE_RESTORE & - ,solver_int_state%ITS & - ,solver_int_state%ITE & - ,solver_int_state%JTS & - ,solver_int_state%JTE & - ,solver_int_state%LM & - ,domain_int_state%NUM_FIELDS_RESTORE_2D & - ,domain_int_state%NUM_FIELDS_RESTORE_3D & - ,domain_int_state%SAVE_2D_PHYS & - ,domain_int_state%SAVE_3D_PHYS ) - ENDIF - - IF(CURRTIME==STARTTIME)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract NDFISTEP from Domain Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- Extract the filter value NDFISTEP from the import state - ,name ='NDFISTEP' & - ,value=NDFISTEP & - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FILT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - INTEGER_DT=ABS(INTEGER_DT) -! - CALL DIGITAL_FILTER_DYN_INIT_NMM(domain_int_state%FILT_BUNDLE_FILTER & - ,NDFISTEP & - ,INTEGER_DT & - ,NUMERATOR_DT & - ,IDENOMINATOR_DT & - ,solver_int_state%ITS & - ,solver_int_state%ITE & - ,solver_int_state%JTS & - ,solver_int_state%JTE & - ,solver_int_state%LM & - ,domain_int_state%NUM_FIELDS_FILTER_2D & - ,domain_int_state%NUM_FIELDS_FILTER_3D & - ,domain_int_state%KSTEP & - ,domain_int_state%NSTEP & - ,domain_int_state%TOTALSUM & - ,domain_int_state%DOLPH_WGTS & - ,domain_int_state%SAVE_2D & - ,domain_int_state%SAVE_3D ) -! - ENDIF -! -!----------------------------------------------------------------------- - direction: IF(CLOCK_DIRECTION(1:7)=='Forward')THEN -!----------------------------------------------------------------------- -! -!------------------------- -!*** The summation stage -!------------------------- -! - startdef: IF(CURRTIME == STARTTIME)THEN -! - DFIHR=NDFISTEP*(INTEGER_DT+(float(NUMERATOR_DT)/IDENOMINATOR_DT)) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set HALFDFIINTVAL in Summation State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeIntervalSet(timeinterval=HALFDFIINTVAL & - ,s =DFIHR & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FILT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - HALFDFITIME=CURRTIME+HALFDFIINTVAL - DFITIME=HALFDFITIME+HALFDFIINTVAL -! - ENDIF startdef -! -!--------------------- -! - IF(CURRTIME>=STARTTIME)THEN - CALL DIGITAL_FILTER_DYN_SUM_NMM(domain_int_state%FILT_BUNDLE_FILTER & - ,MEAN_ON & - ,solver_int_state%ITS & - ,solver_int_state%ITE & - ,solver_int_state%JTS & - ,solver_int_state%JTE & - ,solver_int_state%LM & - ,domain_int_state%NUM_FIELDS_FILTER_2D & - ,domain_int_state%NUM_FIELDS_FILTER_3D & - ,domain_int_state%KSTEP & - ,domain_int_state%NSTEP & - ,domain_int_state%TOTALSUM & - ,domain_int_state%DOLPH_WGTS & - ,domain_int_state%SAVE_2D & - ,domain_int_state%SAVE_3D ) - ENDIF -! -!--------------------- -! - IF(CURRTIME==HALFDFITIME .AND. FILTER_METHOD == 1)THEN - CALL DIGITAL_FILTER_PHY_SAVE_NMM(domain_int_state%FILT_BUNDLE_RESTORE & - ,solver_int_state%ITS & - ,solver_int_state%ITE & - ,solver_int_state%JTS & - ,solver_int_state%JTE & - ,domain_int_state%NUM_FIELDS_RESTORE_2D & - ,domain_int_state%NUM_FIELDS_RESTORE_3D & - ,domain_int_state%SAVE_2D_PHYS & - ,domain_int_state%SAVE_3D_PHYS ) - ENDIF -! -!--------------------- -!*** The final stage -!--------------------- -! - TESTTIME=CURRTIME+DT_ESMF -! - IF(TESTTIME==DFITIME)THEN -! - CALL DIGITAL_FILTER_DYN_AVERAGE_NMM(domain_int_state%FILT_BUNDLE_FILTER & - ,solver_int_state%ITS & - ,solver_int_state%ITE & - ,solver_int_state%JTS & - ,solver_int_state%JTE & - ,solver_int_state%LM & - ,domain_int_state%NUM_FIELDS_FILTER_2D & - ,domain_int_state%NUM_FIELDS_FILTER_3D & - ,domain_int_state%KSTEP & - ,domain_int_state%NSTEP & - ,domain_int_state%TOTALSUM & - ,domain_int_state%SAVE_2D & - ,domain_int_state%SAVE_3D ) -! - CALL DIGITAL_FILTER_PHY_RESTORE_NMM(domain_int_state%FILT_BUNDLE_RESTORE & - ,solver_int_state%ITS & - ,solver_int_state%ITE & - ,solver_int_state%JTS & - ,solver_int_state%JTE & - ,domain_int_state%NUM_FIELDS_RESTORE_2D & - ,domain_int_state%NUM_FIELDS_RESTORE_3D & - ,domain_int_state%SAVE_2D_PHYS & - ,domain_int_state%SAVE_3D_PHYS ) -! - CALL ESMF_ClockPrint(clock =CLOCK_DOMAIN & - ,options="currtime string" & - ,rc =RC) - ENDIF -! -!----------------------------------------------------------------------- - ELSEIF(CLOCK_DIRECTION(1:7)=='Bckward')THEN -!----------------------------------------------------------------------- -! - IF(CURRTIME == STARTTIME)THEN - - DFIHR=NDFISTEP*(ABS(INTEGER_DT) & - +ABS(REAL(NUMERATOR_DT)/IDENOMINATOR_DT) ) -! - CALL ESMF_TimeIntervalSet(timeinterval=HALFDFIINTVAL & - ,s =DFIHR & - ,rc =RC) - CALL DIGITAL_FILTER_PHY_SAVE_NMM(domain_int_state%FILT_BUNDLE_RESTORE & - ,solver_int_state%ITS & - ,solver_int_state%ITE & - ,solver_int_state%JTS & - ,solver_int_state%JTE & - ,domain_int_state%NUM_FIELDS_RESTORE_2D & - ,domain_int_state%NUM_FIELDS_RESTORE_3D & - ,domain_int_state%SAVE_2D_PHYS & - ,domain_int_state%SAVE_3D_PHYS ) -! - HALFDFITIME=CURRTIME-HALFDFIINTVAL - DFITIME=HALFDFITIME-HALFDFIINTVAL -! - ENDIF -! -!------------------------- -!*** The summation stage -!------------------------- -! - IF(CURRTIME<=STARTTIME)THEN - CALL DIGITAL_FILTER_DYN_SUM_NMM(domain_int_state%FILT_BUNDLE_FILTER & - ,MEAN_ON & - ,solver_int_state%ITS & - ,solver_int_state%ITE & - ,solver_int_state%JTS & - ,solver_int_state%JTE & - ,solver_int_state%LM & - ,domain_int_state%NUM_FIELDS_FILTER_2D & - ,domain_int_state%NUM_FIELDS_FILTER_3D & - ,domain_int_state%KSTEP & - ,domain_int_state%NSTEP & - ,domain_int_state%TOTALSUM & - ,domain_int_state%DOLPH_WGTS & - ,domain_int_state%SAVE_2D & - ,domain_int_state%SAVE_3D ) - ENDIF -! -!--------------------- -!*** The final stage -!--------------------- -! - TESTTIME=CURRTIME+DT_ESMF -! - IF(TESTTIME==DFITIME)THEN - IF (FILTER_METHOD == 3) THEN - CALL DIGITAL_FILTER_DYN_AVERAGE_NMM(domain_int_state%FILT_BUNDLE_FILTER & - ,solver_int_state%ITS & - ,solver_int_state%ITE & - ,solver_int_state%JTS & - ,solver_int_state%JTE & - ,solver_int_state%LM & - ,domain_int_state%NUM_FIELDS_FILTER_2D & - ,domain_int_state%NUM_FIELDS_FILTER_3D & - ,domain_int_state%KSTEP & - ,domain_int_state%NSTEP & - ,domain_int_state%TOTALSUM & - ,domain_int_state%SAVE_2D & - ,domain_int_state%SAVE_3D ) - ENDIF -! - CALL ESMF_ClockPrint(clock =CLOCK_DOMAIN & - ,options="currtime string" & - ,rc =RC) - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF direction -! - ENDIF fcst_tasks -! -!----------------------------------------------------------------------- -! - END SUBROUTINE NMM_FILTERING -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE CALL_WRITE_ASYNC(DOMAIN_GRID_COMP & - ,IMP_STATE & - ,EXP_STATE & - ,CLOCK_DOMAIN & - ,RC_RUN2) -! -!----------------------------------------------------------------------- -!*** Phase 3 of the Run step of the NMM Domain component. -!*** It initiates the writing of history/restart files -!*** from each Domain component. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_GridComp) :: DOMAIN_GRID_COMP !<-- The Domain gridded component -! - TYPE(ESMF_State) :: IMP_STATE & !<-- The Domain component's import state - ,EXP_STATE !<-- The Domain component's export state -! - TYPE(ESMF_Clock) :: CLOCK_DOMAIN !<-- The Domain ESMF Clock -! - TYPE(ESMF_Time) :: CURRTIME & !<-- The ESMF current time. - ,STOPTIME !<-- The ESMF start time. -! - INTEGER,INTENT(OUT) :: RC_RUN2 !<-- Return code for the Run step -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: LENGTH,N,NB,RC -! - TYPE(DOMAIN_INTERNAL_STATE),POINTER :: DOMAIN_INT_STATE !<-- The Domain internal state pointer -! - TYPE(WRAP_DOMAIN_INTERNAL_STATE) :: WRAP !<-- The F90 wrap of the Domain internal state -! - CHARACTER(ESMF_MAXSTR) :: CWRT -! - LOGICAL(kind=KINT) :: LAST_TIME !<-- Test time logical -! - LOGICAL(kind=KLOG) :: I_AM_A_FCST_TASK -! - TYPE(SOLVER_INTERNAL_STATE),POINTER :: SOLVER_INT_STATE -! - TYPE(WRAP_SOLVER_INT_STATE) :: WRAP_SOLVER -! - type(esmf_time) :: ringtime - type(esmf_timeinterval) :: ringinterval - integer :: month,day - integer(esmf_kind_i4) :: yy,mm,dd,h,m,s,sn,sd -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RC_RUN2=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** Write a history file at the end of the appropriate timesteps. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** First retrieve the Domain component's internal state. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Run2: Retrieve Domain Component's Internal State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGetInternalState(DOMAIN_GRID_COMP & !<-- The Domain gridded component - ,WRAP & !<-- The F90 wrap of the Domain internal state - ,RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN2) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DOMAIN_INT_STATE=>wrap%DOMAIN_INT_STATE -! -!----------------------------------------------------------------------- -!*** If quilting was not specified then exit. -!----------------------------------------------------------------------- -! - IF(.NOT.domain_int_state%QUILTING)THEN - RETURN - ENDIF -! - call esmf_gridcompget(gridcomp=domain_grid_comp & - ,vm=vm & - ,rc=rc) - call esmf_vmget(vm=vm & - ,localpet=mype & - ,rc=rc) -!----------------------------------------------------------------------- -!*** Is this a forecast task? -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Fcst-or-Write Task Flag from the Domain Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE & !<-- The Domain component export state - ,name ='Fcst-or-Write Flag' & !<-- Use this name inside the state - ,value=I_AM_A_FCST_TASK & !<-- The logical being inserted into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN2) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Check to see if the history alarm is ringing and if so then -!*** prepare to call the Write subroutine WRITE_ASYNC. -!----------------------------------------------------------------------- -! -! write(0,80551)ESMF_AlarmIsRinging(alarm=domain_int_state%ALARM_HISTORY,rc=rc) -80551 format(' CALL_WRITE_ASYNC ALARM_HISTORY AlarmIsRinging=',l1) -! call esmf_alarmget(alarm=domain_int_state%ALARM_HISTORY & -! ,ringtime=ringtime & -! ,ringinterval=ringinterval & -! ,rc=rc) -! call esmf_timeget(time=ringtime & -! ,yy=yy & -! ,mm=month & -! ,dd=dd & -! ,h=h & -! ,m=m & -! ,s=s & -! ,sn=sn & -! ,sd=sd) -! write(0,*)' ALARM_HISTORY ringtime: y=',yy,' mm=',month,' dd=',dd,' h=',h & -! ,' m=',m,' s=',s,' sn=',sn,'s d=',sd -! call esmf_timeintervalget(timeinterval=ringinterval & -! ,m=m & -! ,s=s & -! ,sn=sn & -! ,sd=sd) -! write(0,*)' ringinterval: m=',m,' s=',s,' sn=',sn,'s d=',sd - alarms: IF(ESMF_AlarmIsRinging(alarm=domain_int_state%ALARM_HISTORY & !<-- The history output alarm - ,rc =RC) & - .OR. & - ESMF_AlarmIsRinging(alarm=domain_int_state%ALARM_RESTART & !<-- The restart output alarm - ,rc =RC))THEN -! -! write(0,80552) -80552 format(' CALL_WRITE_ASYNC ALARM_HISTORY AlarmIsRinging= T ') -!----------------------------------------------------------------------- -!*** Extract the Solver internal state in order to access -!*** output-related variables within it. -!----------------------------------------------------------------------- -! - fcst_tasks: IF(I_AM_A_FCST_TASK)THEN -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="CALL_WRITE_ASYNC: Extract Solver Internal State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGetInternalState(domain_int_state%SOLVER_GRID_COMP & !<-- The Solver component - ,WRAP_SOLVER & - ,RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN2) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - SOLVER_INT_STATE=>wrap_solver%INT_STATE -! -!----------------------------------------------------------------------- -!*** Refresh the values of the ESMF Attributes in the history/restart -!*** Bundles because Attributes are not updated automatically as Fields -!*** are. -!----------------------------------------------------------------------- -! - all_vars: DO N=1,solver_int_state%NUM_VARS !<-- Loop through all output variables. -! -!--------------------- -!*** Integer scalars -!--------------------- -! - IF (solver_int_state%VARS(N)%TKR == TKR_I0D) THEN !<-- Select integer scalars -! - IF (solver_int_state%VARS(N)%HISTORY) THEN !<-- Is integer scalar specified for history output? -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="CALL_WRITE_ASYNC: Update Integer Scalar in History Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(FIELDBUNDLE=solver_int_state%BUNDLE_ARRAY(1) & !<-- The output Bundle - ,name =solver_int_state%VARS(N)%VBL_NAME & !<-- Name of the integer scalar - ,value =solver_int_state%VARS(N)%I0D & !<-- The scalar inserted into the Bundle - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN2) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! - IF(solver_int_state%VARS(N)%RESTART)THEN !<-- Is integer scalar specified for restart output -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="CALL_WRITE_ASYNC: Update Integer Attribute in Restart Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(FIELDBUNDLE=solver_int_state%BUNDLE_ARRAY(2) & !<-- The restart Bundle - ,name =solver_int_state%VARS(N)%VBL_NAME & !<-- Name of the integer scalar - ,value =solver_int_state%VARS(N)%I0D & !<-- The scalar being inserted into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN2) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! - ENDIF -! -!------------------------ -!*** 1-D integer arrays -!------------------------ -! - IF (solver_int_state%VARS(N)%TKR == TKR_I1D) THEN !<-- Select 1-D integer arrays -! - LENGTH=SIZE(solver_int_state%VARS(N)%I1D) -! - IF (solver_int_state%VARS(N)%HISTORY) THEN !<-- Is the array specified for history output? -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="CALL_WRITE_ASYNC: Update 1-D Integer Array in History Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(FIELDBUNDLE=solver_int_state%BUNDLE_ARRAY(1) & !<-- The history Bundle - ,name =solver_int_state%VARS(N)%VBL_NAME & !<-- Name of the 1-D integer array - ,itemCount =LENGTH & !<-- # of elements in this attribute - ,valueList =solver_int_state%VARS(N)%I1D & !<-- The array being inserted into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN2) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! - IF(solver_int_state%VARS(N)%RESTART)THEN !<-- Is 1-D integer array specified for restart output? -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="CALL_WRITE_ASYNC: Update 1-D Integer Array in Restart Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(FIELDBUNDLE=solver_int_state%BUNDLE_ARRAY(2) & !<-- The restart Bundle - ,name =solver_int_state%VARS(N)%VBL_NAME & !<-- Name of the integer scalar - ,itemCount =LENGTH & !<-- # of elements in this attribute - ,valueList =solver_int_state%VARS(N)%I1D & !<-- The array being inserted into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN2) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! - ENDIF -! -!------------------ -!*** Real scalars -!------------------ -! - IF(solver_int_state%VARS(N)%TKR == TKR_R0D)THEN !<-- Select real scalars -! - IF(solver_int_state%VARS(N)%HISTORY)THEN !<-- Is real scalar specified for history output? -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="CALL_WRITE_ASYNC: Update Real Scalar in History Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(FIELDBUNDLE=solver_int_state%BUNDLE_ARRAY(1) & !<-- The history Bundle - ,name =solver_int_state%VARS(N)%VBL_NAME & !<-- Name of the real scalar - ,value =solver_int_state%VARS(N)%R0D & !<-- The scalar being inserted into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN2) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! - IF(solver_int_state%VARS(N)%RESTART)THEN !<-- Is real scalar specified for restart output -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="CALL_WRITE_ASYNC: Update Real Scalar in Restart Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(FIELDBUNDLE=solver_int_state%BUNDLE_ARRAY(2) & !<-- The restart Bundle - ,name =solver_int_state%VARS(N)%VBL_NAME & !<-- Name of the real scalar - ,value =solver_int_state%VARS(N)%R0D & !<-- The scalar being inserted into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN2) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! - ENDIF -! -!--------------------- -!*** 1-D real arrays -!--------------------- -! - IF(solver_int_state%VARS(N)%TKR == TKR_R1D)THEN !<-- Select 1-D real arrays -! - LENGTH=SIZE(solver_int_state%VARS(N)%R1D) -! - IF(solver_int_state%VARS(N)%HISTORY)THEN !<-- Is the array specified for history output? -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="CALL_WRITE_ASYNC: Update 1-D Real Array in History Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(FIELDBUNDLE=solver_int_state%BUNDLE_ARRAY(1) & !<-- The history Bundle - ,name =solver_int_state%VARS(N)%VBL_NAME & !<-- Name of the 1-D real array - ,itemCount =LENGTH & !<-- # of elements in this attribute - ,valueList =solver_int_state%VARS(N)%R1D & !<-- The array being inserted into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN2) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! - IF(solver_int_state%VARS(N)%RESTART)THEN !<-- Is the array specified for restart output? -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="CALL_WRITE_ASYNC: Update 1-D Real Array in Restart Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(FIELDBUNDLE=solver_int_state%BUNDLE_ARRAY(2) & !<-- The restart Bundle - ,name =solver_int_state%VARS(N)%VBL_NAME & !<-- Name of the 1-D real array - ,itemCount =LENGTH & !<-- # of elements in this attribute - ,valueList =solver_int_state%VARS(N)%R1D & !<-- The array being inserted into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN2) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO all_vars -! -!----------------------------------------------------------------------- -! - ENDIF fcst_tasks -! -!----------------------------------------------------------------------- -! - ELSE -! - RETURN !<-- No output alarm is ringing -! - ENDIF alarms -! -!----------------------------------------------------------------------- -!*** Check to see if the history alarm is ringing and if so then -!*** call the Write subroutine WRITE_ASYNC to execute the writing -!*** of a history file. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="CALL_WRITE_ASYNC: Is ALARM_HISTORY ringing?" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(ESMF_AlarmIsRinging(alarm=domain_int_state%ALARM_HISTORY & !<-- The history output alarm - ,rc =RC))THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN2) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! call print_memory() - IF(domain_int_state%QUILTING)THEN - CWRT='History' - CALL WRITE_ASYNC(DOMAIN_GRID_COMP & - ,DOMAIN_INT_STATE & - ,CLOCK_DOMAIN & - ,MYPE & - ,CWRT) - ENDIF -! call print_memory() -! -!----------------------------------------------------------------------- -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Write a restart file at the end of the appropriate timesteps. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="CALL_WRITE_ASYNC: Is ALARM_RESTART ringing?" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(ESMF_AlarmIsRinging(alarm=domain_int_state%ALARM_RESTART & !<-- The restart output alarm - ,rc =RC))THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN2) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Retrieve the Domain component's internal state. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Run2: Retrieve Domain Component's Internal State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGetInternalState(DOMAIN_GRID_COMP & !<-- The Domain gridded component - ,WRAP & !<-- The F90 wrap of the Domain internal state - ,RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN2) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DOMAIN_INT_STATE=>wrap%DOMAIN_INT_STATE -! -!----------------------------------------------------------------------- -!*** Execute the writing of a restart file. -!----------------------------------------------------------------------- -! - CALL ESMF_ClockGet(clock =CLOCK_DOMAIN & !<-- The ESMF Clock of this domain - ,stopTime =STOPTIME & !<-- The simulation stop time - ,currTime =CURRTIME & !<-- Current time of simulation - ,rc =RC) -! - LAST_TIME = (STOPTIME==CURRTIME) !<-- Is it last write step? -! - IF(domain_int_state%QUILTING & - .AND. & - (.NOT.LAST_TIME & - .OR. & - domain_int_state%WRITE_LAST_RESTART) )THEN - - CWRT='Restart' - CALL WRITE_ASYNC(DOMAIN_GRID_COMP & - ,DOMAIN_INT_STATE & - ,CLOCK_DOMAIN & - ,MYPE & - ,CWRT) - ENDIF -! call print_memory() -! - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE CALL_WRITE_ASYNC -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- - - SUBROUTINE BUILD_FILT_BUNDLE(GRID_DOMAIN & - ,UBOUND_VARS & - ,VARS & - ,FILT_BUNDLE_FILTER & - ,NUM_VARS_2D_FILTER & - ,NUM_VARS_3D_FILTER & - ,FILT_BUNDLE_RESTORE & - ,NUM_VARS_2D_RESTORE & - ,NUM_VARS_3D_RESTORE & - ,RESTART) - -!----------------------------------------------------------------------- -!*** For digital filtering purposes, the model needs to know both which -!*** variables should be filtered, and which variables need to be saved, -!*** before filtering begins and restored to their original state after -!*** filtering has occurred. Insert the appropriate internal states into -!*** the appropriate bundles. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: UBOUND_VARS !<-- Upper dimension of the VARS array -! - LOGICAL(kind=KLOG),INTENT(IN):: RESTART -! - TYPE(ESMF_Grid),INTENT(IN) :: GRID_DOMAIN !<-- The ESMF Grid for this domain -! - TYPE(VAR),DIMENSION(1:UBOUND_VARS),INTENT(INOUT) :: VARS !<-- Variables in the internal state -! - TYPE(ESMF_FieldBundle),INTENT(INOUT) :: FILT_BUNDLE_FILTER & !<-- The Filter Bundle for variables to be filtered - ,FILT_BUNDLE_RESTORE !<-- The Filter Bundle for variables to be restored -! -! - INTEGER(kind=KINT),INTENT(INOUT) :: NUM_VARS_2D_FILTER & !<-- # of 2-D variables to filter - ,NUM_VARS_3D_FILTER & !<-- # of 3-D variables to filter - ,NUM_VARS_2D_RESTORE & !<-- # of 2-D variables to restore - ,NUM_VARS_3D_RESTORE !<-- # of 3-D variables to restore - -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: IOS,N,RC,RC_CMB,FILT_TYP_INT -! - CHARACTER(len=1) :: UPDATE_TYPE_CHAR -! - CHARACTER(len=2) :: CH_FILTREST -! - CHARACTER(len=25),SAVE :: FNAME_FILT='filt_vars.txt' & - ,VBL_NAME -! - CHARACTER(len=256) :: STRING -! - TYPE(ESMF_Field) :: FIELD_X -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - NUM_VARS_2D_FILTER=0 - NUM_VARS_3D_FILTER=0 - NUM_VARS_2D_RESTORE=0 - NUM_VARS_3D_RESTORE=0 -! - OPEN(unit=10,file=FNAME_FILT,status='OLD',action='READ' & !<-- Open the filtering text file with user specifications - ,iostat=IOS) -! - IF(IOS/=0)THEN - WRITE(0,*)' Failed to open ',FNAME_FILT,' so ABORT!' - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT & - ,rc =RC) - ENDIF - -!----------------------------------------------------------------------- - bundle_loop: DO -!----------------------------------------------------------------------- -! - READ(UNIT=10,FMT="(A)",iostat=IOS)STRING !<-- Read in the next specification line - IF(IOS/=0)EXIT !<-- Finished reading the specification lines -! - IF(STRING(1:1)=='#'.OR.TRIM(STRING)=='')THEN - CYCLE !<-- Read past comments and blanks. - ENDIF -! -!----------------------------------------------------------------------- -!*** Read the text line containing the filtering requirements for -!*** variable N then find that variables' place within the VARS -!*** object. -!----------------------------------------------------------------------- -! - READ(UNIT=STRING,FMT=*,iostat=IOS)VBL_NAME ,CH_FILTREST -! - CALL FIND_VAR_INDX(VBL_NAME,VARS,UBOUND_VARS,N) -! - - IF (CH_FILTREST(1:1)=='F') THEN - FILT_TYP_INT=1 - ELSEIF (CH_FILTREST(1:1)=='R') THEN - FILT_TYP_INT=2 - ELSEIF (CH_FILTREST(1:1)=='B') THEN - IF (RESTART) THEN - FILT_TYP_INT=2 - ELSE - FILT_TYP_INT=1 - ENDIF - ELSE - FILT_TYP_INT=-999 - ENDIF - - build_bundle: IF (FILT_TYP_INT==1) THEN - - IF (ASSOCIATED(VARS(N)%R2D))THEN !<-- 2-D real array -! - NUM_VARS_2D_FILTER=NUM_VARS_2D_FILTER+1 - - FIELD_X=ESMF_FieldCreate(grid =GRID_DOMAIN & !<-- The ESMF Grid for this domain - ,farray =VARS(N)%R2D & !<-- Nth variable in the VARS array - ,totalUWidth=(/IHALO,JHALO/) & !<-- Upper bound of halo region - ,totalLWidth=(/IHALO,JHALO/) & !<-- Lower bound of halo region - ,name =VARS(N)%VBL_NAME & !<-- The name of this variable - ,indexFlag =ESMF_INDEX_GLOBAL & !<-- The variable uses global indexing - ,rc =RC) -! - ELSEIF (ASSOCIATED(VARS(N)%R3D))THEN -! - NUM_VARS_3D_FILTER=NUM_VARS_3D_FILTER+1 - - FIELD_X=ESMF_FieldCreate(grid =GRID_DOMAIN & !<-- The ESMF Grid for this domain - ,farray =VARS(N)%R3D & !<-- Nth variable in the VARS array - ,totalUWidth =(/IHALO,JHALO/) & !<-- Upper bound of halo region - ,totalLWidth =(/IHALO,JHALO/) & !<-- Lower bound of halo region - ,ungriddedLBound=(/lbound(VARS(N)%R3D,dim=3)/) & - ,ungriddedUBound=(/ubound(VARS(N)%R3D,dim=3)/) & - ,name =VARS(N)%VBL_NAME & !<-- The name of this variable - ,indexFlag =ESMF_INDEX_GLOBAL & !<-- The variable uses global indexing - ,rc =RC) -! -!------------------------ -!*** No others expected -!------------------------ -! - ELSE - WRITE(0,*)' SELECTED FILTER VARIABLE IS NOT 2-D or 3-D REAL' - WRITE(0,*)' Variable name is ',VARS(N)%VBL_NAME,' for variable #',N - WRITE(0,*)' ABORT!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! -!----------------------------------------------------------------------- -!*** Add this Field to the Filt Bundle that holds all of the -!*** Fields that must be processed through digital filtering. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Field to the Filtering Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleAdd(FILT_BUNDLE_FILTER & !<-- The Filt Bundle for Filtered variables - ,(/FIELD_X/) & !<-- Add this Field to the Bundle - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CMB) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! IF (MYPE == 0) THEN -! WRITE(0,*)' added variable ',trim(VARS(N)%VBL_NAME),' to Filt Bundle Filter' -! ENDIF -!----------------------------------------------------------------------- - - - ELSEIF (FILT_TYP_INT==2) THEN - - IF (ASSOCIATED(VARS(N)%R2D))THEN !<-- 2-D real array -! - NUM_VARS_2D_RESTORE=NUM_VARS_2D_RESTORE+1 - - FIELD_X=ESMF_FieldCreate(grid =GRID_DOMAIN & !<-- The ESMF Grid for this domain - ,farray =VARS(N)%R2D & !<-- Nth variable in the VARS array - ,totalUWidth=(/IHALO,JHALO/) & !<-- Upper bound of halo region - ,totalLWidth=(/IHALO,JHALO/) & !<-- Lower bound of halo region - ,name =VARS(N)%VBL_NAME & !<-- The name of this variable - ,indexFlag =ESMF_INDEX_GLOBAL & !<-- The variable uses global indexing - ,rc =RC) -! - ELSEIF (ASSOCIATED(VARS(N)%R3D))THEN -! - NUM_VARS_3D_RESTORE=NUM_VARS_3D_RESTORE+1 - - FIELD_X=ESMF_FieldCreate(grid =GRID_DOMAIN & !<-- The ESMF Grid for this domain - ,farray =VARS(N)%R3D & !<-- Nth variable in the VARS array - ,totalUWidth =(/IHALO,JHALO/) & !<-- Upper bound of halo region - ,totalLWidth =(/IHALO,JHALO/) & !<-- Lower bound of halo region - ,ungriddedLBound=(/lbound(VARS(N)%R3D,dim=3)/) & - ,ungriddedUBound=(/ubound(VARS(N)%R3D,dim=3)/) & - ,name =VARS(N)%VBL_NAME & !<-- The name of this variable - ,indexFlag =ESMF_INDEX_GLOBAL & !<-- The variable uses global indexing - ,rc =RC) -!---------------- -!*** No others expected -!---------------- -! - ELSE - WRITE(0,*)' SELECTED FILTER VARIABLE IS NOT 2-D OR 3-D REAL' - WRITE(0,*)' Variable name is ',VARS(N)%VBL_NAME,' for variable #',N - WRITE(0,*)' ABORT!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - -!----------------------------------------------------------------------- -!*** Add this Field to the Filt Bundle that holds all of the -!*** Fields that must be processed through digital filtering -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Field to the Filtering Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleAdd(FILT_BUNDLE_RESTORE & !<-- The Filt Bundle for variables to be restored - ,(/FIELD_X/) & !<-- Add this Field to the Bundle - ,rc =RC ) -! IF (MYPE == 0) THEN -! WRITE(0,*)' added variable ',trim(VARS(N)%VBL_NAME),' to Filt Bundle Restore' -! ENDIF -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CMB) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- - - - ELSE -! if (MYPE==0) then -! write(0,*) 'will ignore ' , VARS(N)%VBL_NAME , ' for Bundle' -! endif - - ENDIF build_bundle - - - - ENDDO bundle_loop - - close(unit=10) - - - END SUBROUTINE BUILD_FILT_BUNDLE -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE BUILD_MOVE_BUNDLE(GRID_DOMAIN & - ,UBOUND_VARS & - ,VARS & - ,MOVE_BUNDLE_H & - ,NUM_VARS_2D_H_I & - ,NUM_VARS_2D_H_R & - ,NUM_VARS_3D_H & - ,NUM_LEVELS_3D_H & - ,MOVE_BUNDLE_V & - ,NUM_VARS_2D_V & - ,NUM_VARS_3D_V & - ,NUM_LEVELS_3D_V & - ) -! -!----------------------------------------------------------------------- -!*** Following a nest's move its appropriate variables will be -!*** updated. The Solver internal state variables lie within -!*** their respective VARS composite arrays. Insert the update -!*** variables from the internal state into the Bundles. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: UBOUND_VARS !<-- Upper dimension of the VARS array -! - TYPE(ESMF_Grid),INTENT(IN) :: GRID_DOMAIN !<-- The ESMF Grid for this domain -! - TYPE(VAR),DIMENSION(1:UBOUND_VARS),INTENT(INOUT) :: VARS !<-- Variables in the internal state -! - TYPE(ESMF_FieldBundle),INTENT(INOUT) :: MOVE_BUNDLE_H & !<-- The Move Bundle for H-point update variables - ,MOVE_BUNDLE_V !<-- The Move Bundle for V-point update variables -! - INTEGER(kind=KINT),INTENT(INOUT) :: NUM_LEVELS_3D_H & !<-- # of 2-D levels for all 3-D H-point variables - ,NUM_LEVELS_3D_V !<-- # of 2-D levels for all 3-D V-point variables -! - INTEGER(kind=KINT),INTENT(INOUT) :: NUM_VARS_2D_H_I & !<-- # of 2-D integer H variables updated for moving nests - ,NUM_VARS_2D_H_R & !<-- # of 2-D real H variables updated for moving nests - ,NUM_VARS_3D_H & !<-- # of 3-D real H variables updated for moving nests - ,NUM_VARS_2D_V & !<-- # of 2-D V variables updated for moving nests - ,NUM_VARS_3D_V !<-- # of 3-D V variables updated for moving nests -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: IOS,N,RC,RC_CMB,UPDATE_TYPE_INT -! - CHARACTER(len=1) :: CH_B,CHECK_EXCH,UPDATE_TYPE_CHAR -! - CHARACTER(len=2) :: CH_M -! - CHARACTER(len=9),SAVE :: FNAME='nests.txt' -! - CHARACTER(len=99) :: FIELD_NAME,VBL_NAME -! - CHARACTER(len=256) :: STRING -! - TYPE(ESMF_Field) :: FIELD_X -! - LOGICAL(kind=KLOG) :: EXCH_NEEDED -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Loop through all internal state variables. -!----------------------------------------------------------------------- -! - OPEN(unit=10,file=FNAME,status='OLD',action='READ' & !<-- Open the text file with user specifications - ,iostat=IOS) -! - IF(IOS/=0)THEN - WRITE(0,*)' Failed to open ',FNAME,' so ABORT!' - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT & - ,rc =RC) - ENDIF -! -!----------------------------------------------------------------------- - bundle_loop: DO -!----------------------------------------------------------------------- -! - READ(UNIT=10,FMT="(A)",iostat=IOS)STRING !<-- Read in the next specification line - IF(IOS/=0)EXIT !<-- Finished reading the specification lines -! - IF(STRING(1:1)=='#'.OR.TRIM(STRING)=='')THEN - CYCLE !<-- Read past comments and blanks. - ENDIF -! -!----------------------------------------------------------------------- -!*** Read the text line containing the shift specifications for -!*** variable N then find that variables' place within the VARS -!*** object. -!----------------------------------------------------------------------- -! - READ(UNIT=STRING,FMT=*,iostat=IOS)VBL_NAME & !<-- The variable's name in the text file. - ,CH_B & !<-- Not relevant here (specification for nest BC vbls) - ,CH_M !<-- Specification for moving nests -! -! - CALL FIND_VAR_INDX(VBL_NAME,VARS,UBOUND_VARS,N) -! - FIELD_NAME=TRIM(VARS(N)%VBL_NAME)//SUFFIX_MOVE -! -!----------------------------------------------------------------------- -!*** Find the 2-D and 3-D arrays in the internal state that need -!*** updating in moving nests and add them to the Move Bundle. -!*** We will also specify whether the Field is a simple H-pt variable, -!*** an H-pt land surface variable that needs to use the sea mask, -!*** a variable that is read in from an external file, or a simple -!*** V-pt variable. -! NOTE -!*** Currently ESMF will not allow the use of Attributes that are -!*** characters therefore we must translate the character codes from -!*** the txt files into something that ESMF can use. In this case -!*** we will use integers. -!----------------------------------------------------------------------- -! - UPDATE_TYPE_CHAR=CH_M(1:1) !<-- Specification flag for this Field -! - IF(UPDATE_TYPE_CHAR=='H')THEN - UPDATE_TYPE_INT=1 !<-- Ordinary H-pt variable - ELSEIF(UPDATE_TYPE_CHAR=='L')THEN - UPDATE_TYPE_INT=2 !<-- H-pt land surface variable - ELSEIF(UPDATE_TYPE_CHAR=='W')THEN - UPDATE_TYPE_INT=3 !<-- H-pt water surface variable - ELSEIF(UPDATE_TYPE_CHAR=='F')THEN - UPDATE_TYPE_INT=4 !<-- H-pt variable read from external file - ELSEIF(UPDATE_TYPE_CHAR=='V')THEN - UPDATE_TYPE_INT=5 !<-- Ordinary V-pt variable - ELSE - UPDATE_TYPE_INT=-999 !<-- Variable not specified for moving nest shifts - ENDIF -! -!----------------------------------------------------------------------- -!*** Does the variable need to have its halos exchanged so parents -!*** are able to properly update nest points? -!----------------------------------------------------------------------- -! - CHECK_EXCH=CH_M(2:2) - IF(CHECK_EXCH=='x')THEN - EXCH_NEEDED=.TRUE. - ELSE - EXCH_NEEDED=.FALSE. - ENDIF -! -!----------------------------------------------------------------------- -! - build_bundle: IF(UPDATE_TYPE_CHAR=='H' & - .OR. & - UPDATE_TYPE_CHAR=='L' & - .OR. & - UPDATE_TYPE_CHAR=='W' & - .OR. & - UPDATE_TYPE_CHAR=='F' & - )THEN -! -!----------------------------------------------------------------------- -! -!--------------------- -!*** 2-D H Variables -!--------------------- -! -!------------- -!*** Integer -!------------- -! - IF(ASSOCIATED(VARS(N)%I2D))THEN !<-- 2-D integer array on mass points -! - NUM_VARS_2D_H_I=NUM_VARS_2D_H_I+1 !<-- ALL 2-D integer variables updated on H points -! - FIELD_X=ESMF_FieldCreate(grid =GRID_DOMAIN & !<-- The ESMF Grid for this domain - ,farray =VARS(N)%I2D & !<-- Nth variable in the VARS array - ,totalUWidth=(/IHALO,JHALO/) & !<-- Upper bound of halo region - ,totalLWidth=(/IHALO,JHALO/) & !<-- Lower bound of halo region - ,name =FIELD_NAME & !<-- The name of this variable - ,indexFlag =ESMF_INDEX_GLOBAL & !<-- The variable uses global indexing - ,rc =RC) -! -!---------- -!*** Real -!---------- -! - ELSEIF(ASSOCIATED(VARS(N)%R2D))THEN !<-- 2-D real array on mass points -! - NUM_VARS_2D_H_R=NUM_VARS_2D_H_R+1 !<-- ALL 2-D real variables updated on H points -! - FIELD_X=ESMF_FieldCreate(grid =GRID_DOMAIN & !<-- The ESMF Grid for this domain - ,farray =VARS(N)%R2D & !<-- Nth variable in the VARS array - ,totalUWidth=(/IHALO,JHALO/) & !<-- Upper bound of halo region - ,totalLWidth=(/IHALO,JHALO/) & !<-- Lower bound of halo region - ,name =FIELD_NAME & !<-- The name of this variable - ,indexFlag =ESMF_INDEX_GLOBAL & !<-- The variable uses global indexing - ,rc =RC) -! -!--------------------- -!*** 3-D H Variables -!--------------------- -! -!---------- -!*** Real -!---------- -! - ELSEIF(ASSOCIATED(VARS(N)%R3D))THEN !<-- 3-D real array on mass points -! - NUM_VARS_3D_H=NUM_VARS_3D_H+1 -! - FIELD_X=ESMF_FieldCreate(grid =GRID_DOMAIN & !<-- The ESMF Grid for this domain - ,farray =VARS(N)%R3D & !<-- Nth variable in the VARS array - ,totalUWidth =(/IHALO,JHALO/) & !<-- Upper bound of halo region - ,totalLWidth =(/IHALO,JHALO/) & !<-- Lower bound of halo region - ,ungriddedLBound=(/lbound(VARS(N)%R3D,dim=3)/) & - ,ungriddedUBound=(/ubound(VARS(N)%R3D,dim=3)/) & - ,name =FIELD_NAME & !<-- The name of this variable - ,indexFlag =ESMF_INDEX_GLOBAL & !<-- The variable uses global indexing - ,rc =RC) -! - NUM_LEVELS_3D_H=(UBOUND(VARS(N)%R3D,3)-LBOUND(VARS(N)%R3D,3)+1) & - +NUM_LEVELS_3D_H -! -!---------------- -!*** All Others -!---------------- -! - ELSE - WRITE(0,*)' SELECTED UPDATE H VARIABLE IS NOT 2-D OR 3-D.' - WRITE(0,*)' Variable name is ',VARS(N)%VBL_NAME,' for variable #',N - WRITE(0,*)' UPDATE_TYPE=',UPDATE_TYPE_CHAR - WRITE(0,*)' ABORT!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Attach the specification flag to this Field that indicates -!*** how it must be handled in the parent-child update region. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Specification Flag to Move Bundle H Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(field=FIELD_X & !<-- The Field to be added to H-pt Move Bundle - ,name ='UPDATE_TYPE' & !<-- The name of the Attribute to set - ,value=UPDATE_TYPE_INT & !<-- The Attribute to be set - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CMB) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Attach the halo exchange flag to this Field that indicates -!*** to the parent if it must perform exchanges prior to updating -!*** its moving nests. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Halo Exchange Flag to Move Bundle H Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(field=FIELD_X & !<-- The Field to be added to H-pt Move Bundle - ,name ='EXCH_NEEDED' & !<-- The name of the Attribute to set - ,value=EXCH_NEEDED & !<-- The Attribute to be set - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CMB) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Add this Field to the Move Bundle that holds all the H-point -!*** Fields that must be shifted after a nest moves. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Field to the H-pt Move Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleAdd( MOVE_BUNDLE_H & !<-- The Move Bundle for H point variables - , (/FIELD_X/) & !<-- Add this Field to the Bundle - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CMB) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - ELSEIF(UPDATE_TYPE_CHAR=='V')THEN !<-- If so, V variable is designated for moving nest updates -! -!--------------------- -!*** 2-D V Variables -!--------------------- -! -!---------- -!*** Real -!---------- -! - IF(ASSOCIATED(VARS(N)%R2D))THEN !<-- 2-D reall array on velocity points -! - NUM_VARS_2D_V=NUM_VARS_2D_V+1 -! - FIELD_X=ESMF_FieldCreate(grid =GRID_DOMAIN & !<-- The ESMF Grid for this domain - ,farray =VARS(N)%R2D & !<-- Nth variable in the VARS array - ,totalUWidth=(/IHALO,JHALO/) & !<-- Upper bound of halo region - ,totalLWidth=(/IHALO,JHALO/) & !<-- Lower bound of halo region - ,name =FIELD_NAME & !<-- The name of this variable - ,indexFlag =ESMF_INDEX_GLOBAL & !<-- The variable uses global indexing - ,rc =RC) -! -!--------------------- -!*** 3-D V Variables -!--------------------- -! -!---------- -!*** Real -!---------- -! - ELSEIF(ASSOCIATED(VARS(N)%R3D))THEN !<-- 3-D real array on velocity points -! - NUM_VARS_3D_V=NUM_VARS_3D_V+1 -! - FIELD_X=ESMF_FieldCreate(grid =GRID_DOMAIN & !<-- The ESMF Grid for this domain - ,farray =VARS(N)%R3D & !<-- Nth variable in the VARS array - ,totalUWidth =(/IHALO,JHALO/) & !<-- Upper bound of halo region - ,totalLWidth =(/IHALO,JHALO/) & !<-- Lower bound of halo region - ,ungriddedLBound=(/lbound(VARS(N)%R3D,dim=3)/) & - ,ungriddedUBound=(/ubound(VARS(N)%R3D,dim=3)/) & - ,name =FIELD_NAME & !<-- The name of this variable - ,indexFlag =ESMF_INDEX_GLOBAL & !<-- The variable uses global indexing - ,rc =RC) -! - NUM_LEVELS_3D_V=(UBOUND(VARS(N)%R3D,3)-LBOUND(VARS(N)%R3D,3)+1) & - +NUM_LEVELS_3D_V -! -! -!------------ -!*** Others -!------------ -! - ELSE - WRITE(0,*)' SELECTED UPDATE V VARIABLE IS NOT 2-D OR 3-D. ABORT!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Attach the specification flag to this Field that indicates -!*** how it must be handled in the parent-child update region. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Specification Flag to Move Bundle V Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(field=FIELD_X & !<-- The Field to be added to V-pt Move Bundle - ,name ='UPDATE_TYPE' & !<-- The name of the Attribute to set - ,value=UPDATE_TYPE_INT & !<-- The Attribute to be set - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CMB) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Attach the halo exchange flag to this Field that indicates -!*** to the parent if it must perform exchanges prior to updating -!*** its moving nests. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Specification Flag to Move Bundle V Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(field=FIELD_X & !<-- The Field to be added to V-pt Move Bundle - ,name ='EXCH_NEEDED' & !<-- The name of the Attribute to set - ,value=EXCH_NEEDED & !<-- The Attribute to be set - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CMB) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Add this Field to the Move Bundle that holds all the H-point -!*** Fields that must be shifted after a nest moves. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Field to the H-pt Move Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleAdd( MOVE_BUNDLE_V & !<-- The Move Bundle for V-point variables - , (/FIELD_X/) & !<-- Add this Field to the Bundle - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CMB) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - -! -!----------------------------------------------------------------------- -! - ENDIF build_bundle -! -!----------------------------------------------------------------------- -! - ENDDO bundle_loop -! -!----------------------------------------------------------------------- -! - CLOSE(10) -! -!----------------------------------------------------------------------- -! - END SUBROUTINE BUILD_MOVE_BUNDLE -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE BUILD_2WAY_BUNDLE(GRID_DOMAIN & - ,LM & - ,UBOUND_VARS & - ,VARS & - ,BUNDLE_2WAY & - ) -! -!----------------------------------------------------------------------- -!*** When 2-way exchange is invoked in the configure file then -!*** a child domain will interpolate specified variables from -!*** the Solver component's internal state on its grid to its -!*** parent's grid and send that data to its parent. Parents -!*** receive that data and incorporate it. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: LM & !<-- # of model layers - ,UBOUND_VARS !<-- Upper dimension of the VARS array -! - TYPE(ESMF_Grid),INTENT(IN) :: GRID_DOMAIN !<-- The ESMF Grid for this domain -! - TYPE(VAR),DIMENSION(1:UBOUND_VARS),INTENT(INOUT) :: VARS !<-- Variables in the Solver internal state -! - TYPE(ESMF_FieldBundle),INTENT(INOUT) :: BUNDLE_2WAY !<-- The Bundle of Solver internal state vbls for 2-way exchange -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: H_OR_V_INT,IOS,N,NLEV,RC,RC_CMB -! - CHARACTER(len=1) :: CH_2,CH_B,CHECK_EXCH,H_OR_V -! - CHARACTER(len=2) :: CH_M -! - CHARACTER(len=9),SAVE :: FNAME='nests.txt' -! - CHARACTER(len=99) :: FIELD_NAME,VBL_NAME -! - CHARACTER(len=256) :: STRING -! - TYPE(ESMF_Field) :: FIELD_X -! - integer(kind=kint) :: lbnd1,lbnd2,lbnd3,ubnd1,ubnd2,ubnd3,nx,ny,nz -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Loop through all Solver internal state variables. -!----------------------------------------------------------------------- -! - OPEN(unit=10,file=FNAME,status='OLD',action='READ' & !<-- Open the text file with user specifications - ,iostat=IOS) -! - IF(IOS/=0)THEN - WRITE(0,*)' Failed to open ',FNAME,' so ABORT!' - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT & - ,rc =RC) - ENDIF -! - NLEV=0 !<-- Counter for total # of levels in all 2-way vbls -! -!----------------------------------------------------------------------- - bundle_loop: DO -!----------------------------------------------------------------------- -! - READ(UNIT=10,FMT='(A)',iostat=IOS)STRING !<-- Read in the next specification line - IF(IOS/=0)EXIT !<-- Finished reading the specification lines -! - IF(STRING(1:1)=='#'.OR.TRIM(STRING)=='')THEN - CYCLE !<-- Read past comments and blanks. - ENDIF -! -!----------------------------------------------------------------------- -!*** Read the text line containing the nest specifications for -!*** variable N then find that variables' place within the VARS -!*** object. -!----------------------------------------------------------------------- -! - READ(UNIT=STRING,FMT=*,iostat=IOS)VBL_NAME & !<-- The variable's name in the text file. - ,CH_B & !<-- Not relevant here (specification for BC vbls) - ,CH_M & !<-- Not relevant here (specification for motion vbls) - ,CH_2 !<-- Specification for 2-way variables -! - CALL FIND_VAR_INDX(VBL_NAME,VARS,UBOUND_VARS,N) -! - FIELD_NAME=TRIM(VARS(N)%VBL_NAME)//SUFFIX_TWOWAY -! -!----------------------------------------------------------------------- -!*** Find the variables in the Solver internal state that will be -!*** used for 2-way exchange and add them to the 2-way Bundle. -!*** We will also specify whether the Field's variable lies on -!*** H points or V points. -! NOTE -!*** Currently ESMF will not allow the use of Attributes that are -!*** characters therefore we must translate the character codes from -!*** the txt files into something that ESMF can use. In this case -!*** we will use integers: H-->1 and V-->2 . -!----------------------------------------------------------------------- -! - H_OR_V=CH_2 !<-- H-V flag for this Field -! - IF(H_OR_V=='H')THEN - H_OR_V_INT=1 !<-- H-pt variable - ELSEIF(H_OR_V=='V')THEN - H_OR_V_INT=2 !<-- V-pt variable - ELSE - H_OR_V_INT=-999 !<-- Variable not specified for 2-way exchange. - ENDIF -! -!----------------------------------------------------------------------- -! - build_bundle: IF(H_OR_V=='H' & - .OR. & - H_OR_V=='V' & - )THEN -! -!----------------------------------------------------------------------- -! -!------------------- -!*** 2-D Variables -!------------------- -! -!------------- -!*** Integer -!------------- -! - IF(ASSOCIATED(VARS(N)%I2D))THEN !<-- 2-D integer array on mass points -! -! FIELD_X=ESMF_FieldCreate(grid =GRID_DOMAIN & !<-- The ESMF Grid for this domain -! ,farray =VARS(N)%I2D & !<-- Nth variable in the VARS array -! ,totalUWidth=(/IHALO,JHALO/) & !<-- Upper bound of halo region -! ,totalLWidth=(/IHALO,JHALO/) & !<-- Lower bound of halo region -! ,name =FIELD_NAME & !<-- The name of this variable -! ,indexFlag =ESMF_INDEX_GLOBAL & !<-- The variable uses global indexing -! ,rc =RC) -! - WRITE(0,*)' The scheme does not consider integer variables.' - WRITE(0,*)' Variable name is ',VARS(N)%VBL_NAME,' for variable #',N - WRITE(0,*)' H_OR_V_INT=',H_OR_V_INT - WRITE(0,*)' ABORT!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) -! -!---------- -!*** Real -!---------- -! - ELSEIF(ASSOCIATED(VARS(N)%R2D))THEN !<-- 2-D real array on mass points -! - FIELD_X=ESMF_FieldCreate(grid =GRID_DOMAIN & !<-- The ESMF Grid for this domain - ,farray =VARS(N)%R2D & !<-- Nth variable in the VARS array - ,totalUWidth=(/IHALO,JHALO/) & !<-- Upper bound of halo region - ,totalLWidth=(/IHALO,JHALO/) & !<-- Lower bound of halo region - ,name =FIELD_NAME & !<-- The name of this variable - ,indexFlag =ESMF_INDEX_GLOBAL & !<-- The variable uses global indexing - ,rc =RC) -! - NLEV=NLEV+1 !<-- Sum the levels for all real 2-way variables. -! -!--------------------- -!*** 3-D H Variables -!--------------------- -! -!---------- -!*** Real -!---------- -! - ELSEIF(ASSOCIATED(VARS(N)%R3D))THEN !<-- 3-D real array on mass points -! - FIELD_X=ESMF_FieldCreate(grid =GRID_DOMAIN & !<-- The ESMF Grid for this domain - ,farray =VARS(N)%R3D & !<-- Nth variable in the VARS array - ,totalUWidth =(/IHALO,JHALO/) & !<-- Upper bound of halo region - ,totalLWidth =(/IHALO,JHALO/) & !<-- Lower bound of halo region - ,ungriddedLBound=(/lbound(VARS(N)%R3D,dim=3)/) & - ,ungriddedUBound=(/ubound(VARS(N)%R3D,dim=3)/) & - ,name =FIELD_NAME & !<-- The name of this variable - ,indexFlag =ESMF_INDEX_GLOBAL & !<-- The variable uses global indexing - ,rc =RC) -! - NLEV=NLEV+LM !<-- Sum the levels for all real 2-way variables. -! -!---------------- -!*** All Others -!---------------- -! - ELSE - WRITE(0,*)' Selected update H variable is NOT 2-D OR 3-D Real.' - WRITE(0,*)' Variable name is ',VARS(N)%VBL_NAME,' for variable #',N - WRITE(0,*)' H_OR_V_INT=',H_OR_V_INT - WRITE(0,*)' ABORT!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Attach the specification flag to this Field that indicates -!*** how it must be handled in the parent-child update region. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Specification Flag to Move Bundle H Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(field=FIELD_X & !<-- The Field to be added to H-pt Move Bundle - ,name ='H_OR_V_INT' & !<-- The name of the Attribute to set - ,value=H_OR_V_INT & !<-- The Attribute to be set - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CMB) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Add this Field to the 2-way Bundle that holds pointers to all -!*** variables in the Solver internal state that are used in 2-way -!*** exchange. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Field to the H-pt Move Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleAdd( BUNDLE_2WAY & !<-- The Move Bundle for H point variables - , (/FIELD_X/) & !<-- Add this Field to the Bundle - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CMB) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - ENDIF build_bundle -! -!----------------------------------------------------------------------- -! - ENDDO bundle_loop -! -!----------------------------------------------------------------------- -!*** Attach the total number of levels in the 2-way variables, -!*** i.e., one level for each 2-D variable and LM levels for -!*** each 3-D variable. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add total # of levels for all 2-way variables" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(FIELDBUNDLE=BUNDLE_2WAY & !<-- The Bundle of 2-way variable pointers - ,name ='NLEV 2-way' & !<-- The name of the Attribute to set - ,value =NLEV & !<-- The # of 2-way Real BC variables - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CMB) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CLOSE(10) -! -!----------------------------------------------------------------------- -! - END SUBROUTINE BUILD_2WAY_BUNDLE -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE UPDATE_GRID_ARRAYS(DOMAIN_IMP_STATE & - ,SOLVER_GRID_COMP) -! -!----------------------------------------------------------------------- -!*** When a nest moves we must update the 1-D (in J) grid-dependent -!*** arrays which span the entire nest north-south dimension. -!*** In addition update the value of the nest's SW corner on its -!*** parent's grid. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_State),INTENT(INOUT) :: DOMAIN_IMP_STATE !<-- The Domain component's import state -! - TYPE(ESMF_GridComp),INTENT(INOUT) :: SOLVER_GRID_COMP !<-- The Solver Component -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: I_SW_NEW,J,J_SW_NEW -! - INTEGER(kind=KINT) :: RC,RC_FINAL -! - REAL(kind=KFPT) :: ARG1,ARG2,DY,TLAT_SW,TLON_SW -! - REAL(kind=KFPT),DIMENSION(JDS:JDE) :: TLAT_H,TLAT_V -! - TYPE(WRAP_SOLVER_INT_STATE) :: WRAP_SOLVER -! - TYPE(SOLVER_INTERNAL_STATE),POINTER :: SOLVER_INT_STATE -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Extract this domain's ID and the shifts in I and J that the -!*** nest is executing. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Domain ID from the Domain Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=DOMAIN_IMP_STATE & !<-- The Domain import state - ,name ='DOMAIN_ID' & !<-- Get Attribute with this name - ,value=MY_DOMAIN_ID & !<-- This domain's ID - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get I_SHIFT and J_SHIFT from Domain Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=DOMAIN_IMP_STATE & !<-- The Domain import state - ,name ='I_SHIFT' & !<-- Get Attribute with this name - ,value=I_SHIFT_CHILD & !<-- Motion of the nest in I on its grid - ,rc =RC ) -! - CALL ESMF_AttributeGet(state=DOMAIN_IMP_STATE & !<-- The Domain import state - ,name ='J_SHIFT' & !<-- Get Attribute with this name - ,value=J_SHIFT_CHILD & !<-- Motion of the nest in J on its grid - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Extract the Solver internal state so we can access its contents. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Solver Internal State for Move Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGetInternalState(SOLVER_GRID_COMP & !<-- The Solver component - ,WRAP_SOLVER & - ,RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - SOLVER_INT_STATE=>wrap_solver%INT_STATE -! -!----------------------------------------------------------------------- -!*** What are the new coordinates on the parent's grid of the nest's -!*** SW corner after the shift? -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Parent-Child Space Ratio from Configure File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The config object - ,value =PARENT_CHILD_SPACE_RATIO & !<-- The variable filled (child grid increment / parent's) - ,label ='parent_child_space_ratio:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - solver_int_state%I_PAR_STA=solver_int_state%I_PAR_STA & - +I_SHIFT_CHILD/PARENT_CHILD_SPACE_RATIO -! - solver_int_state%J_PAR_STA=solver_int_state%J_PAR_STA & - +J_SHIFT_CHILD/PARENT_CHILD_SPACE_RATIO -! -!----------------------------------------------------------------------- -!*** The arrays are tied to the nest grid's transformed latitude. -!*** After determining the transformed latitude of the subdomain's -!*** SW corner following the move the rest can be filled in. -!----------------------------------------------------------------------- -! - CALL GEO_TO_ROT(solver_int_state%GLAT_SW & !<-- The pre-move geographic lat of nest's SW corner (radians) - ,solver_int_state%GLON_SW & !<-- The pre-move geographic lon of nest's SW corner (radians) - ,TLAT_SW & !<-- The pre-move rotated lat of nest's SW corner (radians) - ,TLON_SW ) !<-- The pre-move rotated lon of nest's SW corner (radians) -! - DPH=solver_int_state%DPHD*DEG_TO_RAD - DLM=solver_int_state%DLMD*DEG_TO_RAD -! - TLAT_H(JDS)=TLAT_SW+J_SHIFT_CHILD*DPH - TLAT_V(JDS)=TLAT_H(JDS)+0.5*DPH -! - DO J=JDS+1,JDE - TLAT_H(J)=TLAT_H(JDS)+(J-JDS)*DPH - TLAT_V(J)=TLAT_V(JDS)+(J-JDS)*DPH - ENDDO -! - DY=A*DPH -! -!----------------------------------------------------------------------- -!*** Update the relevant 1-D arrays. -!----------------------------------------------------------------------- -! - DO J=JDS,JDE - solver_int_state%DXH(J)=A*DLM*COS(TLAT_H(J)) - solver_int_state%RDXH(J)=1./solver_int_state%DXH(J) - solver_int_state%DXV(J)=A*DLM*COS(TLAT_V(J)) - solver_int_state%RDXV(J)=1./solver_int_state%DXV(J) - solver_int_state%DARE(J)=solver_int_state%DXH(J)*DY - solver_int_state%RARE(J)=1./solver_int_state%DARE(J) - solver_int_state%WPDAR(J)=-1.E-5*WCOR*DY*DY & - /(DT_REAL*solver_int_state%DXH(J)*DY) - solver_int_state%CURV(J)=TAN(TLAT_V(J))/A - solver_int_state%FAH(J)=-DT_REAL/(3.*solver_int_state%DXH(J)*DY) - solver_int_state%FAD(J)=-0.25*DT_REAL/(3.*solver_int_state%DXV(J)*DY) - solver_int_state%FCP(J)=DT_REAL/(3.*solver_int_state%DXH(J)*DY*CP) - solver_int_state%FDIV(J)=2./(3.*solver_int_state%DXH(J)*DY) - solver_int_state%DDV(J)=SQRT(solver_int_state%DXV(J)**2+DY*DY) - solver_int_state%RDDV(J)=1./solver_int_state%DDV(J) - solver_int_state%DDMPU(J)=0.5*CDDAMP*DY/solver_int_state%DXV(J) - ENDDO -! -!----------------------------------------------------------------------- -!*** Compute the new geographic coordinates of the nest's SW corner -!*** after it shifts. -!----------------------------------------------------------------------- -! - TPH0=solver_int_state%TPH0D*DEG_TO_RAD - TLM0=solver_int_state%TLM0D*DEG_TO_RAD -! - TLAT_SW=TLAT_H(JDS) !<-- Transformed lat (radians) of SW corner after shift - TLON_SW=TLON_SW+I_SHIFT_CHILD*DLM !<-- Transformed lon (radians) of SW corner after shift -! - solver_int_state%GLAT_SW=ASIN(SIN(TLAT_SW)*COS(TPH0) & !<-- Geographic lat (radians) of SW corner after shift - +COS(TLAT_SW)*SIN(TPH0)*COS(TLON_SW)) -! - ARG1=(COS(TLAT_SW)*COS(TLON_SW))/(COS(solver_int_state%GLAT_SW) & - *COS(TPH0)) - ARG2=TAN(solver_int_state%GLAT_SW)*TAN(TPH0) - solver_int_state%GLON_SW=TLM0+SIGN(1.,TLON_SW)*ACOS(ARG1-ARG2) !<-- Geographic lon (radians) of SW corner after shift -! -!----------------------------------------------------------------------- -! - END SUBROUTINE UPDATE_GRID_ARRAYS -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE UPDATE_INTERIOR_FROM_NEST(IMP_STATE & - ,MOVE_BUNDLE_H & - ,NUM_FIELDS_2D_H_I & - ,NUM_FIELDS_2D_H_R & - ,NUM_FIELDS_3D_H & - ,NUM_LEVELS_3D_H & - ,MOVE_BUNDLE_V & - ,NUM_FIELDS_2D_V & - ,NUM_FIELDS_3D_V & - ,NUM_LEVELS_3D_V & - ,INPES,JNPES & - ,ITS,ITE,JTS,JTE & - ,IMS,IME,JMS,JME & - ,IDS,IDE,JDS,JDE & - ) -! -!----------------------------------------------------------------------- -!*** After the nest has moved update all nest gridpoints in that -!*** domain's interior that remain within the footprint of its -!*** pre-move location. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: NUM_FIELDS_2D_H_I & !<-- # of 2-D integer H variables to update - ,NUM_FIELDS_2D_H_R & !<-- # of 2-D real H variables to update - ,NUM_FIELDS_3D_H & !<-- # of 3-D H variables to update - ,NUM_LEVELS_3D_H & !<-- # of 2-D levels in all 3-D H update variables - ,NUM_FIELDS_2D_V & !<-- # of 3-D V variables to update - ,NUM_FIELDS_3D_V & !<-- # of 3-D V variables to update - ,NUM_LEVELS_3D_V !<-- # of 2-D levels in all 3-D V update variables -! - INTEGER(kind=KINT),INTENT(IN) :: INPES,JNPES !<-- # of tasks west-east,north-south on this domain -! - INTEGER(kind=KINT),INTENT(IN) :: ITS,ITE,JTS,JTE & !<-- This domain's integration, - ,IMS,IME,JMS,JME & ! memory, - ,IDS,IDE,JDS,JDE !<-- and domain limits. -! - TYPE(ESMF_State),INTENT(INOUT) :: IMP_STATE !<-- The Domain import state -! - TYPE(ESMF_FieldBundle),INTENT(INOUT) :: MOVE_BUNDLE_H & !<-- Bundle of internal state H arrays needing updates - ,MOVE_BUNDLE_V !<-- Bundle of internal state V arrays needing updates -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: I,I_DIFF_MAX,I_END,I_START & - ,J,J_DIFF_MAX,J_END,J_START & - ,L,N -! - INTEGER(kind=KINT) :: RC,RC_UPD -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RC_UPD=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** Extract the shifts in I and J that the nest is executing. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get I_SHIFT and J_SHIFT from Domain Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Domain import state - ,name ='I_SHIFT' & !<-- Get Attribute with this name - ,value=I_SHIFT_CHILD & !<-- Motion of the nest in I on its grid - ,rc =RC ) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Domain import state - ,name ='J_SHIFT' & !<-- Get Attribute with this name - ,value=J_SHIFT_CHILD & !<-- Motion of the nest in J on its grid - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_UPD) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** After a nested domain changes its position there are two ways -!*** in which its internal gridpoints can be updated that do not -!*** involve the parent. The points updated are those that remain -!*** within the footprint of the domain's previous position. The -!*** two types of updates are: -! -!*** (a) The new value of each variable will come from a different -!*** location on the same nest task's subdomain (intra-task). -!*** (b) The new values will be received from a different nest -!*** task (inter-task). -! -!*** These actions cannot be done in a simple sequence because if -!*** they were then data would be lost that was needed for either -!*** the intra- or inter-task shift. Therefore they are done in -!*** the following order: -! -!*** (1) The data is first gathered into ISend buffers for the -!*** inter-task shift and then sent. -!*** (2) The intra-task update is done. -!*** (3) The inter-task data is Recvd and applied. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Gather data into buffers for the inter-task shift within the -!*** nest domain and send it. -!----------------------------------------------------------------------- -! - CALL SEND_INTER_TASK_DATA(I_SHIFT_CHILD & - ,J_SHIFT_CHILD & - ,MYPE & - ,INPES & - ,JNPES & - ,MOVE_BUNDLE_H & - ,NUM_FIELDS_2D_H_I & - ,NUM_FIELDS_2D_H_R & - ,NUM_FIELDS_3D_H & - ,NUM_LEVELS_3D_H & - ,MOVE_BUNDLE_V & - ,NUM_FIELDS_2D_V & - ,NUM_FIELDS_3D_V & - ,NUM_LEVELS_3D_V & - ,ITS,ITE,JTS,JTE & - ,IMS,IME,JMS,JME & - ,IDS,IDE,JDS,JDE & - ) -! -!----------------------------------------------------------------------- -!*** Carry out the shift on all points that remains on the same task -!*** after the domain moves. -!----------------------------------------------------------------------- -! - CALL SHIFT_INTRA_TASK_DATA(I_SHIFT_CHILD & - ,J_SHIFT_CHILD & - ,MOVE_BUNDLE_H & - ,NUM_FIELDS_2D_H_I & - ,NUM_FIELDS_2D_H_R & - ,NUM_FIELDS_3D_H & - ,MOVE_BUNDLE_V & - ,NUM_FIELDS_2D_V & - ,NUM_FIELDS_3D_V & - ,ITS,ITE,JTS,JTE & - ,IMS,IME,JMS,JME & - ,IDS,IDE,JDS,JDE & - ) -! -!----------------------------------------------------------------------- -!*** Receive data for the inter-task shift within the nest domain -!*** and apply it. -!----------------------------------------------------------------------- -! - CALL RECV_INTER_TASK_DATA(I_SHIFT_CHILD & - ,J_SHIFT_CHILD & - ,MYPE & - ,INPES & - ,JNPES & - ,MOVE_BUNDLE_H & - ,NUM_FIELDS_2D_H_I & - ,NUM_FIELDS_2D_H_R & - ,NUM_FIELDS_3D_H & - ,NUM_LEVELS_3D_H & - ,MOVE_BUNDLE_V & - ,NUM_FIELDS_2D_V & - ,NUM_FIELDS_3D_V & - ,NUM_LEVELS_3D_V & - ,ITS,ITE,JTS,JTE & - ,IMS,IME,JMS,JME & - ,IDS,IDE,JDS,JDE & - ) -! -!----------------------------------------------------------------------- -! - END SUBROUTINE UPDATE_INTERIOR_FROM_NEST -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE SHIFT_INTRA_TASK_DATA(I_SHIFT_CHILD & - ,J_SHIFT_CHILD & - ,MOVE_BUNDLE_H & - ,NUM_FIELDS_2D_H_I & - ,NUM_FIELDS_2D_H_R & - ,NUM_FIELDS_3D_H & - ,MOVE_BUNDLE_V & - ,NUM_FIELDS_2D_V & - ,NUM_FIELDS_3D_V & - ,ITS,ITE,JTS,JTE & - ,IMS,IME,JMS,JME & - ,IDS,IDE,JDS,JDE & - ) -! -!----------------------------------------------------------------------- -!*** After the nest has moved update all nest gridpoints in the -!*** domain's interior whose new locations still lie within the -!*** same MPI task subdomain (same processor memory) as before -!*** the move. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: I_SHIFT_CHILD & !<-- Nest domain moved this far in I in nest space - ,J_SHIFT_CHILD & !<-- Nest domain moved this far in J in nest space - ,NUM_FIELDS_2D_H_I & !<-- # of 2-D integer H variables to update - ,NUM_FIELDS_2D_H_R & !<-- # of 2-D real H variables to update - ,NUM_FIELDS_3D_H & !<-- # of 3-D H variables to update - ,NUM_FIELDS_2D_V & !<-- # of 2-D V variables to update - ,NUM_FIELDS_3D_V & !<-- # of 3-D V variables to update -! - ,ITS,ITE,JTS,JTE & !<-- Subdomain integration limits of this nest task - ,IMS,IME,JMS,JME & !<-- Subdomain memory limits of this nest task - ,IDS,IDE,JDS,JDE !<-- Index limits of this nest's full domain -! - TYPE(ESMF_FieldBundle),INTENT(INOUT) :: MOVE_BUNDLE_H & !<-- Bundle of internal state H arrays for updates - ,MOVE_BUNDLE_V !<-- Bundle of internal state V arrays for updates -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: I,I_DIFF_MAX,I_END,I_INC & - ,I_START,ITE_X,ITS_X & - ,J,J_DIFF_MAX,J_END,J_INC & - ,J_START,JTE_X,JTS_X & - ,L,N,N_FIELD,N_REMOVE,NF1,NF2 & - ,NUM_DIMS,NUM_FIELDS -! - INTEGER(kind=KINT) :: RC -! - INTEGER(kind=KINT),DIMENSION(1:3) :: LIMITS_HI & - ,LIMITS_LO -! - INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: IARRAY_2D -! - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ARRAY_2D -! - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: ARRAY_3D -! - CHARACTER(len=99) :: FIELD_NAME -! - TYPE(ESMF_Field) :: HOLD_FIELD -! - TYPE(ESMF_TypeKind_Flag) :: DATATYPE -! - integer(kind=kint),save :: kount_moves=0 -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** It is critical to realize that neither H-pt nor V-pt variables -!*** on the nest domain's north and east limits can be used in -!*** the intra/intertask updates. That is because the V-pt variables -!*** at IDE and JDE are not part of the integration. Although the -!*** H-pt variables at the domain's IDE and JDE are part of the -!*** integration if a task is on the nest domain's east or -!*** north boundary we must exclude them in the Send too otherwise -!*** there would be occasions when index limits for shift updates -!*** of H-pt data would not be identical to the index limits for -!*** shift updates of V-pt data and we must avoid that situation -!*** since it would greatly complicate the already very complicated -!*** bookkeeping. This fact must also be accounted for in the inter- -!*** task shifts and in the sending/recving of parent update data -!*** after the nest moves. At the same time there are a variety of -!*** variables that do not have valid integration values on the nest -!*** domain boundary so we do not want to shift those into the -!*** interior via intra- or inter-task shifts. Therefore the updates -!*** of the nest's south and west boundary points must also be done -!*** by the parent. Moreover the dynamical tendencies of temperature -!*** and the wind components are not computed in the 2nd row in from -!*** the domain boundary which means nest points shifted to those -!*** pre-move locations cannot use intra- or inter-task updates. -!*** Therefore those locations must also be updated by the parent. -!*** In general the gridpoint locations on the outer two rows of the -!*** nest's pre-move footprint will be updated by the parent although -!*** the actual depth into the footprint that the parent will provide -!*** data will be specified by configure variables for generality. -!*** Use the following quantities in searches for points involved -!*** in the intra-task update. -!----------------------------------------------------------------------- -! - ITS_X=MAX(ITS,IDS+NROWS_P_UPD_W) !<-- These quantities indicate the - ITE_X=MIN(ITE,IDE-NROWS_P_UPD_E) ! outermost locations in the nest - JTS_X=MAX(JTS,JDS+NROWS_P_UPD_S) ! domain subject to the intra-task - JTE_X=MIN(JTE,JDE-NROWS_P_UPD_N) !<-- updates. -! -!----------------------------------------------------------------------- -!*** What is the maximum shift in I and J that can occur for which -!*** there will be points that require an intra-task shift? -!----------------------------------------------------------------------- -! - I_DIFF_MAX=ITE_X-ITS_X+IHALO !<-- Maximum I shift for intra-task update - J_DIFF_MAX=JTE_X-JTS_X+JHALO !<-- Maximum J shift for intra-task update -! -!----------------------------------------------------------------------- -! - IF(ABS(I_SHIFT_CHILD)>I_DIFF_MAX & !<-- If true, gridpoints cannot be updated from - .OR. & ! the same child task following a move. - ABS(J_SHIFT_CHILD)>J_DIFF_MAX)THEN !<-- -! - RETURN !<-- Therefore exit. -! - ENDIF -! - kount_moves=kount_moves+1 -!----------------------------------------------------------------------- -!*** Update those interior nest gridpoints that receive their new -!*** values from within their tasks' subdomain (memory). Update -!*** points include the task subdomain haloes but source points -!*** do not. -!----------------------------------------------------------------------- -!*** NOTE: -!*** If J_SHIFT_CHILD > 0 then we can shift data within each nest task -!*** in the normal sense for J, i.e., from smaller to larger. -!*** However if J_SHIFT_CHILD < 0 then we must shift data going from -!*** larger to smaller J or else we would cover up original data that -!*** needed to be shifted later in the loop. If J_SHIFT_CHILD = 0 -!*** then this same notion is needed for I, i.e., we must loop from -!*** larger to smaller I for a westward shift. -! -!*** First establish some default values then refine them for specific -!*** directions of nest motion. -!----------------------------------------------------------------------- -! - I_START=MAX(IMS,IDS) - I_END =MIN(IME,IDE) - I_INC =1 -! - J_START=MAX(JMS,JDS) - J_END =MIN(JME,JDE) - J_INC =1 -! -!------------------------------------- -!*** Motion has southward component. -!------------------------------------- -! - IF(J_SHIFT_CHILD<0 )THEN - J_START=MIN(J_END,JTE_X-J_SHIFT_CHILD) !<-- Starting J (after move) for updates on same task - J_END =JTS_X-J_SHIFT_CHILD !<-- Ending J (after move) for updates on same task - J_INC =-1 !<-- J loop increment - IF(I_SHIFT_CHILD==0)THEN - I_START=MAX(IMS,IDS+NROWS_P_UPD_W) !<-- See introductory note above. - I_END =MIN(IME,IDE-NROWS_P_UPD_E) !<-- See introductory note above. - ENDIF - ENDIF -! -!------------------------------------- -!*** Motion has northward component. -!------------------------------------- -! - IF(J_SHIFT_CHILD>0)THEN - J_START=MAX(J_START,JTS_X-J_SHIFT_CHILD) !<-- Starting J (after move) for updates on same task - J_END =JTE_X-J_SHIFT_CHILD !<-- Ending J (after move) for updates on same task - IF(I_SHIFT_CHILD==0)THEN - I_START=MAX(IMS,IDS+NROWS_P_UPD_W) !<-- See introductory note above. - I_END =MIN(IME,IDE-NROWS_P_UPD_E) !<-- See introductory note above. - ENDIF - ENDIF -! -!------------------------------------ -!*** Motion has westward component. -!------------------------------------ -! - IF(I_SHIFT_CHILD<0)THEN - IF(J_SHIFT_CHILD/=0)THEN !<-- There is a north or south component of motion - I_START=ITS_X-I_SHIFT_CHILD !<-- Starting I (after move) for updates on same task - I_END =MIN(I_END,ITE_X-I_SHIFT_CHILD) !<-- Ending I (after move) for updates on same task -! - ELSE !<-- Motion is due west - I_START=MIN(I_END,ITE_X-I_SHIFT_CHILD) !<-- Starting I (after move) for updates on same task - I_END =ITS_X-I_SHIFT_CHILD !<-- Ending I (after move) for updates on same task - I_INC =-1 !<-- I loop increment - J_START=MAX(JMS,JDS+NROWS_P_UPD_S) !<-- See introductory note above. - J_END =MIN(JME,JDE-NROWS_P_UPD_N) !<-- See introductory note above. - ENDIF - ENDIF -! -!------------------------------------ -!*** Motion has eastward component. -!------------------------------------ -! - IF(I_SHIFT_CHILD>0)THEN - I_START=MAX(I_START,ITS_X-I_SHIFT_CHILD) !<-- Starting I (after move) for updates on same task - I_END =ITE_X-I_SHIFT_CHILD !<-- Ending I (after move) for updates on same task - IF(J_SHIFT_CHILD==0)THEN - J_START=MAX(JMS,JDS+NROWS_P_UPD_S) !<-- See introductory note above. - J_END =MIN(JME,JDE-NROWS_P_UPD_N) !<-- See introductory note above. - ENDIF - ENDIF -! -!----------------------------------------------------------------------- -!*** Shift the internal points that stay within the same MPI task. -!*** Loop through all pertinent 2-D and 3-D internal state variables -!*** on the moving domain. -!----------------------------------------------------------------------- -! -!-------------- -!*** H points -!-------------- -! - NUM_FIELDS=NUM_FIELDS_2D_H_I+NUM_FIELDS_2D_H_R+NUM_FIELDS_3D_H -! - DO N_FIELD=1,NUM_FIELDS -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=MOVE_BUNDLE_H & !<-- Bundle holding the arrays for move updates - ,fieldIndex =N_FIELD & !<-- Index of the Field in the Bundle - ,field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,rc =RC ) -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,dimCount=NUM_DIMS & !<-- Is this Field 2-D or 3-D? - ,typeKind=DATATYPE & !<-- Does this Field contain an integer or real array? - ,name =FIELD_NAME & !<-- The name of the Field - ,rc =RC ) -! - N_REMOVE=INDEX(FIELD_NAME,SUFFIX_MOVE) - FIELD_NAME=FIELD_NAME(1:N_REMOVE-1) -! -!----------------------------------------------------------------------- - IF(NUM_DIMS==2)THEN -!----------------------------------------------------------------------- -! - IF(DATATYPE==ESMF_TYPEKIND_R4)THEN !<-- The Real 2-D H-point arrays -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,localDe =0 & - ,farrayPtr=ARRAY_2D & !<-- Dummy 2-D real array with Field's data - ,rc =RC ) -! - DO J=J_START,J_END,J_INC - DO I=I_START,I_END,I_INC - ARRAY_2D(I,J)=ARRAY_2D(I+I_SHIFT_CHILD,J+J_SHIFT_CHILD) - ENDDO - ENDDO -! - ELSEIF(DATATYPE==ESMF_TYPEKIND_I4)THEN !<-- The Integer 2-D H-point arrays -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,localDe =0 & - ,farrayPtr=IARRAY_2D & !<-- Dummy 2-D integer array with Field's data - ,rc =RC ) -! - DO J=J_START,J_END,J_INC - DO I=I_START,I_END,I_INC - IARRAY_2D(I,J)=IARRAY_2D(I+I_SHIFT_CHILD,J+J_SHIFT_CHILD) - ENDDO - ENDDO -! - ENDIF -! -!----------------------------------------------------------------------- - ELSEIF(NUM_DIMS==3)THEN !<-- The (Real) 3-D H-point arrays -!----------------------------------------------------------------------- -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N in the Bundle - ,localDe =0 & - ,farrayPtr =ARRAY_3D & !<-- Dummy 3-D array with Field's data - ,totalLBound=LIMITS_LO & !<-- Starting index in each dimension - ,totalUBound=LIMITS_HI & !<-- Ending index in each dimension - ,rc =RC ) -! - DO N=LIMITS_LO(3),LIMITS_HI(3) - DO J=J_START,J_END,J_INC - DO I=I_START,I_END,I_INC - ARRAY_3D(I,J,N)=ARRAY_3D(I+I_SHIFT_CHILD,J+J_SHIFT_CHILD,N) - ENDDO - ENDDO - ENDDO -! - ENDIF -! - ENDDO -! -! -!-------------- -!*** V points -!-------------- -! - NUM_FIELDS=NUM_FIELDS_2D_V+NUM_FIELDS_3D_V -! - DO N_FIELD=1,NUM_FIELDS -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=MOVE_BUNDLE_V & !<-- Bundle holding the arrays for move updates - ,fieldIndex =N_FIELD & !<-- Index of the Field in the Bundle - ,field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,rc =RC ) -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,dimCount=NUM_DIMS & !<-- Is this Field 2-D or 3-D? - ,name =FIELD_NAME & !<-- The name of the Field - ,rc =RC ) -! - N_REMOVE=INDEX(FIELD_NAME,SUFFIX_MOVE) - FIELD_NAME=FIELD_NAME(1:N_REMOVE-1) -! -!----------------------------------------------------------------------- - IF(NUM_DIMS==2)THEN -!----------------------------------------------------------------------- -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,localDe =0 & - ,farrayPtr=ARRAY_2D & !<-- Dummy 2-D array with Field's data - ,rc =RC ) -! - DO J=J_START,J_END,J_INC - DO I=I_START,I_END,I_INC - ARRAY_2D(I,J)=ARRAY_2D(I+I_SHIFT_CHILD,J+J_SHIFT_CHILD) - ENDDO - ENDDO -! -!----------------------------------------------------------------------- - ELSEIF(NUM_DIMS==3)THEN !<-- The (Real) 3-D V-point arrays -!----------------------------------------------------------------------- -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N in the Bundle - ,localDe =0 & - ,farrayPtr =ARRAY_3D & !<-- Dummy 3-D array with Field's data - ,totalLBound=LIMITS_LO & !<-- Starting index in each dimension - ,totalUBound=LIMITS_HI & !<-- Ending index in each dimension - ,rc =RC ) -! - DO N=LIMITS_LO(3),LIMITS_HI(3) - DO J=J_START,J_END,J_INC - DO I=I_START,I_END,I_INC - ARRAY_3D(I,J,N)=ARRAY_3D(I+I_SHIFT_CHILD,J+J_SHIFT_CHILD,N) - ENDDO - ENDDO - ENDDO -! - ENDIF -! - ENDDO -! -!----------------------------------------------------------------------- -! - END SUBROUTINE SHIFT_INTRA_TASK_DATA -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE SEND_INTER_TASK_DATA(I_SHIFT & - ,J_SHIFT & - ,MYPE & - ,INPES & - ,JNPES & - ,MOVE_BUNDLE_H & - ,NUM_FIELDS_2D_H_I & - ,NUM_FIELDS_2D_H_R & - ,NUM_FIELDS_3D_H & - ,NUM_LEVELS_3D_H & - ,MOVE_BUNDLE_V & - ,NUM_FIELDS_2D_V & - ,NUM_FIELDS_3D_V & - ,NUM_LEVELS_3D_V & - ,ITS,ITE,JTS,JTE & - ,IMS,IME,JMS,JME & - ,IDS,IDE,JDS,JDE & - ) -! -!----------------------------------------------------------------------- -!*** After a nest has moved, update those of its interior points -!*** that still lie inside the footprint of the nest domain prior -!*** to the move but which now lie at an earth location previously -!*** occupied by a point in a different one of the nest's tasks. -!*** In this subroutine each of those nest tasks with subdomains -!*** following a move that overlap the location of the nest domain -!*** preceding the move send data to other nest tasks whose -!*** subdomains now overlap its pre-move location. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: I_SHIFT & !<-- Nest moved this far in I on its grid. - ,INPES & !<-- # of fcst tasks in I on child grid - ,J_SHIFT & !<-- Nest moved this far in J on its grid. - ,JNPES & !<-- # of fcst tasks in J on child grid - ,MYPE & !<-- This task's local rank - ,NUM_FIELDS_2D_H_I & !<-- # of 2-D integer H variables to update - ,NUM_FIELDS_2D_H_R & !<-- # of 2-D real H variables to update - ,NUM_FIELDS_3D_H & !<-- # of 3-D H variables to update - ,NUM_LEVELS_3D_H & !<-- # of 2-D levels in all 3-D H update variables - ,NUM_FIELDS_2D_V & !<-- # of 2-D V variables to update - ,NUM_FIELDS_3D_V & !<-- # of 3-D V variables to update - ,NUM_LEVELS_3D_V & !<-- # of 2-D levels in all 3-D V update variables -! - ,ITS,ITE,JTS,JTE & !<-- Subdomain integration limits of this nest task - ,IMS,IME,JMS,JME & !<-- Subdomain memory limits of this nest task - ,IDS,IDE,JDS,JDE !<-- Index limits of this nest's full domain -! - TYPE(ESMF_FieldBundle),INTENT(INOUT) :: MOVE_BUNDLE_H & !<-- Bundle of internal state H arrays for updates - ,MOVE_BUNDLE_V !<-- Bundle of internal state V arrays for updates -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: I,I_END,I_ID_END_SEARCH,I_ID_INC_SEARCH & - ,I_ID_STA_SEARCH & - ,I_INC,I_START,I_TASK & - ,I_TASK_EAST,I_TASK_WEST & - ,I1,I2 & - ,ISEND_END,ISEND_START,ITE_X,ITS_X & - ,J,J_END,J_ID_END_SEARCH,J_ID_INC_SEARCH & - ,J_ID_STA_SEARCH & - ,J_INC,J_START,J_TASK & - ,J_TASK_NORTH,J_TASK_SOUTH & - ,J1,J2 & - ,JSEND_END,JSEND_START,JTE_X,JTS_X & - ,KOUNT,KOUNT_INTEGER,KOUNT_REAL & - ,L,N,N_FIELD,N_REMOVE,NF1,NF2 & - ,NUM_DIMS,NUM_FIELDS & - ,NUM_WORDS_IJ & - ,NUM_WORDS_INTEGER,NUM_WORDS_REAL -! - INTEGER(kind=KINT) :: IDS_BND,IDE_BND,JDS_BND,JDE_BND -! - INTEGER(kind=KINT) :: IERR,ISTAT,RC -! - INTEGER(kind=KINT),DIMENSION(1:3) :: LIMITS_LO & - ,LIMITS_HI -! - INTEGER(kind=KINT),DIMENSION(1:9) :: ID_RECV -! - INTEGER(kind=KINT),DIMENSION(MPI_STATUS_SIZE) :: JSTAT -! - INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: IARRAY_2D -! - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ARRAY_2D -! - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: ARRAY_3D -! - CHARACTER(len=99) :: FIELD_NAME -! - TYPE(ESMF_Field) :: HOLD_FIELD -! - TYPE(ESMF_TypeKind_Flag) :: DATATYPE -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** If the footprint of a nest task prior to a move has no points -!*** in common with the nest domain following the move then that task -!*** will have no data to send to other nest tasks and thus this -!*** routine is not relevant. Remember that sending tasks will send -!*** to the outer 2 rows of recving tasks that lie on the domain -!*** boundary. Those outer two rows cannot provide update data -!*** following a shift but they do receive update data. -!----------------------------------------------------------------------- -! - IF(ITE<=IDS-1+I_SHIFT & !<-- Task footprint lies west of domain after east shift. - .OR. & - ITS>=IDE+1+I_SHIFT & !<-- Task footprint lies east of domain after west shift. - .OR. & - JTE<=JDS-1+J_SHIFT & !<-- Task footprint lies south of domain after north shift. - .OR. & - JTS>=JDE+1+J_SHIFT )THEN !<-- Task footprint lies north of domain after south shift. -! - RETURN !<-- Therefore exit. -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Update those interior nest gridpoints that receive their new -!*** values from a different task within the nest domain. All nest -!*** tasks must determine which of their points' data must be sent to -!*** which other nest tasks. Under normal circumstances the number -!*** of grid increments the nest shifts on its grid will not exceed -!*** a forecast task's dimensions. If that is the case and if the -!*** nest motion has both I and J components then each task except -!*** those on the trailing edge will send to three nest tasks. All -!*** trailing edge tasks except the trailing corner will send to one -!*** task; the corner will send to none. If the motion has only an -!*** I or only a J component then each non-trailing edge task will -!*** send to just one task and all trailing edge tasks will send to -!*** none. -! -!*** However in the general sense if the distance of the nest's -!*** motion exceeds the dimensions of any of its forecast tasks -!*** and the halo points of the receivers are included in those -!*** points to be updated (to avoid doing repeated halo exchanges -!*** after the move) then there are nine tasks that can potentially -!*** receive data from a given task who is sending. If the location -!*** of the footprint of the sending task's pre-move position is -!*** represented by 'X' then the nine tasks are: -! -! -! 7 8 9 -! -! -! 4 5 6 -! X -! -! 1 2 3 -! -! -!*** After the move note that we include as target points the -!*** receiving tasks' halo points that lie within the sending task's -!*** integration domain before the move. We account for the -!*** possibility that the width of the halo is greater than the -!*** magnitude of the shift. -! -!*********************************************************************** -!************************** NOTE *********************************** -!*********************************************************************** -! -!*** HOWEVER it is critical to realize that neither H-pt nor V-pt -!*** variables at the north and east domain limits can be used -!*** in the send. That is because the V-pt variables at -!*** IDE and JDE are not part of the integration. Although the -!*** H-pt variables at the domain's IDE and JDE are part of the -!*** integration if the sender is on the nest domain's east or -!*** north boundary we must exclude them in the send too otherwise -!*** there would be occasions when the receiving tasks for the -!*** sender's H-pt data would not be identical to the receiving -!*** tasks for the sender's V-pt data and we must avoid that -!*** situation since it would greatly complicate the already very -!*** complicated bookkeeping. This fact must also be accounted for -!*** in the intra-task shifts and in the sending/recving of parent -!*** update data after the nest moves. At the same time there are -!*** a variety of variables that do not have valid integration values -!*** on the domain boundary so we do not want to let the inter-task -!*** shift process move those points into the interior. Moreover -!*** the dynamical tendencies of temperature and the wind components -!*** are not defined on the 2nd row of the domain from the boundary -!*** so nest points that shift onto those locations cannot use the -!*** the intra- or inter-task updating. Therefore the parent will -!*** update the outer two boundary rows of the pre-move footprint -!*** location in general. For flexibility the code will use -!*** variables from the configure file to specify the depth into -!*** the footprint that the parent will supply update data. -!*** Use the following quantities to search for points that will -!*** be updated via the inter-task sends/recvs. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** The 'sender' is the current task that is executing this routine. -!*** The range of points within its subdomain that are valid for -!*** sending to other tasks are the following: -!----------------------------------------------------------------------- -! - IDS_BND=IDS+NROWS_P_UPD_W - IDE_BND=IDE-NROWS_P_UPD_E - JDS_BND=JDS+NROWS_P_UPD_S - JDE_BND=JDE-NROWS_P_UPD_N -! - ITS_X=MAX(ITS,IDS_BND) - ITE_X=MIN(ITE,IDE_BND) - JTS_X=MAX(JTS,JDS_BND) - JTE_X=MIN(JTE,JDE_BND) -! -!----------------------------------------------------------------------- -!*** Initialize to nonsense the ranks of tasks who will receive. -!*** There can be no more than nine. -!----------------------------------------------------------------------- -! - DO N=1,9 - ID_RECV(N)=-1 - ENDDO -! -!----------------------------------------------------------------------- -!*** Search for the tasks on this nest domain that will receive -!*** intertask update data from this current task. First look -!*** west/east then north/south. -! -!*** NOTE: The outer two rows of points on the nest grid DO RECEIVE -!*** intra- and inter-task updates after the nest moves. Those -!*** two rows of points DO NOT PROVIDE intra- and inter-task -!*** update data. -!----------------------------------------------------------------------- -! - I_TASK_EAST=(MYPE/INPES+1)*INPES-1 !<-- Task on east end of sender's row. - I_TASK_WEST=(MYPE/INPES)*INPES !<-- Task on west end of sender's row. -! - I_INC=SIGN(1,I_SHIFT) !<-- +1 for eastward motion; -1 for westward motion - J_INC=SIGN(1,J_SHIFT) !<-- +1 for northward motion; -1 for southward motion -! - IF(I_SHIFT>0)THEN !<-- For eastward move, search to the west. - I_ID_STA_SEARCH=MYPE !<-- Begin search with sender's column - I_ID_END_SEARCH=I_TASK_WEST !<-- Task on west end of sender's row. - I_ID_INC_SEARCH=-I_INC !<-- Task rank search increment in I (westward). -! - ELSEIF(I_SHIFT<0)THEN !<-- For westward move, search to the east. - I_ID_STA_SEARCH=MYPE !<-- Begin search with sender's column - I_ID_END_SEARCH=I_TASK_EAST !<-- Task on east end of sender's row. - I_ID_INC_SEARCH=-I_INC !<-- Task rank search increment in I (eastward). -! - ELSEIF(I_SHIFT==0)THEN !<-- No west/east motion - I_ID_STA_SEARCH=MAX(MYPE-1,I_TASK_WEST) !<-- Search inc is +1 so begin 1 task to the west - I_ID_END_SEARCH=MIN(MYPE+1,I_TASK_EAST) !<-- Search 3 columns due to halos on west/east sides - I_ID_INC_SEARCH=1 !<-- Task rank search increment - ENDIF -! - KOUNT=0 !<-- Initialize counter of tasks that receive -! intertask updates from the current sender -!----------------------------------------------------------------------- - search: DO I_TASK=I_ID_STA_SEARCH,I_ID_END_SEARCH,I_ID_INC_SEARCH -!----------------------------------------------------------------------- -! - I_START=MAX(domain_int_state%LOCAL_ISTART(I_TASK)-IHALO,IDS) & !<-- West limit of potential receiver task subdomain - +I_SHIFT - I_END =MIN(domain_int_state%LOCAL_IEND(I_TASK) +IHALO,IDE) & !<-- East limit of potential receiver task subdomain - +I_SHIFT -! - IF(I_END>=ITS_X.AND.I_START<=ITE_X)THEN !<-- If so, task I_TASK's subdomain has moved onto searcher's -! - J_TASK_NORTH=(JNPES-1)*INPES+MOD(I_TASK,INPES) !<-- Task on north end of I_TASK's column. - J_TASK_SOUTH=MOD(I_TASK,INPES) !<-- Task on south end of I_TASK's column. -! - IF(J_SHIFT>0)THEN !<-- For northward move, search to the south. - J_ID_STA_SEARCH=I_TASK !<-- Begin search in I_TASK's column - J_ID_END_SEARCH=J_TASK_SOUTH !<-- Task on south end of I_TASK's column. - J_ID_INC_SEARCH=-J_INC*INPES !<-- Task rank search increment in J (southward). -! - ELSEIF(J_SHIFT<0)THEN !<-- For southward move, search to the north. - J_ID_STA_SEARCH=I_TASK !<-- Begin search in I_TASK's column - J_ID_END_SEARCH=J_TASK_NORTH !<-- Task on north end of I_TASK's column. - J_ID_INC_SEARCH=-J_INC*INPES !<-- Task rank search increment in J (northward). -! - ELSEIF(J_SHIFT==0)THEN !<-- No south/north motion - J_ID_STA_SEARCH=MAX(I_TASK-INPES,J_TASK_SOUTH) !<-- Begin search 1 task to the south due to halos - J_ID_END_SEARCH=MIN(I_TASK+INPES,J_TASK_NORTH) !<-- Search 3 rows due to halos on north/south sides - J_ID_INC_SEARCH=INPES !<-- Task rank search increment - ENDIF -! - DO J_TASK=J_ID_STA_SEARCH,J_ID_END_SEARCH,J_ID_INC_SEARCH !<-- If so then search north/south. -! - J_START=MAX(domain_int_state%LOCAL_JSTART(J_TASK)-JHALO,JDS) & !<-- South limit of potential receiver task subdomain - +J_SHIFT - J_END =MIN(domain_int_state%LOCAL_JEND(J_TASK) +JHALO,JDE) & !<-- North limit of potential receiver task subdomain - +J_SHIFT -! - IF(J_END>=JTS_X.AND.J_START<=JTE_X)THEN !<-- If so, task J_TASK's subdomain has moved onto searcher's -! - KOUNT=KOUNT+1 - ID_RECV(KOUNT)=J_TASK !<-- Save this task ID as a definite receiver of intertask data -! - ENDIF -! - ENDDO -! - ENDIF -! -!----------------------------------------------------------------------- - ENDDO search -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Loop through the receive tasks to determine precisely which -!*** of their points need to be updated by this sender. The sender -!*** does not send to itself. It will update its own internal points -!*** in subroutine SHIFT_INTRA_TASK_DATA. -!----------------------------------------------------------------------- -! - send_loop: DO N=1,9 -! -!----------------------------------------------------------------------- -! - check: IF(ID_RECV(N)>=0.AND.ID_RECV(N)/=MYPE)THEN !<-- Select the genuine receive tasks. -! -!----------------------------------------------------------------------- -! - I1=MAX(domain_int_state%LOCAL_ISTART(ID_RECV(N))-IHALO,IDS)+I_SHIFT !<-- West side of potential receiver N relative to footprint - I2=MIN(domain_int_state%LOCAL_IEND (ID_RECV(N))+IHALO,IDE)+I_SHIFT !<-- East side of potential receiver N relative to footprint - J1=MAX(domain_int_state%LOCAL_JSTART(ID_RECV(N))-JHALO,JDS)+J_SHIFT !<-- South side of potential receiver N relative to footprint - J2=MIN(domain_int_state%LOCAL_JEND (ID_RECV(N))+JHALO,JDE)+J_SHIFT !<-- North side of potential receiver N relative to footprint -! -!----------------------------------------------------------------------- -! - sending: IF(I1<=ITE_X.AND.I2>=ITS_X & !<-- Do any points in potential receiver task ID_RECV(N) - .AND. & ! lie within the footprint of the sender's location - J1<=JTE_X.AND.J2>=JTS_X) THEN ! prior to the move? -! -!----------------------------------------------------------------------- -! - ISEND_START=MAX(I1,ITS_X) !<-- West limit of task N's overlap within sender's footprint - ISEND_END =MIN(I2,ITE_X) !<-- East limit of task N's overlap within sender's footprint - JSEND_START=MAX(J1,JTS_X) !<-- South limit of task N's overlap within sender's footprint - JSEND_END =MIN(J2,JTE_X) !<-- North limit of task N's overlap within sender's footprint - NUM_WORDS_IJ=(ISEND_END-ISEND_START+1)* & !<-- Number of points (in the horizontal) in the overlap region. - (JSEND_END-JSEND_START+1) -! -!----------------------------------------------------------------------- -!*** Make sure the buffers have been received from the previous move -!*** so we can deallocate then reallocate them for the current move. -!----------------------------------------------------------------------- -! -!------------------------------- -!*** Real intertask shift data -!------------------------------- -! - CALL MPI_WAIT(domain_int_state%HANDLE_SEND_INTER_REAL(N) & !<-- Handle for the ISend of inter-task real data on nest - ,JSTAT & !<-- MPI status - ,IERR ) -! - IF(ASSOCIATED(domain_int_state%SHIFT_DATA(N)%DATA_REAL))THEN - DEALLOCATE(domain_int_state%SHIFT_DATA(N)%DATA_REAL) - ENDIF -! - NUM_WORDS_REAL=NUM_WORDS_IJ*(NUM_FIELDS_2D_H_R & !<-- Total # of real words in receiving task N's overlap - +NUM_FIELDS_2D_V & ! region with sender task's pre-move footprint. - +NUM_LEVELS_3D_H & ! - +NUM_LEVELS_3D_V) !<-- -! - ALLOCATE(domain_int_state%SHIFT_DATA(N)%DATA_REAL(1:NUM_WORDS_REAL)) -! -!---------------------------------- -!*** Integer intertask shift data -!---------------------------------- -! - CALL MPI_WAIT(domain_int_state%HANDLE_SEND_INTER_INT(N) & !<-- Handle for the ISend of inter-task integer data on nest - ,JSTAT & !<-- MPI status - ,IERR ) -! - IF(ASSOCIATED(domain_int_state%SHIFT_DATA(N)%DATA_INTEGER))THEN - DEALLOCATE(domain_int_state%SHIFT_DATA(N)%DATA_INTEGER) - ENDIF -! - NUM_WORDS_INTEGER=NUM_WORDS_IJ*NUM_FIELDS_2D_H_I !<-- Total # of integer words in receiving task N's overlap -! - ALLOCATE(domain_int_state%SHIFT_DATA(N)%DATA_INTEGER(1:NUM_WORDS_INTEGER)) -! -!----------------------------------------------------------------------- -!*** Loop through the internal state variables lifting out the -!*** data that lies in each receiving task's overlap region in -!*** the sender's footprint. The indices below are with respect -!*** to the sender's footprint. Store the data in a 1-D array -!*** so that it can be given to MPI_ISEND for transfer to the -!*** receiver tasks. -!----------------------------------------------------------------------- -! - KOUNT_REAL=0 - KOUNT_INTEGER=0 -! -!-------------- -!*** H points -!-------------- -! - NUM_FIELDS=NUM_FIELDS_2D_H_I+NUM_FIELDS_2D_H_R+NUM_FIELDS_3D_H -! - DO N_FIELD=1,NUM_FIELDS -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=MOVE_BUNDLE_H & !<-- Bundle holding the arrays for move updates - ,fieldIndex =N_FIELD & !<-- Index of the Field in the Bundle - ,field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,rc =RC ) -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,dimCount=NUM_DIMS & !<-- Is this Field 2-D or 3-D? - ,typeKind=DATATYPE & !<-- Does the Field contain an integer or real array? - ,name =FIELD_NAME & !<-- This Field's name - ,rc =RC ) -! - N_REMOVE=INDEX(FIELD_NAME,SUFFIX_MOVE) - FIELD_NAME=FIELD_NAME(1:N_REMOVE-1) -! - IF(NUM_DIMS==2)THEN -! - IF(DATATYPE==ESMF_TYPEKIND_R4)THEN !<-- Real 2-D H-point arrays -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,localDe =0 & - ,farrayPtr=ARRAY_2D & !<-- Dummy 2-D real array with Field's data - ,rc =RC ) -! - DO J=JSEND_START,JSEND_END - DO I=ISEND_START,ISEND_END - KOUNT_REAL=KOUNT_REAL+1 - domain_int_state%SHIFT_DATA(N)%DATA_REAL(KOUNT_REAL)=ARRAY_2D(I,J) !<-- Sender collects its 2-D Real H data - ! in overlap region. - ENDDO - ENDDO -! - ELSEIF(DATATYPE==ESMF_TYPEKIND_I4)THEN !<-- Integer 2-D H-point arrays -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,localDe =0 & - ,farrayPtr=IARRAY_2D & !<-- Dummy 2-D integer array with Field's data - ,rc =RC ) -! - DO J=JSEND_START,JSEND_END - DO I=ISEND_START,ISEND_END - KOUNT_INTEGER=KOUNT_INTEGER+1 - domain_int_state%SHIFT_DATA(N)%DATA_INTEGER(KOUNT_INTEGER)=IARRAY_2D(I,J) !<-- Sender collects its 2-D Integer H data - ! in overlap region. - ENDDO - ENDDO -! - ENDIF -! - ELSEIF(NUM_DIMS==3)THEN !<-- (Real) 3-D H-point arrays -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,localDe =0 & - ,farrayPtr =ARRAY_3D & !<-- Dummy 3-D array with Field's data - ,totalLBound=LIMITS_LO & !<-- Starting index in each dimension - ,totalUBound=LIMITS_HI & !<-- Ending index in each dimension - ,rc =RC ) -! - DO L=LIMITS_LO(3),LIMITS_HI(3) - DO J=JSEND_START,JSEND_END - DO I=ISEND_START,ISEND_END - KOUNT_REAL=KOUNT_REAL+1 - domain_int_state%SHIFT_DATA(N)%DATA_REAL(KOUNT_REAL)=ARRAY_3D(I,J,L) !<-- Sender collects its 3-D (Real) H data - ! in overlap region. - ENDDO - ENDDO - ENDDO -! - ENDIF -! - ENDDO -! -! -!-------------- -!*** V points -!-------------- -! - NUM_FIELDS=NUM_FIELDS_2D_V+NUM_FIELDS_3D_V -! - DO N_FIELD=1,NUM_FIELDS -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=MOVE_BUNDLE_V & !<-- Bundle holding the arrays for move updates - ,fieldIndex =N_FIELD & !<-- Index of the Field in the Bundle - ,field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,rc =RC ) -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,dimCount=NUM_DIMS & !<-- Is this Field 2-D or 3-D? - ,name =FIELD_NAME & !<-- This Field's name - ,rc =RC ) -! - N_REMOVE=INDEX(FIELD_NAME,SUFFIX_MOVE) - FIELD_NAME=FIELD_NAME(1:N_REMOVE-1) -! - IF(NUM_DIMS==2)THEN -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,localDe =0 & - ,farrayPtr=ARRAY_2D & !<-- Dummy 2-D array with Field's data - ,rc =RC ) -! - DO J=JSEND_START,JSEND_END - DO I=ISEND_START,ISEND_END - KOUNT_REAL=KOUNT_REAL+1 - domain_int_state%SHIFT_DATA(N)%DATA_REAL(KOUNT_REAL)=ARRAY_2D(I,J) !<-- Sender collects its 2-D (Real) V data - ! in overlap region. - - ENDDO - ENDDO -! - ELSEIF(NUM_DIMS==3)THEN -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,localDe =0 & - ,farrayPtr =ARRAY_3D & !<-- Dummy 3-D array with Field's data - ,totalLBound=LIMITS_LO & !<-- Starting index in each dimension - ,totalUBound=LIMITS_HI & !<-- Ending index in each dimension - ,rc =RC ) -! - DO L=LIMITS_LO(3),LIMITS_HI(3) - DO J=JSEND_START,JSEND_END - DO I=ISEND_START,ISEND_END - KOUNT_REAL=KOUNT_REAL+1 - domain_int_state%SHIFT_DATA(N)%DATA_REAL(KOUNT_REAL)=ARRAY_3D(I,J,L) !<-- Sender collects its 3-D (Real) V data - ! in overlap region. - ENDDO - ENDDO - ENDDO -! - ENDIF -! - ENDDO -! -!----------------------------------------------------------------------- -!*** Send all the real data. -!----------------------------------------------------------------------- -! - CALL MPI_ISSEND(domain_int_state%SHIFT_DATA(N)%DATA_REAL & !<-- All inter-task shift Real data for task N - ,KOUNT_REAL & !<-- # of words in the Real data - ,MPI_REAL & !<-- The words are real - ,ID_RECV(N) & !<-- The nest task to which the sender is sending - ,KOUNT_REAL & !<-- Use the word count as the tag - ,COMM_FCST_TASKS(MY_DOMAIN_ID) & !<-- The MPI intracommunicator for this domain's fcst tasks - ,domain_int_state%HANDLE_SEND_INTER_REAL(N) & !<-- Handle for this ISend - ,IERR ) -! -!----------------------------------------------------------------------- -!*** Send all the integer data. -!----------------------------------------------------------------------- -! - CALL MPI_ISSEND(domain_int_state%SHIFT_DATA(N)%DATA_INTEGER & !<-- All inter-task shift Integer data for task N - ,KOUNT_INTEGER & !<-- # of words in the Integer data - ,MPI_INTEGER & !<-- The words are integer - ,ID_RECV(N) & !<-- The nest task to which the sender is sending - ,KOUNT_INTEGER & !<-- Use the word count as the tag - ,COMM_FCST_TASKS(MY_DOMAIN_ID) & !<-- The MPI intracommunicator for this domain's fcst tasks - ,domain_int_state%HANDLE_SEND_INTER_INT(N) & !<-- Handle for this ISend - ,IERR ) -! -!----------------------------------------------------------------------- -! - ENDIF sending -! -!----------------------------------------------------------------------- -! - ENDIF check -! -!----------------------------------------------------------------------- -! - ENDDO send_loop -! -!----------------------------------------------------------------------- -! - END SUBROUTINE SEND_INTER_TASK_DATA -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE RECV_INTER_TASK_DATA(I_SHIFT & - ,J_SHIFT & - ,MYPE & - ,INPES & - ,JNPES & - ,MOVE_BUNDLE_H & - ,NUM_FIELDS_2D_H_I & - ,NUM_FIELDS_2D_H_R & - ,NUM_FIELDS_3D_H & - ,NUM_LEVELS_3D_H & - ,MOVE_BUNDLE_V & - ,NUM_FIELDS_2D_V & - ,NUM_FIELDS_3D_V & - ,NUM_LEVELS_3D_V & - ,ITS,ITE,JTS,JTE & - ,IMS,IME,JMS,JME & - ,IDS,IDE,JDS,JDE & - ) -! -!----------------------------------------------------------------------- -!*** After a nest has moved, update those of its interior points -!*** that still lie inside the footprint of the nest domain prior -!*** to the move but which now lie at an earth location previously -!*** occupied by a point in a different one of the nest's tasks. -!*** In this subroutine those nest tasks (including their halo points) -!*** after a move that overlap the pre-move location of the integration -!*** subdomain of another nest task now receive their updata date from -!*** the other nest task. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: I_SHIFT & !<-- Nest moved this far in I on its grid. - ,J_SHIFT & !<-- Nest moved this far in J on its grid. - ,INPES & !<-- # of fcst tasks in I on child grid - ,JNPES & !<-- # of fcst tasks in J on child grid - ,MYPE & !<-- This task's local rank - ,NUM_FIELDS_2D_H_I & !<-- # of 2-D integer H variables to update - ,NUM_FIELDS_2D_H_R & !<-- # of 2-D real H variables to update - ,NUM_FIELDS_3D_H & !<-- # of 3-D internal state H variables to update - ,NUM_LEVELS_3D_H & !<-- # of 2-D levels in all 3-D H update variables - ,NUM_FIELDS_2D_V & !<-- # of 2-D internal state V variables to update - ,NUM_FIELDS_3D_V & !<-- # of 3-D internal state V variables to update - ,NUM_LEVELS_3D_V & !<-- # of 2-D levels in all 3-D V update variables -! - ,ITS,ITE,JTS,JTE & !<-- Subdomain integration limits of this nest task - ,IMS,IME,JMS,JME & !<-- Subdomain memory limits of this nest task - ,IDS,IDE,JDS,JDE !<-- Index limits of this nest's full domain -! - TYPE(ESMF_FieldBundle),INTENT(INOUT) :: MOVE_BUNDLE_H & !<-- Bundle of internal state H arrays to update - ,MOVE_BUNDLE_V !<-- Bundle of internal state V arrays to update -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: I,I_END_X,I_ID_END_SEARCH,I_ID_INC_SEARCH & - ,I_ID_STA_SEARCH & - ,I_INC,I_START,I_START_X,I_TASK & - ,I_TASK_EAST,I_TASK_WEST & - ,I1,I2 & - ,IRECV_END,IRECV_START & - ,ITS_X,ITE_X & - ,J,J_END_X,J_ID_END_SEARCH,J_ID_INC_SEARCH & - ,J_ID_STA_SEARCH & - ,J_INC,J_START,J_START_X,J_TASK & - ,J_TASK_NORTH,J_TASK_SOUTH & - ,J1,J2 & - ,JRECV_END,JRECV_START & - ,JTE_X,JTS_X & - ,KOUNT,KOUNT_INTEGER,KOUNT_REAL & - ,L,N,N_FIELD,N_REMOVE,NF1,NF2 & - ,NUM_DIMS,NUM_FIELDS & - ,NUM_WORDS_IJ & - ,NUM_WORDS_INTEGER,NUM_WORDS_REAL -! - INTEGER(kind=KINT) :: IDE_BND,IDS_BND,JDE_BND,JDS_BND -! - INTEGER(kind=KINT) :: IERR,RC -! - INTEGER(kind=KINT),DIMENSION(1:3) :: LIMITS_LO & - ,LIMITS_HI -! - INTEGER(kind=KINT),DIMENSION(1:9) :: ID_SEND -! - INTEGER(kind=KINT),DIMENSION(MPI_STATUS_SIZE) :: JSTAT -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: RECV_INTEGER_DATA -! - INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: IARRAY_2D -! - REAL(kind=KFPT),DIMENSION(:),ALLOCATABLE :: RECV_REAL_DATA -! - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ARRAY_2D -! - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: ARRAY_3D -! - CHARACTER(len=99) :: FIELD_NAME -! - TYPE(ESMF_Field) :: HOLD_FIELD -! - TYPE(ESMF_TypeKind_Flag) :: DATATYPE -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** We will essentially use the inverse of the logic used in -!*** SEND_INTER_TASK_DATA in order to find the set of nine -!*** potential sending tasks from which to receive update data -!*** in each nest task that after a move at least partially remains -!*** within the outline of the nest domain prior to the move. -!*** See the comments in that subroutine. 'Footprint' will always -!*** refer to domain/subdomain positions prior to a move. -! -!*** The following four variables are the limits on the receiving -!*** task subdomain of the points that can receive inter-task -!*** updates. Remember that while the outer two rows of a nest -!*** domain cannot provide intra- and inter-task update data -!*** the points in those two rows certainly do receive intra- and -!*** inter-task update data. -!----------------------------------------------------------------------- -! - I_START_X=MAX(IMS,IDS) - I_END_X =MIN(IME,IDE) - J_START_X=MAX(JMS,JDS) - J_END_X =MIN(JME,JDE) -! -!----------------------------------------------------------------------- -!*** If the subdomain of a nest task after a move has no points in -!*** common with the nest domain footprint prior to the move then -!*** that task will have no data to receive from other nest tasks -!*** and thus this routine is not relevant. -!----------------------------------------------------------------------- -! - IF(I_END_X+I_SHIFT<=IDS+NROWS_P_UPD_W-1 & !<-- Task subdomain lies west of footprint after west shift. - .OR. & - I_START_X+I_SHIFT>=IDE-NROWS_P_UPD_E+1 & !<-- Task subdomain lies east of footprint after east shift. - .OR. & - J_END_X+J_SHIFT<=JDS+NROWS_P_UPD_S-1 & !<-- Task subdomain lies south of footprint after south shift. - .OR. & - J_START_X+J_SHIFT>=JDE-NROWS_P_UPD_N+1 )THEN !<-- Task subdomain lies north of footprint after north shift. -! - RETURN !<-- Therefore exit. -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Initialize to nonsense the ranks of tasks who might send data. -!*** There can be no more than nine. -!----------------------------------------------------------------------- -! - DO N=1,9 - ID_SEND(N)=-1 - ENDDO -! -!----------------------------------------------------------------------- -!*** Search for the tasks that will send intertask update data to -!*** the current search task. First look west/east then north/south. -! -!*** NOTE: The search is done with respect to the grid indices on -!*** the subdomain of the receiver's position after the move. -!----------------------------------------------------------------------- -! - I_INC=SIGN(1,I_SHIFT) !<-- +1 for eastward motion; -1 for westward motion - J_INC=SIGN(1,J_SHIFT) !<-- +1 for northward motion; -1 for southward motion -! - I_TASK_EAST=(MYPE/INPES+1)*INPES-1 !<-- Task on east end of receiver's row. - I_TASK_WEST=(MYPE/INPES)*INPES !<-- Task on west end of receiver's row. -! - IF(I_SHIFT>0)THEN !<-- For eastward move, search to the east. - I_ID_STA_SEARCH=MYPE !<-- Begin search with current task's column. - I_ID_END_SEARCH=I_TASK_EAST !<-- Task on east end of receiver's row. - I_ID_INC_SEARCH=I_INC !<-- Task rank search increment in I (eastward). -! - ELSEIF(I_SHIFT<0)THEN !<-- For westward move, search to the west. - I_ID_STA_SEARCH=MYPE !<-- Begin search with current task's column. - I_ID_END_SEARCH=I_TASK_WEST !<-- Task on west end of receiver's row. - I_ID_INC_SEARCH=I_INC !<-- Task rank search increment in I (westward). -! - ELSEIF(I_SHIFT==0)THEN !<-- No west/east motion - I_ID_STA_SEARCH=MAX(MYPE-1,I_TASK_WEST) !<-- Begin search 1 task to the west due to halos - I_ID_END_SEARCH=MIN(MYPE+1,I_TASK_EAST) !<-- End search 1 task to the east due to halos - I_ID_INC_SEARCH=1 !<-- Task rank search increment - ENDIF -! - KOUNT=0 !<-- Initialize counter of tasks that will send intertask data -! - IDS_BND=IDS+NROWS_P_UPD_W - IDE_BND=IDE-NROWS_P_UPD_E - JDS_BND=JDS+NROWS_P_UPD_S - JDE_BND=JDE-NROWS_P_UPD_N -! -!----------------------------------------------------------------------- - search: DO I_TASK=I_ID_STA_SEARCH,I_ID_END_SEARCH,I_ID_INC_SEARCH -!----------------------------------------------------------------------- -! - ITS_X=MAX(domain_int_state%LOCAL_ISTART(I_TASK),IDS_BND) !<-- West limit of task I_TASK's integration region - ITE_X=MIN(domain_int_state%LOCAL_IEND(I_TASK) ,IDE_BND) !<-- East limit of task I_TASK's integration region -! - IF(I_END_X+I_SHIFT>=ITS_X.AND.I_START_X+I_SHIFT<=ITE_X)THEN !<-- If so, some of current task's subdomain moved onto I_TASK's -! - J_TASK_NORTH=(JNPES-1)*INPES+MOD(I_TASK,INPES) !<-- Task on north end of I_TASK's column. - J_TASK_SOUTH=MOD(I_TASK,INPES) !<-- Task on south end of I_TASK's column. -! - IF(J_SHIFT>0)THEN !<-- For northward move, search to the north. - J_ID_STA_SEARCH=I_TASK !<-- Begin search with I_TASK - J_ID_END_SEARCH=J_TASK_NORTH !<-- Task on north end of I_TASK's column. - J_ID_INC_SEARCH=J_INC*INPES !<-- Task rank search increment in J (northward). -! - ELSEIF(J_SHIFT<0)THEN !<-- For southward move, search to the south. - J_ID_STA_SEARCH=I_TASK !<-- Begin search with I_TASK - J_ID_END_SEARCH=J_TASK_SOUTH !<-- Task on south end of I_TASK's column. - J_ID_INC_SEARCH=J_INC*INPES !<-- Task rank search increment in J (southward). -! - ELSEIF(J_SHIFT==0)THEN !<-- No south/north motion - J_ID_STA_SEARCH=MAX(I_TASK-INPES,J_TASK_SOUTH) !<-- Due to halos begin 1 task to the south - J_ID_END_SEARCH=MIN(I_TASK+INPES,J_TASK_NORTH) !<-- And end search 1 task to the north - J_ID_INC_SEARCH=INPES !<-- Task rank search increment - ENDIF -! - DO J_TASK=J_ID_STA_SEARCH,J_ID_END_SEARCH,J_ID_INC_SEARCH !<-- If so then search north/south. -! - JTS_X=MAX(domain_int_state%LOCAL_JSTART(J_TASK),JDS_BND) !<-- South limit of task J_TASK integration region - JTE_X=MIN(domain_int_state%LOCAL_JEND(J_TASK) ,JDE_BND) !<-- North limit of task J_TASK integration region -! - IF(J_END_X+J_SHIFT>=JTS_X.AND.J_START_X+J_SHIFT<=JTE_X)THEN !<-- If so, current task has moved onto J_TASK's subdomain -! - KOUNT=KOUNT+1 - ID_SEND(KOUNT)=J_TASK !<-- Save this task ID as a definite sender of intertask data - ENDIF -! - ENDDO -! - ENDIF -! -!----------------------------------------------------------------------- - ENDDO search -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Loop through the nine potential send tasks to determine which -!*** of their points are needed for updating points in this receiver. -!*** The current task executing this routine will not receive from -!*** itself. It will update its own internal points in subroutine -!*** SHIFT_INTRA_TASK_DATA. -!----------------------------------------------------------------------- -! - recv_loop: DO N=1,9 -! -!----------------------------------------------------------------------- -! - check: IF(ID_SEND(N)>=0.AND.ID_SEND(N)/=MYPE)THEN !<-- Potential send task has points inside nest boundary. -! -!----------------------------------------------------------------------- -! - I1=MAX(domain_int_state%LOCAL_ISTART(ID_SEND(N)) & !<-- West side of potential sender N relative to subdomain - ,IDS+NROWS_P_UPD_W)-I_SHIFT - I2=MIN(domain_int_state%LOCAL_IEND(ID_SEND(N)) & !<-- East side of potential sender N relative to subdomain - ,IDE-NROWS_P_UPD_E)-I_SHIFT - J1=MAX(domain_int_state%LOCAL_JSTART(ID_SEND(N)) & !<-- South side of potential sender N relative to subdomain - ,JDS+NROWS_P_UPD_S)-J_SHIFT - J2=MIN(domain_int_state%LOCAL_JEND(ID_SEND(N)) & !<-- North side of potential sender N relative to subdomain - ,JDE-NROWS_P_UPD_N)-J_SHIFT -! -!----------------------------------------------------------------------- -! - recving: IF(I_START_X<=I2.AND.I_END_X>=I1 & !<-- Does any of the receiver's subdomain after the move - .AND. & ! intersect potential sender N's subdomain location - J_START_X<=J2.AND.J_END_X>=J1) THEN ! at its pre-move location? -! -!----------------------------------------------------------------------- -! - IRECV_START=MAX(I1,I_START_X) !<-- West limit of task N's overlap within receiver's subdomain - IRECV_END =MIN(I2,I_END_X) !<-- East limit of task N's overlap within receiver's subdomain - JRECV_START=MAX(J1,J_START_X) !<-- South limit of task N's overlap within receiver's subdomain - JRECV_END =MIN(J2,J_END_X) !<-- North limit of task N's overlap within receiver's subdomain -! - NUM_WORDS_IJ=(IRECV_END-IRECV_START+1)* & !<-- Number of points (in the horizontal) in the overlap region. - (JRECV_END-JRECV_START+1) - NUM_WORDS_REAL=NUM_WORDS_IJ*(NUM_FIELDS_2D_H_R & !<-- Total # of Real words in sending task N's overlap - +NUM_FIELDS_2D_V & ! with receiver task's subdomain for all update - +NUM_LEVELS_3D_H & ! variables. - +NUM_LEVELS_3D_V) !<-- -! - NUM_WORDS_INTEGER=NUM_WORDS_IJ*NUM_FIELDS_2D_H_I !<-- Total # of Integer words in sending task N's overlap -! - IF(ALLOCATED(RECV_REAL_DATA))DEALLOCATE(RECV_REAL_DATA) - ALLOCATE(RECV_REAL_DATA(1:NUM_WORDS_REAL)) !<-- Allocate the Recv buffer for Real data -! - IF(ALLOCATED(RECV_INTEGER_DATA))DEALLOCATE(RECV_INTEGER_DATA) - ALLOCATE(RECV_INTEGER_DATA(1:NUM_WORDS_INTEGER)) !<-- Allocate the Recv buffer for Integer data -! -!----------------------------------------------------------------------- -!*** Receive all Real update data from nest task N. -!----------------------------------------------------------------------- -! - CALL MPI_RECV(RECV_REAL_DATA & !<-- All Real inter-task shift data from task N - ,NUM_WORDS_REAL & !<-- # of words in the Real data - ,MPI_REAL & !<-- The words are Real - ,ID_SEND(N) & !<-- The nest task who is sending - ,NUM_WORDS_REAL & !<-- Use the word count as the tag - ,COMM_FCST_TASKS(MY_DOMAIN_ID) & !<-- The MPI intracommunicator for this domain's fcst tasks - ,JSTAT & !<-- MPI status object - ,IERR ) -! -!----------------------------------------------------------------------- -!*** Receive all Integer update data from nest task N. -!----------------------------------------------------------------------- -! - CALL MPI_RECV(RECV_INTEGER_DATA & !<-- All Integer inter-task shift data from task N - ,NUM_WORDS_INTEGER & !<-- # of Integer words in the data - ,MPI_INTEGER & !<-- The words are Integer - ,ID_SEND(N) & !<-- The nest task who is sending - ,NUM_WORDS_INTEGER & !<-- Use the word count as the tag - ,COMM_FCST_TASKS(MY_DOMAIN_ID) & !<-- The MPI intracommunicator for this domain's fcst tasks - ,JSTAT & !<-- MPI status object - ,IERR ) -! -!----------------------------------------------------------------------- -!*** Incorporate all update data. -!----------------------------------------------------------------------- -! - KOUNT_REAL=0 - KOUNT_INTEGER=0 -! -!-------------- -!*** H points -!-------------- -! - NUM_FIELDS=NUM_FIELDS_2D_H_I+NUM_FIELDS_2D_H_R & - +NUM_FIELDS_3D_H -! - DO N_FIELD=1,NUM_FIELDS -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=MOVE_BUNDLE_H & !<-- Bundle holding the H arrays for move updates - ,fieldIndex =N_FIELD & !<-- Index of the Field in the Bundle - ,field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,rc =RC ) -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,dimCount=NUM_DIMS & !<-- Is this Field 2-D or 3-D? - ,typeKind=DATATYPE & !<-- Does this Field contain an integer or real array? - ,name =FIELD_NAME & !<-- This Field's name - ,rc =RC ) -! - N_REMOVE=INDEX(FIELD_NAME,SUFFIX_MOVE) - FIELD_NAME=FIELD_NAME(1:N_REMOVE-1) -! - IF(NUM_DIMS==2)THEN -! - IF(DATATYPE==ESMF_TYPEKIND_I4)THEN -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,localDe =0 & - ,farrayPtr=IARRAY_2D & !<-- Dummy 2-D integer array with the Field's data - ,rc =RC ) -! - DO J=JRECV_START,JRECV_END - DO I=IRECV_START,IRECV_END - KOUNT_INTEGER=KOUNT_INTEGER+1 - IARRAY_2D(I,J)=RECV_INTEGER_DATA(KOUNT_INTEGER) !<-- Task updates 2-D Integer H data in overlap region - ENDDO - ENDDO -! - ELSEIF(DATATYPE==ESMF_TYPEKIND_R4)THEN -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,localDe =0 & - ,farrayPtr=ARRAY_2D & !<-- Dummy 2-D real array with the Field's data - ,rc =RC ) -! - DO J=JRECV_START,JRECV_END - DO I=IRECV_START,IRECV_END - KOUNT_REAL=KOUNT_REAL+1 - ARRAY_2D(I,J)=RECV_REAL_DATA(KOUNT_REAL) !<-- Task updates 2-D Real H data in overlap region - ENDDO - ENDDO -! - ENDIF -! - ELSEIF(NUM_DIMS==3)THEN -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,localDe =0 & - ,farrayPtr =ARRAY_3D & !<-- Dummy 3-D array with the Field's data - ,totalLBound=LIMITS_LO & !<-- Starting index in each dimension - ,totalUBound=LIMITS_HI & !<-- Ending index in each dimension - ,rc =RC ) -! - DO L=LIMITS_LO(3),LIMITS_HI(3) - DO J=JRECV_START,JRECV_END - DO I=IRECV_START,IRECV_END - KOUNT_REAL=KOUNT_REAL+1 - ARRAY_3D(I,J,L)=RECV_REAL_DATA(KOUNT_REAL) !<-- Task updates 3-D Real H data in overlap region - ENDDO - ENDDO - ENDDO -! - ENDIF -! - ENDDO -! -!-------------- -!*** V points -!-------------- -! - NUM_FIELDS=NUM_FIELDS_2D_V+NUM_FIELDS_3D_V -! - DO N_FIELD=1,NUM_FIELDS -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=MOVE_BUNDLE_V & !<-- Bundle holding the V arrays for move updates - ,fieldIndex =N_FIELD & !<-- Index of the Field in the Bundle - ,field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,rc =RC ) -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,dimCount=NUM_DIMS & !<-- Is this Field 2-D or 3-D? - ,name =FIELD_NAME & !<-- This Field's name - ,rc =RC ) -! - N_REMOVE=INDEX(FIELD_NAME,SUFFIX_MOVE) - FIELD_NAME=FIELD_NAME(1:N_REMOVE-1) -! - IF(NUM_DIMS==2)THEN -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,localDe =0 & - ,farrayPtr=ARRAY_2D & !<-- Dummy 2-D array with the Field's data - ,rc =RC ) -! - DO J=JRECV_START,JRECV_END - DO I=IRECV_START,IRECV_END - KOUNT_REAL=KOUNT_REAL+1 - ARRAY_2D(I,J)=RECV_REAL_DATA(KOUNT_REAL) !<-- Task updates (REAL) 2-D V data in overlap region - ENDDO - ENDDO -! - ELSEIF(NUM_DIMS==3)THEN -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,localDe =0 & - ,farrayPtr =ARRAY_3D & !<-- Dummy 3-D array with the Field's data - ,totalLBound=LIMITS_LO & !<-- Starting index in each dimension - ,totalUBound=LIMITS_HI & !<-- Ending index in each dimension - ,rc =RC ) -! - DO L=LIMITS_LO(3),LIMITS_HI(3) - DO J=JRECV_START,JRECV_END - DO I=IRECV_START,IRECV_END - KOUNT_REAL=KOUNT_REAL+1 - ARRAY_3D(I,J,L)=RECV_REAL_DATA(KOUNT_REAL) !<-- Task updates (Real) 3-D V data in overlap region - ENDDO - ENDDO - ENDDO -! - ENDIF -! - ENDDO -! -!----------------------------------------------------------------------- -! - ENDIF recving -! -!----------------------------------------------------------------------- -! - ENDIF check -! -!----------------------------------------------------------------------- -! - ENDDO recv_loop -! -!----------------------------------------------------------------------- -! - IF(ALLOCATED(RECV_REAL_DATA))DEALLOCATE(RECV_REAL_DATA) - IF(ALLOCATED(RECV_INTEGER_DATA))DEALLOCATE(RECV_INTEGER_DATA) -! -!----------------------------------------------------------------------- -! - END SUBROUTINE RECV_INTER_TASK_DATA -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE UPDATE_INTERIOR_FROM_PARENT(IMP_STATE & - ,SFC_FILE_RATIO & - ,MOVE_BUNDLE_H & - ,NUM_FIELDS_2D_H_I & - ,NUM_FIELDS_2D_H_R & - ,NUM_FIELDS_3D_H & - ,MOVE_BUNDLE_V & - ,NUM_FIELDS_2D_V & - ,NUM_FIELDS_3D_V & - ,GLAT_H & - ,GLON_H & - ,ITS,ITE,JTS,JTE & - ,IMS,IME,JMS,JME ) -! -!----------------------------------------------------------------------- -!*** After the nest has moved update all nest gridpoints in that -!*** domain's interior that lie outside of the footprint of its -!*** pre-move location. The update data comes from the parent. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: ITS,ITE,JTS,JTE & !<-- Integration limits - ,IMS,IME,JMS,JME !<-- Memory limits -! - INTEGER(kind=KINT),INTENT(IN) :: NUM_FIELDS_2D_H_I & !<-- # of 2-D integer H variables to update - ,NUM_FIELDS_2D_H_R & !<-- # of 2-D real H variables to update - ,NUM_FIELDS_3D_H & !<-- # of 3-D H variables to update - ,NUM_FIELDS_2D_V & !<-- # of 2-D V variables to update - ,NUM_FIELDS_3D_V !<-- # of 3-D V variables to update -! - INTEGER(kind=KINT),INTENT(IN) :: SFC_FILE_RATIO !<-- Ratio of upper parent grid increment to this domain's -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: GLAT_H & !<-- This domain's geographic latitude (radians) on H pts - ,GLON_H !<-- This domain's geographic longitude (radians) on H pts -! - TYPE(ESMF_State),INTENT(INOUT) :: IMP_STATE !<-- The Domain import state -! - TYPE(ESMF_FieldBundle),INTENT(INOUT) :: MOVE_BUNDLE_H & !<-- Bundle of internal state H arrays needing updates - ,MOVE_BUNDLE_V !<-- Bundle of internal state V arrays needing updates -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: I,I_END,I_OFFSET,I_START & - ,IHI,ILO,INPUT_NEST & - ,J,J_END,J_OFFSET,J_START & - ,JHI,JLO,KHI,KLO & - ,KOUNT_INTEGER,KOUNT_REAL & - ,N,N_FIELD,N_ITER,N_REMOVE,NI,NL,NN & - ,NUM_DIMS,NUM_FIELDS & - ,NUM_INTEGER_WORDS & - ,NUM_PTASK_UPDATE,NUM_REAL_WORDS & - ,UPDATE_TYPE_INT -! - INTEGER(kind=KINT) :: I_COUNT_DATA,I_START_DATA & - ,J_COUNT_DATA,J_START_DATA & - ,NCID,NCTYPE,NDIMS,NX,NY,VAR_ID -! - INTEGER(kind=KINT) :: N_FIELD_T,N_FIELD_TP & - ,N_FIELD_U,N_FIELD_UP & - ,N_FIELD_V,N_FIELD_VP -! - INTEGER(kind=KINT) :: IERR,RC,RC_UPDATE -! - INTEGER(kind=KINT),DIMENSION(1:2) :: DIM_IDS,LBND,UBND -! - INTEGER(kind=KINT),DIMENSION(1:3) :: LIMITS_HI & - ,LIMITS_LO -! - INTEGER(kind=KINT),DIMENSION(1:8) :: INDICES_H,INDICES_V -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: UPDATE_INTEGER_DATA -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: I_INDX,J_INDX -! - INTEGER(kind=KINT),DIMENSION(:,:),ALLOCATABLE :: SFC_IDATA -! - INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: IARRAY_2D=>NULL() -! - REAL(kind=KFPT) :: GBL,REAL_I,REAL_J -! - REAL(kind=KFPT),DIMENSION(:),ALLOCATABLE :: UPDATE_REAL_DATA -! - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ARRAY_2D=>NULL() & -! - ,ALBASE=>NULL() & - ,SEA_MASK=>NULL() & - ,SSTX=>NULL() -! - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: ARRAY_3D=>NULL() & - ,ARRAY_3D_X=>NULL() -! - CHARACTER(len=1) :: N_PTASK & - ,UPDATE_TYPE_CHAR - CHARACTER(len=2) :: ID_SFC_FILE - CHARACTER(len=12) :: NAME - CHARACTER(len=15) :: VNAME - CHARACTER(len=17) :: NAME_REAL - CHARACTER(len=20) :: NAME_INTEGER - CHARACTER(len=99) :: FIELD_NAME & - ,FILENAME -! - LOGICAL(kind=KLOG) :: OPENED -! - TYPE(ESMF_Field) :: HOLD_FIELD & - ,HOLD_FIELD_X -! - TYPE(ESMF_TypeKind_Flag) :: DATATYPE -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Unload the number of parent tasks who provide update data -!*** for this nest task. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="How Many Parent Tasks Sent Interior Updates?" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Domain import state - ,name ='Num Parent Tasks Update' & !<-- Name of the variable - ,value=NUM_PTASK_UPDATE & !<-- # of parent tasks that update this nest task - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_UPDATE) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** If no parent tasks provide data then there is nothing to do -!*** so RETURN. -!----------------------------------------------------------------------- -! - IF(NUM_PTASK_UPDATE==0)RETURN -! -!----------------------------------------------------------------------- -!*** Unload each piece of data that was sent by each parent task -!*** and apply it to given locations within the arrays in the -!*** Move Bundles for H-pt and V-pt variables. -!----------------------------------------------------------------------- -! - parent_loop: DO N=1,NUM_PTASK_UPDATE -! -!----------------------------------------------------------------------- -! - KOUNT_INTEGER=0 !<-- Count the integer update points from this parent task - KOUNT_REAL=0 !<-- Count the real update points from this parent task -! - WRITE(N_PTASK,'(I1)')N - NAME_INTEGER='PTASK_INTEGER_DATA_'//N_PTASK - NAME_REAL ='PTASK_REAL_DATA_'//N_PTASK - NAME ='PTASK_DATA_'//N_PTASK -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Unload # of Words in Integer Update Data from Parent" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Domain import state - ,name =NAME_INTEGER//' Words' & !<-- Name of the variable - ,value=NUM_INTEGER_WORDS & !<-- # of words in integer update data from Nth parent task - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_UPDATE) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - unload_int: IF(NUM_INTEGER_WORDS>0)THEN -! -!----------------------------------------------------------------------- -! - ALLOCATE(UPDATE_INTEGER_DATA(1:NUM_INTEGER_WORDS)) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Unload Interior Update Integer Data from Input State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The Domain import state - ,name =NAME_INTEGER & !<-- Name of the variable - ,itemCount=NUM_INTEGER_WORDS & !<-- # of integer words in update data from Nth parent task - ,valueList=UPDATE_INTEGER_DATA & !<-- The integer update data from Nth parent task - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_UPDATE) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - ENDIF unload_int -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Unload # of Words in Real Update Data from Parent" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Domain import state - ,name =NAME_REAL//' Words' & !<-- Name of the variable - ,value=NUM_REAL_WORDS & !<-- # of words in real update data from Nth parent task - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_UPDATE) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ALLOCATE(UPDATE_REAL_DATA(1:NUM_REAL_WORDS)) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Unload Interior Update Real Data from Input State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The Domain import state - ,name =NAME_REAL & !<-- Name of the variable - ,itemCount=NUM_REAL_WORDS & !<-- # of real words in update data from Nth parent task - ,valueList=UPDATE_REAL_DATA & !<-- The real update data from Nth parent task - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_UPDATE) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Index Limits for Update Data from Domain Input State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The Domain import state - ,name =NAME//' Indices H' & !<-- Name of the variable - ,itemCount=N8 & !<-- # of words in index limits of update data - ,valueList=INDICES_H & !<-- The update data index specifications for H - ,rc =RC) -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The Domain import state - ,name =NAME//' Indices V' & !<-- Name of the variable - ,itemCount=N8 & !<-- # of words in index limits of update data - ,valueList=INDICES_V & !<-- The update data index specifications for V - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_UPDATE) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Update the nest's H points from parent task N. -!----------------------------------------------------------------------- -! - N_ITER=1 - IF(INDICES_H(2)>-99)THEN !<-- If true, there are 2 update regions from parent task - N_ITER=2 - ENDIF -! - NUM_FIELDS=NUM_FIELDS_2D_H_I+NUM_FIELDS_2D_H_R+NUM_FIELDS_3D_H -! -!----------------------------------------------------------------------- -!*** Typically there is only one update region within the task -!*** unless the task lies on a corner of the pre-move footprint -!*** in which case there are two update regions. N_ITER in the -!*** following loop refers to the number of update regions for -!*** this nest task. -!----------------------------------------------------------------------- -! - iterations_h: DO NI=1,N_ITER !<-- Update each region with parent information -! -!----------------------------------------------------------------------- -! - I_START=INDICES_H(1) - I_END =INDICES_H(3) - J_START=INDICES_H(5) - J_END =INDICES_H(7) -! - IF(NI==2)THEN - I_START=INDICES_H(2) - I_END =INDICES_H(4) - J_START=INDICES_H(6) - J_END =INDICES_H(8) - ENDIF -! -!----------------------------------------------------------------------- -!*** For those 2-D surface variables that must be read from -!*** external files after nests shift we will need the regions -!*** within each relevant nest task that must be updated. -!----------------------------------------------------------------------- -! - IF(GLOBAL_TOP_PARENT)THEN - GBL=1. !<-- Account for the extra row that surrounds the global domain. - ELSE - GBL=0. - ENDIF -! - CALL LATLON_TO_IJ(GLAT_H(I_START,J_START) & !<-- Geographic latitude of nest task's 1st update point - ,GLON_H(I_START,J_START) & !<-- Geographic longitude of nest task's 1st update point - ,TPH0_1,TLM0_1 & !<-- Central lat/lon (radians, N/E) of uppermost parent - ,SB_1,WB_1 & !<-- Rotated lat/lon of upper parent's S/W bndry (radians, N/E) - ,RECIP_DPH_1,RECIP_DLM_1 & !<-- Reciprocal of I/J grid increments (radians) on upper parent - ,GLOBAL_TOP_PARENT & !<-- Is the uppermost parent on a global grid? - ,REAL_I & !<-- Corresponding I index on uppermost parent grid - ,REAL_J) !<-- Corresponding J index on uppermost parent grid -! - I_OFFSET=NINT((REAL_I-1.-GBL)*SFC_FILE_RATIO) !<-- Offset in I between sfc file index and nest index - J_OFFSET=NINT((REAL_J-1.-GBL)*SFC_FILE_RATIO) !<-- Offset in J between sfc file index and nest index -! - I_START_DATA=I_OFFSET+1 !<-- Start reading at this I in the external file array - I_COUNT_DATA=I_END-I_START+1 !<-- Read this many points in I - J_START_DATA=J_OFFSET+1 !<-- Start reading at this J in the external file array - J_COUNT_DATA=J_END-J_START+1 !<-- Read this many points in J -! -!----------------------------------------------------------------------- -!*** Now proceed with the updating of all H-pt variables with data -!*** sent from the parent. All Fields in the Move Bundles have names -!*** containing the suffix '-move' to distinguish them from the same -!*** Fields that occur in the same ESMF States for different reasons. -!*** The suffix is removed to obtain the actual name. -!----------------------------------------------------------------------- -! - fields_h: DO N_FIELD=1,NUM_FIELDS !<-- Update all H-point arrays -! -!----------------------------------------------------------------------- -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=MOVE_BUNDLE_H & !<-- Bundle holding the H arrays for move updates - ,fieldIndex =N_FIELD & !<-- Index of the Field in the Bundle - ,field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,rc =RC ) -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,dimCount=NUM_DIMS & !<-- Is this Field 2-D or 3-D? - ,typekind=DATATYPE & !<-- Is the data integer or real? - ,name =FIELD_NAME & !<-- Name of the Field - ,rc =RC ) -! - N_REMOVE=INDEX(FIELD_NAME,SUFFIX_MOVE) - FIELD_NAME=FIELD_NAME(1:N_REMOVE-1) -! -!----------------------------------------------------------------------- -!*** ***** TEMPORARY ***** -!*** **** T/TP, etc. **** -!----------------------------------------------------------------------- -!*** The variables PDO, TP, UP, and VP are valid one timestep before -!*** the current one. Since the timestep of the parent is larger than -!*** that of its nests then if the parent simply interpolated those -!*** variables spatially to the nest update points then they would -!*** not be valid at one timestep before the nest's current time. -!*** Fixing this additional temporal interpolation will be done -!*** at a later date therefore for the moment the parent will send -!*** its spatially interpolated values of PD, T, U, and V for those -!*** four variables. The parent already substituted its interpolated -!*** PD values for PDO in subroutine PARENT_UPDATES_MOVING. Now save -!*** the locations of T and TP in the H Move Bundle so the analogous -!*** substitution can be made after the fields_h loop immediately -!*** following the updates of all H-point variables. The same is -!*** done in the field_v loop for U,UP and V,VP. -!----------------------------------------------------------------------- -! - IF(FIELD_NAME=='T')THEN - N_FIELD_T=N_FIELD - ELSEIF(FIELD_NAME=='TP')THEN - N_FIELD_TP=N_FIELD - ENDIF -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract UPDATE_TYPE from Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(field=HOLD_FIELD & !<-- Get Attribute from this Field - ,name ='UPDATE_TYPE' & !<-- Name of the attribute to extract - ,value=UPDATE_TYPE_INT & !<-- Value of the Attribute - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_UPDATE) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(UPDATE_TYPE_INT==1)THEN - UPDATE_TYPE_CHAR='H' !<-- Ordinary H-pt variable - ELSEIF(UPDATE_TYPE_INT==2)THEN - UPDATE_TYPE_CHAR='L' !<-- H-pt land surface variable - ELSEIF(UPDATE_TYPE_INT==3)THEN - UPDATE_TYPE_CHAR='W' !<-- H-pt water surface variable - ELSEIF(UPDATE_TYPE_INT==4)THEN - UPDATE_TYPE_CHAR='F' !<-- H-pt variable obtained from an external file - ELSEIF(UPDATE_TYPE_INT==5)THEN - UPDATE_TYPE_CHAR='V' !<-- Ordinary V-pt variable - ENDIF -! -!----------------------------------------------------------------------- -!*** Updated 2-D H-point arrays include both Integer and Real. -!----------------------------------------------------------------------- -! - IF(NUM_DIMS==2)THEN -! -!----------------------------------------------------------------------- -!*** Some surface-related variables that do not change in time are -!*** read directly by the relevant moving nest tasks from external -!*** files. Those files contain the data at the nest's resolution -!*** but span the entire uppermost parent domain. Such variables -!*** are all 2-D. -!----------------------------------------------------------------------- -! - update_type: IF(UPDATE_TYPE_CHAR=='F')THEN !<-- If so, the variable is updated from an external file -! -!----------------------------------------------------------------------- -! - IF(SFC_FILE_RATIO<=9)THEN - WRITE(ID_SFC_FILE,'(I1.1)')SFC_FILE_RATIO - ELSEIF(SFC_FILE_RATIO>=10)THEN - WRITE(ID_SFC_FILE,'(I2.2)')SFC_FILE_RATIO - ENDIF -! - FILENAME=TRIM(FIELD_NAME)//'_'//TRIM(ID_SFC_FILE)//'.nc' -! - CALL CHECK(NF90_OPEN(FILENAME,NF90_NOWRITE,NCID)) !<-- Open the current field's external netCDF file. -! -!----------------------------------------------------------------------- -! -!---------- -!*** Real -!---------- -! - IF(DATATYPE==ESMF_TYPEKIND_R4)THEN !<-- The 2-D H-point external file data is Real -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract 2-D Real Array for Type F" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,localDe =0 & - ,farrayPtr=ARRAY_2D & !<-- Dummy 2-D array with Field's Real data - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_UPDATE) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL CHECK(NF90_INQUIRE_VARIABLE(NCID,3,VNAME,NCTYPE & - ,NDIMS,DIM_IDS)) - CALL CHECK(NF90_INQ_VARID(NCID,VNAME,VAR_ID)) -! - CALL CHECK(NF90_GET_VAR(NCID,VAR_ID & !<-- Extract the desired real values from the - ,ARRAY_2D(I_START:I_END,J_START:J_END) & ! current field's external file. - ,start=(/I_START_DATA,J_START_DATA/) & ! Nest points that have moved beyond the - ,count=(/I_COUNT_DATA,J_COUNT_DATA/))) ! pre-move footprint are updated. -! -!----------------------------------------------------------------------- -!*** Save the base albedo to provide values for the dynamic albedo -!*** in parent update regions when needed. -!----------------------------------------------------------------------- -! -! IF(TRIM(FIELDNAME)=='ALBASE')THEN -! ALBASE=>ARRAY_2D !<-- Save the base albedo for fixing conflict points -! ENDIF -! -!----------------------------------------------------------------------- -!*** Save the sea mask for use in cleaning up surface variables -!*** following this primary update. This needs to be done when -!*** the parent uses a land(water) point to update a nest water(land) -!*** point. -!----------------------------------------------------------------------- -! - IF(TRIM(FIELD_NAME)=='SM')THEN - SEA_MASK=>ARRAY_2D - ENDIF -! -!------------- -!*** Integer -!------------- -! - ELSEIF(DATATYPE==ESMF_TYPEKIND_I4)THEN !<-- The 2-D H-point external file data is Integer -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract 2-D Integer Array for Type F" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,localDe =0 & - ,farrayPtr=IARRAY_2D & !<-- Dummy 2-D array with Field's Real data - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_UPDATE) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL CHECK(NF90_INQUIRE_VARIABLE(NCID,3,VNAME,NCTYPE & - ,NDIMS,DIM_IDS)) - CALL CHECK(NF90_INQ_VARID(NCID,VNAME,VAR_ID)) -! - CALL CHECK(NF90_GET_VAR(NCID,VAR_ID & !<-- Extract the desired integer values from the - ,IARRAY_2D(I_START:I_END,J_START:J_END) & ! current field's external file. - ,start=(/I_START_DATA,J_START_DATA/) & ! Nest points that have moved beyond the - ,count=(/I_COUNT_DATA,J_COUNT_DATA/))) ! pre-move footprint are updated. -! - ENDIF -! - CALL CHECK(NF90_CLOSE(NCID)) !<-- Close the external netCDF file. -! - CYCLE fields_h -! -!----------------------------------------------------------------------- -!*** All other variables that are not specified with UPDATE_TYPE='F' -!*** are updated from the data sent from the parent. -!----------------------------------------------------------------------- -! - ELSE update_type -! -!------------- -!*** Integer -!------------- -! - IF(DATATYPE==ESMF_TYPEKIND_I4 & !<-- The 2-D H-point array to be updated is Integer - .AND. & - NUM_INTEGER_WORDS>0)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract General 2-D Integer Array" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,localDe =0 & - ,farrayPtr=IARRAY_2D & !<-- Dummy 2-D array with Field's integer data - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_UPDATE) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** This nest task incorporates the standard 2-D Integer update data -!*** sent to it from the parent. -!----------------------------------------------------------------------- -! - DO J=J_START,J_END - DO I=I_START,I_END - KOUNT_INTEGER=KOUNT_INTEGER+1 - IARRAY_2D(I,J)=UPDATE_INTEGER_DATA(KOUNT_INTEGER) - ENDDO - ENDDO -! -!---------- -!*** Real -!---------- -! - ELSEIF(DATATYPE==ESMF_TYPEKIND_R4)THEN !<-- The 2-D H-point array to be updated is Real -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract General 2-D Real Array" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,localDe =0 & - ,farrayPtr=ARRAY_2D & !<-- Dummy 2-D array with Field's Real data - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_UPDATE) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** This nest task incorporates the standard 2-D Real update -!*** data sent to it from the parent. -!----------------------------------------------------------------------- -! - DO J=J_START,J_END - DO I=I_START,I_END - KOUNT_REAL=KOUNT_REAL+1 - ARRAY_2D(I,J)=UPDATE_REAL_DATA(KOUNT_REAL) - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** Save the sea surface temperature as a flag for discriminating -!*** between sea and land points when there is a conflict between -!*** the nest's sea mask and the type of data (sea or land) it is -!*** sent by its parent. The SST should always equal 0.0 at land -!*** points. -!----------------------------------------------------------------------- -! -! IF(TRIM(FIELD_NAME)=='SST')THEN -! SSTX=>ARRAY_2D -! ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF update_type -! -!----------------------------------------------------------------------- -! - ELSEIF(NUM_DIMS==3)THEN !<-- The parent's update of all 3-D variables -! -!----------------------------------------------------------------------- -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N in the Bundle - ,localDe =0 & - ,farrayPtr =ARRAY_3D & !<-- Dummy 3-D array with Field's data - ,totalLBound=LIMITS_LO & !<-- Starting index in each dimension - ,totalUBound=LIMITS_HI & !<-- Ending index in each dimension - ,rc =RC ) -! - DO NL=LIMITS_LO(3),LIMITS_HI(3) - DO J=J_START,J_END - DO I=I_START,I_END - KOUNT_REAL=KOUNT_REAL+1 - ARRAY_3D(I,J,NL)=UPDATE_REAL_DATA(KOUNT_REAL) - ENDDO - ENDDO - ENDDO -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO fields_h -! -!----------------------------------------------------------------------- -!*** The temporary substitution of T into TP. See note above ('T/TP'). -!----------------------------------------------------------------------- -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=MOVE_BUNDLE_H & !<-- Bundle holding the H arrays for move updates - , fieldIndex=N_FIELD_T & !<-- Index of the T Field in the H Bundle - ,field =HOLD_FIELD & !<-- The T Field in the H Bundle - ,rc =RC ) -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=MOVE_BUNDLE_H & !<-- Bundle holding the H arrays for move updates - ,fieldIndex =N_FIELD_TP & !<-- Index of the TP Field in the H Bundle - ,field =HOLD_FIELD_X & !<-- The TP Field in the H Bundle - ,rc =RC ) -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- The T Field in the H Bundle - ,localDe =0 & - ,farrayPtr =ARRAY_3D & !<-- Dummy 3-D array with Field's data - ,totalLBound=LIMITS_LO & !<-- Starting index in each dimension - ,totalUBound=LIMITS_HI & !<-- Ending index in each dimension - ,rc =RC ) - CALL ESMF_FieldGet(field =HOLD_FIELD_X & !<-- The TP Field in the H Bundle - ,localDe =0 & - ,farrayPtr =ARRAY_3D_X & !<-- Dummy 3-D array with Field's data - ,totalLBound=LIMITS_LO & !<-- Starting index in each dimension - ,totalUBound=LIMITS_HI & !<-- Ending index in each dimension - ,rc =RC ) -! - DO NL=LIMITS_LO(3),LIMITS_HI(3) - DO J=J_START,J_END - DO I=I_START,I_END - ARRAY_3D_X(I,J,NL)=ARRAY_3D(I,J,NL) !<-- For now fill TP with T update values - ENDDO - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** Now go back and correct any mismatches between the nest's -!*** sea/land mask and the type of data (land or water) received -!*** from the parent. -!----------------------------------------------------------------------- -! -! - ILO=LBOUND(SEA_MASK,1) - IHI=UBOUND(SEA_MASK,1) - JLO=LBOUND(SEA_MASK,2) - JHI=UBOUND(SEA_MASK,2) -! - CALL FIX_SFC(MOVE_BUNDLE_H,NUM_FIELDS & - ,SEA_MASK & - ,ILO,IHI,JLO,JHI & - ,I_START,I_END,J_START,J_END) -! -!----------------------------------------------------------------------- -! - ENDDO iterations_h -! -!----------------------------------------------------------------------- -!*** Update the nest's V points from parent task N. -!----------------------------------------------------------------------- -! - N_ITER=1 - IF(INDICES_V(2)>-99)THEN !<-- If true, there are 2 update regions from parent task - N_ITER=2 - ENDIF -! - NUM_FIELDS=NUM_FIELDS_2D_V+NUM_FIELDS_3D_V -! -!----------------------------------------------------------------------- -! - iterations_v: DO NI=1,N_ITER -! -!----------------------------------------------------------------------- -! - I_START=INDICES_V(1) - I_END =INDICES_V(3) - J_START=INDICES_V(5) - J_END =INDICES_V(7) -! - IF(NI==2)THEN - I_START=INDICES_V(2) - I_END =INDICES_V(4) - J_START=INDICES_V(6) - J_END =INDICES_V(8) - ENDIF -! -!----------------------------------------------------------------------- -! - fields_v: DO N_FIELD=1,NUM_FIELDS -! -!----------------------------------------------------------------------- -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=MOVE_BUNDLE_V & !<-- Bundle holding the V arrays for move updates - ,fieldIndex =N_FIELD & !<-- Index of the Field in the Bundle - ,field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,rc =RC ) -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,dimCount=NUM_DIMS & !<-- Is this Field 2-D or 3-D? - ,name =FIELD_NAME & !<-- Name of the Field - ,rc =RC ) -! - N_REMOVE=INDEX(FIELD_NAME,SUFFIX_MOVE) - FIELD_NAME=FIELD_NAME(1:N_REMOVE-1) -! -!----------------------------------------------------------------------- -!*** ***** TEMPORARY ***** -!*** See above regarding T/TP, etc. -!----------------------------------------------------------------------- -! - IF(FIELD_NAME=='U')THEN - N_FIELD_U=N_FIELD - ELSEIF(FIELD_NAME=='UP')THEN - N_FIELD_UP=N_FIELD - ELSEIF(FIELD_NAME=='V')THEN - N_FIELD_V=N_FIELD - ELSEIF(FIELD_NAME=='VP')THEN - N_FIELD_VP=N_FIELD - ENDIF -! -!----------------------------------------------------------------------- -! - IF(NUM_DIMS==2)THEN -! -!----------------------------------------------------------------------- -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,localDe =0 & - ,farrayPtr=ARRAY_2D & !<-- Dummy 2-D array with Field's data - ,rc =RC ) -! -!----------------------------------------------------------------------- -!*** Update this 2-D array with values from the parent. -!----------------------------------------------------------------------- -! - DO J=J_START,J_END - DO I=I_START,I_END - KOUNT_REAL=KOUNT_REAL+1 - ARRAY_2D(I,J)=UPDATE_REAL_DATA(KOUNT_REAL) - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -! - ELSEIF(NUM_DIMS==3)THEN -! -!----------------------------------------------------------------------- -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N in the Bundle - ,localDe =0 & - ,farrayPtr =ARRAY_3D & !<-- Dummy 3-D array with Field's data - ,totalLBound=LIMITS_LO & !<-- Starting index in each dimension - ,totalUBound=LIMITS_HI & !<-- Ending index in each dimension - ,rc =RC ) -! - DO NL=LIMITS_LO(3),LIMITS_HI(3) - DO J=J_START,J_END - DO I=I_START,I_END - KOUNT_REAL=KOUNT_REAL+1 - ARRAY_3D(I,J,NL)=UPDATE_REAL_DATA(KOUNT_REAL) - ENDDO - ENDDO - ENDDO -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO fields_v -! -!----------------------------------------------------------------------- -!*** The temporary substitution of U/V into UP/VP. See note above. -!----------------------------------------------------------------------- -! -!-------- -!*** UP -!-------- -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=MOVE_BUNDLE_V & !<-- Bundle holding the V arrays for move updates - ,fieldIndex =N_FIELD_U & !<-- Index of the U Field in the V Bundle - ,field =HOLD_FIELD & !<-- The U Field in the V Bundle - ,rc =RC ) -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=MOVE_BUNDLE_V & !<-- Bundle holding the V arrays for move updates - ,fieldIndex =N_FIELD_UP & !<-- Index of the UP Field in the V Bundle - ,field =HOLD_FIELD_X & !<-- The UP Field in the V Bundle - ,rc =RC ) -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- The U Field in the V Bundle - ,localDe =0 & - ,farrayPtr =ARRAY_3D & !<-- Dummy 3-D array with Field's data - ,totalLBound=LIMITS_LO & !<-- Starting index in each dimension - ,totalUBound=LIMITS_HI & !<-- Ending index in each dimension - ,rc =RC ) - CALL ESMF_FieldGet(field =HOLD_FIELD_X & !<-- The UP Field in the V Bundle - ,localDe =0 & - ,farrayPtr =ARRAY_3D_X & !<-- Dummy 3-D array with Field's data - ,totalLBound=LIMITS_LO & !<-- Starting index in each dimension - ,totalUBound=LIMITS_HI & !<-- Ending index in each dimension - ,rc =RC ) -! - DO NL=LIMITS_LO(3),LIMITS_HI(3) - DO J=J_START,J_END - DO I=I_START,I_END - ARRAY_3D_X(I,J,NL)=ARRAY_3D(I,J,NL) !<-- For now fill UP with U update values - ENDDO - ENDDO - ENDDO -! -!-------- -!*** VP -!-------- -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=MOVE_BUNDLE_V & !<-- Bundle holding the V arrays for move updates - ,fieldIndex =N_FIELD_V & !<-- Index of the V Field in the V Bundle - ,field =HOLD_FIELD & !<-- The U Field in the V Bundle - ,rc =RC ) -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=MOVE_BUNDLE_V & !<-- Bundle holding the V arrays for move updates - ,fieldIndex =N_FIELD_VP & !<-- Index of the VP Field in the V Bundle - ,field =HOLD_FIELD_X & !<-- The UP Field in the V Bundle - ,rc =RC ) -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- The V Field in the V Bundle - ,localDe =0 & - ,farrayPtr =ARRAY_3D & !<-- Dummy 3-D array with Field's data - ,totalLBound=LIMITS_LO & !<-- Starting index in each dimension - ,totalUBound=LIMITS_HI & !<-- Ending index in each dimension - ,rc =RC ) - CALL ESMF_FieldGet(field =HOLD_FIELD_X & !<-- The VP Field in the V Bundle - ,localDe =0 & - ,farrayPtr =ARRAY_3D_X & !<-- Dummy 3-D array with Field's data - ,totalLBound=LIMITS_LO & !<-- Starting index in each dimension - ,totalUBound=LIMITS_HI & !<-- Ending index in each dimension - ,rc =RC ) -! - DO NL=LIMITS_LO(3),LIMITS_HI(3) - DO J=J_START,J_END - DO I=I_START,I_END - ARRAY_3D_X(I,J,NL)=ARRAY_3D(I,J,NL) !<-- For now fill VP with V update values - ENDDO - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -! - ENDDO iterations_v -! -!----------------------------------------------------------------------- -! - IF(ALLOCATED(UPDATE_INTEGER_DATA))THEN - DEALLOCATE(UPDATE_INTEGER_DATA) - ENDIF -! - DEALLOCATE(UPDATE_REAL_DATA) -! -!----------------------------------------------------------------------- -! - ENDDO parent_loop -! -!----------------------------------------------------------------------- -! - END SUBROUTINE UPDATE_INTERIOR_FROM_PARENT -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE UPDATE_LATLON(IMP_STATE & - ,EXP_STATE_SOLVER & - ,I_LBND,I_UBND & - ,J_LBND,J_UBND & - ,I_START,I_END & - ,J_START,J_END & - ,GLAT_X & - ,GLON_X & - ,HDACX & - ,HDACY & - ,F ) -! -!----------------------------------------------------------------------- -!*** After the nest has moved recompute the geographic latitude and -!*** longitude on only those points that lie in the parent update -!*** region. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: I_START,I_END & !<-- Compute lat/lons over this range of I - ,J_START,J_END !<-- Compute lat/lons over this range of J -! - INTEGER(kind=KINT),INTENT(IN) :: I_LBND,I_UBND & !<-- Lower/upper bounds of I in lat/lon arrays - ,J_LBND,J_UBND !<-- Lower/upper bounds of J in lat/lon arrays -! - TYPE(ESMF_State),INTENT(IN) :: IMP_STATE !<-- The Domain import state -! - TYPE(ESMF_State),INTENT(IN) :: EXP_STATE_SOLVER !<-- The Solver export state -! - REAL(kind=KFPT),DIMENSION(I_LBND:I_UBND,J_LBND:J_UBND) & - ,INTENT(INOUT) :: GLAT_X & !<-- Geographic latitude on nest (radians) - ,GLON_X !<-- Geographic longitude on nest (radians) -! - REAL(kind=KFPT),DIMENSION(I_LBND:I_UBND,J_LBND:J_UBND) & - ,INTENT(OUT) :: HDACX & !<-- Lateral diffusion coefficients - ,HDACY !<-- -! - REAL(kind=KFPT),DIMENSION(I_LBND:I_UBND,J_LBND:J_UBND) & - ,INTENT(OUT),OPTIONAL :: F -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: I,I_SHIFT,INC_LAT,INC_LON & - ,J,J_SHIFT & - ,KOUNT -! - INTEGER(kind=KINT) :: RC,RC_RUN -! - REAL(kind=KFPT) :: A_DLM,ADD,ARG1,ARG2,ARG3 & - ,COS_TPH,COS_TPH0,DY & - ,SB_PARENT1 & - ,SIN_TPH,SIN_TPH0,TAN_TPH0 & - ,WB_PARENT1 -! - REAL(kind=KFPT),DIMENSION(J_LBND:J_UBND) :: DX -! - REAL(kind=KFPT),DIMENSION(I_LBND:I_UBND & - ,J_LBND:J_UBND) :: TLAT_X,TLON_X -! - LOGICAL(kind=KLOG) :: VELOCITY !<-- Are we computing for the V points? -! - TYPE(ESMF_Field) :: FIELD_X -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - IF(.NOT.PRESENT(F))THEN - VELOCITY=.FALSE. !<-- H points - SB_PARENT1=SB_1 !<-- Transformed latitude of upper parent S boundary - WB_PARENT1=WB_1 !<-- Transformed longitude of upper parent W boundary - ELSEIF(PRESENT(F))THEN - VELOCITY=.TRUE. !<-- V points - SB_PARENT1=SB_1+0.5*DPH !<-- Transformed latitude of upper parent S boundary - WB_PARENT1=WB_1+0.5*DLM !<-- Transformed longitude of upper parent W boundary - ENDIF -! - DY=A*DPH - A_DLM=A*DLM -! - COS_TPH0=COS(TPH0) - SIN_TPH0=SIN(TPH0) - TAN_TPH0=TAN(TPH0) -! -!----------------------------------------------------------------------- -!*** Compute the pre-move rotated latitude/longitude of the -!*** update region's SW corner H and V points. Remember that -!*** GLAT and GLON still have their pre-move values. -!----------------------------------------------------------------------- -! - CALL GEO_TO_ROT(GLAT_X(I_START,J_START),GLON_X(I_START,J_START) & - ,TLAT_X(I_START,J_START),TLON_X(I_START,J_START)) -! -!----------------------------------------------------------------------- -!*** What are the transformed coordinates of the SW corner -!*** after the nest moved? And then how many equivalent grid -!*** increments from the upper parent's grid's southern and -!*** western boundary to that SW corner? By anchoring the -!*** update on the upper parent's domain then the nests will -!*** always generate bit identical results no matter what -!*** their task layouts are. -!----------------------------------------------------------------------- -! - TLAT_X(I_START,J_START)=TLAT_X(I_START,J_START)+J_SHIFT_CHILD*DPH - TLON_X(I_START,J_START)=TLON_X(I_START,J_START)+I_SHIFT_CHILD*DLM -! - INC_LAT=NINT((TLAT_X(I_START,J_START)-SB_PARENT1)/DPH) - INC_LON=NINT((TLON_X(I_START,J_START)-WB_PARENT1)/DLM) -! -!----------------------------------------------------------------------- -!*** Now fill in the transformed coordinates on the task subdomain's -!*** update region following the nest's shift. -!----------------------------------------------------------------------- -! - KOUNT=-1 - DO J=J_START,J_END - KOUNT=KOUNT+1 - TLAT_X(I_START,J)=SB_PARENT1+(INC_LAT+KOUNT)*DPH - TLON_X(I_START,J)=WB_PARENT1+INC_LON*DLM - ENDDO -! - DO J=J_START,J_END - KOUNT=0 - DO I=I_START+1,I_END - KOUNT=KOUNT+1 - TLAT_X(I,J)=TLAT_X(I_START,J) -! TLON_X(I,J)=TLON_X(I_START,J)+KOUNT*DLM - TLON_X(I,J)=WB_PARENT1+(INC_LON+KOUNT)*DLM - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** Convert from transformed to geographic coordinates. -!----------------------------------------------------------------------- -! - DO J=J_START,J_END - DX(J)=A_DLM*COS(TLAT_X(I_START,J)) - ENDDO - - DO J=J_START,J_END - DO I=I_START,I_END -! - ARG1=SIN(TLAT_X(I,J))*COS_TPH0 & - +COS(TLAT_X(I,J))*SIN_TPH0*COS(TLON_X(I,J)) - GLAT_X(I,J)=ASIN(ARG1) -! - ARG1=COS(TLAT_X(I,J))*COS(TLON_X(I,J))/(COS(GLAT_X(I,J))*COS_TPH0) - ARG2=TAN(GLAT_X(I,J))*TAN_TPH0 - ADD=SIGN(1.,TLON_X(I,J)) - ARG3=ARG1-ARG2 - ARG3=SIGN(1.,ARG3)*MIN(ABS(ARG3),1.) !<-- Bound the argument of ACOS - GLON_X(I,J)=TLM0+ADD*ACOS(ARG3) -! - HDACX(I,J)=ACDT*DY*MAX(DX(J),DY)/(4.*DX(J)*DY) - HDACY(I,J)=HDACX(I,J) -! - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** Update the Coriolis parameter for V points. -!----------------------------------------------------------------------- -! - IF(VELOCITY)THEN -! - DO J=J_START,J_END - DO I=I_START,I_END -! - SIN_TPH=SIN(TLAT_X(I,J)) - COS_TPH=COS(TLAT_X(I,J)) - F(I,J)=TWOM*(COS_TPH0*SIN_TPH+SIN_TPH0*COS_TPH*COS(TLON_X(I,J))) -! - ENDDO - ENDDO -! - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE UPDATE_LATLON -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE GEO_TO_ROT(GLATX,GLONX,RLATX,RLONX) -! -!----------------------------------------------------------------------- -!*** Convert from geographic to rotated coordinates. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - REAL(kind=KFPT),INTENT(IN) :: GLATX & !<-- Geographic latitude (radians) - ,GLONX !<-- Geographic longitude (radians) -! - REAL(kind=KFPT),INTENT(OUT) :: RLATX & !<-- Rotated latitude (radians) - ,RLONX !<-- Rotated longitude (radians) -! -!--------------------- -!*** Local Variables -!--------------------- -! - REAL(kind=KFPT) :: X,Y,Z -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - X=COS(TPH0)*COS(GLATX)*COS(GLONX-TLM0)+SIN(TPH0)*SIN(GLATX) - Y=COS(GLATX)*SIN(GLONX-TLM0) - Z=-SIN(TPH0)*COS(GLATX)*COS(GLONX-TLM0)+COS(TPH0)*SIN(GLATX) -! - RLATX=ATAN(Z/SQRT(X*X+Y*Y)) - RLONX=ATAN(Y/X) - IF(X<0)RLONX=RLONX+PI -! -!----------------------------------------------------------------------- -! - END SUBROUTINE GEO_TO_ROT -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE FIX_SFC(MOVE_BUNDLE_H,NUM_FIELDS & - ,SEA_MASK & - ,ILO,IHI,JLO,JHI & - ,I_START,I_END,J_START,J_END) -! -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: ILO,IHI,JLO,JHI & !<-- I,J subdomain limits - ,I_START,I_END & !<-- I limits of parent update region - ,J_START,J_END & !<-- J limits of parent update region - ,NUM_FIELDS !<-- # of H-pt update variables after shift -! - REAL(kind=KFPT),DIMENSION(ILO:IHI,JLO:JHI),INTENT(IN) :: SEA_MASK !<-- This nest's sea mask (1=>water) -! - TYPE(ESMF_FieldBundle),INTENT(INOUT) :: MOVE_BUNDLE_H !<-- Bundle of internal state H arrays that shift -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: I,J,K,N_FIELD,NUM_DIMS,UPDATE_TYPE_INT -! - INTEGER(kind=KINT) :: RC,RC_FIX -! - INTEGER(kind=KINT),DIMENSION(1:3) :: LIMITS_HI,LIMITS_LO -! - INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: IARRAY_2D -! - REAL(kind=KFPT) :: CHECK -! - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ARRAY_2D -! - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: ARRAY_3D -! - CHARACTER(len=1) :: UPDATE_TYPE_CHAR -! - CHARACTER(len=25) :: FNAME -! - CHARACTER(len=99) :: FIELD_NAME -! - LOGICAL(kind=KLOG) :: FOUND -! - TYPE(ESMF_Field) :: HOLD_FIELD -! - TYPE(ESMF_TypeKind_Flag) :: DATATYPE -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** We must clean the surface-related variables. If the parent -!*** sends gridpoint data relevant for land but the nest reads its -!*** sea mask and the gridpoint is a water point then the nest -!*** will search for its own nearest water point and use that point's -!*** values for the variable at the conflict point. Conversely if the -!*** parent sends gridpoint data relevant for water but the nest reads -!*** its sea mask and the gridpoint is land then the nest will search -!*** for its own nearest land point that has land surface values and -!*** use those at the conflict point. -! -!*** This work could not be done earlier during the execution of the -!*** fields_h loop in subroutine UPDATE_INTERIOR_FROM_PARENT because -!*** the H-pt variables specified for updates after a domain moves -!*** are not listed in any particular order and thus all updates -!*** from the parent must be complete before this clean up can begin. -! -!*** NOTE: The calls to SEARCH_NEAR are being excluded temporarily -! in order to ensure identical answers in moving nests -! in the simplest manner for different task layouts. -!----------------------------------------------------------------------- -! - all_fields: DO N_FIELD=1,NUM_FIELDS !<-- Loop through H-pt variables again -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Again Extract Field from MOVE_BUNDLE_H" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=MOVE_BUNDLE_H & !<-- Bundle holding the H arrays for move updates - ,fieldIndex =N_FIELD & !<-- Index of the Field in the Bundle - ,field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FIX) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Again Extract Field Information" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,dimCount=NUM_DIMS & !<-- Is this Field 2-D or 3-D? - ,typekind=DATATYPE & !<-- Is the data integer or real? - ,name =FIELD_NAME & !<-- Name of the Field - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FIX) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Again Extract UPDATE_TYPE from Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(field=HOLD_FIELD & !<-- Get Attribute from this Field - ,name ='UPDATE_TYPE' & !<-- Name of the attribute to extract - ,value=UPDATE_TYPE_INT & !<-- Value of the Attribute - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FIX) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - FNAME=TRIM(FIELD_NAME) -! - IF(UPDATE_TYPE_INT==1)THEN - UPDATE_TYPE_CHAR='H' !<-- Ordinary H-pt variable - ELSEIF(UPDATE_TYPE_INT==2)THEN - UPDATE_TYPE_CHAR='L' !<-- H-pt land surface variable - ELSEIF(UPDATE_TYPE_INT==3)THEN - UPDATE_TYPE_CHAR='W' !<-- H-pt water surface variable - ELSEIF(UPDATE_TYPE_INT==4)THEN - UPDATE_TYPE_CHAR='F' !<-- H-pt variable obtained from an external file - ELSEIF(UPDATE_TYPE_INT==5)THEN - UPDATE_TYPE_CHAR='V' !<-- Ordinary V-pt variable - ENDIF -! -!----------------------------------------------------------------------- -!*** We are only interested in water/land sfc variables, albedo, -!*** and the deep ground temperature. -!----------------------------------------------------------------------- -! - IF(UPDATE_TYPE_CHAR/='W' & - .AND. & - UPDATE_TYPE_CHAR/='L' & - .AND. & - INDEX(FNAME,'ALB')==0 & - .AND. & - INDEX(FNAME,'TYP')==0 & - .AND. & - FNAME/='MXSNAL-move' & - .AND. & - FNAME/='TG-move' )THEN -! - CYCLE all_fields -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Near coastlines the parent can generate valid values for both -!*** SST and for land variables. The nest now sorts things out -!*** for each relevant variable based on its own sea mask. We -!*** consider each variable separately since their default values -!*** differ and we do not want to fill a single DO loop with many -!*** IF tests. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Consider the 2-D Integer surface variables. -!----------------------------------------------------------------------- -! - IF(NUM_DIMS==2 & - .AND. & - DATATYPE==ESMF_TYPEKIND_I4)THEN -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract 2-D Integer Sfc Array" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,localDe =0 & - ,farrayPtr=IARRAY_2D & !<-- Dummy 2-D array with Field's Integer data - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FIX) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -!--------------------- -!*** Vegetation type -!--------------------- -! - IF(FNAME=='IVGTYP-move')THEN - DO J=J_START,J_END - DO I=I_START,I_END - IF(SEA_MASK(I,J)>0.5)THEN - IARRAY_2D(I,J)=17 !<-- Set value at nest water point. - ENDIF - ENDDO - ENDDO -! - ENDIF -! -!--------------- -!*** Soil type -!--------------- -! - IF(FNAME=='ISLTYP-move')THEN - DO J=J_START,J_END - DO I=I_START,I_END - IF(SEA_MASK(I,J)>0.5)THEN - IARRAY_2D(I,J)=14 !<-- Set value at nest water point. - ENDIF - ENDDO - ENDDO -! - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Consider the 2-D Real surface variables. -!----------------------------------------------------------------------- -! - IF(NUM_DIMS==2 & - .AND. & - DATATYPE==ESMF_TYPEKIND_R4)THEN -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract 2-D Real Sfc Array" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,localDe =0 & - ,farrayPtr=ARRAY_2D & !<-- Dummy 2-D array with Field's Real data - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FIX) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -!--------- -!*** SST -!--------- -! - IF(FNAME=='SST-move')THEN - DO J=J_START,J_END - DO I=I_START,I_END -! - FOUND=.TRUE. - IF(SEA_MASK(I,J)<0.5)THEN - ARRAY_2D(I,J)=0. !<-- Set dummy value at nest land point. -! - ELSEIF(SEA_MASK(I,J)>0.5.AND.ARRAY_2D(I,J)<1.)THEN !<-- Parent sent land value to nest water point. -! - FOUND=.FALSE. -! - IF(domain_int_state%SFC_CONFLICT=='nearest')THEN - CALL SEARCH_NEAR(FNAME,SEA_MASK,I,J & - ,ILO,IHI,JLO,JHI & - ,I_START,I_END,J_START,J_END & - ,LIMITS_LO(3),LIMITS_HI(3) & - ,FOUND & - ,array_2d=ARRAY_2D ) - ENDIF -! - ENDIF -! - IF(.NOT.FOUND)THEN - ARRAY_2D(I,J)=300. !<-- Made-up sea sfc temperature - ENDIF -! - ENDDO - ENDDO -! - ENDIF -! -!----------------- -!*** Base Albedo -!----------------- -! - IF(FNAME=='ALBASE-move')THEN - DO J=J_START,J_END - DO I=I_START,I_END -! - FOUND=.TRUE. - IF(SEA_MASK(I,J)>0.5)THEN - ARRAY_2D(I,J)=0.06 !<-- Set value at nest water point. - ENDIF -! - ENDDO - ENDDO -! - ENDIF -! -!-------------------- -!*** Dynamic Albedo -!-------------------- -! - IF(FNAME=='ALBEDO-move')THEN - DO J=J_START,J_END - DO I=I_START,I_END -! - FOUND=.TRUE. - IF(SEA_MASK(I,J)>0.5)THEN - ARRAY_2D(I,J)=0.06 !<-- Set water value at nest water point. -! - ELSEIF(SEA_MASK(I,J)<0.5)THEN - CHECK=ABS(ARRAY_2D(I,J)-0.06) - IF(CHECK<1.E-5)THEN !<-- Parent sent water value to nest land point. -! - FOUND=.FALSE. -! - IF(domain_int_state%SFC_CONFLICT=='nearest')THEN - CALL SEARCH_NEAR(FNAME,SEA_MASK,I,J & - ,ILO,IHI,JLO,JHI & - ,I_START,I_END,J_START,J_END & - ,LIMITS_LO(3),LIMITS_HI(3) & - ,FOUND & - ,array_2d=ARRAY_2D ) - ENDIF -! - ENDIF -! - ENDIF -! - IF(.NOT.FOUND)THEN - ARRAY_2D(I,J)=0.25 !<-- Made-up albedo over land - ENDIF -! - ENDDO - ENDDO -! - ENDIF -! -!----------------------------- -!*** Deep ground temperature -!----------------------------- -! - IF(FNAME=='TG-move')THEN - DO J=J_START,J_END - DO I=I_START,I_END -! - IF(SEA_MASK(I,J)>0.5)THEN - ARRAY_2D(I,J)=273.16 !<-- Set water value at nest water point. - ENDIF -! - ENDDO - ENDDO -! - ENDIF -! -!------------ -!*** MXSNAL -!------------ -! - IF(FNAME=='MXSNAL-move')THEN - DO J=J_START,J_END - DO I=I_START,I_END -! - IF(SEA_MASK(I,J)>0.5)THEN - ARRAY_2D(I,J)=0.08 !<-- Set water value at nest water point. - ENDIF -! - ENDDO - ENDDO -! - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Consider the 3-D Real surface variables. -!----------------------------------------------------------------------- -! - IF(NUM_DIMS==3 & - .AND. & - DATATYPE==ESMF_TYPEKIND_R4)THEN -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract 3-D Real Sfc Array" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,localDe =0 & - ,farrayPtr =ARRAY_3D & !<-- Dummy 2-D array with Field's Real data - ,totalLBound=LIMITS_LO & !<-- Starting index in each dimension - ,totalUBound=LIMITS_HI & !<-- Ending index in each dimension - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FIX) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!--------- -!*** STC -!--------- -! - IF(FNAME=='STC-move')THEN - DO J=J_START,J_END - DO I=I_START,I_END -! - FOUND=.TRUE. - IF(SEA_MASK(I,J)>0.5)THEN - DO K=LIMITS_LO(3),LIMITS_HI(3) - ARRAY_3D(I,J,K)=273.16 !<-- Set dummy value at nest water point. - ENDDO -! - ELSEIF(SEA_MASK(I,J)<0.5)THEN - CHECK=ABS(ARRAY_3D(I,J,1)-273.16) - IF(CHECK<1.E-2)THEN !<-- Parent sent water value to nest land point. -! - FOUND=.FALSE. -! - IF(domain_int_state%SFC_CONFLICT=='nearest')THEN - CALL SEARCH_NEAR(FNAME,SEA_MASK,I,J & - ,ILO,IHI,JLO,JHI & - ,I_START,I_END,J_START,J_END & - ,LIMITS_LO(3),LIMITS_HI(3) & - ,FOUND & - ,array_3d=ARRAY_3D ) - ENDIF -! - ENDIF -! - ENDIF -! - IF(.NOT.FOUND)THEN - DO K=LIMITS_LO(3),LIMITS_HI(3) - ARRAY_3D(I,J,K)=285.+K*2. !<-- Made-up soil temperature - ENDDO - ENDIF -! - ENDDO - ENDDO -! - ENDIF -! -!-------------- -!*** SMC/SH2O -!-------------- -! - IF(FNAME=='SMC-move'.OR.FNAME=='SH2O-move')THEN - DO J=J_START,J_END - DO I=I_START,I_END -! - FOUND=.TRUE. - IF(SEA_MASK(I,J)>0.5)THEN - DO K=LIMITS_LO(3),LIMITS_HI(3) - ARRAY_3D(I,J,K)=1.0 !<-- Set dummy value at nest water point. - ENDDO -! - ELSEIF(SEA_MASK(I,J)<0.5.AND.ARRAY_3D(I,J,1)>0.9)THEN !<-- Parent sent water value to nest land point. -! -!*** Temporary exclusion of SEARCH_NEAR - FOUND=.FALSE. -! - IF(domain_int_state%SFC_CONFLICT=='nearest')THEN - CALL SEARCH_NEAR(FNAME,SEA_MASK,I,J & - ,ILO,IHI,JLO,JHI & - ,I_START,I_END,J_START,J_END & - ,LIMITS_LO(3),LIMITS_HI(3) & - ,FOUND & - ,array_3d=ARRAY_3D ) - ENDIF -! - ENDIF -! - IF(.NOT.FOUND)THEN - DO K=LIMITS_LO(3),LIMITS_HI(3) - ARRAY_3D(I,J,K)=0.2 !<-- Made-up soil moisture - ENDDO - ENDIF -! - ENDDO - ENDDO -! - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -! - CYCLE all_fields -! -!----------------------------------------------------------------------- -! - ENDDO all_fields -! -!----------------------------------------------------------------------- -! - END SUBROUTINE FIX_SFC -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE SEARCH_NEAR(FNAME,SEA_MASK,I_IN,J_IN & - ,ILO,IHI,JLO,JHI & - ,I_START,I_END,J_START,J_END & - ,KLO,KHI & - ,FOUND & - ,ARRAY_2D & - ,ARRAY_3D ) -! -!----------------------------------------------------------------------- -!*** Search for nearest points to given conflict points on a nest -!*** after it has moved. The search begins at the point nearest to -!*** the one in question then moves increasingly farther away. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: I_IN,J_IN & !<-- The conflict point - ,I_START,I_END,J_START,J_END & !<-- Limits of nest update region by parent - ,ILO,IHI,JLO,JHI & !<-- Nest subdomain dimensions - ,KHI,KLO !<-- Vertical dimension limits of 3-D soil arrays -! - REAL(kind=KFPT),DIMENSION(ILO:IHI,JLO:JHI),INTENT(IN) :: SEA_MASK !<-- Nest's sea mask (1=>water) -! - CHARACTER(len=*),INTENT(IN) :: FNAME !<-- Name of the variable being considered -! - LOGICAL(kind=KLOG),INTENT(OUT) :: FOUND !<-- Was a valid point found by the search? -! - REAL(kind=KFPT),DIMENSION(ILO:IHI,JLO:JHI),INTENT(INOUT) & - ,OPTIONAL :: ARRAY_2D !<-- 2-D land/water array to repair -! - REAL(kind=KFPT),DIMENSION(ILO:IHI,JLO:JHI,KLO:KHI),INTENT(INOUT) & !<-- 3-D soil array to repair - ,OPTIONAL :: ARRAY_3D -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: I1,I2,J1,J2 -! - INTEGER(kind=KINT) :: I_SEARCH,J_SEARCH,K,N_SEARCH -! - REAL(kind=KFPT) :: CHECK -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - FOUND=.FALSE. -! - I1=ILO+solver_int_state%NHALO !<-- Local integration - I2=IHI-solver_int_state%NHALO ! limits of this - J1=JLO+solver_int_state%NHALO ! task's subdomain. - J2=JHI-solver_int_state%NHALO !<-- -! -!----------------------------------------------------------------------- -!*** If the given nest point following the move is a water point -!*** based on the nest's reading its own sea mask but the value -!*** from the parent is a land value then the nest searches for -!*** its nearest legitimate water value and gives that to the point -!*** in question. -!----------------------------------------------------------------------- -! -!--------- -!*** SST -!--------- -! - IF(FNAME=='SST-move')THEN -! - DO N_SEARCH=2,N_PTS_SEARCH - I_SEARCH=I_IN+I_SEARCH_INC(N_SEARCH) - J_SEARCH=J_IN+J_SEARCH_INC(N_SEARCH) -! - IF(I_SEARCHI2 & !<-- Keep the search on the task subdomain - .OR. & ! - J_SEARCHJ2)CYCLE !<-- -! - IF(ARRAY_2D(I_SEARCH,J_SEARCH)>1.)THEN !<-- If true, the nest found its own nearest water point - ARRAY_2D(I_IN,J_IN)=ARRAY_2D(I_SEARCH,J_SEARCH) - FOUND=.TRUE. - EXIT - ENDIF -! - ENDDO -! - ENDIF -! -!----------------------------------------------------------------------- -!*** If the given nest point following the move is a land point -!*** based on the nest's reading its own sea mask but the value -!*** from the parent is a water value then the nest searches for -!*** its nearest legitimate land value and gives that to the point -!*** in question. The varying dummy values for the different land -!*** variables forces individual searches. -!----------------------------------------------------------------------- -! -!--------- -!*** STC -!--------- -! - IF(FNAME=='STC-move')THEN -! - DO N_SEARCH=2,N_PTS_SEARCH - I_SEARCH=I_IN+I_SEARCH_INC(N_SEARCH) - J_SEARCH=J_IN+J_SEARCH_INC(N_SEARCH) -! - IF(I_SEARCHI2 & !<-- Keep the search on the task subdomain - .OR. & ! - J_SEARCHJ2)CYCLE !<-- -! - CHECK=ABS(ARRAY_3D(I_SEARCH,J_SEARCH,1)-273.16) -! - IF(CHECK>1.E-2)THEN !<-- Make sure the search point has a valid land value - DO K=KLO,KHI - ARRAY_3D(I_IN,J_IN,K)=ARRAY_3D(I_SEARCH,J_SEARCH,K) - ENDDO - FOUND=.TRUE. - EXIT - ENDIF -! - ENDDO -! - ENDIF -! -!-------------- -!*** SMC/SH2O -!-------------- -! - IF(FNAME=='STC-move'.OR.FNAME=='SH2O-move')THEN -! - DO N_SEARCH=2,N_PTS_SEARCH - I_SEARCH=I_IN+I_SEARCH_INC(N_SEARCH) - J_SEARCH=J_IN+J_SEARCH_INC(N_SEARCH) -! - IF(I_SEARCHI2 & !<-- Keep the search on the task subdomain - .OR. & ! - J_SEARCHJ2)CYCLE !<-- -! - IF(ARRAY_3D(I_SEARCH,J_SEARCH,1)<0.9)THEN !<-- Make sure the search point has a valid land value - DO K=KLO,KHI - ARRAY_3D(I_IN,J_IN,K)=ARRAY_3D(I_SEARCH,J_SEARCH,K) - ENDDO - FOUND=.TRUE. - EXIT - ENDIF -! - ENDDO -! - ENDIF -! -!------------ -!*** Albedo -!------------ -! - IF(FNAME=='ALBEDO-move')THEN -! - DO N_SEARCH=2,N_PTS_SEARCH - I_SEARCH=I_IN+I_SEARCH_INC(N_SEARCH) - J_SEARCH=J_IN+J_SEARCH_INC(N_SEARCH) -! - IF(I_SEARCHI2 & !<-- Keep the search on the task subdomain - .OR. & ! - J_SEARCHJ2)CYCLE !<-- -! - CHECK=ABS(ARRAY_2D(I_SEARCH,J_SEARCH)-0.06) -! - IF(CHECK>1.E-2)THEN !<-- Make sure the search point has a valid land value - ARRAY_2D(I_IN,J_IN)=ARRAY_2D(I_SEARCH,J_SEARCH) - FOUND=.TRUE. - EXIT - ENDIF -! - ENDDO -! - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE SEARCH_NEAR -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE SEARCH_INIT -! -!----------------------------------------------------------------------- -!*** Generate I and J increments from any given point to all other -!*** points surrounding it in a square of given width based on the -!*** distances from the central point ranging from smallest to -!*** largest distance. -!----------------------------------------------------------------------- -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: KOUNT=0 -! - INTEGER(kind=KINT) :: I,I_CENTER,ISTAT,J,J_CENTER & - ,N_WIDTH,RC -! - TYPE(DIST),POINTER :: LARGE=>NULL() & - ,SMALL=>NULL() & - ,PTR =>NULL() & - ,PTR1 =>NULL() & - ,PTR2 =>NULL() & - ,PTRX =>NULL() -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - N_WIDTH=2*N_PTS_SEARCH_WIDTH+1 !<-- Width of the search region - I_CENTER=N_PTS_SEARCH_WIDTH+1 !<-- Relative I at the center of the search region - J_CENTER=N_PTS_SEARCH_WIDTH+1 !<-- Relative J at the center of the search region -! - SMALL=>SMALLX(MY_DOMAIN_ID) - LARGE=>LARGEX(MY_DOMAIN_ID) -! -!----------------------------------------------------------------------- -! - DO J=1,N_WIDTH - DO I=1,N_WIDTH -! -!----------------------------------------------------------------------- -!*** We must allocate a pointer to each gridpoint in the search. -!----------------------------------------------------------------------- -! - ALLOCATE(PTR,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate search pointer stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT & - ,rc =RC) - ENDIF -! -!----------------------------------------------------------------------- -!*** Compute the distance from the center point to all of the other -!*** points in the square. We are not accounting for a map projection -!*** at this time. -!----------------------------------------------------------------------- -! - PTR%I_INC=I-I_CENTER - PTR%J_INC=J-J_CENTER - PTR%VALUE=SQRT(REAL(PTR%I_INC*PTR%I_INC & - +PTR%J_INC*PTR%J_INC)) -! -!----------------------------------------------------------------------- -!*** Sort the distances to each point in the square as they are -!*** computed going from smallest to largest. -!----------------------------------------------------------------------- -! - new_val: IF(I==1.AND.J==1)THEN !<-- 1st value is both smallest/largest - SMALL=>PTR - LARGE=>SMALL - NULLIFY(PTR%NEXT_VALUE) -! - ELSE !<-- All subsequent values -! - IF(PTR%VALUESMALL - SMALL=>PTR -! - ELSEIF(PTR%VALUE>=LARGE%VALUE)THEN !<-- New value same or larger than previous largest - LARGE%NEXT_VALUE=>PTR - LARGE=>PTR - NULLIFY(LARGE%NEXT_VALUE) -! - ELSE !<-- New value between current smallest and largest - PTR1=>SMALL - PTR2=>PTR1%NEXT_VALUE -! - search:DO !<-- Find new value's proper place in the list -! - IF(PTR%VALUE>=PTR1%VALUE.AND.PTR%VALUEPTR2 - PTR1%NEXT_VALUE=>PTR - EXIT search - ENDIF -! - PTR1=>PTR2 - PTR2=>PTR2%NEXT_VALUE -! - ENDDO search -! - ENDIF -! - ENDIF new_val -! - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** We now have all the distances from the central point in order -!*** from smallest to largest. Fill the 1-D index increment arrays -!*** for I and J that will allow the search to go from the smallest -!*** distance to the largest when those arrays are stepped through. -!*** As the index increments to each gridpoint are stored we can -!*** deallocate the pointer to that gridpoint since it is no -!*** longer needed. -!----------------------------------------------------------------------- -! - PTR=>SMALL !<-- Begin with the nearest gridpoint - KOUNT=0 -! - DO - KOUNT=KOUNT+1 - IF(.NOT.ASSOCIATED(PTR))EXIT -! WRITE(0,23331)KOUNT,PTR%VALUE -23331 FORMAT(' Value #',I6,' is ',F10.6) - I_SEARCH_INC(KOUNT)=PTR%I_INC !<-- Store the increments of I and J to the next - J_SEARCH_INC(KOUNT)=PTR%J_INC ! gridpoint in the distance list. - PTRX=>PTR - PTR=>PTR%NEXT_VALUE !<-- Proceed to the next gridpoint further away - DEALLOCATE(PTRX) !<-- Deallocate the previous gridpoint's pointer - ENDDO -! -!----------------------------------------------------------------------- -! - END SUBROUTINE SEARCH_INIT -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE RESET_SFC_VARS(SFC_FILE_RATIO & - ,GLAT_H & - ,GLON_H & - ,MOVE_BUNDLE) -! -!----------------------------------------------------------------------- -!*** If the parent initialized this moving nest from the parent's -!*** own initial state then the nest will now reinitialize those -!*** 2-D sfc fields that are constant in time and that the nest -!*** reads from external files for data replacement in parent -!*** update regions during the integration. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: SFC_FILE_RATIO !<-- Ratio of upper parent grid increment to this domain's -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: GLAT_H & !<-- Geographic latitude (radians) at H pts on nest domain. - ,GLON_H !<-- Geographic longitude (radians) at H pts on nest domain. -! - TYPE(ESMF_FieldBundle),INTENT(INOUT) :: MOVE_BUNDLE -! -!--------------------- -!*** Local variables -!--------------------- -! - INTEGER(kind=KINT),SAVE :: I_OFFSET,J_OFFSET -! - INTEGER(kind=KINT) :: I,I_CORNER,IEND,ILOC & - ,INPUT_NEST,ISTART,ITE_X & - ,J,J_CORNER,JEND,JSTART,JTE_Y & - ,N_FIELD,N_REMOVE,NN,NUM_FIELDS & - ,UPDATE_TYPE_INT -! - INTEGER(kind=KINT) :: I_COUNT_DATA,I_START_DATA & - ,J_COUNT_DATA,J_START_DATA & - ,NCID,NCTYPE,NDIMS,VAR_ID -! - INTEGER(kind=KINT) :: IERR,RC,RC_RES -! - INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: IARRAY_2D=>NULL() -! - INTEGER(kind=KINT),DIMENSION(1:2) :: DIM_IDS -! - REAL(kind=KFPT) :: GBL,REAL_I,REAL_J -! - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ARRAY_2D=>NULL() -! - CHARACTER(len=2) :: ID_SFC_FILE - CHARACTER(len=15) :: VNAME - CHARACTER(len=99) :: FIELD_NAME,FILENAME -! - LOGICAL(kind=KLOG),SAVE :: FIRST=.TRUE. - LOGICAL(kind=KLOG) :: OPENED -! - TYPE(ESMF_Field) :: HOLD_FIELD - TYPE(ESMF_TypeKind_Flag) :: DATATYPE -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - IF(GLOBAL_TOP_PARENT)THEN - GBL=1. - ELSE - GBL=0. - ENDIF -! -!----------------------------------------------------------------------- -!*** The nest uses its GLAT and GLON to determine exactly where it -!*** lies on the uppermost parent grid and thus where its grid lies -!*** within the nest-resolution sfc data in the external file. -!*** Find the I,J on the uppermost parent grid on which the SW corner -!*** of this nest task lies. -!----------------------------------------------------------------------- -! - I_CORNER=MAX(IMS,IDS)+GBL !<-- Nest task halos are covered with data - J_CORNER=MAX(JMS,JDS)+GBL ! -! - CALL LATLON_TO_IJ(GLAT_H(I_CORNER,J_CORNER) & !<-- Geographic latitude of nest task subdomain SW corner - ,GLON_H(I_CORNER,J_CORNER) & !<-- Geographic longitude of nest task subdomain SW corner - ,TPH0_1,TLM0_1 & !<-- Central lat/lon (radians, N/E) of uppermost parent - ,SB_1,WB_1 & !<-- Rotated lat/lon of upper parent's S/W bndry (radians, N/E) - ,RECIP_DPH_1,RECIP_DLM_1 & !<-- Reciprocal of I/J grid increments (radians) on upper parent - ,GLOBAL_TOP_PARENT & !<-- Is the uppermost daomin on a global grid? - ,REAL_I & !<-- Corresponding I index on uppermost parent grid - ,REAL_J) -! - I_OFFSET=NINT((REAL_I-1.-GBL)*SFC_FILE_RATIO) !<-- Offset in I between sfc file index and nest index - J_OFFSET=NINT((REAL_J-1.-GBL)*SFC_FILE_RATIO) !<-- Offset in J between sfc file index and nest index -! - ITE_X =MIN(IME,IDE) !<-- Last task point to update in I - I_START_DATA=I_OFFSET+1 !<-- Start reading at this I in external data array - I_COUNT_DATA=ITE_X-I_CORNER+1 !<-- # of points to read in I -! - JTE_Y =MIN(JME,JDE) !<-- Last task point to update in J - J_START_DATA=J_OFFSET+1 !<-- Start reading at this J in external data array - J_COUNT_DATA=JTE_Y-J_CORNER+1 !<-- # of points to read in J -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="How many Fields in the Move_Bundle?" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=MOVE_BUNDLE & !<-- Bundle holding the arrays for move updates - ,fieldCount =NUM_FIELDS & !<-- # of Fields in this Bundle - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RES) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Loop through this Bundles's Fields and replace the values of -!*** those that are associated with the external nest-resolution -!*** surface data files. -!----------------------------------------------------------------------- -! - field_loop: DO N_FIELD=1,NUM_FIELDS -! -!----------------------------------------------------------------------- -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=MOVE_BUNDLE & !<-- Bundle holding the arrays for move updates - ,fieldIndex =N_FIELD & !<-- Index of the Field in the Bundle - ,field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RES) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,typeKind=DATATYPE & !<-- Does this Field contain an integer or real array? - ,name =FIELD_NAME & !<-- The name of the Field - ,rc =RC ) -! - N_REMOVE=INDEX(FIELD_NAME,SUFFIX_MOVE) - FIELD_NAME=FIELD_NAME(1:N_REMOVE-1) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="RESET_SFC_VARS: Extract UPDATE_TYPE from Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(field=HOLD_FIELD & !<-- Get Attribute from this Field - ,name ='UPDATE_TYPE' & !<-- Name of the attribute to extract - ,value=UPDATE_TYPE_INT & !<-- Value of the Attribute - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RES) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** If this Field has data in an external sfc file then open the file. -!----------------------------------------------------------------------- -! - filedata: IF(UPDATE_TYPE_INT==4)THEN !<-- This means the variable has an external file -! -!----------------------------------------------------------------------- -! - IF(SFC_FILE_RATIO<=9)THEN - WRITE(ID_SFC_FILE,'(I1.1)')SFC_FILE_RATIO - ELSEIF(SFC_FILE_RATIO>=10)THEN - WRITE(ID_SFC_FILE,'(I2.2)')SFC_FILE_RATIO - ENDIF -! - FILENAME=TRIM(FIELD_NAME)//'_'//TRIM(ID_SFC_FILE)//'.nc' -! - CALL CHECK(NF90_OPEN(FILENAME,NF90_NOWRITE,NCID)) !<-- Open the current field's external netCDF file. -! -!----------------------------------------------------------------------- -!*** Extract the array from the Field. -!----------------------------------------------------------------------- -! -!---------- -!*** Real -!---------- -! - IF(DATATYPE==ESMF_TYPEKIND_R4)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="RESET_SFC_VARS: Extract 2-D Real Array for Type F" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,localDe =0 & - ,farrayPtr=ARRAY_2D & !<-- Dummy 2-D array with Field's Real data - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RES) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL CHECK(NF90_INQUIRE_VARIABLE(NCID,3,VNAME,NCTYPE & - ,NDIMS,DIM_IDS)) - CALL CHECK(NF90_INQ_VARID(NCID,VNAME,VAR_ID)) -! - CALL CHECK(NF90_GET_VAR(NCID,VAR_ID & !<-- Extract the desired real values from the - ,ARRAY_2D(I_CORNER:ITE_X,J_CORNER:JTE_Y) & ! current field's external file. - ,start=(/I_START_DATA,J_START_DATA/) & ! Nest points that have moved beyond the - ,count=(/I_COUNT_DATA,J_COUNT_DATA/))) ! pre-move footprint are updated. -! -!------------- -!*** Integer -!------------- -! - ELSEIF(DATATYPE==ESMF_TYPEKIND_I4)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="RESET_SFC_VARS: Extract 2-D Integer Array for Type F" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,localDe =0 & - ,farrayPtr=IARRAY_2D & !<-- Dummy 2-D array with Field's Real data - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RES) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL CHECK(NF90_INQUIRE_VARIABLE(NCID,3,VNAME,NCTYPE & - ,NDIMS,DIM_IDS)) - CALL CHECK(NF90_INQ_VARID(NCID,VNAME,VAR_ID)) -! - CALL CHECK(NF90_GET_VAR(NCID,VAR_ID & !<-- Extract the desired integer values from the - ,IARRAY_2D(I_CORNER:ITE_X,J_CORNER:JTE_Y) & ! current field's external file. - ,start=(/I_START_DATA,J_START_DATA/) & ! Nest points that have moved beyond the - ,count=(/I_COUNT_DATA,J_COUNT_DATA/))) ! pre-move footprint are updated. -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Read the appropriate section of the external data to reset the -!*** values of this sfc variable from those that were originally -!*** interpolated from the parent. -!----------------------------------------------------------------------- -! - CALL CHECK(NF90_CLOSE(NCID)) !<-- Close the external netCDF file. -! -!----------------------------------------------------------------------- -! - ENDIF filedata -! - CALL CHECK(NF90_CLOSE(NCID)) !<-- Close the external netCDF file. -! -!----------------------------------------------------------------------- -! - ENDDO field_loop -! -!----------------------------------------------------------------------- -! - END SUBROUTINE RESET_SFC_VARS -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - END MODULE module_DOMAIN_GRID_COMP -! -!----------------------------------------------------------------------- diff --git a/src/nmm/module_DOMAIN_INTERNAL_STATE.F90 b/src/nmm/module_DOMAIN_INTERNAL_STATE.F90 deleted file mode 100644 index 09585e3..0000000 --- a/src/nmm/module_DOMAIN_INTERNAL_STATE.F90 +++ /dev/null @@ -1,168 +0,0 @@ -!--------------------------------------------------------------------------- -! - MODULE MODULE_DOMAIN_INTERNAL_STATE -! -!--------------------------------------------------------------------------- -!*** Define all quantities that lie within the DOMAIN component's -!*** internal state. -!--------------------------------------------------------------------------- -! - USE ESMF -! - USE module_KINDS -! - USE MODULE_DERIVED_TYPES,ONLY: MIXED_DATA -! -!--------------------------------------------------------------------------- -! - IMPLICIT NONE -! -!--------------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: DOMAIN_INTERNAL_STATE & - ,WRAP_DOMAIN_INTERNAL_STATE -! -!--------------------------------------------------------------------------- -! - TYPE DOMAIN_INTERNAL_STATE -! -!--------------------------------------------------------------------------- -! - INTEGER(kind=KINT) :: KOUNT_TIMESTEPS & - ,SFC_FILE_RATIO !<-- Ratio of upper parent's grid increment to this domain's -! - INTEGER(kind=KINT) :: LEAD_TASK_DOMAIN & !<-- The first task on a given domain - ,NUM_PES_FCST !<-- The number of forecast tasks -! - INTEGER(kind=KINT),DIMENSION(1:9) :: HANDLE_SEND_INTER_INT & !<-- For ISSends of intertask integer data after domain shifts - ,HANDLE_SEND_INTER_REAL !<-- For ISSends of intertask real data after domain shifts -! - TYPE(ESMF_GridComp),ALLOCATABLE,DIMENSION(:) :: DOMAIN_CHILD_COMP !<-- DOMAIN components of child domains -! - TYPE(ESMF_GridComp) :: SOLVER_GRID_COMP !<-- The Solver gridded component -! - TYPE(ESMF_State) :: IMP_STATE_SOLVER !<-- The import state of the Solver component - TYPE(ESMF_State) :: IMP_STATE_WRITE !<-- The import state of the write components -! - TYPE(ESMF_State) :: EXP_STATE_SOLVER !<-- The export state of the Solver component - TYPE(ESMF_State) :: EXP_STATE_WRITE !<-- The export state of the write components -! - TYPE(ESMF_Alarm) :: ALARM_HISTORY & !<-- The ESMF Alarm for history output - ,ALARM_RESTART & !<-- The ESMF Alarm for restart output - ,ALARM_CLOCKTIME !<-- The ESMF Alarm for clocktime prints -! - REAL(ESMF_KIND_R8) :: TIMESTEP_FINAL !<-- The forecast's final timestep -! - LOGICAL(kind=KLOG) :: ALLCLEAR_FROM_PARENT & !<-- Child can proceed after parent is free - ,I_AM_A_NEST & !<-- Am I in a nested domain? - ,I_AM_A_PARENT & !<-- Am I in a parent domain? - ,MY_DOMAIN_MOVES & !<-- Does this domain move? - ,RECV_ALL_CHILD_DATA !<-- Parent is free after all 2-way data recvd -! - LOGICAL(kind=KLOG) :: FIRST_PASS & !<-- Note 1st time into NMM_INTEGRATE - ,RESTARTED_RUN & !<-- Is this a restarted forecast? - ,RESTARTED_RUN_FIRST & !<-- Is is time for the initial output in a restarted run? - ,TS_INITIALIZED -! - CHARACTER(len=7) :: SFC_CONFLICT !<-- Do/not search for nearest point with same sfc type -! - TYPE(MIXED_DATA),DIMENSION(1:9) :: SHIFT_DATA !<-- Intertask shift data on the pre-move footprint -! - TYPE(ESMF_FieldBundle) :: BUNDLE_NESTBC !<-- ESMF Bundle of BC update variables (parent to child) -! - TYPE(ESMF_FieldBundle) :: BUNDLE_2WAY !<-- ESMF Bundle of 2-way exchange vbls (child to parent) -! - TYPE(ESMF_FieldBundle) :: MOVE_BUNDLE_H & !<-- ESMF Bundle of update H variables on moving nests - ,MOVE_BUNDLE_V !<-- ESMF Bundle of update V variables on moving nests -! -!--------------------------------------------------------------------------- -!*** The following are specific to asynchronous quilting/writing. -!--------------------------------------------------------------------------- -! - LOGICAL(kind=KLOG) :: QUILTING & !<-- Is the user selecting asynchronous quilting/writing? - ,WRITE_LAST_RESTART & !<-- Shall we write last restart file - ,WROTE_1ST_HIST !<-- Has 1st history output been written? -! - TYPE(ESMF_GridComp),DIMENSION(:),POINTER :: WRITE_COMPS !<-- The array of Write gridded components -! - INTEGER(kind=KINT) :: WRITE_GROUPS & !<-- The number of write groups - ,WRITE_GROUP_READY_TO_GO & !<-- The active group of write tasks - ,WRITE_TASKS_PER_GROUP !<-- The number of write tasks in each write group -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: LOCAL_ISTART,LOCAL_IEND & !<-- The local I limits of the forecast tasks - ,LOCAL_JSTART,LOCAL_JEND & !<-- The local J limits of the forecast tasks - ,PETLIST_FCST !<-- Task ID list of fcst tasks on the domain -! - INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: PETLIST_WRITE !<-- Task ID list of fcst tasks w/ write tasks by group -! -!--------------------------------------------------------------------------- -!*** The following are specific to digital filtering. -!--------------------------------------------------------------------------- -! - INTEGER(kind=KINT) :: KSTEP,NSTEP -! - INTEGER(kind=KINT) :: NUM_FIELDS_FILTER_2D & - ,NUM_FIELDS_FILTER_3D & - ,NUM_FIELDS_RESTORE_2D & - ,NUM_FIELDS_RESTORE_3D -! - REAL(kind=KFPT) :: TOTALSUM -! - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: SAVE_2D,SAVE_2D_PHYS - REAL(kind=KFPT),DIMENSION(:,:,:,:),POINTER :: SAVE_3D,SAVE_3D_PHYS -! - REAL(kind=KFPT),DIMENSION(:),POINTER :: DOLPH_WGTS(:) -! - LOGICAL(kind=KLOG) :: FIRST_FILTER -! - TYPE(ESMF_FieldBundle) :: FILT_BUNDLE_FILTER & !<-- ESMF Bundle of variables to filter - ,FILT_BUNDLE_RESTORE !<-- ESMF Bundle of variables to restore to pre-filtered state -! -!--------------------------------------------------------------------------- -!*** The following are used to transmit fields to/from an external -!*** ocean model via NUOPC coupling. -!--------------------------------------------------------------------------- -! - INTEGER(kind=KINT) :: KOUNT_NPRECIP,KOUNT_NPHS -! -!--------------------- -!*** Imported fields -!--------------------- -! - REAL(ESMF_KIND_R8),DIMENSION(:,:),POINTER :: SST_COUPLED !<-- SST (K) -! -!--------------------- -!*** Exported fields -!--------------------- -! - REAL(ESMF_KIND_R8),DIMENSION(:,:),POINTER :: INST_SFC_PRESSURE_COUPLED !<-- Instantaneous sfc pressure (Pa) - REAL(ESMF_KIND_R8),DIMENSION(:,:),POINTER :: INST_SENS_HT_FLX_COUPLED !<-- Instantaneous sensible heat flux (W m-2) - REAL(ESMF_KIND_R8),DIMENSION(:,:),POINTER :: INST_LAT_HT_FLX_COUPLED !<-- Instantaneous latent heat flux (W m-2) - REAL(ESMF_KIND_R8),DIMENSION(:,:),POINTER :: INST_NET_LW_FLX_COUPLED !<-- Instantaneous net longwave flux (W m-2) - REAL(ESMF_KIND_R8),DIMENSION(:,:),POINTER :: INST_NET_SW_FLX_COUPLED !<-- Instantaneous net shortwave flux (W m-2) - REAL(ESMF_KIND_R8),DIMENSION(:,:),POINTER :: MEAN_ZONAL_MOM_FLX_COUPLED !<-- Mean zonal mom flux (N m-2) - REAL(ESMF_KIND_R8),DIMENSION(:,:),POINTER :: MEAN_MERID_MOM_FLX_COUPLED !<-- Mean merid mom flux (N m-2) - REAL(ESMF_KIND_R8),DIMENSION(:,:),POINTER :: MEAN_PREC_RATE_COUPLED !<-- Mean precip rate (kg m-2 s-1) -! -!--------------------------------------------------------------------------- -! - END TYPE DOMAIN_INTERNAL_STATE -! -!--------------------------------------------------------------------------- -! -!--------------------------------------------------------------------------- -!*** This state is supported by C pointers but not by F90 pointers -!*** therefore we use this "WRAP". -!--------------------------------------------------------------------------- -! - TYPE WRAP_DOMAIN_INTERNAL_STATE - TYPE(DOMAIN_INTERNAL_STATE),POINTER :: DOMAIN_INT_STATE - END TYPE WRAP_DOMAIN_INTERNAL_STATE -! -!--------------------------------------------------------------------------- -! - END MODULE MODULE_DOMAIN_INTERNAL_STATE -! -!--------------------------------------------------------------------------- diff --git a/src/nmm/module_DOMAIN_NUOPC_SET.F90 b/src/nmm/module_DOMAIN_NUOPC_SET.F90 deleted file mode 100644 index a365fe9..0000000 --- a/src/nmm/module_DOMAIN_NUOPC_SET.F90 +++ /dev/null @@ -1,1528 +0,0 @@ -!----------------------------------------------------------------------- -! - MODULE MODULE_DOMAIN_NUOPC_SET -! -!----------------------------------------------------------------------- -! -!*** Create/generate/set various NUOPC-related items for an NMM domain. -! -!----------------------------------------------------------------------- -! - USE ESMF - USE NUOPC -! - USE MODULE_KINDS -! - USE MODULE_CONSTANTS,ONLY : A -! - USE module_NMM_INTERNAL_STATE,ONLY: NMM_INTERNAL_STATE & - ,WRAP_NMM_INTERNAL_STATE -! - USE module_DOMAIN_INTERNAL_STATE,ONLY: DOMAIN_INTERNAL_STATE & - ,WRAP_DOMAIN_INTERNAL_STATE -! - USE module_SOLVER_INTERNAL_STATE,ONLY: SOLVER_INTERNAL_STATE & - ,WRAP_SOLVER_INT_STATE -! - USE module_DOMAIN_TASK_SPECS,ONLY: DOMAIN_TASK_SPECS -! - USE module_CPLFIELDS,ONLY: exportFieldsList,importFieldsList & - ,nExportFields,nImportFields & - ,queryFieldList -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: CONNECT_EXPORT_FIELDS & - ,CONNECT_IMPORT_FIELDS & - ,DOMAIN_DESCRIPTORS & - ,I_AM_ROOT & - ,I_AM_PET & - ,DUMP_DOMAIN_DESCRIPTOR & - ,DUMP_DOMAIN_DESCRIPTORS & - ,NMMB_CreateDomainFields & - ,NMMB_CreateRouteHandle & - ,NMMB_GridCreate & - ,NMMB_GridUpdate & - ,NMMB_RegridExport & - ,NMMB_RegridImport & - ,ROTANGLE_CELLAREA_SEAMASK -! -!----------------------------------------------------------------------- -! - TYPE(DOMAIN_TASK_SPECS),DIMENSION(:),POINTER,SAVE :: & - DOMAIN_DESCRIPTORS !<-- Object holding basic task info for coupling -! -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - FUNCTION NMMB_GridCreate(nestingDomainGridcompIndex & - ,DOMAIN_GRID_COMP & - ,DOMAIN_DESCRIPTORS,TPH0D,TLM0D & - ,RC ) -! -!----------------------------------------------------------------------- -! The NMMB component always runs on the super set of processors of all -! the domains including the parent. ESMF supports a way to create a grid -! on the NMMB component that spans the entire processor list but only has -! data allocation on the given domain processor list, more specifically -! only on the computational PETs of the given domain's processor list. -! In ESMF terms, the NMMB grid for a given domain only has domain elements -! (DEs) on the given domain's processor list while the number of DE is 0 -! on all the other processors. -!----------------------------------------------------------------------- -! - ! arguments - INTEGER, INTENT(IN) :: nestingDomainGridcompIndex - TYPE(ESMF_GridComp),INTENT(IN) :: DOMAIN_GRID_COMP - REAL(kind=KFPT),INTENT(IN) :: TLM0D,TPH0D - TYPE(DOMAIN_TASK_SPECS),POINTER :: DOMAIN_DESCRIPTORS(:) - INTEGER, INTENT(OUT) :: rc - - ! return - type(ESMF_Grid) :: NMMB_GridCreate - - ! local variables - !TYPE(NMM_INTERNAL_STATE),POINTER,SAVE :: NMM_INT_STATE !<-- The NMM component internal state pointer - TYPE(WRAP_NMM_INTERNAL_STATE) :: WRAP_NMM !<-- The F90 wrap of the NMM internal state - type(ESMF_GRID) :: PGRID - type(ESMF_TypeKind_Flag) :: ctk - integer :: tcount, ldecount, dimcount, slcount, I, J, lpet, plpet - integer :: iend, istart, jend, jstart - integer :: elb(2), eub(2), clb(2), cub(2) - integer(ESMF_KIND_I4),dimension(:,:), pointer :: fptr_mask - real(kind=kdbl) :: deg2rad,dlm,dph,j_center,lam0,phi0,pi,rad2deg - real(ESMF_KIND_R8),dimension(:,:), pointer :: fptr_lat,fptr_lon - real(ESMF_KIND_R8),dimension(:,:), pointer :: fptr_area - TYPE(DOMAIN_INTERNAL_STATE),POINTER :: DOMAIN_INT_STATE - TYPE(WRAP_DOMAIN_INTERNAL_STATE) :: WRAP_DOMAIN - TYPE(SOLVER_INTERNAL_STATE),POINTER :: SOLVER_INT_STATE - TYPE(WRAP_SOLVER_INT_STATE) :: WRAP_SOLVER - type(ESMF_Field) :: sstField, sstField_nmmb - type(ESMF_State) :: pgridState - - integer :: ID_X, nElem, pGridIndexCount, deCount, DE, offset - integer :: ITS,ITE,JTS,JTE - integer :: INPES, JNPES - integer :: minIndex(2), maxIndex(2) - integer :: lDetoDeMap(0:0) ! 1LocalDE/DE/PET - integer, allocatable :: pGridIndexCountPDE(:,:) - integer, allocatable :: IndicesD1(:), IndicesD2(:) - integer, allocatable :: deBlockList(:,:,:) - integer, allocatable :: pGridArbIndexList(:,:) - type(ESMF_DistGrid) :: pdistGrid, pDistGrid_nmmb - integer, allocatable :: petMap(:) - type(ESMF_DELayout) :: delayout - type(ESMF_DistGrid) :: distgrid_nmmb - type(ESMF_Grid) :: grid_nmmb - character(4096) :: tmpstr - -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- - ! Implementation - RC = ESMF_SUCCESS - - INPES = DOMAIN_DESCRIPTORS(nestingDomainGridcompIndex)%INPES - JNPES = DOMAIN_DESCRIPTORS(nestingDomainGridcompIndex)%JNPES - - minIndex = DOMAIN_DESCRIPTORS(nestingDomainGridcompIndex)%INDX_MIN - maxIndex = DOMAIN_DESCRIPTORS(nestingDomainGridcompIndex)%INDX_MAX - - delayout = ESMF_DElayOutCreate(DOMAIN_DESCRIPTORS(nestingDomainGridcompIndex)%PET_MAP, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - distgrid_nmmb = ESMF_DistGridCreate(minIndex, maxIndex, & - regDecomp=(/INPES, JNPES/), delayout=delayout, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - !NMMB_GridCreate=ESMF_GRIDCREATE(distgrid_nmmb, coordSys=ESMF_COORDSYS_SPH_RAD, & - NMMB_GridCreate=ESMF_GRIDCREATE(distgrid_nmmb, & - indexflag=ESMF_INDEX_GLOBAL, rc=RC) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - ! Attach coordinates to the NMMB_GridCreate - ! Attach center coordinate to parent Grid - call ESMF_GridAddCoord(NMMB_GridCreate, staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - ! Attach corner coordinate to parent Grid - call ESMF_GridAddCoord(NMMB_GridCreate, staggerLoc=ESMF_STAGGERLOC_CORNER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - ! Attach cell area to NMMB Grid - call ESMF_GridAddItem(NMMB_GridCreate, itemflag=ESMF_GRIDITEM_AREA, & - staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - ! Attach cell area to NMMB Grid - call ESMF_GridAddItem(NMMB_GridCreate, itemflag=ESMF_GRIDITEM_MASK, & - staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - active: if(DOMAIN_DESCRIPTORS(nestingDomainGridcompIndex)%TASK_ACTIVE) then - - CALL ESMF_GridCompGetInternalState(DOMAIN_GRID_COMP & - ,WRAP_DOMAIN & - ,RC) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - DOMAIN_INT_STATE=>wrap_domain%DOMAIN_INT_STATE - - CALL ESMF_GridCompGetInternalState(domain_int_state%SOLVER_GRID_COMP, & - WRAP_SOLVER, RC) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - SOLVER_INT_STATE=>wrap_solver%INT_STATE - -!----------------------------------------------------------------------- -!*** Compute/save the wind rotation angles (grid to earth), grid cell -!*** areas, and sea mask for the given domain. -!----------------------------------------------------------------------- -! - ITS=solver_int_state%ITS - ITE=solver_int_state%ITE - JTS=solver_int_state%JTS - JTE=solver_int_state%JTE -! - ID_X=nestingDomainGridcompIndex -! - CALL ROTANGLE_CELLAREA_SEAMASK(SOLVER_INT_STATE & - ,ITS,ITE,JTS,JTE & - ,DOMAIN_DESCRIPTORS(ID_X)%ROT_ANGLE & - ,DOMAIN_DESCRIPTORS(ID_X)%CELL_AREA & - ,DOMAIN_DESCRIPTORS(ID_X)%SEA_MASK ) - - ! Define cell area - call ESMF_GridGetItem(NMMB_GridCreate, itemflag=ESMF_GRIDITEM_AREA, & - staggerLoc=ESMF_STAGGERLOC_CENTER, & - localDe=0, farrayPtr=fptr_area, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - DOMAIN_DESCRIPTORS(nestingDomainGridcompIndex)%NEST_CELL_AREA => fptr_area - fptr_area = DOMAIN_DESCRIPTORS(nestingDomainGridcompIndex)%CELL_AREA - - ! Define cell mask - call ESMF_GridGetItem(NMMB_GridCreate, itemflag=ESMF_GRIDITEM_MASK, & - staggerLoc=ESMF_STAGGERLOC_CENTER, & - localDe=0, farrayPtr=fptr_mask, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - DOMAIN_DESCRIPTORS(nestingDomainGridcompIndex)%NEST_SEA_MASK => fptr_mask - fptr_mask = DOMAIN_DESCRIPTORS(nestingDomainGridcompIndex)%SEA_MASK - - offset = 0 - - ! Define Center longitude - call ESMF_GridGetCoord(NMMB_GridCreate, coordDim=1, & - staggerLoc=ESMF_STAGGERLOC_CENTER, & - localDe=0, farrayPtr=fptr_lon, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - ! Save a reference so moving nest can update the coordinate values - DOMAIN_DESCRIPTORS(nestingDomainGridcompIndex)%NEST_GLON => fptr_lon - - write(tmpstr, *) 'minIndex= ', minIndex - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - write(tmpstr, *) 'maxIndex= ', maxIndex - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - write(tmpstr, *) 'ITS= ', solver_int_state%ITS - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - write(tmpstr, *) 'ITE= ', solver_int_state%ITE - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - write(tmpstr, *) 'JTS= ', solver_int_state%JTS - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - write(tmpstr, *) 'JTE= ', solver_int_state%JTE - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - write(tmpstr, *) 'shape fptr_lon: ', lbound(fptr_lon), ubound(fptr_lon) - !write(tmpstr, *) 'value fptr_lon: ', fptr_lon - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - write(tmpstr, *) 'shape glon: ', shape(solver_int_state%glon) - !write(tmpstr, *) 'value glon: ', solver_int_state%glon - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - write(tmpstr, *) 'shape glat: ', shape(solver_int_state%glat) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - write(tmpstr, *) 'shape vlon: ', shape(solver_int_state%vlon) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - write(tmpstr, *) 'shape vlat: ', shape(solver_int_state%vlat) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - call ESMF_LogFlush() - - pi=acos(-1._kdbl) - rad2deg=180._kdbl/pi - - do J = solver_int_state%JTS, solver_int_state%JTE - do I = solver_int_state%ITS, solver_int_state%ITE - fptr_lon(I,J) = solver_int_state%GLON(I+offset,J+offset)*rad2deg -! if((i>=1.and.i<=5.and.j>=1.and.j<=2).or.(i>=1.and.i<=2.and.j>=1.and.j<=5))then -! write(0,24240)i,j,fptr_lon(i,j) -24240 format(' center i=',i3,' j=',i3,' lon=',e12.5) -! endif -! if((i==1.or.i==solver_int_state%IDE).and.(j==1.or.j==solver_int_state%JDE))then -! write(0,44421)i,j,fptr_lon(i,j) -44421 format(' i=',i3,' j=',i3,' center lon=',e13.6) -! endif - enddo - enddo - - ! Define Center latitude - call ESMF_GridGetCoord(NMMB_GridCreate, coordDim=2, & - staggerLoc=ESMF_STAGGERLOC_CENTER, & - localDe=0, farrayPtr=fptr_lat, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - DOMAIN_DESCRIPTORS(nestingDomainGridcompIndex)%NEST_GLAT => fptr_lat - - do J = solver_int_state%JTS, solver_int_state%JTE - do I = solver_int_state%ITS, solver_int_state%ITE - fptr_lat(I,J) = solver_int_state%GLAT(I+offset,J+offset)*rad2deg -! if((i>=1.and.i<=5.and.j>=1.and.j<=2).or.(i>=1.and.i<=2.and.j>=1.and.j<=5))then -! write(0,24241)i,j,fptr_lat(i,j) -24241 format(' center i=',i3,' j=',i3,' lat=',e12.5) -! endif -! if((i==1.or.i==solver_int_state%IDE).and.(j==1.or.j==solver_int_state%JDE))then -! write(0,44422)i,j,fptr_lat(i,j) -44422 format(' i=',i3,' j=',i3,' center lat=',e13.6) -! endif - enddo - enddo - - ! Define Corner longitude - call ESMF_GridGetCoord(NMMB_GridCreate, coordDim=1, & - staggerLoc=ESMF_STAGGERLOC_CORNER, & - localDe=0, farrayPtr=fptr_lon, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - DOMAIN_DESCRIPTORS(nestingDomainGridcompIndex)%NEST_VLON => fptr_lon - -!----------------------------------------------------------------------- -!*** On the B grid V points lie to the northeast of H points with the -!*** same indices. So first fill all the lower left grid cell corners -!*** with V-point coordinates then fill in those corner values along -!*** the south and east domain edges by computing the correct -!*** coordinates. -!----------------------------------------------------------------------- - - offset=-1 - - istart=max(2,solver_int_state%ITS) - iend=solver_int_state%ITE - if(solver_int_state%ITE==solver_int_state%IDE)THEN - iend=solver_int_state%IDE+1 - endif - - jstart=max(2,solver_int_state%JTS) - jend=solver_int_state%JTE - if(solver_int_state%JTE==solver_int_state%JDE)THEN - jend=solver_int_state%JDE+1 - endif - - do J = jstart, jend - do I = istart, iend - fptr_lon(I,J) = solver_int_state%VLON(I+offset,J+offset) -! if(i>=solver_int_state%ide-1.or.j>=solver_int_state%jde-1)then -! write(0,45451)i,j,i+offset,j+offset,solver_int_state%VLAT(i+offset,J+offset)*rad2deg & -! ,solver_int_state%VLON(I+offset,J+offset)*rad2deg -45451 format(' NMMB_GridCreate i=',i3,' j=',i3,' i+offset=',i3,' j+offset=',i3,' vlat=',e12.5,' vlon(offset)=',e12.5) -! endif - enddo - enddo - - ! Define Corner latitude - call ESMF_GridGetCoord(NMMB_GridCreate, coordDim=2, & - staggerLoc=ESMF_STAGGERLOC_CORNER, & - localDe=0, farrayPtr=fptr_lat, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - DOMAIN_DESCRIPTORS(nestingDomainGridcompIndex)%NEST_VLAT => fptr_lat - - do J = jstart, jend - do I = istart, iend - fptr_lat(I,J) = solver_int_state%VLAT(I+offset,J+offset) - enddo - enddo - -!*** The dimensions of the arrays holding the cell corners depends on -!*** whether the cell lies on the domain boundary. For cells on the -!*** north boundary the J dimension is JTE+1 while for cells on the -!*** east boundary the I dimension is ITE+1. - - call cell_corners_on_bndry(fptr_lat,fptr_lon,iend,jend & - ,solver_int_state%GLAT,solver_int_state%GLON & - ,solver_int_state%ITS,solver_int_state%ITE & - ,solver_int_state%JTS,solver_int_state%JTE & - ,solver_int_state%IMS,solver_int_state%IME & - ,solver_int_state%JMS,solver_int_state%JME & - ,solver_int_state%IDS,solver_int_state%IDE & - ,solver_int_state%JDS,solver_int_state%JDE ) - -!*** Convert corner coordinates from radians to degrees for ESMF regrid. - - do J = solver_int_state%JTS, jend - do I = solver_int_state%ITS, iend - fptr_lat(I,J) = fptr_lat(I,J) * rad2deg - fptr_lon(I,J) = fptr_lon(I,J) * rad2deg -! if((i>=1.and.i<=5.and.j>=1.and.j<=2).or.(i>=1.and.i<=2.and.j>=1.and.j<=5))then -! write(0,24242)i,j,fptr_lat(i,j),fptr_lon(i,j) -24242 format(' corner i=',i3,' j=',i3,' lat=',e12.5,' lon=',e12.5) -! endif -! if((i<=2.or.i>=solver_int_state%IDE).and.(j<=2.or.j>=solver_int_state%JDE))then -! write(0,44401)i,j,fptr_lat(I,J),fptr_lon(I,J) -44401 format(' i=',i3,' j=',i3,' corner glat=',e13.6,' corner glon=',e13.6) -! endif - enddo - enddo - -!----------------------------------------------------------------------- - - endif active - -! -!----------------------------------------------------------------------- -! - contains -! -!----------------------------------------------------------------------- -! - subroutine cell_corners_on_bndry(vlat,vlon,ilim,jlim & - ,glat,glon & - ,its,ite,jts,jte & - ,ims,ime,jms,jme & - ,ids,ide,jds,jde) - -!----------------------------------------------------------------------- -!*** Compute the geographic lat/lon of the lower left corners of -!*** NMMB grid cells that lie on the south and west boundary of -!*** the domain. -!----------------------------------------------------------------------- - - implicit none - - integer(kind=KINT),intent(in) :: ilim,jlim & !<-- Upper limits of array of corners on this task - ,ids,ide,jds,jde & !<-- Domain limits - ,ims,ime,jms,jme & !<-- Memory limits of MPI task subdomain - ,its,ite,jts,jte !<-- Integration limits of task subdomain - - real(ESMF_KIND_R8),dimension(its:ilim,jts:jlim),intent(inout) :: & - vlat,vlon !<-- Geographic lat/lon (rad) of V points on NMMB grid - real(kind=KFPT),dimension(ims:ime,jms:jme),intent(in) :: glat,glon !<-- Geographic lat/lon (rad) of H points on NMMB grid - integer(kind=KINT) :: i,j - real(kind=KDBL) :: arg1,arg2,deg2rad,dlm,dph,fctr & - ,pi,tlat,tlm0,tlon,tph0,x,y,z - real(kind=KDBL),dimension(its:its+1,jts:jts+1) :: hlat,hlon - - pi=acos(-1._kdbl) - deg2rad=pi/180._kdbl - tph0=tph0d*deg2rad - tlm0=tlm0d*deg2rad -! write(0,40001)tph0d,tlm0d -40001 format(' corners tph0d=',e12.5,' tlm0d=',e12.5) - -!*** We need to know the grid increments in terms of rotated lat/lon. - - do j=jts,jts+1 - do i=its,its+1 - x=cos(tph0)*cos(glat(i,j))*cos(glon(i,j)-tlm0)+sin(tph0)*sin(glat(i,j)) - y= cos(glat(i,j))*sin(glon(i,j)-tlm0) - z=cos(tph0)*sin(glat(i,j))-sin(tph0)*cos(glat(i,j))*cos(glon(i,j)-tlm0) - hlat(i,j)=atan(z/sqrt(x*x+y*y)) !<-- Rotated lat (radians) of SW corner H points - hlon(i,j)=atan(y/x) !<-- Rotated lon (radians) of SW corner H points -! if(its==1.and.jts==1)then -! write(0,32321)i,j,hlat(i,j)/deg2rad,hlon(i,j)/deg2rad -32321 format(' rot h lat i=',i3,' j=',i3,' lat=',e12.5,' lon=',e12.5) -! endif - enddo - enddo - - dph=hlat(its,jts+1)-hlat(its,jts) !<-- The grid increment of rotated latitude (radians) - dlm=hlon(its+1,jts)-hlon(its,jts) !<-- The grid increment of rotated longitude (radians) -! if(its==1.and.jts==1)then -! write(0,32322)dph/deg2rad,dlm/deg2rad -32322 format(' dphd=',e17.10,' dlmd=',e17.10) -! endif - -!*** Using the rotated lat/lon of phantom V points just south and -!*** west of the domain boundary find their geographic lat/lon. -!*** First the south side. - - tlat=hlat(its,jts)-dph*0.5_kdbl !<-- Rotated lat (deg) of phantom V points south of boundary - tlon=hlon(its,jts)-dlm*1.5_kdbl - - if(jts==1)then !<-- Select the tasks on the south boundary. - j=1 - do i=its,ilim - tlon=tlon+dlm -! if((i<=2.or.i>=ide))then -! write(0,55581)i,j,tlat/deg2rad,tlon/deg2rad -55581 format(' corners south i=',i3,' j=',i3,' tlat=',e12.5,' tlon=',e12.5) -! endif - arg1=sin(tlat)*cos(tph0)+cos(tlat)*sin(tph0)*cos(tlon) - vlat(i,j)=asin(arg1) - arg2=cos(tlat)*cos(tlon)/(cos(vlat(i,j))*cos(tph0))- & - tan(vlat(i,j))*tan(tph0) - if(abs(arg2)>1.)arg2=abs(arg2)/arg2 - fctr=-1._kdbl - if(tlon>0.)fctr=1._kdbl - if(tlon>pi)fctr=-1._kdbl -! - vlon(i,j)=tlm0+fctr*acos(arg2) -! if((i<=2.or.i>=ide))then -! write(0,55582)i,j,vlat(i,j)/deg2rad,vlon(i,j)/deg2rad -55582 format(' corners south i=',i3,' j=',i3,' glat=',e12.5,' glon=',e12.5) -! endif - if(vlon(i,j)<-pi)vlon(i,j)=vlon(i,j)+pi*2._kdbl - if(vlon(i,j)> pi)vlon(i,j)=vlon(i,j)-pi*2._kdbl - enddo - endif - -!*** Then the west side. - - tlon=hlon(its,jts)-dlm*0.5_kdbl !<-- Rotated lon (deg) of phantom V points west of boundary - tlat=hlat(its,jts)-dph*1.5_kdbl - - if(its==1)then !<-- Select the tasks on the west boundary. - i=1 - do j=jts,jlim - tlat=tlat+dph -! if((j<=2.or.j>=jde))then -! write(0,55583)i,j,tlat/deg2rad,tlon/deg2rad -55583 format(' corners west i=',i3,' j=',i3,' tlat=',e12.5,' tlon=',e12.5) -! endif - arg1=sin(tlat)*cos(tph0)+cos(tlat)*sin(tph0)*cos(tlon) - vlat(i,j)=asin(arg1) - arg2=cos(tlat)*cos(tlon)/(cos(vlat(i,j))*cos(tph0))- & - tan(vlat(i,j))*tan(tph0) - if(abs(arg2)>1.)arg2=abs(arg2)/arg2 - fctr=-1._kdbl - if(tlon>0.)fctr=1._kdbl - if(tlon>pi)fctr=-1._kdbl -! - vlon(i,j)=tlm0+fctr*acos(arg2) - if(vlon(i,j)<-pi)vlon(i,j)=vlon(i,j)+pi*2._kdbl - if(vlon(i,j)> pi)vlon(i,j)=vlon(i,j)-pi*2._kdbl -! if((j<=2.or.j>=jde))then -! write(0,55584)i,j,vlat(i,j)/deg2rad,vlon(i,j)/deg2rad -55584 format(' corners west i=',i3,' j=',i3,' glat=',e12.5,' glon=',e12.5) -! endif - enddo - endif - -!----------------------------------------------------------------------- - - end subroutine cell_corners_on_bndry - -!----------------------------------------------------------------------- -! - END FUNCTION NMMB_GridCreate -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - SUBROUTINE ROTANGLE_CELLAREA_SEAMASK(SOLVER_INT_STATE & - ,ITS,ITE,JTS,JTE & - ,ROT_ANGLE & - ,CELL_AREA & - ,SEA_MASK ) -! -!----------------------------------------------------------------------- -!*** Compute/save the wind rotation angles (grid to earth), grid cell -!*** areas, and sea mask for the given domain. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument variables -!------------------------ -! - INTEGER(kind=KINT) :: ITS,ITE,JTS,JTE !<-- Subdomain integration limits for the given MPI task. -! - TYPE(SOLVER_INTERNAL_STATE),POINTER,INTENT(IN) :: SOLVER_INT_STATE !<-- The Solver component's internal state. -! - REAL(kind=KDBL),DIMENSION(ITS:ITE,JTS:JTE),INTENT(OUT) :: ROT_ANGLE & !<-- Wind rotations angles (radians) - ,CELL_AREA & !<-- Grid cell areas (m**2) - ,SEA_MASK !<-- Sea mask (1.0->water; 0.0->land) -! -!--------------------- -!*** Local variables -!--------------------- -! - INTEGER(kind=KINT) :: I,J -! - REAL(kind=KDBL) :: ARG,COS_LAM,COS_PHI,DEG2RAD,DLM,DPH,J_CENTER & - ,LAM0,LAMBDA,PHI0,PI,ROT_LAT,SIN_LAM,SIN_PHI,X,Y -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - PI=ACOS(-1._kdbl) - DEG2RAD=PI/180._kdbl - PHI0=solver_int_state%TPH0D*DEG2RAD - LAM0=solver_int_state%TLM0D*DEG2RAD -! - DPH=2._kdbl*solver_int_state%SBD*DEG2RAD/ & !<-- Increment of cell in rotated latitude (rad) - (solver_int_state%JDE-solver_int_state%JDS) - DLM=2._kdbl*solver_int_state%WBD*DEG2RAD/ & !<-- Increment of cell in rotated longitude (rad) - (solver_int_state%IDE-solver_int_state%IDS) -! - J_CENTER=0.5_kdbl*(solver_int_state%JDS+solver_int_state%JDE) !<-- J index of this domain's central location -! -! -!----------------------------------------------------------------------- -! - DO J=JTS,JTE - DO I=ITS,ITE -! -!----------------------------------------------------------------------- -!*** Compute the rotation angle for winds (grid to earth). -!----------------------------------------------------------------------- -! - COS_PHI=COS(solver_int_state%GLAT(I,J)) - SIN_PHI=SIN(solver_int_state%GLAT(I,J)) - COS_LAM=COS(solver_int_state%GLON(I,J)-LAM0) - SIN_LAM=SIN(solver_int_state%GLON(I,J)-LAM0) -! - X=COS(PHI0)*COS_PHI*COS_LAM+SIN(PHI0)*SIN_PHI - Y=COS_PHI*SIN_LAM - LAMBDA=ATAN(Y/X) -! - ARG=SIN(PHI0)*SIN(LAMBDA)/COS_PHI - IF(ABS(ARG)>1.)THEN - ARG=SIGN(1.,ARG) - ENDIF -! - ROT_ANGLE(I,J)=ASIN(ARG) -! -!----------------------------------------------------------------------- -!*** Compute the grid cell areas. -!----------------------------------------------------------------------- -! - ROT_LAT=(J-J_CENTER)*DPH !<-- Rotated latitude (rad) of center of grid cell -! - CELL_AREA(I,J)=2._kdbl*A**2*DLM*COS(ROT_LAT)*SIN(0.5_kdbl*DPH) !<-- Grid cell area (m**2) -! -!----------------------------------------------------------------------- -!*** Store the sea masks for each domain (1.0->water; 0.0->land). -!----------------------------------------------------------------------- -! - SEA_MASK(I,J)=solver_int_state%SM(I,J) -! -!----------------------------------------------------------------------- -! - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -! - END SUBROUTINE ROTANGLE_CELLAREA_SEAMASK -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - SUBROUTINE NMMB_CreateRouteHandle(N, DOMAIN_DESCRIPTORS, RC) -! - INTEGER, INTENT(IN) :: N - TYPE(DOMAIN_TASK_SPECS), POINTER :: DOMAIN_DESCRIPTORS(:) - INTEGER, INTENT(OUT), OPTIONAL :: RC - - TYPE(ESMF_Field) :: parentField, nestField - INTEGER :: parent_domain_id - INTEGER :: srcTermProcessing_Value = 0 - CHARACTER(len=2) :: msg - INTEGER :: nthgrid = 1 - -!----------------------------------------------------------------------- - - if(PRESENT(RC)) RC = ESMF_SUCCESS - if(N == DOMAIN_DESCRIPTORS(N)%PARENT_DOMAIN_ID) return !<-- Upper parent will not regrid to itself. - - parent_domain_id = DOMAIN_DESCRIPTORS(N)%PARENT_DOMAIN_ID - parentField = ESMF_FieldCreate(DOMAIN_DESCRIPTORS(parent_domain_id)%GRID, typekind=ESMF_TYPEKIND_R8, RC=RC) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - nestField = ESMF_FieldCreate(DOMAIN_DESCRIPTORS(N)%GRID, typekind=ESMF_TYPEKIND_R8, RC=RC) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - nthgrid = nthgrid + 1 - if(nthgrid == 10) then - write(msg, '(I2.2)') N - call Grid_Write(DOMAIN_DESCRIPTORS(N)%GRID, "NMMB_Nest_"//trim(msg), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - endif - - call ESMF_FieldRegridStore(parentField, nestField, & - routehandle=DOMAIN_DESCRIPTORS(N)%PARENT2SELF, & - regridmethod=ESMF_REGRIDMETHOD_BILINEAR, & - polemethod=ESMF_POLEMETHOD_ALLAVG, & - srcTermProcessing=srcTermProcessing_Value, & !<-- no partial sum on src side - ignoreDegenerate=.true., & - unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - call ESMF_FieldRegridStore(nestField, parentField, & - routehandle=DOMAIN_DESCRIPTORS(N)%SELF2PARENT, & - regridmethod=ESMF_REGRIDMETHOD_BILINEAR, & - polemethod=ESMF_POLEMETHOD_ALLAVG, & - srcTermProcessing=srcTermProcessing_Value, & !<-- no partial sum on src side - ignoreDegenerate=.true., & - unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - END SUBROUTINE NMMB_CreateRouteHandle - -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - SUBROUTINE NMMB_CreateDomainFields(N, DOMAIN_DESCRIPTORS, RC) -! -!----------------------------------------------------------------------- - - INTEGER, INTENT(IN) :: N - TYPE(DOMAIN_TASK_SPECS), POINTER :: DOMAIN_DESCRIPTORS(:) - INTEGER, INTENT(OUT), OPTIONAL :: RC - - TYPE(ESMF_Field) :: parentField, nestField - INTEGER :: fieldIdx - -!----------------------------------------------------------------------- - - if(PRESENT(RC)) RC = ESMF_SUCCESS - ! Allocate for all domains - if(.not.allocated(DOMAIN_DESCRIPTORS(N)%ImportFieldsList))then - allocate(DOMAIN_DESCRIPTORS(N)%ImportFieldsList(nImportFields)) - allocate(DOMAIN_DESCRIPTORS(N)%ExportFieldsList(nExportFields)) - endif - - !Print *, 'End of NMMB_CreateDomainFields: ', 'nImportFields = ', nImportFields, & - !' nExportFields_NMMB = ', nExportFields, ' N = ', N, & - !' sizeIm = ', size(DOMAIN_DESCRIPTORS(N)%ImportFieldsList), & - !' sizeEx = ', size(DOMAIN_DESCRIPTORS(N)%ExportFieldsList) - - if(N == DOMAIN_DESCRIPTORS(N)%PARENT_DOMAIN_ID) return !<-- CAP will create the Fields for parent domain - - do fieldIdx = 1,nImportFields - DOMAIN_DESCRIPTORS(N)%ImportFieldsList(fieldIdx) = ESMF_FieldCreate( & - DOMAIN_DESCRIPTORS(N)%GRID, typekind=ESMF_TYPEKIND_R8, & - name=trim(importFieldsList(fieldIdx)), RC=RC) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - enddo - - do fieldIdx = 1,nExportFields - call ESMF_LogWrite('NMMB_CreateDomainFields: '//trim(exportFieldsList(fieldIdx)), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - DOMAIN_DESCRIPTORS(N)%ExportFieldsList(fieldIdx) = ESMF_FieldCreate( & - DOMAIN_DESCRIPTORS(N)%GRID, typekind=ESMF_TYPEKIND_R8, & - name=trim(exportFieldsList(fieldIdx)), RC=RC) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - enddo - -!----------------------------------------------------------------------- - - END SUBROUTINE NMMB_CreateDomainFields - -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - SUBROUTINE CONNECT_IMPORT_FIELDS(DOMAIN_ID,DOMAIN_DESCRIPTORS & - ,NMM_GRID_COMP,RC) -! -!----------------------------------------------------------------------- -!*** The ocean's SST has been interpolated onto the NMM-B's grid. -!*** Point at that SST field with a domain-dependent pointer. The -!*** values will be copied to the Solver's internal state in -!*** DOMAIN_RUN immediately before the call to SOLVER_RUN. -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- - - INTEGER,INTENT(IN) :: DOMAIN_ID - TYPE(DOMAIN_TASK_SPECS),POINTER :: DOMAIN_DESCRIPTORS(:) - TYPE(ESMF_GridComp),INTENT(IN) :: NMM_GRID_COMP -! - INTEGER, INTENT(OUT), OPTIONAL :: RC -! -!--------------------- -!*** Local variables -!--------------------- -! - TYPE(NMM_INTERNAL_STATE),POINTER,SAVE :: NMM_INT_STATE !<-- The NMM component internal state pointer - TYPE(WRAP_NMM_INTERNAL_STATE) :: WRAP_NMM !<-- The F90 wrap of the NMM internal state - TYPE(DOMAIN_INTERNAL_STATE),POINTER :: DOMAIN_INT_STATE !<-- The Domain component internal state pointer - TYPE(WRAP_DOMAIN_INTERNAL_STATE) :: WRAP_DOMAIN !<-- The F90 wrap of the Domain internal state - REAL(ESMF_KIND_R8),POINTER :: SST_FPTR(:,:) -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! write(0,36611) -36611 format(' enter CONNECT') -! - IF(PRESENT(RC)) RC= ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** Extract the NMM component's internal state. -!----------------------------------------------------------------------- -! - CALL ESMF_GridCompGetInternalState(NMM_GRID_COMP & - ,WRAP_NMM & - ,RC ) -! - IF(RC/=0)THEN - WRITE(0,*)' CONNECT_IMPORT_FIELDS failed to get NMM int state' - WRITE(0,*)' RC=',RC - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - NMM_INT_STATE=>wrap_nmm%NMM_INT_STATE -! -!----------------------------------------------------------------------- -! -! DO DOMAIN_ID=1,NUM_DOMAINS_TOTAL - -! write(0,40021)domain_id,domain_descriptors(domain_id)%task_active -40021 format(' CONNECT domain_id=',i2,' task_active=',l1) - IF(DOMAIN_DESCRIPTORS(DOMAIN_ID)%TASK_ACTIVE) THEN - CALL ESMF_GridCompGetInternalState(& - nmm_int_state%DOMAIN_GRID_COMP(DOMAIN_ID) & - ,WRAP_DOMAIN & - ,RC) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out -! - DOMAIN_INT_STATE=>wrap_domain%DOMAIN_INT_STATE -! -! fieldIdx = queryFieldList(importFieldsList, 'sea_surface_temperature', rc=rc) - CALL ESMF_FieldGet(DOMAIN_DESCRIPTORS(DOMAIN_ID)%importFieldsList(3), farrayPtr=sst_fptr, rc=rc) -! - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out -! - domain_int_state%SST_COUPLED => sst_fptr -! write(0,36612) -36612 format(' CONNECT pointed at sst_fptr') -! - ENDIF -! -! write(0,36613) -36613 format(' exit CONNECT') -!----------------------------------------------------------------------- -! - END SUBROUTINE CONNECT_IMPORT_FIELDS -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - SUBROUTINE CONNECT_EXPORT_FIELDS(DOMAIN_ID, DOMAIN_DESCRIPTORS & - ,NMM_GRID_COMP, RC) -! -!----------------------------------------------------------------------- -!*** Connect fluxes generated inside the NMM with pointers in the -!*** cap in order to tranfer the fields to the ocean model. -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! -!----------------------- -!*** Argument variables -!----------------------- -! - INTEGER, INTENT(IN) :: DOMAIN_ID - TYPE(DOMAIN_TASK_SPECS),POINTER :: DOMAIN_DESCRIPTORS(:) - TYPE(ESMF_GridComp),INTENT(IN) :: NMM_GRID_COMP - INTEGER, INTENT(OUT), OPTIONAL :: RC -! -!--------------------- -!*** Local variables -!--------------------- -! - TYPE(NMM_INTERNAL_STATE),POINTER,SAVE :: NMM_INT_STATE !<-- The NMM component internal state pointer - TYPE(WRAP_NMM_INTERNAL_STATE) :: WRAP_NMM !<-- The F90 wrap of the NMM internal state - TYPE(DOMAIN_INTERNAL_STATE),POINTER :: DOMAIN_INT_STATE !<-- The Domain component internal state pointer - TYPE(WRAP_DOMAIN_INTERNAL_STATE) :: WRAP_DOMAIN !<-- The F90 wrap of the Domain internal state - REAL(ESMF_KIND_R8),POINTER :: inst_sfc_pressure_fptr(:,:) & !<-- Instantaneous surface pressure pointer in cap - ,inst_latent_htflx_fptr(:,:) & !<-- Instantaneous latent heat flux pointer in cap - ,inst_sensible_htflx_fptr(:,:) & !<-- Instantaneous sensible heat flux pointer in cap - ,inst_net_lwflx_fptr(:,:) & !<-- Instantaneous net lw flux pointer in cap - ,inst_net_swflx_fptr(:,:) & !<-- Instantaneous net sw flux pointer in cap - ,mean_zonal_momflx_fptr(:,:) & !<-- Mean zonal momentum flux pointer in cap - ,mean_merid_momflx_fptr(:,:) & !<-- Mean meridional momentum flux pointer in cap - ,mean_prec_rate_fptr(:,:) !<-- Mean precipitation rate pointer in cap -! - INTEGER :: fieldIdx !<-- Field ID from the Field List -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! write(0,36611) -36611 format(' enter CONNECT export') -! - IF(PRESENT(RC)) RC= ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** Extract the NMM component's internal state. -!----------------------------------------------------------------------- -! -! - CALL ESMF_GridCompGetInternalState(NMM_GRID_COMP & - ,WRAP_NMM & - ,RC ) -! - IF(RC/=0)THEN - WRITE(0,*)' CONNECT_IMPORT_FIELDS failed to get NMM int state' - WRITE(0,*)' RC=',RC - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - NMM_INT_STATE=>wrap_nmm%NMM_INT_STATE -! -!----------------------------------------------------------------------- -! - -! write(0,40021)domain_id,domain_descriptors(domain_id)%task_active -40021 format(' CONNECT domain_id=',i2,' task_active=',l1) - IF(DOMAIN_DESCRIPTORS(DOMAIN_ID)%TASK_ACTIVE) THEN -! - CALL ESMF_GridCompGetInternalState(& - nmm_int_state%DOMAIN_GRID_COMP(DOMAIN_ID) & - ,WRAP_DOMAIN & - ,RC) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out -! - DOMAIN_INT_STATE=>wrap_domain%DOMAIN_INT_STATE -! -!------------------------------------------------------------ -!*** Connect instantaneous sensible heat flux with the cap. -!------------------------------------------------------------ -! -! Fei for hycom compatibility -! fieldIdx = queryFieldList(exportFieldsList, 'inst_sensi_heat_flx', rc=rc) - fieldIdx = queryFieldList(exportFieldsList, 'mean_sensi_heat_flx', rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - CALL ESMF_FieldGet(DOMAIN_DESCRIPTORS(DOMAIN_ID)%exportFieldsList(fieldIdx) & - ,farrayPtr=inst_sensible_htflx_fptr & - ,rc =rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out -! - domain_int_state%INST_SENS_HT_FLX_COUPLED => inst_sensible_htflx_fptr !<-- Connect inst sensible heat flx between atm and cap -! -!---------------------------------------------------------- -!*** Connect instantaneous latent heat flux with the cap. -!---------------------------------------------------------- -! -! Fei for hycom compatibility -! fieldIdx = queryFieldList(exportFieldsList, 'inst_laten_heat_flx', rc=rc) - fieldIdx = queryFieldList(exportFieldsList, 'mean_laten_heat_flx', rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - CALL ESMF_FieldGet(DOMAIN_DESCRIPTORS(DOMAIN_ID)%exportFieldsList(fieldIdx) & - ,farrayPtr=inst_latent_htflx_fptr & - ,rc =rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out -! - domain_int_state%INST_LAT_HT_FLX_COUPLED => inst_latent_htflx_fptr !<-- Connect mean latent heat flx between atm and cap -! -!----------------------------------------------------- -!*** Connect instantaneous net LW flux with the cap. -!----------------------------------------------------- -! -!keep fieldIdx = queryFieldList(exportFieldsList, 'inst_net_lw_flx', rc=rc) - fieldIdx = queryFieldList(exportFieldsList, 'mean_net_lw_flx', rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - CALL ESMF_FieldGet(DOMAIN_DESCRIPTORS(DOMAIN_ID)%exportFieldsList(fieldIdx) & - ,farrayPtr=inst_net_lwflx_fptr & - ,rc =rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out -! - domain_int_state%INST_NET_LW_FLX_COUPLED => inst_net_lwflx_fptr !<-- Connect instantaneous net lw flx between atm and cap -! -!----------------------------------------------------- -!*** Connect instantaneous net SW flux with the cap. -!----------------------------------------------------- -! -!keep fieldIdx = queryFieldList(exportFieldsList, 'inst_net_sw_flx', rc=rc) - fieldIdx = queryFieldList(exportFieldsList, 'mean_net_sw_flx', rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - CALL ESMF_FieldGet(DOMAIN_DESCRIPTORS(DOMAIN_ID)%exportFieldsList(fieldIdx) & - ,farrayPtr=inst_net_swflx_fptr & - ,rc =rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - domain_int_state%INST_NET_SW_FLX_COUPLED => inst_net_swflx_fptr !<-- Connect instantaneous net sw flx between atm and cap -! -!---------------------------------------------------- -!*** Connect mean zonal momentum flux with the cap. -!---------------------------------------------------- -! - fieldIdx = queryFieldList(exportFieldsList, 'mean_zonal_moment_flx', rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - CALL ESMF_FieldGet(DOMAIN_DESCRIPTORS(DOMAIN_ID)%exportFieldsList(fieldIdx) & - ,farrayPtr=mean_zonal_momflx_fptr & - ,rc =rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out -! - domain_int_state%MEAN_ZONAL_MOM_FLX_COUPLED => mean_zonal_momflx_fptr !<-- Connect mean zonal mom flux between atm and cap -! -!--------------------------------------------------------- -!*** Connect mean meridional momentum flux with the cap. -!--------------------------------------------------------- -! - fieldIdx = queryFieldList(exportFieldsList, 'mean_merid_moment_flx', rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - CALL ESMF_FieldGet(DOMAIN_DESCRIPTORS(DOMAIN_ID)%exportFieldsList(fieldIdx) & - ,farrayPtr=mean_merid_momflx_fptr & - ,rc =rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out -! - domain_int_state%MEAN_MERID_MOM_FLX_COUPLED => mean_merid_momflx_fptr !<-- Connect mean meridionalal mom flux between atm and cap -! -!--------------------------------------------------- -!*** Connect mean precipitation rate with the cap. -!--------------------------------------------------- -! - fieldIdx = queryFieldList(exportFieldsList, 'mean_prec_rate', rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - CALL ESMF_FieldGet(DOMAIN_DESCRIPTORS(DOMAIN_ID)%exportFieldsList(fieldIdx) & - ,farrayPtr=mean_prec_rate_fptr & - ,rc =rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out -! - domain_int_state%MEAN_PREC_RATE_COUPLED => mean_prec_rate_fptr !<-- Connect mean precipitation rate between atm and cap -! -!---------------------------------------------------------- -!*** Connect instantaneous surface pressure with the cap. -!---------------------------------------------------------- -! - fieldIdx = queryFieldList(exportFieldsList, 'inst_pres_height_surface', rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - CALL ESMF_FieldGet(DOMAIN_DESCRIPTORS(DOMAIN_ID)%exportFieldsList(fieldIdx) & - ,farrayPtr=inst_sfc_pressure_fptr & - ,rc =rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out -! - domain_int_state%INST_SFC_PRESSURE_COUPLED => inst_sfc_pressure_fptr !<-- Connect instantaneous sfc pressure between atm and cap -! -!----------------------------------------------------------------------- -! - ENDIF -! -! write(0,36613) -36613 format(' exit CONNECT export') -!----------------------------------------------------------------------- -! - END SUBROUTINE CONNECT_EXPORT_FIELDS -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - SUBROUTINE NMMB_RegridImport(slice, DOMAIN_DESCRIPTORS, NUM_DOMAINS_TOTAL, RC) -! -!----------------------------------------------------------------------- -!*** If there are nests interpolate the import field(s) from the -!*** upper parent's grid to those of the nests since for now only -!*** the parent is directly coupled to the external model(s). -!----------------------------------------------------------------------- - - INTEGER, INTENT(IN) :: slice & - ,NUM_DOMAINS_TOTAL - TYPE(DOMAIN_TASK_SPECS), POINTER :: DOMAIN_DESCRIPTORS(:) - INTEGER, INTENT(OUT), OPTIONAL :: RC - - TYPE(ESMF_Field) :: parentField, nestField - INTEGER :: parent_domain_id, N, fieldIdx - character(len=2) :: msg - character(len=32) :: pname, nname - -!----------------------------------------------------------------------- - - if(PRESENT(RC)) RC = ESMF_SUCCESS - - DO N = 2, NUM_DOMAINS_TOTAL - parent_domain_id = DOMAIN_DESCRIPTORS(N)%PARENT_DOMAIN_ID - !DO fieldIdx = 1, nImportFields - DO fieldIdx = 3,3 - parentField=DOMAIN_DESCRIPTORS(parent_domain_id)%ImportFieldsList(fieldIdx) - nestField =DOMAIN_DESCRIPTORS(N) %ImportFieldsList(fieldIdx) - !print *, 'sizeIm = ', size(DOMAIN_DESCRIPTORS(1)%ImportFieldsList), & - ! 'sizeEx = ', size(DOMAIN_DESCRIPTORS(1)%ExportFieldsList), & - ! fieldIdx, parent_domain_id, N - call ESMF_FieldGet(parentField, name=pname, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - call ESMF_FieldGet(nestField, name=nname, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - !print *, 'pname = ', pname, ' nname = ', nname - - call ESMF_FieldRegrid(parentField, nestField, & - routehandle=DOMAIN_DESCRIPTORS(N)%PARENT2SELF, & - termorderflag=ESMF_TERMORDER_SRCSEQ, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - write(msg, '(I2.2)') N -! call ESMF_FieldWrite(nestField,'field_atm_import_sst_'//trim(msg)//'.nc',overwrite=.true.,& -! timeslice=slice, rc=rc) -! if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & -! line=__LINE__, & -! file=__FILE__)) & -! return ! bail out - ENDDO - ENDDO - -!----------------------------------------------------------------------- - - END SUBROUTINE NMMB_RegridImport -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - SUBROUTINE NMMB_RegridExport(slice,DOMAIN_DESCRIPTORS & - ,NUM_DOMAINS_TOTAL,nExportFields_NMMB & - ,EXPORT_FIELDS_INDX, RC) -! -!----------------------------------------------------------------------- -!*** If there are nests then blend the export fields from -!*** their grids onto that of the upper parent since -!*** for now only the parent is directly coupled to the -!*** external model(s). The field 'mean_prec_rate' is -!*** only from the upper parent and contains no information -!*** from the nests. -!----------------------------------------------------------------------- - - INTEGER, INTENT(IN) :: slice & - ,nExportFields_NMMB & - ,NUM_DOMAINS_TOTAL - INTEGER,DIMENSION(:),INTENT(IN) :: EXPORT_FIELDS_INDX - TYPE(DOMAIN_TASK_SPECS), POINTER :: DOMAIN_DESCRIPTORS(:) - INTEGER, INTENT(OUT), OPTIONAL :: RC - - TYPE(ESMF_Field) :: nestField, parentField - INTEGER :: parent_domain_id, N, NN, fieldIdx - character(len=2) :: msg - -!----------------------------------------------------------------------- - - if(PRESENT(RC)) RC = ESMF_SUCCESS - - DO N = 2, NUM_DOMAINS_TOTAL - parent_domain_id = DOMAIN_DESCRIPTORS(N)%PARENT_DOMAIN_ID -! DO fieldIdx = 1, nExportFields - DO NN = 1, nExportFields_NMMB - fieldIdx = EXPORT_FIELDS_INDX(NN) - nestField =DOMAIN_DESCRIPTORS(N) %ExportFieldsList(fieldIdx) - parentField=DOMAIN_DESCRIPTORS(parent_domain_id)%ExportFieldsList(fieldIdx) - call ESMF_FieldRegrid(nestField, parentField, & - routehandle=DOMAIN_DESCRIPTORS(N)%SELF2PARENT, & - zeroregion=ESMF_REGION_SELECT, & - termorderflag=ESMF_TERMORDER_SRCSEQ, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - write(msg, '(I2.2)') N -! call ESMF_FieldWrite(nestField,'field_atm_import_sst_'//trim(msg)//'.nc',overwrite=.true.,& -! timeslice=slice, rc=rc) -! if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & -! line=__LINE__, & -! file=__FILE__)) & -! return ! bail out - ENDDO - ENDDO - -!----------------------------------------------------------------------- - - END SUBROUTINE NMMB_RegridExport -! -!----------------------------------------------------------------------- -! - ! Dump the contents of one element of DOMAIN_DESCRIPTORS - SUBROUTINE DUMP_DOMAIN_DESCRIPTOR(DOMAIN_DESCRIPTORS, ID_X) - TYPE(DOMAIN_TASK_SPECS), POINTER :: DOMAIN_DESCRIPTORS(:) - INTEGER, INTENT(IN) :: ID_X - - INTEGER :: N, RC - CHARACTER(4096) :: TMPSTR - CHARACTER(64) :: fname - - write(tmpstr, *) "DOMAIN ID_X = ", ID_X - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - write(tmpstr, *) "INPES = ", DOMAIN_DESCRIPTORS(ID_X)%INPES - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - write(tmpstr, *) "JNPES = ", DOMAIN_DESCRIPTORS(ID_X)%JNPES - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - write(tmpstr, *) "MIN_INDEX = ", DOMAIN_DESCRIPTORS(ID_X)%INDX_MIN - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - write(tmpstr, *) "MAX_INDEX = ", DOMAIN_DESCRIPTORS(ID_X)%INDX_MAX - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - write(tmpstr, *) "TASK_ACTIVE = ", DOMAIN_DESCRIPTORS(ID_X)%TASK_ACTIVE - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - write(tmpstr, *) "NUM_PETS = ", DOMAIN_DESCRIPTORS(ID_X)%NUM_PETS - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - write(tmpstr, *) "PET_MAP = ", size(DOMAIN_DESCRIPTORS(ID_X)%PET_MAP), DOMAIN_DESCRIPTORS(ID_X)%PET_MAP - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - - write(tmpstr, *) "ImportFieldsList Size = ", SIZE(DOMAIN_DESCRIPTORS(ID_X)%ImportFieldsList) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - DO N = 1, SIZE(DOMAIN_DESCRIPTORS(ID_X)%ImportFieldsList) - Call ESMF_FieldGet(DOMAIN_DESCRIPTORS(ID_X)%ImportFieldsList(N), name=fname, RC=RC) - write(tmpstr, *) "Import Field #", N, " NAME = ", TRIM(fname) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - ENDDO - - write(tmpstr, *) "ExportFieldsList Size = ", SIZE(DOMAIN_DESCRIPTORS(ID_X)%ExportFieldsList) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - DO N = 1, SIZE(DOMAIN_DESCRIPTORS(ID_X)%ExportFieldsList) - Call ESMF_FieldGet(DOMAIN_DESCRIPTORS(ID_X)%ExportFieldsList(N), name=fname, RC=RC) - write(tmpstr, *) "Export Field #", N, " NAME = ", TRIM(fname) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - ENDDO - END SUBROUTINE -! -!----------------------------------------------------------------------- -! - ! Dump the contents of DOMAIN_DESCRIPTORS on a PET(optional) - SUBROUTINE DUMP_DOMAIN_DESCRIPTORS(DOMAIN_DESCRIPTORS, PETNO) - - TYPE(DOMAIN_TASK_SPECS), POINTER :: DOMAIN_DESCRIPTORS(:) - INTEGER, INTENT(IN), OPTIONAL :: PETNO - - INTEGER :: ID_X - - IF(present(PETNO)) THEN - IF(I_AM_PET(PETNO)) THEN - DO ID_X = 1, SIZE(DOMAIN_DESCRIPTORS) - CALL DUMP_DOMAIN_DESCRIPTOR(DOMAIN_DESCRIPTORS, ID_X) - ENDDO - ENDIF - ELSE - DO ID_X = 1, SIZE(DOMAIN_DESCRIPTORS) - CALL DUMP_DOMAIN_DESCRIPTOR(DOMAIN_DESCRIPTORS, ID_X) - ENDDO - ENDIF - call ESMF_LogFlush() - - END SUBROUTINE DUMP_DOMAIN_DESCRIPTORS -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- - FUNCTION I_AM_ROOT(RC) -!----------------------------------------------------------------------- - - integer, intent(out) :: RC - logical :: I_AM_ROOT - - type(ESMF_VM) :: VM - integer :: lpet - - RC = ESMF_SUCCESS - I_AM_ROOT = .FALSE. - call ESMF_VMGetCurrent(VM, RC=RC) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - call ESMF_VMGet(VM, localPet=lpet, RC=RC) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - if(lpet == 0) I_AM_ROOT = .TRUE. - -!----------------------------------------------------------------------- - END FUNCTION I_AM_ROOT -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- - FUNCTION I_AM_PET(PETNO) -!----------------------------------------------------------------------- - - integer, intent(in),optional :: PETNO - logical :: I_AM_PET - - type(ESMF_VM) :: VM - integer :: lpet, PETNO_loc, RC - - RC = ESMF_SUCCESS - I_AM_PET = .FALSE. - call ESMF_VMGetCurrent(VM, RC=RC) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - call ESMF_VMGet(VM, localPet=lpet, RC=RC) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - if(present(PETNO)) THEN - if(lpet == PETNO) I_AM_PET = .TRUE. - else - I_AM_PET = .TRUE. - endif - -!----------------------------------------------------------------------- - END FUNCTION I_AM_PET -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- - SUBROUTINE NMMB_GridUpdate(nestingDomainGridcompIndex & - ,DOMAIN_DESCRIPTORS & - ,AREA, MASK, GLON, GLAT, VLON, VLAT & - ,RC ) -!----------------------------------------------------------------------- -! Update the pointer values saved in DOMAIN_DESCRIPTORS when -! a nest moves. The pointer values are set up to point to memory -! allocated in nest's Grid. -!----------------------------------------------------------------------- - - INTEGER, INTENT(IN) :: nestingDomainGridcompIndex - TYPE(DOMAIN_TASK_SPECS),POINTER :: DOMAIN_DESCRIPTORS(:) - REAL(kind=KDBL),DIMENSION(:,:),INTENT(IN) :: AREA, MASK - REAL(kind=KDBL),DIMENSION(:,:),POINTER :: GLON, GLAT & - ,VLON, VLAT - INTEGER, INTENT(OUT) :: RC - - RC = ESMF_SUCCESS - - DOMAIN_DESCRIPTORS(nestingDomainGridcompIndex)%NEST_CELL_AREA = AREA - DOMAIN_DESCRIPTORS(nestingDomainGridcompIndex)%NEST_SEA_MASK = NINT(MASK) - DOMAIN_DESCRIPTORS(nestingDomainGridcompIndex)%NEST_GLON = GLON - DOMAIN_DESCRIPTORS(nestingDomainGridcompIndex)%NEST_GLAT = GLAT - DOMAIN_DESCRIPTORS(nestingDomainGridcompIndex)%NEST_VLON = VLON - DOMAIN_DESCRIPTORS(nestingDomainGridcompIndex)%NEST_VLAT = VLAT - - END SUBROUTINE NMMB_GridUpdate - -!----------------------------------------------------------------------- - subroutine Grid_Write(grid, string, rc) - type(ESMF_Grid) ,intent(in) :: grid - character(len=*),intent(in) :: string - integer ,intent(out) :: rc - - ! local - type(ESMF_Array) :: array - character(len=*),parameter :: subname='(module_MEDIATOR:Grid_Write)' - logical :: isPresent - - ! -- centers -- - - rc = ESMF_SUCCESS - - ! -- centers -- - - call ESMF_GridGetCoord(grid, staggerLoc=ESMF_STAGGERLOC_CENTER, isPresent=isPresent, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - if (isPresent) then - call ESMF_GridGetCoord(grid, coordDim=1, staggerLoc=ESMF_STAGGERLOC_CENTER, array=array, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_ArraySet(array, name="lon_center", rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_ArrayWrite(array, trim(string)//"_grid_coord1.nc", rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_GridGetCoord(grid, coordDim=2, staggerLoc=ESMF_STAGGERLOC_CENTER, array=array, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_ArraySet(array, name="lat_center", rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_ArrayWrite(array, trim(string)//"_grid_coord2.nc", rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - endif - - ! -- corners -- - - call ESMF_GridGetCoord(grid, staggerLoc=ESMF_STAGGERLOC_CORNER, isPresent=isPresent, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - if (isPresent) then - call ESMF_GridGetCoord(grid, coordDim=1, staggerLoc=ESMF_STAGGERLOC_CORNER, array=array, rc=rc) - if (.not. ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) then - call ESMF_ArraySet(array, name="lon_corner", rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_ArrayWrite(array, trim(string)//"_grid_corner1.nc", rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - endif - call ESMF_GridGetCoord(grid, coordDim=2, staggerLoc=ESMF_STAGGERLOC_CORNER, array=array, rc=rc) - if (.not. ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) then - call ESMF_ArraySet(array, name="lat_corner", rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_ArrayWrite(array, trim(string)//"_grid_corner2.nc", rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - endif - endif - - - ! -- mask -- - - call ESMF_GridGetItem(grid, itemflag=ESMF_GRIDITEM_MASK, staggerLoc=ESMF_STAGGERLOC_CENTER, isPresent=isPresent, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - if (isPresent) then - call ESMF_GridGetItem(grid, staggerLoc=ESMF_STAGGERLOC_CENTER, itemflag=ESMF_GRIDITEM_MASK, array=array, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_ArraySet(array, name="mask", rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_ArrayWrite(array, trim(string)//"_grid_mask.nc", rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - endif - - ! -- area -- - - call ESMF_GridGetItem(grid, itemflag=ESMF_GRIDITEM_AREA, staggerLoc=ESMF_STAGGERLOC_CENTER, isPresent=isPresent, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - if (isPresent) then - call ESMF_GridGetItem(grid, staggerLoc=ESMF_STAGGERLOC_CENTER, itemflag=ESMF_GRIDITEM_AREA, array=array, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_ArraySet(array, name="area", rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_ArrayWrite(array, trim(string)//"_grid_area.nc", rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - endif - - end subroutine Grid_Write - - END MODULE MODULE_DOMAIN_NUOPC_SET -! -!----------------------------------------------------------------------- diff --git a/src/nmm/module_DOMAIN_TASK_SPECS.F90 b/src/nmm/module_DOMAIN_TASK_SPECS.F90 deleted file mode 100644 index afa5655..0000000 --- a/src/nmm/module_DOMAIN_TASK_SPECS.F90 +++ /dev/null @@ -1,75 +0,0 @@ -!----------------------------------------------------------------------- -! - MODULE MODULE_DOMAIN_TASK_SPECS -! -!----------------------------------------------------------------------- -!*** Store fundamental values related to MPI tasks on each domain. -!----------------------------------------------------------------------- -! - USE module_KINDS - USE ESMF -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: DOMAIN_TASK_SPECS -! -!----------------------------------------------------------------------- -! - TYPE DOMAIN_TASK_SPECS -! - INTEGER(kind=KINT) :: PARENT_DOMAIN_ID !<-- The ID of the upper parent domain DOMAIN -! - INTEGER(kind=KINT) :: INPES & !<-- # of MPI tasks in I direction on this domain - ,JNPES !<-- # of MPI tasks in J direction on this domain -! - INTEGER(kind=KINT) :: NUM_PETS !<-- # of compute tasks on this domain -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: PET_MAP !<-- List of this domain's task IDs in terms of -! - INTEGER(kind=KINT),DIMENSION(1:2) :: INDX_MIN & !<-- This task's minimum I,J on this subdomain. - ,INDX_MAX !<-- This task's maximum I,J on this subdomain. -! -! - REAL(kind=KDBL),DIMENSION(:,:),ALLOCATABLE :: CELL_AREA & !<-- Area within each grid cell (m**2) - ,ROT_ANGLE & !<-- Rotation angle (radians) from NMMB grid to earth lat/lon - ,SEA_MASK !<-- Sea mask (1->water; 0->land) -! - REAL(kind=KDBL),DIMENSION(:,:), POINTER :: GLAT=>NULL() & - ,GLON=>NULL() & - ,VLAT=>NULL() & - ,VLON=>NULL() - -! The following 6 pointers are reference to the memory in the Grid for this nest -! Their values need to be updated on the nest processsors only when the nest moves - - INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: NEST_SEA_MASK=>NULL() !<-- Sea mask (1->water; 0->land) - REAL(kind=KDBL) ,DIMENSION(:,:),POINTER :: NEST_CELL_AREA=>NULL() !<-- Area within each grid cell (m**2) -! - REAL(kind=KDBL),DIMENSION(:,:), POINTER :: NEST_GLAT=>NULL() & - ,NEST_GLON=>NULL() & - ,NEST_VLAT=>NULL() & - ,NEST_VLON=>NULL() -! - LOGICAL(kind=KLOG) :: TASK_ACTIVE !<-- Is the current task active on this domain? -! - TYPE(ESMF_GRID) :: GRID !<-- The ESMF_GRID object associated with this domain -! - TYPE(ESMF_ROUTEHANDLE) :: PARENT2SELF & !<-- Regrid interpolators from upper parent to nests - ,SELF2PARENT !<-- Regrid interpolators from nests to upper parent -! - TYPE(ESMF_FIELD),ALLOCATABLE :: EXPORTFIELDSLIST(:) & !<-- The export Fields - ,IMPORTFIELDSLIST(:) !<-- The import Fields -! - END TYPE DOMAIN_TASK_SPECS -! -!----------------------------------------------------------------------- -! - END MODULE MODULE_DOMAIN_TASK_SPECS -! -!----------------------------------------------------------------------- diff --git a/src/nmm/module_DYNAMICS_ROUTINES.F90 b/src/nmm/module_DYNAMICS_ROUTINES.F90 deleted file mode 100644 index b32001d..0000000 --- a/src/nmm/module_DYNAMICS_ROUTINES.F90 +++ /dev/null @@ -1,5246 +0,0 @@ -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - module module_dynamics_routines -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -use mpi -use module_control,only:klog,kint,kfpt,kdbl,timef - -use module_my_domain_specs - -use module_clocktimes,only : timers - -use module_dm_parallel,only : looplimits - -use module_exchange,only: halo_exch -use module_fltbnds,only: polehn,polewn,swaphn,swapwn -use module_constants - -private - -public :: adv1,adv2 & -,cdwdt,cdzdt,ddamp,dht & -,hdiff & -,mono,pdtsdt,pgforce & -,updates,updatet,updateuv & -,vsound,vtoa - -integer(kind=kint),save :: & - jstart & -,jstop - -real(kind=kdbl) :: & - btim - -!----------------- -#ifdef ENABLE_SMP -!----------------- -integer(kind=kint) :: & - nth & -,omp_get_num_threads & -,omp_get_thread_num & -,tid - -external omp_get_num_threads,omp_get_thread_num -!------ -#endif -!------ - -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - contains -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- - subroutine pgforce & -(first,global,restart & -,lm & -,dt,ntimestep,rdyv & -,dsg2,pdsg1 & -,rdxv,wpdar & -,fis,pd & -,t,q,cw & -,pint & -,rtop & -!---temporary arguments------------------------------------------------- -,div & -,pcne,pcnw & -,pcx,pcy & -,tcu,tcv) -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -implicit none -!----------------------------------------------------------------------- -integer(kind=kint),parameter:: & - jw=01 ! rows w/o correction next to poles - -real(kind=kfpt),parameter:: & - cfc=1.533 & ! adams-bashforth positioning in time -,bfc=1.-cfc ! adams bashforth positioning in time -!----------------------------------------------------------------------- -logical(kind=klog),intent(in):: & - first & ! first pass -,global & ! global domain -,restart ! restart case - -integer(kind=kint),intent(in):: & - lm & ! total # of levels -,ntimestep ! the current timestep - -real(kind=kfpt),intent(in):: & - dt & ! dynamics time step -,rdyv ! 1/deltay - -real(kind=kfpt),dimension(1:lm),intent(in):: & - dsg2 & ! delta sigmas -,pdsg1 ! delta pressures - -real(kind=kfpt),dimension(jds:jde),intent(in):: & - rdxv & ! 1/deltax -,wpdar ! divergence correction weight - -real(kind=kfpt),dimension(ims:ime,jms:jme),intent(in):: & - fis & ! surface geopotential -,pd ! sigma range pressure difference - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(in):: & - t & ! temperature -,q & ! specific humidity -,cw ! condensate - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm+1),intent(in):: & - pint ! pressure at interfaces - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(out):: & - rtop ! RT/p - -!----------------------------------------------------------------------- -!---temporary arguments------------------------------------------------- -!----------------------------------------------------------------------- -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(out) :: & - div & ! horizontal mass divergence -,pcne & ! second term of pgf, ne direction -,pcnw & ! second term of pgf, nw direction -,pcx & ! second term of pgf, x direction -,pcy ! second term of pgf, y direction - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(inout) :: & - tcu & ! time change of u -,tcv ! time change of v -!----------------------------------------------------------------------- -!--local variables------------------------------------------------------ -!----------------------------------------------------------------------- -integer(kind=kint):: & - i & ! index in x direction -,icl & ! -,ich & ! -,ip & ! -,j & ! index in y direction -,jcl & ! lower bound for no divergence correction -,jch & ! upper bound for no divergence correction -,jp & ! -,l ! index in p direction - -real(kind=kfpt):: & - apd & ! hydrostatic pressure difference at the point -,apelp & ! pressure at the point -,dfip & ! delta phi -,dfdp & ! dfi/dp -,fiup & ! geopotential at the upper interface -,ppne & ! first term of pgf, ne direction -,ppnw & ! first term of pgf, nw direction -,ppx & ! first term of pgf, x direction -,ppy & ! first term of pgf, y direction -,rdu & ! -,rdv & ! -,rpdp & ! -,wprp ! divergence modification weight at the point - -real(kind=kfpt),dimension(its_h2:ite_h2,jts_h2:jte_h2):: & - apel & ! scratch, pressure in the middle of the layer -,dfi & ! scratch, delta phi -,filo & ! scratch, geopotential at lower interface -,fim ! scratch, geopotential in the middle of the layer - -real(kind=kfpt),dimension(its_h2:ite_h2,jts_h2:jte_h2,1:lm):: & - apel_3d & ! scratch, 3d copy of pressure in the middle of the layer -,fim_3d & ! scratch, 3d copy of geopotential in the middle of the layer -,dfi_3d ! scratch, 3d copy of delta phi - -real(kind=kfpt),dimension(its_b1:ite_h2,jts_b1:jte_h2):: & - pgne & ! scratch, pgf, ne direction -,pgnw ! scratch, pgf, nw direction - -real(kind=kfpt),dimension(its_b1:ite_h2,jts:jte_h2):: & - pgx ! scratch, pgf, x direction - -real(kind=kfpt),dimension(its:ite_h2,jts_b1:jte_h2):: & - pgy ! scratch, pgf, y direction -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- - - do j=jts_h2,jte_h2 - do i=its_h2,ite_h2 - filo(i,j)=fis(i,j) - enddo - enddo -!----------------------------------------------------------------------- -!---vertical grand loop------------------------------------------------- -!----------------------------------------------------------------------- -!----------------- -#ifdef ENABLE_SMP -!----------------- -!....................................................................... -!$omp parallel private(apelp,dfdp,dfip,fiup,i,j,jstart,jstop,l,nth,tid) -!....................................................................... - nth = omp_get_num_threads() - tid = omp_get_thread_num() - call looplimits(tid, nth, jts_h2, jte_h2, jstart, jstop) -!----------------- -#else -!----------------- - jstart = jts_h2 - jstop = jte_h2 -!----------------- -#endif -!----------------- -!----------------------------------------------------------------------- - do l=lm,1,-1 -!----------------------------------------------------------------------- - do j=jstart,jstop - do i=its_h2,ite_h2 - apelp=(pint(i,j,l)+pint(i,j,l+1))*0.5 - apel_3d(i,j,l)=apelp - dfdp=(q(i,j,l)*0.608+(1.-cw(i,j,l)))*t(i,j,l)*r/apelp - dfip=dfdp*(dsg2(l)*pd(i,j)+pdsg1(l)) - rtop(i,j,l)=dfdp - fiup=filo(i,j)+dfip - dfi_3d(i,j,l)=dfip*0.5 - fim_3d(i,j,l)=(filo(i,j)+fiup)*0.5 - filo(i,j)=fiup - enddo - enddo - enddo -!----------------- -#ifdef ENABLE_SMP -!----------------- -!....................................................................... -!$omp end parallel -!....................................................................... -!----------------- -#endif -!----------------- -!....................................................................... -!$omp parallel do & -!$omp private (apd,apel,dfi,fim,i,j,jch,jcl,l,pgne,pgnw,pgx,pgy, & -!$omp ppne,ppnw,ppx,ppy,rdu,rdv,rpdp,wprp,icl,ich,ip,jp) -!....................................................................... -!----------------------------------------------------------------------- -!---vertical grand loop------------------------------------------------- -!----------------------------------------------------------------------- - vertical_loop: do l=lm,1,-1 - do j=jts_h1,jte_h2 - do i=its_h1,ite_h2 - apel(i,j)= apel_3d(i,j,l) - fim(i,j) = fim_3d(i,j,l) - dfi(i,j) = dfi_3d(i,j,l) - enddo - enddo -!----------------------------------------------------------------------- -!---pressure gradient force components, behind h points----------------- -!----------------------------------------------------------------------- - do j=jts,jte_h2 - do i=its_b1,ite_h2 - ppx=(fim(i,j)-fim(i-1,j)) & - *(pint(i ,j ,l+1)+pint(i-1,j ,l+1) & - -pint(i ,j ,l )-pint(i-1,j ,l ))*0.5 - pcx(i,j,l)=(dfi (i-1,j )+dfi (i ,j )) & - *(apel(i ,j )-apel(i-1,j )) - pgx(i,j)=ppx+pcx(i,j,l) - enddo - enddo -! - do j=jts_b1,jte_h2 - do i=its,ite_h2 - ppy=(fim(i,j)-fim(i,j-1)) & - *(pint(i ,j ,l+1)+pint(i ,j-1,l+1) & - -pint(i ,j ,l )-pint(i ,j-1,l ))*0.5 - pcy(i,j,l)=(dfi (i ,j-1)+dfi (i ,j )) & - *(apel(i ,j )-apel(i ,j-1)) - pgy(i,j)=ppy+pcy(i,j,l) - enddo - enddo -! - do j=jts_b1,jte_h2 - do i=its_b1,ite_h2 - ppne=(fim(i,j)-fim(i-1,j-1)) & - *(pint(i-1,j-1,l+1)+pint(i ,j ,l+1) & - -pint(i-1,j-1,l )-pint(i ,j ,l ))*0.5 - ppnw=(fim(i-1,j)-fim(i,j-1)) & - *(pint(i-1,j ,l+1)+pint(i ,j-1,l+1) & - -pint(i-1,j ,l )-pint(i ,j-1,l ))*0.5 - pcne(i,j,l)=(dfi (i-1,j-1)+dfi (i ,j )) & - *(apel(i ,j )-apel(i-1,j-1)) - pcnw(i,j,l)=(dfi (i ,j-1)+dfi (i-1,j )) & - *(apel(i-1,j )-apel(i ,j-1)) - pgne(i,j)=ppne+pcne(i,j,l) - pgnw(i,j)=ppnw+pcnw(i,j,l) - enddo - enddo -!----------------------------------------------------------------------- -!---divergence correction, janjic 1974 mwr, 1979 beitrage--------------- -!----------------------------------------------------------------------- - if(global) then -!----------------------------------------------------------------------- - jcl=jds - jch=jds-1+jw -! - if(jts<=jch)then - do j=max(jts,jcl),min(jte,jch) - do i=its,ite - div(i,j,l)=0. - enddo - enddo - endif -! - jcl=jde-jw+1 - jch=jde -! - if(jte>=jcl)then - do j=max(jts,jcl),min(jte,jch) - do i=its,ite - div(i,j,l)=0. - enddo - enddo - endif -! - jcl=jds+jw - if(jts<=jcl.and.jte>=jcl)then - wprp=wpdar(jcl) - do i=its_b1,ite_b1 - div(i,jcl,l)=( pgx(i+1 ,jcl)-pgx(i,jcl) & - + pgy(i ,jcl+1) & - -(pgne(i+1,jcl+1) & - + pgnw(i ,jcl+1))*0.5)*wprp - enddo - endif -! - jch=jde-jw - if(jts<=jch.and.jte>=jch)then - wprp=wpdar(jch) - do i=its_b1,ite_b1 - div(i,jch,l)=( pgx(i+1,jch)-pgx(i,jch) & - -pgy(i ,jch) & - -(-pgne(i ,jch) & - -pgnw(i+1,jch))*0.5)*wprp - enddo - endif -! - jcl=jds+jw+1 - jch=jde-jw-1 - if(jte>=jcl.and.jts<=jch)then - do j=max(jts,jcl),min(jte,jch) - wprp=wpdar(j) - do i=its_b1,ite_b1 - div(i,j,l)=(pgx(i+1,j)-pgx(i,j) & - +pgy(i,j+1)-pgy(i,j) & - -(pgne(i+1,j+1)-pgne(i,j) & - +pgnw(i,j+1)-pgnw(i+1,j))*0.5)*wprp - enddo - enddo - endif -!----------------------------------------------------------------------- - else ! regional -!----------------------------------------------------------------------- - icl=ids+2 - ich=ide-2 -! - jcl=jds+2 - jch=jde-2 -! - if(s_bdy) then - jp=jds+1 - wprp=wpdar(jp) - do i=max(its,icl),min(ite,ich) - div(i,jp,l)=(pgx(i+1,jp)-pgx(i,jp) & - +pgy(i,jp+1) & - -(pgne(i+1,jp+1) & - +pgnw(i,jp+1))*0.5)*wprp - enddo - endif -! - if(n_bdy) then - jp=jde-1 - wprp=wpdar(jp) - do i=max(its,icl),min(ite,ich) - div(i,jp,l)=(pgx(i+1,jp)-pgx(i,jp) & - -pgy(i,jp) & - -(-pgne(i,jp) & - -pgnw(i+1,jp))*0.5)*wprp - enddo - endif -! - if(w_bdy) then - ip=ids+1 - do j=max(jts,jcl),min(jte,jch) - wprp=wpdar(j) - div(ip,j,l)=(pgx(ip+1,j) & - +pgy(ip,j+1)-pgy(ip,j) & - -(pgne(ip+1,j+1) & - -pgnw(ip+1,j))*0.5)*wprp - enddo - endif -! - if(e_bdy) then - ip=ide-1 - do j=max(jts,jcl),min(jte,jch) - wprp=wpdar(j) - div(ip,j,l)=(-pgx(ip,j) & - +pgy(ip,j+1)-pgy(ip,j) & - -(-pgne(ip,j) & - +pgnw(ip,j+1))*0.5)*wprp - enddo - endif -! - if(s_bdy.and.w_bdy) then - ip=ids+1 - jp=jds+1 - wprp=wpdar(jp) - div(ip,jp,l)=(pgx(ip+1,jp) & - +pgy(ip,jp+1) & - -(pgne(ip+1,jp+1))*0.5)*wprp - endif -! - if(s_bdy.and.e_bdy) then - ip=ide-1 - jp=jds+1 - wprp=wpdar(jp) - div(ip,jp,l)=(-pgx(ip,jp) & - +pgy(ip,jp+1) & - -(pgnw(ip,jp+1))*0.5)*wprp - endif -! - if(n_bdy.and.w_bdy) then - ip=ids+1 - jp=jde-1 - wprp=wpdar(jp) - div(ip,jp,l)=(pgx(ip+1,jp) & - -pgy(ip,jp) & - -(-pgnw(ip+1,jp))*0.5)*wprp - endif -! - if(n_bdy.and.e_bdy) then - ip=ide-1 - jp=jde-1 - wprp=wpdar(jp) - div(ip,jp,l)=(-pgx(ip,jp) & - -pgy(ip,jp) & - -(-pgne(ip,jp))*0.5)*wprp - endif -! - do j=jts_b2,jte_b2 - wprp=wpdar(j) - do i=its_b2,ite_b2 - div(i,j,l)=(pgx(i+1,j)-pgx(i,j) & - +pgy(i,j+1)-pgy(i,j) & - -(pgne(i+1,j+1)-pgne(i,j) & - +pgnw(i,j+1)-pgnw(i+1,j))*0.5)*wprp - enddo - enddo -!----------------------------------------------------------------------- - endif ! global/regional branching -!----------------------------------------------------------------------- -!---first pass switch--------------------------------------------------- -!----------------------------------------------------------------------- - if(.not.first.or.restart) then -!----------------------------------------------------------------------- -!---updating u and v due to pgf force, end of time-step for u and v----- -!----------------------------------------------------------------------- - rdv=rdyv*dt - do j=jts_b1,jte_b2 - rdu=rdxv(j)*dt - do i=its_b1,ite_b2 - apd=(pd(i,j)+pd(i+1,j)+pd(i,j+1)+pd(i+1,j+1))*0.25 - rpdp=0.3333333333/(dsg2(l)*apd+pdsg1(l)) -! - tcu(i,j,l)=-((pgx(i+1,j)+pgx(i+1,j+1)) & - +(pgne(i+1,j+1)-pgnw(i+1,j+1))*0.5)*rdu*rpdp & - +tcu(i,j,l) - tcv(i,j,l)=-((pgy(i,j+1)+pgy(i+1,j+1)) & - +(pgne(i+1,j+1)+pgnw(i+1,j+1))*0.5)*rdv*rpdp & - +tcv(i,j,l) - enddo - enddo -!----------------------------------------------------------------------- - else -!----------------------------------------------------------------------- - do j=jts_b1,jte_b2 - do i=its_b1,ite_b2 - tcu(i,j,l)=0. - tcv(i,j,l)=0. - enddo - enddo -!----------------------------------------------------------------------- - endif -!----------------------------------------------------------------------- -! - enddo vertical_loop -!....................................................................... -!$omp end parallel do -!....................................................................... -! -!----------------------------------------------------------------------- -! - endsubroutine pgforce -! -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- - subroutine dht & -(global & -,lm & -,dyv & -,dsg2,pdsg1 & -,dxv,fcp,fdiv & -,pd,pdo & -,u,v & -,omgalf & -!---temporary arguments------------------------------------------------- -,pcne,pcnw,pcx,pcy,pfne,pfnw,pfx,pfy,div,tdiv) -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -implicit none -!----------------------------------------------------------------------- -real(kind=kfpt),parameter:: & - cfc=1.533 & ! adams-bashforth positioning in time -,bfc=1.-cfc ! adams bashforth positioning in time -!----------------------------------------------------------------------- -logical(kind=klog),intent(in):: & - global - -integer(kind=kint),intent(in):: & - lm ! total # of levels - -real(kind=kfpt),intent(in):: & - dyv ! deltay, v point - -real(kind=kfpt),dimension(1:lm),intent(in):: & - dsg2 & ! delta sigmas -,pdsg1 ! delta pressures - -real(kind=kfpt),dimension(jds:jde),intent(in):: & - dxv & ! deltax, v point -,fcp & ! -,fdiv ! - -real(kind=kfpt),dimension(ims:ime,jms:jme),intent(in):: & - pd & ! sigma range pressure difference -,pdo ! sigma range pressure difference - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(in):: & - u & ! u wind component -,v ! v wind component - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(out):: & - omgalf ! omega-alfa (horizontal) -!----------------------------------------------------------------------- -!---temporary arguments------------------------------------------------- -!----------------------------------------------------------------------- -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(in) :: & - pcne & ! second term of pgf, ne direction -,pcnw & ! second term of pgf, nw direction -,pcx & ! second term of pgf, x direction -,pcy ! second term of pgf, y direction - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(out) :: & - pfne & ! mass flux, ne direction -,pfnw & ! mass flux, nw direction -,pfx & ! mass flux, x direction -,pfy & ! mass flux, y direction -,tdiv ! integrated horizontal mass divergence - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(inout) :: & - div ! horizontal mass divergence -!----------------------------------------------------------------------- -!--local variables------------------------------------------------------ -!----------------------------------------------------------------------- -integer(kind=kint):: & - i & ! index in x direction -,j & ! index in y direction -,l ! index in p direction - -real(kind=kfpt):: & - dyp1 & ! -,dyp & ! -,dxp1 & ! -,dxp & ! -,fcpp & ! -,fdp & ! -,pdp & ! hydrostatic pressure difference at the point -,pdxp & ! hydrostatic pressure at the point -,pdyp & ! hydrostatic pressure at the point -,pdnep & ! hydrostatic pressure at the point -,pdnwp & ! hydrostatic pressure at the point -,udy & ! -,vdx & ! -,udy1 & ! -,vdx1 ! - -real(kind=kfpt),dimension(its_b1:ite_h2,jts_b1:jte_h2):: & - pdne & ! hydrostatic pressure difference at the point -,pdnw & ! hydrostatic pressure difference at the point -,pdx & ! hydrostatic pressure difference at the point -,pdy & ! hydrostatic pressure difference at the point -,tne & ! temperature flux, ne direction -,tnw & ! temperature flux, nw direction -,tx & ! temperature flux, x direction -,ty ! temperature flux, y direction -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - dyp1=dyv - dyp=dyp1*0.5 -! -!----------------- -#ifdef ENABLE_SMP -!----------------- -!....................................................................... -!$omp parallel & -!$omp private(i,j,jstart,jstop,nth,tid) -!....................................................................... - nth = omp_get_num_threads() - tid = omp_get_thread_num() - call looplimits(tid, nth,jts_b1,jte_h2,jstart,jstop) -!----------------- -#else -!----------------- - jstart = jts_b1 - jstop = jte_h2 -!----------------- -#endif -!----------------- -! - do j=jstart,jstop - do i=its_b1,ite_h2 - pdx (i,j)=((pd (i-1,j)+pd (i,j))*cfc & - +(pdo(i-1,j)+pdo(i,j))*bfc)*0.5 - enddo - enddo -! - do j=jstart,jstop - do i=its_b1,ite_h2 - pdy (i,j)=((pd (i,j-1)+pd (i,j))*cfc & - +(pdo(i,j-1)+pdo(i,j))*bfc)*0.5 - enddo - enddo -! - do j=jstart,jstop - do i=its_b1,ite_h2 - pdne(i,j)=((pd (i-1,j-1)+pd (i,j))*cfc & - +(pdo(i-1,j-1)+pdo(i,j))*bfc)*0.5 - pdnw(i,j)=((pd (i,j-1)+pd (i-1,j))*cfc & - +(pdo(i,j-1)+pdo(i-1,j))*bfc)*0.5 - enddo - enddo -!----------------- -#ifdef ENABLE_SMP -!----------------- -!....................................................................... -!$omp end parallel -!....................................................................... -!----------------- -#endif -!----------------- -!----------------------------------------------------------------------- -!---vertical grand loop------------------------------------------------- -!----------------------------------------------------------------------- -! -!....................................................................... -!$omp parallel do & -!$omp private (dxp,dxp1,fcpp,fdp,i,j,l,pdnep,pdnwp,pdp,pdxp,pdyp, & -!$omp tne,tnw,tx,ty,udy,udy1,vdx,vdx1) -!....................................................................... -!----------------------------------------------------------------------- - vertical_loop: do l=1,lm -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!---mass and pressure fluxes, on h points------------------------------- -!----------------------------------------------------------------------- - pdp=pdsg1(l) - do j=jts_b1,jte_h2 - dxp1=dxv(j-1) - dxp=dxp1*0.5 - do i=its_b1,ite_h2 -!----------------------------------------------------------------------- - pdxp=dsg2(l)*pdx(i,j)+pdp - pdyp=dsg2(l)*pdy(i,j)+pdp - pdnep=dsg2(l)*pdne(i,j)+pdp - pdnwp=dsg2(l)*pdnw(i,j)+pdp -! - udy=(u(i-1,j-1,l)+u(i-1,j,l))*dyp - vdx=(v(i-1,j-1,l)+v(i,j-1,l))*dxp -! - pfx(i,j,l)=udy*pdxp - pfy(i,j,l)=vdx*pdyp -! - udy1=u(i-1,j-1,l)*dyp1 - vdx1=v(i-1,j-1,l)*dxp1 -! - pfne(i,j,l)=( udy1+vdx1)*pdnep - pfnw(i,j,l)=(-udy1+vdx1)*pdnwp -! - tx(i,j)=pcx(i,j,l)*udy - ty(i,j)=pcy(i,j,l)*vdx -! - tne(i,j)=pcne(i,j,l)*( udy1+vdx1) - tnw(i,j)=pcnw(i,j,l)*(-udy1+vdx1) - enddo - enddo -!----------------------------------------------------------------------- -!---divergence and hor. pressure advection in t eq.--------------------- -!----------------------------------------------------------------------- - do j=jts_b1,jte_b1_h1 - fdp=fdiv(j) - fcpp=fcp(j) - do i=its_b1,ite_b1_h1 - div(i,j,l)=((pfx (i+1,j ,l)-pfx (i ,j ,l) & - +pfy (i ,j+1,l)-pfy (i ,j ,l)) & - +(pfne(i+1,j+1,l)-pfne(i ,j ,l) & - +pfnw(i ,j+1,l)-pfnw(i+1,j ,l))*0.25)*fdp & - +div(i,j,l) - tdiv(i,j,l)=div(i,j,l) - omgalf(i,j,l)=((tx (i ,j )+tx (i+1,j ) & - +ty (i ,j )+ty (i ,j+1)) & - +(tne(i+1,j+1)+tne(i ,j ) & - +tnw(i ,j+1)+tnw(i+1,j ))*0.25) & - *fcpp/(dsg2(l)*pd(i,j)+pdsg1(l)) - enddo - enddo -!----------------------------------------------------------------------- -!---zero divergence along regional domain boundaries-------------------- -!----------------------------------------------------------------------- - if(.not.global) then - if(s_bdy)then - do i=ims,ime - div (i,jds,l)=0. - tdiv(i,jds,l)=0. - enddo - endif -! - if(n_bdy)then - do i=ims,ime - div (i,jde,l)=0. - tdiv(i,jde,l)=0. - enddo - endif -! - if(w_bdy)then - do j=jms,jme - div (ids,j,l)=0. - tdiv(ids,j,l)=0. - enddo - endif -! - if(e_bdy)then - do j=jms,jme - div (ide,j,l)=0. - tdiv(ide,j,l)=0. - enddo - endif - endif -!----------------------------------------------------------------------- - enddo vertical_loop -!----------------------------------------------------------------------- -!....................................................................... -!$omp end parallel do -!....................................................................... -!----------------- -#ifdef ENABLE_SMP -!----------------- -!....................................................................... -!$omp parallel & -!$omp private(i,j,jstart,jstop,nth,tid) -!....................................................................... - nth = omp_get_num_threads() - tid = omp_get_thread_num() - call looplimits(tid, nth,jts_b1,jte_b1,jstart,jstop) -!----------------- -#else -!----------------- - jstart = jts_b1 - jstop = jte_b1 -!----------------- -#endif -!----------------- - do l=2,lm - do j=jstart,jstop - do i=its_b1,ite_b1 - tdiv(i,j,l)=tdiv(i,j,l-1)+tdiv(i,j,l) - enddo - enddo - enddo -!----------------- -#ifdef ENABLE_SMP -!----------------- -!....................................................................... -!$omp end parallel -!....................................................................... -!----------------- -#endif -!----------------- - -!----------------------------------------------------------------------- -! - endsubroutine dht -! -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- - subroutine ddamp & -(lm & -,ddmpv,pdtop & -,dsg2,pdsg1 & -,sg1,sg2 & -,ddmpu & -,freerun & -,pd,pdo & -,u,v & -!---temporary arguments------------------------------------------------- -,div) -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -implicit none -!----------------------------------------------------------------------- -real(kind=kfpt),parameter:: & - cfc=1.533 & ! adams-bashforth positioning in time -,bfc=1.-cfc ! adams bashforth positioning in time -!----------------------------------------------------------------------- -logical(kind=klog),intent(in):: & - freerun - -integer(kind=kint),intent(in):: & - lm ! total # of levels - -real(kind=kfpt),intent(in):: & - ddmpv & ! divergence damping, v component -,pdtop ! pressure coordinate depth - -real(kind=kfpt),dimension(1:lm),intent(in):: & - dsg2 & ! delta sigmas -,pdsg1 ! delta pressures - -real(kind=kfpt),dimension(1:lm+1),intent(in):: & - sg1 & ! -,sg2 ! - -real(kind=kfpt),dimension(jds:jde),intent(in):: & - ddmpu ! divergence damping, u direction - -real(kind=kfpt),dimension(ims:ime,jms:jme),intent(in):: & - pd & ! sigma range pressure difference -,pdo ! sigma range pressure difference - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(inout):: & - u & ! u wind component -,v ! v wind component - -!---temporary arguments------------------------------------------------- -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm):: & - div ! horizontal mass divergence - -!--local variables------------------------------------------------------ -logical(kind=klog),parameter:: & - extmod=.true. - -real(kind=kfpt),parameter:: & - assimfc=5.0 - -integer(kind=kint):: & - i & ! index in x direction -,j & ! index in y direction -,l ! index in p direction - -real(kind=kfpt):: & - dfac & ! fcim enhancement factor at top -,dpb & ! -,dpl & ! -,fcim & ! relative weight of internal mode damping -,fcxm & ! blow up factor for external mode damping -,fint & ! -,rdpd & ! -,dud & ! -,dvd ! - -real(kind=kfpt),dimension(ims:ime,jms:jme):: & - apd & ! -,dive & ! -,rddu & ! -,rddv ! -! -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- - dfac=9. - dpb=1500. - fint=(1.-dfac)/dpb -!----------------------------------------------------------------------- -! - dvd=ddmpv - do j=jts_b1,jte_b2 - do i=its_b1,ite_b2 - apd(i,j)=((pd (i ,j )+pd (i+1,j ) & - +pd (i ,j+1)+pd (i+1,j+1))*cfc & - +(pdo(i ,j )+pdo(i+1,j ) & - +pdo(i ,j+1)+pdo(i+1,j+1))*bfc)*0.25 - enddo - enddo -! -!----------------------------------------------------------------------- -!---external mode------------------------------------------------------- -!----------------------------------------------------------------------- -! - if(extmod) then - if(freerun) then - fcxm=1.0 - else - fcxm=assimfc - endif -! -!----------------- -#ifdef ENABLE_SMP -!----------------- -!....................................................................... -!$omp parallel private(i,j,l,jstart,jstop,nth,tid) -!....................................................................... - nth = omp_get_num_threads() - tid = omp_get_thread_num() - call looplimits(tid, nth,jts_b1,jte_b1_h2,jstart,jstop) -!----------------- -#else -!----------------- - jstart = jts_b1 - jstop = jte_b1_h2 -!----------------- -#endif -!----------------- - do j=jstart,jstop - do i=its_b1,ite_b1_h2 - dive(i,j)=div(i,j,1) - enddo - enddo - do l=2,lm - do j=jstart,jstop - do i=its_b1,ite_b1_h2 - dive(i,j)=div(i,j,l)+dive(i,j) - enddo - enddo - enddo -!----------------- -#ifdef ENABLE_SMP -!----------------- -!....................................................................... -!$omp end parallel -!....................................................................... -!----------------- -#endif -!----------------- -! - do j=jts_b1,jte_b2 - dud=ddmpu(j) - do i=its_b1,ite_b2 - rdpd=fcxm/(sg1(lm+1)*pdtop+sg2(lm+1)*apd(i,j)) - rddu(i,j)=(dive(i+1,j)+dive(i+1,j+1) & - -dive(i ,j)-dive(i ,j+1))*dud*rdpd - rddv(i,j)=(dive(i,j+1)+dive(i+1,j+1) & - -dive(i,j )-dive(i+1,j ))*dvd*rdpd - enddo - enddo -! - jstart = jts_b1 - jstop = jte_b2 -!....................................................................... -!$omp parallel do private(dpl,dud,fcim,i,j,l,rdpd) -!....................................................................... - do l=1,lm - if(freerun) then - dpl=sg1(l+1)*pdtop+sg2(l+1)*10000. - if(dpl.lt.dpb) then - fcim=fint*dpl+dfac - else - fcim=1. - endif - else - fcim=assimfc - endif -! - do j=jstart,jstop - dud=ddmpu(j) - do i=its_b1,ite_b2 - rdpd=fcim/(dsg2(l)*apd(i,j)+pdsg1(l)) - u(i,j,l)=((div(i+1,j,l)+div(i+1,j+1,l) & - -div(i ,j,l)-div(i ,j+1,l))*dud)*rdpd & - +rddu(i,j)+u(i,j,l) - v(i,j,l)=((div(i,j+1,l)+div(i+1,j+1,l) & - -div(i,j ,l)-div(i+1,j ,l))*dvd)*rdpd & - +rddv(i,j)+v(i,j,l) - enddo - enddo - enddo ! end of vertical loop -!....................................................................... -!$omp end parallel do -!....................................................................... - -!----------------------------------------------------------------------- -! - else -! -!----------------------------------------------------------------------- -!---divergence damping-------------------------------------------------- -!----------------------------------------------------------------------- -!....................................................................... -!$omp parallel do private(dpl,dud,dvd,fcim,i,j,l,rdpd) -!....................................................................... - do l=1,lm - if(freerun) then - dpl=sg1(l+1)*pdtop+sg2(l+1)*10000. - if(dpl.lt.dpb) then - fcim=fint*dpl+dfac - else - fcim=1. - endif - else - fcim=assimfc - endif -! - dvd=ddmpv - do j=jts_b1,jte_b2 - dud=ddmpu(j) - do i=its_b1,ite_b2 - rdpd=fcim/(dsg2(l)*apd(i,j)+pdsg1(l)) - u(i,j,l)=(div(i+1,j,l)+div(i+1,j+1,l) & - -div(i ,j,l)-div(i ,j+1,l)) & - *dud*rdpd+u(i,j,l) - v(i,j,l)=(div(i,j+1,l)+div(i+1,j+1,l) & - -div(i,j ,l)-div(i+1,j ,l)) & - *dvd*rdpd+v(i,j,l) - enddo - enddo - enddo ! end of vertical loop -!....................................................................... -!$omp end parallel do -!....................................................................... -!----------------------------------------------------------------------- -! - endif -! -!----------------------------------------------------------------------- -! - endsubroutine ddamp -! -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- - subroutine pdtsdt & -(lm & -,dt & -,sg2 & -,pd & -,pdo,psdt & -,psgdt & -!---temporary arguments------------------------------------------------- -,div,tdiv) -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -implicit none -!----------------------------------------------------------------------- -integer(kind=kint),intent(in):: & - lm ! total # of levels - -real(kind=kfpt),intent(in):: & - dt ! time step - -real(kind=kfpt),dimension(1:lm+1),intent(in):: & - sg2 ! - -real(kind=kfpt),dimension(ims:ime,jms:jme),intent(inout):: & - pd ! sigma range pressure difference - -real(kind=kfpt),dimension(ims:ime,jms:jme),intent(out):: & - pdo & ! sigma range pressure difference -,psdt ! hydrostatic pressure tendency - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm-1),intent(out):: & - psgdt ! vertical mass flux -!----------------------------------------------------------------------- -!---temporary arguments------------------------------------------------- -!----------------------------------------------------------------------- -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm):: & - div & ! horizontal mass divergence -,tdiv ! integrated unfiltered mass divergence -!----------------------------------------------------------------------- -!--local variables------------------------------------------------------ -!----------------------------------------------------------------------- -integer(kind=kint):: & - i & ! index in x direction -,j & ! index in y direction -,l & ! index in p direction -,loc_npts & ! local point counts for diag -,glb_npts & ! global point counts for diag -,iret & -,rc - - -real(kind=kfpt) :: & - task_change & ! task sum of abs(surface pressure change) -,global_change ! domain total sum -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -!----------------- -#ifdef ENABLE_SMP -!----------------- -!....................................................................... -!$omp parallel & -!$omp private(i,j,jstart,jstop,l,nth,tid) -!....................................................................... - nth = omp_get_num_threads() - tid = omp_get_thread_num() - call looplimits(tid, nth,jts_b1,jte_b1,jstart,jstop) -!----------------- -#else -!----------------- - jstart = jts_b1 - jstop = jte_b1 -!----------------- -#endif -!----------------- - do l=2,lm - do j=jstart,jstop - do i=its_b1,ite_b1 - div(i,j,l)=div(i,j,l-1)+div(i,j,l) - enddo - enddo - enddo -!----------------- -#ifdef ENABLE_SMP -!----------------- -!....................................................................... -!$omp end parallel -!....................................................................... -!----------------- -#endif -!----------------- - -!----------------------------------------------------------------------- - do j=jts_h2,jte_h2 - do i=its_h2,ite_h2 - psdt(i,j)=0. - pdo(i,j)=pd(i,j) - enddo - enddo -! -!----------------- -#ifdef ENABLE_SMP -!----------------- -!....................................................................... -!$omp parallel & -!$omp private(i,j,jstart,jstop,l,nth,tid) -!....................................................................... - nth = omp_get_num_threads() - tid = omp_get_thread_num() - call looplimits(tid, nth,jts_b1,jte_b1,jstart,jstop) -!----------------- -#else -!----------------- - jstart = jts_b1 - jstop = jte_b1 -!----------------- -#endif -!----------------- - -! loc_npts=0 -! task_change=0. - - do j=jstart,jstop - do i=its_b1,ite_b1 - psdt(i,j)=-div(i,j,lm) - pd(i,j)=psdt(i,j)*dt+pd(i,j) - enddo - enddo - -! do j=jstart,jstop -! do i=its_b1,ite_b1 -! if (abs(psdt(i,j)*dt) .ge. 250. .or. psdt(i,j) .ne. psdt(i,j)) then -! write(0,*) 'big PD change...I,J, change: ', I,J, psdt(i,j)*dt -! write(0,*) 'previous PD was: ', PD(I,J)-psdt(i,j)*dt -! endif -! -! if (abs(psdt(i,j)*dt) .ge. 5000.) then -! write(0,*) 'huge PD change...I,J, change: ', I,J, psdt(i,j)*dt -! call ESMF_Finalize(endflag=ESMF_END_ABORT) -! endif -! -! loc_npts=loc_npts+1 -! task_change=task_change+abs(PSDT(I,J)) ! * (108./abs(dt)) ) ! .01*10800/dt (hPa/3 h) -! -! enddo -! enddo -! -! call mpi_reduce(task_change, global_change, 1, mpi_real, mpi_sum,0, & -! mpi_comm_comp, iret) -! -! call mpi_reduce(loc_npts, glb_npts, 1, mpi_integer, mpi_sum,0, & -! mpi_comm_comp, iret) -! -! if (mype == 0) then -! if (dt .gt. 0) then -! write(0,*) 'FWD avg global change (Pa/timestep): ', GLOBAL_CHANGE/ GLB_NPTS -! else -! write(0,*) 'BCKWD avg global change (Pa/timestep): ', GLOBAL_CHANGE/ GLB_NPTS -! endif -! endif - -!----------------------------------------------------------------------- -!---boundary conditions------------------------------------------------- -!----------------------------------------------------------------------- - do l=1,lm-1 - do j=jstart,jstop - do i=its_b1,ite_b1 - psgdt(i,j,l)=-(-tdiv(i,j,lm)*sg2(l+1)+tdiv(i,j,l)) - enddo - enddo - enddo -!----------------- -#ifdef ENABLE_SMP -!----------------- -!....................................................................... -!$omp end parallel -!....................................................................... -!----------------- -#endif -!----------------- -!----------------------------------------------------------------------- -! - endsubroutine pdtsdt -! -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- - subroutine adv1 & -(global,secadv & -,lm,lnsad,inpes,jnpes & -,dt,dyv,rdyh,rdyv & -,dsg2,pdsg1 & -,curv,dxv,fad,fah,rdxh,rdxv & -,f,pd,pdo & -,omgalf,psgdt & -,t,u,v & -,tp,up,vp & -!---temporary arguments------------------------------------------------- -,pfne,pfnw,pfx,pfy,tct,tcu,tcv) -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -implicit none -!----------------------------------------------------------------------- -real(kind=kfpt),parameter:: & - cfc=1.533 & ! adams-bashforth positioning in time -,bfc=1.-cfc & ! adams bashforth positioning in time -,epscm=2.e-6 & ! a floor value (not used) -,pfc=1.+4./6. & ! 4th order momentum advection -,sfc=-1./6. & ! 4th order momentum advection -,w1=0.9 & ! crank-nicholson uncentering -!,w1=0.0 & ! crank-nicholson uncentering -,w2=2.-w1 ! crank-nicholson uncentering - -logical(kind=klog),intent(in):: & - global & ! global or regional -,secadv ! second order momentum advection - -integer(kind=kint),intent(in):: & - lm & ! total # of levels -,lnsad & ! # of boundary lines w. upstream advection -,inpes & ! domain decomposition parameter -,jnpes ! domain decomposition parameter - -real(kind=kfpt),intent(in):: & - dt & ! dynamics time step -,dyv & ! deltay -,rdyh & ! 1/deltay -,rdyv ! 1/deltay - -real(kind=kfpt),dimension(1:lm),intent(in):: & - dsg2 & ! delta sigmas -,pdsg1 ! delta pressures - -real(kind=kfpt),dimension(jds:jde),intent(in):: & - curv & ! curvature -,dxv & ! dxv -,fad & ! grid factor -,fah & ! grid factor -,rdxh & ! 1/deltax -,rdxv ! 1/deltax - -real(kind=kfpt),dimension(ims:ime,jms:jme),intent(in):: & - f & ! coriolis parameter -,pd & ! sigma range pressure difference -,pdo ! sigma range pressure difference - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm-1),intent(in):: & - psgdt ! vertical mass flux - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(in):: & - omgalf & ! -,t & ! temperature -,u & ! u wind component -,v ! v wind component - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(inout):: & - tp & ! old temperature -,up & ! old u -,vp ! old v -!----------------------------------------------------------------------- -!---temporary arguments------------------------------------------------- -!----------------------------------------------------------------------- -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(in) :: & - pfne & ! mass flux, ne direction -,pfnw & ! mass flux, nw direction -,pfx & ! mass flux, x direction -,pfy ! mass flux, y direction - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(out) :: & - tct & ! time change of temperature -,tcu & ! time change of u -,tcv ! time change of v -!----------------------------------------------------------------------- -!--local variables------------------------------------------------------ -!----------------------------------------------------------------------- -integer(kind=kint):: & - i & ! index in x direction -,iap & ! offset in x direction -,ibeg & ! starting i in some horiz advec loops -,iend & ! ending i in some horiz advec loops -,j & ! index in y direction -,jap & ! offset in y direction -,jbeg & ! starting j in some horiz advec loops -,jend & ! ending j in some horiz advec loops -,l ! index in p direction - -real(kind=kfpt):: & - cf & ! temporary -,cmt & ! temporary -,cmw & ! temporary -,crv & ! curvature -,dtq & ! dt/4 -,dts & ! dt/16 -,dux1 & ! momentum advection component -,duy1 & ! momentum advection component -,dvx1 & ! momentum advection component -,dvy1 & ! momentum advection component -,dxody & ! -,dyodx & ! -,emhp & ! scaling in x direction -,enhp & ! scaling in y direction -,emvp & ! scaling in x direction -,envp & ! scaling in y direction -,fadp & ! grid factor at the point -,fahp & ! temporary grid factor -,fdpp & ! temporary grid factor -,fp & ! coriolis parameter factor -,fpp & ! coriolis with curvature -,pp & ! scaled trajectory, x direction -,qq & ! scaled trajectory, y direction -,rdp & ! 1/deltap -,rdxp & ! -,rdyp & ! -,vvlo & ! vertical velocity, lower interface -,vvup & ! vertical velocity, upper interface -,pvvup ! vertical mass flux, upper interface - -real(kind=kfpt),dimension(its:ite,jts:jte):: & - pdop & ! hydrostatic pressure difference at v points -,pvvlo ! vertical mass flux, lower interface - -real(kind=kfpt),dimension(its_b1:ite_b1_h1,jts_b1:jte_b1_h1):: & - pfnex1 & ! average mass flux for momentum advection -,pfney1 & ! average mass flux for momentum advection -,pfnwx1 & ! average mass flux for momentum advection -,pfnwy1 & ! average mass flux for momentum advection -,pfxx1 & ! average mass flux for momentum advection -,pfxy1 & ! average mass flux for momentum advection -,pfyx1 & ! average mass flux for momentum advection -,pfyy1 & ! average mass flux for momentum advection -,ufnex1 & ! average mass flux for momentum advection -,ufney1 & ! average mass flux for momentum advection -,ufnwx1 & ! average mass flux for momentum advection -,ufnwy1 & ! average mass flux for momentum advection -,ufxx1 & ! average mass flux for momentum advection -,ufxy1 & ! average mass flux for momentum advection -,ufyx1 & ! average mass flux for momentum advection -,ufyy1 & ! average mass flux for momentum advection -,vfnex1 & ! average mass flux for momentum advection -,vfney1 & ! average mass flux for momentum advection -,vfnwx1 & ! average mass flux for momentum advection -,vfnwy1 & ! average mass flux for momentum advection -,vfxx1 & ! average mass flux for momentum advection -,vfxy1 & ! average mass flux for momentum advection -,vfyx1 & ! average mass flux for momentum advection -,vfyy1 ! average mass flux for momentum advection - -real(kind=kfpt),dimension(its_b1:ite_h1,jts_b1:jte_h1):: & - tne & ! temperature flux, ne direction -,tnw & ! temperature flux, nw direction -,tx & ! temperature flux, x direction -,ty ! temperature flux, y direction - -real(kind=kfpt),dimension(its_h1:ite_h1,jts_h1:jte_h1):: & - t1 ! extrapolated temperature between time levels - -real(kind=kfpt),dimension(ims:ime,jms:jme):: & - u2d & ! 4th order diagonal u between time levels -,v2d & ! 4th order diagonal v between time levels - -!real(kind=kfpt),dimension(its_h1:ite_h1,jts_h1:jte_h1):: & -,u1d & ! extrapolated diagonal u between time levels -,v1d ! extrapolated diagonal v between time levels - -real(kind=kfpt),dimension(its_b1:ite_b1,jts_b1:jte_b1,1:lm):: & - crt & ! vertical advection temporary -,rcmt & ! vertical advection temporary -,rstt ! vertical advection temporary - -real(kind=kfpt),dimension(its_b1:ite_b2,jts_b1:jte_b2,1:lm):: & - crw & ! vertical advection temporary -,rcmw & ! vertical advection temporary -,rstu & ! vertical advection temporary -,rstv ! vertical advection temporary -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- - do j=jts,jte - do i=its,ite - pdop(i,j)=(pd(i,j)+pdo(i,j))*0.5 - enddo - enddo -!----------------------------------------------------------------------- -!---crank-nicholson vertical advection---------------------------------- -!----------------------------------------------------------------------- -! - dtq=dt*0.25 -! -!----------------- -#ifdef ENABLE_SMP -!----------------- -!....................................................................... -!$omp parallel private(cf,cmt,i,j,jstart,jstop,l,nth,pvvup,rdp,tid, & -!$omp vvlo,vvup) -!....................................................................... - nth = omp_get_num_threads() - tid = omp_get_thread_num() - call looplimits(tid, nth, jts_b1, jte_b1, jstart, jstop) -!----------------- -#else -!----------------- - jstart = jts_b1 - jstop = jte_b1 -!----------------- -#endif -!----------------- - do j=jstart, jstop - do i=its_b1,ite_b1 - pvvlo(i,j)=psgdt(i,j,1)*dtq - vvlo=pvvlo(i,j)/(dsg2(1)*pdop(i,j)+pdsg1(1)) - cmt=-vvlo*w2+1. -! if(abs(cmt).lt.epscm) cmt=epscm - rcmt(i,j,1)=1./cmt - crt(i,j,1)=vvlo*w2 - rstt(i,j,1)=(-vvlo*w1)*(t(i,j,2)-t(i,j,1))+t(i,j,1) - enddo - enddo -! - do l=2,lm-1 - do j=jstart, jstop - do i=its_b1,ite_b1 - rdp=1./(dsg2(l)*pdop(i,j)+pdsg1(l)) - pvvup=pvvlo(i,j) - pvvlo(i,j)=psgdt(i,j,l)*dtq -! - vvup=pvvup*rdp - vvlo=pvvlo(i,j)*rdp -! - cf=-vvup*w2*rcmt(i,j,l-1) - cmt=-crt(i,j,l-1)*cf+((vvup-vvlo)*w2+1.) -! if(abs(cmt).lt.epscm) cmt=epscm - rcmt(i,j,l)=1./cmt - crt(i,j,l)=vvlo*w2 - rstt(i,j,l)=-rstt(i,j,l-1)*cf+t(i,j,l) & - -((t(i,j,l)-t(i,j,l-1))*vvup & - +(t(i,j,l+1)-t(i,j,l))*vvlo)*w1 - enddo - enddo - enddo -! - do j=jstart, jstop - do i=its_b1,ite_b1 - pvvup=pvvlo(i,j) - vvup=pvvup/(dsg2(lm)*pdop(i,j)+pdsg1(lm)) -! - cf=-vvup*w2*rcmt(i,j,lm-1) - cmt=-crt(i,j,lm-1)*cf+(vvup*w2+1.) -! if(abs(cmt).lt.epscm) cmt=epscm - rcmt(i,j,lm)=1./cmt - crt(i,j,lm)=0. - rstt(i,j,lm)=-rstt(i,j,lm-1)*cf+t(i,j,lm) & - & -(t(i,j,lm)-t(i,j,lm-1))*vvup*w1 -! - tct(i,j,lm)=rstt(i,j,lm)*rcmt(i,j,lm)-t(i,j,lm) - enddo - enddo -! - do l=lm-1,1,-1 - do j=jstart, jstop - do i=its_b1,ite_b1 - tct(i,j,l)=(-crt(i,j,l)*(t(i,j,l+1)+tct(i,j,l+1)) & - +rstt(i,j,l)) & - *rcmt(i,j,l)-t(i,j,l) - enddo - enddo - enddo -!----------------- -#ifdef ENABLE_SMP -!----------------- -!....................................................................... -!$omp end parallel -!....................................................................... -!----------------- -#endif -!----------------- - -!....................................................................... -!$omp parallel do & -!$omp private (emhp,enhp,fahp,i,iap,ibeg,iend,j,jap,jbeg,jend,l, & -!$omp pp,qq,t1,tne,tnw,tx,ty) -!....................................................................... -!----------------------------------------------------------------------- - vertical_loop1: do l=1,lm -!----------------------------------------------------------------------- - do j=jts_h1,jte_h1 - do i=its_h1,ite_h1 - t1(i,j)=t(i,j,l)*cfc+tp(i,j,l)*bfc - tp(i,j,l)=t(i,j,l) - enddo - enddo -!----------------------------------------------------------------------- -!---temperature fluxes, on h points------------------------------------- -!----------------------------------------------------------------------- - do j=jts_b1,jte_h1 - do i=its_b1,ite_h1 - tx(i,j)=(t1(i,j)-t1(i-1,j))*pfx(i,j,l) - ty(i,j)=(t1(i,j)-t1(i,j-1))*pfy(i,j,l) - tne(i,j)=(t1(i,j)-t1(i-1,j-1))*pfne(i,j,l) - tnw(i,j)=(t1(i-1,j)-t1(i,j-1))*pfnw(i,j,l) - enddo - enddo -!----------------------------------------------------------------------- -!---advection of temperature-------------------------------------------- -!----------------------------------------------------------------------- - if(adv_standard)then - ibeg=max(its,ids+1+lnsad) - iend=min(ite,ide-1-lnsad) - jbeg=max(jts,jds+1+lnsad) - jend=min(jte,jde-1-lnsad) -! - do j=jbeg,jend - fahp=fah(j) - do i=ibeg,iend - tct(i,j,l)=(((tx (i ,j )+tx (i+1,j ) & - +ty (i ,j )+ty (i ,j+1)) & - +(tne(i+1,j+1)+tne(i ,j ) & - +tnw(i ,j+1)+tnw(i+1,j ))*0.25)*fahp) & - /(dsg2(l)*pdop(i,j)+pdsg1(l)) & - +omgalf(i,j,l)+tct(i,j,l) - enddo - enddo - endif -!----------------------------------------------------------------------- -!---regional branch----------------------------------------------------- -!----------------------------------------------------------------------- - if(.not.global.and.adv_upstream) then -!----------------------------------------------------------------------- - enhp=-dt*rdyh*0.25 -! -!*** Upstream advection along southern rows -! - do j=jts_b1,min(jte,jds+lnsad) - emhp=-dt*rdxh(j)*0.25 - do i=its_b1,ite_b1 - pp=(u(i-1,j-1,l)+u(i,j-1,l)+u(i-1,j,l)+u(i,j,l))*emhp - qq=(v(i-1,j-1,l)+v(i,j-1,l)+v(i-1,j,l)+v(i,j,l))*enhp -! - if(pp.le.0.) then - iap=-1 - pp=-pp - else - iap=1 - endif -! - if(qq.le.0.) then - jap=-1 - qq=-qq - else - jap=1 - endif -! - tct(i,j,l)=(t(i+iap,j,l)-t(i,j,l))*pp & - +(t(i,j+jap,l)-t(i,j,l))*qq & - +(t(i,j,l)-t(i+iap,j,l) & - -t(i,j+jap,l)+t(i+iap,j+jap,l))*pp*qq & - +omgalf(i,j,l)+tct(i,j,l) - enddo - enddo -! -!*** Upstream advection along northern rows -! - do j=max(jts,jde-lnsad),jte_b1 - emhp=-dt*rdxh(j)*0.25 - do i=its_b1,ite_b1 - pp=(u(i-1,j-1,l)+u(i,j-1,l)+u(i-1,j,l)+u(i,j,l))*emhp - qq=(v(i-1,j-1,l)+v(i,j-1,l)+v(i-1,j,l)+v(i,j,l))*enhp -! - if(pp.le.0.) then - iap=-1 - pp=-pp - else - iap=1 - endif -! - if(qq.le.0.) then - jap=-1 - qq=-qq - else - jap=1 - endif -! - tct(i,j,l)=(t(i+iap,j,l)-t(i,j,l))*pp & - +(t(i,j+jap,l)-t(i,j,l))*qq & - +(t(i,j,l)-t(i+iap,j,l) & - -t(i,j+jap,l)+t(i+iap,j+jap,l))*pp*qq & - +omgalf(i,j,l)+tct(i,j,l) - enddo - enddo -! -!*** Upstream advection along western rows -! - do j=max(jts,jds+1+lnsad),min(jte,jde-1-lnsad) - emhp=-dt*rdxh(j)*0.25 - do i=its_b1,min(ite,ids+lnsad) - pp=(u(i-1,j-1,l)+u(i,j-1,l)+u(i-1,j,l)+u(i,j,l))*emhp - qq=(v(i-1,j-1,l)+v(i,j-1,l)+v(i-1,j,l)+v(i,j,l))*enhp -! - if(pp.le.0.) then - iap=-1 - pp=-pp - else - iap=1 - endif -! - if(qq.le.0.) then - jap=-1 - qq=-qq - else - jap=1 - endif -! - tct(i,j,l)=(t(i+iap,j,l)-t(i,j,l))*pp & - +(t(i,j+jap,l)-t(i,j,l))*qq & - +(t(i,j,l)-t(i+iap,j,l) & - -t(i,j+jap,l)+t(i+iap,j+jap,l))*pp*qq & - +omgalf(i,j,l)+tct(i,j,l) - enddo - enddo -! -!*** Upstream advection along eastern rows -! - do j=max(jts,jds+1+lnsad),min(jte,jde-1-lnsad) - emhp=-dt*rdxh(j)*0.25 - do i=max(its,ide-lnsad),ite_b1 - pp=(u(i-1,j-1,l)+u(i,j-1,l)+u(i-1,j,l)+u(i,j,l))*emhp - qq=(v(i-1,j-1,l)+v(i,j-1,l)+v(i-1,j,l)+v(i,j,l))*enhp -! - if(pp.le.0.) then - iap=-1 - pp=-pp - else - iap=1 - endif -! - if(qq.le.0.) then - jap=-1 - qq=-qq - else - jap=1 - endif -! - tct(i,j,l)=(t(i+iap,j,l)-t(i,j,l))*pp & - +(t(i,j+jap,l)-t(i,j,l))*qq & - +(t(i,j,l)-t(i+iap,j,l) & - -t(i,j+jap,l)+t(i+iap,j+jap,l))*pp*qq & - +omgalf(i,j,l)+tct(i,j,l) - enddo - enddo -!----------------------------------------------------------------------- - endif ! regional lateral boundaries -!----------------------------------------------------------------------- -! - enddo vertical_loop1 -!....................................................................... -!$omp end parallel do -!....................................................................... -! -!----------------------------------------------------------------------- -!---crank-nicholson vertical advection---------------------------------- -!----------------------------------------------------------------------- -! - dts=dt*(0.25*0.25) -! -!----------------- -#ifdef ENABLE_SMP -!----------------- -!....................................................................... -!$omp parallel private(cf,cmw,i,j,jstart,jstop,l,nth,pvvup,rdp,tid, & -!$omp vvlo,vvup) -!....................................................................... - nth = omp_get_num_threads() - tid = omp_get_thread_num() - call looplimits(tid, nth, jts_b1, jte_b2, jstart, jstop) -!----------------- -#else -!----------------- - jstart = jts_b1 - jstop = jte_b2 -!----------------- -#endif -!----------------- - do j=jstart, jstop - do i=its_b1,ite_b2 - pdop(i,j)=(pd (i,j)+pd (i+1,j)+pd (i,j+1)+pd (i+1,j+1) & - +pdo(i,j)+pdo(i+1,j)+pdo(i,j+1)+pdo(i+1,j+1))*0.125 - pvvlo(i,j)=(psgdt(i,j ,1)+psgdt(i+1,j ,1) & - +psgdt(i,j+1,1)+psgdt(i+1,j+1,1))*dts - vvlo=pvvlo(i,j)/(dsg2(1)*pdop(i,j)+pdsg1(1)) - cmw=-vvlo*w2+1. -! if(abs(cmw).lt.epscm) cmw=epscm - rcmw(i,j,1)=1./cmw - crw(i,j,1)=vvlo*w2 - rstu(i,j,1)=(-vvlo*w1)*(u(i,j,2)-u(i,j,1))+u(i,j,1) - rstv(i,j,1)=(-vvlo*w1)*(v(i,j,2)-v(i,j,1))+v(i,j,1) - enddo - enddo -! - do l=2,lm-1 - do j=jstart,jstop - do i=its_b1,ite_b2 - rdp=1./(dsg2(l)*pdop(i,j)+pdsg1(l)) - pvvup=pvvlo(i,j) - pvvlo(i,j)=(psgdt(i,j,l)+psgdt(i+1,j,l) & - +psgdt(i,j+1,l)+psgdt(i+1,j+1,l))*dts - vvup=pvvup*rdp - vvlo=pvvlo(i,j)*rdp - cf=-vvup*w2*rcmw(i,j,l-1) - cmw=-crw(i,j,l-1)*cf+((vvup-vvlo)*w2+1.) -! if(abs(cmw).lt.epscm) cmw=epscm - rcmw(i,j,l)=1./cmw - crw(i,j,l)=vvlo*w2 - rstu(i,j,l)=-rstu(i,j,l-1)*cf+u(i,j,l) & - -((u(i,j,l)-u(i,j,l-1))*vvup & - +(u(i,j,l+1)-u(i,j,l))*vvlo)*w1 - rstv(i,j,l)=-rstv(i,j,l-1)*cf+v(i,j,l) & - -((v(i,j,l)-v(i,j,l-1))*vvup & - +(v(i,j,l+1)-v(i,j,l))*vvlo)*w1 - enddo - enddo - enddo -! - do j=jstart,jstop - do i=its_b1,ite_b2 - pvvup=pvvlo(i,j) - vvup=pvvup/(dsg2(lm)*pdop(i,j)+pdsg1(lm)) - cf=-vvup*w2*rcmw(i,j,lm-1) - cmw=-crw(i,j,lm-1)*cf+(vvup*w2+1.) -! if(abs(cmw).lt.epscm) cmw=epscm - rcmw(i,j,lm)=1./cmw - crw(i,j,lm)=vvlo - rstu(i,j,lm)=-rstu(i,j,lm-1)*cf+u(i,j,lm) & - -(u(i,j,lm)-u(i,j,lm-1))*vvup*w1 - rstv(i,j,lm)=-rstv(i,j,lm-1)*cf+v(i,j,lm) & - -(v(i,j,lm)-v(i,j,lm-1))*vvup*w1 - tcu(i,j,lm)=rstu(i,j,lm)*rcmw(i,j,lm)-u(i,j,lm) - tcv(i,j,lm)=rstv(i,j,lm)*rcmw(i,j,lm)-v(i,j,lm) - enddo - enddo -! - do l=lm-1,1,-1 - do j=jstart,jstop - do i=its_b1,ite_b2 - tcu(i,j,l)=(-crw(i,j,l)*(u(i,j,l+1)+tcu(i,j,l+1)) & - +rstu(i,j,l)) & - *rcmw(i,j,l)-u(i,j,l) - tcv(i,j,l)=(-crw(i,j,l)*(v(i,j,l+1)+tcv(i,j,l+1)) & - +rstv(i,j,l)) & - *rcmw(i,j,l)-v(i,j,l) - enddo - enddo - enddo -!----------------- -#ifdef ENABLE_SMP -!----------------- -!....................................................................... -!$omp end parallel -!....................................................................... -!----------------- -#endif -!----------------- - -!----------------------------------------------------------------------- -!---grand vertical loop------------------------------------------------- -!----------------------------------------------------------------------- -! -!....................................................................... -!$omp parallel do & -!$omp private (crv,dux1,duy1,dvx1,dvy1,dxody,dyodx,emvp,envp, & -!$omp fadp,fdpp,fp,fpp,i,iap,ibeg,iend,j,jap,jbeg,jend,l, & -!$omp pfnex1,pfney1,pfnwx1,pfnwy1,pfxx1,pfxy1,pfyx1,pfyy1,pp, & -!$omp qq,u1d,u2d,ufnex1,ufney1,ufnwx1,ufxx1,ufyx1,ufnwy1, & -!$omp ufxy1,ufyy1,v1d,v2d,vfnex1,vfney1,vfnwx1,vfnwy1, & -!$omp vfxx1,vfxy1,vfyx1,vfyy1) -!....................................................................... -!----------------------------------------------------------------------- -! - vertical_loop2: do l=1,lm -! -!----------------------------------------------------------------------- -! - do j=jts_h2,jte_h2 - do i=its_h2,ite_h2 - u1d(i,j)=u(i,j,l)*cfc+up(i,j,l)*bfc - v1d(i,j)=v(i,j,l)*cfc+vp(i,j,l)*bfc -! - up(i,j,l)=u(i,j,l) - vp(i,j,l)=v(i,j,l) - enddo - enddo -!----------------------------------------------------------------------- -!---coriolis force tendency--------------------------------------------- -!----------------------------------------------------------------------- - do j=jts_b1,jte_b2 - crv=curv(j)*dt - do i=its_b1,ite_b2 - fp=f(i,j)*dt - fpp=u1d(i,j)*crv+fp -! - tcu(i,j,l)= fpp*v1d(i,j)+tcu(i,j,l) - tcv(i,j,l)=-fpp*u1d(i,j)+tcv(i,j,l) - enddo - enddo -!----------------------------------------------------------------------- -!---diagonally averaged fluxes on v points------------------------------ -!----------------------------------------------------------------------- - do j=jts_b1,jte_b1_h1 - do i=its_b1,ite_b1_h1 - pfxx1 (i,j)=pfx (i ,j ,l)+pfx (i+1,j+1,l) - pfyx1 (i,j)=pfy (i ,j ,l)+pfy (i+1,j+1,l) - pfnex1(i,j)=pfne(i ,j ,l)+pfne(i+1,j+1,l) - pfnwx1(i,j)=pfnw(i ,j ,l)+pfnw(i+1,j+1,l) -! - pfxy1 (i,j)=pfx (i+1,j ,l)+pfx (i ,j+1,l) - pfyy1 (i,j)=pfy (i+1,j ,l)+pfy (i ,j+1,l) - pfney1(i,j)=pfne(i+1,j ,l)+pfne(i ,j+1,l) - pfnwy1(i,j)=pfnw(i+1,j ,l)+pfnw(i ,j+1,l) - enddo - enddo -!----------------------------------------------------------------------- -!---4th order momentum advection---------------------------------------- -!----------------------------------------------------------------------- - if(.not.secadv) then - do j=jts_b1_h1,jte_b1_h1 - do i=its_b1_h1,ite_b1_h1 - u2d(i,j)=(u1d(i,j-1)+u1d(i-1,j) & - +u1d(i+1,j)+u1d(i,j+1))*sfc & - +(u1d(i,j)*pfc) - v2d(i,j)=(v1d(i,j-1)+v1d(i-1,j) & - +v1d(i+1,j)+v1d(i,j+1))*sfc & - +(v1d(i,j)*pfc) - enddo - enddo - if(global) then - btim=timef() - call swapwn(u2d,ims,ime,jms,jme,1,inpes) - call swapwn(v2d,ims,ime,jms,jme,1,inpes) - timers(my_domain_id)%swapwn_tim=timers(my_domain_id)%swapwn_tim+(timef()-btim) -! - btim=timef() - call polewn(u2d,v2d,ims,ime,jms,jme,1,inpes,jnpes) - timers(my_domain_id)%polewn_tim=timers(my_domain_id)%polewn_tim+(timef()-btim) - else - if(s_bdy)then - do i=ims,ime - u2d(i,jds)=u1d(i,jds) - v2d(i,jds)=v1d(i,jds) - enddo - endif - if(n_bdy)then - do i=ims,ime - u2d(i,jde-1)=u1d(i,jde-1) - v2d(i,jde-1)=v1d(i,jde-1) - u2d(i,jde)=u1d(i,jde-1) - v2d(i,jde)=v1d(i,jde-1) - enddo - endif - if(w_bdy)then - do j=jms,jme - u2d(ids,j)=u1d(ids,j) - v2d(ids,j)=v1d(ids,j) - enddo - endif - if(e_bdy)then - do j=jms,jme - u2d(ide-1,j)=u1d(ide-1,j) - v2d(ide-1,j)=v1d(ide-1,j) - u2d(ide,j)=u1d(ide-1,j) - v2d(ide,j)=v1d(ide-1,j) - enddo - endif - endif -! - do j=jts_h1,jte_h1 - do i=its_h1,ite_h1 - u1d(i,j)=u2d(i,j) - v1d(i,j)=v2d(i,j) - enddo - enddo - endif -!----------------------------------------------------------------------- -!---horizontal fluxes of momentum components on v points---------------- -!----------------------------------------------------------------------- - if(global) then - if(s_bdy) then - do i=its_b1,ite_b1_h1 - pfyx1 (i,jts_b1)=0. - pfyy1 (i,jts_b1)=0. - pfnex1(i,jts_b1)=0. - pfnwx1(i,jts_b1)=0. - pfney1(i,jts_b1)=0. - pfnwy1(i,jts_b1)=0. - enddo - endif -! - if(n_bdy) then - do i=its_b1,ite_b1_h1 - pfyx1 (i,jte_b1_h1)=0. - pfyy1 (i,jte_b1_h1)=0. - pfnex1(i,jte_b1_h1)=0. - pfnwx1(i,jte_b1_h1)=0. - pfney1(i,jte_b1_h1)=0. - pfnwy1(i,jte_b1_h1)=0. - enddo - endif - endif -!----------------------------------------------------------------------- - do j=jts_b1,jte_b1_h1 - do i=its_b1,ite_b1_h1 - ufxx1 (i,j)=(u1d(i ,j )-u1d(i-1,j ))*pfxx1 (i,j) - ufyx1 (i,j)=(u1d(i ,j )-u1d(i ,j-1))*pfyx1 (i,j) - ufnex1(i,j)=(u1d(i ,j )-u1d(i-1,j-1))*pfnex1(i,j) - ufnwx1(i,j)=(u1d(i-1,j )-u1d(i ,j-1))*pfnwx1(i,j) -! - ufxy1 (i,j)=(u1d(i ,j )-u1d(i-1,j ))*pfxy1 (i,j) - ufyy1 (i,j)=(u1d(i ,j )-u1d(i ,j-1))*pfyy1 (i,j) - ufney1(i,j)=(u1d(i ,j )-u1d(i-1,j-1))*pfney1(i,j) - ufnwy1(i,j)=(u1d(i-1,j )-u1d(i ,j-1))*pfnwy1(i,j) -! - vfxx1 (i,j)=(v1d(i ,j )-v1d(i-1,j ))*pfxx1 (i,j) - vfyx1 (i,j)=(v1d(i ,j )-v1d(i ,j-1))*pfyx1 (i,j) - vfnex1(i,j)=(v1d(i ,j )-v1d(i-1,j-1))*pfnex1(i,j) - vfnwx1(i,j)=(v1d(i-1,j )-v1d(i ,j-1))*pfnwx1(i,j) -! - vfxy1 (i,j)=(v1d(i ,j )-v1d(i-1,j ))*pfxy1 (i,j) - vfyy1 (i,j)=(v1d(i ,j )-v1d(i ,j-1))*pfyy1 (i,j) - vfney1(i,j)=(v1d(i ,j )-v1d(i-1,j-1))*pfney1(i,j) - vfnwy1(i,j)=(v1d(i-1,j )-v1d(i ,j-1))*pfnwy1(i,j) - enddo - enddo -!----------------------------------------------------------------------- -!---advection of u1d and v1d-------------------------------------------- -!----------------------------------------------------------------------- - if(adv_standard) then - ibeg=max(its,ids+1+lnsad) - iend=min(ite,ide-2-lnsad) - jbeg=max(jts,jds+1+lnsad) - jend=min(jte,jde-2-lnsad) -! - do j=jbeg,jend - dxody=dxv(j)*rdyv - dyodx=dyv *rdxv(j) - fadp=fad(j) - do i=ibeg,iend -! - fdpp=fadp/(dsg2(l)*pdop(i,j)+pdsg1(l)) -! - dux1=(ufnex1(i+1,j+1)+ufnex1(i ,j ) & - +ufnwx1(i ,j+1)+ufnwx1(i+1,j ))*0.25 & - +(ufxx1 (i ,j )+ufxx1 (i+1,j ) & - +ufyx1 (i ,j )+ufyx1 (i ,j+1)) -! - dvx1=(vfnex1(i+1,j+1)+vfnex1(i ,j ) & - +vfnwx1(i ,j+1)+vfnwx1(i+1,j ))*0.25 & - +(vfxx1 (i ,j )+vfxx1 (i+1,j ) & - +vfyx1 (i ,j )+vfyx1 (i ,j+1)) -! - duy1=(ufney1(i+1,j+1)+ufney1(i ,j ) & - +ufnwy1(i ,j+1)+ufnwy1(i+1,j ))*0.25 & - +(ufxy1 (i ,j )+ufxy1 (i+1,j ) & - +ufyy1 (i ,j )+ufyy1 (i ,j+1)) -! - dvy1=(vfney1(i+1,j+1)+vfney1(i ,j ) & - +vfnwy1(i ,j+1)+vfnwy1(i+1,j ))*0.25 & - +(vfxy1 (i ,j )+vfxy1 (i+1,j ) & - +vfyy1 (i ,j )+vfyy1 (i ,j+1)) -! - tcu(i,j,l)=((dvx1-dvy1)*dxody+(dux1+duy1))*fdpp & - +tcu(i,j,l) - tcv(i,j,l)=((dux1-duy1)*dyodx+(dvx1+dvy1))*fdpp & - +tcv(i,j,l) - enddo - enddo - endif -!----------------------------------------------------------------------- -!---regional branch----------------------------------------------------- -!----------------------------------------------------------------------- -! - if(.not.global.and.adv_upstream) then -! -!----------------------------------------------------------------------- -!---upstream advection of momentum along lateral boundaries------------- -!----------------------------------------------------------------------- -! - envp=-dt*rdyv -! -!*** Upstream advection along southern rows. -! - jbeg=max(jts,jds+1) - jend=min(jte,jds+lnsad) -! - do j=jbeg,jend - emvp=-dt*rdxv(j) - do i=its_b1,ite_b2 - pp=u(i,j,l)*emvp - qq=v(i,j,l)*envp -! - if(pp.le.0.) then - iap=-1 - pp=-pp - else - iap=1 - endif -! - if(qq.le.0.) then - jap=-1 - qq=-qq - else - jap=1 - endif -! - tcu(i,j,l)=(u(i+iap,j,l)-u(i,j,l))*pp & - +(u(i,j+jap,l)-u(i,j,l))*qq & - +(u(i,j,l)-u(i+iap,j,l) & - -u(i,j+jap,l)+u(i+iap,j+jap,l))*pp*qq & - +tcu(i,j,l) - tcv(i,j,l)=(v(i+iap,j,l)-v(i,j,l))*pp & - +(v(i,j+jap,l)-v(i,j,l))*qq & - +(v(i,j,l)-v(i+iap,j,l) & - -v(i,j+jap,l)+v(i+iap,j+jap,l))*pp*qq & - +tcv(i,j,l) - enddo - enddo -! -!*** Upstream advection along northern rows. -! - do j=max(jts,jde-1-lnsad),jte_b2 - emvp=-dt*rdxv(j) - do i=its_b1,ite_b2 - pp=u(i,j,l)*emvp - qq=v(i,j,l)*envp -! - if(pp.le.0.) then - iap=-1 - pp=-pp - else - iap=1 - endif -! - if(qq.le.0.) then - jap=-1 - qq=-qq - else - jap=1 - endif -! - tcu(i,j,l)=(u(i+iap,j,l)-u(i,j,l))*pp & - +(u(i,j+jap,l)-u(i,j,l))*qq & - +(u(i,j,l)-u(i+iap,j,l) & - -u(i,j+jap,l)+u(i+iap,j+jap,l))*pp*qq & - +tcu(i,j,l) - tcv(i,j,l)=(v(i+iap,j,l)-v(i,j,l))*pp & - +(v(i,j+jap,l)-v(i,j,l))*qq & - +(v(i,j,l)-v(i+iap,j,l) & - -v(i,j+jap,l)+v(i+iap,j+jap,l))*pp*qq & - +tcv(i,j,l) - enddo - enddo -! -!*** Upstream advection along western rows. -! - do j=max(jts,jds+1+lnsad),min(jte,jde-2-lnsad) - emvp=-dt*rdxv(j) - do i=its_b1,ids+lnsad - pp=u(i,j,l)*emvp - qq=v(i,j,l)*envp -! - if(pp.le.0.) then - iap=-1 - pp=-pp - else - iap=1 - endif -! - if(qq.le.0.) then - jap=-1 - qq=-qq - else - jap=1 - endif -! - tcu(i,j,l)=(u(i+iap,j,l)-u(i,j,l))*pp & - +(u(i,j+jap,l)-u(i,j,l))*qq & - +(u(i,j,l)-u(i+iap,j,l) & - -u(i,j+jap,l)+u(i+iap,j+jap,l))*pp*qq & - +tcu(i,j,l) - tcv(i,j,l)=(v(i+iap,j,l)-v(i,j,l))*pp & - +(v(i,j+jap,l)-v(i,j,l))*qq & - +(v(i,j,l)-v(i+iap,j,l) & - -v(i,j+jap,l)+v(i+iap,j+jap,l))*pp*qq & - +tcv(i,j,l) - enddo - enddo -! -!*** Upstream advection along eastern rows. -! - do j=max(jts,jds+1+lnsad),min(jte,jde-2-lnsad) - emvp=-dt*rdxv(j) - do i=max(its,ide-1-lnsad),ite_b2 - pp=u(i,j,l)*emvp - qq=v(i,j,l)*envp -! - if(pp.le.0.) then - iap=-1 - pp=-pp - else - iap=1 - endif -! - if(qq.le.0.) then - jap=-1 - qq=-qq - else - jap=1 - endif -! - tcu(i,j,l)=(u(i+iap,j,l)-u(i,j,l))*pp & - +(u(i,j+jap,l)-u(i,j,l))*qq & - +(u(i,j,l)-u(i+iap,j,l) & - -u(i,j+jap,l)+u(i+iap,j+jap,l))*pp*qq & - +tcu(i,j,l) - tcv(i,j,l)=(v(i+iap,j,l)-v(i,j,l))*pp & - +(v(i,j+jap,l)-v(i,j,l))*qq & - +(v(i,j,l)-v(i+iap,j,l) & - -v(i,j+jap,l)+v(i+iap,j+jap,l))*pp*qq & - +tcv(i,j,l) - enddo - enddo -!----------------------------------------------------------------------- - endif ! regional lateral boundaries -!----------------------------------------------------------------------- -! - enddo vertical_loop2 -!....................................................................... -!$omp end parallel do -!....................................................................... -! -!----------------------------------------------------------------------- -! - endsubroutine adv1 -! -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- - subroutine vtoa & -(lm & -,dt,ef4t,pt & -,sg2 & -,psdt & -,dwdt,rtop & -,omgalf & -,pint & -!---temporary arguments------------------------------------------------- -,tdiv,tct) - -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -implicit none -!----------------------------------------------------------------------- -integer(kind=kint),intent(in):: & - lm ! total # of levels - -real(kind=kfpt),intent(in):: & - dt & ! dynamics time step -,ef4t & ! vertical grid parameter -,pt ! pressure at the top of the model's atmosphere - -real(kind=kfpt),dimension(1:lm+1),intent(in):: & - sg2 ! delta sigmas - -real(kind=kfpt),dimension(ims:ime,jms:jme),intent(in):: & - psdt ! surface pressure tendency - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(in):: & - dwdt & ! nonhydrostatic correction factor -,rtop ! RT/p - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(inout):: & - omgalf ! - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm+1),intent(inout):: & - pint ! pressure at interfaces -!----------------------------------------------------------------------- -!---temporary arguments------------------------------------------------- -!----------------------------------------------------------------------- -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(in):: & - tdiv ! integrated horizontal mass divergence - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(inout):: & - tct ! time change of temperature -!----------------------------------------------------------------------- -!--local variables------------------------------------------------------ -!----------------------------------------------------------------------- -integer(kind=kint):: & - i & ! index in x direction -,j & ! index in y direction -,l ! index in p direction - -real(kind=kfpt):: & - dwdtp & ! nonhydrostatic correction factor at the point -,toa & ! omega-alpha temporary -,tpmp ! pressure temporary at the point - -real(kind=kfpt),dimension(its:ite,jts:jte):: & - tpm ! pressure temporary -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------- -#ifdef ENABLE_SMP -!----------------- -!....................................................................... -!$omp parallel private(dwdtp,i,j,jstart,jstop,l,nth,tid,toa,tpmp) -!....................................................................... - nth = omp_get_num_threads() - tid = omp_get_thread_num() - call looplimits(tid, nth, jts_b1,jte_b1,jstart,jstop) -!----------------- -#else -!----------------- - jstart = jts_b1 - jstop = jte_b1 -!----------------- -#endif -!----------------- - - -!do l=1,lm -! do j=jstart,jstop -! do i=its_b1,ite_b1 -! tct(i,j,l)=0. -! enddo -! enddo -!enddo - - - do j=jstart,jstop - do i=its_b1,ite_b1 - pint(i,j,1)=pt - tpm(i,j)=pt+pint(i,j,2) -! - dwdtp=dwdt(i,j,1) -! - tpmp=pint(i,j,2)+pint(i,j,3) - toa=-tdiv(i,j,1)*rtop(i,j,1)*dwdtp*ef4t -! - omgalf(i,j,1)=omgalf(i,j,1)+toa - tct(i,j,1)=tct(i,j,1)+toa -! - pint(i,j,2)=psdt(i,j)*(sg2(1)+sg2(2))*dwdtp*dt & - +tpm(i,j)-pint(i,j,1) -! - tpm(i,j)=tpmp - enddo - enddo -! - do l=2,lm-1 - do j=jstart,jstop - do i=its_b1,ite_b1 - dwdtp=dwdt(i,j,l) -! - tpmp=pint(i,j,l+1)+pint(i,j,l+2) - toa=-(tdiv(i,j,l-1)+tdiv(i,j,l))*rtop(i,j,l)*dwdtp*ef4t -! - omgalf(i,j,l)=omgalf(i,j,l)+toa - tct(i,j,l)=tct(i,j,l)+toa -! - pint(i,j,l+1)=psdt(i,j)*(sg2(l)+sg2(l+1))*dwdtp*dt & - +tpm(i,j)-pint(i,j,l) -! - tpm(i,j)=tpmp - enddo - enddo - enddo -! - do j=jstart,jstop - do i=its_b1,ite_b1 - dwdtp=dwdt(i,j,lm) -! - toa=-(tdiv(i,j,lm-1)+tdiv(i,j,lm))*rtop(i,j,lm)*dwdtp*ef4t -! - omgalf(i,j,lm)=omgalf(i,j,lm)+toa - tct(i,j,lm)=tct(i,j,lm)+toa -! - pint(i,j,lm+1)=psdt(i,j)*(sg2(lm)+sg2(lm+1))*dwdtp*dt & - +tpm(i,j)-pint(i,j,lm) - enddo - enddo -!----------------- -#ifdef ENABLE_SMP -!----------------- -!....................................................................... -!$omp end parallel -!....................................................................... -!----------------- -#endif -!----------------- - -!----------------------------------------------------------------------- -! - endsubroutine vtoa -! -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -! - subroutine updates & -(lm,ntracers,kss,kse,s & -!---temporary arguments------------------------------------------------- -,tcs) -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -implicit none -!----------------------------------------------------------------------- -integer(kind=kint),intent(in):: & - lm & ! total # of levels -,ntracers & ! total # of tracers -,kss & ! starting index of tracers to be updated -,kse ! ending index of tracers to be updated - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm,1:ntracers),intent(inout):: & - s ! tracer -!----------------------------------------------------------------------- -!---temporary arguments------------------------------------------------- -!----------------------------------------------------------------------- -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm,1:ntracers):: & - tcs ! tracer time change -!----------------------------------------------------------------------- -!--local variables------------------------------------------------------ -!----------------------------------------------------------------------- -integer(kind=kint):: & - i & ! index in x direction -,j & ! index in y direction -,l & ! index in p direction -,k ! tracers index -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -!....................................................................... -!$omp parallel do private(i,j,l,k) -!....................................................................... - do k=kss,kse - do l=1,lm - do j=jts_b1,jte_b1 - do i=its_b1,ite_b1 - s(i,j,l,k)=s(i,j,l,k)+tcs(i,j,l,k) -! - tcs(i,j,l,k)=0. - enddo - enddo - enddo - enddo -!....................................................................... -!$omp end parallel do -!....................................................................... -!----------------------------------------------------------------------- -! - endsubroutine updates -! -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- - subroutine updatet & -(lm,t & -!---temporary arguments------------------------------------------------- -,tct) -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -implicit none -!----------------------------------------------------------------------- -integer(kind=kint),intent(in):: & - lm ! total # of levels - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(inout):: & - t ! temperature -!----------------------------------------------------------------------- -!---temporary arguments------------------------------------------------- -!----------------------------------------------------------------------- -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm):: & - tct ! temperature time change -!----------------------------------------------------------------------- -!--local variables------------------------------------------------------ -!----------------------------------------------------------------------- -integer(kind=kint):: & - i & ! index in x direction -,j & ! index in y direction -,l ! index in p direction -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -!....................................................................... -!$omp parallel do private(i,j,l) -!....................................................................... - do l=1,lm - do j=jts_b1,jte_b1 - do i=its_b1,ite_b1 - t(i,j,l)=t(i,j,l)+tct(i,j,l) -! - tct(i,j,l)=0. - enddo - enddo - enddo -!....................................................................... -!$omp end parallel do -!....................................................................... -!----------------------------------------------------------------------- -! - endsubroutine updatet -! -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- - subroutine updateuv & -(lm,u,v & -!---temporary arguments------------------------------------------------- -,tcu,tcv) -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -implicit none -!----------------------------------------------------------------------- -real(kind=kfpt),parameter:: & - cflfc=1./(140.*140.) ! cfl limit - -integer(kind=kint),intent(in):: & - lm ! total # of levels - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(inout):: & - u & ! u -,v ! v -!----------------------------------------------------------------------- -!---temporary arguments------------------------------------------------- -!----------------------------------------------------------------------- -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm):: & - tcu & ! u time change -,tcv ! v time change -!----------------------------------------------------------------------- -!--local variables------------------------------------------------------ -!----------------------------------------------------------------------- -integer(kind=kint):: & - i & ! index in x direction -,j & ! index in y direction -,l ! index in p direction - -real(kind=kfpt):: & - cflc & ! -,rcflc ! - -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -!....................................................................... -!$omp parallel do private (cflc,i,j,l,rcflc) -!....................................................................... - do l=1,lm - do j=jts_b1,jte_b2 - do i=its_b1,ite_b2 - u(i,j,l)=u(i,j,l)+tcu(i,j,l) - v(i,j,l)=v(i,j,l)+tcv(i,j,l) -! - tcu(i,j,l)=0. - tcv(i,j,l)=0. -! - cflc=(u(i,j,l)*u(i,j,l)+v(i,j,l)*v(i,j,l))*cflfc - if(cflc.gt.1.) then - rcflc=sqrt(1./cflc) - u(i,j,l)=u(i,j,l)*rcflc - v(i,j,l)=v(i,j,l)*rcflc - endif - enddo - enddo - enddo -!....................................................................... -!$omp end parallel do -!....................................................................... -!----------------------------------------------------------------------- -! - endsubroutine updateuv -! -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- - subroutine hdiff & -(global,hydro & -,inpes,jnpes,lm,lpt2 & -,dyh,rdyh & -,epsq2 & -,dxv,rare,rdxh & -,sice,sm & -,hdacx,hdacy,hdacvx,hdacvy & -,w,z & -,cw,q,q2,t,u,v,def3d) -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -implicit none -!----------------------------------------------------------------------- -real(kind=kfpt),parameter:: & - defvfc=2. & ! vertical deformation weight -,scq2=50. & ! 2tke weighting factor -,epsq=1.e-20 & ! floor value for specific humidity -,slopec=.05 ! critical slope - -!----------------------------------------------------------------------- -logical(kind=klog),intent(in):: & - global & ! global or regional -,hydro ! logical switch for nonhydrostatic dynamics - -integer(kind=kint),intent(in):: & - inpes & ! w-e # of subdomains -,jnpes & ! n-s # of subdomains -,lm & ! total # of levels -,lpt2 ! # of levels in the pressure range - -real(kind=kfpt),intent(in):: & - dyh & ! -,rdyh ! 1/deltay - -real(kind=kfpt),dimension(1:lm),intent(in):: & - epsq2 ! floor value of 2tke - -real(kind=kfpt),dimension(jds:jde),intent(in):: & - dxv & ! -,rare & ! -,rdxh ! 1/deltax - -real(kind=kfpt),dimension(ims:ime,jms:jme),intent(in):: & - hdacx & ! exchange coefficient for mass points -,hdacy & ! exchange coefficient for mass points -,hdacvx & ! exchange coefficient for velocity points -,hdacvy & ! exchange coefficient for velocity points -,sice & ! sea-ice mask -,sm ! sea mask - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(in):: & - w & ! w wind component -,z ! height at mass points - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(inout):: & - cw & ! condensate -,q & ! specific humidity -,q2 & ! 2tke -,t & ! temperature -,u & ! u wind component -,v ! v wind component - -real(kind=kfpt),dimension(ims:ime,jms:jme,lm),intent(out) :: & - def3d - -!----------------------------------------------------------------------- -!--local variables------------------------------------------------------ -!----------------------------------------------------------------------- -logical(kind=klog):: & - cilinx & ! coast/ice line -,ciliny ! coast/ice line - -integer(kind=kint):: & - i & ! index in x direction -,j & ! index in y direction -,l ! index in p direction - -real(kind=kfpt):: & - def1 & ! component of deformation -,def2 & ! component of deformation -,def3 & ! component of deformation -,def4 & ! component of deformation -,defc & ! deformation floor -,defm & ! deformation cap -,defp & ! deformation at the point -,defs & ! component of deformation -,deft & ! component of deformation -,defvp & -,defhp & -,facdif & ! diffusion factor -,hkfx & ! def with slope factor -,hkfy & ! def with slope factor -,q2trm & ! -,slopx & ! x slope -,slopy ! y slope - -real(kind=kfpt),dimension(ims:ime,jms:jme):: & - cdif & ! condensate 2nd order diffusion -,cx & ! condensate difference, x direction -,cy & ! condensate difference, y direction -,def & ! deformation (in halo exchange) -,fmlx & ! x slope mask -,fmly & ! y slope mask -,hkx & ! deformation sum, x direction -,hky & ! deformation sum, y direction -,qdif & ! specific humidity 2nd order diffusion -,qx & ! specific humidity difference, x direction -,qy & ! specific humidity difference, y direction -,q2dif & ! 2tke 2nd order diffusion -,q2x & ! 2tke difference, x direction -,q2y & ! 2tke difference, y direction -,tdif & ! temperature 2nd order diffusion -,tx & ! temperature difference, x direction -,ty & ! temperature difference, y direction -,udif & ! u wind component 2nd order diffusion -,ux & ! u wind component difference, x direction -,uy & ! u wind component difference, y direction -,vdif & ! v wind component 2nd order diffusion -,vx & ! v wind component difference, x direction -,vy ! v wind component difference, y direction - -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- - if(global) then - defm=1.6875e-4 ! 1.35e-3/2./4. ! deformation cap, /4. for smag2=0.4 - facdif=1.0 - else - defm=9999. - facdif=1.0 !bsf: was 4.0 in 10/18/2011 NAM implementation - endif -!----------------------------------------------------------------------- -! - do l=1,lm - if(s_bdy)then - do i=ims,ime - def3d(i,jds,l)=0. - enddo - endif -! - if(n_bdy)then - do i=ims,ime - def3d(i,jde,l)=0. - enddo - endif -! - if(w_bdy)then - do j=jms,jme - def3d(ids,j,l)=0. - enddo - endif -! - if(e_bdy)then - do j=jms,jme - def3d(ide,j,l)=0. - enddo - endif - enddo -! -!----------------------------------------------------------------------- -!---grand vertical loop------------------------------------------------- -!----------------------------------------------------------------------- -! -!....................................................................... -!$omp parallel do & -!$omp private(def1,def2,def3,def4,defc,defp,defs,deft,i,j,l,q2trm) -!....................................................................... -!----------------------------------------------------------------------- -! - vertical_loop_1: do l=1,lm -! -!----------------------------------------------------------------------- - if(global)then - if(l.gt.lpt2/3) then - defc=0. - else - defc=defm*0.01 - endif - else ! regional - if (l.le.3) then - defc=0.015*(3-l+1.)/3. - else - defc=0. - endif - endif -!----------------------------------------------------------------------- -! do j=jts_h1,jte_h2 -! do i=its_h1,ite_h2 -! q2(i,j,l)=max(q2(i,j,l),epsq2) -! enddo -! enddo -!----------------------------------------------------------------------- - do j=jts_b1_h1,jte_b1_h2 - do i=its_b1_h1,ite_b1_h2 - deft=((u(i ,j-1,l)+u(i ,j ,l) & - -u(i-1,j-1,l)-u(i-1,j ,l))*dyh & - -(v(i-1,j ,l)+v(i ,j ,l))*dxv(j ) & - +(v(i-1,j-1,l)+v(i ,j-1,l))*dxv(j-1))*rare(j) - defs=((u(i-1,j ,l)+u(i ,j ,l))*dxv(j ) & - -(u(i-1,j-1,l)+u(i ,j-1,l))*dxv(j-1) & - +(v(i ,j-1,l)+v(i ,j ,l) & - -v(i-1,j-1,l)-v(i-1,j ,l))*dyh )*rare(j) -! defz=(-(u(i-1,j ,l)+u(i ,j ,l))*dxv(j ) & -! +(u(i-1,j-1,l)+u(i ,j-1,l))*dxv(j-1) & -! +(v(i ,j-1,l)+v(i ,j ,l) & -! -v(i-1,j-1,l)-v(i-1,j ,l))*dyh )*rare(j) *10. -! if(defz.gt.0.) defz=0. -! - if(.not.hydro) then - def1=(w(i,j,l)-w(i,j-1,l))*rdyh - def2=(w(i,j,l)-w(i-1,j,l))*rdxh(j) - def3=(w(i+1,j,l)-w(i,j,l))*rdxh(j) - def4=(w(i,j+1,l)-w(i,j,l))*rdyh - else - def1=0. - def2=0. - def3=0. - def4=0. - endif - - if(q2(i,j,l).gt.epsq2(L)) then - q2trm=scq2*q2(i,j,l)*rare(j) - else - q2trm=0. - endif - - - defhp=deft*deft+defs*defs+q2trm - defvp=def1*def1+def2*def2+def3*def3+def4*def4 -! - defp=sqrt(defhp*2.+defvp*defvfc) - defp=max (defp,defc) - defp=min (defp,defm) -! - def3d(i,j,l)=defp - enddo - enddo -!----------------------------------------------------------------------- -! - enddo vertical_loop_1 -!....................................................................... -!$omp end parallel do -!....................................................................... -! -!----------------------------------------------------------------------- -! - if(global) then - btim=timef() - call swaphn(def3d,ims,ime,jms,jme,lm,inpes) - timers(my_domain_id)%swaphn_tim=timers(my_domain_id)%swaphn_tim+(timef()-btim) -! - btim=timef() - call polehn(def3d,ims,ime,jms,jme,lm,inpes,jnpes) - timers(my_domain_id)%polehn_tim=timers(my_domain_id)%polehn_tim+(timef()-btim) - endif -! -!----------------------------------------------------------------------- -!....................................................................... -!$omp parallel do & -!$omp private(cdif,cilinx,ciliny,cx,cy,fmlx,fmly, & -!$omp hkfx,hkfy,hkx,hky,i,j,l, & -!$omp q2dif,q2x,q2y,qdif,qx,qy,slopx,slopy, & -!$omp tdif,tx,ty,udif,ux,uy,vdif,vx,vy) -!....................................................................... -!----------------------------------------------------------------------- - vertical_loop_3: do l=1,lm -!----------------------------------------------------------------------- - if(l.gt.lpt2.and..not.hydro) then - do j=jts_b1,jte_h2 - do i=its_b1,ite_h2 - cilinx=sice(i-1,j).ne.sice(i,j) & - .or.sm (i-1,j).ne.sm (i,j) - ciliny=sice(i,j-1).ne.sice(i,j) & - .or.sm (i,j-1).ne.sm (i,j) - slopx=abs((z(i,j,l)-z(i-1,j,l))*rdxh(j)) - slopy=abs((z(i,j,l)-z(i,j-1,l))*rdyh ) -! - if(slopx.le.slopec.or.cilinx) then - fmlx(i,j)=1. - else - fmlx(i,j)=0. - endif -! - if(slopy.le.slopec.or.ciliny) then - fmly(i,j)=1. - else - fmly(i,j)=0. - endif -! - enddo - enddo - else - do j=jts_b1,jte_h2 - do i=its_b1,ite_h2 - fmlx(i,j)=1. - fmly(i,j)=1. - enddo - enddo - endif -!----------------------------------------------------------------------- -!---contributions behind mass points------------------------------------ -!----------------------------------------------------------------------- - do j=jts_b1,jte_h2 - do i=its_b1,ite_h2 - hkx(i,j)=(def3d(i-1,j,l)+def3d(i,j,l)) - hky(i,j)=(def3d(i,j-1,l)+def3d(i,j,l)) - hkfx=hkx(i,j)*fmlx(i,j) - hkfy=hky(i,j)*fmly(i,j) -! - tx (i,j)=(t (i,j,l)-t (i-1,j,l))*hkfx - qx (i,j)=(q (i,j,l)-q (i-1,j,l))*hkfx - cx (i,j)=(cw(i,j,l)-cw(i-1,j,l))*hkfx - q2x(i,j)=(q2(i,j,l)-q2(i-1,j,l))*hkfx -! - ty (i,j)=(t (i,j,l)-t (i,j-1,l))*hkfy - qy (i,j)=(q (i,j,l)-q (i,j-1,l))*hkfy - cy (i,j)=(cw(i,j,l)-cw(i,j-1,l))*hkfy - q2y(i,j)=(q2(i,j,l)-q2(i,j-1,l))*hkfy - enddo - enddo -!----------------------------------------------------------------------- -!---u,v, contributions, behind v points--------------------------------- -!----------------------------------------------------------------------- - do j=jts_b1,jte_b1_h1 - do i=its_b1,ite_b1_h1 - ux(i,j)=(u(i,j,l)-u(i-1,j,l))*hky(i,j+1) - vx(i,j)=(v(i,j,l)-v(i-1,j,l))*hky(i,j+1) - uy(i,j)=(u(i,j,l)-u(i,j-1,l))*hkx(i+1,j) - vy(i,j)=(v(i,j,l)-v(i,j-1,l))*hkx(i+1,j) - enddo - enddo -!----------------------------------------------------------------------- - do j=jts_b1,jte_b1 - do i=its_b1,ite_b1 - tdif (i,j)=(tx (i+1,j)-tx (i,j))*hdacx(i,j) & - +(ty (i,j+1)-ty (i,j))*hdacy(i,j) - qdif (i,j)=(qx (i+1,j)-qx (i,j))*hdacx(i,j) & - +(qy (i,j+1)-qy (i,j))*hdacy(i,j) - cdif (i,j)=(cx (i+1,j)-cx (i,j))*hdacx(i,j) & - +(cy (i,j+1)-cy (i,j))*hdacy(i,j) - q2dif(i,j)=(q2x(i+1,j)-q2x(i,j))*hdacx(i,j) & - +(q2y(i,j+1)-q2y(i,j))*hdacy(i,j) - enddo - enddo -!----------------------------------------------------------------------- - do j=jts_b1,jte_b2 - do i=its_b1,ite_b2 - udif(i,j)=(ux(i+1,j)-ux(i,j))*hdacvx(i,j) & - +(uy(i,j+1)-uy(i,j))*hdacvy(i,j) - vdif(i,j)=(vx(i+1,j)-vx(i,j))*hdacvx(i,j) & - +(vy(i,j+1)-vy(i,j))*hdacvy(i,j) - enddo - enddo -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!-------------2-nd order diffusion-------------------------------------- -!----------------------------------------------------------------------- - do j=jts_b1,jte_b1 - do i=its_b1,ite_b1 - t (i,j,l)=t (i,j,l)+tdif (i,j) -!-- Enhanced diffusion for Q & CWM if facdif>1 !bsf: - q (i,j,l)=q (i,j,l)+facdif*qdif (i,j) - cw(i,j,l)=cw(i,j,l)+facdif*cdif (i,j) - q2(i,j,l)=q2(i,j,l)+q2dif(i,j) - enddo - enddo - do j=jts_b1,jte_b2 - do i=its_b1,ite_b2 - u(i,j,l)=u(i,j,l)+udif(i,j) - v(i,j,l)=v(i,j,l)+vdif(i,j) - enddo - enddo -!----------------------------------------------------------------------- -! - enddo vertical_loop_3 -!....................................................................... -!$omp end parallel do -!....................................................................... -! -!----------------------------------------------------------------------- -! - endsubroutine hdiff -! -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- - subroutine cdzdt & -(global,hydro & -,lm & -,dt & -,dsg2,pdsg1 & -,fah & -,fis,pd,pdo & -,psgdt & -,cw,q,rtop,t & -,pint & -,dwdt,pdwdt,w,baro & -,z & -!---temporary arguments------------------------------------------------- -,pfne,pfnw,pfx,pfy) -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -implicit none -!----------------------------------------------------------------------- -real(kind=kfpt),parameter:: & - cfc=1.533 & ! adams-bashforth positioning in time -,bfc=1.-cfc ! adams bashforth positioning in time -!----------------------------------------------------------------------- -logical(kind=klog),intent(in):: & - global & ! global or regional -,hydro ! hydrostatic or nonhydrostatic - -integer(kind=kint),intent(in):: & - lm ! total # of levels - -real(kind=kfpt),intent(in):: & - dt ! dynamics time step - -real(kind=kfpt),dimension(1:lm),intent(in):: & - dsg2 & ! delta sigmas -,pdsg1 ! delta pressures - -real(kind=kfpt),dimension(jds:jde),intent(in):: & - fah ! - -real(kind=kfpt),dimension(ims:ime,jms:jme),intent(in):: & - fis & ! surface geopotential -,pd & ! sigma range pressure difference -,pdo ! sigma range pressure difference - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm-1),intent(in):: & - psgdt ! vertical mass flux - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(in):: & - cw & ! condensate -,q & ! specific humidity -,rtop & ! rt/p -,t ! temperature - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm+1),intent(in):: & - pint ! pressure at interfaces - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(inout):: & - dwdt & ! nonhydrostatic correction factor -,pdwdt & ! previous nonhydrostatic correction factor -,w ! w wind component - -real(kind=kfpt),dimension(ims:ime,jms:jme),intent(out):: & - baro - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(out):: & - z ! heights in the middle of the layers -!----------------------------------------------------------------------- -!---temporary arguments------------------------------------------------- -!----------------------------------------------------------------------- -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(in) :: & - pfne & ! mass flux, ne direction -,pfnw & ! mass flux, nw direction -,pfx & ! mass flux, x direction -,pfy ! mass flux, y direction -!----------------------------------------------------------------------- -!--local variables------------------------------------------------------ -!----------------------------------------------------------------------- -integer(kind=kint):: & - i & ! index in x direction -,j & ! index in y direction -,l ! index in p direction - -real(kind=kfpt):: & - dpup & ! -,dw & ! w wind component increment -,dz & ! layer thickness -,fahp & ! -,rg & ! -,rdt & ! -,trog & ! -,wup & ! w wind component at upper interface -,zup ! height of upper interface - -real(kind=kfpt),dimension(its_b1:ite_h2,jts_b1:jte_h2):: & - zne & ! height flux, ne direction -,znw & ! height flux, nw direction -,zx & ! height flux, x direction -,zy ! height flux, y direction - -real(kind=kfpt),dimension(its_b1:ite_b1,jts_b1:jte_b1):: & - tta & ! advection through upper interface -,ttb ! advection through lower interface - -real(kind=kfpt),dimension(its_h1:ite_h2,jts_h1:jte_h2):: & - wlo & ! w wind component at lower interface -,zlo ! height at lower interface -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - rg=1./g - rdt=1./dt - trog=2.*r/g -! -!----------------------------------------------------------------------- -!----------------- -#ifdef ENABLE_SMP -!----------------- -!....................................................................... -!$omp parallel private(dw,dz,i,j,l,jstart,jstop,nth,tid,wup,zup) - nth = omp_get_num_threads() - tid = omp_get_thread_num() - call looplimits(tid, nth, jts_h1,jte_h2,jstart,jstop) -!....................................................................... -!----------------- -#else -!----------------- - jstart = jts_h1 - jstop = jte_h2 -!----------------- -#endif -!----------------- - do j=jstart,jstop - do i=its_h1,ite_h2 - wlo(i,j)=0. - zlo(i,j)=fis(i,j)*rg - enddo - enddo -!----------------------------------------------------------------------- -!---nonhydrostatic equation--------------------------------------------- -!----------------------------------------------------------------------- - do l=lm,1,-1 - do j=jstart,jstop - do i=its_h1,ite_h2 - pdwdt(i,j,l)=dwdt(i,j,l) - dwdt(i,j,l)=w(i,j,l) -! - dz=(q(i,j,l)*0.608+(1.-cw(i,j,l)))*t(i,j,l)*trog & - *(dsg2(l)*pd(i,j)+pdsg1(l))/(pint(i,j,l)+pint(i,j,l+1)) - dw=(dz-rtop(i,j,l)*(dsg2(l)*pdo(i,j)+pdsg1(l))*rg)*rdt -! - zup=zlo(i,j)+dz - wup=wlo(i,j)+dw - z(i,j,l)=dz*0.5+zlo(i,j) - w(i,j,l)=dw*0.5+wlo(i,j) -! - zlo(i,j)=zup - wlo(i,j)=wup - enddo - enddo - enddo -!----------------- -#ifdef ENABLE_SMP -!----------------- -!....................................................................... -!$omp end parallel -!....................................................................... -!----------------- -#endif -!----------------- -!----------------------------------------------------------------------- -! - if(hydro) return -! -!----------------------------------------------------------------------- -!----------------- -#ifdef ENABLE_SMP -!----------------- -!....................................................................... -!$omp parallel private(i,j,l,jstart,jstop,nth,tid) -!....................................................................... - nth = omp_get_num_threads() - tid = omp_get_thread_num() - call looplimits(tid, nth, jts_b1,jte_b1,jstart,jstop) -!----------------- -#else -!----------------- - jstart = jts_b1 - jstop = jte_b1 -!----------------- -#endif -!----------------- -! - do j=jstart,jstop - do i=its_b1,ite_b1 - ttb(i,j)=0. - enddo - enddo -! - do l=1,lm-1 - do j=jstart,jstop - do i=its_b1,ite_b1 - tta(i,j)=(z(i,j,l+1)-z(i,j,l))*psgdt(i,j,l)*0.5 - w(i,j,l)=(tta(i,j)+ttb(i,j)) & - /(dsg2(l)*pdo(i,j)+pdsg1(l)) & - +w(i,j,l) - ttb(i,j)=tta(i,j) - enddo - enddo - enddo -! - do j=jstart,jstop - do i=its_b1,ite_b1 - w(i,j,lm)=ttb(i,j)/(dsg2(lm)*pdo(i,j)+pdsg1(lm))+w(i,j,lm) - enddo - enddo -! -!----------------------------------------------------------------------- -!---grand horizontal loop----------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------- -#ifdef ENABLE_SMP -!----------------- -!....................................................................... -!$omp end parallel -!....................................................................... -!$omp parallel do private(dpup,fahp,i,j,l,zne,znw,zx,zy) -!....................................................................... -!----------------- -#endif -!----------------- -!----------------------------------------------------------------------- -! - vertical_loop: do l=1,lm -! -!----------------------------------------------------------------------- -! - dpup=pdsg1(l) -! -!----------------------------------------------------------------------- -!-------------mass fluxes, on h points---------------------------------- -!----------------------------------------------------------------------- - do j=jts_b1,jte_h1 - do i=its_b1,ite_h1 - zx(i,j)=(z(i,j,l)-z(i-1,j,l))*pfx(i,j,l) - zy(i,j)=(z(i,j,l)-z(i,j-1,l))*pfy(i,j,l) - zne(i,j)=(z(i,j,l)-z(i-1,j-1,l))*pfne(i,j,l) - znw(i,j)=(z(i-1,j,l)-z(i,j-1,l))*pfnw(i,j,l) - enddo - enddo -!----------------------------------------------------------------------- -!---advection of height------------------------------------------------- -!----------------------------------------------------------------------- - do j=jts_b1,jte_b1 - fahp=-fah(j)/dt - do i=its_b1,ite_b1 - w(i,j,l)=((zx(i,j)+zx(i+1,j)+zy(i,j)+zy(i,j+1)) & - +(zne(i+1,j+1)+zne(i,j) & - +znw(i,j+1)+znw(i+1,j))*0.25)*fahp & - /(dsg2(l)*pdo(i,j)+pdsg1(l)) & - +w(i,j,l) - enddo - enddo -!----------------------------------------------------------------------- -!---setting w on h points to 0. along boundaries------------------------ -!----------------------------------------------------------------------- - if(.not.global) then -!----------------------------------------------------------------------- - if(s_bdy)then - do j=jts,jts+1 - do i=its,ite - w(i,j,l)=0. - enddo - enddo - endif -! - if(n_bdy)then - do j=jte-1,jte - do i=its,ite - w(i,j,l)=0. - enddo - enddo - endif -! - if(w_bdy)then - do j=jts,jte - do i=its,its+1 - w(i,j,l)=0. - enddo - enddo - endif -! - if(e_bdy)then - do j=jts,jte - do i=ite-1,ite - w(i,j,l)=0. - enddo - enddo - endif -!----------------------------------------------------------------------- - endif -!----------------------------------------------------------------------- - enddo vertical_loop -!------------------ -#ifdef ENABLE_SMP -!------------------ -!....................................................................... -!$omp end parallel do -!....................................................................... -!------------------ -#endif -!------------------ -!----------------------------------------------------------------------- -!---taking external mode out-------------------------------------------- -!----------------------------------------------------------------------- - do j=jts_b1,jte_b1 - do i=its_b1,ite_b1 -! ttb(i,j)=0. - baro(i,j)=0. - enddo - enddo -! - do l=1,lm - do j=jts_b1,jte_b1 - do i=its_b1,ite_b1 -! ttb(i,j)=(dsg2(l)*pdo(i,j)+pdsg1(l))*w(i,j,l)+ttb(i,j) - baro(i,j)=(dsg2(l)*pdo(i,j)+pdsg1(l))*w(i,j,l) & - +baro(i,j) - enddo - enddo - enddo -! - do j=jts_b1,jte_b1 - do i=its_b1,ite_b1 -! ttb(i,j)=ttb(i,j)/pdo(i,j) - baro(i,j)=baro(i,j)/pdo(i,j) - enddo - enddo -! - do l=1,lm - do j=jts_b1,jte_b1 - do i=its_b1,ite_b1 -! w(i,j,l)=w(i,j,l)-ttb(i,j) - w(i,j,l)=w(i,j,l)-baro(i,j) - enddo - enddo - enddo -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - endsubroutine cdzdt -! -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- - subroutine cdwdt & -(global,hydro,restart & -,inpes,jnpes,lm,ntsd & -,dt,g & -,dsg2,pdsg1,psgml1 & -,fah & -,hdacx,hdacy & -,pd,pdo & -,psgdt & -,dwdt,pdwdt,w & -,pint & -!---temporary arguments------------------------------------------------- -,def,pfx,pfy,pfne,pfnw) -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -implicit none -!----------------------------------------------------------------------- -integer(kind=kint),parameter:: & - nsmud=00 & ! number of smoothing iterations -,lnsnh=02 ! # of rows with smoothing along boundaries - -real(kind=kfpt),parameter:: & - epsfc=9.80 & ! limiter value -,epsn=-epsfc & ! floor value for vertical acceleration -,epsp=epsfc & ! upper limit for vertical acceleration -,fwhy=1. & ! dwdt control factor -,slpd=1500. & ! dwdt control layer depth (Pa) -,epsvw=9999. & ! limit on horizontal advection of w -,wa=0.125 & ! weighting factor -,wb=0.5 & ! weighting factor -!,wad=0.125 & ! lateral smoothing weight -!,wad=0.0625 & ! lateral smoothing weight -!,wad=0.075 & ! lateral smoothing weight -!,wad=0.050 & ! lateral smoothing weight -,wad=0. & ! lateral smoothing weight -!,wp=0.075 & ! time smoothing weight -,wp=0. ! time smoothing weight -!----------------------------------------------------------------------- - -integer(kind=kint):: & - lsltp ! # of layers within dwdt contol range - -logical(kind=klog),intent(in):: & - global & ! global or regional -,hydro & ! hydrostatic or nonhydrostatic -,restart ! restart - -integer(kind=kint),intent(in):: & - lm & ! total # of levels -,ntsd & ! time step -,inpes & ! tasks in x direction -,jnpes ! tasks in y direction - -real(kind=kfpt),intent(in):: & - dt & ! dynamics time step -,g ! gravity - -real(kind=kfpt),dimension(1:lm),intent(in):: & - dsg2 & ! delta sigmas -,pdsg1 & ! delta pressures -,psgml1 ! midlayer pressure part - -real(kind=kfpt),dimension(jds:jde),intent(in):: & - fah ! delta sigmas - -real(kind=kfpt),dimension(ims:ime,jms:jme),intent(in):: & - pd & ! sigma range pressure difference -,hdacx & ! exchange coefficient mass point -,hdacy & ! exchange coefficient mass point -,pdo ! old sigma range pressure difference - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm-1),intent(in):: & - psgdt ! vertical mass flux - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(inout):: & - dwdt & ! nonhydrostatic correction factor -,pdwdt & ! previous nonhydrostatic correction factor -,w ! w wind component - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm+1),intent(inout):: & - pint ! pressure -!----------------------------------------------------------------------- -!---temporary arguments------------------------------------------------- -!----------------------------------------------------------------------- -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(in) :: & - def & ! deformation -,pfx & ! mass flux, x direction -,pfy & ! mass flux, y direction -,pfne & ! mass flux, ne direction -,pfnw ! mass flux, nw direction -!----------------------------------------------------------------------- -!--local variables------------------------------------------------------ -!----------------------------------------------------------------------- -logical(kind=klog) :: diffw ! turn horizontal diffusion of w on/off - -integer(kind=kint):: & - i & ! index in x direction -,imn & ! -,imx & ! -,j & ! index in y direction -,jmn & ! -,jmx & ! -,l & ! index in p direction -,lmn & ! -,lmx & ! -,kn & ! counter -,kp & ! counter -,ks ! smoothing counter - -real(kind=kfpt):: & - advec & ! -,arg & ! -,dwdtmn & ! minimum value of dwdt -,dwdtmx & ! maximum value of dwdt -,dwdtp & ! nonhydrostatic correction factor at the point -,fahp & ! grid factor -,rdt & ! 1/dt -,rg & ! 1/g -,sltp ! uppermost midlayer pressure - -real(kind=kfpt),dimension(1:lm):: & - why ! dwdt control weight - -real(kind=kfpt),dimension(its_b1:ite_b1,jts_b1:jte_b1):: & - tta ! advection through upper interface -real(kind=kfpt),dimension(its:ite,jts:jte):: & - ttb ! advection through lower interface -real(kind=kfpt),dimension(its_b1:ite_h1,jts_b1:jte_h1):: & - wne & ! height flux, ne direction -,wnw & ! height flux, nw direction -,wx & ! height flux, x direction -,wy ! height flux, y direction - -real(kind=kfpt),dimension(ims:ime,jms:jme):: & - ww ! temporary for lateral smoothing -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -! -!--- cannot diffuse w when in the backward step of digital filtering -! - if (dt .gt. 0) then - diffw=.true. - else - diffw=.false. - endif -! -!----------------------------------------------------------------------- - if(hydro.or.(.not.hydro.and..not.restart.and.ntsd.lt.2)) then -!----------------------------------------------------------------------- - do l=1,lm - do j=jts,jte - do i=its,ite - dwdt(i,j,l)=1. - pdwdt(i,j,l)=1. - pint(i,j,l+1)=dsg2(l)*pd(i,j)+pdsg1(l)+pint(i,j,l) - enddo - enddo - enddo -!----------------------------------------------------------------------- - return -!----------------------------------------------------------------------- - endif -!----------------------------------------------------------------------- - if(.not.global) then -!---smoothing of w on h points along boundaries------------------------- - if(nsmud.gt.0) then -!----------------------------------------------------------------------- - do ks=1,nsmud -!----------------------------------------------------------------------- - do l=1,lm -!----------------------------------------------------------------------- - if(s_bdy)then - do j=jts+1,lnsnh - do i=its_b1,ite_b1 - ww(i,j)=(w(i,j-1,l)+w(i-1,j,l) & - +w(i+1,j,l)+w(i,j+1,l))*wa & - +w(i,j,l)*wb - enddo - enddo - endif -! - if(n_bdy)then - do j=jte-lnsnh+1,jte-1 - do i=its_b1,ite_b1 - ww(i,j)=(w(i,j-1,l)+w(i-1,j,l) & - +w(i+1,j,l)+w(i,j+1,l))*wa & - +w(i,j,l)*wb - enddo - enddo - endif -! - if(w_bdy)then - do j=max(jts,jds+lnsnh),min(jte,jde-lnsnh) - do i=its+1,its-1+lnsnh - ww(i,j)=(w(i,j-1,l)+w(i-1,j,l) & - +w(i+1,j,l)+w(i,j+1,l))*wa & - +w(i,j,l)*wb - enddo - enddo - endif -! - if(e_bdy)then - do j=max(jts,jds+lnsnh),min(jte,jde-lnsnh) - do i=ite-lnsnh+1,ite-1 - ww(i,j)=(w(i,j-1,l)+w(i-1,j,l) & - +w(i+1,j,l)+w(i,j+1,l))*wa & - +w(i,j,l)*wb - enddo - enddo - endif -! - if(s_bdy)then - do j=its+1,its-1+lnsnh - do i=its_b1,ite_b1 - w(i,j,l)=ww(i,j) - enddo - enddo - endif -! - if(n_bdy)then - do j=jte-lnsnh+1,jte-1 - do i=its_b1,ite_b1 - w(i,j,l)=ww(i,j) - enddo - enddo - endif -! - if(w_bdy)then - do j=max(jts,jds+lnsnh),min(jte,jde-lnsnh) - do i=its+1,lnsnh - w(i,j,l)=ww(i,j) - enddo - enddo - endif -! - if(e_bdy)then - do j=max(jts,jds+lnsnh),min(jte,jde-lnsnh) - do i=ite-lnsnh+1,ite-1 - w(i,j,l)=ww(i,j) - enddo - enddo - endif -!----------------------------------------------------------------------- - enddo -!----------------------------------------------------------------------- - enddo -!----------------------------------------------------------------------- - endif ! end of smoothing of w along lateral boundaries -!----------------------------------------------------------------------- -! - endif -! -!----------------------------------------------------------------------- -!---local derivative of w on h points----------------------------------- -!----------------------------------------------------------------------- -! - rdt=1./dt -! -!....................................................................... -!$omp parallel do private(i,j,l) -!....................................................................... - do l=1,lm - do j=jts,jte - do i=its,ite - dwdt(i,j,l)=(w(i,j,l)-dwdt(i,j,l))*rdt - enddo - enddo - enddo -!....................................................................... -!$omp end parallel do -!....................................................................... - -!----------------------------------------------------------------------- -!---lateral diffusion of w---------------------------------------------- -!----------------------------------------------------------------------- -! - if(diffw) then -! -!----------------------------------------------------------------------- -! - do l=1,lm -! -!----------------------------------------------------------------------- -!---w fluxes, on h points----------------------------------------------- -!----------------------------------------------------------------------- -! - do j=jts_b1,jte_h1 - do i=its_b1,ite_h1 - wx(i,j)=(w(i,j,l)-w(i-1,j,l))*(def(i-1,j,l)+def(i,j,l)) - wy(i,j)=(w(i,j,l)-w(i,j-1,l))*(def(i,j-1,l)+def(i,j,l)) - enddo - enddo -! -!----------------------------------------------------------------------- -!---diffusion of w------------------------------------------------------ -!----------------------------------------------------------------------- -! - do j=jts_b1,jte_b1 - do i=its_b1,ite_b1 - dwdt(i,j,l)=-((wx(i+1,j)-wx(i,j))*hdacx(i,j) & - +(wy(i,j+1)-wy(i,j))*hdacy(i,j))*rdt & - +dwdt(i,j,l) - enddo - enddo -! -!----------------------------------------------------------------------- -! - enddo -! -!----------------------------------------------------------------------- -! - endif -!----------------------------------------------------------------------- -!---vertical advection of w--------------------------------------------- -!----------------------------------------------------------------------- - do j=jts,jte - do i=its,ite - ttb(i,j)=0. - enddo - enddo -! - do l=1,lm-1 - do j=jts_b1,jte_b1 - do i=its_b1,ite_b1 - tta(i,j)=(w(i,j,l+1)-w(i,j,l))*psgdt(i,j,l)*0.5 - dwdt(i,j,l)=(tta(i,j)+ttb(i,j)) & - /(dsg2(l)*pdo(i,j)+pdsg1(l)) & - +dwdt(i,j,l) - ttb(i,j)=tta(i,j) - enddo - enddo - enddo -! - do j=jts,jte - do i=its,ite - dwdt(i,j,lm)=ttb(i,j)/(dsg2(lm)*pdo(i,j)+pdsg1(lm)) & - +dwdt(i,j,lm) - enddo - enddo - - kn=0 - kp=0 - imn=0 - jmn=0 - lmn=0 - imx=0 - jmx=0 - lmx=0 - dwdtmx=0. - dwdtmn=0. - -!----------------------------------------------------------------------- -! -!....................................................................... -!$omp parallel do private (fahp,i,j,l,wne,wnw,wx,wy) -!....................................................................... -!----------------------------------------------------------------------- - do l=1,lm -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!---w fluxes, on h points----------------------------------------------- -!----------------------------------------------------------------------- - do j=jts_b1,jte_h1 - do i=its_b1,ite_h1 - wx(i,j)=(w(i,j,l)-w(i-1,j,l))*pfx(i,j,l) - wy(i,j)=(w(i,j,l)-w(i,j-1,l))*pfy(i,j,l) - wne(i,j)=(w(i,j,l)-w(i-1,j-1,l))*pfne(i,j,l) - wnw(i,j)=(w(i-1,j,l)-w(i,j-1,l))*pfnw(i,j,l) - enddo - enddo -!----------------------------------------------------------------------- -!---advection of w------------------------------------------------------ -!----------------------------------------------------------------------- - do j=jms,jme - do i=ims,ime - ww(i,j)=0. - enddo - enddo - - do j=jts_b1,jte_b1 - fahp=-fah(j)/dt - do i=its_b1,ite_b1 - advec=((wx(i,j)+wx(i+1,j)+wy(i,j)+wy(i,j+1)) & - +(wne(i+1,j+1)+wne(i,j) & - +wnw(i,j+1)+wnw(i+1,j))*0.25)*fahp & - /(dsg2(l)*pdo(i,j)+pdsg1(l)) - - dwdtp=advec - - if(dwdtp.gt.dwdtmx) then - dwdtmx=dwdtp - imx=i - jmx=j - lmx=l - endif - if(dwdtp.lt.dwdtmn) then - dwdtmn=dwdtp - imn=i - jmn=j - lmn=l - endif - if(dwdtp.gt. epsvw) then - kp=kp+1 - endif - if(dwdtp.lt.-epsvw) then - kn=kn+1 - endif - -! - if(advec.gt. epsvw) advec= epsvw - if(advec.lt.-epsvw) advec=-epsvw -! - dwdt(i,j,l)=advec & - +dwdt(i,j,l) - - enddo - enddo -!----------------------------------------------------------------------- -! - enddo -!....................................................................... -!$omp end parallel do -!....................................................................... - 1300 format(' **** advecmx=',f9.5,' kp=',i6,' imx=',i4,' jmx=',i4,' lmx=',i2) - 1400 format(' **** advecmn=',f9.5,' kn=',i6,' imn=',i4,' jmn=',i4,' lmn=',i2) - do l=1,lm - why(l)=-99. - enddo -! - lsltp=0 - sltp=(psgml1(1)+psgml1(2))*0.5 - do l=1,lm-1 - arg=((psgml1(l)+psgml1(l+1))*0.5-sltp)/slpd - if(arg.gt.1.) exit - why(l)=1.-fwhy*cos(arg*pi*0.5)**2 - lsltp=l - enddo -! - do l=1,lsltp - do j=jts_b1,jte_b1 - do i=its_b1,ite_b1 - dwdt(i,j,l)=dwdt(i,j,l)*why(l) - enddo - enddo - enddo -!----------------------------------------------------------------------- -!---taking external mode out-------------------------------------------- -!----------------------------------------------------------------------- - do j=jts_b1,jte_b1 - do i=its_b1,ite_b1 - ttb(i,j)=0. - enddo - enddo -! - do l=1,lm - do j=jts_b1,jte_b1 - do i=its_b1,ite_b1 - ttb(i,j)=(dsg2(l)*pdo(i,j)+pdsg1(l))*dwdt(i,j,l)+ttb(i,j) - enddo - enddo - enddo -! - do j=jts_b1,jte_b1 - do i=its_b1,ite_b1 - ttb(i,j)=ttb(i,j)/pdo(i,j) - enddo - enddo -! - do l=1,lm - do j=jts_b1,jte_b1 - do i=its_b1,ite_b1 - dwdt(i,j,l)=dwdt(i,j,l)-ttb(i,j) - enddo - enddo - enddo -!----------------------------------------------------------------------- - if(global) then - btim=timef() - call swaphn(dwdt,ims,ime,jms,jme,lm,inpes) - timers(my_domain_id)%swaphn_tim=timers(my_domain_id)%swaphn_tim+(timef()-btim) -! - btim=timef() - call polehn(dwdt,ims,ime,jms,jme,lm,inpes,jnpes) - timers(my_domain_id)%polehn_tim=timers(my_domain_id)%polehn_tim+(timef()-btim) - endif -! - btim=timef() - call halo_exch(dwdt,lm,1,1) - timers(my_domain_id)%exch_dyn=timers(my_domain_id)%exch_dyn+(timef()-btim) -! -!----------------------------------------------------------------------- -!------------spatial filtering of dwdt---------------------------------- -!----------------------------------------------------------------------- -! - if(wad.gt.0.) then -! -!....................................................................... -!$omp parallel do private (i,j,l,ww) -!....................................................................... - do l=1,lm - do j=jts_b1,jte_b1 - do i=its_b1,ite_b1 - ww(i,j)=(dwdt(i,j-1,l)+dwdt(i-1,j,l) & - +dwdt(i+1,j,l)+dwdt(i,j+1,l)-dwdt(i,j,l)*4.0) - enddo - enddo -! - do j=jts_b1,jte_b1 - do i=its_b1,ite_b1 - dwdt(i,j,l)=ww(i,j)*wad+dwdt(i,j,l) - enddo - enddo - enddo -!....................................................................... -!$omp end parallel do -!....................................................................... - endif -! -!----------------------------------------------------------------------- -! - if(global) then - btim=timef() - call swaphn(dwdt,ims,ime,jms,jme,lm,inpes) - timers(my_domain_id)%swaphn_tim=timers(my_domain_id)%swaphn_tim+(timef()-btim) -! - btim=timef() - call polehn(dwdt,ims,ime,jms,jme,lm,inpes,jnpes) - timers(my_domain_id)%polehn_tim=timers(my_domain_id)%polehn_tim+(timef()-btim) - endif -!----------------------------------------------------------------------- - rg=1./g -! - kn=0 - kp=0 - imn=0 - jmn=0 - lmn=0 - imx=0 - jmx=0 - lmx=0 - dwdtmx=0. - dwdtmn=0. -! - do l=1,lm - do j=jts,jte - do i=its,ite - dwdtp=dwdt(i,j,l) - if(dwdtp.gt.dwdtmx) then - dwdtmx=dwdtp - imx=i - jmx=j - lmx=l - endif - if(dwdtp.lt.dwdtmn) then - dwdtmn=dwdtp - imn=i - jmn=j - lmn=l - endif - if(dwdtp.lt.epsn) then - dwdtp=epsn - kn=kn+1 - endif - if(dwdtp.gt.epsp) then - dwdtp=epsp - kp=kp+1 - endif - dwdt(i,j,l)=(dwdtp*rg+1.)*(1.-wp)+pdwdt(i,j,l)*wp - enddo - enddo - enddo - 1100 format(' dwdtmx=',f9.5,' kp=',i6,' imx=',i4,' jmx=',i4,' lmx=',i2) - 1200 format(' dwdtmn=',f9.5,' kn=',i6,' imn=',i4,' jmn=',i4,' lmn=',i2) -!----------------------------------------------------------------------- -! - if(.not.global) then -! -!----------------------------------------------------------------------- -!---setting dwdt on h points to 1. along boundaries--------------------- -!----------------------------------------------------------------------- - do l=1,lm - if(s_bdy)then - do j=jts,jts+1 - do i=its,ite - dwdt(i,j,l)=1. - enddo - enddo - endif -! - if(n_bdy)then - do j=jte-1,jte - do i=its,ite - dwdt(i,j,l)=1. - enddo - enddo - endif -! - if(w_bdy)then - do j=jts,jte - do i=its,its+1 - dwdt(i,j,l)=1. - enddo - enddo - endif -! - if(e_bdy)then - do j=jts,jte - do i=ite-1,ite - dwdt(i,j,l)=1. - enddo - enddo - endif - enddo -!----------------------------------------------------------------------- - endif ! regional -!----------------------------------------------------------------------- -! - endsubroutine cdwdt -! -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- - subroutine vsound & -(global,hydro,restart & -,lm,ntsd & -,cp,dt,pt & -,dsg2,pdsg1 & -,pd & -,cw,q,rtop & -,dwdt,t,w,w_tot,baro & -,pint) -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -implicit none -!----------------------------------------------------------------------- -integer(kind=kint),parameter:: & - nsmud=0 ! number of smoothing iterations - -real(kind=kfpt),parameter:: & - wght=0.35 ! first guess weight -!----------------------------------------------------------------------- -logical(kind=klog),intent(in):: & - global & ! global or regional -,hydro & ! hydrostatic or nonhydrostatic -,restart ! restart case - -integer(kind=kint),intent(in):: & - lm & ! total # of levels -,ntsd ! time step - -real(kind=kfpt),intent(in):: & - cp & ! cp -,dt & ! dynamics time step -,pt ! pressure at the top of the model's atmosphere - -real(kind=kfpt),dimension(1:lm),intent(in):: & - dsg2 & ! delta sigmas -,pdsg1 ! delta pressures - -real(kind=kfpt),dimension(ims:ime,jms:jme),intent(in):: & - baro - -real(kind=kfpt),dimension(ims:ime,jms:jme),intent(in):: & - pd ! sigma range pressure difference - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(in):: & - cw & ! condensate -,q & ! specific humidity -,rtop ! rt/p - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(inout):: & - dwdt & ! nonhydrostatic correction factor -,t & ! previous nonhydrostatic correction factor -,w ! w wind component - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(out):: & - w_tot ! total w wind component for output - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm+1),intent(inout):: & - pint -!----------------------------------------------------------------------- -!--local variables------------------------------------------------------ -!----------------------------------------------------------------------- -integer(kind=kint):: & - i & ! index in x direction -,j & ! index in y direction -,l ! index in p direction - -real(kind=kfpt):: & - cappa & ! R/cp -,cofl & ! -,dp & ! -,delp & ! -,dppl & ! -,dpstr & ! -,dptl & ! -,fcc & ! -,ffc & ! -,gdt & ! g*dt -,gdt2 & ! gdt**2 -,pp1 & ! -,rcph & ! -,rdpdn & ! -,rdpup & ! -,tfc & ! -,tmp ! - -real(kind=kfpt),dimension(its_b1:ite_b1,jts_b1:jte_b1):: & - dptu ! - -real(kind=kfpt),dimension(its_b1:ite_b1,jts_b1:jte_b1,1:lm):: & - b1 & ! -,b2 & ! -,b3 & ! -,c0 & ! -,rdpp ! - -real(kind=kfpt),dimension(its_b1:ite_b1,jts_b1:jte_b1,1:lm+1):: & - chi & ! -,coff & ! -,dfrh & ! -,pnp1 & ! -,pone & ! -,pstr ! -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - if(hydro.or.ntsd.lt.2) return -! -!----------------------------------------------------------------------- - cappa=r/cp - gdt=g*dt - gdt2=gdt*gdt - ffc=-r*0.25/gdt2 - rcph=0.5/cp -!----------------------------------------------------------------------- -!----------------- -#ifdef ENABLE_SMP -!----------------- -!....................................................................... -!$omp parallel & -!$omp private(i,j,jstart,jstop,nth,tid) -!....................................................................... - nth = omp_get_num_threads() - tid = omp_get_thread_num() - call looplimits(tid, nth, jts_b1, jte_b1, jstart, jstop) -!----------------- -#else -!----------------- - jstart = jts_b1 - jstop = jte_b1 -!----------------- -#endif -!----------------- -! - do j=jstart,jstop - do i=its_b1,ite_b1 - pone(i,j,1)=pt - pstr(i,j,1)=pt - pnp1(i,j,1)=pt - enddo - enddo -! -!----------------- -#ifdef ENABLE_SMP -!----------------- -!....................................................................... -!$omp end parallel -!....................................................................... -!----------------- -#endif -!----------------- -! - jstart = jts_b1 - jstop = jte_b1 -! - do l=2,lm+1 - do j=jstart,jstop - do i=its_b1,ite_b1 - dppl=dsg2(l-1)*pd(i,j)+pdsg1(l-1) - rdpp(i,j,l-1)=1./dppl - dpstr=dwdt(i,j,l-1)*dppl - pstr(i,j,l)=pstr(i,j,l-1)+dpstr - pp1=pnp1(i,j,l-1)+dpstr - pone(i,j,l)=pint(i,j,l) - dp=(pp1-pone(i,j,l))*wght - pnp1(i,j,l)=pone(i,j,l)+dp - tfc=q(i,j,l-1)*0.608-cw(i,j,l-1)+1. - fcc=(1.-cappa*tfc)*tfc*ffc - cofl=t(i,j,l-1)*dppl*fcc & - /((pnp1(i,j,l-1)+pnp1(i,j,l))*0.5)**2 - coff(i,j,l-1)=cofl - dfrh(i,j,l)=(pstr(i,j,l-1)+pstr(i,j,l) & - -pone(i,j,l-1)-pone(i,j,l))*cofl - enddo - enddo - enddo -!----------------------------------------------------------------------- -!----------------- -#ifdef ENABLE_SMP -!----------------- -!....................................................................... -!$omp parallel & -!$omp private(delp,dptl,i,j,jstart,jstop,l,nth,rdpdn,rdpup,tid,tmp) -!....................................................................... - nth = omp_get_num_threads() - tid = omp_get_thread_num() - call looplimits(tid, nth, jts_b1, jte_b1, jstart, jstop) -!----------------- -#else -!----------------- - jstart = jts_b1 - jstop = jte_b1 -!----------------- -#endif -!----------------- -! - do l=2,lm - do j=jstart,jstop - do i=its_b1,ite_b1 - rdpdn=rdpp(i,j,l) - rdpup=rdpp(i,j,l-1) - b1(i,j,l)=coff(i,j,l-1)+rdpup - b2(i,j,l)=coff(i,j,l-1)+coff(i,j,l)-rdpup-rdpdn - b3(i,j,l)=coff(i,j,l)+rdpdn - c0(i,j,l)=-dfrh(i,j,l)-dfrh(i,j,l+1) - enddo - enddo - enddo -!----------------------------------------------------------------------- - do j=jstart,jstop - do i=its_b1,ite_b1 - b2(i,j,lm)=b2(i,j,lm)+b3(i,j,lm) - enddo - enddo -! - do l=3,lm - do j=jstart,jstop - do i=its_b1,ite_b1 - tmp=-b1(i,j,l)/b2(i,j,l-1) - b2(i,j,l)=b3(i,j,l-1)*tmp+b2(i,j,l) - c0(i,j,l)=c0(i,j,l-1)*tmp+c0(i,j,l) - enddo - enddo - enddo -!----------------------------------------------------------------------- - do j=jstart,jstop - do i=its_b1,ite_b1 - chi(i,j,1)=0. - chi(i,j,lm)=c0(i,j,lm)/b2(i,j,lm) - chi(i,j,lm+1)=chi(i,j,lm) - enddo - enddo -! - do l=lm-1,2,-1 - do j=jstart,jstop - do i=its_b1,ite_b1 - chi(i,j,l)=(-b3(i,j,l)*chi(i,j,l+1)+c0(i,j,l))/b2(i,j,l) - enddo - enddo - enddo -!----------------------------------------------------------------------- - do l=1,lm+1 - do j=jstart,jstop - do i=its_b1,ite_b1 - pnp1(i,j,l)=chi(i,j,l)+pstr(i,j,l) - pint(i,j,l)=pnp1(i,j,l) - enddo - enddo - enddo -!----------------------------------------------------------------------- - do j=jstart,jstop - do i=its_b1,ite_b1 - dptu(i,j)=0. - enddo - enddo -! - do l=1,lm - do j=jstart,jstop - do i=its_b1,ite_b1 - dptl=pnp1(i,j,l+1)-pone(i,j,l+1) - t(i,j,l)=(dptu(i,j)+dptl)*rtop(i,j,l)*rcph+t(i,j,l) - delp=(pnp1(i,j,l+1)-pnp1(i,j,l))*rdpp(i,j,l) - w(i,j,l)=(delp-dwdt(i,j,l))*gdt+w(i,j,l) - w_tot(i,j,l)=w(i,j,l)+baro(i,j) - dwdt(i,j,l)=delp - dptu(i,j)=dptl - enddo - enddo - enddo -!----------------- -#ifdef ENABLE_SMP -!----------------- -!....................................................................... -!$omp end parallel -!....................................................................... -!----------------- -#endif -!----------------- -!----------------------------------------------------------------------- -! - if(.not.global) then -! -!----------------------------------------------------------------------- -!---setting dwdt on h points to 1. along boundaries--------------------- -!----------------------------------------------------------------------- - if(s_bdy)then - do l=1,lm - do j=jts,jts+1 - do i=its,ite - dwdt(i,j,l)=1. - enddo - enddo - enddo - endif -! - if(n_bdy)then - do l=1,lm - do j=jte-1,jte - do i=its,ite - dwdt(i,j,l)=1. - enddo - enddo - enddo - endif -! - if(w_bdy)then - do l=1,lm - do j=jts,jte - do i=its,its+1 - dwdt(i,j,l)=1. - enddo - enddo - enddo - endif -! - if(e_bdy)then - do l=1,lm - do j=jts,jte - do i=ite-1,ite - dwdt(i,j,l)=1. - enddo - enddo - enddo - endif -!----------------------------------------------------------------------- - endif ! regional -!----------------------------------------------------------------------- -! - endsubroutine vsound -! -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - subroutine adv2 & -(global & -,idtadt,kss,kse,lm,lnsad & -,dt,rdyh & -,dsg2,pdsg1 & -,epsq2 & -,fah,rdxh & -,pd,pdo & -,psgdt & -,up,vp & -,indx_q2 & -,s,sp & -!---temporary arguments------------------------------------------------- -,pfne,pfnw,pfx,pfy,s1,tcs) -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -implicit none - -!----------------------------------------------------------------------- -real(kind=kfpt),parameter:: & - cfc=1.533 & ! adams-bashforth positioning in time -,bfc=1.-cfc & ! adams bashforth positioning in time -,epsq=1.e-20 & ! floor value for specific humidity -,pfc=1.+4./6. & ! 4th order momentum advection -,sfc=-1./6. & ! 4th order momentum advection -,epscm=2.e-6 & ! a floor value (not used) -,w1=0.9 & ! crank-nicholson uncentering -!,w1=1.0 & ! crank-nicholson uncentering -!,w1=0.80 & ! crank-nicholson uncentering -,w2=2.-w1 ! crank-nicholson uncentering - -logical(kind=klog),intent(in):: & - global - -integer(kind=kint),intent(in):: & - idtadt & ! -,kse & ! terminal species index -,kss & ! initial species index -,lm & ! total # of levels -,lnsad & ! -,indx_q2 ! location of q2 in tracer arrays - -real(kind=kfpt),intent(in):: & - dt & ! dynamics time step -,rdyh ! - -real(kind=kfpt),dimension(1:lm),intent(in):: & - dsg2 & ! delta sigmas -,pdsg1 & ! delta pressures -,epsq2 ! floor value of 2tke - -real(kind=kfpt),dimension(jds:jde),intent(in):: & - fah & ! grid factor -,rdxh ! - -real(kind=kfpt),dimension(ims:ime,jms:jme),intent(in):: & - pd & ! sigma range pressure difference -,pdo ! sigma range pressure difference - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm-1),intent(in):: & - psgdt ! vertical mass flux - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(in):: & - up & ! -,vp ! - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm,1:kse),intent(inout):: & - s & ! tracers -,sp ! s at previous time level - -!---temporary arguments------------------------------------------------- -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm):: & - pfne & ! mass flux, ne direction -,pfnw & ! mass flux, nw direction -,pfx & ! mass flux, x direction -,pfy ! mass flux, y direction - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm,1:kse),intent(inout):: & - s1 & ! intermediate value of sqrt(s) -,tcs ! timechange of s - -!--local variables------------------------------------------------------ -real(kind=kfpt),parameter:: & - wb=1.0 & ! weighting factor -,wa=(1.0-wb)*0.25 ! weighting factor - -integer(kind=kint):: & - i & ! -,iap & ! -,ibeg & ! -,iend & ! -,j & ! -,jap & ! -,jbeg & ! -,jend & ! -,ks & ! -,l ! - -real(kind=kfpt):: & - cf & ! temporary -,cms & ! temporary -,dtq & ! dt/4 -,emhp & ! -,enhp & ! -,fahp & ! temporary grid factor -,pp & ! -,qq & ! -,rdp & ! 1/deltap -,vvlo & ! vertical velocity, lower interface -,vvup & ! vertical velocity, upper interface -,pvvup ! vertical mass flux, upper interface - -real(kind=kfpt),dimension(ims:ime,jms:jme):: & - pdop & ! hydrostatic pressure difference at v points -,pdops & ! smoothed hydrostatic pressure difference at h points -,pvvlo & ! vertical mass flux, lower interface -,ss1 & ! extrapolated species between time levels -,ssne & ! flux, ne direction -,ssnw & ! flux, nw direction -,ssx & ! flux, x direction -,ssy ! flux, y direction - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm):: & - crs & ! vertical advection temporary -,rcms ! vertical advection temporary - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm,1:kse):: & - rsts ! vertical advection temporary -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------- -#ifdef ENABLE_SMP -!----------------- -!....................................................................... -!$omp parallel private(i,j,jstart,jstop,ks,l,nth,tid) -!....................................................................... - nth = omp_get_num_threads() - tid = omp_get_thread_num() - call looplimits(tid, nth, jts_h1, jte_h1, jstart, jstop) -!----------------- -#else -!----------------- - jstart = jts_h1 - jstop = jte_h1 -!----------------- -#endif -!----------------- - do ks=kss,kse - do l=1,lm - do j=jstart,jstop - do i=its_h1,ite_h1 - s(i,j,l,ks)=max(s(i,j,l,ks),epsq) - enddo - enddo - enddo - enddo -! -!*** Interpolate q2 (2*TKE) from interfaces to midlayers -! -q2_check: if (kss<=indx_q2 .and. indx_q2<=kse) then - do l=lm,2,-1 - do j=jstart,jstop - do i=its_h1,ite_h1 - s(i,j,L,indx_q2)=max((s(i,j,L,indx_q2)+s(i,j,L-1,indx_q2))*0.5 & - ,(epsq2(L)+epsq2(L-1))*0.5) - enddo - enddo - enddo - do j=jstart,jstop - do i=its_h1,ite_h1 - s(i,j,1,indx_q2)=max((s(i,j,1,indx_q2)+epsq2(1))*0.5,epsq2(1)) - enddo - enddo - endif q2_check -!----------------------------------------------------------------------- - do ks=kss,kse ! loop by species -!----------------------------------------------------------------------- - do l=1,lm - do j=jstart,jstop - do i=its_h1,ite_h1 - s1(i,j,l,ks)=sqrt(s(i,j,l,ks)) - enddo - enddo - enddo -!----------------------------------------------------------------------- -! - enddo ! end of the loop by species -! -!----------------- -#ifdef ENABLE_SMP -!----------------- -!....................................................................... -!$omp end parallel -!....................................................................... -!----------------- -#endif -!----------------- -!----------------------------------------------------------------------- - do j=jts_h1,jte_h1 - do i=its_h1,ite_h1 - pdop(i,j)=(pd(i,j)+pdo(i,j))*0.5 - enddo - enddo -!----------------- -#ifdef ENABLE_SMP -!----------------- -!....................................................................... -!$omp parallel private(cf,cms,dtq,i,j,jstart,jstop,l,nth,pvvup,rdp, & -!$omp tid,vvlo,vvup) -!....................................................................... - nth = omp_get_num_threads() - tid = omp_get_thread_num() - call looplimits(tid, nth, jts_b1, jte_b1, jstart, jstop) -!----------------- -#else -!----------------- - jstart = jts_b1 - jstop = jte_b1 -!----------------- -#endif -!----------------- -!----------------------------------------------------------------------- -!---crank-nicholson vertical advection---------------------------------- -!----------------------------------------------------------------------- - dtq=dt*0.25*idtadt - do j=jstart,jstop - do i=its_b1,ite_b1 - pdops(i,j)=(pdop(i,j-1)+pdop(i-1,j) & - +pdop(i+1,j)+pdop(i,j+1))*wa & - +pdop(i,j)*wb - enddo - enddo - do j=jstart,jstop - do i=its_b1,ite_b1 - pvvlo(i,j)=((psgdt(i,j-1,1)+psgdt(i-1,j,1) & - +psgdt(i+1,j,1)+psgdt(i,j+1,1))*wa + & - psgdt(i,j,1)*wb)*dtq - vvlo=pvvlo(i,j)/(dsg2(1)*pdops(i,j)+pdsg1(1)) - cms=-vvlo*w2+1. - rcms(i,j,1)=1./cms - crs(i,j,1)=vvlo*w2 -! - do ks=kss,kse - rsts(i,j,1,ks)=(-vvlo*w1) & - *(s1(i,j,2,ks)-s1(i,j,1,ks)) & - +s1(i,j,1,ks) - enddo - enddo - enddo - do l=2,lm-1 - do j=jstart,jstop - do i=its_b1,ite_b1 - rdp=1./(dsg2(l)*pdops(i,j)+pdsg1(l)) - pvvup=pvvlo(i,j) - pvvlo(i,j)=((psgdt(i,j-1,l)+psgdt(i-1,j,l) & - +psgdt(i+1,j,l)+psgdt(i,j+1,l))*wa + & - psgdt(i,j,l)*wb)*dtq -! - vvup=pvvup*rdp - vvlo=pvvlo(i,j)*rdp -! - cf=-vvup*w2*rcms(i,j,l-1) - cms=-crs(i,j,l-1)*cf+((vvup-vvlo)*w2+1.) - rcms(i,j,l)=1./cms - crs(i,j,l)=vvlo*w2 -! - do ks=kss,kse - rsts(i,j,l,ks)=-rsts(i,j,l-1,ks)*cf+s1(i,j,l,ks) & - -(s1(i,j,l ,ks)-s1(i,j,l-1,ks))*vvup*w1 & - -(s1(i,j,l+1,ks)-s1(i,j,l ,ks))*vvlo*w1 - enddo - enddo - enddo - enddo - do j=jstart,jstop - do i=its_b1,ite_b1 - pvvup=pvvlo(i,j) - vvup=pvvup/(dsg2(lm)*pdops(i,j)+pdsg1(lm)) -! - cf=-vvup*w2*rcms(i,j,lm-1) - cms=-crs(i,j,lm-1)*cf+(vvup*w2+1.) - rcms(i,j,lm)=1./cms - crs(i,j,lm)=0. -! - do ks=kss,kse - rsts(i,j,lm,ks)=-rsts(i,j,lm-1,ks)*cf+s1(i,j,lm,ks) & - -(s1(i,j,lm,ks)-s1(i,j,lm-1,ks))*vvup*w1 -! - tcs(i,j,lm,ks)=rsts(i,j,lm,ks)*rcms(i,j,lm)-s1(i,j,lm,ks) - enddo - enddo - enddo - do ks=kss,kse - do l=lm-1,1,-1 - do j=jstart,jstop - do i=its_b1,ite_b1 - tcs(i,j,l,ks)=(-crs(i,j,l)*(s1(i,j,l+1,ks)+tcs(i,j,l+1,ks)) & - +rsts(i,j,l,ks)) & - *rcms(i,j,l)-s1(i,j,l,ks) - enddo - enddo - enddo - enddo -!----------------- -#ifdef ENABLE_SMP -!----------------- -!....................................................................... -!$omp end parallel -!....................................................................... -!----------------- -#endif -!----------------- -!----------------------------------------------------------------------- -!....................................................................... -!$omp parallel do & -!$omp private(fahp,i,ibeg,iend,j,jbeg,jend,ks,l,ss1,ssne,ssnw,ssx,ssy) -!....................................................................... -!----------------------------------------------------------------------- -! - do ks=kss,kse ! loop by species -! -!----------------------------------------------------------------------- - do l=1,lm - do j=jts_h1,jte_h1 - do i=its_h1,ite_h1 - ss1(i,j)=s1(i,j,l,ks)*cfc+sp(i,j,l,ks)*bfc - sp(i,j,l,ks)=s1(i,j,l,ks) - enddo - enddo -!---temperature fluxes, on h points------------------------------------- - do j=jts_b1,jte_h1 - do i=its_b1,ite_h1 - ssx(i,j)=(ss1(i,j)-ss1(i-1,j))*pfx(i,j,l) - ssy(i,j)=(ss1(i,j)-ss1(i,j-1))*pfy(i,j,l) -! - ssne(i,j)=(ss1(i,j)-ss1(i-1,j-1))*pfne(i,j,l) - ssnw(i,j)=(ss1(i-1,j)-ss1(i,j-1))*pfnw(i,j,l) - enddo - enddo -!---advection of species------------------------------------------------ - if(adv_standard)then - ibeg=max(its,ids+1+lnsad) - iend=min(ite,ide-1-lnsad) - jbeg=max(jts,jds+1+lnsad) - jend=min(jte,jde-1-lnsad) -! - do j=jbeg,jend - fahp=fah(j)*idtadt - do i=ibeg,iend - tcs(i,j,l,ks)=(((ssx (i ,j )+ssx (i+1,j ) & - +ssy (i ,j )+ssy (i ,j+1)) & - +(ssne(i+1,j+1)+ssne(i ,j ) & - +ssnw(i ,j+1)+ssnw(i+1,j ))*0.25) & - *fahp) & - /(dsg2(l)*pdop(i,j)+pdsg1(l)) & - +tcs(i,j,l,ks) - enddo - enddo - endif - enddo -!----------------------------------------------------------------------- -! - enddo ! end of the loop by the species -!....................................................................... -!$omp end parallel do -!....................................................................... -! -!----------------------------------------------------------------------- -!---regional branch----------------------------------------------------- -!----------------------------------------------------------------------- - if(.not.global.and.adv_upstream) then -!----------------------------------------------------------------------- - enhp=-dt*rdyh*0.25*idtadt -!----------------------------------------------------------------------- - do l=1,lm -!----------------------------------------------------------------------- -! -!*** Upstream advection along southern rows -! - do j=jts_b1,min(jte,jds+lnsad) - emhp=-dt*rdxh(j)*0.25*idtadt - do i=its_b1,ite_b1 - pp=(up(i-1,j-1,l)+up(i ,j-1,l) & - +up(i-1,j ,l)+up(i ,j ,l))*emhp - qq=(vp(i-1,j-1,l)+vp(i ,j-1,l) & - +vp(i-1,j ,l)+vp(i ,j ,l))*enhp -! - if(pp.le.0.) then - iap=-1 - pp=-pp - else - iap=1 - endif -! - if(qq.le.0.) then - jap=-1 - qq=-qq - else - jap=1 - endif -! - do ks=kss,kse - tcs(i,j,l,ks)=(s1(i+iap,j,l,ks)-s1(i,j,l,ks))*pp & - +(s1(i,j+jap,l,ks)-s1(i,j,l,ks))*qq & - +(s1(i,j,l,ks)-s1(i+iap,j,l,ks) & - -s1(i,j+jap,l,ks)+s1(i+iap,j+jap,l,ks)) & - *pp*qq & - +tcs(i,j,l,ks) - enddo - enddo - enddo -! -!*** Upstream advection along northern rows -! - do j=max(jts,jde-lnsad),jte_b1 - emhp=-dt*rdxh(j)*0.25*idtadt - do i=its_b1,ite_b1 - pp=(up(i-1,j-1,l)+up(i ,j-1,l) & - +up(i-1,j ,l)+up(i ,j ,l))*emhp - qq=(vp(i-1,j-1,l)+vp(i ,j-1,l) & - +vp(i-1,j ,l)+vp(i ,j ,l))*enhp -! - if(pp.le.0.) then - iap=-1 - pp=-pp - else - iap=1 - endif -! - if(qq.le.0.) then - jap=-1 - qq=-qq - else - jap=1 - endif -! - do ks=kss,kse - tcs(i,j,l,ks)=(s1(i+iap,j,l,ks)-s1(i,j,l,ks))*pp & - +(s1(i,j+jap,l,ks)-s1(i,j,l,ks))*qq & - +(s1(i,j,l,ks)-s1(i+iap,j,l,ks) & - -s1(i,j+jap,l,ks)+s1(i+iap,j+jap,l,ks)) & - *pp*qq & - +tcs(i,j,l,ks) - enddo - enddo - enddo -! -!*** Upstream advection along western rows -! - do j=max(jts,jds+1+lnsad),min(jte,jde-1-lnsad) - emhp=-dt*rdxh(j)*0.25*idtadt - do i=its_b1,min(ite,ids+lnsad) - pp=(up(i-1,j-1,l)+up(i ,j-1,l) & - +up(i-1,j ,l)+up(i ,j ,l))*emhp - qq=(vp(i-1,j-1,l)+vp(i ,j-1,l) & - +vp(i-1,j ,l)+vp(i ,j ,l))*enhp -! - if(pp.le.0.) then - iap=-1 - pp=-pp - else - iap=1 - endif -! - if(qq.le.0.) then - jap=-1 - qq=-qq - else - jap=1 - endif -! - do ks=kss,kse - tcs(i,j,l,ks)=(s1(i+iap,j,l,ks)-s1(i,j,l,ks))*pp & - +(s1(i,j+jap,l,ks)-s1(i,j,l,ks))*qq & - +(s1(i,j,l,ks)-s1(i+iap,j,l,ks) & - -s1(i,j+jap,l,ks)+s1(i+iap,j+jap,l,ks)) & - *pp*qq & - +tcs(i,j,l,ks) - enddo - enddo - enddo -! -!*** Upstream advection along eastern rows -! - do j=max(jts,jds+1+lnsad),min(jte,jde-1-lnsad) - emhp=-dt*rdxh(j)*0.25*idtadt - do i=max(its,ide-lnsad),ite_b1 - pp=(up(i-1,j-1,l)+up(i ,j-1,l) & - +up(i-1,j ,l)+up(i ,j ,l))*emhp - qq=(vp(i-1,j-1,l)+vp(i ,j-1,l) & - +vp(i-1,j ,l)+vp(i ,j ,l))*enhp -! - if(pp.le.0.) then - iap=-1 - pp=-pp - else - iap=1 - endif -! - if(qq.le.0.) then - jap=-1 - qq=-qq - else - jap=1 - endif -! - do ks=kss,kse - tcs(i,j,l,ks)=(s1(i+iap,j,l,ks)-s1(i,j,l,ks))*pp & - +(s1(i,j+jap,l,ks)-s1(i,j,l,ks))*qq & - +(s1(i,j,l,ks)-s1(i+iap,j,l,ks) & - -s1(i,j+jap,l,ks)+s1(i+iap,j+jap,l,ks)) & - *pp*qq & - +tcs(i,j,l,ks) - enddo - enddo - enddo -!----------------------------------------------------------------------- - enddo -!----------------------------------------------------------------------- - endif ! regional lateral boundaries -!----------------------------------------------------------------------- -! - endsubroutine adv2 -! -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- - subroutine mono & -(idtadt,kss,kse,lm & -,dsg2,pdsg1 & -,epsq2 & -,dare & -,pd & -,indx_q2 & -,s & -,inpes,jnpes & -,use_allreduce & -!---temporary arguments------------------------------------------------- -,s1,tcs) -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -implicit none - -!----------------------------------------------------------------------- -real(kind=kfpt),parameter:: & - epsq=1.e-20 ! floor value for specific humidity - -integer(kind=kint),intent(in):: & - idtadt & ! -,inpes & ! number of tasks in x direction -,jnpes & ! number of tasks in y direction -,kse & ! terminal species index -,kss & ! initial species index -,lm & ! total # of levels -,indx_q2 ! location of q2 in 4-d tracer arrays - -real(kind=kfpt),dimension(1:lm),intent(in):: & - dsg2 & ! delta sigmas -,pdsg1 & ! delta pressures -,epsq2 ! floor value of 2tke - -real(kind=kfpt),dimension(jds:jde),intent(in):: & - dare ! grid box area - -real(kind=kfpt),dimension(ims:ime,jms:jme),intent(in):: & - pd ! sigma range pressure difference - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm,1:kse),intent(inout):: & - s ! s at previous time level - -logical(kind=klog) :: & - use_allreduce - -!---temporary arguments------------------------------------------------- -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm,1:kse),intent(inout):: & - s1 & ! intermediate value of s -,tcs ! timechange of s -!--local variables------------------------------------------------------ -integer(kind=kint):: & - i & ! -,ierr & ! -,irecv & ! -,j & ! -,ks & ! -,l & ! -,lngth & ! -,loc_its_b1 & ! -,loc_ite_b1 & ! -,loc_jts_b1 & ! -,loc_jte_b1 & ! -,loc_len & ! -,loc_lngth & ! -,n & ! -,nn & ! -,pe ! - -integer,dimension(mpi_status_size) :: jstat - -real(kind=kfpt):: & - s1p & ! -,smax & ! local maximum -,smin & ! local minimum -,smaxh & ! horizontal local maximum -,sminh & ! horizontal local minimum -,smaxv & ! vertical local maximum -,sminv & ! vertical local minimum -,sn & ! -,steep ! - -real(kind=kdbl):: & - dsp & ! -,rfacs & ! -,sfacs & ! -,sumns & ! -,sumps ! - -real(kind=kdbl),dimension(ide*jde*kse):: & - s1_glob ! - -real(kind=kfpt),dimension((ite_b1-its_b1+1)*(jte_b1-jts_b1+1)*kse):: & - s1_loc ! - -real(kind=kfpt),dimension(:), allocatable :: & - s1_pe_loc ! - -real(kind=kdbl),dimension(1:2*kse):: & - gsums & ! sum of neg/pos changes all global fields -,xsums ! sum of neg/pos changes all global fields - -real(kind=kfpt),dimension(its_b1:ite_b1,jts_b1:jte_b1,1:kse):: & - s1l_sum - -real(kind=kfpt),dimension(its_b1:ite_b1,jts_b1:jte_b1,1:lm):: & - dvol & ! grid box volume -,rdvol ! 1./grid box volume -!----------------------------------------------------------------------- -integer(kind=kint) :: & - istat - -logical(kind=klog) :: & - opened - -logical(kind=klog),save :: & - sum_file_is_open=.false. - -character(10) :: & - fstatus -!----------------------------------------------------------------------- -real(kind=kdbl),save :: sumdo3=0. -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - steep=1.-0.040*idtadt -!....................................................................... -!$omp parallel -!$omp do private(i,j,l) -!....................................................................... - do l=1,lm - do j=jts_b1,jte_b1 - do i=its_b1,ite_b1 - dvol (i,j,l)=(dsg2(l)*pd(i,j)+pdsg1(l))*dare(j) - rdvol(i,j,l)=1./dvol(i,j,l) - enddo - enddo - enddo -!....................................................................... -!$omp end do -!$omp end parallel -!....................................................................... -! -!----------------------------------------------------------------------- -!---monotonization------------------------------------------------------ -!----------------------------------------------------------------------- -! - if(use_allreduce)then -! -!----------------------------------------------------------------------- -!....................................................................... -!$omp parallel -!$omp do private (dsp,i,j,ks,l,s1p,smax,smaxh,smaxv,smin,sminh,sminv,sn) -!....................................................................... -!----------------------------------------------------------------------- - do ks=kss,kse ! loop by species - gsums(2*ks-1)=0. - gsums(2*ks )=0. - xsums(2*ks-1)=0. - xsums(2*ks )=0. -! - do j=jts_b1,jte_b1 - do i=its_b1,ite_b1 - s1l_sum(i,j,ks)=0. - enddo - enddo -!----------------------------------------------------------------------- - do l=1,lm - do j=jts_b1,jte_b1 - do i=its_b1,ite_b1 - s1p=(s1(i,j,l,ks)+tcs(i,j,l,ks))**2 - tcs(i,j,l,ks)=s1p-s(i,j,l,ks) -! - sminh=min(s(i-1,j-1,l,ks) & - ,s(i ,j-1,l,ks) & - ,s(i+1,j-1,l,ks) & - ,s(i-1,j ,l,ks) & - ,s(i ,j ,l,ks) & - ,s(i+1,j ,l,ks) & - ,s(i-1,j+1,l,ks) & - ,s(i ,j+1,l,ks) & - ,s(i+1,j+1,l,ks)) - smaxh=max(s(i-1,j-1,l,ks) & - ,s(i ,j-1,l,ks) & - ,s(i+1,j-1,l,ks) & - ,s(i-1,j ,l,ks) & - ,s(i ,j ,l,ks) & - ,s(i+1,j ,l,ks) & - ,s(i-1,j+1,l,ks) & - ,s(i ,j+1,l,ks) & - ,s(i+1,j+1,l,ks)) -! - if(l.gt.1.and.l.lt.lm) then - sminv=min(s(i,j,l-1,ks),s(i,j,l ,ks),s(i,j,l+1,ks)) - smaxv=max(s(i,j,l-1,ks),s(i,j,l ,ks),s(i,j,l+1,ks)) - elseif(l.eq.1) then - sminv=min(s(i,j,l ,ks),s(i,j,l+1,ks)) - smaxv=max(s(i,j,l ,ks),s(i,j,l+1,ks)) - elseif(l.eq.lm) then - sminv=min(s(i,j,l-1,ks),s(i,j,l ,ks)) - smaxv=max(s(i,j,l-1,ks),s(i,j,l ,ks)) - endif -! - smin=min(sminh,sminv) - smax=max(smaxh,smaxv) -! - sn=s1p - if(sn.gt.steep*smax) sn=smax - if(sn.lt. smin) sn=smin -! - dsp=(sn-s1p)*dvol(i,j,l) -! - if(dsp.gt.0.) then - xsums(2*ks-1)=xsums(2*ks-1)+dsp - else - xsums(2*ks )=xsums(2*ks )+dsp - endif -! - enddo - enddo - enddo - enddo ! end of the loop by species -!....................................................................... -!$omp end do -!$omp end parallel -!....................................................................... -!----------------------------------------------------------------------- -! - else ! use send/recv -! -!----------------------------------------------------------------------- -!....................................................................... -!$omp parallel -!$omp do private (dsp,i,j,ks,l,s1p,smax,smaxh,smaxv,smin,sminh,sminv,sn) -!....................................................................... -!----------------------------------------------------------------------- - do ks=kss,kse ! loop by species - gsums(2*ks-1)=0. - gsums(2*ks )=0. -! - do j=jts_b1,jte_b1 - do i=its_b1,ite_b1 - s1l_sum(i,j,ks)=0. - enddo - enddo -!----------------------------------------------------------------------- - do l=1,lm - do j=jts_b1,jte_b1 - do i=its_b1,ite_b1 - s1p=(s1(i,j,l,ks)+tcs(i,j,l,ks))**2 - tcs(i,j,l,ks)=s1p-s(i,j,l,ks) -! - sminh=min(s(i-1,j-1,l,ks) & - ,s(i ,j-1,l,ks) & - ,s(i+1,j-1,l,ks) & - ,s(i-1,j ,l,ks) & - ,s(i ,j ,l,ks) & - ,s(i+1,j ,l,ks) & - ,s(i-1,j+1,l,ks) & - ,s(i ,j+1,l,ks) & - ,s(i+1,j+1,l,ks)) - smaxh=max(s(i-1,j-1,l,ks) & - ,s(i ,j-1,l,ks) & - ,s(i+1,j-1,l,ks) & - ,s(i-1,j ,l,ks) & - ,s(i ,j ,l,ks) & - ,s(i+1,j ,l,ks) & - ,s(i-1,j+1,l,ks) & - ,s(i ,j+1,l,ks) & - ,s(i+1,j+1,l,ks)) -! - if(l.gt.1.and.l.lt.lm) then - sminv=min(s(i,j,l-1,ks),s(i,j,l ,ks),s(i,j,l+1,ks)) - smaxv=max(s(i,j,l-1,ks),s(i,j,l ,ks),s(i,j,l+1,ks)) - elseif(l.eq.1) then - sminv=min(s(i,j,l ,ks),s(i,j,l+1,ks)) - smaxv=max(s(i,j,l ,ks),s(i,j,l+1,ks)) - elseif(l.eq.lm) then - sminv=min(s(i,j,l-1,ks),s(i,j,l ,ks)) - smaxv=max(s(i,j,l-1,ks),s(i,j,l ,ks)) - endif -! - smin=min(sminh,sminv) - smax=max(smaxh,smaxv) -! - sn=s1p - if(sn.gt.steep*smax) sn=smax - if(sn.lt. smin) sn=smin -! - dsp=(sn-s1p)*dvol(i,j,l) -! - s1(i,j,l,ks)=dsp - s1l_sum(i,j,ks) = s1l_sum(i,j,ks) + dsp -! - enddo - enddo - enddo - enddo ! end of the loop by species -!....................................................................... -!$omp end do -!$omp end parallel -!....................................................................... -!----------------------------------------------------------------------- -! - endif -! -!----------------------------------------------------------------------- -!*** Global reductions -!----------------------------------------------------------------------- -! - global_reduce: if(use_allreduce)then -! -!----------------------------------------------------------------------- -!*** Skip computing the global reduction if they are to be read in -!*** from another run to check bit reproducibility. -!----------------------------------------------------------------------- - lngth=2*kse - call mpi_allreduce(xsums,gsums,lngth & - ,mpi_double_precision & - ,mpi_sum,mpi_comm_comp,irecv) -!----------------------------------------------------------------------- -! - else global_reduce -! -!----------------------------------------------------------------------- - if (mype==0) then - - do ks=kss,kse - do j=jts_b1,jte_b1 - do i=its_b1,ite_b1 - n=i+(j-1)*ide+(ks-1)*ide*jde - s1_glob(n) = s1l_sum(i,j,ks) - enddo - enddo - enddo - - do pe=1,inpes*jnpes-1 - loc_its_b1 = max(local_istart(pe),ids+1) - loc_ite_b1 = min(local_iend (pe),ide-1) - loc_jts_b1 = max(local_jstart(pe),jds+1) - loc_jte_b1 = min(local_jend (pe),jde-1) - loc_len = (loc_ite_b1-loc_its_b1+1)* & - (loc_jte_b1-loc_jts_b1+1)*kse - allocate(s1_pe_loc(1:loc_len)) - call mpi_recv(s1_pe_loc(1:loc_len),loc_len & - ,mpi_real,pe,pe,mpi_comm_comp,jstat,ierr) - nn=0 - do ks=kss,kse - do j=loc_jts_b1,loc_jte_b1 - do i=loc_its_b1,loc_ite_b1 - nn=nn+1 - n=i+(j-1)*ide+(ks-1)*ide*jde - s1_glob(n) = s1_pe_loc(nn) - enddo - enddo - enddo - deallocate(s1_pe_loc) - end do - - do ks=kss,kse - do j=jds+1,jde-1 - do i=ids+1,ide-1 - n=i+(j-1)*ide+(ks-1)*ide*jde - if(s1_glob(n).gt.0.0d0) then - gsums(2*ks-1) = gsums(2*ks-1) + s1_glob(n) - else - gsums(2*ks ) = gsums(2*ks ) + s1_glob(n) - endif - enddo - enddo - enddo - - else - loc_lngth=(ite_b1-its_b1+1)*(jte_b1-jts_b1+1)*kse - - n=0 - do ks=kss,kse - do j=jts_b1,jte_b1 - do i=its_b1,ite_b1 - n=n+1 - s1_loc(n) = s1l_sum(i,j,ks) - enddo - enddo - enddo - - call mpi_send(s1_loc(1:loc_lngth),loc_lngth & - ,mpi_real, 0, mype, mpi_comm_comp, ierr) - - endif - - call mpi_bcast(gsums,kse*2 & - ,mpi_double_precision,0,mpi_comm_comp,ierr) - -!---------------------------------------------------------------------- -! - endif global_reduce -! -!---------------------------------------------------------------------- -!....................................................................... -!$omp parallel do private (dsp,i,j,ks,l,rfacs,sfacs,sumns,sumps) -!....................................................................... - do ks=kss,kse - sumps=gsums(2*ks-1) - sumns=gsums(2*ks ) -! - if(sumps*(-sumns).gt.1.) then - sfacs=-sumns/sumps - rfacs=1./sfacs - else - sfacs=0. - rfacs=0. - endif -! - do l=1,lm - do j=jts_b1,jte_b1 - do i=its_b1,ite_b1 - dsp=s1(i,j,l,ks)*rdvol(i,j,l) - if(sfacs.lt.1.) then - if(dsp.gt.0.) dsp=dsp*sfacs - else - if(dsp.lt.0.) dsp=dsp*rfacs - endif - tcs(i,j,l,ks)=tcs(i,j,l,ks)+dsp - enddo - enddo - enddo -!----------------------------------------------------------------------- -! - enddo ! end of the loop by species -!....................................................................... -!$omp end parallel do -!....................................................................... -! -!----------------------------------------------------------------------- -! -!*** Interpolate q2 tendencies and q2 itself from midlayers back to -! interfaces -! -q2_check: if (kss<=indx_q2 .and. indx_q2<=kse) then - do l=1,lm - do j=jts_b1,jte_b1 - do i=its_b1,ite_b1 - tcs(i,j,l,indx_q2)=(dsg2(l)*pd(i,j)+pdsg1(l))*tcs(i,j,l,indx_q2) - enddo - enddo - enddo - do l=1,lm-1 - do j=jts_b1,jte_b1 - do i=its_b1,ite_b1 - tcs(i,j,l,indx_q2)=(tcs(i,j,l,indx_q2)+tcs(i,j,l+1,indx_q2)) & - /((dsg2(l )*pd(i,j)+pdsg1(l )) & - +(dsg2(l+1)*pd(i,j)+pdsg1(l+1))) - s(i,j,l,indx_q2)=max(0.5*(s(i,j,l,indx_q2)+s(i,j,l+1,indx_q2)),epsq2(l)) - enddo - enddo - enddo - do j=jts_b1,jte_b1 - do i=its_b1,ite_b1 - tcs(i,j,lm,indx_q2)=0. - s(i,j,lm,indx_q2)=epsq2(lm) - enddo - enddo - endif q2_check -! -!----------------------------------------------------------------------- -! - endsubroutine mono -! -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -! -!---------------------------------------------------------------------- -!###################################################################### -!---------------------------------------------------------------------- -! - end module module_dynamics_routines -! -!----------------------------------------------------------------------- diff --git a/src/nmm/module_ERROR_MSG.F90 b/src/nmm/module_ERROR_MSG.F90 deleted file mode 100644 index a1584bf..0000000 --- a/src/nmm/module_ERROR_MSG.F90 +++ /dev/null @@ -1,31 +0,0 @@ - module module_error_msg - - USE ESMF - - implicit none - - private - public :: err_msg,message_check - - logical, parameter :: iprint = .false. - character(esmf_maxstr) :: message_check - - contains - - subroutine err_msg(rc1,msg,rc) - integer, intent(inout) :: rc1 - integer, intent(out) :: rc - character (len=*), intent(in) :: msg - if (ESMF_LogFoundError(rc1, msg=msg)) then - rc = esmf_failure - print*, 'error happened for ',msg, ' rc = ', rc1 - write(0,*)' ERROR: ',trim(msg),' rc = ', rc1 - call ESMF_Finalize(endflag=ESMF_END_ABORT) - else - rc = esmf_success - if(iprint) print*, 'pass ',msg - end if - return - end subroutine err_msg - - end module module_error_msg diff --git a/src/nmm/module_EXCHANGE.F90 b/src/nmm/module_EXCHANGE.F90 deleted file mode 100644 index 7503e50..0000000 --- a/src/nmm/module_EXCHANGE.F90 +++ /dev/null @@ -1,4574 +0,0 @@ -!----------------------------------------------------------------------- - module module_exchange -!----------------------------------------------------------------------- -! -!*** MODULE_EXCHANGE contains the halo exchange routines. There is a -!*** unique routine for every combination of 2-D and 3-D real array -!*** exchanges being done at one time. Each subroutine name begins with -!*** "exch" which is then followed by a string of integers. Each "2" -!*** in the string indicates exchange being done for a 2-D array. -!*** Similarly each "3" or "4" in the string indicates exchange being done -!*** for a 3-D or 4-D array. -!*** Currently there are routines for these combinations: -!*** -!*** 2, 22, 222, 2222, 23, 223, 3, 33, 333, 3333, 4 -! -!*** A generic interface exists so that all of the routines -!*** may be called with the name "halo_exch". If new routines -!*** are added because new combinations are needed then also -!*** add the routine's name to the interface block. -! -! -!*** Buffer arrays are used during the exchange process. Set the size -!*** below in the parameter ibufexch. If an error occurs where the -!*** MPI library indicates that the receive buffer is too small then -!*** increase the size of ibufexch. -! -!*** The 4-element IHANDLE array is used for the nonblocking requests -!*** for all the ISENDS/IRECVS and their MPI_WAITS. Here is the key -!*** to their use: -!*** -!*** IRECV/store from north --> IHANDLE(1) -!*** IRECV/store from south --> IHANDLE(2) -!*** ISEND to north --> IHANDLE(3) -!*** ISEND to south --> IHANDLE(4) -!*** -!*** IRECV/store from west --> IHANDLE(1) -!*** IRECV/store from east --> IHANDLE(2) -!*** ISEND to east --> IHANDLE(3) -!*** ISEND to west --> IHANDLE(4) -! -!----------------------------------------------------------------------- -! -use mpi -! -use module_kinds -! -use module_my_domain_specs -! -!----------------------------------------------------------------------- -! - implicit none -! -!----------------------------------------------------------------------- -! - private -! - public :: halo_exch -! -!----------------------------------------------------------------------- -! - integer(kind=kint),parameter :: ibufexch=2500000 -! - real(kind=kfpt),dimension(ibufexch) :: buf0,buf1,buf2,buf3 -! -!----------------------------------------------------------------------- -! - interface halo_exch - module procedure exch2 - module procedure exch22 - module procedure exch222 - module procedure exch2222 - module procedure exch23 - module procedure exch223 - module procedure exch3 - module procedure exch33 - module procedure exch333 - module procedure exch3333 - module procedure exch4 - end interface -! -!----------------------------------------------------------------------- -! - contains -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - subroutine exch2(arr1,ll1,ihalo,jhalo) -! -!----------------------------------------------------------------------- -! -!*** Exchange haloes for a single 2-D array. -! -!----------------------------------------------------------------------- -!*** Argument variables -!----------------------------------------------------------------------- -! - integer(kind=kint),intent(in) :: & -! - ll1 & ! vertical dimension of 2-D array (=1) -,ihalo & ! number of halo rows in i direction -,jhalo ! number of halo rows in j direction -! - real(kind=kfpt),dimension(ims:ime,jms:jme),intent(inout) :: & -! - arr1 ! array whose haloes are exchanged -! -!----------------------------------------------------------------------- -!*** Local variables -!----------------------------------------------------------------------- -! - integer(kind=kint) :: i,ibeg,ic,iend,ierr,irecv,isend,j,jbeg,jend -! - integer(kind=kint),dimension(mpi_status_size) :: istat -! - integer(kind=kint),dimension(4) :: ihandle -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! -!*** The array of neighbors called my_neb is filled in subroutine -!*** decomp in module_dm_parallel. Recall that the directional -!*** designations for my_neb are: -! -!*** north: 1 -!*** east: 2 -!*** south: 3 -!*** west: 4 -!*** northeast: 5 -!*** southeast: 6 -!*** southwest: 7 -!*** northwest: 8 -! -!*** If my_neb(n) holds the task ID of each neighbor. If there is -!*** no neighbor due to the presence of a global boundary then the -!*** value of my_neb(n) in that direction is -1. -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** -!*** North/South -!*** -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Receive from north -!----------------------------------------------------------------------- -! - if(my_neb(1)>=0)then - call mpi_irecv(buf0,ibufexch,mpi_real,my_neb(1),my_neb(1) & - ,mpi_comm_comp,ihandle(1),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Receive from south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - call mpi_irecv(buf1,ibufexch,mpi_real,my_neb(3),my_neb(3) & - ,mpi_comm_comp,ihandle(2),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Send to north -!----------------------------------------------------------------------- -! - ibeg=max(its-ihalo,ids) - iend=min(ite+ihalo,ide) -! - if(my_neb(1)>=0)then - ic=0 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr1(i,jte-j) - enddo - enddo - call mpi_issend(buf2,ic,mpi_real,my_neb(1),mype & - ,mpi_comm_comp,ihandle(3),isend) - endif -! -!----------------------------------------------------------------------- -!*** Send to south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - ic=0 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr1(i,jts+j) - enddo - enddo - call mpi_issend(buf3,ic,mpi_real,my_neb(3),mype & - ,mpi_comm_comp,ihandle(4),isend) - endif -! -!----------------------------------------------------------------------- -!*** Store results from south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - ic=0 - call mpi_wait(ihandle(2),istat,ierr) - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr1(i,jts-j-1)=buf1(ic) - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** Store from north -!----------------------------------------------------------------------- -! - if(my_neb(1)>=0)then - ic=0 - call mpi_wait(ihandle(1),istat,ierr) - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr1(i,jte+j+1)=buf0(ic) - enddo - enddo - endif -! - if(my_neb(1)>=0)then - call mpi_wait(ihandle(3),istat,ierr) - endif -! - if(my_neb(3)>=0)then - call mpi_wait(ihandle(4),istat,ierr) - endif -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** -!*** East/West -!*** -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Receive from west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - call mpi_irecv(buf0,ibufexch,mpi_real,my_neb(4),my_neb(4) & - ,mpi_comm_comp,ihandle(1),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Receive from east -!----------------------------------------------------------------------- -! - if(my_neb(2)>=0)then - call mpi_irecv(buf1,ibufexch,mpi_real,my_neb(2),my_neb(2) & - ,mpi_comm_comp,ihandle(2),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Send to east -!----------------------------------------------------------------------- -! - jbeg=max(jts-jhalo,jds) - jend=min(jte+jhalo,jde) -! - if(my_neb(2)>=0)then - ibeg=ite-ihalo+1 - iend=ite - ic=0 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr1(i,j) - enddo - enddo - call mpi_issend(buf2,ic,mpi_real,my_neb(2),mype & - ,mpi_comm_comp,ihandle(3),isend) - endif -! -!----------------------------------------------------------------------- -!*** Send to west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - ibeg=its - iend=its+ihalo-1 - ic=0 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr1(i,j) - enddo - enddo - call mpi_issend(buf3,ic,mpi_real,my_neb(4),mype & - ,mpi_comm_comp,ihandle(4),isend) - endif -! -!----------------------------------------------------------------------- -!*** Store from west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - ibeg=its-ihalo - iend=its-1 - ic=0 - call mpi_wait(ihandle(1),istat,ierr) - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr1(i,j)=buf0(ic) - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** Store from east -!----------------------------------------------------------------------- -! - if(my_neb(2)>=0)then - ibeg=ite+1 - iend=ite+ihalo - ic=0 - call mpi_wait(ihandle(2),istat,ierr) - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr1(i,j)=buf1(ic) - enddo - enddo - endif -! - if(my_neb(4)>=0)then - call mpi_wait(ihandle(4),istat,ierr) - endif -! - if(my_neb(2)>=0)then - call mpi_wait(ihandle(3),istat,ierr) - endif -! -!----------------------------------------------------------------------- -! - end subroutine exch2 -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - subroutine exch3(arr1,ll1,ihalo,jhalo) -! -!----------------------------------------------------------------------- -! -!*** Exchange haloes for a single 3-D array. -! -!----------------------------------------------------------------------- -!*** Argument variables -!----------------------------------------------------------------------- -! - integer(kind=kint),intent(in) :: & -! - ll1 & ! vertical dimension of array -,ihalo & ! number of halo rows in i direction -,jhalo ! number of halo rows in j direction -! - real(kind=kfpt),dimension(ims:ime,jms:jme,ll1),intent(inout) :: & -! - arr1 ! array whose haloes are exchanged -! -!----------------------------------------------------------------------- -!*** Local variables -!----------------------------------------------------------------------- -! - integer(kind=kint) :: i,ibeg,ic,iend,ierr,irecv,isend,j,jbeg,jend,k -! - integer(kind=kint),dimension(mpi_status_size) :: istat -! - integer(kind=kint),dimension(4) :: ihandle -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** -!*** North/South -!*** -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Receive from north -!----------------------------------------------------------------------- -! - if(my_neb(1)>=0)then - call mpi_irecv(buf0,ibufexch,mpi_real,my_neb(1),my_neb(1) & - ,mpi_comm_comp,ihandle(1),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Receive from south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - call mpi_irecv(buf1,ibufexch,mpi_real,my_neb(3),my_neb(3) & - ,mpi_comm_comp,ihandle(2),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Send to north -!----------------------------------------------------------------------- -! - ibeg=max(its-ihalo,ids) - iend=min(ite+ihalo,ide) -! - if(my_neb(1)>=0)then - ic=0 - do k=1,ll1 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr1(i,jte-j,k) - enddo - enddo - enddo - call mpi_issend(buf2,ic,mpi_real,my_neb(1),mype & - ,mpi_comm_comp,ihandle(3),isend) - endif -! -!----------------------------------------------------------------------- -!*** Send to south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - ic=0 - do k=1,ll1 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr1(i,jts+j,k) - enddo - enddo - enddo - call mpi_issend(buf3,ic,mpi_real,my_neb(3),mype & - ,mpi_comm_comp,ihandle(4),isend) - endif -! -!----------------------------------------------------------------------- -!*** Store results from south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - ic=0 - call mpi_wait(ihandle(2),istat,ierr) - do k=1,ll1 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr1(i,jts-j-1,k)=buf1(ic) - enddo - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** Store from north -!----------------------------------------------------------------------- -! - if(my_neb(1)>=0)then - ic=0 - call mpi_wait(ihandle(1),istat,ierr) - do k=1,ll1 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr1(i,jte+j+1,k)=buf0(ic) - enddo - enddo - enddo - endif -! - if(my_neb(1)>=0)then - call mpi_wait(ihandle(3),istat,ierr) - endif -! - if(my_neb(3)>=0)then - call mpi_wait(ihandle(4),istat,ierr) - endif -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** -!*** East/West -!*** -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Receive from west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - call mpi_irecv(buf0,ibufexch,mpi_real,my_neb(4),my_neb(4) & - ,mpi_comm_comp,ihandle(1),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Receive from east -!----------------------------------------------------------------------- -! - if(my_neb(2)>=0)then - call mpi_irecv(buf1,ibufexch,mpi_real,my_neb(2),my_neb(2) & - ,mpi_comm_comp,ihandle(2),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Send to east -!----------------------------------------------------------------------- -! - jbeg=max(jts-jhalo,jds) - jend=min(jte+jhalo,jde) -! - if(my_neb(2)>=0)then - ibeg=ite-ihalo+1 - iend=ite - ic=0 - do k=1,ll1 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr1(i,j,k) - enddo - enddo - enddo - call mpi_issend(buf2,ic,mpi_real,my_neb(2),mype & - ,mpi_comm_comp,ihandle(3),isend) - endif -! -!----------------------------------------------------------------------- -!*** Send to west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - ibeg=its - iend=its+ihalo-1 - ic=0 - do k=1,ll1 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr1(i,j,k) - enddo - enddo - enddo - call mpi_issend(buf3,ic,mpi_real,my_neb(4),mype & - ,mpi_comm_comp,ihandle(4),isend) - endif -! -!----------------------------------------------------------------------- -!*** Store from west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - ibeg=its-ihalo - iend=its-1 - ic=0 - call mpi_wait(ihandle(1),istat,ierr) - do k=1,ll1 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr1(i,j,k)=buf0(ic) - enddo - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** Store from east -!----------------------------------------------------------------------- -! - if(my_neb(2)>=0)then - ibeg=ite+1 - iend=ite+ihalo - ic=0 - call mpi_wait(ihandle(2),istat,ierr) - do k=1,ll1 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr1(i,j,k)=buf1(ic) - enddo - enddo - enddo - endif -! - if(my_neb(4)>=0)then - call mpi_wait(ihandle(4),istat,ierr) - endif -! - if(my_neb(2)>=0)then - call mpi_wait(ihandle(3),istat,ierr) - endif -! -!----------------------------------------------------------------------- -! - end subroutine exch3 -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - subroutine exch23(arr1,ll1,arr2,ll2,ihalo,jhalo) -! -!----------------------------------------------------------------------- -! -!*** Exchange haloes for 2-D and 3-D arrays. -! -!----------------------------------------------------------------------- -!*** Argument variables -!----------------------------------------------------------------------- -! - integer(kind=kint),intent(in) :: & -! - ll1 & ! vertical dimension of 2-D array (=1) -,ll2 & ! vertical dimension of 3-D array -,ihalo & ! number of halo rows in i direction -,jhalo ! number of halo rows in j direction -! - real(kind=kfpt),dimension(ims:ime,jms:jme),intent(inout) :: & - arr1 ! 2-D array whose haloes are exchanged -! - real(kind=kfpt),dimension(ims:ime,jms:jme,ll2),intent(inout) :: & - arr2 ! 3-D array whose haloes are exchanged -! -!----------------------------------------------------------------------- -!*** Local variables -!----------------------------------------------------------------------- -! - integer(kind=kint) :: i,ibeg,ic,iend,ierr,irecv,isend,j,jbeg,jend,k -! - integer(kind=kint),dimension(mpi_status_size) :: istat -! - integer(kind=kint),dimension(4) :: ihandle -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** -!*** North/South -!*** -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Receive from north -!----------------------------------------------------------------------- -! - if(my_neb(1)>=0)then - call mpi_irecv(buf0,ibufexch,mpi_real,my_neb(1),my_neb(1) & - ,mpi_comm_comp,ihandle(1),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Receive from south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - call mpi_irecv(buf1,ibufexch,mpi_real,my_neb(3),my_neb(3) & - ,mpi_comm_comp,ihandle(2),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Send to north -!----------------------------------------------------------------------- -! - ibeg=max(its-ihalo,ids) - iend=min(ite+ihalo,ide) -! - if(my_neb(1)>=0)then - ic=0 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr1(i,jte-j) - enddo - enddo -! - do k=1,ll2 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr2(i,jte-j,k) - enddo - enddo - enddo - call mpi_issend(buf2,ic,mpi_real,my_neb(1),mype & - ,mpi_comm_comp,ihandle(3),isend) - endif -! -!----------------------------------------------------------------------- -!*** Send to south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - ic=0 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr1(i,jts+j) - enddo - enddo -! - do k=1,ll2 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr2(i,jts+j,k) - enddo - enddo - enddo - call mpi_issend(buf3,ic,mpi_real,my_neb(3),mype & - ,mpi_comm_comp,ihandle(4),isend) - endif -! -!----------------------------------------------------------------------- -!*** Store results from south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - ic=0 - call mpi_wait(ihandle(2),istat,ierr) - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr1(i,jts-j-1)=buf1(ic) - enddo - enddo -! - do k=1,ll2 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr2(i,jts-j-1,k)=buf1(ic) - enddo - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** Store from north -!----------------------------------------------------------------------- -! - if(my_neb(1)>=0)then - ic=0 - call mpi_wait(ihandle(1),istat,ierr) - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr1(i,jte+j+1)=buf0(ic) - enddo - enddo -! - do k=1,ll2 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr2(i,jte+j+1,k)=buf0(ic) - enddo - enddo - enddo - endif -! - if(my_neb(1)>=0)then - call mpi_wait(ihandle(3),istat,ierr) - endif -! - if(my_neb(3)>=0)then - call mpi_wait(ihandle(4),istat,ierr) - endif -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** -!*** East/West -!*** -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Receive from west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - call mpi_irecv(buf0,ibufexch,mpi_real,my_neb(4),my_neb(4) & - ,mpi_comm_comp,ihandle(1),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Receive from east -!----------------------------------------------------------------------- -! - if(my_neb(2)>=0)then - call mpi_irecv(buf1,ibufexch,mpi_real,my_neb(2),my_neb(2) & - ,mpi_comm_comp,ihandle(2),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Send to east -!----------------------------------------------------------------------- -! - jbeg=max(jts-jhalo,jds) - jend=min(jte+jhalo,jde) -! - if(my_neb(2)>=0)then - ibeg=ite-ihalo+1 - iend=ite - ic=0 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr1(i,j) - enddo - enddo -! - do k=1,ll2 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr2(i,j,k) - enddo - enddo - enddo - call mpi_issend(buf2,ic,mpi_real,my_neb(2),mype & - ,mpi_comm_comp,ihandle(3),isend) - endif -! -!----------------------------------------------------------------------- -!*** Send to west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - ibeg=its - iend=its+ihalo-1 - ic=0 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr1(i,j) - enddo - enddo -! - do k=1,ll2 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr2(i,j,k) - enddo - enddo - enddo - call mpi_issend(buf3,ic,mpi_real,my_neb(4),mype & - ,mpi_comm_comp,ihandle(4),isend) - endif -! -!----------------------------------------------------------------------- -!*** Store from west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - ibeg=its-ihalo - iend=its-1 - ic=0 - call mpi_wait(ihandle(1),istat,ierr) - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr1(i,j)=buf0(ic) - enddo - enddo -! - do k=1,ll2 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr2(i,j,k)=buf0(ic) - enddo - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** Store from east -!----------------------------------------------------------------------- -! - if(my_neb(2)>=0)then - ibeg=ite+1 - iend=ite+ihalo - ic=0 - call mpi_wait(ihandle(2),istat,ierr) - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr1(i,j)=buf1(ic) - enddo - enddo -! - do k=1,ll2 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr2(i,j,k)=buf1(ic) - enddo - enddo - enddo - endif -! - if(my_neb(4)>=0)then - call mpi_wait(ihandle(4),istat,ierr) - endif -! - if(my_neb(2)>=0)then - call mpi_wait(ihandle(3),istat,ierr) - endif -! -!----------------------------------------------------------------------- -! - end subroutine exch23 -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - subroutine exch222(arr1,ll1,arr2,ll2,arr3,ll3,ihalo,jhalo) -! -!----------------------------------------------------------------------- -! -!*** Exchange haloes for three 2-D arrays. -! -!----------------------------------------------------------------------- -!*** Argument variables -!----------------------------------------------------------------------- -! - integer(kind=kint),intent(in) :: & -! - ll1 & ! vertical dimension of 1st 2-D array (=1) -,ll2 & ! vertical dimension of 2nd 2-D array (=1) -,ll3 & ! vertical dimension of 3rd 2-D array (=1) -,ihalo & ! number of halo rows in i direction -,jhalo ! number of halo rows in j direction -! - real(kind=kfpt),dimension(ims:ime,jms:jme),intent(inout) :: & - arr1 & ! 2-D array whose haloes are exchanged -,arr2 & ! 2-D array whose haloes are exchanged -,arr3 ! 2-D array whose haloes are exchanged -! -!----------------------------------------------------------------------- -!*** Local variables -!----------------------------------------------------------------------- -! - integer(kind=kint) :: i,ibeg,ic,iend,ierr,irecv,isend,j,jbeg,jend -! - integer(kind=kint),dimension(mpi_status_size) :: istat -! - integer(kind=kint),dimension(4) :: ihandle -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** -!*** North/South -!*** -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Receive from north -!----------------------------------------------------------------------- -! - if(my_neb(1)>=0)then - call mpi_irecv(buf0,ibufexch,mpi_real,my_neb(1),my_neb(1) & - ,mpi_comm_comp,ihandle(1),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Receive from south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - call mpi_irecv(buf1,ibufexch,mpi_real,my_neb(3),my_neb(3) & - ,mpi_comm_comp,ihandle(2),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Send to north -!----------------------------------------------------------------------- -! - ibeg=max(its-ihalo,ids) - iend=min(ite+ihalo,ide) -! - if(my_neb(1)>=0)then - ic=0 -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr1(i,jte-j) - enddo - enddo -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr2(i,jte-j) - enddo - enddo -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr3(i,jte-j) - enddo - enddo -! - call mpi_issend(buf2,ic,mpi_real,my_neb(1),mype & - ,mpi_comm_comp,ihandle(3),isend) - endif -! -!----------------------------------------------------------------------- -!*** Send to south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - ic=0 -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr1(i,jts+j) - enddo - enddo -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr2(i,jts+j) - enddo - enddo -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr3(i,jts+j) - enddo - enddo -! - call mpi_issend(buf3,ic,mpi_real,my_neb(3),mype & - ,mpi_comm_comp,ihandle(4),isend) - endif -! -!----------------------------------------------------------------------- -!*** Store results from south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - ic=0 - call mpi_wait(ihandle(2),istat,ierr) -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr1(i,jts-j-1)=buf1(ic) - enddo - enddo -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr2(i,jts-j-1)=buf1(ic) - enddo - enddo -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr3(i,jts-j-1)=buf1(ic) - enddo - enddo -! - endif -! -!----------------------------------------------------------------------- -!*** Store from north -!----------------------------------------------------------------------- -! - if(my_neb(1)>=0)then - ic=0 - call mpi_wait(ihandle(1),istat,ierr) -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr1(i,jte+j+1)=buf0(ic) - enddo - enddo -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr2(i,jte+j+1)=buf0(ic) - enddo - enddo -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr3(i,jte+j+1)=buf0(ic) - enddo - enddo -! - endif -! - if(my_neb(1)>=0)then - call mpi_wait(ihandle(3),istat,ierr) - endif -! - if(my_neb(3)>=0)then - call mpi_wait(ihandle(4),istat,ierr) - endif -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** -!*** East/West -!*** -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Receive from west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - call mpi_irecv(buf0,ibufexch,mpi_real,my_neb(4),my_neb(4) & - ,mpi_comm_comp,ihandle(1),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Receive from east -!----------------------------------------------------------------------- -! - if(my_neb(2)>=0)then - call mpi_irecv(buf1,ibufexch,mpi_real,my_neb(2),my_neb(2) & - ,mpi_comm_comp,ihandle(2),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Send to east -!----------------------------------------------------------------------- -! - jbeg=max(jts-jhalo,jds) - jend=min(jte+jhalo,jde) -! - if(my_neb(2)>=0)then - ibeg=ite-ihalo+1 - iend=ite - ic=0 -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr1(i,j) - enddo - enddo -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr2(i,j) - enddo - enddo -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr3(i,j) - enddo - enddo -! - call mpi_issend(buf2,ic,mpi_real,my_neb(2),mype & - ,mpi_comm_comp,ihandle(3),isend) - endif -! -!----------------------------------------------------------------------- -!*** Send to west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - ibeg=its - iend=its+ihalo-1 - ic=0 -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr1(i,j) - enddo - enddo -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr2(i,j) - enddo - enddo -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr3(i,j) - enddo - enddo -! - call mpi_issend(buf3,ic,mpi_real,my_neb(4),mype & - ,mpi_comm_comp,ihandle(4),isend) - endif -! -!----------------------------------------------------------------------- -!*** Store from west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - ibeg=its-ihalo - iend=its-1 - ic=0 - call mpi_wait(ihandle(1),istat,ierr) -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr1(i,j)=buf0(ic) - enddo - enddo -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr2(i,j)=buf0(ic) - enddo - enddo -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr3(i,j)=buf0(ic) - enddo - enddo -! - endif -! -!----------------------------------------------------------------------- -!*** Store from east -!----------------------------------------------------------------------- -! - if(my_neb(2)>=0)then - ibeg=ite+1 - iend=ite+ihalo - ic=0 - call mpi_wait(ihandle(2),istat,ierr) -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr1(i,j)=buf1(ic) - enddo - enddo -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr2(i,j)=buf1(ic) - enddo - enddo -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr3(i,j)=buf1(ic) - enddo - enddo -! - endif -! - if(my_neb(4)>=0)then - call mpi_wait(ihandle(4),istat,ierr) - endif -! - if(my_neb(2)>=0)then - call mpi_wait(ihandle(3),istat,ierr) - endif -! -!----------------------------------------------------------------------- -! - end subroutine exch222 -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - subroutine exch2222(arr1,ll1,arr2,ll2,arr3,ll3,arr4,ll4 & - ,ihalo,jhalo) -! -!----------------------------------------------------------------------- -! -!*** Exchange halos for four 2-D arrays. -! -!----------------------------------------------------------------------- -!*** Argument variables -!----------------------------------------------------------------------- -! - integer(kind=kint),intent(in) :: & -! - ll1 & ! vertical dimension of 1st 2-D array (=1) -,ll2 & ! vertical dimension of 2nd 2-D array (=1) -,ll3 & ! vertical dimension of 3rd 2-D array (=1) -,ll4 & ! vertical dimension of 3rd 2-D array (=1) -,ihalo & ! number of halo rows in i direction -,jhalo ! number of halo rows in j direction -! - real(kind=kfpt),dimension(ims:ime,jms:jme),intent(inout) :: & - arr1 & ! 2-D array whose haloes are exchanged -,arr2 & ! 2-D array whose haloes are exchanged -,arr3 & ! 2-D array whose haloes are exchanged -,arr4 ! 2-D array whose haloes are exchanged -! -!----------------------------------------------------------------------- -!*** Local variables -!----------------------------------------------------------------------- -! - integer(kind=kint) :: i,ibeg,ic,iend,ierr,irecv,isend,j,jbeg,jend -! - integer(kind=kint),dimension(mpi_status_size) :: istat -! - integer(kind=kint),dimension(4) :: ihandle -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** -!*** North/South -!*** -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Receive from north -!----------------------------------------------------------------------- -! - if(my_neb(1)>=0)then - call mpi_irecv(buf0,ibufexch,mpi_real,my_neb(1),my_neb(1) & - ,mpi_comm_comp,ihandle(1),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Receive from south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - call mpi_irecv(buf1,ibufexch,mpi_real,my_neb(3),my_neb(3) & - ,mpi_comm_comp,ihandle(2),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Send to north -!----------------------------------------------------------------------- -! - ibeg=max(its-ihalo,ids) - iend=min(ite+ihalo,ide) -! - if(my_neb(1)>=0)then - ic=0 -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr1(i,jte-j) - enddo - enddo -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr2(i,jte-j) - enddo - enddo -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr3(i,jte-j) - enddo - enddo -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr4(i,jte-j) - enddo - enddo -! - call mpi_issend(buf2,ic,mpi_real,my_neb(1),mype & - ,mpi_comm_comp,ihandle(3),isend) - endif -! -!----------------------------------------------------------------------- -!*** Send to south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - ic=0 -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr1(i,jts+j) - enddo - enddo -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr2(i,jts+j) - enddo - enddo -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr3(i,jts+j) - enddo - enddo -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr4(i,jts+j) - enddo - enddo -! - call mpi_issend(buf3,ic,mpi_real,my_neb(3),mype & - ,mpi_comm_comp,ihandle(4),isend) - endif -! -!----------------------------------------------------------------------- -!*** Store results from south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - ic=0 - call mpi_wait(ihandle(2),istat,ierr) -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr1(i,jts-j-1)=buf1(ic) - enddo - enddo -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr2(i,jts-j-1)=buf1(ic) - enddo - enddo -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr3(i,jts-j-1)=buf1(ic) - enddo - enddo -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr4(i,jts-j-1)=buf1(ic) - enddo - enddo -! - endif -! -!----------------------------------------------------------------------- -!*** Store from north -!----------------------------------------------------------------------- -! - if(my_neb(1)>=0)then - ic=0 - call mpi_wait(ihandle(1),istat,ierr) -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr1(i,jte+j+1)=buf0(ic) - enddo - enddo -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr2(i,jte+j+1)=buf0(ic) - enddo - enddo -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr3(i,jte+j+1)=buf0(ic) - enddo - enddo -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr4(i,jte+j+1)=buf0(ic) - enddo - enddo -! - endif -! - if(my_neb(1)>=0)then - call mpi_wait(ihandle(3),istat,ierr) - endif -! - if(my_neb(3)>=0)then - call mpi_wait(ihandle(4),istat,ierr) - endif -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** -!*** East/West -!*** -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Receive from west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - call mpi_irecv(buf0,ibufexch,mpi_real,my_neb(4),my_neb(4) & - ,mpi_comm_comp,ihandle(1),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Receive from east -!----------------------------------------------------------------------- -! - if(my_neb(2)>=0)then - call mpi_irecv(buf1,ibufexch,mpi_real,my_neb(2),my_neb(2) & - ,mpi_comm_comp,ihandle(2),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Send to east -!----------------------------------------------------------------------- -! - jbeg=max(jts-jhalo,jds) - jend=min(jte+jhalo,jde) -! - if(my_neb(2)>=0)then - ibeg=ite-ihalo+1 - iend=ite - ic=0 -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr1(i,j) - enddo - enddo -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr2(i,j) - enddo - enddo -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr3(i,j) - enddo - enddo -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr4(i,j) - enddo - enddo -! - call mpi_issend(buf2,ic,mpi_real,my_neb(2),mype & - ,mpi_comm_comp,ihandle(3),isend) - endif -! -!----------------------------------------------------------------------- -!*** Send to west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - ibeg=its - iend=its+ihalo-1 - ic=0 -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr1(i,j) - enddo - enddo -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr2(i,j) - enddo - enddo -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr3(i,j) - enddo - enddo -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr4(i,j) - enddo - enddo -! - call mpi_issend(buf3,ic,mpi_real,my_neb(4),mype & - ,mpi_comm_comp,ihandle(4),isend) - endif -! -!----------------------------------------------------------------------- -!*** Store from west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - ibeg=its-ihalo - iend=its-1 - ic=0 - call mpi_wait(ihandle(1),istat,ierr) -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr1(i,j)=buf0(ic) - enddo - enddo -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr2(i,j)=buf0(ic) - enddo - enddo -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr3(i,j)=buf0(ic) - enddo - enddo -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr4(i,j)=buf0(ic) - enddo - enddo -! - endif -! -!----------------------------------------------------------------------- -!*** Store from east -!----------------------------------------------------------------------- -! - if(my_neb(2)>=0)then - ibeg=ite+1 - iend=ite+ihalo - ic=0 - call mpi_wait(ihandle(2),istat,ierr) -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr1(i,j)=buf1(ic) - enddo - enddo -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr2(i,j)=buf1(ic) - enddo - enddo -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr3(i,j)=buf1(ic) - enddo - enddo -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr4(i,j)=buf1(ic) - enddo - enddo -! - endif -! - if(my_neb(4)>=0)then - call mpi_wait(ihandle(4),istat,ierr) - endif -! - if(my_neb(2)>=0)then - call mpi_wait(ihandle(3),istat,ierr) - endif -! -!----------------------------------------------------------------------- -! - end subroutine exch2222 -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - subroutine exch22(arr1,ll1,arr2,ll2,ihalo,jhalo) -! -!----------------------------------------------------------------------- -! -!*** Exchange haloes for two 2-D arrays. -! -!----------------------------------------------------------------------- -!*** Argument variables -!----------------------------------------------------------------------- -! - integer(kind=kint),intent(in) :: & -! - ll1 & ! vertical dimension of 1st 2-D array (=1) -,ll2 & ! vertical dimension of 2nd 2-D array (=1) -,ihalo & ! number of halo rows in i direction -,jhalo ! number of halo rows in j direction -! - real(kind=kfpt),dimension(ims:ime,jms:jme),intent(inout) :: & - arr1 & ! 2-D array whose haloes are exchanged -,arr2 ! 2-D array whose haloes are exchanged -! -!----------------------------------------------------------------------- -!*** Local variables -!----------------------------------------------------------------------- -! - integer(kind=kint) :: i,ibeg,ic,iend,ierr,irecv,isend,j,jbeg,jend -! - integer(kind=kint),dimension(mpi_status_size) :: istat -! - integer(kind=kint),dimension(4) :: ihandle -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** -!*** North/South -!*** -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Receive from north -!----------------------------------------------------------------------- -! - if(my_neb(1)>=0)then - call mpi_irecv(buf0,ibufexch,mpi_real,my_neb(1),my_neb(1) & - ,mpi_comm_comp,ihandle(1),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Receive from south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - call mpi_irecv(buf1,ibufexch,mpi_real,my_neb(3),my_neb(3) & - ,mpi_comm_comp,ihandle(2),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Send to north -!----------------------------------------------------------------------- -! - ibeg=max(its-ihalo,ids) - iend=min(ite+ihalo,ide) -! - if(my_neb(1)>=0)then - ic=0 -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr1(i,jte-j) - enddo - enddo -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr2(i,jte-j) - enddo - enddo -! - call mpi_issend(buf2,ic,mpi_real,my_neb(1),mype & - ,mpi_comm_comp,ihandle(3),isend) - endif -! -!----------------------------------------------------------------------- -!*** Send to south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - ic=0 -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr1(i,jts+j) - enddo - enddo -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr2(i,jts+j) - enddo - enddo -! - call mpi_issend(buf3,ic,mpi_real,my_neb(3),mype & - ,mpi_comm_comp,ihandle(4),isend) - endif -! -!----------------------------------------------------------------------- -!*** Store results from south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - ic=0 - call mpi_wait(ihandle(2),istat,ierr) -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr1(i,jts-j-1)=buf1(ic) - enddo - enddo -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr2(i,jts-j-1)=buf1(ic) - enddo - enddo -! - endif -! -!----------------------------------------------------------------------- -!*** Store from north -!----------------------------------------------------------------------- -! - if(my_neb(1)>=0)then - ic=0 - call mpi_wait(ihandle(1),istat,ierr) -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr1(i,jte+j+1)=buf0(ic) - enddo - enddo -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr2(i,jte+j+1)=buf0(ic) - enddo - enddo -! - endif -! - if(my_neb(1)>=0)then - call mpi_wait(ihandle(3),istat,ierr) - endif -! - if(my_neb(3)>=0)then - call mpi_wait(ihandle(4),istat,ierr) - endif -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** -!*** East/West -!*** -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Receive from west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - call mpi_irecv(buf0,ibufexch,mpi_real,my_neb(4),my_neb(4) & - ,mpi_comm_comp,ihandle(1),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Receive from east -!----------------------------------------------------------------------- -! - if(my_neb(2)>=0)then - call mpi_irecv(buf1,ibufexch,mpi_real,my_neb(2),my_neb(2) & - ,mpi_comm_comp,ihandle(2),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Send to east -!----------------------------------------------------------------------- -! - jbeg=max(jts-jhalo,jds) - jend=min(jte+jhalo,jde) -! - if(my_neb(2)>=0)then - ibeg=ite-ihalo+1 - iend=ite - ic=0 -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr1(i,j) - enddo - enddo -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr2(i,j) - enddo - enddo -! - call mpi_issend(buf2,ic,mpi_real,my_neb(2),mype & - ,mpi_comm_comp,ihandle(3),isend) - endif -! -!----------------------------------------------------------------------- -!*** Send to west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - ibeg=its - iend=its+ihalo-1 - ic=0 -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr1(i,j) - enddo - enddo -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr2(i,j) - enddo - enddo -! - call mpi_issend(buf3,ic,mpi_real,my_neb(4),mype & - ,mpi_comm_comp,ihandle(4),isend) - endif -! -!----------------------------------------------------------------------- -!*** Store from west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - ibeg=its-ihalo - iend=its-1 - ic=0 - call mpi_wait(ihandle(1),istat,ierr) -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr1(i,j)=buf0(ic) - enddo - enddo -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr2(i,j)=buf0(ic) - enddo - enddo -! - endif -! -!----------------------------------------------------------------------- -!*** Store from east -!----------------------------------------------------------------------- -! - if(my_neb(2)>=0)then - ibeg=ite+1 - iend=ite+ihalo - ic=0 - call mpi_wait(ihandle(2),istat,ierr) -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr1(i,j)=buf1(ic) - enddo - enddo -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr2(i,j)=buf1(ic) - enddo - enddo -! - endif -! - if(my_neb(4)>=0)then - call mpi_wait(ihandle(4),istat,ierr) - endif -! - if(my_neb(2)>=0)then - call mpi_wait(ihandle(3),istat,ierr) - endif -! -!----------------------------------------------------------------------- -! - end subroutine exch22 -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - subroutine exch223(arr1,ll1,arr2,ll2,arr3,ll3,ihalo,jhalo) -! -!----------------------------------------------------------------------- -! -!*** Exchange haloes for two 2-D arrays and one 3-D array. -! -!----------------------------------------------------------------------- -!*** Argument variables -!----------------------------------------------------------------------- -! - integer(kind=kint),intent(in) :: & -! - ll1 & ! vertical dimension of 1st 2-D array (=1) -,ll2 & ! vertical dimension of 2nd 2-D array (=1) -,ll3 & ! vertical dimension of 3-D array -,ihalo & ! number of halo rows in i direction -,jhalo ! number of halo rows in j direction -! - real(kind=kfpt),dimension(ims:ime,jms:jme),intent(inout) :: & - arr1 & ! 2-D array whose haloes are exchanged -,arr2 ! 2-D array whose haloes are exchanged -! - real(kind=kfpt),dimension(ims:ime,jms:jme,ll3),intent(inout) :: & - arr3 ! 3-D array whose haloes are exchanged -! -!----------------------------------------------------------------------- -!*** Local variables -!----------------------------------------------------------------------- -! - integer(kind=kint) :: i,ibeg,ic,iend,ierr,irecv,isend,j,jbeg,jend,k -! - integer(kind=kint),dimension(mpi_status_size) :: istat -! - integer(kind=kint),dimension(4) :: ihandle -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** -!*** North/South -!*** -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Receive from north -!----------------------------------------------------------------------- -! - if(my_neb(1)>=0)then - call mpi_irecv(buf0,ibufexch,mpi_real,my_neb(1),my_neb(1) & - ,mpi_comm_comp,ihandle(1),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Receive from south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - call mpi_irecv(buf1,ibufexch,mpi_real,my_neb(3),my_neb(3) & - ,mpi_comm_comp,ihandle(2),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Send to north -!----------------------------------------------------------------------- -! - ibeg=max(its-ihalo,ids) - iend=min(ite+ihalo,ide) -! - if(my_neb(1)>=0)then - ic=0 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr1(i,jte-j) - enddo - enddo -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr2(i,jte-j) - enddo - enddo -! - do k=1,ll3 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr3(i,jte-j,k) - enddo - enddo - enddo - call mpi_issend(buf2,ic,mpi_real,my_neb(1),mype & - ,mpi_comm_comp,ihandle(3),isend) - endif -! -!----------------------------------------------------------------------- -!*** Send to south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - ic=0 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr1(i,jts+j) - enddo - enddo -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr2(i,jts+j) - enddo - enddo -! - do k=1,ll3 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr3(i,jts+j,k) - enddo - enddo - enddo - call mpi_issend(buf3,ic,mpi_real,my_neb(3),mype & - ,mpi_comm_comp,ihandle(4),isend) - endif -! -!----------------------------------------------------------------------- -!*** Store results from south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - ic=0 - call mpi_wait(ihandle(2),istat,ierr) - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr1(i,jts-j-1)=buf1(ic) - enddo - enddo -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr2(i,jts-j-1)=buf1(ic) - enddo - enddo -! - do k=1,ll3 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr3(i,jts-j-1,k)=buf1(ic) - enddo - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** Store from north -!----------------------------------------------------------------------- -! - if(my_neb(1)>=0)then - ic=0 - call mpi_wait(ihandle(1),istat,ierr) - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr1(i,jte+j+1)=buf0(ic) - enddo - enddo -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr2(i,jte+j+1)=buf0(ic) - enddo - enddo -! - do k=1,ll3 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr3(i,jte+j+1,k)=buf0(ic) - enddo - enddo - enddo - endif -! - if(my_neb(1)>=0)then - call mpi_wait(ihandle(3),istat,ierr) - endif -! - if(my_neb(3)>=0)then - call mpi_wait(ihandle(4),istat,ierr) - endif -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** -!*** East/West -!*** -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Receive from west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - call mpi_irecv(buf0,ibufexch,mpi_real,my_neb(4),my_neb(4) & - ,mpi_comm_comp,ihandle(1),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Receive from east -!----------------------------------------------------------------------- -! - if(my_neb(2)>=0)then - call mpi_irecv(buf1,ibufexch,mpi_real,my_neb(2),my_neb(2) & - ,mpi_comm_comp,ihandle(2),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Send to east -!----------------------------------------------------------------------- -! - jbeg=max(jts-jhalo,jds) - jend=min(jte+jhalo,jde) -! - if(my_neb(2)>=0)then - ibeg=ite-ihalo+1 - iend=ite - ic=0 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr1(i,j) - enddo - enddo -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr2(i,j) - enddo - enddo -! - do k=1,ll3 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr3(i,j,k) - enddo - enddo - enddo - call mpi_issend(buf2,ic,mpi_real,my_neb(2),mype & - ,mpi_comm_comp,ihandle(3),isend) - endif -! -!----------------------------------------------------------------------- -!*** Send to west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - ibeg=its - iend=its+ihalo-1 - ic=0 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr1(i,j) - enddo - enddo -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr2(i,j) - enddo - enddo -! - do k=1,ll3 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr3(i,j,k) - enddo - enddo - enddo - call mpi_issend(buf3,ic,mpi_real,my_neb(4),mype & - ,mpi_comm_comp,ihandle(4),isend) - endif -! -!----------------------------------------------------------------------- -!*** Store from west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - ibeg=its-ihalo - iend=its-1 - ic=0 - call mpi_wait(ihandle(1),istat,ierr) - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr1(i,j)=buf0(ic) - enddo - enddo -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr2(i,j)=buf0(ic) - enddo - enddo -! - do k=1,ll3 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr3(i,j,k)=buf0(ic) - enddo - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** Store from east -!----------------------------------------------------------------------- -! - if(my_neb(2)>=0)then - ibeg=ite+1 - iend=ite+ihalo - ic=0 - call mpi_wait(ihandle(2),istat,ierr) - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr1(i,j)=buf1(ic) - enddo - enddo -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr2(i,j)=buf1(ic) - enddo - enddo -! - do k=1,ll3 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr3(i,j,k)=buf1(ic) - enddo - enddo - enddo - endif -! - if(my_neb(4)>=0)then - call mpi_wait(ihandle(4),istat,ierr) - endif -! - if(my_neb(2)>=0)then - call mpi_wait(ihandle(3),istat,ierr) - endif -! -!----------------------------------------------------------------------- -! - end subroutine exch223 -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - subroutine exch22333(arr1,ll1,arr2,ll2,arr3,ll3,arr4,ll4,arr5,ll5 & - ,ihalo,jhalo) -! -!----------------------------------------------------------------------- -! -!*** Exchange haloes for two 2-D arrays and three 3-D arrays. -! -!----------------------------------------------------------------------- -!*** Argument variables -!----------------------------------------------------------------------- -! - integer(kind=kint),intent(in) :: & -! - ll1 & ! vertical dimension of 1st 2-D array (=1) -,ll2 & ! vertical dimension of 2nd 2-D array (=1) -,ll3 & ! vertical dimension of 1st 3-D array -,ll4 & ! vertical dimension of 2nd 3-D array -,ll5 & ! vertical dimension of 3rd 3-D array -,ihalo & ! number of halo rows in i direction -,jhalo ! number of halo rows in j direction -! - real(kind=kfpt),dimension(ims:ime,jms:jme),intent(inout) :: & - arr1 & ! 2-D array whose haloes are exchanged -,arr2 ! 2-D array whose haloes are exchanged -! - real(kind=kfpt),dimension(ims:ime,jms:jme,ll3),intent(inout) :: & - arr3 ! 3-D array whose haloes are exchanged -! - real(kind=kfpt),dimension(ims:ime,jms:jme,ll4),intent(inout) :: & - arr4 ! 3-D array whose haloes are exchanged -! - real(kind=kfpt),dimension(ims:ime,jms:jme,ll5),intent(inout) :: & - arr5 ! 3-D array whose haloes are exchanged -! -!----------------------------------------------------------------------- -!*** Local variables -!----------------------------------------------------------------------- -! - integer(kind=kint) :: i,ibeg,ic,iend,ierr,irecv,isend,j,jbeg,jend,k -! - integer(kind=kint),dimension(mpi_status_size) :: istat -! - integer(kind=kint),dimension(4) :: ihandle -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** -!*** North/South -!*** -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Receive from north -!----------------------------------------------------------------------- -! - if(my_neb(1)>=0)then - call mpi_irecv(buf0,ibufexch,mpi_real,my_neb(1),my_neb(1) & - ,mpi_comm_comp,ihandle(1),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Receive from south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - call mpi_irecv(buf1,ibufexch,mpi_real,my_neb(3),my_neb(3) & - ,mpi_comm_comp,ihandle(2),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Send to north -!----------------------------------------------------------------------- -! - ibeg=max(its-ihalo,ids) - iend=min(ite+ihalo,ide) -! - if(my_neb(1)>=0)then - ic=0 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr1(i,jte-j) - enddo - enddo -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr2(i,jte-j) - enddo - enddo -! - do k=1,ll3 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr3(i,jte-j,k) - enddo - enddo - enddo -! - do k=1,ll3 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr3(i,jte-j,k) - enddo - enddo - enddo -! - do k=1,ll4 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr4(i,jte-j,k) - enddo - enddo - enddo -! - do k=1,ll5 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr5(i,jte-j,k) - enddo - enddo - enddo -! - call mpi_issend(buf2,ic,mpi_real,my_neb(1),mype & - ,mpi_comm_comp,ihandle(3),isend) - endif -! -!----------------------------------------------------------------------- -!*** Send to south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - ic=0 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr1(i,jts+j) - enddo - enddo -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr2(i,jts+j) - enddo - enddo -! - do k=1,ll3 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr3(i,jts+j,k) - enddo - enddo - enddo -! - do k=1,ll4 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr4(i,jts+j,k) - enddo - enddo - enddo -! - do k=1,ll5 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr5(i,jts+j,k) - enddo - enddo - enddo -! - call mpi_issend(buf3,ic,mpi_real,my_neb(3),mype & - ,mpi_comm_comp,ihandle(4),isend) - endif -! -!----------------------------------------------------------------------- -!*** Store results from south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - ic=0 - call mpi_wait(ihandle(2),istat,ierr) - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr1(i,jts-j-1)=buf1(ic) - enddo - enddo -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr2(i,jts-j-1)=buf1(ic) - enddo - enddo -! - do k=1,ll3 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr3(i,jts-j-1,k)=buf1(ic) - enddo - enddo - enddo -! - do k=1,ll4 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr4(i,jts-j-1,k)=buf1(ic) - enddo - enddo - enddo -! - do k=1,ll5 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr5(i,jts-j-1,k)=buf1(ic) - enddo - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** Store from north -!----------------------------------------------------------------------- -! - if(my_neb(1)>=0)then - ic=0 - call mpi_wait(ihandle(1),istat,ierr) - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr1(i,jte+j+1)=buf0(ic) - enddo - enddo -! - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr2(i,jte+j+1)=buf0(ic) - enddo - enddo -! - do k=1,ll3 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr3(i,jte+j+1,k)=buf0(ic) - enddo - enddo - enddo -! - do k=1,ll4 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr4(i,jte+j+1,k)=buf0(ic) - enddo - enddo - enddo -! - do k=1,ll5 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr5(i,jte+j+1,k)=buf0(ic) - enddo - enddo - enddo - endif -! - if(my_neb(1)>=0)then - call mpi_wait(ihandle(3),istat,ierr) - endif -! - if(my_neb(3)>=0)then - call mpi_wait(ihandle(4),istat,ierr) - endif -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** -!*** East/West -!*** -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Receive from west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - call mpi_irecv(buf0,ibufexch,mpi_real,my_neb(4),my_neb(4) & - ,mpi_comm_comp,ihandle(1),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Receive from east -!----------------------------------------------------------------------- -! - if(my_neb(2)>=0)then - call mpi_irecv(buf1,ibufexch,mpi_real,my_neb(2),my_neb(2) & - ,mpi_comm_comp,ihandle(2),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Send to east -!----------------------------------------------------------------------- -! - jbeg=max(jts-jhalo,jds) - jend=min(jte+jhalo,jde) -! - if(my_neb(2)>=0)then - ibeg=ite-ihalo+1 - iend=ite - ic=0 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr1(i,j) - enddo - enddo -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr2(i,j) - enddo - enddo -! - do k=1,ll3 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr3(i,j,k) - enddo - enddo - enddo -! - do k=1,ll4 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr4(i,j,k) - enddo - enddo - enddo -! - do k=1,ll5 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr5(i,j,k) - enddo - enddo - enddo -! - call mpi_issend(buf2,ic,mpi_real,my_neb(2),mype & - ,mpi_comm_comp,ihandle(3),isend) - endif -! -!----------------------------------------------------------------------- -!*** Send to west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - ibeg=its - iend=its+ihalo-1 - ic=0 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr1(i,j) - enddo - enddo -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr2(i,j) - enddo - enddo -! - do k=1,ll3 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr3(i,j,k) - enddo - enddo - enddo -! - do k=1,ll4 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr4(i,j,k) - enddo - enddo - enddo -! - do k=1,ll5 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr5(i,j,k) - enddo - enddo - enddo -! - call mpi_issend(buf3,ic,mpi_real,my_neb(4),mype & - ,mpi_comm_comp,ihandle(4),isend) - endif -! -!----------------------------------------------------------------------- -!*** Store from west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - ibeg=its-ihalo - iend=its-1 - ic=0 - call mpi_wait(ihandle(1),istat,ierr) - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr1(i,j)=buf0(ic) - enddo - enddo -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr2(i,j)=buf0(ic) - enddo - enddo -! - do k=1,ll3 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr3(i,j,k)=buf0(ic) - enddo - enddo - enddo -! - do k=1,ll4 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr4(i,j,k)=buf0(ic) - enddo - enddo - enddo -! - do k=1,ll5 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr5(i,j,k)=buf0(ic) - enddo - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** Store from east -!----------------------------------------------------------------------- -! - if(my_neb(2)>=0)then - ibeg=ite+1 - iend=ite+ihalo - ic=0 - call mpi_wait(ihandle(2),istat,ierr) - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr1(i,j)=buf1(ic) - enddo - enddo -! - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr2(i,j)=buf1(ic) - enddo - enddo -! - do k=1,ll3 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr3(i,j,k)=buf1(ic) - enddo - enddo - enddo -! - do k=1,ll4 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr4(i,j,k)=buf1(ic) - enddo - enddo - enddo -! - do k=1,ll5 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr5(i,j,k)=buf1(ic) - enddo - enddo - enddo - endif -! - if(my_neb(4)>=0)then - call mpi_wait(ihandle(4),istat,ierr) - endif -! - if(my_neb(2)>=0)then - call mpi_wait(ihandle(3),istat,ierr) - endif -! -!----------------------------------------------------------------------- -! - end subroutine exch22333 -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - subroutine exch33(arr1,ll1,arr2,ll2,ihalo,jhalo) -! -!----------------------------------------------------------------------- -! -!*** Exchange haloes two 3-D real arrays. -! -!----------------------------------------------------------------------- -!*** Argument variables -!----------------------------------------------------------------------- -! - integer(kind=kint),intent(in) :: & -! - ll1 & ! vertical dimension of 1st 3-D array -,ll2 & ! vertical dimension of 2nd 3-D array -,ihalo & ! number of halo rows in i direction -,jhalo ! number of halo rows in j direction -! - real(kind=kfpt),dimension(ims:ime,jms:jme,ll1),intent(inout) :: & - arr1 ! 3-D array whose haloes are exchanged - real(kind=kfpt),dimension(ims:ime,jms:jme,ll2),intent(inout) :: & - arr2 ! 3-D array whose haloes are exchanged -! -!----------------------------------------------------------------------- -!*** Local variables -!----------------------------------------------------------------------- -! - integer(kind=kint) :: i,ibeg,ic,iend,ierr,irecv,isend,j,jbeg,jend,k -! - integer(kind=kint),dimension(mpi_status_size) :: istat -! - integer(kind=kint),dimension(4) :: ihandle -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** -!*** North/South -!*** -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Receive from north -!----------------------------------------------------------------------- -! - if(my_neb(1)>=0)then - call mpi_irecv(buf0,ibufexch,mpi_real,my_neb(1),my_neb(1) & - ,mpi_comm_comp,ihandle(1),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Receive from south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - call mpi_irecv(buf1,ibufexch,mpi_real,my_neb(3),my_neb(3) & - ,mpi_comm_comp,ihandle(2),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Send to north -!----------------------------------------------------------------------- -! - ibeg=max(its-ihalo,ids) - iend=min(ite+ihalo,ide) -! - if(my_neb(1)>=0)then - ic=0 -! - do k=1,ll1 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr1(i,jte-j,k) - enddo - enddo - enddo -! - do k=1,ll2 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr2(i,jte-j,k) - enddo - enddo - enddo -! - call mpi_issend(buf2,ic,mpi_real,my_neb(1),mype & - ,mpi_comm_comp,ihandle(3),isend) - endif -! -!----------------------------------------------------------------------- -!*** Send to south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - ic=0 -! - do k=1,ll1 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr1(i,jts+j,k) - enddo - enddo - enddo -! - do k=1,ll2 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr2(i,jts+j,k) - enddo - enddo - enddo -! - call mpi_issend(buf3,ic,mpi_real,my_neb(3),mype & - ,mpi_comm_comp,ihandle(4),isend) - endif -! -!----------------------------------------------------------------------- -!*** Store results from south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - ic=0 - call mpi_wait(ihandle(2),istat,ierr) -! - do k=1,ll1 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr1(i,jts-j-1,k)=buf1(ic) - enddo - enddo - enddo -! - do k=1,ll2 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr2(i,jts-j-1,k)=buf1(ic) - enddo - enddo - enddo -! - endif -! -!----------------------------------------------------------------------- -!*** Store from north -!----------------------------------------------------------------------- -! - if(my_neb(1)>=0)then - ic=0 - call mpi_wait(ihandle(1),istat,ierr) -! - do k=1,ll1 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr1(i,jte+j+1,k)=buf0(ic) - enddo - enddo - enddo -! - do k=1,ll2 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr2(i,jte+j+1,k)=buf0(ic) - enddo - enddo - enddo -! - endif -! - if(my_neb(1)>=0)then - call mpi_wait(ihandle(3),istat,ierr) - endif -! - if(my_neb(3)>=0)then - call mpi_wait(ihandle(4),istat,ierr) - endif -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** -!*** East/West -!*** -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Receive from west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - call mpi_irecv(buf0,ibufexch,mpi_real,my_neb(4),my_neb(4) & - ,mpi_comm_comp,ihandle(1),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Receive from east -!----------------------------------------------------------------------- -! - if(my_neb(2)>=0)then - call mpi_irecv(buf1,ibufexch,mpi_real,my_neb(2),my_neb(2) & - ,mpi_comm_comp,ihandle(2),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Send to east -!----------------------------------------------------------------------- -! - jbeg=max(jts-jhalo,jds) - jend=min(jte+jhalo,jde) -! - if(my_neb(2)>=0)then - ibeg=ite-ihalo+1 - iend=ite - ic=0 -! - do k=1,ll1 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr1(i,j,k) - enddo - enddo - enddo -! - do k=1,ll2 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr2(i,j,k) - enddo - enddo - enddo -! - call mpi_issend(buf2,ic,mpi_real,my_neb(2),mype & - ,mpi_comm_comp,ihandle(3),isend) - endif -! -!----------------------------------------------------------------------- -!*** Send to west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - ibeg=its - iend=its+ihalo-1 - ic=0 -! - do k=1,ll1 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr1(i,j,k) - enddo - enddo - enddo -! - do k=1,ll2 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr2(i,j,k) - enddo - enddo - enddo -! - call mpi_issend(buf3,ic,mpi_real,my_neb(4),mype & - ,mpi_comm_comp,ihandle(4),isend) - endif -! -!----------------------------------------------------------------------- -!*** Store from west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - ibeg=its-ihalo - iend=its-1 - ic=0 - call mpi_wait(ihandle(1),istat,ierr) -! - do k=1,ll1 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr1(i,j,k)=buf0(ic) - enddo - enddo - enddo -! - do k=1,ll2 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr2(i,j,k)=buf0(ic) - enddo - enddo - enddo -! - endif -! -!----------------------------------------------------------------------- -!*** Store from east -!----------------------------------------------------------------------- -! - if(my_neb(2)>=0)then - ibeg=ite+1 - iend=ite+ihalo - ic=0 - call mpi_wait(ihandle(2),istat,ierr) -! - do k=1,ll1 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr1(i,j,k)=buf1(ic) - enddo - enddo - enddo -! - do k=1,ll2 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr2(i,j,k)=buf1(ic) - enddo - enddo - enddo -! - endif -! - if(my_neb(4)>=0)then - call mpi_wait(ihandle(4),istat,ierr) - endif -! - if(my_neb(2)>=0)then - call mpi_wait(ihandle(3),istat,ierr) - endif -! -!----------------------------------------------------------------------- -! - end subroutine exch33 -! -!-------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - subroutine exch333(arr1,ll1,arr2,ll2,arr3,ll3,ihalo,jhalo) -! -!----------------------------------------------------------------------- -! -!*** Exchange haloes three 3-D real arrays. -! -!----------------------------------------------------------------------- -!*** Argument variables -!----------------------------------------------------------------------- -! - integer(kind=kint),intent(in) :: & -! - ll1 & ! vertical dimension of 1st 3-D array -,ll2 & ! vertical dimension of 2nd 3-D array -,ll3 & ! vertical dimension of 3rd 3-D array -,ihalo & ! number of halo rows in i direction -,jhalo ! number of halo rows in j direction -! - real(kind=kfpt),dimension(ims:ime,jms:jme,ll1),intent(inout) :: & - arr1 ! 3-D array whose haloes are exchanged - real(kind=kfpt),dimension(ims:ime,jms:jme,ll2),intent(inout) :: & - arr2 ! 3-D array whose haloes are exchanged - real(kind=kfpt),dimension(ims:ime,jms:jme,ll3),intent(inout) :: & - arr3 ! 3-D array whose haloes are exchanged -! -!----------------------------------------------------------------------- -!*** Local variables -!----------------------------------------------------------------------- -! - integer(kind=kint) :: i,ibeg,ic,iend,ierr,irecv,isend,j,jbeg,jend,k -! - integer(kind=kint),dimension(mpi_status_size) :: istat -! - integer(kind=kint),dimension(4) :: ihandle -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** -!*** North/South -!*** -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Receive from north -!----------------------------------------------------------------------- -! - if(my_neb(1)>=0)then - call mpi_irecv(buf0,ibufexch,mpi_real,my_neb(1),my_neb(1) & - ,mpi_comm_comp,ihandle(1),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Receive from south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - call mpi_irecv(buf1,ibufexch,mpi_real,my_neb(3),my_neb(3) & - ,mpi_comm_comp,ihandle(2),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Send to north -!----------------------------------------------------------------------- -! - ibeg=max(its-ihalo,ids) - iend=min(ite+ihalo,ide) -! - if(my_neb(1)>=0)then - ic=0 -! - do k=1,ll1 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr1(i,jte-j,k) - enddo - enddo - enddo -! - do k=1,ll2 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr2(i,jte-j,k) - enddo - enddo - enddo -! - do k=1,ll3 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr3(i,jte-j,k) - enddo - enddo - enddo -! - call mpi_issend(buf2,ic,mpi_real,my_neb(1),mype & - ,mpi_comm_comp,ihandle(3),isend) - endif -! -!----------------------------------------------------------------------- -!*** Send to south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - ic=0 -! - do k=1,ll1 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr1(i,jts+j,k) - enddo - enddo - enddo -! - do k=1,ll2 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr2(i,jts+j,k) - enddo - enddo - enddo -! - do k=1,ll3 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr3(i,jts+j,k) - enddo - enddo - enddo -! - call mpi_issend(buf3,ic,mpi_real,my_neb(3),mype & - ,mpi_comm_comp,ihandle(4),isend) - endif -! -!----------------------------------------------------------------------- -!*** Store results from south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - ic=0 - call mpi_wait(ihandle(2),istat,ierr) -! - do k=1,ll1 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr1(i,jts-j-1,k)=buf1(ic) - enddo - enddo - enddo -! - do k=1,ll2 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr2(i,jts-j-1,k)=buf1(ic) - enddo - enddo - enddo -! - do k=1,ll3 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr3(i,jts-j-1,k)=buf1(ic) - enddo - enddo - enddo -! - endif -! -!----------------------------------------------------------------------- -!*** Store from north -!----------------------------------------------------------------------- -! - if(my_neb(1)>=0)then - ic=0 - call mpi_wait(ihandle(1),istat,ierr) -! - do k=1,ll1 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr1(i,jte+j+1,k)=buf0(ic) - enddo - enddo - enddo -! - do k=1,ll2 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr2(i,jte+j+1,k)=buf0(ic) - enddo - enddo - enddo -! - do k=1,ll3 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr3(i,jte+j+1,k)=buf0(ic) - enddo - enddo - enddo -! - endif -! - if(my_neb(1)>=0)then - call mpi_wait(ihandle(3),istat,ierr) - endif -! - if(my_neb(3)>=0)then - call mpi_wait(ihandle(4),istat,ierr) - endif -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** -!*** East/West -!*** -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Receive from west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - call mpi_irecv(buf0,ibufexch,mpi_real,my_neb(4),my_neb(4) & - ,mpi_comm_comp,ihandle(1),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Receive from east -!----------------------------------------------------------------------- -! - if(my_neb(2)>=0)then - call mpi_irecv(buf1,ibufexch,mpi_real,my_neb(2),my_neb(2) & - ,mpi_comm_comp,ihandle(2),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Send to east -!----------------------------------------------------------------------- -! - jbeg=max(jts-jhalo,jds) - jend=min(jte+jhalo,jde) -! - if(my_neb(2)>=0)then - ibeg=ite-ihalo+1 - iend=ite - ic=0 -! - do k=1,ll1 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr1(i,j,k) - enddo - enddo - enddo -! - do k=1,ll2 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr2(i,j,k) - enddo - enddo - enddo -! - do k=1,ll3 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr3(i,j,k) - enddo - enddo - enddo -! - call mpi_issend(buf2,ic,mpi_real,my_neb(2),mype & - ,mpi_comm_comp,ihandle(3),isend) - endif -! -!----------------------------------------------------------------------- -!*** Send to west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - ibeg=its - iend=its+ihalo-1 - ic=0 -! - do k=1,ll1 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr1(i,j,k) - enddo - enddo - enddo -! - do k=1,ll2 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr2(i,j,k) - enddo - enddo - enddo -! - do k=1,ll3 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr3(i,j,k) - enddo - enddo - enddo -! - call mpi_issend(buf3,ic,mpi_real,my_neb(4),mype & - ,mpi_comm_comp,ihandle(4),isend) - endif -! -!----------------------------------------------------------------------- -!*** Store from west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - ibeg=its-ihalo - iend=its-1 - ic=0 - call mpi_wait(ihandle(1),istat,ierr) -! - do k=1,ll1 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr1(i,j,k)=buf0(ic) - enddo - enddo - enddo -! - do k=1,ll2 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr2(i,j,k)=buf0(ic) - enddo - enddo - enddo -! - do k=1,ll3 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr3(i,j,k)=buf0(ic) - enddo - enddo - enddo -! - endif -! -!----------------------------------------------------------------------- -!*** Store from east -!----------------------------------------------------------------------- -! - if(my_neb(2)>=0)then - ibeg=ite+1 - iend=ite+ihalo - ic=0 - call mpi_wait(ihandle(2),istat,ierr) -! - do k=1,ll1 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr1(i,j,k)=buf1(ic) - enddo - enddo - enddo -! - do k=1,ll2 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr2(i,j,k)=buf1(ic) - enddo - enddo - enddo -! - do k=1,ll3 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr3(i,j,k)=buf1(ic) - enddo - enddo - enddo -! - endif -! - if(my_neb(4)>=0)then - call mpi_wait(ihandle(4),istat,ierr) - endif -! - if(my_neb(2)>=0)then - call mpi_wait(ihandle(3),istat,ierr) - endif -! -!----------------------------------------------------------------------- -! - end subroutine exch333 -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - subroutine exch3333(arr1,ll1,arr2,ll2,arr3,ll3,arr4,ll4,ihalo,jhalo) -! -!----------------------------------------------------------------------- -! -!*** Exchange haloes four 3-D real arrays. -! -!----------------------------------------------------------------------- -!*** Argument variables -!----------------------------------------------------------------------- -! - integer(kind=kint),intent(in) :: & -! - ll1 & ! vertical dimension of 1st 3-D array -,ll2 & ! vertical dimension of 2nd 3-D array -,ll3 & ! vertical dimension of 3rd 3-D array -,ll4 & ! vertical dimension of 4th 3-D array -,ihalo & ! number of halo rows in i direction -,jhalo ! number of halo rows in j direction -! - real(kind=kfpt),dimension(ims:ime,jms:jme,ll1),intent(inout) :: & - arr1 ! 3-D array whose haloes are exchanged - real(kind=kfpt),dimension(ims:ime,jms:jme,ll2),intent(inout) :: & - arr2 ! 3-D array whose haloes are exchanged - real(kind=kfpt),dimension(ims:ime,jms:jme,ll3),intent(inout) :: & - arr3 ! 3-D array whose haloes are exchanged - real(kind=kfpt),dimension(ims:ime,jms:jme,ll4),intent(inout) :: & - arr4 ! 3-D array whose haloes are exchanged -! -!----------------------------------------------------------------------- -!*** Local variables -!----------------------------------------------------------------------- -! - integer(kind=kint) :: i,ibeg,ic,iend,ierr,irecv,isend,j,jbeg,jend,k -! - integer(kind=kint),dimension(mpi_status_size) :: istat -! - integer(kind=kint),dimension(4) :: ihandle -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** -!*** North/South -!*** -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Receive from north -!----------------------------------------------------------------------- -! - if(my_neb(1)>=0)then - call mpi_irecv(buf0,ibufexch,mpi_real,my_neb(1),my_neb(1) & - ,mpi_comm_comp,ihandle(1),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Receive from south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - call mpi_irecv(buf1,ibufexch,mpi_real,my_neb(3),my_neb(3) & - ,mpi_comm_comp,ihandle(2),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Send to north -!----------------------------------------------------------------------- -! - ibeg=max(its-ihalo,ids) - iend=min(ite+ihalo,ide) -! - if(my_neb(1)>=0)then - ic=0 -! - do k=1,ll1 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr1(i,jte-j,k) - enddo - enddo - enddo -! - do k=1,ll2 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr2(i,jte-j,k) - enddo - enddo - enddo -! - do k=1,ll3 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr3(i,jte-j,k) - enddo - enddo - enddo -! - do k=1,ll4 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr4(i,jte-j,k) - enddo - enddo - enddo -! - call mpi_issend(buf2,ic,mpi_real,my_neb(1),mype & - ,mpi_comm_comp,ihandle(3),isend) - endif -! -!----------------------------------------------------------------------- -!*** Send to south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - ic=0 -! - do k=1,ll1 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr1(i,jts+j,k) - enddo - enddo - enddo -! - do k=1,ll2 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr2(i,jts+j,k) - enddo - enddo - enddo -! - do k=1,ll3 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr3(i,jts+j,k) - enddo - enddo - enddo -! - do k=1,ll4 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr4(i,jts+j,k) - enddo - enddo - enddo - call mpi_issend(buf3,ic,mpi_real,my_neb(3),mype & - ,mpi_comm_comp,ihandle(4),isend) - endif -! -!----------------------------------------------------------------------- -!*** Store results from south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - ic=0 - call mpi_wait(ihandle(2),istat,ierr) -! - do k=1,ll1 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr1(i,jts-j-1,k)=buf1(ic) - enddo - enddo - enddo -! - do k=1,ll2 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr2(i,jts-j-1,k)=buf1(ic) - enddo - enddo - enddo -! - do k=1,ll3 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr3(i,jts-j-1,k)=buf1(ic) - enddo - enddo - enddo -! - do k=1,ll4 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr4(i,jts-j-1,k)=buf1(ic) - enddo - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** Store from north -!----------------------------------------------------------------------- -! - if(my_neb(1)>=0)then - ic=0 - call mpi_wait(ihandle(1),istat,ierr) -! - do k=1,ll1 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr1(i,jte+j+1,k)=buf0(ic) - enddo - enddo - enddo -! - do k=1,ll2 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr2(i,jte+j+1,k)=buf0(ic) - enddo - enddo - enddo -! - do k=1,ll3 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr3(i,jte+j+1,k)=buf0(ic) - enddo - enddo - enddo -! - do k=1,ll4 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr4(i,jte+j+1,k)=buf0(ic) - enddo - enddo - enddo - endif -! - if(my_neb(1)>=0)then - call mpi_wait(ihandle(3),istat,ierr) - endif -! - if(my_neb(3)>=0)then - call mpi_wait(ihandle(4),istat,ierr) - endif -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** -!*** East/West -!*** -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Receive from west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - call mpi_irecv(buf0,ibufexch,mpi_real,my_neb(4),my_neb(4) & - ,mpi_comm_comp,ihandle(1),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Receive from east -!----------------------------------------------------------------------- -! - if(my_neb(2)>=0)then - call mpi_irecv(buf1,ibufexch,mpi_real,my_neb(2),my_neb(2) & - ,mpi_comm_comp,ihandle(2),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Send to east -!----------------------------------------------------------------------- -! - jbeg=max(jts-jhalo,jds) - jend=min(jte+jhalo,jde) -! - if(my_neb(2)>=0)then - ibeg=ite-ihalo+1 - iend=ite - ic=0 -! - do k=1,ll1 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr1(i,j,k) - enddo - enddo - enddo -! - do k=1,ll2 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr2(i,j,k) - enddo - enddo - enddo -! - do k=1,ll3 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr3(i,j,k) - enddo - enddo - enddo -! - do k=1,ll4 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr4(i,j,k) - enddo - enddo - enddo - call mpi_issend(buf2,ic,mpi_real,my_neb(2),mype & - ,mpi_comm_comp,ihandle(3),isend) - endif -! -!----------------------------------------------------------------------- -!*** Send to west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - ibeg=its - iend=its+ihalo-1 - ic=0 -! - do k=1,ll1 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr1(i,j,k) - enddo - enddo - enddo -! - do k=1,ll2 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr2(i,j,k) - enddo - enddo - enddo -! - do k=1,ll3 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr3(i,j,k) - enddo - enddo - enddo -! - do k=1,ll4 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr4(i,j,k) - enddo - enddo - enddo - call mpi_issend(buf3,ic,mpi_real,my_neb(4),mype & - ,mpi_comm_comp,ihandle(4),isend) - endif -! -!----------------------------------------------------------------------- -!*** Store from west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - ibeg=its-ihalo - iend=its-1 - ic=0 - call mpi_wait(ihandle(1),istat,ierr) -! - do k=1,ll1 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr1(i,j,k)=buf0(ic) - enddo - enddo - enddo -! - do k=1,ll2 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr2(i,j,k)=buf0(ic) - enddo - enddo - enddo -! - do k=1,ll3 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr3(i,j,k)=buf0(ic) - enddo - enddo - enddo -! - do k=1,ll4 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr4(i,j,k)=buf0(ic) - enddo - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** Store from east -!----------------------------------------------------------------------- -! - if(my_neb(2)>=0)then - ibeg=ite+1 - iend=ite+ihalo - ic=0 - call mpi_wait(ihandle(2),istat,ierr) -! - do k=1,ll1 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr1(i,j,k)=buf1(ic) - enddo - enddo - enddo -! - do k=1,ll2 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr2(i,j,k)=buf1(ic) - enddo - enddo - enddo -! - do k=1,ll3 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr3(i,j,k)=buf1(ic) - enddo - enddo - enddo -! - do k=1,ll4 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr4(i,j,k)=buf1(ic) - enddo - enddo - enddo - endif -! - if(my_neb(4)>=0)then - call mpi_wait(ihandle(4),istat,ierr) - endif -! - if(my_neb(2)>=0)then - call mpi_wait(ihandle(3),istat,ierr) - endif -! -!----------------------------------------------------------------------- -! - end subroutine exch3333 -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - subroutine exch4(arr1,ll1,nl1,nstart,ihalo,jhalo) -! -!----------------------------------------------------------------------- -! -!*** Exchange haloes for a single 4-D array. -! -!----------------------------------------------------------------------- -!*** Argument variables -!----------------------------------------------------------------------- -! - integer(kind=kint),intent(in) :: & -! - ll1 & ! vertical dimension of array -,nl1 & ! 4th dimension of array -,nstart & ! index of the 4th dimension to start exchange -,ihalo & ! number of halo rows in i direction -,jhalo ! number of halo rows in j direction -! - real(kind=kfpt),dimension(ims:ime,jms:jme,ll1,nl1),intent(inout) :: & -! - arr1 ! array whose haloes are exchanged -! -!----------------------------------------------------------------------- -!*** Local variables -!----------------------------------------------------------------------- -! - integer(kind=kint) :: i,ibeg,ic,iend,ierr,irecv,isend,j,jbeg,jend & - ,k,n -! - integer(kind=kint),dimension(mpi_status_size) :: istat -! - integer(kind=kint),dimension(4) :: ihandle -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** -!*** North/South -!*** -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Receive from north -!----------------------------------------------------------------------- -! - if(my_neb(1)>=0)then - call mpi_irecv(buf0,ibufexch,mpi_real,my_neb(1),my_neb(1) & - ,mpi_comm_comp,ihandle(1),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Receive from south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - call mpi_irecv(buf1,ibufexch,mpi_real,my_neb(3),my_neb(3) & - ,mpi_comm_comp,ihandle(2),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Send to north -!----------------------------------------------------------------------- -! - ibeg=max(its-ihalo,ids) - iend=min(ite+ihalo,ide) -! - if(my_neb(1)>=0)then - ic=0 - do n=nstart,nl1 - do k=1,ll1 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr1(i,jte-j,k,n) - enddo - enddo - enddo - enddo - call mpi_issend(buf2,ic,mpi_real,my_neb(1),mype & - ,mpi_comm_comp,ihandle(3),isend) - endif -! -!----------------------------------------------------------------------- -!*** Send to south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - ic=0 - do n=nstart,nl1 - do k=1,ll1 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr1(i,jts+j,k,n) - enddo - enddo - enddo - enddo - call mpi_issend(buf3,ic,mpi_real,my_neb(3),mype & - ,mpi_comm_comp,ihandle(4),isend) - endif -! -!----------------------------------------------------------------------- -!*** Store results from south -!----------------------------------------------------------------------- -! - if(my_neb(3)>=0)then - ic=0 - call mpi_wait(ihandle(2),istat,ierr) - do n=nstart,nl1 - do k=1,ll1 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr1(i,jts-j-1,k,n)=buf1(ic) - enddo - enddo - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** Store from north -!----------------------------------------------------------------------- -! - if(my_neb(1)>=0)then - ic=0 - call mpi_wait(ihandle(1),istat,ierr) - do n=nstart,nl1 - do k=1,ll1 - do j=0,jhalo-1 - do i=ibeg,iend - ic=ic+1 - arr1(i,jte+j+1,k,n)=buf0(ic) - enddo - enddo - enddo - enddo - endif -! - if(my_neb(1)>=0)then - call mpi_wait(ihandle(3),istat,ierr) - endif -! - if(my_neb(3)>=0)then - call mpi_wait(ihandle(4),istat,ierr) - endif -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** -!*** East/West -!*** -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Receive from west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - call mpi_irecv(buf0,ibufexch,mpi_real,my_neb(4),my_neb(4) & - ,mpi_comm_comp,ihandle(1),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Receive from east -!----------------------------------------------------------------------- -! - if(my_neb(2)>=0)then - call mpi_irecv(buf1,ibufexch,mpi_real,my_neb(2),my_neb(2) & - ,mpi_comm_comp,ihandle(2),irecv) - endif -! -!----------------------------------------------------------------------- -!*** Send to east -!----------------------------------------------------------------------- -! - jbeg=max(jts-jhalo,jds) - jend=min(jte+jhalo,jde) -! - if(my_neb(2)>=0)then - ibeg=ite-ihalo+1 - iend=ite - ic=0 - do n=nstart,nl1 - do k=1,ll1 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf2(ic)=arr1(i,j,k,n) - enddo - enddo - enddo - enddo - call mpi_issend(buf2,ic,mpi_real,my_neb(2),mype & - ,mpi_comm_comp,ihandle(3),isend) - endif -! -!----------------------------------------------------------------------- -!*** Send to west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - ibeg=its - iend=its+ihalo-1 - ic=0 - do n=nstart,nl1 - do k=1,ll1 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - buf3(ic)=arr1(i,j,k,n) - enddo - enddo - enddo - enddo - call mpi_issend(buf3,ic,mpi_real,my_neb(4),mype & - ,mpi_comm_comp,ihandle(4),isend) - endif -! -!----------------------------------------------------------------------- -!*** Store from west -!----------------------------------------------------------------------- -! - if(my_neb(4)>=0)then - ibeg=its-ihalo - iend=its-1 - ic=0 - call mpi_wait(ihandle(1),istat,ierr) - do n=nstart,nl1 - do k=1,ll1 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr1(i,j,k,n)=buf0(ic) - enddo - enddo - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** Store from east -!----------------------------------------------------------------------- -! - if(my_neb(2)>=0)then - ibeg=ite+1 - iend=ite+ihalo - ic=0 - call mpi_wait(ihandle(2),istat,ierr) - do n=nstart,nl1 - do k=1,ll1 - do j=jbeg,jend - do i=ibeg,iend - ic=ic+1 - arr1(i,j,k,n)=buf1(ic) - enddo - enddo - enddo - enddo - endif -! - if(my_neb(4)>=0)then - call mpi_wait(ihandle(4),istat,ierr) - endif -! - if(my_neb(2)>=0)then - call mpi_wait(ihandle(3),istat,ierr) - endif -! -!----------------------------------------------------------------------- -! - end subroutine exch4 -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - end module module_exchange -! -!----------------------------------------------------------------------- diff --git a/src/nmm/module_FLTBNDS.F90 b/src/nmm/module_FLTBNDS.F90 deleted file mode 100644 index 43227fc..0000000 --- a/src/nmm/module_FLTBNDS.F90 +++ /dev/null @@ -1,7019 +0,0 @@ -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - module module_fltbnds -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -use mpi - -use module_kinds - -use module_control,only : klog,kint,kfpt - -use module_my_domain_specs - -use module_derived_types,only: bc_h_all,bc_v_all,filt_4d - -use module_dm_parallel,only : gather_layers,scatter_layers - -use module_exchange, only: halo_exch - -public :: presmud - -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -real(kind=kfpt),parameter:: & - pi=3.141592653589793238462643383279502884197169399375105820 & -,pih=pi/2. & -,tpi=pi+pi & -,dtr=pi/180. -! -integer(kind=kint) :: & - ipe_start_north & -,ipe_start_south & -,ipe_end_north & -,ipe_end_south & -,jh_start_fft_north & -,jh_end_fft_north & -,jh_start_fft_south & -,jh_end_fft_south & -,jv_start_fft_north & -,jv_end_fft_north & -,jv_start_fft_south & -,jv_end_fft_south & -,lm_fft & ! Max number of model layers per task for FFTs -,msize_dummy_fft -! -integer(kind=kint),dimension(mpi_status_size),private :: & - istatw -! -integer(kind=kint),allocatable,dimension(:) :: & - k1_fft & -,k2_fft & -,my_jrow_start_h & -,my_jrow_start_v & -,my_jrow_end_h & -,my_jrow_end_v -! -real(kind=kfpt),allocatable,dimension(:,:,:) :: & - hn & -,un & -,vn & -,wn -! -logical(kind=klog) :: & - fft_north & -,fft_south -! -logical(kind=klog),allocatable,dimension(:) :: & - my_domain_has_fft_lats_h & -,my_domain_has_fft_lats_v -! -!----------------------------------------------------------------------- - contains -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- - subroutine prefft & -(dlmd,dphd,sbd,lm & -,khfilt,kvfilt & -,hfilt,vfilt & -,wfftrh,nfftrh,wfftrw,nfftrw & -,inpes,jnpes,mype) -!----------------------------------------------------------------------- - implicit none -!----------------------------------------------------------------------- - -real(kind=kfpt),parameter :: & - cxnc=0.0 & -,rwind=1./2.6 & -,cfilt=1. - -integer(kind=kint),intent(in) :: & - inpes & -,jnpes & -,mype & -,lm - -integer(kind=kint),dimension(jds:jde),intent(out) :: & - khfilt & -,kvfilt - -integer(kind=kint),dimension(1:15),intent(out) :: & - nfftrh & -,nfftrw - -real(kind=kfpt),intent(in) :: & - dlmd & -,dphd & -,sbd - -real(kind=kfpt),dimension(ids:ide,jds:jde),intent(out) :: & - hfilt & -,vfilt - -real(kind=kfpt),dimension(1:2*(ide-3)),intent(out) :: & - wfftrh & -,wfftrw - -!----------------------------------------------------------------------- -!*** Local Variables -!----------------------------------------------------------------------- - -logical(kind=klog) :: & - first - -integer(kind=kint) :: & - icycle & -,imax & -,istat & -,j & -,jmax & -,jmax_north & -,jmax_south & -,k & -,k2 & -,kount_layers & -,kount_pes & -,ks & -,l_remain & -,lyr_frac_north & -,lyr_frac_south & -,n & -,n_extra & -,n_factor & -,n_group1 & -,n_group2 & -,n_remain & -,n_remainder_h_group1 & -,n_remainder_h_group2 & -,n_remainder_v_group1 & -,n_remainder_v_group2 & -,nnew & -,npe & -,npe_next & -,npes & -,npes_north & -,npes_south & -,nrow_x & -,nrows_fft_north_h & -,nrows_fft_south_h & -,nrows_fft_north_v & -,nrows_fft_south_v & -,nrows_group1_h & -,nrows_group2_h & -,nrows_group1_v & -,nrows_group2_v & -,nsmud - -real(kind=kfpt) :: & - cpf & -,cph & -,cx & -,cxn & -,dlm & -,dph & -,flt & -,rcph & -,rcycle & -,sb & -,sub_j & -,sxl & -,tph & -,x & -,xl - -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- - icycle=ide-3 - rcycle=1./icycle -! - dlm=dlmd*dtr - dph=dphd*dtr - sb=sbd*dtr -! - cpf=dph/dlm -!----------------------------------------------------------------------- -!*** Maximum number of layers used per task for FFTs. -!*** Since the FFT regions cap the poles, there are 2*LM layers -!*** in play. -!----------------------------------------------------------------------- -! - npes=inpes*jnpes -! -!----------------------------------------------------------------------- -!-------------filters on h and v rows----------------------------------- -!----------------------------------------------------------------------- -! - jh_start_fft_south=-10 - jh_end_fft_south=-10 - jh_start_fft_north=-10 - jh_end_fft_north=-10 -! - sub_j=real(jds+1) -! -!----------------------------------------------------------------------- -! - h_filters: do j=jds+2,jde-2 -! -!----------------------------------------------------------------------- - tph=sb+(j-sub_j)*dph - cph=cos(tph) - rcph=(cph/cpf) - ks=icycle - nsmud=0 -!----------------------------------------------------------------------- -!*** Perform Fourier filtering where cos(phi) < dph/dlm . -!----------------------------------------------------------------------- -! - if(rcph.lt.cfilt) then -! - if(tph<0.)then - if(jh_start_fft_south<-5)jh_start_fft_south=j - jh_end_fft_south=j - else - if(jh_start_fft_north<-5)jh_start_fft_north=j - jh_end_fft_north=j - endif -! - khfilt(j)=icycle - hfilt(1,j)=rcycle - first=.true. -! - do k=2,icycle-1,2 - x=k*dlm*0.25 - xl=min(x/rcph*cfilt,pih) - sxl=sin(xl)+sin(2.*xl)*0.5*rwind -! - if(rcph/sxl.gt.cfilt) then - flt=rcycle - ks=k - else -!--filter definition---------------------------------------------------- - cx=cos(x) - if(abs(cx).lt.1.e-7) first=.false. - if(first) then - nnew=(log(sxl/(xl*(1.+rwind)))/log(cx)+0.5) - if(nnew.gt.nsmud) nsmud=nnew - if(mod(nsmud,2).gt.0) nsmud=nsmud+1 - if(xl.eq.pih) first=.false. - endif -!----------------------------------------------------------------------- - cxn=cx**nsmud -! - if(cxn.lt.cxnc) then - khfilt(j)=k-1 -! - do k2=k+1,icycle+1 - hfilt(k2,j)=0. - enddo -! - cycle h_filters - endif -! - flt=min(cxn*rcycle,rcycle) - endif -! - hfilt(k ,j)=flt - hfilt(k+1,j)=flt -! - enddo -! - - x=icycle*dlm*0.25 - xl=min(x/rcph*cfilt,pih) - sxl=sin(xl)+sin(2.*xl)*0.5*rwind -! - if(rcph/sxl.gt.cfilt) then - flt=rcycle - ks=k - else -!--filter definition---------------------------------------------------- - cx=cos(x) - if(abs(cx).lt.1.e-7) first=.false. - if(first) then - nnew=(log(sxl/(xl*(1.+rwind)))/log(cx)+0.5) - if(nnew.gt.nsmud) nsmud=nnew - if(mod(nsmud,2).gt.0) nsmud=nsmud+1 - if(xl.eq.pih) first=.false. - endif -!----------------------------------------------------------------------- - cxn=cx**nsmud -! - if(cxn.gt.cxnc) then - khfilt(j)=icycle - else - cxn=0. - endif -! - flt=min(cxn*rcycle,rcycle) - endif -! - hfilt(icycle,j)=flt - else - khfilt(j)=icycle+1 - do k=1,icycle - hfilt(k ,j)=rcycle - enddo - endif -!----------------------------------------------------------------------- -! - enddo h_filters -! -!----------------------------------------------------------------------- -! - if(ks.gt.khfilt(j)) ks=0 -! - khfilt(jds)=khfilt(jds+2) - khfilt(jds+1)=1 - khfilt(jde-1)=1 - khfilt(jde )=khfilt(jde-2) -! - do k=1,icycle - hfilt(k,jds)=hfilt(k,jds+2) - hfilt(k,jds+1)=0. - hfilt(k,jde-1)=0. - hfilt(k,jde )=hfilt(k,jde-2) - enddo -! - hfilt(1,jds+1)=1. - hfilt(1,jde-1)=1. -!----------------------------------------------------------------------- -! - jv_start_fft_south=-10 - jv_end_fft_south=-10 - jv_start_fft_north=-10 - jv_end_fft_north=-10 -! - sub_j=jds+0.5 -! -!----------------------------------------------------------------------- -! - v_filters: do j=jds+1,jde-2 -! -!----------------------------------------------------------------------- - tph=sb+(j-sub_j)*dph - cph=cos(tph) - rcph=(cph/cpf) - ks=icycle - nsmud=0 -!----------------------------------------------------------------------- -!*** Perform Fourier filtering where cos(phi) < dph/dlm . -!----------------------------------------------------------------------- - if(rcph.lt.cfilt) then -! - if(tph<0.)then - if(jv_start_fft_south<-5)jv_start_fft_south=j - jv_end_fft_south=j - else - if(jv_start_fft_north<-5)jv_start_fft_north=j - jv_end_fft_north=j - endif -! - kvfilt(j)=icycle - vfilt(1,j)=rcycle - first=.true. -! - do k=2,icycle-1,2 - x=k*dlm*0.25 - xl=min(x/rcph*cfilt,pih) - sxl=sin(xl)+sin(2.*xl)*0.5*rwind -! - if(rcph/sxl.gt.cfilt) then - flt=rcycle - ks=k - else -!--filter definition---------------------------------------------------- - cx=cos(x) - if(abs(cx).lt.1.e-7) first=.false. - if(first) then - nnew=(log(sxl/(xl*(1.+rwind)))/log(cx)+0.5) - if(nnew.gt.nsmud) nsmud=nnew - if(mod(nsmud,2).gt.0) nsmud=nsmud+1 - if(xl.eq.pih) first=.false. - endif -!----------------------------------------------------------------------- - cxn=cx**nsmud -! - if(cxn.lt.cxnc) then - kvfilt(j)=k-1 -! - do k2=k+1,icycle+1 - vfilt(k2,j)=0. - enddo -! - cycle v_filters - endif -! - flt=min(cxn*rcycle,rcycle) - endif -! - vfilt(k ,j)=flt - vfilt(k+1,j)=flt -! - enddo -! - x=icycle*dlm*0.25 - xl=min(x/rcph*cfilt,pih) - sxl=sin(xl)+sin(2.*xl)*0.5*rwind -! - if(rcph/sxl.gt.cfilt) then - flt=rcycle - ks=k - else -!--filter definition---------------------------------------------------- - cx=cos(x) - if(abs(cx).lt.1.e-7) first=.false. - if(first) then - nnew=(log(sxl/(xl*(1.+rwind)))/log(cx)+0.5) - if(nnew.gt.nsmud) nsmud=nnew - if(mod(nsmud,2).gt.0) nsmud=nsmud+1 - if(xl.eq.pih) first=.false. - endif -!----------------------------------------------------------------------- - cxn=cx**nsmud -! - if(cxn.gt.cxnc) then - kvfilt(j)=icycle - else - cxn=0. - endif -! - flt=min(cxn*rcycle,rcycle) - endif -! - vfilt(icycle,j)=flt -! - else - kvfilt(j)=icycle+1 - do k=1,icycle - vfilt(k ,j)=rcycle - enddo - endif -!----------------------------------------------------------------------- -! - enddo v_filters -! -!----------------------------------------------------------------------- -! - if(ks.gt.kvfilt(j)) ks=0 -! - kvfilt(jds)=kvfilt(jds+1) - kvfilt(jde-1)=kvfilt(jde-2) -! - do k=1,icycle - vfilt(k,jds)=vfilt(k,jds+1) - vfilt(k,jde-1)=vfilt(k,jde-2) - enddo -! - call rffti(icycle,wfftrh,nfftrh) - call rffti(icycle,wfftrw,nfftrw) -! -!----------------------------------------------------------------------- -!*** Much preparation is needed for setting up the sharing of -!*** FFT computations by all compute tasks. If only a single -!*** compute task has been designated for the domain then -!*** no prep is needed. -!----------------------------------------------------------------------- -! - if(inpes==1.and.jnpes==1)then - return - endif -! -!----------------------------------------------------------------------- -! - if(jh_start_fft_south==jds+2)jh_start_fft_south=jds+1 - if(jh_end_fft_north==jde-2)jh_end_fft_north=jde-1 -! -!----------------------------------------------------------------------- -!*** Identify tasks as handling Northern or Southern Hemipshere -!*** model layers for FFTs. -!----------------------------------------------------------------------- -! - fft_south=.false. - fft_north=.false. - ipe_start_south=0 - ipe_end_north=npes-1 -! - if(jts=jh_start_fft_north)then - my_domain_has_fft_lats_h(n)=.true. - endif -! - if(fft_south.and.local_jstart(n)<=jv_end_fft_south.or. & - fft_north.and.local_jend(n)>=jv_start_fft_north)then - my_domain_has_fft_lats_v(n)=.true. - endif -! - enddo -! -!----------------------------------------------------------------------- -!*** Assign layers to each task. -!*** k1_fft and k2_fft are the first and last model layers in -!*** a task's group of layers over which it will apply FFTs. -!*** Groups of model layers will be assigned from top down -!*** in the southern or northern hemisphere and then divided -!*** if there are more than 2*LM MPI tasks being used. -!*** When there are "remainder" layers, give them one at a time -!*** to each task in the row until they are used up. -! -!*** If there are more than LM MPI tasks in a hemisphere then -!*** the layers themselves begin to be divided up to continue -!*** to ensure that all tasks will receive some of the FFT work. -!----------------------------------------------------------------------- -! - allocate(k1_fft(0:npes-1),stat=istat) - allocate(k2_fft(0:npes-1),stat=istat) - allocate(my_jrow_start_h(0:npes-1),stat=istat) - allocate(my_jrow_end_h(0:npes-1) ,stat=istat) - allocate(my_jrow_start_v(0:npes-1),stat=istat) - allocate(my_jrow_end_v(0:npes-1) ,stat=istat) -! -!------------------------- -!*** Southern Hemisphere -!------------------------- -! - npes_south=ipe_end_south-ipe_start_south+1 -! -!---------------------------------------------------- -!*** The number of tasks in the Southern Hemisphere -!*** does not exceed the number of model layers. -!---------------------------------------------------- -! - limits_south: if(npes_south<=lm)then -! - lyr_frac_south=lm/npes_south - l_remain=lm-npes_south*lyr_frac_south -! - k2=0 - do npe=0,ipe_end_south - k1_fft(npe)=k2+1 - k2=k1_fft(npe)+lyr_frac_south-1 - if(l_remain>0)then - k2=k2+1 - l_remain=l_remain-1 - endif - k2_fft(npe)=k2 -! - my_jrow_start_h(npe)=jh_start_fft_south - my_jrow_end_h(npe)=jh_end_fft_south - my_jrow_start_v(npe)=jv_start_fft_south - my_jrow_end_v(npe)=jv_end_fft_south - enddo -! -!---------------------------------------------------- -!*** If there are more tasks in the hemisphere -!*** than there are model layers then divide the -!*** layers into n_factor pieces for tasks in -!*** n_group1 and divide the remaining layers into -!*** n_factor+1 pieces for tasks in n_group2. -!---------------------------------------------------- -! - else - lyr_frac_south=0 - n_factor=npes_south/lm - n_remain=npes_south-n_factor*lm - n_group1=n_factor*(lm-n_remain) !<-- This many tasks get layers divided into n_factor pieces - n_group2=npes_south-n_group1 !<-- This many tasks get layers divided into n_factor+1 pieces -! -!---------------------------------------------------- -!*** Divide layers of FFTs into n_factor pieces -!*** for tasks in n_group1. -!*** Divide remaining layers into n_factor+1 pieces -!*** for tasks in n_group2. -!---------------------------------------------------- -! - nrows_fft_south_h=jh_end_fft_south-jh_start_fft_south+1 -! - nrows_group1_h=nrows_fft_south_h/n_factor !<-- Each task in group 1 handles this many H lat rows - n_remainder_h_group1=nrows_fft_south_h-nrows_group1_h*n_factor ! or one additional row to take care of remainders. -! - nrows_group2_h=nrows_fft_south_h/(n_factor+1) !<-- Each task in group 2 handles this many H lat rows - n_remainder_h_group2=nrows_fft_south_h-nrows_group2_h*(n_factor+1) ! or one additional row to take care of remainders. -! - nrows_fft_south_v=jv_end_fft_south-jv_start_fft_south+1 -! - nrows_group1_v=nrows_fft_south_v/n_factor !<-- Each task in group 1 handles this many V lat rows - n_remainder_v_group1=nrows_fft_south_v-nrows_group1_v*n_factor ! or one additional row to take care of remainders. -! - nrows_group2_v=nrows_fft_south_v/(n_factor+1) !<-- Each task in group 2 handles this many V lat rows - n_remainder_v_group2=nrows_fft_south_v-nrows_group2_v*(n_factor+1) ! or one additional row to take care of remainders. -! -!--------------------------- -!*** Tasks in group 1 for H -!--------------------------- -! - kount_pes=0 - kount_layers=1 - nrow_x=jh_start_fft_south - n_extra=n_remainder_h_group1 -! - do npe=0,ipe_end_south - my_jrow_start_h(npe)=nrow_x - my_jrow_end_h(npe)=min(nrow_x+nrows_group1_h-1,jh_end_fft_south) -! - if(n_extra>0)then !<-- Use up remainder H lat rows. - my_jrow_end_h(npe)=my_jrow_end_h(npe)+1 - n_extra=n_extra-1 - endif -! - k1_fft(npe)=kount_layers - k2_fft(npe)=kount_layers - kount_pes=kount_pes+1 -! - if(kount_pes==n_group1)then - npe_next=npe+1 - kount_layers=kount_layers+1 - exit !<-- Now move on to group 2 tasks - endif -! - if(my_jrow_end_h(npe)==jh_end_fft_south)then !<-- Ready to move down to next model layer. - nrow_x=jh_start_fft_south - kount_layers=kount_layers+1 - n_extra=n_remainder_h_group1 - else !<-- Still divvying up this model layer. - nrow_x=my_jrow_end_h(npe)+1 - endif -! - enddo -! -!--------------------------- -!*** Tasks in group 2 for H -!--------------------------- -! - if(npe_next<=ipe_end_south)then - kount_pes=0 - nrow_x=jh_start_fft_south - n_extra=n_remainder_h_group2 -! - do npe=npe_next,ipe_end_south - my_jrow_start_h(npe)=nrow_x - my_jrow_end_h(npe)=min(nrow_x+nrows_group2_h-1,jh_end_fft_south) -! - if(n_extra>0)then !<-- Use up remainder H lat rows. - my_jrow_end_h(npe)=my_jrow_end_h(npe)+1 - n_extra=n_extra-1 - endif -! - k1_fft(npe)=kount_layers - k2_fft(npe)=kount_layers - kount_pes=kount_pes+1 - if(kount_pes==n_group2)then !<-- All Southern Hemisphere tasks are assigned to FFT's - exit ! for H points. - endif - if(my_jrow_end_h(npe)==jh_end_fft_south)then !<-- Ready to move down to next model layer. - nrow_x=jh_start_fft_south - kount_layers=kount_layers+1 - n_extra=n_remainder_h_group2 - else !<-- Still divvying up this model layer. - nrow_x=my_jrow_end_h(npe)+1 - endif - enddo - endif -! -!--------------------------- -!*** Tasks in group 1 for V -!--------------------------- -! - kount_pes=0 - kount_layers=1 - nrow_x=jv_start_fft_south - n_extra=n_remainder_v_group1 -! - do npe=0,ipe_end_south - my_jrow_start_v(npe)=nrow_x - my_jrow_end_v(npe)=min(nrow_x+nrows_group1_v-1,jv_end_fft_south) -! - if(n_extra>0)then !<-- Use up remainder V lat rows. - my_jrow_end_v(npe)=my_jrow_end_v(npe)+1 - n_extra=n_extra-1 - endif -! - k1_fft(npe)=kount_layers - k2_fft(npe)=kount_layers - kount_pes=kount_pes+1 -! - if(kount_pes==n_group1)then - npe_next=npe+1 - kount_layers=kount_layers+1 - exit !<-- Move on to group 2 tasks. - endif -! - if(my_jrow_end_v(npe)==jv_end_fft_south)then !<-- Ready to move down to next model layer. - nrow_x=jv_start_fft_south - kount_layers=kount_layers+1 - n_extra=n_remainder_v_group1 - else !<-- Still divvying up this model layer. - nrow_x=my_jrow_end_v(npe)+1 - endif -! - enddo -! -!--------------------------- -!*** Tasks in group 2 for V -!--------------------------- -! - if(npe_next<=ipe_end_south)then - kount_pes=0 - nrow_x=jv_start_fft_south - n_extra=n_remainder_v_group2 -! - do npe=npe_next,ipe_end_south - my_jrow_start_v(npe)=nrow_x - my_jrow_end_v(npe)=min(nrow_x+nrows_group2_v-1,jv_end_fft_south) -! - if(n_extra>0)then !<-- Use up remainder V lat rows. - my_jrow_end_v(npe)=my_jrow_end_v(npe)+1 - n_extra=n_extra-1 - endif -! - k1_fft(npe)=kount_layers - k2_fft(npe)=kount_layers - kount_pes=kount_pes+1 -! - if(kount_pes==n_group2)then !<-- All Southern Hemisphere tasks are assigned to FFTs - exit ! for V points. - endif -! - if(my_jrow_end_v(npe)==jv_end_fft_south)then !<-- Ready to move down to next model layer. - nrow_x=jv_start_fft_south - kount_layers=kount_layers+1 - n_extra=n_remainder_v_group2 - else !<-- Still divvying up this model layer. - nrow_x=my_jrow_end_v(npe)+1 - endif -! - enddo - endif -! - endif limits_south -! -!------------------------- -!*** Northern Hemisphere -!------------------------- -! - npes_north=ipe_end_north-ipe_start_north+1 -! -!---------------------------------------------------- -!*** The number of tasks in the Northern Hemisphere -!*** does not exceed the number of model layers. -!---------------------------------------------------- -! - limits_north: if(npes_north<=lm)then -! - lyr_frac_north=lm/npes_north - l_remain=lm-npes_north*lyr_frac_north -! - k2=0 - do npe=ipe_start_north,ipe_end_north - k1_fft(npe)=k2+1 - k2=k1_fft(npe)+lyr_frac_north-1 - if(l_remain>0)then - k2=k2+1 - l_remain=l_remain-1 - endif - k2_fft(npe)=k2 -! - my_jrow_start_h(npe)=jh_start_fft_north - my_jrow_end_h(npe)=jh_end_fft_north - my_jrow_start_v(npe)=jv_start_fft_north - my_jrow_end_v(npe)=jv_end_fft_north - enddo -! -!---------------------------------------------------- -!*** If there are more tasks in the hemisphere -!*** than there are model layers then divide the -!*** layers into n_factor pieces for tasks in -!*** n_group1 and divide the remaining layers into -!*** n_factor+1 pieces for tasks in n_group2. -!---------------------------------------------------- -! - else - lyr_frac_north=0 - n_factor=npes_north/lm - n_remain=npes_north-n_factor*lm - n_group1=n_factor*(lm-n_remain) !<-- This many tasks get layers divided into n_factor pieces - n_group2=npes_north-n_group1 !<-- This many tasks get layers divided into n_factor+1 pieces -! -!---------------------------------------------------- -!*** Divide layers of FFTs into n_factor pieces -!*** for tasks in n_group1. -!*** Divide remaining layers into n_factor+1 pieces -!*** for tasks in n_group2. -!---------------------------------------------------- -! - nrows_fft_north_h=jh_end_fft_north-jh_start_fft_north+1 -! - nrows_group1_h=nrows_fft_north_h/n_factor !<-- Each task in group 1 handles this many H lat rows - n_remainder_h_group1=nrows_fft_north_h-nrows_group1_h*n_factor ! or one additional row to take care of remainders. -! - nrows_group2_h=nrows_fft_north_h/(n_factor+1) !<-- Each task in group 2 handles this many H lat rows - n_remainder_h_group2=nrows_fft_north_h-nrows_group2_h*(n_factor+1) ! or one additional row to take care of remainders. -! - nrows_fft_north_v=jv_end_fft_north-jv_start_fft_north+1 -! - nrows_group1_v=nrows_fft_north_v/n_factor !<-- Each task in group 1 handles this many V lat rows - n_remainder_v_group1=nrows_fft_north_v-nrows_group1_v*n_factor ! or one additional row to take care of remainders. -! - nrows_group2_v=nrows_fft_north_v/(n_factor+1) !<-- Each task in group 2 handles this many V lat rows - n_remainder_v_group2=nrows_fft_north_v-nrows_group2_v*(n_factor+1) ! or one additional row to take care of remainders -! -!--------------------------- -!*** Tasks in group 1 for H -!--------------------------- -! - kount_pes=0 - kount_layers=1 - nrow_x=jh_start_fft_north - n_extra=n_remainder_h_group1 -! - do npe=ipe_start_north,ipe_end_north - my_jrow_start_h(npe)=nrow_x - my_jrow_end_h(npe)=min(nrow_x+nrows_group1_h-1,jh_end_fft_north) -! - if(n_extra>0)then !<-- Use up remainder H lat rows. - my_jrow_end_h(npe)=my_jrow_end_h(npe)+1 - n_extra=n_extra-1 - endif -! - k1_fft(npe)=kount_layers - k2_fft(npe)=kount_layers - kount_pes=kount_pes+1 -! - if(kount_pes==n_group1)then - npe_next=npe+1 - kount_layers=kount_layers+1 - exit !<-- Now move on to group 2 tasks. - endif -! - if(my_jrow_end_h(npe)==jh_end_fft_north)then !<-- Ready to move down to next model layer. - nrow_x=jh_start_fft_north - kount_layers=kount_layers+1 - n_extra=n_remainder_h_group1 - else - nrow_x=my_jrow_end_h(npe)+1 !<-- Still divvying up this model layer. - endif -! - enddo -! -!--------------------------- -!*** Tasks in group 2 for H -!--------------------------- -! - if(npe_next<=ipe_end_north)then - kount_pes=0 - nrow_x=jh_start_fft_north - n_extra=n_remainder_h_group2 -! - do npe=npe_next,ipe_end_north - my_jrow_start_h(npe)=nrow_x - my_jrow_end_h(npe)=min(nrow_x+nrows_group2_h-1,jh_end_fft_north) -! - if(n_extra>0)then !<-- Use up remainder H lat rows. - my_jrow_end_h(npe)=my_jrow_end_h(npe)+1 - n_extra=n_extra-1 - endif -! - k1_fft(npe)=kount_layers - k2_fft(npe)=kount_layers - kount_pes=kount_pes+1 -! - if(kount_pes==n_group2)then !<-- All Northern Hemisphere tasks are assigned to FFT's - exit ! for H points. - endif -! - if(my_jrow_end_h(npe)==jh_end_fft_north)then - nrow_x=jh_start_fft_north - kount_layers=kount_layers+1 !<-- Ready to move down to next model layer. - n_extra=n_remainder_h_group2 - else - nrow_x=my_jrow_end_h(npe)+1 !<-- Still divvying up rows in this model layer. - endif -! - enddo - endif -! -!--------------------------- -!*** Tasks in group 1 for V -!--------------------------- -! - kount_pes=0 - kount_layers=1 - nrow_x=jv_start_fft_north - n_extra=n_remainder_v_group1 -! - do npe=ipe_start_north,ipe_end_north - my_jrow_start_v(npe)=nrow_x - my_jrow_end_v(npe)=min(nrow_x+nrows_group1_v-1,jv_end_fft_north) -! - if(n_extra>0)then !<-- Use up remainder H lat rows. - my_jrow_end_v(npe)=my_jrow_end_v(npe)+1 - n_extra=n_extra-1 - endif -! - k1_fft(npe)=kount_layers - k2_fft(npe)=kount_layers - kount_pes=kount_pes+1 -! - if(kount_pes==n_group1)then - npe_next=npe+1 - kount_layers=kount_layers+1 - exit !<-- Now move on to group 2 tasks. - endif -! - if(my_jrow_end_v(npe)==jv_end_fft_north)then - nrow_x=jv_start_fft_north - kount_layers=kount_layers+1 !<-- Ready to move down to next model layer. - n_extra=n_remainder_v_group1 - else - nrow_x=my_jrow_end_v(npe)+1 !<-- Still divvying up rows in this model layer. - endif -! - enddo -! -!--------------------------- -!*** Tasks in group 2 for V -!--------------------------- -! - if(npe_next<=ipe_end_north)then - kount_pes=0 - nrow_x=jv_start_fft_north - n_extra=n_remainder_v_group2 -! - do npe=npe_next,ipe_end_north - my_jrow_start_v(npe)=nrow_x - my_jrow_end_v(npe)=min(nrow_x+nrows_group2_v-1,jv_end_fft_north) -! - if(n_extra>0)then !<-- Use up remainder H lat rows. - my_jrow_end_v(npe)=my_jrow_end_v(npe)+1 - n_extra=n_extra-1 - endif -! - k1_fft(npe)=kount_layers - k2_fft(npe)=kount_layers - kount_pes=kount_pes+1 -! - if(kount_pes==n_group2)then !<-- All Northern Hemisphere tasks are assigned to FFTs - exit ! for V points. - endif -! - if(my_jrow_end_v(npe)==jv_end_fft_north)then - nrow_x=jv_start_fft_north - kount_layers=kount_layers+1 !<-- Ready to move down to next model layer. - n_extra=n_remainder_v_group2 - else - nrow_x=my_jrow_end_v(npe)+1 !<-- Still divvying up rows in this model layer. - endif -! - enddo - endif -! - endif limits_north -! -!----------------------------------------------------------------------- -!*** Allocate the working arrays for the FFTs depending on which -!*** hemisphere this task is in. -!----------------------------------------------------------------------- -! - lm_fft=max(lyr_frac_north,lyr_frac_south)+1 -! - allocate(hn(ids:ide,my_jrow_start_h(mype):my_jrow_end_h(mype),1:lm_fft) & - ,stat=istat) - allocate(wn(ids:ide,my_jrow_start_v(mype):my_jrow_end_v(mype),1:lm_fft) & - ,stat=istat) - allocate(un(ids:ide,my_jrow_start_v(mype):my_jrow_end_v(mype),1:lm_fft) & - ,stat=istat) - allocate(vn(ids:ide,my_jrow_start_v(mype):my_jrow_end_v(mype),1:lm_fft) & - ,stat=istat) -! -!----------------------------------------------------------------------- -!*** Maximum size of dummy space for FFTs -!----------------------------------------------------------------------- -! - imax=(ide-ids+1)/inpes+1 - jmax_south=max(jh_end_fft_south-jh_start_fft_south & - ,jv_end_fft_south-jv_start_fft_south)+1 - jmax_north=max(jh_end_fft_north-jh_start_fft_north & - ,jv_end_fft_north-jv_start_fft_north)+1 - jmax=max(jmax_south,jmax_north) - msize_dummy_fft=imax*jmax*lm_fft -! -!----------------------------------------------------------------------- -! - endsubroutine prefft -! -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -! - subroutine fftfhn & -(km & -,khfilt & -,hfilt & -,field_h & -,wfftrh,nfftrh & -,npes,mype,mpi_comm_comp) - -!----------------------------------------------------------------------- - implicit none -!----------------------------------------------------------------------- - -integer(kind=kint),intent(in) :: & - km & -,mpi_comm_comp & ! This domain's fcst task intracommunicator -,mype & ! Rank of this task in the fcst intracommunicator -,npes ! Number of compute tasks - -integer(kind=kint),dimension(1:15),intent(in):: & - nfftrh - -integer(kind=kint),dimension(jds:jde),intent(in):: & - khfilt - -real(kind=kfpt),dimension(ids:ide,jds:jde),intent(in):: & - hfilt - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:km),intent(inout):: & - field_h - -real(kind=kfpt),dimension(1:2*(ide-3)),intent(in) :: & - wfftrh - -!----------------------------------------------------------------------- -!*** Local Variables -!----------------------------------------------------------------------- - -integer(kind=kint) :: & - i & -,icycle & -,ipe_end & -,ipe_start & -,j & -,jend & -,jstart & -,jh_end_fft & -,jh_start_fft & -,k1 & -,k2 & -,l & -,n & -,nend - -real(kind=kfpt) :: & - an & -,as & -,rcycle - -!real(kind=kfpt),dimension(ids:ide,jts:jte,1:lm_fft) :: & -!real(kind=kfpt),dimension(ids:ide,jh_start_fft:jh_end_fft,1:lm_fft) :: & -! hn - -real(kind=kfpt),dimension(1:ide-3):: & - buff - -integer :: ierr,ixx,jxx,kxx -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- - icycle=ide-3 - rcycle=1./icycle -!----------------------------------------------------------------------- -!*** First take care of the special case in which only a single -!*** MPI task has been designated for the entire domain. -!----------------------------------------------------------------------- -! - if(npes==1)then -! -!----------------------------------------------------------------------- -! - as=0. - an=0. -! - do l=1,km -! - do i=ids+1,ide-2 - as=field_h(i,jds+1,l)+as - an=field_h(i,jde-1,l)+an - enddo -! - as=as*rcycle - an=an*rcycle -! - do i=ids,ide - field_h(i,jds+1,l)=as - field_h(i,jde-1,l)=an - enddo -! - do j=jds+2,jde-2 -! - if(khfilt(j)<=icycle) then -! - do i=ids+1,ide-2 - buff(i-1)=field_h(i,j,l) - enddo -! - call rfftf(icycle,buff,wfftrh,nfftrh) -! - do i=1,khfilt(j)-1 - buff(i)=buff(i)*hfilt(i,j) - enddo -! - do i=khfilt(j),icycle - buff(i)=0. - enddo -! - call rfftb(icycle,buff,wfftrh,nfftrh) -! - do i=ids+1,ide-2 - field_h(i,j,l)=buff(i-1) - enddo -! - field_h(ide-1,j,l)=buff(1) -! - endif -! - enddo -! - enddo -! - return -! -!----------------------------------------------------------------------- -! - endif -! -!----------------------------------------------------------------------- -!*** The remainder of this subroutine is relevant when more than -!*** a single task has been specified. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** k1 and k2 are starting/ending vertical indices of model layers -!*** that this task will use in applying FFTs. -!----------------------------------------------------------------------- -! - k1=k1_fft(mype) - k2=k2_fft(mype) -! -!----------------------------------------------------------------------- -!*** Select hemisphere-dependent variables. -!----------------------------------------------------------------------- -! - if(fft_south)then - jh_start_fft=jh_start_fft_south - jh_end_fft=jh_end_fft_south - ipe_start=ipe_start_south - ipe_end=ipe_end_south - elseif(fft_north)then - jh_start_fft=jh_start_fft_north - jh_end_fft=jh_end_fft_north - ipe_start=ipe_start_north - ipe_end=ipe_end_north - endif -! -!----------------------------------------------------------------------- -!*** Gather the model layer data from full latitude circles -!*** onto appropriate tasks for the FFTs. -!----------------------------------------------------------------------- -! - call gather_layers(field_h,km,npes,msize_dummy_fft & - ,lm_fft,k1_fft,k2_fft & - ,local_istart,local_iend & - ,local_jstart,local_jend & - ,my_jrow_start_h(mype),my_jrow_end_h(mype) & - ,my_jrow_start_h,my_jrow_end_h & - ,ipe_start,ipe_end & - ,my_domain_has_fft_lats_h & - ,mype,mpi_comm_comp & - ,its,ite,ims,ime,ids,ide,jts,jte,jms,jme & - ,hn) -! -!----------------------------------------------------------------------- -! - nend=k2-k1+1 - kloop1: do n=1,nend -! -!----------------------------------------------------------------------- - if(fft_south)then -!----------------------------------------------------------------------- - as=0. -! - if(lbound(hn,2)==jds+1)then - do i=ids+1,ide-2 - as=hn(i,jds+1,n)+as - enddo -! - as=as*rcycle -! - do i=ids,ide - hn(i,jds+1,n)=as - enddo - endif -! -!----------------------------------------------------------------------- - elseif(fft_north)then -!----------------------------------------------------------------------- - an=0. -! - if(ubound(hn,2)==jde-1)then - do i=ids+1,ide-2 - an=hn(i,jde-1,n)+an - enddo -! - an=an*rcycle -! - do i=ids,ide - hn(i,jde-1,n)=an - enddo - endif -! -!----------------------------------------------------------------------- - endif -!----------------------------------------------------------------------- -! - enddo kloop1 -! -!----------------------------------------------------------------------- -!*** jstart and jend are the starting/ending rows on which this task -!*** will apply FFTs -!----------------------------------------------------------------------- -! - jstart=max(my_jrow_start_h(mype),jds+2) - jend=min(my_jrow_end_h(mype),jde-2) -! -!----------------------------------------------------------------------- -! - kloop2: do n=1,nend -! -!----------------------------------------------------------------------- -! - do j=jstart,jend -! -!----------------------------------------------------------------------- - if(khfilt(j)<=icycle) then -!----------------------------------------------------------------------- - do i=ids+1,ide-2 - buff(i-1)=hn(i,j,n) - enddo -! - call rfftf(icycle,buff,wfftrh,nfftrh) -! - do i=1,khfilt(j)-1 - buff(i)=buff(i)*hfilt(i,j) - enddo -! - do i=khfilt(j),icycle - buff(i)=0. - enddo -! - call rfftb(icycle,buff,wfftrh,nfftrh) -! - do i=ids+1,ide-2 - hn(i,j,n)=buff(i-1) - enddo -! - hn(ide-1,j,n)=buff(1) -!----------------------------------------------------------------------- - endif -!----------------------------------------------------------------------- - enddo -!----------------------------------------------------------------------- -! - enddo kloop2 -! -!----------------------------------------------------------------------- -!*** Now scatter the model layer data from full latitude circles -!*** back to the appropriate tasks. -!----------------------------------------------------------------------- -! - call scatter_layers(hn,km,npes,msize_dummy_fft & - ,lm_fft,k1_fft,k2_fft & - ,local_istart,local_iend & - ,local_jstart,local_jend & - ,my_jrow_start_h(mype),my_jrow_end_h(mype) & - ,my_jrow_start_h,my_jrow_end_h & - ,ipe_start,ipe_end & - ,my_domain_has_fft_lats_h & - ,mype,mpi_comm_comp & - ,its,ite,ims,ime,ids,ide,jts,jte,jms,jme & - ,field_h) -! -!----------------------------------------------------------------------- -! - endsubroutine fftfhn -! -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -! - subroutine fftfwn & -(km & -,kvfilt & -,vfilt & -,field_w & -,wfftrw,nfftrw & -,npes) -! -!----------------------------------------------------------------------- - implicit none -!----------------------------------------------------------------------- - -integer(kind=kint),intent(in) :: & - km & -,npes ! Number of compute tasks - -integer(kind=kint),dimension(1:15),intent(in):: & - nfftrw - -integer(kind=kint),dimension(jds:jde),intent(in):: & - kvfilt - -real(kind=kfpt),dimension(ids:ide,jds:jde),intent(in):: & - vfilt - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:km),intent(inout):: & - field_w - -!----------------------------------------------------------------------- -!*** Local Variables -!----------------------------------------------------------------------- - -integer(kind=kint) :: & - i & -,ipe_start & -,ipe_end & -,icycle & -,iloc_mype & -,j & -,jend & -,jstart & -,jv_end_fft & -,jv_start_fft & -,k1 & -,k2 & -,l & -,n & -,nend - -real(kind=kfpt) :: & - rcycle - -!real(kind=kfpt),dimension(ids:ide,jts:jte,1:lm_fft) :: & -!real(kind=kfpt),dimension(ids:ide,jv_start_fft:jv_end_fft,1:lm_fft) :: & -! wn - -real(kind=kfpt),dimension(1:ide-3):: & - buff - -real(kind=kfpt),dimension(1:2*(ide-3)):: & - wfftrw - -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- - icycle=ide-3 - rcycle=1./icycle -!----------------------------------------------------------------------- -!*** k1 and k2 are starting/ending vertical indices of model layers -!*** that this task will use in applying FFTs. -!----------------------------------------------------------------------- -! - k1=k1_fft(mype) - k2=k2_fft(mype) -! -!----------------------------------------------------------------------- -!*** Select hemisphere-dependent variables. -!----------------------------------------------------------------------- -! - if(fft_south)then - jv_start_fft=jv_start_fft_south - jv_end_fft=jv_end_fft_south - ipe_start=ipe_start_south - ipe_end=ipe_end_south - elseif(fft_north)then - jv_start_fft=jv_start_fft_north - jv_end_fft=jv_end_fft_north - ipe_start=ipe_start_north - ipe_end=ipe_end_north - endif -! -!----------------------------------------------------------------------- -!*** Gather the model layer data from full latitude circles -!*** onto appropriate tasks for the FFTs. -!----------------------------------------------------------------------- -! - call gather_layers(field_w,km,npes,msize_dummy_fft & - ,lm_fft,k1_fft,k2_fft & - ,local_istart,local_iend & - ,local_jstart,local_jend & - ,my_jrow_start_v(mype),my_jrow_end_v(mype) & - ,my_jrow_start_v,my_jrow_end_v & - ,ipe_start,ipe_end & - ,my_domain_has_fft_lats_v & - ,mype,mpi_comm_comp & - ,its,ite,ims,ime,ids,ide,jts,jte,jms,jme & - ,wn) -! -!----------------------------------------------------------------------- -!*** jstart and jend are the starting/ending rows on which this task -!*** will apply FFTs -!----------------------------------------------------------------------- -! - jstart=max(my_jrow_start_v(mype),jds+1) - jend=min(my_jrow_end_v(mype),jde-2) -! -!----------------------------------------------------------------------- -! - nend=k2-k1+1 - kloop1: do n=1,nend -! - do j=jstart,jend -! -!----------------------------------------------------------------------- - if(kvfilt(j)<=icycle) then -!----------------------------------------------------------------------- - do i=ids+1,ide-2 - buff(i-1)=wn(i,j,n) - enddo -! - call rfftf(icycle,buff,wfftrw,nfftrw) -! - do i=1,kvfilt(j)-1 - buff(i)=buff(i)*vfilt(i,j) - enddo - do i=kvfilt(j),icycle - buff(i)=0. - enddo -! - call rfftb(icycle,buff,wfftrw,nfftrw) -! - do i=ids+1,ide-2 - wn(i,j,n)=buff(i-1) - enddo -! - wn(ide-1,j,n)=buff(1) -!----------------------------------------------------------------------- - endif -!----------------------------------------------------------------------- - enddo -!----------------------------------------------------------------------- - enddo kloop1 -!----------------------------------------------------------------------- -!*** Now scatter the model layer data from full latitude circles -!*** back to the appropriate tasks. -!----------------------------------------------------------------------- -! - call scatter_layers(wn,km,npes,msize_dummy_fft & - ,lm_fft,k1_fft,k2_fft & - ,local_istart,local_iend & - ,local_jstart,local_jend & - ,my_jrow_start_v(mype),my_jrow_end_v(mype) & - ,my_jrow_start_v,my_jrow_end_v & - ,ipe_start,ipe_end & - ,my_domain_has_fft_lats_v & - ,mype,mpi_comm_comp & - ,its,ite,ims,ime,ids,ide,jts,jte,jms,jme & - ,field_w) -! -!----------------------------------------------------------------------- -! - endsubroutine fftfwn -! -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -! - subroutine fftfuvn & -(km & -,kvfilt & -,vfilt & -,u,v & -,wfftrw,nfftrw & -,npes,mype,mpi_comm_comp) -! -!----------------------------------------------------------------------- - implicit none -!----------------------------------------------------------------------- - -integer(kind=kint),intent(in) :: & - km & -,mpi_comm_comp & ! This domain's fcst task intracommunicator -,mype & ! Rank of this task in the fcst intracommunicator -,npes ! Number of compute tasks - -integer(kind=kint),dimension(1:15),intent(in):: & - nfftrw - -integer(kind=kint),dimension(jds:jde),intent(in):: & - kvfilt - -real(kind=kfpt),dimension(ids:ide,jds:jde),intent(in):: & - vfilt - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:km),intent(inout):: & - u & -,v - -!----------------------------------------------------------------------- -!*** Local Variables -!----------------------------------------------------------------------- - -integer(kind=kint) :: & - i & -,ipe_start & -,ipe_end & -,icycle & -,iloc_mype & -,j & -,jend & -,jstart & -,jv_end_fft & -,jv_start_fft & -,k1 & -,k2 & -,l & -,n - -real(kind=kfpt) :: & - anu & -,anv & -,asu & -,asv & -,rcycle - -real(kind=kfpt),dimension(1:ide-3):: & - buffu & -,buffv - -real(kind=kfpt),dimension(1:2*(ide-3)):: & - wfftrw - -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- - icycle=ide-3 - rcycle=1./icycle -!----------------------------------------------------------------------- -!*** First take care of the special case in which only a single -!*** MPI task has been designated for the entire domain. -!----------------------------------------------------------------------- -! - if(npes==1)then -! -!----------------------------------------------------------------------- -! - do l=1,km -! - do j=jds+1,jde-2 -! - if(kvfilt(j)<=icycle) then -! - do i=ids+1,ide-2 - buffu(i-1)=u(i,j,l) - buffv(i-1)=v(i,j,l) - enddo -! - call rfftf(icycle,buffu,wfftrw,nfftrw) - call rfftf(icycle,buffv,wfftrw,nfftrw) -! - do i=1,kvfilt(j)-1 - buffu(i)=buffu(i)*vfilt(i,j) - buffv(i)=buffv(i)*vfilt(i,j) - enddo - do i=kvfilt(j),icycle - buffu(i)=0. - buffv(i)=0. - enddo -! - call rfftb(icycle,buffu,wfftrw,nfftrw) - call rfftb(icycle,buffv,wfftrw,nfftrw) -! - do i=ids+1,ide-2 - u(i,j,l)=buffu(i-1) - v(i,j,l)=buffv(i-1) - enddo -! - u(ide-1,j,l)=buffu(1) - v(ide-1,j,l)=buffv(1) -! - endif -! - enddo -! - enddo -! - return -! -!----------------------------------------------------------------------- -! - endif -! -!----------------------------------------------------------------------- -!*** The remainder of this routine is relevant for the use of -!*** multiple MPI tasks on the domain. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** k1 and k2 are starting/ending vertical indices of model layers -!*** that this task will use in applying FFTs. -!----------------------------------------------------------------------- -! - k1=k1_fft(mype) - k2=k2_fft(mype) -! -!----------------------------------------------------------------------- -!*** Select hemisphere-dependent variables. -!----------------------------------------------------------------------- -! - if(fft_south)then - jv_start_fft=jv_start_fft_south - jv_end_fft=jv_end_fft_south - ipe_start=ipe_start_south - ipe_end=ipe_end_south - elseif(fft_north)then - jv_start_fft=jv_start_fft_north - jv_end_fft=jv_end_fft_north - ipe_start=ipe_start_north - ipe_end=ipe_end_north - endif -! -!----------------------------------------------------------------------- -!*** Gather the model layer data from full latitude circles -!*** onto appropriate tasks for the FFTs. -!----------------------------------------------------------------------- -! - call gather_layers(u,km,npes,msize_dummy_fft & - ,lm_fft,k1_fft,k2_fft & - ,local_istart,local_iend & - ,local_jstart,local_jend & - ,my_jrow_start_v(mype),my_jrow_end_v(mype) & - ,my_jrow_start_v,my_jrow_end_v & - ,ipe_start,ipe_end & - ,my_domain_has_fft_lats_v & - ,mype,mpi_comm_comp & - ,its,ite,ims,ime,ids,ide,jts,jte,jms,jme & - ,un) - call gather_layers(v,km,npes,msize_dummy_fft & - ,lm_fft,k1_fft,k2_fft & - ,local_istart,local_iend & - ,local_jstart,local_jend & - ,my_jrow_start_v(mype),my_jrow_end_v(mype) & - ,my_jrow_start_v,my_jrow_end_v & - ,ipe_start,ipe_end & - ,my_domain_has_fft_lats_v & - ,mype,mpi_comm_comp & - ,its,ite,ims,ime,ids,ide,jts,jte,jms,jme & - ,vn) -! -!----------------------------------------------------------------------- -! -! n=0 -! kloop1: do l=k1,k2 -! -!----------------------------------------------------------------------- -! asu=0. -! asv=0. -! anu=0. -! anv=0. -! n=n+1 -!----------------------------------------------------------------------- -! if(fft_south)then -!----------------------------------------------------------------------- -! do i=ids+1,ide-2 -! asu=un(i,jds+1,n)+asu -! asv=vn(i,jds+1,n)+asv -! enddo -! -! asu=asu*rcycle -! asv=asv*rcycle -! -! do i=ids,ide -! un(i,jds+1,n)=un(i,jds+1,n)-asu -! vn(i,jds+1,n)=vn(i,jds+1,n)-asv -! enddo -!----------------------------------------------------------------------- -! elseif(fft_north)then -!----------------------------------------------------------------------- -! do i=ids+1,ide-2 -! anu=un(i,jde-2,n)+anu -! anv=vn(i,jde-2,n)+anv -! enddo -! -! anu=anu*rcycle -! anv=anv*rcycle -! -! do i=ids,ide -! un(i,jde-2,n)=un(i,jde-2,n)-anu -! vn(i,jde-2,n)=vn(i,jde-2,n)-anv -! enddo -!----------------------------------------------------------------------- -! endif -!----------------------------------------------------------------------- -! -! enddo kloop1 -! -!----------------------------------------------------------------------- -!*** jstart and jend are the starting/ending rows on which this task -!*** will apply FFTs -!----------------------------------------------------------------------- -! - jstart=max(my_jrow_start_v(mype),jds+1) - jend=min(my_jrow_end_v(mype),jde-2) -! -!----------------------------------------------------------------------- -! - n=0 - kloop: do l=k1,k2 -! - n=n+1 -! - do j=jstart,jend -!----------------------------------------------------------------------- - if(kvfilt(j).le.icycle) then -!----------------------------------------------------------------------- - do i=ids+1,ide-2 - buffu(i-1)=un(i,j,n) - buffv(i-1)=vn(i,j,n) - enddo -! - call rfftf(icycle,buffu,wfftrw,nfftrw) - call rfftf(icycle,buffv,wfftrw,nfftrw) -! - do i=1,kvfilt(j)-1 - buffu(i)=buffu(i)*vfilt(i,j) - buffv(i)=buffv(i)*vfilt(i,j) - enddo - do i=kvfilt(j),icycle - buffu(i)=0. - buffv(i)=0. - enddo -! - call rfftb(icycle,buffu,wfftrw,nfftrw) - call rfftb(icycle,buffv,wfftrw,nfftrw) -! - do i=ids+1,ide-2 - un(i,j,n)=buffu(i-1) - vn(i,j,n)=buffv(i-1) - enddo -! - un(ide-1,j,n)=buffu(1) - vn(ide-1,j,n)=buffv(1) -!----------------------------------------------------------------------- - endif -!----------------------------------------------------------------------- - enddo -!----------------------------------------------------------------------- - enddo kloop -!----------------------------------------------------------------------- -!*** Now scatter the model layer data from full latitude circles -!*** back to the appropriate tasks. -!----------------------------------------------------------------------- -! - call scatter_layers(un,km,npes,msize_dummy_fft & - ,lm_fft,k1_fft,k2_fft & - ,local_istart,local_iend & - ,local_jstart,local_jend & - ,my_jrow_start_v(mype),my_jrow_end_v(mype) & - ,my_jrow_start_v,my_jrow_end_v & - ,ipe_start,ipe_end & - ,my_domain_has_fft_lats_v & - ,mype,mpi_comm_comp & - ,its,ite,ims,ime,ids,ide,jts,jte,jms,jme & - ,u) - call scatter_layers(vn,km,npes,msize_dummy_fft & - ,lm_fft,k1_fft,k2_fft & - ,local_istart,local_iend & - ,local_jstart,local_jend & - ,my_jrow_start_v(mype),my_jrow_end_v(mype) & - ,my_jrow_start_v,my_jrow_end_v & - ,ipe_start,ipe_end & - ,my_domain_has_fft_lats_v & - ,mype,mpi_comm_comp & - ,its,ite,ims,ime,ids,ide,jts,jte,jms,jme & - ,v) -! -!----------------------------------------------------------------------- -! - endsubroutine fftfuvn -! -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -! subroutine rffti(n,wsave,nsave) -! -! SUBROUTINE RFFTI INITIALIZES THE ARRAY WSAVE WHICH IS USED IN -! BOTH RFFTF AND RFFTB. THE PRIME FACTORIZATION OF N TOGETHER WITH -! A TABULATION OF THE TRIGONOMETRIC FUNCTIONS ARE COMPUTED AND -! STORED IN WSAVE. -! -! INPUT PARAMETER -! -! N THE LENGTH OF THE SEQUENCE TO BE TRANSFORMED. -! -! OUTPUT PARAMETER -! -! WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 2*N+15. -! THE SAME WORK ARRAY CAN BE USED FOR BOTH RFFTF AND RFFTB -! AS LONG AS N REMAINS UNCHANGED. DIFFERENT WSAVE ARRAYS -! ARE REQUIRED FOR DIFFERENT VALUES OF N. THE CONTENTS OF -! WSAVE MUST NOT BE CHANGED BETWEEN CALLS OF RFFTF OR RFFTB. -! - subroutine rffti (n,wsave,nsave) - dimension wsave(*),nsave(*) -! - if (n .eq. 1) return - call rffti1 (n,wsave(n+1),nsave) - return - endsubroutine rffti -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - SUBROUTINE RFFTI1 (N,WA,IFAC) - DIMENSION WA(*) ,IFAC(*) ,NTRYH(4) - DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/ - NL = N - NF = 0 - J = 0 - 101 J = J+1 - if(j.le.4) then - ntry=ntryh(j) - else - ntry=ntry+2 - endif - 104 NQ = NL/NTRY - NR = NL-NTRY*NQ - if(nr.ne.0) go to 101 - nf=nf+1 - IFAC(NF+2) = NTRY - NL = NQ - IF (NTRY .NE. 2) GO TO 107 - IF (NF .EQ. 1) GO TO 107 - DO 106 I=2,NF - IB = NF-I+2 - IFAC(IB+2) = IFAC(IB+1) - 106 CONTINUE - IFAC(3) = 2 - 107 IF (NL .NE. 1) GO TO 104 - IFAC(1) = N - IFAC(2) = NF -! TPI = 2.0*3.141592653589793238462643383279502884197169399375105820 - ARGH = TPI/FLOAT(N) - IS = 0 - NFM1 = NF-1 - L1 = 1 - IF (NFM1 .EQ. 0) RETURN - DO 110 K1=1,NFM1 - IP = IFAC(K1+2) - LD = 0 - L2 = L1*IP - IDO = N/L2 - IPM = IP-1 - DO 109 J=1,IPM - LD = LD+L1 - I = IS - ARGLD = FLOAT(LD)*ARGH - FI = 0. - DO 108 II=3,IDO,2 - I = I+2 - FI = FI+1. - ARG = FI*ARGLD - WA(I-1) = COS(ARG) - WA(I) = SIN(ARG) - 108 CONTINUE - IS = IS+IDO - 109 CONTINUE - L1 = L2 - 110 CONTINUE - RETURN - endsubroutine -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! subroutine rfftf(n,r,wsave,nsave) -! -! SUBROUTINE RFFTF COMPUTES THE FOURIER COEFFICIENTS OF A REAL -! PERODI! SEQUENCE (FOURIER ANALYSIS). THE TRANSFORM IS DEFINED -! BELOW AT OUTPUT PARAMETER R. -! -! INPUT PARAMETERS -! -! N THE LENGTH OF THE ARRAY R TO BE TRANSFORMED. THE METHOD -! IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES. -! N MAY CHANGE SO LONG AS DIFFERENT WORK ARRAYS ARE PROVIDED -! -! R A REAL ARRAY OF LENGTH N WHICH CONTAINS THE SEQUENCE -! TO BE TRANSFORMED -! -! WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 2*N+15. -! IN THE PROGRAM THAT CALLS RFFTF. THE WSAVE ARRAY MUST BE -! INITIALIZED BY CALLING SUBROUTINE RFFTI(N,WSAVE) AND A -! DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT -! VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE -! REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT -! TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST. -! THE SAME WSAVE ARRAY CAN BE USED BY RFFTF AND RFFTB. -! -! -! OUTPUT PARAMETERS -! -! R R(1) = THE SUM FROM I=1 TO I=N OF R(I) -! -! IF N IS EVEN SET L =N/2 , IF N IS ODD SET L = (N+1)/2 -! -! THEN FOR K = 2,...,L -! -! R(2*K-2) = THE SUM FROM I = 1 TO I = N OF -! -! R(I)*COS((K-1)*(I-1)*2*PI/N) -! -! R(2*K-1) = THE SUM FROM I = 1 TO I = N OF -! -! -R(I)*SIN((K-1)*(I-1)*2*PI/N) -! -! IF N IS EVEN -! -! R(N) = THE SUM FROM I = 1 TO I = N OF -! -! (-1)**(I-1)*R(I) -! -! ***** NOTE -! THIS TRANSFORM IS UNNORMALIZED SINCE A CALL OF RFFTF -! FOLLOWED BY A CALL OF RFFTB WILL MULTIPLY THE INPUT -! SEQUENCE BY N. -! -! WSAVE CONTAINS RESULTS WHICH MUST NOT BE DESTROYED BETWEEN -! CALLS OF RFFTF OR RFFTB. -! - subroutine rfftf (n,r,wsave,nsave) - dimension r(*),wsave(*),nsave(*) -! - if (n .eq. 1) return - call rfftf1 (n,r,wsave,wsave(n+1),nsave) - return - endsubroutine rfftf -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - SUBROUTINE RFFTF1 (N,C,CH,WA,IFAC) - DIMENSION CH(*) ,C(*) ,WA(*) ,IFAC(*) - NF = IFAC(2) - NA = 1 - L2 = N - IW = N - DO 111 K1=1,NF - KH = NF-K1 - IP = IFAC(KH+3) - L1 = L2/IP - IDO = N/L2 - IDL1 = IDO*L1 - IW = IW-(IP-1)*IDO - NA = 1-NA - IF (IP .NE. 4) GO TO 102 - IX2 = IW+IDO - IX3 = IX2+IDO - IF (NA .NE. 0) GO TO 101 - CALL RADF4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) - GO TO 110 - 101 CALL RADF4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) - GO TO 110 - 102 IF (IP .NE. 2) GO TO 104 - IF (NA .NE. 0) GO TO 103 - CALL RADF2 (IDO,L1,C,CH,WA(IW)) - GO TO 110 - 103 CALL RADF2 (IDO,L1,CH,C,WA(IW)) - GO TO 110 - 104 IF (IP .NE. 3) GO TO 106 - IX2 = IW+IDO - IF (NA .NE. 0) GO TO 105 - CALL RADF3 (IDO,L1,C,CH,WA(IW),WA(IX2)) - GO TO 110 - 105 CALL RADF3 (IDO,L1,CH,C,WA(IW),WA(IX2)) - GO TO 110 - 106 IF (IP .NE. 5) GO TO 108 - IX2 = IW+IDO - IX3 = IX2+IDO - IX4 = IX3+IDO - IF (NA .NE. 0) GO TO 107 - CALL RADF5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) - GO TO 110 - 107 CALL RADF5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) - GO TO 110 - 108 IF (IDO .EQ. 1) NA = 1-NA - IF (NA .NE. 0) GO TO 109 - CALL RADFG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) - NA = 1 - GO TO 110 - 109 CALL RADFG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) - NA = 0 - 110 L2 = L1 - 111 CONTINUE - IF (NA .EQ. 1) RETURN - DO 112 I=1,N - C(I) = CH(I) - 112 CONTINUE - RETURN - endsubroutine -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - SUBROUTINE RADF2 (IDO,L1,CC,CH,WA1) - DIMENSION CH(IDO,2,L1) ,CC(IDO,L1,2) , & - WA1(*) - DO 101 K=1,L1 - CH(1,1,K) = CC(1,K,1)+CC(1,K,2) - CH(IDO,2,K) = CC(1,K,1)-CC(1,K,2) - 101 CONTINUE - IF (IDO-2) 107,105,102 - 102 IDP2 = IDO+2 - DO 104 K=1,L1 - DO 103 I=3,IDO,2 - IC = IDP2-I - TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) - TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) - CH(I,1,K) = CC(I,K,1)+TI2 - CH(IC,2,K) = TI2-CC(I,K,1) - CH(I-1,1,K) = CC(I-1,K,1)+TR2 - CH(IC-1,2,K) = CC(I-1,K,1)-TR2 - 103 CONTINUE - 104 CONTINUE - IF (MOD(IDO,2) .EQ. 1) RETURN - 105 DO 106 K=1,L1 - CH(1,2,K) = -CC(IDO,K,2) - CH(IDO,1,K) = CC(IDO,K,1) - 106 CONTINUE - 107 RETURN - endsubroutine -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - SUBROUTINE RADF3 (IDO,L1,CC,CH,WA1,WA2) - DIMENSION CH(IDO,3,L1) ,CC(IDO,L1,3) , & - WA1(*) ,WA2(*) - DATA TAUR,TAUI /-.5,.866025403784439/ - DO 101 K=1,L1 - CR2 = CC(1,K,2)+CC(1,K,3) - CH(1,1,K) = CC(1,K,1)+CR2 - CH(1,3,K) = TAUI*(CC(1,K,3)-CC(1,K,2)) - CH(IDO,2,K) = CC(1,K,1)+TAUR*CR2 - 101 CONTINUE - IF (IDO .EQ. 1) RETURN - IDP2 = IDO+2 - DO 103 K=1,L1 - DO 102 I=3,IDO,2 - IC = IDP2-I - DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) - DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) - DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) - DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) - CR2 = DR2+DR3 - CI2 = DI2+DI3 - CH(I-1,1,K) = CC(I-1,K,1)+CR2 - CH(I,1,K) = CC(I,K,1)+CI2 - TR2 = CC(I-1,K,1)+TAUR*CR2 - TI2 = CC(I,K,1)+TAUR*CI2 - TR3 = TAUI*(DI2-DI3) - TI3 = TAUI*(DR3-DR2) - CH(I-1,3,K) = TR2+TR3 - CH(IC-1,2,K) = TR2-TR3 - CH(I,3,K) = TI2+TI3 - CH(IC,2,K) = TI3-TI2 - 102 CONTINUE - 103 CONTINUE - RETURN - endsubroutine -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - SUBROUTINE RADF4 (IDO,L1,CC,CH,WA1,WA2,WA3) - DIMENSION CC(IDO,L1,4) ,CH(IDO,4,L1) , & - WA1(*) ,WA2(*) ,WA3(*) - DATA HSQT2 /.7071067811865475/ - DO 101 K=1,L1 - TR1 = CC(1,K,2)+CC(1,K,4) - TR2 = CC(1,K,1)+CC(1,K,3) - CH(1,1,K) = TR1+TR2 - CH(IDO,4,K) = TR2-TR1 - CH(IDO,2,K) = CC(1,K,1)-CC(1,K,3) - CH(1,3,K) = CC(1,K,4)-CC(1,K,2) - 101 CONTINUE - IF (IDO-2) 107,105,102 - 102 IDP2 = IDO+2 - DO 104 K=1,L1 - DO 103 I=3,IDO,2 - IC = IDP2-I - CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) - CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) - CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) - CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) - CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) - CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) - TR1 = CR2+CR4 - TR4 = CR4-CR2 - TI1 = CI2+CI4 - TI4 = CI2-CI4 - TI2 = CC(I,K,1)+CI3 - TI3 = CC(I,K,1)-CI3 - TR2 = CC(I-1,K,1)+CR3 - TR3 = CC(I-1,K,1)-CR3 - CH(I-1,1,K) = TR1+TR2 - CH(IC-1,4,K) = TR2-TR1 - CH(I,1,K) = TI1+TI2 - CH(IC,4,K) = TI1-TI2 - CH(I-1,3,K) = TI4+TR3 - CH(IC-1,2,K) = TR3-TI4 - CH(I,3,K) = TR4+TI3 - CH(IC,2,K) = TR4-TI3 - 103 CONTINUE - 104 CONTINUE - IF (MOD(IDO,2) .EQ. 1) RETURN - 105 CONTINUE - DO 106 K=1,L1 - TI1 = -HSQT2*(CC(IDO,K,2)+CC(IDO,K,4)) - TR1 = HSQT2*(CC(IDO,K,2)-CC(IDO,K,4)) - CH(IDO,1,K) = TR1+CC(IDO,K,1) - CH(IDO,3,K) = CC(IDO,K,1)-TR1 - CH(1,2,K) = TI1-CC(IDO,K,3) - CH(1,4,K) = TI1+CC(IDO,K,3) - 106 CONTINUE - 107 RETURN - endsubroutine -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - SUBROUTINE RADF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) - DIMENSION CC(IDO,L1,5) ,CH(IDO,5,L1) , & - WA1(*) ,WA2(*) ,WA3(*) ,WA4(*) - DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154, & - -.809016994374947,.587785252292473/ - DO 101 K=1,L1 - CR2 = CC(1,K,5)+CC(1,K,2) - CI5 = CC(1,K,5)-CC(1,K,2) - CR3 = CC(1,K,4)+CC(1,K,3) - CI4 = CC(1,K,4)-CC(1,K,3) - CH(1,1,K) = CC(1,K,1)+CR2+CR3 - CH(IDO,2,K) = CC(1,K,1)+TR11*CR2+TR12*CR3 - CH(1,3,K) = TI11*CI5+TI12*CI4 - CH(IDO,4,K) = CC(1,K,1)+TR12*CR2+TR11*CR3 - CH(1,5,K) = TI12*CI5-TI11*CI4 - 101 CONTINUE - IF (IDO .EQ. 1) RETURN - IDP2 = IDO+2 - DO 103 K=1,L1 - DO 102 I=3,IDO,2 - IC = IDP2-I - DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) - DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) - DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) - DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) - DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) - DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) - DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5) - DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5) - CR2 = DR2+DR5 - CI5 = DR5-DR2 - CR5 = DI2-DI5 - CI2 = DI2+DI5 - CR3 = DR3+DR4 - CI4 = DR4-DR3 - CR4 = DI3-DI4 - CI3 = DI3+DI4 - CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3 - CH(I,1,K) = CC(I,K,1)+CI2+CI3 - TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3 - TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3 - TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3 - TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3 - TR5 = TI11*CR5+TI12*CR4 - TI5 = TI11*CI5+TI12*CI4 - TR4 = TI12*CR5-TI11*CR4 - TI4 = TI12*CI5-TI11*CI4 - CH(I-1,3,K) = TR2+TR5 - CH(IC-1,2,K) = TR2-TR5 - CH(I,3,K) = TI2+TI5 - CH(IC,2,K) = TI5-TI2 - CH(I-1,5,K) = TR3+TR4 - CH(IC-1,4,K) = TR3-TR4 - CH(I,5,K) = TI3+TI4 - CH(IC,4,K) = TI4-TI3 - 102 CONTINUE - 103 CONTINUE - RETURN - endsubroutine -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - SUBROUTINE RADFG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) - DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , & - C1(IDO,L1,IP) ,C2(IDL1,IP), & - CH2(IDL1,IP) ,WA(*) -! TPI = 2.0*3.141592653589793238462643383279502884197169399375105820 - ARG = TPI/FLOAT(IP) - DCP = COS(ARG) - DSP = SIN(ARG) - IPPH = (IP+1)/2 - IPP2 = IP+2 - IDP2 = IDO+2 - NBD = (IDO-1)/2 - IF (IDO .EQ. 1) GO TO 119 - DO 101 IK=1,IDL1 - CH2(IK,1) = C2(IK,1) - 101 CONTINUE - DO 103 J=2,IP - DO 102 K=1,L1 - CH(1,K,J) = C1(1,K,J) - 102 CONTINUE - 103 CONTINUE - IF (NBD .GT. L1) GO TO 107 - IS = -IDO - DO 106 J=2,IP - IS = IS+IDO - IDIJ = IS - DO 105 I=3,IDO,2 - IDIJ = IDIJ+2 - DO 104 K=1,L1 - CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J) - CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J) - 104 CONTINUE - 105 CONTINUE - 106 CONTINUE - GO TO 111 - 107 IS = -IDO - DO 110 J=2,IP - IS = IS+IDO - DO 109 K=1,L1 - IDIJ = IS - DO 108 I=3,IDO,2 - IDIJ = IDIJ+2 - CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J) - CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J) - 108 CONTINUE - 109 CONTINUE - 110 CONTINUE - 111 IF (NBD .LT. L1) GO TO 115 - DO 114 J=2,IPPH - JC = IPP2-J - DO 113 K=1,L1 - DO 112 I=3,IDO,2 - C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC) - C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC) - C1(I,K,J) = CH(I,K,J)+CH(I,K,JC) - C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J) - 112 CONTINUE - 113 CONTINUE - 114 CONTINUE - GO TO 121 - 115 DO 118 J=2,IPPH - JC = IPP2-J - DO 117 I=3,IDO,2 - DO 116 K=1,L1 - C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC) - C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC) - C1(I,K,J) = CH(I,K,J)+CH(I,K,JC) - C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J) - 116 CONTINUE - 117 CONTINUE - 118 CONTINUE - GO TO 121 - 119 DO 120 IK=1,IDL1 - C2(IK,1) = CH2(IK,1) - 120 CONTINUE - 121 DO 123 J=2,IPPH - JC = IPP2-J - DO 122 K=1,L1 - C1(1,K,J) = CH(1,K,J)+CH(1,K,JC) - C1(1,K,JC) = CH(1,K,JC)-CH(1,K,J) - 122 CONTINUE - 123 CONTINUE -! - AR1 = 1. - AI1 = 0. - DO 127 L=2,IPPH - LC = IPP2-L - AR1H = DCP*AR1-DSP*AI1 - AI1 = DCP*AI1+DSP*AR1 - AR1 = AR1H - DO 124 IK=1,IDL1 - CH2(IK,L) = C2(IK,1)+AR1*C2(IK,2) - CH2(IK,LC) = AI1*C2(IK,IP) - 124 CONTINUE - DC2 = AR1 - DS2 = AI1 - AR2 = AR1 - AI2 = AI1 - DO 126 J=3,IPPH - JC = IPP2-J - AR2H = DC2*AR2-DS2*AI2 - AI2 = DC2*AI2+DS2*AR2 - AR2 = AR2H - DO 125 IK=1,IDL1 - CH2(IK,L) = CH2(IK,L)+AR2*C2(IK,J) - CH2(IK,LC) = CH2(IK,LC)+AI2*C2(IK,JC) - 125 CONTINUE - 126 CONTINUE - 127 CONTINUE - DO 129 J=2,IPPH - DO 128 IK=1,IDL1 - CH2(IK,1) = CH2(IK,1)+C2(IK,J) - 128 CONTINUE - 129 CONTINUE -! - IF (IDO .LT. L1) GO TO 132 - DO 131 K=1,L1 - DO 130 I=1,IDO - CC(I,1,K) = CH(I,K,1) - 130 CONTINUE - 131 CONTINUE - GO TO 135 - 132 DO 134 I=1,IDO - DO 133 K=1,L1 - CC(I,1,K) = CH(I,K,1) - 133 CONTINUE - 134 CONTINUE - 135 DO 137 J=2,IPPH - JC = IPP2-J - J2 = J+J - DO 136 K=1,L1 - CC(IDO,J2-2,K) = CH(1,K,J) - CC(1,J2-1,K) = CH(1,K,JC) - 136 CONTINUE - 137 CONTINUE - IF (IDO .EQ. 1) RETURN - IF (NBD .LT. L1) GO TO 141 - DO 140 J=2,IPPH - JC = IPP2-J - J2 = J+J - DO 139 K=1,L1 - DO 138 I=3,IDO,2 - IC = IDP2-I - CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC) - CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC) - CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC) - CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J) - 138 CONTINUE - 139 CONTINUE - 140 CONTINUE - RETURN - 141 DO 144 J=2,IPPH - JC = IPP2-J - J2 = J+J - DO 143 I=3,IDO,2 - IC = IDP2-I - DO 142 K=1,L1 - CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC) - CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC) - CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC) - CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J) - 142 CONTINUE - 143 CONTINUE - 144 CONTINUE - RETURN - endsubroutine -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! subroutine rfftb(n,r,wsave,nsave) -! -! SUBROUTINE RFFTB COMPUTES THE REAL PERODIC SEQUENCE FROM ITS -! FOURIER COEFFICIENTS (FOURIER SYNTHESIS). THE TRANSFORM IS DEFINED -! BELOW AT OUTPUT PARAMETER R. -! -! INPUT PARAMETERS -! -! N THE LENGTH OF THE ARRAY R TO BE TRANSFORMED. THE METHOD -! IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES. -! N MAY CHANGE SO LONG AS DIFFERENT WORK ARRAYS ARE PROVIDED -! -! R A REAL ARRAY OF LENGTH N WHICH CONTAINS THE SEQUENCE -! TO BE TRANSFORMED -! -! WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 2*N+15. -! IN THE PROGRAM THAT CALLS RFFTB. THE WSAVE ARRAY MUST BE -! INITIALIZED BY CALLING SUBROUTINE RFFTI(N,WSAVE) AND A -! DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT -! VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE -! REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT -! TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST. -! THE SAME WSAVE ARRAY CAN BE USED BY RFFTF AND RFFTB. -! -! -! OUTPUT PARAMETERS -! -! R FOR N EVEN AND FOR I = 1,...,N -! -! R(I) = R(1)+(-1)**(I-1)*R(N) -! -! PLUS THE SUM FROM K=2 TO K=N/2 OF -! -! 2.*R(2*K-2)*COS((K-1)*(I-1)*2*PI/N) -! -! -2.*R(2*K-1)*SIN((K-1)*(I-1)*2*PI/N) -! -! FOR N ODD AND FOR I = 1,...,N -! -! R(I) = R(1) PLUS THE SUM FROM K=2 TO K=(N+1)/2 OF -! -! 2.*R(2*K-2)*COS((K-1)*(I-1)*2*PI/N) -! -! -2.*R(2*K-1)*SIN((K-1)*(I-1)*2*PI/N) -! -! ***** NOTE -! THIS TRANSFORM IS UNNORMALIZED SINCE A CALL OF RFFTF -! FOLLOWED BY A CALL OF RFFTB WILL MULTIPLY THE INPUT -! SEQUENCE BY N. -! -! WSAVE CONTAINS RESULTS WHICH MUST NOT BE DESTROYED BETWEEN -! CALLS OF RFFTB OR RFFTF. -! -! - subroutine rfftb (n,r,wsave,nsave) - dimension r(*),wsave(*),nsave(*) -! - if (n .eq. 1) return - call rfftb1 (n,r,wsave,wsave(n+1),nsave) - return - endsubroutine rfftb -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - SUBROUTINE RFFTB1 (N,C,CH,WA,IFAC) - DIMENSION CH(*) ,C(*) ,WA(*) ,IFAC(*) - NF = IFAC(2) - NA = 0 - L1 = 1 - IW = 1 - DO 116 K1=1,NF - IP = IFAC(K1+2) - L2 = IP*L1 - IDO = N/L2 - IDL1 = IDO*L1 - IF (IP .NE. 4) GO TO 103 - IX2 = IW+IDO - IX3 = IX2+IDO - IF (NA .NE. 0) GO TO 101 - CALL RADB4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) - GO TO 102 - 101 CALL RADB4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) - 102 NA = 1-NA - GO TO 115 - 103 IF (IP .NE. 2) GO TO 106 - IF (NA .NE. 0) GO TO 104 - CALL RADB2 (IDO,L1,C,CH,WA(IW)) - GO TO 105 - 104 CALL RADB2 (IDO,L1,CH,C,WA(IW)) - 105 NA = 1-NA - GO TO 115 - 106 IF (IP .NE. 3) GO TO 109 - IX2 = IW+IDO - IF (NA .NE. 0) GO TO 107 - CALL RADB3 (IDO,L1,C,CH,WA(IW),WA(IX2)) - GO TO 108 - 107 CALL RADB3 (IDO,L1,CH,C,WA(IW),WA(IX2)) - 108 NA = 1-NA - GO TO 115 - 109 IF (IP .NE. 5) GO TO 112 - IX2 = IW+IDO - IX3 = IX2+IDO - IX4 = IX3+IDO - IF (NA .NE. 0) GO TO 110 - CALL RADB5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) - GO TO 111 - 110 CALL RADB5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) - 111 NA = 1-NA - GO TO 115 - 112 IF (NA .NE. 0) GO TO 113 - CALL RADBG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) - GO TO 114 - 113 CALL RADBG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) - 114 IF (IDO .EQ. 1) NA = 1-NA - 115 L1 = L2 - IW = IW+(IP-1)*IDO - 116 CONTINUE - IF (NA .EQ. 0) RETURN - DO 117 I=1,N - C(I) = CH(I) - 117 CONTINUE - RETURN - endsubroutine -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - SUBROUTINE RADB2 (IDO,L1,CC,CH,WA1) - DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2) , & - WA1(*) - DO 101 K=1,L1 - CH(1,K,1) = CC(1,1,K)+CC(IDO,2,K) - CH(1,K,2) = CC(1,1,K)-CC(IDO,2,K) - 101 CONTINUE - IF (IDO-2) 107,105,102 - 102 IDP2 = IDO+2 - DO 104 K=1,L1 - DO 103 I=3,IDO,2 - IC = IDP2-I - CH(I-1,K,1) = CC(I-1,1,K)+CC(IC-1,2,K) - TR2 = CC(I-1,1,K)-CC(IC-1,2,K) - CH(I,K,1) = CC(I,1,K)-CC(IC,2,K) - TI2 = CC(I,1,K)+CC(IC,2,K) - CH(I-1,K,2) = WA1(I-2)*TR2-WA1(I-1)*TI2 - CH(I,K,2) = WA1(I-2)*TI2+WA1(I-1)*TR2 - 103 CONTINUE - 104 CONTINUE - IF (MOD(IDO,2) .EQ. 1) RETURN - 105 DO 106 K=1,L1 - CH(IDO,K,1) = CC(IDO,1,K)+CC(IDO,1,K) - CH(IDO,K,2) = -(CC(1,2,K)+CC(1,2,K)) - 106 CONTINUE - 107 RETURN - endsubroutine -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - SUBROUTINE RADB3 (IDO,L1,CC,CH,WA1,WA2) - DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3) , & - WA1(*) ,WA2(*) - DATA TAUR,TAUI /-.5,.866025403784439/ - DO 101 K=1,L1 - TR2 = CC(IDO,2,K)+CC(IDO,2,K) - CR2 = CC(1,1,K)+TAUR*TR2 - CH(1,K,1) = CC(1,1,K)+TR2 - CI3 = TAUI*(CC(1,3,K)+CC(1,3,K)) - CH(1,K,2) = CR2-CI3 - CH(1,K,3) = CR2+CI3 - 101 CONTINUE - IF (IDO .EQ. 1) RETURN - IDP2 = IDO+2 - DO 103 K=1,L1 - DO 102 I=3,IDO,2 - IC = IDP2-I - TR2 = CC(I-1,3,K)+CC(IC-1,2,K) - CR2 = CC(I-1,1,K)+TAUR*TR2 - CH(I-1,K,1) = CC(I-1,1,K)+TR2 - TI2 = CC(I,3,K)-CC(IC,2,K) - CI2 = CC(I,1,K)+TAUR*TI2 - CH(I,K,1) = CC(I,1,K)+TI2 - CR3 = TAUI*(CC(I-1,3,K)-CC(IC-1,2,K)) - CI3 = TAUI*(CC(I,3,K)+CC(IC,2,K)) - DR2 = CR2-CI3 - DR3 = CR2+CI3 - DI2 = CI2+CR3 - DI3 = CI2-CR3 - CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 - CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 - CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 - CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 - 102 CONTINUE - 103 CONTINUE - RETURN - endsubroutine -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - SUBROUTINE RADB4 (IDO,L1,CC,CH,WA1,WA2,WA3) - DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4) , & - WA1(*) ,WA2(*) ,WA3(*) - DATA SQRT2 /1.414213562373095/ - DO 101 K=1,L1 - TR1 = CC(1,1,K)-CC(IDO,4,K) - TR2 = CC(1,1,K)+CC(IDO,4,K) - TR3 = CC(IDO,2,K)+CC(IDO,2,K) - TR4 = CC(1,3,K)+CC(1,3,K) - CH(1,K,1) = TR2+TR3 - CH(1,K,2) = TR1-TR4 - CH(1,K,3) = TR2-TR3 - CH(1,K,4) = TR1+TR4 - 101 CONTINUE - IF (IDO-2) 107,105,102 - 102 IDP2 = IDO+2 - DO 104 K=1,L1 - DO 103 I=3,IDO,2 - IC = IDP2-I - TI1 = CC(I,1,K)+CC(IC,4,K) - TI2 = CC(I,1,K)-CC(IC,4,K) - TI3 = CC(I,3,K)-CC(IC,2,K) - TR4 = CC(I,3,K)+CC(IC,2,K) - TR1 = CC(I-1,1,K)-CC(IC-1,4,K) - TR2 = CC(I-1,1,K)+CC(IC-1,4,K) - TI4 = CC(I-1,3,K)-CC(IC-1,2,K) - TR3 = CC(I-1,3,K)+CC(IC-1,2,K) - CH(I-1,K,1) = TR2+TR3 - CR3 = TR2-TR3 - CH(I,K,1) = TI2+TI3 - CI3 = TI2-TI3 - CR2 = TR1-TR4 - CR4 = TR1+TR4 - CI2 = TI1+TI4 - CI4 = TI1-TI4 - CH(I-1,K,2) = WA1(I-2)*CR2-WA1(I-1)*CI2 - CH(I,K,2) = WA1(I-2)*CI2+WA1(I-1)*CR2 - CH(I-1,K,3) = WA2(I-2)*CR3-WA2(I-1)*CI3 - CH(I,K,3) = WA2(I-2)*CI3+WA2(I-1)*CR3 - CH(I-1,K,4) = WA3(I-2)*CR4-WA3(I-1)*CI4 - CH(I,K,4) = WA3(I-2)*CI4+WA3(I-1)*CR4 - 103 CONTINUE - 104 CONTINUE - IF (MOD(IDO,2) .EQ. 1) RETURN - 105 CONTINUE - DO 106 K=1,L1 - TI1 = CC(1,2,K)+CC(1,4,K) - TI2 = CC(1,4,K)-CC(1,2,K) - TR1 = CC(IDO,1,K)-CC(IDO,3,K) - TR2 = CC(IDO,1,K)+CC(IDO,3,K) - CH(IDO,K,1) = TR2+TR2 - CH(IDO,K,2) = SQRT2*(TR1-TI1) - CH(IDO,K,3) = TI2+TI2 - CH(IDO,K,4) = -SQRT2*(TR1+TI1) - 106 CONTINUE - 107 RETURN - endsubroutine -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - SUBROUTINE RADB5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) - DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5) , & - WA1(*) ,WA2(*) ,WA3(*) ,WA4(*) - DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154, & - -.809016994374947,.587785252292473/ - DO 101 K=1,L1 - TI5 = CC(1,3,K)+CC(1,3,K) - TI4 = CC(1,5,K)+CC(1,5,K) - TR2 = CC(IDO,2,K)+CC(IDO,2,K) - TR3 = CC(IDO,4,K)+CC(IDO,4,K) - CH(1,K,1) = CC(1,1,K)+TR2+TR3 - CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 - CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 - CI5 = TI11*TI5+TI12*TI4 - CI4 = TI12*TI5-TI11*TI4 - CH(1,K,2) = CR2-CI5 - CH(1,K,3) = CR3-CI4 - CH(1,K,4) = CR3+CI4 - CH(1,K,5) = CR2+CI5 - 101 CONTINUE - IF (IDO .EQ. 1) RETURN - IDP2 = IDO+2 - DO 103 K=1,L1 - DO 102 I=3,IDO,2 - IC = IDP2-I - TI5 = CC(I,3,K)+CC(IC,2,K) - TI2 = CC(I,3,K)-CC(IC,2,K) - TI4 = CC(I,5,K)+CC(IC,4,K) - TI3 = CC(I,5,K)-CC(IC,4,K) - TR5 = CC(I-1,3,K)-CC(IC-1,2,K) - TR2 = CC(I-1,3,K)+CC(IC-1,2,K) - TR4 = CC(I-1,5,K)-CC(IC-1,4,K) - TR3 = CC(I-1,5,K)+CC(IC-1,4,K) - CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 - CH(I,K,1) = CC(I,1,K)+TI2+TI3 - CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 - CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 - CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 - CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 - CR5 = TI11*TR5+TI12*TR4 - CI5 = TI11*TI5+TI12*TI4 - CR4 = TI12*TR5-TI11*TR4 - CI4 = TI12*TI5-TI11*TI4 - DR3 = CR3-CI4 - DR4 = CR3+CI4 - DI3 = CI3+CR4 - DI4 = CI3-CR4 - DR5 = CR2+CI5 - DR2 = CR2-CI5 - DI5 = CI2-CR5 - DI2 = CI2+CR5 - CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 - CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 - CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 - CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 - CH(I-1,K,4) = WA3(I-2)*DR4-WA3(I-1)*DI4 - CH(I,K,4) = WA3(I-2)*DI4+WA3(I-1)*DR4 - CH(I-1,K,5) = WA4(I-2)*DR5-WA4(I-1)*DI5 - CH(I,K,5) = WA4(I-2)*DI5+WA4(I-1)*DR5 - 102 CONTINUE - 103 CONTINUE - RETURN - endsubroutine -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - SUBROUTINE RADBG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) - DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , & - C1(IDO,L1,IP) ,C2(IDL1,IP), & - CH2(IDL1,IP) ,WA(*) -! TPI = 2.0*3.141592653589793238462643383279502884197169399375105820 - ARG = TPI/FLOAT(IP) - DCP = COS(ARG) - DSP = SIN(ARG) - IDP2 = IDO+2 - NBD = (IDO-1)/2 - IPP2 = IP+2 - IPPH = (IP+1)/2 - IF (IDO .LT. L1) GO TO 103 - DO 102 K=1,L1 - DO 101 I=1,IDO - CH(I,K,1) = CC(I,1,K) - 101 CONTINUE - 102 CONTINUE - GO TO 106 - 103 DO 105 I=1,IDO - DO 104 K=1,L1 - CH(I,K,1) = CC(I,1,K) - 104 CONTINUE - 105 CONTINUE - 106 DO 108 J=2,IPPH - JC = IPP2-J - J2 = J+J - DO 107 K=1,L1 - CH(1,K,J) = CC(IDO,J2-2,K)+CC(IDO,J2-2,K) - CH(1,K,JC) = CC(1,J2-1,K)+CC(1,J2-1,K) - 107 CONTINUE - 108 CONTINUE - IF (IDO .EQ. 1) GO TO 116 - IF (NBD .LT. L1) GO TO 112 - DO 111 J=2,IPPH - JC = IPP2-J - DO 110 K=1,L1 - DO 109 I=3,IDO,2 - IC = IDP2-I - CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K) - CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K) - CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K) - CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K) - 109 CONTINUE - 110 CONTINUE - 111 CONTINUE - GO TO 116 - 112 DO 115 J=2,IPPH - JC = IPP2-J - DO 114 I=3,IDO,2 - IC = IDP2-I - DO 113 K=1,L1 - CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K) - CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K) - CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K) - CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K) - 113 CONTINUE - 114 CONTINUE - 115 CONTINUE - 116 AR1 = 1. - AI1 = 0. - DO 120 L=2,IPPH - LC = IPP2-L - AR1H = DCP*AR1-DSP*AI1 - AI1 = DCP*AI1+DSP*AR1 - AR1 = AR1H - DO 117 IK=1,IDL1 - C2(IK,L) = CH2(IK,1)+AR1*CH2(IK,2) - C2(IK,LC) = AI1*CH2(IK,IP) - 117 CONTINUE - DC2 = AR1 - DS2 = AI1 - AR2 = AR1 - AI2 = AI1 - DO 119 J=3,IPPH - JC = IPP2-J - AR2H = DC2*AR2-DS2*AI2 - AI2 = DC2*AI2+DS2*AR2 - AR2 = AR2H - DO 118 IK=1,IDL1 - C2(IK,L) = C2(IK,L)+AR2*CH2(IK,J) - C2(IK,LC) = C2(IK,LC)+AI2*CH2(IK,JC) - 118 CONTINUE - 119 CONTINUE - 120 CONTINUE - DO 122 J=2,IPPH - DO 121 IK=1,IDL1 - CH2(IK,1) = CH2(IK,1)+CH2(IK,J) - 121 CONTINUE - 122 CONTINUE - DO 124 J=2,IPPH - JC = IPP2-J - DO 123 K=1,L1 - CH(1,K,J) = C1(1,K,J)-C1(1,K,JC) - CH(1,K,JC) = C1(1,K,J)+C1(1,K,JC) - 123 CONTINUE - 124 CONTINUE - IF (IDO .EQ. 1) GO TO 132 - IF (NBD .LT. L1) GO TO 128 - DO 127 J=2,IPPH - JC = IPP2-J - DO 126 K=1,L1 - DO 125 I=3,IDO,2 - CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC) - CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC) - CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC) - CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC) - 125 CONTINUE - 126 CONTINUE - 127 CONTINUE - GO TO 132 - 128 DO 131 J=2,IPPH - JC = IPP2-J - DO 130 I=3,IDO,2 - DO 129 K=1,L1 - CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC) - CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC) - CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC) - CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC) - 129 CONTINUE - 130 CONTINUE - 131 CONTINUE - 132 CONTINUE - IF (IDO .EQ. 1) RETURN - DO 133 IK=1,IDL1 - C2(IK,1) = CH2(IK,1) - 133 CONTINUE - DO 135 J=2,IP - DO 134 K=1,L1 - C1(1,K,J) = CH(1,K,J) - 134 CONTINUE - 135 CONTINUE - IF (NBD .GT. L1) GO TO 139 - IS = -IDO - DO 138 J=2,IP - IS = IS+IDO - IDIJ = IS - DO 137 I=3,IDO,2 - IDIJ = IDIJ+2 - DO 136 K=1,L1 - C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) - C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) - 136 CONTINUE - 137 CONTINUE - 138 CONTINUE - GO TO 143 - 139 IS = -IDO - DO 142 J=2,IP - IS = IS+IDO - DO 141 K=1,L1 - IDIJ = IS - DO 140 I=3,IDO,2 - IDIJ = IDIJ+2 - C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) - C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) - 140 CONTINUE - 141 CONTINUE - 142 CONTINUE - 143 RETURN - endsubroutine -! -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -! - subroutine presmud & -(dlmd,dphd,sbd & -,nhsmud) -!----------------------------------------------------------------------- -! - implicit none -!----------------------------------------------------------------------- - -integer(kind=kint),dimension(jms:jme),intent(out) :: & - nhsmud -! -real(kind=kfpt),intent(in) :: & - dlmd & -,dphd & -,sbd -! -!----------------------------------------------------------------------- -!*** Local variables -!----------------------------------------------------------------------- -integer(kind=kint) :: & - j -real(kind=kfpt) :: & - dlm & -,dph & -,sb & -,tph -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- - dlm=dlmd*dtr - dph=dphd*dtr - sb=sbd*dtr -!----------------------------------------------------------------------- - do j=jts_b2,jte_b2 - tph=sb+(j-jds-1)*dph - nhsmud(j)=.99*dph/(dlm*cos(tph)) - enddo -!----------------------------------------------------------------------- -! - endsubroutine presmud -! -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -! - subroutine poavhn & -(i_start,i_end,j_start,j_end,km,hn,inpes,jnpes & -,use_allreduce) -!----------------------------------------------------------------------- -! - implicit none -! -!----------------------------------------------------------------------- - -integer(kind=kint),intent(in) :: & - i_start & -,i_end & -,j_start & -,j_end & -,inpes & -,jnpes & -,km -! -real(kind=kfpt),dimension(i_start:i_end,j_start:j_end,km),intent(inout):: & - hn -! -logical(kind=klog),intent(in) :: & - use_allreduce -! -!----------------------------------------------------------------------- -!*** Local Variables -!----------------------------------------------------------------------- -! -integer(kind=kint) :: & - i & -,ierr & -,irecv & -,l & -,loc_its_b1 & -,loc_ite_b2 & -,loc_min & -,loc_max & -,n & -,num_pes & -,pe -! -integer,dimension(mpi_status_size) :: jstat -! -real(kind=kfpt) :: & - rcycle -! -real(kind=kfpt),dimension(ids+1:(ide-3)*km+1) :: & - hn_glob -! -real(kind=kfpt),dimension((ite_b2-its_b1+1)*km):: & - hn_loc -! -real(kind=kfpt),dimension(1:km) :: & - an & -,an_g & -,as & -,as_g - -integer(kind=kint) :: istat -logical(kind=klog) :: opened -logical(kind=klog),save :: sum_file_is_open=.false. -character(10) :: fstatus -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - num_pes=inpes*jnpes -! -!----------------------------------------------------------------------- -! - rcycle=1./(ide-3) - do l=1,km - as(l)=0. - an(l)=0. - enddo -! -!----------------------------------------------------------------------- -!*** Sum the values along the row north of the southern boundary. -!----------------------------------------------------------------------- -! - if(use_allreduce)then -! -!----------------------------------------------------------------------- -!*** Generate the global sum of the previous sums from each task -!*** using mpi_allreduce -!----------------------------------------------------------------------- -! - if(s_bdy)then - do l=1,km - do i=its_b1,ite_b2 - as(l)=hn(i,jts+1,l)+as(l) - enddo - enddo - endif -! - call mpi_allreduce(as,as_g,km,mpi_real,mpi_sum,mpi_comm_comp & - ,irecv) -! - else -! -!----------------------------------------------------------------------- -!*** Generate the global sum of the previous sums from each task -!*** using mpi_recv & mpi_send -!----------------------------------------------------------------------- -! - as_g(1:km)=0 - - if (mype==0) then - - do i=its_b1,ite_b2 - do l=1,km - n=its_b1+l-1+km*(i-its_b1) - hn_glob(n) = hn(i,jts+1,l) - enddo - enddo - - do pe=1,inpes-1 - loc_its_b1 = max(local_istart(pe),ids+1) - loc_ite_b2 = min(local_iend(pe),ide-2) - loc_min = (loc_its_b1-its_b1)*km+its_b1 - loc_max = loc_min + (loc_ite_b2-loc_its_b1+1)*km-1 - call mpi_recv(hn_glob(loc_min:loc_max),(loc_max-loc_min+1) & - ,mpi_real,pe,pe,mpi_comm_comp,jstat,ierr) - end do - - do i=ids+1,ide-2 - do l=1,km - n=ids+1+l-1+km*(i-ids-1) - as_g(l) = hn_glob(n) + as_g(l) - enddo - end do - - else - - if(s_bdy)then - - n=0 - do i=its_b1,ite_b2 - do l=1,km - n=n+1 - hn_loc(n)=hn(i,jts+1,l) - enddo - enddo - - call mpi_send(hn_loc(1:(ite_b2-its_b1+1)*km),(ite_b2-its_b1+1)*km & - ,mpi_real, 0, mype, mpi_comm_comp, ierr) - - endif - endif - - call mpi_bcast (as_g,km,mpi_real,0,mpi_comm_comp,ierr) -! - endif -! -!----------------------------------------------------------------------- -!*** Reset the array values in that same row to the global sum. -!----------------------------------------------------------------------- -! - if(s_bdy)then - do l=1,km - as(l)=as_g(l)*rcycle - do i=its,ite - hn(i,jts+1,l)=as(l) - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** Now sum the values along the row south of the northern boundary. -!----------------------------------------------------------------------- -! - if(use_allreduce)then -! -!----------------------------------------------------------------------- -!*** Generate the global sum of the previous sums from each task -!*** using mpi_allreduce -!----------------------------------------------------------------------- -! - if(n_bdy)then - do l=1,km - do i=its_b1,ite_b2 - an(l)=hn(i,jte-1,l)+an(l) - enddo - enddo - endif -! - call mpi_allreduce(an,an_g,km,mpi_real,mpi_sum,mpi_comm_comp & - ,irecv) -! - else -! -!----------------------------------------------------------------------- -!*** Generate the global sum of the previous sums from each task -!*** using mpi_recv & mpi_send -!----------------------------------------------------------------------- - - an_g(1:km)=0 - - if (mype==num_pes-inpes) then - - do i=its_b1,ite_b2 - do l=1,km - n=its_b1+l-1+km*(i-its_b1) - hn_glob(n) = hn(i,jte-1,l) - enddo - enddo - - do pe=num_pes-inpes+1,num_pes-1 - loc_its_b1 = max(local_istart(pe),ids+1) - loc_ite_b2 = min(local_iend(pe),ide-2) - loc_min = (loc_its_b1-its_b1)*km+its_b1 - loc_max = loc_min + (loc_ite_b2-loc_its_b1+1)*km-1 - call mpi_recv(hn_glob(loc_min:loc_max),(loc_max-loc_min+1) & - ,mpi_real,pe,pe,mpi_comm_comp,jstat,ierr) - end do - - do i=ids+1,ide-2 - do l=1,km - n=ids+1+l-1+km*(i-ids-1) - an_g(l) = hn_glob(n) + an_g(l) - enddo - end do - - else - - if(n_bdy)then - - n=0 - do i=its_b1,ite_b2 - do l=1,km - n=n+1 - hn_loc(n)=hn(i,jte-1,l) - enddo - enddo - - call mpi_send(hn_loc(1:(ite_b2-its_b1+1)*km),(ite_b2-its_b1+1)*km & - ,mpi_real, num_pes-inpes, mype, mpi_comm_comp, ierr) - - endif - endif - - call mpi_bcast (an_g,km,mpi_real,num_pes-inpes,mpi_comm_comp,ierr) - - - endif -! -!----------------------------------------------------------------------- -!*** Reset the array values in that same row to the global sum. -!----------------------------------------------------------------------- -! - if(n_bdy)then - do l=1,km - an(l)=an_g(l)*rcycle - do i=its,ite - hn(i,jte-1,l)=an(l) - enddo - enddo - endif -! -!----------------------------------------------------------------------- -! - endsubroutine poavhn -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - subroutine swaphn & -(hn,i_start,i_end,j_start,j_end,km,inpes) -! -!----------------------------------------------------------------------- -! - implicit none -! -!----------------------------------------------------------------------- - -integer(kind=kint),intent(in) :: & - i_start & -,i_end & -,j_start & -,j_end & -,km & -,inpes -! -real(kind=kfpt),dimension(i_start:i_end,j_start:j_end,km),intent(inout):: & - hn -! -!----------------------------------------------------------------------- -!*** Local Variables -!----------------------------------------------------------------------- -integer(kind=kint) :: & - irecv & -,isend & -,j & -,l & -,length & -,ntask -! -integer(kind=kint),dimension(mpi_status_size) :: & - jstat -! -real(kind=kfpt) :: & - ave - -real(kind=kfpt),dimension(2,jts_h1:jte_h1,km) :: & - eastx & -,westx -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Each task along the eastern and western "boundaries" needs to -!*** exchange with its counterpart on the opposite side. -! -!*** What is being said here is that i=1 (west) and i=ite-2 (east) -!*** are coincident, i=3 (west) and i=ite (east) are coincident, -!*** and since i=2 (west) and i=ite-1 (east) are coincident and -!*** in the true integration domain then they will equal their -!*** mean. -!----------------------------------------------------------------------- -! - length=2*(jte_h1-jts_h1+1)*km -! - if(e_bdy)then - do l=1,km - do j=jts_h1,jte_h1 - eastx(1,j,l)=hn(ite-2,j,l) - eastx(2,j,l)=hn(ite-1,j,l) - enddo - enddo -! - ntask=mype-inpes+1 - call mpi_send(eastx,length,mpi_real,ntask,mype & - ,mpi_comm_comp,isend) -! - call mpi_recv(westx,length,mpi_real,ntask,ntask & - ,mpi_comm_comp,jstat,irecv) -! - do l=1,km - do j=jts_h1,jte_h1 - ave=(westx(1,j,l)+hn(ite-1,j,l))*0.5 - hn(ite-1,j,l)=ave - hn(ite,j,l)=westx(2,j,l) - enddo - enddo -!----------------------------------------------------------------------- - elseif(w_bdy)then -! - ntask=mype+inpes-1 - call mpi_recv(eastx,length,mpi_real,ntask,ntask & - ,mpi_comm_comp,jstat,irecv) -! - do l=1,km - do j=jts_h1,jte_h1 - westx(1,j,l)=hn(its+1,j,l) - westx(2,j,l)=hn(its+2,j,l) - enddo - enddo -! - call mpi_send(westx,length,mpi_real,ntask,mype & - ,mpi_comm_comp,isend) -! - do l=1,km - do j=jts_h1,jte_h1 - hn(its,j,l)=eastx(1,j,l) - ave=(hn(its+1,j,l)+eastx(2,j,l))*0.5 - hn(its+1,j,l)=ave - enddo - enddo -! -!----------------------------------------------------------------------- - endif -!----------------------------------------------------------------------- -! - endsubroutine swaphn -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - subroutine polehn & -(hn,i_start,i_end,j_start,j_end,km,inpes,jnpes) -! -!----------------------------------------------------------------------- -!*** Create polar mass point arrays holding all values around the -!*** southernmost and northernmost latitude circles in the -!*** true integration regions. -!----------------------------------------------------------------------- -! - implicit none -! -!----------------------------------------------------------------------- - -integer(kind=kint),intent(in) :: & - i_end & -,i_start & -,inpes & -,j_end & -,j_start & -,jnpes & -,km -! -real(kind=kfpt),dimension(ims:ime,jms:jme,km),intent(inout):: & - hn -! -!----------------------------------------------------------------------- -!*** Local Variables -!----------------------------------------------------------------------- -! -integer(kind=kint) :: & - i & -,l -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -!*** First do the tasks at the south pole. -!----------------------------------------------------------------------- -! - south_tasks: if(s_bdy)then -! -!------------------------------------------------------------ -! - do l=1,km - do i=i_start,i_end - hn(i,1,l)=hn(i,3,l) - enddo - enddo -! -!----------------------------------------------------------------- -! - endif south_tasks -! -!----------------------------------------------------------------- -!*** Carry out the same procedure for the tasks at the north pole -!*** using three latitude circles. -!----------------------------------------------------------------- -! - north_tasks: if(n_bdy)then -! -!-------------------------------------------------------------- -! - do l=1,km - do i=i_start,i_end - hn(i,jte,l)=hn(i,jte-2,l) - enddo - enddo -! -!----------------------------------------------------------------------- -! - endif north_tasks -! -!----------------------------------------------------------------------- -! - end subroutine polehn -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - subroutine swapwn & -(wn,i_start,i_end,j_start,j_end,km,inpes) -! -!----------------------------------------------------------------------- -! - implicit none -! -!----------------------------------------------------------------------- - -integer(kind=kint),intent(in) :: & - i_start & -,i_end & -,j_start & -,j_end & -,km & -,inpes -! -real(kind=kfpt),dimension(i_start:i_end,j_start:j_end,km),intent(inout):: & - wn -! -!----------------------------------------------------------------------- -!*** Local Variables -!----------------------------------------------------------------------- -integer(kind=kint) :: & - irecv & -,isend & -,j & -,l & -,length_e & -,length_w & -,ntask -! -integer(kind=kint),dimension(mpi_status_size) :: & - jstat -! -real(kind=kfpt),dimension(jts_h1:jte_h1,km) :: & - eastx -! -real(kind=kfpt),dimension(2,jts_h1:jte_h1,km) :: & - westx -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Each task along the eastern and western "boundaries" needs to -!*** exchange with its counterpart on the opposite side. -! -!*** What is being said here is that i=1 (west) and i=ite-2 (east) -!*** are coincident, i=2 (west) and i=ite-1 (east) are coincident, -!*** and i=3 (west) and i=ite (east) are coincident. -!----------------------------------------------------------------------- -! - length_e=(jte_h1-jts_h1+1)*km - length_w=2*length_e -! - if(e_bdy)then - do l=1,km - do j=jts_h1,jte_h1 - eastx(j,l)=wn(ite-2,j,l) - enddo - enddo -! - ntask=mype-inpes+1 - call mpi_send(eastx,length_e,mpi_real,ntask,mype & - ,mpi_comm_comp,isend) -! - call mpi_recv(westx,length_w,mpi_real,ntask,ntask & - ,mpi_comm_comp,jstat,irecv) -! - do l=1,km - do j=jts_h1,jte_h1 - wn(ite-1,j,l)=westx(1,j,l) - wn(ite,j,l)=westx(2,j,l) - enddo - enddo -!----------------------------------------------------------------------- - elseif(w_bdy)then -! - ntask=mype+inpes-1 - call mpi_recv(eastx,length_e,mpi_real,ntask,ntask & - ,mpi_comm_comp,jstat,irecv) -! - do l=1,km - do j=jts_h1,jte_h1 - wn(its,j,l)=eastx(j,l) - enddo - enddo -! - do l=1,km - do j=jts_h1,jte_h1 - westx(1,j,l)=wn(its+1,j,l) - westx(2,j,l)=wn(its+2,j,l) - enddo - enddo -! - call mpi_send(westx,length_w,mpi_real,ntask,mype & - ,mpi_comm_comp,isend) -! -!----------------------------------------------------------------------- - endif -!----------------------------------------------------------------------- -! - endsubroutine swapwn -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - subroutine polewn & -(u,v,i_start,i_end,j_start,j_end,km,inpes,jnpes) -! -!----------------------------------------------------------------------- -!*** Create polar wind arrays holding all values around the -!*** southernmost and northernmost latitude circles in the -!*** true integration regions. -!----------------------------------------------------------------------- -! - implicit none -! -!----------------------------------------------------------------------- - -integer(kind=kint),intent(in) :: & - i_end & -,i_start & -,inpes & -,j_end & -,j_start & -,jnpes & -,km -! -real(kind=kfpt),dimension(ims:ime,jms:jme,km),intent(inout):: & - u & -,v -! -!----------------------------------------------------------------------- -!*** Local Variables -!----------------------------------------------------------------------- -! -integer(kind=kint) :: & - i & -,l -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -!*** First do the tasks at the south pole. -!----------------------------------------------------------------------- -! - south_tasks: if(s_bdy)then -! -!-------------------------------------------------------------- -! - do l=1,km - do i=i_start,i_end - u(i,1,l)=-u(i,2,l) - v(i,1,l)=-v(i,2,l) - enddo - enddo -! -!----------------------------------------------------------------- -! - endif south_tasks -! -!----------------------------------------------------------------- -!*** Carry out the same procedure for the tasks at the north pole -!*** using three latitude circles. -!----------------------------------------------------------------- -! - north_tasks: if(n_bdy)then -! -!-------------------------------------------------------------------- -! - do l=1,km - do i=i_start,i_end - u(i,jte-1,l)=-u(i,jte-2,l) - v(i,jte-1,l)=-v(i,jte-2,l) - u(i,jte ,l)=-u(i,jte-2,l) - v(i,jte ,l)=-v(i,jte-2,l) - enddo - enddo -! -!----------------------------------------------------------------------- -! - endif north_tasks -! -!----------------------------------------------------------------------- -! - end subroutine polewn -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - subroutine read_bc & -(lm,lnsh,lnsv,ntsd,dt & -,runbc,idatbc,ihrstbc,tboco & -,nvars_bc_2d_h,nvars_bc_3d_h,nvars_bc_4d_h & -,nvars_bc_2d_v,nvars_bc_3d_v & -,bnd_vars_h & -,bnd_vars_v & -,n_bc_3d_h ) -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** This routine reads in boundary update data for the single domain -!*** in the forecast or else for the uppermost parent if there are -!*** nests. The data is in external files generated during the -!*** pre-processing. -! -!*** This routine is used for nest boundaries as well if digital -!*** filtering is being used. -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -! -implicit none -! -!------------------------ -!*** Argument variables -!------------------------ - -integer(kind=kint),intent(in):: & - lm & ! total # of levels -,lnsh & ! # of boundary h lines for bc in reg. setup -,lnsv & ! # of boundary v lines for bc in reg. setup -,ntsd ! current timestep - -integer(kind=kint),intent(in) :: & - nvars_bc_2d_h & ! # of 2-d h-pt boundary variables -,nvars_bc_3d_h & ! # of 3-d h-pt boundary variables -,nvars_bc_4d_h & ! # of 4-d h-pt boundary variables -,nvars_bc_2d_v & ! # of 2-d v-pt boundary variables -,nvars_bc_3d_v ! # of 3-d v-pt boundary variables - -integer(kind=kint),intent(out):: & - ihrstbc ! boundary conditions starting time - -integer(kind=kint),dimension(1:3),intent(in):: & - n_bc_3d_h ! order in which to store domain #1's BC vbls - -integer(kind=kint),dimension(1:3),intent(out):: & - idatbc ! date of boundary data, day, month, year - -real(kind=kfpt),intent(in):: & - dt ! dynamics time step - -real(kind=kfpt),intent(out):: & - tboco ! boundary conditions interval, hours - -type(bc_h_all),intent(inout) :: & - bnd_vars_h ! boundary variables on h points - -type(bc_v_all),intent(inout) :: & - bnd_vars_v ! boundary variables on v points - -logical(kind=klog),intent(out) :: runbc - -!--------------------- -!*** Local variables -!--------------------- - -integer(kind=kint):: & - i & ! index in x direction -,i_hi & ! max i loop limit (cannot be > ide) -,i_lo & ! min i loop limit (cannot be < ids) -,ihr & ! current hour -,ihrbc & ! current hour for bc's -,istat & ! return status -,iunit & ! file unit number -,j_hi & ! max j loop limit (cannot be > jde) -,j_lo & ! min j loop limit (cannot be < jds) -,l & -,lbnd & -,n1 & ! dimension 1 of working arrays -,n2 & ! dimension 2 of working arrays -,n3 & ! dimension 3 of working arrays -,n4 & ! dimension 4 of working arrays -,n5 & ! dimension 5 of working arrays -,nl & -,nv & -,nvx & -,ubnd - -real(kind=kfpt),dimension(1:lnsh,jds:jde,1:2) :: global_2d_h_east & - ,global_2d_h_west - -real(kind=kfpt),dimension(ids:ide,1:lnsh,1:2) :: global_2d_h_north & - ,global_2d_h_south - -real(kind=kfpt),dimension(1:lnsh,jds:jde,1:lm,1:2) :: global_3d_h_east & - ,global_3d_h_west - -real(kind=kfpt),dimension(ids:ide,1:lnsh,1:lm,1:2) :: global_3d_h_north & - ,global_3d_h_south - -real(kind=kfpt),dimension(1:lnsv,jds:jde,1:2) :: global_2d_v_east & - ,global_2d_v_west - -real(kind=kfpt),dimension(ids:ide,1:lnsv,1:2) :: global_2d_v_north & - ,global_2d_v_south - -real(kind=kfpt),dimension(1:lnsv,jds:jde,1:lm,1:2) :: global_3d_v_east & - ,global_3d_v_west - -real(kind=kfpt),dimension(ids:ide,1:lnsv,1:lm,1:2) :: global_3d_v_north & - ,global_3d_v_south - -character(64) :: infile -logical(kind=klog) :: opened -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Because subdomains that lie along the global domain boundary -!*** may have haloes that extend beyond the global limits, create -!*** limits here that keep loops from reaching beyond those -!*** global limits. -!----------------------------------------------------------------------- -! - i_lo=max(ims,ids) - i_hi=min(ime,ide) - j_lo=max(jms,jds) - j_hi=min(jme,jde) -! -!----------------------------------------------------------------------- -!*** Read in boundary variables and arrays. -!----------------------------------------------------------------------- -! - ihr=nint(ntsd*abs(dt)/3600.) - - ihrbc=ihr - write(infile,'(a,i4.4)')'boco.',ihrbc -! - select_unit: do l=51,59 - inquire(l,opened=opened) - if(.not.opened)then - iunit=l - exit select_unit - endif - enddo select_unit -! - open(unit=iunit,file=infile,status='OLD' & - ,form='UNFORMATTED',iostat=istat) - -! if (mype_share == 0) write(0,*) 'reading from boco file: ', trim(infile) -! -! write(6,*) 'DEBUG-GT, reading from boco file: ', trim(infile), 'unit number ', iunit -! write(6,*) 'DEBUG-GT, domain size is ide,jde,lm = ', ide, jde, lm -! write(6,*) 'DEBUG-GT, reading logical, 4 INTS, 1 FLOAT | 21 bytes' - rewind(iunit) - read(iunit)runbc,idatbc,ihrstbc,tboco -! write(6,*) 'DEBUG-GT, found: runbc,idatbc,ihrstbc,tboco', runbc,idatbc,ihrstbc,tboco - -! write(6,*) 'DEBUG-GT, assortment of dimensions in subsequent read statements; i_lo, i_hi, j_lo, j_hi, lm, lnsh, lnsv:', i_lo, i_hi, j_lo, j_hi, lm, lnsh, lnsv -! -!----------------------------------------------------------------------- -!*** If there are 2-d h-pt boundary variables then loop through them -!*** reading them from the input file. -!----------------------------------------------------------------------- -! - if(nvars_bc_2d_h>0)then -! - do nv=1,nvars_bc_2d_h -! write(6,*) 'DEBUG-GT, reading PD.1, 2 arrays with N elements to read: ', (ide-ids+1)*lnsh*2, (ide-ids+1)*lnsh*2*4, ' bytes' -! write(6,*) 'DEBUG-GT, reading PD.2, 2 arrays with M elements to read: ', (jde-jds+1)*lnsh*2, (jde-jds+1)*lnsh*2*4, ' bytes' - read(iunit)global_2d_h_south,global_2d_h_north,global_2d_h_west,global_2d_h_east -! write(6,*) 'DEBUG-GT, read arrays pdbs_g,pdbn_g,pdbw_g,pdbe_g' -! - do n3=1,2 - do n2=1,lnsh - do n1=i_lo,i_hi - bnd_vars_h%var_2d(nv)%south(n1,n2,n3)=global_2d_h_south(n1,n2,n3) - bnd_vars_h%var_2d(nv)%north(n1,n2,n3)=global_2d_h_north(n1,n2,n3) - enddo - enddo -! - do n2=j_lo,j_hi - do n1=1,lnsh - bnd_vars_h%var_2d(nv)%west(n1,n2,n3)=global_2d_h_west(n1,n2,n3) - bnd_vars_h%var_2d(nv)%east(n1,n2,n3)=global_2d_h_east(n1,n2,n3) - enddo - enddo - enddo -! - enddo -! - endif -! -!----------------------------------------------------------------------- -!*** If there are 3-d h-pt boundary variables then loop through them -!*** reading them from the input file. -!*** IMPORTANT: See the note in BUILD_BC_BUNDLE regarding the -!*** handling of order in which these 3-D H-pt BC -!*** variables are stored. If there are nests then -!*** the order must agree with these variables' -!*** order in the nests.txt file. -!----------------------------------------------------------------------- -! - if(nvars_bc_3d_h>0)then -! - do nv=1,nvars_bc_3d_h -! - nvx=n_bc_3d_h(nv) !<-- Order of domain #1's T,Q,CW storage in bndry object -! - read(iunit)global_3d_h_south,global_3d_h_north,global_3d_h_west,global_3d_h_east -! - do n4=1,2 - do n3=1,lm - do n2=1,lnsh - do n1=i_lo,i_hi - bnd_vars_h%var_3d(nvx)%south(n1,n2,n3,n4)=global_3d_h_south(n1,n2,n3,n4) - bnd_vars_h%var_3d(nvx)%north(n1,n2,n3,n4)=global_3d_h_north(n1,n2,n3,n4) - enddo - enddo -! - do n2=j_lo,j_hi - do n1=1,lnsh - bnd_vars_h%var_3d(nvx)%west(n1,n2,n3,n4)=global_3d_h_west(n1,n2,n3,n4) - bnd_vars_h%var_3d(nvx)%east(n1,n2,n3,n4)=global_3d_h_east(n1,n2,n3,n4) - enddo - enddo - enddo - enddo -! - enddo -! - endif -! -!----------------------------------------------------------------------- -!*** If there are 4-d h-pt boundary variables then loop through them -!*** reading them from the input file. -!----------------------------------------------------------------------- -! - if(nvars_bc_4d_h>0)then -! - do nv=1,nvars_bc_4d_h -! - lbnd=lbound(bnd_vars_h%var_4d(nv)%full_var,4) - ubnd=ubound(bnd_vars_h%var_4d(nv)%full_var,4) - do nl=lbnd,ubnd - read(iunit)global_3d_h_south,global_3d_h_north,global_3d_h_west,global_3d_h_east -! - do n4=1,2 - do n3=1,lm - do n2=1,lnsh - do n1=i_lo,i_hi - bnd_vars_h%var_4d(nv)%south(n1,n2,n3,n4,nl)=global_3d_h_south(n1,n2,n3,n4) - bnd_vars_h%var_4d(nv)%north(n1,n2,n3,n4,nl)=global_3d_h_north(n1,n2,n3,n4) - enddo - enddo -! - do n2=j_lo,j_hi - do n1=1,lnsh - bnd_vars_h%var_4d(nv)%west(n1,n2,n3,n4,nl)=global_3d_h_west(n1,n2,n3,n4) - bnd_vars_h%var_4d(nv)%east(n1,n2,n3,n4,nl)=global_3d_h_east(n1,n2,n3,n4) - enddo - enddo - enddo - enddo -! - enddo -! - enddo -! - endif -! -!----------------------------------------------------------------------- -!*** If there are 2-d v-pt boundary variables then loop through them -!*** reading them from the input file. -!----------------------------------------------------------------------- -! - if(nvars_bc_2d_v>0)then -! - do nv=1,nvars_bc_2d_v -! - read(iunit)global_2d_v_south,global_2d_v_north,global_2d_v_west,global_2d_v_east -! - do n3=1,2 - do n2=1,lnsv - do n1=i_lo,i_hi - bnd_vars_v%var_2d(nv)%south(n1,n2,n3)=global_2d_v_south(n1,n2,n3) - bnd_vars_v%var_2d(nv)%north(n1,n2,n3)=global_2d_v_north(n1,n2,n3) - enddo - enddo -! - do n2=j_lo,j_hi - do n1=1,lnsv - bnd_vars_v%var_2d(nv)%west(n1,n2,n3)=global_2d_v_west(n1,n2,n3) - bnd_vars_v%var_2d(nv)%east(n1,n2,n3)=global_2d_v_east(n1,n2,n3) - enddo - enddo - enddo -! - enddo -! - endif -! -!----------------------------------------------------------------------- -!*** If there are 3-d v-pt boundary variables then loop through them -!*** reading them from the input file. -!----------------------------------------------------------------------- -! - if(nvars_bc_3d_v>0)then -! - do nv=1,nvars_bc_3d_v -! - read(iunit)global_3d_v_south,global_3d_v_north,global_3d_v_west,global_3d_v_east -! - do n4=1,2 - do n3=1,lm - do n2=1,lnsv - do n1=i_lo,i_hi - bnd_vars_v%var_3d(nv)%south(n1,n2,n3,n4)=global_3d_v_south(n1,n2,n3,n4) - bnd_vars_v%var_3d(nv)%north(n1,n2,n3,n4)=global_3d_v_north(n1,n2,n3,n4) - enddo - enddo -! - do n2=j_lo,j_hi - do n1=1,lnsv - bnd_vars_v%var_3d(nv)%west(n1,n2,n3,n4)=global_3d_v_west(n1,n2,n3,n4) - bnd_vars_v%var_3d(nv)%east(n1,n2,n3,n4)=global_3d_v_east(n1,n2,n3,n4) - enddo - enddo - enddo - enddo -! - enddo -! - endif -! -!----------------------------------------------------------------------- -! - close(iunit) -! -!----------------------------------------------------------------------- - - end subroutine read_bc - -!----------------------------------------------------------------------- - subroutine write_bc & -(lm,lnsh,lnsv,ntsd,dt & -,runbc,tboco & -,nvars_bc_2d_h & -,nvars_bc_3d_h & -,nvars_bc_4d_h & -,nvars_bc_2d_v & -,nvars_bc_3d_v & -,bnd_vars_h & -,bnd_vars_v & -,recomp_tend) -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -! -implicit none -! -!----------------------------------------------------------------------- -! -!include 'kind.inc' -! -!----------------------------------------------------------------------- -integer(kind=kint),intent(in):: & - lm & ! total # of levels -,lnsh & ! # of boundary h lines for bc in reg. setup -,lnsv & ! # of boundary v lines for bc in reg. setup -,ntsd ! current timestep - -integer(kind=kint),intent(in) :: & - nvars_bc_2d_h & -,nvars_bc_3d_h & -,nvars_bc_4d_h & -,nvars_bc_2d_v & -,nvars_bc_3d_v - -real(kind=kfpt),intent(in):: & - dt ! dynamics time step - -real(kind=kfpt),intent(in):: & - tboco ! boundary conditions interval - -logical, intent(in) :: recomp_tend - -logical(kind=klog),intent(in) :: runbc - -type(bc_h_all),intent(inout) :: & - bnd_vars_h - -type(bc_v_all),intent(inout) :: & - bnd_vars_v - -!----------------------------------------------------------------------- -!---local variables----------------------------------------------------- -!----------------------------------------------------------------------- -integer(kind=kint):: & - i & ! index in x direction -,i_hi & ! max i loop limit (cannot be > ide) -,i_lo & ! min i loop limit (cannot be < ids) -,ihr & ! current hour -,ihrbc & ! current hour for bc's -,istat & ! return status -,iunit & ! file unit number -,j_hi & ! max j loop limit (cannot be > jde) -,j_lo & ! min j loop limit (cannot be < jds) -,l & -,lbnd & -,n1 & ! dimension 1 of working arrays -,n2 & ! dimension 2 of working arrays -,n3 & ! dimension 3 of working arrays -,n4 & ! dimension 4 of working arrays -,n5 & ! dimension 5 of working arrays -,nv & -,ubnd - -real(kind=kfpt) :: & - r_tboco - -real(kind=kfpt),dimension(:,:,:,:),allocatable :: & - targ_2d_h_e & -,targ_2d_h_n & -,targ_2d_h_s & -,targ_2d_h_w - -real(kind=kfpt),dimension(:,:,:,:,:),allocatable :: & - targ_3d_h_e & -,targ_3d_h_n & -,targ_3d_h_s & -,targ_3d_h_w - -real(kind=kfpt),dimension(:,:,:,:),allocatable :: & - targ_2d_v_e & -,targ_2d_v_n & -,targ_2d_v_s & -,targ_2d_v_w - -real(kind=kfpt),dimension(:,:,:,:,:),allocatable :: & - targ_3d_v_e & -,targ_3d_v_n & -,targ_3d_v_s & -,targ_3d_v_w - -type(filt_4d),dimension(:),allocatable :: & - targ_4d_h_e & -,targ_4d_h_n & -,targ_4d_h_s & -,targ_4d_h_w - -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - r_tboco=1./tboco -! -!----------------------------------------------------------------------- -!*** Because subdomains that lie along the global domain boundary -!*** may have haloes that extend beyond the global limits, create -!*** limits here that keep loops from reaching beyond those -!*** global limits. -!----------------------------------------------------------------------- -! - i_lo=max(ims,ids) - i_hi=min(ime,ide) - j_lo=max(jms,jds) - j_hi=min(jme,jde) -! -! if (mype_share == 0) write(0,*) 'inside write_bc with recomp_tend: ', recomp_tend - if (recomp_tend) then - -!----------------------------------------------------------------------- -!*** Is this task subdomain on the full domain's north side? -!----------------------------------------------------------------------- - - IF (n_bdy) THEN - - if(nvars_bc_2d_h>0)then - allocate(targ_2d_h_n(ims:ime,1:lnsh,1,1:nvars_bc_2d_h)) - do nv=1,nvars_bc_2d_h - do n3=1,1 - do n2=1,lnsh - do n1=i_lo,i_hi - targ_2d_h_n(n1,n2,n3,nv)=bnd_vars_h%var_2d(nv)%north(n1,n2,1) & - +tboco*bnd_vars_h%var_2d(nv)%north(n1,n2,2) - enddo - enddo - enddo - enddo - endif - - if(nvars_bc_3d_h>0)then - allocate(targ_3d_h_n(ims:ime,1:lnsh,1:lm,1,1:nvars_bc_3d_h)) - do nv=1,nvars_bc_3d_h - do n4=1,1 - do n3=1,lm - do n2=1,lnsh - do n1=i_lo,i_hi - targ_3d_h_n(n1,n2,n3,n4,nv)=bnd_vars_h%var_3d(nv)%north(n1,n2,n3,1) & - +tboco*bnd_vars_h%var_3d(nv)%north(n1,n2,n3,2) - enddo - enddo - enddo - enddo - enddo - endif - - if(nvars_bc_4d_h>0)then - allocate(targ_4d_h_n(1:nvars_bc_4d_h)) - do nv=1,nvars_bc_4d_h - lbnd=lbound(bnd_vars_h%var_4d(nv)%full_var,4) - ubnd=ubound(bnd_vars_h%var_4d(nv)%full_var,4) - allocate(targ_4d_h_n(nv)%base(ims:ime,1:lnsh,1:lm,1,lbnd:ubnd)) - do n5=lbnd,ubnd - do n4=1,1 - do n3=1,lm - do n2=1,lnsh - do n1=i_lo,i_hi - targ_4d_h_n(nv)%base(n1,n2,n3,n4,n5)=bnd_vars_h%var_4d(nv)%north(n1,n2,n3,1,n5) & - +tboco*bnd_vars_h%var_4d(nv)%north(n1,n2,n3,2,n5) - enddo - enddo - enddo - enddo - enddo - enddo - endif - - if(nvars_bc_2d_v>0)then - allocate(targ_2d_v_n(ims:ime,1:lnsv,1,nvars_bc_2d_v)) - do nv=1,nvars_bc_2d_v - do n3=1,1 - do n2=1,lnsv - do n1=i_lo,i_hi - targ_2d_v_n(n1,n2,n3,nv)=bnd_vars_v%var_2d(nv)%north(n1,n2,1) & - +tboco*bnd_vars_v%var_2d(nv)%north(n1,n2,2) - enddo - enddo - enddo - enddo - endif - - if(nvars_bc_3d_v>0)then - allocate(targ_3d_v_n(ims:ime,1:lnsv,1:lm,1,nvars_bc_3d_v)) - do nv=1,nvars_bc_3d_v - do n4=1,1 - do n3=1,lm - do n2=1,lnsv - do n1=i_lo,i_hi - targ_3d_v_n(n1,n2,n3,n4,nv)=bnd_vars_v%var_3d(nv)%north(n1,n2,n3,1) & - +tboco*bnd_vars_v%var_3d(nv)%north(n1,n2,n3,2) - enddo - enddo - enddo - enddo - enddo - endif - - ENDIF ! N_BDY - -!----------------------------------------------------------------------- -!*** Is this task subdomain on the full domain's south side? -!----------------------------------------------------------------------- - - IF (s_bdy) THEN - - if(nvars_bc_2d_h>0)then - allocate(targ_2d_h_s(ims:ime,1:lnsh,1,1:nvars_bc_2d_h)) - do nv=1,nvars_bc_2d_h - do n3=1,1 - do n2=1,lnsh - do n1=i_lo,i_hi - targ_2d_h_s(n1,n2,n3,nv)=bnd_vars_h%var_2d(nv)%south(n1,n2,1) & - +tboco*bnd_vars_h%var_2d(nv)%south(n1,n2,2) - enddo - enddo - enddo - enddo - endif - - if(nvars_bc_3d_h>0)then - allocate(targ_3d_h_s(ims:ime,1:lnsh,1:lm,1,1:nvars_bc_3d_h)) - do nv=1,nvars_bc_3d_h - do n4=1,1 - do n3=1,lm - do n2=1,lnsh - do n1=i_lo,i_hi - targ_3d_h_s(n1,n2,n3,n4,nv)=bnd_vars_h%var_3d(nv)%south(n1,n2,n3,1) & - +tboco*bnd_vars_h%var_3d(nv)%south(n1,n2,n3,2) - enddo - enddo - enddo - enddo - enddo - endif - - if(nvars_bc_4d_h>0)then - allocate(targ_4d_h_s(1:nvars_bc_4d_h)) - do nv=1,nvars_bc_4d_h - lbnd=lbound(bnd_vars_h%var_4d(nv)%full_var,4) - ubnd=ubound(bnd_vars_h%var_4d(nv)%full_var,4) - allocate(targ_4d_h_s(nv)%base(ims:ime,1:lnsh,1:lm,1,lbnd:ubnd)) - do n5=lbnd,ubnd - do n4=1,1 - do n3=1,lm - do n2=1,lnsh - do n1=i_lo,i_hi - targ_4d_h_s(nv)%base(n1,n2,n3,n4,n5)=bnd_vars_h%var_4d(nv)%south(n1,n2,n3,1,n5) & - +tboco*bnd_vars_h%var_4d(nv)%south(n1,n2,n3,2,n5) - enddo - enddo - enddo - enddo - enddo - enddo - endif - - if(nvars_bc_2d_v>0)then - allocate(targ_2d_v_s(ims:ime,1:lnsv,1,nvars_bc_2d_v)) - do nv=1,nvars_bc_2d_v - do n3=1,1 - do n2=1,lnsv - do n1=i_lo,i_hi - targ_2d_v_s(n1,n2,n3,nv)=bnd_vars_v%var_2d(nv)%south(n1,n2,1) & - +tboco*bnd_vars_v%var_2d(nv)%south(n1,n2,2) - enddo - enddo - enddo - enddo - endif - - if(nvars_bc_3d_v>0)then - allocate(targ_3d_v_s(ims:ime,1:lnsv,1:lm,1,nvars_bc_3d_v)) - do nv=1,nvars_bc_3d_v - do n4=1,1 - do n3=1,lm - do n2=1,lnsv - do n1=i_lo,i_hi - targ_3d_v_s(n1,n2,n3,n4,nv)=bnd_vars_v%var_3d(nv)%south(n1,n2,n3,1) & - +tboco*bnd_vars_v%var_3d(nv)%south(n1,n2,n3,2) - enddo - enddo - enddo - enddo - enddo - endif - - ENDIF ! S_BDY - -!----------------------------------------------------------------------- -!*** Is this task subdomain on the full domain's west side? -!----------------------------------------------------------------------- - - IF (w_bdy) THEN - - if(nvars_bc_2d_h>0)then - allocate(targ_2d_h_w(1:lnsh,jms:jme,1,1:nvars_bc_2d_h)) - do nv=1,nvars_bc_2d_h - do n3=1,1 - do n2=j_lo,j_hi - do n1=1,lnsh - targ_2d_h_w(n1,n2,n3,nv)=bnd_vars_h%var_2d(nv)%west(n1,n2,1) & - +tboco*bnd_vars_h%var_2d(nv)%west(n1,n2,2) - enddo - enddo - enddo - enddo - endif - - if(nvars_bc_3d_h>0)then - allocate(targ_3d_h_w(1:lnsh,jms:jme,1:lm,1,1:nvars_bc_3d_h)) - do nv=1,nvars_bc_3d_h - do n4=1,1 - do n3=1,lm - do n2=j_lo,j_hi - do n1=1,lnsh - targ_3d_h_w(n1,n2,n3,n4,nv)=bnd_vars_h%var_3d(nv)%west(n1,n2,n3,1) & - +tboco*bnd_vars_h%var_3d(nv)%west(n1,n2,n3,2) - enddo - enddo - enddo - enddo - enddo - endif - - if(nvars_bc_4d_h>0)then - allocate(targ_4d_h_w(1:nvars_bc_4d_h)) - do nv=1,nvars_bc_4d_h - lbnd=lbound(bnd_vars_h%var_4d(nv)%full_var,4) - ubnd=ubound(bnd_vars_h%var_4d(nv)%full_var,4) - allocate(targ_4d_h_w(nv)%base(1:lnsh,jms:jme,1:lm,1,lbnd:ubnd)) - do n5=lbnd,ubnd - do n4=1,1 - do n3=1,lm - do n2=j_lo,j_hi - do n1=1,lnsh - targ_4d_h_w(nv)%base(n1,n2,n3,n4,n5)=bnd_vars_h%var_4d(nv)%west(n1,n2,n3,1,n5) & - +tboco*bnd_vars_h%var_4d(nv)%west(n1,n2,n3,2,n5) - enddo - enddo - enddo - enddo - enddo - enddo - endif - - if(nvars_bc_2d_v>0)then - allocate(targ_2d_v_w(1:lnsv,jms:jme,1,nvars_bc_2d_v)) - do nv=1,nvars_bc_2d_v - do n3=1,1 - do n2=j_lo,j_hi - do n1=1,lnsv - targ_2d_v_w(n1,n2,n3,nv)=bnd_vars_v%var_2d(nv)%west(n1,n2,1) & - +tboco*bnd_vars_v%var_2d(nv)%west(n1,n2,2) - enddo - enddo - enddo - enddo - endif - - if(nvars_bc_3d_v>0)then - allocate(targ_3d_v_w(1:lnsv,jms:jme,1:lm,1,nvars_bc_3d_v)) - do nv=1,nvars_bc_3d_v - do n4=1,1 - do n3=1,lm - do n2=j_lo,j_hi - do n1=1,lnsv - targ_3d_v_w(n1,n2,n3,n4,nv)=bnd_vars_v%var_3d(nv)%west(n1,n2,n3,1) & - +tboco*bnd_vars_v%var_3d(nv)%west(n1,n2,n3,2) - enddo - enddo - enddo - enddo - enddo - endif - - ENDIF ! W_BDY - -!----------------------------------------------------------------------- -!*** Is this task subdomain on the full domain's east side? -!----------------------------------------------------------------------- - - IF (e_bdy) THEN - - if(nvars_bc_2d_h>0)then - allocate(targ_2d_h_e(1:lnsh,jms:jme,1,1:nvars_bc_2d_h)) - do nv=1,nvars_bc_2d_h - do n3=1,1 - do n2=j_lo,j_hi - do n1=1,lnsh - targ_2d_h_e(n1,n2,n3,nv)=bnd_vars_h%var_2d(nv)%east(n1,n2,1) & - +tboco*bnd_vars_h%var_2d(nv)%east(n1,n2,2) - enddo - enddo - enddo - enddo - endif - - if(nvars_bc_3d_h>0)then - allocate(targ_3d_h_e(1:lnsh,jms:jme,1:lm,1,1:nvars_bc_3d_h)) - do nv=1,nvars_bc_3d_h - do n4=1,1 - do n3=1,lm - do n2=j_lo,j_hi - do n1=1,lnsh - targ_3d_h_e(n1,n2,n3,n4,nv)=bnd_vars_h%var_3d(nv)%east(n1,n2,n3,1) & - +tboco*bnd_vars_h%var_3d(nv)%east(n1,n2,n3,2) - enddo - enddo - enddo - enddo - enddo - endif - - if(nvars_bc_4d_h>0)then - allocate(targ_4d_h_e(1:nvars_bc_4d_h)) - do nv=1,nvars_bc_4d_h - lbnd=lbound(bnd_vars_h%var_4d(nv)%full_var,4) - ubnd=ubound(bnd_vars_h%var_4d(nv)%full_var,4) - allocate(targ_4d_h_e(nv)%base(1:lnsh,jms:jme,1:lm,1,lbnd:ubnd)) - do n5=lbnd,ubnd - do n4=1,1 - do n3=1,lm - do n2=j_lo,j_hi - do n1=1,lnsh - targ_4d_h_e(nv)%base(n1,n2,n3,n4,n5)=bnd_vars_h%var_4d(nv)%east(n1,n2,n3,1,n5) & - +tboco*bnd_vars_h%var_4d(nv)%east(n1,n2,n3,2,n5) - enddo - enddo - enddo - enddo - enddo - enddo - endif - - if(nvars_bc_2d_v>0)then - allocate(targ_2d_v_e(1:lnsv,jms:jme,1,nvars_bc_2d_v)) - do nv=1,nvars_bc_2d_v - do n3=1,1 - do n2=j_lo,j_hi - do n1=1,lnsv - targ_2d_v_e(n1,n2,n3,nv)=bnd_vars_v%var_2d(nv)%east(n1,n2,1) & - +tboco*bnd_vars_v%var_2d(nv)%east(n1,n2,2) - enddo - enddo - enddo - enddo - endif - - if(nvars_bc_3d_v>0)then - allocate(targ_3d_v_e(1:lnsv,jms:jme,1:lm,1,nvars_bc_3d_v)) - do nv=1,nvars_bc_3d_v - do n4=1,1 - do n3=1,lm - do n2=j_lo,j_hi - do n1=1,lnsv - targ_3d_v_e(n1,n2,n3,n4,nv)=bnd_vars_v%var_3d(nv)%east(n1,n2,n3,1) & - +tboco*bnd_vars_v%var_3d(nv)%east(n1,n2,n3,2) - enddo - enddo - enddo - enddo - enddo - endif - - ENDIF ! E_BDY - - endif ! recomp_tend - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!! Define the first portion of the boundary arrays from the full domain fields -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - IF (n_bdy) THEN - - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - do n3=1,1 - do n2=1,lnsh - do n1=i_lo,i_hi - bnd_vars_h%var_2d(nv)%north(n1,n2,n3)= & - bnd_vars_h%var_2d(nv)%full_var(n1,n2+j_hi-lnsh) - enddo - enddo - enddo - enddo - endif - - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - do n4=1,1 - do n3=1,lm - do n2=1,lnsh - do n1=i_lo,i_hi - bnd_vars_h%var_3d(nv)%north(n1,n2,n3,n4)= & - bnd_vars_h%var_3d(nv)%full_var(n1,n2+j_hi-lnsh,n3) - enddo - enddo - enddo - enddo - enddo - endif - - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lbnd=lbound(bnd_vars_h%var_4d(nv)%full_var,4) - ubnd=ubound(bnd_vars_h%var_4d(nv)%full_var,4) - do n5=lbnd,ubnd - do n4=1,1 - do n3=1,lm - do n2=1,lnsh - do n1=i_lo,i_hi - bnd_vars_h%var_4d(nv)%north(n1,n2,n3,n4,n5)= & - bnd_vars_h%var_4d(nv)%full_var(n1,n2+j_hi-lnsh,n3,n5) - enddo - enddo - enddo - enddo - enddo - enddo - endif - - if(nvars_bc_2d_v>0)then - do nv=1,nvars_bc_2d_v - do n3=1,1 - do n2=1,lnsv - do n1=i_lo,i_hi - bnd_vars_v%var_2d(nv)%north(n1,n2,n3)= & - bnd_vars_v%var_2d(nv)%full_var(n1,n2+j_hi-lnsv-1) - enddo - enddo - enddo - enddo - endif - - if(nvars_bc_3d_v>0)then - do nv=1,nvars_bc_3d_v - do n4=1,1 - do n3=1,lm - do n2=1,lnsv - do n1=i_lo,i_hi - bnd_vars_v%var_3d(nv)%north(n1,n2,n3,n4)= & - bnd_vars_v%var_3d(nv)%full_var(n1,n2+j_hi-lnsv,n3) - enddo - enddo - enddo - enddo - enddo - endif - - ENDIF ! N_BDY - - IF (s_bdy) THEN - - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - do n3=1,1 - do n2=1,lnsh - do n1=i_lo,i_hi - bnd_vars_h%var_2d(nv)%south(n1,n2,n3)= & - bnd_vars_h%var_2d(nv)%full_var(n1,j_lo+n2-1) - enddo - enddo - enddo - enddo - endif - - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - do n4=1,1 - do n3=1,lm - do n2=1,lnsh - do n1=i_lo,i_hi - bnd_vars_h%var_3d(nv)%south(n1,n2,n3,n4)= & - bnd_vars_h%var_3d(nv)%full_var(n1,j_lo+n2-1,n3) - enddo - enddo - enddo - enddo - enddo - endif - - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lbnd=lbound(bnd_vars_h%var_4d(nv)%full_var,4) - ubnd=ubound(bnd_vars_h%var_4d(nv)%full_var,4) - do n5=lbnd,ubnd - do n4=1,1 - do n3=1,lm - do n2=1,lnsh - do n1=i_lo,i_hi - bnd_vars_h%var_4d(nv)%south(n1,n2,n3,n4,n5)= & - bnd_vars_h%var_4d(nv)%full_var(n1,j_lo+n2-1,n3,n5) - enddo - enddo - enddo - enddo - enddo - enddo - endif - - if(nvars_bc_2d_v>0)then - do nv=1,nvars_bc_2d_v - do n3=1,1 - do n2=1,lnsv - do n1=i_lo,i_hi - bnd_vars_v%var_2d(nv)%south(n1,n2,n3)= & - bnd_vars_v%var_2d(nv)%full_var(n1,j_lo+n2-1) - enddo - enddo - enddo - enddo - endif - - if(nvars_bc_3d_v>0)then - do nv=1,nvars_bc_3d_v - do n4=1,1 - do n3=1,lm - do n2=1,lnsv - do n1=i_lo,i_hi - bnd_vars_v%var_3d(nv)%south(n1,n2,n3,n4)= & - bnd_vars_v%var_3d(nv)%full_var(n1,j_lo+n2-1,n3) - enddo - enddo - enddo - enddo - enddo - endif - - ENDIF ! S_BDY - - IF (w_bdy) THEN - - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - do n3=1,1 - do n2=j_lo,j_hi - do n1=1,lnsh - bnd_vars_h%var_2d(nv)%west(n1,n2,n3)= & - bnd_vars_h%var_2d(nv)%full_var(i_lo+n1-1,n2) - enddo - enddo - enddo - enddo - endif - - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - do n4=1,1 - do n3=1,lm - do n2=j_lo,j_hi - do n1=1,lnsh - bnd_vars_h%var_3d(nv)%west(n1,n2,n3,n4)= & - bnd_vars_h%var_3d(nv)%full_var(i_lo+n1-1,n2,n3) - enddo - enddo - enddo - enddo - enddo - endif - - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lbnd=lbound(bnd_vars_h%var_4d(nv)%full_var,4) - ubnd=ubound(bnd_vars_h%var_4d(nv)%full_var,4) - do n5=lbnd,ubnd - do n4=1,1 - do n3=1,lm - do n2=j_lo,j_hi - do n1=1,lnsh - bnd_vars_h%var_4d(nv)%west(n1,n2,n3,n4,n5)= & - bnd_vars_h%var_4d(nv)%full_var(i_lo+n1-1,n2,n3,n5) - enddo - enddo - enddo - enddo - enddo - enddo - endif - - if(nvars_bc_2d_v>0)then - do nv=1,nvars_bc_2d_v - do n3=1,1 - do n2=j_lo,j_hi - do n1=1,lnsv - bnd_vars_v%var_2d(nv)%west(n1,n2,n3)= & - bnd_vars_v%var_2d(nv)%full_var(i_lo+n1-1,n2) - enddo - enddo - enddo - enddo - endif - - if(nvars_bc_3d_v>0)then - do nv=1,nvars_bc_3d_v - do n4=1,1 - do n3=1,lm - do n2=j_lo,j_hi - do n1=1,lnsv - bnd_vars_v%var_3d(nv)%west(n1,n2,n3,n4)= & - bnd_vars_v%var_3d(nv)%full_var(i_lo+n1-1,n2,n3) - enddo - enddo - enddo - enddo - enddo - endif - - ENDIF ! W_BDY - - IF (e_bdy) THEN - - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - do n3=1,1 - do n2=j_lo,j_hi - do n1=1,lnsh - bnd_vars_h%var_2d(nv)%east(n1,n2,n3)= & - bnd_vars_h%var_2d(nv)%full_var(n1+i_hi-lnsh,n2) - enddo - enddo - enddo - enddo - endif - - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - do n4=1,1 - do n3=1,lm - do n2=j_lo,j_hi - do n1=1,lnsh - bnd_vars_h%var_3d(nv)%east(n1,n2,n3,n4)= & - bnd_vars_h%var_3d(nv)%full_var(n1+i_hi-lnsh,n2,n3) - enddo - enddo - enddo - enddo - enddo - endif - - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lbnd=lbound(bnd_vars_h%var_4d(nv)%full_var,4) - ubnd=ubound(bnd_vars_h%var_4d(nv)%full_var,4) - do n5=lbnd,ubnd - do n4=1,1 - do n3=1,lm - do n2=j_lo,j_hi - do n1=1,lnsh - bnd_vars_h%var_4d(nv)%east(n1,n2,n3,n4,n5)= & - bnd_vars_h%var_4d(nv)%full_var(n1+i_hi-lnsh,n2,n3,n5) - enddo - enddo - enddo - enddo - enddo - enddo - endif - - if(nvars_bc_2d_v>0)then - do nv=1,nvars_bc_2d_v - do n3=1,1 - do n2=j_lo,j_hi - do n1=1,lnsv - bnd_vars_v%var_2d(nv)%east(n1,n2,n3)= & - bnd_vars_v%var_2d(nv)%full_var(n1+i_hi-lnsh,n2) - enddo - enddo - enddo - enddo - endif - - if(nvars_bc_3d_v>0)then - do nv=1,nvars_bc_3d_v - do n4=1,1 - do n3=1,lm - do n2=j_lo,j_hi - do n1=1,lnsv - bnd_vars_v%var_3d(nv)%east(n1,n2,n3,n4)= & - bnd_vars_v%var_3d(nv)%full_var(n1+i_hi-lnsv-1,n2,n3) - enddo - enddo - enddo - enddo - enddo - endif - - ENDIF ! E_BDY - - if (recomp_tend) then - - IF (n_bdy) THEN - - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - do n2=1,lnsh - do n1=i_lo,i_hi - bnd_vars_h%var_2d(nv)%north(n1,n2,2)= & - (targ_2d_h_n(n1,n2,1,nv)-bnd_vars_h%var_2d(nv)%north(n1,n2,1))/tboco -! (targ_2d_h_n(n1,n2,1,nv)-bnd_vars_h%var_2d(nv)%north(n1,n2,1))*r_tboco - enddo - enddo - enddo - deallocate(targ_2d_h_n) - endif - - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - do n3=1,lm - do n2=1,lnsh - do n1=i_lo,i_hi - bnd_vars_h%var_3d(nv)%north(n1,n2,n3,2)= & - (targ_3d_h_n(n1,n2,n3,1,nv)-bnd_vars_h%var_3d(nv)%north(n1,n2,n3,1))/tboco -! (targ_3d_h_n(n1,n2,n3,1,nv)-bnd_vars_h%var_3d(nv)%north(n1,n2,n3,1))*r_tboco - enddo - enddo - enddo - enddo - deallocate(targ_3d_h_n) - endif - - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lbnd=lbound(bnd_vars_h%var_4d(nv)%full_var,4) - ubnd=ubound(bnd_vars_h%var_4d(nv)%full_var,4) - do n4=lbnd,ubnd - do n3=1,lm - do n2=1,lnsh - do n1=i_lo,i_hi - bnd_vars_h%var_4d(nv)%north(n1,n2,n3,2,n4)= & - (targ_4d_h_n(nv)%base(n1,n2,n3,1,nv)-bnd_vars_h%var_4d(nv)%north(n1,n2,n3,1,n4))/tboco -! (targ_4d_h_n(nv)%base(n1,n2,n3,1,nv)-bnd_vars_h%var_4d(nv)%north(n1,n2,n3,1,n4))*r_tboco - enddo - enddo - enddo - enddo - deallocate(targ_4d_h_n(nv)%base) - enddo - deallocate(targ_4d_h_n) - endif - - if(nvars_bc_2d_v>0)then - do nv=1,nvars_bc_2d_v - do n2=1,lnsv - do n1=i_lo,i_hi - bnd_vars_v%var_2d(nv)%north(n1,n2,2)= & - (targ_2d_v_n(n1,n2,1,nv)-bnd_vars_v%var_2d(nv)%north(n1,n2,1))/tboco -! (targ_2d_v_n(n1,n2,1,nv)-bnd_vars_v%var_2d(nv)%north(n1,n2,1))*r_tboco - enddo - enddo - enddo - deallocate(targ_2d_v_n) - endif - - if(nvars_bc_3d_v>0)then - do nv=1,nvars_bc_3d_v - do n3=1,lm - do n2=1,lnsv - do n1=i_lo,i_hi - bnd_vars_v%var_3d(nv)%north(n1,n2,n3,2)= & - (targ_3d_v_n(n1,n2,n3,1,nv)-bnd_vars_v%var_3d(nv)%north(n1,n2,n3,1))/tboco -! (targ_3d_v_n(n1,n2,n3,1,nv)-bnd_vars_v%var_3d(nv)%north(n1,n2,n3,1))*r_tboco - enddo - enddo - enddo - enddo - deallocate(targ_3d_v_n) - endif - - ENDIF ! N_BDY - - IF (s_bdy) THEN - - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - do n2=1,lnsh - do n1=i_lo,i_hi - bnd_vars_h%var_2d(nv)%south(n1,n2,2)= & - (targ_2d_h_s(n1,n2,1,nv)-bnd_vars_h%var_2d(nv)%south(n1,n2,1))/tboco -! (targ_2d_h_s(n1,n2,1,nv)-bnd_vars_h%var_2d(nv)%south(n1,n2,1))*r_tboco - enddo - enddo - enddo - deallocate(targ_2d_h_s) - endif - - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - do n3=1,lm - do n2=1,lnsh - do n1=i_lo,i_hi - bnd_vars_h%var_3d(nv)%south(n1,n2,n3,2)= & - (targ_3d_h_s(n1,n2,n3,1,nv)-bnd_vars_h%var_3d(nv)%south(n1,n2,n3,1))/tboco -! (targ_3d_h_s(n1,n2,n3,1,nv)-bnd_vars_h%var_3d(nv)%south(n1,n2,n3,1))*r_tboco - enddo - enddo - enddo - enddo - deallocate(targ_3d_h_s) - endif - - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lbnd=lbound(bnd_vars_h%var_4d(nv)%full_var,4) - ubnd=ubound(bnd_vars_h%var_4d(nv)%full_var,4) - do n4=lbnd,ubnd - do n3=1,lm - do n2=1,lnsh - do n1=i_lo,i_hi - bnd_vars_h%var_4d(nv)%south(n1,n2,n3,2,n4)= & - (targ_4d_h_s(nv)%base(n1,n2,n3,1,nv)-bnd_vars_h%var_4d(nv)%south(n1,n2,n3,1,n4))/tboco -! (targ_4d_h_s(nv)%base(n1,n2,n3,1,nv)-bnd_vars_h%var_4d(nv)%south(n1,n2,n3,1,n4))*r_tboco - enddo - enddo - enddo - enddo - deallocate(targ_4d_h_s(nv)%base) - enddo - deallocate(targ_4d_h_s) - endif - - if(nvars_bc_2d_v>0)then - do nv=1,nvars_bc_2d_v - do n2=1,lnsv - do n1=i_lo,i_hi - bnd_vars_v%var_2d(nv)%south(n1,n2,2)= & - (targ_2d_v_s(n1,n2,1,nv)-bnd_vars_v%var_2d(nv)%south(n1,n2,1))/tboco -! (targ_2d_v_s(n1,n2,1,nv)-bnd_vars_v%var_2d(nv)%south(n1,n2,1))*r_tboco - enddo - enddo - enddo - deallocate(targ_2d_v_s) - endif - - if(nvars_bc_3d_v>0)then - do nv=1,nvars_bc_3d_v - do n3=1,lm - do n2=1,lnsv - do n1=i_lo,i_hi - bnd_vars_v%var_3d(nv)%south(n1,n2,n3,2)= & - (targ_3d_v_s(n1,n2,n3,1,nv)-bnd_vars_v%var_3d(nv)%south(n1,n2,n3,1))/tboco -! (targ_3d_v_s(n1,n2,n3,1,nv)-bnd_vars_v%var_3d(nv)%south(n1,n2,n3,1))*r_tboco - enddo - enddo - enddo - enddo - deallocate(targ_3d_v_s) - endif - - ENDIF ! S_BDY - - IF (w_bdy) THEN - - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - do n2=j_lo,j_hi - do n1=1,lnsh - bnd_vars_h%var_2d(nv)%west(n1,n2,2)= & - (targ_2d_h_w(n1,n2,1,nv)-bnd_vars_h%var_2d(nv)%west(n1,n2,1))/tboco -! (targ_2d_h_w(n1,n2,1,nv)-bnd_vars_h%var_2d(nv)%west(n1,n2,1))*r_tboco - enddo - enddo - enddo - deallocate(targ_2d_h_w) - endif - - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - do n3=1,lm - do n2=j_lo,j_hi - do n1=1,lnsh - bnd_vars_h%var_3d(nv)%west(n1,n2,n3,2)= & - (targ_3d_h_w(n1,n2,n3,1,nv)-bnd_vars_h%var_3d(nv)%west(n1,n2,n3,1))/tboco -! (targ_3d_h_w(n1,n2,n3,1,nv)-bnd_vars_h%var_3d(nv)%west(n1,n2,n3,1))*r_tboco - enddo - enddo - enddo - enddo - deallocate(targ_3d_h_w) - endif - - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lbnd=lbound(bnd_vars_h%var_4d(nv)%full_var,4) - ubnd=ubound(bnd_vars_h%var_4d(nv)%full_var,4) - do n4=lbnd,ubnd - do n3=1,lm - do n2=j_lo,j_hi - do n1=1,lnsh - bnd_vars_h%var_4d(nv)%west(n1,n2,n3,2,n4)= & - (targ_4d_h_w(nv)%base(n1,n2,n3,1,nv)-bnd_vars_h%var_4d(nv)%west(n1,n2,n3,1,n4))/tboco -! (targ_4d_h_w(nv)%base(n1,n2,n3,1,nv)-bnd_vars_h%var_4d(nv)%west(n1,n2,n3,1,n4))*r_tboco - enddo - enddo - enddo - enddo - deallocate(targ_4d_h_w(nv)%base) - enddo - deallocate(targ_4d_h_w) - endif - - if(nvars_bc_2d_v>0)then - do nv=1,nvars_bc_2d_v - do n2=j_lo,j_hi - do n1=1,lnsv - bnd_vars_v%var_2d(nv)%west(n1,n2,2)= & - (targ_2d_v_w(n1,n2,1,nv)-bnd_vars_v%var_2d(nv)%west(n1,n2,1))/tboco -! (targ_2d_v_w(n1,n2,1,nv)-bnd_vars_v%var_2d(nv)%west(n1,n2,1))*r_tboco - enddo - enddo - enddo - deallocate(targ_2d_v_w) - endif - - if(nvars_bc_3d_v>0)then - do nv=1,nvars_bc_3d_v - do n3=1,lm - do n2=j_lo,j_hi - do n1=1,lnsv - bnd_vars_v%var_3d(nv)%west(n1,n2,n3,2)= & - (targ_3d_v_w(n1,n2,n3,1,nv)-bnd_vars_v%var_3d(nv)%west(n1,n2,n3,1))/tboco -! (targ_3d_v_w(n1,n2,n3,1,nv)-bnd_vars_v%var_3d(nv)%west(n1,n2,n3,1))*r_tboco - enddo - enddo - enddo - enddo - deallocate(targ_3d_v_w) - endif - - ENDIF ! W_BDY - - IF (e_bdy) THEN - - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - do n2=j_lo,j_hi - do n1=1,lnsh - bnd_vars_h%var_2d(nv)%east(n1,n2,2)= & - (targ_2d_h_e(n1,n2,1,nv)-bnd_vars_h%var_2d(nv)%east(n1,n2,1))/tboco -! (targ_2d_h_e(n1,n2,1,nv)-bnd_vars_h%var_2d(nv)%east(n1,n2,1))*r_tboco - enddo - enddo - enddo - deallocate(targ_2d_h_e) - endif - - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - do n3=1,lm - do n2=j_lo,j_hi - do n1=1,lnsh - bnd_vars_h%var_3d(nv)%east(n1,n2,n3,2)= & - (targ_3d_h_e(n1,n2,n3,1,nv)-bnd_vars_h%var_3d(nv)%east(n1,n2,n3,1))/tboco -! (targ_3d_h_e(n1,n2,n3,1,nv)-bnd_vars_h%var_3d(nv)%east(n1,n2,n3,1))*r_tboco - enddo - enddo - enddo - enddo - deallocate(targ_3d_h_e) - endif - - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lbnd=lbound(bnd_vars_h%var_4d(nv)%full_var,4) - ubnd=ubound(bnd_vars_h%var_4d(nv)%full_var,4) - do n4=lbnd,ubnd - do n3=1,lm - do n2=j_lo,j_hi - do n1=1,lnsh - bnd_vars_h%var_4d(nv)%east(n1,n2,n3,2,n4)= & - (targ_4d_h_e(nv)%base(n1,n2,n3,1,nv)-bnd_vars_h%var_4d(nv)%east(n1,n2,n3,1,n4))/tboco -! (targ_4d_h_e(nv)%base(n1,n2,n3,1,nv)-bnd_vars_h%var_4d(nv)%east(n1,n2,n3,1,n4))*r_tboco - enddo - enddo - enddo - enddo - deallocate(targ_4d_h_e(nv)%base) - enddo - deallocate(targ_4d_h_e) - endif - - if(nvars_bc_2d_v>0)then - do nv=1,nvars_bc_2d_v - do n2=j_lo,j_hi - do n1=1,lnsv - bnd_vars_v%var_2d(nv)%east(n1,n2,2)= & - (targ_2d_v_e(n1,n2,1,nv)-bnd_vars_v%var_2d(nv)%east(n1,n2,1))/tboco -! (targ_2d_v_e(n1,n2,1,nv)-bnd_vars_v%var_2d(nv)%east(n1,n2,1))*r_tboco - enddo - enddo - enddo - deallocate(targ_2d_v_e) - endif - - if(nvars_bc_3d_v>0)then - do nv=1,nvars_bc_3d_v - do n3=1,lm - do n2=j_lo,j_hi - do n1=1,lnsv - bnd_vars_v%var_3d(nv)%east(n1,n2,n3,2)= & - (targ_3d_v_e(n1,n2,n3,1,nv)-bnd_vars_v%var_3d(nv)%east(n1,n2,n3,1))/tboco -! (targ_3d_v_e(n1,n2,n3,1,nv)-bnd_vars_v%var_3d(nv)%east(n1,n2,n3,1))*r_tboco - enddo - enddo - enddo - enddo - deallocate(targ_3d_v_e) - endif - - ENDIF ! E_BDY - - endif ! recomp_tend -! -!----------------------------------------------------------------------- - end subroutine write_bc -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -! - subroutine bocoh & -(lm,lnsh & -,dt,pt & -,pd,dsg2,pdsg1 & -,nvars_bc_2d_h,nvars_bc_3d_h,nvars_bc_4d_h & -,lbnd_4d,ubnd_4d & -,bnd_vars_h & -,pint) -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -implicit none -!----------------------------------------------------------------------- - -real(kind=kfpt),parameter:: & - wa=0.5 & ! weighting factor -,w1=wa*0.25 & ! weighting factor -,w2=1.-wa ! weighting factor -!----------------------------------------------------------------------- -integer(kind=kint),intent(in):: & - lm & ! total # of levels -,lnsh ! blending area width, h points - -integer(kind=kint),intent(in) :: & - nvars_bc_2d_h & ! # of 2-d h-pt boundary variables -,nvars_bc_3d_h & ! # of 3-d h-pt boundary variables -,nvars_bc_4d_h ! # of 4-d h-pt boundary variables - -integer(kind=kint),dimension(*),intent(in) :: & - lbnd_4d & ! lower index of list of 4-D h-pt boundary variables -,ubnd_4d ! upper index of list of 4-D h-pt boundary variables - -real(kind=kfpt),intent(in):: & - dt & ! dynamics time step -,pt ! pressure at the top - -real(kind=kfpt),dimension(1:lm),intent(in):: & - dsg2 & ! delta sigmas -,pdsg1 ! delta pressures - -real(kind=kfpt),dimension(ims:ime,jms:jme),intent(in):: & - pd - -type(bc_h_all),intent(inout) :: & - bnd_vars_h ! boundary variables on h points - -real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm+1),intent(inout):: & - pint ! pressure at interfaces - -!----------------------------------------------------------------------- -!---local variables----------------------------------------------------- -!----------------------------------------------------------------------- - -integer(kind=kint):: & - i & ! index in x direction -,i1 & -,i2 & -,ib & ! index in x direction, boundary zone -,ihe & ! ending index in x direction, boundaries -,ihs & ! starting index in x direction, boundaries -,j & ! index in y direction -,j1 & -,j2 & -,jb & ! index in y direction, boundary zone -,jhe & ! ending index in x direction, boundaries -,jhs & ! starting index in x direction, boundaries -,k & ! boundary line counter -,ks & ! smoothing counter -,l & ! index in p direction -,lbnd & -,lines & ! boundary smoothing area -,nl & -,nsmud & ! number of smoothing passes -,nv & -,ubnd - -real(kind=kfpt),dimension(1:lnsh):: & - wh(lnsh) & ! blending weighting function, temperature -,wq(lnsh) ! blending weighting function, moisture - -real(kind=kfpt),dimension(:,:),allocatable :: & - hbc_2d - -real(kind=kfpt),dimension(:,:,:),pointer :: temp_3d - -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- - lines=lnsh -! nsmud=lines-1 - nsmud=0 -!----------------------------------------------------------------------- - wh(1)=1. - wq(1)=1. - do k=2,lnsh - wh(k)=1.-(0.9/real(lnsh-1))*(k-1) - wq(k)=1.-(0.9/real(lnsh-1))*(k-1) - enddo -!----------------------------------------------------------------------- -!*** Update values of the boundary working objects at H points. -!----------------------------------------------------------------------- -! -!-------------------------------------- -!*** Southern and northern boundaries -!-------------------------------------- -! - if(s_bdy)then -! - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - do jb=1,lnsh - do ib=its_h2,ite_h2 - bnd_vars_h%var_2d(nv)%south(ib,jb,1)=bnd_vars_h%var_2d(nv)%south(ib,jb,1) & - +bnd_vars_h%var_2d(nv)%south(ib,jb,2)*dt - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - do l=1,lm - do jb=1,lnsh - do ib=its_h2,ite_h2 - bnd_vars_h%var_3d(nv)%south(ib,jb,l,1)=bnd_vars_h%var_3d(nv)%south(ib,jb,l,1) & - +bnd_vars_h%var_3d(nv)%south(ib,jb,l,2)*dt - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lbnd=lbnd_4d(nv) - ubnd=ubnd_4d(nv) - do nl=lbnd,ubnd - do l=1,lm - do jb=1,lnsh - do ib=its_h2,ite_h2 - bnd_vars_h%var_4d(nv)%south(ib,jb,l,1,nl)=bnd_vars_h%var_4d(nv)%south(ib,jb,l,1,nl) & - +bnd_vars_h%var_4d(nv)%south(ib,jb,l,2,nl)*dt - enddo - enddo - enddo - enddo - enddo - endif -! - endif -! - if(n_bdy)then -! - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - do jb=1,lnsh - do ib=its_h2,ite_h2 - bnd_vars_h%var_2d(nv)%north(ib,jb,1)=bnd_vars_h%var_2d(nv)%north(ib,jb,1) & - +bnd_vars_h%var_2d(nv)%north(ib,jb,2)*dt - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - do l=1,lm - do jb=1,lnsh - do ib=its_h2,ite_h2 - bnd_vars_h%var_3d(nv)%north(ib,jb,l,1)=bnd_vars_h%var_3d(nv)%north(ib,jb,l,1) & - +bnd_vars_h%var_3d(nv)%north(ib,jb,l,2)*dt - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lbnd=lbnd_4d(nv) - ubnd=ubnd_4d(nv) - do nl=lbnd,ubnd - do l=1,lm - do jb=1,lnsh - do ib=its_h2,ite_h2 - bnd_vars_h%var_4d(nv)%north(ib,jb,l,1,nl)=bnd_vars_h%var_4d(nv)%north(ib,jb,l,1,nl) & - +bnd_vars_h%var_4d(nv)%north(ib,jb,l,2,nl)*dt - enddo - enddo - enddo - enddo - enddo - endif -! - endif -! -!------------------------------------ -!*** Western and eastern boundaries -!------------------------------------ -! - if(w_bdy)then -! - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - do jb=jts_h2,jte_h2 - do ib=1,lnsh - bnd_vars_h%var_2d(nv)%west(ib,jb,1)=bnd_vars_h%var_2d(nv)%west(ib,jb,1) & - +bnd_vars_h%var_2d(nv)%west(ib,jb,2)*dt - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - do l=1,lm - do jb=jts_h2,jte_h2 - do ib=1,lnsh - bnd_vars_h%var_3d(nv)%west(ib,jb,l,1)=bnd_vars_h%var_3d(nv)%west(ib,jb,l,1) & - +bnd_vars_h%var_3d(nv)%west(ib,jb,l,2)*dt - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lbnd=lbnd_4d(nv) - ubnd=ubnd_4d(nv) - do nl=lbnd,ubnd - do l=1,lm - do jb=jts_h2,jte_h2 - do ib=1,lnsh - bnd_vars_h%var_4d(nv)%west(ib,jb,l,1,nl)=bnd_vars_h%var_4d(nv)%west(ib,jb,l,1,nl) & - +bnd_vars_h%var_4d(nv)%west(ib,jb,l,2,nl)*dt - enddo - enddo - enddo - enddo - enddo - endif -! - endif -! - if(e_bdy)then -! - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - do jb=jts_h2,jte_h2 - do ib=1,lnsh - bnd_vars_h%var_2d(nv)%east(ib,jb,1)=bnd_vars_h%var_2d(nv)%east(ib,jb,1) & - +bnd_vars_h%var_2d(nv)%east(ib,jb,2)*dt - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - do l=1,lm - do jb=jts_h2,jte_h2 - do ib=1,lnsh - bnd_vars_h%var_3d(nv)%east(ib,jb,l,1)=bnd_vars_h%var_3d(nv)%east(ib,jb,l,1) & - +bnd_vars_h%var_3d(nv)%east(ib,jb,l,2)*dt - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lbnd=lbnd_4d(nv) - ubnd=ubnd_4d(nv) - do nl=lbnd,ubnd - do l=1,lm - do jb=jts_h2,jte_h2 - do ib=1,lnsh - bnd_vars_h%var_4d(nv)%east(ib,jb,l,1,nl)=bnd_vars_h%var_4d(nv)%east(ib,jb,l,1,nl) & - +bnd_vars_h%var_4d(nv)%east(ib,jb,l,2,nl)*dt - enddo - enddo - enddo - enddo - enddo - endif -! - endif -! -!----------------------------------------------------------------------- -!*** Now update the actual prognostic variables using the values -!*** just computed (coming from the parent) blended with the values -!*** already generated in the blending region by the child. -!----------------------------------------------------------------------- -! -!----------------------- -!*** Southern boundary -!----------------------- -! - if(s_bdy)then -! - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - do j=1,lnsh - jb=j - ihs=jb - ihe=ide+1-jb - do i=max(its_h2,ihs),min(ite_h2,ihe) - ib=i - bnd_vars_h%var_2d(nv)%full_var(i,j)=bnd_vars_h%var_2d(nv)%south(ib,jb,1)*wh(jb) & - +bnd_vars_h%var_2d(nv)%full_var(i,j)*(1.-wh(jb)) - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - do l=1,lm - do j=1,lnsh - jb=j - ihs=jb - ihe=ide+1-jb - do i=max(its_h2,ihs),min(ite_h2,ihe) - ib=i - bnd_vars_h%var_3d(nv)%full_var(i,j,l)=bnd_vars_h%var_3d(nv)%south(ib,jb,l,1)*wh(jb) & - +bnd_vars_h%var_3d(nv)%full_var(i,j,l)*(1.-wh(jb)) - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lbnd=lbnd_4d(nv) - ubnd=ubnd_4d(nv) - do nl=lbnd,ubnd - do l=1,lm - do j=1,lnsh - jb=j - ihs=jb - ihe=ide+1-jb - do i=max(its_h2,ihs),min(ite_h2,ihe) - ib=i - bnd_vars_h%var_4d(nv)%full_var(i,j,l,nl)=bnd_vars_h%var_4d(nv)%south(ib,jb,l,1,nl)*wh(jb) & - +bnd_vars_h%var_4d(nv)%full_var(i,j,l,nl)*(1.-wh(jb)) - enddo - enddo - enddo - enddo - enddo - endif -! -!-------------------- -!*** The pint array -!-------------------- -! - do j=1,lnsh - jb=j - ihs=jb - ihe=ide+1-jb - do i=max(its_h2,ihs),min(ite_h2,ihe) - ib=i - pint(i,j,1)=pt - enddo - enddo -! - do l=1,lm - do j=1,lnsh - jb=j - ihs=jb - ihe=ide+1-jb - do i=max(its_h2,ihs),min(ite_h2,ihe) - ib=i - pint(i,j,l+1)=(pint(i,j,l) & - +(dsg2(l)*pd(i,j)+pdsg1(l)))*wh(jb) & - +pint(i,j,l+1)*(1.-wh(jb)) - enddo - enddo - enddo -! - endif -! -!----------------------- -!*** Northern boundary -!----------------------- -! - if(n_bdy)then -! - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - do j=jde-lnsh+1,jde - jb=j-jde+lnsh - ihs=1-jb+lnsh - ihe=ide+jb-lnsh - do i=max(its_h2,ihs),min(ite_h2,ihe) - ib=i - bnd_vars_h%var_2d(nv)%full_var(i,j)=bnd_vars_h%var_2d(nv)%north(ib,jb,1)*wh(lnsh+1-jb) & - +bnd_vars_h%var_2d(nv)%full_var(i,j)*(1.-wh(lnsh+1-jb)) - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - do l=1,lm - do j=jde-lnsh+1,jde - jb=j-jde+lnsh - ihs=1-jb+lnsh - ihe=ide+jb-lnsh - do i=max(its_h2,ihs),min(ite_h2,ihe) - ib=i - bnd_vars_h%var_3d(nv)%full_var(i,j,l)=bnd_vars_h%var_3d(nv)%north(ib,jb,l,1)*wh(lnsh+1-jb) & - +bnd_vars_h%var_3d(nv)%full_var(i,j,l)*(1.-wh(lnsh+1-jb)) - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lbnd=lbnd_4d(nv) - ubnd=ubnd_4d(nv) - do nl=lbnd,ubnd - do l=1,lm - do j=jde-lnsh+1,jde - jb=j-jde+lnsh - ihs=1-jb+lnsh - ihe=ide+jb-lnsh - do i=max(its_h2,ihs),min(ite_h2,ihe) - ib=i - bnd_vars_h%var_4d(nv)%full_var(i,j,l,nl)=bnd_vars_h%var_4d(nv)%north(ib,jb,l,1,nl)*wh(lnsh+1-jb) & - +bnd_vars_h%var_4d(nv)%full_var(i,j,l,nl)*(1.-wh(lnsh+1-jb)) - enddo - enddo - enddo - enddo - enddo - endif -! -!-------------------- -!*** The pint array -!-------------------- -! - do j=jde-lnsh+1,jde - jb=j-jde+lnsh - ihs=1-jb+lnsh - ihe=ide+jb-lnsh - do i=max(its_h2,ihs),min(ite_h2,ihe) - ib=i - pint(i,j,1)=pt - enddo - enddo -! - do l=1,lm - do j=jde-lnsh+1,jde - jb=j-jde+lnsh - ihs=1-jb+lnsh - ihe=ide+jb-lnsh - do i=max(its_h2,ihs),min(ite_h2,ihe) - ib=i - pint(i,j,l+1)=(pint(i,j,l) & - +(dsg2(l)*pd(i,j)+pdsg1(l)))*wh(lnsh+1-jb) & - +pint(i,j,l+1)*(1.-wh(lnsh+1-jb)) - enddo - enddo - enddo -! - endif -! -!---------------------- -!*** Western boundary -!---------------------- -! - if(w_bdy)then -! - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - do i=1,lnsh - ib=i - jhs=1+ib - jhe=jde-ib - do j=max(jts_h2,jhs),min(jte_h2,jhe) - jb=j - bnd_vars_h%var_2d(nv)%full_var(i,j)=bnd_vars_h%var_2d(nv)%west(ib,jb,1)*wh(ib) & - +bnd_vars_h%var_2d(nv)%full_var(i,j)*(1.-wh(ib)) - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - do l=1,lm - do i=1,lnsh - ib=i - jhs=1+ib - jhe=jde-ib - do j=max(jts_h2,jhs),min(jte_h2,jhe) - jb=j - bnd_vars_h%var_3d(nv)%full_var(i,j,l)=bnd_vars_h%var_3d(nv)%west(ib,jb,l,1)*wh(ib) & - +bnd_vars_h%var_3d(nv)%full_var(i,j,l)*(1.-wh(ib)) - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lbnd=lbnd_4d(nv) - ubnd=ubnd_4d(nv) - do nl=lbnd,ubnd - do l=1,lm - do i=1,lnsh - ib=i - jhs=1+ib - jhe=jde-ib - do j=max(jts_h2,jhs),min(jte_h2,jhe) - jb=j - bnd_vars_h%var_4d(nv)%full_var(i,j,l,nl)=bnd_vars_h%var_4d(nv)%west(ib,jb,l,1,nl)*wh(ib) & - +bnd_vars_h%var_4d(nv)%full_var(i,j,l,nl)*(1.-wh(ib)) - enddo - enddo - enddo - enddo - enddo - endif -! -!-------------------- -!*** The pint array -!-------------------- -! - do i=1,lnsh - ib=i - jhs=1+ib - jhe=jde-ib - do j=max(jts_h2,jhs),min(jte_h2,jhe) - jb=j - pint(i,j,1)=pt - enddo - enddo -! - do l=1,lm - do i=1,lnsh - ib=i - jhs=1+ib - jhe=jde-ib - do j=max(jts_h2,jhs),min(jte_h2,jhe) - jb=j - pint(i,j,l+1)=(pint(i,j,l) & - +(dsg2(l)*pd(i,j)+pdsg1(l)))*wh(ib) & - +pint(i,j,l+1)*(1.-wh(ib)) - enddo - enddo - enddo -! - endif -! -!---------------------- -!*** Eastern boundary -!---------------------- -! - if(e_bdy)then -! - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - do i=ide+1-lnsh,ide - ib=i-ide+lnsh - jhs=2+lnsh-ib - jhe=jde-lnsh-1+ib - do j=max(jts_h2,jhs),min(jte_h2,jhe) - jb=j - bnd_vars_h%var_2d(nv)%full_var(i,j)=bnd_vars_h%var_2d(nv)%east(ib,jb,1)*wh(lnsh+1-ib) & - +bnd_vars_h%var_2d(nv)%full_var(i,j)*(1.-wh(lnsh+1-ib)) - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - do l=1,lm - do i=ide+1-lnsh,ide - ib=i-ide+lnsh - jhs=2+lnsh-ib - jhe=jde-lnsh-1+ib - do j=max(jts_h2,jhs),min(jte_h2,jhe) - jb=j - bnd_vars_h%var_3d(nv)%full_var(i,j,l)=bnd_vars_h%var_3d(nv)%east(ib,jb,l,1)*wh(lnsh+1-ib) & - +bnd_vars_h%var_3d(nv)%full_var(i,j,l)*(1.-wh(lnsh+1-ib)) - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lbnd=lbnd_4d(nv) - ubnd=ubnd_4d(nv) - do nl=lbnd,ubnd - do l=1,lm - do i=ide+1-lnsh,ide - ib=i-ide+lnsh - jhs=2+lnsh-ib - jhe=jde-lnsh-1+ib - do j=max(jts_h2,jhs),min(jte_h2,jhe) - jb=j - bnd_vars_h%var_4d(nv)%full_var(i,j,l,nl)=bnd_vars_h%var_4d(nv)%east(ib,jb,l,1,nl)*wh(lnsh+1-ib) & - +bnd_vars_h%var_4d(nv)%full_var(i,j,l,nl)*(1.-wh(lnsh+1-ib)) - enddo - enddo - enddo - enddo - enddo - endif -! -!-------------------- -!*** The pint array -!-------------------- -! - do i=ide+1-lnsh,ide - ib=i-ide+lnsh - jhs=2+lnsh-ib - jhe=jde-lnsh-1+ib - do j=max(jts_h2,jhs),min(jte_h2,jhe) - jb=j - pint(i,j,1)=pt - enddo - enddo -! - do l=1,lm - do i=ide+1-lnsh,ide - ib=i-ide+lnsh - jhs=2+lnsh-ib - jhe=jde-lnsh-1+ib - do j=max(jts_h2,jhs),min(jte_h2,jhe) - jb=j - pint(i,j,l+1)=(pint(i,j,l) & - +(dsg2(l)*pd(i,j)+pdsg1(l)))*wh(lnsh+1-ib) & - +pint(i,j,l+1)*(1.-wh(lnsh+1-ib)) - enddo - enddo - enddo -! - endif -! -!----------------------------------------------------------------------- -!*** The four corner points. -!----------------------------------------------------------------------- -! -!----------------------------- - if(s_bdy.and.w_bdy)then -!----------------------------- -! - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - bnd_vars_h%var_2d(nv)%full_var(its+1,jts+1)= & - (bnd_vars_h%var_2d(nv)%full_var(its+1,jts) & - +bnd_vars_h%var_2d(nv)%full_var(its,jts+1) & - +bnd_vars_h%var_2d(nv)%full_var(its+2,jts+1) & - +bnd_vars_h%var_2d(nv)%full_var(its+1,jts+2))*0.25 - enddo - endif -! - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - do l=1,lm - bnd_vars_h%var_3d(nv)%full_var(its+1,jts+1,l)= & - (bnd_vars_h%var_3d(nv)%full_var(its+1,jts,l) & - +bnd_vars_h%var_3d(nv)%full_var(its,jts+1,l) & - +bnd_vars_h%var_3d(nv)%full_var(its+2,jts+1,l) & - +bnd_vars_h%var_3d(nv)%full_var(its+1,jts+2,l))*0.25 - enddo - enddo - endif -! - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lbnd=lbnd_4d(nv) - ubnd=ubnd_4d(nv) - do nl=lbnd,ubnd - do l=1,lm - bnd_vars_h%var_4d(nv)%full_var(its+1,jts+1,l,nl)= & - (bnd_vars_h%var_4d(nv)%full_var(its+1,jts,l,nl) & - +bnd_vars_h%var_4d(nv)%full_var(its,jts+1,l,nl) & - +bnd_vars_h%var_4d(nv)%full_var(its+2,jts+1,l,nl) & - +bnd_vars_h%var_4d(nv)%full_var(its+1,jts+2,l,nl))*0.25 - enddo - enddo - enddo - endif -! - endif -! -!----------------------------- - if(s_bdy.and.e_bdy)then -!----------------------------- -! - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - bnd_vars_h%var_2d(nv)%full_var(ite-1,jts+1)= & - (bnd_vars_h%var_2d(nv)%full_var(ite-1,jts) & - +bnd_vars_h%var_2d(nv)%full_var(ite-2,jts+1) & - +bnd_vars_h%var_2d(nv)%full_var(ite,jts+1) & - +bnd_vars_h%var_2d(nv)%full_var(ite-1,jts+2))*0.25 - enddo - endif -! - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - do l=1,lm - bnd_vars_h%var_3d(nv)%full_var(ite-1,jts+1,l)= & - (bnd_vars_h%var_3d(nv)%full_var(ite-1,jts,l) & - +bnd_vars_h%var_3d(nv)%full_var(ite-2,jts+1,l) & - +bnd_vars_h%var_3d(nv)%full_var(ite,jts+1,l) & - +bnd_vars_h%var_3d(nv)%full_var(ite-1,jts+2,l))*0.25 - enddo - enddo - endif -! - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lbnd=lbnd_4d(nv) - ubnd=ubnd_4d(nv) - do nl=lbnd,ubnd - do l=1,lm - bnd_vars_h%var_4d(nv)%full_var(ite-1,jts+1,l,nl)= & - (bnd_vars_h%var_4d(nv)%full_var(ite-1,jts,l,nl) & - +bnd_vars_h%var_4d(nv)%full_var(ite-2,jts+1,l,nl) & - +bnd_vars_h%var_4d(nv)%full_var(ite,jts+1,l,nl) & - +bnd_vars_h%var_4d(nv)%full_var(ite-1,jts+2,l,nl))*0.25 - enddo - enddo - enddo - endif -! - endif -! -!----------------------------- - if(n_bdy.and.w_bdy)then -!----------------------------- -! - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - bnd_vars_h%var_2d(nv)%full_var(its+1,jte-1)= & - (bnd_vars_h%var_2d(nv)%full_var(its+1,jte-2) & - +bnd_vars_h%var_2d(nv)%full_var(its,jte-1) & - +bnd_vars_h%var_2d(nv)%full_var(its+2,jte-1) & - +bnd_vars_h%var_2d(nv)%full_var(its+1,jte))*0.25 - enddo - endif -! - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - do l=1,lm - bnd_vars_h%var_3d(nv)%full_var(its+1,jte-1,l)= & - (bnd_vars_h%var_3d(nv)%full_var(its+1,jte-2,l) & - +bnd_vars_h%var_3d(nv)%full_var(its,jte-1,l) & - +bnd_vars_h%var_3d(nv)%full_var(its+2,jte-1,l) & - +bnd_vars_h%var_3d(nv)%full_var(its+1,jte,l))*0.25 - enddo - enddo - endif -! - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lbnd=lbnd_4d(nv) - ubnd=ubnd_4d(nv) - do nl=lbnd,ubnd - do l=1,lm - bnd_vars_h%var_4d(nv)%full_var(its+1,jte-1,l,nl)= & - (bnd_vars_h%var_4d(nv)%full_var(its+1,jte-2,l,nl) & - +bnd_vars_h%var_4d(nv)%full_var(its,jte-1,l,nl) & - +bnd_vars_h%var_4d(nv)%full_var(its+2,jte-1,l,nl) & - +bnd_vars_h%var_4d(nv)%full_var(its+1,jte,l,nl))*0.25 - enddo - enddo - enddo - endif -! - endif -! -!----------------------------- - if(n_bdy.and.e_bdy)then -!----------------------------- -! - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - bnd_vars_h%var_2d(nv)%full_var(ite-1,jte-1)= & - (bnd_vars_h%var_2d(nv)%full_var(ite-1,jte-2) & - +bnd_vars_h%var_2d(nv)%full_var(ite-2,jte-1) & - +bnd_vars_h%var_2d(nv)%full_var(ite,jte-1) & - +bnd_vars_h%var_2d(nv)%full_var(ite-1,jte))*0.25 - enddo - endif -! - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - do l=1,lm - bnd_vars_h%var_3d(nv)%full_var(ite-1,jte-1,l)= & - (bnd_vars_h%var_3d(nv)%full_var(ite-1,jte-2,l) & - +bnd_vars_h%var_3d(nv)%full_var(ite-2,jte-1,l) & - +bnd_vars_h%var_3d(nv)%full_var(ite,jte-1,l) & - +bnd_vars_h%var_3d(nv)%full_var(ite-1,jte,l))*0.25 - enddo - enddo - endif -! - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lbnd=lbnd_4d(nv) - ubnd=ubnd_4d(nv) - do nl=lbnd,ubnd - do l=1,lm - bnd_vars_h%var_4d(nv)%full_var(ite-1,jte-1,l,nl)= & - (bnd_vars_h%var_4d(nv)%full_var(ite-1,jte-2,l,nl) & - +bnd_vars_h%var_4d(nv)%full_var(ite-2,jte-1,l,nl) & - +bnd_vars_h%var_4d(nv)%full_var(ite,jte-1,l,nl) & - +bnd_vars_h%var_4d(nv)%full_var(ite-1,jte,l,nl))*0.25 - enddo - enddo - enddo - endif -! - endif -! -!----------------------------------------------------------------------- -! - if(s_bdy)then - do j=jts,jts+1 - do i=its_h2,ite_h2 - pint(i,j,1)=pt - enddo - enddo -! - do l=1,lm - do j=jts,jts+1 - do i=its_h2,ite_h2 - pint(i,j,l+1)=pint(i,j,l)+(dsg2(l)*pd(i,j)+pdsg1(l)) - enddo - enddo - enddo - endif -! - if(n_bdy)then - do j=jte-1,jte - do i=its_h2,ite_h2 - pint(i,j,1)=pt - enddo - enddo -! - do l=1,lm - do j=jte-1,jte - do i=its_h2,ite_h2 - pint(i,j,l+1)=pint(i,j,l)+(dsg2(l)*pd(i,j)+pdsg1(l)) - enddo - enddo - enddo - endif -! - if(w_bdy)then - do j=jts_h2,jte_h2 - do i=its,its+1 - pint(i,j,1)=pt - enddo - enddo -! - do l=1,lm - do j=jts_h2,jte_h2 - do i=its,its+1 - pint(i,j,l+1)=pint(i,j,l)+(dsg2(l)*pd(i,j)+pdsg1(l)) - enddo - enddo - enddo - endif -! - if(e_bdy)then - do j=jts_h2,jte_h2 - do i=ite-1,ite - pint(i,j,1)=pt - enddo - enddo -! - do l=1,lm - do j=jts_h2,jte_h2 - do i=ite-1,ite - pint(i,j,l+1)=pint(i,j,l)+(dsg2(l)*pd(i,j)+pdsg1(l)) - enddo - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** The following is executed if spatial smoothing is invoked. -!----------------------------------------------------------------------- -! - if(nsmud>=1)then -! - smooth: do ks=1,nsmud -! -!----------------------------------------------------------------------- -! -!----------- -!*** South -!----------- -! - if(s_bdy)then - i1=max(its_h2,ids+1) - i2=min(ite_h2,ide-1) - j1=jts+1 - j2=jts-1+lines - allocate(hbc_2d(i1:i2,j1:j2)) -! - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - do j=j1,j2 - do i=i1,i2 - hbc_2d(i,j)=(bnd_vars_h%var_2d(nv)%full_var(i,j-1) & - +bnd_vars_h%var_2d(nv)%full_var(i-1,j) & - +bnd_vars_h%var_2d(nv)%full_var(i+1,j) & - +bnd_vars_h%var_2d(nv)%full_var(i,j+1))*w1 & - +w2*bnd_vars_h%var_2d(nv)%full_var(i,j) - enddo - enddo -! - do j=j1,j2 - do i=i1,i2 - bnd_vars_h%var_2d(nv)%full_var(i,j)=hbc_2d(i,j) - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - do l=1,lm - do j=j1,j2 - do i=i1,i2 - hbc_2d(i,j)=(bnd_vars_h%var_3d(nv)%full_var(i,j-1,l) & - +bnd_vars_h%var_3d(nv)%full_var(i-1,j,l) & - +bnd_vars_h%var_3d(nv)%full_var(i+1,j,l) & - +bnd_vars_h%var_3d(nv)%full_var(i,j+1,l))*w1 & - +w2*bnd_vars_h%var_3d(nv)%full_var(i,j,l) - enddo - enddo - do j=j1,j2 - do i=i1,i2 - bnd_vars_h%var_3d(nv)%full_var(i,j,l)=hbc_2d(i,j) - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lbnd=lbnd_4d(nv) - ubnd=ubnd_4d(nv) - do nl=lbnd,ubnd - do l=1,lm - do j=j1,j2 - do i=i1,i2 - hbc_2d(i,j)=(bnd_vars_h%var_4d(nv)%full_var(i,j-1,l,nl) & - +bnd_vars_h%var_4d(nv)%full_var(i-1,j,l,nl) & - +bnd_vars_h%var_4d(nv)%full_var(i+1,j,l,nl) & - +bnd_vars_h%var_4d(nv)%full_var(i,j+1,l,nl))*w1 & - +w2*bnd_vars_h%var_4d(nv)%full_var(i,j,l,nl) - enddo - enddo - do j=j1,j2 - do i=i1,i2 - bnd_vars_h%var_4d(nv)%full_var(i,j,l,nl)=hbc_2d(i,j) - enddo - enddo - enddo - enddo - enddo - endif -! - do l=1,lm - do j=j1,j2 - do i=i1,i2 - hbc_2d(i,j)=(pint(i,j-1,l+1)+pint(i-1,j,l+1) & - +pint(i+1,j,l+1)+pint(i,j+1,l+1))*w1 & - +w2*pint(i,j,l+1) - enddo - enddo - do j=j1,j2 - do i=i1,i2 - pint(i,j,l+1)=hbc_2d(i,j) - enddo - enddo - enddo -! - deallocate(hbc_2d) - endif -! -!----------- -!*** North -!----------- -! - if(n_bdy)then - i1=max(its_h2,ids+1) - i2=min(ite_h2,ide-1) - j1=jte-lines+1 - j2=jte-1 - allocate(hbc_2d(i1:i2,j1:j2)) -! - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - do j=j1,j2 - do i=i1,i2 - hbc_2d(i,j)=(bnd_vars_h%var_2d(nv)%full_var(i,j-1) & - +bnd_vars_h%var_2d(nv)%full_var(i-1,j) & - +bnd_vars_h%var_2d(nv)%full_var(i+1,j) & - +bnd_vars_h%var_2d(nv)%full_var(i,j+1))*w1 & - +w2*bnd_vars_h%var_2d(nv)%full_var(i,j) - enddo - enddo -! - do j=j1,j2 - do i=i1,i2 - bnd_vars_h%var_2d(nv)%full_var(i,j)=hbc_2d(i,j) - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - do l=1,lm - do j=j1,j2 - do i=i1,i2 - hbc_2d(i,j)=(bnd_vars_h%var_3d(nv)%full_var(i,j-1,l) & - +bnd_vars_h%var_3d(nv)%full_var(i-1,j,l) & - +bnd_vars_h%var_3d(nv)%full_var(i+1,j,l) & - +bnd_vars_h%var_3d(nv)%full_var(i,j+1,l))*w1 & - +w2*bnd_vars_h%var_3d(nv)%full_var(i,j,l) - enddo - enddo - do j=j1,j2 - do i=i1,i2 - bnd_vars_h%var_3d(nv)%full_var(i,j,l)=hbc_2d(i,j) - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lbnd=lbnd_4d(nv) - ubnd=ubnd_4d(nv) - do nl=lbnd,ubnd - do l=1,lm - do j=j1,j2 - do i=i1,i2 - hbc_2d(i,j)=(bnd_vars_h%var_4d(nv)%full_var(i,j-1,l,nl) & - +bnd_vars_h%var_4d(nv)%full_var(i-1,j,l,nl) & - +bnd_vars_h%var_4d(nv)%full_var(i+1,j,l,nl) & - +bnd_vars_h%var_4d(nv)%full_var(i,j+1,l,nl))*w1 & - +w2*bnd_vars_h%var_4d(nv)%full_var(i,j,l,nl) - enddo - enddo - do j=j1,j2 - do i=i1,i2 - bnd_vars_h%var_4d(nv)%full_var(i,j,l,nl)=hbc_2d(i,j) - enddo - enddo - enddo - enddo - enddo - endif -! - do l=1,lm - do j=j1,j2 - do i=i1,i2 - hbc_2d(i,j)=(pint(i,j-1,l+1)+pint(i-1,j,l+1) & - +pint(i+1,j,l+1)+pint(i,j+1,l+1))*w1 & - +w2*pint(i,j,l+1) - enddo - enddo - do j=j1,j2 - do i=i1,i2 - pint(i,j,l+1)=hbc_2d(i,j) - enddo - enddo - enddo -! - deallocate(hbc_2d) - endif -! -!---------- -!*** West -!---------- -! - if(w_bdy)then - i1=its+1 - i2=its-1+lines - j1=max(jts_h2,jds+lines) - j2=min(jte_h2,jde-lines) - allocate(hbc_2d(i1:i2,j1:j2)) -! - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - do j=j1,j2 - do i=i1,i2 - hbc_2d(i,j)=(bnd_vars_h%var_2d(nv)%full_var(i,j-1) & - +bnd_vars_h%var_2d(nv)%full_var(i-1,j) & - +bnd_vars_h%var_2d(nv)%full_var(i+1,j) & - +bnd_vars_h%var_2d(nv)%full_var(i,j+1))*w1 & - +w2*bnd_vars_h%var_2d(nv)%full_var(i,j) - enddo - enddo -! - do j=j1,j2 - do i=i1,i2 - bnd_vars_h%var_2d(nv)%full_var(i,j)=hbc_2d(i,j) - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - do l=1,lm - do j=j1,j2 - do i=i1,i2 - hbc_2d(i,j)=(bnd_vars_h%var_3d(nv)%full_var(i,j-1,l) & - +bnd_vars_h%var_3d(nv)%full_var(i-1,j,l) & - +bnd_vars_h%var_3d(nv)%full_var(i+1,j,l) & - +bnd_vars_h%var_3d(nv)%full_var(i,j+1,l))*w1 & - +w2*bnd_vars_h%var_3d(nv)%full_var(i,j,l) - enddo - enddo - do j=j1,j2 - do i=i1,i2 - bnd_vars_h%var_3d(nv)%full_var(i,j,l)=hbc_2d(i,j) - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lbnd=lbnd_4d(nv) - ubnd=ubnd_4d(nv) - do nl=lbnd,ubnd - do l=1,lm - do j=j1,j2 - do i=i1,i2 - hbc_2d(i,j)=(bnd_vars_h%var_4d(nv)%full_var(i,j-1,l,nl) & - +bnd_vars_h%var_4d(nv)%full_var(i-1,j,l,nl) & - +bnd_vars_h%var_4d(nv)%full_var(i+1,j,l,nl) & - +bnd_vars_h%var_4d(nv)%full_var(i,j+1,l,nl))*w1 & - +w2*bnd_vars_h%var_4d(nv)%full_var(i,j,l,nl) - enddo - enddo - do j=j1,j2 - do i=i1,i2 - bnd_vars_h%var_4d(nv)%full_var(i,j,l,nl)=hbc_2d(i,j) - enddo - enddo - enddo - enddo - enddo - endif -! - do l=1,lm - do j=j1,j2 - do i=i1,i2 - hbc_2d(i,j)=(pint(i,j-1,l+1)+pint(i-1,j,l+1) & - +pint(i+1,j,l+1)+pint(i,j+1,l+1))*w1 & - +w2*pint(i,j,l+1) - enddo - enddo - do j=j1,j2 - do i=i1,i2 - pint(i,j,l+1)=hbc_2d(i,j) - enddo - enddo - enddo -! - deallocate(hbc_2d) - endif -! -!---------- -!*** East -!---------- -! - if(e_bdy)then - i1=ite-lines+1 - i2=ite-1 - j1=max(jts_h2,jds+lines) - j2=min(jte_h2,jde-lines) - allocate(hbc_2d(i1:i2,j1:j2)) -! - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - do j=j1,j2 - do i=i1,i2 - hbc_2d(i,j)=(bnd_vars_h%var_2d(nv)%full_var(i,j-1) & - +bnd_vars_h%var_2d(nv)%full_var(i-1,j) & - +bnd_vars_h%var_2d(nv)%full_var(i+1,j) & - +bnd_vars_h%var_2d(nv)%full_var(i,j+1))*w1 & - +w2*bnd_vars_h%var_2d(nv)%full_var(i,j) - enddo - enddo -! - do j=j1,j2 - do i=i1,i2 - bnd_vars_h%var_2d(nv)%full_var(i,j)=hbc_2d(i,j) - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - do l=1,lm - do j=j1,j2 - do i=i1,i2 - hbc_2d(i,j)=(bnd_vars_h%var_3d(nv)%full_var(i,j-1,l) & - +bnd_vars_h%var_3d(nv)%full_var(i-1,j,l) & - +bnd_vars_h%var_3d(nv)%full_var(i+1,j,l) & - +bnd_vars_h%var_3d(nv)%full_var(i,j+1,l))*w1 & - +w2*bnd_vars_h%var_3d(nv)%full_var(i,j,l) - enddo - enddo - do j=j1,j2 - do i=i1,i2 - bnd_vars_h%var_3d(nv)%full_var(i,j,l)=hbc_2d(i,j) - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lbnd=lbnd_4d(nv) - ubnd=ubnd_4d(nv) - do nl=lbnd,ubnd - do l=1,lm - do j=j1,j2 - do i=i1,i2 - hbc_2d(i,j)=(bnd_vars_h%var_4d(nv)%full_var(i,j-1,l,nl) & - +bnd_vars_h%var_4d(nv)%full_var(i-1,j,l,nl) & - +bnd_vars_h%var_4d(nv)%full_var(i+1,j,l,nl) & - +bnd_vars_h%var_4d(nv)%full_var(i,j+1,l,nl))*w1 & - +w2*bnd_vars_h%var_4d(nv)%full_var(i,j,l,nl) - enddo - enddo - do j=j1,j2 - do i=i1,i2 - bnd_vars_h%var_4d(nv)%full_var(i,j,l,nl)=hbc_2d(i,j) - enddo - enddo - enddo - enddo - enddo - endif -! - do l=1,lm - do j=j1,j2 - do i=i1,i2 - hbc_2d(i,j)=(pint(i,j-1,l+1)+pint(i-1,j,l+1) & - +pint(i+1,j,l+1)+pint(i,j+1,l+1))*w1 & - +w2*pint(i,j,l+1) - enddo - enddo - do j=j1,j2 - do i=i1,i2 - pint(i,j,l+1)=hbc_2d(i,j) - enddo - enddo - enddo -! - deallocate(hbc_2d) - endif -! -!----------------------------------------------------------------------- -! - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - call halo_exch(bnd_vars_h%var_2d(nv)%full_var,1,1,1) - enddo - endif -! - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - call halo_exch(bnd_vars_h%var_3d(nv)%full_var,lm,1,1) - enddo - endif -! - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lbnd=lbnd_4d(nv) - ubnd=ubnd_4d(nv) - do nl=lbnd,ubnd - temp_3d=>bnd_vars_h%var_4d(nv)%full_var(:,:,:,nl) - call halo_exch(temp_3d,lm,1,1) - enddo - enddo - endif -! - call halo_exch(pint,lm+1,1,1) -! -!----------------------------------------------------------------------- -! - enddo smooth -! - endif -! -!----------------------------------------------------------------------- -! - endsubroutine bocoh -! -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- - subroutine bocov & -(lm,lnsv & -,dt & -,nvars_bc_2d_v,nvars_bc_3d_v & -,bnd_vars_v & - ) -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -implicit none -!----------------------------------------------------------------------- - -real(kind=kfpt),parameter:: & - wa=0.5 & ! weighting factor -,w1=wa*0.25 & ! weighting factor -,w2=1.-wa ! weighting factor - -!----------------------------------------------------------------------- - -integer(kind=kint),intent(in):: & - lm & ! total # of levels -,lnsv ! blending area width, v points - -integer(kind=kint),intent(in):: & - nvars_bc_2d_v & ! # of 2-d v-pt boundary variables -,nvars_bc_3d_v ! # of 3-d v-pt boundary variables - -real(kind=kfpt),intent(in):: & - dt ! dynamics time step - -type(bc_v_all),intent(inout) :: & - bnd_vars_v ! boundary variables on v points - -!----------------------------------------------------------------------- -!---local variables----------------------------------------------------- -!----------------------------------------------------------------------- -integer(kind=kint):: & - i & ! index in x direction -,i1 & -,i2 & -,ib & ! index in x direction, boundary zone -,ive & ! ending index in x direction, boundaries -,ivs & ! starting index in x direction, boundaries -,j & ! index in y direction -,j1 & -,j2 & -,jb & ! index in y direction, boundary zone -,jve & ! ending index in x direction, boundaries -,jvs & ! starting index in x direction, boundaries -,k & ! boundary line counter -,ks & ! smoothing counter -,l & ! index in p direction -,lines & ! boundary smoothing area -,nsmud & ! number of smoothing passes -,nv - -real(kind=kfpt),dimension(1:lnsv):: & - wv(lnsv) ! blending weighting function, wind - -real(kind=kfpt),dimension(:,:),allocatable :: & - vbc_2d -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- - lines=lnsv -! nsmud=lines-1 - nsmud=0 -!----------------------------------------------------------------------- - wv(1)=1. - do k=2,lnsv - wv(k)=1.-(0.9/real(lnsv-1))*(k-1) - enddo -!----------------------------------------------------------------------- -!*** Update values of the boundary working objects at V points. -!----------------------------------------------------------------------- -! -!-------------------------------------- -!*** Southern and northern boundaries -!-------------------------------------- -! - if(s_bdy)then -! - if(nvars_bc_2d_v>0)then - do nv=1,nvars_bc_2d_v - do jb=1,lnsv - do ib=its_h2,min(ite_h2,ide-1) - bnd_vars_v%var_2d(nv)%south(ib,jb,1)=bnd_vars_v%var_2d(nv)%south(ib,jb,1) & - +bnd_vars_v%var_2d(nv)%south(ib,jb,2)*dt - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_v>0)then - do nv=1,nvars_bc_3d_v - do l=1,lm - do jb=1,lnsv - do ib=its_h2,min(ite_h2,ide-1) - bnd_vars_v%var_3d(nv)%south(ib,jb,l,1)=bnd_vars_v%var_3d(nv)%south(ib,jb,l,1) & - +bnd_vars_v%var_3d(nv)%south(ib,jb,l,2)*dt - enddo - enddo - enddo - enddo - endif -! - endif -! - if(n_bdy)then -! - if(nvars_bc_2d_v>0)then - do nv=1,nvars_bc_2d_v - do jb=1,lnsv - do ib=its_h2,min(ite_h2,ide-1) - bnd_vars_v%var_2d(nv)%north(ib,jb,1)=bnd_vars_v%var_2d(nv)%north(ib,jb,1) & - +bnd_vars_v%var_2d(nv)%north(ib,jb,2)*dt - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_v>0)then - do nv=1,nvars_bc_3d_v - do l=1,lm - do jb=1,lnsv - do ib=its_h2,min(ite_h2,ide-1) - bnd_vars_v%var_3d(nv)%north(ib,jb,l,1)=bnd_vars_v%var_3d(nv)%north(ib,jb,l,1) & - +bnd_vars_v%var_3d(nv)%north(ib,jb,l,2)*dt - enddo - enddo - enddo - enddo - endif -! - endif -! -!------------------------------------ -!*** Western and eastern boundaries -!------------------------------------ -! - if(w_bdy)then -! - if(nvars_bc_2d_v>0)then - do nv=1,nvars_bc_2d_v - do jb=jts_h2,min(jte_h2,jde-1) - do ib=1,lnsv - bnd_vars_v%var_2d(nv)%west(ib,jb,1)=bnd_vars_v%var_2d(nv)%west(ib,jb,1) & - +bnd_vars_v%var_2d(nv)%west(ib,jb,2)*dt - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_v>0)then - do nv=1,nvars_bc_3d_v - do l=1,lm - do jb=jts_h2,min(jte_h2,jde-1) - do ib=1,lnsv - bnd_vars_v%var_3d(nv)%west(ib,jb,l,1)=bnd_vars_v%var_3d(nv)%west(ib,jb,l,1) & - +bnd_vars_v%var_3d(nv)%west(ib,jb,l,2)*dt - enddo - enddo - enddo - enddo - endif -! - endif -! - if(e_bdy)then -! - if(nvars_bc_2d_v>0)then - do nv=1,nvars_bc_2d_v - do jb=jts_h1,min(jte_h2,jde-1) - do ib=1,lnsv - bnd_vars_v%var_2d(nv)%east(ib,jb,1)=bnd_vars_v%var_2d(nv)%east(ib,jb,1) & - +bnd_vars_v%var_2d(nv)%east(ib,jb,2)*dt - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_v>0)then - do nv=1,nvars_bc_3d_v - do l=1,lm - do jb=jts_h1,min(jte_h2,jde-1) - do ib=1,lnsv - bnd_vars_v%var_3d(nv)%east(ib,jb,l,1)=bnd_vars_v%var_3d(nv)%east(ib,jb,l,1) & - +bnd_vars_v%var_3d(nv)%east(ib,jb,l,2)*dt - enddo - enddo - enddo - enddo - endif -! - endif -! -!----------------------------------------------------------------------- -!*** Now update the actual prognostic variables using the values -!*** just computed (coming from the parent) blended with the values -!*** already generated in the blending region by the child. -!----------------------------------------------------------------------- -! -!----------------------- -!*** Southern boundary -!----------------------- -! - if(s_bdy)then -! - if(nvars_bc_2d_v>0)then - do nv=1,nvars_bc_2d_v - do j=jts,jts-1+lnsv - jb=j - ivs=max(its_h1,jb) - ive=min(ite_h1,ide-jb) - do i=ivs,ive - ib=i - bnd_vars_v%var_2d(nv)%full_var(i,j)=bnd_vars_v%var_2d(nv)%south(ib,jb,1)*wv(jb) & - +bnd_vars_v%var_2d(nv)%full_var(i,j)*(1.-wv(jb)) - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_v>0)then - do nv=1,nvars_bc_3d_v - do l=1,lm - do j=jts,jts-1+lnsv - jb=j - ivs=max(its_h1,jb) - ive=min(ite_h1,ide-jb) - do i=ivs,ive - ib=i - bnd_vars_v%var_3d(nv)%full_var(i,j,l)=bnd_vars_v%var_3d(nv)%south(ib,jb,l,1)*wv(jb) & - +bnd_vars_v%var_3d(nv)%full_var(i,j,l)*(1.-wv(jb)) - enddo - enddo - enddo - enddo - endif -! - endif -! -!----------------------- -!*** Northern boundary -!----------------------- -! - if(n_bdy)then -! - if(nvars_bc_2d_v>0)then - do nv=1,nvars_bc_2d_v - do j=jte-lnsv,jte-1 - jb=j-jte+lnsv+1 - ivs=max(its_h1,lnsv-jb+1) - ive=min(ite_h1,ide+jb-lnsv-1) - do i=ivs,ive - ib=i - bnd_vars_v%var_2d(nv)%full_var(i,j)=bnd_vars_v%var_2d(nv)%north(ib,jb,1)*wv(lnsv+1-jb) & - +bnd_vars_v%var_2d(nv)%full_var(i,j)*(1.-wv(lnsv+1-jb)) - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_v>0)then - do nv=1,nvars_bc_3d_v - do l=1,lm - do j=jte-lnsv,jte-1 - jb=j-jte+lnsv+1 - ivs=max(its_h1,lnsv-jb+1) - ive=min(ite_h1,ide+jb-lnsv-1) - do i=max(its_h2,ivs),min(ite_h2,ive) - ib=i - bnd_vars_v%var_3d(nv)%full_var(i,j,l)=bnd_vars_v%var_3d(nv)%north(ib,jb,l,1)*wv(lnsv+1-jb) & - +bnd_vars_v%var_3d(nv)%full_var(i,j,l)*(1.-wv(lnsv+1-jb)) - enddo - enddo - enddo - enddo - endif -! - endif -! -! -!---------------------- -!*** Western boundary -!---------------------- -! - if(w_bdy)then -! - if(nvars_bc_2d_v>0)then - do nv=1,nvars_bc_2d_v - do i=its,its-1+lnsv - ib=i - jvs=max(jts_h1,1+ib) - jve=min(jte_h1,jde-1-ib) - do j=jvs,jve - jb=j - bnd_vars_v%var_2d(nv)%full_var(i,j)=bnd_vars_v%var_2d(nv)%west(ib,jb,1)*wv(ib) & - +bnd_vars_v%var_2d(nv)%full_var(i,j)*(1.-wv(ib)) - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_v>0)then - do nv=1,nvars_bc_3d_v - do l=1,lm - do i=its,its-1+lnsv - ib=i - jvs=max(jts_h1,1+ib) - jve=min(jte_h1,jde-1-ib) - do j=jvs,jve - jb=j - bnd_vars_v%var_3d(nv)%full_var(i,j,l)=bnd_vars_v%var_3d(nv)%west(ib,jb,l,1)*wv(ib) & - +bnd_vars_v%var_3d(nv)%full_var(i,j,l)*(1.-wv(ib)) - enddo - enddo - enddo - enddo - endif -! - endif -! -!---------------------- -!*** Eastern boundary -!---------------------- -! - if(e_bdy)then -! - if(nvars_bc_2d_v>0)then - do nv=1,nvars_bc_2d_v - do i=ite-lnsv,ite-1 - ib=i-ide+lnsv+1 - jvs=max(jts_h1,lnsv-ib+2) - jve=min(jte_h1,jde-lnsv+ib-2) - do j=jvs,jve - jb=j - bnd_vars_v%var_2d(nv)%full_var(i,j)=bnd_vars_v%var_2d(nv)%east(ib,jb,1)*wv(lnsv+1-ib) & - +bnd_vars_v%var_2d(nv)%full_var(i,j)*(1.-wv(lnsv+1-ib)) - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_v>0)then - do nv=1,nvars_bc_3d_v - do l=1,lm - do i=ite-lnsv,ite-1 - ib=i-ide+lnsv+1 - jvs=max(jts_h1,lnsv-ib+2) - jve=min(jte_h1,jde-lnsv+ib-2) - do j=jvs,jve - jb=j - bnd_vars_v%var_3d(nv)%full_var(i,j,l)=bnd_vars_v%var_3d(nv)%east(ib,jb,l,1)*wv(lnsv+1-ib) & - +bnd_vars_v%var_3d(nv)%full_var(i,j,l)*(1.-wv(lnsv+1-ib)) - enddo - enddo - enddo - enddo - endif -! - endif -! -!----------------------------------------------------------------------- -!*** The following is executed if spatial smoothing is invoked. -!----------------------------------------------------------------------- -! - if(nsmud>=1)then -! - smooth: do ks=1,nsmud -! -!----------------------------------------------------------------------- -! -!----------- -!*** South -!----------- -! - if(s_bdy)then - i1=max(its_h1,ids+1) - i2=min(ite_h1,ide-2) - j1=jts+1 - j2=jts-1+lines - allocate(vbc_2d(i1:i2,j1:j2)) -! - if(nvars_bc_2d_v>0)then - do nv=1,nvars_bc_2d_v - do j=j1,j2 - do i=i1,i2 - vbc_2d(i,j)=(bnd_vars_v%var_2d(nv)%full_var(i,j-1) & - +bnd_vars_v%var_2d(nv)%full_var(i-1,j) & - +bnd_vars_v%var_2d(nv)%full_var(i+1,j) & - +bnd_vars_v%var_2d(nv)%full_var(i,j+1))*w1 & - +w2*bnd_vars_v%var_2d(nv)%full_var(i,j) - enddo - enddo -! - do j=j1,j2 - do i=i1,i2 - bnd_vars_v%var_2d(nv)%full_var(i,j)=vbc_2d(i,j) - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_v>0)then - do nv=1,nvars_bc_3d_v - do l=1,lm - do j=j1,j2 - do i=i1,i2 - vbc_2d(i,j)=(bnd_vars_v%var_3d(nv)%full_var(i,j-1,l) & - +bnd_vars_v%var_3d(nv)%full_var(i-1,j,l) & - +bnd_vars_v%var_3d(nv)%full_var(i+1,j,l) & - +bnd_vars_v%var_3d(nv)%full_var(i,j+1,l))*w1 & - +w2*bnd_vars_v%var_3d(nv)%full_var(i,j,l) - enddo - enddo - do j=j1,j2 - do i=i1,i2 - bnd_vars_v%var_3d(nv)%full_var(i,j,l)=vbc_2d(i,j) - enddo - enddo - enddo - enddo - endif -! - deallocate(vbc_2d) - endif -! -!----------- -!*** North -!----------- -! - if(n_bdy)then - i1=max(its_h1,ids+1) - i2=min(ite_h1,ide-2) - j1=jte-lines - j2=jte-2 - allocate(vbc_2d(i1:i2,j1:j2)) -! - if(nvars_bc_2d_v>0)then - do nv=1,nvars_bc_2d_v - do j=j1,j2 - do i=i1,i2 - vbc_2d(i,j)=(bnd_vars_v%var_2d(nv)%full_var(i,j-1) & - +bnd_vars_v%var_2d(nv)%full_var(i-1,j) & - +bnd_vars_v%var_2d(nv)%full_var(i+1,j) & - +bnd_vars_v%var_2d(nv)%full_var(i,j+1))*w1 & - +w2*bnd_vars_v%var_2d(nv)%full_var(i,j) - enddo - enddo -! - do j=j1,j2 - do i=i1,i2 - bnd_vars_v%var_2d(nv)%full_var(i,j)=vbc_2d(i,j) - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_v>0)then - do nv=1,nvars_bc_3d_v - do l=1,lm - do j=j1,j2 - do i=i1,i2 - vbc_2d(i,j)=(bnd_vars_v%var_3d(nv)%full_var(i,j-1,l) & - +bnd_vars_v%var_3d(nv)%full_var(i-1,j,l) & - +bnd_vars_v%var_3d(nv)%full_var(i+1,j,l) & - +bnd_vars_v%var_3d(nv)%full_var(i,j+1,l))*w1 & - +w2*bnd_vars_v%var_3d(nv)%full_var(i,j,l) - enddo - enddo - do j=j1,j2 - do i=i1,i2 - bnd_vars_v%var_3d(nv)%full_var(i,j,l)=vbc_2d(i,j) - enddo - enddo - enddo - enddo - endif -! - deallocate(vbc_2d) - endif -! -!---------- -!*** West -!---------- -! - if(w_bdy)then - i1=ite-lines - i2=ite-2 - j1=max(jts_h1,jds+lines) - j2=min(jte_h1,jde-lines-1) - allocate(vbc_2d(i1:i2,j1:j2)) -! - if(nvars_bc_2d_v>0)then - do nv=1,nvars_bc_2d_v - do j=j1,j2 - do i=i1,i2 - vbc_2d(i,j)=(bnd_vars_v%var_2d(nv)%full_var(i,j-1) & - +bnd_vars_v%var_2d(nv)%full_var(i-1,j) & - +bnd_vars_v%var_2d(nv)%full_var(i+1,j) & - +bnd_vars_v%var_2d(nv)%full_var(i,j+1))*w1 & - +w2*bnd_vars_v%var_2d(nv)%full_var(i,j) - enddo - enddo -! - do j=j1,j2 - do i=i1,i2 - bnd_vars_v%var_2d(nv)%full_var(i,j)=vbc_2d(i,j) - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_v>0)then - do nv=1,nvars_bc_3d_v - do l=1,lm - do j=j1,j2 - do i=i1,i2 - vbc_2d(i,j)=(bnd_vars_v%var_3d(nv)%full_var(i,j-1,l) & - +bnd_vars_v%var_3d(nv)%full_var(i-1,j,l) & - +bnd_vars_v%var_3d(nv)%full_var(i+1,j,l) & - +bnd_vars_v%var_3d(nv)%full_var(i,j+1,l))*w1 & - +w2*bnd_vars_v%var_3d(nv)%full_var(i,j,l) - enddo - enddo -! - do j=j1,j2 - do i=i1,i2 - bnd_vars_v%var_3d(nv)%full_var(i,j,l)=vbc_2d(i,j) - enddo - enddo - enddo - enddo - endif -! - deallocate(vbc_2d) - endif -! -!---------- -!*** East -!---------- -! - if(e_bdy)then - i1=ite-lines - i2=ite-2 - j1=max(jts_h1,jds+lines) - j2=min(jte_h1,jde-lines-1) - allocate(vbc_2d(i1:i2,j1:j2)) -! - if(nvars_bc_2d_v>0)then - do nv=1,nvars_bc_2d_v - do j=j1,j2 - do i=i1,i2 - vbc_2d(i,j)=(bnd_vars_v%var_2d(nv)%full_var(i,j-1) & - +bnd_vars_v%var_2d(nv)%full_var(i-1,j) & - +bnd_vars_v%var_2d(nv)%full_var(i+1,j) & - +bnd_vars_v%var_2d(nv)%full_var(i,j+1))*w1 & - +w2*bnd_vars_v%var_2d(nv)%full_var(i,j) - enddo - enddo -! - do j=j1,j2 - do i=i1,i2 - bnd_vars_v%var_2d(nv)%full_var(i,j)=vbc_2d(i,j) - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_v>0)then - do nv=1,nvars_bc_3d_v - do l=1,lm - do j=j1,j2 - do i=i1,i2 - vbc_2d(i,j)=(bnd_vars_v%var_3d(nv)%full_var(i,j-1,l) & - +bnd_vars_v%var_3d(nv)%full_var(i-1,j,l) & - +bnd_vars_v%var_3d(nv)%full_var(i+1,j,l) & - +bnd_vars_v%var_3d(nv)%full_var(i,j+1,l))*w1 & - +w2*bnd_vars_v%var_3d(nv)%full_var(i,j,l) - enddo - enddo -! - do j=j1,j2 - do i=i1,i2 - bnd_vars_v%var_3d(nv)%full_var(i,j,l)=vbc_2d(i,j) - enddo - enddo - enddo - enddo - endif -! - deallocate(vbc_2d) - endif -! -!----------------------------------------------------------------------- -! - if(nvars_bc_2d_v>0)then - do nv=1,nvars_bc_2d_v - call halo_exch(bnd_vars_v%var_2d(nv)%full_var,1,1,1) - enddo - endif -! - if(nvars_bc_3d_v>0)then - do nv=1,nvars_bc_3d_v - call halo_exch(bnd_vars_v%var_3d(nv)%full_var,lm,1,1) - enddo - endif -! -!----------------------------------------------------------------------- -! - enddo smooth -! -!----------------------------------------------------------------------- - endif -!----------------------------------------------------------------------- -! - endsubroutine bocov -! -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- - endmodule module_fltbnds -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - diff --git a/src/nmm/module_GET_CONFIG.F90 b/src/nmm/module_GET_CONFIG.F90 deleted file mode 100644 index 9129055..0000000 --- a/src/nmm/module_GET_CONFIG.F90 +++ /dev/null @@ -1,2082 +0,0 @@ -!----------------------------------------------------------------------- -! - MODULE module_GET_CONFIG -! -!----------------------------------------------------------------------- -! -!*** EXTRACT DATA FROM THE ESMF CONFIGURATION FILES -!*** AND LOAD IT INTO THE INTERNAL STATES. -! -!----------------------------------------------------------------------- -! - USE ESMF - USE MODULE_ERROR_MSG,ONLY: ERR_MSG,MESSAGE_CHECK -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: GET_CONFIG, GET_CONFIG_DIMS -! -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -! - SUBROUTINE GET_CONFIG_DIMS (GRID_COMP & - ,INPES,JNPES & - ,LM & - ,NUM_TRACERS_CHEM & - ,PCPHR & - ,GFS & - ,MICROPHYSICS & - ,SHORTWAVE & - ,LONGWAVE & - ,lmprate & - ,LNSH,LNSV & - ,RC_CONF) -! -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_GridComp), INTENT(INOUT) :: GRID_COMP !<-- The Solver component -! - INTEGER, INTENT(OUT) :: INPES,JNPES & - ,LM & - ,LNSH,LNSV & - ,NUM_TRACERS_CHEM & - ,PCPHR - LOGICAL, INTENT(OUT) :: GFS,LMPRATE - CHARACTER(LEN=*), INTENT(OUT) :: MICROPHYSICS, SHORTWAVE & - ,LONGWAVE - INTEGER, INTENT(OUT) :: RC_CONF !<-- Final return code -! -!--------------------- -!*** Local Variables -!--------------------- -! - TYPE(ESMF_Config) :: CF - INTEGER :: RC, LNSH_HOLD, LNSV_HOLD -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Initialize the error signal variables. -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RC_CONF=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** Retrieve the ESMF config object CF from the gridded component. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Retrieve Config Object from Solver Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGet(gridcomp=GRID_COMP & !<--- The Solver component - ,config =CF & !<--- The configure (namelist) object - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Begin extraction of the configuration file data. -!----------------------------------------------------------------------- -! -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract LM from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =LM & !<-- Put extracted quantity here - ,label ='lm:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract INPES from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =INPES & !<-- Put extracted quantity here - ,label ='inpes:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract JNPES from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =JNPES & !<-- Put extracted quantity here - ,label ='jnpes:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract NUM_TRACERS_CHEM from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =NUM_TRACERS_CHEM & !<-- Put extracted quantity here - ,label ='num_tracers_chem:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract PCP Assim duration from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =PCPHR & !<-- Put extracted quantity here - ,label ='pcphr:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -!----------------------------------------------------------------------- -!*** Physics options -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract GFS from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =GFS & !<-- Put extracted quantity here - ,label ='gfs:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract MICROPHYSICS from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =MICROPHYSICS & !<-- Put extracted quantity here - ,label ='microphysics:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract SHORTWAVE from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =SHORTWAVE & !<-- Put extracted quantity here - ,label ='shortwave:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract LONGWAVE from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =LONGWAVE & !<-- Put extracted quantity here - ,label ='longwave:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract LMPRATE from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =LMPRATE & !<-- Put extracted quantity here - ,label ='lmprate:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract LNSH, LNSV from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!------------------------------------------------------ -!*** Set default value in case not specified by user. -!----------------------------------------------------- -! - LNSH_HOLD=1 - LNSV_HOLD=1 -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value = LNSH & !<-- Put extracted quantity here - ,label ='lnsh:' & !<-- The quantity's label in the configure file - ,rc =RC) -! - IF (RC/=0) LNSH=LNSH_HOLD -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value = LNSV & !<-- Put extracted quantity here - ,label ='lnsv:' & !<-- The quantity's label in the configure file - ,rc =RC) -! - IF (RC/=0) LNSV=LNSV_HOLD -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - IF(RC_CONF==ESMF_SUCCESS)THEN -!!! WRITE(0,*)'GET_CONFIG_DIMS PASSED' - ELSE - WRITE(0,*)'GET_CONFIG_DIMS FAILED RC_CONF=',RC_CONF - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE GET_CONFIG_DIMS -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE GET_CONFIG(GRID_COMP,INT_STATE,RC_CONF) -! -!----------------------------------------------------------------------- - USE MODULE_SOLVER_INTERNAL_STATE -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_GridComp), INTENT(INOUT) :: GRID_COMP !<-- The Solver component - TYPE(SOLVER_INTERNAL_STATE),INTENT(INOUT) :: INT_STATE !<-- The Solver internal state - INTEGER ,INTENT(OUT) :: RC_CONF !<-- Final return code -! -!--------------------- -!*** Local Variables -!--------------------- -! - TYPE(ESMF_Config) :: CF - INTEGER :: RC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -!*** Initialize the error signal variables. -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RC_CONF=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** Retrieve the ESMF config object CF from the gridded component. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Retrieve Config Object from Solver Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGet(gridcomp=GRID_COMP & !<--- The Solver component - ,config =CF & !<--- The configure (namelist) object - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Extract the PRINT_ESMF flag. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract PRINT_ESMF File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%PRINT_ESMF & !<-- Put extracted quantity here - ,label ='print_esmf:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Extract the PRINT_ALL flag. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract PRINT_ALL File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%PRINT_ALL & !<-- Put extracted quantity here - ,label ='print_all:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Begin extraction of the configuration file data. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract IM from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%IM & !<-- Put extracted quantity here - ,label ='im:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract JM from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%JM & !<-- Put extracted quantity here - ,label ='jm:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract LM from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%LM & !<-- Put extracted quantity here - ,label ='lm:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract TPH0D from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%TPH0D & !<-- Put extracted quantity here - ,label ='tph0d:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract TLM0D from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%TLM0D & !<-- Put extracted quantity here - ,label ='tlm0d:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract START_YEAR from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%START_YEAR & !<-- Put extracted quantity here - ,label ='start_year:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract START_MONTH from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%START_MONTH & !<-- Put extracted quantity here - ,label ='start_month:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract START_DAY from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%START_DAY & !<-- Put extracted quantity here - ,label ='start_day:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract START_HOUR from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%START_HOUR & !<-- Put extracted quantity here - ,label ='start_hour:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract START_MINUTE from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%START_MINUTE & !<-- Put extracted quantity here - ,label ='start_minute:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract START_SECOND from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%START_SECOND & !<-- Put extracted quantity here - ,label ='start_second:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract assorted quantities from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & - ,value =int_state%RADAR_INIT & - ,label ='radar_init:' & - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF & - ,value =int_state%FILTER_METHOD & - ,label ='filter_method:' & - ,rc =RC) - - IF (int_state%FILTER_METHOD == 1) THEN - - CALL ESMF_ConfigGetAttribute(config=CF & - ,value = int_state%DFIHR_BOCO & - ,label ='nsecs_dfl:' & - ,rc =RC) - - ELSEIF (int_state%FILTER_METHOD == 2) THEN - - CALL ESMF_ConfigGetAttribute(config=CF & - ,value = int_state%DFIHR_BOCO & - ,label ='nsecs_bckddfi:' & - ,rc =RC) - - ELSEIF (int_state%FILTER_METHOD == 3) THEN - - CALL ESMF_ConfigGetAttribute(config=CF & - ,value = int_state%DFIHR_BOCO & - ,label ='nsecs_bcktdfi:' & - ,rc =RC) - - ENDIF -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract RESTART from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%RESTART & !<-- Put extracted quantity here - ,label ='restart:' & !<-- The quantity's label in the configure file - ,rc =RC) - - int_state%LISS_RESTART=int_state%RESTART !<-- Switch for LISS initialization -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract FREERUN from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%FREERUN & !<-- Put extracted quantity here - ,label ='freerun:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract NEMSIO_INPUT from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%NEMSIO_INPUT & !<-- Put extracted quantity here - ,label ='nemsio_input:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract GLOBAL from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%GLOBAL & !<-- Put extracted quantity here - ,label ='global:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract OPER from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%OPER & !<-- Put extracted quantity here - ,label ='oper:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract HYDRO from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%HYDRO & !<-- Put extracted quantity here - ,label ='hydro:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract WBD from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%WBD & !<-- Put extracted quantity here - ,label ='wbd:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract SBD from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%SBD & !<-- Put extracted quantity here - ,label ='sbd:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract NHOURS_FCST from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%NHOURS_FCST & !<-- Put extracted quantity here - ,label ='nhours_fcst:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract MINUTES_HISTORY from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%MINUTES_HISTORY & !<-- Put extracted quantity here - ,label ='minutes_history:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract MINUTES_RESTART from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%MINUTES_RESTART & !<-- Put extracted quantity here - ,label ='minutes_restart:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract SECADV from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%SECADV & !<-- Put extracted quantity here - ,label ='secadv:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract SMAG2 from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%SMAG2 & !<-- Put extracted quantity here - ,label ='smag2:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract CODAMP from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%CODAMP & !<-- Put extracted quantity here - ,label ='codamp:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract WCOR from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%WCOR & !<-- Put extracted quantity here - ,label ='wcor:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract IDTADT from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%IDTADT & !<-- Put extracted quantity here - ,label ='idtadt:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract NUM_TRACERS_CHEM from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%NUM_TRACERS_CHEM & !<-- Put extracted quantity here - ,label ='num_tracers_chem:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract INPES from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%INPES & !<-- Put extracted quantity here - ,label ='inpes:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract JNPES from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%JNPES & !<-- Put extracted quantity here - ,label ='jnpes:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract WRITE_TASKS_PER_GROUP from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%WRITE_TASKS_PER_GROUP & !<-- Put extracted quantity here - ,label ='write_tasks_per_group:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract WRITE_GROUPS from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%WRITE_GROUPS & !<-- Put extracted quantity here - ,label ='write_groups:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract USE_ALLREDUCE from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%USE_ALLREDUCE & !<-- Put extracted quantity here - ,label ='use_allreduce:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract SFC_LAYER from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%SFC_LAYER & !<-- Put extracted quantity here - ,label ='sfc_layer:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract TURBULENCE from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%TURBULENCE & !<-- Put extracted quantity here - ,label ='turbulence:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract CONVECTION from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%CONVECTION & !<-- Put extracted quantity here - ,label ='convection:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract MICROPHYSICS from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%MICROPHYSICS & !<-- Put extracted quantity here - ,label ='microphysics:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract LMPRATE from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%LMPRATE & !<-- Put extracted quantity here - ,label ='lmprate:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract ADIABATIC from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & - ,value =int_state%ADIABATIC & - ,label ='adiabatic:' & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract SPEC_ADV from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & - ,value =int_state%SPEC_ADV & - ,label ='spec_adv:' & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - MESSAGE_CHECK="GET_CONFIG: Extract AVGMAXLEN from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%AVGMAXLEN & !<-- Put extracted quantity here - ,label ='avg_max_length:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Precipitation assimilation -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract PCPFLG from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%PCPFLG & !<-- Put extracted quantity here - ,label ='pcpflg:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract PCP Assim duration from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%PCPHR & !<-- Put extracted quantity here - ,label ='pcphr:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract WRITE_PREC_ADJ from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%WRITE_PREC_ADJ & !<-- Put extracted quantity here - ,label ='write_prec_adj:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Gravity wave drag flag -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract GWDFLG from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%GWDFLG & !<-- Put extracted quantity here - ,label ='gwdflg:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Physics options -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract GFS from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%GFS & !<-- Put extracted quantity here - ,label ='gfs:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** Gravity Wave Drag tunable coefficients: -!*** (CDMB,CLEFFAMP,SIGFAC,FACTOP,RLOLEV,DPMIN) -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract CDMB from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%CDMB & !<-- Put extracted quantity here - ,label ='cdmb:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract CLEFFAMP from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%CLEFFAMP & !<-- Put extracted quantity here - ,label ='cleffamp:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract SIGFAC from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%SIGFAC & !<-- Put extracted quantity here - ,label ='sigfac:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract FACTOP from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%FACTOP & !<-- Put extracted quantity here - ,label ='factop:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract RLOLEV from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%RLOLEV & !<-- Put extracted quantity here - ,label ='rlolev:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract DPMIN from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%DPMIN & !<-- Put extracted quantity here - ,label ='dpmin:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Shallow convection switches: (FRES,FR,FSL,FSS, -!*** ENTRAIN,NEWALL,NEWSWAP,NEWUPUP,NODEEP) -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract FRES from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%FRES & !<-- Put extracted quantity here - ,label ='fres:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract FR from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%FR & !<-- Put extracted quantity here - ,label ='fr:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract FSL from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%FSL & !<-- Put extracted quantity here - ,label ='fsl:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract FSS from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%FSS & !<-- Put extracted quantity here - ,label ='fss:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract ENTRAIN from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%ENTRAIN & !<-- Put extracted quantity here - ,label ='entrain:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract NEWALL from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%NEWALL & !<-- Put extracted quantity here - ,label ='newall:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract NEWSWAP from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%NEWSWAP & !<-- Put extracted quantity here - ,label ='newswap:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract NEWUPUP from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%NEWUPUP & !<-- Put extracted quantity here - ,label ='newupup:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract NODEEP from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%NODEEP & !<-- Put extracted quantity here - ,label ='nodeep:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Threshold relative humidity for the onset of grid-scale condensation -!*** in the fer_hires microphysics only (RHGRD) -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract RHGRD from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%RHGRD & !<-- Put extracted quantity here - ,label ='rhgrd:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract LAND_SURFACE from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%LAND_SURFACE & !<-- Put extracted quantity here - ,label ='land_surface:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract CO2TF from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%CO2TF & !<-- Put extracted quantity here - ,label ='co2tf:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - MESSAGE_CHECK="GET_CONFIG: Extract CLDFRACTION from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%CLDFRACTION & !<-- Put extracted quantity here - ,label ='cldfraction:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - MESSAGE_CHECK="GET_CONFIG: Extract NP3D from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%NP3D & !<-- Put extracted quantity here - ,label ='np3d:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract NRADS from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%NRADS & !<-- Put extracted quantity here - ,label ='nrads:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract NRADL from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%NRADL & !<-- Put extracted quantity here - ,label ='nradl:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract NPHS from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%NPHS & !<-- Put extracted quantity here - ,label ='nphs:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract NPRECIP from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%NPRECIP & !<-- Put extracted quantity here - ,label ='nprecip:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract NHRS_UDEF from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%NHRS_UDEF & !<-- Put extracted quantity here - ,label ='nhrs_udef:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract NHRS_PREC from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%NHRS_PREC & !<-- Put extracted quantity here - ,label ='nhrs_prec:' & !<-- The quantity's label in the configure file - ,rc =RC) -! - IF(.NOT.int_state%NHRS_UDEF) int_state%NHRS_PREC=1 !<-- Empty bucket hourly if user did not specify -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract NHRS_HEAT from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%NHRS_HEAT & !<-- Put extracted quantity here - ,label ='nhrs_heat:' & !<-- The quantity's label in the configure file - ,rc =RC) -! - IF(.NOT.int_state%NHRS_UDEF) int_state%NHRS_HEAT=1 !<-- Empty bucket hourly if user did not specify -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract NHRS_CLOD from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%NHRS_CLOD & !<-- Put extracted quantity here - ,label ='nhrs_clod:' & !<-- The quantity's label in the configure file - ,rc =RC) -! - IF(.NOT.int_state%NHRS_UDEF) int_state%NHRS_CLOD=1 !<-- Empty bucket hourly if user did not specify -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract NHRS_RDLW from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%NHRS_RDLW & !<-- Put extracted quantity here - ,label ='nhrs_rdlw:' & !<-- The quantity's label in the configure file - ,rc =RC) -! - IF(.NOT.int_state%NHRS_UDEF) int_state%NHRS_RDLW=1 !<-- Empty bucket hourly if user did not specify -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract NHRS_RDSW from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%NHRS_RDSW & !<-- Put extracted quantity here - ,label ='nhrs_rdsw:' & !<-- The quantity's label in the configure file - ,rc =RC) -! - IF(.NOT.int_state%NHRS_UDEF) int_state%NHRS_RDSW=1 !<-- Empty bucket hourly if user did not specify -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract NHRS_SRFC from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%NHRS_SRFC & !<-- Put extracted quantity here - ,label ='nhrs_srfc:' & !<-- The quantity's label in the configure file - ,rc =RC) -! - IF(.NOT.int_state%NHRS_UDEF) int_state%NHRS_SRFC=1 !<-- Empty bucket hourly if user did not specify -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract UCMCALL from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%UCMCALL & !<-- Put extracted quantity here - ,label ='ucmcall:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract IVEGSRC from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%IVEGSRC & !<-- Put extracted quantity here - ,label ='ivegsrc:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract DT_INT from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%DT_INT & !<-- Put extracted quantity here - ,label ='dt_int:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract RST_OUT_00 from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%RST_OUT_00 & !<-- Put extracted quantity here - ,label ='rst_out_00:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -!----------------------------------------------------------------------- -!!!!! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -!!!!! -!!!!!----------------------------------------------------------------------- -!!!!! options for Hurricane from hwrf, default values defined in -!!!!! module_SOLVER_INTERNAL_STATE.F90 -!!!!! -!!!!! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract SAS_PGCON from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%SAS_PGCON & !<-- Put extracted quantity here - ,label ='sas_pgcon:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract SAS_SHAL_PGCON from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%SAS_SHAL_PGCON & !<-- Put extracted quantity here - ,label ='sas_shal_pgcon:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract SAS_SHALCONV from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%SAS_SHALCONV & !<-- Put extracted quantity here - ,label ='sas_shalconv:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract SAS_MASS_FLUX from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%SAS_MASS_FLUX & !<-- Put extracted quantity here - ,label ='sas_mass_flux:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract SAS_MOMMIX from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%SAS_MOMMIX & !<-- Put extracted quantity here - ,label ='sas_mommix:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract VAR_RIC from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%VAR_RIC & !<-- Put extracted quantity here - ,label ='var_ric:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract COEF_RIC_L from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%COEF_RIC_L & !<-- Put extracted quantity here - ,label ='coef_ric_l:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract COEF_RIC_S from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%COEF_RIC_S & !<-- Put extracted quantity here - ,label ='coef_ric_s:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract DISHEAT from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%DISHEAT & !<-- Put extracted quantity here - ,label ='disheat:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!---------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract SFENTH from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%SFENTH & !<-- Put extracted quantity here - ,label ='sfenth:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!---------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract ALPHA from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%ALPHA & !<-- Put extracted quantity here - ,label ='alpha:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!---------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG: Extract RUN_TC from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%RUN_TC & !<-- Put extracted quantity here - ,label ='run_tc:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! END OF HWRF options -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG_WRITE: Extract PRINT_DIAG from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%PRINT_DIAG & !<-- Put extracted quantity here - ,label ='print_diag:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - IF(RC_CONF==ESMF_SUCCESS)THEN -!!! WRITE(0,*)'GET_CONFIG PASSED' - ELSE - WRITE(0,*)'GET_CONFIG FAILED RC_CONF=',RC_CONF - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE GET_CONFIG -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - END MODULE MODULE_GET_CONFIG -! -!----------------------------------------------------------------------- diff --git a/src/nmm/module_GET_CONFIG_WRITE.F90 b/src/nmm/module_GET_CONFIG_WRITE.F90 deleted file mode 100644 index e8fc6f4..0000000 --- a/src/nmm/module_GET_CONFIG_WRITE.F90 +++ /dev/null @@ -1,419 +0,0 @@ -!----------------------------------------------------------------------- -! - MODULE MODULE_GET_CONFIG_WRITE -! -!----------------------------------------------------------------------- -! -!*** EXTRACT DATA FROM THE ESMF CONFIGURATION FILES -!*** AND LOAD IT INTO THE INTERNAL STATES. -! -!----------------------------------------------------------------------- -! - USE ESMF - USE MODULE_ERROR_MSG,ONLY: ERR_MSG,MESSAGE_CHECK -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: GET_CONFIG_WRITE -! -!----------------------------------------------------------------------- -! - INTERFACE GET_CONFIG_WRITE - MODULE PROCEDURE GET_CONFIG_WRITE - END INTERFACE -! -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE GET_CONFIG_WRITE(GRID_COMP,INT_STATE,RC_CONF) -! -!----------------------------------------------------------------------- -! - USE MODULE_WRITE_INTERNAL_STATE -! -!----------------------------------------------------------------------- -!*** Argument variables -!----------------------------------------------------------------------- -! - TYPE(ESMF_GridComp) , INTENT(INOUT) :: GRID_COMP !<-- The Write gridded component - TYPE(WRITE_INTERNAL_STATE),INTENT(INOUT) :: INT_STATE !<-- The Write component's internal state - INTEGER ,INTENT(OUT) :: RC_CONF !<-- Final return code -! -!----------------------------------------------------------------------- -!*** Local variables -!----------------------------------------------------------------------- -! - INTEGER :: ID_DOMAIN,RC - CHARACTER( 2) :: INT_TO_CHAR - CHARACTER( 6) :: FMT='(I2.2)' - CHARACTER(50) :: MODE - TYPE(ESMF_Config) :: CF -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Initialize the error signal variables. -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RC_CONF=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** Retrieve the esmf config object CF from the Write component. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG_WRITE: Retrieve Config Object from Write Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGet(gridcomp=GRID_COMP & !<--- The Write gridded component - ,config =CF & !<--- The configure (namelist) object - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Begin extraction of the configuration file data. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG_WRITE: Extract PRINT_ALL from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%PRINT_ALL & !<-- Put extracted quantity here - ,label ='print_all:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG_WRITE: Extract PRINT_OUTPUT from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%PRINT_OUTPUT & !<-- Put extracted quantity here - ,label ='print_output:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG_WRITE: Extract PRINT_DIAG from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%PRINT_DIAG & !<-- Put extracted quantity here - ,label ='print_diag:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG_WRITE: Extract PRINT_ESMF from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%PRINT_ESMF & !<-- Put extracted quantity here - ,label ='print_esmf:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG_WRITE: Extract WRITE_HST_BIN from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%WRITE_HST_BIN & !<-- Put extracted quantity here - ,label ='write_hst_bin:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG_WRITE: Extract WRITE_HST_NEMSIO from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%WRITE_HST_NEMSIO & !<-- Put extracted quantity here - ,label ='write_hst_nemsio:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG_WRITE: Extract WRITE_RST_BIN from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%WRITE_RST_BIN & !<-- Put extracted quantity here - ,label ='write_rst_bin:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG_WRITE: Extract WRITE_RST_NEMSIO from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%WRITE_RST_NEMSIO & !<-- Put extracted quantity here - ,label ='write_rst_nemsio:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG_WRITE: Extract WRITE_NEMSIOCTL from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%WRITE_NEMSIOCTL & !<-- Put extracted quantity here - ,label ='write_nemsioctl:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG_WRITE: Extract WRITE_DOPOST from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%WRITE_DOPOST & !<-- Put extracted quantity here - ,label ='write_dopost:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG_WRITE: Extract POST_GRIBVERSION from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%POST_GRIBVERSION & !<-- Put extracted quantity here - ,label ='post_gribversion:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG_WRITE: Extract WRITE_FSYNCFLAG from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%WRITE_FSYNCFLAG & !<-- Put extracted quantity here - ,label ='write_fsyncflag:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG_WRITE: Extract WRITE_DONEFILEFLAG from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%WRITE_DONEFILEFLAG & !<-- Put extracted quantity here - ,label ='write_donefileflag:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG_WRITE: Extract WRITE_GROUPS from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%WRITE_GROUPS & !<-- Put extracted quantity here - ,label ='write_groups:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG_WRITE: Extract WRITE_TASKS_PER_GROUP from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%WRITE_TASKS_PER_GROUP & !<-- Put extracted quantity here - ,label ='write_tasks_per_group:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG_WRITE: Extract Domain ID from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =ID_DOMAIN & !<-- Put extracted quantity here - ,label ='my_domain_id:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG_WRITE: Extract HST_NAME_BASE from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%HST_NAME_BASE & !<-- Put extracted quantity here - ,label ='hst_name_base:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - WRITE(INT_TO_CHAR,FMT)ID_DOMAIN - int_state%HST_NAME_BASE=TRIM(int_state%HST_NAME_BASE)//'_'//INT_TO_CHAR -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="GET_CONFIG_WRITE: Extract RST_NAME_BASE from Config File" - IF(int_state%PRINT_ESMF .OR. int_state%PRINT_ALL) & - CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%RST_NAME_BASE & !<-- Put extracted quantity here - ,label ='rst_name_base:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CONF) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - WRITE(INT_TO_CHAR,FMT)ID_DOMAIN - int_state%RST_NAME_BASE=TRIM(int_state%RST_NAME_BASE)//'_'//INT_TO_CHAR -! -!----------------------------------------------------------------------- -! - IF(RC_CONF==ESMF_SUCCESS)THEN -!!! WRITE(0,*)'GET_CONFIG_WRITE PASSED' - ELSE - WRITE(0,*)'GET_CONFIG_WRITE FAILED RC_CONF=',RC_CONF - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE GET_CONFIG_WRITE -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - END MODULE MODULE_GET_CONFIG_WRITE -! -!----------------------------------------------------------------------- diff --git a/src/nmm/module_GWD.F90 b/src/nmm/module_GWD.F90 deleted file mode 100644 index 38163f5..0000000 --- a/src/nmm/module_GWD.F90 +++ /dev/null @@ -1,1140 +0,0 @@ -!----------------------------------------------------------------------- -! - MODULE MODULE_GWD -! -!----------------------------------------------------------------------- -! -!*** Module for Gravity Wave Drag (GWD) and Mountain Blocking (MB) -! -!*** Initially incorporated into the WRF NMM from the GFS by B. Ferrier -!*** in April/May 2007. -!*** Ratko added in NMM-B (July '08) -!*** Mountain blocking made more robust in July 2016 by BSF -! -!*** Search for "ORIGINAL DOCUMENTATION BLOCK" for further description. -! -!----------------------------------------------------------------------- -! - INTEGER, PARAMETER :: KIND_PHYS=SELECTED_REAL_KIND(13,60) ! the '60' maps to 64-bit real - INTEGER,PRIVATE,SAVE :: NMTVR, IDBG, JDBG - REAL (KIND=KIND_PHYS),PRIVATE :: DELTIM,RDELTIM -! -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! -!-- Initialize variables used in GWD + MB -! - SUBROUTINE GWD_init (DTPHS,RESTRT & - ,CLEFFAMP,DPHD & - ,CLEFF & - ,CEN_LAT,CEN_LON & - ,GLAT,GLON & - ,CROT,SROT,HANGL & - ,IDS,IDE,JDS,JDE & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE,LM ) - -! - IMPLICIT NONE -! -!== INPUT: -!-- CEN_LAT, CEN_LON - central latitude, longitude (degrees) -!-- DPHD - DY in degrees latitude -!-- CLEFFAMP - amplification factor for variable CLEFF -!-- RESTRT - logical flag for restart file (true) or WRF input file (false) -!-- GLAT, GLON - central latitude, longitude at mass points (radians) -!-- CROT, SROT - cosine and sine of the angle between Earth and model coordinates -!-- HANGL - angle of the mountain range w/r/t east (convert to degrees) -! -!-- Saved variables within module: -!-- NMTVR - number of input 2D orographic fields -!-- GRAV = gravitational acceleration -!-- DELTIM - physics time step (s) -!-- RDELTIM - reciprocal of physics time step (s) -! -! - REAL, INTENT(IN) :: DTPHS,CEN_LAT,CEN_LON,DPHD,CLEFFAMP - REAL, INTENT(OUT) :: CLEFF - LOGICAL, INTENT(IN) :: RESTRT - REAL, INTENT(IN), DIMENSION (ims:ime,jms:jme) :: GLON,GLAT - REAL, INTENT(OUT), DIMENSION (ims:ime,jms:jme) :: CROT,SROT - REAL, INTENT(INOUT), DIMENSION (ims:ime,jms:jme) :: HANGL - INTEGER, INTENT(IN) :: IDS,IDE,JDS,JDE & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE,LM -! -!-- Local variables: -! - REAL, PARAMETER :: DPHD0=0.108 !-- Nominal 12-km grid resolution - REAL :: DTR,RTD,TPH0,TLM0,CTPH0,STPH0,RELM,SRLM,CRLM,SPH,CPH,TPH,RCTPH - INTEGER :: I,J -! -!--------------------------------------------------------------------- -! - NMTVR=14 !-- 14 input fields for orography - DELTIM=DTPHS - RDELTIM=1./DTPHS -! -!-- Calculate angle of rotation between Earth and model coordinates, -! but pass back out cosine (CROT) and sine (SROT) of this angle -! - DTR=ACOS(-1.)/180. !-- convert from degrees to radians - TPH0=CEN_LAT*DTR - TLM0=CEN_LON*DTR - CTPH0=COS(TPH0) - STPH0=SIN(TPH0) - DO J=JTS,JTE - DO I=ITS,ITE - RELM=GLON(I,J)-TLM0 - SRLM=SIN(RELM) - CRLM=COS(RELM) - SPH=SIN(GLAT(I,J)) - CPH=COS(GLAT(I,J)) - TPH=ASIN(CTPH0*SPH-STPH0*CPH*CRLM) - RCTPH=1.0/COS(TPH) - SROT(I,J)=STPH0*SRLM*RCTPH - CROT(I,J)=(CTPH0*CPH+STPH0*SPH*CRLM)*RCTPH - ENDDO !-- I - ENDDO !-- J -!-- Convert from radians to degrees - RTD=1./DTR !-- convert from radians to degrees - DO J=JTS,JTE - DO I=ITS,ITE - HANGL(I,J)=RTD*HANGL(I,J) !-- convert to degrees (+/-90 deg) - ENDDO !-- I - ENDDO !-- J -! -!-- Scale cleff to be w/r/t a nominal value of 1e-5 for 12-km grid Launcher runs -! * Launcher 12-km runs used cleff=0.5e-5*SQRT(IMX/192), where IMX=IDE-1=705 -! for the 12-km air quality (na12aq) domain -! - CLEFF=CLEFFAMP*1.E-5*SQRT(DPHD/DPHD0) -! write(0,*) 'dphd,cleff=',dphd,cleff -! - END SUBROUTINE GWD_init -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE GWD_driver(DTPHS,U,V,T,Q,Z,DP,PINT,PMID,EXNR,KPBL & - ,HSTDV,HCNVX,HASYW,HASYS,HASYSW,HASYNW & - ,HLENW,HLENS,HLENSW,HLENNW & - ,HANGL,HANIS,HSLOP,HZMAX,CROT,SROT & - ,CDMB,CLEFF,SIGFAC,FACTOP,RLOLEV,DPMIN & - ,DUDT,DVDT & - ,GLOBAL & - ,IDS,IDE,JDS,JDE & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE,LM ) -! -!== INPUT: -!-- U, V - zonal (U), meridional (V) winds at mass points (m/s) -!-- T, Q - temperature (C), specific humidity (kg/kg) -!-- DP - pressure thickness (Pa) -!-- Z - geopotential height (m) -!-- PINT, PMID - interface and midlayer pressures, respectively (Pa) -!-- EXNR - (p/p0)**(Rd/Cp) -!-- KPBL - vertical index at PBL top -!-- HSTDV - orographic standard deviation -!-- HCNVX - normalized 4th moment of the orographic convexity -!-- Template for the next two sets of 4 arrays: -! NWD 1 2 3 4 5 6 7 8 -! WD W S SW NW E N NE SE -!-- Orographic asymmetry (HASYx, x=1-4) for upstream & downstream flow (4 planes) -!-- * HASYW - orographic asymmetry for upstream & downstream flow in W-E plane -!-- * HASYS - orographic asymmetry for upstream & downstream flow in S-N plane -!-- * HASYSW - orographic asymmetry for upstream & downstream flow in SW-NE plane -!-- * HASYNW - orographic asymmetry for upstream & downstream flow in NW-SE plane -!-- Orographic length scale or mountain width (4 planes) -!-- * HLENW - orographic length scale for upstream & downstream flow in W-E plane -!-- * HLENS - orographic length scale for upstream & downstream flow in S-N plane -!-- * HLENSW - orographic length scale for upstream & downstream flow in SW-NE plane -!-- * HLENNW - orographic length scale for upstream & downstream flow in NW-SE plane -!-- HANGL - angle (degrees) of the mountain range w/r/t east -!-- HANIS - anisotropy/aspect ratio of orography -!-- HSLOP - slope of orography -!-- HZMAX - max height above mean orography -!-- CROT, SROT - cosine & sine of the angle between Earth & model coordinates -! -!== OUTPUT: -!-- DUDT, DVDT - zonal, meridional wind tendencies -!-- UGWDsfc, VGWDsfc - zonal, meridional surface wind stresses (N/m**2) -! -!== INPUT indices: -!-- ids start index for i in domain -!-- ide end index for i in domain -!-- jds start index for j in domain -!-- jde end index for j in domain -!-- ims start index for i in memory -!-- ime end index for i in memory -!-- jms start index for j in memory -!-- jme end index for j in memory -!-- its start i index for tile -!-- ite end i index for tile -!-- jts start j index for tile -!-- jte end j index for tile -! -!-- INPUT variables: -! - REAL, INTENT(IN):: DTPHS,CDMB,CLEFF,SIGFAC,FACTOP,RLOLEV,DPMIN - REAL, INTENT(IN), DIMENSION (ims:ime, jms:jme, 1:lm+1) :: & - & Z, PINT - REAL, INTENT(IN), DIMENSION (ims:ime, jms:jme, 1:lm) :: & - & U,V,T,Q,DP,PMID,EXNR - REAL, INTENT(IN), DIMENSION (ims:ime, jms:jme) :: HSTDV,HCNVX & - & ,HASYW,HASYS,HASYSW,HASYNW,HLENW,HLENS,HLENSW,HLENNW,HANGL & - & ,HANIS,HSLOP,HZMAX,CROT,SROT - INTEGER, INTENT(IN), DIMENSION (ims:ime, jms:jme) :: KPBL - INTEGER, INTENT(IN) :: ids,ide,jds,jde & - &, ims,ime,jms,jme & - &, its,ite,jts,jte,LM -! - LOGICAL, INTENT(IN) :: GLOBAL -! -!-- OUTPUT variables: -! - REAL, INTENT(OUT), DIMENSION (ims:ime, jms:jme, 1:lm) :: & - & DUDT,DVDT -!--- when NPS is done with GWD, add wind stresses in output - REAL, DIMENSION (ims:ime, jms:jme) :: UGWDsfc,VGWDsfc -! -!-- Local variables -!-- DUsfc, DVsfc - zonal, meridional wind stresses (diagnostics) -! - INTEGER, PARAMETER :: IM=1 !-- Reduces changes in subroutine GWPDS - REAL(KIND=KIND_PHYS), PARAMETER :: G=9.806, GHALF=.5*G & - &, THRESH=1.E-6, dtlarge=1. - INTEGER, DIMENSION (IM) :: LPBL - REAL(KIND=KIND_PHYS), DIMENSION (IM,4) :: OA4,CLX4 - REAL(KIND=KIND_PHYS), DIMENSION (IM) :: DUsfc,DVsfc & - &, HPRIME,OC,THETA,SIGMA,GAMMA,ELVMAX - REAL(KIND=KIND_PHYS), DIMENSION (IM,1:LM) :: DUDTcol,DVDTcol & - &, Ucol,Vcol,Tcol,Qcol,DPcol,Pcol,EXNcol,PHIcol - REAL(KIND=KIND_PHYS), DIMENSION (IM,1:LM+1) :: PINTcol,PHILIcol - INTEGER :: I,J,IJ,K,KFLIP,IMX,Imid,Jmid - REAL :: Ugeo,Vgeo,Umod,Vmod, TERRtest,TERRmin - REAL(KIND=KIND_PHYS) :: TEST -! -!-------------------------- Executable below ------------------------- -! -!-- Initialize variables -! - DELTIM=DTPHS - RDELTIM=1./DTPHS -! - DO K=1,LM - DO J=JMS,JME - DO I=IMS,IME - DUDT(I,J,K)=0. - DVDT(I,J,K)=0. - ENDDO - ENDDO - ENDDO -! - DO J=JMS,JME - DO I=IMS,IME - UGWDsfc(I,J)=0. - VGWDsfc(I,J)=0. - ENDDO - ENDDO -! - IF(GLOBAL)THEN - IMX=IDE-3 - ELSE - IMX=IDE-1 - ENDIF -! - DO J=JTS,JTE - DO I=ITS,ITE - if (kpbl(i,j)<=1 .or. kpbl(i,j)>LM) CYCLE !-- Go to next grid column -! -!-- Initial test to see if GWD calculations should be made, otherwise skip -! - TERRtest=HZMAX(I,J)+SIGFAC*HSTDV(I,J) - TERRmin=Z(I,J,LM)-Z(I,J,LM+1) - IF (TERRtest < TERRmin) CYCLE !-- Go to next grid column -! -!-- For debugging: -! - DO K=1,LM - KFLIP = LM-K+1 - DUDTcol(IM,K)=0. - DVDTcol(IM,K)=0. -! -!-- Transform/rotate winds from model to geodetic (Earth) coordinates -! - Ucol(IM,K)=U(I,J,KFLIP)*CROT(I,J)+V(I,J,KFLIP)*SROT(I,J) - Vcol(IM,K)=V(I,J,KFLIP)*CROT(I,J)-U(I,J,KFLIP)*SROT(I,J) -! - Tcol(IM,K)=T(I,J,KFLIP) - Qcol(IM,K)=Q(I,J,KFLIP) -! -!-- Convert from Pa to centibars, which is what's used in subroutine GWD_col -! - DPcol(IM,K)=.001*DP(I,J,KFLIP) - PINTcol(IM,K)=.001*PINT(I,J,KFLIP+1) - Pcol(IM,K)=.001*PMID(I,J,KFLIP) - EXNcol(IM,K)=EXNR(I,J,KFLIP) -! -!-- Next 2 fields are geopotential above the surface at the lower interface -! and at midlayer -! - PHILIcol(IM,K)=G*(Z(I,J,KFLIP+1)-Z(I,J,LM+1)) - PHIcol(IM,K)=GHALF*(Z(I,J,KFLIP+1)+Z(I,J,KFLIP))-G*Z(I,J,LM+1) - ENDDO !- K -! - PINTcol(IM,LM+1)=.001*PINT(I,J,1) - PHILIcol(IM,LM+1)=G*(Z(I,J,1)-Z(I,J,LM+1)) -! -!-- Terrain-specific inputs: -! - HPRIME(IM)=HSTDV(I,J) !-- standard deviation of orography - OC(IM)=HCNVX(I,J) !-- Normalized convexity - OA4(IM,1)=HASYW(I,J) !-- orographic asymmetry in W-E plane - OA4(IM,2)=HASYS(I,J) !-- orographic asymmetry in S-N plane - OA4(IM,3)=HASYSW(I,J) !-- orographic asymmetry in SW-NE plane - OA4(IM,4)=HASYNW(I,J) !-- orographic asymmetry in NW-SE plane - CLX4(IM,1)=HLENW(I,J) !-- orographic length scale in W-E plane - CLX4(IM,2)=HLENS(I,J) !-- orographic length scale in S-N plane - CLX4(IM,3)=HLENSW(I,J) !-- orographic length scale in SW-NE plane - CLX4(IM,4)=HLENNW(I,J) !-- orographic length scale in NW-SE plane - THETA(IM)=HANGL(I,J) ! - SIGMA(IM)=HSLOP(I,J) ! - GAMMA(IM)=HANIS(I,J) ! - ELVMAX(IM)=HZMAX(I,J) ! - LPBL(IM)=LM+1-KPBL(I,J) ! -! -!-- Output (diagnostics) -! - DUsfc(IM)=0. !-- U wind stress - DVsfc(IM)=0. !-- V wind stress -! -!======================================================================= -! - CALL GWD_col(DVDTcol,DUDTcol, DUsfc,DVsfc & ! Output - &, Ucol,Vcol,Tcol,Qcol,PINTcol,DPcol,Pcol,EXNcol & ! Met input - &, PHILIcol,PHIcol & ! Met input - &, HPRIME,OC,OA4,CLX4,THETA,SIGMA,GAMMA,ELVMAX & ! Topo input - &, CDMB,CLEFF,SIGFAC,FACTOP,RLOLEV,DPMIN & ! Tunable coefficients - &, LPBL,IMX,IM,LM) ! Indices -! -!======================================================================= -! - DO K=1,LM - KFLIP=LM-K+1 - TEST=ABS(DUDTcol(IM,K))+ABS(DVDTcol(IM,K)) - IF (TEST > THRESH) THEN -! -!-- First update winds in geodetic coordinates -! - Ugeo=Ucol(IM,K)+DUDTcol(IM,K)*DELTIM - Vgeo=Vcol(IM,K)+DVDTcol(IM,K)*DELTIM -! -!-- Transform/rotate winds from geodetic back to model coordinates -! - Umod=Ugeo*CROT(I,J)-Vgeo*SROT(I,J) - Vmod=Ugeo*SROT(I,J)+Vgeo*CROT(I,J) -! -!-- Calculate wind tendencies from the updated model winds -! - DUDT(I,J,KFLIP)=RDELTIM*(Umod-U(I,J,KFLIP)) - DVDT(I,J,KFLIP)=RDELTIM*(Vmod-V(I,J,KFLIP)) -! -!dtest=abs(dudt(i,k,j))+abs(dvdt(i,k,j)) - ENDIF !- IF (TEST > THRESH) THEN -! - ENDDO !- K -! -!-- Transform/rotate surface wind stresses from geodetic to model coordinates -! - UGWDsfc(I,J)=DUsfc(IM)*CROT(I,J)-DVsfc(IM)*SROT(I,J) - VGWDsfc(I,J)=DUsfc(IM)*SROT(I,J)+DVsfc(IM)*CROT(I,J) -! - ENDDO !- I - ENDDO !- J -! - END SUBROUTINE GWD_driver -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE GWD_col (A,B, DUsfc,DVsfc & !-- Output - &, U1,V1,T1,Q1, PRSI,DEL,PRSL,PRSLK, PHII,PHIL & !-- Met inputs - &, HPRIME,OC,OA4,CLX4,THETA,SIGMA,GAMMA,ELVMAX & !-- Topo inputs - &, CDMB,CLEFF,SIGFAC,FACTOP,RLOLEV,DPMIN & !-- Tunable coefficients - &, KPBL,IMX,IM,LM) !-- Input -! -!-- "A", "B" (from GFS) in GWD_col are DVDTcol, DUDTcol, respectively in GWD_driver -! -!=== Output fields -! -!-- A (DVDT), B (DUDT) - output zonal & meridional wind tendencies in Earth coordinates (m s^-2) -!-- DUsfc, DVsfc - surface zonal meridional wind stresses in Earth coordinates (m s^-1?) -! -!=== Input fields -! -!-- U1, V1 - zonal, meridional wind (m/s) -!-- T1 - temperature (deg K) -!-- Q1 - specific humidity (kg/kg) -!-- PRSI - lower interface pressure in centibars (1000 Pa) -!-- DEL - pressure thickness of layer in centibars (1000 Pa) -!-- PRSL - midlayer pressure in centibars (1000 Pa) -!-- PRSLK - Exner function, (P/P0)**(Rd/CP) -!-- PHII - lower interface geopotential in mks units -!-- PHIL - midlayer geopotential in mks units -!-- KDT - number of time steps into integration for diagnostics -!-- HPRIME - orographic standard deviation -!-- OC - normalized 4th moment of the orographic convexity -!-- OA4 - orographic asymmetry for upstream & downstream flow measured -! along 4 vertical planes (W-E, S-N, SW-NE, NW-SE) -!-- CLX4 - orographic length scale or mountain width measured along -! 4 vertical planes (W-E, S-N, SW-NE, NW-SE) -!-- THETA - angle of the mountain range w/r/t east -!-- SIGMA - slope of orography -!-- GAMMA - anisotropy/aspect ratio -!-- ELVMAX - max height above mean orography -!-- KPBL(IM) - vertical index at the top of the PBL -!-- IMX - points in a grid row -!-- KM - number of vertical levels -! -!####################################################################### -!################## ORIGINAL DOCUMENTATION BLOCK ##################### -!###### The following comments are from the original GFS code ######## -!####################################################################### -! ******************************************************************** -! -----> I M P L E M E N T A T I O N V E R S I O N <---------- -! -! --- Not in this code -- History of GWDP at NCEP---- -! ---------------- ----------------------- -! VERSION 3 MODIFIED FOR GRAVITY WAVES, LOCATION: .FR30(V3GWD) *J* -!--- 3.1 INCLUDES VARIABLE SATURATION FLUX PROFILE CF ISIGST -!--- 3.G INCLUDES PS COMBINED W/ PH (GLAS AND GFDL) -!----- ALSO INCLUDED IS RI SMOOTH OVER A THICK LOWER LAYER -!----- ALSO INCLUDED IS DECREASE IN DE-ACC AT TOP BY 1/2 -!----- THE NMC GWD INCORPORATING BOTH GLAS(P&S) AND GFDL(MIGWD) -!----- MOUNTAIN INDUCED GRAVITY WAVE DRAG -!----- CODE FROM .FR30(V3MONNX) FOR MONIN3 -!----- THIS VERSION (06 MAR 1987) -!----- THIS VERSION (26 APR 1987) 3.G -!----- THIS VERSION (01 MAY 1987) 3.9 -!----- CHANGE TO FORTRAN 77 (FEB 1989) --- HANN-MING HENRY JUANG -!----- -! -! VERSION 4 -! ----- This code ----- -! -!----- MODIFIED TO IMPLEMENT THE ENHANCED LOW TROPOSPHERIC GRAVITY -!----- WAVE DRAG DEVELOPED BY KIM AND ARAKAWA(JAS, 1995). -! Orographic Std Dev (hprime), Convexity (OC), Asymmetry (OA4) -! and Lx (CLX4) are input topographic statistics needed. -! -!----- PROGRAMMED AND DEBUGGED BY HONG, ALPERT AND KIM --- JAN 1996. -!----- debugged again - moorthi and iredell --- may 1998. -!----- -! Further Cleanup, optimization and modification -! - S. Moorthi May 98, March 99. -!----- modified for usgs orography data (ncep office note 424) -! and with several bugs fixed - moorthi and hong --- july 1999. -! -!----- Modified & implemented into NRL NOGAPS -! - Young-Joon Kim, July 2000 -!----- -! VERSION lm MB (6): oz fix 8/2003 -! ----- This code ----- -! -!------ Changed to include the Lott and Miller Mtn Blocking -! with some modifications by (*j*) 4/02 -! From a Principal Coordinate calculation using the -! Hi Res 8 minute orography, the Angle of the -! mtn with that to the East (x) axis is THETA, the slope -! parameter SIGMA. The anisotropy is in GAMMA - all are input -! topographic statistics needed. These are calculated off-line -! as a function of model resolution in the fortran code ml01rg2.f, -! with script mlb2.sh. (*j*) -!----- gwdps_mb.f version (following lmi) elvmax < hncrit (*j*) -! MB3a expt to enhance elvmax mtn hgt see sigfac & hncrit -!----- -!----------------------------------------------------------------------C -! - IMPLICIT NONE -! -!-- INPUT: -! - INTEGER, INTENT(IN) :: IM,IMX,LM - REAL, INTENT(IN) :: CDMB,CLEFF,SIGFAC,FACTOP,RLOLEV,DPMIN - - REAL(kind=kind_phys), INTENT(IN), DIMENSION(IM,1:LM) :: & - & U1,V1,T1,Q1,DEL,PRSL,PRSLK,PHIL - REAL(kind=kind_phys), INTENT(IN), DIMENSION(IM,1:LM+1) :: & - & PRSI,PHII - REAL(kind=kind_phys), INTENT(IN), DIMENSION(IM,4) :: OA4,CLX4 - REAL(kind=kind_phys), INTENT(IN), DIMENSION(IM) :: & - & HPRIME,OC,THETA,SIGMA,GAMMA,ELVMAX - INTEGER, INTENT(IN), DIMENSION(IM) :: KPBL -! -!-- OUTPUT: -! - REAL(kind=kind_phys), INTENT(INOUT), DIMENSION(IM,1:LM) :: A,B - REAL(kind=kind_phys), INTENT(INOUT), DIMENSION(IM) :: DUsfc,DVsfc -! -!----------------------------------------------------------------------- -!-- LOCAL variables: -!----------------------------------------------------------------------- -! -! Some constants -! -! - REAL(kind=kind_phys), PARAMETER :: PI=3.1415926535897931 & - &, G=9.806, CP=1004.6, RD=287.04, RV=461.6 & - &, FV=RV/RD-1., RDI=1./RD, GOR=G/RD, GR2=G*GOR, GOCP=G/CP & - &, ROG=1./G, ROG2=ROG*ROG, ROGN=-1000.*ROG & - &, DW2MIN=1., RIMIN=-100., RIC=0.25, BNV2MIN=1.0E-5 & - &, EFMIN=0.0, EFMAX=10.0, hpmax=2400.0 & !-- hpmax was 200.0 - &, FRC=1.0, CE=0.8, CEOFRC=CE/FRC, frmax=100. & - &, CG=0.5, GMAX=1.0, CRITAC=5.0E-4, VELEPS=1.0 & - &, HZERO=0., HONE=1., HE_2=.01, HE_1=0.1 & - &, PHY180=180.,RAD_TO_DEG=PHY180/PI,DEG_TO_RAD=PI/PHY180 & -! -!-- Lott & Miller mountain blocking => aka "lm mtn blocking" -! -! hncrit set to 8000m and sigfac added to enhance elvmax mtn hgt - &, hncrit=8000. & ! Max value in meters for ELVMAX (*j*) - &, hminmt=50. & ! min mtn height (*j*) - &, hpmin=1. & ! minimum hprime (std dev of terrain) - &, hstdmin=25. & ! min orographic std dev in height - &, minwnd=0.1 ! min wind component (*j*) -!rv &, dpmin=5.0 ! Minimum thickness of the reference layer (centibars) -!rv ! values of dpmin=0, 20 have also been used -! - integer, parameter :: mdir=8 - real(kind=kind_phys), parameter :: FDIR=mdir/(PI+PI) -! -!-- Template: -! NWD 1 2 3 4 5 6 7 8 -! WD W S SW NW E N NE SE -! - integer,save :: nwdir(mdir) - data nwdir /6,7,5,8,2,3,1,4/ -! - LOGICAL ICRILV(IM) -! -!---- MOUNTAIN INDUCED GRAVITY WAVE DRAG -! -! -! for lm mtn blocking - real(kind=kind_phys), DIMENSION(IM) :: WK,PE,EK,ZBK,UP,TAUB,XN & - & ,YN,UBAR,VBAR,ULOW,OA,CLX,ROLL,ULOI,DTFAC,XLINV,DELKS,DELKS1 & - & ,SCOR,BNV2bar, ELEVMX ! ,PSTAR -! - real(kind=kind_phys), DIMENSION(IM,1:LM) :: & - & BNV2LM,DB,ANG,UDS,BNV2,RI_N,TAUD,RO,VTK,VTJ - real(kind=kind_phys), DIMENSION(IM,1:LM-1) :: VELCO - real(kind=kind_phys), DIMENSION(IM,1:LM+1) :: TAUP - real(kind=kind_phys), DIMENSION(LM-1) :: VELKO -! - integer, DIMENSION(IM) :: & - & kref,kint,iwk,iwk2,ipt,kreflm,iwklm,iptlm,idxzb -! -! for lm mtn blocking -! - real(kind=kind_phys) :: ZLEN, DBTMP, R, PHIANG, DBIM & - &, xl, rcsks, bnv, fr & - &, brvf, tem, tem1, tem2, temc, temv & - &, wdir, ti, rdz, dw2, shr2, bvf2 & - &, rdelks, wtkbj, efact, coefm, gfobnv & - &, scork, rscor, hd, fro, rim, sira & - &, dtaux, dtauy, pkp1log, pklog, cosang, sinang -! - integer :: ncnt, kmm1, kmm2, lcap, lcapp1, kbps, kbpsp1,kbpsm1 & - &, kmps, kmpsp1, idir, nwd, i, j, k, klcap, kp1, kmpbl, npt, npr & - &, idxm1, ktrial, klevm1, kmll,kmds, KM & -! &, ihit,jhit & - &, ME !-- processor element for debugging - -! -!----------------------------------------------------------------------- -! - KM = LM - npr = 0 - DO I = 1, IM - DUsfc(I) = 0. - DVsfc(I) = 0. -! -!-- ELEVMX is a local array that could be changed below -! - ELEVMX(I) = ELVMAX(I) - ENDDO -! -!-- Note that A, B already set to zero as DUDTcol, DVDTcol in subroutine GWD_driver -! - ipt = 0 - npt = 0 - IF (NMTVR >= 14) then - DO I = 1,IM - IF (elvmax(i) > HMINMT .AND. hprime(i) > hpmin) then - npt = npt + 1 - ipt(npt) = i - ENDIF - ENDDO - ELSE - DO I = 1,IM - IF (hprime(i) > hpmin) then - npt = npt + 1 - ipt(npt) = i - ENDIF - ENDDO - ENDIF !-- IF (NMTVR >= 14) then -! - -! -!-- Note important criterion for immediately exiting routine! -! - IF (npt <= 0) RETURN ! No gwd/mb calculation done! -! - do i=1,npt - IDXZB(i) = 0 - enddo -! - DO K = 1, KM - DO I = 1, IM - DB(I,K) = 0. - ANG(I,K) = 0. - UDS(I,K) = 0. - ENDDO - ENDDO -! - KMM1 = KM - 1 - KMM2 = KM - 2 - LCAP = KM - LCAPP1 = LCAP + 1 -! -! - IF (NMTVR .eq. 14) then -! ---- for lm and gwd calculation points -! -! --- iwklm is the level above the height of the mountain. -! --- idxzb is the level of the dividing streamline. -! INITIALIZE DIVIDING STREAMLINE (DS) CONTROL VECTOR -! - do i=1,npt - iwklm(i) = 2 - kreflm(i) = 0 - enddo -! -! -! start lm mtn blocking (mb) section -! -!.............................. -!.............................. -! -! (*j*) 11/03: test upper limit on KMLL=km - 1 -! then do not need hncrit -- test with large hncrit first. -! KMLL = km / 2 ! maximum mtnlm height : # of vertical levels / 2 - KMLL = kmm1 -! --- No mtn should be as high as KMLL (so we do not have to start at -! --- the top of the model but could do calc for all levels). -! - - DO I = 1, npt - j = ipt(i) - ELEVMX(J) = min (ELEVMX(J) + sigfac * hprime(j), hncrit) - ENDDO - - DO K = 1,KMLL - DO I = 1, npt - j = ipt(i) -! --- interpolate to max mtn height for index, iwklm(I) wk[gz] -! --- ELEVMX is limited to hncrit because to hi res topo30 orog. - pkp1log = phil(j,k+1) * ROG - pklog = phil(j,k) * ROG - if ( ( ELEVMX(j) .le. pkp1log ) .and. & - & ( ELEVMX(j) .ge. pklog ) ) THEN -! --- wk for diags but can be saved and reused. - wk(i) = G * ELEVMX(j) / ( phil(j,k+1) - phil(j,k) ) - iwklm(I) = MAX(iwklm(I), k+1 ) - - endif -! -! --- find at prsl levels large scale environment variables -! --- these cover all possible mtn max heights - VTJ(I,K) = T1(J,K) * (1.+FV*Q1(J,K)) ! virtual temperature - VTK(I,K) = VTJ(I,K) / PRSLK(J,K) ! potential temperature - RO(I,K) = RDI * PRSL(J,K) / VTJ(I,K) ! DENSITY (1.e-3 kg m^-3) - - ENDDO !-- DO I = 1, npt -! - ENDDO !-- DO K = 1,KMLL -! - klevm1 = KMLL - 1 - DO K = 1, klevm1 - DO I = 1, npt - j = ipt(i) - RDZ = g / ( phil(j,k+1) - phil(j,k) ) -! --- Brunt-Vaisala Frequency - BNV2LM(I,K) = (G+G) * RDZ * ( VTK(I,K+1)-VTK(I,K) ) & - & / ( VTK(I,K+1)+VTK(I,K) ) - bnv2lm(i,k) = max( bnv2lm(i,k), bnv2min ) - - ENDDO - ENDDO -! - DO I = 1, npt - J = ipt(i) - DELKS(I) = 1.0 / (PRSI(J,1) - PRSI(J,iwklm(i))) - DELKS1(I) = 1.0 / (PRSL(J,1) - PRSL(J,iwklm(i))) - UBAR (I) = 0.0 - VBAR (I) = 0.0 - ROLL (I) = 0.0 - PE (I) = 0.0 - EK (I) = 0.0 - BNV2bar(I) = (PRSL(J,1)-PRSL(J,2)) * DELKS1(I) * BNV2LM(I,1) - ENDDO -! -! --- find the dividing stream line height -! --- starting from the level above the max mtn downward -! --- iwklm(i) is the k-index of mtn elevmx elevation -! - DO Ktrial = KMLL, 1, -1 - DO I = 1, npt - IF ( Ktrial .LT. iwklm(I) .and. kreflm(I) .eq. 0 ) then - kreflm(I) = Ktrial - ENDIF - ENDDO - ENDDO -! -! --- in the layer kreflm(I) to 1 find PE (which needs N, ELEVMX) -! --- make averages, guess dividing stream (DS) line layer. -! --- This is not used in the first cut except for testing and -! --- is the vert ave of quantities from the surface to mtn top. -! - - DO I = 1, npt - DO K = 1, Kreflm(I) - J = ipt(i) - RDELKS = DEL(J,K) * DELKS(I) - UBAR(I) = UBAR(I) + RDELKS * U1(J,K) ! trial Mean U below - VBAR(I) = VBAR(I) + RDELKS * V1(J,K) ! trial Mean V below - ROLL(I) = ROLL(I) + RDELKS * RO(I,K) ! trial Mean RO below - RDELKS = (PRSL(J,K)-PRSL(J,K+1)) * DELKS1(I) - BNV2bar(I) = BNV2bar(I) + BNV2lm(I,K) * RDELKS -! --- these vert ave are for diags, testing and GWD to follow (*j*). - - ENDDO - ENDDO - -! -! --- integrate to get PE in the trial layer. -! --- Need the first layer where PE>EK - as soon as -! --- IDXZB is not 0 we have a hit and Zb is found. -! - DO I = 1, npt - J = ipt(i) - - DO K = iwklm(I), 1, -1 - PHIANG = atan2(V1(J,K),U1(J,K))*RAD_TO_DEG -! --- THETA ranges from -+90deg |_ to the mtn "largest topo variations" - ANG(I,K) = ( THETA(J) - PHIANG ) - if ( ANG(I,K) .gt. 90. ) ANG(I,K) = ANG(I,K) - 180. - if ( ANG(I,K) .lt. -90. ) ANG(I,K) = ANG(I,K) + 180. - ANG(I,K) = ANG(I,K)*DEG_TO_RAD - UDS(I,K) = MAX(SQRT(U1(J,K)*U1(J,K)+V1(J,K)*V1(J,K)), minwnd) -! --- Test to see if we found Zb previously - IF (IDXZB(I) .eq. 0 ) then - PE(I) = PE(I) + BNV2lm(I,K) * & - & ( G * ELEVMX(J) - phil(J,K) ) * & - & ( PHII(J,K+1) - PHII(J,K) ) * ROG2 - -! --- Kinetic energy (KE): Wind projected on the line perpendicular to -! mtn range, U(Zb(K)). KE is at the layer Zb - UP(I) = UDS(I,K)*cos(ANG(I,K)) - EK(I) = 0.5*UP(I)*UP(I) -! --- Dividing Stream lime is found when PE =exceeds EK. - IF ( PE(I) .ge. EK(I) ) IDXZB(I) = K -! --- Then mtn blocked flow is between Zb=k(IDXZB(I)) and surface -! - ENDIF !-- IF (IDXZB(I) .eq. 0 ) then - ENDDO !-- DO K = iwklm(I), 1, -1 - ENDDO !-- DO I = 1, npt -! - DO I = 1, npt - J = ipt(i) -! --- Calc if N constant in layers (Zb guess) - a diagnostic only. - ZBK(I) = ELEVMX(J) - SQRT(UBAR(I)**2 + VBAR(I)**2)/BNV2bar(I) - ENDDO -! -! --- The drag for mtn blocked flow -! - DO I = 1, npt - J = ipt(i) - ZLEN = 0. - IF ( IDXZB(I) .gt. 0 ) then - DO K = IDXZB(I), 1, -1 - IF (PHIL(J,IDXZB(I)) > PHIL(J,K)) THEN - ZLEN = SQRT( ( PHIL(J,IDXZB(I))-PHIL(J,K) ) / & - & ( PHIL(J,K ) + G * HPRIME(J) ) ) -! --- lm eq 14: - cosang=cos(ANG(I,K)) - sinang=sin(ANG(I,K)) - R = (cosang*cosang + GAMMA(J)*sinang*sinang) / & - & (GAMMA(J)*cosang*cosang + sinang*sinang) -! --- (negative of DB -- see sign at tendency); CDMB adjusts mountain blocking -! --- modified lm eq 15: - DBTMP = 0.25 * CDMB * & - & MAX( 2. - 1. / R, HZERO ) * SIGMA(J) * & - & MAX(HZERO, cosang, GAMMA(J)*sinang) * & - & ZLEN / hprime(J) - DB(I,K) = MAX(HZERO, DBTMP*UDS(I,K) ) - ENDIF !-- IF (PHIL(J,IDXZB(I)) > PHIL(J,K) .AND. DEN > 0.) THEN - ENDDO !-- DO K = IDXZB(I), 1, -1 - endif - ENDDO !-- DO I = 1, npt -! -!............................. -!............................. -! end mtn blocking section -! - ENDIF !-- IF ( NMTVR .eq. 14) then -! -!............................. -!............................. -! - KMPBL = km / 2 ! maximum pbl height : # of vertical levels / 2 - - DO K = 1,KM - DO I =1,npt - J = ipt(i) - VTJ(I,K) = T1(J,K) * (1.+FV*Q1(J,K)) - VTK(I,K) = VTJ(I,K) / PRSLK(J,K) - RO(I,K) = RDI * PRSL(J,K) / VTJ(I,K) ! DENSITY - TAUP(I,K) = 0.0 - ENDDO - ENDDO - - DO K = 1,KMM1 - DO I =1,npt - J = ipt(i) - TI = 2.0 / (T1(J,K)+T1(J,K+1)) - TEM = TI / (PRSL(J,K)-PRSL(J,K+1)) - RDZ = g / (phil(j,k+1) - phil(j,k)) - TEM1 = U1(J,K) - U1(J,K+1) - TEM2 = V1(J,K) - V1(J,K+1) - DW2 = (TEM1*TEM1 + TEM2*TEM2) - SHR2 = MAX(DW2,DW2MIN) * RDZ * RDZ - BVF2 = G*(GOCP+RDZ*(VTJ(I,K+1)-VTJ(I,K))) * TI -!-- ri_n is Richardson Number, BNV2 is Brunt-Vaisala Frequency - ri_n(I,K) = MAX(BVF2/SHR2,RIMIN) ! Richardson number - BNV2(I,K) = (G+G) * RDZ * (VTK(I,K+1)-VTK(I,K)) & - & / (VTK(I,K+1)+VTK(I,K)) - bnv2(i,k) = max( bnv2(i,k), bnv2min ) - ENDDO !-- DO K = 1,KMM1 - ENDDO !-- DO I =1,npt -! - do i=1,npt - iwk(i) = 2 - enddo - - DO K=3,KMPBL - DO I=1,npt - j = ipt(i) - tem = (prsi(j,1) - prsi(j,k)) - if (tem .lt. dpmin) iwk(i) = k - enddo - enddo -! - KBPS = 1 - KMPS = KM - DO I=1,npt - J = ipt(i) - kref(I) = MAX(IWK(I), KPBL(J)+1 ) ! reference level - DELKS(I) = 1.0 / (PRSI(J,1) - PRSI(J,kref(I))) - DELKS1(I) = 1.0 / (PRSL(J,1) - PRSL(J,kref(I))) - UBAR (I) = 0.0 - VBAR (I) = 0.0 - ROLL (I) = 0.0 - KBPS = MAX(KBPS, kref(I)) - KMPS = MIN(KMPS, kref(I)) - BNV2bar(I) = (PRSL(J,1)-PRSL(J,2)) * DELKS1(I) * BNV2(I,1) - ENDDO -! - KBPSP1 = KBPS + 1 - KBPSM1 = KBPS - 1 - DO K = 1,KBPS - DO I = 1,npt - IF (K .LT. kref(I)) THEN - J = ipt(i) - RDELKS = DEL(J,K) * DELKS(I) - UBAR(I) = UBAR(I) + RDELKS * U1(J,K) ! Mean U below kref - VBAR(I) = VBAR(I) + RDELKS * V1(J,K) ! Mean V below kref - ROLL(I) = ROLL(I) + RDELKS * RO(I,K) ! Mean RO below kref - RDELKS = (PRSL(J,K)-PRSL(J,K+1)) * DELKS1(I) - BNV2bar(I) = BNV2bar(I) + BNV2(I,K) * RDELKS - ENDIF - ENDDO - ENDDO -! -! FIGURE OUT LOW-LEVEL HORIZONTAL WIND DIRECTION AND FIND 'OA' -! -! NWD 1 2 3 4 5 6 7 8 -! WD W S SW NW E N NE SE -! - DO I = 1,npt - J = ipt(i) - wdir = atan2(UBAR(I),VBAR(I)) + pi - idir = mod(nint(fdir*wdir),mdir) + 1 - nwd = nwdir(idir) - OA(I) = (1-2*INT( (NWD-1)/4 )) * OA4(J,MOD(NWD-1,4)+1) - CLX(I) = CLX4(J,MOD(NWD-1,4)+1) - ENDDO -! -!-----XN,YN "LOW-LEVEL" WIND PROJECTIONS IN ZONAL -! & MERIDIONAL DIRECTIONS -!-----ULOW "LOW-LEVEL" WIND MAGNITUDE - (= U) -!-----BNV2 BNV2 = N**2 -!-----TAUB BASE MOMENTUM FLUX -!-----= -(RO * U**3/(N*XL)*GF(FR) FOR N**2 > 0 -!-----= 0. FOR N**2 < 0 -!-----FR FROUDE = N*HPRIME / U -!-----G GMAX*FR**2/(FR**2+CG/OC) -! -!-----INITIALIZE SOME ARRAYS -! - DO I = 1,npt - XN(I) = 0.0 - YN(I) = 0.0 - TAUB (I) = 0.0 - ULOW (I) = 0.0 - DTFAC(I) = 1.0 - ICRILV(I) = .FALSE. ! INITIALIZE CRITICAL LEVEL CONTROL VECTOR -! -!----COMPUTE THE "LOW LEVEL" WIND MAGNITUDE (M/S) -! - ULOW(I) = MAX(SQRT(UBAR(I)*UBAR(I) + VBAR(I)*VBAR(I)), HONE) - ULOI(I) = 1.0 / ULOW(I) - ENDDO -! - DO K = 1,KMM1 - DO I = 1,npt - J = ipt(i) - VELCO(I,K) = 0.5*ULOI(I)*( (U1(J,K)+U1(J,K+1))*UBAR(I) & - & +(V1(J,K)+V1(J,K+1))*VBAR(I) ) - ENDDO - ENDDO -! -! find the interface level of the projected wind where -! low levels & upper levels meet above pbl -! - do i=1,npt - kint(i) = km - enddo - do k = 1,kmm1 - do i = 1,npt - IF (K .GT. kref(I)) THEN - if(velco(i,k) .lt. veleps .and. kint(i) .eq. km) then - kint(i) = k+1 - endif - endif - enddo - enddo -! WARNING KINT = KREF !!!!!!!!! - do i=1,npt - kint(i) = kref(i) - enddo -! -! - DO I = 1,npt - J = ipt(i) - BNV = SQRT( BNV2bar(I) ) - FR = BNV * ULOI(I) * min(HPRIME(J),hpmax) - FR = MIN(FR, FRMAX) - XN(I) = UBAR(I) * ULOI(I) - YN(I) = VBAR(I) * ULOI(I) -! -! Compute the base level stress and store it in TAUB -! CALCULATE ENHANCEMENT FACTOR, NUMBER OF MOUNTAINS & ASPECT -! RATIO CONST. USE SIMPLIFIED RELATIONSHIP BETWEEN STANDARD -! DEVIATION & CRITICAL HGT -! - EFACT = (OA(I) + 2.) ** (CEOFRC*FR) - EFACT = MIN( MAX(EFACT,EFMIN), EFMAX ) -! - COEFM = (1. + CLX(I)) ** (OA(I)+1.) -! - XLINV(I) = COEFM * CLEFF -! - TEM = FR * FR * OC(J) - GFOBNV = GMAX * TEM / ((TEM + CG)*BNV) ! G/N0 -! - TAUB(I) = XLINV(I) * ROLL(I) * ULOW(I) * ULOW(I) & - & * ULOW(I) * GFOBNV * EFACT ! BASE FLUX Tau0 -! - K = MAX(1, kref(I)-1) -!-- Change in the GFS version of gwdps.f - TEM = MAX(VELCO(I,K)*VELCO(I,K), HE_1) - SCOR(I) = BNV2(I,K) / TEM ! Scorer parameter below ref level - ENDDO !-- DO I = 1,npt -! -!----SET UP BOTTOM VALUES OF STRESS -! - DO K = 1, KBPS - DO I = 1,npt - IF (K .LE. kref(I)) TAUP(I,K) = TAUB(I) - ENDDO - ENDDO - -! -! Now compute vertical structure of the stress. -! - DO K = KMPS, KMM1 ! Vertical Level K Loop! - KP1 = K + 1 - DO I = 1, npt -! -!-----UNSTABLE LAYER IF RI < RIC -!-----UNSTABLE LAYER IF UPPER AIR VEL COMP ALONG SURF VEL <=0 (CRIT LAY) -!---- AT (U-C)=0. CRIT LAYER EXISTS AND BIT VECTOR SHOULD BE SET (.LE.) -! - IF (K .GE. kref(I)) THEN - ICRILV(I) = ICRILV(I) .OR. ( ri_n(I,K) .LT. RIC) & - & .OR. (VELCO(I,K) .LE. 0.0) - ENDIF - ENDDO -! - DO I = 1,npt - IF (K .GE. kref(I)) THEN -! - IF (.NOT.ICRILV(I) .AND. TAUP(I,K) .GT. 0.0 ) THEN - TEMV = 1.0 / max(VELCO(I,K), HE_2) -! IF (OA(I) .GT. 0. .AND. PRSI(ipt(i),KP1).GT.RLOLEV) THEN - IF (OA(I).GT.0. .AND. kp1 .lt. kint(i)) THEN - SCORK = BNV2(I,K) * TEMV * TEMV - RSCOR = MIN(HONE, SCORK / SCOR(I)) - SCOR(I) = SCORK - ELSE - RSCOR = 1. - ENDIF -! - BRVF = SQRT(BNV2(I,K)) ! Brunt-Vaisala Frequency - TEM1 = XLINV(I)*(RO(I,KP1)+RO(I,K))*BRVF*0.5 & - & * max(VELCO(I,K),HE_2) - HD = SQRT(TAUP(I,K) / TEM1) - FRO = BRVF * HD * TEMV -! -! RIM is the MINIMUM-RICHARDSON NUMBER BY SHUTTS (1985) -! - TEM2 = SQRT(ri_n(I,K)) - TEM = 1. + TEM2 * FRO - RIM = ri_n(I,K) * (1.-FRO) / (TEM * TEM) -! -! CHECK STABILITY TO EMPLOY THE SATURATION HYPOTHESIS -! OF LINDZEN (1981) EXCEPT AT TROPOSPHERIC DOWNSTREAM REGIONS -! -! ---------------------- - IF (RIM .LE. RIC .AND. & - & (OA(I) .LE. 0. .OR. kp1 .ge. kint(i) )) THEN - TEMC = 2.0 + 1.0 / TEM2 - HD = VELCO(I,K) * (2.*SQRT(TEMC)-TEMC) / BRVF - TAUP(I,KP1) = TEM1 * HD * HD - ELSE - TAUP(I,KP1) = TAUP(I,K) * RSCOR - ENDIF - taup(i,kp1) = min(taup(i,kp1), taup(i,k)) - - ENDIF !-- IF (.NOT.ICRILV(I) .AND. TAUP(I,K) .GT. 0.0 ) THEN - ENDIF !-- IF (K .GE. kref(I)) THEN - ENDDO !-- DO I = 1,npt - ENDDO !-- DO K = KMPS, KMM1 -! - IF(LCAP .LE. KM) THEN - - DO KLCAP = LCAPP1, KM+1 - DO I = 1,npt - SIRA = PRSI(ipt(I),KLCAP) / PRSI(ipt(I),LCAP) - TAUP(I,KLCAP) = SIRA * TAUP(I,LCAP) - ENDDO - ENDDO - ENDIF -! -! Calculate - (g/p*)*d(tau)/d(sigma) and Decel terms DTAUX, DTAUY -! - DO K = 1,KM - DO I = 1,npt - TAUD(I,K) = G*(TAUP(I,K+1)-TAUP(I,K))/DEL(ipt(I),K) - ENDDO - ENDDO - -! -!------LIMIT DE-ACCELERATION (MOMENTUM DEPOSITION ) AT TOP TO 1/2 VALUE -!------THE IDEA IS SOME STUFF MUST GO OUT THE TOP -! - DO KLCAP = LCAP, KM - DO I = 1,npt - TAUD(I,KLCAP) = TAUD(I,KLCAP) * FACTOP - ENDDO - ENDDO -! -!------IF THE GRAVITY WAVE DRAG WOULD FORCE A CRITICAL LINE IN THE -!------LAYERS BELOW SIGMA=RLOLEV DURING THE NEXT DELTIM TIMESTEP, -!------THEN ONLY APPLY DRAG UNTIL THAT CRITICAL LINE IS REACHED. -! - DO K = 1,KMM1 - DO I = 1,npt - IF (K .GT. kref(I) .and. PRSI(ipt(i),K) .GE. RLOLEV) THEN - IF(TAUD(I,K).NE.0.) THEN - TEM = DELTIM * TAUD(I,K) - DTFAC(I) = MIN(DTFAC(I),ABS(VELCO(I,K)/TEM)) - - ENDIF - ENDIF - ENDDO - ENDDO - - DO K = 1,KM - DO I = 1,npt - J = ipt(i) - TAUD(I,K) = TAUD(I,K) * DTFAC(I) - DTAUX = TAUD(I,K) * XN(I) - DTAUY = TAUD(I,K) * YN(I) -! --- lm mb (*j*) changes overwrite GWD - if ( K .lt. IDXZB(I) .AND. IDXZB(I) .ne. 0 ) then - DBIM = DB(I,K) / (1.+DB(I,K)*DELTIM) - -!dbg 20160708 -if(DBIM<0.) write(0,"(a,3g12.4)") 'DBIM,DB,DELTIM=',DBIM,DB(I,K),DELTIM - - DBIM = MAX(DBIM, HZERO) - A(J,K) = - DBIM * V1(J,K) + A(J,K) - B(J,K) = - DBIM * U1(J,K) + B(J,K) - DUsfc(J) = DUsfc(J) - DBIM * V1(J,K) * DEL(J,K) - DVsfc(J) = DVsfc(J) - DBIM * U1(J,K) * DEL(J,K) - else - A(J,K) = DTAUY + A(J,K) - B(J,K) = DTAUX + B(J,K) - DUsfc(J) = DUsfc(J) + DTAUX * DEL(J,K) - DVsfc(J) = DVsfc(J) + DTAUY * DEL(J,K) - endif - ENDDO !-- DO I = 1,npt - ENDDO !-- DO K = 1,KM -! - DO I = 1,npt - J = ipt(i) - DUsfc(J) = ROGN * DUsfc(J) - DVsfc(J) = ROGN * DVsfc(J) - ENDDO -! -!----------------------------------------------------------------------- -! - END SUBROUTINE GWD_col -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - END MODULE MODULE_GWD -! -!----------------------------------------------------------------------- diff --git a/src/nmm/module_H_TO_V.F90 b/src/nmm/module_H_TO_V.F90 deleted file mode 100644 index ad21108..0000000 --- a/src/nmm/module_H_TO_V.F90 +++ /dev/null @@ -1,232 +0,0 @@ -!----------------------------------------------------------------------- - MODULE MODULE_H_TO_V -!----------------------------------------------------------------------- -! -!*** MOVE DATA RESIDING ON B-GRID H POINTS TO V POINTS. -! -!----------------------------------------------------------------------- -! - USE MODULE_KINDS - USE MODULE_MY_DOMAIN_SPECS -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: H_TO_V,H_TO_V_TEND -! -!----------------------------------------------------------------------- -! - INTERFACE H_TO_V - MODULE PROCEDURE H_TO_V_2D - MODULE PROCEDURE H_TO_V_3D - END INTERFACE -! - INTERFACE H_TO_V_TEND - MODULE PROCEDURE H_TO_V_TEND_2D - MODULE PROCEDURE H_TO_V_TEND_3D - END INTERFACE -! -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - SUBROUTINE H_TO_V_2D(ARRAY_H,ARRAY_V) -! -!----------------------------------------------------------------------- -! -!*** MOVE A 2-D ARRAY FROM H POINTS TO V POINTS. -! -!----------------------------------------------------------------------- -!*** ARGUMENT VARIABLES -!----------------------------------------------------------------------- -! - REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: ARRAY_H -! - REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: ARRAY_V -! -!----------------------------------------------------------------------- -!*** LOCAL VARIABLES -!----------------------------------------------------------------------- -! - INTEGER(KIND=KINT) :: I,J -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!$omp parallel do & -!$omp& private(i,j) - DO J=JTS,JTE_B1 - DO I=ITS,ITE_B1 - ARRAY_V(I,J)=(ARRAY_H(I,J )+ARRAY_H(I+1,J ) & - +ARRAY_H(I,J+1)+ARRAY_H(I+1,J+1))*0.25 - ENDDO - ENDDO -!----------------------------------------------------------------------- -! - END SUBROUTINE H_TO_V_2D -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!-------------------------------------------------------------------- -! - SUBROUTINE H_TO_V_3D(ARRAY_H,ARRAY_V,LM) -! -!----------------------------------------------------------------------- -! -!*** MOVE A 3-D ARRAY FROM H POINTS TO V POINTS. -! -!----------------------------------------------------------------------- -!*** ARGUMENT VARIABLES -!----------------------------------------------------------------------- -! - INTEGER(KIND=KINT),INTENT(IN) :: LM -! - REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(IN) :: & - ARRAY_H -! - REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(OUT) :: & - ARRAY_V -! -!----------------------------------------------------------------------- -!*** LOCAL VARIABLES -!----------------------------------------------------------------------- -! - INTEGER(KIND=KINT) :: I,J,K -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!$omp parallel do & -!$omp& private(i,j,k) - DO K=1,LM - DO J=JTS,JTE_B1 - DO I=ITS,ITE_B1 - ARRAY_V(I,J,K)=(ARRAY_H(I,J ,K)+ARRAY_H(I+1,J ,K) & - +ARRAY_H(I,J+1,K)+ARRAY_H(I+1,J+1,K))*0.25 - ENDDO - ENDDO - ENDDO -!----------------------------------------------------------------------- -! - END SUBROUTINE H_TO_V_3D -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!-------------------------------------------------------------------- -! - SUBROUTINE H_TO_V_TEND_2D(TEND,DT,NSTEPS,ARRAY_V) -! -!----------------------------------------------------------------------- -! -!*** UPDATE 2-D V POINT ARRAYS WITH TENDENCIES ON H POINTS. -! -!----------------------------------------------------------------------- -!*** ARGUMENT VARIABLES -!----------------------------------------------------------------------- -! - INTEGER(KIND=KINT),INTENT(IN) :: NSTEPS -! - REAL(KIND=KFPT),INTENT(IN) :: DT -! - REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: TEND -! - REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: ARRAY_V -! -!----------------------------------------------------------------------- -!*** LOCAL VARIABLES -!----------------------------------------------------------------------- -! - INTEGER(KIND=KINT) :: I,J -! - REAL(KIND=KFPT) :: DELTA_T -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - DELTA_T=DT*NSTEPS -! -!$omp parallel do & -!$omp& private(i,j) - DO J=JTS,JTE_B1 - DO I=ITS,ITE_B1 - ARRAY_V(I,J)= ARRAY_V(I,J)+ & - 0.25*(TEND(I,J )+TEND(I+1,J ) & - +TEND(I,J+1)+TEND(I+1,J+1))*DELTA_T - ENDDO - ENDDO -!----------------------------------------------------------------------- -! - END SUBROUTINE H_TO_V_TEND_2D -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!-------------------------------------------------------------------- -! - SUBROUTINE H_TO_V_TEND_3D(TEND,DT,NSTEPS,LM,ARRAY_V) -! -!----------------------------------------------------------------------- -! -!*** UPDATE 3-D V POINT ARRAYS WITH TENDENCIES ON H POINTS. -!*** THE 3-D TEND ARRAY IS I,K,J WHERE K IS RECKONED POSITIVE UPWARD. -! -!----------------------------------------------------------------------- -!*** ARGUMENT VARIABLES -!----------------------------------------------------------------------- -! - INTEGER(KIND=KINT) :: LM,NSTEPS -! - REAL(KIND=KFPT) :: DT -! - REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(IN) :: TEND -! - REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(INOUT) :: & - ARRAY_V -! -!----------------------------------------------------------------------- -!*** LOCAL VARIABLES -!----------------------------------------------------------------------- -! - INTEGER(KIND=KINT) :: I,J,K -! - REAL(KIND=KFPT) :: DELTA_T -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - DELTA_T=DT*NSTEPS -! -!$omp parallel do & -!$omp& private(i,j,k) - DO K=1,LM - DO J=JTS,JTE_B1 - DO I=ITS,ITE_B1 - ARRAY_V(I,J,K)=ARRAY_V(I,J,K)+ & - 0.25*(TEND(I,J,K )+TEND(I+1,J,K ) & - +TEND(I,J+1,K)+TEND(I+1,J+1,K))*DELTA_T - ENDDO - ENDDO - ENDDO -!----------------------------------------------------------------------- -! - END SUBROUTINE H_TO_V_TEND_3D -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!-------------------------------------------------------------------- -! - END MODULE MODULE_H_TO_V -! -!----------------------------------------------------------------------- diff --git a/src/nmm/module_INIT_READ_BIN.F90 b/src/nmm/module_INIT_READ_BIN.F90 deleted file mode 100644 index 2026af0..0000000 --- a/src/nmm/module_INIT_READ_BIN.F90 +++ /dev/null @@ -1,2919 +0,0 @@ -!----------------------------------------------------------------------- - module module_INIT_READ_BIN -!----------------------------------------------------------------------- -use module_kinds -use module_dm_parallel,only : dstrb,idstrb -use module_exchange -use module_constants -use module_solver_internal_state,only: solver_internal_state -use module_microphysics_nmm -! -!----------------------------------------------------------------------- -! - implicit none -! - private -! - public :: read_binary,physics_read_gwd -! -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! - contains -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - subroutine read_binary & - (INT_STATE & - ,my_domain_id & - ,mpi_comm_comp & - ,mype & - ,its,ite,jts,jte & - ,ims,ime,jms,jme & - ,ids,ide,jds,jde & - ,its_h2,ite_h2,jts_h2,jte_h2 & - ,lm & - ,rc) -! -!----------------------------------------------------------------------- -! -implicit none -! -!------------------------ -!*** Argument variables -!------------------------ -! -type(solver_internal_state),pointer :: int_state - -integer(kind=kint),intent(in) :: & - its,ite & -,ims,ime & -,ids,ide & -,its_h2,ite_h2 & -,jts,jte & -,jms,jme & -,jds,jde & -,jts_h2,jte_h2 & -,lm & -,mpi_comm_comp & -,my_domain_id & -,mype - -integer(kind=kint),intent(out) :: & - rc -! -!--------------------- -!*** Local variables -!--------------------- -! -integer(kind=kint) :: & - i & ! index in x direction -,iend & -,irtn & -,j & ! index in y direction -,jend & -,k & ! index -,kount & -,ks & ! tracer index -,l & ! index in p direction -,lb & -,length & -,n & -,nl & -,nv & -,nvars_bc_2d_h & -,nvars_bc_3d_h & -,nvars_bc_4d_h & -,nvars_bc_2d_v & -,nvars_bc_3d_v & -,ub - -integer(kind=kint) :: & ! dimensions from input file - im & -,jm & -,lmm & -,lnsh - -integer(kind=kint) :: & - iyear_fcst & -,imonth_fcst & -,iday_fcst & -,ihour_fcst - -real(kind=kfpt):: & - tend,tend_max,arg - -real(kind=kfpt),dimension(int_state%NSOIL) :: & - soil1din - -real(kind=kfpt),dimension(:),allocatable :: & - all_bc_data,psint - -real(kind=kfpt),allocatable,dimension(:,:) :: & - temp1 - -integer(kind=kfpt),allocatable,dimension(:,:) :: & - itemp - -real(kind=kfpt),allocatable,dimension(:,:,:) :: & - tempsoil - -logical(kind=klog) :: opened - -integer(kind=kint) :: & - ierr - -character(64):: & - infile - -integer(kind=kint):: & - ntsd & -,ntstm_max & -,nfcst - -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - allocate(temp1(ids:ide,jds:jde),stat=i) -! -!----------------------------------------------------------------------- -! - select_unit: do n=51,59 - inquire(n,opened=opened) - if(.not.opened)then - nfcst=n - exit select_unit - endif - enddo select_unit -! -!----------------------------------------------------------------------- -! - read_blocks: if(.not.int_state%RESTART) then ! cold start -! -!----------------------------------------------------------------------- -! - write(infile,'(a,i2.2)')'input_domain_',my_domain_id - open(unit=nfcst,file=infile,status='old',form='unformatted' & - ,iostat=ierr) - if(ierr/=0)then - write(0,*)' Unable to open ',trim(infile),' in READ_BINARY' - rc = ierr - return - endif -! -!----------------------------------------------------------------------- -! - read (nfcst) int_state%RUN, & - int_state%IDAT, & - int_state%IHRST, & - int_state%IHREND, & - NTSD - read (nfcst) int_state%PT, & - int_state%PDTOP, & - int_state%LPT2, & - int_state%SGM, & - int_state%SG1, & - int_state%DSG1, & - int_state%SGML1, & - int_state%SG2, & - int_state%DSG2, & - int_state%SGML2 - read (nfcst) int_state%I_PAR_STA, & - int_state%J_PAR_STA - read (nfcst) int_state%DLMD, & - int_state%DPHD, & - int_state%WBD, & - int_state%SBD, & - int_state%TLM0D, & - int_state%TPH0D - read (nfcst) im,jm,lmm,lnsh -! -!----------------------------------------------------------------------- -!*** Print the time & domain information. -!----------------------------------------------------------------------- -! - if(mype==0)then - write(0,*) 'run, idat,ntsd: ', int_state%RUN, int_state%IDAT, NTSD - write(0,*)' Start year =',int_state%IDAT(3) - write(0,*)' Start month=',int_state%IDAT(2) - write(0,*)' Start day =',int_state%IDAT(1) - write(0,*)' Start hour =',int_state%IHRST - write(0,*)' Timestep =',int_state%DT - write(0,*)' Steps/hour =',3600./int_state%DT - if(.not.int_state%GLOBAL)write(0,*)' Max fcst hours=',int_state%IHREND - write(0,*) 'nmm_dyn reads of PT, PDTOP: ',int_state%PT,int_state%PDTOP - write(0,*) 'nmm_dyn reads of I_PAR_STA, J_PAR_STA: ',int_state%I_PAR_STA,int_state%J_PAR_STA - write(0,*) 'nmm_dyn reads of TLM0D, TPH0D: ',int_state%TLM0D,int_state%TPH0D - write(0,*) 'nmm_dyn reads of DLMD, DPHD: ',int_state%DLMD,int_state%DPHD - write(0,*) 'nmm_dyn reads of WBD, SBD: ',int_state%WBD,int_state%SBD - write(0,*) 'nmm_dyn reads of IM, JM, LM, LNSH: ',im,jm,lmm,lnsh - endif -! -!----------------------------------------------------------------------- -! - DO L=1,LM+1 - int_state%PSG1(L)=int_state%SG1(L)*int_state%PDTOP+int_state%PT - ENDDO - DO L=1,LM - int_state%PDSG1(L)=int_state%DSG1(L)*int_state%PDTOP - int_state%PSGML1(L)=int_state%SGML1(L)*int_state%PDTOP+int_state%PT - ENDDO -! -!-- Compute pressure dependent floor values of EPSL & EPSQ2 -! - ALLOCATE(PSINT(1:LM+1)) - DO K=1,LM+1 - PSINT(K)=int_state%SG2(k)*101325.+int_state%PSG1(K) - ENDDO -! - DO K=2,LM - ARG=(PSINT(K)-PSINT(2))/(PSINT(LM)-PSINT(2))*PI -! int_state%EPSQ2(K-1)=(1.+COS(ARG))*0.09+0.02 - int_state%EPSQ2(K-1)=0.02 - int_state%EPSL(K-1)=SQRT(int_state%EPSQ2(K-1)*0.5) - ENDDO - int_state%EPSQ2(LM)=int_state%EPSQ2(LM-1) - DEALLOCATE(PSINT) - -!write(0,*) 'epsl=',epsl -!write(0,*) 'epsq2=',epsq2 - -! -!----------------------------------------------------------------------- -!*** Proceed with getting fields from input file. -!*** NOTE: Five records were already read at the top of this routine. -!----------------------------------------------------------------------- -! - if(mype==0)then - read(nfcst)temp1 - endif - do j=jms,jme - do i=ims,ime - int_state%fis(i,j)=0. - enddo - enddo - call dstrb(temp1,int_state%fis,1,1,1,1,1,mype,mpi_comm_comp) - call halo_exch(int_state%fis,1,2,2) -!----------------------------------------------------------------------- -! - if(mype==0)then - read(nfcst)temp1 - endif - do j=jms,jme - do i=ims,ime - int_state%stdh(i,j)=0. - enddo - enddo - call dstrb(temp1,int_state%stdh,1,1,1,1,1,mype,mpi_comm_comp) - call halo_exch(int_state%stdh,1,2,2) -!----------------------------------------------------------------------- -! - if(mype==0)then - read(nfcst)temp1 - endif - do j=jms,jme - do i=ims,ime - int_state%sm(i,j)=0. - enddo - enddo - call dstrb(temp1,int_state%sm,1,1,1,1,1,mype,mpi_comm_comp) - call halo_exch(int_state%sm,1,2,2) -!----------------------------------------------------------------------- -! - if(mype==0)then - read(nfcst)temp1 - endif - do j=jms,jme - do i=ims,ime - int_state%pd(i,j)=0. - enddo - enddo - call dstrb(temp1,int_state%pd,1,1,1,1,1,mype,mpi_comm_comp) - call halo_exch(int_state%pd,1,2,2) -!----------------------------------------------------------------------- -! - call mpi_barrier(mpi_comm_comp,irtn) - do l=1,lm - if(mype==0)then - read(nfcst)temp1 - endif - do j=jms,jme - do i=ims,ime - int_state%u(i,j,l)=0. - enddo - enddo - call dstrb(temp1,int_state%u,1,1,1,lm,l,mype,mpi_comm_comp) - enddo - call halo_exch(int_state%u,lm,2,2) -!----------------------------------------------------------------------- -! - do l=1,lm - if(mype==0)then - read(nfcst)temp1 - endif - do j=jms,jme - do i=ims,ime - int_state%v(i,j,l)=0. - enddo - enddo - call dstrb(temp1,int_state%v,1,1,1,lm,l,mype,mpi_comm_comp) - enddo - call halo_exch(int_state%v,lm,2,2) -!----------------------------------------------------------------------- -! - do l=1,lm - if(mype==0)then - read(nfcst)temp1 - write(0,*) 'L, T extremes: ', L, minval(temp1),maxval(temp1) - endif - do j=jms,jme - do i=ims,ime - int_state%t(i,j,l)=0. - enddo - enddo - call dstrb(temp1,int_state%t,1,1,1,lm,l,mype,mpi_comm_comp) - enddo - call halo_exch(int_state%t,lm,2,2) -!----------------------------------------------------------------------- -! - do l=1,lm - if(mype==0)then - read(nfcst)temp1 - endif - do j=jms,jme - do i=ims,ime - int_state%q(i,j,l)=0. - enddo - enddo - call dstrb(temp1,int_state%q,1,1,1,lm,l,mype,mpi_comm_comp) - enddo - call halo_exch(int_state%q,lm,2,2) -! -!----------------------------------------------------------------------- -! - do l=1,lm - if(mype==0)then - read(nfcst)temp1 - endif - do j=jms,jme - do i=ims,ime - int_state%cw(i,j,l)=0. - enddo - enddo - call dstrb(temp1,int_state%cw,1,1,1,lm,l,mype,mpi_comm_comp) - enddo - call halo_exch(int_state%cw,lm,2,2) -! -!----------------------------------------------------------------------- -! - do l=1,lm - if(mype==0)then - read(nfcst)temp1 ! O3 - endif - do j=jms,jme - do i=ims,ime - int_state%o3(i,j,l)=0. - enddo - enddo - call dstrb(temp1,int_state%o3,1,1,1,lm,l,mype,mpi_comm_comp) - enddo - call halo_exch(int_state%o3,lm,2,2) -! -!----------------------------------------------------------------------- -! - tend_max=real(int_state%IHREND) - ntstm_max=nint(tend_max*3600./int_state%DT)+1 - tend=real(int_state%nhours_fcst) - int_state%NTSTM=nint(tend*3600./int_state%DT)+1 - if(.not.int_state%global)then - if(mype==0)then - write(0,*)' Max runtime is ',tend_max,' hours' - endif - endif - if(mype==0)then - write(0,*)' Requested runtime is ',tend,' hours' - write(0,*)' NTSTM=',int_state%NTSTM - endif - if(int_state%NTSTM>ntstm_max.and..not.int_state%global)then - if(mype==0)then - write(0,*)' Requested fcst length exceeds maximum' - write(0,*)' Resetting to maximum' - endif - int_state%NTSTM=min(int_state%NTSTM,ntstm_max) - endif -! - int_state%ihr=nint(ntsd*int_state%DT/3600.) -! -!----------------------------------------------------------------------- - do l=1,lm - int_state%pdsg1(l)=int_state%dsg1(l)*int_state%pdtop - int_state%psgml1(l)=int_state%sgml1(l)*int_state%pdtop+int_state%pt - enddo -! - do l=1,lm+1 - int_state%psg1(l)=int_state%sg1(l)*int_state%pdtop+int_state%pt - enddo -!----------------------------------------------------------------------- - do j=jts,jte - do i=its,ite - int_state%pdo(i,j)=int_state%pd(i,j) - enddo - enddo - call halo_exch(int_state%pdo,1,2,2) -! - do l=1,lm - do j=jts,jte - do i=its,ite - int_state%up(i,j,l)=int_state%u(i,j,l) - int_state%vp(i,j,l)=int_state%v(i,j,l) - int_state%tp(i,j,l)=int_state%t(i,j,l) - enddo - enddo - enddo - call halo_exch(int_state%tp,lm,int_state%up,lm,int_state%vp,lm,2,2) -!----------------------------------------------------------------------- - do l=1,lm - do j=jms,jme - do i=ims,ime - int_state%q2(i,j,l)=0.02 - int_state%o3(i,j,l)=0. - if(i.ge.ide /2+1- 6.and.i.le.ide /2+1+ 6.and. & - j.ge.jde*3/4+1- 6.and.j.le.jde*3/4+1+ 6.) then !global -! j.ge.jde /2+1- 6.and.j.le.jde /2+1+ 6.) then !regional - int_state%o3(i,j,l)=10. - endif - int_state%dwdt(i,j,l)=1. - int_state%w(i,j,l)=0. - enddo - enddo - enddo - call halo_exch(int_state%dwdt,lm,2,2) -! - do j=jts,jte - do i=its,ite - int_state%pint(i,j,1)=int_state%pt - enddo - enddo -! - do l=1,lm - do j=jts,jte - do i=its,ite - int_state%pint(i,j,l+1)=int_state%PINT(i,j,l)+int_state%DSG2(l)*int_state%PD(i,j)+int_state%PDSG1(l) - enddo - enddo - enddo - call halo_exch(int_state%pint,lm+1,2,2) -! - call halo_exch(int_state%q2,lm,int_state%o3,lm,2,2) - do l=1,lm - do j=jms,jme - do i=ims,ime - int_state%tracers_prev(i,j,l,int_state%indx_q )=sqrt(max(int_state%q (i,j,l),0.)) - int_state%tracers_prev(i,j,l,int_state%indx_cw)=sqrt(max(int_state%cw(i,j,l),0.)) - int_state%tracers_prev(i,j,l,int_state%indx_q2)=sqrt(max(int_state%q2(i,j,l),0.)) - enddo - enddo - enddo -! -!----------------------------------------------------------------------- -!---reading surface data------------------------------------------------ -!----------------------------------------------------------------------- -! - if(mype==0)then - read(nfcst)temp1 ! ALBEDO - endif - CALL DSTRB(TEMP1,int_state%ALBEDO,1,1,1,1,1,mype,mpi_comm_comp) -! - if(mype==0)then - read(nfcst)temp1 ! ALBASE - endif - CALL DSTRB(TEMP1,int_state%ALBASE,1,1,1,1,1,mype,mpi_comm_comp) -! - if(mype==0)then - read(nfcst)temp1 ! EPSR - endif - CALL DSTRB(TEMP1,int_state%EPSR,1,1,1,1,1,mype,mpi_comm_comp) -! - if(mype==0)then - read(nfcst)temp1 ! MXSNAL - endif - CALL DSTRB(TEMP1,int_state%MXSNAL,1,1,1,1,1,mype,mpi_comm_comp) -! - if(mype==0)then - read(nfcst)temp1 ! TSKIN - endif - CALL DSTRB(TEMP1,int_state%TSKIN,1,1,1,1,1,mype,mpi_comm_comp) -! - if(mype==0)then - read(nfcst)temp1 ! SST - endif - CALL DSTRB(TEMP1,int_state%SST,1,1,1,1,1,mype,mpi_comm_comp) -! - if(mype==0)then - read(nfcst)temp1 ! SNO and SNOWC - endif - CALL DSTRB(TEMP1,int_state%SNO,1,1,1,1,1,mype,mpi_comm_comp) - - DO J=JMS,JME - DO I=IMS,IME - if(int_state%SNO(I,J).gt.0.) then - int_state%SNOWC(I,J)=0.98 - else - int_state%SNOWC(I,J)=0.0 - endif - ENDDO - ENDDO -! - if(mype==0)then - read(nfcst)temp1 ! SI - endif - CALL DSTRB(TEMP1,int_state%SI,1,1,1,1,1,mype,mpi_comm_comp) -! - if(mype==0)then - read(nfcst)temp1 ! SICE - endif - CALL DSTRB(TEMP1,int_state%SICE,1,1,1,1,1,mype,mpi_comm_comp) -! - if(mype==0)then - read(nfcst) temp1 ! TG - endif - CALL DSTRB(TEMP1,int_state%TG,1,1,1,1,1,mype,mpi_comm_comp) -! - if(mype==0)then - read(nfcst) temp1 ! CMC - endif - CALL DSTRB(TEMP1,int_state%CMC,1,1,1,1,1,mype,mpi_comm_comp) -! - if(mype==0)then - read(nfcst) temp1 ! SR - endif - CALL DSTRB(TEMP1,int_state%SR,1,1,1,1,1,mype,mpi_comm_comp) -! - if(mype==0)then - read(nfcst) temp1 ! USTAR - endif - CALL DSTRB(TEMP1,int_state%USTAR,1,1,1,1,1,mype,mpi_comm_comp) -! - if(mype==0)then - read(nfcst) temp1 ! Z0 - endif - CALL DSTRB(TEMP1,int_state%Z0,1,1,1,1,1,mype,mpi_comm_comp) - CALL HALO_EXCH(int_state%Z0,1,3,3) -! - if(mype==0)then - read(nfcst) temp1 ! Z0BASE - endif - CALL DSTRB(TEMP1,int_state%Z0BASE,1,1,1,1,1,mype,mpi_comm_comp) - CALL HALO_EXCH(int_state%Z0BASE,1,3,3) -! - ALLOCATE(TEMPSOIL(1:int_state%NSOIL,IDS:IDE,JDS:JDE),STAT=I) -! - if(mype==0)then - read(nfcst) TEMPSOIL ! STC - endif - CALL DSTRB(TEMPSOIL(1,IDS:IDE,JDS:JDE),int_state%STC(IMS:IME,JMS:JME,1),1,1,1,1,1,mype,mpi_comm_comp) - CALL DSTRB(TEMPSOIL(2,IDS:IDE,JDS:JDE),int_state%STC(IMS:IME,JMS:JME,2),1,1,1,1,1,mype,mpi_comm_comp) - CALL DSTRB(TEMPSOIL(3,IDS:IDE,JDS:JDE),int_state%STC(IMS:IME,JMS:JME,3),1,1,1,1,1,mype,mpi_comm_comp) - CALL DSTRB(TEMPSOIL(4,IDS:IDE,JDS:JDE),int_state%STC(IMS:IME,JMS:JME,4),1,1,1,1,1,mype,mpi_comm_comp) -! - if(mype==0)then - read(nfcst) TEMPSOIL ! SMC - endif - CALL DSTRB(TEMPSOIL(1,:,:),int_state%SMC(:,:,1),1,1,1,1,1,mype,mpi_comm_comp) - CALL DSTRB(TEMPSOIL(2,:,:),int_state%SMC(:,:,2),1,1,1,1,1,mype,mpi_comm_comp) - CALL DSTRB(TEMPSOIL(3,:,:),int_state%SMC(:,:,3),1,1,1,1,1,mype,mpi_comm_comp) - CALL DSTRB(TEMPSOIL(4,:,:),int_state%SMC(:,:,4),1,1,1,1,1,mype,mpi_comm_comp) -! - if(mype==0)then - read(nfcst) TEMPSOIL ! SH2O - endif - CALL DSTRB(TEMPSOIL(1,:,:),int_state%SH2O(:,:,1),1,1,1,1,1,mype,mpi_comm_comp) - CALL DSTRB(TEMPSOIL(2,:,:),int_state%SH2O(:,:,2),1,1,1,1,1,mype,mpi_comm_comp) - CALL DSTRB(TEMPSOIL(3,:,:),int_state%SH2O(:,:,3),1,1,1,1,1,mype,mpi_comm_comp) - CALL DSTRB(TEMPSOIL(4,:,:),int_state%SH2O(:,:,4),1,1,1,1,1,mype,mpi_comm_comp) -! - DEALLOCATE(TEMPSOIL) - ALLOCATE(ITEMP(IDS:IDE,JDS:JDE),STAT=I) -! - if(mype==0)then - read(nfcst) ITEMP ! ISLTYP - endif - CALL IDSTRB(ITEMP,int_state%ISLTYP,mype,mpi_comm_comp) -! - if(mype==0)then - read(nfcst) ITEMP ! IVGTYP - endif - CALL IDSTRB(ITEMP,int_state%IVGTYP,mype,mpi_comm_comp) -! - DEALLOCATE(ITEMP) -! - if(mype==0)then - read(nfcst) temp1 ! VEGFRC - endif - CALL DSTRB(TEMP1,int_state%VEGFRC,1,1,1,1,1,mype,mpi_comm_comp) -! - if(mype==0)then - read(nfcst) SOIL1DIN ! DZSOIL - endif -! - if(mype==0)then - read(nfcst) SOIL1DIN ! SLDPTH - endif -! -! if(mype==0)then ! here will be 14 orography fields for GWD -! do n=1,14 -! read(nfcst) temp1 -! enddo -! endif -! -!----------------------------------------------------------------------- -! - close(nfcst) -! -!----------------------------------------------------------------------- - else read_blocks ! restart -!----------------------------------------------------------------------- -! - write(infile,'(a,i2.2)')'restart_file_',my_domain_id - open(unit=nfcst,file=infile,status='old',form='unformatted' & - ,iostat=ierr) - if(ierr/=0)then - write(0,*)' Unable to open ',trim(infile),' in READ_BINARY' - rc = ierr - return - endif -! -!----------------------------------------------------------------------- -!*** Read from restart file: Integer scalars -!----------------------------------------------------------------------- - read(nfcst) iyear_fcst - read(nfcst) imonth_fcst - read(nfcst) iday_fcst - read(nfcst) ihour_fcst - read(nfcst) !iminute_fcst - read(nfcst) ! second_fcst - read(nfcst) ! ntsd - read(nfcst) ! im - read(nfcst) ! jm - read(nfcst) ! lm - read(nfcst) int_state%IHRST - read(nfcst) int_state%I_PAR_STA - read(nfcst) int_state%J_PAR_STA - read(nfcst) int_state%LAST_STEP_MOVED - read(nfcst) int_state%LPT2 - read(nfcst) ! nsoil - read(nfcst) ! nphs - read(nfcst) ! nclod - read(nfcst) ! nheat - read(nfcst) ! nmts - read(nfcst) ! nprec - read(nfcst) ! nrdlw - read(nfcst) ! nrdsw - read(nfcst) ! nsrfc -! - read(nfcst) ! cu_physics - read(nfcst) ! mp_physics - read(nfcst) ! lsm_physics -! - read(nfcst) int_state%NTRACK - read(nfcst) int_state%TRACK_HAVE_GUESS - read(nfcst) int_state%TRACK_N_OLD - read(nfcst) int_state%TRACKER_HAVEFIX - read(nfcst) int_state%TRACKER_GAVE_UP - read(nfcst) int_state%TRACKER_IFIX - read(nfcst) int_state%TRACKER_JFIX -! -!----------------------------------------------------------------------- -!*** Read from restart file: Integer 1D arrays -!----------------------------------------------------------------------- - read(nfcst) ! int_state%NTSCM - read(nfcst) int_state%IDAT -! - if(mype==0)then - write(0,*)'**** read in core *******************' - write(0,*)' Restart year =',iyear_fcst - write(0,*)' Restart month=',imonth_fcst - write(0,*)' Restart day =',iday_fcst - write(0,*)' Restart hour =',ihour_fcst - write(0,*)' Original start year =',int_state%IDAT(3) - write(0,*)' Original start month=',int_state%IDAT(2) - write(0,*)' Original start day =',int_state%IDAT(1) - write(0,*)' Original start hour =',int_state%IHRST - write(0,*)' Timestep =',int_state%DT - write(0,*)' Steps/hour =',3600./int_state%DT - write(0,*)'*************************************' - endif -! - read(nfcst) int_state%TRACK_OLD_NTSD -! -!----------------------------------------------------------------------- -!*** Read from restart file: Real scalars -!----------------------------------------------------------------------- - read(nfcst) ! dt - read(nfcst) ! dyh - read(nfcst) int_state%PDTOP - read(nfcst) int_state%PT - read(nfcst) int_state%TLM0D - read(nfcst) int_state%TPH0D - read(nfcst) ! tstart - read(nfcst) int_state%DPHD - read(nfcst) int_state%DLMD - read(nfcst) int_state%SBD - read(nfcst) int_state%WBD -! - read(nfcst) int_state%TRACK_LAST_HOUR - read(nfcst) int_state%TRACK_GUESS_LAT - read(nfcst) int_state%TRACK_GUESS_LON - read(nfcst) int_state%TRACK_EDGE_DIST - read(nfcst) int_state%TRACK_STDERR_M1 - read(nfcst) int_state%TRACK_STDERR_M2 - read(nfcst) int_state%TRACK_STDERR_M3 - read(nfcst) int_state%TRACKER_FIXLAT - read(nfcst) int_state%TRACKER_FIXLON - read(nfcst) int_state%TRACKER_RMW - read(nfcst) int_state%TRACKER_PMIN - read(nfcst) int_state%TRACKER_VMAX -!----------------------------------------------------------------------- -!*** Read from restart file: Real 1D arrays -!----------------------------------------------------------------------- - read(nfcst) ! dxh - read(nfcst) int_state%SG1 - read(nfcst) int_state%SG2 - read(nfcst) int_state%DSG1 - read(nfcst) int_state%DSG2 - read(nfcst) int_state%SGML1 - read(nfcst) int_state%SGML2 - read(nfcst) int_state%SGM - read(nfcst) int_state%EPSL - read(nfcst) int_state%EPSQ2 - read(nfcst) int_state%SLDPTH - read(nfcst) int_state%MP_RESTART_STATE - read(nfcst) int_state%TBPVS_STATE - read(nfcst) int_state%TBPVS0_STATE -! - read(nfcst) int_state%TRACK_OLD_LAT - read(nfcst) int_state%TRACK_OLD_LON -! - DO L=1,LM - int_state%PDSG1(L)=int_state%DSG1(L)*int_state%PDTOP - int_state%PSGML1(L)=int_state%SGML1(L)*int_state%PDTOP+int_state%PT - ENDDO -! - DO L=1,LM+1 - int_state%PSG1(L)=int_state%SG1(L)*int_state%PDTOP+int_state%PT - ENDDO -! -!----------------------------------------------------------------------- -!*** Read in the full-domain 1-D datastring of boundary winds. -!*** Each task isolates its own piece of that data. -!----------------------------------------------------------------------- -! - length=(int_state%nlev_h*int_state%lnsh & !<-- Total # of words - +int_state%nlev_v*int_state%lnsv) & ! in full-domain - *2*2*(ide-ids+jde-jds+2) ! boundary arrays. - allocate(all_bc_data(1:length)) -! - read(nfcst) all_bc_data -! -!----------------------------------------------------------------------- -! - nvars_bc_2d_h=int_state%nvars_bc_2d_h - nvars_bc_3d_h=int_state%nvars_bc_3d_h - nvars_bc_4d_h=int_state%nvars_bc_4d_h - nvars_bc_2d_v=int_state%nvars_bc_2d_v - nvars_bc_3d_v=int_state%nvars_bc_3d_v -! - kount=0 -! -!----------------------------------------------------------------------- -! - iend=min(ite_h2,ide) -! - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - do n=1,2 - do j=1,int_state%lnsh - do i=ids,ide - kount=kount+1 - if(jts==jds.and.i>=its_h2.and.i<=iend)then !<-- South boundary tasks extract 2-D BC H-pt data - int_state%bnd_vars_h%var_2d(nv)%south(i,j,n)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - do n=1,2 - do l=1,lm - do j=1,int_state%lnsh - do i=ids,ide - kount=kount+1 - if(jts==jds.and.i>=its_h2.and.i<=iend)then !<-- South boundary tasks extract 3-D BC H-pt data - int_state%bnd_vars_h%var_3d(nv)%south(i,j,l,n)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lb=int_state%lbnd_4d(nv) - ub=int_state%ubnd_4d(nv) - do nl=lb,ub - do n=1,2 - do l=1,lm - do j=1,int_state%lnsh - do i=ids,ide - kount=kount+1 - if(jts==jds.and.i>=its_h2.and.i<=iend)then !<-- South boundary tasks extract 4-D BC H-pt data - int_state%bnd_vars_h%var_4d(nv)%south(i,j,l,n,nl)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_2d_v>0)then - do nv=1,nvars_bc_2d_v - do n=1,2 - do j=1,int_state%lnsv - do i=ids,ide - kount=kount+1 - if(jts==jds.and.i>=its_h2.and.i<=iend)then !<-- South boundary tasks extract 2-D BC V-pt data - int_state%bnd_vars_v%var_2d(nv)%south(i,j,n)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_v>0)then - do nv=1,nvars_bc_3d_v - do n=1,2 - do l=1,lm - do j=1,int_state%lnsv - do i=ids,ide - kount=kount+1 - if(jts==jds.and.i>=its_h2.and.i<=iend)then !<-- South boundary tasks extract 3-D BC V-pt data - int_state%bnd_vars_v%var_3d(nv)%south(i,j,l,n)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - do n=1,2 - do j=1,int_state%lnsh - do i=ids,ide - kount=kount+1 - if(jte==jde.and.i>=its_h2.and.i<=iend)then !<-- North boundary tasks extract 2-D BC H-pt data - int_state%bnd_vars_h%var_2d(nv)%north(i,j,n)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - do n=1,2 - do l=1,lm - do j=1,int_state%lnsh - do i=ids,ide - kount=kount+1 - if(jte==jde.and.i>=its_h2.and.i<=iend)then !<-- North boundary tasks extract 3-D BC H-pt data - int_state%bnd_vars_h%var_3d(nv)%north(i,j,l,n)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lb=int_state%lbnd_4d(nv) - ub=int_state%ubnd_4d(nv) - do nl=lb,ub - do n=1,2 - do l=1,lm - do j=1,int_state%lnsh - do i=ids,ide - kount=kount+1 - if(jte==jde.and.i>=its_h2.and.i<=iend)then !<-- North boundary tasks extract 4-D BC H-pt data - int_state%bnd_vars_h%var_4d(nv)%north(i,j,l,n,nl)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_2d_v>0)then - do nv=1,nvars_bc_2d_v - do n=1,2 - do j=1,int_state%lnsv - do i=ids,ide - kount=kount+1 - if(jte==jde.and.i>=its_h2.and.i<=iend)then !<-- North boundary tasks extract 2-D BC V-pt data - int_state%bnd_vars_v%var_2d(nv)%north(i,j,n)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_v>0)then - do nv=1,nvars_bc_3d_v - do n=1,2 - do l=1,lm - do j=1,int_state%lnsv - do i=ids,ide - kount=kount+1 - if(jte==jde.and.i>=its_h2.and.i<=iend)then !<-- North boundary tasks extract 3-D BC V-pt data - int_state%bnd_vars_v%var_3d(nv)%north(i,j,l,n)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - enddo - endif -! - jend=min(jte_h2,jde) -! - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - do n=1,2 - do j=jds,jde - do i=1,int_state%lnsh - kount=kount+1 - if(its==ids.and.j>=jts_h2.and.j<=jend)then !<-- West boundary tasks extract 2-D BC H-pt data - int_state%bnd_vars_h%var_2d(nv)%west(i,j,n)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - do n=1,2 - do l=1,lm - do j=jds,jde - do i=1,int_state%lnsh - kount=kount+1 - if(its==ids.and.j>=jts_h2.and.j<=jend)then !<-- West boundary tasks extract 3-D BC H-pt data - int_state%bnd_vars_h%var_3d(nv)%west(i,j,l,n)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lb=int_state%lbnd_4d(nv) - ub=int_state%ubnd_4d(nv) - do nl=lb,ub - do n=1,2 - do l=1,lm - do j=jds,jde - do i=1,int_state%lnsh - kount=kount+1 - if(its==ids.and.j>=jts_h2.and.j<=jend)then !<-- West boundary tasks extract 4-D BC H-pt data - int_state%bnd_vars_h%var_4d(nv)%west(i,j,l,n,nl)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_2d_v>0)then - do nv=1,nvars_bc_2d_v - do n=1,2 - do j=jds,jde - do i=1,int_state%lnsv - kount=kount+1 - if(its==ids.and.j>=jts_h2.and.j<=jend)then !<-- West boundary tasks extract 2-D BC V-pt data - int_state%bnd_vars_v%var_2d(nv)%west(i,j,n)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_v>0)then - do nv=1,nvars_bc_3d_v - do n=1,2 - do l=1,lm - do j=jds,jde - do i=1,int_state%lnsv - kount=kount+1 - if(its==ids.and.j>=jts_h2.and.j<=jend)then !<-- West boundary tasks extract 3-D BC V-pt data - int_state%bnd_vars_v%var_3d(nv)%west(i,j,l,n)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - do n=1,2 - do j=jds,jde - do i=1,int_state%lnsh - kount=kount+1 - if(ite==ide.and.j>=jts_h2.and.j<=jend)then !<-- East boundary tasks extract 2-D BC H-pt data - int_state%bnd_vars_h%var_2d(nv)%east(i,j,n)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - do n=1,2 - do l=1,lm - do j=jds,jde - do i=1,int_state%lnsh - kount=kount+1 - if(ite==ide.and.j>=jts_h2.and.j<=jend)then !<-- East boundary tasks extract 3-D BC H-pt data - int_state%bnd_vars_h%var_3d(nv)%east(i,j,l,n)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lb=int_state%lbnd_4d(nv) - ub=int_state%ubnd_4d(nv) - do nl=lb,ub - do n=1,2 - do l=1,lm - do j=jds,jde - do i=1,int_state%lnsh - kount=kount+1 - if(ite==ide.and.j>=jts_h2.and.j<=jend)then !<-- East boundary tasks extract 4-D BC H-pt data - int_state%bnd_vars_h%var_4d(nv)%east(i,j,l,n,nl)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_2d_v>0)then - do nv=1,nvars_bc_2d_v - do n=1,2 - do j=jds,jde - do i=1,int_state%lnsv - kount=kount+1 - if(ite==ide.and.j>=jts_h2.and.j<=jend)then !<-- East boundary tasks extract 2-D BC V-pt data - int_state%bnd_vars_v%var_2d(nv)%east(i,j,n)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_v>0)then - do nv=1,nvars_bc_3d_v - do n=1,2 - do l=1,lm - do j=jds,jde - do i=1,int_state%lnsv - kount=kount+1 - if(ite==ide.and.j>=jts_h2.and.j<=jend)then !<-- East boundary tasks extract 3-D BC V-pt data - int_state%bnd_vars_v%var_3d(nv)%east(i,j,l,n)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - enddo - endif -! - deallocate(all_bc_data) -! -!----------------------------------------------------------------------- -!*** Read from restart file: Logical -!----------------------------------------------------------------------- - read(nfcst) ! global - read(nfcst) int_state%RUN - read(nfcst) ! adiabatic -! -!----------------------------------------------------------------------- -!*** Read from restart file: Integer 2D arrays -!----------------------------------------------------------------------- -! - ALLOCATE(ITEMP(IDS:IDE,JDS:JDE),STAT=I) -! - IF(MYPE==0)THEN - READ(NFCST) ITEMP - ENDIF - CALL IDSTRB(ITEMP,int_state%ISLTYP,MYPE,MPI_COMM_COMP) -! - IF(MYPE==0)THEN - READ(NFCST) ITEMP - ENDIF - CALL IDSTRB(ITEMP,int_state%IVGTYP,MYPE,MPI_COMM_COMP) -! - IF(MYPE==0)THEN - READ(NFCST) ITEMP - ENDIF - CALL IDSTRB(ITEMP,int_state%NCFRCV,MYPE,MPI_COMM_COMP) -! - IF(MYPE==0)THEN - READ(NFCST) ITEMP - ENDIF - CALL IDSTRB(ITEMP,int_state%NCFRST,MYPE,MPI_COMM_COMP) -! - IF(MYPE==0)THEN - READ(NFCST) ITEMP - ENDIF - CALL IDSTRB(ITEMP,int_state%TRACKER_FIXES,MYPE,MPI_COMM_COMP) -! - DEALLOCATE(ITEMP) -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** Read from restart file by alphabetical order (new in ESMF6) -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** ACFRCV -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%ACFRCV,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** ACFRST -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%ACFRST,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** ACPREC -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%ACPREC,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** ACPREC_TOT -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%ACPREC_TOT,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** ACSNOM -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%ACSNOM,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** ACSNOW -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%ACSNOW,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** ACUTIM -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%ACUTIM,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** AKHS -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%AKHS,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** AKHS_OUT -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%AKHS_OUT,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** AKMS -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%AKMS,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** AKMS_OUT -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%AKMS_OUT,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** ALBASE -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%ALBASE,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** ALBEDO -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%ALBEDO,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** ALWIN -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%ALWIN,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** ALWOUT -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%ALWOUT,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** ALWTOA -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%ALWTOA,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** APHTIM -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%APHTIM,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** ARDLW -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%ARDLW,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** ARDSW -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%ARDSW,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** ASRFC -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%ASRFC,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** ASWIN -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%ASWIN,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** ASWOUT -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%ASWOUT,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** ASWTOA -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%ASWTOA,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** AVCNVC -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%AVCNVC,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** AVRAIN -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%AVRAIN,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** BGROFF -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%BGROFF,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** CFRACH -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%CFRACH,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** CFRACL -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%CFRACL,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** CFRACM -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%CFRACM,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** CLDEFI -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%CLDEFI,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** CLDFRA -!----------------------------------------------------------------------- - DO L=1,LM - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,INT_STATE%CLDFRA,1,1,1,LM,L,MYPE,MPI_COMM_COMP) - ENDDO -!----------------------------------------------------------------------- -!*** CMC -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%CMC,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** CNVBOT -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%CNVBOT,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** CNVTOP -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%CNVTOP,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** CPRATE -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%CPRATE,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** CUPPT -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%CUPPT,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** CUPREC -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%CUPREC,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** CW -!----------------------------------------------------------------------- - DO L=1,LM - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - DO J=JMS,JME - DO I=IMS,IME - int_state%CW(I,J,L)=0. - ENDDO - ENDDO - CALL DSTRB(TEMP1,int_state%CW,1,1,1,LM,L,MYPE,MPI_COMM_COMP) - ENDDO - CALL HALO_EXCH(int_state%CW,LM,2,2) -!----------------------------------------------------------------------- -!*** CZEN -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%CZEN,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** CZMEAN -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%CZMEAN,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** DFI_TTEN -!----------------------------------------------------------------------- - DO L=1,LM - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%DFI_TTEN,1,1,1,LM,L,MYPE,MPI_COMM_COMP) - ENDDO - CALL HALO_EXCH(int_state%DFI_TTEN,LM,2,2) -!----------------------------------------------------------------------- -!*** DIV -!----------------------------------------------------------------------- - DO L=1,LM - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%DIV,1,1,1,LM,L,MYPE,MPI_COMM_COMP) - ENDDO - CALL HALO_EXCH(int_state%DIV,LM,2,2) -!----------------------------------------------------------------------- -!*** DWDT -!----------------------------------------------------------------------- - DO L=1,LM - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - DO J=JMS,JME - DO I=IMS,IME - int_state%DWDT(I,J,L)=0. - ENDDO - ENDDO - CALL DSTRB(TEMP1,int_state%DWDT,1,1,1,LM,L,MYPE,MPI_COMM_COMP) - ENDDO - CALL HALO_EXCH(int_state%DWDT,LM,2,2) -!----------------------------------------------------------------------- -!*** EPSR -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%EPSR,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** F -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - DO J=JMS,JME - DO I=IMS,IME - int_state%F(I,J)=0. - ENDDO - ENDDO - CALL DSTRB(TEMP1,int_state%F,1,1,1,1,1,MYPE,MPI_COMM_COMP) - CALL HALO_EXCH(int_state%F,1,2,2) -!----------------------------------------------------------------------- -!*** FIS -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - DO J=JMS,JME - DO I=IMS,IME - int_state%FIS(I,J)=0. - ENDDO - ENDDO - CALL DSTRB(TEMP1,int_state%FIS,1,1,1,1,1,MYPE,MPI_COMM_COMP) - CALL HALO_EXCH(int_state%FIS,1,2,2) -!----------------------------------------------------------------------- -!*** F_ICE -!----------------------------------------------------------------------- - DO K=1,LM - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - DO J=JMS,JME - DO I=IMS,IME - int_state%F_ICE(I,J,K)=0. - ENDDO - ENDDO - CALL DSTRB(TEMP1,int_state%F_ICE,1,1,1,LM,K,MYPE,MPI_COMM_COMP) - ENDDO -!----------------------------------------------------------------------- -!*** F_RAIN -!----------------------------------------------------------------------- - DO K=1,LM - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - DO J=JMS,JME - DO I=IMS,IME - int_state%F_RAIN(I,J,K)=0. - ENDDO - ENDDO - CALL DSTRB(TEMP1,int_state%F_RAIN,1,1,1,LM,K,MYPE,MPI_COMM_COMP) - ENDDO -!----------------------------------------------------------------------- -!*** F_RIMEF -!----------------------------------------------------------------------- - DO K=1,LM - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - DO J=JMS,JME - DO I=IMS,IME - int_state%F_RIMEF(I,J,K)=0. - ENDDO - ENDDO - CALL DSTRB(TEMP1,int_state%F_RIMEF,1,1,1,LM,K,MYPE,MPI_COMM_COMP) - ENDDO -!----------------------------------------------------------------------- -!*** GLAT -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - DO J=JMS,JME - DO I=IMS,IME - int_state%GLAT(I,J)=0. - ENDDO - ENDDO - CALL DSTRB(TEMP1,int_state%GLAT,1,1,1,1,1,MYPE,MPI_COMM_COMP) - CALL HALO_EXCH(int_state%GLAT,1,2,2) -!----------------------------------------------------------------------- -!*** GLON -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - DO J=JMS,JME - DO I=IMS,IME - int_state%GLON(I,J)=0. - ENDDO - ENDDO - CALL DSTRB(TEMP1,int_state%GLON,1,1,1,1,1,MYPE,MPI_COMM_COMP) - CALL HALO_EXCH(int_state%GLON,1,2,2) -!----------------------------------------------------------------------- -!*** GRNFLX -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%GRNFLX,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** HBOT -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%HBOT,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** HBOTD -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%HBOTD,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** HBOTS -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%HBOTS,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** HDACVX -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - DO J=JMS,JME - DO I=IMS,IME - int_state%HDACVX(I,J)=0. - ENDDO - ENDDO - CALL DSTRB(TEMP1,int_state%HDACVX,1,1,1,1,1,MYPE,MPI_COMM_COMP) - CALL HALO_EXCH(int_state%HDACVX,1,2,2) -!----------------------------------------------------------------------- -!*** HDACVY -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - DO J=JMS,JME - DO I=IMS,IME - int_state%HDACVY(I,J)=0. - ENDDO - ENDDO - CALL DSTRB(TEMP1,int_state%HDACVY,1,1,1,1,1,MYPE,MPI_COMM_COMP) - CALL HALO_EXCH(int_state%HDACVY,1,2,2) -!----------------------------------------------------------------------- -!*** HDACX -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - DO J=JMS,JME - DO I=IMS,IME - int_state%HDACX(I,J)=0. - ENDDO - ENDDO - CALL DSTRB(TEMP1,int_state%HDACX,1,1,1,1,1,MYPE,MPI_COMM_COMP) - CALL HALO_EXCH(int_state%HDACX,1,2,2) -!----------------------------------------------------------------------- -!*** HDACY -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - DO J=JMS,JME - DO I=IMS,IME - int_state%HDACY(I,J)=0. - ENDDO - ENDDO - CALL DSTRB(TEMP1,int_state%HDACY,1,1,1,1,1,MYPE,MPI_COMM_COMP) - CALL HALO_EXCH(int_state%HDACY,1,2,2) -!----------------------------------------------------------------------- -!*** HTOP -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%HTOP,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** HTOPD -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%HTOPD,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** HTOPS -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%HTOPS,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** M10RV -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%M10RV,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** M10WIND -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%M10WIND,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** MEMBRANE_MSLP -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%MEMBRANE_MSLP,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** MXSNAL (SNOW ALBEDO) -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%MXSNAL,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** O3 -!----------------------------------------------------------------------- - DO L=1,LM - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%O3,1,1,1,LM,L,MYPE,MPI_COMM_COMP) - ENDDO - CALL HALO_EXCH(int_state%O3,LM,2,2) -!----------------------------------------------------------------------- -!*** OMGALF -!----------------------------------------------------------------------- - DO L=1,LM - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%OMGALF,1,1,1,LM,L,MYPE,MPI_COMM_COMP) - ENDDO - CALL HALO_EXCH(int_state%OMGALF,LM,2,2) -!----------------------------------------------------------------------- -!*** P500U -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%P500U,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** P500V -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%P500V,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** P700RV -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%P700RV,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** P700U -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%P700U,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** P700V -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%P700V,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** P700WIND -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%P700WIND,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** P700Z -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%P700Z,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** P850RV -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%P850RV,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** P850U -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%P850U,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** P850V -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%P850V,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** P850WIND -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%P850WIND,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** P850Z -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%P850Z,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** PBLH -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%PBLH,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** PD -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - DO J=JMS,JME - DO I=IMS,IME - int_state%PD(I,J)=0. - ENDDO - ENDDO - CALL DSTRB(TEMP1,int_state%PD,1,1,1,1,1,MYPE,MPI_COMM_COMP) - CALL HALO_EXCH(int_state%PD,1,2,2) -!----------------------------------------------------------------------- -!*** PDO -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - DO J=JMS,JME - DO I=IMS,IME - int_state%PDO(I,J)=0. - ENDDO - ENDDO - CALL DSTRB(TEMP1,int_state%PDO,1,1,1,1,1,MYPE,MPI_COMM_COMP) - CALL HALO_EXCH(int_state%PDO,1,2,2) -!----------------------------------------------------------------------- -!*** PINT -!----------------------------------------------------------------------- - DO L=1,LM+1 - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - DO J=JMS,JME - DO I=IMS,IME - int_state%PINT(I,J,L)=0. - ENDDO - ENDDO - CALL DSTRB(TEMP1,int_state%PINT,1,1,1,LM+1,L,MYPE,MPI_COMM_COMP) - ENDDO - CALL HALO_EXCH(int_state%PINT,LM+1,2,2) -!----------------------------------------------------------------------- -!*** POTEVP -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%POTEVP,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** POTFLX -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%POTFLX,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** PREC -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%PREC,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** PSGDT -!----------------------------------------------------------------------- - DO L=1,LM-1 - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - ENDDO -!----------------------------------------------------------------------- -!*** PSHLTR -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%PSHLTR,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** Q10 -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%Q10,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** Q2 -!----------------------------------------------------------------------- - DO L=1,LM - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - DO J=JMS,JME - DO I=IMS,IME - int_state%Q2(I,J,L)=0. - ENDDO - ENDDO - CALL DSTRB(TEMP1,int_state%Q2,1,1,1,LM,L,MYPE,MPI_COMM_COMP) - ENDDO - CALL HALO_EXCH(int_state%Q2,LM,2,2) -!----------------------------------------------------------------------- -!*** QSH -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%QSH,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** QSHLTR -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%QSHLTR,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** QWBS -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%QWBS,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** QZ0 -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%QZ0,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** Q -!----------------------------------------------------------------------- - DO L=1,LM - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - DO J=JMS,JME - DO I=IMS,IME - int_state%Q(I,J,L)=0. - ENDDO - ENDDO - CALL DSTRB(TEMP1,int_state%Q,1,1,1,LM,L,MYPE,MPI_COMM_COMP) - ENDDO - CALL HALO_EXCH(int_state%Q,LM,2,2) -!----------------------------------------------------------------------- -!*** RADOT -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%RADOT,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** RLWIN -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%RLWIN,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** RLWTOA -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%RLWTOA,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** RLWTT -!----------------------------------------------------------------------- - DO L=1,LM - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - DO J=JMS,JME - DO I=IMS,IME - int_state%RLWTT(I,J,L)=0. - ENDDO - ENDDO - CALL DSTRB(TEMP1,int_state%RLWTT,1,1,1,LM,L,MYPE,MPI_COMM_COMP) - ENDDO -!----------------------------------------------------------------------- -!*** RMOL -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%RMOL,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** RSWIN -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%RSWIN,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** RSWINC -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%RSWINC,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** RSWOUT -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%RSWOUT,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** RSWTOA -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%RSWTOA,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** RSWTT -!----------------------------------------------------------------------- - DO L=1,LM - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - DO J=JMS,JME - DO I=IMS,IME - int_state%RSWTT(I,J,L)=0. - ENDDO - ENDDO - CALL DSTRB(TEMP1,int_state%RSWTT,1,1,1,LM,L,MYPE,MPI_COMM_COMP) - ENDDO -!----------------------------------------------------------------------- -!*** SFCEVP -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%SFCEVP,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** SFCEXC -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%SFCEXC,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** SFCLHX -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%SFCLHX,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** SFCSHX -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%SFCSHX,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** SH2O -!----------------------------------------------------------------------- - DO K=1,int_state%NSOIL - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%SH2O,1,1,1,int_state%NSOIL,K & - ,MYPE,MPI_COMM_COMP) - ENDDO -!----------------------------------------------------------------------- -!*** SI -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%SI,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** SICE -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%SICE,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** SIGT4 -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%SIGT4,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** SM (Seamask) -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - DO J=JMS,JME - DO I=IMS,IME - int_state%SM(I,J)=0. - ENDDO - ENDDO - CALL DSTRB(TEMP1,int_state%SM,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** SM10RV -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%SM10RV,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** SM10WIND -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%SM10WIND,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** SMC -!----------------------------------------------------------------------- - DO K=1,int_state%NSOIL - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%SMC,1,1,1,int_state%NSOIL,K & - ,MYPE,MPI_COMM_COMP) - ENDDO -!----------------------------------------------------------------------- -!*** SMSLP -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%SMSLP,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** SMSTAV -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%SMSTAV,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** SMSTOT -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%SMSTOT,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** SNO -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%SNO,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** SNOPCX -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%SNOPCX,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** SNOWC -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%SNOWC,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** SOILTB -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%SOILTB,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** SP700RV -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%SP700RV,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** SP700WIND -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%SP700WIND,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** SP700Z -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%SP700Z,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** SP850RV -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%SP850RV,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** SP850WIND -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%SP850WIND,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** SP850Z -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%SP850Z,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** SR -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%SR,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** SSROFF -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%SSROFF,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** SST -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%SST,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** STC -!----------------------------------------------------------------------- - DO K=1,int_state%NSOIL - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%STC,1,1,1,int_state%NSOIL,K & - ,MYPE,MPI_COMM_COMP) - ENDDO -!----------------------------------------------------------------------- -!*** SUBSHX -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%SUBSHX,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** T2 -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%T2,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** TCT -!----------------------------------------------------------------------- - DO L=1,LM - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%TCT,1,1,1,LM,L,MYPE,MPI_COMM_COMP) - ENDDO - CALL HALO_EXCH(int_state%TCT,LM,2,2) -!----------------------------------------------------------------------- -!*** TCUCN -!----------------------------------------------------------------------- - DO L=1,LM - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - DO J=JMS,JME - DO I=IMS,IME - int_state%TCUCN(I,J,L)=0. - ENDDO - ENDDO - CALL DSTRB(TEMP1,int_state%TCUCN,1,1,1,LM,L,MYPE,MPI_COMM_COMP) - ENDDO -!----------------------------------------------------------------------- -!*** TCU -!----------------------------------------------------------------------- - DO L=1,LM - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%TCU,1,1,1,LM,L,MYPE,MPI_COMM_COMP) - ENDDO - CALL HALO_EXCH(int_state%TCU,LM,2,2) -!----------------------------------------------------------------------- -!*** TCV -!----------------------------------------------------------------------- - DO L=1,LM - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%tcv,1,1,1,LM,L,MYPE,MPI_COMM_COMP) - ENDDO - CALL HALO_EXCH(int_state%TCV,LM,2,2) -!----------------------------------------------------------------------- -!*** TG -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%TG,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** TH10 -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%TH10,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** THS -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%THS,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** THZ0 -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%THZ0,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** TLMAX -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%TLMAX,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** TLMIN -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%TLMIN,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** TP -!----------------------------------------------------------------------- - DO L=1,LM - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%TP,1,1,1,LM,L,MYPE,MPI_COMM_COMP) - ENDDO - CALL HALO_EXCH(int_state%TP,LM,2,2) -!----------------------------------------------------------------------- -!*** TRACERS -!----------------------------------------------------------------------- - DO N=int_state%INDX_Q2+1,int_state%NUM_TRACERS_TOTAL !<-- The first 'indx_q2' arrays are unallocated pointers - DO L=1,LM - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - DO J=JMS,JME - DO I=IMS,IME - int_state%TRACERS(I,J,L,N)=0. - ENDDO - ENDDO - CALL DSTRB(TEMP1,int_state%TRACERS(:,:,:,N),1,1,1,LM,L & - ,MYPE,MPI_COMM_COMP) - ENDDO - ENDDO - CALL HALO_EXCH(int_state%TRACERS,LM,int_state%NUM_TRACERS_TOTAL,1,2,2) -!----------------------------------------------------------------------- -!*** TRACERS_PREV -!----------------------------------------------------------------------- - DO N=1,int_state%NUM_TRACERS_TOTAL - DO L=1,LM - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%TRACERS_PREV(:,:,:,N),1,1,1,LM,L & - ,MYPE,MPI_COMM_COMP) - ENDDO - ENDDO - CALL HALO_EXCH(int_state%TRACERS_PREV,LM,int_state%NUM_TRACERS_TOTAL,1,2,2) -!----------------------------------------------------------------------- -!*** TRACKER_ANGLE -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%TRACKER_ANGLE,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** TRACKER_DISTSQ -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%TRACKER_DISTSQ,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** TRAIN -!----------------------------------------------------------------------- - DO L=1,LM - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - DO J=JMS,JME - DO I=IMS,IME - int_state%TRAIN(I,J,L)=0. - ENDDO - ENDDO - CALL DSTRB(TEMP1,int_state%TRAIN,1,1,1,LM,L,MYPE,MPI_COMM_COMP) - ENDDO -!----------------------------------------------------------------------- -!*** TSHLTR -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%TSHLTR,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** TSKIN -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%TSKIN,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** TWBS -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%TWBS,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** T -!----------------------------------------------------------------------- - DO L=1,LM - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - WRITE(0,*) 'L, T extremes: ', L, MINVAL(TEMP1),MAXVAL(TEMP1) - ENDIF - DO J=JMS,JME - DO I=IMS,IME - int_state%T(I,J,L)=0. - ENDDO - ENDDO - CALL DSTRB(TEMP1,int_state%T,1,1,1,LM,L,MYPE,MPI_COMM_COMP) - ENDDO - CALL HALO_EXCH(int_state%T,LM,2,2) -!----------------------------------------------------------------------- -!*** TADJ -!----------------------------------------------------------------------- - DO L=1,LM - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - DO J=JMS,JME - DO I=IMS,IME - int_state%TADJ(I,J,L)=0. - ENDDO - ENDDO - CALL DSTRB(TEMP1,int_state%TADJ,1,1,1,LM,L,MYPE,MPI_COMM_COMP) - ENDDO - CALL HALO_EXCH(int_state%TADJ,LM,2,2) -!----------------------------------------------------------------------- -!*** TOLD -!----------------------------------------------------------------------- - DO L=1,LM - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - DO J=JMS,JME - DO I=IMS,IME - int_state%TOLD(I,J,L)=0. - ENDDO - ENDDO - CALL DSTRB(TEMP1,int_state%TOLD,1,1,1,LM,L,MYPE,MPI_COMM_COMP) - ENDDO - CALL HALO_EXCH(int_state%TOLD,LM,2,2) -!----------------------------------------------------------------------- -!*** U10 -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%U10,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** UP -!----------------------------------------------------------------------- - DO L=1,LM - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%UP,1,1,1,LM,L,MYPE,MPI_COMM_COMP) - ENDDO - CALL HALO_EXCH(int_state%UP,LM,2,2) -!----------------------------------------------------------------------- -!*** USTAR -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%USTAR,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** UZ0 -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%UZ0,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** U -!----------------------------------------------------------------------- - DO L=1,LM - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - DO J=JMS,JME - DO I=IMS,IME - int_state%U(I,J,L)=0. - ENDDO - ENDDO - CALL DSTRB(TEMP1,int_state%U,1,1,1,LM,L,MYPE,MPI_COMM_COMP) - ENDDO - CALL HALO_EXCH(int_state%U,LM,2,2) -!----------------------------------------------------------------------- -!*** V10 -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%V10,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** VEGFRC -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST) TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%VEGFRC,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** VLAT -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - DO J=JMS,JME - DO I=IMS,IME - int_state%VLAT(I,J)=0. - ENDDO - ENDDO - CALL DSTRB(TEMP1,int_state%VLAT,1,1,1,1,1,MYPE,MPI_COMM_COMP) - CALL HALO_EXCH(int_state%VLAT,1,2,2) -!----------------------------------------------------------------------- -!*** VLON -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - DO J=JMS,JME - DO I=IMS,IME - int_state%VLON(I,J)=0. - ENDDO - ENDDO - CALL DSTRB(TEMP1,int_state%VLON,1,1,1,1,1,MYPE,MPI_COMM_COMP) - CALL HALO_EXCH(int_state%VLON,1,2,2) -!----------------------------------------------------------------------- -!*** VP -!----------------------------------------------------------------------- - DO L=1,LM - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%VP,1,1,1,LM,L,MYPE,MPI_COMM_COMP) - ENDDO - CALL HALO_EXCH(int_state%VP,LM,2,2) -!----------------------------------------------------------------------- -!*** VZ0 -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST) TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%VZ0,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** V -!----------------------------------------------------------------------- - DO L=1,LM - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - DO J=JMS,JME - DO I=IMS,IME - int_state%V(I,J,L)=0. - ENDDO - ENDDO - CALL DSTRB(TEMP1,int_state%V,1,1,1,LM,L,MYPE,MPI_COMM_COMP) - ENDDO - CALL HALO_EXCH(int_state%V,LM,2,2) -!----------------------------------------------------------------------- -!*** W -!----------------------------------------------------------------------- - int_state%W=0.0 - DO L=1,LM - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%W,1,1,1,LM,L,MYPE,MPI_COMM_COMP) - ENDDO - CALL HALO_EXCH(int_state%W,LM,2,2) -!----------------------------------------------------------------------- -!*** XLEN_MIX -!----------------------------------------------------------------------- - DO K=1,LM - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - DO J=JMS,JME - DO I=IMS,IME - int_state%XLEN_MIX(I,J,K)=0. - ENDDO - ENDDO - CALL DSTRB(TEMP1,int_state%XLEN_MIX,1,1,1,LM,K,MYPE,MPI_COMM_COMP) - ENDDO -!----------------------------------------------------------------------- -!*** Z0 -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%Z0,1,1,1,1,1,MYPE,MPI_COMM_COMP) - CALL HALO_EXCH(int_state%Z0,1,3,3) -!----------------------------------------------------------------------- -!*** Z0BASE -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%Z0BASE,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -!*** Z -!----------------------------------------------------------------------- - DO L=1,LM - IF(MYPE==0)THEN - READ(NFCST)TEMP1 - ENDIF - CALL DSTRB(TEMP1,int_state%Z,1,1,1,LM,L,MYPE,MPI_COMM_COMP) - ENDDO - CALL HALO_EXCH(int_state%Z,LM,2,2) -!----------------------------------------------------------------------- -! - close(nfcst) -! -!----------------------------------------------------------------------- -! - tend_max=real(int_state%IHREND) - ntstm_max=nint(tend_max*3600./int_state%DT)+1 - tend=real(int_state%nhours_fcst) - int_state%NTSTM=nint(tend*3600./int_state%DT)+1 - if(.not.int_state%GLOBAL)then - if(mype==0)then - write(0,*)' Max runtime is ',tend_max,' hours' - endif - endif - if(mype==0)then - write(0,*)' Requested runtime is ',tend,' hours' - write(0,*)' NTSTM=',int_state%NTSTM - endif - if(int_state%NTSTM>ntstm_max.and..not.int_state%GLOBAL)then - if(mype==0)then - write(0,*)' Requested fcst length exceeds maximum' - write(0,*)' Resetting to maximum' - endif - int_state%NTSTM=min(int_state%NTSTM,ntstm_max) - endif -! - ntsd=0 - int_state%IHR=nint(ntsd*int_state%DT/3600.) -!----------------------------------------------------------------------- - do l=1,lm - int_state%PDSG1(l)=int_state%DSG1(l)*int_state%PDTOP - int_state%PSGML1(l)=int_state%SGML1(l)*int_state%PDTOP+int_state%PT - enddo -! - do l=1,lm+1 - int_state%PSG1(l)=int_state%SG1(l)*int_state%PDTOP+int_state%PT - enddo -!----------------------------------------------------------------------- - endif read_blocks ! cold start /restart -!----------------------------------------------------------------------- -! - deallocate(temp1) -! -!----------------------------------------------------------------------- -! - end subroutine read_binary -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - SUBROUTINE PHYSICS_READ_GWD(INFILE,NGWD,INT_STATE & - ,MYPE,MPI_COMM_COMP & - ,IDS,IDE,JDS,JDE,RC) -!---------------------------------------------------------------------- -! -!------------------------ -!*** Argument variables -!------------------------ -! - INTEGER,INTENT(IN) :: NGWD,MYPE,MPI_COMM_COMP - INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE -! - CHARACTER(LEN=*),INTENT(IN) :: INFILE -! - TYPE(SOLVER_INTERNAL_STATE),POINTER,INTENT(INOUT) :: INT_STATE !<-- The physics internal state -! - INTEGER,INTENT(OUT) :: RC -! -!--------------------- -!*** Local variables -!--------------------- -! - INTEGER :: IERR -! - REAL,DIMENSION(:,:),ALLOCATABLE :: TEMP_GWD -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC = 0 -! - ALLOCATE(TEMP_GWD(IDS:IDE,JDS:JDE)) -! -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - OPEN(unit=NGWD,file=INFILE,status='old',form='unformatted' & - ,iostat=IERR) - IF(IERR/=0)THEN - WRITE(0,*)' Unable to open file ',TRIM(INFILE) & - ,' in PHYSICS_READ_GWD' - RC = IERR - RETURN - ENDIF - ENDIF -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NGWD)TEMP_GWD - ENDIF -! - CALL DSTRB(TEMP_GWD,int_state%HSTDV,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NGWD)TEMP_GWD - ENDIF -! - CALL DSTRB(TEMP_GWD,int_state%HCNVX,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NGWD)TEMP_GWD - ENDIF -! - CALL DSTRB(TEMP_GWD,int_state%HASYW,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NGWD)TEMP_GWD - ENDIF -! - CALL DSTRB(TEMP_GWD,int_state%HASYS,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NGWD)TEMP_GWD - ENDIF -! - CALL DSTRB(TEMP_GWD,int_state%HASYSW,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NGWD)TEMP_GWD - ENDIF -! - CALL DSTRB(TEMP_GWD,int_state%HASYNW,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NGWD)TEMP_GWD - ENDIF -! - CALL DSTRB(TEMP_GWD,int_state%HLENW,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NGWD)TEMP_GWD - ENDIF -! - CALL DSTRB(TEMP_GWD,int_state%HLENS,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NGWD)TEMP_GWD - ENDIF -! - CALL DSTRB(TEMP_GWD,int_state%HLENSW,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NGWD)TEMP_GWD - ENDIF -! - CALL DSTRB(TEMP_GWD,int_state%HLENNW,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NGWD)TEMP_GWD - ENDIF -! - CALL DSTRB(TEMP_GWD,int_state%HANGL,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NGWD)TEMP_GWD - ENDIF -! - CALL DSTRB(TEMP_GWD,int_state%HANIS,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NGWD)TEMP_GWD - ENDIF -! - CALL DSTRB(TEMP_GWD,int_state%HSLOP,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- - IF(MYPE==0)THEN - READ(NGWD)TEMP_GWD - ENDIF -! - CALL DSTRB(TEMP_GWD,int_state%HZMAX,1,1,1,1,1,MYPE,MPI_COMM_COMP) -!----------------------------------------------------------------------- -! - IF(MYPE==0)THEN - CLOSE(NGWD) - ENDIF -! - DEALLOCATE(TEMP_GWD) -!----------------------------------------------------------------------- -! - END SUBROUTINE PHYSICS_READ_GWD -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - end module module_INIT_READ_BIN -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- - diff --git a/src/nmm/module_INIT_READ_NEMSIO.F90 b/src/nmm/module_INIT_READ_NEMSIO.F90 deleted file mode 100644 index c96762e..0000000 --- a/src/nmm/module_INIT_READ_NEMSIO.F90 +++ /dev/null @@ -1,4221 +0,0 @@ -!----------------------------------------------------------------------- - module module_INIT_READ_NEMSIO -!----------------------------------------------------------------------- -use mpi -use esmf -use module_kinds -use module_dm_parallel,only : ids,ide,jds,jde & - ,ims,ime,jms,jme & - ,its,ite,jts,jte & - ,its_h2,ite_h2,jts_h2,jte_h2 & - ,lm & - ,mype_share,npes,num_pts_max & - ,mpi_comm_comp & - ,dstrb -use module_exchange -use module_constants -use module_solver_internal_state,only: solver_internal_state -use nemsio_module_mpi -! -!----------------------------------------------------------------------- -! - implicit none -! - private -! - public read_nemsio -! -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! - contains -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - subroutine read_nemsio & - (INT_STATE,my_domain_id,rc) -! -!----------------------------------------------------------------------- -! -implicit none -! -!------------------------ -!*** Argument variables -!------------------------ -! -type(solver_internal_state),pointer :: int_state - -integer(kind=kint),intent(in) :: & - my_domain_id - -integer(kind=kint),intent(out) :: & - rc -! -!--------------------- -!*** Local variables -!--------------------- -! -integer(kind=kint) :: & - i & ! index in x direction -,iend & -,ierr & -,irtn & -,j & ! index in y direction -,jend & -,k & ! index -,kount & -,ks & ! tracer index -,l & ! index in p direction -,length & -,n & -,nl & -,nv - -integer(kind=kint) :: & - iyear_fcst & -,imonth_fcst & -,iday_fcst & -,ihour_fcst - -integer(kind=kint) :: & - lb & -,ub & -,nvars_bc_2d_h & -,nvars_bc_3d_h & -,nvars_bc_4d_h & -,nvars_bc_2d_v & -,nvars_bc_3d_v - -integer(kind=kint) :: idate(7) -integer(kind=kint) :: fcstdate(7) -character(3) ::tn - -real(kind=kfpt):: & - tend,tend_max,arg - -real(kind=kfpt),dimension(:),allocatable :: & - all_bc_data & -,tmp, psint - -logical(kind=klog) :: opened - -type(nemsio_gfile) :: gfile - -integer(kind=kint) :: & - mype - -character(64):: & - infile - -integer(kind=kint):: & - ihrend & ! maximum forecast length, hours -,ntsd & -,ntstm_max & -,nfcst - -integer nrec,mysize,myrank -integer fldsize,fldst,js,recn -character(16),allocatable :: recname(:), reclevtyp(:) -integer,allocatable :: reclev(:) -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - mype=mype_share -! -!----------------------------------------------------------------------- -!*** Initialize nemsio_module -!----------------------------------------------------------------------- -! - call nemsio_init() -! -!----------------------------------------------------------------------- -! - read_blocks: if(.not.int_state%RESTART) then ! cold start -! -!----------------------------------------------------------------------- -! - write(infile,'(a,i2.2,a)')'input_domain_',my_domain_id,'_nemsio' - call nemsio_open(gfile,infile,'read',mpi_comm_comp,iret=ierr) - if(ierr/=0)then - write(0,*)' Unable to open file ',trim(infile),' in READ_NEMSIO' - rc = ierr - return - endif -! - call nemsio_getfilehead(gfile,nrec=nrec,iret=ierr) -! - allocate(recname(nrec),reclevtyp(nrec),reclev(nrec)) - call nemsio_getfilehead(gfile,recname=recname,reclevtyp=reclevtyp, & - reclev=reclev,iret=ierr) -! -!----------------------------------------------------------------------- -!*** Get run,idat,ihrst,ihrend,ntsd -!----------------------------------------------------------------------- -! - call nemsio_getheadvar(gfile,'RUN',int_state%RUN,ierr) - call nemsio_getheadvar(gfile,'IDAT',int_state%IDAT,ierr) - call nemsio_getheadvar(gfile,'IHRST',int_state%IHRST,ierr) - call nemsio_getheadvar(gfile,'IHREND',int_state%IHREND,ierr) - call nemsio_getheadvar(gfile,'NTSD',ntsd,ierr) -! -!----------------------------------------------------------------------- -!*** Print the time information. -!----------------------------------------------------------------------- -! - if(mype==0)then - write(0,*) 'run, idat,ntsd: ', int_state%RUN, int_state%IDAT, NTSD - write(0,*)' Start year =',int_state%IDAT(3) - write(0,*)' Start month=',int_state%IDAT(2) - write(0,*)' Start day =',int_state%IDAT(1) - write(0,*)' Start hour =',int_state%IHRST - write(0,*)' Timestep =',int_state%DT - write(0,*)' Steps/hour =',3600./int_state%DT - if(.not.int_state%GLOBAL)write(0,*)' Max fcst hours=',int_state%IHREND - endif -! -!----------------------------------------------------------------------- -!*** Get SW corner of nest domains on their parent grid. -!----------------------------------------------------------------------- -! - call nemsio_getheadvar(gfile,'IPARSTRT',int_state%I_PAR_STA,ierr) - call nemsio_getheadvar(gfile,'JPARSTRT',int_state%J_PAR_STA,ierr) -! -!----------------------------------------------------------------------- -! - call nemsio_getheadvar(gfile,'PT',int_state%PT,ierr) - call nemsio_getheadvar(gfile,'PDTOP',int_state%PDTOP,ierr) - call nemsio_getheadvar(gfile,'LPT2',int_state%LPT2,ierr) - call nemsio_getheadvar(gfile,'SGM',int_state%SGM,ierr) - call nemsio_getheadvar(gfile,'SG1',int_state%SG1,ierr) - call nemsio_getheadvar(gfile,'DSG1',int_state%DSG1,ierr) - call nemsio_getheadvar(gfile,'SGML1',int_state%SGML1,ierr) - call nemsio_getheadvar(gfile,'SG2',int_state%SG2,ierr) - call nemsio_getheadvar(gfile,'DSG2',int_state%DSG2,ierr) - call nemsio_getheadvar(gfile,'SGML2',int_state%SGML2,ierr) -! - fldsize=(jte-jts+1)*(ite-its+1) - allocate(tmp((ite-its+1)*(jte-jts+1)*nrec),stat=i) -! - call nemsio_denseread(gfile,its,ite,jts,jte,tmp,iret=ierr) - if(ierr/=0) then - write(0,*)'WRONG: Could not read all the fields in the file!' - rc = ierr - return - endif -!----------------------------------------------------------------------- -! -!-- fis - int_state%fis=0. - call getrecn(recname,reclevtyp,reclev,nrec,'fis','sfc',1,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%fis(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - call halo_exch(int_state%fis,1,3,3) -!----------------------------------------------------------------------- -! -!-- stdh - int_state%stdh=0. - call getrecn(recname,reclevtyp,reclev,nrec,'stdh','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%stdh(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - call halo_exch(int_state%stdh,1,3,3) -!----------------------------------------------------------------------- -! -!-- sm - int_state%sm=0. - call getrecn(recname,reclevtyp,reclev,nrec,'sm','sfc',1,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%sm(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - call halo_exch(int_state%sm,1,2,2) -!----------------------------------------------------------------------- -! -!-- dpres - int_state%pd=0. - call getrecn(recname,reclevtyp,reclev,nrec,'dpres','hybrid sig lev',1,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%pd(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - call halo_exch(int_state%pd,1,2,2) -!----------------------------------------------------------------------- -! -!-- ugrd - int_state%u=0. - do l=1,lm - call getrecn(recname,reclevtyp,reclev,nrec,'ugrd','mid layer',l,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%u(i,j,l)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - enddo - call halo_exch(int_state%u,lm,2,2) -!----------------------------------------------------------------------- -! -!--vgrd - int_state%v=0. - do l=1,lm - call getrecn(recname,reclevtyp,reclev,nrec,'vgrd','mid layer',l,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%v(i,j,l)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - enddo - call halo_exch(int_state%v,lm,2,2) -!----------------------------------------------------------------------- -!--tmp - int_state%t=0. - do l=1,lm - call getrecn(recname,reclevtyp,reclev,nrec,'tmp','mid layer',l,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%t(i,j,l)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - enddo - call halo_exch(int_state%t,lm,2,2) -!----------------------------------------------------------------------- -! -!--spfh - int_state%q=0. - do l=1,lm - call getrecn(recname,reclevtyp,reclev,nrec,'spfh','mid layer',l,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%q(i,j,l)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - enddo - call halo_exch(int_state%q,lm,2,2) -!----------------------------------------------------------------------- -! -!-- clwmr - int_state%cw=0. - do l=1,lm - call getrecn(recname,reclevtyp,reclev,nrec,'clwmr','mid layer',l,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%cw(i,j,l)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - enddo - call halo_exch(int_state%cw,lm,2,2) -! -!----------------------------------------------------------------------- -! - tend_max=real(int_state%IHREND) - ntstm_max=nint(tend_max*3600./int_state%DT)+1 - tend=real(int_state%nhours_fcst) - int_state%NTSTM=nint(tend*3600./int_state%DT)+1 - if(.not.int_state%global)then - if(mype==0)then - write(0,*)' Max runtime is ',tend_max,' hours' - endif - endif - if(mype==0)then - write(0,*)' Requested runtime is ',tend,' hours' - write(0,*)' NTSTM=',int_state%NTSTM - endif - if(int_state%NTSTM>ntstm_max.and..not.int_state%global)then - if(mype==0)then - write(0,*)' Requested fcst length exceeds maximum' - write(0,*)' Resetting to maximum' - endif - int_state%NTSTM=min(int_state%NTSTM,ntstm_max) - endif -! - int_state%ihr=nint(ntsd*int_state%DT/3600.) -! -!----------------------------------------------------------------------- - do l=1,lm - int_state%pdsg1(l)=int_state%dsg1(l)*int_state%pdtop - int_state%psgml1(l)=int_state%sgml1(l)*int_state%pdtop+int_state%pt - enddo -! - do l=1,lm+1 - int_state%psg1(l)=int_state%sg1(l)*int_state%pdtop+int_state%pt - enddo -! -!-- Compute pressure dependent floor values of EPSL & EPSQ2 -! - ALLOCATE(PSINT(1:LM+1)) - DO K=1,LM+1 - PSINT(K)=int_state%SG2(k)*101325.+int_state%PSG1(K) - ENDDO - ! - DO K=2,LM - ARG=(PSINT(K)-PSINT(2))/(PSINT(LM)-PSINT(2))*PI -! int_state%EPSQ2(K-1)=(1.+COS(ARG))*0.09+0.02 - int_state%EPSQ2(K-1)=0.02 - int_state%EPSL(K-1)=SQRT(int_state%EPSQ2(K-1)*0.5) - ENDDO - int_state%EPSQ2(LM)=int_state%EPSQ2(LM-1) - DEALLOCATE(PSINT) - -!write(0,*) 'epsl=',epsl -!write(0,*) 'epsq2=',epsq2 -!----------------------------------------------------------------------- - do j=jts,jte - do i=its,ite - int_state%pdo(i,j)=int_state%pd(i,j) - enddo - enddo - call halo_exch(int_state%pdo,1,2,2) -! - do l=1,lm - do j=jts,jte - do i=its,ite - int_state%up(i,j,l)=int_state%u(i,j,l) - int_state%vp(i,j,l)=int_state%v(i,j,l) - int_state%tp(i,j,l)=int_state%t(i,j,l) - enddo - enddo - enddo - call halo_exch(int_state%tp,lm,int_state%up,lm,int_state%vp,lm,2,2) -!----------------------------------------------------------------------- - do l=1,lm - do j=jms,jme - do i=ims,ime - int_state%q2(i,j,l)=0.02 - int_state%o3(i,j,l)=0. - if(i.ge.ide /2+1- 6.and.i.le.ide /2+1+ 6.and. & - j.ge.jde*3/4+1- 6.and.j.le.jde*3/4+1+ 6.) then !global -! j.ge.jde /2+1- 6.and.j.le.jde /2+1+ 6.) then !regional - int_state%o3(i,j,l)=10. - endif - int_state%dwdt(i,j,l)=1. - int_state%w(i,j,l)=0. - enddo - enddo - enddo - call halo_exch(int_state%dwdt,lm,2,2) -! - do j=jts,jte - do i=its,ite - int_state%pint(i,j,1)=int_state%pt - enddo - enddo -! - do l=1,lm - do j=jts,jte - do i=its,ite - int_state%pint(i,j,l+1)=int_state%pint(i,j,l)+int_state%dsg2(l)*int_state%pd(i,j)+int_state%pdsg1(l) - enddo - enddo - enddo - call halo_exch(int_state%pint,lm+1,2,2) -! - call halo_exch(int_state%q2,lm,int_state%o3,lm,2,2) - do l=1,lm - do j=jms,jme - do i=ims,ime - int_state%tracers_prev(i,j,l,int_state%indx_q )=sqrt(max(int_state%q (i,j,l),0.)) - int_state%tracers_prev(i,j,l,int_state%indx_cw)=sqrt(max(int_state%cw(i,j,l),0.)) - int_state%tracers_prev(i,j,l,int_state%indx_q2)=sqrt(max(int_state%q2(i,j,l),0.)) - enddo - enddo - enddo -! -!----------------------------------------------------------------------- -!---reading surface data------------------------------------------------ -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** ALBEDO -!----------------------------------------------------------------------- -! - call getrecn(recname,reclevtyp,reclev,nrec,'albedo','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%ALBEDO(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** ALBASE -!----------------------------------------------------------------------- -! - call getrecn(recname,reclevtyp,reclev,nrec,'albase','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%ALBASE(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** EPSR -!----------------------------------------------------------------------- -! - call getrecn(recname,reclevtyp,reclev,nrec,'epsr','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%EPSR(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** MXSNAL -!----------------------------------------------------------------------- -! - call getrecn(recname,reclevtyp,reclev,nrec,'mxsnal','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%MXSNAL(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** TSKIN -!----------------------------------------------------------------------- -! - call getrecn(recname,reclevtyp,reclev,nrec,'tskin','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%TSKIN(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** SST -!----------------------------------------------------------------------- -! - call getrecn(recname,reclevtyp,reclev,nrec,'tsea','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SST(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** SNO and SNOWC -!----------------------------------------------------------------------- -! - call getrecn(recname,reclevtyp,reclev,nrec,'sno','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SNO(i,j)=tmp(i-its+1+js+fldst) - if(int_state%SNO(i,j).gt.0.) then !2013 - int_state%SNOWC(i,j) = 0.98 - else - int_state%SNOWC(i,j) = 0.0 - endif - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** SI -!----------------------------------------------------------------------- -! - call getrecn(recname,reclevtyp,reclev,nrec,'si','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SI(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** SICE -!----------------------------------------------------------------------- -! - call getrecn(recname,reclevtyp,reclev,nrec,'sice','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SICE(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! write(0,*)'aft sice, sice=',maxval(int_state%SICE),minval(int_state%SICE) -! -!----------------------------------------------------------------------- -!*** TG -!----------------------------------------------------------------------- -! - call getrecn(recname,reclevtyp,reclev,nrec,'tg','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%TG(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** CMC -!----------------------------------------------------------------------- -! - call getrecn(recname,reclevtyp,reclev,nrec,'cmc','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%CMC(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** SR -!----------------------------------------------------------------------- -! - call getrecn(recname,reclevtyp,reclev,nrec,'sr','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SR(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** USTAR -!----------------------------------------------------------------------- -! - call getrecn(recname,reclevtyp,reclev,nrec,'ustar','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%ustar(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** Z0 -!----------------------------------------------------------------------- -! - call getrecn(recname,reclevtyp,reclev,nrec,'zorl','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%Z0(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - CALL HALO_EXCH(int_state%Z0,1,3,3) -! -!----------------------------------------------------------------------- -!*** Z0BASE -!----------------------------------------------------------------------- -! - call getrecn(recname,reclevtyp,reclev,nrec,'z0base','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%Z0BASE(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - CALL HALO_EXCH(int_state%Z0BASE,1,3,3) -! -!----------------------------------------------------------------------- -!*** STC, SMC, SH2O -!----------------------------------------------------------------------- -! - DO L=1,int_state%NSOIL -! - call getrecn(recname,reclevtyp,reclev,nrec,'stc','soil layer',l,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%STC(i,j,l)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! - call getrecn(recname,reclevtyp,reclev,nrec,'smc','soil layer',l,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SMC(i,j,l)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! - call getrecn(recname,reclevtyp,reclev,nrec,'sh2o','soil layer',l,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SH2O(i,j,l)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! - ENDDO -! -!----------------------------------------------------------------------- -!*** ISLTYP -!----------------------------------------------------------------------- -! - call getrecn(recname,reclevtyp,reclev,nrec,'sltyp','sfc',1,recn) - int_state%ISLTYP=0 - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%ISLTYP(i,j)=INT(tmp(i-its+1+js+fldst)) - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** IVGTYP -!----------------------------------------------------------------------- -! - call getrecn(recname,reclevtyp,reclev,nrec,'vgtyp','sfc',1,recn) - int_state%IVGTYP=0 - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%IVGTYP(i,j)=INT(tmp(i-its+1+js+fldst)) - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** VEGFRC -!----------------------------------------------------------------------- -! - call getrecn(recname,reclevtyp,reclev,nrec,'vegfrc','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%VEGFRC(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! -!! FOR Hurricane application, U10, V10 at initial time are needed for running tracker -! Weiguo Wang 2014-06-22 - ! write(0,*)'read v10' - ! write(0,*)'int_state%RUN_TC=',int_state%RUN_TC - if (int_state%RUN_TC) then -!----------------------------------------------------------------------- -!*** U10 -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'u10','10 m above gnd',1,recn) - int_state%u10=0.0 - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%U10(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - call halo_exch(int_state%U10,1,2,2) - ! write(0,*)'read u10' - ! write(0,*)int_state%U10(1:10,5) -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** V10 -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'v10','10 m above gnd',1,recn) - int_state%v10=0.0 - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%V10(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - call halo_exch(int_state%v10,1,2,2) - ! write(0,*)'read v10' - ! write(0,*)int_state%v10(1:10,5) - endif ! if hurricane -!----------------------------------------------------------------------- -! - call nemsio_getheadvar(gfile,'dlmd',int_state%dlmd,ierr) - call nemsio_getheadvar(gfile,'dphd',int_state%dphd,ierr) - call nemsio_getheadvar(gfile,'wbd',int_state%wbd,ierr) - call nemsio_getheadvar(gfile,'sbd',int_state%sbd,ierr) - call nemsio_getheadvar(gfile,'tlm0d',int_state%tlm0d,ierr) - call nemsio_getheadvar(gfile,'tph0d',int_state%tph0d,ierr) -! - call mpi_bcast(int_state%pt,1,mpi_real,0,mpi_comm_comp,irtn) - call mpi_bcast(int_state%dlmd,1,mpi_real,0,mpi_comm_comp,irtn) - call mpi_bcast(int_state%dphd,1,mpi_real,0,mpi_comm_comp,irtn) - call mpi_bcast(int_state%wbd,1,mpi_real,0,mpi_comm_comp,irtn) - call mpi_bcast(int_state%sbd,1,mpi_real,0,mpi_comm_comp,irtn) - call mpi_bcast(int_state%tlm0d,1,mpi_real,0,mpi_comm_comp,irtn) - call mpi_bcast(int_state%tph0d,1,mpi_real,0,mpi_comm_comp,irtn) -! -!----------------------------------------------------------------------- -! - call nemsio_close(gfile,iret=ierr) -! -!----------------------------------------------------------------------- - else read_blocks ! restart -!----------------------------------------------------------------------- -! - write(infile,'(a,i2.2,a)')'restart_file_',my_domain_id,'_nemsio' - call nemsio_open(gfile,infile,'read',mpi_comm_comp,iret=ierr) - if(ierr/=0)then - write(0,*)' Unable to open ',trim(infile),' in READ_NEMSIO' - rc = ierr - return - endif -! -!----------------------------------------------------------------------- -!*** Read from restart file: Integer scalars -!----------------------------------------------------------------------- - call nemsio_getheadvar(gfile,'FCSTDATE',FCSTDATE,ierr) - iyear_fcst=FCSTDATE(1) - imonth_fcst=FCSTDATE(2) - iday_fcst=FCSTDATE(3) - ihour_fcst=FCSTDATE(4) - call nemsio_getheadvar(gfile,'IHRST',int_state%IHRST,ierr) - call nemsio_getheadvar(gfile,'LPT2',int_state%LPT2,ierr) - call nemsio_getheadvar(gfile,'I_PAR_STA',int_state%I_PAR_STA,ierr) - call nemsio_getheadvar(gfile,'J_PAR_STA',int_state%J_PAR_STA,ierr) - call nemsio_getheadvar(gfile,'LAST_STEP_MOVED',int_state%LAST_STEP_MOVED,ierr) - call nemsio_getheadvar(gfile,'NMTS',int_state%NMTS,ierr) -! - call nemsio_getheadvar(gfile,'TRACK_N_OLD',int_state%TRACK_N_OLD,ierr) - call nemsio_getheadvar(gfile,'TRACKER_IFIX',int_state%TRACKER_IFIX,ierr) - call nemsio_getheadvar(gfile,'TRACKER_JFIX',int_state%TRACKER_JFIX,ierr) - call nemsio_getheadvar(gfile,'TRACKER_GAVE_UP',int_state%TRACKER_GAVE_UP,ierr) - call nemsio_getheadvar(gfile,'TRACK_HAVE_GUESS',int_state%TRACK_HAVE_GUESS,ierr) - call nemsio_getheadvar(gfile,'TRACKER_HAVEFIX',int_state%TRACKER_HAVEFIX,ierr) -! -!----------------------------------------------------------------------- -!*** Read from restart file: Integer 1D arrays -!----------------------------------------------------------------------- - call nemsio_getheadvar(gfile,'IDAT',int_state%idat,ierr) - call nemsio_getheadvar(gfile,'NTSCM',int_state%ntscm,ierr) -! - if(mype==0)then - write(0,*)'**** in read_nemsio *****************' - write(0,*)' Restart year =',iyear_fcst - write(0,*)' Restart month=',imonth_fcst - write(0,*)' Restart day =',iday_fcst - write(0,*)' Restart hour =',ihour_fcst - write(0,*)' Original start year =',int_state%idat(3) - write(0,*)' Original start month=',int_state%idat(2) - write(0,*)' Original start day =',int_state%idat(1) - write(0,*)' Original start hour =',int_state%ihrst - write(0,*)' Timestep =',int_state%dt - write(0,*)' Steps/hour =',3600./int_state%dt - write(0,*)'*************************************' - endif -! -!----------------------------------------------------------------------- -!*** Read from restart file: Real scalars -!----------------------------------------------------------------------- - call nemsio_getheadvar(gfile,'PDTOP',int_state%pdtop,ierr) - call nemsio_getheadvar(gfile,'PT',int_state%pt,ierr) - call nemsio_getheadvar(gfile,'TLM0D',int_state%tlm0d,ierr) - call nemsio_getheadvar(gfile,'TPH0D',int_state%tph0d,ierr) - call nemsio_getheadvar(gfile,'DPHD',int_state%dphd,ierr) - call nemsio_getheadvar(gfile,'DLMD',int_state%dlmd,ierr) - call nemsio_getheadvar(gfile,'SBD',int_state%sbd,ierr) - call nemsio_getheadvar(gfile,'WBD',int_state%wbd,ierr) -! - call nemsio_getheadvar(gfile,'TRACK_LAST_HOUR',int_state%TRACK_LAST_HOUR,ierr) - call nemsio_getheadvar(gfile,'TRACK_GUESS_LAT',int_state%TRACK_GUESS_LAT,ierr) - call nemsio_getheadvar(gfile,'TRACK_GUESS_LON',int_state%TRACK_GUESS_LON,ierr) - call nemsio_getheadvar(gfile,'TRACK_EDGE_DIST',int_state%TRACK_EDGE_DIST,ierr) - call nemsio_getheadvar(gfile,'TRACK_STDERR_M1',int_state%TRACK_STDERR_M1,ierr) - call nemsio_getheadvar(gfile,'TRACK_STDERR_M2',int_state%TRACK_STDERR_M2,ierr) - call nemsio_getheadvar(gfile,'TRACK_STDERR_M3',int_state%TRACK_STDERR_M3,ierr) - call nemsio_getheadvar(gfile,'TRACKER_FIXLAT',int_state%TRACKER_FIXLAT,ierr) - call nemsio_getheadvar(gfile,'TRACKER_FIXLON',int_state%TRACKER_FIXLON,ierr) - call nemsio_getheadvar(gfile,'TRACKER_RMW',int_state%TRACKER_RMW,ierr) - call nemsio_getheadvar(gfile,'TRACKER_PMIN',int_state%TRACKER_PMIN,ierr) - call nemsio_getheadvar(gfile,'TRACKER_VMAX',int_state%TRACKER_VMAX,ierr) -! -!----------------------------------------------------------------------- -!*** Read from restart file: Real 1D arrays -!----------------------------------------------------------------------- - call nemsio_getheadvar(gfile,'SG1',int_state%sg1,ierr) - call nemsio_getheadvar(gfile,'SG2',int_state%sg2,ierr) - call nemsio_getheadvar(gfile,'DSG1',int_state%dsg1,ierr) - call nemsio_getheadvar(gfile,'DSG2',int_state%dsg2,ierr) - call nemsio_getheadvar(gfile,'SGML1',int_state%sgml1,ierr) - call nemsio_getheadvar(gfile,'SGML2',int_state%sgml2,ierr) - call nemsio_getheadvar(gfile,'SGM',int_state%sgm,ierr) - call nemsio_getheadvar(gfile,'EPSL',int_state%EPSL,ierr) - call nemsio_getheadvar(gfile,'EPSQ2',int_state%EPSQ2,ierr) - CALL NEMSIO_GETHEADVAR(gfile,'SLDPTH',int_state%SLDPTH,iret=irtn) - CALL NEMSIO_GETHEADVAR(gfile,'MP_RESTART',int_state%MP_RESTART_STATE,iret=irtn) - CALL NEMSIO_GETHEADVAR(gfile,'TBPVS_STAT',int_state%TBPVS_STATE,iret=irtn) - CALL NEMSIO_GETHEADVAR(gfile,'TBPVS0_STA',int_state%TBPVS0_STATE,iret=irtn) -! - DO L=1,LM - int_state%PDSG1(L)=int_state%DSG1(L)*int_state%PDTOP - int_state%PSGML1(L)=int_state%SGML1(L)*int_state%PDTOP+int_state%PT - ENDDO -! - DO L=1,LM+1 - int_state%PSG1(L)=int_state%SG1(L)*int_state%PDTOP+int_state%PT - ENDDO -! - CALL NEMSIO_GETHEADVAR(gfile,'TRACK_OLD_NTSD',int_state%TRACK_OLD_NTSD,iret=irtn) - CALL NEMSIO_GETHEADVAR(gfile,'TRACK_OLD_LAT',int_state%TRACK_OLD_LAT,iret=irtn) - CALL NEMSIO_GETHEADVAR(gfile,'TRACK_OLD_LON',int_state%TRACK_OLD_LON,iret=irtn) -! -!----------------------------------------------------------------------- -!*** Read in the full-domain 1-D string of boundary data. -!*** Each task isolates its own piece of that data. -!----------------------------------------------------------------------- -! - length=(int_state%nlev_h*int_state%lnsh & !<-- Total # of words - +int_state%nlev_v*int_state%lnsv) & ! in full-domain - *2*2*(ide-ids+jde-jds+2) ! boundary arrays. - allocate(all_bc_data(1:length)) -! - call nemsio_getheadvar(gfile,'ALL_BC_DATA',all_bc_data,ierr) -! -!----------------------------------------------------------------------- -! - nvars_bc_2d_h=int_state%nvars_bc_2d_h - nvars_bc_3d_h=int_state%nvars_bc_3d_h - nvars_bc_4d_h=int_state%nvars_bc_4d_h - nvars_bc_2d_v=int_state%nvars_bc_2d_v - nvars_bc_3d_v=int_state%nvars_bc_3d_v -! - kount=0 -! -!----------------------------------------------------------------------- -! - iend=min(ite_h2,ide) -! - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - do n=1,2 - do j=1,int_state%lnsh - do i=ids,ide - kount=kount+1 - if(jts==jds.and.i>=its_h2.and.i<=iend)then !<-- South boundary tasks extract 2-D BC H-pt data - int_state%bnd_vars_h%var_2d(nv)%south(i,j,n)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - do n=1,2 - do l=1,lm - do j=1,int_state%lnsh - do i=ids,ide - kount=kount+1 - if(jts==jds.and.i>=its_h2.and.i<=iend)then !<-- South boundary tasks extract 3-D BC H-pt data - int_state%bnd_vars_h%var_3d(nv)%south(i,j,l,n)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lb=int_state%lbnd_4d(nv) - ub=int_state%ubnd_4d(nv) - do nl=lb,ub - do n=1,2 - do l=1,lm - do j=1,int_state%lnsh - do i=ids,ide - kount=kount+1 - if(jts==jds.and.i>=its_h2.and.i<=iend)then !<-- South boundary tasks extract 4-D BC H-pt data - int_state%bnd_vars_h%var_4d(nv)%south(i,j,l,n,nl)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_2d_v>0)then - do nv=1,nvars_bc_2d_v - do n=1,2 - do j=1,int_state%lnsv - do i=ids,ide - kount=kount+1 - if(jts==jds.and.i>=its_h2.and.i<=iend)then !<-- South boundary tasks extract 2-D BC V-pt data - int_state%bnd_vars_v%var_2d(nv)%south(i,j,n)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_v>0)then - do nv=1,nvars_bc_3d_v - do n=1,2 - do l=1,lm - do j=1,int_state%lnsv - do i=ids,ide - kount=kount+1 - if(jts==jds.and.i>=its_h2.and.i<=iend)then !<-- South boundary tasks extract 3-D BC V-pt data - int_state%bnd_vars_v%var_3d(nv)%south(i,j,l,n)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - do n=1,2 - do j=1,int_state%lnsh - do i=ids,ide - kount=kount+1 - if(jte==jde.and.i>=its_h2.and.i<=iend)then !<-- North boundary tasks extract 2-D BC H-pt data - int_state%bnd_vars_h%var_2d(nv)%north(i,j,n)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - do n=1,2 - do l=1,lm - do j=1,int_state%lnsh - do i=ids,ide - kount=kount+1 - if(jte==jde.and.i>=its_h2.and.i<=iend)then !<-- North boundary tasks extract 3-D BC H-pt data - int_state%bnd_vars_h%var_3d(nv)%north(i,j,l,n)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lb=int_state%lbnd_4d(nv) - ub=int_state%ubnd_4d(nv) - do nl=lb,ub - do n=1,2 - do l=1,lm - do j=1,int_state%lnsh - do i=ids,ide - kount=kount+1 - if(jte==jde.and.i>=its_h2.and.i<=iend)then !<-- North boundary tasks extract 4-D BC H-pt data - int_state%bnd_vars_h%var_4d(nv)%north(i,j,l,n,nl)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_2d_v>0)then - do nv=1,nvars_bc_2d_v - do n=1,2 - do j=1,int_state%lnsv - do i=ids,ide - kount=kount+1 - if(jte==jde.and.i>=its_h2.and.i<=iend)then !<-- North boundary tasks extract 2-D BC V-pt data - int_state%bnd_vars_v%var_2d(nv)%north(i,j,n)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_v>0)then - do nv=1,nvars_bc_3d_v - do n=1,2 - do l=1,lm - do j=1,int_state%lnsv - do i=ids,ide - kount=kount+1 - if(jte==jde.and.i>=its_h2.and.i<=iend)then !<-- North boundary tasks extract 3-D BC V-pt data - int_state%bnd_vars_v%var_3d(nv)%north(i,j,l,n)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - enddo - endif -! - jend=min(jte_h2,jde) -! - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - do n=1,2 - do j=jds,jde - do i=1,int_state%lnsh - kount=kount+1 - if(its==ids.and.j>=jts_h2.and.j<=jend)then !<-- West boundary tasks extract 2-D BC H-pt data - int_state%bnd_vars_h%var_2d(nv)%west(i,j,n)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - do n=1,2 - do l=1,lm - do j=jds,jde - do i=1,int_state%lnsh - kount=kount+1 - if(its==ids.and.j>=jts_h2.and.j<=jend)then !<-- West boundary tasks extract 3-D BC H-pt data - int_state%bnd_vars_h%var_3d(nv)%west(i,j,l,n)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lb=int_state%lbnd_4d(nv) - ub=int_state%ubnd_4d(nv) - do nl=lb,ub - do n=1,2 - do l=1,lm - do j=jds,jde - do i=1,int_state%lnsh - kount=kount+1 - if(its==ids.and.j>=jts_h2.and.j<=jend)then !<-- West boundary tasks extract 4-D BC H-pt data - int_state%bnd_vars_h%var_4d(nv)%west(i,j,l,n,nl)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_2d_v>0)then - do nv=1,nvars_bc_2d_v - do n=1,2 - do j=jds,jde - do i=1,int_state%lnsv - kount=kount+1 - if(its==ids.and.j>=jts_h2.and.j<=jend)then !<-- West boundary tasks extract 2-D BC V-pt data - int_state%bnd_vars_v%var_2d(nv)%west(i,j,n)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_v>0)then - do nv=1,nvars_bc_3d_v - do n=1,2 - do l=1,lm - do j=jds,jde - do i=1,int_state%lnsv - kount=kount+1 - if(its==ids.and.j>=jts_h2.and.j<=jend)then !<-- West boundary tasks extract 3-D BC V-pt data - int_state%bnd_vars_v%var_3d(nv)%west(i,j,l,n)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_2d_h>0)then - do nv=1,nvars_bc_2d_h - do n=1,2 - do j=jds,jde - do i=1,int_state%lnsh - kount=kount+1 - if(ite==ide.and.j>=jts_h2.and.j<=jend)then !<-- East boundary tasks extract 2-D BC H-pt data - int_state%bnd_vars_h%var_2d(nv)%east(i,j,n)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_h>0)then - do nv=1,nvars_bc_3d_h - do n=1,2 - do l=1,lm - do j=jds,jde - do i=1,int_state%lnsh - kount=kount+1 - if(ite==ide.and.j>=jts_h2.and.j<=jend)then !<-- East boundary tasks extract 3-D BC H-pt data - int_state%bnd_vars_h%var_3d(nv)%east(i,j,l,n)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_4d_h>0)then - do nv=1,nvars_bc_4d_h - lb=int_state%lbnd_4d(nv) - ub=int_state%ubnd_4d(nv) - do nl=lb,ub - do n=1,2 - do l=1,lm - do j=jds,jde - do i=1,int_state%lnsh - kount=kount+1 - if(ite==ide.and.j>=jts_h2.and.j<=jend)then !<-- East boundary tasks extract 4-D BC H-pt data - int_state%bnd_vars_h%var_4d(nv)%east(i,j,l,n,nl)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_2d_v>0)then - do nv=1,nvars_bc_2d_v - do n=1,2 - do j=jds,jde - do i=1,int_state%lnsv - kount=kount+1 - if(ite==ide.and.j>=jts_h2.and.j<=jend)then !<-- East boundary tasks extract 2-D BC V-pt data - int_state%bnd_vars_v%var_2d(nv)%east(i,j,n)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - endif -! - if(nvars_bc_3d_v>0)then - do nv=1,nvars_bc_3d_v - do n=1,2 - do l=1,lm - do j=jds,jde - do i=1,int_state%lnsv - kount=kount+1 - if(ite==ide.and.j>=jts_h2.and.j<=jend)then !<-- East boundary tasks extract 3-D BC V-pt data - int_state%bnd_vars_v%var_3d(nv)%east(i,j,l,n)= & - all_bc_data(kount) - endif - enddo - enddo - enddo - enddo - enddo - endif -! - deallocate(all_bc_data) -! -!----------------------------------------------------------------------- -!*** Read from restart file: Logical -!----------------------------------------------------------------------- - call nemsio_getheadvar(gfile,'RUN',int_state%run,ierr) -!----------------------------------------------------------------------- -!*** Read from restart file: Real 2D arrays -!----------------------------------------------------------------------- -! - fldsize=(jte-jts+1)*(ite-its+1) -! - call nemsio_getfilehead(gfile,nrec=nrec,iret=ierr) - allocate(recname(nrec),reclevtyp(nrec),reclev(nrec)) - call nemsio_getfilehead(gfile,recname=recname,reclevtyp=reclevtyp, & - reclev=reclev,iret=ierr) -! - allocate(tmp(fldsize*nrec)) - tmp=0. - call nemsio_denseread(gfile,its,ite,jts,jte,tmp,iret=ierr) -! -!----------------------------------------------------------------------- -!*** close nemsio file -!----------------------------------------------------------------------- -! - CALL NEMSIO_CLOSE(GFILE) -!----------------------------------------------------------------------- -! - CALL NEMSIO_FINALIZE() -! -!----------------------------------------------------------------------- -!*** assign data: Integer 2D arrays -!----------------------------------------------------------------------- -! - call getrecn(recname,reclevtyp,reclev,nrec,'sltyp','sfc',1,recn) - int_state%ISLTYP=0 - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%ISLTYP(i,j)=NINT(tmp(i-its+1+js+fldst)) - enddo - enddo - endif -! - call getrecn(recname,reclevtyp,reclev,nrec,'vgtyp','sfc',1,recn) - int_state%IVGTYP=0 - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%IVGTYP(i,j)=NINT(tmp(i-its+1+js+fldst)) - enddo - enddo - endif -! - call getrecn(recname,reclevtyp,reclev,nrec,'cfrcv','sfc',1,recn) - int_state%NCFRCV=0 - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%NCFRCV(i,j)=NINT(tmp(i-its+1+js+fldst)) - enddo - enddo - endif -! - call getrecn(recname,reclevtyp,reclev,nrec,'cfrst','sfc',1,recn) - int_state%NCFRST=0 - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%NCFRST(i,j)=NINT(tmp(i-its+1+js+fldst)) - enddo - enddo - endif -! - call getrecn(recname,reclevtyp,reclev,nrec,'tracker_fixes','sfc',1,recn) - int_state%TRACKER_FIXES=0 - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%TRACKER_FIXES(i,j)=NINT(tmp(i-its+1+js+fldst)) - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** Assign data: Real 2D arrays -!----------------------------------------------------------------------- -!-- fis - int_state%fis=0. - call getrecn(recname,reclevtyp,reclev,nrec,'fis','sfc',1,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%fis(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - call halo_exch(int_state%fis,1,2,2) -!----------------------------------------------------------------------- -!-- glat - int_state%glat=0. - call getrecn(recname,reclevtyp,reclev,nrec,'glat','sfc',1,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%glat(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - call halo_exch(int_state%glat,1,2,2) -!----------------------------------------------------------------------- -!-- glon - int_state%glon=0. - call getrecn(recname,reclevtyp,reclev,nrec,'glon','sfc',1,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%glon(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - call halo_exch(int_state%glon,1,2,2) -!----------------------------------------------------------------------- -!-- vlat - int_state%vlat=0. - call getrecn(recname,reclevtyp,reclev,nrec,'vlat','sfc',1,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%vlat(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - call halo_exch(int_state%vlat,1,2,2) -!----------------------------------------------------------------------- -!-- vlon - int_state%vlon=0. - call getrecn(recname,reclevtyp,reclev,nrec,'vlon','sfc',1,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%vlon(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - call halo_exch(int_state%vlon,1,2,2) -!----------------------------------------------------------------------- -!-- hdacx - int_state%hdacx=0. - call getrecn(recname,reclevtyp,reclev,nrec,'hdacx','sfc',1,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%hdacx(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - call halo_exch(int_state%hdacx,1,2,2) -!----------------------------------------------------------------------- -!-- hdacy - int_state%hdacy=0. - call getrecn(recname,reclevtyp,reclev,nrec,'hdacy','sfc',1,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%hdacy(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - call halo_exch(int_state%hdacy,1,2,2) -!----------------------------------------------------------------------- -!-- f - int_state%f=0. - call getrecn(recname,reclevtyp,reclev,nrec,'f','sfc',1,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%f(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - call halo_exch(int_state%f,1,2,2) -!----------------------------------------------------------------------- -!-- hdacvx - int_state%hdacvx=0. - call getrecn(recname,reclevtyp,reclev,nrec,'hdacvx','sfc',1,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%hdacvx(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - call halo_exch(int_state%hdacvx,1,2,2) -!----------------------------------------------------------------------- -!-- hdacvy - int_state%hdacvy=0. - call getrecn(recname,reclevtyp,reclev,nrec,'hdacvy','sfc',1,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%hdacvy(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - call halo_exch(int_state%hdacvy,1,2,2) -!----------------------------------------------------------------------- -!--pd - int_state%pd=0. - call getrecn(recname,reclevtyp,reclev,nrec,'dpres','hybrid sig lev',1,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%pd(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - call halo_exch(int_state%pd,1,2,2) -!----------------------------------------------------------------------- -!-- pdo - int_state%pdo=0. - call getrecn(recname,reclevtyp,reclev,nrec,'pdo','sfc',1,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%pdo(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - call halo_exch(int_state%pdo,1,2,2) -! -!----------------------------------------------------------------------- -!*** Read from restart file: Real 2D arrays (contd.) -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** ACFRCV -!----------------------------------------------------------------------- - DO J=JMS,JME - DO I=IMS,IME - int_state%ACFRCV(I,J)=0. - ENDDO - ENDDO - call getrecn(recname,reclevtyp,reclev,nrec,'acfrcv','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%ACFRCV(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** ACFRST -!----------------------------------------------------------------------- - DO J=JMS,JME - DO I=IMS,IME - int_state%ACFRST(I,J)=0. - ENDDO - ENDDO - call getrecn(recname,reclevtyp,reclev,nrec,'acfrst','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%ACFRST(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** ACPREC -!----------------------------------------------------------------------- - DO J=JMS,JME - DO I=IMS,IME - int_state%ACPREC(I,J)=0. - ENDDO - ENDDO - call getrecn(recname,reclevtyp,reclev,nrec,'acprec','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%ACPREC(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** ACPREC_TOT -!----------------------------------------------------------------------- - DO J=JMS,JME - DO I=IMS,IME - int_state%ACPREC_TOT(I,J)=0. - ENDDO - ENDDO - call getrecn(recname,reclevtyp,reclev,nrec,'acprec_tot','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%ACPREC_TOT(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** ACSNOM -!----------------------------------------------------------------------- - DO J=JMS,JME - DO I=IMS,IME - int_state%ACSNOM(I,J)=0. - ENDDO - ENDDO - call getrecn(recname,reclevtyp,reclev,nrec,'acsnom','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%ACSNOM(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** ACSNOW -!----------------------------------------------------------------------- - DO J=JMS,JME - DO I=IMS,IME - int_state%ACSNOW(I,J)=0. - ENDDO - ENDDO - call getrecn(recname,reclevtyp,reclev,nrec,'acsnow','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%ACSNOW(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** AKHS_OUT -!----------------------------------------------------------------------- - DO J=JMS,JME - DO I=IMS,IME - int_state%AKHS_OUT(I,J)=0. - ENDDO - ENDDO - call getrecn(recname,reclevtyp,reclev,nrec,'akhs_out','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%AKHS_OUT(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** AKMS_OUT -!----------------------------------------------------------------------- - DO J=JMS,JME - DO I=IMS,IME - int_state%AKMS_OUT(I,J)=0. - ENDDO - ENDDO - call getrecn(recname,reclevtyp,reclev,nrec,'akms_out','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%AKMS_OUT(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** ALBASE -!----------------------------------------------------------------------- - DO J=JMS,JME - DO I=IMS,IME - int_state%ALBASE(I,J)=0. - ENDDO - ENDDO - call getrecn(recname,reclevtyp,reclev,nrec,'albase','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%ALBASE(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** ALBEDO -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'albedo','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%ALBEDO(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** ALWIN -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'alwin','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%ALWIN(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** ALWOUT -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'alwout','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%ALWOUT(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** ALWTOA -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'alwtoa','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%ALWTOA(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** ASWIN -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'aswin','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%ASWIN(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** ASWOUT -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'aswout','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%ASWOUT(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** ASWTOA -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'aswtoa','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%ASWTOA(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** BGROFF -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'bgroff','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%BGROFF(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** CFRACH -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'cfrach','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%CFRACH(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** CFRACL -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'cfracl','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%CFRACL(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** CFRACM -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'cfracm','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%CFRACM(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** CLDEFI -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'cldefi','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%CLDEFI(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** CMC -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'cmc','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%CMC(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** CNVBOT -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'cnvbot','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%CNVBOT(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** CNVTOP -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'cnvtop','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%CNVTOP(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** CPRATE -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'cprate','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%CPRATE(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** CUPPT -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'cuppt','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%CUPPT(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** CUPREC -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'cuprec','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%CUPREC(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** CZEN -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'czen','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%CZEN(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** CZMEAN -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'czmean','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%CZMEAN(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** EPSR -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'epsr','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%EPSR(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** GRNFLX -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'grnflx','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%GRNFLX(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** HBOTD -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'hbotd','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%HBOTD(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** HBOTS -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'hbots','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%HBOTS(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** HTOPD -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'htopd','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%HTOPD(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** HTOPS -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'htops','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%HTOPS(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** SNOW ALBEDO -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'mxsnal','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%MXSNAL(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** PBLH -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'pblh','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%PBLH(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** POTEVP -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'potevp','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%POTEVP(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** PREC -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'prec','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%PREC(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** PSHLTR -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'pshltr','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%PSHLTR(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** Q10 -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'q10','10 m above gnd',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%Q10(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** QSH -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'qsh','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%QSH(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** QSHLTR -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'qshltr','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%QSHLTR(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** QWBS -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'qwbs','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%QWBS(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** QZ0 -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'qz0','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%QZ0(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** RADOT -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'radot','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%RADOT(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** RLWIN -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'rlwin','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%RLWIN(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** RLWTOA -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'rlwtoa','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%RLWTOA(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** RSWIN -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'rswin','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%RSWIN(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** RSWINC -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'rswinc','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%rswinc(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** RSWOUT -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'rswout','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%RSWOUT(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** SFCEVP -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'sfcevp','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SFCEVP(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** SFCEXC -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'sfcexc','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SFCEXC(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** SFCLHX -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'sfclhx','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SFCLHX(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** SFCSHX -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'sfcshx','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SFCSHX(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** SI -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'si','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SI(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** SICE -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'sice','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SICE(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** SIGT4 -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'sigt4','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SIGT4(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** SM (Seamask) -!----------------------------------------------------------------------- - DO J=JMS,JME - DO I=IMS,IME - int_state%SM(I,J)=0. - ENDDO - ENDDO - call getrecn(recname,reclevtyp,reclev,nrec,'sm','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SM(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** SMSTAV -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'smstav','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SMSTAV(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** SMSTOT -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'smstot','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SMSTOT(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** SNO -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'sno','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SNO(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** SNOWC -!----------------------------------------------------------------------- -! - call getrecn(recname,reclevtyp,reclev,nrec,'snowc','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SNOWC(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! -!----------------------------------------------------------------------- -!*** SNOPCX -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'snopcx','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SNOPCX(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** SOILTB -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'soiltb','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SOILTB(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** SR -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'sr','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SR(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** SSROFF -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'ssroff','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SSROFF(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** SST -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'tsea','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SST(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** SUBSHX -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'subshx','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SUBSHX(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** TG -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'tg','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%TG(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** TH10 -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'th10','10 m above gnd',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%TH10(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** THS -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'ths','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%THS(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** THZ0 -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'thz0','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%THZ0(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** TSHLTR -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'tshltr','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%TSHLTR(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** TWBS -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'twbs','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%TWBS(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** U10 -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'u10','10 m above gnd',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%U10(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** USTAR -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'uustar','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%USTAR(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** UZ0 -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'uz0','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%UZ0(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - CALL HALO_EXCH(int_state%UZ0,1,3,3) -!----------------------------------------------------------------------- -!*** V10 -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'v10','10 m above gnd',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%V10(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** VEGFRC -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'vegfrc','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%VEGFRC(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** VZ0 -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'vz0','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%VZ0(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - CALL HALO_EXCH(int_state%VZ0,1,3,3) -!----------------------------------------------------------------------- -!*** Z0 -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'zorl','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%Z0(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - CALL HALO_EXCH(int_state%Z0,1,3,3) -!----------------------------------------------------------------------- -!*** TSKIN -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'tskin','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%TSKIN(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** AKHS -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'akhs','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%AKHS(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** AKMS -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'akms','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%AKMS(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** HBOT -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'hbot','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%HBOT(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** HTOP -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'htop','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%HTOP(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** RSWTOA -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'rswtoa','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%RSWTOA(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** POTFLX -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'potflx','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%POTFLX(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** RMOL -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'rmol','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%RMOL(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** T2 -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'t2','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%T2(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** Z0BASE -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'z0base','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%z0base(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** TLMIN -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'tlmin','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%TLMIN(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** TLMAX -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'tlmax','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%TLMAX(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** ACUTIM -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'acutim','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%ACUTIM(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** APHTIM -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'aphtim','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%APHTIM(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** ARDLW -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'ardlw','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%ARDLW(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** ARDSW -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'ardsw','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%ARDSW(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** ASRFC -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'asrfc','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%ASRFC(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** AVRAIN -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'avrain','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%AVRAIN(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** AVCNVC -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'avcnvc','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%AVCNVC(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** M10RV -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'m10rv','10 m above gnd',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%M10RV(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** M10WIND -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'m10wind','10 m above gnd',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%M10WIND(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** MEMBRANE_MSLP -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'membrane_mslp','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%MEMBRANE_MSLP(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** P500U -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'p500u','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%P500U(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** P500V -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'p500v','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%P500V(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** P700RV -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'p700rv','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%P700RV(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** P700U -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'p700u','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%P700U(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** P700V -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'p700v','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%P700V(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** P700WIND -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'p700wind','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%P700WIND(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** P700Z -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'p700z','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%P700Z(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** P850RV -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'p850rv','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%P850RV(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** P850U -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'p850u','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%P850U(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** P850V -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'p850v','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%P850V(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** P850WIND -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'p850wind','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%P850WIND(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** P850Z -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'p850z','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%P850Z(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** SM10RV -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'sm10rv','10 m above gnd',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SM10RV(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** SM10WIND -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'sm10wind','10 m above gnd',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SM10WIND(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** SMSLP -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'smslp','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SMSLP(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** SP700RV -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'sp700rv','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SP700RV(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** SP700WIND -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'sp700wind','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SP700WIND(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** SP700Z -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'sp700z','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SP700Z(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** SP850RV -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'sp850rv','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SP850RV(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** SP850WIND -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'sp850wind','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SP850WIND(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** SP850Z -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'sp850z','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SP850Z(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** TRACKER_ANGLE -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'tracker_angle','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%tracker_angle(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!*** TRACKER_DISTSQ -!----------------------------------------------------------------------- - call getrecn(recname,reclevtyp,reclev,nrec,'tracker_distsq','sfc',1,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%tracker_distsq(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** Read from restart file: Real 3D arrays (only DYN) -!----------------------------------------------------------------------- -!w - int_state%w=0. - do l=1,lm - call getrecn(recname,reclevtyp,reclev,nrec,'vvel','mid layer',l,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%w(i,j,l)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - enddo - call halo_exch(int_state%w,lm,2,2) -! -!----------------------------------------------------------------------- -!-- dwdt - int_state%dwdt=0. - do l=1,lm - call getrecn(recname,reclevtyp,reclev,nrec,'dwdt','mid layer',l,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%dwdt(i,j,l)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - enddo - call halo_exch(int_state%dwdt,lm,2,2) -!----------------------------------------------------------------------- -!-- pres - int_state%pint=0. - do l=1,lm+1 - call getrecn(recname,reclevtyp,reclev,nrec,'pres','layer',l,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%pint(i,j,l)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - enddo - call halo_exch(int_state%pint,lm+1,2,2) -!----------------------------------------------------------------------- -!-- omgalf - int_state%omgalf=0. - do l=1,lm - call getrecn(recname,reclevtyp,reclev,nrec,'omgalf','mid layer',l,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%omgalf(i,j,l)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - enddo - call halo_exch(int_state%omgalf,lm,2,2) -!----------------------------------------------------------------------- -!-- o3mr - int_state%o3=0. - do l=1,lm - call getrecn(recname,reclevtyp,reclev,nrec,'o3mr','mid layer',l,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%o3(i,j,l)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - enddo - call halo_exch(int_state%o3,lm,2,2) -!----------------------------------------------------------------------- -!-- div - int_state%div=0. - do l=1,lm - call getrecn(recname,reclevtyp,reclev,nrec,'div','mid layer',l,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%div(i,j,l)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - enddo - call halo_exch(int_state%div,lm,2,2) -!----------------------------------------------------------------------- -!-- tcu - int_state%tcu=0. - do l=1,lm - call getrecn(recname,reclevtyp,reclev,nrec,'tcu','mid layer',l,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%tcu(i,j,l)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - enddo - call halo_exch(int_state%tcu,lm,2,2) -!----------------------------------------------------------------------- -!-- tcv - int_state%tcv=0. - do l=1,lm - call getrecn(recname,reclevtyp,reclev,nrec,'tcv','mid layer',l,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%tcv(i,j,l)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - enddo - call halo_exch(int_state%tcv,lm,2,2) -!----------------------------------------------------------------------- -!-- tct - int_state%tct=0. - do l=1,lm - call getrecn(recname,reclevtyp,reclev,nrec,'tct','mid layer',l,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%tct(i,j,l)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - enddo - call halo_exch(int_state%tct,lm,2,2) -!----------------------------------------------------------------------- -!--tp - int_state%tp=0. - do l=1,lm - call getrecn(recname,reclevtyp,reclev,nrec,'tp','mid layer',l,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%tp(i,j,l)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - enddo - call halo_exch(int_state%tp,lm,2,2) -!----------------------------------------------------------------------- -!-- up - int_state%up=0. - do l=1,lm - call getrecn(recname,reclevtyp,reclev,nrec,'up','mid layer',l,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%up(i,j,l)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - enddo - call halo_exch(int_state%up,lm,2,2) -!----------------------------------------------------------------------- -!-- vp - int_state%vp=0. - do l=1,lm - call getrecn(recname,reclevtyp,reclev,nrec,'vp','mid layer',l,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%vp(i,j,l)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - enddo - call halo_exch(int_state%vp,lm,2,2) -!----------------------------------------------------------------------- -!-- z - int_state%z=0. - do l=1,lm - call getrecn(recname,reclevtyp,reclev,nrec,'z','mid layer',l,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%z(i,j,l)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - enddo - call halo_exch(int_state%z,lm,2,2) -!----------------------------------------------------------------------- -! - DO K=1,LM -! - DO J=JMS,JME - DO I=IMS,IME - int_state%Told(I,J,K)=0. - ENDDO - ENDDO - call getrecn(recname,reclevtyp,reclev,nrec,'told','mid layer',k,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%Told(i,j,k)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! - ENDDO -!----------------------------------------------------------------------- -! - DO K=1,LM -! - DO J=JMS,JME - DO I=IMS,IME - int_state%Tadj(I,J,K)=0. - ENDDO - ENDDO - call getrecn(recname,reclevtyp,reclev,nrec,'tadj','mid layer',k,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%Tadj(i,j,k)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! - ENDDO -!----------------------------------------------------------------------- -! - DO K=1,LM -! - DO J=JMS,JME - DO I=IMS,IME - int_state%CLDFRA(I,J,K)=0. - ENDDO - ENDDO - call getrecn(recname,reclevtyp,reclev,nrec,'cldfra','mid layer',k,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%CLDFRA(i,j,k)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! - ENDDO -!----------------------------------------------------------------------- -! - DO K=1,LM -! - DO J=JMS,JME - DO I=IMS,IME - int_state%Q2(I,J,K)=0. - ENDDO - ENDDO - call getrecn(recname,reclevtyp,reclev,nrec,'q2','mid layer',k,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%Q2(i,j,k)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - - ENDDO - CALL HALO_EXCH(int_state%Q2,LM,2,2) -!----------------------------------------------------------------------- -! - DO K=1,LM -! - DO J=JMS,JME - DO I=IMS,IME - int_state%RLWTT(I,J,K)=0. - ENDDO - ENDDO - call getrecn(recname,reclevtyp,reclev,nrec,'rlwtt','mid layer',k,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%RLWTT(i,j,k)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! - ENDDO -!----------------------------------------------------------------------- -! - DO K=1,LM -! - DO J=JMS,JME - DO I=IMS,IME - int_state%RSWTT(I,J,K)=0. - ENDDO - ENDDO - call getrecn(recname,reclevtyp,reclev,nrec,'rswtt','mid layer',k,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%RSWTT(i,j,k)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! - ENDDO -!----------------------------------------------------------------------- -! - DO K=1,LM -! - DO J=JMS,JME - DO I=IMS,IME - int_state%T(I,J,K)=0. - ENDDO - ENDDO - call getrecn(recname,reclevtyp,reclev,nrec,'tmp','mid layer',k,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%T(i,j,k)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! - ENDDO - CALL HALO_EXCH(int_state%T,LM,2,2) -!----------------------------------------------------------------------- -! - DO K=1,LM -! - DO J=JMS,JME - DO I=IMS,IME - int_state%TCUCN(I,J,K)=0. - ENDDO - ENDDO - call getrecn(recname,reclevtyp,reclev,nrec,'tcucn','mid layer',k,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%TCUCN(i,j,k)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! - ENDDO -!----------------------------------------------------------------------- -! - DO K=1,LM -! - DO J=JMS,JME - DO I=IMS,IME - int_state%TRAIN(I,J,K)=0. - ENDDO - ENDDO - call getrecn(recname,reclevtyp,reclev,nrec,'train','mid layer',k,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%TRAIN(i,j,k)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! - ENDDO -!----------------------------------------------------------------------- -! - DO K=1,LM -! - DO J=JMS,JME - DO I=IMS,IME - int_state%U(I,J,K)=0. - ENDDO - ENDDO - call getrecn(recname,reclevtyp,reclev,nrec,'ugrd','mid layer',k,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%U(i,j,k)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! - ENDDO - CALL HALO_EXCH(int_state%U,LM,2,2) -!----------------------------------------------------------------------- -! - DO K=1,LM -! - DO J=JMS,JME - DO I=IMS,IME - int_state%V(I,J,K)=0. - ENDDO - ENDDO - call getrecn(recname,reclevtyp,reclev,nrec,'vgrd','mid layer',k,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%V(i,j,k)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! - ENDDO - CALL HALO_EXCH(int_state%V,LM,2,2) -!----------------------------------------------------------------------- -! - DO K=1,LM -! - DO J=JMS,JME - DO I=IMS,IME - int_state%XLEN_MIX(I,J,K)=0. - ENDDO - ENDDO - call getrecn(recname,reclevtyp,reclev,nrec,'xlen_mix','mid layer',k,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%XLEN_MIX(i,j,k)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! - ENDDO -!----------------------------------------------------------------------- -! - DO K=1,LM -! - DO J=JMS,JME - DO I=IMS,IME - int_state%F_ICE(I,J,K)=0. - ENDDO - ENDDO - call getrecn(recname,reclevtyp,reclev,nrec,'f_ice','mid layer',k,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%F_ICE(i,j,k)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! - ENDDO -!----------------------------------------------------------------------- -! - DO K=1,LM -! - DO J=JMS,JME - DO I=IMS,IME - int_state%F_RIMEF(I,J,K)=0. - ENDDO - ENDDO - call getrecn(recname,reclevtyp,reclev,nrec,'f_rimef','mid layer',k,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%F_RIMEF(i,j,k)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! - ENDDO -!----------------------------------------------------------------------- -! - DO K=1,LM -! - DO J=JMS,JME - DO I=IMS,IME - int_state%F_RAIN(I,J,K)=0. - ENDDO - ENDDO - call getrecn(recname,reclevtyp,reclev,nrec,'f_rain','mid layer',k,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%F_RAIN(i,j,k)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! - ENDDO -!----------------------------------------------------------------------- -! - DO K=1,LM -! - DO J=JMS,JME - DO I=IMS,IME - int_state%REFL_10CM(I,J,K)=DBZmin - ENDDO - ENDDO - call getrecn(recname,reclevtyp,reclev,nrec,'refl_10cm','mid layer',k,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%REFL_10CM(i,j,k)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! - ENDDO -!----------------------------------------------------------------------- -!*** Radar-derived T tendencies from GSI analysis -!----------------------------------------------------------------------- -! - if(int_state%RADAR_INIT==1) then - DO K=1,LM -! - DO J=JMS,JME - DO I=IMS,IME - int_state%DFI_TTEN(I,J,K)=0. - ENDDO - ENDDO - call getrecn(recname,reclevtyp,reclev,nrec,'dfi_tten','mid layer',k,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - if(tmp(i-its+1+js+fldst)>0.0 .and. tmp(i-its+1+js+fldst)<0.1)then - int_state%DFI_TTEN(i,j,k)=tmp(i-its+1+js+fldst)*1.00 - end if - enddo - enddo - endif -! - ENDDO - end if -! -!----------------------------------------------------------------------- -!*** SH2O, SMC, STC -!----------------------------------------------------------------------- -! - DO K=1,int_state%NSOIL -! - call getrecn(recname,reclevtyp,reclev,nrec,'sh2o','soil layer',k,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SH2O(i,j,k)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - - call getrecn(recname,reclevtyp,reclev,nrec,'smc','soil layer',k,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%SMC(i,j,k)=tmp(i-its+1+js+fldst) - enddo - enddo - endif -! - call getrecn(recname,reclevtyp,reclev,nrec,'stc','soil layer',k,recn) - if(recn>0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%STC(i,j,k)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - - ENDDO - - -!-- tracers_prev - do n=1,int_state%num_tracers_total - int_state%tracers_prev(:,:,:,n)=0. - write(tn,'(I3.3)')n - do l=1,lm - call getrecn(recname,reclevtyp,reclev,nrec,'tracers_prev_'//tn, & - 'mid layer',l,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%tracers_prev(i,j,l,n)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - enddo - enddo - call halo_exch(int_state%tracers_prev,lm,int_state%num_tracers_total,1,2,2) -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Read from restart file: Real 2D arrays (contd.) -!----------------------------------------------------------------------- -! -!-- sice - int_state%sice=0. - call getrecn(recname,reclevtyp,reclev,nrec,'sice','sfc',1,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%sice(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - call halo_exch(int_state%sice,1,2,2) -!----------------------------------------------------------------------- -!-- sm - int_state%sm=0. - call getrecn(recname,reclevtyp,reclev,nrec,'sm','sfc',1,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%sm(i,j)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - call halo_exch(int_state%sm,1,2,2) -! -!----------------------------------------------------------------------- -!*** Read from restart file: Real 3D arrays -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!-- cw - int_state%cw=0. - do l=1,lm - call getrecn(recname,reclevtyp,reclev,nrec,'clwmr','mid layer',l,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%cw(i,j,l)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - enddo - call halo_exch(int_state%cw,lm,2,2) -! write(0,*)'in init restart after2,clwmr =',maxval(cw),minval(cw) -!----------------------------------------------------------------------- -!-- spfh - int_state%q=0. - do l=1,lm - call getrecn(recname,reclevtyp,reclev,nrec,'spfh','mid layer',l,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%q(i,j,l)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - enddo - call halo_exch(int_state%q,lm,2,2) -!----------------------------------------------------------------------- -!-- q2 - int_state%q2=0. - do l=1,lm - call getrecn(recname,reclevtyp,reclev,nrec,'q2','mid layer',l,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%q2(i,j,l)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - enddo - call halo_exch(int_state%q2,lm,2,2) -!----------------------------------------------------------------------- -!-- t - int_state%t=0. - do l=1,lm - call getrecn(recname,reclevtyp,reclev,nrec,'tmp','mid layer',l,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%t(i,j,l)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - enddo - call halo_exch(int_state%t,lm,2,2) -!----------------------------------------------------------------------- -!-- u - int_state%u=0. - do l=1,lm - call getrecn(recname,reclevtyp,reclev,nrec,'ugrd','mid layer',l,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%u(i,j,l)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - enddo - call halo_exch(int_state%u,lm,2,2) -!----------------------------------------------------------------------- -!-- v - int_state%v=0. - do l=1,lm - call getrecn(recname,reclevtyp,reclev,nrec,'vgrd','mid layer',l,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%v(i,j,l)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - enddo - call halo_exch(int_state%v,lm,2,2) -!----------------------------------------------------------------------- -!-- rest of tracers - int_state%tracers(:,:,:,int_state%indx_q2+1:int_state%num_tracers_total)=0. - do n=int_state%indx_q2+1,int_state%num_tracers_total !<-- The first 'indx_q2' arrays are unallocated pointers - write(tn,'(I3.3)')n - do l=1,lm - call getrecn(recname,reclevtyp,reclev,nrec,'tracers_'//tn, & - 'mid layer',l,recn) - if(recn/=0) then - fldst=(recn-1)*fldsize - do j=jts,jte - js=(j-jts)*(ite-its+1) - do i=its,ite - int_state%tracers(i,j,l,n)=tmp(i-its+1+js+fldst) - enddo - enddo - endif - enddo - enddo - call halo_exch(int_state%tracers,lm,int_state%num_tracers_total,1,2,2) -!----------------------------------------------------------------------- -! - tend_max=real(int_state%ihrend) - ntstm_max=nint(tend_max*3600./int_state%dt)+1 - tend=real(int_state%nhours_fcst) - int_state%ntstm=nint(tend*3600./int_state%dt)+1 - if(.not.int_state%global)then - if(mype==0)then - write(0,*)' Max runtime is ',tend_max,' hours' - endif - endif - if(mype==0)then - write(0,*)' Requested runtime is ',tend,' hours' - write(0,*)' NTSTM=',int_state%ntstm - endif - if(int_state%ntstm>ntstm_max.and..not.int_state%global)then - if(mype==0)then - write(0,*)' Requested fcst length exceeds maximum' - write(0,*)' Resetting to maximum' - endif - int_state%ntstm=min(int_state%ntstm,ntstm_max) - endif -! - ntsd=0 - int_state%ihr=nint(ntsd*int_state%dt/3600.) -!----------------------------------------------------------------------- - do l=1,lm - int_state%pdsg1(l)=int_state%dsg1(l)*int_state%pdtop - int_state%psgml1(l)=int_state%sgml1(l)*int_state%pdtop+int_state%pt - enddo -! - do l=1,lm+1 - int_state%psg1(l)=int_state%sg1(l)*int_state%pdtop+int_state%pt - enddo -!----------------------------------------------------------------------- - endif read_blocks ! cold start /restart -!----------------------------------------------------------------------- -! - deallocate(tmp) -! -!----------------------------------------------------------------------- -! - end subroutine read_nemsio -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE getrecn(recname,reclevtyp,reclev,nrec,fldname, & - fldlevtyp,fldlev,recn) -!----------------------------------------------------------------------- -!-- this subroutine searches the field list to find out a specific field, -!-- and return the field number for that field -!----------------------------------------------------------------------- -! - implicit none -! - integer,intent(in) :: nrec - character(*),intent(in) :: recname(nrec) - character(*),intent(in) :: reclevtyp(nrec) - integer,intent(in) :: reclev(nrec) - character(*),intent(in) :: fldname - character(*),intent(in) :: fldlevtyp - integer,intent(in) :: fldlev - integer,intent(out) :: recn -! - integer i -! - recn=0 - do i=1,nrec - if(trim(recname(i))==trim(fldname).and. & - trim(reclevtyp(i))==trim(fldlevtyp) .and. & - reclev(i)==fldlev) then - recn=i - return - endif - enddo -! - if(recn==0) print *,'WARNING: field ',trim(fldname),' ', & - trim(fldlevtyp),' ',fldlev,' is not in the nemsio file!' -! -!----------------------------------------------------------------------- -! - END SUBROUTINE getrecn -! -!----------------------------------------------------------------------- -! - end module module_INIT_READ_NEMSIO -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- diff --git a/src/nmm/module_MICROPHYSICS.F90 b/src/nmm/module_MICROPHYSICS.F90 deleted file mode 100644 index b55cef4..0000000 --- a/src/nmm/module_MICROPHYSICS.F90 +++ /dev/null @@ -1,565 +0,0 @@ -!----------------------------------------------------------------------- -! - MODULE MODULE_MICROPHYSICS_NMM -! -!----------------------------------------------------------------------- -! -!*** THE MICROPHYSICS DRIVERS AND PACKAGES - -! 11-06-2009 W. Wang put NAM micorphysics into a single module -! 02-10-2010 W. Wang added wsm6 -!----------------------------------------------------------------------- -! -! HISTORY LOG: -! -! 11-06-2009 W. Wang - Put NAM/Ferrier microphysics into -! a single module. -! -!----------------------------------------------------------------------- -! - USE MODULE_KINDS -! - USE MODULE_CONSTANTS,ONLY : CICE,CLIQ,CPV,EP_1,EP_2,EPSILON,G & - ,P608,PSAT,R_D,R_V,RHOAIR0,RHOWATER & - ,SVPT0,XLF,XLV & - ,CAPPA,CP,EPSQ -! - USE MODULE_CONTROL,ONLY : NMMB_FINALIZE -! MP options - USE MODULE_MP_ETANEW - USE MODULE_MP_FER_HIRES - USE MODULE_MP_WSM6 - USE MODULE_MP_THOMPSON - USE MODULE_MP_GFS -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - PRIVATE -! -! PUBLIC :: FERRIER_INIT,FPVS,GSMDRIVE,WSM3INIT - PUBLIC :: GSMDRIVE -! -!----------------------------------------------------------------------- -! - INTEGER :: MYPE - REAL, PRIVATE,PARAMETER :: & -!--- Physical constants follow: - XLS=2.834E6,R_G=1./G -! - INTEGER,PUBLIC,PARAMETER :: MICRO_RESTART=7501 -! - CONTAINS -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- - SUBROUTINE GSMDRIVE(ITIMESTEP,DT,NPHS & - ,DX,DY,SM,FIS & - ,DSG2,SGML2,PDSG1,PSGML1,PT,PD & - ,T,Q,CWM,OMGALF & - ,TRAIN,SR & - ,F_ICE,F_RAIN,F_RIMEF & - ,QC,QR,QI,QS,QG,NI,NR & - ,F_QC,F_QR,F_QI,F_QS,F_QG,F_NI,F_NR & - ,PREC,ACPREC,AVRAIN,ACPREC_TOT & - ,acpcp_ra,acpcp_sn,acpcp_gr, refl_10cm & - ,re_cloud,re_ice,re_snow & - ,has_reqc,has_reqi,has_reqs & - ,MP_RESTART_STATE & - ,TBPVS_STATE,TBPVS0_STATE & - ,SPECIFIED,NESTED & - ,MICROPHYSICS & - ,RHGRD & - ,TP1,QP1,PSP1 & - ,USE_RADAR & - ,DFI_TTEN & - ,IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE & - ,ITS_B1,ITE_B1,JTS_B1,JTE_B1,MPRATES,D_SS) -!*********************************************************************** -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: GSMDRIVE MICROPHYSICS OUTER DRIVER -! PRGRMMR: BLACK ORG: W/NP22 DATE: 02-03-26 -! -! ABSTRACT: -! RADIATION SERVES AS THE INTERFACE BETWEEN THE NMMB PHYSICS COMPONENT -! AND THE WRF MICROPHYSICS DRIVER. -! -! PROGRAM HISTORY LOG: -! 02-03-26 BLACK - ORIGINATOR -! 04-11-18 BLACK - THREADED -! 06-07-31 BLACK - BUILT INTO NMMB PHYSICS COMPONENT -! 08-08 JANJIC - Synchronize WATER array and Q. -! -! USAGE: CALL GSMDRIVE FROM PHY_RUN -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE : IBM -!$$$ -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER,INTENT(IN) :: D_SS,ITIMESTEP,NPHS & - ,IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE & - ,ITS_B1,ITE_B1,JTS_B1,JTE_B1 -! - LOGICAL,INTENT(IN) :: USE_RADAR -! - REAL,INTENT(IN) :: DT,DX,DY,PT,RHGRD -! - REAL,DIMENSION(IMS:IME,JMS:JME,1:LM,D_SS) :: MPRATES -! - REAL,DIMENSION(1:LM),INTENT(IN) :: DSG2,PDSG1,PSGML1,SGML2 -! - REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: FIS,PD,SM -! - REAL,DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(IN) :: OMGALF & - ,DFI_TTEN -! - REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: ACPREC,PREC & - ,ACPREC_TOT & - ,AVRAIN !<-- Was a scalar -! G. Thompson added next 4 lines. - REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: acpcp_ra,acpcp_sn,acpcp_gr - REAL,DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(INOUT) :: refl_10cm - REAL,DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(INOUT) :: re_cloud, re_ice, re_snow - INTEGER,INTENT(IN):: has_reqc, has_reqi, has_reqs -! - REAL,DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(INOUT) :: CWM,Q,T & - ,TRAIN -! - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER,INTENT(INOUT) :: & - & QC,QI,QR,QS,QG,NI,NR -! - REAL,DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(INOUT) :: F_ICE & - ,F_RAIN & - ,F_RIMEF -! - REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: SR -! - CHARACTER(99),INTENT(IN) :: MICROPHYSICS -! - LOGICAL,INTENT(IN) :: NESTED,SPECIFIED -! - LOGICAL,INTENT(IN) :: F_QC,F_QR,F_QI,F_QS,F_QG,F_NI,F_NR -! -!*** State Variables for ETAMPNEW Microphysics -! - REAL,DIMENSION(:),INTENT(INOUT) :: MP_RESTART_STATE & - ,TBPVS_STATE,TBPVS0_STATE -!*** GFS microphysics - REAL, DIMENSION(IMS:IME,JMS:JME,1:LM), INTENT(INOUT) :: TP1,QP1 - REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(INOUT) :: PSP1 -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER :: I,IJ,J,K,MP_PHYSICS,N,NTSD - INTEGER :: ITSLOC,ITELOC,JTSLOC,JTELOC -! - INTEGER,DIMENSION(IMS:IME,JMS:JME) :: LOWLYR -! - REAL :: DPL,DTPHS,PCPCOL,PDSL,PHMID,QW,RDTPHS,TNEW - REAL :: MP_TTEN,mytten -! - REAL,DIMENSION(1:LM) :: QL,TL -! - REAL,DIMENSION(IMS:IME,JMS:JME) :: CUBOT,CUTOP,RAINNC,RAINNCV & - ,SNOWNC,SNOWNCV,XLAND & - ,graupelnc,graupelncv -! - REAL,DIMENSION(IMS:IME,JMS:JME,1:LM) :: DZ & - ,P_PHY,PI_PHY & - ,RR,TH_PHY,QV -! - LOGICAL :: WARM_RAIN,F_QT,USE_QV -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - NTSD=ITIMESTEP - DTPHS=NPHS*DT - RDTPHS=1./DTPHS -! -!-- AVRAIN was a scalar but changed to a 2D array to allow for updates in ESMF -! - DO J=JTS,JTE - DO I=ITS,ITE - AVRAIN(I,J)=AVRAIN(I,J)+1. - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** NOTE: THE NMMB HAS IJK STORAGE WITH LAYER 1 AT THE TOP. -!*** THE WRF PHYSICS DRIVERS HAVE IKJ STORAGE WITH LAYER 1 -!*** AT THE BOTTOM. -!----------------------------------------------------------------------- -! -!!! DO J=JTS_B1,JTE_B1 -!!! DO I=ITS_B1,ITE_B1 -!....................................................................... -!$omp parallel do & -!$omp& private(j,i,k,pdsl,dpl,phmid,ql,tl) -!....................................................................... - DO J=JTS,JTE - DO I=ITS,ITE -! - PDSL=PD(I,J) - LOWLYR(I,J)=1 - XLAND(I,J)=SM(I,J)+1. -! -!----------------------------------------------------------------------- -!*** FILL RAINNC WITH ZERO (NORMALLY CONTAINS THE NONCONVECTIVE -!*** ACCUMULATED RAIN BUT NOT YET USED BY NMM) -!*** COULD BE OBTAINED FROM ACPREC AND CUPREC (ACPREC-CUPREC) -!----------------------------------------------------------------------- -!..The NC variables were designed to hold simulation total accumulations -!.. whereas the NCV variables hold timestep only values, so change below -!.. to zero out only the timestep amount preparing to go into each -!.. micro routine while allowing NC vars to accumulate continually. -!.. But, the fact is, the total accum variables are local, never saved -!.. nor written so they go nowhere at the moment. -! - RAINNC (I,J)=0. ! NOT YET USED BY NMM - RAINNCv(I,J)=0. - SNOWNCv(I,J)=0. - graupelncv(i,j) = 0.0 -! -!----------------------------------------------------------------------- -!*** FILL THE SINGLE-COLUMN INPUT -!----------------------------------------------------------------------- -! - DO K=LM,1,-1 ! We are moving down from the top in the flipped arrays -! - DPL=DSG2(K)*PDSL+PDSG1(K) - PHMID=SGML2(K)*PDSL+PSGML1(K) - TL(K)=T(I,J,K) - QL(K)=AMAX1(Q(I,J,K),EPSQ) -! - RR(I,J,K)=PHMID/(R_D*TL(K)*(P608*QL(K)+1.)) - PI_PHY(I,J,K)=(PHMID*1.E-5)**CAPPA - TH_PHY(I,J,K)=TL(K)/PI_PHY(I,J,K) - P_PHY(I,J,K)=PHMID - DZ(I,J,K)=DPL*R_G/RR(I,J,K) -! - ENDDO !- DO K=LM,1,-1 -! - ENDDO !- DO I=ITS,ITE - ENDDO !- DO J=JTS,JTE -!....................................................................... -!$omp end parallel do -!....................................................................... -! -!----------------------------------------------------------------------- -!*** IF NEEDED, UPDATE WATER VAPOR RATIO FROM SPECIFIC HUMIDITY. -!----------------------------------------------------------------------- -! - IF(TRIM(MICROPHYSICS)=='wsm6' .OR. TRIM(MICROPHYSICS)=='thompson')THEN - USE_QV=.TRUE. !-- Initialize QV, update Q & CWM at the end - ELSE - USE_QV=.FALSE. - ENDIF -! - IF(USE_QV) THEN -!....................................................................... -!$omp parallel do & -!$omp& private(i,j,k) -!....................................................................... - DO K=1,LM - DO J=JTS_B1,JTE_B1 - DO I=ITS_B1,ITE_B1 - QV(I,J,K)=Q(I,J,K)/(1.-Q(I,J,K)) - ENDDO - ENDDO - ENDDO -!....................................................................... -!$omp end parallel do -!....................................................................... - ENDIF -! -!----------------------------------------------------------------------- -! -!*** CALL MICROPHYSICS -! -!----------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------- -!*** TRANSLATE THE MICROPHYSICS OPTIONS IN THE CONFIG FILE TO THEIR -!*** ANALOGS IN THE WRF REGISTRY SO THAT THE WRF MICROPHYSICS DRIVER -!*** REMAINS UNTOUCHED. -!----------------------------------------------------------------------- -! -! SELECT CASE (TRIM(MICROPHYSICS)) -! CASE ('fer') -! MP_PHYSICS=5 -! CASE ('kes') -! MP_PHYSICS=1 -! CASE ('lin') -! MP_PHYSICS=2 -! CASE ('wsm3') -! MP_PHYSICS=3 -! CASE ('tho') -! MP_PHYSICS=8 -! CASE DEFAULT -! WRITE(0,*)' User selected MICROPHYSICS=',MICROPHYSICS -! WRITE(0,*)' Improper selection of Microphysics scheme in GSMDRIVE' -!!! CALL ESMF_Finalize(endflag=ESMF_END_ABORT) -! CALL NMMB_FINALIZE -! END SELECT -! -!--------------------------------------------------------------------- -! Check for microphysics type. We need a clean way to -! specify these things! -!--------------------------------------------------------------------- - - - ITSLOC = MAX(ITS_B1,IDS) - ITELOC = MIN(ITE_B1,IDE-1) - JTSLOC = MAX(JTS_B1,JDS) - JTELOC = MIN(JTE_B1,JDE-1) - - micro_select: SELECT CASE (TRIM(MICROPHYSICS)) -! - CASE ('fer') - CALL ETAMP_NEW( & - ITIMESTEP=ntsd,DT=dtphs,DX=dx,DY=dy & - ,DZ8W=dz,RHO_PHY=rr,P_PHY=p_phy,PI_PHY=pi_phy,TH_PHY=th_phy & - ,Q=Q & - ,QC=QC & - ,QS=QS & - ,QR=QR & - ,QT=cwm & - ,LOWLYR=LOWLYR,SR=SR & - ,F_ICE_PHY=F_ICE,F_RAIN_PHY=F_RAIN & - ,F_RIMEF_PHY=F_RIMEF & - ,RAINNC=rainnc,RAINNCV=rainncv & - ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=1,KDE=LM+1 & - ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=1,KME=LM & - ,ITS=itsloc,ITE=iteloc, JTS=jtsloc,JTE=jteloc, KTS=1,KTE=LM & - ,MP_RESTART_STATE=mp_restart_state & - ,TBPVS_STATE=tbpvs_state,TBPVS0_STATE=tbpvs0_state & - ,D_SS=d_ss,MPRATES=mprates & - ) - CASE ('fer_hires') - CALL FER_HIRES( & - ITIMESTEP=ntsd,DT=dtphs,DX=dx,DY=dy,RHgrd=RHGRD & - ,DZ8W=dz,RHO_PHY=rr,P_PHY=p_phy,PI_PHY=pi_phy,TH_PHY=th_phy & - ,Q=Q & - ,QC=QC & - ,QS=QS & - ,QR=QR & - ,QT=cwm & - ,LOWLYR=LOWLYR,SR=SR & - ,F_ICE_PHY=F_ICE,F_RAIN_PHY=F_RAIN & - ,F_RIMEF_PHY=F_RIMEF & - ,RAINNC=rainnc,RAINNCV=rainncv & - ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=1,KDE=LM+1 & - ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=1,KME=LM & - ,ITS=itsloc,ITE=iteloc, JTS=jtsloc,JTE=jteloc, KTS=1,KTE=LM & - ,MP_RESTART_STATE=mp_restart_state & - ,TBPVS_STATE=tbpvs_state,TBPVS0_STATE=tbpvs0_state & - ,D_SS=d_ss,MPRATES=mprates & - ,refl_10cm=refl_10cm & - ) - CASE ('gfs') - CALL GFSMP(DT=dtphs, & - dz8w=dz,rho_phy=rr,p_phy=p_phy,pi_phy=pi_phy,th_phy=th_phy, & - SR=SR,QT=CWM, F_ICE_PHY=F_ICE, & - RAINNC=RAINNC,RAINNCV=RAINNCV, & - Q=Q,QC=QC,QI=QI, & - F_QC=F_QC,F_QI=F_QI, & - TP1=TP1,QP1=QP1,PSP1=PSP1, & - IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=1,KDE=LM+1, & - IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=1,KME=LM , & - ITS=itsloc,ITE=iteloc, JTS=jtsloc,JTE=jteloc, KTS=1,KTE=LM ) - CASE ('wsm6') - CALL wsm6( & - TH=th_phy & - ,Q=QV & - ,QC=QC & - ,QR=QR & - ,QI=QI & - ,QS=QS & - ,QG=QG & - ,DEN=rr,PII=pi_phy,P=p_phy,DELZ=dz & - ,DELT=dtphs,G=g,CPD=cp,CPV=cpv & - ,RD=r_d,RV=r_v,T0C=svpt0 & - ,EP1=ep_1, EP2=ep_2, QMIN=epsilon & - ,XLS=xls, XLV0=xlv, XLF0=xlf & - ,DEN0=rhoair0, DENR=rhowater & - ,CLIQ=cliq,CICE=cice,PSAT=psat & - ,RAIN=rainnc ,RAINNCV=rainncv & - ,SNOW=snownc ,SNOWNCV=snowncv & - ,SR=sr & - ,GRAUPEL=graupelnc ,GRAUPELNCV=graupelncv & - ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=1,KDE=LM+1 & - ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=1,KME=LM & - ,ITS=itsloc,ITE=iteloc, JTS=jtsloc,JTE=jteloc, KTS=1,KTE=LM & - ,D_SS=d_ss,MPRATES=mprates) - CASE ('thompson') -!+---+-----------------------------------------------------------------+ -! write(6,*)'DEBUG-GT, calling mp_gt_driver' - CALL mp_gt_driver( & - qv=qv & - ,qc=qc & - ,qr=qr & - ,qi=qi & - ,qs=qs & - ,qg=qg & - ,ni=ni & - ,nr=nr & - ,TH=th_phy,PII=pi_phy,P=p_phy,dz=dz,dt_in=dtphs & - ,itimestep=ntsd & - ,RAINNC=rainnc ,RAINNCV=rainncv & - ,SNOWNC=snownc ,SNOWNCV=snowncv & - ,GRAUPELNC=graupelnc ,GRAUPELNCV=graupelncv & - ,SR=sr & - ,refl_10cm=refl_10cm(ims,jms,1) & - ,diagflag=.true. & - ,do_radar_ref=1 & - ,re_cloud=re_cloud(ims,jms,1) & - ,re_ice=re_ice(ims,jms,1) & - ,re_snow=re_snow(ims,jms,1) & - ,has_reqc=has_reqc & - ,has_reqi=has_reqi & - ,has_reqs=has_reqs & - ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=1,KDE=LM+1 & - ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=1,KME=LM & - ,ITS=itsloc,ITE=iteloc, JTS=jtsloc,JTE=jteloc, KTS=1,KTE=LM & - ,D_SS=d_ss,MPRATES=mprates ) -! -!..rainncv is actually all precip, so need to subtract snow/graupel to isolate rain only -! - DO J=JMS,JME - DO I=IMS,IME - acpcp_sn(I,J) = acpcp_sn(I,J) + snowncv(i,j) - acpcp_gr(I,J) = acpcp_gr(I,J) + graupelncv(i,j) - acpcp_ra(I,J) = acpcp_ra(I,J) & - + MAX(0., rainncv(i,j)-snowncv(i,j)-graupelncv(i,j)) - ENDDO - ENDDO -!+---+-----------------------------------------------------------------+ - - CASE DEFAULT - WRITE(0,*)' The microphysics option does not exist: MICROPHYSICS = ',TRIM(MICROPHYSICS) - CALL NMMB_FINALIZE - - END SELECT micro_select - -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** THE FOLLOWING MUST BE RECONCILED WHEN THREADING IS TURNED ON. -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!jaa!$omp parallel do & -!jaa!$omp& private(ij) -! DO IJ=1,NUM_TILES -! CALL MICROPHYSICS_ZERO_OUT( & -! WATER,N_MOIST,CONFIG_FLAGS & -! ,IDS,IDE,JDS,JDE,KDS,KDE & -! ,IMS,IME,JMS,JME,KMS,KME & -! ,GRID%I_START(IJ),GRID%I_END(IJ) & -! ,GRID%J_START(IJ),GRID%J_END(IJ) & -! ,KTS,KTE ) -! ENDDO -! -!----------------------------------------------------------------------- -! - IF(USE_QV) THEN !-- Update Q & CWM for WSM6 & Thompson microphysics -!....................................................................... -!$omp parallel do & -!$omp& private(i,j,k) -!....................................................................... - DO K=1,LM - DO J=JTS_B1,JTE_B1 - DO I=ITS_B1,ITE_B1 - Q(I,J,K)=QV(I,J,K)/(1.+QV(I,J,K)) - CWM(I,J,K)=QC(i,j,k)+QR(i,j,k)+QI(i,j,k)+QS(i,j,k)+QG(i,j,k) - ENDDO - ENDDO - ENDDO -!....................................................................... -!$omp end parallel do -!....................................................................... - ENDIF -! -!....................................................................... -!$omp parallel do & -!$omp& private(i,j,k,TNEW,MP_TTEN) -!....................................................................... - DO K=1,LM - DO J=JTS_B1,JTE_B1 - DO I=ITS_B1,ITE_B1 -! -!----------------------------------------------------------------------- -!*** UPDATE TEMPERATURE, SPECIFIC HUMIDITY, CLOUD WATER, AND HEATING. -!----------------------------------------------------------------------- -! - TNEW=TH_PHY(I,J,K)*PI_PHY(I,J,K) - TRAIN(I,J,K)=TRAIN(I,J,K)+(TNEW-T(I,J,K))*RDTPHS - IF (USE_RADAR) THEN - MP_TTEN=(TNEW-T(I,J,K))*RDTPHS - IF(DFI_TTEN(I,J,K)>MP_TTEN.AND.DFI_TTEN(I,J,K)<0.01 & - .AND.MP_TTEN<0.0018)THEN - MP_TTEN=DFI_TTEN(I,J,K) - END IF - T(I,J,K)=T(I,J,K)+MP_TTEN/RDTPHS - ELSE - T(I,J,K)=TNEW - ENDIF - ENDDO - ENDDO - ENDDO -!....................................................................... -!$omp end parallel do -!....................................................................... -! -!----------------------------------------------------------------------- -!*** UPDATE PRECIPITATION -!----------------------------------------------------------------------- -! -!jaa!$omp parallel do & -!jaa!$omp& private(i,j,pcpcol) - DO J=JTS_B1,JTE_B1 - DO I=ITS_B1,ITE_B1 - PCPCOL=RAINNCV(I,J)*1.E-3 - PREC(I,J)=PREC(I,J)+PCPCOL - ACPREC(I,J)=ACPREC(I,J)+PCPCOL - ACPREC_TOT(I,J)=ACPREC_TOT(I,J)+PCPCOL -! -! NOTE: RAINNC IS ACCUMULATED INSIDE MICROPHYSICS BUT NMM ZEROES IT OUT ABOVE -! SINCE IT IS ONLY A LOCAL ARRAY FOR NOW -! - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -! - END SUBROUTINE GSMDRIVE -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- - - END MODULE MODULE_MICROPHYSICS_NMM - -!----------------------------------------------------------------------- diff --git a/src/nmm/module_MY_DOMAIN_SPECS.F90 b/src/nmm/module_MY_DOMAIN_SPECS.F90 deleted file mode 100644 index 9b3d8dc..0000000 --- a/src/nmm/module_MY_DOMAIN_SPECS.F90 +++ /dev/null @@ -1,216 +0,0 @@ -!----------------------------------------------------------------------- -! - MODULE MODULE_MY_DOMAIN_SPECS -! -!----------------------------------------------------------------------- -! -!*** Set and hold key domain/subdomain dimensions, the forecast task -!*** intracommunicator, and task rank within that communicator for -!*** the currently active domain. -! -!----------------------------------------------------------------------- -! - USE MODULE_KINDS -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - PUBLIC -! - INTEGER(kind=KINT),SAVE :: IDS,IDE,JDS,JDE & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE & - ,ITS_B1,ITE_B1,ITS_B2,ITE_B2 & - ,ITS_B1_H1,ITE_B1_H1,ITE_B1_H2 & - ,ITS_B1_H2 & - ,ITS_H1,ITE_H1,ITS_H2,ITE_H2 & - ,JTS_B1,JTE_B1,JTS_B2,JTE_B2 & - ,JTS_B1_H1,JTE_B1_H1,JTE_B1_H2 & - ,JTS_B1_H2 & - ,JTS_H1,JTE_H1,JTS_H2,JTE_H2 -! - INTEGER(kind=KINT),SAVE :: IHALO,JHALO & - ,MPI_COMM_COMP & - ,MY_DOMAIN_ID & - ,MYPE -! - INTEGER(kind=KINT),DIMENSION(1:8),SAVE :: MY_NEB -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE,SAVE :: LOCAL_ISTART & - ,LOCAL_IEND & - ,LOCAL_JSTART & - ,LOCAL_JEND -! - LOGICAL(kind=KLOG),SAVE :: ADV_STANDARD & - ,ADV_UPSTREAM & - ,E_BDY & - ,N_BDY & - ,S_BDY & - ,W_BDY -! -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - SUBROUTINE SET_DOMAIN_SPECS(ITS_IN,ITE_IN,JTS_IN,JTE_IN & - ,IMS_IN,IME_IN,JMS_IN,JME_IN & - ,IDS_IN,IDE_IN,JDS_IN,JDE_IN & - ,IHALO_IN,JHALO_IN & - ,MY_DOMAIN_ID_IN & - ,MYPE_IN & - ,MY_NEB_IN & - ,MPI_COMM_COMP_IN & - ,NUM_PES & -! - ,LOCAL_ISTART_IN,LOCAL_IEND_IN & ! ^ - ,LOCAL_JSTART_IN,LOCAL_JEND_IN & ! | - ,ADV_STANDARD_IN,ADV_UPSTREAM_IN & ! Optional arguments - ,S_BDY_IN,N_BDY_IN & ! | - ,W_BDY_IN,E_BDY_IN & ! v - ) -! -!----------------------------------------------------------------------- -! -!*** Set these key domain-related variables for the active domain. -! -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: ITS_IN,ITE_IN,JTS_IN,JTE_IN & - ,IMS_IN,IME_IN,JMS_IN,JME_IN & - ,IDS_IN,IDE_IN,JDS_IN,JDE_IN & - ,IHALO_IN,JHALO_IN & - ,MPI_COMM_COMP_IN & - ,MY_DOMAIN_ID_IN & - ,MYPE_IN & - ,NUM_PES -! - INTEGER(KIND=KINT),DIMENSION(1:8),INTENT(IN) :: MY_NEB_IN -! -!----------------------- -!*** Optional arguments -!----------------------- -! - INTEGER(kind=KINT),DIMENSION(0:NUM_PES-1),INTENT(IN),OPTIONAL :: & - LOCAL_ISTART_IN & - ,LOCAL_IEND_IN & - ,LOCAL_JSTART_IN & - ,LOCAL_JEND_IN -! - LOGICAL(kind=KLOG),INTENT(IN),OPTIONAL :: ADV_STANDARD_IN & - ,ADV_UPSTREAM_IN & - ,E_BDY_IN,N_BDY_IN & - ,S_BDY_IN,W_BDY_IN -! -!--------------------- -!*** Local variables -!--------------------- -! - INTEGER(kind=KINT) :: N -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - ITS=ITS_IN - ITE=ITE_IN - IMS=IMS_IN - IME=IME_IN - IDS=IDS_IN - IDE=IDE_IN -! - JTS=JTS_IN - JTE=JTE_IN - JMS=JMS_IN - JME=JME_IN - JDS=JDS_IN - JDE=JDE_IN -! - IHALO=IHALO_IN - JHALO=JHALO_IN -! - MPI_COMM_COMP=MPI_COMM_COMP_IN - MY_DOMAIN_ID=MY_DOMAIN_ID_IN - MYPE=MYPE_IN -! - ITS_B1=MAX(ITS,IDS+1) - ITE_B1=MIN(ITE,IDE-1) - ITS_B2=MAX(ITS,IDS+2) - ITE_B2=MIN(ITE,IDE-2) - ITS_B1_H1=MAX(ITS-1,IDS+1) - ITE_B1_H1=MIN(ITE+1,IDE-1) - ITE_B1_H2=MIN(ITE+2,IDE-1) - ITS_H1=MAX(ITS-1,IDS) - ITE_H1=MIN(ITE+1,IDE) - ITS_H2=MAX(ITS-2,IDS) - ITE_H2=MIN(ITE+2,IDE) - JTS_B1=MAX(JTS,JDS+1) - JTE_B1=MIN(JTE,JDE-1) - JTS_B2=MAX(JTS,JDS+2) - JTE_B2=MIN(JTE,JDE-2) - JTS_B1_H1=MAX(JTS-1,JDS+1) - JTE_B1_H1=MIN(JTE+1,JDE-1) - JTE_B1_H2=MIN(JTE+2,JDE-1) - JTS_H1=MAX(JTS-1,JDS) - JTE_H1=MIN(JTE+1,JDE) - JTS_H2=MAX(JTS-2,JDS) - JTE_H2=MIN(JTE+2,JDE) -! - DO N=1,8 - MY_NEB(N)=MY_NEB_IN(N) - ENDDO -! - IF(PRESENT(ADV_STANDARD_IN))THEN - ADV_STANDARD=ADV_STANDARD_IN - ADV_UPSTREAM=ADV_UPSTREAM_IN - ENDIF -! - IF(PRESENT(S_BDY_IN))THEN - S_BDY=S_BDY_IN - N_BDY=N_BDY_IN - W_BDY=W_BDY_IN - E_BDY=E_BDY_IN - ENDIF -! - IF(PRESENT(LOCAL_ISTART_IN))THEN - IF(ALLOCATED(LOCAL_ISTART))THEN - DEALLOCATE(LOCAL_ISTART) - DEALLOCATE(LOCAL_IEND) - DEALLOCATE(LOCAL_JSTART) - DEALLOCATE(LOCAL_JEND) - ENDIF -! - ALLOCATE(LOCAL_ISTART(0:NUM_PES-1)) - ALLOCATE(LOCAL_IEND(0:NUM_PES-1)) - ALLOCATE(LOCAL_JSTART(0:NUM_PES-1)) - ALLOCATE(LOCAL_JEND(0:NUM_PES-1)) -! - DO N=0,NUM_PES-1 - LOCAL_ISTART(N)=LOCAL_ISTART_IN(N) - LOCAL_IEND(N) =LOCAL_IEND_IN(N) - LOCAL_JSTART(N)=LOCAL_JSTART_IN(N) - LOCAL_JEND(N) =LOCAL_JEND_IN(N) - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE SET_DOMAIN_SPECS -! -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- -! - END MODULE MODULE_MY_DOMAIN_SPECS -! -!----------------------------------------------------------------------- diff --git a/src/nmm/module_NESTING.F90 b/src/nmm/module_NESTING.F90 deleted file mode 100644 index 068b9e2..0000000 --- a/src/nmm/module_NESTING.F90 +++ /dev/null @@ -1,13183 +0,0 @@ -!----------------------------------------------------------------------- -! - MODULE MODULE_NESTING -! -!----------------------------------------------------------------------- -! -!*** This module contains routines that perform various interactions -!*** between parent domains and their children. -! -!----------------------------------------------------------------------- -! -! PROGRAM HISTORY LOG: -! -! 2008-02-07 Black - PARENT_TO_CHILD_FILL -! 2008-03-05 Black - PARENT_CHILD_SPLIT -! 2008-03-25 Black - PARENT_TO_CHILD_INIT_NMM -! 2008-04-22 Black - Replace PARENT_CHILD_SPLIT with _COMMS -! 2008-06-18 Black - PARENT_TO_CHILD_COMPUTE -! 2008-06-18 Black - PREPARE_PARENT_TO_CHILD_INTERP -! 2008-08-14 Black - Added BOUNDARY_DATA_STATE_TO_STATE -! 2009-03-12 Black - Added Z0BASE and STDH now needed for NPS. -! 2009-10-12 Black - Fix for generalized of parent-child space ratios. -! 2010-03-31 Black - Add parent computation of child boundary topo. -! 2011-05-17 Yang - Modified for using the ESMF 5.2.0r_beta_snapshot_07. -! 2011-07-16 Black - Moving nest capability. -! 2012-07-20 Black - Generational use of MPI tasks. -! -!----------------------------------------------------------------------- -! -! USAGE: -! -!----------------------------------------------------------------------- -! - USE MPI - USE ESMF - USE netcdf -! - USE module_KINDS -! - USE module_DERIVED_TYPES,ONLY: BNDS_2D & - ,CHILD_UPDATE_LINK & - ,COMMS_FAMILY & - ,DOMAIN_DATA & - ,INTEGER_DATA & - ,INTERIOR_DATA_FROM_PARENT & - ,MIXED_DATA_TASKS & - ,REAL_DATA_2D -! - USE module_VARS,ONLY: VAR -! - USE module_LS_NOAHLSM,ONLY: NUM_SOIL_LAYERS -! - USE module_CONSTANTS,ONLY: P608,R_D -! - USE module_CONTROL,ONLY: NUM_DOMAINS_MAX,TIMEF -! - USE module_EXCHANGE,ONLY: HALO_EXCH -! - USE module_ERR_MSG,ONLY: ERR_MSG,MESSAGE_CHECK -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: BOUNDARY_DATA_STATE_TO_STATE & - ,CHECK & - ,CHECK_REAL & - ,CHILD_2WAY_BOOKKEEPING & - ,CHILD_RANKS & - ,GENERATE_2WAY_DATA & - ,HYPERBOLA & - ,INTERNAL_DATA_TO_DOMAIN & - ,INTERIOR_DATA_STATE_TO_STATE & - ,LAG_STEPS & - ,LATLON_TO_IJ & - ,MOVING_NEST_BOOKKEEPING & - ,MOVING_NEST_RECV_DATA & - ,PARENT_2WAY_BOOKKEEPING & - ,PARENT_BOOKKEEPING_MOVING & - ,PARENT_CHILD_COMMS & - ,PARENT_READS_MOVING_CHILD_TOPO & - ,PARENT_TO_CHILD_INIT_NMM & - ,PARENT_UPDATES_HALOS & - ,PARENT_UPDATES_MOVING & - ,REAL_IJ_TO_LATLON & - ,SET_NEST_GRIDS & - ,STENCIL_H_EVEN,STENCIL_SFC_H_EVEN & - ,STENCIL_V_EVEN,STENCIL_SFC_V_EVEN & - ,STENCIL_H_ODD,STENCIL_SFC_H_ODD & - ,STENCIL_V_ODD,STENCIL_SFC_V_ODD & - ,SUFFIX_MOVE & - ,SUFFIX_NESTBC & - ,SUFFIX_TWOWAY -! -!----------------------------------------------------------------------- -! - INTEGER(kind=KINT),PARAMETER :: NEAREST=0 & !<-- Flag for nearest neighbor interpolation (parent to child) - ,BILINEAR=1 !<-- Flag for bilinear interpolation (parent to child) -! - INTEGER(kind=KINT),SAVE :: LM,N8=8 -! - INTEGER(kind=KINT),SAVE :: LAG_STEPS=4 !<-- Nest moves this many parent timesteps after deciding -! - INTEGER(kind=KINT),SAVE :: STENCIL_H_EVEN=3 & - ,STENCIL_V_EVEN=2 & - ,STENCIL_SFC_H_EVEN=3 & - ,STENCIL_SFC_V_EVEN=3 & - ,STENCIL_H_ODD=3 & - ,STENCIL_V_ODD=3 & - ,STENCIL_SFC_H_ODD=3 & - ,STENCIL_SFC_V_ODD=2 -! - REAL(kind=KFPT),SAVE :: CHILD_PARENT_SPACE_RATIO & - ,EPS=1.E-4 -! - CHARACTER(len=5) :: SUFFIX_MOVE='-move' - CHARACTER(len=5) :: SUFFIX_TWOWAY='-2way' - CHARACTER(len=7) :: SUFFIX_NESTBC='-nestbc' -! -!----------------------------------------------------------------------- -! - REAL(kind=KDBL) :: btim,btim0 -! - TYPE(CHILD_UPDATE_LINK),POINTER,SAVE :: TAIL -! - TYPE(DOMAIN_DATA),DIMENSION(:),POINTER,SAVE :: CHILD_RANKS !<-- Lists of child tasks' local ranks in p-c intracomms -! - integer(kind=kint) :: iprt=01,jprt=61 -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE PARENT_CHILD_COMMS(MYPE & - ,NUM_DOMAINS_TOTAL & - ,NUM_TASKS_TOTAL & - ,COMM_WORLD & - ,RANK_TO_DOMAIN_ID & - ,CF & - ,TASK_MODE & - ,QUILTING & - ,DOMAIN_GEN & - ,FULL_GEN & - ,MY_DOMAIN_ID_N & - ,ID_DOMAINS & - ,ID_PARENTS & - ,NUM_CHILDREN & - ,ID_CHILDREN & - ,COMMS_DOMAIN & - ,FTASKS_DOMAIN & - ,NTASKS_DOMAIN & - ,PETLIST_DOM & - ,NUM_GENS & - ) -! -!----------------------------------------------------------------------- -!*** Create MPI intracommunicators between the tasks of a parent domain -!*** and those of all its 1st generation nests (children). -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: COMM_WORLD & !<-- MPI intracommunicator for ALL tasks - ,FULL_GEN & !<-- For 2-way nesting, the generation using all tasks - ,MYPE & !<-- My task ID (global) - ,NUM_DOMAINS_TOTAL & !<-- Total number of domains - ,NUM_TASKS_TOTAL !<-- Total number of tasks in the run -! - INTEGER(kind=KINT),DIMENSION(*),INTENT(IN) :: DOMAIN_GEN & !<-- For 2-way nesting, each domain's generation - ,RANK_TO_DOMAIN_ID !<-- Domain ID for each configure file -! - CHARACTER(len=12),INTENT(IN) :: TASK_MODE !<-- Unique or generational task assignment -! - LOGICAL(kind=KLOG),INTENT(IN) :: QUILTING !<-- Was quilting specified in the configure files? -! - TYPE(ESMF_Config),DIMENSION(*),INTENT(INOUT) :: CF !<-- The config objects (one per domain) -! - INTEGER(kind=KINT),INTENT(OUT) :: NUM_GENS !<-- The # of generations of domains -! - INTEGER(kind=KINT),DIMENSION(:,:),POINTER,INTENT(OUT) :: ID_CHILDREN & !<-- Domain IDs of all domains' children - ,PETLIST_DOM !<-- List of task IDs on each domain -! - INTEGER(kind=KINT),DIMENSION(:),POINTER,INTENT(OUT) :: ID_DOMAINS & !<-- Array of the domain IDs - ,ID_PARENTS & !<-- Array of the domains' parent IDs - ,FTASKS_DOMAIN & !<-- # of forecast tasks on each domain - ,MY_DOMAIN_ID_N & !<-- IDs of the domains on which current task resides - ,NTASKS_DOMAIN & !<-- # of tasks on each domain excluding descendents - ,NUM_CHILDREN !<-- # of children on each domain -! - TYPE(COMMS_FAMILY),DIMENSION(:),POINTER,INTENT(OUT) :: COMMS_DOMAIN !<-- Intracommunicators between parent and child domains - ! and between each domains' forecast tasks. -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: I,IERR,ISTAT & - ,N,N1,N2,N3,NN,RC -! - INTEGER(kind=KINT) :: COMM_INTRA & - ,GROUP_UNION & - ,GROUP_WORLD & - ,ID_CHILD & - ,ID_DOM & - ,ID_FULL & - ,ID_PARENT & - ,INPES & - ,JNPES & - ,KOUNT & - ,KOUNT_DOMS & - ,KOUNT_TASKS & - ,LAST_FCST_TASK_X & - ,LAST_WRITE_TASK_X & - ,LEAD_REMOTE & - ,N_CHILDREN & - ,N_GEN & - ,NDOMS_FULL & - ,NMAX & - ,NSAVE & - ,NTASKS_CONTRIB & - ,NTASKS_PARENT & - ,NTASKS_X & - ,NUM_FCST_TASKS & - ,NUM_TASKS_FULL & - ,NUM_WRITE_TASKS & - ,RC_COMMS & - ,TASK_X & - ,WRITE_GROUPS & - ,WRITE_TASKS_PER_GROUP -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: DOMS_PER_GEN & !<-- Domain count per generation - ,DOMS_FULL & !<-- IDs of domains in the full generation - ,GLOBAL_UNION & !<-- Union of parent and child tasks in intracomms - ,GROUP & !<-- MPI group for each domain - ,KOUNT_FULL & !<-- 1st task on each domain of the full generation - ,LAST_FCST_TASK & !<-- ID of last forecast task on each domain - ,LAST_WRITE_TASK & !<-- ID of last write task on each domain - ,LAST_TASK & !<-- ID of last task on each domain - ,LEAD_FCST_TASK & !<-- ID of first task on each domain - ,LEAD_WRITE_TASK & !<-- ID of first write on each domain - ,LEAD_TASK & !<-- ID of first task on each domain - ,WTASKS_DOMAIN !<-- # of write/quilt tasks on each domain -! - REAL(kind=KFPT) :: RECIP_NUM_TASKS_FULL -! - REAL(kind=KFPT),DIMENSION(:),ALLOCATABLE :: FRAC_FULL !<-- Fraction of tasks on each domain in full generation -! - CHARACTER(2) :: NUM_DOMAIN - CHARACTER(6),SAVE :: FMT='(I2.2)' -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC_COMMS=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -! - ALLOCATE(ID_DOMAINS (1:NUM_DOMAINS_TOTAL)) - ALLOCATE(ID_PARENTS (1:NUM_DOMAINS_TOTAL)) - ALLOCATE(LEAD_TASK (1:NUM_DOMAINS_TOTAL)) - ALLOCATE(LAST_TASK (1:NUM_DOMAINS_TOTAL)) - ALLOCATE(FTASKS_DOMAIN(1:NUM_DOMAINS_TOTAL)) - ALLOCATE(WTASKS_DOMAIN(1:NUM_DOMAINS_TOTAL)) - ALLOCATE(NTASKS_DOMAIN(1:NUM_DOMAINS_TOTAL)) - ALLOCATE(NUM_CHILDREN (1:NUM_DOMAINS_TOTAL)) -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** Incoming tasks extract relevant information from all config files. -! -!*** This loop is general thus the domain IDs do not need to correspond -!*** to the number in the configure file name. The user may assign -!*** IDs monotonically to the domains starting with 1 and in any order -!*** desired except that the uppermost parent must have an ID of 1. -!*** However the rank/element of each domain in the CF array is equal -!*** to the given domain's ID. -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - read_configs: DO N=1,NUM_DOMAINS_TOTAL !<-- Loop through all configure objects -! -!----------------------------------------------------------------------- -!*** Save the domain IDs. -!*** These are simply integers each domain will use to keep track -!*** of itself with respect to others. -!----------------------------------------------------------------------- -! - ID_DOMAINS(N)=RANK_TO_DOMAIN_ID(N) - ID_DOM=ID_DOMAINS(N) -! -!----------------------------------------------------------------------- -!*** Who is the parent of each domain? -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract ID of Parent of this Domain" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_DOM) & !<-- The config object - ,value =ID_PARENTS(ID_DOM) & !<-- The ID of the parent of this domain - ,label ='my_parent_id:' & !<-- Take values from this config label - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_COMMS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -!----------------------------------------------------------------------- -!*** How many children does each domain have? -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract # of Children of this Domain" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_DOM) & !<-- The config object - ,value =NUM_CHILDREN(ID_DOM) & !<-- # of children on this domain - ,label ='n_children:' & !<-- Take value from this config label - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_COMMS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** How many Forecast/Write tasks will be active on each domain? -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Parent_Child_Comms: Extract INPES From Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_DOM) & !<-- The config object - ,value =INPES & !<-- The domain's fcst tasks in I - ,label ='inpes:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_COMMS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Parent_Child_Comms: Extract JNPES From Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_DOM) & !<-- The config object - ,value =JNPES & !<-- The domain's fcst tasks in J - ,label ='jnpes:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_COMMS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Parent_Child_Comms: Extract Write_Groups From Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_DOM) & !<-- The config object - ,value =WRITE_GROUPS & !<-- The number of Write groups on this domain - ,label ='write_groups:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_COMMS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Parent_Child_Comms: Extract Write_Task_Per_Group From Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_DOM) & !<-- The config object - ,value =WRITE_TASKS_PER_GROUP & !<-- The number of tasks per Write group - ,label ='write_tasks_per_group:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_COMMS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(.NOT.QUILTING)THEN - WRITE_GROUPS=0 - WRITE_TASKS_PER_GROUP=0 - ENDIF -! -!----------------------------------------------------------------------- -! - FTASKS_DOMAIN(ID_DOM)=INPES*JNPES !<-- # of compute/forecast tasks on domain ID_DOM -! - WTASKS_DOMAIN(ID_DOM)=WRITE_GROUPS*WRITE_TASKS_PER_GROUP !<-- # of write/quilt tasks on domain ID_DOM -! - NTASKS_DOMAIN(ID_DOM)=FTASKS_DOMAIN(ID_DOM) & !<-- Total # of tasks on each domain - +WTASKS_DOMAIN(ID_DOM) -! -!----------------------------------------------------------------------- -! - ENDDO read_configs -! - ALLOCATE(PETLIST_DOM(1:NUM_TASKS_TOTAL,1:NUM_DOMAINS_TOTAL)) -! - DO N2=1,NUM_DOMAINS_TOTAL - DO N1=1,NUM_TASKS_TOTAL - PETLIST_DOM(N1,N2)=-999 - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** Assign tasks to all domains. -!*** For 1-way nesting each task is uniquely assigned to a single -!*** domain. For 2-way nesting each forecast task can be assigned -!*** to more than one domain but cannot lie on more than one domain -!*** in each generation. The write/quilt tasks in 2-way nesting -!*** must be assigned uniquely to a single domain and they cannot -!*** also be forecast tasks or else the asynchronous writing of -!*** the history/restart files would not always be independent of -!*** the forecast integration. -!----------------------------------------------------------------------- -! - ALLOCATE(MY_DOMAIN_ID_N(1:NUM_DOMAINS_TOTAL),stat=ISTAT) -! - DO N=1,NUM_DOMAINS_TOTAL - MY_DOMAIN_ID_N(N)=0 - ENDDO -! - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate MY_DOMAIN_ID_N rc=',ISTAT - ENDIF -! -!----------------------------------------------------------------------- -! - task_assign: IF(TASK_MODE=='unique')THEN -! -!----------------------------------------------------------------------- -! - DO N=1,NUM_DOMAINS_TOTAL -! - ID_DOM=RANK_TO_DOMAIN_ID(N) -! -!----------------------------------------------------------------------- -!*** Determine the global IDs of the lead and last tasks on each -!*** domain which in turn lets us fill the PETLIST for each domain. -!*** These include the I/O tasks. -!----------------------------------------------------------------------- -! - IF(N==1)THEN - LEAD_TASK(N)=0 !<-- Task 0 is first in line - ELSE - LEAD_TASK(ID_DOM)=LAST_TASK(ID_DOMAINS(N-1))+1 !<-- Lead task on domain follows last task on previous domain - ENDIF -! - LAST_TASK(ID_DOM)=LEAD_TASK(ID_DOM)+NTASKS_DOMAIN(ID_DOM)-1 !<-- The last task on each domain -! - IF(MYPE>=LEAD_TASK(ID_DOM).AND.MYPE<=LAST_TASK(ID_DOM))THEN !<-- Associate tasks with each domain - MY_DOMAIN_ID_N(1)=ID_DOM !<-- Tell this task the ID of the single domain it is on - ENDIF -! - KOUNT_TASKS=0 - DO N2=LEAD_TASK(ID_DOM),LAST_TASK(ID_DOM) - KOUNT_TASKS=KOUNT_TASKS+1 - PETLIST_DOM(KOUNT_TASKS,ID_DOM)=N2 - ENDDO -! - ENDDO -! - NUM_GENS=1 !<-- This is a dummy value; only relevant for 2-way -! -!----------------------------------------------------------------------- -! - ELSEIF(TASK_MODE=='generational')THEN -! -!----------------------------------------------------------------------- -!*** First determine how many domains are in each generation. -!----------------------------------------------------------------------- -! - NUM_GENS=0 - NUM_WRITE_TASKS=0 -! - ALLOCATE(DOMS_PER_GEN(1:NUM_DOMAINS_TOTAL)) -! - DO N=1,NUM_DOMAINS_TOTAL - DOMS_PER_GEN(N)=0 - ENDDO -! - DO N=1,NUM_DOMAINS_TOTAL - ID_DOM=RANK_TO_DOMAIN_ID(N) - N_GEN=DOMAIN_GEN(ID_DOM) !<-- The generation that domain ID_DOM is in - IF(N_GEN>NUM_GENS)NUM_GENS=N_GEN !<-- Determining the # of generations - DOMS_PER_GEN(N_GEN)=DOMS_PER_GEN(N_GEN)+1 !<-- Determining the # of domains per generation - NUM_WRITE_TASKS=NUM_WRITE_TASKS+WTASKS_DOMAIN(ID_DOM) !<-- Sum write tasks for all domains - ENDDO -! -!----------------------------------------------------------------------- -!*** Assign all the run's forecast tasks across the first generation -!*** that uses all of them. This is the first 'full' generation. -!----------------------------------------------------------------------- -! - ALLOCATE(LEAD_FCST_TASK(1:NUM_DOMAINS_TOTAL)) - ALLOCATE(LAST_FCST_TASK(1:NUM_DOMAINS_TOTAL)) - ALLOCATE(LEAD_WRITE_TASK(1:NUM_DOMAINS_TOTAL)) - ALLOCATE(LAST_WRITE_TASK(1:NUM_DOMAINS_TOTAL)) -! - KOUNT_DOMS=0 -! - NUM_FCST_TASKS=NUM_TASKS_TOTAL-NUM_WRITE_TASKS !<-- Total # of forecast tasks available -! - DO N=1,NUM_DOMAINS_TOTAL -! - ID_DOM=RANK_TO_DOMAIN_ID(N) -! - IF(DOMAIN_GEN(ID_DOM)/=FULL_GEN)CYCLE !<-- Only interested in the domains of the 'full' generation - KOUNT_DOMS=KOUNT_DOMS+1 !<-- Counting domains in the 'full' generation -! - IF(KOUNT_DOMS==1)THEN - LEAD_FCST_TASK(ID_DOM)=0 !<-- Task 0 is first in line - LEAD_WRITE_TASK(ID_DOM)=NUM_FCST_TASKS !<-- 1st write task follows the last forecast task - ELSE - LEAD_FCST_TASK(ID_DOM)=LAST_FCST_TASK_X+1 !<-- Lead fcst task on domain follows last on previous domain - LEAD_WRITE_TASK(ID_DOM)=LAST_WRITE_TASK_X+1 !<-- Lead write task on domain follows last on previous domain - ENDIF -! - LAST_FCST_TASK_X=LEAD_FCST_TASK(ID_DOM)+FTASKS_DOMAIN(ID_DOM)-1 - LAST_FCST_TASK(ID_DOM)=LAST_FCST_TASK_X !<-- The last forecast task on this domain -! - LAST_WRITE_TASK_X=LEAD_WRITE_TASK(ID_DOM)+WTASKS_DOMAIN(ID_DOM)-1 - LAST_WRITE_TASK(ID_DOM)=LAST_WRITE_TASK_X !<-- The last write task on this domain -! - IF(MYPE>=LEAD_FCST_TASK(ID_DOM) & !<-- - .AND. & ! - MYPE<=LAST_FCST_TASK(ID_DOM) & ! Associate tasks with each domain. - .OR. & ! Write tasks can be tied to only one domain. - MYPE>=LEAD_WRITE_TASK(ID_DOM) & ! - .AND. & ! - MYPE<=LAST_WRITE_TASK(ID_DOM))THEN !<--- -! - MY_DOMAIN_ID_N(ID_DOM)=ID_DOM !<-- This task collects its domain ID in this generation. - ENDIF -! - KOUNT_TASKS=0 - DO N2=LEAD_FCST_TASK(ID_DOM),LAST_FCST_TASK(ID_DOM) !<-- Loop through this domain's fcst tasks. - KOUNT_TASKS=KOUNT_TASKS+1 - PETLIST_DOM(KOUNT_TASKS,ID_DOM)=N2 !<-- Insert this fcst task into the domain's task list. - ENDDO -! - DO N2=LEAD_WRITE_TASK(ID_DOM),LAST_WRITE_TASK(ID_DOM) !<-- Loop through this domain's quilt/write tasks. - KOUNT_TASKS=KOUNT_TASKS+1 - PETLIST_DOM(KOUNT_TASKS,ID_DOM)=N2 !<-- Insert this write task into the domain's task list. - ENDDO -! - ENDDO -! -!----------------------------------------------------------------------- -!*** Now assign the tasks on all the domains in the remaining -!*** generations. In order to balance the work load as evenly -!*** as possible the domains in each of these generations will -!*** take their tasks equally from each of the domains in the -!*** full generation. -!----------------------------------------------------------------------- -! - NDOMS_FULL=DOMS_PER_GEN(FULL_GEN) !<-- # of domains in 1st full generation -! - ALLOCATE(DOMS_FULL(1:NDOMS_FULL)) - ALLOCATE(FRAC_FULL(1:NDOMS_FULL)) - ALLOCATE(KOUNT_FULL(1:NDOMS_FULL)) -! - DO N=1,NDOMS_FULL - FRAC_FULL(N)=0. - KOUNT_FULL(N)=-1 - ENDDO -! -!----------------------------------------------------------------------- -! - NUM_TASKS_FULL=0 - DO N=1,NUM_DOMAINS_TOTAL - ID_DOM=RANK_TO_DOMAIN_ID(N) !<-- Domain #N's domain ID (selected by the user) - IF(DOMAIN_GEN(ID_DOM)/=FULL_GEN)CYCLE - NUM_TASKS_FULL=NUM_TASKS_FULL+FTASKS_DOMAIN(ID_DOM) !<-- Add up the # of compute tasks in the full generation. - ENDDO -! - RECIP_NUM_TASKS_FULL=1./REAL(NUM_TASKS_FULL) - KOUNT=0 -! - DO N=1,NUM_DOMAINS_TOTAL - ID_DOM=RANK_TO_DOMAIN_ID(N) - IF(DOMAIN_GEN(ID_DOM)/=FULL_GEN)CYCLE !<-- Consider only the first full generation -! - KOUNT=KOUNT+1 - DOMS_FULL(KOUNT)=ID_DOM !<-- IDs of domains in the full generation - FRAC_FULL(KOUNT)=FTASKS_DOMAIN(ID_DOM)*RECIP_NUM_TASKS_FULL !<-- Fraction of all tasks on each domain in full generation - KOUNT_FULL(KOUNT)=PETLIST_DOM(1,ID_DOM) !<-- 1st task on each domain of the full generation - ENDDO -! -!----------------------------------------------------------------------- -!*** In each of the remaining generations fill the domain's compute -!*** tasks proportionately with tasks from each domain in the full -!*** generation in order to spread the work load evenly. -!----------------------------------------------------------------------- -! - gens_loop: DO N=1,NUM_GENS !<-- Loop through the generations -! - dom_loop: DO N1=1,NUM_DOMAINS_TOTAL -! - ID_DOM=RANK_TO_DOMAIN_ID(N1) !<-- Domain ID of domain #N1 - IF(DOMAIN_GEN(ID_DOM)/=N.OR.DOMAIN_GEN(ID_DOM)==FULL_GEN)THEN !<-- Consider domains in gen #N and not in the full generation - CYCLE dom_loop - ENDIF -! -!----------------------------------------------------------------------- -!*** First assign the write/quilt tasks since they are totally -!*** separate from the fcst/compute tasks and are always assigned -!*** monotonically. -!----------------------------------------------------------------------- -! - LEAD_WRITE_TASK(ID_DOM)=LAST_WRITE_TASK_X+1 !<-- Lead write task on domain follows last on previous domain - LAST_WRITE_TASK(ID_DOM)=LEAD_WRITE_TASK(ID_DOM) & !<-- Last write task on this domain - +WTASKS_DOMAIN(ID_DOM)-1 - KOUNT_TASKS=FTASKS_DOMAIN(ID_DOM) !<-- Write/quilt tasks follow the compute tasks in the PETList -! - DO N2=LEAD_WRITE_TASK(ID_DOM),LAST_WRITE_TASK(ID_DOM) - KOUNT_TASKS=KOUNT_TASKS+1 - PETLIST_DOM(KOUNT_TASKS,ID_DOM)=N2 !<-- Insert write task into domain's task list - IF(MYPE==PETLIST_DOM(KOUNT_TASKS,ID_DOM))THEN - MY_DOMAIN_ID_N(ID_DOM)=ID_DOM !<-- This write task collects its domain ID in this generation. - ENDIF - ENDDO - LAST_WRITE_TASK_X=LAST_WRITE_TASK(ID_DOM) -! -!----------------------------------------------------------------------- -!*** Now proceed with the assignment of forecast/compute tasks. -!----------------------------------------------------------------------- -! - KOUNT_TASKS=0 - DO N2=1,NDOMS_FULL !<-- Loop through the domains in the full generation. - ID_FULL=DOMS_FULL(N2) !<-- ID of domain #N2 in full generation - NTASKS_CONTRIB=NINT(FRAC_FULL(N2)*FTASKS_DOMAIN(ID_DOM)) !<-- # of tasks contributed by domain #N2 in full generation -! - DO N3=1,NTASKS_CONTRIB !<-- Apply the contributed tasks to domain ID_DOM. - KOUNT_TASKS=KOUNT_TASKS+1 - PETLIST_DOM(KOUNT_TASKS,ID_DOM)=KOUNT_FULL(N2) !<-- Add this fcst task to this domain's task list. - IF(MYPE==PETLIST_DOM(KOUNT_TASKS,ID_DOM))THEN - MY_DOMAIN_ID_N(ID_DOM)=ID_DOM !<-- This fcst task collects its domain ID in this generation. - ENDIF -! - KOUNT_FULL(N2)=KOUNT_FULL(N2)+1 - IF(KOUNT_FULL(N2)>PETLIST_DOM(FTASKS_DOMAIN(ID_FULL),ID_FULL))THEN - KOUNT_FULL(N2)=PETLIST_DOM(1,ID_FULL) !<-- Cycle around contributed tasks from domain ID_FULL. - ENDIF -! - IF(KOUNT_TASKS==FTASKS_DOMAIN(ID_DOM))THEN !<-- If so, domain ID_DOM has filled its compute tasks. - LEAD_FCST_TASK(ID_DOM)=PETLIST_DOM(1,ID_DOM) !<-- Save identity of this domain's lead compute task. - LAST_FCST_TASK(ID_DOM)=PETLIST_DOM(KOUNT_TASKS,ID_DOM) !<-- Save identity of this domain's last compute task. - CYCLE dom_loop - ENDIF -! - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** If we reach this point then all of domain ID_DOM's compute tasks -!*** still have not been assigned. This is simply due to fractional -!*** roundoff in computing the number of tasks contributed by each -!*** of the domains in the full generation. Finish assigning this -!*** domain's tasks by taking them from the first domain in the full -!*** generation. -!----------------------------------------------------------------------- -! - ID_FULL=DOMS_FULL(1) !<-- Take the tasks from the 1st domain in the full generation. -! - DO N2=KOUNT_TASKS+1,FTASKS_DOMAIN(ID_DOM) - PETLIST_DOM(N2,ID_DOM)=KOUNT_FULL(1) !<-- Add remaining fcst tasks to this domain's task list. - IF(MYPE==PETLIST_DOM(N2,ID_DOM))THEN - MY_DOMAIN_ID_N(ID_DOM)=ID_DOM !<-- This fcst task collects its domain ID in this generation. - ENDIF -! - KOUNT_FULL(1)=KOUNT_FULL(1)+1 - IF(KOUNT_FULL(1)>PETLIST_DOM(FTASKS_DOMAIN(ID_FULL),ID_FULL))THEN - KOUNT_FULL(1)=PETLIST_DOM(1,ID_FULL) !<-- Cycle around contributed tasks from domain ID_FULL. - ENDIF - ENDDO -! - LEAD_FCST_TASK(ID_DOM)=PETLIST_DOM(1,ID_DOM) !<-- Save identity of this domain's lead compute task. - LAST_FCST_TASK(ID_DOM)=PETLIST_DOM(FTASKS_DOMAIN(ID_DOM),ID_DOM) !<-- Save identity of this domain's last compute task. -! -!----------------------------------------------------------------------- -! - ENDDO dom_loop -! - ENDDO gens_loop -! - DEALLOCATE(DOMS_FULL) - DEALLOCATE(FRAC_FULL) - DEALLOCATE(KOUNT_FULL) -! -!----------------------------------------------------------------------- -! - ENDIF task_assign -! -!----------------------------------------------------------------------- -!*** All tasks know the task counts and IDs of all domains as well as -!*** the parents of each domain. -! -!*** Loop through all domains in order to associate all parents -!*** with their children through intracommunicators. We cannot use -!*** intercommunicators in general since parent and child domains -!*** can contain some of the same forecast tasks in 2-way nesting -!*** and MPI dictates that intercommunicators can only link disjoint -!*** sets of tasks. -!----------------------------------------------------------------------- -! - ALLOCATE(ID_CHILDREN(1:NUM_DOMAINS_TOTAL,1:NUM_DOMAINS_TOTAL)) !<-- Array to hold all domains' children's IDs -! - DO N1=1,NUM_DOMAINS_TOTAL - DO N2=1,NUM_DOMAINS_TOTAL - ID_CHILDREN(N1,N2)=0 !<-- All valid Domain IDs are >0 - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** Allocate intracommunicators between parents and children for -!*** all of the domains since some forecast tasks may lie on more -!*** than one parent and/or child domain. The same is true for -!*** the lists of ranks of children's local task ranks in the -!*** intracommunicators. -!----------------------------------------------------------------------- -! - ALLOCATE(COMMS_DOMAIN(1:NUM_DOMAINS_TOTAL),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate COMMS_DOMAIN!' - CALL ESMF_Finalize(rc=RC,endflag=ESMF_END_ABORT) - ENDIF -! - DO N=1,NUM_DOMAINS_TOTAL - comms_domain(N)%TO_PARENT=-999 !<-- Initialize to nonsense the intracommunicator to parent - ENDDO -! - ALLOCATE(CHILD_RANKS(1:NUM_DOMAINS_TOTAL),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate CHILD_RANKS!' - CALL ESMF_Finalize(rc=RC,endflag=ESMF_END_ABORT) - ENDIF -! - DO N=1,NUM_DOMAINS_TOTAL - child_ranks(N)%CHILDREN=>NULL() - ENDDO -! -!----------------------------------------------------------------------- -!*** Next we need to create MPI groups for the task sets on each -!*** of the domains. -!----------------------------------------------------------------------- -! - ALLOCATE(GROUP(1:NUM_DOMAINS_TOTAL)) -! - CALL MPI_COMM_GROUP(COMM_WORLD & !<-- Intracommunicator between all tasks in the run - ,GROUP_WORLD & !<-- The MPI group of all tasks in the run - ,IERR ) -! - DO N=1,NUM_DOMAINS_TOTAL - ID_DOM=RANK_TO_DOMAIN_ID(N) - NTASKS_X=NTASKS_DOMAIN(ID_DOM) !<-- Total # of tasks on domain ID_DOM -! - CALL MPI_GROUP_INCL(GROUP_WORLD & !<-- MPI group with all tasks in the run - ,NTASKS_X & !<-- # of fcst tasks on domain ID_DOM - ,PETLIST_DOM(1:NTASKS_X,ID_DOM) & !<-- The global ranks of tasks that lie on ID_DOM - ,GROUP(ID_DOM) & !<-- The new group containing the tasks on ID_DOM - ,IERR ) - ENDDO -! -!----------------------------------------------------------------------- -!*** Loop through all domains. Parent domains will create -!*** intracommunicators with each of their children and vice versa. -!----------------------------------------------------------------------- -! - main_loop: DO N=1,NUM_DOMAINS_TOTAL -! -!----------------------------------------------------------------------- -! - ID_DOM=RANK_TO_DOMAIN_ID(N) -! -!----------------------------------------------------------------------- -! - ID_PARENT=-999 !<-- Initialize to nonsense the parent's domain ID -! - N_CHILDREN=NUM_CHILDREN(ID_DOM) !<-- The # of children on this domain -! -!----------------------------------------------------------------------- -! - has_children: IF(N_CHILDREN>0)THEN -! -!----------------------------------------------------------------------- -! - ID_PARENT=ID_DOM !<-- ID_DOM is a parent domain - NTASKS_PARENT=NTASKS_DOMAIN(ID_PARENT) !<-- Total # of fcst and write tasks on this parent domain -! -!----------------------------------------------------------------------- -!*** All domain IDs will be searched to find matches between the -!*** current domain's ID and the parent IDs of the other domains. -!*** Matches will identify Parent-Child couplets. -!----------------------------------------------------------------------- -! - NN=0 -! - DO N2=1,NUM_DOMAINS_TOTAL !<-- Search for children who have parent ID_PARENT - ID_CHILD=ID_DOMAINS(N2) !<-- Check if this domain ID is that of a child -! - IF(ID_PARENTS(ID_CHILD)==ID_PARENT.AND.ID_PARENT/=-999)THEN !<-- If yes then we found a nest that is this domain's child - NN=NN+1 !<-- Increment index of children of the parent domain - ID_CHILDREN(NN,ID_PARENT)=ID_CHILD !<-- IDs of this parent's (ID_PARENT's) children's domains - ENDIF -! - IF(NN==N_CHILDREN)THEN !<-- We have found all of this domain's children - ALLOCATE(comms_domain(ID_PARENT)%TO_CHILDREN(1:N_CHILDREN) & !<-- Parent allocates intracommunicators with each child - ,stat=ISTAT) -! - DO N3=1,N_CHILDREN - comms_domain(ID_PARENT)%TO_CHILDREN(N3)=-999 !<-- Parent initializes intracommunicators with each child - ENDDO -! - EXIT -! - ENDIF -! - ENDDO -! -!----------------------------------------------------------------------- -! - ENDIF has_children -! -!----------------------------------------------------------------------- -!*** Now create groups that are unions of each parent with each -!*** of their children. From those unions create the final -!*** parent-child intracommunicators. -!----------------------------------------------------------------------- -! - IF(N_CHILDREN>0)THEN -! - ALLOCATE(child_ranks(ID_PARENT)%CHILDREN(1:N_CHILDREN) & - ,stat=ISTAT) -! - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate child_ranks%CHILDREN!' - CALL ESMF_Finalize(rc=RC,endflag=ESMF_END_ABORT) - ENDIF -! -!----------------------------------------------------------------------- -! - intra_comm: DO N2=1,N_CHILDREN !<-- Loop through the given parent's children -! -!----------------------------------------------------------------------- -! - ID_CHILD=ID_CHILDREN(N2,ID_PARENT) !<-- Domain ID of child N2 of domain ID_PARENT -! - CALL MPI_GROUP_UNION(GROUP(ID_PARENT) & !<-- The group containing the parent tasks (in) - ,GROUP(ID_CHILD) & !<-- The group containing the child tasks (in) - ,GROUP_UNION & !<-- The union of the parent and child groups (out) - ,IERR ) -! - CALL MPI_COMM_CREATE(COMM_WORLD & !<-- Intracommunicator between all tasks in the run (in) - ,GROUP_UNION & !<-- The union of the parent and child groups (in) - ,COMM_INTRA & !<-- Intracommunicator between tasks in the union (out) - ,IERR ) -! - comms_domain(ID_PARENT)%TO_CHILDREN(N2)=COMM_INTRA !<-- Parent: The intracommunicator with its child N2 - comms_domain(ID_CHILD)%TO_PARENT=COMM_INTRA !<-- Child: The intracommunicator with its parent -! -!----------------------------------------------------------------------- -!*** The parent's tasks were listed first in the creation of the union -!*** with child tasks so the parent task ranks in the union go from -!*** 0 to FTASKS_DOMAIN(ID_PARENT)-1. However the child task ranks -!*** in the union can be rather jumbled depending on how they overlie -!*** the parent tasks. Therefore parents must store the union ranks -!*** of their children's forecast tasks in order to use the -!*** intracommunicators. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** First we need to produce the list of global parent and child -!*** tasks equivalent to that which MPI produces but is not seen -!*** when the union of the parent and child groups is created. -!----------------------------------------------------------------------- -! - NMAX=NTASKS_DOMAIN(ID_PARENT)+NTASKS_DOMAIN(ID_CHILD) !<-- Max # of tasks that can be in parent-child union - ALLOCATE(GLOBAL_UNION(1:NMAX)) !<-- For holding global ranks in the union -! - DO N3=1,NTASKS_DOMAIN(ID_PARENT) - GLOBAL_UNION(N3)=PETLIST_DOM(N3,ID_PARENT) !<-- Insert parent's global task ranks into list first - ENDDO -! - KOUNT=NTASKS_DOMAIN(ID_PARENT) !<-- We just inserted this many values into GLOBAL_UNION -! - child_loop1: DO N3=1,NTASKS_DOMAIN(ID_CHILD) !<-- Now loop through all child tasks -! - DO NN=1,NTASKS_DOMAIN(ID_PARENT) !<-- Compare against the parent task ranks - IF(PETLIST_DOM(N3,ID_CHILD)==GLOBAL_UNION(NN))THEN - CYCLE child_loop1 !<-- No task rank can appear twice in the union - ENDIF - ENDDO -! - KOUNT=KOUNT+1 !<-- Accumulating # of unique global task ranks in the union - GLOBAL_UNION(KOUNT)=PETLIST_DOM(N3,ID_CHILD) !<-- Add this child global rank to the union list -! - ENDDO child_loop1 -! -!----------------------------------------------------------------------- -!*** The GLOBAL_UNION array now holds the union of the parent and -!*** child global task ranks with no ranks appearing more than once. -!*** Now the parent creates a list of the child's tasks in the union -!*** but using ranks as they exist in the intracommunicator which -!*** start with 0 for the parent's lead task and simply increase -!*** one by one in a monotonic sequence. -!----------------------------------------------------------------------- -! - ALLOCATE(child_ranks(ID_PARENT)%CHILDREN(N2)%DATA(0:NTASKS_DOMAIN(ID_CHILD)-1)) !<-- Local ranks of child N2's tasks -! in parent-child intracomm - child_loop2: DO N3=0,NTASKS_DOMAIN(ID_CHILD)-1 -! - DO NN=1,KOUNT !<-- Loop through all global task ranks in the union list - IF(PETLIST_DOM(N3+1,ID_CHILD)==GLOBAL_UNION(NN))THEN !<-- Search for child task N3's global rank in the union list - child_ranks(ID_PARENT)%CHILDREN(N2)%DATA(N3)=NN-1 !<-- Save its local rank in the parent-child intracommunicator - CYCLE child_loop2 - ENDIF - IF(NN=NUM_PES_PARENT)RETURN !<-- Parent's quilt/write tasks may leave -! -!----------------------------------------------------------------------- -!*** We need the spatial resolution of the parent grid so extract -!*** its dimensions and its bounds. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Child_Init: Extract IM From Config File" -!!! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The parent's config object - ,value =IM_PARENT & !<-- The variable filled (I dimension of parent grid) - ,label ='im:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CHILD) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Child_Init: Extract JM From Config File" -!!! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The parent's config object - ,value =JM_PARENT & !<-- The variable filled (J dimension of parent grid) - ,label ='jm:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CHILD) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Child_Init: Extract SBD From Config File" -!!! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!!!! CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The parent's config object -!!!! ,value =SBD_PARENT & !<-- The variable filled (South boundary of parent grid) -!!!! ,label ='sbd:' & !<-- Give this label's value to the previous variable -!!!! ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CHILD) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Child_Init: Extract WBD From Config File" -!!! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!!!! CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The parent's config object -!!!! ,value =WBD_PARENT & !<-- The variable filled (West boundary of parent grid) -!!!! ,label ='wbd:' & !<-- Give this label's value to the previous variable -!!!! ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CHILD) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Child_Init: Extract TPH0D From Config File" -!!! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!!!! CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The parent's config object -!!!! ,value =TPH0D_PARENT & !<-- The variable filled (Central lat of parent grid) -!!!! ,label ='tph0d:' & !<-- Give this label's value to the previous variable -!!!! ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CHILD) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Child_Init: Extract TLM0D From Config File" -!!! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!!!! CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The parent's config object -!!!! ,value =TLM0D_PARENT & !<-- The variable filled (Central lon of parent grid) -!!!! ,label ='tlm0d:' & !<-- Give this label's value to the previous variable -!!!! ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CHILD) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Global Flag for Parent Domain" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The configure object of my parent - ,value =GLOBAL_FLAG & !<-- The variable filled - ,label ='global:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CHILD) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** The parent grid resolution. -!----------------------------------------------------------------------- -! - IF(TRIM(GLOBAL_FLAG)=='true')THEN !<-- Parent is global - GLOBAL=.TRUE. - IDE=IM_PARENT+2 - JDE=JM_PARENT+2 -!!!! DPHD_PARENT=-SBD_PARENT*2./REAL(JDE-3) -!!!! DLMD_PARENT=-WBD_PARENT*2./REAL(IDE-3) - ELSE !<-- Parent is regional - GLOBAL=.FALSE. - IDE=IM_PARENT - JDE=JM_PARENT -!!!! DPHD_PARENT=-SBD_PARENT*2./REAL(JDE-1) -!!!! DLMD_PARENT=-WBD_PARENT*2./REAL(IDE-1) - ENDIF -! - ROW_0=0.5*(JDE+1) - COL_0=0.5*(IDE+1) -! -!----------------------------------------------------------------------- -!*** Extract the Solver internal state of the parent -!*** so we can use their data for the nests. -!----------------------------------------------------------------------- -! - CALL ESMF_GridCompGetInternalState(SOLVER_GRID_COMP & - ,WRAP_SOLVER & - ,RC ) -! -!----------------------------------------------------------------------- -! - SOLVER_INT_STATE=>wrap_solver%INT_STATE -! - IMS=solver_int_state%IMS !<-- Horizontal memory limits on parent tasks - IME=solver_int_state%IME ! - JMS=solver_int_state%JMS ! - JME=solver_int_state%JME !<-- -! - ITS=solver_int_state%ITS !<-- Horizontal integration limits on parent tasks - ITE=solver_int_state%ITE ! - JTS=solver_int_state%JTS ! - JTE=solver_int_state%JTE !<-- -! - LM=solver_int_state%LM !<-- Number of atmospheric layers -! - LOCAL_ISTART=>solver_int_state%LOCAL_ISTART !<-- Local integration limits for all parent tasks - LOCAL_IEND =>solver_int_state%LOCAL_IEND ! - LOCAL_JSTART=>solver_int_state%LOCAL_JSTART ! - LOCAL_JEND =>solver_int_state%LOCAL_JEND !<-- -! -!----------------------------------------------------------------------- -!*** DPHD/DLMD and SBD/WBD are used only for stand-alone, independent -!*** rotated parent/nest grids (i.e., not grid-associated nests). -!----------------------------------------------------------------------- -! - DPHD_PARENT=solver_int_state%DPHD - DLMD_PARENT=solver_int_state%DLMD - SBD_PARENT=solver_int_state%SBD - WBD_PARENT=solver_int_state%WBD - TPH0D_PARENT=solver_int_state%TPH0D - TLM0D_PARENT=solver_int_state%TLM0D -! -!----------------------------------------------------------------------- -!*** Extract relevant information from this child's configure file. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Child_Init: Extract I of SW Point on Parent" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(THIS_CHILD_ID) & !<-- The child's config object - ,value =I_PARENT_START & !<-- The variable filled (parent I of child's SW corner) - ,label ='i_parent_start:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CHILD) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Child_Init: Extract J of SW Point on Parent" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(THIS_CHILD_ID) & !<-- The child's config object - ,value =J_PARENT_START & !<-- The variable filled (parent J of child's SW corner) - ,label ='j_parent_start:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CHILD) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Child_Init: Extract Child/Parent Grid Ratio" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(THIS_CHILD_ID) & !<-- The child's config object - ,value =PARENT_CHILD_SPACE_RATIO & !<-- The variable filled (child grid increment / parent's) - ,label ='parent_child_space_ratio:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CHILD) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CHILD_PARENT_SPACE_RATIO=1./REAL(PARENT_CHILD_SPACE_RATIO) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Child_Init: Extract Global IM of Child" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(THIS_CHILD_ID) & !<-- The child's config object - ,value =IM_CHILD & !<-- The variable filled (IM of child domain) - ,label ='im:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CHILD) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Child_Init: Extract Global JM of Child" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(THIS_CHILD_ID) & !<-- The child's config object - ,value =JM_CHILD & !<-- The variable filled (JM of child domain) - ,label ='jm:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CHILD) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Only for free-standing nests: -! -!*** What is the parent lat/lon of the SW corner H point of the -!*** child grid? -!*** Find the resolution, bounds, and center of the child grid. -!----------------------------------------------------------------------- -! -! CALL CONVERT_IJ_TO_LATLON (I_PARENT_START & -! ,J_PARENT_START & -! ,IM_PARENT & -! ,JM_PARENT & -! ,TPH0D_PARENT & -! ,TLM0D_PARENT & -! ,DPHD_PARENT & -! ,DLMD_PARENT & -! ,SW_LATD_CHILD & -! ,SW_LOND_CHILD ) -! -!!! DPHD_CHILD=DPHD_PARENT*CHILD_PARENT_SPACE_RATIO -!!! DLMD_CHILD=DLMD_PARENT*CHILD_PARENT_SPACE_RATIO -! -!!! SBD_CHILD=-0.5*(JM_CHILD-1)*DPHD_CHILD -!!! WBD_CHILD=-0.5*(IM_CHILD-1)*DLMD_CHILD -! -!!! CALL CENTER_NEST(SBD_CHILD & -!!! ,WBD_CHILD & -!!! ,SW_LATD_CHILD & -!!! ,SW_LOND_CHILD & -!!! ,TPH0D_CHILD & -!!! ,TLM0D_CHILD ) -! -!----------------------------------------------------------------------- -!*** Allocate 2-D and 3-D dummy arrays for child quantities. -!----------------------------------------------------------------------- -! - ALLOCATE(SEA_MASK(1:IM_CHILD,1:JM_CHILD)) - ALLOCATE(SEA_ICE(1:IM_CHILD,1:JM_CHILD)) -! - ALLOCATE(IDUMMY_2D(1:IM_CHILD,1:JM_CHILD)) - ALLOCATE(DUMMY_2D_IN (IMS:IME,JMS:JME,1:1)) - ALLOCATE(DUMMY_2D_OUT(1:IM_CHILD,1:JM_CHILD,1:1)) - ALLOCATE(DUMMY_3D (1:IM_CHILD,1:JM_CHILD,1:LM)) - ALLOCATE(DUMMY_3DS(1:IM_CHILD,1:JM_CHILD,1:NUM_SOIL_LAYERS)) - ALLOCATE(DUMMY_SOIL(1:NUM_SOIL_LAYERS)) - ALLOCATE(TEMPSOIL (1:NUM_SOIL_LAYERS,1:IM_CHILD,1:JM_CHILD)) -! - ALLOCATE(PD_NEAREST (1:IM_CHILD,1:JM_CHILD,1:1)) - ALLOCATE(PD_BILINEAR(1:IM_CHILD,1:JM_CHILD,1:1)) -! - ALLOCATE(LOWER_TOPO(1:IM_CHILD,1:JM_CHILD)) - DO J=1,JM_CHILD - DO I=1,IM_CHILD - LOWER_TOPO(I,J)=.FALSE. - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** Parent task 0 opens a file for writing out the child's input. -!----------------------------------------------------------------------- -! - IF(MYPE==0)THEN -! - select_unit: DO N=51,59 - INQUIRE(N,OPENED=OPENED) - IF(.NOT.OPENED)THEN - NFCST=N - EXIT select_unit - ENDIF - ENDDO select_unit -! - FMT='(I2.2)' - WRITE(INT_TO_CHAR,FMT)THIS_CHILD_ID - OUTFILE='input_domain_'//INT_TO_CHAR -! - OPEN(unit=NFCST,file=OUTFILE,status='replace',form='unformatted') -! -!----------------------------------------------------------------------- -!*** The following variables are for the vertical grid structure -!*** and are shared by the parent and its children. -!----------------------------------------------------------------------- -! - IHREND=0 !<-- Not used - NTSD =0 !<-- Not used -! - WRITE(NFCST)solver_int_state%RUN & - ,solver_int_state%IDAT & - ,solver_int_state%IHRST & -! ,solver_int_state%IHREND & -! ,solver_int_state%NTSD - ,IHREND & - ,NTSD -! - WRITE(NFCST)solver_int_state%PT & - ,solver_int_state%PDTOP & - ,solver_int_state%LPT2 & - ,solver_int_state%SGM & - ,solver_int_state%SG1 & - ,solver_int_state%DSG1 & - ,solver_int_state%SGML1 & - ,solver_int_state%SG2 & - ,solver_int_state%DSG2 & - ,solver_int_state%SGML2 -! - WRITE(NFCST)I_PARENT_START,J_PARENT_START -! - DLMD=DLMD_PARENT*CHILD_PARENT_SPACE_RATIO - DPHD=DPHD_PARENT*CHILD_PARENT_SPACE_RATIO -! - IF(GLOBAL)THEN - SBD=SBD_PARENT+(J_PARENT_START-2)*DPHD_PARENT - WBD=WBD_PARENT+(I_PARENT_START-2)*DLMD_PARENT - ELSE - SBD=SBD_PARENT+(J_PARENT_START-1)*DPHD_PARENT - WBD=WBD_PARENT+(I_PARENT_START-1)*DLMD_PARENT - ENDIF -! - WRITE(NFCST)DLMD,DPHD & - ,WBD,SBD & - ,TLM0D_PARENT,TPH0D_PARENT -! - WRITE(NFCST)IM_CHILD,JM_CHILD,LM,LNSH -! -!----------------------------------------------------------------------- -! - ENDIF -! - NLEV=1 -! -!----------------------------------------------------------------------- -!*** Sea Mask -!----------------------------------------------------------------------- -!*** The Sea Mask is needed for the Sfc Geopotential so compute it now. -!*** If there are adjacent water points with different elevations -!*** after Sfc Geopotential is computed then the WATERFALL routine -!*** will level them by changing the sfc elevations. At such points -!*** the atmospheric column will need adjusting so save the locations -!*** of those points along with the preliminary values of the nest's -!*** PD, T, Q, CW, U, and V which will then be modified. -!*** The Sea Mask will be written out in its proper place following -!*** the Stnd Deviation of Sfc Height. -!----------------------------------------------------------------------- -! - DO J=JMS,JME - DO I=IMS,IME - DUMMY_2D_IN(I,J,1)=solver_int_state%SM(I,J) - ENDDO - ENDDO -! - CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & - ,NLEV & - ,'SeaMask' & - ,DUMMY_2D_OUT & - ,NEAREST) -! - IF(MYPE==0)THEN - DO J=1,JM_CHILD - DO I=1,IM_CHILD - SEA_MASK(I,J)=REAL(NINT(DUMMY_2D_OUT(I,J,1))) - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Sfc Geopotential -!----------------------------------------------------------------------- -! - DO J=JMS,JME - DO I=IMS,IME - DUMMY_2D_IN(I,J,1)=solver_int_state%FIS(I,J) - ENDDO - ENDDO -! - CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & - ,NLEV & - ,'FIS' & - ,DUMMY_2D_OUT & - ,BILINEAR) -! - IF(MYPE==0)THEN - CALL WATERFALLS(DUMMY_2D_OUT & !<-- Level adjacent water points with different elevations - ,SEA_MASK & - ,LOWER_TOPO & - ,1,IM_CHILD,1,JM_CHILD) -! - WRITE(NFCST)DUMMY_2D_OUT - ENDIF -! -! write(0,*)' after Sfc Geo' -! -!----------------------------------------------------------------------- -!*** Stnd Deviation of Sfc Height -!----------------------------------------------------------------------- - - DO J=JMS,JME - DO I=IMS,IME - DUMMY_2D_IN(I,J,1)=solver_int_state%STDH(I,J) - ENDDO - ENDDO -! - CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & - ,NLEV & - ,'STDH' & - ,DUMMY_2D_OUT & - ,BILINEAR) -! - IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT -! write(0,*)' after STDH' -! -!----------------------------------------------------------------------- -!*** Sea Mask -!----------------------------------------------------------------------- -! - IF(MYPE==0)THEN - WRITE(NFCST)SEA_MASK - ENDIF -! write(0,*)' after Sea Mask' -! -!----------------------------------------------------------------------- -!*** PD -!----------------------------------------------------------------------- -! - DO J=JMS,JME - DO I=IMS,IME - DUMMY_2D_IN(I,J,1)=solver_int_state%PD(I,J) - ENDDO - ENDDO -! - CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & - ,NLEV & - ,'PD' & - ,PD_BILINEAR & - ,BILINEAR) -! - CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & !<-- Save nearest neighbors for topo adjustment - ,NLEV & - ,'PD' & - ,PD_NEAREST & - ,NEAREST) -! - IF(MYPE==0)THEN - DO J=1,JM_CHILD - DO I=1,IM_CHILD - IF(LOWER_TOPO(I,J))THEN - DUMMY_2D_OUT(I,J,1)=PD_NEAREST(I,J,1) - ELSE - DUMMY_2D_OUT(I,J,1)=PD_BILINEAR(I,J,1) - ENDIF - ENDDO - ENDDO - ENDIF -! -! write(0,*)' after PD' -! - IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT -! -!----------------------------------------------------------------------- -!*** U -!----------------------------------------------------------------------- -! - CALL PARENT_TO_CHILD_FILL(solver_int_state%U, LM & - ,'Uwind' & - ,DUMMY_3D & - ,BILINEAR) -! - IF(MYPE==0)THEN - CALL ADJUST_COLUMNS(PD_NEAREST & - ,PD_BILINEAR & - ,LOWER_TOPO & - ,DUMMY_3D & - ,solver_int_state%PT & - ,solver_int_state%PDTOP & - ,solver_int_state%SG1 & - ,solver_int_state%SG2 & - ,IM_CHILD,JM_CHILD) - ENDIF -! - DO L=1,LM - IF(MYPE==0)WRITE(NFCST)DUMMY_3D(:,:,L) - ENDDO -! write(0,*)' after U' -! -!----------------------------------------------------------------------- -!*** V -!----------------------------------------------------------------------- -! - CALL PARENT_TO_CHILD_FILL(solver_int_state%V, LM & - ,'Vwind' & - ,DUMMY_3D & - ,BILINEAR) -! - IF(MYPE==0)THEN - CALL ADJUST_COLUMNS(PD_NEAREST & - ,PD_BILINEAR & - ,LOWER_TOPO & - ,DUMMY_3D & - ,solver_int_state%PT & - ,solver_int_state%PDTOP & - ,solver_int_state%SG1 & - ,solver_int_state%SG2 & - ,IM_CHILD,JM_CHILD) - ENDIF -! - DO L=1,LM - IF(MYPE==0)WRITE(NFCST)DUMMY_3D(:,:,L) - ENDDO -! write(0,*)' after V' -! -!----------------------------------------------------------------------- -!*** T -!----------------------------------------------------------------------- -! - CALL PARENT_TO_CHILD_FILL(solver_int_state%T, LM & - ,'Temperature' & - ,DUMMY_3D & - ,BILINEAR) -! - IF(MYPE==0)THEN - CALL ADJUST_COLUMNS(PD_NEAREST & - ,PD_BILINEAR & - ,LOWER_TOPO & - ,DUMMY_3D & - ,solver_int_state%PT & - ,solver_int_state%PDTOP & - ,solver_int_state%SG1 & - ,solver_int_state%SG2 & - ,IM_CHILD,JM_CHILD) - ENDIF -! - DO L=1,LM - IF(MYPE==0)WRITE(NFCST)DUMMY_3D(:,:,L) - ENDDO -! write(0,*)' after T' -! -!----------------------------------------------------------------------- -!*** Q -!----------------------------------------------------------------------- -! - CALL PARENT_TO_CHILD_FILL(solver_int_state%Q, LM & - ,'SpecHum' & - ,DUMMY_3D & - ,BILINEAR) -! - IF(MYPE==0)THEN - CALL ADJUST_COLUMNS(PD_NEAREST & - ,PD_BILINEAR & - ,LOWER_TOPO & - ,DUMMY_3D & - ,solver_int_state%PT & - ,solver_int_state%PDTOP & - ,solver_int_state%SG1 & - ,solver_int_state%SG2 & - ,IM_CHILD,JM_CHILD) - ENDIF -! - DO L=1,LM - IF(MYPE==0)WRITE(NFCST)DUMMY_3D(:,:,L) - ENDDO -! write(0,*)' after Q' -! -!----------------------------------------------------------------------- -!*** CW -!----------------------------------------------------------------------- -! - CALL PARENT_TO_CHILD_FILL(solver_int_state%CW, LM & - ,'CW' & - ,DUMMY_3D & - ,BILINEAR) -! - IF(MYPE==0)THEN - CALL ADJUST_COLUMNS(PD_NEAREST & - ,PD_BILINEAR & - ,LOWER_TOPO & - ,DUMMY_3D & - ,solver_int_state%PT & - ,solver_int_state%PDTOP & - ,solver_int_state%SG1 & - ,solver_int_state%SG2 & - ,IM_CHILD,JM_CHILD) - ENDIF -! - DO L=1,LM - IF(MYPE==0)WRITE(NFCST)DUMMY_3D(:,:,L) - ENDDO -! write(0,*)' after CW' -! -!----------------------------------------------------------------------- -!*** O3 -!----------------------------------------------------------------------- -! -! CALL PARENT_TO_CHILD_FILL(solver_int_state%O3, LM & -! ,'O3' & -! ,DUMMY_3D & -! ,BILINEAR) -! -! IF(MYPE==0)THEN -! CALL ADJUST_COLUMNS(PD_NEAREST & -! ,PD_BILINEAR & -! ,LOWER_TOPO & -! ,DUMMY_3D & -! ,solver_int_state%PT & -! ,solver_int_state%PDTOP & -! ,solver_int_state%SG1 & -! ,solver_int_state%SG2 & -! ,IM_CHILD,JM_CHILD) -! ENDIF -! - DO L=1,LM - DO J=1,JM_CHILD - DO I=1,IM_CHILD - DUMMY_3D(I,J,L)=0. ! for now keep O3 = 0. - ENDDO - ENDDO - IF(MYPE==0)WRITE(NFCST)DUMMY_3D(:,:,L) - ENDDO -! write(0,*)' after O3' -! -!----------------------------------------------------------------------- -!*** ALBEDO -!----------------------------------------------------------------------- -! - DO J=JMS,JME - DO I=IMS,IME - DUMMY_2D_IN(I,J,1)=solver_int_state%ALBEDO(I,J) - ENDDO - ENDDO -! - CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & - ,NLEV & - ,'ALBEDO' & - ,DUMMY_2D_OUT & - ,BILINEAR) -! - IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT -! write(0,*)' after Albedo' -! -!----------------------------------------------------------------------- -!*** ALBASE -!----------------------------------------------------------------------- -! - DO J=JMS,JME - DO I=IMS,IME - DUMMY_2D_IN(I,J,1)=solver_int_state%ALBASE(I,J) - ENDDO - ENDDO -! - CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN, 1 & - ,'ALBASE' & - ,DUMMY_2D_OUT & - ,BILINEAR) -! - IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT -! -!----------------------------------------------------------------------- -!*** EPSR -!----------------------------------------------------------------------- -! - DO J=JMS,JME - DO I=IMS,IME - DUMMY_2D_IN(I,J,1)=solver_int_state%EPSR(I,J) - ENDDO - ENDDO -! - CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & - ,NLEV & - ,'EPSR' & - ,DUMMY_2D_OUT & - ,BILINEAR) -! - IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT -! write(0,*)' after EPSR' -! -!----------------------------------------------------------------------- -!*** MXSNAL -!----------------------------------------------------------------------- -! - DO J=JMS,JME - DO I=IMS,IME - DUMMY_2D_IN(I,J,1)=solver_int_state%MXSNAL(I,J) - ENDDO - ENDDO -! - CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & - ,NLEV & - ,'MXSNAL' & - ,DUMMY_2D_OUT & - ,BILINEAR) -! - IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT -! write(0,*)' after MXSNAL' -! -!----------------------------------------------------------------------- -!*** TSKIN -!----------------------------------------------------------------------- -! -! write(0,*)' before TSKIN' - DO J=JMS,JME - DO I=IMS,IME - DUMMY_2D_IN(I,J,1)=solver_int_state%TSKIN(I,J) - ENDDO - ENDDO -! - CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & - ,NLEV & - ,'TSKIN' & - ,DUMMY_2D_OUT & - ,BILINEAR) -! - IF(MYPE==0)THEN - DO J=1,JM_CHILD - DO I=1,IM_CHILD - IF(DUMMY_2D_OUT(I,J,1)<150.)THEN - SEA_MASK(I,J)=1.0 - DUMMY_2D_OUT(I,J,1)=0. - ENDIF - if(dummy_2d_out(i,j,1)<173..and.sea_mask(i,j)<0.5)then - write(0,*)' Very cold TSKIN=',dummy_2d_out(i,j,1) & - ,' at (',i,',',j,')' - endif - ENDDO - ENDDO - ENDIF -! - IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT -! write(0,*)' after TSKIN' -! -!----------------------------------------------------------------------- -!*** SST -!----------------------------------------------------------------------- -! - DO J=JMS,JME - DO I=IMS,IME - DUMMY_2D_IN(I,J,1)=solver_int_state%SST(I,J) - ENDDO - ENDDO -! - CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & - ,NLEV & - ,'SST' & - ,DUMMY_2D_OUT & - ,BILINEAR) -! - IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT -! write(0,*)' after SST' -! -!----------------------------------------------------------------------- -!*** SNO -!----------------------------------------------------------------------- -! - DO J=JMS,JME - DO I=IMS,IME - DUMMY_2D_IN(I,J,1)=solver_int_state%SNO(I,J) - ENDDO - ENDDO -! - CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & - ,NLEV & - ,'SNO' & - ,DUMMY_2D_OUT & - ,BILINEAR) -! - IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT -! write(0,*)' after SNO' -! -!----------------------------------------------------------------------- -!*** SI -!----------------------------------------------------------------------- -! - DO J=JMS,JME - DO I=IMS,IME - DUMMY_2D_IN(I,J,1)=solver_int_state%SI(I,J) - ENDDO - ENDDO -! - CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & - ,NLEV & - ,'SI' & - ,DUMMY_2D_OUT & - ,BILINEAR) -! - IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT -! write(0,*)' after SI' -! -!----------------------------------------------------------------------- -!*** SICE -!----------------------------------------------------------------------- -! - DO J=JMS,JME - DO I=IMS,IME - DUMMY_2D_IN(I,J,1)=solver_int_state%SICE(I,J) - ENDDO - ENDDO -! -! write(0,*)' PARENT_TO_CHILD_INIT SICE max=',maxval(DUMMY_2D_IN(IMS:IME,JMS:JME,1)) & -! ,' min=',minval(DUMMY_2D_IN(IMS:IME,JMS:JME,1)) - CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & - ,NLEV & - ,'SICE' & - ,DUMMY_2D_OUT & - ,BILINEAR) -! - IF(MYPE==0)THEN - DO J=1,JM_CHILD - DO I=1,IM_CHILD - SEA_ICE(I,J)=DUMMY_2D_OUT(I,J,1) - ENDDO - ENDDO - ENDIF -! - IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT -! write(0,*)' after SICE' -! -!----------------------------------------------------------------------- -!*** TG -!----------------------------------------------------------------------- -! - DO J=JMS,JME - DO I=IMS,IME - DUMMY_2D_IN(I,J,1)=solver_int_state%TG(I,J) - ENDDO - ENDDO -! - CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & - ,NLEV & - ,'TG' & - ,DUMMY_2D_OUT & - ,BILINEAR) -! - IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT -! write(0,*)' after TG' -! -!----------------------------------------------------------------------- -!*** CMC -!----------------------------------------------------------------------- -! - DO J=JMS,JME - DO I=IMS,IME - DUMMY_2D_IN(I,J,1)=solver_int_state%CMC(I,J) - ENDDO - ENDDO -! - CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & - ,NLEV & - ,'CMC' & - ,DUMMY_2D_OUT & - ,BILINEAR) -! - IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT -! write(0,*)' after CMC' -! -!----------------------------------------------------------------------- -!*** SR -!----------------------------------------------------------------------- -! - DO J=JMS,JME - DO I=IMS,IME - DUMMY_2D_IN(I,J,1)=solver_int_state%SR(I,J) - ENDDO - ENDDO -! - CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & - ,NLEV & - ,'SR' & - ,DUMMY_2D_OUT & - ,BILINEAR) -! - IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT -! write(0,*)' after SR' -! -!----------------------------------------------------------------------- -!*** USTAR -!----------------------------------------------------------------------- -! - DO J=JMS,JME - DO I=IMS,IME - DUMMY_2D_IN(I,J,1)=solver_int_state%USTAR(I,J) - ENDDO - ENDDO -! - CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & - ,NLEV & - ,'USTAR' & - ,DUMMY_2D_OUT & - ,BILINEAR) -! - IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT -! write(0,*)' after USTAR' -! -!----------------------------------------------------------------------- -!*** Z0 -!----------------------------------------------------------------------- -! - DO J=JMS,JME - DO I=IMS,IME - DUMMY_2D_IN(I,J,1)=solver_int_state%Z0(I,J) - ENDDO - ENDDO -! - CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & - ,NLEV & - ,'Z0' & - ,DUMMY_2D_OUT & - ,BILINEAR) -! - IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT -! write(0,*)' after Z0' -! -!----------------------------------------------------------------------- -!*** Z0BASE -!----------------------------------------------------------------------- -! - DO J=JMS,JME - DO I=IMS,IME - DUMMY_2D_IN(I,J,1)=solver_int_state%Z0BASE(I,J) - ENDDO - ENDDO -! - CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & - ,NLEV & - ,'Z0BASE' & - ,DUMMY_2D_OUT & - ,BILINEAR) -! - IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT -! write(0,*)' after Z0BASE' -! -!----------------------------------------------------------------------- -!*** STC -!----------------------------------------------------------------------- -! - CALL PARENT_TO_CHILD_FILL(solver_int_state%STC, NUM_SOIL_LAYERS & - ,'STC' & - ,DUMMY_3DS & - ,BILINEAR) -! - IF(MYPE==0)THEN - DO L=1,NUM_SOIL_LAYERS - DO J=1,JM_CHILD - DO I=1,IM_CHILD - TEMPSOIL(L,I,J)=DUMMY_3DS(I,J,L) - ENDDO - ENDDO - ENDDO -! - WRITE(NFCST)TEMPSOIL - ENDIF -! write(0,*)' after STC' -! -!----------------------------------------------------------------------- -!*** SMC -!----------------------------------------------------------------------- -! - CALL PARENT_TO_CHILD_FILL(solver_int_state%SMC, NUM_SOIL_LAYERS & - ,'SMC' & - ,DUMMY_3DS & - ,BILINEAR) -! - IF(MYPE==0)THEN - DO L=1,NUM_SOIL_LAYERS - DO J=1,JM_CHILD - DO I=1,IM_CHILD - TEMPSOIL(L,I,J)=DUMMY_3DS(I,J,L) - ENDDO - ENDDO - ENDDO -! - WRITE(NFCST)TEMPSOIL - ENDIF -! write(0,*)' after SMC' -! -!----------------------------------------------------------------------- -!*** SH2O -!----------------------------------------------------------------------- -! - CALL PARENT_TO_CHILD_FILL(solver_int_state%SH2O, NUM_SOIL_LAYERS & - ,'SH2O' & - ,DUMMY_3DS & - ,BILINEAR) -! - IF(MYPE==0)THEN - DO L=1,NUM_SOIL_LAYERS - DO J=1,JM_CHILD - DO I=1,IM_CHILD - TEMPSOIL(L,I,J)=DUMMY_3DS(I,J,L) - ENDDO - ENDDO - ENDDO -! - WRITE(NFCST)TEMPSOIL - ENDIF -! write(0,*)' after SH2O' -! -!----------------------------------------------------------------------- -!*** ISLTYP -!----------------------------------------------------------------------- -! - CALL PARENT_TO_CHILD_IFILL(solver_int_state%ISLTYP & - ,'ISLTYP' & - ,IDUMMY_2D ) -! - IF(MYPE==0)THEN - DO J=1,JM_CHILD - DO I=1,IM_CHILD - IF(IDUMMY_2D(I,J)<1.AND.SEA_MASK(I,J)<0.5)THEN - IDUMMY_2D(I,J)=1 !<--------- Bandaid for interpolated soil value=0 while interpolated seamask=0 (i.e, a land point) -! if(abs(IDUMMY_2D(I,J))>50)write(0,*)' write ISLTYP i=',i,' j=',j,' sea_mask=',SEA_MASK(I,J),' isltyp=',IDUMMY_2D(I,J) - ENDIF - ENDDO - ENDDO -! - WRITE(NFCST)IDUMMY_2D - ENDIF -! write(0,*)' after ISLTYP' -! -!----------------------------------------------------------------------- -!*** IVGTYP -!----------------------------------------------------------------------- -! -! write(0,*)' PARENT_TO_CHILD_INIT IVGTYP max=',maxval(solver_int_state%IVGTYP) & -! ,' min=',minval(solver_int_state%IVGTYP),' maxloc=',maxloc(solver_int_state%IVGTYP) & -! ,' minloc=',minloc(solver_int_state%IVGTYP) - CALL PARENT_TO_CHILD_IFILL(solver_int_state%IVGTYP & - ,'IVGTYP' & - ,IDUMMY_2D ) -! - IF(MYPE==0)THEN - DO J=1,JM_CHILD - DO I=1,IM_CHILD - IF(IDUMMY_2D(I,J)<1.AND.SEA_MASK(I,J)<0.5)THEN - IDUMMY_2D(I,J)=1 !<--------- Bandaid for interpolated vegetation value=0 while interpolated seamask=0 (i.e, a land point) - ENDIF - ENDDO - ENDDO -! - WRITE(NFCST)IDUMMY_2D - ENDIF -! write(0,*)' after IVGTYP' -! -!----------------------------------------------------------------------- -!*** VEGFRC -!----------------------------------------------------------------------- -! - DO J=JMS,JME - DO I=IMS,IME - DUMMY_2D_IN(I,J,1)=solver_int_state%VEGFRC(I,J) - ENDDO - ENDDO -! - CALL PARENT_TO_CHILD_FILL(DUMMY_2D_IN & - ,NLEV & - ,'VEGFRC' & - ,DUMMY_2D_OUT & - ,BILINEAR) -! - IF(MYPE==0)THEN - DO J=1,JM_CHILD - DO I=1,IM_CHILD - IF(DUMMY_2D_OUT(I,J,1)>0..AND.(SEA_MASK(I,J)>0.5.OR.SEA_ICE(I,J)>0.))THEN - DUMMY_2D_OUT(I,J,1)=0. !<--------- Bandaid for interpolated veg frac value >0 while interpolated seamask or sice >0 - ENDIF - ENDDO - ENDDO - ENDIF -! - IF(MYPE==0)WRITE(NFCST)DUMMY_2D_OUT -! write(0,*)' after VEGFRC' -! -!----------------------------------------------------------------------- -! - IF(MYPE==0)WRITE(NFCST)DUMMY_SOIL - IF(MYPE==0)WRITE(NFCST)DUMMY_SOIL -! -!----------------------------------------------------------------------- -! - IF(MYPE==0)CLOSE(NFCST) -! -!----------------------------------------------------------------------- -! - DEALLOCATE(IDUMMY_2D) - DEALLOCATE(DUMMY_2D_IN) - DEALLOCATE(DUMMY_2D_OUT) - DEALLOCATE(DUMMY_3D) - DEALLOCATE(DUMMY_3DS) - DEALLOCATE(DUMMY_SOIL) - DEALLOCATE(TEMPSOIL) - DEALLOCATE(SEA_MASK) - DEALLOCATE(PD_BILINEAR) - DEALLOCATE(PD_NEAREST) - DEALLOCATE(LOWER_TOPO) -! -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!!! SUBROUTINE PARENT_TO_CHILD_FILL_ASSOC(PARENT_ARRAY & - SUBROUTINE PARENT_TO_CHILD_FILL (PARENT_ARRAY & - ,NLEV & - ,VBL_NAME & - ,CHILD_ARRAY & - ,METHOD) -! -!----------------------------------------------------------------------- -!*** Rows and columns of the child's grid lie directly on top of -!*** rows and colums of the parent (thus 'ASSOCIATED'). -! -!*** Fill a child's domain with data from the parent. Only the parent -!*** tasks are needed in this routine. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: METHOD & !<-- Interpolaton method (bilinear or nearest neighbor) - ,NLEV !<-- Vertical dimension of the data array -! -!!! REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME,1:NLEV),INTENT(INOUT) :: & -!!! DATA_ARRAY !<-- The parent array that will initialize the child array -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME,1:NLEV),INTENT(IN) :: & - PARENT_ARRAY !<-- The parent array that will initialize the child array -! - CHARACTER(*),INTENT(IN) :: VBL_NAME -! - REAL(kind=KFPT),DIMENSION(1:IM_CHILD,1:JM_CHILD,1:NLEV),INTENT(OUT) :: & !<-- Data from parent tasks interpolated to child grid - CHILD_ARRAY ! but still on parent task 0 -! -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: I,IERR,II,IPE,IPE_LOCAL,ISTAT,J,JJ,L,N,NN - INTEGER(kind=KINT) :: I_COPY,I_END,I_END_COPY,I_EXTENT,I_PARENT_END & - ,I_START_COPY - INTEGER(kind=KINT) :: J_COPY,J_END,J_END_COPY,J_EXTENT,J_PARENT_END & - ,J_START_COPY - INTEGER(kind=KINT) :: INDX_EAST,INDX_NORTH,INDX_SOUTH,INDX_WEST - INTEGER(kind=KINT) :: NWORDS_RECV,NWORDS_SEND -! - INTEGER(kind=KINT),DIMENSION(MPI_STATUS_SIZE) :: JSTAT -! - REAL(kind=KFPT) :: DELTA_I_EAST,DELTA_I_WEST & - ,DELTA_J_NORTH,DELTA_J_SOUTH - REAL(kind=KFPT) :: RATIO,REAL_INDX_I_PARENT,REAL_INDX_J_PARENT - REAL(kind=KFPT) :: WEIGHT_EAST,WEIGHT_NORTH & - ,WEIGHT_SOUTH,WEIGHT_WEST - REAL(kind=KFPT) :: WEIGHT_NE,WEIGHT_NW,WEIGHT_SE,WEIGHT_SW - REAL(kind=KFPT) :: WEIGHT_MAX,WEIGHT_SUM -! - REAL(kind=KFPT),DIMENSION(:) ,ALLOCATABLE :: DATA_BUFFER - REAL(kind=KFPT),DIMENSION(:,:,:),ALLOCATABLE :: ARRAY_STAGE_PARENT -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** To simplify matters somewhat, isolate the minimum subset of -!*** points on the parent domain that underlie the child's domain. -! -!*** The southwest corner of the child always lies directly on a -!*** point in the parent domain. We already know the I,J of that -!*** parent point since it was specified in the configure file. -!*** The number of parent points that are covered by the child is -!*** determined by the child-to-parent grid ratio and the lateral -!*** dimensions of the child's domain. -!----------------------------------------------------------------------- -! - I_PARENT_END=I_PARENT_START & !<-- Easternmost I on parent domain surrounding child domain - +INT((IM_CHILD-1)*CHILD_PARENT_SPACE_RATIO)+1 -! - I_EXTENT=I_PARENT_END-I_PARENT_START+1 -! - J_PARENT_END=J_PARENT_START & !<-- Northernmost J on parent domain surrounding child domain - +INT((JM_CHILD-1)*CHILD_PARENT_SPACE_RATIO)+1 -! - J_EXTENT=J_PARENT_END-J_PARENT_START+1 -! -!----------------------------------------------------------------------- -!*** Create a staging array on parent task 0 that will hold the entire -!*** subset of the parent domain underlying the child. -!*** Then all parent tasks with points in the intersecting region -!*** send their data to parent task 0. -!----------------------------------------------------------------------- -! - parent_stage: IF(MYPE==0)THEN !<-- Parent task 0 -! -!----------------------------------------------------------------------- -! - ALLOCATE(ARRAY_STAGE_PARENT(1:I_EXTENT,1:J_EXTENT,1:NLEV)) !<-- Array holding all parent points in staging region - ! Note that this array begins at (1,1,1), i.e., - ! its indices are relative to the nest. -! -!----------------------------------------------------------------------- -!*** If parent task 0 holds some of the staging region, copy it to -!*** the staging array. -!----------------------------------------------------------------------- -! - IF(I_PARENT_START<=ITE.AND.J_PARENT_START<=JTE)THEN - I_END=MIN(ITE,I_PARENT_END) - J_END=MIN(JTE,J_PARENT_END) -! - DO L=1,NLEV - JJ=0 - DO J=J_PARENT_START,J_END - JJ=JJ+1 -! - II=0 - DO I=I_PARENT_START,I_END - II=II+1 - ARRAY_STAGE_PARENT(II,JJ,L)=PARENT_ARRAY(I,J,L) - ENDDO - ENDDO - ENDDO -! - ENDIF -! -!----------------------------------------------------------------------- -!*** If there are points in the staging region outside of parent task 0 -!*** then task 0 receives those points from the other parent tasks that -!*** contain those points. -!----------------------------------------------------------------------- -! - parent_search: DO IPE=1,NUM_PES_PARENT-1 !<-- Parent task 0 checks other parent fcst tasks for points -! - remote_stage: IF(I_PARENT_START<=LOCAL_IEND (IPE).AND. & !<-- Does remote parent task IPE contain any staging region? - I_PARENT_END >=LOCAL_ISTART(IPE) & ! - .AND. & ! - J_PARENT_START<=LOCAL_JEND (IPE).AND. & ! - J_PARENT_END >=LOCAL_JSTART(IPE))THEN !<-- -! - I_START_COPY=MAX(I_PARENT_START,LOCAL_ISTART(IPE)) !<-- I index of first point in staging region on remote parent task - I_END_COPY =MIN(I_PARENT_END ,LOCAL_IEND (IPE)) !<-- I index of last point in staging region on remote parent task - I_COPY =I_END_COPY-I_START_COPY+1 !<-- I range of points to receive -! - J_START_COPY=MAX(J_PARENT_START,LOCAL_JSTART(IPE)) !<-- J index of first point in staging region on remote parent task - J_END_COPY =MIN(J_PARENT_END ,LOCAL_JEND (IPE)) !<-- J index of last point in staging region on remote parent task - J_COPY =J_END_COPY-J_START_COPY+1 !<-- J range of points to receive -! - NWORDS_RECV=I_COPY*J_COPY*NLEV !<-- Total # of words from remote parent task in staging region -! - ALLOCATE(DATA_BUFFER(1:NWORDS_RECV)) !<-- Allocate buffer array to hold remote task's staging data - CALL MPI_RECV(DATA_BUFFER & !<-- The staging region data from remote parent task IPE - ,NWORDS_RECV & !<-- Total words received - ,MPI_REAL & !<-- Datatype - ,IPE & !<-- Receive from this parent task - ,IPE & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- The MPI communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - NN=0 !<-- Counter for received words -! - DO L=1,NLEV -! - JJ=J_START_COPY-J_PARENT_START - DO J=1,J_COPY - JJ=JJ+1 -! - II=I_START_COPY-I_PARENT_START - DO I=1,I_COPY - II=II+1 - NN=NN+1 - ARRAY_STAGE_PARENT(II,JJ,L)=DATA_BUFFER(NN) !<-- Fill in array with staging region data from parent task IPE - ENDDO - ENDDO - ENDDO -! - DEALLOCATE(DATA_BUFFER) -! - ENDIF remote_stage -! - ENDDO parent_search -! -!----------------------------------------------------------------------- -!*** Now the remaining parent tasks check to see if they contain -!*** any points in the staging region. If they do, gather them -!*** and send them to parent task 0. -!----------------------------------------------------------------------- -! - ELSEIF(MYPE>0.AND.MYPE<=NUM_PES_PARENT-1)THEN parent_stage !<-- All parent forecast tasks other than 0 -! -!----------------------------------------------------------------------- - IF(I_PARENT_START<=ITE.AND.I_PARENT_END>=ITS & !<-- Does this parent task contain any staging region? - .AND. & ! - J_PARENT_START<=JTE.AND.J_PARENT_END>=JTS)THEN !<-- -! - I_START_COPY=MAX(I_PARENT_START,ITS) !<-- I index of first point in staging region on this parent task - I_END_COPY =MIN(I_PARENT_END ,ITE) !<-- I index of last point in staging region on this parent task - I_COPY=I_END_COPY-I_START_COPY+1 !<-- I range of points to send to parent task 0 -! - J_START_COPY=MAX(J_PARENT_START,JTS) !<-- J index of first point in staging region on remote parent task - J_END_COPY =MIN(J_PARENT_END ,JTE) !<-- J index of last point in staging region on remote parent task - J_COPY=J_END_COPY-J_START_COPY+1 !<-- J range of copied points -! - NWORDS_SEND=I_COPY*J_COPY*NLEV !<-- Total number of words from this parent task in staging region - ALLOCATE(DATA_BUFFER(1:NWORDS_SEND),stat=ISTAT) !<-- Allocate the buffer array to hold this task's staging data -! - NN=0 -! - DO L=1,NLEV - DO J=J_START_COPY,J_END_COPY - DO I=I_START_COPY,I_END_COPY - NN=NN+1 - DATA_BUFFER(NN)=PARENT_ARRAY(I,J,L) - ENDDO - ENDDO - ENDDO -! - CALL MPI_SEND(DATA_BUFFER & !<-- The staging region data from this parent task to parent task 0 - ,NWORDS_SEND & !<-- Total words sent - ,MPI_REAL & !<-- Datatype - ,0 & !<-- Send to parent task 0 - ,MYPE & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- The MPI communicator - ,IERR ) -! - DEALLOCATE(DATA_BUFFER) -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF parent_stage -! -!----------------------------------------------------------------------- -!*** The subset of the input array on the parent domain that lies -!*** under the child's domain has been mirrored onto parent task 0. -!*** Parent task 0 will fill out the array to match the child -!*** domain's horizontal grid increments and then parcel out the -!*** appropriate pieces to the corresponding tasks of the child. -!----------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------- -!*** First fill in the southern and western sides of the array. -!*** If bilinear interpolation is specified then only linear -!*** interpolation needs to be used. -!----------------------------------------------------------------------- -! - parent_task_0: IF(MYPE==0)THEN !<-- Parent task 0 -! -!----------------------------------------------------------------------- -! - RATIO=CHILD_PARENT_SPACE_RATIO -! - DO L=1,NLEV -! - CHILD_ARRAY(1,1,L)=ARRAY_STAGE_PARENT(1,1,L) !<-- SW corner of child's array coincides with a parent point -! - DO I=2,IM_CHILD !<-- Move along southern boundary of child's domain - REAL_INDX_I_PARENT=1+(I-1)*RATIO !<-- Exact I index of child point on parent - INDX_WEST=INT(REAL_INDX_I_PARENT) !<-- The parent point's I index west of the child's point - INDX_EAST=INDX_WEST+1 !<-- The parent point's I index east of the child's point - WEIGHT_WEST=INDX_EAST-REAL_INDX_I_PARENT !<-- Interpolation weight given parent's point to the west - WEIGHT_EAST=1.-WEIGHT_WEST !<-- Interpolation weight given parent's point to the east -! - IF(METHOD==NEAREST)THEN !<-- Assign points using nearest neighbors - WEIGHT_MAX=MAX(WEIGHT_WEST,WEIGHT_EAST) - IF(WEIGHT_WEST==WEIGHT_MAX)THEN - CHILD_ARRAY(I,1,L)=ARRAY_STAGE_PARENT(INDX_WEST,1,L) - ELSEIF(WEIGHT_EAST==WEIGHT_MAX)THEN - CHILD_ARRAY(I,1,L)=ARRAY_STAGE_PARENT(INDX_EAST,1,L) - ENDIF -! - ELSEIF(METHOD==BILINEAR)THEN !<-- Assign points using (bi)linear interpolation - CHILD_ARRAY(I,1,L)=WEIGHT_WEST*ARRAY_STAGE_PARENT(INDX_WEST,1,L) & !<-- Value at points along child's southern boundary - +WEIGHT_EAST*ARRAY_STAGE_PARENT(INDX_EAST,1,L) - ELSE - WRITE(0,*)" Attempting to use unknown interpolation method: ",METHOD - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) -! - ENDIF -! - ENDDO -! - DO J=2,JM_CHILD !<-- Move along western boundary of child's domain - REAL_INDX_J_PARENT=1+(J-1)*RATIO !<-- Exact J index of child point on parent - INDX_SOUTH=INT(REAL_INDX_J_PARENT) !<-- The parent point's J index south of the child's point - INDX_NORTH=INDX_SOUTH+1 !<-- The parent point's J index north of the child's point - WEIGHT_SOUTH=INDX_NORTH-REAL_INDX_J_PARENT !<-- Interpolation weight of parent's point to the south - WEIGHT_NORTH=1.-WEIGHT_SOUTH !<-- Interpolation weight of parent's point to the north -! - IF(METHOD==NEAREST)THEN !<-- Assign points using nearest neighbors - WEIGHT_MAX=MAX(WEIGHT_SOUTH,WEIGHT_NORTH) - IF(WEIGHT_SOUTH==WEIGHT_MAX)THEN - CHILD_ARRAY(1,J,L)=ARRAY_STAGE_PARENT(1,INDX_SOUTH,L) - ELSE - CHILD_ARRAY(1,J,L)=ARRAY_STAGE_PARENT(1,INDX_NORTH,L) - ENDIF -! - ELSEIF(METHOD==BILINEAR)THEN !<-- Assign points using (bi)linear interpolation - CHILD_ARRAY(1,J,L)=WEIGHT_SOUTH*ARRAY_STAGE_PARENT(1,INDX_SOUTH,L) & !<-- Value at points along child's western boundary - +WEIGHT_NORTH*ARRAY_STAGE_PARENT(1,INDX_NORTH,L) - ELSE - WRITE(0,*)" Attempting to use unknown interpolation method: ",METHOD - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) -! - ENDIF -! - ENDDO -! -!----------------------------------------------------------------------- -!*** Fill in the interior of the staging array. -!----------------------------------------------------------------------- -! - DO J=2,JM_CHILD - REAL_INDX_J_PARENT=1+(J-1)*RATIO !<-- Exact J index of child point in parent staging region - INDX_SOUTH=INT(REAL_INDX_J_PARENT) !<-- The parent point's J index south of the child's point - INDX_NORTH=INDX_SOUTH+1 !<-- The parent point's J index north of the child's point -! - DELTA_J_NORTH=INDX_NORTH-REAL_INDX_J_PARENT !<-- Parent grid increment from child point to parent point north - DELTA_J_SOUTH=REAL_INDX_J_PARENT-INDX_SOUTH !<-- Parent grid increment from child point to parent point south -! - DO I=2,IM_CHILD - REAL_INDX_I_PARENT=1+(I-1)*RATIO !<-- Exact I index of child point in parent staging region - INDX_WEST=INT(REAL_INDX_I_PARENT) !<-- The parent point's I index west of the child's point - INDX_EAST=INDX_WEST+1 !<-- The parent point's I index east of the child's point -! - DELTA_I_EAST=INDX_EAST-REAL_INDX_I_PARENT - DELTA_I_WEST=REAL_INDX_I_PARENT-INDX_WEST -! - WEIGHT_SW=DELTA_I_EAST*DELTA_J_NORTH !<-- Interpolation weight of parent's point to SW - WEIGHT_SE=DELTA_I_WEST*DELTA_J_NORTH !<-- Interpolation weight of parent's point to SE - WEIGHT_NW=DELTA_I_EAST*DELTA_J_SOUTH !<-- Interpolation weight of parent's point to NW - WEIGHT_NE=DELTA_I_WEST*DELTA_J_SOUTH !<-- Interpolation weight of parent's point to NE -! -!----------------------------------------------------------------------- -! - assign: IF(METHOD==NEAREST)THEN !<-- Assign points using nearest neighbors - WEIGHT_MAX=MAX(WEIGHT_SW,WEIGHT_SE & - ,WEIGHT_NW,WEIGHT_NE) - IF(WEIGHT_SW==WEIGHT_MAX)THEN - CHILD_ARRAY(I,J,L)=ARRAY_STAGE_PARENT(INDX_WEST,INDX_SOUTH,L) - ELSEIF(WEIGHT_SE==WEIGHT_MAX)THEN - CHILD_ARRAY(I,J,L)=ARRAY_STAGE_PARENT(INDX_EAST,INDX_SOUTH,L) - ELSEIF(WEIGHT_NW==WEIGHT_MAX)THEN - CHILD_ARRAY(I,J,L)=ARRAY_STAGE_PARENT(INDX_WEST,INDX_NORTH,L) - ELSEIF(WEIGHT_NE==WEIGHT_MAX)THEN - CHILD_ARRAY(I,J,L)=ARRAY_STAGE_PARENT(INDX_EAST,INDX_NORTH,L) - ENDIF -! - ELSEIF(METHOD==BILINEAR)THEN !<-- Assign points using bilinear interpolation - IF(VBL_NAME/='FIS')THEN - IF(ABS(ARRAY_STAGE_PARENT(INDX_WEST,INDX_SOUTH,L))<1.E-12)WEIGHT_SW=0. - IF(ABS(ARRAY_STAGE_PARENT(INDX_EAST,INDX_SOUTH,L))<1.E-12)WEIGHT_SE=0. - IF(ABS(ARRAY_STAGE_PARENT(INDX_WEST,INDX_NORTH,L))<1.E-12)WEIGHT_NW=0. - IF(ABS(ARRAY_STAGE_PARENT(INDX_EAST,INDX_NORTH,L))<1.E-12)WEIGHT_NE=0. - ENDIF -! - CHILD_ARRAY(I,J,L)=WEIGHT_SW*ARRAY_STAGE_PARENT(INDX_WEST,INDX_SOUTH,L) & !<-- Value at points in child's interior - +WEIGHT_SE*ARRAY_STAGE_PARENT(INDX_EAST,INDX_SOUTH,L) & - +WEIGHT_NW*ARRAY_STAGE_PARENT(INDX_WEST,INDX_NORTH,L) & - +WEIGHT_NE*ARRAY_STAGE_PARENT(INDX_EAST,INDX_NORTH,L) -! - WEIGHT_SUM=WEIGHT_SW+WEIGHT_SE+WEIGHT_NW+WEIGHT_NE - IF(WEIGHT_SUM<0.99.AND.WEIGHT_SUM>0.01)THEN - CHILD_ARRAY(I,J,L)=CHILD_ARRAY(I,J,L)/WEIGHT_SUM !<-- Normalize if some weights are zero (e.g., coastal land Temp) - ENDIF -! - IF(VBL_NAME=='SST')THEN !<-- Include only realistic SST temperatures - WEIGHT_SUM=0. - CHILD_ARRAY(I,J,L)=0. - IF(ARRAY_STAGE_PARENT(INDX_WEST,INDX_SOUTH,L)>200.)THEN - WEIGHT_SUM=WEIGHT_SUM+WEIGHT_SW - CHILD_ARRAY(I,J,L)=WEIGHT_SW*ARRAY_STAGE_PARENT(INDX_WEST,INDX_SOUTH,L) & - +CHILD_ARRAY(I,J,L) - ENDIF - IF(ARRAY_STAGE_PARENT(INDX_EAST,INDX_SOUTH,L)>200.)THEN - WEIGHT_SUM=WEIGHT_SUM+WEIGHT_SE - CHILD_ARRAY(I,J,L)=WEIGHT_SE*ARRAY_STAGE_PARENT(INDX_EAST,INDX_SOUTH,L) & - +CHILD_ARRAY(I,J,L) - ENDIF - IF(ARRAY_STAGE_PARENT(INDX_WEST,INDX_NORTH,L)>200.)THEN - WEIGHT_SUM=WEIGHT_SUM+WEIGHT_NW - CHILD_ARRAY(I,J,L)=WEIGHT_NW*ARRAY_STAGE_PARENT(INDX_WEST,INDX_NORTH,L) & - +CHILD_ARRAY(I,J,L) - ENDIF - IF(ARRAY_STAGE_PARENT(INDX_EAST,INDX_NORTH,L)>200.)THEN - WEIGHT_SUM=WEIGHT_SUM+WEIGHT_NE - CHILD_ARRAY(I,J,L)=WEIGHT_NE*ARRAY_STAGE_PARENT(INDX_EAST,INDX_NORTH,L) & - +CHILD_ARRAY(I,J,L) - ENDIF - IF(WEIGHT_SUM<0.99.AND.WEIGHT_SUM>0.01)THEN - CHILD_ARRAY(I,J,L)=CHILD_ARRAY(I,J,L)/WEIGHT_SUM - ENDIF - ENDIF -! - ELSE - WRITE(0,*)" Attempting to use unknown interpolation method: ",METHOD - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) -! - ENDIF assign -! -!----------------------------------------------------------------------- -! - ENDDO - ENDDO -! - ENDDO -! - DEALLOCATE(ARRAY_STAGE_PARENT) -! -!----------------------------------------------------------------------- -! - ENDIF parent_task_0 -! -!----------------------------------------------------------------------- -! -!!! END SUBROUTINE PARENT_TO_CHILD_FILL_ASSOC - END SUBROUTINE PARENT_TO_CHILD_FILL -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!!! SUBROUTINE PARENT_TO_CHILD_IFILL_ASSOC(PARENT_ARRAY & - SUBROUTINE PARENT_TO_CHILD_IFILL (PARENT_ARRAY & - ,VBL_NAME & - ,CHILD_ARRAY) -! -!----------------------------------------------------------------------- -!*** Rows and columns of the child's grid lie directly on top of -!*** rows and colums of the parent (thus 'ASSOCIATED'). -!*** Fill a child's domain with data from the parent. Only the parent -!*** tasks are needed in this routine. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: & - PARENT_ARRAY !<-- The parent array that will initialize the child array -! - INTEGER(kind=KINT),DIMENSION(1:IM_CHILD,1:JM_CHILD),INTENT(OUT) :: & !<-- Data from parent tasks interpolated to child grid - CHILD_ARRAY ! but still on parent task 0 -! - CHARACTER(*),INTENT(IN) :: VBL_NAME !<-- The variable's name -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: I,IERR,II,IPE,IPE_LOCAL,J,JJ,N,NN - INTEGER(kind=KINT) :: I_COPY,I_END,I_END_COPY,I_EXTENT,I_PARENT_END & - ,I_START_COPY - INTEGER(kind=KINT) :: J_COPY,J_END,J_END_COPY,J_EXTENT,J_PARENT_END & - ,J_START_COPY - INTEGER(kind=KINT) :: INDX_EAST,INDX_NORTH,INDX_SOUTH,INDX_WEST - INTEGER(kind=KINT) :: NWORDS_RECV,NWORDS_SEND -! - INTEGER(kind=KINT),DIMENSION(MPI_STATUS_SIZE) :: JSTAT -! - INTEGER,DIMENSION(:) ,ALLOCATABLE :: DATA_BUFFER - INTEGER,DIMENSION(:,:),ALLOCATABLE :: ARRAY_STAGE_PARENT -! - REAL(kind=KFPT) :: DELTA_I_EAST,DELTA_I_WEST,DELTA_J_NORTH,DELTA_J_SOUTH - REAL(kind=KFPT) :: RATIO,REAL_INDX_I_PARENT,REAL_INDX_J_PARENT - REAL(kind=KFPT) :: WEIGHT_EAST,WEIGHT_NORTH,WEIGHT_SOUTH,WEIGHT_WEST - REAL(kind=KFPT) :: WEIGHT_NE,WEIGHT_NW,WEIGHT_SE,WEIGHT_SW - REAL(kind=KFPT) :: WEIGHT_MAX -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** To simplify matters somewhat, isolate the minimum subset of -!*** points on the parent domain that underlie the child's domain. -! -!*** The southwest corner of the child always lies directly on a -!*** point in the parent domain. We already know the I,J of that -!*** parent point since it was specified in the configure file. -!*** The number of parent points that are covered by the child is -!*** determined by the child-to-parent grid ratio and the lateral -!*** dimensions of the child's domain. -!----------------------------------------------------------------------- -! - I_PARENT_END=I_PARENT_START & !<-- Easternmost I on parent domain surrounding child domain - +INT((IM_CHILD-1)*CHILD_PARENT_SPACE_RATIO)+1 -! - I_EXTENT=I_PARENT_END-I_PARENT_START+1 -! - J_PARENT_END=J_PARENT_START & !<-- Northernmost J on parent domain surrounding child domain - +INT((JM_CHILD-1)*CHILD_PARENT_SPACE_RATIO)+1 -! - J_EXTENT=J_PARENT_END-J_PARENT_START+1 -! -!----------------------------------------------------------------------- -!*** Create a staging array on parent task 0 that will hold the entire -!*** subset of the parent domain underlying the child. -!*** Then all parent tasks with points in the intersecting region -!*** send their data to parent task 0. -!----------------------------------------------------------------------- -! - parent_stage: IF(MYPE==0)THEN !<-- Parent task 0 -! -!----------------------------------------------------------------------- -! - ALLOCATE(ARRAY_STAGE_PARENT(1:I_EXTENT,1:J_EXTENT)) !<-- Array holding all parent points in staging region - ! Note that this array begins at (1,1,1), i.e., - ! its indices are relative to the nest. -! -!----------------------------------------------------------------------- -!*** If parent task 0 holds some of the staging region, copy it to -!*** the staging array. -!----------------------------------------------------------------------- -! - IF(I_PARENT_START<=ITE.AND.J_PARENT_START<=JTE)THEN - I_END=MIN(ITE,I_PARENT_END) - J_END=MIN(JTE,J_PARENT_END) -! - JJ=0 - DO J=J_PARENT_START,J_END - JJ=JJ+1 -! - II=0 - DO I=I_PARENT_START,I_END - II=II+1 - ARRAY_STAGE_PARENT(II,JJ)=PARENT_ARRAY(I,J) - ENDDO - ENDDO -! - ENDIF -! -!----------------------------------------------------------------------- -!*** If there are points in the staging region outside of parent task 0 -!*** then task 0 receives those points from the other parent tasks that -!*** contain those points. -!----------------------------------------------------------------------- -! - parent_search: DO IPE=1,NUM_PES_PARENT-1 !<-- Parent task 0 checks other parent tasks for points -! - remote_stage: IF(I_PARENT_START<=LOCAL_IEND (IPE).AND. & !<-- Does remote parent task IPE contain any staging region? - I_PARENT_END >=LOCAL_ISTART(IPE) & ! - .AND. & ! - J_PARENT_START<=LOCAL_JEND (IPE).AND. & ! - J_PARENT_END >=LOCAL_JSTART(IPE))THEN !<-- -! - I_START_COPY=MAX(I_PARENT_START,LOCAL_ISTART(IPE)) !<-- I index of first point in staging region on remote parent task - I_END_COPY =MIN(I_PARENT_END ,LOCAL_IEND (IPE)) !<-- I index of last point in staging region on remote parent task - I_COPY =I_END_COPY-I_START_COPY+1 !<-- I range of points to receive -! - J_START_COPY=MAX(J_PARENT_START,LOCAL_JSTART(IPE)) !<-- J index of first point in staging region on remote parent task - J_END_COPY =MIN(J_PARENT_END ,LOCAL_JEND (IPE)) !<-- J index of last point in staging region on remote parent task - J_COPY =J_END_COPY-J_START_COPY+1 !<-- J range of points to receive -! - NWORDS_RECV=I_COPY*J_COPY !<-- Total # of words from remote parent task in staging region -! - ALLOCATE(DATA_BUFFER(1:NWORDS_RECV)) !<-- Allocate buffer array to hold remote task's staging data - CALL MPI_RECV(DATA_BUFFER & !<-- The staging region data from remote parent task IPE - ,NWORDS_RECV & !<-- Total words received - ,MPI_INTEGER & !<-- Datatype - ,IPE & !<-- Receive from this parent task - ,IPE & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- The MPI communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - NN=0 !<-- Counter for received words -! - JJ=J_START_COPY-J_PARENT_START - DO J=1,J_COPY - JJ=JJ+1 -! - II=I_START_COPY-I_PARENT_START - DO I=1,I_COPY - II=II+1 - NN=NN+1 - ARRAY_STAGE_PARENT(II,JJ)=DATA_BUFFER(NN) !<-- Fill in array with staging region data from parent task IPE - ENDDO - ENDDO -! - DEALLOCATE(DATA_BUFFER) -! - ENDIF remote_stage -! - ENDDO parent_search -! -!----------------------------------------------------------------------- -!*** Now the remaining parent tasks check to see if they contain -!*** any points in the staging region. If they do, gather them -!*** and send them to parent task 0. -!----------------------------------------------------------------------- -! - ELSEIF(MYPE>0.AND.MYPE<=NUM_PES_PARENT-1)THEN parent_stage !<-- All parent tasks other than 0 -! -!----------------------------------------------------------------------- - IF(I_PARENT_START<=ITE.AND.I_PARENT_END>=ITS & !<-- Does this parent task contain any staging region? - .AND. & ! - J_PARENT_START<=JTE.AND.J_PARENT_END>=JTS)THEN !<-- -! - I_START_COPY=MAX(I_PARENT_START,ITS) !<-- I index of first point in staging region on this parent task - I_END_COPY =MIN(I_PARENT_END ,ITE) !<-- I index of last point in staging region on this parent task - I_COPY=I_END_COPY-I_START_COPY+1 !<-- I range of points to send to parent task 0 -! - J_START_COPY=MAX(J_PARENT_START,JTS) !<-- J index of first point in staging region on remote parent task - J_END_COPY =MIN(J_PARENT_END ,JTE) !<-- J index of last point in staging region on remote parent task - J_COPY=J_END_COPY-J_START_COPY+1 !<-- J range of copied points -! - NWORDS_SEND=I_COPY*J_COPY !<-- Total number of words from this parent task in staging region - ALLOCATE(DATA_BUFFER(1:NWORDS_SEND)) !<-- Allocate the buffer array to hold this task's staging data -! - NN=0 -! - DO J=J_START_COPY,J_END_COPY - DO I=I_START_COPY,I_END_COPY - NN=NN+1 - DATA_BUFFER(NN)=PARENT_ARRAY(I,J) - ENDDO - ENDDO -! - CALL MPI_SEND(DATA_BUFFER & !<-- The staging region data from this parent task to parent task 0 - ,NWORDS_SEND & !<-- Total words sent - ,MPI_INTEGER & !<-- Datatype - ,0 & !<-- Send to parent task 0 - ,MYPE & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- The MPI communicator - ,IERR ) -! - DEALLOCATE(DATA_BUFFER) -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF parent_stage -! -!----------------------------------------------------------------------- -!*** The subset of the input array on the parent domain that lies -!*** under the child's domain has been mirrored onto parent task 0. -!*** Parent task 0 will fill out the array to match the child -!*** domain's horizontal grid increments and then parcel out the -!*** appropriate pieces to the corresponding tasks of the child. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** First fill in the southern and western sides of the array -!*** choosing the nearest parent points. -!----------------------------------------------------------------------- -! - parent_task_0: IF(MYPE==0)THEN !<-- Parent task 0 -! -!----------------------------------------------------------------------- -! - RATIO=CHILD_PARENT_SPACE_RATIO -! - CHILD_ARRAY(1,1)=ARRAY_STAGE_PARENT(1,1) !<-- SW corner of child's array coincides with a parent point -! -!*** Choose nearest parent point along child's southern boundary -! - DO I=2,IM_CHILD !<-- Move along southern boundary of child's domain - REAL_INDX_I_PARENT=1+(I-1)*RATIO !<-- Exact I index of child point on parent - INDX_WEST=INT(REAL_INDX_I_PARENT) !<-- The parent point's I index west of the child's point - INDX_EAST=INDX_WEST+1 !<-- The parent point's I index east of the child's point - WEIGHT_WEST=INDX_EAST-REAL_INDX_I_PARENT !<-- Interpolation weight given parent's point to the west - WEIGHT_EAST=1.-WEIGHT_WEST !<-- Interpolation weight given parent's point to the east -! - WEIGHT_MAX=MAX(WEIGHT_WEST,WEIGHT_EAST) - IF(WEIGHT_WEST==WEIGHT_MAX)THEN - CHILD_ARRAY(I,1)=ARRAY_STAGE_PARENT(INDX_WEST,1) - ELSEIF(WEIGHT_EAST==WEIGHT_MAX)THEN - CHILD_ARRAY(I,1)=ARRAY_STAGE_PARENT(INDX_EAST,1) - ENDIF - ENDDO -! -!*** Choose nearest parent point along child's western boundary -! - DO J=2,JM_CHILD !<-- Move along western boundary of child's domain - REAL_INDX_J_PARENT=1+(J-1)*RATIO !<-- Exact J index of child point on parent - INDX_SOUTH=INT(REAL_INDX_J_PARENT) !<-- The parent point's J index south of the child's point - INDX_NORTH=INDX_SOUTH+1 !<-- The parent point's J index north of the child's point - WEIGHT_SOUTH=INDX_NORTH-REAL_INDX_J_PARENT !<-- Interpolation weight of parent's point to the south - WEIGHT_NORTH=1.-WEIGHT_SOUTH !<-- Interpolation weight of parent's point to the north - WEIGHT_MAX=MAX(WEIGHT_SOUTH,WEIGHT_NORTH) -! - IF(WEIGHT_SOUTH==WEIGHT_MAX)THEN - CHILD_ARRAY(1,J)=ARRAY_STAGE_PARENT(1,INDX_SOUTH) - ELSE - CHILD_ARRAY(1,J)=ARRAY_STAGE_PARENT(1,INDX_NORTH) - ENDIF -! - ENDDO -! -!----------------------------------------------------------------------- -!*** Fill in the interior of the staging array choosing the -!*** nearest parent point. -!----------------------------------------------------------------------- -! - DO J=2,JM_CHILD - REAL_INDX_J_PARENT=1+(J-1)*RATIO !<-- Exact J index of child point in parent staging region - INDX_SOUTH=INT(REAL_INDX_J_PARENT) !<-- The parent point's J index south of the child's point - INDX_NORTH=INDX_SOUTH+1 !<-- The parent point's J index north of the child's point -! - DELTA_J_NORTH=INDX_NORTH-REAL_INDX_J_PARENT - DELTA_J_SOUTH=REAL_INDX_J_PARENT-INDX_SOUTH -! - DO I=2,IM_CHILD - REAL_INDX_I_PARENT=1+(I-1)*RATIO !<-- Exact I index of child point in parent staging region - INDX_WEST=INT(REAL_INDX_I_PARENT) !<-- The parent point's I index west of the child's point - INDX_EAST=INDX_WEST+1 !<-- The parent point's I index east of the child's point -! - DELTA_I_EAST=INDX_EAST-REAL_INDX_I_PARENT - DELTA_I_WEST=REAL_INDX_I_PARENT-INDX_WEST -! - WEIGHT_SW=DELTA_I_EAST*DELTA_J_NORTH !<-- Interpolation weight of parent's point to SW - WEIGHT_SE=DELTA_I_WEST*DELTA_J_NORTH !<-- Interpolation weight of parent's point to SE - WEIGHT_NW=DELTA_I_EAST*DELTA_J_SOUTH !<-- Interpolation weight of parent's point to NW - WEIGHT_NE=DELTA_I_WEST*DELTA_J_SOUTH !<-- Interpolation weight of parent's point to NE -! - WEIGHT_MAX=MAX(WEIGHT_SW,WEIGHT_SE & - ,WEIGHT_NW,WEIGHT_NE) -! - IF(WEIGHT_SW==WEIGHT_MAX)THEN - CHILD_ARRAY(I,J)=ARRAY_STAGE_PARENT(INDX_WEST,INDX_SOUTH) - ELSEIF(WEIGHT_SE==WEIGHT_MAX)THEN - CHILD_ARRAY(I,J)=ARRAY_STAGE_PARENT(INDX_EAST,INDX_SOUTH) - ELSEIF(WEIGHT_NW==WEIGHT_MAX)THEN - CHILD_ARRAY(I,J)=ARRAY_STAGE_PARENT(INDX_WEST,INDX_NORTH) - ELSEIF(WEIGHT_NE==WEIGHT_MAX)THEN - CHILD_ARRAY(I,J)=ARRAY_STAGE_PARENT(INDX_EAST,INDX_NORTH) - ENDIF - ENDDO - ENDDO -! - DEALLOCATE(ARRAY_STAGE_PARENT) -! -!----------------------------------------------------------------------- -! - ENDIF parent_task_0 -! -!----------------------------------------------------------------------- -! -!!! END SUBROUTINE PARENT_TO_CHILD_IFILL_ASSOC - END SUBROUTINE PARENT_TO_CHILD_IFILL -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE PARENT_TO_CHILD_FILL_GENERAL(PARENT_ARRAY & -!!! SUBROUTINE PARENT_TO_CHILD_FILL (PARENT_ARRAY & - ,NLEV & - ,VBL_NAME & - ,CHILD_ARRAY) -! -!----------------------------------------------------------------------- -!*** Parent tasks interpolate their data to the locations of their -!*** children's gridpoints. The child grids are unique rotated -!*** lat/lon grids with their own centers. The southwest H point -!*** of the child grid lies directly on an H point of the parent. -! -!*** Only parent tasks participate in this work. -!----------------------------------------------------------------------- -! - USE module_CONSTANTS,ONLY: PI -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: NLEV !<-- Vertical dimension of the data array -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME,1:NLEV),INTENT(IN) :: & - PARENT_ARRAY !<-- The parent array that will initialize the child array -! - CHARACTER(*),INTENT(IN) :: VBL_NAME !<-- The variable's name -! - REAL(kind=KFPT),DIMENSION(1:IM_CHILD,1:JM_CHILD,1:NLEV),INTENT(OUT) :: & - CHILD_ARRAY !<-- Data from parent tasks interpolated to child grid -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: I,I_END,ISTART,J,J_END,JSTART & - ,KOUNT,L,NIJ,NN,NTOT & - ,NUM_DATA & - ,NUM_CHILD_POINTS & - ,NUM_IJ & - ,NUM_POINTS_REMOTE -! - INTEGER(kind=KINT) :: I_PARENT_SW,I_PARENT_SE & - ,I_PARENT_NW,I_PARENT_NE & - ,J_PARENT_SW,J_PARENT_SE & - ,J_PARENT_NW,J_PARENT_NE -! - INTEGER(kind=KINT) :: IERR,IPE,ISTAT -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: CHILD_POINT_INDICES & - ,IJ_REMOTE -! - INTEGER,DIMENSION(MPI_STATUS_SIZE) :: JSTAT -! - REAL(kind=KFPT) :: CHILD_LATD_ON_PARENT & - ,CHILD_LOND_ON_PARENT & - ,DEG_TO_RAD & - ,DIST & - ,R_DLMD,R_DPHD & - ,REAL_I_PARENT & - ,REAL_J_PARENT & - ,RLATD_SW,RLOND_SW & - ,RLATD_SE,RLOND_SE & - ,RLATD_NW,RLOND_NW & - ,RLATD_NE,RLOND_NE & - ,SUM,SUM_RECIP & - ,WEIGHT_SW,WEIGHT_SE & - ,WEIGHT_NW,WEIGHT_NE & - ,WEIGHT_SUM,WEIGHT_SUM_RECIP -! - REAL(kind=KFPT),DIMENSION(4) :: RLATD,RLOND,WGT -! - REAL(kind=KFPT),DIMENSION(:),ALLOCATABLE :: CHILD_STRING & - ,DATA_REMOTE -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - R_DPHD=1./DPHD_PARENT - R_DLMD=1./DLMD_PARENT - DEG_TO_RAD=PI/180. -! - NUM_CHILD_POINTS=0 -! - ISTART=1 - JSTART=1 - IF(GLOBAL)THEN - ISTART=2 - JSTART=2 - ENDIF -! -!----------------------------------------------------------------------- -!*** Each parent task is responsible for searching the parent domain -!*** extending from ITS and JTS to ITE+1 and JTE+1. Those latter +1's -!*** are needed in order to reach the next gridpoint in each direction. -!*** We cannot go outside the full domain of course plus the wind -!*** points have no values at IDE and JDE. -!----------------------------------------------------------------------- -! - IF(VBL_NAME=='Uwind'.OR.VBL_NAME=='Vwind')THEN - I_END=MIN(ITE+1,IDE-1) - J_END=MIN(JTE+1,JDE-1) - ELSE - I_END=MIN(ITE+1,IDE) - J_END=MIN(JTE+1,JDE) - ENDIF -! -!----------------------------------------------------------------------- -! - NTOT=2*IM_CHILD*JM_CHILD - ALLOCATE(CHILD_POINT_INDICES(1:NTOT),stat=ISTAT) - IF(ISTAT/=0)WRITE(0,*)' Failed to allocate CHILD_POINT_INDICES in PARENT_TO_CHILD_FILL_GENERAL' -! - NTOT=IM_CHILD*JM_CHILD*NLEV - ALLOCATE(CHILD_STRING(1:NTOT),stat=ISTAT) - IF(ISTAT/=0)WRITE(0,*)' Failed to allocate CHILD_STRING in PARENT_TO_CHILD_FILL_GENERAL' -! -!----------------------------------------------------------------------- -!*** Compute the parent's lat/lon of each child gridpoint in order to -!*** determine if that gridpoint lies on a given parent task. -!*** Save the I,J of each gridpoint found since ultimately parent -!*** task 0 will need that to properly place all interpolated child -!*** data onto the full child grid for writing out. -!----------------------------------------------------------------------- -! - NN=0 -! - DO J=1,JM_CHILD - DO I=1,IM_CHILD -! - CALL CONVERT_IJ_TO_LATLON(I,J & !<-- A point on the child grid - ,IM_CHILD,JM_CHILD & !<-- Dimensions of child grid - ,TPH0D_CHILD,TLM0D_CHILD & !<-- Parent lat/lon (deg) of child grid central point - ,DPHD_CHILD,DLMD_CHILD & !<-- Angular grid increments (deg) on child grid - ,CHILD_LATD_ON_PARENT & !<-- Parent latitude of child point - ,CHILD_LOND_ON_PARENT ) !<-- Parent longitude of child point -! - REAL_I_PARENT=(CHILD_LOND_ON_PARENT-WBD_PARENT)*R_DLMD+ISTART !<-- REAL I index of child point on parent grid - REAL_J_PARENT=(CHILD_LATD_ON_PARENT-SBD_PARENT)*R_DPHD+JSTART !<-- REAL J index of child point on parent grid -! -!----------------------------------------------------------------------- -! - IF(REAL(ITS)<=REAL_I_PARENT.AND.REAL(I_END)>REAL_I_PARENT.AND. & !<-- Is child gridpoint on this parent task? - REAL(JTS)<=REAL_J_PARENT.AND.REAL(J_END)>REAL_J_PARENT)THEN !<-- -! - NUM_CHILD_POINTS=NUM_CHILD_POINTS+1 !<-- Add up number of child points on this parent task -! - CHILD_POINT_INDICES(2*NUM_CHILD_POINTS-1)=I !<-- Save I index of this child - CHILD_POINT_INDICES(2*NUM_CHILD_POINTS )=J !<-- Save J index of this child point -! -!----------------------------------------------------------------------- -!*** Compute the distance from the child point location to each of -!*** the four surrounding parent points and generate the bilinear -!*** interpolation weights. -!*** The indices 1-->4 indicate the parent points to the SW, SE, -!*** NW, and NE in that order. -!----------------------------------------------------------------------- -! - I_PARENT_SW=INT(REAL_I_PARENT) - J_PARENT_SW=INT(REAL_J_PARENT) - RLATD(1)=(J_PARENT_SW-ROW_0)*DPHD_PARENT !<-- Parent latitude (deg) of parent point SW of child point - RLOND(1)=(I_PARENT_SW-COL_0)*DLMD_PARENT !<-- Parent longitude (deg) of parent point SW of child point -! - I_PARENT_SE=I_PARENT_SW+1 - J_PARENT_SE=J_PARENT_SW - RLATD(2)=RLATD(1) !<-- SE and SW on same line of parent latitude - RLOND(2)=RLOND(1)+DLMD_PARENT !<-- SE is one gridpoint east of SW parent point -! - I_PARENT_NW=I_PARENT_SW - J_PARENT_NW=J_PARENT_SW+1 - RLATD(3)=RLATD(1)+DPHD_PARENT !<-- NW is one gridpoint north of SW parent point - RLOND(3)=RLOND(1) !<-- NW and SW on same line of parent longitude -! - I_PARENT_NE=I_PARENT_SE - J_PARENT_NE=J_PARENT_NW - RLATD(4)=RLATD(3) !<-- NE and NW on same line of parent latitude - RLOND(4)=RLOND(2) !<-- NE and SE on same line of parent longitude -! - SUM=0. -! - DO N=1,4 !<-- Loop over SW, SE, NW, and NE parent points -! - CALL DISTANCE_ON_SPHERE(CHILD_LATD_ON_PARENT*DEG_TO_RAD & !<-- Parent latitiude (deg) of child gridpoint - ,CHILD_LOND_ON_PARENT*DEG_TO_RAD & !<-- Parent latitiude (deg) of child gridpoint - ,RLATD(N)*DEG_TO_RAD & !<-- Latitude (deg) of surrounding parent point N - ,RLOND(N)*DEG_TO_RAD & !<-- Longitude (deg) of surrounding parent point N - ,DIST ) !<-- Distance (radians) from child point to parent point N -! - WGT(N)=1./DIST - SUM=SUM+WGT(N) -! - ENDDO -! - SUM_RECIP=1./SUM -! -!----------------------------------------------------------------------- -!*** The bilinear interpolation weights of the four parent points -!*** surrounding the child point. -!----------------------------------------------------------------------- -! - WEIGHT_SW=WGT(1)*SUM_RECIP - WEIGHT_SE=WGT(2)*SUM_RECIP - WEIGHT_NW=WGT(3)*SUM_RECIP - WEIGHT_NE=WGT(4)*SUM_RECIP -! - IF(ABS(PARENT_ARRAY(I_PARENT_SW,J_PARENT_SW,1))<1.E-12)WEIGHT_SW=0. - IF(ABS(PARENT_ARRAY(I_PARENT_SE,J_PARENT_SE,1))<1.E-12)WEIGHT_SE=0. - IF(ABS(PARENT_ARRAY(I_PARENT_NW,J_PARENT_NW,1))<1.E-12)WEIGHT_NW=0. - IF(ABS(PARENT_ARRAY(I_PARENT_NE,J_PARENT_NE,1))<1.E-12)WEIGHT_NE=0. - WEIGHT_SUM=WEIGHT_SW+WEIGHT_SE+WEIGHT_NW+WEIGHT_NE - WEIGHT_SUM_RECIP=1./WEIGHT_SUM -! - DO L=1,NLEV - NN=NN+1 -! - CHILD_STRING(NN)=WEIGHT_SW*PARENT_ARRAY(I_PARENT_SW,J_PARENT_SW,L) & !<-- Value at points on child's grid - +WEIGHT_SE*PARENT_ARRAY(I_PARENT_SE,J_PARENT_SE,L) & - +WEIGHT_NW*PARENT_ARRAY(I_PARENT_NW,J_PARENT_NW,L) & - +WEIGHT_NE*PARENT_ARRAY(I_PARENT_NE,J_PARENT_NE,L) -! - IF(WEIGHT_SUM<0.99.AND.WEIGHT_SUM>0.01)THEN - CHILD_STRING(NN)=CHILD_STRING(NN)*WEIGHT_SUM_RECIP !<-- Normalize if some weights are zero (e.g., coastal land Temp) - ENDIF -! - IF(VBL_NAME=='SeaMask')THEN - IF(CHILD_STRING(NN)>=0.5)CHILD_STRING(NN)=1.0 - IF(CHILD_STRING(NN)< 0.5)CHILD_STRING(NN)=0.0 - ENDIF -! - ENDDO -! -!----------------------------------------------------------------------- -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** Each parent task that contains a child grid point has now done -!*** the horizontal interpolation of the parent variable to the child. -!*** Now parent task 0 receives all the interpolated data from the -!*** other parent tasks. -!----------------------------------------------------------------------- -! - data_fill: IF(MYPE==0)THEN -! -!----------------------------------------------------------------------- -! - remote_tasks: DO IPE=1,NUM_PES_PARENT-1 -! - CALL MPI_RECV(NUM_POINTS_REMOTE & !<-- # of child points on parent task IPE - ,1 & !<-- Total words received - ,MPI_INTEGER & !<-- Datatype - ,IPE & !<-- Receive from this parent task - ,IPE & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- The MPI communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - IF(NUM_POINTS_REMOTE==0)CYCLE remote_tasks -! - NUM_IJ =2*NUM_POINTS_REMOTE - NUM_DATA=NUM_POINTS_REMOTE*NLEV -! - ALLOCATE(DATA_REMOTE(1:NUM_DATA)) - ALLOCATE(IJ_REMOTE (1:NUM_IJ )) -! - CALL MPI_RECV(DATA_REMOTE & !<-- Interpolated data on child grid from parent task IPE - ,NUM_DATA & !<-- Total words received - ,MPI_REAL & !<-- Datatype - ,IPE & !<-- Receive from this parent task - ,IPE & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- The MPI communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - CALL MPI_RECV(IJ_REMOTE & !<-- Interpolated data on child grid from parent task IPE - ,NUM_IJ & !<-- Total words received - ,MPI_INTEGER & !<-- Datatype - ,IPE & !<-- Receive from this parent task - ,IPE & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- The MPI communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! -!----------------------------------------------------------------------- -!*** Parent task 0 fills in section of child data from remote -!*** parent task IPE. -!----------------------------------------------------------------------- -! - KOUNT=0 -! - DO L=1,NLEV - DO NIJ=1,NUM_POINTS_REMOTE - KOUNT=KOUNT+1 - I=IJ_REMOTE(2*NIJ-1) - J=IJ_REMOTE(2*NIJ ) - CHILD_ARRAY(I,J,L)=DATA_REMOTE(KOUNT) - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -! - DEALLOCATE(DATA_REMOTE) - DEALLOCATE(IJ_REMOTE) -! -!----------------------------------------------------------------------- -! - ENDDO remote_tasks -! -!----------------------------------------------------------------------- -!*** Finally parent task 0 fills in its own section of the child array. -!----------------------------------------------------------------------- -! - IF(NUM_CHILD_POINTS>0)THEN -! - KOUNT=0 - DO L=1,NLEV - DO N=1,NUM_CHILD_POINTS - KOUNT=KOUNT+1 - I=CHILD_POINT_INDICES(2*N-1) - J=CHILD_POINT_INDICES(2*N ) - CHILD_ARRAY(I,J,L)=CHILD_STRING(KOUNT) - ENDDO - ENDDO -! - ENDIF -! -!----------------------------------------------------------------------- -! - ELSE data_fill -! -!----------------------------------------------------------------------- -!*** Remote parent tasks send their sections of interpolated child -!*** data to parent task 0. -!----------------------------------------------------------------------- -! - CALL MPI_SEND(NUM_CHILD_POINTS & !<-- # of child points on this parent task - ,1 & - ,MPI_INTEGER & !<-- Datatype - ,0 & !<-- Send to parent task 0 - ,MYPE & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- The MPI communicator - ,IERR ) -! - IF(NUM_CHILD_POINTS>0)THEN - NUM_IJ =2*NUM_CHILD_POINTS - NUM_DATA=NUM_CHILD_POINTS*NLEV -! - CALL MPI_SEND(CHILD_STRING & !<-- Interpolated data on child grid for this parent task - ,NUM_DATA & !<-- Total words sent - ,MPI_REAL & !<-- Datatype - ,0 & !<-- Send to parent task 0 - ,MYPE & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- The MPI communicator - ,IERR ) -! - CALL MPI_SEND(CHILD_POINT_INDICES & !<-- Indices of child points for this parent task - ,NUM_IJ & !<-- Total words sent - ,MPI_INTEGER & !<-- Datatype - ,0 & !<-- Send to parent task 0 - ,MYPE & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- The MPI communicator - ,IERR ) -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF data_fill -! -!----------------------------------------------------------------------- -! - DEALLOCATE(CHILD_POINT_INDICES) - DEALLOCATE(CHILD_STRING) -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PARENT_TO_CHILD_FILL_GENERAL -!!! END SUBROUTINE PARENT_TO_CHILD_FILL -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE PARENT_TO_CHILD_IFILL_GENERAL(PARENT_ARRAY & -!!! SUBROUTINE PARENT_TO_CHILD_IFILL (PARENT_ARRAY & - ,VBL_NAME & - ,CHILD_ARRAY) -! -!----------------------------------------------------------------------- -!*** Parent tasks interpolate their data to the locations of their -!*** children's gridpoints. The child grids are unique rotated -!*** lat/lon grids with their own centers. The southwest H point -!*** of the child grid lies directly on an H point of the parent. -! -!*** Only parent tasks participate in this work. -!----------------------------------------------------------------------- -! - USE module_CONSTANTS,ONLY: PI -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: & - PARENT_ARRAY !<-- The parent array that will initialize the child array -! - CHARACTER(*),INTENT(IN) :: VBL_NAME !<-- The variable's name -! - INTEGER(kind=KINT),DIMENSION(1:IM_CHILD,1:JM_CHILD),INTENT(OUT) :: & - CHILD_ARRAY !<-- Data from parent tasks interpolated to child grid -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: I,I_END,ISTART,J,J_END,JSTART & - ,KOUNT,NIJ,NN,NTOT & - ,NUM_DATA & - ,NUM_CHILD_POINTS & - ,NUM_IJ & - ,NUM_POINTS_REMOTE -! - INTEGER(kind=KINT) :: I_PARENT_SW,I_PARENT_SE & - ,I_PARENT_NW,I_PARENT_NE & - ,J_PARENT_SW,J_PARENT_SE & - ,J_PARENT_NW,J_PARENT_NE -! - INTEGER(kind=KINT) :: IERR,IPE,ISTAT -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: CHILD_POINT_INDICES & - ,CHILD_STRING & - ,DATA_REMOTE & - ,IJ_REMOTE -! - INTEGER,DIMENSION(MPI_STATUS_SIZE) :: JSTAT -! - REAL(kind=KFPT) :: CHILD_LATD_ON_PARENT & - ,CHILD_LOND_ON_PARENT & - ,DEG_TO_RAD & - ,DIST & - ,R_DLMD,R_DPHD & - ,REAL_I_PARENT & - ,REAL_J_PARENT & - ,RLATD_SW,RLOND_SW & - ,RLATD_SE,RLOND_SE & - ,RLATD_NW,RLOND_NW & - ,RLATD_NE,RLOND_NE & - ,SUM,SUM_RECIP & - ,WEIGHT_SW,WEIGHT_SE & - ,WEIGHT_NW,WEIGHT_NE & - ,WEIGHT_MAX -! - REAL(kind=KFPT),DIMENSION(4) :: RLATD,RLOND,WGT -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - R_DPHD=1./DPHD_PARENT - R_DLMD=1./DLMD_PARENT - DEG_TO_RAD=PI/180. -! - NUM_CHILD_POINTS=0 -! - ISTART=1 - JSTART=1 - IF(GLOBAL)THEN - ISTART=2 - JSTART=2 - ENDIF -! -!----------------------------------------------------------------------- -!*** Each parent task is responsible for searching the parent domain -!*** extending from ITS and JTS to ITE+1 and JTE+1. Those latter +1's -!*** are needed in order to reach the next gridpoint in each direction. -!*** We cannot go outside the full domain of course. -!----------------------------------------------------------------------- -! - I_END=MIN(ITE+1,IDE) - J_END=MIN(JTE+1,JDE) -! -!----------------------------------------------------------------------- -! - NTOT=2*IM_CHILD*JM_CHILD - ALLOCATE(CHILD_POINT_INDICES(1:NTOT),stat=ISTAT) - IF(ISTAT/=0)WRITE(0,*)' Failed to allocate CHILD_POINT_INDICES in PARENT_TO_CHILD_IFILL_GENERAL' -! - NTOT=IM_CHILD*JM_CHILD - ALLOCATE(CHILD_STRING(1:NTOT),stat=ISTAT) - IF(ISTAT/=0)WRITE(0,*)' Failed to allocate CHILD_STRING in PARENT_TO_CHILD_IFILL_GENERAL' -! -!----------------------------------------------------------------------- -!*** Compute the parent's lat/lon of each child gridpoint in order to -!*** determine if that gridpoint lies on a given parent task. -!*** Save the I,J of each gridpoint found since ultimately parent -!*** task 0 will need that to properly place all interpolated child -!*** data onto the full child grid for writing out. -!----------------------------------------------------------------------- -! - NN=0 -! - DO J=1,JM_CHILD - DO I=1,IM_CHILD -! - CALL CONVERT_IJ_TO_LATLON(I,J & !<-- A point on the child grid - ,IM_CHILD,JM_CHILD & !<-- Dimensions of child grid - ,TPH0D_CHILD,TLM0D_CHILD & !<-- Parent lat/lon (deg) of child grid central point - ,DPHD_CHILD,DLMD_CHILD & !<-- Angular grid increments (deg) on child grid - ,CHILD_LATD_ON_PARENT & !<-- Parent latitude of child point - ,CHILD_LOND_ON_PARENT ) !<-- Parent longitude of child point -! - REAL_I_PARENT=(CHILD_LOND_ON_PARENT-WBD_PARENT)*R_DLMD+ISTART !<-- REAL I index of child point on parent grid - REAL_J_PARENT=(CHILD_LATD_ON_PARENT-SBD_PARENT)*R_DPHD+JSTART !<-- REAL J index of child point on parent grid -! -!----------------------------------------------------------------------- -! - IF(REAL(ITS)<=REAL_I_PARENT.AND.REAL(I_END)>REAL_I_PARENT.AND. & !<-- Is child gridpoint on this parent task? - REAL(JTS)<=REAL_J_PARENT.AND.REAL(J_END)>REAL_J_PARENT)THEN !<-- -! - NUM_CHILD_POINTS=NUM_CHILD_POINTS+1 !<-- Add up number of child points on this parent task -! - CHILD_POINT_INDICES(2*NUM_CHILD_POINTS-1)=I !<-- Save I index of this child - CHILD_POINT_INDICES(2*NUM_CHILD_POINTS )=J !<-- Save J index of this child point -! -!----------------------------------------------------------------------- -!*** Compute the distance from the child point location to each of -!*** the four surrounding parent points and generate the bilinear -!*** interpolation weights. -!*** The indices 1-->4 indicate the parent points to the SW, SE, -!*** NW, and NE in that order. -!----------------------------------------------------------------------- -! - I_PARENT_SW=INT(REAL_I_PARENT) - J_PARENT_SW=INT(REAL_J_PARENT) - RLATD(1)=(J_PARENT_SW-ROW_0)*DPHD_PARENT !<-- Parent latitude (deg) of parent point SW of child point - RLOND(1)=(I_PARENT_SW-COL_0)*DLMD_PARENT !<-- Parent longitude (deg) of parent point SW of child point -! - I_PARENT_SE=I_PARENT_SW+1 - J_PARENT_SE=J_PARENT_SW - RLATD(2)=RLATD(1) !<-- SE and SW on same line of parent latitude - RLOND(2)=RLOND(1)+DLMD_PARENT !<-- SE is one gridpoint east of SW parent point -! - I_PARENT_NW=I_PARENT_SW - J_PARENT_NW=J_PARENT_SW+1 - RLATD(3)=RLATD(1)+DPHD_PARENT !<-- NW is one gridpoint north of SW parent point - RLOND(3)=RLOND(1) !<-- NW and SW on same line of parent longitude -! - I_PARENT_NE=I_PARENT_SE - J_PARENT_NE=J_PARENT_NW - RLATD(4)=RLATD(3) !<-- NE and NW on same line of parent latitude - RLOND(4)=RLOND(2) !<-- NE and SE on same line of parent longitude -! - SUM=0. -! - DO N=1,4 !<-- Loop over SW, SE, NW, and NE parent points -! - CALL DISTANCE_ON_SPHERE(CHILD_LATD_ON_PARENT*DEG_TO_RAD & !<-- Parent latitiude (deg) of child gridpoint - ,CHILD_LOND_ON_PARENT*DEG_TO_RAD & !<-- Parent latitiude (deg) of child gridpoint - ,RLATD(N)*DEG_TO_RAD & !<-- Latitude (deg) of surrounding parent point N - ,RLOND(N)*DEG_TO_RAD & !<-- Longitude (deg) of surrounding parent point N - ,DIST ) !<-- Distance (radians) from child point to parent point N -! - WGT(N)=1./DIST - SUM=SUM+WGT(N) -! - ENDDO -! - SUM_RECIP=1./SUM -! -!----------------------------------------------------------------------- -!*** The bilinear interpolation weights of the four parent points -!*** surrounding the child point. -!----------------------------------------------------------------------- -! - WEIGHT_SW=WGT(1)*SUM_RECIP - WEIGHT_SE=WGT(2)*SUM_RECIP - WEIGHT_NW=WGT(3)*SUM_RECIP - WEIGHT_NE=WGT(4)*SUM_RECIP - WEIGHT_MAX=MAX(WEIGHT_SW,WEIGHT_SE,WEIGHT_NW,WEIGHT_NE) -! -!----------------------------------------------------------------------- -!*** Using the bilinear interpolation weights, assign the value of -!*** the nearest parent point to the child point. -!----------------------------------------------------------------------- -! - NN=NN+1 -! - IF(WEIGHT_SW==WEIGHT_MAX)THEN - CHILD_STRING(NN)=PARENT_ARRAY(I_PARENT_SW,J_PARENT_SW) -! write(0,*)' SW parent=',PARENT_ARRAY(I_PARENT_SW,J_PARENT_SW),' nn=',nn,' i=',i,' j=',j - ELSEIF(WEIGHT_SE==WEIGHT_MAX)THEN - CHILD_STRING(NN)=PARENT_ARRAY(I_PARENT_SE,J_PARENT_SE) -! write(0,*)' SE parent=',PARENT_ARRAY(I_PARENT_SE,J_PARENT_SE),' nn=',nn,' i=',i,' j=',j - ELSEIF(WEIGHT_NW==WEIGHT_MAX)THEN - CHILD_STRING(NN)=PARENT_ARRAY(I_PARENT_NW,J_PARENT_NW) -! write(0,*)' NW parent=',PARENT_ARRAY(I_PARENT_NW,J_PARENT_NW),' nn=',nn,' i=',i,' j=',j - ELSEIF(WEIGHT_NE==WEIGHT_MAX)THEN - CHILD_STRING(NN)=PARENT_ARRAY(I_PARENT_NE,J_PARENT_NE) -! write(0,*)' NE parent=',PARENT_ARRAY(I_PARENT_NE,J_PARENT_NE),' nn=',nn,' i=',i,' j=',j - ENDIF -! if(i==01.and.j==01.and.vbl_name=='ISLTYP')then -! write(0,*)' parent interp value to ISLTYP is ',CHILD_STRING(NN),' nn=',nn -! endif -! if(vbl_name=='ISLTYP'.and.child_string(nn)<1.and.sea_mask(i,j)<0.5)then -! write(0,*)' Parent creating bad value of ISLTYP=',CHILD_STRING(NN),' nn=',nn,' i=',i,' j=',j & -! ,' SeaMask=',sea_mask(i,j) -! endif - -! -!----------------------------------------------------------------------- -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** Each parent task that contains a child grid point has now done -!*** the horizontal interpolation of the parent variable to the child. -!*** Now parent task 0 receives all the interpolated data from the -!*** other parent tasks. -!----------------------------------------------------------------------- -! - data_fill: IF(MYPE==0)THEN -! -!----------------------------------------------------------------------- -! - remote_tasks: DO IPE=1,NUM_PES_PARENT-1 -! - CALL MPI_RECV(NUM_POINTS_REMOTE & !<-- # of child points on parent task IPE - ,1 & !<-- Total words received - ,MPI_INTEGER & !<-- Datatype - ,IPE & !<-- Receive from this parent task - ,IPE & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- The MPI communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - IF(NUM_POINTS_REMOTE==0)CYCLE remote_tasks -! - NUM_IJ =2*NUM_POINTS_REMOTE - NUM_DATA=NUM_POINTS_REMOTE -! - ALLOCATE(DATA_REMOTE(1:NUM_DATA)) - ALLOCATE(IJ_REMOTE (1:NUM_IJ )) -! - CALL MPI_RECV(DATA_REMOTE & !<-- Interpolated data on child grid from parent task IPE - ,NUM_DATA & !<-- Total words received - ,MPI_INTEGER & !<-- Datatype - ,IPE & !<-- Receive from this parent task - ,IPE & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- The MPI communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - CALL MPI_RECV(IJ_REMOTE & !<-- Interpolated data on child grid from parent task IPE - ,NUM_IJ & !<-- Total words received - ,MPI_INTEGER & !<-- Datatype - ,IPE & !<-- Receive from this parent task - ,IPE & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- The MPI communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! -!----------------------------------------------------------------------- -!*** Parent task 0 fills in section of child data from remote -!*** parent task IPE. -!----------------------------------------------------------------------- -! - KOUNT=0 -! - DO NIJ=1,NUM_POINTS_REMOTE - KOUNT=KOUNT+1 - I=IJ_REMOTE(2*NIJ-1) - J=IJ_REMOTE(2*NIJ ) - CHILD_ARRAY(I,J)=DATA_REMOTE(KOUNT) -! write(0,*)' new child i=',i,' j=',j,' kount=',kount,' data=',data_remote(kount) -! if(vbl_name=='ISLTYP'.and.i==01.and.j==01)then -! write(0,*)' parent fills ISLTYP with ',DATA_REMOTE(KOUNT),' kount=',kount -! endif - ENDDO -! -!----------------------------------------------------------------------- -! - DEALLOCATE(DATA_REMOTE) - DEALLOCATE(IJ_REMOTE) -! -!----------------------------------------------------------------------- -! - ENDDO remote_tasks -! -!----------------------------------------------------------------------- -!*** Finally parent task 0 fills in its own section of the child array. -!----------------------------------------------------------------------- -! - IF(NUM_CHILD_POINTS>0)THEN -! - KOUNT=0 - DO N=1,NUM_CHILD_POINTS - KOUNT=KOUNT+1 - I=CHILD_POINT_INDICES(2*N-1) - J=CHILD_POINT_INDICES(2*N ) - CHILD_ARRAY(I,J)=CHILD_STRING(KOUNT) - ENDDO -! - ENDIF -! -!----------------------------------------------------------------------- -! - ELSE data_fill -! -!----------------------------------------------------------------------- -!*** Remote parent tasks send their sections of interpolated child -!*** data to parent task 0. -!----------------------------------------------------------------------- -! - CALL MPI_SEND(NUM_CHILD_POINTS & !<-- # of child points on this parent task - ,1 & - ,MPI_INTEGER & !<-- Datatype - ,0 & !<-- Send to parent task 0 - ,MYPE & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- The MPI communicator - ,IERR ) -! - IF(NUM_CHILD_POINTS>0)THEN - NUM_IJ =2*NUM_CHILD_POINTS - NUM_DATA=NUM_CHILD_POINTS -! - CALL MPI_SEND(CHILD_STRING & !<-- Interpolated data on child grid for this parent task - ,NUM_DATA & !<-- Total words sent - ,MPI_INTEGER & !<-- Datatype - ,0 & !<-- Send to parent task 0 - ,MYPE & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- The MPI communicator - ,IERR ) -! - CALL MPI_SEND(CHILD_POINT_INDICES & !<-- Indices of child points for this parent task - ,NUM_IJ & !<-- Total words sent - ,MPI_INTEGER & !<-- Datatype - ,0 & !<-- Send to parent task 0 - ,MYPE & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- The MPI communicator - ,IERR ) -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF data_fill -! -!----------------------------------------------------------------------- -! - DEALLOCATE(CHILD_POINT_INDICES) - DEALLOCATE(CHILD_STRING) -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PARENT_TO_CHILD_IFILL_GENERAL -!!! END SUBROUTINE PARENT_TO_CHILD_IFILL -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PARENT_TO_CHILD_INIT_NMM -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE CONVERT_IJ_TO_LATLON (I_INDEX & - ,J_INDEX & - ,IM & - ,JM & - ,TPH0D & - ,TLM0D & - ,DPHD & - ,DLMD & - ,RLATD & - ,RLOND) -! -!----------------------------------------------------------------------- -!*** Given the (I,J) of mass points on an Arakawa B-Grid, -!*** compute the latitudes and longitudes before rotation. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: I_INDEX & !<-- I value on the grid - ,J_INDEX & !<-- J value on the grid - ,IM & !<-- Full I dimension - ,JM !<-- Full J dimension -! - REAL(kind=KFPT),INTENT(IN) :: DPHD & !<-- Latitude grid increment (degrees) - ,DLMD & !<-- Longitude grid increment (degrees) - ,TPH0D & ! Central latitude (deg, positive north), unrotated system - ,TLM0D ! Central longitude (deg, positive east), unrotated system -! - REAL(kind=KFPT),INTENT(OUT) :: RLATD & !<-- Latitude (deg, positive north) of point, unrotated system - ,RLOND !<-- Longitude (deg, positive east) of point, unrotated system -! -!----------------------------------------------------------------------- -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: I,IEND,ISTART,J,JEND,JSTART -! - REAL(kind=KDBL) :: ARG1,ARG2,COL_MID,D2R,FCTR,GLATR,GLATD,GLOND & - ,HALF,ONE,PI,R2D,ROW_MID,TLATD,TLOND & - ,TLATR,TLONR,TLM0,TPH0 -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -!*** Convert from transformed grid location (I,J) -!*** to geographic coordinates (degrees). -!----------------------------------------------------------------------- -! - ONE=1.0 - HALF=1./2. - PI=DACOS(-ONE) - D2R=PI/180. - R2D=1./D2R - TPH0=TPH0D*D2R - TLM0=TLM0D*D2R -! - ROW_MID=(JM+ONE)*HALF - COL_MID=(IM+ONE)*HALF -! -!----------------------------------------------------------------------- -! - J=J_INDEX - I=I_INDEX -! -!----------------------------------------------------------------------- -!*** Find the rotated latitude (positive north) and -!*** longitude (positive east). -!----------------------------------------------------------------------- -! - TLATD=(J-ROW_MID)*DPHD - TLOND=(I-COL_MID)*DLMD -! -! WRITE(0,50)I,J,TLATD,TLOND - 50 FORMAT(' I=',I4,' J=',I4,' ROTATED LATITUDE IS',F8.3 & - ,4X,'LONGITUDE IS',F8.3) -! -!----------------------------------------------------------------------- -!*** Now convert to geographic latitude (positive north) and -!*** longitude (positive west) in degrees. -!----------------------------------------------------------------------- -! - TLATR=TLATD*D2R - TLONR=TLOND*D2R - ARG1=SIN(TLATR)*COS(TPH0)+COS(TLATR)*SIN(TPH0)*COS(TLONR) - GLATR=ASIN(ARG1) -! - GLATD=GLATR*R2D -! - ARG2=DCOS(TLATR)*DCOS(TLONR)/(DCOS(GLATR)*DCOS(TPH0))- & - DTAN(GLATR)*DTAN(TPH0) - IF(ABS(ARG2)>1.)ARG2=ABS(ARG2)/ARG2 - FCTR=1. - IF(TLOND>0.)FCTR=1. - IF(TLOND>180.)FCTR=-1. -! - GLOND=-TLM0D+FCTR*DACOS(ARG2)*R2D -! -! WRITE(6,100)I,J,GLATD,GLOND - 100 FORMAT(' I=',I3,' J=',I3 & - ,' PARENT LATITUDE=',F9.5,' LONGITUDE=',F10.5) -!----------------------------------------------------------------------- -! - RLATD=GLATD - RLOND=-GLOND - IF(RLOND<-180.)RLOND=RLOND+360. -! -!----------------------------------------------------------------------- -! - END SUBROUTINE CONVERT_IJ_TO_LATLON -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE REAL_IJ_TO_LATLON (I_INDEX & - ,J_INDEX & - ,IM & - ,JM & - ,TPH0 & - ,TLM0 & - ,DPH & - ,DLM & - ,RLAT & - ,RLON ) -! -!----------------------------------------------------------------------- -!*** Given the (I,J) of mass points on an Arakawa B-Grid, compute -!*** the latitudes and longitudes on the given projection. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: IM & !<-- Full I dimension - ,JM !<-- Full J dimension -! - REAL(kind=KFPT),INTENT(IN) :: I_INDEX & !<-- Real I value on the grid - ,J_INDEX & !<-- Real J value on the grid - ,DPH & !<-- Latitude grid increment (radians) - ,DLM & !<-- Longitude grid increment (radians) - ,TPH0 & !<-- Central latitude (rad, positive north) of projection - ,TLM0 !<-- Central longitude (rad, positive east) of projection -! - REAL(kind=KFPT),INTENT(OUT) :: RLAT & !<-- Latitude (rad, positive north) of point on projection - ,RLON !<-- Longitude (rad, positive east) of point on projection -! -!----------------------------------------------------------------------- -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: I,IEND,ISTART,J,JEND,JSTART -! - REAL(kind=KDBL) :: ARG1,ARG2,COL_MID,FCTR,GLATR,GLATD,GLOND & - ,HALF,ONE,PI,R2D,ROW_MID,TLAT,TLON -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -!*** Convert from transformed grid location (I,J) -!*** to geographic coordinates (degrees). -!----------------------------------------------------------------------- -! - ONE=1.0 - HALF=1./2. - PI=DACOS(-ONE) - R2D=180./PI -! - ROW_MID=(JM+ONE)*HALF - COL_MID=(IM+ONE)*HALF -! -!----------------------------------------------------------------------- -! - J=J_INDEX - I=I_INDEX -! -!----------------------------------------------------------------------- -!*** Find the rotated latitude (positive north) and -!*** longitude (positive east). -!----------------------------------------------------------------------- -! - TLAT=(J-ROW_MID)*DPH - TLON=(I-COL_MID)*DLM -! -! WRITE(0,50)I,J,TLAT*R2D,TLOND*R2D - 50 FORMAT(' I=',I4,' J=',I4,' Projection latitude=',F8.3 & - ,4X,'longitude=',F8.3) -! -!----------------------------------------------------------------------- -!*** Now convert to geographic latitude (positive north) and -!*** longitude (positive west) in degrees. -!----------------------------------------------------------------------- -! - ARG1=DSIN(TLAT)*COS(TPH0)+DCOS(TLAT)*SIN(TPH0)*DCOS(TLON) - RLAT=ASIN(ARG1) -! - ARG2=DCOS(TLAT)*DCOS(TLON)/(DCOS(TLAT)*COS(TPH0))- & - DTAN(TLAT)*TAN(TPH0) - IF(ABS(ARG2)>1.)ARG2=ABS(ARG2)/ARG2 - FCTR=1. - IF(TLON>0.)FCTR=1. - IF(TLON>PI)FCTR=-1. -! - RLON=-TLM0+FCTR*DACOS(ARG2) - RLON=-RLON - IF(RLON<-PI)RLON=RLON+PI*2. -! -! WRITE(6,100)I,J,RLAT*R2D,RLON*R2D - 100 FORMAT(' I=',I4,' J=',I4 & - ,' Geographic latitude=',F9.5,' longitude=',F10.5) -! -!----------------------------------------------------------------------- -! - END SUBROUTINE REAL_IJ_TO_LATLON -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE GEO_TO_ROT_LATLON(GLAT,GLON,TPH0,TLM0 & - ,RLAT,RLON ) -! -!----------------------------------------------------------------------- -!*** Convert from geographic coordinates to latitude/longitude on -!*** a rotated projection. -!----------------------------------------------------------------------- -! - USE module_CONSTANTS,ONLY: PI -! -!------------------------ -!*** Argument Variables -!------------------------ -! - REAL(kind=KFPT),INTENT(IN) :: GLAT,GLON & !<-- Geographic lat/lon (rad, +east) of point - ,TPH0,TLM0 !<-- Geographic lat/lon (rad, +east) of projection center -! - REAL(kind=KFPT),INTENT(OUT) :: RLAT,RLON !<-- Lat/lon (rad) of point on the projection -! -!----------------------------------------------------------------------- -! -!-------------------- -!*** Local Variables -!-------------------- -! - REAL(kind=KFPT) :: X,Y,Z -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - X=COS(TPH0)*COS(GLAT)*COS(GLON-TLM0)+SIN(TPH0)*SIN(GLAT) - Y=COS(GLAT)*SIN(GLON-TLM0) - Z=COS(TPH0)*SIN(GLAT)-SIN(TPH0)*COS(GLAT)*COS(GLON-TLM0) - RLAT=ATAN(Z/SQRT(X*X+Y*Y)) - RLON=ATAN(Y/X) - IF(X<0.)THEN - RLON=RLON+PI - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE GEO_TO_ROT_LATLON -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE DISTANCE_ON_SPHERE(RLAT_1,RLON_1 & - ,RLAT_2,RLON_2 & - ,DISTANCE ) -! -!----------------------------------------------------------------------- -!*** Compute the great circle distance between two points on the -!*** spherical earth. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - REAL(kind=KFPT),INTENT(IN) :: RLAT_1,RLON_1 & !<-- Lat/lon (rad, +east) of point 1 - ,RLAT_2,RLON_2 !<-- Lat/lon (rad, +east) of point 2 -! - REAL(kind=KFPT),INTENT(OUT) :: DISTANCE !<-- Distance (radians) between points 1 and 2 -! -!----------------------------------------------------------------------- -! -!-------------------- -!*** Local Variables -!-------------------- -! - REAL(kind=KDBL) :: ALPHA,ARG,BETA,CROSS,DLON,PI_H -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - PI_H=ACOS(0.) -! -!----------------------------------------------------------------------- -! - DLON=RLON_2-RLON_1 -! - CROSS=ACOS(COS(DLON)*COS(RLAT_2)) - ARG=TAN(RLAT_2)/SIN(DLON) - ALPHA=ATAN(ARG) - IF(DLON<0.)ALPHA=-ALPHA - BETA=PI_H-ALPHA -! - DISTANCE=ACOS(COS(RLAT_1)*COS(RLAT_2)*COS(DLON) & - +SIN(RLAT_1)*SIN(CROSS)*COS(BETA)) -! -!----------------------------------------------------------------------- -! - END SUBROUTINE DISTANCE_ON_SPHERE -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- - SUBROUTINE CENTER_NEST(SBD_DOMAIN & - ,WBD_DOMAIN & - ,SW_CORNER_LATD & - ,SW_CORNER_LOND & - ,TPH0D_DOMAIN & - ,TLM0D_DOMAIN ) -!----------------------------------------------------------------------- -!*** Given the southern and western boundaries of a rotated lat/lon -!*** grid as well as the coordinates of the southwest corner point, -!*** find the coordinates of the grid's central point with respect -!*** to the grid upon which the rotated grid lies. -!----------------------------------------------------------------------- -! -!--------------- -!*** Arguments -!--------------- -! - REAL(kind=KFPT),INTENT(IN) :: SBD_DOMAIN & !<-- Latitude (deg) of domain's southern boundary - ,WBD_DOMAIN & !<-- Longitude (deg, +east) of domain's western boundary - ,SW_CORNER_LATD & !<-- Latitude (deg) of domain's southwest corner point - ,SW_CORNER_LOND !<-- Longitude (deg, +east) of domain's southwest corner point -! - REAL(kind=KFPT),INTENT(OUT) :: TPH0D_DOMAIN & !<-- Latitude (deg) of domain's center - ,TLM0D_DOMAIN !<-- Longitude (deg) of domain's center -! -!----------------------------------------------------------------------- -! -!--------------------- -!*** Local Variables -!--------------------- -! - REAL(kind=KFPT) :: ALPHA,BETA,CENTRAL_LAT,CENTRAL_LON & - ,DEG_RAD,DELTA,GAMMA & - ,PI_2,SB_R,SIDE1,SIDE2,SIDE3,SIDE4,SIDE5 & - ,SW_LAT,SW_LON,WB_R -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - PI_2=ACOS(0.) - DEG_RAD=PI_2/90. -! -!----------------------------------------------------------------------- -!*** Southern and western boundaries of the rotated domain in radians. -!----------------------------------------------------------------------- -! - SB_R=-SBD_DOMAIN*DEG_RAD - WB_R=-WBD_DOMAIN*DEG_RAD -! -!----------------------------------------------------------------------- -!*** Southwest corner of the domain in radians. -!----------------------------------------------------------------------- -! - SW_LAT=SW_CORNER_LATD*DEG_RAD - SW_LON=SW_CORNER_LOND*DEG_RAD -! -!----------------------------------------------------------------------- -!*** SIDE1 is the arc from the southwest corner to the center -!*** of the domain. -!----------------------------------------------------------------------- -! - SIDE1=ACOS(COS(SB_R)*COS(WB_R)) -! -!----------------------------------------------------------------------- -!*** ALPHA is the angle between SIDE1 and the domain's equator west of -!*** the central point. -!----------------------------------------------------------------------- -! - ALPHA=ATAN(TAN(SB_R)/SIN(WB_R)) -! -!----------------------------------------------------------------------- -!*** BETA is the angle between SIDE1 and the domain's prime meridian -!*** south of the central point. -!----------------------------------------------------------------------- -! - BETA=PI_2-ALPHA -! -!----------------------------------------------------------------------- -!*** SIDE2 is the arc from the central point southward along the -!*** domain's prime meridian to the great circle that intersects -!*** both the SW and SE corners of the domain. -!----------------------------------------------------------------------- -! - SIDE2=ATAN(COS(BETA)*TAN(SIDE1)) -! -!----------------------------------------------------------------------- -!*** SIDE3 is the arc between the domain's prime meridian and the SW -!*** corner along the great circle that connects the domain's SW and -!*** SE corners. -!----------------------------------------------------------------------- -! - SIDE3=ASIN(SIN(BETA)*SIN(SIDE1)) -! -!----------------------------------------------------------------------- -!*** SIDE4 is the arc along the outer grid's equator that lies between -!*** its western intersection with the above mentioned great circle -!*** and the outer grid's meridian that passes through the domain's -!*** SW corner. -!----------------------------------------------------------------------- -! - SIDE4=ACOS(SIN(SIDE3)/COS(SW_LAT)) -! -!----------------------------------------------------------------------- -!*** GAMMA is the angle between the outer grid's equator and the arc -!*** that connects the domain's SW corner with the point where the -!*** domain's central meridian crosses the outer grid's equator. -!----------------------------------------------------------------------- -! - GAMMA=ATAN(TAN(SW_LAT)/COS(SIDE4)) -! -!----------------------------------------------------------------------- -!*** DELTA is the angle between the arc that connects the domain's SW -!*** corner with the point where the domain's central meridian crosses -!*** the outer grid's equator and the domain's central meridian itself. -!----------------------------------------------------------------------- -! - DELTA=PI_2-GAMMA -! -!----------------------------------------------------------------------- -!*** SIDE5 is the arc along the domain's central meridian that lies -!*** between the outer grid's equator and the great circle that passes -!*** through the SW and SE corners of the domain. -!----------------------------------------------------------------------- -! - SIDE5=ASIN(TAN(SIDE3)/TAN(DELTA)) -! -!----------------------------------------------------------------------- -!*** The central latitude and longitude of the domain in terms of -!*** the coordinates of the outer grid. -!----------------------------------------------------------------------- -! - CENTRAL_LAT=SIDE2+SIDE5 - CENTRAL_LON=SW_LON+PI_2-SIDE4 -! - TPH0D_DOMAIN=CENTRAL_LAT/DEG_RAD - TLM0D_DOMAIN=CENTRAL_LON/DEG_RAD -! -!----------------------------------------------------------------------- -! - END SUBROUTINE CENTER_NEST -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE SET_NEST_GRIDS(DOMAIN_ID_MINE & - ,TPH0D,TLM0D & -!!! ,SBD_MINE,WBD_MINE & - ,DPHD_MINE,DLMD_MINE) -! -!----------------------------------------------------------------------- -!*** Basic grid characteristics for nests are based upon those of -!*** the uppermost parent grid. Use those parent values to compute -!*** appropriate analogs for the nests. -!*** This subroutine is relevant only to grid-associated nests. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: DOMAIN_ID_MINE !<-- Domain ID for this nested domain -! - REAL(kind=KFPT),INTENT(OUT) :: DPHD_MINE & !<-- Delta phi of this nested domain (degrees) - ,DLMD_MINE & !<-- Delta lambda of this nested domain (degrees) - ,TLM0D & !<-- Central rotated longitude of all domains (degrees) - ,TPH0D !<-- Central rotated latitude of all domains (degrees) -!!! ,SBD_MINE & !<-- Southern boundary this nested domain (degrees) -!!! ,WBD_MINE !<-- Western boundary this nested domain (degrees) -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT),PARAMETER :: MAX_DOMAINS=99 -! - INTEGER(kind=KINT) :: IM_1,JM_1 & - ,ID_ANCESTOR,ID_DOMAIN & - ,IDE_1,JDE_1 & - ,I_BOUND,J_BOUND & - ,I_PARENT_SW,J_PARENT_SW & - ,I_START_SW,J_START_SW & - ,N,NUM_ANCESTORS -! - INTEGER(kind=KINT) :: RC,RC_SET -! - INTEGER(kind=KINT),DIMENSION(MAX_DOMAINS) :: ID_ANCESTORS=0 -! - INTEGER(kind=KINT),DIMENSION(MAX_DOMAINS) :: PARENT_CHILD_SPACE_RATIO -! - INTEGER(kind=KINT),DIMENSION(2,MAX_DOMAINS) :: SW_CORNER -! - REAL(kind=KFPT) :: DPHD_1,DLMD_1,TLM_BASE_1,TPH_BASE_1,SBD_1,WBD_1 - REAL(kind=KFPT) :: DPHD_X,DLMD_X,TLM_BASE,TPH_BASE,SBD_X,WBD_X -! - CHARACTER(2) :: INT_TO_CHAR - CHARACTER(6) :: FMT='(I2.2)' - CHARACTER(50) :: GLOBAL - CHARACTER(99) :: CONFIG_FILE_NAME -! - TYPE(ESMF_Config),DIMENSION(MAX_DOMAINS) :: CF -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RC_SET=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** First load all of the domains' configure files. -!----------------------------------------------------------------------- -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!******* See NMM_ATM_INIT where -!******* CF(N) is made to be -!******* CF(ID of domain). -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! - DO N=1,MAX_DOMAINS - CF(N)=ESMF_ConfigCreate(rc=RC) -! - WRITE(INT_TO_CHAR,FMT)N - CONFIG_FILE_NAME='configure_file_'//INT_TO_CHAR !<-- Prepare the config file names -! - CALL ESMF_ConfigLoadFile(config =CF(N) & - ,filename=CONFIG_FILE_NAME & - ,rc =RC) - IF(RC/=0)EXIT !<-- Exit loop after running out of config files - ENDDO -! -!----------------------------------------------------------------------- -!*** We must loop through the configure files of all of the current -!*** domain's ancestors to collect information needed to properly -!*** describe the current grid. This is necessary because all -!*** grids' rows and columns lie parallel to those of the uppermost -!*** grid. -!----------------------------------------------------------------------- -! - ID_DOMAIN=DOMAIN_ID_MINE -! - N=0 -! -!----------------------------------------------------------------------- - main_loop: DO -!----------------------------------------------------------------------- -! - N=N+1 -! -!----------------------------- -!*** Domain IDs of Ancestors -!----------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Domain ID of Ancestor" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_DOMAIN) & !<-- The config object - ,value =ID_ANCESTOR & !<-- The variable filled - ,label ='my_parent_id:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_SET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!-------------------------------------- -!*** SW Corner Locations on Ancestors -!-------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get SW Corner I and J on Ancestor Grid" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_DOMAIN) & !<-- The config object - ,value =I_START_SW & !<-- The variable filled - ,label ='i_parent_start:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_DOMAIN) & !<-- The config object - ,value =J_START_SW & !<-- The variable filled - ,label ='j_parent_start:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_SET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!---------------------------- -!*** Parent-to-Child Ratios -!---------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Child-to-Parent Ratio of Ancestor" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_DOMAIN) & !<-- The config object - ,value =PARENT_CHILD_SPACE_RATIO(N) & !<-- The variable filled - ,label ='parent_child_space_ratio:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_SET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - ID_ANCESTORS(N)=ID_ANCESTOR !<-- Store domain IDs of all ancestors - SW_CORNER(1,N)=I_START_SW !<-- Store parent I of SW corner of its child - SW_CORNER(2,N)=J_START_SW !<-- Store parent J of SW corner of its child -! - IF(ID_ANCESTOR==1)EXIT !<-- We have reached the uppermost domain -! - ID_DOMAIN=ID_ANCESTOR -! -!----------------------------------------------------------------------- -! - ENDDO main_loop -! -!----------------------------------------------------------------------- -! - NUM_ANCESTORS=N !<-- How many ancestors are there? -! -!----------------------------------------------------------------------- -!*** Rows and columns of all nests' grids lie parallel to those of -!*** uppermost parent grid. Thus the central rotated latitude and -!*** longitude of all nests must be those of the uppermost domain. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Central Lat/Lon of Uppermost Domain" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_ANCESTORS(N)) & !<-- The config object - ,value =TPH0D & !<-- The variable filled - ,label ='tph0d:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_ANCESTORS(N)) & !<-- The config object - ,value =TLM0D & !<-- The variable filled - ,label ='tlm0d:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_SET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Get dimensions of uppermost domain as the baseline. -!*** We must also know southern and western boundary locations -!*** as well as whether it is global or not. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Baseline Dimensions of Uppermost Domain" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_ANCESTORS(N)) & !<-- The config object - ,value =IM_1 & !<-- The variable filled - ,label ='im:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_ANCESTORS(N)) & !<-- The config object - ,value =JM_1 & !<-- The variable filled - ,label ='jm:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_SET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Southern/Western Boundary of Uppermost Domain" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_ANCESTORS(N)) & !<-- The config object - ,value =SBD_1 & !<-- The variable filled - ,label ='sbd:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_ANCESTORS(N)) & !<-- The config object - ,value =WBD_1 & !<-- The variable filled - ,label ='wbd:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_SET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Global Flag for Uppermost Domain" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_ANCESTORS(N)) & !<-- The config object - ,value =GLOBAL & !<-- The variable filled - ,label ='global:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_SET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Full grid dimensions; delta phi and delta lambda -!*** for uppermost domain. -!----------------------------------------------------------------------- -! - IF(TRIM(GLOBAL)=='true')THEN !<-- Uppermost domain is global - IDE_1=IM_1+2 - JDE_1=JM_1+2 - DPHD_1=-SBD_1*2./REAL(JDE_1-3) - DLMD_1=-WBD_1*2./REAL(IDE_1-3) - TPH_BASE_1=SBD_1-2.*DPHD_1 - TLM_BASE_1=WBD_1-2.*DLMD_1 - ELSE !<-- Uppermost domain is regional - IDE_1=IM_1 - JDE_1=JM_1 - DPHD_1=-SBD_1*2./REAL(JDE_1-1) - DLMD_1=-WBD_1*2./REAL(IDE_1-1) - TPH_BASE_1=SBD_1-DPHD_1 - TLM_BASE_1=WBD_1-DLMD_1 - ENDIF -! -!----------------------------------------------------------------------- -!*** Loop through this nest's ancestors in order to obtain its: -!*** (1) delta phi and delta lambda -!*** (2) southern/western boundary locations -! -!*** We must work downward through the ancestors because -!*** the uppermost domain is the foundation. -!----------------------------------------------------------------------- -! - DPHD_X=DPHD_1 - DLMD_X=DLMD_1 - TPH_BASE=TPH_BASE_1 - TLM_BASE=TLM_BASE_1 -! -!----------------------------------------------------------------------- -! - work_loop: DO N=NUM_ANCESTORS,1,-1 -! - I_START_SW=SW_CORNER(1,N) - J_START_SW=SW_CORNER(2,N) -! - SBD_X=TPH_BASE+J_START_SW*DPHD_X !<-- Southern boundary of ancestor N - WBD_X=TLM_BASE+I_START_SW*DLMD_X !<-- Western boundary of ancestor N -! - DPHD_X=DPHD_X/REAL(PARENT_CHILD_SPACE_RATIO(N)) !<-- Delta phi for child of ancestor N - DLMD_X=DLMD_X/REAL(PARENT_CHILD_SPACE_RATIO(N)) !<-- Delta lambda for child of ancestor N -! - TPH_BASE=SBD_X-DPHD_X - TLM_BASE=WBD_X-DLMD_X -! - ENDDO work_loop -! - DPHD_MINE=DPHD_X - DLMD_MINE=DLMD_X -!!! SBD_MINE=SBD_X -!!! WBD_MINE=WBD_X -! -!----------------------------------------------------------------------- -! - END SUBROUTINE SET_NEST_GRIDS -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE WATERFALLS(FIS & - ,SEA_MASK & - ,LOWER_TOPO & - ,IDS,IDE,JDS,JDE) -! -!----------------------------------------------------------------------- -!*** When a parent initializes its child, the sea mask had to be done -!*** with nearest neighbor logic while FIS should be done bilinearly. -!*** This can lead to adjacent water points having different values -!*** of FIS. when that is the case, make the elevation of all -!*** adjacent water points equal to the lowest of their values. -!*** Save the I,J of all lowered points so the atmospheric column -!*** can ultimately be adjusted. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: IDS,IDE,JDS,JDE !<-- Lateral dimensions of nest grid -! - REAL(kind=KFPT),DIMENSION(IDS:IDE,JDS:JDE),INTENT(IN) :: SEA_MASK !<-- Sea mask of nest grid points -! - REAL(kind=KFPT),DIMENSION(IDS:IDE,JDS:JDE,1),INTENT(INOUT) :: FIS !<-- Sfc geopotential on nest grid points -! - LOGICAL(kind=KLOG),DIMENSION(IDS:IDE,JDS:JDE),INTENT(OUT) :: & - LOWER_TOPO !<-- Flag points where topography is lowered -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: I,ITER,J,KOUNT_CHANGE -! - REAL(kind=KFPT) :: FIS_0 & - ,FIS_E,FIS_N,FIS_W,FIS_S & - ,FIS_NE,FIS_NW,FIS_SW,FIS_SE & - ,FIS_NEW -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - iter_loop: DO ITER=1,500 -! - KOUNT_CHANGE=0 -! -!----------------------------------------------------------------------- -! - DO J=JDS,JDE - DO I=IDS,IDE -! - IF(SEA_MASK(I,J)<0.01)CYCLE !<-- We are adjusting only water points -! -!----------------------------------------------------------------------- -! - FIS_0=FIS(I,J,1) -! -!---------- -!*** East -!---------- -! - FIS_E=FIS_0 -! - IF(I+1<=IDE)THEN - IF(SEA_MASK(I+1,J)>0.99)FIS_E=FIS(I+1,J,1) - ENDIF -! -!--------------- -!*** Northeast -!--------------- -! - FIS_NE=FIS_0 -! - IF(I+1<=IDE.AND.J+1<=JDE)THEN - IF(SEA_MASK(I+1,J+1)>0.99)FIS_NE=FIS(I+1,J+1,1) - ENDIF -! -!----------- -!*** North -!----------- -! - FIS_N=FIS_0 -! - IF(J+1<=JDE)THEN - IF(SEA_MASK(I,J+1)>0.99)FIS_N=FIS(I,J+1,1) - ENDIF -! -!--------------- -!*** Northwest -!--------------- -! - FIS_NW=FIS_0 -! - IF(I-1>=IDS.AND.J+1<=JDE)THEN - IF(SEA_MASK(I-1,J+1)>0.99)FIS_NW=FIS(I-1,J+1,1) - ENDIF -! -!---------- -!*** West -!---------- -! - FIS_W=FIS_0 -! - IF(I-1>=IDS)THEN - IF(SEA_MASK(I-1,J)>0.99)FIS_W=FIS(I-1,J,1) - ENDIF -! -!--------------- -!*** Southwest -!--------------- -! - FIS_SW=FIS_0 -! - IF(I-1>=IDS.AND.J-1>=JDS)THEN - IF(SEA_MASK(I-1,J-1)>0.99)FIS_SW=FIS(I-1,J-1,1) - ENDIF -! -!----------- -!*** South -!----------- -! - FIS_S=FIS_0 -! - IF(J-1>=JDS)THEN - IF(SEA_MASK(I,J-1)>0.99)FIS_S=FIS(I,J-1,1) - ENDIF -! -!--------------- -!*** Southeast -!--------------- -! - FIS_SE=FIS_0 -! - IF(I+1<=IDE.AND.J-1>=JDS)THEN - IF(SEA_MASK(I+1,J-1)>0.99)FIS_SE=FIS(I+1,J-1,1) - ENDIF -! -!----------------------------------------------------------------------- -!*** Lower the point in question to the lowest value of itself and -!*** its neighbors if it is a water point. -!*** Also save all I,J locations where FIS is changed so that we -!*** can adjust the atmospheric column appropriately later. -!----------------------------------------------------------------------- -! - FIS_NEW=MIN(FIS_0 & - ,FIS_E,FIS_N,FIS_W,FIS_E & - ,FIS_NE,FIS_NW,FIS_SW,FIS_SE) -! - IF(FIS_NEW+0.10)THEN -! -!----------------------------------------------------------------------- -! - parent_tasks: DO N=1,NUM_PTASK_UPDATE -! -!----------------------------------------------------------------------- -! - WRITE(N_PTASK,'(I1)')N -! - NAME_INTEGER='PTASK_INTEGER_DATA_'//N_PTASK - NAME_REAL ='PTASK_REAL_DATA_'//N_PTASK - NAME ='PTASK_DATA_'//N_PTASK -! -!----------------------------------------------------------------------- -! -!------------ -!*** Integer -!------------ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Unload # of Words in Integer Update Data from Parent" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=STATE_IN & !<-- The input State - ,name =NAME_INTEGER//' Words' & !<-- Name of the variable - ,value=NUM_INTEGER_WORDS & !<-- # of words in integer update data from Nth parent task - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_S2S) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load # of Words in Integer Update Data from Parent" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=STATE_OUT & !<-- The output State - ,name =NAME_INTEGER//' Words' & !<-- Name of the variable - ,value=NUM_INTEGER_WORDS & !<-- # of words in integer update data from Nth parent task - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_S2S) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - transfer_int: IF(NUM_INTEGER_WORDS>0)THEN -! -!----------------------------------------------------------------------- -! - ALLOCATE(UPDATE_INTEGER_DATA(1:NUM_INTEGER_WORDS)) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Unload Interior Integer Update Data from Input State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =STATE_IN & !<-- The input State - ,name =NAME_INTEGER & !<-- Name of the variable - ,itemCount=NUM_INTEGER_WORDS & !<-- # of words in integer update data from Nth parent task - ,valueList=UPDATE_INTEGER_DATA & !<-- The integer update data from Nth parent task - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_S2S) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Interior Integer Update Data into Output State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state =STATE_OUT & !<-- The output State - ,name =NAME_INTEGER & !<-- Name of the variable - ,itemCount=NUM_INTEGER_WORDS & !<-- # of words in integer update data from Nth parent task - ,valueList=UPDATE_INTEGER_DATA & !<-- The integer update data from Nth parent task - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_S2S) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DEALLOCATE(UPDATE_INTEGER_DATA) -! -!----------------------------------------------------------------------- -! - ENDIF transfer_int -! -!----------------------------------------------------------------------- -! -!---------- -!*** Real -!---------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Unload # of Words in Real Update Data from Parent" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=STATE_IN & !<-- The input State - ,name =NAME_REAL//' Words' & !<-- Name of the variable - ,value=NUM_REAL_WORDS & !<-- # of words in real update data from Nth parent task - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_S2S) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load # of Words in Real Update Data from Parent" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=STATE_OUT & !<-- The output State - ,name =NAME_REAL//' Words' & !<-- Name of the variable - ,value=NUM_REAL_WORDS & !<-- # of words in real update data from Nth parent task - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_S2S) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ALLOCATE(UPDATE_REAL_DATA(1:NUM_REAL_WORDS)) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Unload Interior Real Update Data from Input State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =STATE_IN & !<-- The input State - ,name =NAME_REAL & !<-- Name of the variable - ,itemCount=NUM_REAL_WORDS & !<-- # of words in real update data from Nth parent task - ,valueList=UPDATE_REAL_DATA & !<-- The real update data from Nth parent task - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_S2S) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Interior Real Update Data into Output State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state =STATE_OUT & !<-- The output State - ,name =NAME_REAL & !<-- Name of the variable - ,itemCount=NUM_REAL_WORDS & !<-- # of words in real update data from Nth parent task - ,valueList=UPDATE_REAL_DATA & !<-- The real update data from Nth parent task - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_S2S) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DEALLOCATE(UPDATE_REAL_DATA) -! -!----------------------------------------------------------------------- -!*** Transfer the H and V loop limits for the nest update regions. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Unload Index Limits for H Update Data from Parent" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =STATE_IN & !<-- The input State - ,name =NAME//' Indices H' & !<-- Name of the variable - ,itemCount=N8 & !<-- # of words in index limits of update data - ,valueList=INDICES_H & !<-- The update data index specifications for H - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_S2S) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Index Limits for H Update Data from Parent" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state =STATE_OUT & !<-- The output State - ,name =NAME//' Indices H' & !<-- Name of the variable - ,itemCount=N8 & !<-- # of words in index limits of update data - ,valueList=INDICES_H & !<-- The update data index specifications for H - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_S2S) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Unload Index Limits for V Update Data from Parent" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =STATE_IN & !<-- The input State - ,name =NAME//' Indices V' & !<-- Name of the variable - ,itemCount=N8 & !<-- # of words in index limits of update data - ,valueList=INDICES_V & !<-- The update data index specifications for V - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_S2S) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Index Limits for V Update Data from Parent" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state =STATE_OUT & !<-- The output State - ,name =NAME//' Indices V' & !<-- Name of the variable - ,itemCount=N8 & !<-- # of words in index limits of update data - ,valueList=INDICES_V & !<-- The update data index specifications for V - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_S2S) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - ENDDO parent_tasks -! -!----------------------------------------------------------------------- -! - ENDIF transfer -! -!----------------------------------------------------------------------- -! - ENDIF move_check -! -!----------------------------------------------------------------------- -!*** Finally transfer the value of the domain's next move timestep. -!*** This variable is part of the Solver internal state and is thus -!*** defined for all domains. Its value is a dummy if not relevant. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="INTERIOR_DATA_STATE_TO_STATE: Unload the Next Move Timestep" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=STATE_IN & !<-- The input State - ,name ='NEXT_MOVE_TIMESTEP' & !<-- Name of the variable - ,value=NEXT_MOVE_TIMESTEP & !<-- Timestep of domain's next shift. - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_S2S) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="INTERIOR_DATA_STATE_TO_STATE: Load the Next Move Timestep" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=STATE_OUT & !<-- The output State - ,name ='NEXT_MOVE_TIMESTEP' & !<-- Name of the variable - ,value=NEXT_MOVE_TIMESTEP & !<-- Timestep of domain's next shift. - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_S2S) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - END SUBROUTINE INTERIOR_DATA_STATE_TO_STATE -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE MOVING_NEST_BOOKKEEPING(I_SHIFT_CHILD & - ,J_SHIFT_CHILD & - ,I_SW_PARENT_NEW & - ,J_SW_PARENT_NEW & - ,NUM_TASKS_PARENT & - ,INPES_PARENT & - ,ITS_PARENT & - ,ITE_PARENT & - ,JTS_PARENT & - ,JTE_PARENT & - ,SPACE_RATIO_MY_PARENT & - ,NROWS_P_UPD_W & - ,NROWS_P_UPD_E & - ,NROWS_P_UPD_S & - ,NROWS_P_UPD_N & - ,SEND_TASK & - ,ITS,ITE,JTS,JTE & - ,IMS,IME,JMS,JME & - ,IDS,IDE,JDS,JDE & - ) -! -!----------------------------------------------------------------------- -!*** Nest tasks determine which parent tasks will send them update -!*** data and on which points following a move by the nest domain. -!*** The data is for all nest task subdomain points including haloes -!*** that lie outside of the footprint of the nest domain's location -!*** preceding the move. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: I_SHIFT_CHILD & !<-- Nest domain moved this far in I in nest space - ,J_SHIFT_CHILD & !<-- Nest domain moved this far in J in nest space - ,I_SW_PARENT_NEW & !<-- SW corner of nest on this parent I after the move - ,J_SW_PARENT_NEW & !<-- SW corner of nest on this parent J after the move - ,INPES_PARENT & !<-- # of tasks in E/W direction on parent domain - ,NROWS_P_UPD_W & !<-- Moving nest footprint W bndry rows updated by parent - ,NROWS_P_UPD_E & !<-- Moving nest footprint E bndry rows updated by parent - ,NROWS_P_UPD_S & !<-- Moving nest footprint S bndry rows updated by parent - ,NROWS_P_UPD_N & !<-- Moving nest footprint N bndry rows updated by parent - ,NUM_TASKS_PARENT & !<-- Number of fcst tasks on this nest's parent domain - ,SPACE_RATIO_MY_PARENT & !<-- Ratio of parent grid increment to this child's -! - ,ITS,ITE,JTS,JTE & !<-- Integration limits of nest task - ,IMS,IME,JMS,JME & !<-- Memory limits of nest task - ,IDS,IDE,JDS,JDE !<-- Nest's domain limits -! - INTEGER(kind=KINT),DIMENSION(0:NUM_TASKS_PARENT-1),INTENT(IN) :: & - ITS_PARENT & !<-- Starting I of all parent integration subdomains - ,ITE_PARENT & !<-- Ending I of all parent integration subdomains - ,JTS_PARENT & !<-- Starting J of all parent integration subdomains - ,JTE_PARENT !<-- Ending J of all parent integration subdomains -! - TYPE(INTERIOR_DATA_FROM_PARENT),DIMENSION(1:4),INTENT(OUT) :: & - SEND_TASK !<-- Specifics about interior data from sending parent tasks -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: I_END_X,I_SHIFT,I_START_X & - ,ID_1,ID_E,ID_N,ID_NE & - ,J_END_X,J_SHIFT,J_START_X & - ,KOUNT_PARENT_TASKS,KP,N,NI,NJ -! - INTEGER(kind=KINT),DIMENSION(1:4) :: I_UPDATE & - ,J_UPDATE -! - REAL(kind=KFPT),DIMENSION(:),ALLOCATABLE :: ITS_PARENT_ON_CHILD & - ,ITE_PARENT_ON_CHILD & - ,JTS_PARENT_ON_CHILD & - ,JTE_PARENT_ON_CHILD -! - CHARACTER(2) :: CORNER -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Initialize working variables. -!----------------------------------------------------------------------- -! - DO N=1,4 !<-- 4 is maximum # of parent tasks that can send data - SEND_TASK(N)%ID=-9999 - SEND_TASK(N)%ISTART(1)=-9999 - SEND_TASK(N)%IEND (1)=-9999 - SEND_TASK(N)%JSTART(1)=-9999 - SEND_TASK(N)%JEND (1)=-9999 - SEND_TASK(N)%ISTART(2)=-9999 - SEND_TASK(N)%IEND (2)=-9999 - SEND_TASK(N)%JSTART(2)=-9999 - SEND_TASK(N)%JEND (2)=-9999 - ENDDO -! -!----------------------------------------------------------------------- -!*** Each nest task needs to determine if it has moved outside of -!*** the footprint of the nest domain's previous position. If it -!*** has then that task next finds out from which parent tasks it -!*** must receive data. Finally it receives and incorporates that -!*** data. -! -!*** If no part of a nest task's subdomain has moved outside of the -!*** footprint of the nest domain's previous location then that task -!*** may RETURN now from this routine since none of its points will -!*** be updated by the parent. -!*** -!*** Note that the north and east domain limits are not considered -!*** to be part of the nest's pre-move footprint because those points -!*** cannot be updated by intra-task or inter-task shifts. The reason -!*** is that V-pt variables at those points are not part of the nest's -!*** integration thus their values are not valid. Although the H-pt -!*** variables are valid at those points, we cannot use them for -!*** intra- or inter-task updates or else the nest tasks being updated -!*** for H points would sometimes differ from the nest tasks being -!*** updated for V points. We do not allow that to happen or else -!*** the bookkeeping would be even more complex. Therefore the -!*** parent updates nest points that would otherwise have been updated -!*** from the north and east domain limits of the nest's pre-move -!*** footprint. But since a variety of variables do not have valid -!*** integration values on the domain boundary then we also must not -!*** allow the intra- and inter-task shift to handle the updating -!*** of the southern and western boundaries of the nest but instead -!*** must let the parent handle those points as well. Moreover some -!*** key dynamical tendenies are not computed one row inside the -!*** domain boundary which thus means that the parent must provide -!*** updates for all nest points that not only move beyond the -!*** nest's pre-move footprint but also for those nest points that -!*** move onto IDE and IDE-1 and JDE and JDE-1. Variables read -!*** from the configure file now specify how deeply the parent will -!*** update nest points with respect to the pre-move footprint. -!----------------------------------------------------------------------- -! - I_START_X=MAX(IMS,IDS) - I_END_X =MIN(IME,IDE) - J_START_X=MAX(JMS,JDS) - J_END_X =MIN(JME,JDE) -! - IF(I_START_X>=IDS+NROWS_P_UPD_W-I_SHIFT_CHILD & !<-- If the entire nest task subdomain including its - .AND. & ! halo is inside the footprint of the nest domain - I_END_X<=IDE-NROWS_P_UPD_E-I_SHIFT_CHILD & ! (the domain's position prior to the move) then - .AND. & ! no update from the parent is done. - J_START_X>=JDS+NROWS_P_UPD_S-J_SHIFT_CHILD & ! - .AND. & ! - J_END_X<=JDE-NROWS_P_UPD_N-J_SHIFT_CHILD )THEN !<--- -! - RETURN !<-- Therefore exit. -! - ENDIF -! -!----------------------------------------------------------------------- -! - I_SHIFT=I_SHIFT_CHILD - J_SHIFT=J_SHIFT_CHILD - CORNER=' ' - KOUNT_PARENT_TASKS=0 -! -!----------------------------------------------------------------------- -!*** The parent is going to send data interpolated to the nest grid -!*** since that is simpler than handling sparse parent grid data on -!*** the nest domain. Which points on this nest task now lie outside -!*** the footprint of the pre-move nest domain? Do a search relative -!*** to the indices on the post-move nest task position since it is -!*** that location at which parent data are received. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Following the move most nest tasks that lie along the boundary -!*** of the footprint of the nest domain will have simple -!*** rectangular update regions in which they will receive -!*** update data from parent tasks. However if a nest task's new -!*** position is over a corner of the nest domain's pre-move footprint -!*** then there will be an update region in the nest task that has a -!*** wedge missing in the intersection with the footprint corner. -!*** This greatly complicates the situation. -! -!*** The diagram below shows a nest task after the nest has moved. -!*** That task now lies over the northeast corner of the footprint -!*** of the domain's pre-move position. In this case the task -!*** receives update data from four parent tasks (the maximum). -!*** Note that the southwest update region in that nest task -!*** subdomain has the missing wedge. To handle this situation -!*** when it arises, the I and J limits on the nest task subdomain -!*** update region will be dimensioned (1:4). See how the missing -!*** wedge in the update region goes from I_UPDATE(1) to I_UPDATE(2) -!*** and from J_UPDATE(1) to J_UPDATE(2). The 3rd and 4th elements -!*** of these arrays are filled only for tasks that are on the -!*** footprint's corners. -!----------------------------------------------------------------------- -! -! ' -! ' -! ' -! '<-- parent task boundary -! ' -! ' -! + + + + + + + + + + + + + + + + + + + + + --- J_UPDATE(4) -! + ' + -! ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' -! ^ + ' + -! | + ' nest task position + -! parent task + ' after the move + -! boundary + ' + --- J_UPDATE(3) -! ------------------------------------------ + --- J_UPDATE(2) -! / /| + -! I_UPDATE(1) / | + -! I_UPDATE(2) |+ + + + + + + + + + + + + + + + --- J_UPDATE(1) -! | \ \ -! footprint of the nest domain | \ \ -! in its pre-move location | I_UPDATE(3) I_UPDATE(4) -! | -! | -! | -! -!----------------------------------------------------------------------- -!*** Compute I_UPDATE(1-2) and J_UPDATE(1-2) as well as I_UPDATE(3-4) -!*** and J_UPDATE(3-4) if they exist. -!----------------------------------------------------------------------- -! - update_limits: IF( & - I_START_XIDE-NROWS_P_UPD_E-I_SHIFT & ! then we only have I and J indices 1 and 2 which - .AND. & ! are the starting and ending indices for the - I_END_X >IDE-NROWS_P_UPD_E-I_SHIFT & ! nest task's entire subdomain including the halo. - .OR. & ! - J_START_XJDE-NROWS_P_UPD_N-J_SHIFT & ! - .AND. & ! - J_END_X >JDE-NROWS_P_UPD_N-J_SHIFT & !<-- - )THEN -! - I_UPDATE(1)=I_START_X - I_UPDATE(2)=I_END_X - I_UPDATE(3)=-9999 - I_UPDATE(4)=-9999 -! - J_UPDATE(1)=J_START_X - J_UPDATE(2)=J_END_X - J_UPDATE(3)=-9999 - J_UPDATE(4)=-9999 -! -!----------------------------------------------------------------------- -! - ELSE update_limits !<-- Nest task lies on footprint boundary after move -! -!----------------------------------------------------------------------- -! - i_block: IF(I_SHIFT>0)THEN !<-- Shift has eastward component -! -!----------------------------------------------------------------------- -! -!--------------------- -!*** Northeast shift -!--------------------- -! - IF(J_SHIFT>0)THEN -! - IF(I_END_X>IDE-NROWS_P_UPD_E-I_SHIFT)THEN !<-- NE shift, nest task on east side of footprint - I_UPDATE(1)=IDE-NROWS_P_UPD_E+1-I_SHIFT !<-- Begin on east edge of footprint - I_UPDATE(2)=I_END_X - J_UPDATE(1)=J_START_X - J_UPDATE(2)=J_END_X -! - IF(J_END_X>JDE-NROWS_P_UPD_N-J_SHIFT)THEN !<-- NE shift, nest task on NE corner of footprint - CORNER='NE' - I_UPDATE(1)=I_START_X - I_UPDATE(2)=IDE-NROWS_P_UPD_E-I_SHIFT - I_UPDATE(3)=I_UPDATE(2)+1 - I_UPDATE(4)=I_END_X - J_UPDATE(2)=JDE-NROWS_P_UPD_N-J_SHIFT - J_UPDATE(3)=J_UPDATE(2)+1 - J_UPDATE(4)=J_END_X - ENDIF -! - ELSEIF(I_END_X<=IDE-NROWS_P_UPD_E-I_SHIFT)THEN !<-- NE shift, nest task on north side of footprint; not corner - I_UPDATE(1)=I_START_X - I_UPDATE(2)=I_END_X - J_UPDATE(1)=JDE-NROWS_P_UPD_N+1-J_SHIFT !<-- Begin on north edge of footprint - J_UPDATE(2)=J_END_X -! - ENDIF -! -!--------------------- -!*** Southeast shift -!--------------------- -! - ELSEIF(J_SHIFT<0)THEN -! - IF(I_END_X>IDE-NROWS_P_UPD_E-I_SHIFT)THEN !<-- SE shift, nest task on east side of footprint; not corner - I_UPDATE(1)=IDE-NROWS_P_UPD_E+1-I_SHIFT !<-- Begin on east edge of footprint - I_UPDATE(2)=I_END_X - J_UPDATE(1)=J_START_X - J_UPDATE(2)=J_END_X -! - IF(J_START_X general IF(JME>=JDE-NROWS_P_UPD_N+1)THEN - IF(I_END_XJDS)THEN !<-- Nest task only on east edge of footprint -!-> general ELSEIF(JMS>JDS+NROWS_P_UPD_S-1)THEN !<-- Nest task only on east edge of footprint - I_UPDATE(1)=IDE-NROWS_P_UPD_E+1-I_SHIFT !<-- Begin on east edge of footprint - I_UPDATE(2)=I_END_X - J_UPDATE(1)=J_START_X - J_UPDATE(2)=J_END_X -! - ELSEIF(JTS==JDS)THEN -!-> general ELSEIF(JMS<=JDS+NROWS_P_UPD_S-1)THEN - IF(I_END_X general J_UPDATE(1)=J_START_X - J_UPDATE(2)=JDS+NROWS_P_UPD_S-1 - ELSE !<-- Nest task on S bndry of footprint; extends east of it - CORNER='SE' - I_UPDATE(1)=I_START_X - I_UPDATE(2)=IDE-NROWS_P_UPD_E-I_SHIFT - I_UPDATE(3)=I_UPDATE(2)+1 - I_UPDATE(4)=I_END_X - J_UPDATE(1)=J_START_X - J_UPDATE(2)=JDS+NROWS_P_UPD_S-1 - J_UPDATE(3)=J_UPDATE(2)+1 - J_UPDATE(4)=J_END_X - ENDIF -! - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -! - ELSEIF(I_SHIFT<0)THEN i_block !<-- Shift has westard component -! -!----------------------------------------------------------------------- -! -!--------------------- -!*** Northwest shift -!--------------------- -! - IF(J_SHIFT>0)THEN -! - IF(I_START_XJDE-NROWS_P_UPD_N-J_SHIFT)THEN !<-- NW shift, nest task on NW corner of footprint - CORNER='NW' - I_UPDATE(3)=I_UPDATE(2)+1 - I_UPDATE(4)=I_END_X - J_UPDATE(2)=JDE-NROWS_P_UPD_N-J_SHIFT - J_UPDATE(3)=J_UPDATE(2)+1 - J_UPDATE(4)=J_END_X - ENDIF -! - ELSEIF(I_START_X>=IDS+NROWS_P_UPD_W-I_SHIFT)THEN !<-- NW shift, nest tasks on north side of footprint; not corner - I_UPDATE(1)=I_START_X - I_UPDATE(2)=I_END_X - J_UPDATE(1)=JDE-NROWS_P_UPD_N+1-J_SHIFT !<-- Begin on north edge of footprint - J_UPDATE(2)=J_END_X -! - ENDIF -! -!--------------------- -!*** Southwest shift -!--------------------- -! - ELSEIF(J_SHIFT<0)THEN -! - IF(I_START_X=IDS+NROWS_P_UPD_W-I_SHIFT)THEN !<-- SW shift, nest tasks on south side; not corner - I_UPDATE(1)=I_START_X - I_UPDATE(2)=I_END_X - J_UPDATE(1)=J_START_X - J_UPDATE(2)=JDS+NROWS_P_UPD_S-1-J_SHIFT -! - ENDIF -! -!----------------------- -!*** Shift is due west -!----------------------- -! - ELSEIF(J_SHIFT==0)THEN - IF(JTE==JDE)THEN -!-> general IF(JME>=JDE-NROWS_P_UPD_N+1)THEN - IF(I_START_X>=IDS+NROWS_P_UPD_W-I_SHIFT)THEN !<-- Nest task on N bndry of footprint; no part west of it - I_UPDATE(1)=I_START_X - I_UPDATE(2)=I_END_X - J_UPDATE(1)=JDE-NROWS_P_UPD_N+1 - J_UPDATE(2)=J_END_X - ELSE !<-- Nest task on N bndry of footprint; extends west of it - CORNER='NW' - I_UPDATE(1)=I_START_X - I_UPDATE(2)=IDS+NROWS_P_UPD_W-1-I_SHIFT - I_UPDATE(3)=I_UPDATE(2)+1 - I_UPDATE(4)=I_END_X - J_UPDATE(1)=J_START_X - J_UPDATE(2)=J_END_X-1 - J_UPDATE(2)=JDE-NROWS_P_UPD_N - J_UPDATE(3)=J_UPDATE(2)+1 - J_UPDATE(4)=J_END_X - ENDIF -! - ELSEIF(JTS>JDS)THEN !<-- Nest task only on west edge of footprint -!-> general ELSEIF(JMS>JDS+NROWS_P_UPD_S-1)THEN !<-- Nest task only on west edge of footprint - I_UPDATE(1)=I_START_X - I_UPDATE(2)=IDS+NROWS_P_UPD_W-1-I_SHIFT !<-- End on the west edge of footprint - J_UPDATE(1)=J_START_X - J_UPDATE(2)=J_END_X -! - ELSEIF(JTS==JDS)THEN -!-> general ELSEIF(JMS<=JDS+NROWS_P_UPD_S-1)THEN - IF(I_START_X>=IDS+NROWS_P_UPD_W-I_SHIFT)THEN !<-- Nest task on S bndry of footprint; no part west of it - I_UPDATE(1)=I_START_X - I_UPDATE(2)=I_END_X - J_UPDATE(1)=JDS -!-> general J_UPDATE(1)=J_START_X - J_UPDATE(2)=JDS+NROWS_P_UPD_S-1 - ELSE !<-- Nest task on S bndry of footprint; extends west of it - CORNER='SW' - I_UPDATE(1)=I_START_X - I_UPDATE(2)=IDS+NROWS_P_UPD_W-1-I_SHIFT - I_UPDATE(3)=I_UPDATE(2)+1 - I_UPDATE(4)=I_END_X - J_UPDATE(1)=JDS -!-> general J_UPDATE(1)=J_START_X - J_UPDATE(2)=JDS+NROWS_P_UPD_S-1 - J_UPDATE(3)=J_UPDATE(2)+1 - J_UPDATE(4)=J_END_X - ENDIF -! - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -! - ELSEIF(I_SHIFT==0)THEN !<-- Shift has no eastward or westward component -! -!------------------------ -!*** Shift is due north -!------------------------ -! - IF(J_SHIFT>0)THEN - IF(ITE==IDE)THEN -!-> general IF(IME>=IDE-NROWS_P_UPD_E+1)THEN - IF(J_END_XIDS)THEN !<-- Nest task only on north edge of footprint -!-> general ELSEIF(IMS>IDS+NROWS_P_UPD_W-1)THEN !<-- Nest task only on north edge of footprint - I_UPDATE(1)=I_START_X - I_UPDATE(2)=I_END_X - J_UPDATE(1)=JDE-NROWS_P_UPD_N+1-J_SHIFT !<-- Begin on north edge of footprint - J_UPDATE(2)=J_END_X -! - ELSEIF(ITS==IDS)THEN -!-> general ELSEIF(IMS<=IDS+NROWS_P_UPD_W-1)THEN - IF(J_END_X general I_UPDATE(1)=I_START_X - I_UPDATE(2)=IDS+NROWS_P_UPD_W-1 - J_UPDATE(1)=J_START_X - J_UPDATE(2)=J_END_X - ELSE !<-- Nest task on W bndry of footprint; extends north of it - CORNER='NW' - I_UPDATE(1)=IDS -!-> general I_UPDATE(1)=I_START_X - I_UPDATE(2)=IDS+NROWS_P_UPD_W-1 - I_UPDATE(3)=I_UPDATE(2)+1 - I_UPDATE(4)=I_END_X - J_UPDATE(1)=J_START_X - J_UPDATE(2)=JDE-NROWS_P_UPD_N-J_SHIFT - J_UPDATE(3)=J_UPDATE(2)+1 - J_UPDATE(4)=J_END_X - ENDIF -! - ENDIF -! -!------------------------ -!*** Shift is due south -!------------------------ -! - ELSEIF(J_SHIFT<0)THEN - IF(ITE==IDE)THEN -!-> general IF(IME>=IDE-NROWS_P_UPD_E+1)THEN - IF(J_START_X>=JDS+NROWS_P_UPD_S-J_SHIFT)THEN !<-- Nest task on E bndry of footprint; no part south of it - I_UPDATE(1)=IDE-NROWS_P_UPD_E+1 - I_UPDATE(2)=I_END_X - J_UPDATE(1)=J_START_X - J_UPDATE(2)=J_END_X - ELSE !<-- Nest task on E bndry of footprint; extends south of it - CORNER='SE' - I_UPDATE(1)=I_START_X - I_UPDATE(2)=IDE-NROWS_P_UPD_E - I_UPDATE(3)=I_UPDATE(2)+1 - I_UPDATE(4)=I_END_X - J_UPDATE(1)=J_START_X - J_UPDATE(2)=JDS+NROWS_P_UPD_S-1-J_SHIFT - J_UPDATE(2)=JDS+NROWS_P_UPD_S-1-J_SHIFT - J_UPDATE(3)=J_UPDATE(2)+1 - J_UPDATE(4)=J_END_X - ENDIF -! - ELSEIF(ITS>IDS)THEN !<-- Nest task only on south edge of footprint -!-> general ELSEIF(IMS>IDS+NROWS_P_UPD_W-1)THEN !<-- Nest task only on south edge of footprint - I_UPDATE(1)=I_START_X - I_UPDATE(2)=I_END_X - J_UPDATE(1)=J_START_X - J_UPDATE(2)=JDS+NROWS_P_UPD_S-1-J_SHIFT !<-- End on south edge of footprint -! - ELSEIF(ITS==IDS)THEN -!-> general ELSEIF(IMS<=IDS+NROWS_P_UPD_W-1)THEN - IF(J_START_X>=JDS+NROWS_P_UPD_S-J_SHIFT)THEN !<-- Nest task on W bndry of footprint; no part south of it - I_UPDATE(1)=IDS -!-> general I_UPDATE(1)=I_START_X - I_UPDATE(2)=IDS+NROWS_P_UPD_W-1 - J_UPDATE(1)=J_START_X - J_UPDATE(2)=J_END_X - ELSE !<-- Nest task on W bndry of footprint; extends south of it - CORNER='SW' - I_UPDATE(1)=I_START_X - I_UPDATE(2)=IDS+NROWS_P_UPD_W-1 - I_UPDATE(3)=I_UPDATE(2)+1 - I_UPDATE(4)=I_END_X - J_UPDATE(1)=J_START_X - J_UPDATE(2)=JDS+NROWS_P_UPD_S-1-J_SHIFT - J_UPDATE(3)=J_UPDATE(2)+1 - J_UPDATE(4)=J_END_X - ENDIF -! - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF i_block -! -!----------------------------------------------------------------------- -! - ENDIF update_limits -! -!----------------------------------------------------------------------- -!*** Now we know which portion of each task's subdomain on the -!*** moving nest lies outside of the nest domain's pre-move -!*** footprint location and it is that portion that must be -!*** updated from the parent tasks. -! -!*** To receive data from its parent, each moving nest task must -!*** know how many parent tasks it will receive from. Nest tasks -!*** could do this blindly by receiving a message from all parent -!*** tasks which would inform them which parent tasks had actual -!*** data, or they could receive all that information from parent -!*** task 0 if that task had first been sent all that information -!*** from the other parent tasks, or each nest task could compute -!*** which parent tasks will send it data and how much. The third -!*** option involves the least overall communication and serves to -!*** double check the parent's bookkeeping therefore that option -!*** is the one used here. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** The nest tasks determine all of their parent tasks' integration -!*** limits in terms of their own (the nest tasks') indices so they -!*** will know where to put the data they receive from the parent. -!*** This must be done for all parent tasks since the nest tasks -!*** can make no assumptions about which parent tasks will have -!*** update data for them and that is because there is no limit -!*** imposed on the distance the nest can traverse in any single -!*** move. -! -!*** See the explanation and accompanying diagrams in subroutine -!*** PARENT_BOOKKEEPING_MOVING for more details. The results must -!*** be the same for both H and V points. -!----------------------------------------------------------------------- -! - ALLOCATE(ITS_PARENT_ON_CHILD(0:NUM_TASKS_PARENT-1)) - ALLOCATE(ITE_PARENT_ON_CHILD(0:NUM_TASKS_PARENT-1)) - ALLOCATE(JTS_PARENT_ON_CHILD(0:NUM_TASKS_PARENT-1)) - ALLOCATE(JTE_PARENT_ON_CHILD(0:NUM_TASKS_PARENT-1)) -! - DO N=0,NUM_TASKS_PARENT-1 -! - ITS_PARENT_ON_CHILD(N)=REAL(IDS & !<-- ITS of parent task N in child's coordinate space - -(I_SW_PARENT_NEW-ITS_PARENT(N)) & - *SPACE_RATIO_MY_PARENT) -! - ITE_PARENT_ON_CHILD(N)=REAL(IDS & !<-- ITE of parent task N in child's coordinate space - -(I_SW_PARENT_NEW-ITE_PARENT(N)) & - *SPACE_RATIO_MY_PARENT & - +SPACE_RATIO_MY_PARENT-1) !<-- Filling in gap beyond last parent point on nest grid -! - JTS_PARENT_ON_CHILD(N)=REAL(JDS & !<-- JTS of parent task N in child's coordinate space - -(J_SW_PARENT_NEW-JTS_PARENT(N)) & - *SPACE_RATIO_MY_PARENT) -! - JTE_PARENT_ON_CHILD(N)=REAL(JDS & !<-- JTE of parent task N in child's coordinate space - -(J_SW_PARENT_NEW-JTE_PARENT(N)) & - *SPACE_RATIO_MY_PARENT & - +SPACE_RATIO_MY_PARENT-1) !<-- Filling in gap beyond last parent point on nest grid -! - ENDDO -! -!----------------------------------------------------------------------- -!*** Find the parent task whose subdomain contains the nest point -!*** [I_UPDATE(1),J_UPDATE(1)]. This parent task will be referred -!*** to as parent task #1 since up to four parent tasks might -!*** provide update data to the nest task. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- - search_i: DO NI=0,INPES_PARENT-1 !<-- Look eastward for parent task. -!----------------------------------------------------------------------- -! - update_i: IF(REAL(I_UPDATE(1))>=ITS_PARENT_ON_CHILD(NI)-EPS & !<-- Search for 1st parent task that covers - .AND. & ! nest index I_UPDATE(1). - REAL(I_UPDATE(1))<=ITE_PARENT_ON_CHILD(NI)+EPS) & - THEN !<-- -! -!----------------------------------------------------------------------- - search_j: DO NJ=NI,NUM_TASKS_PARENT-1,INPES_PARENT !<-- Look northward for parent task. -!----------------------------------------------------------------------- -! - update_j: IF(REAL(J_UPDATE(1))>=JTS_PARENT_ON_CHILD(NJ)-EPS & !<-- Search for parent task that covers nest point - .AND. & ! I_UPDATE(1),J_UPDATE(1). - REAL(J_UPDATE(1))<=JTE_PARENT_ON_CHILD(NJ)+EPS) & !<-- - THEN !<-- -! - SEND_TASK(1)%ID=NJ !<-- Store the ID of this parent task who will send data. - ID_1=NJ !<-- Local task ID of the identified parent task. - KOUNT_PARENT_TASKS=1 !<-- Count how many parent tasks send to this nest task. -! -!----------------------------------------------------------------------- -!*** First consider all nest tasks that either lie totally outside -!*** of the footprint or lie on the footprint's edge but not on a -!*** corner. Corners can be very complicated and are each treated -!*** separately. -!----------------------------------------------------------------------- -! - not_a_corner: IF(CORNER==' ')THEN -! -!----------------------------------------------------------------------- -!*** I and J limits on the nest task of data received from the -!*** parent task #1 that covers [I_UPDATE(1),J_UPDATE(1)]. -!----------------------------------------------------------------------- -! - SEND_TASK(1)%ISTART(1)=I_UPDATE(1) !<-- Nest index limits updated by parent task 1. - SEND_TASK(1)%IEND (1)=MIN(I_UPDATE(2) & ! - ,NINT(ITE_PARENT_ON_CHILD(ID_1))) ! - SEND_TASK(1)%JSTART(1)=J_UPDATE(1) ! - SEND_TASK(1)%JEND (1)=MIN(J_UPDATE(2) & ! - ,NINT(JTE_PARENT_ON_CHILD(ID_1))) !<-- -! -!----------------------------------------------------------------------- -!*** Is there a parent task to the the north of the first that covers -!*** points on this nest task's subdomain? -!----------------------------------------------------------------------- -! - IF(JTE_PARENT_ON_CHILD(ID_1)+EPS=J_UPDATE(3))THEN -! - IF(ITE_PARENT_ON_CHILD(ID_1)-EPS<=I_UPDATE(2))THEN - SEND_TASK(1)%JEND(1)=MIN(J_END_X & !<-- Nest J where parent task 1 ends updating nest task. - ,NINT(JTE_PARENT_ON_CHILD(ID_1))) !<-- -! - ELSEIF(ITE_PARENT_ON_CHILD(ID_1)+EPS>=I_UPDATE(3))THEN !<-- Parent task 1 covers SW corner of footprint too. -! - SEND_TASK(1)%JEND(1)=J_UPDATE(2) !<-- Nest J where parent task 1 ends updating nest task's - ! first region. - SEND_TASK(1)%ISTART(2)=I_START_X !<-- 2nd region on nest task updated by parent task 1 - SEND_TASK(1)%IEND(2)=I_UPDATE(2) ! - SEND_TASK(1)%JSTART(2)=J_UPDATE(3) ! - SEND_TASK(1)%JEND(2)=MIN(J_END_X & ! - ,NINT(JTE_PARENT_ON_CHILD(ID_1))) !<-- -! - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** The points in this nest task subdomain being updated by the first -!*** identified parent task have been demarcated. Now identify any -!*** other parent tasks updating this nest task lying on the SW corner -!*** of the footprint. -!----------------------------------------------------------------------- -! -!------------------------------------------------------ -!*** Is there a parent task to the north of the first -!*** that provides update data? -!------------------------------------------------------ -! - sw_north: IF(JTE_PARENT_ON_CHILD(ID_1)+EPS=J_UPDATE(3))THEN ! if either of these statements is true. -! - SEND_TASK(KP)%IEND(1)=MIN(I_UPDATE(2) & !<-- Ending I on nest task where parent task ID_N updates. - ,NINT(ITE_PARENT_ON_CHILD(ID_N))) !<-- - SEND_TASK(KP)%JSTART(1)=NINT(JTS_PARENT_ON_CHILD(ID_N)) !<-- Starting J on nest task where parent task ID_N updates. - SEND_TASK(KP)%JEND(1)=J_END_X !<-- Ending J on nest task where parent task ID_N updates. -! - ELSEIF(ITE_PARENT_ON_CHILD(ID_N)+EPS>=I_UPDATE(3).AND. & !<-- Parent task ID_N covers SW corner of - JTS_PARENT_ON_CHILD(ID_N)-EPS<=J_UPDATE(2))THEN ! footprint too. -! -! | -! | -! | -! | -! + + + + + + + + + + + +.| footprint of nest domain -! + .| in its pre-move location -! + parent task 2's .| -! + 2nd update region .| -! + .| -! +.......................---------------------------------- -! +.............................. + -! + parent task 2's ' <------- parent task 3's update region -! + 1st update region ' + -! ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' <--- parent task boundary -! + ' + -! + parent task 1's ' <------- parent task 4's update region -! + update region ' + -! + ' + -! + + + + + + + + + + + + + + + ' + + + + -! ^ ' -! | ' -! nest task '<--- parent task boundary -! boundary ' -! after move ' -! ' -! - SEND_TASK(KP)%IEND(1)=MIN(I_END_X & !<-- Ending I on nest task where parent task ID_N updates - ,NINT(ITE_PARENT_ON_CHILD(ID_N))) !<-- in nest task's 1st region. - SEND_TASK(KP)%JSTART(1)=NINT(JTS_PARENT_ON_CHILD(ID_N)) !<-- Starting J of parent task ID_N in nest task 1st region. - SEND_TASK(KP)%JEND (1)=J_UPDATE(2) !<-- Ending J of parent task ID_N in nest task 1st region. - SEND_TASK(KP)%ISTART(2)=I_START_X !<-- Starting I of parent task ID_N in nest task 2nd region. - SEND_TASK(KP)%IEND (2)=MIN(I_UPDATE(2) & !<-- Ending I of parent task ID_N in nest task 2nd region. - ,NINT(ITE_PARENT_ON_CHILD(ID_N))) !<-- - SEND_TASK(KP)%JSTART(2)=J_UPDATE(3) !<-- Starting J of parent task ID_N in nest task 2nd region. - SEND_TASK(KP)%JEND (2)=J_END_X !<-- Ending J of parent task ID_N in nest task 2nd region. -! - ENDIF !<-- End contingencies of parent task north of first one. -! -!----------------------------------------------- -!*** Does a parent task northeast of the first -!*** provide any update data? This can only -!*** happen if there was already a parent task -!*** to the north of the first one providing -!*** update data. -!----------------------------------------------- -! -! - IF(ITE_PARENT_ON_CHILD(ID_N)+EPS=J_UPDATE(3))THEN !<-- not cover the SW corner of the footprint. -! - KOUNT_PARENT_TASKS=KOUNT_PARENT_TASKS+1 !<-- Increment parent task counter. - KP=KOUNT_PARENT_TASKS - SEND_TASK(KP)%ID=ID_N+1 !<-- Store the ID of this parent task northeast of the first - ID_NE=SEND_TASK(KP)%ID ! (i.e. east of the parent task to the north of the first). - SEND_TASK(KP)%ISTART(1)=NINT(ITS_PARENT_ON_CHILD(ID_NE)) !<-- Starting I where parent task ID_NE updates nest task. - SEND_TASK(KP)%IEND (1)=I_UPDATE(2) !<-- Ending I where parent task ID_NE updates nest task. - SEND_TASK(KP)%JSTART(1)=NINT(JTS_PARENT_ON_CHILD(ID_NE)) !<-- Starting J where parent task ID_NE updates nest task. - SEND_TASK(KP)%JEND (1)=J_END_X !<-- Ending J where parent task ID_NE updates nest task. -! - ENDIF -! - IF(ITE_PARENT_ON_CHILD(ID_N)+EPS>=I_UPDATE(2) & !<-- 2nd scenario of parent update task to northeast of - .AND. & ! the first update parent task. The NE parent task - ITE_PARENT_ON_CHILD(ID_N)+EPS< I_END_X & ! does not cover the SW corner of the footprint. - .AND. & ! - JTS_PARENT_ON_CHILD(ID_N)-EPS<=J_UPDATE(2))THEN !<-- -! - KOUNT_PARENT_TASKS=KOUNT_PARENT_TASKS+1 !<-- Increment parent task counter. - KP=KOUNT_PARENT_TASKS - SEND_TASK(KP)%ID=ID_N+1 !<-- Store the ID of this parent task northeast of the first. - ID_NE=SEND_TASK(KP)%ID - SEND_TASK(KP)%ISTART(1)=NINT(ITS_PARENT_ON_CHILD(ID_NE)) !<-- Starting I where parent task ID_NE updates nest task. - SEND_TASK(KP)%IEND (1)=I_END_X !<-- Ending I where parent task ID_NE updates nest task. - SEND_TASK(KP)%JSTART(1)=NINT(JTS_PARENT_ON_CHILD(ID_NE)) !<-- Starting J where parent task ID_NE updates nest task. - SEND_TASK(KP)%JEND (1)=J_UPDATE(2) !<-- Ending J where parent task ID_NE updates nest task. -! - ENDIF -! - IF(ITE_PARENT_ON_CHILD(ID_N)+EPS ' .| -! + '.......................---------------------------------- -! + '.................................+ -! + ' parent task 3's + -! + ' 1st update region + -! ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' <--- parent task boundary -! + ' + -! parent task 1's + ' parent task 4's + -! update region ----------> ' update region + -! + ' + <--- nest task boundary after move -! + + + + + ' + + + + + + + + + + + + + + + + + -! ' -! ' -! '<----- parent task boundary -! ' -! ' -! -! - KOUNT_PARENT_TASKS=KOUNT_PARENT_TASKS+1 !<-- Increment the parent task counter. - KP=KOUNT_PARENT_TASKS - SEND_TASK(KP)%ID=ID_N+1 !<-- Store the ID of this parent task northeast of the first. - ID_NE=SEND_TASK(KP)%ID - SEND_TASK(KP)%ISTART(1)=NINT(ITS_PARENT_ON_CHILD(ID_NE)) !<-- Starting I in nest task's 1st region updated by parent. - SEND_TASK(KP)%IEND (1)=I_END_X !<-- Ending I in nest task's 1st region updated by parent. - SEND_TASK(KP)%JSTART(1)=NINT(JTS_PARENT_ON_CHILD(ID_NE)) !<-- Starting J in nest task's 1st region updated by parent. - SEND_TASK(KP)%JEND (1)=J_UPDATE(2) !<-- Ending J in nest task's 1st region updated by parent. - SEND_TASK(KP)%ISTART(2)=NINT(ITS_PARENT_ON_CHILD(ID_NE)) !<-- Starting I in nest task's 2nd region updated by parent. - SEND_TASK(KP)%IEND (2)=I_UPDATE(2) !<-- Ending I in nest task's 2nd region updated by parent. - SEND_TASK(KP)%JSTART(2)=J_UPDATE(3) !<-- Starting J in nest task's 2nd region updated by parent. - SEND_TASK(KP)%JEND (2)=J_END_X !<-- Ending J in nest task's 2nd region updated by parent. -! - ENDIF -! - ENDIF sw_north -! -!---------------------------------------------- -!*** Is there a parent task east of the first -!*** that provides update data? -!---------------------------------------------- -! - sw_east: IF(ITE_PARENT_ON_CHILD(ID_1)+EPS=J_UPDATE(3))THEN -! - IF(ITS_PARENT_ON_CHILD(ID_E)+EPS>=I_UPDATE(3))THEN !<-- 2nd scenario of parent update task to east of first. -! -! | -! | -! | -! | -! + + + + + + + + + + + +.| footprint of nest domain -! + .| in its pre-move location -! + parent task 1's .| -! + 2nd update region .| -! + .| -! +.......................---------------------------------- -! +.............................. + -! + ' + -! + ' + -! + parent task 1's ' + -! + 1st upate region ' <------- parent task 2's update region -! + ' + -! + ' + -! + ' + -! + + + + + + + + + + + + + + + ' + + + + -! ^ ' -! | ' -! nest task '<--- parent task boundary -! boundary ' -! after move ' -! ' -! - SEND_TASK(KP)%IEND(1)=I_END_X - SEND_TASK(KP)%JSTART(1)=J_START_X - SEND_TASK(KP)%JEND(1)=J_UPDATE(2) -! - ELSEIF(ITS_PARENT_ON_CHILD(ID_E)-EPS<=I_UPDATE(2))THEN !<-- 3rd scenario of parent update task to east of first. -! -! | -! ' | -! ' | -! ' | -! + + + + + ' + + + + + + + + + + +.| -! parent task 2's + ' .| -! update region ----------> ' parent task 3's .| footprint of nest domain -! + ' update region .| in its pre-move location -! + ' .| -! ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' -! ^ + ' .| -! parent task | + ' parent task 4's .| -! boundary + ' 2nd update region .| -! + ' .| -! + '.......................---------------------------------- -! parent task 1's + '.................................+ -! update region ----------> ' + -! + ' + -! + ' parent task 4's + -! + ' 1st update region + -! + ' + <--- nest task boundary after move -! + ' + -! + ' + -! + + + + + ' + + + + + + + + + + + + + + + + + -! ' -! ' -! '<----- parent task boundary -! ' -! ' -! -! - SEND_TASK(KP)%IEND (1)=I_END_X !<-- Ending I of 1st update region in nest task by parent. - SEND_TASK(KP)%JSTART(1)=J_START_X !<-- Starting J of 1st update region in nest task by parent. - SEND_TASK(KP)%JEND (1)=J_UPDATE(2) !<-- Ending J of 1st update region in nest task by parent. - SEND_TASK(KP)%ISTART(2)=NINT(ITS_PARENT_ON_CHILD(ID_E)) !<-- Starting I of 2nd update region in nest task by parent. - SEND_TASK(KP)%IEND (2)=I_UPDATE(2) !<-- Ending I of 2nd update region in nest task by parent. - SEND_TASK(KP)%JSTART(2)=J_UPDATE(3) !<-- Starting J of 2nd update region in nest task by parent. - SEND_TASK(KP)%JEND (2)=MIN(J_END_X & !<-- Ending J of 2nd update region in nest task by parent. - ,NINT(JTE_PARENT_ON_CHILD(ID_E))) - ENDIF -! - ENDIF -! - ENDIF sw_east -! - EXIT search_i -! - ENDIF sw -! -!------------------------------------------------------ -!------------------------------------------------------ -!*** The nest task on the SE corner of the footprint. -!------------------------------------------------------ -!------------------------------------------------------ -! - se: IF(CORNER=='SE')THEN !<-- This nest task lies on the SE corner of the footprint. -! - SEND_TASK(1)%ISTART(1)=I_START_X !<-- Nest I where parent task 1 begins updating nest task. - SEND_TASK(1)%IEND(1)=MIN(I_UPDATE(4) & !<-- Nest I where parent task 1 ends updating nest task. - ,NINT(ITE_PARENT_ON_CHILD(ID_1))) -! - SEND_TASK(1)%JSTART(1)=J_START_X !<-- Nest J where parent task 1 begins updating nest task. -! - IF(JTE_PARENT_ON_CHILD(ID_1)-EPS<=J_UPDATE(2))THEN - SEND_TASK(1)%JEND(1)=NINT(JTE_PARENT_ON_CHILD(ID_1)) !<-- Nest J where parent task 1 ends updating nest task. -! - ELSEIF(JTE_PARENT_ON_CHILD(ID_1)+EPS>=J_UPDATE(3))THEN - SEND_TASK(1)%JEND(1)=J_UPDATE(2) !<-- Nest J where parent task 1 ends updating nest task. -! - IF(ITE_PARENT_ON_CHILD(ID_1)+EPS>=I_UPDATE(3))THEN !<-- Parent task 1 covers SE corner of footprint too. -! - SEND_TASK(1)%ISTART(2)=I_UPDATE(3) !<-- 2nd region on nest task updated by parent task 1 - SEND_TASK(1)%IEND(2)=MIN(I_END_X & ! - ,NINT(ITE_PARENT_ON_CHILD(ID_1))) ! - SEND_TASK(1)%JSTART(2)=J_UPDATE(3) ! - SEND_TASK(1)%JEND(2)=MIN(J_END_X & ! - ,NINT(JTE_PARENT_ON_CHILD(ID_1))) !<-- -! - ENDIF - ENDIF -! -!----------------------------------------------------------------------- -!*** The points in this nest task subdomain being updated by the first -!*** identified parent task have been demarcated. Now identify any -!*** other parent tasks updating this nest task lying on the SE corner -!*** of the footprint. -!----------------------------------------------------------------------- -! -!------------------------------------------------------ -!*** Is there a parent task to the north of the first -!*** that provides update data? -!------------------------------------------------------ -! - se_north: IF(JTE_PARENT_ON_CHILD(ID_1)+EPS=I_UPDATE(3))THEN !<-- east side. -! - KOUNT_PARENT_TASKS=KOUNT_PARENT_TASKS+1 !<-- Increment parent task counter. - KP=KOUNT_PARENT_TASKS - SEND_TASK(KP)%ID=ID_1+INPES_PARENT !<-- Store the ID of this parent task to the north. - ID_N=SEND_TASK(KP)%ID -! - IF(JTS_PARENT_ON_CHILD(ID_N)+EPS>=J_UPDATE(3))THEN !<-- Parent task ID_N does not cover SE corner of footprint. - SEND_TASK(KP)%ISTART(1)=I_UPDATE(3) !<-- Starting I on nest task where parent task ID_N updates. - SEND_TASK(KP)%IEND(1)=MIN(I_UPDATE(4) & !<-- Ending I on nest task where parent task ID_N updates. - ,NINT(ITE_PARENT_ON_CHILD(ID_N))) !<-- - SEND_TASK(KP)%JSTART(1)=NINT(JTS_PARENT_ON_CHILD(ID_N)) !<-- Starting J on nest task where parent task ID_N updates. - SEND_TASK(KP)%JEND(1)=J_END_X !<-- Ending J on nest task where parent task ID_N updates. -! - ELSEIF(JTS_PARENT_ON_CHILD(ID_N)-EPS<=J_UPDATE(2))THEN !<-- Parent task ID_N covers SE corner of footprint too. -! - SEND_TASK(KP)%ISTART(1)=I_START_X !<-- Starting I on nest task where parent task ID_N updates - SEND_TASK(KP)%IEND(1)=MIN(I_END_X & !<-- Ending I on nest task where parent task ID_N updates - ,NINT(ITE_PARENT_ON_CHILD(ID_N))) !<-- in nest task's 1st region. - SEND_TASK(KP)%JSTART(1)=NINT(JTS_PARENT_ON_CHILD(ID_N)) !<-- Starting J of parent task ID_N in nest task 1st region. - SEND_TASK(KP)%JEND (1)=J_UPDATE(2) !<-- Ending J of parent task ID_N in nest task 1st region. - SEND_TASK(KP)%ISTART(2)=I_UPDATE(3) !<-- Starting I of parent task ID_N in nest task 2nd region. - SEND_TASK(KP)%IEND (2)=MIN(I_UPDATE(4) & !<-- Ending I of parent task ID_N in nest task 2nd region. - ,NINT(ITE_PARENT_ON_CHILD(ID_N))) !<-- - SEND_TASK(KP)%JSTART(2)=J_UPDATE(3) !<-- Starting J of parent task ID_N in nest task 2nd region. - SEND_TASK(KP)%JEND (2)=J_END_X !<-- Ending J of parent task ID_N in nest task 2nd region. -! - ENDIF -! - ELSEIF(JTE_PARENT_ON_CHILD(ID_1)+EPS=I_UPDATE(2) & ! does not cover the SE corner of the footprint. - .AND. & ! - JTE_PARENT_ON_CHILD(ID_1)+EPS=J_UPDATE(2) & !<-- is north of the SE corner of the footprint. - .AND. & ! - JTE_PARENT_ON_CHILD(ID_1)+EPS=I_UPDATE(3))THEN !<-- 2nd scenario of parent update task E of first. No corner. -! - SEND_TASK(KP)%JEND(1)=MIN(J_END_X & !<-- Ending J of 2nd update region in nest task by parent. - ,NINT(JTE_PARENT_ON_CHILD(ID_E))) !<-- -! - ELSEIF(ITS_PARENT_ON_CHILD(ID_E)-EPS<=I_UPDATE(2) & !<-- 2nd scenario of parent update task to E of first. - .AND. & ! The east parent task covers the SE corner of the - JTE_PARENT_ON_CHILD(ID_E)+EPS>=J_UPDATE(3))THEN !<-- footprint. -! - SEND_TASK(KP)%JEND (1)=J_UPDATE(2) !<-- Ending J of 1st update region in nest task by parent. - SEND_TASK(KP)%ISTART(2)=I_UPDATE(3) !<-- Starting I of 2nd update region in nest task by parent. - SEND_TASK(KP)%IEND (2)=I_END_X !<-- Ending I of 2nd update region in nest task by parent. - SEND_TASK(KP)%JSTART(2)=J_UPDATE(3) !<-- Starting J of 2nd update region in nest task by parent. - SEND_TASK(KP)%JEND (2)=MIN(J_END_X & !<-- Ending J of 2nd update region in nest task by parent. - ,NINT(JTE_PARENT_ON_CHILD(ID_E))) !<-- - ENDIF !<-- Finished with parent task east of the first one. -! - ENDIF se_east -! - EXIT search_i -! - ENDIF se -! -!----------------------------------------------------------------------- -! -!------------------------------------------------------ -!------------------------------------------------------ -!*** The nest task on the NW corner of the footprint. -!------------------------------------------------------ -!------------------------------------------------------ -! - nw: IF(CORNER=='NW')THEN !<-- This nest task lies on the NW corner of the footprint. -! - SEND_TASK(1)%ISTART(1)=I_START_X !<-- Nest I where parent task 1 begins updating nest task. - SEND_TASK(1)%JSTART(1)=J_START_X !<-- Nest J where parent task 1 begins updating nest task. -! - IF(ITE_PARENT_ON_CHILD(ID_1)-EPS<=I_UPDATE(2))THEN - SEND_TASK(1)%IEND(1)=NINT(ITE_PARENT_ON_CHILD(ID_1)) !<-- Nest I where parent task 1 ends updating nest task. - SEND_TASK(1)%JEND(1)=MIN(J_END_X & !<-- Nest J where parent task 1 ends updating nest task. - ,NINT(JTE_PARENT_ON_CHILD(ID_1))) !<-- -! - ELSEIF(ITE_PARENT_ON_CHILD(ID_1)+EPS>=I_UPDATE(3))THEN - SEND_TASK(1)%IEND(1)=I_UPDATE(2) !<-- Nest J where parent task 1 ends updating nest task. - SEND_TASK(1)%JEND(1)=MIN(J_UPDATE(2) & !<-- Nest J where parent task 1 ends updating nest task. - ,NINT(JTE_PARENT_ON_CHILD(ID_1))) !<-- -! - IF(JTE_PARENT_ON_CHILD(ID_1)+EPS>=J_UPDATE(3))THEN !<-- Parent task 1 covers NW corner of footprint too. - SEND_TASK(1)%ISTART(2)=I_START_X !<-- 2nd region on nest task updated by parent task 1 - SEND_TASK(1)%IEND(2)=MIN(I_END_X & ! - ,NINT(ITE_PARENT_ON_CHILD(ID_1))) ! - SEND_TASK(1)%JSTART(2)=J_UPDATE(3) ! - SEND_TASK(1)%JEND(2)=MIN(J_END_X & ! - ,NINT(JTE_PARENT_ON_CHILD(ID_1))) !<-- - ENDIF - ENDIF -! -!----------------------------------------------------------------------- -!*** The points in this nest task subdomain being updated by the first -!*** identified parent task have been demarcated. Now identify any -!*** other parent tasks updating this nest task lying on the NW corner -!*** of the footprint. -!----------------------------------------------------------------------- -! -!------------------------------------------------------ -!*** Is there a parent task to the north of the first -!*** that provides update data? -!------------------------------------------------------ -! - nw_north: IF(JTE_PARENT_ON_CHILD(ID_1)+EPS=J_UPDATE(3) & !<-- Parent task ID_N does not cover NW corner of footprint. - .OR. & ! - ITE_PARENT_ON_CHILD(ID_N)-EPS<=I_UPDATE(2))THEN !<-- -! - SEND_TASK(KP)%IEND(1)=MIN(I_UPDATE(4) & !<-- Ending I on nest task where parent task ID_N updates. - ,NINT(ITE_PARENT_ON_CHILD(ID_N))) !<-- - SEND_TASK(KP)%JEND(1)=J_END_X !<-- Ending J on nest task where parent task ID_N updates. -! - ELSEIF(JTS_PARENT_ON_CHILD(ID_N)-EPS<=J_UPDATE(2) & !<-- Parent task ID_N covers NW corner of footprint too. - .AND. & - ITE_PARENT_ON_CHILD(ID_N)+EPS>=I_UPDATE(3))THEN -! - SEND_TASK(KP)%IEND(1)=MIN(I_UPDATE(2) & !<-- Ending I on nest task where parent task ID_N updates - ,NINT(ITE_PARENT_ON_CHILD(ID_N))) !<-- in nest task's 1st region. - SEND_TASK(KP)%JEND (1)=J_UPDATE(2) !<-- Ending J of parent task ID_N in nest task 1st region. - SEND_TASK(KP)%ISTART(2)=I_START_X !<-- Starting I of parent task ID_N in nest task 2nd region. - SEND_TASK(KP)%IEND (2)=MIN(I_UPDATE(4) & !<-- Ending I of parent task ID_N in nest task 2nd region. - ,NINT(ITE_PARENT_ON_CHILD(ID_N))) !<-- - SEND_TASK(KP)%JSTART(2)=J_UPDATE(3) !<-- Starting J of parent task ID_N in nest task 2nd region. - SEND_TASK(KP)%JEND (2)=J_END_X !<-- Ending J of parent task ID_N in nest task 2nd region. - ENDIF !<-- End contingencies of parent task north of first one. -! -!----------------------------------------------- -!*** Does a parent task northeast of the first -!*** provide any update data? For this to be -!*** true there must be a parent task to the -!*** north of the first so we remain in the -!*** nw_north IF block. -!----------------------------------------------- -! - IF(ITE_PARENT_ON_CHILD(ID_N)+EPS=J_UPDATE(3) & ! - .OR. & ! - ITE_PARENT_ON_CHILD(ID_N)+EPS>=I_UPDATE(2) & ! - .AND. & ! - JTS_PARENT_ON_CHILD(ID_N)-EPS<=J_UPDATE(2)))THEN !<-- -! - KOUNT_PARENT_TASKS=KOUNT_PARENT_TASKS+1 !<-- Increment parent task counter. - KP=KOUNT_PARENT_TASKS - SEND_TASK(KP)%ID=ID_N+1 !<-- Store the ID of this parent task northeast of the first. - ID_NE=SEND_TASK(KP)%ID - SEND_TASK(KP)%ISTART(1)=NINT(ITS_PARENT_ON_CHILD(ID_NE)) !<-- Starting I in nest task's update region. - SEND_TASK(KP)%IEND (1)=I_END_X !<-- Ending I in nest task's update region. - SEND_TASK(KP)%JSTART(1)=MAX(J_UPDATE(3) & !<-- Starting J where parent task ID_NE updates nest. - ,NINT(JTS_PARENT_ON_CHILD(ID_NE))) - SEND_TASK(KP)%JEND (1)=J_END_X !<-- Ending J in nest task's update region. -! - ENDIF -! - ENDIF nw_north -! -!---------------------------------------------- -!*** Is there a parent task east of the first -!*** that provides update data? -!---------------------------------------------- -! - nw_east: IF(ITE_PARENT_ON_CHILD(ID_1)+EPS=J_UPDATE(3))THEN - SEND_TASK(KP)%ISTART(2)=NINT(ITS_PARENT_ON_CHILD(ID_E)) !<-- Starting I for east parent in 2nd update region. - SEND_TASK(KP)%IEND (2)=I_END_X !<-- Ending I for east parent in 2nd update region. - SEND_TASK(KP)%JSTART(2)=J_UPDATE(3) !<-- Starting J for east parent in 2nd update region. - SEND_TASK(KP)%JEND (2)=MIN(J_END_X & !<-- Ending J for east parent in 2nd update region. - ,NINT(JTE_PARENT_ON_CHILD(ID_E))) - ENDIF -! - ENDIF -! - IF(ITE_PARENT_ON_CHILD(ID_1)+EPS>=I_UPDATE(2) & !<-- 2nd scenario of a parent task to the east of - .AND. & ! the first parent task. - JTE_PARENT_ON_CHILD(ID_1)+EPS>=J_UPDATE(3))THEN !<-- -! - KOUNT_PARENT_TASKS=KOUNT_PARENT_TASKS+1 !<-- Increment the parent task counter. - KP=KOUNT_PARENT_TASKS - SEND_TASK(KP)%ID=ID_1+1 !<-- Store the ID of this parent task to the east. - ID_E=SEND_TASK(KP)%ID - SEND_TASK(KP)%ISTART(1)=NINT(ITS_PARENT_ON_CHILD(ID_E)) !<-- Starting I where parent task ID_E updates nest task. - SEND_TASK(KP)%IEND (1)=I_END_X !<-- Ending I where parent task ID_E updates nest task. - SEND_TASK(KP)%JSTART(1)=J_UPDATE(3) !<-- Starting J where parent task ID_E updates nest task. - SEND_TASK(KP)%JEND (1)=MIN(J_END_X & !<-- Ending J where parent task ID_E updates nest task. - ,NINT(JTE_PARENT_ON_CHILD(ID_E))) - ENDIF -! - ENDIF nw_east -! - EXIT search_i -! - ENDIF nw -! -!------------------------------------------------------ -!------------------------------------------------------ -!*** The nest task on the NE corner of the footprint. -!------------------------------------------------------ -!------------------------------------------------------ -! - ne: IF(CORNER=='NE')THEN !<-- This nest task lies on the NE corner of the footprint. -! -!----------------------------------------------------------------------- -!*** The northeast corner of the footprint is even more involved -!*** than the other three because [I_UPDATE(1),J_UPDATE(1)] on this -!*** nest task is within the footprint of the nest's previous location -!*** and thus is not updated by parent task 1. In fact parent task 1 -!*** might not update any points on this nest task if that region of -!*** the nest task covered by parent task 1 lies entirely within the -!*** footprint. -!----------------------------------------------------------------------- -! - KOUNT_PARENT_TASKS=0 !<-- Parent task ID_1 might not send any data. -! - IF(ITE_PARENT_ON_CHILD(ID_1)+EPS>=I_UPDATE(3))THEN -! - KOUNT_PARENT_TASKS=1 !<-- Parent task ID_1 does send data. - SEND_TASK(1)%ISTART(1)=I_UPDATE(3) !<-- Nest I where parent task 1 begins updating nest task. - SEND_TASK(1)%IEND(1)=MIN(I_END_X & !<-- Nest I where parent task 1 ends updating nest task. - ,NINT(ITE_PARENT_ON_CHILD(ID_1))) - SEND_TASK(1)%JSTART(1)=J_START_X !<-- Nest J where parent task 1 begins updating nest task. - SEND_TASK(1)%JEND (1)=MIN(J_UPDATE(2) & !<-- Nest J where parent task 1 ends updating nest task. - ,NINT(JTE_PARENT_ON_CHILD(ID_1))) -! - IF(JTE_PARENT_ON_CHILD(ID_1)+EPS>=J_UPDATE(3))THEN - SEND_TASK(1)%ISTART(2)=I_START_X !<-- Nest I where parent task 1 begins updating 2nd region. - SEND_TASK(1)%IEND (2)=SEND_TASK(1)%IEND(1) !<-- Nest I where parent task 1 ends updating 2nd region. - SEND_TASK(1)%JSTART(2)=J_UPDATE(3) !<-- Nest J where parent task 1 begins updating 2nd region. - SEND_TASK(1)%JEND (2)=MIN(J_END_X & !<-- Nest J where parent task 1 ends updating 2nd region. - ,NINT(JTE_PARENT_ON_CHILD(ID_1))) - ENDIF -! - ELSEIF(JTE_PARENT_ON_CHILD(ID_1)+EPS>=J_UPDATE(3))THEN -! - KOUNT_PARENT_TASKS=1 !<-- Parent task ID_1 does send data. - SEND_TASK(1)%ISTART(1)=I_UPDATE(1) !<-- Nest I where parent task 1 begins updating nest task. - SEND_TASK(1)%IEND(1)=NINT(ITE_PARENT_ON_CHILD(ID_1)) !<-- Nest I where parent task 1 ends updating nest task. - SEND_TASK(1)%JSTART(1)=J_UPDATE(3) !<-- Nest J where parent task 1 begins updating nest task. - SEND_TASK(1)%JEND(1)=MIN(J_END_X & !<-- Nest J where parent task 1 ends updating 2nd region. - ,NINT(JTE_PARENT_ON_CHILD(ID_1))) -! - ENDIF -! -!----------------------------------------------------------------------- -!*** The points in this nest task subdomain being updated by the first -!*** identified parent task have been demarcated. Now identify any -!*** other parent tasks updating this nest task lying on the NE corner -!*** of the footprint. -!----------------------------------------------------------------------- -! -!------------------------------------------------------ -!*** Is there a parent task to the north of the first -!*** that provides update data? -!------------------------------------------------------ -! - ne_north: IF(JTE_PARENT_ON_CHILD(ID_1)+EPS=I_UPDATE(3))THEN - SEND_TASK(KP)%IEND (1)=MIN(I_END_X & !<-- Nest I where parent task ID_N ends updating this region. - ,NINT(ITE_PARENT_ON_CHILD(ID_N))) - IF(JTS_PARENT_ON_CHILD(ID_N)<=J_UPDATE(2))THEN !<-- 2nd scenario of parent task north of the first. - SEND_TASK(KP)%ISTART(1)=I_UPDATE(3) !<-- Nest I where parent task ID_N begins updating this region. - SEND_TASK(KP)%JSTART(1)=NINT(JTS_PARENT_ON_CHILD(ID_N)) !<-- Nest J where parent task ID_N begins updating this region. - SEND_TASK(KP)%JEND (1)=J_UPDATE(2) !<-- Nest J where parent task ID_N ends updating this region. - SEND_TASK(KP)%ISTART(2)=I_START_X !<-- Nest I where parent task ID_N begins updating 2nd region. - SEND_TASK(KP)%IEND (2)=SEND_TASK(KP)%IEND(1) !<-- Nest I where parent task ID_N ends updating 2nd region. - SEND_TASK(KP)%JSTART(2)=J_UPDATE(3) !<-- Nest J where parent task ID_N begins updating 2nd region. - SEND_TASK(KP)%JEND (2)=J_END_X !<-- Nest J where parent task ID_N ends updating 2nd region. - ELSEIF(JTS_PARENT_ON_CHILD(ID_N)>=J_UPDATE(3))THEN !<-- 3rd scenario of parent task north of the first. - SEND_TASK(KP)%ISTART(1)=I_START_X !<-- Nest I where parent task ID_N begins updating this region. - SEND_TASK(KP)%JSTART(1)=MAX(J_UPDATE(3) & !<-- Nest J where parent task ID_N begins updating this region. - ,NINT(JTS_PARENT_ON_CHILD(ID_N))) - SEND_TASK(KP)%JEND (1)=J_END_X !<-- Nest J where parent task ID_N begins updating this region. - ENDIF - ENDIF -! -!----------------------------------------------- -!*** Does a parent task northeast of the first -!*** provide any update data? This can only -!*** happen if there was a parent task to -!*** the north of the first therefore we -!*** remain in the ne_north IF block. -!----------------------------------------------- -! - ne_ne: IF(ITE_PARENT_ON_CHILD(ID_N)+EPS=J_UPDATE(3) & !<-- 1st scenario of parent task to the NE of the first. - .OR. & ! - ITS_PARENT_ON_CHILD(ID_NE)+EPS>=I_UPDATE(3) & ! - .AND. & ! - JTS_PARENT_ON_CHILD(ID_NE)-EPS<=J_UPDATE(2))THEN !<-- -! - SEND_TASK(KP)%ISTART(1)=NINT(ITS_PARENT_ON_CHILD(ID_NE)) !<-- Nest I where parent task ID_NE begins updating this region. - SEND_TASK(KP)%IEND (1)=I_END_X !<-- Nest I where parent task ID_NE ends updating this region. - SEND_TASK(KP)%JSTART(1)=NINT(JTS_PARENT_ON_CHILD(ID_NE)) !<-- Nest J where parent task ID_NE begins updating this region. - SEND_TASK(KP)%JEND (1)=J_END_X !<-- Nest J where parent task ID_NE ends updating this region. - ENDIF -! - IF(ITS_PARENT_ON_CHILD(ID_NE)-EPS<=I_UPDATE(2) & !<-- 2nd scenario of parent task to the NE of the first. - .AND. & ! - JTS_PARENT_ON_CHILD(ID_NE)-EPS<=J_UPDATE(2))THEN !<-- -! - SEND_TASK(KP)%ISTART(1)=I_UPDATE(3) !<-- Nest I where parent task ID_NE begins updating this region - SEND_TASK(KP)%IEND (1)=I_END_X !<-- Nest I where parent task ID_NE ends updating this region. - SEND_TASK(KP)%JSTART(1)=NINT(JTS_PARENT_ON_CHILD(ID_NE)) !<-- Nest J where parent task ID_NE begins updating this region - SEND_TASK(KP)%JEND (1)=J_UPDATE(2) !<-- Nest J where parent task ID_NE ends updating this region. - SEND_TASK(KP)%ISTART(2)=NINT(ITS_PARENT_ON_CHILD(ID_NE)) !<-- Nest I where parent task ID_NE begins updating 2nd region. - SEND_TASK(KP)%IEND (2)=I_END_X !<-- Nest I where parent task ID_NE ends updating 2nd region. - SEND_TASK(KP)%JSTART(2)=J_UPDATE(3) !<-- Nest J where parent task ID_NE begins updating 2nd region. - SEND_TASK(KP)%JEND (2)=J_END_X !<-- Nest J where parent task ID_NE ends updating 2nd region. - ENDIF -! - ENDIF ne_ne -! - ENDIF ne_north -! -!---------------------------------------------- -!*** Is there a parent task east of the first -!*** that provides update data? -!---------------------------------------------- -! - ne_east: IF(ITE_PARENT_ON_CHILD(ID_1)+EPS=I_UPDATE(3))THEN !<-- 1st scenario of parent task east of the first. - SEND_TASK(KP)%ISTART(1)=NINT(ITS_PARENT_ON_CHILD(ID_E)) !<-- Starting I where parent task ID_E updates nest task. - SEND_TASK(KP)%IEND (1)=I_END_X !<-- Ending I where parent task ID_E updates nest task. - SEND_TASK(KP)%JSTART(1)=J_START_X !<-- Starting J where parent task ID_E updates nest task. - SEND_TASK(KP)%JEND (1)=MIN(J_END_X & !<-- Ending J where parent task ID_E updates nest task. - ,NINT(JTE_PARENT_ON_CHILD(ID_E))) - ENDIF -! - IF(ITS_PARENT_ON_CHILD(ID_E)-EPS<=I_UPDATE(2))THEN - SEND_TASK(KP)%ISTART(1)=I_UPDATE(3) !<-- Nest I where parent task ID_E begins updating 1st region. - SEND_TASK(KP)%IEND (1)=I_END_X !<-- Nest I where parent task ID_E ends updating 1st region. - SEND_TASK(KP)%JSTART(1)=J_START_X !<-- Nest J where parent task ID_E begins updating 1st region. - SEND_TASK(KP)%JEND (1)=MIN(J_UPDATE(2) & !<-- Nest J where parent task ID_E ends updating 1st region. - ,NINT(JTE_PARENT_ON_CHILD(ID_E))) -! - IF(JTE_PARENT_ON_CHILD(ID_E)+EPS>=J_UPDATE(3))THEN - SEND_TASK(KP)%ISTART(2)=NINT(ITS_PARENT_ON_CHILD(ID_E)) !<-- Nest I where parent task ID_E begins updating 2nd region. - SEND_TASK(KP)%IEND (2)=I_END_X !<-- Nest I where parent task ID_E ends updating 2nd region. - SEND_TASK(KP)%JSTART(2)=J_UPDATE(3) !<-- Nest J where parent task ID_E begins updating 2nd region. - SEND_TASK(KP)%JEND (2)=MIN(J_END_X & !<-- Nest I where parent task ID_E ends updating 2nd region. - ,NINT(JTE_PARENT_ON_CHILD(ID_E))) - ENDIF - ENDIF -! - ENDIF ne_east -! - EXIT search_i -! - ENDIF ne -! -!----------------------------------------------------------------------- -! - ENDIF update_j -! - ENDDO search_j -! - ENDIF update_i -! - ENDDO search_i -! -!----------------------------------------------------------------------- -!*** Add up the number of points being updated by each parent task. -!----------------------------------------------------------------------- -! - DO KP=1,KOUNT_PARENT_TASKS -! - SEND_TASK(KP)%NPTS=(SEND_TASK(KP)%IEND(1) & - -SEND_TASK(KP)%ISTART(1)+1)* & - (SEND_TASK(KP)%JEND(1) & - -SEND_TASK(KP)%JSTART(1)+1) -! - IF(SEND_TASK(KP)%ISTART(2)>=IMS)THEN !<-- Add points for 2nd regions on corners if present. - SEND_TASK(KP)%NPTS=SEND_TASK(KP)%NPTS & - +(SEND_TASK(KP)%IEND(2) & - -SEND_TASK(KP)%ISTART(2)+1)* & - (SEND_TASK(KP)%JEND(2) & - -SEND_TASK(KP)%JSTART(2)+1) - ENDIF -! - ENDDO -! -!----------------------------------------------------------------------- -! - DEALLOCATE(ITS_PARENT_ON_CHILD) - DEALLOCATE(ITE_PARENT_ON_CHILD) - DEALLOCATE(JTS_PARENT_ON_CHILD) - DEALLOCATE(JTE_PARENT_ON_CHILD) -! -!----------------------------------------------------------------------- -! - END SUBROUTINE MOVING_NEST_BOOKKEEPING -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE MOVING_NEST_RECV_DATA(COMM_TO_MY_PARENT & - ,NTIMESTEP & - ,NUM_FIELDS_MOVE_2D_H_I & - ,NUM_FIELDS_MOVE_2D_X_I & - ,NUM_FIELDS_MOVE_2D_H_R & - ,NUM_FIELDS_MOVE_2D_X_R & - ,NUM_LEVELS_MOVE_3D_H & - ,NUM_FIELDS_MOVE_2D_V & - ,NUM_LEVELS_MOVE_3D_V & - ,SEND_TASK & - ,EXPORT_STATE & - ) -! -!----------------------------------------------------------------------- -!*** After having determined which of their internal gridpoints -!*** need to be updated by which parent tasks following a nest's -!*** move, the nest's forecast tasks now receive the update data -!*** from the parent. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: COMM_TO_MY_PARENT & !<-- MPI communicator from this nest to its parent - ,NTIMESTEP & !<-- Nest's current timestep - ,NUM_FIELDS_MOVE_2D_H_I & !<-- # of 2-D internal state integer H variables to be updated - ,NUM_FIELDS_MOVE_2D_X_I & !<-- # of 2-D integer H variables updated from external files - ,NUM_FIELDS_MOVE_2D_H_R & !<-- # of 2-D internal state real H variables to be updated - ,NUM_FIELDS_MOVE_2D_X_R & !<-- # of 2-D real H variables updated from external files - ,NUM_LEVELS_MOVE_3D_H & !<-- # of 2-D levels in all 3-D H update variables - ,NUM_FIELDS_MOVE_2D_V & !<-- # of 2-D internal state V variables to be updated - ,NUM_LEVELS_MOVE_3D_V !<-- # of 2-D levels in all 3-D V update variables -! - TYPE(INTERIOR_DATA_FROM_PARENT),DIMENSION(1:4),INTENT(IN) :: & - SEND_TASK !<-- Specifics about interior data from sending parent tasks -! - TYPE(ESMF_State),INTENT(INOUT) :: EXPORT_STATE !<-- The Parent-Child coupler export state -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: ITAG,N,NUM_PTASK_UPDATE,NUM_WORDS -! - INTEGER(kind=KINT) :: IERR,RC,RC_RECV -! - INTEGER(kind=KINT),DIMENSION(1:8) :: INDICES_H,INDICES_V -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: UPDATE_INTEGER_DATA -! - INTEGER,DIMENSION(MPI_STATUS_SIZE) :: JSTAT -! - REAL(kind=KFPT),DIMENSION(:),ALLOCATABLE :: UPDATE_REAL_DATA -! - CHARACTER(len=1) :: N_PTASK - CHARACTER(len=12) :: NAME - CHARACTER(len=17) :: NAME_REAL - CHARACTER(len=20) :: NAME_INTEGER -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RC_RECV=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** First load into the Parent-Child coupler export state the -!*** number of parent tasks that send update data to this nest task. -!*** We insist that parent tasks will update the same H and V points -!*** with respect to their I,J indices. -!----------------------------------------------------------------------- -! - NUM_PTASK_UPDATE=0 -! - DO N=1,4 !<-- No more than 4 parent tasks will send data. - IF(SEND_TASK(N)%ID<0)THEN - EXIT - ELSE - NUM_PTASK_UPDATE=NUM_PTASK_UPDATE+1 - ENDIF - ENDDO -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="MOVING_NEST_RECV_DATA: Load # of Parent Tasks Sending Interior Updates" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXPORT_STATE & !<-- The Parent-Child coupler export state - ,name ='Num Parent Tasks Update' & !<-- Name of the variable - ,value=NUM_PTASK_UPDATE & !<-- # of parent tasks that update this nest task - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RECV) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** If no parent tasks are sending update data to this nest task -!*** then there is nothing more to do so RETURN. -!----------------------------------------------------------------------- -! - IF(NUM_PTASK_UPDATE==0)RETURN -! -!----------------------------------------------------------------------- -! - parent_tasks: DO N=1,NUM_PTASK_UPDATE -! -!----------------------------------------------------------------------- -! - NUM_WORDS=(NUM_FIELDS_MOVE_2D_H_R-NUM_FIELDS_MOVE_2D_X_R & !<-- Total # of real words coming from Nth parent task - +NUM_LEVELS_MOVE_3D_H)*SEND_TASK(N)%NPTS & - +(NUM_FIELDS_MOVE_2D_V+NUM_LEVELS_MOVE_3D_V) & - *SEND_TASK(N)%NPTS -! - ALLOCATE(UPDATE_REAL_DATA(1:NUM_WORDS)) !<-- Allocate the Recv buffer -! - ITAG=NUM_WORDS+NTIMESTEP !<-- Tag that changes for both data size and time -! -!----------------------------------------------------------------------- -!*** Receive the interior H and V real update data sent by -!*** parent task N. -!----------------------------------------------------------------------- -! - CALL MPI_RECV(UPDATE_REAL_DATA & !<-- Real update data from Nth parent task - ,NUM_WORDS & !<-- # of real words received - ,MPI_REAL & !<-- The data is Real - ,SEND_TASK(N)%ID & !<-- Receive from parent task with this rank - ,ITAG & !<-- Unique MPI tag - ,COMM_TO_MY_PARENT & !<-- MPI communicator from this nest to its parent - ,JSTAT & !<-- MPI status object - ,IERR ) -! -!----------------------------------------------------------------------- -!*** Load the update data and associated index limits into the -!*** Parent-Child coupler export state so it can be sent back into -!*** the DOMAIN component for incorporation. -!----------------------------------------------------------------------- -! - WRITE(N_PTASK,'(I1)')N - NAME_REAL='PTASK_REAL_DATA_'//N_PTASK -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load # of Words in Real Update Data from Parent" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXPORT_STATE & !<-- The Parent-Child coupler export state - ,name =NAME_REAL//' Words' & !<-- Name of the variable - ,value=NUM_WORDS & !<-- Put # of real words here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RECV) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Real Update Data from Parent into P-C Cpl Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state =EXPORT_STATE & !<-- The Parent-Child coupler export state - ,name =NAME_REAL & !<-- Name of the variable - ,itemCount=NUM_WORDS & !<-- # of words in real update data from parent task N - ,valueList=UPDATE_REAL_DATA & !<-- The real update data from parent task N - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RECV) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DEALLOCATE(UPDATE_REAL_DATA) -! -!----------------------------------------------------------------------- -!*** There may or may not be integer variable updates at this time. -!----------------------------------------------------------------------- -! - NUM_WORDS=(NUM_FIELDS_MOVE_2D_H_I-NUM_FIELDS_MOVE_2D_X_I) & !<-- Total # of integer words coming from - *SEND_TASK(N)%NPTS ! the Nth parent task -! -!----------------------------------------------------------------------- -!*** Load into the Parent-Child coupler export state the number -!*** of integer words to be updated so the value can be sent to -!*** the DOMAIN component for incorporation of the integer data. -!----------------------------------------------------------------------- -! - WRITE(N_PTASK,'(I1)')N - NAME_INTEGER='PTASK_INTEGER_DATA_'//N_PTASK -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load # of Words in Integer Update Data from Parent" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXPORT_STATE & !<-- The Parent-Child coupler export state - ,name =NAME_INTEGER//' Words' & !<-- Name of the variable - ,value=NUM_WORDS & !<-- Put # of integer words here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RECV) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - recv_int: IF(NUM_WORDS>0)THEN -! -!----------------------------------------------------------------------- -! - ALLOCATE(UPDATE_INTEGER_DATA(1:NUM_WORDS)) !<-- Allocate the Recv buffer -! - ITAG=NUM_WORDS+NTIMESTEP !<-- Tag that changes for both data size and time -! -!----------------------------------------------------------------------- -!*** Receive the interior integer update data for H and V points -!*** sent by parent task N. -!----------------------------------------------------------------------- -! - CALL MPI_RECV(UPDATE_INTEGER_DATA & !<-- Integer update data from Nth parent task - ,NUM_WORDS & !<-- # of integer words received - ,MPI_INTEGER & !<-- The data is Integer - ,SEND_TASK(N)%ID & !<-- Receive from parent task with this rank - ,ITAG & !<-- Unique MPI tag - ,COMM_TO_MY_PARENT & !<-- MPI communicator from this nest to its parent - ,JSTAT & !<-- MPI status object - ,IERR ) -! -!----------------------------------------------------------------------- -!*** Load the update data and associated index limits into the -!*** Parent-Child coupler export state so it can be sent back into -!*** the DOMAIN component for incorporation. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Integer Update Data from Parent into P-C Cpl Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state =EXPORT_STATE & !<-- The Parent-Child coupler export state - ,name =NAME_INTEGER & !<-- Name of the variable - ,itemCount=NUM_WORDS & !<-- # of words in integer update data from parent task N - ,valueList=UPDATE_INTEGER_DATA & !<-- The integer update data from parent task N - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RECV) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DEALLOCATE(UPDATE_INTEGER_DATA) -! -!----------------------------------------------------------------------- -! - ENDIF recv_int -! -!----------------------------------------------------------------------- -! - INDICES_H(1)=SEND_TASK(N)%ISTART(1) - INDICES_H(2)=SEND_TASK(N)%ISTART(2) - INDICES_H(3)=SEND_TASK(N)%IEND(1) - INDICES_H(4)=SEND_TASK(N)%IEND(2) - INDICES_H(5)=SEND_TASK(N)%JSTART(1) - INDICES_H(6)=SEND_TASK(N)%JSTART(2) - INDICES_H(7)=SEND_TASK(N)%JEND(1) - INDICES_H(8)=SEND_TASK(N)%JEND(2) -! - INDICES_V(1)=SEND_TASK(N)%ISTART(1) - INDICES_V(2)=SEND_TASK(N)%ISTART(2) - INDICES_V(3)=SEND_TASK(N)%IEND(1) - INDICES_V(4)=SEND_TASK(N)%IEND(2) - INDICES_V(5)=SEND_TASK(N)%JSTART(1) - INDICES_V(6)=SEND_TASK(N)%JSTART(2) - INDICES_V(7)=SEND_TASK(N)%JEND(1) - INDICES_V(8)=SEND_TASK(N)%JEND(2) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Index Limits for Update Data from Parent" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - WRITE(N_PTASK,'(I1)')N - NAME='PTASK_DATA_'//N_PTASK -! - CALL ESMF_AttributeSet(state =EXPORT_STATE & !<-- The Parent-Child coupler export state - ,name =NAME//' Indices H' & !<-- Name of the variable - ,itemCount=N8 & !<-- # of words in index limits of update data - ,valueList=INDICES_H & !<-- The update data index specifications for H - ,rc =RC) -! - CALL ESMF_AttributeSet(state =EXPORT_STATE & !<-- The Parent-Child coupler export state - ,name =NAME//' Indices V' & !<-- Name of the variable - ,itemCount=N8 & !<-- # of words in index limits of update data - ,valueList=INDICES_V & !<-- The update data index specifications for V - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RECV) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - ENDDO parent_tasks -! -!----------------------------------------------------------------------- -! - END SUBROUTINE MOVING_NEST_RECV_DATA -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE PARENT_UPDATES_HALOS(FLAG_H_OR_V & - ,MOVE_BUNDLE & - ,NFLDS_3DR & - ,NFLDS_2DR & - ,NFLDS_2DI & - ) -! -!----------------------------------------------------------------------- -!*** Before a parent can update locations on its moving nests' domains -!*** it must perform halo exchanges for all those variables specified -!*** for use in updates but which do not have their halos exchanged -!*** during the normal integration. Use of the parent tasks halo -!*** regions cannot be avoided during the nest point updates. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - CHARACTER(len=1),INTENT(IN) :: FLAG_H_OR_V -! - TYPE(ESMF_FieldBundle),INTENT(INOUT) :: MOVE_BUNDLE !<-- ESMF Bundle of 2-D and 3-D arrays specified for updating -! - INTEGER(kind=KINT),INTENT(IN) :: NFLDS_2DR & !<-- # of 2-D real arrays specified for updating - ,NFLDS_3DR !<-- # of 3-D real arrays specified for updating -! - INTEGER(kind=KINT),INTENT(IN),OPTIONAL :: NFLDS_2DI !<-- # of 2-D integer arrays specified for updating -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: N_FIELD,N_REMOVE,NUM_DIMS & - ,NUM_FIELDS_MOVE,NUM_LEVELS & - ,RC,RC_FINAL -! - INTEGER(kind=KINT),DIMENSION(1:3) :: LIMITS_HI & - ,LIMITS_LO -! - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ARRAY_2D -! - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: ARRAY_3D -! - CHARACTER(len=30) :: FIELD_NAME -! - TYPE(ESMF_Field) :: HOLD_FIELD -! - TYPE(ESMF_TypeKind_Flag) :: DATATYPE -! - LOGICAL(kind=KLOG) :: EXCH_NEEDED -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** What is the total number of Fields in the update data BUNDLE? -!----------------------------------------------------------------------- -! - IF(FLAG_H_OR_V=='H')THEN - NUM_FIELDS_MOVE=NFLDS_2DI+NFLDS_2DR+NFLDS_3DR -! - ELSEIF(FLAG_H_OR_V=='V')THEN - NUM_FIELDS_MOVE=NFLDS_2DR+NFLDS_3DR - ENDIF -! -!----------------------------------------------------------------------- -!*** Check each Field to see if its array has its halo exchanged -!*** during the integration. -!----------------------------------------------------------------------- -! - field_loop: DO N_FIELD=1,NUM_FIELDS_MOVE -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Each Field From Move_Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=MOVE_BUNDLE & !<-- Bundle holding the arrays for move updates - ,fieldIndex =N_FIELD & !<-- Index of the Field in the Bundle - ,field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Type, Dimensions, Name of the Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,dimCount=NUM_DIMS & !<-- Is this Field 2-D or 3-D? - ,typeKind=DATATYPE & !<-- Is this Field integer or real? - ,name =FIELD_NAME & !<-- This Field's name - ,rc =RC ) -! - N_REMOVE=INDEX(FIELD_NAME,SUFFIX_MOVE) - FIELD_NAME=FIELD_NAME(1:N_REMOVE-1) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** None of the variables needed by the parent for updating its -!*** moving nests are type integer so we can skip those outright. -!----------------------------------------------------------------------- -! - IF(DATATYPE==ESMF_TYPEKIND_I4)THEN - CYCLE field_loop - ENDIF -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract the Halo Exchange Flag" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(field=HOLD_FIELD & !<-- Take Attribute from this Field - ,name ='EXCH_NEEDED' & !<-- The Attribute's name - ,value=EXCH_NEEDED & !<-- The Attribute's value - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Move to the next Field if a halo exchange is not needed. -!----------------------------------------------------------------------- -! - IF(.NOT.EXCH_NEEDED)THEN - CYCLE field_loop - ENDIF -! -!----------------------------------------------------------------------- -!*** 2-D Fields -!----------------------------------------------------------------------- -! - dims_2_or_3: IF(NUM_DIMS==2)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract the 2-D Array from Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,localDe =0 & - ,farrayPtr=ARRAY_2D & !<-- Dummy 2-D real array with Field's data - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL HALO_EXCH(ARRAY_2D,1,1,1) -! -!----------------------------------------------------------------------- -!*** 3-D Fields -!----------------------------------------------------------------------- -! - ELSEIF(NUM_DIMS==3)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract the 3-D Array from Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,localDe =0 & - ,farrayPtr =ARRAY_3D & !<-- Dummy 3-D real array with Field's data - ,totalLBound=LIMITS_LO & !<-- Starting index in each dimension - ,totalUBound=LIMITS_HI & !<-- Ending index in each dimension - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NUM_LEVELS=LIMITS_HI(3)-LIMITS_LO(3)+1 -! - CALL HALO_EXCH(ARRAY_3D,NUM_LEVELS,1,1) -! -!----------------------------------------------------------------------- -! - ENDIF dims_2_or_3 -! -!----------------------------------------------------------------------- -! - ENDDO field_loop -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PARENT_UPDATES_HALOS -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE PARENT_BOOKKEEPING_MOVING(I_PARENT_SW_NEW & - ,J_PARENT_SW_NEW & - ,I_PARENT_SW_OLD & - ,J_PARENT_SW_OLD & - ,ITS,ITE,JTS,JTE & - ,NUM_CHILD_TASKS & - ,CHILD_TASK_LIMITS & - ,PARENT_CHILD_SPACE_RATIO & - ,NHALO & - ,NROWS_P_UPD_W & - ,NROWS_P_UPD_E & - ,NROWS_P_UPD_S & - ,NROWS_P_UPD_N & - ,N_UPDATE_CHILD_TASKS & - ,TASK_UPDATE_SPECS & - ,HANDLE_UPDATE & - ,CHILD_UPDATE_DATA & - ) -! -!----------------------------------------------------------------------- -!*** This parent has learned that one of its children wants to move -!*** to a new location therefore the parent must determine which -!*** points on which child tasks need to be updated by which of its -!*** own tasks. Update points on nests are those that lie outside -!*** of the nest's pre-move footprint following the move. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: I_PARENT_SW_NEW & !<-- SW corner of nest on this parent I after move - ,I_PARENT_SW_OLD & !<-- SW corner of nest on this parent I before move - ,J_PARENT_SW_NEW & !<-- SW corner of nest on this parent J after move - ,J_PARENT_SW_OLD & !<-- SW corner of nest on this parent J before move -! - ,ITS,ITE,JTS,JTE & !<-- Subdomain integration limits of parent task -! - ,NHALO & !<-- # of halo points - ,NROWS_P_UPD_W & !<-- Moving nest footprint W bndry rows updated by parent - ,NROWS_P_UPD_E & !<-- Moving nest footprint E bndry rows updated by parent - ,NROWS_P_UPD_S & !<-- Moving nest footprint S bndry rows updated by parent - ,NROWS_P_UPD_N & !<-- Moving nest footprint N bndry rows updated by parent - ,NUM_CHILD_TASKS & !<-- # of child forecast tasks - ,PARENT_CHILD_SPACE_RATIO !<-- # of child grid increments in one of parent's -! - INTEGER(kind=KINT),DIMENSION(1:4,NUM_CHILD_TASKS),INTENT(IN) :: & - CHILD_TASK_LIMITS !<-- ITS,ITE,JTS,JTE for each child forecast task -! - INTEGER(kind=KINT),INTENT(INOUT) :: N_UPDATE_CHILD_TASKS !<-- # of moving nest tasks to be updated by this parent task -! - INTEGER(kind=KINT),DIMENSION(1:NUM_CHILD_TASKS),INTENT(IN) :: & - HANDLE_UPDATE !<-- MPI Handles for ISends to the child tasks -! - TYPE(CHILD_UPDATE_LINK),TARGET,INTENT(INOUT) :: TASK_UPDATE_SPECS !<-- Linked list with nest task update region specifications -! - TYPE(MIXED_DATA_TASKS),INTENT(INOUT) :: CHILD_UPDATE_DATA !<-- Composite of all update data from parent for nest tasks -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: I_SHIFT,I1,I2 & - ,IDE_CHILD,IDS_CHILD & - ,IMS_CHILD,IME_CHILD & - ,IDE_FOOTPRINT,IDS_FOOTPRINT & - ,ITE_PARENT_ON_CHILD,ITS_PARENT_ON_CHILD & - ,J_SHIFT,J1,J2 & - ,JDE_CHILD,JDS_CHILD & - ,JMS_CHILD,JME_CHILD & - ,JDE_FOOTPRINT,JDS_FOOTPRINT & - ,JTE_PARENT_ON_CHILD,JTS_PARENT_ON_CHILD & - ,KOUNT_TASKS,N,NN -! - INTEGER(kind=KINT) :: IERR,ISTAT -! - INTEGER,DIMENSION(MPI_STATUS_SIZE) :: JSTAT -! - REAL(kind=KFPT) :: I1R,I2R & - ,ITE_PARENT_ON_CHILD_R,ITS_PARENT_ON_CHILD_R & - ,J1R,J2R & - ,JTE_PARENT_ON_CHILD_R,JTS_PARENT_ON_CHILD_R -! - TYPE(CHILD_UPDATE_LINK),POINTER :: PTR,PTR_X -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Prior to doing anything related to updating nest tasks -!*** following the latest move, be sure that all update data -!*** that this parent task might have sent to any nest tasks -!*** following the preceding move has indeed been received -!*** by all of those tasks whether or not this parent task -!*** will send to any of the same nest tasks this time. -!----------------------------------------------------------------------- -! - PTR=>TASK_UPDATE_SPECS !<-- Start at the top of the list of updated nest tasks -! - DO WHILE(ASSOCIATED(PTR%TASK_ID)) !<-- A link exists if TASK_ID is associated. - CALL MPI_WAIT(HANDLE_UPDATE(PTR%TASK_ID) & !<-- Handle for ISend from parent task to child task - ,JSTAT & !<-- MPI status - ,IERR ) - IF(ASSOCIATED(PTR%NEXT_LINK))THEN - PTR=>PTR%NEXT_LINK - ELSE - EXIT - ENDIF - ENDDO -! -!----------------------------------------------------------------------- -!*** All nest tasks have received data from the previous move -!*** so proceed with deleting those data objects. -!----------------------------------------------------------------------- -! - PTR_X=>TASK_UPDATE_SPECS !<-- Go back to the top of the list of updated nest tasks - KOUNT_TASKS=0 -! - DO WHILE(ASSOCIATED(PTR_X%TASK_ID)) !<-- An old link exists if TASK_ID is associated. - KOUNT_TASKS=KOUNT_TASKS+1 - DEALLOCATE(PTR_X%TASK_ID,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to deallocate TASK_UPDATE_SPECS%TASK_ID for nest task #',KOUNT_TASKS,' stat=',istat - ENDIF - DEALLOCATE(PTR_X%NUM_PTS_UPDATE_HZ,stat=ISTAT) - DEALLOCATE(PTR_X%IL,stat=ISTAT) - DEALLOCATE(PTR_X%JL,stat=ISTAT) -! - TAIL=>NULL() - IF(ASSOCIATED(PTR_X%NEXT_LINK))THEN !<-- If another links exists, point to it. - TAIL=>PTR_X%NEXT_LINK - ENDIF -! - IF(KOUNT_TASKS>1)THEN !<-- The top of TASK_UPDATE_SPECS is allocatable array element N - DEALLOCATE(PTR_X,stat=ISTAT) ! (for the Nth moving child) and is not a pointer. - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to deallocate TASK_UPDATE_SPECS for nest task #',KOUNT_TASKS,' stat=',istat - ENDIF - ENDIF -! -!--------------------------------------------------------------- -!*** Precisely the same nest tasks are updated for both -!*** H and V points therefore the deallocation of working -!*** pointers for nest tasks in the following block is -!*** removing all data for both types of points and not -!*** leaving some behind of one type or the other. -!--------------------------------------------------------------- -! - IF(ASSOCIATED(CHILD_UPDATE_DATA%TASKS(KOUNT_TASKS)%DATA_INTEGER))THEN - DEALLOCATE(CHILD_UPDATE_DATA%TASKS(KOUNT_TASKS)%DATA_INTEGER,stat=ISTAT) - IF(ISTAT/=0)then - WRITE(0,*)' Failed to deallocate CHILD_UPDATE_DATA%TASKS(KOUNT_TASKS)%DATA_INTEGER' & - ,' for KOUNT_TASKS=',kount_tasks,' stat=',istat - ENDIF - ENDIF -! - IF(ASSOCIATED(CHILD_UPDATE_DATA%TASKS(KOUNT_TASKS)%DATA_REAL))THEN - DEALLOCATE(CHILD_UPDATE_DATA%TASKS(KOUNT_TASKS)%DATA_REAL,stat=ISTAT) - IF(ISTAT/=0)then - WRITE(0,*)' Failed to deallocate CHILD_UPDATE_DATA%TASKS(KOUNT_TASKS)%DATA_REAL' & - ,' for KOUNT_TASKS=',kount_tasks,' stat=',istat - ENDIF - ENDIF -! - IF(ASSOCIATED(TAIL))THEN - PTR_X=>TAIL !<-- There is still another old link - ELSE - EXIT !<-- The last link in this list has been deallocated - ENDIF -! - ENDDO -! - IF(ASSOCIATED(CHILD_UPDATE_DATA%TASKS))THEN - DEALLOCATE(CHILD_UPDATE_DATA%TASKS) - ENDIF -! -!----------------------------------------------------------------------- -!*** How far did the nest move on the parent grid? -!----------------------------------------------------------------------- -! - I_SHIFT=I_PARENT_SW_NEW-I_PARENT_SW_OLD - J_SHIFT=J_PARENT_SW_NEW-J_PARENT_SW_OLD -! -!----------------------------------------------------------------------- -!*** What are this parent task's integration limits -!*** in terms of the moving nest's grid indices? -!*** To figure that out begin with the values of the -!*** index limits of the entire moving nest domain. -!----------------------------------------------------------------------- -! - IDS_CHILD=CHILD_TASK_LIMITS(1,1) !<-- Index limits of the moving nest on - IDE_CHILD=CHILD_TASK_LIMITS(2,NUM_CHILD_TASKS) ! its own grid. - JDS_CHILD=CHILD_TASK_LIMITS(3,1) ! - JDE_CHILD=CHILD_TASK_LIMITS(4,NUM_CHILD_TASKS) !<-- -! -!----------------------------------------------------------------------- -!*** In the following diagram 'H' represents mass points on the -!*** parent grid while 'h' represents mass points on the nest grid. -!*** Gridpoint values on the top are with respect to the nest. -!*** Gridpoint values on the bottom are with respect to the parent. -!*** The Parent-Child space ratio is 3. The given parent task must -!*** cover the gap between its ITE and the next parent task's ITS. -!*** 'Hh' indicates that parent and nest points coincide. -!----------------------------------------------------------------------- -! -! -! ITS_PARENT_ON_CHILD=-5 I=1 ITE_PARENT_ON_CHILD=9 -! | | | -! | | | -! Hh h h Hh h h Hh h h Hh h h Hh h h Hh -! | | | -! | | |<--gap--> -! ITS_PARENT=1 I_PARENT_SW=3 ITE_PARENT=5 -! -! -!----------------------------------------------------------------------- -! - ITS_PARENT_ON_CHILD=IDS_CHILD-(I_PARENT_SW_NEW-ITS) & !<-- ITS of parent task in child's coordinate space - *PARENT_CHILD_SPACE_RATIO ! for H points -! - ITE_PARENT_ON_CHILD=IDS_CHILD-(I_PARENT_SW_NEW-ITE) & !<-- ITE of parent task in child's coordinate space - *PARENT_CHILD_SPACE_RATIO & ! for H points - +PARENT_CHILD_SPACE_RATIO-1 !<-- Filling in gap beyond last parent point on nest grid -! - JTS_PARENT_ON_CHILD=JDS_CHILD-(J_PARENT_SW_NEW-JTS) & !<-- JTS of parent task in child's coordinate space - *PARENT_CHILD_SPACE_RATIO ! for H points -! - JTE_PARENT_ON_CHILD=JDS_CHILD-(J_PARENT_SW_NEW-JTE) & !<-- JTE of parent task in child's coordinate space - *PARENT_CHILD_SPACE_RATIO & ! for H points - +PARENT_CHILD_SPACE_RATIO-1 !<-- Filling in gap beyond last parent point on nest grid -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** The situation for V points is necessarily more complex. -!*** In the following diagram 'H' represents mass points on the -!*** parent grid and 'h' represents mass points on the nest grid -!*** while 'V' and 'v' represent the velocity points on the respective -!*** grids. Gridpoint values on the top are with respect to the -!*** nest's v points. The Parent-Child space ratio is 3. -!*** 'Hh' and 'Vv' indicate that parent and nest points coincide. -!*** Note the correspondence of the V diagram below with the H diagram -!*** above. The nest's v points for which a parent task is responsible -!*** have exactly the same indices as the nest h points for which that -!*** parent task is responsible. Although doing this means that -!*** ITS_PARENT_ON_CHILD is not at the same location as ITS_PARENT, -!*** it is required for exactly the same nest tasks to be updated by -!*** a parent task for both the h and v points. Likewise for -!*** ITE_PARENT_ON_CHILD, etc. -!*** The reason the relationships on velocity points are much more -!*** complicated than on mass points is that the SW corner point -!*** which serves as the anchor of the nest is always an H/h point. -!----------------------------------------------------------------------- -! -! -! ITS_PARENT_ON_CHILD_R=-5. I=1 ITE_PARENT_ON_CHILD_R=9. -! | | | -! | | | -! Hh | h h Hh h h Hh | h h Hh h h Hh h h | Hh -! | | v v v |<-gap->| | -! | | | -! | v Vv v v Vv v v Vv v v Vv v v Vv v v Vv -! | | | | -! | | v | v | -! Hh h | h Hh h h Hh h | h Hh h h Hh h | h Hh -! | | | | | | -! | | | | | | -! | ITS_PARENT=1 | I_PARENT_SW=3 | ITE_PARENT=5 -! | on V | on V | on V -! | | | -! | | | -! ITS_PARENT=1 I_PARENT_SW=3 ITE_PARENT=5 -! on H on H on H -! -! -!----------------------------------------------------------------------- -!*** However the logic has been constructed such that the index limits -!*** on each moving nest task subdomain for which each parent task -!*** must provide update data are identical for H and V points so we -!*** need only use the simpler perspective of H points to find those -!*** limits. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Boundary of the nest's pre-move footprint in terms of the -!*** nest's new position. -!----------------------------------------------------------------------- -! - IDS_FOOTPRINT=IDS_CHILD-I_SHIFT*PARENT_CHILD_SPACE_RATIO - IDE_FOOTPRINT=IDE_CHILD-I_SHIFT*PARENT_CHILD_SPACE_RATIO - JDS_FOOTPRINT=JDS_CHILD-J_SHIFT*PARENT_CHILD_SPACE_RATIO - JDE_FOOTPRINT=JDE_CHILD-J_SHIFT*PARENT_CHILD_SPACE_RATIO -! -!----------------------------------------------------------------------- -!*** Loop through the nest's task subdomains. -!----------------------------------------------------------------------- -! - child_tasks: DO N=1,NUM_CHILD_TASKS -! -!----------------------------------------------------------------------- -!*** What are child task N's memory limits? We use those limits -!*** since the parent task updates both integration and halo points -!*** on the child's subdomains in order to avoid all of the -!*** communication involved in doing halo exchanges following the -!*** updates. The parent uses only its integration points (no halo -!*** points) to do the updating. -!----------------------------------------------------------------------- -! - IMS_CHILD=MAX(CHILD_TASK_LIMITS(1,N)-NHALO,IDS_CHILD) - IME_CHILD=MIN(CHILD_TASK_LIMITS(2,N)+NHALO,IDE_CHILD) - JMS_CHILD=MAX(CHILD_TASK_LIMITS(3,N)-NHALO,JDS_CHILD) - JME_CHILD=MIN(CHILD_TASK_LIMITS(4,N)+NHALO,JDE_CHILD) -! -!----------------------------------------------------------------------- -!*** Do any of child task N's H points lie within this parent task's -!*** subdomain for the new nest position? -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! - limits: IF((IMS_CHILD>=ITS_PARENT_ON_CHILD & - .AND. & - IMS_CHILD<=ITE_PARENT_ON_CHILD & - .OR. & - IME_CHILD>=ITS_PARENT_ON_CHILD & - .AND. & - IME_CHILD<=ITE_PARENT_ON_CHILD) & - .AND. & - (JMS_CHILD>=JTS_PARENT_ON_CHILD & - .AND. & - JMS_CHILD<=JTE_PARENT_ON_CHILD & - .OR. & - JME_CHILD>=JTS_PARENT_ON_CHILD & - .AND. & - JME_CHILD<=JTE_PARENT_ON_CHILD))THEN !<-- If so, some of child task N's points are within -! ! this parent task's region of responsibility for - ! updating post-move nest points. -!----------------------------------------------------------------------- -!*** The intersection of child task N's subdomain with this parent -!*** task's region. -!----------------------------------------------------------------------- -! - I1=MAX(IMS_CHILD,ITS_PARENT_ON_CHILD) !<-- I limits of child task N's subdomain that lies - I2=MIN(IME_CHILD,ITE_PARENT_ON_CHILD) ! within this parent task's subdomain. -! - J1=MAX(JMS_CHILD,JTS_PARENT_ON_CHILD) !<-- J limits of child task N's subdomain that lies - J2=MIN(JME_CHILD,JTE_PARENT_ON_CHILD) ! within this parent task's subdomain. -! -!----------------------------------------------------------------------- -!*** The parent task will update only those nest H points that lie -!*** outside of the footprint of the nest domain's pre-move position. -!*** If all the nest points in child task N's subdomain lie within -!*** the footprint then the parent task has nothing to do so move on -!*** to the next child task. -! -!*** NOTE: The north and east limits of the nest domain's pre-move -!*** footprint cannot be used as a source for post-move updates -!*** in the intra-task and inter-task shifts of data. That is -!*** because the V-pt variables there are not part of the nest -!*** integration therefore their values are not valid. So we -!*** also must not use the H-pt variables at those same limits -!*** or else occasions would arise when nest tasks receiving -!*** H-pt updates would not be exactly the same as the nest -!*** tasks receiving V-pt updates. That situation is avoided -!*** or else the bookkeeping would be even more complicated. -!*** The parent will update H-pt and V-pt variables along the -!*** nest domain's pre-move footprint's north and east limits. -!*** But the intra- and inter-task shifts also cannot do the -!*** updating of the nest domain's southern and western boundary -!*** because many of the nest variables do not have valid -!*** integration values there so the parent must also update -!*** those nest boundaries following a shift. Moreover the -!*** dynamical tendencies for T, U, and V are not computed in -!*** the next to the outermost row of the domain which means the -!*** parent will have to update all nest points that move to -!*** IDE and IDE-1 and JDE and JDE-1 on the pre-move footprint. -!*** Use variables for the depth to which the parent will -!*** provide update data to nest points within the footprint -!*** in case that depth needs to change in the future. -!----------------------------------------------------------------------- -! - IF(I1>=IDS_FOOTPRINT+NROWS_P_UPD_W & - .AND. & - I2<=IDE_FOOTPRINT-NROWS_P_UPD_E & - .AND. & - J1>=JDS_FOOTPRINT+NROWS_P_UPD_S & - .AND. & - J2<=JDE_FOOTPRINT-NROWS_P_UPD_N )THEN !<-- If so, these nest points lie entirely within the footprint. -! - CYCLE child_tasks !<-- So this child task receives no updating from this -! ! parent task. - ENDIF -! -!----------------------------------------------------------------------- -!*** Now we know this parent task is updating at least some H points -!*** within child task N's subdomain so allocate a link in the -!*** linked list that holds update information about task N. -!*** We use a linked list because we do not know a priori how many -!*** child tasks need updates from each parent task and that number -!*** will change with each shift of the nest. -!----------------------------------------------------------------------- -! - N_UPDATE_CHILD_TASKS=N_UPDATE_CHILD_TASKS+1 -! - CALL PARENT_FINDS_UPDATE_LIMITS -! -!----------------------------------------------------------------------- -! - ENDIF limits -! -!----------------------------------------------------------------------- -!*** The parent task now knows which H points on child task N's -!*** subdomain that it must update following the nest's move. -!*** Those same index limits will apply to V point updates even -!*** though the physical locations differ. -!----------------------------------------------------------------------- -! - ENDDO child_tasks -! -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -! - SUBROUTINE PARENT_FINDS_UPDATE_LIMITS -! -!----------------------------------------------------------------------- -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: ISTAT,NLOC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Add a link to this parent task's linked list of moving nest -!*** specifications. Each new link is associated with another -!*** nest task that needs updating by this parent task on the -!*** current moving nest. -!----------------------------------------------------------------------- -! - IF(N_UPDATE_CHILD_TASKS==1)THEN - TAIL=>TASK_UPDATE_SPECS !<-- For the 1st link, point at the top of the list. - NULLIFY(TAIL%NEXT_LINK) - ELSE - ALLOCATE(TAIL%NEXT_LINK,stat=ISTAT) !<-- Add a new link for each additional child task - TAIL=>TAIL%NEXT_LINK !<-- Point at the new link so it is ready to use - NULLIFY(TAIL%NEXT_LINK) - ENDIF -! - ALLOCATE(TAIL%TASK_ID) !<-- Allocate the pieces of data in this link - ALLOCATE(TAIL%NUM_PTS_UPDATE_HZ) ! - ALLOCATE(TAIL%IL(1:4)) ! - ALLOCATE(TAIL%JL(1:4)) !<-- -! - TAIL%TASK_ID=N !<-- Task is Nth among all tasks on this child -! - DO NLOC=1,4 - TAIL%IL(NLOC)=-999 - TAIL%JL(NLOC)=-999 - ENDDO -! -!----------------------------------------------------------------------- -!*** The simplest case occurs when all of child task N's subdomain -!*** that intersects this parent task's subdomain lies outside of -!*** the pre-move footprint. The parent task then just updates -!*** all those nest points. -!----------------------------------------------------------------------- -! - parent_updates: IF(I2<=IDS_FOOTPRINT+NROWS_P_UPD_W-1 & - .OR. & - I1>=IDE_FOOTPRINT-NROWS_P_UPD_E+1 & - .OR. & - J2<=JDS_FOOTPRINT+NROWS_P_UPD_S-1 & - .OR. & - J1>=JDE_FOOTPRINT-NROWS_P_UPD_N+1 )THEN -! -!----------------------------------------------------------------------- -! - TAIL%IL(1)=I1 !<-- I limits of nest task N's update region by parent task - TAIL%IL(2)=I2 ! in terms of the nest's grid. -! - TAIL%JL(1)=J1 !<-- J limits of nest task N's update region by parent task - TAIL%JL(2)=J2 ! in terms of the nest's grid. -! -!----------------------------------------------------------------------- -!*** What remains are intersections between child task N's subdomain -!*** and this parent task's subdomain that lie along the edge of the -!*** pre-move footprint. Usually these regions will be a rectangle. -!*** However if both child task N and this parent task cover a corner -!*** of the footprint then the update region of the child task's -!*** subdomain is not a simple rectangle; essentially it is two -!*** rectangles. -!*** See diagrams in subroutine RECV_INTERIOR_DATA_FROM_PARENT -!*** in this module. -!----------------------------------------------------------------------- -! - ELSE parent_updates -! - IF(I1>=IDS_FOOTPRINT+NROWS_P_UPD_W & - .AND. & - I2<=IDE_FOOTPRINT-NROWS_P_UPD_E )THEN !<-- Rectangular update region on S/N edge of footprint. -! - TAIL%IL(1)=I1 - TAIL%IL(2)=I2 -! - IF(J1<=JDS_FOOTPRINT+NROWS_P_UPD_S-1)THEN !<-- Rectangular update region on south edge of footprint. - TAIL%JL(1)=J1 - TAIL%JL(2)=JDS_FOOTPRINT+NROWS_P_UPD_S-1 -! - ELSEIF(J2>=JDE_FOOTPRINT-NROWS_P_UPD_N+1)THEN !<-- Rectangular update region on north edge of footprint. - TAIL%JL(1)=JDE_FOOTPRINT-NROWS_P_UPD_N+1 - TAIL%JL(2)=J2 - ENDIF -! - ELSEIF(J1>=JDS_FOOTPRINT+NROWS_P_UPD_S & - .AND. & - J2<=JDE_FOOTPRINT-NROWS_P_UPD_N )THEN !<-- Rectangular update region on W/E edge of footprint. -! - TAIL%JL(1)=J1 - TAIL%JL(2)=J2 -! - IF(I1<=IDS_FOOTPRINT+NROWS_P_UPD_W-1)THEN !<-- Rectangular update region on west edge of footprint. - TAIL%IL(1)=I1 - TAIL%IL(2)=IDS_FOOTPRINT+NROWS_P_UPD_W-1 -! - ELSEIF(I2>=IDE_FOOTPRINT-NROWS_P_UPD_N+1)THEN !<-- Rectangular update region on east edge of footprint. - TAIL%IL(1)=IDE_FOOTPRINT-NROWS_P_UPD_N+1 - TAIL%IL(2)=I2 - ENDIF -! - ELSEIF(I1<=IDS_FOOTPRINT+NROWS_P_UPD_W-1 & - .AND. & - I2>=IDS_FOOTPRINT+NROWS_P_UPD_W )THEN !<-- Child task update region on SW/NW corner of footprint. -! - IF(J1<=JDS_FOOTPRINT+NROWS_P_UPD_S-1)THEN !<-- Child task update region on SW corner of footprint. - TAIL%IL(1)=I1 - TAIL%IL(2)=I2 - TAIL%IL(3)=I1 - TAIL%IL(4)=IDS_FOOTPRINT+NROWS_P_UPD_W-1 - TAIL%JL(1)=J1 - TAIL%JL(2)=JDS_FOOTPRINT+NROWS_P_UPD_S-1 - TAIL%JL(3)=TAIL%JL(2)+1 - TAIL%JL(4)=J2 -! - ELSEIF(J2>=JDE_FOOTPRINT-NROWS_P_UPD_N-1)THEN !<-- Child task update region on NW corner of footprint. - TAIL%IL(1)=I1 - TAIL%IL(2)=IDS_FOOTPRINT+NROWS_P_UPD_W-1 - TAIL%IL(3)=I1 - TAIL%IL(4)=I2 - TAIL%JL(1)=J1 - TAIL%JL(2)=JDE_FOOTPRINT-NROWS_P_UPD_N - TAIL%JL(3)=TAIL%JL(2)+1 - TAIL%JL(4)=J2 - ENDIF -! - ELSEIF(I1<=IDE_FOOTPRINT-NROWS_P_UPD_E & - .AND. & - I2>=IDE_FOOTPRINT-NROWS_P_UPD_E+1 )THEN !<-- Child task update region on SE/NE corner of footprint -! - IF(J1<=JDS_FOOTPRINT+NROWS_P_UPD_S-1)THEN !<-- Child task update region on SE corner of footprint. - TAIL%IL(1)=I1 - TAIL%IL(2)=I2 - TAIL%IL(3)=IDE_FOOTPRINT-NROWS_P_UPD_E+1 - TAIL%IL(4)=I2 - TAIL%JL(1)=J1 - TAIL%JL(2)=JDS_FOOTPRINT+NROWS_P_UPD_S-1 - TAIL%JL(3)=TAIL%JL(2)+1 - TAIL%JL(4)=J2 -! - ELSEIF(J2>=JDE_FOOTPRINT-NROWS_P_UPD_N+1)THEN !<-- Child task update region on NE corner of footprint. - TAIL%IL(1)=IDE_FOOTPRINT-NROWS_P_UPD_E+1 - TAIL%IL(2)=I2 - TAIL%IL(3)=I1 - TAIL%IL(4)=I2 - TAIL%JL(1)=J1 - TAIL%JL(2)=JDE_FOOTPRINT-NROWS_P_UPD_N - TAIL%JL(3)=TAIL%JL(2)+1 - TAIL%JL(4)=J2 - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF parent_updates -! -!----------------------------------------------------------------------- -! - TAIL%NUM_PTS_UPDATE_HZ=(TAIL%IL(2)-TAIL%IL(1)+1) & - *(TAIL%JL(2)-TAIL%JL(1)+1) -! - IF(TAIL%IL(3)>0)THEN - TAIL%NUM_PTS_UPDATE_HZ=(TAIL%IL(4)-TAIL%IL(3)+1) & - *(TAIL%JL(4)-TAIL%JL(3)+1) & - +TAIL%NUM_PTS_UPDATE_HZ - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PARENT_FINDS_UPDATE_LIMITS -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PARENT_BOOKKEEPING_MOVING -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE PARENT_UPDATES_MOVING(FLAG_H_OR_V & - ,N_UPDATE_CHILD_TASKS & - ,PARENT_CHILD_SPACE_RATIO & - ,PARENT_CHILD_TIME_RATIO & - ,NTIMESTEP_CHILD & - ,I_PARENT_SW & - ,J_PARENT_SW & - ,PT,PDTOP,PSGML1,SGML2,SG1,SG2 & - ,DSG2,PDSG1 & - ,FIS,PD & - ,T,Q,CW & - ,NUM_PARENT_TASKS & - ,NUM_CHILD_TASKS & - ,CHILD_TASK_RANKS & - ,CHILD_TASK_LIMITS & - ,HYPER_A & - ,IMS,IME,JMS,JME & - ,IDS,IDE,JDS,JDE & - ,NUM_LYRS & - ,LBND1,UBND1,LBND2,UBND2 & - ,FIS_CHILD & - ,COMM_TO_MY_CHILD & - ,HANDLE_UPDATE & - ,MOVE_BUNDLE & - ,NUM_FIELDS_MOVE_2D_H_I & - ,NUM_FIELDS_MOVE_2D_X_I & - ,NUM_FIELDS_MOVE_2D_H_R & - ,NUM_FIELDS_MOVE_2D_X_R & - ,NUM_FIELDS_MOVE_3D_H & - ,NUM_LEVELS_MOVE_3D_H & - ,NUM_FIELDS_MOVE_2D_V & - ,NUM_FIELDS_MOVE_3D_V & - ,NUM_LEVELS_MOVE_3D_V & - ,TASK_UPDATE_SPECS & - ,CHILD_UPDATE_DATA & - ) -! -!----------------------------------------------------------------------- -!*** Each parent task knows which moving nest tasks if any that it -!*** must update and which points on those tasks. Now the bilinear -!*** interpolation weights can be computed and then all specified -!*** 2-D and 3-D variables are interpolated from the parent grid -!*** to the nest's. Finally the parent tasks send the data to the -!*** appropriate nest tasks. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: COMM_TO_MY_CHILD & !<-- MPI communicator to the current nest/child - ,I_PARENT_SW,J_PARENT_SW & !<-- SW corner of nest on this parent I,J after move - ,IDS,IDE,JDS,JDE & !<-- Parent domain index limits - ,IMS,IME,JMS,JME & !<-- Parent task memory index limits - ,N_UPDATE_CHILD_TASKS & !<-- # of moving nest tasks updated by this parent task - ,NTIMESTEP_CHILD & !<-- Child's timestep at which it recvs parent data - ,NUM_LYRS & !<-- # of model layers - ,NUM_CHILD_TASKS & !<-- # of forecast tasks on all of this parent's children - ,NUM_FIELDS_MOVE_2D_H_I & !<-- # of 2-D integer H arrays specified for updating - ,NUM_FIELDS_MOVE_2D_X_I & !<-- # of 2-D integer H arrays updated from external files - ,NUM_FIELDS_MOVE_2D_H_R & !<-- # of 2-D real H arrays specified for updating - ,NUM_FIELDS_MOVE_2D_X_R & !<-- # of 2-D real H arrays updated from external files - ,NUM_FIELDS_MOVE_3D_H & !<-- # of 3-D H arrays specified for updating - ,NUM_LEVELS_MOVE_3D_H & !<-- # of 2-D levels in all 3-D H update arrays - ,NUM_FIELDS_MOVE_2D_V & !<-- # of 2-D V arrays specified for updating - ,NUM_FIELDS_MOVE_3D_V & !<-- # of 3-D V arrays specified for updating - ,NUM_LEVELS_MOVE_3D_V & !<-- # of 2-D levels in all 3-D V update arrays - ,NUM_PARENT_TASKS & !<-- # of forecast tasks on this parent - ,PARENT_CHILD_SPACE_RATIO & !<-- Ratio of parent's grid increment to its child's - ,PARENT_CHILD_TIME_RATIO & !<-- Ratio of parent's time step to its child's - ,LBND1,UBND1,LBND2,UBND2 !<-- Array bounds of nest-resolution FIS on parent -! - INTEGER(kind=KINT),DIMENSION(:),POINTER,INTENT(IN) :: & - HANDLE_UPDATE !<-- MPI Handles for ISends to the child tasks -! - INTEGER(kind=KINT),DIMENSION(1:NUM_CHILD_TASKS),INTENT(IN) :: & - CHILD_TASK_RANKS !<-- Child task local ranks in p-c intracomm -! - INTEGER(kind=KINT),DIMENSION(1:4,NUM_CHILD_TASKS),INTENT(IN) :: & - CHILD_TASK_LIMITS !<-- ITS,ITE,JTS,JTE for each child forecast task -! - REAL(kind=KFPT),INTENT(IN) :: PDTOP & !<-- Pressure at top of sigma domain (Pa) - ,PT !<-- Top pressure of model domain (Pa) -! - REAL(kind=KDBL),INTENT(IN) :: HYPER_A !<-- Underground extrapolation quantity -! - REAL(kind=KFPT),DIMENSION(1:NUM_LYRS),INTENT(IN) :: DSG2 & !<-- Vertical structure coefficients for midlayers - ,PDSG1 & ! - ,PSGML1 & ! - ,SGML2 !<-- -! - REAL(kind=KFPT),DIMENSION(1:NUM_LYRS+1),INTENT(IN) :: SG1,SG2 !<-- Vertical structure coefficients for interfaces -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: FIS & !<-- Sfc geopotential on parent mass points - ,PD !<-- Parent PD -! - REAL(kind=KFPT),DIMENSION(LBND1:UBND1,LBND2:UBND2),INTENT(IN) :: & - FIS_CHILD !<-- Moving nest's full res FIS distributed on the parent -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME,1:NUM_LYRS) & - ,INTENT(IN) :: T & !<-- Parent sensible temperature (K) - ,Q & !<-- Parent specific humidity (kg/kg) - ,CW !<-- Parent cloud condensate (kg/kg) -! - CHARACTER(len=1),INTENT(IN) :: FLAG_H_OR_V !<-- Are we updating H or V points? -! - TYPE(MIXED_DATA_TASKS),INTENT(INOUT) :: CHILD_UPDATE_DATA !<-- Composite of all update data from parent for each nest task -! - TYPE(CHILD_UPDATE_LINK),TARGET,INTENT(INOUT) :: & - TASK_UPDATE_SPECS !<-- Linked list with nest task update specifications -! - TYPE(ESMF_FieldBundle),INTENT(INOUT) :: MOVE_BUNDLE !<-- ESMF Bundle of 2-D and 3-D arrays specified for updating -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT),SAVE :: I,I1,I2 & - ,I_EAST,I_OFFSET,I_WEST & - ,IDS_CHILD,ISTART,ITAG,ITER & - ,J,J1,J2 & - ,J_NORTH,J_OFFSET,J_SOUTH & - ,JDS_CHILD,JSTART & - ,KHI,KLO & - ,L,LOC_1,LOC_2 & - ,N,N_ADD,N_FIELD,N_REMOVE,N_STRIDE & - ,NPOINTS_HORIZ & - ,NPOINTS_HORIZ_H & - ,NPOINTS_HORIZ_V & - ,NUM_DIMS & - ,NUM_FIELDS_MOVE & - ,NUM_LEVS_IN & - ,NUM_LEVS_SEC & - ,NUM_LEVELS & - ,NUM_INTEGER_WORDS_SEND & - ,NUM_REAL_WORDS_SEND & - ,UPDATE_TYPE_INT -! - INTEGER(kind=KINT) :: CHILDTASK,I_TRANS,IERR,ISTAT,IVAL,J_TRANS & - ,KNT_DUMMY,RC,RC_UPDATE -! - INTEGER(kind=KINT),DIMENSION(1:3) :: LIMITS_HI & - ,LIMITS_LO -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE,TARGET :: & - I_PARENT_EAST & - ,I_PARENT_WEST & - ,J_PARENT_NORTH & - ,J_PARENT_SOUTH -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: I_PARENT_EAST_H & - ,I_PARENT_WEST_H & - ,J_PARENT_NORTH_H & - ,J_PARENT_SOUTH_H -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE,SAVE :: & - KNT_INTEGER_PTS & - ,KNT_REAL_PTS & - ,NUM_ITER -! - INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: IARRAY_2D -! - REAL(kind=KFPT) :: CHILD_PARENT_SPACE_RATIO & - ,COEFF_1,COEFF_2,CW_INTERP & - ,D_LNP_DFI,DELP_EXTRAP,DP,FACTOR & - ,IDIFF_EAST,IDIFF_WEST & - ,JDIFF_NORTH,JDIFF_SOUTH & - ,LOG_P1_PARENT & - ,MAX_WGHT & - ,PDTOP_PT,PHI_DIFF & - ,PSFC_CHILD & - ,PSFC_PARENT_NE,PSFC_PARENT_NW & - ,PSFC_PARENT_SE,PSFC_PARENT_SW & - ,PX_NE,PX_NW,PX_SE,PX_SW & - ,Q_INTERP,R_DELP,R_INC & - ,RECIP_SUM_WGT,SUM_PROD,SUM_WGT & - ,T_INTERP,TMP & - ,X_NE,X_NW,X_SE,X_SW -! - REAL(kind=KFPT),DIMENSION(:),ALLOCATABLE :: P_OUTPUT -! - REAL(kind=KFPT),DIMENSION(1:NUM_LYRS+2) :: P_INPUT & - ,VBL_INPUT -! - REAL(kind=KFPT),DIMENSION(:),ALLOCATABLE :: I_PARENT & - ,J_PARENT & - ,SEC_DERIV -! - REAL(kind=KFPT),DIMENSION(:),POINTER :: I_CHILD_ON_PARENT_H & - ,J_CHILD_ON_PARENT_H -! - REAL(kind=KFPT),DIMENSION(:),POINTER :: VBL_COL_CHILD & - ,VBL_COL_X -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME) :: LMASK -! - REAL(kind=KFPT),DIMENSION(1:NUM_LYRS+2,1:4) :: C_TMP !<-- Working array for ESSL spline call -! - REAL(kind=KFPT),DIMENSION(:,:),ALLOCATABLE :: LOG_PBOT & - ,LOG_PTOP & - ,PD_CHILD & - ,PD_INTERP & - ,PROD_LWGT_NE & - ,PROD_LWGT_NW & - ,PROD_LWGT_SE & - ,PROD_LWGT_SW & - ,PROD_SWGT_NE & - ,PROD_SWGT_NW & - ,PROD_SWGT_SE & - ,PROD_SWGT_SW -! - REAL(kind=KFPT),DIMENSION(:,:),ALLOCATABLE,TARGET :: WGHT_NE & - ,WGHT_NW & - ,WGHT_SE & - ,WGHT_SW -! - REAL(kind=KFPT),DIMENSION(:,:),POINTER,SAVE :: PDO & - ,SMASK -! - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ARRAY_2D & - ,WGHT_NE_H & - ,WGHT_NW_H & - ,WGHT_SE_H & - ,WGHT_SW_H -! - REAL(kind=KFPT),DIMENSION(:,:,:),ALLOCATABLE,TARGET :: PINT_CHILD & - ,PINT_INTERP & - ,PMID_CHILD & - ,PMID_INTERP -! - REAL(kind=KFPT),DIMENSION(:,:,:),ALLOCATABLE :: PHI_INTERP & - ,VBL_INTERP -! - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: ARRAY_3D & - ,P3D_INPUT & - ,P3D_OUTPUT -! - LOGICAL(kind=KLOG) :: INTERFACES & - ,MIDLAYERS -! - CHARACTER(len=1) :: UPDATE_TYPE_CHAR -! - CHARACTER(len=4) :: FNAME -! - CHARACTER(len=30) :: FIELD_NAME -! - TYPE(CHILD_UPDATE_LINK),POINTER,SAVE :: PTR_H,PTR_V -! - TYPE(CHILD_UPDATE_LINK),POINTER :: PTR_X -! - TYPE(ESMF_Field) :: HOLD_FIELD -! - TYPE(ESMF_TypeKind_Flag) :: DATATYPE -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - btim=timef() -! - RC =ESMF_SUCCESS - RC_UPDATE=ESMF_SUCCESS -! - CHILD_PARENT_SPACE_RATIO=1./PARENT_CHILD_SPACE_RATIO -! -!----------------------------------------------------------------------- -!*** This update routine is called first for H points and then -!*** a second time for V points. To save time on communication -!*** all H and V point data will be sent together at the end of -!*** the 2nd (V-point) call. First do some prep work that only -!*** needs to be done once for both H and V at this move. -!----------------------------------------------------------------------- -! - prep_block: IF(FLAG_H_OR_V=='H')THEN -! -!----------------------------------------------------------------------- -! - ALLOCATE(KNT_REAL_PTS(1:N_UPDATE_CHILD_TASKS) & - ,stat=ISTAT) - ALLOCATE(KNT_INTEGER_PTS(1:N_UPDATE_CHILD_TASKS) & - ,stat=ISTAT) - ALLOCATE(CHILD_UPDATE_DATA%TASKS(1:N_UPDATE_CHILD_TASKS) & - ,stat=ISTAT) - ALLOCATE(NUM_ITER(1:N_UPDATE_CHILD_TASKS) & - ,stat=ISTAT) -! - LM=NUM_LYRS -! -!----------------------------------------------------------------------- -!*** Start at the top of the linked lists that hold the task ID -!*** and index limits for all update H and V points on each nest -!*** task for the current nest. Remember that each link in the -!*** lists corresponds to a nest task that this parent task must -!*** update. -!----------------------------------------------------------------------- -! - PTR_H=>TASK_UPDATE_SPECS - PTR_V=>TASK_UPDATE_SPECS -! -!----------------------------------------------------------------------- -!*** Find the total number of words to be updated on each nest task -!*** for both H and V points. -!----------------------------------------------------------------------- -! - prep_loop: DO N=1,N_UPDATE_CHILD_TASKS -! -!----------------------------------------------------------------------- -! - IF(N>1)THEN !<-- Point to the next link (the next task to be updated). - PTR_H=>PTR_H%NEXT_LINK - PTR_V=>PTR_V%NEXT_LINK - ENDIF -! - NPOINTS_HORIZ_H=(PTR_H%IL(2)-PTR_H%IL(1)+1) & - *(PTR_H%JL(2)-PTR_H%JL(1)+1) -! - NPOINTS_HORIZ_V=(PTR_V%IL(2)-PTR_V%IL(1)+1) & - *(PTR_V%JL(2)-PTR_V%JL(1)+1) -! - NUM_INTEGER_WORDS_SEND=(NUM_FIELDS_MOVE_2D_H_I & - -NUM_FIELDS_MOVE_2D_X_I) & - *NPOINTS_HORIZ_H -! - NUM_REAL_WORDS_SEND=(NUM_FIELDS_MOVE_2D_H_R & - -NUM_FIELDS_MOVE_2D_X_R & - +NUM_LEVELS_MOVE_3D_H) & - *NPOINTS_HORIZ_H & - +(NUM_FIELDS_MOVE_2D_V & - +NUM_LEVELS_MOVE_3D_V) & - *NPOINTS_HORIZ_V -! -!----------------------------------------------------------------------- -!*** If there is a 2nd region on nest task N updated by the current -!*** parent task then we need to iterate twice through the updating -!*** process. These 2nd regions exist only when the parent task -!*** and the nest task it is updating both lie on the corner of the -!*** nest's pre-move footprint. -!----------------------------------------------------------------------- -! - NUM_ITER(N)=1 -! - IF(PTR_H%IL(3)>0)THEN !<-- If true then there must be a 2nd update region. - IF(PTR_V%IL(3)<0)THEN - WRITE(0,*)' A 2nd update region exists for H points but not V!! ABORT!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - NUM_ITER(N)=2 - NPOINTS_HORIZ_H=(PTR_H%IL(4)-PTR_H%IL(3)+1) & - *(PTR_H%JL(4)-PTR_H%JL(3)+1) -! - NPOINTS_HORIZ_V=(PTR_V%IL(4)-PTR_V%IL(3)+1) & - *(PTR_V%JL(4)-PTR_V%JL(3)+1) -! - NUM_INTEGER_WORDS_SEND=(NUM_FIELDS_MOVE_2D_H_I & !<-- Total # of integer words in parent's update - -NUM_FIELDS_MOVE_2D_X_I) & ! of nest task N. - *NPOINTS_HORIZ_H & - +NUM_INTEGER_WORDS_SEND -! - NUM_REAL_WORDS_SEND=(NUM_FIELDS_MOVE_2D_H_R & !<-- Total # of real words in parent's update - -NUM_FIELDS_MOVE_2D_X_R & ! of nest task N. - +NUM_LEVELS_MOVE_3D_H) & - *NPOINTS_HORIZ_H & - +(NUM_FIELDS_MOVE_2D_V & - +NUM_LEVELS_MOVE_3D_V) & - *NPOINTS_HORIZ_V & - +NUM_REAL_WORDS_SEND - ENDIF -! -!----------------------------------------------------------------------- -!*** Now we know how many words will be sent from the current parent -!*** task to nest task N so allocate the objects that will hold this -!*** data. There may or may not be any integer variables updated at -!*** this time. -!----------------------------------------------------------------------- -! - ALLOCATE(CHILD_UPDATE_DATA%TASKS(N)%DATA_REAL(1:NUM_REAL_WORDS_SEND)) -! - IF(NUM_INTEGER_WORDS_SEND>0)THEN - ALLOCATE(CHILD_UPDATE_DATA%TASKS(N)%DATA_INTEGER(1:NUM_INTEGER_WORDS_SEND)) - ELSE - CHILD_UPDATE_DATA%TASKS(N)%DATA_INTEGER=>NULL() - ENDIF -! -!----------------------------------------------------------------------- -! - KNT_REAL_PTS(N)=0 !<-- Initialize the counter of real update data words. - KNT_INTEGER_PTS(N)=0 !<-- Initialize the counter of integer update data words. -! - ISTART=MAX(IMS,IDS) - JSTART=MAX(JMS,JDS) -! - I_OFFSET=(I_PARENT_SW-ISTART)*PARENT_CHILD_SPACE_RATIO & !<-- I offset of child SW corner in full topo array on parent - +LBND1-1 - J_OFFSET=(J_PARENT_SW-JSTART)*PARENT_CHILD_SPACE_RATIO & !<-- J offset of child SW corner in full topo array on parent - +LBND2-1 -! -!----------------------------------------------------------------------- -! - ENDDO prep_loop -! -!----------------------------------------------------------------------- -!*** We need PD and PDO on the parent for building the -!*** pressure structure from which to interpolate to the nest -!*** update points. PD was already sent into this routine via -!*** the argument list since it was needed earlier in the coupler. -!*** Unload PDO now. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract PDO Field From H Move_Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=MOVE_BUNDLE & !<-- Bundle holding the arrays for move updates - ,fieldName ='PDO'//SUFFIX_MOVE & !<-- Get the Field with this name - ,field =HOLD_FIELD & !<-- Put the Field here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_UPDATE) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract PDO Array from Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field holding PDO - ,localDe =0 & - ,farrayPtr=PDO & !<-- Put array here - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_UPDATE) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** We need the parent's Sea Mask for generating surface variable -!*** updates in order to exclude either sea or land point values -!*** in the bilinear interpolation. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract the Sea Mask from the H Move_Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=MOVE_BUNDLE & !<-- Bundle holding the arrays for move updates - ,fieldName ='SM'//SUFFIX_MOVE & !<-- The parent's sea mask - ,field =HOLD_FIELD & !<-- Put the Field here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_UPDATE) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Sea Mask Array from Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field holding PDO - ,localDe =0 & - ,farrayPtr=SMASK & !<-- Put the sea mask array here - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_UPDATE) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** 'Flip' the seamask values (1=>sea) for use as a landmask (0=>sea). -!----------------------------------------------------------------------- -! - DO J=JMS,JME - DO I=IMS,IME - IF(SMASK(I,J)>0.5)THEN - LMASK(I,J)=0. - ELSE - LMASK(I,J)=1. - ENDIF - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -! - ENDIF prep_block -! -!----------------------------------------------------------------------- -!*** As we prepare to interpolate from the parent to the child, -!*** we need to be aware of another distinction between the H -!*** and the V point locations on those domains' grids regarding -!*** I=1 on the nest relative to I_PARENT_SW. For H points -!*** I=1 on the nest coincides with I_PARENT_SW on the parent. -!*** However for V points I=1 is to the west of I_PARENT_SW. -!*** See the diagram at the beginning of the FLAG_H_OR_V==V -!*** section of PARENT_BOOKKEEPING_MOVING. Specifically -!*** v(1) on the nest is -!*** (0.5*PARENT_CHILD_SPACE_RATIO-0.5)/PARENT_CHILD_SPACE_RATIO -!*** to the west of V(I_PARENT_SW) on the parent grid. Compute -!*** that increment here then use it below when we need the -!*** Real values for parent I's and J's on the parent grid -!*** that coincide with the update locations on the nest grid. -!----------------------------------------------------------------------- -! - PTR_X=>TASK_UPDATE_SPECS -! - IF(FLAG_H_OR_V=='H')THEN - NUM_FIELDS_MOVE=NUM_FIELDS_MOVE_2D_H_I & - +NUM_FIELDS_MOVE_2D_H_R & - +NUM_FIELDS_MOVE_3D_H - R_INC=0. -! - ELSEIF(FLAG_H_OR_V=='V')THEN - NUM_FIELDS_MOVE=NUM_FIELDS_MOVE_2D_V & - +NUM_FIELDS_MOVE_3D_V - R_INC=-(0.5*PARENT_CHILD_SPACE_RATIO-0.5) & - *CHILD_PARENT_SPACE_RATIO - ENDIF -! -!----------------------------------------------------------------------- -! - DO L=1,NUM_LYRS+2 - P_INPUT(L)=0. - VBL_INPUT(L)=0. - ENDDO -! -!----------------------------------------------------------------------- -!*** Loop through each of the moving nest tasks whose subdomains -!*** contain points that must be updated by this parent task -!*** after the nest moved. -!----------------------------------------------------------------------- -! - ctask_loop: DO N=1,N_UPDATE_CHILD_TASKS -! -!----------------------------------------------------------------------- -! - iter_loop: DO ITER=1,NUM_ITER(N) !<-- Either one or two regions on the nest task must be updated. -! -!----------------------------------------------------------------------- -! - IF(ITER==1)THEN - I1=PTR_X%IL(1) !<-- I limits of nest task's update region by parent task - I2=PTR_X%IL(2) ! in terms of the nest's grid. - J1=PTR_X%JL(1) !<-- J limits of nest task's update region by parent task - J2=PTR_X%JL(2) ! in terms of the nest's grid. - ELSE - I1=PTR_X%IL(3) !<-- I limits of nest task's update region by parent task - I2=PTR_X%IL(4) ! in terms of the nest's grid for 2nd update region. - J1=PTR_X%JL(3) !<-- J limits of nest task's update region by parent task - J2=PTR_X%JL(4) ! in terms of the nest's grid for 2nd update region. - ENDIF -! - ALLOCATE(I_PARENT(I1:I2)) - ALLOCATE(I_PARENT_EAST(I1:I2)) - ALLOCATE(I_PARENT_WEST(I1:I2)) -! - ALLOCATE(J_PARENT(J1:J2)) - ALLOCATE(J_PARENT_NORTH(J1:J2)) - ALLOCATE(J_PARENT_SOUTH(J1:J2)) -! - ALLOCATE(WGHT_SW(I1:I2,J1:J2)) - ALLOCATE(WGHT_NW(I1:I2,J1:J2)) - ALLOCATE(WGHT_NE(I1:I2,J1:J2)) - ALLOCATE(WGHT_SE(I1:I2,J1:J2)) -! - ALLOCATE(PINT_INTERP(I1:I2,J1:J2,1:NUM_LYRS+1)) - ALLOCATE( PHI_INTERP(I1:I2,J1:J2,1:NUM_LYRS+1)) - ALLOCATE( PD_CHILD(I1:I2,J1:J2)) - ALLOCATE( PD_INTERP(I1:I2,J1:J2)) - ALLOCATE( LOG_PBOT(I1:I2,J1:J2)) - ALLOCATE( LOG_PTOP(I1:I2,J1:J2)) -! - NPOINTS_HORIZ=(I2-I1+1)*(J2-J1+1) - ALLOCATE(PMID_INTERP(I1:I2,J1:J2,1:NUM_LYRS)) - ALLOCATE( PMID_CHILD(I1:I2,J1:J2,1:NUM_LYRS)) - ALLOCATE( PINT_CHILD(I1:I2,J1:J2,1:NUM_LYRS+1)) -! - IDS_CHILD=CHILD_TASK_LIMITS(1,1) !<-- Child task's starting I on grid of moving nest - JDS_CHILD=CHILD_TASK_LIMITS(3,1) !<-- Child task's starting J on grid of moving nest -! - DO I=I1,I2 - I_PARENT(I)=I_PARENT_SW+R_INC & !<-- Real Parent I's on parent grid for these nest I's - +(I-IDS_CHILD)*CHILD_PARENT_SPACE_RATIO ! in the nest grid's Update region. - ENDDO -! - DO J=J1,J2 - J_PARENT(J)=J_PARENT_SW+R_INC & !<-- Real Parent J's on parent grid for these nest J's - +(J-JDS_CHILD)*CHILD_PARENT_SPACE_RATIO ! in the nest grid's update region. - ENDDO -! -!----------------------------------------------------------------------- -!*** Loop through this nest's update points and determine the four -!*** parent points that surround each nest point as well and the -!*** bilinear interpolation weight associated with each of those -!*** four parent points for the given nest point. -!----------------------------------------------------------------------- -! - DO J=J1,J2 - J_PARENT_SOUTH(J)=INT(J_PARENT(J)+EPS) !<-- Parent J at or immediately south of nest point - J_PARENT_NORTH(J)=J_PARENT_SOUTH(J)+1 !<-- Parent J immediately north of nest point -! - DO I=I1,I2 - I_PARENT_WEST(I)=INT(I_PARENT(I)+EPS) !<-- Parent I at or immediately west of nest point - I_PARENT_EAST(I)=I_PARENT_WEST(I)+1 !<-- Parent I immediately east of nest point -! - IDIFF_EAST=I_PARENT_EAST(I)-I_PARENT(I) - IDIFF_WEST=I_PARENT(I)-I_PARENT_WEST(I) - JDIFF_NORTH=J_PARENT_NORTH(J)-J_PARENT(J) - JDIFF_SOUTH=J_PARENT(J)-J_PARENT_SOUTH(J) -! - WGHT_SW(I,J)=IDIFF_EAST*JDIFF_NORTH !<-- Bilinear weight for parent's point SW of child's point - WGHT_NW(I,J)=IDIFF_EAST*JDIFF_SOUTH !<-- Bilinear weight for parent's point NW of child's point - WGHT_NE(I,J)=IDIFF_WEST*JDIFF_SOUTH !<-- Bilinear weight for parent's point NE of child's point - WGHT_SE(I,J)=IDIFF_WEST*JDIFF_NORTH !<-- Bilinear weight for parent's point SE of child's point -! - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** The parent computes its layer interface pressures at the -!*** locations of the moving nest update points. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** If we are updating mass point variables then those variables -!*** obviously coincide with the pressure information. In other -!*** words we are interpolating from parent H points to nest h points. -!----------------------------------------------------------------------- -! - h_v_block: IF(FLAG_H_OR_V=='H')THEN -! - I_PARENT_EAST_H=>I_PARENT_EAST - I_PARENT_WEST_H=>I_PARENT_WEST - J_PARENT_NORTH_H=>J_PARENT_NORTH - J_PARENT_SOUTH_H=>J_PARENT_SOUTH -! - WGHT_NE_H=>WGHT_NE - WGHT_NW_H=>WGHT_NW - WGHT_SE_H=>WGHT_SE - WGHT_SW_H=>WGHT_SW -! -!----------------------------------------------------------------------- -!*** If we are updating wind components then we need to know -!*** T, Q, and FIS at V points in order to compute sfc pressure -!*** and ultimately midlayer pressure at the V points. -!*** Base the bilinear interpolation to nest v points on the -!*** values at parent H points (where T, Q, and FIS are defined) -!*** in order to minimize horizontal interpolation. -!----------------------------------------------------------------------- -! - ELSEIF(FLAG_H_OR_V=='V')THEN -! - ALLOCATE(I_PARENT_EAST_H(I1:I2)) - ALLOCATE(I_PARENT_WEST_H(I1:I2)) - ALLOCATE(J_PARENT_NORTH_H(J1:J2)) - ALLOCATE(J_PARENT_SOUTH_H(J1:J2)) -! - ALLOCATE(I_CHILD_ON_PARENT_H(I1:I2)) - ALLOCATE(J_CHILD_ON_PARENT_H(J1:J2)) -! - ALLOCATE(WGHT_NE_H(I1:I2,J1:J2)) - ALLOCATE(WGHT_NW_H(I1:I2,J1:J2)) - ALLOCATE(WGHT_SE_H(I1:I2,J1:J2)) - ALLOCATE(WGHT_SW_H(I1:I2,J1:J2)) -! - DO I=I1,I2 -! - I_CHILD_ON_PARENT_H(I)=I_PARENT_SW & - +(I-IDS_CHILD+0.5) & - *CHILD_PARENT_SPACE_RATIO -! - I_PARENT_WEST_H(I)=INT(I_CHILD_ON_PARENT_H(I)) !<-- Parent I on H immediately west of nest V point - I_PARENT_EAST_H(I)=I_PARENT_WEST_H(I)+1 !<-- Parent I on H immediately east of nest V point -! - ENDDO -! - DO J=J1,J2 -! - J_CHILD_ON_PARENT_H(J)=J_PARENT_SW & - +(J-JDS_CHILD+0.5) & - *CHILD_PARENT_SPACE_RATIO -! - J_PARENT_SOUTH_H(J)=INT(J_CHILD_ON_PARENT_H(J)) !<-- Parent J on H immediately south of nest V point - J_PARENT_NORTH_H(J)=J_PARENT_SOUTH_H(J)+1 !<-- Parent J on H immediately north of nest V point -! - ENDDO -! - DO J=J1,J2 - DO I=I1,I2 - WGHT_SW_H(I,J)=(I_PARENT_EAST_H(I)-I_CHILD_ON_PARENT_H(I)) & - *(J_PARENT_NORTH_H(J)-J_CHILD_ON_PARENT_H(J)) - WGHT_SE_H(I,J)=(I_CHILD_ON_PARENT_H(I)-I_PARENT_WEST_H(I)) & - *(J_PARENT_NORTH_H(J)-J_CHILD_ON_PARENT_H(J)) - WGHT_NW_H(I,J)=(I_PARENT_EAST_H(I)-I_CHILD_ON_PARENT_H(I)) & - *(J_CHILD_ON_PARENT_H(J)-J_PARENT_SOUTH_H(J)) - WGHT_NE_H(I,J)=(I_CHILD_ON_PARENT_H(I)-I_PARENT_WEST_H(I)) & - *(J_CHILD_ON_PARENT_H(J)-J_PARENT_SOUTH_H(J)) - ENDDO - ENDDO -! - ENDIF h_v_block -! -!----------------------------------------------------------------------- -!*** When the parent generates Real soil variable updates for its -!*** moving nests it uses bilinear interpolation but also must use -!*** the sea/land mask in order to avoid including sea values in -!*** land variables and vice versa. This means the bilinear -!*** interpolation weighting needs to be adjusted to account for -!*** the exclusion of sea or land points in the 4-pt summation. -!----------------------------------------------------------------------- -! - soil_wgts: IF(FLAG_H_OR_V=='H')THEN -! - ALLOCATE(PROD_LWGT_SW(I1:I2,J1:J2)) - ALLOCATE(PROD_LWGT_SE(I1:I2,J1:J2)) - ALLOCATE(PROD_LWGT_NW(I1:I2,J1:J2)) - ALLOCATE(PROD_LWGT_NE(I1:I2,J1:J2)) - ALLOCATE(PROD_SWGT_SW(I1:I2,J1:J2)) - ALLOCATE(PROD_SWGT_SE(I1:I2,J1:J2)) - ALLOCATE(PROD_SWGT_NW(I1:I2,J1:J2)) - ALLOCATE(PROD_SWGT_NE(I1:I2,J1:J2)) -! - DO J=J1,J2 - J_SOUTH=J_PARENT_SOUTH(J) - J_NORTH=J_PARENT_NORTH(J) -! - DO I=I1,I2 - I_WEST=I_PARENT_WEST(I) - I_EAST=I_PARENT_EAST(I) -! - X_SW=WGHT_SW(I,J)*LMASK(I_WEST,J_SOUTH) - X_SE=WGHT_SE(I,J)*LMASK(I_EAST,J_SOUTH) - X_NW=WGHT_NW(I,J)*LMASK(I_WEST,J_NORTH) - X_NE=WGHT_NE(I,J)*LMASK(I_EAST,J_NORTH) -! - SUM_WGT=X_SW+X_SE+X_NW+X_NE -! - IF(ABS(SUM_WGT)>1.E-6)THEN - RECIP_SUM_WGT=1./(X_SW+X_SE+X_NW+X_NE) - ELSE - RECIP_SUM_WGT=0. - ENDIF -! - PROD_LWGT_SW(I,J)=X_SW*RECIP_SUM_WGT !<-- These are the adjusted bilinear interpolation - PROD_LWGT_SE(I,J)=X_SE*RECIP_SUM_WGT ! weights that take into account the presence - PROD_LWGT_NW(I,J)=X_NW*RECIP_SUM_WGT ! of sea points that must be excluded in the - PROD_LWGT_NE(I,J)=X_NE*RECIP_SUM_WGT ! summation. -! - X_SW=WGHT_SW(I,J)*SMASK(I_WEST,J_SOUTH) - X_SE=WGHT_SE(I,J)*SMASK(I_EAST,J_SOUTH) - X_NW=WGHT_NW(I,J)*SMASK(I_WEST,J_NORTH) - X_NE=WGHT_NE(I,J)*SMASK(I_EAST,J_NORTH) -! - SUM_WGT=X_SW+X_SE+X_NW+X_NE -! - IF(ABS(SUM_WGT)>1.E-6)THEN - RECIP_SUM_WGT=1./(X_SW+X_SE+X_NW+X_NE) - ELSE - RECIP_SUM_WGT=0. - ENDIF -! - PROD_SWGT_SW(I,J)=X_SW*RECIP_SUM_WGT !<-- These are the adjusted bilinear interpolation - PROD_SWGT_SE(I,J)=X_SE*RECIP_SUM_WGT ! weights that take into account the presence - PROD_SWGT_NW(I,J)=X_NW*RECIP_SUM_WGT ! of land points that must be excluded in the - PROD_SWGT_NE(I,J)=X_NE*RECIP_SUM_WGT ! summation. - ENDDO - ENDDO -! - ENDIF soil_wgts -! -!----------------------------------------------------------------------- -!*** Some of the primary dynamics integration variables are valid -!*** at the previous time step (PDO,TP,UP,VP). Update those at -!*** the appropriate nest gridpoints as well. Since the parent's -!*** time step is larger than the child's, approximate the child's -!*** previous time step value as -!*** (PARENT_CHILD_TIME_RATIO-1.)/PARENT_CHILD_TIME_RATIO -!*** between the old and current parent values. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Compute the parent's Psfc at the nest H or V update points. -!----------------------------------------------------------------------- -! - DO J=J1,J2 - DO I=I1,I2 -! - PSFC_PARENT_SW=PD(I_PARENT_WEST_H(I),J_PARENT_SOUTH_H(J))+PT - PSFC_PARENT_SE=PD(I_PARENT_EAST_H(I),J_PARENT_SOUTH_H(J))+PT - PSFC_PARENT_NW=PD(I_PARENT_WEST_H(I),J_PARENT_NORTH_H(J))+PT - PSFC_PARENT_NE=PD(I_PARENT_EAST_H(I),J_PARENT_NORTH_H(J))+PT -! - PINT_INTERP(I,J,LM+1)=WGHT_SW_H(I,J)*PSFC_PARENT_SW & !<-- Parent's Psfc at nest point at parent's sfc elevation - +WGHT_SE_H(I,J)*PSFC_PARENT_SE & ! - +WGHT_NW_H(I,J)*PSFC_PARENT_NW & ! - +WGHT_NE_H(I,J)*PSFC_PARENT_NE !<-- -! - LOG_PBOT(I,J)=LOG(PINT_INTERP(I,J,LM+1)) -! - PHI_INTERP(I,J,LM+1)=WGHT_SW_H(I,J)*FIS(I_PARENT_WEST_H(I) & !<-- Parent's sfc geopotential at nest point - ,J_PARENT_SOUTH_H(J)) & ! - +WGHT_SE_H(I,J)*FIS(I_PARENT_EAST_H(I) & ! - ,J_PARENT_SOUTH_H(J)) & ! - +WGHT_NW_H(I,J)*FIS(I_PARENT_WEST_H(I) & ! - ,J_PARENT_NORTH_H(J)) & ! - +WGHT_NE_H(I,J)*FIS(I_PARENT_EAST_H(I) & ! - ,J_PARENT_NORTH_H(J)) !<-- -! - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** Parent computes its layer interface pressures and geopotentials -!*** at the locations of the moving nest update points. The input -!*** and target values of pressure locations for the vertical -!*** interpolations from parent to nest are the hydrostatic midlayer -!*** and interface pressures. -!----------------------------------------------------------------------- -! - DO J=J1,J2 !<-- J limits of child task update region on parent task - J_SOUTH=J_PARENT_SOUTH_H(J) - J_NORTH=J_PARENT_NORTH_H(J) -! - DO I=I1,I2 !<-- I limits of child task update region on parent task - I_WEST=I_PARENT_WEST_H(I) - I_EAST=I_PARENT_EAST_H(I) -! - PD_INTERP(I,J)=WGHT_SW_H(I,J)*PD(I_WEST,J_SOUTH) & !<-- Parent's PD interp'd to child task update points - +WGHT_SE_H(I,J)*PD(I_EAST,J_SOUTH) & - +WGHT_NW_H(I,J)*PD(I_WEST,J_NORTH) & - +WGHT_NE_H(I,J)*PD(I_EAST,J_NORTH) -! - ENDDO - ENDDO -! - DO L=NUM_LYRS,1,-1 -! - PDTOP_PT=SG1(L+1)*PDTOP+PT -! - DO J=J1,J2 !<-- J limits of child task update region on parent task - J_SOUTH=J_PARENT_SOUTH_H(J) - J_NORTH=J_PARENT_NORTH_H(J) -! - DO I=I1,I2 !<-- I limits of child task update region on parent task - I_WEST=I_PARENT_WEST_H(I) - I_EAST=I_PARENT_EAST_H(I) -! - PX_SW=SG2(L)*PD(I_WEST,J_SOUTH)+PDTOP_PT !<-- Pressure, top of layer L, parent point SW of nest point - PX_SE=SG2(L)*PD(I_EAST,J_SOUTH)+PDTOP_PT !<-- Pressure, top of layer L, parent point SE of nest point - PX_NW=SG2(L)*PD(I_WEST,J_NORTH)+PDTOP_PT !<-- Pressure, top of layer L, parent point NW of nest point - PX_NE=SG2(L)*PD(I_EAST,J_NORTH)+PDTOP_PT !<-- Pressure, top of layer L, parent point NE of nest point -! - PINT_INTERP(I,J,L)=WGHT_SW_H(I,J)*PX_SW & !<-- Top interface hydrostatic pressure interpolated to - +WGHT_SE_H(I,J)*PX_SE & ! update point for child task N. These are the source - +WGHT_NW_H(I,J)*PX_NW & ! pressures for interface variables. - +WGHT_NE_H(I,J)*PX_NE !<-- -! - PMID_INTERP(I,J,L)=0.5*(PINT_INTERP(I,J,L) & !<-- Parent's midlayer hydrostatic pressure at nest update - +PINT_INTERP(I,J,L+1)) ! points. Source pressures for midlayer variables. -! - T_INTERP=WGHT_SW_H(I,J)*T(I_WEST,J_SOUTH,L) & !<-- T interp'd to update point for child task N - +WGHT_SE_H(I,J)*T(I_EAST,J_SOUTH,L) & ! - +WGHT_NW_H(I,J)*T(I_WEST,J_NORTH,L) & ! - +WGHT_NE_H(I,J)*T(I_EAST,J_NORTH,L) !<-- -! - Q_INTERP=WGHT_SW_H(I,J)*Q(I_WEST,J_SOUTH,L) & !<-- Q interp'd to update point for child task N - +WGHT_SE_H(I,J)*Q(I_EAST,J_SOUTH,L) & ! - +WGHT_NW_H(I,J)*Q(I_WEST,J_NORTH,L) & ! - +WGHT_NE_H(I,J)*Q(I_EAST,J_NORTH,L) !<-- -! - CW_INTERP=WGHT_SW_H(I,J)*CW(I_WEST,J_SOUTH,L) & !<-- CW interp'd to update point for child task N - +WGHT_SE_H(I,J)*CW(I_EAST,J_SOUTH,L) & ! - +WGHT_NW_H(I,J)*CW(I_WEST,J_NORTH,L) & ! - +WGHT_NE_H(I,J)*CW(I_EAST,J_NORTH,L) !<-- -! - DP=DSG2(L)*PD_INTERP(I,J)+PDSG1(L) -! - TMP=R_D*T_INTERP*((1.-CW_INTERP)+P608*Q_INTERP) - LOG_PTOP(I,J)=LOG(PINT_INTERP(I,J,L)) -! - PHI_INTERP(I,J,L)=PHI_INTERP(I,J,L+1) & !<-- Top interface geopotl of parent at child update point I,J - +TMP*(LOG_PBOT(I,J)-LOG_PTOP(I,J)) -! - LOG_PBOT(I,J)=LOG_PTOP(I,J) -! - ENDDO - ENDDO -! - ENDDO -! -!----------------------------------------------------------------------- -!*** Use the sfc geopotential at the nest points to derive the -!*** value of PD at the nest points based on the parent's heights -!*** and pressures on the parent's layer interfaces over the -!*** child's points. -! -!*** If the child's terrain is lower than the value of the parent's -!*** terrain interpolated to the child point then extrapolate the -!*** parent's interpolated sfc pressure down to the child's terrain -!*** quadratically. -!----------------------------------------------------------------------- -! - DO J=J1,J2 - J_TRANS=J+J_OFFSET !<-- J on full nest resolution of parent at given nest J -! - DO I=I1,I2 - I_TRANS=I+I_OFFSET !<-- I on full nest resolution of parent at given nest I -! - IF(FIS_CHILD(I_TRANS,J_TRANS) Bilinear interpolation -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - ELSEIF(NUM_DIMS==3)THEN dims_2_or_3 -! -!----------------------------------------------------------------------- -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N in the Bundle - ,localDe =0 & - ,farrayPtr =ARRAY_3D & !<-- Dummy 3-D array with Field's data - ,totalLBound=LIMITS_LO & !<-- Starting index in each dimension - ,totalUBound=LIMITS_HI & !<-- Ending index in each dimension - ,rc =RC ) -! - KLO=LIMITS_LO(3) - KHI=LIMITS_HI(3) - NUM_LEVELS=KHI-KLO+1 !<-- # of levels in this 3-D Real variable -! -!----------------------------------------------------------------------- -!*** The nature of the unique Q2 array complicates how the parent -!*** must interpolate its values to the nest gridpoints. Q2 is a -!*** 3-D array that lie on the layer interfaces BUT its level K=1 -!*** is the BOTTOM of the uppermost model layer and not the top of -!*** the uppermost layer. Thus while there are NUM_LYRS+1 layer -!*** interfaces there are only NUM_LYRS levels in Q2 that correspond -!*** with interfaces 2->NUM_LYRS+1. Rather than insert an assortment -!*** of confusing IF tests to make a single set of code be generic, -!*** separate Q2 from the rest of the variables and deal with it -!*** inside its own block. -!----------------------------------------------------------------------- -! - q2: IF(FIELD_NAME=='Q2')THEN -! -!----------------------------------------------------------------------- -!*** We must add a new level to the top of the Q2 or E2 data in case -!*** their pressures at the bottom of the uppermost layer are less -!*** than on the bottom of the uppermost layer in the parent. -!----------------------------------------------------------------------- -! - IF(ALLOCATED(P_OUTPUT))DEALLOCATE(P_OUTPUT) - ALLOCATE(P_OUTPUT(KLO:KHI+1)) -! - IF(ALLOCATED(VBL_INTERP))DEALLOCATE(VBL_INTERP) - ALLOCATE(VBL_INTERP(I1:I2,J1:J2,KLO:KHI+1+1)) - ALLOCATE(VBL_COL_X(KLO:KHI+1)) -! - DO L=KLO,KHI+2 - P_INPUT(L)=0. - VBL_INPUT(L)=0. - ENDDO -! - DO J=J1,J2 - DO I=I1,I2 - VBL_INTERP(I,J,KHI+1+1)=0. - ENDDO - ENDDO -! - DO L=KLO,KHI - DO J=J1,J2 - J_SOUTH=J_PARENT_SOUTH(J) - J_NORTH=J_PARENT_NORTH(J) -! - DO I=I1,I2 - I_WEST=I_PARENT_WEST(I) - I_EAST=I_PARENT_EAST(I) -! - VBL_INTERP(I,J,L+1)= & !<-- Parent's 3-D variable interpolated - WGHT_SW(I,J)*ARRAY_3D(I_WEST,J_SOUTH,L) & ! horizontally to the moving nest's - +WGHT_SE(I,J)*ARRAY_3D(I_EAST,J_SOUTH,L) & ! update location. - +WGHT_NW(I,J)*ARRAY_3D(I_WEST,J_NORTH,L) & ! - +WGHT_NE(I,J)*ARRAY_3D(I_EAST,J_NORTH,L) !<-- - ENDDO - ENDDO - ENDDO -! - DO J=J1,J2 - DO I=I1,I2 - VBL_INTERP(I,J,1)=VBL_INTERP(I,J,2) !<-- Fill in the artificial top level. - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** Use cubic spline interpolation to move variables to child update -!*** point levels from their original vertical locations in the column -!*** following horizontal interpolation from the surrounding parent -!*** points. The target locations are the new interface pressures -!*** in the nest update point columns based on the new surface -!*** pressure for the nest's terrain. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** If the target location lies below the lowest parent pressure -!*** level in the newly created child column then extrapolate linearly -!*** in pressure to obtain a value at the lowest child level and -!*** fill in the remaining 'underground' levels using the call to -!*** 'SPLINE' just as with all the other levels above it. -!----------------------------------------------------------------------- -! - N_STRIDE=NPOINTS_HORIZ - N_ADD =NPOINTS_HORIZ*(NUM_LEVELS-1) -! - NUM_LEVS_SEC=NUM_LEVELS+1+1 !<-- Use this many levels in the 2nd derivative array - ALLOCATE(SEC_DERIV(1:NUM_LEVS_SEC)) !<-- Allocate 1 longer in case we increase the -! ! # of input levels below. - LOC_1=KNT_REAL_PTS(N) -! - P3D_INPUT=>PINT_INTERP - P3D_OUTPUT=>PINT_CHILD -! - DO J=J1,J2 - DO I=I1,I2 -! - DO L=1,NUM_LEVELS+1 !<-- We are adding a temporary top level to Q2 and E2 - P_INPUT (L)=P3D_INPUT(I,J,L) !<-- Parent input pressures over nest update point - P_OUTPUT (L)=P3D_OUTPUT(I,J,L) !<-- Nest target pressures over nest update point - VBL_INPUT(L)=VBL_INTERP(I,J,L) !<-- Values of parent variable values over nest update point - ENDDO -! - NUM_LEVS_IN=NUM_LEVELS+1 - LOC_1=LOC_1+1 - LOC_2=LOC_1+N_ADD - VBL_COL_CHILD=>CHILD_UPDATE_DATA%TASKS(N)%DATA_REAL(LOC_1:LOC_2:N_STRIDE) !<-- Point working column pointer into - ! the 1-D rendering of this 3-D real - ! update variable in the composite output. -! - IF(P_OUTPUT(NUM_LEVELS+1)>P_INPUT(NUM_LEVELS+1))THEN !<-- The nest's bottom level is below the parent's - NUM_LEVS_IN=NUM_LEVELS+1+1 ! so add another input level that is the same - P_INPUT(NUM_LEVELS+1+1)=P_OUTPUT(NUM_LEVELS+1) ! as the nest's lowest level. - R_DELP=1./(P_INPUT(NUM_LEVELS+1)-P_INPUT(NUM_LEVELS)) - DELP_EXTRAP=P_OUTPUT(NUM_LEVELS+1) & - -P_INPUT(NUM_LEVELS+1) -! - COEFF_1=(VBL_INPUT(NUM_LEVELS+1) & - -VBL_INPUT(NUM_LEVELS))*R_DELP - FACTOR=HYPER_A/(DELP_EXTRAP+HYPER_A) - VBL_INPUT(NUM_LEVELS+1+1)=VBL_INPUT(NUM_LEVELS+1) & !<-- Create extrapolated value at parent's new lowest - +COEFF_1*DELP_EXTRAP*FACTOR ! level for input to the spline. - ENDIF -! - DO L=1,NUM_LEVS_SEC - SEC_DERIV(L)=0. !<-- Initialize 2nd derivatives of the spline to zero. - ENDDO -! - CALL SPLINE(NUM_LEVS_IN & !<-- # of input levels - ,P_INPUT & !<-- Input variable is at these input pressure values - ,VBL_INPUT & !<-- The column of input variable values - ,SEC_DERIV & !<-- Specified 2nd derivatives (=0) at parent levels - ,NUM_LEVS_SEC & !<-- Vertical dimension of SEC_DERIV - ,NUM_LEVELS+1 & !<-- # of child target levels to interpolate to - ,P_OUTPUT & !<-- Child target pressure values to interpolate to - ,VBL_COL_X) !<-- Child values of variable returned on P_OUTPUT levels -! - DO L=KLO,KHI - VBL_COL_CHILD(L)=VBL_COL_X(L+1) !<-- Eliminate the artificial level on top of layer 1. - ENDDO -! - ENDDO - ENDDO -! - KNT_REAL_PTS(N)=KNT_REAL_PTS(N)+NPOINTS_HORIZ*NUM_LEVELS !<-- Total points updated in composite output after -! ! this 3-D real variable was done. - DEALLOCATE(VBL_COL_X) - DEALLOCATE(SEC_DERIV) -! -!----------------------------------------------------------------------- -! - ELSE q2 !<-- All 3-D variables that are not Q2 -! -!----------------------------------------------------------------------- -! - MIDLAYERS=.FALSE. - INTERFACES=.FALSE. -! - IF(NUM_LEVELS==NUM_LYRS)THEN - MIDLAYERS=.TRUE. - ELSEIF(NUM_LEVELS==NUM_LYRS+1)THEN - INTERFACES=.TRUE. - ENDIF -! - IF(ALLOCATED(P_OUTPUT))DEALLOCATE(P_OUTPUT) - ALLOCATE(P_OUTPUT(KLO:KHI)) -! - IF(ALLOCATED(VBL_INTERP))DEALLOCATE(VBL_INTERP) - ALLOCATE(VBL_INTERP(I1:I2,J1:J2,KLO:KHI+1)) -! -!----------------------------------------------------------------------- -!*** Use cubic spline interpolation to move variables to child update -!*** point levels from their original vertical locations in the column -!*** following horizontal interpolation from the surrounding parent -!*** points. The target locations are the new pressures values -!*** in the nest update point columns based on the new surface -!*** pressure for the nest's terrain. However this is obviously -!*** done only for atmospheric variables. Of course it is not -!*** done for 3-D land surface variables. -!----------------------------------------------------------------------- -! - soil_or_not: IF(UPDATE_TYPE_CHAR/='L')THEN !<-- 3-D H-pt variable that is not soil. -! -!----------------------------------------------------------------------- -! - DO L=1,NUM_LYRS+2 !<-- Maximum # of levels to be used. - P_INPUT(L)=0. - VBL_INPUT(L)=0. - ENDDO -! - DO J=J1,J2 - DO I=I1,I2 - VBL_INTERP(I,J,KHI+1)=0. - ENDDO - ENDDO -! - DO L=KLO,KHI - DO J=J1,J2 - J_SOUTH=J_PARENT_SOUTH(J) - J_NORTH=J_PARENT_NORTH(J) -! - DO I=I1,I2 - I_WEST=I_PARENT_WEST(I) - I_EAST=I_PARENT_EAST(I) -! - VBL_INTERP(I,J,L)= & !<-- Parent's 3-D variable interpolated - WGHT_SW(I,J)*ARRAY_3D(I_WEST,J_SOUTH,L) & ! horizontally to the moving nest's - +WGHT_SE(I,J)*ARRAY_3D(I_EAST,J_SOUTH,L) & ! update location. - +WGHT_NW(I,J)*ARRAY_3D(I_WEST,J_NORTH,L) & ! - +WGHT_NE(I,J)*ARRAY_3D(I_EAST,J_NORTH,L) !<-- - ENDDO - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** If the target location lies below the lowest parent pressure -!*** level in the newly created child column then extrapolate linearly -!*** in pressure to obtain a value at the lowest child level and -!*** fill in the remaining 'underground' levels using the call to -!*** 'SPLINE' just as with all the other levels above it. -!----------------------------------------------------------------------- -! - N_STRIDE=NPOINTS_HORIZ - N_ADD =NPOINTS_HORIZ*(NUM_LEVELS-1) -! - NUM_LEVS_SEC=NUM_LEVELS+1 !<-- Use this many levels in the 2nd derivative array - ALLOCATE(SEC_DERIV(1:NUM_LEVS_SEC)) !<-- Allocate 1 longer in case we increase the -! ! # of input levels below. - LOC_1=KNT_REAL_PTS(N) -! - IF(MIDLAYERS)THEN !<-- Input/output pressures are at midlayers - P3D_INPUT=>PMID_INTERP - P3D_OUTPUT=>PMID_CHILD -! - ELSEIF(INTERFACES)THEN !<-- Input/output pressures are at interfaces - P3D_INPUT=>PINT_INTERP - P3D_OUTPUT=>PINT_CHILD -! - ELSE - WRITE(0,*)' # of levels in 3-D variable is ',NUM_LEVELS - WRITE(0,*)' That is not midlayer, interface, or soil.' - WRITE(0,*)' ABORT!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) -! - ENDIF -! - DO J=J1,J2 - DO I=I1,I2 -! - DO L=1,NUM_LEVELS !<-- Variable has NUM_LEVELS levels in parent and nest - P_INPUT (L)=P3D_INPUT(I,J,L) !<-- Parent input pressures over nest update point - P_OUTPUT (L)=P3D_OUTPUT(I,J,L) !<-- Nest target pressures over nest update point - VBL_INPUT(L)=VBL_INTERP(I,J,L) !<-- Values of parent variable values over nest update point - ENDDO -! - NUM_LEVS_IN=NUM_LEVELS - LOC_1=LOC_1+1 - LOC_2=LOC_1+N_ADD - VBL_COL_CHILD=>CHILD_UPDATE_DATA%TASKS(N)%DATA_REAL(LOC_1:LOC_2:N_STRIDE) !<-- Point working column pointer into - ! the 1-D rendering of this 3-D real - ! update variable in the composite output. -! - IF(P_OUTPUT(NUM_LEVELS)>P_INPUT(NUM_LEVELS))THEN !<-- The nest's bottom level is below the parent's - NUM_LEVS_IN=NUM_LEVELS+1 ! so add another input level that is the same - P_INPUT(NUM_LEVELS+1)=P_OUTPUT(NUM_LEVELS) ! as the nest's lowest level. - R_DELP=1./(P_INPUT(NUM_LEVELS)-P_INPUT(NUM_LEVELS-1)) - DELP_EXTRAP=P_OUTPUT(NUM_LEVELS) & - -P_INPUT(NUM_LEVELS) -! - COEFF_1=(VBL_INPUT(NUM_LEVELS) & - -VBL_INPUT(NUM_LEVELS-1))*R_DELP - FACTOR=HYPER_A/(DELP_EXTRAP+HYPER_A) - VBL_INPUT(NUM_LEVELS+1)=VBL_INPUT(NUM_LEVELS) & !<-- Create extrapolated value at parent's new lowest - +COEFF_1*DELP_EXTRAP*FACTOR ! level for input to the spline. - ENDIF -! - DO L=1,NUM_LEVS_SEC - SEC_DERIV(L)=0. !<-- Initialize 2nd derivatives of the spline to zero. - ENDDO -! - CALL SPLINE(NUM_LEVS_IN & !<-- # of input levels - ,P_INPUT & !<-- Input variable is at these input pressure values - ,VBL_INPUT & !<-- The column of input variable values - ,SEC_DERIV & !<-- Specified 2nd derivatives (=0) at parent levels - ,NUM_LEVS_SEC & !<-- Vertical dimension of SEC_DERIV - ,NUM_LEVELS & !<-- # of child target levels to interpolate to - ,P_OUTPUT & !<-- Child target pressure values to interpolate to - ,VBL_COL_CHILD) !<-- Child values of variable returned on P_OUTPUT levels -! - ENDDO - ENDDO -! - KNT_REAL_PTS(N)=KNT_REAL_PTS(N)+NPOINTS_HORIZ*NUM_LEVELS !<-- Total points updated in composite output after -! ! this 3-D real variable was done. - DEALLOCATE(SEC_DERIV) -! -!----------------------------------------------------------------------- -!*** For 3-D soil variables the parent uses bilinear interpolation -!*** but must also use the land mask. The bilinear interpolation -!*** weighting needs to be adjusted to account for water points that -!*** are excluded from the summation. The code assumes there are -!*** no 3-D water point variables to update (UPDATE_TYPE_CHAR=='S'). -!----------------------------------------------------------------------- -! - ELSEIF(UPDATE_TYPE_CHAR=='L')THEN !<-- 3-D H-pt variable that is soil -! -!----------------------------------------------------------------------- -! -!!! FNAME=TRIM(FIELD_NAME) - FNAME=FIELD_NAME -! - DO L=KLO,KHI !<-- Loop through the soil layers -! - DO J=J1,J2 - J_SOUTH=J_PARENT_SOUTH(J) - J_NORTH=J_PARENT_NORTH(J) -! - DO I=I1,I2 - I_WEST=I_PARENT_WEST(I) - I_EAST=I_PARENT_EAST(I) -! - KNT_REAL_PTS(N)=KNT_REAL_PTS(N)+1 !<-- Total real points updated in composite output. -! -!!! CHILD_UPDATE_DATA%TASKS(N)%DATA_REAL(KNT_REAL_PTS(N))= & !<-- Parent's 3-D soil variable interpolated - SUM_PROD=PROD_LWGT_SW(I,J)+PROD_LWGT_SE(I,J) & - +PROD_LWGT_NW(I,J)+PROD_LWGT_NE(I,J) -! - IF(ABS(SUM_PROD)<1.E-5)THEN - IF(FNAME=='SMC'.OR.FNAME=='SH2O')THEN - CHILD_UPDATE_DATA%TASKS(N)%DATA_REAL(KNT_REAL_PTS(N))=1.0 - ELSEIF(FNAME=='STC')THEN - CHILD_UPDATE_DATA%TASKS(N)%DATA_REAL(KNT_REAL_PTS(N))=273.16 - ENDIF - ELSE - CHILD_UPDATE_DATA%TASKS(N)%DATA_REAL(KNT_REAL_PTS(N))= & !<--- - PROD_LWGT_SW(I,J)*ARRAY_3D(I_WEST,J_SOUTH,L) & ! Parent's 3-D soil variable interpolated - +PROD_LWGT_SE(I,J)*ARRAY_3D(I_EAST,J_SOUTH,L) & ! horizontally to the moving nest's - +PROD_LWGT_NW(I,J)*ARRAY_3D(I_WEST,J_NORTH,L) & ! update location using the land mask. - +PROD_LWGT_NE(I,J)*ARRAY_3D(I_EAST,J_NORTH,L) !<-- - ENDIF -! - ENDDO - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -! - ENDIF soil_or_not -! -!----------------------------------------------------------------------- -! - ENDIF q2 -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! - ENDIF dims_2_or_3 -! -!----------------------------------------------------------------------- -! - ENDDO field_loop -! -!----------------------------------------------------------------------- -! - DEALLOCATE(I_PARENT) - DEALLOCATE(I_PARENT_EAST) - DEALLOCATE(I_PARENT_WEST) -! - DEALLOCATE(J_PARENT) - DEALLOCATE(J_PARENT_NORTH) - DEALLOCATE(J_PARENT_SOUTH) -! - DEALLOCATE(WGHT_SW) - DEALLOCATE(WGHT_NW) - DEALLOCATE(WGHT_NE) - DEALLOCATE(WGHT_SE) -! - DEALLOCATE(LOG_PBOT ) - DEALLOCATE(LOG_PTOP ) - DEALLOCATE(PINT_INTERP) - DEALLOCATE( PHI_INTERP) - DEALLOCATE(PMID_INTERP) - DEALLOCATE(PMID_CHILD ) - DEALLOCATE(PINT_CHILD ) - DEALLOCATE(PD_CHILD ) - DEALLOCATE(PD_INTERP ) - DEALLOCATE(VBL_INTERP ) -! - NULLIFY(P3D_INPUT) - NULLIFY(P3D_OUTPUT) -! - IF(FLAG_H_OR_V=='H')THEN - DEALLOCATE(PROD_LWGT_NE) - DEALLOCATE(PROD_LWGT_NW) - DEALLOCATE(PROD_LWGT_SE) - DEALLOCATE(PROD_LWGT_SW) - DEALLOCATE(PROD_SWGT_NE) - DEALLOCATE(PROD_SWGT_NW) - DEALLOCATE(PROD_SWGT_SE) - DEALLOCATE(PROD_SWGT_SW) - ENDIF -! - IF(FLAG_H_OR_V=='V')THEN -! - DEALLOCATE(I_PARENT_EAST_H) - DEALLOCATE(I_PARENT_WEST_H) - DEALLOCATE(J_PARENT_NORTH_H) - DEALLOCATE(J_PARENT_SOUTH_H) -! - DEALLOCATE(I_CHILD_ON_PARENT_H) - DEALLOCATE(J_CHILD_ON_PARENT_H) -! - DEALLOCATE(WGHT_NE_H) - DEALLOCATE(WGHT_NW_H) - DEALLOCATE(WGHT_SE_H) - DEALLOCATE(WGHT_SW_H) -! - ENDIF -! - ENDDO iter_loop -! -!----------------------------------------------------------------------- -!*** The parent task sends its update data to this moving nest task. -!*** The parent only sends to a moving nest after updating both H -!*** and V points so that all data can be sent to each nest task -!*** in a single message. -!----------------------------------------------------------------------- -! - IF(FLAG_H_OR_V=='V')THEN -! - CHILDTASK=CHILD_TASK_RANKS(PTR_X%TASK_ID) - ITAG=KNT_REAL_PTS(N)+NTIMESTEP_CHILD !<-- Tag that changes for data size and time -! - CALL MPI_ISSEND(CHILD_UPDATE_DATA%TASKS(N)%DATA_REAL & !<-- Internal real update data for moving nest task N - ,KNT_REAL_PTS(N) & !<-- # of real words in the data string - ,MPI_REAL & !<-- Datatype - ,CHILDTASK & !<-- Local intracom rank of nest task to recv data - ,ITAG & !<-- Unique MPI tag - ,COMM_TO_MY_CHILD & !<-- MPI intracommunicator - ,HANDLE_UPDATE(PTR_X%TASK_ID) & !<-- Handle for ISend to child task - ,IERR ) -! - IF(KNT_INTEGER_PTS(N)>0)THEN - ITAG=KNT_INTEGER_PTS(N)+NTIMESTEP_CHILD !<-- Tag that changes for data size and time -! - CALL MPI_ISSEND(CHILD_UPDATE_DATA%TASKS(N)%DATA_INTEGER & !<-- Internal integer update data for moving nest task N - ,KNT_INTEGER_PTS(N) & !<-- # of integer words in the data string - ,MPI_INTEGER & !<-- Datatype - ,CHILDTASK & !<-- Local intracom rank of nest task to recv data - ,ITAG & !<-- Unique MPI tag - ,COMM_TO_MY_CHILD & !<-- MPI intracommunicator - ,HANDLE_UPDATE(PTR_X%TASK_ID) & !<-- Handle for ISend to child task - ,IERR ) - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Point at the next link of the linked list holding the -!*** update task ID and index limits on the next task. -!----------------------------------------------------------------------- -! - PTR_X=>PTR_X%NEXT_LINK -! -!----------------------------------------------------------------------- -! - ENDDO ctask_loop -! -!----------------------------------------------------------------------- -!*** All of the combined H and V update data has been sent by this -!*** parent task to each appropriate task on this nest so deallocate -!*** the array holding the number of update points on each nest task. -!----------------------------------------------------------------------- -! - IF(FLAG_H_OR_V=='V')THEN - DEALLOCATE(KNT_REAL_PTS) - DEALLOCATE(KNT_INTEGER_PTS) - DEALLOCATE(NUM_ITER) - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PARENT_UPDATES_MOVING -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE PARENT_READS_MOVING_CHILD_TOPO(MY_DOMAIN_ID & - ,NUM_MOVING_CHILDREN & - ,LINK_MRANK_RATIO & - ,LIST_OF_RATIOS & - ,M_NEST_RATIO & - ,KOUNT_RATIOS_MN & - ,GLOBAL_TOP_PARENT & - ,IM_1,JM_1 & - ,TPH0_1,TLM0_1 & - ,SB_1,WB_1 & - ,RECIP_DPH_1,RECIP_DLM_1 & - ,GLAT,GLON & - ,NEST_FIS_ON_PARENT_BNDS & - ,NEST_FIS_ON_PARENT & - ,NEST_FIS_V_ON_PARENT & - ,IDS,IDE,IMS,IME,ITS,ITE & - ,JDS,JDE,JMS,JME,JTS,JTE) -! -!----------------------------------------------------------------------- -!*** Parents of moving nests must fill their own domains with the -!*** full resolution topography of those children. That data spans -!*** the entire domain of the uppermost parent. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: IM_1,JM_1 & !<-- Dimensions of the uppermost parent domain - ,IDS,IDE,JDS,JDE & !<-- This parent domain's index limits - ,IMS,IME,JMS,JME & !<-- This parent tasks's memory limits - ,ITS,ITE,JTS,JTE & !<-- This parent tasks's integration limits - ,KOUNT_RATIOS_MN & !<-- # of space ratios of children to upper parent - ,MY_DOMAIN_ID & !<-- This parent domain's ID - ,NUM_MOVING_CHILDREN !<-- # of moving children on this parent domain -! - INTEGER(kind=KINT),DIMENSION(1:NUM_MOVING_CHILDREN),INTENT(IN) :: & - LINK_MRANK_RATIO & !<-- Each child asociated with rank of space ratio in list - ,LIST_OF_RATIOS & !<-- The list of different space ratios - ,M_NEST_RATIO !<-- Associate each child with its upper parent space ratio -! - REAL(kind=KFPT),INTENT(IN) :: RECIP_DPH_1,RECIP_DLM_1 & !<-- Reciprocal of uppermost domain grid increments (radians) - ,TLM0_1,TPH0_1 & !<-- Central geo lat/lon of uppermost domain (radians; east/north) - ,SB_1,WB_1 !<-- Rotated lat/lon of south/west boundary (radians; north/east) -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: GLAT,GLON !<-- Geographic lat/lon (radians) on parent grid -! - LOGICAL(kind=KLOG),INTENT(IN) :: GLOBAL_TOP_PARENT !<-- Is the uppermost parent domain global? -! - TYPE(BNDS_2D),DIMENSION(1:KOUNT_RATIOS_MN),INTENT(OUT) :: & - NEST_FIS_ON_PARENT_BNDS !<-- Parent subdomain index limits of nest-res topo data -! - TYPE(REAL_DATA_2D),DIMENSION(1:KOUNT_RATIOS_MN),INTENT(INOUT) :: & - NEST_FIS_ON_PARENT & !<-- Nest-res topo data on the parent task subdomain - ,NEST_FIS_V_ON_PARENT !<-- Nest-res topo data at V on the parent task subdomain -! -!-------------------- -!*** Local Variables -!-------------------- -! - INTEGER(kind=KINT) :: I,ICORNER,IDIM,IEND,ISTART,IUNIT_FIS_NEST & - ,J,JCORNER,JDIM,JEND,JSTART,JSTOP,LOR,N,NN -! - INTEGER(kind=KINT) :: I_COUNT_DATA,J_COUNT_DATA & - ,I_EXTRA_DATA,J_EXTRA_DATA & - ,NCID,NCTYPE,NDIMS,VAR_ID -! - INTEGER(kind=KINT) :: IERR,ISTAT -! - INTEGER(kind=KINT),DIMENSION(1:2) :: DIM_IDS -! - REAL(kind=KFPT) :: GBL,REAL_I_NE,REAL_I_SW,REAL_J_NE,REAL_J_SW & - ,VAL_NE -! - REAL(kind=KFPT),DIMENSION(:),ALLOCATABLE :: COL,ROW -! - CHARACTER(len=2) :: ID_TOPO_FILE - CHARACTER(len=9) :: FILENAME - CHARACTER(len=15) :: VNAME -! - LOGICAL(kind=KLOG) :: OPENED -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Parents with moving nests need to know those nests' topography -!*** at the nests' own resolutions for the hydrostatic adjustment -!*** that must take place when the parents interpolate their data -!*** to moving nest grid points. For the sake of generality all -!*** of those nest-resolution datasets must span the domain of the -!*** uppermost parent which is the true maximum range of any nest's -!*** motion. -! -!*** So each parent with moving nests must: -!*** (1) Know how many different space resolutions its moving -!*** children use; -!*** (2) Associate each resolution with the appropriate moving -!*** child using the nest-to-uppermost parent space ratio -!*** that the user specified in each moving nest's configure -!*** file; -!*** (3) Have each of its forecast tasks read in its own piece of -!*** each different resolution of topography data needed by -!*** all of its moving children. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Each parent task obtains the real I,J on the uppermost parent -!*** of the SW and NE corners of each of their subdomains. Given -!*** the known resolution of the nest topography data the parent -!*** tasks can then extract and save only that data which covers -!*** their own subdomain. -!----------------------------------------------------------------------- -! -!---------------------------------------- -!*** SW corner of parent task subdomain -!---------------------------------------- -! - ICORNER=MAX(IMS,IDS) !<-- Parent task covers its halos with data too since - JCORNER=MAX(JMS,JDS) ! the moving nest boundaries can extend into them. -! - IF(MY_DOMAIN_ID==1.AND.GLOBAL_TOP_PARENT)THEN !<-- The current parent domain is global. - IF(ITS==IDS)THEN - ICORNER=ICORNER+1. !<-- Past buffer row to Intl Dateline - ENDIF - IF(JTS==JDS)THEN - JCORNER=JCORNER+1. - ENDIF - ENDIF -! - CALL LATLON_TO_IJ(GLAT(ICORNER,JCORNER) & !<-- Geographic lat (radians) of parent task's SW corner - ,GLON(ICORNER,JCORNER) & !<-- Geographic lon (radians) of parent task's SW corner - ,TPH0_1,TLM0_1 & !<-- Geographic lat,lon of upper parent's central point - ,SB_1,WB_1 & !<-- Rotated lat/lon of upper parent's SW corner - ,RECIP_DPH_1,RECIP_DLM_1 & - ,GLOBAL_TOP_PARENT & !<-- Is the uppermost parent domain global? - ,REAL_I_SW & !<-- Uppermost parent I of this task's SW corner - ,REAL_J_SW) !<-- Uppermost parent J of this task's SW corner -! -!---------------------------------------- -!*** NE corner of parent task subdomain -!---------------------------------------- -! - ICORNER=MIN(IME,IDE) !<-- Parent task covers its halos with data too since - JCORNER=MIN(JME,JDE) ! the moving nest boundaries can extend into them. -! - IF(MY_DOMAIN_ID==1.AND.GLOBAL_TOP_PARENT)THEN !<-- The current parent domain is global. - IF(ITE==IDE)THEN - ICORNER=ICORNER-1. !<-- Past buffer row to Intl Dateline - ENDIF - IF(JTE==JDE)THEN - JCORNER=JCORNER-1. - ENDIF - ENDIF -! - CALL LATLON_TO_IJ(GLAT(ICORNER,JCORNER) & - ,GLON(ICORNER,JCORNER) & - ,TPH0_1,TLM0_1 & - ,SB_1,WB_1 & - ,RECIP_DPH_1,RECIP_DLM_1 & - ,GLOBAL_TOP_PARENT & - ,REAL_I_NE & - ,REAL_J_NE) -! -!----------------------------------------------------------------------- - nr_loop: DO N=1,KOUNT_RATIOS_MN !<-- Loop through the different parent-child space ratios -!----------------------------------------------------------------------- -! - LOR=LIST_OF_RATIOS(N) -! - IF(GLOBAL_TOP_PARENT)THEN - GBL=1. !<-- Account for the extra row that surrounds global domains. - ELSE - GBL=0. - ENDIF -! - ISTART=NINT((REAL_I_SW-1.-GBL)*LOR+1.) !<-- I index in sfc data at W bndry of this parent task - JSTART=NINT((REAL_J_SW-1.-GBL)*LOR+1.) !<-- J index in sfc data at S bndry of this parent task -! - IEND=NINT((REAL_I_NE-1.-GBL)*LOR+1.) !<-- I index in nest sfc data at E bndry (H) of this parent task - JEND=NINT((REAL_J_NE-1.-GBL)*LOR+1.) !<-- J index in nest sfc data at N bndry (H) of this parent task -! - I_COUNT_DATA=IEND-ISTART+1 - J_COUNT_DATA=JEND-JSTART+1 -! -!----------------------------------------------------------------------- -! - NEST_FIS_ON_PARENT_BNDS(N)%LBND1=ISTART !<-- Array limits in nest-resolution topography data - NEST_FIS_ON_PARENT_BNDS(N)%UBND1=IEND ! for region covering this parent task's subdomain. - NEST_FIS_ON_PARENT_BNDS(N)%LBND2=JSTART ! - NEST_FIS_ON_PARENT_BNDS(N)%UBND2=JEND !<-- -! -!----------------------------------------------------------------------- -!*** Each parent task opens and reads the topography file. -!----------------------------------------------------------------------- -! - IF(N<=9)THEN - NN=LOR - IF(NN<=9)THEN - WRITE(ID_TOPO_FILE,'(I1.1)')NN - ELSEIF(NN>=10)THEN - WRITE(ID_TOPO_FILE,'(I2.2)')NN - ENDIF - ELSE - WRITE(0,*)' User specified more than 9 different' & - ,' moving nest resolutions!!!' - WRITE(0,*)' ABORTING' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - FILENAME='FIS_'//TRIM(ID_TOPO_FILE)//'.nc' -! - CALL CHECK(NF90_OPEN(FILENAME,NF90_NOWRITE,NCID)) !<-- Open the FIS external netCDF file for Nth space ratio. -! -!----------------------------------------------------------------------- -!*** Each task allocates its space for holding its moving children's -!*** topography at their resolution. -!----------------------------------------------------------------------- -! - IF(ASSOCIATED(NEST_FIS_ON_PARENT(N)%DATA))THEN - DEALLOCATE(NEST_FIS_ON_PARENT(N)%DATA,stat=ISTAT) - ENDIF - IF(ASSOCIATED(NEST_FIS_V_ON_PARENT(N)%DATA))THEN - DEALLOCATE(NEST_FIS_V_ON_PARENT(N)%DATA,stat=ISTAT) - ENDIF -! - ALLOCATE(NEST_FIS_ON_PARENT(N)%DATA(ISTART:IEND,JSTART:JEND)) - ALLOCATE(NEST_FIS_V_ON_PARENT(N)%DATA(ISTART:IEND,JSTART:JEND)) -! -!----------------------------------------------------------------------- -!*** Save only those points in the topography data for resolution N -!*** that cover this parent task's subdomain. -!*** Begin with the nest-resolution topography at H points. -!----------------------------------------------------------------------- -! - CALL CHECK(NF90_INQUIRE_VARIABLE(NCID,3,VNAME,NCTYPE & !<-- Topography is the 3rd variable in the file. - ,NDIMS,DIM_IDS)) - CALL CHECK(NF90_INQ_VARID(NCID,VNAME,VAR_ID)) -! - CALL CHECK(NF90_GET_VAR(NCID,VAR_ID & !<-- Extract the values - ,NEST_FIS_ON_PARENT(N)%DATA(ISTART:IEND,JSTART:JEND) & ! of nest-resolution - ,start=(/ISTART,JSTART/) & ! topography from the - ,count=(/I_COUNT_DATA,J_COUNT_DATA/))) ! external file. -! -!----------------------------------------------------------------------- -!*** For the nest topography values at V points we can begin by -!*** averaging the values at H points. -!----------------------------------------------------------------------- -! - DO J=JSTART,JEND-1 - DO I=ISTART,IEND-1 - NEST_FIS_V_ON_PARENT(N)%DATA(I,J)=(NEST_FIS_ON_PARENT(N)%DATA(I,J) & - +NEST_FIS_ON_PARENT(N)%DATA(I+1,J) & - +NEST_FIS_ON_PARENT(N)%DATA(I,J+1) & - +NEST_FIS_ON_PARENT(N)%DATA(I+1,J+1) & - )*0.25 - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** The V row at J=J_END is north of the H row at J=J_END. -!*** The V column at I=I_END is east of the H column at I=I_END. -!*** This means we need to read in extra values to get those -!*** V points on the north and east edges of the parent tasks. -!----------------------------------------------------------------------- -! - ALLOCATE(ROW(ISTART:IEND)) - ALLOCATE(COL(JSTART:JEND)) -! - I_EXTRA_DATA=ISTART+I_COUNT_DATA !<-- 1 column east of task's saved H data - J_EXTRA_DATA=JSTART+J_COUNT_DATA !<-- 1 row north of task's saved H data -! -!----------------------------------------------------------------------- -!*** Fill in values of nest topography on V points one row north -!*** of the northern limit of the H-point topography saved on -!*** this parent task. -!----------------------------------------------------------------------- -! - IF(JTEH, -!*** v-->V, pd-->H, and pd-->V. Determine the set of parent -!*** target I's and J's common to all the stencils and use -!*** that to ensure that the same parent I,J indices are used -!*** for both H and V variables. -!----------------------------------------------------------------------- -! - N_STENCIL_X(1)=N_STENCIL_H_CHILD - N_STENCIL_X(2)=N_STENCIL_V_CHILD - N_STENCIL_X(3)=N_STENCIL_SFC_H_CHILD - N_STENCIL_X(4)=N_STENCIL_SFC_V_CHILD -! -!----------------------------------------------------------------------- -!*** Deallocate the linked list of child update tasks if it already -!*** exists. This is relevant only for moving nests. This routine -!*** is called only once for static nests when the linked list does -!*** not yet exist. -!----------------------------------------------------------------------- -! - KOUNT=0 - HEAD=>CHILD_TASKS_2WAY_UPDATE !<-- Point at the top of the linked list -! - dealloc: DO -! - KOUNT=KOUNT+1 - TAIL=>NULL() - IF(ASSOCIATED(HEAD%NEXT_LINK))THEN - TAIL=>HEAD%NEXT_LINK !<-- If another link exists, point at it. - ENDIF -! - IF(KOUNT>1)THEN !<-- Do not deallocate the topmost object's memory - DEALLOCATE(HEAD%TASK_ID) - DEALLOCATE(HEAD%IL) - DEALLOCATE(HEAD%JL) - DEALLOCATE(HEAD%NUM_PTS_UPDATE_HZ) - DEALLOCATE(HEAD,stat=ISTAT) !<-- Deallocate the current link. - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to deallocate link #',KOUNT,' in 2-way linked list!' - WRITE(0,*)' Aborting!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - ENDIF -! - IF(ASSOCIATED(TAIL))THEN !<-- If true, another link exists. - HEAD=>TAIL !<-- Reset so that the head is at the new link. - ELSE - EXIT dealloc !<-- No further links exist. - ENDIF -! - ENDDO dealloc -! -!----------------------------------------------------------------------- -!*** Only the top of the list remains. Point at it. -!----------------------------------------------------------------------- -! - HEAD=>CHILD_TASKS_2WAY_UPDATE - HEAD%NEXT_LINK=>NULL() !<-- There is no 'next link' in the list yet. -! -!----------------------------------------------------------------------- -!*** Which if any child tasks will be updating this parent task? -!*** Begin by finding the subdomain limits of each child task on -!*** the parent domain. -!----------------------------------------------------------------------- -! - child_tasks: DO NT=1,NUM_CHILD_TASKS -! -!----------------------------------------------------------------------- -! - ITS_CHILD_ON_PARENT=(CHILD_TASK_LIMITS(1,NT)-CHILD_TASK_LIMITS(1,1))*RECIP_RATIO & !<-- Child task NT's starting I on parent grid - +REAL(I_PARENT_SW) - ITE_CHILD_ON_PARENT=(CHILD_TASK_LIMITS(2,NT)-CHILD_TASK_LIMITS(1,1))*RECIP_RATIO & !<-- Child task NT's ending I on parent grid - +REAL(I_PARENT_SW) -! - JTS_CHILD_ON_PARENT=(CHILD_TASK_LIMITS(3,NT)-CHILD_TASK_LIMITS(3,1))*RECIP_RATIO & !<-- Child task NT's starting J on parent grid - +REAL(J_PARENT_SW) - JTE_CHILD_ON_PARENT=(CHILD_TASK_LIMITS(4,NT)-CHILD_TASK_LIMITS(3,1))*RECIP_RATIO & !<-- Child task NT's ending J on parent grid - +REAL(J_PARENT_SW) -! - CHILD_ISTART_ON_PARENT=ITS_CHILD_ON_PARENT - CHILD_IEND_ON_PARENT =ITE_CHILD_ON_PARENT - CHILD_JSTART_ON_PARENT=JTS_CHILD_ON_PARENT - CHILD_JEND_ON_PARENT =JTE_CHILD_ON_PARENT -! -!----------------------------------------------------------------------- -!*** Find the common parent target points for all averaging stencils. -!----------------------------------------------------------------------- -! - DO N=1,4 !<-- There are 4 averaging stencils; see above. -! - N_STENCIL_0=N_STENCIL_X(N)/2 !<-- Child's delta I,J from parent update pt to edge of -! ! stencil region that will update the parent point. - LIMIT_WEST_H=REAL(I_PARENT_SW) & - +(N_BLEND_CHILD+N_STENCIL_0)*RECIP_RATIO -! - CHILD_ISTART_ON_PARENT=MAX(CHILD_ISTART_ON_PARENT & !<-- - ,ITS_CHILD_ON_PARENT & - ,LIMIT_WEST_H ) -! - LIMIT_EAST_H=REAL(I_PARENT_SW) & - +(IM_CHILD-1-N_BLEND_CHILD-N_STENCIL_0)*RECIP_RATIO -! - CHILD_IEND_ON_PARENT=MIN(CHILD_IEND_ON_PARENT & !<-- - ,ITE_CHILD_ON_PARENT & - ,LIMIT_EAST_H ) -! - LIMIT_SOUTH_H=REAL(J_PARENT_SW) & - +(N_BLEND_CHILD+N_STENCIL_0)*RECIP_RATIO -! - CHILD_JSTART_ON_PARENT=MAX(CHILD_JSTART_ON_PARENT & !<-- - ,JTS_CHILD_ON_PARENT & - ,LIMIT_SOUTH_H ) -! - LIMIT_NORTH_H=REAL(J_PARENT_SW) & - +(JM_CHILD-1-N_BLEND_CHILD-N_STENCIL_0)*RECIP_RATIO -! - CHILD_JEND_ON_PARENT=MIN(CHILD_JEND_ON_PARENT & !<-- - ,JTE_CHILD_ON_PARENT & - ,LIMIT_NORTH_H ) -! - ENDDO -! -!----------------------------------------------------------------------- -!*** Which if any of this parent task's points are updated by -!*** this child's task NT? -!----------------------------------------------------------------------- -! - IF(REAL(ITS)CHILD_ISTART_ON_PARENT-EPS & - .AND. & - REAL(JTS)CHILD_JSTART_ON_PARENT-EPS )THEN -! -!----------------------------------------------------------------------- -!*** Which points on this parent task will be updated by this -!*** child task? See examples of the logic used here in -!*** subroutine CHILD_2WAY_BOOKKEEPING. -!----------------------------------------------------------------------- -! - I1=MAX(ITS,INT(CHILD_ISTART_ON_PARENT+1.-EPS)) !<-- Lower I limit on parent update region by child task NT. - I2=MIN(ITE,INT(CHILD_IEND_ON_PARENT+EPS)) !<-- Upper I limit on parent update region by child task NT. - J1=MAX(JTS,INT(CHILD_JSTART_ON_PARENT+1.-EPS)) !<-- Lower J limit on parent update region by child task NT. - J2=MIN(JTE,INT(CHILD_JEND_ON_PARENT+EPS)) !<-- Upper J limit on parent update region by child task NT. -! - NPTS_PARENT_UPDATE=(I2-I1+1)*(J2-J1+1) -! - IF(NPTS_PARENT_UPDATE<=0)THEN - CYCLE child_tasks !<-- No usable 2-way exchange region on this child task. - ENDIF -! - NTASKS_UPDATE_CHILD=NTASKS_UPDATE_CHILD+1 !<-- Save # of child tasks that send 2-way update -! - IF(NTASKS_UPDATE_CHILD>1)THEN !<-- We need another link in the list. - ALLOCATE(HEAD%NEXT_LINK) !<-- Create the new link - HEAD=>HEAD%NEXT_LINK !<-- Point at the new link. - HEAD%NEXT_LINK=>NULL() !<-- Nullify the link that would follow the new link. -! - ALLOCATE(HEAD%TASK_ID) !<-- - ALLOCATE(HEAD%IL(1:2)) ! Create the components - ALLOCATE(HEAD%JL(1:2)) ! of the new link. - ALLOCATE(HEAD%NUM_PTS_UPDATE_HZ) !<-- - ENDIF -! -!----------------------------------------------------------------------- -!*** In this link of the list save the updating child task's local -!*** rank on its domain as well as the index limits on this parent -!*** task that this child task will update along with the total -!*** number of updated parent task points. -!----------------------------------------------------------------------- -! - HEAD%TASK_ID=NT-1 !<-- Local rank of child task sending 2-way update -! - HEAD%IL(1)=I1 - HEAD%IL(2)=I2 - HEAD%JL(1)=J1 - HEAD%JL(2)=J2 -! - HEAD%NUM_PTS_UPDATE_HZ=NPTS_PARENT_UPDATE -! -!----------------------------------------------------------------------- -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO child_tasks -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PARENT_2WAY_BOOKKEEPING -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE CHILD_2WAY_BOOKKEEPING(I_SW_PARENT_CURRENT & - ,J_SW_PARENT_CURRENT & - ,SPACE_RATIO_MY_PARENT & - ,NUM_FCST_TASKS_PARENT & - ,ITS_PARENT_TASKS & - ,ITE_PARENT_TASKS & - ,JTS_PARENT_TASKS & - ,JTE_PARENT_TASKS & - ,N_BLEND_H & - ,N_BLEND_V & - ,N_STENCIL_H & - ,N_STENCIL_V & - ,N_STENCIL_SFC_H & - ,N_STENCIL_SFC_V & - ,ITS,ITE,JTS,JTE & - ,IDS,IDE,JDS,JDE & -! - ,NTASKS_UPDATE_PARENT & - ,ID_PARENT_UPDATE_TASKS & - ,NPTS_UPDATE_PARENT & - ,I_2WAY_UPDATE & - ,J_2WAY_UPDATE & - ) -! -!----------------------------------------------------------------------- -!*** In 2-way mode each child domain must determine to which parent -!*** tasks and to which points on those tasks update data must be -!*** sent. The method used here is taking the mean of the points -!*** on a stencil of child points that surround a given parent -!*** point. -!*** This routine is called from CHILDREN_SEND_PARENTS_2WAY_DATA. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: I_SW_PARENT_CURRENT & !<-- Child domain SW corner on this parent I - ,J_SW_PARENT_CURRENT & !<-- Child domain SW corner on this parent J - ,N_BLEND_H & !<-- # of nest blending rows for H pts - ,N_BLEND_V & !<-- # of nest blending rows for V pts - ,N_STENCIL_H & !<-- Width of stencil for averaging h to parent H - ,N_STENCIL_V & !<-- Width of stencil for averaging v to parent V - ,N_STENCIL_SFC_H & !<-- Width of stencil for averaging fis,pd to parent H - ,N_STENCIL_SFC_V & !<-- Width of stencil for averaging fis,pd to parent V - ,NUM_FCST_TASKS_PARENT & !<-- # of fcst tasks on this nest's parent - ,SPACE_RATIO_MY_PARENT !<-- Parent-to-child gridspace ratio -! - INTEGER(kind=KINT),DIMENSION(0:NUM_FCST_TASKS_PARENT-1),INTENT(IN) :: & - ITS_PARENT_TASKS & !<-- Starting I on all parent tasks in parent space - ,ITE_PARENT_TASKS & !<-- Ending I on all parent tasks in parent space - ,JTS_PARENT_TASKS & !<-- Starting J on all parent tasks in parent space - ,JTE_PARENT_TASKS !<-- Ending J on all parent tasks in parent space -! - INTEGER(kind=KINT),INTENT(IN) :: IDE,IDS,ITE,ITS & - ,JDE,JDS,JTE,JTS -! - INTEGER(kind=KINT),INTENT(INOUT) :: NTASKS_UPDATE_PARENT !<-- How many parent tasks does this child task update? -! - INTEGER(kind=KINT),DIMENSION(1:4),INTENT(OUT) :: NPTS_UPDATE_PARENT !<-- # of points to update on each parent task subdomain -! - INTEGER(kind=KINT),DIMENSION(1:4),INTENT(OUT) :: & - ID_PARENT_UPDATE_TASKS !<-- Local ID in P-C intracom of parent tasks to update -! - TYPE(INTEGER_DATA),DIMENSION(1:4),INTENT(OUT) :: I_2WAY_UPDATE & !<-- I indices of parent points to update - ,J_2WAY_UPDATE !<-- J indices of parent points to update -! -!--------------------- -!*** Local variables -!--------------------- -! - INTEGER(kind=KINT) :: I,ISTAT,J,KOUNT,N,N_BLEND,N_STENCIL_0 & - ,NPTS_PARENT_UPDATE -! - INTEGER(kind=KINT) :: I1,I2,J1,J2 -! - INTEGER(kind=KINT),DIMENSION(1:4) :: N_STENCIL_X -! - REAL(kind=KFPT) :: LIMIT_EAST,LIMIT_NORTH & - ,LIMIT_SOUTH,LIMIT_WEST -! - REAL(kind=KFPT) :: MY_IDE_ON_PARENT,MY_IDS_ON_PARENT & - ,MY_JDE_ON_PARENT,MY_JDS_ON_PARENT & - ,MY_ITE_ON_PARENT,MY_ITS_ON_PARENT & - ,MY_JTE_ON_PARENT,MY_JTS_ON_PARENT -! - REAL(kind=KFPT) :: MY_ISTART_ON_PARENT,MY_IEND_ON_PARENT & - ,MY_JSTART_ON_PARENT,MY_JEND_ON_PARENT -! - REAL(kind=KFPT) :: RECIP_RATIO -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RECIP_RATIO=1./REAL(SPACE_RATIO_MY_PARENT) !<-- Reciprocal of parent-to-child gridspace ratio -! - NTASKS_UPDATE_PARENT=0 !<-- Initialize the # of parent tasks this child task -! ! will update. -!----------------------------------------------------------------------- -!*** The domain blending region must be the same for H and V points -!*** at the current time. -!----------------------------------------------------------------------- -! - N_BLEND=N_BLEND_H -! -!----------------------------------------------------------------------- -!*** What are this child's domain limits in terms of its parent's -!*** grid? -!----------------------------------------------------------------------- -! - MY_IDS_ON_PARENT=REAL(I_SW_PARENT_CURRENT) - MY_IDE_ON_PARENT=REAL(I_SW_PARENT_CURRENT)+(IDE-1)*RECIP_RATIO - MY_JDS_ON_PARENT=REAL(J_SW_PARENT_CURRENT) - MY_JDE_ON_PARENT=REAL(J_SW_PARENT_CURRENT)+(JDE-1)*RECIP_RATIO -! -!----------------------------------------------------------------------- -!*** What are this child task's subdomain integration limits in -!*** terms of its parent's grid? -!----------------------------------------------------------------------- -! - MY_ITS_ON_PARENT=REAL(I_SW_PARENT_CURRENT)+(ITS-IDS)*RECIP_RATIO !<-- Child task starting I in parent grid space - MY_ITE_ON_PARENT=REAL(I_SW_PARENT_CURRENT)+(ITE-IDS)*RECIP_RATIO !<-- Child task ending I in parent grid space - MY_JTS_ON_PARENT=REAL(J_SW_PARENT_CURRENT)+(JTS-JDS)*RECIP_RATIO !<-- Child task starting J in parent grid space - MY_JTE_ON_PARENT=REAL(J_SW_PARENT_CURRENT)+(JTE-JDS)*RECIP_RATIO !<-- Child task ending J in parent grid space -! -!----------------------------------------------------------------------- -!*** We want to limit the child points that can be used for -!*** computing the 2-way data. For now do not use any child -!*** points in the averaging stencil that lie in the child's -!*** boundary blending region. Stencils can vary for h-->H, -!*** v-->V, fis,pd-->H, and fis,pd-->V. Determine the set of -!*** parent target I's and J's common to all the stencils and -!*** use that to ensure that the same parent I,J indices are -!*** used for both H and V variables. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Loop through the four stencils. They will be considered in -!*** this order: h-->H, v-->V, fis,pd-->H, fis,pd-->V where small -!*** letters refer to the child and capitals refer to the parent. -!----------------------------------------------------------------------- -! - N_STENCIL_X(1)=N_STENCIL_H - N_STENCIL_X(2)=N_STENCIL_V - N_STENCIL_X(3)=N_STENCIL_SFC_H - N_STENCIL_X(4)=N_STENCIL_SFC_V -! - MY_ISTART_ON_PARENT=MY_IDS_ON_PARENT !<-- - MY_IEND_ON_PARENT =MY_IDE_ON_PARENT ! | Child domain limits in terms of - MY_JSTART_ON_PARENT=MY_JDS_ON_PARENT ! | the parent I,J. - MY_JEND_ON_PARENT =MY_JDE_ON_PARENT !<-- -! -!----------------------------------------------------------------------- -! - DO N=1,4 !<-- Loop through the four stencils. -! -!----------------------------------------------------------------------- -! - N_STENCIL_0=N_STENCIL_X(N)/2 !<-- Child's delta I,J from parent update pt to -! west/south edge of stencil. - LIMIT_WEST=REAL(MY_IDS_ON_PARENT) & - +(N_BLEND+N_STENCIL_0)*RECIP_RATIO - MY_ISTART_ON_PARENT=MAX(MY_ISTART_ON_PARENT & !<-- Westernmost parent I that this child task - ,MY_ITS_ON_PARENT & ! will update on the parent domain. - ,LIMIT_WEST) -! - LIMIT_EAST=REAL(MY_IDE_ON_PARENT) & - -(N_BLEND+N_STENCIL_0)*RECIP_RATIO - MY_IEND_ON_PARENT=MIN(MY_IEND_ON_PARENT & !<-- Easternmost parent I that this child task - ,MY_ITE_ON_PARENT & ! will update on the parent domain. - ,LIMIT_EAST) -! - LIMIT_SOUTH=REAL(MY_JDS_ON_PARENT) & - +(N_BLEND+N_STENCIL_0)*RECIP_RATIO - MY_JSTART_ON_PARENT=MAX(MY_JSTART_ON_PARENT & !<-- Southernmost parent J that this child task - ,MY_JTS_ON_PARENT & ! will update on the parent domain. - ,LIMIT_SOUTH) -! - LIMIT_NORTH=REAL(MY_JDE_ON_PARENT) & - -(N_BLEND+N_STENCIL_0)*RECIP_RATIO - MY_JEND_ON_PARENT=MIN(MY_JEND_ON_PARENT & !<-- Northernmost parent J that this child task - ,MY_JTE_ON_PARENT & ! will update on the parent domain. - ,LIMIT_NORTH) -! - ENDDO -! -!----------------------------------------------------------------------- -!*** Find how many parent tasks will be updated by this child task -!*** and save their local IDs from the P-C intracommunicator. -!----------------------------------------------------------------------- -! - find: DO N=0,NUM_FCST_TASKS_PARENT-1 -! -!----------------------------------------------------------------------- -! - IF(REAL(ITS_PARENT_TASKS(N))MY_ISTART_ON_PARENT-EPS & - .AND. & - REAL(JTS_PARENT_TASKS(N))MY_JSTART_ON_PARENT-EPS )THEN -! -!----------------------------------------------------------------------- -!*** Now determine which points on each parent task will be updated. -! -! Example 1: The child task's MY_ISTART_ON_PARENT is 10.666667 and -! the parent task's ITS is 10. Then the first parent I -! to be updated by the child task is -! INT(10.66667+1.-EPS)=INT(11.66667-EPS)=11. -! Example 2: The child task's MY_ISTART_ON_PARENT is 10.999999 and -! the parent task's ITS is 10. Then the first parent I -! to be updated by the child task is -! INT(10.999999+1.-EPS)=INT(11.999999-EPS)=11. -! Example 3: The child task's MY_ISTART_ON_PARENT is 11.000001 and -! the parent task's ITS is 10. Then the first parent I -! to be updated by the child task is -! INT(11.000001+1.-EPS)=INT(12.000001-EPS)=11. -! Example 4: The child task's MY_IEND_ON_PARENT is 18.999999 and -! the parent task's ITE is 20. Then the last parent I -! to be updated by the child task is -! INT(18.999999+EPS)=19. -!----------------------------------------------------------------------- -! - I1=MAX(ITS_PARENT_TASKS(N),INT(MY_ISTART_ON_PARENT+1.-EPS)) !<-- Starting parent I to update on parent task N - I2=MIN(ITE_PARENT_TASKS(N),INT(MY_IEND_ON_PARENT+EPS)) !<-- Ending parent I to update on parent task N - J1=MAX(JTS_PARENT_TASKS(N),INT(MY_JSTART_ON_PARENT+1.-EPS)) !<-- Starting parent J to update on parent task N - J2=MIN(JTE_PARENT_TASKS(N),INT(MY_JEND_ON_PARENT+EPS)) !<-- Ending parent J to update on parent task N -! - NPTS_PARENT_UPDATE=(I2-I1+1)*(J2-J1+1) !<-- # of points to update on parent task N -! - IF(NPTS_PARENT_UPDATE<=0)THEN - CYCLE find !<-- No usable 2-way exchange region on this child task. - ENDIF -! - NTASKS_UPDATE_PARENT=NTASKS_UPDATE_PARENT+1 !<-- Count the # of parent tasks to update. -! - IF(NTASKS_UPDATE_PARENT>4)THEN - WRITE(0,11101)NTASKS_UPDATE_PARENT -11101 FORMAT(' Child task is updating ',I3,' parent tasks which is > 4') - WRITE(0,*)' Aborting!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - ID_PARENT_UPDATE_TASKS(NTASKS_UPDATE_PARENT)=N !<-- Local rank of the parent task. -! - NPTS_UPDATE_PARENT(NTASKS_UPDATE_PARENT)=NPTS_PARENT_UPDATE !<-- # of points to update on parent task N -! - IF(ASSOCIATED(I_2WAY_UPDATE(NTASKS_UPDATE_PARENT)%DATA))THEN - DEALLOCATE(I_2WAY_UPDATE(NTASKS_UPDATE_PARENT)%DATA,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,11102)NTASKS_UPDATE_PARENT -11102 FORMAT(' Failed to deallocate I_2WAY_UPDATE(',I1,')%DATA') - WRITE(0,*)' Aborting!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - ENDIF -! - ALLOCATE(I_2WAY_UPDATE(NTASKS_UPDATE_PARENT)%DATA(1:NPTS_UPDATE_PARENT(NTASKS_UPDATE_PARENT)) & - ,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,11103)NTASKS_UPDATE_PARENT -11103 FORMAT(' Failed to allocate I_2WAY_UPDATE(',I1,')%DATA') - WRITE(0,*)' Aborting!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - IF(ASSOCIATED(J_2WAY_UPDATE(NTASKS_UPDATE_PARENT)%DATA))THEN - DEALLOCATE(J_2WAY_UPDATE(NTASKS_UPDATE_PARENT)%DATA,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,11104)NTASKS_UPDATE_PARENT -11104 FORMAT(' Failed to deallocate J_2WAY_UPDATE(',I1,')%DATA') - WRITE(0,*)' Aborting!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - ENDIF -! - ALLOCATE(J_2WAY_UPDATE(NTASKS_UPDATE_PARENT)%DATA(1:NPTS_UPDATE_PARENT(NTASKS_UPDATE_PARENT)) & - ,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,11105)NTASKS_UPDATE_PARENT -11105 FORMAT(' Failed to allocate J_2WAY_UPDATE(',I1,')%DATA') - WRITE(0,*)' Aborting!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! -!----------------------------------------------------------------------- -!*** This child task saves the parent I's and J's it will update -!*** on parent task N which is update task #NTASKS_UPDATE_PARENT). -!*** Recall that NTASKS_UPDATE_PARENT ranges from 1 to 4. -!----------------------------------------------------------------------- -! - KOUNT=0 - DO J=J1,J2 - DO I=I1,I2 - KOUNT=KOUNT+1 - I_2WAY_UPDATE(NTASKS_UPDATE_PARENT)%DATA(KOUNT)=I - J_2WAY_UPDATE(NTASKS_UPDATE_PARENT)%DATA(KOUNT)=J - ENDDO - ENDDO -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO find -! -!----------------------------------------------------------------------- -! - END SUBROUTINE CHILD_2WAY_BOOKKEEPING -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE GENERATE_2WAY_DATA(VAR_CHILD & - ,PD_CHILD & - ,FIS_CHILD & - ,IMS,IME,JMS,JME,NVERT & - ,I_2WAY & - ,J_2WAY & - ,N_STENCIL & - ,N_STENCIL_SFC & - ,NPTS_UPDATE_PARENT & - ,VAR_2WAY & - ,INTERPOLATE_SFC & - ,CHILD_SFC_ON_PARENT & - ) -! -!----------------------------------------------------------------------- -!*** When there is 2-way nesting the children interpolate data in -!*** their domains to gridpoints in their parents' domains. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: IMS,IME,JMS,JME !<-- Child task subdomain horizontal memory dimensions -! - INTEGER(kind=KINT),INTENT(IN) :: N_STENCIL & !<-- Use N_STENCILxN_STENCIL child pts for each parent point - ,N_STENCIL_SFC & !<-- Stencil width for interpolating child FIS,PD to parent - ,NPTS_UPDATE_PARENT & !<-- # of parent points (I,J) updated on given parent task - ,NVERT !<-- Vertical dimension of VAR_CHILD -! - INTEGER(kind=KINT),DIMENSION(1:NPTS_UPDATE_PARENT),INTENT(IN) :: & - I_2WAY & !<-- Child I on each parent update point (H or V) - ,J_2WAY !<-- Child J on each parent update point (H or V) -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: FIS_CHILD & !<-- The child's sfc geopotential - ,PD_CHILD !<-- The child's PD array -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME,1:NVERT),INTENT(IN) :: & - VAR_CHILD !<-- The child array of the 3-D update variable -! - REAL(kind=KFPT),DIMENSION(1:NPTS_UPDATE_PARENT,1:2),INTENT(OUT) :: & - CHILD_SFC_ON_PARENT !<-- Child's FIS,PD interpolated to parent update points -! - REAL(kind=KFPT),DIMENSION(1:NPTS_UPDATE_PARENT*NVERT),INTENT(OUT) :: & - VAR_2WAY !<-- 2-way variable interp'd from child grid to parent's -! - LOGICAL(kind=KLOG),INTENT(IN) :: INTERPOLATE_SFC !<-- Should FIS,PD be interpolated this call? -! -!--------------------- -!*** Local variables -!--------------------- -! - INTEGER(kind=KINT),SAVE :: KNT_PTS -! - INTEGER(kind=KINT) :: I,IC,J,JC,KNT_PTS_HORZ,L & - ,N_STENCIL_0,N_STENCIL_TOT,NP -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: I_START,I_END & - ,J_START,J_END -! - REAL(kind=KFPT) :: FIS_SUM,PD_SUM,RECIP_N_STENCIL_TOT,VSUM -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - N_STENCIL_0=N_STENCIL/2 !<-- 2->1; 3->1; 4->2; 5->2, etc. - N_STENCIL_TOT=N_STENCIL*N_STENCIL !<-- # of points in the stencil - RECIP_N_STENCIL_TOT=1./REAL(N_STENCIL_TOT) !<-- Reciprocal of # of points in the stencil -! -!----------------------------------------------------------------------- -!*** Parent-child gridspace ratios can be any positive integer (>1 of -!*** course). On the B-grid a child H point will lie on a parent H -!*** point no matter what the ratio is. A child V point will lie on -!*** a parent V point only for odd values of the parent-child gridspace -!*** ratio. If the ratio is even then child H points will lie on -!*** parent V points. The I,J of the child H point on the parent -!*** V point in that case will be the same as the child V point's -!*** immediately to the NE on the B grid. This implies that the -!*** stencil will always be even (2x2, 4x4, etc) for interpolating -!*** to parent V points when the gridspace ratio is even while it -!*** will be odd (3x3, 5x5, etc.) for all other cases. The previous -!*** statement is true for stencils that are oriented north-south. -!*** New code will need to be added if stencils rotated 45 degrees -!*** are desired. -! -!*** The diagram below exemplifies odd and even ratios. The capital -!*** letters are parent gridpoints and the small letters are child -!*** gridpoints. -!----------------------------------------------------------------------- -! -! Parent-child Parent-child -! gridspace ratio gridspace ratio -! is odd (3) is even (2) -! -! -! Hh h h Hh Hh h Hh -! -! v v v -! v v -! h h h h -! -! v Vv v h Vh h -! -! h h h h -! v v -! v v v -! -! Hh h h Hh Hh h Hh -! -! -! -! Child h points lie on parent H Child h points lie on parent H -! points and child v points lie points but child h points also -! on parent V points. lie on parent V points. -! -! -!----------------------------------------------------------------------- -!*** Recall that the I,J of a V point on the B grid is the same as -!*** that of the neighboring H point to the southwest. Therefore -!*** from the diagrams above one can see that if a child point I,J -!*** coincides with a parent point to be interpolated to then -!*** the SW corner of the interpolation stencil will always be -!*** at I-N_STENCIL_0, J-N_STENCIL_0 where N_STENCIL_0 is equal to -!*** N_STENCIL/2 (integer division). -!----------------------------------------------------------------------- -! - ALLOCATE(I_START(1:NPTS_UPDATE_PARENT)) - ALLOCATE(I_END (1:NPTS_UPDATE_PARENT)) - ALLOCATE(J_START(1:NPTS_UPDATE_PARENT)) - ALLOCATE(J_END (1:NPTS_UPDATE_PARENT)) -! - DO NP=1,NPTS_UPDATE_PARENT !<-- Loop through this parent task subdomain's update points -! - IC=I_2WAY(NP) !<-- Child I at parent's NP'th update point - I_START(NP)=IC-N_STENCIL_0 !<-- Child I on west side of averaging stencil - I_END(NP) =I_START(NP)+N_STENCIL-1 !<-- Child I on east side of averaging stencil -! - JC=J_2WAY(NP) !<-- Child J at parent's NP'th update point - J_START(NP)=JC-N_STENCIL_0 !<-- Child J on south side of averaging stencil - J_END(NP) =J_START(NP)+N_STENCIL-1 !<-- Child J on north side of averaging stencil -! - ENDDO -! -!----------------------------------------------------------------------- -!*** This child task loops through the parent points for which it is -!*** responsible on the given parent task. -!----------------------------------------------------------------------- -! - KNT_PTS=0 - DO L=1,NVERT -! - DO NP=1,NPTS_UPDATE_PARENT !<-- Loop over update points on the given parent task -! - VSUM=0. -! - DO J=J_START(NP),J_END(NP) - DO I=I_START(NP),I_END(NP) - VSUM=VSUM+VAR_CHILD(I,J,L) !<-- Sum the variable over the averaging stencil for - ENDDO ! parent point NP. - ENDDO -! - KNT_PTS=KNT_PTS+1 - VAR_2WAY(KNT_PTS)=VSUM*RECIP_N_STENCIL_TOT !<-- Child's update value at parent point stored as 1-D -! - ENDDO -! - ENDDO -! -!----------------------------------------------------------------------- -!*** The child interpolates its sfc geopotential and sfc pressure -!*** to the parent points to be updated as it did for the primary -!*** prognostic variables. If either the parent's sfc geopotential -!*** or the child's interpolated sfc geopotential is above sea level -!*** then the parent will interpolate vertically the update values -!*** received from the child to account for differences in the -!*** domains' topographies. -!*** Note that the value of N_STENCIL_0 (the distance in I or J -!*** from the child I,J lying on the target parent H or V point to -!*** the west/south edge of the stencil) is different than above -!*** since now child H-pt values (FIS,PD) are always being averaged -!*** onto both H and V parent points. -!----------------------------------------------------------------------- -! - IF(INTERPOLATE_SFC)THEN -! - N_STENCIL_0=(N_STENCIL_SFC+1)/2-1 !<-- 2-->0; 3-->1; 4-->1; 5-->2, etc. - N_STENCIL_TOT=N_STENCIL_SFC*N_STENCIL_SFC !<-- # of points in the sfc stencil - RECIP_N_STENCIL_TOT=1./REAL(N_STENCIL_TOT) !<-- Reciprocal of # of points in the sfc stencil -! - KNT_PTS_HORZ=0 -! - DO NP=1,NPTS_UPDATE_PARENT !<-- Loop over update points on the given parent task -! - PD_SUM=0. - FIS_SUM=0. -! - IC=I_2WAY(NP) !<-- Child I at parent's NP'th update point - I_START(NP)=IC-N_STENCIL_0 !<-- Child I on west side of sfc averaging stencil - I_END(NP) =I_START(NP)+N_STENCIL_SFC-1 !<-- Child I on east side of sfc averaging stencil -! - JC=J_2WAY(NP) !<-- Child J at parent's NP'th update point - J_START(NP)=JC-N_STENCIL_0 !<-- Child J on south side of sfc averaging stencil - J_END(NP) =J_START(NP)+N_STENCIL_SFC-1 !<-- Child J on north side of sfc averaging stencil -! - DO J=J_START(NP),J_END(NP) - DO I=I_START(NP),I_END(NP) - PD_SUM=PD_SUM+PD_CHILD(I,J) - FIS_SUM=FIS_SUM+FIS_CHILD(I,J) - ENDDO - ENDDO -! - KNT_PTS_HORZ=KNT_PTS_HORZ+1 - CHILD_SFC_ON_PARENT(KNT_PTS_HORZ,1)=FIS_SUM*RECIP_N_STENCIL_TOT !<-- Child's mean sfc geopotential within stencil - CHILD_SFC_ON_PARENT(KNT_PTS_HORZ,2)=PD_SUM*RECIP_N_STENCIL_TOT !<-- Child's mean PD within stencil -! - ENDDO -! - ENDIF -! -!----------------------------------------------------------------------- -! - DEALLOCATE(I_START) - DEALLOCATE(I_END) - DEALLOCATE(J_START) - DEALLOCATE(J_END) -! -!----------------------------------------------------------------------- -! - END SUBROUTINE GENERATE_2WAY_DATA -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- - SUBROUTINE SPLINE(NOLD,XOLD,YOLD,Y2,Y2_K,NNEW,XNEW,YNEW) -!----------------------------------------------------------------------- -! -! ****************************************************************** -! * * -! * This is a one-dimensional cubic spline fitting routine * -! * programmed for a small scalar machine. * -! * * -! * Programmer: Z. Janjic, Yugoslav Fed. Hydromet. Inst., Beograd * -! * * -! * NOLD - Number of given values of the function. Must be >= 3. * -! * XOLD - Locations of the points at which the values of the * -! * function are given. Must be in ascending order. * -! * YOLD - The given values of the function at the points XOLD. * -! * Y2 - The second derivatives at the points XOLD. If natural * -! * spline is fitted Y2(1)=0 and Y2(nold)=0. Must be * -! * specified. * -! * Y2_K - Vertical dimension of Y2 array. * -! * NNEW - Number of values of the function to be calculated. * -! * XNEW - Locations of the points at which the values of the * -! * function are calculated. XNEW(K) must be >= XOLD(1) * -! * and <= XOLD(NOLD). * -! * YNEW - The values of the function to be calculated. * -! * * -! ****************************************************************** -! -!----------------------------------------------------------------------- -!*** Arguments -!----------------------------------------------------------------------- -! - INTEGER,INTENT(IN) :: NNEW,NOLD,Y2_K -! - REAL,DIMENSION(1:NOLD),INTENT(IN) :: XOLD,YOLD - REAL,DIMENSION(1:NNEW),INTENT(IN) :: XNEW -! - REAL,DIMENSION(1:Y2_K),INTENT(INOUT) :: Y2 -! - REAL,DIMENSION(1:NNEW),INTENT(OUT) :: YNEW -! -!----------------------------------------------------------------------- -!*** Local Variables -!----------------------------------------------------------------------- -! - INTEGER :: K,K1,K2,KOLD,NOLDM1 -! - REAL :: AK,BK,CK,DEN,DX,DXC,DXL,DXR,DYDXL,DYDXR,RDX,RTDXC & - ,X,XK,XSQ,Y2K,Y2KP1 -! - REAL,DIMENSION(1:NOLD-2) :: P,Q -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - NOLDM1=NOLD-1 -! - DXL=XOLD(2)-XOLD(1) - DXR=XOLD(3)-XOLD(2) - DYDXL=(YOLD(2)-YOLD(1))/DXL - DYDXR=(YOLD(3)-YOLD(2))/DXR - RTDXC=0.5/(DXL+DXR) -! - P(1)= RTDXC*(6.*(DYDXR-DYDXL)-DXL*Y2(1)) - Q(1)=-RTDXC*DXR -! - IF(NOLD==3) GO TO 700 -! -!----------------------------------------------------------------------- - K=3 -! - 100 CONTINUE - DXL=DXR - DYDXL=DYDXR - DXR=XOLD(K+1)-XOLD(K) - DYDXR=(YOLD(K+1)-YOLD(K))/DXR - DXC=DXL+DXR - DEN=1./(DXL*Q(K-2)+DXC+DXC) -! - P(K-1)= DEN*(6.*(DYDXR-DYDXL)-DXL*P(K-2)) - Q(K-1)=-DEN*DXR -! - K=K+1 - IF(K1) GO TO 200 -! -!----------------------------------------------------------------------- -! - K1=1 -! - 300 CONTINUE - XK=XNEW(K1) -! - DO 400 K2=2,NOLD - IF(XOLD(K2)<=XK) GO TO 400 - KOLD=K2-1 - GO TO 450 - 400 CONTINUE -! - YNEW(K1)=YOLD(NOLD) - GO TO 600 -! - 450 CONTINUE - IF(K1==1) GO TO 500 - IF(K==KOLD) GO TO 550 -! - 500 CONTINUE - K=KOLD -! - Y2K=Y2(K) - Y2KP1=Y2(K+1) - DX=XOLD(K+1)-XOLD(K) - RDX=1./DX -! - AK=0.1666667*RDX*(Y2KP1-Y2K) - BK=0.5*Y2K - CK=RDX*(YOLD(K+1)-YOLD(K))-0.1666667*DX*(Y2KP1+Y2K+Y2K) -! - 550 CONTINUE - X=XK-XOLD(K) - XSQ=X*X -! - YNEW(K1)=AK*XSQ*X+BK*XSQ+CK*X+YOLD(K) -! - 600 CONTINUE - K1=K1+1 -! - IF(K1<=NNEW) GO TO 300 -! -!----------------------------------------------------------------------- -! - END SUBROUTINE SPLINE -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE HYPERBOLA(A) -! -!----------------------------------------------------------------------- -!*** Generate a hyperbola that will reduce the magnitude of the -!*** source domain's underground extrapolation in those instances -!*** when the target domain's ground surface lies below the source -!*** domain's. The hyperbola has the formula: -! -! Y=A/(X+A) -! -!*** The value of Y is the fraction between 1 and 0 that provides -!*** the reduction in the amount added to the source domain's lowest -!*** layer value to account for the extrapolation underground. -!*** The value of X is the difference in pressure (Pa) between the -!*** source domain's lowest pressure level and the target pressure -!*** of the extrapolation. When the pressure difference is zero then -!*** there is no reduction in the source domain's extrapolation and -!*** so the value of Y is 1.0. For very large extrapolations then -!*** the amount added to the source domain's lowest layer value to -!*** account for the extrapolation is reduced by a factor approaching -!*** zero. -!*** The formula gives the user 1 degree of freedom. Specify one -!*** extrapolated underground pressure depth and the amount desired -!*** for the reduction in the linear extrapolation of the source -!*** domain's lowest layer value through that depth. -!*** For example, if X1=10000.0 and Y1=0.05 then when the lowest -!*** layer value in the source domain is linearly extrapolated -!*** through an underground depth of 10000 Pa then the amount added -!*** to that lowest layer value to account for the extrapolation is -!*** first multiplied by 0.05. -!----------------------------------------------------------------------- -! - REAL(kind=KDBL),PARAMETER :: X1=10000.0, Y1=0.05 -! -!------------------------ -!*** Argument Variables -!------------------------ -! - REAL(kind=KDBL),INTENT(OUT) :: A !<-- Constant in the hyperbola Y=A/(X+A) -! -!--------------------- -!*** Local Variables -!--------------------- -! - REAL(kind=KDBL) :: F,G,H,DISCRIM,PROD1,PROD2 -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - A=(X1*Y1)/(1.-Y1) -! -!----------------------------------------------------------------------- -! - END SUBROUTINE HYPERBOLA -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE CHECK_REAL(P_IN,NAME) -! -!----------------------------------------------------------------------- -!*** Check the status of pointer P_IN and deallocate or nullify. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - REAL(kind=KFPT),DIMENSION(:),POINTER,INTENT(INOUT) :: P_IN -! - CHARACTER(len=*),INTENT(IN) :: NAME -! -!-------------------- -!*** Local Variables -!-------------------- -! - INTEGER(kind=KINT) :: ISTAT -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - IF(ASSOCIATED(P_IN))THEN - DEALLOCATE(P_IN,stat=ISTAT) - IF(ISTAT/=0)THEN - NULLIFY(P_IN) - WRITE(0,*)NAME,' was associated but not allocated. ' & - ,' It has now been nullified.' - ELSE - WRITE(0,*)' Forced to deallocate ',NAME - ENDIF - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE CHECK_REAL -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE CHECK(RC) -! - IMPLICIT NONE -! - INTEGER,INTENT(IN) :: RC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - IF(RC/=NF90_NOERR)THEN - WRITE(*,*)TRIM(ADJUSTL(NF90_STRERROR(RC))) -! WRITE(0,11101)RC -11101 FORMAT(' ERROR: RC=',I5) - ENDIF -! - END SUBROUTINE CHECK -! -!----------------------------------------------------------------------- -! - END MODULE MODULE_NESTING -! -!----------------------------------------------------------------------- diff --git a/src/nmm/module_NMM_GRID_COMP.F90 b/src/nmm/module_NMM_GRID_COMP.F90 deleted file mode 100644 index c98da25..0000000 --- a/src/nmm/module_NMM_GRID_COMP.F90 +++ /dev/null @@ -1,7141 +0,0 @@ -!----------------------------------------------------------------------- -! - MODULE module_NMM_GRID_COMP -! -!----------------------------------------------------------------------- -!*** This is the NMM-B module. It will set up one or more Domain -!*** subcomponents then execute their Initialize, Run, and Finalize -!*** steps. -!----------------------------------------------------------------------- -! -! PROGRAM HISTORY LOG: -! 2011-02 W. Yang - Updated to use both the ESMF 4.0.0rp2 library, -! ESMF 5 library and the the ESMF 3.1.0rp2 library. -! 2011-05 W. Yang - Modified for using the ESMF 5.2.0r_beta_snapshot_07. -! 2011-07 Black - Modified for moving nests. -! 2011-09 W. Yang - Modified for using the ESMF 5.2.0r library. -! 2012-07 Black - Modified for 'generational' task usage. -! 2015-09 Fei Liu - Modified for use with NUOPC driver. -!----------------------------------------------------------------------- -! - USE MPI - USE ESMF - USE NUOPC -! - USE module_KINDS -! - USE module_DOMAIN_NUOPC_SET,ONLY: DOMAIN_DESCRIPTORS & - ,I_AM_PET & - ,I_AM_ROOT & - ,NMMB_CreateDomainFields & - ,NMMB_CreateRouteHandle & - ,NMMB_GridCreate -! - USE module_NMM_INTERNAL_STATE,ONLY: NMM_INTERNAL_STATE & - ,WRAP_NMM_INTERNAL_STATE -! - USE module_DOMAIN_GRID_COMP,ONLY: DOMAIN_REGISTER !<-- The Register routine for DOMAIN_GRID_COMP -! - USE module_DOMAIN_INTERNAL_STATE,ONLY: DOMAIN_INTERNAL_STATE & - ,WRAP_DOMAIN_INTERNAL_STATE -! - USE module_DOMAIN_TASK_SPECS,ONLY: DOMAIN_TASK_SPECS -! - USE module_NMM_INTEGRATE,ONLY: NMM_INTEGRATE -! - USE module_DERIVED_TYPES,ONLY: COMMS_FAMILY & - ,CTASK_LIMITS & - ,HANDLE_CHILD_LIMITS & - ,HANDLE_CHILD_TOPO_S & - ,HANDLE_CHILD_TOPO_N & - ,HANDLE_CHILD_TOPO_W & - ,HANDLE_CHILD_TOPO_E & - ,HANDLE_I_SW & - ,HANDLE_J_SW & - ,HANDLE_PACKET_S_H & - ,HANDLE_PACKET_S_V & - ,HANDLE_PACKET_N_H & - ,HANDLE_PACKET_N_V & - ,HANDLE_PACKET_W_H & - ,HANDLE_PACKET_W_V & - ,HANDLE_PACKET_E_H & - ,HANDLE_PACKET_E_V & - ,HANDLE_PARENT_DOM_LIMITS & - ,HANDLE_PARENT_ITE & - ,HANDLE_PARENT_ITS & - ,HANDLE_PARENT_JTE & - ,HANDLE_PARENT_JTS & - ,INFO_SEND & - ,PTASK_LIMITS -! - USE module_NESTING,ONLY: PARENT_CHILD_COMMS -! - USE module_PARENT_CHILD_CPL_COMP,ONLY: PARENT_CHILD_CPL_REGISTER & !<-- The Register routine for PARENT_CHILD Coupler - ,PARENT_CHILD_COUPLER_SETUP -! - USE module_CONTROL,ONLY: NUM_DOMAINS_MAX,TIMEF -! - USE module_CLOCKTIMES,ONLY: TIMERS & - ,cbcst_tim,pbcst_tim -! - USE module_ERROR_MSG,ONLY: ERR_MSG,MESSAGE_CHECK -! - USE MODULE_SOLVER_GRID_COMP,ONLY: RESTVAL -! - USE module_CONSTANTS,ONLY: A -! - USE module_CPLFIELDS,ONLY: exportFieldsList,importFieldsList & - ,queryFieldList -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: NMM_REGISTER - PUBLIC :: EXPORT_FIELDS_INDX & - ,NUM_DOMAINS_TOTAL,nExportFields_NMMB,NMM_GRID -! -!----------------------------------------------------------------------- -! - INTEGER(kind=KINT) :: MYPE & !<-- Each MPI task ID - ,NHOURS_CLOCKTIME !<-- Fcst hours between prints of integration clocktime -! - INTEGER(kind=KINT) :: FILT_TIMESTEP_SEC_WHOLE & - ,FILT_TIMESTEP_SEC_NUMERATOR & - ,FILT_TIMESTEP_SEC_DENOMINATOR & - ,TIMESTEP_SEC_WHOLE & - ,TIMESTEP_SEC_NUMERATOR & - ,TIMESTEP_SEC_DENOMINATOR & - ,TIMESTEPS_RESTART -! - INTEGER(kind=KINT),SAVE :: COMM_GLOBAL & !<-- The MPI communicator for all tasks (COMM_WORLD) - ,FILTER_METHOD !<-- Digital filter flag (0->no filter; >0->filter type) -! - INTEGER(kind=KINT),POINTER :: COMM_TO_MY_PARENT & !<-- Intercommunicator between a domain and its parent - ,NPE_PRINT !<-- Clocktime diagnostics from this MPI task -! - REAL(kind=KFPT),SAVE :: TLM0D,TPH0D !<-- Central geographic lon/lat (degrees) of primary domain. -! - REAL(kind=KFPT),DIMENSION(:),ALLOCATABLE,SAVE :: DT & !<-- Each domain's fundamental timestep - ,FILT_DT !<-- Filter timestep (s) of the domains -! - CHARACTER(ESMF_MAXSTR) :: ALARM_CPL_NAME & !<-- Name of the ESMF Alarms for coupling intervals - ,CLOCK_NMM_NAME !<-- Name of the NMM's ESMF Clock -! - LOGICAL(kind=KLOG) :: PRINT_TIMING !<-- Print timing flag -! - LOGICAL(kind=KLOG),POINTER :: RESTARTED_RUN & !<-- Flag indicating if this is a restarted run - ,RST_OUT_00 !<-- Shall we write 00h history in restarted run? -! - TYPE(ESMF_VM),SAVE :: VM !<-- The ESMF virtual machine. -! - TYPE(ESMF_Time),SAVE :: STARTTIME !<-- The ESMF start time. -! - TYPE(ESMF_TimeInterval),SAVE :: INTERVAL_CPL & !<-- The NUOPC coupling interval (sec ESMF) - ,RUNDURATION !<-- The simulation length (sec ESMF) -! - TYPE(ESMF_TimeInterval),POINTER :: FILT_TIMESTEP & !<-- ESMF filter timestep (s) - ,INTERVAL_CLOCKTIME & !<-- ESMF time interval between clocktime prints (h) - ,INTERVAL_HISTORY & !<-- ESMF time interval between history output (h) - ,INTERVAL_RESTART & !<-- ESMF time interval between restart output (h) - ,TIMESTEP !<-- The ESMF timestep (s) -! - TYPE(ESMF_Alarm),DIMENSION(:),ALLOCATABLE,SAVE :: ALARM_CPL !<-- The ESMF Alarms for the coupling interval -! - TYPE(ESMF_Clock),DIMENSION(:),ALLOCATABLE,SAVE :: CLOCK_NMM !<-- The NMM ESMF Clocks -! - TYPE(ESMF_GridComp),POINTER :: DOMAIN_GRID_COMP !<-- A domain's ESMF component -! - TYPE(ESMF_State),POINTER :: EXP_STATE_DOMAIN & !<-- A domain's export state - ,IMP_STATE_DOMAIN !<-- A domain's import state -! - TYPE(NMM_INTERNAL_STATE),POINTER,SAVE :: NMM_INT_STATE !<-- The NMM component internal state pointer -! - INTEGER(kind=KINT),DIMENSION(:),POINTER,SAVE :: & - RANK_TO_DOMAIN_ID_PTR !<-- Save converter for runtime timestep retrieval -! - TYPE(WRAP_NMM_INTERNAL_STATE),SAVE :: WRAP !<-- The F90 wrap of the NMM internal state -! -! -!--------------------- -!*** For NMM Nesting -!--------------------- -! - INTEGER(kind=KINT),PARAMETER :: nExportFields_NMMB=7 !<-- The # of fields to regrid from the full export field list -! - INTEGER(kind=KINT),SAVE :: NUM_DOMAINS_TOTAL -! - INTEGER(kind=KINT) :: KOUNT_STEPS=0 & - ,NUM_GENS=1 !<-- The # of generations of domains (only for 2-way nests) -! - INTEGER(kind=KINT) :: COMM_MY_DOMAIN & !<-- Each domain's local intracommunicator - ,FULL_GEN & !<-- The 1st generation of domains that uses all fcst tasks - ,MY_DOMAIN_ID & !<-- The ID of each domain - ,NPHS & !<-- The physics timestep - ,NTRACK & !<-- The storm locator flag - ,NUM_DOMAINS_MINE !<-- The # of domains on which each task resides -! - INTEGER(kind=KINT),POINTER :: NUM_CHILDREN & !<-- # of children on a domain - ,NUM_2WAY_CHILDREN & !<-- # of 2-way children on a domain - ,PARENT_CHILD_TIME_RATIO !<-- Ratio of parent timestep to child's -! - INTEGER(kind=KINT),DIMENSION(nExportFields_NMMB),SAVE :: & - EXPORT_FIELDS_INDX !<-- Index of the desired export fields from the full list -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: DOMAIN_GEN & !<-- The generation of each domain - ,MY_DOMAIN_IDS & !<-- All domains on which each task resides - ,MY_DOMAINS_IN_GENS !<-- List a task's domain on each generation -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: ID_DOMAINS & !<-- IDs of all domains - ,ID_PARENTS & !<-- IDs of all domains' parents - ,FTASKS_DOMAIN & !<-- # of forecast tasks on each domain excluding descendents - ,NTASKS_DOMAIN !<-- # of tasks on each domain excluding descendents -! - INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: ID_CHILDREN & !<-- IDs of all children of all domains - ,PETLIST_DOMAIN !<-- List of task IDs for each domain (DOMAIN Component) -! - CHARACTER(len=12),SAVE :: TASK_MODE !<-- Task assignments are unique or generational -! - CHARACTER(len=5) :: NEST_MODE !<-- Is the nesting 1-way or 2-way with the parent? -! - CHARACTER(len=40),DIMENSION(nExportFields_NMMB) :: EXPORT_FIELDS_BLEND & - =(/ & - 'mean_zonal_moment_flx' & - ,'mean_merid_moment_flx' & - ,'inst_sensi_heat_flx' & - ,'inst_laten_heat_flx' & - ,'inst_net_lw_flx' & - ,'inst_net_sw_flx' & - ,'inst_pres_height_surface' & - /) -! - LOGICAL(kind=KLOG),SAVE :: ALL_FORECASTS_COMPLETE=.FALSE. & !<-- Are this task's domains' fcsts all finished? - ,NESTING_NMM !<-- Does this run contain nests? -! - LOGICAL(kind=KLOG) :: MY_DOMAIN_MOVES !<-- Does my domain move? -! - LOGICAL(kind=KLOG),POINTER :: I_AM_A_FCST_TASK & !<-- Am I a forecast task? - ,I_AM_LEAD_FCST_TASK & !<-- Am I the lead forecast task? - ,I_AM_A_NEST !<-- Am I in a nested domain? -! - LOGICAL(kind=KLOG),DIMENSION(:),ALLOCATABLE,SAVE :: FREE_TO_INTEGRATE & !<-- A yes/no flag for 2-way domains calling DOMAIN_RUN - ,GENERATION_FINISHED !<-- Flag of when forecast is done per generation -! - TYPE(COMMS_FAMILY),DIMENSION(:),POINTER :: COMMS_DOMAIN !<-- Intracommunicators between parents and children - ! and between each domains' forecast tasks -! - TYPE(ESMF_Config),DIMENSION(NUM_DOMAINS_MAX),SAVE :: CF !<-- The config objects (one per domain) -! - TYPE(ESMF_State),POINTER :: IMP_STATE_CPL_NEST & - ,EXP_STATE_CPL_NEST -! - TYPE(ESMF_CplComp),POINTER :: PARENT_CHILD_COUPLER_COMP !<-- Coupler component for parent-child/nest exchange -! -!----------------------------------------------------------------------- -! -!--------------------------- -!*** For Digital Filtering -!--------------------------- -! - INTEGER(kind=KINT),PUBLIC :: DFIHR,DFIHR_CHK -! - TYPE(ESMF_Time),SAVE,PUBLIC :: DFITIME -! -!----------------------------------------------------------------------- -! -!----------- -!*** Timing -!----------- -! - REAL(kind=KDBL) :: btim,btim0 -! -!----------------------------------------------------------------------- -! - character(len=160) :: nuopcMsg - type fld_list_type - character(len=64) :: stdname - character(len=64) :: shortname - character(len=64) :: transferOffer - logical :: assoc ! is the farrayPtr associated with internal data - real(ESMF_KIND_R8), dimension(:,:,:), pointer :: farrayPtr - end type fld_list_type - - integer,parameter :: fldsMax = 100 - integer :: fldsToNMMB_num = 0 - type (fld_list_type) :: fldsToNMMB(fldsMax) - integer :: fldsFrNMMB_num = 0 - type (fld_list_type) :: fldsFrNMMB(fldsMax) - character(len=2048):: info - type(ESMF_Grid), save :: nmm_grid - -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE NMM_REGISTER(NMM_GRID_COMP,RC_REG) -! -!----------------------------------------------------------------------- -!*** Register the NMM component's Initialize, Run, and Finalize steps. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_GridComp) :: NMM_GRID_COMP !<-- The NMM component -! - INTEGER,INTENT(OUT) :: RC_REG -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER :: RC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS ! Error signal variable - RC_REG=ESMF_SUCCESS ! Error signal variable -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Register the NMM Initialize routine" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSetEntryPoint(NMM_GRID_COMP & - ,ESMF_METHOD_INITIALIZE & - ,NMM_INITIALIZE & - ,phase=1 & - ,rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Register the NMM Run routine" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSetEntryPoint(NMM_GRID_COMP & - ,ESMF_METHOD_RUN & - ,NMM_RUN & - ,phase=1 & - ,rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Register the NMM Finalize routine" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSetEntryPoint(NMM_GRID_COMP & - ,ESMF_METHOD_FINALIZE & - ,NMM_FINALIZE & - ,phase=1 & - ,rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - IF(RC_REG==ESMF_SUCCESS)THEN -! WRITE(0,*)' NMM_REGISTER succeeded' - ELSE - WRITE(0,*)' NMM_REGISTER failed RC_REG=',RC_REG - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE NMM_REGISTER -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE NMM_INITIALIZE(NMM_GRID_COMP & - ,IMP_STATE & - ,EXP_STATE & - ,CLOCK_NEMS & - ,RC_INIT) -! -!----------------------------------------------------------------------- -!*** This routine creates the individual DOMAIN gridded components -!*** and executes their Initialize step. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_GridComp) :: NMM_GRID_COMP !<-- The NMM component -! - TYPE(ESMF_State) :: IMP_STATE & !<-- The NMM import state - ,EXP_STATE !<-- The NMM export state -! - TYPE(ESMF_Clock) :: CLOCK_NEMS !<-- The NEMS ESMF Clock -! - INTEGER,INTENT(OUT) :: RC_INIT !<-- Error return code -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: ID,ID_DOM,ID_X,IERR,INDX2,ISTAT,KOUNT & - ,N,N1,N2,N3,NN,NT -! - INTEGER(kind=KINT) :: MINUTES_HISTORY & !<-- Hours between history output - ,MINUTES_RESTART & !<-- Hours between restart output - ,NHOURS_FCST & !<-- Length of forecast in hours - ,NSECONDS_FCST & !<-- Length of forecast in seconds - ,TIMESTEP_FINAL !<-- # of timesteps in entire forecast -! - INTEGER(kind=KINT) :: ISECOND_FCST,ISECOND_NUM,ISECOND_DEN -! - INTEGER(kind=KINT) :: GEN_X,INPES,JNPES,LEAD_TASK & - ,LENGTH,LENGTH_FCST,LENGTH_FCST_1 & - ,MAX_GEN,MY_DOMAIN_ID,MYPE_LOCAL,MYPE_X & - ,N_GEN,N_TASKS,NUM_CHILD_TASKS & - ,NUM_DOMAINS_X,NUM_FCST_TASKS & - ,NUM_WRITE_TASKS,NUM_TASKS_TOTAL & - ,WRITE_GROUPS,WRITE_TASKS_PER_GROUP -! - INTEGER(kind=KINT) :: RC -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: MY_DOMAIN_ID_N !<-- Domain IDs for each task among all domains -! - INTEGER(kind=KINT),DIMENSION(NUM_DOMAINS_MAX) :: DOMAIN_ID_TO_RANK=0 & !<-- The configure file associated with each domain ID - ,RANK_TO_DOMAIN_ID=0 !<-- The domain ID associated with each configure file -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: N_FCST_TASKS_GEN !<-- The # of fcst tasks in each geenration -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: CHILD_ID & - ,COMM_TO_MY_CHILDREN & !<-- Intercommunicators between a domain and its children - ,PETLIST -! - INTEGER,DIMENSION(MPI_STATUS_SIZE) :: JSTAT -! - REAL(kind=KFPT) :: TIMESTEP_RATIO -! - LOGICAL(kind=KLOG) :: CFILE_EXIST & - ,QUILTING,QUILTING_1 & - ,USED_ALL_FCST_TASKS -! - CHARACTER(2) :: INT_TO_CHAR - CHARACTER(6) :: FMT='(I2.2)' - CHARACTER(7) :: MODE - CHARACTER(NUM_DOMAINS_MAX) :: CONFIG_FILE_NAME -! - CHARACTER(ESMF_MAXSTR) :: DOMAIN_COMP_BASE='DOMAIN Gridded Component ' & - ,DOMAIN_GRID_COMP_NAME,STATE_NAME -! - TYPE(ESMF_TimeInterval) :: COUPLING_INTERVAL !<-- ESMF time interval (sec) between coupling times - TYPE(ESMF_TimeInterval) :: TIMEINTERVAL_RECV_FROM_PARENT !<-- ESMF time interval between Recv times from parent - TYPE(ESMF_TimeInterval) :: ZERO_INTERVAL !<-- Zero time interval used in comparison of time step -! ! and restart interval. - LOGICAL :: PHYSICS_ON !<-- Does the integration include physics? - - TYPE(ESMF_Config) :: CF_X !<-- Working config object -! - TYPE(ESMF_Grid) :: pGrid_NMMB -! - TYPE(DOMAIN_INTERNAL_STATE),POINTER :: DOMAIN_INT_STATE - TYPE(WRAP_DOMAIN_INTERNAL_STATE) :: WRAP_DOMAIN -! - type(esmf_time) :: ringtime,master_starttime,master_stoptime - type(esmf_timeinterval) :: ringinterval - integer(kind=kint) :: iyear_fcst & - ,imonth_fcst & - ,iday_fcst & - ,ihour_fcst & - ,iminute_fcst -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RC_INIT=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** Allocate the NMM component's internal state. -!----------------------------------------------------------------------- - - ALLOCATE(NMM_INT_STATE,stat=RC) - wrap%NMM_INT_STATE=>NMM_INT_STATE -! -!----------------------------------------------------------------------- -!*** Attach the NMM internal state to the NMM component. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Attach NMM Internal State to the NMM Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSetInternalState(NMM_GRID_COMP & - ,WRAP & - ,RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Retrieve the VM (Virtual Machine) of the NMM component. -!*** We need VM now to obtain the MPI task IDs. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Retrieve VM from NMM Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGet(gridcomp=NMM_GRID_COMP & !<-- The NMM component - ,vm =VM & !<-- Get the Virtual Machine from the NMM component - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Obtain MPI Task IDs from VM" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_VMGet(vm =VM & !<-- The virtual machine - ,localpet=MYPE & !<-- Each MPI global task ID (all tasks are present) - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Create and load all of the configure objects. All domains -!*** are functionally equivalent thus each has its own configure -!*** file. We are counting the configure files as we create the -!*** ESMF configure objects so we will know how many different -!*** domains there are. -!----------------------------------------------------------------------- -! - NUM_DOMAINS_X=0 -! - ALLOCATE(RANK_TO_DOMAIN_ID_PTR(NUM_DOMAINS_MAX)) -! - DO N=1,NUM_DOMAINS_MAX !<-- Number of config files must not exceed 99 -! - WRITE(INT_TO_CHAR,FMT)N - CONFIG_FILE_NAME='configure_file_'//INT_TO_CHAR !<-- Each configure file has a unique number. -! - CFILE_EXIST=.FALSE. - INQUIRE(FILE=CONFIG_FILE_NAME,EXIST=CFILE_EXIST) -! - IF(CFILE_EXIST)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Create Temporary Configure Object" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CF_X=ESMF_ConfigCreate(rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Load the Temp Configure Object" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigLoadFile(config =CF_X & - ,filename=CONFIG_FILE_NAME & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Extract Domain ID From Temp Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF_X & !<-- The config object - ,value =ID_X & !<-- The domain's ID - ,label ='my_domain_id:' & !<-- Take value from this config labelious variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CF(ID_X)=ESMF_ConfigCreate(rc=RC) !<-- Domain's ID is its element in the CF array -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Destroy Temporary Config Object" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigDestroy(config=CF_X & !<-- The temporary config object - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Load the Nest Configure Object" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigLoadFile(config =CF(ID_X) & - ,filename=CONFIG_FILE_NAME & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DOMAIN_ID_TO_RANK(ID_X)=N !<-- The configure file rank for a given domain ID - RANK_TO_DOMAIN_ID(N)=ID_X !<-- The domain ID for a given configure file rank - RANK_TO_DOMAIN_ID_PTR(N)=ID_X !<-- The domain ID for a given configure file rank -! - NUM_DOMAINS_X=NUM_DOMAINS_X+1 -! - ELSE -! - EXIT -! - ENDIF -! - ENDDO -! - NESTING_NMM=.FALSE. - IF(NUM_DOMAINS_X>1)NESTING_NMM=.TRUE. !<-- We have nests if more than one domain is present -! -!----------------------------------------------------------------------- -!*** Before going further we need to be certain that the number of -!*** configure files present actually matches the number of domains -!*** the user intends there to be. If they do not match then abort -!*** the run. The uppermost domain's configure file contains the -!*** total number of domains that the user wants. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! MESSAGE_CHECK="NMM_INIT: Extract Total Domain Count Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(1) & !<-- The config object - ,value =NUM_DOMAINS_TOTAL & !<-- The user-specified total number of domains - ,label ='num_domains_total:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF (NUM_DOMAINS_X/=NUM_DOMAINS_TOTAL) THEN - WRITE(0,*)' # of configure files in working directory is wrong!' - WRITE(0,*)' You have said there are ',NUM_DOMAINS_TOTAL & - ,' domains in this run.' - WRITE(0,*)' But there are ',NUM_DOMAINS_X,' configure files present.' - WRITE(0,*)' There must be one configure file per domain.' - WRITE(0,*)' ABORTING!!' - CALL ESMF_Finalize(rc=RC,endflag=ESMF_END_ABORT) - ENDIF -! -!----------------------------------------------------------------------- -!*** Obtain the global communicator for all tasks in this run. -!----------------------------------------------------------------------- -! - CALL ESMF_VMGet(vm =VM & !<-- The virtual machine - ,mpiCommunicator=COMM_GLOBAL & !<-- Global intracommunicator for all tasks - ,petCount =NUM_TASKS_TOTAL & !<-- Total # of tasks in this run - ,rc =RC) -! -!----------------------------------------------------------------------- -!*** Check now if the user has specified quilt tasks. If there -!*** are multiple domains then either all or none must set quilting -!*** to false. -!----------------------------------------------------------------------- -! - DO N=1,NUM_DOMAINS_TOTAL -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Get Value of QUILTING from Config Files" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(N) & !<-- The config object of domain N - ,value =QUILTING & !<-- Has quilting been specified? - ,label ='quilting:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(N==1)THEN - QUILTING_1=QUILTING - ELSE - IF(QUILTING.AND..NOT.QUILTING_1)THEN - WRITE(0,*)' Conflicting quilting settings in configure files!' - WRITE(0,*)' Aborting!!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - ENDIF -! - ENDDO -! -!----------------------------------------------------------------------- -!*** Set the default for the mode of MPI task assignment. -!----------------------------------------------------------------------- -! - TASK_MODE='unique' -! -!----------------------------------------------------------------------- -!*** IF NESTED DOMAINS ARE BEING USED THEN: -!*** (1) Split the MPI Communicator between all domains; -!*** (2) Create a DOMAIN subcomponent for all domains; -!*** (3) Call DOMAIN_INIT recursively for all domains. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! - nesting_block_1: IF(NESTING_NMM)THEN !<-- Special communicators are needed for nesting -! -!----------------------------------------------------------------------- -!*** There is no need to proceed if the specified forecast lengths -!*** of all domains are not the same. Currently the upper parent -!*** cannot integrate longer than its children and some nests cannot -!*** integrate longer than other nests. -!----------------------------------------------------------------------- -! - DO N=1,NUM_DOMAINS_TOTAL -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Check forecast lengths of domains." -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(N) & !<-- The config object of domain N - ,value =LENGTH_FCST & !<-- Forecast length of domain N - ,label ='nhours_fcst:' & !<-- Configure label for forecast length - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(N==1)THEN - LENGTH_FCST_1=LENGTH_FCST - ELSE - IF(LENGTH_FCST/=LENGTH_FCST_1)THEN - WRITE(0,*)' Domain forecast lengths differ!' - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - ENDIF -! - ENDDO -! -!----------------------------------------------------------------------- -!*** Task 0 checks all the configure files to see if 2-way exchange -!*** appears in any of them. If it does then the mode for this run's -!*** task assignments is generational and not unique to each domain. -!----------------------------------------------------------------------- -! - IF(MYPE==0)THEN -! - search: DO N=1,NUM_DOMAINS_TOTAL -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Is Nest_Mode in the Configure File?" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigFindLabel(config=CF(N) & !<-- The config object of domain N - ,label ='nest_mode:' & !<-- Domain N's nesting mode ('1-way' or '2-way') - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(RC==-2)THEN !<-- Return code is -2 if the label is not found -! - CYCLE !<-- nest_mode not in config file (domain not a child) -! - ELSE -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Check Exchange Mode in Config Files" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(N) & !<-- The config object of domain N - ,value =NEST_MODE & !<-- Domain N's nesting mode ('1-way' or '2-way') - ,label ='nest_mode:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(NEST_MODE=='2-way')THEN - TASK_MODE='generational' - EXIT search - ENDIF -! - ENDIF -! - ENDDO search -! - ENDIF -! - CALL MPI_BCAST(TASK_MODE & !<-- Broadcast the value of TASK_MODE - ,12 & !<-- It contains 12 characters - ,MPI_CHARACTER & !<-- Type CHARACTER - ,0 & !<-- Global task 0 is sending - ,COMM_GLOBAL & !<-- The global communicator - ,IERR ) -! -!----------------------------------------------------------------------- -! - ALLOCATE(DOMAIN_GEN(1:NUM_DOMAINS_TOTAL),stat=ISTAT) !<-- For 2-way nesting, the generation of each domain - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate DOMAIN_GEN istat=',ISTAT - ENDIF -! - DO N=1,NUM_DOMAINS_TOTAL - DOMAIN_GEN(N)=0 !<-- Initialize value of each domain's generation - ENDDO -! - FULL_GEN=0 -! -!----------------------------------------------------------------------- -!*** If the task assignment is generational then we must check to be -!*** sure that at least one of the generations of nests uses all of -!*** the tasks assigned to the run. -!----------------------------------------------------------------------- -! - two_way: IF(TASK_MODE=='generational')THEN -! -!----------------------------------------------------------------------- -!*** Read all the configure files to find out how many generations -!*** of nests there are by checking which generation all the domains -!*** are in. -!----------------------------------------------------------------------- -! - MAX_GEN=0 - NUM_WRITE_TASKS=0 -! - DO N=1,NUM_DOMAINS_TOTAL -! - ID_X=RANK_TO_DOMAIN_ID(N) !<-- The domain ID for the Nth domain -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Extract generation from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_X) & !<-- The config object - ,value =DOMAIN_GEN(ID_X) & !<-- This domain's generation - ,label ='generation:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - MAX_GEN=MAX(MAX_GEN,DOMAIN_GEN(ID_X)) -! - ENDDO -! - ALLOCATE(N_FCST_TASKS_GEN(1:MAX_GEN),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate N_FCST_TASKS_GEN istat=',ISTAT - ENDIF -! - DO N=1,MAX_GEN - N_FCST_TASKS_GEN(N)=0 !<-- Initialize # of tasks in each generation - ENDDO -! -!----------------------------------------------------------------------- -!*** Now determine and check all generations' task counts. -!----------------------------------------------------------------------- -! - DO N=1,NUM_DOMAINS_TOTAL -! - ID_X=RANK_TO_DOMAIN_ID(N) !<-- The domain ID for the Nth domain - N_GEN=DOMAIN_GEN(ID_X) !<-- This domain's generation -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Extract INPES From Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_X) & !<-- The config object - ,value =INPES & !<-- The domain's fcst tasks in I - ,label ='inpes:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Extract JNPES From Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_X) & !<-- The config object - ,value =JNPES & !<-- The domain's fcst tasks in J - ,label ='jnpes:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Extract Write_Groups From Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_X) & !<-- The config object - ,value =WRITE_GROUPS & !<-- The number of Write groups on this domain - ,label ='write_groups:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Extract Write Tasks Per Group From Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_X) & !<-- The config object - ,value =WRITE_TASKS_PER_GROUP & !<-- The number of tasks per Write group - ,label ='write_tasks_per_group:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - N_FCST_TASKS_GEN(N_GEN)=N_FCST_TASKS_GEN(N_GEN)+INPES*JNPES -! - NUM_WRITE_TASKS=NUM_WRITE_TASKS & - +WRITE_GROUPS*WRITE_TASKS_PER_GROUP -! - ENDDO -! -!----------------------------------------------------------------------- -! - USED_ALL_FCST_TASKS=.FALSE. - NUM_FCST_TASKS=NUM_TASKS_TOTAL-NUM_WRITE_TASKS !<-- # of forecast tasks available -! - DO N=1,MAX_GEN -! - IF(N_FCST_TASKS_GEN(N)==NUM_FCST_TASKS.AND.FULL_GEN==0)THEN - USED_ALL_FCST_TASKS=.TRUE. - FULL_GEN=N !<-- Save the 1st generation that uses all fcst tasks -! - ELSEIF(N_FCST_TASKS_GEN(N)>NUM_FCST_TASKS)THEN - WRITE(0,*)' Generation ',N,' is using more fcst tasks' & - ,' than assigned to the run!' - WRITE(0,*)' There are ',NUM_FCST_TASKS,' fcst tasks in this run.' - WRITE(0,*)' Generation ',N,' is using ',N_FCST_TASKS_GEN(N) & - ,' fcst tasks.' - WRITE(0,*)' Aborting!!' - CALL ESMF_Finalize(rc=RC,endflag=ESMF_END_ABORT) -! - ELSEIF(N_FCST_TASKS_GEN(N)==0)THEN - WRITE(0,*)' Generation ',N,' is using no tasks!!' - WRITE(0,*)' Aborting!!' - CALL ESMF_Finalize(rc=RC,endflag=ESMF_END_ABORT) -! - ENDIF -! - ENDDO -! - IF(.NOT.USED_ALL_FCST_TASKS)THEN - WRITE(0,*)' No generation is using all fcst tasks assigned' & - ,' to the run.' - WRITE(0,*)' At least one generation must use all fcst tasks.' - WRITE(0,*)' Aborting!!' - CALL ESMF_Finalize(rc=RC,endflag=ESMF_END_ABORT) - ENDIF -! - DEALLOCATE(N_FCST_TASKS_GEN) -! -!----------------------------------------------------------------------- -! - ENDIF two_way -! -!----------------------------------------------------------------------- -!*** Split the global communicator among all NMM domains and create -!*** Parent-Child intercommunicators. -!----------------------------------------------------------------------- -! - CALL PARENT_CHILD_COMMS(MYPE & !<-- This task's global rank (in) - ,NUM_DOMAINS_TOTAL & !<-- Total number of domains, all generations (in) - ,NUM_TASKS_TOTAL & !<-- Total number of tasks assigned to the run (in) - ,COMM_GLOBAL & !<-- Intracommunicator for ALL tasks (in) - ,RANK_TO_DOMAIN_ID & !<-- Domain IDs for each configure file - ,CF & !<-- Configure objects for all domains (in) - ,TASK_MODE & !<-- 1-way or 2-way nesting (in) - ,QUILTING & !<-- Was quilting specified in the configure files? - ,DOMAIN_GEN & !<-- For 2-way nesting, the generation of each domain (in) - ,FULL_GEN & !<-- For 2-way nesting, the generation using all tasks (in) - ,MY_DOMAIN_ID_N & !<-- ID of domains on which this task resides (out) - ,ID_DOMAINS & !<-- IDs of all domains (out) - ,ID_PARENTS & !<-- ID of all domains' parents (out) - ,nmm_int_state%NUM_CHILDREN & !<-- # of children on each domain (out) - ,ID_CHILDREN & !<-- IDs of all children of all domains (out) - ,COMMS_DOMAIN & !<-- Parent and child intracommunicators (out) - ,FTASKS_DOMAIN & !<-- # of fcst tasks on each domain excluding descendents (out) - ,NTASKS_DOMAIN & !<-- # of tasks on each domain excluding descendents (out) - ,PETLIST_DOMAIN & !<-- List of task IDs for each domain (DOMAIN Component) (out) - ,NUM_GENS ) !<-- # of generations of domains (out) -! -!----------------------------------------------------------------------- -!*** The array MY_DOMAIN_ID_N is dimensioned 1:NUM_DOMAINS_TOTAL. -!*** The indices that correspond to the domain IDs on which the -!*** current task lies equal those respective IDs. All the other -!*** indices are zero. Now how many domains does the current -!*** task lie on? -!----------------------------------------------------------------------- -! - IF(TASK_MODE=='unique')THEN -! -!----------------------------------------------------------------------- -! - NUM_DOMAINS_MINE=1 -! - ALLOCATE(MY_DOMAIN_IDS(1:1)) - MY_DOMAIN_IDS(1)=MY_DOMAIN_ID_N(1) !<-- A task lies on only one domain in 1-way nests -! - ALLOCATE(MY_DOMAINS_IN_GENS(1:1)) - MY_DOMAINS_IN_GENS(1)=MY_DOMAIN_ID_N(1) !<-- The task only lies on one domain -! - ALLOCATE(GENERATION_FINISHED(1:1)) - GENERATION_FINISHED(1)=.FALSE. !<-- Generations not relevant for 1-way nesting -! - ALLOCATE(FREE_TO_INTEGRATE(1:1)) !<-- 1-way => task on one domain per generation; always free - FREE_TO_INTEGRATE(1)=.TRUE. -! -!----------------------------------------------------------------------- -! - ELSEIF(TASK_MODE=='generational')THEN -! -!----------------------------------------------------------------------- -! - NUM_DOMAINS_MINE=0 -! - DO N=1,NUM_DOMAINS_TOTAL - IF(MY_DOMAIN_ID_N(N)>0)THEN - NUM_DOMAINS_MINE=NUM_DOMAINS_MINE+1 - ENDIF - ENDDO -! -!----------------------------------------------------------------------- -!*** What are the domain IDs of the domains this task lies on? -!*** Save those in an array dimensioned to exactly the number -!*** of domains it actually lies on. -!----------------------------------------------------------------------- -! - ALLOCATE(MY_DOMAIN_IDS(1:NUM_DOMAINS_MINE),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate MY_DOMAIN_IDS istat=',ISTAT - ENDIF -! - KOUNT=0 - DO N=1,NUM_DOMAINS_TOTAL - IF(MY_DOMAIN_ID_N(N)/=0)THEN - KOUNT=KOUNT+1 - MY_DOMAIN_IDS(KOUNT)=MY_DOMAIN_ID_N(N) - ENDIF - ENDDO -! -!----------------------------------------------------------------------- -!*** Any task can be in no more than one domain per generation. -!*** Save the domain IDs that the current task lies on within -!*** each generation. If the task does not lie on any domain -!*** in a generation then the value is 0. -! -!*** MY_DOMAINS_IN_GENS - A task's domain in each generation (1: # of generations) -!*** MY_DOMAIN_IDS - All domains on which a task resides (1: # of domains a task is on) -!*** DOMAIN_GEN - The generation of each domain (1: total # of domains) -!----------------------------------------------------------------------- -! - ALLOCATE(MY_DOMAINS_IN_GENS(1:NUM_GENS)) -! - DO N=1,NUM_GENS - MY_DOMAINS_IN_GENS(N)=0 - ENDDO -! - DO N=1,NUM_DOMAINS_MINE !<-- Loop through the domains this task is on - ID_DOM=MY_DOMAIN_IDS(N) !<-- This task's Nth domain - GEN_X=DOMAIN_GEN(ID_DOM) !<-- The generation of that domain - IF(MY_DOMAINS_IN_GENS(GEN_X)>0)THEN !<-- The task already has a domain in that generation? - WRITE(0,*)' ERROR' - WRITE(0,*)' Domain ID is ',ID_DOM - WRITE(0,*)' Generation of that domain is ',GEN_X - WRITE(0,*)' This task already has a domain ',MY_DOMAINS_IN_GENS(GEN_X),' in that generation!' - WRITE(0,*)' Aborting!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ELSE - MY_DOMAINS_IN_GENS(GEN_X)=ID_DOM !<-- Save the task's domain ID in this generation - ENDIF - ENDDO -! -!----------------------------------------------------------------------- -!*** Prepare an array over the generations to indicate when -!*** each task completes its forecast for the domain on which -!*** it lies within each generation. Recall that in 2-way mode -!*** a task may lie on no more than one domain per generation. -!----------------------------------------------------------------------- -! - ALLOCATE(GENERATION_FINISHED(1:NUM_GENS)) -! - DO N=1,NUM_GENS - IF(MY_DOMAINS_IN_GENS(N)>0)THEN - GENERATION_FINISHED(N)=.FALSE. - ELSE - GENERATION_FINISHED(N)=.TRUE. !<-- Task not in this generation; consider it finished. - ENDIF - ENDDO -! -!----------------------------------------------------------------------- -!*** Prepare an array over the domains as to whether any one of them -!*** will be allowed to integrate a timestep at any given time. -!----------------------------------------------------------------------- -! - ALLOCATE(FREE_TO_INTEGRATE(1:NUM_GENS)) -! - DO N=1,NUM_GENS - FREE_TO_INTEGRATE(N)=.TRUE. - ENDDO -! - ENDIF -! -!----------------------------------------------------------------------- -!*** The user was required to specify the nest mode in each domain's -!*** configure file indicating whether the parent-child interaction -!*** will be 1-way or 2-way. The domains will now extract and save -!*** that specification. -!----------------------------------------------------------------------- -! - ALLOCATE(nmm_int_state%NEST_MODE(1:NUM_DOMAINS_TOTAL)) -! - DO N=1,NUM_DOMAINS_TOTAL -! - nmm_int_state%NEST_MODE(N)=' ' -! - IF(MY_DOMAIN_ID_N(N)/=0)THEN !<-- Select tasks on domain #N - MY_DOMAIN_ID=MY_DOMAIN_ID_N(N) !<-- The ID of domain #N - COMM_TO_MY_PARENT=>comms_domain(MY_DOMAIN_ID)%TO_PARENT !<-- The domain's parent-child intracommunicator -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Extract Nest_Mode From Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The config object of this domain - ,value =nmm_int_state%NEST_MODE(N) & !<-- The nest domain's nest_mode - ,label ='nest_mode:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - ENDIF -! - ENDDO -! -!----------------------------------------------------------------------- -! - ELSE nesting_block_1 !<-- There is only a single domain -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** How many forecast/write tasks will be active on the domain? -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Extract INPES From Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(1) & !<-- The config object - ,value =INPES & !<-- The domain's fcst tasks in I - ,label ='inpes:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Extract JNPES From Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(1) & !<-- The config object - ,value =JNPES & !<-- The domain's fcst tasks in J - ,label ='jnpes:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Extract Write_Groups From Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(1) & !<-- The config object - ,value =WRITE_GROUPS & !<-- The number of Write groups on this domain - ,label ='write_groups:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Extract Write Tasks Per Group From Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(1) & !<-- The config object - ,value =WRITE_TASKS_PER_GROUP & !<-- The number of tasks per Write group - ,label ='write_tasks_per_group:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(.NOT.QUILTING)THEN - WRITE_GROUPS=0 - WRITE_TASKS_PER_GROUP=0 - ENDIF -! -!----------------------------------------------------------------------- -! - ALLOCATE(nmm_int_state%NUM_CHILDREN(1)) - nmm_int_state%NUM_CHILDREN(1)=0 -! - N_TASKS=INPES*JNPES+WRITE_GROUPS*WRITE_TASKS_PER_GROUP !<-- Total # of tasks on the domain - ALLOCATE(NTASKS_DOMAIN(1)) - NTASKS_DOMAIN(1)=N_TASKS - ALLOCATE(PETLIST_DOMAIN(1:N_TASKS,1)) -! - ALLOCATE(MY_DOMAINS_IN_GENS(1:1)) - MY_DOMAINS_IN_GENS(1)=1 !<-- Dummy value; only relevant for 2-way nests -! - DO N=1,N_TASKS - PETLIST_DOMAIN(N,1)=N-1 !<-- The list of task IDs for the DOMAIN Component - ENDDO -! - ALLOCATE(ID_DOMAINS(1)) - ID_DOMAINS(1)=1 !<-- There is a single domain; its ID is 1 -! - NUM_DOMAINS_MINE=1 - ALLOCATE(MY_DOMAIN_IDS(1),stat=ISTAT) - MY_DOMAIN_IDS(1)=1 - MY_DOMAIN_ID=1 -! - ALLOCATE(ID_CHILDREN(1,1)) - ID_CHILDREN(1,1)=0 !<-- A single domain thus no children -! - ALLOCATE(ID_PARENTS(1)) - ID_PARENTS(1)=-999 !<-- There is a single domain; it has no parent -! - ALLOCATE(COMMS_DOMAIN(1)) - comms_domain(1)%TO_PARENT=-999 !<-- There is a single domain; it has no parent -! - ALLOCATE(FREE_TO_INTEGRATE(1:1)) - FREE_TO_INTEGRATE(1)=.TRUE. !<-- A single domain has no constraints on integration -! - ALLOCATE(GENERATION_FINISHED(1:1)) !<-- A single domain has only one generation to finish - GENERATION_FINISHED(1)=.FALSE. -! - ALLOCATE(nmm_int_state%NEST_MODE(1:1)) - nmm_int_state%NEST_MODE(1)=' ' -!----------------------------------------------------------------------- -! - ENDIF nesting_block_1 -! -!----------------------------------------------------------------------- -!*** Allocate the DOMAIN import/export states. -!----------------------------------------------------------------------- -! - ALLOCATE(nmm_int_state%IMP_STATE_DOMAIN(1:NUM_DOMAINS_TOTAL) & - ,stat=ISTAT) - ALLOCATE(nmm_int_state%EXP_STATE_DOMAIN(1:NUM_DOMAINS_TOTAL) & - ,stat=ISTAT) -! -!----------------------------------------------------------------------- -!*** Create the DOMAIN import/export states. -!----------------------------------------------------------------------- -! - DO N=1,NUM_DOMAINS_TOTAL -! - ID_DOM=RANK_TO_DOMAIN_ID(N) -! - WRITE(INT_TO_CHAR,FMT)ID_DOM - STATE_NAME='Domain '//INT_TO_CHAR//' Import State' -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Create the DOMAIN Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - nmm_int_state%IMP_STATE_DOMAIN(ID_DOM)=ESMF_StateCreate( & !<-- DOMAIN import state - name =STATE_NAME & !<-- DOMAIN import state name - ,stateintent=ESMF_STATEINTENT_IMPORT & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - STATE_NAME='Domain '//INT_TO_CHAR//' Export State' -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Create the DOMAIN Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - nmm_int_state%EXP_STATE_DOMAIN(ID_DOM)=ESMF_StateCreate( & !<-- DOMAIN export state - name =STATE_NAME & !<-- DOMAIN export state name - ,stateintent=ESMF_STATEINTENT_EXPORT & - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDDO -! -!----------------------------------------------------------------------- -!*** For the integration we need to know if this is a restarted run -!*** and if we should write a restart file at time 0. -!----------------------------------------------------------------------- -! - ALLOCATE(nmm_int_state%RESTARTED_RUN(1:NUM_DOMAINS_TOTAL),stat=ISTAT) - ALLOCATE(nmm_int_state%RST_OUT_00 (1:NUM_DOMAINS_TOTAL),stat=ISTAT) -! -!----------------------------------------------------------------------- -!*** Each task will create Clocks for all domains for simplicity -!*** in executing the major DO loops over the DOMAIN components. -! -!*** Create the domains' clocks with their timesteps, start times, -!*** and run durations. Also the user-selected task that will -!*** print the clocktimes. -! -!*** Alarms are also created to determine when the integration -!*** of given tasks on each domain reach coupling times. -!----------------------------------------------------------------------- -! - ALLOCATE(CLOCK_NMM(1:NUM_DOMAINS_TOTAL)) - ALLOCATE(DT(1:NUM_DOMAINS_TOTAL)) - ALLOCATE(FILT_DT(1:NUM_DOMAINS_TOTAL)) -! - ALLOCATE(nmm_int_state%TIMESTEP(1:NUM_DOMAINS_TOTAL)) - ALLOCATE(nmm_int_state%FILT_TIMESTEP(1:NUM_DOMAINS_TOTAL)) -! - ALLOCATE(nmm_int_state%INTERVAL_CLOCKTIME(1:NUM_DOMAINS_TOTAL)) - ALLOCATE(nmm_int_state%INTERVAL_HISTORY (1:NUM_DOMAINS_TOTAL)) - ALLOCATE(nmm_int_state%INTERVAL_RESTART (1:NUM_DOMAINS_TOTAL)) -! - ALLOCATE(nmm_int_state%NPE_PRINT(1:NUM_DOMAINS_TOTAL)) -! - ALLOCATE(ALARM_CPL(1:NUM_DOMAINS_TOTAL)) -! -!----------------------------------------------------------------------- -!*** Extract timestep information and history/restart output frequency -!*** from the config files of all domains. -!----------------------------------------------------------------------- -! - timeinfo_loop: DO N=1,NUM_DOMAINS_TOTAL -! -!----------------------------------------------------------------------- -! - ID_DOM=RANK_TO_DOMAIN_ID(N) -! - TIMESTEP=>nmm_int_state%TIMESTEP(ID_DOM) - FILT_TIMESTEP=>nmm_int_state%FILT_TIMESTEP(ID_DOM) -! - EXP_STATE_DOMAIN=>nmm_int_state%EXP_STATE_DOMAIN(ID_DOM) -! - INTERVAL_HISTORY=>nmm_int_state%INTERVAL_HISTORY(ID_DOM) - INTERVAL_RESTART=>nmm_int_state%INTERVAL_RESTART(ID_DOM) -! - RESTARTED_RUN=>nmm_int_state%RESTARTED_RUN(ID_DOM) - RST_OUT_00 =>nmm_int_state%RST_OUT_00(ID_DOM) -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Extract Timestep from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_DOM) & !<-- The config object for this domain - ,value =TIMESTEP_SEC_WHOLE & !<-- The variable filled (integer part of timestep (sec)) - ,label ='dt_int:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_DOM) & !<-- The config object for this domain - ,value =TIMESTEP_SEC_NUMERATOR & !<-- The variable filled (numerator of timestep fraction) - ,label ='dt_num:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_DOM) & !<-- The config object for this domain - ,value =TIMESTEP_SEC_DENOMINATOR & !<-- The variable filled (denominator of timestep fraction) - ,label ='dt_den:' & !<-- Give this label's value to the previous variable - ,rc =RC) - - CALL ESMF_ConfigGetAttribute(config=CF(ID_DOM) & !<-- The config object for this domain - ,value =FILT_TIMESTEP_SEC_WHOLE & !<-- The variable filled (integer part of timestep (sec)) - ,label ='filt_dt_int:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_DOM) & !<-- The config object for this domain - ,value =FILT_TIMESTEP_SEC_NUMERATOR & !<-- The variable filled (numerator of timestep fraction) - ,label ='filt_dt_num:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_DOM) & !<-- The config object for this domain - ,value =FILT_TIMESTEP_SEC_DENOMINATOR & !<-- The variable filled (denominator of timestep fraction) - ,label ='filt_dt_den:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Establish the timesteps for all of the domains. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Set Timestep Interval" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeIntervalSet(timeinterval=TIMESTEP & !<-- Fundamental timestep on this domain (sec) (ESMF) - ,s =TIMESTEP_SEC_WHOLE & - ,sn =TIMESTEP_SEC_NUMERATOR & - ,sd =TIMESTEP_SEC_DENOMINATOR & - ,rc =RC) -! - CALL ESMF_TimeIntervalSet(timeinterval=FILT_TIMESTEP & !<-- Fundamental filter timestep on this domain (sec) (ESMF) - ,s =FILT_TIMESTEP_SEC_WHOLE & - ,sn =FILT_TIMESTEP_SEC_NUMERATOR & - ,sd =FILT_TIMESTEP_SEC_DENOMINATOR & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DT(ID_DOM)=TIMESTEP_SEC_WHOLE+REAL(TIMESTEP_SEC_NUMERATOR) & !<-- The domain's fundamental timestep (sec) (REAL) - /REAL(TIMESTEP_SEC_DENOMINATOR) -! - FILT_DT(ID_DOM)=FILT_TIMESTEP_SEC_WHOLE+ & !<-- The domain's filter timestep (sec) (REAL) - REAL(FILT_TIMESTEP_SEC_NUMERATOR) & - /REAL(FILT_TIMESTEP_SEC_DENOMINATOR) -! -!----------------------------------------------------------------------- -!*** Get the NMM history and restart output intervals (minutes) -!*** from the config file and save them. Then make certain that -!*** the fundamental timestep divides evenly into each interval. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Obtain History Interval from the Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_DOM) & !<-- The configure object of this domain - ,value =MINUTES_HISTORY & !<-- Fill this variable - ,label ='minutes_history:' & !<-- Give the variable this label's value from the config file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Create the ESMF history file output time interval. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create the History Output Time Interval." -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeIntervalSet(timeinterval=INTERVAL_HISTORY & !<-- Time interval between - ,m =MINUTES_HISTORY & !<-- Minutes between history output - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Obtain Restart Interval from the Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_DOM) & !<-- The configure object of this domain - ,value =MINUTES_RESTART & !<-- Fill this variable - ,label ='minutes_restart:' & !<-- Give the variable this label's value from the config file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Create the ESMF restart file output time interval. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create the Restart Output Time Interval." -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeIntervalSet(timeinterval=INTERVAL_RESTART & !<-- Time interval between restart output (ESMF) - ,m =MINUTES_RESTART & !<-- Minutes between restart output (integer) - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Set variables related to restarted runs. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Extract Restart Flag from Configure File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_DOM) & !<-- The config object - ,value =RESTARTED_RUN & !<-- Logical flag indicating if this is a restarted run - ,label ='restart:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_ATM_DRIVER_INIT: Extract Rst_out_00 Flag from Configure File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_DOM) & !<-- The config object - ,value =RST_OUT_00 & !<-- Should 0-hr history be written for restarted run? - ,label ='rst_out_00:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Ensure that the timestep divides evenly into the restart interval. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Create zero time interval" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeIntervalSet(timeinterval=ZERO_INTERVAL & - ,s =0 & - ,sn =0 & - ,sd =1 & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF (MOD(INTERVAL_RESTART,TIMESTEP) /= ZERO_INTERVAL) THEN - WRITE(0,*)'Timestep of this domain does not divide evenly' & - ,' into the restart interval!' - WRITE(0,*)' ABORTING!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO timeinfo_loop -! -!----------------------------------------------------------------------- -!*** The coupling interval is the timestep of CLOCK_NEMS. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_Init: Extract the coupling interval" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock=CLOCK_NEMS & - ,timeStep=COUPLING_INTERVAL & - ,StartTime=Master_StartTime & - ,StopTime =Master_StopTime & !<-- The end time of the current coupling timestep (ESMF) - ,rc=RC) -! -! write(0,48642)coupling_interval_real -48642 format(' NMM_Init coupling_interval_real=',e12.5) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - call esmf_timeintervalget(timeinterval=coupling_interval & - ,s=isecond_fcst & - ,sn=isecond_num & - ,sd=isecond_den & - ,rc=rc) -! write(0,*)' NMM Init timestep of CLOCK_NEMS is ',isecond_fcst & -! ,' ',isecond_num,'/',isecond_den,' sec' -! call esmf_timeget(Master_StartTime, dd=iday_fcst, h=ihour_fcst, m=iminute_fcst, s=isecond_fcst, rc=rc) -! write(0,*)' NMM Init CLOCK_NEMS starttime is d=',iday_fcst,' h=',ihour_fcst,' m=',iminute_fcst,' s=',isecond_fcst -! call esmf_timeget(Master_StopTime, dd=iday_fcst, h=ihour_fcst, m=iminute_fcst, s=isecond_fcst, rc=rc) -! write(0,*)' NMM Init CLOCK_NEMS stoptime is d=',iday_fcst,' h=',ihour_fcst,' m=',iminute_fcst,' s=',isecond_fcst -!----------------------------------------------------------------------- -!*** Obtain the forecast start time from the Main Clock. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Start Time from NMM Clock" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock =CLOCK_NEMS & !<-- The NEMS ESMF Clock - ,startTime =STARTTIME & !<-- The simulation start time (ESMF) -!!! ,runDuration=RUNDURATION & !<-- The simulation run duration (ESMF) - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - clock_loop: DO N=1,NUM_DOMAINS_TOTAL -! - ID_DOM=RANK_TO_DOMAIN_ID(N) -! - TIMESTEP=>nmm_int_state%TIMESTEP(ID_DOM) -! -!----------------------------------------------------------------------- -!*** Obtain the forecast length time from the configure file. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Extract Forecast Length from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_DOM) & - ,value =NHOURS_FCST & - ,label ='nhours_fcst:' & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NSECONDS_FCST=NHOURS_FCST*3600 !<-- The forecast length (sec) (REAL) - TIMESTEP_FINAL=NINT(NSECONDS_FCST/DT(ID_DOM)) !<-- # of timesteps in the full forecast -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Set the Forecast Length" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeIntervalSet(timeinterval=RUNDURATION & !<-- The forecast length (sec) (ESMF) - ,s =NSECONDS_FCST & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** With data from above, create the ESMF Clocks to control -!*** the timestepping within the DOMAIN subcomponent(s). -!*** Each domain will set its own clock in the initialize -!*** step of DOMAIN_GRID_COMP. -!----------------------------------------------------------------------- -! - WRITE(INT_TO_CHAR,FMT)ID_DOM - CLOCK_NMM_NAME='CLOCK_NMM_'//INT_TO_CHAR -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create the Clocks for the NMM Domains" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CLOCK_NMM(N)=ESMF_ClockCreate(name =CLOCK_NMM_NAME & !<-- The NMM Domain's Clock's name - ,timeStep =TIMESTEP & !<-- The fundamental timestep in this Domain component - ,startTime =STARTTIME & !<-- Start time of simulation -! ,runDuration =RUNDURATION & !<-- Duration of simulation - ,runTimeStepCount=TIMESTEP_FINAL & !<-- Length of forecast (timesteps) - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - if(I_AM_ROOT(RC)) then - CALL NMM_CLOCKPRINT(CLOCK_NMM(N), 'CLOCK_NMM in NMM_INIT', rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) - endif -! -!----------------------------------------------------------------------- -!*** An Alarm is needed to check if each task on a given domain -!*** has reached the end of a coupling interval. The coupling -!*** interval is the same for all domains. -!----------------------------------------------------------------------- -! - WRITE(INT_TO_CHAR,FMT)ID_DOM - ALARM_CPL_NAME='ALARM_CPL_'//INT_TO_CHAR -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create coupling Alarms for the NMM Domains" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ALARM_CPL(ID_DOM)=ESMF_AlarmCreate(name =ALARM_CPL_NAME & !<-- The coupling Alarm's name - ,clock =CLOCK_NMM(ID_DOM) & !<-- The Alarm is associated with this Clock - ,ringInterval =COUPLING_INTERVAL & !<-- Time interval between coupling with ocean - ,ringTimeStepCount=1 & !<-- The Alarm rings for this many timesteps - ,sticky =.false. & !<-- Alarm does not ring until turned offs - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! write(0,23231)id_dom -23231 format(' NMM_Init created ALARM_CPL my_domain_id=',i2) -! call esmf_alarmget(alarm=ALARM_CPL(ID_DOM) & -! ,ringtime=ringtime & -! ,ringinterval=ringinterval & -! ,rc=rc) -! call esmf_timeget(time=ringtime & -! ,yy=iyear_fcst & -! ,mm=imonth_fcst & -! ,dd=iday_fcst & -! ,h=ihour_fcst & -! ,m=iminute_fcst & -! ,s=isecond_fcst & -! ,sn=isecond_num & -! ,sd=isecond_den) -! write(0,*)' ringtime: y=',iyear_fcst,' mm=',imonth_fcst,' dd=',iday_fcst,' h=',ihour_fcst & -! ,' m=',iminute_fcst,' s=',isecond_fcst,' sn=',isecond_num,'s d=',isecond_den -! call esmf_timeintervalget(timeinterval=ringinterval & -! ,m=iminute_fcst & -! ,s=isecond_fcst & -! ,sn=isecond_num & -! ,sd=isecond_den) -! write(0,*)' ringinterval: m=',iminute_fcst,' s=',isecond_fcst,' sn=',isecond_num,'s d=',isecond_den -!----------------------------------------------------------------------- -!*** The fundamental timestep of each NMM domain must divide evenly -!*** into the coupling interval. If that is not true then abort -!*** the run. -!----------------------------------------------------------------------- -! - CALL ESMF_TimeIntervalGet(timeinterval=COUPLING_INTERVAL & - ,s =ISECOND_FCST & - ,sn =ISECOND_NUM & - ,sd =ISECOND_DEN & - ,rc =RC) - TIMESTEP_RATIO=(ISECOND_FCST+ISECOND_NUM/ISECOND_DEN)/DT(ID_DOM) - IF(ABS(TIMESTEP_RATIO-NINT(TIMESTEP_RATIO))>1.E-4)THEN - WRITE(0,11101)ID_DOM - WRITE(0,11102)DT(ID_DOM) - WRITE(0,11103)REAL(ISECOND_FCST)+ISECOND_NUM/ISECOND_DEN - WRITE(0,*)' Aborting!' -11101 FORMAT(' Timestep of NMM domain ',I2,' does not divide' & - ,' evenly into the coupling interval!!!') -11102 FORMAT(' NMM timestep is ',F8.3,' sec') -11103 FORMAT(' Coupling interval is ',F8.3,' sec') - CALL ESMF_Finalize(rc=RC,endflag=ESMF_END_ABORT) - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO clock_loop -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Allocate the DOMAIN gridded component(s). -!----------------------------------------------------------------------- -! - ALLOCATE(nmm_int_state%DOMAIN_GRID_COMP(1:NUM_DOMAINS_TOTAL),stat=ISTAT) -! - IF(ISTAT/=0)THEN - WRITE(0,*)' ERROR: Failed to allocate DOMAIN_GRID_COMP' - WRITE(6,*)' ERROR: Failed to allocate DOMAIN_GRID_COMP' - ENDIF -! -!----------------------------------------------------------------------- -!*** Allocate other quantities associated with each domain. -!----------------------------------------------------------------------- -! - ALLOCATE(nmm_int_state%COMM_MY_DOMAIN(1:NUM_DOMAINS_TOTAL)) - ALLOCATE(nmm_int_state%P_C_TIME_RATIO(1:NUM_DOMAINS_TOTAL)) - ALLOCATE(nmm_int_state%MY_DOMAIN_MOVES(1:NUM_DOMAINS_TOTAL)) - ALLOCATE(nmm_int_state%NPHS (1:NUM_DOMAINS_TOTAL)) - ALLOCATE(nmm_int_state%NTRACK (1:NUM_DOMAINS_TOTAL)) -! - ALLOCATE(I_AM_A_FCST_TASK) - ALLOCATE(nmm_int_state%I_AM_A_FCST_TASK(1:NUM_DOMAINS_TOTAL)) - ALLOCATE(nmm_int_state%I_AM_LEAD_FCST_TASK(1:NUM_DOMAINS_TOTAL)) - ALLOCATE(nmm_int_state%I_AM_A_NEST(1:NUM_DOMAINS_TOTAL)) -! - DO N=1,NUM_DOMAINS_TOTAL -! - nmm_int_state%I_AM_A_FCST_TASK(N) =.FALSE. - nmm_int_state%I_AM_LEAD_FCST_TASK(N)=.FALSE. - nmm_int_state%I_AM_A_NEST(N) =.FALSE. -! - nmm_int_state%P_C_TIME_RATIO(N)=0. - nmm_int_state%MY_DOMAIN_MOVES(N)=.FALSE. - nmm_int_state%NPHS(N)=0 - nmm_int_state%NTRACK(N)=0 - ENDDO -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** Create the DOMAIN gridded components (one per domain of course). -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - domain_comp_create: DO N=1,NUM_DOMAINS_TOTAL -! -!----------------------------------------------------------------------- -! - ID_DOM=RANK_TO_DOMAIN_ID(N) - WRITE(INT_TO_CHAR,FMT)ID_DOM - DOMAIN_GRID_COMP_NAME=DOMAIN_COMP_BASE//INT_TO_CHAR !<-- Append domain ID to DOMAIN Comp name -! - N_TASKS=NTASKS_DOMAIN(ID_DOM) !<-- # of tasks on this domain - PETLIST=>PETLIST_DOMAIN(1:N_TASKS,ID_DOM) !<-- The PETlist for this domain -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Create DOMAIN_GRID_COMP"//INT_TO_CHAR -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - nmm_int_state%DOMAIN_GRID_COMP(ID_DOM)=ESMF_GridCompCreate( & !<-- The DOMAIN Component for this domain - name =DOMAIN_GRID_COMP_NAME & !<-- Name of the new DOMAIN gridded component - ,config =CF(ID_DOM) & !<-- This domain's configure file - ,petList=PETLIST & !<-- The IDs of tasks that will run on this domain - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Register the DOMAIN components' Init, Run, Finalize routines. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Register DOMAIN Init, Run, Finalize" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSetServices(nmm_int_state%DOMAIN_GRID_COMP(ID_DOM) & !<-- The DOMAIN component - ,DOMAIN_REGISTER & !<-- User's subroutineName - ,rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Each task knows on which domain in which generation it lies. -!*** We are currently considering each domain in the run. Loop -!*** through the generations to see if a task lies on this domain. -!*** If it does then it proceeds with initialization action for -!*** that domain otherwise we continue on to the next generation -!*** and check if the task is on this domain in that generation. -!*** If we get all the way through the generations and the task -!*** does not lie on the given domain for any of the generations -!*** then we move on to the next domain and begin the search again -!*** for the task being on that domain. -!----------------------------------------------------------------------- -! - MY_DOMAIN_ID=0 -! - DO NN=1,NUM_GENS - IF(ID_DOM==MY_DOMAINS_IN_GENS(NN))THEN !<-- Only tasks on domain ID_DOM continue - MY_DOMAIN_ID=ID_DOM !<-- Yes, this task is on this domain so proceed - EXIT - ENDIF - ENDDO -! - IF(MY_DOMAIN_ID==0)THEN !<-- Given task not on domain N - CYCLE domain_comp_create - ENDIF -! -!----------------------------------------------------------------------- -!*** Insert various quantities into the Domain import state that -!*** will be needed by that component. -!----------------------------------------------------------------------- -! - COMM_TO_MY_PARENT=>comms_domain(MY_DOMAIN_ID)%TO_PARENT - COMM_TO_MY_CHILDREN=>comms_domain(MY_DOMAIN_ID)%to_children -! - IMP_STATE_DOMAIN=>nmm_int_state%IMP_STATE_DOMAIN(MY_DOMAIN_ID) - NUM_CHILDREN =>nmm_int_state%NUM_CHILDREN(MY_DOMAIN_ID) -! -!----------------------------------------------------------------------- -!*** Does this domain move? -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM Init: Extract Move Flag From the Configure file" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & - ,value =MY_DOMAIN_MOVES & - ,label ='my_domain_moves:' & - ,rc =rc) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - nmm_int_state%MY_DOMAIN_MOVES(MY_DOMAIN_ID)=MY_DOMAIN_MOVES -! -!----------------------------------------------------------------------- -!*** For hurricane runs we need to know if the storm locator is on -!*** as well as the physics timestep. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM Init: Extract the storm locator flag." -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & - ,value =NTRACK & - ,label ='ntrack:' & - ,rc =rc) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM Init: Extract the physics timestep." -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & - ,value =NPHS & - ,label ='nphs:' & - ,rc =rc) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - nmm_int_state%NTRACK(MY_DOMAIN_ID)=NTRACK - nmm_int_state%NPHS (MY_DOMAIN_ID)=NPHS -! -!----------------------------------------------------------------------- -!*** Check the configure flag indicating whether or not to run -!*** adiabatically (i.e., with no physics). Insert the flag -!*** into the DOMAIN import state. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Adiabatic Flag From the Configure file" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & - ,value =MODE & - ,label ='adiabatic:' & - ,rc =rc) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(TRIM(MODE)=='true')THEN - PHYSICS_ON = .FALSE. - IF(MYPE==0) WRITE(0,*)' NMM will run without physics.' - ELSE - PHYSICS_ON = .TRUE. - IF(MYPE==0) WRITE(0,*)' NMM will run with physics.' - ENDIF - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Physics flag to the DOMAIN Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state - ,name ='PHYSICS_ON' & !<-- The flag indicating if physics is active - ,value=PHYSICS_ON & !<-- The value being inserted into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Insert the maximum number of domains. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add NUM_DOMAINS_MAX to the DOMAIN Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state - ,name ='MAX_DOMAINS' & !<-- Maximum # of domains - ,value=NUM_DOMAINS_MAX & !<-- The scalar being inserted into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add NUM_DOMAINS to the DOMAIN Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state - ,name ='NUM_DOMAINS' & !<-- # of domains in this run - ,value=NUM_DOMAINS_TOTAL & !<-- The scalar being inserted into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Insert the domain IDs into the DOMAIN import state(s) along with -!*** the association of domains with configure file names, -!*** the number of children and the children's domain IDs. -!*** Also insert a flag as to whether the DOMAIN component is a nest. -! -!*** Note that all tasks are aware of all domains' IDs, -!*** number of children, and those children's domain IDs. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Domain IDs to the DOMAIN Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state - ,name ='DOMAIN_ID' & !<-- This DOMAIN Component's domain ID - ,value=MY_DOMAIN_ID & !<-- The scalar being inserted into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Insert the association of configure file IDs with domain IDs. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Configure File ID Associated With Each Domain ID" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state =IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state - ,name ='DOMAIN_ID_TO_RANK' & !<-- Adding Attribute with this name - ,itemCount=NUM_DOMAINS_MAX & !<-- Total # of domains - ,valueList=DOMAIN_ID_TO_RANK & !<-- Configure file IDs linked to each domain - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Insert the global rank of the lead task of each domain. This -!*** is the rank that is retrieved from the VM of each domain. -!----------------------------------------------------------------------- -! - LEAD_TASK=PETLIST_DOMAIN(1,MY_DOMAIN_ID) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Lead Task Rank on Each Domain" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state - ,name ='Lead Task Domain' & !<-- Name of Attribute - ,value=LEAD_TASK & !<-- Global ran of lead task on this domain - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Number of Children to the DOMAIN Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state - ,name ='NUM_CHILDREN' & !<-- This DOMAIN Component's # of children - ,value=NUM_CHILDREN & !<-- Insert this into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(COMM_TO_MY_PARENT==-999)THEN - nmm_int_state%I_AM_A_NEST(ID_DOM)=.FALSE. - ELSE - nmm_int_state%I_AM_A_NEST(ID_DOM)=.TRUE. - ENDIF -! - I_AM_A_NEST=>nmm_int_state%I_AM_A_NEST(ID_DOM) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Nest/Not-a-Nest Flag to the DOMAIN Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state - ,name ='I-Am-A-Nest Flag' & !<-- Name of Attribute - ,value=I_AM_A_NEST & !<-- Logical nest flag - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Insert the digital filter flag ( >0 indicates which method). -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_Init: Get Filter Method from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & - ,value =FILTER_METHOD & - ,label ='filter_method:' & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_Init: Put Filter Method into DOMAIN import state" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state for filter - ,name ='Filter_Method' & !<-- Flag for type of digital filter - ,value=FILTER_METHOD & !<-- Value of digital filter flag - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- - nesting_block_2: IF(NESTING_NMM)THEN -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Domain IDs of Children to the DOMAIN Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - LENGTH=MAX(1,NUM_CHILDREN) - CHILD_ID=>ID_CHILDREN(1:LENGTH,ID_DOM) !<-- Select only the IDs of this domain's children -! - CALL ESMF_AttributeSet(state =IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state - ,name ='CHILD_IDs' & !<-- The children's IDs of this DOMAIN Component - ,itemCount=LENGTH & !<-- Length of inserted array - ,valueList=CHILD_ID & !<-- Insert this into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(I_AM_A_NEST) THEN -! - PARENT_CHILD_TIME_RATIO=>nmm_int_state%P_C_TIME_RATIO(ID_DOM) -! - PARENT_CHILD_TIME_RATIO=NINT(DT(ID_PARENTS(ID_DOM)) & !<-- Ratio of parent's timestep to this nest's - /DT(ID_DOM)) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Parent-Child Time Ratio to DOMAIN Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state - ,name ='Parent-Child Time Ratio' & !<-- Name of Attribute - ,value=PARENT_CHILD_TIME_RATIO & !<-- # of child timesteps per parent timestep - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF nesting_block_2 -! -!----------------------------------------------------------------------- -! - ENDDO domain_comp_create -! -!----------------------------------------------------------------------- -!*** Allocate the clocktime object for all of the domains. This -!*** holds various timers that will be printed to indicate the -!*** clocktime used by different parts of the code. -!----------------------------------------------------------------------- -! - ALLOCATE(TIMERS(1:NUM_DOMAINS_TOTAL),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate TIMERS(1:',NUM_DOMAINS_TOTAL,') in NMM_Init.' - WRITE(0,*)' Aborting!!' - CALL ESMF_Finalize(rc=RC,endflag=ESMF_END_ABORT) - ENDIF -! - DO N=1,NUM_DOMAINS_TOTAL -! - timers(n)%total_integ_tim=0. - timers(n)%totalsum_tim=0 - timers(n)%adv1_tim=0. - timers(n)%adv2_tim=0. - timers(n)%bocoh_tim=0. - timers(n)%bocov_tim=0. - timers(n)%cdwdt_tim=0. - timers(n)%cdzdt_tim=0. - timers(n)%consts_tim=0. - timers(n)%ddamp_tim=0. - timers(n)%dht_tim=0. - timers(n)%exch_tim=0. - timers(n)%fftfhn_tim=0. - timers(n)%fftfwn_tim=0. - timers(n)%hdiff_tim=0. - timers(n)%mono_tim=0. - timers(n)%pdtsdt_tim=0. - timers(n)%pgforce_tim=0. - timers(n)%poavhn_tim=0. - timers(n)%polehn_tim=0. - timers(n)%polewn_tim=0. - timers(n)%prefft_tim=0. - timers(n)%presmud_tim=0. - timers(n)%solver_init_tim=0. - timers(n)%solver_dyn_tim=0. - timers(n)%solver_phy_tim=0. - timers(n)%swaphn_tim=0. - timers(n)%swapwn_tim=0. - timers(n)%updatet_tim=0. - timers(n)%updateuv_tim=0. - timers(n)%updates_tim=0. - timers(n)%vsound_tim=0. - timers(n)%vtoa_tim=0. - timers(n)%adjppt_tim=0. - timers(n)%cucnvc_tim=0. - timers(n)%gsmdrive_tim=0. - timers(n)%cltend_tim=0. - timers(n)%rfupdate_tim=0. - timers(n)%tqadjust_tim=0. - timers(n)%h_to_v_tim=0. - timers(n)%gfs_phy_tim=0. - timers(n)%phy_sum_tim=0. - timers(n)%pole_swap_tim=0. - timers(n)%radiation_tim=0. - timers(n)%rdtemp_tim=0. - timers(n)%turbl_tim=0. - timers(n)%domain_run_1=0. - timers(n)%domain_run_2=0. - timers(n)%domain_run_3=0. - timers(n)%pc_cpl_run_cpl1=0. - timers(n)%pc_cpl_run_cpl2=0. - timers(n)%pc_cpl_run_cpl3=0. - timers(n)%pc_cpl_run_cpl4=0. - timers(n)%pc_cpl_run_cpl5=0. - timers(n)%cpl1_recv_tim=0. - timers(n)%cpl2_send_tim=0. - timers(n)%cpl2_comp_tim=0. - timers(n)%cpl2_wait_tim=0. - timers(n)%parent_bookkeep_moving_tim=0. - timers(n)%parent_update_moving_tim=0. - timers(n)%t0_recv_move_tim=0. - timers(n)%update_interior_from_nest_tim=0. - timers(n)%update_interior_from_parent_tim=0. -! - ENDDO -! -!----------------------------------------------------------------------- -!*** At this point, DOMAIN components for each domain have been -!*** created and registered. Now they need to be initialized. -! -!*** The following call will initialize DOMAIN_GRID_COMP for domain #1. -!*** If more than one domain exists, domain #1 is the uppermost and -!*** the remaining domains will be initialized recursively through -!*** the generations of children. Recursion is necessary because -!*** children must not be initialized before their parents since -!*** a parent might be directed by the user to generate input data -!*** for its children and that must be complete before the parent's -!*** children are initialized and try to read their input data -!*** before it exists. -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -! - CALL CALL_DOMAIN_INITIALIZE(1,CLOCK_NMM) !<-- Initiate cascade of DOMAIN Initialize calls for all domains -! -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** We now prepare for work with the coupler components between -!*** parents and their children. -!----------------------------------------------------------------------- -! - ALLOCATE(nmm_int_state%PC_CPL_COMP(1:NUM_DOMAINS_TOTAL)) !<-- The coupler components. - ALLOCATE(nmm_int_state%IMP_STATE_PC_CPL(1:NUM_DOMAINS_TOTAL)) !<-- The couplers' import states. - ALLOCATE(nmm_int_state%EXP_STATE_PC_CPL(1:NUM_DOMAINS_TOTAL)) !<-- The couplers' export states. -! - ALLOCATE(HANDLE_PACKET_S_H(1:NUM_DOMAINS_TOTAL)) !<-- Request handles for parent ISends of bndry data packets - ALLOCATE(HANDLE_PACKET_S_V(1:NUM_DOMAINS_TOTAL)) ! to children - ALLOCATE(HANDLE_PACKET_N_H(1:NUM_DOMAINS_TOTAL)) ! - ALLOCATE(HANDLE_PACKET_N_V(1:NUM_DOMAINS_TOTAL)) ! - ALLOCATE(HANDLE_PACKET_W_H(1:NUM_DOMAINS_TOTAL)) ! - ALLOCATE(HANDLE_PACKET_W_V(1:NUM_DOMAINS_TOTAL)) ! - ALLOCATE(HANDLE_PACKET_E_H(1:NUM_DOMAINS_TOTAL)) ! - ALLOCATE(HANDLE_PACKET_E_V(1:NUM_DOMAINS_TOTAL)) !<-- -! - ALLOCATE(HANDLE_I_SW(1:NUM_DOMAINS_TOTAL)) !<-- Request handle for child ISend of its SW corner to parent - ALLOCATE(HANDLE_J_SW(1:NUM_DOMAINS_TOTAL)) !<-- Request handle for child ISend of its SW corner to parent -! - ALLOCATE(HANDLE_CHILD_LIMITS(1:NUM_DOMAINS_TOTAL)) !<-- Request handles for parent IRecvs of child task limits -! - ALLOCATE(HANDLE_CHILD_TOPO_S(1:NUM_DOMAINS_TOTAL)) !<-- Request handles for parent IRecvs of child bndry topo - ALLOCATE(HANDLE_CHILD_TOPO_N(1:NUM_DOMAINS_TOTAL)) ! - ALLOCATE(HANDLE_CHILD_TOPO_W(1:NUM_DOMAINS_TOTAL)) ! - ALLOCATE(HANDLE_CHILD_TOPO_E(1:NUM_DOMAINS_TOTAL)) !<-- -! - ALLOCATE(HANDLE_PARENT_DOM_LIMITS(1:NUM_DOMAINS_TOTAL)) !<-- Request handles for ISSends of parent domain limits to -! children. - ALLOCATE(HANDLE_PARENT_ITE(1:NUM_DOMAINS_TOTAL)) !<-- Request handles for ISends of parent task limits to children - ALLOCATE(HANDLE_PARENT_ITS(1:NUM_DOMAINS_TOTAL)) ! - ALLOCATE(HANDLE_PARENT_JTE(1:NUM_DOMAINS_TOTAL)) ! - ALLOCATE(HANDLE_PARENT_JTS(1:NUM_DOMAINS_TOTAL)) !<-- -! - ALLOCATE(PTASK_LIMITS(1:NUM_DOMAINS_TOTAL)) !<-- Object holding the parent task limits - ALLOCATE(CTASK_LIMITS(1:NUM_DOMAINS_TOTAL)) !<-- Object holding parent's children's tasks' limits -! - ALLOCATE(INFO_SEND(1:NUM_DOMAINS_TOTAL),stat=ISTAT) !<-- Parent info to children about which BC updates - IF(ISTAT/=0)THEN - WRITE(0,*)' NMM_INIT failed to allocate INFO_SEND stat=',ISTAT - WRITE(0,*)' Aborting!!' - CALL ESMF_Finalize(rc=RC,endflag=ESMF_END_ABORT) - ENDIF -! - ALLOCATE(nmm_int_state%NUM_2WAY_CHILDREN(1:NUM_DOMAINS_TOTAL)) !<-- Object holding # of 2-way nests on each domain. - DO N=1,NUM_DOMAINS_TOTAL - nmm_int_state%NUM_2WAY_CHILDREN(N)=0 - ENDDO -! -!----------------------------------------------------------------------- -!*** Everybody creates an array of Parent-Child couplers for all -!*** the domains. If there is only a single domain then the -!*** coupler and related variables are empty shells. -!----------------------------------------------------------------------- -! - pc_cpl_create: DO N=1,NUM_DOMAINS_TOTAL -! -!----------------------------------------------------------------------- -! - ID_X=RANK_TO_DOMAIN_ID(N) !<-- The domain ID for the Nth domain -! -!----------------------------------------------------------------------- -!*** Create the couplers' import/export states. -!----------------------------------------------------------------------- -! - IMP_STATE_CPL_NEST=>nmm_int_state%IMP_STATE_PC_CPL(ID_X) - EXP_STATE_CPL_NEST=>nmm_int_state%EXP_STATE_PC_CPL(ID_X) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create Empty Import/Export States for Nesting" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IMP_STATE_CPL_NEST=ESMF_StateCreate(name ='Nesting Coupler Import' & !<-- The P-C Coupler import state name - ,stateintent= ESMF_STATEINTENT_IMPORT & - ,rc =RC) -! - EXP_STATE_CPL_NEST=ESMF_StateCreate(name ='Nesting Coupler Export' & !<-- The P-C Coupler export state name - ,stateintent= ESMF_STATEINTENT_EXPORT & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Create the Parent-Child Couplers. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create the Parent-Child Coupler Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - PARENT_CHILD_COUPLER_COMP=>nmm_int_state%PC_CPL_COMP(ID_X) - PARENT_CHILD_COUPLER_COMP=ESMF_CplCompCreate(name='Parent_Child Coupler' & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Register the coupler's Init, Run, and Finalize steps. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Register the Parent-Child Coupler's Init, Run, Finalize" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_CplCompSetServices(cplcomp =PARENT_CHILD_COUPLER_COMP & ! <-- The Nesting coupler component - ,userRoutine =PARENT_CHILD_CPL_REGISTER & ! <-- The user's subroutineName - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Initialize the request handles for nonblocking sends/recvs in -!*** the gens_1 loop below as well as the object holding those limits. -!----------------------------------------------------------------------- -! - HANDLE_PACKET_S_H(N)%CHILDREN=>NULL() - HANDLE_PACKET_S_V(N)%CHILDREN=>NULL() - HANDLE_PACKET_N_H(N)%CHILDREN=>NULL() - HANDLE_PACKET_N_V(N)%CHILDREN=>NULL() - HANDLE_PACKET_W_H(N)%CHILDREN=>NULL() - HANDLE_PACKET_W_V(N)%CHILDREN=>NULL() - HANDLE_PACKET_E_H(N)%CHILDREN=>NULL() - HANDLE_PACKET_E_V(N)%CHILDREN=>NULL() -! - HANDLE_PARENT_DOM_LIMITS(N)%DATA=>NULL() -! - HANDLE_PARENT_ITS(N)%DATA=>NULL() - HANDLE_PARENT_ITE(N)%DATA=>NULL() - HANDLE_PARENT_JTS(N)%DATA=>NULL() - HANDLE_PARENT_JTE(N)%DATA=>NULL() -! - HANDLE_CHILD_LIMITS(N)%CHILDREN=>NULL() -! - HANDLE_CHILD_TOPO_S(N)%CHILDREN=>NULL() - HANDLE_CHILD_TOPO_N(N)%CHILDREN=>NULL() - HANDLE_CHILD_TOPO_W(N)%CHILDREN=>NULL() - HANDLE_CHILD_TOPO_E(N)%CHILDREN=>NULL() -! - CTASK_LIMITS(N)%CHILDREN=>NULL() -! - INFO_SEND(N)%CHILDREN=>NULL() -! -!----------------------------------------------------------------------- -! - ENDDO pc_cpl_create -! -!----------------------------------------------------------------------- -!*** Each task loops through the generations. Remember that a given -!*** task can be on no more than one domain in each generation. -!*** This first loop handles the setting up of the Parent-Child -!*** coupler and does preliminary data exchange. Because that data -!*** exchange includes child-->parent and the parents must use that -!*** data in the upcoming execution of the 1st phase of the coupler -!*** then the setup and the 1st phase must be in their own loops -!*** across the generations. -!----------------------------------------------------------------------- -! - gens_0: DO NN=1,NUM_GENS -! -!----------------------------------------------------------------------- -! - MY_DOMAIN_ID=MY_DOMAINS_IN_GENS(NN) !<-- This task's (only) domain in generation NN - IF(MY_DOMAIN_ID==0)CYCLE !<-- This task not on a domain in generation NN -! -!----------------------------------------------------------------------- -!*** Identify the forecast vs. quilt/write tasks since Parent-Child -!*** interaction does not involve any Write tasks. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Extract Fcst-or-Write Flag from Domain Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=nmm_int_state%EXP_STATE_DOMAIN(MY_DOMAIN_ID) & !<-- The DOMAIN component export state - ,name ='Fcst-or-Write Flag' & !<-- Name of the attribute to extract - ,value=I_AM_A_FCST_TASK & !<-- Am I a forecast task? - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - nmm_int_state%I_AM_A_FCST_TASK(MY_DOMAIN_ID)=I_AM_A_FCST_TASK -! -!----------------------------------------------------------------------- -!*** Save this domain's intracommunicator between its forecast tasks. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Extract Fcst Task Intracomm from Domain Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=nmm_int_state%EXP_STATE_DOMAIN(MY_DOMAIN_ID) & !<-- The Domain component export state - ,name ='Comm Fcst Tasks' & !<-- Name of the attribute to extract - ,value=comms_domain(MY_DOMAIN_ID)%TO_FCST_TASKS & !<-- Intracommunicator between fcst tasks - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Identify the lead forecast task on each domain. -!----------------------------------------------------------------------- -! - IF(I_AM_A_FCST_TASK)THEN -! - CALL MPI_COMM_RANK(comms_domain(MY_DOMAIN_ID)%TO_FCST_TASKS & !<-- Intracomm for fcst tasks on this domain - ,MYPE_X & !<-- Rank of this task in the intracommunicator - ,IERR) -! - IF(MYPE_X==0)THEN - nmm_int_state%I_AM_LEAD_FCST_TASK(MY_DOMAIN_ID)=.TRUE. - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** If there are nests then create a Parent-Child coupler through -!*** which parents will send boundary data to their children and -!*** also internal data to moving children. -!*** Load that coupler's import state with the data the parents -!*** need to generate boundary data for their children. -!----------------------------------------------------------------------- -! - nesting_block_3: IF(NESTING_NMM)THEN !<-- All parents and children create the Coupler. -! -!----------------------------------------------------------------------- -! - NUM_CHILDREN=>nmm_int_state%NUM_CHILDREN(MY_DOMAIN_ID) !<-- How many children does this domain have? - LENGTH=MAX(1,NUM_CHILDREN) - CHILD_ID=>ID_CHILDREN(1:LENGTH,MY_DOMAIN_ID) !<-- Select the IDs of this domain's children -! - COMM_TO_MY_PARENT=>comms_domain(MY_DOMAIN_ID)%TO_PARENT !<-- This domain's intracommunicator to its parent - IF(NUM_CHILDREN>0)THEN - COMM_TO_MY_CHILDREN=>comms_domain(MY_DOMAIN_ID)%TO_CHILDREN !<-- This domain's intracommunicators to its children - ELSE - COMM_TO_MY_CHILDREN=>NULL() - ENDIF -! - TIMESTEP=>nmm_int_state%TIMESTEP(MY_DOMAIN_ID) !<-- This domain's fundamental timestep - RESTARTED_RUN=>nmm_int_state%RESTARTED_RUN(MY_DOMAIN_ID) !<-- Is this a restarted forecast? -! - DOMAIN_GRID_COMP=>nmm_int_state%DOMAIN_GRID_COMP(MY_DOMAIN_ID) !<-- This domain's ESMF component - EXP_STATE_DOMAIN=>nmm_int_state%EXP_STATE_DOMAIN(MY_DOMAIN_ID) !<-- Its export state -! - PARENT_CHILD_COUPLER_COMP=>nmm_int_state%PC_CPL_COMP(MY_DOMAIN_ID) !<-- P-C coupler associated with this domain - IMP_STATE_CPL_NEST=>nmm_int_state%IMP_STATE_PC_CPL(MY_DOMAIN_ID) !<-- The P-C coupler's import state - EXP_STATE_CPL_NEST=>nmm_int_state%EXP_STATE_PC_CPL(MY_DOMAIN_ID) !<-- The P-C coupler's export state -! -!----------------------------------------------------------------------- -! - CALL PARENT_CHILD_COUPLER_SETUP(NUM_DOMAINS_TOTAL & ! - ,MY_DOMAIN_ID & ! - ,NUM_CHILDREN & ! - ,COMM_TO_MY_CHILDREN & ! - ,COMM_TO_MY_PARENT & ! - ,DT & ! - ,CHILD_ID & ! ^ - ,DOMAIN_GRID_COMP & ! | - ,EXP_STATE_DOMAIN & ! | - ,FTASKS_DOMAIN & ! | - ,NTASKS_DOMAIN & ! | - ,ID_PARENTS & ! | - ,DOMAIN_ID_TO_RANK & ! | - ,NUM_DOMAINS_MAX & ! Input -! ---------- - ,IMP_STATE_CPL_NEST & ! Output - ,EXP_STATE_CPL_NEST & ! | - ) ! v -! -!----------------------------------------------------------------------- -! - ENDIF nesting_block_3 -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** The tasks in each domain must synchronize before moving to -!*** a different generation. -!----------------------------------------------------------------------- -! - DOMAIN_GRID_COMP=>nmm_int_state%DOMAIN_GRID_COMP(MY_DOMAIN_ID) !<-- This domain's ESMF component -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Extract VM for this Domain Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGet(gridcomp=DOMAIN_GRID_COMP & - ,vm =VM & !<-- Get the Virtual Machine for this domain - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Get Intracommunicator for this Domain" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_VMGet(vm =VM & !<-- The virtual machine - ,mpiCommunicator=COMM_MY_DOMAIN & !<-- Intracommunicator for domain MY_DOMAIN_ID - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - nmm_int_state%COMM_MY_DOMAIN(MY_DOMAIN_ID)=COMM_MY_DOMAIN -! - CALL MPI_BARRIER(COMM_MY_DOMAIN,IERR) -! -!----------------------------------------------------------------------- -! - ENDDO gens_0 -! -!----------------------------------------------------------------------- -!*** The forecast tasks now execute phase 1 of the Parent-Child -!*** coupler initialization. -!----------------------------------------------------------------------- -! - gens_1: DO NN=NUM_GENS,1,-1 -! - MY_DOMAIN_ID=MY_DOMAINS_IN_GENS(NN) !<-- This task's (only) domain in generation NN - IF(MY_DOMAIN_ID==0)CYCLE !<-- This task not on a domain in generation NN -! - nesting_block_4: IF(NESTING_NMM)THEN !<-- All parents and children initialize the Coupler. -! - PARENT_CHILD_COUPLER_COMP=>nmm_int_state%PC_CPL_COMP(MY_DOMAIN_ID) !<-- P-C coupler associated with this domain - IMP_STATE_CPL_NEST=>nmm_int_state%IMP_STATE_PC_CPL(MY_DOMAIN_ID) !<-- The P-C coupler's import state - EXP_STATE_CPL_NEST=>nmm_int_state%EXP_STATE_PC_CPL(MY_DOMAIN_ID) !<-- The P-C coupler's export state -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Phase 1 Initialization of the Parent-Child Coupler" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_CplCompInitialize(cplcomp =PARENT_CHILD_COUPLER_COMP & !<-- The parent-child coupler component - ,importState=IMP_STATE_CPL_NEST & !<-- The parent-child coupler import state - ,exportState=EXP_STATE_CPL_NEST & !<-- The parent-child coupler export state - ,clock =CLOCK_NMM(MY_DOMAIN_ID) & !<-- The DOMAIN Clock - ,phase =1 & !<-- The phase (see P-C Register routine) - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF nesting_block_4 -! - ENDDO gens_1 -! -!----------------------------------------------------------------------- -!*** The forecast tasks now execute phase 2 of the Parent-Child -!*** coupler initialization. -!----------------------------------------------------------------------- -! - gens_2: DO NN=1,NUM_GENS -! - MY_DOMAIN_ID=MY_DOMAINS_IN_GENS(NN) !<-- This task's (only) domain in generation NN - IF(MY_DOMAIN_ID==0)CYCLE !<-- This task not on a domain in generation NN -! -!----------------------------------------------------------------------- -! - nesting_block_5: IF(NESTING_NMM)THEN !<-- All parents and children initialize the Coupler. -! - DOMAIN_GRID_COMP=>nmm_int_state%DOMAIN_GRID_COMP(MY_DOMAIN_ID) - I_AM_A_FCST_TASK=nmm_int_state%I_AM_A_FCST_TASK(MY_DOMAIN_ID) - NUM_CHILDREN=>nmm_int_state%NUM_CHILDREN(MY_DOMAIN_ID) -! -!----------------------------------------------------------------------- -! - parent_waits_limits: IF(NUM_CHILDREN>0)THEN !<-- If so this task is on a parent domain in generation NN -! -!----------------------------------------------------------------------- -! - CALL ESMF_GridCompGet(gridcomp=DOMAIN_GRID_COMP & - ,vm =VM & !<-- Get the Virtual Machine for this domain - ,rc =RC) -! - CALL ESMF_VMGet(vm =VM & !<-- The virtual machine - ,localPet =MYPE_LOCAL & !<-- Rank of task in the domain's intracommunicator - ,rc =RC) -! -!----------------------------------------------------------------------- -!*** Before executing phase 2 of the initialization of the Parent- -!*** Child coupler we will clear the request handles associated with -!*** the nonblocking sends/recvs of the child subdomain limits in -!*** subroutine PARENT_CHILD_COUPLER_SETUP called in the previous -!*** loop. Those sends/recvs consisted of cross-generational -!*** exchanges of data between parents and their children. Because -!*** only one generation at a time was executed during the loop's -!*** iterations those data exchanges had to be non-blocking. Now -!*** loop through the generations again, make certain the non-blocking -!*** sends/recvs have finished, then call phase 2 of the Parent- -!*** Child coupler's initialization that includes the use of the -!*** exchanged data. -!----------------------------------------------------------------------- -! - CHILD_ID=>ID_CHILDREN(1:NUM_CHILDREN,MY_DOMAIN_ID) !<-- Select the IDs of this domain's children - ID=MY_DOMAIN_ID -! - DO N=1,NUM_CHILDREN - NUM_CHILD_TASKS=FTASKS_DOMAIN(CHILD_ID(N)) -! - DO NT=1,NUM_CHILD_TASKS -! - IF(MYPE_LOCAL==0)THEN - CALL MPI_WAIT(HANDLE_CHILD_LIMITS(ID)%CHILDREN(N)%DATA(NT) & - ,JSTAT & - ,IERR) -! - DO N2=2,FTASKS_DOMAIN(ID) - CALL MPI_SEND(CTASK_LIMITS(ID)%CHILDREN(N)%DATA(1,NT) & !<-- Subdomain limits of child N's task NT - ,4 & !<-- Consists of 4 words - ,MPI_INTEGER & !<-- Data are integers - ,N2-1 & !<-- Send to parent task N2-1 - ,N2-1 & !<-- Use target task rank as the MPI tag - ,comms_domain(ID)%TO_FCST_TASKS & !<-- Intracomm between parent fcst tasks - ,IERR ) - ENDDO -! - ELSE -! - IF(I_AM_A_FCST_TASK)THEN - CALL MPI_RECV(CTASK_LIMITS(ID)%CHILDREN(N)%DATA(1:4,NT) & !<-- Subdomain limits of child N's task NT - ,4 & !<-- Consists of 4 words - ,MPI_INTEGER & !<-- Data are integers - ,0 & !<-- Parent task 0 is sending the data - ,MYPE_LOCAL & !<-- Current parent task's local rank - ,comms_domain(ID)%TO_FCST_TASKS & !<-- Intracomm between parent fcst tasks - ,JSTAT & - ,IERR ) - ENDIF -! - ENDIF -! - ENDDO -! - ENDDO -! -!----------------------------------------------------------------------- -! - ENDIF parent_waits_limits -! -!----------------------------------------------------------------------- -!*** Now we can proceed in executing phase 2 of the Parent-Child -!*** coupler initialization. -!----------------------------------------------------------------------- -! - PARENT_CHILD_COUPLER_COMP=>nmm_int_state%PC_CPL_COMP(MY_DOMAIN_ID) !<-- P-C coupler associated with this domain - IMP_STATE_CPL_NEST=>nmm_int_state%IMP_STATE_PC_CPL(MY_DOMAIN_ID) !<-- The P-C coupler's import state - EXP_STATE_CPL_NEST=>nmm_int_state%EXP_STATE_PC_CPL(MY_DOMAIN_ID) !<-- The P-C coupler's export state -! - I_AM_A_FCST_TASK=nmm_int_state%I_AM_A_FCST_TASK(MY_DOMAIN_ID) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Phase 2 Initialization of the Parent-Child Coupler" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_CplCompInitialize(cplcomp =PARENT_CHILD_COUPLER_COMP & !<-- The parent-child coupler component - ,importState=IMP_STATE_CPL_NEST & !<-- The parent-child coupler import state - ,exportState=EXP_STATE_CPL_NEST & !<-- The parent-child coupler export state - ,clock =CLOCK_NMM(MY_DOMAIN_ID) & !<-- The DOMAIN Clock - ,phase =2 & !<-- The phase (see P-C Register routine) - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** The number of 2-way children is a required argument in the call -!*** to NMM_INTEGRATE. Extract its value from the export state of -!*** the P-C coupler. -!----------------------------------------------------------------------- -! - NUM_2WAY_CHILDREN=>nmm_int_state%NUM_2WAY_CHILDREN(MY_DOMAIN_ID) -! - IF(I_AM_A_FCST_TASK.AND.NUM_CHILDREN>0)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_Init: Extract # of 2-Way Children from P-C Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_CPL_NEST & !<-- The Parent-Child coupler export state - ,name ='NUM_2WAY_CHILDREN' & !<-- Name of the attribute to extract - ,value=NUM_2WAY_CHILDREN & !<-- How many 2-way children in the current domain? - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF nesting_block_5 -! -!----------------------------------------------------------------------- -! - INTERVAL_CLOCKTIME=>nmm_int_state%INTERVAL_CLOCKTIME(MY_DOMAIN_ID) - NPE_PRINT=>nmm_int_state%NPE_PRINT(MY_DOMAIN_ID) -! -!----------------------------------------------------------------------- -!*** Extract ID of the task that will print clocktimes on this domain. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Read MPI Task ID That Provides Clocktime Output" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The configure object - ,value =NPE_PRINT & !<-- Fill this variable (this task prints its clocktimes) - ,label ='npe_print:' & !<-- Give the variable this label's value from the config file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Get print_timing flag from config file. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get print_timing flag from configure file" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The configure object - ,value =PRINT_TIMING & !<-- Fill this variable (this task prints its clocktimes) - ,label ='print_timing:' & !<-- Give the variable this label's value from the config file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Set the forecast time interval (sec) between writes of the -!*** clocktime statistics by the task specified in the configure -!*** file. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Read Fcst Interval for Clocktime Output" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The configure object - ,value =NHOURS_CLOCKTIME & !<-- Fill this variable (fcst hrs between clocktime prints) - ,label ='nhours_clocktime:' & !<-- Give the variable this label's value from the config file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create ESMF Clocktime Output Interval" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeIntervalSet(timeinterval=INTERVAL_CLOCKTIME & !<-- Time interval between clocktime writes (h) (ESMF) - ,h =NHOURS_CLOCKTIME & !<-- Hours between clocktime writes (INTEGER) - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** The tasks in each domain must synchronize before moving to -!*** a different generation. -!----------------------------------------------------------------------- -! - COMM_MY_DOMAIN=nmm_int_state%COMM_MY_DOMAIN(MY_DOMAIN_ID) -! - CALL MPI_BARRIER(COMM_MY_DOMAIN,IERR) -! -!----------------------------------------------------------------------- -! - ENDDO gens_2 -! -!----------------------------------------------------------------------- -! - gens_3: DO NN=1,NUM_GENS -! -!----------------------------------------------------------------------- -!*** Before executing phase 3 of the initialization of the Parent- -!*** Child coupler we will clear the request handles associated with -!*** the nonblocking sends/recvs of the child topography in phase 1 -!*** of the initialization. Those sends/recvs consisted of cross- -!*** generational exchanges of data between parents and their -!*** children. Because only one generation at a time is executed -!*** during the loop's iterations those data exchanges had to be -!*** non-blocking. Now loop through the generations again, make -!*** certain the non-blocking sends/recvs have finished, then call -!*** phase 3 of the Parent-Child coupler's initialization that -!*** includes the use of the exchanged data. -!----------------------------------------------------------------------- -! - MY_DOMAIN_ID=MY_DOMAINS_IN_GENS(NN) !<-- This task's (only) domain in generation NN - IF(MY_DOMAIN_ID==0)CYCLE !<-- This task not on a domain in generation NN -! - I_AM_A_FCST_TASK=nmm_int_state%I_AM_A_FCST_TASK(MY_DOMAIN_ID) - NUM_CHILDREN=>nmm_int_state%NUM_CHILDREN(MY_DOMAIN_ID) -! -!----------------------------------------------------------------------- -! - parent_waits_topo: IF(NUM_CHILDREN>0 & !<-- If so this task is on a parent domain in generation NN - .AND. & - I_AM_A_FCST_TASK)THEN -! -!----------------------------------------------------------------------- -! - DOMAIN_GRID_COMP=>nmm_int_state%DOMAIN_GRID_COMP(MY_DOMAIN_ID) -! - CALL ESMF_GridCompGet(gridcomp=DOMAIN_GRID_COMP & - ,vm =VM & !<-- Get the Virtual Machine for this domain - ,rc =RC) -! - CALL ESMF_VMGet(vm =VM & !<-- The virtual machine - ,localPet =MYPE_LOCAL & !<-- Rank of task in the domain's intracommunicator - ,rc =RC) -! -!----------------------------------------------------------------------- -!*** Make sure the relevant parent tasks received boundary topography -!*** from their children. -!----------------------------------------------------------------------- -! - ID=MY_DOMAIN_ID -! - IF(ASSOCIATED(HANDLE_CHILD_TOPO_S(ID)%CHILDREN))THEN -! - DO N=1,NUM_CHILDREN - IF(ASSOCIATED(HANDLE_CHILD_TOPO_S(ID)%CHILDREN(N)%DATA))THEN - INDX2=UBOUND(HANDLE_CHILD_TOPO_S(ID)%CHILDREN(N)%DATA,1) - DO NT=1,INDX2 - CALL MPI_WAIT(HANDLE_CHILD_TOPO_S(ID)%CHILDREN(N)%DATA(NT) & - ,JSTAT & - ,IERR) - ENDDO - ENDIF - ENDDO - ENDIF -! - IF(ASSOCIATED(HANDLE_CHILD_TOPO_N(ID)%CHILDREN))THEN -! - DO N=1,NUM_CHILDREN - IF(ASSOCIATED(HANDLE_CHILD_TOPO_N(ID)%CHILDREN(N)%DATA))THEN - INDX2=UBOUND(HANDLE_CHILD_TOPO_N(ID)%CHILDREN(N)%DATA,1) - DO NT=1,INDX2 - CALL MPI_WAIT(HANDLE_CHILD_TOPO_N(ID)%CHILDREN(N)%DATA(NT) & - ,JSTAT & - ,IERR) - ENDDO - ENDIF - ENDDO - ENDIF -! - IF(ASSOCIATED(HANDLE_CHILD_TOPO_W(ID)%CHILDREN))THEN -! - DO N=1,NUM_CHILDREN - IF(ASSOCIATED(HANDLE_CHILD_TOPO_W(ID)%CHILDREN(N)%DATA))THEN - INDX2=UBOUND(HANDLE_CHILD_TOPO_W(ID)%CHILDREN(N)%DATA,1) - DO NT=1,INDX2 - CALL MPI_WAIT(HANDLE_CHILD_TOPO_W(ID)%CHILDREN(N)%DATA(NT) & - ,JSTAT & - ,IERR) - ENDDO - ENDIF - ENDDO - ENDIF -! - IF(ASSOCIATED(HANDLE_CHILD_TOPO_E(ID)%CHILDREN))THEN -! - DO N=1,NUM_CHILDREN - IF(ASSOCIATED(HANDLE_CHILD_TOPO_E(ID)%CHILDREN(N)%DATA))THEN - INDX2=UBOUND(HANDLE_CHILD_TOPO_E(ID)%CHILDREN(N)%DATA,1) - DO NT=1,INDX2 - CALL MPI_WAIT(HANDLE_CHILD_TOPO_E(ID)%CHILDREN(N)%DATA(NT) & - ,JSTAT & - ,IERR) - ENDDO - ENDIF - ENDDO - ENDIF -! -! - DO N=1,NUM_CHILDREN -! - IF(ASSOCIATED(HANDLE_PARENT_DOM_LIMITS(ID)%DATA))THEN - CALL MPI_WAIT(HANDLE_PARENT_DOM_LIMITS(ID)%DATA(N) & - ,JSTAT & - ,IERR) - ENDIF -! - IF(ASSOCIATED(HANDLE_PARENT_ITS(ID)%DATA))THEN - CALL MPI_WAIT(HANDLE_PARENT_ITS(ID)%DATA(N) & - ,JSTAT & - ,IERR) -! - CALL MPI_WAIT(HANDLE_PARENT_ITE(ID)%DATA(N) & - ,JSTAT & - ,IERR) -! - CALL MPI_WAIT(HANDLE_PARENT_JTS(ID)%DATA(N) & - ,JSTAT & - ,IERR) -! - CALL MPI_WAIT(HANDLE_PARENT_JTE(ID)%DATA(N) & - ,JSTAT & - ,IERR) - ENDIF -! - ENDDO -! - ENDIF parent_waits_topo -! -!----------------------------------------------------------------------- -!*** Clear the request handles for the parents' ISends of the -!*** boundary info packets in phase 1 of the Init step and -!*** deallocate memory we are finished with. -!----------------------------------------------------------------------- -! - I_AM_A_FCST_TASK=nmm_int_state%I_AM_A_FCST_TASK(MY_DOMAIN_ID) -! - parent_waits_bc_info: IF(NUM_CHILDREN>0.AND. & !<-- Select fcst tasks on all the parents - I_AM_A_FCST_TASK)THEN -! - ID=MY_DOMAIN_ID -! - IF(ASSOCIATED(HANDLE_PACKET_S_H(ID)%CHILDREN))THEN -! - DO N=1,NUM_CHILDREN - IF(ASSOCIATED(HANDLE_PACKET_S_H(ID)%CHILDREN(N)%DATA))THEN - INDX2=UBOUND(HANDLE_PACKET_S_H(ID)%CHILDREN(N)%DATA,1) - DO NT=1,INDX2 - CALL MPI_WAIT(HANDLE_PACKET_S_H(ID)%CHILDREN(N)%DATA(NT) & - ,JSTAT & - ,IERR) - ENDDO -! - ENDIF - ENDDO - ENDIF -! - IF(ASSOCIATED(HANDLE_PACKET_S_V(ID)%CHILDREN))THEN -! - DO N=1,NUM_CHILDREN - IF(ASSOCIATED(HANDLE_PACKET_S_V(ID)%CHILDREN(N)%DATA))THEN - INDX2=UBOUND(HANDLE_PACKET_S_V(ID)%CHILDREN(N)%DATA,1) - DO NT=1,INDX2 - CALL MPI_WAIT(HANDLE_PACKET_S_V(ID)%CHILDREN(N)%DATA(NT) & - ,JSTAT & - ,IERR) - ENDDO -! - ENDIF - ENDDO - ENDIF -! - IF(ASSOCIATED(HANDLE_PACKET_N_H(ID)%CHILDREN))THEN -! - DO N=1,NUM_CHILDREN - IF(ASSOCIATED(HANDLE_PACKET_N_H(ID)%CHILDREN(N)%DATA))THEN - INDX2=UBOUND(HANDLE_PACKET_N_H(ID)%CHILDREN(N)%DATA,1) - DO NT=1,INDX2 - CALL MPI_WAIT(HANDLE_PACKET_N_H(ID)%CHILDREN(N)%DATA(NT) & - ,JSTAT & - ,IERR) - ENDDO -! - ENDIF - ENDDO - ENDIF -! - IF(ASSOCIATED(HANDLE_PACKET_N_V(ID)%CHILDREN))THEN -! - DO N=1,NUM_CHILDREN - IF(ASSOCIATED(HANDLE_PACKET_N_V(ID)%CHILDREN(N)%DATA))THEN - INDX2=UBOUND(HANDLE_PACKET_N_V(ID)%CHILDREN(N)%DATA,1) - DO NT=1,INDX2 - CALL MPI_WAIT(HANDLE_PACKET_N_V(ID)%CHILDREN(N)%DATA(NT) & - ,JSTAT & - ,IERR) - ENDDO -! - ENDIF - ENDDO - ENDIF -! - IF(ASSOCIATED(HANDLE_PACKET_W_H(ID)%CHILDREN))THEN -! - DO N=1,NUM_CHILDREN - IF(ASSOCIATED(HANDLE_PACKET_W_H(ID)%CHILDREN(N)%DATA))THEN - INDX2=UBOUND(HANDLE_PACKET_W_H(ID)%CHILDREN(N)%DATA,1) - DO NT=1,INDX2 - CALL MPI_WAIT(HANDLE_PACKET_W_H(ID)%CHILDREN(N)%DATA(NT) & - ,JSTAT & - ,IERR) - ENDDO -! - ENDIF - ENDDO - ENDIF -! - IF(ASSOCIATED(HANDLE_PACKET_W_V(ID)%CHILDREN))THEN -! - DO N=1,NUM_CHILDREN - IF(ASSOCIATED(HANDLE_PACKET_W_V(ID)%CHILDREN(N)%DATA))THEN - INDX2=UBOUND(HANDLE_PACKET_W_V(ID)%CHILDREN(N)%DATA,1) - DO NT=1,INDX2 - CALL MPI_WAIT(HANDLE_PACKET_W_V(ID)%CHILDREN(N)%DATA(NT) & - ,JSTAT & - ,IERR) - ENDDO -! - ENDIF - ENDDO - ENDIF -! - IF(ASSOCIATED(HANDLE_PACKET_E_H(ID)%CHILDREN))THEN -! - DO N=1,NUM_CHILDREN - IF(ASSOCIATED(HANDLE_PACKET_E_H(ID)%CHILDREN(N)%DATA))THEN - INDX2=UBOUND(HANDLE_PACKET_E_H(ID)%CHILDREN(N)%DATA,1) - DO NT=1,INDX2 - CALL MPI_WAIT(HANDLE_PACKET_E_H(ID)%CHILDREN(N)%DATA(NT) & - ,JSTAT & - ,IERR) - ENDDO -! - ENDIF - ENDDO - ENDIF -! - IF(ASSOCIATED(HANDLE_PACKET_E_V(ID)%CHILDREN))THEN -! - DO N=1,NUM_CHILDREN - IF(ASSOCIATED(HANDLE_PACKET_E_V(ID)%CHILDREN(N)%DATA))THEN - INDX2=UBOUND(HANDLE_PACKET_E_V(ID)%CHILDREN(N)%DATA,1) - DO NT=1,INDX2 - CALL MPI_WAIT(HANDLE_PACKET_E_V(ID)%CHILDREN(N)%DATA(NT) & - ,JSTAT & - ,IERR) - ENDDO -! - ENDIF - ENDDO - ENDIF -! - ENDIF parent_waits_bc_info -! -!----------------------------------------------------------------------- -!*** The tasks in each domain must synchronize before moving to -!*** a different generation. -!----------------------------------------------------------------------- -! - COMM_MY_DOMAIN=nmm_int_state%COMM_MY_DOMAIN(MY_DOMAIN_ID) -! - CALL MPI_BARRIER(COMM_MY_DOMAIN,IERR) -! -!----------------------------------------------------------------------- -!*** The forecast tasks now execute phase 3 of the Parent-Child -!*** coupler initialization. -!----------------------------------------------------------------------- -! - nesting_block_6: IF(NESTING_NMM)THEN !<-- All parents and children create the Coupler. -! -!----------------------------------------------------------------------- -! - IMP_STATE_CPL_NEST=>nmm_int_state%IMP_STATE_PC_CPL(MY_DOMAIN_ID) - EXP_STATE_CPL_NEST=>nmm_int_state%EXP_STATE_PC_CPL(MY_DOMAIN_ID) - PARENT_CHILD_COUPLER_COMP=>nmm_int_state%PC_CPL_COMP(MY_DOMAIN_ID) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Phase 3 Initialization of Parent-Child Coupler" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_CplCompInitialize(cplcomp =PARENT_CHILD_COUPLER_COMP & !<-- The parent-child coupler component - ,importState=IMP_STATE_CPL_NEST & !<-- The parent-child coupler import state - ,exportState=EXP_STATE_CPL_NEST & !<-- The parent-child coupler export state - ,clock =CLOCK_NMM(MY_DOMAIN_ID) & !<-- The DOMAIN Clock - ,phase =3 & !<-- The phase (see P-C Register routine) - ,rc =RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF nesting_block_6 -! -!----------------------------------------------------------------------- -! - ENDDO gens_3 -! -!----------------------------------------------------------------------- -!*** The central lat/lon of the single domain / upper parent are -!*** needed. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! MESSAGE_CHECK="NMM_INIT: Extract Total Domain Count Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(1) & !<-- The config object - ,value =TPH0D & !<-- Central geographic lat (deg) of uppermost domain. - ,label ='tph0d:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF(1) & !<-- The config object - ,value =TLM0D & !<-- Central geographic lon (deg) of uppermost domain. - ,label ='tlm0d:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Save the values needed for NUOPC coupling to external models. -!----------------------------------------------------------------------- -! - CALL STORE_DOMAIN_DESCRIPTORS -! -!----------------------------------------------------------------------- -!*** Create the ESMF grid. See comments in FUNCTION NMMB_GridCreate. -!*** For multiple NMM domains each task must tell NMMB_GridCreate -!*** which domain it is on. -!*** Announce the fields that will be part of the coupling. -!----------------------------------------------------------------------- -! - DO N=1,NUM_DOMAINS_TOTAL -! - ID_X=RANK_TO_DOMAIN_ID(N) !<-- The domain ID for the Nth domain - MY_DOMAIN_ID=ID_X -! -!-------------------------------------------------- -!*** Extract the current domain's internal state. -!-------------------------------------------------- -! - IF(DOMAIN_DESCRIPTORS(MY_DOMAIN_ID)%TASK_ACTIVE)THEN - CALL ESMF_GridCompGetInternalState(& - nmm_int_state%DOMAIN_GRID_COMP(MY_DOMAIN_ID), & - WRAP_DOMAIN, RC) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - DOMAIN_INT_STATE=>wrap_domain%DOMAIN_INT_STATE - ELSE - DOMAIN_INT_STATE=>NULL() - ENDIF -! - pGrid_NMMB = NMMB_GridCreate(N, nmm_int_state%DOMAIN_GRID_COMP(MY_DOMAIN_ID), DOMAIN_DESCRIPTORS, TPH0D,TLM0D, RC=RC) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out -! - DOMAIN_DESCRIPTORS(N)%GRID = pGrid_NMMB - DOMAIN_DESCRIPTORS(N)%PARENT_DOMAIN_ID = 1 -! - CALL NMMB_CreateRouteHandle(N, DOMAIN_DESCRIPTORS, RC=RC) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out -! - CALL NMMB_CreateDomainFields(N, DOMAIN_DESCRIPTORS, RC=RC) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out -! - ENDDO - - nmm_grid = DOMAIN_DESCRIPTORS(1)%GRID - -!----------------------------------------------------------------------- -!*** Only some of the full list of potential export fields will -!*** be regridded from the nests to the upper parent. Find those -!*** fields' indices in the full list of export fields and save them. -!----------------------------------------------------------------------- -! - DO N1=1,nExportFields_NMMB - N2=queryFieldList(exportFieldsList, EXPORT_FIELDS_BLEND(N1), rc=rc) - EXPORT_FIELDS_INDX(N1)=N2 - ENDDO -! -!----------------------------------------------------------------------- -! - IF(RC_INIT==ESMF_SUCCESS)THEN -! WRITE(0,*)' NMM_INITIALIZE succeeded' - ELSE - WRITE(0,*)' NMM_INITIALIZE failed RC_INIT=',RC_INIT - ENDIF -! -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -! - SUBROUTINE STORE_DOMAIN_DESCRIPTORS -! -!----------------------------------------------------------------------- -!*** Store values into the derived-type object needed for coupling -!*** domains to external models. This is an internal subroutine -!*** in NMM_INITIALIZE. -!----------------------------------------------------------------------- -! - USE module_DOMAIN_INTERNAL_STATE,ONLY: DOMAIN_INTERNAL_STATE & - ,WRAP_DOMAIN_INTERNAL_STATE - - USE module_SOLVER_INTERNAL_STATE,ONLY: SOLVER_INTERNAL_STATE & - ,WRAP_SOLVER_INT_STATE -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! -!--------------------- -!*** Local variables -!--------------------- -! - INTEGER(kind=KINT) :: I,ITE,ITS,J,JTE,JTS,NUM_PETS,PET_N,RC - INTEGER(kind=KINT),DIMENSION(2) :: minIndex, maxIndex -! - REAL(kind=KDBL) :: DEG2RAD,LAM0,PHI0,PI -! - REAL(kind=KDBL),DIMENSION(2) :: CENTRAL_LATLON -! - CHARACTER(4096) :: TMPSTR -! - TYPE(DOMAIN_INTERNAL_STATE),POINTER :: DOMAIN_INT_STATE - TYPE(WRAP_DOMAIN_INTERNAL_STATE) :: WRAP_DOMAIN - TYPE(SOLVER_INTERNAL_STATE),POINTER :: SOLVER_INT_STATE - TYPE(WRAP_SOLVER_INT_STATE) :: WRAP_SOLVER - TYPE(ESMF_VM) :: VM -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Allocate the object that will store fundamental specifications -!*** of the domains and MPI task subdomains. This object will be -!*** used for coupling to external models. -!----------------------------------------------------------------------- -! - ALLOCATE(DOMAIN_DESCRIPTORS(1:NUM_DOMAINS_TOTAL),stat=ISTAT) -! - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate NMMB_DOMAIN_DESCRIPTORS' - WRITE(0,*)' stat=',ISTAT - WRITE(0,*)' ABORTING!' - CALL ESMF_Finalize(rc=RC,endflag=ESMF_END_ABORT) - ENDIF - - call ESMF_VMGetCurrent(vm, rc=RC) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out -! -!----------------------------------------------------------------------- -! - PI=ACOS(-1._KDBL) - DEG2RAD=PI/180._KDBL -! -!----------------------------------------------------------------------- -! - domains: DO N=1,NUM_DOMAINS_TOTAL -! -!----------------------------------------------------------------------- -!*** First save the domains' compute task layouts. -!----------------------------------------------------------------------- -! - ID_X=RANK_TO_DOMAIN_ID(N) !<-- The domain ID for the Nth domain -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INIT: Extract generation from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_X) & !<-- The config object - ,value =INPES & !<-- # of tasks in domain N in I direction - ,label ='inpes:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF(ID_X) & !<-- The config object - ,value =JNPES & !<-- # of tasks in domain N in J direction - ,label ='jnpes:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DOMAIN_DESCRIPTORS(ID_X)%INPES=INPES - DOMAIN_DESCRIPTORS(ID_X)%JNPES=JNPES -! -!----------------------------------------------------------------------- -!*** Save the IDs of all compute tasks on the domain. Also save -!*** a flag indicating whether or not the current task is on the -!*** given domain. -!----------------------------------------------------------------------- -! - NUM_PETS=INPES*JNPES - DOMAIN_DESCRIPTORS(ID_X)%NUM_PETS=NUM_PETS -! - ALLOCATE(DOMAIN_DESCRIPTORS(ID_X)%PET_MAP(1:NUM_PETS),stat=ISTAT) -! - DOMAIN_DESCRIPTORS(ID_X)%TASK_ACTIVE=.FALSE. -! - DO N1=1,NUM_PETS - PET_N=PETLIST_DOMAIN(N1,ID_X) - DOMAIN_DESCRIPTORS(ID_X)%PET_MAP(N1)=PET_N !<-- The task IDs on domain ID_X relative to all tasks. - IF(MYPE==PET_N)THEN - DOMAIN_DESCRIPTORS(ID_X)%TASK_ACTIVE=.TRUE. !<-- The current task lies on domain ID_X. - ENDIF - ENDDO -! -!----------------------------------------------------------------------- -!*** We need to extract the Solver component's internal state -!*** in order to obtain this domain's full coordinate limits. -!----------------------------------------------------------------------- -! - if(DOMAIN_DESCRIPTORS(ID_X)%TASK_ACTIVE) then - CALL ESMF_GridCompGetInternalState(nmm_int_state%DOMAIN_GRID_COMP(ID_X) & - ,WRAP_DOMAIN & - ,RC) -! - DOMAIN_INT_STATE=>wrap_domain%DOMAIN_INT_STATE -! - CALL ESMF_GridCompGetInternalState(domain_int_state%SOLVER_GRID_COMP & - ,WRAP_SOLVER & - ,RC) -! - SOLVER_INT_STATE=>wrap_solver%INT_STATE -! - minIndex(1) = solver_int_state%IDS - minIndex(2) = solver_int_state%JDS - maxIndex(1) = solver_int_state%IDE - maxIndex(2) = solver_int_state%JDE - endif - - ! Broadcast min/max Index from first active PET to all PETs on NMMB_GRID_COMP - call ESMF_VMBroadcast(vm, minIndex, 2, PETLIST_DOMAIN(1,ID_X), rc=RC) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - call ESMF_VMBroadcast(vm, maxIndex, 2, PETLIST_DOMAIN(1,ID_X), rc=RC) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - DOMAIN_DESCRIPTORS(ID_X)%INDX_MIN(1)=minIndex(1) - DOMAIN_DESCRIPTORS(ID_X)%INDX_MIN(2)=minIndex(2) - DOMAIN_DESCRIPTORS(ID_X)%INDX_MAX(1)=maxIndex(1) - DOMAIN_DESCRIPTORS(ID_X)%INDX_MAX(2)=maxIndex(2) - - write(tmpstr, *) "DOMAIN ID_X = ", ID_X - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - write(tmpstr, *) "INPES = ", DOMAIN_DESCRIPTORS(ID_X)%INPES - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - write(tmpstr, *) "JNPES = ", DOMAIN_DESCRIPTORS(ID_X)%JNPES - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - write(tmpstr, *) "MIN_INDEX = ", DOMAIN_DESCRIPTORS(ID_X)%INDX_MIN - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - write(tmpstr, *) "MAX_INDEX = ", DOMAIN_DESCRIPTORS(ID_X)%INDX_MAX - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - write(tmpstr, *) "TASK_ACTIVE = ", DOMAIN_DESCRIPTORS(ID_X)%TASK_ACTIVE - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - write(tmpstr, *) "NUM_PETS = ", DOMAIN_DESCRIPTORS(ID_X)%NUM_PETS - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - write(tmpstr, *) "PET_MAP = ", size(DOMAIN_DESCRIPTORS(ID_X)%PET_MAP), DOMAIN_DESCRIPTORS(ID_X)%PET_MAP - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - - call ESMF_LogFlush() -! -!----------------------------------------------------------------------- -!*** Get the central geographic lat/lon (radians) of the -!*** upper parent's grid. Also compute the angular increments of -!*** the grid cells in rotated lat/lon. -!----------------------------------------------------------------------- -! - IF(nmm_int_state%I_AM_A_FCST_TASK(ID_X))THEN - PHI0=solver_int_state%TPH0D*DEG2RAD - LAM0=solver_int_state%TLM0D*DEG2RAD - CENTRAL_LATLON(1)=PHI0 - CENTRAL_LATLON(2)=LAM0 - ENDIF -! - IF(NUM_DOMAINS_TOTAL>1.AND.ID_X==1)THEN - CALL ESMF_VMBroadcast(VM, CENTRAL_LATLON, 2, PETLIST_DOMAIN(1,1), rc=RC) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - PHI0=CENTRAL_LATLON(1) - LAM0=CENTRAL_LATLON(2) - ENDIF -! -!----------------------------------------------------------------------- -!*** Generate the angles to rotate vectors on the NMM-B native grid -!*** to geographic latitude/longitude. Also compute the grid cell -!*** areas and save the sea masks. These quantities are only valid -!*** on compute tasks. -!----------------------------------------------------------------------- -! - compute_tasks: IF(nmm_int_state%I_AM_A_FCST_TASK(ID_X))THEN -! - ITS=solver_int_state%ITS - ITE=solver_int_state%ITE - JTS=solver_int_state%JTS - JTE=solver_int_state%JTE -! -!----------------------------------------------------------------------- -!*** First allocate the arrays if not already done. -!----------------------------------------------------------------------- -! - IF(.NOT.ALLOCATED(DOMAIN_DESCRIPTORS(ID_X)%ROT_ANGLE))THEN -! - ALLOCATE(DOMAIN_DESCRIPTORS(ID_X)%ROT_ANGLE(ITS:ITE,JTS:JTE) & - ,stat=RC) - IF(RC/=0)THEN - WRITE(0,*)' Failed to allocate rotation angles in' & - ,' STORE_DOMAIN_DESCRIPTORS!' - WRITE(0,101)ID_X,RC - 101 FORMAT(' Domain #',I2,' RC=',I3) - WRITE(0,*)' ABORT!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT & - ,rc =RC ) - ENDIF -! - ALLOCATE(DOMAIN_DESCRIPTORS(ID_X)%CELL_AREA(ITS:ITE,JTS:JTE) & - ,stat=RC) - IF(RC/=0)THEN - WRITE(0,*)' Failed to allocate cell areas in' & - ,' STORE_DOMAIN_DESCRIPTORS!' - WRITE(0,102)ID_X,RC - 102 FORMAT(' Domain #',I2,' RC=',I3) - WRITE(0,*)' ABORT!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT & - ,rc =RC ) - ENDIF -! - ALLOCATE(DOMAIN_DESCRIPTORS(ID_X)%SEA_MASK(ITS:ITE,JTS:JTE) & - ,stat=RC) - IF(RC/=0)THEN - WRITE(0,*)' Failed to allocate sea mask in' & - ,' STORE_DOMAIN_DESCRIPTORS!' - WRITE(0,103)ID_X,RC - 103 FORMAT(' Domain #',I2,' RC=',I3) - WRITE(0,*)' ABORT!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT & - ,rc =RC ) - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -! - ELSE -! - ALLOCATE(DOMAIN_DESCRIPTORS(ID_X)%ROT_ANGLE(1,1) & !<-- Dummy allocation for write tasks - ,stat=RC) - DOMAIN_DESCRIPTORS(ID_X)%ROT_ANGLE(1,1)=-999. -! - ALLOCATE(DOMAIN_DESCRIPTORS(ID_X)%CELL_AREA(1,1) & !<-- Dummy allocation for write tasks - ,stat=RC) - DOMAIN_DESCRIPTORS(ID_X)%CELL_AREA(1,1)=-999. -! - ALLOCATE(DOMAIN_DESCRIPTORS(ID_X)%SEA_MASK(1,1) & !<-- Dummy allocation for write tasks - ,stat=RC) - DOMAIN_DESCRIPTORS(ID_X)%SEA_MASK(1,1)=-999. -! - ENDIF compute_tasks -! -!----------------------------------------------------------------------- -! - ENDDO domains -! -!----------------------------------------------------------------------- -! - END SUBROUTINE STORE_DOMAIN_DESCRIPTORS -! -!----------------------------------------------------------------------- -! - END SUBROUTINE NMM_INITIALIZE -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE NMM_RUN(NMM_GRID_COMP & - ,IMP_STATE & - ,EXP_STATE & - ,CLOCK_NEMS & - ,RC_RUN) -! -!----------------------------------------------------------------------- -!*** This routine executes the integration timeloop for the NMM -!*** through a call to subroutine NMM_INTEGRATE. -!*** That is preceded by digital filtering if it is requested. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_GridComp) :: NMM_GRID_COMP !<-- The NMM component -! - TYPE(ESMF_State) :: IMP_STATE & !<-- The NMM import state - ,EXP_STATE !<-- The NMM export state -! - TYPE(ESMF_Clock) :: CLOCK_NEMS !<-- The NEMS ESMF Clock -! - INTEGER,INTENT(OUT) :: RC_RUN !<-- Error return code -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: HDIFF_ON,MYPE_LOCAL & - ,N,NTIMESTEP & - ,YY,MM,DD,H,M,S,Sn,Sd -! - INTEGER(kind=KINT) :: ID_DOM,Domain_RunstepCount -! - INTEGER(kind=KINT) :: IERR,RC -! - INTEGER(kind=ESMF_KIND_I8) :: NTIMESTEP_ESMF -! - LOGICAL(kind=KLOG) :: ADVANCED,I_AM_ACTIVE,FREE_FORECAST & - ,LAST_GENERATION -! - TYPE(ESMF_Time) :: CURRTIME -! - REAL(kind=KDBL) :: gentimer3 -! - REAL(kind=KDBL),DIMENSION(99) :: gentimer1,gentimer2 -! - REAL(ESMF_KIND_R8) :: NTIMESTEP_ESMF_REAL !nuopc -! - CHARACTER(2) :: INT_TO_CHAR - CHARACTER(6) :: FMT='(I2.2)' -! - TYPE(ESMF_TimeInterval) :: Master_TimeStep - TYPE(ESMF_TimeInterval),POINTER :: Domain_TimeStep - TYPE(ESMF_Time) :: Master_CurrTime & - ,Master_StartTime & - ,Master_StopTime -! - type(esmf_timeinterval) :: timestep_esmf - type(esmf_time) :: starttime,stoptime - INTEGER(kind=KINT) :: iyear_fcst & - ,imonth_fcst & - ,iday_fcst & - ,ihour_fcst & - ,iminute_fcst & - ,isecond_fcst & - ,isecond_num & - ,isecond_den - type(esmf_time) :: ringtime - type(esmf_timeinterval) :: ringinterval - integer :: month,day -!!! integer(esmf_kind_i4) :: yy,mm,dd,h,m,s,sn,sd - integer(kind=kint) :: coupling_interval_int - real(kind=kfpt) :: coupling_interval_real - character(10) :: coupling_interval_char -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - btim0=timef() -! - gentimer1=0. - gentimer2=0. - gentimer3=0. -! - RC =ESMF_SUCCESS - RC_RUN=ESMF_SUCCESS -! - MESSAGE_CHECK='Print NEMS Clock at start of NMM_RUN' - if(I_AM_ROOT(RC)) then - CALL NMM_CLOCKPRINT(CLOCK_NEMS, 'Driver NMM Clock', rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) - endif -! -!----------------------------------------------------------------------- -!*** CLOCK_NEMS is used to control coupling of the NMM with other -!*** models via NUOPC. Here inside the NMM we need CLOCK_NEMS -!*** for its timestep to compute the number of NMM timesteps per -!*** coupling timestep. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_RUN: Get the NEMS Clock" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock =CLOCK_NEMS & - ,currTime =Master_CurrTime & !<-- The beginning time of the current coupling timestep (ESMF) - ,StartTime=Master_StartTime & - ,StopTime =Master_StopTime & !<-- The end time of the current coupling timestep (ESMF) - ,timestep =master_timestep & - ,rc =RC) -! -! call esmf_timeintervalget(master_timestep, h=h, m=m, s=s, rc=rc) -! write(0,*)' NMM_RUN CLOCK_NEMS timestep is h=',h,' m=',m,' s=',s -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - Master_TimeStep = Master_StopTime - Master_CurrTime !<-- The coupling timestep length (sec) (ESMF) - -! call esmf_timeintervalget(master_timestep, h=h, m=m, s=s, rc=rc) -! write(0,*)' master_timestep h=',h,' m=',m,' s=',s -! call esmf_timeget(master_stoptime, dd=dd, h=h, m=m, s=s, rc=rc) -! write(0,*)' master_stoptime d=',dd,' h=',h,' m=',m,' s=',s -! call esmf_timeget(master_currtime, dd=dd, h=h, m=m, s=s, rc=rc) -! write(0,*)' master_currtime d=',dd,' h=',h,' m=',m,' s=',s -! - DO N = 1, NUM_DOMAINS_TOTAL - ID_DOM=RANK_TO_DOMAIN_ID_ptr(N) - Domain_TimeStep=>nmm_int_state%TIMESTEP(ID_DOM) !<-- The timestep length (DT) of this Domain (sec) (ESMF) - Domain_RunstepCount = nint(Master_TimeStep/Domain_TimeStep) !<-- # of Domain timesteps per coupling timestep - -! if(I_AM_ROOT(RC)) print *, 'Domain_RunstepCount: ', Domain_RunstepCount -! call esmf_timeintervalget(domain_timestep, h=h, m=m, s=s, rc=rc) -! write(0,*)' domain_timestep h=',h,' m=',m,' s=',s -! write(0,*)' domain_runstepcount=',domain_runstepcount -! - END DO -! -!----------------------------------------------------------------------- -!*** Extract the digital filter specification from the configure file. -!*** If it is >0 then the user is asking that one of the filters be -!*** used prior to the free forecast. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Digital Filter: Extract Filter Method" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(1) & !<-- Use uppermost parent domain; all domains the same - ,value =FILTER_METHOD & !<-- The digital filter flag - ,label ='filter_method:' & !<-- Give this label's value to preceding variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** If the user has requested digital filtering then proceed with the -!*** selected method before performing the normal forecast integration. -!----------------------------------------------------------------------- -! - IF(FILTER_METHOD>0)THEN !<-- If true then filtering was selected -! -!----------------------------------------------------------------------- -! - DO N=1,NUM_GENS -! - MY_DOMAIN_ID=MY_DOMAINS_IN_GENS(N) !<-- Task's domain in generation N - - IF(MY_DOMAIN_ID>0)THEN !<-- Domain ID is 0 for 2-way nesting if task not in generation N -! - IMP_STATE_DOMAIN=>nmm_int_state%IMP_STATE_DOMAIN(MY_DOMAIN_ID) !<-- This domain's import state - IMP_STATE_CPL_NEST=>nmm_int_state%IMP_STATE_PC_CPL(MY_DOMAIN_ID) - FREE_FORECAST=.FALSE. -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_Run: Set Free Forecast flag in the Domain import state" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state - ,name ='Free Forecast' & !<-- The forecast is in the digital filter. - ,value=FREE_FORECAST & !<-- Value of filter method flag - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_Run: Set Free Forecast flag in the P-C import state" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- This DOMAIN component's import state - ,name ='Free Forecast' & !<-- The forecast is in the digital filter. - ,value=FREE_FORECAST & !<-- Value of filter method flag - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! - ENDDO -! -!----------------------------------------------------------------------- -! - CALL RUN_DIGITAL_FILTER_NMM !<-- See internal subroutine below. -! -!----------------------------------------------------------------------- -! - ENDIF -! -!----------------------------------------------------------------------- -!*** If there was digital filtering it is finished so set the filter -!*** method to 0 for the free forecast on all this task's domains. -!----------------------------------------------------------------------- -! - FILTER_METHOD=0 !<-- Filter is done or was not run so set method to 0 - I_AM_ACTIVE=.TRUE. !<-- All domains are active in the free forecast. -! - DO N=1,NUM_GENS -! - MY_DOMAIN_ID=MY_DOMAINS_IN_GENS(N) !<-- Task's domain in generation N - - IF(MY_DOMAIN_ID>0)THEN !<-- Domain ID is 0 for 2-way nesting if task not in generation N -! - IMP_STATE_DOMAIN=>nmm_int_state%IMP_STATE_DOMAIN(MY_DOMAIN_ID) !<-- This domain's import state - EXP_STATE_DOMAIN=>nmm_int_state%EXP_STATE_DOMAIN(MY_DOMAIN_ID) !<-- This domain's export state -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_Run: Set Filter Method to 0 in DOMAIN import state" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state - ,name ='Filter_Method' & !<-- Flag for filter method - ,value=FILTER_METHOD & !<-- Value of filter method flag - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_Run: Set domain active flag in DOMAIN export state" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE_DOMAIN & !<-- This DOMAIN component's export state - ,name ='I Am Active' & !<-- This domain is active in the forecast. - ,value=I_AM_ACTIVE & !<-- Value of filter method flag - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IMP_STATE_DOMAIN=>nmm_int_state%IMP_STATE_DOMAIN(MY_DOMAIN_ID) !<-- This domain's import state - IMP_STATE_CPL_NEST=>nmm_int_state%IMP_STATE_PC_CPL(MY_DOMAIN_ID) - FREE_FORECAST=.TRUE. -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_Run: Set Free Forecast flag in the Domain import state" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state - ,name ='Free Forecast' & !<-- The forecast is now free. - ,value=FREE_FORECAST & !<-- Is this the free forecast? - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_Run: Set Free Forecast flag in the P-C import state" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- This P-C coupler component's import state - ,name ='Free Forecast' & !<-- The forecast is now free. - ,value=FREE_FORECAST & !<-- Is this the free forecast? - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! - ENDDO -! -!----------------------------------------------------------------------- -!*** Prepare to run the free forecast. -!----------------------------------------------------------------------- -! - ALL_FORECASTS_COMPLETE=.FALSE. -! - DO N=1,NUM_GENS - IF(MY_DOMAINS_IN_GENS(N)>0)THEN - GENERATION_FINISHED(N)=.FALSE. - ELSE - GENERATION_FINISHED(N)=.TRUE. !<-- Task not in this generation; consider it finished. - ENDIF - ENDDO -! -!----------------------------------------------------------------------- -! - main_block: DO WHILE(.NOT.ALL_FORECASTS_COMPLETE) -! -!----------------------------------------------------------------------- -!*** The execution of the timestepping differs fundamentally between -!*** 1-way and 2-way nesting. In 1-way nesting each task belongs to -!*** only one domain and all domains run concurrently from the start -!*** to the end of the forecast. In 2-way nesting some or all tasks -!*** will lie in more than one domain but never more than one domain -!*** per generation therefore a loop over the generations must exist -!*** above partial timestep loops allowing tasks to return after the -!*** timestep is finished so they can participate in a different -!*** generation's timestep(s) before switching generations again. -!*** Thus NUM_GENS in generations_loop is a relevant integer >1 only -!*** for 2-way nesting. -!----------------------------------------------------------------------- -! - btim0=timef() - generations_loop: DO N=1,NUM_GENS !<-- A single iteration for 1-way nesting -! -!----------------------------------------------------------------------- -! - IF(GENERATION_FINISHED(N))THEN - CYCLE generations_loop - ENDIF -! - LAST_GENERATION=.FALSE. - IF(N==NUM_GENS)LAST_GENERATION=.TRUE. - MY_DOMAIN_ID=MY_DOMAINS_IN_GENS(N) !<-- Multiple generations only apply to 2-way nesting -! -!----------------------------------------------------------------------- -! - domain: IF(MY_DOMAIN_ID>0)THEN !<-- Domain ID is 0 for 2-way nesting if task not in generation N -! -!----------------------------------------------------------------------- -! - btim=timef() - DOMAIN_GRID_COMP=>nmm_int_state%DOMAIN_GRID_COMP(MY_DOMAIN_ID) !<-- This domain's ESMF component - IMP_STATE_DOMAIN=>nmm_int_state%IMP_STATE_DOMAIN(MY_DOMAIN_ID) !<-- Its import state - EXP_STATE_DOMAIN=>nmm_int_state%EXP_STATE_DOMAIN(MY_DOMAIN_ID) !<-- Its export state -! - I_AM_A_FCST_TASK =>nmm_int_state%I_AM_A_FCST_TASK(MY_DOMAIN_ID) !<-- Is this task a fcst task on this domain? - I_AM_LEAD_FCST_TASK=>nmm_int_state%I_AM_LEAD_FCST_TASK(MY_DOMAIN_ID) !<-- Is this the lead fcst task on this domain? -! -!----------------------------------------------------------------------- -!*** Again obtain current information from the Clock. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_Run: Get current time info from the Clock" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock =CLOCK_NMM(MY_DOMAIN_ID) & - ,starttime =STARTTIME & - ,currtime =CURRTIME & - ,advanceCount=NTIMESTEP_ESMF & - ,runduration =RUNDURATION & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** We need the local MPI task ID on the given NMM domain. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_RUN: Retrieve VM from DOMAIN Gridded Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGet(gridcomp=DOMAIN_GRID_COMP & !<-- The DOMAIN gridded component - ,vm =VM & !<-- Get the Virtual Machine from the DOMAIN component - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_RUN: Obtain the Local Task ID" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_VMGet(vm =VM & !<-- The virtual machine for this DOMAIN component - ,localpet=MYPE_LOCAL & !<-- Each task's local rank on this domain - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Set default value for horizontal diffusion flag (1-->ON). -!----------------------------------------------------------------------- -! - HDIFF_ON=1 -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_Run: Put Horizontal Diffusion Flag into DOMAIN import state" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state - ,name ='HDIFF' & !<-- Flag for diffusion on/off - ,value=HDIFF_ON & !<-- Value of horizontal diffusion flag - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Execute the normal forecast integration after dereferencing -!*** argument variables for this particular domain. -!----------------------------------------------------------------------- -! - COMM_TO_MY_PARENT=>comms_domain(MY_DOMAIN_ID)%TO_PARENT !<-- This domain's intracommunicator to its parent - NUM_CHILDREN =>nmm_int_state%NUM_CHILDREN(MY_DOMAIN_ID) !<-- How many children does this domain have? -! - NTIMESTEP=NTIMESTEP_ESMF !<-- This domains' current timestep count (integer) - TIMESTEP=>nmm_int_state%TIMESTEP(MY_DOMAIN_ID) !<-- This domain's fundamental timestep (sec) (ESMF) -! - CALL ESMF_TimeGet(CURRTIME, dd=DD, h=H, m=M, s=S, rc=RC) -! IF (I_AM_LEAD_FCST_TASK) WRITE(0,*) 'CURRTIME going into normal NMM_INTEG: ', DD, H, M, S -! - CALL ESMF_TimeGet(STARTTIME, dd=DD, h=H, m=M, s=S, rc=RC) -! IF (I_AM_LEAD_FCST_TASK) WRITE(0,*) 'STARTTIME going into normal NMM_INTEG: ', DD, H, M, S -! - INTERVAL_CLOCKTIME=>nmm_int_state%INTERVAL_CLOCKTIME(MY_DOMAIN_ID) !<-- Time interval for this domain's clocktime prints - INTERVAL_HISTORY =>nmm_int_state%INTERVAL_HISTORY(MY_DOMAIN_ID) !<-- Time interval for this domain's history output - INTERVAL_RESTART =>nmm_int_state%INTERVAL_RESTART(MY_DOMAIN_ID) !<-- Time interval for this domain's restart output -! - NPE_PRINT=>nmm_int_state%NPE_PRINT(MY_DOMAIN_ID) !<-- Print clocktimes from this task -! - RESTARTED_RUN=>nmm_int_state%RESTARTED_RUN(MY_DOMAIN_ID) - RST_OUT_00 =>nmm_int_state%RST_OUT_00(MY_DOMAIN_ID) -! - I_AM_A_NEST =>nmm_int_state%I_AM_A_NEST(MY_DOMAIN_ID) !<-- Is this domain a nest? -! - PARENT_CHILD_COUPLER_COMP=>nmm_int_state%PC_CPL_COMP(MY_DOMAIN_ID) !<-- The P-C coupler associated with this domain - IMP_STATE_CPL_NEST=>nmm_int_state%IMP_STATE_PC_CPL(MY_DOMAIN_ID) !<-- The P-C coupler import state - EXP_STATE_CPL_NEST=>nmm_int_state%EXP_STATE_PC_CPL(MY_DOMAIN_ID) !<-- The P-C coupler export state -! - PARENT_CHILD_TIME_RATIO=>nmm_int_state%P_C_TIME_RATIO(MY_DOMAIN_ID) !<-- Ratio of this domain's timestep to its parent's - MY_DOMAIN_MOVES=nmm_int_state%MY_DOMAIN_MOVES(MY_DOMAIN_ID) !<-- Does this domain move? - NEST_MODE=nmm_int_state%NEST_MODE(MY_DOMAIN_ID) !<-- Is this domain involved in any 2-way nesting? - NUM_2WAY_CHILDREN=>nmm_int_state%NUM_2WAY_CHILDREN(MY_DOMAIN_ID) !<-- How many 2-way children on this domain? - NTRACK=nmm_int_state%NTRACK(MY_DOMAIN_ID) !<-- Storm locator flag - NPHS=nmm_int_state%NPHS(MY_DOMAIN_ID) !<-- Physics timestep - ADVANCED=.FALSE. !<-- Does the integration advance? -! - gentimer1(my_domain_id)=gentimer1(my_domain_id)+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Call the timestepping routine. -!----------------------------------------------------------------------- -! if(mype_local==0)then -! write(0,77501)n,my_domain_id,mype_local,ntimestep -77501 format(' NMM_RUN before NMM_INTEGRATE generation #',i2,' my_domain_id=',i2,' mype_local=',i3,' ntimestep=',i5) -! endif -! - btim=timef() - CALL NMM_INTEGRATE(clock_direction ='Forward ' & - ,domain_grid_comp =DOMAIN_GRID_COMP & - ,imp_state_domain =IMP_STATE_DOMAIN & - ,exp_state_domain =EXP_STATE_DOMAIN & - ,clock_integrate =CLOCK_NMM(MY_DOMAIN_ID) & - ,currtime =CURRTIME & - ,starttime =STARTTIME & - ,timestep =TIMESTEP & - ,ntimestep_ext =NTIMESTEP & - ,runstepcount =Domain_RunstepCount & - ,dt =DT(MY_DOMAIN_ID) & - ,interval_clocktime =INTERVAL_CLOCKTIME & - ,interval_history =INTERVAL_HISTORY & - ,interval_restart =INTERVAL_RESTART & - ,filter_method =FILTER_METHOD & - ,restarted_run =RESTARTED_RUN & - ,rst_out_00 =RST_OUT_00 & - ,i_am_a_fcst_task =I_AM_A_FCST_TASK & - ,i_am_lead_fcst_task=I_AM_LEAD_FCST_TASK & - ,nesting =NESTING_NMM & - ,nest_mode =NEST_MODE & - ,task_mode =TASK_MODE & - ,i_am_a_nest =I_AM_A_NEST & - ,my_domain_id =MY_DOMAIN_ID & - ,num_children =NUM_CHILDREN & - ,num_2way_children =NUM_2WAY_CHILDREN & - ,parent_child_cpl =PARENT_CHILD_COUPLER_COMP & - ,imp_state_cpl_nest =IMP_STATE_CPL_NEST & - ,exp_state_cpl_nest =EXP_STATE_CPL_NEST & - ,par_chi_time_ratio =PARENT_CHILD_TIME_RATIO & - ,my_domain_moves =MY_DOMAIN_MOVES & - ,ntrack =NTRACK & - ,nphs =NPHS & - ,last_generation =LAST_GENERATION & - ,advanced =ADVANCED & - ,mype =MYPE_LOCAL & - ,comm_global =COMM_GLOBAL & - ,timers_domain =TIMERS(MY_DOMAIN_ID) & - ,npe_print =NPE_PRINT & - ,print_timing =PRINT_TIMING ) -! write(0,40403)n,my_domain_id,mype_local,ntimestep,advanced -40403 format(' NMM_RUN after NMM_INTEGRATE generation #',i2,' my_domain_id=',i2,' mype_local=',i4,' ntimestep=',i5,' advanced=',l1) -! if(mype_local==0)then -! call esmf_clockget(clock=clock_nmm(my_domain_id) & -! ,timeStep=timestep_esmf & -! ,startTime=starttime & -! ,currTime=currtime & -! ,stopTime=stoptime & -! ,rc=rc) -! call esmf_timeintervalget(timeinterval=timestep_esmf & -! ,s=isecond_fcst & -! ,sn=isecond_num & -! ,sd=isecond_den & -! ,rc=rc) -! write(0,55020)isecond_fcst,isecond_num,isecond_den -55020 format(' timestep: sec=',i4,' sn=',i3,' sd=',i3) -! call esmf_timeget(time=starttime & -! ,yy =iyear_fcst & -! ,mm =imonth_fcst & -! ,dd =iday_fcst & -! ,h =ihour_fcst & -! ,m =iminute_fcst & -! ,s =isecond_fcst & -! ,sN =isecond_num & -! ,sD =isecond_den & -! ,rc=rc) -! write(0,55021)iyear_fcst,imonth_fcst,iday_fcst & -! ,ihour_fcst,iminute_fcst & -! ,isecond_fcst,isecond_num,isecond_den -55021 format(' starttime: year=',i4,' month=',i2,' day=',i2,' hour=',i2 & - ,' min=',i2,' sec=',i2,' sn=',i3,' sd=',i3) -! call esmf_timeget(time=currtime & -! ,yy =iyear_fcst & -! ,mm =imonth_fcst & -! ,dd =iday_fcst & -! ,h =ihour_fcst & -! ,m =iminute_fcst & -! ,s =isecond_fcst & -! ,sN =isecond_num & -! ,sD =isecond_den & -! ,rc=rc) -! write(0,55022)iyear_fcst,imonth_fcst,iday_fcst & -! ,ihour_fcst,iminute_fcst & -! ,isecond_fcst,isecond_num,isecond_den -55022 format(' currtime: year=',i4,' month=',i2,' day=',i2,' hour=',i2 & - ,' min=',i2,' sec=',i2,' sn=',i3,' sd=',i3) -! call esmf_timeget(time=stoptime & -! ,yy =iyear_fcst & -! ,mm =imonth_fcst & -! ,dd =iday_fcst & -! ,h =ihour_fcst & -! ,m =iminute_fcst & -! ,s =isecond_fcst & -! ,sN =isecond_num & -! ,sD =isecond_den & -! ,rc=rc) -! write(0,55023)iyear_fcst,imonth_fcst,iday_fcst & -! ,ihour_fcst,iminute_fcst & -! ,isecond_fcst,isecond_num,isecond_den -55023 format(' stoptime: year=',i4,' month=',i2,' day=',i2,' hour=',i2 & - ,' min=',i2,' sec=',i2,' sn=',i3,' sd=',i3) -! endif -! - gentimer2(my_domain_id)=gentimer2(my_domain_id)+(timef()-btim) -! -!----------------------------------------------------------------------- -! - IF(ESMF_AlarmIsRinging(alarm=ALARM_CPL(MY_DOMAIN_ID) & !<-- Is it time to couple atmosphere and ocean? - ,rc =RC) & - .AND. ADVANCED ) THEN !<-- Did the integration actually advance? - GENERATION_FINISHED(N)=.TRUE. !<-- Task's fcst in generation N has finished this cpling interval -! write(0,23230)n -23230 format(' generation_finished true after NMM_INTEGRATE generation=',i2) -! else -! if(.not.generation_finished(n))then -! write(0,23231)n -23231 format(' generation_finished false after NMM_INTEGRATE generation=',i2) -! endif - ENDIF -! call esmf_alarmget(alarm=ALARM_CPL(MY_DOMAIN_ID) & -! ,ringtime=ringtime & -! ,ringinterval=ringinterval & -! ,rc=rc) -! call esmf_timeget(time=ringtime & -! ,yy=yy & -! ,mm=month & -! ,dd=dd & -! ,h=h & -! ,m=m & -! ,s=s & -! ,sn=sn & -! ,sd=sd) -! write(0,*)' ringtime: y=',yy,' mm=',month,' dd=',dd,' h=',h & -! ,' m=',m,' s=',s,' sn=',sn,'s d=',sd -! call esmf_timeintervalget(timeinterval=ringinterval & -! ,m=m & -! ,s=s & -! ,sn=sn & -! ,sd=sd) -! write(0,*)' ringinterval: m=',m,' s=',s,' sn=',sn,'s d=',sd -! -! write(0,55024)generation_finished(n),n -55024 format(' NMM_RUN end of domain loop generation_finished=',l1,' generation #',i2) -!----------------------------------------------------------------------- -! - ENDIF domain -! -! write(0,55025)generation_finished(n),n,num_gens -55025 format(' NMM_RUN after domain block generation_finished=',l1,' generation #',i2,' num_gens=',i2) -!----------------------------------------------------------------------- -!*** All tasks that are finished on all generations may leave. -!----------------------------------------------------------------------- -! - IF(ALL(GENERATION_FINISHED,NUM_GENS))THEN !<-- If true, all of this task's domains are finished - ALL_FORECASTS_COMPLETE=.TRUE. -! write(0,55125)n,generation_finished -55125 format(' all_forecasts_complete is true generation #',i2,' generation_finished=',3(1x,l1)) - EXIT generations_loop -! else -! write(0,55026)n,generation_finished -55026 format(' all_forecasts_complete is false generation #',i2,' generation_finished=',3(1x,l1)) - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO generations_loop -! - gentimer3=gentimer3+timef()-btim0 -! -!----------------------------------------------------------------------- -! - ENDDO main_block -! -!----------------------------------------------------------------------- -!*** Currently in coupled runs only the upper parent is coupled to -!*** the ocean. The nests receive SST updates from interpolation -!*** by the parent at the start of the upcoming coupling interval -!*** so now generate regrid interpolation weights between parent -!*** and nests for the nests' current positions. The weights are -!*** stored in DOMAIN_DESCRIPTORS. -!----------------------------------------------------------------------- -! - DO N=2,NUM_DOMAINS_TOTAL -! - MY_DOMAIN_ID=RANK_TO_DOMAIN_ID_PTR(N) !<-- The domain ID for the Nth domain -! - CALL NMMB_CreateRouteHandle(MY_DOMAIN_ID & - ,DOMAIN_DESCRIPTORS & - ,RC=RC) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out -! - ENDDO -! -!----------------------------------------------------------------------- -!*** Print clocktimes for: -!*** (1) Parent tasks learning if they can proceed with integration -!*** based on information from their parent and their children. -!*** (2) Child tasks sharing information as to whether their parent -!*** has sent an all clear signal that the parent has received -!*** 2-way exchange data from all its children thus the children -!*** may proceed with their integration. -!----------------------------------------------------------------------- -! - IF (NUM_GENS > 1) THEN - DO N=1,NUM_GENS -! - MY_DOMAIN_ID = MY_DOMAINS_IN_GENS(N) - IF(MY_DOMAIN_ID>0) THEN - IF (MY_DOMAIN_ID == 1) THEN - WRITE(0,896)my_domain_id, & - gentimer1(my_domain_id), & - gentimer2(my_domain_id), & - gentimer3, & - pbcst_tim(my_domain_id) - ELSE - WRITE(0,897)my_domain_id, & - gentimer1(my_domain_id), & - gentimer2(my_domain_id), & - gentimer3, & - cbcst_tim(my_domain_id) - ENDIF - ENDIF -! - ENDDO - ENDIF -! - 896 format (' For domain ',i2,' t1,t2,t3,pb ',4(g10.3)) - 897 format (' For domain ',i2,' t1,t2,t3,cb ',4(g10.3)) -! -!----------------------------------------------------------------------- -! - MESSAGE_CHECK='Print domain 1 Clock and NEMS Clock' - if(I_AM_ROOT(RC)) then - CALL NMM_CLOCKPRINT(CLOCK_NMM(1), 'Native NMM Clock', rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) - CALL NMM_CLOCKPRINT(CLOCK_NEMS, 'Driver NMM Clock', rc=RC) - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) - endif -! - ALL_FORECASTS_COMPLETE = .FALSE. ! Force the next time step to run - DO N = 1, NUM_DOMAINS_TOTAL - GENERATION_FINISHED(N) = .FALSE. - ENDDO -! -!----------------------------------------------------------------------- -! - IF(RC_RUN==ESMF_SUCCESS)THEN -! WRITE(0,*)' NMM_RUN succeeded' - ELSE - WRITE(0,*)' NMM_RUN failed RC_RUN=',RC_RUN - ENDIF -! -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -! - SUBROUTINE RUN_DIGITAL_FILTER_NMM -! -!----------------------------------------------------------------------- -!*** This routine executes the digital filters for the NMM -!*** if specified by the user. -!----------------------------------------------------------------------- -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: HDIFF_ON,MEAN_ON & - ,N,NTIMESTEP & - ,YY,MM,DD,H,M,S -! - INTEGER(kind=KINT) :: RC -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE,SAVE :: NDFISTEP -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: LOC_PAR_CHILD_TIME_RATIO -! - TYPE(ESMF_Clock),DIMENSION(:),ALLOCATABLE :: CLOCK_FILTER -! - TYPE(ESMF_Time) :: SDFITIME -! - TYPE(ESMF_Time),DIMENSION(:),ALLOCATABLE,SAVE :: HALFDFITIME -! - TYPE(ESMF_TimeInterval) :: TIMESTEP_FILTER -! - TYPE(ESMF_TimeInterval),DIMENSION(:),ALLOCATABLE,SAVE :: HALFDFIINTVAL -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Allocate the clocks to control the filtering. -!----------------------------------------------------------------------- -! - ALLOCATE(CLOCK_FILTER(1:NUM_DOMAINS_TOTAL),stat=RC) -! - IF(RC/=0)THEN - WRITE(0,*)' Error allocating filter clocks; rc=',RC - ENDIF -! -!----------------------------------------------------------------------- -! - ALLOCATE(HALFDFITIME(1:NUM_DOMAINS_TOTAL),stat=RC) - ALLOCATE(HALFDFIINTVAL(1:NUM_DOMAINS_TOTAL),stat=RC) -! - ALLOCATE(NDFISTEP(1:NUM_DOMAINS_TOTAL),stat=RC) -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - method_block: IF(FILTER_METHOD==1)THEN !<-- The DFL digital filter. -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** First loop through the generations to set preliminary variables -!*** specific to the domains in each generation. -!----------------------------------------------------------------------- -! - gens_f1_1: DO N=1,NUM_GENS -! - MY_DOMAIN_ID=MY_DOMAINS_IN_GENS(N) !<-- This task's (only) domain in generation N - IF(MY_DOMAIN_ID==0)CYCLE !<-- This task is not on a domain in generation N -! -!----------------------------------------------------------------------- -! - IMP_STATE_DOMAIN=>nmm_int_state%IMP_STATE_DOMAIN(MY_DOMAIN_ID) -! - FILT_TIMESTEP=>nmm_int_state%FILT_TIMESTEP(MY_DOMAIN_ID) !<-- This domain's timestep for digital filtering -! - I_AM_LEAD_FCST_TASK=>nmm_int_state%I_AM_LEAD_FCST_TASK(MY_DOMAIN_ID) !<-- Is this the lead fcst task on this domain? -! - IF(I_AM_LEAD_FCST_TASK)WRITE(0,*)' Beginning DFL Filter' -! -!----------------------------------------------------------------------- -!*** Extract the length of the half forward filter window -!*** for the DFL filter. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Digital Filter: Extract DFIHR Value for DFL" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- This domain's config object - ,value =DFIHR & !<-- Half foward filter window (s) - ,label ='nsecs_dfl:' & !<-- Give this label's value to preceding variable - ,rc =RC) -! - CALL ESMF_TimeIntervalSet(timeinterval=HALFDFIINTVAL(MY_DOMAIN_ID) & - ,s =DFIHR & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Is DFIHR divided evenly by the timestep? We cannot proceed -!*** unless it is. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="For DFL Get Actual Timestep from ESMF Value" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeIntervalGet(timeinterval=FILT_TIMESTEP & !<-- The filter timestep of this domain (sec) (ESMF) - ,s =S & !<-- Integer part of timestep - ,sn =Sn & !<-- Numerator of fractional part - ,sd =Sd & !<-- Denominator of fractional part - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NDFISTEP(MY_DOMAIN_ID)=INT( 0.1+DFIHR/(S+REAL(Sn)/REAL(Sd))) - DFIHR_CHK=INT(0.1+NDFISTEP(MY_DOMAIN_ID)*(S+REAL(Sn)/REAL(Sd))) -! - IF (DFIHR /= DFIHR_CHK) THEN - WRITE(0,*)' DFIHR=',DFIHR,' DFIHR_CHK=',DFIHR_CHK,' for domain #',my_domain_id - WRITE(0,*)' nsecs_dfl in configure MUST be integer multiple of the timestep' - WRITE(0,*)' User must reset the value' - WRITE(0,*)' ABORTING!!' - CALL ESMF_Finalize(rc=RC,endflag=ESMF_END_ABORT) - ENDIF -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="DFL Filter: Get current time info from NMM Clock" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock =CLOCK_NMM(MY_DOMAIN_ID) & - ,currtime=CURRTIME & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - STARTTIME=CURRTIME - HALFDFITIME(MY_DOMAIN_ID)=STARTTIME+HALFDFIINTVAL(MY_DOMAIN_ID) - SDFITIME=STARTTIME - DFITIME=HALFDFITIME(MY_DOMAIN_ID)+HALFDFIINTVAL(MY_DOMAIN_ID) -! - TIMESTEP_FILTER=FILT_TIMESTEP -! -!----------------------------------------------------------------------- -!*** In preparation for this filter's forward integration -!*** create a clock to control the filter's timestepping. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create the Clock for the DFL Digital Filter." -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CLOCK_FILTER(MY_DOMAIN_ID)=ESMF_ClockCreate(name ='CLOCK_DFL' & !<-- The clock for the DFI filter - ,timeStep =TIMESTEP_FILTER & !<-- The filter timestep in this domain - ,startTime=STARTTIME & !<-- Start time of filter - ,stopTime =DFITIME & !<-- Stop time of the filter - ,rc =RC) -! - CALL ESMF_ClockSet(clock =CLOCK_FILTER(MY_DOMAIN_ID) & - ,currtime =CURRTIME & - ,starttime=CURRTIME & - ,rc =RC) -! - CALL ESMF_TimeGet(CURRTIME, dd=DD, h=H, m=M, s=S, rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - HDIFF_ON=1 !<-- Forward integration so we want horiz diffusion. - MEAN_ON =0 -! - CALL ESMF_AttributeSet(state=IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state for filter - ,name ='Clock_Direction' & - ,value='Forward ' & - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state for filter - ,name ='HDIFF' & !<-- Flag for horizontal diffusion on/off - ,value=HDIFF_ON & !<-- Value of horizontal diffusion flag - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state for filter - ,name ='MEAN_ON' & - ,value=MEAN_ON & - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state for filter - ,name ='NDFISTEP' & - ,value=NDFISTEP(MY_DOMAIN_ID) & - ,rc =RC) -! -!----------------------------------------------------------------------- -! - ENDDO gens_f1_1 -! -!----------------------------------------------------------------------- -!*** Execute the DFL filter's integration for all domains after -!*** dereferencing argument variables for the given domain. -!*** See fuller explanation in subroutine NMM_RUN. -!----------------------------------------------------------------------- -! - dfl_int: DO WHILE(.NOT.ALL_FORECASTS_COMPLETE) -! -!----------------------------------------------------------------------- -! - gens_f1_2: DO N=1,NUM_GENS -! -!----------------------------------------------------------------------- -! - IF(GENERATION_FINISHED(N))THEN - CYCLE gens_f1_2 - ENDIF -! - LAST_GENERATION=.FALSE. - IF(N==NUM_GENS)LAST_GENERATION=.TRUE. -! - MY_DOMAIN_ID=MY_DOMAINS_IN_GENS(N) !<-- This task's (only) domain in generation N - IF(MY_DOMAIN_ID==0)CYCLE !<-- This task is not on a domain in generation N -! - DOMAIN_GRID_COMP=>nmm_int_state%DOMAIN_GRID_COMP(MY_DOMAIN_ID) !<-- This domain's ESMF component -! -!----------------------------------------------------------------------- -!*** We need the task's rank on the current domain. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_RUN: Retrieve VM from DOMAIN Gridded Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGet(gridcomp=DOMAIN_GRID_COMP & !<-- The DOMAIN gridded component - ,vm =VM & !<-- Get the Virtual Machine from the DOMAIN component - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_RUN: Obtain the Local Task ID" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_VMGet(vm =VM & !<-- The virtual machine for this DOMAIN component - ,localpet=MYPE_LOCAL & !<-- Each task's local rank on this domain - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - IMP_STATE_DOMAIN=>nmm_int_state%IMP_STATE_DOMAIN(MY_DOMAIN_ID) !<-- Its import state - EXP_STATE_DOMAIN=>nmm_int_state%EXP_STATE_DOMAIN(MY_DOMAIN_ID) !<-- Its export state -! - I_AM_A_FCST_TASK =>nmm_int_state%I_AM_A_FCST_TASK(MY_DOMAIN_ID) !<-- Is this task a fcst task on this domain? - I_AM_LEAD_FCST_TASK=>nmm_int_state%I_AM_LEAD_FCST_TASK(MY_DOMAIN_ID) !<-- Is this the lead fcst task on this domain? -! - FILT_TIMESTEP=>nmm_int_state%FILT_TIMESTEP(MY_DOMAIN_ID) !<-- This domain's timestep for digital filtering -! - COMM_TO_MY_PARENT=>comms_domain(MY_DOMAIN_ID)%TO_PARENT !<-- This domain's intracommunicator to its parent - NUM_CHILDREN=>nmm_int_state%NUM_CHILDREN(MY_DOMAIN_ID) !<-- How many children does this domain have? -! - NPE_PRINT=>nmm_int_state%NPE_PRINT(MY_DOMAIN_ID) !<-- Print clocktimes from this task -! - RESTARTED_RUN=>nmm_int_state%RESTARTED_RUN(MY_DOMAIN_ID) - RST_OUT_00=>nmm_int_state%RST_OUT_00(MY_DOMAIN_ID) -! - I_AM_A_NEST=>nmm_int_state%I_AM_A_NEST(MY_DOMAIN_ID) !<-- Is this domain a nest? -! - PARENT_CHILD_COUPLER_COMP=>nmm_int_state%PC_CPL_COMP(MY_DOMAIN_ID) !<-- The P-C coupler associated with this domain - IMP_STATE_CPL_NEST=>nmm_int_state%IMP_STATE_PC_CPL(MY_DOMAIN_ID) !<-- The P-C coupler import state - EXP_STATE_CPL_NEST=>nmm_int_state%EXP_STATE_PC_CPL(MY_DOMAIN_ID) !<-- The P-C coupler export state -! - PARENT_CHILD_TIME_RATIO=>nmm_int_state%P_C_TIME_RATIO(MY_DOMAIN_ID) !<-- Ratio of this domain's timestep to its parent's - MY_DOMAIN_MOVES=nmm_int_state%MY_DOMAIN_MOVES(MY_DOMAIN_ID) !<-- Does this domain move? - NEST_MODE=nmm_int_state%NEST_MODE(MY_DOMAIN_ID) !<-- Is this domain involved in any 2-way nesting? - NUM_2WAY_CHILDREN=>nmm_int_state%NUM_2WAY_CHILDREN(MY_DOMAIN_ID) !<-- How many 2-way children on this domain? - NTRACK=nmm_int_state%NTRACK(MY_DOMAIN_ID) !<-- Storm locator flag - NPHS=nmm_int_state%NPHS(MY_DOMAIN_ID) !<-- Physics timestep -! -!----------------------------------------------------------------------- -!*** Obtain current information from the filter clock. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="DFL: Get time info from the Clock" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock =CLOCK_FILTER(MY_DOMAIN_ID) & - ,starttime =STARTTIME & - ,currtime =CURRTIME & - ,advanceCount=NTIMESTEP_ESMF & -! ,runTimeStepCount=NTIMESTEP_ESMF_REAL & - ,runduration =RUNDURATION & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NTIMESTEP=NTIMESTEP_ESMF -! NTIMESTEP=NINT(NTIMESTEP_ESMF_REAL)-1 !<-- ESMF timestep count starts with 1 - TIMESTEP=>nmm_int_state%TIMESTEP(MY_DOMAIN_ID) -! -!----------------------------------------------------------------------- -! - CALL NMM_INTEGRATE(clock_direction ='Forward ' & !<-- This filter only integrates forward - ,domain_grid_comp =DOMAIN_GRID_COMP & - ,imp_state_domain =IMP_STATE_DOMAIN & - ,exp_state_domain =EXP_STATE_DOMAIN & - ,clock_integrate =CLOCK_FILTER(MY_DOMAIN_ID) & - ,currtime =CURRTIME & - ,starttime =STARTTIME & - ,timestep =FILT_TIMESTEP & - ,ntimestep_ext =NTIMESTEP & - ,runstepcount =Domain_RunstepCount & - ,dt =FILT_DT(MY_DOMAIN_ID) & - ,filter_method =FILTER_METHOD & - ,halfdfiintval =HALFDFIINTVAL(MY_DOMAIN_ID) & - ,halfdfitime =HALFDFITIME(MY_DOMAIN_ID) & - ,restarted_run =RESTARTED_RUN & - ,rst_out_00 =RST_OUT_00 & - ,i_am_a_fcst_task =I_AM_A_FCST_TASK & - ,i_am_lead_fcst_task=I_AM_LEAD_FCST_TASK & - ,nesting =NESTING_NMM & - ,nest_mode =NEST_MODE & - ,task_mode =TASK_MODE & - ,i_am_a_nest =I_AM_A_NEST & - ,my_domain_id =MY_DOMAIN_ID & - ,num_children =NUM_CHILDREN & - ,num_2way_children =NUM_2WAY_CHILDREN & - ,parent_child_cpl =PARENT_CHILD_COUPLER_COMP & - ,imp_state_cpl_nest =IMP_STATE_CPL_NEST & - ,exp_state_cpl_nest =EXP_STATE_CPL_NEST & - ,par_chi_time_ratio =PARENT_CHILD_TIME_RATIO & - ,my_domain_moves =MY_DOMAIN_MOVES & - ,ntrack =NTRACK & - ,nphs =NPHS & - ,last_generation =LAST_GENERATION & - ,advanced =ADVANCED & - ,mype =MYPE_LOCAL & - ,comm_global =COMM_GLOBAL & - ,generation_finished=GENERATION_FINISHED(N) & - ,timers_domain =TIMERS(MY_DOMAIN_ID) & - ,npe_print =NPE_PRINT & - ,print_timing =PRINT_TIMING ) -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** All tasks that are finished on all generations may leave. -!----------------------------------------------------------------------- -! - IF(ALL(GENERATION_FINISHED,NUM_GENS))THEN !<-- If true, all of this task's domains are finished - ALL_FORECASTS_COMPLETE=.TRUE. - EXIT gens_f1_2 - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO gens_f1_2 -! -!----------------------------------------------------------------------- -! - ENDDO dfl_int -! -!----------------------------------------------------------------------- -!*** The filter is now finished integrating. Reset the actual -!*** integration clock. -!----------------------------------------------------------------------- -! - gens_f1_3: DO N=1,NUM_GENS -! - MY_DOMAIN_ID=MY_DOMAINS_IN_GENS(N) !<-- This task's (only) domain in generation N - IF(MY_DOMAIN_ID==0)CYCLE !<-- This task is not on a domain in generation N -! - I_AM_LEAD_FCST_TASK=>nmm_int_state%I_AM_LEAD_FCST_TASK(MY_DOMAIN_ID) !<-- Is this the lead fcst task on this domain? - FILT_TIMESTEP=>nmm_int_state%FILT_TIMESTEP(MY_DOMAIN_ID) !<-- This domain's timestep for digital filtering -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="DFL: Get CURRTIME from Filter Clock When Finished" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock =CLOCK_FILTER(MY_DOMAIN_ID) & - ,currtime =CURRTIME & -! ,advanceCount =NTIMESTEP_ESMF & - ,runTimeStepCount=NTIMESTEP_ESMF_REAL & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeGet(CURRTIME, dd=DD, h=H, m=M, s=S, rc=RC) - CURRTIME=CURRTIME+FILT_TIMESTEP -! - CALL ESMF_TimeGet(CURRTIME, dd=DD, h=H, m=M, s=S, rc=RC) - STARTTIME=CURRTIME-HALFDFIINTVAL(MY_DOMAIN_ID) !<-- Start time set to halfway point of filter period - CALL ESMF_TimeGet(STARTTIME, dd=DD, h=H, m=M, s=S, rc=RC) -! -! NTIMESTEP=NTIMESTEP_ESMF - NTIMESTEP=NINT(NTIMESTEP_ESMF_REAL)-1 - NTIMESTEP=NTIMESTEP+1 -! NTIMESTEP_ESMF=NTIMESTEP - NTIMESTEP_ESMF_REAL=REAL(NTIMESTEP)+1 -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Clock After DFL Filter" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockSet(clock =CLOCK_NMM(MY_DOMAIN_ID) & !<-- For DFL filter, the starttime of the free forecast -! ,starttime =STARTTIME & ! moves ahead to the halfway point of the filter - ,currtime =CURRTIME & ! interval. -! ,advancecount =NTIMESTEP_ESMF & - ,runTimeStepCount=NTIMESTEP+1 & !<-- ESMF timestep count starts with 1, not 0 - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - IF(I_AM_LEAD_FCST_TASK) write(0,*) 'steps to increment for DFL: ', RESTVAL/DT(MY_DOMAIN_ID) -! -!nuopc NTIMESTEP_ESMF=NTIMESTEP_ESMF*(FILT_DT(MY_DOMAIN_ID)/DT(MY_DOMAIN_ID))+0.1 -!nuopc NTIMESTEP_ESMF=NTIMESTEP_ESMF + (RESTVAL/DT(MY_DOMAIN_ID)) - NTIMESTEP=NTIMESTEP*(FILT_DT(MY_DOMAIN_ID)/DT(MY_DOMAIN_ID))+0.1 - NTIMESTEP=NTIMESTEP + (RESTVAL/DT(MY_DOMAIN_ID)) -! - CALL ESMF_ClockSet(clock =CLOCK_NMM(MY_DOMAIN_ID) & !<-- The NEMS ESMF Clock - ,starttime =STARTTIME & !<-- The simulation start time (ESMF) -! ,advanceCount =NTIMESTEP_ESMF & - ,runTimeStepCount=NTIMESTEP+1 & - ,rc =RC) -! -!----------------------------------------------------------------------- -! - IF(I_AM_LEAD_FCST_TASK)THEN - WRITE(0,*)' Completed filter method ',filter_method - WRITE(0,*)' Now reset filter method to 0.' - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO gens_f1_3 -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - ELSEIF(FILTER_METHOD==2)THEN method_block !<-- The DDFI digital filter. -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** First loop through the generations to set preliminary variables -!*** specific to the domains in them. -!----------------------------------------------------------------------- -! - gens_f2_1: DO N=1,NUM_GENS -! - MY_DOMAIN_ID=MY_DOMAINS_IN_GENS(N) !<-- This task's (only) domain in generation N - IF(MY_DOMAIN_ID==0)CYCLE !<-- This task is not on a domain in generation N -! -!----------------------------------------------------------------------- -! - FILT_TIMESTEP=>nmm_int_state%FILT_TIMESTEP(MY_DOMAIN_ID) !<-- This domain's timestep for digital filtering -! - I_AM_LEAD_FCST_TASK=>nmm_int_state%I_AM_LEAD_FCST_TASK(MY_DOMAIN_ID) !<-- Is this the lead fcst task on this domain? -! - IF(I_AM_LEAD_FCST_TASK)WRITE(0,*)' Beginning DDFI Filter' -! -!----------------------------------------------------------------------- -! -!-------------------------------- -!*** The initial backward step. -!-------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Digital Filter: Extract DFIHR Value for DDFI" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The config object - ,value = DFIHR & !<-- Half foward filter window (s) - ,label ='nsecs_bckddfi:' & !<-- Time duration of this backward part of filter - ,rc =RC) -! - CALL ESMF_TimeIntervalSet(timeinterval=HALFDFIINTVAL(MY_DOMAIN_ID) & - ,s =DFIHR & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Is DFIHR divided evenly by the timestep? We cannot proceed -!*** unless it is. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="For DDFI Get Actual Timestep from ESMF Value" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeIntervalGet(timeinterval=FILT_TIMESTEP & !<-- The filter timestep on this domain (sec) (ESMF) - ,s =S & - ,sn =Sn & - ,sd =Sd & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NDFISTEP(MY_DOMAIN_ID)=INT( 0.1+DFIHR/(S+REAL(Sn)/REAL(Sd))) - DFIHR_CHK=INT(0.1+NDFISTEP(MY_DOMAIN_ID)*(S+REAL(Sn)/REAL(Sd))) -! - IF (DFIHR_CHK /= DFIHR) THEN - WRITE(0,*)' DFIHR=',DFIHR,' DFIHR_CHK=',DFIHR_CHK,' on domain #',my_domain_id - WRITE(0,*)'nsecs_bckddfi in configure MUST be integer multiple of the timestep' - WRITE(0,*)' User must reset the value' - WRITE(0,*)' *** ABORTING MODEL RUN *** ' - CALL ESMF_Finalize(RC=RC,endflag=ESMF_END_ABORT) - ENDIF -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="DDFI Filter: Get current time info from NMM Clock" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock =CLOCK_NMM(MY_DOMAIN_ID) & - ,currtime=CURRTIME & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - STARTTIME=CURRTIME - HALFDFITIME(MY_DOMAIN_ID)=STARTTIME-HALFDFIINTVAL(MY_DOMAIN_ID) - DFITIME=HALFDFITIME(MY_DOMAIN_ID) -! - TIMESTEP_FILTER=-FILT_TIMESTEP !<-- Prepare for backward part of integration -! -!----------------------------------------------------------------------- -!*** In preparation for this filter's forward integration -!*** create a clock to control the filter's timestepping. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create the Clock for the DDFI Digital Filter." -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CLOCK_FILTER(MY_DOMAIN_ID)=ESMF_ClockCreate(name ='CLOCK_DDFI' & !<-- The Clock for the DDFI filter - ,timeStep =TIMESTEP_FILTER & !<-- The filter timestep in this component - ,startTime=STARTTIME & !<-- Start time of filter - ,stopTime =DFITIME & !<-- Stop time of the filter - ,rc =RC) -! - CALL ESMF_ClockSet(clock =CLOCK_FILTER(MY_DOMAIN_ID) & - ,currtime =CURRTIME & - ,starttime=CURRTIME & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - HDIFF_ON=0 !<-- Turn off horiz diffusion for backward integration. - MEAN_ON =0 -! - IMP_STATE_DOMAIN=>nmm_int_state%IMP_STATE_DOMAIN(MY_DOMAIN_ID) -! - IF(I_AM_LEAD_FCST_TASK)WRITE(0,*)' Set Clock direction to backward for DDFI' -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="For DDFI Set Import State Attributes for Backward Integration" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state - ,name ='Clock_Direction' & - ,value='Bckward ' & - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state for filter - ,name ='HDIFF' & !<-- Flag for horizontal diffusion on/off - ,value=HDIFF_ON & !<-- Value of horizontal diffusion flag - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state for filter - ,name ='MEAN_ON' & - ,value=MEAN_ON & - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state for filter - ,name ='NDFISTEP' & - ,value=NDFISTEP(MY_DOMAIN_ID) & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - ENDDO gens_f2_1 -! -!----------------------------------------------------------------------- -!*** Execute the DDFI filter's backward integration for all domains -!*** after dereferencing argument variables for the given domain. -!*** See fuller explanation in subroutine NMM_RUN. -!----------------------------------------------------------------------- -! - ddfi_backward: DO WHILE(.NOT.ALL_FORECASTS_COMPLETE) -! -!----------------------------------------------------------------------- -! - gens_f2_2: DO N=1,NUM_GENS -! -!----------------------------------------------------------------------- -! - IF(GENERATION_FINISHED(N))THEN - CYCLE gens_f2_2 - ENDIF -! - LAST_GENERATION=.FALSE. - IF(N==NUM_GENS)LAST_GENERATION=.TRUE. -! - MY_DOMAIN_ID=MY_DOMAINS_IN_GENS(N) !<-- This task's (only) domain in generation N - IF(MY_DOMAIN_ID==0)CYCLE !<-- This task is not on a domain in generation N -! - DOMAIN_GRID_COMP=>nmm_int_state%DOMAIN_GRID_COMP(MY_DOMAIN_ID) !<-- This domain's ESMF component -! -!----------------------------------------------------------------------- -!*** We need the task's rank on the current domain. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_RUN: Retrieve VM from DOMAIN Gridded Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGet(gridcomp=DOMAIN_GRID_COMP & !<-- The DOMAIN gridded component - ,vm =VM & !<-- Get the Virtual Machine from the DOMAIN component - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_RUN: Obtain the Local Task ID" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_VMGet(vm =VM & !<-- The virtual machine for this DOMAIN component - ,localpet=MYPE_LOCAL & !<-- Each task's local rank on this domain - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - IMP_STATE_DOMAIN=>nmm_int_state%IMP_STATE_DOMAIN(MY_DOMAIN_ID) !<-- Its import state - EXP_STATE_DOMAIN=>nmm_int_state%EXP_STATE_DOMAIN(MY_DOMAIN_ID) !<-- Its export state -! - I_AM_A_FCST_TASK =>nmm_int_state%I_AM_A_FCST_TASK(MY_DOMAIN_ID) !<-- Is this task a fcst task on this domain? - I_AM_LEAD_FCST_TASK=>nmm_int_state%I_AM_LEAD_FCST_TASK(MY_DOMAIN_ID) !<-- Is this the lead fcst task on this domain? -! - FILT_TIMESTEP=>nmm_int_state%FILT_TIMESTEP(MY_DOMAIN_ID) !<-- This domain's timestep for digital filtering -! - COMM_TO_MY_PARENT=>comms_domain(MY_DOMAIN_ID)%TO_PARENT !<-- This domain's intracommunicator to its parent - NUM_CHILDREN=>nmm_int_state%NUM_CHILDREN(MY_DOMAIN_ID) !<-- How many children does this domain have? -! - NPE_PRINT=>nmm_int_state%NPE_PRINT(MY_DOMAIN_ID) !<-- Print clocktimes from this task -! - RESTARTED_RUN=>nmm_int_state%RESTARTED_RUN(MY_DOMAIN_ID) - RST_OUT_00=>nmm_int_state%RST_OUT_00(MY_DOMAIN_ID) -! - I_AM_A_NEST=>nmm_int_state%I_AM_A_NEST(MY_DOMAIN_ID) !<-- Is this domain a nest? -! - PARENT_CHILD_COUPLER_COMP=>nmm_int_state%PC_CPL_COMP(MY_DOMAIN_ID) !<-- The P-C coupler associated with this domain - IMP_STATE_CPL_NEST=>nmm_int_state%IMP_STATE_PC_CPL(MY_DOMAIN_ID) !<-- The P-C coupler import state - EXP_STATE_CPL_NEST=>nmm_int_state%EXP_STATE_PC_CPL(MY_DOMAIN_ID) !<-- The P-C coupler export state -! - PARENT_CHILD_TIME_RATIO=>nmm_int_state%P_C_TIME_RATIO(MY_DOMAIN_ID) !<-- Ratio of this domain's timestep to its parent's - MY_DOMAIN_MOVES=nmm_int_state%MY_DOMAIN_MOVES(MY_DOMAIN_ID) !<-- Does this domain move? - NEST_MODE=nmm_int_state%NEST_MODE(MY_DOMAIN_ID) !<-- Is this domain involved in any 2-way nesting? - NUM_2WAY_CHILDREN=>nmm_int_state%NUM_2WAY_CHILDREN(MY_DOMAIN_ID) !<-- How many 2-way children on this domain? - NTRACK=nmm_int_state%NTRACK(MY_DOMAIN_ID) !<-- Storm locator flag - NPHS=nmm_int_state%NPHS(MY_DOMAIN_ID) !<-- Physics timestep -! -!----------------------------------------------------------------------- -!*** Obtain current information from the filter clock. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="DDFI Backward: Get time info from the Clock" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock =CLOCK_FILTER(MY_DOMAIN_ID) & - ,starttime =STARTTIME & - ,currtime =CURRTIME & -! ,advanceCount =NTIMESTEP_ESMF & - ,runTimeStepCount=NTIMESTEP_ESMF_REAL & - ,runduration =RUNDURATION & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! NTIMESTEP=NTIMESTEP_ESMF - NTIMESTEP=NINT(NTIMESTEP_ESMF_REAL)-1 -! -!----------------------------------------------------------------------- -! - CALL NMM_INTEGRATE(clock_direction ='Bckward ' & !<-- The initial backward piece of the filter - ,domain_grid_comp =DOMAIN_GRID_COMP & - ,imp_state_domain =IMP_STATE_DOMAIN & - ,exp_state_domain =EXP_STATE_DOMAIN & - ,clock_integrate =CLOCK_FILTER(MY_DOMAIN_ID) & - ,currtime =CURRTIME & - ,starttime =STARTTIME & - ,timestep =FILT_TIMESTEP & - ,ntimestep_ext =NTIMESTEP & - ,runstepcount =Domain_RunstepCount & - ,dt =FILT_DT(MY_DOMAIN_ID) & - ,filter_method =FILTER_METHOD & - ,ndfistep =NDFISTEP(MY_DOMAIN_ID) & - ,restarted_run =RESTARTED_RUN & - ,rst_out_00 =RST_OUT_00 & - ,i_am_a_fcst_task =I_AM_A_FCST_TASK & - ,i_am_lead_fcst_task=I_AM_LEAD_FCST_TASK & - ,nesting =NESTING_NMM & - ,nest_mode =NEST_MODE & - ,task_mode =TASK_MODE & - ,i_am_a_nest =I_AM_A_NEST & - ,my_domain_id =MY_DOMAIN_ID & - ,num_children =NUM_CHILDREN & - ,num_2way_children =NUM_2WAY_CHILDREN & - ,parent_child_cpl =PARENT_CHILD_COUPLER_COMP & - ,imp_state_cpl_nest =IMP_STATE_CPL_NEST & - ,exp_state_cpl_nest =EXP_STATE_CPL_NEST & - ,par_chi_time_ratio =PARENT_CHILD_TIME_RATIO & - ,my_domain_moves =MY_DOMAIN_MOVES & - ,ntrack =NTRACK & - ,nphs =NPHS & - ,last_generation =LAST_GENERATION & - ,advanced =ADVANCED & - ,mype =MYPE_LOCAL & - ,comm_global =COMM_GLOBAL & - ,generation_finished=GENERATION_FINISHED(N) & - ,timers_domain =TIMERS(MY_DOMAIN_ID) & - ,npe_print =NPE_PRINT & - ,print_timing =PRINT_TIMING ) -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** All tasks that are finished on all generations may leave. -!----------------------------------------------------------------------- -! - IF(ALL(GENERATION_FINISHED,NUM_GENS))THEN !<-- If true, all of this task's domains are finished - ALL_FORECASTS_COMPLETE=.TRUE. - EXIT gens_f2_2 - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO gens_f2_2 -! -!----------------------------------------------------------------------- -! - ENDDO ddfi_backward -! -!----------------------------------------------------------------------- -!*** Reset the completion flags for the forward integration. -!----------------------------------------------------------------------- -! - IF(NUM_GENS==1)THEN - GENERATION_FINISHED(1)=.FALSE. -! - ELSE - DO N=1,NUM_GENS - IF(MY_DOMAINS_IN_GENS(N)>0)THEN - GENERATION_FINISHED(N)=.FALSE. - ELSE - GENERATION_FINISHED(N)=.TRUE. !<-- Task not in this generation; consider it finished. - ENDIF - ENDDO -! - ENDIF -! - ALL_FORECASTS_COMPLETE=.FALSE. -! -!----------------------------------------------------------------------- -!*** Prepare to do the final forward step of the DDFI filter. -!----------------------------------------------------------------------- -! - gens_f2_3: DO N=1,NUM_GENS -! - MY_DOMAIN_ID=MY_DOMAINS_IN_GENS(N) !<-- This task's (only) domain in generation N - IF(MY_DOMAIN_ID==0)CYCLE !<-- This task is not on a domain in generation N -! -!----------------------------------------------------------------------- -! - NTIMESTEP=0 -!nuopc NTIMESTEP_ESMF=NTIMESTEP - NTIMESTEP_ESMF_REAL=REAL(NTIMESTEP)+1 !<-- ESMF timestep count starts with 1, not 0 -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="For DDFI Get DFIHR for Forward Integration" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The config object for this domain - ,value =DFIHR & !<-- Time duration of this forward integration - ,label ='nsecs_fwdddfi:' & !<-- The configure name - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="For Forward Part of DDFI Set HALFDFIINTVAL" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeIntervalSet(timeinterval=HALFDFIINTVAL(MY_DOMAIN_ID) & - ,s =DFIHR & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="For Forward Part of DDFI Get Starttime" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock =CLOCK_FILTER(MY_DOMAIN_ID) & !<-- The Clock for the DFI filter - ,startTime=STARTTIME & !<-- The simulation start time (ESMF) - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - HALFDFITIME(MY_DOMAIN_ID)=CURRTIME+HALFDFIINTVAL(MY_DOMAIN_ID) - DFITIME=HALFDFITIME(MY_DOMAIN_ID)+HALFDFIINTVAL(MY_DOMAIN_ID) -! - FILT_TIMESTEP=>nmm_int_state%FILT_TIMESTEP(MY_DOMAIN_ID) !<-- This domain's timestep for digital filtering - TIMESTEP_FILTER=FILT_TIMESTEP !<-- Prepare for forward part of integration -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Reset the Clock for Forward DDFI Digital Filter." -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockSet(clock =CLOCK_FILTER(MY_DOMAIN_ID) & !<-- Reset the stoptime for the forward part of the filter - ,timeStep =TIMESTEP_FILTER & !<-- The fundamental timestep in this component - ,starttime =CURRTIME & !<-- Start backward integration at current time - ,stoptime =DFITIME & !<-- End backward integration at DFITIME -! ,advancecount =NTIMESTEP_ESMF & - ,runTimeStepCount=NTIMESTEP+1 & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - HDIFF_ON=1 !<-- Forward integration so we want horiz diffusion. - MEAN_ON =0 -! - IMP_STATE_DOMAIN=>nmm_int_state%IMP_STATE_DOMAIN(MY_DOMAIN_ID) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="For DDFI Set Import State Attributes for Forward Integration" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state for filter - ,name ='Clock_Direction' & - ,value='Forward ' & - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state for filter - ,name ='HDIFF' & !<-- Flag for horizontal diffusion on/off - ,value=HDIFF_ON & !<-- Value of horizontal diffusion flag - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state for filter - ,name ='MEAN_ON' & - ,value=MEAN_ON & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - ENDDO gens_f2_3 -! -!----------------------------------------------------------------------- -!*** Now execute the final forward step of the DDFI filter. -!*** See fuller explanation in subroutine NMM_RUN. -!----------------------------------------------------------------------- -! - ddfi_forward: DO WHILE(.NOT.ALL_FORECASTS_COMPLETE) -! -!----------------------------------------------------------------------- -! - gens_f2_4: DO N=1,NUM_GENS -! -!----------------------------------------------------------------------- -! - IF(GENERATION_FINISHED(N))THEN - CYCLE gens_f2_4 - ENDIF -! - LAST_GENERATION=.FALSE. - IF(N==NUM_GENS)LAST_GENERATION=.TRUE. -! - MY_DOMAIN_ID=MY_DOMAINS_IN_GENS(N) !<-- This task's (only) domain in generation N - IF(MY_DOMAIN_ID==0)CYCLE !<-- This task is not on a domain in generation N -! - DOMAIN_GRID_COMP=>nmm_int_state%DOMAIN_GRID_COMP(MY_DOMAIN_ID) !<-- This domain's ESMF component -! -!----------------------------------------------------------------------- -!*** We need the task's rank on the current domain. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_RUN: Retrieve VM from DOMAIN Gridded Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGet(gridcomp=DOMAIN_GRID_COMP & !<-- The DOMAIN gridded component - ,vm =VM & !<-- Get the Virtual Machine from the DOMAIN component - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_RUN: Obtain the Local Task ID" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_VMGet(vm =VM & !<-- The virtual machine for this DOMAIN component - ,localpet=MYPE_LOCAL & !<-- Each task's local rank on this domain - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Starttime and Currtime from Clock for Forward DDFI" -! CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock =CLOCK_FILTER(MY_DOMAIN_ID) & !<-- The ESMF Clock for the digital filter - ,startTime =STARTTIME & !<-- The simulation start time (ESMF) - ,currTime =CURRTIME & !<-- The simulation current time (ESMF) -!!! ,runDuration =RUNDURATION & !<-- The simulation run duration (ESMF) -! ,advanceCount =NTIMESTEP_ESMF & !<-- Timestep count - ,runTimeStepCount=NTIMESTEP_ESMF_REAL & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! NTIMESTEP=NTIMESTEP_ESMF - NTIMESTEP=NINT(NTIMESTEP_ESMF_REAL)-1 !<-- ESMF timestep count starts with 1, not 0 -! -!----------------------------------------------------------------------- -! - IMP_STATE_DOMAIN=>nmm_int_state%IMP_STATE_DOMAIN(MY_DOMAIN_ID) - EXP_STATE_DOMAIN=>nmm_int_state%EXP_STATE_DOMAIN(MY_DOMAIN_ID) !<-- Its export state -! - I_AM_A_FCST_TASK =>nmm_int_state%I_AM_A_FCST_TASK(MY_DOMAIN_ID) !<-- Is this task a fcst task on this domain? - I_AM_LEAD_FCST_TASK=>nmm_int_state%I_AM_LEAD_FCST_TASK(MY_DOMAIN_ID) !<-- Is this the lead fcst task on this domain? -! - FILT_TIMESTEP=>nmm_int_state%FILT_TIMESTEP(MY_DOMAIN_ID) !<-- This domain's timestep for digital filtering -! - COMM_TO_MY_PARENT=>comms_domain(MY_DOMAIN_ID)%TO_PARENT !<-- This domain's intracommunicator to its parent - NUM_CHILDREN=>nmm_int_state%NUM_CHILDREN(MY_DOMAIN_ID) !<-- How many children does this domain have? -! - NPE_PRINT=>nmm_int_state%NPE_PRINT(MY_DOMAIN_ID) !<-- Print clocktimes from this task -! - RESTARTED_RUN=>nmm_int_state%RESTARTED_RUN(MY_DOMAIN_ID) - RST_OUT_00=>nmm_int_state%RST_OUT_00(MY_DOMAIN_ID) -! - I_AM_A_NEST=>nmm_int_state%I_AM_A_NEST(MY_DOMAIN_ID) !<-- Is this domain a nest? -! - PARENT_CHILD_COUPLER_COMP=>nmm_int_state%PC_CPL_COMP(MY_DOMAIN_ID) !<-- The P-C coupler associated with this domain - IMP_STATE_CPL_NEST=>nmm_int_state%IMP_STATE_PC_CPL(MY_DOMAIN_ID) !<-- The P-C coupler import state - EXP_STATE_CPL_NEST=>nmm_int_state%EXP_STATE_PC_CPL(MY_DOMAIN_ID) !<-- The P-C coupler export state -! - PARENT_CHILD_TIME_RATIO=>nmm_int_state%P_C_TIME_RATIO(MY_DOMAIN_ID) !<-- Ratio of this domain's timestep to its parent's - MY_DOMAIN_MOVES=nmm_int_state%MY_DOMAIN_MOVES(MY_DOMAIN_ID) !<-- Does this domain move? - NEST_MODE=nmm_int_state%NEST_MODE(MY_DOMAIN_ID) !<-- Is this domain involved in any 2-way nesting? - NUM_2WAY_CHILDREN=>nmm_int_state%NUM_2WAY_CHILDREN(MY_DOMAIN_ID) !<-- How many 2-way children on this domain? - NTRACK=nmm_int_state%NTRACK(MY_DOMAIN_ID) !<-- Storm locator flag - NPHS=nmm_int_state%NPHS(MY_DOMAIN_ID) !<-- Physics timestep -! -!----------------------------------------------------------------------- -! - CALL NMM_INTEGRATE(clock_direction ='Forward ' & !<-- The final forward piece of the filter - ,domain_grid_comp =DOMAIN_GRID_COMP & - ,imp_state_domain =IMP_STATE_DOMAIN & - ,exp_state_domain =EXP_STATE_DOMAIN & - ,clock_integrate =CLOCK_FILTER(MY_DOMAIN_ID) & - ,currtime =CURRTIME & - ,starttime =CURRTIME & !<-- CURRTIME was set or reset at end of backward piece - ,timestep =FILT_TIMESTEP & - ,ntimestep_ext =NTIMESTEP & - ,ndfistep =NDFISTEP(MY_DOMAIN_ID) & - ,runstepcount =Domain_RunstepCount & - ,dt =FILT_DT(MY_DOMAIN_ID) & - ,filter_method =FILTER_METHOD & - ,halfdfiintval =HALFDFIINTVAL(MY_DOMAIN_ID) & - ,halfdfitime =HALFDFITIME(MY_DOMAIN_ID) & - ,restarted_run =RESTARTED_RUN & - ,rst_out_00 =RST_OUT_00 & - ,i_am_a_fcst_task =I_AM_A_FCST_TASK & - ,i_am_lead_fcst_task=I_AM_LEAD_FCST_TASK & - ,nesting =NESTING_NMM & - ,nest_mode =NEST_MODE & - ,task_mode =TASK_MODE & - ,i_am_a_nest =I_AM_A_NEST & - ,my_domain_id =MY_DOMAIN_ID & - ,num_children =NUM_CHILDREN & - ,num_2way_children =NUM_2WAY_CHILDREN & - ,parent_child_cpl =PARENT_CHILD_COUPLER_COMP & - ,imp_state_cpl_nest =IMP_STATE_CPL_NEST & - ,exp_state_cpl_nest =EXP_STATE_CPL_NEST & - ,par_chi_time_ratio =PARENT_CHILD_TIME_RATIO & - ,my_domain_moves =MY_DOMAIN_MOVES & - ,ntrack =NTRACK & - ,nphs =NPHS & - ,last_generation =LAST_GENERATION & - ,advanced =ADVANCED & - ,mype =MYPE_LOCAL & - ,comm_global =COMM_GLOBAL & - ,timers_domain =TIMERS(MY_DOMAIN_ID) & - ,npe_print =NPE_PRINT & - ,print_timing =PRINT_TIMING ) -! -!----------------------------------------------------------------------- -! - IF(ESMF_ClockIsStopTime(CLOCK_FILTER(MY_DOMAIN_ID),rc=RC))THEN - GENERATION_FINISHED(N)=.TRUE. !<-- Generation N's filter has finished -! - IF(I_AM_LEAD_FCST_TASK)THEN - WRITE(0,*)' Completed filter method ',filter_method - WRITE(0,*)' Now reset filter method to 0.' - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** All tasks that are finished on all generations may leave. -!----------------------------------------------------------------------- -! - IF(ALL(GENERATION_FINISHED,NUM_GENS))THEN !<-- If true, all of this task's domains are finished - ALL_FORECASTS_COMPLETE=.TRUE. - EXIT gens_f2_4 - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO gens_f2_4 -! -!----------------------------------------------------------------------- -! - ENDDO ddfi_forward -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - ELSEIF(FILTER_METHOD==3)THEN method_block !<-- The TDFI digital filter. -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** First loop through the generations to set preliminary variables -!*** specific to the domains in them. -!----------------------------------------------------------------------- -! - gens_f3_1: DO N=1,NUM_GENS -! - MY_DOMAIN_ID=MY_DOMAINS_IN_GENS(N) !<-- This task's (only) domain in generation N - IF(MY_DOMAIN_ID==0)CYCLE !<-- This task is not on a domain in generation N -! -!----------------------------------------------------------------------- -! - FILT_TIMESTEP=>nmm_int_state%FILT_TIMESTEP(MY_DOMAIN_ID) !<-- This domain's timestep for digital filtering -! - I_AM_LEAD_FCST_TASK=>nmm_int_state%I_AM_LEAD_FCST_TASK(MY_DOMAIN_ID) !<-- Is this the lead fcst task on this domain? -! - IF(I_AM_LEAD_FCST_TASK)WRITE(0,*)' Beginning TDFI Filter' -! -!----------------------------------------------------------------------- -! -!-------------------------------- -!*** The initial backward step. -!-------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Digital Filter: Extract DFIHR Value for TDFI" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The config object - ,value = DFIHR & !<-- The digital filter flag - ,label ='nsecs_bcktdfi:' & !<-- Give this label's value to preceding variable - ,rc =RC) -! - CALL ESMF_TimeIntervalSet(timeinterval=HALFDFIINTVAL(MY_DOMAIN_ID) & - ,s =DFIHR & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="For TDFI Get Actual Timestep from ESMF Value" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeIntervalGet(timeinterval=FILT_TIMESTEP & !<-- The fundamental timestep of this domain (sec) (ESMF) - ,s =S & - ,sn =Sn & - ,sd =Sd & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NDFISTEP(MY_DOMAIN_ID)=INT( 0.1+DFIHR/(S+REAL(Sn)/REAL(Sd))) - DFIHR_CHK=INT(0.1+NDFISTEP(MY_DOMAIN_ID)*(REAL(S)+REAL(Sn)/REAL(Sd))) -! - IF (DFIHR_CHK /= DFIHR) THEN - WRITE(0,*)' DFIHR=',DFIHR,' DFIHR_CHK=',DFIHR_CHK - WRITE(0,*)'nsecs_bcktdfi in configure MUST be integer multiple of the timestep' - WRITE(0,*)' User must reset the value' - WRITE(0,*)' *** ABORTING MODEL RUN *** ' - CALL ESMF_Finalize(RC=RC,endflag=ESMF_END_ABORT) - ENDIF -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="TDFI Filter: Get current time info from NMM Clock" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock =CLOCK_NMM(MY_DOMAIN_ID) & - ,currtime=CURRTIME & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - STARTTIME=CURRTIME - HALFDFITIME(MY_DOMAIN_ID)=STARTTIME-HALFDFIINTVAL(MY_DOMAIN_ID) - DFITIME=HALFDFITIME(MY_DOMAIN_ID)-HALFDFIINTVAL(MY_DOMAIN_ID) -! - TIMESTEP_FILTER=-FILT_TIMESTEP !<-- Prepare for initial backward part of integration -! - CALL ESMF_TimeGet(STARTTIME, dd=DD, h=H, m=M, s=S, rc=RC) -! - IF(I_AM_LEAD_FCST_TASK)WRITE(0,*)' STARTTIME in TDFI DD H M S: ', DD, H, M, S - IF(I_AM_LEAD_FCST_TASK)WRITE(0,*)' NDFISTEP=',NDFISTEP(MY_DOMAIN_ID),' DFIHR=',DFIHR -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create the Clock for the TDFI Digital Filter." -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CLOCK_FILTER(MY_DOMAIN_ID)=ESMF_ClockCreate(name ='CLOCK_TDFI' & !<-- The Clock for the DFI filter - ,timeStep =TIMESTEP_FILTER & !<-- The fundamental timestep in this component - ,startTime=STARTTIME & !<-- Start time of filter -!!!!!!!! ,direction=ESMF_MODE_REVERSE & !<-- Reverse the Clock for backward integration - ,stopTime =DFITIME & !<-- Stop time of the filter - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - HDIFF_ON=0 !<-- Turn off horiz diffusion for backward integration. - MEAN_ON =0 !<-- Turn off horiz diffusion for backward integration. -! - IMP_STATE_DOMAIN=>nmm_int_state%IMP_STATE_DOMAIN(MY_DOMAIN_ID) !<-- This domain's import state -! - IF(I_AM_LEAD_FCST_TASK)WRITE(0,*)' Set Clock direction to backward for TDFI' -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="For TDFI Set Import State Attributes for Backward Integration" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state for filter - ,name ='Clock_Direction' & - ,value='Bckward ' & - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state for filter - ,name ='HDIFF' & !<-- Flag for horizontal diffusion on/off - ,value=HDIFF_ON & !<-- Value of horizontal diffusion flag - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state for filter - ,name ='MEAN_ON' & - ,value=MEAN_ON & - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state for filter - ,name ='NDFISTEP' & - ,value=NDFISTEP(MY_DOMAIN_ID) & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - ENDDO gens_f3_1 -! -!----------------------------------------------------------------------- -!*** Execute the TDFI filter's backward integration for all domains -!*** after dereferencing argument variables for the given domain. -!*** See fuller explanation in subroutine NMM_RUN. -!----------------------------------------------------------------------- -! - tdfi_backward: DO WHILE(.NOT.ALL_FORECASTS_COMPLETE) -! -!----------------------------------------------------------------------- -! - gens_f3_2: DO N=1,NUM_GENS -! -!----------------------------------------------------------------------- -! - IF(GENERATION_FINISHED(N))THEN - CYCLE gens_f3_2 - ENDIF -! - LAST_GENERATION=.FALSE. - IF(N==NUM_GENS)LAST_GENERATION=.TRUE. -! - MY_DOMAIN_ID=MY_DOMAINS_IN_GENS(N) !<-- This task's (only) domain in generation N - IF(MY_DOMAIN_ID==0)CYCLE !<-- This task is not on a domain in generation N -! - DOMAIN_GRID_COMP=>nmm_int_state%DOMAIN_GRID_COMP(MY_DOMAIN_ID) !<-- This domain's ESMF component -! -!----------------------------------------------------------------------- -!*** We need the task's rank on the current domain. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_RUN: Retrieve VM from DOMAIN Gridded Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGet(gridcomp=DOMAIN_GRID_COMP & !<-- The DOMAIN gridded component - ,vm =VM & !<-- Get the Virtual Machine from the DOMAIN component - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_RUN: Obtain the Local Task ID" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_VMGet(vm =VM & !<-- The virtual machine for this DOMAIN component - ,localpet=MYPE_LOCAL & !<-- Each task's local rank on this domain - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - IMP_STATE_DOMAIN=>nmm_int_state%IMP_STATE_DOMAIN(MY_DOMAIN_ID) !<-- Its import state - EXP_STATE_DOMAIN=>nmm_int_state%EXP_STATE_DOMAIN(MY_DOMAIN_ID) !<-- Its export state -! - I_AM_A_FCST_TASK =>nmm_int_state%I_AM_A_FCST_TASK(MY_DOMAIN_ID) !<-- Is this task a fcst task on this domain? - I_AM_LEAD_FCST_TASK=>nmm_int_state%I_AM_LEAD_FCST_TASK(MY_DOMAIN_ID) !<-- Is this the lead fcst task on this domain? -! - FILT_TIMESTEP=>nmm_int_state%FILT_TIMESTEP(MY_DOMAIN_ID) !<-- This domain's timestep for digital filtering -! - COMM_TO_MY_PARENT=>comms_domain(MY_DOMAIN_ID)%TO_PARENT !<-- This domain's intracommunicator to its parent - NUM_CHILDREN=>nmm_int_state%NUM_CHILDREN(MY_DOMAIN_ID) !<-- How many children does this domain have? -! - NPE_PRINT=>nmm_int_state%NPE_PRINT(MY_DOMAIN_ID) !<-- Print clocktimes from this task -! - RESTARTED_RUN=>nmm_int_state%RESTARTED_RUN(MY_DOMAIN_ID) - RST_OUT_00=>nmm_int_state%RST_OUT_00(MY_DOMAIN_ID) -! - I_AM_A_NEST=>nmm_int_state%I_AM_A_NEST(MY_DOMAIN_ID) !<-- Is this domain a nest? -! - PARENT_CHILD_COUPLER_COMP=>nmm_int_state%PC_CPL_COMP(MY_DOMAIN_ID) !<-- The P-C coupler associated with this domain - IMP_STATE_CPL_NEST=>nmm_int_state%IMP_STATE_PC_CPL(MY_DOMAIN_ID) !<-- The P-C coupler import state - EXP_STATE_CPL_NEST=>nmm_int_state%EXP_STATE_PC_CPL(MY_DOMAIN_ID) !<-- The P-C coupler export state -! - PARENT_CHILD_TIME_RATIO=>nmm_int_state%P_C_TIME_RATIO(MY_DOMAIN_ID) !<-- Ratio of this domain's timestep to its parent's - MY_DOMAIN_MOVES=nmm_int_state%MY_DOMAIN_MOVES(MY_DOMAIN_ID) !<-- Does this domain move? - NEST_MODE=nmm_int_state%NEST_MODE(MY_DOMAIN_ID) !<-- Is this domain involved in any 2-way nesting? - NUM_2WAY_CHILDREN=>nmm_int_state%NUM_2WAY_CHILDREN(MY_DOMAIN_ID) !<-- How many 2-way children on this domain? - NTRACK=nmm_int_state%NTRACK(MY_DOMAIN_ID) !<-- Storm locator flag - NPHS=nmm_int_state%NPHS(MY_DOMAIN_ID) !<-- Physics timestep -! -!----------------------------------------------------------------------- -!*** Obtain current information from the filter clock. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="TDFI Backward: Get time info from the Clock" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock =CLOCK_FILTER(MY_DOMAIN_ID) & - ,starttime =STARTTIME & - ,currtime =CURRTIME & -! ,advanceCount =NTIMESTEP_ESMF & - ,runTimeStepCount=NTIMESTEP_ESMF_REAL & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! NTIMESTEP=NTIMESTEP_ESMF - NTIMESTEP=NINT(NTIMESTEP_ESMF_REAL)-1 -! -!----------------------------------------------------------------------- -! - CALL NMM_INTEGRATE(clock_direction ='Bckward ' & !<-- The initial backward piece of the filter - ,domain_grid_comp =DOMAIN_GRID_COMP & - ,imp_state_domain =IMP_STATE_DOMAIN & - ,exp_state_domain =EXP_STATE_DOMAIN & - ,clock_integrate =CLOCK_FILTER(MY_DOMAIN_ID) & - ,currtime =CURRTIME & - ,starttime =STARTTIME & - ,timestep =FILT_TIMESTEP & - ,ntimestep_ext =NTIMESTEP & - ,runstepcount =Domain_RunstepCount & - ,dt =FILT_DT(MY_DOMAIN_ID) & - ,filter_method =FILTER_METHOD & - ,halfdfiintval =HALFDFIINTVAL(MY_DOMAIN_ID) & - ,ndfistep =NDFISTEP(MY_DOMAIN_ID) & - ,restarted_run =RESTARTED_RUN & - ,rst_out_00 =RST_OUT_00 & - ,i_am_a_fcst_task =I_AM_A_FCST_TASK & - ,i_am_lead_fcst_task=I_AM_LEAD_FCST_TASK & - ,nesting =NESTING_NMM & - ,nest_mode =NEST_MODE & - ,task_mode =TASK_MODE & - ,i_am_a_nest =I_AM_A_NEST & - ,my_domain_id =MY_DOMAIN_ID & - ,num_children =NUM_CHILDREN & - ,num_2way_children =NUM_2WAY_CHILDREN & - ,parent_child_cpl =PARENT_CHILD_COUPLER_COMP & - ,imp_state_cpl_nest =IMP_STATE_CPL_NEST & - ,exp_state_cpl_nest =EXP_STATE_CPL_NEST & - ,par_chi_time_ratio =PARENT_CHILD_TIME_RATIO & - ,my_domain_moves =MY_DOMAIN_MOVES & - ,ntrack =NTRACK & - ,nphs =NPHS & - ,last_generation =LAST_GENERATION & - ,advanced =ADVANCED & - ,mype =MYPE_LOCAL & - ,comm_global =COMM_GLOBAL & - ,generation_finished=GENERATION_FINISHED(N) & - ,timers_domain =TIMERS(MY_DOMAIN_ID) & - ,npe_print =NPE_PRINT & - ,print_timing =PRINT_TIMING ) -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** All tasks that are finished on all generations may leave. -!----------------------------------------------------------------------- -! - IF(ALL(GENERATION_FINISHED,NUM_GENS))THEN !<-- If true, all of this task's domains are finished - ALL_FORECASTS_COMPLETE=.TRUE. - EXIT gens_f3_2 - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO gens_f3_2 -! -!----------------------------------------------------------------------- -! - ENDDO tdfi_backward -! -!----------------------------------------------------------------------- -!*** Reset the completion flags for the forward integration. -!----------------------------------------------------------------------- -! - IF(NUM_GENS==1)THEN - GENERATION_FINISHED(1)=.FALSE. -! - ELSE - DO N=1,NUM_GENS - IF(MY_DOMAINS_IN_GENS(N)>0)THEN - GENERATION_FINISHED(N)=.FALSE. - ELSE - GENERATION_FINISHED(N)=.TRUE. !<-- Task not in this generation; consider it finished. - ENDIF - ENDDO -! - ENDIF -! - ALL_FORECASTS_COMPLETE=.FALSE. -! -!----------------------------------------------------------------------- -!*** Prepare to do the final forward step of the TDFI filter. -!----------------------------------------------------------------------- -! - gens_f3_3: DO N=1,NUM_GENS -! - MY_DOMAIN_ID=MY_DOMAINS_IN_GENS(N) !<-- This task's (only) domain in generation N - IF(MY_DOMAIN_ID==0)CYCLE !<-- This task is not on a domain in generation N -! - IMP_STATE_DOMAIN=>nmm_int_state%IMP_STATE_DOMAIN(MY_DOMAIN_ID) !<-- Its import state - FILT_TIMESTEP=>nmm_int_state%FILT_TIMESTEP(MY_DOMAIN_ID) !<-- This domain's timestep for digital filtering -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="For TDFI Get DFIHR for Forward Integration" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(MY_DOMAIN_ID) & !<-- The config object - ,value =DFIHR & !<-- The digital filter duration time - ,label ='nsecs_fwdtdfi:' & !<-- Give this label's value to preceding variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="For Forward Part of TDFI Set HALFDFIINTVAL" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeIntervalSet(timeinterval=HALFDFIINTVAL(MY_DOMAIN_ID) & - ,s =DFIHR & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="For Forward Part of TDFI Set Clock Direction" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state for filter - ,name ='Clock_Direction' & - ,value='Forward ' & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - HALFDFITIME(MY_DOMAIN_ID)=CURRTIME+HALFDFIINTVAL(MY_DOMAIN_ID) - SDFITIME=CURRTIME - DFITIME=HALFDFITIME(MY_DOMAIN_ID)+HALFDFIINTVAL(MY_DOMAIN_ID) -! - TIMESTEP_FILTER=FILT_TIMESTEP !<-- Prepare for forward part of integration -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Reset the Clock for Forward TDFI Digital Filter." -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeIntervalGet(timeinterval=TIMESTEP_FILTER & - ,s =S & - ,rc =RC) -! - NTIMESTEP=0 -! NTIMESTEP_ESMF=NTIMESTEP - NTIMESTEP_ESMF_REAL=REAL(NTIMESTEP)+1 !<-- ESMF timestep count starts with 1, not 0 - -! NTIMESTEP=-NTIMESTEP/2 -! NTIMESTEP_ESMF=NTIMESTEP -! - CALL ESMF_ClockSet(clock =CLOCK_FILTER(MY_DOMAIN_ID) & !<-- Reset the stoptime for the forward part of the filter - ,timeStep =TIMESTEP_FILTER & !<-- The fundamental timestep in this component - ,starttime =CURRTIME & !<-- Start forward integration at the current time - ,currtime =CURRTIME & -! ,advancecount =NTIMESTEP_ESMF & - ,runTimeStepCount=NTIMESTEP+1 & !<-- ESMF timestep count starts with 1, not 0 - ,stoptime =DFITIME & !<-- Stop forward integration at DFITIME - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - HDIFF_ON=1 !<-- Forward integration so we want horiz diffusion. - MEAN_ON =0 -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="For TDFI Set Import State Attributes for Forward Integration" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state for filter - ,name ='HDIFF' & !<-- Flag for horizontal diffusion on/off - ,value=HDIFF_ON & !<-- Value of horizontal diffusion flag - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_DOMAIN & !<-- This DOMAIN component's import state for filter - ,name ='MEAN_ON' & - ,value=MEAN_ON & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - ENDDO gens_f3_3 -! -!----------------------------------------------------------------------- -!*** Now execute the final forward step of the TDFI filter. -!*** See fuller explanation in subroutine NMM_RUN. -!----------------------------------------------------------------------- -! - tdfi_forward: DO WHILE(.NOT.ALL_FORECASTS_COMPLETE) -! -!----------------------------------------------------------------------- -! - gens_f3_4: DO N=1,NUM_GENS -! -!----------------------------------------------------------------------- -! - IF(GENERATION_FINISHED(N))THEN - CYCLE gens_f3_4 - ENDIF -! - LAST_GENERATION=.FALSE. - IF(N==NUM_GENS)LAST_GENERATION=.TRUE. -! - MY_DOMAIN_ID=MY_DOMAINS_IN_GENS(N) !<-- This task's (only) domain in generation N - IF(MY_DOMAIN_ID==0)CYCLE !<-- This task is not on a domain in generation N -! - DOMAIN_GRID_COMP=>nmm_int_state%DOMAIN_GRID_COMP(MY_DOMAIN_ID) !<-- This domain's ESMF component -! -!----------------------------------------------------------------------- -!*** We need the task's rank on the current domain. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_RUN: Retrieve VM from DOMAIN Gridded Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGet(gridcomp=DOMAIN_GRID_COMP & !<-- The DOMAIN gridded component - ,vm =VM & !<-- Get the Virtual Machine from the DOMAIN component - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_RUN: Obtain the Local Task ID" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_VMGet(vm =VM & !<-- The virtual machine for this DOMAIN component - ,localpet=MYPE_LOCAL & !<-- Each task's local rank on this domain - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Starttime and Currtime from Clock for Forward TDFI" -! CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock =CLOCK_FILTER(MY_DOMAIN_ID) & !<-- The ESMF Clock for the digital filter - ,startTime =STARTTIME & !<-- The simulation start time (ESMF) - ,currTime =CURRTIME & !<-- The simulation current time (ESMF) -!!! ,runDuration =RUNDURATION & !<-- The simulation run duration (ESMF) -! ,advanceCount =NTIMESTEP_ESMF & !<-- Timestep count - ,runTimeStepCount=NTIMESTEP_ESMF_REAL & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! NTIMESTEP=NTIMESTEP_ESMF - NTIMESTEP=NINT(NTIMESTEP_ESMF_REAL)-1 -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="TDFI Forward: Get Actual Timestep from ESMF Timestep" -! CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeIntervalGet(timeinterval=TIMESTEP & - ,s =S & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - IMP_STATE_DOMAIN=>nmm_int_state%IMP_STATE_DOMAIN(MY_DOMAIN_ID) - EXP_STATE_DOMAIN=>nmm_int_state%EXP_STATE_DOMAIN(MY_DOMAIN_ID) !<-- Its export state -! - I_AM_A_FCST_TASK =>nmm_int_state%I_AM_A_FCST_TASK(MY_DOMAIN_ID) !<-- Is this task a fcst task on this domain? - I_AM_LEAD_FCST_TASK=>nmm_int_state%I_AM_LEAD_FCST_TASK(MY_DOMAIN_ID) !<-- Is this the lead fcst task on this domain? -! - FILT_TIMESTEP=>nmm_int_state%FILT_TIMESTEP(MY_DOMAIN_ID) !<-- This domain's timestep for digital filtering -! - COMM_TO_MY_PARENT=>comms_domain(MY_DOMAIN_ID)%TO_PARENT !<-- This domain's intracommunicator to its parent - NUM_CHILDREN=>nmm_int_state%NUM_CHILDREN(MY_DOMAIN_ID) !<-- How many children does this domain have? -! - NPE_PRINT=>nmm_int_state%NPE_PRINT(MY_DOMAIN_ID) !<-- Print clocktimes from this task -! - RESTARTED_RUN=>nmm_int_state%RESTARTED_RUN(MY_DOMAIN_ID) - RST_OUT_00=>nmm_int_state%RST_OUT_00(MY_DOMAIN_ID) -! - I_AM_A_NEST=>nmm_int_state%I_AM_A_NEST(MY_DOMAIN_ID) !<-- Is this domain a nest? -! - PARENT_CHILD_COUPLER_COMP=>nmm_int_state%PC_CPL_COMP(MY_DOMAIN_ID) !<-- The P-C coupler associated with this domain - IMP_STATE_CPL_NEST=>nmm_int_state%IMP_STATE_PC_CPL(MY_DOMAIN_ID) !<-- The P-C coupler import state - EXP_STATE_CPL_NEST=>nmm_int_state%EXP_STATE_PC_CPL(MY_DOMAIN_ID) !<-- The P-C coupler export state -! - PARENT_CHILD_TIME_RATIO=>nmm_int_state%P_C_TIME_RATIO(MY_DOMAIN_ID) !<-- Ratio of this domain's timestep to its parent's - MY_DOMAIN_MOVES=nmm_int_state%MY_DOMAIN_MOVES(MY_DOMAIN_ID) !<-- Does this domain move? - NEST_MODE=nmm_int_state%NEST_MODE(MY_DOMAIN_ID) !<-- Is this domain involved in any 2-way nesting? - NUM_2WAY_CHILDREN=>nmm_int_state%NUM_2WAY_CHILDREN(MY_DOMAIN_ID) !<-- How many 2-way children on this domain? - NTRACK=nmm_int_state%NTRACK(MY_DOMAIN_ID) !<-- Storm locator flag - NPHS=nmm_int_state%NPHS(MY_DOMAIN_ID) !<-- Physics timestep -! -!----------------------------------------------------------------------- -! - CALL NMM_INTEGRATE(clock_direction ='Forward ' & !<-- The final forward piece of the filter - ,domain_grid_comp =DOMAIN_GRID_COMP & - ,imp_state_domain =IMP_STATE_DOMAIN & - ,exp_state_domain =EXP_STATE_DOMAIN & - ,clock_integrate =CLOCK_FILTER(MY_DOMAIN_ID) & - ,currtime =CURRTIME & - ,starttime =CURRTIME & !<-- CURRTIME was set or reset at end of backwward piece - ,timestep =FILT_TIMESTEP & - ,ntimestep_ext =NTIMESTEP & - ,runstepcount =Domain_RunstepCount & - ,ndfistep =NDFISTEP(MY_DOMAIN_ID) & - ,dt =FILT_DT(MY_DOMAIN_ID) & - ,filter_method =FILTER_METHOD & - ,halfdfiintval =HALFDFIINTVAL(MY_DOMAIN_ID) & - ,halfdfitime =HALFDFITIME(MY_DOMAIN_ID) & - ,restarted_run =RESTARTED_RUN & - ,rst_out_00 =RST_OUT_00 & - ,i_am_a_fcst_task =I_AM_A_FCST_TASK & - ,i_am_lead_fcst_task=I_AM_LEAD_FCST_TASK & - ,nesting =NESTING_NMM & - ,nest_mode =NEST_MODE & - ,task_mode =TASK_MODE & - ,i_am_a_nest =I_AM_A_NEST & - ,my_domain_id =MY_DOMAIN_ID & - ,num_children =NUM_CHILDREN & - ,num_2way_children =NUM_2WAY_CHILDREN & - ,parent_child_cpl =PARENT_CHILD_COUPLER_COMP & - ,imp_state_cpl_nest =IMP_STATE_CPL_NEST & - ,exp_state_cpl_nest =EXP_STATE_CPL_NEST & - ,par_chi_time_ratio =PARENT_CHILD_TIME_RATIO & - ,my_domain_moves =MY_DOMAIN_MOVES & - ,ntrack =NTRACK & - ,nphs =NPHS & - ,last_generation =LAST_GENERATION & - ,advanced =ADVANCED & - ,mype =MYPE_LOCAL & - ,comm_global =COMM_GLOBAL & - ,timers_domain =TIMERS(MY_DOMAIN_ID) & - ,npe_print =NPE_PRINT & - ,print_timing =PRINT_TIMING ) -! -!----------------------------------------------------------------------- -! - IF(ESMF_ClockIsStopTime(CLOCK_FILTER(MY_DOMAIN_ID),rc=RC))THEN - GENERATION_FINISHED(N)=.TRUE. !<-- Generation N's filter has finished - IF(I_AM_LEAD_FCST_TASK)THEN - WRITE(0,*)' Completed filter method ',filter_method - WRITE(0,*)' Now reset filter method to 0.' - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** All tasks that are finished on all generations may leave. -!----------------------------------------------------------------------- -! - IF(ALL(GENERATION_FINISHED,NUM_GENS))THEN !<-- If true, all of this task's domains are finished - ALL_FORECASTS_COMPLETE=.TRUE. - EXIT gens_f3_4 - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO gens_f3_4 -! -!----------------------------------------------------------------------- -! - ENDDO tdfi_forward -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - ENDIF method_block -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Remove working objects we are finished with. -!----------------------------------------------------------------------- -! - DEALLOCATE(CLOCK_FILTER,stat=RC) - DEALLOCATE(HALFDFITIME,stat=RC) - DEALLOCATE(HALFDFIINTVAL,stat=RC) - DEALLOCATE(NDFISTEP,stat=RC) -! -!----------------------------------------------------------------------- -!*** Reset the completion flags for integration of the free forecast. -!----------------------------------------------------------------------- -! - IF(NUM_GENS==1)THEN - GENERATION_FINISHED(1)=.FALSE. -! - ELSE - DO N=1,NUM_GENS - IF(MY_DOMAINS_IN_GENS(N)>0)THEN - GENERATION_FINISHED(N)=.FALSE. - ELSE - GENERATION_FINISHED(N)=.TRUE. !<-- Task not in this generation; consider it finished. - ENDIF - ENDDO -! - ENDIF -! - ALL_FORECASTS_COMPLETE=.FALSE. -! -!----------------------------------------------------------------------- -! - END SUBROUTINE RUN_DIGITAL_FILTER_NMM -! -!----------------------------------------------------------------------- -! - END SUBROUTINE NMM_RUN -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE NMM_FINALIZE(NMM_GRID_COMP & - ,IMP_STATE & - ,EXP_STATE & - ,CLOCK_NMM & - ,RC_FINALIZE) -! -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_GridComp) :: NMM_GRID_COMP !<-- The NMM component -! - TYPE(ESMF_State) :: IMP_STATE & !<-- The NMM import state - ,EXP_STATE !<-- The NMM export state -! - TYPE(ESMF_Clock) :: CLOCK_NMM !<-- The NMM component's ESMF Clock - - INTEGER,INTENT(OUT) :: RC_FINALIZE !<-- Error return code -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER :: I,J,N - INTEGER(kind=KINT) :: RC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- - - RC =ESMF_SUCCESS - RC_FINALIZE=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -! - IF(RC_FINALIZE==ESMF_SUCCESS)THEN -! WRITE(0,*)' NMM_FINALIZE succeeded' - ELSE - WRITE(0,*)' NMM_FINALIZE failed RC_FINALIZE=',RC_FINALIZE - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE NMM_FINALIZE -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - RECURSIVE SUBROUTINE CALL_DOMAIN_INITIALIZE(ID_DOMAIN,CLOCK_NMM) -! -!----------------------------------------------------------------------- -!*** This routine calls DOMAIN_INITIALIZE for all DOMAIN components. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER,INTENT(IN) :: ID_DOMAIN !<-- ID of the DOMAIN Component to initialize -! - TYPE(ESMF_Clock),DIMENSION(1:NUM_DOMAINS_TOTAL),INTENT(INOUT) :: CLOCK_NMM !<-- The NMM ESMF Clock -! -!----------------------------------------------------------------------- -!*** Local Variables -!----------------------------------------------------------------------- -! - INTEGER :: ID_CHILD,IRTN,N,N_CHILDREN - INTEGER :: RC,RC_CALL_INIT -! - CHARACTER(2) :: INT_TO_CHAR - CHARACTER(6) :: FMT -! - integer :: i_par_sta,j_par_sta,next_move_timestep -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RC_CALL_INIT=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -! - FMT='(I2.2)' - WRITE(INT_TO_CHAR,FMT)ID_DOMAIN -! -!----------------------------------------------------------------------- -!*** Initialize the DOMAIN component with the ID of ID_DOMAIN. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Initialize DOMAIN Component "//INT_TO_CHAR -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompInitialize(gridcomp =nmm_int_state%DOMAIN_GRID_COMP(ID_DOMAIN) & !<-- The DOMAIN component - ,importState=nmm_int_state%IMP_STATE_DOMAIN(ID_DOMAIN) & !<-- The DOMAIN import state - ,exportState=nmm_int_state%EXP_STATE_DOMAIN(ID_DOMAIN) & !<-- The DOMAIN export state - ,clock =CLOCK_NMM(ID_DOMAIN) & !<-- The DOMAIN clock - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CALL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** If the domain being initialized has children, force those -!*** children to wait. The parent might be generating input for -!*** the children therefore children should not be trying to read -!*** the input in their own initialize steps prematurely. -!----------------------------------------------------------------------- -! - CALL MPI_BARRIER(COMM_GLOBAL,IRTN) -! -!----------------------------------------------------------------------- -!*** If there are children, initialize them. -!----------------------------------------------------------------------- -! - N_CHILDREN=nmm_int_state%NUM_CHILDREN(ID_DOMAIN) -! - IF(N_CHILDREN>0)THEN !<-- Does the current DOMAIN have any children? - DO N=1,N_CHILDREN !<-- If so, loop through the children to Initialize them - ID_CHILD=ID_CHILDREN(N,ID_DOMAIN) - CALL CALL_DOMAIN_INITIALIZE(ID_CHILD,CLOCK_NMM) - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE CALL_DOMAIN_INITIALIZE -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - SUBROUTINE BOUNDARY_DATA_TO_DOMAIN(EXP_STATE_CPL & - ,IMP_STATE_DOMAIN ) -! -!----------------------------------------------------------------------- -!*** This routine moves new boundary data for nested domains from the -!*** export state of the Parent-Child coupler to the import state of -!*** the NMM nests' DOMAIN components. -!----------------------------------------------------------------------- -! - TYPE(ESMF_State),INTENT(INOUT) :: EXP_STATE_CPL !<-- The Parent-Child Coupler's export state - - TYPE(ESMF_State),INTENT(OUT) :: IMP_STATE_DOMAIN !<-- The nests' DOMAIN import state -! -!----------------------------------------------------------------------- -!*** Local variables -!----------------------------------------------------------------------- -! - TYPE SIDES_1D_REAL - REAL,DIMENSION(:),ALLOCATABLE :: SOUTH - REAL,DIMENSION(:),ALLOCATABLE :: NORTH - REAL,DIMENSION(:),ALLOCATABLE :: WEST - REAL,DIMENSION(:),ALLOCATABLE :: EAST - END TYPE SIDES_1D_REAL -! - INTEGER :: ISTAT,KOUNT,RC,RC_BND_MV -! - TYPE(SIDES_1D_REAL),SAVE :: BOUNDARY_H & - ,BOUNDARY_V -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Check each side of the child boundary. If data is present from -!*** that side in the Parent-Child coupler export state then move it -!*** to the DOMAIN component's import state. -!----------------------------------------------------------------------- -! -!------------- -!*** South H -!------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Check Parent-Child Cpl Export State for South H Data" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =EXP_STATE_CPL & !<-- Look at the Parent-Child Coupler's export state - ,name ='SOUTH_H' & !<-- Is this name present? - ,itemCount=KOUNT & !<-- How many items present? - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BND_MV) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - south_h: IF(KOUNT>0.AND.RC==ESMF_SUCCESS)THEN !<-- True => South boundary H point data is present -! - IF(.NOT.ALLOCATED(BOUNDARY_H%SOUTH))THEN - ALLOCATE(BOUNDARY_H%SOUTH(1:KOUNT),stat=ISTAT) - IF(ISTAT/=0)WRITE(0,*)' Failed to allocate BOUNDARY_H%SOUTH stat=',ISTAT - ENDIF -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract South H Data from Parent-Child Cpl Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeGet(state =EXP_STATE_CPL & !<-- Extract data from Parent-Child Coupler's export state - ,name ='SOUTH_H' & !<-- The name of the data - ,itemCount=KOUNT & !<-- The data has this many items - ,valueList=BOUNDARY_H%SOUTH & !<-- The new combined boundary data - ,rc=RC ) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BND_MV) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert South H Data into Nest DOMAIN Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeSet(state =IMP_STATE_DOMAIN & !<-- Insert data into nest's DOMAIN import state - ,name ='SOUTH_H' & !<-- The name of the data - ,itemCount=KOUNT & !<-- The data has this many items - ,valueList=BOUNDARY_H%SOUTH & !<-- The new combined boundary data - ,rc=RC ) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BND_MV) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF south_h -! -!------------- -!*** South V -!------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Check Parent-Child Cpl Export State for South V Data" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeGet(state =EXP_STATE_CPL & !<-- Look at the Parent-Child Coupler's export state - ,name ='SOUTH_V' & !<-- Is this name present? - ,itemCount=KOUNT & !<-- How many items present? - ,rc =RC ) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BND_MV) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - south_v: IF(KOUNT>0.AND.RC==ESMF_SUCCESS)THEN !<-- True => South boundary V point data is present -! - IF(.NOT.ALLOCATED(BOUNDARY_V%SOUTH))THEN - ALLOCATE(BOUNDARY_V%SOUTH(1:KOUNT),stat=ISTAT) - IF(ISTAT/=0)WRITE(0,*)' Failed to allocate BOUNDARY_V%SOUTH stat=',ISTAT - ENDIF -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract South V Data from Parent-Child Cpl Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeGet(state =EXP_STATE_CPL & !<-- Extract data from Parent-Child Coupler's export state - ,name ='SOUTH_V' & !<-- The name of the data - ,itemCount=KOUNT & !<-- The data has this many items - ,valueList=BOUNDARY_V%SOUTH & !<-- The new combined boundary data - ,rc=RC ) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BND_MV) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert South V Data into Nest DOMAIN Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeSet(state =IMP_STATE_DOMAIN & !<-- Insert data into nest's DOMAIN import state - ,name ='SOUTH_V' & !<-- The name of the data - ,itemCount=KOUNT & !<-- The data has this many items - ,valueList=BOUNDARY_V%SOUTH & !<-- The new combined boundary data - ,rc=RC ) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BND_MV) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF south_v -! -!------------- -!*** North H -!------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Check Parent-Child Cpl Export State for North H Data" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeGet(state =EXP_STATE_CPL & !<-- Look at the Parent-Child Coupler's export state - ,name ='NORTH_H' & !<-- Is this name present? - ,itemCount=KOUNT & !<-- How many items present? - ,rc =RC ) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BND_MV) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - north_h: IF(KOUNT>0.AND.RC==ESMF_SUCCESS)THEN !<-- True => North boundary H point data is present -! - IF(.NOT.ALLOCATED(BOUNDARY_H%NORTH))THEN - ALLOCATE(BOUNDARY_H%NORTH(1:KOUNT),stat=ISTAT) - IF(ISTAT/=0)WRITE(0,*)' Failed to allocate BOUNDARY_H%NORTH stat=',ISTAT - ENDIF -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract North H Data from Parent-Child Cpl Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeGet(state =EXP_STATE_CPL & !<-- Extract data from Parent-Child Coupler's export state - ,name ='NORTH_H' & !<-- The name of the data - ,itemCount=KOUNT & !<-- The data has this many items - ,valueList=BOUNDARY_H%NORTH & !<-- The new combined boundary data - ,rc=RC ) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BND_MV) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert North H Data into Nest DOMAIN Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeSet(state =IMP_STATE_DOMAIN & !<-- Insert data into nest's DOMAIN import state - ,name ='NORTH_H' & !<-- The name of the data - ,itemCount=KOUNT & !<-- The data has this many items - ,valueList=BOUNDARY_H%NORTH & !<-- The new combined boundary data - ,rc=RC ) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BND_MV) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF north_h -! -!------------- -!*** North V -!------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Check Parent-Child Cpl Export State for North V Data" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeGet(state =EXP_STATE_CPL & !<-- Look at the Parent-Child Coupler's export state - ,name ='NORTH_V' & !<-- Is this name present? - ,itemCount=KOUNT & !<-- How many items present? - ,rc =RC ) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BND_MV) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - north_v: IF(KOUNT>0.AND.RC==ESMF_SUCCESS)THEN !<-- True => North boundary V point data is present -! - IF(.NOT.ALLOCATED(BOUNDARY_V%NORTH))THEN - ALLOCATE(BOUNDARY_V%NORTH(1:KOUNT),stat=ISTAT) - IF(ISTAT/=0)WRITE(0,*)' Failed to allocate BOUNDARY_V%NORTH stat=',ISTAT - ENDIF -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract North V Data from Parent-Child Cpl Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeGet(state =EXP_STATE_CPL & !<-- Extract data from Parent-Child Coupler's export state - ,name ='NORTH_V' & !<-- The name of the data - ,itemCount=KOUNT & !<-- The data has this many items - ,valueList=BOUNDARY_V%NORTH & !<-- The new combined boundary data - ,rc=RC ) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BND_MV) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert North V Data into Nest DOMAIN Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeSet(state =IMP_STATE_DOMAIN & !<-- Insert data into nest's DOMAIN import state - ,name ='NORTH_V' & !<-- The name of the data - ,itemCount=KOUNT & !<-- The data has this many items - ,valueList=BOUNDARY_V%NORTH & !<-- The new combined boundary data - ,rc=RC ) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BND_MV) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF north_v -! -!------------ -!*** West H -!------------ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Check Parent-Child Cpl Export State for West H Data" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeGet(state =EXP_STATE_CPL & !<-- Look at the Parent-Child Coupler's export state - ,name ='WEST_H' & !<-- Is this name present? - ,itemCount=KOUNT & !<-- How many items present? - ,rc =RC ) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BND_MV) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - west_h: IF(KOUNT>0.AND.RC==ESMF_SUCCESS)THEN !<-- True => West boundary H point data is present -! - IF(.NOT.ALLOCATED(BOUNDARY_H%WEST))THEN - ALLOCATE(BOUNDARY_H%WEST(1:KOUNT),stat=ISTAT) - IF(ISTAT/=0)WRITE(0,*)' Failed to allocate BOUNDARY_H%WEST stat=',ISTAT - ENDIF -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract West H Data from Parent-Child Cpl Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeGet(state =EXP_STATE_CPL & !<-- Extract data from Parent-Child Coupler's export state - ,name ='WEST_H' & !<-- The name of the data - ,itemCount=KOUNT & !<-- The data has this many items - ,valueList=BOUNDARY_H%WEST & !<-- The new combined boundary data - ,rc=RC ) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BND_MV) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert West H Data into Nest DOMAIN Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeSet(state =IMP_STATE_DOMAIN & !<-- Insert data into nest's DOMAIN import state - ,name ='WEST_H' & !<-- The name of the data - ,itemCount=KOUNT & !<-- The data has this many items - ,valueList=BOUNDARY_H%WEST & !<-- The new combined boundary data - ,rc=RC ) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BND_MV) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF west_h -! -!------------ -!*** West V -!------------ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Check Parent-Child Cpl Export State for West V Data" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeGet(state =EXP_STATE_CPL & !<-- Look at the Parent-Child Coupler's export state - ,name ='WEST_V' & !<-- Is this name present? - ,itemCount=KOUNT & !<-- How many items present? - ,rc =RC ) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BND_MV) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - west_v: IF(KOUNT>0.AND.RC==ESMF_SUCCESS)THEN !<-- True => West boundary V point data is present -! - IF(.NOT.ALLOCATED(BOUNDARY_V%WEST))THEN - ALLOCATE(BOUNDARY_V%WEST(1:KOUNT),stat=ISTAT) - IF(ISTAT/=0)WRITE(0,*)' Failed to allocate BOUNDARY_V%WEST stat=',ISTAT - ENDIF -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract West V Data from Parent-Child Cpl Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeGet(state =EXP_STATE_CPL & !<-- Extract data from Parent-Child Coupler's export state - ,name ='WEST_V' & !<-- The name of the data - ,itemCount=KOUNT & !<-- The data has this many items - ,valueList=BOUNDARY_V%WEST & !<-- The new combined boundary data - ,rc=RC ) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BND_MV) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert West V Data into Nest DOMAIN Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeSet(state =IMP_STATE_DOMAIN & !<-- Insert data into nest's DOMAIN import state - ,name ='WEST_V' & !<-- The name of the data - ,itemCount=KOUNT & !<-- The data has this many items - ,valueList=BOUNDARY_V%NORTH & !<-- The new combined boundary data - ,rc=RC ) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BND_MV) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF west_v -! -!------------ -!*** East H -!------------ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Check Parent-Child Cpl Export State for East H Data" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeGet(state =EXP_STATE_CPL & !<-- Look at the Parent-Child Coupler's export state - ,name ='EAST_H' & !<-- Is this name present? - ,itemCount=KOUNT & !<-- How many items present? - ,rc =RC ) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BND_MV) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - east_h: IF(KOUNT>0.AND.RC==ESMF_SUCCESS)THEN !<-- True => East boundary H point data is present -! - IF(.NOT.ALLOCATED(BOUNDARY_H%EAST))THEN - ALLOCATE(BOUNDARY_H%EAST(1:KOUNT),stat=ISTAT) - IF(ISTAT/=0)WRITE(0,*)' Failed to allocate BOUNDARY_H%EAST stat=',ISTAT - ENDIF -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract East H Data from Parent-Child Cpl Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeGet(state =EXP_STATE_CPL & !<-- Extract data from Parent-Child Coupler's export state - ,name ='EAST_H' & !<-- The name of the data - ,itemCount=KOUNT & !<-- The data has this many items - ,valueList=BOUNDARY_H%EAST & !<-- The new combined boundary data - ,rc=RC ) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BND_MV) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert East H Data into Nest DOMAIN Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeSet(state =IMP_STATE_DOMAIN & !<-- Insert data into nest's DOMAIN import state - ,name ='EAST_H' & !<-- The name of the data - ,itemCount=KOUNT & !<-- The data has this many items - ,valueList=BOUNDARY_H%EAST & !<-- The new combined boundary data - ,rc=RC ) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BND_MV) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF east_h -! -!------------ -!*** East V -!------------ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Check Parent-Child Cpl Export State for East V Data" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeGet(state =EXP_STATE_CPL & !<-- Look at the Parent-Child Coupler's export state - ,name ='EAST_V' & !<-- Is this name present? - ,itemCount=KOUNT & !<-- How many items present? - ,rc =RC ) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BND_MV) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - east_v: IF(KOUNT>0.AND.RC==ESMF_SUCCESS)THEN !<-- True => East boundary V point data is present -! - IF(.NOT.ALLOCATED(BOUNDARY_V%EAST))THEN - ALLOCATE(BOUNDARY_V%EAST(1:KOUNT),stat=ISTAT) - IF(ISTAT/=0)WRITE(0,*)' Failed to allocate BOUNDARY_V%EAST stat=',ISTAT - ENDIF -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract East V Data from Parent-Child Cpl Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeGet(state =EXP_STATE_CPL & !<-- Extract data from Parent-Child Coupler's export state - ,name ='EAST_V' & !<-- The name of the data - ,itemCount=KOUNT & !<-- The data has this many items - ,valueList=BOUNDARY_V%EAST & !<-- The new combined boundary data - ,rc=RC ) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BND_MV) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert East V Data into Nest DOMAIN Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeSet(state =IMP_STATE_DOMAIN & !<-- Insert data into nest's DOMAIN import state - ,name ='EAST_V' & !<-- The name of the data - ,itemCount=KOUNT & !<-- The data has this many items - ,valueList=BOUNDARY_V%EAST & !<-- The new combined boundary data - ,rc=RC ) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BND_MV) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF east_v -! -!----------------------------------------------------------------------- -! - END SUBROUTINE BOUNDARY_DATA_TO_DOMAIN - -!----------------------------------------------------------------------- - SUBROUTINE NMM_CLOCKPRINT(CLOCK, msg, RC) -!----------------------------------------------------------------------- - type(ESMF_CLOCK), intent(inout) :: CLOCK - character(len=*), intent(in) :: msg - integer, intent(out) :: RC - - RC = ESMF_SUCCESS - call ESMF_ClockPrint(CLOCK, & - preString=trim(msg)// ' CurrentTime: ', unit=nuopcMsg) - call ESMF_LogWrite(nuopcMsg, ESMF_LOGMSG_INFO) - call ESMF_ClockPrint(CLOCK, & - preString=trim(msg)// ' StartTime: ', unit=nuopcMsg) - call ESMF_LogWrite(nuopcMsg, ESMF_LOGMSG_INFO) - call ESMF_ClockPrint(CLOCK, & - preString=trim(msg)// ' StopTime: ', unit=nuopcMsg) - call ESMF_LogWrite(nuopcMsg, ESMF_LOGMSG_INFO) - -!----------------------------------------------------------------------- - END SUBROUTINE -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- - subroutine AdvertiseFields(state, nfields, field_defs, rc) -! -!----------------------------------------------------------------------- - - type(ESMF_State), intent(inout) :: state - integer,intent(in) :: nfields - type(fld_list_type), intent(inout) :: field_defs(:) - integer, intent(inout) :: rc - - integer :: i - character(len=*),parameter :: subname='(nmmb_cap:AdvertiseFields)' - -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- - - rc = ESMF_SUCCESS - - do i = 1, nfields - - call ESMF_LogWrite('NMMB Advertise: '//trim(field_defs(i)%stdname), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call NUOPC_Advertise(state, & - standardName=field_defs(i)%stdname, & - name=field_defs(i)%shortname, & - rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - enddo - -!----------------------------------------------------------------------- -! - end subroutine AdvertiseFields -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - subroutine RealizeFields(state, grid, nfields, field_defs, tag, rc) -! -!----------------------------------------------------------------------- - - type(ESMF_State), intent(inout) :: state - type(ESMF_Grid), intent(in) :: grid - integer, intent(in) :: nfields - type(fld_list_type), intent(inout) :: field_defs(:) - character(len=*), intent(in) :: tag - integer, intent(inout) :: rc - - integer :: i - type(ESMF_Field) :: field - integer :: npet, nx, ny, pet, & - elb(2), eub(2), clb(2), cub(2), tlb(2), tub(2) - type(ESMF_VM) :: vm - character(len=*),parameter :: subname='(nmmb_cap:RealizeFields)' - -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- - - rc = ESMF_SUCCESS - - !call ESMF_VMGetCurrent(vm, rc=rc) - !if (rc /= ESMF_SUCCESS) call ESMF_Finalize() - - !call ESMF_VMGet(vm, petcount=npet, localPet=pet, rc=rc) - !if (rc /= ESMF_SUCCESS) call ESMF_Finalize() - - !call ESMF_GridGet(grid, exclusiveLBound=elb, exclusiveUBound=eub, & - ! computationalLBound=clb, computationalUBound=cub, & - ! totalLBound=tlb, totalUBound=tub, rc=rc) - !if (rc /= ESMF_SUCCESS) call ESMF_Finalize() - - !write(info, *) pet, 'exc', elb, eub, 'comp', clb, cub, 'total', tlb, tub - !call ESMF_LogWrite(subname // tag // " Grid "// info, & - ! ESMF_LOGMSG_INFO, & - ! line=__LINE__, & - ! file=__FILE__, & - ! rc=rc) - - do i = 1, nfields - - if (field_defs(i)%assoc) then - write(info, *) subname, tag, ' Field ', field_defs(i)%shortname, ':', & - lbound(field_defs(i)%farrayPtr,1), ubound(field_defs(i)%farrayPtr,1), & - lbound(field_defs(i)%farrayPtr,2), ubound(field_defs(i)%farrayPtr,2), & - lbound(field_defs(i)%farrayPtr,3), ubound(field_defs(i)%farrayPtr,3) - call ESMF_LogWrite(info, ESMF_LOGMSG_INFO, rc=rc) - field = ESMF_FieldCreate(grid=grid, & - farray=field_defs(i)%farrayPtr, indexflag=ESMF_INDEX_DELOCAL, & - name=field_defs(i)%shortname, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - else - field = ESMF_FieldCreate(grid, ESMF_TYPEKIND_R8, indexflag=ESMF_INDEX_DELOCAL, & - name=field_defs(i)%shortname, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - endif - - if (NUOPC_IsConnected(state, fieldName=field_defs(i)%shortname)) then - call NUOPC_Realize(state, field=field, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - call ESMF_LogWrite(subname // tag // " Field "// field_defs(i)%stdname // " is connected.", & - ESMF_LOGMSG_INFO, & - line=__LINE__, & - file=__FILE__, & - rc=rc) -! call ESMF_FieldPrint(field=field, rc=rc) -! if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & -! line=__LINE__, & -! file=__FILE__)) & -! return ! bail out - else - call ESMF_LogWrite(subname // tag // " Field "// field_defs(i)%stdname // " is not connected.", & - ESMF_LOGMSG_INFO, & - line=__LINE__, & - file=__FILE__, & - rc=rc) - ! TODO: Initialize the value in the pointer to 0 after proper restart is setup - !if(associated(field_defs(i)%farrayPtr) ) field_defs(i)%farrayPtr = 0.0 - ! remove a not connected Field from State - call ESMF_StateRemove(state, (/field_defs(i)%shortname/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - endif - - enddo - -!----------------------------------------------------------------------- -! - end subroutine RealizeFields -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - subroutine fld_list_add(num, fldlist, stdname, transferOffer, data, shortname) -! -!----------------------------------------------------------------------- - ! ---------------------------------------------- - ! Set up a list of field information - ! ---------------------------------------------- - integer, intent(inout) :: num - type(fld_list_type), intent(inout) :: fldlist(:) - character(len=*), intent(in) :: stdname - character(len=*), intent(in) :: transferOffer - real(ESMF_KIND_R8), dimension(:,:,:), optional, target :: data - character(len=*), intent(in),optional :: shortname - - ! local variables - integer :: rc - character(len=*), parameter :: subname='(cice_cap:fld_list_add)' - -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- - ! fill in the new entry - - num = num + 1 - if (num > fldsMax) then - call ESMF_LogWrite(trim(subname)//": ERROR num gt fldsMax "//trim(stdname), & - ESMF_LOGMSG_ERROR, line=__LINE__, file=__FILE__, rc=rc) - return - endif - - fldlist(num)%stdname = trim(stdname) - if (present(shortname)) then - fldlist(num)%shortname = trim(shortname) - else - fldlist(num)%shortname = trim(stdname) - endif - fldlist(num)%transferOffer = trim(transferOffer) - if (present(data)) then - fldlist(num)%assoc = .true. - fldlist(num)%farrayPtr => data - else - fldlist(num)%assoc = .false. - endif - - end subroutine fld_list_add -! -!----------------------------------------------------------------------- -! - END MODULE module_NMM_GRID_COMP -! -!----------------------------------------------------------------------- diff --git a/src/nmm/module_NMM_GRID_COMP_stub.F90 b/src/nmm/module_NMM_GRID_COMP_stub.F90 deleted file mode 100644 index 9566c88..0000000 --- a/src/nmm/module_NMM_GRID_COMP_stub.F90 +++ /dev/null @@ -1,174 +0,0 @@ -!----------------------------------------------------------------------- -! - MODULE module_NMM_GRID_COMP -! -!----------------------------------------------------------------------- -! - USE ESMF -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: NMM_REGISTER -! -!----------------------------------------------------------------------- -! - INTEGER :: DUMMY -! -!----------------------------------------------------------------------- - - CONTAINS -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE NMM_REGISTER(NMM_GRID_COMP,RC_REG) -! -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_GridComp) :: NMM_GRID_COMP - INTEGER ,INTENT(OUT) :: RC_REG -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER :: RC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - CALL ESMF_GridCompSetEntryPoint(NMM_GRID_COMP & - ,ESMF_METHOD_INITIALIZE & - ,NMM_INITIALIZE & - ,phase=1 & - ,rc=RC) - - CALL ESMF_GridCompSetEntryPoint(NMM_GRID_COMP & - ,ESMF_METHOD_RUN & - ,NMM_RUN & - ,phase=1 & - ,rc=RC) - - CALL ESMF_GridCompSetEntryPoint(NMM_GRID_COMP & - ,ESMF_METHOD_FINALIZE & - ,NMM_FINALIZE & - ,phase=1 & - ,rc=RC) - -!----------------------------------------------------------------------- -! - RC_REG = ESMF_SUCCESS -! -!----------------------------------------------------------------------- -! - END SUBROUTINE NMM_REGISTER -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE NMM_INITIALIZE(NMM_GRID_COMP & - ,IMP_STATE & - ,EXP_STATE & - ,CLOCK_NMM & - ,RC_INIT) -! -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_GridComp) :: NMM_GRID_COMP - TYPE(ESMF_State) :: IMP_STATE - TYPE(ESMF_State) :: EXP_STATE - TYPE(ESMF_Clock) :: CLOCK_NMM - INTEGER ,INTENT(OUT) :: RC_INIT -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC_INIT = ESMF_SUCCESS -! -!----------------------------------------------------------------------- -! - END SUBROUTINE NMM_INITIALIZE -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE NMM_RUN(NMM_GRID_COMP & - ,IMP_STATE & - ,EXP_STATE & - ,CLOCK_NMM & - ,RC_RUN) -! -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_GridComp) :: NMM_GRID_COMP - TYPE(ESMF_State) :: IMP_STATE - TYPE(ESMF_State) :: EXP_STATE - TYPE(ESMF_Clock) :: CLOCK_NMM - INTEGER ,INTENT(OUT) :: RC_RUN -! -!----------------------------------------------------------------------- -! - RC_RUN=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -! - END SUBROUTINE NMM_RUN -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE NMM_FINALIZE(NMM_GRID_COMP & - ,IMP_STATE & - ,EXP_STATE & - ,CLOCK_NMM & - ,RC_FINALIZE) -! -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_GridComp) :: NMM_GRID_COMP - TYPE(ESMF_State) :: IMP_STATE - TYPE(ESMF_State) :: EXP_STATE - TYPE(ESMF_Clock) :: CLOCK_NMM - INTEGER ,INTENT(OUT) :: RC_FINALIZE -! -!----------------------------------------------------------------------- -! - RC_FINALIZE=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -! - END SUBROUTINE NMM_FINALIZE -! -!----------------------------------------------------------------------- -! - END MODULE module_NMM_GRID_COMP -! -!----------------------------------------------------------------------- diff --git a/src/nmm/module_NMM_INTEGRATE.F90 b/src/nmm/module_NMM_INTEGRATE.F90 deleted file mode 100644 index 7e2a54f..0000000 --- a/src/nmm/module_NMM_INTEGRATE.F90 +++ /dev/null @@ -1,1965 +0,0 @@ -!----------------------------------------------------------------------- -! - MODULE module_NMM_INTEGRATE -! -!----------------------------------------------------------------------- -! -!*** This module holds the fundamental NMM integration runstream -!*** when 2-way nesting is being used. -!*** It is called from subroutine NMM_RUN in module_NMM_GRID_COMP. -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! PROGRAM HISTORY LOG: -! 2008-08 Colon - Moved NMM runstream from ATM_RUN into separate -! routines when adding digital filters. -! 2009-07-09 Black - Condense all three NMM integrate routines -! into one when when merging with nesting. -! 2010_03_24 Black - Revised for new structure. -! 2010-11-03 Pyle - Revised for digital filters. -! 2011-02 Yang - Updated to use both the ESMF 4.0.0rp2 library, -! ESMF 5 series library and the the -! ESMF 3.1.0rp2 library. -! 2011-05 Yang - Modified for using the ESMF 5.2.0r_beta_snapshot_07. -! 2011-07 Black - Revised for moving nests. -! 2012-02 Yang - Modified for using the ESMF 5.2.0rp1 library. -! 2012-07 Black - Revised for 'generational' task usage. -!----------------------------------------------------------------------- -! - USE ESMF -! - USE MODULE_ERROR_MSG,ONLY: ERR_MSG,MESSAGE_CHECK -! - USE module_CLOCKTIMES,ONLY: INTEGRATION_TIMERS & - ,PRINT_CLOCKTIMES -! - USE module_DOMAIN_INTERNAL_STATE,ONLY: DOMAIN_INTERNAL_STATE & - ,WRAP_DOMAIN_INTERNAL_STATE -! - USE module_WRITE_ROUTINES,ONLY: WRITE_ASYNC -! - USE module_NESTING,ONLY: BOUNDARY_DATA_STATE_TO_STATE & - ,INTERIOR_DATA_STATE_TO_STATE -! - USE module_CONTROL,ONLY: TIMEF -! - USE module_PARENT_CHILD_CPL_COMP,ONLY: NSTEP_CHILD_RECV -! - USE module_KINDS -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: NMM_INTEGRATE -! -!----------------------------------------------------------------------- -! - CHARACTER(ESMF_MAXSTR) :: CWRT !<-- Restart/History label -! -!----------------------------------------------------------------------- -!*** For determining clocktimes of various pieces of the Solver. -!----------------------------------------------------------------------- -! - REAL(kind=KDBL) :: btim,btim0 -! -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE NMM_INTEGRATE(CLOCK_DIRECTION & - ,DOMAIN_GRID_COMP & - ,IMP_STATE_DOMAIN & - ,EXP_STATE_DOMAIN & - ,CLOCK_INTEGRATE & - ,CURRTIME & - ,STARTTIME & - ,TIMESTEP & - ,NTIMESTEP_EXT & - ,RUNSTEPCOUNT & - ,DT & - ,INTEGRATE_TIMESTEP & - ,INTERVAL_CLOCKTIME & - ,INTERVAL_HISTORY & - ,INTERVAL_RESTART & - ,FILTER_METHOD & - ,HALFDFIINTVAL & - ,HALFDFITIME & - ,NDFISTEP & - ,RESTARTED_RUN & - ,RST_OUT_00 & - ,I_AM_A_FCST_TASK & - ,I_AM_LEAD_FCST_TASK & - ,NESTING & - ,NEST_MODE & - ,TASK_MODE & - ,I_AM_A_NEST & - ,MY_DOMAIN_ID & - ,NUM_CHILDREN & - ,NUM_2WAY_CHILDREN & - ,PARENT_CHILD_CPL & - ,IMP_STATE_CPL_NEST & - ,EXP_STATE_CPL_NEST & - ,PAR_CHI_TIME_RATIO & - ,MY_DOMAIN_MOVES & - ,NTRACK & - ,NPHS & - ,LAST_GENERATION & - ,ADVANCED & - ,MYPE & - ,COMM_GLOBAL & - ,GENERATION_FINISHED & - ,TIMERS_DOMAIN & - ,NPE_PRINT & - ,PRINT_TIMING ) -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** The following USEs are needed for NMM-B time series output. -!----------------------------------------------------------------------- -! - USE MODULE_SOLVER_INTERNAL_STATE, ONLY: SOLVER_INTERNAL_STATE & - ,WRAP_SOLVER_INT_STATE -! - USE MODULE_TIMESERIES -! -!----------------- -!*** Arguments IN -!----------------- -! - INTEGER(kind=KINT),INTENT(IN) :: COMM_GLOBAL & !<-- The MPI communicator for all tasks (COMM_WORLD) - ,FILTER_METHOD & !<-- The type of digital filtering desired - ,MYPE & !<-- Local task rank on this domain - ,NPE_PRINT & !<-- Task to print clocktimes - ,NPHS & !<-- Physics timestep - ,NTRACK & !<-- Storm locator flag - ,NUM_2WAY_CHILDREN & !<-- How many 2-way children on this domain? - ,RUNSTEPCOUNT !<-- # of integration steps per coupling step - - INTEGER(kind=KINT),INTENT(INOUT) :: NUM_CHILDREN !<-- # of children on this domain -! - REAL(kind=KFPT),INTENT(IN) :: DT !<-- Fundamental timestep of this domain (REAL) (s) -! - LOGICAL(kind=KLOG),INTENT(IN) :: NESTING & !<-- Are there any nested domains? - ,PRINT_TIMING & !<-- Shall we print timing in err file? - ,RESTARTED_RUN & !<-- Is this a restarted run? - ,RST_OUT_00 !<-- Shall we write 00h history in restarted run? -! - CHARACTER(5) ,INTENT(IN) :: NEST_MODE !<-- 1-way or 2-way nesting - CHARACTER(8) ,INTENT(IN) :: CLOCK_DIRECTION !<-- The direction of time in the Clock - CHARACTER(12),INTENT(IN) :: TASK_MODE !<-- Task assignments unique per domain or generational? - - LOGICAL(kind=KLOG),INTENT(IN) :: I_AM_A_FCST_TASK & !<-- Am I in a forecast task? - ,I_AM_LEAD_FCST_TASK & !<-- Am I the first forecast task in the domain's comm? - ,I_AM_A_NEST !<-- Am I in a nested domain? -! - TYPE(ESMF_TimeInterval),INTENT(IN) :: TIMESTEP !<-- Fundamental timestep of this domain (ESMF) (s) -! -!-------------------- -!*** Arguments INOUT -!-------------------- -! - INTEGER(kind=KINT),INTENT(INOUT) :: NTIMESTEP_EXT !<-- This domain's current timestep count -! - LOGICAL(kind=KLOG),INTENT(OUT) :: ADVANCED !<-- Did the integration advance during the routine? -! - TYPE(ESMF_GridComp),INTENT(INOUT) :: DOMAIN_GRID_COMP !<-- The DOMAIN component -! - TYPE(ESMF_Time),INTENT(INOUT) :: CURRTIME & !<-- The clock's current time - ,STARTTIME !<-- The clock's start time -! - TYPE(ESMF_Clock),INTENT(INOUT) :: CLOCK_INTEGRATE !<-- This DOMAIN Component's ESMF Clock -! - TYPE(ESMF_State),INTENT(INOUT) :: IMP_STATE_DOMAIN & !<-- Import state of this DOMAIN component - ,EXP_STATE_DOMAIN !<-- Export state of this DOMAIN component -! - TYPE(INTEGRATION_TIMERS),TARGET :: TIMERS_DOMAIN !<-- Clocktime variables to be printed. -! -!------------------------ -!*** Optional Arguments -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN),OPTIONAL :: MY_DOMAIN_ID & !<-- The ID of this domain - ,NDFISTEP & - ,PAR_CHI_TIME_RATIO !<-- Ratio of parent's timestep to this domain's -! - LOGICAL(kind=KLOG),INTENT(IN),OPTIONAL :: LAST_GENERATION & !<-- For 2-way nests, is this the final generation? - ,MY_DOMAIN_MOVES !<-- Does my domain move? -! - LOGICAL(kind=KLOG),INTENT(INOUT),OPTIONAL :: INTEGRATE_TIMESTEP !<-- For 2-way nests, is this the final generation? -! - LOGICAL(kind=KLOG),INTENT(OUT),OPTIONAL :: GENERATION_FINISHED !<-- Is a generation through with its integration? -! - TYPE(ESMF_State),INTENT(INOUT),OPTIONAL:: IMP_STATE_CPL_NEST & - ,EXP_STATE_CPL_NEST -! - TYPE(ESMF_Time),INTENT(IN),OPTIONAL :: HALFDFITIME -! - TYPE(ESMF_TimeInterval),INTENT(IN),OPTIONAL :: HALFDFIINTVAL & - ,INTERVAL_CLOCKTIME & !<-- Time interval between clocktime prints - ,INTERVAL_HISTORY & !<-- Time interval between history output - ,INTERVAL_RESTART !<-- Time interval between restart output -! - TYPE(ESMF_CplComp),INTENT(INOUT),OPTIONAL :: PARENT_CHILD_CPL !<-- Coupler component for parent-child/nest exchange -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: YY,YY1,YY2,MM,DD,H,M,S,START_SEC,STOP_SEC -! - INTEGER(kind=KINT) :: FIRST_STEP,I,KOUNT_STEPS,LAST_STEP & - ,N,NSTEP_INTEGRATE,NSECONDS_FCST & - ,NTIMESTEP -! - INTEGER(kind=KINT) :: IERR,RC,RC_INTEG -! - INTEGER(kind=ESMF_KIND_I8) :: NTIMESTEP_ESMF !<-- The current forecast timestep (ESMF_INT) -! - INTEGER(kind=KINT),DIMENSION(2) :: STORM_CENTER -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: LOC_PAR_CHILD_TIME_RATIO -! - CHARACTER(2) :: INT_TO_CHAR - CHARACTER(6) :: FMT -! - LOGICAL(kind=KLOG) :: ALLCLEAR_FROM_PARENT & - ,RECV_ALL_CHILD_DATA -! - LOGICAL(kind=KLOG) :: E_BDY,N_BDY,S_BDY,W_BDY & - ,FREE_FORECAST & - ,FREE_TO_INTEGRATE & - ,I_AM_ACTIVE & - ,INTEGRATED_SOLVER -! - TYPE(ESMF_Time) :: ALARM_HISTORY_RING & - ,ALARM_RESTART_RING & - ,ALARM_CLOCKTIME_RING -! - TYPE(ESMF_Time) :: STOPTIME -! - TYPE(ESMF_TimeInterval) :: TIMESTEP_FILTER !<-- Dynamics timestep during filter (s) (ESMF) -! - TYPE(DOMAIN_INTERNAL_STATE),POINTER :: DOMAIN_INT_STATE -! - TYPE(WRAP_DOMAIN_INTERNAL_STATE) :: WRAP -! - TYPE(WRAP_SOLVER_INT_STATE) :: WRAP_SOLVER -! - TYPE(SOLVER_INTERNAL_STATE),POINTER :: SOLVER_INT_STATE -! - integer(kind=kint),dimension(8) :: values -!----------------------------------------------------------------------- -!*** For timers. -!----------------------------------------------------------------------- -! - REAL(kind=KFPT) :: phase1_tim,phase3_tim -! - TYPE(INTEGRATION_TIMERS),POINTER :: TD -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Point timers into this domain's timer object. -!----------------------------------------------------------------------- -! - TD=>TIMERS_DOMAIN !<-- Abbreviate the name of this domain's timers. -! -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RC_INTEG=ESMF_SUCCESS -! - FMT='(I2.2)' - WRITE(INT_TO_CHAR,FMT)MY_DOMAIN_ID -! -!----------------------------------------------------------------------- -!*** Before beginning the integration of the DOMAIN component, -!*** extract the internal state which will be needed for -!*** initial writing of history/restart files. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get DOMAIN Internal State in NMM_INTEGRATE" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGetInternalState(DOMAIN_GRID_COMP & - ,WRAP & - ,RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DOMAIN_INT_STATE=>wrap%DOMAIN_INT_STATE -! -!----------------------------------------------------------------------- -!*** When using digital filters the timestep is set back to 0 when -!*** the filtering direction changes and when the filtering ends. -!----------------------------------------------------------------------- -! - IF(domain_int_state%KOUNT_TIMESTEPS==0)THEN - domain_int_state%FIRST_PASS=.TRUE. - ENDIF -! -! -!----------------------------------------------------------------------- -!*** For normal forecast integration set the Alarm ring times -!*** while accounting for restarts and digital filtering. -!----------------------------------------------------------------------- -! - IF(FILTER_METHOD==0.AND.domain_int_state%FIRST_PASS)THEN -! -! if(mype==0)then -! call esmf_clockprint(clock=clock_integrate,rc=rc) -! endif - CALL RESET_ALARMS -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Forecast tasks extract the Solver internal state needed for -!*** timeseries output. These tasks also need to know if they lie -!*** on a boundary of the current domain. -!----------------------------------------------------------------------- -! - IF(I_AM_A_FCST_TASK)THEN -! - CALL ESMF_GridCompGetInternalState(domain_int_state%SOLVER_GRID_COMP & !<-- The Solver component - ,WRAP_SOLVER & !<-- The F90 wrap of the Solver internal state - ,RC) -! - SOLVER_INT_STATE => wrap_solver%INT_STATE -! - S_BDY=(solver_int_state%JTS==solver_int_state%JDS) ! This task is on the southern boundary - N_BDY=(solver_int_state%JTE==solver_int_state%JDE) ! This task is on the northern boundary - W_BDY=(solver_int_state%ITS==solver_int_state%IDS) ! This task is on the western boundary - E_BDY=(solver_int_state%ITE==solver_int_state%IDE) ! This task is on the eastern boundary -! - END IF -! -!----------------------------------------------------------------------- -!*** The limits on the integration timeloop below depend on the -!*** mode of nesting. For 1-way nests the domains all integrate -!*** straight through from the start to the end of the forecast. -!*** Two-way nesting is different due to the children's feedback. -!*** All generations except the lowermost will execute only one -!*** timestep at a time then return since their domains cannot -!*** proceed until they receive internal updates from their children. -!*** The domains in the lowermost generation have no children and -!*** can thus execute a full N timesteps at a time where N is the -!*** number of timesteps within a single timestep of their parents. -!*** Since each task saves the final timestep in the internal -!*** state of each domain it is on then it needs to determine the -!*** forecast's final timestep only once. -!----------------------------------------------------------------------- -! - IF(domain_int_state%FIRST_PASS)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -!xxx MESSAGE_CHECK="NMM_INTEGRATE: Get the Final Timestep" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!xxx CALL ESMF_ClockGet(clock =CLOCK_INTEGRATE & -!xxx ,runTimeStepCount=domain_int_state%TIMESTEP_FINAL & !<-- Final timestep of this domain's forecast -!xxx ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -!xxx CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - domain_int_state%KOUNT_TIMESTEPS=0 !<-- Initialize timestep counter on this domain -! domain_int_state%FIRST_PASS=.FALSE. -! - ENDIF -! -!----------------------------------------------------------------------- -! - FIRST_STEP=NTIMESTEP_EXT -! -!----------------------------------------------------------------------- -!*** What is the last timestep of the entire integration? -!----------------------------------------------------------------------- -! - IF(TASK_MODE=='unique')THEN !<-- Single domains and 1-way nests integrate to end of fcst -! -!xxx fix for coupled runs -!!!!!! cpl_fix: if(runstepcount>0)then !<-- this means there is coupling -!!!!!! last_step=first_step+runstepcount-1 -!!!!!! else cpl_fix -!xxxxfix for coupled runs -!!!!!! IF(FILTER_METHOD==0.AND.domain_int_state%FIRST_PASS)THEN !<-- Free forecast - IF(FILTER_METHOD==0)THEN !<-- Free forecast -! -!*** Without this ClockGet the FIRST_PASS from above represents the filter -!*** clock if a filter case. -! - CALL ESMF_ClockGet(clock =CLOCK_INTEGRATE & - ,runTimeStepCount=domain_int_state%TIMESTEP_FINAL & - ,stopTime =STOPTIME & - ,rc =RC) -! - IF(domain_int_state%FIRST_PASS)THEN - CALL RESET_ALARMS - ENDIF -! -! LAST_STEP=NINT(domain_int_state%TIMESTEP_FINAL)-1 - LAST_STEP=FIRST_STEP+RUNSTEPCOUNT-1 -! if(mype==0)then -! write(0,33661)last_step,first_step,runstepcount -33661 format(' NMM_INTEG last_step=',i5,' first_step=',i5,' runtimestepcount=',i5) -! endif -! - ELSE !<-- Digital filter -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INTEGRATE: Get Filter StopTime" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock =CLOCK_INTEGRATE & !<-- The filter clock - ,stopTime=STOPTIME & !<-- The simulation stop time (ESMF) - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeGet(STARTTIME,yy=YY1,s=START_SEC,rc=RC) - if(rc/=0)then - write(0,20001)rc -20001 format(' NMM_INTEGRATE timeget1 rc=',i3) - endif - CALL ESMF_TimeGet(STOPTIME ,yy=YY2,s=STOP_SEC ,rc=RC) - if(rc/=0)then - write(0,20002)rc -20002 format(' NMM_INTEGRATE timeget2 rc=',i3) - endif -! - IF(YY1/=YY2)THEN !<-- Account for dates that straddle 31 Dec / 1 Jan -! - IF(CLOCK_DIRECTION=='Bckward ')THEN - IF(MOD(YY2,4)==0)THEN - STOP_SEC=STOP_SEC-31557600 - ELSE - STOP_SEC=STOP_SEC-31536000 - ENDIF -! - ELSEIF(CLOCK_DIRECTION=='Forward ')THEN - IF(MOD(YY1,4)==0)THEN - START_SEC=START_SEC-31557600 - ELSE - START_SEC=START_SEC-31536000 - ENDIF -! - ENDIF -! - ENDIF -! - NSECONDS_FCST=ABS(STOP_SEC-START_SEC) !<-- The forecast length (sec) (REAL) - LAST_STEP=NINT(NSECONDS_FCST/DT)-1 - - ENDIF -! - ELSEIF(TASK_MODE=='generational')THEN - IF(.NOT.PRESENT(LAST_GENERATION))THEN - WRITE(0,*)' LAST_GENERATION must be supplied for 2-way nesting but was not.' - WRITE(0,*)' Aborting!!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - IF(.NOT.LAST_GENERATION)THEN - LAST_STEP=FIRST_STEP !<-- Most 2-way domains integrate one timestep at a time - ELSE - LAST_STEP=NTIMESTEP_EXT+PAR_CHI_TIME_RATIO-1 !<-- Lowest generation 2-way nests run through a parent timestep - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** THE INTEGRATION TIME LOOP OF THE ATMOSPHERE. -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** For runs with a single domain or with 1-way nesting then the -!*** tasks will execute straight through from the beginning of the -!*** forecast (or the restart time) to the end of the forecast. -!*** For runs with 2-way nesting the tasks integrate only through -!*** one or a few timesteps at a time as described above. However note that -!*** the timestep will be incremented only after phase 1 of the -!*** Domain component's Run step is executed. Due to the nature of -!*** the generational use of task assignments in 2-way nesting some -!*** tasks will enter timeloop_drv but not be allowed to integrate -!*** (i.e., to call DOMAIN_RUN which is phase 1 of the Run step of -!*** the Domain component) because: (1) parent domains must first -!*** recv 2-way exchange data from all of their children at the end -!*** of each parent timestep; (2) child domains at the end of their -!*** parents' timesteps must be informed by their parent that the -!*** parent did recv exchange data from all its children meaning the -!*** given child can proceed because its parent is free to integrate -!*** to the end of its next timestep and send back BC update data. -!*** If a domain is both a parent and a child then both of those -!*** conditions must be true for the domain to integrate another -!*** timestep. -!----------------------------------------------------------------------- -! if(mype==0)then -! write(0,44251)ntimestep_ext,first_step,last_step -44251 format(' NMM_INTEG before timeloop_drv ntimestep_ext=',i4,' first_step=',i4,' last_step=',i4) -! endif -! - timeloop_drv: DO NSTEP_INTEGRATE=FIRST_STEP,LAST_STEP !<-- For 1-way nesting this would go from start to end of the fcst -! -! call print_memory() -!----------------------------------------------------------------------- -! - KOUNT_STEPS=domain_int_state%KOUNT_TIMESTEPS - NTIMESTEP=KOUNT_STEPS !<-- Internal timesteps to avoid confusion with NUOPC Clock - I_AM_ACTIVE=.TRUE. -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INTEGRATE: Extract Free Forecast flag" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE_CPL_NEST & !<-- The parent-child coupler import state - ,name ='Free Forecast' & !<-- Flag for free forecasts. - ,value=FREE_FORECAST & !<-- Is this the freee forecast? - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(I_AM_A_FCST_TASK.AND..NOT.FREE_FORECAST)THEN - IF(MY_DOMAIN_ID>1.OR.NUM_CHILDREN>1)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INTEGRATE: Extract I_AM_ACTIVE" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_CPL_NEST & !<-- The parent-child coupler export state - ,name ='I Am Active' & !<-- Flag for digital filter activity. - ,value=I_AM_ACTIVE & !<-- Is this domain active in the digital filter? - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF - ENDIF -! -!----------------------------------------------------------------------- -!*** For 2-way nesting check for the signals from parents and -!*** children to know if the execution can proceed into this timestep. -!*** Call phase 1 of the Parent-Child coupler's Run step to perform -!*** these checks. The subroutine name is CHECK_2WAY_SIGNALS. -!----------------------------------------------------------------------- -! - check_2way: IF(NEST_MODE=='2-way' & - .AND. & - I_AM_A_FCST_TASK)THEN - btim0=timef() -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Call Phase 1 Coupler Run: Check 2-Way Signals" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_CplCompRun(cplcomp =PARENT_CHILD_CPL & !<-- The Parent-Child coupler component - ,importState=IMP_STATE_CPL_NEST & !<-- The Parent-Child coupler import state - ,exportState=EXP_STATE_CPL_NEST & !<-- The Parent-Child coupler export state - ,clock =CLOCK_INTEGRATE & !<-- The Domain Clock - ,phase =1 & !<-- The phase (subroutine) of the coupler to execute - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** What are the values of the 2-way signals? -!----------------------------------------------------------------------- -! - IF(KOUNT_STEPS>0)THEN -! -!-------------------------------------------------------------- -!*** Is 2-way data ready for my parent from all its children? -!-------------------------------------------------------------- -! - IF(I_AM_A_NEST)THEN - IF(MOD(NSTEP_INTEGRATE,PAR_CHI_TIME_RATIO)==0)THEN -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INTEGRATE: Extract ALLCLEAR from P-C Exp State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_CPL_NEST & !<-- The parent-child coupler export state - ,name ='ALLCLEAR' & !<-- Flag for proceeding now in timestep - ,value=ALLCLEAR_FROM_PARENT & !<-- Parent did/not recv all exch data; child can/not proceed - ,rc =RC) -! - domain_int_state%ALLCLEAR_FROM_PARENT=ALLCLEAR_FROM_PARENT -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(.NOT.domain_int_state%ALLCLEAR_FROM_PARENT)THEN -! - RETURN !<-- All my siblings are not yet ready to send our parent -! ! their 2-way data. - ENDIF - ENDIF - ENDIF -! -!------------------------------------------------------------------ -!*** Are all of my children ready to send their 2-way data to me? -!------------------------------------------------------------------ -! - IF(NUM_2WAY_CHILDREN>0)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Call Coupler: Extract RECV_ALL_CHILD_DATA from P-C Exp State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_CPL_NEST & !<-- The parent-child coupler export state - ,name ='Recv All Child Data' & !<-- Flag for integration (true or false) - ,value=RECV_ALL_CHILD_DATA & !<-- The value of the integration flag - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - domain_int_state%RECV_ALL_CHILD_DATA=RECV_ALL_CHILD_DATA -! - IF(.NOT.domain_int_state%RECV_ALL_CHILD_DATA)THEN -! - RETURN !<-- All my children are not yet ready to send me -! ! their 2-way data. - ENDIF - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF -! -!----------------------------------------------------------------------- -! - td%pc_cpl_run_cpl1=td%pc_cpl_run_cpl1+(timef()-btim0) - ENDIF check_2way -! -!----------------------------------------------------------------------- -!*** Children receive data from their parents at the beginning -!*** of child timesteps that coincide with the beginning of -!*** parent timesteps. -! -!*** (1) At the beginning of every such timestep the children -!*** receive new boundary data that is sent by their parents -!*** from the end of that parent timestep so the children can -!*** compute boundary value tendencies to be used for the -!*** integration through the next N child timesteps where -!*** N is the number of child timesteps per parent timestep. -!*** The handling of these new boundary values is the only -!*** action in this phase of the Parent-Child coupler for -!*** domains that are static 1-way nests. -! -!*** (2) If a child is a moving nest that has decided it must move: -!*** (a) It sends a message to its parent informing it of that -!*** fact along with the location to which it is moving on -!*** the parent grid. That move must happen at a -!*** parent timestep in the future because the parent -!*** must provide data to some internal child points -!*** following a move and since the parent must always -!*** run ahead of its children (to provide the boundary -!*** data from the future) then the new data for those -!*** internal child points must also originate at a -!*** future timestep. That future parent timestep in -!*** which the nest will shift is also sent to the parent. -!*** (b) If the current timestep is equal to the timestep -!*** in which the nest determined it wants to shift then -!*** the child now Recvs the parent data for its internal -!*** gridpoints that have moved over a new portion of the -!*** parent grid as well as the first boundary data at the -!*** new location. -!*** (c) The child Recvs the new boundary data sent by the parent -!*** from the future [see (1) above]. -!----------------------------------------------------------------------- -! -! - IF(I_AM_A_NEST.AND.I_AM_A_FCST_TASK)THEN - btim0=timef() -! - IF(MOD(KOUNT_STEPS,PAR_CHI_TIME_RATIO)==0)THEN !<-- Child is at the start of a parent timestep. -! -!----------------------------------------------------------------------- -!*** Call Phase 2 of the Run step of the Parent-Child coupler in -!*** which children receive BC data from their parents. The -!*** name of the subroutine is CHILDREN_RECV_PARENT_DATA. If the -!*** child is a moving nest then its shifts in position take place -!*** in this phase as well since BC data from the parent depends -!*** on the location of the child domain. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Call Phase 2 Coupler Run: Children Recv Data from Parents" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_CplCompRun(cplcomp =PARENT_CHILD_CPL & !<-- The Parent-Child coupler component - ,importState=IMP_STATE_CPL_NEST & !<-- The Parent-Child coupler import state - ,exportState=EXP_STATE_CPL_NEST & !<-- The Parent-Child coupler export state - ,clock =CLOCK_INTEGRATE & !<-- The Domain Clock - ,phase =2 & !<-- The phase (subroutine) of the coupler to execute - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** The new nest boundary data must be moved from the Parent-Child -!*** coupler into the nest's DOMAIN component. Do not do this -!*** if the digital filter is running and the child domain is not -!*** active. -!----------------------------------------------------------------------- -! - IF(FREE_FORECAST.OR.(FILTER_METHOD>0.AND.I_AM_ACTIVE))THEN - CALL BOUNDARY_DATA_STATE_TO_STATE(s_bdy =S_BDY & !<-- This task lies on a south boundary? - ,n_bdy =N_BDY & !<-- This task lies on a north boundary? - ,w_bdy =W_BDY & !<-- This task lies on a west boundary? - ,e_bdy =E_BDY & !<-- This task lies on an east boundary? - ,nest =domain_int_state%I_AM_A_NEST & !<-- The nest flag (yes or no) - ,state_in =EXP_STATE_CPL_NEST & !<-- The P-C coupler export state - ,state_out=IMP_STATE_DOMAIN) !<-- The Domain import state - ENDIF -! -!----------------------------------------------------------------------- -!*** If the nest is movable then the DOMAIN component must be -!*** informed if the nest does or does not want to move now. -!*** If it does want to move now then all of the interior update -!*** data generated by the parent must be transferred to the DOMAIN -!*** import state. -!----------------------------------------------------------------------- -! - IF(MY_DOMAIN_MOVES)THEN -! -! - CALL INTERIOR_DATA_STATE_TO_STATE(EXP_STATE_CPL_NEST & - ,IMP_STATE_DOMAIN ) -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF -! - td%pc_cpl_run_cpl2=td%pc_cpl_run_cpl2+(timef()-btim0) - ENDIF -! -!----------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------- -!*** Call phase 3 of the Run step of the Parent-Child coupler. -!*** The name of the subroutine is PARENTS_RECV_CHILD_2WAY_DATA. -!*** It is at this point that the appropriate parent tasks receive -!*** 2-way exchange data from their children. -!----------------------------------------------------------------------- -! -! - IF(I_AM_A_FCST_TASK)THEN -! - IF(NUM_2WAY_CHILDREN>0)THEN !<-- Parents w/ 2way children call phase 3 of P-C coupler -! - IF(KOUNT_STEPS>0)THEN - btim0=timef() -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Call Phase 3 Coupler Run: Parents Recv Exchange Data from Children" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_CplCompRun(cplcomp =PARENT_CHILD_CPL & !<-- The parent-child coupler component - ,importState=IMP_STATE_CPL_NEST & !<-- The parent-child coupler import state - ,exportState=EXP_STATE_CPL_NEST & !<-- The parent-child coupler export state - ,clock =CLOCK_INTEGRATE & !<-- The DOMAIN Clock - ,phase =3 & !<-- The phase (subroutine) of the coupler to execute - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - td%pc_cpl_run_cpl3=td%pc_cpl_run_cpl3+(timef()-btim0) - ENDIF -! - ENDIF -! - ENDIF -! -! -!----------------------------------------------------------------------- -!*** If filtering is not in effect and this is the start or restart -!*** of a forecast then write out a history file. -!----------------------------------------------------------------------- -! - history_output_0_a: IF(NTIMESTEP==0 & - .AND. & - .NOT.RESTARTED_RUN & - .AND. & - FILTER_METHOD==0 & - .AND. & - .NOT.domain_int_state%WROTE_1ST_HIST & - .AND. & - domain_int_state%QUILTING)THEN -! - CWRT='History' - domain_int_state%WROTE_1ST_HIST=.TRUE. -! - CALL WRITE_ASYNC(DOMAIN_GRID_COMP & - ,DOMAIN_INT_STATE & - ,CLOCK_INTEGRATE & - ,MYPE & - ,CWRT) -! - ENDIF history_output_0_a -! - history_output_0_b: IF(RESTARTED_RUN & - .AND. & - domain_int_state%RESTARTED_RUN_FIRST & - .AND. & - RST_OUT_00 & - .AND. & - .NOT.domain_int_state%WROTE_1ST_HIST & - .AND. & - (FILTER_METHOD == 0) & - .AND. & - domain_int_state%QUILTING)THEN -! - domain_int_state%RESTARTED_RUN_FIRST=.FALSE. - CWRT='History' - domain_int_state%WROTE_1ST_HIST=.TRUE. -! - CALL WRITE_ASYNC(DOMAIN_GRID_COMP & - ,DOMAIN_INT_STATE & - ,CLOCK_INTEGRATE & - ,MYPE & - ,CWRT) -! - ENDIF history_output_0_b -! -!----------------------------------------------------------------------- -!*** Initialize the timeseries output and write timestep 0 data -!*** for this domain. -!----------------------------------------------------------------------- -! - time_series_0: IF(.NOT.domain_int_state%TS_INITIALIZED) THEN -! - IF(MYPE0.AND.I_AM_ACTIVE))THEN - CALL ESMF_GridCompRun(gridcomp =DOMAIN_GRID_COMP & !<-- The DOMAIN gridded component - ,importState=IMP_STATE_DOMAIN & !<-- The DOMAIN import state - ,exportState=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,clock =CLOCK_INTEGRATE & !<-- The ESMF DOMAIN Clock - ,phase =1 & !<-- The phase (subroutine) of DOMAIN Run to execute - ,rc =RC) - ENDIF -! ENDIF -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - phase1_tim = (timef()-btim0) - td%domain_run_1=td%domain_run_1+phase1_tim -! -!----------------------------------------------------------------------- -!*** If this domain moves then transfer the storm center location -!*** to the P-C coupler import state. -!----------------------------------------------------------------------- -! - IF(I_AM_A_FCST_TASK.AND.MY_DOMAIN_MOVES.AND.NTRACK>0)THEN -! - IF(NTIMESTEP==0. & - .OR. & - MOD(NTIMESTEP+1,NTRACK*NPHS)==0)THEN - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INTEGRATE: Get storm center location." -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =EXP_STATE_DOMAIN & !<-- The Domain component export state - ,name ='Storm Center' & !<-- Name of the attribute to extract - ,valueList=STORM_CENTER & !<-- I,J of storm center - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_Integrate: Transfer storm center location." -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The parent-child coupler import state - ,name ='Storm Center' & !<-- I,J of storm center - ,itemCount=2 & !<-- There are 2 words - ,valueList=STORM_CENTER & !<-- The data is here. - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Now that this domain has integrated a timestep, if it is a -!*** 2-way run then reset the 2-way signal flags from the parent -!*** and children of this domain. -!----------------------------------------------------------------------- -! - IF(NEST_MODE=='2-way')THEN !<-- Reset these 2-way flags - IF(I_AM_A_NEST.AND.I_AM_A_FCST_TASK)THEN - domain_int_state%RECV_ALL_CHILD_DATA=.FALSE. -! - IF(MOD(KOUNT_STEPS+1,PAR_CHI_TIME_RATIO)==0)THEN - domain_int_state%ALLCLEAR_FROM_PARENT=.FALSE. - ALLCLEAR_FROM_PARENT=domain_int_state%ALLCLEAR_FROM_PARENT -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_Integrate: Set ALLCLEAR Signal in P-C Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE_CPL_NEST & !<-- The parent-child coupler import state - ,name ='ALLCLEAR' & !<-- Flag for ALLCLEAR from parent (reset to false) - ,value=ALLCLEAR_FROM_PARENT & !<-- The value of the ALLCLEAR flag - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** A parent sends BC data to its children at the end of each parent -!*** timestep and before any potential filter averaging. -!*** -!*** (1) For static nests the parents compute only once the association -!*** between their tasks and their children's boundary tasks then -!*** send those child tasks the information they need in order to -!*** be able to properly receive forecast data. Then the parents -!*** send the new boundary data to the child boundary tasks. -!*** (2) For moving nests the parents are sent the new location of -!*** any of their children who moved. The parents then recompute -!*** the association between their tasks and their children's -!*** boundary tasks as well as with child tasks in the new -!*** region of the parent into which the children moved. Parents -!*** send the pertinent child tasks information they need in -!*** order to receive BC data. Finally the parents send their -!*** moving children new boundary data plus new internal data -!*** for the new area of the parent newly covered by the most -!*** recent motion of the nests. -!----------------------------------------------------------------------- -! -! - IF(NUM_CHILDREN>0.AND.I_AM_A_FCST_TASK)THEN !<-- Fcst tasks call the coupler if there are children - btim0=timef() -! -!----------------------------------------------------------------------- -!*** Call the Run step for phase 4 of the Parent-Child coupler. -!*** The name of the subroutine is PARENTS_SEND_CHILD_DATA. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Call Phase 4 Coupler Run: Parents Send Child Data" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_CplCompRun(cplcomp =PARENT_CHILD_CPL & !<-- The parent-child coupler component - ,importState=IMP_STATE_CPL_NEST & !<-- The parent-child coupler import state - ,exportState=EXP_STATE_CPL_NEST & !<-- The parent-child coupler export state - ,clock =CLOCK_INTEGRATE & !<-- The DOMAIN Clock - ,phase =4 & !<-- The phase (subroutine) of the coupler to execute - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL BOUNDARY_DATA_STATE_TO_STATE(parent =domain_int_state%I_AM_A_PARENT & !<-- Is this a parent domain? - ,state_in = EXP_STATE_CPL_NEST & !<-- The P-C coupler export state - ,state_out= IMP_STATE_DOMAIN) !<-- The Domain import state -! - td%pc_cpl_run_cpl4=td%pc_cpl_run_cpl4+(timef()-btim0) - ENDIF -! -! -!----------------------------------------------------------------------- -!*** Call the Run step for phase 5 of the Parent-Child coupler. -!*** The name of the subroutine is CHILDREN_SEND_PARENTS_2WAY_DATA. -!*** For 2-way nesting the children send exchange data to their -!*** parents at the end of each parent timestep. -!----------------------------------------------------------------------- -! -! - IF(I_AM_A_NEST.AND.I_AM_A_FCST_TASK)THEN -! - IF(NEST_MODE=='2-way')THEN -! - IF(MOD(KOUNT_STEPS+1,PAR_CHI_TIME_RATIO)==0 & !<-- If true then this child has - .AND. & ! reached the end of a timestep - MY_DOMAIN_ID>1)THEN ! of its parent. - btim0=timef() -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Call Phase 5 Coupler Run: Children Send 2-Way Data to Parents" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_CplCompRun( PARENT_CHILD_CPL & !<-- The Parent-Child coupler component - ,importState=IMP_STATE_CPL_NEST & !<-- The Parent-Child coupler import state - ,exportState=EXP_STATE_CPL_NEST & !<-- The Parent-Child coupler export state - ,clock =CLOCK_INTEGRATE & !<-- The Domain Clock - ,phase =5 & !<-- The phase (subroutine) of the coupler to execute - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - td%pc_cpl_run_cpl5=td%pc_cpl_run_cpl5+(timef()-btim0) - ENDIF -! - ENDIF -! - ENDIF -! -! -!----------------------------------------------------------------------- -!*** If digital filtering is currently executing then call phase 2 -!*** of the Domain component's Run step. The subroutine name of this -!*** phase is NMM_FILTERING. -!----------------------------------------------------------------------- -! - IF(FILTER_METHOD>0.AND.I_AM_A_FCST_TASK.AND.I_AM_ACTIVE)THEN - btim0=timef() -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INTEGRATE: Phase 2 Domain Run for Filtering " -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompRun(gridcomp =DOMAIN_GRID_COMP & !<-- The DOMAIN gridded component for this domain - ,importState=IMP_STATE_DOMAIN & !<-- The DOMAIN import state - ,exportState=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,clock =CLOCK_INTEGRATE & !<-- The ESMF DOMAIN Clock - ,phase =2 & !<-- The phase (subroutine) of DOMAIN Run to execute - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - td%domain_run_2=td%domain_run_2+(timef()-btim0) - ENDIF -! -! -!----------------------------------------------------------------------- -!*** Increment the timestep if integration took place. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INTEGRATE: Advance the Timestep" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockAdvance(clock=CLOCK_INTEGRATE & - ,rc =RC) -! - KOUNT_STEPS=KOUNT_STEPS+1 - domain_int_state%KOUNT_TIMESTEPS=KOUNT_STEPS - ADVANCED=.TRUE. -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(FILTER_METHOD > 0 .AND. I_AM_LEAD_FCST_TASK ) THEN - WRITE(0,*)'Filter is running, KOUNT_STEPS= ',KOUNT_STEPS,' for method=',FILTER_METHOD - ENDIF -! -!----------------------------------------------------------------------- -!*** Retrieve the timestep from the DOMAIN clock and -!*** print the forecast time. -!----------------------------------------------------------------------- -! - CALL ESMF_ClockGet(clock =CLOCK_INTEGRATE & - ,advanceCount=NTIMESTEP_ESMF & !<-- # of times the clock has advanced - ,rc =RC) -! - NTIMESTEP=NTIMESTEP_ESMF -! write(0,57611)ntimestep,kount_steps -57611 format(' NMM_INTEGRATE advanced CLOCK_INTEGRATE ntimestep=',i5 & - ,' kount_steps=',i5) -! -!----------------------------------------------------------------------- -!*** Write timeseries data for this timestep on this domain. -!----------------------------------------------------------------------- -! - IF(MYPE0.AND.I_AM_A_FCST_TASK)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Cpl2 Wait Time from Parent-Child Cpl Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_CPL_NEST & !<-- The Parent-Child Coupler export state - ,name ='Cpl2_Wait_Time' & !<-- Name of the attribute to extract - ,value=td%cpl2_wait_tim & !<-- Clocktime for Wait in phase 2 of Cpl - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Cpl2 Comp Time from Parent-Child Cpl Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_CPL_NEST & !<-- The Parent-Child Coupler export state - ,name ='Cpl2_Comp_Time' & !<-- Name of the attribute to extract - ,value=td%cpl2_comp_tim & !<-- Clocktime for Compute in Phase 2 of Cpl - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Cpl2 Send Time from Parent-Child Cpl Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_CPL_NEST & !<-- The Parent-Child Coupler export state - ,name ='Cpl2_Send_Time' & !<-- Name of the attribute to extract - ,value=td%cpl2_send_tim & !<-- Clocktime for Send in Phase 2 of Cpl - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - MESSAGE_CHECK="Extract parent_bookkeep_moving_tim from Parent-Child Cpl Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_CPL_NEST & !<-- The Parent-Child Coupler export state - ,name ='parent_bookkeep_moving_tim' & !<-- Name of the attribute to extract - ,value=td%parent_bookkeep_moving_tim & !<-- moving nest bookeeping time - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - MESSAGE_CHECK="Extract parent_update_moving_tim from Parent-Child Cpl Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_CPL_NEST & !<-- The Parent-Child Coupler export state - ,name ='parent_update_moving_tim' & !<-- Name of the attribute to extract - ,value=td%parent_update_moving_tim & !<-- moving nest update time - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - MESSAGE_CHECK="Extract t0_recv_move_tim from Parent-Child Cpl Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_CPL_NEST & !<-- The Parent-Child Coupler export state - ,name ='t0_recv_move_tim' & !<-- Name of the attribute to extract - ,value=td%t0_recv_move_tim & !<-- task 0 time to process receive of move flag - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - MESSAGE_CHECK="Extract read_moving_child_topo_tim from Parent-Child Cpl Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_CPL_NEST & !<-- The Parent-Child Coupler export state - ,name ='read_moving_child_topo_tim' & !<-- Name of the attribute to extract - ,value=td%read_moving_child_topo_tim & !<-- task 0 time to process receive of move flag - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - MESSAGE_CHECK="Extract barrier_move_tim from Parent-Child Cpl Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_CPL_NEST & !<-- The Parent-Child Coupler export state - ,name ='barrier_move_tim' & !<-- Name of the attribute to extract - ,value=td%barrier_move_tim & !<-- task 0 time to process receive of move flag - ,rc =RC) - - CALL ESMF_AttributeGet(state=EXP_STATE_CPL_NEST & !<-- The Parent-Child Coupler export state - ,name ='pscd_tim' & !<-- Name of the attribute to extract - ,value=td%pscd_tim & !<-- task 0 time to process receive of move flag - ,rc =RC) - CALL ESMF_AttributeGet(state=EXP_STATE_CPL_NEST & !<-- The Parent-Child Coupler export state - ,name ='pscd1_tim' & !<-- Name of the attribute to extract - ,value=td%pscd1_tim & !<-- task 0 time to process receive of move flag - ,rc =RC) - CALL ESMF_AttributeGet(state=EXP_STATE_CPL_NEST & !<-- The Parent-Child Coupler export state - ,name ='pscd2_tim' & !<-- Name of the attribute to extract - ,value=td%pscd2_tim & !<-- task 0 time to process receive of move flag - ,rc =RC) - CALL ESMF_AttributeGet(state=EXP_STATE_CPL_NEST & !<-- The Parent-Child Coupler export state - ,name ='pscd3_tim' & !<-- Name of the attribute to extract - ,value=td%pscd3_tim & !<-- task 0 time to process receive of move flag - ,rc =RC) - CALL ESMF_AttributeGet(state=EXP_STATE_CPL_NEST & !<-- The Parent-Child Coupler export state - ,name ='pscd4_tim' & !<-- Name of the attribute to extract - ,value=td%pscd4_tim & !<-- task 0 time to process receive of move flag - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - - ENDIF -! -!----------------------------------------------------------------------- -! - IF(.NOT. NESTING) THEN !<-- Parent only run - IF (td%domain_run_1 < 1.0) THEN !<-- An I/O task - IF(PRINT_TIMING) & - WRITE(0,899)td%domain_run_3 - ELSE - IF (td%domain_run_2 > 1.0) THEN !<-- Digital filter - IF(PRINT_TIMING) & - WRITE(0,900)td%domain_run_1,td%domain_run_2,td%domain_run_3 - ELSE - IF(PRINT_TIMING) & - WRITE(0,901)td%domain_run_1,td%domain_run_3 !<-- Primary compute task - ENDIF - ENDIF -! - ELSE - IF(I_AM_A_FCST_TASK)THEN !<-- Nested run and a forecast task - IF (td%domain_run_2 > 1.0) THEN !<-- Digital filter - WRITE(0,800)my_domain_id,td%pc_cpl_run_cpl1,td%pc_cpl_run_cpl2 & - ,td%pc_cpl_run_cpl3,td%domain_run_1,td%pc_cpl_run_cpl4 & - ,td%pc_cpl_run_cpl5,td%domain_run_2,td%domain_run_3 - ELSE - IF(td%domain_run_3 > 1.0) then - WRITE(0,801)my_domain_id,td%pc_cpl_run_cpl1,td%pc_cpl_run_cpl2 & - ,td%pc_cpl_run_cpl3,td%domain_run_1,td%pc_cpl_run_cpl4 & - ,td%pc_cpl_run_cpl5,td%domain_run_3 - WRITE(0,803)my_domain_id,td%parent_bookkeep_moving_tim & - ,td%cpl2_comp_tim,td%cpl2_send_tim,td%cpl2_wait_tim & - ,td%barrier_move_tim -!jaa WRITE(0,803)my_domain_id,td%parent_bookkeep_moving_tim & -!jaa ,td%parent_update_moving_tim,td%t0_recv_move_tim & -!jaa ,td%read_moving_child_topo_tim,td%barrier_move_tim - WRITE(0,804)my_domain_id,td%pscd_tim,td%pscd1_tim,td%pscd2_tim & - ,td%pscd3_tim,td%pscd4_tim - ELSE - WRITE(0,802)my_domain_id,td%pc_cpl_run_cpl1,td%pc_cpl_run_cpl2 & - ,td%pc_cpl_run_cpl3,td%domain_run_1,td%pc_cpl_run_cpl4 & - ,td%pc_cpl_run_cpl5 - WRITE(0,803)my_domain_id,td%parent_bookkeep_moving_tim & - ,td%cpl2_comp_tim,td%cpl2_send_tim,td%cpl2_wait_tim & - ,td%barrier_move_tim -!jaa WRITE(0,803)my_domain_id,td%parent_bookkeep_moving_tim & -!jaa ,td%parent_update_moving_tim,td%t0_recv_move_tim & -!jaa ,td%read_moving_child_topo_tim,td%barrier_move_tim - WRITE(0,804)my_domain_id,td%pscd_tim,td%pscd1_tim,td%pscd2_tim & - ,td%pscd3_tim,td%pscd4_tim - - ENDIF - ENDIF - ELSE !<-- I/O tasks - WRITE(0,899)td%domain_run_3 - ENDIF - ENDIF -! - 897 FORMAT(' The timers that may be printed include: '/ & - ' Integrate - timers around gridcomp_run phase=1 for parent tasks in NMM_Integrate ',/& - ' Filter - timers around gridcomp_run phase=2 in NMM_Integrate ',/& - ' Phase 3(I/O) - timers around gridcomp_run phase=3 in NMM_Integrate ',/& - ' cpl compute - timers around gridcomp_run phase=1 for nest tasks in NMM_Integrate or ',/& - ' cpl compute - time for parent tasks to compute boundary updates ',/& - ' cpl recv - time nest tasks spend waiting to receive boundary updates from parents ',/& - ' update interior nest - time nest task spends updating from other nest tasks in a moving nest ',/& - ' update interior parent - time nest task spends updating from parent tasks in a moving nest ',/& - ' update parent move- time parent task spends updating nest internal points in a moving nest ',/& - ' cpl wait - time parent task spends waiting for nest tasks to receive boundary data ',/& - ' cpl 2-way send - time child task computing/sending exchange data to parent ') - - 800 FORMAT(' For domain ',i2,' c1 ',g10.3,' c2 ',g10.3,' c3 ',g10.3 & - ,' run ',g10.3,' c4 ',g10.3,' c5 ',g10.3,' df ',g10.3 & - ,' i/o ',g10.3) - 801 FORMAT(' For domain ',i2,' c1 ',g10.3,' c2 ',g10.3,' c3 ',g10.3 & - ,' run ',g10.3,' c4 ',g10.3,' c5 ',g10.3,' i/o ',g10.3) - 802 FORMAT(' For domain ',i2,' c1 ',f10.5,' c2 ',f10.3,' c3 ',f10.5 & - ,' run ',f10.5,' c4 ',f10.5,' c5 ',f10.5) -!jaa 803 FORMAT(' For domain ',i2,' pbm ',f10.5,' pumt ',f10.5,' rmt ',f10.5 & -!jaa ,' rmctt ',f10.5,' bmt ',f10.5) - 803 FORMAT(' For domain ',i2,' pbm ',f10.5,' comp ',f10.5,' send ',f10.5 & - ,' wait ',f10.5,' bmt ',f10.5) - 804 FORMAT(' For domain ',i2,' pscd ',f10.5,' pscd1 ',f10.5,' pscd2 ',f10.5 & - ,' pscd3 ',f10.5,' pscd4 ',f10.5) - 899 FORMAT(' I/O task Phase 3= ',g10.3) - 900 FORMAT(' Integrate = ',g10.3,' Filter = ',g10.3, & - ' Phase 3 = ',g10.3,' update parent move = ',g10.3) - 901 FORMAT(' Integrate = ',g10.3,' Phase 3 = ',g10.3, & - ' update parent move = ',g10.3) - -! -!----------------------------------------------------------------------- -! - ELSE driver_run_end !<-- Filtering is in effect -! -!----------------------------------------------------------------------- -!*** If we are completing the execution of digital filtering then reset -!*** the Clock and times. -!----------------------------------------------------------------------- -! - IF(CLOCK_DIRECTION=='Bckward')THEN -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INTEGRATE: Get CurrTime and Timestep for Bckward" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock =CLOCK_INTEGRATE & - ,currtime=CURRTIME & - ,timestep=TIMESTEP_FILTER & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - TIMESTEP_FILTER=-TIMESTEP_FILTER !<-- We must set the timestep back to positive. -! -!----------------------------------------------------------------------- - filter_method_block : IF(FILTER_METHOD==3)THEN -!----------------------------------------------------------------------- -! - ndfiloop: DO I=1,NDFISTEP -! -!----------------------------------------------------------------------- -!*** Now set the timestep of the children at which they receive -!*** data from their parent. This must be known by the parents -!*** since it will provide the proper tag to the MPI data sent. -!----------------------------------------------------------------------- -! - - parents_only: IF(NUM_CHILDREN>0 & - .AND. & - I_AM_A_FCST_TASK)THEN -! -!----------------------------------------------------------------------- -! - IF(.NOT.ALLOCATED(LOC_PAR_CHILD_TIME_RATIO)) THEN - ALLOCATE(LOC_PAR_CHILD_TIME_RATIO(1:NUM_CHILDREN)) - ENDIF -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INTEGRATE: Parent/child DT Ratio for TDFI" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE_CPL_NEST & !<-- The parent-child coupler import state - ,name ='Parent-Child Time Ratio' & !<-- Name of the attribute to extract - ,itemCount=NUM_CHILDREN & !<-- # of items in the Attribute - ,valueList=LOC_PAR_CHILD_TIME_RATIO & !<-- Ratio of parent to child DTs - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DO N=1,NUM_CHILDREN - NSTEP_CHILD_RECV(N)=NSTEP_CHILD_RECV(N) + LOC_PAR_CHILD_TIME_RATIO(N) - ENDDO -! -!----------------------------------------------------------------------- -! - ENDIF parents_only -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INTEGRATE: Advance Clock for TDFI" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockAdvance(clock =CLOCK_INTEGRATE & - ,timestep=TIMESTEP_FILTER & !<-- Advance the clock to the forward starttime - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - ENDDO ndfiloop -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INTEGRATE: Get Current Clock Time for TDFI" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock =CLOCK_INTEGRATE & - ,currtime=CURRTIME & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - ENDIF filter_method_block -! -!----------------------------------------------------------------------- -! - ELSEIF(CLOCK_DIRECTION=='Forward ')THEN -! -!----------------------------------------------------------------------- -! - IF(FILTER_METHOD==1)THEN -! - domain_int_state%FIRST_PASS=.TRUE. -! - CURRTIME=HALFDFITIME-TIMESTEP - NTIMESTEP=NTIMESTEP-(HALFDFIINTVAL/TIMESTEP)-1 - NTIMESTEP_ESMF=NTIMESTEP -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INTEGRATE: Set Time to Half Filter Interval" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockSet(clock =CLOCK_INTEGRATE & !<-- Reset current time and timestep to the - ,currtime =CURRTIME & ! halfway point of the filter interval. - ,advanceCount=NTIMESTEP_ESMF & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF driver_run_end -! -!----------------------------------------------------------------------- -!*** The final error signal information. -!----------------------------------------------------------------------- -! - IF(RC_INTEG==ESMF_SUCCESS)THEN -! WRITE(0,*)'NMM RUN step succeeded' - ELSE - WRITE(0,*)'NMM RUN step failed RC_INTEG=',RC_INTEG - ENDIF -! -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!----------------------------------------------------------------------- -! - SUBROUTINE RESET_ALARMS -! -!----------------------------------------------------------------------- -!*** For normal forecast integration set the Alarm ring times -!*** while accounting for restarts and digital filtering. -!----------------------------------------------------------------------- -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: iyear_fcst & - ,imonth_fcst & - ,iday_fcst & - ,ihour_fcst & - ,iminute_fcst & - ,isecond_fcst & - ,isecond_num & - ,isecond_den -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - IF(CURRTIME==STARTTIME)THEN - ALARM_HISTORY_RING =CURRTIME - ALARM_RESTART_RING =CURRTIME - ALARM_CLOCKTIME_RING=CURRTIME -! write(0,36361) -36361 format(' RESET_ALARMS 1 set ALARM_HISTORY_RING to CURRTIME') - ELSE - IF(RESTARTED_RUN)THEN - ALARM_HISTORY_RING =CURRTIME+INTERVAL_HISTORY - ALARM_RESTART_RING =CURRTIME+INTERVAL_RESTART - ALARM_CLOCKTIME_RING=CURRTIME+INTERVAL_CLOCKTIME - ELSE - ALARM_HISTORY_RING =STARTTIME+INTERVAL_HISTORY - ALARM_RESTART_RING =STARTTIME+INTERVAL_RESTART - ALARM_CLOCKTIME_RING=STARTTIME+INTERVAL_CLOCKTIME -! write(0,36362) -36362 format(' RESET_ALARMS 2 set ALARM_HISTORY_RING to STARTTIME+INTERVAL_HISTORY') - ENDIF - ENDIF -! -#if 0 -!------------------------------------------------- -!*** Adjust time of History Alarm if necessary. -!------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get time from ALARM_HISTORY_RING." -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeGet(time=ALARM_HISTORY_RING & !<-- Extract the time from this variable - ,yy =YY & !<-- Year - ,mm =MM & !<-- Month - ,dd =DD & !<-- Day - ,h =H & !<-- Hour - ,m =M & !<-- Minute - ,s =S & !<-- Second - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(M/=0)THEN - H=H+1 - M=0 -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Reset time in ALARM_HISTORY_RING." -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeSet(time=ALARM_HISTORY_RING & !<-- Reset the time for initial history output - ,yy =YY & !<-- Year - ,mm =MM & !<-- Month - ,dd =DD & !<-- Day - ,h =H & !<-- Hour - ,m =M & !<-- Minute - ,s =S & !<-- Second - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! -!------------------------------------------------- -!*** Adjust time of Restart Alarm if necessary. -!------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get time from ALARM_RESTART_RING." -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeGet(time=ALARM_RESTART_RING & !<-- Extract the time from this variable - ,yy =YY & !<-- Year - ,mm =MM & !<-- Month - ,dd =DD & !<-- Day - ,h =H & !<-- Hour - ,m =M & !<-- Minute - ,s =S & !<-- Second - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(M/=0)THEN - H=H+1 - M=0 -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Reset time in ALARM_RESTART_RING." -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeSet(time=ALARM_RESTART_RING & !<-- Reset the time for initial restart output - ,yy =YY & !<-- Year - ,mm =MM & !<-- Month - ,dd =DD & !<-- Day - ,h =H & !<-- Hour - ,m =M & !<-- Minute - ,s =S & !<-- Second - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! -!------------------------------------------------------------- -!*** Adjust time of Alarm for clocktime writes if necessary. -!------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get time from ALARM_CLOCKTIME_RING." -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeGet(time=ALARM_CLOCKTIME_RING & !<-- Extract the time from this variable - ,yy =YY & !<-- Year - ,mm =MM & !<-- Month - ,dd =DD & !<-- Day - ,h =H & !<-- Hour - ,m =M & !<-- Minute - ,s =S & !<-- Second - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(M/=0)THEN - H=H+1 - M=0 -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Reset time in ALARM_CLOCKTIME_RING." -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeSet(time=ALARM_CLOCKTIME_RING & !<-- Reset the time for clocktime prints - ,yy =YY & !<-- Year - ,mm =MM & !<-- Month - ,dd =DD & !<-- Day - ,h =H & !<-- Hour - ,m =M & !<-- Minute - ,s =S & !<-- Second - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -#endif -! -!----------------------------------------------------------------------- -!*** Now create the three Alarms using the final ringtimes. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="RESET_ALARMS: Create ALARM_HISTORY" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - domain_int_state%ALARM_HISTORY= & - ESMF_AlarmCreate(name ='ALARM_HISTORY' & - ,clock =CLOCK_INTEGRATE & !<-- DOMAIN Clock - ,ringTime =ALARM_HISTORY_RING & !<-- Forecast/Restart start time (ESMF) - ,ringInterval =INTERVAL_HISTORY & !<-- Time interval between history output - ,ringTimeStepCount=1 & !<-- The Alarm rings for this many timesteps - ,sticky =.false. & !<-- Alarm does not ring until turned off - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="RESET_ALARMS: Create ALARM_RESTART" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - domain_int_state%ALARM_RESTART= & - ESMF_AlarmCreate(name ='ALARM_RESTART' & - ,clock =CLOCK_INTEGRATE & !<-- DOMAIN Clock - ,ringTime =ALARM_RESTART_RING & !<-- Forecast/Restart start time (ESMF) - ,ringInterval =INTERVAL_RESTART & !<-- Time interval between restart output (ESMF) - ,ringTimeStepCount=1 & !<-- The Alarm rings for this many timesteps - ,sticky =.false. & !<-- Alarm does not ring until turned off - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="RESET_ALARMS: Create ALARM_CLOCKTIME" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - domain_int_state%ALARM_CLOCKTIME= & - ESMF_AlarmCreate(name ='ALARM_CLOCKTIME' & - ,clock =CLOCK_INTEGRATE & !<-- DOMAIN Clock - ,ringTime =ALARM_CLOCKTIME_RING & !<-- Forecast start time (ESMF) - ,ringInterval =INTERVAL_CLOCKTIME & !<-- Time interval between clocktime prints (ESMF) - ,ringTimeStepCount=1 & !<-- The Alarm rings for this many timesteps - ,sticky =.false. & !<-- Alarm does not ring until turned off - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INTEG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - END SUBROUTINE RESET_ALARMS -! -!----------------------------------------------------------------------- -! - END SUBROUTINE NMM_INTEGRATE -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - END MODULE MODULE_NMM_INTEGRATE -! -!----------------------------------------------------------------------- diff --git a/src/nmm/module_NMM_INTERNAL_STATE.F90 b/src/nmm/module_NMM_INTERNAL_STATE.F90 deleted file mode 100644 index 757f7ab..0000000 --- a/src/nmm/module_NMM_INTERNAL_STATE.F90 +++ /dev/null @@ -1,79 +0,0 @@ -!----------------------------------------------------------------------- -! - MODULE module_NMM_INTERNAL_STATE -! -!----------------------------------------------------------------------- -!*** The NMM component's ESMF internal state. -!----------------------------------------------------------------------- -! - USE ESMF -! - USE module_KINDS -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: NMM_INTERNAL_STATE & - ,WRAP_NMM_INTERNAL_STATE -! -!----------------------------------------------------------------------- -! - TYPE NMM_INTERNAL_STATE -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: NPHS & !<-- Physics timestep - ,NTRACK & !<-- Storm locator flag - ,NUM_2WAY_CHILDREN !<-- # of 2-way children in each domain -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: COMM_MY_DOMAIN & !<-- MPI intracommunicator for all tasks on each domain - ,NPE_PRINT & !<-- Clocktime diagnostics from this MPI task - ,NUM_CHILDREN & !<-- How many children on each domain - ,P_C_TIME_RATIO !<-- Ratio of a parent's DT to its child's -! - REAL(kind=KFPT),DIMENSION(:),POINTER :: DT !<-- The fundamental timestep (s) of the domains -! - LOGICAL(kind=KLOG),DIMENSION(:),POINTER :: MY_DOMAIN_MOVES & !<-- Does my domain move? - ,RESTARTED_RUN & !<-- Flag indicating if this is a restarted run - ,RST_OUT_00 !<-- Shall we write 00h history in restarted run? -! - CHARACTER(len=5),DIMENSION(:),POINTER :: NEST_MODE !<-- Is the nesting 1-way or 2-way with the parent? -! - LOGICAL(kind=KLOG),DIMENSION(:),POINTER :: I_AM_A_FCST_TASK & !<-- Is this task a fcst task on a given domain? - ,I_AM_A_NEST & !<-- Is this task on a nested domain? - ,I_AM_LEAD_FCST_TASK !<-- Is this the lead fcst task on the domain? -! - TYPE(ESMF_GridComp),DIMENSION(:),POINTER :: DOMAIN_GRID_COMP !<-- Gridded components of all domains -! - TYPE(ESMF_State),DIMENSION(:),POINTER :: IMP_STATE_DOMAIN !<-- The import state of the DOMAIN components - TYPE(ESMF_State),DIMENSION(:),POINTER :: EXP_STATE_DOMAIN !<-- The export state of the DOMAIN components -! - TYPE(ESMF_TimeInterval),DIMENSION(:),POINTER :: FILT_TIMESTEP & !<-- ESMF timestep for digital filter (s) - ,INTERVAL_CLOCKTIME & !<-- ESMF time interval between clocktime prints (h) - ,INTERVAL_HISTORY & !<-- ESMF time interval between history output (h) - ,INTERVAL_RESTART & !<-- ESMF time interval between restart output (h) - ,TIMESTEP !<-- The ESMF timestep (s) -! - TYPE(ESMF_CplComp),DIMENSION(:),POINTER :: PC_CPL_COMP -! - TYPE(ESMF_State),DIMENSION(:),POINTER :: IMP_STATE_PC_CPL !<-- The import state of the P-C Coupler components - TYPE(ESMF_State),DIMENSION(:),POINTER :: EXP_STATE_PC_CPL !<-- The export state of the P-C Coupler components -! - END TYPE NMM_INTERNAL_STATE -! -!----------------------------------------------------------------------- -! - TYPE WRAP_NMM_INTERNAL_STATE -! - TYPE(NMM_INTERNAL_STATE),POINTER :: NMM_INT_STATE -! - END TYPE WRAP_NMM_INTERNAL_STATE -! -!----------------------------------------------------------------------- -! - END MODULE module_NMM_INTERNAL_STATE -! -!----------------------------------------------------------------------- diff --git a/src/nmm/module_OUTPUT.F90 b/src/nmm/module_OUTPUT.F90 deleted file mode 100644 index 3fce23e..0000000 --- a/src/nmm/module_OUTPUT.F90 +++ /dev/null @@ -1,390 +0,0 @@ -!----------------------------------------------------------------------- -! - MODULE MODULE_OUTPUT -! -!----------------------------------------------------------------------- -!*** Insert quantities from the Solver internal state into the -!*** Write import state for output. -!----------------------------------------------------------------------- -! - USE ESMF - USE MODULE_KINDS - USE MODULE_SOLVER_INTERNAL_STATE,ONLY: SOLVER_INTERNAL_STATE - USE MODULE_ERROR_MSG,ONLY: ERR_MSG,MESSAGE_CHECK - USE MODULE_VARS - USE MODULE_VARS_STATE -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: POINT_OUTPUT -! -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - SUBROUTINE POINT_OUTPUT(GRID,INT_STATE,IMP_STATE_WRITE) -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** This routine takes the user's selections for output quantities, -!*** points at them, and inserts those pointers into the import state -!*** of the Write components. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument variables -!------------------------ -! - TYPE(ESMF_Grid) ,INTENT(IN) :: GRID !<-- The ESMF Grid -! - TYPE(SOLVER_INTERNAL_STATE),POINTER,INTENT(INOUT) :: INT_STATE !<-- The Solver internal state -! - TYPE(ESMF_State),INTENT(INOUT) :: IMP_STATE_WRITE !<-- Import state for the Write components -! -!--------------------- -!*** Local variables -!--------------------- -! - INTEGER :: IHALO,JHALO -! - INTEGER :: K,LENGTH,MYPE & - ,N,NDIM3,NFIND,NUM_2D_FIELDS,NV & - ,RC,RC_DYN_OUT -! - INTEGER :: LDIM1,LDIM2 & - ,UDIM1,UDIM2 -! - INTEGER :: ITWO=2 -! - REAL(KIND=KFPT),DIMENSION(:,:),POINTER :: TEMP_R2D -! - CHARACTER(2) :: MODEL_LEVEL - CHARACTER(6) :: FMT='(I2.2)' - CHARACTER(ESMF_MAXSTR) :: VBL_NAME -! - TYPE(ESMF_FieldBundle) :: HISTORY_BUNDLE & - ,RESTART_BUNDLE -! - TYPE(ESMF_Field) :: FIELD -! - TYPE(ESMF_DataCopy_Flag) :: COPYFLAG=ESMF_DATACOPY_REFERENCE -! TYPE(ESMF_DataCopy_Flag) :: COPYFLAG=ESMF_DATA_COPY -! -!----------------------------------------------------------------------- -! - MYPE=int_state%MYPE -! -!----------------------------------------------------------------------- -!*** Create an ESMF Bundle that will hold history output data -!*** and nothing else. This will serve to isolate the output -!*** data from everything else inside the Write component's -!*** import state. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create History Data Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - HISTORY_BUNDLE=ESMF_FieldBundleCreate(name='History Bundle' & !<-- The Bundle's name - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_DYN_OUT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Create an ESMF Bundle that will hold restart data -!*** and nothing else. This will serve to isolate the restart -!*** data from everything else inside the Write component's -!*** import state. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create Restart Data Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - RESTART_BUNDLE=ESMF_FieldBundleCreate(name='Restart Bundle' & !<-- The Bundle's name - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_DYN_OUT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** First add the local subdomain limits to the Write component's -!*** import state as Attributes along with the global/regional mode. -!*** This information is needed for quilting the local domain data -!*** into full domain fields. -!*** The local domain limits go directly into the Write component's -!*** import state to keep them separate from the history data that -!*** will be inserted into a Bundle. -! -!*** Do the same with the number of fcst tasks (INPESxJNPES) since -!*** the Write component also needs that information as well as -!*** the halo depths. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Local Subdomain Limits to the Write Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeSet(state =IMP_STATE_WRITE & !<-- The Write component import state - ,name ='LOCAL_ISTART' & !<-- Name of the integer array - ,itemCount=int_state%NUM_PES & !<-- Length of array being inserted into the import state - ,valueList=int_state%LOCAL_ISTART & !<-- The array being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state =IMP_STATE_WRITE & !<-- The Write component import state - ,name ='LOCAL_IEND' & !<-- Name of the integer array - ,itemCount=int_state%NUM_PES & !<-- Length of array being inserted into the import state - ,valueList=int_state%LOCAL_IEND & !<-- The array being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state =IMP_STATE_WRITE & !<-- The Write component import state - ,name ='LOCAL_JSTART' & !<-- Name of the integer array - ,itemCount=int_state%NUM_PES & !<-- Length of array being inserted into the import state - ,valueList=int_state%LOCAL_JSTART & !<-- The array being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state =IMP_STATE_WRITE & !<-- The Write component import state - ,name ='LOCAL_JEND' & !<-- Name of the integer array - ,itemCount=int_state%NUM_PES & !<-- Length of array being inserted into the import state - ,valueList=int_state%LOCAL_JEND & !<-- The array being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_WRITE & !<-- The Write component import state - ,name ='INPES' & !<-- Name of the integer scalar - ,value=int_state%INPES & !<-- The value being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_WRITE & !<-- The Write component import state - ,name ='JNPES' & !<-- Name of the integer scalar - ,value=int_state%JNPES & !<-- The value being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_WRITE & !<-- The Write component import state - ,name ='IHALO' & !<-- Name of the integer scalar - ,value=int_state%IHALO & !<-- The value being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_WRITE & !<-- The Write component import state - ,name ='JHALO' & !<-- Name of the integer scalar - ,value=int_state%JHALO & !<-- The value being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_WRITE & !<-- The Write component import state - ,name ='WRITE_TASKS_PER_GROUP' & !<-- Name of the integer scalar - ,value=int_state%WRITE_TASKS_PER_GROUP & !<-- The value being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_WRITE & !<-- The Write component import state - ,name ='WRITE_GROUPS' & !<-- Name of the integer scalar - ,value=int_state%WRITE_GROUPS & !<-- The value being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_WRITE & !<-- The Write component import state - ,name ='LNSH' & !<-- Name of the integer scalar - ,value=int_state%LNSH & !<-- The value being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_WRITE & !<-- The Write component import state - ,name ='LNSV' & !<-- Name of the integer scalar - ,value=int_state%LNSV & !<-- The value being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_WRITE & !<-- The Write component import state - ,name ='NVARS_BC_2D_H' & !<-- Name of the integer scalar - ,value=int_state%NVARS_BC_2D_H & !<-- The value being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_WRITE & !<-- The Write component import state - ,name ='NVARS_BC_3D_H' & !<-- Name of the integer scalar - ,value=int_state%NVARS_BC_3D_H & !<-- The value being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_WRITE & !<-- The Write component import state - ,name ='NVARS_BC_4D_H' & !<-- Name of the integer scalar - ,value=int_state%NVARS_BC_4D_H & !<-- The value being inserted into the import state - ,rc =RC) -! - IF(int_state%NVARS_BC_4D_H>0)THEN - CALL ESMF_AttributeSet(state =IMP_STATE_WRITE & !<-- The Write component import state - ,name ='LBND_4D' & !<-- Name of the integer scalar - ,itemCount=int_state%NVARS_BC_4D_H & !<-- Length of array being inserted into the import state - ,valuelist=int_state%LBND_4D & !<-- The array being inserted into the import state - ,rc =RC) - CALL ESMF_AttributeSet(state =IMP_STATE_WRITE & !<-- The Write component import state - ,name ='UBND_4D' & !<-- Name of the integer scalar - ,itemCount=int_state%NVARS_BC_4D_H & !<-- Length of array being inserted into the import state - ,valuelist=int_state%UBND_4D & !<-- The array being inserted into the import state - ,rc =RC) - ENDIF -! - CALL ESMF_AttributeSet(state=IMP_STATE_WRITE & !<-- The Write component import state - ,name ='NVARS_BC_2D_V' & !<-- Name of the integer scalar - ,value=int_state%NVARS_BC_2D_V & !<-- The value being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_WRITE & !<-- The Write component import state - ,name ='NVARS_BC_3D_V' & !<-- Name of the integer scalar - ,value=int_state%NVARS_BC_3D_V & !<-- The value being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_WRITE & !<-- The Write component import state - ,name ='NLEV_H' & !<-- Name of the integer scalar - ,value=int_state%NLEV_H & !<-- The value being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_WRITE & !<-- The Write component import state - ,name ='NLEV_V' & !<-- Name of the integer scalar - ,value=int_state%NLEV_V & !<-- The value being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state =IMP_STATE_WRITE & !<-- The Write component import state - ,name ='LOCAL_JEND' & !<-- Name of the integer array - ,itemCount=int_state%NUM_PES & !<-- Length of array being inserted into the import state - ,valueList=int_state%LOCAL_JEND & !<-- The array being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_WRITE & !<-- The Write component import state - ,name ='IDS' & !<-- Name of the integer scalar - ,value=int_state%IDS & !<-- The value being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_WRITE & !<-- The Write component import state - ,name ='IDE' & !<-- Name of the integer scalar - ,value=int_state%IDE & !<-- The value being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_WRITE & !<-- The Write component import state - ,name ='JDS' & !<-- Name of the integer scalar - ,value=int_state%JDS & !<-- The value being inserted into the import state - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_WRITE & !<-- The Write component import state - ,name ='JDE' & !<-- Name of the integer scalar - ,value=int_state%JDE & !<-- The value being inserted into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_DYN_OUT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** The following logical variables are to be part of the -!*** history output therefore place them into the history Bundle. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert Global and Run Logicals into History Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeSet(FIELDBUNDLE=HISTORY_BUNDLE & !<-- The Write component output history Bundle - ,name ='GLOBAL' & !<-- Name of the logical - ,value =int_state%GLOBAL & !<-- The logical being inserted into the Bundle - ,rc =RC) -! - CALL ESMF_AttributeSet(FIELDBUNDLE=HISTORY_BUNDLE & !<-- The Write component output history Bundle - ,name ='RUN' & !<-- Name of the logical - ,value =int_state%RUN & !<-- The logical being inserted into the Bundle - ,rc =RC) -! - CALL ESMF_AttributeSet(FIELDBUNDLE=HISTORY_BUNDLE & !<-- The Write component output history Bundle - ,name ='ADIABATIC' & !<-- Name of the logical - ,value =int_state%ADIABATIC & !<-- The logical being inserted into the Bundle - ,rc =RC) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_DYN_OUT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** The following logical variables are to be part of the -!*** restart output therefore place them into the restart Bundle. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert Global and Run Logicals into Restart Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeSet(FIELDBUNDLE=RESTART_BUNDLE & !<-- The Write component restart Bundle - ,name ='GLOBAL' & !<-- Name of the logical - ,value =int_state%GLOBAL & !<-- The logical being inserted into the Bundle - ,rc =RC) -! - CALL ESMF_AttributeSet(FIELDBUNDLE=RESTART_BUNDLE & !<-- The Write component restart Bundle - ,name ='RUN' & !<-- Name of the logical - ,value =int_state%RUN & !<-- The logical being inserted into the Bundle - ,rc =RC) -! - CALL ESMF_AttributeSet(FIELDBUNDLE=RESTART_BUNDLE & !<-- The Write component restart Bundle - ,name ='ADIABATIC' & !<-- Name of the logical - ,value =int_state%ADIABATIC & !<-- The logical being inserted into the Bundle - ,rc =RC) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_DYN_OUT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Now insert into the Write components' import state the pointers -!*** of only those quantities that are specified by the user for -!*** history and restart output. The data is placed into an ESMF -!*** Bundle which itself will be placed into the import state at -!*** the end of the routine. -!----------------------------------------------------------------------- -! - CALL PUT_VARS_IN_BUNDLES(int_state%VARS & - ,int_state%NUM_VARS & - ,GRID & - ,HISTORY_BUNDLE & - ,RESTART_BUNDLE) -! -!----------------------------------------------------------------------- -!*** Load the two output Bundles into the Solver's internal state -!*** array needed to add them to the Write component's import state. -!----------------------------------------------------------------------- -! - int_state%BUNDLE_ARRAY(1)=HISTORY_BUNDLE - int_state%BUNDLE_ARRAY(2)=RESTART_BUNDLE -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Solver: Insert Bundle Array into the Write Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateAddReplace(state =IMP_STATE_WRITE & !<-- The Write component's import state - ,fieldbundlelist=(/int_state%BUNDLE_ARRAY/) & !<-- Array holding the History/Restart Bundles - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_DYN_OUT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - END SUBROUTINE POINT_OUTPUT -! -!----------------------------------------------------------------------- -! - END MODULE MODULE_OUTPUT -! -!----------------------------------------------------------------------- diff --git a/src/nmm/module_PARENT_CHILD_CPL_COMP.F90 b/src/nmm/module_PARENT_CHILD_CPL_COMP.F90 deleted file mode 100644 index b3e9347..0000000 --- a/src/nmm/module_PARENT_CHILD_CPL_COMP.F90 +++ /dev/null @@ -1,24848 +0,0 @@ -!----------------------------------------------------------------------- -! - MODULE MODULE_PARENT_CHILD_CPL_COMP -! -!----------------------------------------------------------------------- -! -!*** This module contains the coupler that exchanges data between -!*** NMM-B parent domains and their children. -! -!----------------------------------------------------------------------- -! -! PROGRAM HISTORY LOG: -! -! 2008-06-12 Black - Module created. -! 2009-02-19 Black - Hydrostatic update of nest boundaries. -! 2010-01-20 Black - Enable parent tasks to update associations -! with nest boundary tasks throughout the -! integration. -! 2011-02 Yang - Updated to use both the ESMF 4.0.0rp2 library, -! ESMF 5 series library and the the -! ESMF 3.1.0rp2 library. -! 2011-05-12 Yang - Modified for using the ESMF 5.2.0r_beta_snapshot_07. -! 2011-07-16 Black - Add moving nest capability. -! 2011-09-27 Yang - Modified for using the ESMF 5.2.0r library. -! 2012-07-20 Black - Add generational use of MPI tasks. -! -!----------------------------------------------------------------------- -! -! USAGE: -! -!----------------------------------------------------------------------- -! - USE MPI - USE ESMF -! - USE module_KINDS -! - USE module_DERIVED_TYPES,ONLY: BC_H & - ,BC_V & - ,BNDS_2D & - ,CHILD_UPDATE_LINK & - ,CTASK_LIMITS & - ,HANDLE_CHILD_LIMITS & - ,HANDLE_CHILD_TOPO_S & - ,HANDLE_CHILD_TOPO_N & - ,HANDLE_CHILD_TOPO_W & - ,HANDLE_CHILD_TOPO_E & - ,HANDLE_I_SW & - ,HANDLE_J_SW & - ,HANDLE_PACKET_S_H & - ,HANDLE_PACKET_S_V & - ,HANDLE_PACKET_N_H & - ,HANDLE_PACKET_N_V & - ,HANDLE_PACKET_W_H & - ,HANDLE_PACKET_W_V & - ,HANDLE_PACKET_E_H & - ,HANDLE_PACKET_E_V & - ,HANDLE_PARENT_DOM_LIMITS & - ,HANDLE_PARENT_ITE & - ,HANDLE_PARENT_ITS & - ,HANDLE_PARENT_JTE & - ,HANDLE_PARENT_JTS & - ,INFO_SEND & - ,INTEGER_DATA & - ,INTEGER_DATA_2D & - ,INTERIOR_DATA_FROM_PARENT & - ,MIXED_DATA & - ,MIXED_DATA_TASKS & - ,MULTIDATA & - ,REAL_DATA & - ,REAL_DATA_TASKS & - ,PTASK_LIMITS & - ,REAL_DATA_2D & - ,REAL_VBLS_3D -! - USE module_CONTROL,ONLY: NUM_DOMAINS_MAX,TIMEF -! - USE module_EXCHANGE,ONLY: HALO_EXCH -! - USE module_VARS,ONLY: VAR -! - USE module_NESTING,ONLY: CHECK_REAL & - ,CHILD_2WAY_BOOKKEEPING & - ,CHILD_RANKS & - ,GENERATE_2WAY_DATA & - ,HYPERBOLA & - ,LAG_STEPS & - ,MOVING_NEST_BOOKKEEPING & - ,MOVING_NEST_RECV_DATA & - ,PARENT_2WAY_BOOKKEEPING & - ,PARENT_BOOKKEEPING_MOVING & - ,PARENT_READS_MOVING_CHILD_TOPO & - ,PARENT_UPDATES_HALOS & - ,PARENT_UPDATES_MOVING & - ,STENCIL_H_EVEN & - ,STENCIL_V_EVEN & - ,STENCIL_SFC_H_EVEN & - ,STENCIL_SFC_V_EVEN & - ,STENCIL_H_ODD & - ,STENCIL_V_ODD & - ,STENCIL_SFC_H_ODD & - ,STENCIL_SFC_V_ODD -! - USE module_CONSTANTS,ONLY: A,G,P608,R_D -! - USE MODULE_MY_DOMAIN_SPECS, IDS_share=>IDS,IDE_share=>IDE & - ,IMS_share=>IMS,IME_share=>IME & - ,ITS_share=>ITS,ITE_share=>ITE & - ,JDS_share=>JDS,JDE_share=>JDE & - ,JMS_share=>JMS,JME_share=>JME & - ,JTS_share=>JTS,JTE_share=>JTE & -! - ,MPI_COMM_COMP_share=>MPI_COMM_COMP & - ,MYPE_share=>MYPE & - ,MY_NEB_share=>MY_NEB & -! - ,LOCAL_ISTART_share=>LOCAL_ISTART & - ,LOCAL_IEND_share =>LOCAL_IEND & - ,LOCAL_JSTART_share=>LOCAL_JSTART & - ,LOCAL_JEND_share =>LOCAL_JEND -! - USE module_CLOCKTIMES,ONLY: cbcst_tim,pbcst_tim -! - USE module_DIAGNOSE,ONLY: HMAXMIN,VMAXMIN -! - USE module_ERROR_MSG,ONLY: ERR_MSG,MESSAGE_CHECK -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: PARENT_CHILD_CPL_REGISTER & - ,PARENT_CHILD_COUPLER_SETUP & - ,NSTEP_CHILD_RECV -! -!----------------------------------------------------------------------- -! - TYPE BOUNDARY_SIDES !<-- Hold the boundary blending region along each side of a domain - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: SOUTH - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: NORTH - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: WEST - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: EAST - END TYPE BOUNDARY_SIDES -! - TYPE INTEGER_DATA_TASKS - INTEGER(kind=KINT),DIMENSION(:),POINTER :: TASKS - END TYPE INTEGER_DATA_TASKS -! - TYPE SIDES_0D - INTEGER(kind=KINT) :: SOUTH - INTEGER(kind=KINT) :: NORTH - INTEGER(kind=KINT) :: WEST - INTEGER(kind=KINT) :: EAST - END TYPE SIDES_0D -! - TYPE SIDES_2D - INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: SOUTH - INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: NORTH - INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: WEST - INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: EAST - END TYPE SIDES_2D -! - TYPE SAVE_TASK_IJ - INTEGER(kind=KINT),DIMENSION(:),POINTER :: I_LO_SOUTH - INTEGER(kind=KINT),DIMENSION(:),POINTER :: I_HI_SOUTH - INTEGER(kind=KINT),DIMENSION(:),POINTER :: I_HI_SOUTH_TRANSFER - INTEGER(kind=KINT),DIMENSION(:),POINTER :: I_LO_NORTH - INTEGER(kind=KINT),DIMENSION(:),POINTER :: I_HI_NORTH - INTEGER(kind=KINT),DIMENSION(:),POINTER :: I_HI_NORTH_TRANSFER - INTEGER(kind=KINT),DIMENSION(:),POINTER :: J_LO_WEST - INTEGER(kind=KINT),DIMENSION(:),POINTER :: J_HI_WEST - INTEGER(kind=KINT),DIMENSION(:),POINTER :: J_HI_WEST_TRANSFER - INTEGER(kind=KINT),DIMENSION(:),POINTER :: J_LO_EAST - INTEGER(kind=KINT),DIMENSION(:),POINTER :: J_HI_EAST - INTEGER(kind=KINT),DIMENSION(:),POINTER :: J_HI_EAST_TRANSFER - END TYPE SAVE_TASK_IJ -! - TYPE HANDLE_SEND - INTEGER(kind=KINT),DIMENSION(:),POINTER :: NTASKS_TO_RECV !<-- Parent MPI handles used when ISend'ing to each child task - END TYPE HANDLE_SEND -! - TYPE DATA_INFO - REAL(kind=KFPT),DIMENSION(:),ALLOCATABLE :: STRING - INTEGER(kind=KINT) :: LENGTH - INTEGER(kind=KINT) :: ID_SOURCE - INTEGER(kind=KINT) :: INDX_START - INTEGER(kind=KINT) :: INDX_END - INTEGER(kind=KINT) :: INDX_END_EXP - END TYPE DATA_INFO -! - TYPE PARENT_DATA - TYPE(DATA_INFO) :: SOUTH_H - TYPE(DATA_INFO) :: SOUTH_V - TYPE(DATA_INFO) :: NORTH_H - TYPE(DATA_INFO) :: NORTH_V - TYPE(DATA_INFO) :: WEST_H - TYPE(DATA_INFO) :: WEST_V - TYPE(DATA_INFO) :: EAST_H - TYPE(DATA_INFO) :: EAST_V - END TYPE PARENT_DATA -! - TYPE PARENT_POINTS_SURROUND_H !<-- Indices of parent points around each child bndry H point - INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: I_INDX_NBND - INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: I_INDX_SBND - INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: I_INDX_EBND - INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: I_INDX_WBND - INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: J_INDX_NBND - INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: J_INDX_SBND - INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: J_INDX_EBND - INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: J_INDX_WBND - END TYPE PARENT_POINTS_SURROUND_H -! - TYPE PARENT_POINTS_SURROUND_V !<-- Indices of parent points around each child bndry V point - INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: I_INDX_NBND - INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: I_INDX_SBND - INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: I_INDX_EBND - INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: I_INDX_WBND - INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: J_INDX_NBND - INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: J_INDX_SBND - INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: J_INDX_EBND - INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: J_INDX_WBND - END TYPE PARENT_POINTS_SURROUND_V -! - TYPE PARENT_WEIGHTS_SURROUND_H !<-- Bilinear interpolation weights of the 4 parent points - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: WEIGHTS_NBND ! around each child boundary H point - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: WEIGHTS_SBND - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: WEIGHTS_EBND - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: WEIGHTS_WBND - END TYPE PARENT_WEIGHTS_SURROUND_H -! - TYPE PARENT_WEIGHTS_SURROUND_V !<-- Bilinear interpolation weights of the 4 parent points - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: WEIGHTS_NBND ! around each child boundary H point - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: WEIGHTS_SBND - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: WEIGHTS_EBND - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: WEIGHTS_WBND - END TYPE PARENT_WEIGHTS_SURROUND_V -! -!----------------------------------------------------------------------- -!*** In 1-way nesting the MPI tasks lie on only one domain but -!*** in 2-way nesting the tasks can lie on more than one domain. -!*** The composite object holds quantities in the Parent-Child -!*** coupler that vary depending on which domain they are on. -!*** The composite object differentiates between the quantities -!*** inside it. The tasks point into the proper element of the -!*** object with unallocated pointers to access the quantities -!*** for the desired domain. -!----------------------------------------------------------------------- -! -!----------------------------------- -!*** The composite type definition -!----------------------------------- -! - TYPE COMPOSITE -! - INTEGER(kind=KINT) :: NCYCLE_CHILD & - ,NCYCLE_PARENT -! - INTEGER(kind=KINT) :: COMM_TO_MY_PARENT - INTEGER(kind=KINT) :: HANDLE_MOVE_FLAG - INTEGER(kind=KINT) :: HANDLE_SEND_2WAY_SIGNAL - INTEGER(kind=KINT) :: I_CENTER_CURRENT - INTEGER(kind=KINT) :: I_SHIFT_CHILD - INTEGER(kind=KINT) :: J_SHIFT_CHILD - INTEGER(kind=KINT) :: I_SW_PARENT_CURRENT - INTEGER(kind=KINT) :: I_SW_PARENT_NEW - INTEGER(kind=KINT) :: J_CENTER_CURRENT - INTEGER(kind=KINT) :: J_SW_PARENT_CURRENT - INTEGER(kind=KINT) :: J_SW_PARENT_NEW - INTEGER(kind=KINT) :: ITS,ITE,JTS,JTE,LM - INTEGER(kind=KINT) :: IMS,IME,JMS,JME - INTEGER(kind=KINT) :: IDS,IDE,JDS,JDE - INTEGER(kind=KINT) :: IM_1,JM_1,JM - INTEGER(kind=KINT) :: INPES,JNPES - INTEGER(kind=KINT) :: INPES_PARENT,JNPES_PARENT - INTEGER(kind=KINT) :: KOUNT_2WAY_CHILDREN - INTEGER(kind=KINT) :: LAST_STEP_MOVED - INTEGER(kind=KINT) :: MAX_SHIFT - INTEGER(kind=KINT) :: MYPE - INTEGER(kind=KINT) :: N_BLEND_H,N_BLEND_V - INTEGER(kind=KINT) :: N_STENCIL_H,N_STENCIL_SFC_H - INTEGER(kind=KINT) :: N_STENCIL_V,N_STENCIL_SFC_V - INTEGER(kind=KINT) :: NEXT_MOVE_TIMESTEP - INTEGER(kind=KINT) :: NHALO - INTEGER(kind=KINT) :: NLEV_H - INTEGER(kind=KINT) :: NLEV_V - INTEGER(kind=KINT) :: NPHS - INTEGER(kind=KINT) :: NTASKS_UPDATE_PARENT - INTEGER(kind=KINT) :: NTIMESTEP_CHECK - INTEGER(kind=KINT) :: NTIMESTEP_FINAL - INTEGER(kind=KINT) :: NTIMESTEP_WAIT_PARENT - INTEGER(kind=KINT) :: NTIMESTEP_WAIT_FORCED_PARENT - INTEGER(kind=KINT) :: NTIMESTEPS_RESTART - INTEGER(kind=KINT) :: NTOT_SFC - INTEGER(kind=KINT) :: NTRACK - INTEGER(kind=KINT) :: NUM_CHILDREN - INTEGER(kind=KINT) :: NUM_2WAY_CHILDREN - INTEGER(kind=KINT) :: NUM_MOVING_CHILDREN - INTEGER(kind=KINT) :: NUM_PES_FCST - INTEGER(kind=KINT) :: NUM_FCST_TASKS_PARENT - INTEGER(kind=KINT) :: NUM_TASKS_PARENT - INTEGER(kind=KINT) :: NUM_LEVELS_MOVE_3D_H - INTEGER(kind=KINT) :: NUM_LEVELS_MOVE_3D_V - INTEGER(kind=KINT) :: NUM_SPACE_RATIOS_MVG - INTEGER(kind=KINT) :: NVARS_BC_2D_H - INTEGER(kind=KINT) :: NVARS_BC_3D_H - INTEGER(kind=KINT) :: NVARS_BC_4D_H - INTEGER(kind=KINT) :: NVARS_BC_2D_V - INTEGER(kind=KINT) :: NVARS_BC_3D_V - INTEGER(kind=KINT) :: SPACE_RATIO_MY_PARENT - INTEGER(kind=KINT) :: TIME_RATIO_MY_PARENT -! - INTEGER(kind=KINT),DIMENSION(1:2) :: MY_FORCED_SHIFT - INTEGER(kind=KINT),DIMENSION(1:2) :: STORM_CENTER - INTEGER(kind=KINT),DIMENSION(1:3) :: PARENT_SHIFT - INTEGER(kind=KINT),DIMENSION(1:4) :: MY_DOMAIN_LIMITS - INTEGER(kind=KINT),DIMENSION(1:4) :: PARENT_DOMAIN_LIMITS - INTEGER(kind=KINT),DIMENSION(1:8) :: MY_NEB -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: PARENT_CHILD_SPACE_RATIO - INTEGER(kind=KINT),DIMENSION(:),POINTER :: TIME_RATIO_MY_CHILDREN - INTEGER(kind=KINT),DIMENSION(:),POINTER :: IM_CHILD - INTEGER(kind=KINT),DIMENSION(:),POINTER :: JM_CHILD - INTEGER(kind=KINT),DIMENSION(:),POINTER :: I_PARENT_SW - INTEGER(kind=KINT),DIMENSION(:),POINTER :: J_PARENT_SW - INTEGER(kind=KINT),DIMENSION(:),POINTER :: ITE_PARENT - INTEGER(kind=KINT),DIMENSION(:),POINTER :: ITS_PARENT - INTEGER(kind=KINT),DIMENSION(:),POINTER :: JTE_PARENT - INTEGER(kind=KINT),DIMENSION(:),POINTER :: JTS_PARENT - INTEGER(kind=KINT),DIMENSION(:),POINTER :: LINK_MRANK_RATIO - INTEGER(kind=KINT),DIMENSION(:),POINTER :: LIST_OF_RATIOS - INTEGER(kind=KINT),DIMENSION(:),POINTER :: M_NEST_RATIO - INTEGER(kind=KINT),DIMENSION(:),POINTER :: N_BLEND_H_CHILD - INTEGER(kind=KINT),DIMENSION(:),POINTER :: N_BLEND_V_CHILD - INTEGER(kind=KINT),DIMENSION(:),POINTER :: N_STENCIL_H_CHILD - INTEGER(kind=KINT),DIMENSION(:),POINTER :: N_STENCIL_SFC_H_CHILD - INTEGER(kind=KINT),DIMENSION(:),POINTER :: N_STENCIL_V_CHILD - INTEGER(kind=KINT),DIMENSION(:),POINTER :: N_STENCIL_SFC_V_CHILD - INTEGER(kind=KINT),DIMENSION(:),POINTER :: NTASKS_UPDATE_CHILD - INTEGER(kind=KINT),DIMENSION(:),POINTER :: NSTEP_CHILD_RECV - INTEGER(kind=KINT),DIMENSION(:),POINTER :: INC_FIX - INTEGER(kind=KINT),DIMENSION(:),POINTER :: COMM_TO_MY_CHILDREN - INTEGER(kind=KINT),DIMENSION(:),POINTER :: ID_PARENTS - INTEGER(kind=KINT),DIMENSION(:),POINTER :: ID_PARENT_UPDATE_TASKS - INTEGER(kind=KINT),DIMENSION(:),POINTER :: MY_CHILDREN_ID - INTEGER(kind=KINT),DIMENSION(:),POINTER :: RANK_2WAY_CHILD - INTEGER(kind=KINT),DIMENSION(:),POINTER :: RANK_MOVING_CHILD - INTEGER(kind=KINT),DIMENSION(:),POINTER :: FTASKS_DOMAIN - INTEGER(kind=KINT),DIMENSION(:),POINTER :: NTASKS_DOMAIN - INTEGER(kind=KINT),DIMENSION(:),POINTER :: NPTS_UPDATE_ON_PARENT_TASKS - INTEGER(kind=KINT),DIMENSION(:),POINTER :: HANDLE_BC_UPDATE - INTEGER(kind=KINT),DIMENSION(:),POINTER :: HANDLE_PARENT_SHIFT - INTEGER(kind=KINT),DIMENSION(:),POINTER :: HANDLE_TIMESTEP - INTEGER(kind=KINT),DIMENSION(:),POINTER :: HANDLE_SEND_2WAY_DATA - INTEGER(kind=KINT),DIMENSION(:),POINTER :: HANDLE_SEND_2WAY_SFC - INTEGER(kind=KINT),DIMENSION(:),POINTER :: HANDLE_SEND_ALLCLEAR - INTEGER(kind=KINT),DIMENSION(:),POINTER :: LBND_4D - INTEGER(kind=KINT),DIMENSION(:),POINTER :: UBND_4D - INTEGER(kind=KINT),DIMENSION(:),POINTER :: LOCAL_ISTART - INTEGER(kind=KINT),DIMENSION(:),POINTER :: LOCAL_IEND - INTEGER(kind=KINT),DIMENSION(:),POINTER :: LOCAL_JSTART - INTEGER(kind=KINT),DIMENSION(:),POINTER :: LOCAL_JEND - INTEGER(kind=KINT),DIMENSION(:),POINTER :: NTIMESTEP_CHILD_MOVES - INTEGER(kind=KINT),DIMENSION(:),POINTER :: NUM_TASKS_SEND_H_S - INTEGER(kind=KINT),DIMENSION(:),POINTER :: NUM_TASKS_SEND_H_N - INTEGER(kind=KINT),DIMENSION(:),POINTER :: NUM_TASKS_SEND_H_W - INTEGER(kind=KINT),DIMENSION(:),POINTER :: NUM_TASKS_SEND_H_E - INTEGER(kind=KINT),DIMENSION(:),POINTER :: NUM_TASKS_SEND_V_S - INTEGER(kind=KINT),DIMENSION(:),POINTER :: NUM_TASKS_SEND_V_N - INTEGER(kind=KINT),DIMENSION(:),POINTER :: NUM_TASKS_SEND_V_W - INTEGER(kind=KINT),DIMENSION(:),POINTER :: NUM_TASKS_SEND_V_E - INTEGER(kind=KINT),DIMENSION(:),POINTER :: SHIFT_INFO_MINE -! - INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: SHIFT_INFO_CHILDREN -! - REAL(kind=KFPT) :: CENTERS_DISTANCE - REAL(kind=KFPT) :: DLM - REAL(kind=KFPT) :: DPH - REAL(kind=KFPT) :: DYH - REAL(kind=KFPT) :: PDTOP - REAL(kind=KFPT) :: PT - REAL(kind=KFPT) :: SB_1 - REAL(kind=KFPT) :: WB_1 - REAL(kind=KFPT) :: TPH0_1 - REAL(kind=KFPT) :: TLM0_1 - REAL(kind=KFPT) :: RECIP_DPH_1 - REAL(kind=KFPT) :: RECIP_DLM_1 - REAL(kind=KFPT) :: RECIP_PARENT_SPACE_RATIO -! - REAL(kind=KFPT),DIMENSION(:),POINTER :: DT_DOMAIN - REAL(kind=KFPT),DIMENSION(:),POINTER :: DXH - REAL(kind=KFPT),DIMENSION(:),POINTER :: DSG2 - REAL(kind=KFPT),DIMENSION(:),POINTER :: PDSG1 - REAL(kind=KFPT),DIMENSION(:),POINTER :: PSGML1 - REAL(kind=KFPT),DIMENSION(:),POINTER :: SG1 - REAL(kind=KFPT),DIMENSION(:),POINTER :: SG2 - REAL(kind=KFPT),DIMENSION(:),POINTER :: SGML2 -! - REAL(kind=KFPT),DIMENSION(:),POINTER :: CHILD_2WAY_WGT - REAL(kind=KFPT),DIMENSION(:),POINTER :: CHILD_PARENT_SPACE_RATIO -! - REAL(kind=KFPT),DIMENSION(:),POINTER :: BOUND_1D_SOUTH_H - REAL(kind=KFPT),DIMENSION(:),POINTER :: BOUND_1D_SOUTH_V - REAL(kind=KFPT),DIMENSION(:),POINTER :: BOUND_1D_NORTH_H - REAL(kind=KFPT),DIMENSION(:),POINTER :: BOUND_1D_NORTH_V - REAL(kind=KFPT),DIMENSION(:),POINTER :: BOUND_1D_WEST_H - REAL(kind=KFPT),DIMENSION(:),POINTER :: BOUND_1D_WEST_V - REAL(kind=KFPT),DIMENSION(:),POINTER :: BOUND_1D_EAST_H - REAL(kind=KFPT),DIMENSION(:),POINTER :: BOUND_1D_EAST_V -! - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: FIS - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: FIS_CHILD_ON_PARENT - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: GLAT - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: GLON - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: PD - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: SM - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: U10 - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: V10 -! - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: PDB_S - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: PDB_N - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: PDB_W - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: PDB_E -! - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: CW - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: PINT - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: Q - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: T - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: U - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: V - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: Z -! - REAL(kind=KFPT),DIMENSION(:,:,:,:),POINTER :: TRACERS -! - CHARACTER(len=6),DIMENSION(:),POINTER :: STATIC_OR_MOVING -! - LOGICAL(kind=KLOG) :: CALLED_CHILD_2WAY_BOOKKEEPING - LOGICAL(kind=KLOG) :: CHILD_FORCES_MY_SHIFT - LOGICAL(kind=KLOG) :: FIRST_CALL_RECV_2WAY - LOGICAL(kind=KLOG) :: FIRST_CALL_RECV_BC - LOGICAL(kind=KLOG) :: FORCED_PARENT_SHIFT - LOGICAL(kind=KLOG) :: I_AM_ACTIVE - LOGICAL(kind=KLOG) :: I_AM_LEAD_FCST_TASK - LOGICAL(kind=KLOG) :: I_WANT_TO_MOVE - LOGICAL(kind=KLOG) :: MOVE_FLAG_SENT - LOGICAL(kind=KLOG) :: MY_PARENT_MOVES - LOGICAL(kind=KLOG) :: PARENT_WANTS_TO_MOVE - LOGICAL(kind=KLOG) :: STOP_MY_MOTION -! - LOGICAL(kind=KLOG),DIMENSION(:),POINTER :: CHILD_ACTIVE - LOGICAL(kind=KLOG),DIMENSION(:),POINTER :: MOVE_FLAG - LOGICAL(kind=KLOG),DIMENSION(:),POINTER :: SEND_CHILD_DATA - LOGICAL(kind=KLOG),DIMENSION(:),ALLOCATABLE :: CALLED_PARENT_2WAY_BOOKKEEPING - LOGICAL(kind=KLOG),DIMENSION(:),ALLOCATABLE :: SIGNAL_2WAY_SEND_READY - LOGICAL(kind=KLOG),DIMENSION(:),ALLOCATABLE :: SKIP_2WAY_UPDATE -! - TYPE(INTEGER_DATA),DIMENSION(:),POINTER :: I_2WAY_UPDATE - TYPE(INTEGER_DATA),DIMENSION(:),POINTER :: J_2WAY_UPDATE - TYPE(INTEGER_DATA),DIMENSION(:),POINTER :: I_2WAY_H - TYPE(INTEGER_DATA),DIMENSION(:),POINTER :: J_2WAY_H - TYPE(INTEGER_DATA),DIMENSION(:),POINTER :: I_2WAY_V - TYPE(INTEGER_DATA),DIMENSION(:),POINTER :: J_2WAY_V -! - TYPE(INTEGER_DATA_TASKS),DIMENSION(:),POINTER :: WORDS_BOUND_H_SOUTH - TYPE(INTEGER_DATA_TASKS),DIMENSION(:),POINTER :: WORDS_BOUND_H_NORTH - TYPE(INTEGER_DATA_TASKS),DIMENSION(:),POINTER :: WORDS_BOUND_H_WEST - TYPE(INTEGER_DATA_TASKS),DIMENSION(:),POINTER :: WORDS_BOUND_H_EAST - TYPE(INTEGER_DATA_TASKS),DIMENSION(:),POINTER :: WORDS_BOUND_V_SOUTH - TYPE(INTEGER_DATA_TASKS),DIMENSION(:),POINTER :: WORDS_BOUND_V_NORTH - TYPE(INTEGER_DATA_TASKS),DIMENSION(:),POINTER :: WORDS_BOUND_V_WEST - TYPE(INTEGER_DATA_TASKS),DIMENSION(:),POINTER :: WORDS_BOUND_V_EAST -! - TYPE(REAL_DATA),DIMENSION(:),POINTER :: UPDATE_PARENT_2WAY -! - TYPE(REAL_DATA_2D),DIMENSION(:),POINTER :: CHILD_SFC_ON_PARENT - TYPE(REAL_DATA_2D),DIMENSION(:),POINTER :: NEST_FIS_ON_PARENT - TYPE(REAL_DATA_2D),DIMENSION(:),POINTER :: NEST_FIS_V_ON_PARENT -! - TYPE(REAL_DATA_TASKS),DIMENSION(:),POINTER :: PD_B_SOUTH - TYPE(REAL_DATA_TASKS),DIMENSION(:),POINTER :: PD_B_NORTH - TYPE(REAL_DATA_TASKS),DIMENSION(:),POINTER :: PD_B_WEST - TYPE(REAL_DATA_TASKS),DIMENSION(:),POINTER :: PD_B_EAST -! - TYPE(REAL_DATA_TASKS),DIMENSION(:),POINTER :: PD_B_SOUTH_V - TYPE(REAL_DATA_TASKS),DIMENSION(:),POINTER :: PD_B_NORTH_V - TYPE(REAL_DATA_TASKS),DIMENSION(:),POINTER :: PD_B_WEST_V - TYPE(REAL_DATA_TASKS),DIMENSION(:),POINTER :: PD_B_EAST_V -! - TYPE(MULTIDATA),DIMENSION(:),POINTER :: BND_VAR_H_SOUTH - TYPE(MULTIDATA),DIMENSION(:),POINTER :: BND_VAR_H_NORTH - TYPE(MULTIDATA),DIMENSION(:),POINTER :: BND_VAR_H_WEST - TYPE(MULTIDATA),DIMENSION(:),POINTER :: BND_VAR_H_EAST -! - TYPE(MULTIDATA),DIMENSION(:),POINTER :: BND_VAR_V_SOUTH - TYPE(MULTIDATA),DIMENSION(:),POINTER :: BND_VAR_V_NORTH - TYPE(MULTIDATA),DIMENSION(:),POINTER :: BND_VAR_V_WEST - TYPE(MULTIDATA),DIMENSION(:),POINTER :: BND_VAR_V_EAST -! - TYPE(REAL_DATA_TASKS),DIMENSION(:),POINTER :: FIS_CHILD_SOUTH - TYPE(REAL_DATA_TASKS),DIMENSION(:),POINTER :: FIS_CHILD_NORTH - TYPE(REAL_DATA_TASKS),DIMENSION(:),POINTER :: FIS_CHILD_WEST - TYPE(REAL_DATA_TASKS),DIMENSION(:),POINTER :: FIS_CHILD_EAST -! - TYPE(REAL_DATA_TASKS),DIMENSION(:,:),POINTER :: CHILD_BOUND_H_SOUTH - TYPE(REAL_DATA_TASKS),DIMENSION(:,:),POINTER :: CHILD_BOUND_H_NORTH - TYPE(REAL_DATA_TASKS),DIMENSION(:,:),POINTER :: CHILD_BOUND_H_WEST - TYPE(REAL_DATA_TASKS),DIMENSION(:,:),POINTER :: CHILD_BOUND_H_EAST - TYPE(REAL_DATA_TASKS),DIMENSION(:,:),POINTER :: CHILD_BOUND_V_SOUTH - TYPE(REAL_DATA_TASKS),DIMENSION(:,:),POINTER :: CHILD_BOUND_V_NORTH - TYPE(REAL_DATA_TASKS),DIMENSION(:,:),POINTER :: CHILD_BOUND_V_WEST - TYPE(REAL_DATA_TASKS),DIMENSION(:,:),POINTER :: CHILD_BOUND_V_EAST -! - TYPE(BC_H) :: MY_BC_VARS_H_S - TYPE(BC_H) :: MY_BC_VARS_H_N - TYPE(BC_H) :: MY_BC_VARS_H_W - TYPE(BC_H) :: MY_BC_VARS_H_E -! - TYPE(BC_V) :: MY_BC_VARS_V_S - TYPE(BC_V) :: MY_BC_VARS_V_N - TYPE(BC_V) :: MY_BC_VARS_V_W - TYPE(BC_V) :: MY_BC_VARS_V_E -! - TYPE(MIXED_DATA_TASKS),DIMENSION(:),POINTER :: MOVING_CHILD_UPDATE -! - TYPE(BNDS_2D),DIMENSION(:),POINTER :: NEST_FIS_ON_PARENT_BNDS -! - TYPE(SIDES_0D) :: INDX_MAX_H,INDX_MAX_V - TYPE(SIDES_0D) :: INDX_MIN_H,INDX_MIN_V - TYPE(SIDES_0D) :: NUM_PARENT_TASKS_SENDING_H - TYPE(SIDES_0D) :: NUM_PARENT_TASKS_SENDING_V -! - TYPE(SIDES_2D),DIMENSION(:),POINTER :: CHILDTASK_BNDRY_H_RANKS - TYPE(SIDES_2D),DIMENSION(:),POINTER :: CHILDTASK_BNDRY_V_RANKS -! - TYPE(SAVE_TASK_IJ),DIMENSION(:),POINTER :: CHILDTASK_H_SAVE - TYPE(SAVE_TASK_IJ),DIMENSION(:),POINTER :: CHILDTASK_V_SAVE -! - TYPE(PARENT_POINTS_SURROUND_H),DIMENSION(:),POINTER :: PARENT_4_INDICES_H - TYPE(PARENT_POINTS_SURROUND_V),DIMENSION(:),POINTER :: PARENT_4_INDICES_V -! - TYPE(PARENT_WEIGHTS_SURROUND_H),DIMENSION(:),POINTER :: PARENT_4_WEIGHTS_H - TYPE(PARENT_WEIGHTS_SURROUND_V),DIMENSION(:),POINTER :: PARENT_4_WEIGHTS_V -! - TYPE(PARENT_DATA),DIMENSION(:),POINTER :: PARENT_TASK -! - TYPE(CHILD_UPDATE_LINK),DIMENSION(:),POINTER :: TASK_UPDATE_SPECS & - ,CHILD_TASKS_2WAY_UPDATE -! - TYPE(HANDLE_SEND),DIMENSION(:),POINTER :: HANDLE_MOVE_DATA -! - TYPE(HANDLE_SEND),DIMENSION(:,:),POINTER :: HANDLE_H_SOUTH - TYPE(HANDLE_SEND),DIMENSION(:,:),POINTER :: HANDLE_H_NORTH - TYPE(HANDLE_SEND),DIMENSION(:,:),POINTER :: HANDLE_H_WEST - TYPE(HANDLE_SEND),DIMENSION(:,:),POINTER :: HANDLE_H_EAST - TYPE(HANDLE_SEND),DIMENSION(:,:),POINTER :: HANDLE_V_SOUTH - TYPE(HANDLE_SEND),DIMENSION(:,:),POINTER :: HANDLE_V_NORTH - TYPE(HANDLE_SEND),DIMENSION(:,:),POINTER :: HANDLE_V_WEST - TYPE(HANDLE_SEND),DIMENSION(:,:),POINTER :: HANDLE_V_EAST -! - TYPE(ESMF_Config) :: CF_MINE - TYPE(ESMF_Config) :: CF_PARENT - TYPE(ESMF_Config),DIMENSION(:),POINTER :: CF -! - TYPE(ESMF_FieldBundle) :: BUNDLE_2WAY - TYPE(ESMF_FieldBundle) :: BUNDLE_NESTBC - TYPE(ESMF_FieldBundle) :: MOVE_BUNDLE_H - TYPE(ESMF_FieldBundle) :: MOVE_BUNDLE_V -! - LOGICAL(kind=KLOG) :: ALLCLEAR_SIGNAL_PRESENT & - ,I_AM_A_FCST_TASK & - ,I_AM_A_PARENT & - ,MY_DOMAIN_MOVES & - ,RECV_ALL_CHILD_DATA -! - REAL(kind=KDBL) :: cpl1_prelim_tim & - ,cpl1_south_h_tim,cpl1_south_v_tim & - ,cpl1_north_h_tim,cpl1_north_v_tim & - ,cpl1_west_h_tim, cpl1_west_v_tim & - ,cpl1_east_h_tim, cpl1_east_v_tim & - ,cpl1_recv_tim -! - REAL(kind=KDBL) :: cpl1_south_h_recv_tim & - ,cpl1_south_h_undo_tim & - ,cpl1_south_h_exp_tim & - ,cpl1_south_v_recv_tim & - ,cpl1_south_v_undo_tim & - ,cpl1_south_v_exp_tim -! - REAL(kind=KDBL) :: cpl2_comp_tim & - ,cpl2_send_tim & - ,cpl2_wait_tim -! - REAL(kind=KDBL) :: moving_nest_bookkeep_tim & - ,moving_nest_update_tim -! - REAL(kind=KDBL) :: parent_bookkeep_moving_tim & - ,parent_update_moving_tim & - ,t0_recv_move_tim & - ,read_moving_child_topo_tim & - ,barrier_move_tim,pscd_tim,pscd1_tim & - ,pscd2_tim,pscd3_tim,pscd4_tim -! - REAL(kind=KDBL) :: ja1_tim,ja2_tim,ja3_tim,ja4_tim,jat_tim -! -!*** The following are for moving nests. -! - CHARACTER(len=32) :: MOVE_TYPE -! - INTEGER(kind=KINT) :: I_EAST_M,I_WEST_M,J_NORTH_M,J_SOUTH_M - INTEGER(kind=KINT) :: I_MAX,I_MIN,J_MAX,J_MIN - INTEGER(kind=KINT) :: NPTS_NS,NPTS_WE -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: I_PG,J_PG -! - REAL(kind=KFPT) :: COEF - REAL(kind=KFPT) :: ELAPSED_TIME_MIN - REAL(kind=KFPT) :: RNPTS_HZ -! - LOGICAL(kind=KLOG) :: FIRST_PASS_M - LOGICAL(kind=KLOG) :: FIRST_STEP_2WAY - LOGICAL(kind=KLOG) :: I_HOLD_CENTER_POINT -! - LOGICAL(kind=KLOG),DIMENSION(:),POINTER :: IN_WINDOW=>NULL() - LOGICAL(kind=KLOG),DIMENSION(:),POINTER :: I_HOLD_PG_POINT -! -!*** The following are for prescribed moves -! - INTEGER(kind=KINT) :: MOVE_INTERVAL_MINUTES - INTEGER(kind=KINT) :: N_MOVES - REAL(kind=KFPT),DIMENSION(:),POINTER :: MOVE_MINUTE - INTEGER(kind=KINT),DIMENSION(:),POINTER :: MOVE_I_SW,MOVE_J_SW -! - END TYPE COMPOSITE -! -!----------------------------------------------------------------------- -!*** Now declare the composite object. It will hold all of the -!*** above quantities separately for each domain a task is on. -!----------------------------------------------------------------------- -! - TYPE(COMPOSITE),DIMENSION(:),POINTER,SAVE :: CPL_COMPOSITE !<-- Coupler's composite object of domain variables -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Declare generic pointers that will point into the composite -!*** object. We want to be able to do this so that the standard -!*** names of the generic pointers can be used where desired. -!----------------------------------------------------------------------- -! - INTEGER(kind=KINT),POINTER :: NCYCLE_CHILD & - ,NCYCLE_PARENT -! - INTEGER(kind=KINT),POINTER :: COMM_TO_MY_PARENT & - ,HANDLE_MOVE_FLAG & - ,HANDLE_SEND_2WAY_SIGNAL & - ,I_CENTER_CURRENT & - ,I_SHIFT_CHILD & - ,J_SHIFT_CHILD & - ,I_SW_PARENT_CURRENT & - ,I_SW_PARENT_NEW & - ,J_CENTER_CURRENT & - ,J_SW_PARENT_CURRENT & - ,J_SW_PARENT_NEW & - ,ITS,ITE,JTS,JTE,LM & - ,IMS,IME,JMS,JME & - ,IDS,IDE,JDS,JDE & - ,IM_1,JM_1 & - ,INPES,JNPES & - ,INPES_PARENT,JNPES_PARENT & - ,JM & - ,KOUNT_2WAY_CHILDREN & - ,LAST_STEP_MOVED & - ,MAX_SHIFT & - ,MYPE & - ,N_BLEND_H,N_BLEND_V & - ,N_STENCIL_H,N_STENCIL_SFC_H & - ,N_STENCIL_V,N_STENCIL_SFC_V & - ,NHALO & - ,NLEV_H & - ,NLEV_V & - ,NPHS & - ,NTASKS_UPDATE_PARENT & - ,NTIMESTEP_CHECK & - ,NTIMESTEP_FINAL & - ,NTIMESTEP_WAIT_PARENT & - ,NTIMESTEP_WAIT_FORCED_PARENT & - ,NTIMESTEPS_RESTART & - ,NTOT_SFC & - ,NTRACK & - ,NUM_CHILDREN & - ,NUM_2WAY_CHILDREN & - ,NUM_MOVING_CHILDREN & - ,NUM_PES_FCST & - ,NUM_FCST_TASKS_PARENT & - ,NUM_TASKS_PARENT & - ,NEXT_MOVE_TIMESTEP & - ,NUM_LEVELS_MOVE_3D_H & - ,NUM_LEVELS_MOVE_3D_V & - ,NUM_SPACE_RATIOS_MVG & - ,NVARS_BC_2D_H & - ,NVARS_BC_3D_H & - ,NVARS_BC_4D_H & - ,NVARS_BC_2D_V & - ,NVARS_BC_3D_V & - ,SPACE_RATIO_MY_PARENT & - ,TIME_RATIO_MY_PARENT -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: DOMAIN_ID_TO_RANK & - ,MY_DOMAIN_LIMITS & - ,MY_FORCED_SHIFT & - ,MY_NEB & - ,PARENT_DOMAIN_LIMITS & - ,PARENT_SHIFT & - ,STORM_CENTER -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: PARENT_CHILD_SPACE_RATIO & - ,TIME_RATIO_MY_CHILDREN & - ,IM_CHILD & - ,JM_CHILD & - ,I_PARENT_SW & - ,J_PARENT_SW & - ,ITE_PARENT & - ,ITS_PARENT & - ,JTE_PARENT & - ,JTS_PARENT & - ,LBND_4D & - ,UBND_4D & - ,LINK_MRANK_RATIO & - ,LIST_OF_RATIOS & - ,LOCAL_ISTART & - ,LOCAL_IEND & - ,LOCAL_JSTART & - ,LOCAL_JEND & - ,M_NEST_RATIO & - ,N_BLEND_H_CHILD & - ,N_BLEND_V_CHILD & - ,N_STENCIL_H_CHILD & - ,N_STENCIL_SFC_H_CHILD & - ,N_STENCIL_V_CHILD & - ,N_STENCIL_SFC_V_CHILD & - ,NTASKS_UPDATE_CHILD & - ,NSTEP_CHILD_RECV & - ,INC_FIX & - ,COMM_TO_MY_CHILDREN & - ,ID_PARENTS & - ,ID_PARENT_UPDATE_TASKS & - ,MY_CHILDREN_ID & - ,RANK_2WAY_CHILD & - ,RANK_MOVING_CHILD & - ,FTASKS_DOMAIN & - ,NTASKS_DOMAIN & - ,NPTS_UPDATE_ON_PARENT_TASKS & - ,HANDLE_BC_UPDATE & - ,HANDLE_PARENT_SHIFT & - ,HANDLE_TIMESTEP & - ,HANDLE_SEND_2WAY_DATA & - ,HANDLE_SEND_2WAY_SFC & - ,HANDLE_SEND_ALLCLEAR & - ,NTIMESTEP_CHILD_MOVES & - ,NUM_TASKS_SEND_H_S & - ,NUM_TASKS_SEND_H_N & - ,NUM_TASKS_SEND_H_W & - ,NUM_TASKS_SEND_H_E & - ,NUM_TASKS_SEND_V_S & - ,NUM_TASKS_SEND_V_N & - ,NUM_TASKS_SEND_V_W & - ,NUM_TASKS_SEND_V_E & - ,SHIFT_INFO_MINE -! - INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: SHIFT_INFO_CHILDREN -! - REAL(kind=KFPT),POINTER :: CENTERS_DISTANCE & - ,DLM & - ,DPH & - ,DYH & - ,PDTOP & - ,PT & - ,SB_1 & - ,WB_1 & - ,TPH0_1 & - ,TLM0_1 & - ,RECIP_DPH_1 & - ,RECIP_DLM_1 & - ,RECIP_PARENT_SPACE_RATIO -! - REAL(kind=KFPT),DIMENSION(:),POINTER :: DT_DOMAIN & - ,DXH & - ,DSG2 & - ,PDSG1 & - ,PSGML1 & - ,SG1 & - ,SG2 & - ,SGML2 -! - REAL(kind=KFPT),DIMENSION(:),POINTER :: CHILD_2WAY_WGT & - ,CHILD_PARENT_SPACE_RATIO -! - REAL(kind=KFPT),DIMENSION(:),POINTER :: BOUND_1D_SOUTH_H & - ,BOUND_1D_SOUTH_V & - ,BOUND_1D_NORTH_H & - ,BOUND_1D_NORTH_V & - ,BOUND_1D_WEST_H & - ,BOUND_1D_WEST_V & - ,BOUND_1D_EAST_H & - ,BOUND_1D_EAST_V -! - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: FIS & - ,FIS_CHILD_ON_PARENT & - ,GLAT & - ,GLON & - ,PD & - ,SM & - ,U10 & - ,V10 -! - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: PDB_S & - ,PDB_N & - ,PDB_W & - ,PDB_E -! - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: CW & - ,PINT & - ,Q & - ,T & - ,U & - ,V & - ,Z -! - REAL(kind=KFPT),DIMENSION(:,:,:,:),POINTER :: TRACERS -! - CHARACTER(len=6),DIMENSION(:),POINTER,SAVE :: STATIC_OR_MOVING -! - LOGICAL(kind=KLOG),POINTER :: CALLED_CHILD_2WAY_BOOKKEEPING - LOGICAL(kind=KLOG),POINTER :: CHILD_FORCES_MY_SHIFT - LOGICAL(kind=KLOG),POINTER :: FIRST_CALL_RECV_2WAY - LOGICAL(kind=KLOG),POINTER :: FIRST_CALL_RECV_BC - LOGICAL(kind=KLOG),POINTER :: FORCED_PARENT_SHIFT - LOGICAL(kind=KLOG),POINTER :: I_AM_ACTIVE - LOGICAL(kind=KLOG),POINTER :: I_AM_LEAD_FCST_TASK - LOGICAL(kind=KLOG),POINTER :: I_WANT_TO_MOVE - LOGICAL(kind=KLOG),POINTER :: MOVE_FLAG_SENT - LOGICAL(kind=KLOG),POINTER :: MY_PARENT_MOVES - LOGICAL(kind=KLOG),POINTER :: PARENT_WANTS_TO_MOVE - LOGICAL(kind=KLOG),POINTER :: STOP_MY_MOTION -! - LOGICAL(kind=KLOG),DIMENSION(:),POINTER :: CALLED_PARENT_2WAY_BOOKKEEPING - LOGICAL(kind=KLOG),DIMENSION(:),POINTER :: CHILD_ACTIVE - LOGICAL(kind=KLOG),DIMENSION(:),POINTER :: MOVE_FLAG - LOGICAL(kind=KLOG),DIMENSION(:),POINTER :: SEND_CHILD_DATA - LOGICAL(kind=KLOG),DIMENSION(:),POINTER :: SIGNAL_2WAY_SEND_READY - LOGICAL(kind=KLOG),DIMENSION(:),POINTER :: SKIP_2WAY_UPDATE -! - TYPE(INTEGER_DATA),DIMENSION(:),POINTER :: I_2WAY_UPDATE & - ,J_2WAY_UPDATE & - ,I_2WAY_H & - ,J_2WAY_H & - ,I_2WAY_V & - ,J_2WAY_V -! - TYPE(INTEGER_DATA_TASKS),DIMENSION(:),POINTER :: WORDS_BOUND_H_SOUTH & - ,WORDS_BOUND_H_NORTH & - ,WORDS_BOUND_H_WEST & - ,WORDS_BOUND_H_EAST & - ,WORDS_BOUND_V_SOUTH & - ,WORDS_BOUND_V_NORTH & - ,WORDS_BOUND_V_WEST & - ,WORDS_BOUND_V_EAST -! - TYPE(REAL_DATA),DIMENSION(:),POINTER :: UPDATE_PARENT_2WAY -! - TYPE(REAL_DATA_2D),DIMENSION(:),POINTER :: CHILD_SFC_ON_PARENT - TYPE(REAL_DATA_2D),DIMENSION(:),POINTER :: NEST_FIS_ON_PARENT - TYPE(REAL_DATA_2D),DIMENSION(:),POINTER :: NEST_FIS_V_ON_PARENT -! - TYPE(REAL_DATA_TASKS),DIMENSION(:),POINTER :: PD_B_SOUTH & - ,PD_B_NORTH & - ,PD_B_WEST & - ,PD_B_EAST & -! - ,PD_B_SOUTH_V & - ,PD_B_NORTH_V & - ,PD_B_WEST_V & - ,PD_B_EAST_V & -! - ,FIS_CHILD_SOUTH & - ,FIS_CHILD_NORTH & - ,FIS_CHILD_WEST & - ,FIS_CHILD_EAST -! - TYPE(REAL_DATA_TASKS),DIMENSION(:,:),POINTER :: CHILD_BOUND_H_SOUTH & - ,CHILD_BOUND_H_NORTH & - ,CHILD_BOUND_H_WEST & - ,CHILD_BOUND_H_EAST & - ,CHILD_BOUND_V_SOUTH & - ,CHILD_BOUND_V_NORTH & - ,CHILD_BOUND_V_WEST & - ,CHILD_BOUND_V_EAST -! - TYPE(BC_H),POINTER :: MY_BC_VARS_H_S & - ,MY_BC_VARS_H_N & - ,MY_BC_VARS_H_W & - ,MY_BC_VARS_H_E -! - TYPE(BC_V),POINTER :: MY_BC_VARS_V_S & - ,MY_BC_VARS_V_N & - ,MY_BC_VARS_V_W & - ,MY_BC_VARS_V_E -! - TYPE(MIXED_DATA_TASKS),DIMENSION(:),POINTER :: MOVING_CHILD_UPDATE -! - TYPE(MULTIDATA),DIMENSION(:),POINTER :: BND_VAR_H_SOUTH & - ,BND_VAR_H_NORTH & - ,BND_VAR_H_WEST & - ,BND_VAR_H_EAST & - ,BND_VAR_V_SOUTH & - ,BND_VAR_V_NORTH & - ,BND_VAR_V_WEST & - ,BND_VAR_V_EAST -! - TYPE(BNDS_2D),DIMENSION(:),POINTER :: NEST_FIS_ON_PARENT_BNDS -! - TYPE(SIDES_0D),POINTER :: INDX_MAX_H,INDX_MAX_V - TYPE(SIDES_0D),POINTER :: INDX_MIN_H,INDX_MIN_V - TYPE(SIDES_0D),POINTER :: NUM_PARENT_TASKS_SENDING_H - TYPE(SIDES_0D),POINTER :: NUM_PARENT_TASKS_SENDING_V -! - TYPE(SIDES_2D),DIMENSION(:),POINTER :: CHILDTASK_BNDRY_H_RANKS - TYPE(SIDES_2D),DIMENSION(:),POINTER :: CHILDTASK_BNDRY_V_RANKS -! - TYPE(SAVE_TASK_IJ),DIMENSION(:),POINTER :: CHILDTASK_H_SAVE - TYPE(SAVE_TASK_IJ),DIMENSION(:),POINTER :: CHILDTASK_V_SAVE -! - TYPE(PARENT_POINTS_SURROUND_H),DIMENSION(:),POINTER :: PARENT_4_INDICES_H - TYPE(PARENT_POINTS_SURROUND_V),DIMENSION(:),POINTER :: PARENT_4_INDICES_V -! - TYPE(PARENT_WEIGHTS_SURROUND_H),DIMENSION(:),POINTER :: PARENT_4_WEIGHTS_H - TYPE(PARENT_WEIGHTS_SURROUND_V),DIMENSION(:),POINTER :: PARENT_4_WEIGHTS_V -! - TYPE(PARENT_DATA),DIMENSION(:),POINTER :: PARENT_TASK -! - TYPE(CHILD_UPDATE_LINK),DIMENSION(:),POINTER :: TASK_UPDATE_SPECS & - ,CHILD_TASKS_2WAY_UPDATE -! - TYPE(HANDLE_SEND),DIMENSION(:),POINTER :: HANDLE_MOVE_DATA -! - TYPE(HANDLE_SEND),DIMENSION(:,:),POINTER :: HANDLE_H_SOUTH & - ,HANDLE_H_NORTH & - ,HANDLE_H_WEST & - ,HANDLE_H_EAST & - ,HANDLE_V_SOUTH & - ,HANDLE_V_NORTH & - ,HANDLE_V_WEST & - ,HANDLE_V_EAST -! - TYPE(ESMF_Config),POINTER :: CF_MINE - TYPE(ESMF_Config),POINTER :: CF_PARENT - TYPE(ESMF_Config),DIMENSION(:),POINTER :: CF -! - TYPE(ESMF_FieldBundle),POINTER :: BUNDLE_2WAY & - ,BUNDLE_NESTBC & - ,MOVE_BUNDLE_H & - ,MOVE_BUNDLE_V -! - LOGICAL(kind=KLOG),POINTER :: ALLCLEAR_SIGNAL_PRESENT & - ,I_AM_A_FCST_TASK & - ,I_AM_A_PARENT & - ,MY_DOMAIN_MOVES & - ,RECV_ALL_CHILD_DATA -! - REAL(kind=KDBL),POINTER :: cpl1_prelim_tim & - ,cpl1_south_h_tim,cpl1_south_v_tim & - ,cpl1_north_h_tim,cpl1_north_v_tim & - ,cpl1_west_h_tim, cpl1_west_v_tim & - ,cpl1_east_h_tim, cpl1_east_v_tim & - ,cpl1_recv_tim -! - REAL(kind=KDBL),POINTER :: cpl1_south_h_recv_tim & - ,cpl1_south_h_undo_tim & - ,cpl1_south_h_exp_tim & - ,cpl1_south_v_recv_tim & - ,cpl1_south_v_undo_tim & - ,cpl1_south_v_exp_tim -! - REAL(kind=KDBL),POINTER :: cpl2_comp_tim & - ,cpl2_send_tim & - ,cpl2_wait_tim -! - REAL(kind=KDBL),POINTER :: moving_nest_bookkeep_tim & - ,moving_nest_update_tim -! - REAL(kind=KDBL),POINTER :: parent_bookkeep_moving_tim & - ,parent_update_moving_tim & - ,t0_recv_move_tim & - ,read_moving_child_topo_tim & - ,barrier_move_tim,pscd_tim,pscd1_tim & - ,pscd2_tim,pscd3_tim,pscd4_tim - - REAL(kind=KDBL),POINTER :: ja1_tim,ja2_tim,ja3_tim,ja4_tim,jat_tim -! -!----------------------------------------- -!*** The following are for moving nests. -!----------------------------------------- -! - CHARACTER(len=32),POINTER :: MOVE_TYPE - INTEGER(kind=KINT),POINTER :: I_EAST_M,I_WEST_M & - ,I_MAX,I_MIN & - ,J_NORTH_M,J_SOUTH_M & - ,J_MAX,J_MIN & - ,NPTS_NS,NPTS_WE -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: I_PG,J_PG -! - REAL(kind=KFPT),POINTER :: COEF - REAL(kind=KFPT),POINTER :: ELAPSED_TIME_MIN - REAL(kind=KFPT),POINTER :: RNPTS_HZ -! - LOGICAL(kind=KLOG),POINTER :: FIRST_PASS_M - LOGICAL(kind=KLOG),POINTER :: FIRST_STEP_2WAY - LOGICAL(kind=KLOG),POINTER :: I_HOLD_CENTER_POINT -! - LOGICAL(kind=KLOG),DIMENSION(:),POINTER :: IN_WINDOW - LOGICAL(kind=KLOG),DIMENSION(:),POINTER :: I_HOLD_PG_POINT -! - INTEGER(kind=KINT),POINTER :: MOVE_INTERVAL_MINUTES - INTEGER(kind=KINT),POINTER :: N_MOVES - REAL(kind=KFPT),DIMENSION(:),POINTER :: MOVE_MINUTE - INTEGER(kind=KINT),DIMENSION(:),POINTER :: MOVE_I_SW,MOVE_J_SW -! -!----------------------------------------------------------------------- -!*** Quantities not associated with the composite object. -!----------------------------------------------------------------------- -! - INTEGER(kind=KINT),PARAMETER :: INDX_SW=1 & - ,INDX_SE=2 & - ,INDX_NW=3 & - ,INDX_NE=4 -! - INTEGER(kind=KINT),SAVE :: MOVE_TAG=1111 & !<-- Arbitrary tag used for child's move - ,MOVING_BC_TAG=1112 & !<-- Arbitrary tag used for moving nests' BC updates - ,PARENT_SHIFT_TAG=1E6 !<-- Arbitrary tag used for parent's move. -! - INTEGER(kind=KINT),SAVE :: MAX_FORCED_SHIFT !<-- # parent points a child forces its parent to shift -! - INTEGER(kind=KINT),SAVE :: CHILD_ID & - ,COMM_FCST_TASKS & - ,INDX_CW,INDX_Q & - ,NHOURS_FCST & - ,NLEV_2WAY & - ,NROWS_P_UPD_E & - ,NROWS_P_UPD_N & - ,NROWS_P_UPD_S & - ,NROWS_P_UPD_W & - ,NUM_FIELDS_MOVE & - ,NUM_FIELDS_MOVE_2D_H_I & - ,NUM_FIELDS_MOVE_2D_X_I & - ,NUM_FIELDS_MOVE_2D_H_R & - ,NUM_FIELDS_MOVE_2D_X_R & - ,NUM_FIELDS_MOVE_3D_H & - ,NUM_FIELDS_MOVE_2D_V & - ,NUM_FIELDS_MOVE_3D_V & - ,NVARS_2WAY_UPDATE & - ,NVARS_NESTBC & - ,NVARS_NESTBC_H & - ,NVARS_NESTBC_V -! - INTEGER(kind=KINT) :: TWOWAY_SIGNAL_TAG !<-- Arbitrary tag used for 2way exchange -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE,SAVE :: NBASE_VAR_H & - ,NBASE_VAR_V -! - REAL(kind=KDBL),SAVE :: HYPER_A -! - REAL(kind=KFPT),SAVE :: EPS=1.E-4 & - ,MIN_DIST_PARENT !<-- # of parent gridpoints a child can be from parent -! - REAL(kind=KFPT),SAVE :: NORTH_LAT_MAX_MVG_NEST & !<-- Do not let nests move north of this latitude (rad) - ,SOUTH_LAT_MAX_MVG_NEST !<-- Do not let nests move south of this latitude (rad) -! - REAL(kind=KDBL) :: btim,btim0,btim1,btim2 -! - CHARACTER(len=5),SAVE :: NEST_MODE !<--- Is the nesting 1-way or 2-way -! - CHARACTER(len=99) :: CONFIG_FILE_NAME -! - LOGICAL(kind=KLOG) :: FREE_FORECAST,DIG_FILTER -! - LOGICAL(kind=KLOG),SAVE :: GLOBAL_TOP_PARENT & !<-- Is the uppermost parent global? - ,RESTART !<-- Is this a restarted run? -! - TYPE(ESMF_Config),SAVE :: CF_1 !<-- Domain #1's configure object -! - integer(kind=kint),dimension(8) :: values -! -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE PARENT_CHILD_CPL_REGISTER(CPL_COMP,RC_NEST_REG) -! -!----------------------------------------------------------------------- -!*** Register the nesting coupler component's Initialize, Run, and -!*** Finalize routines. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument variables -!------------------------ -! - TYPE(ESMF_CplComp) :: CPL_COMP !<-- Coupler component -! - INTEGER(kind=KINT),INTENT(OUT) :: RC_NEST_REG !<-- Return code for register -! -!--------------------- -!*** Local variables -!--------------------- -! - INTEGER(kind=KINT) :: RC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RC_NEST_REG=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** Register the various pieces of the Parent-Child coupler component. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for Phase 1 of the P-C Coupler Initialize" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_CplCompSetEntryPoint(CPL_COMP & !<-- The Parent-Child Coupler Component - ,ESMF_METHOD_INITIALIZE & !<-- subroutineType - ,PARENT_CHILD_CPL_INITIALIZE0 & !<-- User's subroutineName - ,phase=1 & - ,rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NEST_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for Phase 2 of the P-C Coupler Initialize" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_CplCompSetEntryPoint(CPL_COMP & !<-- The Parent-Child Coupler Component - ,ESMF_METHOD_INITIALIZE & !<-- subroutineType - ,PARENT_CHILD_CPL_INITIALIZE1 & !<-- User's subroutineName - ,phase=2 & - ,rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NEST_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for Phase 3 of the P-C Coupler Initialize" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_CplCompSetEntryPoint(CPL_COMP & !<-- The Parent-Child Coupler Component - ,ESMF_METHOD_INITIALIZE & !<-- subroutineType - ,PARENT_CHILD_CPL_INITIALIZE2 & !<-- User's subroutineName - ,phase=3 & - ,rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NEST_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Register the Parent-Child coupler's Run subroutines. -! -! The Parent-Child Run step of the coupler has five distinct parts: -! (1) Check for signals related to 2-way exchange at the beginning -! of timesteps to determine if the execution should proceed -! into the timestep or drop out. This is only relevant for -! generational task assignment (i.e., for 2-way nesting). -! (2) At the start of parent timesteps a child receives BC data -! from its parent. -! (3) If using 2-way nesting then parents receive exchange data -! from their children at the start of every parent timestep. -! (4) At the end of every parent timestep a parent sends BC data -! to its children. For those children that moved, the parent -! must first generate new interpolation information and then -! compute the new internal shift data for those nests. -! (5) Finally any 2-way children send exchange data to their -! parents at the end of every parent timestep. -! -!*** Thus register the coupler's Run step with those two phases. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for Phase 1 of P-C Coupler Run" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_CplCompSetEntryPoint(CPL_COMP & !<-- The Parent-Child Coupler Component - ,ESMF_METHOD_RUN & !<-- subroutineType - ,CHECK_2WAY_SIGNALS & !<-- User's subroutineName - ,phase=1 & - ,rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NEST_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for Phase 2 of P-C Coupler Run" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_CplCompSetEntryPoint(CPL_COMP & !<-- The Parent-Child Coupler Component - ,ESMF_METHOD_RUN & !<-- subroutineType - ,CHILDREN_RECV_PARENT_DATA & !<-- User's subroutineName - ,phase=2 & - ,rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NEST_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for Phase 3 of P-C Coupler Run" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_CplCompSetEntryPoint(CPL_COMP & !<-- The Parent-Child Coupler Component - ,ESMF_METHOD_RUN & !<-- subroutineType - ,PARENTS_RECV_CHILD_2WAY_DATA & !<-- User's subroutineName - ,phase=3 & - ,rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NEST_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for Phase 4 of P-C Coupler Run" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_CplCompSetEntryPoint(CPL_COMP & !<-- The Parent-Child Coupler Component - ,ESMF_METHOD_RUN & !<-- subroutineType - ,PARENTS_SEND_CHILD_DATA & !<-- User's subroutineName - ,phase=4 & - ,rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NEST_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for Phase 5 of P-C Coupler Run" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_CplCompSetEntryPoint(CPL_COMP & !<-- The Parent-Child Coupler Component - ,ESMF_METHOD_RUN & !<-- subroutineType - ,CHILDREN_SEND_PARENTS_2WAY_DATA & !<-- User's subroutineName - ,phase=5 & - ,rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NEST_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Register the coupler Finalize subroutine. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for Nesting Coupler Finalize" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_CplCompSetEntryPoint(CPL_COMP & !<-- The Parent-Child Coupler Component - ,ESMF_METHOD_FINALIZE & !<-- subroutineType - ,PARENT_CHILD_CPL_FINALIZE & !<-- User's subroutineName - ,phase=1 & - ,rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NEST_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Check the error signal variable. -!----------------------------------------------------------------------- -! - IF(RC_NEST_REG==ESMF_SUCCESS)THEN -! WRITE(0,*)" NESTING COUPLER REGISTER SUCCEEDED" - ELSE - WRITE(0,*)" NESTING COUPLER REGISTER FAILED" - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PARENT_CHILD_CPL_REGISTER -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE PARENT_CHILD_CPL_INITIALIZE0(CPL_COMP & - ,IMP_STATE & - ,EXP_STATE & - ,CLOCK & - ,RC_FINAL) -! -!----------------------------------------------------------------------- -!*** This preliminary routine is used only for runs containing nests. -!*** It serves primarily to allow children to send their SW corner -!*** location to their parents. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument variables -!------------------------ -! - TYPE(ESMF_CplComp) :: CPL_COMP !<-- The Parent-Child Coupler Component -! - TYPE(ESMF_State) :: IMP_STATE & !<-- The Coupler's Import State - ,EXP_STATE !<-- The Coupler's Export State -! - TYPE(ESMF_Clock) :: CLOCK !<-- The ESMF Clock -! - INTEGER,INTENT(OUT) :: RC_FINAL -! -!--------------------- -!*** Local variables -!--------------------- -! - INTEGER(kind=KINT) :: CHILDTASK_0,CONFIG_ID,HANDLE_X,ID_CHILD & - ,MAX_DOMAINS,MY_DOMAIN_ID,MYPE_X,N,NTAG -! - INTEGER(kind=KINT) :: IERR,ISTAT,RC,RC_CPL_INIT -! - CHARACTER(len=2) :: INT_TO_CHAR - CHARACTER(len=6) :: FMT='(I2.2)' -! - TYPE(COMPOSITE),POINTER :: CC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Initialize the error signal variables. -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RC_FINAL =ESMF_SUCCESS - RC_CPL_INIT=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** What is this domain's ID? -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Init1: Extract Current Domain ID" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='MY_DOMAIN_ID' & !<-- Name of the attribute to extract - ,value=MY_DOMAIN_ID & !<-- Current domain's ID - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - CC=>CPL_COMPOSITE(MY_DOMAIN_ID) !<-- Use dummy for shorter reference to composite -! -!----------------------------------------------------------------------- -! -!------------------------ -!*** Number of Children -!------------------------ -! - NUM_CHILDREN=>cc%NUM_CHILDREN - NUM_CHILDREN=0 -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Number of Children on This Domain" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='NUM_CHILDREN' & !<-- Name of the attribute to extract - ,value=NUM_CHILDREN & !<-- # of this domain's children - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!------------------------------- -!*** Maximum number of domains -!------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Maximum Number of Domains" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='MAX_DOMAINS' & !<-- Name of the attribute to extract - ,value=MAX_DOMAINS & !<-- Maximum # of domains - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!---------------------------------- -!*** Child-to-Parent Communicator -!---------------------------------- -! - COMM_TO_MY_PARENT=>CC%COMM_TO_MY_PARENT -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Child-to-Parent Comm in P-C Coupler Init1" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='Child-to-Parent Comm' & !<-- Name of the attribute to extract - ,value=COMM_TO_MY_PARENT & !<-- MPI communicator to my parent - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------- -!*** The association of domains and their configure files. -!----------------------------------------------------------- -! - IF(.NOT.ASSOCIATED(DOMAIN_ID_TO_RANK))THEN - ALLOCATE(DOMAIN_ID_TO_RANK(1:MAX_DOMAINS)) - ENDIF -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Association of Domains and Config Files" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,name ='DOMAIN_ID_TO_RANK' & !<-- Name of the attribute to extract - ,itemCount=MAX_DOMAINS & !<-- Name of elements in the Attribute - ,valueList=DOMAIN_ID_TO_RANK & !<-- Array associating domains and config files - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------- -!*** Intracommunicator for fcst tasks on each domain -!----------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Fcst Task Intracomm in P-C Coupler Init0" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='Comm Fcst Tasks' & !<-- Name of the attribute to extract - ,value=COMM_FCST_TASKS & !<-- Intracommunicator for fcst tasks - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - I_AM_LEAD_FCST_TASK=>cc%I_AM_LEAD_FCST_TASK - I_AM_LEAD_FCST_TASK=.FALSE. -! - IF(I_AM_A_FCST_TASK)THEN -! - CALL MPI_COMM_RANK(COMM_FCST_TASKS,MYPE_X,IERR) -! - IF(MYPE_X==0)THEN - I_AM_LEAD_FCST_TASK=.TRUE. - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Tasks load their domain's configure file. -!----------------------------------------------------------------------- -! - CONFIG_ID=DOMAIN_ID_TO_RANK(MY_DOMAIN_ID) - WRITE(INT_TO_CHAR,FMT)CONFIG_ID - CONFIG_FILE_NAME='configure_file_'//INT_TO_CHAR !<-- Prepare the config file name -! - cc%CF_MINE=ESMF_ConfigCreate(rc=RC) - CF_MINE=>cc%CF_MINE -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Parent-Child Init: Nest Loads Its Configure File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigLoadFile(config =CF_MINE & - ,filename=CONFIG_FILE_NAME & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Parent tasks must know the communicators to their children -!*** and their domain IDs. -!----------------------------------------------------------------------- -! - IF(I_AM_A_FCST_TASK.AND.NUM_CHILDREN>0)THEN !<-- Select parent fcst tasks for additional setup -! - ALLOCATE(cc%COMM_TO_MY_CHILDREN(1:NUM_CHILDREN),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%COMM_TO_MY_CHILDREN stat=',ISTAT - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) - ENDIF - COMM_TO_MY_CHILDREN=>cc%COMM_TO_MY_CHILDREN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Init0: Extract Parent-to-Child Comm in Coupler" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,name ='Parent-to-Child Comms' & !<-- Name of the attribute to extract - ,itemCount=NUM_CHILDREN & !<-- # of items in the Attribute - ,valueList=COMM_TO_MY_CHILDREN & !<-- MPI communicators to my children - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------- -!*** The IDs of the Children -!----------------------------- -! - ALLOCATE(CC%MY_CHILDREN_ID(1:NUM_CHILDREN),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%MY_CHILDREN_ID stat=',ISTAT - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) - ENDIF -! - MY_CHILDREN_ID=>cc%MY_CHILDREN_ID -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Init0: Extract IDs of Children" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,name ='CHILD_IDs' & !<-- Name of the attribute to extract - ,itemCount=NUM_CHILDREN & !<-- # of items in the Attribute - ,valueList=MY_CHILDREN_ID & !<-- The domain IDs of the current domain's children - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Is this a restarted run? -!----------------------------------------------------------------------- -! - I_AM_A_FCST_TASK=>cc%I_AM_A_FCST_TASK -! - RESTART=.FALSE. -! - IF(I_AM_A_FCST_TASK)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Init0: Extract Restart Flag from P-C Cpl Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='RESTART' & !<-- Name of the attribute to extract - ,value=RESTART & !<-- The restart flag (true or false) - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! -!----------------------------------------------------------------------- -!*** The children get the location of their SW corner. -!*** That information was exported from the Domain component. -!----------------------------------------------------------------------- -! - child_block_0: IF(MY_DOMAIN_ID>1)THEN !<-- Select the children -! - I_SW_PARENT_CURRENT=>cc%I_SW_PARENT_CURRENT - J_SW_PARENT_CURRENT=>cc%J_SW_PARENT_CURRENT - LAST_STEP_MOVED=>cc%LAST_STEP_MOVED -! - IF(I_AM_A_FCST_TASK)THEN -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Parent-Child Init: Gets SW Corner from Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='I_PAR_STA' & !<-- Name of Attribute to extract - ,value=I_SW_PARENT_CURRENT & !<-- Put the extracted Attribute here - ,rc =RC) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='J_PAR_STA' & !<-- Name of Attribute to extract - ,value=J_SW_PARENT_CURRENT & !<-- Put the extracted Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Parent-Child Init: Get Last Move Timestep from Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='LAST_STEP_MOVED' & !<-- Name of Attribute to extract - ,value=LAST_STEP_MOVED & !<-- Put the extracted Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Fill the domain's next move timestep. The value is a dummy if -!*** it is not relevant. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Parent-Child Init: Get Next Move Timestep from Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='NEXT_MOVE_TIMESTEP' & !<-- Name of Attribute to extract - ,value=cc%NEXT_MOVE_TIMESTEP & !<-- Put the extracted Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! -!----------------------------------------------------------------------- -!*** The lead child task ISends its parent's lead task the child -!*** domain's SW corner location. There is no need for a Wait -!*** since a task will only ever execute this send one time. -!----------------------------------------------------------------------- -! - IF(I_AM_LEAD_FCST_TASK)THEN -! - NTAG=12121+100*MY_DOMAIN_ID !<-- Use a unique tag dependent on the domain ID -! - CALL MPI_ISSEND(I_SW_PARENT_CURRENT & !<-- Parent I of SW corner of nest domain - ,1 & !<-- There is 1 word - ,MPI_INTEGER & !<-- The message is an integer - ,0 & !<-- Send to lead parent task (always 0 in intracomm) - ,NTAG & !<-- Unique MPI tag - ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator to the parent - ,HANDLE_X & !<-- Request handle for this ISend - ,IERR ) -! - NTAG=12122+100*MY_DOMAIN_ID !<-- Use a unique tag dependent on the domain ID -! - CALL MPI_ISSEND(J_SW_PARENT_CURRENT & !<-- Parent J of SW corner of nest domain - ,1 & !<-- There is 1 word - ,MPI_INTEGER & !<-- The message is an integer - ,0 & !<-- Send to lead parent task (always 0 in intracomm) - ,NTAG & !<-- Unique MPI tag - ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator to the parent - ,HANDLE_X & !<-- Request handle for this ISend - ,IERR ) -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF child_block_0 -! -!----------------------------------------------------------------------- -!*** Parents receive their children's SW corner locations. -!----------------------------------------------------------------------- -! - parent_block_0: IF(NUM_CHILDREN>0)THEN !<-- Select the parents -! -!----------------------------------------------------------------------- -! - ALLOCATE(cc%I_PARENT_SW(1:NUM_CHILDREN),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%I_PARENT_SW stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - ALLOCATE(cc%J_PARENT_SW(1:NUM_CHILDREN),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%J_PARENT_SW stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! -! - I_PARENT_SW=>cc%I_PARENT_SW - J_PARENT_SW=>cc%J_PARENT_SW -! -!----------------------------------------------------------------------- -! - IF(I_AM_LEAD_FCST_TASK)THEN -! - DO N=1,NUM_CHILDREN -! - CHILDTASK_0=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(0) !<-- Local rank of child's lead task in P-C communicator - ID_CHILD=MY_CHILDREN_ID(N) !<-- Domain ID of child N - NTAG=12121+100*MY_CHILDREN_ID(N) -! - CALL MPI_IRECV(I_PARENT_SW(N) & !<-- Parent I of SW corner of child N - ,1 & !<-- There is 1 word - ,MPI_INTEGER & !<-- The word is an integer - ,CHILDTASK_0 & !<-- The Child task who sent - ,NTAG & !<-- Unique MPI tag - ,COMM_TO_MY_CHILDREN(N) & !<-- MPI communicator between parent and child N - ,HANDLE_I_SW(ID_CHILD) & !<-- Request handle for IRecv from child N - ,IERR ) -! - NTAG=12122+100*MY_CHILDREN_ID(N) -! - CALL MPI_IRECV(J_PARENT_SW(N) & !<-- Parent J of SW corner of child N - ,1 & !<-- There is 1 word - ,MPI_INTEGER & !<-- The word is an integer - ,CHILDTASK_0 & !<-- The Child task who sent - ,NTAG & !<-- Unique MPI tag - ,COMM_TO_MY_CHILDREN(N) & !<-- MPI communicator between parent and child N - ,HANDLE_J_SW(ID_CHILD) & !<-- Request handle for IRecv from child N - ,IERR ) -! - ENDDO -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF parent_block_0 -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PARENT_CHILD_CPL_INITIALIZE0 -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE PARENT_CHILD_CPL_INITIALIZE1(CPL_COMP & - ,IMP_STATE & - ,EXP_STATE & - ,CLOCK & - ,RC_FINAL) -! -!----------------------------------------------------------------------- -!*** Perform initial work needed by the Parent-Child coupler. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument variables -!------------------------ -! - TYPE(ESMF_CplComp) :: CPL_COMP !<-- The Parent-Child Coupler Component -! - TYPE(ESMF_State) :: IMP_STATE & !<-- The Coupler's Import State - ,EXP_STATE !<-- The Coupler's Export State -! - TYPE(ESMF_Clock) :: CLOCK !<-- The ESMF Clock -! - INTEGER,INTENT(OUT) :: RC_FINAL -! -!--------------------- -!*** Local variables -!--------------------- -! - INTEGER(kind=KINT),SAVE :: N8=8 -! - INTEGER(kind=KINT) :: I,J,L -! - INTEGER(kind=KINT) :: CHILD_FILTER,CHILDTASK_0,CONFIG_ID & - ,H_OR_V_INT,HANDLE_X,ID_CHILD,ID_DOM & - ,IDIM,IEND,ISTART,IUNIT_FIS_NEST & - ,JCORNER,JDIM,JEND,JSTART,JSTOP & - ,KOUNT & - ,LENGTH,LIM1_H,LIM1_V,LIM2_H,LIM2_V,LMP1,LOR & - ,MAX_DOMAINS,MY_DOMAIN_ID,MY_PARENT_ID & - ,MYPE_X & - ,N,N1,N2,N3,NN & - ,N_CHILD,N_FIELD,N_START,N_END & - ,N_H_EAST_WEST,N_H_NORTH_SOUTH & - ,N_V_EAST_WEST,N_V_NORTH_SOUTH & - ,NKOUNT,NTAG,NTIMESTEP & - ,NUM_BOUNDARY_WORDS & - ,NUM_DOMAINS,NUM_TASKS_TOTAL & - ,NUM_WORDS,NV -! - INTEGER(kind=KINT) :: IERR,ISTAT,RC,RC_CPL_INIT -! - INTEGER(kind=ESMF_KIND_I8) :: NTIMESTEP_ESMF -! - INTEGER(kind=KINT),DIMENSION(1:3) :: INFO_EXT_DATA -! - INTEGER,DIMENSION(MPI_STATUS_SIZE) :: JSTAT -! - REAL(kind=KFPT) :: CONST1,CONST2,CONST3,CONST4 & - ,DIST_NESTV_SOUTH_TO_PARENTV_SOUTH & - ,DT_PARENT & - ,GRID_DIST_KM & - ,REAL_I & - ,REAL_J -! - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: ARRAY_R3D -! - REAL(kind=DOUBLE) :: D2R,D_ONE,D_180,PI -! - CHARACTER(len=2) :: INT_TO_CHAR - CHARACTER(len=6) :: FMT='(I2.2)' - CHARACTER(len=5),DIMENSION(:),ALLOCATABLE :: NEST_MODE_CHILD - CHARACTER(len=19) :: PRESCRIBED_FILENAME - CHARACTER(len=99) :: FIELD_NAME -! - LOGICAL(kind=KLOG) :: DOMAIN_MOVES,OPENED -! - TYPE(COMPOSITE),POINTER :: CC -! - TYPE(ESMF_Field) :: HOLD_FIELD -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Initialize the error signal variables. -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RC_FINAL =ESMF_SUCCESS - RC_CPL_INIT=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** What is this domain's ID? -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Init1: Extract Current Domain ID" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='MY_DOMAIN_ID' & !<-- Name of the attribute to extract - ,value=MY_DOMAIN_ID & !<-- Current domain's ID - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - CALL POINT_TO_COMPOSITE(MY_DOMAIN_ID) -! - CC=>CPL_COMPOSITE(MY_DOMAIN_ID) !<-- Use dummy for shorter reference to composite -! -!----------------------------------------------------------------------- -!*** What is the total number of domains in this run? -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Total Number of Domains in P-C Coupler Init" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='NUM_DOMAINS' & !<-- Name of the attribute to extract - ,value=NUM_DOMAINS & !<-- Total number of domains - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** What is the total # of tasks on each domain? -!----------------------------------------------------------------------- -! - ALLOCATE(cc%NTASKS_DOMAIN(1:NUM_DOMAINS),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%NTASKS_DOMAIN stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - NTASKS_DOMAIN=>cc%NTASKS_DOMAIN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Total # of Tasks on Each Domain in P-C Coupler Init" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,name ='NTASKS_DOMAIN' & !<-- Name of the attribute to extract - ,itemCount=NUM_DOMAINS & !<-- # of items in the Attribute - ,valueList=NTASKS_DOMAIN & !<-- # of fcst+quilt tasks on each domain - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** How many forecast tasks on each domain? -!----------------------------------------------------------------------- -! - ALLOCATE(cc%FTASKS_DOMAIN(1:NUM_DOMAINS),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%FTASKS_DOMAIN stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - FTASKS_DOMAIN=>cc%FTASKS_DOMAIN -! - I_AM_A_FCST_TASK=>cc%I_AM_A_FCST_TASK -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Number of Fcst Tasks on Each Domain in P-C Coupler Init" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,name ='FTASKS_DOMAIN' & !<-- Name of the attribute to extract - ,itemCount=NUM_DOMAINS & !<-- # of items in the Attribute - ,valueList=FTASKS_DOMAIN & !<-- # of forecast tasks on each domain - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!------------------------------------------- -!*** Children sending 2-way data to parent -!------------------------------------------- -! - NUM_2WAY_CHILDREN=>cc%NUM_2WAY_CHILDREN - NUM_2WAY_CHILDREN=0 -! -!-------------------------------- -!*** Motion and moving children -!-------------------------------- -! - NUM_MOVING_CHILDREN=>cc%NUM_MOVING_CHILDREN - NUM_MOVING_CHILDREN=0 -! - MY_DOMAIN_MOVES=>cc%MY_DOMAIN_MOVES - MY_DOMAIN_MOVES=.FALSE. -! -!--------------------------- -!*** Domain IDs of Parents -!--------------------------- -! - ALLOCATE(cc%ID_PARENTS(1:NUM_DOMAINS),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%ID_PARENTS stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - ID_PARENTS=>cc%ID_PARENTS -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Domain IDs of Parents in Init Step Coupler" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,name ='ID_PARENTS' & !<-- Name of the attribute to extract - ,itemCount=NUM_DOMAINS & !<-- # of items in the Attribute - ,valueList=ID_PARENTS & !<-- Domain IDs of parents - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!------------------------------------------------------ -!*** Number of forecast tasks on this domain's parent -!------------------------------------------------------ -! - MY_PARENT_ID=ID_PARENTS(MY_DOMAIN_ID) !<-- Domain ID of the current domain's parent -! - NUM_TASKS_PARENT =>cc%NUM_TASKS_PARENT - NUM_FCST_TASKS_PARENT=>cc%NUM_FCST_TASKS_PARENT -! - IF(MY_PARENT_ID>0)THEN - NUM_TASKS_PARENT =NTASKS_DOMAIN(MY_PARENT_ID) !<-- Total # of fcst+quilt tasks on the parent's domain - NUM_FCST_TASKS_PARENT=FTASKS_DOMAIN(MY_PARENT_ID) !<-- # of forecast tasks on the parent's domain - ELSE - NUM_TASKS_PARENT=0 !<-- Uppermost parent has no parent - NUM_FCST_TASKS_PARENT=0 !<-- Uppermost parent has no parent - ENDIF -! -!------------------------------------------------------------- -!*** Task's local rank in its Parent-Child Intracommunicator -!------------------------------------------------------------- -! - MYPE=>CC%MYPE -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Task Rank in Domain Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='MYPE_DOMAIN' & !<-- Name of the attribute to extract - ,value=MYPE & !<-- Rank of task in Parent-Child intracomm - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------- -!*** Intracommunicator for fcst tasks on each domain -!----------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Fcst Task Intracomm in P-C Coupler Init1" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='Comm Fcst Tasks' & !<-- Name of the attribute to extract - ,value=COMM_FCST_TASKS & !<-- Intracommunicator for fcst tasks - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------- -!*** Number of fcst tasks on this domain -!----------------------------------------- -! - NUM_PES_FCST=>CC%NUM_PES_FCST -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract # of Forecast Tasks in P-C Coupler Init1" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='NUM_PES_FCST' & !<-- Name of the attribute to extract - ,value=NUM_PES_FCST & !<-- MPI communicator for this domain - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------- -!*** Fundamental Timestep on Each Domain -!----------------------------------------- -! - ALLOCATE(cc%DT_DOMAIN(1:NUM_DOMAINS),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%DT_DOMAIN stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - DT_DOMAIN=>cc%DT_DOMAIN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Timestep of Domains in P-C Coupler Init1" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,name ='DOMAIN_DTs' & !<-- Name of the attribute to extract - ,itemCount=NUM_DOMAINS & !<-- # of items in the Attribute - ,valueList=DT_DOMAIN & !<-- Timestep on each domain - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Parent tasks must know the communicators to their children. -!----------------------------------------------------------------------- -! - IF(NUM_CHILDREN>0)THEN !<-- Select parents for additional setup -! - ALLOCATE(cc%COMM_TO_MY_CHILDREN(1:NUM_CHILDREN),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%COMM_TO_MY_CHILDREN stat=',ISTAT - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) - ENDIF - COMM_TO_MY_CHILDREN=>cc%COMM_TO_MY_CHILDREN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Init1: Extract Parent-to-Child Comm in Coupler" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,name ='Parent-to-Child Comms' & !<-- Name of the attribute to extract - ,itemCount=NUM_CHILDREN & !<-- # of items in the Attribute - ,valueList=COMM_TO_MY_CHILDREN & !<-- MPI communicators to my children - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Write/quilt tasks are excluded from the grid-specific information. -!----------------------------------------------------------------------- -! - I_AM_A_FCST_TASK=>cc%I_AM_A_FCST_TASK -! - IF(.NOT.I_AM_A_FCST_TASK)RETURN -! -!--------------------------------------------- -!*** The Tasks' Subdomain Integration Limits -!--------------------------------------------- -! - ITS=>cc%ITS - ITE=>cc%ITE - JTS=>cc%JTS - JTE=>cc%JTE - LM =>cc%LM -! - NHALO=>cc%NHALO -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Integration Subdomain Limits in Parent-Child Coupler" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='ITS' & !<-- Name of the attribute to extract - ,value=ITS & !<-- This task's integration limit: Starting I - ,rc =RC) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='ITE' & !<-- Name of the attribute to extract - ,value=ITE & !<-- This task's integration limit: Ending I - ,rc =RC) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='JTS' & !<-- Name of the attribute to extract - ,value=JTS & !<-- This task's integration limit: Starting J - ,rc =RC) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='JTE' & !<-- Name of the attribute to extract - ,value=JTE & !<-- This task's integration limit: Ending J - ,rc =RC) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='LM' & !<-- Name of the attribute to extract - ,value=LM & !<-- This task's integration limit: # of layers in vertical - ,rc =RC) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='NHALO' & !<-- Name of the attribute to extract - ,value=NHALO & !<-- Width of the task subdomain haloes - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IMS=>cc%IMS - IME=>cc%IME - JMS=>cc%JMS - JME=>cc%JME -! - IMS=ITS-NHALO - IME=ITE+NHALO - JMS=JTS-NHALO - JME=JTE+NHALO -! -!----------------------------------------------------- -!*** Index Limits of All Forecast Tasks on My Domain -!----------------------------------------------------- -! - ALLOCATE(cc%LOCAL_ISTART(1:FTASKS_DOMAIN(MY_DOMAIN_ID)),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate LOCAL_ISTART for MY_DOMAIN_ID=',MY_DOMAIN_ID,' stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - ALLOCATE(cc%LOCAL_IEND (1:FTASKS_DOMAIN(MY_DOMAIN_ID))) - ALLOCATE(cc%LOCAL_JSTART(1:FTASKS_DOMAIN(MY_DOMAIN_ID))) - ALLOCATE(cc%LOCAL_JEND (1:FTASKS_DOMAIN(MY_DOMAIN_ID))) -! - LOCAL_ISTART=>cc%LOCAL_ISTART - LOCAL_IEND =>cc%LOCAL_IEND - LOCAL_JSTART=>cc%LOCAL_JSTART - LOCAL_JEND =>cc%LOCAL_JEND -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Index Limits of Fcst Tasks on My Domain in Init Step Coupler" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,name ='LOCAL ISTART' & !<-- Name of the attribute to extract - ,itemCount=FTASKS_DOMAIN(MY_DOMAIN_ID) & !<-- # of items in the Attribute - ,valueList=LOCAL_ISTART & !<-- Starting I's of fcst tasks on my domain - ,rc =RC) -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,name ='LOCAL IEND' & !<-- Name of the attribute to extract - ,itemCount=FTASKS_DOMAIN(MY_DOMAIN_ID) & !<-- # of items in the Attribute - ,valueList=LOCAL_IEND & !<-- Ending I's of fcst tasks on my domain - ,rc =RC) -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,name ='LOCAL JSTART' & !<-- Name of the attribute to extract - ,itemCount=FTASKS_DOMAIN(MY_DOMAIN_ID) & !<-- # of items in the Attribute - ,valueList=LOCAL_JSTART & !<-- Starting J's of fcst tasks on my domain - ,rc =RC) -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,name ='LOCAL JEND' & !<-- Name of the attribute to extract - ,itemCount=FTASKS_DOMAIN(MY_DOMAIN_ID) & !<-- # of items in the Attribute - ,valueList=LOCAL_JEND & !<-- Ending J's of fcst tasks on my domain - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!-------------------------------- -!*** The Full Domain Dimensions -!-------------------------------- -! - IDS=>cc%IDS - IDE=>cc%IDE - JDS=>cc%JDS - JDE=>cc%JDE -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Full Domain Dimensions in Parent-Child Coupler" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='IDS' & !<-- Name of the attribute to extract - ,value=IDS & !<-- This task's integration limit: Starting I - ,rc =RC) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='IDE' & !<-- Name of the attribute to extract - ,value=IDE & !<-- This task's integration limit: Ending I - ,rc =RC) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='JDS' & !<-- Name of the attribute to extract - ,value=JDS & !<-- This task's integration limit: Starting J - ,rc =RC) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='JDE' & !<-- Name of the attribute to extract - ,value=JDE & !<-- This task's integration limit: Ending J - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!------------------------------------------------ -!*** The Widths of the Boundary Blending Region -!------------------------------------------------ -! - N_BLEND_H=>cc%N_BLEND_H - N_BLEND_V=>cc%N_BLEND_V -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Widths of Bndry Blending Region in Parent-Child Coupler" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='N_BLEND_H' & !<-- Name of the attribute to extract - ,value=N_BLEND_H & !<-- # of boundary blending rows for H points - ,rc =RC) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='N_BLEND_V' & !<-- Name of the attribute to extract - ,value=N_BLEND_V & !<-- # of boundary blending rows for V points - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(N_BLEND_V>N_BLEND_H)THEN - WRITE(0,*)' N_BLEND_V CANNOT EXCEED N_BLEND_H DUE TO PD AVERAGING!!!' - WRITE(0,*)' ABORTING' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! -!-------------------------------------- -!*** Each forecast task's 8 neighbors -!-------------------------------------- -! - MY_NEB=>cc%MY_NEB -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,name ='MY_NEB' & !<-- Name of the attribute to extract - ,itemCount=N8 & !<-- # of items in the Attribute - ,valueList=MY_NEB & !<-- This task's eight neighbors - ,rc =RC) -! -!------------------------------------ -!*** The frequency of physics calls -!------------------------------------ -! - NPHS=>cc%NPHS -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract NPHS in Parent-Child Coupler" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='NPHS' & !<-- Name of the attribute to extract - ,value=NPHS & !<-- The frequency of physics calls - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Unload some key prognostic data from the import state that are -!*** needed inside the Parent-Child coupler and point at those data -!*** (located in the Solver internal state) appropriate for the -!*** current domain. -!----------------------------------------------------------------------- -! -!-------- -!*** PD -!-------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract PD Field from Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,itemName='PD' & !<-- Extract PD - ,field =HOLD_FIELD & !<-- Put the extracted Field here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract PD from ESMF Field in Parent-Child Coupler" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer - ,localDe =0 & - ,farrayPtr=PD & !<-- Put the pointer here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - cc%PD=>PD -! -!------------------------------- -!*** Layer Interface Pressures -!------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract PINT from Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,itemName='PINT' & !<-- Extract layer interface pressures - ,field =HOLD_FIELD & !<-- Put the extracted Field here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract PINT from ESMF Field in Parent-Child Coupler" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer - ,localDe =0 & - ,farrayPtr=PINT & !<-- Put the pointer here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - cc%PINT=>PINT -! -!----------------- -!*** Temperature -!----------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract T Field from Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,itemName='T' & !<-- Extract temperature - ,field =HOLD_FIELD & !<-- Put the extracted Field here - ,rc =RC) - -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract T from ESMF Field in Parent-Child Coupler" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer - ,localDe =0 & - ,farrayPtr=T & !<-- Put the pointer here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - cc%T=>T -! -!------------ -!*** U Wind -!------------ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract U Field from Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,itemName='U' & !<-- Extract U wind - ,field =HOLD_FIELD & !<-- Put the extracted Field here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract U from ESMF Field in Parent-Child Coupler" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer - ,localDe =0 & - ,farrayPtr=U & !<-- Put the pointer here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - cc%U=>U -! -!------------ -!*** V Wind -!------------ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract V Field from Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,itemName='V' & !<-- Extract V wind - ,field =HOLD_FIELD & !<-- Put the extracted Field here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract V from ESMF Field in Parent-Child Coupler" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer - ,localDe =0 & - ,farrayPtr=V & !<-- Put the pointer here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - cc%V=>V -! -!---------------- -!*** Modlayer Z -!---------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Midlayer Z Field from P-C Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,itemName='Z' & !<-- Extract midlayer Z - ,field =HOLD_FIELD & !<-- Put the extracted Field here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Midlayer Z from ESMF Field in Parent-Child Coupler" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer - ,localDe =0 & - ,farrayPtr=Z & !<-- Put the pointer here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - cc%Z=>Z -! -!---------------------------------- -!*** 10-m U component of the wind -!---------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract 10-m U Field from Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,itemName='U10' & !<-- Extract 10-m U wind component - ,field =HOLD_FIELD & !<-- Put the extracted Field here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract 10-m U from ESMF Field in Parent-Child Coupler" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer - ,localDe =0 & - ,farrayPtr=U10 & !<-- Put the pointer here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - cc%U10=>U10 -! -!---------------------------------- -!*** 10-m V component of the wind -!---------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract 10-m V Field from Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,itemName='V10' & !<-- Extract 10-m V wind component - ,field =HOLD_FIELD & !<-- Put the extracted Field here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract 10-m V from ESMF Field in Parent-Child Coupler" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer - ,localDe =0 & - ,farrayPtr=V10 & !<-- Put the pointer here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - cc%V10=>V10 -! -!------------- -!*** Tracers -!------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Tracers Field from Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,itemName='TRACERS' & !<-- Extract tracers - ,field =HOLD_FIELD & !<-- Put the extracted Field here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Tracers from ESMF Field in Parent-Child Coupler" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer - ,localDe =0 & - ,farrayPtr=TRACERS & !<-- Put the pointer here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - cc%TRACERS=>TRACERS -! -!---------------------- -!*** Sfc Geopotential -!---------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract FIS Field from Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,itemName='FIS' & !<-- Extract sfc geopotential - ,field =HOLD_FIELD & !<-- Put the extracted Field here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract FIS from ESMF Field in Parent-Child Coupler" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer - ,localDe =0 & - ,farrayPtr=FIS & !<-- Put the pointer here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - cc%FIS=>FIS -! -!-------------- -!*** Sea Mask -!-------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Sea Mask from Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,itemName='SM' & !<-- Extract sea mask - ,field =HOLD_FIELD & !<-- Put the extracted Field here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract SM from ESMF Field in Parent-Child Coupler" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer - ,localDe =0 & - ,farrayPtr=SM & !<-- Put the pointer here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - cc%SM=>SM -! -!------------------------- -!*** Geographic latitude -!------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract GLAT Field from Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,itemName='GLAT' & !<-- Extract geographic latitude - ,field =HOLD_FIELD & !<-- Put the extracted Field here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract GLAT from ESMF Field in Parent-Child Coupler" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer - ,localDe =0 & - ,farrayPtr=cc%GLAT & !<-- Put the pointer here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!-------------------------- -!*** Geographic longitude -!-------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract GLON Field from Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,itemName='GLON' & !<-- Extract geographic longitude - ,field =HOLD_FIELD & !<-- Put the extracted Field here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract GLON from ESMF Field in Parent-Child Coupler" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer - ,localDe =0 & - ,farrayPtr=cc%GLON & !<-- Put the pointer here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!---------------------------------------------- -!*** PT,PDTOP,PSGML1,SG1,SG2,SGML2,DSG2,PDSG1 -!---------------------------------------------- -! - PT=>cc%PT - PDTOP=>cc%PDTOP -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract PT from Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='PT' & !<-- Extract PT - ,value=PT & !<-- Put the extracted Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract PDTOP from Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='PDTOP' & !<-- Extract PDTOP - ,value=PDTOP & !<-- Put the extracted Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ALLOCATE(CC%PSGML1(1:LM),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%PSGML1 stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - PSGML1=>cc%PSGML1 -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract PSGML1 from Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,name ='PSGML1' & !<-- Name of Attribute to extract - ,itemCount=LM & !<-- # of words in data list - ,valueList=PSGML1 & !<-- Put the extracted Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - LMP1=LM+1 - ALLOCATE(cc%SG1(1:LMP1),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%SG1 stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - SG1=>cc%SG1 -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract SG1 from Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,name ='SG1' & !<-- Name of Attribute to extract - ,itemCount=LMP1 & !<-- # of words in data list - ,valueList=SG1 & !<-- Put the extracted Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ALLOCATE(CC%SG2(1:LMP1),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%SG2 stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - SG2=>cc%SG2 -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract SG2 from Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,name ='SG2' & !<-- Name of Attribute to extract - ,itemCount=LMP1 & !<-- # of words in data list - ,valueList=SG2 & !<-- Put the extracted Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ALLOCATE(CC%SGML2(1:LM),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%SGML2 stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - SGML2=>cc%SGML2 -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract SGML2 from Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,name ='SGML2' & !<-- Name of Attribute to extract - ,itemCount=LM & !<-- # of words in data list - ,valueList=SGML2 & !<-- Put the extracted Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ALLOCATE(CC%DSG2(1:LM),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%DSG2 stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - DSG2=>cc%DSG2 -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract DSG2 from Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,name ='DSG2' & !<-- Extract DSG2 - ,itemCount=LM & !<-- # of words in data list - ,valueList=DSG2 & !<-- Put the extracted Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ALLOCATE(CC%PDSG1(1:LM),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%PDSG1 stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - PDSG1=>cc%PDSG1 -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract PDSG1 from Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,name ='PDSG1' & !<-- Extract PDSG1 - ,itemCount=LM & !<-- # of words in data list - ,valueList=PDSG1 & !<-- Put the extracted Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!------------- -!*** DYH,DXH -!------------- -! - DYH=>cc%DYH -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract DYH from Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='DYH' & !<-- Extract DYH - ,value=DYH & !<-- Put the extracted Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ALLOCATE(CC%DXH(JDS:JDE),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%DXH stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - DXH=>cc%DXH -! - NKOUNT=JDE-JDS+1 -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract DXH from Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,name ='DXH' & !<-- Name of Attribute to extract - ,itemCount=NKOUNT & !<-- # of words in data list - ,valueList=DXH & !<-- Put the extracted Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!------------------ -!*** DPHD,DLMD,JM -!------------------ -! - DLM=>cc%DLM - DPH=>cc%DPH - JM=>cc%JM -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~~~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract DPHD,DLMD from Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~~~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='DLMD' & !<-- Extract grid's longitude increment (deg) - ,value=DLM & !<-- Put the extracted Attribute here - ,rc =RC) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='DPHD' & !<-- Extract grid's latitude increment (deg) - ,value=DPH & !<-- Put the extracted Attribute here - ,rc =RC) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='JM' & !<-- Extract J extent of domain - ,value=JM & !<-- Put the extracted Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - D_ONE=1. - D_180=180. - PI=DACOS(-D_ONE) - D2R=PI/D_180 -! - DLM=DLM*D2R !<-- Convert from degrees to radians - DPH=DPH*D2R !<-- Convert from degrees to radians -! -!------------ -!*** INDX_Q -!------------ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract INDX_Q from Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='INDX_Q' & !<-- Name of Attribute to extract - ,value=INDX_Q & !<-- Put the extracted Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!------------- -!*** INDX_CW -!------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract INDX_CW from Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='INDX_CW' & !<-- Name of Attribute to extract - ,value=INDX_CW & !<-- Put the extracted Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - cc%Q=>TRACERS(IMS:IME,JMS:JME,1:LM,INDX_Q) - cc%CW=>TRACERS(IMS:IME,JMS:JME,1:LM,INDX_CW) -! -!----------------------------------------------------------------------- -!*** Extract the Bundles holding pointers to nest boundary variables -!*** updated by the parents (used in all nesting) and to 2-way -!*** variables updated by the child on the parent (if indeed 2-way -!*** nesting is invoked). Since the Fields in these Bundles will be -!*** accessed via looping through the Bundles then we need to know -!*** how many total Fields are present as well as specifically how -!*** many are on H points and on V points. -!----------------------------------------------------------------------- -! - IF(I_AM_A_FCST_TASK)THEN -! -!----------------------------------------------------------------------- -!*** Begin with the Bundle of pointers to the variables specified -!*** by the user that are to be updated on the nest boundaries. -!*** In addition to the total number of such variables, we need -!*** to know how many of them are on H points and how many are -!*** on V points. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Nest BC Bundle in P-C Init" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =IMP_STATE & !<-- The Parent-Child coupler import state - ,itemname ='Bundle_nestbc' & !<-- Name of Bundle of nest BC internal state arrays to use - ,fieldbundle=BUNDLE_NESTBC & !<-- The ESMF nest BC Bundle - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="How many Fields in the Nest BC Bundle?" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=BUNDLE_NESTBC & !<-- The ESMF Bundle of 2-way exchange variables - ,fieldcount =NVARS_NESTBC & !<-- # of Fields in the Bundle - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NLEV_H=>cc%NLEV_H - NLEV_V=>cc%NLEV_V -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract # of Model Lyrs for all Nest BC Variables" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='NLEV_H' & !<-- Name of Attribute to extract - ,value=NLEV_H & !<-- # of model lyrs for all BC H-pt variables - ,rc =RC) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='NLEV_V' & !<-- Name of Attribute to extract - ,value=NLEV_V & !<-- # of model lyrs for all BC H-pt variables - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NVARS_BC_2D_H=>cc%NVARS_BC_2D_H - NVARS_BC_3D_H=>cc%NVARS_BC_3D_H - NVARS_BC_4D_H=>cc%NVARS_BC_4D_H -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract # of H-pt Nest BC Variables from P-C Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='NVARS_BC_2D_H' & !<-- Name of Attribute to extract - ,value=NVARS_BC_2D_H & !<-- # of 2-D H-pt boundary variables - ,rc =RC) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='NVARS_BC_3D_H' & !<-- Name of Attribute to extract - ,value=NVARS_BC_3D_H & !<-- # of 3-D H-pt boundary variables - ,rc =RC) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='NVARS_BC_4D_H' & !<-- Name of Attribute to extract - ,value=NVARS_BC_4D_H & !<-- # of 4-D H-pt boundary variables - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NVARS_BC_2D_V=>cc%NVARS_BC_2D_V - NVARS_BC_3D_V=>cc%NVARS_BC_3D_V -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract # of V-pt Nest BC Variables from P-C Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='NVARS_BC_2D_V' & !<-- Name of Attribute to extract - ,value=NVARS_BC_2D_V & !<-- # of 2-D V-pt boundary variables - ,rc =RC) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='NVARS_BC_3D_V' & !<-- Name of Attribute to extract - ,value=NVARS_BC_3D_V & !<-- # of 3-D V-pt boundary variables - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NVARS_NESTBC_H=NVARS_BC_2D_H+NVARS_BC_3D_H+NVARS_BC_4D_H - NVARS_NESTBC_V=NVARS_BC_2D_V+NVARS_BC_3D_V -! - IF(.NOT.ALLOCATED(NBASE_VAR_H))THEN - ALLOCATE(NBASE_VAR_H(1:NVARS_NESTBC_H-1)) - ENDIF -! - IF(.NOT.ALLOCATED(NBASE_VAR_V))THEN - ALLOCATE(NBASE_VAR_V(1:NVARS_NESTBC_V)) - ENDIF -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Allocate the objects that hold the boundary values for arrays -!*** of various dimensions. While it is certain there will be 2-D -!*** H-pt variables (PD) and 3-D H-pt and V-pt variables (T,Q,U,V) -!*** there may not be 4-D H-pt or 2-D V-pt variables so account for -!*** the possible lack of those. -!----------------------------------------------------------------------- -! - ALLOCATE(cc%MY_BC_VARS_H_S%VAR_2D(1:NVARS_BC_2D_H)) - ALLOCATE(cc%MY_BC_VARS_H_N%VAR_2D(1:NVARS_BC_2D_H)) - ALLOCATE(cc%MY_BC_VARS_H_W%VAR_2D(1:NVARS_BC_2D_H)) - ALLOCATE(cc%MY_BC_VARS_H_E%VAR_2D(1:NVARS_BC_2D_H)) -! - ALLOCATE(cc%MY_BC_VARS_H_S%VAR_3D(1:NVARS_BC_3D_H)) - ALLOCATE(cc%MY_BC_VARS_H_N%VAR_3D(1:NVARS_BC_3D_H)) - ALLOCATE(cc%MY_BC_VARS_H_W%VAR_3D(1:NVARS_BC_3D_H)) - ALLOCATE(cc%MY_BC_VARS_H_E%VAR_3D(1:NVARS_BC_3D_H)) -! - IF(NVARS_BC_4D_H==0)THEN - ALLOCATE(cc%MY_BC_VARS_H_S%VAR_4D(-1:-1)) - ALLOCATE(cc%MY_BC_VARS_H_N%VAR_4D(-1:-1)) - ALLOCATE(cc%MY_BC_VARS_H_W%VAR_4D(-1:-1)) - ALLOCATE(cc%MY_BC_VARS_H_E%VAR_4D(-1:-1)) - ELSEIF(NVARS_BC_4D_H>0)THEN - ALLOCATE(cc%MY_BC_VARS_H_S%VAR_4D(1:NVARS_BC_4D_H)) - ALLOCATE(cc%MY_BC_VARS_H_N%VAR_4D(1:NVARS_BC_4D_H)) - ALLOCATE(cc%MY_BC_VARS_H_W%VAR_4D(1:NVARS_BC_4D_H)) - ALLOCATE(cc%MY_BC_VARS_H_E%VAR_4D(1:NVARS_BC_4D_H)) - ENDIF -! - IF(NVARS_BC_2D_V==0)THEN - ALLOCATE(cc%MY_BC_VARS_V_S%VAR_2D(-1:-1)) - ALLOCATE(cc%MY_BC_VARS_V_N%VAR_2D(-1:-1)) - ALLOCATE(cc%MY_BC_VARS_V_W%VAR_2D(-1:-1)) - ALLOCATE(cc%MY_BC_VARS_V_E%VAR_2D(-1:-1)) - ELSEIF(NVARS_BC_2D_V>0)THEN - ALLOCATE(cc%MY_BC_VARS_V_S%VAR_2D(1:NVARS_BC_2D_V)) - ALLOCATE(cc%MY_BC_VARS_V_N%VAR_2D(1:NVARS_BC_2D_V)) - ALLOCATE(cc%MY_BC_VARS_V_W%VAR_2D(1:NVARS_BC_2D_V)) - ALLOCATE(cc%MY_BC_VARS_V_E%VAR_2D(1:NVARS_BC_2D_V)) - ENDIF -! - ALLOCATE(cc%MY_BC_VARS_V_S%VAR_3D(1:NVARS_BC_3D_V)) - ALLOCATE(cc%MY_BC_VARS_V_N%VAR_3D(1:NVARS_BC_3D_V)) - ALLOCATE(cc%MY_BC_VARS_V_W%VAR_3D(1:NVARS_BC_3D_V)) - ALLOCATE(cc%MY_BC_VARS_V_E%VAR_3D(1:NVARS_BC_3D_V)) -! -!----------------------------------------------------------------------- -!*** Extract the lower and upper bounds of each of the 4-D H-pt -!*** boundary variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_4D_H==0)THEN -! - ALLOCATE(cc%LBND_4D(1:1)) - ALLOCATE(cc%UBND_4D(1:1)) -! - cc%LBND_4D(1)=-1 - cc%UBND_4D(1)=-1 -! - ELSEIF(NVARS_BC_4D_H>0)THEN -! - ALLOCATE(cc%LBND_4D(1:NVARS_BC_4D_H)) - ALLOCATE(cc%UBND_4D(1:NVARS_BC_4D_H)) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Lower Bounds of 4-D Bndry Vbls" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,name ='LBND_4D' & !<-- Extract Attribute with this name - ,itemCount=NVARS_BC_4D_H & !<-- How many items? - ,valueList=cc%LBND_4D & !<-- Lower bounds of 4-D H-pt bndry vbls - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Upper Bounds of 4-D Bndry Vbls" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,name ='UBND_4D' & !<-- Extract Attribute with this name - ,itemCount=NVARS_BC_4D_H & !<-- How many items? - ,valueList=cc%UBND_4D & !<-- Upper bounds of 4-D H-pt bndry vbls - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! -!----------------------------------------------------------------------- -! - IF(NVARS_NESTBC/=NVARS_BC_2D_H+NVARS_BC_3D_H+NVARS_BC_4D_H & - +NVARS_BC_2D_V+NVARS_BC_3D_V)THEN - WRITE(0,22001)NVARS_NESTBC -22001 FORMAT(' Total # of variables in nest BC Bundle is ',I4) - WRITE(0,22002)NVARS_BC_2D_H+NVARS_BC_3D_H+NVARS_BC_4D_H -22002 FORMAT(' # of H-pt nest BC variables is ',I4) - WRITE(0,22002)NVARS_BC_2D_V+NVARS_BC_3D_V -22003 FORMAT(' # of V-pt nest BC variables is ',I4) - WRITE(0,22004) -22004 FORMAT(' They do not add up so ABORT!!') - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT & - ,rc =RC) - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract the mode of nesting, i.e., 1-way or 2-way. Use the -!*** configure file of domain #1 where the variable is required. -!----------------------------------------------------------------------- -! - CF_1=ESMF_ConfigCreate(rc=RC) -! - CONFIG_FILE_NAME='configure_file_01' !<-- Config file name of uppermost parent -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Configure Object of Upper Domain in P-C Cpl Init1" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigLoadFile(config =CF_1 & - ,filename=CONFIG_FILE_NAME & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Init1: Extract Nesting Mode from Config File 1" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF_1 & !<-- The config object for the uppermost domain - ,value =NEST_MODE & !<-- The mode of nesting ('1-way' or '2-way') - ,label ='nest_mode:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -!----------------------------------------------------------------------- -!*** Tasks load their domain's configure file. -!----------------------------------------------------------------------- -! - CONFIG_ID=DOMAIN_ID_TO_RANK(MY_DOMAIN_ID) - WRITE(INT_TO_CHAR,FMT)CONFIG_ID - CONFIG_FILE_NAME='configure_file_'//INT_TO_CHAR !<-- Prepare the config file name -! - CF_MINE=>cc%CF_MINE -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Parent-Child Init: Domain Loads Its Configure File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigLoadFile(config =CF_MINE & - ,filename=CONFIG_FILE_NAME & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Children need to save the ratio of their parent's timestep and -!*** grid increment to their own. The timestep ratio MUST be an -!*** integer and for now so must the space ratio. -!*** Then obtain the parent I,J of the nest's SW corner. -!----------------------------------------------------------------------- -! - child_block: IF(MY_DOMAIN_ID>1)THEN !<-- Select the children -! -!----------------------------------------------------------------------- -! - DT_PARENT=DT_DOMAIN(ID_PARENTS(MY_DOMAIN_ID)) -! - TIME_RATIO_MY_PARENT=>cc%TIME_RATIO_MY_PARENT - TIME_RATIO_MY_PARENT=NINT(DT_PARENT/DT_DOMAIN(MY_DOMAIN_ID)) !<-- Ratio of my parent's timestep to mine -! -!----------------------------------------------------------------------- -!*** In order to allow moving nests to be updated their tasks need -!*** to know their domain's forecast task layout as well as that of -!*** their parents. Likewise the parents of moving nests need to -!*** know the forecast task layout of their moving children. For -!*** simplicity we will provide that information to all domain tasks -!*** now. -!*** The SW corner location of the nests is read from the configure -!*** files for regular forecasts but must come from the restart -!*** file data for restarted runs. -!----------------------------------------------------------------------- -! - SPACE_RATIO_MY_PARENT=>cc%SPACE_RATIO_MY_PARENT -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Parent-Child Init: Child Gets Space Ratio" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF_MINE & !<-- The child's config object - ,value =SPACE_RATIO_MY_PARENT & !<-- The variable filled (Parent-to-child space ratio) - ,label ='parent_child_space_ratio:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - cc%RECIP_PARENT_SPACE_RATIO=1./REAL(SPACE_RATIO_MY_PARENT) -! -!----------------------------------------------------------------------- -! - INPES=>cc%INPES - JNPES=>cc%JNPES -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Parent-Child Init: Child Gets INPES,JNPES" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF_MINE & !<-- The child's config object - ,value =INPES & !<-- The variable filled (fcst tasks in I direction) - ,label ='inpes:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF_MINE & !<-- The child's config object - ,value =JNPES & !<-- The variable filled (fcst tasks in J direction) - ,label ='jnpes:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Task 0 on each child receives the domain index limits of their -!*** parents then braodcasts them to the other child tasks. -!*** Task 0 on each child then receives the integration limits of -!*** their parents' forecast tasks and broadcasts that information to -!*** the remaining child tasks. -!*** Also each child task needs to allocate the derived type that will -!*** hold: (i) Which parent task(s) will send boundary data to it; -!*** (ii) The grid index limits on the child boundary covered by -!*** the parent task's data the child will receive. Then it receives -!*** those pieces of information from the parent. -!----------------------------------------------------------------------- -! - MY_PARENT_ID=ID_PARENTS(MY_DOMAIN_ID) !<-- Domain ID of the current domain's parent -! -!----------------------------------------------------------------------- -! - NUM_FCST_TASKS_PARENT=FTASKS_DOMAIN(MY_PARENT_ID) !<-- # of forecast tasks on the parent's domain -! - ALLOCATE(PTASK_LIMITS(MY_DOMAIN_ID)%ITS(0:NUM_FCST_TASKS_PARENT-1)) !<-- Task subdomain limits for current domain's parent - ALLOCATE(PTASK_LIMITS(MY_DOMAIN_ID)%ITE(0:NUM_FCST_TASKS_PARENT-1)) ! - ALLOCATE(PTASK_LIMITS(MY_DOMAIN_ID)%JTS(0:NUM_FCST_TASKS_PARENT-1)) ! - ALLOCATE(PTASK_LIMITS(MY_DOMAIN_ID)%JTE(0:NUM_FCST_TASKS_PARENT-1)) !<-- -! - DO N=0,NUM_FCST_TASKS_PARENT-1 - PTASK_LIMITS(MY_DOMAIN_ID)%ITS(N)=-9999 - PTASK_LIMITS(MY_DOMAIN_ID)%ITE(N)=-9999 - PTASK_LIMITS(MY_DOMAIN_ID)%JTS(N)=-9999 - PTASK_LIMITS(MY_DOMAIN_ID)%JTE(N)=-9999 - ENDDO -! - CALL MPI_BARRIER(COMM_FCST_TASKS,IERR) !<-- Syncs all child fcst tasks on this domain -! -!----------------------------------------------------------------------- -!*** Child task 0 recvs its parent's domain limits and task subdomain -!*** limits from parent task 0. -!----------------------------------------------------------------------- -! - IF(I_AM_LEAD_FCST_TASK)THEN -! - NTAG=MY_DOMAIN_ID*111+1 - CALL MPI_RECV(cc%PARENT_DOMAIN_LIMITS & !<-- This domain's parent's domain index limits - ,4 & !<-- Total words received - ,MPI_INTEGER & !<-- Indices are integers - ,0 & !<-- Receive from this parent task - ,NTAG & !<-- Unique MPI tag - ,COMM_TO_MY_PARENT & !<-- The MPI communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - CALL MPI_RECV(PTASK_LIMITS(MY_DOMAIN_ID)%ITS & !<-- Starting I on each parent forecast task's subdomain - ,NUM_FCST_TASKS_PARENT & !<-- Total words received - ,MPI_INTEGER & !<-- Indices are integers - ,0 & !<-- Receive from this parent task - ,NTAG & !<-- Unique MPI tag - ,COMM_TO_MY_PARENT & !<-- The MPI communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - NTAG=NTAG+1 - CALL MPI_RECV(PTASK_LIMITS(MY_DOMAIN_ID)%JTS & !<-- Starting J on each parent forecast task's subdomain - ,NUM_FCST_TASKS_PARENT & !<-- Total words received - ,MPI_INTEGER & !<-- Indices are integers - ,0 & !<-- Receive from this parent task - ,NTAG & !<-- Unique MPI tag - ,COMM_TO_MY_PARENT & !<-- The MPI communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - NTAG=NTAG+1 - CALL MPI_RECV(PTASK_LIMITS(MY_DOMAIN_ID)%ITE & !<-- Ending I on each parent forecast task's subdomain - ,NUM_FCST_TASKS_PARENT & !<-- Total words received - ,MPI_INTEGER & !<-- Indices are integers - ,0 & !<-- Receive from this parent task - ,NTAG & !<-- Unique MPI tag - ,COMM_TO_MY_PARENT & !<-- The MPI communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - NTAG=NTAG+1 - CALL MPI_RECV(PTASK_LIMITS(MY_DOMAIN_ID)%JTE & !<-- Ending J on each parent forecast task's subdomain - ,NUM_FCST_TASKS_PARENT & !<-- Total words received - ,MPI_INTEGER & !<-- Indices are integers - ,0 & !<-- Receive from this parent task - ,NTAG & !<-- Unique MPI tag - ,COMM_TO_MY_PARENT & !<-- The MPI communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - ENDIF -! -!----------------------------------------------------------------------- -!*** The lead child task sends the parent's domain limits and -!*** task subdomain limits to all the other child forecast tasks. -!----------------------------------------------------------------------- -! - CALL MPI_BCAST(cc%PARENT_DOMAIN_LIMITS & !<-- This domain's parent's domain index limits - ,4 & !<-- There are 4 index limits - ,MPI_INTEGER & !<-- Data are integers - ,0 & !<-- Data sent from child task 0 - ,COMM_FCST_TASKS & !<-- Intracommunicator for fcst tasks - ,IERR ) -! - CALL MPI_BCAST(PTASK_LIMITS(MY_DOMAIN_ID)%ITS & !<-- Starting I indices for parent subdomains - ,NUM_FCST_TASKS_PARENT & !<-- # of words in the data - ,MPI_INTEGER & !<-- Data are integers - ,0 & !<-- Data sent from child task 0 - ,COMM_FCST_TASKS & !<-- Intracommunicator for fcst tasks - ,IERR ) -! - CALL MPI_BCAST(PTASK_LIMITS(MY_DOMAIN_ID)%ITE & !<-- Ending I indices for parent subdomains - ,NUM_FCST_TASKS_PARENT & !<-- # of words in the data - ,MPI_INTEGER & !<-- Data are integers - ,0 & !<-- Data sent from child task 0 - ,COMM_FCST_TASKS & !<-- Intracommunicator for fcst tasks - ,IERR ) -! - CALL MPI_BCAST(PTASK_LIMITS(MY_DOMAIN_ID)%JTS & !<-- Starting J indices for parent subdomains - ,NUM_FCST_TASKS_PARENT & !<-- # of words in the data - ,MPI_INTEGER & !<-- Data are integers - ,0 & !<-- Data sent from child task 0 - ,COMM_FCST_TASKS & !<-- Intracommunicator for fcst tasks - ,IERR ) -! - CALL MPI_BCAST(PTASK_LIMITS(MY_DOMAIN_ID)%JTE & !<-- Ending J indices for parent subdomains - ,NUM_FCST_TASKS_PARENT & !<-- # of words in the data - ,MPI_INTEGER & !<-- Data are integers - ,0 & !<-- Data sent from child task 0 - ,COMM_FCST_TASKS & !<-- Intracommunicator for fcst tasks - ,IERR ) -! -!----------------------------------------------------------------------- -!*** Children receive from their parents basic bookkeeping information -!*** needed for the exchange of boundary data during the integration. -!----------------------------------------------------------------------- -! - MY_PARENT_ID=ID_PARENTS(MY_DOMAIN_ID) !<-- Domain ID of the current domain's parent - ALLOCATE(CC%PARENT_TASK(1:FTASKS_DOMAIN(MY_PARENT_ID))) !<-- Dimensioned as # of fcst tasks on domain of parent. -! - CALL CHILD_RECVS_CHILD_DATA_LIMITS(EXP_STATE,MY_DOMAIN_ID) !<-- Recv specs of new parent/child task associations -! -!----------------------------------------------------------------------- -!*** All the children send to their parents their boundary -!*** topography so that the parents can properly balance the data -!*** generated for the children's boundaries. For moving nests -!*** these are only initial values that will change when the nests -!*** move. -!----------------------------------------------------------------------- -! - CALL CHILD_SENDS_TOPO_TO_PARENT(MY_DOMAIN_ID,IMP_STATE) -! -!----------------------------------------------------------------------- -!*** Children are going to need some information from their -!*** parents' configure files so load those objects into memory. -!----------------------------------------------------------------------- -! - MY_PARENT_ID=ID_PARENTS(MY_DOMAIN_ID) - CONFIG_ID=DOMAIN_ID_TO_RANK(MY_PARENT_ID) - WRITE(INT_TO_CHAR,FMT)CONFIG_ID - CONFIG_FILE_NAME='configure_file_'//INT_TO_CHAR !<-- Prepare the parent's config file name -! - cc%CF_PARENT=ESMF_ConfigCreate(rc=RC) - CF_PARENT=>cc%CF_PARENT -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Parent-Child Init1: Nest Loads Parent Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigLoadFile(config =CF_PARENT & - ,filename=CONFIG_FILE_NAME & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** What is the parent's layout of forecast tasks? -!----------------------------------------------------------------------- -! - INPES_PARENT=>cc%INPES_PARENT - JNPES_PARENT=>cc%JNPES_PARENT -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Parent-Child Init1: Child Gets Parent INPES,JNPES" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF_PARENT & !<-- The parent's config object - ,value =INPES_PARENT & !<-- The variable filled (fcst tasks in I direction) - ,label ='inpes:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF_PARENT & !<-- The parent's config object - ,value =JNPES_PARENT & !<-- The variable filled (fcst tasks in J direction) - ,label ='jnpes:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** If this child moves then some additional information is gathered. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Move Flag from Nest's Configure File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF_MINE & !<-- The child's config object - ,value =MY_DOMAIN_MOVES & !<-- The variable filled (Move flag) - ,label ='my_domain_moves:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Moving nests must know if their parents move. -!----------------------------------------------------------------------- -! - MY_PARENT_MOVES=>cc%MY_PARENT_MOVES - MY_PARENT_MOVES=.FALSE. -! - IF(MY_DOMAIN_MOVES)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Parent-Child Init: Nest Checks If Parent Moves" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF_PARENT & !<-- The parent's config object - ,value =MY_PARENT_MOVES & !<-- The variable filled (does the parent move?) - ,label ='my_domain_moves:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(MY_PARENT_MOVES)THEN - cc%FORCED_PARENT_SHIFT=.FALSE. - ENDIF -! - DO N=1,3 - cc%PARENT_SHIFT(N)=-999 - ENDDO -! -!----------------------------------------------------------------------- -!*** Since the nests can only move on parent timesteps and -!*** are allowed to move only on physics timesteps then -!*** warn the user if the Parent timestep ratio does not -!*** divide evenly into the nest's physics frequency. -!----------------------------------------------------------------------- -! - NPHS=>cc%NPHS -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Parent-Child Init: Child Gets NPHS" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF_MINE & !<-- The nest's config object - ,value =NPHS & !<-- The variable filled (frequency of physics calls) - ,label ='nphs:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(MOD(NPHS,TIME_RATIO_MY_PARENT)/=0)THEN - WRITE(0,*)' WARNING: Moving nest parent time ratio does' & - ,' not divide into its NPHS!!!' - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Moving nests must know the move type -!----------------------------------------------------------------------- -! - IF(MY_DOMAIN_MOVES)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Move Type Flag from Nest's Configure File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF_MINE & !<-- The child's config object - ,value =MOVE_TYPE & !<-- The variable filled (type of this child's move) - ,label ='move_type:' & !<-- Give this label's value to the previous variabl - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF (TRIM(MOVE_TYPE) == 'prescribed') THEN - - WRITE(PRESCRIBED_FILENAME,"(A,I2.2)") 'prescribed_moves_',MY_DOMAIN_ID - - OPEN(99,FILE=PRESCRIBED_FILENAME,STATUS='OLD',ACTION='READ',IOSTAT=ISTAT) - - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to open ',PRESCRIBED_FILENAME,' stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - - READ(99,*)MOVE_INTERVAL_MINUTES - - N_MOVES=0 - DO WHILE(.TRUE.) - N_MOVES=N_MOVES+1 - READ(99,*,END=101) - ENDDO - 101 CONTINUE - N_MOVES=N_MOVES-1 - - REWIND(99) - - ALLOCATE(MOVE_MINUTE(N_MOVES)) - ALLOCATE(MOVE_I_SW(N_MOVES)) - ALLOCATE(MOVE_J_SW(N_MOVES)) - - READ(99,*) - DO N=1,N_MOVES - READ(99,*)MOVE_MINUTE(N),MOVE_I_SW(N),MOVE_J_SW(N) - END DO - - CLOSE(99) - -! write(0,*)'MOVE_INTERVAL_MINUTES=',MOVE_INTERVAL_MINUTES -! write(0,*)'N_MOVES=',N_MOVES -! DO N=1,N_MOVES -! write(0,*)'MOVE_MINUTE(N),MOVE_I_SW(N),MOVE_J_SW(N)',N,MOVE_MINUTE(N),MOVE_I_SW(N),MOVE_J_SW(N) -! END DO -! - END IF -! -!----------------------------------------------------------------------- -!*** The user can specify if a nest's motion must be limited to -!*** only a certain number of its parent's grid increments per -!*** shift. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Shift Limit from Nest's Configure File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - MAX_SHIFT=>cc%MAX_SHIFT -! - CALL ESMF_ConfigGetAttribute(config=CF_MINE & !<-- The child's config object - ,value =MAX_SHIFT & !<-- Max shift in parent I,J this nest can execute - ,label ='max_shift:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Collisions must be avoided between a moving nest and its -!*** independently moving child. When the inner nest gets too -!*** close to the outer nest's boundary then the inner nest will -!*** inform the outer nest that it (outer) must move away. -!*** Use a totally empirical relation to determine the distance -!*** measured in parent gridpoints that the parent is pushed -!*** by the child. Likewise compute the minimum distance in parent -!*** grid increments that the child can be to its parent's -!*** boundary. These values are used by moving children and are -!*** are only relevant if the parent also moves. -!----------------------------------------------------------------------- -! - MAX_FORCED_SHIFT=-999 - MIN_DIST_PARENT=-999. -! - IF(MY_PARENT_ID>1)THEN - GRID_DIST_KM=DPH*A*1.E-3 !<-- Approximate grid increment in km - CONST1=-8./15. - CONST2=15.33333 - MAX_FORCED_SHIFT=NINT(GRID_DIST_KM*SPACE_RATIO_MY_PARENT*CONST1+CONST2) - MAX_FORCED_SHIFT=MIN(MAX_FORCED_SHIFT,10) - MAX_FORCED_SHIFT=MAX(MAX_FORCED_SHIFT, 2) -! - CONST3=-1./3. - CONST4=11.33333 - MIN_DIST_PARENT=GRID_DIST_KM*SPACE_RATIO_MY_PARENT*CONST3+CONST4 - MIN_DIST_PARENT=MIN(MIN_DIST_PARENT,8.) - MIN_DIST_PARENT=MAX(MIN_DIST_PARENT,3.) - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF -! -!----------------------------------------------------------------------- -!*** If the run will use 2-way nesting then allocate the objects -!*** the children will use to hold the indices of the points to -!*** be updated on each parent task. The use of the upper dimension -!*** of 4 in the following allocations is a reflection of the fact -!*** that a nest task can update no more than 4 parent task subdomains -!*** under the assumption that parent task subdomains must always -!*** cover a larger physical area than child task subdomains. -!----------------------------------------------------------------------- -! - IF(NEST_MODE=='2-way')THEN -! -!----------------------------------------------------------------------- -! - CALLED_CHILD_2WAY_BOOKKEEPING=>cc%CALLED_CHILD_2WAY_BOOKKEEPING - CALLED_CHILD_2WAY_BOOKKEEPING=.FALSE. -! - ALLOCATE(cc%UPDATE_PARENT_2WAY(1:4)) -! - ALLOCATE(cc%ID_PARENT_UPDATE_TASKS(1:4)) - ALLOCATE(cc%NPTS_UPDATE_ON_PARENT_TASKS(1:4)) -! - ALLOCATE(cc%I_2WAY_UPDATE(1:4)) - ALLOCATE(cc%J_2WAY_UPDATE(1:4)) -! - ALLOCATE(cc%I_2WAY_H(1:4)) - ALLOCATE(cc%J_2WAY_H(1:4)) - ALLOCATE(cc%I_2WAY_V(1:4)) - ALLOCATE(cc%J_2WAY_V(1:4)) -! - ALLOCATE(cc%CHILD_SFC_ON_PARENT(1:4)) -! - ALLOCATE(cc%HANDLE_SEND_2WAY_DATA(1:4)) - ALLOCATE(cc%HANDLE_SEND_2WAY_SFC(1:4)) -! - DO N=1,4 -! - cc%UPDATE_PARENT_2WAY(N)%DATA=>NULL() -! - cc%ID_PARENT_UPDATE_TASKS(N)=0 - cc%NPTS_UPDATE_ON_PARENT_TASKS(N)=0 -! - cc%I_2WAY_UPDATE(N)%DATA=>NULL() - cc%J_2WAY_UPDATE(N)%DATA=>NULL() -! - cc%I_2WAY_H(N)%DATA=>NULL() - cc%J_2WAY_H(N)%DATA=>NULL() - cc%I_2WAY_V(N)%DATA=>NULL() - cc%J_2WAY_V(N)%DATA=>NULL() -! - cc%CHILD_SFC_ON_PARENT(N)%DATA=>NULL() -! - cc%HANDLE_SEND_2WAY_DATA(N)=MPI_REQUEST_NULL - cc%HANDLE_SEND_2WAY_SFC(N) =MPI_REQUEST_NULL -! - ENDDO -! - cc%NTASKS_UPDATE_PARENT=0 -! - cc%NTIMESTEP_WAIT_PARENT=0 - cc%NTIMESTEP_WAIT_FORCED_PARENT=0 -! - cc%PARENT_WANTS_TO_MOVE=.FALSE. -! -!----------------------------------------------------------------------- -!*** The averaging stencil used by the child to interpolate its -!*** gridpoint values to the parent's points must have permissible -!*** values. The range of theoretical values are: - -! Parent-Child Space Ratio -! Odd Even -! -! N_STENCIL_H (h-->H): 1,3,5,.. N_STENCIL_H (h-->H): 1,3,5,.. -! N_STENCIL_V (v-->V): 1,3,5,.. N_STENCIL_V (v-->V): 2,4,6,.. -! N_STENCIL_SFC_H (fis,pd-->H): 1,3,5,.. N_STENCIL_SFC_H (fis,pd-->H): 1,3,5,.. -! N_STENCIL_SFC_V (fis,pd-->V): 2,4,6,.. N_STENCIL_SFC_V (fis,pd-->V): 1,3,5,.. -! -!*** where small letters refer to the child and capitals to the parent. -!*** The stencils are oriented along I and J (they are not rotated -!*** diamonds). A stencil of 1 means the child point lies on top -!*** of a parent point and can thus be lifted directly to the parent -!*** point with no interpolation. A stencil of 2 means a 2x2 square -!*** of child points surrounding the parent point are used to average -!*** onto the parent point. Likewise for 3x3, etc. Note that for -!*** odd parent-to-child space ratios with odd stencil values the -!*** type of child point (h or v) lying on the the target parent -!*** point is the same as that target point whereas if the stencil -!*** value is even then the child and parent point types are -!*** different. That is not the case with an even parent-to-child -!*** space ratio as seen in the above table. -! -!*** HOWEVER, due to the MPI subdomain haloes we must select values -!*** that are less than or equal to 3 (halo width is set in module -!*** VARS_STATE with IHALO,JHALO). If the halo width increases then -!*** so can the stencil values. -!----------------------------------------------------------------------- -! - N_STENCIL_H =>cc%N_STENCIL_H - N_STENCIL_V =>cc%N_STENCIL_V - N_STENCIL_SFC_H=>cc%N_STENCIL_SFC_H - N_STENCIL_SFC_V=>cc%N_STENCIL_SFC_V -! - IF(MOD(SPACE_RATIO_MY_PARENT,2)==1)THEN - N_STENCIL_H=STENCIL_H_ODD !<-- - N_STENCIL_V=STENCIL_V_ODD ! Parent-Child space ratio - N_STENCIL_SFC_H=STENCIL_SFC_H_ODD ! is odd - N_STENCIL_SFC_V=STENCIL_SFC_V_ODD !<-- - ELSE - N_STENCIL_H=STENCIL_H_EVEN !<-- - N_STENCIL_V=STENCIL_V_EVEN ! Parent-Child space ratio - N_STENCIL_SFC_H=STENCIL_SFC_H_EVEN ! is even - N_STENCIL_SFC_V=STENCIL_SFC_V_EVEN !<-- - ENDIF -! - IF(MOD(N_STENCIL_H,2)/=1)THEN - WRITE(0,*)' N_STENCIL_H must be odd for any Parent-Child space ratio!!!' - WRITE(0,15551)SPACE_RATIO_MY_PARENT,N_STENCIL_H -15551 FORMAT(' Parent-Child space ratio=',I2 & - ,' but N_STENCIL_H=',I2) - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - IF(MOD(N_STENCIL_SFC_H,2)/=1)THEN - WRITE(0,*)' N_STENCIL_SFC_H must be odd for any Parent-Child space ratio!!!' - WRITE(0,15552)SPACE_RATIO_MY_PARENT,N_STENCIL_SFC_H -15552 FORMAT(' Parent-Child space ratio=',I2 & - ,' but N_STENCIL_SFC_H=',I2) - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - IF(MOD(SPACE_RATIO_MY_PARENT,2)==1)THEN !<-- For odd parent-child space ratios -! - IF(MOD(N_STENCIL_V,2)/=1)THEN - WRITE(0,*)' N_STENCIL_V must be odd for odd Parent-Child space ratios!!!' - WRITE(0,15553)SPACE_RATIO_MY_PARENT,N_STENCIL_V -15553 FORMAT(' Parent-Child space ratio=',I2 & - ,' but N_STENCIL_V=',I2) - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - IF(MOD(N_STENCIL_SFC_V,2)/=0)THEN - WRITE(0,*)' N_STENCIL_SFC_V must be even for odd Parent-Child space ratios!!!' - WRITE(0,15554)SPACE_RATIO_MY_PARENT,N_STENCIL_SFC_V -15554 FORMAT(' Parent-Child space ratio=',I2 & - ,' but N_STENCIL_SFC_V=',I2) - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - ENDIF -! - IF(MOD(SPACE_RATIO_MY_PARENT,2)==0)THEN !<-- For even parent-child space ratios -! - IF(MOD(N_STENCIL_V,2)/=0)THEN - WRITE(0,*)' N_STENCIL_V must be even for even Parent-Child space ratios!!!' - WRITE(0,15555)SPACE_RATIO_MY_PARENT,N_STENCIL_V -15555 FORMAT(' Parent-Child space ratio=',I2 & - ,' but N_STENCIL_V=',I2) - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - IF(MOD(N_STENCIL_SFC_V,2)/=1)THEN - WRITE(0,*)' N_STENCIL_SFC_V must be odd for even Parent-Child space ratios!!!' - WRITE(0,15556)SPACE_RATIO_MY_PARENT,N_STENCIL_SFC_V -15556 FORMAT(' Parent-Child space ratio=',I2 & - ,' but N_STENCIL_SFC_V=',I2) - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Initialize the flag that indicates whether or not the 2-way -!*** forecast is in its first step. -!----------------------------------------------------------------------- -! - cc%FIRST_STEP_2WAY=.TRUE. -! -!----------------------------------------------------------------------- -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF child_block -! -!----------------------------------------------------------------------- -!*** Parent tasks prepare various quantities for the integration. -!----------------------------------------------------------------------- -! - parent_block_1: IF(NUM_CHILDREN>0)THEN !<-- Select parents for additional setup -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Extract integer ratios of parent-to-child timesteps. -!----------------------------------------------------------------------- -! - ALLOCATE(CC%TIME_RATIO_MY_CHILDREN(1:NUM_CHILDREN),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%TIME_RATIO_MY_CHILDREN stat=',ISTAT - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) - ENDIF -! - TIME_RATIO_MY_CHILDREN=>cc%TIME_RATIO_MY_CHILDREN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Parent-to-Child DT Ratio from Imp State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,name ='Parent-Child Time Ratio' & !<-- Name of the attribute to extract - ,itemCount=NUM_CHILDREN & !<-- # of items in the Attribute - ,valueList=TIME_RATIO_MY_CHILDREN & !<-- Ratio of parent to child DTs - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Extract the timestep from the Clock to set the initial value for -!*** the child's timestep at which it will next receive parent data. -!----------------------------------------------------------------------- -! - CALL ESMF_ClockGet(clock =CLOCK & - ,advanceCount=NTIMESTEP_ESMF & - ,rc =RC) -! - NTIMESTEP=NTIMESTEP_ESMF -! - ALLOCATE(cc%NSTEP_CHILD_RECV(1:NUM_CHILDREN),stat=ISTAT) !<-- Children's timesteps at which they recv data - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%NSTEP_CHILD_RECV stat=',ISTAT - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) - ENDIF -! - NSTEP_CHILD_RECV=>cc%NSTEP_CHILD_RECV -! - DO N=1,NUM_CHILDREN - NSTEP_CHILD_RECV(N)=(NTIMESTEP-1)*TIME_RATIO_MY_CHILDREN(N) - ENDDO -! -!----------------------------------------------------------------------- -!*** Allocate more arrays needed by the parent to hold child -!*** information derived from the children's configure files. -!----------------------------------------------------------------------- -! - ALLOCATE(cc%IM_CHILD(1:NUM_CHILDREN),stat=ISTAT) !<-- I extent of children's domains - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%IM_CHILD stat=',ISTAT - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) - ENDIF - IM_CHILD=>cc%IM_CHILD -! - ALLOCATE(cc%JM_CHILD(1:NUM_CHILDREN),stat=ISTAT) !<-- J extent of children's domains - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%JM_CHILD stat=',ISTAT - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) - ENDIF - JM_CHILD=>cc%JM_CHILD -! - ALLOCATE(cc%PARENT_CHILD_SPACE_RATIO(1:NUM_CHILDREN),stat=ISTAT) !<-- Integer ratio of parent grid increment to children's - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%PARENT_CHILD_SPACE_RATIO stat=',ISTAT - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) - ENDIF - PARENT_CHILD_SPACE_RATIO=>cc%PARENT_CHILD_SPACE_RATIO -! - ALLOCATE(cc%CHILD_PARENT_SPACE_RATIO(1:NUM_CHILDREN),stat=ISTAT) !<-- Inverse of PARENT_CHILD_SPACE_RATIO - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%CHILD_PARENT_SPACE_RATIO stat=',ISTAT - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) - ENDIF - CHILD_PARENT_SPACE_RATIO=>cc%CHILD_PARENT_SPACE_RATIO -! - ALLOCATE(cc%N_BLEND_H_CHILD(1:NUM_CHILDREN),stat=ISTAT) !<-- Boundary blending width for child H points - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%N_BLEND_H_CHILD stat=',ISTAT - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) - ENDIF - N_BLEND_H_CHILD=>cc%N_BLEND_H_CHILD -! - ALLOCATE(cc%N_BLEND_V_CHILD(1:NUM_CHILDREN),stat=ISTAT) !<-- Boundary blending width for child V points - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%N_BLEND_V_CHILD stat=',ISTAT - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) - ENDIF - N_BLEND_V_CHILD=>cc%N_BLEND_V_CHILD -! - ALLOCATE(cc%CHILD_ACTIVE(1:NUM_CHILDREN),stat=ISTAT) !<-- Will child participate in the digital filtering? - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%CHILD_ACTIVE stat=',ISTAT - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) - ENDIF - CHILD_ACTIVE=>cc%CHILD_ACTIVE -! - ALLOCATE(cc%INC_FIX(1:NUM_CHILDREN),stat=ISTAT) !<-- See below where INC_FIX is filled - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%INC_FIX stat=',ISTAT - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) - ENDIF - INC_FIX=>cc%INC_FIX -! - ALLOCATE(cc%RANK_2WAY_CHILD(1:NUM_CHILDREN),stat=ISTAT) !<-- Location of moving nests in list of all children - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%RANK_2WAY_CHILD stat=',ISTAT - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) - ENDIF - RANK_2WAY_CHILD=>cc%RANK_2WAY_CHILD -! - ALLOCATE(cc%RANK_MOVING_CHILD(1:NUM_CHILDREN),stat=ISTAT) !<-- Location of moving nests in list of all children - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%RANK_MOVING_CHILD stat=',ISTAT - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) - ENDIF - RANK_MOVING_CHILD=>cc%RANK_MOVING_CHILD -! - ALLOCATE(cc%STATIC_OR_MOVING(1:NUM_CHILDREN),stat=ISTAT) !<-- Are the individual children static or moving? - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%STATIC_OR_MOVING stat=',ISTAT - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) - ENDIF - STATIC_OR_MOVING=>cc%STATIC_OR_MOVING -! - ALLOCATE(NEST_MODE_CHILD(1:NUM_CHILDREN)) -! -!----------------------------------------------------------------------- -! - ALLOCATE(cc%CF(1:NUM_CHILDREN)) !<-- Configure objects of this parent's children - CF=>cc%CF -! -!----------------------------------------------------------------------- -! - child_info_loop: DO N=1,NUM_CHILDREN -! -!----------------------------------------------------------------------- -!*** Initialize to nonsense the newly allocated arrays. -!----------------------------------------------------------------------- -! - IM_CHILD(N) =-999 - JM_CHILD(N) =-999 - PARENT_CHILD_SPACE_RATIO(N)=-999 - CHILD_PARENT_SPACE_RATIO(N)=-999. - INC_FIX(N) =-999 - RANK_2WAY_CHILD(N) =-999 - RANK_MOVING_CHILD(N) =-999 -! - STATIC_OR_MOVING(N) ='Static' -! -!----------------------------------------------------------------------- -!*** The parent loads each of its children's configure files. -!----------------------------------------------------------------------- -! - CF(N)=ESMF_ConfigCreate(rc=RC) -! - MY_CHILDREN_ID=>cc%MY_CHILDREN_ID - CHILD_ID=MY_CHILDREN_ID(N) - CONFIG_ID=DOMAIN_ID_TO_RANK(CHILD_ID) - WRITE(INT_TO_CHAR,FMT)CONFIG_ID - CONFIG_FILE_NAME='configure_file_'//INT_TO_CHAR !<-- Prepare the config file names -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Parent-Child Init1: Load Configure Files" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigLoadFile(config =CF(N) & - ,filename=CONFIG_FILE_NAME & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(RC/=0)THEN - WRITE(0,*)' Parent unable to load child configure file ' & - ,TRIM(CONFIG_FILE_NAME) & - ,' in PARENT_CHILD_CPL_INITIALIZE1' - WRITE(0,*)' ABORTING!' - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT & - ,rc =RC) - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract the children's domain sizes from the configure files. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Parent-Child Init: Extract Global IM,JM of Child" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(N) & !<-- The child's config object - ,value =IM_CHILD(N) & !<-- The variable filled (IM of child domain) - ,label ='im:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF(N) & !<-- The child's config object - ,value =JM_CHILD(N) & !<-- The variable filled (JM of child domain) - ,label ='jm:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Extract the children's boundary blending widths. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Parent-Child Init: Extract Child Bndry Blending Width" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(N) & !<-- The child's config object - ,value =N_BLEND_H_CHILD(N) & !<-- The variable filled (N_BLEND_H of child domain N) - ,label ='lnsh:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF(N) & !<-- The child's config object - ,value =N_BLEND_V_CHILD(N) & !<-- The variable filled (N_BLEND_V of child domain N) - ,label ='lnsv:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(N_BLEND_V_CHILD(N)>N_BLEND_H_CHILD(N))THEN - WRITE(0,*)' N_BLEND_V CANNOT EXCEED N_BLEND_H DUE TO PD AVERAGING!!!' - WRITE(0,*)' ABORTING in child N=',N - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract the integer ratio of parent-to-child grid increments. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Parent-to-Child Space Ratio" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(N) & !<-- The child's config object - ,value =PARENT_CHILD_SPACE_RATIO(N) & !<-- The variable filled (# of child grid inc's to parent's) - ,label ='parent_child_space_ratio:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Use this ratio to compute an increment that is needed for -!*** selecting the appropriate nest tasks as mass values on the -!*** nest boundaries are averaged to the V points. Its values -!*** are based on the nest grid increment distance from the -!*** southernmost V point on a nest's southernmost tasks to -!*** the nearest parent V point to the north. Fractional values -!*** are increased to the next integer. -!----------------------------------------------------------------------- -! - DIST_NESTV_SOUTH_TO_PARENTV_SOUTH= & - (PARENT_CHILD_SPACE_RATIO(N)-1)*0.5 - INC_FIX(N)=INT(DIST_NESTV_SOUTH_TO_PARENTV_SOUTH+0.9) -! -!----------------------------------------------------------------------- -!*** Which of the children will be sending 2-way update data? Save -!*** their ranks in the list of all child ranks. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract the Child's Flag Indicating Nest Mode" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(N) & !<-- The child's config object - ,value =NEST_MODE_CHILD(N) & !<-- The variable filled (does the child send 2-way data?) - ,label ='nest_mode:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! - IF(NEST_MODE_CHILD(N)=='2-way')THEN - NEST_MODE='2-way' - ENDIF -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(NEST_MODE_CHILD(N)=='2-way')THEN !<-- If true then this child sends 2-way update data. -! - NUM_2WAY_CHILDREN=NUM_2WAY_CHILDREN+1 !<-- Add up the # of 2-way children. - RANK_2WAY_CHILD(NUM_2WAY_CHILDREN)=N !<-- Rank of 2-way children among all children. -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Which of the children will be moving? Save their ranks in -!*** the list of all children. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract the Child's Flag Indicating Movability" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(N) & !<-- The child's config object - ,value =DOMAIN_MOVES & !<-- The variable filled (will the child move?) - ,label ='my_domain_moves:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(DOMAIN_MOVES)THEN !<-- If true then child N moves. -! - NUM_MOVING_CHILDREN=NUM_MOVING_CHILDREN+1 !<-- Add up the # of moving children. - RANK_MOVING_CHILD(NUM_MOVING_CHILDREN)=N !<-- Location in list of children of those who move. - STATIC_OR_MOVING(N)='Moving' !<-- Child N moves -! - ENDIF -! -!----------------------------------------------------------------------- -!*** We do not allow moving parents to have static children for now. -!----------------------------------------------------------------------- -! - IF(MY_DOMAIN_MOVES)THEN - IF(NUM_MOVING_CHILDREN/=NUM_CHILDREN)THEN - WRITE(0,*)' You have specified a moving parent with' & - ,' static children. This is not allowed. ' - WRITE(0,*)' Moving parents can have only moving children.' - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO child_info_loop -! -!----------------------------------------------------------------------- -!*** The number of 2-way children is a required argument in the -!*** call to NMM_INTEGRATE therefore it must be known by the NMM -!*** component. Insert it into the P-C coupler export state. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Init1: Set # of 2-Way Children in P-C Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The P-C coupler's export state - ,name ='NUM_2WAY_CHILDREN' & - ,value=NUM_2WAY_CHILDREN & !<-- Current domain has this many 2-way children - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Allocate arrays/pointers needed by the parents to compute -!*** update data for their children. The routine is called only -!*** by parents. -!----------------------------------------------------------------------- -! - CALL PARENT_CHILD_INTERP_SETUP(MY_DOMAIN_ID & - ,NUM_CHILDREN & - ,MY_CHILDREN_ID & - ,IM_CHILD & - ,JM_CHILD & - ,FTASKS_DOMAIN & - ,N_BLEND_H_CHILD & - ,N_BLEND_V_CHILD & - ,CF & - ,ITS,ITE,JTS,JTE & - ,IDS,IDE,JDS,JDE ) -! -!----------------------------------------------------------------------- -!*** The lead parent task now broadcasts the locations of the -!*** children's SW corner. The lead tasks recvd this information -!*** from the children in phase 0 of the P-C coupler initialize -!*** step (subroutine _INITIALIZE0). -!----------------------------------------------------------------------- -! - DO N=1,NUM_CHILDREN -! - IF(I_AM_LEAD_FCST_TASK)THEN !<-- Lead parent task clears IRecv in P-C Initialize0 - ID_CHILD=MY_CHILDREN_ID(N) !<-- Child N's domain ID - CALL MPI_WAIT(HANDLE_I_SW(ID_CHILD) & !<-- Be sure the lead parent task has recvd child N's data. - ,JSTAT & - ,IERR ) - ENDIF -! - CALL MPI_BCAST(I_PARENT_SW(N) & !<-- Parent I of chkid N's SW corner - ,1 & !<-- It is one word - ,MPI_INTEGER & !<-- Datatype - ,0 & !<-- Lead parent task in parent-child intracomm is root - ,COMM_FCST_TASKS & !<-- Intracommunicator for fcst tasks - ,IERR ) -! - IF(I_AM_LEAD_FCST_TASK)THEN !<-- Lead parent task clears IRecv in P-C Initialize0 - ID_CHILD=MY_CHILDREN_ID(N) !<-- Child N's domain ID - CALL MPI_WAIT(HANDLE_J_SW(ID_CHILD) & !<-- Be sure the lead parent task has recvd child N's data. - ,JSTAT & - ,IERR ) - ENDIF -! - CALL MPI_BCAST(J_PARENT_SW(N) & !<-- Parent J of chkid N's SW corner - ,1 & !<-- It is one word - ,MPI_INTEGER & !<-- Datatype - ,0 & !<-- Lead parent task in parent-child intracomm is root - ,COMM_FCST_TASKS & !<-- Intracommunicator for fcst tasks - ,IERR ) -! - ENDDO -! -!----------------------------------------------------------------------- -!*** We now compute various indices and weights needed by the parents -!*** to compute boundary data for their children. It is here that -!*** location-dependent interpolation information is determined -!*** regarding the parent and nests. Again only parents call this -!*** routine. -!----------------------------------------------------------------------- -! - DO N=1,NUM_CHILDREN - CALL PREPARE_NEST_INTERP_FACTORS(N,MY_DOMAIN_ID) - ENDDO -! -!----------------------------------------------------------------------- -!*** The parents need to send their children some key information -!*** regarding the association of child boundary tasks with parent -!*** tasks so the children know how to receive boundary data from -!*** their parents. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** MPI request handles for nonblocking sends in the following call -!*** to subroutine PARENT_SENDS_CHILD_DATA_LIMITS. -!----------------------------------------------------------------------- -! - ALLOCATE(HANDLE_PACKET_S_H(MY_DOMAIN_ID)%CHILDREN(1:NUM_CHILDREN) & - ,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,20001)MY_DOMAIN_ID,NUM_CHILDREN -20001 FORMAT(' Failed to allocate HANDLE_PACKET_S_H(',I2,')%CHILDREN(1:',I2,')') - WRITE(0,*)' ISTAT=',ISTAT - WRITE(0,*)' Aborting!' - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) - ENDIF - ALLOCATE(HANDLE_PACKET_S_V(MY_DOMAIN_ID)%CHILDREN(1:NUM_CHILDREN)) - ALLOCATE(HANDLE_PACKET_N_H(MY_DOMAIN_ID)%CHILDREN(1:NUM_CHILDREN)) - ALLOCATE(HANDLE_PACKET_N_V(MY_DOMAIN_ID)%CHILDREN(1:NUM_CHILDREN)) - ALLOCATE(HANDLE_PACKET_W_H(MY_DOMAIN_ID)%CHILDREN(1:NUM_CHILDREN)) - ALLOCATE(HANDLE_PACKET_W_V(MY_DOMAIN_ID)%CHILDREN(1:NUM_CHILDREN)) - ALLOCATE(HANDLE_PACKET_E_H(MY_DOMAIN_ID)%CHILDREN(1:NUM_CHILDREN)) - ALLOCATE(HANDLE_PACKET_E_V(MY_DOMAIN_ID)%CHILDREN(1:NUM_CHILDREN)) -! - DO N=1,NUM_CHILDREN -! - ID_CHILD=MY_CHILDREN_ID(N) - N1=0 - N2=FTASKS_DOMAIN(ID_CHILD)-1 - ALLOCATE(HANDLE_PACKET_S_H(MY_DOMAIN_ID)%CHILDREN(N)%DATA(N1:N2)) - ALLOCATE(HANDLE_PACKET_S_V(MY_DOMAIN_ID)%CHILDREN(N)%DATA(N1:N2)) - ALLOCATE(HANDLE_PACKET_N_H(MY_DOMAIN_ID)%CHILDREN(N)%DATA(N1:N2)) - ALLOCATE(HANDLE_PACKET_N_V(MY_DOMAIN_ID)%CHILDREN(N)%DATA(N1:N2)) - ALLOCATE(HANDLE_PACKET_W_H(MY_DOMAIN_ID)%CHILDREN(N)%DATA(N1:N2)) - ALLOCATE(HANDLE_PACKET_W_V(MY_DOMAIN_ID)%CHILDREN(N)%DATA(N1:N2)) - ALLOCATE(HANDLE_PACKET_E_H(MY_DOMAIN_ID)%CHILDREN(N)%DATA(N1:N2)) - ALLOCATE(HANDLE_PACKET_E_V(MY_DOMAIN_ID)%CHILDREN(N)%DATA(N1:N2)) -! - DO NN=N1,N2 - HANDLE_PACKET_S_H(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NN)=MPI_REQUEST_NULL - HANDLE_PACKET_S_V(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NN)=MPI_REQUEST_NULL - HANDLE_PACKET_N_H(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NN)=MPI_REQUEST_NULL - HANDLE_PACKET_N_V(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NN)=MPI_REQUEST_NULL - HANDLE_PACKET_W_H(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NN)=MPI_REQUEST_NULL - HANDLE_PACKET_W_V(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NN)=MPI_REQUEST_NULL - HANDLE_PACKET_E_H(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NN)=MPI_REQUEST_NULL - HANDLE_PACKET_E_V(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NN)=MPI_REQUEST_NULL - ENDDO -! - ENDDO -! -!----------------------------------------------------------------------- -!*** Allocate unique memory locations for all of the data packets -!*** that parents will send to their children's tasks to inform -!*** them precisely which BC update data will be provided. -!----------------------------------------------------------------------- -! - ALLOCATE(INFO_SEND(MY_DOMAIN_ID)%CHILDREN(1:NUM_CHILDREN),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate INFO_SEND%CHILDREN stat=',ISTAT - WRITE(0,*)' Aborting!' - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) - ENDIF -! - DO N=1,NUM_CHILDREN -! - CHILD_ID=MY_CHILDREN_ID(N) - ALLOCATE(INFO_SEND(MY_DOMAIN_ID)%CHILDREN(N)%INFO(1:6,0:FTASKS_DOMAIN(CHILD_ID)-1,1:8) & - ,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate INFO for n=',n,' child ID=',CHILD_ID,' stat=',ISTAT - WRITE(0,*)' Aborting!' - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) - ENDIF -! - DO N3=1,8 - DO N2=0,FTASKS_DOMAIN(CHILD_ID)-1 - DO N1=1,6 - INFO_SEND(MY_DOMAIN_ID)%CHILDREN(N)%INFO(N1,N2,N3)=-1 !<-- Initialize to invalid values - ENDDO - ENDDO - ENDDO -! - CALL PARENT_SENDS_CHILD_DATA_LIMITS(N,MY_DOMAIN_ID,'Future') -! - ENDDO -! -!----------------------------------------------------------------------- -!*** Allocate the pointers that will hold the surface geopotential -!*** of child tasks on each side of the child boundaries. The child -!*** tasks of static nests will send that data to the appropriate -!*** parent tasks. -!----------------------------------------------------------------------- -! - ALLOCATE(cc%FIS_CHILD_SOUTH(1:NUM_CHILDREN),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%FIS_CHILD_SOUTH stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - ALLOCATE(cc%FIS_CHILD_NORTH(1:NUM_CHILDREN),stat=ISTAT) - ALLOCATE(cc%FIS_CHILD_WEST(1:NUM_CHILDREN),stat=ISTAT) - ALLOCATE(cc%FIS_CHILD_EAST(1:NUM_CHILDREN),stat=ISTAT) -! -!----------------------------------------------------------------------- -!*** The parent receives the child's boundary topography. This -!*** is needed to maintain hydrostatic balance when parent data is -!*** interpolated to child boundaries where the terrain is different. -!----------------------------------------------------------------------- -! - ALLOCATE(HANDLE_CHILD_TOPO_S(MY_DOMAIN_ID)%CHILDREN(1:NUM_CHILDREN)) - ALLOCATE(HANDLE_CHILD_TOPO_N(MY_DOMAIN_ID)%CHILDREN(1:NUM_CHILDREN)) - ALLOCATE(HANDLE_CHILD_TOPO_W(MY_DOMAIN_ID)%CHILDREN(1:NUM_CHILDREN)) - ALLOCATE(HANDLE_CHILD_TOPO_E(MY_DOMAIN_ID)%CHILDREN(1:NUM_CHILDREN)) -! - DO N=1,NUM_CHILDREN -! - HANDLE_CHILD_TOPO_S(MY_DOMAIN_ID)%CHILDREN(N)%DATA=>NULL() - HANDLE_CHILD_TOPO_N(MY_DOMAIN_ID)%CHILDREN(N)%DATA=>NULL() - HANDLE_CHILD_TOPO_W(MY_DOMAIN_ID)%CHILDREN(N)%DATA=>NULL() - HANDLE_CHILD_TOPO_E(MY_DOMAIN_ID)%CHILDREN(N)%DATA=>NULL() -! - CALL PARENT_RECVS_CHILD_TOPO(N,MY_DOMAIN_ID) -! - ENDDO -! -!----------------------------------------------------------------------- -!*** When the child's terrain is much lower than the parent's at -!*** locations where the parent generates BC data for the child then -!*** those values can be unrealistic due to the very large distance -!*** the parent must extrapolate under its own ground surface. To -!*** control this effect use the hyperbola Y=A/(X+A) to reduce the -!*** magnitude of the parent's underground extrapolation as the -!*** target depth increases. The following call returns the value -!*** of the constant in the formula. One point on the curve must be -!*** set by the user in subroutine HYPERBOLA in module_NESTING. -!----------------------------------------------------------------------- -! - CALL HYPERBOLA(HYPER_A) -! -!----------------------------------------------------------------------- -! - CHILDTASK_H_SAVE=>cc%CHILDTASK_H_SAVE - CHILDTASK_BNDRY_H_RANKS=>cc%CHILDTASK_BNDRY_H_RANKS - N_BLEND_H_CHILD=>cc%N_BLEND_H_CHILD - COMM_TO_MY_CHILDREN=>cc%COMM_TO_MY_CHILDREN - MY_CHILDREN_ID=>cc%MY_CHILDREN_ID - MYPE=>cc%MYPE -! - CALL MPI_COMM_RANK(COMM_TO_MY_CHILDREN(1),MYPE,IERR) !<-- Obtain local rank of parent task in p-c intracomm -! -!----------------------------------------------------------------------- -!*** Parents send their children the parent domain limits and the -!*** integration limits of all forecast tasks on the parent domain. -!----------------------------------------------------------------------- -! - IF(I_AM_LEAD_FCST_TASK)THEN -! - ALLOCATE(HANDLE_PARENT_DOM_LIMITS(MY_DOMAIN_ID)%DATA(1:NUM_CHILDREN)) - cc%MY_DOMAIN_LIMITS(1)=IDS - cc%MY_DOMAIN_LIMITS(2)=IDE - cc%MY_DOMAIN_LIMITS(3)=JDS - cc%MY_DOMAIN_LIMITS(4)=JDE -! - ALLOCATE(HANDLE_PARENT_ITS(MY_DOMAIN_ID)%DATA(1:NUM_CHILDREN) & - ,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate HANDLE_PARENT_ITS(',MY_DOMAIN_ID,')%DATA' - WRITE(0,*)' Aborting!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - ALLOCATE(HANDLE_PARENT_ITE(MY_DOMAIN_ID)%DATA(1:NUM_CHILDREN)) - ALLOCATE(HANDLE_PARENT_JTS(MY_DOMAIN_ID)%DATA(1:NUM_CHILDREN)) - ALLOCATE(HANDLE_PARENT_JTE(MY_DOMAIN_ID)%DATA(1:NUM_CHILDREN)) -! - DO N=1,NUM_CHILDREN -! - CHILDTASK_0=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(0) !<-- Local rank of child N's lead task in parent-child intracomm - NTAG=MY_CHILDREN_ID(N)*111+1 -! - HANDLE_PARENT_DOM_LIMITS(MY_DOMAIN_ID)%DATA(N)=MPI_REQUEST_NULL -! - CALL MPI_ISSEND(cc%MY_DOMAIN_LIMITS & !<-- Index limits of parent domain - ,4 & !<-- There are 4 index limits - ,MPI_INTEGER & !<-- Indices are integers - ,CHILDTASK_0 & !<-- Send to each child's task 0 - ,NTAG & !<-- Unique MPI tag - ,COMM_TO_MY_CHILDREN(N) & !<-- MPI intracommunicator to child N - ,HANDLE_PARENT_DOM_LIMITS(MY_DOMAIN_ID)%DATA(N) & !<-- Request handle for this ISend - ,IERR ) -! - HANDLE_PARENT_ITS(MY_DOMAIN_ID)%DATA(N)=MPI_REQUEST_NULL -! - CALL MPI_ISSEND(LOCAL_ISTART & !<-- Starting I's of fcst tasks on parent domain - ,FTASKS_DOMAIN(MY_DOMAIN_ID) & !<-- # of fcst tasks on parent domain - ,MPI_INTEGER & !<-- Indices are integers - ,CHILDTASK_0 & !<-- Send to each child's task 0 - ,NTAG & !<-- Unique MPI tag - ,COMM_TO_MY_CHILDREN(N) & !<-- MPI intracommunicator to child N - ,HANDLE_PARENT_ITS(MY_DOMAIN_ID)%DATA(N) & !<-- Request handle for this ISend - ,IERR ) -! - NTAG=NTAG+1 - CALL MPI_ISSEND(LOCAL_JSTART & !<-- Starting J's of fcst tasks on parent domain - ,FTASKS_DOMAIN(MY_DOMAIN_ID) & !<-- # of fcst tasks on parent domain - ,MPI_INTEGER & !<-- Indices are integers - ,CHILDTASK_0 & !<-- Send to each child's task 0 - ,NTAG & !<-- Unique MPI tag - ,COMM_TO_MY_CHILDREN(N) & !<-- MPI intracommunicator to child N - ,HANDLE_PARENT_JTS(MY_DOMAIN_ID)%DATA(N) & !<-- Request handle for this ISend - ,IERR ) -! - NTAG=NTAG+1 - CALL MPI_ISSEND(LOCAL_IEND & !<-- Ending I's of fcst tasks on parent domain - ,FTASKS_DOMAIN(MY_DOMAIN_ID) & !<-- # of fcst tasks on parent domain - ,MPI_INTEGER & !<-- Indices are integers - ,CHILDTASK_0 & !<-- Send to each child's task 0 - ,NTAG & !<-- Unique MPI tag - ,COMM_TO_MY_CHILDREN(N) & !<-- MPI intracommunicator to child N - ,HANDLE_PARENT_ITE(MY_DOMAIN_ID)%DATA(N) & !<-- Request handle for this ISend - ,IERR ) -! - NTAG=NTAG+1 - CALL MPI_ISSEND(LOCAL_JEND & !<-- Ending J's of fcst tasks on parent domain - ,FTASKS_DOMAIN(MY_DOMAIN_ID) & !<-- # of fcst tasks on parent domain - ,MPI_INTEGER & !<-- Indices are integers - ,CHILDTASK_0 & !<-- Send to each child's task 0 - ,NTAG & !<-- Unique MPI tag - ,COMM_TO_MY_CHILDREN(N) & !<-- MPI intracommunicator to child N - ,HANDLE_PARENT_JTE(MY_DOMAIN_ID)%DATA(N) & !<-- Request handle for this ISend - ,IERR ) -! - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** If there are any 2-way children then allocate the top of the -!*** linked list that will hold specifications of each relevant -!*** child task's updating of a parent task's point. -!----------------------------------------------------------------------- -! - IF(NUM_2WAY_CHILDREN>0)THEN -! - ALLOCATE(cc%CHILD_TASKS_2WAY_UPDATE(1:NUM_2WAY_CHILDREN)) - DO N=1,NUM_2WAY_CHILDREN - ALLOCATE(cc%CHILD_TASKS_2WAY_UPDATE(N)%TASK_ID) - ALLOCATE(cc%CHILD_TASKS_2WAY_UPDATE(N)%NUM_PTS_UPDATE_HZ) - ALLOCATE(cc%CHILD_TASKS_2WAY_UPDATE(N)%IL(1:2)) - ALLOCATE(cc%CHILD_TASKS_2WAY_UPDATE(N)%JL(1:2)) - cc%CHILD_TASKS_2WAY_UPDATE(N)%NEXT_LINK=>NULL() - ENDDO -! -!----------------------------------------------------------------------- -!*** Initialize parent flag for its computing 2-way bookkeeping. -!----------------------------------------------------------------------- -! - ALLOCATE(cc%CALLED_PARENT_2WAY_BOOKKEEPING(1:NUM_2WAY_CHILDREN)) - DO N=1,NUM_2WAY_CHILDREN - cc%CALLED_PARENT_2WAY_BOOKKEEPING(N)=.FALSE. - ENDDO -! -!----------------------------------------------------------------------- -!*** Allocate the object that will keep track of the number of -!*** tasks on each child that will provide 2-way exchange data -!*** to this parent task. -!----------------------------------------------------------------------- -! - ALLOCATE(cc%NTASKS_UPDATE_CHILD(1:NUM_2WAY_CHILDREN)) - DO N=1,NUM_2WAY_CHILDREN - cc%NTASKS_UPDATE_CHILD(N)=0 - ENDDO -! -!----------------------------------------------------------------------- -!*** Each 2-way nest can have its own weight used in blending the -!*** child's update values with the parents' pre-update values. -!----------------------------------------------------------------------- -! - ALLOCATE(cc%CHILD_2WAY_WGT(1:NUM_2WAY_CHILDREN)) - DO N=1,NUM_2WAY_CHILDREN - cc%CHILD_2WAY_WGT(N)=-99999. - ENDDO -! -!----------------------------------------------------------------------- -!*** Allocate the stencils used for averaging a child's data to -!*** its parent's grid. -!----------------------------------------------------------------------- -! - ALLOCATE(cc%N_STENCIL_H_CHILD(1:NUM_2WAY_CHILDREN)) - ALLOCATE(cc%N_STENCIL_v_CHILD(1:NUM_2WAY_CHILDREN)) - ALLOCATE(cc%N_STENCIL_SFC_H_CHILD(1:NUM_2WAY_CHILDREN)) - ALLOCATE(cc%N_STENCIL_SFC_V_CHILD(1:NUM_2WAY_CHILDREN)) -! - N_STENCIL_H_CHILD=>cc%N_STENCIL_H_CHILD - N_STENCIL_V_CHILD=>cc%N_STENCIL_V_CHILD - N_STENCIL_SFC_H_CHILD=>cc%N_STENCIL_SFC_H_CHILD - N_STENCIL_SFC_V_CHILD=>cc%N_STENCIL_SFC_V_CHILD -! - DO N=1,NUM_2WAY_CHILDREN - cc%N_STENCIL_H_CHILD(N)=-99999. - cc%N_STENCIL_V_CHILD(N)=-99999. - cc%N_STENCIL_SFC_H_CHILD(N)=-99999. - cc%N_STENCIL_SFC_V_CHILD(N)=-99999. - ENDDO -! -!----------------------------------------------------------------------- -!*** Set the 2-way children's averaging weights. When a child -!*** updates its parent's points the final value is a blend of the -!*** child's interpolated value and the parent's own incoming value. -!----------------------------------------------------------------------- -! - NN=0 -! -!----------------------------------------------------------------------- -! - DO N=1,NUM_CHILDREN -! -!----------------------------------------------------------------------- -! - IF(NEST_MODE_CHILD(N)=='2-way')THEN - NN=NN+1 -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract the Child's 2-Way Weight" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(N) & !<-- The child's config object - ,value =cc%CHILD_2WAY_WGT(NN) & !<-- Child domain's weight in 2-way updates. - ,label ='2way_wgt:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Set the children's 2-way averaging widths for H and V points. -!----------------------------------------------------------------------- -! - IF(MOD(PARENT_CHILD_SPACE_RATIO(N),2)==1)THEN - N_STENCIL_H_CHILD(N)=STENCIL_H_ODD - N_STENCIL_V_CHILD(N)=STENCIL_V_ODD - N_STENCIL_SFC_H_CHILD(N)=STENCIL_SFC_H_ODD - N_STENCIL_SFC_V_CHILD(N)=STENCIL_SFC_V_ODD - ELSE - N_STENCIL_H_CHILD(N)=STENCIL_H_EVEN - N_STENCIL_V_CHILD(N)=STENCIL_V_EVEN - N_STENCIL_SFC_H_CHILD(N)=STENCIL_SFC_H_EVEN - N_STENCIL_SFC_V_CHILD(N)=STENCIL_SFC_V_EVEN - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO -! -!----------------------------------------------------------------------- -! - ENDIF -! - DEALLOCATE(NEST_MODE_CHILD) -! -!----------------------------------------------------------------------- -!*** Allocate the Handle for use by moving parents in ISends of their -!*** shift information to their children. -!----------------------------------------------------------------------- -! - IF(I_AM_LEAD_FCST_TASK)THEN - ALLOCATE(cc%HANDLE_PARENT_SHIFT(1:NUM_CHILDREN)) - DO N=1,NUM_CHILDREN - cc%HANDLE_PARENT_SHIFT(N)=MPI_REQUEST_NULL - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** If a moving child comes too close to its parent's boundary -!*** then the parent must move to avoid the collision. Initialize -!*** the flag and shift array. -!----------------------------------------------------------------------- -! - cc%CHILD_FORCES_MY_SHIFT=.FALSE. - cc%MY_FORCED_SHIFT(1)=-99999 - cc%MY_FORCED_SHIFT(2)=-99999 -! - DO N=1,3 - cc%PARENT_SHIFT(N)=-999 - ENDDO -! -!----------------------------------------------------------------------- -! - ENDIF parent_block_1 -! -!----------------------------------------------------------------------- -!*** All domains want to know what their very last timestep is -!*** in the forecast. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Parent-Child Init1: Get Forecast Length" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF_MINE & !<-- This domain's configure object - ,value =NHOURS_FCST & !<-- The # of hours in the forecast - ,label ='nhours_fcst:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - cc%NTIMESTEP_FINAL=NHOURS_FCST*3600./DT_DOMAIN(MY_DOMAIN_ID)-1 !<-- This domain's final timestep in the forecast -! -!----------------------------------------------------------------------- -!*** If there is digital filtering does this domain participate? -!*** Currently a nest must be static and 1-way for this to be -!*** considered. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Init1: Extract domain DFI flag from P-C cpl imp state" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='I Am Active' & !<-- Name of Attribute to extract - ,value=I_AM_ACTIVE & !<-- Does domain participate in digital filtering? - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Insert the flag indicating digital filter activity into the -!*** P-C coupler export state. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Init1: Insert DFI activity flag into P-C Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The P-C coupler's export state - ,name ='I Am Active' & - ,value=I_AM_ACTIVE & !<-- Does this domain execute the digital filter? - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(NUM_CHILDREN>0)THEN - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract child DFI flags from P-C cpl import state" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,name ='Child Active' & !<-- Name of the attribute to extract - ,itemCount=NUM_CHILDREN & !<-- # of items in the Attribute - ,valueList=CHILD_ACTIVE & !<-- Which children participate in digital filtering? - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert child DFI flags into P-C cpl export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state =EXP_STATE & !<-- This Parent_child Coupler export state - ,name ='Child Active' & !<-- Name of the attribute to extract - ,itemCount=NUM_CHILDREN & !<-- # of words in the data - ,valueList=CHILD_ACTIVE & !<-- Which children participate in digital filtering? - ,rc =RC) -! - ENDIF -! -!----------------------------------------------------------------------- -! - IF(RC_CPL_INIT==ESMF_SUCCESS)THEN -! WRITE(0,*)"PARENT_CHILD_CPL INITIALIZE STEP SUCCEEDED" - ELSE - WRITE(0,*)"PARENT_CHILD_CPL INITIALIZE STEP FAILED" - ENDIF -! - RC_FINAL=RC_CPL_INIT -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PARENT_CHILD_CPL_INITIALIZE1 -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE PARENT_CHILD_CPL_INITIALIZE2(CPL_COMP & - ,IMP_STATE & - ,EXP_STATE & - ,CLOCK & - ,RC_FINAL) -! -!----------------------------------------------------------------------- -!*** Perform final work needed by the Parent-Child coupler. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument variables -!------------------------ -! - TYPE(ESMF_CplComp) :: CPL_COMP !<-- The Parent-Child Coupler Component -! - TYPE(ESMF_State) :: IMP_STATE & !<-- The Coupler's Import State - ,EXP_STATE !<-- The Coupler's Export State -! - TYPE(ESMF_Clock) :: CLOCK !<-- The ESMF Clock -! - INTEGER,INTENT(OUT) :: RC_FINAL -! -!--------------------- -!*** Local variables -!--------------------- -! - INTEGER(kind=KINT) :: CONFIG_ID & - ,ID_CHILD,KR & - ,MINUTES_RESTART,MY_DOMAIN_ID & - ,N,N_FIELD,N_MOVING,N1,N2,NN & - ,NROWS_P_UPD_X,NTAG,NTIMESTEP & - ,NUM_CHILD_TASKS,NUM_DIMS,NV & - ,SFC_FILE_RATIO,UPDATE_TYPE_INT -! - INTEGER(kind=KINT) :: IERR,ISTAT,RC,RC_CPL_INIT -! - INTEGER(kind=ESMF_KIND_I8) :: NTIMESTEP_ESMF -! - INTEGER(kind=KINT),DIMENSION(1:3) :: LIMITS_LO,LIMITS_HI -! - INTEGER,DIMENSION(MPI_STATUS_SIZE) :: JSTAT -! - REAL(kind=KFPT) :: DPH_1,DLM_1 & - ,SBD_1,WBD_1 & - ,TPH0D_1,TLM0D_1 -! - REAL(kind=KFPT) :: LATITUDE_LIMIT -! - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: DUMMY_3D=>NULL() -! - REAL(kind=DOUBLE) :: D2R,D_ONE,D_180,FACTOR1,FACTOR2,PI -! - LOGICAL(kind=KLOG) :: FOUND -! - LOGICAL(kind=KLOG) :: I_AM_A_NEST & - ,INTEGRATE_TIMESTEP -! - CHARACTER(len=1) :: UPDATE_TYPE_CHAR - CHARACTER(len=2) :: INT_TO_CHAR - CHARACTER(len=6) :: FMT='(I2.2)' - CHARACTER(len=99) :: FIELD_NAME -! - TYPE(COMPOSITE),POINTER :: CC -! - TYPE(ESMF_TypeKind_Flag) :: DATATYPE -! - TYPE(ESMF_Field) :: HOLD_FIELD -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Initialize the error signal variables. -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RC_FINAL =ESMF_SUCCESS - RC_CPL_INIT=ESMF_SUCCESS -! -!---------------------- -!*** This domain's ID -!---------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Init2: Extract Current Domain ID" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='MY_DOMAIN_ID' & !<-- Name of the attribute to extract - ,value=MY_DOMAIN_ID & !<-- Current domain's ID - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Point to this domain's values in the composite object. -!----------------------------------------------------------------------- -! - CALL POINT_TO_COMPOSITE(MY_DOMAIN_ID) -! - CC=>CPL_COMPOSITE(MY_DOMAIN_ID) !<-- Use dummy for shorter reference to composite -! -!----------------------------------------------------------------------- -! - NUM_CHILDREN=>cc%NUM_CHILDREN !<-- How many children does this domain have? -! - D_ONE=1. - D_180=180. - PI=DACOS(-D_ONE) - D2R=PI/D_180 -! -!----------------------------------------------------------------------- -!*** Begin the work of the parents. -!----------------------------------------------------------------------- -! - parent_block_2: IF(NUM_CHILDREN>0)THEN -! -!----------------------------------------------------------------------- -!*** Allocate arrays for the parents' tracking of when children have -!*** data ready to send in 2-way nesting. Also initialize the flag -!*** that allows DOMAIN_RUN to always be called during the first -!*** pass through NMM_INTEGRATE. For 1-way nesting the flag will -!*** remain TRUE and never be reset. -!----------------------------------------------------------------------- -! - IF(NUM_2WAY_CHILDREN>0)THEN - ALLOCATE(cc%SIGNAL_2WAY_SEND_READY(1:NUM_2WAY_CHILDREN),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%SIGNAL_2WAY_SEND_READY stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - SIGNAL_2WAY_SEND_READY=>cc%SIGNAL_2WAY_SEND_READY -! - DO N=1,NUM_2WAY_CHILDREN - SIGNAL_2WAY_SEND_READY(N)=.FALSE. - ENDDO -! - ALLOCATE(cc%SKIP_2WAY_UPDATE(1:NUM_CHILDREN),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%SKIP_2WAY_UPDATE stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - SKIP_2WAY_UPDATE=>cc%SKIP_2WAY_UPDATE -! - DO N=1,NUM_CHILDREN - SKIP_2WAY_UPDATE(N)=.FALSE. - ENDDO -! - ENDIF -! - ALLOCATE(cc%HANDLE_SEND_ALLCLEAR(1:NUM_CHILDREN),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%HANDLE_SEND_ALLCLEAR stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - HANDLE_SEND_ALLCLEAR=>cc%HANDLE_SEND_ALLCLEAR -! - DO N=1,NUM_CHILDREN - HANDLE_SEND_ALLCLEAR(N)=MPI_REQUEST_NULL - ENDDO -! - cc%KOUNT_2WAY_CHILDREN=0 -! - cc%FIRST_CALL_RECV_2WAY=.TRUE. - INTEGRATE_TIMESTEP=.TRUE. - cc%RECV_ALL_CHILD_DATA=.TRUE. -! - RECV_ALL_CHILD_DATA=>cc%RECV_ALL_CHILD_DATA -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Init2: Set Integrate Flag" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The P-C coupler's export state - ,name ='Integrate Flag' & - ,value=INTEGRATE_TIMESTEP & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Init2: Set Recv Flag for Child Data" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The P-C coupler's export state - ,name ='Recv All Child Data' & - ,value=RECV_ALL_CHILD_DATA & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Write/quilt tasks return now since the rest of the routine -!*** is directly or indirectly related to the grid. -!----------------------------------------------------------------------- -! - IF(.NOT.I_AM_A_FCST_TASK)RETURN -! -!----------------------------------------------------------------------- -!*** Allocate the pointers that will hold all of the interpolated -!*** boundary data for the child tasks if the parent task contains -!*** child boundary points on the four sides. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** The data pointer within the CHILD_BOUND_* arrays will -!*** hold the boundary data of each child tasks' boundary data in a -!*** 1-D string that will be used to send the data from the parent -!*** to the child tasks. The *_B_* arrays are what will be sent -!*** into subroutine PARENT_TO_CHILD_BNDRY_COMPUTE where the -!*** actual computations of the boundary data are carried out. -!*** The unallocated subcomponents of the *_B_* arrays are filled -!*** by the routine and thus the 1-D string will automatically -!*** be filled and ready for sending to each child task that contains -!*** boundary points. -! -!*** NOTE the heirarchy of the derived data variables' pointers -!*** that hold the boundary data: -! -!*** (1) Primary variable dimensioned 1-D over the children. -!*** (2) For each child, TASKS is dimensioned 1-D over the given -!*** child's tasks that contain segments of boundary on the -!*** parent task. -!*** (3) For each child task, DATA is dimensioned 1-D since -!*** 1-D strings are required for MPI Send/Recv. -!*** (a) The 1-D CHILD_BOUND_* DATA pointers are allocated -!*** and are filled with the child boundary data destined -!*** for each individual child task that contains any -!*** segment of a child's boundary on a given parent -!*** task. -!*** (b) The specific boundary variables (T_B_*, Q_B_*, etc.) -!*** DATA subcomponent pointers are declared but never -!*** allocated and instead are simply pointed into the -!*** allocated 1-D CHILD_BOUND_* DATA subcomponent pointer. -!*** These specific boundary variables are sent into the -!*** subroutine where the child boundary data is computed -!*** which then leads to the allocated CHILD_BOUND_* 1-D -!*** DATA pointer being filled automatically. Thus the -!*** allocated 1-D pointer is immediately ready for subsequent -!*** sending to child tasks. -!*** The subcomponent pointer for PD_B_* though must be -!*** allocated. That is because it contains values one row -!*** beyond those actually needed to be sent to the child -!*** tasks to update their boundary values of PD. That -!*** extra row is used to do 4-pt averaging to obtain PD -!*** on V points within the nests' boundary regions which -!*** is needed to do the hydrostatic updating of the winds -!*** there. So the PD_B sections of the full 1-D DATA -!*** pointer CHILD_BOUND_* that is actually sent from -!*** parents to children must be filled explicitly inside -!*** subroutine PARENT_UPDATE_CHILD_PSFC. -!----------------------------------------------------------------------- -! - ALLOCATE(cc%CHILD_BOUND_H_SOUTH(1:NUM_CHILDREN,1:2),stat=ISTAT) !<-- 1-D bndry data string for child tasks with Sbndry H points - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%CHILD_BOUND_H_SOUTH stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - CHILD_BOUND_H_SOUTH=>cc%CHILD_BOUND_H_SOUTH -! - ALLOCATE(cc%CHILD_BOUND_V_SOUTH(1:NUM_CHILDREN,1:2),stat=ISTAT) !<-- 1-D bndry data string for child tasks with Sbndry V points - CHILD_BOUND_V_SOUTH=>cc%CHILD_BOUND_V_SOUTH -! -!----------------------------------------------------------------------- -! - ALLOCATE(cc%WORDS_BOUND_H_SOUTH(1:NUM_CHILDREN),stat=ISTAT) !<-- # of words in Sbndry H point 1-D data string - WORDS_BOUND_H_SOUTH=>cc%WORDS_BOUND_H_SOUTH -! - ALLOCATE(cc%WORDS_BOUND_V_SOUTH(1:NUM_CHILDREN),stat=ISTAT) !<-- # of words in Sbndry V point 1-D data string - WORDS_BOUND_V_SOUTH=>cc%WORDS_BOUND_V_SOUTH -! -!----------------------------------------------------------------------- -! - ALLOCATE(cc%PD_B_SOUTH(1:NUM_CHILDREN),stat=ISTAT) !<-- South boundary PD on H points - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%PD_B_SOUTH stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - PD_B_SOUTH=>cc%PD_B_SOUTH -! - ALLOCATE(cc%PD_B_SOUTH_V(1:NUM_CHILDREN),stat=ISTAT) !<-- South boundary PD on V points - PD_B_SOUTH_V=>cc%PD_B_SOUTH_V -! -!----------------------------------------------------------------------- -!*** Allocate the working objects used by the parents for H-pt -!*** update variables on the nest boundaries. Exclude PD since -!*** it must be handled separately (thus the '-1' in the allocates). -!----------------------------------------------------------------------- -! - ALLOCATE(cc%BND_VAR_H_SOUTH(1:NVARS_NESTBC_H-1),stat=ISTAT) - IF(ISTAT>0)THEN - WRITE(0,11001)NVARS_NESTBC_H-1,ISTAT -11001 FORMAT(' P-C Init2 failed to allocate BND_VAR_H_SOUTH(1:',I2,') istat=',i3) - ENDIF - ALLOCATE(cc%BND_VAR_H_NORTH(1:NVARS_NESTBC_H-1),stat=ISTAT) - ALLOCATE(cc%BND_VAR_H_WEST (1:NVARS_NESTBC_H-1),stat=ISTAT) - ALLOCATE(cc%BND_VAR_H_EAST (1:NVARS_NESTBC_H-1),stat=ISTAT) -! - DO NV=1,NVARS_NESTBC_H-1 - ALLOCATE(cc%BND_VAR_H_SOUTH(NV)%CHILD(1:NUM_CHILDREN),stat=ISTAT) - IF(ISTAT>0)THEN - WRITE(0,11011)NV,NUM_CHILDREN,ISTAT -11011 FORMAT(' P-C Init2 failed to allocate BND_VAR_H_SOUTH(',I2,')%CHILD(1:',I2,') istat=',i3) - ENDIF - ALLOCATE(cc%BND_VAR_H_NORTH(NV)%CHILD(1:NUM_CHILDREN),stat=ISTAT) - ALLOCATE(cc%BND_VAR_H_WEST(NV)%CHILD(1:NUM_CHILDREN),stat=ISTAT) - ALLOCATE(cc%BND_VAR_H_EAST(NV)%CHILD(1:NUM_CHILDREN),stat=ISTAT) - ENDDO -! - BND_VAR_H_SOUTH=>cc%BND_VAR_H_SOUTH - BND_VAR_H_NORTH=>cc%BND_VAR_H_NORTH - BND_VAR_H_WEST =>cc%BND_VAR_H_WEST - BND_VAR_H_EAST =>cc%BND_VAR_H_EAST -! -!----------------------------------------------------------------------- -!*** Allocate the working objects used by the parents for V-pt -!*** update variables on the nest boundaries. -!----------------------------------------------------------------------- -! - ALLOCATE(cc%BND_VAR_V_SOUTH(1:NVARS_NESTBC_V),stat=ISTAT) - ALLOCATE(cc%BND_VAR_V_NORTH(1:NVARS_NESTBC_V),stat=ISTAT) - ALLOCATE(cc%BND_VAR_V_WEST (1:NVARS_NESTBC_V),stat=ISTAT) - ALLOCATE(cc%BND_VAR_V_EAST (1:NVARS_NESTBC_V),stat=ISTAT) -! - DO NV=1,NVARS_NESTBC_V - ALLOCATE(cc%BND_VAR_V_SOUTH(NV)%CHILD(1:NUM_CHILDREN),stat=ISTAT) - ALLOCATE(cc%BND_VAR_V_NORTH(NV)%CHILD(1:NUM_CHILDREN),stat=ISTAT) - ALLOCATE(cc%BND_VAR_V_WEST(NV)%CHILD(1:NUM_CHILDREN),stat=ISTAT) - ALLOCATE(cc%BND_VAR_V_EAST(NV)%CHILD(1:NUM_CHILDREN),stat=ISTAT) - ENDDO -! - BND_VAR_V_SOUTH=>cc%BND_VAR_V_SOUTH - BND_VAR_V_NORTH=>cc%BND_VAR_V_NORTH - BND_VAR_V_WEST =>cc%BND_VAR_V_WEST - BND_VAR_V_EAST =>cc%BND_VAR_V_EAST -! -!----------------------------------------------------------------------- -! - ALLOCATE(cc%CHILD_BOUND_H_NORTH(1:NUM_CHILDREN,1:2),stat=ISTAT) !<-- 1-D bndry data string for child tasks with Nbndry H points - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%CHILD_BOUND_H_NORTH stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - CHILD_BOUND_H_NORTH=>cc%CHILD_BOUND_H_NORTH -! - ALLOCATE(cc%CHILD_BOUND_V_NORTH(1:NUM_CHILDREN,1:2),stat=ISTAT) !<-- 1-D bndry data string for child tasks with Nbndry V points - CHILD_BOUND_V_NORTH=>cc%CHILD_BOUND_V_NORTH -! -!----------------------------------------------------------------------- -! - ALLOCATE(cc%WORDS_BOUND_H_NORTH(1:NUM_CHILDREN),stat=ISTAT) !<-- # of words in Nbndry H point 1-D data string - WORDS_BOUND_H_NORTH=>cc%WORDS_BOUND_H_NORTH -! - ALLOCATE(cc%WORDS_BOUND_V_NORTH(1:NUM_CHILDREN),stat=ISTAT) !<-- # of words in Nbndry V point 1-D data string - WORDS_BOUND_V_NORTH=>cc%WORDS_BOUND_V_NORTH -! -!----------------------------------------------------------------------- -! - ALLOCATE(cc%PD_B_NORTH(1:NUM_CHILDREN),stat=ISTAT) !<-- North boundary PD on H points - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%PD_B_NORTH stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - PD_B_NORTH=>cc%PD_B_NORTH -! - ALLOCATE(cc%PD_B_NORTH_V(1:NUM_CHILDREN),stat=ISTAT) !<-- North boundary PD on V points - PD_B_NORTH_V=>cc%PD_B_NORTH_V -! -!----------------------------------------------------------------------- -! - ALLOCATE(cc%CHILD_BOUND_H_WEST(1:NUM_CHILDREN,1:2),stat=ISTAT) !<-- 1-D bndry data string for child tasks with Wbndry H points - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%CHILD_BOUND_H_WEST stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - CHILD_BOUND_H_WEST=>cc%CHILD_BOUND_H_WEST -! - ALLOCATE(cc%CHILD_BOUND_V_WEST(1:NUM_CHILDREN,1:2),stat=ISTAT) !<-- 1-D bndry data string for child tasks with Wbndry V points - CHILD_BOUND_V_WEST=>cc%CHILD_BOUND_V_WEST -! -!----------------------------------------------------------------------- -! - ALLOCATE(cc%WORDS_BOUND_H_WEST(1:NUM_CHILDREN),stat=ISTAT) !<-- # of words in Wbndry H point 1-D data string - WORDS_BOUND_H_WEST=>cc%WORDS_BOUND_H_WEST -! - ALLOCATE(cc%WORDS_BOUND_V_WEST(1:NUM_CHILDREN),stat=ISTAT) !<-- # of words in Wbndry V point 1-D data string - WORDS_BOUND_V_WEST=>cc%WORDS_BOUND_V_WEST -! -!----------------------------------------------------------------------- -! - ALLOCATE(cc%PD_B_WEST(1:NUM_CHILDREN),stat=ISTAT) !<-- West boundary PD on H points - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%PD_B_WEST stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - PD_B_WEST=>cc%PD_B_WEST -! - ALLOCATE(cc%PD_B_WEST_V(1:NUM_CHILDREN),stat=ISTAT) !<-- West boundary PD on V points - PD_B_WEST_V=>cc%PD_B_WEST_V -! -!----------------------------------------------------------------------- -! - ALLOCATE(cc%CHILD_BOUND_H_EAST(1:NUM_CHILDREN,1:2),stat=ISTAT) !<-- 1-D bndry data string for child tasks with Ebndry H points - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%CHILD_BOUND_H_EAST stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - CHILD_BOUND_H_EAST=>cc%CHILD_BOUND_H_EAST -! - ALLOCATE(cc%CHILD_BOUND_V_EAST(1:NUM_CHILDREN,1:2),stat=ISTAT) !<-- 1-D bndry data string for child tasks with Ebndry V points - CHILD_BOUND_V_EAST=>cc%CHILD_BOUND_V_EAST -! - ALLOCATE(cc%WORDS_BOUND_H_EAST(1:NUM_CHILDREN),stat=ISTAT) !<-- # of words in Ebndry H point 1-D data string - WORDS_BOUND_H_EAST=>cc%WORDS_BOUND_H_EAST -! - ALLOCATE(cc%WORDS_BOUND_V_EAST(1:NUM_CHILDREN),stat=ISTAT) !<-- # of words in Ebndry V point 1-D data string - WORDS_BOUND_V_EAST=>cc%WORDS_BOUND_V_EAST -! -!----------------------------------------------------------------------- -! - ALLOCATE(cc%PD_B_EAST(1:NUM_CHILDREN),stat=ISTAT) !<-- East boundary PD on H points - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%PD_B_EAST stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - PD_B_EAST=>cc%PD_B_EAST -! - ALLOCATE(cc%PD_B_EAST_V(1:NUM_CHILDREN),stat=ISTAT) !<-- East boundary PD on V points - PD_B_EAST_V=>cc%PD_B_EAST_V -! - DO NN=1,2 - DO N=1,NUM_CHILDREN - CHILD_BOUND_H_SOUTH(N,NN)%TASKS=>NULL() - CHILD_BOUND_H_NORTH(N,NN)%TASKS=>NULL() - CHILD_BOUND_H_WEST(N,NN)%TASKS=>NULL() - CHILD_BOUND_H_EAST(N,NN)%TASKS=>NULL() - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** Allocate dummy subcomponents for the working pointers for (N,2) -!*** which correspond to values used when parents must send BC data -!*** to a nest immediately after it has moved, i.e., for that nest's -!*** current time and not for its future time. Pointers for (N,1) -!*** will always be allocated ahead of deallocation since they are -!*** continually needed for the parent's sending BC data to all the -!*** nests from their future. -!*** In the normal sequence these working pointers are deallocated -!*** each time a nest moves so that they can be reallocated properly -!*** for the given association of parent and nest tasks. Therefore -!*** they must be allocated already for the deallocations that take -!*** place with each nest's first move. -!----------------------------------------------------------------------- -! - DO N=1,NUM_CHILDREN -! - ALLOCATE(CHILD_BOUND_H_SOUTH(N,2)%TASKS(1)) - ALLOCATE(CHILD_BOUND_V_SOUTH(N,2)%TASKS(1)) - CHILD_BOUND_H_SOUTH(N,2)%TASKS(1)%DATA=>NULL() - CHILD_BOUND_V_SOUTH(N,2)%TASKS(1)%DATA=>NULL() -! - ALLOCATE(CHILD_BOUND_H_NORTH(N,2)%TASKS(1)) - ALLOCATE(CHILD_BOUND_V_NORTH(N,2)%TASKS(1)) - CHILD_BOUND_H_NORTH(N,2)%TASKS(1)%DATA=>NULL() - CHILD_BOUND_V_NORTH(N,2)%TASKS(1)%DATA=>NULL() -! - ALLOCATE(CHILD_BOUND_H_WEST(N,2)%TASKS(1)) - ALLOCATE(CHILD_BOUND_V_WEST(N,2)%TASKS(1)) - CHILD_BOUND_H_WEST(N,2)%TASKS(1)%DATA=>NULL() - CHILD_BOUND_V_WEST(N,2)%TASKS(1)%DATA=>NULL() -! - ALLOCATE(CHILD_BOUND_H_EAST(N,2)%TASKS(1)) - ALLOCATE(CHILD_BOUND_V_EAST(N,2)%TASKS(1)) - CHILD_BOUND_H_EAST(N,2)%TASKS(1)%DATA=>NULL() - CHILD_BOUND_V_EAST(N,2)%TASKS(1)%DATA=>NULL() -! - ENDDO -! -!----------------------------------------------------------------------- -!*** Allocate logical flags indicating if parent task holds any -!*** child boundary points for the purpose of sending that data -!*** to pertinent child tasks. -!----------------------------------------------------------------------- -! - ALLOCATE(cc%SEND_CHILD_DATA(1:NUM_CHILDREN),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%SEND_CHILD_DATA stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - SEND_CHILD_DATA=>cc%SEND_CHILD_DATA -! -!----------------------------------------------------------------------- -!*** Allocate the handles to be used by parent tasks when they ISend -!*** data directly to the appropiate child boundary tasks. The 2nd -!*** dimension is 2 because these handles are used in two different -!*** and essentially independent situations. The first is when the -!*** parents send their children the usual boundary updates from the -!*** children's future so that the children can compute time tendencies -!*** for their integration through the next parent timestep. The -!*** second is when parents send their moving children the same set -!*** of boundary values that they will receive at one of their -!*** current timesteps immediately after they move to a new location. -!*** Those values will serve as the time N values in the subsequent -!*** tendency computations for variable X: [X(N+1)-X(N)]/DT(parent) -!*** Note that while the 2nd dimension of all children is 2, the -!*** Handles' subcomponents associated with that index's value of 2 -!*** will be allocated and used only for moving nests. -!----------------------------------------------------------------------- -! - ALLOCATE(cc%HANDLE_H_SOUTH(1:NUM_CHILDREN,1:2),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%HANDLE_H_SOUTH stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - HANDLE_H_SOUTH=>cc%HANDLE_H_SOUTH -! - ALLOCATE(cc%HANDLE_H_NORTH(1:NUM_CHILDREN,1:2),stat=ISTAT) - HANDLE_H_NORTH=>cc%HANDLE_H_NORTH -! - ALLOCATE(cc%HANDLE_H_WEST(1:NUM_CHILDREN,1:2),stat=ISTAT) - HANDLE_H_WEST=>cc%HANDLE_H_WEST -! - ALLOCATE(cc%HANDLE_H_EAST(1:NUM_CHILDREN,1:2),stat=ISTAT) - HANDLE_H_EAST=>cc%HANDLE_H_EAST -! - ALLOCATE(cc%HANDLE_V_SOUTH(1:NUM_CHILDREN,1:2),stat=ISTAT) - HANDLE_V_SOUTH=>cc%HANDLE_V_SOUTH -! - ALLOCATE(cc%HANDLE_V_NORTH(1:NUM_CHILDREN,1:2),stat=ISTAT) - HANDLE_V_NORTH=>cc%HANDLE_V_NORTH -! - ALLOCATE(cc%HANDLE_V_WEST(1:NUM_CHILDREN,1:2),stat=ISTAT) - HANDLE_V_WEST=>cc%HANDLE_V_WEST -! - ALLOCATE(cc%HANDLE_V_EAST(1:NUM_CHILDREN,1:2),stat=ISTAT) - HANDLE_V_EAST=>cc%HANDLE_V_EAST -! - DO N=1,NUM_CHILDREN -! - ALLOCATE(HANDLE_H_SOUTH(N,2)%NTASKS_TO_RECV(1)) - ALLOCATE(HANDLE_V_SOUTH(N,2)%NTASKS_TO_RECV(1)) - ALLOCATE(HANDLE_H_NORTH(N,2)%NTASKS_TO_RECV(1)) - ALLOCATE(HANDLE_V_NORTH(N,2)%NTASKS_TO_RECV(1)) - ALLOCATE(HANDLE_H_WEST(N,2)%NTASKS_TO_RECV(1)) - ALLOCATE(HANDLE_V_WEST(N,2)%NTASKS_TO_RECV(1)) - ALLOCATE(HANDLE_H_EAST(N,2)%NTASKS_TO_RECV(1)) - ALLOCATE(HANDLE_V_EAST(N,2)%NTASKS_TO_RECV(1)) -! - HANDLE_H_SOUTH(N,2)%NTASKS_TO_RECV(1)=MPI_REQUEST_NULL - HANDLE_V_SOUTH(N,2)%NTASKS_TO_RECV(1)=MPI_REQUEST_NULL - HANDLE_H_NORTH(N,2)%NTASKS_TO_RECV(1)=MPI_REQUEST_NULL - HANDLE_V_NORTH(N,2)%NTASKS_TO_RECV(1)=MPI_REQUEST_NULL - HANDLE_H_WEST(N,2)%NTASKS_TO_RECV(1)=MPI_REQUEST_NULL - HANDLE_V_WEST(N,2)%NTASKS_TO_RECV(1)=MPI_REQUEST_NULL - HANDLE_H_EAST(N,2)%NTASKS_TO_RECV(1)=MPI_REQUEST_NULL - HANDLE_V_EAST(N,2)%NTASKS_TO_RECV(1)=MPI_REQUEST_NULL -! - ENDDO -! -!----------------------------------------------------------------------- -!*** Point unallocated working pointers of parent's interpolated data -!*** into the allocated composite pointer holding all boundary data -!*** to be sent to each child from their future. -!----------------------------------------------------------------------- -! - DO N=1,NUM_CHILDREN - CALL POINT_INTERP_DATA_TO_MEMORY(N,MY_DOMAIN_ID,'Future') - ENDDO -! -!----------------------------------------------------------------------- -!*** Allocate an array of logical flags the parent will use for its -!*** moving children to know when they want to move. -!*** Also allocate the composite data object that will hold all of -!*** the update data the parent sends to its moving children and -!*** the associated Handles for the ISends. -!----------------------------------------------------------------------- -! - IF(NUM_MOVING_CHILDREN>0)THEN - ALLOCATE(cc%MOVE_FLAG(1:NUM_MOVING_CHILDREN),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%MOVE_FLAG stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - MOVE_FLAG=>cc%MOVE_FLAG - MY_CHILDREN_ID=>cc%MY_CHILDREN_ID -! - ALLOCATE(cc%HANDLE_BC_UPDATE(1:NUM_MOVING_CHILDREN),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%HANDLE_BC_UPDATE stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - HANDLE_BC_UPDATE=>cc%HANDLE_BC_UPDATE -! - ALLOCATE(cc%HANDLE_TIMESTEP(1:NUM_MOVING_CHILDREN),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%HANDLE_TIMESTEP stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - HANDLE_TIMESTEP=>cc%HANDLE_TIMESTEP -! - ALLOCATE(cc%HANDLE_MOVE_DATA(1:NUM_MOVING_CHILDREN),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%HANDLE_MOVE_DATA stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - HANDLE_MOVE_DATA=>cc%HANDLE_MOVE_DATA -! - DO N=1,NUM_MOVING_CHILDREN - MOVE_FLAG(N) =.FALSE. - HANDLE_BC_UPDATE(N)=MPI_REQUEST_NULL - HANDLE_TIMESTEP(N) =MPI_REQUEST_NULL -! - N_MOVING=RANK_MOVING_CHILD(N) - NUM_CHILD_TASKS=FTASKS_DOMAIN(MY_CHILDREN_ID(N_MOVING)) - ALLOCATE(HANDLE_MOVE_DATA(N)%NTASKS_TO_RECV(1:NUM_CHILD_TASKS)) -! - DO NN=1,NUM_CHILD_TASKS - HANDLE_MOVE_DATA(N)%NTASKS_TO_RECV(NN)=MPI_REQUEST_NULL - ENDDO - ENDDO -! - ALLOCATE(cc%TASK_UPDATE_SPECS(1:NUM_MOVING_CHILDREN),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%TASK_UPDATE_SPECS stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - TASK_UPDATE_SPECS=>cc%TASK_UPDATE_SPECS -! - ALLOCATE(cc%MOVING_CHILD_UPDATE(1:NUM_MOVING_CHILDREN),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%MOVING_CHILD_UPDATE stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - MOVING_CHILD_UPDATE=>cc%MOVING_CHILD_UPDATE -! - DO N=1,NUM_MOVING_CHILDREN - TASK_UPDATE_SPECS(N)%TASK_ID=>NULL() - TASK_UPDATE_SPECS(N)%NUM_PTS_UPDATE_HZ=>NULL() - TASK_UPDATE_SPECS(N)%NEXT_LINK=>NULL() - MOVING_CHILD_UPDATE(N)%TASKS=>NULL() - ENDDO -! - ALLOCATE(cc%SHIFT_INFO_CHILDREN(1:4,1:NUM_MOVING_CHILDREN),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%SHIFT_INFO_CHILDREN stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - SHIFT_INFO_CHILDREN=>cc%SHIFT_INFO_CHILDREN -! - DO N2=1,NUM_MOVING_CHILDREN - DO N1=1,4 - SHIFT_INFO_CHILDREN(N1,N2)=0 - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** If this is a restarted run then take the value of the children's -!*** next move timestep from the import state (the values having -!*** originated from the Solver's read of the restart file). -!----------------------------------------------------------------------- -! - IF(RESTART)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Init2: Get Next Move Timestep of Children for Restart" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The Parent-Child coupler import state - ,name ='NEXT_TIMESTEP_CHILD_MOVES' & !<-- Name in import state - ,valueList=cc%NTIMESTEP_CHILD_MOVES & !<-- The next timestep the moving children move - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF -! -!----------------------------------------------------------------------- -! - cc%NCYCLE_PARENT=0 -! -!----------------------------------------------------------------------- -! - ENDIF parent_block_2 -! -!----------------------------------------------------------------------- -!*** Both parent and child need to know the child's shift information. -!----------------------------------------------------------------------- -! - ALLOCATE(cc%SHIFT_INFO_MINE(1:4),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%SHIFT_INFO_MINE stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - SHIFT_INFO_MINE=>cc%SHIFT_INFO_MINE -! - DO N=1,4 - SHIFT_INFO_MINE(N)=-99999 - ENDDO -! -!----------------------------------------------------------------------- -! - I_AM_A_NEST=.TRUE. -! - IF(COMM_TO_MY_PARENT==-999)THEN !<-- The uppermost parent - I_AM_A_NEST=.FALSE. - ENDIF -! -!----------------------------------------------------------------------- -!*** Everyone loads the coupler export state with the flag indicating -!*** whether or not they are a nest. Nests load the flag indicating -!*** if they move or not. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert Nest Flag into the Coupler Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child coupler export state - ,name ='I-Am-A-Nest Flag' & !<-- The name of the flag - ,value=I_AM_A_NEST & !<-- The nest flag - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - IF(I_AM_A_NEST)THEN -! -!----------------------------------------------------------------------- -!*** If this child moves then a variety of motion-related issues -!*** are now taken care of. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert Moving Nest Flag into the Coupler Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child coupler export state - ,name ='MY_DOMAIN_MOVES' & !<-- The name of the flag - ,value=MY_DOMAIN_MOVES & !<-- The moving nest flag - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** If this is not a restarted run then initialize the value of -!*** the nest's next move timestep to nonsense. If this is a -!*** restarted run then the value originated in the restart file -!*** and was obtained through the P-C coupler import state in -!*** PARENT_CHILD_COUPLER_SETUP. -!----------------------------------------------------------------------- -! - NEXT_MOVE_TIMESTEP=>cc%NEXT_MOVE_TIMESTEP -! - IF(.NOT.RESTART)THEN - NEXT_MOVE_TIMESTEP=-999999 - ENDIF -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Init2: Insert NEST_MOVE_TIMESTEP into P-C Cpl Exp State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child coupler export state - ,name ='NEXT_MOVE_TIMESTEP' & !<-- The name of the Attribute - ,value=NEXT_MOVE_TIMESTEP & !<-- Initialized value for nest's next move timestep - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - I_SHIFT_CHILD=>cc%I_SHIFT_CHILD - J_SHIFT_CHILD=>cc%J_SHIFT_CHILD - I_SHIFT_CHILD=-999999 - J_SHIFT_CHILD=-999999 -! - I_SW_PARENT_NEW=>cc%I_SW_PARENT_NEW - J_SW_PARENT_NEW=>cc%J_SW_PARENT_NEW - I_SW_PARENT_NEW=-999999 - J_SW_PARENT_NEW=-999999 -! - LAST_STEP_MOVED=>cc%LAST_STEP_MOVED -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Init2: Insert I_SHIFT/J_SHIFT into P-C Cpl Exp State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent-Child coupler export state - ,name ='I_SHIFT' & !<-- Insert Attribute with this name - ,value=I_SHIFT_CHILD & !<-- Motion of nest in I on its grid - ,rc =RC ) -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent-Child coupler export state - ,name ='J_SHIFT' & !<-- Insert Attribute with this name - ,value=J_SHIFT_CHILD & !<-- Motion of nest in J on its grid - ,rc =RC ) -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent-Child coupler export state - ,name ='I_SW_PARENT_NEW' & !<-- Insert Attribute with this name - ,value=I_SW_PARENT_NEW & !<-- Motion of nest in I on its grid - ,rc =RC ) -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent-Child coupler export state - ,name ='J_SW_PARENT_NEW' & !<-- Insert Attribute with this name - ,value=J_SW_PARENT_NEW & !<-- Motion of nest in J on its grid - ,rc =RC ) -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent-Child coupler export state - ,name ='LAST_STEP_MOVED' & !<-- Insert Attribute with this name - ,value=LAST_STEP_MOVED & !<-- Motion of nest in J on its grid - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - I_WANT_TO_MOVE=>cc%I_WANT_TO_MOVE - MOVE_FLAG_SENT=>cc%MOVE_FLAG_SENT -! - I_WANT_TO_MOVE=.FALSE. !<-- Initialize the nest 'move' flag - MOVE_FLAG_SENT=.FALSE. !<-- Initialize the flag for ISending the nest move flag -! - HANDLE_MOVE_FLAG=>cc%HANDLE_MOVE_FLAG - HANDLE_MOVE_FLAG=MPI_REQUEST_NULL -! -!----------------------------------------------------------------------- -!*** Allocate variables for children's handling their data exchange -!*** with parents in 2-way nesting. -!----------------------------------------------------------------------- -! - IF(NEST_MODE=='2-way')THEN -! -!----------------------------------------------------------------------- -! - HANDLE_SEND_2WAY_SIGNAL=>cc%HANDLE_SEND_2WAY_SIGNAL -! - HANDLE_SEND_2WAY_SIGNAL=MPI_REQUEST_NULL -! - cc%FIRST_CALL_RECV_BC=.TRUE. -! - cc%NTIMESTEP_CHECK=-99999 -! - cc%NCYCLE_CHILD=0 -! - ENDIF -! - ENDIF -! -! ALLCLEAR=.TRUE. - ALLCLEAR_SIGNAL_PRESENT=.FALSE. - STOP_MY_MOTION=.FALSE. -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Init2: Insert Initial ALLCLEAR Flag" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child coupler export state - ,name ='ALLCLEAR' & !<-- The name of the flag - ,value=ALLCLEAR_SIGNAL_PRESENT & !<-- The moving nest flag - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Now take care of several issues related to moving nests. -!*** All moving nests and their parents must participate. -!----------------------------------------------------------------------- -! - parents_and_moving: IF(NUM_MOVING_CHILDREN>0 & !<-- This is a parent of moving nests. - .OR. & ! - MY_DOMAIN_MOVES)THEN !<-- This is a moving nest. -! -!----------------------------------------------------------------------- -!*** Extract the Bundle with the 2-D and 3-D arrays of Solver -!*** internal state variables needed for updating any nests that -!*** are moving. Since the eventual update of moving nest data -!*** will be done via looping through the Fields in the Bundles -!*** we need to know how many Fields there are. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Bundles for Updates of Moving Nests in P-C Init" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =IMP_STATE & !<-- The Parent-Child coupler import state - ,itemname ='Move_Bundle H' & !<-- Name of Bundle of internal state arrays to update - ,fieldbundle=MOVE_BUNDLE_H & !<-- The H-point ESMF Bundle - ,rc =RC) -! - CALL ESMF_StateGet(state =IMP_STATE & !<-- The Parent-Child coupler import state - ,itemname ='Move_Bundle V' & !<-- Name of Bundle of internal state arrays to update - ,fieldbundle=MOVE_BUNDLE_V & !<-- The V-point ESMF Bundle - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="How many Fields in the H Bundle?" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=MOVE_BUNDLE_H & !<-- The ESMF Bundle of H update arrays for moving nests - ,fieldcount =NUM_FIELDS_MOVE & !<-- # of Fields in the Bundle - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Count the number of 2-D and 3-D Fields. Those numbers will be -!*** needed to know how many points are updated on moving nest tasks. -!*** Also initialize the flag telling parent domains they must -!*** update halos of motion-related variables after they shift. -!----------------------------------------------------------------------- -! - NUM_FIELDS_MOVE_2D_H_I=0 - NUM_FIELDS_MOVE_2D_X_I=0 - NUM_FIELDS_MOVE_2D_H_R=0 - NUM_FIELDS_MOVE_2D_X_R=0 - NUM_FIELDS_MOVE_3D_H=0 - NUM_LEVELS_MOVE_3D_H=0 -! -!----------------------------------------------------------------------- -! - DO N_FIELD=1,NUM_FIELDS_MOVE -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Fields from H Move Bundle for Counting" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=MOVE_BUNDLE_H & !<-- Bundle holding the H arrays for move updates - ,fieldIndex =N_FIELD & !<-- Index of the Field in the Bundle - ,field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="How Many Dims in H Move Bundle Field?" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,dimCount=NUM_DIMS & !<-- Is this Field 2-D or 3-D? - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract UPDATE_TYPE from Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(field=HOLD_FIELD & !<-- Get Attribute from this Field - ,name ='UPDATE_TYPE' & !<-- Name of the attribute to extract - ,value=UPDATE_TYPE_INT & !<-- Value of the Attribute - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(UPDATE_TYPE_INT==1)THEN - UPDATE_TYPE_CHAR='H' !<-- Ordinary H-pt variable - ELSEIF(UPDATE_TYPE_INT==2)THEN - UPDATE_TYPE_CHAR='L' !<-- H-pt land sfc variable - ELSEIF(UPDATE_TYPE_INT==3)THEN - UPDATE_TYPE_CHAR='S' !<-- H-pt sea sfc variable - ELSEIF(UPDATE_TYPE_INT==4)THEN - UPDATE_TYPE_CHAR='F' !<-- H-pt variable updated from external file - ELSEIF(UPDATE_TYPE_INT==5)THEN - UPDATE_TYPE_CHAR='V' !<-- Ordinary V-pt variable - ENDIF -! -!----------------------------------------------------------------------- -! - IF(NUM_DIMS==2)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Does the Field Contain Integer or Real Data?" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,typekind=DATATYPE & !<-- Is the data Integer or Real? - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(DATATYPE==ESMF_TYPEKIND_I4)THEN - NUM_FIELDS_MOVE_2D_H_I=NUM_FIELDS_MOVE_2D_H_I+1 !<-- Count ALL 2-D Integer Fields - IF(UPDATE_TYPE_CHAR=='F')THEN - NUM_FIELDS_MOVE_2D_X_I=NUM_FIELDS_MOVE_2D_X_I+1 !<-- Count the 2-D Integer variables updated from external files - ENDIF -! - ELSE - NUM_FIELDS_MOVE_2D_H_R=NUM_FIELDS_MOVE_2D_H_R+1 !<-- Count ALL 2-D Real Fields - IF(UPDATE_TYPE_CHAR=='F')THEN - NUM_FIELDS_MOVE_2D_X_R=NUM_FIELDS_MOVE_2D_X_R+1 !<-- Count the 2-D Real variables updated from external files - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -! - ELSEIF(NUM_DIMS==3)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract 3rd Dimension Limits in 3-D H Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N in the Bundle - ,localDe =0 & - ,farrayPtr =DUMMY_3D & !<-- Dummy 3-D array with Field's data - ,totalLBound=LIMITS_LO & !<-- Starting index in each dimension - ,totalUBound=LIMITS_HI & !<-- Ending index in each dimension - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NUM_FIELDS_MOVE_3D_H=NUM_FIELDS_MOVE_3D_H+1 !<-- Count the 3-D Real H Fields -! - NUM_LEVELS_MOVE_3D_H=LIMITS_HI(3)-LIMITS_LO(3)+1 & !<-- Count the # of 2-D levels in the 3-D H Fields - +NUM_LEVELS_MOVE_3D_H - ENDIF -! - ENDDO -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="How many Fields in the V Bundle?" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=MOVE_BUNDLE_V & !<-- The ESMF Bundle of V update arrays for moving nests - ,fieldcount =NUM_FIELDS_MOVE & !<-- # of Fields in the Bundle - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Count the number of 2-D and 3-D Fields. Those numbers will be -!*** needed to know how many points are updated on moving nest tasks. -!----------------------------------------------------------------------- -! - NUM_FIELDS_MOVE_2D_V=0 - NUM_FIELDS_MOVE_3D_V=0 - NUM_LEVELS_MOVE_3D_V=0 -! - DO N_FIELD=1,NUM_FIELDS_MOVE -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Fields from V Move Bundle for Counting" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=MOVE_BUNDLE_V & !<-- Bundle holding the H arrays for move updates - ,fieldIndex =N_FIELD & !<-- Index of the Field in the Bundle - ,field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="How Many Dims in V Move Bundle Field?" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,dimCount=NUM_DIMS & !<-- Is this Field 2-D or 3-D? - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(NUM_DIMS==2)THEN - NUM_FIELDS_MOVE_2D_V=NUM_FIELDS_MOVE_2D_V+1 -! - ELSEIF(NUM_DIMS==3)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract 3rd Dimension Limits in 3-D V Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N in the Bundle - ,localDe =0 & - ,farrayPtr =DUMMY_3D & !<-- Dummy 3-D array with Field's data - ,totalLBound=LIMITS_LO & !<-- Starting index in each dimension - ,totalUBound=LIMITS_HI & !<-- Ending index in each dimension - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NUM_FIELDS_MOVE_3D_V=NUM_FIELDS_MOVE_3D_V+1 !<-- Count the 3-D V Fields -! - NUM_LEVELS_MOVE_3D_V=LIMITS_HI(3)-LIMITS_LO(3)+1 & !<-- Count the # of 2-D levels in the 3-D V Fields - +NUM_LEVELS_MOVE_3D_V - ENDIF -! - ENDDO -! -!----------------------------------------------------------------------- -!*** The moving nests and their parents read in the four configure -!*** variables specifying the number of boundary rows on the nests' -!*** pre-move footprints whose locations will receive update data -!*** from the parent after the nests move. All moving nests use -!*** the same values and the parent checks to be sure this is true. -!----------------------------------------------------------------------- -! - parents_with_movers: IF(NUM_MOVING_CHILDREN>0)THEN !<-- Parents read moving nests' configure files -! -!----------------------------------------------------------------------- -! - DO N=1,NUM_MOVING_CHILDREN - NN=RANK_MOVING_CHILD(N) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Init2: Parent Reads NROWS_P_UPD_W" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(N) & !<-- The child's config object - ,value =NROWS_P_UPD_X & !<-- # of footprint W bndry rows updated by parent - ,label ='nrows_p_upd_w:' & !<-- The configure label - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(N==1)THEN - NROWS_P_UPD_W=NROWS_P_UPD_X - ELSE - IF(NROWS_P_UPD_X/=NROWS_P_UPD_W)THEN - WRITE(0,*)' Moving nests must have same values for NROWS_P_UPD_W!' - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - ENDIF -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Init2: Parent Reads NROWS_P_UPD_E" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(N) & !<-- The child's config object - ,value =NROWS_P_UPD_X & !<-- # of footprint E bndry rows updated by parent - ,label ='nrows_p_upd_e:' & !<-- The configure label - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(N==1)THEN - NROWS_P_UPD_E=NROWS_P_UPD_X - ELSE - IF(NROWS_P_UPD_X/=NROWS_P_UPD_E)THEN - WRITE(0,*)' Moving nests must have same values for NROWS_P_UPD_E!' - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - ENDIF -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Init2: Parent Reads NROWS_P_UPD_S" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(N) & !<-- The child's config object - ,value =NROWS_P_UPD_X & !<-- # of footprint S bndry rows updated by parent - ,label ='nrows_p_upd_s:' & !<-- The configure label - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(N==1)THEN - NROWS_P_UPD_S=NROWS_P_UPD_X - ELSE - IF(NROWS_P_UPD_X/=NROWS_P_UPD_S)THEN - WRITE(0,*)' Moving nests must have same values for NROWS_P_UPD_S!' - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - ENDIF -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Init2: Parent Reads NROWS_P_UPD_N" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(N) & !<-- The child's config object - ,value =NROWS_P_UPD_X & !<-- # of footprint N bndry rows updated by parent - ,label ='nrows_p_upd_n:' & !<-- The configure label - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(N==1)THEN - NROWS_P_UPD_N=NROWS_P_UPD_X - ELSE - IF(NROWS_P_UPD_X/=NROWS_P_UPD_N)THEN - WRITE(0,*)' Moving nests must have same values for NROWS_P_UPD_N!' - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO -! -!----------------------------------------------------------------------- -!*** All parents of moving nests will be reading those children's -!*** full resolution topography files that span the entire uppermost -!*** parent. This will require these parents to know the dimensions -!*** as well as other key aspects of the uppermost parent's grid. -!*** Read the pertinent data from the uppermost parent's configure -!*** file and save what will be needed later. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Is the Upper Parent Global?" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF_1 & !<-- The config object of domain #1 - ,value =GLOBAL_TOP_PARENT & !<-- The variable filled - ,label ='global:' & !<-- True--> upper parent is global - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Base Dimensions of Uppermost Domain" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF_1 & !<-- The config object of domain #1 - ,value =IM_1 & !<-- The variable filled - ,label ='im:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF_1 & !<-- The config object of domain #1 - ,value =JM_1 & !<-- The variable filled - ,label ='jm:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Central Lat/Lon of Uppermost Domain" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF_1 & !<-- The config object of domain #1 - ,value =TPH0D_1 & !<-- The variable filled - ,label ='tph0d:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF_1 & !<-- The config object of domain #1 - ,value =TLM0D_1 & !<-- The variable filled - ,label ='tlm0d:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Southern/Western Boundary of Uppermost Domain" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF_1 & !<-- The config object of domain #1 - ,value =SBD_1 & !<-- The variable filled - ,label ='sbd:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF_1 & !<-- The config object of domain #1 - ,value =WBD_1 & !<-- The variable filled - ,label ='wbd:' & !<-- Give this label's value to the previous variable - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - TPH0_1=TPH0D_1*D2R !<-- Central geo lat of domain (radians, positive north) - TLM0_1=TLM0D_1*D2R !<-- Central geo lon of domain (radians, positive east) - WB_1=WBD_1*D2R !<-- Rotated lon of west boundary (radians, positive east) - SB_1=SBD_1*D2R !<-- Rotated lat of south boundary (radians, positive north) -! - DPH_1=-2.*SB_1/(JM_1-1) !<-- Uppermost parent's grid increment in J (radians) - DLM_1=-2.*WB_1/(IM_1-1) !<-- Uppermost parent's grid increment in I (radians) -! - RECIP_DPH_1=1./DPH_1 - RECIP_DLM_1=1./DLM_1 -! -!----------------------------------------------------------------------- -! - ENDIF parents_with_movers -! -!----------------------------------------------------------------------- -! - IF(MY_DOMAIN_MOVES)THEN !<-- Moving nests read their configure files -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Init2: Extract NTRACK flag from P-C Cpl import state." -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Parent-Child coupler import state. - ,name ='NTRACK' & !<-- Name of the attribute to extract - ,value=NTRACK & !<-- Total # of levels in all Real 2-way exch variables - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Init2: Nest Reads NROWS_P_UPD_W" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF_MINE & !<-- The nest's config object - ,value =NROWS_P_UPD_W & !<-- # of footprint W bndry rows updated by parent - ,label ='nrows_p_upd_w:' & !<-- The configure label - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Init2: Nest Reads NROWS_P_UPD_E" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF_MINE & !<-- The nest's config object - ,value =NROWS_P_UPD_E & !<-- # of footprint E bndry rows updated by parent - ,label ='nrows_p_upd_e:' & !<-- The configure label - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Init2: Nest Reads NROWS_P_UPD_S" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF_MINE & !<-- The nest's config object - ,value =NROWS_P_UPD_S & !<-- # of footprint S bndry rows updated by parent - ,label ='nrows_p_upd_s:' & !<-- The configure label - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Init2: Nest Reads NROWS_P_UPD_N" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF_MINE & !<-- The nest's config object - ,value =NROWS_P_UPD_N & !<-- # of footprint N bndry rows updated by parent - ,label ='nrows_p_upd_n:' & !<-- The configure label - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** What is the distance between this moving nest's center -!*** and its moving child's before this nest will consider -!*** shifting in order to follow its child? The value is only -!*** relevant for a moving nest with a child. Units are grid -!*** increments on this moving nest's grid. -!----------------------------------------------------------------------- -! - CENTERS_DISTANCE=R4_IN !<-- Initialize to nonsense -! - IF(NUM_CHILDREN>0.AND.MY_DOMAIN_MOVES)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Init2: Outer nest reads centers separation" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF_MINE & !<-- The nest's config object - ,value =CENTERS_DISTANCE & !<-- Distance between outer/inner nest centers before outer shift - ,label ='centers_distance:' & !<-- The configure label - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! -!----------------------------------------------------------------------- -!*** What is the latitude (degrees) past which no nests will be -!*** allowed to move? -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Init2: Nest Reads Latitude Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF_MINE & !<-- The nest's config object - ,value =LATITUDE_LIMIT & !<-- Max distance nest bndry can move from equator (deg) - ,label ='latitude_limit:' & !<-- The configure label - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NORTH_LAT_MAX_MVG_NEST=LATITUDE_LIMIT*D2R !<-- Mvg nest Nbndry must not pass this latitude (rad) - SOUTH_LAT_MAX_MVG_NEST=-NORTH_LAT_MAX_MVG_NEST !<-- Mvg nest Sbndry must not pass this latitude (rad) -! -!----------------------------------------------------------------------- -!*** Moving nests set up some variables for computing motion. -!----------------------------------------------------------------------- -! - FIRST_PASS_M=.TRUE. -! - ALLOCATE(cc%I_PG(1:4)) - ALLOCATE(cc%J_PG(1:4)) -! - ALLOCATE(cc%I_HOLD_PG_POINT(1:4)) -! - I_CENTER_CURRENT=IDS+INT(0.5*(IDE-IDS)+EPS) - J_CENTER_CURRENT=JDS+INT(0.5*(JDE-JDS)+EPS) -! -!----------------------------------------------------------------------- -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF parents_and_moving -! -!----------------------------------------------------------------------- -!*** Additional setup for parents of moving nests and/or for moving -!*** parents with any children at all. -!----------------------------------------------------------------------- -! - nests_move: IF(NUM_MOVING_CHILDREN>0)THEN -! -!----------------------------------------------------------------------- -!*** By 'moving nest' we mean any domain that moves across the earth -!*** and not those domains that move within their parent's domain. -!*** This would therefore include static children inside moving parents -!*** however that arrangement is not allowed at present. That setup -!*** would require full updates of the child domain following the -!*** parent's shift since the child moved with resepct to the earth -!*** and atmosphere. However a moving child in a moving parent will -!*** stay in place when its parent shifts and thus that child domain -!*** needs no updating at all following the parent shift. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Parents with moving nests need to know those nests' topography -!*** at the nests' own resolutions for the hydrostatic adjustment -!*** that must take place when the parents interpolate their data -!*** to moving nest grid points. For the sake of generality all -!*** of those nest-resolution datasets must span the domain of the -!*** uppermost parent which is the true maximum range of any nest's -!*** motion. -! -!*** So each parent with moving nests must: -!*** (1) Know how many different space resolutions its moving -!*** children use; -!*** (2) Associate each resolution with the appropriate moving -!*** child using the nest-to-uppermost parent space ratio -!*** that the user specified in each moving nest's configure -!*** file; -!*** (3) Have each of its forecast tasks read in its own piece of -!*** each different resolution of topography data needed by -!*** all of its moving children. -! -!*** If a parent domain moves then it must refill its task subdomains -!*** with the topography of its moving children each time it (the -!*** parent) shifts its position. That is handled in subroutine -!*** CHILDREN_RECV_PARENT_DATA. -!----------------------------------------------------------------------- -! - ALLOCATE(cc%M_NEST_RATIO(1:NUM_MOVING_CHILDREN),stat=ISTAT) !<-- Associate moving nests with list of different space ratios - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%M_NEST_RATIO stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - M_NEST_RATIO=>cc%M_NEST_RATIO -! - ALLOCATE(cc%LIST_OF_RATIOS(1:NUM_MOVING_CHILDREN),stat=ISTAT) !<-- Keep a list of the different space ratios - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%LIST_OF_RATIOS stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - LIST_OF_RATIOS=>cc%LIST_OF_RATIOS -! - ALLOCATE(cc%LINK_MRANK_RATIO(1:NUM_MOVING_CHILDREN),stat=ISTAT) !<-- Which different space ratio for each moving child - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%LINK_MRANK_RATIO stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - LINK_MRANK_RATIO=>cc%LINK_MRANK_RATIO -! - NN=0 - NUM_SPACE_RATIOS_MVG=0 !<-- Count the different resolutions of moving children -! -!----------------------------------------------------------------------- -! - DO N=1,NUM_CHILDREN -! - IF(STATIC_OR_MOVING(N)=='Static')CYCLE - NN=NN+1 -! -!----------------------------------------------------------------------- -! - LIST_OF_RATIOS(NN)=0 -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Moving Child's Sfc File Ratio" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF(N) & !<-- Child N's config object - ,value =SFC_FILE_RATIO & !<-- Save the configure value with the following label. - ,label ='ratio_sfc_files:' & !<-- Ratio of upper parent's grid increment to this nest's - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - M_NEST_RATIO(NN)=SFC_FILE_RATIO !<-- Moving child NN uses topography file with this ratio/ID -! - IF(NN==1)THEN - NUM_SPACE_RATIOS_MVG=1 !<-- Begin counting the space ratios of moving children - LIST_OF_RATIOS(1)=SFC_FILE_RATIO !<-- The 1st sfc file ratio is that of the 1st moving nest - LINK_MRANK_RATIO(1)=1 !<-- 1st moving nest uses 1st sfc file ratio -! - ELSE - FOUND=.FALSE. - DO KR=1,NUM_SPACE_RATIOS_MVG - IF(SFC_FILE_RATIO==LIST_OF_RATIOS(KR))THEN - FOUND=.TRUE. - LINK_MRANK_RATIO(NN)=KR !<-- Moving nest NN uses existing KR'th sfc file ratio - EXIT - ENDIF - ENDDO -! - IF(.NOT.FOUND)THEN - NUM_SPACE_RATIOS_MVG=NUM_SPACE_RATIOS_MVG+1 !<-- Increment the counter of children's different space ratios - LIST_OF_RATIOS(NUM_SPACE_RATIOS_MVG)=SFC_FILE_RATIO !<-- Save the new ratio in the list of different ratios - LINK_MRANK_RATIO(NN)=NUM_SPACE_RATIOS_MVG !<-- Moving child NN uses this rank in list of all different ratios - ENDIF -! - ENDIF -! - ENDDO -! -!----------------------------------------------------------------------- -! - ALLOCATE(cc%NEST_FIS_ON_PARENT(1:NUM_SPACE_RATIOS_MVG),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%NEST_FIS_ON_PARENT stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - NEST_FIS_ON_PARENT=>cc%NEST_FIS_ON_PARENT -! - ALLOCATE(cc%NEST_FIS_V_ON_PARENT(1:NUM_SPACE_RATIOS_MVG),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%NEST_FIS_V_ON_PARENT stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - NEST_FIS_V_ON_PARENT=>cc%NEST_FIS_V_ON_PARENT -! - DO N=1,NUM_SPACE_RATIOS_MVG - NEST_FIS_ON_PARENT(N)%DATA=>NULL() - NEST_FIS_V_ON_PARENT(N)%DATA=>NULL() - ENDDO -! - ALLOCATE(cc%NEST_FIS_ON_PARENT_BNDS(1:NUM_SPACE_RATIOS_MVG),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%NEST_FIS_ON_PARENT_BNDS stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - NEST_FIS_ON_PARENT_BNDS=>cc%NEST_FIS_ON_PARENT_BNDS -! -!----------------------------------------------------------------------- -!*** Now fill the parent's data objects that hold the nest-resolution -!*** topography at child H points and child V points. -!----------------------------------------------------------------------- -! - CALL PARENT_READS_MOVING_CHILD_TOPO(MY_DOMAIN_ID & - ,NUM_MOVING_CHILDREN & - ,LINK_MRANK_RATIO & - ,LIST_OF_RATIOS & - ,M_NEST_RATIO & - ,NUM_SPACE_RATIOS_MVG & - ,GLOBAL_TOP_PARENT & - ,IM_1,JM_1 & - ,TPH0_1,TLM0_1 & - ,SB_1,WB_1 & - ,RECIP_DPH_1,RECIP_DLM_1 & - ,GLAT,GLON & - ,NEST_FIS_ON_PARENT_BNDS & - ,NEST_FIS_ON_PARENT & - ,NEST_FIS_V_ON_PARENT & - ,IDS,IDE,IMS,IME,ITS,ITE & - ,JDS,JDE,JMS,JME,JTS,JTE) -! -!----------------------------------------------------------------------- -! - ENDIF nests_move -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Extract the 2-way Bundle holding pointers to Solver internal -!*** state variables needed for 2-way exchange of data between -!*** children and parents. Since the generation and incorporation -!*** of 2-way exchange data will be done via looping through Fields -!*** we need to know how many Fields there are. -!----------------------------------------------------------------------- -! - IF(I_AM_A_FCST_TASK.AND.NEST_MODE=='2-way')THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract 2-way Bundle in P-C Init" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =IMP_STATE & !<-- The Parent-Child coupler import state - ,itemname ='Bundle_2way' & !<-- Name of 2-way Bundle of internal state arrays to use - ,fieldbundle=BUNDLE_2WAY & !<-- The ESMF 2-way Bundle - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="How many Fields in the 2-way Bundle?" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=BUNDLE_2WAY & !<-- The ESMF Bundle of 2-way exchange variables - ,fieldcount =NVARS_2WAY_UPDATE & !<-- # of Fields in the Bundle - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract # of levels in all fields in 2-way Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(FIELDBUNDLE=BUNDLE_2WAY & !<-- The ESMF Bundle of 2-way exchange variables - ,name ='NLEV 2-way' & !<-- Name of the attribute to extract - ,value=NLEV_2WAY & !<-- Total # of levels in all Real 2-way exch variables - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Compute the number of timesteps between restart outputs. -!*** This will be used if the domain is a moving nest. The nest -!*** will not be allowed to decide to move LAG_STEPS parent -!*** timesteps before a restart output time. This will postpone -!*** such decisions until after the restart output time and thus -!*** ensure that the same decision will be made in the forecast -!*** when it is restarted. -!*** This variable is also used in a similar way in 2-way nesting. -!*** Children send 2-way exchange data to their parents at the end -!*** of parent timestep N and the parents receive it early in -!*** parent timestep N+1. For bit-reproducible restarts we must -!*** therefore not let parents incorporate 2-way data in parent -!*** timesteps that immediately follow the writing of a restart file. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Init2: Nest Reads NROWS_P_UPD_N" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF_MINE & !<-- The nest's config object - ,value =MINUTES_RESTART & !<-- Minutes between restart output - ,label ='minutes_restart:' & !<-- The configure label - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - cc%NTIMESTEPS_RESTART=NINT((60.*MINUTES_RESTART)/DT_DOMAIN(MY_DOMAIN_ID)) -! -!----------------------------------------------------------------------- -! - IF(ASSOCIATED(DOMAIN_ID_TO_RANK))DEALLOCATE(DOMAIN_ID_TO_RANK) -! -!----------------------------------------------------------------------- -! -!------------ -!*** Timers -!------------ -! - cpl1_prelim_tim=>cc%cpl1_prelim_tim - cpl1_south_h_tim=>cc%cpl1_south_h_tim - cpl1_south_v_tim=>cc%cpl1_south_v_tim - cpl1_north_h_tim=>cc%cpl1_north_h_tim - cpl1_north_v_tim=>cc%cpl1_north_v_tim - cpl1_west_h_tim=>cc%cpl1_west_h_tim - cpl1_west_v_tim=>cc%cpl1_west_v_tim - cpl1_east_h_tim=>cc%cpl1_east_h_tim - cpl1_east_v_tim=>cc%cpl1_east_v_tim - cpl1_recv_tim=>cc%cpl1_recv_tim -! - cpl1_recv_tim=>cc%cpl1_recv_tim -! - cpl1_south_h_recv_tim=>cc%cpl1_south_h_recv_tim - cpl1_south_h_undo_tim=>cc%cpl1_south_h_undo_tim - cpl1_south_h_exp_tim=>cc%cpl1_south_h_exp_tim - cpl1_south_v_recv_tim=>cc%cpl1_south_v_recv_tim - cpl1_south_v_undo_tim=>cc%cpl1_south_v_undo_tim - cpl1_south_v_exp_tim=>cc%cpl1_south_v_exp_tim -! - cpl2_comp_tim=>cc%cpl2_comp_tim - cpl2_wait_tim=>cc%cpl2_wait_tim - cpl2_send_tim=>cc%cpl2_send_tim -! - moving_nest_bookkeep_tim=>cc%moving_nest_bookkeep_tim - moving_nest_update_tim=>cc%moving_nest_update_tim - parent_bookkeep_moving_tim=>cc%parent_bookkeep_moving_tim - parent_update_moving_tim=>cc%parent_update_moving_tim - t0_recv_move_tim=>cc%t0_recv_move_tim - read_moving_child_topo_tim=>cc%read_moving_child_topo_tim - barrier_move_tim=>cc%barrier_move_tim - pscd_tim=>cc%pscd_tim - pscd1_tim=>cc%pscd1_tim - pscd2_tim=>cc%pscd2_tim - pscd3_tim=>cc%pscd3_tim - pscd4_tim=>cc%pscd4_tim - ja1_tim=>cc%ja1_tim - ja2_tim=>cc%ja2_tim - ja3_tim=>cc%ja3_tim - ja4_tim=>cc%ja4_tim - jat_tim=>cc%jat_tim -! - cpl1_prelim_tim=0. - cpl1_south_h_tim=0. - cpl1_south_v_tim=0. - cpl1_north_h_tim=0. - cpl1_north_v_tim=0. - cpl1_west_h_tim=0. - cpl1_west_v_tim=0. - cpl1_east_h_tim=0. - cpl1_east_v_tim=0. - cpl1_recv_tim=0. -! - cpl1_south_h_recv_tim=0. - cpl1_south_h_undo_tim=0. - cpl1_south_h_exp_tim=0. - cpl1_south_v_recv_tim=0. - cpl1_south_v_undo_tim=0. - cpl1_south_v_exp_tim=0. -! - cpl2_comp_tim=0. - cpl2_wait_tim=0. - cpl2_send_tim=0. -! - moving_nest_bookkeep_tim =0. - moving_nest_update_tim =0. - parent_bookkeep_moving_tim=0. - parent_update_moving_tim =0. - t0_recv_move_tim =0. - read_moving_child_topo_tim=0.0 - barrier_move_tim=0.0 - pscd_tim=0. - pscd1_tim=0. - pscd2_tim=0. - pscd3_tim=0. - pscd4_tim=0. - ja1_tim=0. - ja2_tim=0. - ja3_tim=0. - ja4_tim=0. - jat_tim=0. -! -!----------------------------------------------------------------------- -! - IF(RC_CPL_INIT==ESMF_SUCCESS)THEN -! WRITE(0,*)"PARENT_CHILD_CPL INITIALIZE STEP SUCCEEDED" - ELSE - WRITE(0,*)"PARENT_CHILD_CPL INITIALIZE STEP FAILED" - ENDIF -! - RC_FINAL=RC_CPL_INIT -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PARENT_CHILD_CPL_INITIALIZE2 -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE CHECK_2WAY_SIGNALS(CPL_COMP & - ,IMP_STATE & - ,EXP_STATE & - ,CLOCK & - ,RC_FINAL ) -! -!----------------------------------------------------------------------- -!*** When 2-way nesting is used do not proceed into a timestep until -!*** the update data from all of the current domain's children have -!*** been received and the current domain's parent has signaled that -!*** the parent has received 2-way update data from all of its -!*** children. This routine checks for those conditions. -!*** This is phase 1 of the Parent-Child coupler's Run step. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_CplComp) :: CPL_COMP !<-- The Parent-Child Coupler Component -! - TYPE(ESMF_State) :: IMP_STATE & !<-- The Coupler's Import State - ,EXP_STATE !<-- The Coupler's Export State -! - TYPE(ESMF_Clock) :: CLOCK !<-- The ESMF Clock -! - INTEGER,INTENT(OUT) :: RC_FINAL -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: ALLCLEAR_SIGNAL_TAG,CHILDTASK_0 & - ,COMM_FCST_TASKS,MY_DOMAIN_ID,N,NTIMESTEP -! - INTEGER(kind=KINT) :: IERR,RC,RC_CPL_RUN -! - INTEGER(kind=ESMF_KIND_I8) :: NTIMESTEP_ESMF -! - INTEGER(kind=KINT),DIMENSION(MPI_STATUS_SIZE) :: JSTAT -! - LOGICAL(kind=KLOG) :: ALLCLEAR_SIGNAL_IS_PRESENT & - ,ALLCLEAR_SIGNAL & - ,READY_TO_RECV & - ,TWOWAY_SIGNAL_IS_PRESENT -! - LOGICAL(kind=KLOG) :: RECV_ALL_CHILD_DATA -! - integer(kind=kint) :: mype_local -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Initialize the error signal variables. -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RC_FINAL =ESMF_SUCCESS - RC_CPL_RUN=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** What is the current timestep on this nest's Clock? -!----------------------------------------------------------------------- -! - CALL ESMF_ClockGet(clock =CLOCK & - ,advanceCount=NTIMESTEP_ESMF & !<-- The current timestep of this domain (ESMF) - ,rc =RC) -! - NTIMESTEP=NTIMESTEP_ESMF !<-- The current timestep of this domain (integer) -! -!----------------------- -!*** Current Domain ID -!----------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Current Domain ID" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='MY_DOMAIN_ID' & !<-- Name of the attribute to extract - ,value=MY_DOMAIN_ID & !<-- Current domain's ID - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!---------------------------------------------- -!*** Intracommunicator between forecast tasks -!---------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Fcst Task Intracomm in P-C Coupler Init0" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='Comm Fcst Tasks' & !<-- Name of the attribute to extract - ,value=COMM_FCST_TASKS & !<-- Intracommunicator for fcst tasks - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Point to the correct part of the composite object. -!----------------------------------------------------------------------- -! - CALL POINT_TO_COMPOSITE(MY_DOMAIN_ID) -! -!----------------------------------------------------------------------- -!*** Do not repeatedly extract the parent's ALLCLEAR signal if it -!*** was already done in the current timestep. -!----------------------------------------------------------------------- -! - IF(NTIMESTEP>NTIMESTEP_CHECK)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract ALLCLEAR Signal from P-C Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE & !<-- The parent-child coupler import state - ,name ='ALLCLEAR' & !<-- Name of the attribute to extract - ,value=ALLCLEAR_SIGNAL_PRESENT & !<-- ALLCLEAR signal reset to fals - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NTIMESTEP_CHECK=NTIMESTEP -! - ENDIF -! -!----------------------------------------------------------------------- -!*** When 2-way nests are being used then this child checks to see -!*** if its parent has sent a signal indicating it has received all -!*** exchange data from this child and its siblings. That signal -!*** means this child is now free to proceed in its integration. -!*** If the signal is not present then the child immediately -!*** returns and exits the current iteration of the time loop -!*** without incrementing the timestep. -!----------------------------------------------------------------------- -! - children: IF(MY_DOMAIN_ID>1 & !<-- Select the domains with parents - .AND. & - MOD(NTIMESTEP,TIME_RATIO_MY_PARENT)==0 & !<-- Is this a timestep boundary of my parent? - .AND. & - .NOT.ALLCLEAR_SIGNAL_PRESENT)THEN !<-- Already recvd signal from parent this timestep? -!----------------------------------------------------------------------- -! - IF(I_AM_LEAD_FCST_TASK)THEN - ALLCLEAR_SIGNAL_TAG=20000+1000*MY_DOMAIN_ID+10*NTIMESTEP !<-- Use the domain ID,timestep to get a unique tag -! - CALL MPI_IPROBE(0 & !<-- Parent task 0 sends the signal - ,ALLCLEAR_SIGNAL_TAG & !<-- The message's tag - ,COMM_TO_MY_PARENT & !<-- Communicator to the parent - ,ALLCLEAR_SIGNAL_IS_PRESENT & !<-- Has the parent's signal arrived? - ,JSTAT & !<-- MPI status object - ,IERR ) -! - IF(ALLCLEAR_SIGNAL_IS_PRESENT)THEN - CALL MPI_RECV(ALLCLEAR_SIGNAL & !<-- Clear the buffer if signal is present - ,1 & !<-- Signal has 1 word - ,MPI_LOGICAL & !<-- Signal is logical - ,0 & !<-- Signal sent by parent task 0 - ,ALLCLEAR_SIGNAL_TAG & !<-- Tag associated with the signal - ,COMM_TO_MY_PARENT & !<-- Communicator between child and parent - ,JSTAT & !<-- MPI status object - ,IERR ) -! - ENDIF -! - ENDIF -! - btim=timef() - CALL MPI_BCAST(ALLCLEAR_SIGNAL_IS_PRESENT & !<-- Can the child tasks proceed or not? - ,1 & !<-- The signal is one word - ,MPI_LOGICAL & !<-- The signal is logical - ,0 & !<-- Broadcast from lead nest forecast task - ,COMM_FCST_TASKS & !<-- MPI communicator for this nest's forecast tasks - ,IERR) - cbcst_tim(my_domain_id)=cbcst_tim(my_domain_id)+(timef()-btim) -! - ALLCLEAR_SIGNAL_PRESENT=ALLCLEAR_SIGNAL_IS_PRESENT -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="NMM_INTEGRATE: Child Inserts ALLCLEAR into Cpl Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent-Child coupler export state - ,name ='ALLCLEAR' & !<-- Name of the attribute to insert - ,value=ALLCLEAR_SIGNAL_PRESENT & !<-- Parent does/not have exch data; child can/not proceed - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - ENDIF children -! -!----------------------------------------------------------------------- -!*** Also with 2-way nesting this parent checks to see if all its -!*** children have indicated they are ready to send their 2-way -!*** update data. If not then the parent immediately returns and -!*** exits the current iteration of the time loop without incrementing -!*** the timestep. -! -!*** When any of this parent's children catch up to the parent at -!*** the end of a parent timestep then that child's lead fcst task -!*** sends a signal to the parent's lead fcst task that the child -!*** is ready to send the 2-way exchange data. Here the parent lead -!*** fcst task probes for that signal from each of the children. The -!*** probe needs to be done until all children have been heard from. -!----------------------------------------------------------------------- -! - parents: IF(NUM_CHILDREN>0)THEN !<-- Select the domains with children -! -!----------------------------------------------------------------------- -! -! call mpi_comm_rank(comm_fcst_tasks,mype_local,ierr) - READY_TO_RECV=.FALSE. -! - task0_a: IF(I_AM_LEAD_FCST_TASK)THEN -! - IF(KOUNT_2WAY_CHILDREN3)then -! write(0,24331)ncycle_parent,my_domain_id,ntimestep -24331 format(' parent cycled ',i5,' times my_domain_id=',i2,' ntimestep=',i6) -! endif -! ncycle_parent=0 -! endif -! - ELSE -! - RECV_ALL_CHILD_DATA=.FALSE. -! ncycle_parent=ncycle_parent+1 -! - ENDIF -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="PARENTS_RECV_CHILD_2WAY_DATA: Set Integrate Flag" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The P-C coupler's export state - ,name ='Recv All Child Data' & - ,value=RECV_ALL_CHILD_DATA & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - ENDIF parents -! -!----------------------------------------------------------------------- -! - END SUBROUTINE CHECK_2WAY_SIGNALS -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE CHILDREN_RECV_PARENT_DATA(CPL_COMP & - ,IMP_STATE & - ,EXP_STATE & - ,CLOCK & - ,RC_FINAL) -! -!----------------------------------------------------------------------- -!*** Run the coupler step where children receive data from parents. -!*** This is phase 2 of the coupler Run step and it occurs at the -!*** beginning of the timesteps. The parents send the data in -!*** phase 4 at the end of the timesteps. Only child tasks enter -!*** this routine. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_CplComp) :: CPL_COMP !<-- The Parent-Child Coupler Component -! - TYPE(ESMF_State) :: IMP_STATE & !<-- The Coupler's Import State - ,EXP_STATE !<-- The Coupler's Export State -! - TYPE(ESMF_Clock) :: CLOCK !<-- The ESMF Clock -! - INTEGER,INTENT(OUT) :: RC_FINAL -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: NEXT_MOVE_TIMESTEP_PARENT -! - INTEGER(kind=KINT) :: ALLCLEAR_SIGNAL_TAG & - ,BC_UPDATE_FLAG,CHILDTASK_0 & - ,COMM_FCST_TASKS & - ,ID_GRANDPARENT & - ,I_DIFF,J_DIFF & - ,MAX_SHIFT_CHILD & - ,MY_DOMAIN_ID,MYPE_LOCAL & - ,N,NN,NTIMESTEP,NTAG0 -! - INTEGER(kind=KINT) :: I_SHIFT,I_SHIFT_MY_GRID,I_SHIFT_PARENT_GRID & - ,J_SHIFT,J_SHIFT_MY_GRID,J_SHIFT_PARENT_GRID -! - INTEGER(kind=KINT) :: IERR,IRTN,RC,RC_CPL_RUN -! -!xxx INTEGER(kind=KINT),DIMENSION(2) :: STORM_CENTER -! - INTEGER(kind=KINT),DIMENSION(MPI_STATUS_SIZE) :: JSTAT -! - INTEGER(kind=ESMF_KIND_I8) :: NTIMESTEP_ESMF -! - REAL(kind=KFPT) :: CHILD_DOMAIN_EW,CHILD_DOMAIN_NS & - ,DIFF_I,DIFF_J & - ,DT_GRANDPARENT,PARENT_DIFF,SHIFT_LAT -! - REAL(kind=KFPT) :: CENTER_I_INNER,CENTER_I_OUTER & - ,CENTER_J_INNER,CENTER_J_OUTER -! - REAL(kind=KFPT) :: DIST_EAST,DIST_WEST & - ,DIST_NORTH,DIST_SOUTH & - ,DIST_TO_PARENT_BNDRY & - ,DISTANCE -! - REAL(kind=KFPT) :: DISTN_TO_PARENT_BNDRY & - ,DISTN_EAST,DISTN_WEST & - ,DISTN_NORTH,DISTN_SOUTH -! - REAL(kind=KFPT) :: DOMAIN_NBND,DOMAIN_SBND & - ,PARENT_NBND,PARENT_SBND -! - LOGICAL(kind=KLOG) :: ALLCLEAR_SIGNAL_IS_PRESENT & - ,ALLCLEAR_SIGNAL -! - TYPE(COMPOSITE),POINTER :: CC -! - TYPE(INTERIOR_DATA_FROM_PARENT),DIMENSION(1:4) :: SEND_TASK !<-- Specifics about interior data from sending parent tasks -! - LOGICAL(kind=KLOG) :: PARENT_SHIFT_IS_PRESENT -! - LOGICAL(kind=KLOG) :: ALLCLEAR_SIGNAL_PRESENT & - ,MOVE_NOW -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - btim =timef() - btim0=timef() -! -!----------------------------------------------------------------------- -!*** Initialize the error signal variables. -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RC_FINAL =ESMF_SUCCESS - RC_CPL_RUN=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** What is the current timestep on this nest's Clock? -!----------------------------------------------------------------------- -! - CALL ESMF_ClockGet(clock =CLOCK & - ,advanceCount=NTIMESTEP_ESMF & !<-- The current timestep of this child (ESMF) - ,rc =RC) -! - NTIMESTEP=NTIMESTEP_ESMF !<-- The current timestep of this child (integer) -! -!----------------------- -!*** Current Domain ID -!----------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Current Domain ID" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='MY_DOMAIN_ID' & !<-- Name of the attribute to extract - ,value=MY_DOMAIN_ID & !<-- Current domain's ID - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Point to the correct part of the composite object. -!----------------------------------------------------------------------- -! - CALL POINT_TO_COMPOSITE(MY_DOMAIN_ID) -! -!---------------------------------- -!*** Are we in the free forecast? -!---------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="PARENTS_SEND_CHILD_DATA: Extract Free Forecast flag" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='Free Forecast' & !<-- Name of the attribute to extract - ,value=FREE_FORECAST & !<-- Is this the free forecast? - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DIG_FILTER=.FALSE. - IF(.NOT.FREE_FORECAST)THEN - DIG_FILTER=.TRUE. - ELSEIF(FREE_FORECAST)THEN - I_AM_ACTIVE=.TRUE. !<-- All domains are always active in the free forecast. - ENDIF -! -!----------------------------------------------------------- -!*** Intracommunicator for current domain's forecast tasks -!----------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Fcst Task Intracommunicator" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='Comm Fcst Tasks' & !<-- Name of the attribute to extract - ,value=COMM_FCST_TASKS & !<-- Current domain's intracomm for fcst tasks - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL MPI_COMM_RANK(COMM_FCST_TASKS,MYPE_LOCAL,IERR) !<-- Local task rank in this domain's fcst tasks -! -!----------------------------------------------------------------------- -!*** The child is now at the beginning of a timestep that coincides -!*** with the beginning of a parent timestep which is where moving -!*** children execute their shifts. To eliminate potential randomness -!*** a child will always shift a fixed number of timesteps after it -!*** has made the decision to move. It is then at that point in -!*** time that the parent will generate new internal data for the -!*** child as well as new starting boundary data for the child's new -!*** location. So it is at that point in time that the child will -!*** have the data needed to execute its shift. -!----------------------------------------------------------------------- -! - moving_children_a: IF(MY_DOMAIN_MOVES)THEN !<-- Select the moving nests -! -!----------------------------------------------------------------------- -! - MOVE_NOW=.FALSE. -! -!----------------------------------------------------------------------- -!*** If this is now the point in time at which the parent prepared -!*** internal and boundary data for the child's new position, then -!*** the child initiates its shift now by receiving the data prepared -!*** for it by its parent for the child's new position. Note that -!*** the actual updating of the prognostic variables due to the -!*** shift takes place in DOMAIN_RUN which is called in NMM_INTEGRATE -!*** following phases 2 and 3 of the Parent-Child coupler (where the -!*** children receive update data from their parents and the parents -!*** receive update data from their children, respectively). -!----------------------------------------------------------------------- -! - the_child_moves: IF(NTIMESTEP==NEXT_MOVE_TIMESTEP)THEN -! -!----------------------------------------------------------------------- -!*** Later in this subroutine moving nests begin their decision of -!*** whether they want to shift with the call to COMPUTE_STORM_MOTION. -!*** If they do want to shift then they check to see if the shift -!*** would lead to a collision with their parent's boundary. If the -!*** nest is also a parent it checks to see if its desired shift -!*** would lead to a collision with its children. However after -!*** the decision to shift is made then the nest must wait LAG_STEPS -!*** timesteps of its parent before executing that shift. This is -!*** because in 1-way nesting the parent can run several timesteps -!*** ahead of its children and thus the parent will lie out in the -!*** child's future when the parent learns what the new location of -!*** the child will be. Only then can the parent generate new data -!*** to update the child's boundaries at that location. The existence -!*** of this time lag can permit a fatal situation. A child/parent -!*** may determine it is safe to shift given the current location -!*** of the domains involved but then before it executes the shift -!*** the related parent/child may decide it also wants to shift and -!*** determines it is safe to shift given the present location of the -!*** of the domains. After the first of the domains shifts that may -!*** then make the shift of the second domain fatal by leading to -!*** a collision IF either or both shifts are relatively large. -! -!*** Here are the three basic scenarios that must be avoided. -! -!----------------------------------------------------------------------- -! Scenario 1 -!----------------------------------------------------------------------- -! -! <------ Child decides it wants to shift -! -! <------- Parent decides it wants to shift -! TIME -! | <------ Child executes its shift -! | -! | -! v -! -! -! -! -! <------- Parent executes its shift -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! Scenario 2 -!----------------------------------------------------------------------- -! -! <------- Parent decides it wants to shift -! -! -! TIME -! | <------ Child decides it wants to shift -! | -! | -! v -! <------ Child executes its shift -! -! -! -! -! <------- Parent executes its shift -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! Scenario 3 (~equivalent to Scenario 2) -!----------------------------------------------------------------------- -! -! <------- Parent decides it wants to shift -! -! -! TIME -! | -! | -! | -! v -! <------ Child decides it wants to shift -! -! <------- Parent executes its shift -! -! <------ Child executes its shift -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - MOVE_NOW=.TRUE. !<-- Yes, the child moves at beginning of this timestep -! -! IF(NTRACK>0)THEN -! I_CENTER_CURRENT=STORM_CENTER(1) & -! -(I_SW_PARENT_NEW-I_SW_PARENT_CURRENT) & -! *SPACE_RATIO_MY_PARENT -! J_CENTER_CURRENT=STORM_CENTER(2) & -! -(J_SW_PARENT_NEW-J_SW_PARENT_CURRENT) & -! *SPACE_RATIO_MY_PARENT -! ENDIF -! - I_WANT_TO_MOVE=.FALSE. !<-- Reset the 'move' flag - MOVE_FLAG_SENT=.FALSE. !<-- Reset the flag for ISending the move flag -! -!----------------------------------------------------------------------- -!*** Deallocate this moving nest's working arrays/pointers whose -!*** dimensions are functions of moving nests' positions. They will -!*** be reallocated with dimensions appropriate for the new positions. -!*** For static nests the same nest arrays/pointers never become -!*** invalid and thus are not deallocated/reallocated. -!----------------------------------------------------------------------- -! - CALL DEALLOC_WORK_CHILDREN(MY_DOMAIN_ID) !<-- Reset this child's working pointers for new location -! -!----------------------------------------------------------------------- -!*** Each child boundary task receives small information packets -!*** from the parent tasks that cover them. That information -!*** can change with each move and includes the identities of -!*** those parent tasks that will be sending boundary data -!*** updates along with the index limits on the child task of -!*** that boundary data from each parent task. -!----------------------------------------------------------------------- -! - CALL CHILD_RECVS_CHILD_DATA_LIMITS(EXP_STATE,MY_DOMAIN_ID) !<-- Recv specs of new parent/child task associations -! ! for BC data. -!----------------------------------------------------------------------- -!*** Receive standard boundary data update from the parent valid for -!*** the current timestep but now at the child's new location. This -!*** data will be for time N in the boundary tendency computation: -!*** dX/dt = [ X(N+1) - X(N) ] / DT_parent -!----------------------------------------------------------------------- -! - CALL NEST_RECVS_BC_DATA('Current') !<-- Recv parent data for new nest boundary after move -! -!----------------------------------------------------------------------- -!*** Receive update data for all interior points on the nest domain -!*** that have moved outside of the nest's pre-move footprint. Those -!*** points can only be updated by the parent. The index limits of -!*** the parent update regions on the nest tasks are identical for -!*** H and V points therefore the nest needs to call its bookkeeping -!*** only once. -!----------------------------------------------------------------------- -! - IF(I_AM_LEAD_FCST_TASK)THEN - WRITE(0,12341)MY_DOMAIN_ID,NTIMESTEP - WRITE(0,12342)I_SHIFT_CHILD,J_SHIFT_CHILD & - ,I_SW_PARENT_NEW,J_SW_PARENT_NEW -12341 FORMAT(' Nest shifts now my_domain_id=',I2,' ntimestep=',I6) -12342 FORMAT(' i_shift_child=',I4,' j_shift_child=',I4 & - ,' i_sw_parent_new=',I4,' j_sw_parent_new=',I4) - ENDIF -! - btim=timef() - CALL MOVING_NEST_BOOKKEEPING(I_SHIFT_CHILD & - ,J_SHIFT_CHILD & - ,I_SW_PARENT_NEW & - ,J_SW_PARENT_NEW & - ,NUM_FCST_TASKS_PARENT & - ,INPES_PARENT & - ,PTASK_LIMITS(MY_DOMAIN_ID)%ITS & - ,PTASK_LIMITS(MY_DOMAIN_ID)%ITE & - ,PTASK_LIMITS(MY_DOMAIN_ID)%JTS & - ,PTASK_LIMITS(MY_DOMAIN_ID)%JTE & - ,SPACE_RATIO_MY_PARENT & - ,NROWS_P_UPD_W & - ,NROWS_P_UPD_E & - ,NROWS_P_UPD_S & - ,NROWS_P_UPD_N & - ,SEND_TASK & - ,ITS,ITE,JTS,JTE & - ,IMS,IME,JMS,JME & - ,IDS,IDE,JDS,JDE & - ) -! - btim=timef() - CALL MOVING_NEST_RECV_DATA(COMM_TO_MY_PARENT & - ,NTIMESTEP & - ,NUM_FIELDS_MOVE_2D_H_I & - ,NUM_FIELDS_MOVE_2D_X_I & - ,NUM_FIELDS_MOVE_2D_H_R & - ,NUM_FIELDS_MOVE_2D_X_R & - ,NUM_LEVELS_MOVE_3D_H & - ,NUM_FIELDS_MOVE_2D_V & - ,NUM_LEVELS_MOVE_3D_V & - ,SEND_TASK & - ,EXP_STATE & - ) - moving_nest_update_tim=moving_nest_update_tim+(timef()-btim) -! - I_SW_PARENT_CURRENT=I_SW_PARENT_NEW !<-- Reset the location of the nest's SW corner - J_SW_PARENT_CURRENT=J_SW_PARENT_NEW ! in its parent's grid space. -! - ENDIF the_child_moves -! -!----------------------------------------------------------------------- -!*** Load the Attribute into the coupler export state indicating that -!*** the child is or is not moving at this timestep. This information -!*** will be used in the transfer of the new data from the Parent-Child -!*** coupler export state to the Domain import state to the Solver -!*** import state. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Child Inserts Move Flag into Cpl Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent-Child coupler export state - ,name ='MOVE_NOW' & !<-- Name of the attribute to insert - ,value=MOVE_NOW & !<-- Is the child moving right now? - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!--------------------------------------------------------- -! - ENDIF moving_children_a -! -!----------------------------------------------------------------------- -!*** If this is a (moving) child of a moving parent then it needs -!*** to watch for the appearance of a signal from the parent -!*** indicating that it (the parent) intends to move. The child -!*** will use that shift information in two different ways. -!*** If two-way interaction is being used then the child must know -!*** the direction of the parent's move and prepare/send the 2-way -!*** data at the end of the parent timestep in which the parent -!*** shift took place. Then for all nesting the child uses the -!*** new parent location at the beginning of the parent timestep -!*** in which the shift occurs to properly prepare working objects, -!*** to receive, and to incorporate standard BC update data that -!*** was sent from the parent at the end of the timestep of the -!*** parent's shift. -!*** So in order to be ready for both those situations the child -!*** now receives the parent's shift and the new specifics of the -!*** parent task and nest task associations if this is the start -!*** of the parent timestep preceding the parent's shift. -!----------------------------------------------------------------------- -! - moving_parent: IF(MY_PARENT_MOVES)THEN -! -!----------------------------------------------------------------------- -! - PARENT_SHIFT_IS_PRESENT=.FALSE. -! - IF(I_AM_LEAD_FCST_TASK)THEN - NTAG0=PARENT_SHIFT_TAG+NTIMESTEP/TIME_RATIO_MY_PARENT !<-- Unique timestep-dependent MPI tag. It is valid one - ! parent timestep after the parent decides to move. - CALL MPI_IPROBE(0 & !<-- The message is sent by moving parent's fcst task 0. - ,NTAG0 & !<-- Tag associated with parent's shift - ,COMM_TO_MY_PARENT & !<-- Communicator between this nest and its parent - ,PARENT_SHIFT_IS_PRESENT & !<-- Is the parent's shift now available? - ,JSTAT & - ,IERR) -! - IF(PARENT_SHIFT_IS_PRESENT)THEN - CALL MPI_RECV(PARENT_SHIFT & !<-- Recv the parent's shift - ,3 & !<-- # of words in the message - ,MPI_INTEGER & !<-- The shifts in I and J are integers - ,0 & !<-- Local rank of the parent task sending the word - ,NTAG0 & !<-- Tag used for this data exchange - ,COMM_TO_MY_PARENT & !<-- Communicator between this nest and its parent - ,JSTAT & - ,IERR ) - ENDIF -! - ENDIF -! - CALL MPI_BCAST(PARENT_SHIFT_IS_PRESENT & !<-- Has the new move timestep been received? - ,1 & !<-- The signal is one word - ,MPI_LOGICAL & !<-- The signal is type Logical - ,0 & !<-- Broadcast from nest forecast task 0 - ,COMM_FCST_TASKS & !<-- MPI communicator for this nest's forecast tasks - ,IRTN) -! - IF(PARENT_SHIFT_IS_PRESENT)THEN -! - CALL MPI_BCAST(PARENT_SHIFT & !<-- Broadcast the parent shift - ,3 & !<-- # of words in the message - ,MPI_INTEGER & !<-- The shifts in I and J are integers - ,0 & !<-- Broadcast from nest forecast task 0 - ,COMM_FCST_TASKS & !<-- MPI communicator for this nest's forecast tasks - ,IRTN) -! - PARENT_WANTS_TO_MOVE=.TRUE. - NTIMESTEP_WAIT_PARENT=PARENT_SHIFT(1)*TIME_RATIO_MY_PARENT !<-- This child domain's timestep in which -! ! its parent will shift. -! - ENDIF -! - IF(NTIMESTEP==PARENT_SHIFT(1)*TIME_RATIO_MY_PARENT & !<-- Did the parent shift at the start of this parent timestep? - .AND. & - PARENT_SHIFT(1)>0)THEN -! - I_SW_PARENT_CURRENT=I_SW_PARENT_CURRENT-PARENT_SHIFT(2) !<-- Current parent I,J of SW corner of this child's domain - J_SW_PARENT_CURRENT=J_SW_PARENT_CURRENT-PARENT_SHIFT(3) ! after its parent shifts. -! - I_SW_PARENT_NEW=I_SW_PARENT_NEW-PARENT_SHIFT(2) !<-- New parent I,J of SW corner of this child's domain - J_SW_PARENT_NEW=J_SW_PARENT_NEW-PARENT_SHIFT(3) ! after the child and parent have shifted. -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent-Child coupler export state - ,name ='I_SW_PARENT_NEW' & !<-- Insert Attribute with this name - ,value=I_SW_PARENT_NEW & !<-- Motion of nest in I on its grid - ,rc =RC ) -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent-Child coupler export state - ,name ='J_SW_PARENT_NEW' & !<-- Insert Attribute with this name - ,value=J_SW_PARENT_NEW & !<-- Motion of nest in J on its grid - ,rc =RC ) -! - CALL DEALLOC_WORK_CHILDREN(MY_DOMAIN_ID) !<-- Reset this child's working pointers for 'new' location -! - CALL CHILD_RECVS_CHILD_DATA_LIMITS(EXP_STATE,MY_DOMAIN_ID) !<-- Parent/child bndry task associations -! - IF(FORCED_PARENT_SHIFT)THEN - I_WANT_TO_MOVE=.FALSE. !<-- Now the child is free to compute its storm motion after - FORCED_PARENT_SHIFT=.FALSE. ! forcing its parent to shift due to close boundaries. - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF moving_parent -! -!----------------------------------------------------------------------- -!*** Children receive boundary data from their parents from one -!*** parent timestep in the future which will be put into the Parent- -!*** Child coupler export state on its way to the dynamics where it -!*** will be used to compute boundary tendencies through the next -!*** NN timesteps. NN is the number of child timesteps per parent -!*** timestep. This data will be for time N+1 in the boundary -!*** tendency computation: -!*** dX/dt = [ X(N+1) - X(N) ] / DT_parent -! -!*** Note that if this is a timestep at which a child has just moved, -!*** the child's location-dependent working pointers for the boundary -!*** data were already reset for the new location in the IF block for -!*** NTIMESTEP==NEXT_MOVE_TIMESTEP above. -! -!*** If the digital filter is running and this child is not active -!*** in it then it does not receive. -!----------------------------------------------------------------------- -! - IF(FREE_FORECAST.OR.(DIG_FILTER.AND.I_AM_ACTIVE))THEN -! - CALL NEST_RECVS_BC_DATA('Future') -! - ENDIF -! -!----------------------------------------------------------------------- -!*** In telescoping moving nests only the innermost utilizes the -!*** storm center location from the storm tracker. This prevents -!*** different generations of moving nests over the same storm -!*** from deciding to move in different ways. -! -!*** If the nest is forcing its parent to shift to avoid a -!*** collision then it will not call the routine until it knows -!*** the parent has completed its evasive shift. -! -!*** If a nest's or its parent's poleward boundary has moved -!*** beyond the user-specified latitude limit then the nest -!*** is permanently immobilized. -! -!*** After taking the storm center location if the nest decides it -!*** wants to move then the shift will be executed LAG_STEPS parent -!*** timesteps later in this routine immediately above. By that -!*** time its parent will have learned that the nest wants to move -!*** and will have prepared BC and internal shift data valid at the -!*** proper timestep. -!----------------------------------------------------------------------- -! - moving_children_b: IF(MY_DOMAIN_MOVES)THEN !<-- Select the moving nests -! -!----------------------------------------------------------------------- -! - motion: IF(.NOT.I_WANT_TO_MOVE & !<-- Nest not waiting to shift from earlier call to routine - .AND. & - .NOT.FORCED_PARENT_SHIFT & !<-- Nest not immobilized after forcing its parent to shift - .AND. & - .NOT.STOP_MY_MOTION)THEN !<-- Nest not immobilized at the specified latitude limit. -! -!----------------------------------------------------------------------- -! - innermost: IF(NUM_CHILDREN==0)THEN !<-- Only innermost moving nests explicitly follow storms -! ! whereas outer nests follow their inner nests. -!----------------------------------------------------------------------- -! - IF (TRIM(MOVE_TYPE) == 'storm') THEN -! -!----------------------------------------------------------------------- -!*** The storm tracker determines the storm center on this domain's -!*** grid every NPHS*NTRACK timesteps. If this is an appropriate -!*** timestep then extract the latest center location. -!----------------------------------------------------------------------- -! - new_center: & -! - IF(NTRACK>0 & - .AND. & - NTIMESTEP>0 & - .AND. & - MOD(NTIMESTEP,NTRACK*NPHS)==0)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract storm center from P-C Cpl import state." -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & - ,name ='Storm Center' & !<-- Name of the attribute to extract - ,valueList=STORM_CENTER & !<-- I,J of the storm center on this grid. - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - I_DIFF=STORM_CENTER(1)-I_CENTER_CURRENT !<-- Distance in I,J from current to - J_DIFF=STORM_CENTER(2)-J_CENTER_CURRENT ! new storm center. -! -!----------------------------------------------------------------------- -!*** If the child moves then its SW corner must shift from one parent -!*** H point to another which means the I and J shifts must be in -!*** integer multiples of SPACE_RATIO_MY_PARENT. Adjust I_DIFF and -!*** J_DIFF given this constraint. -!----------------------------------------------------------------------- -! - IF(MOD(I_DIFF,SPACE_RATIO_MY_PARENT)/=0)THEN - PARENT_DIFF=REAL(I_DIFF)/REAL(SPACE_RATIO_MY_PARENT) - IF(ABS(FRACTION(PARENT_DIFF))>0.5)THEN - I_DIFF=NINT(PARENT_DIFF)*SPACE_RATIO_MY_PARENT - ELSE - I_DIFF=INT(PARENT_DIFF)*SPACE_RATIO_MY_PARENT - ENDIF - ENDIF -! - IF(MOD(J_DIFF,SPACE_RATIO_MY_PARENT)/=0)THEN - PARENT_DIFF=REAL(J_DIFF)/REAL(SPACE_RATIO_MY_PARENT) - IF(ABS(FRACTION(PARENT_DIFF))>0.5)THEN - J_DIFF=NINT(PARENT_DIFF)*SPACE_RATIO_MY_PARENT - ELSE - J_DIFF=INT(PARENT_DIFF)*SPACE_RATIO_MY_PARENT - ENDIF - ENDIF -! - IF(MAX_SHIFT<999)THEN !<-- If true the nest's shift distance is restricted. - MAX_SHIFT_CHILD=MAX_SHIFT*SPACE_RATIO_MY_PARENT !<-- Max shift in I and/or J on the nest's grid - I_DIFF=MIN(MAX(I_DIFF,-MAX_SHIFT_CHILD),MAX_SHIFT_CHILD) - J_DIFF=MIN(MAX(J_DIFF,-MAX_SHIFT_CHILD),MAX_SHIFT_CHILD) - ENDIF -! - I_SW_PARENT_NEW=I_SW_PARENT_CURRENT+I_DIFF/SPACE_RATIO_MY_PARENT - J_SW_PARENT_NEW=J_SW_PARENT_CURRENT+J_DIFF/SPACE_RATIO_MY_PARENT -! - I_WANT_TO_MOVE=.TRUE. -! - IF(ABS(I_DIFF)==0.AND.ABS(J_DIFF)==0)THEN - I_WANT_TO_MOVE=.FALSE. - IF(I_AM_LEAD_FCST_TASK)THEN - WRITE(0,*)' NO MOTION: Less than one parent grid increment.' - ENDIF - ENDIF -! - ENDIF new_center -! -! CALL COMPUTE_STORM_MOTION(NTIMESTEP & -! ,LAST_STEP_MOVED & -! ,DT_DOMAIN(MY_DOMAIN_ID) & -! ,NUM_PES_FCST & -! ,COMM_FCST_TASKS & -! ,FIS & -! ,PD & -! ,PINT & -! ,T & -! ,Q & -! ,CW & -! ,U & -! ,V & -! ,DSG2 & -! ,PDSG1 & -! ,DXH & -! ,DYH & -! ,SM & -! ,I_SW_PARENT_CURRENT & -! ,J_SW_PARENT_CURRENT & -! ,I_WANT_TO_MOVE & -! ,I_SW_PARENT_NEW & -! ,J_SW_PARENT_NEW & -! ,MY_DOMAIN_ID ) -! - ELSE IF (TRIM(MOVE_TYPE) == 'prescribed') THEN - - CALL PRESCRIBED_MOVE(NTIMESTEP,DT_DOMAIN(MY_DOMAIN_ID) & - ,I_WANT_TO_MOVE & - ,I_SW_PARENT_CURRENT & - ,J_SW_PARENT_CURRENT & - ,I_SW_PARENT_NEW & - ,J_SW_PARENT_NEW ) - -! ELSE IF (TRIM(MOVE_TYPE) == 'artificial5') THEN -! -! CALL ARTIFICIAL_MOVE5(NTIMESTEP & -! ,KOUNT_MOVES & -! ,I_WANT_TO_MOVE & -! ,I_SW_PARENT_CURRENT & -! ,J_SW_PARENT_CURRENT & -! ,I_SW_PARENT_NEW & -! ,J_SW_PARENT_NEW ) - - ELSE - - WRITE(0,*)' Unknown move type :', TRIM(MOVE_TYPE) - WRITE(0,*)' ABORTING!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - - ENDIF -! - ENDIF innermost -! -!----------------------------------------------------------------------- -!*** The motion of a moving parent is essentially determined by the -!*** motion of its child. The parent watches the location of its -!*** child and when the distance between the centers of the two -!*** domains exceeds the specified value then the parent shifts in -!*** order to bring its center as close as possible to the child's. -!*** However that desired shift must also be great enough to span -!*** at least one of its own parent's grid increments since all -!*** nests move so that their SW corner coincides with an H point -!*** on their parent's grid. -!----------------------------------------------------------------------- -! - outer: IF(NUM_CHILDREN>0 & !<-- This moving child has a moving child. - .AND. & - NTIMESTEP>NEXT_MOVE_TIMESTEP)THEN !<-- Wait 1 timestep after shifting before considering another. -! -!----------------------------------------------------------------------- -! - N=1 !<-- Moving nests can have only one child for now. -! - CENTER_I_OUTER=0.5*(IDS+IDE) - CENTER_J_OUTER=0.5*(JDS+JDE) -! - CENTER_I_INNER=I_PARENT_SW(N) & - +0.5*(IM_CHILD(N)-1.)*CHILD_PARENT_SPACE_RATIO(N) - CENTER_J_INNER=J_PARENT_SW(N) & - +0.5*(JM_CHILD(N)-1.)*CHILD_PARENT_SPACE_RATIO(N) - DIFF_I=CENTER_I_INNER-CENTER_I_OUTER - DIFF_J=CENTER_J_INNER-CENTER_J_OUTER -! - DISTANCE=SQRT(DIFF_I**2+DIFF_J**2) !<-- Distance in outer nest grid increments - ! between the outer and inner nest centers. -! - I_SHIFT_PARENT_GRID=NINT(DIFF_I/REAL(SPACE_RATIO_MY_PARENT)) !<-- Prospective I shift on this nest's parent's grid. - J_SHIFT_PARENT_GRID=NINT(DIFF_J/REAL(SPACE_RATIO_MY_PARENT)) !<-- Prospective J shift on this nest's parent's grid. - I_SHIFT_MY_GRID=I_SHIFT_PARENT_GRID*SPACE_RATIO_MY_PARENT !<-- Prospective I shift on this nest's grid. - J_SHIFT_MY_GRID=J_SHIFT_PARENT_GRID*SPACE_RATIO_MY_PARENT !<-- Prospective J shift on this nest's grid. -! -!----------------------------------------------------------------------- -!*** The outer moving nest now checks to see if the distance between -!*** its center and its moving child's exceeds the pre-specified -!*** value. If it does then it will set a prospective shift as -!*** long as that shift will span at least one of its parent's grid -!*** increments since all nest motion involves moving the SW corner -!*** of the nest domain from one parent H point to another. -!----------------------------------------------------------------------- -! - IF(DISTANCE>CENTERS_DISTANCE & !<-- Inner nest center exceeds distance for outer nest shift. - .AND. & - (ABS(I_SHIFT_PARENT_GRID)>=1 & !<-- Outer nest shift must be at least - .OR. & ! one grid increment in I or J - ABS(J_SHIFT_PARENT_GRID)>=1))THEN ! on its parent's grid. -! - I_WANT_TO_MOVE=.TRUE. -! - I_SW_PARENT_NEW=I_SW_PARENT_CURRENT+I_SHIFT_PARENT_GRID !<-- This nest's SW corner will lie on this I and J - J_SW_PARENT_NEW=J_SW_PARENT_CURRENT+J_SHIFT_PARENT_GRID ! of its parent's domain after this shift. -! -!----------------------------------------------------------------------- -!*** This moving parent wants to shift since its and its childs -!*** centers are now too far apart. However make sure the child -!*** is not already prepared to shift again. If it is then the -!*** parent will not shift. -!----------------------------------------------------------------------- -! - DO NN=1,NUM_CHILDREN - IF(NTIMESTEP<=SHIFT_INFO_CHILDREN(1,NN) & - .AND. & - SHIFT_INFO_CHILDREN(1,NN) & - <=NTIMESTEP+TIME_RATIO_MY_PARENT*LAG_STEPS)THEN -! - I_WANT_TO_MOVE=.FALSE. - I_SW_PARENT_NEW=I_SW_PARENT_CURRENT - J_SW_PARENT_NEW=J_SW_PARENT_CURRENT -! - IF(I_AM_LEAD_FCST_TASK)THEN - WRITE(0,51511)MY_DOMAIN_ID,NTIMESTEP & - ,N,SHIFT_INFO_CHILDREN(1,NN) -51511 FORMAT(' CHILDREN_RECV MY_DOMAIN_ID=',I2,' NTIMESTEP=',I6 & - ,' I wanted to move but child #',I2,' will shift at ',i6) - WRITE(0,51512) -51512 FORMAT(' So I will not shift.') - ENDIF - ENDIF - ENDDO -! -!----------------------------------------------------------------------- -! - ENDIF -! - ENDIF outer -! -!----------------------------------------------------------------------- -! - ENDIF motion -! -!----------------------------------------------------------------------- -!*** If necessary account for the very special situation in which -!*** a child of this domain wants to move too close to this domain's -!*** boundary. When that happens then this domain is forced to -!*** move to avoid the collision. -!----------------------------------------------------------------------- -! - IF(CHILD_FORCES_MY_SHIFT)THEN - I_WANT_TO_MOVE=.TRUE. - MOVE_FLAG_SENT=.FALSE. - I_SW_PARENT_NEW=I_SW_PARENT_CURRENT & - +NINT(MY_FORCED_SHIFT(1)*RECIP_PARENT_SPACE_RATIO) - J_SW_PARENT_NEW=J_SW_PARENT_CURRENT & - +NINT(MY_FORCED_SHIFT(2)*RECIP_PARENT_SPACE_RATIO) -! - IF(I_AM_LEAD_FCST_TASK)THEN - WRITE(0,52053)I_WANT_TO_MOVE,MOVE_FLAG_SENT,MY_DOMAIN_ID,NTIMESTEP - WRITE(0,52054)MY_FORCED_SHIFT(1),MY_FORCED_SHIFT(2) -52053 FORMAT(' CHILDREN_RECV child_forces_my_shift i_want_to_move=',L1,' move_flag_sent=',L1,' my_domain_id=',I2,' ntimestep=',I5) -52054 FORMAT(' my forced I shift=',i4,' my forced J shift=',I4) - ENDIF - ENDIF -! -!----------------------------------------------------------------------- -!*** If this child wants to shift and it knows that its parent -!*** had already initiated its own shift but has not yet moved -!*** then this child simply ignores its own desire to shift and -!*** waits NTIMESTEP_WAIT_PARENT after which its parent will -!*** have executed its shift. The child will then be free to -!*** initiate a shift. -!----------------------------------------------------------------------- -! - IF(I_WANT_TO_MOVE.AND.PARENT_WANTS_TO_MOVE)THEN -! - I_WANT_TO_MOVE=.FALSE. - I_SW_PARENT_NEW=I_SW_PARENT_CURRENT - J_SW_PARENT_NEW=J_SW_PARENT_CURRENT - NEXT_MOVE_TIMESTEP=-999 - MOVE_FLAG_SENT=.FALSE. -! - ENDIF -! - IF(NTIMESTEP_WAIT_PARENT>0 & !<-- Parent has wanted to shift at least once - .AND. & - NTIMESTEP>NTIMESTEP_WAIT_PARENT-TIME_RATIO_MY_PARENT)THEN !<-- Reset this brake 1 parent timestep before parent shifts. - PARENT_WANTS_TO_MOVE=.FALSE. - ENDIF -! -!----------------------------------------------------------------------- -!*** If the nest has decided it wants to shift then finalize the -!*** key values and inform the parent. -!----------------------------------------------------------------------- -! - IF(I_WANT_TO_MOVE.AND..NOT.MOVE_FLAG_SENT)THEN !<-- Nest wants to move; shift info not already sent -! -!----------------------------------------------------------------------- -!*** If this child domain is also a parent then it must check to see -!*** if its shift would bring its children's domains too close to the -!*** parent boundary. If it does then this domain must not shift. -!----------------------------------------------------------------------- -! - DISTN_TO_PARENT_BNDRY=1.E6 -! - IF(NUM_CHILDREN>0)THEN - DO N=1,NUM_CHILDREN - I_SHIFT=(I_SW_PARENT_NEW-I_SW_PARENT_CURRENT)*SPACE_RATIO_MY_PARENT - J_SHIFT=(J_SW_PARENT_NEW-J_SW_PARENT_CURRENT)*SPACE_RATIO_MY_PARENT - CHILD_DOMAIN_EW=REAL(IM_CHILD(N)-1)/REAL(PARENT_CHILD_SPACE_RATIO(N)) - CHILD_DOMAIN_NS=REAL(JM_CHILD(N)-1)/REAL(PARENT_CHILD_SPACE_RATIO(N)) - DISTN_SOUTH=J_PARENT_SW(N)-J_SHIFT-JDS - DISTN_NORTH=JDE-(J_PARENT_SW(N)+CHILD_DOMAIN_NS)+J_SHIFT - DISTN_WEST =I_PARENT_SW(N)-I_SHIFT-IDS - DISTN_EAST =IDE-(I_PARENT_SW(N)+CHILD_DOMAIN_EW)+I_SHIFT - DISTN_TO_PARENT_BNDRY=MIN(DISTN_SOUTH,DISTN_NORTH & - ,DISTN_WEST,DISTN_EAST & - ,DISTN_TO_PARENT_BNDRY) - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -! - check_shift: IF(DISTN_TO_PARENT_BNDRY<=MIN_DIST_PARENT)THEN -! - I_WANT_TO_MOVE=.FALSE. !<-- Do not allow this domain (as a parent) to move. -! - IF(NTIMESTEP>NTIMESTEP_WAIT_FORCED_PARENT)THEN !<-- If true, previous forced move of parent is done. - I_SW_PARENT_NEW=I_SW_PARENT_CURRENT - J_SW_PARENT_NEW=J_SW_PARENT_CURRENT - ENDIF -! - IF(I_AM_LEAD_FCST_TASK)THEN - WRITE(0,77771)MY_DOMAIN_ID,NTIMESTEP,DISTN_TO_PARENT_BNDRY - WRITE(0,77772)I_SHIFT,J_SHIFT - WRITE(0,77773)DISTN_SOUTH,DISTN_NORTH,DISTN_WEST,DISTN_EAST -77771 FORMAT(' DO NOT allow this parent to move my_domain_id=',i2 & - ,' ntimestep=',i5,' distn_to_parent_bndry=',e12.5) -77772 FORMAT(' Parent wanted to shift ',I3,3X,I3,' on its grid') -77773 FORMAT(' distn_south=',e12.5,' distn_north=',e12.5 & - ,' distn_west=',e12.5,' distn_east=',e12.5) - ENDIF -! - ELSE -! -!----------------------------------------------------------------------- -!*** First the child checks to see if the shift it wants to make -!*** will take it too near to the domain boundary of its parent. -!*** If it does then the child does not move and instead informs -!*** the parent that it must move far enough in the direction the -!*** child wants to move so that when the child does move then -!*** the child will not be too close to the parent boundary. -!*** The array PARENT_DOMAIN_LIMITS used below holds the west, -!*** east, south, and north index limits, respectively, of the -!*** parent domain. -!----------------------------------------------------------------------- -! - CHILD_DOMAIN_EW=REAL(IDE-IDS)*RECIP_PARENT_SPACE_RATIO !<-- E-W extent of child domain in terms of parent grid - CHILD_DOMAIN_NS=REAL(JDE-JDS)*RECIP_PARENT_SPACE_RATIO !<-- N-S extent of child domain in terms of parent grid -! - DIST_SOUTH=J_SW_PARENT_NEW-PARENT_DOMAIN_LIMITS(3) !<-- Distance of child sbdry from parent sbdry - DIST_NORTH=PARENT_DOMAIN_LIMITS(4)-(J_SW_PARENT_NEW+CHILD_DOMAIN_NS) !<-- Distance of child nbdry from parent nbdry - DIST_WEST =I_SW_PARENT_NEW-PARENT_DOMAIN_LIMITS(1) !<-- Distance of child wbdry from parent wbdry - DIST_EAST =PARENT_DOMAIN_LIMITS(2)-(I_SW_PARENT_NEW+CHILD_DOMAIN_EW) !<-- Distance of child ebdry from parent ebdry -! - DIST_TO_PARENT_BNDRY=MIN(DIST_SOUTH,DIST_NORTH,DIST_WEST,DIST_EAST) !<-- Min distance between child and parent boundaries - ! in terms of the parent grid. -! -!----------------------------------------------------------------------- -! - parent_bdy: IF(DIST_TO_PARENT_BNDRY>MIN_DIST_PARENT)THEN !<-- If true, the child is not too close to the parent boundary. -! -!----------------------------------------------------------------------- -!*** If this child's shift will take its poleward boundary beyond -!*** the latitude limit then let it execute that shift after which -!*** it will not move again. Likewise if this child's parent is a -!*** moving nest and has reached the latitude limit then the child -!*** must stop its own motion as the parent has already done. -!----------------------------------------------------------------------- -! - J_SHIFT=J_SW_PARENT_NEW-J_SW_PARENT_CURRENT !<-- This nest's shift in terms of its parent's grid - SHIFT_LAT=J_SHIFT*SPACE_RATIO_MY_PARENT*DPH !<-- This nest's shift in geographic latitude (rad) - DOMAIN_NBND=GLAT(ITS,JTS)+DPH*(JDE-JTS)+SHIFT_LAT !<-- Post-shift geog latitude (rad) of child's north bndry - DOMAIN_SBND=GLAT(ITS,JTS)-DPH*(JTS-JDS)+SHIFT_LAT !<-- Post-shift geog latitude (rad) of child's south bndry -! - PARENT_NBND=((PARENT_DOMAIN_LIMITS(4)-J_SW_PARENT_NEW) & !<-- - *SPACE_RATIO_MY_PARENT & ! Geographic latitude (rad) - -(JTS-JDS))*DPH & ! of parent's north boundary. - +GLAT(ITS,JTS) !<-- -! - PARENT_SBND=((PARENT_DOMAIN_LIMITS(3)-J_SW_PARENT_NEW) & !<-- - *SPACE_RATIO_MY_PARENT & ! Geographic latitude (rad) - -(JTS-JDS))*DPH & ! of parent's south boundary. - +GLAT(ITS,JTS) !<-- -! - IF(DOMAIN_NBND>NORTH_LAT_MAX_MVG_NEST-EPS & !<-- Has the nest's north boundary reached too far north? - .OR. & - DOMAIN_SBNDNORTH_LAT_MAX_MVG_NEST-EPS & !<-- Has the parent's north boundary reached too far north? - .OR. & - PARENT_SBNDTIME_RATIO_MY_PARENT*LAG_STEPS & - .AND. & - NTIMESTEPNTIMESTEP_WAIT_FORCED_PARENT)THEN !<-- If true, previous forced move of parent is done. -! - FORCED_PARENT_SHIFT=.TRUE. !<-- Flag remains true until the parent shifts as told. -! - IF(I_AM_LEAD_FCST_TASK)THEN !<-- Lead forecast task on this moving nest -! - CALL MPI_WAIT(HANDLE_MOVE_FLAG & !<-- Handle for ISend of child's move flag to parent - ,JSTAT & !<-- MPI status - ,IERR) -! - SHIFT_INFO_MINE(1)=-11111 !<-- This tells the parent it is being forced to shift. -! - IF(DIST_WEST<=MIN_DIST_PARENT)THEN - SHIFT_INFO_MINE(2)=-MAX_FORCED_SHIFT !<-- Child pushes parent to the west (parent grid increments) - ELSEIF(DIST_EAST<=MIN_DIST_PARENT)THEN - SHIFT_INFO_MINE(2)=MAX_FORCED_SHIFT !<-- Child pushes parent to the east (parent grid increments) - ENDIF -! - IF(DIST_SOUTH<=MIN_DIST_PARENT)THEN - SHIFT_INFO_MINE(3)=-MAX_FORCED_SHIFT !<-- Child pushes parent to the south (parent grid increments) - ELSEIF(DIST_NORTH<=MIN_DIST_PARENT)THEN - SHIFT_INFO_MINE(3)=MAX_FORCED_SHIFT !<-- Child pushes parent to the north (parent grid increments) - ENDIF -! - MOVE_TAG=1111+10*MY_DOMAIN_ID+25*ID_PARENTS(MY_DOMAIN_ID) !<-- Unique MPI tag uses child and parent domain IDs -! - CALL MPI_ISSEND(SHIFT_INFO_MINE & !<-- Key shift information - ,4 & !<-- There are 3 words in the flag - ,MPI_INTEGER & !<-- Signal is type Integer - ,0 & !<-- Signal sent to parent task 0 - ,MOVE_TAG & !<-- Arbitrary tag used for this data exchange - ,COMM_TO_MY_PARENT & !<-- MPI communicator between this child and its parent - ,HANDLE_MOVE_FLAG & !<-- Communication request handle for ISend to parent - ,IERR ) -! - WRITE(0,55551)MY_DOMAIN_ID,NTIMESTEP - WRITE(0,55552)SHIFT_INFO_MINE,MOVE_TAG -55551 FORMAT(' CHILDREN_RECV forcing parent to shift' & - ,' my_domain_id=',I2,' ntimestep=',I5) -55552 FORMAT(' SHIFT_INFO=',4(1X,I6),' move_tag=',I6) -! - ENDIF -! -!----------------------------------------------------------------------- -!*** This child has just sent its parent a message saying that the -!*** parent must shift because the child's desired shift would -!*** otherwise cause a collision between the two domains' boundaries. -!*** The parent will not be able to act on this until the start of -!*** the following parent timestep and then must wait for LAG_STEPS -!*** timesteps of its own parent before executing its shift. This -!*** child must not initiate another forced shift of its parent -!*** until after that amount of time which is LAG_STEPS+1 of this -!*** child's grandparent's timesteps from now. -!----------------------------------------------------------------------- -! - ID_GRANDPARENT=ID_PARENTS(ID_PARENTS(MY_DOMAIN_ID)) !<-- My parent's parent's domain ID - DT_GRANDPARENT=DT_DOMAIN(ID_GRANDPARENT) !<-- My parent's parent's timestep interval (sec) -! - NTIMESTEP_WAIT_FORCED_PARENT=NTIMESTEP & !<-- The next timestep this domain - +NINT(DT_GRANDPARENT*(LAG_STEPS+1) & ! will be allowed to initiate a - /DT_DOMAIN(MY_DOMAIN_ID)) ! forced move of its parent. -! - ENDIF -! -!----------------------------------------------------------------------- -! - ELSE !<-- This child's parent is static. -! - I_WANT_TO_MOVE=.FALSE. !<-- The parent cannot be pushed so do nothing. -! - WRITE(0,55553)MY_DOMAIN_ID,NTIMESTEP - WRITE(0,55554) - WRITE(0,55555) -55553 FORMAT(' CHILDREN_RECV my_domain_id=',I2 & - ,' ntimestep=',I5) -55554 FORMAT(' Child wants to move too close to parent bndry!') -55555 FORMAT(' Parent cannot be pushed away so do not shift.') -! -!----------------------------------------------------------------------- -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF parent_bdy -! -!----------------------------------------------------------------------- -! - ENDIF check_shift -! -!----------------------------------------------------------------------- -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF moving_children_b -! -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -! - SUBROUTINE NEST_RECVS_BC_DATA(TIME_FLAG) -! -!----------------------------------------------------------------------- -!*** A nest receives boundary data from its parent so that -!*** it can compute boundary tendencies for its integration. -!*** This is an internal subroutine to CHILDREN_RECV_PARENT_DATA. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - CHARACTER(len=*),INTENT(IN) :: TIME_FLAG !<-- BC data valid for current or future timestep? -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: ID_ADD,IERR,N,NP_H,NP_V,NTAG -! - integer(kind=kint) :: mype_intra -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Point at the memory valid for this particular domain -!*** since individual tasks might lie on more than one domain. -!----------------------------------------------------------------------- -! - CALL POINT_TO_COMPOSITE(MY_DOMAIN_ID) -! -!----------------------------------------------------------------------- -!*** Each child task that holds part of the domain boundary receives -!*** data from the parent tasks that cover its boundary points. -!*** This occurs for two different situations: -!*** (1) All nests receive boundary data from their parents that was -!*** sent from one parent timestep in the future. That allows -!*** each nest to compute boundary value tendencies that are -!*** applied through the next NN child timesteps of integration -!*** where NN is the number of child timesteps within each parent -!*** timestep. -!*** (2) Immediately after a moving nest moves, it needs new boundary -!*** values for that current time at the new location. The -!*** structure of that boundary data is the same as in (1) so -!*** it is received from the parents in the same way. However -!*** that data then needs to be stored as the values for current -!*** parent timestep N where the boundary tendency for variable X -!*** is [X(N+1)-X(N)]/DT(parent). The values from the future -!*** timestep N+1 will subsequently be received as usual. -! -!*** Thus we simply need to know whether the incoming data is for the -!*** future time (#1 above) or for the current time (#2 above). That -!*** information is given by this subroutine's input argument. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! -!*** Now for each side of the nests' boundaries: -! -!*** (a) Each child task receives all boundary data from the -!*** relevant parent task(s). Note that more than one -!*** parent task might send to each child task and there may -!*** be overlap due to haloes. -!*** (b) The child tasks separate the data received from each of -!*** the parent tasks and combines them into unified segments -!*** on the boundary for each variable. -!*** (c) All boundary data is loaded into the Parent-Child Coupler's -!*** export state. -! -!----------------------------------------------------------------------- -! - cpl1_prelim_tim=cpl1_prelim_tim+(timef()-btim0) -! - ID_ADD=1000*MY_DOMAIN_ID -! -!-------------------- -!*** South H Points -!-------------------- -! - btim0=timef() -! - NP_H=NUM_PARENT_TASKS_SENDING_H%SOUTH !<-- # of parent tasks sending south boundary H data -! - IF(NP_H>0)THEN -! - NTAG=NTIMESTEP+101+ID_ADD !<-- Add 101 and domain ID to obtain a unique south H tag -! - DO N=1,NP_H !<-- Loop over each parent task sending Sboundary H data - call date_and_time(values=values) -! write(0,123)n,parent_task(n)%south_h%id_source,values(5),values(6),values(7),values(8) - 123 format(' Ready to recv South_H from parent task #',i1,' id=',i3.3,' at ',i2.2,':',i2.2,':',i2.2,'.',i3.3) -! -! if(my_domain_id==4.and.ntimestep>=15516)then -! write(0,39571)trim(time_flag) -! write(0,39572)n,PARENT_TASK(N)%SOUTH_H%ID_SOURCE,PARENT_TASK(N)%SOUTH_H%LENGTH,ntag,np_h -39571 format(' NEST_RECVS_BC_DATA(',a7,') for South_H') -39572 format(' from parent task #',i3,' id=',i3,' # words=',i5,' ntag=',i6,' # parent tasks sending=',i2) -! endif - btim=timef() - CALL MPI_RECV(PARENT_TASK(N)%SOUTH_H%STRING & !<-- 1-D boundary datastring from parent task - ,PARENT_TASK(N)%SOUTH_H%LENGTH & !<-- # of words in the datastring - ,MPI_REAL & !<-- Datatype - ,PARENT_TASK(N)%SOUTH_H%ID_SOURCE & !<-- Local rank of the parent task sending the datastring - ,NTAG & !<-- MPI tag - ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator - ,JSTAT & !<-- MPI status object - ,IERR) - cpl1_south_h_recv_tim=cpl1_south_h_recv_tim+(timef()-btim) - cpl1_recv_tim=cpl1_recv_tim+(timef()-btim) - call date_and_time(values=values) -! write(0,124)n,parent_task(n)%south_h%id_source,values(5),values(6),values(7),values(8) - 124 format(' Recvd South_H from parent task #',i1,' id=',i3.3,' at ',i2.2,':',i2.2,':',i2.2,'.',i3.3) -! -!----------------------------------------------------------------------- -! - btim=timef() - CALL CHILD_DATA_FROM_STRING(length_data=PARENT_TASK(N)%SOUTH_H%LENGTH & !<-- Length of parent datastring - ,datastring =PARENT_TASK(N)%SOUTH_H%STRING & !<-- Parent datastring of child task bndry segment - ,ilim_lo =INDX_MIN_H%SOUTH & !<-- Lower I limit of child's segment of boundary - ,ilim_hi =INDX_MAX_H%SOUTH & !<-- Upper I limit of child's segment of boundary - ,jlim_lo =1 & !<-- Lower J limit of child's segment of boundary - ,jlim_hi =N_BLEND_H & !<-- Upper J limit of child's segment of boundary - ,i_start =PARENT_TASK(N)%SOUTH_H%INDX_START & !<-- Child's segment Istart on each parent task - ,i_end =PARENT_TASK(N)%SOUTH_H%INDX_END & !<-- Child's segment Iend on each parent task - ,j_start =1 & !<-- Child's segment Jstart on each parent task - ,j_end =N_BLEND_H & !<-- Child's segment Jend on each parent task - ,nvars_bc_2d_h =NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary - ,nvars_bc_3d_h =NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary - ,nvars_bc_4d_h =NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary - ,lbnd_4d =LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension - ,ubnd_4d =UBND_4D & !<-- Upper bounds of 4-D variables' 4th dimension - ,nvars_bc_2d_v =NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary - ,nvars_bc_3d_v =NVARS_BC_3D_V & !<-- # of 3-D V-pt vbls on child boundary - ,pdb =PDB_S & !<-- Child's 1-D segment of PD on Sbndry - ,bc_vars_h =MY_BC_VARS_H_S ) !<-- Child's 1-D segment of other H-pt vbls on Sbndry -! - cpl1_south_h_undo_tim=cpl1_south_h_undo_tim+(timef()-btim) -! - ENDDO -! -!----------------------------------------------------------------------- -! - btim=timef() - CALL EXPORT_CHILD_BOUNDARY(nvars_bc_2d_h=NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary - ,nvars_bc_3d_h=NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary - ,nvars_bc_4d_h=NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary - ,lbnd_4d =LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension - ,ubnd_4d =UBND_4D & !<-- Upper bounds of 4-D variables' 4th dimension - ,nvars_bc_2d_v=NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary - ,nvars_bc_3d_v=NVARS_BC_3D_V & !<-- # of 3-D V-pt vbls on child boundary - ,pdb =PDB_S & !<-- Child's 1-D segment of PD on Sbndry - ,bc_vars_h =MY_BC_VARS_H_S & !<-- Child's 1-D segment of other H-pt vbls on Sbndry - ,ilim_lo =INDX_MIN_H%SOUTH & !<-- Lower I limit of child's segment of boundary - ,ilim_hi =INDX_MAX_H%SOUTH & !<-- Upper I limit of child's segment of boundary - ,jlim_lo =1 & !<-- Lower J limit of child's segment of boundary - ,jlim_hi =N_BLEND_H & !<-- Upper J limit of child's segment of boundary - ,data_name ='SOUTH_H_'//TIME_FLAG & !<-- Name attached to the combined exported data - ,data_exp =BOUND_1D_SOUTH_H & !<-- Combined boundary segment H data for child task - ,export_state =EXP_STATE ) !<-- The Parent-Child Coupler export state -! - cpl1_south_h_exp_tim=cpl1_south_h_exp_tim+(timef()-btim) - ENDIF -! - cpl1_south_h_tim=cpl1_south_h_tim+(timef()-btim0) -! -!-------------------- -!*** South V Points -!-------------------- -! - btim0=timef() -! - NP_V=NUM_PARENT_TASKS_SENDING_V%SOUTH !<-- # of parent tasks sending south boundary V data -! - IF(NP_V>0)THEN - NTAG=NTIMESTEP+102+ID_ADD !<-- Add 102 and domain ID to obtain a unique south V tag -! - DO N=1,NP_V !<-- Loop over each parent task sending Sboundary V data -! - btim=timef() - CALL MPI_RECV(PARENT_TASK(N)%SOUTH_V%STRING & !<-- 1-D boundary datastring from parent task - ,PARENT_TASK(N)%SOUTH_V%LENGTH & !<-- # of words in the datastring - ,MPI_REAL & !<-- Datatype - ,PARENT_TASK(N)%SOUTH_V%ID_SOURCE & !<-- Local rank of the parent task sending the datastring - ,NTAG & !<-- MPI tag - ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator - ,JSTAT & !<-- MPI status object - ,IERR) - cpl1_south_v_recv_tim=cpl1_south_v_recv_tim+(timef()-btim) - cpl1_recv_tim=cpl1_recv_tim+(timef()-btim) - call date_and_time(values=values) -! write(0,125)n,parent_task(n)%south_v%id_source,values(5),values(6),values(7),values(8) - 125 format(' Recvd South_V from parent task #',i1,' id=',i3.3,' at ',i2.2,':',i2.2,':',i2.2,'.',i3.3) -! -!----------------------------------------------------------------------- -! - btim=timef() - CALL CHILD_DATA_FROM_STRING(length_data=PARENT_TASK(N)%SOUTH_V%LENGTH & !<-- Length of parent datastring - ,datastring =PARENT_TASK(N)%SOUTH_V%STRING & !<-- Parent datastring of child task bndry segment - ,ilim_lo =INDX_MIN_V%SOUTH & !<-- Lower I limit of child's segment of boundary - ,ilim_hi =INDX_MAX_V%SOUTH & !<-- Upper I limit of child's segment of boundary - ,jlim_lo =1 & !<-- Lower J limit of child's segment of boundary - ,jlim_hi =N_BLEND_V & !<-- Upper J limit of child's segment of boundary - ,i_start =PARENT_TASK(N)%SOUTH_V%INDX_START & !<-- Child's segment Istart on each parent task - ,i_end =PARENT_TASK(N)%SOUTH_V%INDX_END & !<-- Child's segment Iend on each parent task - ,j_start =1 & !<-- Child's segment Jstart on each parent task - ,j_end =N_BLEND_V & !<-- Child's segment Jend on each parent task - ,nvars_bc_2d_h=NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary - ,nvars_bc_3d_h=NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary - ,nvars_bc_4d_h=NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary - ,lbnd_4d =LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension - ,ubnd_4d =UBND_4D & !<-- Upper bounds of 4-D variables' 4th dimension - ,nvars_bc_2d_v=NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary - ,nvars_bc_3d_v=NVARS_BC_3D_V & !<-- # of 3-D V-pt vbls on child boundary - ,bc_vars_v =MY_BC_VARS_V_S ) !<-- Child's 1-D segment of V-pt vbls on Sbndry - cpl1_south_v_undo_tim=cpl1_south_v_undo_tim+(timef()-btim) -! - ENDDO -! -!----------------------------------------------------------------------- -! - btim=timef() - CALL EXPORT_CHILD_BOUNDARY(nvars_bc_2d_h=NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary - ,nvars_bc_3d_h=NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary - ,nvars_bc_4d_h=NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary - ,lbnd_4d =LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension - ,ubnd_4d =UBND_4D & !<-- Upper bounds of 4-D variables' 4th dimension - ,nvars_bc_2d_v=NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary - ,nvars_bc_3d_v=NVARS_BC_3D_V & !<-- # of 3-D V-pt vbls on child boundary - ,bc_vars_v =MY_BC_VARS_V_S & !<-- Child's 1-D segment of V-pt vbls on Sbndry - ,ilim_lo =INDX_MIN_V%SOUTH & !<-- Lower I limit of child's segment of boundary - ,ilim_hi =INDX_MAX_V%SOUTH & !<-- Upper I limit of child's segment of boundary - ,jlim_lo =1 & !<-- Lower J limit of child's segment of boundary - ,jlim_hi =N_BLEND_V & !<-- Upper J limit of child's segment of boundary - ,data_name ='SOUTH_V_'//TIME_FLAG & !<-- Name attached to the combined exported data - ,data_exp =BOUND_1D_SOUTH_V & !<-- Combined boundary segment V data for child task - ,export_state =EXP_STATE ) !<-- The Parent-Child Coupler export state -! - cpl1_south_v_exp_tim=cpl1_south_v_exp_tim+(timef()-btim) -! - ENDIF -! - cpl1_south_v_tim=cpl1_south_v_tim+(timef()-btim0) -! -!-------------------- -!*** North H Points -!-------------------- -! - btim0=timef() -! - NP_H=NUM_PARENT_TASKS_SENDING_H%NORTH !<-- # of parent tasks sending north boundary H data -! - IF(NP_H>0)THEN - NTAG=NTIMESTEP+103+ID_ADD !<-- Add 103 and domain ID to obtain a unique north H tag -! - DO N=1,NP_H !<-- Loop over each parent task sending Nboundary H data - btim=timef() - CALL MPI_RECV(PARENT_TASK(N)%NORTH_H%STRING & !<-- 1-D boundary datastring from parent task - ,PARENT_TASK(N)%NORTH_H%LENGTH & !<-- # of words in the datastring - ,MPI_REAL & !<-- Datatype - ,PARENT_TASK(N)%NORTH_H%ID_SOURCE & !<-- Local rank of the parent task sending the datastring - ,NTAG & !<-- MPI tag - ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator - ,JSTAT & !<-- MPI status object - ,IERR) - cpl1_recv_tim=cpl1_recv_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -! - CALL CHILD_DATA_FROM_STRING(length_data =PARENT_TASK(N)%NORTH_H%LENGTH & - ,datastring =PARENT_TASK(N)%NORTH_H%STRING & - ,ilim_lo =INDX_MIN_H%NORTH & - ,ilim_hi =INDX_MAX_H%NORTH & - ,jlim_lo =1 & - ,jlim_hi =N_BLEND_H & - ,i_start =PARENT_TASK(N)%NORTH_H%INDX_START & - ,i_end =PARENT_TASK(N)%NORTH_H%INDX_END & - ,j_start =1 & - ,j_end =N_BLEND_H & - ,nvars_bc_2d_h=NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary - ,nvars_bc_3d_h=NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary - ,nvars_bc_4d_h=NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary - ,lbnd_4d =LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension - ,ubnd_4d =UBND_4D & !<-- Upper bounds of 4-D variables' 4th dimension - ,nvars_bc_2d_v=NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary - ,nvars_bc_3d_v=NVARS_BC_3D_V & !<-- # of 3-D V-pt vbls on child boundary - ,pdb =PDB_N & !<-- Child's 1-D segment of PD on Nbndry - ,bc_vars_h =MY_BC_VARS_H_N ) !<-- Child's 1-D segment of other H-pt vbls on Nbndry -! - ENDDO -! -!----------------------------------------------------------------------- -! - CALL EXPORT_CHILD_BOUNDARY(nvars_bc_2d_h=NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary - ,nvars_bc_3d_h=NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary - ,nvars_bc_4d_h=NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary - ,lbnd_4d =LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension - ,ubnd_4d =UBND_4D & !<-- Upper bounds of 4-D variables' 4th dimension - ,nvars_bc_2d_v=NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary - ,nvars_bc_3d_v=NVARS_BC_3D_V & !<-- # of 3-D V-pt vbls on child boundary - ,pdb =PDB_N & !<-- Child's 1-D segment of PD on Nbndry - ,bc_vars_h =MY_BC_VARS_H_N & !<-- Child's 1-D segment of other H-pt vbls on Nbndry - ,ilim_lo =INDX_MIN_H%NORTH & !<-- Lower I limit of child's segment of boundary - ,ilim_hi =INDX_MAX_H%NORTH & !<-- Upper I limit of child's segment of boundary - ,jlim_lo =1 & !<-- Lower J limit of child's segment of boundary - ,jlim_hi =N_BLEND_H & !<-- Upper J limit of child's segment of boundary - ,data_name ='NORTH_H_'//TIME_FLAG & !<-- Name attached to the combined exported data - ,data_exp =BOUND_1D_NORTH_H & !<-- Combined boundary segment H data for child task - ,export_state =EXP_STATE ) !<-- The Parent-Child Coupler export state -! - ENDIF -! - cpl1_north_h_tim=cpl1_north_h_tim+(timef()-btim0) -! -!-------------------- -!*** North V Points -!-------------------- -! - btim0=timef() -! - NP_V=NUM_PARENT_TASKS_SENDING_V%NORTH !<-- # of parent tasks sending north boundary V data -! - IF(NP_V>0)THEN - NTAG=NTIMESTEP+104+ID_ADD !<-- Add 104 and domain ID to obtain a unique north V tag -! - DO N=1,NP_V !<-- Loop over each parent task sending Nboundary V data - btim=timef() - CALL MPI_RECV(PARENT_TASK(N)%NORTH_V%STRING & !<-- 1-D boundary datastring from parent task - ,PARENT_TASK(N)%NORTH_V%LENGTH & !<-- # of words in the datastring - ,MPI_REAL & !<-- Datatype - ,PARENT_TASK(N)%NORTH_V%ID_SOURCE & !<-- Local rank of the parent task sending the datastring - ,NTAG & !<-- MPI tag - ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator - ,JSTAT & !<-- MPI status object - ,IERR) - cpl1_recv_tim=cpl1_recv_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -! - CALL CHILD_DATA_FROM_STRING(length_data =PARENT_TASK(N)%NORTH_V%LENGTH & - ,datastring =PARENT_TASK(N)%NORTH_V%STRING & - ,ilim_lo =INDX_MIN_V%NORTH & - ,ilim_hi =INDX_MAX_V%NORTH & - ,jlim_lo =1 & - ,jlim_hi =N_BLEND_V & - ,i_start =PARENT_TASK(N)%NORTH_V%INDX_START & - ,i_end =PARENT_TASK(N)%NORTH_V%INDX_END & - ,j_start =1 & - ,j_end =N_BLEND_V & - ,nvars_bc_2d_h=NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary - ,nvars_bc_3d_h=NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary - ,nvars_bc_4d_h=NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary - ,lbnd_4d =LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension - ,ubnd_4d =UBND_4D & !<-- Upper bounds of 4-D variables' 4th dimension - ,nvars_bc_2d_v=NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary - ,nvars_bc_3d_v=NVARS_BC_3D_V & !<-- # of 3-D V-pt vbls on child boundary - ,bc_vars_v =MY_BC_VARS_V_N ) !<-- Child's 1-D segment of V-pt vbls on Nbndry -! - ENDDO -! -!----------------------------------------------------------------------- -! - CALL EXPORT_CHILD_BOUNDARY(nvars_bc_2d_h=NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary - ,nvars_bc_3d_h=NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary - ,nvars_bc_4d_h=NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary - ,lbnd_4d =LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension - ,ubnd_4d =UBND_4D & !<-- Upper bounds of 4-D variables' 4th dimension - ,nvars_bc_2d_v=NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary - ,nvars_bc_3d_v=NVARS_BC_3D_V & !<-- # of 3-D V-pt vbls on child boundary - ,bc_vars_v =MY_BC_VARS_V_N & !<-- Child's 1-D segment of V-pt vbls on Nbndry - ,ilim_lo =INDX_MIN_V%NORTH & !<-- Lower I limit of child's segment of boundary - ,ilim_hi =INDX_MAX_V%NORTH & !<-- Upper I limit of child's segment of boundary - ,jlim_lo =1 & !<-- Lower J limit of child's segment of boundary - ,jlim_hi =N_BLEND_V & !<-- Upper J limit of child's segment of boundary - ,data_name ='NORTH_V_'//TIME_FLAG & !<-- Name attached to the combined exported data - ,data_exp =BOUND_1D_NORTH_V & !<-- Combined boundary segment V data for child task - ,export_state =EXP_STATE ) !<-- The Parent-Child Coupler export state -! - ENDIF -! - cpl1_north_v_tim=cpl1_north_v_tim+(timef()-btim0) -! -!------------------- -!*** West H Points -!------------------- -! - btim0=timef() -! - NP_H=NUM_PARENT_TASKS_SENDING_H%WEST !<-- # of parent tasks sending west boundary H data -! - IF(NP_H>0)THEN - NTAG=NTIMESTEP+105+ID_ADD !<-- Add 105 and domain ID to obtain a unique west H tag -! - DO N=1,NP_H !<-- Loop over each parent task sending Wboundary H data - btim=timef() - CALL MPI_RECV(PARENT_TASK(N)%WEST_H%STRING & !<-- 1-D boundary datastring from parent task - ,PARENT_TASK(N)%WEST_H%LENGTH & !<-- # of words in the datastring - ,MPI_REAL & !<-- Datatype - ,PARENT_TASK(N)%WEST_H%ID_SOURCE & !<-- Local rank of the parent task sending the datastring - ,NTAG & !<-- MPI tag - ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator - ,JSTAT & !<-- MPI status object - ,IERR) - cpl1_recv_tim=cpl1_recv_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -! - CALL CHILD_DATA_FROM_STRING(length_data =PARENT_TASK(N)%WEST_H%LENGTH & - ,datastring =PARENT_TASK(N)%WEST_H%STRING & - ,ilim_lo =1 & - ,ilim_hi =N_BLEND_H & - ,jlim_lo =INDX_MIN_H%WEST & - ,jlim_hi =INDX_MAX_H%WEST & - ,i_start =1 & - ,i_end =N_BLEND_H & - ,j_start =PARENT_TASK(N)%WEST_H%INDX_START & - ,j_end =PARENT_TASK(N)%WEST_H%INDX_END & - ,nvars_bc_2d_h=NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary - ,nvars_bc_3d_h=NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary - ,nvars_bc_4d_h=NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary - ,lbnd_4d =LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension - ,ubnd_4d =UBND_4D & !<-- Upper bounds of 4-D variables' 4th dimension - ,nvars_bc_2d_v=NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary - ,nvars_bc_3d_v=NVARS_BC_3D_V & !<-- # of 3-D V-pt vbls on child boundary - ,pdb =PDB_W & !<-- Child's 1-D segment of PD on Wbndry - ,bc_vars_h =MY_BC_VARS_H_W ) !<-- Child's 1-D segment of other H-pt vbls on Wbndry -! - ENDDO -! -!----------------------------------------------------------------------- -! - CALL EXPORT_CHILD_BOUNDARY(nvars_bc_2d_h=NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary - ,nvars_bc_3d_h=NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary - ,nvars_bc_4d_h=NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary - ,lbnd_4d =LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension - ,ubnd_4d =UBND_4D & !<-- Upper bounds of 4-D variables' 4th dimension - ,nvars_bc_2d_v=NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary - ,nvars_bc_3d_v=NVARS_BC_3D_V & !<-- # of 3-D V-pt vbls on child boundary - ,pdb =PDB_W & !<-- Child's 1-D segment of PD on Wbndry - ,bc_vars_h =MY_BC_VARS_H_W & !<-- Child's 1-D segment of other H-pt vbls on Wbndry - ,ilim_lo =1 & !<-- Lower I limit of child's segment of boundary - ,ilim_hi =N_BLEND_H & !<-- Upper I limit of child's segment of boundary - ,jlim_lo =INDX_MIN_H%WEST & !<-- Lower J limit of child's segment of boundary - ,jlim_hi =INDX_MAX_H%WEST & !<-- Upper J limit of child's segment of boundary - ,data_name ='WEST_H_'//TIME_FLAG & !<-- Name attached to the combined exported data - ,data_exp =BOUND_1D_WEST_H & !<-- Combined boundary segment H data for child task - ,export_state =EXP_STATE ) !<-- The Parent-Child Coupler export state -! - ENDIF -! - cpl1_west_h_tim=cpl1_west_h_tim+(timef()-btim0) -! -!------------------- -!*** West V Points -!------------------- -! - btim0=timef() -! - NP_V=NUM_PARENT_TASKS_SENDING_V%WEST !<-- # of parent tasks sending west boundary V data -! - IF(NP_V>0)THEN - NTAG=NTIMESTEP+106+ID_ADD !<-- Add 106 and domain ID to obtain a unique west V tag -! - DO N=1,NP_V !<-- Loop over each parent task sending Sboundary V data - btim=timef() - CALL MPI_RECV(PARENT_TASK(N)%WEST_V%STRING & !<-- 1-D boundary datastring from parent task - ,PARENT_TASK(N)%WEST_V%LENGTH & !<-- # of words in the datastring - ,MPI_REAL & !<-- Datatype - ,PARENT_TASK(N)%WEST_V%ID_SOURCE & !<-- Local rank of the parent task sending the datastring - ,NTAG & !<-- MPI tag - ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator - ,JSTAT & !<-- MPI status object - ,IERR) - cpl1_recv_tim=cpl1_recv_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -! - CALL CHILD_DATA_FROM_STRING(length_data =PARENT_TASK(N)%WEST_V%LENGTH & - ,datastring =PARENT_TASK(N)%WEST_V%STRING & - ,ilim_lo =1 & - ,ilim_hi =N_BLEND_V & - ,jlim_lo =INDX_MIN_V%WEST & - ,jlim_hi =INDX_MAX_V%WEST & - ,i_start =1 & - ,i_end =N_BLEND_V & - ,j_start =PARENT_TASK(N)%WEST_V%INDX_START & - ,j_end =PARENT_TASK(N)%WEST_V%INDX_END & - ,nvars_bc_2d_h=NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary - ,nvars_bc_3d_h=NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary - ,nvars_bc_4d_h=NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary - ,lbnd_4d =LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension - ,ubnd_4d =UBND_4D & !<-- Upper bounds of 4-D variables' 4th dimension - ,nvars_bc_2d_v=NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary - ,nvars_bc_3d_v=NVARS_BC_3D_V & !<-- # of 3-D V-pt vbls on child boundary - ,bc_vars_v =MY_BC_VARS_V_W ) !<-- Child's 1-D segment of V-pt vbls on Wbndry -! - ENDDO -! -!----------------------------------------------------------------------- -! - CALL EXPORT_CHILD_BOUNDARY(nvars_bc_2d_h=NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary - ,nvars_bc_3d_h=NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary - ,nvars_bc_4d_h=NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary - ,lbnd_4d =LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension - ,ubnd_4d =UBND_4D & !<-- Upper bounds of 4-D variables' 4th dimension - ,nvars_bc_2d_v=NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary - ,nvars_bc_3d_v=NVARS_BC_3D_V & !<-- # of 3-D V-pt vbls on child boundary - ,bc_vars_v =MY_BC_VARS_V_W & !<-- Child's 1-D segment of V-pt vbls on Wbndry - ,ilim_lo =1 & !<-- Lower I limit of child's segment of boundary - ,ilim_hi =N_BLEND_V & !<-- Upper I limit of child's segment of boundary - ,jlim_lo =INDX_MIN_V%WEST & !<-- Lower J limit of child's segment of boundary - ,jlim_hi =INDX_MAX_V%WEST & !<-- Upper J limit of child's segment of boundary - ,data_name ='WEST_V_'//TIME_FLAG & !<-- Name attached to the combined exported data - ,data_exp =BOUND_1D_WEST_V & !<-- Combined boundary segment V data for child task - ,export_state =EXP_STATE ) !<-- The Parent-Child Coupler export state -! - ENDIF -! - cpl1_west_v_tim=cpl1_west_v_tim+(timef()-btim0) -! -!------------------- -!*** East H Points -!------------------- -! - btim0=timef() -! - NP_H=NUM_PARENT_TASKS_SENDING_H%EAST !<-- # of parent tasks sending east boundary H data -! - IF(NP_H>0)THEN - NTAG=NTIMESTEP+107+ID_ADD !<-- Add 107 and domain ID to obtain a unique east H tag -! - DO N=1,NP_H !<-- Loop over each parent task sending Eboundary H data - btim=timef() - CALL MPI_RECV(PARENT_TASK(N)%EAST_H%STRING & !<-- 1-D boundary datastring from parent task - ,PARENT_TASK(N)%EAST_H%LENGTH & !<-- # of words in the datastring - ,MPI_REAL & !<-- Datatype - ,PARENT_TASK(N)%EAST_H%ID_SOURCE & !<-- Local rank of the parent task sending the datastring - ,NTAG & !<-- MPI tag - ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator - ,JSTAT & !<-- MPI status object - ,IERR) - cpl1_recv_tim=cpl1_recv_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -! - CALL CHILD_DATA_FROM_STRING(length_data =PARENT_TASK(N)%EAST_H%LENGTH & - ,datastring =PARENT_TASK(N)%EAST_H%STRING & - ,ilim_lo =1 & - ,ilim_hi =N_BLEND_H & - ,jlim_lo =INDX_MIN_H%EAST & - ,jlim_hi =INDX_MAX_H%EAST & - ,i_start =1 & - ,i_end =N_BLEND_H & - ,j_start =PARENT_TASK(N)%EAST_H%INDX_START & - ,j_end =PARENT_TASK(N)%EAST_H%INDX_END & - ,nvars_bc_2d_h=NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary - ,nvars_bc_3d_h=NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary - ,nvars_bc_4d_h=NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary - ,lbnd_4d =LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension - ,ubnd_4d =UBND_4D & !<-- Upper bounds of 4-D variables' 4th dimension - ,nvars_bc_2d_v=NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary - ,nvars_bc_3d_v=NVARS_BC_3D_V & !<-- # of 3-D V-pt vbls on child boundary - ,pdb =PDB_E & !<-- Child's 1-D segment of PD on Ebndry - ,bc_vars_h =MY_BC_VARS_H_E ) !<-- Child's 1-D segment of other H-pt vbls on Ebndry -! - ENDDO -! -!----------------------------------------------------------------------- -! - CALL EXPORT_CHILD_BOUNDARY(nvars_bc_2d_h=NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary - ,nvars_bc_3d_h=NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary - ,nvars_bc_4d_h=NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary - ,lbnd_4d =LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension - ,ubnd_4d =UBND_4D & !<-- Upper bounds of 4-D variables' 4th dimension - ,nvars_bc_2d_v=NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary - ,nvars_bc_3d_v=NVARS_BC_3D_V & !<-- # of 3-D V-pt vbls on child boundary - ,pdb =PDB_E & !<-- Child's 1-D segment of PD on Ebndry - ,bc_vars_h =MY_BC_VARS_H_E & !<-- Child's 1-D segment of other H-pt vbls on Ebndry - ,ilim_lo =1 & !<-- Lower I limit of child's segment of boundary - ,ilim_hi =N_BLEND_H & !<-- Upper I limit of child's segment of boundary - ,jlim_lo =INDX_MIN_H%EAST & !<-- Lower J limit of child's segment of boundary - ,jlim_hi =INDX_MAX_H%EAST & !<-- Upper J limit of child's segment of boundary - ,data_name ='EAST_H_'//TIME_FLAG & !<-- Name attached to the combined exported data - ,data_exp =BOUND_1D_EAST_H & !<-- Combined boundary segment H data for child task - ,export_state =EXP_STATE ) !<-- The Parent-Child Coupler export state -! - ENDIF -! - cpl1_east_h_tim=cpl1_east_h_tim+(timef()-btim0) -! -!------------------- -!*** East V Points -!------------------- -! - btim0=timef() -! - NP_V=NUM_PARENT_TASKS_SENDING_V%EAST !<-- # of parent tasks sending east boundary V data -! - IF(NP_V>0)THEN - NTAG=NTIMESTEP+108+ID_ADD !<-- Add 108 and domain ID to obtain a unique east V tag -! - DO N=1,NP_V !<-- Loop over each parent task sending Eboundary V data - btim=timef() - CALL MPI_RECV(PARENT_TASK(N)%EAST_V%STRING & !<-- 1-D boundary datastring from parent task - ,PARENT_TASK(N)%EAST_V%LENGTH & !<-- # of words in the datastring - ,MPI_REAL & !<-- Datatype - ,PARENT_TASK(N)%EAST_V%ID_SOURCE & !<-- Local rank of the parent task sending the datastring - ,NTAG & !<-- MPI tag - ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator - ,JSTAT & !<-- MPI status object - ,IERR) - cpl1_recv_tim=cpl1_recv_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -! - CALL CHILD_DATA_FROM_STRING(length_data =PARENT_TASK(N)%EAST_V%LENGTH & - ,datastring =PARENT_TASK(N)%EAST_V%STRING & - ,ilim_lo =1 & - ,ilim_hi =N_BLEND_V & - ,jlim_lo =INDX_MIN_V%EAST & - ,jlim_hi =INDX_MAX_V%EAST & - ,i_start =1 & - ,i_end =N_BLEND_V & - ,j_start =PARENT_TASK(N)%EAST_V%INDX_START & - ,j_end =PARENT_TASK(N)%EAST_V%INDX_END & - ,nvars_bc_2d_h=NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary - ,nvars_bc_3d_h=NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary - ,nvars_bc_4d_h=NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary - ,lbnd_4d =LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension - ,ubnd_4d =UBND_4D & !<-- Upper bounds of 4-D variables' 4th dimension - ,nvars_bc_2d_v=NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary - ,nvars_bc_3d_v=NVARS_BC_3D_V & !<-- # of 3-D V-pt vbls on child boundary - ,bc_vars_v =MY_BC_VARS_V_E ) !<-- Child's 1-D segment of V-pt vbls on Ebndry -! - ENDDO -! -!----------------------------------------------------------------------- -! - CALL EXPORT_CHILD_BOUNDARY(nvars_bc_2d_h=NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary - ,nvars_bc_3d_h=NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary - ,nvars_bc_4d_h=NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary - ,lbnd_4d =LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension - ,ubnd_4d =UBND_4D & !<-- Upper bounds of 4-D variables' 4th dimension - ,nvars_bc_2d_v=NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary - ,nvars_bc_3d_v=NVARS_BC_3D_V & !<-- # of 3-D V-pt vbls on child boundary - ,bc_vars_v =MY_BC_VARS_V_E & !<-- Child's 1-D segment of V-pt vbls on Ebndry - ,ilim_lo =1 & !<-- Lower I limit of child's segment of boundary - ,ilim_hi =N_BLEND_V & !<-- Upper I limit of child's segment of boundary - ,jlim_lo =INDX_MIN_V%EAST & !<-- Lower J limit of child's segment of boundary - ,jlim_hi =INDX_MAX_V%EAST & !<-- Upper J limit of child's segment of boundary - ,data_name ='EAST_V_'//TIME_FLAG & !<-- Name attached to the combined exported data - ,data_exp =BOUND_1D_EAST_V & !<-- Combined boundary segment V data for child task - ,export_state =EXP_STATE ) !<-- The Parent-Child Coupler export state -! - ENDIF -! - cpl1_east_v_tim=cpl1_east_v_tim+(timef()-btim0) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert Clocktime for Recv in Phase1 into Cpl Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The parent-child coupler export state - ,name ='Cpl1_Recv_Time' & !<-- Name of the attribute to insert - ,value=cpl1_recv_tim & !<-- Phase 1 Recv time - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - END SUBROUTINE NEST_RECVS_BC_DATA -! -!----------------------------------------------------------------------- -! - END SUBROUTINE CHILDREN_RECV_PARENT_DATA -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE PARENTS_SEND_CHILD_DATA(CPL_COMP & - ,IMP_STATE & - ,EXP_STATE & - ,CLOCK & - ,RC_FINAL) -! -!----------------------------------------------------------------------- -!*** Parents send new boundary data to each of their children. -!*** Only parents execute this routine that is called as phase 4 -!*** of the Run step of the Parent-Child coupler in subroutine -!*** NMM_INTEGRATE. -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_CplComp) :: CPL_COMP !<-- The Parent-Child Coupler Component -! - TYPE(ESMF_State) :: IMP_STATE & !<-- The Coupler's Import State - ,EXP_STATE !<-- The Coupler's Export State -! - TYPE(ESMF_Clock) :: CLOCK !<-- The NMM Clock for this parent domain -! - INTEGER,INTENT(OUT) :: RC_FINAL -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: CHILDTASK_0 & - ,COMM_FCST_TASKS & - ,I_PARENT_SW_OLD & - ,J_PARENT_SW_OLD & - ,KOUNT_MOVING,MY_DOMAIN_ID,N,N_MOVING & - ,N_UPDATE_CHILD_TASKS & - ,NR,NRES,NTAG0 & - ,NTIMESTEP & - ,NTIMESTEP_CHILD & - ,NTIMESTEP_MOVE & - ,NUM_CHILD_TASKS,SPACE_RATIO -! - INTEGER(kind=KINT) :: IERR,IRTN,RC,RC_CPL_RUN -! - INTEGER(kind=ESMF_KIND_I8) :: NTIMESTEP_ESMF -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE,SAVE :: & - PROCEED_AFTER_BC_RECV -! - INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: CHILD_TASK_LIMITS -! - INTEGER(kind=KINT),DIMENSION(MPI_STATUS_SIZE) :: JSTAT -! - LOGICAL(kind=KLOG) :: EXCH_DONE & - ,INTEGRATE_TIMESTEP,PARENT_MOVED & - ,SHIFT_INFO_IS_PRESENT -! - TYPE(COMPOSITE),POINTER :: CC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - btim0=timef() - btim2=timef() -! -!----------------------------------------------------------------------- -!*** Initialize the error signal variables. -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RC_FINAL =ESMF_SUCCESS - RC_CPL_RUN=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -! -!----------------------- -!*** Current Domain ID -!----------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="PARENTS_SEND_CHILD_DATA: Extract Current Domain ID" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='MY_DOMAIN_ID' & !<-- Name of the attribute to extract - ,value=MY_DOMAIN_ID & !<-- Current domain's ID - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!---------------------------------- -!*** Are we in the free forecast? -!---------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="PARENTS_SEND_CHILD_DATA: Extract Free Forecast flag" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='Free Forecast' & !<-- Name of the attribute to extract - ,value=FREE_FORECAST & !<-- Is this the free forecast? - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DIG_FILTER=.FALSE. - IF(.NOT.FREE_FORECAST)THEN - DIG_FILTER=.TRUE. - ENDIF -! -!----------------------------------------------------------------------- -!*** Point to the correct part of the composite object which will -!*** align working variables with values associated with this domain. -!----------------------------------------------------------------------- -! - CALL POINT_TO_COMPOSITE(MY_DOMAIN_ID) -! -!----------------------------------------------------------------------- -!*** Intracommunicator for current domain's forecast tasks -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Fcst Task Intracommunicator" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='Comm Fcst Tasks' & !<-- Name of the attribute to extract - ,value=COMM_FCST_TASKS & !<-- Current domain's intracomm for fcst tasks - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_CLOCKGET(CLOCK =CLOCK & !<-- The ESMF Clock - ,advanceCount=ntimestep_esmf & !<-- The parent's current timestep (ESMF) - ,rc =rc) -! - NTIMESTEP=NTIMESTEP_ESMF !<-- The parent just finished the current timestep -! -!----------------------------------------------------------------------- -! - CHILDTASK_0=FTASKS_DOMAIN(MY_DOMAIN_ID) !<-- Rank of each child's task 0 in intracommunicator - KOUNT_MOVING=0 !<-- Keep track of nests who want to move. -! -!----------------------------------------------------------------------- -!*** The following block is for the setup in which this parent domain -!*** is a moving nest and it contains children (which must be moving -!*** and cannot be static). -!*** If this domain is going to move in one of its parent's timesteps -!*** from now (TIME_RATIO_MY_PARENT timesteps of this domain) then -!*** it now notifies its children of the coming shift. This is -!*** required so that the children will be able to recompute the -!*** parent-child task layout relationships which will change when the -!*** parent moves. This will force the children to wait to recv the -!*** task update specifications for BCs from the parent before they -!*** execute their normal recvs of BC data updates from the future -!*** at the end of this routine. -!*** If the parent just moved at the beginning of the current timestep -!*** it must adjust its location of its children. -!*** Note that I_SHIFT_CHILD and J_SHIFT_CHILD here are the shift -!*** values of this parent domain on its own grid inherited from -!*** subroutine CHILDREN_RECV_PARENT_DATA in which it was a child. -!----------------------------------------------------------------------- -! - PARENT_MOVED=.FALSE. -! - parent_moves: IF(MY_DOMAIN_MOVES)THEN !<-- Does this parent domain move? -! -!----------------------------------------------------------------------- -!*** The lead task on this parent domain notifies the lead tasks on -!*** each of its children's domains that it is going to shift. -!*** Even though PARENT_SHIFT is the same for all children it must -!*** be filled after the call to MPI_WAIT. -!----------------------------------------------------------------------- -! - btim2=timef() -! - IF(NTIMESTEP==NEXT_MOVE_TIMESTEP-TIME_RATIO_MY_PARENT*LAG_STEPS)THEN !<-- Parent sends its shift information at the end of the -! ! timestep in which the decision to shift was made. - IF(NUM_CHILDREN>0.AND.I_AM_LEAD_FCST_TASK)THEN -! - DO N=1,NUM_CHILDREN -! - CALL MPI_WAIT(HANDLE_PARENT_SHIFT(N) & !<-- Handle for ISend of parent's shift - ,JSTAT & !<-- MPI status - ,IERR) -! - PARENT_SHIFT(1)=NEXT_MOVE_TIMESTEP !<-- Parent will shift in this parent timestep. - PARENT_SHIFT(2)=I_SHIFT_CHILD !<-- Parent's I shift in its space - PARENT_SHIFT(3)=J_SHIFT_CHILD !<-- Parent's J shift in its space -! - NTAG0=PARENT_SHIFT_TAG+NTIMESTEP+1 !<-- Unique MPI tag valid 1 parent timestep after decision to shift - CHILDTASK_0=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(0) !<-- Local rank of child N's lead task in parent-child intracomm -! - CALL MPI_ISSEND(PARENT_SHIFT & !<-- Send parent's shift to all its children - ,3 & !<-- There are 2 words in the message - ,MPI_INTEGER & !<-- The shift increments are integers - ,CHILDTASK_0 & !<-- Signal sent to all lead child tasks - ,NTAG0 & !<-- Tag valid for parent timestep preceding its actual shift - ,COMM_TO_MY_CHILDREN(N) & !<-- MPI communicator between this parent and its children - ,HANDLE_PARENT_SHIFT(N) & !<-- Communication request handle for this ISend to children - ,IERR ) -! - ENDDO -! - pscd1_tim=pscd1_tim+(timef()-btim2) -! - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -! - this_timestep: IF(NTIMESTEP==NEXT_MOVE_TIMESTEP)THEN -! - btim2=timef() -! - PARENT_MOVED=.TRUE. !<-- Parent moved at beginning of current timestep -! - DO N=1,NUM_CHILDREN - I_PARENT_SW(N)=I_PARENT_SW(N)-I_SHIFT_CHILD !<-- Child N's new SW corner I after parent moved - J_PARENT_SW(N)=J_PARENT_SW(N)-J_SHIFT_CHILD !<-- Child N's new SW corner J after parent moved - ENDDO -! -!----------------------------------------------------------------------- -!*** Now fill the parent's data objects that hold the nest-resolution -!*** topography at child H points and child V points. Since the -!*** parent just moved then its MPI task subdomains need that data -!*** for their new locations. Note that in this situation the total -!*** number of children must equal the number of moving children. -!----------------------------------------------------------------------- -! - CALL PARENT_READS_MOVING_CHILD_TOPO(MY_DOMAIN_ID & - ,NUM_CHILDREN & - ,LINK_MRANK_RATIO & - ,LIST_OF_RATIOS & - ,M_NEST_RATIO & - ,NUM_SPACE_RATIOS_MVG & - ,GLOBAL_TOP_PARENT & - ,IM_1,JM_1 & - ,TPH0_1,TLM0_1 & - ,SB_1,WB_1 & - ,RECIP_DPH_1,RECIP_DLM_1 & - ,GLAT,GLON & - ,NEST_FIS_ON_PARENT_BNDS & - ,NEST_FIS_ON_PARENT & - ,NEST_FIS_V_ON_PARENT & - ,IDS,IDE,IMS,IME,ITS,ITE & - ,JDS,JDE,JMS,JME,JTS,JTE) -! - read_moving_child_topo_tim=read_moving_child_topo_tim+(timef()-btim2) -! - ENDIF this_timestep -! - ENDIF parent_moves -! -!----------------------------------------------------------------------- -!*** The parent generates new boundary data for all of its children -!*** given their domains' positions at the beginning of this parent -!*** timestep and sends it to the children so they can form time -!*** tendencies for their boundary variables as they integrate through -!*** this parent timestep. This is relevant for all children, both -!*** static and moving. If this is now a timestep in which the -!*** child shifts then the parent must now reset those working -!*** pointers/arrays that are used for the preparation of the -!*** standard child boundary updates that are sent back in time -!*** to all children every parent timestep so the child can generate -!*** its boundary tendencies. The reset is needed because the child's -!*** boundary has different associations with the parent tasks after -!*** the move. The same work is needed if the parent domain moved -!*** at the beginning of this timestep since that also changes the -!*** association of parent tasks and child boundary tasks. Also if -!*** the child just moved then the parent should update its haloes -!*** for those variables used to update the child's boundaries -!*** because a parent task's halo points will need to be used if -!*** some of the child's boundary rows lie within the parent task's -!*** integration points while others lie within that parent task's -!*** halo points. -!----------------------------------------------------------------------- -! - btim2=timef() -! - DO N=1,NUM_CHILDREN -! - IF(STATIC_OR_MOVING(N)=='Moving')THEN !<-- Select the children who can move. - KOUNT_MOVING=KOUNT_MOVING+1 -! - IF(NTIMESTEP==NTIMESTEP_CHILD_MOVES(N) & !<-- If either of these statements is true - .OR. & ! then child N just moved relative - PARENT_MOVED)THEN ! to this parent. -! - NRES=LINK_MRANK_RATIO(KOUNT_MOVING) !<-- Rank of space ratio value among the moving children -! - CALL RESET_WORK_PARENT(N,NRES,'Future',PARENT_MOVED) !<-- Reset working arrays for this moving nest. -! - ENDIF -! - ENDIF -! - IF(FREE_FORECAST.OR.(DIG_FILTER.AND.CHILD_ACTIVE(N)))THEN !<-- For DFI, check that the child is participating. -! - CALL COMPUTE_SEND_NEST_BC_DATA(N,'Future') !<-- Parent sends BC data to children from their future. -! - ENDIF -! - ENDDO -! - IF(PARENT_MOVED)PARENT_MOVED=.FALSE. -! - pscd2_tim=pscd2_tim + (timef()-btim2) -! -!----------------------------------------------------------------------- -!*** We are at the end of a parent timestep. If the parent has -!*** children who move then: -!*** -!*** (1) The parent receives a message from each child who can move -!*** only when the child wants to move. The message contains -!*** the parent timestep in which the child will shift as well -!*** as the shift in I and J on the parent grid. The message -!*** is received by the parent at the end of a parent timestep -!*** while the child will have sent it from the beginning of -!*** an earlier parent timestep depending on the relative -!*** integration speeds of parent and child. -!*** (2) The parent computes and sends new information to the moving -!*** children regarding the association of parent and child tasks -!*** for the children's new locations after they move. Then the -!*** parent computes and sends the new internal child data for -!*** those child gridpoints that have moved over a new region of -!*** the parent grid as well as the new starting boundary data -!*** for their grids' new locations. -!----------------------------------------------------------------------- -! - moving_children: IF(NUM_MOVING_CHILDREN>0)THEN !<-- Select all of this parent's moving children -! -!----------------------------------------------------------------------- -! - btim2=timef() -! - CALL MPI_BARRIER(COMM_FCST_TASKS,IRTN) !<-- Syncs Probe below with BC ISends above; required -! - barrier_move_tim=barrier_move_tim+(timef()-btim2) -! - EXCH_DONE=.FALSE. !<-- Initialize flag for parent halo exchanges -! -!----------------------------------------------------------------------- -! - btim2=timef() -! - parent_task_0: IF(I_AM_LEAD_FCST_TASK)THEN !<-- Lead parent task will probe for children's shift signals. -! -!----------------------------------------------------------------------- -! - child_loop_1: DO N=1,NUM_MOVING_CHILDREN !<-- Loop through this parent's moving children. -! -!----------------------------------------------------------------------- -! - N_MOVING=RANK_MOVING_CHILD(N) !<-- In the list of this parent's children, these can move. -! -!----------------------------------------------------------------------- -! - check_block1: IF(NTIMESTEP>NTIMESTEP_CHILD_MOVES(N))THEN !<-- Probe only after child's previous shift is complete. -! -!----------------------------------------------------------------------- -! - MOVE_FLAG(N)=.FALSE. !<-- True only when parent first learns child N wants to move. -! - CHILDTASK_0=child_ranks(MY_DOMAIN_ID)%CHILDREN(N_MOVING)%DATA(0) !<-- Local rank of child's lead task in p-c intracommunicator - MOVE_TAG=1111+10*MY_CHILDREN_ID(N_MOVING) & !<-- Unique MPI tag uses child and parent domain IDs - +25*MY_DOMAIN_ID -! - CALL MPI_IPROBE(CHILDTASK_0 & !<-- Is shift info present from moving child N's fcst task 0? - ,MOVE_TAG & !<-- Tag associated with nest N's move flag - ,COMM_TO_MY_CHILDREN(N_MOVING) & !<-- MPI communicator between parent and moving child N - ,SHIFT_INFO_IS_PRESENT & !<-- Is the nest's shift information now available? - ,JSTAT & - ,IERR) -! -!----------------------------------------------------------------------- -! - IF(SHIFT_INFO_IS_PRESENT)THEN -! - MOVE_FLAG(N)=.TRUE. !<-- Moving child N is saying it wants to move -! - CALL MPI_RECV(SHIFT_INFO_CHILDREN(1,N) & !<-- Recv the message and clear the nest's ISEND - ,4 & !<-- # of words in message - ,MPI_INTEGER & !<-- The message is type Integer. - ,CHILDTASK_0 & !<-- The message was sent by moving child N's fcst task 0. - ,MOVE_TAG & !<-- Arbitrary tag used for this data exchange - ,COMM_TO_MY_CHILDREN(N_MOVING) & !<-- MPI communicator between parent and moving child N - ,JSTAT & - ,IERR) -! - IF(I_WANT_TO_MOVE.AND.MOVE_FLAG(N))THEN - MOVE_FLAG(N)=.FALSE. !<-- Turn off the child's shift if parent also wants to move. - ENDIF -! - IF(NTIMESTEP>=NTIMESTEP_FINAL-2)THEN - MOVE_FLAG(N)=.FALSE. !<-- Children must not move just before the fcst ends - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF check_block1 -! -!----------------------------------------------------------------------- -! - ENDDO child_loop_1 -! -!----------------------------------------------------------------------- -! - ENDIF parent_task_0 -! - t0_recv_move_tim=t0_recv_move_tim+(timef()-btim2) -! -!----------------------------------------------------------------------- -! - child_loop_2: DO N=1,NUM_MOVING_CHILDREN !<-- Loop through this parent's moving children -! - N_MOVING=RANK_MOVING_CHILD(N) !<-- In the list of this parent's children, these can move. -! -!----------------------------------------------------------------------- -!*** Parent task 0 informs the other parent tasks if moving child N -!*** has signaled that it wants to move and if so then it shares -!*** the child's shift information. The 3 words in the shift info are: -! (1) The parent's timestep in which child N will move. -! (2) The child's shift in I on the parent grid. -! (3) The child's shift in J on the parent grid. -!----------------------------------------------------------------------- -! - check_block2: IF(NTIMESTEP>NTIMESTEP_CHILD_MOVES(N))THEN -! -!----------------------------------------------------------------------- -! - btim2=timef() -! - CALL MPI_BCAST(MOVE_FLAG(N) & !<-- Moving child N's signal: Does it want to move? - ,1 & !<-- The timestep is one word - ,MPI_LOGICAL & !<-- The signal is type Logical - ,0 & !<-- Broadcast from parent forecast task 0 - ,COMM_FCST_TASKS & !<-- Intracommunicator for this parent's forecast tasks - ,IRTN ) -! - IF(MOVE_FLAG(N))THEN !<-- If true then moving child N sent shift information. -! - CALL MPI_BCAST(SHIFT_INFO_CHILDREN(1,N) & !<-- Moving child N's shift information - ,4 & !<-- # of words in message - ,MPI_INTEGER & !<-- The message is type Integer - ,0 & !<-- Broadcast from parent forecast task 0 - ,COMM_FCST_TASKS & !<-- Intracommunicator for this parent's forecast tasks - ,IRTN ) -! - IF(SHIFT_INFO_CHILDREN(1,N)>0)THEN - NTIMESTEP_CHILD_MOVES(N)=SHIFT_INFO_CHILDREN(1,N) !<-- The parent timestep in which the child will move -! - ELSEIF(SHIFT_INFO_CHILDREN(1,N)==-11111)THEN !<-- Child is forcing the parent to move. - IF(.NOT.I_WANT_TO_MOVE)THEN !<-- Parent already wants to shift so do not force it again. - CHILD_FORCES_MY_SHIFT=.TRUE. !<-- Child N too close to parent boundary - MY_FORCED_SHIFT(1)=SHIFT_INFO_CHILDREN(2,N) !<-- Parent must shift this many gridspaces in I - MY_FORCED_SHIFT(2)=SHIFT_INFO_CHILDREN(3,N) !<-- Parent must shift this many gridspaces in J -! - IF(I_AM_LEAD_FCST_TASK)THEN - WRITE(0,74741)MY_FORCED_SHIFT,MY_DOMAIN_ID,NTIMESTEP -74741 FORMAT(' PARENTS_SEND my_forced_shift=',2(1X,I6),' my_domain_id=',I2,' ntimestep=',I5) - ENDIF -! - ENDIF -! - ENDIF -! - ENDIF -! - pscd3_tim=pscd3_tim+(timef()-btim2) -! -!----------------------------------------------------------------------- -! - ENDIF check_block2 -! -!----------------------------------------------------------------------- -!*** If the parent is at the end of a timestep immediately preceding -!*** a child's shift at the start of the next parent timestep then -!*** it prepares appropriate internal and BC update data for the -!*** child's new position. -!----------------------------------------------------------------------- -! - child_moves: IF(NTIMESTEP==NTIMESTEP_CHILD_MOVES(N)-1)THEN !<-- If true, moving child N will shift at the -! ! beginning of the next parent timestep. -!----------------------------------------------------------------------- -! - btim2=timef() -! - I_PARENT_SW_OLD=I_PARENT_SW(N_MOVING) !<-- Save the previous location of the nest. - J_PARENT_SW_OLD=J_PARENT_SW(N_MOVING) !<-- -! - CHILDTASK_0=child_ranks(MY_DOMAIN_ID)%CHILDREN(N_MOVING)%DATA(0) !<-- Local rank of child's lead task in p-c intracomm -! - I_PARENT_SW(N_MOVING)=I_PARENT_SW_OLD+SHIFT_INFO_CHILDREN(2,N) !<-- Child N to move its SW corner to this parent I - J_PARENT_SW(N_MOVING)=J_PARENT_SW_OLD+SHIFT_INFO_CHILDREN(3,N) !<-- Child N to move its SW corner to this parent J -! -!----------------------------------------------------------------------- -!*** If this child will shift at the start of the next parent timestep -!*** then reset the working arrays/pointers used to generate values -!*** interpolated from the parent to child's boundary immediately -!*** after a move. This set of working objects is separate from the -!*** standard ones used to interpolate boundary data for all nests -!*** since when a nest moves we need to have the objects in place -!*** for both the old location and the new until we know for certain -!*** those for the old location have been received by the moving child. -! -!*** Note that N_MOVING is the rank of the moving child among ALL of -!*** children and NRES is the rank of the moving child's space ratio -!*** in the list of unique space ratios for all moving children. -!----------------------------------------------------------------------- -! - NRES=LINK_MRANK_RATIO(N) !<-- Rank of space ratio value among the moving children -! - CALL RESET_WORK_PARENT(N_MOVING,NRES,'Current',PARENT_MOVED) -! -!----------------------------------------------------------------------- -!*** The parent generates and sends new boundary data for the child's -!*** new position that it will move to when it reaches this point in -!*** time that the parent is at now. -!----------------------------------------------------------------------- -! - CALL COMPUTE_SEND_NEST_BC_DATA(N_MOVING,'Current') -! -!----------------------------------------------------------------------- -!*** Parent tasks determine the index limits of the regions on -!*** moving nest N's task subdomains that they are responsible -!*** for updating after the nest moves. Those index limits are -!*** identical for H and V points. -!----------------------------------------------------------------------- -! - CHILD_TASK_LIMITS=>CTASK_LIMITS(MY_DOMAIN_ID)%CHILDREN(N_MOVING)%DATA - NUM_CHILD_TASKS=FTASKS_DOMAIN(MY_CHILDREN_ID(N_MOVING)) - SPACE_RATIO=PARENT_CHILD_SPACE_RATIO(N_MOVING) -! - N_UPDATE_CHILD_TASKS=0 - pscd4_tim=pscd4_tim+(timef()-btim2) -! - btim2=timef() - CALL PARENT_BOOKKEEPING_MOVING(I_PARENT_SW(N_MOVING) & !<-- SW corner of nest is on this parent I after move - ,J_PARENT_SW(N_MOVING) & !<-- SW corner of nest is on this parent J after move - ,I_PARENT_SW_OLD & !<-- SW corner of nest is on this parent I before move - ,J_PARENT_SW_OLD & !<-- SW corner of nest is on this parent J before move - ,ITS,ITE,JTS,JTE & !<-- ITS,ITE,JTS,JTE for this parent task - ,NUM_CHILD_TASKS & !<-- # of child forecast tasks - ,CHILD_TASK_LIMITS & !<-- ITS,ITE,JTS,JTE for each child forecast task - ,SPACE_RATIO & !<-- # of child grid increments in one of parent's - ,NHALO & !<-- # of halo points - ,NROWS_P_UPD_W & !<-- Moving nest footprint W bndry rows updated by parent - ,NROWS_P_UPD_E & !<-- Moving nest footprint E bndry rows updated by parent - ,NROWS_P_UPD_S & !<-- Moving nest footprint S bndry rows updated by parent - ,NROWS_P_UPD_N & !<-- Moving nest footprint N bndry rows updated by parent - ,N_UPDATE_CHILD_TASKS & !<-- # of moving nest tasks updated by this parent task - ,TASK_UPDATE_SPECS(N) & !<-- Linked list of nest task update region specs - ,HANDLE_MOVE_DATA(N)%NTASKS_TO_RECV & !<-- MPI handles for update data ISent to nest N's tasks - ,MOVING_CHILD_UPDATE(N) & !<-- Composite H/V update data for tasks on moving child N - ) -! -!----------------------------------------------------------------------- -!*** When a parent needs to update data on some of its moving nests -!*** and any of those nest points lie between ITE/JTE on one parent -!*** task and ITS/JTS on an adjacent parent task then values from -!*** the parent tasks' halo regions must be used. However some of -!*** the variables that need updating are not computed in the halo -!*** regions. That means that prior to proceeding with moving nest -!*** updates the parent needs to do special halo exchanges for all -!*** those variables required for moving nest updates but for which -!*** halo exchanges were not performed during the normal integration. -!*** Of course these parent tasks' halo exchanges need to be done -!*** only once in a timestep in which any number of its nests move. -!----------------------------------------------------------------------- -! - IF(.NOT.EXCH_DONE)THEN -! - CALL PARENT_UPDATES_HALOS('H' & - ,MOVE_BUNDLE_H & - ,NUM_FIELDS_MOVE_3D_H & - ,NUM_FIELDS_MOVE_2D_H_R & - ,nflds_2di=NUM_FIELDS_MOVE_2D_H_I) -! - CALL PARENT_UPDATES_HALOS('V' & - ,MOVE_BUNDLE_V & - ,NUM_FIELDS_MOVE_3D_V & - ,NUM_FIELDS_MOVE_2D_V ) -! - EXCH_DONE=.TRUE. -! - ENDIF -! - parent_bookkeep_moving_tim=parent_bookkeep_moving_tim+(timef()-btim2) -! -!----------------------------------------------------------------------- -!*** While the index limits of each parent update region of each -!*** moving nest are identical for H and V points the routine that -!*** performs the updating will be called separately for H and V -!*** points. That is because of the different physical locations -!*** of H versus V points which must be accounted for when finding -!*** the parent's four surrounding points for bilinear interpolations. -!----------------------------------------------------------------------- -! - btim2=timef() -! - IF(N_UPDATE_CHILD_TASKS>0)THEN -! -!----------------------------------------------------------------------- -!*** First do the H point updates for moving nest N. -!----------------------------------------------------------------------- -! - NR=M_NEST_RATIO(N) !<-- Child's space ratio with uppermost parent. - NTIMESTEP_CHILD=(NTIMESTEP+1) & !<-- The nest's timestep in which it will recv - *TIME_RATIO_MY_CHILDREN(N_MOVING) ! parent shift data. -! - CALL PARENT_UPDATES_MOVING('H' & - ,N_UPDATE_CHILD_TASKS & - ,SPACE_RATIO & - ,TIME_RATIO_MY_CHILDREN(N_MOVING) & - ,NTIMESTEP_CHILD & - ,I_PARENT_SW(N_MOVING) & - ,J_PARENT_SW(N_MOVING) & - ,PT,PDTOP,PSGML1,SGML2,SG1,SG2 & - ,DSG2,PDSG1 & - ,FIS,PD & - ,T & - ,TRACERS(:,:,:,INDX_Q) & - ,TRACERS(:,:,:,INDX_CW) & - ,FTASKS_DOMAIN(MY_DOMAIN_ID) & !<-- # of forecast tasks on parent - ,NUM_CHILD_TASKS & !<-- # of child forecast tasks - ,child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA & !<-- Child task local ranks in p-c intracomm - ,CHILD_TASK_LIMITS & !<-- ITS,ITE,JTS,JTE for each child forecast task - ,HYPER_A & !<-- Underground extrapolation quantity - ,IMS,IME,JMS,JME & !<-- Subdomain memory limits for parent tasks - ,IDS,IDE,JDS,JDE & !<-- Full parent domain limits - ,LM & - ,NEST_FIS_ON_PARENT_BNDS(NRES)%LBND1 & - ,NEST_FIS_ON_PARENT_BNDS(NRES)%UBND1 & - ,NEST_FIS_ON_PARENT_BNDS(NRES)%LBND2 & - ,NEST_FIS_ON_PARENT_BNDS(NRES)%UBND2 & - ,NEST_FIS_ON_PARENT(NRES)%DATA & - ,COMM_TO_MY_CHILDREN(N) & - ,HANDLE_MOVE_DATA(N)%NTASKS_TO_RECV & - ,MOVE_BUNDLE_H & - ,NUM_FIELDS_MOVE_2D_H_I & - ,NUM_FIELDS_MOVE_2D_X_I & - ,NUM_FIELDS_MOVE_2D_H_R & - ,NUM_FIELDS_MOVE_2D_X_R & - ,NUM_FIELDS_MOVE_3D_H & - ,NUM_LEVELS_MOVE_3D_H & - ,NUM_FIELDS_MOVE_2D_V & - ,NUM_FIELDS_MOVE_3D_V & - ,NUM_LEVELS_MOVE_3D_V & - ,TASK_UPDATE_SPECS(N) & !<-- Linked list of nest task update region specs - ,MOVING_CHILD_UPDATE(N) & !<-- Composite H/V update data for nest task N - ) -! -!----------------------------------------------------------------------- -!*** Now the parent does the V point updates for moving nest N -!*** and then sends all H and V update data to that nest. -!----------------------------------------------------------------------- -! - NR=M_NEST_RATIO(N) -! - CALL PARENT_UPDATES_MOVING('V' & - ,N_UPDATE_CHILD_TASKS & - ,SPACE_RATIO & - ,TIME_RATIO_MY_CHILDREN(N_MOVING) & - ,NTIMESTEP_CHILD & - ,I_PARENT_SW(N_MOVING) & - ,J_PARENT_SW(N_MOVING) & - ,PT,PDTOP,PSGML1,SGML2,SG1,SG2 & - ,DSG2,PDSG1 & - ,FIS,PD & - ,T & - ,TRACERS(:,:,:,INDX_Q) & - ,TRACERS(:,:,:,INDX_CW) & - ,FTASKS_DOMAIN(MY_DOMAIN_ID) & !<-- # of forecast tasks on parent - ,NUM_CHILD_TASKS & !<-- # of child forecast tasks - ,child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA & !<-- Child task local ranks in p-c intracomm - ,CHILD_TASK_LIMITS & !<-- ITS,ITE,JTS,JTE for each child forecast task - ,HYPER_A & !<-- Underground extrapolation quantity - ,IMS,IME,JMS,JME & !<-- Subdomain memory limits for parent tasks - ,IDS,IDE,JDS,JDE & !<-- Full parent domain limits - ,LM & - ,NEST_FIS_ON_PARENT_BNDS(NRES)%LBND1 & - ,NEST_FIS_ON_PARENT_BNDS(NRES)%UBND1 & - ,NEST_FIS_ON_PARENT_BNDS(NRES)%LBND2 & - ,NEST_FIS_ON_PARENT_BNDS(NRES)%UBND2 & - ,NEST_FIS_V_ON_PARENT(NRES)%DATA & - ,COMM_TO_MY_CHILDREN(N) & - ,HANDLE_MOVE_DATA(N)%NTASKS_TO_RECV & - ,MOVE_BUNDLE_V & - ,NUM_FIELDS_MOVE_2D_H_I & - ,NUM_FIELDS_MOVE_2D_X_I & - ,NUM_FIELDS_MOVE_2D_H_R & - ,NUM_FIELDS_MOVE_2D_X_R & - ,NUM_FIELDS_MOVE_3D_H & - ,NUM_LEVELS_MOVE_3D_H & - ,NUM_FIELDS_MOVE_2D_V & - ,NUM_FIELDS_MOVE_3D_V & - ,NUM_LEVELS_MOVE_3D_V & - ,TASK_UPDATE_SPECS(N) & !<-- Linked list of nest task update region specs - ,MOVING_CHILD_UPDATE(N) & !<-- Composite H/V update data for nest task N - ) - ENDIF -! - parent_update_moving_tim=parent_update_moving_tim & - +(timef()-btim2) -! -!----------------------------------------------------------------------- -!*** If the child has executed its final shift before stopping due to -!*** its having reached the specified latitude limit then the parent -!*** sets its own flag to stop incorporating 2-way data from this -!*** child. -!----------------------------------------------------------------------- -! - IF(SHIFT_INFO_CHILDREN(4,N)==-22222)THEN !<-- Child motion has stopped so skip 2-way updates. - IF(NUM_2WAY_CHILDREN>0)THEN - SKIP_2WAY_UPDATE(N_MOVING)=.TRUE. - ENDIF -! - IF(I_AM_LEAD_FCST_TASK)THEN - WRITE(0,70110)N -70110 FORMAT(' Parent knows its moving child #',I2,' is now frozen.') - ENDIF - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF child_moves -! -!----------------------------------------------------------------------- -! - ENDDO child_loop_2 -! -!----------------------------------------------------------------------- -! - ENDIF moving_children -! - btim2=timef() -! -!----------------------------------------------------------------------- -!*** The values of the moving children's next move timesteps need -!*** to be updated in the Solver's internal state so they can be -!*** written to the restart file. Dummy values are set for static -!*** children. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert the Children's Next Move Timesteps into Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state =EXP_STATE & !<-- The parent-child coupler export state - ,name ='NEXT_TIMESTEP_CHILD_MOVES' & !<-- Name of the attribute to insert - ,itemCount=NUM_DOMAINS_MAX & !<-- # of words in array - ,valueList=NTIMESTEP_CHILD_MOVES & !<-- The next timestep the moving children move - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Insert clocktimes into the coupler's export state that are related -!*** to this phase. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert Clocktime for Comp in Phase2 into Cpl Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The parent-child coupler export state - ,name ='Cpl2_Comp_Time' & !<-- Name of the attribute to insert - ,value=cpl2_comp_tim & !<-- Phase 2 Compute time - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert Clocktime for Wait in Phase2 into Cpl Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The parent-child coupler export state - ,name ='Cpl2_Wait_Time' & !<-- Name of the attribute to insert - ,value=cpl2_wait_tim & !<-- Phase 2 Wait time - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert Clocktime for Send in Phase2 into Cpl Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The parent-child coupler export state - ,name ='Cpl2_Send_Time' & !<-- Name of the attribute to insert - ,value=cpl2_send_tim & !<-- Phase 2 Send time - ,rc =RC) -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The parent-child coupler export state - ,name ='parent_bookkeep_moving_tim' & !<-- Name of the attribute to insert - ,value=parent_bookkeep_moving_tim & !<-- moving nest bookeeping time - ,rc =RC) -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The parent-child coupler export state - ,name ='parent_update_moving_tim' & !<-- Name of the attribute to insert - ,value=parent_update_moving_tim & !<-- moving nest update time - ,rc =RC) -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The parent-child coupler export state - ,name ='t0_recv_move_tim' & !<-- Name of the attribute to insert - ,value=t0_recv_move_tim & !<-- task 0 time to process receive of move flag - ,rc =RC) -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The parent-child coupler export state - ,name ='read_moving_child_topo_tim' & !<-- Name of the attribute to insert - ,value=read_moving_child_topo_tim & !<-- task 0 time to process receive of move flag - ,rc =RC) -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The parent-child coupler export state - ,name ='barrier_move_tim' & !<-- Name of the attribute to insert - ,value=barrier_move_tim & !<-- task 0 time to process receive of move flag - ,rc =RC) -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The parent-child coupler export state - ,name ='pscd_tim' & !<-- Name of the attribute to insert - ,value=pscd_tim & !<-- task 0 time to process receive of move flag - ,rc =RC) -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The parent-child coupler export state - ,name ='pscd1_tim' & !<-- Name of the attribute to insert - ,value=pscd1_tim & !<-- task 0 time to process receive of move flag - ,rc =RC) -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The parent-child coupler export state - ,name ='pscd2_tim' & !<-- Name of the attribute to insert - ,value=pscd2_tim & !<-- task 0 time to process receive of move flag - ,rc =RC) -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The parent-child coupler export state - ,name ='pscd3_tim' & !<-- Name of the attribute to insert - ,value=pscd3_tim & !<-- task 0 time to process receive of move flag - ,rc =RC) -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The parent-child coupler export state - ,name ='pscd4_tim' & !<-- Name of the attribute to insert - ,value=pscd4_tim & !<-- task 0 time to process receive of move flag - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - pscd_tim=pscd_tim+(timef()-btim0) -! -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -! - SUBROUTINE RESET_WORK_PARENT(N_CHILD,N_RATIO & - ,TIME_FLAG,PARENT_MOVED) -! -!----------------------------------------------------------------------- -!*** A parent resets its working pointers/arrays that depend on a -!*** moving child's location to get ready to generate values on -!*** that child's boundary. This routine is not called for static -!*** nests since there is nothing to reset for them. -!*** This is an internal subroutine to PARENTS_SEND_CHILD_DATA. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: N_CHILD & !<-- Rank of nest in list of ALL children - ,N_RATIO !<-- Rank of space ratio value among the moving children -! - CHARACTER(len=*),INTENT(IN) :: TIME_FLAG !<-- Child to recv data from its present or future -! - LOGICAL(kind=KLOG),INTENT(IN) :: PARENT_MOVED !<-- Did this parent just shift its own domain? -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: IERR,INDX,N,NR,NT,NTAG,NUM_CHILD_TASKS -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** If this child wants to move then deallocate parent working -!*** arrays/pointers whose dimensions are functions of moving nests' -!*** positions. They will be reallocated with dimensions appropriate -!*** for the new positions. (For static nests these parent arrays -!*** are used over and over and are not deallocated/reallocated.) -!*** If this is the first time we have reached this point though -!*** then nothing has been allocated yet so skip the deallocation. -!*** Note however that if this parent can move then it must call -!*** this routine when it shifts since that will also mean that -!*** its children's positions have changed with respect to the -!*** parent's grid. -!----------------------------------------------------------------------- -! - INDX=1 - IF(TIME_FLAG=='Current')INDX=2 -! - CALL DEALLOC_WORK_PARENTS(N_CHILD,TIME_FLAG) -! -!----------------------------------------------------------------------- -!*** We now compute various indices and weights needed by the parents -!*** to compute boundary data for their children. It is here that -!*** location-dependent interpolation information is determined -!*** regarding the parent and nests. Parents need to call these -!*** routines only for children who have moved because this work was -!*** done once and for all for static nests in the coupler's Init -!*** step. -!----------------------------------------------------------------------- -! - CALL PREPARE_NEST_INTERP_FACTORS(N_CHILD,MY_DOMAIN_ID) -! - CALL POINT_INTERP_DATA_TO_MEMORY(N_CHILD,MY_DOMAIN_ID,TIME_FLAG) -! -!----------------------------------------------------------------------- -!*** The parent determines the new association between its tasks -!*** and those of its moving child's then sends the information -!*** to that child so the child will know exactly how to receive -!*** the new internal and boundary data from its parent when the -!*** child arrives at this point in time and executes its move. -!*** This only needs to be done when the nest has just moved, i.e., -!*** when the time flag has switched to 'Current'. When it goes -!*** back to 'Future' we do not need to send the information again -!*** since the nest has not moved again and thus the associations -!*** remain the same. -!----------------------------------------------------------------------- -! - IF(TIME_FLAG=='Current'.OR.PARENT_MOVED)THEN -! - CALL PARENT_SENDS_CHILD_DATA_LIMITS(N_CHILD,MY_DOMAIN_ID,TIME_FLAG) -! - ENDIF -! -!----------------------------------------------------------------------- -!*** The parent determines the child's boundary topography at the -!*** new location after the child moves. This is needed to maintain -!*** hydrostatic balance when parent data is interpolated to child -!*** boundaries where the terrain is different. -!----------------------------------------------------------------------- -! - NR=N_RATIO -! - CALL PARENT_COMPUTES_CHILD_TOPO(N_CHILD & - ,I_PARENT_SW(N_CHILD) & - ,J_PARENT_SW(N_CHILD) & - ,IM_CHILD(N_CHILD) & - ,JM_CHILD(N_CHILD) & - ,N_BLEND_H_CHILD(N_CHILD) & - ,NEST_FIS_ON_PARENT_BNDS(NR)%LBND1 & - ,NEST_FIS_ON_PARENT_BNDS(NR)%UBND1 & - ,NEST_FIS_ON_PARENT_BNDS(NR)%LBND2 & - ,NEST_FIS_ON_PARENT_BNDS(NR)%UBND2 & - ,NEST_FIS_ON_PARENT(NR)%DATA & - ) -! -!----------------------------------------------------------------------- -! - END SUBROUTINE RESET_WORK_PARENT -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE COMPUTE_SEND_NEST_BC_DATA(N_CHILD,TIME_FLAG) -! -!----------------------------------------------------------------------- -!*** A parent generates and sends boundary data to a child. -!*** This is an internal subroutine to PARENTS_SEND_CHILD_DATA. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: N_CHILD !<-- Compute/send this child's boundary conditions -! - CHARACTER(len=*),INTENT(IN) :: TIME_FLAG !<-- Child to recv data from its present or future -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: CHILDTASK,H_OR_V_INT,I,ID_ADD,IERR,INDX2,J & - ,KOUNT_H,KOUNT_V & - ,LB1,LB2,LB_4D & - ,N,N4,NRANK,NT,NTAG & - ,NUM_CHILD_TASKS,NUM_DIMS,NUM_LEVS,NV & - ,UB1,UB2,UB_4D -! - INTEGER(kind=KINT) :: ISTAT -! - INTEGER(kind=KINT),DIMENSION(MPI_STATUS_SIZE) :: JSTAT -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME) :: PD_V -! - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ARRAY_R2D -! - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: ARRAY_R3D & - ,VBL_ARRAY -! - REAL(kind=KFPT),DIMENSION(:,:,:,:),POINTER :: ARRAY_R4D -! - CHARACTER(len=99) :: FIELD_NAME -! - TYPE(ESMF_Field) :: HOLD_FIELD -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - N=N_CHILD !<-- The Nth child of this parent. -! -!----------------------------------------------------------------------- -!*** Select the appropriate part of the working array depending on -!*** whether we are now concerned with children's boundaries for -!*** their current time or from their future. -!----------------------------------------------------------------------- -! - IF(TIME_FLAG=='Future')THEN - INDX2=1 - ELSEIF(TIME_FLAG=='Current')THEN - INDX2=2 - ENDIF -! - KOUNT_H=0 - KOUNT_V=0 -! -!----------------------------------------------------------------------- -!*** Before parents can generate new boundary data for their children -!*** we must check to be sure the previous set of ISend's from the -!*** parent tasks to the children's boundary tasks have completed. -!----------------------------------------------------------------------- -! - btim=timef() -! -!------------- -!*** South H -!------------- -! - IF(NUM_TASKS_SEND_H_S(N)>0)THEN !<-- Parent task has Sbndry H data to send to child tasks? - DO NT=1,NUM_TASKS_SEND_H_S(N) - CALL MPI_WAIT(HANDLE_H_SOUTH(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend from parent task to child N's task NT - ,JSTAT & !<-- MPI status - ,IERR ) - ENDDO - ENDIF -! -!------------- -!*** South V -!------------- -! - IF(NUM_TASKS_SEND_V_S(N)>0)THEN !<-- Parent task has Sbndry V data to send to child tasks? - DO NT=1,NUM_TASKS_SEND_V_S(N) - CALL MPI_WAIT(HANDLE_V_SOUTH(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend from parent task to child N's task NT - ,JSTAT & !<-- MPI status - ,IERR ) - ENDDO - ENDIF -! -!------------- -!*** North H -!------------- -! - IF(NUM_TASKS_SEND_H_N(N)>0)THEN !<-- Parent task has Nbndry H data to send to child tasks? - DO NT=1,NUM_TASKS_SEND_H_N(N) - CALL MPI_WAIT(HANDLE_H_NORTH(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend from parent task to child N's task NT - ,JSTAT & !<-- MPI status - ,IERR ) - ENDDO - ENDIF -! -!------------- -!*** North V -!------------- -! - IF(NUM_TASKS_SEND_V_N(N)>0)THEN !<-- Parent task has Nbndry V data to send to child tasks? - DO NT=1,NUM_TASKS_SEND_V_N(N) - CALL MPI_WAIT(HANDLE_V_NORTH(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend from parent task to child N's task NT - ,JSTAT & !<-- MPI status - ,IERR ) - ENDDO - ENDIF -! -!------------ -!*** West H -!------------ -! - IF(NUM_TASKS_SEND_H_W(N)>0)THEN !<-- Parent task has Wbndry H data to send to child tasks? - DO NT=1,NUM_TASKS_SEND_H_W(N) - CALL MPI_WAIT(HANDLE_H_WEST(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend from parent task to child N's task NT - ,JSTAT & !<-- MPI status - ,IERR ) - ENDDO - ENDIF -! -!------------ -!*** West V -!------------ -! - IF(NUM_TASKS_SEND_V_W(N)>0)THEN !<-- Parent task has Wbndry V data to send to child tasks? - DO NT=1,NUM_TASKS_SEND_V_W(N) - CALL MPI_WAIT(HANDLE_V_WEST(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend from parent task to child N's task NT - ,JSTAT & !<-- MPI status - ,IERR ) - ENDDO - ENDIF -! -!------------ -!*** East H -!------------ -! - IF(NUM_TASKS_SEND_H_E(N)>0)THEN !<-- Parent task has Ebndry H data to send to child tasks? - DO NT=1,NUM_TASKS_SEND_H_E(N) - CALL MPI_WAIT(HANDLE_H_EAST(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend from parent task to child N's task NT - ,JSTAT & !<-- MPI status - ,IERR ) - ENDDO - ENDIF -! -!------------ -!*** East V -!------------ -! - IF(NUM_TASKS_SEND_V_E(N)>0)THEN !<-- Parent task has Ebndry V data to send to child tasks? - DO NT=1,NUM_TASKS_SEND_V_E(N) - CALL MPI_WAIT(HANDLE_V_EAST(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend from parent task to child N's task NT - ,JSTAT & !<-- MPI status - ,IERR ) - ENDDO - ENDIF -! - cpl2_wait_tim=cpl2_wait_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** The parents can now compute the new surface pressure on the -!*** nests' boundary points (overwriting the previous values). -!*** This must be done for both H points and V points. Only the -!*** H point pressure is actually sent to the nest boundaries. -!*** The V point pressures are only used for proper vertical -!*** interpolation of V point boundary variables. -!----------------------------------------------------------------------- -! - NUM_CHILD_TASKS=FTASKS_DOMAIN(MY_CHILDREN_ID(N)) -! -!-------------------- -!*** PD on H points -!-------------------- -! - btim=timef() - CALL PARENT_UPDATE_CHILD_PSFC(FIS,PD,T,Q & !<-- Native parent values - ,PT,PDTOP & !<-- Domain PT and PDTOP - ,SG1,SG2 & !<-- General vertical structure (shared by all domains) - ,IMS,IME,JMS,JME & !<-- Parent task subdomain lateral memory dimensions - ,LM & !<-- # of model layers -! - ,NUM_CHILD_TASKS & !<-- # of fcst tasks on child N - ,CTASK_LIMITS(MY_DOMAIN_ID)%CHILDREN(N)%DATA & !<-- Integration limits on each task of child N -! - ,FIS_CHILD_SOUTH(N)%TASKS & !<-- Sfc geopotential on Sbndry points on child tasks - ,FIS_CHILD_NORTH(N)%TASKS & !<-- Sfc geopotential on Nbndry points on child tasks - ,FIS_CHILD_WEST(N)%TASKS & !<-- Sfc geopotential on Wbndry points on child tasks - ,FIS_CHILD_EAST(N)%TASKS & !<-- Sfc geopotential on Ebndry points on child tasks -! - ,NUM_TASKS_SEND_H_S(N) & !<-- # of child tasks with south boundary segments - ,NUM_TASKS_SEND_H_N(N) & !<-- # of child tasks with north boundary segments - ,NUM_TASKS_SEND_H_W(N) & !<-- # of child tasks with west boundary segments - ,NUM_TASKS_SEND_H_E(N) & !<-- # of child tasks with east boundary segments -! - ,PARENT_4_INDICES_H(N)%I_INDX_SBND & !<-- Parent I's west and east of each child Sbndry point - ,PARENT_4_INDICES_H(N)%I_INDX_NBND & !<-- Parent I's west and east of each child Nbndry point - ,PARENT_4_INDICES_H(N)%I_INDX_WBND & !<-- Parent I's west and east of each child Wbndry point - ,PARENT_4_INDICES_H(N)%I_INDX_EBND & !<-- Parent I's west and east of each child Ebndry point - ,PARENT_4_INDICES_H(N)%J_INDX_SBND & !<-- Parent J's south and north of each child Sbndry point - ,PARENT_4_INDICES_H(N)%J_INDX_NBND & !<-- Parent J's south and north of each child Nbndry point - ,PARENT_4_INDICES_H(N)%J_INDX_WBND & !<-- Parent J's south and north of each child Wbndry point - ,PARENT_4_INDICES_H(N)%J_INDX_EBND & !<-- Parent J's south and north of each child Ebndry point -! - ,CHILDTASK_H_SAVE(N)%I_LO_SOUTH & !<-- Starting I on each south boundary child task - ,CHILDTASK_H_SAVE(N)%I_HI_SOUTH & !<-- Ending I on each south boundary child task - ,CHILDTASK_H_SAVE(N)%I_HI_SOUTH_TRANSFER & !<-- Ending I on each south boundary child task - ,CHILDTASK_H_SAVE(N)%I_LO_NORTH & !<-- Starting I on each north boundary child task - ,CHILDTASK_H_SAVE(N)%I_HI_NORTH & !<-- Ending I on each north boundary child task - ,CHILDTASK_H_SAVE(N)%I_HI_NORTH_TRANSFER & !<-- Ending I on each north boundary child task - ,CHILDTASK_H_SAVE(N)%J_LO_WEST & !<-- Starting J on each west boundary child task - ,CHILDTASK_H_SAVE(N)%J_HI_WEST & !<-- Ending J on each west boundary child task - ,CHILDTASK_H_SAVE(N)%J_HI_WEST_TRANSFER & !<-- Ending J on each west boundary child task - ,CHILDTASK_H_SAVE(N)%J_LO_EAST & !<-- Starting J on each east boundary child task - ,CHILDTASK_H_SAVE(N)%J_HI_EAST & !<-- Ending J on each east boundary child task - ,CHILDTASK_H_SAVE(N)%J_HI_EAST_TRANSFER & !<-- Ending J on each east boundary child task -! - ,PARENT_4_WEIGHTS_H(N)%WEIGHTS_SBND & !<-- Bilinear interpolation wgts of the four parent - ,PARENT_4_WEIGHTS_H(N)%WEIGHTS_NBND & ! points surrounding each child bndry point - ,PARENT_4_WEIGHTS_H(N)%WEIGHTS_WBND & ! on each side of the child boundary. - ,PARENT_4_WEIGHTS_H(N)%WEIGHTS_EBND & ! -! - ,N_BLEND_H_CHILD(N) & !<-- Width of boundary blending region for mass points - ,IM_CHILD(N) & !<-- East-west points on child domain - ,JM_CHILD(N) & !<-- North-south points on child domain -! ^ -! | -! Input -! -------------- -! Output -! | -! v - ,CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS & !<-- 1-D H-pt Sbndry datastring to be sent by parent to child - ,CHILD_BOUND_H_NORTH(N,INDX2)%TASKS & !<-- 1-D H-pt Nbndry datastring to be sent by parent to child - ,CHILD_BOUND_H_WEST(N,INDX2)%TASKS & !<-- 1-D H-pt Wbndry datastring to be sent by parent to child - ,CHILD_BOUND_H_EAST(N,INDX2)%TASKS & !<-- 1-D H-pt Ebndry datastring to be sent by parent to child -! - ,PD_B_SOUTH(N)%TASKS & !<-- Updated sigma domain pressure (Pa) on nest bndry points - ,PD_B_NORTH(N)%TASKS & ! for all four sides of nest N's boundary. - ,PD_B_WEST(N)%TASKS & ! - ,PD_B_EAST(N)%TASKS ) !<-- -! -!----------------------------------------------------------------------- -! -!-------------------- -!*** PD on V points -!-------------------- -! - CALL PRESSURE_ON_NEST_BNDRY_V(PD & !<-- Sigma domain pressure (Pa) on parent mass points - ,IMS,IME,JMS,JME & !<-- Memory dimensions of PD -! - ,PD_B_SOUTH(N)%TASKS & !<-- Sigma domain pressure (Pa) on nest Sbndry mass points - ,PD_B_NORTH(N)%TASKS & !<-- Sigma domain pressure (Pa) on nest Nbndry mass points - ,PD_B_WEST (N)%TASKS & !<-- Sigma domain pressure (Pa) on nest Wbndry mass points - ,PD_B_EAST (N)%TASKS & !<-- Sigma domain pressure (Pa) on nest Ebndry mass points -! - ,NUM_TASKS_SEND_V_S(N) & !<-- # of child tasks with south boundary segments on V - ,NUM_TASKS_SEND_V_N(N) & !<-- # of child tasks with north boundary segments on V - ,NUM_TASKS_SEND_V_W(N) & !<-- # of child tasks with west boundary segments on V - ,NUM_TASKS_SEND_V_E(N) & !<-- # of child tasks with east boundary segments on V -! - ,CHILDTASK_V_SAVE(N)%I_LO_SOUTH & !<-- Starting I on each south V boundary child task - ,CHILDTASK_V_SAVE(N)%I_HI_SOUTH & !<-- Ending I on each south V boundary child task - ,CHILDTASK_V_SAVE(N)%I_LO_NORTH & !<-- Starting I on each north V boundary child task - ,CHILDTASK_V_SAVE(N)%I_HI_NORTH & !<-- Ending I on each north V boundary child task - ,CHILDTASK_V_SAVE(N)%J_LO_WEST & !<-- Starting J on each west V boundary child task - ,CHILDTASK_V_SAVE(N)%J_HI_WEST & !<-- Ending J on each west V boundary child task - ,CHILDTASK_V_SAVE(N)%J_LO_EAST & !<-- Starting J on each east V boundary child task - ,CHILDTASK_V_SAVE(N)%J_HI_EAST & !<-- Ending J on each east V boundary child task -! - ,CHILDTASK_H_SAVE(N)%I_LO_SOUTH & !<-- Starting I on each south H boundary child task - ,CHILDTASK_H_SAVE(N)%I_HI_SOUTH & !<-- Ending I on each south H boundary child task - ,CHILDTASK_H_SAVE(N)%I_LO_NORTH & !<-- Starting I on each north H boundary child task - ,CHILDTASK_H_SAVE(N)%I_HI_NORTH & !<-- Ending I on each north H boundary child task - ,CHILDTASK_H_SAVE(N)%J_LO_WEST & !<-- Starting J on each west H boundary child task - ,CHILDTASK_H_SAVE(N)%J_HI_WEST & !<-- Ending J on each west H boundary child task - ,CHILDTASK_H_SAVE(N)%J_LO_EAST & !<-- Starting J on each east H boundary child task - ,CHILDTASK_H_SAVE(N)%J_HI_EAST & !<-- Ending J on each east H boundary child task -! - ,N_BLEND_H_CHILD(N) & !<-- H rows in nests' boundary regions - ,N_BLEND_V_CHILD(N) & !<-- V rows in nests' boundary regions - ,IM_CHILD(N) & !<-- East-west points on child domain - ,JM_CHILD(N) & !<-- North-south points on child domain -! - ,INC_FIX(N) & !<-- Increment used to select nest tasks for averaging H to V -! ^ -! | -! Input -! -------------- -! Output -! | -! v - ,PD_V & !<-- Sigma domain pressure (Pa) on parent V points - ,PD_B_SOUTH_V(N)%TASKS & !<-- Sigma domain pressure (Pa) on nest Sbndry V points - ,PD_B_NORTH_V(N)%TASKS & !<-- Sigma domain pressure (Pa) on nest Nbndry V points - ,PD_B_WEST_V(N)%TASKS & !<-- Sigma domain pressure (Pa) on nest Wbndry V points - ,PD_B_EAST_V(N)%TASKS ) !<-- Sigma domain pressure (Pa) on nest Ebndry V points -! -!----------------------------------------------------------------------- -!*** Now loop through the Solver internal state variables that the -!*** user has specified for the nest boundary conditions. The 2-D -!*** PD array was already taken care of. For the remaining variables -!*** find the number of dimensions and see whether they are on H or -!*** V points. -!----------------------------------------------------------------------- -! - vars_bc: DO NV=1,NVARS_NESTBC !<-- Loop over all nest BC variables updated by the parent. -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Field from the Bundle of Nest BC Vars" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=BUNDLE_NESTBC & !<-- Bundle holding the arrays of nest BC update variables - ,fieldIndex =NV & !<-- Index of the Field in the Bundle - ,field =HOLD_FIELD & !<-- Field NV in the Bundle - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract the Name of this Nest BC Variable" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field NV in the Bundle - ,name =FIELD_NAME & !<-- This Field's name - ,dimCount=NUM_DIMS & !<-- Is this Field 2-D or 3-D? - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Is this an H-pt or a V-pt Variable?" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(field=HOLD_FIELD & !<-- Get Attribute from this Field - ,name ='H_OR_V_INT' & !<-- Name of the attribute to extract - ,value=H_OR_V_INT & !<-- Value of the Attribute - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(TRIM(FIELD_NAME)=='PD-nestbc')THEN -! - CYCLE vars_bc !<-- PD was already taken care of. -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Get the desired boundary variable array from the Field and -!*** see whether it is on H or V points. -!----------------------------------------------------------------------- -! -!--------- -!*** 2-D -!--------- -! - IF(NUM_DIMS==2)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract the Nest BC Real 2-D Array from the Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer - ,localDe =0 & - ,farrayPtr=ARRAY_R2D & !<-- Use this 2-D pointer to the variable. - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NUM_LEVS=1 !<-- # of vertical levels for this variable. - LB_4D=1 - UB_4D=1 -! - LB1=LBOUND(ARRAY_R2D,1) - UB1=UBOUND(ARRAY_R2D,1) - LB2=LBOUND(ARRAY_R2D,2) - UB2=UBOUND(ARRAY_R2D,2) - ALLOCATE(VBL_ARRAY(LB1:UB1,LB2:UB2,1),stat=ISTAT) !<-- Use only 3-D arrays in PARENT_UPDATE_CHILD_BNDRY below. - IF(ISTAT/=0)THEN - WRITE(0,20001)ISTAT -20001 FORMAT(' Failed to allocate VBL_ARRAY for 2-D variable stat=',i4) - WRITE(0,*)' Aborting!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - DO J=LB2,UB2 - DO I=LB1,UB1 - VBL_ARRAY(I,J,1)=ARRAY_R2D(I,J) !<-- Fill the 3-D array with the 2-D boundary variable. - ENDDO - ENDDO -! -!--------- -!*** 3-D -!--------- -! - ELSEIF(NUM_DIMS==3)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract the Nest BC Real 3-D Array from the Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer - ,localDe =0 & - ,farrayPtr=VBL_ARRAY & !<-- Use this 3-D pointer to the variable. - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NUM_LEVS=SIZE(VBL_ARRAY,3) !<-- # of vertical levels for this 3-D boundary variable. - LB_4D=1 - UB_4D=1 -! -!--------- -!*** 4-D -!--------- -! - ELSEIF(NUM_DIMS==4)THEN !<-- Possible only for H-pt boundary variables -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract the Nest BC Real 4-D Array from the Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer - ,localDe =0 & - ,farrayPtr=ARRAY_R4D & !<-- Use this 4-D pointer to the variable. - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - LB_4D=LBOUND(ARRAY_R4D,4) - UB_4D=UBOUND(ARRAY_R4D,4) -! - ENDIF -! -!----------------------------------------------------------------------- -!*** The parent computes the new values of the specified H-pt -!*** variables in the columns above the nest boundary points. -!----------------------------------------------------------------------- -! - IF(H_OR_V_INT==1)THEN !<-- Value of 1 implies an H-point variable -! - KOUNT_H=KOUNT_H+1 !<-- Count the H-pt boundary variables (excluding PD) -! - loop_4d: DO N4=LB_4D,UB_4D !<-- Loop through 3-D sub-variables of 4-D variables, if any. -! - IF(NUM_DIMS==4)THEN - VBL_ARRAY=>ARRAY_R4D(:,:,:,N4) !<-- Point at the current 3-D array in the 4-D variable. - NUM_LEVS=SIZE(VBL_ARRAY,3) !<-- # of vertical levels for this 3-D sub-variable. - ENDIF -! - CALL PARENT_UPDATE_CHILD_BNDRY(VBL_ARRAY & !<-- Parent variable to interpolate to nest boundary - ,TRIM(FIELD_NAME) & !<-- Name of the variable -! - ,PD,PT,PDTOP & !<-- Parent PD; domain PT and PDTOP - ,PSGML1,SGML2,SG1,SG2 & !<-- General vertical structure (shared by all domains) -! - ,PD_B_SOUTH(N)%TASKS & !<-- Sigma domain pressure (Pa) on nest Sbndry points - ,PD_B_NORTH(N)%TASKS & !<-- Sigma domain pressure (Pa) on nest Nbndry points - ,PD_B_WEST(N)%TASKS & !<-- Sigma domain pressure (Pa) on nest Wbndry points - ,PD_B_EAST(N)%TASKS & !<-- Sigma domain pressure (Pa) on nest Ebndry points -! - ,IMS,IME,JMS,JME & !<-- Parent task subdomain lateral memory dimensions - ,NUM_LEVS & !<-- # of model layers in the given H-pt boundary variable - ,0 & !<-- # of rows to ignore on north/east nest boundaries -! - ,NUM_TASKS_SEND_H_S(N) & !<-- # of child tasks with south boundary segments - ,NUM_TASKS_SEND_H_N(N) & !<-- # of child tasks with north boundary segments - ,NUM_TASKS_SEND_H_W(N) & !<-- # of child tasks with west boundary segments - ,NUM_TASKS_SEND_H_E(N) & !<-- # of child tasks with east boundary segments -! - ,PARENT_4_INDICES_H(N)%I_INDX_SBND & !<-- Parent I's west and east of each child S bndry point - ,PARENT_4_INDICES_H(N)%I_INDX_NBND & !<-- Parent I's west and east of each child N bndry point - ,PARENT_4_INDICES_H(N)%I_INDX_WBND & !<-- Parent I's west and east of each child W bndry point - ,PARENT_4_INDICES_H(N)%I_INDX_EBND & !<-- Parent I's west and east of each child E bndry point - ,PARENT_4_INDICES_H(N)%J_INDX_SBND & !<-- Parent J's south and north of each child S bndry point - ,PARENT_4_INDICES_H(N)%J_INDX_NBND & !<-- Parent J's south and north of each child N bndry point - ,PARENT_4_INDICES_H(N)%J_INDX_WBND & !<-- Parent J's south and north of each child W bndry point - ,PARENT_4_INDICES_H(N)%J_INDX_EBND & !<-- Parent J's south and north of each child E bndry point -! - ,CHILDTASK_H_SAVE(N)%I_LO_SOUTH & !<-- Starting I on each south boundary child task - ,CHILDTASK_H_SAVE(N)%I_HI_SOUTH & !<-- Ending I on each south boundary child task - ,CHILDTASK_H_SAVE(N)%I_HI_SOUTH_TRANSFER & !<-- Ending I for transfer to child on each Sbndry child task - ,CHILDTASK_H_SAVE(N)%I_LO_NORTH & !<-- Starting I on each north boundary child task - ,CHILDTASK_H_SAVE(N)%I_HI_NORTH & !<-- Ending I on each north boundary child task - ,CHILDTASK_H_SAVE(N)%I_HI_NORTH_TRANSFER & !<-- Ending I for transfer to child on each Nbndry child task - ,CHILDTASK_H_SAVE(N)%J_LO_WEST & !<-- Starting J on each west boundary child task - ,CHILDTASK_H_SAVE(N)%J_HI_WEST & !<-- Ending J on each west boundary child task - ,CHILDTASK_H_SAVE(N)%J_HI_WEST_TRANSFER & !<-- Ending J for transfer to child on each Wbndry child task - ,CHILDTASK_H_SAVE(N)%J_LO_EAST & !<-- Starting J on each east boundary child task - ,CHILDTASK_H_SAVE(N)%J_HI_EAST & !<-- Ending J on each east boundary child task - ,CHILDTASK_H_SAVE(N)%J_HI_EAST_TRANSFER & !<-- Ending J for transfer to child on each Ebndry child task -! - ,PARENT_4_WEIGHTS_H(N)%WEIGHTS_SBND & !<-- Bilinear interpolation wgts of the four parent - ,PARENT_4_WEIGHTS_H(N)%WEIGHTS_NBND & ! points surrounding each child bndry point. - ,PARENT_4_WEIGHTS_H(N)%WEIGHTS_WBND & ! - ,PARENT_4_WEIGHTS_H(N)%WEIGHTS_EBND & !<-- -! - ,N_BLEND_H_CHILD(N) & !<-- Width of boundary blending region - ,IM_CHILD(N) & !<-- East-west points on child domain - ,JM_CHILD(N) & !<-- North-south points on child domain -! ^ -! | -! Input -! -------------- -! Output -! | -! v - ,BND_VAR_H_SOUTH(KOUNT_H)%CHILD(N)%TASKS & !<-- - ,BND_VAR_H_NORTH(KOUNT_H)%CHILD(N)%TASKS & ! Updated H-point variable on the four sides - ,BND_VAR_H_WEST(KOUNT_H)%CHILD(N)%TASKS & ! of the nest domain boundary. - ,BND_VAR_H_EAST(KOUNT_H)%CHILD(N)%TASKS & !<-- - ) -! - ENDDO loop_4d -! -!----------------------------------------------------------------------- -!*** The parent computes the new values of the specified velocity -!*** variables in the columns above the nest boundary points. -!----------------------------------------------------------------------- -! -! - ELSEIF(H_OR_V_INT==2)THEN !<-- Value of 2 implies a V-point variable -! - KOUNT_V=KOUNT_V+1 !<-- Count the V-pt boundary variables. -! - CALL PARENT_UPDATE_CHILD_BNDRY(VBL_ARRAY & !<-- Parent variable to interpolate to nest boundary - ,TRIM(FIELD_NAME) & !<-- Name of the variable -! - ,PD_V,PT,PDTOP & !<-- Parent PD on V; domain PT and PDTOP - ,PSGML1,SGML2,SG1,SG2 & !<-- General vertical structure (shared by all domains) -! - ,PD_B_SOUTH_V(N)%TASKS & !<-- Sigma domain pressure (Pa) on nest Sbndry points - ,PD_B_NORTH_V(N)%TASKS & !<-- Sigma domain pressure (Pa) on nest Nbndry points - ,PD_B_WEST_V(N)%TASKS & !<-- Sigma domain pressure (Pa) on nest Wbndry points - ,PD_B_EAST_V(N)%TASKS & !<-- Sigma domain pressure (Pa) on nest Ebndry points -! - ,IMS,IME,JMS,JME & !<-- Parent task subdomain lateral memory dimensions - ,NUM_LEVS & !<-- # of model layers - ,1 & !<-- # of rows to ignore on north/east nest boundaries -! - ,NUM_TASKS_SEND_V_S(N) & !<-- # of child tasks with south boundary segments - ,NUM_TASKS_SEND_V_N(N) & !<-- # of child tasks with north boundary segments - ,NUM_TASKS_SEND_V_W(N) & !<-- # of child tasks with west boundary segments - ,NUM_TASKS_SEND_V_E(N) & !<-- # of child tasks with east boundary segments -! - ,PARENT_4_INDICES_V(N)%I_INDX_SBND & !<-- Parent I's west and east of each child S bndry point - ,PARENT_4_INDICES_V(N)%I_INDX_NBND & !<-- Parent I's west and east of each child N bndry point - ,PARENT_4_INDICES_V(N)%I_INDX_WBND & !<-- Parent I's west and east of each child W bndry point - ,PARENT_4_INDICES_V(N)%I_INDX_EBND & !<-- Parent I's west and east of each child E bndry point - ,PARENT_4_INDICES_V(N)%J_INDX_SBND & !<-- Parent J's south and north of each child S bndry point - ,PARENT_4_INDICES_V(N)%J_INDX_NBND & !<-- Parent J's south and north of each child N bndry point - ,PARENT_4_INDICES_V(N)%J_INDX_WBND & !<-- Parent J's south and north of each child W bndry point - ,PARENT_4_INDICES_V(N)%J_INDX_EBND & !<-- Parent J's south and north of each child E bndry point -! - ,CHILDTASK_V_SAVE(N)%I_LO_SOUTH & !<-- Starting I on each south boundary child task - ,CHILDTASK_V_SAVE(N)%I_HI_SOUTH & !<-- Ending I on each south boundary child task - ,CHILDTASK_V_SAVE(N)%I_HI_SOUTH_TRANSFER & !<-- Not relevant for V points - ,CHILDTASK_V_SAVE(N)%I_LO_NORTH & !<-- Starting I on each north boundary child task - ,CHILDTASK_V_SAVE(N)%I_HI_NORTH & !<-- Ending I on each north boundary child task - ,CHILDTASK_V_SAVE(N)%I_HI_NORTH_TRANSFER & !<-- Not relevant for V points - ,CHILDTASK_V_SAVE(N)%J_LO_WEST & !<-- Starting J on each west boundary child task - ,CHILDTASK_V_SAVE(N)%J_HI_WEST & !<-- Ending J on each west boundary child task - ,CHILDTASK_V_SAVE(N)%J_HI_WEST_TRANSFER & !<-- Not relevant for V points - ,CHILDTASK_V_SAVE(N)%J_LO_EAST & !<-- Starting J on each east boundary child task - ,CHILDTASK_V_SAVE(N)%J_HI_EAST & !<-- Ending J on each east boundary child task - ,CHILDTASK_V_SAVE(N)%J_HI_EAST_TRANSFER & !<-- Not relevant for V points -! - ,PARENT_4_WEIGHTS_V(N)%WEIGHTS_SBND & !<-- Bilinear interpolation wgts of the four parent - ,PARENT_4_WEIGHTS_V(N)%WEIGHTS_NBND & ! points surrounding each child bndry point. - ,PARENT_4_WEIGHTS_V(N)%WEIGHTS_WBND & ! - ,PARENT_4_WEIGHTS_V(N)%WEIGHTS_EBND & !<-- -! - ,N_BLEND_V_CHILD(N) & !<-- Width of boundary blending region - ,IM_CHILD(N) & !<-- East-west points on child domain - ,JM_CHILD(N) & !<-- North-south points on child domain -! ^ -! | -! Input -! -------------- -! Output -! | -! v - ,BND_VAR_V_SOUTH(KOUNT_V)%CHILD(N)%TASKS & !<-- - ,BND_VAR_V_NORTH(KOUNT_V)%CHILD(N)%TASKS & ! Updated V-point variable on the four sides - ,BND_VAR_V_WEST(KOUNT_V)%CHILD(N)%TASKS & ! of the nest domain boundary. - ,BND_VAR_V_EAST(KOUNT_V)%CHILD(N)%TASKS & !<-- - ) -! - ENDIF -! - IF(NUM_DIMS==2.AND.ASSOCIATED(VBL_ARRAY))THEN - DEALLOCATE(VBL_ARRAY,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,20002)ISTAT -20002 FORMAT(' Failed to deallocate VBL_ARRAY stat=',i4) - WRITE(0,*)' Aborting!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO vars_bc -! - cpl2_comp_tim=cpl2_comp_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Parent tasks send data directly to those child tasks whose -!*** boundary points the parent tasks contain. -!----------------------------------------------------------------------- -! - IF(TIME_FLAG=='Current')THEN - NSTEP_CHILD_RECV(N)=(NTIMESTEP+1)*TIME_RATIO_MY_CHILDREN(N) !<-- Child "N" is waiting at this timestep to recv its data - ELSEIF(TIME_FLAG=='Future')THEN - NSTEP_CHILD_RECV(N)=NTIMESTEP*TIME_RATIO_MY_CHILDREN(N) !<-- Child "N" is waiting at this timestep to recv its data - ENDIF -! - ID_ADD=1000*MY_CHILDREN_ID(N) -! -!------------- -!*** South H -!------------- -! - NTAG=NSTEP_CHILD_RECV(N)+101+ID_ADD !<-- Add 101 and child's domain ID to obtain a unique South H tag -! - IF(NUM_TASKS_SEND_H_S(N)>0)THEN !<-- Parent task has Sbndry H data to send to child tasks? -! - DO NT=1,NUM_TASKS_SEND_H_S(N) !<-- Send to all appropriate child tasks - NRANK=CHILDTASK_BNDRY_H_RANKS(N)%SOUTH(NT,1) !<-- Child task count in its list of fcst tasks - CHILDTASK=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NRANK-1) !<-- Local rank of child task NT in p-c intracomm -! -! call date_and_time(values=values) -! write(0,221)n,nt,childtask,values(5),values(6),values(7),values(8) - 221 format(' Ready to send South_H to child #',i1,' task #',i1,' id #',i3.3,' at ',i2.2,':',i2.2,':',i2.2,'.',i3.3) -! -! write(0,22011)n,nt,childtask_bndry_h_ranks(n)%south(nt,1),childtask,ntag -! write(0,22012)nstep_child_recv(n),id_add,my_children_id(n) -22011 format(' ready to send South_H to child #',i2,' task #',i3,' count=',i3,' rank=',i3,' tag=',i5) -22012 format(' nstep_child_recv(n)=',i5,' id_add=',i5,' my_children_id(n)=',i2) - btim=timef() - CALL MPI_ISSEND(CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS(NT)%DATA & !<-- Child south boundary H data on child task NT - ,WORDS_BOUND_H_SOUTH(N)%TASKS(NT) & !<-- # of words in the data string - ,MPI_REAL & !<-- Datatype - ,CHILDTASK & !<-- Local rank of child to recv data - ,NTAG & !<-- MPI tag - ,COMM_TO_MY_CHILDREN(N) & !<-- MPI intracommunicator - ,HANDLE_H_SOUTH(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend to child N's task NT - ,IERR ) - cpl2_send_tim=cpl2_send_tim+(timef()-btim) -! write(0,22013)n,nt,childtask_bndry_h_ranks(n)%south(nt,1),nrank,childtask -! write(0,22014)words_bound_h_south(n)%tasks(nt),ntag,comm_to_my_children(n) -! write(0,22015)indx2,handle_h_south(n,indx2)%ntasks_to_recv(nt) -22013 format(' isent South_H to child #',i2,' task #',i3,' count=',i3,' nrank=',i3,' rank=',i3) -22014 format(' # of words=',i5,' ntag=',i5,' comm=',i12) -22015 format(' indx2=',i3,' handle_h_south(n,indx2)%ntasks_to_recv(nt)=',i12) -! -! call date_and_time(values=values) -! write(0,124)n,nt,childtask,values(5),values(6),values(7),values(8) - 124 format(' Sent South_H to child #',i1,' task #',i1,' id #',i3.3,' at ',i2.2,':',i2.2,':',i2.2,'.',i3.3) -! - ENDDO -! - ENDIF -! -!------------- -!*** South V -!------------- -! - NTAG=NSTEP_CHILD_RECV(N)+102+ID_ADD !<-- Add 102 and child's domain ID to obtain a unique South V tag -! - IF(NUM_TASKS_SEND_V_S(N)>0)THEN !<-- Parent task has Sbndry V data to send to child tasks? - DO NT=1,NUM_TASKS_SEND_V_S(N) !<-- Send to all appropriate child tasks - NRANK=CHILDTASK_BNDRY_V_RANKS(N)%SOUTH(NT,1) !<-- Child task count in its list of fcst tasks - CHILDTASK=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NRANK-1) !<-- Local rank of child task NT in p-c intracomm -! -! call date_and_time(values=values) -! write(0,125)n,nt,childtask,values(5),values(6),values(7),values(8) -! 125 format(' Ready to send South_V to child #',i1,' task #',i1,' id #',i3.3,' at ',i2.2,':',i2.2,':',i2.2,'.',i3.3) -! - btim=timef() - CALL MPI_ISSEND(CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS(NT)%DATA & !<-- Child south boundary V data on child task NT - ,WORDS_BOUND_V_SOUTH(N)%TASKS(NT) & !<-- # of words in the data string - ,MPI_REAL & !<-- Datatype - ,CHILDTASK & !<-- Local rank of child to recv data - ,NTAG & !<-- MPI tag - ,COMM_TO_MY_CHILDREN(N) & !<-- MPI communicator - ,HANDLE_V_SOUTH(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend to child N's task NT - ,IERR ) - cpl2_send_tim=cpl2_send_tim+(timef()-btim) -! -! call date_and_time(values=values) -! write(0,126)n,nt,childtask,values(5),values(6),values(7),values(8) - 126 format(' Sent South_V to child #',i1,' task #',i1,' id #',i3.3,' at ',i2.2,':',i2.2,':',i2.2,'.',i3.3) -! - ENDDO - ENDIF -! -!------------- -!*** North H -!------------- -! - NTAG=NSTEP_CHILD_RECV(N)+103+ID_ADD !<-- Add 103 and child's domain ID to obtain a unique North H tag -! - IF(NUM_TASKS_SEND_H_N(N)>0)THEN !<-- Parent task has Nbndry H data to send to child tasks? - DO NT=1,NUM_TASKS_SEND_H_N(N) !<-- Send to all appropriate child tasks - NRANK=CHILDTASK_BNDRY_H_RANKS(N)%NORTH(NT,1) !<-- Child task count in its list of fcst tasks - CHILDTASK=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NRANK-1) !<-- Local rank of child task NT in p-c intracomm -! - btim=timef() - CALL MPI_ISSEND(CHILD_BOUND_H_NORTH(N,INDX2)%TASKS(NT)%DATA & !<-- Child north boundary H data on child task NT - ,WORDS_BOUND_H_NORTH(N)%TASKS(NT) & !<-- # of words in the data string - ,MPI_REAL & !<-- Datatype - ,CHILDTASK & !<-- Local rank of child to recv data - ,NTAG & !<-- MPI tag - ,COMM_TO_MY_CHILDREN(N) & !<-- MPI communicator - ,HANDLE_H_NORTH(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend to child N's task NT - ,IERR ) - cpl2_send_tim=cpl2_send_tim+(timef()-btim) -! - ENDDO - ENDIF -! -!------------- -!*** North V -!------------- -! - NTAG=NSTEP_CHILD_RECV(N)+104+ID_ADD !<-- Add 104 and child's domain ID to obtain a unique North V tag -! - IF(NUM_TASKS_SEND_V_N(N)>0)THEN !<-- Parent task has Nbndry V data to send to child tasks? - DO NT=1,NUM_TASKS_SEND_V_N(N) !<-- Send to all appropriate child tasks - NRANK=CHILDTASK_BNDRY_V_RANKS(N)%NORTH(NT,1) !<-- Child task count in its list of fcst tasks - CHILDTASK=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NRANK-1) !<-- Local rank of child task NT in p-c intracomm -! - btim=timef() - CALL MPI_ISSEND(CHILD_BOUND_V_NORTH(N,INDX2)%TASKS(NT)%DATA & !<-- Child north boundary V data on child task NT - ,WORDS_BOUND_V_NORTH(N)%TASKS(NT) & !<-- # of words in the data string - ,MPI_REAL & !<-- Datatype - ,CHILDTASK & !<-- Local rank of child to recv data - ,NTAG & !<-- MPI tag - ,COMM_TO_MY_CHILDREN(N) & !<-- MPI communicator - ,HANDLE_V_NORTH(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend to child N's task NT - ,IERR ) - cpl2_send_tim=cpl2_send_tim+(timef()-btim) -! - ENDDO - ENDIF -! -!------------ -!*** West H -!------------ -! - NTAG=NSTEP_CHILD_RECV(N)+105+ID_ADD !<-- Add 105 and child's domain ID to obtain a unique West H tag -! - IF(NUM_TASKS_SEND_H_W(N)>0)THEN !<-- Parent task has Wbndry H data to send to child tasks? - DO NT=1,NUM_TASKS_SEND_H_W(N) !<-- Send to all appropriate child tasks - NRANK=CHILDTASK_BNDRY_H_RANKS(N)%WEST(NT,1) !<-- Child task count in its list of fcst tasks - CHILDTASK=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NRANK-1) !<-- Local rank of child task NT in p-c intracomm -! - btim=timef() - CALL MPI_ISSEND(CHILD_BOUND_H_WEST(N,INDX2)%TASKS(NT)%DATA & !<-- Child west boundary H data on child task NT - ,WORDS_BOUND_H_WEST(N)%TASKS(NT) & !<-- # of words in the data string - ,MPI_REAL & !<-- Datatype - ,CHILDTASK & !<-- Local rank of child to recv data - ,NTAG & !<-- MPI tag - ,COMM_TO_MY_CHILDREN(N) & !<-- MPI communicator - ,HANDLE_H_WEST(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend to child N's task NT - ,IERR ) - cpl2_send_tim=cpl2_send_tim+(timef()-btim) -! - ENDDO - ENDIF -! -!------------ -!*** West V -!------------ -! - NTAG=NSTEP_CHILD_RECV(N)+106+ID_ADD !<-- Add 106 and child's domain ID to obtain a unique West V tag -! - IF(NUM_TASKS_SEND_V_W(N)>0)THEN !<-- Parent task has Wbndry V data to send to child tasks? - DO NT=1,NUM_TASKS_SEND_V_W(N) !<-- Send to all appropriate child tasks - NRANK=CHILDTASK_BNDRY_V_RANKS(N)%WEST(NT,1) !<-- Child task count in its list of fcst tasks - CHILDTASK=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NRANK-1) !<-- Local rank of child task NT in p-c intracomm -! - btim=timef() - CALL MPI_ISSEND(CHILD_BOUND_V_WEST(N,INDX2)%TASKS(NT)%DATA & !<-- Child west boundary V data on child task NT - ,WORDS_BOUND_V_WEST(N)%TASKS(NT) & !<-- # of words in the data string - ,MPI_REAL & !<-- Datatype - ,CHILDTASK & !<-- Local rank of child to recv data - ,NTAG & !<-- MPI tag - ,COMM_TO_MY_CHILDREN(N) & !<-- MPI communicator - ,HANDLE_V_WEST(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend to child N's task NT - ,IERR ) - cpl2_send_tim=cpl2_send_tim+(timef()-btim) -! - ENDDO - ENDIF -! -!------------ -!*** East H -!------------ -! - NTAG=NSTEP_CHILD_RECV(N)+107+ID_ADD !<-- Add 107 and child's domain ID to obtain a unique East H tag -! - IF(NUM_TASKS_SEND_H_E(N)>0)THEN !<-- Parent task has Ebndry H data to send to child tasks? - DO NT=1,NUM_TASKS_SEND_H_E(N) !<-- Send to all appropriate child tasks - NRANK=CHILDTASK_BNDRY_H_RANKS(N)%EAST(NT,1) !<-- Child task count in its list of fcst tasks - CHILDTASK=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NRANK-1) !<-- Local rank of child task NT in p-c intracomm -! - btim=timef() - CALL MPI_ISSEND(CHILD_BOUND_H_EAST(N,INDX2)%TASKS(NT)%DATA & !<-- Child east boundary H data on child task NT - ,WORDS_BOUND_H_EAST(N)%TASKS(NT) & !<-- # of words in the data string - ,MPI_REAL & !<-- Datatype - ,CHILDTASK & !<-- Local rank of child to recv data - ,NTAG & !<-- MPI tag - ,COMM_TO_MY_CHILDREN(N) & !<-- MPI communicator - ,HANDLE_H_EAST(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend to child N's task NT - ,IERR ) - cpl2_send_tim=cpl2_send_tim+(timef()-btim) -! - ENDDO - ENDIF -! -!------------ -!*** East V -!------------ -! - NTAG=NSTEP_CHILD_RECV(N)+108+ID_ADD !<-- Add 108 and child's domain ID to obtain a unique East V tag -! - IF(NUM_TASKS_SEND_V_E(N)>0)THEN !<-- Parent task has Ebndry V data to send to child tasks? - DO NT=1,NUM_TASKS_SEND_V_E(N) !<-- Send to all appropriate child tasks - NRANK=CHILDTASK_BNDRY_V_RANKS(N)%EAST(NT,1) !<-- Child task count in its list of fcst tasks - CHILDTASK=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NRANK-1) !<-- Local rank of child task NT in p-c intracomm -! - btim=timef() - CALL MPI_ISSEND(CHILD_BOUND_V_EAST(N,INDX2)%TASKS(NT)%DATA & !<-- Child east boundary V data on child task NT - ,WORDS_BOUND_V_EAST(N)%TASKS(NT) & !<-- # of words in the data string - ,MPI_REAL & !<-- Datatype - ,CHILDTASK & !<-- Local rank of child to recv data - ,NTAG & !<-- MPI tag - ,COMM_TO_MY_CHILDREN(N) & !<-- MPI communicator - ,HANDLE_V_EAST(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend to child N's task NT - ,IERR ) - cpl2_send_tim=cpl2_send_tim+(timef()-btim) -! - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE COMPUTE_SEND_NEST_BC_DATA -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - END SUBROUTINE PARENTS_SEND_CHILD_DATA -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE PARENTS_RECV_CHILD_2WAY_DATA(CPL_COMP & - ,IMP_STATE & - ,EXP_STATE & - ,CLOCK & - ,RC_FINAL) -! -!----------------------------------------------------------------------- -!*** When 2-way nesting is being used the parents will receive -!*** internal update data from each of their children at the -!*** start of every parent timestep. -!*** Only parents execute this routine that is called as phase 3 -!*** of the Run step of the Parent-Child coupler in subroutine -!*** NMM_INTEGRATE. -! -!*** IMPORTANT: The indices of the parent H points and V points -!*** that are updated by the children are identical. -!*** A signficant generalization will be needed if -!*** that ever changes. -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_CplComp) :: CPL_COMP !<-- The Parent-Child Coupler Component -! - TYPE(ESMF_State) :: IMP_STATE & !<-- The Coupler's Import State - ,EXP_STATE !<-- The Coupler's Export State -! - TYPE(ESMF_Clock) :: CLOCK !<-- The NMM Clock for this parent domain -! - INTEGER,INTENT(OUT) :: RC_FINAL -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: ALLCLEAR_SIGNAL_TAG & - ,CHILDTASK,CHILDTASK_0,COMM_FCST_TASKS & - ,ID_CHILD,L1,L2,MY_DOMAIN_ID,MYPE_LOCAL & - ,N,N_ALL,NCHILD_TASKS,NL,NM,NMX,NPTS2 & - ,NPTS_UPDATE_HORIZ,NPTS_UPDATE_TOTAL & - ,NT,NTIMESTEP,NTIMESTEP_CHILD,NUM_DIMS,NV & - ,PARENT_TAG,SFC_TAG,TASK_ID,UPDATE_TAG -! - INTEGER(kind=KINT) :: I_2WAY_UPDATE_START,I_2WAY_UPDATE_END & - ,J_2WAY_UPDATE_START,J_2WAY_UPDATE_END -! - INTEGER(kind=KINT) :: I_PARENT_SW_X,J_PARENT_SW_X -! - INTEGER(kind=KINT) :: IERR,RC -! - INTEGER(kind=ESMF_KIND_I8) :: NTIMESTEP_ESMF -! - INTEGER,DIMENSION(MPI_STATUS_SIZE) :: JSTAT -! - INTEGER,DIMENSION(:,:),POINTER :: CHILD_TASK_LIMITS -! - REAL(kind=KFPT),DIMENSION(:),ALLOCATABLE :: VAR_2WAY -! - REAL(kind=KFPT),DIMENSION(:,:),ALLOCATABLE :: CHILD_SFC_ON_PARENT_GRID -! - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: VAR_PARENT_2D - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: VAR_PARENT_3D,VAR_3D - REAL(kind=KFPT),DIMENSION(:,:,:,:),POINTER :: VAR_PARENT_4D -! - LOGICAL(kind=KLOG),SAVE :: ALLCLEAR_SIGNAL=.TRUE. -! -! LOGICAL(kind=KLOG) :: INTEGRATE_TIMESTEP & -! ,READY_TO_RECV & - LOGICAL(kind=KLOG) :: READY_TO_RECV & - ,TWOWAY_SIGNAL_IS_PRESENT -! - LOGICAL(kind=KLOG) :: ALLCLEAR_FROM_MY_PARENT -! - CHARACTER(len=99) :: FIELD_NAME -! - TYPE(CHILD_UPDATE_LINK),POINTER :: PTR -! - TYPE(COMPOSITE),POINTER :: CC -! - TYPE(ESMF_Field) :: HOLD_FIELD -! - TYPE(ESMF_TypeKind_Flag) :: DATATYPE -! - integer(kind=kint),dimension(8) :: values - integer(kind=kint) :: mype_intra -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="PARENTS_RECV_CHILD_2WAY_DATA:Extract Fcst Task Intracom" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='Comm Fcst Tasks' & !<-- Name of the attribute to extract - ,value=COMM_FCST_TASKS & !<-- Current domain's intracomm for fcst tasks - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL MPI_COMM_RANK(COMM_FCST_TASKS,MYPE_LOCAL,IERR) !<-- Local task rank in this domain's fcst tasks -! -!----------------------- -!*** Current Domain ID -!----------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="PARENTS_RECV_CHILD_2WAY_DATA: Extract Current Domain ID" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='MY_DOMAIN_ID' & !<-- Name of the attribute to extract - ,value=MY_DOMAIN_ID & !<-- Current domain's ID - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Point to the correct part of the composite object which will -!*** align working variables with values associated with this domain. -!----------------------------------------------------------------------- -! - CALL POINT_TO_COMPOSITE(MY_DOMAIN_ID) -! - CC=>CPL_COMPOSITE(MY_DOMAIN_ID) !<-- Use dummy for shorter reference to composite -! -!----------------------------------------------------------------------- -!*** Get the current timestep. -!----------------------------------------------------------------------- -! - CALL ESMF_CLOCKGET(CLOCK =CLOCK & !<-- The ESMF Clock - ,advanceCount=NTIMESTEP_ESMF & !<-- The parent's current timestep (ESMF) - ,rc =rc) -! - NTIMESTEP=NTIMESTEP_ESMF !<-- The current parent timestep -! -!----------------------------------------------------------------------- -!*** At this point all the children's 2-way data is ready to be -!*** received. There is one more issue that must be considered. -!*** If any of the 2-way children has just shifted then the points -!*** updated by such children have just changed so bookkeeping must -!*** first be done so the parent knows the correct points to have -!*** updated. If this parent has just moved in this timestep then -!*** it must do the bookkeeping for all its children (currently a -!*** domain that moves can have only moving children and not static -!*** ones) to know which of its points will be updated. -!*** Below is a diagram illustrating the relationship between a child's -!*** move and the parent's need to execute 2-way bookkeeping after that -!*** child's move. In this instance the parent was informed by the -!*** child that the child would move at the start of the child's -!*** timestep 24 (parent timestep 8) therefore the parent must prepare -!*** and deposit move data at the end of its timestep 7. (The parent- -!*** child timestep ratio is 3.) The parent first recvs 2-way update -!*** data from the child's new position at the beginning of parent -!*** timestep 9. -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -! ---------------------------------- -! Parent-child timestep ratio is 3 -! ---------------------------------- -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -! Child shifts at start of its timestep 24 -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -! parent parent -! 7 <-- timestep --> 8 8 <-- timestep --> 9 -! boundary boundary -! -! | | -! parent sends | child recvs | -! post-shift | post-shift | -! internal data | internal data | -! to child | from parent | -! | | | | -! | | | | -! v | v | -! | ^ | -! | | | -! | | child child | -! | CHILD timestep timestep | -! | SHIFTS boundary boundary | -! | HERE | | | -! | | | | | -! 23<--|-->24 | 24<--|-->25 25<--|-->26 26<--|-->27 -! | v | | | -! | | | | -! | | -! | | -! | | -! ^ | ^ ^ | ^ -! | | | | | | -! | | | | | | -! child sends | parent recvs child sends | parent recvs -! pre-shift | pre-shift post-shift | post-shift -! 2-way data | 2-way data 2-way data | 2-way data -! to parent | from child to parent | from child -! | | -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** Below is an example of the parent domain shifting at the start -!*** of its timestep 8. However the parent receives and incorporates -!*** the 2-way data from its child in that timestep BEFORE the shift -!*** in position occurs therefore the child generates that data for -!*** the parent's pre-shift position. -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -! Parent shifts at start of its timestep 8 -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -! parent parent -! 7 <-- timestep --> 8 8 <-- timestep --> 9 -! boundary boundary -! -! | | -! | | -! | PARENT | -! | SHIFTS | -! | HERE | -! | | | -! | | | -! | | | -! | v | -! | child child | -! | timestep timestep | -! | boundary boundary | -! | | | | -! | | | | -! 23<--|-->24 24<--|-->25 25<--|-->26 26<--|-->27 -! | | | | -! | | | | -! | | -! | | -! | | -! ^ | ^ | -! | | | | -! | | | | -! child sends | parent recvs/ | -! pre-shift | incorporates | -! 2-way data | pre-shift | -! to parent | 2-way data | -! | from child | -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - two_way_children: DO N=1,NUM_2WAY_CHILDREN !<-- Loop through all of this domain's 2-way children -! -!----------------------------------------------------------------------- -! - N_ALL=RANK_2WAY_CHILD(N) !<-- Rank of 2-way child N among ALL children - NM=1 - call mpi_comm_rank(comm_to_my_children(n_all),mype_intra,ierr) -! - IF(STATIC_OR_MOVING(N_ALL)=='Moving')THEN !<-- If so, 2-way child N's domain is movable. -! - DO NMX=1,NUM_MOVING_CHILDREN - IF(N_ALL==RANK_MOVING_CHILD(NMX))THEN !<-- Which moving child is 2-way child N? - NM=NMX !<-- 2-way child N is moving child NM - EXIT - ENDIF - ENDDO -! - ENDIF -! - IF(.NOT.CALLED_PARENT_2WAY_BOOKKEEPING(N) & !<-- Initial parent bookkeeping for all 2-way nests - .OR. & - NTIMESTEP==NTIMESTEP_CHILD_MOVES(NM)+1 & !<-- 2-way child N moved one parent timestep ago - .OR. & - NTIMESTEP==NEXT_MOVE_TIMESTEP+1)THEN !<-- This parent moved in its preceding timestep -! -!----------------------------------------------------------------------- -!*** If this parent moved in its preceding timestep then it -!*** needs to modify the locations of its children accordingly. -!*** This will be done as a local computation because 2-way nesting -!*** is only optional. The children's locations as changed by -!*** the parent's shift will be permanently modified in -!*** PARENTS_SEND_CHILD_DATA where it is always required for -!*** generation of BC update data to send to the children. -!----------------------------------------------------------------------- -! - I_PARENT_SW_X=I_PARENT_SW(N_ALL) - J_PARENT_SW_X=J_PARENT_SW(N_ALL) -! -!----------------------------------------------------------------------- -!*** Parent tasks determine which if any of their points are updated -!*** by 2-way child N in that child's or the parent's new location. -!----------------------------------------------------------------------- -! - NTASKS_UPDATE_CHILD(N)=0 !<-- Initialize # of child tasks that will update - CHILD_TASK_LIMITS=>CTASK_LIMITS(MY_DOMAIN_ID)%CHILDREN(N_ALL)%DATA !<-- All subdomain limits on 2-way child N's domain - ID_CHILD=MY_CHILDREN_ID(N_ALL) !<-- Domain ID of 2-way child N -! - CALL PARENT_2WAY_BOOKKEEPING(PARENT_CHILD_SPACE_RATIO(N_ALL) & !<-- Ratio of parent grid increment to 2-way child N's - ,FTASKS_DOMAIN(ID_CHILD) & !<-- # of forecast tasks on 2-way child N's domain - ,CHILD_TASK_LIMITS & !<-- 2-way child N's subdomains' integration limits - ,IM_CHILD(N_ALL) & !<-- I extent of 2-way child N's domain - ,JM_CHILD(N_ALL) & !<-- J extent of 2-way child N's domain - ,I_PARENT_SW_X & !<-- Parent I of SW corner of child domain N_ALL - ,J_PARENT_SW_X & !<-- Parent J of SW corner of child domain N_ALL - ,N_BLEND_H_CHILD(N_ALL) & !<-- H-pt blending region width for 2-way child N - ,N_BLEND_V_CHILD(N_ALL) & !<-- V-pt blending region width for 2-way child N - ,N_STENCIL_H_CHILD(N) & !<-- Stencil width for averaging child h to parent H - ,N_STENCIL_V_CHILD(N) & !<-- Stencil width for averaging child v to parent V - ,N_STENCIL_SFC_H_CHILD(N) & !<-- Stencil width for averaging child fis,pd to parent H - ,N_STENCIL_SFC_V_CHILD(N) & !<-- Stencil width for averaging child fis,pd to parent V - ,ITS,ITE,JTS,JTE & !<-- Integration limits of this parent task subdomain -! - ,NTASKS_UPDATE_CHILD(N) & !<-- # of tasks on 2-way child N that update this parent task - ,CHILD_TASKS_2WAY_UPDATE(N) & !<-- Info for 2-way child N's update on this parent task - ) -! - CALLED_PARENT_2WAY_BOOKKEEPING(N)=.TRUE. -! - ENDIF -! -!----------------------------------------------------------------------- -!*** The parent receives update data from child N. -!----------------------------------------------------------------------- -! - IF(NTASKS_UPDATE_CHILD(N)<1)THEN - CYCLE !<-- Skip this child if none of its tasks are sending data. - ENDIF -! - NCHILD_TASKS=NTASKS_UPDATE_CHILD(N) !<-- # of child N's tasks that update the parent task. - NTIMESTEP_CHILD=NTIMESTEP*TIME_RATIO_MY_CHILDREN(N_ALL)-1 !<-- Child's timestep when it sent the data. -! - PTR=>CHILD_TASKS_2WAY_UPDATE(N) !<-- Point at child N's 2-way exchange specifications -! -!----------------------------------------------------------------------- -! - child_tasks: DO NT=1,NCHILD_TASKS !<-- Loop though child N's tasks that send 2-way data -! -!----------------------------------------------------------------------- -! - IF(NT>1)PTR=>PTR%NEXT_LINK !<-- Advance through this child's tasks that are sending data -! - NPTS_UPDATE_TOTAL=NLEV_2WAY*PTR%NUM_PTS_UPDATE_HZ !<-- Total # of values (Real) updated by child N's task NT. - ALLOCATE(VAR_2WAY(1:NPTS_UPDATE_TOTAL)) !<-- The recv buffer -! - TASK_ID=PTR%TASK_ID !<-- Local rank of task NT among child N's fcst tasks. - CHILDTASK=child_ranks(MY_DOMAIN_ID)%CHILDREN(N_ALL)%DATA(TASK_ID) !<-- Local rank of child task NT in P-C intracommunicator. - UPDATE_TAG=100*MY_CHILDREN_ID(N_ALL)+CHILDTASK -! - CALL MPI_RECV(VAR_2WAY & !<-- All update values from child N's task NT - ,NPTS_UPDATE_TOTAL & !<-- Receiving this many words - ,MPI_REAL & !<-- The data is real - ,CHILDTASK & !<-- Data was sent by this nest task - ,UPDATE_TAG & !<-- The MPI tag - ,COMM_TO_MY_CHILDREN(N_ALL) & !<-- Intracommunicator between current domain and child N_ALL - ,JSTAT & !<-- MPI status - ,IERR ) -! - NPTS_UPDATE_HORIZ=2*PTR%NUM_PTS_UPDATE_HZ !<-- # of sfc H,V points updated on parent by child N's task NT. - ALLOCATE(CHILD_SFC_ON_PARENT_GRID(1:NPTS_UPDATE_HORIZ,1:2)) !<-- The recv buffer - NPTS2=2*NPTS_UPDATE_HORIZ !<-- Total # of points in CHILD_SFC_ON_PARENT_GRID - ! (child N's FIS,PD interpolated to parent H and V) - SFC_TAG=100*MY_CHILDREN_ID(N_ALL)+CHILDTASK -! - CALL MPI_RECV(CHILD_SFC_ON_PARENT_GRID & !<-- Child PD,FIS interpolated to parent points - ,NPTS2 & !<-- Receiving this many words - ,MPI_REAL & !<-- The data is real - ,CHILDTASK & !<-- Data was sent by this nest task - ,SFC_TAG & !<-- The MPI tag - ,COMM_TO_MY_CHILDREN(N_ALL) & !<-- Intracommunicator between current domain and child N_ALL - ,JSTAT & !<-- MPI status - ,IERR ) -! -!----------------------------------------------------------------------- -!*** The parent does not incorporate data sent from the child if -!*** this is a parent timestep that immediately follows the writing -!*** of a restart file. This ensures bit-reproducible restarts. -!*** A child sends 2-way data to its parent at the end of parent -!*** timestep N and the parent receives that data early in timestep -!*** N+1. Two-way data is not in the restart files so in a restart -!*** the parent sees no 2-way data coming from its children in the -!*** first timestep. Therefore the parent must not use 2-way data -!*** from the children in any parent timestep that follows the -!*** writing of a restart file. -!----------------------------------------------------------------------- -! - no_restart: IF(MOD(NTIMESTEP,NTIMESTEPS_RESTART)/=0)THEN -! -!----------------------------------------------------------------------- -!*** The parent incorporates the 2-way data sent from child N's -!*** task NT. -!----------------------------------------------------------------------- -! - I_2WAY_UPDATE_START=PTR%IL(1) !<-- Starting parent I updated by child N's task NT - I_2WAY_UPDATE_END =PTR%IL(2) !<-- Ending parent I updated by child N's task NT - J_2WAY_UPDATE_START=PTR%JL(1) !<-- Starting parent J updated by child N's task NT - J_2WAY_UPDATE_END =PTR%JL(2) !<-- Ending parent J updated by child N's task NT -! - IF(.NOT.SKIP_2WAY_UPDATE(N_ALL))THEN !<-- IF test passes => nest N lies within latitude limits - CALL PARENT_2WAY_UPDATE(I_2WAY_UPDATE_START & !<-- # of tasks on 2-way child N that update this parent task - ,I_2WAY_UPDATE_END & !<-- Info for 2-way child N's update on this parent task - ,J_2WAY_UPDATE_START & !<-- Info for 2-way child N's update on this parent task - ,J_2WAY_UPDATE_END & !<-- Info for 2-way child N's update on this parent task - ,LM & !<-- # of model layers (all domains) - ,NPTS_UPDATE_HORIZ & !<-- # of update parent sfc H,V points - ,NPTS_UPDATE_TOTAL & !<-- Total # of words in 2-way 3D update data from child - ,NVARS_2WAY_UPDATE & !<-- # of variables updated in 2-way exchange - ,VAR_2WAY & !<-- String of all 2-way update data from child - ,CHILD_SFC_ON_PARENT_GRID & !<-- Child's FIS,PD interpolated to parent update points - ,CHILD_2WAY_WGT(N) & !<-- Weight (0-1) given to child 2-way data in the update - ,FIS & !<-- Parent's sfc geopotential - ,PD,PDTOP,PT & !<-- Parent's PD - ,SG1,SG2 & !<-- Interface 'sigma' values in pressure/hybrid regions - ,IMS,IME,JMS,JME & !<-- Memory limits of parent subdomains -! - ,BUNDLE_2WAY & !<-- Bundle holding pointers to the 2-way exchange variables - ) - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF no_restart -! -!----------------------------------------------------------------------- -! - DEALLOCATE(VAR_2WAY) - DEALLOCATE(CHILD_SFC_ON_PARENT_GRID) -! -!----------------------------------------------------------------------- -! - ENDDO child_tasks -! -!----------------------------------------------------------------------- -! - ENDDO two_way_children -! -!----------------------------------------------------------------------- -! - KOUNT_2WAY_CHILDREN=0 -! -!----------------------------------------------------------------------- -!*** The parent tasks have received all the 2-way exchange data from -!*** their children. The lead parent task now informs the lead -!*** child tasks that the children are now free to proceed to the -!*** beginning of the next parent timestep since the parent will now -!*** be able to integrate its next step and send back BC data to the -!*** children. Until the children are informed of this by their -!*** parents at the end of each parent timestep the children will -!*** simply continue to fall out of the integration loop in -!*** NMM_INTEGRATE. -!----------------------------------------------------------------------- -! - task0_b: IF(I_AM_LEAD_FCST_TASK)THEN -! -!----------------------------------------------------------------------- -! - DO N=1,NUM_CHILDREN -! - ALLCLEAR_SIGNAL_TAG=20000+1000*MY_CHILDREN_ID(N) & !<-- Use child's domain ID, timestep to create a unique tag - +10*NTIMESTEP*TIME_RATIO_MY_CHILDREN(N) - CHILDTASK_0=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(0) !<-- Local rank of child's lead task in p-c communicator -! - CALL MPI_WAIT(HANDLE_SEND_ALLCLEAR(N) & !<-- Handle for this ISend - ,JSTAT & !<-- MPI status object - ,IERR) -! - CALL MPI_ISSEND(ALLCLEAR_SIGNAL & !<-- Send signal to children they may now integrate - ,1 & !<-- # of words in signal - ,MPI_LOGICAL & !<-- The signal is type Logical (it is TRUE) - ,CHILDTASK_0 & !<-- The signal was sent by child N's fcst task 0. - ,ALLCLEAR_SIGNAL_TAG & !<-- Tag to free the children to integrate - ,COMM_TO_MY_CHILDREN(N) & !<-- MPI intracommunicator between parent and moving child N - ,HANDLE_SEND_ALLCLEAR(N) & - ,IERR) -! - ENDDO -! -!----------------------------------------------------------------------- -! - ENDIF task0_b -! -!----------------------------------------------------------------------- -! - CALL SET_DOMAIN_SPECS(ITS,ITE,JTS,JTE & - ,IMS,IME,JMS,JME & - ,IDS,IDE,JDS,JDE & - ,NHALO,NHALO & - ,MY_DOMAIN_ID & - ,MYPE_LOCAL & - ,MY_NEB & - ,COMM_FCST_TASKS & - ,NUM_PES_FCST & - ) -! -!----------------------------------------------------------------------- -!*** Now that parent variables have been modified by each of the -!*** children who have contributions the parent's halos need to -!*** be updated. Therefore extract each of the 2-way exchange -!*** variables from the Bundle and call the halo exchange. -!----------------------------------------------------------------------- -! - vars: DO NV=1,NVARS_2WAY_UPDATE !<-- Loop over all parent exchange variables updated by the child. -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Field from the Bundle of 2-way Vars" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=BUNDLE_2WAY & !<-- Bundle holding pointers to the 2-way exchange variables - ,fieldIndex =NV & !<-- Index of the Field in the Bundle - ,field =HOLD_FIELD & !<-- Field NV in the Bundle - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Info about this 2-way Variable" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field NV in the Bundle - ,dimCount=NUM_DIMS & !<-- Is this Field 2-D or 3-D? - ,typeKind=DATATYPE & !<-- Does the Field contain an integer or real array? - ,name =FIELD_NAME & !<-- This Field's name - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - IF(NUM_DIMS==2)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Real 2-way 2-D Array from the Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the exchange variable pointer - ,localDe =0 & - ,farrayPtr=VAR_PARENT_2D & !<-- Put the pointer here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL HALO_EXCH(VAR_PARENT_2D,LM,2,2) -! -!----------------------------------------------------------------------- -! - ELSEIF(NUM_DIMS>=3)THEN -! -!----------------------------------------------------------------------- -! - IF(NUM_DIMS==3)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Real 2-way 3-D Array from the Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the exchange variable pointer - ,localDe =0 & - ,farrayPtr=VAR_PARENT_3D & !<-- Put the pointer here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - L1=1 - L2=1 - VAR_3D=>VAR_PARENT_3D -! - ELSEIF(NUM_DIMS==4)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Real 2-way 4-D Array from the Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the exchange variable pointer - ,localDe =0 & - ,farrayPtr=VAR_PARENT_4D & !<-- Put the pointer here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - L1=LBOUND(VAR_PARENT_4D,4) - L2=UBOUND(VAR_PARENT_4D,4) -! - ENDIF -! - DO NL=L1,L2 -! - IF(NUM_DIMS==4)THEN - VAR_3D=>VAR_PARENT_4D(:,:,:,NL) !<-- Point at NL'th 3-D array in the 4-D variable. - ENDIF -! - CALL HALO_EXCH(VAR_3D,LM,2,2) -! - ENDDO -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO vars -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PARENTS_RECV_CHILD_2WAY_DATA -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE CHILDREN_SEND_PARENTS_2WAY_DATA(CPL_COMP & - ,IMP_STATE & - ,EXP_STATE & - ,CLOCK & - ,RC_FINAL) -! -!----------------------------------------------------------------------- -!*** Run the coupler step where children send their 2-way exchange -!*** data to their parents. This is phase 5 of the Parent-Child -!*** coupler Run step called in subroutine NMM_INTEGRATE and takes -!*** place at the end of a parent timestep after the parents execute -!*** their receiving and incorporation of 2-way exchanges from their -!*** children which occurred in phase 2 at the beginning of the parent -!*** timestep. Of course this routine is executed only if 2-way -!*** nesting is being used. -! -!*** IMPORTANT: The specific indices of the parent H points and V -!*** points that are updated by the children are identical. -!*** A signficant generalization will be needed if that -!*** fact ever changes. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_CplComp) :: CPL_COMP !<-- The Parent-Child Coupler Component -! - TYPE(ESMF_State) :: IMP_STATE & !<-- The Coupler's Import State - ,EXP_STATE !<-- The Coupler's Export State -! - TYPE(ESMF_Clock) :: CLOCK !<-- The ESMF Clock -! - INTEGER,INTENT(OUT) :: RC_FINAL -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT),SAVE :: H_OR_V_INT,NTOT,NTOT_H_V -! - INTEGER(kind=KINT) :: L1,L2,MY_DOMAIN_ID,MY_PARENT_ID & - ,N,N_STENCIL,N_STENCIL_SFC & - ,N1,N1P,N2,N2P,NL,NT,NTAG,NTIMESTEP & - ,NUM_DIMS,NV,NVERT,NX,NY -! - INTEGER(kind=KINT) :: I_SW_PARENT_CURRENT_X & - ,J_SW_PARENT_CURRENT_X -! - INTEGER(kind=KINT) :: LB1,LB2,UB1,UB2 -! - INTEGER(kind=KINT) :: IERR,RC -! - INTEGER(kind=ESMF_KIND_I8) :: NTIMESTEP_ESMF -! - INTEGER,DIMENSION(MPI_STATUS_SIZE) :: JSTAT -! - INTEGER(kind=KINT),DIMENSION(1:2) :: LBND,UBND -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: I_2WAY,I_2WAY_X & - ,J_2WAY,J_2WAY_X -! - REAL(kind=KFPT),DIMENSION(:),POINTER :: VAR_PARENT -! - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ARRAY_2WAY_R2D -! - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: CHILD_SFC_INTERP -! - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: ARRAY_2WAY_R3D & - ,VAR_CHILD -! - REAL(kind=KFPT),DIMENSION(:,:,:,:),POINTER :: ARRAY_2WAY_R4D -! - LOGICAL(kind=KLOG) :: INTERPOLATE_SFC -! - LOGICAL(kind=KLOG),SAVE :: BEGIN_H,BEGIN_V & - ,MY_2WAY_SIGNAL=.TRUE. -! - CHARACTER(len=1) :: H_OR_V -! - CHARACTER(len=99) :: FIELD_NAME -! - LOGICAL(kind=KLOG) :: MOVE_NOW -! - TYPE(ESMF_Field) :: HOLD_FIELD -! - TYPE(ESMF_TypeKind_Flag) :: DATATYPE -! - TYPE(COMPOSITE),POINTER :: CC -! - integer(kind=kint),dimension(8) :: values -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!-------------------------- -!*** The current timestep -!-------------------------- -! - CALL ESMF_CLOCKGET(clock =CLOCK & - ,advanceCount=NTIMESTEP_ESMF & - ,rc =RC) -! - NTIMESTEP=NTIMESTEP_ESMF -! -!----------------------- -!*** Current Domain ID -!----------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="CHILDREN_SEND_PARENTS_2WAY_DATA: Extract Domain ID" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='MY_DOMAIN_ID' & !<-- Name of the attribute to extract - ,value=MY_DOMAIN_ID & !<-- Current domain's ID - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Point to the correct part of the composite object which will -!*** align working variables in this task's memory with values -!*** associated with this particular domain. -!----------------------------------------------------------------------- -! - CALL POINT_TO_COMPOSITE(MY_DOMAIN_ID) -! - CC=>CPL_COMPOSITE(MY_DOMAIN_ID) -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Did this domain move at the beginning of this timestep? -!----------------------------------------------------------------------- -! - IF(MY_DOMAIN_MOVES.AND..NOT.FIRST_STEP_2WAY)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="CHILDREN_SEND_PARENTS_2WAY_DATA: Extract Move Flag" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE & !<-- The parent-child coupler export state - ,name ='MOVE_NOW' & !<-- Name of the attribute to extract - ,value=MOVE_NOW & !<-- Did this child just move? - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! - IF(FIRST_STEP_2WAY)THEN - FIRST_STEP_2WAY=.FALSE. - ENDIF -! -!----------------------------------------------------------------------- -! - CALL MPI_COMM_RANK(COMM_TO_MY_PARENT,MYPE,IERR) !<-- Obtain my local rank in parent-child intracomm -! -!----------------------------------------------------------------------- -!*** The lead child task now sends the lead parent task a signal -!*** indicating that the child has caught up to the parent in time -!*** and is ready to send its 2-way exchange data. -!*** A child must never send its signal to its parent at the end -!*** of the final timestep of the forecast since the parent would -!*** need to go one timestep beyond the end of the forecast in -!*** order to receive that signal. -!----------------------------------------------------------------------- -! - IF(NTIMESTEP0)THEN - DO NT=1,NTASKS_UPDATE_PARENT !<-- Loop through parent task subdomains updated last time. -! - CALL MPI_WAIT(HANDLE_SEND_2WAY_DATA(NT) & !<-- Request handle for ISend of update to parent task NT - ,JSTAT & !<-- MPI status - ,IERR ) -! - CALL MPI_WAIT(HANDLE_SEND_2WAY_SFC(NT) & !<-- Request handle for ISend of FIS,PD to parent task NT - ,JSTAT & !<-- MPI status - ,IERR ) -! - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Each child task determines the parent tasks to which it must -!*** provide update data and to which points on those parent tasks. -!*** This needs to be done only once for static nests. For moving -!*** nests it must be done initially and then again each time the -!*** child or parent has moved at the beginning of this parent -!*** timestep. Recall that at this point in time the child -!*** is at the end of a parent timestep and that the parent will -!*** receive 2-way update data from this child at the beginning -!*** of the next parent timestep. In timesteps that the parent -!*** shifts the parent will incorporate the 2-way data BEFORE the -!*** the shift of data actually occurs in DOMAIN_RUN. Therefore -!*** the child always generates 2-way data for the parent's -!*** position valid for the same time at which the child is -!*** doing the 2-way data generation. -! -!*** Recall that the child's I,J of its southwest corner on its -!*** parent's grid is part of the composite object and thus is -!*** always retained. However the change of that corner location -!*** due to the parent's upcoming shift is computed locally here -!*** because 2-way exchange is only optional. The location of -!*** the child's SW corner due the motion of its parent will be -!*** permanently updated in CHILD_RECV_PARENT_DATA where the -!*** computation is always needed for receiving BC updates. -!----------------------------------------------------------------------- -! - I_SW_PARENT_CURRENT_X=I_SW_PARENT_CURRENT - J_SW_PARENT_CURRENT_X=J_SW_PARENT_CURRENT -! -!----------------------------------------------------------------------- -! - IF(.NOT.CALLED_CHILD_2WAY_BOOKKEEPING & !<-- All nests' first update of their parents. - .OR. & - MY_DOMAIN_MOVES.AND.MOVE_NOW & !<-- This child moved at the start of this parent timestep. - .OR. & - MY_DOMAIN_MOVES & - .AND. & - NTIMESTEP==PARENT_SHIFT(1)*TIME_RATIO_MY_PARENT & !<-- Parent moved at the start of - +TIME_RATIO_MY_PARENT-1)THEN !<-- the current parent timestep. -! - MY_PARENT_ID=ID_PARENTS(MY_DOMAIN_ID) !<-- Domain ID of the current domain's parent -! - CALL CHILD_2WAY_BOOKKEEPING(I_SW_PARENT_CURRENT_X & ! ^ - ,J_SW_PARENT_CURRENT_X & ! | - ,SPACE_RATIO_MY_PARENT & ! | - ,NUM_FCST_TASKS_PARENT & ! | - ,PTASK_LIMITS(MY_DOMAIN_ID)%ITS & ! | - ,PTASK_LIMITS(MY_DOMAIN_ID)%ITE & ! | - ,PTASK_LIMITS(MY_DOMAIN_ID)%JTS & ! | - ,PTASK_LIMITS(MY_DOMAIN_ID)%JTE & ! - ,N_BLEND_H & ! input - ,N_BLEND_V & ! - ,N_STENCIL_H & ! | - ,N_STENCIL_V & ! | - ,N_STENCIL_SFC_H & ! | - ,N_STENCIL_SFC_V & ! | - ,ITS,ITE,JTS,JTE & ! | - ,IDS,IDE,JDS,JDE & ! v -! ----- - ,NTASKS_UPDATE_PARENT & ! ^ - ,ID_PARENT_UPDATE_TASKS & ! | - ,NPTS_UPDATE_ON_PARENT_TASKS & ! | - ,I_2WAY_UPDATE & ! output - ,J_2WAY_UPDATE & ! | - ) ! v -! - CALLED_CHILD_2WAY_BOOKKEEPING=.TRUE. -! -!----------------------------------------------------------------------- -!*** If this child task has determined that it is responsible for -!*** updating any of its parent tasks initially or after either domain -!*** shifts then reset arrays/variables associated with the -!*** interpolation from the child to the parent. -!----------------------------------------------------------------------- -! - reset: IF(NTASKS_UPDATE_PARENT>0)THEN !<-- If true then the current child task must update -! ! at least one parent task subdomain. -!----------------------------------------------------------------------- -! - parent_subdomains_1: DO NT=1,NTASKS_UPDATE_PARENT !<-- Loop through each parent task subdomain to be updated. -! -!----------------------------------------------------------------------- -! - IF(ASSOCIATED(I_2WAY_H(NT)%DATA))THEN - DEALLOCATE(I_2WAY_H(NT)%DATA) - DEALLOCATE(J_2WAY_H(NT)%DATA) - DEALLOCATE(I_2WAY_V(NT)%DATA) - DEALLOCATE(J_2WAY_V(NT)%DATA) - ENDIF -! - ALLOCATE(I_2WAY_H(NT)%DATA(1:NPTS_UPDATE_ON_PARENT_TASKS(NT))) - ALLOCATE(J_2WAY_H(NT)%DATA(1:NPTS_UPDATE_ON_PARENT_TASKS(NT))) - ALLOCATE(I_2WAY_V(NT)%DATA(1:NPTS_UPDATE_ON_PARENT_TASKS(NT))) - ALLOCATE(J_2WAY_V(NT)%DATA(1:NPTS_UPDATE_ON_PARENT_TASKS(NT))) -! -!----------------------------------------------------------------------- -!*** Translate to this child's I's and J's the parent I's and J's to -!*** be updated. If a child h point lies on a parent target V point -!*** (the opposite cannot happen on the B-grid) then the child's I and -!*** J are those of the child h point which corresponds to the child -!*** v point to the NE of the parent V point. The H-V diagrams seen in -!*** subroutines GENERATE_2WAY_DATA and PARENT_BOOKKEEPING_MOVING help -!*** clarify the relationship between h,v and H,V. -!----------------------------------------------------------------------- -! - I_2WAY=>I_2WAY_UPDATE(NT)%DATA !<-- Parent I at each parent update point on parent task NT - J_2WAY=>J_2WAY_UPDATE(NT)%DATA !<-- Parent J at each parent update point on parent task NT -! - DO N=1,NPTS_UPDATE_ON_PARENT_TASKS(NT) !<-- Loop through each parent I,J to be updated on subdomain NT -! - I_2WAY_H(NT)%DATA(N)=(I_2WAY(N)-I_SW_PARENT_CURRENT_X) & !<-- Child I at parent update H point - *SPACE_RATIO_MY_PARENT+1 ! on parent task NT. - J_2WAY_H(NT)%DATA(N)=(J_2WAY(N)-J_SW_PARENT_CURRENT_X) & !<-- Child J at parent update H point - *SPACE_RATIO_MY_PARENT+1 ! on parent task NT. -! - I_2WAY_V(NT)%DATA(N)=I_2WAY_H(NT)%DATA(N) & !<-- Child I at parent update V point - +SPACE_RATIO_MY_PARENT/2 ! on parent task NT. -! - J_2WAY_V(NT)%DATA(N)=J_2WAY_H(NT)%DATA(N) & !<-- Child J at parent update V point - +SPACE_RATIO_MY_PARENT/2 !<-- on parent task NT. -! - ENDDO -! -!----------------------------------------------------------------------- -! - NTOT=NPTS_UPDATE_ON_PARENT_TASKS(NT)*NLEV_2WAY !<-- # of points updated for all vbls on parent task NT -! - IF(ASSOCIATED(cc%UPDATE_PARENT_2WAY(NT)%DATA))THEN - DEALLOCATE(cc%UPDATE_PARENT_2WAY(NT)%DATA) - ENDIF - ALLOCATE(cc%UPDATE_PARENT_2WAY(NT)%DATA(1:NTOT),stat=RC) !<-- Updated values for all 2-way variables on parent task NT -! -!----------------------------------------------------------------------- -! - NTOT_H_V=NPTS_UPDATE_ON_PARENT_TASKS(NT)*2 !<-- # of updated H points then V points (thus *2) - IF(ASSOCIATED(cc%CHILD_SFC_ON_PARENT(NT)%DATA))THEN - DEALLOCATE(cc%CHILD_SFC_ON_PARENT(NT)%DATA) - ENDIF - ALLOCATE(cc%CHILD_SFC_ON_PARENT(NT)%DATA(1:NTOT_H_V,1:2)) !<-- Child FIS(:1),PD(:2) interp'd to H and V parent update pts -! - NTOT_SFC=2*NTOT_H_V !<-- Both FIS and PD (thus *2) are interpolated from the child -! ! to parent H and V. -!----------------------------------------------------------------------- -! - ENDDO parent_subdomains_1 -! -!----------------------------------------------------------------------- -! - ENDIF reset -! -!----------------------------------------------------------------------- -! - ENDIF -! -!----------------------------------------------------------------------- -!*** If this child task is responsible for updating none of its -!*** parent's task subdomains then it may leave. -!----------------------------------------------------------------------- -! - IF(NTASKS_UPDATE_PARENT==0)THEN - RETURN !<-- Nothing more to do if no parent tasks are updated - ENDIF -! -!----------------------------------------------------------------------- -!*** The child tasks generate 2-way update data for those points on -!*** each parent task for which they are responsible. -!----------------------------------------------------------------------- -! - parent_subdomains_2: DO NT=1,NTASKS_UPDATE_PARENT !<-- Loop over the parent task subdomains this child task updates. -! -!----------------------------------------------------------------------- -! - N2=0 - BEGIN_H=.TRUE. - BEGIN_V=.TRUE. -! -!----------------------------------------------------------------------- -!*** Loop through the variables in the 2-way exchange. -!----------------------------------------------------------------------- -! - vars: DO NV=1,NVARS_2WAY_UPDATE !<-- Loop over all parent exchange variables updated by the child. -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Field from the Bundle of 2-way Vars" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=BUNDLE_2WAY & !<-- Bundle holding the arrays for 2-way exchange - ,fieldIndex =NV & !<-- Index of the Field in the Bundle - ,field =HOLD_FIELD & !<-- Field NV in the Bundle - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Info about this 2-way Variable" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,dimCount=NUM_DIMS & !<-- Is this Field 2-D or 3-D? - ,typeKind=DATATYPE & !<-- Does the Field contain an integer or real array? - ,name =FIELD_NAME & !<-- This Field's name - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Character variables cannot be used as ESMF Attributes so -!*** integers are used below to indicate whether the 2-way variable -!*** is on H or V points. After this integer Attribute is read in -!*** translate it to a character. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract whether H or V Array from Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(field=HOLD_FIELD & !<-- Get Attribute from this Field - ,name ='H_OR_V_INT' & !<-- Name of the attribute to extract - ,value=H_OR_V_INT & !<-- Value of the Attribute - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(H_OR_V_INT==1)THEN - H_OR_V='H' - ELSEIF(H_OR_V_INT==2)THEN - H_OR_V='V' - ENDIF -! -!----------------------------------------------------------------------- -!*** Point at the child I,J points used for interpolation to the -!*** appropriate parent tasks' H and V points. -!----------------------------------------------------------------------- -! - IF(H_OR_V=='H')THEN - I_2WAY_X=>I_2WAY_H(NT)%DATA !<-- Use child I's at parent H points - J_2WAY_X=>J_2WAY_H(NT)%DATA !<-- Use child J's at parent H points - N_STENCIL=N_STENCIL_H !<-- Width of stencil of child averaging for parent H pts -! - ELSEIF(H_OR_V=='V')THEN - I_2WAY_X=>I_2WAY_V(NT)%DATA !<-- Use child I's at parent V points - J_2WAY_X=>J_2WAY_V(NT)%DATA !<-- Use child J's at parent V points - N_STENCIL=N_STENCIL_V !<-- Width of stencil of child averaging for parent V pts -! - ENDIF -! -!----------------------------------------------------------------------- -!*** The nest also interpolates its PD and sfc geopotential to parent -!*** H and V points so the parent will be able to adjust the update -!*** variables when the parent and nest surface elevations differ. -!----------------------------------------------------------------------- -! - INTERPOLATE_SFC=.FALSE. -! - IF(H_OR_V=='H'.AND.BEGIN_H)THEN !<-- Child generates FIS,PD on H only once per vbl for parent task NT - INTERPOLATE_SFC=.TRUE. - N1P=1 !<-- Starting word location for FIS,PD on H for parent task NT - N2P=NPTS_UPDATE_ON_PARENT_TASKS(NT) !<-- Ending word location for FIS,PD on H for parent task NT - CHILD_SFC_INTERP=>cc%CHILD_SFC_ON_PARENT(NT)%DATA(N1P:N2P,1:2) !<-- Child's FIS,PD on parent task NT's update H points - N_STENCIL_SFC=N_STENCIL_SFC_H !<-- Stencil width for interpolating child FIS,PD to parent H -! - ELSEIF(H_OR_V=='V'.AND.BEGIN_V)THEN !<-- Child generates FIS,PD on V only once per vbl for parent task NT - INTERPOLATE_SFC=.TRUE. - N1P=NPTS_UPDATE_ON_PARENT_TASKS(NT)+1 !<-- Starting word location for FIS,PD on V for parent task NT - N2P=N1P+NPTS_UPDATE_ON_PARENT_TASKS(NT)-1 !<-- Ending word location for FIS,PD on V for parent task NT - CHILD_SFC_INTERP=>cc%CHILD_SFC_ON_PARENT(NT)%DATA(N1P:N2P,1:2) !<-- Child's FIS,PD on parent task NT's update V points - N_STENCIL_SFC=N_STENCIL_SFC_V !<-- Stencil width for interpolating child FIS,PD to parent V -! - ENDIF -! -!----------------------------------------------------------------------- -! - dtype: IF(DATATYPE==ESMF_TYPEKIND_R4)THEN !<-- Is this a Real 2-way variable? -! -!----------------------------------------------------------------------- -! - ndims: IF(NUM_DIMS==2)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract 2-way Real 2-D Array from the Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the 2-D data pointer - ,localDe =0 & - ,farrayPtr=ARRAY_2WAY_R2D & !<-- Use this 2-D pointer to the variable. - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - L1=1 - L2=1 - NVERT=1 -! - LBND=LBOUND(ARRAY_2WAY_R2D) - LB1=LBND(1) - LB2=LBND(2) - UBND=UBOUND(ARRAY_2WAY_R2D) - UB1=UBND(1) - UB2=UBND(2) -! - ALLOCATE(VAR_CHILD(LB1:UB1,LB2:UB2,1)) - DO NY=LB2,UB2 - DO NX=LB1,UB1 - VAR_CHILD(NX,NY,1)=ARRAY_2WAY_R2D(NX,NY) !<-- For simplicity the generic exchange input is always 3-D - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -! - ELSEIF(NUM_DIMS==3)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract 2-way Real 3-D Array from the Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer - ,localDe =0 & - ,farrayPtr=ARRAY_2WAY_R3D & !<-- Use this 3-D pointer to the variable. - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - L1=1 - L2=1 - NVERT=LM !<-- Assume all 3-D exchange vbls have LM levels - VAR_CHILD=>ARRAY_2WAY_R3D -! -!----------------------------------------------------------------------- -! - ELSEIF(NUM_DIMS==4)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract 2-way Real 4-D Array from the Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer - ,localDe =0 & - ,farrayPtr=ARRAY_2WAY_R4D & !<-- Use this 4-D pointer to the variable. - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - L1=LBOUND(ARRAY_2WAY_R4D,4) - L2=UBOUND(ARRAY_2WAY_R4D,4) - NVERT=LM !<-- Assume all 3-D exchange vbls have LM levels -! -!----------------------------------------------------------------------- -! - ENDIF ndims -! -!----------------------------------------------------------------------- -! - ELSEIF(DATATYPE==ESMF_TYPEKIND_I4)THEN -! - WRITE(0,10001) -10001 FORMAT(' Not considering the use of Integer 2-way exchange variables') - WRITE(0,*)' ABORT!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) -! -!----------------------------------------------------------------------- -! - ENDIF dtype -! -!----------------------------------------------------------------------- -! - DO NL=L1,L2 !<-- Loop through this variable's 4th dimension if it exists. -! - IF(NUM_DIMS==4)THEN - VAR_CHILD=>ARRAY_2WAY_R4D(:,:,:,NL) !<-- Select the NL'th 3-D piece of the 4-D exchange variable - ENDIF -! - N1=N2+1 !<-- Starting word location of Real vbl #NV to parent task NT - N2=N1+NPTS_UPDATE_ON_PARENT_TASKS(NT)*NVERT-1 !<-- Ending word location of Real vbl #NV to parent task NT - VAR_PARENT=>cc%UPDATE_PARENT_2WAY(NT)%DATA(N1:N2) !<-- Updated values for Real variable #NV on parent task NT -! - CALL GENERATE_2WAY_DATA(VAR_CHILD & !<-- Child variable to be interpolated - ,PD & !<-- The child's PD array - ,FIS & !<-- The child's sfc geopotential array - ,IMS,IME,JMS,JME,NVERT & !<-- This child task subdomain's memory dimensions - ,I_2WAY_X & !<-- Child I at each parent update point (H or V) - ,J_2WAY_X & !<-- Child J at each parent update point (H or V) - ,N_STENCIL & !<-- Stencil width of child averaging for parent variable - ,N_STENCIL_SFC & !<-- Stencil width of child averaging its FIS,PD to parent grid - ,NPTS_UPDATE_ON_PARENT_TASKS(NT) & !<-- # of update points (I,J) on parent task NT - ,VAR_PARENT & !<-- Child values interpolated onto parent points for this vbl - ,INTERPOLATE_SFC & !<-- Should PD and FIS be interpolated in this call? - ,CHILD_SFC_INTERP & !<-- Child PD,FIS interpolated onto parent H then V points - ) - ENDDO -! - IF(BEGIN_H)THEN - BEGIN_H=.FALSE. - ENDIF - IF(BEGIN_V)THEN - BEGIN_V=.FALSE. - ENDIF -! - IF(NUM_DIMS==2)THEN !<-- VAR_CHILD explicitly allocated only for 2-D variables - DEALLOCATE(VAR_CHILD) - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO vars -! -!----------------------------------------------------------------------- -!*** The child task ISSends parent fcst task NT its update data for -!*** all the relevant variables at once followed by another ISSend -!*** of the child's FIS and PD values interpolated to the parent's -!*** H and V points to be updated. -!----------------------------------------------------------------------- -! - NTOT=NLEV_2WAY*NPTS_UPDATE_ON_PARENT_TASKS(NT) !<-- # of points (3-D) updated for all vbls on parent task NT - NTAG=100*MY_DOMAIN_ID+MYPE -! - CALL MPI_ISSEND(cc%UPDATE_PARENT_2WAY(NT)%DATA & !<-- All variables at parent task NT's 2-way update points - ,NTOT & !<-- # of words sent to parent task to update 3-D variables - ,MPI_REAL & !<-- The words are real - ,ID_PARENT_UPDATE_TASKS(NT) & !<-- Local ID of target parent task in P-C intracomm - ,NTAG & !<-- MPI tag - ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator between child and parent - ,HANDLE_SEND_2WAY_DATA(NT) & !<-- Request handle for ISend - ,IERR ) -! - NTOT_H_V=NPTS_UPDATE_ON_PARENT_TASKS(NT)*2 !<-- # of updated H points then V points (thus *2) - NTOT_SFC=2*NTOT_H_V !<-- # of updated FIS and PD values updated (thus *2) - NTAG=100*MY_DOMAIN_ID+MYPE -! - CALL MPI_ISSEND(cc%CHILD_SFC_ON_PARENT(NT)%DATA & !<-- Child FIS,PD on H,V update points of parent task NT - ,NTOT_SFC & !<-- # of words sent to parent task to update FIS,PD - ,MPI_REAL & !<-- The words are real - ,ID_PARENT_UPDATE_TASKS(NT) & !<-- Local ID of parent task in P-C intracomm - ,NTAG & !<-- MPI tag - ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator between child and parent - ,HANDLE_SEND_2WAY_SFC(NT) & !<-- Request handle for ISend - ,IERR ) -! -!----------------------------------------------------------------------- -! - ENDDO parent_subdomains_2 -! -!----------------------------------------------------------------------- -! - END SUBROUTINE CHILDREN_SEND_PARENTS_2WAY_DATA -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE PARENT_CHILD_CPL_FINALIZE(CPL_COMP & - ,IMP_STATE & - ,EXP_STATE & - ,CLOCK & - ,RC_FINAL) -! -!----------------------------------------------------------------------- -!*** FINALIZE THE COUPLER. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_CplComp) :: CPL_COMP !<-- The Parent-Child Coupler Component -! - TYPE(ESMF_State) :: IMP_STATE & !<-- The Coupler's Import State - ,EXP_STATE !<-- The Coupler's Export State -! - TYPE(ESMF_Clock) :: CLOCK !<-- The ESMF Clock -! - INTEGER,INTENT(OUT) :: RC_FINAL -! -!--------------------- -!*** Local variables -!--------------------- -! - INTEGER :: MY_DOMAIN_ID,RC,RC_CPL_FINAL -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RC_FINAL =ESMF_SUCCESS - RC_CPL_FINAL=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** Extract the domain ID. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Finalize: Extract Current Domain ID" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The parent-child coupler import state - ,name ='MY_DOMAIN_ID' & !<-- Name of the attribute to extract - ,value=MY_DOMAIN_ID & !<-- Current domain's ID - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL_FINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - CALL POINT_TO_COMPOSITE(MY_DOMAIN_ID) -! -!----------------------------------------------------------------------- -! - WRITE(0,*)' Clocktime Parent-Child Coupler' - WRITE(0,*)' Cpl1 Prelim=',cpl1_prelim_tim*1.e-3 - WRITE(0,*)' Cpl1 South_H=',cpl1_south_h_tim*1.e-3 - WRITE(0,*)' Cpl1 South_V=',cpl1_south_v_tim*1.e-3 - WRITE(0,*)' Cpl1 North_H=',cpl1_north_h_tim*1.e-3 - WRITE(0,*)' Cpl1 North_V=',cpl1_north_v_tim*1.e-3 - WRITE(0,*)' Cpl1 West_H=',cpl1_west_h_tim*1.e-3 - WRITE(0,*)' Cpl1 West_V=',cpl1_west_v_tim*1.e-3 - WRITE(0,*)' Cpl1 East_H=',cpl1_east_h_tim*1.e-3 - WRITE(0,*)' Cpl1 East_V=',cpl1_east_v_tim*1.e-3 - WRITE(0,*)' ' - WRITE(0,*)' Cpl1 South_H_Recv=',cpl1_south_h_recv_tim*1.e-3 - WRITE(0,*)' Cpl1 South_H_Undo=',cpl1_south_h_undo_tim*1.e-3 - WRITE(0,*)' Cpl1 South_H_Exp =',cpl1_south_h_exp_tim*1.e-3 - WRITE(0,*)' Cpl1 South_V_Recv=',cpl1_south_v_recv_tim*1.e-3 - WRITE(0,*)' Cpl1 South_V_Undo=',cpl1_south_v_undo_tim*1.e-3 - WRITE(0,*)' Cpl1 South_V_Exp =',cpl1_south_v_exp_tim*1.e-3 - WRITE(0,*)' ' -! -!----------------------------------------------------------------------- -! - IF(I_AM_A_PARENT)THEN - WRITE(0,*)' Cpl2 Parent Bookkeeping for Moving Nest=' & - ,parent_bookkeep_moving_tim*1.e-3 - WRITE(0,*)' Cpl2 Parent Update for Moving Nest=' & - ,parent_update_moving_tim*1.e-3 - ENDIF - WRITE(0,*)' ' - IF(MY_DOMAIN_MOVES)THEN - WRITE(0,*)' Cpl1 Moving Nest Bookkeeping=' & - ,parent_bookkeep_moving_tim*1.e-3 - WRITE(0,*)' Cpl1 Moving Nest Update=' & - ,parent_update_moving_tim*1.e-3 - ENDIF -! -!----------------------------------------------------------------------- -! - IF(RC_CPL_FINAL==ESMF_SUCCESS)THEN -! WRITE(0,*)"CPL FINALIZE STEP SUCCEEDED" - ELSE - WRITE(0,*)"CPL FINALIZE STEP FAILED" - ENDIF -! - RC_FINAL=RC_CPL_FINAL -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PARENT_CHILD_CPL_FINALIZE -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE PARENT_CHILD_COUPLER_SETUP(NUM_DOMAINS & ! - ,MY_DOMAIN_ID & ! - ,NUM_CHILDREN & ! - ,COMM_TO_MY_CHILDREN & ! - ,COMM_TO_MY_PARENT & ! - ,DT & ! - ,CHILD_ID & ! ^ - ,DOMAIN_GRID_COMP & ! | - ,EXP_STATE_DOMAIN & ! | - ,FTASKS_DOMAIN & ! | - ,NTASKS_DOMAIN & ! | - ,ID_PARENTS_IN & ! | - ,DOMAIN_ID_TO_RANK & ! | - ,MAX_DOMAINS & ! Input -! ----------- - ,IMP_STATE_CPL_NEST & ! Output - ,EXP_STATE_CPL_NEST & ! | - ) ! v -! -!----------------------------------------------------------------------- -!*** Create the Parent-Child coupler through which they will -!*** communicate. This coupler is called by the NMM component. -!*** Move data from the DOMAIN export state into the Parent-Child -!*** coupler import state that the coupler will need in order for -!*** parents to generate data for their children and for moving -!*** nests to determine when to move. -!----------------------------------------------------------------------- -! - USE module_DOMAIN_INTERNAL_STATE,ONLY: DOMAIN_INTERNAL_STATE & - ,WRAP_DOMAIN_INTERNAL_STATE -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: COMM_TO_MY_PARENT & !<-- Current domain's MPI communicator to its parent - ,MAX_DOMAINS & !<-- Maximum # of domains - ,MY_DOMAIN_ID & !<-- ID of current domain - ,NUM_CHILDREN & !<-- Current domain's number of children - ,NUM_DOMAINS !<-- Total number of domains -! - INTEGER(kind=KINT),DIMENSION(:),POINTER,INTENT(IN) :: CHILD_ID & !<-- Domain IDs of current domain's children - ,COMM_TO_MY_CHILDREN & !<-- Current domain's MPI communicators to its children - ,FTASKS_DOMAIN & !<-- # of forecast tasks on each domain - ,ID_PARENTS_IN & !<-- IDs of parents of nested domains - ,NTASKS_DOMAIN !<-- # of fcst+quilt tasks on each domain -! - INTEGER(kind=KINT),DIMENSION(MAX_DOMAINS),INTENT(IN) :: DOMAIN_ID_TO_RANK !<-- Configure file associated with each domain ID -! - REAL(kind=KFPT),DIMENSION(1:NUM_DOMAINS),INTENT(IN) :: DT !<-- Timesteps for all domains (DOMAIN Components) -! - TYPE(ESMF_GridComp) :: DOMAIN_GRID_COMP !<-- The current DOMAIN component -! - TYPE(ESMF_State),INTENT(INOUT) :: EXP_STATE_DOMAIN !<-- Export state of the current DOMAIN Component -! - TYPE(ESMF_State),INTENT(INOUT) :: IMP_STATE_CPL_NEST & !<-- Parent-Child Coupler import state - ,EXP_STATE_CPL_NEST !<-- Parent-Child Coupler export state -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT),SAVE :: N8=8 -! - INTEGER(kind=KINT) :: CHILDTASK & - ,COMM_FCST_TASKS & - ,COMM_MY_DOMAIN & - ,ITS,ITE,JTS,JTE & - ,IDS,IDE,JDS,JDE & - ,ID,ID_CHILD,IERR & - ,IHANDLE_RECV,IHANDLE_SEND & - ,INDX_CW,INDX_Q & - ,I_PAR_STA,J_PAR_STA & - ,JM & - ,LAST_STEP_MOVED & - ,KOUNT,LM,LMP1,MYPE,MYPE_DOMAIN & - ,N,N_BLEND_H,N_BLEND_V,NHALO & - ,NKOUNT,NN,NPHS,NTAG,NX -! - INTEGER(kind=KINT) :: ISTAT,RC,RC_NESTSET -! - INTEGER(kind=KINT),DIMENSION(2) :: STORM_CENTER -! - INTEGER(kind=KINT),DIMENSION(4) :: LIMITS -! - INTEGER(kind=KINT),DIMENSION(8) :: MY_NEB -! - INTEGER(kind=KINT),DIMENSION(MPI_STATUS_SIZE) :: JSTAT -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: PARENT_CHILD_RATIO -! -! - REAL(kind=KFPT) :: DLMD,DPHD,DYH,PDTOP,PT -! - REAL(kind=KFPT),DIMENSION(:),ALLOCATABLE :: ARRAY_1D -! - TYPE(ESMF_Field) :: HOLD_FIELD -! - TYPE(ESMF_VM) :: VM_DOMAIN -! - LOGICAL(kind=KLOG) :: I_AM_ACTIVE,RESTART -! - LOGICAL(kind=KLOG),DIMENSION(:),ALLOCATABLE :: CHILD_ACTIVE -! - TYPE(WRAP_DOMAIN_INTERNAL_STATE) :: WRAP_DOMAIN -! - TYPE(DOMAIN_INTERNAL_STATE),POINTER :: DOMAIN_INT_STATE -! - TYPE(COMPOSITE),POINTER :: CC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RC_NESTSET=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** Allocate the coupler's composite object to the total # of domains -!*** for generality. Use the specific domain ID to access only that -!*** part of the object that is pertinent to the given domain. This -!*** is needed because any MPI task can be on more than one domain -!*** and it must know which domain's variables to use. -!----------------------------------------------------------------------- -! - IF(.NOT.ASSOCIATED(CPL_COMPOSITE))THEN - ALLOCATE(CPL_COMPOSITE(1:NUM_DOMAINS),stat=ISTAT) -! - IF(ISTAT/=0)THEN - WRITE(0,*)' Parent-Child composite object already allocated!' - WRITE(0,*)' ABORTING!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - ENDIF -! - CC=>CPL_COMPOSITE(MY_DOMAIN_ID) -! -!----------------------------------------------------------------------- -!*** From the DOMAIN export state find out if this task is a forecast -!*** task and if it is on a parent domain. Set them into the Parent- -!*** Child coupler's export state s they are available. -!----------------------------------------------------------------------- -! - I_AM_A_FCST_TASK=>cc%I_AM_A_FCST_TASK - I_AM_A_PARENT =>cc%I_AM_A_PARENT -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Parent-Child CPL Setup: Extract Fcst-or-Write Flag from DOMAIN Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='Fcst-or-Write Flag' & !<-- Name of the attribute to extract - ,value=I_AM_A_FCST_TASK & !<-- Am I a forecast task? - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Parent/Not-a-Parent Flag from DOMAIN Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='I-Am-A-Parent Flag' & !<-- Name of the attribute to extract - ,value=I_AM_A_PARENT & !<-- Am I on a nested domain? - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Parent-Child CPL Setup: Insert Fcst-or-Write Flag into Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE_CPL_NEST & !<-- The P-C coupler export state - ,name ='Fcst-or-Write Flag' & !<-- Name of the attribute to extract - ,value=I_AM_A_FCST_TASK & !<-- Am I a forecast task? - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert Parent/Not-a-Parent Flag into Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE_CPL_NEST & !<-- The P-C coupler export state - ,name ='I-Am-A-Parent Flag' & !<-- Name of the attribute to extract - ,value=I_AM_A_PARENT & !<-- Am I on a nested domain? - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!------------------------- -!*** Current Domain's ID -!------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Current Domain ID to the Parent-Child Cpl Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='MY_DOMAIN_ID' & !<-- Current domain's ID - ,value=MY_DOMAIN_ID & !<-- Insert this into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Retrieve this domain's VM -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get the VM of this Domain" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGet(gridcomp=DOMAIN_GRID_COMP & !<-- The Domain Component - ,vm =VM_DOMAIN & !<-- This domain's VM - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Now load key variables into the coupler's import state. -!----------------------------------------------------------------------- -! -!--------------------------------------------------- -!*** The task's local rank in the Domain component -!--------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Cpl Setup: Obtain the Local Task ID" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_VMGet(vm =VM_DOMAIN & !<-- The virtual machine for this Domain component - ,localpet=MYPE_DOMAIN & !<-- Each MPI task rank in the Domain component - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Local Task Rank on Domain to P-C Cpl Imp State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='MYPE_DOMAIN' & !<-- Local rank in Domain component - ,value=MYPE_DOMAIN & !<-- Insert this into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!------------------------------- -!*** Maximum number of domains -!------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Max # of Domains to the Parent-Child Cpl Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='MAX_DOMAINS' & !<-- Maximum # of domains - ,value=MAX_DOMAINS & !<-- Insert this into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------- -!*** Total Number of Domains -!----------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Number of Domains to the Parent-Child Cpl Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='NUM_DOMAINS' & !<-- Total number of domains - ,value=NUM_DOMAINS & !<-- Insert this into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!---------------------------------------------------------- -!*** The association of domains and their configure files -!---------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Domain/ConfigFile Association to the Parent-Child Cpl Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='DOMAIN_ID_TO_RANK' & !<-- The association of domains and their config files - ,itemCount=MAX_DOMAINS & !<-- Maximum # of domains - ,valueList=DOMAIN_ID_TO_RANK & !<-- Insert this into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!-------------------------------------- -!*** Total Number of Tasks on Domains -!-------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Total Number of Tasks Per Domain to the P-C Cpl Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='NTASKS_DOMAIN' & !<-- Number of fcst+quilt tasks on each domain - ,itemCount=NUM_DOMAINS & !<-- Number of domains - ,valueList=NTASKS_DOMAIN & !<-- Insert this into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!------------------------------------- -!*** Number of Fcst Tasks on Domains -!------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Number of Fcst Tasks Per Domain to the Parent-Child Cpl Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='FTASKS_DOMAIN' & !<-- Number of forecast tasks on each domain - ,itemCount=NUM_DOMAINS & !<-- Number of domains - ,valueList=FTASKS_DOMAIN & !<-- Insert this into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!------------------------------------- -!*** Fundamental Timestep on Domains -!------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Number of Fcst Tasks Per Domain to the Parent-Child Cpl Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='DOMAIN_DTs' & !<-- Number of forecast tasks on each domain - ,itemCount=NUM_DOMAINS & !<-- Number of domains - ,valueList=DT & !<-- Insert this into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!--------------------------- -!*** Domain IDs of Parents -!--------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Domain IDs of Parents to the Parent-Child Cpl Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='ID_PARENTS' & !<-- IDs of parent domain - ,itemCount=NUM_DOMAINS & !<-- Number of domains - ,valueList=ID_PARENTS_IN & !<-- Insert this into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!------------------------ -!*** Number of Children -!------------------------ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Number of Children to the Parent-Child Cpl Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='NUM_CHILDREN' & !<-- This DOMAIN component's # of children - ,value=NUM_CHILDREN & !<-- Insert this into the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!------------------------------- -!*** Communicators to Children -!------------------------------- -! - IF(NUM_CHILDREN>0)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Parent-to-Child Communicators to the Parent-Child CPL Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='Parent-to-Child Comms' & !<-- Name of Attribute - ,itemCount=NUM_CHILDREN & !<-- Length of inserted array - ,valueList=COMM_TO_MY_CHILDREN & !<-- Communicators to my children - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! -!---------------------------- -!*** Communicator to Parent -!---------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Child-to-Parent Communicator to the Parent-Child Cpl Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='Child-to-Parent Comm' & !<-- Name of Attribute - ,value=COMM_TO_MY_PARENT & !<-- The communicator to my parent - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!---------------------------------- -!*** Communicator for each domain -!---------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C CPL Setup: Get the Intracommunicator of this Domain" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_VMGet(vm =VM_DOMAIN & !<-- This domain's VM - ,mpiCommunicator=COMM_MY_DOMAIN & !<-- This domain's intracommunicator - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!------------------------------------------------------------- -!*** The intracommunicator for forecast tasks on this domain -!------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C CPL Setup: Extract Fcst Task Intracomm from Domain Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='Comm Fcst Tasks' & !<-- Name of the attribute to extract - ,value=COMM_FCST_TASKS & !<-- Intracomm for fcst task on this domain - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add COMM_FCST_TASKS to Parent-Child Cpl Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='Comm Fcst Tasks' & !<-- Name of Attribute - ,value=COMM_FCST_TASKS & !<-- Intracomm for fcst task on this domain - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------- -!*** Number of fcst tasks on this domain -!----------------------------------------- -! - NUM_PES_FCST=>cc%NUM_PES_FCST -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add NUM_PES_FCST to the Parent-Child Cpl Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='NUM_PES_FCST' & !<-- The name of the Attribute - ,value=NUM_PES_FCST & !<-- The Attribute to be retrieved - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='NUM_PES_FCST' & !<-- Name of Attribute - ,value=NUM_PES_FCST & !<-- The # of fcst tasks on this domain - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** The write/quilt tasks are no longer needed. -!----------------------------------------------------------------------- -! - IF(.NOT.I_AM_A_FCST_TASK)RETURN -! -!----------------------------------------------------------------------- -! -!-------------------------------------------------------- -!*** Subdomain integration limits on the forecast tasks -!-------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Integration Limits from DOMAIN Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='ITS' & !<-- The name of the Attribute - ,value=ITS & !<-- The Attribute to be retrieved - ,rc =RC) -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='ITE' & !<-- The name of the Attribute - ,value=ITE & !<-- The Attribute to be retrieved - ,rc =RC) -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='JTS' & !<-- The name of the Attribute - ,value=JTS & !<-- The Attribute to be retrieved - ,rc =RC) -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='JTE' & !<-- The name of the Attribute - ,value=JTE & !<-- The Attribute to be retrieved - ,rc =RC) -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='LM' & !<-- The name of the Attribute - ,value=LM & !<-- The Attribute to be retrieved - ,rc =RC) -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='NHALO' & !<-- The name of the Attribute - ,value=NHALO & !<-- The Attribute to be retrieved - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Subdomain Integration Limits to the P-C Cpl Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='ITS' & !<-- The name of the Attribute - ,value=ITS & !<-- The Attribute to be inserted - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='ITE' & !<-- The name of the Attribute - ,value=ITE & !<-- The Attribute to be inserted - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='JTS' & !<-- The name of the Attribute - ,value=JTS & !<-- The Attribute to be inserted - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='JTE' & !<-- The name of the Attribute - ,value=JTE & !<-- The Attribute to be inserted - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='LM' & !<-- The name of the Attribute - ,value=LM & !<-- The Attribute to be inserted - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='NHALO' & !<-- The name of the Attribute - ,value=NHALO & !<-- The Attribute to be inserted - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!------------------------------------------------------------------ -!*** Subdomain integration limits for all fcst tasks on my domain -!------------------------------------------------------------------ -! -! - CALL ESMF_GridCompGetInternalState(DOMAIN_GRID_COMP & !<-- The DOMAIN component - ,WRAP_DOMAIN & !<-- Extract the pointer to my DOMAIN internal state - ,RC ) -! - DOMAIN_INT_STATE=>wrap_domain%DOMAIN_INT_STATE !<-- Point at my DOMAIN internal state -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add All Fcst Task Integration Limits to the P-C Cpl Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='LOCAL ISTART' & !<-- Name of Attribute - ,itemCount=FTASKS_DOMAIN(MY_DOMAIN_ID) & !<-- Length of inserted array (# of fcst tasks on domain) - ,valueList=domain_int_state%LOCAL_ISTART & !<-- Starting I's on my domain's fcst tasks - ,rc =RC) -! - CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='LOCAL IEND' & !<-- Name of Attribute - ,itemCount=FTASKS_DOMAIN(MY_DOMAIN_ID) & !<-- Length of inserted array (# of fcst tasks on domain) - ,valueList=domain_int_state%LOCAL_IEND & !<-- Ending I's on my domain's fcst tasks - ,rc =RC) -! - CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='LOCAL JSTART' & !<-- Name of Attribute - ,itemCount=FTASKS_DOMAIN(MY_DOMAIN_ID) & !<-- Length of inserted array (# of fcst tasks on domain) - ,valueList=domain_int_state%LOCAL_JSTART & !<-- Starting J's on my domain's fcst tasks - ,rc =RC) -! - CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='LOCAL JEND' & !<-- Name of Attribute - ,itemCount=FTASKS_DOMAIN(MY_DOMAIN_ID) & !<-- Length of inserted array (# of fcst tasks on domain) - ,valueList=domain_int_state%LOCAL_JEND & !<-- Ending J's on my domain's fcst tasks - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!---------------------------- -!*** Full Domain Dimensions -!---------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Full Domain Dimensions from DOMAIN Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='IDS' & !<-- The name of the Attribute - ,value=IDS & !<-- The Attribute to be retrieved - ,rc =RC) -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='IDE' & !<-- The name of the Attribute - ,value=IDE & !<-- The Attribute to be retrieved - ,rc =RC) -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='JDS' & !<-- The name of the Attribute - ,value=JDS & !<-- The Attribute to be retrieved - ,rc =RC) -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='JDE' & !<-- The name of the Attribute - ,value=JDE & !<-- The Attribute to be retrieved - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Full Domain Dimensions to the Parent-Child Cpl Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='IDS' & !<-- The name of the Attribute - ,value=IDS & !<-- The Attribute to be inserted - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='IDE' & !<-- The name of the Attribute - ,value=IDE & !<-- The Attribute to be inserted - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='JDS' & !<-- The name of the Attribute - ,value=JDS & !<-- The Attribute to be inserted - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='JDE' & !<-- The name of the Attribute - ,value=JDE & !<-- The Attribute to be inserted - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** My 8 neighboring tasks. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract MY_NEB from DOMAIN Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='MY_NEB' & !<-- The name of the Attribute - ,itemCount=N8 & !<-- # of words in data list - ,valueList=MY_NEB & !<-- Put extracted values here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add MY_NEB to the Parent-Child Cpl Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='MY_NEB' & !<-- The name of the Attribute - ,itemCount=N8 & !<-- # of words in data list - ,valueList=MY_NEB & !<-- Put added values here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!-------------------------------- -!*** Frequency of physics calls -!-------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract NPHS from DOMAIN Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='NPHS' & !<-- The name of the Attribute - ,value=NPHS & !<-- The Attribute to be retrieved - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add NPHS to the Parent-Child Cpl Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='NPHS' & !<-- The name of the Attribute - ,value=NPHS & !<-- The Attribute to be inserted - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!--------------------------------------- -!*** Width of Boundary Blending Region -!--------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Boundary Blending Region Widths from DOMAIN Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='LNSH' & !<-- The name of the Attribute - ,value=N_BLEND_H & !<-- The Attribute to be retrieved - ,rc =RC) -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='LNSV' & !<-- The name of the Attribute - ,value=N_BLEND_V & !<-- The Attribute to be retrieved - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Boundary Blending Region Widths to the Parent-Child Cpl Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='N_BLEND_H' & !<-- The name of the Attribute - ,value=N_BLEND_H & !<-- The Attribute to be inserted - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='N_BLEND_V' & !<-- The name of the Attribute - ,value=N_BLEND_V & !<-- The Attribute to be inserted - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!-------------------------------- -!*** Transfer SW Corner of Nest -!-------------------------------- -! - nests_only: IF(ID_PARENTS_IN(MY_DOMAIN_ID)>0)THEN !<-- If so, this domain is a nest. -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract SW Corner of Nest from DOMAIN Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='I_PAR_STA' & !<-- The name of the Attribute - ,value=I_PAR_STA & !<-- The Attribute to be retrieved - ,rc =RC) -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='J_PAR_STA' & !<-- The name of the Attribute - ,value=J_PAR_STA & !<-- The Attribute to be retrieved - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add SW Corner of Nest to the Parent-Child Cpl Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='I_PAR_STA' & !<-- The name of the Attribute - ,value=I_PAR_STA & !<-- The Attribute to be inserted - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='J_PAR_STA' & !<-- The name of the Attribute - ,value=J_PAR_STA & !<-- The Attribute to be inserted - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------- -!*** Transfer the domain's storm center. -!----------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Storm Center of Nest from DOMAIN Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='Storm Center' & !<-- The name of the Attribute - ,valueList=STORM_CENTER & !<-- The Attribute to be retrieved - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Storm Center of Nest to the Parent-Child Cpl Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='Storm Center' & !<-- The name of the Attribute - ,itemCount=2 & !<-- The # of words in the Attribute - ,valueList=STORM_CENTER & !<-- The Attribute to be inserted - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------- -!*** Transfer the domain's last move timestep. -!----------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Last Move Timestep from DOMAIN Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='LAST_STEP_MOVED' & !<-- The name of the Attribute - ,value=LAST_STEP_MOVED & !<-- The Attribute to be retrieved - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Next Move Timestep to the Parent-Child Cpl Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='LAST_STEP_MOVED' & !<-- The name of the Attribute - ,value=LAST_STEP_MOVED & !<-- The Attribute to be inserted - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------- -!*** Transfer the domain's next move timestep. -!----------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Next Move Timestep from DOMAIN Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='NEXT_MOVE_TIMESTEP' & !<-- The name of the Attribute - ,value=cc%NEXT_MOVE_TIMESTEP & !<-- The Attribute to be retrieved - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Next Move Timestep to the Parent-Child Cpl Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='NEXT_MOVE_TIMESTEP' & !<-- The name of the Attribute - ,value=cc%NEXT_MOVE_TIMESTEP & !<-- The Attribute to be inserted - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Cpl Setup: Extract NTRACK storm flag from Domain exp state." -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='NTRACK' & !<-- The name of the Attribute - ,value=cc%NTRACK & !<-- The Attribute to be retrieved - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="P-C Cpl Setup: Insert NTRACK storm flag into P-C Cpl imp state." -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='NTRACK' & !<-- The name of the Attribute - ,value=cc%NTRACK & !<-- The Attribute to be inserted - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF nests_only -! -!--------------------------- -!*** Transfer restart flag -!--------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Restart Flag from DOMAIN Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='RESTART' & !<-- The name of the Attribute - ,value=RESTART & !<-- The Attribute to be retrieved - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Restart Flag to the Parent-Child Cpl Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='RESTART' & !<-- The name of the Attribute - ,value=RESTART & !<-- The Attribute to be inserted - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!------------------------------- -!*** Transfer Sfc Geopotential -!------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract FIS from Parent DOMAIN Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,itemName='FIS' & !<-- Extract FIS Field - ,field =HOLD_FIELD & !<-- Put the extracted Field here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert FIS into Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,(/HOLD_FIELD/) & !<-- The Field to be inserted - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!---------------------------------- -!*** Transfer geographic latitude -!---------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract GLAT from Parent DOMAIN Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,itemName='GLAT' & !<-- Extract GLAT Field - ,field =HOLD_FIELD & !<-- Put the extracted Field here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert GLAT into Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,(/HOLD_FIELD/) & !<-- The Field to be inserted - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------- -!*** Transfer geographic longitude -!----------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract GLON from Parent DOMAIN Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,itemName='GLON' & !<-- Extract GLON Field - ,field =HOLD_FIELD & !<-- Put the extracted Field here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert GLON into Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,(/HOLD_FIELD/) & !<-- The Field to be inserted - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!------------------------------------------------------- -!*** Transfer PT,PDTOP,PSGML1,SG1,SG2,SGML2,DSG2,PDSG1 -!------------------------------------------------------- -! - LMP1=LM+1 -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract PT from Parent DOMAIN Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='PT' & !<-- Extract PT - ,value=PT & !<-- Put the extracted value here - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='PT' & !<-- Insert PT - ,value=PT & !<-- Insert this value - ,rc =RC) -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='PDTOP' & !<-- Extract PDTOP - ,value=PDTOP & !<-- Put the extracted value here - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='PDTOP' & !<-- Insert PDTOP - ,value=PDTOP & !<-- Insert this value - ,rc =RC) -! - ALLOCATE(ARRAY_1D(1:LM)) -! - CALL ESMF_AttributeGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='PSGML1' & !<-- Extract PGMSL1 - ,itemCount=LM & !<-- # of words in data list - ,valueList=ARRAY_1D & !<-- Put extracted values here - ,rc =RC) -! - CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='PSGML1' & !<-- Insert PGMSL1 - ,itemCount=LM & !<-- # of words in data list - ,valueList=ARRAY_1D & !<-- Insert these values - ,rc =RC) -! - CALL ESMF_AttributeGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='SGML2' & !<-- Extract SGML2 - ,itemCount=LM & !<-- # of words in data list - ,valueList=ARRAY_1D & !<-- Put extracted values here - ,rc =RC) -! - CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='SGML2' & !<-- Insert SGML2 - ,itemCount=LM & !<-- # of words in data list - ,valueList=ARRAY_1D & !<-- Insert these values - ,rc =RC) -! - CALL ESMF_AttributeGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='DSG2' & !<-- Extract DSG2 - ,itemCount=LM & !<-- # of words in data list - ,valueList=ARRAY_1D & !<-- Put extracted values here - ,rc =RC) -! - CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='DSG2' & !<-- Insert DSG2 - ,itemCount=LM & !<-- # of words in data list - ,valueList=ARRAY_1D & !<-- Insert these values - ,rc =RC) -! - CALL ESMF_AttributeGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='PDSG1' & !<-- Extract PDSG1 - ,itemCount=LM & !<-- # of words in data list - ,valueList=ARRAY_1D & !<-- Put extracted values here - ,rc =RC) -! - CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='PDSG1' & !<-- Insert PDSG1 - ,itemCount=LM & !<-- # of words in data list - ,valueList=ARRAY_1D & !<-- Insert these values - ,rc =RC) -! - DEALLOCATE(ARRAY_1D) -! - ALLOCATE(ARRAY_1D(1:LMP1)) -! - CALL ESMF_AttributeGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='SG1' & !<-- Extract SG1 - ,itemCount=LMP1 & !<-- # of words in data list - ,valueList=ARRAY_1D & !<-- Put extracted values here - ,rc =RC) -! - CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='SG1' & !<-- Insert SG1 - ,itemCount=LMP1 & !<-- # of words in data list - ,valueList=ARRAY_1D & !<-- Insert these values - ,rc =RC) -! - CALL ESMF_AttributeGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='SG2' & !<-- Extract SG2 - ,itemCount=LMP1 & !<-- # of words in data list - ,valueList=ARRAY_1D & !<-- Put extracted values here - ,rc =RC) -! - CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='SG2' & !<-- Insert SG2 - ,itemCount=LMP1 & !<-- # of words in data list - ,valueList=ARRAY_1D & !<-- Insert these values - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DEALLOCATE(ARRAY_1D) -! -!------------------------ -!*** Transfer DY and DX -!------------------------ -! - NKOUNT=JDE-JDS+1 - ALLOCATE(ARRAY_1D(1:NKOUNT)) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract DY,DX from Parent DOMAIN Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='DYH' & !<-- Extract DYH - ,value=DYH & !<-- Put the extracted value here - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='DYH' & !<-- Insert DYH - ,value=DYH & !<-- Insert this value - ,rc =RC) -! - CALL ESMF_AttributeGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='DXH' & !<-- Extract DXH - ,itemCount=NKOUNT & !<-- # of words in data list - ,valueList=ARRAY_1D & !<-- Put extracted values here - ,rc =RC) -! - CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='DXH' & !<-- Insert DXH - ,itemCount=NKOUNT & !<-- # of words in data list - ,valueList=ARRAY_1D & !<-- Insert these values - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DEALLOCATE(ARRAY_1D) -! -!------------------------ -!*** Transfer DPHD,JM -!------------------------ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract DPHD,JM from DOMAIN Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='DPHD' & !<-- Extract latitude grid increment (deg) - ,value=DPHD & !<-- Put the extracted value here - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='DPHD' & !<-- Insert latitude grid increment (deg) - ,value=DPHD & !<-- Insert this value - ,rc =RC) -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='DLMD' & !<-- Extract longitude grid increment (deg) - ,value=DLMD & !<-- Put the extracted value here - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='DLMD' & !<-- Insert longitude grid increment (deg) - ,value=DLMD & !<-- Insert this value - ,rc =RC) -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='JM' & !<-- Extract DYH - ,value=JM & !<-- Put the extracted value here - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='JM' & !<-- Insert DYH - ,value=JM & !<-- Insert this value - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - parents_only: IF(I_AM_A_PARENT)THEN -! -!----------------------------------------------------------------------- -! -!---------------------------------------------- -!*** Ratio of Domain's Timestep to Children's -!---------------------------------------------- -! - ALLOCATE(PARENT_CHILD_RATIO(1:NUM_CHILDREN)) -! - DO N=1,NUM_CHILDREN - PARENT_CHILD_RATIO(N)=NINT(DT(MY_DOMAIN_ID)/DT(CHILD_ID(N))) - ENDDO -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Parent-Child DT Ratios to the Parent-Child Cpl Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='Parent-Child Time Ratio' & !<-- Name of Attribute - ,itemCount=NUM_CHILDREN & !<-- Length of inserted array - ,valueList=PARENT_CHILD_RATIO & !<-- The communicator to my parent - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DEALLOCATE(PARENT_CHILD_RATIO) -! -!------------------------------- -!*** The Children's Domain IDs -!------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Domain IDs of Children to Parent-Child Cpl Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='CHILD_IDs' & !<-- Name of Attribute - ,itemCount=NUM_CHILDREN & !<-- Length of inserted array - ,valueList=CHILD_ID & !<-- The children's IDs of this ATM Component - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF parents_only -! -!----------------------------------------------------------------------- -!*** Now transfer the parent's prognostic arrays from the DOMAIN export -!*** state to the Parent-Child coupler import state that will be -!*** required for the children's boundary data. -!----------------------------------------------------------------------- -! -!----------------- -!*** Transfer PD -!----------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract PD Field from Parent DOMAIN Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,itemName='PD' & !<-- Extract PD Field - ,field =HOLD_FIELD & !<-- Put the extracted Field here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert PD into Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,(/HOLD_FIELD/) & !<-- The Field to be inserted - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!---------------------------------------- -!*** Transfer Layer Interface Pressures -!---------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract PINT Field from Parent DOMAIN Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,itemName='PINT' & !<-- Extract PINT Field - ,field =HOLD_FIELD & !<-- Put the extracted Field here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert PINT into Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,(/HOLD_FIELD/) & !<-- The Field to be inserted - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!-------------------------- -!*** Transfer Temperature -!-------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract T Field from Parent DOMAIN Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,itemName='T' & !<-- Extract T Field - ,field =HOLD_FIELD & !<-- Put the extracted Field here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert T into Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,(/HOLD_FIELD/) & !<-- The Field to be inserted - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!--------------------- -!*** Transfer U Wind -!--------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract U Wind Field from Parent DOMAIN Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,itemName='U' & !<-- Extract U Field - ,field =HOLD_FIELD & !<-- Put the extracted Field here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert U into Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,(/HOLD_FIELD/) & !<-- The Field to be inserted - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!--------------------- -!*** Transfer V Wind -!--------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract V Wind Field from Parent DOMAIN Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,itemName='V' & !<-- Extract V Field - ,field =HOLD_FIELD & !<-- Put the extracted Field here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert V into Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,(/HOLD_FIELD/) & !<-- The Field to be inserted - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!------------------------- -!*** Transfer Midlayer Z -!------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Midlyaer Z Field from Parent DOMAIN Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,itemName='Z' & !<-- Extract midlayer Z Field - ,field =HOLD_FIELD & !<-- Put the extracted Field here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert Midlayer Z into Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,(/HOLD_FIELD/) & !<-- The Field to be inserted - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!---------------------------- -!*** Transfer TRACERS Field -!---------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Tracers Field from Parent DOMAIN Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,itemName='TRACERS' & !<-- Extract TRACERS Field - ,field =HOLD_FIELD & !<-- Put the extracted Field here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert Tracers into Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,(/HOLD_FIELD/) & !<-- The Field to be inserted - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------- -!*** Transfer Sea Mask Field -!----------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract SM Field from Parent DOMAIN Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,itemName='SM' & !<-- Extract Seas Mask Field - ,field =HOLD_FIELD & !<-- Put the extracted Field here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert SM into Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,(/HOLD_FIELD/) & !<-- The Field to be inserted - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!--------------------- -!*** Transfer INDX_Q -!--------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract INDX_Q from Parent DOMAIN Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='INDX_Q' & !<-- Name of Attribute to extract - ,value=INDX_Q & !<-- Put the extracted Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert INDX_Q into Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='INDX_Q' & !<-- The name of the Attribute to insert - ,value=INDX_Q & !<-- The Attribute to be inserted - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!---------------------- -!*** Transfer INDX_CW -!---------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract INDX_CW from Parent DOMAIN Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='INDX_CW' & !<-- Name of Attribute to extract - ,value=INDX_CW & !<-- Put the extracted Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert INDX_CW into Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='INDX_CW' & !<-- The name of the Attribute to insert - ,value=INDX_CW & !<-- The Attribute to be inserted - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!------------------------------------ -!*** Transfer 10-m U wind component -!------------------------------------ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract U10 Field from Parent DOMAIN Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,itemName='U10' & !<-- Extract U10 Field - ,field =HOLD_FIELD & !<-- Put the extracted Field here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert U10 into Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,(/HOLD_FIELD/) & !<-- The Field to be inserted - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!------------------------------------ -!*** Transfer 10-m V wind component -!------------------------------------ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract V10 Field from Parent DOMAIN Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,itemName='V10' & !<-- Extract V10 Field - ,field =HOLD_FIELD & !<-- Put the extracted Field here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert V10 into Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,(/HOLD_FIELD/) & !<-- The Field to be inserted - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** All parent tasks need to know the local subdomain limits of each -!*** task on their children. -!----------------------------------------------------------------------- -! - LIMITS(1)=ITS - LIMITS(2)=ITE - LIMITS(3)=JTS - LIMITS(4)=JTE -! -!----------------------------------------------------------------------- -!*** Child tasks send their subdomain limits to parent task 0. -!----------------------------------------------------------------------- -! - IF(COMM_TO_MY_PARENT/=-999)THEN !<-- Select child tasks - CALL MPI_COMM_RANK(COMM_TO_MY_PARENT,MYPE,IERR) !<-- Obtain my local rank in parent-child intracomm - NTAG=MYPE+9999 -! - CALL MPI_SEND(LIMITS & !<-- Child task sends its subdomain limits - ,4 & !<-- # of indices sent - ,MPI_INTEGER & !<-- Indices are integers - ,0 & !<-- Indices sent to parent fcst task 0 - ,NTAG & !<-- Unique MPI tag - ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator between parent and child - ,IERR) - ENDIF -! -!----------------------------------------------------------------------- -!*** Rank 0 parent tasks recv their children's tasks' subdomain limits -!*** then send the children the integration limits of every fcst task -!*** on the parent domain. -!----------------------------------------------------------------------- -! - ID=MY_DOMAIN_ID -! - IF(I_AM_A_PARENT)THEN -! - ALLOCATE(CTASK_LIMITS(ID)%CHILDREN(1:NUM_CHILDREN)) -! - ALLOCATE(HANDLE_CHILD_LIMITS(ID)%CHILDREN(1:NUM_CHILDREN)) -! - DO N=1,NUM_CHILDREN - ID_CHILD=CHILD_ID(N) -! - ALLOCATE(CTASK_LIMITS(ID)%CHILDREN(N)%DATA(1:4,1:FTASKS_DOMAIN(ID_CHILD)),stat=IERR) !<-- Pointer to hold each child task's - ! subdomain limits - IF(IERR/=0)WRITE(0,*)' Failed to allocate CTASK_LIMITS' -! - CALL MPI_COMM_RANK(COMM_TO_MY_CHILDREN(N),MYPE,IERR) !<-- Obtain the ranks of parent tasks -! - HANDLE_CHILD_LIMITS(ID)%CHILDREN(N)%DATA=>NULL() -! - IF(MYPE==0)THEN -! - ALLOCATE(HANDLE_CHILD_LIMITS(ID)%CHILDREN(N)%DATA(1:FTASKS_DOMAIN(ID_CHILD))) -! - DO NN=1,FTASKS_DOMAIN(ID_CHILD) - CHILDTASK=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NN-1) !<-- Local rank of child task NN in p-c intracomm - NTAG=CHILDTASK+9999 - CALL MPI_IRECV(CTASK_LIMITS(ID)%CHILDREN(N)%DATA(1,NN) & !<-- Subdomain limits of fcst task NN on child N - ,4 & !<-- # of index limits received - ,MPI_INTEGER & !<-- Indices are integers - ,CHILDTASK & !<-- Local rank of child task NN (the sender) in p-c intracomm - ,NTAG & !<-- Unique MPI tag - ,COMM_TO_MY_CHILDREN(N) & !<-- MPI communicator between parent and child N - ,HANDLE_CHILD_LIMITS(ID)%CHILDREN(N)%DATA(NN) & - ,IERR) - ENDDO -! - ENDIF -! - ENDDO -! -!----------------------------------------------------------------------- -!*** Create then transfer the object holding the domain's children's -!*** next move timesteps if this is a restarted run. -!----------------------------------------------------------------------- -! - ALLOCATE(cc%NTIMESTEP_CHILD_MOVES(1:NUM_DOMAINS_MAX),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%NTIMESTEP_CHILD_MOVES stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - NTIMESTEP_CHILD_MOVES=>cc%NTIMESTEP_CHILD_MOVES -! - DO N=1,NUM_DOMAINS_MAX - NTIMESTEP_CHILD_MOVES(N)=-999 - ENDDO -! - IF(RESTART)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Next Move Timestep of Children from DOMAIN Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='NEXT_TIMESTEP_CHILD_MOVES' & !<-- The name of the Attribute - ,valueList=NTIMESTEP_CHILD_MOVES & !<-- The Attribute to be retrieved - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Next Move Timestep of Children to the Parent-Child Cpl Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state =IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='NEXT_TIMESTEP_CHILD_MOVES' & !<-- The name of the Attribute - ,itemCount=NUM_DOMAINS_MAX & !<-- The number of items - ,valueList=cc%NTIMESTEP_CHILD_MOVES & !<-- The Attribute to be inserted - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** The Parent-Child coupler needs the pointers to the Solver -!*** internal state variables that are updated on the child -!*** boundaries by the parents. The Bundle holding those pointers -!*** is in the Domain component's export state. Transfer the -!*** Bundle to the P-C coupler's import state. -!----------------------------------------------------------------------- -! -! - get_bc_bundle: IF(I_AM_A_FCST_TASK)THEN - BUNDLE_NESTBC=>cc%BUNDLE_NESTBC -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Bundle of Nest BC Vbls from Domain Exp State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,itemName ='Bundle_nestbc' & !<-- Bundle of Solver internal state pointers for nest BC vbls - ,fieldbundle=BUNDLE_NESTBC & !<-- Put the extracted Bundle here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert Bundle of Nest BC Vbls into P-C Coupler Imp State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,(/BUNDLE_NESTBC/) & !<-- The Bundle of Solver int state pointers for nest BC vbls - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** The Parent-Child coupler also needs to know the # of H-pt and -!*** V-pt boundary variables. Transfer those values. -!----------------------------------------------------------------------- -! - NVARS_BC_2D_H=>cc%NVARS_BC_2D_H - NVARS_BC_3D_H=>cc%NVARS_BC_3D_H - NVARS_BC_4D_H=>cc%NVARS_BC_4D_H -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract # of H-pt Nest Bndry Vrbls from Domain Exp State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='NVARS_BC_2D_H' & !<-- Name of Attribute to extract - ,value=NVARS_BC_2D_H & !<-- # of 2-D H-pt boundary variables - ,rc =RC) -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='NVARS_BC_3D_H' & !<-- Name of Attribute to extract - ,value=NVARS_BC_3D_H & !<-- # of 3-D H-pt boundary variables - ,rc =RC) -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='NVARS_BC_4D_H' & !<-- Name of Attribute to extract - ,value=NVARS_BC_4D_H & !<-- # of 4-D H-pt boundary variables - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NVARS_BC_2D_V=>cc%NVARS_BC_2D_V - NVARS_BC_3D_V=>cc%NVARS_BC_3D_V -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract # of V-pt Nest Bndry Vrbls from Domain Exp State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='NVARS_BC_2D_V' & !<-- Name of Attribute to extract - ,value=NVARS_BC_2D_V & !<-- # of 2-D V-pt boundary variables - ,rc =RC) -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='NVARS_BC_3D_V' & !<-- Name of Attribute to extract - ,value=NVARS_BC_3D_V & !<-- # of 3-D V-pt boundary variables - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert # of H-pt Nest Bndry Vrbls into P-C Imp State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='NVARS_BC_2D_H' & !<-- The name of the Attribute to insert - ,value=NVARS_BC_2D_H & !<-- # of 2-D H-pt boundary variables - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='NVARS_BC_3D_H' & !<-- The name of the Attribute to insert - ,value=NVARS_BC_3D_H & !<-- # of 3-D H-pt boundary variables - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='NVARS_BC_4D_H' & !<-- The name of the Attribute to insert - ,value=NVARS_BC_4D_H & !<-- # of 4-D H-pt boundary variables - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert # of V-pt Nest Bndry Vrbls into P-C Imp State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='NVARS_BC_2D_V' & !<-- The name of the Attribute to insert - ,value=NVARS_BC_2D_V & !<-- # of 2-D H-pt boundary variables - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='NVARS_BC_3D_V' & !<-- The name of the Attribute to insert - ,value=NVARS_BC_3D_V & !<-- # of 3-D H-pt boundary variables - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** How many total model layers are involved with all H-pt and V-pt -!*** boundary variables? Tansfer that information to the Parent- -!*** Child coupler for use in allocating working objects. -!----------------------------------------------------------------------- -! - NLEV_H=>cc%NLEV_H - NLEV_V=>cc%NLEV_V -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract # of Model Lyrs in all Nest Bndry Vrbls" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='NLEV_H' & !<-- Name of Attribute to extract - ,value=NLEV_H & !<-- # of model layers for all H-pt BC variables - ,rc =RC) -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='NLEV_V' & !<-- Name of Attribute to extract - ,value=NLEV_V & !<-- # of model layers for all V-pt BC variables - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set # of Model Lyrs in all Nest Bndry Vrbls" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The P-C coupler import state - ,name ='NLEV_H' & !<-- Name of Attribute to extract - ,value=NLEV_H & !<-- # of model layers for all H-pt BC variables - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The P-C coupler import state - ,name ='NLEV_V' & !<-- Name of Attribute to extract - ,value=NLEV_V & !<-- # of model layers for all V-pt BC variables - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF get_bc_bundle -! -!----------------------------------------------------------------------- -!*** If there are moving nests then their parents need the Bundles -!*** of 2-D and 3-D variables in the Solver internal state that -!*** need to be updated after the nests move. The Bundles are -!*** unloaded from the DOMAIN export state and loaded into the -!*** Parent-Child coupler import state. If there are no moving -!*** nests then the Bundles are empty. -!----------------------------------------------------------------------- -! - MOVE_BUNDLE_H=>cc%MOVE_BUNDLE_H - MOVE_BUNDLE_V=>cc%MOVE_BUNDLE_V -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Bundles for Moving Nests from Domain Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,itemName ='Move_Bundle H' & !<-- Name of Bundle of internal state H arrays - ,fieldbundle=MOVE_BUNDLE_H & !<-- Put the extracted Bundle here - ,rc =RC) -! - CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,itemName ='Move_Bundle V' & !<-- Name of Bundle of internal state V arrays - ,fieldbundle=MOVE_BUNDLE_V & !<-- Put the extracted Bundle here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert Bundle for Moving Nests into P-C Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,(/MOVE_BUNDLE_H/) & !<-- The Bundle of internal state H arrays to update - ,rc =RC) -! - CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,(/MOVE_BUNDLE_V/) & !<-- The Bundle of internal state V arrays to update - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** If 2-way nesting is being used then an ESMF Bundle is used -!*** to hold pointers to the Solver component's internal state -!*** variables which are interpolated by the child to its parent's -!*** grid then sent to the parent. Unload the 2-way Bundle from -!*** the Domain component's export state and load it into the -!*** parent-Child coupler's import state. If 2-way nesting has -!*** not been selected by the user then the 2-way Bundle is -!*** still present but is empty. -!----------------------------------------------------------------------- -! - BUNDLE_2WAY=>cc%BUNDLE_2WAY -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract 2-way Bundle from Domain Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,itemName ='Bundle_2way' & !<-- Bundle of Solver internal state pointers for 2-way exch - ,fieldbundle=BUNDLE_2WAY & !<-- Put the extracted Bundle here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert 2-way Bundle into P-C Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateAddReplace(IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,(/BUNDLE_2WAY/) & !<-- The Bundle of Solver internal state pointers for 2-way exch - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Transfer the flags indicating whether a domain and any of its -!*** children are active in the digital filtering. -!----------------------------------------------------------------------- -! - IF(I_AM_A_FCST_TASK)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract DFI flag for this domain" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='I Am Active' & !<-- Name of Attribute to extract - ,value=I_AM_ACTIVE & !<-- Does this domain participate in digital filtering? - ,rc =RC) -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The P-C coupler import state - ,name ='I Am Active' & !<-- Name of Attribute to set. - ,value=I_AM_ACTIVE & !<-- Does this domain participate in digital filtering? - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(NUM_CHILDREN>0)THEN - ALLOCATE(CHILD_ACTIVE(1:NUM_CHILDREN)) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract child DFI flags from Domain export state" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=EXP_STATE_DOMAIN & !<-- The DOMAIN export state - ,name ='Child Active' & !<-- The name of the Attribute -! ,itemCount=NUM_CHILDREN & !<-- # of words in data list - ,valueList=CHILD_ACTIVE & !<-- Put extracted values here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add child DFI flags to the Parent-Child Cpl Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=IMP_STATE_CPL_NEST & !<-- The Parent-Child Coupler's import state - ,name ='Child Active' & !<-- The name of the Attribute - ,itemCount=NUM_CHILDREN & !<-- # of words in data list - ,valueList=CHILD_ACTIVE & !<-- Put added values here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_NESTSET) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DEALLOCATE(CHILD_ACTIVE) - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PARENT_CHILD_COUPLER_SETUP -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE POINT_TO_COMPOSITE(MY_DOMAIN_ID) -! -!----------------------------------------------------------------------- -!*** Tasks point into the Parent-Child coupler's composite object -!*** in order to access coupler variables valid for the current -!*** domain. This is an internal subroutine of -!*** PARENT_CHILD_CPL_INITIALIZE. -!----------------------------------------------------------------------- -! - INTEGER(kind=KINT),INTENT(IN) :: MY_DOMAIN_ID !<-- The current domain's ID -! -!----------------------------------------------------------------------- -! - TYPE(COMPOSITE),POINTER :: CC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - CC=>CPL_COMPOSITE(MY_DOMAIN_ID) -! -!----------------------------------------------------------------------- -! -! - NCYCLE_CHILD =>cc%NCYCLE_CHILD - NCYCLE_PARENT=>cc%NCYCLE_PARENT -! - I_AM_A_FCST_TASK=>cc%I_AM_A_FCST_TASK -! - COMM_TO_MY_PARENT =>cc%COMM_TO_MY_PARENT - I_CENTER_CURRENT =>cc%I_CENTER_CURRENT - I_SHIFT_CHILD =>cc%I_SHIFT_CHILD - J_SHIFT_CHILD =>cc%J_SHIFT_CHILD - I_SW_PARENT_CURRENT =>cc%I_SW_PARENT_CURRENT - I_SW_PARENT_NEW =>cc%I_SW_PARENT_NEW - J_CENTER_CURRENT =>cc%J_CENTER_CURRENT - J_SW_PARENT_CURRENT =>cc%J_SW_PARENT_CURRENT - J_SW_PARENT_NEW =>cc%J_SW_PARENT_NEW - ITS =>cc%ITS - ITE =>cc%ITE - JTS =>cc%JTS - JTE =>cc%JTE - JM =>cc%JM - LM =>cc%LM - IMS =>cc%IMS - IME =>cc%IME - JMS =>cc%JMS - JME =>cc%JME - IDS =>cc%IDS - IDE =>cc%IDE - JDS =>cc%JDS - JDE =>cc%JDE - IM_1 =>cc%IM_1 - JM_1 =>cc%JM_1 - INPES =>cc%INPES - JNPES =>cc%JNPES - INPES_PARENT =>cc%INPES_PARENT - JNPES_PARENT =>cc%JNPES_PARENT - KOUNT_2WAY_CHILDREN =>cc%KOUNT_2WAY_CHILDREN - LAST_STEP_MOVED =>cc%LAST_STEP_MOVED - MAX_SHIFT =>cc%MAX_SHIFT - MYPE =>cc%MYPE - N_BLEND_H =>cc%N_BLEND_H - N_BLEND_V =>cc%N_BLEND_V - N_STENCIL_H =>cc%N_STENCIL_H - N_STENCIL_V =>cc%N_STENCIL_V - N_STENCIL_SFC_H =>cc%N_STENCIL_SFC_H - N_STENCIL_SFC_V =>cc%N_STENCIL_SFC_V - NLEV_H =>cc%NLEV_H - NLEV_V =>cc%NLEV_V - NHALO =>cc%NHALO - NPHS =>cc%NPHS - NTASKS_UPDATE_PARENT =>cc%NTASKS_UPDATE_PARENT - NTIMESTEP_CHECK =>cc%NTIMESTEP_CHECK - NTIMESTEP_FINAL =>cc%NTIMESTEP_FINAL - NTOT_SFC =>cc%NTOT_SFC - NTIMESTEPS_RESTART =>cc%NTIMESTEPS_RESTART - NTRACK =>cc%NTRACK - NUM_CHILDREN =>cc%NUM_CHILDREN - NUM_2WAY_CHILDREN =>cc%NUM_2WAY_CHILDREN - NUM_MOVING_CHILDREN =>cc%NUM_MOVING_CHILDREN - NUM_PES_FCST =>cc%NUM_PES_FCST - NUM_FCST_TASKS_PARENT=>cc%NUM_FCST_TASKS_PARENT - NUM_TASKS_PARENT =>cc%NUM_TASKS_PARENT - NEXT_MOVE_TIMESTEP =>cc%NEXT_MOVE_TIMESTEP - NUM_LEVELS_MOVE_3D_H =>cc%NUM_LEVELS_MOVE_3D_H - NUM_LEVELS_MOVE_3D_V =>cc%NUM_LEVELS_MOVE_3D_V - NUM_SPACE_RATIOS_MVG =>cc%NUM_SPACE_RATIOS_MVG - NVARS_BC_2D_H =>cc%NVARS_BC_2D_H - NVARS_BC_3D_H =>cc%NVARS_BC_3D_H - NVARS_BC_4D_H =>cc%NVARS_BC_4D_H - NVARS_BC_2D_V =>cc%NVARS_BC_2D_V - SPACE_RATIO_MY_PARENT=>cc%SPACE_RATIO_MY_PARENT - TIME_RATIO_MY_PARENT =>cc%TIME_RATIO_MY_PARENT -! - NTIMESTEP_WAIT_PARENT =>cc%NTIMESTEP_WAIT_PARENT - NTIMESTEP_WAIT_FORCED_PARENT=>cc%NTIMESTEP_WAIT_FORCED_PARENT - PARENT_WANTS_TO_MOVE =>cc%PARENT_WANTS_TO_MOVE -! - LBND_4D=>cc%LBND_4D - UBND_4D=>cc%UBND_4D -! - LOCAL_ISTART=>cc%LOCAL_ISTART - LOCAL_IEND =>cc%LOCAL_IEND - LOCAL_JSTART=>cc%LOCAL_JSTART - LOCAL_JEND =>cc%LOCAL_JEND -! - MY_DOMAIN_LIMITS =>cc%MY_DOMAIN_LIMITS - MY_FORCED_SHIFT =>cc%MY_FORCED_SHIFT - MY_NEB =>cc%MY_NEB - PARENT_DOMAIN_LIMITS=>cc%PARENT_DOMAIN_LIMITS - PARENT_SHIFT =>cc%PARENT_SHIFT - STORM_CENTER =>cc%STORM_CENTER -! - PARENT_CHILD_SPACE_RATIO =>cc%PARENT_CHILD_SPACE_RATIO - TIME_RATIO_MY_CHILDREN =>cc%TIME_RATIO_MY_CHILDREN - IM_CHILD =>cc%IM_CHILD - JM_CHILD =>cc%JM_CHILD - I_PARENT_SW =>cc%I_PARENT_SW - J_PARENT_SW =>cc%J_PARENT_SW - ITE_PARENT =>cc%ITE_PARENT - ITS_PARENT =>cc%ITS_PARENT - JTE_PARENT =>cc%JTE_PARENT - JTS_PARENT =>cc%JTS_PARENT - LINK_MRANK_RATIO =>cc%LINK_MRANK_RATIO - LIST_OF_RATIOS =>cc%LIST_OF_RATIOS - M_NEST_RATIO =>cc%M_NEST_RATIO - N_STENCIL_H_CHILD =>cc%N_STENCIL_H_CHILD - N_STENCIL_V_CHILD =>cc%N_STENCIL_V_CHILD - N_STENCIL_SFC_H_CHILD =>cc%N_STENCIL_SFC_H_CHILD - N_STENCIL_SFC_V_CHILD =>cc%N_STENCIL_SFC_V_CHILD - N_BLEND_H_CHILD =>cc%N_BLEND_H_CHILD - N_BLEND_V_CHILD =>cc%N_BLEND_V_CHILD - CHILD_2WAY_WGT =>cc%CHILD_2WAY_WGT - NTASKS_UPDATE_CHILD =>cc%NTASKS_UPDATE_CHILD - NSTEP_CHILD_RECV =>cc%NSTEP_CHILD_RECV - INC_FIX =>cc%INC_FIX - COMM_TO_MY_CHILDREN =>cc%COMM_TO_MY_CHILDREN - ID_PARENTS =>cc%ID_PARENTS - ID_PARENT_UPDATE_TASKS =>cc%ID_PARENT_UPDATE_TASKS - MY_CHILDREN_ID =>cc%MY_CHILDREN_ID - RANK_2WAY_CHILD =>cc%RANK_2WAY_CHILD - RANK_MOVING_CHILD =>cc%RANK_MOVING_CHILD - FTASKS_DOMAIN =>cc%FTASKS_DOMAIN - NTASKS_DOMAIN =>cc%NTASKS_DOMAIN - NPTS_UPDATE_ON_PARENT_TASKS=>cc%NPTS_UPDATE_ON_PARENT_TASKS - HANDLE_BC_UPDATE =>cc%HANDLE_BC_UPDATE - HANDLE_MOVE_FLAG =>cc%HANDLE_MOVE_FLAG - HANDLE_PARENT_SHIFT =>cc%HANDLE_PARENT_SHIFT - HANDLE_SEND_2WAY_DATA =>cc%HANDLE_SEND_2WAY_DATA - HANDLE_SEND_2WAY_SFC =>cc%HANDLE_SEND_2WAY_SFC - HANDLE_SEND_2WAY_SIGNAL =>cc%HANDLE_SEND_2WAY_SIGNAL - HANDLE_SEND_ALLCLEAR =>cc%HANDLE_SEND_ALLCLEAR - HANDLE_TIMESTEP =>cc%HANDLE_TIMESTEP - NTIMESTEP_CHILD_MOVES =>cc%NTIMESTEP_CHILD_MOVES - SHIFT_INFO_MINE =>cc%SHIFT_INFO_MINE -! - SHIFT_INFO_CHILDREN=>cc%SHIFT_INFO_CHILDREN -! - NUM_TASKS_SEND_H_S=>cc%NUM_TASKS_SEND_H_S - NUM_TASKS_SEND_H_N=>cc%NUM_TASKS_SEND_H_N - NUM_TASKS_SEND_H_W=>cc%NUM_TASKS_SEND_H_W - NUM_TASKS_SEND_H_E=>cc%NUM_TASKS_SEND_H_E - NUM_TASKS_SEND_V_S=>cc%NUM_TASKS_SEND_V_S - NUM_TASKS_SEND_V_N=>cc%NUM_TASKS_SEND_V_N - NUM_TASKS_SEND_V_W=>cc%NUM_TASKS_SEND_V_W - NUM_TASKS_SEND_V_E=>cc%NUM_TASKS_SEND_V_E -! - CENTERS_DISTANCE=>cc%CENTERS_DISTANCE - DLM =>cc%DLM - DPH =>cc%DPH - DYH =>cc%DYH - PDTOP =>cc%PDTOP - PT =>cc%PT - SB_1 =>cc%SB_1 - WB_1 =>cc%WB_1 - TPH0_1 =>cc%TPH0_1 - TLM0_1 =>cc%TLM0_1 - RECIP_DPH_1 =>cc%RECIP_DPH_1 - RECIP_DLM_1 =>cc%RECIP_DLM_1 - RECIP_PARENT_SPACE_RATIO=>cc%RECIP_PARENT_SPACE_RATIO -! - DT_DOMAIN=>cc%DT_DOMAIN - DXH =>cc%DXH - DSG2 =>cc%DSG2 - PDSG1 =>cc%PDSG1 - PSGML1 =>cc%PSGML1 - SG1 =>cc%SG1 - SG2 =>cc%SG2 - SGML2 =>cc%SGML2 -! - CHILD_PARENT_SPACE_RATIO=>cc%CHILD_PARENT_SPACE_RATIO -! - BOUND_1D_SOUTH_H=>cc%BOUND_1D_SOUTH_H - BOUND_1D_SOUTH_V=>cc%BOUND_1D_SOUTH_V - BOUND_1D_NORTH_H=>cc%BOUND_1D_NORTH_H - BOUND_1D_NORTH_V=>cc%BOUND_1D_NORTH_V - BOUND_1D_WEST_H =>cc%BOUND_1D_WEST_H - BOUND_1D_WEST_V =>cc%BOUND_1D_WEST_V - BOUND_1D_EAST_H =>cc%BOUND_1D_EAST_H - BOUND_1D_EAST_V =>cc%BOUND_1D_EAST_V -! - FIS =>cc%FIS - FIS_CHILD_ON_PARENT=>cc%FIS_CHILD_ON_PARENT - GLAT =>cc%GLAT - GLON =>cc%GLON - PD =>cc%PD - SM =>cc%PD - U10 =>cc%U10 - V10 =>cc%V10 -! - PDB_S=>cc%PDB_S - PDB_N=>cc%PDB_N - PDB_W=>cc%PDB_W - PDB_E=>cc%PDB_E -! - CW =>cc%CW - PINT=>cc%PINT - Q =>cc%Q - T =>cc%T - U =>cc%U - V =>cc%V - Z =>cc%Z -! - TRACERS=>cc%TRACERS -! - STATIC_OR_MOVING=>cc%STATIC_OR_MOVING -! - ALLCLEAR_SIGNAL_PRESENT =>cc%ALLCLEAR_SIGNAL_PRESENT - CALLED_CHILD_2WAY_BOOKKEEPING=>cc%CALLED_CHILD_2WAY_BOOKKEEPING - FIRST_CALL_RECV_2WAY =>cc%FIRST_CALL_RECV_2WAY - FIRST_CALL_RECV_BC =>cc%FIRST_CALL_RECV_BC - FORCED_PARENT_SHIFT =>cc%FORCED_PARENT_SHIFT - I_AM_ACTIVE =>cc%I_AM_ACTIVE - I_AM_LEAD_FCST_TASK =>cc%I_AM_LEAD_FCST_TASK - I_WANT_TO_MOVE =>cc%I_WANT_TO_MOVE - MOVE_FLAG_SENT =>cc%MOVE_FLAG_SENT - MY_DOMAIN_MOVES =>cc%MY_DOMAIN_MOVES - MY_PARENT_MOVES =>cc%MY_PARENT_MOVES -! - CALLED_PARENT_2WAY_BOOKKEEPING=>cc%CALLED_PARENT_2WAY_BOOKKEEPING - CHILD_ACTIVE =>cc%CHILD_ACTIVE - CHILD_FORCES_MY_SHIFT =>cc%CHILD_FORCES_MY_SHIFT - MOVE_FLAG =>cc%MOVE_FLAG - SEND_CHILD_DATA =>cc%SEND_CHILD_DATA - SIGNAL_2WAY_SEND_READY=>cc%SIGNAL_2WAY_SEND_READY - SKIP_2WAY_UPDATE =>cc%SKIP_2WAY_UPDATE -! - I_2WAY_UPDATE=>cc%I_2WAY_UPDATE - J_2WAY_UPDATE=>cc%J_2WAY_UPDATE -! - I_2WAY_H=>cc%I_2WAY_H - J_2WAY_H=>cc%J_2WAY_H - I_2WAY_V=>cc%I_2WAY_V - J_2WAY_V=>cc%J_2WAY_V -! - WORDS_BOUND_H_SOUTH =>cc%WORDS_BOUND_H_SOUTH - WORDS_BOUND_H_NORTH =>cc%WORDS_BOUND_H_NORTH - WORDS_BOUND_H_WEST =>cc%WORDS_BOUND_H_WEST - WORDS_BOUND_H_EAST =>cc%WORDS_BOUND_H_EAST -! - WORDS_BOUND_V_SOUTH=>cc%WORDS_BOUND_V_SOUTH - WORDS_BOUND_V_NORTH=>cc%WORDS_BOUND_V_NORTH - WORDS_BOUND_V_WEST =>cc%WORDS_BOUND_V_WEST - WORDS_BOUND_V_EAST =>cc%WORDS_BOUND_V_EAST -! - CHILD_SFC_ON_PARENT=>cc%CHILD_SFC_ON_PARENT - UPDATE_PARENT_2WAY=>cc%UPDATE_PARENT_2WAY -! - NEST_FIS_ON_PARENT =>cc%NEST_FIS_ON_PARENT - NEST_FIS_V_ON_PARENT=>cc%NEST_FIS_V_ON_PARENT -! - PD_B_SOUTH=>cc%PD_B_SOUTH - PD_B_NORTH=>cc%PD_B_NORTH - PD_B_WEST =>cc%PD_B_WEST - PD_B_EAST =>cc%PD_B_EAST -! - PD_B_SOUTH_V=>cc%PD_B_SOUTH_V - PD_B_NORTH_V=>cc%PD_B_NORTH_V - PD_B_WEST_V =>cc%PD_B_WEST_V - PD_B_EAST_V =>cc%PD_B_EAST_V -! - MY_BC_VARS_H_S=>cc%MY_BC_VARS_H_S - MY_BC_VARS_H_N=>cc%MY_BC_VARS_H_N - MY_BC_VARS_H_W=>cc%MY_BC_VARS_H_W - MY_BC_VARS_H_E=>cc%MY_BC_VARS_H_E - MY_BC_VARS_V_S=>cc%MY_BC_VARS_V_S - MY_BC_VARS_V_N=>cc%MY_BC_VARS_V_N - MY_BC_VARS_V_W=>cc%MY_BC_VARS_V_W - MY_BC_VARS_V_E=>cc%MY_BC_VARS_V_E -! - BND_VAR_H_SOUTH=>cc%BND_VAR_H_SOUTH - BND_VAR_H_NORTH=>cc%BND_VAR_H_NORTH - BND_VAR_H_WEST =>cc%BND_VAR_H_WEST - BND_VAR_H_EAST =>cc%BND_VAR_H_EAST - BND_VAR_V_SOUTH=>cc%BND_VAR_V_SOUTH - BND_VAR_V_NORTH=>cc%BND_VAR_V_NORTH - BND_VAR_V_WEST =>cc%BND_VAR_V_WEST - BND_VAR_V_EAST =>cc%BND_VAR_V_EAST -! - FIS_CHILD_SOUTH=>cc%FIS_CHILD_SOUTH - FIS_CHILD_NORTH=>cc%FIS_CHILD_NORTH - FIS_CHILD_WEST =>cc%FIS_CHILD_WEST - FIS_CHILD_EAST =>cc%FIS_CHILD_EAST -! - CHILD_BOUND_H_SOUTH=>cc%CHILD_BOUND_H_SOUTH - CHILD_BOUND_H_NORTH=>cc%CHILD_BOUND_H_NORTH - CHILD_BOUND_H_WEST =>cc%CHILD_BOUND_H_WEST - CHILD_BOUND_H_EAST =>cc%CHILD_BOUND_H_EAST - CHILD_BOUND_V_SOUTH=>cc%CHILD_BOUND_V_SOUTH - CHILD_BOUND_V_NORTH=>cc%CHILD_BOUND_V_NORTH - CHILD_BOUND_V_WEST =>cc%CHILD_BOUND_V_WEST - CHILD_BOUND_V_EAST =>cc%CHILD_BOUND_V_EAST -! - NEST_FIS_ON_PARENT_BNDS=>cc%NEST_FIS_ON_PARENT_BNDS -! - INDX_MAX_H=>cc%INDX_MAX_H - INDX_MAX_V=>cc%INDX_MAX_V - INDX_MIN_H=>cc%INDX_MIN_H - INDX_MIN_V=>cc%INDX_MIN_V -! - NUM_PARENT_TASKS_SENDING_H=>cc%NUM_PARENT_TASKS_SENDING_H - NUM_PARENT_TASKS_SENDING_V=>cc%NUM_PARENT_TASKS_SENDING_V -! - CHILDTASK_BNDRY_H_RANKS=>cc%CHILDTASK_BNDRY_H_RANKS - CHILDTASK_BNDRY_V_RANKS=>cc%CHILDTASK_BNDRY_V_RANKS -! - CHILDTASK_H_SAVE=>cc%CHILDTASK_H_SAVE - CHILDTASK_V_SAVE=>cc%CHILDTASK_V_SAVE -! - PARENT_4_INDICES_H=>cc%PARENT_4_INDICES_H - PARENT_4_INDICES_V=>cc%PARENT_4_INDICES_V -! - PARENT_4_WEIGHTS_H=>cc%PARENT_4_WEIGHTS_H - PARENT_4_WEIGHTS_V=>cc%PARENT_4_WEIGHTS_V -! - PARENT_TASK=>cc%PARENT_TASK -! - HANDLE_MOVE_DATA=>cc%HANDLE_MOVE_DATA -! - HANDLE_H_SOUTH=>cc%HANDLE_H_SOUTH - HANDLE_H_NORTH=>cc%HANDLE_H_NORTH - HANDLE_H_WEST =>cc%HANDLE_H_WEST - HANDLE_H_EAST =>cc%HANDLE_H_EAST - HANDLE_V_SOUTH=>cc%HANDLE_V_SOUTH - HANDLE_V_NORTH=>cc%HANDLE_V_NORTH - HANDLE_V_WEST =>cc%HANDLE_V_WEST - HANDLE_V_EAST =>cc%HANDLE_V_EAST -! - CF_PARENT=>cc%CF_PARENT - CF_MINE =>cc%CF_MINE - CF =>cc%CF -! - BUNDLE_2WAY =>cc%BUNDLE_2WAY - BUNDLE_NESTBC=>cc%BUNDLE_NESTBC - MOVE_BUNDLE_H=>cc%MOVE_BUNDLE_H - MOVE_BUNDLE_V=>cc%MOVE_BUNDLE_V -! - cpl1_prelim_tim =>cc%cpl1_prelim_tim - cpl1_south_h_tim=>cc%cpl1_south_h_tim - cpl1_south_v_tim=>cc%cpl1_south_v_tim - cpl1_north_h_tim=>cc%cpl1_north_h_tim - cpl1_north_v_tim=>cc%cpl1_north_v_tim - cpl1_west_h_tim =>cc%cpl1_west_h_tim - cpl1_west_v_tim =>cc%cpl1_west_v_tim - cpl1_east_h_tim =>cc%cpl1_east_h_tim - cpl1_east_v_tim =>cc%cpl1_east_v_tim - cpl1_recv_tim =>cc%cpl1_recv_tim - cpl1_south_h_recv_tim=>cc%cpl1_south_h_recv_tim - cpl1_south_h_undo_tim=>cc%cpl1_south_h_undo_tim - cpl1_south_h_exp_tim =>cc%cpl1_south_h_exp_tim - cpl1_south_v_recv_tim=>cc%cpl1_south_v_recv_tim - cpl1_south_v_undo_tim=>cc%cpl1_south_v_undo_tim - cpl1_south_v_exp_tim =>cc%cpl1_south_v_exp_tim - cpl2_comp_tim =>cc%cpl2_comp_tim - cpl2_send_tim =>cc%cpl2_send_tim - cpl2_wait_tim =>cc%cpl2_wait_tim - moving_nest_bookkeep_tim=>cc%moving_nest_bookkeep_tim - moving_nest_update_tim =>cc%moving_nest_update_tim - parent_bookkeep_moving_tim=>cc%parent_bookkeep_moving_tim - parent_update_moving_tim =>cc%parent_update_moving_tim - t0_recv_move_tim =>cc%t0_recv_move_tim - read_moving_child_topo_tim =>cc%read_moving_child_topo_tim - barrier_move_tim =>cc%barrier_move_tim - pscd_tim=>cc%pscd_tim - pscd1_tim=>cc%pscd1_tim - pscd2_tim=>cc%pscd2_tim - pscd3_tim=>cc%pscd3_tim - pscd4_tim=>cc%pscd4_tim - ja1_tim=>cc%ja1_tim - ja2_tim=>cc%ja2_tim - ja3_tim=>cc%ja3_tim - ja4_tim=>cc%ja4_tim - jat_tim=>cc%jat_tim -! -!---------------------------------------- -!*** The following are for moving nests -!---------------------------------------- -! - I_EAST_M=>cc%I_EAST_M - I_WEST_M=>cc%I_WEST_M - J_NORTH_M=>cc%J_NORTH_M - J_SOUTH_M=>cc%J_SOUTH_M -! - I_MAX=>cc%I_MAX - I_MIN=>cc%I_MIN - J_MAX=>cc%J_MAX - J_MIN=>cc%J_MIN -! - NPTS_NS=>cc%NPTS_NS - NPTS_WE=>cc%NPTS_WE -! - I_PG=>cc%I_PG - J_PG=>cc%J_PG -! - COEF=>cc%COEF - RNPTS_HZ=>cc%RNPTS_HZ - ELAPSED_TIME_MIN=>cc%ELAPSED_TIME_MIN -! - FIRST_PASS_M =>cc%FIRST_PASS_M - FIRST_STEP_2WAY=>cc%FIRST_STEP_2WAY - IN_WINDOW =>cc%IN_WINDOW - STOP_MY_MOTION =>cc%STOP_MY_MOTION -! - I_HOLD_CENTER_POINT=>cc%I_HOLD_CENTER_POINT - I_HOLD_PG_POINT=>cc%I_HOLD_PG_POINT -! - MOVING_CHILD_UPDATE=>cc%MOVING_CHILD_UPDATE - TASK_UPDATE_SPECS=>cc%TASK_UPDATE_SPECS -! - MOVE_TYPE=>CC%MOVE_TYPE -! - MOVE_INTERVAL_MINUTES=>CC%MOVE_INTERVAL_MINUTES - N_MOVES=>CC%N_MOVES - MOVE_MINUTE=>CC%MOVE_MINUTE - MOVE_I_SW=>CC%MOVE_I_SW - MOVE_J_SW=>CC%MOVE_J_SW -! -!---------------------------------------- -!*** The following is for 2-way nesting -!---------------------------------------- -! - CHILD_TASKS_2WAY_UPDATE=>cc%CHILD_TASKS_2WAY_UPDATE -! -!----------------------------------------------------------------------- -! - END SUBROUTINE POINT_TO_COMPOSITE -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE PARENT_CHILD_INTERP_SETUP(MY_DOMAIN_ID & - ,NUM_CHILDREN & - ,MY_CHILDREN_ID & - ,IM_CHILD & - ,JM_CHILD & - ,FTASKS_DOMAIN & - ,N_BLEND_H_CHILD & - ,N_BLEND_V_CHILD & - ,CF & - ,ITS,ITE,JTS,JTE & - ,IDS,IDE,JDS,JDE ) -! -!----------------------------------------------------------------------- -! -!*** ALLOCATE THREE PRIMARY INTERPOLATION QUANTITIES NEEDED BY -!*** A PARENT DOMAIN TO GENERATE BOUNDARY DATA FOR ITS CHILDREN: -! -! (1) Children's boundary index limits on each parent task; -! (2) Parent I's and J's surrounding each child boundary point; -! (3) Bilinear weights of each parent point surrounding each -! child boundary point. -! -!----------------------------------------------------------------------- -! -!*** ONLY PARENT TASKS EXECUTE THIS ROUTINE. -! -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: ITS,ITE,JTS,JTE & - ,IDS,IDE,JDS,JDE & - ,MY_DOMAIN_ID & - ,NUM_CHILDREN -! - INTEGER(kind=KINT),DIMENSION(1:NUM_CHILDREN),INTENT(IN) :: IM_CHILD & - ,JM_CHILD & - ,N_BLEND_H_CHILD & - ,N_BLEND_V_CHILD -! - INTEGER(kind=KINT),DIMENSION(:),POINTER,INTENT(IN) :: FTASKS_DOMAIN & - ,MY_CHILDREN_ID -! - TYPE(ESMF_Config),DIMENSION(1:NUM_CHILDREN),INTENT(INOUT) :: CF -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: N,N_CHILD_TASKS,NUM_CHILD_TASKS & - ,THIS_CHILD_ID -! - INTEGER(kind=KINT) :: EAST_LIMIT1 ,EAST_LIMIT2 & - ,WEST_LIMIT1 ,WEST_LIMIT2 & - ,NORTH_LIMIT1,NORTH_LIMIT2 & - ,SOUTH_LIMIT1,SOUTH_LIMIT2 -! - INTEGER(kind=KINT) :: ISTAT,RC,RC_SET -! - TYPE(COMPOSITE),POINTER :: CC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RC_SET=ESMF_SUCCESS -! - CC=>CPL_COMPOSITE(MY_DOMAIN_ID) -! -!----------------------------------------------------------------------- -!*** Allocate the pointers that hold the four H and V parent points -!*** that surround each child point in the child's boundary region. -!----------------------------------------------------------------------- -! - ALLOCATE(CC%PARENT_4_INDICES_H(1:NUM_CHILDREN),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%PARENT_4_INDICES_H stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - PARENT_4_INDICES_H=>cc%PARENT_4_INDICES_H -! - ALLOCATE(CC%PARENT_4_INDICES_V(1:NUM_CHILDREN),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%PARENT_4_INDICES_V stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - PARENT_4_INDICES_V=>cc%PARENT_4_INDICES_V -! -!----------------------------------------------------------------------- -!*** Allocate the pointers that hold the weights of the four H and V -!*** parent points that surround each child point in the child's -!*** boundary region. -!----------------------------------------------------------------------- -! - ALLOCATE(CC%PARENT_4_WEIGHTS_H(1:NUM_CHILDREN),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%PARENT_4_WEIGHTS_H stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - PARENT_4_WEIGHTS_H=>CC%PARENT_4_WEIGHTS_H -! - ALLOCATE(CC%PARENT_4_WEIGHTS_V(1:NUM_CHILDREN)) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%PARENT_4_WEIGHTS_V stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - PARENT_4_WEIGHTS_V=>CC%PARENT_4_WEIGHTS_V -! -!----------------------------------------------------------------------- -!*** Allocate the arrays that hold the number of child tasks -!*** on each side of the child boundaries that will be sent -!*** data from the parent tasks. -!----------------------------------------------------------------------- -! - ALLOCATE(cc%NUM_TASKS_SEND_H_S(1:NUM_CHILDREN),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%NUM_TASKS_SEND_H_S stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - NUM_TASKS_SEND_H_S=>cc%NUM_TASKS_SEND_H_S -! - ALLOCATE(cc%NUM_TASKS_SEND_H_N(1:NUM_CHILDREN),stat=ISTAT) - NUM_TASKS_SEND_H_N=>cc%NUM_TASKS_SEND_H_N -! - ALLOCATE(cc%NUM_TASKS_SEND_H_W(1:NUM_CHILDREN),stat=ISTAT) - NUM_TASKS_SEND_H_W=>cc%NUM_TASKS_SEND_H_W -! - ALLOCATE(cc%NUM_TASKS_SEND_H_E(1:NUM_CHILDREN),stat=ISTAT) - NUM_TASKS_SEND_H_E=>cc%NUM_TASKS_SEND_H_E -! - ALLOCATE(cc%NUM_TASKS_SEND_V_S(1:NUM_CHILDREN),stat=ISTAT) - NUM_TASKS_SEND_V_S=>cc%NUM_TASKS_SEND_V_S -! - ALLOCATE(cc%NUM_TASKS_SEND_V_N(1:NUM_CHILDREN),stat=ISTAT) - NUM_TASKS_SEND_V_N=>cc%NUM_TASKS_SEND_V_N -! - ALLOCATE(cc%NUM_TASKS_SEND_V_W(1:NUM_CHILDREN),stat=ISTAT) - NUM_TASKS_SEND_V_W=>cc%NUM_TASKS_SEND_V_W -! - ALLOCATE(cc%NUM_TASKS_SEND_V_E(1:NUM_CHILDREN),stat=ISTAT) - NUM_TASKS_SEND_V_E=>cc%NUM_TASKS_SEND_V_E -! -!----------------------------------------------------------------------- -!*** Allocate the pointers that will hold the ranks of all child tasks -!*** on each side of the child boundaries that will be sent data -!*** from the parent tasks. -!----------------------------------------------------------------------- -! - ALLOCATE(cc%CHILDTASK_BNDRY_H_RANKS(1:NUM_CHILDREN),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%CHILDTASK_BNDRY_H_RANKS stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - CHILDTASK_BNDRY_H_RANKS=>cc%CHILDTASK_BNDRY_H_RANKS -! - ALLOCATE(cc%CHILDTASK_BNDRY_V_RANKS(1:NUM_CHILDREN),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%CHILDTASK_BNDRY_V_RANKS stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - CHILDTASK_BNDRY_V_RANKS=>cc%CHILDTASK_BNDRY_V_RANKS -! -!----------------------------------------------------------------------- -!*** Allocate the pointers for starting/ending I's and J's on each -!*** parent task for each side of the boundary. -!----------------------------------------------------------------------- -! - ALLOCATE(cc%CHILDTASK_H_SAVE(1:NUM_CHILDREN),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%CHILDTASK_H_SAVE stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - CHILDTASK_H_SAVE=>cc%CHILDTASK_H_SAVE -! - ALLOCATE(cc%CHILDTASK_V_SAVE(1:NUM_CHILDREN),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate cpl_composite%CHILDTASK_V_SAVE stat=',ISTAT - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF - CHILDTASK_V_SAVE=>cc%CHILDTASK_V_SAVE -! -!----------------------------------------------------------------------- -!*** Extract relevant information from the children's configure files. -!----------------------------------------------------------------------- -! - child_loop_0: DO N=1,NUM_CHILDREN -! - THIS_CHILD_ID=MY_CHILDREN_ID(N) -! -!----------------------------------------------------------------------- -!*** Invert the Parent-to-Child space ratio for computation. -!----------------------------------------------------------------------- -! - CHILD_PARENT_SPACE_RATIO(N)=1./REAL(PARENT_CHILD_SPACE_RATIO(N)) -! -!----------------------------------------------------------------------- -!*** Allocate the individual pointers holding the four H points of -!*** the parent that surround this child's boundary region H points -!*** and the bilinear interpolation weights of the four parent points -!*** surrounding those same child points. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! *************************** NOTE ***************************** -!----------------------------------------------------------------------- -! Although the H points in the nests' boundary region cover only -! N_BLEND rows, we actually need to have the nests' PD values -! one row further. That is because we also need PD values at the -! V points in the nests' boundary region to perform the proper -! hydrostatic updating of the winds by the parents there. To -! do the 4-point average needed to obtain PD on V points, we -! necessarily must have them on mass points one row beyond where -! they are needed for the mass points alone. -!----------------------------------------------------------------------- -! *************************** NOTE ***************************** -!----------------------------------------------------------------------- -! - SOUTH_LIMIT1=1 - SOUTH_LIMIT2=N_BLEND_H_CHILD(N)+1 !<-- Extend the region by 1 row for 4-point averaging of PD -! - NORTH_LIMIT1=JM_CHILD(N)-N_BLEND_H_CHILD(N) !<-- Extend the region by 1 row for 4-point averaging of PD - NORTH_LIMIT2=JM_CHILD(N) -! - WEST_LIMIT1=1 - WEST_LIMIT2=N_BLEND_H_CHILD(N)+1 !<-- Extend the region by 1 row for 4-point averaging of PD -! - EAST_LIMIT1=IM_CHILD(N)-N_BLEND_H_CHILD(N) !<-- Extend the region by 1 row for 4-point averaging of PD - EAST_LIMIT2=IM_CHILD(N) -! -!-------------------------- -!*** Parent point indices -!-------------------------- -! - ALLOCATE(PARENT_4_INDICES_H(N)%I_INDX_SBND(1:IM_CHILD(N) & !<-- Parent I's west/east of child south bndry H points - ,SOUTH_LIMIT1:SOUTH_LIMIT2 & - ,1:2)) -! - ALLOCATE(PARENT_4_INDICES_H(N)%I_INDX_NBND(1:IM_CHILD(N) & !<-- Parent I's west/east of child north bndry H points - ,NORTH_LIMIT1:NORTH_LIMIT2 & - ,1:2)) -! - ALLOCATE(PARENT_4_INDICES_H(N)%I_INDX_WBND(WEST_LIMIT1:WEST_LIMIT2 & !<-- Parent I's west/east of child west bndry H points - ,1:JM_CHILD(N) & - ,1:2)) -! - ALLOCATE(PARENT_4_INDICES_H(N)%I_INDX_EBND(EAST_LIMIT1:EAST_LIMIT2 & !<-- Parent I's west/east of child east bndry H points - ,1:JM_CHILD(N) & - ,1:2)) -! - ALLOCATE(PARENT_4_INDICES_H(N)%J_INDX_SBND(1:IM_CHILD(N) & !<-- Parent J's south/north of child south bndry H points - ,SOUTH_LIMIT1:SOUTH_LIMIT2 & - ,1:2)) -! - ALLOCATE(PARENT_4_INDICES_H(N)%J_INDX_NBND(1:IM_CHILD(N) & !<-- Parent J's south/north of child north bndry H points - ,NORTH_LIMIT1:NORTH_LIMIT2 & - ,1:2)) -! - ALLOCATE(PARENT_4_INDICES_H(N)%J_INDX_WBND(WEST_LIMIT1:WEST_LIMIT2 & !<-- Parent J's south/north of child west bndry H points - ,1:JM_CHILD(N) & - ,1:2)) -! - ALLOCATE(PARENT_4_INDICES_H(N)%J_INDX_EBND(EAST_LIMIT1:EAST_LIMIT2 & !<-- Parent J's south/north of child east bndry H points - ,1:JM_CHILD(N) & - ,1:2)) -! -!-------------------------- -!*** Parent point weights -!-------------------------- -! - ALLOCATE(PARENT_4_WEIGHTS_H(N)%WEIGHTS_SBND(1:IM_CHILD(N) & !<-- Bilinear interpolation weights of parent points - ,SOUTH_LIMIT1:SOUTH_LIMIT2 & ! surrounding child south bndry region H points. - ,1:4)) ! 1:4 indicates SW, SE, NW, NE of child point. -! - ALLOCATE(PARENT_4_WEIGHTS_H(N)%WEIGHTS_NBND(1:IM_CHILD(N) & !<-- Bilinear interpolation weights of parent points - ,NORTH_LIMIT1:NORTH_LIMIT2 & ! surrounding child north bndry region H points. - ,1:4)) ! 1:4 indicates SW, SE, NW, NE of child point. -! - ALLOCATE(PARENT_4_WEIGHTS_H(N)%WEIGHTS_WBND(WEST_LIMIT1:WEST_LIMIT2 & !<-- Bilinear interpolation weights of parent points - ,1:JM_CHILD(N) & ! surrounding child west bndry region H points. - ,1:4)) ! 1:4 indicates SW, SE, NW, NE of child point. -! - ALLOCATE(PARENT_4_WEIGHTS_H(N)%WEIGHTS_EBND(EAST_LIMIT1:EAST_LIMIT2 & !<-- Bilinear interpolation weights of parent points - ,1:JM_CHILD(N) & ! surrounding child east bndry region H points. - ,1:4)) ! 1:4 indicates SW, SE, NW, NE of child point. -! -!----------------------------------------------------------------------- -!*** Allocate the individual pointers holding the four V points of -!*** the parent that surround this child's boundary region V points. -!----------------------------------------------------------------------- -! - SOUTH_LIMIT1=1 - SOUTH_LIMIT2=N_BLEND_V_CHILD(N) -! - NORTH_LIMIT1=JM_CHILD(N)-1-N_BLEND_V_CHILD(N)+1 - NORTH_LIMIT2=JM_CHILD(N)-1 -! - WEST_LIMIT1=1 - WEST_LIMIT2=N_BLEND_V_CHILD(N) -! - EAST_LIMIT1=IM_CHILD(N)-1-N_BLEND_V_CHILD(N)+1 - EAST_LIMIT2=IM_CHILD(N)-1 -! -!-------------------------- -!*** Parent point indices -!-------------------------- -! - ALLOCATE(PARENT_4_INDICES_V(N)%I_INDX_SBND(1:IM_CHILD(N)-1 & !<-- Parent I's west/east of child south bndry V points. - ,SOUTH_LIMIT1:SOUTH_LIMIT2 & - ,1:2)) -! - ALLOCATE(PARENT_4_INDICES_V(N)%I_INDX_NBND(1:IM_CHILD(N)-1 & !<-- Parent I's west/east of child north bndry V points. - ,NORTH_LIMIT1:NORTH_LIMIT2 & - ,1:2)) -! - ALLOCATE(PARENT_4_INDICES_V(N)%I_INDX_WBND(WEST_LIMIT1:WEST_LIMIT2 & !<-- Parent I's west/east of child west bndry V points. - ,1:JM_CHILD(N)-1 & - ,1:2)) -! - ALLOCATE(PARENT_4_INDICES_V(N)%I_INDX_EBND(EAST_LIMIT1:EAST_LIMIT2 & !<-- Parent I's west/east of child east bndry V points. - ,1:JM_CHILD(N)-1 & - ,1:2)) -! - ALLOCATE(PARENT_4_INDICES_V(N)%J_INDX_SBND(1:IM_CHILD(N)-1 & !<-- Parent J's south/north of child south bndry V points. - ,SOUTH_LIMIT1:SOUTH_LIMIT2 & - ,1:2)) -! - ALLOCATE(PARENT_4_INDICES_V(N)%J_INDX_NBND(1:IM_CHILD(N)-1 & !<-- Parent J's south/north of child north bndry V points. - ,NORTH_LIMIT1:NORTH_LIMIT2 & - ,1:2)) -! - ALLOCATE(PARENT_4_INDICES_V(N)%J_INDX_WBND(WEST_LIMIT1:WEST_LIMIT2 & !<-- Parent J's south/north of child west bndry V points. - ,1:JM_CHILD(N)-1 & - ,1:2)) -! - ALLOCATE(PARENT_4_INDICES_V(N)%J_INDX_EBND(EAST_LIMIT1:EAST_LIMIT2 & !<-- Parent J's south/north of child east bndry V points. - ,1:JM_CHILD(N)-1 & - ,1:2)) -! -!-------------------------- -!*** Parent point weights -!-------------------------- -! - ALLOCATE(PARENT_4_WEIGHTS_V(N)%WEIGHTS_SBND(1:IM_CHILD(N)-1 & !<-- Bilinear interpolation weights of parent points - ,SOUTH_LIMIT1:SOUTH_LIMIT2 & ! surrounding child south bndry region V points. - ,1:4)) ! 1:4 indicates SW, SE, NW, NE of child point. -! - ALLOCATE(PARENT_4_WEIGHTS_V(N)%WEIGHTS_NBND(1:IM_CHILD(N)-1 & !<-- Bilinear interpolation weights of parent points - ,NORTH_LIMIT1:NORTH_LIMIT2 & ! surrounding child north bndry region V points. - ,1:4)) ! 1:4 indicates SW, SE, NW, NE of child point. -! - ALLOCATE(PARENT_4_WEIGHTS_V(N)%WEIGHTS_WBND(WEST_LIMIT1:WEST_LIMIT2 & !<-- Bilinear interpolation weights of parent points - ,1:JM_CHILD(N)-1 & ! surrounding child west bndry region V points. - ,1:4)) ! 1:4 indicates SW, SE, NW, NE of child point. -! - ALLOCATE(PARENT_4_WEIGHTS_V(N)%WEIGHTS_EBND(EAST_LIMIT1:EAST_LIMIT2 & !<-- Bilinear interpolation weights of parent points - ,1:JM_CHILD(N)-1 & ! surrounding child east bndry region V points. - ,1:4)) ! 1:4 indicates SW, SE, NW, NE of child point. -! -!----------------------------------------------------------------------- -!*** What is the number of forecast tasks on the child domain? -!----------------------------------------------------------------------- -! - NUM_CHILD_TASKS=FTASKS_DOMAIN(THIS_CHILD_ID) -! -!----------------------------------------------------------------------- -!*** Allocate the pointers for starting/ending I's and J's on each -!*** parent task for each side of the boundary. -!----------------------------------------------------------------------- -! - ALLOCATE(CHILDTASK_H_SAVE(N)%I_LO_SOUTH (1:NUM_CHILD_TASKS)) - ALLOCATE(CHILDTASK_H_SAVE(N)%I_HI_SOUTH (1:NUM_CHILD_TASKS)) - ALLOCATE(CHILDTASK_H_SAVE(N)%I_HI_SOUTH_TRANSFER(1:NUM_CHILD_TASKS)) - ALLOCATE(CHILDTASK_H_SAVE(N)%I_LO_NORTH (1:NUM_CHILD_TASKS)) - ALLOCATE(CHILDTASK_H_SAVE(N)%I_HI_NORTH (1:NUM_CHILD_TASKS)) - ALLOCATE(CHILDTASK_H_SAVE(N)%I_HI_NORTH_TRANSFER(1:NUM_CHILD_TASKS)) - ALLOCATE(CHILDTASK_H_SAVE(N)%J_LO_WEST (1:NUM_CHILD_TASKS)) - ALLOCATE(CHILDTASK_H_SAVE(N)%J_HI_WEST (1:NUM_CHILD_TASKS)) - ALLOCATE(CHILDTASK_H_SAVE(N)%J_HI_WEST_TRANSFER (1:NUM_CHILD_TASKS)) - ALLOCATE(CHILDTASK_H_SAVE(N)%J_LO_EAST (1:NUM_CHILD_TASKS)) - ALLOCATE(CHILDTASK_H_SAVE(N)%J_HI_EAST (1:NUM_CHILD_TASKS)) - ALLOCATE(CHILDTASK_H_SAVE(N)%J_HI_EAST_TRANSFER (1:NUM_CHILD_TASKS)) -! - ALLOCATE(CHILDTASK_V_SAVE(N)%I_LO_SOUTH (1:NUM_CHILD_TASKS)) - ALLOCATE(CHILDTASK_V_SAVE(N)%I_HI_SOUTH (1:NUM_CHILD_TASKS)) - ALLOCATE(CHILDTASK_V_SAVE(N)%I_HI_SOUTH_TRANSFER(1:NUM_CHILD_TASKS)) - ALLOCATE(CHILDTASK_V_SAVE(N)%I_LO_NORTH (1:NUM_CHILD_TASKS)) - ALLOCATE(CHILDTASK_V_SAVE(N)%I_HI_NORTH (1:NUM_CHILD_TASKS)) - ALLOCATE(CHILDTASK_V_SAVE(N)%I_HI_NORTH_TRANSFER(1:NUM_CHILD_TASKS)) - ALLOCATE(CHILDTASK_V_SAVE(N)%J_LO_WEST (1:NUM_CHILD_TASKS)) - ALLOCATE(CHILDTASK_V_SAVE(N)%J_HI_WEST (1:NUM_CHILD_TASKS)) - ALLOCATE(CHILDTASK_V_SAVE(N)%J_HI_WEST_TRANSFER(1:NUM_CHILD_TASKS)) - ALLOCATE(CHILDTASK_V_SAVE(N)%J_LO_EAST (1:NUM_CHILD_TASKS)) - ALLOCATE(CHILDTASK_V_SAVE(N)%J_HI_EAST (1:NUM_CHILD_TASKS)) - ALLOCATE(CHILDTASK_V_SAVE(N)%J_HI_EAST_TRANSFER(1:NUM_CHILD_TASKS)) -! -!----------------------------------------------------------------------- -!*** Allocate the pointers for the child task ID's that contain -!*** segments of the child boundary within a parent task for -!*** each side of the boundary. -!----------------------------------------------------------------------- -! - ALLOCATE(CHILDTASK_BNDRY_H_RANKS(N)%SOUTH(1:NUM_CHILD_TASKS,2)) - ALLOCATE(CHILDTASK_BNDRY_H_RANKS(N)%NORTH(1:NUM_CHILD_TASKS,2)) - ALLOCATE(CHILDTASK_BNDRY_H_RANKS(N)%WEST (1:NUM_CHILD_TASKS,2)) - ALLOCATE(CHILDTASK_BNDRY_H_RANKS(N)%EAST (1:NUM_CHILD_TASKS,2)) -! - ALLOCATE(CHILDTASK_BNDRY_V_RANKS(N)%SOUTH(1:NUM_CHILD_TASKS,2)) - ALLOCATE(CHILDTASK_BNDRY_V_RANKS(N)%NORTH(1:NUM_CHILD_TASKS,2)) - ALLOCATE(CHILDTASK_BNDRY_V_RANKS(N)%WEST (1:NUM_CHILD_TASKS,2)) - ALLOCATE(CHILDTASK_BNDRY_V_RANKS(N)%EAST (1:NUM_CHILD_TASKS,2)) -! -!----------------------------------------------------------------------- -! - ENDDO child_loop_0 -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PARENT_CHILD_INTERP_SETUP -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE PREPARE_NEST_INTERP_FACTORS(N_CHILD,MY_DOMAIN_ID) -! -!----------------------------------------------------------------------- -!*** Call the routine that computes the interpolation factors -!*** each parent needs in order to interpolate its data to -!*** its nests' boundaries. -! -!*** Only parent tasks execute this routine. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: N_CHILD & !<-- The parent's N-CHILD'th child - ,MY_DOMAIN_ID !<-- The parent's domain ID -! -!--------------------- -!*** Local variables -!--------------------- -! - INTEGER(kind=KINT) :: ITE_CHILD_X,JTE_CHILD_X & - ,N,N_CHILD_TASKS,NCX,NT,NUM_CHILD_TASKS -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** The parent sets up quantities to be used for general -!*** bilinear interpolation from the parent to its children's -!*** boundary regions. These quantities are: -! -! (1a) The westernmost/eastermost I's of children's south/north -! boundary region points on this parent task's subdomain. -! (1b) The southernmost/northernmost J's of children's west/east -! boundary region points on this parent task's subdomain. -! (2) The I,J of the four parent points surrounding each -! child's boundary region point. -! (3) The bilinear interpolation weights for each of the four -! parent points surrounding each child's boundary region -! point. -!----------------------------------------------------------------------- -! - N=N_CHILD -! - NUM_CHILD_TASKS=FTASKS_DOMAIN(MY_CHILDREN_ID(N)) !<-- # of fcst tasks on this parent's Nth child -! -!------------------------------------------------------------ -!*** Compute interpolation indices and weights for H points -!------------------------------------------------------------ -! - CALL PARENT_TO_CHILD_INTERP_FACTORS('H_POINTS' & - ,N_CHILD & - ,I_PARENT_SW(N) & - ,J_PARENT_SW(N) & - ,N_BLEND_H_CHILD(N) & -! - ,IM_CHILD(N) & - ,JM_CHILD(N) & -! - ,NUM_CHILD_TASKS & - ,CTASK_LIMITS(MY_DOMAIN_ID)%CHILDREN(N)%DATA & - ,CHILD_RANKS(MY_DOMAIN_ID)%CHILDREN(N)%DATA & -! ^ - ,CHILD_PARENT_SPACE_RATIO(N) & ! | -! ! | - ,ITS,ITE,JTS,JTE & ! | - ,IDS,IDE,JDS,JDE & ! Input -! ----------------- - ,NUM_TASKS_SEND_H_S(N) & ! Output - ,NUM_TASKS_SEND_H_N(N) & ! | - ,NUM_TASKS_SEND_H_W(N) & ! | - ,NUM_TASKS_SEND_H_E(N) & ! v -! - ,CHILDTASK_H_SAVE(N)%I_LO_SOUTH & - ,CHILDTASK_H_SAVE(N)%I_HI_SOUTH & - ,CHILDTASK_H_SAVE(N)%I_LO_NORTH & - ,CHILDTASK_H_SAVE(N)%I_HI_NORTH & - ,CHILDTASK_H_SAVE(N)%J_LO_WEST & - ,CHILDTASK_H_SAVE(N)%J_HI_WEST & - ,CHILDTASK_H_SAVE(N)%J_LO_EAST & - ,CHILDTASK_H_SAVE(N)%J_HI_EAST & -! - ,CHILDTASK_BNDRY_H_RANKS(N)%SOUTH & - ,CHILDTASK_BNDRY_H_RANKS(N)%NORTH & - ,CHILDTASK_BNDRY_H_RANKS(N)%WEST & - ,CHILDTASK_BNDRY_H_RANKS(N)%EAST & -! - ,PARENT_4_INDICES_H(N)%I_INDX_SBND & - ,PARENT_4_INDICES_H(N)%I_INDX_NBND & - ,PARENT_4_INDICES_H(N)%I_INDX_WBND & - ,PARENT_4_INDICES_H(N)%I_INDX_EBND & - ,PARENT_4_INDICES_H(N)%J_INDX_SBND & - ,PARENT_4_INDICES_H(N)%J_INDX_NBND & - ,PARENT_4_INDICES_H(N)%J_INDX_WBND & - ,PARENT_4_INDICES_H(N)%J_INDX_EBND & -! - ,PARENT_4_WEIGHTS_H(N)%WEIGHTS_SBND & - ,PARENT_4_WEIGHTS_H(N)%WEIGHTS_NBND & - ,PARENT_4_WEIGHTS_H(N)%WEIGHTS_WBND & - ,PARENT_4_WEIGHTS_H(N)%WEIGHTS_EBND) -! -!------------------------------------------------------------------------ -!*** The child J extent of words to be transferred from this parent task -!*** to child task NT is one less than the limit used for saving values -!*** of PDB on the child boundary. We needed to save PDB at one point -!*** further north than the northernmost V in the segment to be able -!*** to do 4-pt averaging of PDB onto the V points in order to do -!*** hydrostatic updating of V by the parent. Now indicate that -!*** reduction in the number of points to be transferred. -!------------------------------------------------------------------------ -! -!------------- -!*** South H -!------------- -! - NUM_CHILD_TASKS=NUM_TASKS_SEND_H_S(N) -! - DO NT=1,NUM_CHILD_TASKS - CHILDTASK_H_SAVE(N)%I_HI_SOUTH_TRANSFER(NT)= & !<-- Sbndry I limit for transfer to child - CHILDTASK_H_SAVE(N)%I_HI_SOUTH(NT)-1 -! - NCX=CHILDTASK_BNDRY_H_RANKS(N)%SOUTH(NT,1) !<-- Count of this child task in list of all its fcst tasks - ITE_CHILD_X=CTASK_LIMITS(MY_DOMAIN_ID)%CHILDREN(N)%DATA(2,NCX) - IF(CHILDTASK_H_SAVE(N)%I_HI_SOUTH(NT)==ITE_CHILD_X)THEN !<-- We do not reduce the area for H data - CHILDTASK_H_SAVE(N)%I_HI_SOUTH_TRANSFER(NT)= & ! transfer if the bndry segment reaches - CHILDTASK_H_SAVE(N)%I_HI_SOUTH_TRANSFER(NT)+1 ! the physical limit of that bndry - ENDIF - ENDDO -! -!------------- -!*** North H -!------------- -! - NUM_CHILD_TASKS=NUM_TASKS_SEND_H_N(N) -! - DO NT=1,NUM_CHILD_TASKS - CHILDTASK_H_SAVE(N)%I_HI_NORTH_TRANSFER(NT)= & !<-- Nbndry I limit for transfer to child - CHILDTASK_H_SAVE(N)%I_HI_NORTH(NT)-1 -! - NCX=CHILDTASK_BNDRY_H_RANKS(N)%NORTH(NT,1) !<-- Count of this child task in list of all its fcst tasks - ITE_CHILD_X=CTASK_LIMITS(MY_DOMAIN_ID)%CHILDREN(N)%DATA(2,NCX) - IF(CHILDTASK_H_SAVE(N)%I_HI_NORTH(NT)==ITE_CHILD_X)THEN !<-- We do not reduce the area for H data - CHILDTASK_H_SAVE(N)%I_HI_NORTH_TRANSFER(NT)= & ! transfer if the bndry segment reaches - CHILDTASK_H_SAVE(N)%I_HI_NORTH_TRANSFER(NT)+1 ! the physical limit of that bndry - ENDIF - ENDDO -! -!------------ -!*** West H -!------------ -! - NUM_CHILD_TASKS=NUM_TASKS_SEND_H_W(N) -! - DO NT=1,NUM_CHILD_TASKS - CHILDTASK_H_SAVE(N)%J_HI_WEST_TRANSFER(NT)= & !<-- Wbndry J limit for transfer to child - CHILDTASK_H_SAVE(N)%J_HI_WEST(NT)-1 -! - NCX=CHILDTASK_BNDRY_H_RANKS(N)%WEST(NT,1) !<-- Count of this child task in list of all its fcst tasks - JTE_CHILD_X=CTASK_LIMITS(MY_DOMAIN_ID)%CHILDREN(N)%DATA(4,NCX) - IF(CHILDTASK_H_SAVE(N)%J_HI_WEST(NT)==JTE_CHILD_X)THEN !<-- We do not reduce the area for H data - CHILDTASK_H_SAVE(N)%J_HI_WEST_TRANSFER(NT)= & ! transfer if the bndry segment reaches - CHILDTASK_H_SAVE(N)%J_HI_WEST_TRANSFER(NT)+1 ! the physical limit of that bndry - ENDIF - ENDDO -! -!------------ -!*** East H -!------------ -! - NUM_CHILD_TASKS=NUM_TASKS_SEND_H_E(N) -! - DO NT=1,NUM_CHILD_TASKS - CHILDTASK_H_SAVE(N)%J_HI_EAST_TRANSFER(NT)= & !<-- Ebndry J limit for transfer to child - CHILDTASK_H_SAVE(N)%J_HI_EAST(NT)-1 -! - NCX=CHILDTASK_BNDRY_H_RANKS(N)%EAST(NT,1) !<-- Count of this child task in list of all its fcst tasks - JTE_CHILD_X=CTASK_LIMITS(MY_DOMAIN_ID)%CHILDREN(N)%DATA(4,NCX) - IF(CHILDTASK_H_SAVE(N)%J_HI_EAST(NT)==JTE_CHILD_X)THEN !<-- We do not reduce the area for H data - CHILDTASK_H_SAVE(N)%J_HI_EAST_TRANSFER(NT)= & ! transfer if the bndry segment reaches - CHILDTASK_H_SAVE(N)%J_HI_EAST_TRANSFER(NT)+1 ! the physical limit of that bndry - ENDIF - ENDDO -! -!------------------------------------------------------------ -!*** Compute interpolation indices and weights for V points -!------------------------------------------------------------ -! - NUM_CHILD_TASKS=FTASKS_DOMAIN(MY_CHILDREN_ID(N)) !<-- # of fcst tasks on this parent's Nth child -! - CALL PARENT_TO_CHILD_INTERP_FACTORS('V_POINTS' & - ,N_CHILD & - ,I_PARENT_SW(N) & - ,J_PARENT_SW(N) & - ,N_BLEND_V_CHILD(N) & -! - ,IM_CHILD(N) & - ,JM_CHILD(N) & -! - ,NUM_CHILD_TASKS & - ,CTASK_LIMITS(MY_DOMAIN_ID)%CHILDREN(N)%DATA & - ,CHILD_RANKS(MY_DOMAIN_ID)%CHILDREN(N)%DATA & -! - ,CHILD_PARENT_SPACE_RATIO(N) & ! ^ -! | - ,ITS,ITE,JTS,JTE & ! | - ,IDS,IDE,JDS,JDE & ! Input -! ---------------- - ,NUM_TASKS_SEND_V_S(N) & ! Output - ,NUM_TASKS_SEND_V_N(N) & ! | - ,NUM_TASKS_SEND_V_W(N) & ! | - ,NUM_TASKS_SEND_V_E(N) & ! v -! - ,CHILDTASK_V_SAVE(N)%I_LO_SOUTH & - ,CHILDTASK_V_SAVE(N)%I_HI_SOUTH & - ,CHILDTASK_V_SAVE(N)%I_LO_NORTH & - ,CHILDTASK_V_SAVE(N)%I_HI_NORTH & - ,CHILDTASK_V_SAVE(N)%J_LO_WEST & - ,CHILDTASK_V_SAVE(N)%J_HI_WEST & - ,CHILDTASK_V_SAVE(N)%J_LO_EAST & - ,CHILDTASK_V_SAVE(N)%J_HI_EAST & -! - ,CHILDTASK_BNDRY_V_RANKS(N)%SOUTH & - ,CHILDTASK_BNDRY_V_RANKS(N)%NORTH & - ,CHILDTASK_BNDRY_V_RANKS(N)%WEST & - ,CHILDTASK_BNDRY_V_RANKS(N)%EAST & -! - ,PARENT_4_INDICES_V(N)%I_INDX_SBND & - ,PARENT_4_INDICES_V(N)%I_INDX_NBND & - ,PARENT_4_INDICES_V(N)%I_INDX_WBND & - ,PARENT_4_INDICES_V(N)%I_INDX_EBND & - ,PARENT_4_INDICES_V(N)%J_INDX_SBND & - ,PARENT_4_INDICES_V(N)%J_INDX_NBND & - ,PARENT_4_INDICES_V(N)%J_INDX_WBND & - ,PARENT_4_INDICES_V(N)%J_INDX_EBND & -! - ,PARENT_4_WEIGHTS_V(N)%WEIGHTS_SBND & - ,PARENT_4_WEIGHTS_V(N)%WEIGHTS_NBND & - ,PARENT_4_WEIGHTS_V(N)%WEIGHTS_WBND & - ,PARENT_4_WEIGHTS_V(N)%WEIGHTS_EBND) -! -!----------------------------------------------------------------------- -!*** For V point variables, the number of points to be transferred -!*** from parents to their children's boundaries is the same as -!*** the number of computation points (no extensions as is needed -!*** for PDB). -!----------------------------------------------------------------------- -! - NUM_CHILD_TASKS=FTASKS_DOMAIN(MY_CHILDREN_ID(N)) -! - DO N_CHILD_TASKS=1,NUM_CHILD_TASKS -! - CHILDTASK_V_SAVE(N)%I_HI_SOUTH_TRANSFER(N_CHILD_TASKS)= & - CHILDTASK_V_SAVE(N)%I_HI_SOUTH(N_CHILD_TASKS) -! - CHILDTASK_V_SAVE(N)%I_HI_NORTH_TRANSFER(N_CHILD_TASKS)= & - CHILDTASK_V_SAVE(N)%I_HI_NORTH(N_CHILD_TASKS) -! - CHILDTASK_V_SAVE(N)%J_HI_WEST_TRANSFER(N_CHILD_TASKS)= & - CHILDTASK_V_SAVE(N)%J_HI_WEST(N_CHILD_TASKS) -! - CHILDTASK_V_SAVE(N)%J_HI_EAST_TRANSFER(N_CHILD_TASKS)= & - CHILDTASK_V_SAVE(N)%J_HI_EAST(N_CHILD_TASKS) -! - ENDDO -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PREPARE_NEST_INTERP_FACTORS -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE PARENT_TO_CHILD_INTERP_FACTORS(FLAG_H_OR_V & - ,N_CHILD & - ,I_PARENT_SW & - ,J_PARENT_SW & - ,N_BLEND & -! - ,IM_CHILD & - ,JM_CHILD & -! - ,NUM_CHILD_TASKS & - ,LIMITS & - ,CHILD_RANKS & -! - ,CHILD_PARENT_SPACE_RATIO & ! ^ -! | - ,ITS,ITE,JTS,JTE & ! | - ,IDS,IDE,JDS,JDE & ! Input -! -------------- - ,NUM_TASKS_SEND_S & ! Output - ,NUM_TASKS_SEND_N & ! | - ,NUM_TASKS_SEND_W & ! | - ,NUM_TASKS_SEND_E & ! v -! - ,I_SAVE_LO_SOUTH & - ,I_SAVE_HI_SOUTH & - ,I_SAVE_LO_NORTH & - ,I_SAVE_HI_NORTH & - ,J_SAVE_LO_WEST & - ,J_SAVE_HI_WEST & - ,J_SAVE_LO_EAST & - ,J_SAVE_HI_EAST & -! - ,LOCAL_TASK_RANK_S & - ,LOCAL_TASK_RANK_N & - ,LOCAL_TASK_RANK_W & - ,LOCAL_TASK_RANK_E & -! - ,I_INDX_SBND & - ,I_INDX_NBND & - ,I_INDX_WBND & - ,I_INDX_EBND & - ,J_INDX_SBND & - ,J_INDX_NBND & - ,J_INDX_WBND & - ,J_INDX_EBND & -! - ,WEIGHTS_SBND & - ,WEIGHTS_NBND & - ,WEIGHTS_WBND & - ,WEIGHTS_EBND ) -! -!----------------------------------------------------------------------- -!*** Parent components compute various indices, weights, etc. -!*** needed to generate boundary point data for the given -!*** child throughout the upcoming forecast. -!*** Only parent tasks execute this routine. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: I_PARENT_SW,J_PARENT_SW & !<-- SW corner of nest lies on this I,J of parent - ,IM_CHILD,JM_CHILD & !<-- Horizontal dimensions of nest domain - ,N_BLEND & !<-- Width (in rows) of boundary's blending region - ,N_CHILD & !<-- Rank of this child in list of children - ,NUM_CHILD_TASKS !<-- # of fcst tasks on the child's domain -! - INTEGER(kind=KINT),INTENT(IN) :: ITE,ITS,JTE,JTS & !<-- Index limits on parent task subdomain - ,IDE,IDS,JDE,JDS !<-- Full dimensions of parent domain -! - INTEGER(kind=KINT),DIMENSION(0:NUM_CHILD_TASKS-1),INTENT(IN) :: & - CHILD_RANKS !<-- Child fcst task ranks in parent-child intracommunicator -! - INTEGER(kind=KINT),DIMENSION(1:4,1:NUM_CHILD_TASKS),INTENT(IN) :: & - LIMITS !<-- ITS,ITE,JTS,JTE on each task of the child -! - REAL(kind=KFPT),INTENT(IN) :: CHILD_PARENT_SPACE_RATIO !<-- Ratio of nest grid increment to parent's increment -! - CHARACTER(*),INTENT(IN) :: FLAG_H_OR_V !<-- Are we dealing with H or V child boundary points? -! - INTEGER(kind=KINT),INTENT(OUT) :: NUM_TASKS_SEND_S & !<-- # of child tasks with S bndry segments on this parent task - ,NUM_TASKS_SEND_N & !<-- # of child tasks with N bndry segments on this parent task - ,NUM_TASKS_SEND_W & !<-- # of child tasks with W bndry segments on this parent task - ,NUM_TASKS_SEND_E !<-- # of child tasks with E bndry segments on this parent task -! - INTEGER(kind=KINT),DIMENSION(NUM_CHILD_TASKS),INTENT(OUT) :: & - I_SAVE_LO_SOUTH & !<-- Child tasks' westernmost Sbndry I's on this parent task - ,I_SAVE_HI_SOUTH & !<-- Child tasks' easternmost Sbndry I's on this parent task - ,I_SAVE_LO_NORTH & !<-- Child tasks' westernmost Nbndry I's on this parent task - ,I_SAVE_HI_NORTH & !<-- Child tasks' easternmost Nbndry I's on this parent task - ,J_SAVE_LO_WEST & !<-- Child tasks' southernmost Wbndry J's on this parent task - ,J_SAVE_HI_WEST & !<-- Child tasks' northernmost Wbndry J's on this parent task - ,J_SAVE_LO_EAST & !<-- Child tasks' southernmost Ebndry J's on this parent task - ,J_SAVE_HI_EAST !<-- Child tasks' northernmost Ebndry J's on this parent task -! - INTEGER(kind=KINT),DIMENSION(NUM_CHILD_TASKS,2),INTENT(OUT) :: & - LOCAL_TASK_RANK_S & !<-- Child task counts/ranks with S bndry on this parent task - ,LOCAL_TASK_RANK_N & !<-- Child task counts/ranks with N bndry on this parent task - ,LOCAL_TASK_RANK_W & !<-- Child task counts/ranks with W bndry on this parent task - ,LOCAL_TASK_RANK_E !<-- Child task counts/ranks with E bndry on this parent task -! - INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER,INTENT(INOUT) :: & - I_INDX_SBND & !<-- Parent I west/east of child south boundary point - ,I_INDX_NBND & !<-- Parent I west/east of child north boundary point - ,I_INDX_WBND & !<-- Parent I west/east of child west boundary point - ,I_INDX_EBND & !<-- Parent I west/east of child east boundary point - ,J_INDX_SBND & !<-- Parent J south/north of child south boundary point - ,J_INDX_NBND & !<-- Parent J south/north of child north boundary point - ,J_INDX_WBND & !<-- Parent J south/north of child west boundary point - ,J_INDX_EBND !<-- Parent J south/north of child east boundary point -! - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER,INTENT(INOUT) :: & - WEIGHTS_SBND & !<-- Sbndry bilinear interp wghts for 4 surrounding parent points - ,WEIGHTS_NBND & !<-- Nbndry bilinear interp wghts for 4 surrounding parent points - ,WEIGHTS_WBND & !<-- Wbndry bilinear interp wghts for 4 surrounding parent points - ,WEIGHTS_EBND !<-- Ebndry bilinear interp wghts for 4 surrounding parent points -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: I_CHILD,IM_END & - ,J_CHILD,JM_END & - ,KOUNT_I,KOUNT_J & - ,N,N_ADD,NC & - ,NC_LAST_S,NC_LAST_N,NC_LAST_W,NC_LAST_E & - ,RATIO_P_C -! - INTEGER(kind=KINT),DIMENSION(1:NUM_CHILD_TASKS) :: I_LIMIT_LO & - ,I_LIMIT_HI & - ,ITS_CHILD & - ,ITE_CHILD & - ,J_LIMIT_LO & - ,J_LIMIT_HI & - ,JTS_CHILD & - ,JTE_CHILD & - ,NC_HOLD_S & - ,NC_HOLD_N & - ,NC_HOLD_W & - ,NC_HOLD_E -! - REAL(kind=KFPT) :: ADD_INC,ARG1,ARG2 & - ,R_ITS,R_ITE,R_IEND,R_JTS,R_JTE,R_JEND -! - REAL(kind=KFPT) :: PARENT_I_CHILD_EBND,PARENT_I_CHILD_WBND & - ,PARENT_J_CHILD_NBND,PARENT_J_CHILD_SBND & - ,PARENT_S_TASK_LIM_ON_NEST & - ,PARENT_W_TASK_LIM_ON_NEST & - ,RATIO_C_P & - ,REAL_I_PARENT,REAL_I_START & - ,REAL_J_PARENT,REAL_J_START & - ,RECIP_SUM -! - REAL(kind=KFPT) :: WEIGHT_NE,WEIGHT_NW,WEIGHT_SE,WEIGHT_SW -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RATIO_C_P=CHILD_PARENT_SPACE_RATIO !<-- Child-to-Parent gridspace ratio - RATIO_P_C=NINT(1./RATIO_C_P) !<-- Parent-to-Child gridspace ratio -! -!----------------------------------------------------------------------- -!*** Create the Real index limits on the parent grid across which -!*** the children's boundary point values will be computed. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** !!!!! NOTE !!!!! -! -!*** For the purpose of handling child boundaries, parent tasks will -!*** "BEGIN" directly on their southernmost/westernmost H or V points. -!*** Each parent task covers the gap between itself and the next task -!*** on the parent grid in each direction. -!*** This means that if a child south boundary point lies exactly on -!*** a parent task point that itself is on the westernmost side of -!*** that parent task's integration subdomain then that child point -!*** will be considered to lie on both that parent task and the -!*** parent task to the west simply because it is the intersection -!*** of the regions managed by both of those parent tasks. -!*** This same notion applies for all other directions and sides. -!----------------------------------------------------------------------- -! - R_ITE =REAL(ITE) !<-- REAL Iend of parent task's subdomain -! - R_JTE =REAL(JTE) !<-- REAL Jend of parent task's subdomain -! -!----------------------------------------------------------------------- -!*** Because each parent gridpoint covers the gap to the next parent -!*** gridpoint as explained above, increase the search limit for -!*** child boundary points. That increase would be 1 for both H and V -!*** but due to the nature of the B-Grid layout and the fact that -!*** the I index of child V points on the west boundary and the -!*** J index of the child V points on the south boundary have smaller -!*** grid index values in terms of the parent indices, we must search -!*** for child H points 1/2+0.5*(space_ratio) grid increments further -!*** than for child V points in order to reach the same actual position. -!----------------------------------------------------------------------- -! -!*** In this diagram the H's and V's are points on the parent task's -!*** subdomain while the h's and v's are points on a nest. It shows -!*** how each parent point must look eastward. The same goes for -!*** looking northwward. A parent/nest ratio of 3:1 is used in this -!*** diagram. -! -!----------------------------------------------------------------------- -! -! H H H -! -! -! -! V V -! v -! h h h h -! -! H H H -! -! -----------> ----> -> -! 1 1/2 1/6 -! ^ -! | -! This parent -! gridpoint -! must cover -! area to the -! next H. -! But V with -! the same I -! as the next H -! is 1.5 farther -! than this H. -! If nest v at -! 1.5 past this -! H is on the east -! bndry of the nest -! then the east h -! on the bndry is -! 1+1/2+1/6. -! That is how -! far we must -! scan from -! this H. -!----------------------------------------------------------------------- -! - IF(FLAG_H_OR_V=='H_POINTS')THEN -! ADD_INC=1.5 - ADD_INC=1.5+0.5*RATIO_C_P+EPS - - ELSE - ADD_INC=1.0 - ENDIF -! -!----------------------------------------------------------------------- -! - DO N=1,NUM_CHILD_TASKS - I_SAVE_LO_SOUTH(N)=-1 - I_SAVE_LO_NORTH(N)=-1 - J_SAVE_LO_WEST (N)=-1 - J_SAVE_LO_EAST (N)=-1 -! - NC_HOLD_S(N)=-1 - NC_HOLD_N(N)=-1 - NC_HOLD_W(N)=-1 - NC_HOLD_E(N)=-1 - ENDDO -! -!----------------------------------------------------------------------- -!*** What are the child I and J index limits of any sections of its -!*** (the child's) boundary that lie within a parent task's subdomain? -! -!*** What are the indices of the four parent gridpoints surrounding -!*** each child boundary point? -! -!*** What are the bilinear weights associated with each of the four -!*** surrounding parent points to obtain the child boundary point? -! -!*** The parent will use these pieces of information to interpolate -!*** from its grid to its children's boundary points. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------- -!********************** NOTE ***************************** -!----------------------------------------------------------- -!*** We assume that the WIDTH of the blending region of -!*** a child's boundary does NOT cross the border between -!*** two parent tasks' subdomains. -!----------------------------------------------------------- -! - IF(FLAG_H_OR_V=='H_POINTS')THEN - PARENT_J_CHILD_SBND=REAL(J_PARENT_SW) !<-- J index of parent H for child's south H boundary - PARENT_J_CHILD_NBND=PARENT_J_CHILD_SBND+(JM_CHILD-1)*RATIO_C_P !<-- J index of parent H for child's north H boundary - PARENT_I_CHILD_WBND=REAL(I_PARENT_SW) !<-- I index of parent H for child's west H boundary - PARENT_I_CHILD_EBND=PARENT_I_CHILD_WBND+(IM_CHILD-1)*RATIO_C_P !<-- I index of parent H for child's east H boundary - IM_END=IM_CHILD - JM_END=JM_CHILD - N_ADD=1 !<-- Blending region along child's boundary - ! increased by 1 row to allow 4-pt averaging of PD. -! - ELSEIF(FLAG_H_OR_V=='V_POINTS')THEN - PARENT_J_CHILD_SBND=REAL(J_PARENT_SW)-0.5+RATIO_C_P*0.5 !<-- J index of parent V for child's south V boundary - PARENT_J_CHILD_NBND=PARENT_J_CHILD_SBND+(JM_CHILD-2)*RATIO_C_P !<-- J index of parent V for child's north V boundary - PARENT_I_CHILD_WBND=REAL(I_PARENT_SW)-0.5+RATIO_C_P*0.5 !<-- I index of parent V for child's west V boundary - PARENT_I_CHILD_EBND=PARENT_I_CHILD_WBND+(IM_CHILD-2)*RATIO_C_P !<-- I index of parent V for child's east V boundary - IM_END=IM_CHILD-1 - JM_END=JM_CHILD-1 - N_ADD=0 !<-- Blending region along child's boundary - ! increased only for mass points (for PD averaging) - ENDIF -! -!----------------------------------------------------------------------- -!*** Check to see if the child domain is too near to the parent -!*** domain's boundary. -!----------------------------------------------------------------------- -! - IF(PARENT_J_CHILD_SBND<=JDS+2)THEN - WRITE(0,20221)N_CHILD,MY_DOMAIN_ID - WRITE(0,20222)PARENT_J_CHILD_SBND,JDS,FLAG_H_OR_V -20221 FORMAT(' Child #',I2,' is within 2 points of the south' & - ,' boundary of domain #',I2) -20222 FORMAT(' Parent J of child Sbndry=',e12.5,' parent jds=',i3,' flag_h_or_v=',a) - WRITE(0,*)' ABORTING!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - IF(PARENT_J_CHILD_NBND>=JDE-2)THEN - WRITE(0,20223)N_CHILD,MY_DOMAIN_ID - WRITE(0,20224)PARENT_J_CHILD_NBND,JDE,FLAG_H_OR_V -20223 FORMAT(' Child #',I2,' is within 2 points of the north' & - ,' boundary of domain #',I2) -20224 FORMAT(' Parent J of child Nbndry=',e12.5,' parent jde=',i3,' flag_h_or_v=',a) - WRITE(0,*)' ABORTING!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - IF(PARENT_I_CHILD_WBND<=IDS+2)THEN - WRITE(0,20225)N_CHILD,MY_DOMAIN_ID - WRITE(0,20226)PARENT_I_CHILD_WBND,IDS,FLAG_H_OR_V -20225 FORMAT(' Child #',I2,' is within 2 points of the west' & - ,' boundary of domain #',I2) -20226 FORMAT(' Parent I of child Wbndry=',e12.5,' parent ids=',i3,' flag_h_or_v=',a) - WRITE(0,*)' ABORTING!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - IF(PARENT_I_CHILD_EBND>=IDE+2)THEN - WRITE(0,20227)N_CHILD,MY_DOMAIN_ID - WRITE(0,20228)PARENT_I_CHILD_EBND,IDE,FLAG_H_OR_V -20227 FORMAT(' Child #',I2,' is within 2 points of the east' & - ,' boundary of domain #',I2) -20228 FORMAT(' Parent I of child Ebndry=',e12.5,' parent ide=',i3,' flag_h_or_v=',a) - WRITE(0,*)' ABORTING!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! -!----------------------------------------------------------------------- -! - DO N=1,NUM_CHILD_TASKS !<-- Loop through forecast tasks on the child domain - ITS_CHILD(N)=LIMITS(1,N) !<-- ITS on this child task - ITE_CHILD(N)=LIMITS(2,N) !<-- ITE on this child task - JTS_CHILD(N)=LIMITS(3,N) !<-- JTS on this child task - JTE_CHILD(N)=LIMITS(4,N) !<-- JTE on this child task - I_LIMIT_LO(N)=MAX(ITS_CHILD(N)-2,1) !<-- Starting I's for each child task on N/S bndries (2-pt halo) - I_LIMIT_HI(N)=MIN(ITE_CHILD(N)+2+N_ADD,IM_END) !<-- Ending I's for each child task on N/S bndries (2-pt halo) - J_LIMIT_LO(N)=MAX(JTS_CHILD(N)-2,1) !<-- Starting J's for each child task on W/E bndries (2-pt halo) - J_LIMIT_HI(N)=MIN(JTE_CHILD(N)+2+N_ADD,JM_END) !<-- Ending J's for each child task on W/E bndries (2-pt halo) -! -!----------------------------------------------------------------------- -!*** If the northernmost/easternmost extra row of H bndry points -!*** on a nest task coincides with the southern/western boundary -!*** of a parent task then that parent task will not be associated -!*** with the nest since no bndry V points would be seen by the -!*** parent task. -!----------------------------------------------------------------------- -! - IF(FLAG_H_OR_V=='H_POINTS')THEN -! - PARENT_S_TASK_LIM_ON_NEST=REAL(JTS-J_PARENT_SW)*RATIO_P_C+1 !<-- South limit of parent task w/r to nest J - IF(J_LIMIT_HI(N)-PARENT_S_TASK_LIM_ON_NEST<=0.5)THEN - J_LIMIT_HI(N)=J_LIMIT_HI(N)-1 - ENDIF -! - PARENT_W_TASK_LIM_ON_NEST=REAL(ITS-I_PARENT_SW)*RATIO_P_C+1 !<-- West limit of parent task w/r to nest I - IF(I_LIMIT_HI(N)-PARENT_W_TASK_LIM_ON_NEST<=0.5)THEN - I_LIMIT_HI(N)=I_LIMIT_HI(N)-1 - ENDIF - ENDIF -! - ENDDO -! -!----------------------------------------------------- -!----------------------------------------------------- -!*** Child's southern/northern boundaries -! -!*** Work eastward along these boundaries -!*** and save the basic indices and weights -!*** needed by the parent. -!----------------------------------------------------- -!----------------------------------------------------- -! - NC_LAST_S=-1 - NC_LAST_N=-1 -! - NUM_TASKS_SEND_S=0 - NUM_TASKS_SEND_N=0 -! - IF(FLAG_H_OR_V=='H_POINTS')THEN - R_ITS=REAL(ITS)-EPS !<-- REAL Istart of parent task's subdomain for H on B grid - ELSEIF(FLAG_H_OR_V=='V_POINTS')THEN - R_ITS=REAL(ITS-0.5)-EPS !<-- REAL Istart of parent task's subdomain for V on B grid - ENDIF -! - ARG1=REAL(ITE)+ADD_INC - ARG2=REAL(IDE) - R_IEND=MIN(ARG1,ARG2)-2.*EPS !<-- REAL Iend of parent task's region for child N/S boundaries -! -!----------------------------------------------------- -! - REAL_I_START=PARENT_I_CHILD_WBND !<-- I index of parent H for child's west H boundary -! -!----------------------------------------------------------------------- - i_loop: DO I_CHILD=1,IM_END !<-- Loop over child I's across its South/North boundaries -!----------------------------------------------------------------------- -! - REAL_I_PARENT=REAL_I_START+(I_CHILD-1)*RATIO_C_P !<-- Parent I index coinciding with child domain point -! -!----------------------------------------------------------------------- -! -! i_block: IF(REAL_I_PARENT>=R_ITS.AND.REAL_I_PARENT<=R_IEND)THEN !<-- Column (I) of child's S/N bndry point lies on parent task? - i_block: IF(REAL_I_PARENT>=R_ITS.AND.REAL_I_PARENT< R_IEND)THEN !<-- Column (I) of child's S/N bndry point lies on parent task? -! -!----------- -!----------- -!*** South -!----------- -!----------- -! - REAL_J_START=PARENT_J_CHILD_SBND !<-- J index of parent H for child's south H boundary - KOUNT_J=0 -! - IF(FLAG_H_OR_V=='H_POINTS')THEN - R_JTS=REAL(JTS)-EPS !<-- REAL Jstart of parent task's subdomain for H on B grid - R_JEND=REAL(MIN(JTE+1,JDE))-EPS !<-- Allow search for child H boundary points to go into - ! the parent's halo. - ELSEIF(FLAG_H_OR_V=='V_POINTS')THEN - R_JTS =REAL(JTS-0.5)-EPS !<-- REAL Jstart of parent task's subdomain for V on B grid - ! (-0.5 yields same location on grid as R_JTS for H). - R_JEND=REAL(MIN(REAL(JTE+0.5),REAL(JDE)))-EPS !<-- Use JTE+0.5 to stop V search at the row of the - ! northernmost H that is searched; this ensures that - ! a parent will send both H and V boundary points. - ENDIF -! -!----------------------------------------------------------------------- -! - J_CHILD=1 -! -!----------------------------------------------------------------------- -!*** Which child task contains this (I_CHILD,J_CHILD) point? -!*** Find out then save the I limits of that task's boundary -!*** segment on this parent task so that the parent task -!*** will know exactly which words to send to the child task. -!*** Also remember that the NMM-B boundary update routines go -!*** two points into the halo which means that two child -!*** tasks will share some boundary points on the parent. -!----------------------------------------------------------------------- -! - child_ij_s: IF(REAL_J_START >=R_JTS.AND.REAL_J_START < R_JEND)THEN !<-- Does parent task see this row of its child? -! - DO NC=1,NUM_CHILD_TASKS !<-- Loop through all tasks on child domain -! - IF(I_CHILD>=I_LIMIT_LO(NC).AND. & !<-- Does current child boundary point on this - I_CHILD<=I_LIMIT_HI(NC) & ! parent task lie on child task "NC"? - .AND. & ! - J_CHILD>=JTS_CHILD(NC).AND. & ! - J_CHILD<=JTE_CHILD(NC))THEN -! - IF(NC>NC_LAST_S)THEN !<-- Encountered a new child task holding this S bndry point? - NUM_TASKS_SEND_S=NUM_TASKS_SEND_S+1 !<-- Then increment the S bndry counter of the child tasks - LOCAL_TASK_RANK_S(NUM_TASKS_SEND_S,1)=NC !<-- This child task's count in list of fcst tasks - LOCAL_TASK_RANK_S(NUM_TASKS_SEND_S,2)=CHILD_RANKS(NC-1) !<-- This child task's local rank in p-c intracomm - NC_LAST_S=NC - NC_HOLD_S(NC)=NUM_TASKS_SEND_S - ENDIF -! - IF(I_SAVE_LO_SOUTH(NC_HOLD_S(NC))<0)THEN - I_SAVE_LO_SOUTH(NC_HOLD_S(NC))=I_CHILD !<-- Save westernmost Sbndry I of child task NC - ! that is on this parent task. - ENDIF - I_SAVE_HI_SOUTH(NC_HOLD_S(NC))=I_CHILD !<-- Save easternmost Sbndry I of child task NC - ! that is on this parent task. -! - ENDIF -! - ENDDO -! -!----------------------------------------------------------------------- -! - j_south: DO J_CHILD=1,N_BLEND+N_ADD !<-- Blending region along child's southern boundary -! - KOUNT_J=KOUNT_J+1 - REAL_J_PARENT=REAL_J_START+(KOUNT_J-1)*RATIO_C_P !<-- REAL parent J for this child's J -! - I_INDX_SBND(I_CHILD,J_CHILD,1)=INT(REAL_I_PARENT+EPS) !<-- Parent I west of child's south boundary point - I_INDX_SBND(I_CHILD,J_CHILD,2)=INT(REAL_I_PARENT+EPS)+1 !<-- Parent I east of child's south boundary point - J_INDX_SBND(I_CHILD,J_CHILD,1)=INT(REAL_J_PARENT+EPS) !<-- Parent J south of child's south boundary point - J_INDX_SBND(I_CHILD,J_CHILD,2)=INT(REAL_J_PARENT+EPS)+1 !<-- Parent J north of child's south boundary point -! - WEIGHT_SW=(I_INDX_SBND(I_CHILD,J_CHILD,2)-REAL_I_PARENT)* & - (J_INDX_SBND(I_CHILD,J_CHILD,2)-REAL_J_PARENT) - WEIGHT_SE=(REAL_I_PARENT-I_INDX_SBND(I_CHILD,J_CHILD,1))* & - (J_INDX_SBND(I_CHILD,J_CHILD,2)-REAL_J_PARENT) - WEIGHT_NW=(I_INDX_SBND(I_CHILD,J_CHILD,2)-REAL_I_PARENT)* & - (REAL_J_PARENT-J_INDX_SBND(I_CHILD,J_CHILD,1)) - WEIGHT_NE=(REAL_I_PARENT-I_INDX_SBND(I_CHILD,J_CHILD,1))* & - (REAL_J_PARENT-J_INDX_SBND(I_CHILD,J_CHILD,1)) -! - RECIP_SUM=1./(WEIGHT_SW+WEIGHT_SE+WEIGHT_NW+WEIGHT_NE) -! - WEIGHTS_SBND(I_CHILD,J_CHILD,INDX_SW)=WEIGHT_SW*RECIP_SUM !<-- Bilin interp wght of parent point SW of child bndry point - WEIGHTS_SBND(I_CHILD,J_CHILD,INDX_SE)=WEIGHT_SE*RECIP_SUM !<-- Bilin interp wght of parent point SE of child bndry point - WEIGHTS_SBND(I_CHILD,J_CHILD,INDX_NW)=WEIGHT_NW*RECIP_SUM !<-- Bilin interp wght of parent point NW of child bndry point - WEIGHTS_SBND(I_CHILD,J_CHILD,INDX_NE)=WEIGHT_NE*RECIP_SUM !<-- Bilin interp wght of parent point NE of child bndry point -! - ENDDO j_south -! -!----------------------------------------------------------------------- - ENDIF child_ij_s -!----------------------------------------------------------------------- -! -! -!----------- -!----------- -!*** North -!----------- -!----------- -! - REAL_J_START=PARENT_J_CHILD_NBND - KOUNT_J=0 -! - IF(FLAG_H_OR_V=='H_POINTS')THEN - R_JTS=REAL(JTS)+EPS !<-- REAL Jstart of parent task's subdomain for H on B grid - R_JEND=REAL(MIN(JTE+1,JDE))+EPS !<-- Allow search for child H boundary points to go into - ! the parent's halo. - ELSEIF(FLAG_H_OR_V=='V_POINTS')THEN - R_JTS =REAL(JTS-0.5)+EPS !<-- REAL Jstart of parent task's subdomain for V on B grid - ! (-0.5 yields same location on grid as R_JTS for H). - R_JEND=REAL(MIN(REAL(JTE+0.5),REAL(JDE)))+EPS !<-- Use JTE+0.5 to stop V search at the row of the - ! northernmost H that is searched; this ensures that - ! a parent will send both H and V boundary points. - ENDIF -! -!----------------------------------------------------------------------- -! - J_CHILD=JM_END -! -!----------------------------------------------------------------------- -! - child_ij_n: IF(REAL_J_START >=R_JTS.AND.REAL_J_START < R_JEND)THEN !<-- Does parent task see this row of its child? -! -!----------------------------------------------------------------------- -! -!------------------------------------------------------------- -!*** Find the child tasks and their relevant limits -!*** along the child's northern boundary. -!------------------------------------------------------------- -! - DO NC=1,NUM_CHILD_TASKS !<-- Loop through all tasks on child domain - IF(I_CHILD>=I_LIMIT_LO(NC).AND. & !<-- Does current child boundary point on this - I_CHILD<=I_LIMIT_HI(NC) & ! parent task lie on child task "NC"? - .AND. & ! - J_CHILD>=JTS_CHILD(NC).AND. & ! - J_CHILD<=JTE_CHILD(NC))THEN -! - IF(NC>NC_LAST_N)THEN !<-- Have we encountered a new child task holding this N bndry? - NUM_TASKS_SEND_N=NUM_TASKS_SEND_N+1 !<-- Then increment the N bndry counter of the child tasks - LOCAL_TASK_RANK_N(NUM_TASKS_SEND_N,1)=NC !<-- This child task's count in list of fcst tasks - LOCAL_TASK_RANK_N(NUM_TASKS_SEND_N,2)=CHILD_RANKS(NC-1) !<-- This child task's local rank in p-c intracomm - NC_LAST_N=NC - NC_HOLD_N(NC)=NUM_TASKS_SEND_N - ENDIF -! - IF(I_SAVE_LO_NORTH(NC_HOLD_N(NC))<0)THEN - I_SAVE_LO_NORTH(NC_HOLD_N(NC))=I_CHILD !<-- Save westernmost Nbndry I of child task NC - ! that is on this parent task. - ENDIF - I_SAVE_HI_NORTH(NC_HOLD_N(NC))=I_CHILD !<-- Save easternmost Nbndry I of child task NC - ! that is on this parent task. -! - ENDIF -! - ENDDO -! -!----------------------------------------------------------------------- -! - j_north: DO J_CHILD=JM_END,JM_END-N_BLEND+1-N_ADD,-1 !<-- Blending region of child's northern boundary -! -!----------------------------------------------------------------------- -! - KOUNT_J=KOUNT_J+1 - REAL_J_PARENT=REAL_J_START-(KOUNT_J-1)*RATIO_C_P !<-- REAL parent J for this child's J -! - I_INDX_NBND(I_CHILD,J_CHILD,1)=INT(REAL_I_PARENT+EPS) !<-- Parent I west of child's north boundary point - I_INDX_NBND(I_CHILD,J_CHILD,2)=INT(REAL_I_PARENT+EPS)+1 !<-- Parent I east of child's north boundary point - J_INDX_NBND(I_CHILD,J_CHILD,1)=INT(REAL_J_PARENT+EPS) !<-- Parent J south of child's north boundary point - J_INDX_NBND(I_CHILD,J_CHILD,2)=INT(REAL_J_PARENT+EPS)+1 !<-- Parent J north of child's north boundary point -! - WEIGHT_SW=(I_INDX_NBND(I_CHILD,J_CHILD,2)-REAL_I_PARENT)* & - (J_INDX_NBND(I_CHILD,J_CHILD,2)-REAL_J_PARENT) - WEIGHT_SE=(REAL_I_PARENT-I_INDX_NBND(I_CHILD,J_CHILD,1))* & - (J_INDX_NBND(I_CHILD,J_CHILD,2)-REAL_J_PARENT) - WEIGHT_NW=(I_INDX_NBND(I_CHILD,J_CHILD,2)-REAL_I_PARENT)* & - (REAL_J_PARENT-J_INDX_NBND(I_CHILD,J_CHILD,1)) - WEIGHT_NE=(REAL_I_PARENT-I_INDX_NBND(I_CHILD,J_CHILD,1))* & - (REAL_J_PARENT-J_INDX_NBND(I_CHILD,J_CHILD,1)) -! - RECIP_SUM=1./(WEIGHT_SW+WEIGHT_SE+WEIGHT_NW+WEIGHT_NE) -! - WEIGHTS_NBND(I_CHILD,J_CHILD,INDX_SW)=WEIGHT_SW*RECIP_SUM !<-- Interp wght of parent point SW of child bndry point - WEIGHTS_NBND(I_CHILD,J_CHILD,INDX_SE)=WEIGHT_SE*RECIP_SUM !<-- Interp wght of parent point SE of child bndry point - WEIGHTS_NBND(I_CHILD,J_CHILD,INDX_NW)=WEIGHT_NW*RECIP_SUM !<-- Interp wght of parent point NW of child bndry point - WEIGHTS_NBND(I_CHILD,J_CHILD,INDX_NE)=WEIGHT_NE*RECIP_SUM !<-- Interp wght of parent point NE of child bndry point -! - ENDDO j_north -! -!----------------------------------------------------------------------- - ENDIF child_ij_n -!----------------------------------------------------------------------- -! - ENDIF i_block -! -!----------------------------------------------------------------------- -! - ENDDO i_loop -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------- -!----------------------------------------------------- -!*** Child's western/eastern boundaries -! -!*** Work northward along these boundaries -!*** and save the basic indices and weights -!*** needed by the parent. -!----------------------------------------------------- -!----------------------------------------------------- -! - NC_LAST_W=-1 - NC_LAST_E=-1 -! - NUM_TASKS_SEND_W=0 !<-- Parent task sends to this many child tasks on W bndry - NUM_TASKS_SEND_E=0 !<-- Parent task sends to this many child tasks on E bndry -! - IF(FLAG_H_OR_V=='H_POINTS')THEN - R_JTS=REAL(JTS)-EPS !<-- REAL Jstart of parent task's subdomain for H on B grid - ELSEIF(FLAG_H_OR_V=='V_POINTS')THEN - R_JTS=REAL(JTS-0.5)-EPS !<-- REAL Jstart of parent task's subdomain for V on B grid - ENDIF -! - ARG1=REAL(JTE)+ADD_INC - ARG2=REAL(JDE) - R_JEND=MIN(ARG1,ARG2)-2.*EPS !<-- REAL Jend of parent task's region for child W/E boundaries -! - REAL_J_START=PARENT_J_CHILD_SBND !<-- J index of parent H for child's south H boundary -! -!----------------------------------------------------------------------- - j_loop: DO J_CHILD=1,JM_END !<-- Loop through child J's across its W/E boundaries -!----------------------------------------------------------------------- - - REAL_J_PARENT=REAL_J_START+(J_CHILD-1)*RATIO_C_P !<-- Parent J index coinciding with child domain point -! -!----------------------------------------------------------------------- -! -! j_block: IF(REAL_J_PARENT>=R_JTS.AND.REAL_J_PARENT<=R_JEND)THEN !<-- Row (J) of child's W/E bndry point lies on parent task? - j_block: IF(REAL_J_PARENT>=R_JTS.AND.REAL_J_PARENT< R_JEND)THEN !<-- Row (J) of child's W/E bndry point lies on parent task? -! -!---------- -!---------- -!*** West -!---------- -!---------- -! - REAL_I_START=PARENT_I_CHILD_WBND - KOUNT_I=0 -! - IF(FLAG_H_OR_V=='H_POINTS')THEN - R_ITS=REAL(ITS)-EPS !<-- REAL Istart of parent task's subdomain for H on B grid - R_IEND=REAL(MIN(ITE+1,IDE))-EPS !<-- Allow search for child H boundary points to go into - ! the parent's halo. - ELSEIF(FLAG_H_OR_V=='V_POINTS')THEN - R_ITS =REAL(ITS-0.5)-EPS !<-- REAL Istart of parent task's subdomain for V on B grid - ! (-0.5 yields same location on grid as R_JTS for H). - R_IEND=REAL(MIN(REAL(ITE+0.5),REAL(IDE)))-EPS !<-- Use ITE+0.5 to stop V search at the row of the - ! northernmost H that is searched; this ensures that - ! a parent will send both H and V boundary points. - ENDIF -! -!----------------------------------------------------------------------- -! - I_CHILD=1 -! -!----------------------------------------------------------------------- -! - child_ij_w: IF(REAL_I_START >=R_ITS.AND.REAL_I_START < R_IEND)THEN !<-- Does parent task see this column of its child? -! -!----------------------------------------------------------------------- -! -!------------------------------------------------------------- -!*** Find the child tasks and their relevant limits -!*** along the child's western boundary. -!------------------------------------------------------------- -! - DO NC=1,NUM_CHILD_TASKS !<-- Loop through all tasks on child domain -! - IF(J_CHILD>=J_LIMIT_LO(NC).AND. & !<-- Does current child boundary point on this - J_CHILD<=J_LIMIT_HI(NC) & ! parent task lie on child task "NC"? - .AND. & ! - I_CHILD>=ITS_CHILD(NC).AND. & ! - I_CHILD<=ITE_CHILD(NC))THEN -! - IF(NC>NC_LAST_W)THEN !<-- Have we encountered a new child task holding this W bndry? - NUM_TASKS_SEND_W=NUM_TASKS_SEND_W+1 !<-- Then increment the W bndry counter of the child tasks - LOCAL_TASK_RANK_W(NUM_TASKS_SEND_W,1)=NC !<-- This child task's count in list of fcst tasks - LOCAL_TASK_RANK_W(NUM_TASKS_SEND_W,2)=CHILD_RANKS(NC-1) !<-- This child task's local rank in p-c intracomm - NC_LAST_W=NC - NC_HOLD_W(NC)=NUM_TASKS_SEND_W - ENDIF -! - IF(J_SAVE_LO_WEST(NC_HOLD_W(NC))<0)THEN - J_SAVE_LO_WEST(NC_HOLD_W(NC))=J_CHILD !<-- Save southernmost Wbndry J of child task NC - ! that is on this parent task. - ENDIF - J_SAVE_HI_WEST(NC_HOLD_W(NC))=J_CHILD !<-- Save northernmost Wbndry J of child task NC - ! that is on this parent task. -! - ENDIF -! - ENDDO -! -!------------------------------------------------------------- - i_west: DO I_CHILD=1,N_BLEND+N_ADD !<-- Blending region of child's western boundary -!------------------------------------------------------------- -! - KOUNT_I=KOUNT_I+1 - REAL_I_PARENT=REAL_I_START+(KOUNT_I-1)*RATIO_C_P !<-- REAL parent I for this child's I -! - I_INDX_WBND(I_CHILD,J_CHILD,1)=INT(REAL_I_PARENT+EPS) !<-- Parent I west of child's west boundary point - I_INDX_WBND(I_CHILD,J_CHILD,2)=INT(REAL_I_PARENT+EPS)+1 !<-- Parent I east of child's west boundary point - J_INDX_WBND(I_CHILD,J_CHILD,1)=INT(REAL_J_PARENT+EPS) !<-- Parent J south of child's west boundary point - J_INDX_WBND(I_CHILD,J_CHILD,2)=INT(REAL_J_PARENT+EPS)+1 !<-- Parent J north of child's west boundary point -! - WEIGHT_SW=(I_INDX_WBND(I_CHILD,J_CHILD,2)-REAL_I_PARENT)* & - (J_INDX_WBND(I_CHILD,J_CHILD,2)-REAL_J_PARENT) - WEIGHT_SE=(REAL_I_PARENT-I_INDX_WBND(I_CHILD,J_CHILD,1))* & - (J_INDX_WBND(I_CHILD,J_CHILD,2)-REAL_J_PARENT) - WEIGHT_NW=(I_INDX_WBND(I_CHILD,J_CHILD,2)-REAL_I_PARENT)* & - (REAL_J_PARENT-J_INDX_WBND(I_CHILD,J_CHILD,1)) - WEIGHT_NE=(REAL_I_PARENT-I_INDX_WBND(I_CHILD,J_CHILD,1))* & - (REAL_J_PARENT-J_INDX_WBND(I_CHILD,J_CHILD,1)) -! - RECIP_SUM=1./(WEIGHT_SW+WEIGHT_SE+WEIGHT_NW+WEIGHT_NE) -! - WEIGHTS_WBND(I_CHILD,J_CHILD,INDX_SW)=WEIGHT_SW*RECIP_SUM !<-- Interp wght of parent point SW of child bndry point - WEIGHTS_WBND(I_CHILD,J_CHILD,INDX_SE)=WEIGHT_SE*RECIP_SUM !<-- Interp wght of parent point SE of child bndry point - WEIGHTS_WBND(I_CHILD,J_CHILD,INDX_NW)=WEIGHT_NW*RECIP_SUM !<-- Interp wght of parent point NW of child bndry point - WEIGHTS_WBND(I_CHILD,J_CHILD,INDX_NE)=WEIGHT_NE*RECIP_SUM !<-- Interp wght of parent point NE of child bndry point -! - ENDDO i_west -! -!----------------------------------------------------------------------- - ENDIF child_ij_w -!----------------------------------------------------------------------- -! -!---------- -!---------- -!*** East -!---------- -!---------- -! - REAL_I_START=PARENT_I_CHILD_EBND !<-- I index of parent H for child's east H boundary - KOUNT_I=0 -! - IF(FLAG_H_OR_V=='H_POINTS')THEN - R_ITS=REAL(ITS)+EPS !<-- REAL Istart of parent task's subdomain for H on B grid - R_IEND=REAL(MIN(ITE+1,IDE))+EPS !<-- Allow search for child H boundary points to go into - ! the parent's halo. - ELSEIF(FLAG_H_OR_V=='V_POINTS')THEN - R_ITS =REAL(ITS-0.5)+EPS !<-- REAL Istart of parent task's subdomain for V on B grid - ! (-0.5 yields same location on grid as R_JTS for H). - R_IEND=REAL(MIN(REAL(ITE+0.5),REAL(IDE)))+EPS !<-- Use ITE+0.5 to stop V search at the row of the - ! northernmost H that is searched; this ensures that - ! a parent will send both H and V boundary points. - ENDIF -! -!----------------------------------------------------------------------- -!*** Recall that we need an additional row of H points to allow 4-pt -!*** averaging of PD to V points. We need only to search for the -!*** westernmost child J row of the east boundary blending region with -!*** the extra row because if that child I is on a parent task then -!*** all of the blending region must be on that task since we are -!*** permitting the search to go into the parent tasks' haloes. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! - I_CHILD=IM_END -! -!----------------------------------------------------------------------- -! - child_ij_e: IF(REAL_I_START >=R_ITS.AND.REAL_I_START < R_IEND)THEN !<-- Does parent task see this column of its child? -! -!----------------------------------------------------------------------- -!------------------------------------------------------------- -!*** Find the child tasks and their relevant limits -!*** along the child's eastern boundary. -!------------------------------------------------------------- -! - DO NC=1,NUM_CHILD_TASKS !<-- Loop through all tasks on child domain -! - IF(J_CHILD>=J_LIMIT_LO(NC).AND. & !<-- Does current child boundary point on this - J_CHILD<=J_LIMIT_HI(NC) & ! parent task lie on child task "NC"? - .AND. & ! - I_CHILD>=ITS_CHILD(NC).AND. & ! - I_CHILD<=ITE_CHILD(NC))THEN -! - IF(NC>NC_LAST_E)THEN !<-- Have we encountered a new child task holding this E bndry? - NUM_TASKS_SEND_E=NUM_TASKS_SEND_E+1 !<-- Then increment the E bndry counter of the child tasks - LOCAL_TASK_RANK_E(NUM_TASKS_SEND_E,1)=NC !<-- This child task's count in list of fcst tasks - LOCAL_TASK_RANK_E(NUM_TASKS_SEND_E,2)=CHILD_RANKS(NC-1) !<-- This child task's local rank in p-c intracomm - NC_LAST_E=NC - NC_HOLD_E(NC)=NUM_TASKS_SEND_E - ENDIF -! - IF(J_SAVE_LO_EAST(NC_HOLD_E(NC))<0)THEN - J_SAVE_LO_EAST(NC_HOLD_E(NC))=J_CHILD !<-- Save southernmost Ebndry J of child task NC - ! that is on this parent task. - ENDIF - J_SAVE_HI_EAST(NC_HOLD_E(NC))=J_CHILD !<-- Save northernmost Ebndry J of child task NC - ! that is on this parent task. -! - ENDIF -! - ENDDO -! -!----------------------------------------------------------------------- -! - i_east: DO I_CHILD=IM_END,IM_END-N_BLEND+1-N_ADD,-1 !<-- Blending region of child's eastern boundary -! - KOUNT_I=KOUNT_I+1 - REAL_I_PARENT=REAL_I_START-(KOUNT_I-1)*RATIO_C_P !<-- REAL parent I for this child's I -! - I_INDX_EBND(I_CHILD,J_CHILD,1)=INT(REAL_I_PARENT+EPS) !<-- Parent I west of child's east boundary point - I_INDX_EBND(I_CHILD,J_CHILD,2)=INT(REAL_I_PARENT+EPS)+1 !<-- Parent I east of child's east boundary point - J_INDX_EBND(I_CHILD,J_CHILD,1)=INT(REAL_J_PARENT+EPS) !<-- Parent J south of child's east boundary point - J_INDX_EBND(I_CHILD,J_CHILD,2)=INT(REAL_J_PARENT+EPS)+1 !<-- Parent J north of child's east boundary point -! - WEIGHT_SW=(I_INDX_EBND(I_CHILD,J_CHILD,2)-REAL_I_PARENT)* & - (J_INDX_EBND(I_CHILD,J_CHILD,2)-REAL_J_PARENT) - WEIGHT_SE=(REAL_I_PARENT-I_INDX_EBND(I_CHILD,J_CHILD,1))* & - (J_INDX_EBND(I_CHILD,J_CHILD,2)-REAL_J_PARENT) - WEIGHT_NW=(I_INDX_EBND(I_CHILD,J_CHILD,2)-REAL_I_PARENT)* & - (REAL_J_PARENT-J_INDX_EBND(I_CHILD,J_CHILD,1)) - WEIGHT_NE=(REAL_I_PARENT-I_INDX_EBND(I_CHILD,J_CHILD,1))* & - (REAL_J_PARENT-J_INDX_EBND(I_CHILD,J_CHILD,1)) -! - RECIP_SUM=1./(WEIGHT_SW+WEIGHT_SE+WEIGHT_NW+WEIGHT_NE) -! - WEIGHTS_EBND(I_CHILD,J_CHILD,INDX_SW)=WEIGHT_SW*RECIP_SUM !<-- Interp wght of parent point SW of child bndry point - WEIGHTS_EBND(I_CHILD,J_CHILD,INDX_SE)=WEIGHT_SE*RECIP_SUM !<-- Interp wght of parent point SE of child bndry point - WEIGHTS_EBND(I_CHILD,J_CHILD,INDX_NW)=WEIGHT_NW*RECIP_SUM !<-- Interp wght of parent point NW of child bndry point - WEIGHTS_EBND(I_CHILD,J_CHILD,INDX_NE)=WEIGHT_NE*RECIP_SUM !<-- Interp wght of parent point NE of child bndry point -! - ENDDO i_east -! -!----------------------------------------------------------------------- - ENDIF child_ij_e -!----------------------------------------------------------------------- -! - ENDIF j_block -! -!----------------------------------------------------------------------- -! - ENDDO j_loop -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PARENT_TO_CHILD_INTERP_FACTORS -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE POINT_INTERP_DATA_TO_MEMORY(N_CHILD & - ,MY_DOMAIN_ID & - ,TIME_FLAG) -! -!----------------------------------------------------------------------- -!*** Create unallocated working pointers for nest boundary variables -!*** and point them into the allocated composite pointer that holds -!*** all of a parent task's data it will send to each child boundary -!*** task it covers. Nest boundary pressure though must be allocated -!*** because it contains more data than is transferred since we need -!*** extra points in order to do the 4-pt averaging to the nest -!*** boundary V points for hydrostatic balancing of the boundary -!*** data. -! -!*** Only parents execute this routine. -!----------------------------------------------------------------------- -! -!----------------------- -!*** Argument Variables -!----------------------- -! - INTEGER(kind=KINT),INTENT(IN) :: N_CHILD & !<-- This child is being handled. - ,MY_DOMAIN_ID !<-- The parent domain's ID -! - CHARACTER(*),INTENT(IN) :: TIME_FLAG !<-- Current or future boundary data for the child? -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: I_END_TRANSFER,ITE_CHILD_X,INDX2 & - ,J_END_TRANSFER,JTE_CHILD_X & - ,KOUNT_VAR,N,N_TASK & - ,NBASE,NBASE_3D,NBASE_4D,NBASE_EXP & - ,NCHILD_TASKS & - ,NLOC_1,NLOC_2,NLOC_2_EXP & - ,NN,NT,NV,NVAR,NWORDS,PROD -! - INTEGER(kind=KINT) :: ISTAT -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - N=N_CHILD -! -!----------------------------------------------------------------------- -!*** Select the appropriate part of the working array depending on -!*** whether we are now concerned with children's boundaries for -!*** their current time or for their future. -!----------------------------------------------------------------------- -! - IF(TIME_FLAG=='Future')THEN - INDX2=1 - ELSEIF(TIME_FLAG=='Current')THEN - INDX2=2 - ENDIF -! -!----------------------------------------------------------------------- -!*** For each child domain on this parent, create the working pointers -!*** for the nest boundary variables for each child boundary task -!*** and point them into the allocated composite data pointer that -!*** holds all the data for transfer. Nest boundary pressure is -!*** treated differently by allocating it and eventually copying it -!*** directly into the composite data pointer. -! -!*** Set logical flags so parent tasks know if they must send any -!*** data at all to any nest boundary tasks. -! -!*** Allocate/nullify new MPI handles for the most recent association -!*** between parent tasks and nest boundary tasks for the ISends of -!*** data to the nest boundaries. -!----------------------------------------------------------------------- -! -!----------- -!*** South -!----------- -! - south_h: IF(NUM_TASKS_SEND_H_S(N)>0)THEN !<-- Parent task has child south boundary H points? -! - NCHILD_TASKS=NUM_TASKS_SEND_H_S(N) !<-- # of Sbndry tasks on child N to recv H point data - ALLOCATE(CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS(1:NCHILD_TASKS) & !<-- 1-D bndry data string for child tasks with Sbndry H points - ,stat=ISTAT) - ALLOCATE(WORDS_BOUND_H_SOUTH(N)%TASKS(1:NCHILD_TASKS)) !<-- # of words in Sbndry H point 1-D data string - ALLOCATE(PD_B_SOUTH(N)%TASKS(1:NCHILD_TASKS)) !<-- PD_B_SOUTH for each child task -! - DO NVAR=1,NVARS_NESTBC_H-1 !<-- All nest 3D BC H-pt variables (excludes PD) - ALLOCATE(BND_VAR_H_SOUTH(NVAR)%CHILD(N)%TASKS(1:NCHILD_TASKS) & !<-- Working object for each 3D Sbnd H-pt vbl on each child task - ,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,11101)NVAR,N,NCHILD_TASKS,ISTAT -11101 FORMAT(' POINT_INTERP_DATA_TO_MEMORY failed to allocate' & - ,' BND_VAR(',I2,')%CHILD(',I2,')%TASKS(1:',I4,')' & - ,' ISTAT=',I4) - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT) - ENDIF - ENDDO -! -!----------------------------------------------------------------------- -! - nt_south_h: DO NT=1,NCHILD_TASKS -! - N_TASK=CHILDTASK_BNDRY_H_RANKS(N)%SOUTH(NT,1) !<-- Count of this task in list of all child fcst tasks -! - NBASE=CHILDTASK_H_SAVE(N)%I_HI_SOUTH_TRANSFER(NT) & - -CHILDTASK_H_SAVE(N)%I_LO_SOUTH(NT)+1 -! - PROD=NBASE*N_BLEND_H_CHILD(N) - NBASE_3D=LM*PROD - NWORDS=(NVARS_BC_2D_H+NVARS_BC_3D_H*LM)*PROD !<-- # of Sbndry words in 2D,3D H-pt vbls parent sends to child -! - KOUNT_VAR=0 - IF(NVARS_BC_2D_H>1)THEN - DO NV=2,NVARS_BC_2D_H - KOUNT_VAR=KOUNT_VAR+1 !<-- Count 2-D H-pt vbls excluding PD - NBASE_VAR_H(KOUNT_VAR)=NBASE - ENDDO - ENDIF -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - KOUNT_VAR=KOUNT_VAR+1 !<-- Add the 3-D H-pt vbls - NBASE_VAR_H(KOUNT_VAR)=NBASE_3D - ENDDO - ENDIF -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - NBASE_4D=(UBND_4D(NV)-LBND_4D(NV)+1)*NBASE_3D - KOUNT_VAR=KOUNT_VAR+1 !<-- Add the 4-D H-pt vbls - NBASE_VAR_H(KOUNT_VAR)=NBASE_4D - NWORDS=NWORDS+(UBND_4D(NV)-LBND_4D(NV)+1)*NBASE_3D !<-- Add the # of Sbndry words in 4-D H-pt variables - ENDDO - ENDIF -! - WORDS_BOUND_H_SOUTH(N)%TASKS(NT)=NWORDS !<-- Save total number of words -! - CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS(NT)%DATA=>NULL() - CALL CHECK_REAL(CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS(NT)%DATA & - ,'CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS(NT)%DATA') - ALLOCATE(CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS(NT)%DATA(1:NWORDS)) !<-- 1-D bndry data string for child tasks -! with South boundary H points - NLOC_1=1 - NLOC_2=NLOC_1+NBASE*N_BLEND_H_CHILD(N)-1 -! - NBASE_EXP=CHILDTASK_H_SAVE(N)%I_HI_SOUTH(NT) & - -CHILDTASK_H_SAVE(N)%I_LO_SOUTH(NT)+1 -! - NLOC_2_EXP=NLOC_1+NBASE_EXP*(N_BLEND_H_CHILD(N)+1)-1 !<-- Extend PD_B_* to allow 4-pt averaging to V pts -! - PD_B_SOUTH(N)%TASKS(NT)%DATA=>NULL() - CALL CHECK_REAL(PD_B_SOUTH(N)%TASKS(NT)%DATA & - ,'PD_B_SOUTH(N)%TASKS(NT)%DATA') - ALLOCATE(PD_B_SOUTH(N)%TASKS(NT)%DATA(NLOC_1:NLOC_2_EXP),stat=ISTAT) -! -!----------------------------------------------------------------------- -!*** Point the working pointer for each nest H-pt boundary variable -!*** into the object that holds all nest BC update data for child N's -!*** domain's south side. -!----------------------------------------------------------------------- -! - DO NVAR=1,NVARS_NESTBC_H-1 -! - NLOC_1=NLOC_2+1 !<-- Start at NLOC_2, NOT NLOC_2_EXPAND - NLOC_2=NLOC_1+NBASE_VAR_H(NVAR)-1 - BND_VAR_H_SOUTH(NVAR)%CHILD(N)%TASKS(NT)%DATA=> & - CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS(NT)%DATA(NLOC_1:NLOC_2) !<-- Sbndry storage for H-pt vbl NVAR, child N, task NT -! - ENDDO -! - ENDDO nt_south_h -! - ELSE south_h !<-- Dummy nonzero length -! - ALLOCATE(CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS(1:1)) - CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS(1)%DATA=>NULL() - CALL CHECK_REAL(CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS(1)%DATA & - ,'CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS(1)%DATA') - ALLOCATE(CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS(1)%DATA(1:1)) - ALLOCATE(PD_B_SOUTH(N)%TASKS(1:1)) - PD_B_SOUTH(N)%TASKS(1)%DATA=>NULL() - CALL CHECK_REAL(PD_B_SOUTH(N)%TASKS(1)%DATA & - ,'PD_B_SOUTH(N)%TASKS(1)%DATA') - ALLOCATE(PD_B_SOUTH(N)%TASKS(1)%DATA(1:1),stat=ISTAT) -! - DO NVAR=1,NVARS_NESTBC_H-1 - ALLOCATE(BND_VAR_H_SOUTH(NVAR)%CHILD(N)%TASKS(1:1),stat=ISTAT) - IF(ISTAT>0)THEN - WRITE(0,11201)NVAR,N,ISTAT -11201 FORMAT(' POINT_INTERP_DATA_TO_MEMORY failed to allocate' & - ,' dummy BND_VAR(',I2,')%CHILD(',I2,')%TASKS(1:1)' & - ,' ISTAT=',I4) - ENDIF - BND_VAR_H_SOUTH(NVAR)%CHILD(N)%TASKS(1)%DATA=>NULL() - ENDDO -! - ALLOCATE(WORDS_BOUND_H_SOUTH(N)%TASKS(1:1)) -! - ENDIF south_h -! -!----------------------------------------------------------------------- -! - south_v: IF(NUM_TASKS_SEND_V_S(N)>0)THEN !<-- Parent task has child south boundary V points? -! - NCHILD_TASKS=NUM_TASKS_SEND_V_S(N) - ALLOCATE(CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS(1:NCHILD_TASKS)) !<-- 1-D bndry data string for child tasks with Sbndry V points - ALLOCATE(WORDS_BOUND_V_SOUTH(N)%TASKS(1:NCHILD_TASKS)) !<-- # of words in Sbndry V point 1-D data string -! - ALLOCATE(PD_B_SOUTH_V(N)%TASKS(1:NCHILD_TASKS)) !<-- PD_B_SOUTH_V for each child task -! - DO NVAR=1,NVARS_NESTBC_V !<-- All nest 3D BC V-pt variables - ALLOCATE(BND_VAR_V_SOUTH(NVAR)%CHILD(N)%TASKS(1:NCHILD_TASKS)) !<-- Working object for each 3D Sbnd V-pt vbl on each child task - ENDDO -! - DO NT=1,NCHILD_TASKS - NBASE =CHILDTASK_V_SAVE(N)%I_HI_SOUTH(NT) & - -CHILDTASK_V_SAVE(N)%I_LO_SOUTH(NT)+1 - PROD=NBASE*N_BLEND_V_CHILD(N) - NBASE_3D=LM*PROD - NWORDS=(NVARS_BC_2D_V+NVARS_BC_3D_V*LM)*PROD !<-- # of Sbndry words in 2D,3D V-pt vbls parent sends to child - WORDS_BOUND_V_SOUTH(N)%TASKS(NT)=NWORDS !<-- Save total number of words -! - KOUNT_VAR=0 - IF(NVARS_BC_2D_V>0)THEN - DO NV=2,NVARS_BC_2D_V - KOUNT_VAR=KOUNT_VAR+1 !<-- Count 2-D H-pt vbls excluding PD - NBASE_VAR_V(KOUNT_VAR)=NBASE - ENDDO - ENDIF -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - KOUNT_VAR=KOUNT_VAR+1 !<-- Add the 3-D H-pt vbls - NBASE_VAR_V(KOUNT_VAR)=NBASE_3D - ENDDO - ENDIF -! - CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS(NT)%DATA=>NULL() - CALL CHECK_REAL(CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS(NT)%DATA & - ,'CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS(NT)%DATA') - ALLOCATE(CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS(NT)%DATA(1:NWORDS)) !<-- 1-D bndry data string for child tasks with Sbndry V points -! - PD_B_SOUTH_V(N)%TASKS(NT)%DATA=>NULL() - CALL CHECK_REAL(PD_B_SOUTH_V(N)%TASKS(NT)%DATA & - ,'PD_B_SOUTH_V(N)%TASKS(NT)%DATA') - ALLOCATE(PD_B_SOUTH_V(N)%TASKS(NT)%DATA(1:NBASE*N_BLEND_V_CHILD(N)),stat=ISTAT) -! -!----------------------------------------------------------------------- -!*** Point the working pointer for each nest V-pt boundary variable -!*** into the object that holds all nest BC update data for child N's -!*** domain's south side. -!----------------------------------------------------------------------- -! - NLOC_2=0 - DO NVAR=1,NVARS_NESTBC_V -! - NLOC_1=NLOC_2+1 - NLOC_2=NLOC_1+NBASE_VAR_V(NVAR)-1 - BND_VAR_V_SOUTH(NVAR)%CHILD(N)%TASKS(NT)%DATA=> & - CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS(NT)%DATA(NLOC_1:NLOC_2) !<-- S bndry storage for V-pt vbl NVAR, child N, task NT -! - ENDDO -! - ENDDO -! - ELSE south_v !<-- Dummy nonzero length -! - ALLOCATE(CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS(1:1)) - CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS(1)%DATA=>NULL() - CALL CHECK_REAL(CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS(1)%DATA & - ,'CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS(1)%DATA') - ALLOCATE(CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS(1)%DATA(1:1)) - ALLOCATE(PD_B_SOUTH_V(N)%TASKS(1:1)) - PD_B_SOUTH_V(N)%TASKS(1)%DATA=>NULL() - CALL CHECK_REAL(PD_B_SOUTH_V(N)%TASKS(1)%DATA & - ,'PD_B_SOUTH_V(N)%TASKS(1)%DATA') - ALLOCATE(PD_B_SOUTH_V(N)%TASKS(1)%DATA(1:1),stat=ISTAT) -! - DO NVAR=1,NVARS_NESTBC_V - ALLOCATE(BND_VAR_V_SOUTH(NVAR)%CHILD(N)%TASKS(1:1)) - BND_VAR_V_SOUTH(NVAR)%CHILD(N)%TASKS(1)%DATA=>NULL() - ENDDO -! - ALLOCATE(WORDS_BOUND_V_SOUTH(N)%TASKS(1:1)) -! - ENDIF south_v -! -!------------------------------------------------------------------------ -! -!----------- -!*** North -!----------- -! - north_h: IF(NUM_TASKS_SEND_H_N(N)>0)THEN !<-- Parent task has child north boundary H points? -! - NCHILD_TASKS=NUM_TASKS_SEND_H_N(N) - ALLOCATE(CHILD_BOUND_H_NORTH(N,INDX2)%TASKS(1:NCHILD_TASKS) & !<-- 1-D bndry data string for child tasks with Nbndry H points - ,stat=ISTAT) - ALLOCATE(WORDS_BOUND_H_NORTH(N)%TASKS(1:NCHILD_TASKS)) !<-- # of words in Nbndry H point 1-D data string - ALLOCATE(PD_B_NORTH(N)%TASKS(1:NCHILD_TASKS)) !<-- PD_B_NORTH for each child task -! - DO NVAR=1,NVARS_NESTBC_H-1 !<-- All nest 3D BC H-pt variables (excludes PD) - ALLOCATE(BND_VAR_H_NORTH(NVAR)%CHILD(N)%TASKS(1:NCHILD_TASKS)) !<-- Working object for each 3D Nbnd H-pt vbl on each child task - ENDDO -! - nt_north_h: DO NT=1,NCHILD_TASKS -! - N_TASK=CHILDTASK_BNDRY_H_RANKS(N)%NORTH(NT,1) !<-- Count of this task in list of all child fcst tasks -! -!------------------------------------------------------------------------ -! - NBASE=CHILDTASK_H_SAVE(N)%I_HI_NORTH_TRANSFER(NT) & - -CHILDTASK_H_SAVE(N)%I_LO_NORTH(NT)+1 -! - PROD=NBASE*N_BLEND_H_CHILD(N) - NBASE_3D=LM*NBASE*N_BLEND_H_CHILD(N) - NWORDS=(NVARS_BC_2D_H+NVARS_BC_3D_H*LM)*PROD !<-- # of Nbndry words in 2D,3D H-pt vbls parent sends to child - WORDS_BOUND_H_NORTH(N)%TASKS(NT)=NWORDS !<-- Save total number of words -! - KOUNT_VAR=0 - IF(NVARS_BC_2D_H>1)THEN - DO NV=2,NVARS_BC_2D_H - KOUNT_VAR=KOUNT_VAR+1 !<-- Count 2-D H-pt vbls excluding PD - NBASE_VAR_H(KOUNT_VAR)=NBASE - ENDDO - ENDIF -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - KOUNT_VAR=KOUNT_VAR+1 !<-- Add the 3-D H-pt vbls - NBASE_VAR_H(KOUNT_VAR)=NBASE_3D - ENDDO - ENDIF -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - NBASE_4D=(UBND_4D(NV)-LBND_4D(NV)+1)*NBASE_3D - KOUNT_VAR=KOUNT_VAR+1 !<-- Add the 4-D H-pt vbls - NBASE_VAR_H(KOUNT_VAR)=NBASE_4D - NWORDS=NWORDS+(UBND_4D(NV)-LBND_4D(NV)+1)*NBASE_3D !<-- Add the # of Nbndry words in 4-D H-pt variables - ENDDO - ENDIF -! - CHILD_BOUND_H_NORTH(N,INDX2)%TASKS(NT)%DATA=>NULL() - CALL CHECK_REAL(CHILD_BOUND_H_NORTH(N,INDX2)%TASKS(NT)%DATA & - ,'CHILD_BOUND_H_NORTH(N,INDX2)%TASKS(NT)%DATA') - ALLOCATE(CHILD_BOUND_H_NORTH(N,INDX2)%TASKS(NT)%DATA(1:NWORDS) & !<-- 1-D bndry data string for child tasks - ,stat=ISTAT) ! with north boundary H points. - NLOC_1=1 - NLOC_2=NLOC_1+NBASE*N_BLEND_H_CHILD(N)-1 -! - NBASE_EXP=CHILDTASK_H_SAVE(N)%I_HI_NORTH(NT) & - -CHILDTASK_H_SAVE(N)%I_LO_NORTH(NT)+1 -! - NLOC_2_EXP=NLOC_1+NBASE_EXP*(N_BLEND_H_CHILD(N)+1)-1 !<-- Extend PD_B_* by one row to allow 4-pt averaging to V pts -! - PD_B_NORTH(N)%TASKS(NT)%DATA=>NULL() - CALL CHECK_REAL(PD_B_NORTH(N)%TASKS(NT)%DATA & - ,'PD_B_NORTH(N)%TASKS(NT)%DATA') - ALLOCATE(PD_B_NORTH(N)%TASKS(NT)%DATA(NLOC_1:NLOC_2_EXP) & - ,stat=ISTAT) -! -!----------------------------------------------------------------------- -!*** Point the working pointer for each nest H-pt boundary variable -!*** into the object that holds all nest BC update data for child N's -!*** domain's north side. -!----------------------------------------------------------------------- -! - DO NVAR=1,NVARS_NESTBC_H-1 -! - NLOC_1=NLOC_2+1 !<-- Start at NLOC_2, NOT NLOC_2_EXPAND - NLOC_2=NLOC_1+NBASE_VAR_H(NVAR)-1 - BND_VAR_H_NORTH(NVAR)%CHILD(N)%TASKS(NT)%DATA=> & - CHILD_BOUND_H_NORTH(N,INDX2)%TASKS(NT)%DATA(NLOC_1:NLOC_2) !<-- N bndry storage for H-pt vbl NVAR, child N, task NT -! - ENDDO -! - ENDDO nt_north_h -! - ELSE north_h !<-- Dummy nonzero length -! - ALLOCATE(CHILD_BOUND_H_NORTH(N,INDX2)%TASKS(1:1)) - CHILD_BOUND_H_NORTH(N,INDX2)%TASKS(1)%DATA=>NULL() - CALL CHECK_REAL(CHILD_BOUND_H_NORTH(N,INDX2)%TASKS(1)%DATA & - ,'CHILD_BOUND_H_NORTH(N,INDX2)%TASKS(1)%DATA') - ALLOCATE(CHILD_BOUND_H_NORTH(N,INDX2)%TASKS(1)%DATA(1:1) & - ,stat=ISTAT) - ALLOCATE(PD_B_NORTH(N)%TASKS(1:1)) - PD_B_NORTH(N)%TASKS(1)%DATA=>NULL() - CALL CHECK_REAL(PD_B_NORTH(N)%TASKS(1)%DATA & - ,'PD_B_NORTH(N)%TASKS(1)%DATA') - ALLOCATE(PD_B_NORTH(N)%TASKS(1)%DATA(1:1),stat=ISTAT) -! - DO NVAR=1,NVARS_NESTBC_H-1 - ALLOCATE(BND_VAR_H_NORTH(NVAR)%CHILD(N)%TASKS(1:1)) - ENDDO -! - ALLOCATE(WORDS_BOUND_H_NORTH(N)%TASKS(1:1)) -! - ENDIF north_h -! -!------------------------------------------------------------------------ -! - north_v: IF(NUM_TASKS_SEND_V_N(N)>0)THEN !<-- Parent task has child north boundary V points? -! - NCHILD_TASKS=NUM_TASKS_SEND_V_N(N) - ALLOCATE(CHILD_BOUND_V_NORTH(N,INDX2)%TASKS(1:NCHILD_TASKS)) !<-- 1-D bndry data string for child tasks with Nbndry V points - ALLOCATE(WORDS_BOUND_V_NORTH(N)%TASKS(1:NCHILD_TASKS)) !<-- # of words in Nbndry V point 1-D data string -! - ALLOCATE(PD_B_NORTH_V(N)%TASKS(1:NCHILD_TASKS)) !<-- PD_B_NORTH_V for each child task -! - DO NVAR=1,NVARS_NESTBC_V !<-- All nest 3D BC V-pt variables - ALLOCATE(BND_VAR_V_NORTH(NVAR)%CHILD(N)%TASKS(1:NCHILD_TASKS)) !<-- Working object for each 3D Nbnd V-pt vbl on each child task - ENDDO -! - DO NT=1,NCHILD_TASKS - NBASE=CHILDTASK_V_SAVE(N)%I_HI_NORTH(NT) & - -CHILDTASK_V_SAVE(N)%I_LO_NORTH(NT)+1 - PROD=NBASE*N_BLEND_V_CHILD(N) - NBASE_3D=LM*PROD - NWORDS=(NVARS_BC_2D_V+NVARS_BC_3D_V*LM)*PROD !<-- # of Nbndry words in 2D,3D V-pt vbls parent sends to child - WORDS_BOUND_V_NORTH(N)%TASKS(NT)=NWORDS !<-- Save total number of words -! - KOUNT_VAR=0 - IF(NVARS_BC_2D_V>0)THEN - DO NV=2,NVARS_BC_2D_V - KOUNT_VAR=KOUNT_VAR+1 !<-- Count 2-D H-pt vbls excluding PD - NBASE_VAR_V(KOUNT_VAR)=NBASE - ENDDO - ENDIF -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - KOUNT_VAR=KOUNT_VAR+1 !<-- Add the 3-D H-pt vbls - NBASE_VAR_V(KOUNT_VAR)=NBASE_3D - ENDDO - ENDIF -! - CHILD_BOUND_V_NORTH(N,INDX2)%TASKS(NT)%DATA=>NULL() - CALL CHECK_REAL(CHILD_BOUND_V_NORTH(N,INDX2)%TASKS(NT)%DATA & - ,'CHILD_BOUND_V_NORTH(N,INDX2)%TASKS(NT)%DATA') - ALLOCATE(CHILD_BOUND_V_NORTH(N,INDX2)%TASKS(NT)%DATA(1:NWORDS) & !<-- 1-D bndry data string for child tasks with Nbndry V points - ,stat=ISTAT) -! - PD_B_NORTH_V(N)%TASKS(NT)%DATA=>NULL() - CALL CHECK_REAL(PD_B_NORTH_V(N)%TASKS(NT)%DATA & - ,'PD_B_NORTH_V(N)%TASKS(NT)%DATA') - ALLOCATE(PD_B_NORTH_V(N)%TASKS(NT)%DATA(1:NBASE*N_BLEND_V_CHILD(N)) & - ,stat=ISTAT) -! -!----------------------------------------------------------------------- -!*** Point the working pointer for each nest V-pt boundary variable -!*** into the object that holds all nest BC update data for child N's -!*** domain's north side. -!----------------------------------------------------------------------- -! - NLOC_2=0 - DO NVAR=1,NVARS_NESTBC_V -! - NLOC_1=NLOC_2+1 - NLOC_2=NLOC_1+NBASE_VAR_V(NVAR)-1 - BND_VAR_V_NORTH(NVAR)%CHILD(N)%TASKS(NT)%DATA=> & - CHILD_BOUND_V_NORTH(N,INDX2)%TASKS(NT)%DATA(NLOC_1:NLOC_2) !<-- N bndry storage for V-pt vbl NVAR, child N, task NT -! - ENDDO -! - ENDDO -! - ELSE north_v !<-- Dummy nonzero length -! - ALLOCATE(CHILD_BOUND_V_NORTH(N,INDX2)%TASKS(1:1)) - CHILD_BOUND_V_NORTH(N,INDX2)%TASKS(1)%DATA=>NULL() - CALL CHECK_REAL(CHILD_BOUND_V_NORTH(N,INDX2)%TASKS(1)%DATA & - ,'CHILD_BOUND_V_NORTH(N,INDX2)%TASKS(1)%DATA') - ALLOCATE(CHILD_BOUND_V_NORTH(N,INDX2)%TASKS(1)%DATA(1:1) & - ,stat=ISTAT) - ALLOCATE(PD_B_NORTH_V(N)%TASKS(1:1)) - PD_B_NORTH_V(N)%TASKS(1)%DATA=>NULL() - CALL CHECK_REAL(PD_B_NORTH_V(N)%TASKS(1)%DATA & - ,'PD_B_NORTH_V(N)%TASKS(1)%DATA') - ALLOCATE(PD_B_NORTH_V(N)%TASKS(1)%DATA(1:1),stat=ISTAT) -! - DO NVAR=1,NVARS_NESTBC_V - ALLOCATE(BND_VAR_V_NORTH(NVAR)%CHILD(N)%TASKS(1:1)) - ENDDO -! - ALLOCATE(WORDS_BOUND_V_NORTH(N)%TASKS(1:1)) -! - ENDIF north_v -! -!------------------------------------------------------------------------ -! -!---------- -!*** West -!---------- -! - west_h: IF(NUM_TASKS_SEND_H_W(N)>0)THEN !<-- Parent task has child west boundary H points? -! - NCHILD_TASKS=NUM_TASKS_SEND_H_W(N) - ALLOCATE(CHILD_BOUND_H_WEST(N,INDX2)%TASKS(1:NCHILD_TASKS) & !<-- 1-D bndry data string for child tasks with Wbndry H points - ,stat=ISTAT) - ALLOCATE(WORDS_BOUND_H_WEST(N)%TASKS(1:NCHILD_TASKS)) !<-- # of words in Wbndry H point 1-D data string - ALLOCATE(PD_B_WEST(N)%TASKS(1:NCHILD_TASKS)) !<-- PD_B_WEST for each child task -! - DO NVAR=1,NVARS_NESTBC_H-1 !<-- All nest 3D BC H-pt variables (excludes PD) - ALLOCATE(BND_VAR_H_WEST(NVAR)%CHILD(N)%TASKS(1:NCHILD_TASKS)) !<-- Working object for each 3D Wbnd H-pt vbl on each child task - ENDDO -! - nt_west_h: DO NT=1,NCHILD_TASKS -! - N_TASK=CHILDTASK_BNDRY_H_RANKS(N)%WEST(NT,1) !<-- Count of this task in list of all child fcst tasks -! -!----------------------------------------------------------------------- -! - NBASE=CHILDTASK_H_SAVE(N)%J_HI_WEST_TRANSFER(NT) & - -CHILDTASK_H_SAVE(N)%J_LO_WEST(NT)+1 -! - PROD=NBASE*N_BLEND_H_CHILD(N) - NBASE_3D=LM*PROD - NWORDS=(NVARS_BC_2D_H+NVARS_BC_3D_H*LM)*PROD !<-- # of Wbndry words in 2D,3D H-pt vbls parent sends to child -! - KOUNT_VAR=0 - IF(NVARS_BC_2D_H>1)THEN - DO NV=2,NVARS_BC_2D_H - KOUNT_VAR=KOUNT_VAR+1 !<-- Count 2-D H-pt vbls excluding PD - NBASE_VAR_H(KOUNT_VAR)=NBASE - ENDDO - ENDIF -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - KOUNT_VAR=KOUNT_VAR+1 !<-- Add the 3-D H-pt vbls - NBASE_VAR_H(KOUNT_VAR)=NBASE_3D - ENDDO - ENDIF -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - NBASE_4D=(UBND_4D(NV)-LBND_4D(NV)+1)*NBASE_3D - KOUNT_VAR=KOUNT_VAR+1 !<-- Add the 4-D H-pt vbls - NBASE_VAR_H(KOUNT_VAR)=NBASE_4D - NWORDS=NWORDS+(UBND_4D(NV)-LBND_4D(NV)+1)*NBASE_3D !<-- Add the # of Wbndry words in 4-D H-pt variables - ENDDO - ENDIF -! - WORDS_BOUND_H_WEST(N)%TASKS(NT)=NWORDS !<-- Save total number of words -! - CHILD_BOUND_H_WEST(N,INDX2)%TASKS(NT)%DATA=>NULL() - CALL CHECK_REAL(CHILD_BOUND_H_WEST(N,INDX2)%TASKS(NT)%DATA & - ,'CHILD_BOUND_H_WEST(N,INDX2)%TASKS(NT)%DATA') - ALLOCATE(CHILD_BOUND_H_WEST(N,INDX2)%TASKS(NT)%DATA(1:NWORDS)) !<-- 1-D bndry data string for child tasks -! with west boundary H points - NLOC_1=1 - NLOC_2=NLOC_1+NBASE*N_BLEND_H_CHILD(N)-1 -! - NBASE_EXP=CHILDTASK_H_SAVE(N)%J_HI_WEST(NT) & - -CHILDTASK_H_SAVE(N)%J_LO_WEST(NT)+1 -! - NLOC_2_EXP=NLOC_1+NBASE_EXP*(N_BLEND_H_CHILD(N)+1)-1 !<-- Extend PD_B_* by one row to allow 4-pt averaging to V pts -! - PD_B_WEST(N)%TASKS(NT)%DATA=>NULL() - CALL CHECK_REAL(PD_B_WEST(N)%TASKS(NT)%DATA & - ,'PD_B_WEST(N)%TASKS(NT)%DATA') - ALLOCATE(PD_B_WEST(N)%TASKS(NT)%DATA(NLOC_1:NLOC_2_EXP),stat=ISTAT) -! -!----------------------------------------------------------------------- -!*** Point the working pointer for each nest H-pt boundary variable -!*** into the object that holds all nest BC update data for child N's -!*** domain's west side. -!----------------------------------------------------------------------- -! - DO NVAR=1,NVARS_NESTBC_H-1 -! - NLOC_1=NLOC_2+1 !<-- Start at NLOC_2, NOT NLOC_2_EXPAND - NLOC_2=NLOC_1+NBASE_VAR_H(NVAR)-1 - BND_VAR_H_WEST(NVAR)%CHILD(N)%TASKS(NT)%DATA=> & - CHILD_BOUND_H_WEST(N,INDX2)%TASKS(NT)%DATA(NLOC_1:NLOC_2) !<-- W bndry storage for H-pt vbl NVAR, child N, task NT -! - ENDDO -! - ENDDO nt_west_h -! - ELSE west_h !<-- Dummy nonzero length -! - ALLOCATE(CHILD_BOUND_H_WEST(N,INDX2)%TASKS(1:1)) - CHILD_BOUND_H_WEST(N,INDX2)%TASKS(1)%DATA=>NULL() - CALL CHECK_REAL(CHILD_BOUND_H_WEST(N,INDX2)%TASKS(1)%DATA & - ,'CHILD_BOUND_H_WEST(N,INDX2)%TASKS(1)%DATA') - ALLOCATE(CHILD_BOUND_H_WEST(N,INDX2)%TASKS(1)%DATA(1:1)) - ALLOCATE(PD_B_WEST(N)%TASKS(1:1)) - PD_B_WEST(N)%TASKS(1)%DATA=>NULL() - CALL CHECK_REAL(PD_B_WEST(N)%TASKS(1)%DATA & - ,'PD_B_WEST(N)%TASKS(1)%DATA') - ALLOCATE(PD_B_WEST(N)%TASKS(1)%DATA(1:1),stat=ISTAT) -! - DO NVAR=1,NVARS_NESTBC_H-1 - ALLOCATE(BND_VAR_H_WEST(NVAR)%CHILD(N)%TASKS(1:1)) - ENDDO -! - ALLOCATE(WORDS_BOUND_H_WEST(N)%TASKS(1:1)) -! - ENDIF west_h -! -!----------------------------------------------------------------------- -! - west_v: IF(NUM_TASKS_SEND_V_W(N)>0)THEN !<-- Parent task has child west boundary V points? -! - NCHILD_TASKS=NUM_TASKS_SEND_V_W(N) - ALLOCATE(CHILD_BOUND_V_WEST(N,INDX2)%TASKS(1:NCHILD_TASKS)) !<-- 1-D bndry data string for child tasks with Wbndry V points - ALLOCATE(WORDS_BOUND_V_WEST(N)%TASKS(1:NCHILD_TASKS)) !<-- # of words in Wbndry V point 1-D data string -! - ALLOCATE(PD_B_WEST_V(N)%TASKS(1:NCHILD_TASKS)) !<-- PD_B_WEST_V for each child task -! - DO NVAR=1,NVARS_NESTBC_V !<-- All nest 3D BC V-pt variables - ALLOCATE(BND_VAR_V_WEST(NVAR)%CHILD(N)%TASKS(1:NCHILD_TASKS) & !<-- Working object for each 3D Wbnd V-pt vbl on each child task - ,stat=ISTAT) - ENDDO -! - DO NT=1,NCHILD_TASKS - NBASE=CHILDTASK_V_SAVE(N)%J_HI_WEST(NT) & - -CHILDTASK_V_SAVE(N)%J_LO_WEST(NT)+1 - PROD=NBASE*N_BLEND_V_CHILD(N) - NBASE_3D=LM*PROD - NWORDS=(NVARS_BC_2D_V+NVARS_BC_3D_V*LM)*PROD !<-- # of Wbndry words in 2D,3D V-pt vbls parent sends to child - WORDS_BOUND_V_WEST(N)%TASKS(NT)=NWORDS !<-- Save total number of words -! - KOUNT_VAR=0 - IF(NVARS_BC_2D_V>0)THEN - DO NV=2,NVARS_BC_2D_V - KOUNT_VAR=KOUNT_VAR+1 !<-- Count 2-D H-pt vbls excluding PD - NBASE_VAR_V(KOUNT_VAR)=NBASE - ENDDO - ENDIF -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - KOUNT_VAR=KOUNT_VAR+1 !<-- Add the 3-D H-pt vbls - NBASE_VAR_V(KOUNT_VAR)=NBASE_3D - ENDDO - ENDIF -! - CHILD_BOUND_V_WEST(N,INDX2)%TASKS(NT)%DATA=>NULL() - CALL CHECK_REAL(CHILD_BOUND_V_WEST(N,INDX2)%TASKS(NT)%DATA & - ,'CHILD_BOUND_V_WEST(N,INDX2)%TASKS(NT)%DATA') - ALLOCATE(CHILD_BOUND_V_WEST(N,INDX2)%TASKS(NT)%DATA(1:NWORDS) & !<-- 1-D bndry data string for child tasks with Wbndry V points - ,stat=ISTAT) -! - PD_B_WEST_V(N)%TASKS(NT)%DATA=>NULL() - CALL CHECK_REAL(PD_B_WEST_V(N)%TASKS(NT)%DATA & - ,'PD_B_WEST_V(N)%TASKS(NT)%DATA') - ALLOCATE(PD_B_WEST_V(N)%TASKS(NT)%DATA(1:NBASE*N_BLEND_V_CHILD(N)),stat=ISTAT) -! -!----------------------------------------------------------------------- -!*** Point the working pointer for each nest V-pt boundary variable -!*** into the object that holds all nest BC update data for child N's -!*** domain's west side. -!----------------------------------------------------------------------- -! - NLOC_2=0 - DO NVAR=1,NVARS_NESTBC_V -! - NLOC_1=NLOC_2+1 - NLOC_2=NLOC_1+NBASE_VAR_V(NVAR)-1 - BND_VAR_V_WEST(NVAR)%CHILD(N)%TASKS(NT)%DATA=> & - CHILD_BOUND_V_WEST(N,INDX2)%TASKS(NT)%DATA(NLOC_1:NLOC_2) !<-- W bndry storage for V-pt vbl NVAR, child N, task NT -! - ENDDO -! - ENDDO -! - ELSE west_v !<-- Dummy nonzero length -! - ALLOCATE(CHILD_BOUND_V_WEST(N,INDX2)%TASKS(1:1)) - CHILD_BOUND_V_WEST(N,INDX2)%TASKS(1)%DATA=>NULL() - CALL CHECK_REAL(CHILD_BOUND_V_WEST(N,INDX2)%TASKS(1)%DATA & - ,'CHILD_BOUND_V_WEST(N,INDX2)%TASKS(1)%DATA') - ALLOCATE(CHILD_BOUND_V_WEST(N,INDX2)%TASKS(1)%DATA(1:1)) - ALLOCATE(PD_B_WEST_V(N)%TASKS(1:1)) - PD_B_WEST_V(N)%TASKS(1)%DATA=>NULL() - CALL CHECK_REAL(PD_B_WEST_V(N)%TASKS(1)%DATA & - ,'PD_B_WEST_V(N)%TASKS(1)%DATA') - ALLOCATE(PD_B_WEST_V(N)%TASKS(1)%DATA(1:1),stat=ISTAT) -! - DO NVAR=1,NVARS_NESTBC_V - ALLOCATE(BND_VAR_V_WEST(NVAR)%CHILD(N)%TASKS(1:1)) - ENDDO -! - ALLOCATE(WORDS_BOUND_V_WEST(N)%TASKS(1:1)) -! - ENDIF west_v -! -!----------------------------------------------------------------------- -! -!---------- -!*** East -!---------- -! - east_h: IF(NUM_TASKS_SEND_H_E(N)>0)THEN !<-- Parent task has child east boundary H points? -! - NCHILD_TASKS=NUM_TASKS_SEND_H_E(N) - ALLOCATE(CHILD_BOUND_H_EAST(N,INDX2)%TASKS(1:NCHILD_TASKS) & !<-- 1-D bndry data string for child tasks with Ebndry H points - ,stat=ISTAT) - ALLOCATE(WORDS_BOUND_H_EAST(N)%TASKS(1:NCHILD_TASKS)) !<-- # of words in Ebndry H point 1-D data string -! - ALLOCATE(PD_B_EAST(N)%TASKS(1:NCHILD_TASKS)) !<-- PD_B_EAST for each child task -! - DO NVAR=1,NVARS_NESTBC_H-1 !<-- All nest 3D BC H-pt variables (excludes PD) - ALLOCATE(BND_VAR_H_EAST(NVAR)%CHILD(N)%TASKS(1:NCHILD_TASKS)) !<-- Working object for each 3D Ebnd H-pt vbl on each child task - ENDDO -! - nt_east_h: DO NT=1,NCHILD_TASKS -! - N_TASK=CHILDTASK_BNDRY_H_RANKS(N)%EAST(NT,1) !<-- Count of this task in list of all child fcst tasks -! -!----------------------------------------------------------------------- -! - NBASE=CHILDTASK_H_SAVE(N)%J_HI_EAST_TRANSFER(NT) & - -CHILDTASK_H_SAVE(N)%J_LO_EAST(NT)+1 -! - PROD=NBASE*N_BLEND_H_CHILD(N) - NBASE_3D=LM*NBASE*N_BLEND_H_CHILD(N) - NWORDS=(NVARS_BC_2D_H+NVARS_BC_3D_H*LM)*PROD !<-- # of Ebndry words in 2D,3D H-pt vbls parent sends to child -! - KOUNT_VAR=0 - IF(NVARS_BC_2D_H>1)THEN - DO NV=2,NVARS_BC_2D_H - KOUNT_VAR=KOUNT_VAR+1 !<-- Count 2-D H-pt vbls excluding PD - NBASE_VAR_H(KOUNT_VAR)=NBASE - ENDDO - ENDIF -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - KOUNT_VAR=KOUNT_VAR+1 !<-- Add the 3-D H-pt vbls - NBASE_VAR_H(KOUNT_VAR)=NBASE_3D - ENDDO - ENDIF -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - NBASE_4D=(UBND_4D(NV)-LBND_4D(NV)+1)*NBASE_3D - KOUNT_VAR=KOUNT_VAR+1 !<-- Add the 4-D H-pt vbls - NBASE_VAR_H(KOUNT_VAR)=NBASE_4D - NWORDS=NWORDS+(UBND_4D(NV)-LBND_4D(NV)+1)*NBASE_3D !<-- Add the # of Wbndry words in 4-D H-pt variables - ENDDO - ENDIF -! - WORDS_BOUND_H_EAST(N)%TASKS(NT)=NWORDS !<-- Save total number of words -! - CHILD_BOUND_H_EAST(N,INDX2)%TASKS(NT)%DATA=>NULL() - CALL CHECK_REAL(CHILD_BOUND_H_EAST(N,INDX2)%TASKS(NT)%DATA & - ,'CHILD_BOUND_H_EAST(N,INDX2)%TASKS(NT)%DATA') - ALLOCATE(CHILD_BOUND_H_EAST(N,INDX2)%TASKS(NT)%DATA(1:NWORDS)) !<-- 1-D bndry data string for child tasks -! with east boundary H points - NLOC_1=1 - NLOC_2=NLOC_1+NBASE*N_BLEND_H_CHILD(N)-1 -! - NBASE_EXP=CHILDTASK_H_SAVE(N)%J_HI_EAST(NT) & - -CHILDTASK_H_SAVE(N)%J_LO_EAST(NT)+1 -! - NLOC_2_EXP=NLOC_1+NBASE_EXP*(N_BLEND_H_CHILD(N)+1)-1 !<-- Extend PD_B_* by one row to allow 4-pt averaging to V pts -! - PD_B_EAST(N)%TASKS(NT)%DATA=>NULL() - CALL CHECK_REAL(PD_B_EAST(N)%TASKS(NT)%DATA & - ,'PD_B_EAST(N)%TASKS(NT)%DATA') - ALLOCATE(PD_B_EAST(N)%TASKS(NT)%DATA(NLOC_1:NLOC_2_EXP),stat=ISTAT) -! -!----------------------------------------------------------------------- -!*** Point the working pointer for each nest H-pt boundary variable -!*** into the object that holds all nest BC update data for child N's -!*** domain's east side. -!----------------------------------------------------------------------- -! - DO NVAR=1,NVARS_NESTBC_H-1 -! - NLOC_1=NLOC_2+1 !<-- Start at NLOC_2, NOT NLOC_2_EXPAND - NLOC_2=NLOC_1+NBASE_VAR_H(NVAR)-1 - BND_VAR_H_EAST(NVAR)%CHILD(N)%TASKS(NT)%DATA=> & - CHILD_BOUND_H_EAST(N,INDX2)%TASKS(NT)%DATA(NLOC_1:NLOC_2) !<-- E bndry storage for H-pt vbl NVAR, child N, task NT -! - ENDDO -! - ENDDO nt_east_h -! - ELSE east_h !<-- Dummy nonzero length -! - ALLOCATE(CHILD_BOUND_H_EAST(N,INDX2)%TASKS(1:1)) - CHILD_BOUND_H_EAST(N,INDX2)%TASKS(1)%DATA=>NULL() - CALL CHECK_REAL(CHILD_BOUND_H_EAST(N,INDX2)%TASKS(1)%DATA & - ,'CHILD_BOUND_H_EAST(N,INDX2)%TASKS(1)%DATA') - ALLOCATE(CHILD_BOUND_H_EAST(N,INDX2)%TASKS(1)%DATA(1:1)) - ALLOCATE(PD_B_EAST(N)%TASKS(1:1)) - PD_B_EAST(N)%TASKS(1)%DATA=>NULL() - CALL CHECK_REAL(PD_B_EAST(N)%TASKS(1)%DATA & - ,'PD_B_EAST(N)%TASKS(1)%DATA') - ALLOCATE(PD_B_EAST(N)%TASKS(1)%DATA(1:1)) -! - DO NVAR=1,NVARS_NESTBC_H-1 - ALLOCATE(BND_VAR_H_EAST(NVAR)%CHILD(N)%TASKS(1:1)) - ENDDO -! - ALLOCATE(WORDS_BOUND_H_EAST(N)%TASKS(1:1)) -! - ENDIF east_h -! -!----------------------------------------------------------------------- -! - east_v: IF(NUM_TASKS_SEND_V_E(N)>0)THEN !<-- Parent task has child east boundary V points? -! - NCHILD_TASKS=NUM_TASKS_SEND_V_E(N) - ALLOCATE(CHILD_BOUND_V_EAST(N,INDX2)%TASKS(1:NCHILD_TASKS)) !<-- 1-D bndry data string for child tasks with Ebndry V points - ALLOCATE(WORDS_BOUND_V_EAST(N)%TASKS(1:NCHILD_TASKS)) !<-- # of words in Ebndry V point 1-D data string -! - ALLOCATE(PD_B_EAST_V(N)%TASKS(1:NCHILD_TASKS)) !<-- PD_B_EAST_V for each child task -! - DO NVAR=1,NVARS_NESTBC_V !<-- All nest 3D BC V-pt variables - ALLOCATE(BND_VAR_V_EAST(NVAR)%CHILD(N)%TASKS(1:NCHILD_TASKS)) !<-- Working object for each 3D Ebnd V-pt vbl on each child task - ENDDO -! - DO NT=1,NCHILD_TASKS - NBASE=CHILDTASK_V_SAVE(N)%J_HI_EAST(NT) & - -CHILDTASK_V_SAVE(N)%J_LO_EAST(NT)+1 - PROD=NBASE*N_BLEND_V_CHILD(N) - NBASE_3D=LM*PROD - NWORDS=(NVARS_BC_2D_V+NVARS_BC_3D_V*LM)*PROD !<-- # of Ebndry words in 2D,3D V-pt vbls parent sends to child - WORDS_BOUND_V_EAST(N)%TASKS(NT)=NWORDS !<-- Save total number of words -! - KOUNT_VAR=0 - IF(NVARS_BC_2D_V>0)THEN - DO NV=2,NVARS_BC_2D_V - KOUNT_VAR=KOUNT_VAR+1 !<-- Count 2-D H-pt vbls excluding PD - NBASE_VAR_V(KOUNT_VAR)=NBASE - ENDDO - ENDIF -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - KOUNT_VAR=KOUNT_VAR+1 !<-- Add the 3-D H-pt vbls - NBASE_VAR_V(KOUNT_VAR)=NBASE_3D - ENDDO - ENDIF -! - CHILD_BOUND_V_EAST(N,INDX2)%TASKS(NT)%DATA=>NULL() - CALL CHECK_REAL(CHILD_BOUND_V_EAST(N,INDX2)%TASKS(NT)%DATA & - ,'CHILD_BOUND_V_EAST(N,INDX2)%TASKS(NT)%DATA') - ALLOCATE(CHILD_BOUND_V_EAST(N,INDX2)%TASKS(NT)%DATA(1:NWORDS)) !<-- 1-D bndry data string for child tasks with Ebndry V points -! - PD_B_EAST_V(N)%TASKS(NT)%DATA=>NULL() - CALL CHECK_REAL(PD_B_EAST_V(N)%TASKS(NT)%DATA & - ,'PD_B_EAST_V(N)%TASKS(NT)%DATA') - ALLOCATE(PD_B_EAST_V(N)%TASKS(NT)%DATA(1:NBASE*N_BLEND_V_CHILD(N)),stat=ISTAT) -! -!----------------------------------------------------------------------- -!*** Point the working pointer for each nest V-pt boundary variable -!*** into the object that holds all nest BC update data for child N's -!*** domain's east side. -!----------------------------------------------------------------------- -! - NLOC_2=0 - DO NVAR=1,NVARS_NESTBC_V -! - NLOC_1=NLOC_2+1 - NLOC_2=NLOC_1+NBASE_VAR_V(NVAR)-1 - BND_VAR_V_EAST(NVAR)%CHILD(N)%TASKS(NT)%DATA=> & - CHILD_BOUND_V_EAST(N,INDX2)%TASKS(NT)%DATA(NLOC_1:NLOC_2) !<-- E bndry storage for V-pt vbl NVAR, child N, task NT -! - ENDDO -! - ENDDO -! - ELSE east_v !<-- Dummy nonzero length -! - ALLOCATE(CHILD_BOUND_V_EAST(N,INDX2)%TASKS(1:1)) - CHILD_BOUND_V_EAST(N,INDX2)%TASKS(1)%DATA=>NULL() - CALL CHECK_REAL(CHILD_BOUND_V_EAST(N,INDX2)%TASKS(1)%DATA & - ,'CHILD_BOUND_V_EAST(N,INDX2)%TASKS(1)%DATA') - ALLOCATE(CHILD_BOUND_V_EAST(N,INDX2)%TASKS(1)%DATA(1:1)) - ALLOCATE(PD_B_EAST_V(N)%TASKS(1:1)) - PD_B_EAST_V(N)%TASKS(1)%DATA=>NULL() - CALL CHECK_REAL(PD_B_EAST_V(N)%TASKS(1)%DATA & - ,'PD_B_EAST_V(N)%TASKS(1)%DATA') - ALLOCATE(PD_B_EAST_V(N)%TASKS(1)%DATA(1:1),stat=ISTAT) -! - DO NVAR=1,NVARS_NESTBC_V - ALLOCATE(BND_VAR_V_EAST(NVAR)%CHILD(N)%TASKS(1:1)) - ENDDO -! - ALLOCATE(WORDS_BOUND_V_EAST(N)%TASKS(1:1)) -! - ENDIF east_v -! -!----------------------------------------------------------------------- -!*** Here we set logical flags so each parent tasks knows whether or -!*** not it must send data to any side of child N's boundary. -!----------------------------------------------------------------------- -! - IF(NUM_TASKS_SEND_H_S(N)>0.OR. & - NUM_TASKS_SEND_H_N(N)>0.OR. & - NUM_TASKS_SEND_H_W(N)>0.OR. & - NUM_TASKS_SEND_H_E(N)>0.OR. & - NUM_TASKS_SEND_V_S(N)>0.OR. & - NUM_TASKS_SEND_V_N(N)>0.OR. & - NUM_TASKS_SEND_V_W(N)>0.OR. & - NUM_TASKS_SEND_V_E(N)>0)THEN -! - SEND_CHILD_DATA(N)=.TRUE. -! - ELSE - SEND_CHILD_DATA(N)=.FALSE. - ENDIF -! -!----------------------------------------------------------------------- -!*** Allocate and initialize the new handles created for ISends -!*** between parent tasks and nest boundary tasks. That association -!*** of tasks obviously changes each time the nests move. -!----------------------------------------------------------------------- -! -!------------------------------- -!*** For child boundary, south -!------------------------------- -! - IF(NUM_TASKS_SEND_H_S(N)>0)THEN - ALLOCATE(HANDLE_H_SOUTH(N,INDX2)%NTASKS_TO_RECV(1:NUM_TASKS_SEND_H_S(N)) & - ,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate HANDLE_H_SOUTH(N,INDX2)%NTASKS_TO_RECV(1:',NUM_TASKS_SEND_H_S(N) & - ,') stat=',ISTAT - WRITE(0,*)' N=',N,' INDX2=',INDX2 -! ELSE -! WRITE(0,*)' Allocated HANDLE_H_SOUTH(N,INDX2)%NTASKS_TO_RECV(1:',NUM_TASKS_SEND_H_S(N),')' - ENDIF - DO NN=1,NUM_TASKS_SEND_H_S(N) - HANDLE_H_SOUTH(N,INDX2)%NTASKS_TO_RECV(NN)=MPI_REQUEST_NULL - ENDDO - ELSE - ALLOCATE(HANDLE_H_SOUTH(N,INDX2)%NTASKS_TO_RECV(1:1),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate dummy HANDLE_H_SOUTH(N,INDX2)%NTASKS_TO_RECV(1:1) stat=',ISTAT - WRITE(0,*)' N=',N,' INDX2=',INDX2 -! ELSE -! WRITE(0,*)' Allocated dummy HANDLE_H_SOUTH(N,INDX2)%NTASKS_TO_RECV(1:1)' - ENDIF - HANDLE_H_SOUTH(N,INDX2)%NTASKS_TO_RECV(1)=MPI_REQUEST_NULL - ENDIF -! - IF(NUM_TASKS_SEND_V_S(N)>0)THEN - ALLOCATE(HANDLE_V_SOUTH(N,INDX2)%NTASKS_TO_RECV(1:NUM_TASKS_SEND_V_S(N))) - DO NN=1,NUM_TASKS_SEND_V_S(N) - HANDLE_V_SOUTH(N,INDX2)%NTASKS_TO_RECV(NN)=MPI_REQUEST_NULL - ENDDO - ELSE - ALLOCATE(HANDLE_V_SOUTH(N,INDX2)%NTASKS_TO_RECV(1:1)) - HANDLE_V_SOUTH(N,INDX2)%NTASKS_TO_RECV(1)=MPI_REQUEST_NULL - ENDIF -! -!------------------------------- -!*** For child boundary, north -!------------------------------- -! - IF(NUM_TASKS_SEND_H_N(N)>0)THEN - ALLOCATE(HANDLE_H_NORTH(N,INDX2)%NTASKS_TO_RECV(1:NUM_TASKS_SEND_H_N(N))) - DO NN=1,NUM_TASKS_SEND_H_N(N) - HANDLE_H_NORTH(N,INDX2)%NTASKS_TO_RECV(NN)=MPI_REQUEST_NULL - ENDDO - ELSE - ALLOCATE(HANDLE_H_NORTH(N,INDX2)%NTASKS_TO_RECV(1:1)) - HANDLE_H_NORTH(N,INDX2)%NTASKS_TO_RECV(1)=MPI_REQUEST_NULL - ENDIF -! - IF(NUM_TASKS_SEND_V_N(N)>0)THEN - ALLOCATE(HANDLE_V_NORTH(N,INDX2)%NTASKS_TO_RECV(1:NUM_TASKS_SEND_V_N(N))) - DO NN=1,NUM_TASKS_SEND_V_N(N) - HANDLE_V_NORTH(N,INDX2)%NTASKS_TO_RECV(NN)=MPI_REQUEST_NULL - ENDDO - ELSE - ALLOCATE(HANDLE_V_NORTH(N,INDX2)%NTASKS_TO_RECV(1:1)) - HANDLE_V_NORTH(N,INDX2)%NTASKS_TO_RECV(1)=MPI_REQUEST_NULL - ENDIF -! -!------------------------------ -!*** For child boundary, west -!------------------------------ -! - IF(NUM_TASKS_SEND_H_W(N)>0)THEN - ALLOCATE(HANDLE_H_WEST(N,INDX2)%NTASKS_TO_RECV(1:NUM_TASKS_SEND_H_W(N))) - DO NN=1,NUM_TASKS_SEND_H_W(N) - HANDLE_H_WEST(N,INDX2)%NTASKS_TO_RECV(NN)=MPI_REQUEST_NULL - ENDDO - ELSE - ALLOCATE(HANDLE_H_WEST(N,INDX2)%NTASKS_TO_RECV(1:1)) - HANDLE_H_WEST(N,INDX2)%NTASKS_TO_RECV(1)=MPI_REQUEST_NULL - ENDIF -! - IF(NUM_TASKS_SEND_V_W(N)>0)THEN - ALLOCATE(HANDLE_V_WEST(N,INDX2)%NTASKS_TO_RECV(1:NUM_TASKS_SEND_V_W(N))) - DO NN=1,NUM_TASKS_SEND_V_W(N) - HANDLE_V_WEST(N,INDX2)%NTASKS_TO_RECV(NN)=MPI_REQUEST_NULL - ENDDO - ELSE - ALLOCATE(HANDLE_V_WEST(N,INDX2)%NTASKS_TO_RECV(1:1)) - HANDLE_V_WEST(N,INDX2)%NTASKS_TO_RECV(1)=MPI_REQUEST_NULL - ENDIF -! -!------------------------------ -!*** For child boundary, east -!------------------------------ -! - IF(NUM_TASKS_SEND_H_E(N)>0)THEN - ALLOCATE(HANDLE_H_EAST(N,INDX2)%NTASKS_TO_RECV(1:NUM_TASKS_SEND_H_E(N))) - DO NN=1,NUM_TASKS_SEND_H_E(N) - HANDLE_H_EAST(N,INDX2)%NTASKS_TO_RECV(NN)=MPI_REQUEST_NULL - ENDDO - ELSE - ALLOCATE(HANDLE_H_EAST(N,INDX2)%NTASKS_TO_RECV(1:1)) - HANDLE_H_EAST(N,INDX2)%NTASKS_TO_RECV(1)=MPI_REQUEST_NULL - ENDIF -! - IF(NUM_TASKS_SEND_V_E(N)>0)THEN - ALLOCATE(HANDLE_V_EAST(N,INDX2)%NTASKS_TO_RECV(1:NUM_TASKS_SEND_V_E(N))) - DO NN=1,NUM_TASKS_SEND_V_E(N) - HANDLE_V_EAST(N,INDX2)%NTASKS_TO_RECV(NN)=MPI_REQUEST_NULL - ENDDO - ELSE - ALLOCATE(HANDLE_V_EAST(N,INDX2)%NTASKS_TO_RECV(1:1)) - HANDLE_V_EAST(N,INDX2)%NTASKS_TO_RECV(1)=MPI_REQUEST_NULL - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE POINT_INTERP_DATA_TO_MEMORY -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE PARENT_SENDS_CHILD_DATA_LIMITS(N_CHILD & - ,MY_DOMAIN_ID & - ,TIME_FLAG ) -! -!----------------------------------------------------------------------- -!*** Parents send children basic bookkeeping information needed -!*** for the exchange of boundary data during the integration. -!----------------------------------------------------------------------- -! -!----------------------- -!*** Argument Variables -!----------------------- -! - INTEGER(kind=KINT),INTENT(IN) :: N_CHILD & !<-- The child being considered by this parent - ,MY_DOMAIN_ID !<-- Parent's domain ID -! - CHARACTER(len=*),INTENT(IN) :: TIME_FLAG !<-- For future or current BC data from parent -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: ID,ID_ADD,ID_CHILD,ID_CHILDTASK,IERR,ISTAT & - ,MYPE,N,NRANK,NT,NTAG_SEND,NTX -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: HANDLE_PACKET,INFO -! - INTEGER(kind=KINT),DIMENSION(MPI_STATUS_SIZE) :: JSTAT -! - TYPE(COMPOSITE),POINTER :: CC -! - integer(kind=kint) :: lb1,ub1,nz - integer(kind=kint),dimension(8) :: values -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Parent tasks send six pieces of information (five for V points) -!*** to child tasks on child domain boundaries so those child tasks -!*** will be able to receive boundary data and use it properly. The -!*** final two are used to serve as checks that the intended child -!*** targeted tasks are the actual recipients. -! -! (1) The parent-child intracomm rank of the sending parent task. -! (2) The child boundary tasks' starting (I,J) on the parent task. -! (3) The child boundary tasks' ending (I,J) on the parent task. -! -! (4) The child boundary tasks' ending (I,J) on the parent task <-- Only for H points. -! for the extended data to allow for 4-pt interpolation. <-- -! -! (5) The parent-child intracomm rank of the target child task. -! (6) The domain ID of the target child task. -! -!*** The child task must be able to know if the data it receives -!*** pertains to south boundary H or V points, north boundary -!*** H or V, points, etc. Thus the MPI tag will indicate -!*** the boundary's side and variable type. -! -! 11111 --> South H -! 22222 --> South V -! 33333 --> North H -! 44444 --> North V -! 55555 --> West H -! 66666 --> West V -! 77777 --> East H -! 88888 --> East V -! -!*** (The child tasks know which side of their domain's boundary they -!*** are on of course but since a corner task is on more than one side, -!*** the above tags indicating the side are used for all child tasks.) -!----------------------------------------------------------------------- -! - N=N_CHILD - ID=MY_DOMAIN_ID -! - CALL POINT_TO_COMPOSITE(MY_DOMAIN_ID) -! -!----------------------------------------------------------------------- -! - CALL MPI_COMM_RANK(COMM_TO_MY_CHILDREN(N),MYPE,IERR) !<-- Obtain rank of parent task - ID_CHILD=MY_CHILDREN_ID(N) - ID_ADD=1000*ID_CHILD -! -!------------- -!*** South H -!------------- -! - HANDLE_PACKET=>HANDLE_PACKET_S_H(ID)%CHILDREN(N)%DATA -! - sh_loop: DO NT=0,FTASKS_DOMAIN(ID_CHILD)-1 !<-- Each parent task loops through all tasks on each child -! - CALL MPI_WAIT(HANDLE_PACKET(NT) & !<-- Be sure the previous send is complete. - ,JSTAT & - ,IERR ) -! - INFO=>INFO_SEND(ID)%CHILDREN(N)%INFO(1:6,NT,1) !<-- South H info to child N's task NT -! - INFO(1)=-1 -! - IF(NUM_TASKS_SEND_H_S(N)>0)THEN -! - DO NTX=1,NUM_TASKS_SEND_H_S(N) !<-- Look for a child task with south boundary H points - ID_CHILDTASK=CHILDTASK_BNDRY_H_RANKS(N)%SOUTH(NTX,1) !<-- Count of this child task in list of all fcst tasks -! - IF(NT==ID_CHILDTASK-1)THEN !<-- If yes, we found a child task w/ south boundary H points - NRANK=ID_CHILDTASK-1 - ID_CHILDTASK=child_ranks(ID)%CHILDREN(N)%DATA(NRANK) !<-- Local rank of child task NTX in p-c intracomm - NTAG_SEND=11111+ID_CHILDTASK+ID_ADD !<-- Combine child task rank and child domain ID for unique tag -! - INFO(1)=MYPE !<-- Save the parent task rank - INFO(2)=CHILDTASK_H_SAVE(N)%I_LO_SOUTH(NTX) !<-- Save the starting index of boundary segment on child - INFO(3)=CHILDTASK_H_SAVE(N)%I_HI_SOUTH_TRANSFER(NTX) !<-- Save the ending index of boundary segment on child - INFO(4)=CHILDTASK_H_SAVE(N)%I_HI_SOUTH(NTX) !<-- Save the ending index of expanded boundary segment on child - INFO(5)=ID_CHILDTASK !<-- Save the target child task rank - INFO(6)=ID_CHILD !<-- Save the domain ID of the target child task -! -! write(0,56561)my_domain_id,n,id_child,nt,nrank,id_childtask -! write(0,56562)ntag_send,id_childtask,id_add,info -56561 format(' PARENT_SENDS_CHILD_DATA_LIMITS my_domain_id=',i2,' to send SH to child #',i2,' domain id=',i2,' task #',i3 & - ,' nrank=',i3,' child task rank=',i3) -56562 format(' tag=',i6,' intracomm rank=',i3,' id_add=',i5,' info=',6(1x,i5)) - CALL MPI_ISSEND(INFO & !<-- Parent task sends the key data to the child Sbndry task - ,6 & !<-- # of words - ,MPI_INTEGER & !<-- Datatype - ,ID_CHILDTASK & !<-- Rank of target child task in parent-child intracomm - ,NTAG_SEND & !<-- Tag for south boundary H points - ,COMM_TO_MY_CHILDREN(N) & !<-- Parent-child intracommunicator - ,HANDLE_PACKET(NT) & !<-- Request handle for this ISend - ,IERR) -! write(0,56563)id_childtask -56563 format(' sent SH info to id_childtask=',i3) -! write(0,*)' S_H parent ISent child #',n,' child domain id=',id_child,' task #',nt,' nrank=',nrank,' ntx=',ntx & -! ,' child task count=',CHILDTASK_BNDRY_H_RANKS(N)%SOUTH(NTX,1) & -! ,' intracomm rank=',id_childtask,' ierr=',ierr -! write(0,*)' south_h info=',info -! - CYCLE sh_loop !<-- Move on to next child task - ENDIF - ENDDO -! - ENDIF -! - ID_CHILDTASK=child_ranks(ID)%CHILDREN(N)%DATA(NT) !<-- This child task has no south boundary H points - NTAG_SEND=11111+ID_CHILDTASK+ID_ADD !<-- Combine child task rank and child domain ID for unique tag -! write(0,*)' PARENT_SENDS_CHILD_DATA_LIMITS my_domain_id=',id,' dummy South H isend to child #',n,' child rank ',ID_CHILDTASK & -! ,' task #',nt - CALL MPI_ISSEND(INFO,6,MPI_INTEGER,ID_CHILDTASK & !<-- Then send this child task some dummy information - ,NTAG_SEND,COMM_TO_MY_CHILDREN(N) & - ,HANDLE_PACKET(NT),IERR) -! - ENDDO sh_loop -! -!------------- -!*** South V -!------------- -! - HANDLE_PACKET=>HANDLE_PACKET_S_V(ID)%CHILDREN(N)%DATA -! - sv_loop: DO NT=0,FTASKS_DOMAIN(ID_CHILD)-1 !<-- Each parent task loops through all tasks on each child -! - CALL MPI_WAIT(HANDLE_PACKET(NT) & !<-- Be sure the previous send is complete. - ,JSTAT & - ,IERR ) -! - INFO=>INFO_SEND(ID)%CHILDREN(N)%INFO(1:5,NT,2) !<-- South V info to child N's task NT -! - INFO(1)=-1 -! - IF(NUM_TASKS_SEND_V_S(N)>0)THEN -! - DO NTX=1,NUM_TASKS_SEND_V_S(N) !<-- Look for a child task with south boundary V points - ID_CHILDTASK=CHILDTASK_BNDRY_V_RANKS(N)%SOUTH(NTX,1) !<-- Count of this child task in list of all fcst tasks -! - IF(NT==ID_CHILDTASK-1)THEN !<-- If yes, we found a child task w/ south boundary V points - NRANK=ID_CHILDTASK-1 - ID_CHILDTASK=child_ranks(ID)%CHILDREN(N)%DATA(NRANK) !<-- Local rank of child task NTX in p-c intracomm - NTAG_SEND=22222+ID_CHILDTASK+ID_ADD !<-- Combine child task rank and child domain ID for unique tag -! - INFO(1)=MYPE !<-- Save the parent task rank - INFO(2)=CHILDTASK_V_SAVE(N)%I_LO_SOUTH(NTX) !<-- Save the starting index of boundary segment on child - INFO(3)=CHILDTASK_V_SAVE(N)%I_HI_SOUTH(NTX) !<-- Save the ending index of boundary segment on child - INFO(4)=ID_CHILDTASK !<-- Save the target child task rank - INFO(5)=ID_CHILD !<-- Save the domain ID of the target child task -! - CALL MPI_ISSEND(INFO & !<-- Parent task sends the key data to the child Sbndry task - ,5 & !<-- # of words - ,MPI_INTEGER & !<-- Datatype - ,ID_CHILDTASK & !<-- Rank of target child task in parent-child intracomm - ,NTAG_SEND & !<-- Tag for south boundary H points - ,COMM_TO_MY_CHILDREN(N) & !<-- Parent-child intracommunicator - ,HANDLE_PACKET(NT) & !<-- Request handle for this ISend - ,IERR) -! - CYCLE sv_loop !<-- Move on to next child task - ENDIF - ENDDO -! - ENDIF -! - ID_CHILDTASK=child_ranks(ID)%CHILDREN(N)%DATA(NT) !<-- This child task has no south boundary H points - NTAG_SEND=22222+ID_CHILDTASK+ID_ADD !<-- Combine child task rank and child domain ID for unique tag -! - CALL MPI_ISSEND(INFO,5,MPI_INTEGER,ID_CHILDTASK & !<-- Then send this child task some dummy information - ,NTAG_SEND,COMM_TO_MY_CHILDREN(N) & - ,HANDLE_PACKET(NT),IERR) -! - ENDDO sv_loop -! -!------------- -!*** North H -!------------- -! - HANDLE_PACKET=>HANDLE_PACKET_N_H(ID)%CHILDREN(N)%DATA -! - nh_loop: DO NT=0,FTASKS_DOMAIN(ID_CHILD)-1 !<-- Each parent task loops through all tasks on each child -! - CALL MPI_WAIT(HANDLE_PACKET(NT) & !<-- Be sure the previous send is complete. - ,JSTAT & - ,IERR ) -! - INFO=>INFO_SEND(ID)%CHILDREN(N)%INFO(1:6,NT,3) !<-- North H info to child N's task NT -! - INFO(1)=-1 -! - IF(NUM_TASKS_SEND_H_N(N)>0)THEN -! - DO NTX=1,NUM_TASKS_SEND_H_N(N) !<-- Look for a child task with north boundary H points - ID_CHILDTASK=CHILDTASK_BNDRY_H_RANKS(N)%NORTH(NTX,1) !<-- Count of this child task in list of all fcst tasks -! - IF(NT==ID_CHILDTASK-1)THEN !<-- If yes, we found a child task w/ north boundary H points - NRANK=ID_CHILDTASK-1 - ID_CHILDTASK=child_ranks(ID)%CHILDREN(N)%DATA(NRANK) !<-- Local rank of child task NTX in p-c intracomm - NTAG_SEND=33333+ID_CHILDTASK+ID_ADD !<-- Combine child task rank and child domain ID for unique tag -! - INFO(1)=MYPE !<-- Save the parent task rank - INFO(2)=CHILDTASK_H_SAVE(N)%I_LO_NORTH(NTX) !<-- Save the starting index of boundary segment on child - INFO(3)=CHILDTASK_H_SAVE(N)%I_HI_NORTH_TRANSFER(NTX) !<-- Save the ending index of boundary segment on child - INFO(4)=CHILDTASK_H_SAVE(N)%I_HI_NORTH(NTX) !<-- Save the ending index of expanded boundary segment on child - INFO(5)=ID_CHILDTASK !<-- Save the target child task rank - INFO(6)=ID_CHILD !<-- Save the domain ID of the target child task -! - CALL MPI_ISSEND(INFO & !<-- Parent task sends the key data to the child Nbndry task - ,6 & !<-- # of words - ,MPI_INTEGER & !<-- Datatype - ,ID_CHILDTASK & !<-- Rank of target child task in parent-child intracomm - ,NTAG_SEND & !<-- Tag for south boundary H points - ,COMM_TO_MY_CHILDREN(N) & !<-- Parent-child intracommunicator - ,HANDLE_PACKET(NT) & !<-- Request handle for this ISend - ,IERR) -! - CYCLE nh_loop !<-- Move on to next child task - ENDIF - ENDDO -! - ENDIF -! - ID_CHILDTASK=child_ranks(ID)%CHILDREN(N)%DATA(NT) !<-- This child task has no north boundary H points - NTAG_SEND=33333+ID_CHILDTASK+ID_ADD !<-- Combine child task rank and child domain ID for unique tag -! - CALL MPI_ISSEND(INFO,6,MPI_INTEGER,ID_CHILDTASK & !<-- Then send this child task some dummy information - ,NTAG_SEND,COMM_TO_MY_CHILDREN(N) & - ,HANDLE_PACKET(NT),IERR) -! - ENDDO nh_loop -! -!------------- -!*** North V -!------------- -! - HANDLE_PACKET=>HANDLE_PACKET_N_V(ID)%CHILDREN(N)%DATA -! - nv_loop: DO NT=0,FTASKS_DOMAIN(ID_CHILD)-1 !<-- Each parent task loops through all tasks on each child -! - CALL MPI_WAIT(HANDLE_PACKET(NT) & !<-- Be sure the previous send is complete. - ,JSTAT & - ,IERR ) -! - INFO=>INFO_SEND(ID)%CHILDREN(N)%INFO(1:5,NT,4) !<-- North V info to child N's task NT -! - INFO(1)=-1 -! - IF(NUM_TASKS_SEND_V_N(N)>0)THEN -! - DO NTX=1,NUM_TASKS_SEND_V_N(N) !<-- Look for a child task with north boundary V points - ID_CHILDTASK=CHILDTASK_BNDRY_V_RANKS(N)%NORTH(NTX,1) !<-- Count of this child task in list of all fcst tasks -! - IF(NT==ID_CHILDTASK-1)THEN !<-- If yes, we found a child task w/ north boundary V points - NRANK=ID_CHILDTASK-1 - ID_CHILDTASK=child_ranks(ID)%CHILDREN(N)%DATA(NRANK) !<-- Local rank of child task NTX in p-c intracomm - NTAG_SEND=44444+ID_CHILDTASK+ID_ADD !<-- Combine child task rank and child domain ID for unique tag -! - INFO(1)=MYPE !<-- Save the parent task rank - INFO(2)=CHILDTASK_V_SAVE(N)%I_LO_NORTH(NTX) !<-- Save the starting index of boundary segment on child - INFO(3)=CHILDTASK_V_SAVE(N)%I_HI_NORTH(NTX) !<-- Save the ending index of boundary segment on child - INFO(4)=ID_CHILDTASK !<-- Save the target child task rank - INFO(5)=ID_CHILD !<-- Save the domain ID of the target child task -! - CALL MPI_ISSEND(INFO & !<-- Parent task sends the key data to the child Nbndry task - ,5 & !<-- # of words - ,MPI_INTEGER & !<-- Datatype - ,ID_CHILDTASK & !<-- Rank of target child task in parent-child intracomm - ,NTAG_SEND & !<-- Tag for south boundary H points - ,COMM_TO_MY_CHILDREN(N) & !<-- Parent-child intracommunicator - ,HANDLE_PACKET(NT) & !<-- Request handle for this ISend - ,IERR) -! - CYCLE nv_loop !<-- Move on to next child task - ENDIF - ENDDO -! - ENDIF -! - ID_CHILDTASK=child_ranks(ID)%CHILDREN(N)%DATA(NT) !<-- This child task has no north boundary V points - NTAG_SEND=44444+ID_CHILDTASK+ID_ADD !<-- Combine child task rank and child domain ID for unique tag -! - CALL MPI_ISSEND(INFO,5,MPI_INTEGER,ID_CHILDTASK & !<-- Then send this child task some dummy information - ,NTAG_SEND,COMM_TO_MY_CHILDREN(N) & - ,HANDLE_PACKET(NT),IERR) -! - ENDDO nv_loop -! -!------------ -!*** West H -!------------ -! - HANDLE_PACKET=>HANDLE_PACKET_W_H(ID)%CHILDREN(N)%DATA -! - wh_loop: DO NT=0,FTASKS_DOMAIN(ID_CHILD)-1 !<-- Each parent task loops through all tasks on each child -! - CALL MPI_WAIT(HANDLE_PACKET(NT) & !<-- Be sure the previous send is complete. - ,JSTAT & - ,IERR ) -! - INFO=>INFO_SEND(ID)%CHILDREN(N)%INFO(1:6,NT,5) !<-- West H info to child N's task NT -! - INFO(1)=-1 -! - IF(NUM_TASKS_SEND_H_W(N)>0)THEN -! - DO NTX=1,NUM_TASKS_SEND_H_W(N) !<-- Look for a child task with west boundary H points - ID_CHILDTASK=CHILDTASK_BNDRY_H_RANKS(N)%WEST(NTX,1) !<-- Count of this child task in list of all fcst tasks -! - IF(NT==ID_CHILDTASK-1)THEN !<-- If yes, we found a child task w/ west boundary H points - NRANK=ID_CHILDTASK-1 - ID_CHILDTASK=CHILD_RANKS(ID)%CHILDREN(N)%DATA(NRANK) !<-- Local rank of child task NTX in p-c intracomm - NTAG_SEND=55555+ID_CHILDTASK+ID_ADD !<-- Combine child task rank and child domain ID for unique tag -! - INFO(1)=MYPE !<-- Save the parent task rank - INFO(2)=CHILDTASK_H_SAVE(N)%J_LO_WEST(NTX) !<-- Save the starting index of boundary segment on child - INFO(3)=CHILDTASK_H_SAVE(N)%J_HI_WEST_TRANSFER(NTX) !<-- Save the ending index of boundary segment on child - INFO(4)=CHILDTASK_H_SAVE(N)%J_HI_WEST(NTX) !<-- Save the ending index of expanded boundary segment on child - INFO(5)=ID_CHILDTASK !<-- Save the target child task rank - INFO(6)=ID_CHILD !<-- Save the domain ID of the target child task -! - CALL MPI_ISSEND(INFO & !<-- Parent task sends the key data to the child Wbndry task - ,6 & !<-- # of words - ,MPI_INTEGER & !<-- Datatype - ,ID_CHILDTASK & !<-- Rank of target child task in parent-child intracomm - ,NTAG_SEND & !<-- Tag for south boundary H points - ,COMM_TO_MY_CHILDREN(N) & !<-- Parent-child intracommunicator - ,HANDLE_PACKET(NT) & !<-- Request handle for this ISend - ,IERR) -! - CYCLE wh_loop !<-- Move on to next child task - ENDIF - ENDDO -! - ENDIF -! - ID_CHILDTASK=child_ranks(ID)%CHILDREN(N)%DATA(NT) !<-- This child task has no west boundary H points - NTAG_SEND=55555+ID_CHILDTASK+ID_ADD !<-- Combine child task rank and child domain ID for unique tag -! - CALL MPI_ISSEND(INFO,6,MPI_INTEGER,ID_CHILDTASK & !<-- Then send this child task some dummy information -! ,55555,COMM_TO_MY_CHILDREN(N) & - ,NTAG_SEND,COMM_TO_MY_CHILDREN(N) & - ,HANDLE_PACKET(NT),IERR) -! - ENDDO wh_loop -! -!------------ -!*** West V -!------------ -! - HANDLE_PACKET=>HANDLE_PACKET_W_V(ID)%CHILDREN(N)%DATA -! - wv_loop: DO NT=0,FTASKS_DOMAIN(ID_CHILD)-1 !<-- Each parent task loops through all tasks on each child -! - CALL MPI_WAIT(HANDLE_PACKET(NT) & !<-- Be sure the previous send is complete. - ,JSTAT & - ,IERR ) -! - INFO=>INFO_SEND(ID)%CHILDREN(N)%INFO(1:5,NT,6) !<-- West V info to child N's task NT -! - INFO(1)=-1 -! - IF(NUM_TASKS_SEND_V_W(N)>0)THEN -! - DO NTX=1,NUM_TASKS_SEND_V_W(N) !<-- Look for a child task with west boundary V points - ID_CHILDTASK=CHILDTASK_BNDRY_V_RANKS(N)%WEST(NTX,1) !<-- Count of this child task in list of all fcst tasks -! - IF(NT==ID_CHILDTASK-1)THEN !<-- If yes, we found a child task w/ west boundary V points - NRANK=ID_CHILDTASK-1 - ID_CHILDTASK=child_ranks(ID)%CHILDREN(N)%DATA(NRANK) !<-- Local rank of child task NTX in p-c intracomm - NTAG_SEND=66666+ID_CHILDTASK+ID_ADD !<-- Combine child task rank and child domain ID for unique tag -! - INFO(1)=MYPE !<-- Save the parent task rank - INFO(2)=CHILDTASK_V_SAVE(N)%J_LO_WEST(NTX) !<-- Save the starting index of boundary segment on child - INFO(3)=CHILDTASK_V_SAVE(N)%J_HI_WEST(NTX) !<-- Save the ending index of boundary segment on child - INFO(4)=ID_CHILDTASK !<-- Save the target child task rank - INFO(5)=ID_CHILD !<-- Save the domain ID of the target child task -! - CALL MPI_ISSEND(INFO & !<-- Parent task sends the key data to the child Wbndry task - ,5 & !<-- # of words - ,MPI_INTEGER & !<-- Datatype - ,ID_CHILDTASK & !<-- Rank of target child task in parent-child intracomm - ,NTAG_SEND & !<-- Tag for south boundary H points - ,COMM_TO_MY_CHILDREN(N) & !<-- Parent-child intracommunicator - ,HANDLE_PACKET(NT) & !<-- Request handle for this ISend - ,IERR) -! - CYCLE wv_loop !<-- Move on to next child task - ENDIF - ENDDO -! - ENDIF -! - ID_CHILDTASK=child_ranks(ID)%CHILDREN(N)%DATA(NT) !<-- This child task has no west boundary V points - NTAG_SEND=66666+ID_CHILDTASK+ID_ADD !<-- Combine child task rank and child domain ID for unique tag -! - CALL MPI_ISSEND(INFO,5,MPI_INTEGER,ID_CHILDTASK & !<-- Then send this child task some dummy information -! ,66666,COMM_TO_MY_CHILDREN(N) & - ,NTAG_SEND,COMM_TO_MY_CHILDREN(N) & - ,HANDLE_PACKET(NT),IERR) -! - ENDDO wv_loop -! -!------------ -!*** East H -!------------ -! - HANDLE_PACKET=>HANDLE_PACKET_E_H(ID)%CHILDREN(N)%DATA -! - eh_loop: DO NT=0,FTASKS_DOMAIN(ID_CHILD)-1 !<-- Each parent task loops through all tasks on each child -! - CALL MPI_WAIT(HANDLE_PACKET(NT) & !<-- Be sure the previous send is complete. - ,JSTAT & - ,IERR ) -! - INFO=>INFO_SEND(ID)%CHILDREN(N)%INFO(1:6,NT,7) !<-- East H info to child N's task NT -! - INFO(1)=-1 -! - IF(NUM_TASKS_SEND_H_E(N)>0)THEN -! - DO NTX=1,NUM_TASKS_SEND_H_E(N) !<-- Look for a child task with east boundary H points - ID_CHILDTASK=CHILDTASK_BNDRY_H_RANKS(N)%EAST(NTX,1) !<-- Count of this child task in list of all fcst tasks -! - IF(NT==ID_CHILDTASK-1)THEN !<-- If yes, we found a child task w/ east boundary H points - NRANK=ID_CHILDTASK-1 - ID_CHILDTASK=child_ranks(ID)%CHILDREN(N)%DATA(NRANK) !<-- Local rank of child task NTX in p-c intracomm - NTAG_SEND=77777+ID_CHILDTASK+ID_ADD !<-- Combine child task rank and child domain ID for unique tag -! - INFO(1)=MYPE !<-- Save the parent task rank - INFO(2)=CHILDTASK_H_SAVE(N)%J_LO_EAST(NTX) !<-- Save the starting index of boundary segment on child - INFO(3)=CHILDTASK_H_SAVE(N)%J_HI_EAST_TRANSFER(NTX) !<-- Save the ending index of boundary segment on child - INFO(4)=CHILDTASK_H_SAVE(N)%J_HI_EAST(NTX) !<-- Save the ending index of expanded boundary segment on child - INFO(5)=ID_CHILDTASK !<-- Save the target child task rank - INFO(6)=ID_CHILD !<-- Save the domain ID of the target child task -! - CALL MPI_ISSEND(INFO & !<-- Parent task sends the key data to the child Ebndry task - ,6 & !<-- # of words - ,MPI_INTEGER & !<-- Datatype - ,ID_CHILDTASK & !<-- Rank of target child task in parent-child intracomm - ,NTAG_SEND & !<-- Tag for south boundary H points - ,COMM_TO_MY_CHILDREN(N) & !<-- Parent-child intracommunicator - ,HANDLE_PACKET(NT) & !<-- Request handle for this ISend - ,IERR) -! - CYCLE eh_loop !<-- Move on to next child task - ENDIF - ENDDO -! - ENDIF -! - ID_CHILDTASK=child_ranks(ID)%CHILDREN(N)%DATA(NT) !<-- This child task has no east boundary H points - NTAG_SEND=77777+ID_CHILDTASK+ID_ADD !<-- Combine child task rank and child domain ID for unique tag -! - CALL MPI_ISSEND(INFO,6,MPI_INTEGER,ID_CHILDTASK & !<-- Then send this child task some dummy information - ,NTAG_SEND,COMM_TO_MY_CHILDREN(N) & - ,HANDLE_PACKET(NT),IERR) -! - ENDDO eh_loop -! -!------------ -!*** East V -!------------ -! - HANDLE_PACKET=>HANDLE_PACKET_E_V(ID)%CHILDREN(N)%DATA -! - ev_loop: DO NT=0,FTASKS_DOMAIN(ID_CHILD)-1 !<-- Each parent task loops through all tasks on each child -! - CALL MPI_WAIT(HANDLE_PACKET(NT) & !<-- Be sure the previous send is complete. - ,JSTAT & - ,IERR ) -! - INFO=>INFO_SEND(ID)%CHILDREN(N)%INFO(1:5,NT,8) !<-- East V info to child N's task NT -! - INFO(1)=-1 -! - IF(NUM_TASKS_SEND_V_E(N)>0)THEN -! - DO NTX=1,NUM_TASKS_SEND_V_E(N) !<-- Look for a child task with east boundary V points - ID_CHILDTASK=CHILDTASK_BNDRY_V_RANKS(N)%EAST(NTX,1) !<-- Count of this child task in list of all fcst tasks -! - IF(NT==ID_CHILDTASK-1)THEN !<-- If yes, we found a child task w/ east boundary V points - NRANK=ID_CHILDTASK-1 - ID_CHILDTASK=child_ranks(ID)%CHILDREN(N)%DATA(NRANK) !<-- Local rank of child task NTX in p-c intracomm - NTAG_SEND=88888+ID_CHILDTASK+ID_ADD !<-- Combine child task rank and child domain ID for unique tag -! - INFO(1)=MYPE !<-- Save the parent task rank - INFO(2)=CHILDTASK_V_SAVE(N)%J_LO_EAST(NTX) !<-- Save the starting index of boundary segment on child - INFO(3)=CHILDTASK_V_SAVE(N)%J_HI_EAST(NTX) !<-- Save the ending index of boundary segment on child - INFO(4)=ID_CHILDTASK !<-- Save the target child task rank - INFO(5)=ID_CHILD !<-- Save the domain ID of the target child task -! - CALL MPI_ISSEND(INFO & !<-- Parent task sends the key data to the child Ebndry task - ,5 & !<-- # of words - ,MPI_INTEGER & !<-- Datatype - ,ID_CHILDTASK & !<-- Rank of target child task in parent-child intracomm - ,NTAG_SEND & !<-- Tag for south boundary H points - ,COMM_TO_MY_CHILDREN(N) & !<-- Parent-child intracommunicator - ,HANDLE_PACKET(NT) & !<-- Request handle for this ISend - ,IERR) -! - CYCLE ev_loop !<-- Move on to next child task - ENDIF - ENDDO -! - ENDIF -! - ID_CHILDTASK=child_ranks(ID)%CHILDREN(N)%DATA(NT) !<-- This child task has no east boundary V points - NTAG_SEND=88888+ID_CHILDTASK+ID_ADD !<-- Combine child task rank and child domain ID for unique tag -! - CALL MPI_ISSEND(INFO,5,MPI_INTEGER,ID_CHILDTASK & !<-- Then send this child task some dummy information - ,NTAG_SEND,COMM_TO_MY_CHILDREN(N) & - ,HANDLE_PACKET(NT),IERR) -! - ENDDO ev_loop -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PARENT_SENDS_CHILD_DATA_LIMITS -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE CHILD_RECVS_CHILD_DATA_LIMITS(EXP_STATE & - ,MY_DOMAIN_ID) -! -!----------------------------------------------------------------------- -!*** Children receive from their parents basic bookkeeping information -!*** needed for the exchange of boundary data during the integration. -!*** The routine in which the parents send this data is -!*** PARENT_SENDS_CHILD_DATA_LIMITS. -!----------------------------------------------------------------------- -! -!----------------------- -!*** Argument Variables -!----------------------- -! - INTEGER(kind=KINT),INTENT(IN) :: MY_DOMAIN_ID !<-- The current domain's ID -! - TYPE(ESMF_State),INTENT(INOUT) :: EXP_STATE !<-- Parent-Child Coupler export state -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: ID_ADD,ID_DOM,KOUNT,LB,LENGTH,N,N1,NBASE & - ,NTAG_RECV,NV,UB -! - INTEGER(kind=KINT) :: ILIM_HI,ILIM_LO,JLIM_HI,JLIM_LO -! - INTEGER(kind=KINT) :: IERR,ISTAT,RC,RC_LIMITS -! - INTEGER(kind=KINT),DIMENSION(6) :: INFO_R=(/-9999,0,0,0,0,0/) - INTEGER(kind=KINT),DIMENSION(4) :: TEMP - INTEGER(kind=KINT),DIMENSION(4,2) :: PARENT_INFO -! - INTEGER(kind=KINT),DIMENSION(MPI_STATUS_SIZE) :: STATUS -! - TYPE(COMPOSITE),POINTER :: CC -! - integer(kind=kint),dimension(8) :: values - integer(kind=kint) :: my_rank,source,tag -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - CALL POINT_TO_COMPOSITE(MY_DOMAIN_ID) -! - CC=>CPL_COMPOSITE(MY_DOMAIN_ID) -! -!----------------------------------------------------------------------- -!*** The child tasks receive the key information from their -!*** parent tasks. At this point the child tasks do not know -!*** the local ranks of the parent tasks that will be sending -!*** information to them thus MPI_ANY_SOURCE is used in the -!*** receive. However this means that when there are two -!*** parent tasks sending to a nest task (rather than only one) -!*** then the two overlap points on the nest boundary segment -!*** computed by the parent tasks will ultimately have values -!*** depending on which parent task's preliminary information -!*** is received last in the MPI_ANY_SOURCE Recv below. Since -!*** the values in those overlap points are not bit identical -!*** then any successive runs can have slightly different answers. -!*** To avoid that happening when two parent tasks are sending, -!*** the child task will receive their ranks and then put them -!*** in ascending order so that all subsequent updates of the -!*** nest boundary overlap points are always done in the same -!*** way regardless of the order the preliminary information -!*** is received with MPI_ANY_SOURCE. -! -!*** All nests execute this routine once during the Init step and -!*** then again on those parent timesteps during the Run step when -!*** the child has moved. -!----------------------------------------------------------------------- -! - CALL MPI_COMM_RANK(COMM_TO_MY_PARENT,MYPE,IERR) !<-- Obtain local rank of child task in p-c intracomm - ID_DOM=ID_PARENTS(MY_DOMAIN_ID) !<-- Domain ID of this child's parent - ID_ADD=1000*MY_DOMAIN_ID -! -!------------- -!*** South H -!------------- -! - KOUNT=0 - INDX_MIN_H%SOUTH= 1000000 - INDX_MAX_H%SOUTH=-1000000 - NTAG_RECV=11111+MYPE+ID_ADD !<-- Combine child task rank and child domain ID for unique tag -! - DO N=0,FTASKS_DOMAIN(ID_DOM)-1 !<-- Child task loops through its parent's tasks -! -! write(0,12711)my_domain_id,mype,n,ntag_recv,id_add -12711 format(' CHILD_RECVS_CHILD_DATA_LIMITS my_domain_id=',i2,' mype=',i3,' ready to recv SH from parent task ',i3,' tag=',i6,' id_add=',i5) - CALL MPI_RECV(INFO_R & !<-- Receive data packet from each parent task - ,6 & !<-- # of words in data packet - ,MPI_INTEGER & !<-- Datatype - ,N & !<-- Rank of parent task that is sending -! ,11111 & !<-- Tag used for south boundary H points - ,NTAG_RECV & !<-- Tag used for south boundary H points - ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator between child and parent - ,STATUS & !<-- Status of Recv - ,IERR) -! write(0,12712)n,info_r(1) -12712 format(' recvd SH from parent task ',i3,' info_r(1)=',6(1x,i5)) -! - IF(INFO_R(1)>=0)THEN !<-- If yes, this parent task sent key preliminary bndry info -! - IF(INFO_R(5)/=MYPE.OR.INFO_R(6)/=MY_DOMAIN_ID)THEN !<-- Is data really for my task on this domain? - WRITE(0,*)' Recvd South H data that is not mine!!' - WRITE(0,*)' Parent data sent to child task ',INFO_R(5),' on domain ',INFO_R(6) - WRITE(0,*)' But I am child task ',MYPE,' on domain ID ',MY_DOMAIN_ID - CYCLE !<-- If not then move on to next parent task's data. - ENDIF -! - KOUNT=KOUNT+1 - DO N1=1,4 - PARENT_INFO(N1,KOUNT)=INFO_R(N1) !<-- Save the data from that parent task - ENDDO -! write(0,*)' CHILD_RECVS_CHILD_DATA_LIMITS south_h info_r=',info_r,' kount=',kount - ENDIF -! - ENDDO -! - IF(KOUNT==2)THEN !<-- Nest task recvs data from two parent tasks - IF(PARENT_INFO(1,1)>PARENT_INFO(1,2))THEN !<-- Data recvd from 'out of order' parent tasks -! - DO N1=1,4 !<-- Save parent data in order of ascending task IDs - TEMP(N1) =PARENT_INFO(N1,1) ! - PARENT_INFO(N1,1)=PARENT_INFO(N1,2) ! - PARENT_INFO(N1,2)=TEMP(N1) !<-- - ENDDO -! - ENDIF - ENDIF -! - IF(KOUNT>0)THEN - DO N=1,KOUNT - PARENT_TASK(N)%SOUTH_H%ID_SOURCE =PARENT_INFO(1,N) !<-- Rank of parent task that will send Sboundary H data segment - PARENT_TASK(N)%SOUTH_H%INDX_START =PARENT_INFO(2,N) !<-- Istart on child grid of the boundary data segment - PARENT_TASK(N)%SOUTH_H%INDX_END =PARENT_INFO(3,N) !<-- Iend on child grid of the boundary data segment - PARENT_TASK(N)%SOUTH_H%INDX_END_EXP=PARENT_INFO(4,N) !<-- Iend on child grid of the expanded boundary data segment -! - NBASE =(PARENT_INFO(3,N)-PARENT_INFO(2,N)+1)*N_BLEND_H - LENGTH=NLEV_H*NBASE -! - PARENT_TASK(N)%SOUTH_H%LENGTH=LENGTH !<-- # of words in this parent task's datastring of child bndry -! - ALLOCATE(PARENT_TASK(N)%SOUTH_H%STRING(1:LENGTH)) !<-- Sboundary H datastring to be received from parent task -! - INDX_MIN_H%SOUTH=MIN(INDX_MIN_H%SOUTH,PARENT_INFO(2,N)) !<-- Starting child I for union of parent task segments sent - INDX_MAX_H%SOUTH=MAX(INDX_MAX_H%SOUTH,PARENT_INFO(3,N)) !<-- Ending child I for union of parent task segments sent - ENDDO - ENDIF -! - NUM_PARENT_TASKS_SENDING_H%SOUTH=KOUNT -!!! LENGTH_BND_SEG_H%SOUTH=INDX_MAX_H%SOUTH-INDX_MIN_H%SOUTH+1 -! - south_h: IF(NUM_PARENT_TASKS_SENDING_H%SOUTH>0)THEN !<-- Does this child task recv Sboundary H data from parent? -! - ALLOCATE(cc%PDB_S(INDX_MIN_H%SOUTH:INDX_MAX_H%SOUTH,1:N_BLEND_H)) !<-- Full PDB south H boundary segment on this child task -! - IF(NVARS_BC_2D_H>1)THEN - DO NV=1,NVARS_BC_2D_H-1 - ALLOCATE(cc%MY_BC_VARS_H_S%VAR_2D(NV)%SIDE(INDX_MIN_H%SOUTH:INDX_MAX_H%SOUTH,1:N_BLEND_H)) !<-- 2-D BC H-pt vbls except PD - ENDDO - ENDIF -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - ALLOCATE(cc%MY_BC_VARS_H_S%VAR_3D(NV)%SIDE(INDX_MIN_H%SOUTH:INDX_MAX_H%SOUTH,1:N_BLEND_H,1:LM)) !<-- 3-D BC H-pt vbls - ENDDO - ENDIF -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - LB=LBND_4D(NV) - UB=UBND_4D(NV) - ALLOCATE(cc%MY_BC_VARS_H_S%VAR_4D(NV)%SIDE(INDX_MIN_H%SOUTH:INDX_MAX_H%SOUTH,1:N_BLEND_H,1:LM,LB:UB)) !<-- 4-D BC H-pt vbls - ENDDO - ENDIF -! - ILIM_LO=INDX_MIN_H%SOUTH - ILIM_HI=INDX_MAX_H%SOUTH - JLIM_LO=1 - JLIM_HI=N_BLEND_H -! - LENGTH=NLEV_H*(ILIM_HI-ILIM_LO+1)*(JLIM_HI-JLIM_LO+1) - ALLOCATE(cc%BOUND_1D_SOUTH_H(1:LENGTH),stat=ISTAT) !<-- 1-D combined H-point data on child task's Sbndry segment -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry H Data Lower I Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state - ,name ='ILIM_LO_SOUTH_H' & !<-- Name of the boundary array's lower I limit - ,value=ILIM_LO & !<-- The boundary array's lower I limit - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry H Data Upper I Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state - ,name ='ILIM_HI_SOUTH_H' & !<-- Name of the boundary array's upper I limit - ,value=ILIM_HI & !<-- The boundary array's upper I limit - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry H Data Lower J Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state - ,name ='JLIM_LO_SOUTH_H' & !<-- Name of the boundary array's lower J limit - ,value=JLIM_LO & !<-- The boundary array's lower J limit - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry H Data Upper J Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state - ,name ='JLIM_HI_SOUTH_H' & !<-- Name of the boundary array's upper J limit - ,value=JLIM_HI & !<-- The boundary array's upper J limit - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF south_h -! -!----------------------------------------------------------------------- -! -!------------- -!*** South V -!------------- -! - KOUNT=0 - INDX_MIN_V%SOUTH= 1000000 - INDX_MAX_V%SOUTH=-1000000 - NTAG_RECV=22222+MYPE+ID_ADD !<-- Combine child task rank and child domain ID for unique tag -! - DO N=0,FTASKS_DOMAIN(ID_DOM)-1 !<-- Child task loops through its parent's tasks -! - CALL MPI_RECV(INFO_R & !<-- Receive data packet from each parent task - ,5 & !<-- # of words in data packet - ,MPI_INTEGER & !<-- Datatype - ,N & !<-- Rank of parent task that is sending -! ,22222 & !<-- Tag used for south boundary V points - ,NTAG_RECV & !<-- Tag used for south boundary V points - ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator between child and parent - ,STATUS & !<-- Status of Recv - ,IERR) -! - IF(INFO_R(1)>=0)THEN !<-- If yes, this parent task has key preliminary bndry info -! - IF(INFO_R(4)/=MYPE.OR.INFO_R(5)/=MY_DOMAIN_ID)THEN !<-- Is data really for my task on this domain? - WRITE(0,*)' Recvd South V data that is not mine!!' - WRITE(0,*)' Parent data sent to child task ',INFO_R(4),' on domain ',INFO_R(5) - WRITE(0,*)' But I am child task ',MYPE,' on domain ID ',MY_DOMAIN_ID - CYCLE !<-- If not then move on to next parent task's data. - ENDIF -! - KOUNT=KOUNT+1 - DO N1=1,3 - PARENT_INFO(N1,KOUNT)=INFO_R(N1) !<-- Save the data from that parent task - ENDDO - ENDIF -! - ENDDO -! - IF(KOUNT==2)THEN !<-- Nest task recvs data from two parent tasks - IF(PARENT_INFO(1,1)>PARENT_INFO(1,2))THEN !<-- Data recvd from 'out of order' parent tasks -! - DO N1=1,3 !<-- Save parent data in order of ascending task IDs - TEMP(N1) =PARENT_INFO(N1,1) ! - PARENT_INFO(N1,1)=PARENT_INFO(N1,2) ! - PARENT_INFO(N1,2)=TEMP(N1) !<-- - ENDDO -! - ENDIF - ENDIF -! - IF(KOUNT>0)THEN - DO N=1,KOUNT - PARENT_TASK(N)%SOUTH_V%ID_SOURCE =PARENT_INFO(1,N) !<-- Rank of parent task that will send Sboundary V data segment - PARENT_TASK(N)%SOUTH_V%INDX_START=PARENT_INFO(2,N) !<-- Istart on child grid of the boundary data segment - PARENT_TASK(N)%SOUTH_V%INDX_END =PARENT_INFO(3,N) !<-- Iend on child grid of the boundary data segment -! - NBASE =(PARENT_INFO(3,N)-PARENT_INFO(2,N)+1)*N_BLEND_V - LENGTH=NLEV_V*NBASE -! - PARENT_TASK(N)%SOUTH_V%LENGTH=LENGTH !<-- # of words in this parent task's datastring of child bndry -! - ALLOCATE(PARENT_TASK(N)%SOUTH_V%STRING(1:LENGTH)) !<-- Sboundary V datastring to be received from parent task -! - INDX_MIN_V%SOUTH=MIN(INDX_MIN_V%SOUTH,PARENT_INFO(2,N)) !<-- Starting child I for union of parent task segments sent - INDX_MAX_V%SOUTH=MAX(INDX_MAX_V%SOUTH,PARENT_INFO(3,N)) !<-- Ending child I for union of parent task segments sent - ENDDO - ENDIF -! - NUM_PARENT_TASKS_SENDING_V%SOUTH=KOUNT -!!! LENGTH_BND_SEG_V%SOUTH=INDX_MAX_V%SOUTH-INDX_MIN_V%SOUTH+1 -! - south_v: IF(NUM_PARENT_TASKS_SENDING_V%SOUTH>0)THEN !<-- Does this child task recv any Sboundary V data from parent? -! - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - ALLOCATE(cc%MY_BC_VARS_V_S%VAR_2D(NV)%SIDE(INDX_MIN_V%SOUTH:INDX_MAX_V%SOUTH,1:N_BLEND_V)) !<-- 2-D vbls on this child task's - ! south V bndry segment. - ENDDO - ENDIF -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - ALLOCATE(cc%MY_BC_VARS_V_S%VAR_3D(NV)%SIDE(INDX_MIN_V%SOUTH:INDX_MAX_V%SOUTH,1:N_BLEND_V,1:LM)) !<-- 3-D vbls on this child task's - ! south V bndry segment. - ENDDO - ENDIF -! - ILIM_LO=INDX_MIN_V%SOUTH - ILIM_HI=INDX_MAX_V%SOUTH - JLIM_LO=1 - JLIM_HI=N_BLEND_V -! - LENGTH=NLEV_V*(ILIM_HI-ILIM_LO+1)*(JLIM_HI-JLIM_LO+1) - ALLOCATE(cc%BOUND_1D_SOUTH_V(1:LENGTH),stat=ISTAT) !<-- 1-D combined V-point data on child task's Sbndry segment -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry V Data Lower I Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state - ,name ='ILIM_LO_SOUTH_V' & !<-- Name of the boundary array's lower I limit - ,value=ILIM_LO & !<-- The boundary array's lower I limit - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry V Data Upper I Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state - ,name ='ILIM_HI_SOUTH_V' & !<-- Name of the boundary array's upper I limit - ,value=ILIM_HI & !<-- The boundary array's upper I limit - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry V Data Lower J Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state - ,name ='JLIM_LO_SOUTH_V' & !<-- Name of the boundary array's lower J limit - ,value=JLIM_LO & !<-- The boundary array's lower J limit - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry V Data Upper J Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state - ,name ='JLIM_HI_SOUTH_V' & !<-- Name of the boundary array's upper J limit - ,value=JLIM_HI & !<-- The boundary array's upper J limit - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF south_v -! -!----------------------------------------------------------------------- -! -!------------- -!*** North H -!------------- -! - KOUNT=0 - INDX_MIN_H%NORTH= 1000000 - INDX_MAX_H%NORTH=-1000000 - NTAG_RECV=33333+MYPE+ID_ADD !<-- Combine child task rank and child domain ID for unique tag -! - DO N=0,FTASKS_DOMAIN(ID_DOM)-1 !<-- Child task loops through its parent's tasks -! - CALL MPI_RECV(INFO_R & !<-- Receive data packet from each parent task - ,6 & !<-- # of words in data packet - ,MPI_INTEGER & !<-- Datatype - ,N & !<-- Rank of parent task that is sending -! ,33333 & !<-- Tag used for north boundary H points - ,NTAG_RECV & !<-- Tag used for north boundary H points - ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator between child and parent - ,STATUS & !<-- Status of Recv - ,IERR) -! - IF(INFO_R(1)>=0)THEN !<-- If yes, this parent task has key preliminary bndry info -! - IF(INFO_R(5)/=MYPE.OR.INFO_R(6)/=MY_DOMAIN_ID)THEN !<-- Is data really for my task on this domain? - WRITE(0,*)' Recvd North H data that is not mine!!' - WRITE(0,*)' Parent data sent to child task ',INFO_R(5),' on domain ',INFO_R(6) - WRITE(0,*)' But I am child task ',MYPE,' on domain ID ',MY_DOMAIN_ID - CYCLE !<-- If not then move on to next parent task's data. - ENDIF -! - KOUNT=KOUNT+1 - DO N1=1,4 - PARENT_INFO(N1,KOUNT)=INFO_R(N1) !<-- Save the data from that parent task - ENDDO - ENDIF -! - ENDDO -! - IF(KOUNT==2)THEN !<-- Nest task recvs data from two parent tasks - IF(PARENT_INFO(1,1)>PARENT_INFO(1,2))THEN !<-- Data recvd from 'out of order' parent tasks -! - DO N1=1,4 !<-- Save parent data in order of ascending task IDs - TEMP(N1) =PARENT_INFO(N1,1) ! - PARENT_INFO(N1,1)=PARENT_INFO(N1,2) ! - PARENT_INFO(N1,2)=TEMP(N1) !<-- - ENDDO -! - ENDIF - ENDIF -! - IF(KOUNT>0)THEN - DO N=1,KOUNT - PARENT_TASK(N)%NORTH_H%ID_SOURCE =PARENT_INFO(1,N) !<-- Rank of parent task that will send Nboundary H data segment - PARENT_TASK(N)%NORTH_H%INDX_START =PARENT_INFO(2,N) !<-- Istart on child grid of the boundary data segment - PARENT_TASK(N)%NORTH_H%INDX_END =PARENT_INFO(3,N) !<-- Iend on child grid of the boundary data segment - PARENT_TASK(N)%NORTH_H%INDX_END_EXP=PARENT_INFO(4,N) !<-- Iend on child grid of the expanded boundary data segment -! - NBASE =(PARENT_INFO(3,N)-PARENT_INFO(2,N)+1)*N_BLEND_H - LENGTH=NLEV_H*NBASE -! - PARENT_TASK(N)%NORTH_H%LENGTH=LENGTH !<-- # of words in this parent task's datastring of child bndry -! - ALLOCATE(PARENT_TASK(N)%NORTH_H%STRING(1:LENGTH)) !<-- Nboundary H datastring to be received from parent task -! - INDX_MIN_H%NORTH=MIN(INDX_MIN_H%NORTH,PARENT_INFO(2,N)) !<-- Starting child I for union of parent task segments sent - INDX_MAX_H%NORTH=MAX(INDX_MAX_H%NORTH,PARENT_INFO(3,N)) !<-- Ending child I for union of parent task segments sent - ENDDO - ENDIF -! - NUM_PARENT_TASKS_SENDING_H%NORTH=KOUNT -!!! LENGTH_BND_SEG_H%NORTH=INDX_MAX_H%NORTH-INDX_MIN_H%NORTH+1 -! - north_h: IF(NUM_PARENT_TASKS_SENDING_H%NORTH>0)THEN !<-- Does this child task recv Nboundary H data from parent? -! - ALLOCATE(cc%PDB_N(INDX_MIN_H%NORTH:INDX_MAX_H%NORTH,1:N_BLEND_H)) -! - IF(NVARS_BC_2D_H>1)THEN - DO NV=1,NVARS_BC_2D_H-1 - ALLOCATE(cc%MY_BC_VARS_H_N%VAR_2D(NV)%SIDE(INDX_MIN_H%NORTH:INDX_MAX_H%NORTH,1:N_BLEND_H)) !<-- 2-D BC H-pt vbls except PD - ENDDO - ENDIF -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - ALLOCATE(cc%MY_BC_VARS_H_N%VAR_3D(NV)%SIDE(INDX_MIN_H%NORTH:INDX_MAX_H%NORTH,1:N_BLEND_H,1:LM)) !<-- 3-D BC H-pt vbls - ENDDO - ENDIF -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - LB=LBND_4D(NV) - UB=UBND_4D(NV) - ALLOCATE(cc%MY_BC_VARS_H_N%VAR_4D(NV)%SIDE(INDX_MIN_H%NORTH:INDX_MAX_H%NORTH,1:N_BLEND_H,1:LM,LB:UB)) !<-- 4-D BC H-pt vbls - ENDDO - ENDIF -! - ILIM_LO=INDX_MIN_H%NORTH - ILIM_HI=INDX_MAX_H%NORTH - JLIM_LO=1 - JLIM_HI=N_BLEND_H -! - LENGTH=NLEV_H*(ILIM_HI-ILIM_LO+1)*(JLIM_HI-JLIM_LO+1) - ALLOCATE(cc%BOUND_1D_NORTH_H(1:LENGTH),stat=ISTAT) !<-- 1-D combined H-point data on child task's Nbndry segment -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry H Data Lower I Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state - ,name ='ILIM_LO_NORTH_H' & !<-- Name of the boundary array's lower I limit - ,value=ILIM_LO & !<-- The boundary array's lower I limit - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry H Data Upper I Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state - ,name ='ILIM_HI_NORTH_H' & !<-- Name of the boundary array's upper I limit - ,value=ILIM_HI & !<-- The boundary array's upper I limit - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry H Data Lower J Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state - ,name ='JLIM_LO_NORTH_H' & !<-- Name of the boundary array's lower J limit - ,value=JLIM_LO & !<-- The boundary array's lower J limit - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry H Data Upper J Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state - ,name ='JLIM_HI_NORTH_H' & !<-- Name of the boundary array's upper J limit - ,value=JLIM_HI & !<-- The boundary array's upper J limit - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF north_h -! -!----------------------------------------------------------------------- -! -!------------- -!*** North V -!------------- -! - KOUNT=0 - INDX_MIN_V%NORTH= 1000000 - INDX_MAX_V%NORTH=-1000000 - NTAG_RECV=44444+MYPE+ID_ADD !<-- Combine child task rank and child domain ID for unique tag -! - DO N=0,FTASKS_DOMAIN(ID_DOM)-1 !<-- Child task loops through its parent's tasks -! - CALL MPI_RECV(INFO_R & !<-- Receive data packet from each parent task - ,5 & !<-- # of words in data packet - ,MPI_INTEGER & !<-- Datatype - ,N & !<-- Rank of parent task that is sending -! ,44444 & !<-- Tag used for north boundary V points - ,NTAG_RECV & !<-- Tag used for north boundary V points - ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator between child and parent - ,STATUS & !<-- Status of Recv - ,IERR) -! - IF(INFO_R(1)>=0)THEN !<-- If yes, this parent task has key preliminary bndry info -! - IF(INFO_R(4)/=MYPE.OR.INFO_R(5)/=MY_DOMAIN_ID)THEN !<-- Is data really for my task on this domain? - WRITE(0,*)' Recvd North V data that is not mine!!' - WRITE(0,*)' Parent data sent to child task ',INFO_R(4),' on domain ',INFO_R(5) - WRITE(0,*)' But I am child task ',MYPE,' on domain ID ',MY_DOMAIN_ID - CYCLE !<-- If not then move on to next parent task's data. - ENDIF -! - KOUNT=KOUNT+1 -! if(kount>2)then -! write(0,*)' BUG: exceeded two parent tasks sending to this child bndry task' -! endif - DO N1=1,3 - PARENT_INFO(N1,KOUNT)=INFO_R(N1) !<-- Save the data from that parent task - ENDDO -!!!!!!!!!!!!!!!!!!!!!!!debug -! else -! write(0,*)' PARENT_TO_CHILD_DATA_LIMITS child recvd dummy north V from parent task #n=',n,' with id=',-1*info_r(1) -!!!!!!!!!!!!!!!!!!!!!!!debug - ENDIF -! - ENDDO -! - IF(KOUNT==2)THEN !<-- Nest task recvs data from two parent tasks - IF(PARENT_INFO(1,1)>PARENT_INFO(1,2))THEN !<-- Data recvd from 'out of order' parent tasks -! - DO N1=1,3 !<-- Save parent data in order of ascending task IDs - TEMP(N1) =PARENT_INFO(N1,1) ! - PARENT_INFO(N1,1)=PARENT_INFO(N1,2) ! - PARENT_INFO(N1,2)=TEMP(N1) !<-- - ENDDO -! - ENDIF - ENDIF -! - IF(KOUNT>0)THEN - DO N=1,KOUNT - PARENT_TASK(N)%NORTH_V%ID_SOURCE =PARENT_INFO(1,N) !<-- Rank of parent task that will send Nboundary V data segment - PARENT_TASK(N)%NORTH_V%INDX_START=PARENT_INFO(2,N) !<-- Istart on child grid of the boundary data segment - PARENT_TASK(N)%NORTH_V%INDX_END =PARENT_INFO(3,N) !<-- Iend on child grid of the boundary data segment -! - NBASE =(PARENT_INFO(3,N)-PARENT_INFO(2,N)+1)*N_BLEND_V - LENGTH=NLEV_V*NBASE -! - PARENT_TASK(N)%NORTH_V%LENGTH=LENGTH !<-- # of words in this parent task's datastring of child bndry -! - ALLOCATE(PARENT_TASK(N)%NORTH_V%STRING(1:LENGTH)) !<-- Nboundary V datastring to be received from parent task -! - INDX_MIN_V%NORTH=MIN(INDX_MIN_V%NORTH,PARENT_INFO(2,N)) !<-- Starting child I for union of parent task segments sent - INDX_MAX_V%NORTH=MAX(INDX_MAX_V%NORTH,PARENT_INFO(3,N)) !<-- Ending child I for union of parent task segments sent - ENDDO - ENDIF -! - NUM_PARENT_TASKS_SENDING_V%NORTH=KOUNT -!!! LENGTH_BND_SEG_V%NORTH=INDX_MAX_V%NORTH-INDX_MIN_V%NORTH+1 -! - north_v: IF(NUM_PARENT_TASKS_SENDING_V%NORTH>0)THEN !<-- Does this child task recv any Nboundary V data from parent? -! - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - ALLOCATE(cc%MY_BC_VARS_V_N%VAR_2D(NV)%SIDE(INDX_MIN_V%NORTH:INDX_MAX_V%NORTH,1:N_BLEND_V)) !<-- 2-D vbls on this child task's - ! north V bndry segment. - ENDDO - ENDIF -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - ALLOCATE(cc%MY_BC_VARS_V_N%VAR_3D(NV)%SIDE(INDX_MIN_V%NORTH:INDX_MAX_V%NORTH,1:N_BLEND_V,1:LM)) !<-- 3-D vbls on this child task's - ! north V bndry segment. - ENDDO - ENDIF -! - ILIM_LO=INDX_MIN_V%NORTH - ILIM_HI=INDX_MAX_V%NORTH - JLIM_LO=1 - JLIM_HI=N_BLEND_V -! - LENGTH=NLEV_V*(ILIM_HI-ILIM_LO+1)*(JLIM_HI-JLIM_LO+1) - ALLOCATE(cc%BOUND_1D_NORTH_V(1:LENGTH),stat=ISTAT) !<-- 1-D combined V-point data on child task's Nbndry segment -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry V Data Lower I Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state - ,name ='ILIM_LO_NORTH_V' & !<-- Name of the boundary array's lower I limit - ,value=ILIM_LO & !<-- The boundary array's lower I limit - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry V Data Upper I Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state - ,name ='ILIM_HI_NORTH_V' & !<-- Name of the boundary array's upper I limit - ,value=ILIM_HI & !<-- The boundary array's upper I limit - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry V Data Lower J Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state - ,name ='JLIM_LO_NORTH_V' & !<-- Name of the boundary array's lower J limit - ,value=JLIM_LO & !<-- The boundary array's lower J limit - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry V Data Upper J Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state - ,name ='JLIM_HI_NORTH_V' & !<-- Name of the boundary array's upper J limit - ,value=JLIM_HI & !<-- The boundary array's upper J limit - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF north_v -! -!----------------------------------------------------------------------- -! -!------------ -!*** West H -!------------ -! - KOUNT=0 - INDX_MIN_H%WEST= 1000000 - INDX_MAX_H%WEST=-1000000 - NTAG_RECV=55555+MYPE+ID_ADD !<-- Combine child task rank and child domain ID for unique tag -! - DO N=0,FTASKS_DOMAIN(ID_DOM)-1 !<-- Child task loops through its parent's tasks -! - CALL MPI_RECV(INFO_R & !<-- Receive data packet from each parent task - ,6 & !<-- # of words in data packet - ,MPI_INTEGER & !<-- Datatype - ,N & !<-- Rank of parent task that is sending -! ,55555 & !<-- Tag used for west boundary H points - ,NTAG_RECV & !<-- Tag used for west boundary H points - ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator between child and parent - ,STATUS & !<-- Status of Recv - ,IERR) -! - IF(INFO_R(1)>=0)THEN !<-- If yes, this parent task has key preliminary bndry info -! - IF(INFO_R(5)/=MYPE.OR.INFO_R(6)/=MY_DOMAIN_ID)THEN !<-- Is data really for my task on this domain? - WRITE(0,*)' Recvd West H data that is not mine!!' - WRITE(0,*)' Parent data sent to child task ',INFO_R(5),' on domain ',INFO_R(6) - WRITE(0,*)' But I am child task ',MYPE,' on domain ID ',MY_DOMAIN_ID - CYCLE !<-- If not then move on to next parent task's data. - ENDIF -! - KOUNT=KOUNT+1 - DO N1=1,4 - PARENT_INFO(N1,KOUNT)=INFO_R(N1) !<-- Save the data from that parent task - ENDDO - ENDIF -! - ENDDO -! - IF(KOUNT==2)THEN !<-- Nest task recvs data from two parent tasks - IF(PARENT_INFO(1,1)>PARENT_INFO(1,2))THEN !<-- Data recvd from 'out of order' parent tasks -! - DO N1=1,4 !<-- Save parent data in order of ascending task IDs - TEMP(N1) =PARENT_INFO(N1,1) ! - PARENT_INFO(N1,1)=PARENT_INFO(N1,2) ! - PARENT_INFO(N1,2)=TEMP(N1) !<-- - ENDDO -! - ENDIF - ENDIF -! - IF(KOUNT>0)THEN - DO N=1,KOUNT - PARENT_TASK(N)%WEST_H%ID_SOURCE =PARENT_INFO(1,N) !<-- Rank of parent task that will send Wboundary H data segment - PARENT_TASK(N)%WEST_H%INDX_START =PARENT_INFO(2,N) !<-- Jstart on child grid of the boundary data segment - PARENT_TASK(N)%WEST_H%INDX_END =PARENT_INFO(3,N) !<-- Jend on child grid of the boundary data segment - PARENT_TASK(N)%WEST_H%INDX_END_EXP=PARENT_INFO(4,N) !<-- Jend on child grid of the expanded boundary data segment -! - NBASE =(PARENT_INFO(3,N)-PARENT_INFO(2,N)+1)*N_BLEND_H - LENGTH=NLEV_H*NBASE -! - PARENT_TASK(N)%WEST_H%LENGTH=LENGTH !<-- # of words in this parent task's datastring of child bndry -! - ALLOCATE(PARENT_TASK(N)%WEST_H%STRING(1:LENGTH)) !<-- Wboundary H datastring to be received from parent task -! - INDX_MIN_H%WEST=MIN(INDX_MIN_H%WEST,PARENT_INFO(2,N)) !<-- Starting child J for union of parent task segments sent - INDX_MAX_H%WEST=MAX(INDX_MAX_H%WEST,PARENT_INFO(3,N)) !<-- Ending child J for union of parent task segments sent - ENDDO - ENDIF -! - NUM_PARENT_TASKS_SENDING_H%WEST=KOUNT -!!! LENGTH_BND_SEG_H%WEST=INDX_MAX_H%WEST-INDX_MIN_H%WEST+1 -! - west_h: IF(NUM_PARENT_TASKS_SENDING_H%WEST>0)THEN !<-- Does this child task recv Wboundary H data from parent? -! - ALLOCATE(cc%PDB_W(1:N_BLEND_H,INDX_MIN_H%WEST:INDX_MAX_H%WEST)) -! - IF(NVARS_BC_2D_H>1)THEN - DO NV=1,NVARS_BC_2D_H-1 - ALLOCATE(cc%MY_BC_VARS_H_W%VAR_2D(NV)%SIDE(1:N_BLEND_H,INDX_MIN_H%WEST:INDX_MAX_H%WEST)) !<-- 2-D BC H-pt vbls except PD - ENDDO - ENDIF -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - ALLOCATE(cc%MY_BC_VARS_H_W%VAR_3D(NV)%SIDE(1:N_BLEND_H,INDX_MIN_H%WEST:INDX_MAX_H%WEST,1:LM)) !<-- 3-D BC H-pt vbls - ENDDO - ENDIF -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - LB=LBND_4D(NV) - UB=UBND_4D(NV) - ALLOCATE(cc%MY_BC_VARS_H_W%VAR_4D(NV)%SIDE(1:N_BLEND_H,INDX_MIN_H%WEST:INDX_MAX_H%WEST,1:LM,LB:UB)) !<-- 4-D BC H-pt vbls - ENDDO - ENDIF -! - ILIM_LO=1 - ILIM_HI=N_BLEND_H - JLIM_LO=INDX_MIN_H%WEST - JLIM_HI=INDX_MAX_H%WEST -! - LENGTH=NLEV_H*(ILIM_HI-ILIM_LO+1)*(JLIM_HI-JLIM_LO+1) - ALLOCATE(cc%BOUND_1D_WEST_H(1:LENGTH),stat=ISTAT) !<-- 1-D combined H-point data on child task's Wbndry segment -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry H Data Lower I Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state - ,name ='ILIM_LO_WEST_H' & !<-- Name of the boundary array's lower I limit - ,value=ILIM_LO & !<-- The boundary array's lower I limit - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry H Data Upper I Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state - ,name ='ILIM_HI_WEST_H' & !<-- Name of the boundary array's upper I limit - ,value=ILIM_HI & !<-- The boundary array's upper I limit - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry H Data Lower J Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state - ,name ='JLIM_LO_WEST_H' & !<-- Name of the boundary array's lower J limit - ,value=JLIM_LO & !<-- The boundary array's lower J limit - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry H Data Upper J Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state - ,name ='JLIM_HI_WEST_H' & !<-- Name of the boundary array's upper J limit - ,value=JLIM_HI & !<-- The boundary array's upper J limit - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF west_h -! -!----------------------------------------------------------------------- -! -!------------ -!*** West V -!------------ -! - KOUNT=0 - INDX_MIN_V%WEST= 1000000 - INDX_MAX_V%WEST=-1000000 - NTAG_RECV=66666+MYPE+ID_ADD !<-- Combine child task rank and child domain ID for unique tag -! - DO N=0,FTASKS_DOMAIN(ID_DOM)-1 !<-- Child task loops through its parent's tasks -! - CALL MPI_RECV(INFO_R & !<-- Receive data packet from each parent task - ,5 & !<-- # of words in data packet - ,MPI_INTEGER & !<-- Datatype - ,N & !<-- Rank of parent task that is sending -! ,66666 & !<-- Tag used for west boundary V points - ,NTAG_RECV & !<-- Tag used for west boundary V points - ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator between child and parent - ,STATUS & !<-- Status of Recv - ,IERR) -! - IF(INFO_R(1)>=0)THEN !<-- If yes, this parent task has key preliminary bndry info -! - IF(INFO_R(4)/=MYPE.OR.INFO_R(5)/=MY_DOMAIN_ID)THEN !<-- Is data really for my task on this domain? - WRITE(0,*)' Recvd West V data that is not mine!!' - WRITE(0,*)' Parent data sent to child task ',INFO_R(4),' on domain ',INFO_R(5) - WRITE(0,*)' But I am child task ',MYPE,' on domain ID ',MY_DOMAIN_ID - CYCLE !<-- If not then move on to next parent task's data. - ENDIF -! - KOUNT=KOUNT+1 - DO N1=1,3 - PARENT_INFO(N1,KOUNT)=INFO_R(N1) !<-- Save the data from that parent task - ENDDO - ENDIF -! - ENDDO -! - IF(KOUNT==2)THEN !<-- Nest task recvs data from two parent tasks - IF(PARENT_INFO(1,1)>PARENT_INFO(1,2))THEN !<-- Data recvd from 'out of order' parent tasks -! - DO N1=1,3 !<-- Save parent data in order of ascending task IDs - TEMP(N1) =PARENT_INFO(N1,1) ! - PARENT_INFO(N1,1)=PARENT_INFO(N1,2) ! - PARENT_INFO(N1,2)=TEMP(N1) !<-- - ENDDO -! - ENDIF - ENDIF -! - IF(KOUNT>0)THEN - DO N=1,KOUNT - PARENT_TASK(N)%WEST_V%ID_SOURCE =PARENT_INFO(1,N) !<-- Rank of parent task that will send Wboundary V data segment - PARENT_TASK(N)%WEST_V%INDX_START=PARENT_INFO(2,N) !<-- Jstart on child grid of the boundary data segment - PARENT_TASK(N)%WEST_V%INDX_END =PARENT_INFO(3,N) !<-- Jend on child grid of the boundary data segment -! - NBASE =(PARENT_INFO(3,N)-PARENT_INFO(2,N)+1)*N_BLEND_V - LENGTH=NLEV_V*NBASE -! - PARENT_TASK(N)%WEST_V%LENGTH=LENGTH !<-- # of words in this parent task's datastring of child bndry -! - ALLOCATE(PARENT_TASK(N)%WEST_V%STRING(1:LENGTH)) !<-- Wboundary V datastring to be received from parent task -! - INDX_MIN_V%WEST=MIN(INDX_MIN_V%WEST,PARENT_INFO(2,N)) !<-- Starting child J for union of parent task segments sent - INDX_MAX_V%WEST=MAX(INDX_MAX_V%WEST,PARENT_INFO(3,N)) !<-- Ending child J for union of parent task segments sent - ENDDO - ENDIF -! - NUM_PARENT_TASKS_SENDING_V%WEST=KOUNT -!!! LENGTH_BND_SEG_V%WEST=INDX_MAX_V%WEST-INDX_MIN_V%WEST+1 -! - west_v: IF(NUM_PARENT_TASKS_SENDING_V%WEST>0)THEN !<-- Does this child task recv Wboundary V data from parent? -! - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - ALLOCATE(cc%MY_BC_VARS_V_W%VAR_2D(NV)%SIDE(1:N_BLEND_V,INDX_MIN_V%WEST:INDX_MAX_V%WEST)) !<-- 2-D vbls on this child task's - ! west V bndry segment. - ENDDO - ENDIF -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - ALLOCATE(cc%MY_BC_VARS_V_W%VAR_3D(NV)%SIDE(1:N_BLEND_V,INDX_MIN_V%WEST:INDX_MAX_V%WEST,1:LM)) !<-- 3-D vbls on this child task's - ! west V bndry segment. - ENDDO - ENDIF -! - ILIM_LO=1 - ILIM_HI=N_BLEND_V - JLIM_LO=INDX_MIN_V%WEST - JLIM_HI=INDX_MAX_V%WEST -! - LENGTH=NLEV_V*(ILIM_HI-ILIM_LO+1)*(JLIM_HI-JLIM_LO+1) - ALLOCATE(cc%BOUND_1D_WEST_V(1:LENGTH),stat=ISTAT) !<-- 1-D combined V-point data on child task's Wbndry segment -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry V Data Lower I Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state - ,name ='ILIM_LO_WEST_V' & !<-- Name of the boundary array's lower I limit - ,value=ILIM_LO & !<-- The boundary array's lower I limit - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry V Data Upper I Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state - ,name ='ILIM_HI_WEST_V' & !<-- Name of the boundary array's upper I limit - ,value=ILIM_HI & !<-- The boundary array's upper I limit - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry V Data Lower J Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state - ,name ='JLIM_LO_WEST_V' & !<-- Name of the boundary array's lower J limit - ,value=JLIM_LO & !<-- The boundary array's lower J limit - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry V Data Upper J Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state - ,name ='JLIM_HI_WEST_V' & !<-- Name of the boundary array's upper J limit - ,value=JLIM_HI & !<-- The boundary array's upper J limit - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF west_v -! -!----------------------------------------------------------------------- -! -!------------ -!*** East H -!------------ -! - KOUNT=0 - INDX_MIN_H%EAST= 1000000 - INDX_MAX_H%EAST=-1000000 - NTAG_RECV=77777+MYPE+ID_ADD !<-- Combine child task rank and child domain ID for unique tag -! -! call date_and_time(values=values) -! write(0,9876)values(5),values(6),values(7),values(8) - 9876 format(' Ready to recv E_H info from parent tasks at ',i2.2,':',i2.2,':',i2.2,'.',i3.3) - DO N=0,FTASKS_DOMAIN(ID_DOM)-1 !<-- Child task loops through its parent's tasks -! - CALL MPI_RECV(INFO_R & !<-- Receive data packet from each parent task - ,6 & !<-- # of words in data packet - ,MPI_INTEGER & !<-- Datatype - ,N & !<-- Rank of parent task that is sending -! ,77777 & !<-- Tag used for east boundary H points - ,NTAG_RECV & !<-- Tag used for east boundary H points - ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator between child and parent - ,STATUS & !<-- Status of Recv - ,IERR) -! -! source = status(MPI_SOURCE) -! tag = status(MPI_TAG) - IF(INFO_R(1)>=0)THEN !<-- If yes, this parent task has key preliminary bndry info -! -! IF(INFO_R(5)/=MYPE.OR.INFO_R(6)/=MY_DOMAIN_ID)THEN !<-- Is data really for my task on this domain? -! WRITE(0,*)' Recvd East H data that is not mine!!' -! WRITE(0,*)' Parent data sent to child task ',INFO_R(5),' on domain ',INFO_R(6) -! WRITE(0,*)' But I am child task ',MYPE,' on domain ID ',MY_DOMAIN_ID -! write(0,*)' source=',source,' tag=',tag -! CYCLE !<-- If not then move on to next parent task's data. -! ENDIF -! - KOUNT=KOUNT+1 - DO N1=1,4 - PARENT_INFO(N1,KOUNT)=INFO_R(N1) !<-- Save the data from that parent task - ENDDO - ENDIF -! - ENDDO -! - IF(KOUNT==2)THEN !<-- Nest task recvs data from two parent tasks - IF(PARENT_INFO(1,1)>PARENT_INFO(1,2))THEN !<-- Data recvd from 'out of order' parent tasks -! - DO N1=1,4 !<-- Save parent data in order of ascending task IDs - TEMP(N1) =PARENT_INFO(N1,1) ! - PARENT_INFO(N1,1)=PARENT_INFO(N1,2) ! - PARENT_INFO(N1,2)=TEMP(N1) !<-- - ENDDO -! - ENDIF - ENDIF -! - IF(KOUNT>0)THEN - DO N=1,KOUNT - PARENT_TASK(N)%EAST_H%ID_SOURCE =PARENT_INFO(1,N) !<-- Rank of parent task that will send Eboundary H data segment - PARENT_TASK(N)%EAST_H%INDX_START =PARENT_INFO(2,N) !<-- Jstart on child grid of the boundary data segment - PARENT_TASK(N)%EAST_H%INDX_END =PARENT_INFO(3,N) !<-- Jend on child grid of the boundary data segment - PARENT_TASK(N)%EAST_H%INDX_END_EXP=PARENT_INFO(4,N) !<-- Jend on child grid of the expanded boundary data segment -! - NBASE =(PARENT_INFO(3,N)-PARENT_INFO(2,N)+1)*N_BLEND_H - LENGTH=NLEV_H*NBASE -! - PARENT_TASK(N)%EAST_H%LENGTH=LENGTH !<-- # of words in this parent task's datastring of child bndry -! - ALLOCATE(PARENT_TASK(N)%EAST_H%STRING(1:LENGTH)) !<-- Eboundary H datastring to be received from parent task -! - INDX_MIN_H%EAST=MIN(INDX_MIN_H%EAST,PARENT_INFO(2,N)) !<-- Starting child J for union of parent task segments sent - INDX_MAX_H%EAST=MAX(INDX_MAX_H%EAST,PARENT_INFO(3,N)) !<-- Ending child J for union of parent task segments sent - ENDDO - ENDIF -! - NUM_PARENT_TASKS_SENDING_H%EAST=KOUNT -!!! LENGTH_BND_SEG_H%EAST=INDX_MAX_H%EAST-INDX_MIN_H%EAST+1 -! - east_h: IF(NUM_PARENT_TASKS_SENDING_H%EAST>0)THEN !<-- Does this child task recv Eboundary H data from parent? -! - ALLOCATE(cc%PDB_E(1:N_BLEND_H,INDX_MIN_H%EAST:INDX_MAX_H%EAST)) -! - IF(NVARS_BC_2D_H>1)THEN - DO NV=1,NVARS_BC_2D_H-1 - ALLOCATE(cc%MY_BC_VARS_H_E%VAR_2D(NV)%SIDE(1:N_BLEND_H,INDX_MIN_H%EAST:INDX_MAX_H%EAST)) !<-- 2-D BC H-pt vbls except PD - ENDDO - ENDIF -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - ALLOCATE(cc%MY_BC_VARS_H_E%VAR_3D(NV)%SIDE(1:N_BLEND_H,INDX_MIN_H%EAST:INDX_MAX_H%EAST,1:LM)) !<-- 3-D BC H-pt vbls - ENDDO - ENDIF -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - LB=LBND_4D(NV) - UB=UBND_4D(NV) - ALLOCATE(cc%MY_BC_VARS_H_E%VAR_4D(NV)%SIDE(1:N_BLEND_H,INDX_MIN_H%EAST:INDX_MAX_H%EAST,1:LM,LB:UB)) !<-- 4-D BC H-pt vbls - ENDDO - ENDIF -! - ILIM_LO=1 - ILIM_HI=N_BLEND_H - JLIM_LO=INDX_MIN_H%EAST - JLIM_HI=INDX_MAX_H%EAST -! - LENGTH=NLEV_H*(ILIM_HI-ILIM_LO+1)*(JLIM_HI-JLIM_LO+1) - ALLOCATE(cc%BOUND_1D_EAST_H(1:LENGTH),stat=ISTAT) !<-- 1-D combined H-point data on child task's Ebndry segment -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry H Data Lower I Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state - ,name ='ILIM_LO_EAST_H' & !<-- Name of the boundary array's lower I limit - ,value=ILIM_LO & !<-- The boundary array's lower I limit - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry H Data Upper I Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state - ,name ='ILIM_HI_EAST_H' & !<-- Name of the boundary array's upper I limit - ,value=ILIM_HI & !<-- The boundary array's upper I limit - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry H Data Lower J Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state - ,name ='JLIM_LO_EAST_H' & !<-- Name of the boundary array's lower J limit - ,value=JLIM_LO & !<-- The boundary array's lower J limit - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry H Data Upper J Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state - ,name ='JLIM_HI_EAST_H' & !<-- Name of the boundary array's upper J limit - ,value=JLIM_HI & !<-- The boundary array's upper J limit - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF east_h -! -!----------------------------------------------------------------------- -! -!------------ -!*** East V -!------------ -! - KOUNT=0 - INDX_MIN_V%EAST= 1000000 - INDX_MAX_V%EAST=-1000000 - NTAG_RECV=88888+MYPE+ID_ADD !<-- Combine child task rank and child domain ID for unique tag -! - DO N=0,FTASKS_DOMAIN(ID_DOM)-1 !<-- Child task loops through its parent's tasks -! - CALL MPI_RECV(INFO_R & !<-- Receive data packet from each parent task - ,5 & !<-- # of words in data packet - ,MPI_INTEGER & !<-- Datatype - ,N & !<-- Rank of parent task that is sending -! ,88888 & !<-- Tag used for east boundary V points - ,NTAG_RECV & !<-- Tag used for east boundary V points - ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator between child and parent - ,STATUS & !<-- Status of Recv - ,IERR) -! source=status(mpi_source) -! tag=status(mpi_tag) -! write(0,*)' parent task #',n,' source=',source,' info_r(1)=',info_r(1),' (2)=',info_r(2),' (3)=',info_r(3),' (4)=',info_r(4) & -! ,' (5)=',info_r(5) -! - IF(INFO_R(1)>=0)THEN !<-- If yes, this parent task has key preliminary bndry info -! - IF(INFO_R(4)/=MYPE.OR.INFO_R(5)/=MY_DOMAIN_ID)THEN !<-- Is data really for my task on this domain? - WRITE(0,*)' Recvd East V data that is not mine!!' - WRITE(0,*)' Parent data sent to child task ',INFO_R(4),' on domain ',INFO_R(5) - WRITE(0,*)' But I am child task ',MYPE,' on domain ID ',MY_DOMAIN_ID -! WRITE(0,*)' Message was sent from task ',source,' with tag=',tag - CYCLE !<-- If not then move on to next parent task's data. - ENDIF -! - KOUNT=KOUNT+1 - DO N1=1,3 - PARENT_INFO(N1,KOUNT)=INFO_R(N1) !<-- Save the data from that parent task - ENDDO - ENDIF -! - ENDDO -! - IF(KOUNT==2)THEN !<-- Nest task recvs data from two parent tasks - IF(PARENT_INFO(1,1)>PARENT_INFO(1,2))THEN !<-- Data recvd from 'out of order' parent tasks -! - DO N1=1,3 !<-- Save parent data in order of ascending task IDs - TEMP(N1) =PARENT_INFO(N1,1) ! - PARENT_INFO(N1,1)=PARENT_INFO(N1,2) ! - PARENT_INFO(N1,2)=TEMP(N1) !<-- - ENDDO -! - ENDIF - ENDIF -! - IF(KOUNT>0)THEN - DO N=1,KOUNT -! - PARENT_TASK(N)%EAST_V%ID_SOURCE =PARENT_INFO(1,N) !<-- Rank of parent task that will send Eboundary V data segment - PARENT_TASK(N)%EAST_V%INDX_START=PARENT_INFO(2,N) !<-- Jstart on child grid of the boundary data segment - PARENT_TASK(N)%EAST_V%INDX_END =PARENT_INFO(3,N) !<-- Jend on child grid of the boundary data segment -! - NBASE =(PARENT_INFO(3,N)-PARENT_INFO(2,N)+1)*N_BLEND_V - LENGTH=NLEV_V*NBASE -! - PARENT_TASK(N)%EAST_V%LENGTH=LENGTH !<-- # of words in this parent task's datastring of child bndry -! - ALLOCATE(PARENT_TASK(N)%EAST_V%STRING(1:LENGTH)) !<-- Eboundary V datastring to be received from parent task -! - INDX_MIN_V%EAST=MIN(INDX_MIN_V%EAST,PARENT_INFO(2,N)) !<-- Starting child J for union of parent task segments sent - INDX_MAX_V%EAST=MAX(INDX_MAX_V%EAST,PARENT_INFO(3,N)) !<-- Ending child J for union of parent task segments sent - ENDDO - ENDIF -! - NUM_PARENT_TASKS_SENDING_V%EAST=KOUNT -!!! LENGTH_BND_SEG_V%EAST=INDX_MAX_V%EAST-INDX_MIN_V%EAST+1 -! - east_v: IF(NUM_PARENT_TASKS_SENDING_V%EAST>0)THEN !<-- Does this child task recv Eboundary V data from parent? -! - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - ALLOCATE(cc%MY_BC_VARS_V_E%VAR_2D(NV)%SIDE(1:N_BLEND_V,INDX_MIN_V%EAST:INDX_MAX_V%EAST)) !<-- 2-D vbls on this child task's - ! east V bndry segment. - ENDDO - ENDIF -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - ALLOCATE(cc%MY_BC_VARS_V_E%VAR_3D(NV)%SIDE(1:N_BLEND_V,INDX_MIN_V%EAST:INDX_MAX_V%EAST,1:LM)) !<-- 3-D vbls on this child task's - ! east V bndry segment. - ENDDO - ENDIF -! - ILIM_LO=1 - ILIM_HI=N_BLEND_V - JLIM_LO=INDX_MIN_V%EAST - JLIM_HI=INDX_MAX_V%EAST -! - LENGTH=NLEV_V*(ILIM_HI-ILIM_LO+1)*(JLIM_HI-JLIM_LO+1) !<-- All V-pt BC variables are assumed to be 3-D - ALLOCATE(cc%BOUND_1D_EAST_V(1:LENGTH),stat=ISTAT) !<-- 1-D combined V-point data on child task's Ebndry segment -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry V Data Lower I Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state - ,name ='ILIM_LO_EAST_V' & !<-- Name of the boundary array's lower I limit - ,value=ILIM_LO & !<-- The boundary array's lower I limit - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry V Data Upper I Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state - ,name ='ILIM_HI_EAST_V' & !<-- Name of the boundary array's upper I limit - ,value=ILIM_HI & !<-- The boundary array's upper I limit - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry V Data Lower J Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state - ,name ='JLIM_LO_EAST_V' & !<-- Name of the boundary array's lower J limit - ,value=JLIM_LO & !<-- The boundary array's lower J limit - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry V Data Upper J Limit" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=EXP_STATE & !<-- The Parent_Child Coupler export state - ,name ='JLIM_HI_EAST_V' & !<-- Name of the boundary array's upper J limit - ,value=JLIM_HI & !<-- The boundary array's upper J limit - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_LIMITS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF east_v -! -!----------------------------------------------------------------------- -! - END SUBROUTINE CHILD_RECVS_CHILD_DATA_LIMITS -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE CHILD_SENDS_TOPO_TO_PARENT(MY_DOMAIN_ID & - ,IMP_STATE ) -! -!----------------------------------------------------------------------- -!*** The children send their boundary surface geopotential to their -!*** parents so the parents can properly balance their own data that -!*** they interpolate to child boundary gridpoints. -!----------------------------------------------------------------------- -! -!----------------------- -!*** Argument Variables -!----------------------- -! - INTEGER(kind=KINT),INTENT(IN) :: MY_DOMAIN_ID !<-- This child's domain ID -! - TYPE(ESMF_State),INTENT(IN) :: IMP_STATE !<-- Parent-Child Coupler import state -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: IERR,KOUNT,MYPE & - ,N,N1,N2,NTAG_SEND,NUM_WORDS & - ,RC,RC_FIS -! - INTEGER(kind=KINT) :: I_LO,I_HI,I_OFFSET & - ,J_LO,J_HI,J_OFFSET -! - INTEGER(kind=KINT),DIMENSION(MPI_STATUS_SIZE) :: STATUS -! - REAL(kind=KFPT),DIMENSION(:),ALLOCATABLE :: FIS_SEND -! - TYPE(ESMF_Field) :: HOLD_FIELD -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -! I_OFFSET=IMS-1+NHALO !<-- Offset of I in unloaded FIS vs. original FIS -! J_OFFSET=JMS-1+NHALO !<-- Offset of J in unloaded FIS vs. original FIS - I_OFFSET=0 !<-- ESMF_INDEX now GLOBAL - J_OFFSET=0 !<-- ESMF_INDEX now GLOBAL -! -!----------------------------------------------------------------------- -!*** Extract the Sfc Geopotential from the Coupler's import state. -!*** If this child domain is also a parent then it already extracted -!*** its FIS in 'parent_block' of PARENT_CHILD_CPL_INITIALIZE but we -!*** now extract FIS again in case this child domain is not a parent. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract FIS Field from Parent-Child Coupler Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =IMP_STATE & !<-- The parent-child coupler import state - ,itemName='FIS' & !<-- Extract FIS Field - ,field =HOLD_FIELD & !<-- Put the extracted Field here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FIS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract FIS from ESMF Field in Parent-Child Coupler" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the data pointer - ,localDe =0 & - ,farrayPtr=FIS & !<-- Put the pointer here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_FIS) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - CALL MPI_COMM_RANK(COMM_TO_MY_PARENT,MYPE,IERR) !<-- Obtain rank of this child task -! -!----------------------------------------------------------------------- -! -!------------------------------ -!*** Child South Boundary FIS -!------------------------------ -! -! write(0,*)' CHILD_SENDS_TOPO_TO_PARENT mype=',mype,' NUM_PARENT_TASKS_SENDING_H%SOUTH=',NUM_PARENT_TASKS_SENDING_H%SOUTH - IF(NUM_PARENT_TASKS_SENDING_H%SOUTH>0)THEN !<-- Child tasks know which parent tasks compute their BCs - NTAG_SEND=MYPE+1000*MY_DOMAIN_ID !<-- A unique MPI tag for this Send -! - DO N=1,NUM_PARENT_TASKS_SENDING_H%SOUTH !<-- Child sends its FIS to parent tasks that will be -! computing its BCs. - I_LO=PARENT_TASK(N)%SOUTH_H%INDX_START !<-- Starting I of child covered by parent task N - I_HI=PARENT_TASK(N)%SOUTH_H%INDX_END_EXP !<-- Ending I of child for expanded area covered by parent task N - NUM_WORDS=(I_HI-I_LO+1)*(N_BLEND_H+1) !<-- # of child points covered by parent task N - ALLOCATE(FIS_SEND(1:NUM_WORDS)) !<-- Array to hold child FIS values to go to parent task N - ! with extra row of values for 4-pt interp to V pts - KOUNT=0 -! - DO N2=1,N_BLEND_H+1 !<-- Extra row for 4-pt interp of PD to V pts - DO N1=I_LO,I_HI - KOUNT=KOUNT+1 - FIS_SEND(KOUNT)=FIS(N1-I_OFFSET,N2-J_OFFSET) !<-- 1-D FIS of child points covered by parent task N - IF(ABS(FIS_SEND(KOUNT))<1.E-2)THEN - FIS_SEND(KOUNT)=0. - ENDIF - ENDDO - ENDDO -! - CALL MPI_SEND(FIS_SEND & !<-- Send FIS data to parent task N - ,NUM_WORDS & !<-- There are NUM_WORDS words in the data - ,MPI_REAL & !<-- Data is type Real - ,PARENT_TASK(N)%SOUTH_H%ID_SOURCE & !<-- Data sent to this parent task -! ,MYPE & !<-- Use child task ID as the tag - ,NTAG_SEND & !<-- MPI tag - ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator between this child and its parent - ,IERR) -! - DEALLOCATE(FIS_SEND) -! - ENDDO -! - ENDIF -! -!------------------------------ -!*** Child North Boundary FIS -!------------------------------ -! - IF(NUM_PARENT_TASKS_SENDING_H%NORTH>0)THEN !<-- Child tasks know which parent tasks compute their BCs - NTAG_SEND=MYPE+2000*MY_DOMAIN_ID !<-- A unique MPI tag for this Send -! - DO N=1,NUM_PARENT_TASKS_SENDING_H%NORTH !<-- Child sends its FIS to parent tasks that will be -! computing its BCs. - I_LO=PARENT_TASK(N)%NORTH_H%INDX_START !<-- Starting I of child covered by parent task N - I_HI=PARENT_TASK(N)%NORTH_H%INDX_END_EXP !<-- Ending I of child for expanded area covered by parent task N - NUM_WORDS=(I_HI-I_LO+1)*(N_BLEND_H+1) !<-- # of child points covered by parent task N - ALLOCATE(FIS_SEND(1:NUM_WORDS)) !<-- Array to hold child FIS values to go to parent task N - ! with extra row of values for 4-pt interp to V pts - KOUNT=0 -! - DO N2=JTE-N_BLEND_H ,JTE !<-- Extra row for 4-pt interp of PD to V pts - DO N1=I_LO,I_HI - KOUNT=KOUNT+1 - FIS_SEND(KOUNT)=FIS(N1-I_OFFSET,N2-J_OFFSET) !<-- 1-D FIS of child points covered by parent task N - IF(ABS(FIS_SEND(KOUNT))<1.E-2)THEN - FIS_SEND(KOUNT)=0. - ENDIF - ENDDO - ENDDO -! - CALL MPI_SEND(FIS_SEND & !<-- Send FIS data to parent task N - ,NUM_WORDS & !<-- There are NUM_WORDS words in the data - ,MPI_REAL & !<-- Data is type Real - ,PARENT_TASK(N)%NORTH_H%ID_SOURCE & !<-- Data sent to this parent task -! ,MYPE & !<-- Use child task ID as the tag - ,NTAG_SEND & !<-- MPI tag - ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator between this child and its parent - ,IERR) -! - DEALLOCATE(FIS_SEND) - ENDDO -! - ENDIF -! -!----------------------------------------------------------------------- -! -!----------------------------- -!*** Child West Boundary FIS -!----------------------------- -! - IF(NUM_PARENT_TASKS_SENDING_H%WEST>0)THEN !<-- Child tasks know which parent tasks compute their BCs - NTAG_SEND=MYPE+3000*MY_DOMAIN_ID !<-- A unique MPI tag for this Send -! - DO N=1,NUM_PARENT_TASKS_SENDING_H%WEST !<-- Child sends its FIS to parent tasks that will be -! computing its BCs. - J_LO=PARENT_TASK(N)%WEST_H%INDX_START !<-- Starting J of child covered by parent task N - J_HI=PARENT_TASK(N)%WEST_H%INDX_END_EXP !<-- Ending J of child for expanded area covered by parent task N - NUM_WORDS=(J_HI-J_LO+1)*(N_BLEND_H+1) !<-- # of child points covered by parent task N - ALLOCATE(FIS_SEND(1:NUM_WORDS)) !<-- Array to hold child FIS values to go to parent task N - ! with extra row of values for 4-pt interp to V pts - KOUNT=0 -! - DO N2=J_LO,J_HI - DO N1=1,N_BLEND_H+1 !<-- Extra row for 4-pt interp of PD to V pts - KOUNT=KOUNT+1 - FIS_SEND(KOUNT)=FIS(N1-I_OFFSET,N2-J_OFFSET) !<-- 1-D FIS of child points covered by parent task N - IF(ABS(FIS_SEND(KOUNT))<1.E-2)then - FIS_SEND(KOUNT)=0. - ENDIF - ENDDO - ENDDO -! - CALL MPI_SEND(FIS_SEND & !<-- Send FIS data to parent task N - ,NUM_WORDS & !<-- There are NUM_WORDS words in the data - ,MPI_REAL & !<-- Data is type Real - ,PARENT_TASK(N)%WEST_H%ID_SOURCE & !<-- Data sent to this parent task -! ,MYPE & !<-- Use child task ID as the tag - ,NTAG_SEND & !<-- MPI tag - ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator between this child and its parent - ,IERR) -! - DEALLOCATE(FIS_SEND) - ENDDO -! - ENDIF -! -!----------------------------- -!*** Child East Boundary FIS -!----------------------------- -! - IF(NUM_PARENT_TASKS_SENDING_H%EAST>0)THEN !<-- Child tasks know which parent tasks compute their BCs - NTAG_SEND=MYPE+4000*MY_DOMAIN_ID !<-- A unique MPI tag for this Send -! - DO N=1,NUM_PARENT_TASKS_SENDING_H%EAST !<-- Child sends its FIS to parent tasks that will be -! computing its BCs. - J_LO=PARENT_TASK(N)%EAST_H%INDX_START !<-- Starting J of child covered by parent task N - J_HI=PARENT_TASK(N)%EAST_H%INDX_END_EXP !<-- Ending J of child for expanded area covered by parent task N - NUM_WORDS=(J_HI-J_LO+1)*(N_BLEND_H+1) !<-- # of child points covered by parent task N - ALLOCATE(FIS_SEND(1:NUM_WORDS)) !<-- Array to hold child FIS values to go to parent task N - ! with extra row of values for 4-pt interp to V pts - KOUNT=0 -! - DO N2=J_LO,J_HI - DO N1=ITE-N_BLEND_H ,ITE !<-- Extra row for 4-pt interp of PD to V pts - KOUNT=KOUNT+1 - FIS_SEND(KOUNT)=FIS(N1-I_OFFSET,N2-J_OFFSET) !<-- 1-D FIS of child points covered by parent task N - IF(ABS(FIS_SEND(KOUNT))<1.E-2)THEN - FIS_SEND(KOUNT)=0. - ENDIF - ENDDO - ENDDO -! - CALL MPI_SEND(FIS_SEND & !<-- Send FIS data to parent task N - ,NUM_WORDS & !<-- There are NUM_WORDS words in the data - ,MPI_REAL & !<-- Data is type Real - ,PARENT_TASK(N)%EAST_H%ID_SOURCE & !<-- Data sent to this parent task -! ,MYPE & !<-- Use child task ID as the tag - ,NTAG_SEND & !<-- MPI tag - ,COMM_TO_MY_PARENT & !<-- MPI intracommunicator between this child and its parent - ,IERR) -! - DEALLOCATE(FIS_SEND) - ENDDO -! - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE CHILD_SENDS_TOPO_TO_PARENT -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE PARENT_RECVS_CHILD_TOPO(N_CHILD,MY_DOMAIN_ID) -! -!----------------------------------------------------------------------- -!*** Parents receive the boundary topography from their children -!*** so the parents can properly balance their own data that they -!*** interpolate to child gridpoints. -!----------------------------------------------------------------------- -! -!----------------------- -!*** Argument Variables -!----------------------- -! - INTEGER(kind=KINT),INTENT(IN) :: N_CHILD & !<-- The child who is sending - ,MY_DOMAIN_ID !<-- The parent's domain ID -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: CHILDTASK,ID,IERR,N,NDATA,NRANK & - ,NTAG_RECV,NTX,NUM_WORDS -! - INTEGER(kind=KINT) :: I_LO,I_HI,J_LO,J_HI -! - INTEGER(kind=KINT),DIMENSION(MPI_STATUS_SIZE) :: STATUS -! - TYPE(COMPOSITE),POINTER :: CC -! - integer(kind=kint) :: nnnn -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - N=N_CHILD - ID=MY_DOMAIN_ID -! - CC=>CPL_COMPOSITE(MY_DOMAIN_ID) -! -!----------------------------------------------------------------------- -!*** The parent tasks receive sfc geopotentials from the -!*** child boundary tasks. -!----------------------------------------------------------------------- -! -!------------------------------ -!*** Child South Boundary FIS -!------------------------------ -! - NUM_TASKS_SEND_H_S=>cc%NUM_TASKS_SEND_H_S - FIS_CHILD_SOUTH=>cc%FIS_CHILD_SOUTH -! - IF(NUM_TASKS_SEND_H_S(N)>0)THEN !<-- This parent task covers some child Sboundary H points -! - NDATA=NUM_TASKS_SEND_H_S(N) - ALLOCATE(FIS_CHILD_SOUTH(N)%TASKS(1:NDATA)) !<-- FIS data slot for each Sbndry child task on parent task -! write(0,*)' PARENT_RECVS_CHILD_TOPO allocated fis_child_south(',n,')%tasks(1:',ndata,')' - ALLOCATE(HANDLE_CHILD_TOPO_S(ID)%CHILDREN(N)%DATA(NDATA)) !<-- Request handles for IRecv -! - DO NTX=1,NUM_TASKS_SEND_H_S(N) !<-- Loop through those particular child tasks -! - I_LO=CHILDTASK_H_SAVE(N)%I_LO_SOUTH(NTX) !<-- Starting I of child point bndry segment on this parent task - I_HI=CHILDTASK_H_SAVE(N)%I_HI_SOUTH(NTX) !<-- Ending I of child point bndry segment on this parent task - NUM_WORDS=(I_HI-I_LO+1)*(N_BLEND_H_CHILD(N)+1) !<-- # of child points in its bndry segment on parent task - ! with extra row for 4-pt interpolation of PD to V pts - NRANK=CHILDTASK_BNDRY_H_RANKS(N)%SOUTH(NTX,1) !<-- Count of child task in list of fcst tasks - CHILDTASK=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NRANK-1) !<-- Rank of child task NTX in p-c intracommunicator - NTAG_RECV=CHILDTASK_BNDRY_H_RANKS(N)%SOUTH(NTX,2) & !<-- A unique MPI tag for this Recv - +1000*MY_CHILDREN_ID(N) -! - ALLOCATE(FIS_CHILD_SOUTH(N)%TASKS(NTX)%DATA(1:NUM_WORDS)) !<-- FIS on child S bndry covered by this parent task - ! with extra row for 4-pt interpolation of PD to V pts -! write(0,*)' PARENT_RECVS_CHILD_TOPO allocated fis_child_south(',n,')%tasks(',ntx,')%data(1:',num_words,')' -! write(0,*)' before IRecv S topo from child #',n,' child task #',ntx,' child task rank=',childtask,' ntag=',ntag_recv & -! ,' num_words=',num_words -! write(0,*)' i_lo=',i_lo,' i_hi=',i_hi,' n_blend_h_child(n)=',n_blend_h_child(n) -! - CALL MPI_IRECV(FIS_CHILD_SOUTH(N)%TASKS(NTX)%DATA & !<-- Recv FIS values from Sbndry child task NTX - ,NUM_WORDS & !<-- # of FIS values - ,MPI_REAL & !<-- Datatype - ,CHILDTASK & !<-- The child task sending - ,NTAG_RECV & !<-- MPI tag - ,COMM_TO_MY_CHILDREN(N) & !<-- MPI intracommunicator with child N - ,HANDLE_CHILD_TOPO_S(ID)%CHILDREN(N)%DATA(NTX) & !<-- MPI request handle for IRecvs - ,IERR) -! write(0,*)' after IRecv S topo from child #',n,' child task #',ntx,' child task rank=',childtask,' ntag=',ntag_recv -! - ENDDO -! - ELSE -! - ALLOCATE(FIS_CHILD_SOUTH(N)%TASKS(1:1)) - ALLOCATE(FIS_CHILD_SOUTH(N)%TASKS(1)%DATA(1:1)) -! - ENDIF -! -!----------------------------------------------------------------------- -! -!------------------------------ -!*** Child North Boundary FIS -!------------------------------ -! - NUM_TASKS_SEND_H_N=>cc%NUM_TASKS_SEND_H_N - FIS_CHILD_NORTH=>cc%FIS_CHILD_NORTH -! - IF(NUM_TASKS_SEND_H_N(N)>0)THEN !<-- This parent task covers some child Nboundary H points -! - NDATA=NUM_TASKS_SEND_H_N(N) - ALLOCATE(FIS_CHILD_NORTH(N)%TASKS(1:NDATA)) !<-- FIS data slot for each Nbndry child task on parent task - ALLOCATE(HANDLE_CHILD_TOPO_N(ID)%CHILDREN(N)%DATA(NDATA)) !<-- Request handles for IRecv -! - DO NTX=1,NUM_TASKS_SEND_H_N(N) !<-- Loop through those particular child tasks -! - I_LO=CHILDTASK_H_SAVE(N)%I_LO_NORTH(NTX) !<-- Starting I of child point bndry segment on this parent task - I_HI=CHILDTASK_H_SAVE(N)%I_HI_NORTH(NTX) !<-- Ending I of child point bndry segment on this parent task - NUM_WORDS=(I_HI-I_LO+1)*(N_BLEND_H_CHILD(N)+1) !<-- # of child points in its bndry segment on parent task - NRANK=CHILDTASK_BNDRY_H_RANKS(N)%NORTH(NTX,1) !<-- Count of child task in list of fcst tasks - CHILDTASK=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NRANK-1) !<-- Rank of child task NTX in p-c intracommunicator - NTAG_RECV=CHILDTASK_BNDRY_H_RANKS(N)%NORTH(NTX,2) & !<-- A unique MPI tag for this Recv - +2000*MY_CHILDREN_ID(N) -! - ALLOCATE(FIS_CHILD_NORTH(N)%TASKS(NTX)%DATA(1:NUM_WORDS)) !<-- FIS on child N bndry covered by this parent task - ! with extra row for 4-pt interpolation of PD to V pts -! - CALL MPI_IRECV(FIS_CHILD_NORTH(N)%TASKS(NTX)%DATA & !<-- Recv FIS values from Nbndry child task NTX - ,NUM_WORDS & !<-- # of FIS values - ,MPI_REAL & !<-- Datatype - ,CHILDTASK & !<-- The child task sending - ,NTAG_RECV & !<-- MPI tag - ,COMM_TO_MY_CHILDREN(N) & !<-- MPI intracommunicator with child N - ,HANDLE_CHILD_TOPO_N(ID)%CHILDREN(N)%DATA(NTX) & !<-- MPI request handles for IRecvs - ,IERR) -! - ENDDO -! - ELSE -! - ALLOCATE(FIS_CHILD_NORTH(N)%TASKS(1:1)) - ALLOCATE(FIS_CHILD_NORTH(N)%TASKS(1)%DATA(1:1)) -! - ENDIF -! -!----------------------------------------------------------------------- -! -!----------------------------- -!*** Child West Boundary FIS -!----------------------------- -! - NUM_TASKS_SEND_H_W=>cc%NUM_TASKS_SEND_H_W - FIS_CHILD_WEST=>cc%FIS_CHILD_WEST -! - IF(NUM_TASKS_SEND_H_W(N)>0)THEN !<-- This parent task covers some child Wboundary H points -! - NDATA=NUM_TASKS_SEND_H_W(N) - ALLOCATE(FIS_CHILD_WEST(N)%TASKS(1:NDATA)) !<-- FIS data slot for each Wbndry child task on parent task - ALLOCATE(HANDLE_CHILD_TOPO_W(ID)%CHILDREN(N)%DATA(NDATA)) !<-- Request handles for IRecv -! - DO NTX=1,NUM_TASKS_SEND_H_W(N) !<-- Loop through those particular child tasks -! - J_LO=CHILDTASK_H_SAVE(N)%J_LO_WEST(NTX) !<-- Starting J of child point bndry segment on this parent task - J_HI=CHILDTASK_H_SAVE(N)%J_HI_WEST(NTX) !<-- Ending J of child point bndry segment on this parent task - NUM_WORDS=(J_HI-J_LO+1)*(N_BLEND_H_CHILD(N)+1) !<-- # of child points in its bndry segment on parent task - NRANK=CHILDTASK_BNDRY_H_RANKS(N)%WEST(NTX,1) !<-- Count of child task in list of fcst tasks - CHILDTASK=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NRANK-1) !<-- Rank of child task NTX in p-c intracommunicator - NTAG_RECV=CHILDTASK_BNDRY_H_RANKS(N)%WEST(NTX,2) & !<-- A unique MPI tag for this Recv - +3000*MY_CHILDREN_ID(N) -! - ALLOCATE(FIS_CHILD_WEST(N)%TASKS(NTX)%DATA(1:NUM_WORDS)) !<-- FIS on child W bndry covered by this parent task - ! with extra row for 4-pt interpolation of PD to V pts - CALL MPI_IRECV(FIS_CHILD_WEST(N)%TASKS(NTX)%DATA & !<-- Recv FIS values from Wbndry child task NTX - ,NUM_WORDS & !<-- # of FIS values - ,MPI_REAL & !<-- Datatype - ,CHILDTASK & !<-- The child task sending - ,NTAG_RECV & !<-- MPI tag - ,COMM_TO_MY_CHILDREN(N) & !<-- MPI intracommunicator with child N - ,HANDLE_CHILD_TOPO_W(ID)%CHILDREN(N)%DATA(NTX) & !<-- MPI request handles for IRecvs - ,IERR) -! - ENDDO -! - ELSE -! - ALLOCATE(FIS_CHILD_WEST(N)%TASKS(1:1)) - ALLOCATE(FIS_CHILD_WEST(N)%TASKS(1)%DATA(1:1)) -! - ENDIF -! -!----------------------------------------------------------------------- -! -!----------------------------- -!*** Child East Boundary FIS -!----------------------------- -! - NUM_TASKS_SEND_H_E=>cc%NUM_TASKS_SEND_H_E - FIS_CHILD_EAST=>cc%FIS_CHILD_EAST -! - IF(NUM_TASKS_SEND_H_E(N)>0)THEN !<-- This parent task covers some child Eboundary H points -! - NDATA=NUM_TASKS_SEND_H_E(N) - ALLOCATE(FIS_CHILD_EAST(N)%TASKS(1:NDATA)) !<-- FIS data slot for each Ebndry child task on parent task - ALLOCATE(HANDLE_CHILD_TOPO_E(ID)%CHILDREN(N)%DATA(NDATA)) !<-- Request handles for IRecv -! - DO NTX=1,NUM_TASKS_SEND_H_E(N) !<-- Loop through those particular child tasks -! - J_LO=CHILDTASK_H_SAVE(N)%J_LO_EAST(NTX) !<-- Starting J of child point bndry segment on this parent task - J_HI=CHILDTASK_H_SAVE(N)%J_HI_EAST(NTX) !<-- Ending J of child point bndry segment on this parent task - NUM_WORDS=(J_HI-J_LO+1)*(N_BLEND_H_CHILD(N)+1) !<-- # of child points in its bndry segment on parent task - NRANK=CHILDTASK_BNDRY_H_RANKS(N)%EAST(NTX,1) !<-- Count of child task in list of fcst tasks - CHILDTASK=child_ranks(MY_DOMAIN_ID)%CHILDREN(N)%DATA(NRANK-1) !<-- Rank of child task NTX in p-c intracommunicator - NTAG_RECV=CHILDTASK_BNDRY_H_RANKS(N)%EAST(NTX,2) & !<-- A unique MPI tag for this Recv - +4000*MY_CHILDREN_ID(N) -! - ALLOCATE(FIS_CHILD_EAST(N)%TASKS(NTX)%DATA(1:NUM_WORDS)) !<-- FIS on child E bndry covered by this parent task - ! with extra row for 4-pt interpolation of PD to V pts -! write(0,*)' PARENT_RECVS_CHILD_TOPO allocated FIS_CHILD_EAST(',n,')%tasks(',ntx,')%data(1:',num_words,')' -! write(0,*)' j_lo=',j_lo,' j_hi=',j_hi,' n_blend_h_child(',n,')=',n_blend_h_child(n) -! -! write(0,*)' before IRecv E topo from child #',n,' child task #',ntx,' child task rank=',childtask,' ntag=',ntag_recv - CALL MPI_IRECV(FIS_CHILD_EAST(N)%TASKS(NTX)%DATA & !<-- Recv FIS values from Ebndry child task NTX - ,NUM_WORDS & !<-- # of FIS values - ,MPI_REAL & !<-- Datatype - ,CHILDTASK & !<-- The child task sending - ,NTAG_RECV & !<-- MPI tag - ,COMM_TO_MY_CHILDREN(N) & !<-- MPI intracommunicator with child N - ,HANDLE_CHILD_TOPO_E(ID)%CHILDREN(N)%DATA(NTX) & !<-- MPI request handle for the IRecv - ,IERR) -! - ENDDO -! - ELSE -! - ALLOCATE(FIS_CHILD_EAST(N)%TASKS(1:1)) - ALLOCATE(FIS_CHILD_EAST(N)%TASKS(1)%DATA(1:1)) -! - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PARENT_RECVS_CHILD_TOPO -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE PARENT_COMPUTES_CHILD_TOPO(N_CHILD & - ,I_PARENT_SW & - ,J_PARENT_SW & - ,IM_CHILD & - ,JM_CHILD & - ,N_BLEND_H_CHILD & - ,LBND1,UBND1,LBND2,UBND2 & - ,MOVING_NEST_TOPO & - ) -! -!----------------------------------------------------------------------- -!*** Parents fill the working arrays of their moving children's -!*** boundary topography. The parents carry full arrays of topography -!*** at each of their moving children's resolutions so the data only -!*** needs to be lifted from those arrays. This avoids Sends and -!*** Recvs of that data which could force the parents to Wait. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: N_CHILD & !<-- Which child are we considering? - ,I_PARENT_SW & !<-- Parent I index of child's SW corner - ,J_PARENT_SW & !<-- Parent J index of child's SW corner - ,IM_CHILD & !<-- I dimension of child domain - ,JM_CHILD & !<-- J dimension of child domain - ,N_BLEND_H_CHILD & !<-- Width of child's boundary blending region -! - ,LBND1,UBND1 & !<-- I limits of nest-res FIS on this parent task - ,LBND2,UBND2 !<-- J limits of nest-res FIS on this parent task -! - REAL(kind=KFPT),DIMENSION(LBND1:UBND1,LBND2:UBND2),INTENT(IN) :: & - MOVING_NEST_TOPO !<-- Nest-resolution topography on the parent task -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: I,I_HI,I_LO,I_OFFSET,ISTART & - ,J,J_HI,J_LO,J_OFFSET,JSTART & - ,KOUNT,N,NTX,NUM_WORDS -! - REAL(kind=KFPT),DIMENSION(:),POINTER :: FIS_X -! - integer(kind=kint) :: nnnn -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - N=N_CHILD -! - ISTART=MAX(IMS,IDS) !<-- The SW corner of this parent domain - JSTART=MAX(JMS,JDS) !<-- -! -!------------------------------ -!*** Child South Boundary FIS -!------------------------------ -! - IF(NUM_TASKS_SEND_H_S(N)>0)THEN !<-- This parent task covers some child Sboundary H points -! - ALLOCATE(FIS_CHILD_SOUTH(N)%TASKS(1:NUM_TASKS_SEND_H_S(N))) !<-- FIS data slot for each Sbndry child task on parent task -! - DO NTX=1,NUM_TASKS_SEND_H_S(N) !<-- Loop through those particular child tasks -! - I_LO=CHILDTASK_H_SAVE(N)%I_LO_SOUTH(NTX) !<-- Starting I of child point bndry segment on this parent task - I_HI=CHILDTASK_H_SAVE(N)%I_HI_SOUTH(NTX) !<-- Ending I of child point bndry segment on this parent task - NUM_WORDS=(I_HI-I_LO+1)*(N_BLEND_H_CHILD+1) !<-- # of child points in its bndry segment on parent task -! - ALLOCATE(FIS_CHILD_SOUTH(N)%TASKS(NTX)%DATA(1:NUM_WORDS)) !<-- FIS on child S bndry covered by this parent task - ! with extra row for 4-pt interpolation of PD to V pts - FIS_X=>FIS_CHILD_SOUTH(N)%TASKS(NTX)%DATA -! - I_OFFSET=(I_PARENT_SW-ISTART)*PARENT_CHILD_SPACE_RATIO(N) & !<-- I offset of child SW corner in full topo array on parent - +LBND1-1 - J_OFFSET=(J_PARENT_SW-JSTART)*PARENT_CHILD_SPACE_RATIO(N) & !<-- J offset of child SW corner in full topo array on parent - +LBND2-1 - KOUNT=0 -! - DO J=1,N_BLEND_H_CHILD+1 - DO I=I_LO,I_HI - KOUNT=KOUNT+1 - FIS_X(KOUNT)=MOVING_NEST_TOPO(I+I_OFFSET,J+J_OFFSET) !<-- Lift child topography from full parent array - ENDDO - ENDDO -! - ENDDO -! - ELSE -! - ALLOCATE(FIS_CHILD_SOUTH(N)%TASKS(1:1)) - ALLOCATE(FIS_CHILD_SOUTH(N)%TASKS(1)%DATA(1:1)) -! - ENDIF -! -!----------------------------------------------------------------------- -! -!------------------------------ -!*** Child North Boundary FIS -!------------------------------ -! - IF(NUM_TASKS_SEND_H_N(N)>0)THEN !<-- This parent task covers some child Nboundary H points -! - ALLOCATE(FIS_CHILD_NORTH(N)%TASKS(1:NUM_TASKS_SEND_H_N(N))) !<-- FIS data slot for each Nbndry child task on parent task -! - DO NTX=1,NUM_TASKS_SEND_H_N(N) !<-- Loop through those particular child tasks -! - I_LO=CHILDTASK_H_SAVE(N)%I_LO_NORTH(NTX) !<-- Starting I of child point bndry segment on this parent task - I_HI=CHILDTASK_H_SAVE(N)%I_HI_NORTH(NTX) !<-- Ending I of child point bndry segment on this parent task - NUM_WORDS=(I_HI-I_LO+1)*(N_BLEND_H_CHILD+1) !<-- # of child points in its bndry segment on parent task -! - ALLOCATE(FIS_CHILD_NORTH(N)%TASKS(NTX)%DATA(1:NUM_WORDS)) !<-- FIS on child N bndry covered by this parent task - ! with extra row for 4-pt interpolation of PD to V pts - FIS_X=>FIS_CHILD_NORTH(N)%TASKS(NTX)%DATA -! - I_OFFSET=(I_PARENT_SW-ISTART)*PARENT_CHILD_SPACE_RATIO(N) & !<-- I offset of child SW corner in full topo array on parent - +LBND1-1 - J_OFFSET=(J_PARENT_SW-JSTART)*PARENT_CHILD_SPACE_RATIO(N) & !<-- J offset of child SW corner in full topo array on parent - +LBND2-1 - KOUNT=0 -! - DO J=JM_CHILD-N_BLEND_H_CHILD ,JM_CHILD - DO I=I_LO,I_HI - KOUNT=KOUNT+1 - FIS_X(KOUNT)=MOVING_NEST_TOPO(I+I_OFFSET,J+J_OFFSET) !<-- Lift child topography from full parent array - ENDDO - ENDDO -! - ENDDO -! - ELSE -! - ALLOCATE(FIS_CHILD_NORTH(N)%TASKS(1:1)) - ALLOCATE(FIS_CHILD_NORTH(N)%TASKS(1)%DATA(1:1)) -! - ENDIF -! -!----------------------------------------------------------------------- -! -!----------------------------- -!*** Child West Boundary FIS -!----------------------------- -! - IF(NUM_TASKS_SEND_H_W(N)>0)THEN !<-- This parent task covers some child Wboundary H points -! - ALLOCATE(FIS_CHILD_WEST(N)%TASKS(1:NUM_TASKS_SEND_H_W(N))) !<-- FIS data slot for each Wbndry child task on parent task -! - DO NTX=1,NUM_TASKS_SEND_H_W(N) !<-- Loop through those particular child tasks -! - J_LO=CHILDTASK_H_SAVE(N)%J_LO_WEST(NTX) !<-- Starting J of child point bndry segment on this parent task - J_HI=CHILDTASK_H_SAVE(N)%J_HI_WEST(NTX) !<-- Ending J of child point bndry segment on this parent task - NUM_WORDS=(J_HI-J_LO+1)*(N_BLEND_H_CHILD+1) !<-- # of child points in its bndry segment on parent task -! - ALLOCATE(FIS_CHILD_WEST(N)%TASKS(NTX)%DATA(1:NUM_WORDS)) !<-- FIS on child W bndry covered by this parent task - ! with extra row for 4-pt interpolation of PD to V pts - FIS_X=>FIS_CHILD_WEST(N)%TASKS(NTX)%DATA -! - I_OFFSET=(I_PARENT_SW-ISTART)*PARENT_CHILD_SPACE_RATIO(N) & !<-- I offset of child SW corner in full topo array on parent - +LBND1-1 - J_OFFSET=(J_PARENT_SW-JSTART)*PARENT_CHILD_SPACE_RATIO(N) & !<-- J offset of child SW corner in full topo array on parent - +LBND2-1 - KOUNT=0 -! - DO J=J_LO,J_HI - DO I=1,N_BLEND_H_CHILD+1 - KOUNT=KOUNT+1 - FIS_X(KOUNT)=MOVING_NEST_TOPO(I+I_OFFSET,J+J_OFFSET) !<-- Lift child topography from full parent array - ENDDO - ENDDO -! - ENDDO -! - ELSE -! - ALLOCATE(FIS_CHILD_WEST(N)%TASKS(1:1)) - ALLOCATE(FIS_CHILD_WEST(N)%TASKS(1)%DATA(1:1)) -! - ENDIF -! -!----------------------------------------------------------------------- -! -!----------------------------- -!*** Child East Boundary FIS -!----------------------------- -! - IF(NUM_TASKS_SEND_H_E(N)>0)THEN !<-- This parent task covers some child Eboundary H points -! - ALLOCATE(FIS_CHILD_EAST(N)%TASKS(1:NUM_TASKS_SEND_H_E(N))) !<-- FIS data slot for each Ebndry child task on parent task -! - DO NTX=1,NUM_TASKS_SEND_H_E(N) !<-- Loop through those particular child tasks -! - J_LO=CHILDTASK_H_SAVE(N)%J_LO_EAST(NTX) !<-- Starting J of child point bndry segment on this parent task - J_HI=CHILDTASK_H_SAVE(N)%J_HI_EAST(NTX) !<-- Ending J of child point bndry segment on this parent task - NUM_WORDS=(J_HI-J_LO+1)*(N_BLEND_H_CHILD+1) !<-- # of child points in its bndry segment on parent task -! - ALLOCATE(FIS_CHILD_EAST(N)%TASKS(NTX)%DATA(1:NUM_WORDS)) !<-- FIS on child E bndry covered by this parent task - ! with extra row for 4-pt interpolation of PD to V pts - FIS_X=>FIS_CHILD_EAST(N)%TASKS(NTX)%DATA -! - I_OFFSET=(I_PARENT_SW-ISTART)*PARENT_CHILD_SPACE_RATIO(N) & !<-- I offset of child SW corner in full topo array on parent - +LBND1-1 - J_OFFSET=(J_PARENT_SW-JSTART)*PARENT_CHILD_SPACE_RATIO(N) & !<-- J offset of child SW corner in full topo array on parent - +LBND2-1 - KOUNT=0 -! - DO J=J_LO,J_HI -!!! DO I=IM_CHILD-N_BLEND_H_CHILD+1,IM_CHILD - DO I=IM_CHILD-N_BLEND_H_CHILD ,IM_CHILD - KOUNT=KOUNT+1 - FIS_X(KOUNT)=MOVING_NEST_TOPO(I+I_OFFSET,J+J_OFFSET) !<-- Lift child topography from full parent array - ENDDO - ENDDO -! - ENDDO -! - ELSE -! - ALLOCATE(FIS_CHILD_EAST(N)%TASKS(1:1)) - ALLOCATE(FIS_CHILD_EAST(N)%TASKS(1)%DATA(1:1)) -! - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PARENT_COMPUTES_CHILD_TOPO -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE PARENT_UPDATE_CHILD_PSFC(FIS,PD,T,Q & - ,PT,PDTOP,SG1,SG2 & - ,IMS,IME,JMS,JME & - ,NLEV & -! - ,NUM_CHILD_TASKS & - ,LIMITS & -! - ,FIS_CHILD_SBND & - ,FIS_CHILD_NBND & - ,FIS_CHILD_WBND & - ,FIS_CHILD_EBND & -! - ,NUM_TASKS_SEND_SBND & - ,NUM_TASKS_SEND_NBND & - ,NUM_TASKS_SEND_WBND & - ,NUM_TASKS_SEND_EBND & -! - ,I_INDX_PARENT_SBND & - ,I_INDX_PARENT_NBND & - ,I_INDX_PARENT_WBND & - ,I_INDX_PARENT_EBND & - ,J_INDX_PARENT_SBND & - ,J_INDX_PARENT_NBND & - ,J_INDX_PARENT_WBND & - ,J_INDX_PARENT_EBND & -! - ,I_LO_SOUTH & - ,I_HI_SOUTH & - ,I_HI_SOUTH_TRANSFER & - ,I_LO_NORTH & - ,I_HI_NORTH & - ,I_HI_NORTH_TRANSFER & - ,J_LO_WEST & - ,J_HI_WEST & - ,J_HI_WEST_TRANSFER & - ,J_LO_EAST & - ,J_HI_EAST & - ,J_HI_EAST_TRANSFER & -! - ,WEIGHT_SBND & - ,WEIGHT_NBND & - ,WEIGHT_WBND & - ,WEIGHT_EBND & -! ^ - ,N_BLEND & ! | - ,IM_CHILD_X & ! | - ,JM_CHILD_X & ! Input -! ----------- - ,CHILD_H_SBND & ! Output - ,CHILD_H_NBND & ! | - ,CHILD_H_WBND & ! | - ,CHILD_H_EBND & ! v -! - ,PDB_SBND & ! - ,PDB_NBND & ! - ,PDB_WBND & ! - ,PDB_EBND ) ! -! -!----------------------------------------------------------------------- -!*** Given a child's actual surface geopotential, generate a new -!*** value of PD for the child boundary points based on the -!*** surrounding parent points. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: IMS,IME,JMS,JME & !<-- Parent task's memory limits - ,IM_CHILD_X,JM_CHILD_X & !<-- Index limits of the nest domain - ,N_BLEND & !<-- # of domain boundary blending rows - ,NLEV & !<-- # of vertical levels in parent array - ,NUM_CHILD_TASKS & !<-- # of fcst tasks on this child - ,NUM_TASKS_SEND_SBND & !<-- # of child tasks with Sboundary regions on parent task - ,NUM_TASKS_SEND_NBND & !<-- # of child tasks with Nboundary regions on parent task - ,NUM_TASKS_SEND_WBND & !<-- # of child tasks with Wboundary regions on parent task - ,NUM_TASKS_SEND_EBND !<-- # of child tasks with Eboundary regions on parent task -! - INTEGER(kind=KINT),DIMENSION(1:4,1:NUM_CHILD_TASKS),INTENT(IN) :: & - LIMITS !<-- ITS,ITE,JTS,JTE on each task of the child -! - INTEGER(kind=KINT),DIMENSION(:),POINTER,INTENT(IN) :: & - I_LO_SOUTH & !<-- Starting I of Sbndry region on child tasks - ,I_HI_SOUTH & !<-- Ending I of Sbndry region on child tasks - ,I_HI_SOUTH_TRANSFER & !<-- Ending I of Sbndry region for transfer to child - ,I_LO_NORTH & !<-- Starting I of Nbndry region on child tasks - ,I_HI_NORTH & !<-- Ending I of Nbndry region on child tasks - ,I_HI_NORTH_TRANSFER & !<-- Ending I of Nbndry region for transfer to child - ,J_LO_WEST & !<-- Starting J of Wbndry region on child tasks - ,J_HI_WEST & !<-- Ending J of Wbndry region on child tasks - ,J_HI_WEST_TRANSFER & !<-- Ending J of Wbndry region for transfer to child - ,J_LO_EAST & !<-- Starting J of Ebndry region on child tasks - ,J_HI_EAST & !<-- Ending J of Ebndry region on child tasks - ,J_HI_EAST_TRANSFER !<-- Ending J of Ebndry region for transfer to child -! - INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER,INTENT(IN) :: & - I_INDX_PARENT_SBND & !<-- I indices of parent points west/east of child Sbndry point - ,I_INDX_PARENT_NBND & !<-- I indices of parent points west/east of child Nbndry point - ,I_INDX_PARENT_WBND & !<-- I indices of parent points west/east of child Wbndry point - ,I_INDX_PARENT_EBND & !<-- I indices of parent points west/east of child Ebndry point - ,J_INDX_PARENT_SBND & !<-- J indices of parent points south/north of child Sbndry point - ,J_INDX_PARENT_NBND & !<-- J indices of parent points south/north of child Nbndry point - ,J_INDX_PARENT_WBND & !<-- J indices of parent points south/north of child Wbndry point - ,J_INDX_PARENT_EBND !<-- J indices of parent points south/north of child Ebndry point -! - REAL(kind=KFPT),INTENT(IN) :: PT & !<-- Top pressure of model domain (Pa) - ,PDTOP !<-- Pressure at top of sigma domain (Pa) -! - REAL(kind=KFPT),DIMENSION(:),POINTER,INTENT(IN) :: SG1 & !<-- Interface sigmas, pressure domain - ,SG2 !<-- Interface sigmas, sigma domain -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: FIS & !<-- Parent FIS - ,PD !<-- Parent PD -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME,1:NLEV),INTENT(IN) :: T & !<-- Parent sensible temperature (K) - ,Q !<-- Parent specific humidity (kg/kg) -! - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER,INTENT(IN) :: & - WEIGHT_SBND & !<-- Bilinear interp weights of the 4 parent points around - ,WEIGHT_NBND & ! each point on child's boundary sides (S,N,W,E). - ,WEIGHT_WBND & ! - ,WEIGHT_EBND !<-- -! - TYPE(REAL_DATA),DIMENSION(:),POINTER,INTENT(IN) :: FIS_CHILD_SBND & !<-- Sfc geopot on Sbndry points of each child task - ,FIS_CHILD_NBND & !<-- Sfc geopot on Nbndry points of each child task - ,FIS_CHILD_WBND & !<-- Sfc geopot on Wbndry points of each child task - ,FIS_CHILD_EBND !<-- Sfc geopot on Ebndry points of each child task -! - TYPE(REAL_DATA),DIMENSION(:),POINTER,INTENT(INOUT) :: CHILD_H_SBND & !<-- All H point data for child Sbndry to be sent by parent - ,CHILD_H_NBND & !<-- All H point data for child Nbndry to be sent by parent - ,CHILD_H_WBND & !<-- All H point data for child Wbndry to be sent by parent - ,CHILD_H_EBND & !<-- All H point data for child Ebndry to be sent by parent -! - ,PDB_SBND & !<-- Child boundary PD (Pa) on child domain Sbndry - ,PDB_NBND & !<-- Child boundary PD (Pa) on child domain Nbndry - ,PDB_WBND & !<-- Child boundary PD (Pa) on child domain Wbndry - ,PDB_EBND !<-- Child boundary PD (Pa) on child domain Ebndry -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: I,J,L & - ,I_EAST,I_WEST,J_SOUTH,J_NORTH & - ,I_START,I_END,J_START,J_END & - ,I_START_TRANSFER,I_END_TRANSFER & - ,J_START_TRANSFER,J_END_TRANSFER & - ,KOUNT_PTS & - ,KOUNT_TRANSFER & - ,N_SIDE,NUM_TASKS_SEND,NTX & - ,RC -! - INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: I_INDX_PARENT_BND & - ,J_INDX_PARENT_BND -! - REAL(kind=KFPT) :: COEFF_1,COEFF_2,D_LNP_DFI,FIS_CHILD & - ,LOG_P1_PARENT,PDTOP_PT,PHI_DIFF,PSFC_CHILD & - ,Q_INTERP,T_INTERP -! - REAL(kind=KFPT) :: PX_NE,PX_NW,PX_SE,PX_SW & - ,WGHT_NE,WGHT_NW,WGHT_SE,WGHT_SW -! - REAL(kind=KFPT),DIMENSION(:,:),ALLOCATABLE :: LOG_PBOT & - ,LOG_PTOP -! - REAL(kind=KFPT),DIMENSION(:,:,:),ALLOCATABLE :: PHI_INTERP & - ,PINT_INTERP -! - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: WEIGHT_BND -! - TYPE(REAL_DATA),DIMENSION(:),POINTER :: CHILD_BOUND_H & - ,FIS_CHILD_BND & - ,PDB -! - integer,dimension(8) :: values -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Loop through the four sides of the nest domain boundary (S,N,W,E). -!*** We use some dummy variables/pointers generically for all four -!*** of the sides. -!----------------------------------------------------------------------- -! - loop_sides: DO N_SIDE=1,4 !<-- Loop through the 4 lateral boundaries (S,N,W,E) -! -!----------------------------------------------------------------------- -! - IF(N_SIDE==1)THEN - IF(NUM_TASKS_SEND_SBND==0)CYCLE !<-- Move on if parent task sees no part of nest's Sbndry -! - NUM_TASKS_SEND=NUM_TASKS_SEND_SBND - I_INDX_PARENT_BND=>I_INDX_PARENT_SBND - J_INDX_PARENT_BND=>J_INDX_PARENT_SBND - WEIGHT_BND=>WEIGHT_SBND - FIS_CHILD_BND=>FIS_CHILD_SBND - PDB=>PDB_SBND - CHILD_BOUND_H=>CHILD_H_SBND -! - ELSEIF(N_SIDE==2)THEN - IF(NUM_TASKS_SEND_NBND==0)CYCLE !<-- Move on if parent task sees no part of nest's Nbndry -! - NUM_TASKS_SEND=NUM_TASKS_SEND_NBND - I_INDX_PARENT_BND=>I_INDX_PARENT_NBND - J_INDX_PARENT_BND=>J_INDX_PARENT_NBND - WEIGHT_BND=>WEIGHT_NBND - FIS_CHILD_BND=>FIS_CHILD_NBND - PDB=>PDB_NBND - CHILD_BOUND_H=>CHILD_H_NBND -! - ELSEIF(N_SIDE==3)THEN - IF(NUM_TASKS_SEND_WBND==0)CYCLE !<-- Move on if parent task sees no part of nest's Wbndry -! - NUM_TASKS_SEND=NUM_TASKS_SEND_WBND - I_INDX_PARENT_BND=>I_INDX_PARENT_WBND - J_INDX_PARENT_BND=>J_INDX_PARENT_WBND - WEIGHT_BND=>WEIGHT_WBND - FIS_CHILD_BND=>FIS_CHILD_WBND - PDB=>PDB_WBND - CHILD_BOUND_H=>CHILD_H_WBND -! - ELSEIF(N_SIDE==4)THEN - IF(NUM_TASKS_SEND_EBND==0)CYCLE !<-- Move on if parent task sees no part of nest's Ebndry -! - NUM_TASKS_SEND=NUM_TASKS_SEND_EBND - I_INDX_PARENT_BND=>I_INDX_PARENT_EBND - J_INDX_PARENT_BND=>J_INDX_PARENT_EBND - WEIGHT_BND=>WEIGHT_EBND - FIS_CHILD_BND=>FIS_CHILD_EBND - PDB=>PDB_EBND - CHILD_BOUND_H=>CHILD_H_EBND -! - ENDIF -! -!----------------------------------------------------------------------- -!....................................................................... -!$omp parallel do private( & -!$omp coeff_1,coeff_2,d_lnp_dfi,fis_child, & -!$omp i,i_east,i_end,i_end_transfer, & -!$omp i_start,i_start_transfer,i_west, & -!$omp j,j_end,j_end_transfer,j_north,j_south, & -!$omp j_start,j_start_transfer, & -!$omp kount_pts,kount_transfer, & -!$omp l,log_p1_parent,log_pbot,log_ptop, & -!$omp ntx,pdtop_pt,phi_diff,phi_interp,pint_interp,psfc_child, & -!$omp px_ne,px_nw,px_se,px_sw, & -!$omp q_interp,t_interp,wght_ne,wght_nw,wght_se,wght_sw) -!....................................................................... -! - child_task_loop: DO NTX=1,NUM_TASKS_SEND !<-- Fill bndry data for each child task on the child bndry - ! segment seen by this parent task. -!----------------------------------------------------------------------- -! -!---------------------------------------------- -!*** South boundary limits on this child task -!---------------------------------------------- -! - IF(N_SIDE==1)THEN - I_START=I_LO_SOUTH(NTX) - I_END =I_HI_SOUTH(NTX) - J_START=1 -! J_END =N_BLEND - J_END =N_BLEND+1 !<-- Extend by one row to allow 4-pt averaging of PD to V pts -! - I_START_TRANSFER=I_START - I_END_TRANSFER =I_HI_SOUTH_TRANSFER(NTX) !<-- Extra PD points for 4-pt average are not transferred -! - J_START_TRANSFER=J_START - J_END_TRANSFER =J_END-1 !<-- The extra row of PD is not transferred to the nests -! -!---------------------------------------------- -!*** North boundary limits on this child task -!---------------------------------------------- -! - ELSEIF(N_SIDE==2)THEN - I_START=I_LO_NORTH(NTX) - I_END =I_HI_NORTH(NTX) -! J_START=JM_CHILD_X-N_BLEND+1 - J_START=JM_CHILD_X-N_BLEND !<-- Extend by one row to allow 4-pt averaging of PD to V pts - J_END =JM_CHILD_X -! - I_START_TRANSFER=I_START - I_END_TRANSFER =I_HI_NORTH_TRANSFER(NTX) !<-- Extra PD points for 4-pt average are not transferred -! - J_START_TRANSFER=J_START+1 !<-- The extra row of PD is not transferred to the nests - J_END_TRANSFER =J_END -! -!--------------------------------------------- -!*** West boundary limits on this child task -!--------------------------------------------- -! - ELSEIF(N_SIDE==3)THEN - I_START=1 -! I_END =N_BLEND - I_END =N_BLEND+1 !<-- Extend by one row to allow 4-pt averaging of PD to V pts - J_START=J_LO_WEST(NTX) - J_END =J_HI_WEST(NTX) -! - I_START_TRANSFER=I_START - I_END_TRANSFER =I_END-1 !<-- The extra row of PD is not transferred to the nests -! - J_START_TRANSFER=J_START - J_END_TRANSFER =J_HI_WEST_TRANSFER(NTX) !<-- Extra PD points for 4-pt average are not transferred -! -!--------------------------------------------- -!*** East boundary limits on this child task -!--------------------------------------------- -! - ELSEIF(N_SIDE==4)THEN -! I_START=IM_CHILD_X-N_BLEND+1 - I_START=IM_CHILD_X-N_BLEND !<-- Extend by one row to allow 4-pt averaging of PD to V pts - I_END =IM_CHILD_X - J_START=J_LO_EAST(NTX) - J_END =J_HI_EAST(NTX) -! - I_START_TRANSFER=I_START+1 !<-- The extra row of PD is not transferred to the nests - I_END_TRANSFER =I_END -! - J_START_TRANSFER=J_START - J_END_TRANSFER =J_HI_EAST_TRANSFER(NTX) !<-- Extra PD points for 4-pt average are not transferred -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Allocate the nest working arrays valid for the current child task -!*** on the child's grid. -!----------------------------------------------------------------------- -! - ALLOCATE(PINT_INTERP(I_START:I_END,J_START:J_END,1:LM+1)) - ALLOCATE( PHI_INTERP(I_START:I_END,J_START:J_END,1:LM+1)) - ALLOCATE( LOG_PTOP(I_START:I_END,J_START:J_END)) - ALLOCATE( LOG_PBOT(I_START:I_END,J_START:J_END)) -! -!----------------------------------------------------------------------- -!*** Compute parent heights of layer interfaces at the four points -!*** surrounding each child boundary point. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** First the bottom layer (L=NLEV). -!----------------------------------------------------------------------- -! - DO J=J_START,J_END !<-- J limits of child task bndry region on parent task - DO I=I_START,I_END !<-- I limits of child task bndry region on parent task -! - I_WEST =I_INDX_PARENT_BND(I,J,1) !<-- Parent I index on or west of child's boundary point - I_EAST =I_INDX_PARENT_BND(I,J,2) !<-- Parent I index east of child's boundary point - J_SOUTH=J_INDX_PARENT_BND(I,J,1) !<-- Parent J index on or south of child's boundary point - J_NORTH=J_INDX_PARENT_BND(I,J,2) !<-- Parent J index north of child's boundary point -! - WGHT_SW=WEIGHT_BND(I,J,INDX_SW) !<-- Bilinear weight for parent's point SW of nest's point - WGHT_SE=WEIGHT_BND(I,J,INDX_SE) !<-- Bilinear weight for parent's point SE of nest's point - WGHT_NW=WEIGHT_BND(I,J,INDX_NW) !<-- Bilinear weight for parent's point NW of nest's point - WGHT_NE=WEIGHT_BND(I,J,INDX_NE) !<-- Bilinear weight for parent's point NE of nest's point -! - PX_SW=PD(I_WEST,J_SOUTH)+PT !<-- Sfc pressure on parent point SW of nest point - PX_SE=PD(I_EAST,J_SOUTH)+PT !<-- Sfc pressure on parent point SE of nest point - PX_NW=PD(I_WEST,J_NORTH)+PT !<-- Sfc pressure on parent point NW of nest point - PX_NE=PD(I_EAST,J_NORTH)+PT !<-- Sfc pressure on parent point NE of nest point -! - PINT_INTERP(I,J,LM+1)=WGHT_SW*PX_SW & !<-- Parent's surface pressure interp'd to this child's - +WGHT_SE*PX_SE & ! gridpoint (I,J) along child's boundary - +WGHT_NW*PX_NW & ! on child task NTX. - +WGHT_NE*PX_NE -! - LOG_PBOT(I,J)=LOG(PINT_INTERP(I,J,LM+1)) !<-- Log of parent's horizontally interpolated sfc pressure - ! at child boundary point (I,J) -! - PHI_INTERP(I,J,LM+1)=WGHT_SW*FIS(I_WEST,J_SOUTH) & !<-- Parent sfc geoptential interp'd to nest bndry point (I,J) - +WGHT_SE*FIS(I_EAST,J_SOUTH) & - +WGHT_NW*FIS(I_WEST,J_NORTH) & - +WGHT_NE*FIS(I_EAST,J_NORTH) -! - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** Now that we have the parent's sfc pressure and sfc geopotential -!*** at the child boundary points (I,J), compute the interface heights -!*** based on the horizontally interpolated interface pressure and -!*** the T and Q. -!----------------------------------------------------------------------- -! - DO L=NLEV,1,-1 !<-- Work upward to obtain interface geopotentials -! - PDTOP_PT=PDTOP*SG1(L)+PT -! - DO J=J_START,J_END !<-- J limits of child task bndry region on parent task - DO I=I_START,I_END !<-- I limits of child task bndry region on parent task -! - I_WEST =I_INDX_PARENT_BND(I,J,1) !<-- Parent I index on or west of child's boundary point - I_EAST =I_INDX_PARENT_BND(I,J,2) !<-- Parent I index east of child's boundary point - J_SOUTH=J_INDX_PARENT_BND(I,J,1) !<-- Parent J index on or south of child's boundary point - J_NORTH=J_INDX_PARENT_BND(I,J,2) !<-- Parent J index north of child's boundary point -! - PX_SW=SG2(L)*PD(I_WEST,J_SOUTH)+PDTOP_PT !<-- Pressure, top of layer L, parent point SW of nest point - PX_SE=SG2(L)*PD(I_EAST,J_SOUTH)+PDTOP_PT !<-- Pressure, top of layer L, parent point SE of nest point - PX_NW=SG2(L)*PD(I_WEST,J_NORTH)+PDTOP_PT !<-- Pressure, top of layer L, parent point NW of nest point - PX_NE=SG2(L)*PD(I_EAST,J_NORTH)+PDTOP_PT !<-- Pressure, top of layer L, parent point NE of nest point -! - WGHT_SW=WEIGHT_BND(I,J,INDX_SW) !<-- Bilinear weight for parent's point SW of child's point - WGHT_SE=WEIGHT_BND(I,J,INDX_SE) !<-- Bilinear weight for parent's point SE of child's point - WGHT_NW=WEIGHT_BND(I,J,INDX_NW) !<-- Bilinear weight for parent's point NW of child's point - WGHT_NE=WEIGHT_BND(I,J,INDX_NE) !<-- Bilinear weight for parent's point NE of child's point -! - PINT_INTERP(I,J,L)=WGHT_SW*PX_SW & !<-- Top interface pressure interp'd to child gridpoint - +WGHT_SE*PX_SE & ! along child's boundary for child task NTX - +WGHT_NW*PX_NW & - +WGHT_NE*PX_NE -! - T_INTERP=WGHT_SW*T(I_WEST,J_SOUTH,L) & !<-- T interp'd to child gridpoint along child's - +WGHT_SE*T(I_EAST,J_SOUTH,L) & ! boundary for child task NTX - +WGHT_NW*T(I_WEST,J_NORTH,L) & - +WGHT_NE*T(I_EAST,J_NORTH,L) -! - Q_INTERP=WGHT_SW*Q(I_WEST,J_SOUTH,L) & !<-- Q interp'd to child gridpoint along child's - +WGHT_SE*Q(I_EAST,J_SOUTH,L) & ! boundary for child task NTX - +WGHT_NW*Q(I_WEST,J_NORTH,L) & - +WGHT_NE*Q(I_EAST,J_NORTH,L) -! - LOG_PTOP(I,J)=LOG(PINT_INTERP(I,J,L)) !<-- Log of parent (top) interface pressure at child bndry point -! - PHI_INTERP(I,J,L)=PHI_INTERP(I,J,L+1) & !<-- Top interface geopotl of parent at child gridpoint (I,J) - +R_D*T_INTERP*(1.+P608*Q_INTERP) & - *(LOG_PBOT(I,J)-LOG_PTOP(I,J)) -! - LOG_PBOT(I,J)=LOG_PTOP(I,J) !<--- Move Log(Ptop) to bottom of next model layer up -! - ENDDO - ENDDO -! - ENDDO -! -!----------------------------------------------------------------------- -!*** Use the child's actual sfc geopotential to derive the value of -!*** PD at the child boundary points based on the parent's heights -!*** and pressures at its (the parent's) layer interfaces over the -!*** child's boundary points. -! -!*** If the child's terrain is lower than the value of the parent's -!*** terrain interpolated to the child point then extrapolate the -!*** parent's interpolated Sfc Pressure down to the child's terrain -!*** quadratically. -!----------------------------------------------------------------------- -! - KOUNT_PTS=0 - KOUNT_TRANSFER=0 -! -!----------------------------------------------------------------------- - core_loop: DO J=J_START,J_END !<-- J limits of child task bndry region on parent task - DO I=I_START,I_END !<-- I limits of child task bndry region on parent task -!----------------------------------------------------------------------- -! - KOUNT_PTS=KOUNT_PTS+1 - FIS_CHILD=FIS_CHILD_BND(NTX)%DATA(KOUNT_PTS) -! - IF(FIS_CHILD=I_START_TRANSFER.AND.I<=I_END_TRANSFER & - .AND. & - J>=J_START_TRANSFER.AND.J<=J_END_TRANSFER)THEN -! - KOUNT_TRANSFER=KOUNT_TRANSFER+1 - CHILD_BOUND_H(NTX)%DATA(KOUNT_TRANSFER)= & - PDB(NTX)%DATA(KOUNT_PTS) - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO - ENDDO core_loop -! -!----------------------------------------------------------------------- -! - DEALLOCATE(PINT_INTERP) - DEALLOCATE(PHI_INTERP) - DEALLOCATE(LOG_PTOP) - DEALLOCATE(LOG_PBOT) -! -!----------------------------------------------------------------------- -! - ENDDO child_task_loop -! -!....................................................................... -!$omp end parallel do -!....................................................................... -! -!----------------------------------------------------------------------- -! - ENDDO loop_sides -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PARENT_UPDATE_CHILD_PSFC -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE PARENT_UPDATE_CHILD_BNDRY(VBL_PARENT & - ,VBL_NAME & -! - ,PD,PT,PDTOP & - ,PSGML1,SGML2,SG1,SG2 & -! - ,PD_SBND & - ,PD_NBND & - ,PD_WBND & - ,PD_EBND & -! - ,IMS,IME,JMS,JME & - ,NLEV & - ,N_REMOVE & -! - ,NUM_TASKS_SEND_SBND & - ,NUM_TASKS_SEND_NBND & - ,NUM_TASKS_SEND_WBND & - ,NUM_TASKS_SEND_EBND & -! - ,I_INDX_PARENT_SBND & - ,I_INDX_PARENT_NBND & - ,I_INDX_PARENT_WBND & - ,I_INDX_PARENT_EBND & - ,J_INDX_PARENT_SBND & - ,J_INDX_PARENT_NBND & - ,J_INDX_PARENT_WBND & - ,J_INDX_PARENT_EBND & -! - ,I_LO_SOUTH & - ,I_HI_SOUTH & - ,I_HI_SOUTH_TRANSFER & - ,I_LO_NORTH & - ,I_HI_NORTH & - ,I_HI_NORTH_TRANSFER & - ,J_LO_WEST & - ,J_HI_WEST & - ,J_HI_WEST_TRANSFER & - ,J_LO_EAST & - ,J_HI_EAST & - ,J_HI_EAST_TRANSFER & -! - ,WEIGHT_SBND & - ,WEIGHT_NBND & - ,WEIGHT_WBND & - ,WEIGHT_EBND & -! ^ - ,N_BLEND & ! | - ,IM_CHILD_X & ! | - ,JM_CHILD_X & ! Input -! ---------- - ,VBL_CHILD_SBND & ! Output - ,VBL_CHILD_NBND & ! | - ,VBL_CHILD_WBND & ! | - ,VBL_CHILD_EBND ) ! v -! -!----------------------------------------------------------------------- -!*** Parent tasks interpolate their values of variables -!*** to child grid points. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: IMS,IME,JMS,JME & !<-- Parent task's memory limits - ,IM_CHILD_X,JM_CHILD_X & !<-- Index limits of the nest domain - ,N_BLEND & !<-- # of domain boundary blending rows - ,NLEV & !<-- # of vertical levels in parent array - ,N_REMOVE & !<-- # of rows to ignore on north/east sides (H=>0;V=>1) -! - ,NUM_TASKS_SEND_SBND & !<-- # of child tasks with Sbndry points on parent task - ,NUM_TASKS_SEND_NBND & !<-- # of child tasks with Nbndry points on parent task - ,NUM_TASKS_SEND_WBND & !<-- # of child tasks with Wbndry points on parent task - ,NUM_TASKS_SEND_EBND !<-- # of child tasks with Ebndry points on parent task -! - INTEGER(kind=KINT),DIMENSION(:),POINTER,INTENT(IN) :: & - I_LO_SOUTH & !<-- Starting I of Sbndry region on child tasks - ,I_HI_SOUTH & !<-- Ending I of Sbndry region on child tasks - ,I_HI_SOUTH_TRANSFER & !<-- Ending I of Sbndry for transfer to child - ,I_LO_NORTH & !<-- Starting I of Nbndry region on child tasks - ,I_HI_NORTH & !<-- Ending I of Nbndry region on child tasks - ,I_HI_NORTH_TRANSFER & !<-- Ending I of Nbndry for transfer to child - ,J_LO_WEST & !<-- Starting J of Wbndry region on child tasks - ,J_HI_WEST & !<-- Ending J of Wbndry region on child tasks - ,J_HI_WEST_TRANSFER & !<-- Ending J of Wbndry for transfer to child - ,J_LO_EAST & !<-- Starting J of Ebndry region on child tasks - ,J_HI_EAST & !<-- Ending J of Ebndry region on child tasks - ,J_HI_EAST_TRANSFER !<-- Ending J of Ebndry for transfer to child -! - INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER,INTENT(IN) :: & - I_INDX_PARENT_SBND & !<-- I indices of parent points west/east of child Sbndry point - ,I_INDX_PARENT_NBND & !<-- I indices of parent points west/east of child Nbndry point - ,I_INDX_PARENT_WBND & !<-- I indices of parent points west/east of child Wbndry point - ,I_INDX_PARENT_EBND & !<-- I indices of parent points west/east of child Ebndry point - ,J_INDX_PARENT_SBND & !<-- J indices of parent points south/north of child Sbndry point - ,J_INDX_PARENT_NBND & !<-- J indices of parent points south/north of child Nbndry point - ,J_INDX_PARENT_WBND & !<-- J indices of parent points south/north of child Wbndry point - ,J_INDX_PARENT_EBND !<-- J indices of parent points south/north of child Ebndry point -! - REAL(kind=KFPT),INTENT(IN) :: PT & !<-- Top pressure of model domain (Pa) - ,PDTOP !<-- Pressure at top of sigma domain (Pa) -! - REAL(kind=KFPT),DIMENSION(:),POINTER,INTENT(IN) :: PSGML1 & !<-- Midlayer pressures, pressure domain - ,SGML2 & !<-- Midlayer sigmas, sigma domain - ,SG1 & !<-- Interface sigmas, pressure domain - ,SG2 !<-- Interface sigmas, sigma domain -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: PD !<-- Parent PD -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME,1:NLEV),INTENT(IN) :: & - VBL_PARENT !<-- Current variable on the parent domain -! - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER,INTENT(IN) :: & - WEIGHT_SBND & !<-- Bilinear interp weights of the 4 parent points around - ,WEIGHT_NBND & ! each point on child's boundaries. - ,WEIGHT_WBND & ! - ,WEIGHT_EBND ! -! - CHARACTER(len=*),INTENT(IN) :: VBL_NAME !<-- Which variable is the parent interpolating? Suffix: -nestbc -! - TYPE(REAL_DATA),DIMENSION(:),POINTER,INTENT(IN) :: PD_SBND & !<-- Boundary region PD (Pa) (column mass in sigma domain) - ,PD_NBND & ! on the four sides of the child boundary. - ,PD_WBND & ! - ,PD_EBND ! -! - TYPE(REAL_DATA),DIMENSION(:),POINTER,INTENT(INOUT) :: & - VBL_CHILD_SBND & !<-- Mass variable in child bndry region as computed - ,VBL_CHILD_NBND & !<-- by parent. - ,VBL_CHILD_WBND & ! - ,VBL_CHILD_EBND ! -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: I,J,L & - ,I_EAST,I_WEST,J_SOUTH,J_NORTH & - ,I_START,I_START_EXPAND & - ,I_END,I_END_EXPAND & - ,J_START,J_START_EXPAND & - ,J_END,J_END_EXPAND & - ,KNT_PTS,KNT_PTS_X & - ,L_VBL,LOC_1,LOC_2 & - ,N_ADD,N_EXP,N_SIDE,N_STRIDE,NTX & - ,NUM_LEVS_SEC,NUM_LEVS_SPLINE & - ,NUM_TASKS_SEND & - ,RC -! - INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: I_INDX_PARENT_BND & - ,J_INDX_PARENT_BND -! - REAL(kind=KFPT) :: COEFF_1,DELP_EXTRAP,DP1,DP2,DP3,FACTOR & - ,PDTOP_PT,PROD1,PROD2,PROD3,R_DELP -! - REAL(kind=KFPT) :: PX_NE,PX_NW,PX_SE,PX_SW & - ,WGHT_NE,WGHT_NW,WGHT_SE,WGHT_SW -! - REAL(kind=KFPT),DIMENSION(1:LM) :: PMID_CHILD -! - REAL(kind=KFPT),DIMENSION(1:LM+1) :: P_INPUT & - ,SEC_DERIV & - ,VBL_INPUT -! - REAL(kind=KFPT),DIMENSION(:),ALLOCATABLE :: T_LOWEST -! - REAL(kind=KFPT),DIMENSION(:,:),ALLOCATABLE :: PINT_INTERP_HI & - ,PMID_INTERP & - ,VBL_INTERP -! - REAL(kind=KFPT),DIMENSION(:,:,:),ALLOCATABLE :: PINT_INTERP_LO -! - REAL(kind=KFPT),DIMENSION(:),POINTER :: VBL_COL_CHILD -! - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: WEIGHT_BND -! - LOGICAL(kind=KLOG),DIMENSION(:),ALLOCATABLE :: INVERSION -! - TYPE(REAL_DATA),DIMENSION(:),POINTER :: PDB & - ,VBL_CHILD_BND -! - integer :: nnn,lll - integer,dimension(8) :: values -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - N_EXP=1-N_REMOVE !<-- Handle expansion of PDB range (H->1; V->0) - NUM_LEVS_SEC=LM+1 !<-- # of levels in spline routine's 2nd derivative array -! -!----------------------------------------------------------------------- -!*** Loop through the four sides of the nest domain boundary (S,N,W,E). -!*** We use some dummy variables/pointers generically for all four -!*** of the sides. -!----------------------------------------------------------------------- -! - loop_sides: DO N_SIDE=1,4 -! -!----------------------------------------------------------------------- -! - IF(N_SIDE==1)THEN - IF(NUM_TASKS_SEND_SBND==0)CYCLE !<-- Move on if parent task sees no part of nest's Sbndry -! - NUM_TASKS_SEND=NUM_TASKS_SEND_SBND - I_INDX_PARENT_BND=>I_INDX_PARENT_SBND - J_INDX_PARENT_BND=>J_INDX_PARENT_SBND - WEIGHT_BND=>WEIGHT_SBND - PDB=>PD_SBND - VBL_CHILD_BND=>VBL_CHILD_SBND -! - ELSEIF(N_SIDE==2)THEN - IF(NUM_TASKS_SEND_NBND==0)CYCLE !<-- Move on if parent task sees no part of nest's Nbndry -! - NUM_TASKS_SEND=NUM_TASKS_SEND_NBND - I_INDX_PARENT_BND=>I_INDX_PARENT_NBND - J_INDX_PARENT_BND=>J_INDX_PARENT_NBND - WEIGHT_BND=>WEIGHT_NBND - PDB=>PD_NBND - VBL_CHILD_BND=>VBL_CHILD_NBND -! - ELSEIF(N_SIDE==3)THEN - IF(NUM_TASKS_SEND_WBND==0)CYCLE !<-- Move on if parent task sees no part of nest's Wbndry -! - NUM_TASKS_SEND=NUM_TASKS_SEND_WBND - I_INDX_PARENT_BND=>I_INDX_PARENT_WBND - J_INDX_PARENT_BND=>J_INDX_PARENT_WBND - WEIGHT_BND=>WEIGHT_WBND - PDB=>PD_WBND - VBL_CHILD_BND=>VBL_CHILD_WBND -! - ELSEIF(N_SIDE==4)THEN - IF(NUM_TASKS_SEND_EBND==0)CYCLE !<-- Move on if parent task sees no part of nest's Ebndry -! - NUM_TASKS_SEND=NUM_TASKS_SEND_EBND - I_INDX_PARENT_BND=>I_INDX_PARENT_EBND - J_INDX_PARENT_BND=>J_INDX_PARENT_EBND - WEIGHT_BND=>WEIGHT_EBND - PDB=>PD_EBND - VBL_CHILD_BND=>VBL_CHILD_EBND -! - ENDIF -! -!----------------------------------------------------------------------- -!....................................................................... -!$omp parallel do & -!$omp private(coeff_1,delp_extrap,dp1,dp2,dp3,factor, & -!$omp i,i_east,i_end,i_end_expand,i_start,i_start_expand, & -!$omp i_west,inversion, & -!$omp j,j_end,j_end_expand,j_north,j_south, & -!$omp j_start,j_start_expand, & -!$omp knt_pts,knt_pts_x,l,l_vbl,loc_1,loc_2, & -!$omp n_add,n_stride,ntx,num_levs_spline, & -!$omp p_input,pdtop_pt,pint_interp_hi,pint_interp_lo, & -!$omp pmid_child,pmid_interp,prod1,prod2,prod3, & -!$omp px_ne,px_nw,px_se,px_sw,r_delp,sec_deriv, & -!$omp t_lowest,vbl_col_child,vbl_input,vbl_interp, & -!$omp wght_ne,wght_nw,wght_se,wght_sw) -!....................................................................... -! - child_task_loop: DO NTX=1,NUM_TASKS_SEND !<-- Fill bndry data for each child task on the child bndry - ! segment seen by this parent task. -!----------------------------------------------------------------------- -! -!---------------------------------------------- -!*** South boundary limits on this child task -!---------------------------------------------- -! - IF(N_SIDE==1)THEN - I_START =I_LO_SOUTH(NTX) - I_END =I_HI_SOUTH_TRANSFER(NTX) - J_START =1 - J_END =N_BLEND -! - I_START_EXPAND=I_START !<-- Expanded limits for extra row of PD for 4-pt averaging - I_END_EXPAND=I_HI_SOUTH(NTX) ! - J_START_EXPAND=J_START ! - J_END_EXPAND=J_END+N_EXP !<-- -! -!---------------------------------------------- -!*** North boundary limits on this child task -!---------------------------------------------- -! - ELSEIF(N_SIDE==2)THEN - I_START =I_LO_NORTH(NTX) - I_END =I_HI_NORTH_TRANSFER(NTX) - J_START =JM_CHILD_X-N_BLEND+1-N_REMOVE - J_END =JM_CHILD_X-N_REMOVE -! - I_START_EXPAND=I_START !<-- Expanded limits for extra row of PD for 4-pt averaging - I_END_EXPAND=I_HI_NORTH(NTX) ! - J_START_EXPAND=J_START-N_EXP ! - J_END_EXPAND=J_END !<-- -! -!--------------------------------------------- -!*** West boundary limits on this child task -!--------------------------------------------- -! - ELSEIF(N_SIDE==3)THEN - I_START =1 - I_END =N_BLEND - J_START =J_LO_WEST(NTX) - J_END =J_HI_WEST_TRANSFER(NTX) -! - I_START_EXPAND=I_START !<-- Expanded limits for extra row of PD for 4-pt averaging - I_END_EXPAND=I_END+N_EXP ! - J_START_EXPAND=J_START ! - J_END_EXPAND=J_HI_WEST(NTX) !<-- -! -!--------------------------------------------- -!*** East boundary limits on this child task -!--------------------------------------------- -! - ELSEIF(N_SIDE==4)THEN - I_START =IM_CHILD_X-N_BLEND+1-N_REMOVE - I_END =IM_CHILD_X-N_REMOVE - J_START =J_LO_EAST(NTX) - J_END =J_HI_EAST_TRANSFER(NTX) -! - I_START_EXPAND=I_START-N_EXP !<-- Expanded limits for extra row of PD for 4-pt averaging - I_END_EXPAND=I_END ! - J_START_EXPAND=J_START ! - J_END_EXPAND=J_HI_EAST(NTX) !<-- -! - ENDIF -! -!----------------------------------------------------------------------- -! - N_STRIDE=(I_END-I_START+1)*(J_END-J_START+1) !<-- # of pts, this side, this child task's bndry region -! - ALLOCATE(PMID_INTERP(1:N_STRIDE,1:LM)) - ALLOCATE(VBL_INTERP (1:N_STRIDE,1:NLEV)) - ALLOCATE(T_LOWEST (1:N_STRIDE)) - ALLOCATE(INVERSION (1:N_STRIDE)) -! - ALLOCATE(PINT_INTERP_HI(I_START:I_END,J_START:J_END)) - ALLOCATE(PINT_INTERP_LO(I_START:I_END,J_START:J_END,1:NLEV+1)) -! -!----------------------------------------------------------------------- -!*** We need the mid-layer pressure values in the parent layers -!*** over the child boundary point locations since those are -!*** required for the vertical interpolation of variables -!*** to the mid-layers in the child. -!*** Compute the interface pressures of the parent layers -!*** then take the means to get the mid-layer values. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Start with the bottom layer (L=NLEV). -!----------------------------------------------------------------------- -! - DO J=J_START,J_END !<-- J limits of child task bndry region on parent task - DO I=I_START,I_END !<-- I limits of child task bndry region on parent task -! - I_WEST =I_INDX_PARENT_BND(I,J,1) !<-- Parent I index on or west of child's boundary point - I_EAST =I_INDX_PARENT_BND(I,J,2) !<-- Parent I index east of child's boundary point - J_SOUTH=J_INDX_PARENT_BND(I,J,1) !<-- Parent J index on or south of child's boundary point - J_NORTH=J_INDX_PARENT_BND(I,J,2) !<-- Parent J index north of child's boundary point -! - WGHT_SW=WEIGHT_BND(I,J,INDX_SW) !<-- Bilinear weight for parent's point SW of nest's point - WGHT_SE=WEIGHT_BND(I,J,INDX_SE) !<-- Bilinear weight for parent's point SE of nest's point - WGHT_NW=WEIGHT_BND(I,J,INDX_NW) !<-- Bilinear weight for parent's point NW of nest's point - WGHT_NE=WEIGHT_BND(I,J,INDX_NE) !<-- Bilinear weight for parent's point NE of nest's point -! - PX_SW=PD(I_WEST,J_SOUTH)+PT !<-- Sfc pressure on parent point SW of nest point - PX_SE=PD(I_EAST,J_SOUTH)+PT !<-- Sfc pressure on parent point SE of nest point - PX_NW=PD(I_WEST,J_NORTH)+PT !<-- Sfc pressure on parent point NW of nest point - PX_NE=PD(I_EAST,J_NORTH)+PT !<-- Sfc pressure on parent point NE of nest point -! - PINT_INTERP_LO(I,J,NLEV+1)=WGHT_SW*PX_SW & !<-- Parent's surface pressure interp'd to this child's - +WGHT_SE*PX_SE & ! gridpoint (I,J) along child's boundary for - +WGHT_NW*PX_NW & ! child task NTX. - +WGHT_NE*PX_NE -! - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** Now compute those mid-layer pressures in the parent layers -!*** as well as the values of the parent's variable at those -!*** pressure levels. -!----------------------------------------------------------------------- -! - DO L=LM,1,-1 !<-- Work upward to get geopotentials on child layer interfaces -! - KNT_PTS=0 - PDTOP_PT=SG1(L)*PDTOP+PT -! - IF(NLEV==1)THEN - L_VBL=1 !<-- Account for possible 2-D boundary variables - ELSE - L_VBL=L - ENDIF -! - DO J=J_START,J_END !<-- J limits of child task bndry region on parent task - DO I=I_START,I_END !<-- I limits of child task bndry region on parent task -! - I_WEST =I_INDX_PARENT_BND(I,J,1) !<-- Parent I index on or west of child's boundary point - I_EAST =I_INDX_PARENT_BND(I,J,2) !<-- Parent I index east of child's boundary point - J_SOUTH=J_INDX_PARENT_BND(I,J,1) !<-- Parent J index on or south of child's boundary point - J_NORTH=J_INDX_PARENT_BND(I,J,2) !<-- Parent J index north of child's boundary point -! - PX_SW=SG2(L)*PD(I_WEST,J_SOUTH)+PDTOP_PT !<-- Pressure, top of layer L, parent point SW of nest point - PX_SE=SG2(L)*PD(I_EAST,J_SOUTH)+PDTOP_PT !<-- Pressure, top of layer L, parent point SE of nest point - PX_NW=SG2(L)*PD(I_WEST,J_NORTH)+PDTOP_PT !<-- Pressure, top of layer L, parent point NW of nest point - PX_NE=SG2(L)*PD(I_EAST,J_NORTH)+PDTOP_PT !<-- Pressure, top of layer L, parent point NE of nest point -! - WGHT_SW=WEIGHT_BND(I,J,INDX_SW) !<-- Bilinear weight for parent's point SW of child's point - WGHT_SE=WEIGHT_BND(I,J,INDX_SE) !<-- Bilinear weight for parent's point SE of child's point - WGHT_NW=WEIGHT_BND(I,J,INDX_NW) !<-- Bilinear weight for parent's point NW of child's point - WGHT_NE=WEIGHT_BND(I,J,INDX_NE) !<-- Bilinear weight for parent's point NE of child's point -! - PINT_INTERP_HI(I,J)=WGHT_SW*PX_SW & !<-- Top interface pressure interp'd to child gridpoint - +WGHT_SE*PX_SE & ! in child's boundary region on child task NTX - +WGHT_NW*PX_NW & - +WGHT_NE*PX_NE -! - KNT_PTS=KNT_PTS+1 -! - PMID_INTERP(KNT_PTS,L)=0.5*(PINT_INTERP_HI(I,J) & !<-- Parent midlayer pressure interp'd to child gridpoint - +PINT_INTERP_LO(I,J,L+1)) ! in child's boundary region of child task NTX -! - VBL_INTERP(KNT_PTS,L_VBL)=WGHT_SW & !<-- Parent variable interp'd to child gridpoint - *VBL_PARENT(I_WEST,J_SOUTH,L) & ! in child's boundary region of child task NTX. - +WGHT_SE & ! - *VBL_PARENT(I_EAST,J_SOUTH,L) & ! - +WGHT_NW & ! - *VBL_PARENT(I_WEST,J_NORTH,L) & ! - +WGHT_NE & ! - *VBL_PARENT(I_EAST,J_NORTH,L) !<-- -! if(i==isee.and.j==jsee.and.l==ksee)then -! if(n_side==2)then -! write(0,44370)trim(vbl_name) -! write(0,44371)vbl_interp(knt_pts,l_vbl),knt_pts,i_west,i_east,j_south,j_north -! write(0,44372)wght_sw,wght_se,wght_nw,wght_ne -! write(0,44373)vbl_parent(i_west,j_south,l),vbl_parent(i_east,j_south,l) & -! ,vbl_parent(i_west,j_north,l),vbl_parent(i_east,j_north,l) -44370 format(' PARENT_UPDATE_CHILD_BNDRY vbl_name=',a) -44371 format(' vbl_interp=',f6.2,' knt_pnts=',i6,' i_west=',i3,' i_east=',i3,' j_south=',i3,' j_north=',i3) -44372 format(' wgts=',4(1x,f6.3)) -44373 format(' parent values=',4(1x,f6.2)) -! endif -! endif -! if(n_side==3.and.i==5.and.j==7.and.l==1.and.trim(vbl_flag)=='T-nestbc')THEN -! write(0,33891)knt_pts,vbl_interp(knt_pts,l) -! write(0,33892)vbl_parent(i_west,j_south,l),vbl_parent(i_east,j_south,l) & -! ,vbl_parent(i_west,j_north,l),vbl_parent(i_east,j_north,l) -! write(0,33893)wght_sw,wght_se,wght_nw,wght_ne -! write(0,33894)i_west,i_east,j_south,j_north -33891 format(' PARENT_UPDATE_CHILD_BNDRY knt_pts=',i6,' vbl_interp=',z8) -33892 format(' vbl_parent=',4(1x,z8)) -33893 format(' wght=',4(1x,z8)) -33894 format(' i_west=',i3,' i_east=',i3,' j_south=',i3,' j_north=',i3) -! endif - PINT_INTERP_LO(I,J,L)=PINT_INTERP_HI(I,J) -! - ENDDO - ENDDO -! - IF(NLEV==1)EXIT -! - ENDDO -! -!----------------------------------------------------------------------- -!*** The parent uses mass-weighted averages of the lowest and -!*** 2nd lowest layer temperatures to avoid extrapolation problems -!*** when there is an inversion present. -!----------------------------------------------------------------------- -! - IF(TRIM(VBL_NAME)=='T-nestbc')THEN - KNT_PTS=0 -! - DO J=J_START,J_END - DO I=I_START,I_END - KNT_PTS=KNT_PTS+1 - INVERSION(KNT_PTS)=.FALSE. - IF(VBL_INTERP(KNT_PTS,NLEV)I_END & - .OR. & - JJ_END)CYCLE -! - KNT_PTS=KNT_PTS+1 !<-- Location in 1-D datastring of child bndry variable - LOC_1=LOC_1+1 !<-- Next storage location in the final BC object -! -!----------------------------------------------------------------------- -!*** For 2-D boundary variables the parent simply inserts the -!*** given I,J value for the single level into the final output -!*** object. -!----------------------------------------------------------------------- -! - IF(NLEV==1)THEN - VBL_CHILD_BND(NTX)%DATA(LOC_1)=VBL_INTERP(KNT_PTS,1) - CYCLE !<-- Move through the I,J locations disregarding the vertical. - ENDIF -! -!----------------------------------------------------------------------- -!*** Midlayer pressures for the nest boundary points. -!----------------------------------------------------------------------- -! - DO L=1,LM - PMID_CHILD(L)=PSGML1(L)+SGML2(L)*PDB(NTX)%DATA(KNT_PTS_X) !<-- Nest midlayer pressure - ENDDO -! -!----------------------------------------------------------------------- -!*** Use spline interpolation to move variables from their -!*** vertical locations in the column after horizontal interpolation -!*** from the surrounding parent points to child boundary point levels. -!*** The target locations are the new midlayer pressures in the -!*** nest boundary point columns based on the new surface pressure -!*** for the nest's terrain. -! -!*** If the target location lies below the middle of the lowest parent -!*** layer in the newly created child column then extrapolate linearly -!*** in pressure to obtain a value at the lowest child mid-layer and -!*** fill in the remaining 'underground' levels using the call to -!*** 'SPLINE' just as with all the other higher levels. -!----------------------------------------------------------------------- -! - DO L=1,LM !<-- Extract mid-layer values of parent in nest column - P_INPUT (L)=PMID_INTERP(KNT_PTS,L) - VBL_INPUT(L)= VBL_INTERP(KNT_PTS,L) - ENDDO -! - LOC_2=LOC_1+N_ADD - VBL_COL_CHILD=>VBL_CHILD_BND(NTX)%DATA(LOC_1:LOC_2:N_STRIDE) !<-- Point working column pointer into 1-D horizontal -! output pointer for this variable. - NUM_LEVS_SPLINE=LM -! - IF(PMID_CHILD(LM)>P_INPUT(LM))THEN !<-- Nest's lowest mid-layer is lower than parent's - NUM_LEVS_SPLINE=LM+1 !<-- Add another input level at nest's lowest - P_INPUT(LM+1)=PMID_CHILD(LM) ! mid-layer. -! -! IF(TRIM(VBL_FLAG)=='T'.AND.INVERSION(KNT_PTS))THEN !<-- For temperature inversions place the parent's -! VBL_INPUT(LM+1)=T_LOWEST(KNT_PTS) ! original cold sfc lyr into the new bottom lyr. -! ELSE - R_DELP=1./(P_INPUT(LM)-P_INPUT(LM-1)) - DELP_EXTRAP=PMID_CHILD(LM)-P_INPUT(LM) -! - COEFF_1=(VBL_INPUT(LM)-VBL_INPUT(LM-1))*R_DELP - FACTOR=HYPER_A/(DELP_EXTRAP+HYPER_A) - VBL_INPUT(LM+1)=VBL_INPUT(LM) & !<-- Extrapolated value at nest's new bottom - +COEFF_1*DELP_EXTRAP*FACTOR ! midlayer. -! ENDIF -! - ENDIF -! - DO L=1,LM+1 - SEC_DERIV(L)=0. !<-- Initialize 2nd derivatives of the spline to zero. - ENDDO -! - CALL SPLINE(NUM_LEVS_SPLINE & !<-- # of input levels - ,P_INPUT(1:NUM_LEVS_SPLINE) & !<-- Input mid-layer pressures - ,VBL_INPUT(1:NUM_LEVS_SPLINE) & !<-- Input mid-layer mass variable value - ,SEC_DERIV & !<-- Specified 2nd derivatives (=0) at parent points - ,NUM_LEVS_SEC & - ,LM & !<-- # of child mid-layers to interpolate to - ,PMID_CHILD & !<-- Child mid-layer pressures to interpolate to - ,VBL_COL_CHILD) !<-- Child mid-layer variable value returned -! if(n_side==2.and.i==isee.and.j==jsee.and.trim(vbl_name)=='T-nestbc')THEN -! write(0,69471)ntx,loc_1,loc_2,n_stride,vbl_child_bnd(ntx)%data(loc_1) -! write(0,69476)knt_pts,vbl_input(1),vbl_input(2),vbl_input(3) -! write(0,69477)p_input(1),p_input(2),p_input(3) -69471 format(' PARENT_UPDATE_CHILD_BNDRY T after SPLINE ntx=',i2,' loc_1=',i5,' loc_2=',i5,' n_stride=',i5 & - ,' vbl_child_bnd(ntx)%data(loc_1)=',f6.2) -69476 format(' knt_pts=',i6,' vbl_input=',3(1x,f6.2)) -69477 format(' p_input=',3(1x,f9.2)) -! endif -! -!----------------------------------------------------------------------- -! - ENDDO - ENDDO main_loop -! -!----------------------------------------------------------------------- -! - DEALLOCATE(PMID_INTERP) - DEALLOCATE(VBL_INTERP) - DEALLOCATE(INVERSION) - DEALLOCATE(T_LOWEST) -! - DEALLOCATE(PINT_INTERP_HI) - DEALLOCATE(PINT_INTERP_LO) -! -!----------------------------------------------------------------------- -! - ENDDO child_task_loop -! -!....................................................................... -!$omp end parallel do -!....................................................................... -! -!----------------------------------------------------------------------- -! - ENDDO loop_sides -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PARENT_UPDATE_CHILD_BNDRY -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE PRESSURE_ON_NEST_BNDRY_V(PD_H & - ,IMS,IME,JMS,JME & -! - ,PDB_S_H & - ,PDB_N_H & - ,PDB_W_H & - ,PDB_E_H & -! - ,NUM_TASKS_SEND_SBND & - ,NUM_TASKS_SEND_NBND & - ,NUM_TASKS_SEND_WBND & - ,NUM_TASKS_SEND_EBND & -! - ,I_LO_SOUTH_V & - ,I_HI_SOUTH_V & - ,I_LO_NORTH_V & - ,I_HI_NORTH_V & - ,J_LO_WEST_V & - ,J_HI_WEST_V & - ,J_LO_EAST_V & - ,J_HI_EAST_V & -! - ,I_LO_SOUTH_H & - ,I_HI_SOUTH_H & - ,I_LO_NORTH_H & - ,I_HI_NORTH_H & - ,J_LO_WEST_H & - ,J_HI_WEST_H & - ,J_LO_EAST_H & - ,J_HI_EAST_H & -! ^ - ,N_BLEND_H_CHILD & ! | - ,N_BLEND_V_CHILD & ! | - ,IM_CHILD & ! | - ,JM_CHILD & ! | - ! | - ,INC_FIX_N & ! Input -! --------- - ,PD_V & ! Output - ,PDB_S_V & ! | - ,PDB_N_V & ! | - ,PDB_W_V & ! v - ,PDB_E_V ) ! -! -!----------------------------------------------------------------------- -!*** Use 4-pt horizontal interpolation to compute PD on V points -!*** of the parent domain and of the nest boundary given those -!*** values on H points. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: IMS,IME,JMS,JME & !<-- Parent task's memory limits - ,IM_CHILD,JM_CHILD & !<-- Nest domain limits - ,INC_FIX_N & !<-- Increment for selecting nest tasks for averaging H to V - ,N_BLEND_H_CHILD & !<-- H rows in nest's boundary region - ,N_BLEND_V_CHILD & !<-- V rows in nest's boundary region - ,NUM_TASKS_SEND_SBND & !<-- # of child tasks with Sbndry V points on parent task - ,NUM_TASKS_SEND_NBND & !<-- # of child tasks with Nbndry V points on parent task - ,NUM_TASKS_SEND_WBND & !<-- # of child tasks with Wbndry V points on parent task - ,NUM_TASKS_SEND_EBND !<-- # of child tasks with Ebndry V points on parent task -! - INTEGER(kind=KINT),DIMENSION(:),POINTER,INTENT(IN) :: & - I_LO_SOUTH_H & !<-- Starting I of Sbndry region H points on child tasks - ,I_HI_SOUTH_H & !<-- Ending I of Sbndry region H points on child tasks - ,I_LO_NORTH_H & !<-- Starting I of Nbndry region H points on child tasks - ,I_HI_NORTH_H & !<-- Ending I of Nbndry region H points on child tasks - ,J_LO_WEST_H & !<-- Starting J of Wbndry region H points on child tasks - ,J_HI_WEST_H & !<-- Ending J of Wbndry region H points on child tasks - ,J_LO_EAST_H & !<-- Starting J of Ebndry region H points on child tasks - ,J_HI_EAST_H !<-- Ending J of Ebndry region H points on child tasks -! - INTEGER(kind=KINT),DIMENSION(:),POINTER,INTENT(IN) :: & - I_LO_SOUTH_V & !<-- Starting I of Sbndry region V points on child tasks - ,I_HI_SOUTH_V & !<-- Ending I of Sbndry region V points on child tasks - ,I_LO_NORTH_V & !<-- Starting I of Nbndry region V points on child tasks - ,I_HI_NORTH_V & !<-- Ending I of Nbndry region V points on child tasks - ,J_LO_WEST_V & !<-- Starting J of Wbndry region V points on child tasks - ,J_HI_WEST_V & !<-- Ending J of Wbndry region V points on child tasks - ,J_LO_EAST_V & !<-- Starting J of Ebndry region V points on child tasks - ,J_HI_EAST_V !<-- Ending J of Ebndry region V points on child tasks -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: PD_H !<-- Parent PD (Pa) (column mass in sigma domain) on H points -! - TYPE(REAL_DATA),DIMENSION(:),POINTER,INTENT(IN) :: PDB_S_H & !<-- Boundary region PD (Pa) (column mass in sigma domain) - ,PDB_N_H & ! on mass points on the four sides of the child boundary. - ,PDB_W_H & ! - ,PDB_E_H !<-- -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: PD_V !<-- Parent PD (Pa) (column mass in sigma domain) on V points -! - TYPE(REAL_DATA),DIMENSION(:),POINTER,INTENT(INOUT) :: PDB_S_V & !<-- Child boundary PD (Pa) on child domain Sbndry V points - ,PDB_N_V & !<-- Child boundary PD (Pa) on child domain Nbndry V points - ,PDB_W_V & !<-- Child boundary PD (Pa) on child domain Wbndry V points - ,PDB_E_V !<-- Child boundary PD (Pa) on child domain Ebndry V points -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: DIFF_START,DIFF_START_PTS & - ,I,J & - ,I_ADD_H,I_INC_H & - ,I_START_H,I_START_V & - ,I_END_H,I_END_V & - ,I_HI_H,I_LO_H & - ,J_START_H,J_START_V & - ,J_END_H,J_END_V & - ,KNT_H,KNT_V & - ,N_ADD_H,N_OFFSET_H,N_SIDE & - ,NTX,NTX_H,NUM_TASKS_SEND -! - INTEGER(kind=KINT),DIMENSION(4) :: NTX_ADD -! - TYPE(REAL_DATA),DIMENSION(:),POINTER :: PDB_H & - ,PDB_V -! - integer,dimension(8) :: values -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - DO N_SIDE=1,4 - NTX_ADD(N_SIDE)=0 - ENDDO -! -!----------------------------------------------------------------------- -!*** First obtain PD on the parent's V points. -!----------------------------------------------------------------------- -! - DO J=JMS,JME-1 - DO I=IMS,IME-1 - PD_V(I,J)=0.25*(PD_H(I,J)+PD_H(I+1,J)+PD_H(I,J+1)+PD_H(I+1,J+1)) - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** Now average values of PD on and adjacent to the nests' boundary -!*** to obtain PD on the nests' boundary V points. -!----------------------------------------------------------------------- -! - loop_sides: DO N_SIDE=1,4 !<-- Loop through the 4 lateral boundaries (S,N,W,E) -! -!----------------------------------------------------------------------- -! - IF(N_SIDE==1)THEN - IF(NUM_TASKS_SEND_SBND==0)CYCLE !<-- Move on if parent task sees no part of nest's Sbndry -! - NUM_TASKS_SEND=NUM_TASKS_SEND_SBND !<-- # of Sbndry nest tasks to which parent sends PDB on V - PDB_H=>PDB_S_H !<-- String of Sbndry PDB on H for this nest task - PDB_V=>PDB_S_V !<-- String of Sbndry PDB on V for this nest task -! -! - ELSEIF(N_SIDE==2)THEN - IF(NUM_TASKS_SEND_NBND==0)CYCLE !<-- Move on if parent task sees no part of nest's Nbndry -! - NUM_TASKS_SEND=NUM_TASKS_SEND_NBND !<-- # of Nbndry nest tasks to which parent sends PDB on V - PDB_H=>PDB_N_H !<-- String of Nbndry PDB on H for this nest task - PDB_V=>PDB_N_V !<-- String of Nbndry PDB on V for this nest task -! - ELSEIF(N_SIDE==3)THEN - IF(NUM_TASKS_SEND_WBND==0)CYCLE !<-- Move on if parent task sees no part of nest's Wbndry -! - NUM_TASKS_SEND=NUM_TASKS_SEND_WBND !<-- # of Wbndry nest tasks to which parent sends PDB on V - PDB_H=>PDB_W_H !<-- String of Wbndry PDB on H for this nest task - PDB_V=>PDB_W_V !<-- String of Wbndry PDB on V for this nest task -! - ELSEIF(N_SIDE==4)THEN - IF(NUM_TASKS_SEND_EBND==0)CYCLE !<-- Move on if parent task sees no part of nest's Ebndry -! - NUM_TASKS_SEND=NUM_TASKS_SEND_EBND !<-- # of Ebndry nest tasks to which parent sends PDB on V - PDB_H=>PDB_E_H !<-- String of Ebndry PDB on H for this nest task - PDB_V=>PDB_E_V !<-- String of Ebndry PDB on V for this nest task -! - ENDIF -! -!----------------------------------------------------------------------- -! - child_task_loop: DO NTX=1,NUM_TASKS_SEND !<-- Compute PD on V points for each child task with - ! bndry segments seen by this parent task. -!----------------------------------------------------------------------- -! -!---------------------------------------------- -!*** South boundary limits on this child task -!---------------------------------------------- -! - IF(N_SIDE==1)THEN - I_START_V=I_LO_SOUTH_V(NTX) !<-- I index of first Sbndry V point on this child task - I_END_V =I_HI_SOUTH_V(NTX) !<-- I index of last Sbndry V point on this child task - J_START_V=1 !<-- J index of first Sbndry V point on this child task - J_END_V =N_BLEND_V_CHILD !<-- J index of last Sbndry V point on this child task -! - I_END_H =I_HI_SOUTH_H(NTX) !<-- I index of last Sbndry H point east of last Sbndry V point -! - IF(NTX==1.AND.NUM_TASKS_SEND>1)THEN - IF(I_START_V==I_LO_SOUTH_H(NTX+1)+INC_FIX_N & - .AND. & - I_END_V>=I_END_H)THEN - NTX_ADD(N_SIDE)=1 - ENDIF - ENDIF -! - NTX_H=NTX+NTX_ADD(N_SIDE) !<-- Reference parent task for PDB on nest H points - DIFF_START=I_START_V-I_LO_SOUTH_H(NTX_H) - I_HI_H=I_HI_SOUTH_H(NTX_H) - I_LO_H=I_LO_SOUTH_H(NTX_H) - N_ADD_H=I_HI_H-I_LO_H+1 -! -!---------------------------------------------- -!*** North boundary limits on this child task -!---------------------------------------------- -! - ELSEIF(N_SIDE==2)THEN - I_START_V=I_LO_NORTH_V(NTX) !<-- I index of first Nbndry V point on this child task - I_END_V =I_HI_NORTH_V(NTX) !<-- I index of last Nbndry V point on this child task - J_START_V=JM_CHILD-N_BLEND_V_CHILD !<-- J index of first Nbndry V point on this child task - J_END_V =JM_CHILD-1 !<-- J index of last Nbndry V point on this child task -! - I_END_H =I_HI_NORTH_H(NTX) !<-- I index of last Nbndry H point east of last Nbndry V point -! - IF(NTX==1.AND.NUM_TASKS_SEND>1)THEN - IF(I_START_V==I_LO_NORTH_H(NTX+1)+INC_FIX_N & - .AND. & - I_END_V>=I_END_H)THEN - NTX_ADD(N_SIDE)=1 - ENDIF - ENDIF -! - NTX_H=NTX+NTX_ADD(N_SIDE) !<-- Reference parent task for PDB on nest H points - DIFF_START=I_START_V-I_LO_NORTH_H(NTX_H) - I_HI_H=I_HI_NORTH_H(NTX_H) - I_LO_H=I_LO_NORTH_H(NTX_H) - N_ADD_H=I_HI_H-I_LO_H+1 -! -!---------------------------------------------- -!*** West boundary limits on this child task -!--------------------------------------------- -! - ELSEIF(N_SIDE==3)THEN - I_START_V=1 !<-- I index of first Wbndry V point on this child task - I_END_V =N_BLEND_V_CHILD !<-- I index of last Wbndry V point on this child task - J_START_V=J_LO_WEST_V(NTX) !<-- J index of first Wbndry V point on this child task - J_END_V =J_HI_WEST_V(NTX) !<-- J index of last Wbndry V point on this child task -! - J_END_H =J_HI_WEST_H(NTX) !<-- J index of last Wbndry H point east of last Wbndry V point -! - IF(NTX==1.AND.NUM_TASKS_SEND>1)THEN - IF(J_START_V==J_LO_WEST_H(NTX+1)+INC_FIX_N & - .AND. & - J_END_V>=J_END_H)THEN - NTX_ADD(N_SIDE)=1 - ENDIF - ENDIF -! - NTX_H=NTX+NTX_ADD(N_SIDE) !<-- Reference parent task for PDB on nest H points - DIFF_START=J_START_V-J_LO_WEST_H(NTX_H) - DIFF_START_PTS=DIFF_START*(N_BLEND_H_CHILD+1) - N_ADD_H=N_BLEND_H_CHILD+1 -! -!--------------------------------------------- -!*** East boundary limits on this child task -!--------------------------------------------- -! - ELSEIF(N_SIDE==4)THEN - I_START_V=IM_CHILD-N_BLEND_V_CHILD !<-- I index of first Ebndry V point on this child task - I_END_V =IM_CHILD-1 !<-- I index of last Ebndry V point on this child task - J_START_V=J_LO_EAST_V(NTX) !<-- J index of first Ebndry V point on this child task - J_END_V =J_HI_EAST_V(NTX) !<-- J index of last Ebndry V point on this child task -! - J_END_H =J_HI_EAST_H(NTX) !<-- J index of last Ebndry H point east of last Ebndry V point -! - IF(NTX==1.AND.NUM_TASKS_SEND>1)THEN - IF(J_START_V==J_LO_EAST_H(NTX+1)+INC_FIX_N & - .AND. & - J_END_V>=J_END_H)THEN - NTX_ADD(N_SIDE)=1 - ENDIF - ENDIF -! - NTX_H=NTX+NTX_ADD(N_SIDE) !<-- Reference parent task for PDB on nest H points - DIFF_START=J_START_V-J_LO_EAST_H(NTX_H) - DIFF_START_PTS=DIFF_START*(N_BLEND_H_CHILD+1) - N_ADD_H=N_BLEND_H_CHILD+1 -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Ready to average nest boundary PD on H to PD on V. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Recall that the PDB_H pointer contains data for one extra row -!*** beyond the child boundary on all sides since we need the -!*** ability to do 4-pt averages of PD to V points. -!*** Here we must use PDB_H but the values for PDB_V (and thus U,V) -!*** are only generated on the true boundary points. To address PDB_H -!*** correctly we must take into account those extra points in PDB_H -!*** as we march through the V point locations. -! -!*** Also we must be aware that the nest boundary V segments that are -!*** being considered for each nest task must correspond to the same -!*** nest task H point values of PDB. Because of overlap that can -!*** occur due to the segments of PDB on H being larger than PBD on -!*** V we must explicitly check to be sure that nest PDB on V is -!*** being filled by nest PDB on H for the same nest task. -!----------------------------------------------------------------------- -! - KNT_V=0 -! - DO J=J_START_V,J_END_V - IF(N_SIDE<=2)THEN - N_OFFSET_H=(DIFF_START+1)*(J-J_START_V+1)-1 - ELSEIF(N_SIDE>=3)THEN - N_OFFSET_H=J-J_START_V+DIFF_START_PTS - ENDIF -! - DO I=I_START_V,I_END_V - KNT_V=KNT_V+1 - KNT_H=KNT_V+N_OFFSET_H - PDB_V(NTX)%DATA(KNT_V)=(PDB_H(NTX_H)%DATA(KNT_H) & - +PDB_H(NTX_H)%DATA(KNT_H+1) & - +PDB_H(NTX_H)%DATA(KNT_H+N_ADD_H) & - +PDB_H(NTX_H)%DATA(KNT_H+N_ADD_H+1)) & - *0.25 -! if(i==36.and.n_side==2)then -! write(0,*)' PRESSURE_ON_NEST_BNDRY_V j=',j,' ntx=',ntx,' n_offset_h=',n_offset_h -! write(0,*)' pdb_v=',pdb_v(ntx)%data(knt_v),' knt_v=',knt_v,' knt_h=',knt_h -! write(0,*)' pdb_h=',PDB_H(NTX_H)%DATA(KNT_H),PDB_H(NTX_H)%DATA(KNT_H+1) & -! ,PDB_H(NTX_H)%DATA(KNT_H+N_ADD_H),PDB_H(NTX_H)%DATA(KNT_H+N_ADD_H+1) -! endif - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -! - ENDDO child_task_loop -! -!----------------------------------------------------------------------- -! - ENDDO loop_sides -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PRESSURE_ON_NEST_BNDRY_V -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE PARENT_2WAY_UPDATE(I_2WAY_UPDATE_START & - ,I_2WAY_UPDATE_END & - ,J_2WAY_UPDATE_START & - ,J_2WAY_UPDATE_END & - ,LM & - ,NPTS_UPDATE_HORIZ & - ,NPTS_UPDATE_TOTAL & - ,NVARS_2WAY_UPDATE & - ,VAR_2WAY & - ,CHILD_SFC_ON_PARENT_GRID & - ,WGT_CHILD & - ,FIS & - ,PD,PDTOP,PT & ! ^ - ,SG1,SG2 & ! | - ,IMS,IME,JMS,JME & ! | - ! input -! ----- - ,BUNDLE_2WAY & ! output - ) -! -!----------------------------------------------------------------------- -!*** Parent tasks incorporate new 2-way exchange data sent from the -!*** children. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: I_2WAY_UPDATE_START & !<-- Starting parent I of its 2-way update region - ,I_2WAY_UPDATE_END & !<-- Ending parent I of its 2-way update region - ,J_2WAY_UPDATE_START & !<-- Starting parent J of its 2-way update region - ,J_2WAY_UPDATE_END & !<-- Ending parent J of its 2-way update region - ,LM !<-- # of model layers (all domains) -! - INTEGER(kind=KINT),INTENT(IN) :: NPTS_UPDATE_HORIZ & !<-- # of parent sfc H,V points updated in the horizontal - ,NPTS_UPDATE_TOTAL & !<-- Total # of words in 2-way 3D update data from child - ,NVARS_2WAY_UPDATE !<-- # of variables updated in 2-way exchange -! - INTEGER(kind=KINT),INTENT(IN) :: IMS,IME,JMS,JME !<-- Parent subdomain memory limits -! - REAL(kind=KFPT),INTENT(IN) :: PDTOP & !<-- Pressure at top of the sigma domain (Pa) - ,PT & !<-- Pressure at the top of the domain (Pa) - ,WGT_CHILD !<-- Weight (0-1) given to child 2-way data in the update -! - REAL(kind=KFPT),DIMENSION(1:NPTS_UPDATE_HORIZ,1:2),INTENT(IN) :: & - CHILD_SFC_ON_PARENT_GRID !<-- Child's FIS(:,1),PD(:,2) interpolated to parent update pts -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: FIS & !<-- Parent's sfc geopotential (m2/s2) - ,PD !<-- Parent's PD (Pa) -! - REAL(kind=KFPT),DIMENSION(1:LM+1),INTENT(IN) :: SG1,SG2 !<-- Interface 'sigma' values in pressure and hybrid regions -! - REAL(kind=KFPT),DIMENSION(1:NPTS_UPDATE_TOTAL),TARGET & - ,INTENT(INOUT):: VAR_2WAY !<-- String of all 2-way update data from child -! - TYPE(ESMF_FieldBundle),INTENT(INOUT) :: BUNDLE_2WAY !<-- Object holding pointes to the 2-way exchange variables -! -!--------------------- -!*** Local variables -!--------------------- -! - INTEGER(kind=KINT) :: I,IPTS,J,JPTS,KNT,KNT_HZ & - ,L,L1,L2,LOC1_2WAY,LOC2_2WAY & - ,N_STRIDE,NL,NPTS_3D,NPTS_HZ & - ,NUM_DIMS,NUM_LEVS_SEC,NUM_LEVS_SPLINE,NV -! - INTEGER(kind=KINT) :: RC,RC_UPD -! - REAL(kind=KFPT) :: COEFF_1,DELP_EXTRAP,FACTOR,PDTOP_PT & - ,PINT_HI_CHILD,PINT_HI_PARENT,PINT_LO & - ,R_DELP,WGT_PARENT -! - REAL(kind=KFPT),DIMENSION(1:LM) :: PMID_PARENT & - ,VBL_OUT -! - REAL(kind=KFPT),DIMENSION(1:LM+1) :: PMID_CHILD & - ,SEC_DERIV -! - REAL(kind=KFPT) :: PMID_CHILD_LM,PMID_CHILD_LM1 & - ,PROD_LM,PROD_LM1,PROD_LM2 & - ,VBL_LM,VBL_LM1 -! - REAL(kind=KFPT),DIMENSION(:),POINTER :: VBL_COL,VBL_X -! - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: VAR_PARENT_2D -! - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: VAR_PARENT_3D & - ,VAR_3D -! - REAL(kind=KFPT),DIMENSION(:,:,:,:),POINTER :: VAR_PARENT_4D -! - LOGICAL(kind=KLOG) :: EXTRAPOLATE -! - CHARACTER(len=99) :: FIELD_NAME -! - TYPE(ESMF_Field) :: HOLD_FIELD -! - TYPE(ESMF_TypeKind_Flag) :: DATATYPE -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** The parent does not incorporate data sent from the child if -!*** this is a parent timestep that immediately follows the writing -!*** of a restart file. This ensures bit-reproducible restarts. -!*** A child sends 2-way data to its parent at the end of parent -!*** timestep N and the parent receives that data early in timestep -!*** N+1. Two-way data is not in the restart files so in a restart -!*** the parent sees no 2-way data coming from its children in the -!*** first timestep. Therefore the parent must not use 2-way data -!*** from the children in any parent timestep that follows the -!*** writing of a restart file. -!----------------------------------------------------------------------- -! - NUM_LEVS_SEC=LM+1 - WGT_PARENT=1.-WGT_CHILD -! -!----------------------------------------------------------------------- -! - IPTS=I_2WAY_UPDATE_END-I_2WAY_UPDATE_START+1 !<-- # of parent points updated in I dimension - JPTS=J_2WAY_UPDATE_END-J_2WAY_UPDATE_START+1 !<-- # of parent points updated in J dimension - NPTS_HZ=IPTS*JPTS !<-- # of parent update points in the horizontal - NPTS_3D=NPTS_HZ*LM !<-- # of parent points updated for each 3D variable -! - KNT=0 !<-- Count words in 2-D string of 2-way exchange variables -! -!----------------------------------------------------------------------- -!*** Loop through all the 2-way exchange variables. -!----------------------------------------------------------------------- -! - vars: DO NV=1,NVARS_2WAY_UPDATE -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Field from the Bundle of 2-way Vbls" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=BUNDLE_2WAY & !<-- Bundle holding the arrays for move updates - ,fieldIndex =NV & !<-- Index of the Field in the Bundle - ,field =HOLD_FIELD & !<-- Field NV in the Bundle - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_UPD) -!----------------------------------------------------------------------- -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Info about this 2-way Variable" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field N_FIELD in the Bundle - ,dimCount=NUM_DIMS & !<-- Is this Field 2-D or 3-D? - ,typeKind=DATATYPE & !<-- Does the Field contain an integer or real array? - ,name =FIELD_NAME & !<-- This variable's name. - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_UPD) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - ndim: IF(NUM_DIMS==2)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Real 2-way 2-D Array from the Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the exchange variable pointer - ,localDe =0 & - ,farrayPtr=VAR_PARENT_2D & !<-- Put the pointer here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_UPD) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DO J=J_2WAY_UPDATE_START,J_2WAY_UPDATE_END - DO I=I_2WAY_UPDATE_START,I_2WAY_UPDATE_END -! - KNT=KNT+1 -! - VAR_PARENT_2D(I,J)=VAR_2WAY(KNT)*WGT_CHILD & !<-- The 2-way data from the child provides the fraction - +VAR_PARENT_2D(I,J)*WGT_PARENT ! WGT_CHILD of the final updated parent value. -! - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -! - ELSEIF(NUM_DIMS>=3)THEN -! -!----------------------------------------------------------------------- -! - IF(NUM_DIMS==3)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Real 2-way 3-D Array from the Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the exchange variable pointer - ,localDe =0 & - ,farrayPtr=VAR_PARENT_3D & !<-- Put the pointer here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_UPD) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - L1=1 - L2=1 -! -!----------------------------------------------------------------------- -! - ELSEIF(NUM_DIMS==4)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Real 2-way 4-D Array from the Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =HOLD_FIELD & !<-- Field that holds the exchange variable pointer - ,localDe =0 & - ,farrayPtr=VAR_PARENT_4D & !<-- Put the pointer here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_UPD) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - L1=LBOUND(VAR_PARENT_4D,4) - L2=UBOUND(VAR_PARENT_4D,4) -! - ENDIF -! -!----------------------------------------------------------------------- -! - nl_loop: DO NL=L1,L2 !<-- Loop through exchange variable's 4th dimension -! if it exists. - KNT_HZ=0 -! - DO J=J_2WAY_UPDATE_START,J_2WAY_UPDATE_END - DO I=I_2WAY_UPDATE_START,I_2WAY_UPDATE_END -! -!----------------------------------------------------------------------- -! - KNT_HZ=KNT_HZ+1 - EXTRAPOLATE=.FALSE. -! -!----------------------------------------------------------------------- -!*** If either the interpolated nest sfc or the parent sfc lies -!*** above sea level then the parent adjusts the child data in -!*** the vertical to account for different topographies. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- - adjust: IF(CHILD_SFC_ON_PARENT_GRID(KNT_HZ,1)>1. & !<-- Child's interpolated sfc is above sea level - .OR. & - FIS(I,J)>1.)THEN !<-- Parent's sfc is above sea level -!----------------------------------------------------------------------- -! - PDTOP_PT=SG1(1)*PDTOP+PT - PINT_HI_CHILD=SG2(1)*CHILD_SFC_ON_PARENT_GRID(KNT_HZ,2)+PDTOP_PT - PINT_HI_PARENT=SG2(1)*PD(I,J)+PDTOP_PT -! - DO L=1,LM - PDTOP_PT=SG1(L+1)*PDTOP+PT - PINT_LO=SG2(L+1)*CHILD_SFC_ON_PARENT_GRID(KNT_HZ,2)+PDTOP_PT - PMID_CHILD(L)=0.5*(PINT_HI_CHILD+PINT_LO) !<-- Midlayer P of 2-way data from child at parent I,J - PINT_HI_CHILD=PINT_LO -! - PINT_LO=SG2(L+1)*PD(I,J)+PDTOP_PT - PMID_PARENT(L)=0.5*(PINT_HI_PARENT+PINT_LO) !<-- Current midlayer pressure at parent I,J - PINT_HI_PARENT=PINT_LO - ENDDO -! - NUM_LEVS_SPLINE=LM -! - DO L=1,NUM_LEVS_SEC - SEC_DERIV(L)=0. !<-- Needed in the SPLINE subroutine - ENDDO -! -!----------------------------------------------------------------------- -!*** If the target parent midlayer pressure level lies below the -!*** lowest child input midlayer (interpolated) pressure then -!*** extrapolate linearly downward in pressure to obtain an -!*** artificial child input value at the lowest parent midlayer -!*** pressure then fill in the remaining 'underground' parent levels -!*** using SPLINE just as is done with all the higher levels. -! -!*** In order to reduce the effects of the ground surface, the lowest -!*** input layer is changed to be the mass-weighted average of the -!*** original two lowest layers while the 2nd lowest input layer is -!*** changed to be the mass-weighted average of the three original -!*** lowest layers. -!----------------------------------------------------------------------- -! - IF(PMID_PARENT(LM)>PMID_CHILD(LM))THEN - EXTRAPOLATE=.TRUE. - NUM_LEVS_SPLINE=LM+1 !<-- Insert 'underground' artificial input level from child -! - PMID_CHILD(LM+1)=PMID_PARENT(LM) !<-- 'Underground' child P is the parent's bottom midlayer P - ALLOCATE(VBL_X(1:LM+1)) !<-- Allocate 2-way data input column with extra bottom layer - ENDIF -! - LOC1_2WAY=(NV-1)*NPTS_3D & !<-- The 1st word of the column of 2-way data in 1-D data - +(J-J_2WAY_UPDATE_START)*IPTS & ! recvd from child for variable NV at parent I,J. - +(I-I_2WAY_UPDATE_START+1) - LOC2_2WAY=LOC1_2WAY+(LM-1)*NPTS_HZ !<-- The last word of parent I,J column in 2-way exchange data. - N_STRIDE=NPTS_HZ !<-- Stride between points in this I,J column. -! - VBL_COL=>VAR_2WAY(LOC1_2WAY:LOC2_2WAY:N_STRIDE) !<-- Pre-adjusted values in this column of the input 2-way data -! - IF(.NOT.EXTRAPOLATE)THEN - VBL_X=>VBL_COL !<-- No extrapolation so no need to copy values -! - ELSEIF(EXTRAPOLATE)THEN - DO L=1,LM-2 - VBL_X(L)=VBL_COL(L) !<-- Copy the genuine values from the input column - ENDDO -! - PROD_LM=VBL_COL(LM)*PMID_CHILD(LM) - PROD_LM1=VBL_COL(LM-1)*PMID_CHILD(LM-1) - PROD_LM2=VBL_COL(LM-2)*PMID_CHILD(LM-2) - VBL_LM=(PROD_LM+PROD_LM1) & - /(PMID_CHILD(LM)+PMID_CHILD(LM-1)) - VBL_LM1=(PROD_LM+PROD_LM1+PROD_LM2) & - /(PMID_CHILD(LM)+PMID_CHILD(LM-1) & - +PMID_CHILD(LM-2)) - VBL_X(LM)=VBL_LM - VBL_X(LM-1)=VBL_LM1 - PMID_CHILD_LM=0.5*(PMID_CHILD(LM-1)+PMID_CHILD(LM)) - PMID_CHILD_LM1=(PMID_CHILD(LM-2)+PMID_CHILD(LM-1) & - +PMID_CHILD(LM))/3. - PMID_CHILD(LM)=PMID_CHILD_LM - PMID_CHILD(LM-1)=PMID_CHILD_LM1 - R_DELP=1./(PMID_CHILD(LM)-PMID_CHILD(LM-1)) - DELP_EXTRAP=PMID_PARENT(LM)-PMID_CHILD(LM) -! - COEFF_1=(VBL_X(LM)-VBL_X(LM-1))*R_DELP - FACTOR=HYPER_A/(DELP_EXTRAP+HYPER_A) - VBL_X(LM+1)=VBL_X(LM) & !<-- Fill in the extra artificial underground value - +COEFF_1*DELP_EXTRAP*FACTOR ! in 2-way input. -! - ENDIF -! - CALL SPLINE(NUM_LEVS_SPLINE & !<-- # of midlayers in column of child input 2-way data - ,PMID_CHILD & !<-- Interpolated input pressures at child's midlayers - ,VBL_X & !<-- Input values of variable in column at parent I,J - ,SEC_DERIV & - ,NUM_LEVS_SEC & - ,LM & !<-- Interpolate to this many parent midlayers - ,PMID_PARENT & !<-- Target output pressures at parent's midlayers - ,VBL_OUT) !<-- Values in the column at I,J adjusted for topo differences -! - DO L=1,LM - VBL_COL(L)=VBL_OUT(L) !<-- Transfer adjusted column values back into 2-way data - ENDDO -! - IF(EXTRAPOLATE)THEN !<-- VBL_X is explicitly allocated only if EXTRAPOLATE is true. - DEALLOCATE(VBL_X) - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF adjust -! -!----------------------------------------------------------------------- -! - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** Now the parent simply updates its values of the exchange -!*** variables at its update points using a weighted average -!*** between its original values and those coming from the child. -!----------------------------------------------------------------------- -! - IF(NUM_DIMS==3)THEN - VAR_3D=>VAR_PARENT_3D - ELSEIF(NUM_DIMS==4)THEN - VAR_3D=>VAR_PARENT_4D(:,:,:,NL) - ENDIF -! - DO L=1,LM - DO J=J_2WAY_UPDATE_START,J_2WAY_UPDATE_END - DO I=I_2WAY_UPDATE_START,I_2WAY_UPDATE_END -! - KNT=KNT+1 -! - VAR_3D(I,J,L)=VAR_2WAY(KNT)*WGT_CHILD & !<-- The 2-way data from the child provides the fraction - +VAR_3D(I,J,L)*WGT_PARENT ! WGT_CHILD of the final updated parent value. -! - ENDDO - ENDDO -! - ENDDO -! -!----------------------------------------------------------------------- -! - ENDDO nl_loop -! -!----------------------------------------------------------------------- -! - ENDIF ndim -! -!----------------------------------------------------------------------- -! - ENDDO vars -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PARENT_2WAY_UPDATE -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE CHILD_DATA_FROM_STRING(LENGTH_DATA & - ,DATASTRING & - ,ILIM_LO,ILIM_HI & - ,JLIM_LO,JLIM_HI & - ,I_START,I_END & - ,J_START,J_END & - ,NVARS_BC_2D_H & - ,NVARS_BC_3D_H & - ,NVARS_BC_4D_H & - ,LBND_4D & - ,UBND_4D & - ,NVARS_BC_2D_V & - ,NVARS_BC_3D_V & - ,PDB & - ,BC_VARS_H & - ,BC_VARS_V ) -! -!----------------------------------------------------------------------- -!*** Extract variables for a nest's boundary from the datastring -!*** received by the child from its parent. A child task might -!*** receive segments of boundary data from two parent tasks in -!*** which case the pieces are be combined. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: LENGTH_DATA & !<-- # of words in datastring - ,I_START & !<-- Starting I of data segment in string on child's grid - ,I_END & !<-- Ending I of data segment in string on child's grid - ,J_START & !<-- Starting J of data segment in string on child's grid - ,J_END & !<-- Ending J of data segment in string on child's grid - ,ILIM_LO & !<-- Lower I limit of full boundary segment - ,ILIM_HI & !<-- Upper I limit of full boundary segment - ,JLIM_LO & !<-- Lower J limit of full boundary segment - ,JLIM_HI !<-- Upper J limit of full boundary segment -! - REAL(kind=KFPT),DIMENSION(:),INTENT(IN) :: DATASTRING !<-- The string of boundary data from the parent -! - INTEGER(kind=KINT),INTENT(IN) :: NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary - ,NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary - ,NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary - ,NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary - ,NVARS_BC_3D_V !<-- # of 3-D V-pt vbls on child boundary -! - INTEGER(kind=KINT),DIMENSION(:),INTENT(IN) :: LBND_4D & !<-- Lower bounds of 4-D variables' 4th dimension - ,UBND_4D !<-- Upper bounds of 4-D variables' 4th dimension -! - REAL(kind=KFPT),DIMENSION(ILIM_LO:ILIM_HI,JLIM_LO:JLIM_HI) & - ,INTENT(OUT),OPTIONAL :: PDB !<-- PD for segment of the child boundary -! - TYPE(BC_H),INTENT(INOUT),OPTIONAL :: BC_VARS_H !<-- Child's 1-D segment of other H-pt vbls on bndry segment -! - TYPE(BC_V),INTENT(INOUT),OPTIONAL :: BC_VARS_V !<-- Child's 1-D segment of V-pt vbls on bndry segment -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: I,J,K,L,LB,N,NV,UB -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Extract the appropriate boundary variables from the datastring -!*** provided by the parent. -!*** Here we transfer from the 1-D string to the 2-D and 3-D arrays. -!*** This easily allows for proper combining of separate strings -!*** whose ends may overlap that are arriving from different parent -!*** tasks. To export these boundary arrays out of the coupler -!*** though the data must be put back into 1-D. -! -!*** The 2-D pressure array PD is always the first variable in the -!*** datastring from the parent. -!----------------------------------------------------------------------- -! - N=0 -! - IF(PRESENT(BC_VARS_H))THEN !<-- Parent datastring for H-pt variables has been sent in -! - DO J=J_START,J_END - DO I=I_START,I_END - N=N+1 - PDB(I,J)=DATASTRING(N) !<-- The 2-D PD array is handled separately - ENDDO - ENDDO -! - IF(NVARS_BC_2D_H>1)THEN !<-- Loop through remaining 2-D H-pt boundary variables - DO NV=1,NVARS_BC_2D_H-1 - DO J=J_START,J_END - DO I=I_START,I_END - N=N+1 - BC_VARS_H%VAR_2D(NV)%SIDE(I,J)=DATASTRING(N) - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_H>0)THEN !<-- Loop through 3-D H-pt boundary variables - DO NV=1,NVARS_BC_3D_H - DO K=1,LM - DO J=J_START,J_END - DO I=I_START,I_END - N=N+1 - BC_VARS_H%VAR_3D(NV)%SIDE(I,J,K)=DATASTRING(N) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_4D_H>0)THEN !<-- Loop through 3-D H-pt boundary variables - DO NV=1,NVARS_BC_4D_H - LB=LBND_4D(NV) - UB=UBND_4D(NV) - DO L=LB,UB - DO K=1,LM - DO J=J_START,J_END - DO I=I_START,I_END - N=N+1 - BC_VARS_H%VAR_4D(NV)%SIDE(I,J,K,L)=DATASTRING(N) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - ELSEIF(PRESENT(BC_VARS_V))THEN !<-- Parent datastring for V-pt variables has been sent in -! - IF(NVARS_BC_2D_V>1)THEN !<-- Loop through 2-D V-pt boundary variables - DO NV=1,NVARS_BC_2D_V - DO J=J_START,J_END - DO I=I_START,I_END - N=N+1 - BC_VARS_V%VAR_2D(NV)%SIDE(I,J)=DATASTRING(N) - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_V>1)THEN !<-- Loop through all the 3-D V-pt boundary variables - DO NV=1,NVARS_BC_3D_V - DO K=1,LM - DO J=J_START,J_END - DO I=I_START,I_END - N=N+1 - BC_VARS_V%VAR_3D(NV)%SIDE(I,J,K)=DATASTRING(N) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE CHILD_DATA_FROM_STRING -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE EXPORT_CHILD_BOUNDARY(NVARS_BC_2D_H & - ,NVARS_BC_3D_H & - ,NVARS_BC_4D_H & - ,LBND_4D & - ,UBND_4D & - ,NVARS_BC_2D_V & - ,NVARS_BC_3D_V & - ,PDB & - ,BC_VARS_H & - ,BC_VARS_V & -! - ,ILIM_LO,ILIM_HI & - ,JLIM_LO,JLIM_HI & -! - ,DATA_NAME & -! - ,DATA_EXP & -! - ,EXPORT_STATE ) -! -!----------------------------------------------------------------------- -!*** Load the child boundary values received from the parent -!*** into the Parent-Child coupler export state. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: NVARS_BC_2D_H & !<-- # of 2-D H-pt vbls on child boundary - ,NVARS_BC_3D_H & !<-- # of 3-D H-pt vbls on child boundary - ,NVARS_BC_4D_H & !<-- # of 4-D H-pt vbls on child boundary - ,NVARS_BC_2D_V & !<-- # of 2-D V-pt vbls on child boundary - ,NVARS_BC_3D_V !<-- # of 3-D V-pt vbls on child boundary -! - INTEGER(kind=KINT),INTENT(IN) :: ILIM_LO & !<-- Lower I limit of full boundary segment - ,ILIM_HI & !<-- Upper I limit of full boundary segment - ,JLIM_LO & !<-- Lower J limit of full boundary segment - ,JLIM_HI !<-- Upper J limit of full boundary segment -! - INTEGER(kind=KINT),DIMENSION(:),INTENT(IN) :: LBND_4D & !<-- Lower bound of 4-D variables' 4th dimension - ,UBND_4D !<-- Upper bound of 4-D variables' 4th dimension -! - REAL(kind=KFPT),DIMENSION(ILIM_LO:ILIM_HI,JLIM_LO:JLIM_HI) & - ,INTENT(IN),OPTIONAL :: PDB !<-- PD for segment of the child boundary -! - TYPE(BC_H),INTENT(IN),OPTIONAL :: BC_VARS_H !<-- Child's 1-D segment of other H-pt vbls on bndry segment -! - TYPE(BC_V),INTENT(IN),OPTIONAL :: BC_VARS_V !<-- Child's 1-D segment of V-pt vbls on bndry segment -! - CHARACTER(*),INTENT(IN) :: DATA_NAME !<-- Name used for each child task's boundary segment -! - REAL(kind=KFPT),DIMENSION(:),POINTER,INTENT(INOUT) :: DATA_EXP !<-- Combined boundary segment data on child task -! - TYPE(ESMF_State),INTENT(INOUT) :: EXPORT_STATE !<-- The Parent-Child Coupler export state -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: I,J,K,L,LB,NV,UB & - ,ISTAT,RC,RC_EXP_BNDRY -! - INTEGER(kind=KINT),SAVE :: NN -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RC_EXP_BNDRY=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** The children's final boundary data will be loaded into the -!*** Parent-Child Coupler's export state as 1-D arrays (Attributes) -!*** since they are not spanning the childrens' ESMF Grids (as Fields). -!*** But because they are Attributes and not Fields, they will need -!*** to be reset every time. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- - main: IF(PRESENT(BC_VARS_H))THEN !<-- If true then H-point variables were sent in -!----------------------------------------------------------------------- -! - NN=0 !<-- The data always begins with H points -! - DO J=JLIM_LO,JLIM_HI - DO I=ILIM_LO,ILIM_HI - NN=NN+1 - DATA_EXP(NN)=PDB(I,J) !<-- First insert complete PDB into the 1-D H boundary data - ENDDO - ENDDO -! -! - IF(NVARS_BC_2D_H>1)THEN - DO NV=1,NVARS_BC_2D_H-1 - DO J=JLIM_LO,JLIM_HI - DO I=ILIM_LO,ILIM_HI - NN=NN+1 - DATA_EXP(NN)=BC_VARS_H%VAR_2D(NV)%SIDE(I,J) !<-- Insert 2-D H-pt BC vbls into the 1-D H boundary data - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - DO K=1,LM - DO J=JLIM_LO,JLIM_HI - DO I=ILIM_LO,ILIM_HI - NN=NN+1 - DATA_EXP(NN)=BC_VARS_H%VAR_3D(NV)%SIDE(I,J,K) !<-- Insert 3-D H-pt BC vbls into the 1-D H boundary data - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - LB=LBND_4D(NV) - UB=UBND_4D(NV) - DO L=LB,UB - DO K=1,LM - DO J=JLIM_LO,JLIM_HI - DO I=ILIM_LO,ILIM_HI - NN=NN+1 - DATA_EXP(NN)=BC_VARS_H%VAR_4D(NV)%SIDE(I,J,K,L) !<-- Insert 4-D H-pt BC vbls into the 1-D H boundary data - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry Data "//DATA_NAME//" Into Coupler Export" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state =EXPORT_STATE & !<-- This Parent_child Coupler export state - ,name =DATA_NAME & !<-- Name of the children's new boundary H data - ,itemCount=NN & !<-- # of words in the data - ,valueList=DATA_EXP & !<-- The children's new boundary H data - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_EXP_BNDRY) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - ELSEIF(PRESENT(BC_VARS_V))THEN !<-- If true then V-point variables were sent in -! -!----------------------------------------------------------------------- -! - NN=0 -! - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - DO J=JLIM_LO,JLIM_HI - DO I=ILIM_LO,ILIM_HI - NN=NN+1 - DATA_EXP(NN)=BC_VARS_V%VAR_2D(NV)%SIDE(I,J) !<-- Insert 2-D V-pt BC vbls into the 1-D V boundary data - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - DO K=1,LM - DO J=JLIM_LO,JLIM_HI - DO I=ILIM_LO,ILIM_HI - NN=NN+1 - DATA_EXP(NN)=BC_VARS_V%VAR_3D(NV)%SIDE(I,J,K) !<-- Insert 3-D V-pt BC vbls into the 1-D V boundary data - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Load Child Bndry Data "//DATA_NAME//" Into Coupler Export" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state =EXPORT_STATE & !<-- This Parent_child Coupler export state - ,name =DATA_NAME & !<-- Name of the children's new boundary V data - ,itemCount=NN & !<-- # of words in the data - ,valueList=DATA_EXP & !<-- The children's new boundary V data - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_EXP_BNDRY) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - ENDIF main -! -!----------------------------------------------------------------------- -! - END SUBROUTINE EXPORT_CHILD_BOUNDARY -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE DEALLOC_WORK_PARENTS(N,TIME_FLAG) -! -!----------------------------------------------------------------------- -!*** Parents deallocate all working pointers that needed to be -!*** allocated with unique dimensions at the outset of the forecast -!*** and again each time a nest moves. Those allocations took place -!*** in subroutine POINT_INTERP_DATA_TO_MEMORY. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: N !<-- Which child of this parent -! - CHARACTER(*),INTENT(IN) :: TIME_FLAG !<-- Current or future boundary data for children? -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: IERR,INDX2,ISTAT,NCHILD_TASKS,NMAX,NT,NV -! - INTEGER(kind=KINT),DIMENSION(MPI_STATUS_SIZE) :: JSTAT -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Select the appropriate part of the working array depending on -!*** whether we are now concerned with children's boundaries for -!*** their current time or for their future. -!----------------------------------------------------------------------- -! - IF(TIME_FLAG=='Future')THEN - INDX2=1 - ELSEIF(TIME_FLAG=='Current')THEN - INDX2=2 - ENDIF -! -!----------------------------------------------------------------------- -!*** The parent must not deallocate the actual BC update buffers -!*** until it knows that they have been Recvd by the children. -!*** That is the reason for the Waits below. -!----------------------------------------------------------------------- -! -!----------- -!*** South -!----------- -! - NMAX=UBOUND(HANDLE_H_SOUTH(N,INDX2)%NTASKS_TO_RECV,1) - IF(NMAX>0)THEN - DO NT=1,NMAX - CALL MPI_WAIT(HANDLE_H_SOUTH(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend from parent task to child N's task NT - ,JSTAT & !<-- MPI status - ,IERR ) - ENDDO - ENDIF -! - south_h: IF(ASSOCIATED(CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS))THEN -! - NCHILD_TASKS=UBOUND(CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS,1) !<-- # of Sbndry tasks on child N that recvd H point data -! - DO NT=1,NCHILD_TASKS - IF(ASSOCIATED(CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS(NT)%DATA))THEN - DEALLOCATE(CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS(NT)%DATA) - ENDIF - ENDDO -! - DEALLOCATE(CHILD_BOUND_H_SOUTH(N,INDX2)%TASKS,stat=ISTAT) -! - IF(ASSOCIATED(HANDLE_H_SOUTH(N,INDX2)%NTASKS_TO_RECV))THEN - DEALLOCATE(HANDLE_H_SOUTH(N,INDX2)%NTASKS_TO_RECV) - ENDIF -! - ENDIF south_h -! - NCHILD_TASKS=UBOUND(PD_B_SOUTH(N)%TASKS,1) !<-- # of Sbndry tasks on child N that recvd H point data - DO NT=1,NCHILD_TASKS - IF(ASSOCIATED(PD_B_SOUTH(N)%TASKS(NT)%DATA))THEN - DEALLOCATE(PD_B_SOUTH(N)%TASKS(NT)%DATA) - ENDIF - DEALLOCATE(FIS_CHILD_SOUTH(N)%TASKS(NT)%DATA) - ENDDO -! - DEALLOCATE(PD_B_SOUTH(N)%TASKS) -! - DO NV=1,NVARS_NESTBC_H-1 - DEALLOCATE(BND_VAR_H_SOUTH(NV)%CHILD(N)%TASKS,stat=ISTAT) - IF(ISTAT>0)THEN - WRITE(0,11011)NV,N,ISTAT -11011 FORMAT(' DEALLOC_WORK_PARENTS failed to deallocate' & - ,' BND_VAR_H_SOUTH(',I2,')%CHILD(',I2,')%TASKS' & - ,' ISTAT=',I4) - ENDIF - ENDDO -! - DEALLOCATE(FIS_CHILD_SOUTH(N)%TASKS) - DEALLOCATE(WORDS_BOUND_H_SOUTH(N)%TASKS) -! - NMAX=UBOUND(HANDLE_V_SOUTH(N,INDX2)%NTASKS_TO_RECV,1) - IF(NMAX>0)THEN - DO NT=1,NMAX - CALL MPI_WAIT(HANDLE_V_SOUTH(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend from parent task to child N's task NT - ,JSTAT & !<-- MPI status - ,IERR ) - ENDDO - ENDIF -! - south_v: IF(ASSOCIATED(CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS))THEN -! - NCHILD_TASKS=UBOUND(CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS,1) !<-- # of Sbndry tasks on child N that recvd V point data -! - DO NT=1,NCHILD_TASKS - IF(ASSOCIATED(CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS(NT)%DATA))THEN - DEALLOCATE(CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS(NT)%DATA) - ENDIF - ENDDO -! - DEALLOCATE(CHILD_BOUND_V_SOUTH(N,INDX2)%TASKS) -! - IF(ASSOCIATED(HANDLE_V_SOUTH(N,INDX2)%NTASKS_TO_RECV))THEN - DEALLOCATE(HANDLE_V_SOUTH(N,INDX2)%NTASKS_TO_RECV) - ENDIF -! - ENDIF south_v -! - NCHILD_TASKS=UBOUND(PD_B_SOUTH_V(N)%TASKS,1) !<-- # of Sbndry tasks on child N that recvd V point data - DO NT=1,NCHILD_TASKS - IF(ASSOCIATED(PD_B_SOUTH_V(N)%TASKS(NT)%DATA))THEN - DEALLOCATE(PD_B_SOUTH_V(N)%TASKS(NT)%DATA) - ENDIF - ENDDO -! - DEALLOCATE(WORDS_BOUND_V_SOUTH(N)%TASKS) - DEALLOCATE(PD_B_SOUTH_V(N)%TASKS) -! - DO NV=1,NVARS_NESTBC_V - DEALLOCATE(BND_VAR_V_SOUTH(NV)%CHILD(N)%TASKS) - ENDDO -! -!----------------------------------------------------------------------- -! -!----------- -!*** North -!----------- -! - NMAX=UBOUND(HANDLE_H_NORTH(N,INDX2)%NTASKS_TO_RECV,1) - IF(NMAX>0)THEN - DO NT=1,NMAX - CALL MPI_WAIT(HANDLE_H_NORTH(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend from parent task to child N's task NT - ,JSTAT & !<-- MPI status - ,IERR ) - ENDDO - ENDIF -! - north_h: IF(ASSOCIATED(CHILD_BOUND_H_NORTH(N,INDX2)%TASKS))THEN -! - NCHILD_TASKS=UBOUND(CHILD_BOUND_H_NORTH(N,INDX2)%TASKS,1) !<-- # of Nbndry tasks on child N that recvd H point data -! - DO NT=1,NCHILD_TASKS - IF(ASSOCIATED(CHILD_BOUND_H_NORTH(N,INDX2)%TASKS(NT)%DATA))THEN - DEALLOCATE(CHILD_BOUND_H_NORTH(N,INDX2)%TASKS(NT)%DATA,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' DEALLOC_WORK_PARENTS N=',N,' NT=',NT,' INDX2=',INDX2 & - ,' Failed to deallocate CHILD_BOUND_H_NORTH(N,INDX2)%TASKS(NT)%DATA' - ELSE -! WRITE(0,*)' DEALLOC_WORK_PARENTS N=',N,' NT=',NT,' INDX2=',INDX2 & -! ,' Succeeded in deallocating CHILD_BOUND_H_NORTH(N,INDX2)%TASKS(NT)%DATA' - ENDIF - ENDIF - ENDDO -! - DEALLOCATE(CHILD_BOUND_H_NORTH(N,INDX2)%TASKS) -! - IF(ASSOCIATED(HANDLE_H_NORTH(N,INDX2)%NTASKS_TO_RECV))THEN - DEALLOCATE(HANDLE_H_NORTH(N,INDX2)%NTASKS_TO_RECV) - ENDIF -! - ENDIF north_h -! - NCHILD_TASKS=UBOUND(PD_B_NORTH(N)%TASKS,1) !<-- # of Nbndry tasks on child N that recvd H point data -! - DO NT=1,NCHILD_TASKS - IF(ASSOCIATED(PD_B_NORTH(N)%TASKS(NT)%DATA))THEN - DEALLOCATE(PD_B_NORTH(N)%TASKS(NT)%DATA,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' DEALLOC_WORK_PARENTS N=',N,' NT=',NT,' INDX2=',INDX2 & - ,' Failed to deallocate PD_B_NORTH(N)%TASKS(NT)%DATA' - ELSE -! WRITE(0,*)' DEALLOC_WORK_PARENTS N=',N,' NT=',NT,' INDX2=',INDX2 & -! ,' Succeeded in deallocating PD_B_NORTH(N)%TASKS(NT)%DATA' - ENDIF - ENDIF - DEALLOCATE(FIS_CHILD_NORTH(N)%TASKS(NT)%DATA) - ENDDO -! - DEALLOCATE(PD_B_NORTH(N)%TASKS) -! - DO NV=1,NVARS_NESTBC_H-1 - DEALLOCATE(BND_VAR_H_NORTH(NV)%CHILD(N)%TASKS) - ENDDO -! - DEALLOCATE(FIS_CHILD_NORTH(N)%TASKS) - DEALLOCATE(WORDS_BOUND_H_NORTH(N)%TASKS) -! - NMAX=UBOUND(HANDLE_V_NORTH(N,INDX2)%NTASKS_TO_RECV,1) - IF(NMAX>0)THEN - DO NT=1,NMAX - CALL MPI_WAIT(HANDLE_V_NORTH(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend from parent task to child N's task NT - ,JSTAT & !<-- MPI status - ,IERR ) - ENDDO - ENDIF -! - north_v: IF(ASSOCIATED(CHILD_BOUND_V_NORTH(N,INDX2)%TASKS))THEN -! - NCHILD_TASKS=UBOUND(CHILD_BOUND_V_NORTH(N,INDX2)%TASKS,1) !<-- # of Nbndry tasks on child N that recvd V point data - DO NT=1,NCHILD_TASKS - IF(ASSOCIATED(CHILD_BOUND_V_NORTH(N,INDX2)%TASKS(NT)%DATA))THEN - DEALLOCATE(CHILD_BOUND_V_NORTH(N,INDX2)%TASKS(NT)%DATA & - ,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' DEALLOC_WORK_PARENTS N=',N,' NT=',NT,' INDX2=',INDX2 & - ,' Failed to deallocate CHILD_BOUND_V_NORTH(N,INDX2)%TASKS(NT)%DATA' - ELSE -! WRITE(0,*)' DEALLOC_WORK_PARENTS N=',N,' NT=',NT,' INDX2=',INDX2 & -! ,' Succeeded in deallocating CHILD_BOUND_V_NORTH(N,INDX2)%TASKS(NT)%DATA' - ENDIF - ENDIF - ENDDO -! - DEALLOCATE(CHILD_BOUND_V_NORTH(N,INDX2)%TASKS) -! - IF(ASSOCIATED(HANDLE_V_NORTH(N,INDX2)%NTASKS_TO_RECV))THEN - DEALLOCATE(HANDLE_V_NORTH(N,INDX2)%NTASKS_TO_RECV) - ENDIF -! - ENDIF north_v -! - NCHILD_TASKS=UBOUND(PD_B_NORTH_V(N)%TASKS,1) !<-- # of Nbndry tasks on child N that recvd V point data - DO NT=1,NCHILD_TASKS - IF(ASSOCIATED(PD_B_NORTH_V(N)%TASKS(NT)%DATA))THEN - DEALLOCATE(PD_B_NORTH_V(N)%TASKS(NT)%DATA,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' DEALLOC_WORK_PARENTS N=',N,' NT=',NT,' INDX2=',INDX2 & - ,' Failed to deallocate PD_B_NORTH_V(N)%TASKS(NT)%DATA' - ELSE -! WRITE(0,*)' DEALLOC_WORK_PARENTS N=',N,' NT=',NT,' INDX2=',INDX2 & -! ,' Succeeded in deallocating PD_B_NORTH_V(N)%TASKS(NT)%DATA' - ENDIF - ENDIF - ENDDO -! - DEALLOCATE(WORDS_BOUND_V_NORTH(N)%TASKS) - DEALLOCATE(PD_B_NORTH_V(N)%TASKS) -! - DO NV=1,NVARS_NESTBC_V - DEALLOCATE(BND_VAR_V_NORTH(NV)%CHILD(N)%TASKS) - ENDDO -! -!----------------------------------------------------------------------- -! -!---------- -!*** West -!---------- -! - NMAX=UBOUND(HANDLE_H_WEST(N,INDX2)%NTASKS_TO_RECV,1) - IF(NMAX>0)THEN - DO NT=1,NMAX - CALL MPI_WAIT(HANDLE_H_WEST(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend from parent task to child N's task NT - ,JSTAT & !<-- MPI status - ,IERR ) - ENDDO - ENDIF -! - west_h: IF(ASSOCIATED(CHILD_BOUND_H_WEST(N,INDX2)%TASKS))THEN -! - NCHILD_TASKS=UBOUND(CHILD_BOUND_H_WEST(N,INDX2)%TASKS,1) !<-- # of Wbndry tasks on child N that recvd H point data - DO NT=1,NCHILD_TASKS - IF(ASSOCIATED(CHILD_BOUND_H_WEST(N,INDX2)%TASKS(NT)%DATA))THEN - DEALLOCATE(CHILD_BOUND_H_WEST(N,INDX2)%TASKS(NT)%DATA) - ENDIF - ENDDO -! - DEALLOCATE(CHILD_BOUND_H_WEST(N,INDX2)%TASKS) -! - IF(ASSOCIATED(HANDLE_H_WEST(N,INDX2)%NTASKS_TO_RECV))THEN - DEALLOCATE(HANDLE_H_WEST(N,INDX2)%NTASKS_TO_RECV) - ENDIF -! - ENDIF west_h -! - NCHILD_TASKS=UBOUND(PD_B_WEST(N)%TASKS,1) !<-- # of Wbndry tasks on child N that recvd H point data - DO NT=1,NCHILD_TASKS - IF(ASSOCIATED(PD_B_WEST(N)%TASKS(NT)%DATA))THEN - DEALLOCATE(PD_B_WEST(N)%TASKS(NT)%DATA) - ENDIF - DEALLOCATE(FIS_CHILD_WEST(N)%TASKS(NT)%DATA) - ENDDO -! - DEALLOCATE(PD_B_WEST(N)%TASKS) -! - DO NV=1,NVARS_NESTBC_H-1 - DEALLOCATE(BND_VAR_H_WEST(NV)%CHILD(N)%TASKS) - ENDDO -! - DEALLOCATE(FIS_CHILD_WEST(N)%TASKS) - DEALLOCATE(WORDS_BOUND_H_WEST(N)%TASKS) -! - NMAX=UBOUND(HANDLE_V_WEST(N,INDX2)%NTASKS_TO_RECV,1) - IF(NMAX>0)THEN - DO NT=1,NMAX - CALL MPI_WAIT(HANDLE_V_WEST(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend from parent task to child N's task NT - ,JSTAT & !<-- MPI status - ,IERR ) - ENDDO - ENDIF -! - west_v: IF(ASSOCIATED(CHILD_BOUND_V_WEST(N,INDX2)%TASKS))THEN -! - NCHILD_TASKS=UBOUND(CHILD_BOUND_V_WEST(N,INDX2)%TASKS,1) !<-- # of Wbndry tasks on child N that recvd V point data -! - DO NT=1,NCHILD_TASKS - IF(ASSOCIATED(CHILD_BOUND_V_WEST(N,INDX2)%TASKS(NT)%DATA))THEN - DEALLOCATE(CHILD_BOUND_V_WEST(N,INDX2)%TASKS(NT)%DATA) - ENDIF - ENDDO -! - DEALLOCATE(CHILD_BOUND_V_WEST(N,INDX2)%TASKS) -! - IF(ASSOCIATED(HANDLE_V_WEST(N,INDX2)%NTASKS_TO_RECV))THEN - DEALLOCATE(HANDLE_V_WEST(N,INDX2)%NTASKS_TO_RECV) - ENDIF -! - ENDIF west_v -! - NCHILD_TASKS=UBOUND(PD_B_WEST_V(N)%TASKS,1) !<-- # of Wbndry tasks on child N that recvd V point data - DO NT=1,NCHILD_TASKS - IF(ASSOCIATED(PD_B_WEST_V(N)%TASKS(NT)%DATA))THEN - DEALLOCATE(PD_B_WEST_V(N)%TASKS(NT)%DATA) - ENDIF - ENDDO -! - DEALLOCATE(WORDS_BOUND_V_WEST(N)%TASKS) - DEALLOCATE(PD_B_WEST_V(N)%TASKS) -! - DO NV=1,NVARS_NESTBC_V - DEALLOCATE(BND_VAR_V_WEST(NV)%CHILD(N)%TASKS) - ENDDO -! -!----------------------------------------------------------------------- -! -!---------- -!*** East -!---------- -! - NMAX=UBOUND(HANDLE_H_EAST(N,INDX2)%NTASKS_TO_RECV,1) - IF(NMAX>0)THEN - DO NT=1,NMAX - CALL MPI_WAIT(HANDLE_H_EAST(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend from parent task to child N's task NT - ,JSTAT & !<-- MPI status - ,IERR ) - ENDDO - ENDIF -! - east_h: IF(ASSOCIATED(CHILD_BOUND_H_EAST(N,INDX2)%TASKS))THEN -! - NCHILD_TASKS=UBOUND(CHILD_BOUND_H_EAST(N,INDX2)%TASKS,1) !<-- # of Ebndry tasks on child N that recvd H point data -! - DO NT=1,NCHILD_TASKS - IF(ASSOCIATED(CHILD_BOUND_H_EAST(N,INDX2)%TASKS(NT)%DATA))THEN - DEALLOCATE(CHILD_BOUND_H_EAST(N,INDX2)%TASKS(NT)%DATA) - ENDIF - ENDDO -! - DEALLOCATE(CHILD_BOUND_H_EAST(N,INDX2)%TASKS) -! - IF(ASSOCIATED(HANDLE_H_EAST(N,INDX2)%NTASKS_TO_RECV))THEN - DEALLOCATE(HANDLE_H_EAST(N,INDX2)%NTASKS_TO_RECV) - ENDIF -! - ENDIF east_h -! - NCHILD_TASKS=UBOUND(PD_B_EAST(N)%TASKS,1) !<-- # of Ebndry tasks on child N that recvd H point data - DO NT=1,NCHILD_TASKS - IF(ASSOCIATED(PD_B_EAST(N)%TASKS(NT)%DATA))THEN - DEALLOCATE(PD_B_EAST(N)%TASKS(NT)%DATA) - ENDIF - DEALLOCATE(FIS_CHILD_EAST(N)%TASKS(NT)%DATA) - ENDDO -! - DEALLOCATE(PD_B_EAST(N)%TASKS) -! - DO NV=1,NVARS_NESTBC_H-1 - DEALLOCATE(BND_VAR_H_EAST(NV)%CHILD(N)%TASKS) - ENDDO -! - DEALLOCATE(FIS_CHILD_EAST(N)%TASKS) - DEALLOCATE(WORDS_BOUND_H_EAST(N)%TASKS) -! - NMAX=UBOUND(HANDLE_V_EAST(N,INDX2)%NTASKS_TO_RECV,1) - IF(NMAX>0)THEN - DO NT=1,NMAX - CALL MPI_WAIT(HANDLE_V_EAST(N,INDX2)%NTASKS_TO_RECV(NT) & !<-- Handle for ISend from parent task to child N's task NT - ,JSTAT & !<-- MPI status - ,IERR ) - ENDDO - ENDIF -! - east_v: IF(ASSOCIATED(CHILD_BOUND_V_EAST(N,INDX2)%TASKS))THEN -! - NCHILD_TASKS=UBOUND(CHILD_BOUND_V_EAST(N,INDX2)%TASKS,1) !<-- # of Ebndry tasks on child N that recvd V point data -! - DO NT=1,NCHILD_TASKS - IF(ASSOCIATED(CHILD_BOUND_V_EAST(N,INDX2)%TASKS(NT)%DATA))THEN - DEALLOCATE(CHILD_BOUND_V_EAST(N,INDX2)%TASKS(NT)%DATA) - ENDIF - ENDDO -! - DEALLOCATE(CHILD_BOUND_V_EAST(N,INDX2)%TASKS) -! - IF(ASSOCIATED(HANDLE_V_EAST(N,INDX2)%NTASKS_TO_RECV))THEN - DEALLOCATE(HANDLE_V_EAST(N,INDX2)%NTASKS_TO_RECV) - ENDIF -! - ENDIF east_v -! - NCHILD_TASKS=UBOUND(PD_B_EAST_V(N)%TASKS,1) !<-- # of Ebndry tasks on child N that recvd V point data - DO NT=1,NCHILD_TASKS - IF(ASSOCIATED(PD_B_EAST_V(N)%TASKS(NT)%DATA))THEN - DEALLOCATE(PD_B_EAST_V(N)%TASKS(NT)%DATA) - ENDIF - ENDDO -! - DEALLOCATE(WORDS_BOUND_V_EAST(N)%TASKS) - DEALLOCATE(PD_B_EAST_V(N)%TASKS) -! - DO NV=1,NVARS_NESTBC_V - DEALLOCATE(BND_VAR_V_EAST(NV)%CHILD(N)%TASKS) - ENDDO -! -!----------------------------------------------------------------------- -! - END SUBROUTINE DEALLOC_WORK_PARENTS -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE DEALLOC_WORK_CHILDREN(MY_DOMAIN_ID) -! -!----------------------------------------------------------------------- -!*** Children deallocate all working pointers that need to be allocated -!*** with unique dimensions at the outset of the forecast and again -!*** each time a nest moves. These allocations took place in -!*** subroutine CHILD_RECVS_CHILD_DATA_LIMITS. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: MY_DOMAIN_ID !<-- The current domain's ID -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: ID_DOM,LIM_HI,N,NV -! - TYPE(COMPOSITE),POINTER :: CC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - CALL POINT_TO_COMPOSITE(MY_DOMAIN_ID) -! - CC=>CPL_COMPOSITE(MY_DOMAIN_ID) -! - ID_DOM=ID_PARENTS(MY_DOMAIN_ID) !<-- Domain ID of this child's parent - LIM_HI=FTASKS_DOMAIN(ID_DOM) !<-- # of fcst tasks on this nest's parent domain -! - DO N=1,LIM_HI - IF(ALLOCATED(PARENT_TASK(N)%SOUTH_H%STRING))THEN - DEALLOCATE(PARENT_TASK(N)%SOUTH_H%STRING) !<-- Sboundary H datastring from parent 'N' - ENDIF - IF(ALLOCATED(PARENT_TASK(N)%SOUTH_V%STRING))THEN - DEALLOCATE(PARENT_TASK(N)%SOUTH_V%STRING) !<-- Sboundary V datastring from parent 'N' - ENDIF -! - IF(ALLOCATED(PARENT_TASK(N)%NORTH_H%STRING))THEN - DEALLOCATE(PARENT_TASK(N)%NORTH_H%STRING) !<-- Nboundary H datastring from parent 'N' - ENDIF - IF(ALLOCATED(PARENT_TASK(N)%NORTH_V%STRING))THEN - DEALLOCATE(PARENT_TASK(N)%NORTH_V%STRING) !<-- Nboundary V datastring from parent 'N' - ENDIF -! - IF(ALLOCATED(PARENT_TASK(N)%WEST_H%STRING))THEN - DEALLOCATE(PARENT_TASK(N)%WEST_H%STRING) !<-- Wboundary H datastring from parent 'N' - ENDIF - IF(ALLOCATED(PARENT_TASK(N)%WEST_V%STRING))THEN - DEALLOCATE(PARENT_TASK(N)%WEST_V%STRING) !<-- Wboundary V datastring from parent 'N' - ENDIF -! - IF(ALLOCATED(PARENT_TASK(N)%EAST_H%STRING))THEN - DEALLOCATE(PARENT_TASK(N)%EAST_H%STRING) !<-- Eboundary H datastring from parent 'N' - ENDIF - IF(ALLOCATED(PARENT_TASK(N)%EAST_V%STRING))THEN - DEALLOCATE(PARENT_TASK(N)%EAST_V%STRING) !<-- Eboundary V datastring from parent 'N' - ENDIF -! - ENDDO -! - IF(NUM_PARENT_TASKS_SENDING_H%SOUTH>0)THEN !<-- Did this child task recv Sboundary H data from parent? - IF(NVARS_BC_2D_H>0)THEN - DO NV=1,NVARS_BC_2D_H-1 - DEALLOCATE(MY_BC_VARS_H_S%VAR_2D(NV)%SIDE) - ENDDO - ENDIF - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - DEALLOCATE(MY_BC_VARS_H_S%VAR_3D(NV)%SIDE) - ENDDO - ENDIF - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - DEALLOCATE(MY_BC_VARS_H_S%VAR_4D(NV)%SIDE) - ENDDO - ENDIF - DEALLOCATE(cc%PDB_S) - DEALLOCATE(cc%BOUND_1D_SOUTH_H) - ENDIF -! - IF(NUM_PARENT_TASKS_SENDING_V%SOUTH>0)THEN !<-- Did this child task recv Sboundary V data from parent? - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - DEALLOCATE(MY_BC_VARS_V_S%VAR_2D(NV)%SIDE) - ENDDO - ENDIF - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - DEALLOCATE(MY_BC_VARS_V_S%VAR_3D(NV)%SIDE) - ENDDO - ENDIF - DEALLOCATE(cc%BOUND_1D_SOUTH_V) - ENDIF -! - IF(NUM_PARENT_TASKS_SENDING_H%NORTH>0)THEN !<-- Did this child task recv Nboundary H data from parent? - IF(NVARS_BC_2D_H>0)THEN - DO NV=1,NVARS_BC_2D_H-1 - DEALLOCATE(MY_BC_VARS_H_N%VAR_2D(NV)%SIDE) - ENDDO - ENDIF - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - DEALLOCATE(MY_BC_VARS_H_N%VAR_3D(NV)%SIDE) - ENDDO - ENDIF - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - DEALLOCATE(MY_BC_VARS_H_N%VAR_4D(NV)%SIDE) - ENDDO - ENDIF - DEALLOCATE(cc%BOUND_1D_NORTH_H) - DEALLOCATE(cc%PDB_N) - ENDIF -! - IF(NUM_PARENT_TASKS_SENDING_V%NORTH>0)THEN !<-- Did this child task recv Nboundary V data from parent? - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - DEALLOCATE(MY_BC_VARS_V_N%VAR_2D(NV)%SIDE) - ENDDO - ENDIF - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - DEALLOCATE(MY_BC_VARS_V_N%VAR_3D(NV)%SIDE) - ENDDO - ENDIF - DEALLOCATE(cc%BOUND_1D_NORTH_V) - ENDIF -! - IF(NUM_PARENT_TASKS_SENDING_H%WEST>0)THEN !<-- Did this child task recv Wboundary H data from parent? - IF(NVARS_BC_2D_H>0)THEN - DO NV=1,NVARS_BC_2D_H-1 - DEALLOCATE(MY_BC_VARS_H_W%VAR_2D(NV)%SIDE) - ENDDO - ENDIF - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - DEALLOCATE(MY_BC_VARS_H_W%VAR_3D(NV)%SIDE) - ENDDO - ENDIF - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - DEALLOCATE(MY_BC_VARS_H_W%VAR_4D(NV)%SIDE) - ENDDO - ENDIF - DEALLOCATE(cc%PDB_W) - DEALLOCATE(cc%BOUND_1D_WEST_H) - ENDIF -! - IF(NUM_PARENT_TASKS_SENDING_V%WEST>0)THEN !<-- Did this child task recv Wboundary V data from parent? - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - DEALLOCATE(MY_BC_VARS_V_W%VAR_2D(NV)%SIDE) - ENDDO - ENDIF - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - DEALLOCATE(MY_BC_VARS_V_W%VAR_3D(NV)%SIDE) - ENDDO - ENDIF - DEALLOCATE(cc%BOUND_1D_WEST_V) - ENDIF -! - IF(NUM_PARENT_TASKS_SENDING_H%EAST>0)THEN !<-- Did this child task recv Eboundary H data from parent? - IF(NVARS_BC_2D_H>0)THEN - DO NV=1,NVARS_BC_2D_H-1 - DEALLOCATE(MY_BC_VARS_H_E%VAR_2D(NV)%SIDE) - ENDDO - ENDIF - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - DEALLOCATE(MY_BC_VARS_H_E%VAR_3D(NV)%SIDE) - ENDDO - ENDIF - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - DEALLOCATE(MY_BC_VARS_H_E%VAR_4D(NV)%SIDE) - ENDDO - ENDIF - DEALLOCATE(cc%PDB_E) - DEALLOCATE(cc%BOUND_1D_EAST_H) - ENDIF -! - IF(NUM_PARENT_TASKS_SENDING_V%EAST>0)THEN !<-- Did this child task recv Eboundary V data from parent? - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - DEALLOCATE(MY_BC_VARS_V_E%VAR_2D(NV)%SIDE) - ENDDO - ENDIF - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - DEALLOCATE(MY_BC_VARS_V_E%VAR_3D(NV)%SIDE) - ENDDO - ENDIF - DEALLOCATE(cc%BOUND_1D_EAST_V) - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE DEALLOC_WORK_CHILDREN -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE COMPUTE_STORM_MOTION(NTIMESTEP & - ,LAST_STEP_MOVED & - ,DT & - ,NUM_PES_FCST & - ,COMM_FCST_TASKS & - ,FIS & - ,PD & - ,PINT & - ,T & - ,Q & - ,CW & - ,U & - ,V & - ,DSG2 & - ,PDSG1 & - ,DX,DY & - ,SEA_MASK & - ,I_SW_PARENT_CURRENT & - ,J_SW_PARENT_CURRENT & - ,I_WANT_TO_MOVE & - ,I_SW_PARENT_NEW & - ,J_SW_PARENT_NEW & - ,MY_DOMAIN_ID ) -! -!----------------------------------------------------------------------- -!*** The nest computes the location of the center of the storm -!*** on its grid and decides if it should move. This routine -!*** is called at the end of each timestep. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: COMM_FCST_TASKS & !<-- Intracommunicator for domain's forecast tasks - ,I_SW_PARENT_CURRENT & !<-- Parent I of nest domain's SW corner; current position - ,J_SW_PARENT_CURRENT & !<-- Parent J of nest domain's SW corner; current position - ,LAST_STEP_MOVED & !<-- Most recent timestep the nest moved - ,MY_DOMAIN_ID & !<-- This domain's ID - ,NTIMESTEP & !<-- The nest's current timestep - ,NUM_PES_FCST !<-- # of forecast tasks -! - INTEGER(kind=KINT),INTENT(OUT) :: I_SW_PARENT_NEW & !<-- Parent I of nest domain's SW corner; new position - ,J_SW_PARENT_NEW !<-- Parent J of nest domain's SW corner; new position -! - REAL(kind=KFPT),INTENT(IN) :: DT & !<-- This domain's timestep - ,DY !<-- Delta Y (m) on the nest grid -! - REAL(kind=KFPT),DIMENSION(JDS:JDE),INTENT(IN) :: DX !<-- Delta X (m) on the nest grid -! - REAL(kind=KFPT),DIMENSION(1:LM),INTENT(IN) :: DSG2,PDSG1 -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: FIS & !<-- Sfc geopotential (m2/s2) - ,PD & !<-- Psfc minus PTOP (Pa) - ,SEA_MASK !<-- Sea mask (1->water) -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(IN) :: CW & !<-- Cloud condensate (kg/kg) - ,Q & !<-- Specific humidity (kg/kg) - ,T & !<-- Sensible temperature (K) - ,U & !<-- U component of wind (m/s) - ,V !<-- V component of wind (m/s) -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM+1),INTENT(IN) :: & - PINT !<-- Layer interface pressures (Pa) -! - LOGICAL(kind=KLOG),INTENT(OUT) :: I_WANT_TO_MOVE !<-- Does nest want to move to a new position? -! -!--------------------- -!*** Local Variables -!--------------------- -! -! INTEGER(kind=KINT),SAVE :: I_EAST,I_WEST & !<-- These define the nest domain search limits -! ,J_NORTH,J_SOUTH ! within the central window. -! - INTEGER(kind=KINT),SAVE :: ID_DUMMY=-999 & !<-- Dummy value for task ID - ,ITAG_PG=200 !<-- Hardwire this tag for Sends/Recvs of Pgrad values -! -! INTEGER(kind=KINT),SAVE :: I_MAX,I_MIN & -! ,J_MAX,J_MIN & -! ,NPTS_NS,NPTS_WE -! - INTEGER(kind=KINT) :: I,I_CENTER_CURRENT,I_CENTER_NEW & - ,I_DIFF,ID_PE_MIN & - ,J,J_CENTER_CURRENT,J_CENTER_NEW & - ,J_DIFF & - ,L,L1,L2,L3,MYPE_DOM,N,N_SEND -! - INTEGER(kind=KINT) :: IERR,ISTAT -! -! INTEGER(kind=KINT),DIMENSION(1:4),SAVE :: I_PG,J_PG -! - INTEGER(kind=KINT),DIMENSION(1:4) :: HANDLE_PVAL -! - INTEGER(kind=KINT),DIMENSION(0:NUM_PES_FCST-1) :: HANDLE_PDYN & - ,HANDLE_WIN -! - INTEGER(kind=KINT),DIMENSION(MPI_STATUS_SIZE) :: JSTAT -! - REAL(kind=KFPT),SAVE :: DIST_GRAD=100000. & !<-- Distance (m) for checking storm-scale pressure gradient - ,DIST_LAND=100000. & !<-- Distance (m) for checking shift over land - ,ELAPSED_TIME_MAX=30000. & !<-- Maximum time (sec) between nest shifts over land - ,GI=1./G & - ,PGRD_MIN=200. & !<-- Minimum storm scale pressure gradient (Pa) - ,PGRD_MIN_LAND=400. & !<-- Minimum storm scale pressure gradient (Pa) over land - ,STD_LAPSE=6.5E-3 & !<-- Standard atmospheric lapse rate - ,THIRD=1./3. & - ,Z1=2000. & !<-- In computing the dynamic pressure use the winds - ,Z2=1500. & ! at around 2km, 1.5km and 1km. - ,Z3=1000. !<-- -! -! REAL(kind=KFPT),SAVE :: COEF & -! ,ELAPSED_TIME_MIN & -! ,RNPTS_HZ -! - REAL(kind=KFPT) :: APELP,DFDP,DIST_I,DIST_J,DZ & - ,ELAPSED_TIME,FACTOR,FRAC_SEA & - ,PARENT_DIFF,PCHECK & - ,PDYN_MIN_GBL,PMAX,PVAL,PVAL_N & - ,SLP_MIN,SQWS,SUM_SEA,TSFC & - ,ZDIFF,ZLOW,ZSAVE1,ZSAVE2,ZSAVE3 -! - REAL(kind=KFPT),DIMENSION(:),POINTER :: PDYN_MIN_VALS !<-- Minimum PDYN on each task subdomain -! - REAL(kind=KFPT),DIMENSION(1:3,0:NUM_PES_FCST-1),TARGET :: & - PDYN_MIN !<-- Minimum PDYN and its I,J on each nest task subdomain -! - REAL(kind=KFPT),DIMENSION(1:LM) :: ZMEAN -! - REAL(kind=KFPT),DIMENSION(ITS:ITE,JTS:JTE) :: PDYN,SLP -! - REAL(kind=KFPT),DIMENSION(ITS:ITE,JTS:JTE,1:LM+1) :: Z -! -! LOGICAL(kind=KLOG),SAVE :: FIRST_PASS=.TRUE. & -! ,I_HOLD_CENTER_POINT -! -! LOGICAL(kind=KLOG),DIMENSION(:),ALLOCATABLE,SAVE :: IN_WINDOW -! - LOGICAL(kind=KLOG),DIMENSION(1:4) :: NO_VALUE -! -! LOGICAL(kind=KLOG),DIMENSION(1:4),SAVE :: I_HOLD_PG_POINT -! - TYPE(COMPOSITE),POINTER :: CC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - CC=>CPL_COMPOSITE(MY_DOMAIN_ID) !<-- Use dummy for shorter reference to composite -! - CALL MPI_COMM_RANK(COMM_FCST_TASKS,MYPE_DOM,IERR) !<-- Task's local rank on this domain -! - I_WANT_TO_MOVE=.FALSE. !<-- Begin with this assumption -! -!----------------------------------------------------------------------- -! - I_CENTER_CURRENT=IDS+INT(0.5*(IDE-IDS)+EPS) - J_CENTER_CURRENT=JDS+INT(0.5*(JDE-JDS)+EPS) -! -!----------------------------------------------------------------------- -!*** In the first pass through this routine the nest tasks -!*** determine which of their subdomains contain points within -!*** the nest domain's central search window over the storm. Then -!*** they exchange that information with each other. -!----------------------------------------------------------------------- -! - prelim: IF(FIRST_PASS_M)THEN !<-- Work needs to be done only once during the forecast -! -!----------------------------------------------------------------------- -! - FIRST_PASS_M=.FALSE. -! - I_WEST_M =IDE/2-IDE/3 !<-- These define the nest domain search limits - I_EAST_M =IDE/2+IDE/3 ! within the central window. - J_SOUTH_M=JDE/2-JDE/3 ! - J_NORTH_M=JDE/2+JDE/3 !<-- -! - IF(.NOT.ASSOCIATED(cc%IN_WINDOW))THEN - ALLOCATE(cc%IN_WINDOW(0:NUM_PES_FCST-1),stat=ISTAT) !<-- Must be allocated since 0:NUM_PES_FCST is passed in - IF(ISTAT/=0)THEN - WRITE(0,*)' COMPUTE_STORM_MOTION: ERROR' - WRITE(0,*)' Failed to allocate IN_WINDOW stat=',ISTAT - ENDIF - ENDIF -! - IN_WINDOW=>cc%IN_WINDOW - IN_WINDOW(MYPE_DOM)=.FALSE. -! - IF(ITS<=I_EAST_M.AND.ITE>=I_WEST_M & !<-- Does any of nest task N's subdomain - .AND. & ! lie within the central window? - JTS<=J_NORTH_M.AND.JTE>=J_SOUTH_M)THEN -! - IN_WINDOW(MYPE_DOM)=.TRUE. !<-- Yes, this task lies in the search window -! - I_MIN=MAX(ITS,I_WEST_M) !<-- Index limits of this task's subdomain - I_MAX=MIN(ITE,I_EAST_M) ! that lie inside the search window. - J_MIN=MAX(JTS,J_SOUTH_M) ! - J_MAX=MIN(JTE,J_NORTH_M) !<-- -! - RNPTS_HZ=1./REAL((I_MAX-I_MIN+1)*(J_MAX-J_MIN+1)) !<-- Reciprocal of # of task's points in search window -! - ENDIF -! - DO N=0,NUM_PES_FCST-1 !<-- Nest fcst tasks send their window status to each other - IF(N/=MYPE_DOM)THEN !<-- But not to themselves - CALL MPI_ISSEND(IN_WINDOW(MYPE_DOM) & !<-- This task's central window status - ,1 & !<-- Sending this many words - ,MPI_LOGICAL & !<-- Datatype - ,N & !<-- Sending to this local nest task ID - ,MYPE_DOM & !<-- Use this task's ID as the tag - ,COMM_FCST_TASKS & !<-- Intracommunicator for fcst tasks - ,HANDLE_WIN(N) & !<-- Communication request handle for task N's Recv - ,IERR ) - ENDIF - ENDDO -! - DO N=0,NUM_PES_FCST-1 !<-- Nest fcst tasks recv window status from each other - IF(N/=MYPE_DOM)THEN !<-- But not from themselves - CALL MPI_RECV(IN_WINDOW(N) & !<-- Nest task N's central window status - ,1 & !<-- Receiving this many words - ,MPI_LOGICAL & !<-- Datatype - ,N & !<-- Data was sent by this nest task - ,N & !<-- Tag is the sender's rank - ,COMM_FCST_TASKS & !<-- Intracommunicator for fcst tasks - ,JSTAT & !<-- MPI status - ,IERR ) - ENDIF - ENDDO -! - DO N=0,NUM_PES_FCST-1 - IF(N/=MYPE_DOM)THEN - CALL MPI_WAIT(HANDLE_WIN(N) & !<-- Proceed only after all ISSends have completed - ,JSTAT & - ,IERR ) - ENDIF - ENDDO -! -!----------------------------------------------------------------------- -!*** We will need an approximation of the maximum pressure gradient -!*** around the storm center. Use SLP values roughly DIST_GRAD meters -!*** N, S, W, and E of the center. What is the relative distance -!*** in gridpoints that this distance represents? -!----------------------------------------------------------------------- -! - NPTS_NS=NINT(DIST_GRAD/DY) !<-- # grid points to N/S of center to check SLP - NPTS_WE=NINT(DIST_GRAD/DX(J_CENTER_CURRENT)) !<-- # grid points to W/E of center to check SLP -! -!----------------------------------------------------------------------- -! - COEF=-G/(R_D*STD_LAPSE) -! -!----------------------------------------------------------------------- -!*** Set the minimum time between domain shifts. For now make it a -!*** linear relationship where the 9km nest must wait at least 15 min -!*** to move. -!----------------------------------------------------------------------- -! - ELAPSED_TIME_MIN=45.*DT !<-- Equals 900s for a 9 km nest. -! -!----------------------------------------------------------------------- -!*** Allow the minimum pressure gradient between the storm center -!*** and the cardinal points to be smaller for higher resolution. -!----------------------------------------------------------------------- -! - IF(DY<8999.)THEN - PGRD_MIN=PGRD_MIN*DY/9000. - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF prelim -! -!----------------------------------------------------------------------- -!*** Allow the nest to move only in one of its physics timesteps. -!----------------------------------------------------------------------- -! - IF(MOD(NTIMESTEP,NPHS)/=0)THEN - RETURN - ENDIF -! -!----------------------------------------------------------------------- -!*** Never let the nest move until a minimum amount of time -!*** has passed. -!----------------------------------------------------------------------- -! - ELAPSED_TIME=(NTIMESTEP-LAST_STEP_MOVED)*DT -! - IF(ELAPSED_TIMEELAPSED_TIME_MAX)THEN - IF(MYPE_DOM==0)THEN - WRITE(0,*)' SKIP MOTION COMPUTATION: Storm stationary over land.' - ENDIF - RETURN - ENDIF -! -!----------------------------------------------------------------------- -! - DO N=0,NUM_PES_FCST-1 - PDYN_MIN(1,N)=110000. !<-- Initialize the minimum value of PDYN. - PDYN_MIN(2,N)=-1000. !<-- Initialize the I index of minimum PDYN - PDYN_MIN(3,N)=-1000. !<-- Initialize the J index of minimum PDYN - ENDDO -! - DO J=JTS,JTE - DO I=ITS,ITE - SLP(I,J)=0. !<-- Initialize the SLP array. - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** Begin the search for the new storm center location. -!*** Search inside the central window. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- - window: IF(IN_WINDOW(MYPE_DOM))THEN !<-- Only those tasks within the search window proceed -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Compute a 'dynamic pressure' using vertically averaged winds -!*** around Z1, Z2, and Z3 meters as well as the sea level pressure. -!----------------------------------------------------------------------- -! - DO J=J_MIN,J_MAX - DO I=I_MIN,I_MAX - Z(I,J,LM+1)=FIS(I,J)*GI !<-- The surface elevation (m) - ENDDO - ENDDO -! - DO L=LM,1,-1 - ZMEAN(L)=0. - DO J=J_MIN,J_MAX - DO I=I_MIN,I_MAX - APELP=(PINT(I,J,L)+PINT(I,J,L+1))*0.5 - DFDP=(Q(I,J,L)*P608+(1.-CW(I,J,L)))*T(I,J,L)*R_D/APELP - DZ=GI*DFDP*(DSG2(L)*PD(I,J)+PDSG1(L)) - Z(I,J,L)=Z(I,J,L+1)+DZ - ZMEAN(L)=ZMEAN(L)+0.5*(Z(I,J,L)+Z(I,J,L+1)) - ENDDO - ENDDO - ZMEAN(L)=ZMEAN(L)*RNPTS_HZ !<-- The mean height (m) of midlayer L in search window - ENDDO -! - ZSAVE1=1.E10 - ZSAVE2=1.E10 - ZSAVE3=1.E10 -! -!----------------------------------------------------------------------- -!*** Find and save the model midlayer indices nearest to the -!*** prescribed heights of Z1, Z2, and Z3 meters above the ground. -!----------------------------------------------------------------------- -! - DO L=1,LM -! - ZDIFF=ABS(ZMEAN(L)-Z1) - IF(ZDIFFPDYN_MIN(1,0:NUM_PES_FCST-1) !<-- Select only the PDYN values from the array -! - ID_PE_MIN=MINLOC(PDYN_MIN_VALS,1)-1 !<-- ID of nest task with minimum value of PDYN -! - SLP_MIN=PDYN_MIN(1,ID_PE_MIN) !<-- Minimum value of PDYN for all tasks - I_CENTER_NEW=INT(PDYN_MIN(2,ID_PE_MIN)) !<-- I index of minimum PDYN on the nest domain - J_CENTER_NEW=INT(PDYN_MIN(3,ID_PE_MIN)) !<-- J index of minimum PDYN on the nest domain -! - I_DIFF=I_CENTER_NEW-I_CENTER_CURRENT !<-- Shift in I to potential new center - J_DIFF=J_CENTER_NEW-J_CENTER_CURRENT !<-- Shift in J to potential new center -! -!----------------------------------------------------------------------- -!*** If the nest moves then its SW corner must shift from one parent -!*** H point to another which means the I and J shifts must be in -!*** integer multiples of SPACE_RATIO_MY_PARENT. Adjust I_DIFF and -!*** J_DIFF given this constraint. -!----------------------------------------------------------------------- -! - IF(MOD(I_DIFF,SPACE_RATIO_MY_PARENT)/=0)THEN - PARENT_DIFF=REAL(I_DIFF)/REAL(SPACE_RATIO_MY_PARENT) - IF(ABS(FRACTION(PARENT_DIFF))>0.5)THEN - I_DIFF=NINT(PARENT_DIFF)*SPACE_RATIO_MY_PARENT - ELSE - I_DIFF=INT(PARENT_DIFF)*SPACE_RATIO_MY_PARENT - ENDIF - I_CENTER_NEW=I_CENTER_CURRENT+I_DIFF - ENDIF -! - IF(MOD(J_DIFF,SPACE_RATIO_MY_PARENT)/=0)THEN - PARENT_DIFF=REAL(J_DIFF)/REAL(SPACE_RATIO_MY_PARENT) - IF(ABS(FRACTION(PARENT_DIFF))>0.5)THEN - J_DIFF=NINT(PARENT_DIFF)*SPACE_RATIO_MY_PARENT - ELSE - J_DIFF=INT(PARENT_DIFF)*SPACE_RATIO_MY_PARENT - ENDIF - J_CENTER_NEW=J_CENTER_CURRENT+J_DIFF - ENDIF -! - IF(ABS(I_DIFF)==0.AND.ABS(J_DIFF)==0)THEN - IF(MYPE_DOM==0)THEN -! WRITE(0,*)' NO MOTION: Less than one parent grid increment.' - ENDIF - RETURN !<-- No motion so exit. - ENDIF -! -!----------------------------------------------------------------------- -!*** Tasks learn if they contain any of the four cardinal direction -!*** points to be used for the storm-gradient check. -!----------------------------------------------------------------------- -! - N_SEND=4 - DO N=1,4 - NO_VALUE(N)=.FALSE. !<-- Start with all cardinal directions having values inside - ENDDO -! - I_PG(1)=I_CENTER_NEW !<-- I coordinate of north pressure point - J_PG(1)=J_CENTER_NEW+NPTS_NS !<-- J coordinate of north pressure point - IF(I_PG(1)IDE.OR.J_PG(1)JDE)THEN - NO_VALUE(1)=.TRUE. !<-- North point is outside nest domain - N_SEND=N_SEND-1 - ELSE - CALL LOCATE_POINT_ON_TASKS(I_PG(1) & - ,J_PG(1) & - ,I_HOLD_PG_POINT(1)) !<-- Does this task subdomain contain north PG point? - ENDIF -! - I_PG(2)=I_CENTER_NEW !<-- I coordinate of south pressure point - J_PG(2)=J_CENTER_NEW-NPTS_NS !<-- J coordinate of south pressure point - IF(I_PG(2)IDE.OR.J_PG(2)JDE)THEN - NO_VALUE(2)=.TRUE. !<-- South point is outside nest domain - N_SEND=N_SEND-1 - ELSE - CALL LOCATE_POINT_ON_TASKS(I_PG(2) & - ,J_PG(2) & - ,I_HOLD_PG_POINT(2)) !<-- Does this task subdomain contain south PG point? - ENDIF -! - I_PG(3)=I_CENTER_NEW-NPTS_WE !<-- I coordinate of west pressure point - J_PG(3)=J_CENTER_NEW !<-- J coordinate of west pressure point - IF(I_PG(3)IDE.OR.J_PG(3)JDE)THEN - NO_VALUE(3)=.TRUE. !<-- West point is outside nest domain - N_SEND=N_SEND-1 - ELSE - CALL LOCATE_POINT_ON_TASKS(I_PG(3) & - ,J_PG(3) & - ,I_HOLD_PG_POINT(3)) !<-- Does this task subdomain contain west PG point? - ENDIF -! - I_PG(4)=I_CENTER_NEW+NPTS_WE !<-- I coordinate of east pressure point - J_PG(4)=J_CENTER_NEW !<-- J coordinate of east pressure point - IF(I_PG(4)IDE.OR.J_PG(4)JDE)THEN - NO_VALUE(4)=.TRUE. !<-- East point is outside nest domain - N_SEND=N_SEND-1 - ELSE - CALL LOCATE_POINT_ON_TASKS(I_PG(4) & - ,J_PG(4) & - ,I_HOLD_PG_POINT(4)) !<-- Does this task subdomain contain east PG point? - ENDIF -! -!----------------------------------------------------------------------- -!*** Those tasks that hold the four points N, S, W, and E of the -!*** new storm center send their pressure values to the task -!*** whose subdomain contains the new storm center. -!----------------------------------------------------------------------- -! - IF(N_SEND>0)THEN - DO N=1,4 !<-- The 4 cardinal direction points - IF(NO_VALUE(N))CYCLE - IF(I_HOLD_PG_POINT(N))THEN - PVAL=SLP(I_PG(N),J_PG(N)) - CALL MPI_ISSEND(PVAL & !<-- SLP at cardinal point N around storm center - ,1 & !<-- It is one word - ,MPI_REAL & !<-- Datatype - ,ID_PE_MIN & !<-- ID of task holding the new storm center - ,ITAG_PG & !<-- Tag used for exchange of pressure data for gradient - ,COMM_FCST_TASKS & !<-- Intracommunicator for fcst tasks - ,HANDLE_PVAL(N) & !<-- Communication request handle for task N's Recv - ,IERR ) - ENDIF - ENDDO - ELSE - WRITE(0,*)' ALERT: Storm has moved more than DIST_GRAD beyond' & - ,' moving nest boundary!' - RETURN - ENDIF -! -!----------------------------------------------------------------------- -!*** The task holding the new storm center saves the maximum -!*** pressure among the four cardinal points then informs all -!*** other tasks of that value. -!----------------------------------------------------------------------- -! - IF(MYPE_DOM==ID_PE_MIN)THEN - PMAX=-100000. - DO N=1,4 - IF(NO_VALUE(N))CYCLE - CALL MPI_RECV(PVAL_N & !<-- Pressure from cardinal point N - ,1 & !<-- It is one word - ,MPI_REAL & !<-- Datatype - ,MPI_ANY_SOURCE & !<-- Does not know ID of the sending task - ,ITAG_PG & !<-- Tag used for exchange of pressure data for gradient - ,COMM_FCST_TASKS & !<-- Intracommunicator for fcst tasks - ,JSTAT & !<-- MPI status - ,IERR ) -! - IF(PVAL_N>PMAX)THEN - PMAX=PVAL_N !<-- Save the maximum pressure. - ENDIF -! - ENDDO - ENDIF -! - DO N=1,4 !<-- The 4 cardinal directions - IF(NO_VALUE(N))CYCLE - IF(I_HOLD_PG_POINT(N))THEN - CALL MPI_WAIT(HANDLE_PVAL(N) & !<-- Proceed only after all Recvs have completed - ,JSTAT & - ,IERR ) - ENDIF - ENDDO -! - IF(N_SEND>0)THEN - CALL MPI_BCAST(PMAX & !<-- Max cardinal pressure around storm - ,1 & !<-- It is one word - ,MPI_REAL & !<-- Datatype - ,ID_PE_MIN & !<-- The root sender - ,COMM_FCST_TASKS & !<-- Intracommunicator for fcst tasks - ,IERR ) - IF(PMAX<50000.)PMAX=1000000. - ELSE - PMAX=1000000. - ENDIF -! -!----------------------------------------------------------------------- -!*** Now that a new central pressure and its location have been -!*** identified several conditions must be met before the move -!*** can be allowed to execute. We have already made certain -!*** that the nest domain's SW corner remains on a parent H point -!*** if the shift is executed. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** (1) Did the vortex disappear? -!----------------------------------------------------------------------- -! - IF(PMAXDIST_LAND.AND.DIST_J>DIST_LAND)THEN - IF(MYPE_DOM==0)THEN - WRITE(0,*)' CANNOT MOVE: Vortex lost over land.' - ENDIF - RETURN - ENDIF -! -!----------------------------------------------------------------------- -!*** (4) Is the vortex too weak over land? -!----------------------------------------------------------------------- -! - IF(FRAC_SEA<=0.2.AND.PMAX-SLP_MIN=ITS.AND.I_PG<=ITE.AND.J_PG>=JTS.AND.J_PG<=JTE)THEN - I_HOLD_THIS_POINT=.TRUE. - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE LOCATE_POINT_ON_TASKS -! -!----------------------------------------------------------------------- -! - END SUBROUTINE COMPUTE_STORM_MOTION -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- - SUBROUTINE SPLINE(NOLD,XOLD,YOLD,Y2,Y2_K,NNEW,XNEW,YNEW) -!----------------------------------------------------------------------- -! -! ****************************************************************** -! * * -! * This is a one-dimensional cubic spline fitting routine * -! * programmed for a small scalar machine. * -! * * -! * Programmer: Z. Janjic, Yugoslav Fed. Hydromet. Inst., Beograd * -! * * -! * NOLD - Number of given values of the function. Must be >= 3. * -! * XOLD - Locations of the points at which the values of the * -! * function are given. Must be in ascending order. * -! * YOLD - The given values of the function at the points XOLD. * -! * Y2 - The second derivatives at the points XOLD. If natural * -! * spline is fitted Y2(1)=0 and Y2(nold)=0. Must be * -! * specified. * -! * Y2_K - Vertical dimension of Y2 array. * -! * NNEW - Number of values of the function to be calculated. * -! * XNEW - Locations of the points at which the values of the * -! * function are calculated. XNEW(K) must be >= XOLD(1) * -! * and <= XOLD(NOLD). * -! * YNEW - The values of the function to be calculated. * -! * * -! ****************************************************************** -! -!------------------------ -!*** Argument variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: NNEW,NOLD,Y2_K -! - REAL(kind=KFPT),DIMENSION(1:NOLD),INTENT(IN) :: XOLD,YOLD - REAL(kind=KFPT),DIMENSION(1:NNEW),INTENT(IN) :: XNEW -! - REAL(kind=KFPT),DIMENSION(1:Y2_K),INTENT(INOUT) :: Y2 -! - REAL(kind=KFPT),DIMENSION(1:NNEW),INTENT(OUT) :: YNEW -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: K,K1,K2,KOLD,NOLDM1 -! - REAL(kind=KFPT) :: AK,BK,CK,DEN,DX,DXC,DXL,DXR,DYDXL,DYDXR & - ,RDX,RTDXC,X,XK,XSQ,Y2K,Y2KP1 -! - REAL(kind=KFPT),DIMENSION(1:NOLD-2) :: P,Q -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - NOLDM1=NOLD-1 -! - DXL=XOLD(2)-XOLD(1) - DXR=XOLD(3)-XOLD(2) - DYDXL=(YOLD(2)-YOLD(1))/DXL - DYDXR=(YOLD(3)-YOLD(2))/DXR - RTDXC=0.5/(DXL+DXR) -! - P(1)= RTDXC*(6.*(DYDXR-DYDXL)-DXL*Y2(1)) - Q(1)=-RTDXC*DXR -! - IF(NOLD==3) GO TO 700 -! -!----------------------------------------------------------------------- -! - K=3 -! - 100 CONTINUE - DXL=DXR - DYDXL=DYDXR - DXR=XOLD(K+1)-XOLD(K) - DYDXR=(YOLD(K+1)-YOLD(K))/DXR - DXC=DXL+DXR - DEN=1./(DXL*Q(K-2)+DXC+DXC) -! - P(K-1)= DEN*(6.*(DYDXR-DYDXL)-DXL*P(K-2)) - Q(K-1)=-DEN*DXR -! - K=K+1 - IF(K1) GO TO 200 -! -!----------------------------------------------------------------------- -! - K1=1 -! - 300 CONTINUE - XK=XNEW(K1) -! - DO 400 K2=2,NOLD - IF(XOLD(K2)<=XK) GO TO 400 - KOLD=K2-1 - GO TO 450 - 400 CONTINUE -! - YNEW(K1)=YOLD(NOLD) - GO TO 600 -! - 450 CONTINUE - IF(K1==1) GO TO 500 - IF(K==KOLD) GO TO 550 -! - 500 CONTINUE - K=KOLD -! - Y2K=Y2(K) - Y2KP1=Y2(K+1) - DX=XOLD(K+1)-XOLD(K) - RDX=1./DX -! - AK=0.1666667*RDX*(Y2KP1-Y2K) - BK=0.5*Y2K - CK=RDX*(YOLD(K+1)-YOLD(K))-0.1666667*DX*(Y2KP1+Y2K+Y2K) -! - 550 CONTINUE - X=XK-XOLD(K) - XSQ=X*X -! - YNEW(K1)=AK*XSQ*X+BK*XSQ+CK*X+YOLD(K) -! - 600 CONTINUE - K1=K1+1 -! - IF(K1<=NNEW) GO TO 300 -! -!----------------------------------------------------------------------- -! - END SUBROUTINE SPLINE -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - subroutine artificial_move(ntimestep & - ,kount_moves & - ,i_want_to_move & - ,i_sw_parent_current & - ,j_sw_parent_current & - ,i_sw_parent_new & - ,j_sw_parent_new ) -! -!----------------------------------------------------------------------- -! - integer(kind=kint),intent(in) :: i_sw_parent_current & - ,j_sw_parent_current & - ,kount_moves & - ,ntimestep -! - integer(kind=kint),intent(out) :: i_sw_parent_new & - ,j_sw_parent_new -! - logical(kind=klog),intent(out) :: i_want_to_move -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - i_want_to_move=.false. -! - write(0,*)' enter artificial ntimestep=',ntimestep,' kount_moves=',kount_moves - if(ntimestep>0.and.mod(ntimestep,51)==0)then - i_want_to_move=.true. - write(0,*)' artificial set i_want_to_move=',i_want_to_move - if(mod(kount_moves,16)<= 1)then !<-- NW - i_sw_parent_new=i_sw_parent_current-1 - j_sw_parent_new=j_sw_parent_current+1 - write(0,*)' artificial to NW' - elseif(mod(kount_moves,16)<= 3)then !<-- N - i_sw_parent_new=i_sw_parent_current - j_sw_parent_new=j_sw_parent_current+1 - write(0,*)' artificial to N' - elseif(mod(kount_moves,16)<= 5)then !<-- NE - i_sw_parent_new=i_sw_parent_current+1 - j_sw_parent_new=j_sw_parent_current+1 - write(0,*)' artificial to NE' - elseif(mod(kount_moves,16)<= 7)then !<-- E - i_sw_parent_new=i_sw_parent_current+1 - j_sw_parent_new=j_sw_parent_current - write(0,*)' artificial to E' - elseif(mod(kount_moves,16)<= 9)then !<-- SE - i_sw_parent_new=i_sw_parent_current+1 - j_sw_parent_new=j_sw_parent_current-1 - write(0,*)' artificial to SE' - elseif(mod(kount_moves,16)<=11)then !<-- S - i_sw_parent_new=i_sw_parent_current - j_sw_parent_new=j_sw_parent_current-1 - write(0,*)' artificial to S' - elseif(mod(kount_moves,16)<=13)then !<-- SW - i_sw_parent_new=i_sw_parent_current-1 - j_sw_parent_new=j_sw_parent_current-1 - write(0,*)' artificial to SW' - elseif(mod(kount_moves,16)<=15)then !<-- W - i_sw_parent_new=i_sw_parent_current-1 - j_sw_parent_new=j_sw_parent_current - write(0,*)' artificial to W' - endif - endif - write(0,*)' exit artificial_move ntimestep=',ntimestep,' mod=',mod(ntimestep,14) & - ,' i_want_to_move=',i_want_to_move -! -!----------------------------------------------------------------------- - end subroutine artificial_move -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - subroutine artificial_move2(ntimestep & - ,kount_moves & - ,i_want_to_move & - ,i_sw_parent_current & - ,j_sw_parent_current & - ,i_sw_parent_new & - ,j_sw_parent_new ) -! -!----------------------------------------------------------------------- -! - integer(kind=kint),intent(in) :: i_sw_parent_current & - ,j_sw_parent_current & - ,kount_moves & - ,ntimestep -! - integer(kind=kint),intent(out) :: i_sw_parent_new & - ,j_sw_parent_new -! - logical(kind=klog),intent(out) :: i_want_to_move -! - integer(kind=kint) :: mod_km -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - i_want_to_move=.false. -! - write(0,*)' enter artificial ntimestep=',ntimestep,' kount_moves=',kount_moves -!!! if(ntimestep>3.and.mod(ntimestep,14)<=2)then - if(ntimestep>0.and.mod(ntimestep+3,51)==0)then - i_want_to_move=.true. - write(0,*)' artificial set i_want_to_move=',i_want_to_move - mod_km=mod(kount_moves,16) - if(mod_km<=01)then !<-- E - i_sw_parent_new=i_sw_parent_current+1 - j_sw_parent_new=j_sw_parent_current - write(0,*)' artificial to E mod_km=',mod_km - elseif(mod_km<=03)then !<-- NE - i_sw_parent_new=i_sw_parent_current+1 - j_sw_parent_new=j_sw_parent_current+1 - write(0,*)' artificial to NE mod_km=',mod_km - elseif(mod_km<=05)then !<-- N - i_sw_parent_new=i_sw_parent_current - j_sw_parent_new=j_sw_parent_current+1 - write(0,*)' artificial to N mod_km=',mod_km - elseif(mod_km<=07)then !<-- NW - i_sw_parent_new=i_sw_parent_current-1 - j_sw_parent_new=j_sw_parent_current+1 - write(0,*)' artificial to NW mod_km=',mod_km - elseif(mod_km<=09)then !<-- W - i_sw_parent_new=i_sw_parent_current-1 - j_sw_parent_new=j_sw_parent_current - write(0,*)' artificial to W mod_km=',mod_km - elseif(mod_km<=11)then !<-- SW - i_sw_parent_new=i_sw_parent_current-1 - j_sw_parent_new=j_sw_parent_current-1 - write(0,*)' artificial to SW mod_km=',mod_km - elseif(mod_km<=13)then !<-- S - i_sw_parent_new=i_sw_parent_current - j_sw_parent_new=j_sw_parent_current-1 - write(0,*)' artificial to S mod_km=',mod_km - elseif(mod_km<=15)then !<-- SE - i_sw_parent_new=i_sw_parent_current+1 - j_sw_parent_new=j_sw_parent_current-1 - write(0,*)' artificial to SE mod_km=',mod_km - endif - endif - write(0,*)' exit artificial_move ntimestep=',ntimestep,' mod=',mod(ntimestep+3,51) & - ,' i_want_to_move=',i_want_to_move -! -!----------------------------------------------------------------------- - end subroutine artificial_move2 -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - subroutine artificial_move3(ntimestep & - ,kount_moves & - ,i_want_to_move & - ,i_sw_parent_current & - ,j_sw_parent_current & - ,i_sw_parent_new & - ,j_sw_parent_new ) -! -!----------------------------------------------------------------------- -! - integer(kind=kint),intent(in) :: i_sw_parent_current & - ,j_sw_parent_current & - ,kount_moves & - ,ntimestep -! - integer(kind=kint),intent(out) :: i_sw_parent_new & - ,j_sw_parent_new -! - logical(kind=klog),intent(out) :: i_want_to_move -! - integer(kind=kint) :: mod_km -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - i_want_to_move=.false. -! - write(0,*)' enter artificial ntimestep=',ntimestep,' kount_moves=',kount_moves -!!! if(ntimestep>3.and.mod(ntimestep,14)<=2)then - if(ntimestep>0.and.mod(ntimestep+3,51)==0)then - i_want_to_move=.true. - write(0,*)' artificial set i_want_to_move=',i_want_to_move - mod_km=mod(kount_moves,16) - if(mod_km<=01)then !<-- NW - i_sw_parent_new=i_sw_parent_current-1 - j_sw_parent_new=j_sw_parent_current+1 - write(0,*)' artificial to NW mod_km=',mod_km - elseif(mod_km<=03)then !<-- N - i_sw_parent_new=i_sw_parent_current - j_sw_parent_new=j_sw_parent_current+1 - write(0,*)' artificial to N mod_km=',mod_km - elseif(mod_km<=05)then !<-- NE - i_sw_parent_new=i_sw_parent_current+1 - j_sw_parent_new=j_sw_parent_current+1 - write(0,*)' artificial to NE mod_km=',mod_km - elseif(mod_km<=07)then !<-- E - i_sw_parent_new=i_sw_parent_current+1 - j_sw_parent_new=j_sw_parent_current - write(0,*)' artificial to E mod_km=',mod_km - elseif(mod_km<=09)then !<-- SE - i_sw_parent_new=i_sw_parent_current+1 - j_sw_parent_new=j_sw_parent_current-1 - write(0,*)' artificial to SE mod_km=',mod_km - elseif(mod_km<=11)then !<-- S - i_sw_parent_new=i_sw_parent_current - j_sw_parent_new=j_sw_parent_current-1 - write(0,*)' artificial to S mod_km=',mod_km - elseif(mod_km<=13)then !<-- SW - i_sw_parent_new=i_sw_parent_current-1 - j_sw_parent_new=j_sw_parent_current-1 - write(0,*)' artificial to SW mod_km=',mod_km - elseif(mod_km<=15)then !<-- W - i_sw_parent_new=i_sw_parent_current-1 - j_sw_parent_new=j_sw_parent_current - write(0,*)' artificial to W mod_km=',mod_km - endif - endif - write(0,*)' exit artificial_move ntimestep=',ntimestep,' mod=',mod(ntimestep+3,51) & - ,' i_want_to_move=',i_want_to_move -! -!----------------------------------------------------------------------- - end subroutine artificial_move3 -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - subroutine artificial_move4(ntimestep & - ,kount_moves & - ,i_want_to_move & - ,i_sw_parent_current & - ,j_sw_parent_current & - ,i_sw_parent_new & - ,j_sw_parent_new ) -! -!----------------------------------------------------------------------- -! - integer(kind=kint),intent(in) :: i_sw_parent_current & - ,j_sw_parent_current & - ,kount_moves & - ,ntimestep -! - integer(kind=kint),intent(out) :: i_sw_parent_new & - ,j_sw_parent_new -! - logical(kind=klog),intent(out) :: i_want_to_move -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - i_want_to_move=.false. -! - write(0,*)' enter artificial ntimestep=',ntimestep,' kount_moves=',kount_moves - if(ntimestep>3.and.mod(ntimestep,14)<=2)then - i_want_to_move=.true. - write(0,*)' artificial set i_want_to_move=',i_want_to_move - if(mod(kount_moves,45)<=5)then !<-- E - i_sw_parent_new=i_sw_parent_current+1 - j_sw_parent_new=j_sw_parent_current - write(0,*)' artificial to NW' - elseif(mod(kount_moves,45)<=11)then !<-- NE - i_sw_parent_new=i_sw_parent_current+1 - j_sw_parent_new=j_sw_parent_current+1 - write(0,*)' artificial to N' - elseif(mod(kount_moves,45)<=16)then !<-- N - i_sw_parent_new=i_sw_parent_current - j_sw_parent_new=j_sw_parent_current+1 - write(0,*)' artificial to NE' - elseif(mod(kount_moves,45)<=22)then !<-- NW - i_sw_parent_new=i_sw_parent_current-1 - j_sw_parent_new=j_sw_parent_current+1 - write(0,*)' artificial to E' - elseif(mod(kount_moves,45)<=27)then !<-- W - i_sw_parent_new=i_sw_parent_current-1 - j_sw_parent_new=j_sw_parent_current - write(0,*)' artificial to SE' - elseif(mod(kount_moves,45)<=33)then !<-- SW - i_sw_parent_new=i_sw_parent_current-1 - j_sw_parent_new=j_sw_parent_current-1 - write(0,*)' artificial to S' - elseif(mod(kount_moves,45)<=38)then !<-- S - i_sw_parent_new=i_sw_parent_current - j_sw_parent_new=j_sw_parent_current-1 - write(0,*)' artificial to SW' - elseif(mod(kount_moves,45)<=44)then !<-- SW - i_sw_parent_new=i_sw_parent_current+1 - j_sw_parent_new=j_sw_parent_current-1 - write(0,*)' artificial to W' - endif - endif - write(0,*)' exit artificial_move ntimestep=',ntimestep,' mod=',mod(ntimestep,14) & - ,' i_want_to_move=',i_want_to_move -! -!----------------------------------------------------------------------- - end subroutine artificial_move4 -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - subroutine artificial_move5(ntimestep & - ,kount_moves & - ,i_want_to_move & - ,i_sw_parent_current & - ,j_sw_parent_current & - ,i_sw_parent_new & - ,j_sw_parent_new ) -! -!----------------------------------------------------------------------- -! - integer(kind=kint),intent(in) :: i_sw_parent_current & - ,j_sw_parent_current & - ,kount_moves & - ,ntimestep -! - integer(kind=kint),intent(out) :: i_sw_parent_new & - ,j_sw_parent_new -! - logical(kind=klog),intent(out) :: i_want_to_move -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - i_want_to_move=.false. -! - write(0,*)' enter artificial ntimestep=',ntimestep,' kount_moves=',kount_moves - if(ntimestep>3.and.mod(ntimestep,15)==0)then - i_want_to_move=.true. - write(0,*)' artificial set i_want_to_move=',i_want_to_move - if(mod(kount_moves,40)<5)then !<-- E - i_sw_parent_new=i_sw_parent_current+1 - j_sw_parent_new=j_sw_parent_current - write(0,*)' artificial to E',kount_moves - elseif(mod(kount_moves,40)<10)then !<-- NE - i_sw_parent_new=i_sw_parent_current+1 - j_sw_parent_new=j_sw_parent_current+1 - write(0,*)' artificial to NE',kount_moves - elseif(mod(kount_moves,40)<15)then !<-- N - i_sw_parent_new=i_sw_parent_current - j_sw_parent_new=j_sw_parent_current+1 - write(0,*)' artificial to N',kount_moves - elseif(mod(kount_moves,40)<20)then !<-- NW - i_sw_parent_new=i_sw_parent_current-1 - j_sw_parent_new=j_sw_parent_current+1 - write(0,*)' artificial to NW',kount_moves - elseif(mod(kount_moves,40)<25)then !<-- W - i_sw_parent_new=i_sw_parent_current-1 - j_sw_parent_new=j_sw_parent_current - write(0,*)' artificial to W',kount_moves - elseif(mod(kount_moves,40)<30)then !<-- SW - i_sw_parent_new=i_sw_parent_current-1 - j_sw_parent_new=j_sw_parent_current-1 - write(0,*)' artificial to SW',kount_moves - elseif(mod(kount_moves,40)<35)then !<-- S - i_sw_parent_new=i_sw_parent_current - j_sw_parent_new=j_sw_parent_current-1 - write(0,*)' artificial to S',kount_moves - elseif(mod(kount_moves,40)<40)then !<-- SW - i_sw_parent_new=i_sw_parent_current+1 - j_sw_parent_new=j_sw_parent_current-1 - write(0,*)' artificial to SW',kount_moves - endif - endif - write(0,*)' exit artificial_move ntimestep=',ntimestep,' mod=',mod(ntimestep,14) & - ,' i_want_to_move=',i_want_to_move -! -!----------------------------------------------------------------------- - end subroutine artificial_move5 -!----------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - subroutine prescribed_move(ntimestep,dt & - ,i_want_to_move & - ,i_sw_parent_current & - ,j_sw_parent_current & - ,i_sw_parent_new & - ,j_sw_parent_new ) -! -!----------------------------------------------------------------------- -! - real(KIND=kfpt),intent(in) :: dt -! - integer(kind=kint),intent(in) :: i_sw_parent_current & - ,j_sw_parent_current & - ,ntimestep -! - integer(kind=kint),intent(out) :: i_sw_parent_new & - ,j_sw_parent_new -! - logical(kind=klog),intent(out) :: i_want_to_move -! - integer, save :: kount_moves = 1 - integer :: nsteps_move -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - i_want_to_move=.false. - i_sw_parent_new = 0 - j_sw_parent_new = 0 - - nsteps_move = MOVE_INTERVAL_MINUTES*60/DT - if ( ntimestep>0 .and. mod(ntimestep,nsteps_move)<3 ) then - kount_moves=kount_moves+1 - if (kount_moves > size(MOVE_I_SW) ) return - write(0,"(A,4I6)")' WILL_MOVE_NOW ',ntimestep,kount_moves, & - MOVE_I_SW(kount_moves),MOVE_J_SW(kount_moves) - i_want_to_move=.true. - i_sw_parent_new = MOVE_I_SW(kount_moves) - j_sw_parent_new = MOVE_J_SW(kount_moves) - end if -! -!----------------------------------------------------------------------- - end subroutine prescribed_move -!----------------------------------------------------------------------- -! - END MODULE MODULE_PARENT_CHILD_CPL_COMP -! -!----------------------------------------------------------------------- diff --git a/src/nmm/module_PRECIP_ADJUST.F90 b/src/nmm/module_PRECIP_ADJUST.F90 deleted file mode 100644 index f2f75ef..0000000 --- a/src/nmm/module_PRECIP_ADJUST.F90 +++ /dev/null @@ -1,342 +0,0 @@ -!----------------------------------------------------------------------- -! - MODULE MODULE_PRECIP_ADJUST -! -! This module contains 3 subroutines: -! READPCP -! CHKSNOW -! ADJPPT -!----------------------------------------------------------------------- -!*** -!*** Specify the diagnostic point here: (i,j) and the processor number. -!*** Remember that in WRF, local and global (i,j) are the same, so don't -!*** use the "local(i,j)" output from glb2loc.f; use the GLOBAL (I,J) -!*** and the PE_WRF. -!*** -! - USE MODULE_DM_PARALLEL,ONLY : DSTRB - INTEGER,PRIVATE,SAVE :: ITS_B1,ITE_B1,JTS_B2,JTE_B2 - - INTEGER :: ITEST=346,JTEST=256,TESTPE=53 -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- - SUBROUTINE READPCP(MYPE,MPI_COMM_COMP & - ,PPTDAT,DDATA,LSPA,PCPHR & - ,MY_DOMAIN_ID & - ,IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE & - ,ITS_B1,ITE_B1,JTS_B2,JTE_B2) -! -! **************************************************************** -! * * -! * PRECIPITATION ASSIMILATION INITIALIZATION. * -! * READ IN PRECIP ANALYSIS AND DATA MASK AND SET UP ALL * -! * APPROPRIATE VARIABLES. * -! * MIKE BALDWIN, MARCH 1994 * -! * Adapted to 2-D code, Ying Lin, Mar 1996 * -! * For WRF/NMM: Y.Lin Mar 2005 * -! * * -! **************************************************************** -!----------------------------------------------------------------------- -! -! READ THE BINARY VERSION OF THE PRECIP ANALYSIS. -! - - IMPLICIT NONE - INTEGER,INTENT(IN) :: MYPE,MPI_COMM_COMP & - ,MY_DOMAIN_ID & - ,IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE & - ,ITS_B1,ITE_B1,JTS_B2,JTE_B2 - INTEGER,INTENT(IN) :: PCPHR - REAL,DIMENSION(IDS:IDE,JDS:JDE) :: TEMPG - REAL,DIMENSION(IMS:IME,JMS:JME) :: TEMPL - REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: DDATA, LSPA - REAL,DIMENSION(IMS:IME,JMS:JME,1:PCPHR),INTENT(OUT) :: PPTDAT - INTEGER :: I, IER, IHR, J, N, NUNIT_PCP - CHARACTER*256 :: MESSAGE - CHARACTER(14) :: FILENAME - CHARACTER(6),SAVE :: FMT_ID='(I2.2)' & - ,FMT_HR='(I1.1)' - CHARACTER(2) :: CHAR_ID - CHARACTER(1) :: CHAR_HR - LOGICAL :: OPENED -!----------------------------------------------------------------------- -! -! Get the value of MYPE: -! -! - TEMPG=999. - IF(MYPE==0)THEN - write(0,*)'PCPHR=',PCPHR - write(0,*)'IDS,IDE,JDS,JDE in ADJPCP=',IDS,IDE,JDS,JDE - ENDIF -! - WRITE(CHAR_ID,FMT_ID)MY_DOMAIN_ID -! - hours: DO IHR=1,PCPHR -! - WRITE(CHAR_HR,FMT_HR)IHR - FILENAME='pcp.hr'//CHAR_HR//'.'//CHAR_ID//'.bin' -! - IF(MYPE==0)THEN -! - DO N=51,99 - INQUIRE(N,opened=OPENED) - IF(.NOT.OPENED)THEN - NUNIT_PCP=N - EXIT - ENDIF - ENDDO -! - CLOSE(NUNIT_PCP) -!rv OPEN(unit=NUNIT_PCP,file=FILENAME,form='UNFORMATTED' & -!rv ,STATUS='REPLACE',IOSTAT=IER) - OPEN(unit=NUNIT_PCP,file=FILENAME,form='UNFORMATTED',IOSTAT=IER) -!rv - IF(IER/=0)THEN - WRITE(0,*)' Failed to open ',FILENAME,' in READPCP ier=',IER - ENDIF - READ(NUNIT_PCP) ((TEMPG(I,J),I=IDS,IDE),J=JDS,JDE) -! WRITE(60+IHR,*)((TEMPG(I,J),I=IDS,IDE),J=JDS,JDE) - WRITE(0,*) 'IHR=', IHR, ' FINISHED READING PCP TO TEMPG' - CLOSE(NUNIT_PCP) -! - DO J=JDS,JDE - DO I=IDS,IDE -! In the binary version of the precip data, missing data are denoted as '999.' -! Convert the valid data from mm to m: - - IF (TEMPG(I,J).LT.900.) TEMPG(I,J)=TEMPG(I,J)*0.001 - ENDDO - ENDDO - ENDIF -! -! Distribute to local temp array: - CALL DSTRB(TEMPG,TEMPL,1,1,1,1,1,MYPE,MPI_COMM_COMP) -! -! Place into correct hour slot in PPTDAT: - - DO J=JMS,JME - DO I=IMS,IME - PPTDAT(I,J,IHR)=TEMPL(I,J) - ENDDO - ENDDO -! - IF(MYPE==0)THEN - WRITE(0,*) 'ADJPPT-READPCP, IHR',IHR, 'PPTDAT=', & - & PPTDAT(1,1,IHR) - ENDIF - - ENDDO hours -! -! Give DDATA (hourly precipitation analysis partitioned into each physics -! timestep; partitioning done in ADJPPT) an initial value of 999, because -! TURBL/SURFCE is called before ADJPPT. Also initialize LSPA to zero. -! - DDATA=999. - LSPA=0. -! - END SUBROUTINE READPCP -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE CHKSNOW(MYPE,NTSD,DT,NPHS,SR,PPTDAT,PCPHR & - ,IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE & - ,ITS_B1,ITE_B1,JTS_B2,JTE_B2) -! -! AT THE FIRST PHYSICS TIME STEP AFTER THE TOP OF EACH HOUR, CHECK THE SNOW -! ARRAY AGAINST THE SR (SNOW/TOTAL PRECIP RATIO). IF SR .GE. 0.9, SET THIS -! POINT TO MISSING (SO WE WON'T DO SNOW ADJUSTMENT HERE). -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - INTEGER,INTENT(IN) :: MYPE,NTSD,NPHS - INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE & - ,ITS_B1,ITE_B1,JTS_B2,JTE_B2 - INTEGER,INTENT(IN) :: PCPHR - REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: SR - REAL,DIMENSION(IMS:IME,JMS:JME,1:PCPHR),INTENT(INOUT) :: PPTDAT - REAL,INTENT(IN) :: DT - REAL :: TIMES - INTEGER :: I, J, IHR - CHARACTER*256 :: MESSAGE -!----------------------------------------------------------------------- - TIMES=NTSD*DT - IF (MOD(TIMES,3600.) < NPHS*DT) THEN - IHR=INT(TIMES)/3600+1 - IF (IHR > PCPHR) GO TO 10 - DO J=JTS_B2,JTE_B2 - DO I=ITS_B1,ITE_B1 - IF (SR(I,J) >= 0.9) PPTDAT(I,J,IHR) = 999. - ENDDO - ENDDO -! -! Get the value of MYPE: -! - IF (MYPE==0) THEN - WRITE(0,1010) TIMES,SR(1,1) - 1010 FORMAT('ADJPPT-CHKSNOW: TIMES, SR=',F6.0,1X,F6.4) - ENDIF - ENDIF - 10 CONTINUE - END SUBROUTINE CHKSNOW -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE ADJPPT(MYPE,NTSD,DT,NPHS,PREC,LSPA,PPTDAT,DDATA,PCPHR & - ,IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE & - ,ITS_B1,ITE_B1,JTS_B2,JTE_B2) - -!*********************************************************************** -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: ADJPPT PRECIPITATION/CLOUD ADJUSTMENT -! PRGRMMR: Y. LIN ORG: W/NP22 DATE: 2005/03/30 -! -! ABSTRACT: -! ADJPPT MAKES ADJUSTMENT TO MODEL'S TEMPERATURE, MOISTURE, HYDROMETEOR -! FIELDS TO BE MORE CONSISTENT WITH THE OBSERVED PRECIPITATION AND CLOUD -! TOP PRESSURE -! -! FOR NOW, AS A FIRST STEP, JUST PARTITION THE INPUT HOURLY PRECIPITATION -! OBSERVATION INTO TIME STEPS, AND FEED IT INTO THE SOIL. -! PROGRAM HISTORY LOG: -! -! 2005/03/30 LIN - BAREBONES PRECIPITATION PARTITION/FEEDING TO GROUND -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE : IBM -!$$$ -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- - INTEGER,INTENT(IN) :: MYPE,NPHS, NTSD - INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE & - ,ITS_B1,ITE_B1,JTS_B2,JTE_B2 - REAL,INTENT(IN) :: DT - INTEGER,INTENT(IN) :: PCPHR - REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: PREC - REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: DDATA, LSPA - REAL,DIMENSION(IMS:IME,JMS:JME,1:PCPHR),INTENT(IN) :: PPTDAT -!----------------------------------------------------------------------- -!*** -!*** LOCAL VARIABLES -!*** -!----------------------------------------------------------------------- - REAL :: DTPHS, FRACT, FRACT1, FRACT2, TIMES, TPHS1, TPHS2 - INTEGER :: I, J, IHR, IHR1, IHR2, NTSP - CHARACTER*256 :: MESSAGE -! -! Get the value of MYPE: -! -! - TIMES=NTSD*DT - IHR=INT(TIMES)/3600+1 -! Size of physics time step: - DTPHS=NPHS*DT -! -! Compute the beginning and ending time of the current physics time step, -! TPHS1 and TPHS2: -! - NTSP=NTSD/NPHS+1 - TPHS1=(NTSP-1)*DTPHS - TPHS2=NTSP*DTPHS -! - IHR1=INT(TPHS1)/3600+1 - IHR2=INT(TPHS2)/3600+1 -! -! Fraction of an hour that falls into IHR1 and IHR2. Note that IHR1 and IHR2 -! might be identical. - IF (IHR1 > PCPHR) THEN - GO TO 200 - ELSEIF (IHR2 > PCPHR) THEN - IHR2=3 - FRACT1=(3600.- MOD(INT(TPHS1),3600))/3600. - FRACT2=0. - ELSEIF (IHR1 .EQ. IHR2) THEN - FRACT1=0.5*DTPHS/3600. - FRACT2=FRACT1 - ELSE - FRACT1=(3600.- MOD(INT(TPHS1),3600))/3600. - FRACT2=FLOAT(MOD(INT(TPHS2),3600))/3600. - ENDIF -! - FRACT=FRACT1 + FRACT2 -! - IF (MYPE==0) THEN - WRITE(0,1010) NTSD,NTSP,TIMES,IHR1,IHR2,TPHS1,TPHS2, & - & FRACT1,FRACT2 - 1010 FORMAT('ADJPPT: NTSD,NTSP,TIMES=',I4,1X,I4,1X,F6.0,' IHR1,IHR2=' & - & ,I1,1X,I1,' TPHS1,TPHS2=',F6.0,1X,F6.0,' FRACT1,FRACT2=' & - & ,2(1X,F6.4)) - ENDIF -! -!----------------------------------------------------------------------- -! FRACT1/2 IS THE FRACTION OF IHR1/2'S PRECIP THAT WE WANT FOR -! THIS ADJUSTMENT (assuming that the physics time step spans over -! IHR1 and IHR2. If not, then IHR1=IHR2). -!----------------------------------------------------------------------- -! SET UP OBSERVED PRECIP FOR THIS TIMESTEP IN DDATA -!----------------------------------------------------------------------- -! - DO J=JTS_B2,JTE_B2 - DO I=ITS_B1,ITE_B1 -! Note sometimes IHR1=IHR2. - IF (PPTDAT(I,J,IHR1).GT.900..OR.PPTDAT(I,J,IHR2).GT.900.) THEN - DDATA(I,J) = 999. - LSPA(I,J) = LSPA(I,J) + PREC(I,J) - GO TO 100 - ELSE - IF (IHR2 .LE. PCPHR) then - DDATA(I,J) = PPTDAT(I,J,IHR1)*FRACT1 & - & + PPTDAT(I,J,IHR2)*FRACT2 - ELSE - DDATA(I,J) = PPTDAT(I,J,IHR1)*FRACT1 - ENDIF -! - LSPA(I,J) = LSPA(I,J) + DDATA(I,J) - ENDIF - IF (I.EQ.1 .AND. J.EQ.1 .AND. MYPE.EQ.0) THEN - WRITE(0,1020) DDATA(I,J), PREC(I,J), LSPA(I,J) - 1020 FORMAT('ADJPPT: DDATA=',E12.6, ' PREC=',E12.6,' LSPA=',E12.6) - ENDIF - - 100 CONTINUE - ENDDO - ENDDO -! - 200 CONTINUE - - END SUBROUTINE ADJPPT -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - END MODULE MODULE_PRECIP_ADJUST -! -!----------------------------------------------------------------------- diff --git a/src/nmm/module_QUASIPOST.F90 b/src/nmm/module_QUASIPOST.F90 deleted file mode 100644 index 0ade536..0000000 --- a/src/nmm/module_QUASIPOST.F90 +++ /dev/null @@ -1,854 +0,0 @@ -module module_quasipost - use module_RELAX4E - use module_REDUCTION - implicit none - private - - public :: quasipost - - integer, parameter :: npres = 33 - real, parameter :: badheight=-9e9 - - ! NCEP Unified Post standard pressure levels (SLPDEF) used for this - ! membrane MSLP calculation. These are ALL of the post pressure - ! levels up to 200mbar: - real, parameter :: post_stdpres(npres) = (/ 20000., & - 22500., 25000., 27500., 30000., 32500., 35000., 37500., 40000., & - 42500., 45000., 47500., 50000., 52500., 55000., 57500., 60000., & - 62500., 65000., 67500., 70000., 72500., 75000., 77500., 80000., & - 82500., 85000., 87500., 90000., 92500., 95000., 97500.,100000./) - - ! index within post_stdpres of the 850mbar, 700mbar and 500mbar - ! levels, respectively: - integer, parameter :: k850 = 27, k700=21, k500=13 - - ! Pressure "interface" levels, used only for interpolation. These - ! are half-way between pressure levels (post_stdpres) in pressure - ! space (instead of z, Z or density), to match assumptions made in - ! the post's Memberane MSLP calculation: - real, parameter :: post_istdpres(npres+1) = (/ 18750., & - 21250., 23750., 26250., 28750., 31250., 33750., 36250., 38750., & - 41250., 43750., 46250., 48750., 51250., 53750., 56250., 58750., & - 61250., 63750., 66250., 68750., 71250., 73750., 76250., 78750., & - 81250., 83750., 86250., 88750., 91250., 93750., 96250., 98750., & - 101250./) - - ! Constants from the NCEP Unified Post used for interpolation and - ! extrapolation: - real, parameter :: post_H1=1.0 - real, parameter :: post_PQ0=379.90516 - real, parameter :: post_A2=17.2693882 - real, parameter :: post_A3=273.16 - real, parameter :: post_A4=35.86 - real, parameter :: post_D608=0.608 - real, parameter :: post_RD=287.04 - real, parameter :: post_G=9.81 - real, parameter :: post_GAMMA=6.5E-3 - real, parameter :: post_RGAMOG=post_RD*post_GAMMA/post_G - real, parameter :: post_RHmin=1.0E-6 ! minimal RH bound - real, parameter :: post_smallQ=1.E-12 - - real, parameter :: post_slope=-6.6e-4 ! K/km - - REAL, PARAMETER :: old_COEF3=post_RD*post_SLOPE - REAL, PARAMETER :: old_COEF2=-1./old_COEF3 - - type TRACKER_DATA - integer :: ids,ide,jds,jde,kds,kde - integer :: ims,ime,jms,jme,kms,kme - end type TRACKER_DATA - - -contains - subroutine quasipost_message(what) - character*(*), intent(in) :: what - print "('Quasipost: ',A)",trim(what) - end subroutine quasipost_message - - subroutine quasipost(grid) - use MODULE_SOLVER_INTERNAL_STATE, only : SOLVER_INTERNAL_STATE - type(solver_internal_state), intent(inout) :: grid - integer :: ids,ide,jds,jde,kds,kde, & - ims,ime,jms,jme,kms,kme, & - ips,ipe,jps,jpe,kps,kpe - ids=grid%ids ; jds=grid%jds ; kds=1 - ide=grid%ide ; jde=grid%jde ; kde=grid%LM - ims=grid%ims ; jms=grid%jms ; kms=1 - ime=grid%ime ; jme=grid%jme ; kme=grid%LM - ips=grid%its ; jps=grid%jts ; kps=1 - ipe=grid%ite ; jpe=grid%jte ; kpe=grid%LM - call quasipost_impl(grid,ids,ide,jds,jde,kds,kde,& - ims,ime,jms,jme,kms,kme,& - ips,ipe,jps,jpe,kps,kpe) - end subroutine quasipost - - subroutine quasipost_impl(grid,ids,ide,jds,jde,kds,kde,& - ims,ime,jms,jme,kms,kme,& - ips,ipe,jps,jpe,kps,kpe) - use MODULE_SOLVER_INTERNAL_STATE, only : SOLVER_INTERNAL_STATE - use module_exchange, only: halo_exch - use MPI - implicit none - - ! ------------------------------ - - type(SOLVER_INTERNAL_STATE), intent(inout) :: grid - integer :: ids,ide,jds,jde,kds,kde, & - ims,ime,jms,jme,kms,kme, & - ips,ipe,jps,jpe,kps,kpe - real :: presTv(ims:ime,jms:jme,npres), Pmsl(ims:ime,jms:jme) - real :: presZ(ims:ime,jms:jme,npres) - integer :: relaxmask(ims:ime,jms:jme) - real :: relaxwork(ims:ime,jms:jme) - real :: interP(ims:ime,jms:jme,npres+1) - real(kind=8) :: dum8 - integer :: ground_mask(ims:ime,jms:jme,npres) - integer :: ground_level(ims:ime,jms:jme) - integer :: ipres,i,j,mpres,imin,jmin,k,need_to_relax,imax,jmax,ierr - real :: pmin - - ! Make sure the three constant pressure level values are right: -100 format('In module_membrane_mslp, post_stdpres(',A,')=',F0.3,& - ' but should be ',F0.3) - if(abs(post_stdpres(k850)-85000.)>1) then - write(0,100) 'k850',post_stdpres(k850),85000. - call mpi_abort(MPI_COMM_WORLD,1,ierr) - endif - if(abs(post_stdpres(k700)-70000.)>1) then - write(0,100) 'k700',post_stdpres(k700),70000. - call mpi_abort(MPI_COMM_WORLD,1,ierr) - endif - if(abs(post_stdpres(k500)-50000.)>1) then - write(0,100) 'k500',post_stdpres(k500),50000. - call mpi_abort(MPI_COMM_WORLD,1,ierr) - endif - - if(size(grid%p700rv)>1) then - ! Need a halo for winds in order to get vorticity and H point wind magnetudes: - call HALO_EXCH(grid%V10,1,grid%U10,1,3,3) - endif - - ! UPPER BOUND: MPRES - - ! Find mpres: the lowest pressure that we need to handle. This is - ! mostly for efficiency: we don't need to interpolate or relax - ! anything higher in the atmosphere than the next pressure level - ! above the domain-wide lowest surface pressure: - call reduce(grid,pmin,grid%PINT,grid%LM,REDUCE_MIN,& - ims,ime,jms,jme,kms,kme) - - ! FIXME: DON'T HANDLE ANYTHING ABOVE PMIN - ! NOTE: MUST HANDLE TWO LEVELS ABOVE - - ! Step 1: calculate Tv, Q and Z on pressure levels using the same - ! method as the NCEP Unified Post: - call calculate_3D(grid,presTv,presZ,ground_mask,ground_level, & - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - IPS,IPE,JPS,JPE,KPS,KPE) - - ! Step 2: smooth Tv through an overrelaxation method: - - ! Modify the relax mask so that the outermost three rows and - ! columns are always relaxed. This is needed to overcome bad - ! values fed in from the parent every timestep. Setting the mask - ! to true on the boundaries of the domain prevent them from being - ! used as boundaries of the overrelaxation. - - ! Some of the reasons for boundary issues: The parent and nest - ! terrain will never match because the nest terrain is smoothed on - ! the boundary, and the parent is not. Also, the user may have - ! set a different terrain data source for different domains, in - ! which case you'll get an even worse mismatch. Every time the - ! nest moves, terrain changes on the leading and trailing edges of - ! the nest. That causes huge shocks when there are high mountains - ! near the boundaries. If you do a plot of 500mbar geopotential - ! height, it looks like a piece of jello shaking every time the - ! nest moves. Also, there is some weirdness on the lateral - ! boundaries of the outermost domain due to the mismatch between - ! GFS terrain (which has its higher spectral components discarded) - ! and the smoothed regional terrain. - - relaxmask=1 - - ! Now loop over all vertical levels and relax them: - do ipres=npres,1,-1 - ! In the inner regions (all but outermost row & col) set the - ! relaxmask to the ground_mask: - need_to_relax=0 - do j=max(jps,jds+1),min(jde-1,jpe) - do i=max(ips,ids+1),min(ide-1,ipe) - relaxmask(i,j)=ground_mask(i,j,ipres) - if(relaxmask(i,j)/=0) need_to_relax=1 - enddo - enddo - - ! If we do not need to relax any points, we are done. - call max_integer(grid,need_to_relax) - if(need_to_relax==0) then -! 38 format('end mslp relax loop at ',I0) -! print 38,ipres - exit - endif - - ! Store Tv in relaxwork: - do j=jps,jpe - do i=ips,ipe - relaxwork(i,j)=presTv(i,j,ipres) - enddo - enddo - - ! Overrelax: - call relax4e(relaxwork,relaxmask,0.7,100, & - IDS,IDE,JDS,JDE, & - IMS,IME,JMS,JME, & - IPS,IPE,JPS,JPE) - - ! Copy back the modified relaxation mask - do j=jps,jpe - do i=ips,ipe - ground_mask(i,j,ipres)=relaxmask(i,j) - enddo - enddo - - ! Copy the relaxed values back to Tv: - do j=jps,jpe - do i=ips,ipe - presTv(i,j,ipres)=relaxwork(i,j) - enddo - enddo - end do - - ! Step 3: Solve for Z on interface levels (pressure space - ! interface levels) using the hydrostatic equation. Once Z=0 is - ! reached, solve for Pmsl. - call calculate_interP(presTv,presZ,grid%Z,Pmsl,grid%PINT, & - grid%T(:,:,kde), grid%Q(:,:,kde), & - ground_level,ground_mask,grid%fis, & - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - IPS,IPE,JPS,JPE,KPS,KPE) - - ! Copy the MSLP values back to the grid: - do j=jps,jpe - do i=ips,ipe - grid%membrane_MSLP(i,j)=Pmsl(i,j) - enddo - enddo - - ! Smooth the membrane_mslp values: - call smoothMSLP(grid,1,relaxmask,relaxwork, & - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - IPS,IPE,JPS,JPE,KPS,KPE) - - if(size(grid%p850z)>1) then - ! Copy 700 and 850 mbar heights to their arrays: - do j=jps,jpe - do i=ips,ipe - grid%p850z(i,j)=presZ(i,j,k850) - grid%p700z(i,j)=presZ(i,j,k700) - enddo - enddo - endif - - end subroutine quasipost_impl - - subroutine calculate_3D(grid,presTv,presZ,ground_mask,ground_level, & - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - IPS,IPE,JPS,JPE,KPS,KPE) - use MODULE_SOLVER_INTERNAL_STATE, only : SOLVER_INTERNAL_STATE - use mpi, only: MPI_COMM_WORLD,MPI_Abort - use module_exchange, only: halo_exch - implicit none - - type(SOLVER_INTERNAL_STATE), intent(inout) :: grid - - integer, intent(in) :: IDS,IDE,JDS,JDE,KDS,KDE - integer, intent(in) :: IMS,IME,JMS,JME,KMS,KME - integer, intent(in) :: IPS,IPE,JPS,JPE,KPS,KPE - - real, intent(inout) :: presTv(ims:ime,jms:jme,npres) - real, intent(inout) :: presZ(ims:ime,jms:jme,npres) - - integer, intent(inout) :: ground_mask(ims:ime,jms:jme,npres) - integer, intent(inout) :: ground_level(ims:ime,jms:jme) - - integer :: Tkdest(ims:ime,jms:jme), Zkdest(ims:ime,jms:jme), Zbottom(ims:ime,jms:jme) - integer :: i,j,ks,kd,k - real :: weight, TL,QL,PL, tempT, RHL, TVRL, TVRBLO, TBLO,QBLO - - integer,target, dimension(ims:ime,jms:jme) :: ks850,ks700,ks500 - real, target,dimension(ims:ime,jms:jme) :: dummy1,dummy2 - integer, pointer, dimension(:,:) :: ksX - integer :: nanfound,ierr,iref,jref,b - real, pointer, dimension(:,:) :: preswind,presrv,presu,presv - - real :: Pmass(ims:ime,jms:jme,kds:kde) - real :: numsum,densum,modelP1,modelP2,pdiff,presQ,presT,ZL,QSAT, U1, V1, U2, V2, dudy1,dvdx1, dudy2,dvdx2 - character*255 :: message - logical :: wantuv - !call quasipost_message('calculate3D') - call HALO_EXCH(grid%u10,1,grid%U,grid%LM,2,2) - call HALO_EXCH(grid%v10,1,grid%V,grid%LM,2,2) - - ! ks: k in source (model level) array - ! kd: k in destination (pressure level) array - ground_level=0 - ground_mask=0 - Zkdest=1 - Tkdest=1 - - ks850=0 - ks700=0 - ks500=0 - - ! Interpolate geopotential height to post_stdpres pressure levels - ! and create a temporary array with non-hydrostatic pressure - ! (PINT) on model mass points: - do ks=kds+1,kde - do j=jps,jpe - iZ: do i=ips,ipe - Pmass(i,j,ks)=sqrt(grid%PINT(i,j,ks)*grid%PINT(i,j,ks+1)) - enddo iZ - enddo - enddo - - ! Interpolate temperature and specific humidity to post_stdpres - ! pressure levels: - do ks=kds+1,kde-1 - do j=jps,jpe - iTQ: do i=ips,ipe - kd=Tkdest(i,j) - if(kd<=npres) then - innerTQ: do while(kd<=npres) - if(.not.(post_stdpres(kd)<=Pmass(i,j,ks+1) & - .and. post_stdpres(kd)>=Pmass(i,j,ks))) then - cycle iTQ - endif - weight=log(post_stdpres(kd)/Pmass(i,j,ks))/log(Pmass(i,j,ks+1)/Pmass(i,j,ks)) - - presZ(i,j,kd)=weight*grid%Z(i,j,ks+1) + (1.-weight)*grid%Z(i,j,ks) - - presT=weight*grid%T(i,j,ks+1) + (1.-weight)*grid%T(i,j,ks) - presQ=weight*grid%Q(i,j,ks+1) + (1.-weight)*grid%Q(i,j,ks) - presTv(i,j,kd)=presT*(1.+post_D608*presQ) - - if(kd==k850) then - ks850(i,j)=ks - elseif(kd==k700) then - ks700(i,j)=ks - elseif(kd==k500) then - ks500(i,j)=ks - endif - -103 format('interp ks=',I0,' kd=',I0,' presT(i=',I0,',j=',I0,',kd)=',F0.3, & - ' between T(i,j,ks-1)=',F0.3,' and T(i,j,ks)=', & - F0.3,' using weight=',F0.3) - !write(message,103) ks,kd,i,j,presT,grid%T(i,j,ks-1),grid%T(i,j,ks),weight - !call quasipost_message(message) -104 format(' Pmass(i,j,ks)=',F0.3,' Pmass(i,j,ks-1)=',F0.3,' post_stdpres(kd)=',F0.3) - !write(message,104) Pmass(i,j,ks),Pmass(i,j,ks-1),post_stdpres(kd) - !call quasipost_message(message) - if(weight<0 .or. weight>1) then - write(0,*) 'Bad weight: ',weight - call MPI_Abort(MPI_COMM_WORLD,1,ierr) - endif - kd=kd+1 - Tkdest(i,j)=kd - Zkdest(i,j)=kd - end do innerTQ - end if - end do iTQ - end do - end do - - ! Interpolate to regions between the middle of the lowest mass - ! level and the bottom of the atmosphere: - do j=jps,jpe - iTQ2: do i=ips,ipe - kd=Zkdest(i,j) - if(kd<=npres) then - do while(kd<=npres) - if(.not.(post_stdpres(kd)<=grid%PINT(i,j,kde+1) & - .and. post_stdpres(kd)>=Pmass(i,j,kde))) then - cycle iTQ2 - endif - - presT=grid%T(i,j,kde) - presQ=grid%Q(i,j,kde) - presTv(i,j,kd)=presT*(1.+post_D608*presQ) - - weight=log(post_stdpres(kd)/Pmass(i,j,kde))/log(grid%PINT(i,j,kde+1)/Pmass(i,j,kde)) - presZ(i,j,kd)=(1.-weight)*grid%Z(i,j,kde)+weight*grid%fis(i,j)/post_g - - kd=kd+1 - Tkdest(i,j)=kd - Zkdest(i,j)=kd - end do - end if - end do iTQ2 - end do - -1234 format('grid size(',A,') = ',I0) - !print 1234, 'grid%p700rv',size(grid%p700rv) - !print 1234, 'grid%p700u',size(grid%p700u) - - ! do I need to calc. presu & presv? Yes. - wantuv=.true. ! WAS: (grid%vortex_tracker == 7) - - ifwind: if(size(grid%p700rv)>1 .or. size(grid%p700u)>1) then - ! Interpolate wind to H points on pressure levels, calculating - ! horizontal wind vector magnitude and vertical component of - ! vorticity. Interpolate only to 700 and 850 mbar, except for U & - ! V which are also interpolated to 500mbar. - nullify(presu) - nullify(presv) - windloop: do k=0,2 - if(k==0) then - ! Only need wind components at 500 mbar - kd=k500 - ksX=>ks500 - preswind=>dummy1 - presrv=>dummy2 - if(wantuv) then - presu=>grid%p500u - presv=>grid%p500v - endif - elseif(k==1) then - ksX=>ks700 - preswind=>grid%p700wind - presrv=>grid%p700rv - kd=k700 - if(wantuv) then - presu=>grid%p700u - presv=>grid%p700v - endif - elseif(k==2) then - ksX=>ks850 - kd=k850 - preswind=>grid%p850wind - presrv=>grid%p850rv - if(wantuv) then - presu=>grid%p850u - presv=>grid%p850v - endif - endif - - ! No wind on boundaries: - if(jps<=jds) then - do i=ips,ipe - preswind(i,jds)=0 - presrv(i,jds)=0 - enddo - if(wantuv) then - do i=ips,ipe - presu(i,jds)=0 - presv(i,jds)=0 - enddo - endif - endif - if(jpe>=jde-1) then - do i=ips,ipe - preswind(i,jde-1)=0 - presrv(i,jde-1)=0 - enddo - if(wantuv) then - do i=ips,ipe - presu(i,jde-1)=0 - presv(i,jde-1)=0 - enddo - endif - endif - if(ips<=ids) then - do j=jps,jpe - preswind(ids,j)=0 - presrv(ids,j)=0 - enddo - if(wantuv) then - do j=jps,jpe - presu(ids,j)=0 - presv(ids,j)=0 - enddo - endif - endif - if(ipe>=ide-1) then - do j=jps,jpe - preswind(ide-1,j)=0 - presrv(ide-1,j)=0 - enddo - if(wantuv) then - do j=jps,jpe - presu(ide-1,j)=0 - presv(ide-1,j)=0 - enddo - endif - endif - - ! Interpolate winds: - do j=max(jps,jds+1),min(jde-2,jpe) - do i=max(ips,ids+1),min(ide-2,ipe) - ks=ksX(i,j) - if(ks>1) then - ! Interpolate between mass levels: - weight=log(post_stdpres(kd)/Pmass(i,j,ks))/log(Pmass(i,j,ks+1)/Pmass(i,j,ks)) - - U1=0.25*(grid%u(i,j-1,ks) + grid%u(i,j,ks) + grid%u(i-1,j,ks) + grid%u(i-1,j-1,ks)) - V1=0.25*(grid%v(i,j-1,ks) + grid%v(i,j,ks) + grid%v(i-1,j,ks) + grid%v(i-1,j-1,ks)) - U2=0.25*(grid%u(i,j-1,ks+1) + grid%u(i,j,ks+1) + grid%u(i-1,j,ks+1) + grid%u(i-1,j-1,ks+1)) - V2=0.25*(grid%v(i,j-1,ks+1) + grid%v(i,j,ks+1) + grid%v(i-1,j,ks+1) + grid%v(i-1,j-1,ks+1)) - - dvdx1 = (grid%v(i+1,j,ks)-grid%v(i-1,j,ks))/(2.*grid%DXH(j)) - dudy1 = (grid%u(i,j+1,ks)-grid%u(i,j-1,ks))/(2.*grid%DYH) - dvdx2 = (grid%v(i+1,j,ks+1)-grid%v(i-1,j,ks+1))/(2.*grid%DXH(j)) - dudy2 = (grid%u(i,j+1,ks+1)-grid%u(i,j-1,ks+1))/(2.*grid%DYH) - - if(wantuv) then - presu(i,j)=weight*u2+(1.-weight)*u1 - presv(i,j)=weight*v2+(1.-weight)*v1 - endif - preswind(i,j)=weight*sqrt(u2*u2+v2*v2) + (1.-weight)*sqrt(u1*u1+v1*v1) - presrv(i,j)=(dvdx2-dudy2)*weight + (dvdx1-dudy1)*(1.-weight) - elseif(post_stdpres(kd)>=Pmass(i,j,kds)) then - ! At and below lowest mass level, use lowest model level winds - ks=1 - U1=0.25*(grid%u(i,j-1,ks) + grid%u(i-1,j,ks) + grid%u(i,j,ks) + grid%u(i-1,j-1,ks)) - V1=0.25*(grid%v(i,j-1,ks) + grid%v(i-1,j,ks) + grid%v(i,j,ks) + grid%v(i-1,j-1,ks)) - - dvdx1 = (grid%v(i+1,j,ks)-grid%v(i-1,j,ks))/(2.*grid%DXH(j)) - dudy1 = (grid%u(i,j+1,ks)-grid%u(i,j-1,ks))/(2.*grid%DYH) - - preswind(i,j)=sqrt(u1*u1 + v1*v1) - presrv(i,j)=dvdx1-dudy1 - if(wantuv) then - presu(i,j)=u1 - presv(i,j)=v1 - endif - endif - end do - end do - - ! Copy wind-related fields to boundary points. - do b=1,3 - if (b==1) then ; i=ids ; iref=ids+1 - elseif(b==2) then ; i=ide-1 ; iref=ide-2 - elseif(b==3) then ; i=ide ; iref=ide-2 - endif - if(i<=ipe .and. i>=ips) then - do j=max(jps,jds+1),min(jde-2,jpe) - if(wantuv) then - presu(i,j)=presu(iref,j) - presv(i,j)=presv(iref,j) - endif - presrv(i,j)=presrv(iref,j) - preswind(i,j)=preswind(iref,j) - enddo - endif - enddo - - do b=1,3 - if (b==1) then ; j=jds ; jref=jds+1 - elseif(b==2) then ; j=jde-1 ; jref=jde-2 - elseif(b==3) then ; j=jde ; jref=jde-2 - endif - if(j<=jpe .and. j>=jps) then - do i=ips,ipe - if(wantuv) then - presu(i,j)=presu(i,jref) - presv(i,j)=presv(i,jref) - endif - presrv(i,j)=presrv(i,jref) - preswind(i,j)=preswind(i,jref) - enddo - endif - enddo - enddo windloop - - ! Calculate 10m wind magnitude and vorticity - ! NOTE: u10 and v10 are already on H points - nanfound=0 - do j=max(jps,jds+1),min(jpe,jde-1) - do i=max(ips,ids+1),min(ipe,ide-1) - grid%m10wind(i,j)=sqrt(grid%u10(i,j)*grid%u10(i,j) + grid%v10(i,j)*grid%v10(i,j)) - dvdx1 = (grid%v10(i+1,j)-grid%v10(i-1,j)) / (2*grid%DXH(j)) - dudy1 = (grid%u10(i,j+1)-grid%u10(i,j-1)) / (2*grid%DYH) - grid%m10rv(i,j) = dvdx1 - dudy1 - if(grid%m10rv(i,j) == grid%m10rv(i,j)) then - continue - else -3088 format('NaN m10rv at i=',I0,' j=',I0,' dx=',F0.3,' dy=',F0.3) - write(0,3088) i,j,grid%DXH(j),grid%DYH - call MPI_Abort(MPI_COMM_WORLD,1,ierr) -3089 format('NaN m10rv at i=',I0,' j=',I0,': dvdx1=',F0.5,' dudy=',F0.5) - write(0,3089) i,j,dvdx1,dudy1 - call MPI_Abort(MPI_COMM_WORLD,1,ierr) - nanfound=1 - endif - enddo - enddo - - call max_integer(grid,nanfound) - if(nanfound/=0) then - write(0,*) 'ERROR: NaN m10rv seen; aborting.' - call MPI_Abort(MPI_COMM_WORLD,1,ierr) - endif - endif ifwind - - do j=jps,jpe - do i=ips,ipe - ground_level(i,j)=min(Zkdest(i,j),Tkdest(i,j)) - enddo - enddo - - do kd=1,npres - do j=jps,jpe - do i=ips,ipe - if(kd>=ground_level(i,j)) then - ground_mask(i,j,kd) = 1 - else - ground_mask(i,j,kd) = 0 - endif - enddo - enddo - enddo - - if(50>=ips .and. 50<=ipe .and. 50>=jps .and. 50<=jpe) then - !print *,'Z(50,50) = ',grid%Z(50,50,:) - endif - - ! Extrapolate below-ground temperature but not height. Fill in - ! badheight for height below ground. - jloop2: do j=jps,jpe - iloop2: do i=ips,ipe - if(ground_level(i,j)>npres) then -301 format('Extrap: i=',I0,' j=',I0,' NO EXTRAP: ground at ',I0) - !write(message,301) i,j,ground_level(i,j) - !call quasipost_message(message) - cycle iloop2 - else -302 format('Extrap: i=',I0,' j=',I0,' extrap from ',F0.3,' ground at ',I0) - !write(message,302) i,j,post_stdpres(ground_level(i,j)),ground_level(i,j) - !call quasipost_message(message) - endif - kloop2: do kd=ground_level(i,j),npres - ! Extrapolate first guess below-ground values using the - ! exact same method used in the post. Even the constants - ! are copied from the post: - PL=grid%PINT(I,J,kde-1) - ZL=0.5*(grid%Z(I,J,kde-1)+grid%Z(I,J,kde)) - TL=0.5*(grid%T(I,J,kde-1)+grid%T(I,J,kde)) - QL=0.5*(grid%Q(I,J,kde-1)+grid%Q(I,J,kde)) - QSAT=post_PQ0/PL*EXP(post_A2*(TL-post_A3)/(TL-post_A4)) - ! - RHL=QL/QSAT - ! - IF(RHL.GT.1.)THEN - RHL=1. - QL =RHL*QSAT - ENDIF - ! - IF(RHL.LT.post_RHmin)THEN - RHL=post_RHmin - QL =RHL*QSAT - ENDIF - ! - TVRL =TL*(1.+post_D608*QL) - TVRBLO=TVRL*(post_stdpres(kd)/PL)**post_RGAMOG - TBLO =TVRBLO/(1.+post_D608*QL) - - !QSAT=post_PQ0/post_stdpres(kd)*EXP(post_A2*(TBLO-post_A3)/(TBLO-post_A4)) - - !QBLO =RHL*QSAT - !presQ(i,j,kd)=AMAX1(post_smallQ,QBLO) - - presTv(i,j,kd)=TBLO - - ! Extrapolated virtual temperature: - !presTv(i,j,kd)=TBLO*(1.+post_D608*QBLO) - - ! extrapolated temperature, with virtual part removed using extrapolated specific humidity: - !presTv(i,j,kd)=TVRBLO/(1.+post_D608*QBLO) - - ! Below-ground Z is recalcluated after smoothing Tv. We - ! only fill in badval here: - presZ(i,j,kd)=badheight - -303 format('Extrap i=',I0,' j=',I0,' kd=',I0,' presTv=',F0.3,' presZ=',F0.3) -304 format(' TL=',F0.3,' QL=',F0.3,' ZL=',F0.3,' QSAT=',F0.3) -305 format(' TVRL=',F0.3,' TVRBLO=',F0.3,' TBLO=',F0.3,' RHL=',F0.3) - !write(0,303) i,j,kd,presTv(i,j,kd),presZ(i,j,kd) - !write(0,304) TL,QL,ZL,QSAT - !write(0,305) TVRL,TVRBLO,TBLO,RHL - enddo kloop2 - enddo iloop2 - enddo jloop2 - end subroutine calculate_3D - - subroutine calculate_interP( & - presTv,presZ,modelZ,Pmsl,PINT,T1,Q1, & - ground_level,ground_mask,fis, & - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - IPS,IPE,JPS,JPE,KPS,KPE) - - USE MPI, only: MPI_Abort,MPI_COMM_WORLD - implicit none - - integer, intent(in) :: IDS,IDE,JDS,JDE,KDS,KDE - integer, intent(in) :: IMS,IME,JMS,JME,KMS,KME - integer, intent(in) :: IPS,IPE,JPS,JPE,KPS,KPE - - real, intent(in) :: PINT(ims:ime,jms:jme,kms:kme+1), modelZ(ims:ime,jms:jme,kms:kme) - real, intent(in) :: T1(ims:ime,jms:jme,1) - real, intent(in) :: Q1(ims:ime,jms:jme,1) - - real, intent(in) :: fis(ims:ime,jms:jme) - real, intent(out) :: Pmsl(ims:ime,jms:jme) - real, intent(inout) :: presTv(ims:ime,jms:jme,npres) - real, intent(inout) :: presZ(ims:ime,jms:jme,npres) - - integer, intent(inout) :: ground_mask(ims:ime,jms:jme,npres) - integer, intent(inout) :: ground_level(ims:ime,jms:jme) - - real :: Z,midTv,dZ,newZ,P,newP,TVRT,TLYR,DIS,oa,slope - integer :: kp,ip,i,j,ierr - - ! What this code does: - - ! For every point where the surface is above Z=0, we start from - ! the lowest above-ground pressure and integrate the hydrostatic - ! equation downward to find P at Z=0. - - ! For points where the surface Z<=0 (surface is at or below sea - ! level), we interpolate to get P at Z=0. - - - ! STEP 1: extrapolate below-ground values - do j=jps,jpe - iloop: do i=ips,ipe - ! nearground: if(modelZ(i,j,1)<50.0) then - ! Pmsl(i,j)=pint1(i,j,1) - ! method(i,j)=-30 - ! else - if(ground_level(i,j)=0 Tv=',F0.3,' P=',F0.3,' newP=',F0.3,' kp=',I0) - write(0,80881) i,j,dZ,midTv,P,newP,kp - call MPI_Abort(MPI_COMM_WORLD,1,ierr) - endif - newZ=Z+dZ - presZ(i,j,ip+1)=newZ - if(newZ<=0) then - ! interpolate between Z and newZ -1022 format(' extrap using ',F0.3,'/exp(-',F0.3,'*',F0.3,'/(',F0.3,'*',F0.3,'))') - !write(0,1022) P,Z,post_G,post_RD,presTV(i,j,ip) - - - !Pmsl(i,j)=P/exp(-Z*post_G/(post_RD*presTv(i,j,ip))) - Pmsl(i,j)=(Z*newP-newZ*P)/(-dZ) -10221 format(' result: ',F0.3) - !write(0,10221) Pmsl(i,j) -! method(i,j)=ip - cycle iloop - endif - enddo - endif - ! If we get here, then Z=0 is below the lowest standard - ! pressure level and we must extrapolate. - - ! if(pint1(i,j,1)>post_stdpres(npres) .and. modelZ(i,j,1)>0.)then - ! ! Model surface pressure is a higher pressure than the - ! ! highest standard pressure level. Use the model - ! ! fields to extrapolate. - ! TVRT=T1(I,J,1)*(post_H1+post_D608*Q1(I,J,1)) - ! !DIS=modelZ(I,J,kde-1)-modelZ(I,J,1)+0.5*modelZ(I,J,kde-1) ??? - ! DIS=0.5*(modelZ(I,J,kde-1)+modelZ(I,J,1)) - ! TLYR=TVRT-DIS*post_SLOPE*post_G*0.5 - ! Pmsl(I,J)=PINT(I,J,1)*EXP((modelZ(I,J,1))*post_G/(post_RD*TLYR)) - ! ! 1023 format(' use model: TVRT=',F0.3,' DIS=',F0.3,' TLYR=',F0.3,' Pmsl=',F0.3) - ! ! 1024 format(' result: ',F0.3,'*EXP(',F0.3,'/(',F0.3,'*',F0.3'))') - ! ! write(0,1023) TVRT,DIS,TLYR,Pmsl(i,j) - ! ! write(0,1024) PINT(I,J,1),modelZ(I,J,kde-1),post_RD,TLYR - ! method(i,j)=-20 - ! ELSE - ! Highest pressure level (post_stdpres(1)) has a - ! higher pressure than the model surface pressure, so - ! extrapolate using the pressure level values. -1025 format(' use npres: TLYR=',F0.3,' Pmsl=',F0.3) -1026 format(' result: ',F0.3,'/EXP(-',F0.3,'*',F0.3,'/(',F0.3,'*',F0.3,'))') - TLYR=presTv(I,J,npres)-presZ(I,J,npres)*post_SLOPE*post_G*0.5 - Pmsl(I,J)=post_stdpres(npres)/EXP(-presZ(I,J,npres)*post_G/(post_RD*TLYR)) - !oa=0.5*post_SLOPE*post_g*presZ(i,j,npres)/TLYR - !Pmsl(i,j)=post_stdpres(npres)*(1.-oa)**old_coef2 - !write(0,1025) TLYR,Pmsl(I,J) - !write(0,1026) post_stdpres(npres),presZ(I,J,npres),post_G,post_RD,TLYR -! method(i,j)=-10 - ! END IF - ! endif nearground - enddo iloop - enddo - end subroutine calculate_interP - - subroutine smoothMSLP(grid,iterations,relaxmask,relaxwork, & - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - IPS,IPE,JPS,JPE,KPS,KPE) - use module_relax4e - use MODULE_SOLVER_INTERNAL_STATE, only : SOLVER_INTERNAL_STATE - implicit none - type(solver_internal_state), intent(inout) :: grid - integer, intent(in) :: iterations - integer :: relaxmask(ims:ime,jms:jme) - real :: relaxwork(ims:ime,jms:jme) - - integer :: IDS,IDE,JDS,JDE,KDS,KDE - integer :: IMS,IME,JMS,JME,KMS,KME - integer :: IPS,IPE,JPS,JPE,KPS,KPE - integer :: i,j - - do j=jps,jpe - do i=ips,ipe - relaxmask(i,j)=1 - relaxwork(i,j)=grid%membrane_mslp(i,j) - enddo - enddo - - call relax4e(relaxwork,relaxmask,0.5,iterations, & - IDS,IDE,JDS,JDE, & - IMS,IME,JMS,JME, & - IPS,IPE,JPS,JPE) - - do j=jps,jpe - do i=ips,ipe - grid%membrane_mslp(i,j)=relaxwork(i,j) - enddo - enddo - - end subroutine smoothMSLP - -end module module_quasipost diff --git a/src/nmm/module_RADIATION.F90 b/src/nmm/module_RADIATION.F90 deleted file mode 100644 index 088fdd9..0000000 --- a/src/nmm/module_RADIATION.F90 +++ /dev/null @@ -1,1141 +0,0 @@ -!----------------------------------------------------------------------- -! - MODULE MODULE_RADIATION -! -!----------------------------------------------------------------------- -! -!*** THE RADIATION DRIVERS AND PACKAGES -! -!--------------------- -!--- Modifications --- -!--------------------- -! 2010-04-02 Vasic - Removed WFR driver -!----------------------------------------------------------------------- -! - USE MODULE_KINDS - USE MODULE_MY_DOMAIN_SPECS - USE MODULE_RA_GFDL,ONLY : GFDL,CAL_MON_DAY,ZENITH - USE MODULE_RA_RRTM,ONLY : RRTM - USE MODULE_CONSTANTS,ONLY : CAPPA,CP,EPSQ,G,P608,PI,R_D,STBOLT -! - USE MODULE_DM_PARALLEL,ONLY : LOOPLIMITS -! - USE MODULE_CONTROL,ONLY : NMMB_FINALIZE - - USE module_mp_thompson, ONLY : cal_cldfra3 - - use module_radiation_driver_nmmb, only : radupdate_nmmb - use machine, only : kind_phys - -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: RADIATION -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** THE RADIATION PACKAGE OPTIONS -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!*** Shortwave -! - INTEGER,PARAMETER :: GFDLSWSCHEME=99 & !<--- (GFDL) - ,SWRADSCHEME=1 & !<--- (Dudhia, WRF) - ,GSFCSWSCHEME=2 & !<--- (Goddard, WRF) - ,RRTMSWSCHEME=3 !<--- (RRTM) -! -!*** Longwave -! - INTEGER,PARAMETER :: GFDLLWSCHEME=99 & !<--- (GFDL) - ,RRTMLWSCHEME=3 !<--- (RRTM) -! -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- - SUBROUTINE RADIATION(ITIMESTEP,DT,JULDAY,JULYR,XTIME,JULIAN & - & ,IHRST,NPHS,GLAT,GLON & - & ,NRADS,NRADL & - & ,DSG2,SGML2,SG2,PDSG1,PSGML1,PSG1,PT,PD & - & ,T,Q & - & ,THS,ALBEDO & - & ,QC,QR,QI,QS,QG,NI & - & ,F_QC,F_QR,F_QI,F_QS,F_QG,F_NI & - & ,NUM_WATER & - & ,SM,CLDFRA & - & ,RLWTT,RSWTT & - & ,RLWIN,RSWIN & - & ,RSWINC,RSWOUT & - & ,RLWTOA,RSWTOA & - & ,CZMEAN,SIGT4 & - & ,CFRACL,CFRACM,CFRACH & - & ,ACFRST,NCFRST & - & ,ACFRCV,NCFRCV & - & ,CUPPT,SNOW & - & ,HTOP,HBOT & - & ,SHORTWAVE,LONGWAVE & - & ,CLDFRACTION & - & ,DYH & -! - & ,DT_INT,JDAT & - & ,CW,O3 & - & ,F_ICE,F_RAIN & - & ,F_RIMEF & - & ,SI,TSKIN & - & ,Z0,SICE & - & ,MXSNAL,SGM & - & ,STDH,OMGALF & - & ,SNOWC & - & ,LM) -!----------------------------------------------------------------------- -!*** NOTE *** -! RLWIN - downward longwave at the surface (=GLW) -! RSWIN - downward shortwave at the surface (=XXX) -! RSWINC - CLEAR-SKY downward shortwave at the surface (=SWDOWN, new for AQ) -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: RADIATION RADIATION OUTER DRIVER -! PRGRMMR: BLACK ORG: W/NP22 DATE: 2002-06-04 -! -! ABSTRACT: -! RADIATION SERVES AS THE INTERFACE BETWEEN THE NMMB PHYSICS COMPONENT -! AND THE WRF RADIATION DRIVER. -! -! PROGRAM HISTORY LOG: -! 02-06-04 BLACK - ORIGINATOR -! 02-09-09 WOLFE - CONVERTING TO GLOBAL INDEXING -! 04-11-18 BLACK - THREADED -! 06-07-20 BLACK - INCORPORATED INTO NMMB PHYSICS COMPONENT -! 08-08 JANJIC - Synchronize WATER array and Q. -! 08-11-23 janjic - general hybrid coordinate -! -! USAGE: CALL RADIATION FROM PHY_RUN -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE : IBM -!$$$ -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER,INTENT(IN) :: LM,DT_INT & - ,IHRST,ITIMESTEP,JULDAY,JULYR & - ,NPHS,NRADL,NRADS,NUM_WATER -! - INTEGER,INTENT(IN) :: JDAT(8) -! - INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: NCFRCV,NCFRST -! - REAL,INTENT(IN) :: DT,JULIAN,PT,XTIME,DYH -! - REAL,DIMENSION(1:LM),INTENT(IN) :: DSG2,PDSG1,PSGML1,SGML2 -! - REAL,DIMENSION(1:LM+1),INTENT(IN) :: PSG1,SG2 -! - REAL,DIMENSION(LM+1),INTENT(IN) :: SGM -! - REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: ALBEDO,CUPPT & - ,GLAT,GLON & - ,PD,SM & - ,SNOW,SNOWC,THS,SI & - ,TSKIN,Z0,SICE & - ,MXSNAL,STDH -! - REAL,DIMENSION(IMS:IME,JMS:JME,LM),INTENT(IN) :: Q,T,CW,O3 & - ,F_ICE,F_RAIN & - ,F_RIMEF,OMGALF -! - REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: ACFRCV,ACFRST & - ,RLWIN,RLWTOA & - ,RSWIN,RSWOUT & - ,HBOT,HTOP & - ,RSWINC,RSWTOA -! - REAL,DIMENSION(IMS:IME,JMS:JME,LM),INTENT(INOUT) :: RLWTT,RSWTT -! - REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: CFRACH,CFRACL & - ,CFRACM,CZMEAN & - ,SIGT4 -! - REAL,DIMENSION(:,:,:),POINTER,INTENT(INOUT)::QC,QI,QS,QR,QG,NI - -! - REAL,DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(OUT) :: CLDFRA -! - LOGICAL,INTENT(IN) :: F_QC,F_QR,F_QI,F_QS,F_QG,F_NI -! - CHARACTER(99),INTENT(IN) :: LONGWAVE,SHORTWAVE,CLDFRACTION -! -!--------------------- -!*** Local Variables -!--------------------- -! -!....................................................................... - INTEGER :: IQS,IQE,JQS,JQE ! Same as ITS,ITE,JTS,JTE - Changed in looplimits - INTEGER :: I_S,I_E,J_S,J_E ! Also represent ITS,ITE,JTS,JTE -#ifdef ENABLE_SMP - INTEGER :: NTH,TID - INTEGER,EXTERNAL :: OMP_GET_NUM_THREADS,OMP_GET_THREAD_NUM - INTEGER,EXTERNAL :: OMP_GET_MAX_THREADS -#endif -!....................................................................... - INTEGER :: I,II,J,IJ,JDAY,JMONTH & - ,K,KMNTH,N,NRAD -! - INTEGER :: LW_PHYSICS=0,SW_PHYSICS=0,CLD_FRACTION -! - INTEGER,DIMENSION(3) :: IDAT - INTEGER,DIMENSION(12) :: MONTH=(/31,28,31,30,31,30,31,31 & - & ,30,31,30,31/) -! - REAL :: DAYI,GMT,HOUR,PDSL,PLYR,RADT,TIMES,TDUM,QIdum,QLdum -! - real :: gridkm -! - real (kind=kind_phys) :: SLAG, SDEC, CDEC, SOLCON, DTSW, DTX -! - REAL,DIMENSION(1:LM) :: QL -! - REAL,DIMENSION(IMS:IME,JMS:JME) :: GSW & - & ,TOT,TSFC,XLAND & - & ,GLW,SWDOWN,SWDOWNC,CZEN & - & ,CUPPTR -! - REAL,DIMENSION(IMS:IME,JMS:JME,1:LM+1) :: PHINT -! - REAL,DIMENSION(IMS:IME,JMS:JME,1:LM) :: PI3D & - ,THRATEN,THRATENLW & - ,THRATENSW & - ,PRL,RHO,QV & - ,QCW,QCI,QSNOW,NCI & - ,QTdum,FIdum,FRdum -! - LOGICAL :: GFDL_LW, GFDL_SW, LSSWR - - INTEGER :: jj, ip ! used for 2D threading around RRTM - - integer(4) :: ic1, crate1, cmax1 - integer(4) :: ic2, crate2, cmax2 - -! call system_clock(count=ic1, count_rate=crate1, count_max=cmax1) -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -!***** -!***** NOTE: THIS IS HARDWIRED FOR CALLS TO LONGWAVE AND SHORTWAVE -!***** AT EQUAL INTERVALS -!***** -!----------------------------------------------------------------------- -! - NRAD=NRADS - RADT=DT*NRADS/60. -! -!----------------------------------------------------------------------- -!*** NOTE: THE NMMB HAS IJK STORAGE WITH LAYER 1 AT THE TOP. -!*** THE WRF PHYSICS DRIVERS HAVE IKJ STORAGE WITH LAYER 1 -!*** AT THE BOTTOM. -!----------------------------------------------------------------------- -! -!....................................................................... -!$omp parallel do & -!$omp private (j,i,k,pdsl,plyr,ql) -!....................................................................... - DO J=JTS,JTE - DO I=ITS,ITE -! - PDSL=PD(I,J) - XLAND(I,J)=SM(I,J)+1. -! -!----------------------------------------------------------------------- -!*** FILL THE SINGLE-COLUMN INPUT -!----------------------------------------------------------------------- -! - DO K=1,LM -! - PLYR=SGML2(K)*PDSL+PSGML1(K) -! - QL(K)=AMAX1(Q(I,J,K),EPSQ) -! - PHINT(I,J,K)=SG2(K)*PD(I,J)+PSG1(K) - PI3D(I,J,K)=(PLYR*1.E-5)**CAPPA ! Exner funtion -! - THRATEN(I,J,K)=0. - THRATENLW(I,J,K)=0. - THRATENSW(I,J,K)=0. - - PRL(I,J,K)=PLYR ! model layer pressure - RHO(I,J,K)=PLYR/(R_D*T(I,J,K)*(1.+P608*Q(I,J,K))) ! Air density (kg/m**3) - ENDDO -! - PHINT(I,J,LM+1)=SG2(LM+1)*PD(I,J)+PSG1(LM+1) -! -!----------------------------------------------------------------------- -! - TSFC(I,J)=THS(I,J)*(PHINT(I,J,LM+1)*1.E-5)**CAPPA -! - ENDDO - ENDDO -!....................................................................... -!$omp end parallel do -!....................................................................... -! - GMT=REAL(IHRST) -! -!....................................................................... -!$omp parallel do & -!$omp private (k,j,i) -!....................................................................... - DO K=1,LM - DO J=JMS,JME - DO I=IMS,IME - CLDFRA(I,J,K)=0. - ENDDO - ENDDO - ENDDO -! -!....................................................................... -!$omp parallel do & -!$omp private (j,i) -!....................................................................... - DO J=JMS,JME - DO I=IMS,IME - CFRACH(I,J)=0. - CFRACL(I,J)=0. - CFRACM(I,J)=0. - CZMEAN(I,J)=0. - SIGT4(I,J)=0. - SWDOWN(I,J)=0. ! TOTAL (clear+cloudy sky) shortwave down at the surface - SWDOWNC(I,J)=0. ! CLEAR SKY shortwave down at the surface - GSW(I,J)=0. ! Net (down - up) total (clear+cloudy sky) shortwave at the surface - GLW(I,J)=0. ! Total longwave down at the surface - CUPPTR(I,J)=CUPPT(I,J) ! Temporary array set to zero in radiation - ENDDO - ENDDO -!....................................................................... -!$omp end parallel do -!....................................................................... -! -!----------------------------------------------------------------------- -!*** SYNCHRONIZE MIXING RATIO IN WATER ARRAY WITH SPECIFIC HUMIDITY. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! -!*** CALL THE INNER DRIVER. -! -!----------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------- -! -!*** A PRIMARY MODIFICATION TO THE WRF DRIVER IS THE SPECIFICATION -!*** OF THE PACKAGES IN THE SELECT_CASE BLOCKS BEING CHANGED FROM -!*** INTEGERS (LISTED IN THE PHYSICS SECTION OF THE WRF REGISTRY) -!*** TO CHARACTERS (AS DEFINED IN THE ESMF CONFIG FILE). -! -!----------------------------------------------------------------------- -!*** TRANSLATE THE RADIATION OPTIONS IN THE CONFIG FILE TO THEIR -!*** ANALOGS IN THE WRF REGISTRY SO THAT THE WRF RADIATION DRIVER -!*** REMAINS UNTOUCHED. -!----------------------------------------------------------------------- -! - SELECT CASE (TRIM(SHORTWAVE)) - CASE ('gfdl') - SW_PHYSICS=99 - CASE ('dudh') - SW_PHYSICS=1 - CASE ('gsfc') - SW_PHYSICS=2 - CASE ('rrtm') - SW_PHYSICS=3 - CASE DEFAULT - WRITE(0,*)' User selected SHORTWAVE=',TRIM(SHORTWAVE) - WRITE(0,*)' Improper selection of SW scheme in RADIATION' - CALL NMMB_FINALIZE - END SELECT - - SELECT CASE (TRIM(LONGWAVE)) - CASE ('gfdl') - LW_PHYSICS=99 - CASE ('rrtm') - LW_PHYSICS=3 - CASE DEFAULT - WRITE(0,*)' User selected LONGWAVE=',TRIM(LONGWAVE) - WRITE(0,*)' Improper selection of LW scheme in RADIATION' - CALL NMMB_FINALIZE - END SELECT - -!========================================================================== -! Put "call radupdate_nmmb" here for threading safe -!========================================================================== -!---- for forcast purpose IDAT=JDAT - - DTSW =NRADS*DT ! [s] - LSSWR=MOD(ITIMESTEP,NRADS)==0 - - IF (SW_PHYSICS .EQ. 3 .or. LW_PHYSICS .EQ. 3) THEN - DTX =DT - call radupdate_nmmb & -! --- inputs: - & ( JDAT, JDAT, DTSW, DTX, LSSWR, MYPE, & -! --- outputs: - & SLAG, SDEC, CDEC, SOLCON & - & ) - ENDIF - -!========================================================================== -!========================================================================== - - -! -!----------------------------------------------------------------------- -! CALL RADIATION_DRIVER -!----------------------------------------------------------------------- - - IF (LW_PHYSICS .EQ. 0 .AND. SW_PHYSICS .EQ. 0) RETURN - - IF (ITIMESTEP .EQ. 1 .OR. MOD(ITIMESTEP,NRAD) .EQ. 0) THEN - GFDL_LW = .FALSE. - GFDL_SW = .FALSE. - -!--------------- - - IQS = ITS_B1 - IQE = ITE_B1 -!....................................................................... -#ifdef ENABLE_SMP -!$omp parallel private(nth,tid,i,j,k,jqs,jqe) -!....................................................................... - NTH = OMP_GET_NUM_THREADS() - TID = OMP_GET_THREAD_NUM() - CALL LOOPLIMITS(TID,NTH,JTS_B1,JTE_B1,JQS,JQE) -#else - JQS = JTS_B1 - JQE = JTE_B1 -#endif -!----------------------------------------------------------------------- -!*** Initialize Data -!----------------------------------------------------------------------- -! - DO J=JQS,JQE - DO I=IQS,IQE - GSW(I,J)=0. - GLW(I,J)=0. - SWDOWN(I,J)=0. - ENDDO - ENDDO -! - DO K=1,LM - DO J=JQS,JQE - DO I=IQS,IQE - THRATEN(I,J,K)=0. - ENDDO - ENDDO - ENDDO - -!----------------------------------------------------------------------- -! - lwrad_gfdl_select: SELECT CASE(lw_physics) -! -!----------------------------------------------------------------------- - - CASE (GFDLLWSCHEME) - -!-- Do nothing, since cloud fractions (with partial cloudiness effects) -!-- are defined in GFDL LW/SW schemes and do not need to be initialized. - - CASE (RRTMLWSCHEME) - -!-- Do nothing, since cloud fractions is calculated in RRTM - - CASE DEFAULT - - CALL CAL_CLDFRA(CLDFRA, & - QC,QI,F_QC,F_QI, & - IDS,IDE, JDS,JDE, 1,LM+1, & - IMS,IME, JMS,JME, 1,LM+1, & - IQS,IQE, JQS,JQE, 1,LM ) - - END SELECT lwrad_gfdl_select - - -!----------------------------------------------------------------------- -! - lwrad_select: SELECT CASE(lw_physics) -! -!----------------------------------------------------------------------- - CASE (RRTMLWSCHEME) - - - !==== cloud fraction modification (HM Lin, 201503) =========== - ! - !--- use Thompson cloud fraction - - cfr3_select: SELECT CASE (TRIM(CLDFRACTION)) - - CASE ('thompson') ! -- THOMPSON CLOUD FRACTION - IF(MYPE==0)THEN - write(6,*) 'DEBUG-GT: using thompson cloud fraction scheme' - ENDIF - CLD_FRACTION=88 -! -!--- Use dummy arrays QCW, QCI, QSNOW, NCI for Thompson cloud fraction scheme -! These arrays are updated in cal_cldfra3, and the adjust cloud fields are -! provided as input to RRTM and used by the radiation, but they are **not -! used** to change (update) the model arrays QC, QI, QS, and NI (those -! remain unchanged; BSF 4/13/2015). -! - DO K=1,LM - DO J=JMS,JME - DO I=IMS,IME - QV(I,J,K)=Q(I,J,K)/(1.-Q(I,J,K)) - QCW(I,J,K)=QC(I,J,K) - QCI(I,J,K)=0. - QSNOW(I,J,K)=0. - NCI(I,J,K)=0. - IF (F_QI) QCI(I,J,K)=QI(I,J,K) - IF (F_QS) QSNOW(I,J,K)=QS(I,J,K) - IF (F_NI) NCI(I,J,K)=NI(I,J,K) - ENDDO - ENDDO - ENDDO -! - gridkm = DYH/1000. ! convert m to km - - CALL cal_cldfra3(CLDFRA, & - QV,QCW,QCI,QSNOW,F_NI,NCI, & - PRL,T,RHO,XLAND, gridkm, & ! note:12.=gridkm is only for testing - IDS,IDE, JDS,JDE, 1,LM+1, & - IMS,IME, JMS,JME, 1,LM+1, & - IQS,IQE, JQS,JQE, 1,LM ) -! - DO K=1,LM - DO J=JMS,JME - DO I=IMS,IME - FIdum(I,J,K)=F_ICE(I,J,K) - FRdum(I,J,K)=F_RAIN(I,J,K) - QLdum=QCW(I,J,K) - QIdum=QCI(I,J,K)+QSNOW(I,J,K) - IF (F_QR) QLdum=QLdum+QR(I,J,K) - IF (F_QG) QIdum=QIdum+QG(I,J,K) - QTdum(I,J,K)=QLdum+QIdum - IF (QTdum(I,J,K)>0.) FIdum(I,J,K)=QIdum/QTdum(I,J,K) - IF (QLdum>0.) FRdum(I,J,K)=QR(I,J,K)/QLdum - ENDDO - ENDDO - ENDDO - - CASE DEFAULT - if(mype==0.and.ITIMESTEP==0) WRITE(0,*)' Default cloud fraction in radiation scheme ' - CLD_FRACTION=0 - - DO K=1,LM - DO J=JMS,JME - DO I=IMS,IME - QTdum(I,J,K)=CW(I,J,K) - FIdum(I,J,K)=F_ICE(I,J,K) - FRdum(I,J,K)=F_RAIN(I,J,K) - QCW(I,J,K)=QC(I,J,K) - IF (F_QI) QCI(I,J,K)=QI(I,J,K) - IF (F_QS) QSNOW(I,J,K)=QS(I,J,K) - IF (F_NI) NCI(I,J,K)=NI(I,J,K) - ENDDO - ENDDO - ENDDO - - END SELECT cfr3_select - -!----------------------------------------------------------------------- -! -! The purpose of this logic is to divide the domain into tiles that -! are CHNK_RRTM elements in I and 1 element in J, giving potentially -! many more (greater concurrency) and smaller sized (better cache -! locality) tiles that may also be the width of the vector unit -! depending on the value of CHNK_RRTM (defined via CPP). Dynamic -! thread scheduling is specified to help with load imbalance in -! RRTM radiation. The outer loop, chunk_loop_rrtm, is over the -! total number of tiles in the 2D subdomain. For each tile, ip, -! the J index (jj) by dividing the tile index by the number of tiles -! in a row. That index is checked to make sure it falls within the -! extent of the subdomain in J, then the starting I index (ii) -! of the tile is computed by taking the integer modulus of the tile -! index and the number of tiles in a row. Finally, to avoid having -! more than one J-row at the start or end of the J-extent (which can -! happen because we're skipping the first and last J-row), which check -! to make sure that the start and end of this J-iteration (J_S and J_E) -! are identical (that is, we're only doing one row in each tile). -! -!$OMP DO PRIVATE (ip,ii,jj,i_s,i_e,j_s,j_e) schedule(dynamic) - chunk_loop_rrtm: & - DO ip=1,((1+(ite-its+1)/CHNK_RRTM)*CHNK_RRTM)*(jte-jts+1) & - ,CHNK_RRTM - jj=jts+(ip-1)/((1+(ite-its+1)/CHNK_RRTM)*CHNK_RRTM) - j_in_range_rrtm: & - IF ((jj.ge.jts.and.jj.le.jte) .AND. & - ((JDS+1).LE.jj .AND. jj.LE.(JDE-1))) THEN - ii=its+mod((ip-1),((1+(ite-its+1)/CHNK_RRTM)* & - CHNK_RRTM)) - I_S = MAX(MAX(ii,ITS),IDS) - I_E = MIN(MIN(ii+CHNK_RRTM-1,ITE),IDE) - J_S = jj - J_E = jj - - IF ( I_S .LE. I_E ) THEN - CALL RRTM(ITIMESTEP,DT,JDAT & - ,NPHS,GLAT,GLON & - ,NRADS,NRADL & - ,DSG2,SGML2,PDSG1,PSGML1 & - ,PT,PD & - ,T,Q,QTdum,O3 & ! QTdum was CW - ,ALBEDO & - ,FIdum,FRdum & ! FIdum,FRdum were F_ICE,F_RAIN - ,QCW,QCI,QSNOW,QR,QG,NCI & ! QCW,QCI,QSNOW,NCI were QC,QI,QS,NI - ,F_QC,F_QI,F_QS,F_QR,F_QG,F_NI & - ,NUM_WATER & - ,CLD_FRACTION & - ,SM,CLDFRA & - ,RLWTT,RSWTT & - ,RLWIN,RSWIN & - ,RSWINC,RSWOUT & - ,RLWTOA,RSWTOA & - ,CZMEAN,SIGT4 & - ,CFRACL,CFRACM,CFRACH & - ,ACFRST,NCFRST & - ,ACFRCV,NCFRCV & - ,CUPPT,SNOWC,SI & ! was SNOW - ,HTOP,HBOT & - ,TSKIN,Z0,SICE,F_RIMEF,MXSNAL,SGM,STDH,OMGALF & - ,IMS,IME,JMS,JME & - ,I_S,I_E,J_S,J_E & - ,LM & - ,SOLCON & - ,MYPE ) - ENDIF - - ENDIF j_in_range_rrtm - ENDDO chunk_loop_rrtm -!$OMP END DO - - CASE (GFDLLWSCHEME) - - gfdl_lw = .true. - CALL GFDL( & - DT=dt,XLAND=xland & - ,PHINT=phint,T=t & - ,Q=Q & - ,QW=QC & - ,QI=QI & - ,QS=QS & - ,F_QC=F_QC,F_QI=F_QI,F_QS=F_QS & - ,TSK2D=tsfc,GLW=GLW,RSWIN=SWDOWN,GSW=GSW & - ,RSWINC=SWDOWNC,CLDFRA=CLDFRA,PI3D=PI3D & - ,GLAT=glat,GLON=glon,HTOP=htop,HBOT=hbot & - ,ALBEDO=albedo,CUPPT=cupptr & - ,SNOW=snow,G=g,GMT=gmt & - ,NSTEPRA=nrad,NPHS=nphs,ITIMESTEP=itimestep & - ,XTIME=xtime,JULIAN=julian & - ,JULYR=julyr,JULDAY=julday & - ,GFDL_LW=gfdl_lw,GFDL_SW=gfdl_sw & - ,CFRACL=cfracl,CFRACM=cfracm,CFRACH=cfrach & - ,ACFRST=acfrst,NCFRST=ncfrst & - ,ACFRCV=acfrcv,NCFRCV=ncfrcv & - ,RSWTOA=rswtoa,RLWTOA=rlwtoa,CZMEAN=czmean & - ,THRATEN=thraten,THRATENLW=thratenlw & - ,THRATENSW=thratensw & - ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=1,KDE=lm+1 & - ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=1,KME=lm+1 & - ,ITS=iqs,ITE=iqe, JTS=jqs,JTE=jqe, KTS=1,KTE=lm & - ) - - CASE DEFAULT - - WRITE(0,*)'The longwave option does not exist: lw_physics = ', lw_physics - CALL NMMB_FINALIZE - -!----------------------------------------------------------------------- - - END SELECT lwrad_select - -!----------------------------------------------------------------------- -! - swrad_select: SELECT CASE(sw_physics) -! -!----------------------------------------------------------------------- - - CASE (SWRADSCHEME) -!!! CALL SWRAD() - - CASE (GSFCSWSCHEME) -!!! CALL GSFCSWRAD() - - CASE (RRTMSWSCHEME) - -!-- Already called complete RRTM SW/LW scheme in LW part of driver -!!! CALL RRTM() - - CASE (GFDLSWSCHEME) - - gfdl_sw = .true. - CALL GFDL( & - DT=dt,XLAND=xland & - ,PHINT=phint,T=t & - ,Q=Q & - ,QW=QC & - ,QI=QI & - ,QS=QS & - ,F_QC=F_QC,F_QI=F_QI,F_QS=F_QS & - ,TSK2D=tsfc,GLW=GLW,RSWIN=SWDOWN,GSW=GSW & - ,RSWINC=SWDOWNC,CLDFRA=CLDFRA,PI3D=PI3D & - ,GLAT=glat,GLON=glon,HTOP=htop,HBOT=hbot & - ,ALBEDO=albedo,CUPPT=cupptr & - ,SNOW=snow,G=g,GMT=gmt & - ,NSTEPRA=nrad,NPHS=nphs,ITIMESTEP=itimestep & - ,XTIME=xtime,JULIAN=julian & - ,JULYR=julyr,JULDAY=julday & - ,GFDL_LW=gfdl_lw,GFDL_SW=gfdl_sw & - ,CFRACL=cfracl,CFRACM=cfracm,CFRACH=cfrach & - ,ACFRST=acfrst,NCFRST=ncfrst & - ,ACFRCV=acfrcv,NCFRCV=ncfrcv & - ,RSWTOA=rswtoa,RLWTOA=rlwtoa,CZMEAN=czmean & - ,THRATEN=thraten,THRATENLW=thratenlw & - ,THRATENSW=thratensw & - ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=1,KDE=lm+1 & - ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=1,KME=lm+1 & - ,ITS=iqs,ITE=iqe, JTS=jqs,JTE=jqe, KTS=1,KTE=lm & - ) - - CASE DEFAULT - - WRITE(0,*)'The shortwave option does not exist: sw_physics = ', sw_physics - CALL NMMB_FINALIZE - -!----------------------------------------------------------------------- - - END SELECT swrad_select - -!----------------------------------------------------------------------- -! -!....................................................................... -#ifdef ENABLE_SMP -!$omp end parallel -#endif -!....................................................................... -! - -#if 0 - JQS = JTS_B1 - JQE = JTE_B1 - - write(50+mype,*)iqe-iqs+1,jqe-jqs+1,'acfrcv' - do j=jqs,jqe - do i=iqs,iqe - write(50+mype,*)acfrcv(i,j) - enddo - enddo - write(50+mype,*)iqe-iqs+1,jqe-jqs+1,'acfrst' ! *** - do j=jqs,jqe - do i=iqs,iqe - write(50+mype,*)acfrst(i,j) - enddo - enddo - write(50+mype,*)iqe-iqs+1,jqe-jqs+1,'rlwin' - do j=jqs,jqe - do i=iqs,iqe - write(50+mype,*)rlwin(i,j) - enddo - enddo - write(50+mype,*)iqe-iqs+1,jqe-jqs+1,'rlwtoa' - do j=jqs,jqe - do i=iqs,iqe - write(50+mype,*)rlwtoa(i,j) - enddo - enddo - write(50+mype,*)iqe-iqs+1,jqe-jqs+1,'rswin' - do j=jqs,jqe - do i=iqs,iqe - write(50+mype,*)rswin(i,j) - enddo - enddo - write(50+mype,*)iqe-iqs+1,jqe-jqs+1,'rswout' - do j=jqs,jqe - do i=iqs,iqe - write(50+mype,*)rswout(i,j) - enddo - enddo - write(50+mype,*)iqe-iqs+1,jqe-jqs+1,'hbot' - do j=jqs,jqe - do i=iqs,iqe - write(50+mype,*)hbot(i,j) - enddo - enddo - write(50+mype,*)iqe-iqs+1,jqe-jqs+1,'htop' - do j=jqs,jqe - do i=iqs,iqe - write(50+mype,*)htop(i,j) - enddo - enddo - write(50+mype,*)iqe-iqs+1,jqe-jqs+1,'rswinc' - do j=jqs,jqe - do i=iqs,iqe - write(50+mype,*)rswinc(i,j) - enddo - enddo - write(50+mype,*)iqe-iqs+1,jqe-jqs+1,'rswtoa' - do j=jqs,jqe - do i=iqs,iqe - write(50+mype,*)rswtoa(i,j) - enddo - enddo - write(50+mype,*)iqe-iqs+1,jqe-jqs+1,'rlwtt' - do j=jqs,jqe - do i=iqs,iqe - write(50+mype,*)rlwtt(i,j,1) - enddo - enddo - write(50+mype,*)iqe-iqs+1,jqe-jqs+1,'rswtt' - do j=jqs,jqe - do i=iqs,iqe - write(50+mype,*)rswtt(i,j,1) - enddo - enddo - write(50+mype,*)iqe-iqs+1,jqe-jqs+1,'cfrach' ! *** - do j=jqs,jqe - do i=iqs,iqe - write(50+mype,*)cfrach(i,j) - enddo - enddo - write(50+mype,*)iqe-iqs+1,jqe-jqs+1,'cfracl' ! *** - do j=jqs,jqe - do i=iqs,iqe - write(50+mype,*)cfracl(i,j) - enddo - enddo - write(50+mype,*)iqe-iqs+1,jqe-jqs+1,'cfracm' ! *** - do j=jqs,jqe - do i=iqs,iqe - write(50+mype,*)cfracm(i,j) - enddo - enddo - write(50+mype,*)iqe-iqs+1,jqe-jqs+1,'czmean' - do j=jqs,jqe - do i=iqs,iqe - write(50+mype,*)czmean(i,j) - enddo - enddo - write(50+mype,*)iqe-iqs+1,jqe-jqs+1,'sigt4' - do j=jqs,jqe - do i=iqs,iqe - write(50+mype,*)sigt4(i,j) - enddo - enddo -#endif - -! CALL NMMB_FINALIZE - - ENDIF - -!----------------------------------------------------------------------- -! - IF(TRIM(SHORTWAVE)=='rrtm')THEN -! call system_clock(count=ic2, count_rate=crate2, count_max=cmax2) -! write(0,*)'RADIATION: ',ic2-ic1 -!--- RRTM already calculated variables below - RETURN - ENDIF -! -!----------------------------------------------------------------------- -! -!*** UPDATE FLUXES AND TEMPERATURE TENDENCIES. -! -!----------------------------------------------------------------------- -!*** SHORTWAVE -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- - IF(MOD(ITIMESTEP,NRADS)==0)THEN -!----------------------------------------------------------------------- -! - IF(TRIM(SHORTWAVE)/='gfdl')THEN -! -!----------------------------------------------------------------------- -!*** COMPUTE CZMEAN FOR NON-GFDL SHORTWAVE -!----------------------------------------------------------------------- -! - DO J=JMS,JME - DO I=IMS,IME - CZMEAN(I,J)=0. - TOT(I,J)=0. - ENDDO - ENDDO -! - CALL CAL_MON_DAY(JULDAY,JULYR,JMONTH,JDAY) - IDAT(1)=JMONTH - IDAT(2)=JDAY - IDAT(3)=JULYR -! - DO II=0,NRADS,NPHS - TIMES=ITIMESTEP*DT+II*DT - CALL ZENITH(TIMES,DAYI,HOUR,IDAT,IHRST,GLON,GLAT,CZEN & - & ,ITS,ITE,JTS,JTE & - & ,IDS,IDE,JDS,JDE,1,LM+1 & - & ,IMS,IME,JMS,JME,1,LM+1 & - & ,ITS,ITE,JTS,JTE,1,LM) - DO J=JTS,JTE - DO I=ITS,ITE - IF(CZEN(I,J)>0.)THEN - CZMEAN(I,J)=CZMEAN(I,J)+CZEN(I,J) - TOT(I,J)=TOT(I,J)+1. - ENDIF - ENDDO - ENDDO -! - ENDDO -! - DO J=JTS,JTE - DO I=ITS,ITE - IF(TOT(I,J)>0.)CZMEAN(I,J)=CZMEAN(I,J)/TOT(I,J) - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** COMPUTE TOTAL SFC SHORTWAVE DOWN FOR NON-GFDL SCHEMES -!----------------------------------------------------------------------- -! - DO J=JTS_B1,JTE_B1 - DO I=ITS_B1,ITE_B1 -! - SWDOWN(I,J)=GSW(I,J)/(1.-ALBEDO(I,J)) -!--- No value currently available for clear-sky solar fluxes from -! non GFDL schemes, though it's needed for air quality forecasts. -! For the time being, set to the total downward solar fluxes. - SWDOWNC(I,J)=SWDOWN(I,J) -! - ENDDO - ENDDO -! - ENDIF !End non-GFDL/non-RRTM block -!----------------------------------------------------------------------- -! -!....................................................................... -!$omp parallel do & -!$omp& private(i,j,k) -!....................................................................... - DO J=JTS_B1,JTE_B1 - DO I=ITS_B1,ITE_B1 -! - RSWIN(I,J)=SWDOWN(I,J) - RSWINC(I,J)=SWDOWNC(I,J) - RSWOUT(I,J)=SWDOWN(I,J)-GSW(I,J) -! - DO K=1,LM - RSWTT(I,J,K)=THRATENSW(I,J,K)*PI3D(I,J,K) - ENDDO -! - ENDDO - ENDDO -!....................................................................... -!$omp end parallel do -!....................................................................... -! - ENDIF -! -!----------------------------------------------------------------------- -!*** LONGWAVE -!----------------------------------------------------------------------- -! - IF(MOD(ITIMESTEP,NRADL)==0)THEN -! -!....................................................................... -!$omp parallel do & -!$omp& private(i,j,k,tdum) -!....................................................................... - DO J=JTS_B1,JTE_B1 - DO I=ITS_B1,ITE_B1 -! - TDUM=T(I,J,LM) - SIGT4(I,J)=STBOLT*TDUM*TDUM*TDUM*TDUM -! - DO K=1,LM - RLWTT(I,J,K)=THRATENLW(I,J,K)*PI3D(I,J,K) - ENDDO -! - RLWIN(I,J)=GLW(I,J) -! - ENDDO - ENDDO -!....................................................................... -!$omp end parallel do -!....................................................................... -! - ENDIF - -! call system_clock(count=ic2, count_rate=crate2, count_max=cmax2) -! write(0,*)'RADIATION: ',ic2-ic1 - -! -!----------------------------------------------------------------------- -! - END SUBROUTINE RADIATION -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- - SUBROUTINE radconst(XTIME,DECLIN,SOLCON,JULIAN) -!--------------------------------------------------------------------- - IMPLICIT NONE -!--------------------------------------------------------------------- - -! !ARGUMENTS: - REAL, INTENT(IN ) :: XTIME,JULIAN - REAL, INTENT(OUT ) :: DECLIN,SOLCON - REAL, PARAMETER :: DEGRAD=3.1415926/180. - REAL :: OBECL,SINOB,SXLONG,ARG, & - DECDEG,DJUL,RJUL,ECCFAC -! ---- local variables ----- - REAL :: DPD=360./365. -! -! !DESCRIPTION: -! Compute terms used in radiation physics -! for short wave radiation - - DECLIN=0. - SOLCON=0. - -!-----OBECL : OBLIQUITY = 23.5 DEGREE. - - OBECL=23.5*DEGRAD - SINOB=SIN(OBECL) - -!-----CALCULATE LONGITUDE OF THE SUN FROM VERNAL EQUINOX: - - IF(JULIAN.GE.80.)SXLONG=DPD*(JULIAN-80.) - IF(JULIAN.LT.80.)SXLONG=DPD*(JULIAN+285.) - - SXLONG=SXLONG*DEGRAD - ARG=SINOB*SIN(SXLONG) - DECLIN=ASIN(ARG) - DECDEG=DECLIN/DEGRAD -!----SOLAR CONSTANT ECCENTRICITY FACTOR (PALTRIDGE AND PLATT 1976) - DJUL=JULIAN*360./365. - RJUL=DJUL*DEGRAD - ECCFAC=1.000110+0.034221*COS(RJUL)+0.001280*SIN(RJUL)+0.000719* & - COS(2*RJUL)+0.000077*SIN(2*RJUL) - SOLCON=1370.*ECCFAC - - END SUBROUTINE radconst - -!--------------------------------------------------------------------- - SUBROUTINE cal_cldfra(CLDFRA,QC,QI,F_QC,F_QI, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) -!--------------------------------------------------------------------- - IMPLICIT NONE -!--------------------------------------------------------------------- - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - -! - REAL, DIMENSION( ims:ime, jms:jme, kts:kte ), INTENT(OUT ) :: & - CLDFRA - - REAL, DIMENSION( ims:ime, jms:jme, kts:kte ), INTENT(IN ) :: & - QI, & - QC - - LOGICAL,INTENT(IN) :: F_QC,F_QI - - REAL thresh - INTEGER:: i,j,k -! !DESCRIPTION: -! Compute cloud fraction from input ice and cloud water fields -! if provided. -! -! Whether QI or QC is active or not is determined from the logical -! switches f_qi and f_qc. They are passed in to the routine -! to enable testing to see if QI and QC represent active fields. -! -!--------------------------------------------------------------------- - thresh=1.0e-6 - - IF ( f_qi .AND. f_qc ) THEN -!....................................................................... -!$omp parallel do private(k,j,i) -!....................................................................... - DO k = kts,kte - DO j = jts,jte - DO i = its,ite - IF ( QC(i,j,k)+QI(I,j,k) .gt. thresh) THEN - CLDFRA(i,j,k)=1. - ELSE - CLDFRA(i,j,k)=0. - ENDIF - ENDDO - ENDDO - ENDDO -!....................................................................... -!$omp end parallel do -!....................................................................... -! - ELSE IF ( f_qc ) THEN -!....................................................................... -!$omp parallel do private(k,j,i) -!....................................................................... - DO k = kts,kte - DO j = jts,jte - DO i = its,ite - IF ( QC(i,j,k) .gt. thresh) THEN - CLDFRA(i,j,k)=1. - ELSE - CLDFRA(i,j,k)=0. - ENDIF - ENDDO - ENDDO - ENDDO -!....................................................................... -!$omp end parallel do -!....................................................................... -! - ELSE -! -!....................................................................... -!$omp parallel do private(k,j,i) -!....................................................................... - DO k = kts,kte - DO j = jts,jte - DO i = its,ite - CLDFRA(i,j,k)=0. - ENDDO - ENDDO - ENDDO -!....................................................................... -!$omp end parallel do -!....................................................................... - ENDIF - - END SUBROUTINE cal_cldfra -!--------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!--------------------------------------------------------------------- -! - END MODULE MODULE_RADIATION -! -!----------------------------------------------------------------------- diff --git a/src/nmm/module_REDUCTION.F90 b/src/nmm/module_REDUCTION.F90 deleted file mode 100644 index 046ec36..0000000 --- a/src/nmm/module_REDUCTION.F90 +++ /dev/null @@ -1,557 +0,0 @@ -module module_REDUCTION - implicit none - private - integer, public, parameter :: FIND_MAX=1, FIND_MIN=2 - integer, public, parameter :: REDUCE_MAX=1, REDUCE_MIN=2, REDUCE_ADD=3, REDUCE_ADD_DOUBLE=4 - - public :: reduce,find,max_integer,max_real,minloc_real,maxloc_real - - interface reduce - module procedure reduce_3d_real2double - module procedure reduce_2d_real2double - module procedure reduce_3d_real - module procedure reduce_2d_real - end interface reduce - - interface find - module procedure find_3d_real - module procedure find_2d_real - module procedure find_3d_integer - module procedure find_2d_integer - end interface find - - interface minloc_real - module procedure minloc7_real ! value, full 3d location and grid index - module procedure minloc4_real ! value and grid index - end interface - - interface maxloc_real - module procedure maxloc7_real ! value, full 3d location and grid index - module procedure maxloc4_real ! value and grid index - end interface - -contains - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!! Array reductions without find - subroutine reduce_3d_real2double(sis,dout,array,nk,method,& - ims,ime,jms,jme,kms,kme) - use module_solver_internal_state, only: solver_internal_state - type(solver_internal_state), intent(in) :: sis - integer, intent(in) :: ims,ime,jms,jme,kms,kme,nk - real, intent(in) :: array(ims:ime,jms:jme,kms:kme) - integer, intent(in) :: method - real :: rout - double precision,intent(out) :: dout - call reduce_real_impl(array,rout,dout,& - ims,ime,jms,jme,kms,kme, & - sis%its,sis%ite,sis%jts,sis%jte,1,nk,& - method,sis%MPI_COMM_COMP,sis%MYPE) - if(method/=REDUCE_ADD_DOUBLE) & - dout=rout - end subroutine reduce_3d_real2double - - subroutine reduce_3d_real(sis,rout,array,nk,method,& - ims,ime,jms,jme,kms,kme) - use module_solver_internal_state, only: solver_internal_state - type(solver_internal_state), intent(in) :: sis - integer, intent(in) :: ims,ime,jms,jme,kms,kme,nk - real, intent(in) :: array(ims:ime,jms:jme,kms:kme) - integer, intent(in) :: method - real, intent(inout) :: rout - double precision :: dout - rout=0 - dout=0 - call reduce_real_impl(array,rout,dout,& - ims,ime,jms,jme,kms,kme, & - sis%its,sis%ite,sis%jts,sis%jte,1,nk,& - method,sis%MPI_COMM_COMP,sis%MYPE) - if(method==REDUCE_ADD_DOUBLE) & - rout=dout - end subroutine reduce_3d_real - - subroutine reduce_2d_real2double(sis,dout,array,method,& - ims,ime,jms,jme) - use module_solver_internal_state, only: solver_internal_state - type(solver_internal_state), intent(in) :: sis - integer, intent(in) :: ims,ime,jms,jme - real, intent(in) :: array(ims:ime,jms:jme) - integer, intent(in) :: method - real :: rout - double precision,intent(out) :: dout - call reduce_real_impl(array,rout,dout,& - ims,ime,jms,jme,1,1, & - sis%its,sis%ite,sis%jts,sis%jte,1,1,& - method,sis%MPI_COMM_COMP,sis%MYPE) - if(method/=REDUCE_ADD_DOUBLE) & - dout=rout - end subroutine reduce_2d_real2double - - subroutine reduce_2d_real(sis,rout,array,method,& - ims,ime,jms,jme) - use module_solver_internal_state, only: solver_internal_state - type(solver_internal_state), intent(in) :: sis - integer, intent(in) :: ims,ime,jms,jme - real, intent(in) :: array(ims:ime,jms:jme) - integer, intent(in) :: method - real, intent(out) :: rout - double precision :: dout - call reduce_real_impl(array,rout,dout,& - ims,ime,jms,jme,1,1, & - sis%its,sis%ite,sis%jts,sis%jte,1,1,& - method,sis%MPI_COMM_COMP,sis%MYPE) - if(method==REDUCE_ADD_DOUBLE) & - rout=dout - end subroutine reduce_2d_real - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!! Array reductions with find - - subroutine find_3d_real(sis,rfnd,iloc,jloc,kloc,rankloc,array,nk,method,& - ims,ime,jms,jme,kms,kme) - use module_solver_internal_state, only: solver_internal_state - type(solver_internal_state), intent(in) :: sis - integer, intent(in) :: ims,ime,jms,jme,kms,kme,nk - real, intent(in) :: array(ims:ime,jms:jme,kms:kme) - integer, intent(in) :: method - real, intent(out) :: rfnd - integer, intent(out) :: iloc,jloc,kloc,rankloc - call reduce_find_real_impl(array,rfnd,iloc,jloc,kloc,rankloc,& - ims,ime,jms,jme,kms,kme, & - sis%its,sis%ite,sis%jts,sis%jte,1,nk,& - method,sis%MPI_COMM_COMP,sis%MYPE) - end subroutine find_3d_real - - subroutine find_2d_real(sis,rfnd,iloc,jloc,rankloc,array,method,& - ims,ime,jms,jme) - use module_solver_internal_state, only: solver_internal_state - type(solver_internal_state), intent(in) :: sis - integer, intent(in) :: ims,ime,jms,jme - real, intent(in) :: array(ims:ime,jms:jme) - integer, intent(in) :: method - real, intent(out) :: rfnd - integer, intent(out) :: iloc,jloc,rankloc - integer :: kloc - call reduce_find_real_impl(array,rfnd,iloc,jloc,kloc,rankloc,& - ims,ime,jms,jme,1,1, & - sis%its,sis%ite,sis%jts,sis%jte,1,1,& - method,sis%MPI_COMM_COMP,sis%MYPE) - end subroutine find_2d_real - - subroutine find_3d_integer(sis,ifnd,iloc,jloc,kloc,rankloc,array,nk,method,& - ims,ime,jms,jme,kms,kme) - use module_solver_internal_state, only: solver_internal_state - type(solver_internal_state), intent(in) :: sis - integer, intent(in) :: ims,ime,jms,jme,kms,kme,nk - integer, intent(in) :: array(ims:ime,jms:jme,kms:kme) - integer, intent(in) :: method - integer, intent(out) :: ifnd - integer, intent(out) :: iloc,jloc,kloc,rankloc - call reduce_find_integer_impl(array,ifnd,iloc,jloc,kloc,rankloc,& - ims,ime,jms,jme,kms,kme, & - sis%its,sis%ite,sis%jts,sis%jte,1,nk,& - method,sis%MPI_COMM_COMP,sis%MYPE) - end subroutine find_3d_integer - - subroutine find_2d_integer(sis,ifnd,iloc,jloc,rankloc,array,method,& - ims,ime,jms,jme) - use module_solver_internal_state, only: solver_internal_state - type(solver_internal_state), intent(in) :: sis - integer, intent(in) :: ims,ime,jms,jme - integer, intent(in) :: array(ims:ime,jms:jme) - integer, intent(in) :: method - integer, intent(out) :: ifnd - integer, intent(out) :: iloc,jloc,rankloc - integer :: kloc - call reduce_find_integer_impl(array,ifnd,iloc,jloc,kloc,rankloc,& - ims,ime,jms,jme,1,1, & - sis%its,sis%ite,sis%jts,sis%jte,1,1,& - method,sis%MPI_COMM_COMP,sis%MYPE) - end subroutine find_2d_integer - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!! Scalar reductions - subroutine max_real(sis,val) - use mpi - use module_solver_internal_state, only: solver_internal_state - type(solver_internal_state), intent(in) :: sis - integer ierr - real maxv,val - call MPI_Allreduce(val,maxv,1,MPI_REAL,MPI_MAX,& - sis%MPI_COMM_COMP,ierr) - val=maxv - end subroutine max_real - - subroutine max_integer(sis,val) - use mpi - use module_solver_internal_state, only: solver_internal_state - type(solver_internal_state), intent(in) :: sis - integer ierr - integer maxv,val - call MPI_Allreduce(val,maxv,1,MPI_REAL,MPI_MAX,& - sis%MPI_COMM_COMP,ierr) - val=maxv - end subroutine max_integer - - subroutine minloc7_real(sis,val,lat,lon,z,idex,jdex) - use mpi - use module_solver_internal_state, only: solver_internal_state - type(solver_internal_state), intent(in) :: sis - REAL,intent(inout) :: val, lat, lon, z - integer, intent(inout) :: idex,jdex - INTEGER ierr, mrank - REAL inreduce(2), outreduce(2), bcast(5) - - inreduce=(/ val, real(sis%MYPE) /) - call MPI_Allreduce(inreduce,outreduce,1,MPI_2REAL,MPI_MINLOC,& - sis%MPI_COMM_COMP,ierr) - val=outreduce(1) - mrank=outreduce(2) - bcast=(/ lat,lon,z,real(idex),real(jdex) /) - call MPI_Bcast(bcast,5,MPI_REAL,mrank,sis%MPI_COMM_COMP,ierr) - lat=bcast(1) - lon=bcast(2) - z=bcast(3) - idex=bcast(4) - jdex=bcast(5) - end subroutine minloc7_real - - subroutine maxloc7_real(sis,val,lat,lon,z,idex,jdex) - use mpi - use module_solver_internal_state, only: solver_internal_state - type(solver_internal_state), intent(in) :: sis - REAL,intent(inout) :: val, lat, lon, z - integer, intent(inout) :: idex,jdex - INTEGER ierr, mrank - REAL inreduce(2), outreduce(2), bcast(5) - - inreduce=(/ val, real(sis%MYPE) /) - call MPI_Allreduce(inreduce,outreduce,1,MPI_2REAL,MPI_MAXLOC,& - sis%MPI_COMM_COMP,ierr) - val=outreduce(1) - mrank=outreduce(2) - bcast=(/ lat,lon,z,real(idex),real(jdex) /) - call MPI_Bcast(bcast,5,MPI_REAL,mrank,sis%MPI_COMM_COMP,ierr) - lat=bcast(1) - lon=bcast(2) - z=bcast(3) - idex=bcast(4) - jdex=bcast(5) - end subroutine maxloc7_real - - subroutine minloc4_real(sis,val,idex,jdex) - use mpi - use module_solver_internal_state, only: solver_internal_state - type(solver_internal_state), intent(in) :: sis - REAL,intent(inout) :: val - integer, intent(inout) :: idex,jdex - INTEGER ierr, mrank - REAL inreduce(2), outreduce(2), bcast(2) - - inreduce=(/ val, real(sis%MYPE) /) - call MPI_Allreduce(inreduce,outreduce,1,MPI_2REAL,MPI_MINLOC,& - sis%MPI_COMM_COMP,ierr) - val=outreduce(1) - mrank=outreduce(2) - bcast=(/ real(idex),real(jdex) /) - call MPI_Bcast(bcast,2,MPI_REAL,mrank,sis%MPI_COMM_COMP,ierr) - idex=bcast(1) - jdex=bcast(2) - end subroutine minloc4_real - - subroutine maxloc4_real(sis,val,idex,jdex) - use mpi - use module_solver_internal_state, only: solver_internal_state - type(solver_internal_state), intent(in) :: sis - REAL,intent(inout) :: val - integer, intent(inout) :: idex,jdex - INTEGER ierr, mrank - REAL inreduce(2), outreduce(2), bcast(2) - - inreduce=(/ val, real(sis%MYPE) /) - call MPI_Allreduce(inreduce,outreduce,1,MPI_2REAL,MPI_MAXLOC,& - sis%MPI_COMM_COMP,ierr) - val=outreduce(1) - mrank=outreduce(2) - bcast=(/ real(idex),real(jdex) /) - call MPI_Bcast(bcast,2,MPI_REAL,mrank,sis%MPI_COMM_COMP,ierr) - idex=bcast(1) - jdex=bcast(2) - end subroutine maxloc4_real - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!! Private implementation functions - subroutine reduce_real_impl(dat,rfnd,dfnd, & - ims,ime,jms,jme,kms,kme,& - its,ite,jts,jte,kts,kte,& - method,comm,rank) - use mpi - integer, intent(in) :: method, comm, rank - real, intent(in) :: dat(ims:ime,jms:jme,kms:kme) - real, intent(inout) :: rfnd - integer, intent(in) :: ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte - double precision, intent(out) :: dfnd - - real :: rfnd_mpi - double precision :: dfnd_mpi - integer :: i,j,k,ierr - real :: rthread - real :: inreduce(2),outreduce(2) - double precision :: dthread - logical :: found - - !$OMP PARALLEL PRIVATE(k,found) - rthread=0 - dthread=0 - found=.false. - if(method==REDUCE_ADD) then - do k=kts,kte - !$OMP DO PRIVATE(i,j) REDUCTION(+:rthread) - do j=jts,jte - do i=its,ite - rthread=rthread+dat(i,j,k) - enddo - enddo - !$OMP END DO - enddo - call MPI_Allreduce(rthread,rfnd_mpi,1,MPI_REAL,MPI_SUM,comm,ierr) - dfnd=rfnd_mpi - rfnd=rfnd_mpi - elseif(method==REDUCE_ADD_DOUBLE) then - do k=kts,kte - !$OMP DO PRIVATE(i,j) REDUCTION(+:dthread) - do j=jts,jte - do i=its,ite - dthread=dthread+dat(i,j,k) - enddo - enddo - !$OMP END DO - enddo - call MPI_Allreduce(dthread,dfnd_mpi,1,MPI_DOUBLE_PRECISION,& - MPI_SUM,comm,ierr) - rfnd=real(dfnd_mpi) - dfnd=dfnd_mpi - elseif(method==REDUCE_MAX) then - rthread=dat(its,jts,kts) - do k=kts,kte - !$OMP DO PRIVATE(i,j) REDUCTION(max:rthread) - do j=jts,jte - do i=its,ite - rthread=max(rthread,dat(i,j,k)) - enddo - enddo - !$OMP END DO - enddo - call MPI_Allreduce(rthread,rfnd_mpi,1,MPI_REAL,MPI_MAX,comm,ierr) - dfnd=rfnd_mpi - rfnd=rfnd_mpi - elseif(method==REDUCE_MIN) then - rthread=dat(its,jts,kts) - do k=kts,kte - !$OMP DO PRIVATE(i,j) REDUCTION(min:rthread) - do j=jts,jte - do i=its,ite - rthread=min(rthread,dat(i,j,k)) - enddo - enddo - !$OMP END DO - enddo - call MPI_Allreduce(rthread,rfnd_mpi,1,MPI_REAL,MPI_MIN,comm,ierr) - dfnd=rfnd_mpi - rfnd=rfnd_mpi - endif - !$OMP END PARALLEL - end subroutine reduce_real_impl - - subroutine reduce_find_real_impl(dat,rfnd,iloc,jloc,kloc,rankloc,& - ims,ime,jms,jme,kms,kme,& - its,ite,jts,jte,kts,kte,& - method,comm,rank) - use mpi - integer, intent(in) :: method, comm, rank - integer, intent(inout) :: iloc,jloc,kloc,rankloc - real, intent(in) :: dat(ims:ime,jms:jme,kms:kme) - real, intent(inout) :: rfnd - integer, intent(in) :: ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte - - integer :: i,j,k,iloc_local,jloc_local,kloc_local - integer :: iloc_thread, jloc_thread,kloc_thread - real :: rfnd_local, rfnd_thread - real :: inreduce(2),outreduce(2) - integer :: bcast(3), ierr - - if(method/=FIND_MAX .and. method/=FIND_MIN) then - write(0,*) 'In module_REDUCTION reduce_find, method must be FIND_MAX or FIND_MIN.' - call MPI_Abort(MPI_COMM_WORLD,2,ierr) - endif - - iloc=-99 ; iloc_local=-99 ; iloc_thread=-99 - jloc=-99 ; jloc_local=-99 ; jloc_thread=-99 - kloc=-99 ; kloc_local=-99 ; kloc_thread=-99 - rfnd=0. ; rfnd_local=0. ; rfnd_thread=0. - k=kts - - !$OMP PARALLEL FIRSTPRIVATE(k,iloc_thread,jloc_thread,kloc_thread,rfnd_thread) - ifmax: if(method==FIND_MAX) then - kmax: do k=kts,kte - !$OMP DO PRIVATE(j,i) - jmax: do j=jts,jte - imax: do i=its,ite - if(dat(i,j,k)>rfnd_thread .or. iloc_thread<0) then - rfnd_thread=dat(i,j,k) - iloc_thread=i - jloc_thread=j - kloc_thread=k - endif - enddo imax - enddo jmax - !$OMP END DO - enddo kmax - !$OMP CRITICAL - if(iloc_local<0 .or. rfnd_thread>rfnd_local) then - rfnd_local=rfnd_thread - iloc_local=iloc_thread - jloc_local=jloc_thread - kloc_local=kloc_thread - endif - !$OMP END CRITICAL - else ! FIND_MIN - kmin: do k=kts,kte - !$OMP DO PRIVATE(j,i) - jmin: do j=jts,jte - imin: do i=its,ite - if(dat(i,j,k)ifnd_thread .or. iloc_thread<0) then - ifnd_thread=dat(i,j,k) - iloc_thread=i - jloc_thread=j - kloc_thread=k - endif - enddo imax - enddo jmax - !$OMP END DO - enddo kmax - !$OMP CRITICAL - if(iloc_local<0 .or. ifnd_thread>ifnd_local) then - ifnd_local=ifnd_thread - iloc_local=iloc_thread - jloc_local=jloc_thread - kloc_local=kloc_thread - endif - !$OMP END CRITICAL - else ! FIND_MIN - kmin: do k=kts,kte - !$OMP DO PRIVATE(j,i) - jmin: do j=jts,jte - imin: do i=its,ite - if(dat(i,j,k)=jde) then - j=jde - !$omp parallel do private(i) - do i=i1,i2 - if(mask(i,j)/=0) & - next(i,j) = r1 * work(i,j) + r * & - (work(i-1,j) + work(i+1,j) + work(i,j-1))/3 - enddo - endif - ! WEST: - if(its<=ids) then - i=1 - !$omp parallel do private(j) - do j=j1,j2 - if(mask(i,j)/=0) & - next(i,j) = r1 * work(i,j) + r * & - (work(i+1,j) + work(i,j-1) + work(i,j+1))/3 - enddo - endif - ! EAST: - if(ite>=ide) then - i=ide - !$omp parallel do private(j) - do j=j1,j2 - if(mask(i,j)/=0) & - next(i,j) = r1 * work(i,j) + r * & - (work(i-1,j) + work(i,j-1) + work(i,j+1))/3 - enddo - endif - - ! Finally, handle corner points: - ! SOUTHWEST: - if(its<=ids .and. jts<=jds) then - if(mask(ids,jds)/=0) & - next(ids,jds) = r1 * work(ids,jds) + r * & - (work(ids+1,jds) + work(ids,jds+1))/2 - endif - ! SOUTHEAST: - if(ite>=ide .and. jts<=jds) then - if(mask(ide,jds)/=0) & - next(ide,jds) = r1 * work(ide,jds) + r * & - (work(ide-1,jds) + work(ide,jds+1))/2 - endif - ! NORTHWEST: - if(its<=ids .and. jte>=jde) then - if(mask(ids,jde)/=0) & - next(ids,jde) = r1 * work(ids,jde) + r * & - (work(ids+1,jde) + work(ids,jde-1))/2 - endif - ! NORTHEAST: - if(ite>=ide .and. jte>=jde) then - if(mask(ide,jde)/=0) & - next(ide,jde) = r1 * work(ide,jde) + r * & - (work(ide-1,jde) + work(ide,jde-1))/2 - endif - - !$OMP PARALLEL DO PRIVATE(i,j) - backj: do j=jts,jte - backi: do i=its,ite - work(i,j)=next(i,j) - end do backi - end do backj - !$OMP END PARALLEL DO - enddo relaxloop - end subroutine relax4e -end module MODULE_RELAX4E diff --git a/src/nmm/module_SOLVER_GRID_COMP.F90 b/src/nmm/module_SOLVER_GRID_COMP.F90 deleted file mode 100644 index 296e894..0000000 --- a/src/nmm/module_SOLVER_GRID_COMP.F90 +++ /dev/null @@ -1,12125 +0,0 @@ -!----------------------------------------------------------------------- -! - MODULE module_SOLVER_GRID_COMP -! -!----------------------------------------------------------------------- -! -!*** This module holds the Solver component's Register, Init, Run, -!*** and Finalize routines. They are called from the DOMAIN component -!*** (DOMAIN_INITIALIZE calls SOLVER_INITIALIZE, etc.) -!*** in MODULE_DOMAIN_GRID_COMP.F90. -! -!----------------------------------------------------------------------- -! HISTORY LOG: -! -! 2008-07-30 Janjic - Add CONVECTION='none' to OPERATIONAL_PHYSICS. -! Janjic - Fix lower J limit in FFTFHN(WATER). -! 2008-08-23 Janjic - General pressure-sigma hybrid -! Janjic - Consistent nonhydrostatic correction in the -! first term of the pressure gradient force -! 2008-09-03 Black - Added initialization of boundary arrays -! for nests. -! 2009-03-12 Black - Changes for general hybrid coordinate. -! 2009-11 Jovic - Modified for ownership/import/export specification -! 2010-11-03 Pyle - Modifications/corrections for digital filter. -! 2011-02 Yang - Updated to use both the ESMF 4.0.0rp2 library, -! ESMF 5 series library and the the -! ESMF 3.1.0rp2 library. -! 2011-05-12 Yang - Modified for using the ESMF 5.2.0r_beta_snapshot_07. -! 2011-12-22 Jovic - Combined Dyn and Phy into single component. -! -! 2012-02-08 Yang - Modified for using the ESMF 5.2.0rp1 library. -! 2012-04-06 Juang - add passing argument for gbphys for idea -! 2012-07-20 Black - Modified for generational usage. -! 2013-09-09 Moorthi - Adding SR, DTDT, and TRIGGERPERTS for GBPHYS call -! 2013-11-09 Xingren Wu - Adding DUSFCI/DVSFCI for GBPHYS call -! 2014-03-28 Xingren Wu - Add "_CPL" field for GBPHYS call -! 2014-05-14 J. Wang - Adding cgwf,prslrd0 and levr to gbphys call -! 2014-06-26 Weiguo Wang -- Add HURRICANE PBL and SFCLAY calls -! 2016-02-16 J. Wang - change newsas/sashal from logical to integer -! 2016-05-09 Ferrier/Janjic - Constants epsq2,epsl function of level, -! added subroutine TQadjust -! 2016-08-29 Weiguo wang -- add scale-aware convection schemes -!----------------------------------------------------------------------- -! - USE MPI - USE ESMF - USE MODULE_KINDS - USE MODULE_VARS,ONLY : FIND_VAR_INDX - USE MODULE_VARS_STATE - USE MODULE_SOLVER_INTERNAL_STATE !<-- Horizontal loop limits obtained here -! - USE MODULE_MY_DOMAIN_SPECS, IDS_share=>IDS,IDE_share=>IDE & - ,IMS_share=>IMS,IME_share=>IME & - ,ITS_share=>ITS,ITE_share=>ITE & - ,JDS_share=>JDS,JDE_share=>JDE & - ,JMS_share=>JMS,JME_share=>JME & - ,JTS_share=>JTS,JTE_share=>JTE -! - USE MODULE_EXCHANGE,ONLY: HALO_EXCH -! - USE MODULE_GET_CONFIG -! - USE MODULE_DERIVED_TYPES,ONLY : BC_H_ALL,BC_V_ALL -! - USE MODULE_CONTROL,ONLY : NUM_DOMAINS_MAX,TIMEF,NMMB_FINALIZE -! - USE MODULE_CONSTANTS,ONLY : A2,A3,A4,CAPPA,CP,ELIV,ELWV,EPSQ,G & - ,P608,PQ0,R_D,TIW,DBZmin -! - USE MODULE_DIAGNOSE,ONLY : EXIT,FIELD_STATS & - ,MAX_FIELDS,MAX_FIELDS_HR,MAX_FIELDS_W6 & - ,MAX_FIELDS_THO & - ,HMAXMIN,TWR,VMAXMIN,VWR,WRT_PCP & - ,LAT_LON_BNDS -! - USE MODULE_CLOCKTIMES,ONLY : INTEGRATION_TIMERS,TIMERS -! - USE MODULE_ERROR_MSG,ONLY: ERR_MSG,MESSAGE_CHECK -! - USE MODULE_FLTBNDS,ONLY : POLEHN,POLEWN,SWAPHN,SWAPWN -! - USE MODULE_VARS,ONLY : VAR -! - USE MODULE_NESTING,ONLY : SUFFIX_NESTBC -! - USE MODULE_RADIATION ,ONLY : RADIATION - USE MODULE_RA_GFDL ,ONLY : GFDL_INIT,RDTEMP,TIME_MEASURE - USE MODULE_RA_RRTM ,ONLY : RRTM_INIT - USE MODULE_TURBULENCE - USE MODULE_SF_JSFC ,ONLY : JSFC_INIT - USE MODULE_SF_GFDL ,ONLY : JSFC_INIT4GFDL - USE MODULE_BL_MYJPBL ,ONLY : MYJPBL_INIT - USE MODULE_LS_NOAHLSM ,ONLY : DZSOIL,NOAH_LSM_INIT & - ,NUM_SOIL_LAYERS,SLDPTH - USE MODULE_CU_BMJ ,ONLY : BMJ_INIT - USE MODULE_CU_SAS ,ONLY : SAS_INIT - USE MODULE_CU_SASHUR ,ONLY : SASHUR_INIT - USE MODULE_CU_SCALE ,ONLY : SCALECU_INIT - USE MODULE_CONVECTION - - USE MODULE_MICROPHYSICS_NMM ,ONLY : GSMDRIVE & - ,MICRO_RESTART - USE MODULE_MP_ETANEW ,ONLY : FERRIER_INIT - USE MODULE_MP_FER_HIRES ,ONLY : FERRIER_INIT_HR - USE MODULE_MP_WSM6 ,ONLY : WSM6INIT - USE MODULE_MP_THOMPSON, ONLY : thompson_init - USE MODULE_MP_GFS ,ONLY : GFSMP_INIT - - USE MODULE_H_TO_V ,ONLY : H_TO_V,H_TO_V_TEND - USE MODULE_GWD ,ONLY : GWD_INIT - USE MODULE_PRECIP_ADJUST -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: SOLVER_REGISTER -! - INTEGER(kind=KINT),PUBLIC :: IM,JM,LM,RESTVAL -! - INTEGER(kind=KINT) :: START_YEAR,START_MONTH,START_DAY & - ,START_HOUR,START_MINUTE,START_SECOND -! - INTEGER(kind=KINT),SAVE :: JC -! - INTEGER(kind=KINT) :: NUM_PES -! - LOGICAL(kind=KLOG),SAVE :: QUILTING !<-- Was quilting specified by the user? -! - LOGICAL(kind=KLOG) :: I_AM_A_NEST !<-- Flag indicating if DOMAIN Component is a nest -! - LOGICAL(kind=KLOG),SAVE :: MOVE_NOW !<-- Flag indicating if nested moves this timestep -! LOGICAL(kind=KLOG) :: MOVE_NOW & !<-- Flag indicating if nested moves this timestep -! ,MY_DOMAIN_MOVES !<-- Flag indicating if nested domain moves - - REAL(kind=KFPT),SAVE :: PT -! - TYPE(SOLVER_INTERNAL_STATE),POINTER :: INT_STATE !<-- The Solver component internal state pointer. -! -!----------------------------------------------------------------------- -!*** For determining clocktimes of various pieces of the Solver. -!----------------------------------------------------------------------- -! - REAL(kind=KDBL) :: btim,btim0 -! - TYPE(INTEGRATION_TIMERS),POINTER :: TD -! -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE SOLVER_REGISTER(GRID_COMP,RC_REG) -! -!----------------------------------------------------------------------- -!*** Register the Solver component's Initialize, Run, and Finalize -!*** subroutine names. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument variables -!------------------------ -! - TYPE(ESMF_GridComp) :: GRID_COMP !<-- The Solver Gridded Component -! - INTEGER(kind=KINT),INTENT(OUT) :: RC_REG !<-- Return code for Solver register -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: RC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RC_REG=ESMF_SUCCESS !<-- Initialize error signal variable -! -!----------------------------------------------------------------------- -!*** Register the Solver initialize subroutine. Since it is just one -!*** subroutine, use ESMF_SINGLEPHASE. The second argument is -!*** a pre-defined subroutine type, such as ESMF_SETINIT, ESMF_SETRUN, -!*** or ESMF_SETFINAL. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for Solver Initialize" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSetEntryPoint(GRID_COMP & !<-- The gridded component - ,ESMF_METHOD_INITIALIZE & !<-- Predefined subroutine type - ,SOLVER_INITIALIZE & !<-- User's subroutineName - ,phase=1 & - ,rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Register the Solver Run subroutine. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for Solver Run" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSetEntryPoint(GRID_COMP & !<-- gridcomp - ,ESMF_METHOD_RUN & !<-- subroutineType - ,SOLVER_RUN & !<-- user's subroutineName - ,phase=1 & - ,rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Register the Solver Finalize subroutine. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for Solver Finalize" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSetEntryPoint(GRID_COMP & !<-- gridcomp - ,ESMF_METHOD_FINALIZE & !<-- subroutineType - ,SOLVER_FINALIZE & !<-- user's subroutineName - ,phase=1 & - ,rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Check the error signal variable. -!----------------------------------------------------------------------- -! - IF(RC_REG==ESMF_SUCCESS)THEN -! WRITE(0,*)" SOLVER_REGISTER SUCCEEDED" - ELSE - WRITE(0,*)" SOLVER_REGISTER FAILED" - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE SOLVER_REGISTER -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE SOLVER_INITIALIZE (GRID_COMP & - ,IMP_STATE & - ,EXP_STATE & - ,CLOCK_ATM & - ,RC_INIT) -! -!----------------------------------------------------------------------- -!*** Carry out all necessary setups for the model Solver. -!----------------------------------------------------------------------- -! - USE MODULE_CONTROL,ONLY : CONSTS -! - USE MODULE_INIT_READ_BIN,ONLY : READ_BINARY - USE MODULE_INIT_READ_NEMSIO,ONLY : READ_NEMSIO -! - USE MODULE_FLTBNDS,ONLY : PREFFT, PRESMUD - USE MODULE_TRACKER - -!------------------------ -!*** Argument variables -!------------------------ -! - TYPE(ESMF_GridComp) :: GRID_COMP !<-- The Solver gridded component -! - TYPE(ESMF_State) :: IMP_STATE & !<-- The Solver Initialize step's import state - ,EXP_STATE !<-- The Solver Initialize step's export state -! - TYPE(ESMF_Clock) :: CLOCK_ATM !<-- The ATM's ESMF Clock -! - INTEGER,INTENT(OUT) :: RC_INIT -! -!--------------------- -!*** Local variables -!--------------------- -! - INTEGER(kind=KINT),SAVE :: N8=8 -! - INTEGER(kind=KINT) :: IDE,IDS,IME,IMS,ITE,ITS & - ,JDE,JDS,JME,JMS,JTE,JTS -! - INTEGER(kind=KINT) :: IHALO,JHALO,MPI_COMM_COMP,MY_DOMAIN_ID & - ,MY_DOMAIN_ID_LOC,MYPE,NUM_PES,UBOUND_VARS -! - INTEGER(kind=KINT) :: I,I_INC,IDENOMINATOR_DT & - ,IEND,IERR,INTEGER_DT & - ,J,J_INC,JEND,KK,KOUNT,KSE,KSS & - ,L,LL,LMP1,LNSH,LNSV & - ,N,NUMERATOR_DT,NV,RC -! - INTEGER(kind=KINT) :: ITE_H2,ITS_H2,JTE_H2,JTS_H2 -! - INTEGER(kind=KINT),DIMENSION(1:8) :: MY_NEB -! - REAL(kind=KFPT) :: DPH,DLM,DT,GLATX,GLONX,SB_1,SBD_1,TLATX,TLONX & - ,TPH0_1,TPH0D_1,TLM0_1,TLM0D_1,WB_1,WBD_1 & - ,X,Y,Z -! - REAL(kind=KFPT),DIMENSION(1:2) :: SW_X -! - REAL(kind=DOUBLE) :: D2R,D_ONE,D_180,PI -! - LOGICAL(kind=KLOG) :: RUN_LOCAL -! - CHARACTER(20) :: FIELD_NAME -! - TYPE(WRAP_SOLVER_INT_STATE) :: WRAP ! <-- This wrap is a derived type which contains - ! only a pointer to the internal state. It is needed - ! for using different architectures or compilers. -! - TYPE(ESMF_Grid) :: GRID !<-- The ESMF Grid -! - TYPE(ESMF_VM) :: VM !<-- The ESMF Virtual Machine -! - TYPE(ESMF_Field) :: FIELD -! - TYPE(ESMF_FieldBundle) :: BUNDLE_NESTBC -! - TYPE(ESMF_TimeInterval) :: DT_ESMF !<-- The ESMF fundamental timestep (s) -! - TYPE(ESMF_Config) :: CF !<-- ESMF configure object -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - btim0=timef() -! -!----------------------------------------------------------------------- -!*** Initialize the error signal variables. -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RC_INIT=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** Allocate the Solver internal state pointer. -!----------------------------------------------------------------------- -! - ALLOCATE(INT_STATE,STAT=RC) -! -!----------------------------------------------------------------------- -!*** Attach the internal state to the Solver gridded component. -!----------------------------------------------------------------------- -! - WRAP%INT_STATE=>INT_STATE -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Attach Solver Internal State to the Gridded Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSetInternalState(GRID_COMP & !<-- The Solver gridded component - ,WRAP & !<-- Pointer to the Solver internal state - ,RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Retrieve fundamental domain characteristics from the Solver -!*** import state and set them in the internal state so they will -!*** always be available to this component. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Domain Dimensions from Solver Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Solver import state - ,name ='ITS' & !<-- Name of variable to get from Solver import state - ,value=int_state%ITS & !<-- Put extracted value here - ,rc =RC) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Solver import state - ,name ='ITE' & !<-- Name of variable to get from Solver import state - ,value=int_state%ITE & !<-- Put extracted value here - ,rc =RC) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Solver import state - ,name ='JTS' & !<-- Name of variable to get from Solver import state - ,value=int_state%JTS & !<-- Put extracted value here - ,rc =RC) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Solver import state - ,name ='JTE' & !<-- Name of variable to get from Solver import state - ,value=int_state%JTE & !<-- Put extracted value here - ,rc =RC) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Solver import state - ,name ='IMS' & !<-- Name of variable to get from Solver import state - ,value=int_state%IMS & !<-- Put extracted value here - ,rc =RC) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Solver import state - ,name ='IME' & !<-- Name of variable to get from Solver import state - ,value=int_state%IME & !<-- Put extracted value here - ,rc =RC) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Solver import state - ,name ='JMS' & !<-- Name of variable to get from Solver import state - ,value=int_state%JMS & !<-- Put extracted value here - ,rc =RC) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Solver import state - ,name ='JME' & !<-- Name of variable to get from Solver import state - ,value=int_state%JME & !<-- Put extracted value here - ,rc =RC) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Solver import state - ,name ='IDS' & !<-- Name of variable to get from Solver import state - ,value=int_state%IDS & !<-- Put extracted value here - ,rc =RC) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Solver import state - ,name ='IDE' & !<-- Name of variable to get from Solver import state - ,value=int_state%IDE & !<-- Put extracted value here - ,rc =RC) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Solver import state - ,name ='JDS' & !<-- Name of variable to get from Solver import state - ,value=int_state%JDS & !<-- Put extracted value here - ,rc =RC) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Solver import state - ,name ='JDE' & !<-- Name of variable to get from Solver import state - ,value=int_state%JDE & !<-- Put extracted value here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Halo Widths from Solver Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Solver import state - ,name ='IHALO' & !<-- Name of variable to get from Solver import state - ,value=int_state%IHALO & !<-- Put extracted value here - ,rc =RC) -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Solver import state - ,name ='JHALO' & !<-- Name of variable to get from Solver import state - ,value=int_state%JHALO & !<-- Put extracted value here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Fcst/Quilt Task Intracomm from Solver Imp State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Solver import state - ,name ='Fcst/Quilt Intracommunicators' & !<-- Name of variable to get from Solver import state - ,value=int_state%MPI_COMM_COMP & !<-- Put extracted value here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Task Neighbors from Solver Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The Solver import state - ,name ='MY_NEB' & !<-- Name of the attribute to extract - ,valueList=int_state%MY_NEB & !<-- Insert Attribute into Solver internal state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Insert the local domain starting limits and the halo width into -!*** the Solver internal state. -!----------------------------------------------------------------------- -! - ITS=int_state%ITS - ITE=int_state%ITE - IMS=int_state%IMS - IME=int_state%IME - IDS=int_state%IDS - IDE=int_state%IDE -! - JTS=int_state%JTS - JTE=int_state%JTE - JMS=int_state%JMS - JME=int_state%JME - JDS=int_state%JDS - JDE=int_state%JDE -! - int_state%ITS_B1=MAX(ITS,IDS+1) - int_state%ITE_B1=MIN(ITE,IDE-1) - int_state%ITS_B2=MAX(ITS,IDS+2) - int_state%ITE_B2=MIN(ITE,IDE-2) - int_state%ITS_B1_H1=MAX(ITS-1,IDS+1) - int_state%ITE_B1_H1=MIN(ITE+1,IDE-1) - int_state%ITE_B1_H2=MIN(ITE+2,IDE-1) - int_state%ITS_H1=MAX(ITS-1,IDS) - int_state%ITE_H1=MIN(ITE+1,IDE) - int_state%ITS_H2=MAX(ITS-2,IDS) - int_state%ITE_H2=MIN(ITE+2,IDE) - int_state%JTS_B1=MAX(JTS,JDS+1) - int_state%JTE_B1=MIN(JTE,JDE-1) - int_state%JTS_B2=MAX(JTS,JDS+2) - int_state%JTE_B2=MIN(JTE,JDE-2) - int_state%JTS_B1_H1=MAX(JTS-1,JDS+1) - int_state%JTE_B1_H1=MIN(JTE+1,JDE-1) - int_state%JTE_B1_H2=MIN(JTE+2,JDE-1) - int_state%JTS_H1=MAX(JTS-1,JDS) - int_state%JTE_H1=MIN(JTE+1,JDE) - int_state%JTS_H2=MAX(JTS-2,JDS) - int_state%JTE_H2=MIN(JTE+2,JDE) -! - IHALO=int_state%IHALO - JHALO=int_state%JHALO -! - ! Disable the tracker by default. This may be overridden below - ! when reading the configure file. - int_state%NTRACK_trigger=0 -! - IF(IHALO==JHALO)THEN - int_state%NHALO=IHALO - ELSE - RC_INIT=ESMF_FAILURE - WRITE(0,*)'Error due to ihalo /= jhalo' - ENDIF -! -!----------------------------------------------------------------------- -!*** Use ESMF utilities to get information from the configuration file. -!*** The function is similar to reading a namelist. The GET_CONFIG -!*** routine is the user's. It extracts values from the config file -!*** and places them in the namelist components of the internal state. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Configure File Parameters for Solver" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL GET_CONFIG_DIMS (GRID_COMP & - ,int_state%INPES,int_state%JNPES & - ,LM & - ,int_state%NUM_TRACERS_CHEM & - ,int_state%PCPHR & - ,int_state%GFS & - ,int_state%MICROPHYSICS & - ,int_state%SHORTWAVE & - ,int_state%LONGWAVE & - ,int_state%LMPRATE & - ,int_state%LNSH, int_state%LNSV & - ,RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - LNSH=int_state%LNSH - LNSV=int_state%LNSV -! -!----------------------------------------------------------------------- -!*** We must know whether or not this is a global domain. Get the -!*** configure object from the Solver component and extract the -!*** value of 'global'. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Solver_Init: Retrieve Config Object from Solver Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGet(gridcomp=GRID_COMP & !<--- The Solver component - ,config =CF & !<--- The configure (namelist) object - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Solver_Init: Extract GLOBAL from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%GLOBAL & !<-- Put extracted quantity here - ,label ='global:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! Is the tracker enabled? Triggers allocations later on. (Or, rather, -! it would do that if such a thing was supported by the current -! framework.) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =int_state%NTRACK_TRIGGER & !<-- Put extracted quantity here - ,label ='ntrack:' & !<-- The quantity's label in the configure file - ,rc =RC) - if(RC/=0) then - print '(A)','Disabling tracker and tracker vars for domain.' - int_state%NTRACK_TRIGGER=0 - endif - - int_state%HIFREQ_file=' ' - int_state%PATCF_file=' ' - if(int_state%NTRACK_TRIGGER /= 0) then ! Check for additional tracker options. - ! Per-timestep output. - call ESMF_ConfigGetAttribute(config=CF,value=int_state%HIFREQ_file,label='hifreq:',rc=RC) - if(RC/=0) then - print '(A)','Disabling per-timestep output because "hifreq:" was not specified.' - int_state%HIFREQ_file=' ' - endif - ! Per-tracker-step output. - call ESMF_ConfigGetAttribute(config=CF,value=int_state%PATCF_file,label='patcf:',rc=RC) - if(RC/=0) then - print '(A)','Disabling tracker output because "patcf:" was not specified.' - int_state%PATCF_file=' ' - endif - endif -! -!----------------------------------------------------------------------- -!*** Retrieve the VM to obtain the task ID and total number of tasks -!*** for the internal state. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get VM from the Solver Gridded Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGet(gridcomp=GRID_COMP & !<-- The Solver gridded component - ,vm =VM & !<-- The ESMF Virtual Machine - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Task IDs and Number of MPI Tasks from VM" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_VMGet(vm =VM & !<-- The ESMF virtual machine - ,localpet=int_state%MYPE & !<-- My task's local rank on this domain - ,petcount=int_state%NUM_PES & !<-- Total number of MPI tasks - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** int_state%NUM_PES taken from VM is the total number of tasks -!*** on this domain including Write/Quilt tasks. We want only the -!*** number of forecast tasks. -!----------------------------------------------------------------------- -! - int_state%NUM_PES=int_state%INPES*int_state%JNPES -! - NUM_PES=int_state%NUM_PES !<-- The number of forecast tasks - MYPE=int_state%MYPE !<-- The local task ID -! -!----------------------------------------------------------------------- -!*** Only forecast tasks are needed for the remaining -!*** initialization process. -!----------------------------------------------------------------------- -! - fcst_tasks: IF(MYPE int_state%TRACERS(:,:,:,INDX_Q2) - int_state%OMGALF(I,J,L)=0. - int_state%T(I,J,L)=-1.E6 - int_state%U(I,J,L)=-1.E6 - int_state%V(I,J,L)=-1.E6 - int_state%RLWTT(I,J,L)=0. - int_state%RSWTT(I,J,L)=0. - int_state%EXCH_H(I,J,L)=0. - int_state%XLEN_MIX(I,J,L)=0. - int_state%CLDFRA(I,J,L)=0. - int_state%TRAIN(I,J,L) =0. - int_state%TCUCN(I,J,L) =0. - int_state%TCT(I,J,L) =-1.E6 - int_state%TCU(I,J,L) =-1.E6 - int_state%TCV(I,J,L) =-1.E6 - int_state%W_TOT(I,J,L)=0. - ENDDO - ENDDO - ENDDO -! - int_state%I_PAR_STA=0 - int_state%J_PAR_STA=0 - int_state%NMTS=-999 -! - DO L=1,NUM_SOIL_LAYERS - int_state%SLDPTH(L)=SLDPTH(L) - DO J=JMS,JME - DO I=IMS,IME - int_state%SMC(I,J,L)=-1.E6 - int_state%STC(I,J,L)=-1.E6 - int_state%SH2O(I,J,L)=-1.E6 - ENDDO - ENDDO - ENDDO -! - DO L=1,MICRO_RESTART - int_state%MP_RESTART_STATE(L)=0. - int_state%TBPVS_STATE(L)=0. - int_state%TBPVS0_STATE(L)=0. - ENDDO - DO L=1, int_state%MDRMAXout-int_state%MDRMINout+1 - int_state%MASSRout(L)=0. - ENDDO - DO L=1, int_state%MDIMAXout-int_state%MDIMINout+1 - int_state%MASSIout(L)=0. - ENDDO -! - int_state%NSOIL=NUM_SOIL_LAYERS -! - DO J=JMS,JME - DO I=IMS,IME - int_state%LPBL(I,J) =-999 - int_state%NCFRCV(I,J) =-999 - int_state%NCFRST(I,J) =-999 - int_state%ACFRCV(I,J) =-1.E6 - int_state%ACFRST(I,J) =-1.E6 - int_state%AKHS(I,J) = 0. - int_state%AKHS_OUT(I,J)= 0. - int_state%AKMS(I,J) = 0. - int_state%AKMS_OUT(I,J)= 0. - int_state%ALBASE(I,J) =-1.E6 - int_state%ALBEDO(I,J) =-1.E6 - int_state%ALWIN(I,J) =-1.E6 - int_state%ALWOUT(I,J) =-1.E6 - int_state%ALWTOA(I,J) =-1.E6 - int_state%ASWIN(I,J) =-1.E6 - int_state%ASWOUT(I,J) =-1.E6 - int_state%ASWTOA(I,J) =-1.E6 - int_state%BGROFF(I,J) =-1.E6 - int_state%CFRACH(I,J) =-1.E6 - int_state%CFRACM(I,J) =-1.E6 - int_state%CFRACL(I,J) =-1.E6 - int_state%CNVBOT(I,J) =0.0 - int_state%CNVTOP(I,J) =0.0 - int_state%CMC(I,J) =-1.E6 - int_state%CPRATE(I,J) =0.0 - int_state%CUPPT(I,J) =-1.E6 - int_state%CZMEAN(I,J) =-1.E6 - int_state%CZEN(I,J) =-1.E6 - int_state%LSPA(I,J) =-1.E6 - int_state%EPSR(I,J) =-1.E6 - int_state%FIS(I,J) =-1.E6 - int_state%HBOT(I,J) =-1.E6 - int_state%HBOTD(I,J) =-1.E6 - int_state%HBOTS(I,J) =-1.E6 - int_state%HTOP(I,J) =-1.E6 - int_state%HTOPD(I,J) =-1.E6 - int_state%HTOPS(I,J) =-1.E6 - int_state%GRNFLX(I,J) = 0. - int_state%MAVAIL(I,J) = 1. - int_state%MXSNAL(I,J) =-1.E6 - int_state%PBLH(I,J) =-1.E6 - int_state%MIXHT(I,J) =0. - int_state%PD(I,J) =-1.E6 - int_state%POTEVP(I,J) = 0. - int_state%POTFLX(I,J) =-1.E6 - int_state%QSH(I,J) = 0. - int_state%QWBS(I,J) =-1.E6 - int_state%QZ0(I,J) = 0. - int_state%RADOT(I,J) = 0. - int_state%RLWIN(I,J) = 0. - int_state%RMOL(I,J) =-1.E6 - int_state%RSWIN(I,J) = 0. - int_state%RSWINC(I,J) = 0. - int_state%RSWOUT(I,J) = 0. - int_state%RLWTOA(I,J) = 0. - int_state%RSWTOA(I,J) = 0. - int_state%SFCEVP(I,J) = 0. - int_state%SFCEXC(I,J) = 0. - int_state%SFCLHX(I,J) =-1.E6 - int_state%SFCSHX(I,J) =-1.E6 - int_state%SICE(I,J) =-1.E6 - int_state%SIGT4(I,J) =-1.E6 - int_state%SM(I,J) =-1.E6 - int_state%SMSTAV(I,J) = 0. - int_state%SMSTOT(I,J) = 0. - int_state%SNO(I,J) = 0. - int_state%SNOWC(I,J) = 0. - int_state%SNOPCX(I,J) =-1.E6 - int_state%SOILTB(I,J) = 273. - int_state%SR(I,J) =-1.E6 - int_state%SSROFF(I,J) = 0. - int_state%SST(I,J) = 273. - int_state%SUBSHX(I,J) =-1.E6 - int_state%THS(I,J) =-1.E6 - int_state%THZ0(I,J) = 273. - int_state%TSKIN(I,J) =-1.E6 - int_state%TWBS(I,J) =-1.E6 - int_state%USTAR(I,J) = 0.1 - int_state%UZ0(I,J) = 0. - int_state%VEGFRC(I,J) =-1.E6 - int_state%VZ0(I,J) = 0. - int_state%Z0(I,J) =-1.E6 - int_state%Z0BASE(I,J) =-1.E6 - int_state%STDH(I,J) =-1.E6 - int_state%CROT(I,J) = 0. - int_state%SROT(I,J) = 0. - int_state%HSTDV(I,J) = 0. - int_state%HCNVX(I,J) = 0. - int_state%HASYW(I,J) = 0. - int_state%HASYS(I,J) = 0. - int_state%HASYSW(I,J) = 0. - int_state%HASYNW(I,J) = 0. - int_state%HLENW(I,J) = 0. - int_state%HLENS(I,J) = 0. - int_state%HLENSW(I,J) = 0. - int_state%HLENNW(I,J) = 0. - int_state%HANGL(I,J) = 0. - int_state%HANIS(I,J) = 0. - int_state%HSLOP(I,J) = 0. - int_state%HZMAX(I,J) = 0. - ENDDO - ENDDO -! - DO J=JMS,JME - DO I=IMS,IME - int_state%ACSNOM(I,J)= 0. - int_state%ACSNOW(I,J)= 0. - int_state%ACPREC(I,J)= 0. - int_state%ACPREC_TOT(I,J)= 0. - int_state%acpcp_ra(I,J)= 0. - int_state%acpcp_sn(I,J)= 0. - int_state%acpcp_gr(I,J)= 0. - int_state%CUPREC(I,J)= 0. - int_state%PREC(I,J) = 0. - int_state%CLDEFI(I,J)= 0. - int_state%PSHLTR(I,J)= 1.E5 - int_state%P10(I,J) = 1.E5 - int_state%PSFC(I,J) = 1.E5 - int_state%Q02(I,J) = 0. - int_state%Q10(I,J) = 0. - int_state%QSHLTR(I,J)= 0. - int_state%T2(I,J) = 273. - int_state%TH02(I,J) = 0. - int_state%TH10(I,J) = 273. - int_state%TSHLTR(I,J)= 273. - int_state%U10(I,J) = 0. - int_state%V10(I,J) = 0. - int_state%TLMIN(I,J) = 0. - int_state%TLMAX(I,J) = 0. - - int_state%ACUTIM(I,J)= 0. - int_state%APHTIM(I,J)= 0. - int_state%ARDLW(I,J) = 0. - int_state%ARDSW(I,J) = 0. - int_state%ASRFC(I,J) = 0. - int_state%AVRAIN(I,J)= 0. - int_state%AVCNVC(I,J)= 0. - ENDDO - ENDDO -! - IF (int_state%has_reqc.eq.1 .and. int_state%has_reqi.eq.1 .and. int_state%has_reqs.eq.1) THEN - DO L=1,LM - DO J=JMS,JME - DO I=IMS,IME - int_state%re_cloud(I,J,L)=2.51E-6 - int_state%re_ice(I,J,L)=10.1E-6 - int_state%re_snow(I,J,L)=20.1E-6 - ENDDO - ENDDO - ENDDO - ENDIF -! - DO J=JMS,JME - DO I=IMS,IME - int_state%TLMAX(I,J)=-999. - int_state%TLMIN(I,J)=999. - int_state%T02MAX(I,J)=-999. - int_state%T02MIN(I,J)=999. - int_state%RH02MAX(I,J)=-999. - int_state%RH02MIN(I,J)=999. - int_state%SPD10MAX(I,J)=-999. - int_state%UPHLMAX(I,J)=0. - int_state%U10MAX(I,J)=-999. - int_state%V10MAX(I,J)=-999. - int_state%UPVVELMAX(I,J)=-999. - int_state%DNVVELMAX(I,J)=999. - int_state%T10AVG(I,J)=0. - int_state%T10(I,J)=0. - int_state%PSFCAVG(I,J)=0. - int_state%AKHSAVG(I,J)=0. - int_state%AKMSAVG(I,J)=0. - int_state%SNOAVG(I,J)=0. - int_state%REFDMAX(I,J)=DBZmin - int_state%UPHLMAX(I,J)=-999. - ENDDO - ENDDO - int_state%NCOUNT=0 -! - DO N=1,NUM_DOMAINS_MAX - int_state%NTSCM(N)=-999 - ENDDO -! - int_state%BDY_WAS_READ=.FALSE. -! -!! End of tracker variables -!### Tracker scalar integer -!rv int_state%NTRACK=0 - int_state%TRACK_HAVE_GUESS=0 - int_state%TRACK_N_OLD=0 - int_state%TRACKER_HAVEFIX=0 - int_state%TRACKER_GAVE_UP=0 -!### Tracker scalar real - int_state%TRACK_LAST_HOUR=0. - int_state%TRACK_GUESS_LAT=0. - int_state%TRACK_GUESS_LON=0. - int_state%TRACK_EDGE_DIST=0. - int_state%TRACK_STDERR_M1=0. - int_state%TRACK_STDERR_M2=0. - int_state%TRACK_STDERR_M3=0. - int_state%TRACKER_FIXLAT=0. - int_state%TRACKER_FIXLON=0. - int_state%TRACKER_IFIX=0. - int_state%TRACKER_JFIX=0. - int_state%TRACKER_RMW=0. - int_state%TRACKER_PMIN=0. - int_state%TRACKER_VMAX=0. -!### Tracker 1D integer - DO I=1,TRACK_MAX_OLD - int_state%TRACK_OLD_NTSD(I)=0 - ENDDO -!### Tracker 1D real - DO I=1,TRACK_MAX_OLD - int_state%TRACK_OLD_LAT(I)=0. - int_state%TRACK_OLD_LON(I)=0. - ENDDO -!### Tracker 2D integer - DO J=JMS,JME - DO I=IMS,IME - int_state%TRACKER_FIXES(I,J)=-999. - ENDDO - ENDDO -!### Tracker 2D real - DO J=JMS,JME - DO I=IMS,IME - int_state%MEMBRANE_MSLP(I,J)=0. - int_state%P850RV(I,J)=0. - int_state%P700RV(I,J)=0. - int_state%P850WIND(I,J)=0. - int_state%P700WIND(I,J)=0. - int_state%P500U(I,J)=0. - int_state%P500V(I,J)=0. - int_state%P700U(I,J)=0. - int_state%P700V(I,J)=0. - int_state%P850U(I,J)=0. - int_state%P850V(I,J)=0. - int_state%P850Z(I,J)=0. - int_state%P700Z(I,J)=0. - int_state%M10WIND(I,J)=0. - int_state%M10RV(I,J)=0. - int_state%SP850RV(I,J)=0. - int_state%SP700RV(I,J)=0. - int_state%SP850WIND(I,J)=0. - int_state%SP700WIND(I,J)=0. - int_state%SP850Z(I,J)=0. - int_state%SP700Z(I,J)=0. - int_state%SM10WIND(I,J)=0. - int_state%SM10RV(I,J)=0. - int_state%SMSLP(I,J)=0. - int_state%TRACKER_ANGLE(I,J)=0. - int_state%TRACKER_DISTSQ(I,J)=0. - ENDDO - ENDDO -!! End of tracker variables -! -!----------------------------------------------------------------------- -!*** Initialize the timer variables now. -!----------------------------------------------------------------------- -! - TD=>TIMERS(MY_DOMAIN_ID_LOC) !<-- Abbreviate the name of this domain's timers -! - td%adv1_tim=0. - td%adv2_tim=0. - td%bocoh_tim=0. - td%bocov_tim=0. - td%cdwdt_tim=0. - td%cdzdt_tim=0. - td%consts_tim=0. - td%ddamp_tim=0. - td%dht_tim=0. - td%exch_dyn=0. - td%exch_phy=0. - td%exch_tim=0. - td%fftfhn_tim=0. - td%fftfwn_tim=0. - td%hdiff_tim=0. - td%mono_tim=0. - td%pdtsdt_tim=0. - td%pgforce_tim=0. - td%poavhn_tim=0. - td%polehn_tim=0. - td%pole_swap_tim=0. - td%polewn_tim=0. - td%prefft_tim=0. - td%presmud_tim=0. - td%solver_init_tim=0. - td%solver_dyn_tim=0. - td%solver_phy_tim=0. - td%swaphn_tim=0. - td%swapwn_tim=0. - td%updatet_tim=0. - td%updateuv_tim=0. - td%updates_tim=0. - td%vsound_tim=0. - td%vtoa_tim=0. -! - td%cucnvc_tim=0. - td%gsmdrive_tim=0. - td%cltend_tim=0. - td%rfupdate_tim=0. - td%tqadjust_tim=0. - td%h_to_v_tim=0. - td%radiation_tim=0. - td%rdtemp_tim=0. - td%turbl_tim=0. - td%adjppt_tim=0. - td%gfs_phy_tim=0. -! -!----------------------------------------------------------------------- -! - ITS=int_state%ITS - ITE=int_state%ITE - JTS=int_state%JTS - JTE=int_state%JTE - IMS=int_state%IMS - IME=int_state%IME - JMS=int_state%JMS - JME=int_state%JME - IDS=int_state%IDS - IDE=int_state%IDE - JDS=int_state%JDS - JDE=int_state%JDE -! - IHALO=int_state%IHALO - JHALO=int_state%JHALO -! - MYPE=int_state%MYPE - MY_DOMAIN_ID=int_state%MY_DOMAIN_ID - MPI_COMM_COMP=int_state%MPI_COMM_COMP - NUM_PES=int_state%NUM_PES -! - DO N=1,8 - MY_NEB(N)=int_state%MY_NEB(N) - ENDDO -! -!----------------------------------------------------------------------- -!*** Extract all forecast tasks' horizontal subdomain limits -!*** from the Solver import state and give them to the -!*** Solver internal state. -!*** This is necessary if quilting is selected because these -!*** limits will be taken from the Solver internal state, -!*** placed into the Write components' import states and -!*** used for the combining of local domain data onto the -!*** global domain. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Local Domain Limits to Solver Internal State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The Solver import state - ,name ='LOCAL_ISTART' & !<-- Name of the attribute to extract - ,valueList=int_state%LOCAL_ISTART & !<-- Insert Attribute into Solver internal state - ,rc =RC) -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The Solver import state - ,name ='LOCAL_IEND' & !<-- Name of the attribute to extract - ,valueList=int_state%LOCAL_IEND & !<-- Insert Attribute into Solver internal state - ,rc =RC) -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The Solver import state - ,name ='LOCAL_JSTART' & !<-- Name of the attribute to extract - ,valueList=int_state%LOCAL_JSTART & !<-- Insert Attribute into Solver internal state - ,rc =RC) -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- The Solver import state - ,name ='LOCAL_JEND' & !<-- Name of the attribute to extract - ,valueList=int_state%LOCAL_JEND & !<-- Insert Attribute into Solver internal state - ,rc =RC) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Fill the ESMF Bundle with the user-selected boundary variables -!*** and also the generalized boundary object that Solver must use -!*** when handling those boundary variables. This must take place -!*** here because it must follow the creation of the Solver's -!*** internal state but precede the call to the read routine. For -!*** restarted runs the read routine must allocate an object to -!*** hold special boundary data from the restart files and the size -!*** of tha object depends on values determined when the ESMF Bundle -!*** is filled. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Solver Init Extracts BC Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =IMP_STATE & !<-- The Solver component import state - ,itemname ='Bundle_nestbc' & !<-- Name of Bundle of selected BC variables - ,fieldbundle=BUNDLE_NESTBC & !<-- The Bundle - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - UBOUND_VARS=SIZE(int_state%VARS) -! - CALL BUILD_BC_BUNDLE(GRID & !<-- Add Solver int state variables to the nest BC Bundle - ,LNSH,LNSV & - ,IHALO,JHALO & - ,UBOUND_VARS & - ,int_state%VARS & - ,MY_DOMAIN_ID & - ,BUNDLE_NESTBC & - ,int_state%BND_VARS_H & - ,int_state%BND_VARS_V & - ,int_state%NVARS_BC_2D_H & - ,int_state%NVARS_BC_3D_H & - ,int_state%NVARS_BC_4D_H & - ,int_state%NVARS_BC_2D_V & - ,int_state%NVARS_BC_3D_V & - ,int_state%NLEV_H & - ,int_state%NLEV_V & - ,int_state%N_BC_3D_H & - ) -! -!----------------------------------------------------------------------- -!*** The input file is about to be read and halo exchanges will be -!*** done in conjunction with that process. The halo exchange -!*** routines require 15 domain-related variables so set them now. -!----------------------------------------------------------------------- -! - CALL SET_DOMAIN_SPECS(int_state%ITS,int_state%ITE & - ,int_state%JTS,int_state%JTE & - ,int_state%IMS,int_state%IME & - ,int_state%JMS,int_state%JME & - ,int_state%IDS,int_state%IDE & - ,int_state%JDS,int_state%JDE & - ,int_state%IHALO,int_state%JHALO & - ,int_state%MY_DOMAIN_ID & - ,int_state%MYPE & - ,int_state%MY_NEB & - ,int_state%MPI_COMM_COMP & - ,int_state%NUM_PES & - ,LOCAL_ISTART_IN=int_state%LOCAL_ISTART & - ,LOCAL_IEND_IN=int_state%LOCAL_IEND & - ,LOCAL_JSTART_IN=int_state%LOCAL_JSTART & - ,LOCAL_JEND_IN=int_state%LOCAL_JEND & - ) -! -!----------------------------------------------------------------------- -!*** Read the input file. -!----------------------------------------------------------------------- -! - KSS=1 - KSE=int_state%NUM_TRACERS_MET -! - ITS_H2=MAX(ITS-2,int_state%IDS) - ITE_H2=MIN(ITE+2,int_state%IDE) - JTS_H2=MAX(JTS-2,int_state%JDS) - JTE_H2=MIN(JTE+2,int_state%JDE) -! - btim=timef() -! - -! write(0,*)'int_state%NEMSIO_INPUT=',int_state%NEMSIO_INPUT !wang - IF(.NOT.int_state%NEMSIO_INPUT)THEN -! - CALL READ_BINARY(INT_STATE & - ,MY_DOMAIN_ID & - ,MPI_COMM_COMP & - ,int_state%MYPE & - ,int_state%ITS,int_state%ITE & - ,int_state%JTS,int_state%JTE & - ,int_state%IMS,int_state%IME & - ,int_state%JMS,int_state%JME & - ,int_state%IDS,int_state%IDE & - ,int_state%JDS,int_state%JDE & - ,ITS_H2,ITE_H2,JTS_H2,JTE_H2 & - ,LM & - ,RC) -! - IF (RC /= 0) THEN - RC_INIT = RC - RETURN - END IF -! - ELSE -! -! write(0,*) 'mype=',mype,'call read_nemsio' - CALL READ_NEMSIO(int_state,MY_DOMAIN_ID,RC) -! - IF (RC /= 0) THEN - RC_INIT = RC - RETURN - END IF -! - ENDIF -!rv -! Use this (OPER) for operational run, for having vertical velocity -! in history file (00hr) when starting from restart file -!rv - IF(int_state%OPER) THEN - DO L=1,LM - DO J=JMS,JME - DO I=IMS,IME - int_state%W_TOT(I,J,L)=int_state%W(I,J,L) - ENDDO - ENDDO - ENDDO - ENDIF -!rv -! - if (mype==-9999) then - write(0,*)'solver' - write(0,*)'ihr,ihrst,lpt2,ntstm=',int_state%ihr,int_state%ihrst,int_state%lpt2,int_state%ntstm - write(0,*)'idat=',int_state%idat(1),int_state%idat(2),int_state%idat(3) - write(0,*)'dsg1=',minval(int_state%dsg1),maxval(int_state%dsg1) - write(0,*)'pdsg1=',minval(int_state%pdsg1),maxval(int_state%pdsg1) - write(0,*)'psgml1=',minval(int_state%psgml1),maxval(int_state%psgml1) - write(0,*)'sgml1=',minval(int_state%sgml1),maxval(int_state%sgml1) - write(0,*)'sgml2=',minval(int_state%sgml2),maxval(int_state%sgml2) - write(0,*)'psg1=',minval(int_state%psg1),maxval(int_state%psg1) - write(0,*)'sg1=',minval(int_state%sg1),maxval(int_state%sg1) - write(0,*)'sg2=',minval(int_state%sg2),maxval(int_state%sg2) - write(0,*)'fis=',minval(int_state%fis),maxval(int_state%fis) - write(0,*)'pd=',minval(int_state%pd),maxval(int_state%pd) - write(0,*)'pdo=',minval(int_state%pdo),maxval(int_state%pdo) - write(0,*)'sice=',minval(int_state%sice),maxval(int_state%sice) - write(0,*)'sm=',minval(int_state%sm),maxval(int_state%sm) - write(0,*)'cw=',minval(int_state%cw),maxval(int_state%cw) - write(0,*)'dwdt=',minval(int_state%dwdt),maxval(int_state%dwdt) - write(0,*)'q=',minval(int_state%q),maxval(int_state%q) - write(0,*)'q2=',minval(int_state%q2),maxval(int_state%q2) - write(0,*)'o3=',minval(int_state%o3),maxval(int_state%o3) - write(0,*)'omgalf=',minval(int_state%omgalf),maxval(int_state%omgalf) - write(0,*)'div=',minval(int_state%div),maxval(int_state%div) - write(0,*)'z=',minval(int_state%z),maxval(int_state%z) - write(0,*)'rtop=',minval(int_state%rtop),maxval(int_state%rtop) - write(0,*)'tcu=',minval(int_state%tcu),maxval(int_state%tcu) - write(0,*)'tcv=',minval(int_state%tcv),maxval(int_state%tcv) - write(0,*)'tct=',minval(int_state%tct),maxval(int_state%tct) - write(0,*)'t=',minval(int_state%t),maxval(int_state%t) - write(0,*)'tp=',minval(int_state%tp),maxval(int_state%tp) - write(0,*)'u=',minval(int_state%u),maxval(int_state%u) - write(0,*)'up=',minval(int_state%up),maxval(int_state%up) - write(0,*)'v=',minval(int_state%v),maxval(int_state%v) - write(0,*)'vp=',minval(int_state%vp),maxval(int_state%vp) - write(0,*)'w=',minval(int_state%w),maxval(int_state%w) - write(0,*)'w_tot=',minval(int_state%w_tot),maxval(int_state%w_tot) - write(0,*)'pint=',minval(int_state%pint),maxval(int_state%pint) - write(0,*)'tracers=',minval(int_state%tracers),maxval(int_state%tracers) -! write(0,*)'sp=',minval(int_state%sp),maxval(int_state%sp) - write(0,*)'run=',int_state%run - endif -! -!----------------------------------------------------------------------- -!*** Check if starting Date/Time in input data file agrees with -!*** the configure file. -!----------------------------------------------------------------------- -! - IF(.NOT.int_state%RESTART.AND.MYPE==0)THEN - IF(int_state%START_HOUR /=int_state%IHRST.OR. & - int_state%START_DAY /=int_state%IDAT(1).OR. & - int_state%START_MONTH/=int_state%IDAT(2).OR. & - int_state%START_YEAR /=int_state%IDAT(3))THEN - WRITE(0,*)' *** WARNING *** WARNING *** WARNING *** ' - WRITE(0,*)' *** WARNING *** WARNING *** WARNING *** ' - WRITE(0,*)' DATES IN INPUT AND CONFIGURE FILES DISAGREE!!' - WRITE(0,*)' INPUT: HOUR=',int_state%IHRST & - , ' DAY=',int_state%IDAT(1) & - , ' MONTH=',int_state%IDAT(2) & - , ' YEAR=',int_state%IDAT(3) - WRITE(0,*)' CONFIG: HOUR=',int_state%START_HOUR & - , ' DAY=',int_state%START_DAY & - , ' MONTH=',int_state%START_MONTH & - , ' YEAR=',int_state%START_YEAR - WRITE(0,*)' *** WARNING *** WARNING *** WARNING *** ' - WRITE(0,*)' *** WARNING *** WARNING *** WARNING *** ' - ENDIF - ENDIF -! -!----------------------------------------------------------------------- -! - td%solver_init_tim=td%solver_init_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Nested domains do not have boundary condition files since the -!*** boundary values come from their parents. However the boundary -!*** variable arrays need to contain initial values before tendencies -!*** from the parent can be added. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Retrieve the Nest/Not_A_Nest flag from the Solver import state. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Nest/Not-a-Nest Flag from Solver Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Solver import state - ,name ='I-Am-A-Nest Flag' & !<-- Name of variable to get from Solver import state - ,value=I_AM_A_NEST & !<-- Put extracted value here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - int_state%I_AM_A_NEST=I_AM_A_NEST -! - IF(I_AM_A_NEST)THEN -! -!----------------------------------------------------------------------- -!*** Also we need to retrieve the Parent-Child timestep ratio in order -!*** to know how often to update the boundary tendencies. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Parent-Child Time Ratio from Solver Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Solver import state - ,name ='Parent-Child Time Ratio' & !<-- Name of variable to get from Solver import state - ,value=int_state%PARENT_CHILD_TIME_RATIO & !<-- Put extracted value here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Does this nested domain move? -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Nest Move Flag from Solver Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Solver import state - ,name ='My Domain Moves' & !<-- Name of variable to get from Solver import state - ,value=int_state%MY_DOMAIN_MOVES & !<-- Put extracted value here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Currently moving nests are not allowed to use gravity wave drag. -!*** One quantity used in that parameterization is the mountains' -!*** angle with respect to east. From the moving nest's perspective -!*** the mountains are moving and thus that angle would need to be -!*** updated with each shift of the domain. That is not handled -!*** yet in the code. -!----------------------------------------------------------------------- -! - IF(int_state%MY_DOMAIN_MOVES)THEN -! - int_state%GWDFLG=.FALSE. -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Assign grid-related constants after dereferencing needed variables. -!----------------------------------------------------------------------- -! - btim=timef() -! - CALL CONSTS(int_state%GLOBAL & - ,int_state%DT & - ,int_state%SMAG2 & - ,int_state%CODAMP,int_state%WCOR & - ,int_state%PT & - ,int_state%TPH0D,int_state%TLM0D & - ,int_state%SBD,int_state%WBD & - ,int_state%DPHD,int_state%DLMD & - ,int_state%DXH,int_state%RDXH & - ,int_state%DXV,int_state%RDXV & - ,int_state%DYH,int_state%RDYH & - ,int_state%DYV,int_state%RDYV & - ,int_state%DDV,int_state%RDDV & - ,int_state%DDMPU,int_state%DDMPV & - ,int_state%EF4T,int_state%WPDAR & - ,int_state%FCP,int_state%FDIV & - ,int_state%CURV,int_state%F & - ,int_state%FAD,int_state%FAH & - ,int_state%DARE,int_state%RARE & - ,int_state%GLAT,int_state%GLON & - ,int_state%GLAT_SW,int_state%GLON_SW & - ,int_state%VLAT,int_state%VLON & - ,int_state%HDACX,int_state%HDACY & - ,int_state%HDACVX,int_state%HDACVY & - ,int_state%LNSH,int_state%LNSAD & - ,int_state%ADV_STANDARD,int_state%ADV_UPSTREAM & - ,int_state%E_BDY,int_state%N_BDY & - ,int_state%S_BDY,int_state%W_BDY & - ,int_state%NBOCO,int_state%TBOCO & - ,MY_DOMAIN_ID,MYPE & - ,ITS,ITE,JTS,JTE & - ,IMS,IME,JMS,JME & - ,IDS,IDE,JDS,JDE ) -! - td%consts_tim=td%consts_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Exchange haloes for some grid-related arrays in case there are -!*** moving nests. -!----------------------------------------------------------------------- -! - CALL HALO_EXCH & - (int_state%GLAT,1 & - ,int_state%GLON,1 & - ,int_state%VLAT,1 & - ,int_state%VLON,1 & - ,3,3) -! - CALL HALO_EXCH & - (int_state%HDACX,1 & - ,int_state%HDACY,1 & - ,int_state%HDACVX,1 & - ,int_state%HDACVY,1 & - ,3,3) -! - CALL HALO_EXCH & - (int_state%F,1 & - ,3,3) -! -!----------------------------------------------------------------------- -!*** Search for lat/lon min/max values and store it in file for -!*** later use in creating GrADS ctl file -!----------------------------------------------------------------------- -! - CALL LAT_LON_BNDS(int_state%GLAT,int_state%GLON & - ,mype,num_pes,mpi_comm_comp & - ,ids,ide,jds,jde & - ,ims,ime,jms,jme & - ,its,ite,jts,jte & - ,my_domain_id ) -! -! -!----------------------------------------------------------------------- -!*** Initialize the FFT filters. -!----------------------------------------------------------------------- -! - IF(int_state%GLOBAL)THEN - btim=timef() -! - CALL PREFFT(int_state%DLMD,int_state%DPHD,int_state%SBD,LM & - ,int_state%KHFILT,int_state%KVFILT & - ,int_state%HFILT,int_state%VFILT & - ,int_state%WFFTRH,int_state%NFFTRH & - ,int_state%WFFTRW,int_state%NFFTRW & - ,int_state%INPES,int_state%JNPES,int_state%MYPE) -! - td%prefft_tim=td%prefft_tim+(timef()-btim) -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Initialize the physics schemes. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Initialize the Physics Schemes" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL PHYSICS_INITIALIZE(int_state%GFS & - ,int_state%SHORTWAVE & - ,int_state%LONGWAVE & - ,int_state%CONVECTION & - ,int_state%MICROPHYSICS & - ,int_state%SFC_LAYER & - ,int_state%TURBULENCE & - ,int_state%LAND_SURFACE & - ,int_state%CO2TF & - ,int_state%NP3D & - ,int_state%SBD & - ,int_state%WBD & - ,int_state%DPHD & - ,int_state%DLMD & - ,int_state%TPH0D & - ,int_state%TLM0D & - ,MY_DOMAIN_ID & - ,MYPE & - ,MPI_COMM_COMP & - ,IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE & - ,RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! Initialize the storm tracker if needed. -!----------------------------------------------------------------------- -! - IF(int_state%MYPE 0) - REAL (kind=KDBL) ,DIMENSION(1) :: TSEA,TISFC,ZORL,SLMSK,SNWDPH,WEASD,SNCOVR,SNOALB - REAL (kind=KDBL) ,DIMENSION(1) :: XSIHFCS,XSICFCS,XSLPFCS,XTG3FCS,XVEGFCS,XVETFCS,XSOTFCS - REAL (kind=KDBL) ,DIMENSION(1) :: ALVSF,ALNSF,ALVWF,ALNWF,FACSF,FACWF - REAL (kind=KDBL) ,DIMENSION(1) :: WRK, DPSHC, GQ, RANNUM_V - REAL (kind=KDBL) ,DIMENSION(1) :: ORO, EVAP, HFLX, CDQ, QSS - REAL (kind=KDBL) ,DIMENSION(:),ALLOCATABLE :: CLDCOV_V,PRSL,PRSLK,GU,GV,GT,GR,VVEL,F_ICE,F_RAIN,R_RIME - REAL (kind=KDBL) ,DIMENSION(:),ALLOCATABLE :: ADT,ADU,ADV,PHIL - REAL (kind=KDBL) ,DIMENSION(:,:),ALLOCATABLE :: GR3,ADR - REAL (kind=KDBL) ,DIMENSION(:),ALLOCATABLE :: PRSI,PRSIK,RSGM,PHII - REAL (kind=KDBL) ,DIMENSION(:),ALLOCATABLE :: SINLAT_R,COSLAT_R - REAL (kind=KDBL) ,DIMENSION(:,:),ALLOCATABLE :: XLON,COSZEN,COSZDG,RANN,SINLAT_V,COSLAT_V - REAL (kind=KDBL) ,DIMENSION(:),ALLOCATABLE :: RANNUM -! - REAL (kind=KDBL) ,DIMENSION(39) :: FLUXR_V - REAL (kind=KDBL) ,DIMENSION(:,:,:),ALLOCATABLE :: GR1 -! - REAL (kind=KDBL) ,DIMENSION(1) :: SFALB,TSFLW,SEMIS,SFCDLW,SFCDSW,SFCNSW - REAL (kind=KDBL) ,DIMENSION(1) :: NIRBMD_CPL,NIRDFD_CPL,VISBMD_CPL,VISDFD_CPL - REAL (kind=KDBL) ,DIMENSION(1) :: NIRBMU_CPL,NIRDFU_CPL,VISBMU_CPL,VISDFU_CPL - - - type (topfsw_type), dimension(1) :: topfsw - type (sfcfsw_type), dimension(1) :: sfcfsw - type (topflw_type), dimension(1) :: topflw - type (sfcflw_type), dimension(1) :: sfcflw - - REAL (kind=KDBL) ,DIMENSION(:),ALLOCATABLE :: SWH,HLW,DKH,RNP -!--- gbphys --- - LOGICAL :: OLD_MONIN, CNVGWD - INTEGER :: NEWSAS - INTEGER ,DIMENSION(2) :: NCW - REAL (kind=KDBL) :: CGWF(2),PRSLRD0 - REAL (kind=KDBL) :: CCWF,FAC - REAL (kind=KDBL) ,DIMENSION(1) :: CNVPRCP, TOTPRCP, TPRCP, SRFLAG, SHDMIN, SHDMAX, CANOPY - REAL (kind=KDBL) ,DIMENSION(1) :: RAIN, RAINC - REAL (kind=KDBL) ,DIMENSION(1) :: ACV, ACVB, ACVT - REAL (kind=KDBL) ,DIMENSION(2) :: FLGMIN - REAL (kind=KDBL) ,DIMENSION(3) :: CRTRH - REAL (kind=KDBL) ,DIMENSION(NUM_SOIL_LAYERS) :: SMC_V, STC_V, SLC_V - REAL (kind=KDBL) ,DIMENSION(14) :: HPRIME - REAL (kind=KDBL) ,DIMENSION(:),ALLOCATABLE :: UPD_MF, DWN_MF, DET_MF !!!!!!!!!!! not in use - REAL (kind=KDBL) ,DIMENSION(:),ALLOCATABLE :: DQDT !!!!!!!!!!! not in use - REAL (kind=KDBL) ,DIMENSION(:,:),ALLOCATABLE :: DQ3DT !!!!!!!!!!! (9=5+pl_coeff) - REAL (kind=KDBL) ,DIMENSION(:,:),ALLOCATABLE :: DT3DT !!!!!!!!!!! while - REAL (kind=KDBL) ,DIMENSION(:,:),ALLOCATABLE :: DU3DT, DV3DT !!!!!!!!!!! LDIAG3D =.FALSE. - - REAL (kind=KDBL) ,DIMENSION(:,:) ,ALLOCATABLE :: OZPLOUT_V - REAL (kind=KDBL) ,DIMENSION(:,:,:),ALLOCATABLE :: OZPLOUT - - REAL (kind=KDBL) ,DIMENSION(3) :: PHY_F2DV ! NUM_P2D for Zhao =3, Ferr=1 (fix later) - REAL (kind=KDBL) ,DIMENSION(:,:),ALLOCATABLE :: PHY_F3DV ! NUM_P3D for Zhao =4, Ferr=3 (fix later) -!--- gbphys output - REAL (kind=KDBL) ,DIMENSION(1) :: EVBSA, EVCWA, TRANSA, SBSNOA, SNOWCA, CLDWRK, PSMEAN - REAL (kind=KDBL) ,DIMENSION(1) :: CHH, CMM, EP, EPI, DLWSFCI, ULWSFCI, USWSFCI, DSWSFCI - REAL (kind=KDBL) ,DIMENSION(1) :: DLWSFC, ULWSFC, DTSFC, DQSFC, DUSFC, DVSFC, GFLUX - REAL (kind=KDBL) ,DIMENSION(1) :: DUSFCI, DVSFCI - REAL (kind=KDBL) ,DIMENSION(1) :: DTSFCI, DQSFCI, GFLUXI, T1, Q1, U1, V1 - REAL (kind=KDBL) ,DIMENSION(1) :: ZLVL, SOILM, RUNOFF, SRUNOFF, SUNTIM - REAL (kind=KDBL) ,DIMENSION(1) :: F10M, UUSTAR, FFMM, FFHH, SPFHMIN, SPFHMAX - REAL (kind=KDBL) ,DIMENSION(1) :: PSURF, U10M, V10M, T2M, Q2M, HPBL, PWAT, SNOHFA - REAL (kind=KDBL) ,DIMENSION(1) :: DLWSFC_CC, ULWSFC_CC, DTSFC_CC, SWSFC_CC - REAL (kind=KDBL) ,DIMENSION(1) :: DUSFC_CC, DVSFC_CC, DQSFC_CC, PRECR_CC - REAL (kind=KDBL) ,DIMENSION(1) :: DUSFC_CPL,DVSFC_CPL,DTSFC_CPL,DQSFC_CPL - REAL (kind=KDBL) ,DIMENSION(1) :: DLWSFC_CPL,DSWSFC_CPL,DNIRBM_CPL,DNIRDF_CPL - REAL (kind=KDBL) ,DIMENSION(1) :: DVISBM_CPL,DVISDF_CPL,RAIN_CPL - REAL (kind=KDBL) ,DIMENSION(1) :: NLWSFC_CPL,NSWSFC_CPL,NNIRBM_CPL,NNIRDF_CPL - REAL (kind=KDBL) ,DIMENSION(1) :: NVISBM_CPL,NVISDF_CPL - REAL (kind=KDBL) ,DIMENSION(1) :: XT, XS, XU, XV, XZ, ZM, XTTS - REAL (kind=KDBL) ,DIMENSION(1) :: XZTS, D_CONV, IFD, DT_COOL, QRAIN - REAL (kind=KDBL) ,DIMENSION(1) :: SMCWLT2, SMCREF2, GSOIL, GTMP2M, GUSTAR, GPBLH, WET1 - REAL (kind=KDBL) ,DIMENSION(1) :: GU10M, GV10M, GZORL, GORO, SR - REAL (kind=KDBL) ,DIMENSION(1) :: XMU_CC, DLW_CC, DSW_CC, SNW_CC, LPREC_CC, TREF - REAL (kind=KDBL) ,DIMENSION(1) :: DUSFCI_CPL,DVSFCI_CPL,DTSFCI_CPL,DQSFCI_CPL - REAL (kind=KDBL) ,DIMENSION(1) :: DLWSFCI_CPL,DSWSFCI_CPL,DNIRBMI_CPL,DNIRDFI_CPL - REAL (kind=KDBL) ,DIMENSION(1) :: DVISBMI_CPL,DVISDFI_CPL - REAL (kind=KDBL) ,DIMENSION(1) :: NLWSFCI_CPL,NSWSFCI_CPL,NNIRBMI_CPL,NNIRDFI_CPL - REAL (kind=KDBL) ,DIMENSION(1) :: NVISBMI_CPL,NVISDFI_CPL,T2MI_CPL,Q2MI_CPL - REAL (kind=KDBL) ,DIMENSION(1) :: U10MI_CPL,V10MI_CPL,TSEAI_CPL,PSURFI_CPL,ORO_CPL - REAL (kind=KDBL) ,DIMENSION(1) :: SLMSK_CPL - REAL (kind=KDBL) ,DIMENSION(1) :: Z_C, C_0, C_D, W_0, W_D, RQTK - REAL (kind=KDBL) ,DIMENSION(1) :: HLWD - REAL (kind=KDBL) ,DIMENSION(LM) :: DTDT - REAL (kind=KDBL) ,DIMENSION(1) :: TRIGGERPERTS - LOGICAL, PARAMETER :: LSIDEA = .FALSE. -! -#endif -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - btim0=timef() -! -!----------------------------------------------------------------------- -! - RC_RUN=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** Extract the Solver internal state. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="SOLVER_RUN: Extract Solver Internal State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGetInternalState(GRID_COMP & !<-- The Solver component - ,WRAP & - ,RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - INT_STATE=>wrap%INT_STATE -! -!----------------------------------------------------------------------- -!*** The total number of forecast tasks. -!----------------------------------------------------------------------- -! - INPES=int_state%INPES !<-- I fcst tasks - JNPES=int_state%JNPES !<-- J fcst tasks - NUM_PES=INPES*JNPES !<-- # of fcst tasks -! -!----------------------------------------------------------------------- -!*** Is this task on a domain boundary? -!----------------------------------------------------------------------- -! - S_BDY=int_state%S_BDY - N_BDY=int_state%N_BDY - W_BDY=int_state%W_BDY - E_BDY=int_state%E_BDY -! -!----------------------------------------------------------------------- -!*** Dereference fundamental variables for the dynamics routines. -!----------------------------------------------------------------------- -! - ITS=int_state%ITS - ITE=int_state%ITE - JTS=int_state%JTS - JTE=int_state%JTE - IMS=int_state%IMS - IME=int_state%IME - JMS=int_state%JMS - JME=int_state%JME - IDS=int_state%IDS - IDE=int_state%IDE - JDS=int_state%JDS - JDE=int_state%JDE -! - ITS_B1=int_state%ITS_B1 - ITE_B1=int_state%ITE_B1 - ITS_B2=int_state%ITS_B2 - ITE_B2=int_state%ITE_B2 - ITS_B1_H1=int_state%ITS_B1_H1 - ITE_B1_H1=int_state%ITE_B1_H1 - ITE_B1_H2=int_state%ITE_B1_H2 - ITS_H1=int_state%ITS_H1 - ITE_H1=int_state%ITE_H1 - ITS_H2=int_state%ITS_H2 - ITE_H2=int_state%ITE_H2 - JTS_B1=int_state%JTS_B1 - JTE_B1=int_state%JTE_B1 - JTS_B2=int_state%JTS_B2 - JTE_B2=int_state%JTE_B2 - JTS_B1_H1=int_state%JTS_B1_H1 - JTE_B1_H1=int_state%JTE_B1_H1 - JTE_B1_H2=int_state%JTE_B1_H2 - JTS_H1=int_state%JTS_H1 - JTE_H1=int_state%JTE_H1 - JTS_H2=int_state%JTS_H2 - JTE_H2=int_state%JTE_H2 -! - LM=int_state%LM -! - IHALO=int_state%IHALO - JHALO=int_state%JHALO -! - MYPE=int_state%MYPE !<-- The local task rank on this domain - MY_DOMAIN_ID=int_state%MY_DOMAIN_ID - MPI_COMM_COMP=int_state%MPI_COMM_COMP -! -!----------------------------------------------------------------------- -!*** Nested domains -!----------------------------------------------------------------------- -! - I_AM_A_NEST=int_state%I_AM_A_NEST -! -!----------------------------------------------------------------------- -!*** Dereference more variables for shorter names. -!----------------------------------------------------------------------- -! -! firstpass: IF(FIRST_PASS)THEN -! - DDMPV=int_state%DDMPV - DT=int_state%DT - DYH=int_state%DYH - DYV=int_state%DYV - EF4T=int_state%EF4T - GLOBAL=int_state%GLOBAL -! HYDRO=int_state%HYDRO - IDTADT=int_state%IDTADT - IF(GLOBAL) THEN - IDTADTQ=IDTADT !global - ELSE - IDTADTQ=1 !regional - ENDIF - IHRSTBC=int_state%IHRSTBC - KSE=int_state%NUM_TRACERS_MET - KSS=1 - LNSAD=int_state%LNSAD - LNSH=int_state%LNSH - LNSV=int_state%LNSV - LPT2=int_state%LPT2 - NBOCO=int_state%NBOCO - NSTEPS_PER_CHECK=int_state%NSTEPS_PER_CHECK - NSTEPS_PER_HOUR=int_state%NSTEPS_PER_HOUR - NSTEPS_PER_RESET=int_state%NSTEPS_PER_RESET - PDTOP=int_state%PDTOP - PT=int_state%PT - RDYH=int_state%RDYH - RDYV=int_state%RDYV - RUNBC=int_state%RUNBC - SECADV=int_state%SECADV - TBOCO=int_state%TBOCO - FILTER_METHOD=int_state%FILTER_METHOD - FILTER_METHOD_LAST=int_state%FILTER_METHOD_LAST -! - RIME_FACTOR_ADVECT=.FALSE. - RIME_FACTOR_INPUT=.FALSE. - IF (TRIM(int_state%MICROPHYSICS) == 'fer_hires' .AND. & - int_state%F_QG .AND. int_state%SPEC_ADV) THEN - RIME_FACTOR_ADVECT=.TRUE. - ENDIF -! - PARENT_CHILD_TIME_RATIO=int_state%PARENT_CHILD_TIME_RATIO -! - DO N=1,3 - IDATBC(N)=int_state%IDATBC(N) - ENDDO -! - CALL SET_DOMAIN_SPECS(int_state%ITS,int_state%ITE & - ,int_state%JTS,int_state%JTE & - ,int_state%IMS,int_state%IME & - ,int_state%JMS,int_state%JME & - ,int_state%IDS,int_state%IDE & - ,int_state%JDS,int_state%JDE & - ,int_state%IHALO,int_state%JHALO & - ,int_state%MY_DOMAIN_ID & - ,int_state%MYPE & - ,int_state%MY_NEB & - ,int_state%MPI_COMM_COMP & - ,int_state%NUM_PES & -! - ,LOCAL_ISTART_IN=int_state%LOCAL_ISTART & - ,LOCAL_IEND_IN=int_state%LOCAL_IEND & - ,LOCAL_JSTART_IN=int_state%LOCAL_JSTART & - ,LOCAL_JEND_IN=int_state%LOCAL_JEND & - ,ADV_STANDARD_IN=int_state%ADV_STANDARD & - ,ADV_UPSTREAM_IN=int_state%ADV_UPSTREAM & - ,S_BDY_IN=int_state%S_BDY & - ,N_BDY_IN=int_state%N_BDY & - ,W_BDY_IN=int_state%W_BDY & - ,E_BDY_IN=int_state%E_BDY & - ) -! -!----------------------------------------------------------------------- -!*** Extract the timestep count from the Clock. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Solver Run Gets Timestep from the ATM Clock" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock =CLOCK_ATM & !<-- The ESMF Clock - ,timeStep =DT_ESMF & !<-- Fundamental timestep (s) (ESMF) - ,currtime =CURRTIME & !<-- current time - ,advanceCount=NTIMESTEP_ESMF & !<-- The number of times the clock has been advanced - ,rc =RC) - -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeIntervalGet(timeinterval=DT_ESMF & !<-- the ESMF timestep - ,s =INTEGER_DT & !<-- the integer part of the timestep in seconds - ,sN =NUMERATOR_DT & !<-- the numerator of the fractional second - ,sD =IDENOMINATOR_DT & !<-- the denominator of the fractional second - ,rc =RC) -! - int_state%DT=REAL(INTEGER_DT)+REAL(NUMERATOR_DT) & !<-- Fundamental timestep (s) (REAL) - /REAL(IDENOMINATOR_DT) - DT=int_state%DT -! - CALL ESMF_AttributeGet(state=IMP_STATE & - ,name ='FUND_DT' & - ,value=FUND_DT & - ,rc =RC) -! - DTRATIO=ABS(DT/FUND_DT) -! - NTIMESTEP=NTIMESTEP_ESMF - int_state%NTSD=NTIMESTEP - -!---------------------- - if (int_state%RADAR_INIT==0) then - USE_RADAR=.false. - else - if(filter_method==0) then - USE_RADAR=.false. - else - USE_RADAR=.true. - end if - endif -!---------------------- -! write(6,*)'filter method::',NTIMESTEP,int_state%RADAR_INIT,FILTER_METHOD,FILTER_METHOD_LAST,USE_RADAR - - if (DT .lt. 0 .and. FILTER_METHOD .ge. 2 .and. & - (int(NTIMESTEP*DT) .le. int_state%DFIHR_BOCO/2.)) then - HYDRO=.true. - else - HYDRO=int_state%HYDRO - endif - - - -! - FIRST_PASS=int_state%FIRST_PASS -! - NSTEPS_PER_HOUR=NINT(3600./DT) -! - N_PRINT_STATS=NINT(3600./DT) !<-- Print layer statistics once per forecast hour -! -!----------------------------------------------------------------------- -!*** Extract the horizontal diffusion flag from the import state. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Solver Run Extracts Horizontal Diffusion Flag " -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & - ,name ='HDIFF' & - ,value=HDIFF_ON & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Extract the digital filter method from the import state. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! MESSAGE_CHECK="Solver Run Extracts Horizontal Diffusion Flag " -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Solver import state -! ,name ='Filter_Method' & !<-- Name of the attribute to extract -! ,value=int_state%FILTER_METHOD & !<-- The scalar being extracted from the import state -! ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! FILTER_METHOD=int_state%FILTER_METHOD -! FILTER_METHOD_LAST=int_state%FILTER_METHOD_LAST -! -!----------------------------------------------------------------------- -!rh_hold IF (USE_RADAR_FIRST == 1 .and. FIRST_PASS ) THEN -!rh_hold ALLOCATE(RH_HOLD(IMS:IME,JMS:JME,1:LM)) -!rh_hold IFLAG=1 ! <---- IFLAG=1 takes T,Q,P and returns RH_HOLD -!rh_hold CALL CALC_RH_RADAR_DFI(int_state%T,int_state%Q,int_state%PD & -!rh_hold ,int_state%PSGML1,int_state%SGML2 & -!rh_hold ,R_D,R_V,RH_HOLD & -!rh_hold ,IMS,IME,JMS,JME,LM & -!rh_hold ,IFLAG) -!rh_hold ENDIF - -! -! ENDIF firstpass -! -!----------------------------------------------------------------------- -!*** The following set of internal state arrays never changes unless -!*** the domain moves in which case they must be dereferenced again. -!----------------------------------------------------------------------- -! - MOVE_NOW=.FALSE. - IF(int_state%MY_DOMAIN_MOVES)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract the MOVE_NOW flag in SOLVER_RUN" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- Solver import state - ,name ='MOVE_NOW' & !<-- Name of the flag for current domain motion - ,value=MOVE_NOW & !<-- Did the nest move this timestep? - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF - -! -!----------------------------------------------------------------------- -!*** If this is a moving nest and it moved this timestep then we -!*** need to update the haloes of the geographic lat/lon and the -!*** HDAC variables because like all variables they are updated -!*** only in the integration region when a nest shifts. -!----------------------------------------------------------------------- -! - IF(MOVE_NOW)THEN -! - btim=timef() - CALL HALO_EXCH & - (int_state%GLAT,1 & - ,int_state%GLON,1 & - ,int_state%VLAT,1 & - ,int_state%VLAT,1 & - ,2,2) -! - CALL HALO_EXCH & - (int_state%HDACX,1 & - ,int_state%HDACY,1 & - ,int_state%HDACVX,1 & - ,int_state%HDACVY,1 & - ,2,2) - td%exch_dyn=td%exch_dyn+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Also the geography information for the gravity wave drag -!*** must be updated to account for the domain's new position. -! -!*** NOTE: Currently the gravity wave drag is turned off in -!*** moving nests. A quantity used by the parameterization -!*** is mountains' angle with respect to east. From the -!*** moving nest's perspective the mountains are moving -!*** and thus those angles would need to be updated. -!*** Such updating is not yet included. -!----------------------------------------------------------------------- -! - IF(int_state%GWDFLG)THEN -! - DTPHY=int_state%DT*int_state%NPHS -! - CALL GWD_init(DTPHY,int_state%RESTART & - ,int_state%CLEFFAMP,int_state%DPHD & - ,int_state%CLEFF & - ,int_state%TPH0D,int_state%TLM0D & - ,int_state%GLAT,int_state%GLON & - ,int_state%CROT,int_state%SROT,int_state%HANGL & - ,IDS,IDE,JDS,JDE & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE,LM) - ENDIF -! - IF(int_state%NTRACK>0 .AND. int_state%MYPE= 0) IFACT=1 - IF (INTEGER_DT < 0) IFACT=-1 -! - IF(FIRST_PASS)THEN -! - IF (FILTER_METHOD /= 0) THEN -! -!*** Save copies of the internal state variables scaled by -!*** DTRATIO below so we can restore them precisely after the filter -!*** (*_SV variables). Needed for bit-wise identical restarts -! - ALLOCATE(HDACX_SV(ITS:ITE,JTS:JTE),HDACY_SV(ITS:ITE,JTS:JTE), & - HDACVX_SV(ITS:ITE,JTS:JTE),HDACVY_SV(ITS:ITE,JTS:JTE)) - ALLOCATE(DDMPU_SV(JDS:JDE),FAD_SV(JDS:JDE),FAH_SV(JDS:JDE), & - FCP_SV(JDS:JDE)) - - DDMPV_SV=int_state%DDMPV - EF4T_SV=int_state%EF4T - END IF - - int_state%DDMPV=IFACT*DTRATIO*int_state%DDMPV - int_state%EF4T=IFACT*DTRATIO*int_state%EF4T -! - DO J=JDS,JDE - - IF (FILTER_METHOD /= 0) THEN - DDMPU_SV(J) = int_state%DDMPU(J) - FAD_SV(J) = int_state%FAD(J) - FAH_SV(J) = int_state%FAH(J) - FCP_SV(J) = int_state%FCP(J) - END IF - - int_state%DDMPU(J)=IFACT*int_state%DDMPU(J) - int_state%FAD(J)=IFACT*DTRATIO*int_state%FAD(J) - int_state%FAH(J)=IFACT*DTRATIO*int_state%FAH(J) - int_state%FCP(J)=IFACT*DTRATIO*int_state%FCP(J) - int_state%WPDAR(J)=IFACT*int_state%WPDAR(J) - ENDDO -! - DO J=JTS,JTE - DO I=ITS,ITE - - IF (FILTER_METHOD /= 0) THEN - HDACX_SV(I,J)=int_state%HDACX(I,J) - HDACY_SV(I,J)=int_state%HDACY(I,J) - HDACVX_SV(I,J)=int_state%HDACVX(I,J) - HDACVY_SV(I,J)=int_state%HDACVY(I,J) - END IF - - int_state%HDACX(I,J)=IFACT*DTRATIO*int_state%HDACX(I,J) - int_state%HDACY(I,J)=IFACT*DTRATIO*int_state%HDACY(I,J) - int_state%HDACVX(I,J)=IFACT*DTRATIO*int_state%HDACVX(I,J) - int_state%HDACVY(I,J)=IFACT*DTRATIO*int_state%HDACVY(I,J) - ENDDO - ENDDO - ENDIF -! - DDMPV=int_state%DDMPV - EF4T=int_state%EF4T -! - NBOCO=int(0.5+NBOCO/DTRATIO) -! IF (MYPE == 0) WRITE(0,*) 'NBOCO reset to : ', NBOCO -! -!----------------------------------------------------------------------- -!*** Now we need to do some things related to digital filtering -!*** that are only relevant after the first pass through the -!*** Run step. -!----------------------------------------------------------------------- -! - DT_TEST=INTEGER_DT - DT_TEST_RATIO=int_state%DT_TEST_RATIO -! -!----------------------------------------------------------------------- -! - not_firstpass: IF (.NOT. FIRST_PASS) THEN -! -!----------------------------------------------------------------------- -! - changedir: IF (int_state%DT_LAST /= DT_TEST & - .AND. & - ABS(int_state%DT_LAST) == ABS(DT_TEST) ) THEN -! -!----------------------------------------------------------------------- -! - IF(MYPE == 0)WRITE(0,*)' Change in integration direction...' & - ,' dt_last=',int_state%dt_last & - ,' dt_test=',dt_test -! -!----------------------------------------------------------------------- -!*** Setting previous time level variables (Adams-Bashforth scheme) -!*** to the current time level. Seems safer than potentially leaving them -!*** defined as values at a very different point in the time integration. -!----------------------------------------------------------------------- -! - int_state%FIRST_STEP=.TRUE. -! - int_state%TP=int_state%T - int_state%UP=int_state%U - int_state%VP=int_state%V -! - IFACT=-1 -! - int_state%DDMPV=IFACT*int_state%DDMPV - int_state%EF4T=IFACT*int_state%EF4T - DDMPV=int_state%DDMPV - EF4T=int_state%EF4T -! - DO J=JDS,JDE - int_state%DDMPU(J)=IFACT*int_state%DDMPU(J) - int_state%FAD(J)=IFACT*int_state%FAD(J) - int_state%FAH(J)=IFACT*int_state%FAH(J) - int_state%FCP(J)=IFACT*int_state%FCP(J) - int_state%WPDAR(J)=IFACT*int_state%WPDAR(J) - ENDDO -! - DO J=JTS,JTE - DO I=ITS,ITE - int_state%HDACX(I,J)=IFACT*int_state%HDACX(I,J) - int_state%HDACY(I,J)=IFACT*int_state%HDACY(I,J) - int_state%HDACVX(I,J)=IFACT*int_state%HDACVX(I,J) - int_state%HDACVY(I,J)=IFACT*int_state%HDACVY(I,J) - ENDDO - ENDDO -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Solver Run Gets HDIFF from Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE & !<-- The Solver import state - ,name ='HDIFF' & !<-- Name of the Attribute to extract - ,value=HDIFF_ON & !<-- Put the Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - btim=timef() - CALL HALO_EXCH & - (int_state%T,LM & - ,int_state%Q,LM & - ,int_state%CW,LM & - ,2,2) -!..What about other items in the TRACER array? -! - CALL HALO_EXCH & - (int_state%U,LM & - ,int_state%V,LM & - ,2,2) -! - CALL HALO_EXCH & - (int_state%PD,1 & - ,2,2) - td%exch_dyn=td%exch_dyn+(timef()-btim) -! - IF(.NOT.int_state%GLOBAL)THEN - CALL WRITE_BC(LM,LNSH,LNSV,NTIMESTEP,DT & - ,RUNBC & - ,TBOCO+int_state%DFIHR_BOCO/2. & - ,int_state%NVARS_BC_2D_H & - ,int_state%NVARS_BC_3D_H & - ,int_state%NVARS_BC_4D_H & - ,int_state%NVARS_BC_2D_V & - ,int_state%NVARS_BC_3D_V & - ,int_state%BND_VARS_H & - ,int_state%BND_VARS_V & - ,.TRUE.) !<-- Recompute tendencies at this stage? - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF changedir -! -!----------------------------------------------------------------------- -! - end_filt: IF (FILTER_METHOD /= FILTER_METHOD_LAST) THEN -! -!----------------------------------------------------------------------- -! - DTRATIO=ABS(FUND_DT/DT_TEST_RATIO) - IF(MYPE == 0) WRITE(0,*) ' RESTORING PRE-FILTER CONSTANTS with DTRATIO: ', DTRATIO -! -!----------------------------------------------------------------------- -!*** Setting previous time level variables (Adams-Bashforth scheme) -!*** to the current time level. Seems safer than potentially leaving them -!*** defined as values at a very different point in the time integration. -!----------------------------------------------------------------------- -! - int_state%TP=int_state%T - int_state%UP=int_state%U - int_state%VP=int_state%V -! - IFACT=1 -! - int_state%DDMPV=DDMPV_SV - int_state%EF4T=EF4T_SV - - DDMPV=int_state%DDMPV - EF4T=int_state%EF4T - - DDMPV=int_state%DDMPV - EF4T=int_state%EF4T - NBOCO=int(0.5+NBOCO/DTRATIO) -! -! IF (MYPE == 0) WRITE(0,*) 'NBOCO reset to : ', NBOCO -! - DO J=JDS,JDE - int_state%DDMPU(J)=DDMPU_SV(J) - int_state%FAD(J)=FAD_SV(J) - int_state%FAH(J)=FAH_SV(J) - int_state%FCP(J)=FCP_SV(J) - int_state%WPDAR(J)=IFACT*int_state%WPDAR(J) - ENDDO -! - DO J=JTS,JTE - DO I=ITS,ITE - int_state%HDACX(I,J)=HDACX_SV(I,J) - int_state%HDACY(I,J)=HDACY_SV(I,J) - int_state%HDACVX(I,J)=HDACVX_SV(I,J) - int_state%HDACVY(I,J)=HDACVY_SV(I,J) - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -! - DEALLOCATE(HDACX_SV,HDACY_SV,HDACVX_SV,HDACVY_SV) - DEALLOCATE(DDMPU_SV,FAD_SV,FAH_SV,FCP_SV) -! - int_state%FIRST_STEP=.TRUE. -! - ENDIF end_filt -! -!----------------------------------------------------------------------- -! - ENDIF not_firstpass -! -!----------------------------------------------------------------------- -! - IF(FIRST_PASS)THEN - int_state%FIRST_PASS=.FALSE. - FIRST_PASS=int_state%FIRST_PASS - ENDIF -! -!----------------------------------------------------------------------- -! - TD=>TIMERS(MY_DOMAIN_ID) !<-- Abbreviate the name of this domain's timers. -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** Begin the Solver calling sequence. -!*** Note that the first timestep begins differently -!*** than all subsequent timesteps. -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - firststep: IF(int_state%FIRST_STEP.AND. & !<-- The following block is used only for - .NOT.int_state%RESTART)THEN ! the first timestep and cold start -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! - IF(GLOBAL)THEN -! - btim=timef() - CALL SWAPHN & - (int_state%T,IMS,IME,JMS,JME,LM & - ,INPES) - td%swaphn_tim=td%swaphn_tim+(timef()-btim) -! - btim=timef() - CALL POLEHN & - (int_state%T & - ,IMS,IME,JMS,JME,LM & - ,INPES,JNPES) - td%polehn_tim=td%polehn_tim+(timef()-btim) -! - ENDIF -! - btim=timef() - CALL HALO_EXCH(int_state%T,LM & - ,2,2) - td%exch_dyn=td%exch_dyn+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** The pressure gradient routine. -!----------------------------------------------------------------------- -! - btim=timef() -! - CALL PGFORCE & - (int_state%FIRST_STEP,int_state%GLOBAL,int_state%RESTART & - ,LM,DT,NTIMESTEP & - ,RDYV,int_state%DSG2,int_state%PDSG1,int_state%RDXV & - ,int_state%WPDAR,int_state%FIS & - ,int_state%PD & - ,int_state%T,int_state%Q,int_state%CW & ! And how about other TRACER elements? - ,int_state%PINT & - ,int_state%RTOP & - ,int_state%DIV & - ,int_state%PCNE,int_state%PCNW & - ,int_state%PCX,int_state%PCY & - ,int_state%TCU,int_state%TCV ) -! - td%pgforce_tim=td%pgforce_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -! - btim=timef() - CALL HALO_EXCH(int_state%DIV,LM & - ,2,2) - CALL HALO_EXCH(int_state%U,LM & - ,int_state%V,LM & - ,2,2) - td%exch_dyn=td%exch_dyn+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Divergence and horizontal pressure advection in thermo eqn -!----------------------------------------------------------------------- -! - btim=timef() -! - CALL DHT & - (GLOBAL,LM,DYV,int_state%DSG2,int_state%PDSG1,int_state%DXV & - ,int_state%FCP,int_state%FDIV & - ,int_state%PD,int_state%PDO & - ,int_state%U,int_state%V & - ,int_state%OMGALF & - ,int_state%PCNE,int_state%PCNW,int_state%PCX,int_state%PCY & - ,int_state%PFNE,int_state%PFNW,int_state%PFX,int_state%PFY & - ,int_state%DIV,int_state%TDIV) -! - td%dht_tim=td%dht_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Filtering and boundary conditions for the global forecast. -!----------------------------------------------------------------------- -! - IF(GLOBAL)THEN -! - btim=timef() - CALL FFTFHN & - (LM & - ,int_state%KHFILT & - ,int_state%HFILT & - ,int_state%DIV & - ,int_state%WFFTRH,int_state%NFFTRH & - ,NUM_PES,MYPE,MPI_COMM_COMP) - td%fftfhn_tim=td%fftfhn_tim+(timef()-btim) -! - btim=timef() - CALL SWAPHN & - (int_state%DIV & - ,IMS,IME,JMS,JME,LM & - ,INPES) -! - CALL SWAPHN & - (int_state%OMGALF & - ,IMS,IME,JMS,JME,LM & - ,INPES) - td%swaphn_tim=td%swaphn_tim+(timef()-btim) -! - btim=timef() - CALL POLEHN & - (int_state%DIV & - ,IMS,IME,JMS,JME,LM & - ,INPES,JNPES) -! - CALL POLEHN & - (int_state%OMGALF & - ,IMS,IME,JMS,JME,LM & - ,INPES,JNPES) - td%polehn_tim=td%polehn_tim+(timef()-btim) -! - btim=timef() - CALL SWAPWN & - (int_state%U & - ,IMS,IME,JMS,JME,LM & - ,INPES) -! - CALL SWAPWN & - (int_state%V & - ,IMS,IME,JMS,JME,LM & - ,INPES) - td%swapwn_tim=td%swapwn_tim+(timef()-btim) -! - btim=timef() - CALL POLEWN & - (int_state%U,int_state%V & - ,IMS,IME,JMS,JME,LM & - ,INPES,JNPES) - td%polewn_tim=td%polewn_tim+(timef()-btim) -! - ENDIF -! -!----------------------------------------------------------------------- -! - btim=timef() - CALL HALO_EXCH & - (int_state%T,LM & - ,int_state%U,LM & - ,int_state%V,LM & - ,2,2) - td%exch_dyn=td%exch_dyn+(timef()-btim) -! -!----------------------------------------------------------------------- -! - ENDIF firststep -! -!----------------------------------------------------------------------- -! - not_firststep: IF(.NOT.int_state%FIRST_STEP & !<-- The following block is for all timesteps after - .OR.int_state%RESTART)THEN ! the first or all steps in restart case -! - -!rh_hold IF(FILTER_METHOD==0.and.USE_RADAR_FIRST==1.and.USE_RADAR==0)THEN -!rh_hold IFLAG=-1 ! <---- IFLAG=-1 takes RH_HOLD, and filtered -!rh_hold ! T,P, to restore Q to be consistent with -!rh_hold ! prefiltered humidity level -!rh_hold -!rh_hold!!! NOTE: restoring down here means they are restored AFTER the 00 h -!rh_hold!!! output is written. Any way to restore them before the output -!rh_hold!!! is written? -!rh_hold -!rh_hold CALL CALC_RH_RADAR_DFI(int_state%T,int_state%Q,int_state%PD & -!rh_hold ,int_state%PSGML1,int_state%SGML2 & -!rh_hold ,R_D,R_V,RH_HOLD & -!rh_hold ,IMS,IME,JMS,JME,LM & -!rh_hold ,IFLAG) -!rh_hold -!rh_hold USE_RADAR_FIRST=0 -!rh_hold -!rh_hold ENDIF - -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Horizontal diffusion (internal halo exchange for 4th order) -!----------------------------------------------------------------------- -! - btim=timef() -! - IF(HDIFF_ON>0)THEN - CALL HDIFF & - (GLOBAL,HYDRO & - ,INPES,JNPES,LM,LPT2 & - ,DYH,RDYH & - ,int_state%EPSQ2 & - ,int_state%DXV,int_state%RARE,int_state%RDXH & - ,int_state%SICE,int_state%SM & - ,int_state%HDACX,int_state%HDACY & - ,int_state%HDACVX,int_state%HDACVY & - ,int_state%W,int_state%Z & - ,int_state%CW,int_state%Q,int_state%Q2 & ! And how about other TRACER elements? - ,int_state%T,int_state%U,int_state%V,int_state%DEF) - ENDIF -! - td%hdiff_tim=td%hdiff_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Filtering and boundary conditions for the global forecast. -!----------------------------------------------------------------------- -! - IF(GLOBAL)THEN -! - btim=timef() -! - CALL POAVHN & - (IMS,IME,JMS,JME,LM & - ,int_state%T & - ,INPES,JNPES & - ,int_state%USE_ALLREDUCE) -! - CALL POAVHN & - (IMS,IME,JMS,JME,LM & - ,int_state%Q & - ,INPES,JNPES & - ,int_state%USE_ALLREDUCE) -! - CALL POAVHN & - (IMS,IME,JMS,JME,LM & - ,int_state%CW & - ,INPES,JNPES & - ,int_state%USE_ALLREDUCE) -! - CALL POAVHN & - (IMS,IME,JMS,JME,LM & - ,int_state%Q2 & - ,INPES,JNPES & - ,int_state%USE_ALLREDUCE) -! - td%poavhn_tim=td%poavhn_tim+(timef()-btim) -! - btim=timef() - CALL SWAPHN(int_state%T,IMS,IME,JMS,JME,LM,INPES) - CALL SWAPHN(int_state%Q,IMS,IME,JMS,JME,LM,INPES) - CALL SWAPHN(int_state%CW,IMS,IME,JMS,JME,LM,INPES) - CALL SWAPHN(int_state%Q2,IMS,IME,JMS,JME,LM,INPES) - td%swaphn_tim=td%swaphn_tim+(timef()-btim) -! - btim=timef() - CALL POLEHN(int_state%T,IMS,IME,JMS,JME,LM,INPES,JNPES) - CALL POLEHN(int_state%Q,IMS,IME,JMS,JME,LM,INPES,JNPES) - CALL POLEHN(int_state%CW,IMS,IME,JMS,JME,LM,INPES,JNPES) - CALL POLEHN(int_state%Q2,IMS,IME,JMS,JME,LM,INPES,JNPES) - td%polehn_tim=td%polehn_tim+(timef()-btim) -! - btim=timef() - CALL SWAPWN(int_state%U,IMS,IME,JMS,JME,LM,INPES) - CALL SWAPWN(int_state%V,IMS,IME,JMS,JME,LM,INPES) - td%swapwn_tim=td%swapwn_tim+(timef()-btim) -! - btim=timef() - CALL POLEWN(int_state%U,int_state%V & - ,IMS,IME,JMS,JME,LM,INPES,JNPES) - td%polewn_tim=td%polewn_tim+(timef()-btim) -! - ENDIF -! -!----------------------------------------------------------------------- -! - btim=timef() - CALL HALO_EXCH(int_state%T,LM & - ,int_state%Q,LM & - ,int_state%CW,LM & - ,int_state%Q2,LM & ! And how about other TRACER elements? - ,2,2) - CALL HALO_EXCH(int_state%U,LM & - ,int_state%V,LM & - ,1,1) - td%exch_dyn=td%exch_dyn+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Regional domains that have no children or are uppermost parents -!*** need to set a digital filter flag and exchange haloes. -!----------------------------------------------------------------------- -! - IF(.NOT.I_AM_A_NEST.AND..NOT.GLOBAL)THEN !<-- For single domains or uppermost parents -! - READBC=(NTIMESTEP==1.OR.MOD(NTIMESTEP,NBOCO)==0) -! - bc_check: IF(READBC)THEN !<-- Is it time to read BCs? -! - IF(MYPE==0)THEN - WRITE_BC_FLAG=0 -! - IF(FILTER_METHOD>0)THEN - IF(NTIMESTEP<=1.AND.int_state%BDY_WAS_READ)THEN - WRITE_BC_FLAG=1 - ELSE - WRITE_BC_FLAG=0 - ENDIF - ENDIF -! - ENDIF -! - CALL MPI_BCAST(WRITE_BC_FLAG,1,MPI_INTEGER,0 & - ,MPI_COMM_COMP,IRTN) -! - IF(WRITE_BC_FLAG==1)THEN - CALL HALO_EXCH & - (int_state%T,LM & - ,int_state%Q,LM & - ,int_state%CW,LM & ! And how about other TRACER elements? - ,2,2) -! - CALL HALO_EXCH & - (int_state%U,LM & - ,int_state%V,LM & - ,2,2) -! - CALL HALO_EXCH & - (int_state%PD,1 & - ,2,2) -! - ENDIF -! - ENDIF bc_check -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Update the boundary mass points. -! -!*** For non-nested regional domains, read new boundary tendencies -!*** at the appropriate times. -! -!*** If this is a nested domain then unload the new boundary data -!*** from the Solver import state and compute the time tendencies. -!----------------------------------------------------------------------- -! - bc_update: IF(.NOT.GLOBAL)THEN -! -!----------------------------------------------------------------------- -!*** The following block is for digital filtering. -!----------------------------------------------------------------------- -! - IF(I_AM_A_NEST)THEN -! - IF(MYPE==0)THEN - WRITE_BC_FLAG_NEST=0 -! - IF(FILTER_METHOD>0)THEN - IF (S_BDY.AND.W_BDY & - .AND. & - NTIMESTEP <= 1 & - .AND. & - int_state%BDY_WAS_READ) THEN -! - WRITE_BC_FLAG_NEST=1 - ENDIF - ENDIF -! - ENDIF -! - CALL MPI_BCAST(WRITE_BC_FLAG_NEST,1,MPI_INTEGER & - ,0,MPI_COMM_COMP,IRTN) -! - IF (WRITE_BC_FLAG_NEST == 1) THEN - CALL HALO_EXCH & - (int_state%T,LM & - ,int_state%Q,LM & - ,int_state%CW,LM & ! And how about other TRACER elements? - ,2,2) -! - CALL HALO_EXCH & - (int_state%U,LM & - ,int_state%V,LM & - ,2,2) -! - CALL HALO_EXCH & - (int_state%PD,1 & - ,2,2) - ENDIF - ENDIF -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set SIMULATION_START_TIME for Filter in Solver Run" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeSet(time=SIMULATION_START_TIME & - ,yy =START_YEAR & - ,mm =START_MONTH & - ,dd =START_DAY & - ,h =START_HOUR & - ,calkindflag=ESMF_CALKIND_GREGORIAN & - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF (FILTER_METHOD == 1 .and. NTIMESTEP == 0) THEN -! - REST_OFFSET=CURRTIME-SIMULATION_START_TIME -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Time Offset for Filter in Solver Run" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeIntervalGet(timeinterval=REST_OFFSET & - ,s =JDAT(7) & - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - RESTVAL=JDAT(7) - IF (MYPE == 0) WRITE(0,*) 'set RESTVAL to: ', RESTVAL -! - ENDIF -! -!----------------------------------------------------------------------- -! - boundary_tendencies: IF(S_BDY.OR.N_BDY.OR.W_BDY.OR.E_BDY)THEN -! -!----------------------------------------------------------------------- -!*** Nests update boundary tendencies based on data from parent. -!----------------------------------------------------------------------- -! - nest_or_parent: IF(I_AM_A_NEST)THEN -! -!----------------------------------------------------------------------- -!*** The following block is for digital filtering. -!----------------------------------------------------------------------- -! - IF(NTIMESTEP<=1.AND.WRITE_BC_FLAG_NEST==1)THEN -! - TBOCO=PARENT_CHILD_TIME_RATIO*DT - CALL WRITE_BC(LM,LNSH,LNSV,NTIMESTEP,DT & - ,RUNBC,TBOCO & - ,int_state%NVARS_BC_2D_H & - ,int_state%NVARS_BC_3D_H & - ,int_state%NVARS_BC_4D_H & - ,int_state%NVARS_BC_2D_V & - ,int_state%NVARS_BC_3D_V & - ,int_state%BND_VARS_H & - ,int_state%BND_VARS_V & - ,.FALSE.) !<-- Are tendencies recomputed? -! - ENDIF -! -!----------------------------------------------------------------------- -! - COMPUTE_BC=(NTIMESTEP==1.OR. & - MOD(NTIMESTEP,PARENT_CHILD_TIME_RATIO)==0) -! - IF(COMPUTE_BC)THEN -! - CALL UPDATE_BC_TENDS(IMP_STATE & - ,LM,LNSH,LNSV & - ,PARENT_CHILD_TIME_RATIO,DT & - ,S_BDY,N_BDY,W_BDY,E_BDY & - ,int_state%NLEV_H & - ,int_state%NLEV_V & - ,int_state%NVARS_BC_2D_H & - ,int_state%NVARS_BC_3D_H & - ,int_state%NVARS_BC_4D_H & - ,int_state%NVARS_BC_2D_V & - ,int_state%NVARS_BC_3D_V & - ,int_state%BND_VARS_H & - ,int_state%BND_VARS_V & - ,int_state%ITS,int_state%ITE & - ,int_state%JTS,int_state%JTE & - ,int_state%IMS,int_state%IME & - ,int_state%JMS,int_state%JME & - ,int_state%IDS,int_state%IDE & - ,int_state%JDS,int_state%JDE & - ) -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Single/uppermost domain reads its own boundary input data -!----------------------------------------------------------------------- -! - ELSE nest_or_parent -! - CALL ESMF_TimeSet(time=SIMULATION_START_TIME & - ,yy =START_YEAR & - ,mm =START_MONTH & - ,dd =START_DAY & - ,h =START_HOUR) -! - IF (FILTER_METHOD > 0 .and. NTIMESTEP == 0) THEN - REST_OFFSET=CURRTIME-SIMULATION_START_TIME - CALL ESMF_TimeIntervalGet(timeinterval=REST_OFFSET, s=JDAT(7)) - NTIMESTEP_BC=(NTIMESTEP)+NINT(JDAT(7)/abs(DT)) - ELSE - NTIMESTEP_BC=NTIMESTEP - ENDIF -! -!----------------------------------------------------------------------- -!*** Set logical flag to read the BCs -!----------------------------------------------------------------------- -! - READBC=( (NTIMESTEP==0 .AND. MOD(NTIMESTEP_BC,NBOCO)==0) & !<-- Filter related? -! - .OR. & -! - NTIMESTEP_BC==1 & !<-- First timestep -! - .OR. & -! - ((MOD(NTIMESTEP_BC,NBOCO)==0) .AND. FILTER_METHOD==0) ) !<-- Non-filter, NBOCO coincident time -! -!----------------------------------------------------------------------- -! - bc_read: IF(READBC)THEN -! - bc_flag: IF(WRITE_BC_FLAG==0)THEN -! - CALL READ_BC(LM,LNSH,LNSV,NTIMESTEP_BC,DT & - ,RUNBC,IDATBC,IHRSTBC,TBOCO & -! - ,int_state%NVARS_BC_2D_H & - ,int_state%NVARS_BC_3D_H & - ,int_state%NVARS_BC_4D_H & - ,int_state%NVARS_BC_2D_V & - ,int_state%NVARS_BC_3D_V & -! - ,int_state%BND_VARS_H & - ,int_state%BND_VARS_V & - ,int_state%N_BC_3D_H & - ) -! - ELSE -! - IF (NTIMESTEP==0) THEN - CALL WRITE_BC(LM,LNSH,LNSV,NTIMESTEP,DT & - ,RUNBC,TBOCO & - ,int_state%NVARS_BC_2D_H & - ,int_state%NVARS_BC_3D_H & - ,int_state%NVARS_BC_4D_H & - ,int_state%NVARS_BC_2D_V & - ,int_state%NVARS_BC_3D_V & - ,int_state%BND_VARS_H & - ,int_state%BND_VARS_V & - ,.TRUE.) !<-- Are tendencies recomputed? - ENDIF -! - ENDIF bc_flag -! - ENDIF bc_read -! - ENDIF nest_or_parent -! -!----------------------------------------------------------------------- -! - ENDIF boundary_tendencies -! -!----------------------------------------------------------------------- -! - IF(.NOT.int_state%BDY_WAS_READ) THEN - int_state%BDY_WAS_READ=.TRUE. - ENDIF -! -!----------------------------------------------------------------------- -! - btim=timef() -! - CALL BOCOH & - (LM,LNSH,DT,PT & - ,int_state%PD,int_state%DSG2,int_state%PDSG1 & - ,int_state%NVARS_BC_2D_H & - ,int_state%NVARS_BC_3D_H & - ,int_state%NVARS_BC_4D_H & - ,int_state%LBND_4D & - ,int_state%UBND_4D & - ,int_state%BND_VARS_H & - ,int_state%PINT) -! - td%bocoh_tim=td%bocoh_tim+(timef()-btim) -! - ENDIF bc_update -! -!----------------------------------------------------------------------- -!*** The pressure gradient routine. -!----------------------------------------------------------------------- -! - btim=timef() -! - CALL PGFORCE & - (int_state%FIRST_STEP,int_state%GLOBAL,int_state%RESTART & - ,LM,DT,NTIMESTEP & - ,RDYV,int_state%DSG2,int_state%PDSG1,int_state%RDXV & - ,int_state%WPDAR,int_state%FIS & - ,int_state%PD & - ,int_state%T,int_state%Q,int_state%CW & ! And how about other TRACER elements? - ,int_state%PINT & - ,int_state%RTOP & - ,int_state%DIV & - ,int_state%PCNE,int_state%PCNW & - ,int_state%PCX,int_state%PCY & - ,int_state%TCU,int_state%TCV ) -! - td%pgforce_tim=td%pgforce_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Filtering and boundary conditions for the global forecast. -!----------------------------------------------------------------------- -! - IF(GLOBAL)THEN -! - btim=timef() - CALL FFTFUVN & - (LM & - ,int_state%KVFILT,int_state%VFILT & - ,int_state%TCU,int_state%TCV & - ,int_state%WFFTRW,int_state%NFFTRW & - ,NUM_PES,MYPE,MPI_COMM_COMP) - td%fftfwn_tim=td%fftfwn_tim+(timef()-btim) -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Update the wind field. -!----------------------------------------------------------------------- -! - btim=timef() - CALL UPDATEUV & - (LM & - ,int_state%U,int_state%V & - ,int_state%TCU,int_state%TCV ) -! - td%updateuv_tim=td%updateuv_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Filtering and boundary conditions for the global forecast. -!----------------------------------------------------------------------- -! - IF(GLOBAL)THEN -! - btim=timef() - CALL SWAPWN(int_state%U,IMS,IME,JMS,JME,LM,INPES) - CALL SWAPWN(int_state%V,IMS,IME,JMS,JME,LM,INPES) - td%swapwn_tim=td%swapwn_tim+(timef()-btim) -! - btim=timef() - CALL POLEWN(int_state%U,int_state%V & - ,IMS,IME,JMS,JME,LM,INPES,JNPES) - td%polewn_tim=td%polewn_tim+(timef()-btim) -! - ENDIF -! -!----------------------------------------------------------------------- -! - btim=timef() - CALL HALO_EXCH(int_state%DIV,LM & - ,2,2) - CALL HALO_EXCH(int_state%U,LM & - ,int_state%V,LM & - ,2,2) - td%exch_dyn=td%exch_dyn+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Update the boundary velocity points for the regional forecast. -!----------------------------------------------------------------------- -! - IF(.NOT.GLOBAL)THEN -! - btim=timef() - CALL BOCOV & - (LM,LNSV,DT & - ,int_state%NVARS_BC_2D_V & - ,int_state%NVARS_BC_3D_V & - ,int_state%BND_VARS_V ) - td%bocov_tim=td%bocov_tim+(timef()-btim) -! - ENDIF -! -!----------------------------------------------------------------------- -!*** The boundary winds have just been updated. In order to replicate -!*** the integration of a restarted run compared to its free-forecast -!*** counterpart then we must save the wind data in the boundary -!*** arrays for the restart files at this place in the runstream. -!----------------------------------------------------------------------- -! - IF(QUILTING)THEN - IF(MOD(NTIMESTEP+1,int_state%NSTEPS_BC_RESTART)==0)THEN !<-- Look ahead to the end of this timestep - CALL SAVE_BC_DATA & - (LM,LNSH,LNSV & - ,int_state%NVARS_BC_2D_H & - ,int_state%NVARS_BC_3D_H & - ,int_state%NVARS_BC_4D_H & - ,int_state%NVARS_BC_2D_V & - ,int_state%NVARS_BC_3D_V & - ,int_state%BND_VARS_H & - ,int_state%BND_VARS_V & - ,int_state%NUM_WORDS_BC_SOUTH,int_state%RST_BC_DATA_SOUTH & - ,int_state%NUM_WORDS_BC_NORTH,int_state%RST_BC_DATA_NORTH & - ,int_state%NUM_WORDS_BC_WEST ,int_state%RST_BC_DATA_WEST & - ,int_state%NUM_WORDS_BC_EAST ,int_state%RST_BC_DATA_EAST & - ,EXP_STATE & - ,int_state%ITS,int_state%ITE,int_state%JTS,int_state%JTE & - ,int_state%IMS,int_state%IME,int_state%JMS,int_state%JME & - ,int_state%IDS,int_state%IDE,int_state%JDS,int_state%JDE & - ) -! - ENDIF - ENDIF -! -!----------------------------------------------------------------------- -!*** Divergence and horizontal pressure advection in thermo eqn -!----------------------------------------------------------------------- -! - btim=timef() -! - CALL DHT & - (GLOBAL,LM,DYV,int_state%DSG2,int_state%PDSG1,int_state%DXV & - ,int_state%FCP,int_state%FDIV & - ,int_state%PD,int_state%PDO & - ,int_state%U,int_state%V & - ,int_state%OMGALF & - ,int_state%PCNE,int_state%PCNW,int_state%PCX,int_state%PCY & - ,int_state%PFNE,int_state%PFNW,int_state%PFX,int_state%PFY & - ,int_state%DIV,int_state%TDIV) -! - td%dht_tim=td%dht_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Filtering and boundary conditions for the global forecast. -!----------------------------------------------------------------------- -! - IF(GLOBAL)THEN -! - btim=timef() - CALL FFTFHN & - (LM & - ,int_state%KHFILT & - ,int_state%HFILT & - ,int_state%DIV & - ,int_state%WFFTRH,int_state%NFFTRH & - ,NUM_PES,MYPE,MPI_COMM_COMP) - td%fftfhn_tim=td%fftfhn_tim+(timef()-btim) -! - btim=timef() - CALL SWAPHN & - (int_state%DIV & - ,IMS,IME,JMS,JME,LM & - ,INPES) -! - CALL SWAPHN & - (int_state%OMGALF & - ,IMS,IME,JMS,JME,LM & - ,INPES) - td%swaphn_tim=td%swaphn_tim+(timef()-btim) -! - btim=timef() - CALL POLEHN & - (int_state%DIV & - ,IMS,IME,JMS,JME,LM & - ,INPES,JNPES) -! - CALL POLEHN & - (int_state%OMGALF & - ,IMS,IME,JMS,JME,LM & - ,INPES,JNPES) - td%polehn_tim=td%polehn_tim+(timef()-btim) -! - ENDIF -! -!----------------------------------------------------------------------- -! - btim=timef() - CALL HALO_EXCH(int_state%DIV,LM & - ,int_state%OMGALF,LM & - ,2,2) - td%exch_dyn=td%exch_dyn+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Divergence damping -!----------------------------------------------------------------------- -! - btim=timef() -! - IF(HDIFF_ON>0)THEN - CALL DDAMP & - (LM & - ,DDMPV,PDTOP & - ,int_state%DSG2,int_state%PDSG1 & - ,int_state%SG1,int_state%SG2 & - ,int_state%DDMPU & - ,int_state%FREERUN & - ,int_state%PD,int_state%PDO & - ,int_state%U,int_state%V & - ,int_state%DIV) - ENDIF -! - td%ddamp_tim=td%ddamp_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Filtering and boundary conditions for the global forecast. -!----------------------------------------------------------------------- -! - IF(GLOBAL)THEN -! - btim=timef() - CALL SWAPWN & - (int_state%U & - ,IMS,IME,JMS,JME,LM & - ,INPES) -! - CALL SWAPWN & - (int_state%V & - ,IMS,IME,JMS,JME,LM & - ,INPES) - td%swapwn_tim=td%swapwn_tim+(timef()-btim) -! - btim=timef() - CALL POLEWN & - (int_state%U,int_state%V & - ,IMS,IME,JMS,JME,LM & - ,INPES,JNPES) - td%polewn_tim=td%polewn_tim+(timef()-btim) -! - ENDIF -! -!----------------------------------------------------------------------- -! - btim=timef() - CALL HALO_EXCH(int_state%U,int_state%LM & - ,int_state%V,int_state%LM & - ,2,2) - td%exch_dyn=td%exch_dyn+(timef()-btim) -! -!----------------------------------------------------------------------- -! - ENDIF not_firststep -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** The remainder of the Solver integration call sequence -!*** is the same for all timesteps. -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - int_state%FIRST_STEP=.FALSE. -! -!----------------------------------------------------------------------- -!*** Update the surface pressure. -!----------------------------------------------------------------------- -! - btim=timef() -! - CALL PDTSDT & - (LM,DT,int_state%SG2 & - ,int_state%PD & - ,int_state%PDO,int_state%PSDT & - ,int_state%PSGDT & -! -!*** Temporary argument -! - ,int_state%DIV,int_state%TDIV) -! - td%pdtsdt_tim=td%pdtsdt_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Filtering and boundary conditions -!----------------------------------------------------------------------- -! - IF(GLOBAL)THEN - btim=timef() - CALL SWAPHN(int_state%PD,IMS,IME,JMS,JME,1,INPES) - CALL SWAPHN(int_state%PSDT,IMS,IME,JMS,JME,1,INPES) - td%swaphn_tim=td%swaphn_tim+(timef()-btim) -! - btim=timef() - CALL POLEHN(int_state%PD,IMS,IME,JMS,JME,1,INPES,JNPES) - CALL POLEHN(int_state%PSDT,IMS,IME,JMS,JME,1,INPES,JNPES) - td%polehn_tim=td%polehn_tim+(timef()-btim) -! - btim=timef() - CALL SWAPHN(int_state%PSGDT,IMS,IME,JMS,JME,LM-1,INPES) - td%swaphn_tim=td%swaphn_tim+(timef()-btim) -! - btim=timef() - CALL POLEHN(int_state%PSGDT,IMS,IME,JMS,JME,LM-1,INPES,JNPES) - td%polehn_tim=td%polehn_tim+(timef()-btim) - ENDIF -! -!----------------------------------------------------------------------- -! - btim=timef() - CALL HALO_EXCH(int_state%PD,1 & - ,int_state%PSDT,1 & - ,int_state%PSGDT,LM-1 & - ,2,2) - td%exch_dyn=td%exch_dyn+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Advection of T, U, and V -!----------------------------------------------------------------------- -! - btim=timef() -! - CALL ADV1 & - (GLOBAL,SECADV & - ,LM,LNSAD,INPES,JNPES & - ,DT,DYV,RDYH,RDYV & - ,int_state%DSG2,int_state%PDSG1 & - ,int_state%CURV,int_state%DXV,int_state%FAD,int_state%FAH & - ,int_state%RDXH,int_state%RDXV,int_state%F & - ,int_state%PD,int_state%PDO & - ,int_state%OMGALF,int_state%PSGDT & - ,int_state%T,int_state%U,int_state%V & - ,int_state%TP,int_state%UP,int_state%VP & -! -!*** Temporary arguments -! - ,int_state%PFNE,int_state%PFNW & - ,int_state%PFX,int_state%PFY & - ,int_state%TCT,int_state%TCU,int_state%TCV) -! - td%adv1_tim=td%adv1_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Advect specific humidity IDTADTQ time steps -!----------------------------------------------------------------------- -! -q_tracer: IF(MOD(ABS(NTIMESTEP),IDTADTQ)==0)THEN - KSS=int_state%INDX_Q - KSE1=KSS - ! - btim=timef() - CALL ADV2 & - (GLOBAL & - ,IDTADTQ,KSS,KSE1,LM,LNSAD & - ,DT,RDYH & - ,int_state%DSG2,int_state%PDSG1 & - ,int_state%EPSQ2 & - ,int_state%FAH,int_state%RDXH & - ,int_state%PD,int_state%PDO & - ,int_state%PSGDT & - ,int_state%UP,int_state%VP & - ,int_state%INDX_Q2 & - ,int_state%TRACERS & - ,int_state%TRACERS_PREV & -! -!*** Temporary arguments -! - ,int_state%PFNE,int_state%PFNW & - ,int_state%PFX,int_state%PFY & - ,int_state%TRACERS_SQRT & - ,int_state%TRACERS_TEND) - td%adv2_tim=td%adv2_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Filtering and boundary conditions for global forecasts of specific humidity -!----------------------------------------------------------------------- -! - IF(GLOBAL)THEN - btim=timef() - DO KS=KSS,KSE1 - CALL FFTFHN & - (LM & - ,int_state%KHFILT & - ,int_state%HFILT & - ,int_state%TRACERS_TEND(IMS:IME,JMS:JME,1:LM,KS) & - ,int_state%WFFTRH,int_state%NFFTRH & - ,NUM_PES,MYPE,MPI_COMM_COMP) - ENDDO - td%fftfhn_tim=td%fftfhn_tim+(timef()-btim) - ENDIF -! -!----------------------------------------------------------------------- -!*** Tracer monotonization for specific humidity -!----------------------------------------------------------------------- -! - btim=timef() - CALL MONO & - (IDTADTQ,KSS,KSE1,LM & - ,int_state%DSG2,int_state%PDSG1 & - ,int_state%EPSQ2 & - ,int_state%DARE & - ,int_state%PD & - ,int_state%INDX_Q2 & - ,int_state%TRACERS & - ,INPES,JNPES & - ,int_state%USE_ALLREDUCE & -! -!*** Temporary arguments -! - ,int_state%TRACERS_SQRT & - ,int_state%TRACERS_TEND) - td%mono_tim=td%mono_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Update specific humidity -!----------------------------------------------------------------------- -! - btim=timef() - CALL UPDATES & - (LM,int_state%NUM_TRACERS_TOTAL,KSS,KSE1 & - ,int_state%TRACERS,int_state%TRACERS_TEND) - td%updates_tim=td%updates_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -! - IF(GLOBAL)THEN - btim=timef() - CALL SWAPHN(int_state%Q,IMS,IME,JMS,JME,LM,INPES) - td%swaphn_tim=td%swaphn_tim+(timef()-btim) - btim=timef() - CALL POLEHN(int_state%Q,IMS,IME,JMS,JME,LM,INPES,JNPES) - td%polehn_tim=td%polehn_tim+(timef()-btim) - ENDIF -! - btim=timef() - CALL HALO_EXCH(int_state%Q,LM,2,2) - td%exch_dyn=td%exch_dyn+(timef()-btim) - ENDIF q_tracer -! -!----------------------------------------------------------------------- -!*** Advection of tracers *other* than specific humidity -!----------------------------------------------------------------------- -! -not_q_tracers: IF(MOD(ABS(NTIMESTEP),IDTADT)==0)THEN -! -!----------------------------------------------------------------------- -! -!-- Water vapor *mixing ratio* is not considered below, it will be -! calculated from specific humidity before entering the physics block -! - IF(int_state%SPEC_ADV)THEN -! -!-- Separate species advection (SPEC_ADV=T): advect Q2 (TKE) and -! individual *condensate* species (QC,QI,QR,QS,QG,etc) -! -!-- At the initial time step (NTIMESTEP=0), subroutine UPDATE_WATER has not -! been called yet, so the initial individual hydrometeor species (QC,QI,etc.) -! have not been calculated from the int_state%CW/F_ice/F_rain arrays when -! initialized from NPS-generated input files. In the trunk code, the total -! condensate is advected along with the individual species, so this leads to -! an initial discrepancy in the values for int_state%CW, which are passed in -! as input to the radiation code. -! -! IF(NTIMESTEP<=0) THEN -! KSS=int_state%INDX_CW -! ELSE -! KSS=int_state%INDX_Q2 -! ENDIF - KSS=int_state%INDX_CW - KSE1=int_state%NUM_TRACERS_TOTAL - IF (RIME_FACTOR_ADVECT) THEN - btim=timef() -!----------- QG(:,:,:)=F_RIMEF(:,:,:)*QS(:,:,:) for advection - RIME_FACTOR_INPUT=.TRUE. - CALL RIME_FACTOR_UPDATE (RIME_FACTOR_INPUT & - ,int_state%QS,int_state%QG & - ,int_state%F_RIMEF & - ,IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE) - td%rfupdate_tim=td%rfupdate_tim+(timef()-btim) - ENDIF - ELSE -! -!-- Total condensate advection (SPEC_ADV=F): advect Q2 (TKE) & total condensate (CW) -! - KSS=int_state%INDX_CW - KSE1=int_state%INDX_Q2 - ENDIF - -! write(6,*) 'DEBUG-GT: 2nd call to ADV2, kss,kse=',kss,kse1 -! - btim=timef() -! - CALL ADV2 & - (GLOBAL & - ,IDTADT,KSS,KSE1,LM,LNSAD & - ,DT,RDYH & - ,int_state%DSG2,int_state%PDSG1 & - ,int_state%EPSQ2 & - ,int_state%FAH,int_state%RDXH & - ,int_state%PD,int_state%PDO & - ,int_state%PSGDT & - ,int_state%UP,int_state%VP & - ,int_state%INDX_Q2 & - ,int_state%TRACERS & - ,int_state%TRACERS_PREV & -! -!*** Temporary arguments -! - ,int_state%PFNE,int_state%PFNW & - ,int_state%PFX,int_state%PFY & - ,int_state%TRACERS_SQRT & - ,int_state%TRACERS_TEND) -! - td%adv2_tim=td%adv2_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Filtering and boundary conditions for global forecasts -!----------------------------------------------------------------------- -! - IF(GLOBAL)THEN -! - btim=timef() -! - DO KS=KSS,KSE1 - CALL FFTFHN & - (LM & - ,int_state%KHFILT & - ,int_state%HFILT & - ,int_state%TRACERS_TEND(IMS:IME,JMS:JME,1:LM,KS) & - ,int_state%WFFTRH,int_state%NFFTRH & - ,NUM_PES,MYPE,MPI_COMM_COMP) - ENDDO -! - td%fftfhn_tim=td%fftfhn_tim+(timef()-btim) -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Tracer monotonization -!----------------------------------------------------------------------- -! - btim=timef() -! - CALL MONO & - (IDTADT,KSS,KSE1,LM & - ,int_state%DSG2,int_state%PDSG1 & - ,int_state%EPSQ2 & - ,int_state%DARE & - ,int_state%PD & - ,int_state%INDX_Q2 & - ,int_state%TRACERS & - ,INPES,JNPES & - ,int_state%USE_ALLREDUCE & -! -!*** Temporary arguments -! - ,int_state%TRACERS_SQRT & - ,int_state%TRACERS_TEND) -! - td%mono_tim=td%mono_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Update tracers -!----------------------------------------------------------------------- -! - btim=timef() -! - CALL UPDATES & - (LM,int_state%NUM_TRACERS_TOTAL,KSS,KSE1 & - ,int_state%TRACERS,int_state%TRACERS_TEND) -! - td%updates_tim=td%updates_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -! -if_global: IF(GLOBAL)THEN !-- Global NMMB -! - btim=timef() - CALL SWAPHN(int_state%CW,IMS,IME,JMS,JME,LM,INPES) - CALL SWAPHN(int_state%O3,IMS,IME,JMS,JME,LM,INPES) - CALL SWAPHN(int_state%Q2,IMS,IME,JMS,JME,LM,INPES) -!..Need a similar set of lines for the TRACERS array at some point. -! - td%swaphn_tim=td%swaphn_tim+(timef()-btim) -! - btim=timef() - CALL POLEHN(int_state%CW,IMS,IME,JMS,JME,LM,INPES,JNPES) - CALL POLEHN(int_state%O3,IMS,IME,JMS,JME,LM,INPES,JNPES) - CALL POLEHN(int_state%Q2,IMS,IME,JMS,JME,LM,INPES,JNPES) -!..Need a similar set of lines for the TRACERS array at some point. -! - td%polehn_tim=td%polehn_tim+(timef()-btim) -! - btim=timef() - CALL HALO_EXCH(int_state%CW,LM & - ,int_state%O3,LM & - ,int_state%Q2,LM & - ,2,2) - td%exch_dyn=td%exch_dyn+(timef()-btim) -! - ELSE if_global !-- Regional NMMB -! - btim=timef() - DO KS=KSS,KSE1 - CALL HALO_EXCH( & - int_state%TRACERS(IMS:IME,JMS:JME,1:LM,KS),LM & - ,2,2) - ENDDO - td%exch_dyn=td%exch_dyn+(timef()-btim) -! - IF (RIME_FACTOR_ADVECT) THEN - btim=timef() -!--------------- F_RIMEF(:,:,:)=QG(:,:,:)/QS(:,:,:) for physics (after advection) - RIME_FACTOR_INPUT=.FALSE. - CALL RIME_FACTOR_UPDATE (RIME_FACTOR_INPUT & - ,int_state%QS,int_state%QG & - ,int_state%F_RIMEF & - ,IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE) - td%rfupdate_tim=td%rfupdate_tim+(timef()-btim) - ENDIF -! - ENDIF if_global -! -!----------------------------------------------------------------------- -! - ENDIF not_q_tracers -! -!----------------------------------------------------------------------- -!*** Interface pressures and horizontal part of Omega-Alpha term -!----------------------------------------------------------------------- -! - btim=timef() -! - CALL VTOA & - (LM,DT,EF4T,PT,int_state%SG2 & - ,int_state%PSDT & - ,int_state%DWDT,int_state%RTOP & - ,int_state%OMGALF & - ,int_state%PINT & -! -!*** Temporary arguments -! - ,int_state%TDIV,int_state%TCT) -! - td%vtoa_tim=td%vtoa_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Filtering and boundary conditions for global forecasts -!----------------------------------------------------------------------- -! - IF(GLOBAL)THEN -! - btim=timef() - CALL FFTFHN & - (LM & - ,int_state%KHFILT & - ,int_state%HFILT & - ,int_state%TCT & - ,int_state%WFFTRH,int_state%NFFTRH & - ,NUM_PES,MYPE,MPI_COMM_COMP) - td%fftfhn_tim=td%fftfhn_tim+(timef()-btim) -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Update the temperature field. -!----------------------------------------------------------------------- -! - btim=timef() -! - CALL UPDATET & - (LM & - ,int_state%T & -! -!*** Temporary argument -! - ,int_state%TCT) -! - td%updatet_tim=td%updatet_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Filtering and boundary conditions for global forecasts -!----------------------------------------------------------------------- -! - IF(GLOBAL)THEN -! - btim=timef() - CALL SWAPHN(int_state%OMGALF,IMS,IME,JMS,JME,LM,INPES) - CALL SWAPHN(int_state%PINT,IMS,IME,JMS,JME,LM+1,INPES) - CALL SWAPHN(int_state%T,IMS,IME,JMS,JME,LM,INPES) - td%swaphn_tim=td%swaphn_tim+(timef()-btim) -! - btim=timef() - CALL POLEHN(int_state%OMGALF,IMS,IME,JMS,JME,LM,INPES,JNPES) - CALL POLEHN(int_state%PINT,IMS,IME,JMS,JME,LM+1,INPES,JNPES) - CALL POLEHN(int_state%T,IMS,IME,JMS,JME,LM,INPES,JNPES) - td%polehn_tim=td%polehn_tim+(timef()-btim) -! - ENDIF -! -!----------------------------------------------------------------------- -! - btim=timef() - CALL HALO_EXCH(int_state%OMGALF,LM & - ,int_state%PINT,LM+1 & - ,2,2) - CALL HALO_EXCH(int_state%T,LM & - ,2,2) - td%exch_dyn=td%exch_dyn+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Nonhydrostatic advection of height -!----------------------------------------------------------------------- -! - btim=timef() -! - CALL CDZDT & - (GLOBAL,HYDRO & - ,LM,DT,int_state%DSG2,int_state%PDSG1 & - ,int_state%FAH,int_state%FIS & - ,int_state%PD,int_state%PDO & - ,int_state%PSGDT & - ,int_state%CW,int_state%Q,int_state%RTOP,int_state%T & - ,int_state%PINT & - ,int_state%DWDT,int_state%PDWDT,int_state%W,int_state%BARO & - ,int_state%Z & -! -!*** temporary arguments -! - ,int_state%PFNE,int_state%PFNW,int_state%PFX,int_state%PFY) -! - td%cdzdt_tim=td%cdzdt_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Filtering and boundary conditions for global forecasts -!----------------------------------------------------------------------- -! - IF(GLOBAL)THEN -! - btim=timef() - CALL FFTFHN & - (LM & - ,int_state%KHFILT & - ,int_state%HFILT & - ,int_state%W & - ,int_state%WFFTRH,int_state%NFFTRH & - ,NUM_PES,MYPE,MPI_COMM_COMP) - td%fftfhn_tim=td%fftfhn_tim+(timef()-btim) -! - btim=timef() - CALL SWAPHN(int_state%W,IMS,IME,JMS,JME,LM,INPES) - td%swaphn_tim=td%swaphn_tim+(timef()-btim) -! - btim=timef() - CALL POLEHN(int_state%W,IMS,IME,JMS,JME,LM,INPES,JNPES) - td%polehn_tim=td%polehn_tim+(timef()-btim) -! - ENDIF -! -!----------------------------------------------------------------------- -! - btim=timef() - CALL HALO_EXCH(int_state%W,LM & - ,3,3) - td%exch_dyn=td%exch_dyn+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Advection of W (with internal halo exchange) -!----------------------------------------------------------------------- -! - btim=timef() -! - CALL CDWDT & - (GLOBAL,HYDRO,int_state%RESTART & - ,INPES,JNPES,LM,ABS(NTIMESTEP) & - ,DT,G,int_state%DSG2,int_state%PDSG1,int_state%PSGML1 & - ,int_state%FAH & - ,int_state%HDACX,int_state%HDACY & - ,int_state%PD,int_state%PDO & - ,int_state%PSGDT & - ,int_state%DWDT,int_state%PDWDT,int_state%W & - ,int_state%PINT & -! -!*** External scratch areas -! - ,int_state%DEF,int_state%PFX,int_state%PFY & - ,int_state%PFNE,int_state%PFNW) -! - td%cdwdt_tim=td%cdwdt_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Filtering and boundary conditions for global forecasts -!----------------------------------------------------------------------- -! - IF(GLOBAL)THEN -! - btim=timef() - CALL FFTFHN & - (LM & - ,int_state%KHFILT & - ,int_state%HFILT & - ,int_state%DWDT & - ,int_state%WFFTRH,int_state%NFFTRH & - ,NUM_PES,MYPE,MPI_COMM_COMP) - td%fftfhn_tim=td%fftfhn_tim+(timef()-btim) -! - btim=timef() - CALL SWAPHN(int_state%DWDT,IMS,IME,JMS,JME,LM,INPES) - td%swaphn_tim=td%swaphn_tim+(timef()-btim) -! - btim=timef() - CALL POLEHN(int_state%DWDT,IMS,IME,JMS,JME,LM,INPES,JNPES) - td%polehn_tim=td%polehn_tim+(timef()-btim) -! - ENDIF -! -!----------------------------------------------------------------------- -! - btim=timef() - CALL HALO_EXCH(int_state%DWDT,LM & - ,2,2) - td%exch_dyn=td%exch_dyn+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Vertically propagating fast waves -!----------------------------------------------------------------------- -! - btim=timef() -! - CALL VSOUND & - (GLOBAL,HYDRO,int_state%RESTART & - ,LM,ABS(NTIMESTEP) & - ,CP,DT,PT,int_state%DSG2,int_state%PDSG1 & - ,int_state%PD & - ,int_state%CW,int_state%Q,int_state%RTOP & - ,int_state%DWDT,int_state%T,int_state%W,int_state%W_TOT & - ,int_state%BARO & - ,int_state%PINT) -! - td%vsound_tim=td%vsound_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Filtering and boundary conditions for global forecasts -!----------------------------------------------------------------------- -! - IF(GLOBAL)THEN -! - btim=timef() - CALL POAVHN & - (IMS,IME,JMS,JME,LM & - ,int_state%DWDT & - ,INPES,JNPES & - ,int_state%USE_ALLREDUCE) - CALL POAVHN & - (IMS,IME,JMS,JME,LM & - ,int_state%W & - ,INPES,JNPES & - ,int_state%USE_ALLREDUCE) - CALL POAVHN & - (IMS,IME,JMS,JME,LM & - ,int_state%PINT & - ,INPES,JNPES & - ,int_state%USE_ALLREDUCE) - td%poavhn_tim=td%poavhn_tim+(timef()-btim) -! - btim=timef() - CALL SWAPHN(int_state%DWDT,IMS,IME,JMS,JME,LM,INPES) - CALL SWAPHN(int_state%T,IMS,IME,JMS,JME,LM,INPES) - CALL SWAPHN(int_state%W,IMS,IME,JMS,JME,LM,INPES) - CALL SWAPHN(int_state%PINT,IMS,IME,JMS,JME,LM+1,INPES) - td%swaphn_tim=td%swaphn_tim+(timef()-btim) -! - btim=timef() - CALL POLEHN(int_state%DWDT,IMS,IME,JMS,JME,LM,INPES,JNPES) - CALL POLEHN(int_state%T,IMS,IME,JMS,JME,LM,INPES,JNPES) - CALL POLEHN(int_state%W,IMS,IME,JMS,JME,LM,INPES,JNPES) - CALL POLEHN(int_state%PINT,IMS,IME,JMS,JME,LM+1,INPES,JNPES) - td%polehn_tim=td%polehn_tim+(timef()-btim) -! - ENDIF -! -!----------------------------------------------------------------------- -! - btim=timef() - CALL HALO_EXCH(int_state%DWDT,LM & - ,int_state%T,LM & - ,2,2) - CALL HALO_EXCH(int_state%W,LM & - ,int_state%PINT,LM+1 & - ,2,2) - td%exch_dyn=td%exch_dyn+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Save DT to compare and see if sign has changed for filtering. -!----------------------------------------------------------------------- -! - int_state%DT_LAST=DT_TEST - int_state%DT_TEST_RATIO=REAL(INTEGER_DT)+REAL(NUMERATOR_DT) & - /REAL(IDENOMINATOR_DT) - int_state%FILTER_METHOD_LAST=FILTER_METHOD -! -!----------------------------------------------------------------------- -!*** NOTE: The Solver export state is fully updated now -!*** because subroutine SOLVER_INITIALIZE inserted the -!*** appropriate ESMF Fields into it. Those Fields -!*** contain pointers to the actual data and those -!*** pointers are never re-directed, i.e., no explicit -!*** action is needed to update the Solver export state. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Write the layer statistics for temperature. -!----------------------------------------------------------------------- -! - IF(MOD(ABS(NTIMESTEP)+1,N_PRINT_STATS)==0)THEN -! - IF(int_state%PRINT_DIAG .OR. int_state%PRINT_ALL) & - CALL FIELD_STATS(INT_STATE%T,MYPE,MPI_COMM_COMP,LM & - ,ITS,ITE,JTS,JTE & - ,IMS,IME,JMS,JME & - ,IDS,IDE,JDS,JDE) - ENDIF -! - td%solver_dyn_tim=td%solver_dyn_tim+(timef()-btim0) -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!----PHY_RUN START ----------------------------------------------------- -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!rv - please do not remove this template call: -! call exit('dyn',int_state%pint,int_state%t,int_state%q & -! ,int_state%u,int_state%v,int_state%q2,int_state%w & -! ,ntimestep,mype,my_domain_id,mpi_comm_comp & -! ,ids,ide,jds,jde,lm & -! ,ims,ime,jms,jme & -! ,its,ite,jts,jte) -! if(mod(nint(dt*ntimestep),3600)==0)then -! call twr(int_state%t,lm,'tphy',ntimestep,mype,num_pes,mpi_comm_comp & -! ,ids,ide,jds,jde & -! ,ims,ime,jms,jme & -! ,its,ite,jts,jte & -! ,my_domain_id ) -! call vwr(int_state%u,lm,'uphy',ntimestep,mype,num_pes,mpi_comm_comp & -! ,ids,ide,jds,jde & -! ,ims,ime,jms,jme & -! ,its,ite,jts,jte & -! ,my_domain_id ) -! endif -!rv -! - physics: IF(INTEGER_DT>0)THEN !<-- Physics is active -! - btim0=timef() -! -!----------------------------------------------------------------------- -!*** Call radiation so that updated fields are written to the -!*** history files after 0 hours. -!----------------------------------------------------------------------- -! - IF(NTIMESTEP==0)THEN - NTIMESTEP_RAD=NTIMESTEP - ELSE - NTIMESTEP_RAD=NTIMESTEP+1 - ENDIF -! -!----------------------------------------------------------------------- -!*** Dereference some internal state components for convenience. -!----------------------------------------------------------------------- -! - NPRECIP=int_state%NPRECIP - PDTOP=int_state%PDTOP - PT=int_state%PT -! -!----------------------------------------------------------------------- -! - gfs_phys_test: IF(.NOT.int_state%GFS)THEN !<-- NMM-B physics is NOT the GFS package -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** At the appropriate times, reset the various min/max/average -!*** diagnostic fields to begin accumulating for the next period -!----------------------------------------------------------------------- -! - IF(NTIMESTEP == 0 .or. MOD(NTIMESTEP,NSTEPS_PER_RESET)==0) THEN - DO J=JTS,JTE - DO I=ITS,ITE - int_state%TLMAX(I,J)=-999. - int_state%TLMIN(I,J)=999. - int_state%T02MAX(I,J)=-999. - int_state%T02MIN(I,J)=999. - int_state%RH02MAX(I,J)=-999. - int_state%RH02MIN(I,J)=999. - int_state%SPD10MAX(I,J)=-999. - int_state%UPHLMAX(I,J)=0. - int_state%U10MAX(I,J)=-999. - int_state%V10MAX(I,J)=-999. - int_state%UPVVELMAX(I,J)=-999. - int_state%DNVVELMAX(I,J)=999. - int_state%T10AVG(I,J)=0. - int_state%T10(I,J)=0. - int_state%PSFCAVG(I,J)=0. - int_state%AKHSAVG(I,J)=0. - int_state%AKMSAVG(I,J)=0. - int_state%SNOAVG(I,J)=0. - int_state%REFDMAX(I,J)=DBZmin - int_state%PRATEMAX(I,J)=0 - int_state%FPRATEMAX(I,J)=0 - int_state%UPHLMAX(I,J)=-999. - ENDDO - ENDDO -! - int_state%NCOUNT=0 - ENDIF -! -! IF (mod(int_state%NTSD,NSTEPS_PER_CHECK) == 0) THEN - IF (mod(int_state%NTSD,NSTEPS_PER_CHECK) == 0 .and. FILTER_METHOD==0 ) THEN -! -max_hrly: IF (TRIM(int_state%MICROPHYSICS) == 'fer') THEN -! - CALL MAX_FIELDS(int_state%T,int_state%Q,int_state%U & - ,int_state%V,int_state%CW & - ,int_state%F_RAIN,int_state%F_ICE & - ,int_state%F_RIMEF,int_state%Z & - ,int_state%W_TOT,int_state%PINT & - ,int_state%PD,int_state%PREC & - ,int_state%CPRATE,int_state%HTOP & - ,int_state%T2,int_state%U10,int_state%V10 & - ,int_state%PSHLTR,int_state%TSHLTR & - ,int_state%QSHLTR & - ,int_state%SGML2,int_state%PSGML1 & - ,int_state%REFDMAX,int_state%PRATEMAX & - ,int_state%FPRATEMAX,int_state%SR & - ,int_state%UPVVELMAX,int_state%DNVVELMAX & - ,int_state%TLMAX,int_state%TLMIN & - ,int_state%T02MAX,int_state%T02MIN & - ,int_state%RH02MAX,int_state%RH02MIN & - ,int_state%U10MAX,int_state%V10MAX & - ,int_state%TH10,int_state%T10 & - ,int_state%SPD10MAX,int_state%T10AVG & - ,int_state%PSFCAVG & - ,int_state%AKHS,int_state%AKMS & - ,int_state%AKHSAVG,int_state%AKMSAVG & - ,int_state%SNO,int_state%SNOAVG & - ,int_state%UPHLMAX & - ,int_state%DT,int_state%NPHS,int_state%NTSD & - ,int_state%DXH,int_state%DYH & - ,int_state%FIS & - ,ITS,ITE,JTS,JTE & - ,IMS,IME,JMS,JME & - ,IDE,JDE & - ,ITS_B1,ITE_B1,JTS_B1,JTE_B1 & - ,LM,int_state%NCOUNT,int_state%FIRST_NMM & - ,MY_DOMAIN_ID & - ) -! - ELSEIF (TRIM(int_state%MICROPHYSICS) == 'fer_hires') THEN max_hrly -! - CALL MAX_FIELDS_HR(int_state%T,int_state%Q,int_state%U & - ,int_state%V,int_state%CW & - ,int_state%F_RAIN,int_state%F_ICE & - ,int_state%F_RIMEF,int_state%Z & - ,int_state%W_TOT,int_state%refl_10cm & - ,int_state%PINT,int_state%PD,int_state%PREC & - ,int_state%CPRATE,int_state%HTOP & - ,int_state%T2,int_state%U10,int_state%V10 & - ,int_state%PSHLTR,int_state%TSHLTR & - ,int_state%QSHLTR & - ,int_state%SGML2,int_state%PSGML1 & - ,int_state%REFDMAX,int_state%PRATEMAX & - ,int_state%FPRATEMAX,int_state%SR & - ,int_state%UPVVELMAX,int_state%DNVVELMAX & - ,int_state%TLMAX,int_state%TLMIN & - ,int_state%T02MAX,int_state%T02MIN & - ,int_state%RH02MAX,int_state%RH02MIN & - ,int_state%U10MAX,int_state%V10MAX & - ,int_state%TH10,int_state%T10 & - ,int_state%SPD10MAX,int_state%T10AVG & - ,int_state%PSFCAVG & - ,int_state%AKHS,int_state%AKMS & - ,int_state%AKHSAVG,int_state%AKMSAVG & - ,int_state%SNO,int_state%SNOAVG & - ,int_state%UPHLMAX & - ,int_state%DT,int_state%NPHS,int_state%NTSD & - ,int_state%DXH,int_state%DYH & - ,int_state%FIS & - ,ITS,ITE,JTS,JTE & - ,IMS,IME,JMS,JME & - ,IDE,JDE & - ,ITS_B1,ITE_B1,JTS_B1,JTE_B1 & - ,LM,int_state%NCOUNT,int_state%FIRST_NMM & - ,MY_DOMAIN_ID & - ) -! - ELSEIF (TRIM(int_state%MICROPHYSICS) == 'wsm6') THEN max_hrly -! - CALL MAX_FIELDS_W6(int_state%T,int_state%Q,int_state%U & - ,int_state%V,int_state%Z,int_state%W_TOT & - ,int_state%QR,int_state%QS,int_state%QG & - ,int_state%PINT,int_state%PD,int_state%PREC & - ,int_state%CPRATE,int_state%HTOP & - ,int_state%T2,int_state%U10,int_state%V10 & - ,int_state%PSHLTR,int_state%TSHLTR & - ,int_state%QSHLTR & - ,int_state%SGML2,int_state%PSGML1 & - ,int_state%REFDMAX,int_state%PRATEMAX & - ,int_state%FPRATEMAX,int_state%SR & - ,int_state%UPVVELMAX,int_state%DNVVELMAX & - ,int_state%TLMAX,int_state%TLMIN & - ,int_state%T02MAX,int_state%T02MIN & - ,int_state%RH02MAX,int_state%RH02MIN & - ,int_state%U10MAX,int_state%V10MAX & - ,int_state%TH10,int_state%T10 & - ,int_state%SPD10MAX,int_state%T10AVG & - ,int_state%PSFCAVG & - ,int_state%AKHS,int_state%AKMS & - ,int_state%AKHSAVG,int_state%AKMSAVG & - ,int_state%SNO,int_state%SNOAVG & - ,int_state%UPHLMAX & - ,int_state%DT,int_state%NPHS,int_state%NTSD & - ,int_state%DXH,int_state%DYH & - ,int_state%FIS & - ,ITS,ITE,JTS,JTE & - ,IMS,IME,JMS,JME & - ,IDE,JDE & - ,ITS_B1,ITE_B1,JTS_B1,JTE_B1 & - ,LM & - ,int_state%NCOUNT,int_state%FIRST_NMM & - ,MY_DOMAIN_ID & - ) -! - ELSEIF (TRIM(int_state%MICROPHYSICS) == 'thompson') THEN max_hrly -! - CALL MAX_FIELDS_THO(int_state%T,int_state%Q,int_state%U & - ,int_state%V,int_state%Z,int_state%W_TOT & - ,int_state%refl_10cm & - ,int_state%PINT,int_state%PD,int_state%PREC & - ,int_state%CPRATE,int_state%HTOP & - ,int_state%T2,int_state%U10,int_state%V10 & - ,int_state%PSHLTR,int_state%TSHLTR & - ,int_state%QSHLTR & - ,int_state%SGML2,int_state%PSGML1 & - ,int_state%REFDMAX,int_state%PRATEMAX & - ,int_state%FPRATEMAX,int_state%SR & - ,int_state%UPVVELMAX,int_state%DNVVELMAX & - ,int_state%TLMAX,int_state%TLMIN & - ,int_state%T02MAX,int_state%T02MIN & - ,int_state%RH02MAX,int_state%RH02MIN & - ,int_state%U10MAX,int_state%V10MAX & - ,int_state%TH10,int_state%T10 & - ,int_state%SPD10MAX,int_state%T10AVG & - ,int_state%PSFCAVG & - ,int_state%AKHS,int_state%AKMS & - ,int_state%AKHSAVG,int_state%AKMSAVG & - ,int_state%SNO,int_state%SNOAVG & - ,int_state%UPHLMAX & - ,int_state%DT,int_state%NPHS,int_state%NTSD & - ,int_state%DXH,int_state%DYH & - ,int_state%FIS & - ,ITS,ITE,JTS,JTE & - ,IMS,IME,JMS,JME & - ,IDE,JDE & - ,ITS_B1,ITE_B1,JTS_B1,JTE_B1 & - ,LM & - ,int_state%NCOUNT,int_state%FIRST_NMM & - ,MY_DOMAIN_ID & - ) -! - ENDIF max_hrly -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Set logical switches for calling each of the Physics schemes. -!----------------------------------------------------------------------- -! - CALL_SHORTWAVE=MOD(NTIMESTEP_RAD,int_state%NRADS)==0 - CALL_LONGWAVE=MOD(NTIMESTEP_RAD,int_state%NRADL)==0 - CALL_TURBULENCE=MOD(NTIMESTEP,int_state%NPHS)==0 - CALL_PRECIP=MOD(NTIMESTEP,NPRECIP)==0 -! -!----------------------------------------------------------------------- -!*** Update WATER array from CWM, F_ICE, F_RAIN for Ferrier -!*** microphysics but only if any of the Physics subroutines -!*** are called (subroutine UPDATE_WATER is after subroutine -!*** PHYSICS_INITIALIZE in this module). -! -!*** Expanded to also update CWM, F_ICE, F_RAIN, F_RIMEF for non-Ferrier -!*** microphysics. -!----------------------------------------------------------------------- -! - update_wtr: IF((int_state%MICROPHYSICS=='fer' & - .OR. & - int_state%MICROPHYSICS=='fer_hires' & - .OR. & - int_state%MICROPHYSICS=='gfs' & - .OR. & - int_state%MICROPHYSICS=='wsm6' & - .OR. & - int_state%MICROPHYSICS=='thompson') & - .AND. & - (CALL_SHORTWAVE .OR. CALL_LONGWAVE .OR. & - CALL_TURBULENCE .OR. CALL_PRECIP) ) THEN -! -! write(*,*) 'DEBUG-GT, now calling UPDATE_WATER' - CALL UPDATE_WATER(int_state%CW & - ,int_state%F_ICE & - ,int_state%F_RAIN & - ,int_state%F_RIMEF & - ,int_state%T & - ,int_state%QC & - ,int_state%QR & - ,int_state%QS & - ,int_state%QI & - ,int_state%QG & - ,int_state%MICROPHYSICS & - ,int_state%SPEC_ADV & - ,NTIMESTEP & - ,IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE) -! - ENDIF update_wtr -! -!--------------------------------------------------------------------- -!*** Precipitation Adjustment -!----------------------------------------------------------------------- -! -!*** -!*** Call READPCP to -!*** 1) READ IN PRECIPITATION FOR HOURS 1, 2 and 3; -!*** 2) Initialize DDATA to 999. (this is the amount -!*** of input precip allocated to each physics time step -!*** in ADJPPT; TURBL/SURFCE, which uses DDATA, is called -!*** before ADJPPT) -!*** 3) Initialize LSPA to zero -!*** -!----------------------------------------------------------------------- -! - IF(int_state%NTSD==0)THEN - IF(int_state%PCPFLG .and. FILTER_METHOD == 0)THEN - CALL READPCP(MYPE,MPI_COMM_COMP & - ,int_state%PPTDAT & - ,int_state%DDATA & - ,int_state%LSPA & - ,int_state%PCPHR & - ,MY_DOMAIN_ID & - ,IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE & - ,ITS_B1,ITE_B1,JTS_B2,JTE_B2) - ENDIF - ENDIF -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** Call the individual physical processes. -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** Radiation -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!*** Radiation needs some specific time quantities. Use NTIMESTEP_rad -!*** for the next time step ahead of the current time so that the -!*** radiation fields can be updated prior to being written to -!*** output (BSF 10/6/2010). -! - CALL TIME_MEASURE(START_YEAR,START_MONTH,START_DAY,START_HOUR & - ,START_MINUTE,START_SECOND & - ,NTIMESTEP_rad,int_state%DT & - ,JULDAY,JULYR,JULIAN,XTIME) -! -!----------------------------------------------------------------------- - radiatn: IF(CALL_SHORTWAVE.OR.CALL_LONGWAVE)THEN -!----------------------------------------------------------------------- -! - btim=timef() -! write(*,*) 'DEBUG-GT, now calling RADIATION ', btim -! -!----------------------------------------------------------------------- -!*** Temporary switch between radiation schemes placed in SOLVER_RUN -!*** rather than inside RADIATION_DRIVER (will be done later) -!----------------------------------------------------------------------- -! - CALL ESMF_ClockGet(clock =CLOCK_ATM & !<-- The ESMF Clock - ,startTime =STARTTIME & !<-- The start time (ESMF) on the clock - ,currTime =CURRTIME & !<-- The current time (ESMF) on the clock - ,rc =RC) -! - CALL ESMF_TimeGet(time=STARTTIME & !<-- The start forecast time (ESMF) - ,yy =IDAT(1) & !<-- The start forecast year (integer) - ,mm =IDAT(2) & !<-- The start forecast month (integer) - ,dd =IDAT(3) & !<-- The start forecast day (integer) - ,h =IDAT(5) & !<-- The start forecast hour (integer) - ,m =IDAT(6) & !<-- The start forecast minute (integer) - ,s =IDAT(7) & !<-- The start forecast second (integer) - ,rc =RC) - IDAT(4)=0 - IDAT(8)=0 -! - CALL ESMF_TimeGet(time=CURRTIME & !<-- The cuurent forecast time (ESMF) - ,yy =JDAT(1) & !<-- The current forecast year (integer) - ,mm =JDAT(2) & !<-- The current forecast month (integer) - ,dd =JDAT(3) & !<-- The current forecast day (integer) - ,h =JDAT(5) & !<-- The current forecast hour (integer) - ,m =JDAT(6) & !<-- The current forecast minute (integer) - ,s =JDAT(7) & !<-- The current forecast second (integer) - ,rc =RC) - JDAT(4)=0 - JDAT(8)=0 -! - CALL RADIATION(NTIMESTEP_RAD & - ,int_state%DT,JULDAY,JULYR,XTIME,JULIAN & - ,START_HOUR,int_state%NPHS & - ,int_state%GLAT,int_state%GLON & - ,int_state%NRADS,int_state%NRADL & - ,int_state%DSG2,int_state%SGML2,int_state%SG2 & - ,int_state%PDSG1,int_state%PSGML1 & - ,int_state%PSG1 & - ,int_state%PT,int_state%PD & - ,int_state%T,int_state%Q & - ,int_state%THS,int_state%ALBEDO & - ,int_state%QC,int_state%QR & - ,int_state%QI,int_state%QS,int_state%QG & - ,int_state%NI & - ,int_state%F_QC,int_state%F_QR & - ,int_state%F_QI,int_state%F_QS,int_state%F_QG & - ,int_state%F_NI & - ,int_state%NUM_WATER & - ,int_state%SM,int_state%CLDFRA & - ,int_state%RLWTT,int_state%RSWTT & - ,int_state%RLWIN,int_state%RSWIN & - ,int_state%RSWINC,int_state%RSWOUT & - ,int_state%RLWTOA,int_state%RSWTOA & - ,int_state%CZMEAN,int_state%SIGT4 & - ,int_state%CFRACL,int_state%CFRACM & - ,int_state%CFRACH & - ,int_state%ACFRST,int_state%NCFRST & - ,int_state%ACFRCV,int_state%NCFRCV & - ,int_state%CUPPT,int_state%SNO & - ,int_state%HTOP,int_state%HBOT & - ,int_state%SHORTWAVE,int_state%LONGWAVE & - ,int_state%CLDFRACTION & - ,int_state%DYH & -!---- RRTM part --------------------------------------------------------- - ,int_state%DT_INT,JDAT & - ,int_state%CW,int_state%O3 & - ,int_state%F_ICE,int_state%F_RAIN & - ,int_state%F_RIMEF & - ,int_state%SI,int_state%TSKIN & - ,int_state%Z0,int_state%SICE & - ,int_state%MXSNAL,int_state%SGM & - ,int_state%STDH,int_state%OMGALF & - ,int_state%SNOWC & -!------------------------------------------------------------------------ - ,LM) -! - td%radiation_tim=td%radiation_tim+(timef()-btim) -! - ENDIF radiatn -! -!----------------------------------------------------------------------- -!*** Empty the ACFRST and ACFRCV accumulation arrays if it is time -!*** to do so prior to their being updated by the radiation. -!----------------------------------------------------------------------- -! - IF(MOD(NTIMESTEP,int_state%NCLOD)==0)THEN - DO J=JTS,JTE - DO I=ITS,ITE - int_state%ACFRST(I,J)=0. - int_state%ACFRCV(I,J)=0. - int_state%NCFRST(I,J)=0 - int_state%NCFRCV(I,J)=0 - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Update the temperature with the radiative tendency. -!----------------------------------------------------------------------- -! - btim=timef() -! - CALL RDTEMP(NTIMESTEP,int_state%DT,JULDAY,JULYR,START_HOUR & - ,int_state%GLAT,int_state%GLON & - ,int_state%CZEN,int_state%CZMEAN,int_state%T & - ,int_state%RSWTT,int_state%RLWTT & - ,IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE & - ,ITS_B1,ITE_B1,JTS_B1,JTE_B1) -! - td%rdtemp_tim=td%rdtemp_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Poles and East-West boundary. -!----------------------------------------------------------------------- -! - IF(int_state%GLOBAL)THEN - btim=timef() -! - CALL SWAPHN(int_state%RSWIN,IMS,IME,JMS,JME,1,int_state%INPES) - CALL POLEHN(int_state%RSWIN,IMS,IME,JMS,JME,1 & - ,int_state%INPES,int_state%JNPES) -! - CALL SWAPHN(int_state%T,IMS,IME,JMS,JME,LM,int_state%INPES) - CALL POLEHN(int_state%T,IMS,IME,JMS,JME,LM & - ,int_state%INPES,int_state%JNPES) -! - td%pole_swap_tim=td%pole_swap_tim+(timef()-btim) - ENDIF -! -!----------------------------------------------------------------------- -!*** Empty the accumulators of sfc energy flux and sfc hydrology if -!*** it is time to do so prior to their being updated by turbulence. -!----------------------------------------------------------------------- -! - IF(MOD(NTIMESTEP,int_state%NRDLW)==0)THEN - DO J=JTS,JTE - DO I=ITS,ITE - int_state%ALWIN(I,J) =0. - int_state%ALWOUT(I,J)=0. - int_state%ALWTOA(I,J)=0. - int_state%ARDLW(I,J) =0. !<-- An artificial 2-D array - ! (ESMF cannot have an evolving scalar Attribute) - ENDDO - ENDDO - ENDIF -! - IF(MOD(NTIMESTEP,int_state%NRDSW)==0)THEN - DO J=JTS,JTE - DO I=ITS,ITE - int_state%ASWIN(I,J)=0. - int_state%ASWOUT(I,J)=0. - int_state%ASWTOA(I,J)=0. - int_state%ARDSW(I,J) =0. !<-- An artificial 2-D array - ! (ESMF cannot have an evolving scalar Attribute) - ENDDO - ENDDO - ENDIF -! - IF(MOD(NTIMESTEP,int_state%NSRFC)==0)THEN - DO J=JTS,JTE - DO I=ITS,ITE - int_state%SFCSHX(I,J)=0. - int_state%SFCLHX(I,J)=0. - int_state%SUBSHX(I,J)=0. - int_state%SNOPCX(I,J)=0. - int_state%POTFLX(I,J)=0. - int_state%ASRFC(I,J) =0. !<-- An artificial 2-D array - ! (ESMF cannot have an evolving scalar Attribute) - ENDDO - ENDDO - ENDIF -! - IF(MOD(NTIMESTEP,int_state%NPREC)==0)THEN - DO J=JTS,JTE - DO I=ITS,ITE - int_state%ACSNOW(I,J)=0. - int_state%ACSNOM(I,J)=0. - int_state%SSROFF(I,J)=0. - int_state%BGROFF(I,J)=0. - int_state%SFCEVP(I,J)=0. - int_state%POTEVP(I,J)=0. - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** Turbulence, Sfc Layer, and Land Surface -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - turbulence: IF(CALL_TURBULENCE)THEN -! - btim=timef() -! write(*,*) 'DEBUG-GT, now calling TURBL ', btim -! - DO L=1,NUM_SOIL_LAYERS - DZSOIL(L)=SLDPTH(L) - ENDDO -! - IF(int_state%PCPFLG .and. FILTER_METHOD == 0)THEN - LOC_PCPFLG=int_state%PCPFLG - ELSE - LOC_PCPFLG=.FALSE. - ENDIF -! - CALL TURBL(NTIMESTEP,int_state%DT,int_state%NPHS & - ,NUM_SOIL_LAYERS,SLDPTH,DZSOIL & - ,int_state%DSG2,int_state%SGML2,int_state%SG2 & - ,int_state%PDSG1,int_state%PSGML1,int_state%PSG1,PT & - ,int_state%EPSL,int_state%EPSQ2 & - ,int_state%SM,int_state%CZEN,int_state%CZMEAN & - ,int_state%SIGT4,int_state%RLWIN,int_state%RSWIN & - ,int_state%RADOT & - ,int_state%RLWTT,int_state%RSWTT & - ,int_state%PD,int_state%T & - ,int_state%Q,int_state%CW & - ,int_state%F_ICE,int_state%F_RAIN,int_state%F_RIMEF & - ,int_state%SR,int_state%Q2,int_state%U,int_state%V & - ,int_state%DUDT,int_state%DVDT & - ,int_state%THS,int_state%TSKIN,int_state%SST & - ,int_state%PREC,int_state%SNO & - ,int_state%SNOWC & - ,int_state%QC,int_state%QR & - ,int_state%QI,int_state%QS,int_state%QG & - ,int_state%F_QC,int_state%F_QR & - ,int_state%F_QI,int_state%F_QS,int_state%F_QG & - ,int_state%FIS,int_state%Z0,int_state%Z0BASE & - ,int_state%USTAR,int_state%PBLH,int_state%LPBL & - ,int_state%XLEN_MIX,int_state%RMOL & - ,int_state%EXCH_H,int_state%AKHS,int_state%AKMS & - ,int_state%AKHS_OUT,int_state%AKMS_OUT & - ,int_state%THZ0,int_state%QZ0 & - ,int_state%UZ0,int_state%VZ0 & - ,int_state%QSH,int_state%MAVAIL & - ,int_state%STC,int_state%SMC,int_state%CMC & - ,int_state%SMSTAV,int_state%SMSTOT & - ,int_state%SSROFF,int_state%BGROFF & - ,int_state%IVGTYP,int_state%ISLTYP,int_state%VEGFRC & - ,int_state%GRNFLX & - ,int_state%SFCEXC,int_state%ACSNOW,int_state%ACSNOM & - ,int_state%SNOPCX,int_state%SICE & - ,int_state%TG,int_state%SOILTB & - ,int_state%ALBASE,int_state%MXSNAL,int_state%ALBEDO & - ,int_state%SH2O,int_state%SI,int_state%EPSR & - ,int_state%U10,int_state%V10 & - ,int_state%TH10,int_state%Q10 & - ,int_state%TSHLTR,int_state%QSHLTR,int_state%PSHLTR & - ,int_state%PSFC,int_state%T2 & - ,int_state%TWBS,int_state%QWBS & - ,int_state%SFCSHX,int_state%SFCLHX,int_state%SFCEVP & - ,int_state%TAUX,int_state%TAUY & - ,int_state%POTEVP,int_state%POTFLX,int_state%SUBSHX & - ,int_state%APHTIM & - ,int_state%ARDSW,int_state%ARDLW & - ,int_state%ASRFC & - ,int_state%CROT,int_state%SROT,int_state%MIXHT & - ,int_state%HSTDV,int_state%HCNVX,int_state%HASYW & - ,int_state%HASYS,int_state%HASYSW,int_state%HASYNW & - ,int_state%HLENW,int_state%HLENS,int_state%HLENSW & - ,int_state%HLENNW,int_state%HANGL,int_state%HANIS & - ,int_state%HSLOP,int_state%HZMAX & - ,int_state%CDMB,int_state%CLEFF,int_state%SIGFAC & - ,int_state%FACTOP,int_state%RLOLEV & - ,int_state%DPMIN & - ,int_state%RSWOUT,int_state%RSWTOA,int_state%RLWTOA & - ,int_state%ASWIN,int_state%ASWOUT,int_state%ASWTOA & - ,int_state%ALWIN,int_state%ALWOUT,int_state%ALWTOA & - ,int_state%GWDFLG,LOC_PCPFLG & - ,int_state%DDATA,int_state%UCMCALL,int_state%IVEGSRC& - ,int_state%TURBULENCE,int_state%SFC_LAYER & - ,int_state%LAND_SURFACE & - ,int_state%MICROPHYSICS & - ,int_state%LISS_RESTART & - ,int_state%GLOBAL & - !!! HURRICANE PBL/SFCLAY - ,int_state%VAR_RIC,int_state%COEF_RIC_L & - ,int_state%COEF_RIC_S,int_state%DISHEAT & - ,int_state%ALPHA,int_state%SFENTH & -!!! HURRICANE - - ,IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE) -! - td%turbl_tim=td%turbl_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Exchange wind tendencies. -!----------------------------------------------------------------------- -! - btim=timef() -! - CALL HALO_EXCH(int_state%DUDT,LM,int_state%DVDT,LM,1,1) -! - td%exch_phy=td%exch_phy+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Now interpolate wind tendencies from H to V points. -!----------------------------------------------------------------------- -! - btim=timef() -! - CALL H_TO_V_TEND(int_state%DUDT,int_state%DT,int_state%NPHS,LM & - ,int_state%U) - CALL H_TO_V_TEND(int_state%DVDT,int_state%DT,int_state%NPHS,LM & - ,int_state%V) -! - td%h_to_v_tim=td%h_to_v_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Poles and East-West boundary. -!----------------------------------------------------------------------- -! - IF(int_state%GLOBAL)THEN - btim=timef() -! - CALL SWAPHN(int_state%T,IMS,IME,JMS,JME,LM,int_state%INPES) - CALL POLEHN(int_state%T,IMS,IME,JMS,JME,LM & - ,int_state%INPES,int_state%JNPES) -! - CALL SWAPHN(int_state%Q,IMS,IME,JMS,JME,LM,int_state%INPES) - CALL POLEHN(int_state%Q,IMS,IME,JMS,JME,LM & - ,int_state%INPES,int_state%JNPES) -! - CALL SWAPHN(int_state%CW,IMS,IME,JMS,JME,LM,int_state%INPES) - CALL POLEHN(int_state%CW,IMS,IME,JMS,JME,LM & - ,int_state%INPES,int_state%JNPES) -! - CALL SWAPHN(int_state%Q2,IMS,IME,JMS,JME,LM,int_state%INPES) - CALL POLEHN(int_state%Q2,IMS,IME,JMS,JME,LM & - ,int_state%INPES,int_state%JNPES) -! - CALL SWAPWN(int_state%U,IMS,IME,JMS,JME,LM,int_state%INPES) - CALL SWAPWN(int_state%V,IMS,IME,JMS,JME,LM,int_state%INPES) - CALL POLEWN(int_state%U,int_state%V,IMS,IME,JMS,JME,LM & - ,int_state%INPES,int_state%JNPES) -! - td%pole_swap_tim=td%pole_swap_tim+(timef()-btim) - ENDIF -! -!----------------------------------------------------------------------- -!*** Exchange wind components and TKE. -!----------------------------------------------------------------------- -! - btim=timef() -! - CALL HALO_EXCH(int_state%U,LM,int_state%V,LM & - ,2,2) -! - CALL HALO_EXCH(int_state%UZ0,1,int_state%VZ0,1 & - ,int_state%Q2,LM & - ,1,1) -! -!----------------------------------------------------------------------- -!*** Exchange other variables that are needed for parents' -!*** interpolations to interior points of moving nests. -!----------------------------------------------------------------------- -! - CALL HALO_EXCH(int_state%ALBEDO,1 & - ,int_state%EPSR,1 & - ,int_state%QSH,1 & - ,int_state%QWBS,1,1,1) - CALL HALO_EXCH(int_state%QZ0,1 & - ,int_state%SOILTB,1 & - ,int_state%THS,1 & - ,int_state%THZ0,1,1,1) - CALL HALO_EXCH(int_state%USTAR,1 & - ,int_state%UZ0,1 & - ,int_state%VZ0,1 & - ,int_state%Z0,1,1,1) - CALL HALO_EXCH(int_state%TSKIN,1 & - ,int_state%CMC,1,1,1) - CALL HALO_EXCH(int_state%SMC,NUM_SOIL_LAYERS & - ,int_state%SH2O,NUM_SOIL_LAYERS & - ,int_state%STC,NUM_SOIL_LAYERS,1,1) -! - td%exch_phy=td%exch_phy+(timef()-btim) -! -!----------------------------------------------------------------------- -! - ENDIF turbulence -! -!----------------------------------------------------------------------- -!*** Empty the accumulators of precipitation and latent heating if is -!*** is time prior to their being updated by convection/microphysics. -!----------------------------------------------------------------------- -! - IF(MOD(NTIMESTEP,int_state%NPREC)==0)THEN - DO J=JTS,JTE - DO I=ITS,ITE - int_state%ACPREC(I,J)=0. - int_state%CUPREC(I,J)=0. - ENDDO - ENDDO - ENDIF -! - IF(MOD(NTIMESTEP,int_state%NHEAT)==0)THEN - DO J=JTS,JTE - DO I=ITS,ITE - int_state%AVCNVC(I,J)=0. !- was a scalar, now 2D for ESMF - int_state%AVRAIN(I,J)=0. !- was a scalar, now 2D for ESMF - ENDDO - ENDDO -! - DO L=1,LM - DO J=JTS,JTE - DO I=ITS,ITE - int_state%TRAIN(I,J,L)=0. - int_state%TCUCN(I,J,L)=0. - do KK=1,int_state%d_ss - int_state%MPRATES(I,J,L,KK)=0. - enddo - ENDDO - ENDDO - ENDDO - ENDIF !-- IF(MOD(NTSD_BUCKET,NHEAT)==0)THEN -! -!----------------------------------------------------------------------- -!*** 1 of 3 calls to CLTEND, save Told array before convection & microphysics -!----------------------------------------------------------------------- -! - cld_tend1: IF(CALL_PRECIP .AND. int_state%NPRECIP>1) THEN - btim=timef() - ICLTEND=-1 - CALL CLTEND(ICLTEND,int_state%NPRECIP,int_state%T & - ,int_state%Told,int_state%Tadj & - ,IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE) - td%cltend_tim=td%cltend_tim+(timef()-btim) - ENDIF cld_tend1 -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** Convection -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - convection: IF(CALL_PRECIP.AND.int_state%CONVECTION/='none')THEN -! - btim=timef() -! write(*,*) 'DEBUG-GT, now calling CUCNVC ', btim -! -!----------------------------------------------------------------------- - IF(int_state%CONVECTION=='bmj' .OR. & - int_state%CONVECTION=='sas' .OR. & - int_state%CONVECTION=='scalecu' .OR. & - int_state%CONVECTION=='sashur') THEN -! - CALL CUCNVC(NTIMESTEP,int_state%DT,int_state%NPRECIP & - ,int_state%NRADS,int_state%NRADL & - ,int_state%MINUTES_HISTORY & - ,int_state%ENTRAIN,int_state%NEWALL & - ,int_state%NEWSWAP,int_state%NEWUPUP & - ,int_state%NODEEP & - ,int_state%FRES,int_state%FR & - ,int_state%FSL,int_state%FSS & - ,int_state%DYH,int_state%RESTART,int_state%HYDRO & - ,int_state%CLDEFI & - ,int_state%F_ICE,int_state%F_RAIN & - ,int_state%QC,int_state%QR & - ,int_state%QI,int_state%QS,int_state%QG & - ,int_state%F_QC,int_state%F_QR & - ,int_state%F_QI,int_state%F_QS,int_state%F_QG & - ,int_state%DSG2,int_state%SGML2,int_state%SG2 & - ,int_state%PDSG1,int_state%PSGML1,int_state%PSG1 & - ,int_state%DXH & - ,int_state%PT,int_state%PD & - ,int_state%T,int_state%Q & - ,int_state%CW,int_state%TCUCN & - ,int_state%OMGALF & - ,int_state%U,int_state%V & - ,int_state%FIS,int_state%W0AVG & - ,int_state%PREC,int_state%ACPREC & - ,int_state%CUPREC,int_state%ACPREC_TOT & - ,int_state%CUPPT,int_state%CPRATE & - ,int_state%CNVBOT,int_state%CNVTOP & - ,int_state%SM,int_state%LPBL & - ,int_state%HTOP,int_state%HTOPD,int_state%HTOPS & - ,int_state%HBOT,int_state%HBOTD,int_state%HBOTS & - ,int_state%AVCNVC,int_state%ACUTIM & - ,int_state%RSWIN,int_state%RSWOUT & - ,int_state%CONVECTION,int_state%CU_PHYSICS & - ,int_state%MICROPHYSICS & - ,int_state%SICE,int_state%QWBS,int_state%TWBS & - ,int_state%PBLH,int_state%DUDT,int_state%DVDT & -!!! added for SAS-hurricane - ,int_state%SAS_MOMMIX,int_state%SAS_PGCON & !hwrf,namelist - ,int_state%SAS_MASS_FLUX & !hwrf,namelist - ,int_state%SAS_SHALCONV,int_state%SAS_SHAL_PGCON & !hwrf,namelist - ,int_state%W_TOT,int_state%PSGDT & -!!! SAS-huricane - ,A2,A3,A4,CAPPA,CP,ELIV,ELWV,EPSQ,G & - ,P608,PQ0,R_D,TIW & - ,IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE & - ,ITS_B1,ITE_B1,JTS_B1,JTE_B1) -! - ELSE -! -! write(0,*)' Invalid selection for convection scheme' - STOP -! - ENDIF -! - td%cucnvc_tim=td%cucnvc_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Poles and East-West boundary. -!----------------------------------------------------------------------- -! - IF(int_state%GLOBAL)THEN - btim=timef() -! - CALL SWAPHN(int_state%T,IMS,IME,JMS,JME,LM,int_state%INPES) - CALL POLEHN(int_state%T,IMS,IME,JMS,JME,LM & - ,int_state%INPES,int_state%JNPES) -! - CALL SWAPHN(int_state%Q,IMS,IME,JMS,JME,LM,int_state%INPES) - CALL POLEHN(int_state%Q,IMS,IME,JMS,JME,LM & - ,int_state%INPES,int_state%JNPES) -! - td%pole_swap_tim=td%pole_swap_tim+(timef()-btim) - ENDIF -! -!----------------------------------------------------------------------- -!*** Exchange wind tendencies for SAS and bmj schemes. -!----------------------------------------------------------------------- -! - wind: IF (int_state%CONVECTION=='sas' .or. & - int_state%CONVECTION=='bmj') THEN !zj -! -!----------------------------------------------------------------------- -! - btim=timef() - CALL HALO_EXCH(int_state%DUDT,LM,int_state%DVDT,LM,1,1) - td%exch_phy=td%exch_phy+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Now interpolate wind tendencies from H to V points. -!----------------------------------------------------------------------- -! - btim=timef() - CALL H_TO_V_TEND(int_state%DUDT,int_state%DT & - ,int_state%NPRECIP,LM & - ,int_state%U) - CALL H_TO_V_TEND(int_state%DVDT,int_state%DT & - ,int_state%NPRECIP,LM & - ,int_state%V) - td%h_to_v_tim=td%h_to_v_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Poles and East-West boundary. -!----------------------------------------------------------------------- -! - IF(int_state%GLOBAL)THEN - btim=timef() -! - CALL SWAPWN(int_state%U,IMS,IME,JMS,JME,LM & - ,int_state%INPES) - CALL SWAPWN(int_state%V,IMS,IME,JMS,JME,LM & - ,int_state%INPES) - CALL POLEWN(int_state%U,int_state%V,IMS,IME,JMS,JME,LM & - ,int_state%INPES,int_state%JNPES) -! - td%pole_swap_tim=td%pole_swap_tim+(timef()-btim) - ENDIF -! -!----------------------------------------------------------------------- -!*** Exchange wind components. -!----------------------------------------------------------------------- -! - btim=timef() - CALL HALO_EXCH(int_state%U,LM,int_state%V,LM & - ,2,2) - td%exch_phy=td%exch_phy+(timef()-btim) -! -!----------------------------------------------------------------------- -! - ENDIF wind -! -!----------------------------------------------------------------------- -! - ENDIF convection -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** Microphysics -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - microphysics: IF(CALL_PRECIP)THEN -! - btim=timef() -! write(*,*) 'DEBUG-GT, now calling GSMDRIVE ', btim -! - CALL GSMDRIVE(NTIMESTEP,int_state%DT & - ,NPRECIP & - ,int_state%DXH(JC),int_state%DYH & - ,int_state%SM,int_state%FIS & - ,int_state%DSG2,int_state%SGML2 & - ,int_state%PDSG1,int_state%PSGML1 & - ,int_state%PT,int_state%PD & - ,int_state%T,int_state%Q & - ,int_state%CW,int_state%OMGALF & - ,int_state%TRAIN,int_state%SR & - ,int_state%F_ICE,int_state%F_RAIN,int_state%F_RIMEF & - ,int_state%QC,int_state%QR & - ,int_state%QI,int_state%QS,int_state%QG & - ,int_state%NI,int_state%NR & ! G. Thompson - ,int_state%F_QC,int_state%F_QR & - ,int_state%F_QI,int_state%F_QS,int_state%F_QG & - ,int_state%F_NI,int_state%F_NR & ! G. Thompson - ,int_state%PREC,int_state%ACPREC & - ,int_state%AVRAIN,int_state%ACPREC_TOT & - ,int_state%acpcp_ra,int_state%acpcp_sn,int_state%acpcp_gr & ! G. Thompson - ,int_state%refl_10cm & ! G. Thompson - ,int_state%re_cloud,int_state%re_ice,int_state%re_snow & ! G. Thompson - ,int_state%has_reqc,int_state%has_reqi,int_state%has_reqs & ! G. Thompson - ,int_state%MP_RESTART_STATE & - ,int_state%TBPVS_STATE,int_state%TBPVS0_STATE & - ,int_state%SPECIFIED,int_state%NESTED & - ,int_state%MICROPHYSICS & - ,int_state%RHGRD & ! fer_hires only - ,int_state%TP1 & !gfs mod-brad - ,int_state%QP1 & !gfs mod-brad - ,int_state%PSP1 & !gfs mod-brad - ,USE_RADAR & - ,int_state%DFI_TTEN & - ,IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE & - ,ITS_B1,ITE_B1,JTS_B1,JTE_B1,int_state%MPRATES & - ,int_state%D_SS) -! - td%gsmdrive_tim=td%gsmdrive_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** 2 of 3 calls to CLTEND, calculate Tadj and replace T with Told -!----------------------------------------------------------------------- -! - cld_tend2: IF(int_state%NPRECIP>1) THEN - btim=timef() - ICLTEND=0 - CALL CLTEND(ICLTEND,int_state%NPRECIP,int_state%T & - ,int_state%Told,int_state%Tadj & - ,IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE) - td%cltend_tim=td%cltend_tim+(timef()-btim) - ENDIF cld_tend2 -! -!----------------------------------------------------------------------- -!*** Precipitation Assimilation -!----------------------------------------------------------------------- -! - IF (int_state%PCPFLG .and. FILTER_METHOD == 0) THEN -! - btim=timef() - CALL CHKSNOW(MYPE & - ,int_state%NTSD & - ,int_state%DT & - ,int_state%NPHS & - ,int_state%SR & - ,int_state%PPTDAT & - ,int_state%PCPHR & - ,IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE & - ,ITS_B1,ITE_B1,JTS_B2,JTE_B2) -! - CALL ADJPPT(MYPE & - ,int_state%NTSD & - ,int_state%DT & - ,int_state%NPHS & - ,int_state%PREC & - ,int_state%LSPA & - ,int_state%PPTDAT & - ,int_state%DDATA & - ,int_state%PCPHR & - ,IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE & - ,ITS_B1,ITE_B1,JTS_B2,JTE_B2) -! - td%adjppt_tim=td%adjppt_tim+(timef()-btim) -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Poles and East-West boundary. -!----------------------------------------------------------------------- -! - IF(int_state%GLOBAL)THEN - btim=timef() -! -!bsf: Apply these after last (3rd) call to CLTEND below -! -! CALL SWAPHN(int_state%T,IMS,IME,JMS,JME,LM,int_state%INPES) -! CALL POLEHN(int_state%T,IMS,IME,JMS,JME,LM & -! ,int_state%INPES,int_state%JNPES) -! - CALL SWAPHN(int_state%Q,IMS,IME,JMS,JME,LM,int_state%INPES) - CALL POLEHN(int_state%Q,IMS,IME,JMS,JME,LM & - ,int_state%INPES,int_state%JNPES) -! - CALL SWAPHN(int_state%CW,IMS,IME,JMS,JME,LM,int_state%INPES) - CALL POLEHN(int_state%CW,IMS,IME,JMS,JME,LM & - ,int_state%INPES,int_state%JNPES) -! - td%pole_swap_tim=td%pole_swap_tim+(timef()-btim) - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF microphysics -! -!----------------------------------------------------------------------- -!*** 3 of 3 calls to CLTEND, incremental updates of T using Told & Tadj -!----------------------------------------------------------------------- -! - cld_tend3: IF(int_state%NPRECIP>1) THEN - btim=timef() - ICLTEND=1 - CALL CLTEND(ICLTEND,int_state%NPRECIP,int_state%T & - ,int_state%Told,int_state%Tadj & - ,IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE) - td%cltend_tim=td%cltend_tim+(timef()-btim) - ENDIF cld_tend3 -! -!----------------------------------------------------------------------- -!*** Prevent supersaturation w/r/t water and smooth temperature profiles -! if lapse rates are steeper than dry adiabatic above lowest levels. -!----------------------------------------------------------------------- -! - btim=timef() - CALL TQADJUST(int_state%T,int_state%Q,int_state%QC & - ,int_state%CW,int_state%F_ICE,int_state%F_RAIN & - ,int_state%PD,int_state%DSG2,int_state%PDSG1 & - ,int_state%PSGML1,int_state%SGML2 & - ,int_state%SPEC_ADV,int_state%RHGRD & - ,IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE) - td%tqadjust_tim=td%tqadjust_tim+(timef()-btim) -! -!bsf: Call SWAPHN & POLEHN for temperature here after temperature update -! - IF(int_state%GLOBAL)THEN - btim=timef() -! - CALL SWAPHN(int_state%T,IMS,IME,JMS,JME,LM,int_state%INPES) - CALL POLEHN(int_state%T,IMS,IME,JMS,JME,LM & - ,int_state%INPES,int_state%JNPES) - td%pole_swap_tim=td%pole_swap_tim+(timef()-btim) - ENDIF -! -!----------------------------------------------------------------------- -!*** Exchange T, Q, CW now every timestep; also QC for species advection -!----------------------------------------------------------------------- -! - btim=timef() - CALL HALO_EXCH(int_state%T,LM,2,2) - CALL HALO_EXCH(int_state%Q,LM,int_state%CW,LM,2,2) - IF(int_state%SPEC_ADV) THEN - CALL HALO_EXCH(int_state%QC,LM,2,2) -! -!----------------------------------------------------------------------- -!*** Exchange various cloud species for separate species advection -!----------------------------------------------------------------------- -! - IF(CALL_PRECIP .OR. CALL_TURBULENCE) THEN - IF(int_state%F_QR) CALL HALO_EXCH(int_state%QR,LM,2,2) - IF(int_state%F_QS) CALL HALO_EXCH(int_state%QS,LM,2,2) - IF(int_state%F_QI) CALL HALO_EXCH(int_state%QI,LM,2,2) - IF(int_state%F_QG) CALL HALO_EXCH(int_state%QG,LM,2,2) - IF(int_state%F_NI) CALL HALO_EXCH(int_state%NI,LM,2,2) - IF(int_state%F_NR) CALL HALO_EXCH(int_state%NR,LM,2,2) - ENDIF - ENDIF - td%exch_phy=td%exch_phy+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** NOTE: The Physics export state is fully updated now -!*** because subroutine PHY_INITIALIZE inserted the -!*** appropriate ESMF Fields into it. Those Fields -!*** contain pointers to the actual data and those -!*** pointers are never re-directed. -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - ELSE gfs_phys_test !<-- Use GFS physics package -#if 1 - WRITE(0,*)'Init of GFS phys in NMMB disabled, 20140812, jm' - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT & - ,rc =RC) -#else -! -!----------------------------------------------------------------------- -! -!####################################################################### -!####################################################################### -!############ G F S P H Y S I C S D R I V E R ###################### -!####################################################################### -!####################################################################### -! - btim=timef() -! - ALLOCATE(LONSPERLAR(JTS:JTE)) - ALLOCATE(NLNSP(JTS:JTE)) - ALLOCATE(GLOBAL_LATS_R(JTS:JTE)) - ALLOCATE(CLDCOV_V(LM)) - ALLOCATE(PRSL(LM)) - ALLOCATE(PRSLK(LM)) - ALLOCATE(GU(LM)) - ALLOCATE(GV(LM)) - ALLOCATE(GT(LM)) - ALLOCATE(GR(LM)) - ALLOCATE(VVEL(LM)) - ALLOCATE(F_ICE(LM)) - ALLOCATE(F_RAIN(LM)) - ALLOCATE(R_RIME(LM)) - ALLOCATE(ADT(LM)) - ALLOCATE(ADU(LM)) - ALLOCATE(ADV(LM)) - ALLOCATE(PHIL(LM)) - ALLOCATE(GR3(LM,NTRAC)) - ALLOCATE(ADR(LM,NTRAC)) - ALLOCATE(PRSI(LM+1)) - ALLOCATE(PRSIK(LM+1)) - ALLOCATE(RSGM(LM+1)) - ALLOCATE(PHII(LM+1)) - ALLOCATE(SINLAT_R(JTS:JTE)) - ALLOCATE(COSLAT_R(JTS:JTE)) - ALLOCATE(XLON(ITS:ITE,JTS:JTE)) - ALLOCATE(COSZEN(ITS:ITE,JTS:JTE)) - ALLOCATE(COSZDG(ITS:ITE,JTS:JTE)) - ALLOCATE(SINLAT_V(ITS:ITE,JTS:JTE)) - ALLOCATE(COSLAT_V(ITS:ITE,JTS:JTE)) - ALLOCATE(RANN(ITS:ITE,JTS:JTE)) - ALLOCATE(RANNUM((ITE-ITS+1)*(JTE-JTS+1))) - ALLOCATE(GR1(1,LM,NTRAC-1)) - ALLOCATE(SWH(LM)) - ALLOCATE(HLW(LM)) - ALLOCATE(DKH(LM)) - ALLOCATE(RNP(LM)) - ALLOCATE(UPD_MF(LM)) - ALLOCATE(DWN_MF(LM)) - ALLOCATE(DET_MF(LM)) - ALLOCATE(DQDT(LM)) - ALLOCATE(DQ3DT(LM,9)) - ALLOCATE(DT3DT(LM,6)) - ALLOCATE(DU3DT(LM,4)) - ALLOCATE(DV3DT(LM,4)) - ALLOCATE(PHY_F3DV(LM,4)) -! - CALL ESMF_ClockGet(clock =CLOCK_ATM & !<-- The ESMF Clock - ,currTime =CURRTIME & !<-- The current time (ESMF) on the clock - ,rc =RC) -! - CALL ESMF_TimeGet(time=CURRTIME & !<-- The cuurent forecast time (ESMF) - ,yy =JDAT(1) & !<-- The current forecast year (integer) - ,mm =JDAT(2) & !<-- The current forecast month (integer) - ,dd =JDAT(3) & !<-- The current forecast day (integer) - ,h =JDAT(5) & !<-- The current forecast hour (integer) - ,m =JDAT(6) & !<-- The current forecast minute (integer) - ,s =JDAT(7) & !<-- The current forecast second (integer) - ,rc =RC) - JDAT(4)=0 - JDAT(8)=0 -! - DO J=JTS,JTE - GLOBAL_LATS_R(J) = J-JTS+1 - LONSPERLAR(J) = ITE-ITS+1 - SINLAT_R(J) = SIN(int_state%GLAT( (ITS+ITE)/2 ,J)) - COSLAT_R(J) = SQRT( 1.d0 - SINLAT_R(J)*SINLAT_R(J) ) - DO I=ITS,ITE - XLON(I,J) = int_state%GLON(I,J) - IF(int_state%GLON(I,J)<0) & - XLON(I,J) = 2.0d0*3.14159d0+XLON(I,J) - COSZEN(I,J) = int_state%CZEN(I,J) - COSZDG(I,J) = int_state%CZMEAN(I,J) - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** GFS Radiation -!----------------------------------------------------------------------- -! - CALL_GFS_PHY = MOD(NTIMESTEP,int_state%NPHS)==0 - - FHSWR = FLOAT(int_state%NRADS)*int_state%DT/3600. ! [h] - LSCCA = MOD(NTIMESTEP+1,int_state%NRADS)==0 ! logical true during a step for which convective clouds - ! are calculated from convective precipitation rates - LSSWR = MOD(NTIMESTEP,int_state%NRADS)==0 - LSLWR = MOD(NTIMESTEP,int_state%NRADL)==0 -! -!----------------------------------------------------------------------- - lw_or_sw: IF (LSSWR .OR. LSLWR ) THEN -!----------------------------------------------------------------------- -! - DO L=1,LM+1 - KFLIP=LM-L+2 - RSGM(KFLIP)=int_state%SGM(L) - ENDDO -! - ICWP=0 ! control flag for cloud generation schemes - IF (NTCW > 0) ICWP = 1 ! 0: use diagnostic cloud scheme - ! 1: use prognostic cloud scheme (default) -! -! ---- -!rv - find IOVR_SW,IOVR_LW,isubc_sw, isubc_lw - CALL RADINIT_gfs ( RSGM, LM, IFLIP, IDAT, JDAT, ICTM, ISOL, ICO2, & - IAER, IALB, IEMS, ICWP, NUM_P3D, 0, 0, & - 0, 0, MYPE, RADDT, FDAER ) -! ---- - - IF (NTOZ .LE. 0) THEN ! Climatological Ozone -! - IDAY = JDAT(3) - IMON = JDAT(2) - MIDMON = DAYS(IMON)/2 + 1 - CHANGE = FIRST .OR. ( (IDAY .EQ. MIDMON) .AND. (JDAT(5).EQ.0) ) -! - IF (CHANGE) THEN - IF (IDAY .LT. MIDMON) THEN - K1OZ = MOD(IMON+10,12) + 1 - MIDM = DAYS(K1OZ)/2 + 1 - K2OZ = IMON - MIDP = DAYS(K1OZ) + MIDMON - ELSE - K1OZ = IMON - MIDM = MIDMON - K2OZ = MOD(IMON,12) + 1 - MIDP = DAYS(K2OZ)/2 + 1 + DAYS(K1OZ) - ENDIF - ENDIF -! - IF (IDAY .LT. MIDMON) THEN - ID = IDAY + DAYS(K1OZ) - ELSE - ID = IDAY - ENDIF -! - FACOZ = REAL (ID-MIDM) / REAL (MIDP-MIDM) -! - ELSE -! - K1OZ = 0 - K2OZ = 0 - FACOZ = 1.0D0 -! - ENDIF -! - FLGMIN_L(1) = 0.2D0 ! --- for ferrier (for now, any number) - - DO J=JTS,JTE - DO I=ITS,ITE - SINLAT_V(I,J) = SINLAT_R(J) - COSLAT_V(I,J) = COSLAT_R(J) - ENDDO - ENDDO - DO J=JTS,JTE - NLNSP(J) = LONR - ENDDO - - -! ---- - CALL ASTRONOMY & -! --- inputs: - ( SINLAT_V, COSLAT_V, XLON, FHSWR, JDAT, & - LONR, LATS_NODE_R, NLNSP, LSSWR, MYPE, & -! --- outputs: - int_state%SOLCON, int_state%SLAG, int_state%SDEC, & - int_state%CDEC, COSZEN, COSZDG ) -! -!----------------------------------------------------------------------- -! - ENDIF lw_or_sw -! -!----------------------------------------------------------------------- -! -!--- - IF (FIRST) THEN -! - SEED0 = JDAT(4) + JDAT(3) + JDAT(2) + JDAT(1) - CALL RANDOM_SETSEED(SEED0) - CALL RANDOM_NUMBER(WRK) - SEED0 = SEED0 + NINT(WRK(1)*1000.0) - FIRST = .FALSE. -! - ENDIF -!--- - FHOUR=NTIMESTEP*int_state%DT/3600.d0 - ISEED = MOD(100.0*SQRT(FHOUR*3600),1.0d9) + 1 + SEED0 - CALL RANDOM_SETSEED(ISEED) - CALL RANDOM_NUMBER(RANNUM) - N=0 -! - DO J=JTS,JTE - DO I=ITS,ITE - N=N+1 - RANN(I,J) = RANNUM(N) - ENDDO - ENDDO -!--- - DTF=int_state%NPHS*int_state%DT - DTP=int_state%NPHS*int_state%DT -!--- - SOLHR=MOD(FHOUR+START_HOUR,24.d0) -!--- -!... set switch for saving convective clouds - IF(LSCCA.AND.LSSWR) THEN - CLSTP=1100+MIN(FHSWR,FHOUR,99.d0) !initialize,accumulate,convert - ELSEIF(LSCCA) THEN - CLSTP=0100+MIN(FHSWR,FHOUR,99.d0) !accumulate,convert - ELSEIF(LSSWR) THEN - CLSTP=1100 !initialize,accumulate - ELSE - CLSTP=0100 !accumulate - ENDIF -!--- -!---- OZONE ------------------------------------------------------------ -! - IF(.NOT.ALLOCATED(OZPLOUT_V)) & - ALLOCATE (OZPLOUT_V(LEVOZP, PL_COEFF)) - IF(.NOT.ALLOCATED(OZPLOUT )) & - ALLOCATE (OZPLOUT (LEVOZP,JTS:JTE,PL_COEFF)) -! - IDATE(1)=JDAT(5) - IDATE(2)=JDAT(2) - IDATE(3)=JDAT(3) - IDATE(4)=JDAT(1) -! - IF (NTOZ .GT. 0) THEN - CALL OZINTERPOL(MYPE,LATS_NODE_R,LATS_NODE_R,IDATE,FHOUR, & - int_state%JINDX1,int_state%JINDX2, & - int_state%OZPLIN,OZPLOUT,int_state%DDY) - ENDIF -! -!---- OZONE ------------------------------------------------------------ -!----------------------------------------------------------------------- -!*** Set diagnostics to 0. -!----------------------------------------------------------------------- -! - DT3DT=0.0d0 - DU3DT=0.0d0 - DV3DT=0.0d0 - DQ3DT=0.0d0 -! - CV (1) = 0.d0 !!!!! not in use if ntcw-1 > 0 - CVB(1) = 0.d0 !!!!! not in use if ntcw-1 > 0 - CVT(1) = 0.d0 !!!!! not in use if ntcw-1 > 0 -! -!----------------------------------------------------------------------- -!*** Empty the radiation flux and precipitation arrays if it is time. -!----------------------------------------------------------------------- -! - IF(MOD(NTIMESTEP,int_state%NRDLW)==0)THEN -! - DO J=JTS,JTE - DO I=ITS,ITE - int_state%ALWIN(I,J) =0. - int_state%ALWOUT(I,J)=0. - int_state%ALWTOA(I,J)=0. - int_state%ARDLW (I,J)=0. !<-- An artificial 2-D array (ESMF - !<-- cannot have evolving scalar Attributes) - ENDDO - ENDDO -! - ENDIF -! - IF(MOD(NTIMESTEP,int_state%NRDSW)==0)THEN -! - DO J=JTS,JTE - DO I=ITS,ITE - int_state%ASWIN(I,J)=0. - int_state%ASWOUT(I,J)=0. - int_state%ASWTOA(I,J)=0. - int_state%ARDSW (I,J)=0. !<-- An artificial 2-D array (ESMF - !<-- cannot have evolving scalar Attributes) - ENDDO - ENDDO -! - ENDIF -! - IF(MOD(NTIMESTEP,int_state%NSRFC)==0)THEN -! - DO J=JTS,JTE - DO I=ITS,ITE - int_state%ACSNOW(I,J)=0. - int_state%POTEVP(I,J)=0. - int_state%SFCEVP(I,J)=0. - int_state%SFCLHX(I,J)=0. - int_state%SFCSHX(I,J)=0. - int_state%SUBSHX(I,J)=0. - int_state%BGROFF(I,J)=0. - int_state%SSROFF(I,J)=0. - int_state%ASRFC (I,J)=0. !<-- An artificial 2-D array (ESMF - !<-- cannot have evolving scalar Attributes) - ENDDO - ENDDO -! - ENDIF -! - IF(MOD(NTIMESTEP,int_state%NPREC)==0)THEN - DO J=JTS,JTE - DO I=ITS,ITE - int_state%ACPREC(I,J)=0. - int_state%CUPREC(I,J)=0. - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- - gfs_physics: IF(CALL_GFS_PHY)THEN -#if 1 - WRITE(0,*)' GFS physics option in NMMB disabled, 20140812, jm' - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT & - ,rc =RC) -#else -!----------------------------------------------------------------------- -! - DTLW = FLOAT(int_state%NRADL)*int_state%DT ! [s] - DTSW = FLOAT(int_state%NRADS)*int_state%DT ! [s] - RADDT = MIN(DTSW,DTLW) - DTLWI = 1./DTLW - DTSWI = 1./DTSW - MINDT = 1./MIN(DTLW,DTSW) - DTPHS = int_state%NPHS*int_state%DT - DTPHSI = 1./DTPHS - XLVRW = XLV*RHOWATER - XLVRWI = 1./XLVRW - RoCP = R/CP - LSSAV_CC = LSSAV - LSSAV_CPL= LSSAV - IDE_GR = IDE-1 - IF(int_state%GLOBAL) IDE_GR = IDE-3 -! -!----------------------------------------------------------------------- -! *** MAIN GFS-PHYS DOMAIN LOOP -!----------------------------------------------------------------------- -! - j_loop: DO J=JTS,JTE -! - i_loop: DO I=ITS,ITE -! - int_state%ACUTIM(I,J) = int_state%ACUTIM(I,J) + 1. ! advance counters - int_state%APHTIM(I,J) = int_state%APHTIM(I,J) + 1. - int_state%ARDLW(I,J) = int_state%ARDLW(I,J) + 1. - int_state%ARDSW(I,J) = int_state%ARDSW(I,J) + 1. - int_state%ASRFC(I,J) = int_state%ASRFC(I,J) + 1. - int_state%AVRAIN(I,J) = int_state%AVRAIN(I,J) + 1. - int_state%AVCNVC(I,J) = int_state%AVCNVC(I,J) + 1. -! - T1(1) = 0.0D0 ! initialize all local variables - Q1(1) = 0.0D0 ! used in gfs_physics - U1(1) = 0.0D0 - V1(1) = 0.0D0 - QSS(1) = 0.0D0 - CDQ(1) = 0.0D0 - HFLX(1) = 0.0D0 - EVAP(1) = 0.0D0 - DTSFC(1) = 0.0D0 - DQSFC(1) = 0.0D0 - DUSFC(1) = 0.0D0 - DVSFC(1) = 0.0D0 - PSMEAN(1) = 0.0D0 - EPI(1) = 0.0D0 - EVBSA(1) = 0.0D0 - EVCWA(1) = 0.0D0 - TRANSA(1) = 0.0D0 - SBSNOA(1) = 0.0D0 - SOILM(1) = 0.0D0 - SNOWCA(1) = 0.0D0 - DLWSFC_CC(1) = 0.0D0 - ULWSFC_CC(1) = 0.0D0 - DTSFC_CC(1) = 0.0D0 - SWSFC_CC(1) = 0.0D0 - DUSFC_CC(1) = 0.0D0 - DVSFC_CC(1) = 0.0D0 - DQSFC_CC(1) = 0.0D0 - PRECR_CC(1) = 0.0D0 - DUSFC_CPL(1) = 0.0D0 - DVSFC_CPL(1) = 0.0D0 - DTSFC_CPL(1) = 0.0D0 - DQSFC_CPL(1) = 0.0D0 - DLWSFC_CPL(1) = 0.0D0 - DSWSFC_CPL(1) = 0.0D0 - DNIRBM_CPL(1) = 0.0D0 - DNIRDF_CPL(1) = 0.0D0 - DVISBM_CPL(1) = 0.0D0 - DVISDF_CPL(1) = 0.0D0 - NLWSFC_CPL(1) = 0.0D0 - NSWSFC_CPL(1) = 0.0D0 - NNIRBM_CPL(1) = 0.0D0 - NNIRDF_CPL(1) = 0.0D0 - NVISBM_CPL(1) = 0.0D0 - NVISDF_CPL(1) = 0.0D0 - RAIN_CPL(1) = 0.0D0 - XT(1) = 0.0D0 - XS(1) = 0.0D0 - XU(1) = 0.0D0 - XV(1) = 0.0D0 - XZ(1) = 0.0D0 - ZM(1) = 0.0D0 - XTTS(1) = 0.0D0 - XZTS(1) = 0.0D0 - D_CONV(1) = 0.0D0 - IFD(1) = 0.0D0 - DT_COOL(1) = 0.0D0 - QRAIN(1) = 0.0D0 - XMU_CC(1) = 0.0D0 - DLW_CC(1) = 0.0D0 - DSW_CC(1) = 0.0D0 - SNW_CC(1) = 0.0D0 - LPREC_CC(1) = 0.0D0 - DUSFCI_CPL(1) = 0.0D0 - DVSFCI_CPL(1) = 0.0D0 - DTSFCI_CPL(1) = 0.0D0 - DQSFCI_CPL(1) = 0.0D0 - DLWSFCI_CPL(1) = 0.0D0 - DSWSFCI_CPL(1) = 0.0D0 - DNIRBMI_CPL(1) = 0.0D0 - DNIRDFI_CPL(1) = 0.0D0 - DVISBMI_CPL(1) = 0.0D0 - DVISDFI_CPL(1) = 0.0D0 - NLWSFCI_CPL(1) = 0.0D0 - NSWSFCI_CPL(1) = 0.0D0 - NNIRBMI_CPL(1) = 0.0D0 - NNIRDFI_CPL(1) = 0.0D0 - NVISBMI_CPL(1) = 0.0D0 - NVISDFI_CPL(1) = 0.0D0 - T2MI_CPL(1) = 0.0D0 - Q2MI_CPL(1) = 0.0D0 - U10MI_CPL(1) = 0.0D0 - V10MI_CPL(1) = 0.0D0 - TSEAI_CPL(1) = 0.0D0 - PSURFI_CPL(1) = 0.0D0 - ORO_CPL(1) = 0.0D0 - SLMSK_CPL(1) = 0.0D0 - TREF(1) = 0.0D0 - Z_C(1) = 0.0D0 - C_0(1) = 0.0D0 - C_D(1) = 0.0D0 - W_0(1) = 0.0D0 - W_D(1) = 0.0D0 - RQTK(1) = 0.0D0 - SNOHFA(1) = 0.0D0 - SMCWLT2(1) = 0.0D0 - SMCREF2(1) = 0.0D0 - WET1(1) = 0.0D0 - GSOIL(1) = 0.0D0 - GTMP2M(1) = 0.0D0 - GUSTAR(1) = 0.0D0 - GPBLH(1) = 0.0D0 - GU10M(1) = 0.0D0 - GV10M(1) = 0.0D0 - GZORL(1) = 0.0D0 - GORO(1) = 0.0D0 - SR(1) = 0.0D0 - SPFHMIN(1) = 0.0D0 - SPFHMAX(1) = 0.0D0 - CLDWRK(1) = 0.0D0 - ZLVL(1) = 0.0D0 - PHII = 0.0D0 - PHIL = 0.0D0 - CHH(1) = 0.0D0 - HPBL(1) = 0.0D0 - PSURF(1) = 100000.0D0 - T2M(1) = 273.0D0 - Q2M(1) = 0.0D0 - U10M(1) = 0.0D0 - V10M(1) = 0.0D0 - ADR = 0.0D0 - ADT = 0.0D0 - ADU = 0.0D0 - ADV = 0.0D0 - SUNTIM = 0.0D0 - ICSDSW(1) = 0 - ICSDLW(1) = 0 - - IF(int_state%TSKIN(I,J) .LT. 50. ) THEN - TSEA(1) = int_state%SST(I,J) - TISFC(1) = int_state%SST(I,J) - ELSE - TSEA(1) = int_state%TSKIN(I,J) - TISFC(1) = int_state%TSKIN(I,J) - ENDIF - - IF(int_state%SICE(I,J) > 0.5 ) THEN ! slmsk - ocean - 0 - SLMSK(1) = 2.0D0 ! land - 1 - ELSE ! seaice - 2 - SLMSK(1) = 1.0D0-int_state%SM(I,J) ! - ENDIF - - DO L=1,LM - KFLIP=LM+1-L -! CLDCOV_V(KFLIP) = 0.0D0 ! GRRAD now returns instant cloud cover (Sarah Lu) - F_ICE(KFLIP) = int_state%F_ICE(I,J,L) ! for ferrier phy, do init first - F_RAIN(KFLIP) = int_state%F_RAIN(I,J,L) - R_RIME(KFLIP) = int_state%F_RIMEF(I,J,L) - ENDDO - - XLAT(1) = int_state%GLAT(I,J) - ZORL(1) = int_state%ZORFCS(I,J) - SNCOVR(1) = int_state%SNO(I,J)/(int_state%SNO(I,J)+70.) ! FORMULATION OF MARSHALL ET AL. 1994 - ! change this later only initially, add new int_state - SNWDPH(1) = int_state%SI(I,J) ! snwdph[mm] - WEASD(1) = int_state%SNO(I,J) ! snow water eq.[mm] - SNOALB(1) = int_state%MXSNAL(I,J) - ALVSF(1) = int_state%ALBFC1(I,J,1) ! VIS, direct - ALVWF(1) = int_state%ALBFC1(I,J,2) ! VIS, diffuse - ALNSF(1) = int_state%ALBFC1(I,J,3) ! NIR, direct - ALNWF(1) = int_state%ALBFC1(I,J,4) ! NIR, diffuse - FACSF(1) = int_state%ALFFC1(I,J,1) ! direct - FACWF(1) = int_state%ALFFC1(I,J,2) ! diffuse -! - PRSI (LM+1) = int_state%PT ! [ Pa] - PRSIK(LM+1) = (PRSI(LM+1)*0.00001d0)**RoCP - DO L=1,LM - KFLIP=LM+1-L - PRSI (KFLIP) = PRSI(KFLIP+1) + & - (int_state%DSG2(L)*int_state%PD(I,J)+int_state%PDSG1(L)) ! (pressure on interface) [ Pa] - PRSIK(KFLIP) = (PRSI(KFLIP)*0.00001d0)**RoCP - - PRSL (KFLIP) = (PRSI(KFLIP)+PRSI(KFLIP+1))*0.5d0 ! (pressure on mid-layer) [kPa] - PRSLK(KFLIP) = (PRSL(KFLIP)*0.00001d0)**RoCP -! - RTvR = 1. / ( R * (int_state%Q(I,J,L)*0.608+1.-int_state%CW(I,J,L) ) * int_state%T(I,J,L) ) - VVEL(KFLIP) = int_state%OMGALF(I,J,L) * PRSL(KFLIP) * RTvR -! - GU(KFLIP) = (int_state%U(I,J ,L) + int_state%U(I-1,J ,L) + & - int_state%U(I,J-1,L) + int_state%U(I-1,J-1,L))*0.25d0 - GV(KFLIP) = (int_state%V(I,J ,L) + int_state%V(I-1,J ,L) + & - int_state%V(I,J-1,L) + int_state%V(I-1,J-1,L))*0.25d0 - GT(KFLIP) = int_state%T(I,J,L) - GR(KFLIP) = int_state%Q(I,J,L) - GR3(KFLIP,1) = int_state%Q(I,J,L) - IF (NTIMESTEP == 0 ) THEN - GR3(KFLIP,2) = 0.0d0 - GR3(KFLIP,3) = 0.0d0 - ELSE - GR3(KFLIP,2) = int_state%O3(I,J,L) - GR3(KFLIP,3) = int_state%CW(I,J,L) - ENDIF - GR1(1,KFLIP,1) = GR3(KFLIP,2) - GR1(1,KFLIP,2) = int_state%CW(I,J,L) - ENDDO -!--- - DLWSFC(1) = int_state%ALWIN(I,J) - ULWSFC(1) = int_state%ALWOUT(I,J) - DLWSFCI(1) = int_state%RLWIN(I,J) - ULWSFCI(1) = int_state%RADOT(I,J) - DSWSFCI(1) = int_state%RSWIN(I,J) - USWSFCI(1) = int_state%RSWOUT(I,J) -!--- - GFLUX(1) = 0.0D0 - DQSFCI(1) = 0.0D0 - DTSFCI(1) = 0.0D0 - GFLUXI(1) = 0.0D0 - EP(1) = int_state%POTEVP(I,J)*XLVRW -!--- - XSIHFCS(1) = int_state%SIHFCS(I,J) - XSICFCS(1) = int_state%SICFCS(I,J) - XSLPFCS(1) = int_state%SLPFCS(I,J) - XTG3FCS(1) = int_state%TG3FCS(I,J) - XVEGFCS(1) = int_state%VEGFCS(I,J) - XVETFCS(1) = int_state%VETFCS(I,J) - XSOTFCS(1) = int_state%SOTFCS(I,J) -!--- - FLUXR_V = 0.0D0 - IF(.NOT.LSLWR) FLUXR_V(1) = int_state%RLWTOA(I,J)*DTLW - IF(.NOT.LSSWR) FLUXR_V(2) = int_state%RSWTOA(I,J)*DTSW -!--- - HPRIME (1) = int_state%HSTDV(I,J) - HPRIME (2) = int_state%HCNVX(I,J) - HPRIME (3) = int_state%HASYW(I,J) - HPRIME (4) = int_state%HASYS(I,J) - HPRIME (5) = int_state%HASYSW(I,J) - HPRIME (6) = int_state%HASYNW(I,J) - HPRIME (7) = int_state%HLENW(I,J) - HPRIME (8) = int_state%HLENS(I,J) - HPRIME (9) = int_state%HLENSW(I,J) - HPRIME(10) = int_state%HLENNW(I,J) - HPRIME(11) = int_state%HANGL(I,J)*180.D0/3.14159D0 - HPRIME(12) = int_state%HANIS(I,J) - HPRIME(13) = int_state%HSLOP(I,J) - HPRIME(14) = int_state%HZMAX(I,J) -!--- - RUNOFF(1) = int_state%BGROFF(I,J)*0.001D0 - SRUNOFF(1) = int_state%SSROFF(I,J)*0.001D0 -!--- - DO L=1,LM - KFLIP=LM+1-L - DKH(L) = 0.0D0 - RNP(L) = 0.0D0 - SWH(KFLIP) = int_state%RSWTT(I,J,L) - HLW(KFLIP) = int_state%RLWTT(I,J,L) - ENDDO - DO N=1,3 ! for Zhao =3, Ferr=1 - PHY_F2DV(N) = int_state%PHY_F2DV (I,J,N) - ENDDO - DO N=1,4 ! for Zhao =4, Ferr=3 - DO L=1,LM - PHY_F3DV(L,N) = int_state%PHY_F3DV (I,J,L,N) - ENDDO - ENDDO -! -!----------------------------------------------------------------------- - CALL GRRAD_gfs & -!----------------------------------------------------------------------- -! --- inputs: - (PRSI,PRSL,PRSLK,GT,GR,GR1,VVEL,SLMSK, & - XLON(I,J),XLAT,TSEA,SNWDPH,SNCOVR,SNOALB,ZORL,HPRIME(1), & - ALVSF,ALNSF,ALVWF,ALNWF,FACSF,FACWF,XSICFCS,TISFC, & - int_state%SOLCON,COSZEN(I,J),COSZDG(I,J),K1OZ,K2OZ,FACOZ, & - CV,CVT,CVB,IOVR_SW,IOVR_LW,F_ICE,F_RAIN,R_RIME,FLGMIN_L, & - ICSDSW,ICSDLW,NUM_P3D,NTCW-1,NCLD,NTOZ-1,NTRAC-1,NFXR, & - DTLW,DTSW,LSSWR,LSLWR,LSSAV,SASHAL,NORAD_PRECIP, & - CRICK_PROOF,CCNORM, & - 1,1,LM,IFLIP,MYPE,LPRNT,1,NTIMESTEP, & -! --- outputs: - SWH,TOPFSW,SFCFSW,SFALB, & - HLW,TOPFLW,SFCFLW,TSFLW,SEMIS,CLDCOV_V, & -! --- input/output: - FLUXR_V & - ) -!----------------------------------------------------------------------- -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!! GBPHYS !!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!--- - IF (LSSWR .OR. LSLWR ) THEN - SFCDLW(1) = SFCFLW(1)%DNFXC - SFCDSW(1) = SFCFSW(1)%DNFXC - SFCNSW(1) = SFCFSW(1)%DNFXC - SFCFSW(1)%UPFXC - int_state%SFCDLW(I,J) = SFCDLW(1) - int_state%SFCDSW(I,J) = SFCDSW(1) - int_state%SFCNSW(I,J) = SFCNSW(1) - int_state%SFALB(I,J) = SFALB(1) - int_state%TSFLW(I,J) = TSFLW(1) - int_state%SEMIS(I,J) = SEMIS(1) - ELSE - SFCDLW(1) = int_state%SFCDLW(I,J) - SFCDSW(1) = int_state%SFCDSW(I,J) - SFCNSW(1) = int_state%SFCNSW(I,J) - SFALB(1) = int_state%SFALB(I,J) - TSFLW(1) = int_state%TSFLW(I,J) - SEMIS(1) = int_state%SEMIS(I,J) - ENDIF -!--- - NIRBMD_CPL(1) = 0.25 * SFCDSW(1) - NIRDFD_CPL(1) = 0.26 * SFCDSW(1) - VISBMD_CPL(1) = 0.16 * SFCDSW(1) - VISDFD_CPL(1) = 0.33 * SFCDSW(1) - NIRBMU_CPL(1) = NIRBMD_CPL(1) - 0.25 * SFCNSW(1) - NIRDFU_CPL(1) = NIRDFD_CPL(1) - 0.26 * SFCNSW(1) - VISBMU_CPL(1) = VISBMD_CPL(1) - 0.16 * SFCNSW(1) - VISDFU_CPL(1) = VISDFD_CPL(1) - 0.33 * SFCNSW(1) -!--- - DPSHC(1) = 0.3 * PRSI(1) - GQ(1) = PRSI(1) -!--- - RANNUM_V(1) = RANN(I,J) -!--- - RCS2_V(1) = 1.0d0/(0.0001d0+COS(XLAT(1))*COS(XLAT(1))) ! fixed XLAT=+/-90 -!--- - TPRCP(1) = int_state%PREC(I,J) - CNVPRCP(1) = int_state%CUPREC(I,J) - TOTPRCP(1) = int_state%ACPREC(I,J) - - DO L=1,NUM_SOIL_LAYERS - SMC_V(L) = int_state%SMC(I,J,L) - STC_V(L) = int_state%STC(I,J,L) - SLC_V(L) = int_state%SH2O(I,J,L) - ENDDO - - SHDMIN(1) = int_state%SHDMIN(I,J) - SHDMAX(1) = int_state%SHDMAX(I,J) - - UUSTAR(1) = int_state%USTAR(I,J) - CANOPY(1) = int_state%CMC(I,J)*1000. - FLGMIN = 0.2d0 !!! put this in ferrier init - CRTRH = 0.85d0 - FLIPV = .FALSE. - NCW(1) = 50 - NCW(2) = 150 - OLD_MONIN = .FALSE. - CNVGWD = .FALSE. - NEWSAS = 0 - CCWF = 0.5d0 ! only for RAS scheme - CGWF = 0.1 ! cloud top fraction for convective gwd scheme - PRSLRD0 = 0. ! pressure(pa) above which Raleigh damping applied -! -! ---- ESTIMATE T850 FOR RAIN-SNOW DECISION ---------------------------- -! - T850 = GT(1) - DO L = 1, LM - 1 - IF(PRSL(L) .GT. 85000.d0 .AND. PRSL(L+1) .LE. 85000.d0) THEN - T850 = GT(L) - (PRSL(L)-85000.d0) / (PRSL(L)-PRSL(L+1)) * (GT(L)-GT(L+1)) - ENDIF - ENDDO -! - SRFLAG(1) = 0.0d0 - IF(T850 .LE. 273.16d0) SRFLAG(1) = 1.0d0 -! -!---- OZONE ------------------------------------------------------------ - IF (NTOZ .GT. 0) THEN - DO N=1,PL_COEFF - DO L=1,LEVOZP - OZPLOUT_V(L,N) = OZPLOUT(L,j,N) - ENDDO - ENDDO - ELSE - OZPLOUT_V = 0.0d0 - ENDIF - DTDT = 0.0D0 - TRIGGERPERTS(1) = 0.0d0 -!----------------------------------------------------------------------- - CALL GBPHYS(1, 1, LM, NUM_SOIL_LAYERS, LSM, NTRAC, NCLD, NTOZ, NTCW, & - NMTVR, 1, LEVOZP, IDE_GR, LATR, 62, NUM_P3D, NUM_P2D, & - NTIMESTEP, J-JTS+1, MYPE, PL_COEFF, LONR, NCW, FLGMIN, CRTRH, & - CDMBGWD, & - CCWF, DLQF, CTEI_RM, CLSTP, CGWF, PRSLRD0, DTP, DTF, FHOUR, & - SOLHR, int_state%SLAG, int_state%SDEC, int_state%CDEC, & - SINLAT_R(J), COSLAT_R(J), GQ, GU, GV, & - GT, GR3, VVEL, PRSI, PRSL, PRSLK, PRSIK, PHII, PHIL, & - RANN, OZPLOUT_V, PL_PRES, DPSHC, HPRIME, XLON(I,J), XLAT, & - XSLPFCS, SHDMIN, SHDMAX, SNOALB, XTG3FCS, SLMSK, XVEGFCS, & - XVETFCS, XSOTFCS, UUSTAR, ORO, oro, COSZEN(I,J), SFCDSW, SFCNSW, & - NIRBMD_CPL, NIRDFD_CPL, VISBMD_CPL, VISDFD_CPL, & - NIRBMU_CPL, NIRDFU_CPL, VISBMU_CPL, VISDFU_CPL, & - SFCDLW, TSFLW, SEMIS, SFALB, SWH, HLW, RAS, PRE_RAD, & - LDIAG3D, LGGFS3D, LGOCART, LSSAV, LSSAV_CC, LSSAV_CPL, & - BKGD_VDIF_M, BKGD_VDIF_H, BKGD_VDIF_S, PSAUTCO, PRAUTCO, EVPCO, & - WMINCO, & - FLIPV, OLD_MONIN, CNVGWD, SHAL_CNV, SASHAL, NEWSAS, CAL_PRE, & - MOM4ICE, MSTRAT, TRANS_TRAC, NST_FCST, MOIST_ADJ, & - THERMODYN_ID, SFCPRESS_ID, GEN_COORD_HYBRID, LEVR, & - XSIHFCS, XSICFCS, TISFC, TSEA, TPRCP, CV, CVB, CVT, & - SRFLAG, SNWDPH, WEASD, SNCOVR, ZORL, CANOPY, & - FFMM, FFHH, F10M, SRUNOFF, EVBSA, EVCWA, SNOHFA, & - TRANSA, SBSNOA, SNOWCA, SOILM, int_state%TMPMIN(I,J), & - int_state%TMPMAX(I,J), & - DUSFC, DVSFC, DTSFC, DQSFC, TOTPRCP, GFLUX, & - DLWSFC, ULWSFC, SUNTIM, RUNOFF, EP, CLDWRK, & - int_state%DUGWD(I,J), int_state%DVGWD(I,J), PSMEAN, CNVPRCP, & - SPFHMIN, SPFHMAX, RAIN, RAINC, & - DT3DT, DQ3DT, DU3DT, DV3DT, DQDT, ACV, ACVB, ACVT, & - SLC_V, SMC_V, STC_V, UPD_MF, DWN_MF, DET_MF, DKH, RNP, PHY_F3DV, & - PHY_F2DV, & - DLWSFC_CC, ULWSFC_CC, DTSFC_CC, SWSFC_CC, & - DUSFC_CC, DVSFC_CC, DQSFC_CC, PRECR_CC, & - DUSFC_CPL, DVSFC_CPL, DTSFC_CPL, DQSFC_CPL, & - DLWSFC_CPL,DSWSFC_CPL,DNIRBM_CPL,DNIRDF_CPL, & - DVISBM_CPL,DVISDF_CPL,RAIN_CPL, & - NLWSFC_CPL,NSWSFC_CPL,NNIRBM_CPL,NNIRDF_CPL, & - NVISBM_CPL,NVISDF_CPL, & - XT, XS, XU, XV, XZ, ZM, XTTS, XZTS, D_CONV, IFD, DT_COOL, QRAIN, & - ADT, ADR, ADU, ADV, T2M, Q2M, U10M, V10M, & - ZLVL, PSURF, HPBL, PWAT, T1, Q1, U1, V1, & - CHH, CMM, DLWSFCI, ULWSFCI, DSWSFCI, USWSFCI, DUSFCI, DVSFCI, & - DTSFCI, DQSFCI, GFLUXI, EPI, SMCWLT2, SMCREF2, WET1, & - GSOIL, GTMP2M, GUSTAR, GPBLH, GU10M, GV10M, GZORL, GORO, SR, & - XMU_CC, DLW_CC, DSW_CC, SNW_CC, LPREC_CC, & - DUSFCI_CPL, DVSFCI_CPL, DTSFCI_CPL, DQSFCI_CPL, & - DLWSFCI_CPL,DSWSFCI_CPL,DNIRBMI_CPL,DNIRDFI_CPL, & - DVISBMI_CPL,DVISDFI_CPL, & - NLWSFCI_CPL,NSWSFCI_CPL,NNIRBMI_CPL,NNIRDFI_CPL, & - NVISBMI_CPL,NVISDFI_CPL,T2MI_CPL,Q2MI_CPL, & - U10MI_CPL,V10MI_CPL,TSEAI_CPL,PSURFI_CPL,ORO_CPL,SLMSK_CPL, & - TREF, Z_C, C_0, C_D, W_0, W_D, RQTK, HLWD, LSIDEA, & - DTDT, TRIGGERPERTS) -!----------------------------------------------------------------------- -! *** UPDATE AFTER PHYSICS -!----------------------------------------------------------------------- - int_state%SIHFCS(I,J) = XSIHFCS(1) - int_state%SICFCS(I,J) = XSICFCS(1) - int_state%ZORFCS(I,J) = ZORL(1) - - int_state%CZEN(I,J) = COSZEN(I,J) - int_state%CZMEAN(I,J) = COSZDG(I,J) - - int_state%SI(I,J) = SNWDPH(1) - int_state%SNO(I,J) = WEASD(1) - int_state%MXSNAL(I,J) = SNOALB(1) - - DO L=1,NUM_SOIL_LAYERS - int_state%SMC(I,J,L) = SMC_V(L) - int_state%STC(I,J,L) = STC_V(L) - int_state%SH2O(I,J,L) = SLC_V(L) - ENDDO - - int_state%CMC(I,J) = CANOPY(1)*0.001 - int_state%USTAR(I,J) = UUSTAR(1) - int_state%SMSTOT(I,J) = SOILM(1)*1000. - - DO L=1,LM - KFLIP=LM+1-L - int_state%RSWTT(I,J,L) = SWH(KFLIP) - int_state%RLWTT(I,J,L) = HLW(KFLIP) - ENDDO - - DO N=1,3 ! for Zhao =3, Ferr=1 - int_state%PHY_F2DV (I,J,N) = PHY_F2DV(N) - ENDDO - - DO N=1,4 ! for Zhao =4, Ferr=3 - DO L=1,LM - int_state%PHY_F3DV (I,J,L,N) = PHY_F3DV(L,N) - ENDDO - ENDDO - - int_state%ALWIN(I,J) = int_state%ALWIN(I,J) + int_state%RLWIN(I,J) - int_state%ALWOUT(I,J) = int_state%ALWOUT(I,J) - int_state%RADOT(I,J) - int_state%ASWIN(I,J) = int_state%ASWIN(I,J) + int_state%RSWIN(I,J) - int_state%ASWOUT(I,J) = int_state%ASWOUT(I,J) - int_state%RSWOUT(I,J) - int_state%RLWIN(I,J) = DLWSFCI(1) - int_state%RADOT(I,J) = ULWSFCI(1) - int_state%RSWIN(I,J) = DSWSFCI(1) - int_state%RSWOUT(I,J) = USWSFCI(1) - int_state%RSWINC(I,J) = int_state%RSWIN(I,J)/(1.-int_state%ALBEDO(I,J)) - - int_state%RLWTOA(I,J) = FLUXR_V(1)*DTLWI - int_state%RSWTOA(I,J) = FLUXR_V(2)*DTSWI - int_state%ALWTOA(I,J) = int_state%ALWTOA(I,J) + FLUXR_V(1)*DTLWI - int_state%ASWTOA(I,J) = int_state%ASWTOA(I,J) + FLUXR_V(2)*DTSWI - - int_state%TWBS(I,J) = -DQSFCI(1) - int_state%QWBS(I,J) = -DTSFCI(1) - int_state%SFCSHX(I,J) = int_state%SFCSHX(I,J) + int_state%QWBS(I,J) - int_state%SFCLHX(I,J) = int_state%SFCLHX(I,J) + int_state%TWBS(I,J) - int_state%SUBSHX(I,J) = int_state%SUBSHX(I,J) + GFLUXI(1) - int_state%GRNFLX(I,J) = GFLUXI(1) - int_state%POTEVP(I,J) = EP(1)*XLVRWI - int_state%POTFLX(I,J) = -EP(1)*DTPHSI - int_state%SFCEVP(I,J) = int_state%SFCEVP(I,J) + DQSFCI(1)*DTPHS*XLVRWI - - int_state%SFCEXC(I,J) = CDQ(1) !need CDQ from GFS - int_state%PBLH(I,J) = HPBL(1) - int_state%PSFC(I,J) = PSURF(1) - int_state%PREC(I,J) = TPRCP(1) - int_state%CUPPT(I,J) = CNVPRCP(1)-int_state%CUPREC(I,J) - int_state%CPRATE(I,J) = CNVPRCP(1)-int_state%CUPREC(I,J) - int_state%CUPREC(I,J) = CNVPRCP(1) - int_state%ACPREC(I,J) = TOTPRCP(1) - - int_state%BGROFF(I,J) = RUNOFF(1)*1000. - int_state%SSROFF(I,J) = SRUNOFF(1)*1000. - - int_state%TSKIN(I,J) = TISFC(1) - int_state%SST(I,J) = TSEA(1) - int_state%SOILTB(I,J) = XTG3FCS(1) - IF( SRFLAG(1) >= 0.5 .AND. SLMSK(1) >= 0.5 ) & - int_state%ACSNOW(I,J) = int_state%ACSNOW(I,J) + int_state%ACPREC(I,J)*100. - - int_state%PSHLTR(I,J) = PSURF(1)*EXP(0.06823/T2M(1)) - int_state%TSHLTR(I,J) = T2M(1) - int_state%QSHLTR(I,J) = Q2M(1) - int_state%QSH(I,J) = QSS(1) !need QSS from GFS - int_state%T2(I,J) = T2M(1) - int_state%TH02(I,J) = T2M(1)*(100000./PSURF(1))**RoCP - int_state%Q02(I,J) = Q2M(1) - int_state%U10(I,J) = U10M(1) - int_state%V10(I,J) = V10M(1) - int_state%THS(I,J) = TSFLW(1)*(100000./PSURF(1))**RoCP - int_state%SIGT4(I,J) = int_state%T(I,J,LM)*int_state%T(I,J,LM) * & - int_state%T(I,J,LM)*int_state%T(I,J,LM) * STBOLT - DO L=1,LM - KFLIP=LM+1-L - int_state%T(I,J,L) = ADT(KFLIP) - int_state%DUDT(I,J,L) = (ADU(KFLIP) - GU(KFLIP)) / DTP - int_state%DVDT(I,J,L) = (ADV(KFLIP) - GV(KFLIP)) / DTP - int_state%CLDFRA(I,J,L) = CLDCOV_V(KFLIP) - int_state%Q (I,J,L) = ADR(KFLIP,1) - int_state%O3(I,J,L) = ADR(KFLIP,2) - int_state%CW(I,J,L) = ADR(KFLIP,3) - ENDDO -! -!----------------------------------------------------------------------- -! *** End update after Physics -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! *** End GFS-PHYS domain loop -!----------------------------------------------------------------------- -! - ENDDO i_loop -! - ENDDO j_loop -! -!----------------------------------------------------------------------- -! - td%gfs_phy_tim=td%gfs_phy_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Exchange wind tendencies -!----------------------------------------------------------------------- -! - btim=timef() -! - CALL HALO_EXCH(int_state%DUDT,LM,int_state%DVDT,LM,3,3) -! - td%exch_phy=td%exch_phy+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Now interpolate wind tendencies from H to V points. -!----------------------------------------------------------------------- -! - btim=timef() -! - CALL H_TO_V_TEND(int_state%DUDT,int_state%DT,int_state%NPHS,LM & - ,int_state%U) - CALL H_TO_V_TEND(int_state%DVDT,int_state%DT,int_state%NPHS,LM & - ,int_state%V) -! - td%h_to_v_tim=td%h_to_v_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** Poles and East-West boundary. -!----------------------------------------------------------------------- -! - IF(int_state%GLOBAL)THEN - btim=timef() -! - CALL SWAPHN(int_state%T,IMS,IME,JMS,JME,LM,int_state%INPES) - CALL POLEHN(int_state%T,IMS,IME,JMS,JME,LM & - ,int_state%INPES,int_state%JNPES) -! - CALL SWAPHN(int_state%Q,IMS,IME,JMS,JME,LM,int_state%INPES) - CALL POLEHN(int_state%Q,IMS,IME,JMS,JME,LM & - ,int_state%INPES,int_state%JNPES) -! - CALL SWAPHN(int_state%CW,IMS,IME,JMS,JME,LM,int_state%INPES) - CALL POLEHN(int_state%CW,IMS,IME,JMS,JME,LM & - ,int_state%INPES,int_state%JNPES) -! - CALL SWAPHN(int_state%O3,IMS,IME,JMS,JME,LM,int_state%INPES) - CALL POLEHN(int_state%O3,IMS,IME,JMS,JME,LM & - ,int_state%INPES,int_state%JNPES) -! - CALL SWAPWN(int_state%U,IMS,IME,JMS,JME,LM,int_state%INPES) - CALL SWAPWN(int_state%V,IMS,IME,JMS,JME,LM,int_state%INPES) - CALL POLEWN(int_state%U,int_state%V,IMS,IME,JMS,JME,LM & - ,int_state%INPES,int_state%JNPES) -! - td%pole_swap_tim=td%pole_swap_tim+(timef()-btim) - ENDIF -! -!----------------------------------------------------------------------- -!*** Exchange U, V, T, Q and CW -!----------------------------------------------------------------------- -! - btim=timef() -! - CALL HALO_EXCH(int_state%T,LM & - ,3,3) -! - CALL HALO_EXCH(int_state%Q,LM,int_state%CW,LM & - ,3,3) -! - CALL HALO_EXCH(int_state%O3,LM & - ,3,3) -! - CALL HALO_EXCH(int_state%U,LM,int_state%V,LM & - ,3,3) -! - td%exch_phy=td%exch_phy+(timef()-btim) -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -#endif - ENDIF gfs_physics -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - DEALLOCATE(LONSPERLAR) - DEALLOCATE(GLOBAL_LATS_R) - DEALLOCATE(CLDCOV_V) - DEALLOCATE(PRSL) - DEALLOCATE(PRSLK) - DEALLOCATE(GU) - DEALLOCATE(GV) - DEALLOCATE(GT) - DEALLOCATE(GR) - DEALLOCATE(VVEL) - DEALLOCATE(F_ICE) - DEALLOCATE(F_RAIN) - DEALLOCATE(R_RIME) - DEALLOCATE(ADT) - DEALLOCATE(ADU) - DEALLOCATE(ADV) - DEALLOCATE(PHIL) - DEALLOCATE(GR3) - DEALLOCATE(ADR) - DEALLOCATE(PRSI) - DEALLOCATE(PRSIK) - DEALLOCATE(RSGM) - DEALLOCATE(PHII) - DEALLOCATE(SINLAT_R) - DEALLOCATE(COSLAT_R) - DEALLOCATE(XLON) - DEALLOCATE(COSZEN) - DEALLOCATE(COSZDG) - DEALLOCATE(RANN) - DEALLOCATE(RANNUM) - DEALLOCATE(GR1) - DEALLOCATE(SWH) - DEALLOCATE(HLW) - DEALLOCATE(DKH) - DEALLOCATE(RNP) - DEALLOCATE(UPD_MF) - DEALLOCATE(DWN_MF) - DEALLOCATE(DET_MF) - DEALLOCATE(DQDT) - DEALLOCATE(DQ3DT) - DEALLOCATE(DT3DT) - DEALLOCATE(DU3DT) - DEALLOCATE(DV3DT) - DEALLOCATE(PHY_F3DV) -! -!####################################################################### -!####################################################################### -!######### E N D O F G F S P H Y S I C S D R I V E R ########### -!####################################################################### -!####################################################################### -!----------------------------------------------------------------------- -! -#endif - ENDIF gfs_phys_test -! -!----------------------------------------------------------------------- -!*** Write precipitation files for ADJPPT regression test -!----------------------------------------------------------------------- -! - IF( int_state%WRITE_PREC_ADJ .AND. & - MOD(XTIME,60.) <= 0.001 .AND. & - INT(XTIME/60.) <= int_state%PCPHR ) THEN - CALL WRT_PCP(int_state%PREC & - ,MYPE,NUM_PES,MPI_COMM_COMP,MY_DOMAIN_ID & - ,INT(XTIME/60.)+1 & - ,IDS,IDE,JDS,JDE & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE) - ENDIF -! - ENDIF physics -! -!----------------------------------------------------------------------- -!*** Run the tracker -!----------------------------------------------------------------------- -! - IF(int_state%NTRACK>0 .AND. int_state%MYPEwrap%INT_STATE -! - MYPE=int_state%MYPE !<-- The local task rank -! - IF(MYPE==0)THEN - WRITE(0,*)' Solver Completed Normally.' - ENDIF -! -!----------------------------------------------------------------------- -!*** DO NOT DEALLOCATE THE SOLVER INTERNAL STATE POINTER -!*** WITHOUT DEALLOCATING ITS CONTENTS. -!----------------------------------------------------------------------- -! -!!! DEALLOCATE(INT_STATE,stat=RC) -! -!----------------------------------------------------------------------- -! - IF(RC_FINAL==ESMF_SUCCESS)THEN - WRITE(0,*)'SOLVER FINALIZE STEP SUCCEEDED' - ELSE - WRITE(0,*)'SOLVER FINALIZE STEP FAILED' - ENDIF -! -! IF(PRESENT(RC_FINALIZE))THEN - RC_FINALIZE=RC_FINAL -! ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE SOLVER_FINALIZE -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE BUILD_BC_BUNDLE(GRID & - ,LNSH,LNSV & - ,IHALO,JHALO & - ,UBOUND_VARS & - ,VARS & - ,MY_DOMAIN_ID & - ,BUNDLE_NESTBC & - ,BND_VARS_H & - ,BND_VARS_V & - ,NVARS_BC_2D_H & - ,NVARS_BC_3D_H & - ,NVARS_BC_4D_H & - ,NVARS_BC_2D_V & - ,NVARS_BC_3D_V & - ,NLEV_H & - ,NLEV_V & - ,N_BC_3D_H & - ) -! -!----------------------------------------------------------------------- -!*** This routine builds an ESMF Bundle for holding groups of pointers -!*** to Solver internal state variables that are updated on the -!*** domain boundaries during the integration. -!*** In addition the object that holds primary boundary information -!*** is partially allocated and pointed at the relevant variables. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: IHALO,JHALO & !<-- Subdomain halo widths - ,LNSH,LNSV !<-- Domain boundary blending width - INTEGER(kind=KINT),INTENT(IN) :: MY_DOMAIN_ID & !<-- This domain's ID - ,UBOUND_VARS !<-- Upper dimension of the VARS array -! - INTEGER(kind=KINT),DIMENSION(1:3),INTENT(OUT) :: N_BC_3D_H !<-- Hold order of domain #1's BC vbls from boco files -! - TYPE(ESMF_Grid),INTENT(IN) :: GRID !<-- The ESMF Grid for this domain -! - TYPE(VAR),DIMENSION(1:UBOUND_VARS),INTENT(INOUT) :: VARS !<-- Variables in the Solver internal state -! - TYPE(ESMF_FieldBundle),INTENT(INOUT) :: BUNDLE_NESTBC !<-- The Bundle of Solver internal state vbls to be -! ! updated on the nest boundaries - INTEGER(kind=KINT),INTENT(OUT) :: NVARS_BC_2D_H & !<-- # of 2-D,3-D,4-D H-pt variables - ,NVARS_BC_3D_H & ! that are inserted - ,NVARS_BC_4D_H ! into the Bundle. -! - INTEGER(kind=KINT),INTENT(OUT) :: NVARS_BC_2D_V & !<-- # of 2-D,3-D V-pt variables - ,NVARS_BC_3D_V ! that are inserted into the Bundle. -! - INTEGER(kind=KINT),INTENT(OUT) :: NLEV_H,NLEV_V !<-- # of model levels in all H-pt,V-pt variables used -! - TYPE(BC_H_ALL),INTENT(OUT) :: BND_VARS_H !<-- Object holding H-pt variable info on domain boundaries - TYPE(BC_V_ALL),INTENT(OUT) :: BND_VARS_V !<-- Object holding V-pt variable info on domain boundaries -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: H_OR_V_INT,IOS,LB3,LB4 & - ,N,NSIZE,NUM_DIMS,NUM_FIELDS & - ,UB3,UB4 -! - INTEGER(kind=KINT) :: IMS,IME,JMS,JME -! - INTEGER(kind=KINT) :: KNT_2D_H,KNT_3D_H,KNT_4D_H & - ,KNT_2D_V,KNT_3D_V -! - INTEGER(kind=KINT) :: KNT_3D_DOM_01 -! - INTEGER(kind=KINT) :: ISTAT,RC,RC_CMB -! - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ARRAY_2D=>NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: ARRAY_3D=>NULL() - REAL(kind=KFPT),DIMENSION(:,:,:,:),POINTER :: ARRAY_4D=>NULL() -! - CHARACTER(len=1) :: CH_2,CH_B,H_OR_V -! - CHARACTER(len=2) :: CH_M -! - CHARACTER(len=9),SAVE :: FNAME='nests.txt' -! - CHARACTER(len=99) :: BUNDLE_NAME,FIELD_NAME,VBL_NAME -! - CHARACTER(len=256) :: STRING -! - LOGICAL(kind=KLOG) :: CASE_2WAY,CASE_NESTBC -! - TYPE(ESMF_Field) :: FIELD_X -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - IMS=int_state%IMS - IME=int_state%IME - JMS=int_state%JMS - JME=int_state%JME -! - NVARS_BC_2D_H=0 - NVARS_BC_3D_H=0 - NVARS_BC_4D_H=0 -! - NVARS_BC_2D_V=0 - NVARS_BC_3D_V=0 -! - KNT_3D_DOM_01=0 -! - DO N=1,3 - N_BC_3D_H(N)=-1 - ENDDO -! -!----------------------------------------------------------------------- -!*** Loop through all Solver internal state variables. -!----------------------------------------------------------------------- -! - OPEN(unit=10,file=FNAME,status='OLD',action='READ' & !<-- Open the text file with user specifications - ,iostat=IOS) -! - IF(IOS/=0)THEN - WRITE(0,*)' Failed to open ',FNAME,' so ABORT!' - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT & - ,rc =RC) - ENDIF -! - NLEV_H=0 !<-- Counter for total # of levels in all 2-way vbls - NLEV_V=0 !<-- Counter for total # of levels in all 2-way vbls -! -!----------------------------------------------------------------------- - bundle_loop: DO -!----------------------------------------------------------------------- -! - READ(UNIT=10,FMT='(A)',iostat=IOS)STRING !<-- Read in the next specification line - IF(IOS/=0)THEN !<-- Finished reading the specification lines - CLOSE(10) - EXIT - ENDIF -! - IF(STRING(1:1)=='#'.OR.TRIM(STRING)=='')THEN - CYCLE !<-- Read past comments and blanks. - ENDIF -! -!----------------------------------------------------------------------- -!*** Read the text line containing the H or V specification for -!*** variable N then find that variable's place within the VARS -!*** object. -!----------------------------------------------------------------------- -! - READ(UNIT=STRING,FMT=*,iostat=IOS)VBL_NAME & !<-- The variable's name in the text file. - ,CH_B & !<-- The flag for nest BC vbls in the text file. - ,CH_M & !<-- Not relevant here (flag for moving nests) - ,CH_2 !<-- The flag for 2-way vbls in the text file. -! - CALL FIND_VAR_INDX(VBL_NAME,VARS,UBOUND_VARS,N) -! - FIELD_NAME=TRIM(VARS(N)%VBL_NAME)//TRIM(SUFFIX_NESTBC) !<-- Append the BC suffix to the Field -! -!----------------------------------------------------------------------- -!*** Check the Bundle's name to determine which column of user -!*** specifications to read from the text file. -!----------------------------------------------------------------------- -! - H_OR_V=CH_B !<-- H-V flag for this nest BC variable -! -!----------------------------------------------------------------------- -!*** Find the variables in the Solver internal state that have been -!*** selected to be placed into the Bundle. The user has specified -!*** whether the variable lies on H points or V points. -!*** Currently ESMF will not allow the use of Attributes that are -!*** characters therefore we must translate the character codes from -!*** the txt file into something that ESMF can use. In this case -!*** we will use integers: H-->1 and V-->2 . -!----------------------------------------------------------------------- -! - IF(H_OR_V=='H')THEN - H_OR_V_INT=1 !<-- H-pt variable - ELSEIF(H_OR_V=='V')THEN - H_OR_V_INT=2 !<-- V-pt variable - ELSE - H_OR_V_INT=-999 !<-- Variable not specified for use. - ENDIF -! -!----------------------------------------------------------------------- -! - build_bundle: IF(H_OR_V=='H' & - .OR. & - H_OR_V=='V' & - )THEN -! -!----------------------------------------------------------------------- -! -!------------------- -!*** 2-D Variables -!------------------- -! -!------------- -!*** Integer -!------------- -! - IF(ASSOCIATED(VARS(N)%I2D))THEN !<-- 2-D integer array on mass points -! -! FIELD_X=ESMF_FieldCreate(grid =GRID & !<-- The ESMF Grid for this domain -! ,farray =VARS(N)%I2D & !<-- Nth variable in the VARS array -! ,totalUWidth=(/IHALO,JHALO/) & !<-- Upper bound of halo region -! ,totalLWidth=(/IHALO,JHALO/) & !<-- Lower bound of halo region -! ,name =FIELD_NAME & !<-- The name of this variable -! ,indexFlag =ESMF_INDEX_GLOBAL & !<-- The variable uses global indexing -! ,rc =RC) - WRITE(0,*)' MUST ADD THE CAPABILITY TO USE 2-D INTEGERS IN 2WAY/BC UPDATES!!' - WRITE(0,*)' Variable name is ',VARS(N)%VBL_NAME,' for variable #',N - WRITE(0,*)' H_OR_V_INT=',H_OR_V_INT - WRITE(0,*)' ABORT!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) -! -! -!---------- -!*** Real -!---------- -! - ELSEIF(ASSOCIATED(VARS(N)%R2D))THEN !<-- 2-D real array on mass points -! - FIELD_X=ESMF_FieldCreate(grid =GRID & !<-- The ESMF Grid for this domain - ,farray =VARS(N)%R2D & !<-- Nth variable in the VARS array - ,totalUWidth=(/IHALO,JHALO/) & !<-- Upper bound of halo region - ,totalLWidth=(/IHALO,JHALO/) & !<-- Lower bound of halo region - ,name =FIELD_NAME & !<-- The name of this variable - ,indexFlag =ESMF_INDEX_GLOBAL & !<-- The variable uses global indexing - ,rc =RC) -! - IF(H_OR_V=='H')THEN - NVARS_BC_2D_H=NVARS_BC_2D_H+1 !<-- Count # of 2-D H-pt variables - NLEV_H=NLEV_H+1 !<-- Sum all levels for H-pt variables - ELSEIF(H_OR_V=='V')THEN - NVARS_BC_2D_V=NVARS_BC_2D_V+1 !<-- Count # of 2-D V-pt variables - NLEV_V=NLEV_V+1 !<-- Sum all levels for V-pt variables - ENDIF -! -!------------------- -!*** 3-D Variables -!------------------- -! -!---------- -!*** Real -!---------- -! - ELSEIF(ASSOCIATED(VARS(N)%R3D))THEN !<-- 3-D real array on mass points -! - FIELD_X=ESMF_FieldCreate(grid =GRID & !<-- The ESMF Grid for this domain - ,farray =VARS(N)%R3D & !<-- Nth variable in the VARS array - ,totalUWidth =(/IHALO,JHALO/) & !<-- Upper bound of halo region - ,totalLWidth =(/IHALO,JHALO/) & !<-- Lower bound of halo region - ,ungriddedLBound=(/lbound(VARS(N)%R3D,dim=3)/) & - ,ungriddedUBound=(/ubound(VARS(N)%R3D,dim=3)/) & - ,name =FIELD_NAME & !<-- The name of this variable - ,indexFlag =ESMF_INDEX_GLOBAL & !<-- The variable uses global indexing - ,rc =RC) -! - LB3=LBOUND(VARS(N)%R3D,3) - UB3=UBOUND(VARS(N)%R3D,3) -! - IF(H_OR_V=='H')THEN - NVARS_BC_3D_H=NVARS_BC_3D_H+1 !<-- Count # of 3-D H-pt variables - NLEV_H=NLEV_H+(UB3-LB3+1) !<-- Sum all levels for H-pt variables - ELSEIF(H_OR_V=='V')THEN - NVARS_BC_3D_V=NVARS_BC_3D_V+1 !<-- Count # of 3-D V-pt variables - NLEV_V=NLEV_V+(UB3-LB3+1) !<-- Sum all levels for V-pt variables - ENDIF -! -!------------------- -!*** 4-D Variables -!------------------- -! -!---------- -!*** Real -!---------- -! - ELSEIF(ASSOCIATED(VARS(N)%R4D))THEN !<-- 4-D real array on mass points -! - LB4=LBOUND(VARS(N)%R4D,dim=4) - UB4=UBOUND(VARS(N)%R4D,dim=4) -! - FIELD_X=ESMF_FieldCreate(grid =GRID & !<-- The ESMF Grid for this domain - ,farray =VARS(N)%R4D & !<-- Nth variable in the VARS array - ,totalUWidth =(/IHALO,JHALO/) & !<-- Upper bound of halo region - ,totalLWidth =(/IHALO,JHALO/) & !<-- Lower bound of halo region - ,ungriddedLBound =(/ LBOUND(VARS(N)%R4D,dim=3),LB4 /) & - ,ungriddedUBound =(/ UBOUND(VARS(N)%R4D,dim=3),UB4 /) & - ,name =FIELD_NAME & !<-- The name of this variable - ,indexFlag =ESMF_INDEX_GLOBAL & !<-- The variable uses global indexing - ,rc =RC) -! - LB3=LBOUND(VARS(N)%R4D,3) - UB3=UBOUND(VARS(N)%R4D,3) -! - IF(H_OR_V=='H')THEN - NVARS_BC_4D_H=NVARS_BC_4D_H+1 !<-- Count # of 4-D H-pt variables - NLEV_H=NLEV_H+(UB3-LB3+1)*(UB4-LB4+1) !<-- Sum all levels for H-pt variables - ENDIF -! -!---------------- -!*** All Others -!---------------- -! - ELSE - WRITE(0,*)' SELECTED UPDATE H VARIABLE IS NOT 2,3,4-D REAL.' - WRITE(0,*)' Variable name is ',VARS(N)%VBL_NAME,' for variable #',N - WRITE(0,*)' H_OR_V_INT=',H_OR_V_INT - WRITE(0,*)' ABORT!!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Attach the index of this variable within the Solver internal -!*** state so it can be referenced w/r to the boundary objects. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Solver Int State Indx to Bundle Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(field=FIELD_X & !<-- The Field to be added to the Bundle - ,name ='Solver Int State Indx' & !<-- The name of the Attribute to set - ,value=N & !<-- The index of the Solver internal state vbl - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CMB) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Attach the specification flag to this Field that indicates -!*** whether it is an H-pt or a V-pt variable. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add H-or-V Specification Flag to Bundle Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(field=FIELD_X & !<-- The Field to be added to the Bundle - ,name ='H_OR_V_INT' & !<-- The name of the Attribute to set - ,value=H_OR_V_INT & !<-- H-pt or V-pt flag - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CMB) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Add this Field to the Bundle that holds pointers to all -!*** variables in the Solver internal state that have been -!*** selected. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Add Desired Field to the Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleAdd( BUNDLE_NESTBC & !<-- The Bundle of Solver internal state BC variables - , (/FIELD_X/) & !<-- Add this Field to the Bundle - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CMB) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - ENDIF build_bundle -! -!----------------------------------------------------------------------- -! - ENDDO bundle_loop -! -!----------------------------------------------------------------------- -!*** Allocate the appropriate pieces of the boundary variable -!*** objects. All nests use the same set of boundary variables -!*** that are specified by the user in the external text file. -! -!*** The upper parent domain uses its own set of boundary variables -!*** updated from the BC files generated during preprocessing. -!*** They are currently hardwired to PD,T,Q,CW,U,V. -!----------------------------------------------------------------------- -! - IF(MY_DOMAIN_ID==1)THEN !<-- The uppermost parent will hardwire its BC vbls -! - NVARS_BC_2D_H=1 !<-- PD - NVARS_BC_3D_H=3 !<-- T,Q,CW - NVARS_BC_4D_H=0 - NVARS_BC_2D_V=0 - NVARS_BC_3D_V=2 !<-- U,V -! - ENDIF -! - IF(NVARS_BC_2D_H>0)THEN - ALLOCATE(BND_VARS_H%VAR_2D(1:NVARS_BC_2D_H)) !<-- All 2-D H-pt nest boundary variables - ENDIF -! - IF(NVARS_BC_3D_H>0)THEN - ALLOCATE(BND_VARS_H%VAR_3D(1:NVARS_BC_3D_H)) !<-- All 3-D H-pt nest boundary variables - ENDIF -! - IF(NVARS_BC_4D_H>0)THEN - ALLOCATE(BND_VARS_H%VAR_4D(1:NVARS_BC_4D_H)) !<-- All 4-D H-pt nest boundary variables - ENDIF -! - IF(NVARS_BC_2D_V>0)THEN - ALLOCATE(BND_VARS_V%VAR_2D(1:NVARS_BC_2D_V)) !<-- All 2-D V-pt nest boundary variables - ENDIF -! - IF(NVARS_BC_3D_V>0)THEN - ALLOCATE(BND_VARS_V%VAR_3D(1:NVARS_BC_3D_V)) !<-- All 3-D V-pt nest boundary variables - ENDIF -! -!----------------------------------------------------------------------- -!*** Now go through the boundary Bundle's variables and point the -!*** full variable pointer of the appropriate boundary object that -!*** was allocated immediately above at that variable in the Bundle -!*** in order to associate each piece of the boundary object with -!*** the actual boundary variable. -!----------------------------------------------------------------------- -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=BUNDLE_NESTBC & !<-- Bundle holding the arrays for BC updates - ,fieldCount =NUM_FIELDS & !<-- Number of Fields in the Bundle - ,rc =RC ) -! -!----------------------------------------------------------------------- -! - KNT_2D_H=0 - KNT_3D_H=0 - KNT_4D_H=0 - KNT_2D_V=0 - KNT_3D_V=0 -! -!----------------------------------------------------------------------- -! - bc_fields: DO N=1,NUM_FIELDS -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Field N from the Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=BUNDLE_NESTBC & !<-- Bundle holding the arrays for BC updates - ,fieldIndex =N & !<-- Index of the Field in the Bundle - ,field =FIELD_X & !<-- Field N in the Bundle - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CMB) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract H_OR_V Flag from the Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(field=FIELD_X & !<-- The Domain import state - ,name ='H_OR_V_INT' & !<-- Name of the Attribute - ,value=H_OR_V_INT & !<-- Is the Field on H or V points? (1 is H; 2 is V) - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CMB) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------- -!*** H-pt boundary variables -!----------------------------- -! - h_v: IF(H_OR_V_INT==1)THEN !<-- If true, it is an H-pt variable -! - CALL ESMF_FieldGet(field =FIELD_X & !<-- Field N in the Bundle - ,dimCount=NUM_DIMS & !<-- How many dimensions? - ,rc =RC ) -! -!-------------- -!*** 2-D Real -!-------------- -! - IF(NUM_DIMS==2)THEN -! - KNT_2D_H=KNT_2D_H+1 -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract the 2-D H-pt Array from the Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =FIELD_X & !<-- Field N in the Bundle - ,localDe =0 & - ,farrayPtr=ARRAY_2D & !<-- Dummy 2-D array with Field's Real data - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CMB) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - BND_VARS_H%VAR_2D(KNT_2D_H)%FULL_VAR=>ARRAY_2D !<-- This variable becomes a boundary variable -! - ALLOCATE(BND_VARS_H%VAR_2D(KNT_2D_H)%SOUTH(IMS:IME,1:LNSH,1:2) & !<-- 2-D H-pt boundary variable N on domain's south side - ,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,45001)ISTAT -45001 FORMAT(' Failed to allocate BND_VARS_H%VAR_2D(N)%SOUTH istat=',i5) - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - ALLOCATE(BND_VARS_H%VAR_2D(KNT_2D_H)%NORTH(IMS:IME,1:LNSH,1:2) & !<-- 2-D H-pt boundary variable N on domain's north side - ,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,45002)ISTAT -45002 FORMAT(' Failed to allocate BND_VARS_H%VAR_2D(N)%NORTH istat=',i5) - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - ALLOCATE(BND_VARS_H%VAR_2D(KNT_2D_H)%WEST(1:LNSH,JMS:JME,1:2) & !<-- 2-D H-pt boundary variable N on domain's west side - ,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,45003)ISTAT -45003 FORMAT(' Failed to allocate BND_VARS_H%VAR_2D(N)%WEST istat=',i5) - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - ALLOCATE(BND_VARS_H%VAR_2D(KNT_2D_H)%EAST(1:LNSH,JMS:JME,1:2) & !<-- 2-D H-pt boundary variable N on domain's east side - ,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,45004)ISTAT -45004 FORMAT(' Failed to allocate BND_VARS_H%VAR_2D(N)%EasT istat=',i5) - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - BND_VARS_H%VAR_2D(KNT_2D_H)%SOUTH=R4_IN - BND_VARS_H%VAR_2D(KNT_2D_H)%NORTH=R4_IN - BND_VARS_H%VAR_2D(KNT_2D_H)%WEST=R4_IN - BND_VARS_H%VAR_2D(KNT_2D_H)%EAST=R4_IN -! -!-------------- -!*** 3-D Real -!-------------- -! - ELSEIF(NUM_DIMS==3)THEN -! - KNT_3D_H=KNT_3D_H+1 -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract the 3-D H-pt Array from the Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =FIELD_X & !<-- Field N in the Bundle - ,localDe =0 & - ,farrayPtr=ARRAY_3D & !<-- Dummy 3-D array with Field's Real data - ,rc =RC ) -! - CALL ESMF_FieldGet(field=FIELD_X & !<-- Field N in the Bundle - ,name =FIELD_NAME & !<-- This Field's name - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CMB) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - BND_VARS_H%VAR_3D(KNT_3D_H)%FULL_VAR=>ARRAY_3D !<-- This variable becomes a boundary variable -! - LB3=LBOUND(ARRAY_3D,3) - UB3=UBOUND(ARRAY_3D,3) -! - ALLOCATE(BND_VARS_H%VAR_3D(KNT_3D_H)%SOUTH(IMS:IME,1:LNSH,LB3:UB3,1:2) & !<-- 3-D H-pt bndry vbl N on domain's south side - ,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,45011)ISTAT -45011 FORMAT(' Failed to allocate BND_VARS_H%VAR_3D(N)%SOUTH istat=',i5) - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - ALLOCATE(BND_VARS_H%VAR_3D(KNT_3D_H)%NORTH(IMS:IME,1:LNSH,LB3:UB3,1:2) & !<-- 3-D H-pt bndry vbl N on domain's north side - ,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,45012)ISTAT -45012 FORMAT(' Failed to allocate BND_VARS_H%VAR_3D(N)%NORTH istat=',i5) - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - ALLOCATE(BND_VARS_H%VAR_3D(KNT_3D_H)%WEST(1:LNSH,JMS:JME,LB3:UB3,1:2) & !<-- 3-D H-pt bndry vbl N on domain's west side - ,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,45013)ISTAT -45013 FORMAT(' Failed to allocate BND_VARS_H%VAR_3D(N)%WEST istat=',i5) - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - ALLOCATE(BND_VARS_H%VAR_3D(KNT_3D_H)%EAST(1:LNSH,JMS:JME,LB3:UB3,1:2) & !<-- 3-D H-pt bndry vbl N on domain's east side - ,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,45014)ISTAT -45014 FORMAT(' Failed to allocate BND_VARS_H%VAR_3D(N)%EAST istat=',i5) - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - BND_VARS_H%VAR_3D(KNT_3D_H)%SOUTH=R4_IN - BND_VARS_H%VAR_3D(KNT_3D_H)%NORTH=R4_IN - BND_VARS_H%VAR_3D(KNT_3D_H)%WEST=R4_IN - BND_VARS_H%VAR_3D(KNT_3D_H)%EAST=R4_IN -! -!----------------------------------------------------------------------- -!*** Now some hardwiring is required. The same boundary objects -!*** are of course used by all domains but the arrays for the -!*** upper domain will be read in from the external boco files -!*** when that domain is not global. The boundary objects store -!*** the arrays in the order they are encountered in the nests.txt -!*** file and in general that order will be different than the -!*** order they are read from the boco files. Therefore we now -!*** save the order of the three 3-D H-pt boundary arrays used -!*** by the upper parent so they can be saved in the proper order -!*** when they are read in subroutine READ_BC. The order in which -!*** READ_BC reads them from the boco files is T,Q,CW. -!*** REGRETTABLY THIS IS DIRTY but is needed since all domains -!*** must use the same boundary objects but the dataread in -!*** READ_BC is fixed in its order in NPS. -!----------------------------------------------------------------------- -! - IF(FIELD_NAME(1:1)=='T' & - .OR. & - FIELD_NAME(1:1)=='Q' & - .OR. & - FIELD_NAME(1:2)=='CW')THEN -! - KNT_3D_DOM_01=KNT_3D_DOM_01+1 -! - IF(FIELD_NAME(1:1)=='T')THEN - N_BC_3D_H(1)=KNT_3D_DOM_01 - ELSEIF(FIELD_NAME(1:1)=='Q')THEN - N_BC_3D_H(2)=KNT_3D_DOM_01 - ELSEIF(FIELD_NAME(1:2)=='CW')THEN - N_BC_3D_H(3)=KNT_3D_DOM_01 - ENDIF -! - ENDIF -! -!-------------- -!*** 4-D Real -!-------------- -! - ELSEIF(NUM_DIMS==4)THEN -! - KNT_4D_H=KNT_4D_H+1 -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract the 4-D H-pt Array from the Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =FIELD_X & !<-- Field N in the Bundle - ,localDe =0 & - ,farrayPtr=ARRAY_4D & !<-- Dummy 4-D array with Field's Real data - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CMB) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - BND_VARS_H%VAR_4D(KNT_4D_H)%FULL_VAR=>ARRAY_4D !<-- This variable becomes a boundary variable -! - LB3=LBOUND(ARRAY_4D,3) - UB3=UBOUND(ARRAY_4D,3) - LB4=LBOUND(ARRAY_4D,4) - UB4=UBOUND(ARRAY_4D,4) -! - ALLOCATE(BND_VARS_H%VAR_4D(KNT_4D_H)%SOUTH(IMS:IME,1:LNSH,LB4:UB4,1:2,LB4:UB4) & !<-- 4-D H-pt bndry vbl N on domain's south side - ,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,45021)ISTAT -45021 FORMAT(' Failed to allocate BND_VARS_H%VAR_4D(N)%SOUTH istat=',i5) - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - ALLOCATE(BND_VARS_H%VAR_4D(KNT_4D_H)%NORTH(IMS:IME,1:LNSH,LB3:UB3,1:2,LB4:UB4) & !<-- 4-D H-pt bndry vbl N on domain's north side - ,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,45022)ISTAT -45022 FORMAT(' Failed to allocate BND_VARS_H%VAR_4D(N)%NORTH istat=',i5) - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - ALLOCATE(BND_VARS_H%VAR_4D(KNT_4D_H)%WEST(1:LNSH,JMS:JME,LB3:UB3,1:2,LB4:UB4) & !<-- 4-D H-pt bndry vbl N on domain's west side - ,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,45023)ISTAT -45023 FORMAT(' Failed to allocate BND_VARS_H%VAR_4D(N)%WEST istat=',i5) - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - ALLOCATE(BND_VARS_H%VAR_4D(KNT_4D_H)%EAST(1:LNSH,JMS:JME,LB3:UB3,1:2,LB4:UB4) & !<-- 4-D H-pt bndry vbl N on domain's east side - ,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,45024)ISTAT -45024 FORMAT(' Failed to allocate BND_VARS_H%VAR_4D(N)%EAST istat=',i5) - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - BND_VARS_H%VAR_4D(KNT_4D_H)%SOUTH=R4_IN - BND_VARS_H%VAR_4D(KNT_4D_H)%NORTH=R4_IN - BND_VARS_H%VAR_4D(KNT_4D_H)%WEST=R4_IN - BND_VARS_H%VAR_4D(KNT_4D_H)%EAST=R4_IN -! - ENDIF -! -!----------------------------- -!*** V-pt boundary variables -!----------------------------- -! - ELSEIF(H_OR_V_INT==2)THEN -! - CALL ESMF_FieldGet(field =FIELD_X & !<-- Field N in the Bundle - ,dimCount=NUM_DIMS & !<-- How many dimensions? - ,rc =RC ) -! -!-------------- -!*** 2-D Real -!-------------- -! - IF(NUM_DIMS==2)THEN -! - KNT_2D_V=KNT_2D_V+1 -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract the 2-D V-pt Array from the Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =FIELD_X & !<-- Field N in the Bundle - ,localDe =0 & - ,farrayPtr=ARRAY_2D & !<-- Dummy 2-D array with Field's Real data - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CMB) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - BND_VARS_V%VAR_2D(KNT_2D_V)%FULL_VAR=>ARRAY_2D !<-- This variable becomes a boundary variable -! - ALLOCATE(BND_VARS_V%VAR_2D(KNT_2D_V)%SOUTH(IMS:IME,1:LNSV,1:2) & !<-- 2-D V-pt bndry vbl N on domain's south side - ,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,45041)ISTAT -45041 FORMAT(' Failed to allocate BND_VARS_V%VAR_2D(N)%SOUTH istat=',i5) - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - ALLOCATE(BND_VARS_V%VAR_2D(KNT_2D_V)%NORTH(IMS:IME,1:LNSV,1:2) & !<-- 2-D V-pt bndry vbl N on domain's north side - ,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,45042)ISTAT -45042 FORMAT(' Failed to allocate BND_VARS_V%VAR_2D(N)%NORTH istat=',i5) - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - ALLOCATE(BND_VARS_V%VAR_2D(KNT_2D_V)%WEST(1:LNSV,JMS:JME,1:2) & !<-- 2-D V-pt bndry vbl N on domain's west side - ,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,45043)ISTAT -45043 FORMAT(' Failed to allocate BND_VARS_V%VAR_2D(N)%WEST istat=',i5) - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - ALLOCATE(BND_VARS_V%VAR_2D(KNT_2D_V)%EAST(1:LNSV,JMS:JME,1:2) & !<-- 2-D V-pt bndry vbl N on domain's east side - ,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,45044)ISTAT -45044 FORMAT(' Failed to allocate BND_VARS_V%VAR_2D(N)%EAST istat=',i5) - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - BND_VARS_V%VAR_2D(KNT_2D_V)%SOUTH=R4_IN - BND_VARS_V%VAR_2D(KNT_2D_V)%NORTH=R4_IN - BND_VARS_V%VAR_2D(KNT_2D_V)%WEST=R4_IN - BND_VARS_V%VAR_2D(KNT_2D_V)%EAST=R4_IN -! -!-------------- -!*** 3-D Real -!-------------- -! - ELSEIF(NUM_DIMS==3)THEN -! - KNT_3D_V=KNT_3D_V+1 -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract the 3-D V-pt Array from the Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =FIELD_X & !<-- Field N in the Bundle - ,localDe =0 & - ,farrayPtr=ARRAY_3D & !<-- Dummy 3-D array with Field's Real data - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CMB) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - BND_VARS_V%VAR_3D(KNT_3D_V)%FULL_VAR=>ARRAY_3D !<-- This variable becomes a boundary variable -! - LB3=LBOUND(ARRAY_3D,3) - UB3=UBOUND(ARRAY_3D,3) -! - ALLOCATE(BND_VARS_V%VAR_3D(KNT_3D_V)%SOUTH(IMS:IME,1:LNSV,LB3:UB3,1:2) & !<-- 3-D V-pt bndry vbl N on domain's south side - ,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,45051)ISTAT -45051 FORMAT(' Failed to allocate BND_VARS_V%VAR_3D(N)%SOUTH istat=',i5) - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - ALLOCATE(BND_VARS_V%VAR_3D(KNT_3D_V)%NORTH(IMS:IME,1:LNSV,LB3:UB3,1:2) & !<-- 3-D V-pt bndry vbl N on domain's north side - ,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,45052)ISTAT -45052 FORMAT(' Failed to allocate BND_VARS_V%VAR_3D(N)%NORTH istat=',i5) - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - ALLOCATE(BND_VARS_V%VAR_3D(KNT_3D_V)%WEST(1:LNSV,JMS:JME,LB3:UB3,1:2) & !<-- 3-D V-pt bndry vbl N on domain's west side - ,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,45053)ISTAT -45053 FORMAT(' Failed to allocate BND_VARS_V%VAR_3D(N)%WEST istat=',i5) - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - ALLOCATE(BND_VARS_V%VAR_3D(KNT_3D_V)%EAST(1:LNSV,JMS:JME,LB3:UB3,1:2) & !<-- 3-D V-pt bndry vbl N on domain's east side - ,stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,45054)ISTAT -45054 FORMAT(' Failed to allocate BND_VARS_V%VAR_3D(N)%EAST istat=',i5) - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT) - ENDIF -! - BND_VARS_V%VAR_3D(KNT_3D_V)%SOUTH=R4_IN - BND_VARS_V%VAR_3D(KNT_3D_V)%NORTH=R4_IN - BND_VARS_V%VAR_3D(KNT_3D_V)%WEST=R4_IN - BND_VARS_V%VAR_3D(KNT_3D_V)%EAST=R4_IN -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF h_v -! -!----------------------------------------------------------------------- -! - ENDDO bc_fields -! -!----------------------------------------------------------------------- -! - END SUBROUTINE BUILD_BC_BUNDLE -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE UPDATE_BC_TENDS(IMP_STATE & - ,LM,LNSH,LNSV & - ,PARENT_CHILD_TIME_RATIO,DT & - ,S_BDY,N_BDY,W_BDY,E_BDY & - ,NLEV_H,NLEV_V & - ,NVARS_BC_2D_H & - ,NVARS_BC_3D_H & - ,NVARS_BC_4D_H & - ,NVARS_BC_2D_V & - ,NVARS_BC_3D_V & - ,BND_VARS_H & - ,BND_VARS_V & - ,ITS,ITE,JTS,JTE & - ,IMS,IME,JMS,JME & - ,IDS,IDE,JDS,JDE ) -! -!----------------------------------------------------------------------- -!*** This routine extracts boundary data from the Solver import -!*** state of nested domains that was received from their parents. -!*** This data is then used to update the time tendencies of the -!*** boundary variables. Those tendencies are valid through each -!*** timestep of the nested domain's parent. -!*** Note that this data was first loaded into the export state of -!*** the Parent-Child coupler in subroutine EXPORT_CHILD_BOUNDARY. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER,INTENT(IN) :: LNSH & !<-- # of boundary blending rows for H points - ,LNSV & !<-- # of boundary blending rows for V points - ,NLEV_H,NLEV_V & !<-- Total # of levels in H-pt,V-pt BC vbls - ,NVARS_BC_2D_H,NVARS_BC_3D_H,NVARS_BC_4D_H & !<-- # of multi-dim H-pt boundary variables - ,NVARS_BC_2D_V,NVARS_BC_3D_V & !<-- # of multi-dim V-pt boundary variables - ,PARENT_CHILD_TIME_RATIO !<-- # of child timesteps per parent timestep -! - INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE & ! - ,IMS,IME,JMS,JME & !<-- Array dimensions - ,ITS,ITE,JTS,JTE & ! - ,LM ! -! - REAL,INTENT(IN) :: DT !<-- This domain's fundamental timestep -! - LOGICAL(kind=KLOG),INTENT(IN) :: E_BDY,N_BDY,S_BDY,W_BDY !<-- Is this task on any side of its domain boundary? -! - TYPE(ESMF_State),INTENT(INOUT) :: IMP_STATE !<-- Solver import state -! - TYPE(BC_H_ALL),INTENT(INOUT) :: BND_VARS_H !<-- All H-pt boundary data/tendencies -! - TYPE(BC_V_ALL),INTENT(INOUT) :: BND_VARS_V !<-- All V-pt boundary data/tendencies -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: I1,I2_H,I2_V,J1,J2_H,J2_V -! - INTEGER(kind=KINT) :: KOUNT_S_H,KOUNT_S_V,KOUNT_N_H,KOUNT_N_V & - ,KOUNT_W_H,KOUNT_W_V,KOUNT_E_H,KOUNT_E_V -! - INTEGER(kind=KINT) :: I,J,K,KOUNT,LBND,NL,NV,UBND - INTEGER(kind=KINT) :: ISTAT,RC,RC_BCT -! - REAL,SAVE :: RECIP -! - REAL,DIMENSION(:),ALLOCATABLE :: BND_DATA_S_H & - ,BND_DATA_S_V & - ,BND_DATA_N_H & - ,BND_DATA_N_V & - ,BND_DATA_W_H & - ,BND_DATA_W_V & - ,BND_DATA_E_H & - ,BND_DATA_E_V -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RC_BCT=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** Gridpoint index limits along the South/North and West/East -!*** boundaries for mass (H) and velocity (V) points. Note that -!*** the boundary data goes two points into the halo. -!----------------------------------------------------------------------- -! - I1 =MAX(ITS-2,IDS) - I2_H=MIN(ITE+2,IDE) - I2_V=MIN(ITE+2,IDE-1) - J1 =MAX(JTS-2,JDS) - J2_H=MIN(JTE+2,JDE) - J2_V=MIN(JTE+2,JDE-1) -! -!----------------------------------------------------------------------- -!*** The following 'KOUNT' variables are the number of gridpoints -!*** on the given task subdomain's South/North/West/East boundaries -!*** for all 2-D,3-D,4-D quantities on mass and velocity points. -!----------------------------------------------------------------------- -! - KOUNT_S_H=NLEV_H*(I2_H-I1+1)*LNSH - KOUNT_N_H=NLEV_H*(I2_H-I1+1)*LNSH - KOUNT_S_V=NLEV_V*(I2_V-I1+1)*LNSV - KOUNT_N_V=NLEV_V*(I2_V-I1+1)*LNSV - KOUNT_W_H=NLEV_H*(J2_H-J1+1)*LNSH - KOUNT_E_H=NLEV_H*(J2_H-J1+1)*LNSH - KOUNT_W_V=NLEV_V*(J2_V-J1+1)*LNSV - KOUNT_E_V=NLEV_V*(J2_V-J1+1)*LNSV -! -!----------------------------------------------------------------------- -!*** Compute RECIP every time in case the sign of DT has changed -!*** due to digital filtering. -!----------------------------------------------------------------------- -! - RECIP=1./(DT*PARENT_CHILD_TIME_RATIO) -! -!----------------------------------------------------------------------- -!*** Unload the boundary data from the import state and compute -!*** the time tendencies for the time period spanning the number -!*** of this nest's timesteps needed to reach the end of its -!*** parent's timestep (from which the data was sent). -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** If this is a moving nest SOLVER_RUN already knows if it moved at -!*** the beginning of this timestep. If it has then the import state -!*** not only contains the usual boundary data from one parent timestep -!*** in the future but it also contains boundary data for the current -!*** timestep for the domain's new location. We would then need to -!*** fill the current time level of the boundary variable arrays -!*** before differencing with the values from the future to obtain -!*** the tendencies. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! - south: IF(S_BDY)THEN -! -!----------------------------------------------------------------------- -! -!------------- -!*** South H -!------------- -! - ALLOCATE(BND_DATA_S_H(1:KOUNT_S_H)) !<-- For south boundary H-pt data from Solver import state -! - move_now_south_h: IF(MOVE_NOW)THEN -! -!----------------------------------------------------------------------- -!*** Time level 1 (current) south boundary H values for new location -!*** of this nest. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract South Boundary H Data in UPDATE_BC_TENDS for Time N" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- Solver import state - ,name ='SOUTH_H_Current' & !<-- Name of south boundary H data at time N - ,valueList=BND_DATA_S_H & !<-- The south boundary H data at time N - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BCT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - KOUNT=0 -! - IF(NVARS_BC_2D_H>0)THEN - DO NV=1,NVARS_BC_2D_H - DO J=1,LNSH - DO I=I1,I2_H - KOUNT=KOUNT+1 - BND_VARS_H%VAR_2D(NV)%SOUTH(I,J,1)=BND_DATA_S_H(KOUNT) - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - DO K=1,LM - DO J=1,LNSH - DO I=I1,I2_H - KOUNT=KOUNT+1 - BND_VARS_H%VAR_3D(NV)%SOUTH(I,J,K,1)=BND_DATA_S_H(KOUNT) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - LBND=LBOUND(BND_VARS_H%VAR_4D(NV)%FULL_VAR,4) - UBND=UBOUND(BND_VARS_H%VAR_4D(NV)%FULL_VAR,4) - DO NL=LBND,UBND - DO K=1,LM - DO J=1,LNSH - DO I=I1,I2_H - KOUNT=KOUNT+1 - BND_VARS_H%VAR_4D(NV)%SOUTH(I,J,K,1,NL)=BND_DATA_S_H(KOUNT) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - ENDIF move_now_south_h -! -!----------------------------------------------------------------------- -!*** Use time level 2 (future) south boundary H values to compute -!*** new tendencies. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract South Boundary H Data in UPDATE_BC_TENDS for Time N+1" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- Solver import state - ,name ='SOUTH_H_Future' & !<-- Name of south boundary H data at time N+1 - ,valueList=BND_DATA_S_H & !<-- The boundary data - ,rc =RC ) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BCT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - KOUNT=0 -! - IF(NVARS_BC_2D_H>0)THEN - DO NV=1,NVARS_BC_2D_H - DO J=1,LNSH - DO I=I1,I2_H - KOUNT=KOUNT+1 - BND_VARS_H%VAR_2D(NV)%SOUTH(I,J,2)= & - (BND_DATA_S_H(KOUNT)-BND_VARS_H%VAR_2D(NV)%SOUTH(I,J,1))*RECIP - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - DO K=1,LM - DO J=1,LNSH - DO I=I1,I2_H - KOUNT=KOUNT+1 - BND_VARS_H%VAR_3D(NV)%SOUTH(I,J,K,2)= & - (BND_DATA_S_H(KOUNT)-BND_VARS_H%VAR_3D(NV)%SOUTH(I,J,K,1))*RECIP - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - LBND=LBOUND(BND_VARS_H%VAR_4D(NV)%FULL_VAR,4) - UBND=UBOUND(BND_VARS_H%VAR_4D(NV)%FULL_VAR,4) - DO NL=LBND,UBND - DO K=1,LM - DO J=1,LNSH - DO I=I1,I2_H - KOUNT=KOUNT+1 - BND_VARS_H%VAR_4D(NV)%SOUTH(I,J,K,2,NL)= & - (BND_DATA_S_H(KOUNT)-BND_VARS_H%VAR_4D(NV)%SOUTH(I,J,K,1,NL))*RECIP - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - DEALLOCATE(BND_DATA_S_H) -! -!------------- -!*** South V -!------------- -! - ALLOCATE(BND_DATA_S_V(1:KOUNT_S_V)) !<-- For south boundary V-pt data from Solver import state -! - move_now_south_v: IF(MOVE_NOW)THEN -! -!----------------------------------------------------------------------- -!*** Time level 1 (current) south boundary V values for new location -!*** of this nest. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract South Boundary V Data in UPDATE_BC_TENDS for Time N" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- Solver import state - ,name ='SOUTH_V_Current' & !<-- Name of south boundary V data at time N - ,valueList=BND_DATA_S_V & !<-- The south boundary V data at time N - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BCT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - KOUNT=0 -! - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - DO J=1,LNSV - DO I=I1,I2_V - KOUNT=KOUNT+1 - BND_VARS_V%VAR_2D(NV)%SOUTH(I,J,1)=BND_DATA_S_V(KOUNT) - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - DO K=1,LM - DO J=1,LNSV - DO I=I1,I2_V - KOUNT=KOUNT+1 - BND_VARS_V%VAR_3D(NV)%SOUTH(I,J,K,1)=BND_DATA_S_V(KOUNT) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - ENDIF move_now_south_v -! -!----------------------------------------------------------------------- -!*** Use time level 2 (future) south boundary V values to compute -!*** new tendencies. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract South Boundary V Data in UPDATE_BC_TENDS" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- Solver import state - ,name ='SOUTH_V_Future' & !<-- Name of south boundary V data at time N+1 - ,valueList=BND_DATA_S_V & !<-- The boundary data - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BCT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - KOUNT=0 -! - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - DO J=1,LNSV - DO I=I1,I2_V - KOUNT=KOUNT+1 - BND_VARS_V%VAR_2D(NV)%SOUTH(I,J,2)= & - (BND_DATA_S_V(KOUNT)-BND_VARS_V%VAR_2D(NV)%SOUTH(I,J,1))*RECIP - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - DO K=1,LM - DO J=1,LNSV - DO I=I1,I2_V - KOUNT=KOUNT+1 - BND_VARS_V%VAR_3D(NV)%SOUTH(I,J,K,2)= & - (BND_DATA_S_V(KOUNT)-BND_VARS_V%VAR_3D(NV)%SOUTH(I,J,K,1))*RECIP - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - DEALLOCATE(BND_DATA_S_V) -! - ENDIF south -! -!----------------------------------------------------------------------- -! - north: IF(N_BDY)THEN -! -!----------------------------------------------------------------------- -! -!------------- -!*** North H -!------------- -! - ALLOCATE(BND_DATA_N_H(1:KOUNT_N_H),stat=ISTAT) !<-- For north boundary H-pt data from Solver import state -! - move_now_north_h: IF(MOVE_NOW)THEN -! -!----------------------------------------------------------------------- -!*** Time level 1 (current) north boundary H values for new location -!*** of this nest. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract North Boundary H Data in UPDATE_BC_TENDS for Time N" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- Solver import state - ,name ='NORTH_H_Current' & !<-- Name of north boundary H data at time N - ,valueList=BND_DATA_N_H & !<-- The north boundary H data at time N - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BCT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - KOUNT=0 -! - IF(NVARS_BC_2D_H>0)THEN - DO NV=1,NVARS_BC_2D_H - DO J=1,LNSH - DO I=I1,I2_H - KOUNT=KOUNT+1 - BND_VARS_H%VAR_2D(NV)%NORTH(I,J,1)=BND_DATA_N_H(KOUNT) - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - DO K=1,LM - DO J=1,LNSH - DO I=I1,I2_H - KOUNT=KOUNT+1 - BND_VARS_H%VAR_3D(NV)%NORTH(I,J,K,1)=BND_DATA_N_H(KOUNT) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - LBND=LBOUND(BND_VARS_H%VAR_4D(NV)%FULL_VAR,4) - UBND=UBOUND(BND_VARS_H%VAR_4D(NV)%FULL_VAR,4) - DO NL=LBND,UBND - DO K=1,LM - DO J=1,LNSH - DO I=I1,I2_H - KOUNT=KOUNT+1 - BND_VARS_H%VAR_4D(NV)%NORTH(I,J,K,1,NL)=BND_DATA_N_H(KOUNT) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - ENDIF move_now_north_h -! -!----------------------------------------------------------------------- -!*** Use time level 2 (future) north boundary H values to compute -!*** new tendencies. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract North Boundary H Data in UPDATE_BC_TENDS for time N+1" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- Solver import state - ,name ='NORTH_H_Future' & !<-- Name of north boundary H data for time N+1 - ,valueList=BND_DATA_N_H & !<-- The boundary data - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BCT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - KOUNT=0 -! - IF(NVARS_BC_2D_H>0)THEN - DO NV=1,NVARS_BC_2D_H - DO J=1,LNSH - DO I=I1,I2_H - KOUNT=KOUNT+1 - BND_VARS_H%VAR_2D(NV)%NORTH(I,J,2)= & - (BND_DATA_N_H(KOUNT)-BND_VARS_H%VAR_2D(NV)%NORTH(I,J,1))*RECIP - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - DO K=1,LM - DO J=1,LNSH - DO I=I1,I2_H - KOUNT=KOUNT+1 - BND_VARS_H%VAR_3D(NV)%NORTH(I,J,K,2)= & - (BND_DATA_N_H(KOUNT)-BND_VARS_H%VAR_3D(NV)%NORTH(I,J,K,1))*RECIP - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - LBND=LBOUND(BND_VARS_H%VAR_4D(NV)%FULL_VAR,4) - UBND=UBOUND(BND_VARS_H%VAR_4D(NV)%FULL_VAR,4) - DO NL=LBND,UBND - DO K=1,LM - DO J=1,LNSH - DO I=I1,I2_H - KOUNT=KOUNT+1 - BND_VARS_H%VAR_4D(NV)%NORTH(I,J,K,2,NL)= & - (BND_DATA_N_H(KOUNT)-BND_VARS_H%VAR_4D(NV)%NORTH(I,J,K,1,NL))*RECIP - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - DEALLOCATE(BND_DATA_N_H) -! -!------------- -!*** North V -!------------- -! - ALLOCATE(BND_DATA_N_V(1:KOUNT_N_V)) !<-- For north boundary V-pt data from Solver import state -! - move_now_north_v: IF(MOVE_NOW)THEN -! -!----------------------------------------------------------------------- -!*** Time level 1 (current) north boundary V values for new location -!*** of this nest. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract North Boundary V Data in UPDATE_BC_TENDS for Time N" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- Solver import state - ,name ='NORTH_V_Current' & !<-- Name of north boundary V data at time N - ,valueList=BND_DATA_N_V & !<-- The north boundary V data at time N - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BCT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - KOUNT=0 -! - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - DO J=1,LNSV - DO I=I1,I2_V - KOUNT=KOUNT+1 - BND_VARS_V%VAR_2D(NV)%NORTH(I,J,1)=BND_DATA_S_V(KOUNT) - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - DO K=1,LM - DO J=1,LNSV - DO I=I1,I2_V - KOUNT=KOUNT+1 - BND_VARS_V%VAR_3D(NV)%NORTH(I,J,K,1)=BND_DATA_N_V(KOUNT) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - ENDIF move_now_north_v -! -!----------------------------------------------------------------------- -!*** Use time level 2 (future) north boundary H values to compute -!*** new tendencies. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract North Boundary V Data in UPDATE_BC_TENDS for Time N+1" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- Solver import state - ,name ='NORTH_V_Future' & !<-- Name of north boundary V data at time N+1 - ,valueList=BND_DATA_N_V & !<-- The boundary data - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BCT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - KOUNT=0 -! - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - DO J=1,LNSV - DO I=I1,I2_V - KOUNT=KOUNT+1 - BND_VARS_V%VAR_2D(NV)%NORTH(I,J,2)= & - (BND_DATA_N_V(KOUNT)-BND_VARS_V%VAR_2D(NV)%NORTH(I,J,1))*RECIP - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - DO K=1,LM - DO J=1,LNSV - DO I=I1,I2_V - KOUNT=KOUNT+1 - BND_VARS_V%VAR_3D(NV)%NORTH(I,J,K,2)= & - (BND_DATA_N_V(KOUNT)-BND_VARS_V%VAR_3D(NV)%NORTH(I,J,K,1))*RECIP - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - DEALLOCATE(BND_DATA_N_V) -! - ENDIF north -! -!----------------------------------------------------------------------- -! - west: IF(W_BDY)THEN -! -!----------------------------------------------------------------------- -! -!------------ -!*** West H -!------------ -! - ALLOCATE(BND_DATA_W_H(1:KOUNT_W_H)) !<-- For west boundary H-pt data from Solver import state -! - move_now_west_h: IF(MOVE_NOW)THEN -! -!----------------------------------------------------------------------- -!*** Time level 1 (current) west boundary H values for new location -!*** of this nest. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract West Boundary H Data in UPDATE_BC_TENDS for Time N" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- Solver import state - ,name ='WEST_H_Current' & !<-- Name of west boundary H data at time N - ,valueList=BND_DATA_W_H & !<-- The west boundary H data at time N - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BCT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - KOUNT=0 -! - IF(NVARS_BC_2D_H>0)THEN - DO NV=1,NVARS_BC_2D_H - DO J=J1,J2_H - DO I=1,LNSH - KOUNT=KOUNT+1 - BND_VARS_H%VAR_2D(NV)%WEST(I,J,1)=BND_DATA_W_H(KOUNT) - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - DO K=1,LM - DO J=J1,J2_H - DO I=1,LNSH - KOUNT=KOUNT+1 - BND_VARS_H%VAR_3D(NV)%WEST(I,J,K,1)=BND_DATA_W_H(KOUNT) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - LBND=LBOUND(BND_VARS_H%VAR_4D(NV)%FULL_VAR,4) - UBND=UBOUND(BND_VARS_H%VAR_4D(NV)%FULL_VAR,4) - DO NL=LBND,UBND - DO K=1,LM - DO J=J1,J2_H - DO I=1,LNSH - KOUNT=KOUNT+1 - BND_VARS_H%VAR_4D(NV)%WEST(I,J,K,1,NL)=BND_DATA_W_H(KOUNT) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - ENDIF move_now_west_h -! -!----------------------------------------------------------------------- -!*** Use time level 2 (future) west boundary H values to compute -!*** new tendencies. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract West Boundary H Data in UPDATE_BC_TENDS at Time N+1" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- Solver import state - ,name ='WEST_H_Future' & !<-- Name of west boundary H data at time N+1 - ,valueList=BND_DATA_W_H & !<-- The boundary data - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BCT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - KOUNT=0 -! - IF(NVARS_BC_2D_H>0)THEN - DO NV=1,NVARS_BC_2D_H - DO J=J1,J2_H - DO I=1,LNSH - KOUNT=KOUNT+1 - BND_VARS_H%VAR_2D(NV)%WEST(I,J,2)= & - (BND_DATA_W_H(KOUNT)-BND_VARS_H%VAR_2D(NV)%WEST(I,J,1))*RECIP - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - DO K=1,LM - DO J=J1,J2_H - DO I=1,LNSH - KOUNT=KOUNT+1 - BND_VARS_H%VAR_3D(NV)%WEST(I,J,K,2)= & - (BND_DATA_W_H(KOUNT)-BND_VARS_H%VAR_3D(NV)%WEST(I,J,K,1))*RECIP - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - LBND=LBOUND(BND_VARS_H%VAR_4D(NV)%FULL_VAR,4) - UBND=UBOUND(BND_VARS_H%VAR_4D(NV)%FULL_VAR,4) - DO NL=LBND,UBND - DO K=1,LM - DO J=J1,J2_H - DO I=1,LNSH - KOUNT=KOUNT+1 - BND_VARS_H%VAR_4D(NV)%WEST(I,J,K,2,NL)= & - (BND_DATA_W_H(KOUNT)-BND_VARS_H%VAR_4D(NV)%WEST(I,J,K,1,NL))*RECIP - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - DEALLOCATE(BND_DATA_W_H) -! -!------------ -!*** West V -!------------ -! - ALLOCATE(BND_DATA_W_V(1:KOUNT_W_V)) !<-- For west boundary V-pt data from Solver import state -! - move_now_west_v: IF(MOVE_NOW)THEN -! -!----------------------------------------------------------------------- -!*** Time level 1 (current) west boundary V values for new location -!*** of this nest. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract West Boundary V Data in UPDATE_BC_TENDS for Time N" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- Solver import state - ,name ='WEST_V_Current' & !<-- Name of west boundary V data at time N - ,valueList=BND_DATA_W_V & !<-- The west boundary V data at time N - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BCT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - KOUNT=0 -! - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - DO J=J1,J2_V - DO I=1,LNSV - KOUNT=KOUNT+1 - BND_VARS_V%VAR_2D(NV)%WEST(I,J,1)=BND_DATA_W_V(KOUNT) - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - DO K=1,LM - DO J=J1,J2_V - DO I=1,LNSV - KOUNT=KOUNT+1 - BND_VARS_V%VAR_3D(NV)%WEST(I,J,K,1)=BND_DATA_W_V(KOUNT) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - ENDIF move_now_west_v -! -!----------------------------------------------------------------------- -!*** Use time level 2 (future) west boundary V values to compute -!*** new tendencies. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract West Boundary V Data in UPDATE_BC_TENDS at Time N+1" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- Solver import state - ,name ='WEST_V_Future' & !<-- Name of west boundary V data at time N+1 - ,valueList=BND_DATA_W_V & !<-- The boundary data - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BCT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - KOUNT=0 -! - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - DO J=J1,J2_V - DO I=1,LNSV - KOUNT=KOUNT+1 - BND_VARS_V%VAR_2D(NV)%WEST(I,J,2)= & - (BND_DATA_W_V(KOUNT)-BND_VARS_V%VAR_2D(NV)%WEST(I,J,1))*RECIP - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - DO K=1,LM - DO J=J1,J2_V - DO I=1,LNSV - KOUNT=KOUNT+1 - BND_VARS_V%VAR_3D(NV)%WEST(I,J,K,2)= & - (BND_DATA_W_V(KOUNT)-BND_VARS_V%VAR_3D(NV)%WEST(I,J,K,1))*RECIP - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - DEALLOCATE(BND_DATA_W_V) -! - ENDIF west -! -!----------------------------------------------------------------------- -! - east: IF(E_BDY)THEN -! -!----------------------------------------------------------------------- -! -!------------ -!*** East H -!------------ -! - ALLOCATE(BND_DATA_E_H(1:KOUNT_E_H)) !<-- For east boundary H-pt data from Solver import state -! - move_now_east_h: IF(MOVE_NOW)THEN -! -!----------------------------------------------------------------------- -!*** Time level 1 (current) east boundary H values for new location -!*** of this nest. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract East Boundary H Data in UPDATE_BC_TENDS for Time N" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- Solver import state - ,name ='EAST_H_Current' & !<-- Name of east boundary H data at time N - ,valueList=BND_DATA_E_H & !<-- The east boundary H data at time N - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BCT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - KOUNT=0 -! - IF(NVARS_BC_2D_H>0)THEN - DO NV=1,NVARS_BC_2D_H - DO J=J1,J2_H - DO I=1,LNSH - KOUNT=KOUNT+1 - BND_VARS_H%VAR_2D(NV)%EAST(I,J,1)=BND_DATA_E_H(KOUNT) - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - DO K=1,LM - DO J=J1,J2_H - DO I=1,LNSH - KOUNT=KOUNT+1 - BND_VARS_H%VAR_3D(NV)%EAST(I,J,K,1)=BND_DATA_E_H(KOUNT) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - LBND=LBOUND(BND_VARS_H%VAR_4D(NV)%FULL_VAR,4) - UBND=UBOUND(BND_VARS_H%VAR_4D(NV)%FULL_VAR,4) - DO NL=LBND,UBND - DO K=1,LM - DO J=J1,J2_H - DO I=1,LNSH - KOUNT=KOUNT+1 - BND_VARS_H%VAR_4D(NV)%EAST(I,J,K,1,NL)=BND_DATA_E_H(KOUNT) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - ENDIF move_now_east_h -! -!----------------------------------------------------------------------- -!*** Use time level 2 (future) east boundary H values to compute -!*** new tendencies. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract East Boundary H Data in UPDATE_BC_TENDS at Time N+1" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- Solver import state - ,name ='EAST_H_Future' & !<-- Name of east boundary H data at time N+1 - ,valueList=BND_DATA_E_H & !<-- The boundary data - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BCT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - KOUNT=0 -! - IF(NVARS_BC_2D_H>0)THEN - DO NV=1,NVARS_BC_2D_H - DO J=J1,J2_H - DO I=1,LNSH - KOUNT=KOUNT+1 - BND_VARS_H%VAR_2D(NV)%EAST(I,J,2)= & - (BND_DATA_E_H(KOUNT)-BND_VARS_H%VAR_2D(NV)%EAST(I,J,1))*RECIP - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - DO K=1,LM - DO J=J1,J2_H - DO I=1,LNSH - KOUNT=KOUNT+1 - BND_VARS_H%VAR_3D(NV)%EAST(I,J,K,2)= & - (BND_DATA_E_H(KOUNT)-BND_VARS_H%VAR_3D(NV)%EAST(I,J,K,1))*RECIP - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - LBND=LBOUND(BND_VARS_H%VAR_4D(NV)%FULL_VAR,4) - UBND=UBOUND(BND_VARS_H%VAR_4D(NV)%FULL_VAR,4) - DO NL=LBND,UBND - DO K=1,LM - DO J=J1,J2_H - DO I=1,LNSH - KOUNT=KOUNT+1 - BND_VARS_H%VAR_4D(NV)%EAST(I,J,K,2,NL)= & - (BND_DATA_E_H(KOUNT)-BND_VARS_H%VAR_4D(NV)%EAST(I,J,K,1,NL))*RECIP - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - DEALLOCATE(BND_DATA_E_H) -! -!------------ -!*** East V -!------------ -! - ALLOCATE(BND_DATA_E_V(1:KOUNT_E_V)) !<-- For east boundary V-pt data from Solver import state -! - move_now_east_v: IF(MOVE_NOW)THEN -! -!----------------------------------------------------------------------- -!*** Time level 1 (current) east boundary V values for new location -!*** of this nest. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract East Boundary V Data in UPDATE_BC_TENDS for Time N" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- Solver import state - ,name ='EAST_V_Current' & !<-- Name of esat boundary V data at time N - ,valueList=BND_DATA_E_V & !<-- The east boundary V data at time N - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BCT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - KOUNT=0 -! - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - DO J=J1,J2_V - DO I=1,LNSV - KOUNT=KOUNT+1 - BND_VARS_V%VAR_2D(NV)%EAST(I,J,1)=BND_DATA_E_V(KOUNT) - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - DO K=1,LM - DO J=J1,J2_V - DO I=1,LNSV - KOUNT=KOUNT+1 - BND_VARS_V%VAR_3D(NV)%EAST(I,J,K,1)=BND_DATA_E_V(KOUNT) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - ENDIF move_now_east_v -! -!----------------------------------------------------------------------- -!*** Use time level 2 (future) east boundary V values to compute -!*** new tendencies. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract East Boundary V Data in UPDATE_BC_TENDS for Time N+1" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE & !<-- Solver import state - ,name ='EAST_V_Future' & !<-- Name of east boundary V data at time N+1 - ,valueList=BND_DATA_E_V & !<-- The boundary data - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_BCT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - KOUNT=0 -! - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - DO J=J1,J2_V - DO I=1,LNSV - KOUNT=KOUNT+1 - BND_VARS_V%VAR_2D(NV)%EAST(I,J,2)= & - (BND_DATA_E_V(KOUNT)-BND_VARS_V%VAR_2D(NV)%EAST(I,J,1))*RECIP - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - DO K=1,LM - DO J=J1,J2_V - DO I=1,LNSV - KOUNT=KOUNT+1 - BND_VARS_V%VAR_3D(NV)%EAST(I,J,K,2)= & - (BND_DATA_E_V(KOUNT)-BND_VARS_V%VAR_3D(NV)%EAST(I,J,K,1))*RECIP - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - DEALLOCATE(BND_DATA_E_V) -! - ENDIF east -! -!----------------------------------------------------------------------- -! - END SUBROUTINE UPDATE_BC_TENDS -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE SAVE_BC_DATA(LM,LNSH,LNSV & - ,NVARS_BC_2D_H & - ,NVARS_BC_3D_H & - ,NVARS_BC_4D_H & - ,NVARS_BC_2D_V & - ,NVARS_BC_3D_V & - ,BND_VARS_H & - ,BND_VARS_V & - ,NUM_WORDS_BC_SOUTH,RST_BC_DATA_SOUTH & - ,NUM_WORDS_BC_NORTH,RST_BC_DATA_NORTH & - ,NUM_WORDS_BC_WEST ,RST_BC_DATA_WEST & - ,NUM_WORDS_BC_EAST ,RST_BC_DATA_EAST & - ,EXP_STATE_SOLVER & - ,ITS,ITE,JTS,JTE & - ,IMS,IME,JMS,JME & - ,IDS,IDE,JDS,JDE & - ) -! -!----------------------------------------------------------------------- -!*** Boundary array winds are needed in the restart file in order to -!*** achieve bit identical answers between restarted runs and their -!*** free-forecast analogs. The boundary arrays do not span the -!*** integration grid thus they can only be transmitted through -!*** ESMF States as Attributes. Non-scalar Attributes can only -!*** contain one dimension therefore the boundary data is moved -!*** into 1-D arrays in this routine then inserted into the -!*** Write component's import state. -!----------------------------------------------------------------------- -! -!--------------------- -!*** Input Arguments -!--------------------- -! - INTEGER(kind=KINT),INTENT(IN) :: LNSH & !<-- # of boundary blending rows for H points - ,LNSV & !<-- # of boundary blending rows for V points - ,NUM_WORDS_BC_SOUTH & !<-- Total # of words in south bndry winds, this fcst task - ,NUM_WORDS_BC_NORTH & !<-- Total # of words in north bndry winds, this fcst task - ,NUM_WORDS_BC_WEST & !<-- Total # of words in west bndry winds, this fcst task - ,NUM_WORDS_BC_EAST !<-- Total # of words in east bndry winds, this fcst task -! - INTEGER(kind=KINT),INTENT(IN) :: NVARS_BC_2D_H & - ,NVARS_BC_3D_H & - ,NVARS_BC_4D_H & - ,NVARS_BC_2D_V & - ,NVARS_BC_3D_V -! - INTEGER(kind=KINT),INTENT(IN) :: IDS,IDE,JDS,JDE & !<-- - ,IMS,IME,JMS,JME & !<-- Array dimensions - ,ITS,ITE,JTS,JTE & !<-- - ,LM !<-- -! - TYPE(BC_H_ALL),INTENT(IN) :: BND_VARS_H !<-- All H-pt boundary data/tendencies -! - TYPE(BC_V_ALL),INTENT(IN) :: BND_VARS_V !<-- All V-pt boundary data/tendencies -! -!--------------------- -!*** Inout Arguments -!--------------------- -! - TYPE(ESMF_State),INTENT(INOUT) :: EXP_STATE_SOLVER !<-- The Solver export state -! -!---------------------- -!*** Output Arguments -!---------------------- -! - REAL(kind=KFPT),DIMENSION(1:NUM_WORDS_BC_SOUTH),INTENT(OUT) :: & - RST_BC_DATA_SOUTH !<-- All south bndry wind data on this fcst task - REAL(kind=KFPT),DIMENSION(1:NUM_WORDS_BC_NORTH),INTENT(OUT) :: & - RST_BC_DATA_NORTH !<-- All north bndry wind data on this fcst task - REAL(kind=KFPT),DIMENSION(1:NUM_WORDS_BC_WEST ),INTENT(OUT) :: & - RST_BC_DATA_WEST !<-- All west bndry wind data on this fcst task - REAL(kind=KFPT),DIMENSION(1:NUM_WORDS_BC_EAST ),INTENT(OUT) :: & - RST_BC_DATA_EAST !<-- All east bndry wind data on this fcst task -! -!----------------------------------------------------------------------- -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: IB,JB,KOUNT,L,LBND,NL,NT,NV,UBND -! - INTEGER(kind=KINT) :: RC,RC_SAVE -! - TYPE(ESMF_State) :: IMP_STATE_WRITE -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Southern boundary data to 1-D -!----------------------------------------------------------------------- -! - IF(JTS==JDS)THEN !<-- Tasks on south boundary -! - KOUNT=0 -! - IF(NVARS_BC_2D_H>0)THEN - DO NV=1,NVARS_BC_2D_H - DO NT=1,2 - DO JB=1,LNSH - DO IB=ITS,ITE - KOUNT=KOUNT+1 - RST_BC_DATA_SOUTH(KOUNT)=BND_VARS_H%VAR_2D(NV)%SOUTH(IB,JB,NT) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - DO NT=1,2 - DO L=1,LM - DO JB=1,LNSH - DO IB=ITS,ITE - KOUNT=KOUNT+1 - RST_BC_DATA_SOUTH(KOUNT)=BND_VARS_H%VAR_3D(NV)%SOUTH(IB,JB,L,NT) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - LBND=LBOUND(BND_VARS_H%VAR_4D(NV)%FULL_VAR,4) - UBND=UBOUND(BND_VARS_H%VAR_4D(NV)%FULL_VAR,4) - DO NL=LBND,UBND - DO NT=1,2 - DO L=1,LM - DO JB=1,LNSH - DO IB=ITS,ITE - KOUNT=KOUNT+1 - RST_BC_DATA_SOUTH(KOUNT)=BND_VARS_H%VAR_4D(NV)%SOUTH(IB,JB,L,NT,NL) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - DO NT=1,2 - DO JB=1,LNSV - DO IB=ITS,ITE - KOUNT=KOUNT+1 - RST_BC_DATA_SOUTH(KOUNT)=BND_VARS_V%VAR_2D(NV)%SOUTH(IB,JB,NT) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - DO NT=1,2 - DO L=1,LM - DO JB=1,LNSV - DO IB=ITS,ITE - KOUNT=KOUNT+1 - RST_BC_DATA_SOUTH(KOUNT)=BND_VARS_V%VAR_3D(NV)%SOUTH(IB,JB,L,NT) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Write Import State in SAVE_BC_DATA" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =EXP_STATE_SOLVER & !<-- The Solver export state - ,itemName ='Write Import State' & !<-- Name of the state to get from Solver export state - ,nestedState=IMP_STATE_WRITE & !<-- Extract Write Component import state from Solver export - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_SAVE) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set BC South Data Attribute in SAVE_BC_DATA" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeSet(state =IMP_STATE_WRITE & !<-- The Write component import state - ,name ='RST_BC_DATA_SOUTH' & !<-- Name of 1-D string of south boundary values - ,itemCount=NUM_WORDS_BC_SOUTH & !<-- # of south boundary words on this fcst task - ,valueList=RST_BC_DATA_SOUTH & !<-- The 1-D data being inserted into the Write import state - ,rc =RC) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_SAVE) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Northern boundary data to 1-D -!----------------------------------------------------------------------- -! - IF(JTE==JDE)THEN !<-- Tasks on north boundary -! - KOUNT=0 -! - IF(NVARS_BC_2D_H>0)THEN - DO NV=1,NVARS_BC_2D_H - DO JB=1,LNSH - DO IB=ITS,ITE - KOUNT=KOUNT+1 - RST_BC_DATA_NORTH(KOUNT)=BND_VARS_H%VAR_2D(NV)%NORTH(IB,JB,1) - ENDDO - ENDDO - DO JB=1,LNSH - DO IB=ITS,ITE - KOUNT=KOUNT+1 - RST_BC_DATA_NORTH(KOUNT)=BND_VARS_H%VAR_2D(NV)%NORTH(IB,JB,2) - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - DO L=1,LM - DO JB=1,LNSH - DO IB=ITS,ITE - KOUNT=KOUNT+1 - RST_BC_DATA_NORTH(KOUNT)=BND_VARS_H%VAR_3D(NV)%NORTH(IB,JB,L,1) - ENDDO - ENDDO - ENDDO - DO L=1,LM - DO JB=1,LNSH - DO IB=ITS,ITE - KOUNT=KOUNT+1 - RST_BC_DATA_NORTH(KOUNT)=BND_VARS_H%VAR_3D(NV)%NORTH(IB,JB,L,2) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - LBND=LBOUND(BND_VARS_H%VAR_4D(NV)%FULL_VAR,4) - UBND=UBOUND(BND_VARS_H%VAR_4D(NV)%FULL_VAR,4) - DO NL=LBND,UBND - DO L=1,LM - DO JB=1,LNSH - DO IB=ITS,ITE - KOUNT=KOUNT+1 - RST_BC_DATA_NORTH(KOUNT)=BND_VARS_H%VAR_4D(NV)%NORTH(IB,JB,L,1,NL) - ENDDO - ENDDO - ENDDO - DO L=1,LM - DO JB=1,LNSH - DO IB=ITS,ITE - KOUNT=KOUNT+1 - RST_BC_DATA_NORTH(KOUNT)=BND_VARS_H%VAR_4D(NV)%NORTH(IB,JB,L,2,NL) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - DO JB=1,LNSV - DO IB=ITS,ITE - KOUNT=KOUNT+1 - RST_BC_DATA_NORTH(KOUNT)=BND_VARS_V%VAR_2D(NV)%NORTH(IB,JB,1) - ENDDO - ENDDO - DO JB=1,LNSV - DO IB=ITS,ITE - KOUNT=KOUNT+1 - RST_BC_DATA_NORTH(KOUNT)=BND_VARS_V%VAR_2D(NV)%NORTH(IB,JB,2) - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - DO L=1,LM - DO JB=1,LNSV - DO IB=ITS,ITE - KOUNT=KOUNT+1 - RST_BC_DATA_NORTH(KOUNT)=BND_VARS_V%VAR_3D(NV)%NORTH(IB,JB,L,1) - ENDDO - ENDDO - ENDDO - DO L=1,LM - DO JB=1,LNSV - DO IB=ITS,ITE - KOUNT=KOUNT+1 - RST_BC_DATA_NORTH(KOUNT)=BND_VARS_V%VAR_3D(NV)%NORTH(IB,JB,L,2) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Write Import State in SAVE_BC_DATA" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =EXP_STATE_SOLVER & !<-- The Solver export state - ,itemName ='Write Import State' & !<-- Name of the state to get from Solver export state - ,nestedState=IMP_STATE_WRITE & !<-- Extract Write Component import state from Solver export - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_SAVE) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set BC North Data Attribute in SAVE_BC_DATA" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeSet(state =IMP_STATE_WRITE & !<-- The Write component import state - ,name ='RST_BC_DATA_NORTH' & !<-- Name of 1-D string of north boundary values - ,itemCount=NUM_WORDS_BC_NORTH & !<-- # of north boundary words on this fcst task - ,valueList=RST_BC_DATA_NORTH & !<-- The 1-D data being inserted into the Write import state - ,rc =RC) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_SAVE) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Western boundary data to 1-D -!----------------------------------------------------------------------- -! - IF(ITS==IDS)THEN !<-- Tasks on west boundary -! - KOUNT=0 -! - IF(NVARS_BC_2D_H>0)THEN - DO NV=1,NVARS_BC_2D_H - DO JB=JTS,JTE - DO IB=1,LNSH - KOUNT=KOUNT+1 - RST_BC_DATA_WEST(KOUNT)=BND_VARS_H%VAR_2D(NV)%WEST(IB,JB,1) - ENDDO - ENDDO - DO JB=JTS,JTE - DO IB=1,LNSH - KOUNT=KOUNT+1 - RST_BC_DATA_WEST(KOUNT)=BND_VARS_H%VAR_2D(NV)%WEST(IB,JB,2) - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - DO L=1,LM - DO JB=JTS,JTE - DO IB=1,LNSH - KOUNT=KOUNT+1 - RST_BC_DATA_WEST(KOUNT)=BND_VARS_H%VAR_3D(NV)%WEST(IB,JB,L,1) - ENDDO - ENDDO - ENDDO - DO L=1,LM - DO JB=JTS,JTE - DO IB=1,LNSH - KOUNT=KOUNT+1 - RST_BC_DATA_WEST(KOUNT)=BND_VARS_H%VAR_3D(NV)%WEST(IB,JB,L,2) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - LBND=LBOUND(BND_VARS_H%VAR_4D(NV)%FULL_VAR,4) - UBND=UBOUND(BND_VARS_H%VAR_4D(NV)%FULL_VAR,4) - DO NL=LBND,UBND - DO L=1,LM - DO JB=JTS,JTE - DO IB=1,LNSH - KOUNT=KOUNT+1 - RST_BC_DATA_WEST(KOUNT)=BND_VARS_H%VAR_4D(NV)%WEST(IB,JB,L,1,NL) - ENDDO - ENDDO - ENDDO - DO L=1,LM - DO JB=JTS,JTE - DO IB=1,LNSH - KOUNT=KOUNT+1 - RST_BC_DATA_WEST(KOUNT)=BND_VARS_H%VAR_4D(NV)%WEST(IB,JB,L,2,NL) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - DO JB=JTS,JTE - DO IB=1,LNSV - KOUNT=KOUNT+1 - RST_BC_DATA_WEST(KOUNT)=BND_VARS_V%VAR_2D(NV)%WEST(IB,JB,1) - ENDDO - ENDDO - DO JB=JTS,JTE - DO IB=1,LNSV - KOUNT=KOUNT+1 - RST_BC_DATA_WEST(KOUNT)=BND_VARS_V%VAR_2D(NV)%WEST(IB,JB,2) - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - DO L=1,LM - DO JB=JTS,JTE - DO IB=1,LNSV - KOUNT=KOUNT+1 - RST_BC_DATA_WEST(KOUNT)=BND_VARS_V%VAR_3D(NV)%WEST(IB,JB,L,1) - ENDDO - ENDDO - ENDDO - DO L=1,LM - DO JB=JTS,JTE - DO IB=1,LNSV - KOUNT=KOUNT+1 - RST_BC_DATA_WEST(KOUNT)=BND_VARS_V%VAR_3D(NV)%WEST(IB,JB,L,2) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Write Import State in SAVE_BC_DATA" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =EXP_STATE_SOLVER & !<-- The Solver export state - ,itemName ='Write Import State' & !<-- Name of the state to get from Solver export state - ,nestedState=IMP_STATE_WRITE & !<-- Extract Write Component import state from Solver export - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_SAVE) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set BC West Data Attribute in SAVE_BC_DATA" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeSet(state =IMP_STATE_WRITE & !<-- The Write component import state - ,name ='RST_BC_DATA_WEST' & !<-- Name of 1-D string of west boundary values - ,itemCount=NUM_WORDS_BC_WEST & !<-- # of west boundary words on this fcst task - ,valueList=RST_BC_DATA_WEST & !<-- The 1-D data being inserted into the Write import state - ,rc =RC) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_SAVE) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Eastern boundary data to 1-D -!----------------------------------------------------------------------- -! - IF(ITE==IDE)THEN !<-- Tasks on east boundary -! - KOUNT=0 -! - IF(NVARS_BC_2D_H>0)THEN - DO NV=1,NVARS_BC_2D_H - DO JB=JTS,JTE - DO IB=1,LNSH - KOUNT=KOUNT+1 - RST_BC_DATA_EAST(KOUNT)=BND_VARS_H%VAR_2D(NV)%EAST(IB,JB,1) - ENDDO - ENDDO - DO JB=JTS,JTE - DO IB=1,LNSH - KOUNT=KOUNT+1 - RST_BC_DATA_EAST(KOUNT)=BND_VARS_H%VAR_2D(NV)%EAST(IB,JB,2) - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - DO L=1,LM - DO JB=JTS,JTE - DO IB=1,LNSH - KOUNT=KOUNT+1 - RST_BC_DATA_EAST(KOUNT)=BND_VARS_H%VAR_3D(NV)%EAST(IB,JB,L,1) - ENDDO - ENDDO - ENDDO - DO L=1,LM - DO JB=JTS,JTE - DO IB=1,LNSH - KOUNT=KOUNT+1 - RST_BC_DATA_EAST(KOUNT)=BND_VARS_H%VAR_3D(NV)%EAST(IB,JB,L,2) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - LBND=LBOUND(BND_VARS_H%VAR_4D(NV)%FULL_VAR,4) - UBND=UBOUND(BND_VARS_H%VAR_4D(NV)%FULL_VAR,4) - DO NL=LBND,UBND - DO L=1,LM - DO JB=JTS,JTE - DO IB=1,LNSH - KOUNT=KOUNT+1 - RST_BC_DATA_EAST(KOUNT)=BND_VARS_H%VAR_4D(NV)%EAST(IB,JB,L,1,NL) - ENDDO - ENDDO - ENDDO - DO L=1,LM - DO JB=JTS,JTE - DO IB=1,LNSH - KOUNT=KOUNT+1 - RST_BC_DATA_EAST(KOUNT)=BND_VARS_H%VAR_4D(NV)%EAST(IB,JB,L,2,NL) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - DO JB=JTS,JTE - DO IB=1,LNSV - KOUNT=KOUNT+1 - RST_BC_DATA_EAST(KOUNT)=BND_VARS_V%VAR_2D(NV)%EAST(IB,JB,1) - ENDDO - ENDDO - DO JB=JTS,JTE - DO IB=1,LNSV - KOUNT=KOUNT+1 - RST_BC_DATA_EAST(KOUNT)=BND_VARS_V%VAR_2D(NV)%EAST(IB,JB,2) - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - DO L=1,LM - DO JB=JTS,JTE - DO IB=1,LNSV - KOUNT=KOUNT+1 - RST_BC_DATA_EAST(KOUNT)=BND_VARS_V%VAR_3D(NV)%EAST(IB,JB,L,1) - ENDDO - ENDDO - ENDDO - DO L=1,LM - DO JB=JTS,JTE - DO IB=1,LNSV - KOUNT=KOUNT+1 - RST_BC_DATA_EAST(KOUNT)=BND_VARS_V%VAR_3D(NV)%EAST(IB,JB,L,2) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Write Import State in SAVE_BC_DATA" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =EXP_STATE_SOLVER & !<-- The Solver export state - ,itemName ='Write Import State' & !<-- Name of the state to get from Solver export state - ,nestedState=IMP_STATE_WRITE & !<-- Extract Write Component import state from Solver export - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_SAVE) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set BC East Data Attribute in SAVE_BC_DATA" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_AttributeSet(state =IMP_STATE_WRITE & !<-- The Write component import state - ,name ='RST_BC_DATA_EAST' & !<-- Name of 1-D string of east boundary values - ,itemCount=NUM_WORDS_BC_EAST & !<-- # of east boundary words on this fcst task - ,valueList=RST_BC_DATA_EAST & !<-- The 1-D data being inserted into the Write import state - ,rc =RC) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_SAVE) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE SAVE_BC_DATA -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE PHYSICS_INITIALIZE(GFS & - ,SHORTWAVE & - ,LONGWAVE & - ,CONVECTION & - ,MICROPHYSICS & - ,SFC_LAYER & - ,TURBULENCE & - ,LAND_SURFACE & - ,CO2TF & - ,NP3D & - ,SBD,WBD & - ,DPHD,DLMD & - ,TPH0D,TLM0D & - ,MY_DOMAIN_ID & - ,MYPE & - ,MPI_COMM_COMP & - ,IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE & - ,RC) -! -!----------------------------------------------------------------------- -! - USE MODULE_CONSTANTS,ONLY : A,CLIQ,CV,DTR,PI & - ,RHOAIR0,RHOWATER,RHOSNOW -! - USE MODULE_INIT_READ_BIN,ONLY : physics_read_gwd -! -!----------------------------------------------------------------------- -!*** Only for GFS physics -!----------------------------------------------------------------------- -! - USE FUNCPHYS - USE MODULE_MP_FER_HIRES, ONLY : GPVS_HR - - USE MERSENNE_TWISTER - USE N_LAYOUT1, ONLY : LATS_NODE_R,IPT_LATS_NODE_R -! USE TRACER_CONST, ONLY : SET_TRACER_CONST -! USE DATE_DEF, ONLY : FHOUR - USE N_RESOL_DEF, ONLY : LSOIL,LEVR,NXPT,JCAP,LEVS,NYPT & - ,JINTMX,THERMODYN_ID,SFCPRESS_ID & - ,NUM_P3D,NUM_P2D,NTOZ,NTCW,NCLD & - ,NMTVR,NFXR,LONR,LATR -! - USE OZNE_DEF, ONLY: LEVOZC,LATSOZP,BLATC,TIMEOZC,TIMEOZ & - ,KOZPL,LEVOZP,PL_TIME,PL_LAT,PL_PRES & - ,KOZC,DPHIOZC,LATSOZC,PL_COEFF - - USE N_NAMELIST_PHYSICS_DEF, ONLY: ISOL,ICO2,IALB,IEMS,IAER,ICTM & - ,IOVR_SW,IOVR_LW,LSSAV,LDIAG3D & - ,FHCYC,SASHAL,PRE_RAD,RAS,LSM & - ,CDMBGWD,DLQF,CTEI_RM,LGGFS3D & - ,BKGD_VDIF_M, SHAL_CNV & - ,BKGD_VDIF_H,BKGD_VDIF_S & - ,PSAUTCO,PRAUTCO,EVPCO & - ,CAL_PRE,MOM4ICE,MSTRAT & - ,TRANS_TRAC,NST_FCST & - ,MOIST_ADJ - - USE MODULE_CONTROL,ONLY : NMMB_FINALIZE - -! -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: CO2TF & - ,MPI_COMM_COMP & - ,MY_DOMAIN_ID & - ,MYPE, NP3D -! - INTEGER(kind=KINT),INTENT(IN) :: IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE -! - REAL(kind=KFPT),INTENT(INOUT) :: DLMD,DPHD & - ,TPH0D,TLM0D & - ,SBD,WBD -! - LOGICAL,INTENT(IN) :: GFS -! - CHARACTER(99),INTENT(IN) :: CONVECTION,LONGWAVE,MICROPHYSICS & - ,SFC_LAYER,SHORTWAVE,TURBULENCE & - ,LAND_SURFACE -! - INTEGER(kind=KINT),INTENT(OUT) :: RC -! -!--------------------- -!*** Local variables -!--------------------- -! - INTEGER :: I,I_HI,I_LO,IHRST,IRTN,J,J_HI,J_LO,JULDAY,JULYR & - ,K,KFLIP,L,LPT2,N,NFCST,NRECS_SKIP_FOR_PT & - ,NSOIL,NSTEPS_PER_HOUR,NTIMESTEP -! - INTEGER :: LDIM1,LDIM2,UDIM1,UDIM2 -! - INTEGER :: IAER_MDL, ISUBCSW, ISUBCLW, IFLIP, & - ICLIQ_SW, ICICE_SW, ICLIQ_LW, ICICE_LW -! - INTEGER,DIMENSION(3) :: IDAT -! - INTEGER,DIMENSION(:,:),ALLOCATABLE :: ITEMP,LOWLYR -! - REAL :: SECOND_FCST -! - REAL :: SWRAD_SCAT=1. -! - REAL :: DELX,DELY,DPH,DT,DT_MICRO,DTPHS & - ,GMT,JULIAN,PDBOT,PDTOP,PDTOT,PT_CB,RELM,RPDTOT & - ,SB,THETA_HALF,TPV,XTIME -! - REAL,DIMENSION(LM) :: DSG1,PDSG1,PSGML1,SGML1,SGML2 - REAL,DIMENSION(LM+1) :: PSG1,SG1,SG2,SGM & - ,SFULL,SFULL_FLIP,SMID,SMID_FLIP - REAL(KIND=KDBL),DIMENSION(LM+1) :: SFULLD -! - REAL,DIMENSION(IMS:IME,JMS:JME) :: EMISS - REAL,DIMENSION(:,:),ALLOCATABLE :: TEMP1,TEMP_GWD - REAL,DIMENSION(:,:,:),ALLOCATABLE :: TEMPSOIL - REAL,DIMENSION(NUM_SOIL_LAYERS) :: SOIL1DIN -! - CHARACTER(LEN=256) :: INFILE -! - LOGICAL,SAVE :: ALLOWED_TO_READ=.TRUE. - LOGICAL :: OPENED - LOGICAL :: LSASHAL - - LOGICAL :: CRICK_PROOF, CCNORM, NORAD_PRECIP -! -#ifdef USE_GFS_PHYS -!--------------------------------- -!*** GFS physics local variables -!--------------------------------- -! - CHARACTER(80) :: GFS_PHY_NAMELIST - INTEGER :: JDAT(8),NLUNIT,NTRAC,IRET,IMJM,NIJ - REAL(kind=KDBL) :: DELTIM,GAUL - - REAL *4 :: BLATC4 - REAL *4, ALLOCATABLE :: PL_LAT4(:), PL_PRES4(:), PL_TIME4(:), TEMPIN(:) - - REAL(kind=KDBL),DIMENSION(:),ALLOCATABLE :: & - SIG1T, RLA, RLO, SLMASK, OROG, AISFCS, & - SIHFCS, SICFCS, SITFCS, SWDFCS, VMNFCS, VMXFCS, SLPFCS, & - ABSFCS, TSFFCS, SNOFCS, ZORFCS, TG3FCS, CNPFCS, SLIFCS, & - F10MFCS, VEGFCS, VETFCS, SOTFCS, CVFCS, CVBFCS, CVTFCS -! - REAL(kind=KDBL),DIMENSION(:,:),ALLOCATABLE :: ALFFC1 & - ,SMCFC1 & - ,STCFC1 & - ,SLCFC1 & - ,ALBFC1 -! -#endif -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Initialize allocated arrays -!----------------------------------------------------------------------- -! - NSOIL=NUM_SOIL_LAYERS !<-- From Landsurface module -! -#ifdef USE_GFS_PHYS - IF(GFS)THEN - - int_state%SOLCON=0.0D0 - int_state%SLAG =0.0D0 - int_state%SDEC =0.0D0 - int_state%CDEC =0.0D0 -! - DO J=JTS,JTE - int_state%DDY (J)=0.0D0 - int_state%JINDX1(J)=0 - int_state%JINDX2(J)=0 - ENDDO -! - DO J=JMS,JME - DO I=IMS,IME -! - int_state%DUGWD (I,J)=0.0D0 - int_state%DVGWD (I,J)=0.0D0 -! - int_state%TMPMIN (I,J)=373.0D0 - int_state%TMPMAX (I,J)=173.0D0 -! - int_state%SHDMIN (I,J)=0.0 - int_state%SHDMAX (I,J)=0.0 -! - int_state%SFALB (I,J)=0.0D0 - int_state%TSFLW (I,J)=0.0D0 - int_state%SEMIS (I,J)=0.0D0 - int_state%SFCDLW (I,J)=0.0D0 - int_state%SFCDSW (I,J)=0.0D0 - int_state%SFCNSW (I,J)=0.0D0 - int_state%ZORFCS (I,J)=-1.D6 - int_state%SIHFCS (I,J)=-1.D6 - int_state%SICFCS (I,J)=-1.D6 - int_state%SLPFCS (I,J)=-1.D6 - int_state%TG3FCS (I,J)=-1.D6 - int_state%VEGFCS (I,J)=-1.D6 - int_state%VETFCS (I,J)=-1.D6 - int_state%SOTFCS (I,J)=-1.D6 -! - DO N=1,4 - int_state%ALBFC1(I,J,N)=-1.D6 - ENDDO -! - DO N=1,2 - int_state%ALFFC1(I,J,N)=-1.D6 - ENDDO -! - DO N=1,3 ! for Zhao =3, Ferr=1 - int_state%PHY_F2DV (I,J,N)=0.0D0 - ENDDO -! - DO N=1,4 ! for Zhao =4, Ferr=3 - DO L=1,LM - int_state%PHY_F3DV (I,J,L,N)=0.0D0 - ENDDO - ENDDO -! - ENDDO - ENDDO - - rewind (kozpl) - read (kozpl) pl_coeff, latsozp, levozp, timeoz - - DO N=1,TIMEOZ - DO L=1,PL_COEFF - DO J=1,LEVOZP - DO I=1,LATSOZP - int_state%OZPLIN(I,J,L,N)=-1.D6 - ENDDO - ENDDO - ENDDO - ENDDO -! - ENDIF -! -#endif -!----------------------------------------------------------------------- -!*** Dereference the start time. -!----------------------------------------------------------------------- -! - START_YEAR=int_state%START_YEAR - START_MONTH=int_state%START_MONTH - START_DAY=int_state%START_DAY - START_HOUR=int_state%START_HOUR - START_MINUTE=int_state%START_MINUTE - START_SECOND=int_state%START_SECOND - DT=int_state%DT -! -!----------------------------------------------------------------------- -!*** Radiation needs some specific time quantities. -!----------------------------------------------------------------------- -! - CALL TIME_MEASURE(START_YEAR,START_MONTH,START_DAY,START_HOUR & - ,START_MINUTE,START_SECOND & - ,NTIMESTEP,DT & - ,JULDAY,JULYR,JULIAN,XTIME) -! -!----------------------------------------------------------------------- -!*** Open and read GWD data file (14 orography fields) -!----------------------------------------------------------------------- -! - gwd_read: IF(int_state%GWDFLG) THEN -! - select_GWD_unit: DO N=51,59 - INQUIRE(N,OPENED=OPENED) - IF(.NOT.OPENED)THEN - NFCST=N - EXIT select_GWD_unit - ENDIF - ENDDO select_GWD_unit -! - WRITE(INFILE,'(A,I2.2)')'GWD_bin_',MY_DOMAIN_ID -! -!----------------------------------------------------------------------- -! - CALL PHYSICS_READ_GWD(INFILE,NFCST,INT_STATE & - ,MYPE,MPI_COMM_COMP & - ,IDS,IDE,JDS,JDE,RC) -! - IF (RC /= 0) THEN - RETURN - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF gwd_read -! -!----------------------------------------------------------------------- -! - PT_CB=int_state%PT*1.0E-3 !<-- Convert pascals to centibars for GFDL initialization -! -!----------------------------------------------------------------------- -!*** Make up a potential skin temperature. -!----------------------------------------------------------------------- -! - IF(.NOT.int_state%RESTART) THEN -! - DO J=JTS,JTE - DO I=ITS,ITE - int_state%THS(I,J)=int_state%TSKIN(I,J) & - *(100000./(int_state%SG2(LM+1)*int_state%PD(I,J) & - +int_state%PSG1(LM+1)))**CAPPA - ENDDO - ENDDO -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Initializing TLMAX, TLMIN -!----------------------------------------------------------------------- -! - DO J=JTS,JTE - DO I=ITS,ITE - int_state%TLMAX(I,J)=int_state%T(I,J,1) - int_state%TLMIN(I,J)=int_state%T(I,J,1) - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** Recreate sigma values at layer interfaces for the full vertical -!*** domain. -!----------------------------------------------------------------------- -! - DO L=1,LM+1 - SFULL(L)=int_state%SGM(L) - ENDDO -! - DO L=1,LM - SMID(L)=(SFULL(L)+SFULL(L+1))*0.5 - ENDDO -! - SMID(LM+1)=-9999999. -! -!----------------------------------------------------------------------- -!*** The radiative emissivity -!----------------------------------------------------------------------- -! - DO J=JMS,JME - DO I=IMS,IME - EMISS(I,J)=1. - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** Choose a J index for an "average" DX. -!*** Select the J that divides the domain's area in half. -!----------------------------------------------------------------------- -! - SB=int_state%SBD*DTR - DPH=int_state%DPHD*DTR -!!! THETA_HALF=ASIN(0.5*SIN(-SB)) - THETA_HALF=0. - JC=NINT(0.5*(JDE-JDS+1)+THETA_HALF/DPH) -! -!----------------------------------------------------------------------- -!*** Set time variables needed for history output. -!----------------------------------------------------------------------- -! - NSTEPS_PER_HOUR=NINT(3600./int_state%DT) - int_state%NPREC=NSTEPS_PER_HOUR*int_state%NHRS_PREC - int_state%NCLOD=NSTEPS_PER_HOUR*int_state%NHRS_CLOD - int_state%NHEAT=NSTEPS_PER_HOUR*int_state%NHRS_HEAT - int_state%NRDLW=NSTEPS_PER_HOUR*int_state%NHRS_RDLW - int_state%NRDSW=NSTEPS_PER_HOUR*int_state%NHRS_RDSW - int_state%NSRFC=NSTEPS_PER_HOUR*int_state%NHRS_SRFC -! -!----------------------------------------------------------------------- -!*** If this is a restarted run from timestep 0 then zero out -!*** the accumulated precip since they pass through the analysis -!*** with nonzero values from the first guess. -!----------------------------------------------------------------------- -! - IF(int_state%RST_OUT_00)THEN - DO J=JMS,JME - DO I=IMS,IME - int_state%ACPREC(I,J)=0. - int_state%ACPREC_TOT(I,J)=0. - int_state%CUPREC(I,J)=0. - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Finally initialize individual schemes. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** The GFS physics suite is considered a single package here. -!---------------------------------------------------------------------- -! - package: IF(GFS)THEN -! -#ifdef USE_GFS_PHYS -!----------------------------------------------------------------------- -!*** The GFS physics suite is considered a single package here. -!---------------------------------------------------------------------- -! - namelist_unit: DO N=101,151 - INQUIRE(N,OPENED=OPENED) - IF(.NOT.OPENED)THEN - NLUNIT=N - EXIT namelist_unit - ENDIF - ENDDO namelist_unit - - GFS_PHY_NAMELIST = 'atm_namelist' - DELTIM = int_state%DT - LEVS = LM - CALL N_COMPNS_PHYSICS(DELTIM, IRET, & - NTRAC, NXPT, NYPT, JINTMX, & - JCAP, LEVS, LEVR, LONR, LATR, & - NTOZ, NTCW, NCLD, & - LSOIL, NMTVR, NUM_P3D, NUM_P2D, & - THERMODYN_ID, SFCPRESS_ID, & - NLUNIT, MYPE, GFS_PHY_NAMELIST) -!-------------- - IALB = 0 - DELTIM = int_state%DT - LONR = ITE-ITS+1 ! this is changed in compns_physics from - LATR = JTE-JTS+1 ! atm_namelist (restore it back) - LATS_NODE_R = JTE-JTS+1 - IPT_LATS_NODE_R = 1 - NFXR = 39 - LSSAV = .TRUE. ! logical flag for store 3-d cloud field - LDIAG3D = .FALSE. ! logical flag for store 3-d diagnostic fields - LGGFS3D = .FALSE. -!-------------- - CALL SET_SOILVEG(MYPE,NLUNIT) - CALL SET_TRACER_CONST(NTRAC,MYPE,NLUNIT) - CALL GFUNCPHYS -! -!----------------------------------------------------------------------- -!*** Initialize ozone -!----------------------------------------------------------------------- - IF( NTOZ .LE. 0 ) THEN ! Diagnostic ozone -! -!! rewind (kozc) ! there is no header in global_o3clim.txt file -!! read (kozc,end=101) latsozc, levozc, timeozc, blatc4 -!!101 if (levozc .lt. 10 .or. levozc .gt. 100) then -!! rewind (kozc) - levozc = 17 - latsozc = 18 - blatc = -85.0 -!! else -!! blatc = blatc4 -!! endif - latsozp = 2 - levozp = 1 - timeoz = 1 - pl_coeff = 1 !!! 0 (MUST set > 0, used in GBPHYS for allocation) - timeozc = 12 !!! this is not in header -! - ELSE ! Prognostic Ozone -! - rewind (kozpl) - read (kozpl) pl_coeff, latsozp, levozp, timeoz - IF(.NOT.ALLOCATED(pl_lat))THEN - allocate (pl_lat (latsozp), pl_pres (levozp),pl_time (timeoz+1)) - ENDIF - IF(.NOT.ALLOCATED(pl_lat4))THEN - allocate (pl_lat4(latsozp), pl_pres4(levozp),pl_time4(timeoz+1)) - ENDIF - IF(.NOT.ALLOCATED(tempin)) allocate (tempin(latsozp)) - rewind (kozpl) - read (kozpl) pl_coeff, latsozp, levozp, timeoz, pl_lat4, pl_pres4, pl_time4 - pl_pres(:) = pl_pres4(:) - pl_lat(:) = pl_lat4(:) - pl_time(:) = pl_time4(:) -! - DO J=JTS,JTE - - gaul=int_state%GLAT( (ITS+ITE)/2 ,J)*180.0d0/3.14159d0 - - int_state%jindx2(j) = latsozp + 1 - do i=1,latsozp - if (gaul.lt. pl_lat(i)) then - int_state%jindx2(j) = i - exit - endif - enddo - int_state%jindx1(j) = max(int_state%jindx2(j)-1,1) - int_state%jindx2(j) = min(int_state%jindx2(j),latsozp) - - if (int_state%jindx2(j) .ne. int_state%jindx1(j)) then - int_state%ddy(j) = (gaul - pl_lat(int_state%jindx1(j))) & - / (pl_lat(int_state%jindx2(j)) - pl_lat(int_state%jindx1(j))) - else - int_state%ddy(j) = 1.0 - endif - - ENDDO -! - DO I=1,TIMEOZ - DO N=1,PL_COEFF - DO K=1,LEVOZP - READ(KOZPL) TEMPIN - int_state%OZPLIN(:,K,N,I) = TEMPIN(:) - ENDDO - ENDDO - ENDDO -! - ENDIF ! Diagnostic/Prognostic Ozone -! - dphiozc = -(blatc+blatc)/(latsozc-1) -!----------------------------------------------------------------------- -!*** End initialization of ozone -!----------------------------------------------------------------------- -! - IMJM=(ITE-ITS+1)*(JTE-JTS+1) - ALLOCATE(SIG1T(IMJM),RLA(IMJM),RLO(IMJM),SLMASK(IMJM),OROG(IMJM) & - ,AISFCS(IMJM),SIHFCS(IMJM),SICFCS(IMJM),SITFCS(IMJM) & - ,SWDFCS(IMJM),VMNFCS(IMJM),VMXFCS(IMJM),SLPFCS(IMJM) & - ,ABSFCS(IMJM),TSFFCS(IMJM),SNOFCS(IMJM),ZORFCS(IMJM) & - ,TG3FCS(IMJM),CNPFCS(IMJM),SLIFCS(IMJM),F10MFCS(IMJM) & - ,VEGFCS(IMJM),VETFCS(IMJM),SOTFCS(IMJM),CVFCS(IMJM) & - ,CVBFCS(IMJM),CVTFCS(IMJM),ALFFC1(IMJM,2),ALBFC1(IMJM,4) & - ,SMCFC1(IMJM,NSOIL),STCFC1(IMJM,NSOIL),SLCFC1(IMJM,NSOIL) ) - - SIHFCS = 0.0d0 - SICFCS = 0.0d0 - SITFCS = 0.0d0 - SWDFCS = 0.0d0 - VMNFCS = 0.0d0 - VMXFCS = 0.0d0 - SLPFCS = 0.0d0 - ABSFCS = 0.0d0 - TSFFCS = 0.0d0 - SNOFCS = 0.0d0 - ZORFCS = 0.0d0 - TG3FCS = 0.0d0 - CNPFCS = 0.0d0 - SLIFCS = 0.0d0 - F10MFCS = 0.0d0 - VEGFCS = 0.0d0 - VETFCS = 0.0d0 - SOTFCS = 0.0d0 - CVFCS = 0.0d0 - CVBFCS = 0.0d0 - CVTFCS = 0.0d0 - ALFFC1 = 0.0d0 - ALBFC1 = 0.0d0 - SMCFC1 = 0.0d0 - STCFC1 = 0.0d0 - SLCFC1 = 0.0d0 - - - JDAT(1)=int_state%IDAT(3) - JDAT(2)=int_state%IDAT(2) - JDAT(3)=int_state%IDAT(1) - JDAT(4)=0 - JDAT(5)=int_state%IHRST - JDAT(6)=0 - JDAT(7)=0 - JDAT(8)=0 - FHOUR=FLOAT(int_state%IHRST) -! - NIJ=0 - DO J=JTS,JTE - DO I=ITS,ITE - - NIJ=NIJ+1 - - SIG1T(NIJ) = 0.d0 - RLA(NIJ) = int_state%GLAT(I,J)*180.0d0/3.14159d0 - RLO(NIJ) = int_state%GLON(I,J)*180.0d0/3.14159d0 - SLMASK(NIJ) = 1.0d0-int_state%SM(I,J) - OROG(NIJ) = int_state%FIS(I,J)/9.81d0 - AISFCS(NIJ) = int_state%SICE(I,J) - - ENDDO - ENDDO -! - CALL SFCCYCLE(204,(ITE-ITS+1)*(JTE-JTS+1),4,SIG1T,FHCYC & - &, JDAT(1), JDAT(2), JDAT(3), JDAT(5), FHOUR & -! &, RLA, RLO, SLMASK, OROG & - &, RLA, RLO, SLMASK, OROG, OROG, .FALSE. & - &, SIHFCS, SICFCS, SITFCS & - &, SWDFCS, SLCFC1 & - &, VMNFCS, VMXFCS, SLPFCS, ABSFCS & - &, TSFFCS, SNOFCS, ZORFCS, ALBFC1, TG3FCS & - &, CNPFCS, SMCFC1, STCFC1, SLIFCS, AISFCS, F10MFCS & - &, VEGFCS, VETFCS, SOTFCS, ALFFC1 & - &, CVFCS, CVBFCS, CVTFCS, MYPE, NLUNIT, IALB) -! - NIJ=0 - DO J=JTS,JTE - DO I=ITS,ITE - NIJ=NIJ+1 - - SIHFCS(NIJ) = int_state%SICE(I,J) * 1.0d0 ! initialize like this - SICFCS(NIJ) = int_state%SICE(I,J) * 0.9d0 ! initialize like this - - if(int_state%SICE(I,J) > 0.5 ) then - SLPFCS(NIJ)=9.0d0 - VEGFCS(NIJ)=0.01d0 - SOTFCS(NIJ)=9.0d0 - VETFCS(NIJ)=13.0d0 - endif - - int_state%ZORFCS(I,J) = ZORFCS(NIJ) - int_state%SIHFCS(I,J) = SIHFCS(NIJ) - int_state%SICFCS(I,J) = SICFCS(NIJ) - int_state%SLPFCS(I,J) = SLPFCS(NIJ) - int_state%TG3FCS(I,J) = TG3FCS(NIJ) - int_state%VEGFCS(I,J) = VEGFCS(NIJ) - int_state%VETFCS(I,J) = VETFCS(NIJ) - int_state%SOTFCS(I,J) = SOTFCS(NIJ) -!!! - int_state%isltyp(I,J) = nint(SOTFCS(NIJ)) - int_state%ivgtyp(I,J) = nint(VETFCS(NIJ)) -!!! - - int_state%ALBFC1(I,J,1) = ALBFC1(NIJ,1) - int_state%ALBFC1(I,J,2) = ALBFC1(NIJ,2) - int_state%ALBFC1(I,J,3) = ALBFC1(NIJ,3) - int_state%ALBFC1(I,J,4) = ALBFC1(NIJ,4) - - int_state%ALFFC1(I,J,1) = ALFFC1(NIJ,1) - int_state%ALFFC1(I,J,2) = ALFFC1(NIJ,2) - - ENDDO - ENDDO - - DEALLOCATE(SIG1T,RLA,RLO,SLMASK,OROG & - ,AISFCS,SIHFCS,SICFCS,SITFCS & - ,SWDFCS,VMNFCS,VMXFCS,SLPFCS & - ,ABSFCS,TSFFCS,SNOFCS,ZORFCS & - ,TG3FCS,CNPFCS,SLIFCS,F10MFCS & - ,VEGFCS,VETFCS,SOTFCS,CVFCS & - ,CVBFCS,CVTFCS,ALFFC1,ALBFC1 & - ,SMCFC1,STCFC1,SLCFC1) -! -!---------------------------------------------------------------------- -!*** Set fluxes to zero -!---------------------------------------------------------------------- -! - int_state%ALWIN(I,J) = 0. - int_state%ALWOUT(I,J) = 0. - int_state%ASWIN(I,J) = 0. - int_state%ASWOUT(I,J) = 0. - int_state%RLWIN(I,J) = 0. - int_state%RADOT(I,J) = 0. - int_state%RSWIN(I,J) = 0. - int_state%RSWOUT(I,J) = 0. - - int_state%ALWTOA(I,J) = 0. - int_state%ASWTOA(I,J) = 0. - int_state%RLWTOA(I,J) = 0. - int_state%RSWTOA(I,J) = 0. - - int_state%SFCSHX(I,J) = 0. - int_state%SFCLHX(I,J) = 0. - int_state%TWBS(I,J) = 0. - int_state%QWBS(I,J) = 0. - - int_state%BGROFF(I,J) = 0. - int_state%SSROFF(I,J) = 0. - int_state%ACSNOW(I,J) = 0. - - int_state%CUPPT(I,J) = 0. -! -!---------------------------------------------------------------------- -!*** End GFS package init -!---------------------------------------------------------------------- -#endif -! - ELSE -! -!---------------------------------------------------------------------- -!*** If not selecting the GFS suite, each of the physics groups is -!*** treated individually. -!---------------------------------------------------------------------- -! -!---------------------------------------------------------------------- -!*** Longwave radiation -!---------------------------------------------------------------------- -! - SELECT CASE (longwave) - CASE ('gfdl') -! -!*** We are calling a WRF routine thus flip the vertical. -! - DO K=1,LM - KFLIP=LM+1-K - SFULL_FLIP(KFLIP)=SFULL(K+1) - SMID_FLIP(KFLIP)=SMID(K) - ENDDO - SFULL_FLIP(LM+1)=SFULL(1) -! - GMT=REAL(START_HOUR) - CALL GFDL_INIT(EMISS,SFULL_FLIP,SMID_FLIP,PT_CB & - ,JULYR,START_MONTH,START_DAY,GMT & - ,CO2TF & - ,IDS,IDE,JDS,JDE,1,LM+1 & - ,IMS,IME,JMS,JME,1,LM+1 & - ,ITS,ITE,JTS,JTE,1,LM) - CASE ('rrtm') - - CALL GPKAP ! for ozone by using the unified RRTM from GFS - CALL GPVS ! for aerosol by using the unified RRTM from GFS - - CALL GPVS_HR !- Initialize regional version of FPVS, FPVS0 functions -! -!----------------------------------------------------------------------- -!*** For threading safe (rad_initialize). Default value -!----------------------------------------------------------------------- -! - ICTM=1 ! 0: use data at initial cond time, if not available, use latest, no extrapolation. - ! 1: use data at the forecast time, if not available, use latest and extrapolation. - ! -1: use user provided external data for the fcst time, no extrapolation. - ! -2: same as ictm=0, but add seasonal cycle from climatology. no extrapolation. - ! yyyy0: use yyyy data for the forecast time, no further data extrapolation. - ! yyyy1: use yyyy data for the fcst. if needed, do extrapolation to match the fcst time. - ISOL=0 ! 0: use a fixed solar constant value 1.3660e+3 (default) - !10: use a fixed solar constant value 1.3608e+3 - ! 1: use 11-year cycle solar constant table - ICO2=1 ! 0: use prescribed global mean co2 (default) - ! 1: use observed co2 annual mean value only - ! 2: use obs co2 monthly data with 2-d variation - IAER=11 ! flag for aerosols scheme selection (all options work for NMMB) - ! - 3-digit aerosol flag (volc,lw,sw) - ! 0: turn all aeros effects off (sw,lw,volc) - ! 1: use clim tropspheric aerosol for sw only - ! 10: use clim tropspheric aerosol for lw only - ! 11: use clim tropspheric aerosol for both sw and lw - ! 100: volc aerosol only for both sw and lw - ! 101: volc and clim trops aerosol for sw only - ! 110: volc and clim trops aerosol for lw only - ! 111: volc and clim trops aerosol for both sw and lw - ! 2: gocart/BSC-Dust tropspheric aerosol for sw only - ! 20: gocart/BSC-Dust tropspheric aerosol for lw only - ! 22: gocart/BSC-Dust tropspheric aerosol for both sw and lw - ! 102: volc and gocart trops aerosol for sw only - ! 120: volc and gocart trops aerosol for lw only - ! 122: volc and gocart trops aerosol for both sw and lw - IAER_MDL=0 ! default aerosol model is opac-climatology - ! > 0, future gocart-clim/prog scheme (not ready) - IALB=2 ! control flag for surface albedo schemes - ! 0: climatology, based on surface veg types ! ONLY THIS ONE WORKS (GFS) - ! 1: modis retrieval based surface albedo scheme - ! 2: use externally provided albedoes directly. ! ONLY THIS ONE WORKS for regional - ! (CALCULATES ALBEDO FROM NMMB MONTHLY CLIMATOLOGY AS IN GFDL RADIATION) - IEMS=0 ! control flag for surface emissivity schemes - ! 0: fixed value of 1.0 (default) - ! 1: varying value based on surface veg types - NTCW=3 ! 0: no cloud condensate calculated - ! >0: array index location for cloud condensate - ! NP3D=3 ! 3: ferrier's microphysics cloud scheme (only stratiform cloud) - ! (set iflagliq>0 in radsw_param.f and radlw_param.f) - ! 4: zhao/carr/sundqvist microphysics cloud (now available in the NMMB) - ! 5: NAM stratiform + convective cloud optical depth and fraction - ! (set iflagliq=0 in radsw_param.f and radlw_param.f) - NTOZ=0 ! 0: climatological ozone profile - ! >0: interactive ozone profile - IOVR_SW=1 ! 0 sw: random overlap clouds - ! 1 sw: max-random overlap clouds - IOVR_LW=1 ! 0 lw: random overlap clouds - ! 1 lw: max-random overlap clouds - ISUBCSW=0 ! isubcsw/isubclw - ! sub-column cloud approx control flag (sw/lw rad) - ! 0: with out sub-column cloud approximation - ! 1: mcica sub-col approx. prescribed random seed - ! 2: mcica sub-col approx. provided random seed - ISUBCLW=0 - - !---------------------------------------------------------- - ! --- check physparam for detail of the following --------- - - ICLIQ_SW=1 ! sw optical property for liquid clouds - ICICE_SW=3 ! sw optical property for ice clouds (only iswcliq>0) - ICLIQ_LW=1 ! lw optical property for liquid clouds - ICICE_LW=1 ! lw optical property for ice clouds (only ilwcliq>0) - - !---------------------------------------------------------- - - IFLIP=0 ! 0: input data from toa to sfc - ! 1: input data from sfc to toa - - SASHAL=0 ! New Massflux based shallow convection (Not in use for NMMB) - LSASHAL=.false. - if (SASHAL>0 .and. .not.RAS) LSASHAL=.true. - CRICK_PROOF=.false. ! flag for eliminating CRICK (smooths profiles) - CCNORM=.true. ! flag for incloud condensate mixing ratio - NORAD_PRECIP=.false. ! flag for precip in radiation - ! .true. snow/rain has no impact on radiation - -!----------------------------------------------------------------------- -!*** Initialize ozone -!----------------------------------------------------------------------- - -!OZONE CLIMATOLOGY -! -! there is no header in global_o3clim.txt file - - IF (NTOZ .LE. 0) THEN ! DIAGNOSTIC OZONE, ONLY THIS ONE WORKS - LEVOZC = 17 - LATSOZC = 18 - BLATC = -85.0 - TIMEOZC = 12 !!! this is not in header - LATSOZP = 2 - LEVOZP = 1 - TIMEOZ = 1 - PL_COEFF = 0 - ENDIF - - DPHIOZC = -(BLATC+BLATC)/(LATSOZC-1) - -!----------------------------------------------------------------------- -!*** End initialization of ozone -!----------------------------------------------------------------------- - - DO L=1,LM+1 - SFULLD(L)=SFULL(L) !-- double precision - ENDDO - -!========================================================================== -! Similar to GFS "GFS_Initialize_ESMFMod.f" line #1103 -!========================================================================== - -!..Special case for altering microphysics coupling with RRTM radiation -!.. based on namelist settings. The NP3Dx variable is incredibly convoluted -!.. and renamed many times, including icmphys, np3d, and num_p3d. Extremely -!.. confusing and hard-wired and needs help to adapt to new physics couplings -!.. and choices for full flexibility. G. Thompson 06Feb2013 - -!..SPECIAL TEST FOR THOMPSON MICROPHYSICS AND RRTM RADIATION. It is strongly -!.. advised against using GFDL or other radiation in combination with Thompson -!.. microphysics because other schemes are not properly using the cloud data. - - IF (TRIM(int_state%SHORTWAVE)=='rrtm' .AND. & - & TRIM(int_state%MICROPHYSICS)=='thompson' ) THEN - - IF (NP3D /=8) THEN - WRITE(0,*)' User selected np3d=',NP3D - WRITE(0,*)' NP3D=8 for RRTM & THOMPSON MICROPHYSICS' - CALL NMMB_FINALIZE - ENDIF - - ICICE_SW=4 - ICICE_LW=4 - - ENDIF - -!========================================================================== -!..For GFDL type diagnostic -!========================================================================== - - IF (NP3D == 5) THEN - ICLIQ_SW=0 - ICLIQ_LW=0 - ENDIF - - IF(MYPE==0)THEN - WRITE(0,*)' Model Proces np3d=',NP3D - ENDIF - -!========================================================================== - - call rad_initialize_nmmb & -! --- inputs: - & ( SFULLD,LM,ICTM,ISOL,ICO2,IAER,IAER_MDL,IALB,IEMS,NTCW, & - & NP3D,NTOZ,IOVR_SW,IOVR_LW,ISUBCSW,ISUBCLW, & - & ICLIQ_SW,ICICE_SW,ICLIQ_LW,ICICE_LW, & - & LSASHAL,CRICK_PROOF,CCNORM,NORAD_PRECIP,IFLIP,MYPE ) -! --- outputs: -! ( none ) - -!========================================================================== -!========================================================================== - - DO K=1,LM - KFLIP=LM+1-K - SFULL_FLIP(KFLIP)=SFULL(K+1) - SMID_FLIP(KFLIP)=SMID(K) - ENDDO - SFULL_FLIP(LM+1)=SFULL(1) -! - GMT=REAL(START_HOUR) - -!========================================================================== -! This following "RRTM_INIT" is only a L,M,H DIAGNOSTIC cloud. -! It is not a real RRTM initialization -!========================================================================== - - - CALL RRTM_INIT(EMISS,SFULL_FLIP,SMID_FLIP,PT_CB & - ,JULYR,START_MONTH,START_DAY,GMT & - ,CO2TF & - ,IDS,IDE,JDS,JDE,1,LM+1 & - ,IMS,IME,JMS,JME,1,LM+1 & - ,ITS,ITE,JTS,JTE,1,LM) -! - CASE DEFAULT - WRITE(0,*)' BAD SELECTION OF LONGWAVE SCHEME: INIT ' - END SELECT -! -!---------------------------------------------------------------------- -!*** Shortwave radiation -!---------------------------------------------------------------------- -! - SELECT CASE (shortwave) - CASE ('gfdl') -! WRITE(0,*)' Already called GFDL_INIT from LONGWAVE' - CASE ('rrtm') -! WRITE(0,*)' Already called RRTM_INIT from LONGWAVE' -!!! CASE ('gsfc') -!!! CALL GSFC_INIT - CASE ('dudh') -!!! CALL SWINIT(SWRAD_SCAT,int_state%RESTART & -!!! ,ALLOWED_TO_READ & -!!! ,IDS,IDE,JDS,JDE,1,LM+1 & -!!! ,IMS,IME,JMS,JME,1,LM+1 & -!!! ,ITS,ITE,JTS,JTE,1,LM) - CASE DEFAULT - WRITE(0,*)' BAD SELECTION OF SHORTWAVE SCHEME: INIT' - END SELECT -! -!---------------------------------------------------------------------- -!*** Surface layer -!---------------------------------------------------------------------- -! - ALLOCATE(LOWLYR(IMS:IME,JMS:JME),STAT=I) -! - SELECT CASE (sfc_layer) - CASE ('myj') - CALL JSFC_INIT(LOWLYR & !<-- Placeholder (computed in TURBULENCE) - ,int_state%USTAR,int_state%Z0 & - ,int_state%SM,int_state%SICE & - ,int_state%IVGTYP,int_state%RESTART & - ,ALLOWED_TO_READ & - ,IDS,IDE,JDS,JDE,1,LM+1 & - ,IMS,IME,JMS,JME,1,LM+1 & - ,ITS,ITE,JTS,JTE,1,LM & - ,MPI_COMM_COMP ) - CASE ('gfdl') - CALL JSFC_INIT4GFDL(LOWLYR & !<-- Placeholder (computed in TURBULENCE) - ,int_state%USTAR,int_state%Z0 & - ,int_state%SM,int_state%SICE & - ,int_state%IVGTYP,int_state%RESTART & - ,ALLOWED_TO_READ & - ,IDS,IDE,JDS,JDE,1,LM+1 & - ,IMS,IME,JMS,JME,1,LM+1 & - ,ITS,ITE,JTS,JTE,1,LM & - ,MPI_COMM_COMP ) -!!! CASE ('mm5') -!!! CALL SFCLYR_INIT - CASE DEFAULT - WRITE(0,*)' BAD SELECTION OF SURFACE LAYER SCHEME: INIT' - END SELECT -! -!---------------------------------------------------------------------- -!*** Turbulence -!---------------------------------------------------------------------- -! - SELECT CASE (turbulence) - CASE ('myj') - CALL MYJPBL_INIT(int_state%EXCH_H,int_state%RESTART & - ,IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE) - CASE ('gfs') -!!! CASE ('ysu') -!!! CALL YSU_INIT - CASE ('gfshur') - CASE ('gfsedmfhur') - CASE DEFAULT - WRITE(0,*)' BAD SELECTION OF TURBULENCE SCHEME: INIT' - END SELECT -! -!---------------------------------------------------------------------- -!*** Land surface -!---------------------------------------------------------------------- -! - SELECT CASE (land_surface) - CASE ('noah') - int_state%LSM_PHYSICS=LSMSCHEME - CALL NOAH_LSM_INIT(int_state%CMC, int_state%ISLTYP & - ,int_state%STC, int_state%SMC & - ,int_state%IVEGSRC & - ,int_state%SH2O, NUM_SOIL_LAYERS & - ,int_state%RESTART, ALLOWED_TO_READ & - ,IDS,IDE, JDS,JDE & - ,IMS,IME, JMS,JME & - ,ITS,ITE, JTS,JTE & - ,MYPE,MPI_COMM_COMP ) - CASE ('liss') - int_state%LSM_PHYSICS=LISSSCHEME - - CASE ('gfdlslab') - int_state%LSM_PHYSICS=GFDLSLABSCHEME -! WRITE(0,*)'See GFDL Surface Layer SF_GFDL' - - CASE DEFAULT - WRITE(0,*)' BAD SELECTION OF LAND SURFACE SCHEME: INIT' - END SELECT -! -!---------------------------------------------------------------------- -!**** Convection -!---------------------------------------------------------------------- -! - SELECT CASE (convection) - CASE ('bmj') - int_state%CU_PHYSICS=BMJSCHEME - CALL BMJ_INIT(int_state%CLDEFI,int_state%RESTART & - ,a2,a3,a4,cappa,cp & - ,pq0,r_d & - ,IDS,IDE,JDS,JDE & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE,LM) - - CASE ('sas') - int_state%CU_PHYSICS=SASSCHEME - CALL SAS_INIT -! - CASE ('sashur') - int_state%CU_PHYSICS=SASHURSCHEME - CALL SASHUR_INIT -! - CASE ('scalecu') - int_state%CU_PHYSICS=SCALECUSCHEME - CALL SCALECU_INIT( IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE,lm & - ,int_state%DUDT,int_state%DVDT & - ) -! - CASE ('none') -! WRITE(0,*)' User has chosen to run with no parameterized convection.' - CASE DEFAULT - WRITE(0,*)' BAD SELECTION OF CONVECTION SCHEME: INIT' - WRITE(0,*)' User selected CONVECTION = ',TRIM(CONVECTION) - CALL NMMB_FINALIZE - END SELECT -! -!---------------------------------------------------------------------- -!*** Microphysics -!---------------------------------------------------------------------- -! - SELECT CASE (microphysics) -! - CASE ('fer') - int_state%MP_PHYSICS=95 - DT_MICRO=int_state%NPRECIP*DT - DELX=-2.*int_state%WBD*111.3/REAL(int_state%IM) !DX at rotated equator (km) - DELY=-2.*int_state%SBD*111.3/REAL(int_state%JM) !DY at rotated equator (km) -! - CALL FERRIER_INIT(DT_MICRO,DT,DELX,DELY,int_state%RESTART & - ,int_state%F_ICE & - ,int_state%F_RAIN & - ,int_state%F_RIMEF & - ,int_state%MP_RESTART_STATE & - ,int_state%TBPVS_STATE & - ,int_state%TBPVS0_STATE & - ,ALLOWED_TO_READ & - ,IDS,IDE,JDS,JDE,1,LM+1 & - ,IMS,IME,JMS,JME,1,LM & - ,ITS,ITE,JTS,JTE,1,LM & - ,MPI_COMM_COMP,MYPE,int_state%MASSRout & - ,int_state%MASSIout) -! - CASE ('fer_hires') - int_state%MP_PHYSICS=5 - DT_MICRO=int_state%NPRECIP*DT - DELX=-2.*int_state%WBD*111.3/REAL(int_state%IM) !DX at rotated equator (km) - DELY=-2.*int_state%SBD*111.3/REAL(int_state%JM) !DY at rotated equator (km) -! - CALL FERRIER_INIT_HR(DT_MICRO,DT,DELX,DELY,int_state%RESTART & - ,int_state%F_ICE & - ,int_state%F_RAIN & - ,int_state%F_RIMEF & - ,int_state%MP_RESTART_STATE & - ,int_state%TBPVS_STATE & - ,int_state%TBPVS0_STATE & - ,ALLOWED_TO_READ & - ,IDS,IDE,JDS,JDE,1,LM+1 & - ,IMS,IME,JMS,JME,1,LM & - ,ITS,ITE,JTS,JTE,1,LM & - ,MPI_COMM_COMP,MYPE,int_state%MASSRout & - ,int_state%MASSIout) -! - CASE ('gfs') - int_state%MP_PHYSICS=99 - CALL GFSMP_INIT -! - CASE ('wsm6') - int_state%MP_PHYSICS=6 - CALL WSM6INIT(RHOAIR0,RHOWATER,RHOSNOW,CLIQ,CV & - ,ALLOWED_TO_READ ) -! - CASE ('thompson') - int_state%MP_PHYSICS=8 - CALL thompson_init() -! - CASE DEFAULT - WRITE(0,*)' BAD SELECTION OF MICROPHYSICS SCHEME: INIT' - WRITE(0,*)' User selected MICROPHYSICS = ',TRIM(MICROPHYSICS) - CALL NMMB_FINALIZE - - END SELECT -! -!---------------------------------------------------------------------- -!**** Gravity wave drag (GWD) & mountain blocking (MB) initialization -!---------------------------------------------------------------------- -! - DTPHS=int_state%DT*int_state%NPHS -! - CALL GWD_init(DTPHS,int_state%RESTART & - ,int_state%CLEFFAMP,int_state%DPHD & - ,int_state%CLEFF & - ,int_state%TPH0D,int_state%TLM0D & - ,int_state%GLAT,int_state%GLON & - ,int_state%CROT,int_state%SROT,int_state%HANGL & - ,IDS,IDE,JDS,JDE & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE,LM) -! -! uncomment this for output in future -! -! IF(.NOT.int_state%RESTART)THEN -! DO J=JMS,JME -! DO I=IMS,IME -! UGWDsfc(I,J)=0. -! VGWDsfc(I,J)=0. -! ENDDO -! ENDDO -! ENDIF -! -! -!---------------------------------------------------------------------- -! - ENDIF package -! -!---------------------------------------------------------------------- -! - END SUBROUTINE PHYSICS_INITIALIZE -! - -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE UPDATE_WATER(CWM,F_ICE,F_RAIN,F_RIMEF & - ,T,QC,QR,QS,QI,QG & - ,MICROPHYSICS,SPEC_ADV,NTIMESTEP & - ,IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE) -!*********************************************************************** -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: UPDATE_WATER UPDATE WATER ARRAY -! PRGRMMR: FERRIER ORG: NP22 DATE: 3 AUG 2009 -! -! ABSTRACT: -! UPDATE WATER ARRAY FOR FERRIER MICROPHYSICS -! -! PROGRAM HISTORY LOG (with changes to called routines) : -! 2009-08 FERRIER - Synchronize WATER array with CWM, F_rain, F_ice arrays -! -! USAGE: CALL UPDATE_WATER FROM PHY_RUN -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -!----------------------------------------------------------------------- - USE MODULE_CONSTANTS,ONLY : EPSQ,TIW -!----------------------------------------------------------------------- - IMPLICIT NONE -!----------------------------------------------------------------------- -! -!---------------------- -!-- Argument Variables -!---------------------- -! - INTEGER,INTENT(IN) :: NTIMESTEP & - ,IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE -! - CHARACTER(99),INTENT(IN) :: MICROPHYSICS -! - LOGICAL,INTENT(IN) :: SPEC_ADV -! - REAL,DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(INOUT) :: CWM & - ,F_ICE & - ,F_RAIN & - ,F_RIMEF & - ,T -! - REAL,DIMENSION(:,:,:),POINTER,INTENT(INOUT) :: QC,QR,QS,QI,QG -! -!-------------------- -!-- Local Variables -!-------------------- -! - INTEGER :: I,J,K, NW - REAL :: FRACTION, LIQW, OLDCWM - LOGICAL :: CLD_INIT - LOGICAL :: deep_ice -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - IF(NTIMESTEP<=1)THEN - CLD_INIT=.TRUE. - ELSE - CLD_INIT=.FALSE. - ENDIF -! -!---------------------------------------------------------------------- -!-- Couple 2 sets of condensed water arrays for different microphysics: -! QC,QR,QS, etc. arrays <=> CWM,F_ice,F_rain,F_RimeF 3D arrays -!---------------------------------------------------------------------- -! - SELECT CASE ( TRIM(MICROPHYSICS) ) -! -!---------------------------------------------------------------------- - CASE ('fer','fer_hires') !-- Update fields for Ferrier microphysics -!---------------------------------------------------------------------- -! - spec_adv_fer: IF (.NOT.SPEC_ADV .OR. CLD_INIT) THEN -!-- Update WATER arrays when advecting only total condensate (spec_adv=F) -! or at the initial time step - DO K=1,LM - DO J=JMS,JME - DO I=IMS,IME - IF (CWM(I,J,K)>EPSQ) THEN - LIQW=(1.-F_ice(I,J,K))*CWM(I,J,K) - QC(I,J,K)=(1.-F_rain(I,J,K))*LIQW - QR(I,J,K)=F_rain(I,J,K)*LIQW - QS(I,J,K)=F_ice(I,J,K)*CWM(I,J,K) - ELSE - QC(I,J,K)=0. - QR(I,J,K)=0. - QS(I,J,K)=0. - ENDIF - ENDDO - ENDDO - ENDDO -! - ELSE spec_adv_fer -!-- Update CWM,F_ICE,F_RAIN arrays from separate species advection (spec_adv=T) - DO K=1,LM - DO J=JMS,JME - DO I=IMS,IME - CWM(I,J,K)=QC(I,J,K)+QR(I,J,K)+QS(I,J,K) - IF (QS(I,J,K)>EPSQ) THEN - F_ICE(I,J,K)=QS(I,J,K)/CWM(I,J,K) - ELSE - F_ICE(I,J,K)=0.0 - ENDIF - IF (QR(I,J,K)>EPSQ) THEN - F_RAIN(I,J,K)=QR(I,J,K)/(QC(I,J,K)+QR(I,J,K)) - ELSE - F_RAIN(I,J,K)=0. - ENDIF - ENDDO - ENDDO - ENDDO - ENDIF spec_adv_fer -! -!---------------------------------------------------------------------- - CASE ('gfs') !-- Update fields for GFS microphysics -!---------------------------------------------------------------------- -! - spec_adv_gfs: IF (.NOT.SPEC_ADV .OR. CLD_INIT) THEN - cld_init_gfs: IF (CLD_INIT) THEN -!-- Initialize F_ICE, F_RAIN, & F_RIMEF arrays - IF (SPEC_ADV) THEN - WRITE(0,*) 'Never ran GFS microphysics with SPEC_ADV=T.' & - ,' Use at your own risk.' - ENDIF - DO K=1,LM - DO J=JMS,JME - DO I=IMS,IME - F_RAIN(I,J,K)=0. - F_RIMEF(I,J,K)=1. - IF (CWM(I,J,K)>EPSQ .AND. T(I,J,K)<233.15) THEN - F_ICE(I,J,K)=1. - ELSE - F_ICE(I,J,K)=0. - ENDIF - ENDDO - ENDDO - ENDDO - ENDIF cld_init_gfs -!-- Update WATER arrays (QC,QI) when advecting only total condensate (spec_adv=F) -! or initialize them at the start of the forecast (CLD_INIT=T). - DO K=1,LM - DO J=JMS,JME - DO I=IMS,IME - IF (CWM(I,J,K)>EPSQ) THEN - QC(I,J,K)=(1.-F_ice(I,J,K))*CWM(I,J,K) - QI(I,J,K)=F_ice(I,J,K)*CWM(I,J,K) - ELSE - QC(I,J,K)=0. - QI(I,J,K)=0. - ENDIF - ENDDO - ENDDO - ENDDO - ELSE spec_adv_gfs -!-- Update CWM, F_ICE arrays from separate species advection (spec_adv=T) - DO K=1,LM - DO J=JMS,JME - DO I=IMS,IME - CWM(I,J,K)=QC(I,J,K)+QI(I,J,K) - IF (CWM(I,J,K)>EPSQ) THEN - F_ICE(I,J,K)=QI(I,J,K)/CWM(I,J,K) - ELSE - F_ICE(I,J,K)=0. - ENDIF - ENDDO - ENDDO - ENDDO - ENDIF spec_adv_gfs -! -!---------------------------------------------------------------------- - CASE ('wsm6') !-- Update fields for WSM6 microphysics -!---------------------------------------------------------------------- -! - init_adv_wsm6: IF (CLD_INIT) THEN -!-- Assume only cloud ice is present at initial time - DO K=1,LM - DO J=JMS,JME - DO I=IMS,IME - QS(I,J,K)=0.0 - QG(I,J,K)=0.0 - IF (CWM(I,J,K)>EPSQ) THEN - LIQW=(1.-F_ice(I,J,K))*CWM(I,J,K) - QC(I,J,K)=(1.-F_rain(I,J,K))*LIQW - QR(I,J,K)=F_rain(I,J,K)*LIQW - QI(I,J,K)=F_ice(I,J,K)*CWM(I,J,K) - ELSE - QC(I,J,K)=0. - QR(I,J,K)=0. - QI(I,J,K)=0. - ENDIF - ENDDO - ENDDO - ENDDO - ELSE init_adv_wsm6 - notspec_adv_wsm6: IF (.NOT.SPEC_ADV) THEN -!-- Update WATER arrays (QC,QR,...) when advecting only total condensate (spec_adv=F). -!-- Assume fraction of each water category is unchanged by advection. - DO K=1,LM - DO J=JMS,JME - DO I=IMS,IME - OLDCWM=QC(I,J,K)+QR(I,J,K) & - +QI(I,J,K)+QS(I,J,K) & - +QG(I,J,K) - IF (OLDCWM>EPSQ) THEN - FRACTION=CWM(I,J,K)/OLDCWM - QC(I,J,K)=FRACTION*QC(I,J,K) - QR(I,J,K)=FRACTION*QR(I,J,K) - QI(I,J,K)=FRACTION*QI(I,J,K) - QS(I,J,K)=FRACTION*QS(I,J,K) - QG(I,J,K)=FRACTION*QG(I,J,K) - ELSE - QC(I,J,K)=0.0 - QR(I,J,K)=0.0 - QI(I,J,K)=0.0 - QS(I,J,K)=0.0 - QG(I,J,K)=0.0 - IF (T(I,J,K)<233.15) THEN - QI(I,J,K)=CWM(I,J,K) - ELSE - QC(I,J,K)=CWM(I,J,K) - ENDIF - ENDIF - ENDDO - ENDDO - ENDDO - ENDIF notspec_adv_wsm6 -! -!-- Couple QC,QR,... <=> CWM,F_ice,F_rain,F_RimeF arrays -!-- Update CWM,F_XXX arrays from separate species advection (spec_adv=T) -! - DO K=1,LM - DO J=JMS,JME - DO I=IMS,IME - CWM(I,J,K)=QC(I,J,K)+QR(I,J,K) & - +QI(I,J,K)+QS(I,J,K) & - +QG(I,J,K) - IF (CWM(I,J,K)>EPSQ) THEN - LIQW=QI(I,J,K)+QS(I,J,K)+QG(I,J,K) - F_ICE(I,J,K)=LIQW/CWM(I,J,K) - ELSE - F_ICE(I,J,K)=0. - ENDIF - IF (QR(I,J,K)>EPSQ) THEN - F_RAIN(I,J,K)=QR(I,J,K)/(QC(I,J,K)+QR(I,J,K)) - ELSE - F_RAIN(I,J,K)=0. - ENDIF - IF (QG(I,J,K)>EPSQ) THEN -!-- Update F_RIMEF: assume 5x higher graupel density (500 kg/m**3) vs snow (100 kg/m**3) - LIQW=5.*QG(I,J,K)+QS(I,J,K) - F_RIMEF(I,J,K)=LIQW/(QS(I,J,K)+QG(I,J,K)) - ELSE - F_RIMEF(I,J,K)=1. - ENDIF - ENDDO - ENDDO - ENDDO -! - ENDIF init_adv_wsm6 -! -!---------------------------------------------------------------------- - CASE ('thompson') !-- Update fields for Thompson microphysics -!---------------------------------------------------------------------- -! -!+---+-----------------------------------------------------------------+ -!..The CLD_INIT test provides a way to translate initial values of CWM -!.. into coomponent species of cloud water, rain, and ice, but not snow -!.. or graupel. Thompson MP will pretty rapidly make snow from the -!.. cloud ice field. Next IF-test is whether individual species -!.. advection is enabled, which almost certainly should be the case when -!.. picking this scheme. In this case, the separate species are summed -!.. into the CWM and ice, rain, and rime variables are computed only for -!.. consistency with other schemes. But, if single species advection is -!.. not enabled, then each t-step the CWM array needs to be split into -!.. component species to prepare MP routine to have some semblance of -!.. proper individual species. Again, this is strongly discouraged. -!+---+-----------------------------------------------------------------+ - spec_adv_thompson: IF (CLD_INIT) THEN - DO K=1,LM - DO J=JMS,JME - DO I=IMS,IME - QS(I,J,K)=0.0 - QG(I,J,K)=0.0 - IF (CWM(I,J,K) .gt. EPSQ) THEN - LIQW=(1.-F_ice(I,J,K))*CWM(I,J,K) - QC(I,J,K)=(1.-F_rain(I,J,K))*LIQW - QR(I,J,K)=F_rain(I,J,K)*LIQW - QI(I,J,K)=F_ice(I,J,K)*CWM(I,J,K) - ELSE - QC(I,J,K)=0. - QR(I,J,K)=0. - QI(I,J,K)=0. - ENDIF - ENDDO - ENDDO - ENDDO - ELSE IF(SPEC_ADV) THEN spec_adv_thompson - DO K=1,LM - DO J=JMS,JME - DO I=IMS,IME - CWM(I,J,K) = QC(I,J,K)+QR(I,J,K) & - + QI(I,J,K) & - + QS(I,J,K)+QG(I,J,K) - IF (CWM(I,J,K) .gt. EPSQ) THEN - LIQW = MAX(0., CWM(I,J,K) - QI(I,J,K) & - - QS(I,J,K) & - - QG(I,J,K)) - F_ICE(I,J,K) = MAX(0., 1.0 - LIQW/CWM(I,J,K)) - IF (QR(I,J,K) .gt. EPSQ) THEN - F_RAIN(I,J,K) = QR(I,J,K) & - / (QC(I,J,K)+QR(I,J,K)) - ELSE - F_RAIN(I,J,K)=0. - ENDIF - IF (QG(I,J,K) .gt. EPSQ) THEN - F_RIMEF(I,J,K) = (5.*QG(I,J,K) & - + QS(I,J,K)) & - / (QS(I,J,K) & - + QG(I,J,K)) - ELSE - F_RIMEF(I,J,K)=1. - ENDIF - ELSE - F_ICE(I,J,K) = 0. - F_RAIN(I,J,K)=0. - F_RIMEF(I,J,K)=1. - CWM(I,J,K) = 0. - ENDIF - ENDDO - ENDDO - ENDDO - ELSE spec_adv_thompson - ! write(0,*) 'WARNING: This option is STRONGLY DISCOURAGED' - ! write(0,*) ' please consider using full advection of all' - ! write(0,*) ' species when picking Thompson microphysics.' - DO J=JMS,JME - DO I=IMS,IME - DO K=LM,1,-1 - deep_ice = .false. - IF (CWM(I,J,K) .gt. EPSQ) THEN - OLDCWM = QC(I,J,K)+QR(I,J,K) & - + QI(I,J,K) & - + QS(I,J,K)+QG(I,J,K) - IF (OLDCWM .gt. EPSQ) THEN - LIQW = MAX(0., OLDCWM - QI(I,J,K) & - - QS(I,J,K) & - - QG(I,J,K)) - F_ICE(I,J,K) = MAX(0., 1.0 - LIQW/OLDCWM) - IF (QR(I,J,K) .gt. EPSQ) THEN - F_RAIN(I,J,K) = QR(I,J,K) & - / (QC(I,J,K)+QR(I,J,K)) - ELSE - F_RAIN(I,J,K)=0. - ENDIF - IF (QG(I,J,K) .gt. EPSQ) THEN - F_RIMEF(I,J,K) = (5.*QG(I,J,K) & - + QS(I,J,K)) & - / (QS(I,J,K) & - + QG(I,J,K)) - ELSE - F_RIMEF(I,J,K)=1. - ENDIF - LIQW = MAX(0., (1.-F_ICE(I,J,K))*CWM(I,J,K)) - QR(I,J,K) = LIQW*F_RAIN(I,J,K)*CWM(I,J,K) - QC(I,J,K) = LIQW*(1.-F_RAIN(I,J,K))*CWM(I,J,K) - IF (QG(I,J,K) .gt. EPSQ) THEN - FRACTION = MAX(0., MIN(QG(I,J,K) & - / (QG(I,J,K)+QS(I,J,K)), 1.) ) - ELSE - FRACTION = 0. - ENDIF - QG(I,J,K) = FRACTION*F_ICE(I,J,K)*CWM(I,J,K) - QI(I,J,K) = 0.1*(1.-FRACTION)*F_ICE(I,J,K)*CWM(I,J,K) - QS(I,J,K) = 0.9*(1.-FRACTION)*F_ICE(I,J,K)*CWM(I,J,K) - - ELSE ! Below, the condensate is all new here - QC(I,J,K) = 0.0 - QI(I,J,K) = 0.0 - QR(I,J,K) = 0.0 - QS(I,J,K) = 0.0 - QG(I,J,K) = 0.0 - IF (T(I,J,K) .le. 235.15) THEN - QI(I,J,K) = 0.5*CWM(I,J,K) - QS(I,J,K) = 0.5*CWM(I,J,K) - ELSEIF (T(I,J,K) .le. 258.15) THEN - QI(I,J,K) = 0.1*CWM(I,J,K) - QS(I,J,K) = 0.9*CWM(I,J,K) - deep_ice = .true. - ELSEIF (T(I,J,K) .le. 275.15) THEN - if (deep_ice .and. T(I,J,K).lt.273.15) then - QS(I,J,K) = CWM(I,J,K) - elseif (deep_ice .and. T(I,J,K).lt.274.15) then - QS(I,J,K) = 0.333*CWM(I,J,K) - QR(I,J,K) = 0.667*CWM(I,J,K) - elseif (deep_ice) then - QS(I,J,K) = 0.1*CWM(I,J,K) - QR(I,J,K) = 0.9*CWM(I,J,K) - else - QC(I,J,K) = CWM(I,J,K) - endif - ELSE - QC(I,J,K) = CWM(I,J,K) - ENDIF - LIQW = MAX(0., CWM(I,J,K) - QI(I,J,K) & - - QS(I,J,K) & - - QG(I,J,K)) - IF (CWM(I,J,K) .gt. EPSQ) THEN - F_ICE(I,J,K) = (1.0-LIQW)/CWM(I,J,K) - ELSE - F_ICE(I,J,K) = 0. - ENDIF - IF (QR(I,J,K) .gt. EPSQ) THEN - F_RAIN(I,J,K) = QR(I,J,K) & - / (QC(I,J,K)+QR(I,J,K)) - ELSE - F_RAIN(I,J,K)=0. - ENDIF - IF (QG(I,J,K) .gt. EPSQ) THEN - F_RIMEF(I,J,K) = (5.*QG(I,J,K) & - + QS(I,J,K)) & - / (QS(I,J,K) & - + QG(I,J,K)) - ELSE - F_RIMEF(I,J,K)=1. - ENDIF - ENDIF - ELSE - QC(I,J,K) = 0.0 - QR(I,J,K) = 0.0 - QI(I,J,K) = 0.0 - QS(I,J,K) = 0.0 - QG(I,J,K) = 0.0 - F_ICE(I,J,K) = 0.0 - F_RAIN(I,J,K) = 0.0 - F_RIMEF(I,J,K) = 1.0 - ENDIF - ENDDO - ENDDO - ENDDO - ENDIF spec_adv_thompson - -! -!---------------------------------------------------------------------- - CASE DEFAULT -!---------------------------------------------------------------------- -! - IF (CLD_INIT) THEN - WRITE(0,*) 'Do nothing for default option' - ENDIF -! - END SELECT ! MICROPHYSICS -! -!---------------------------------------------------------------------- -! - END SUBROUTINE UPDATE_WATER - -!---------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- - -! - SUBROUTINE CALC_RH_RADAR_DFI(T,Q,PD,PSGML1,SGML2 & - ,R_D,R_V,RH_HOLD & - ,IMS,IME,JMS,JME,LM & - ,IFLAG) - - USE MODULE_MP_ETANEW, ONLY : FERRIER_INIT,GPVS,FPVS & - ,FPVS0,NX,RQR_DRmin & - ,RQR_DRmax,MASSI,CN0R0 & - ,CN0r_DMRmin,CN0r_DMRmax - - IMPLICIT NONE - -!tst - INTEGER, INTENT(IN):: IMS,IME,JMS,JME, LM - - REAL :: T(IMS:IME,JMS:JME,1:LM) - REAL :: Q(IMS:IME,JMS:JME,1:LM) - REAL :: RH_HOLD(IMS:IME,JMS:JME,1:LM) - REAL :: PD(IMS:IME,JMS:JME) - REAL :: PSGML1(LM),SGML2(LM) - REAL :: R_D,R_V,PMID,VPRES,SATVPRES, EPS, DEN - INTEGER :: IFLAG,I,J,L - - EPS=R_D/R_V - - IF (IFLAG == 1) THEN - DO L=1,LM - DO J=JMS,JME - DO I=IMS,IME - PMID=SGML2(L)*PD(I,J)+PSGML1(L) - DEN=EPS+Q(I,J,L)*(1.-EPS) - VPRES=PMID*Q(I,J,L)/DEN - SATVPRES=1.E3*FPVS0(T(I,J,L)) - RH_HOLD(I,J,L)=VPRES/SATVPRES - ENDDO - ENDDO - ENDDO - ENDIF - - IF (IFLAG == -1) THEN - DO L=1,LM - DO J=JMS,JME - DO I=IMS,IME - SATVPRES=1.E3*FPVS0(T(I,J,L)) - VPRES=SATVPRES*RH_HOLD(I,J,L) - PMID=SGML2(L)*PD(I,J)+PSGML1(L) - DEN=PMID-VPRES*(1.-EPS) - Q(I,J,L)=VPRES*EPS/DEN - ENDDO - ENDDO - ENDDO - ENDIF - - END SUBROUTINE CALC_RH_RADAR_DFI - - -!---------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- - - SUBROUTINE CLTEND (ICLTEND,NPRECIP, T,Told,Tadj & - ,IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE) -!---------------------------------------------------------------------- -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: CLTEND TEMPERATURE CHANGE BY CLOUD PROCESSES -! PRGRMMR: FERRIER ORG: W/NP22 DATE: 01-09-26 -! -! ABSTRACT: -! CLTEND GRADUALLY UPDATES TEMPERATURE TENDENCIES FROM CONVECTION -! AND GRID-SCALE MICROPHYSICS. -! -! USAGE: CALL CLTEND FROM SOLVER_RUN -! INPUT ARGUMENT LIST: -! ICLTEND - FLAG SET TO -1 PRIOR TO PHYSICS CALLS, 0 AFTER PHYSICS -! CALLS, AND 1 FOR UPDATING TEMPERATURES EVERY TIME STEP -! -! OUTPUT ARGUMENT LIST: NONE -! -! OUTPUT FILES: NONE -! -! SUBPROGRAMS CALLED: NONE -! -! UNIQUE: NONE -! -! LIBRARY: NONE -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -!$$$ -!---------------------------------------------------------------------- -! - IMPLICIT NONE -! -!---------------------------------------------------------------------- -! - INTEGER,INTENT(IN) :: ICLTEND,NPRECIP & - ,IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE -! - REAL,DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(INOUT) :: T & - ,Tadj & - ,Told -! -!*** LOCAL VARIABLES -! - INTEGER :: I,J,K - REAL :: RDTPH -! -!---------------------------------------------------------------------- -!---------------------------------------------------------------------- -! - IF(ICLTEND<0)THEN - DO K=1,LM - DO J=JTS,JTE - DO I=ITS,ITE - Told(I,J,K)=T(I,J,K) - ENDDO - ENDDO - ENDDO - ELSE IF(ICLTEND==0)THEN - RDTPH=1./REAL(NPRECIP) - DO K=1,LM - DO J=JTS,JTE - DO I=ITS,ITE - Tadj(I,J,K)=RDTPH*(T(I,J,K)-Told(I,J,K)) - T(I,J,K)=Told(I,J,K) - ENDDO - ENDDO - ENDDO - ELSE - DO K=1,LM - DO J=JTS,JTE - DO I=ITS,ITE - T(I,J,K)=T(I,J,K)+Tadj(I,J,K) - ENDDO - ENDDO - ENDDO - ENDIF -!---------------------------------------------------------------------- -! - END SUBROUTINE CLTEND -! -!----------------------------------------------------------------------- -!---------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- - - SUBROUTINE RIME_FACTOR_UPDATE (RIME_FACTOR_INPUT & - ,QS,QG,F_RIMEF & - ,IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE) -!---------------------------------------------------------------------- -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: RIME_FACTOR_UPDATE -! PRGRMMR: FERRIER ORG: W/NP22 DATE: 2013-06-14 -! -! ABSTRACT: -! -! UPDATES THE RIME FACTOR ARRAY AFTER 3D ADVECTION -! -! USAGE: CALL CLTEND FROM SOLVER_RUN -! INPUT ARGUMENT LIST: -! RIME_FACTOR_INPUT= TRUE BEFORE ADVECTION, RIME_FACTOR IS INPUT -! RIME_FACTOR_INPUT=FALSE BEFORE ADVECTION, RIME FACTOR IS OUTPUT -! -! OUTPUT ARGUMENT LIST: NONE -! -! OUTPUT FILES: NONE -! -! SUBPROGRAMS CALLED: NONE -! -! UNIQUE: NONE -! -! LIBRARY: NONE -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE : IBM SP -!$$$ -!---------------------------------------------------------------------- -! - IMPLICIT NONE -! -!---------------------------------------------------------------------- -! - LOGICAL,INTENT(IN) :: RIME_FACTOR_INPUT -! - INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE -! - REAL,DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(INOUT) :: F_RIMEF -! - REAL,DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(INOUT) :: QS,QG -! -!*** LOCAL VARIABLES -! - INTEGER :: I,J,K - REAL :: RIMEF -! -!---------------------------------------------------------------------- - IF (RIME_FACTOR_INPUT) THEN !-- Before advection - DO K=1,LM - DO J=JTS,JTE - DO I=ITS,ITE - QG(I,J,K)=QS(I,J,K)*F_RIMEF(I,J,K) - ENDDO - ENDDO - ENDDO -! - CALL HALO_EXCH(QG,LM,2,2) -! - - ELSE !-- After advection - DO K=1,LM - DO J=JMS,JME - DO I=IMS,IME - IF (QG(I,J,K)>EPSQ .AND. & - QS(I,J,K)>EPSQ) THEN - RIMEF=QG(I,J,K)/QS(I,J,K) - F_RIMEF(I,J,K)=MIN(50., MAX(1.,RIMEF) ) - ELSE - F_RIMEF(I,J,K)=1. - ENDIF - ENDDO - ENDDO - ENDDO - ENDIF - END SUBROUTINE RIME_FACTOR_UPDATE -! -!---------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- - - SUBROUTINE TQADJUST(T,Q,QC,CWM,F_ICE,F_RAIN & - ,PD,DSG2,PDSG1,PSGML1,SGML2 & - ,SPEC_ADV,RHgrd & - ,IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE) -!*********************************************************************** -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: TQADJUST TQADJUST -! PRGRMMR: FERRIER ORG: NP22 DATE: 5 APR 2016 -! -! ABSTRACT: -! Smooth temperature profiles when lapse rates exceed dry adiabatic -! above PBL, prevent supersaturation with respect to water. -! -! PROGRAM HISTORY LOG (with changes to called routines) : -! 2016-04 FERRIER, JANJIC - Smooth T profiles, prevent supersaturation -! -! USAGE: CALL TQADJUST FROM PHY_RUN -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -!----------------------------------------------------------------------- -! - USE MODULE_CONSTANTS,ONLY : CAPPA,CP,EP_2,EPSQ,R_d,R_v,CPV,CLIQ, & - A2,A4,PSAT,XLV,TIW - USE MODULE_MP_ETANEW, ONLY : FPVS0 -! -!----------------------------------------------------------------------- - IMPLICIT NONE -!----------------------------------------------------------------------- -! -!---------------------- -!-- Input argument variables -!---------------------- -! - REAL,DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(INOUT) :: & - T,Q,QC,CWM,F_ICE,F_RAIN - REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: PD - REAL,DIMENSION(1:LM),INTENT(IN) :: DSG2,PDSG1,PSGML1,SGML2 - REAL,INTENT(IN) :: RHgrd - LOGICAL,INTENT(IN) :: SPEC_ADV - INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE -! -!-- Local Variables -! - INTEGER :: I,J,K,LM2,KMIX,KTHmin,KBOT,KTOP,ITmax,ITER,ITRmax - REAL :: RCP,RRV,TK,PP,QV,QCW,TREF,ESW,QSW,DQsat,SSat,DTHmin,COND, & - Qrain,Qice,Qliq - REAL,DIMENSION(1:LM) :: Tcol,Pcol,QVcol,QCcol,EXNcol,THcol,DPcol, & - DTHcol,Fcol - LOGICAL :: LRFilt,SSFilt -! - REAL,PARAMETER :: SupSat=0.001, SubSat=-SupSat, DTHthresh=-0.01, & - TTP=TIW+0.01, XA=(CLIQ-CPV)/R_V, XB=XA+XLV/(R_V*TTP), & - XLV1=XLV/CP, XLV2=XLV1*XLV/R_V -! -!----------------------------------------------------------------------- -! - ITmax=LM/5 - LM2=LM-2 -! -!----------------------------------------------------------------------- -!-- Main loop through I, J, ------------------------------------------ -!----------------------------------------------------------------------- -! - DO J=JTS,JTE - DO I=ITS,ITE -! - LRFilt=.FALSE. ! Lapse rate flag (full column) - SSFilt=.FALSE. ! Supersaturation flag - IF(SPEC_ADV) THEN - DO K=1,LM - QCcol(K)=QC(I,J,K) - ENDDO - ELSE - DO K=1,LM - QCcol(K)=CWM(I,J,K)*(1.-F_ICE(I,J,K))*(1.-F_RAIN(I,J,K)) - ENDDO - ENDIF - DO K=1,LM - Tcol(K)=T(I,J,K) - Pcol(K)=SGML2(K)*PD(I,J)+PSGML1(K) - QVcol(K)=Q(I,J,K)/(1.-Q(I,J,K)) ! Water vapor mixing ratio - EXNcol(K)=(1.E5/Pcol(K))**CAPPA - ENDDO -! -!----------------------------------------------------------------------- -!-- Ferrier-Aligo condensation/evaporation algorithm - 1st of 2 times -!----------------------------------------------------------------------- -! -SSadj1: DO K=1,LM - TK=Tcol(K) ! Temperature (deg K) - PP=Pcol(K) ! Pressure (Pa) - QV=QVcol(K) ! Water vapor mixing ratio - QCW=QCcol(K) ! Cloud water mixing ratio -! TREF=TTP/TK ! WSM6 -! ESW=PSAT*EXP(LOG(TREF)*(XA))*EXP(XB*(1.-TREF)) ! WSM6 -! ESW=1000.*FPVS0(TK) ! Old global tables - ESW=PSAT*EXP(A2*(TK-TTP)/(TK-A4)) ! Magnus Tetens -! TREF=TK-TIW ! Bolton (1980) -! ESW=611.2*EXP(17.67*TREF/(TREF+243.5)) ! Bolton (1980) - ESW=MIN(ESW,0.99*PP) ! Saturation vapor pressure (water) - QSW=RHgrd*EP_2*ESW/(PP-ESW) ! Saturation mixing ratio (water) - DQsat=QV-QSW ! Excess QV above saturation - SSat=DQsat/QSW ! Grid-scale supersaturation ratio -SSrem1: IF(SSat>SupSat .OR. & ! Remove supersaturation if SSat>0.1% - (QCW>EPSQ .AND. SSat=SubSat .AND. SSat<=SupSat) EXIT ! Exit if -0.1%0.) THEN -!-- Start above the well-mixed layer immediately above the -! surface where theta may decrease with height - KMIX=K - EXIT - ENDIF - ENDDO -! -!************************* -LRadjust: IF (KMIX>2) THEN -!************************* -! - KTOP=0 - DO K=3,KMIX - IF(DTHcol(K)0) THEN -!------------------------- -! - KBOT=0 - DO K=KMIX,2,-1 - IF(DTHcol(K)0) THEN - LRFilt=.TRUE. !- For the full column (any layer) - ITRmax=ITmax - ELSE - ITRmax=0 !- Do not mix - ENDIF -! - DO K=1,LM - DPcol(K)=DSG2(K)*PD(I,J)+PDSG1(K) ! Hydrostatic pressure thickness - Fcol(K)=THcol(K) !- Fcol, modified theta - ENDDO -! -!- - - - - - - - - - - - - -Mix_lyrs: DO ITER=1,ITRmax -!- - - - - - - - - - - - - - DO K=KTOP,KBOT - IF(DTHcol(K)0) -!------------------------- -!************************* - ENDIF LRadjust -!************************* -! -!----------------------------------------------------------------------- -!-- Ferrier-Aligo condensation/evaporation algorithm - 2nd of 2 times -!----------------------------------------------------------------------- -! -SSadj2: DO K=1,LM - TK=Tcol(K) ! Temperature (deg K) - PP=Pcol(K) ! Pressure (Pa) - QV=QVcol(K) ! Water vapor mixing ratio - QCW=QCcol(K) ! Cloud water mixing ratio -! TREF=TTP/TK ! WSM6 -! ESW=PSAT*EXP(LOG(TREF)*(XA))*EXP(XB*(1.-TREF)) ! WSM6 -! ESW=1000.*FPVS0(TK) ! Old global tables - ESW=PSAT*EXP(A2*(TK-TTP)/(TK-A4)) ! Magnus Tetens -! TREF=TK-TIW ! Bolton (1980) -! ESW=611.2*EXP(17.67*TREF/(TREF+243.5)) ! Bolton (1980) - ESW=MIN(ESW,0.99*PP) ! Saturation vapor pressure (water) - QSW=RHgrd*EP_2*ESW/(PP-ESW) ! Saturation mixing ratio (water) - DQsat=QV-QSW ! Excess QV above saturation - SSat=DQsat/QSW ! Grid-scale supersaturation ratio -SSrem2: IF(SSat>SupSat .OR. & ! Remove supersaturation if SSat>0.1% - (QCW>EPSQ .AND. SSat=SubSat .AND. SSat<=SupSat) EXIT ! Exit if -0.1%EPSQ) F_ICE(I,J,K)=Qice/CWM(I,J,K) - IF(Qliq>EPSQ) F_RAIN(I,J,K)=Qrain/Qliq - ENDDO - ENDIF - ENDIF adjust2 -! - ENDDO !- I - ENDDO !- J -!----------------------------------------------------------------------- -! - END SUBROUTINE TQADJUST - -!---------------------------------------------------------------------- -!###################################################################### -!----------------------------------------------------------------------- - - END MODULE MODULE_SOLVER_GRID_COMP -! -!----------------------------------------------------------------------- diff --git a/src/nmm/module_SOLVER_INTERNAL_STATE.F90 b/src/nmm/module_SOLVER_INTERNAL_STATE.F90 deleted file mode 100644 index f2cee11..0000000 --- a/src/nmm/module_SOLVER_INTERNAL_STATE.F90 +++ /dev/null @@ -1,1679 +0,0 @@ -!----------------------------------------------------------------------- - - MODULE MODULE_SOLVER_INTERNAL_STATE - -!----------------------------------------------------------------------- -!*** Declare the derived datatype called SOLVER_INTERNAL_STATE. -!*** For now the components of this datatype will include everything -!*** needed to advance the model integration, i.e. everything that -!*** would be part of a restart file. Specifically this will include -!*** those quantities that evolve during the integration, the namelist -!*** variables, and the grid decomposition variables. -!----------------------------------------------------------------------- -! - USE ESMF -! - USE module_KINDS - USE module_DERIVED_TYPES,ONLY: BC_H_ALL,BC_V_ALL - USE module_CONTROL, ONLY: NUM_DOMAINS_MAX - - USE module_LS_NOAHLSM, ONLY: NUM_SOIL_LAYERS - USE module_MICROPHYSICS_NMM, ONLY: MICRO_RESTART - - USE module_VARS -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: SOLVER_INTERNAL_STATE & - ,SET_INTERNAL_STATE_SOLVER & - ,WRAP_SOLVER_INT_STATE & - ,TRACK_MAX_OLD -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - INTEGER, PARAMETER :: MAX_VARS = 310 - INTEGER, PARAMETER :: TRACK_MAX_OLD = 100 ! max # of old track fixes to store -! - TYPE SOLVER_INTERNAL_STATE -! - INTEGER(kind=KINT) :: NUM_VARS = 0 - TYPE(VAR),DIMENSION(MAX_VARS) :: VARS -! -!----------------------------------------------------------------------- -!*** Begin with the 'generic' variables. Variables which are pointers -! associated with a memory allocated in VARS -!----------------------------------------------------------------------- -! - ! 0D integer - INTEGER(kind=KINT), POINTER :: IM => NULL() - INTEGER(kind=KINT), POINTER :: JM => NULL() - INTEGER(kind=KINT), POINTER :: LM => NULL() - INTEGER(kind=KINT), POINTER :: IHRST => NULL() - INTEGER(kind=KINT), POINTER :: I_PAR_STA => NULL() - INTEGER(kind=KINT), POINTER :: J_PAR_STA => NULL() - INTEGER(kind=KINT), POINTER :: LAST_STEP_MOVED => NULL() - INTEGER(kind=KINT), POINTER :: LPT2 => NULL() - INTEGER(kind=KINT), POINTER :: NSOIL => NULL() - INTEGER(kind=KINT), POINTER :: NPHS => NULL() - INTEGER(kind=KINT), POINTER :: NCLOD => NULL() - INTEGER(kind=KINT), POINTER :: NHEAT => NULL() - INTEGER(kind=KINT), POINTER :: NMTS => NULL() - INTEGER(kind=KINT), POINTER :: NPREC => NULL() - INTEGER(kind=KINT), POINTER :: NRDLW => NULL() - INTEGER(kind=KINT), POINTER :: NRDSW => NULL() - INTEGER(kind=KINT), POINTER :: NSRFC => NULL() - INTEGER(kind=KINT), POINTER :: AVGMAXLEN => NULL() - INTEGER(kind=KINT), POINTER :: MDRMINout => NULL() - INTEGER(kind=KINT), POINTER :: MDRMAXout => NULL() - INTEGER(kind=KINT), POINTER :: MDIMINout => NULL() - INTEGER(kind=KINT), POINTER :: MDIMAXout => NULL() - INTEGER(kind=KINT), POINTER :: IVEGSRC => NULL() - INTEGER(kind=KINT), POINTER :: CU_PHYSICS => NULL() - INTEGER(kind=KINT), POINTER :: MP_PHYSICS => NULL() - INTEGER(kind=KINT), POINTER :: LSM_PHYSICS => NULL() - - ! 0D real - REAL(kind=KFPT), POINTER :: DT => NULL() - REAL(kind=KFPT), POINTER :: DYH => NULL() - REAL(kind=KFPT), POINTER :: PDTOP => NULL() - REAL(kind=KFPT), POINTER :: PT => NULL() - REAL(kind=KFPT), POINTER :: TLM0D => NULL() - REAL(kind=KFPT), POINTER :: TPH0D => NULL() - REAL(kind=KFPT), POINTER :: TSTART => NULL() - REAL(kind=KFPT), POINTER :: DLMD => NULL() - REAL(kind=KFPT), POINTER :: DPHD => NULL() - REAL(kind=KFPT), POINTER :: SBD => NULL() - REAL(kind=KFPT), POINTER :: WBD => NULL() - - ! 1D integer - INTEGER(kind=KINT),DIMENSION(:), POINTER :: IDAT => NULL() - INTEGER(kind=KINT),DIMENSION(:), POINTER :: NTSCM => NULL() - - ! 1D real - REAL(kind=KFPT),DIMENSION(:),POINTER :: DXH => NULL() - REAL(kind=KFPT),DIMENSION(:),POINTER :: SG1 => NULL() - REAL(kind=KFPT),DIMENSION(:),POINTER :: SG2 => NULL() - REAL(kind=KFPT),DIMENSION(:),POINTER :: DSG1 => NULL() - REAL(kind=KFPT),DIMENSION(:),POINTER :: DSG2 => NULL() - REAL(kind=KFPT),DIMENSION(:),POINTER :: SGML1 => NULL() - REAL(kind=KFPT),DIMENSION(:),POINTER :: SGML2 => NULL() - REAL(kind=KFPT),DIMENSION(:),POINTER :: SGM => NULL() - REAL(kind=KFPT),DIMENSION(:),POINTER :: EPSL => NULL() - REAL(kind=KFPT),DIMENSION(:),POINTER :: EPSQ2 => NULL() - REAL(kind=KFPT),DIMENSION(:),POINTER :: SLDPTH => NULL() - REAL(kind=KFPT),DIMENSION(:),POINTER :: MP_RESTART_STATE => NULL() - REAL(kind=KFPT),DIMENSION(:),POINTER :: TBPVS_STATE => NULL() - REAL(kind=KFPT),DIMENSION(:),POINTER :: TBPVS0_STATE => NULL() - REAL(kind=KFPT),DIMENSION(:),POINTER :: MASSRout => NULL() - REAL(kind=KFPT),DIMENSION(:),POINTER :: MASSIout => NULL() - - ! 2D integer - INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: ISLTYP => NULL() - INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: IVGTYP => NULL() - INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: NCFRCV => NULL() - INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: NCFRST => NULL() - - ! 2D real - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: BARO => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: FIS => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: GLAT => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: GLON => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: HDACX => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: HDACY => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: PD => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: F => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: VLAT => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: VLON => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: HDACVX => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: HDACVY => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: PDO => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ACFRCV => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ACFRST => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ACPREC => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ACPREC_TOT => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ACSNOM => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ACSNOW => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ACPCP_RA => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ACPCP_SN => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ACPCP_GR => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: AKHS_OUT => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: AKHSAVG => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: AKMS_OUT => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: AKMSAVG => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ALBASE => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ALBEDO => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ALWIN => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ALWOUT => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ALWTOA => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ASWIN => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ASWOUT => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ASWTOA => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: BGROFF => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: CFRACH => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: CFRACL => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: CFRACM => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: CLDEFI => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: CMC => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: CNVBOT => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: CNVTOP => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: CPRATE => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: CUPPT => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: CUPREC => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: CZEN => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: CZMEAN => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: DNVVELMAX => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: EPSR => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: GRNFLX => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: HBOTD => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: HBOTS => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: HTOPD => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: HTOPS => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: MIXHT => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: MXSNAL => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: PBLH => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: POTEVP => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: PREC => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: PSFCAVG => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: PSHLTR => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: P10 => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: RH02MAX => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: RH02MIN => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: T02MAX => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: T02MIN => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: T10 => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: T10AVG => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: Q10 => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: QSH => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: QSHLTR => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: QWBS => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: QZ0 => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: RADOT => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: PRATEMAX => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: FPRATEMAX => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: REFDMAX => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: RLWIN => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: RLWTOA => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: RSWIN => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: RSWINC => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: RSWOUT => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: SFCEVP => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: SFCEXC => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: SFCLHX => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: SFCSHX => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: SI => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: SICE => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: SIGT4 => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: SM => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: SMSTAV => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: SMSTOT => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: SNO => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: SNOAVG => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: SNOPCX => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: SOILTB => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: SPD10MAX => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: SR => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: SSROFF => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: SST => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: SUBSHX => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: TAUX => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: TAUY => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: TG => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: TH10 => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: THS => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: THZ0 => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: TSHLTR => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: TWBS => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: UPHLMAX => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: UPVVELMAX => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: U10 => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: U10MAX => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: USTAR => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: UZ0 => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: V10 => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: V10MAX => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: VEGFRC => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: SNOWC => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: VZ0 => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: Z0 => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: TSKIN => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: AKHS => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: AKMS => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: HBOT => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: HTOP => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: RSWTOA => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: POTFLX => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: RMOL => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: T2 => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: Z0BASE => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: PSFC => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: TLMIN => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: TLMAX => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: LSPA => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ACUTIM => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: APHTIM => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ARDLW => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ARDSW => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: ASRFC => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: AVRAIN => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: AVCNVC => NULL() - - ! 3D real - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: W => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: W_TOT => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: DFI_TTEN => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: OMGALF => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: O3 => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: DIV => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: TCU => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: TCV => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: TCT => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: TP => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: UP => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: VP => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: PSGDT => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: Z => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: Told => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: Tadj => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: CLDFRA => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: CW => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: EXCH_H => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: Q => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: Q2 => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: RLWTT => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: RSWTT => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: PINT => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: DWDT => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: T => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: TCUCN => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: TRAIN => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: U => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: V => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: XLEN_MIX => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: F_ICE => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: F_RIMEF => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: F_RAIN => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: QC => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: QI => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: QR => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: QS => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: QG => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: NI => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: NR => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: REFL_10CM => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: RE_CLOUD => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: RE_ICE => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: RE_SNOW => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: SH2O => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: SMC => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: STC => NULL() - - ! 4D real - REAL(kind=KFPT),DIMENSION(:,:,:,:),POINTER :: TRACERS_PREV => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:,:),POINTER :: TRACERS => NULL() - REAL(kind=KFPT),DIMENSION(:,:,:,:),POINTER :: MPRATES => NULL() - - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !! Tracker variables - - ! These variables are for the inline vortex tracker. They're - ! in a separate section since there are so many of them. - ! We're hoping, in a future release, to allocate them only if - ! the tracker is in use. - - ! Trigger variable: - INTEGER(kind=KINT) :: NTRACK_trigger - - ! Scalar integer: - !INTEGER(kind=KINT), POINTER :: VORTEX_TRACKER => NULL() - INTEGER(kind=KINT), POINTER :: TRACK_HAVE_GUESS => NULL() - INTEGER(kind=KINT), POINTER :: TRACK_N_OLD => NULL() - INTEGER(kind=KINT), POINTER :: TRACKER_HAVEFIX => NULL() - INTEGER(kind=KINT), POINTER :: TRACKER_GAVE_UP => NULL() - INTEGER(kind=KINT), POINTER :: NTRACK => NULL() - INTEGER(kind=KINT), POINTER :: TRACKER_IFIX => NULL() - INTEGER(kind=KINT), POINTER :: TRACKER_JFIX => NULL() - - ! Scalar real: - REAL(kind=KINT), POINTER :: TRACK_LAST_HOUR => NULL() - REAL(kind=KINT), POINTER :: TRACK_GUESS_LAT => NULL() - REAL(kind=KINT), POINTER :: TRACK_GUESS_LON => NULL() - REAL(kind=KINT), POINTER :: TRACK_EDGE_DIST => NULL() - !REAL(kind=KINT), POINTER :: TRACK_ANGLE => NULL() - REAL(kind=KINT), POINTER :: TRACK_STDERR_M1 => NULL() - REAL(kind=KINT), POINTER :: TRACK_STDERR_M2 => NULL() - REAL(kind=KINT), POINTER :: TRACK_STDERR_M3 => NULL() - REAL(kind=KINT), POINTER :: TRACKER_FIXLAT => NULL() - REAL(kind=KINT), POINTER :: TRACKER_FIXLON => NULL() - REAL(kind=KINT), POINTER :: TRACKER_RMW => NULL() - REAL(kind=KINT), POINTER :: TRACKER_PMIN => NULL() - REAL(kind=KINT), POINTER :: TRACKER_VMAX => NULL() - - ! 1D integer: - INTEGER(kind=KINT),DIMENSION(:), POINTER :: TRACK_OLD_NTSD => NULL() - - ! 1D Real: - REAL(kind=KFPT),DIMENSION(:),POINTER :: TRACK_OLD_LAT => NULL() - REAL(kind=KFPT),DIMENSION(:),POINTER :: TRACK_OLD_LON => NULL() - - ! 2D integer: - INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: TRACKER_FIXES => NULL() - !INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: GROUND_LEVEL => NULL() - - ! 2D real: - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: MEMBRANE_MSLP => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: P850RV => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: P700RV => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: P850WIND => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: P700WIND => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: P500U => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: P500V => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: P700U => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: P700V => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: P850U => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: P850V => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: P850Z => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: P700Z => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: M10WIND => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: M10RV => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: SP850RV => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: SP700RV => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: SP850WIND => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: SP700WIND => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: SP850Z => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: SP700Z => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: SM10WIND => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: SM10RV => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: SMSLP => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: TRACKER_DISTSQ => NULL() - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: TRACKER_ANGLE => NULL() - - CHARACTER(255) :: HIFREQ_file,PATCF_file - integer :: HIFREQ_unit, PATCF_unit - !! End of tracker variables - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!----------------------------------------------------------------------- -!*** End of 'generic' variables declaration. The remaining internal -! state variables do not have to be declared as pointers. They can -! be allocatble arrays. -!----------------------------------------------------------------------- -! - - INTEGER(kind=KINT) :: INPES,JNPES & - ,DFIHR_BOCO & - ,FILTER_METHOD & - ,FILTER_METHOD_LAST & - ,MINUTES_HISTORY & - ,MINUTES_RESTART & - ,MY_DOMAIN_ID & - ,NCOUNT & - ,NHOURS_FCST & - ,NSTEPS_BC_RESTART & - ,NSTEPS_PER_CHECK & - ,NSTEPS_PER_HOUR & - ,NSTEPS_PER_RESET & - ,RADAR_INIT & - ,NUM_TRACERS_MET & !<-- Number of meteorological tracers (e.g. water) - ,NUM_TRACERS_CHEM & !<-- Number of chem/aerosol tracers - ,START_YEAR & - ,START_MONTH & - ,START_DAY & - ,START_HOUR & - ,START_MINUTE & - ,START_SECOND -! - REAL(kind=KFPT) :: CLEFFAMP & - ,CLEFF & - ,CDMB & - ,CODAMP & - ,DPMIN & - ,FACTOP & - ,RLOLEV & - ,RUN_DURATION & - ,SIGFAC & - ,SMAG2 & - ,WCOR -! - LOGICAL(kind=KLOG) :: ADIABATIC & - ,BDY_WAS_READ & - ,FIRST_NMM & - ,FREERUN & - ,GLOBAL & - ,HYDRO & - ,LISS_RESTART & - ,NEMSIO_INPUT & - ,OPER & - ,OPERATIONAL_PHYSICS & - ,PRINT_ALL & - ,PRINT_OUTPUT & - ,PRINT_DIAG & - ,PRINT_ESMF & - ,RESTART & - ,SECADV & - ,SPEC_ADV & - ,USE_ALLREDUCE - -!! from HWRF, SASHUR, GFSPBLHUR - REAL(kind=KFPT) :: sas_pgcon=0.55 & !convectively forced pressure gradient factor,default=0.55 - ,sas_shal_pgcon=-1 & !convectively forced pressure gradient factor sas shallow conv, -1 means use sas_pgcon - ,sas_shalconv=1 & ! 1=enable shallow conv,better with gfspblhur scheme - ,sas_mass_flux=9e9 & !mass flux limit,default=9e9 - ,sas_mommix=1.0 & ! SAS momentum mixing coef - ,var_ric=1.0 & !for gfspblhur - ,coef_ric_l=0.16 & !Regression coef for land Ric,default=0.16 - ,coef_ric_s=0.16 & !Regression coef for sea Ric,default=0.16 - ,ALPHA=0.7 & !adjustment coef for K in PBLHUR - ,SFENTH=0.0 !GFDL surface-layer enhancement coef -! LOGICAL(kind=KLOG) :: RUN_TC=.true. ! true='run hurricane' - LOGICAL(kind=KLOG) :: RUN_TC=.false. ! false='run hurricane' - LOGICAL(kind=KLOG) :: DISHEAT=.true. ! true='consider diss heating' -!! -! - LOGICAL(kind=KLOG) :: MY_DOMAIN_MOVES -! -!----------------------------------------------------------------------- -!*** Distributed memory information. -!----------------------------------------------------------------------- -! - INTEGER(kind=KINT) :: IHALO,JHALO,MYPE,NHALO,NUM_PES & - ,NUM_PTS_MAX & - ,WRITE_GROUPS,WRITE_TASKS_PER_GROUP -! - INTEGER(kind=KINT) :: ITS,ITE,JTS,JTE & - ,IMS,IME,JMS,JME & - ,IDS,IDE,JDS,JDE -! - INTEGER(kind=KINT) :: ITE_B1,ITE_B2,ITE_B1_H1,ITE_B1_H2 & - ,ITE_H1,ITE_H2 & - ,ITS_B1,ITS_B2,ITS_B1_H1,ITS_B1_H2 & - ,ITS_H1,ITS_H2 & - ,JTE_B1,JTE_B2,JTE_B1_H1,JTE_B1_H2 & - ,JTE_H1,JTE_H2 & - ,JTS_B1,JTS_B2,JTS_B1_H1,JTS_B1_H2 & - ,JTS_H1,JTS_H2 -! - INTEGER(kind=KINT) :: MPI_COMM_COMP -! - INTEGER(kind=KINT),DIMENSION(1:8) :: MY_NEB -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: LOCAL_ISTART & - ,LOCAL_IEND & - ,LOCAL_JSTART & - ,LOCAL_JEND -! - LOGICAL(kind=KLOG) :: E_BDY,N_BDY,S_BDY,W_BDY -! -!----------------------------------------------------------------------- -!*** Horizontal and vertical grid-related variables. -!----------------------------------------------------------------------- -! -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: KHFILT,KVFILT & - ,NFFTRH,NFFTRW & - ,NHSMUD -! - REAL(kind=KFPT) :: DDMPV,DYV,EF4T & - ,GLAT_SW,GLON_SW & - ,RDYH,RDYV -! - REAL(kind=KFPT),DIMENSION(:),ALLOCATABLE :: PSG1 & - ,PDSG1 & - ,PSGML1 & - ,DDMPU,WPDAR & - ,FCP,FDIV & - ,CURV,DDV & - ,DARE,RARE & - ,FAD,FAH & - ,RDXH & - ,DXV,RDXV & - ,RDDV & - ,WFFTRH,WFFTRW -! - REAL(kind=KFPT),DIMENSION(:,:),ALLOCATABLE :: HFILT,VFILT -! - REAL(kind=KFPT),DIMENSION(:,:),ALLOCATABLE :: PSDT -! -!----------------------------------------------------------------------- -!*** Integration quantities. -!----------------------------------------------------------------------- -! - LOGICAL(kind=KLOG) :: FIRST_STEP,READBC & - ,ADV_STANDARD,ADV_UPSTREAM -! -! - INTEGER(kind=KINT) :: NTSD,IDTADT,IHR,IHREND & - ,LNSAD,NBOCO,NTSTM,NTSTM_MAX -! -! - REAL(kind=KFPT) :: DT_TEST_RATIO & - ,DT_LAST -! - REAL(kind=KFPT),DIMENSION(:,:,:),ALLOCATABLE :: DEF & - ,TDIV & - ,PDWDT & - ,PCNE,PCNW & - ,PFNE,PFNW & - ,PCX,PCY & - ,PFX,PFY -! - LOGICAL(kind=KLOG) :: FIRST_PASS & - ,LMPRATE,RUN -! -!----------------------------------------------------------------------- -!*** The general 4-D arrays for 3-D "tracers". -!----------------------------------------------------------------------- -! - INTEGER(kind=KINT) :: NUM_TRACERS_TOTAL !<-- Total number of "tracer" variables. - INTEGER(kind=KINT) :: D_SS !<-- Total number of mp "source/sink" variables. -! -!----------------------------------------------- -!*** Declare indices of meteorological tracers -!----------------------------------------------- -! - INTEGER(kind=KINT) :: INDX_Q & !<-- Location of Q in tracer arrays - ,INDX_CW & !<-- Location of CW in tracer arrays - ,INDX_Q2=0 & !<-- Location of Q2 in tracer arrays - ,INDX_QC=0 & !<-- Location of Qc in tracer arrays - ,INDX_QI=0 & !<-- Location of Qi in tracer arrays - ,INDX_QR=0 & !<-- Location of Qr in tracer arrays - ,INDX_QS=0 & !<-- Location of Qs in tracer arrays - ,INDX_QG=0 & !<-- Location of Qg in tracer arrays - ,INDX_NI=0 & !<-- Location of Ni in tracer arrays - ,INDX_NR=0 !<-- Location of Nr in tracer arrays -! - REAL(kind=KFPT),DIMENSION(:,:,:,:),ALLOCATABLE :: TRACERS_SQRT & !<-- Sqrt of the tracer variables (for advection) - ,TRACERS_TEND !<-- Tendencies of tracer variables (for advection) -! - REAL(kind=KFPT),DIMENSION(:),POINTER :: TRACERS_ARR & !<-- Storage array for "tracer" variables. - ,TRACERS_PREV_ARR !<-- Storage array for "Values of tracer variables in prev timestep" -! -!----------------------------------------------------------------------- -!*** Boundary conditions. -!----------------------------------------------------------------------- -! - INTEGER(kind=KINT) :: IHRSTBC,LNSH,LNSV -! - INTEGER(kind=KINT),DIMENSION(3) :: IDATBC & - ,N_BC_3D_H -! - REAL(kind=KFPT) :: TBOCO -! - TYPE(BC_H_ALL) :: BND_VARS_H !<-- H-pt boundary variables -! - TYPE(BC_V_ALL) :: BND_VARS_V !<-- V-pt boundary variables -! - LOGICAL(kind=KLOG) :: RUNBC -! -!---------------------------- -!*** For 1-D restart output -!---------------------------- -! - INTEGER(kind=KINT) :: NUM_WORDS_BC_SOUTH & !<-- Word counts of 1-D boundary data strings - ,NUM_WORDS_BC_NORTH & ! for each side of the domain. - ,NUM_WORDS_BC_WEST & ! - ,NUM_WORDS_BC_EAST !<-- -! - REAL(kind=KFPT),DIMENSION(:),ALLOCATABLE :: RST_BC_DATA_SOUTH & !<-- 1-D strings of boundary data - ,RST_BC_DATA_NORTH & ! for each side of the domain. - ,RST_BC_DATA_WEST & ! - ,RST_BC_DATA_EAST !<-- -! -!----------------------------------------------------------------------- -!*** Some physics variables are needed. -!----------------------------------------------------------------------- -! - CHARACTER(99) :: SHORTWAVE & - ,LONGWAVE & - ,CLDFRACTION & - ,LAND_SURFACE & - ,SFC_LAYER & - ,TURBULENCE & - ,CONVECTION & - ,MICROPHYSICS -! - INTEGER(kind=KINT) :: NUM_WATER & !<-- 1 + types of water substance in microphysics - ,P_QC & !<-- Index for cloud water in WATER array - ,P_QR & !<-- Index for rain in WATER array - ,P_QI & !<-- Index for cloud ice in WATER array - ,P_QS & !<-- Index for snow in WATER array - ,P_QG & !<-- Index for graupel in WATER array - ,P_NI & !<-- Index for ice number conc in WATER array - ,P_NR !<-- Index for rain number conc in WATER array - INTEGER(kind=KINT) :: has_reqc,has_reqi,has_reqs !<-- Flags for computed water/ice radii for radiation -! - INTEGER(kind=KINT) :: INDX_WATER_START & !<-- Start index of the water in tracers array - ,INDX_WATER_END !<-- End index of the water in tracers array - - INTEGER(kind=KINT) :: NP3D !<-- cloud properties for rrtm -! - LOGICAL(kind=KLOG) :: F_QC,F_QR,F_QI,F_QS,F_QG,F_NI,F_NR -! -!----------------------------------------------------------------------- -!*** Nesting -!----------------------------------------------------------------------- -! - INTEGER(kind=KINT) :: NVARS_BC_2D_H,NVARS_BC_3D_H,NVARS_BC_4D_H !<-- # of 2-D,3-D,4-D H-pt nest boundary variables - INTEGER(kind=KINT) :: NVARS_BC_2D_V,NVARS_BC_3D_V !<-- # of 2-D,3-D V-pt nest boundary variables - INTEGER(kind=KINT) :: NLEV_H,NLEV_V !<-- Total # of levels in all H-pt,V-pt bndry vbls -! - INTEGER(kind=KINT) :: PARENT_CHILD_TIME_RATIO !<-- # of child timesteps per parent timestep -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: LBND_4D & !<-- Lower/upper bounds of the count of the # of - ,UBND_4D ! 3-D arrays in the 4-D variables -! - LOGICAL(kind=KLOG) :: I_AM_A_NEST !<-- Am I in a nested domain? -! -!----------------------------------------------------------------------- -!*** Begin with the namelist variables. -!----------------------------------------------------------------------- -! - INTEGER(kind=KINT) :: DT_INT,NPRECIP,NRADL,NRADS & - ,PCPHR,UCMCALL -! - LOGICAL(kind=KLOG) :: GWDFLG,NESTED,NHRS_UDEF,PCPFLG & - ,SPECIFIED,WRITE_PREC_ADJ & - ,ENTRAIN,NEWALL,NEWSWAP,NEWUPUP,NODEEP & - ,RST_OUT_00 -! -!----------------------------------------------------------------------- -!*** Horizontal/Vertical grid -!----------------------------------------------------------------------- -! - REAL(kind=KFPT) :: FRES,FR,FSL,FSS ! BMJ convection only - REAL(kind=KFPT) :: RHGRD ! fer_hires microphysics only -! -!----------------------------------------------------------------------- -!*** Integration quantities. -!----------------------------------------------------------------------- -! - INTEGER(kind=KINT) :: NHRS_CLOD & !<-- Fcst hours cloud is accumulated - ,NHRS_HEAT & !<-- Fcst hours heating is accumulated - ,NHRS_PREC & !<-- Fcst hours precip is accumulated - ,NHRS_RDLW & !<-- Fcst hours LW radiation is accumulated - ,NHRS_RDSW & !<-- Fcst hours SW radiation is accumulated - ,NHRS_SRFC !<-- Fcst hours sfc evap/flux is accumulated -! - INTEGER(kind=KINT),DIMENSION(:,:),ALLOCATABLE :: LPBL -! - REAL(kind=KFPT),DIMENSION(:,:,:),ALLOCATABLE :: DUDT,DVDT -! - REAL(kind=KFPT),DIMENSION(:,:,:),ALLOCATABLE :: PPTDAT,RTOP -! - REAL(kind=KFPT),DIMENSION(:,:,:),ALLOCATABLE :: W0AVG -! - REAL(kind=KFPT),DIMENSION(:,:),ALLOCATABLE :: CROT,SROT & - ,HANGL,HANIS,HASYS & - ,HASYSW,HASYNW & - ,HASYW,HCNVX & - ,HLENNW,HLENSW & - ,HLENW,HLENS & - ,HSLOP,HSTDV,HZMAX -! - REAL(kind=KFPT),DIMENSION(:,:),ALLOCATABLE :: DDATA -! - REAL(kind=KFPT),DIMENSION(:,:),ALLOCATABLE :: MAVAIL & - ,SHDMAX,SHDMIN & - ,STDH -! - REAL(kind=KFPT),DIMENSION(:,:),ALLOCATABLE :: Q02,TH02 -! -!----------------------------------------------------------------------- -!*** GFS physics additional arrays -!----------------------------------------------------------------------- -! - REAL(kind=KDBL) :: CDEC,SDEC & - ,SLAG,SOLCON - INTEGER(kind=KINT),DIMENSION(:) ,ALLOCATABLE :: JINDX1,JINDX2 - REAL(kind=KDBL),DIMENSION(:) ,ALLOCATABLE :: DDY - REAL(kind=KDBL),DIMENSION(:,:) ,ALLOCATABLE :: TMPMIN,TMPMAX - REAL(kind=KDBL),DIMENSION(:,:) ,ALLOCATABLE :: DUGWD,DVGWD - REAL(kind=KDBL),DIMENSION(:,:) ,ALLOCATABLE :: SEMIS,SFALB & - ,SFCDLW,SFCDSW & - ,SFCNSW,TSFLW - REAL(kind=KDBL),DIMENSION(:,:) ,ALLOCATABLE :: SICFCS,SIHFCS & - ,SLPFCS,SOTFCS & - ,TG3FCS & - ,VEGFCS,VETFCS & - ,ZORFCS - REAL(kind=KDBL),DIMENSION(:,:,:) ,ALLOCATABLE :: ALBFC1,ALFFC1 - REAL(kind=KDBL),DIMENSION(:,:,:) ,ALLOCATABLE :: PHY_F2DV ! save last time step 2Ds - REAL(kind=KDBL),DIMENSION(:,:,:,:),ALLOCATABLE :: PHY_F3DV ! save last time step 3Ds - REAL(kind=KDBL),DIMENSION(:,:,:,:),ALLOCATABLE :: OZPLIN -! -!----------------------------------------------------------------------- -!*** GFS microphysics additional arrays saving surface pressure, -! Temperature,water vapor at previous time steps, Weiguo Wang 11-22-2010 -!----------------------------------------------------------------------- -! - REAL(kind=KFPT),DIMENSION(:,:,:),ALLOCATABLE :: TP1,QP1 - REAL(kind=KFPT),DIMENSION(:,:), ALLOCATABLE :: PSP1 -! - LOGICAL(kind=KLOG) :: GFS -! - INTEGER(kind=KINT) :: CO2TF -! -!----------------------------------------------------------------------- -!*** Output -!----------------------------------------------------------------------- -! - TYPE(ESMF_FieldBundle),DIMENSION(1:2) :: BUNDLE_ARRAY -! -!----------------------------------------------------------------------- -! - END TYPE SOLVER_INTERNAL_STATE -! -!----------------------------------------------------------------------- -!*** The INTERNAL_STATE type is supported by a C pointer (not an F90 -!*** pointer) and therefore the following type is needed. -!----------------------------------------------------------------------- -! - TYPE WRAP_SOLVER_INT_STATE - TYPE(SOLVER_INTERNAL_STATE),POINTER :: INT_STATE - END TYPE WRAP_SOLVER_INT_STATE -! -!----------------------------------------------------------------------- -! - INTEGER(kind=KINT) :: ITS,ITE,IMS,IME,IDS,IDE & - ,JTS,JTE,JMS,JME,JDS,JDE -! -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE SET_INTERNAL_STATE_SOLVER(INT_STATE & - ,LM & - ,ITS,ITE,JTS,JTE & - ,IMS,IME,JMS,JME & - ,IDS,IDE,JDS,JDE & - ,IHALO,JHALO & - ,MYPE & - ,RC ) -! -!----------------------------------------------------------------------- -!*** Allocate the internal state quantities in the Solver component's -!*** Init step. -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(SOLVER_INTERNAL_STATE),INTENT(INOUT) :: INT_STATE !<-- The SOLVER internal state -! - INTEGER(kind=KINT),INTENT(IN) :: ITS,ITE,JTS,JTE & !<-- Integration limits of task subdomains - ,IMS,IME,JMS,JME & !<-- Memory dimensions of task subdomain - ,IDS,IDE,JDS,JDE & !<-- Dimensions of full domain - ,IHALO,JHALO & !<-- Width of haloes in I and J - ,LM & !<-- Number of model layers - ,MYPE !<-- Local task rank on this domain -! - INTEGER, INTENT(OUT) :: RC -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: I,I_CYCLE,J,L,LB,LNSH,LNSV,N,NV,UB - INTEGER(kind=KINT) :: TRACER_SIZE_1, TRACER_SIZE - INTEGER(kind=KINT) :: ISTAT -! - INTEGER :: LATSOZP,TIMEOZ,LEVOZP,PL_COEFF,KOZPL=28 -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** The array called WATER is a special case needed to satisfy -!*** various WRF physics options. The 4th dimension is set to -!*** 1+Number_of_species including vapor. The "1+" is needed -!*** because WRF never touches the first level. -! -!*** Set the P_ and F_ variables. -!*** V=>vapor; C=>cloudwater; R=>rain; I=>cloudice; S=>snow; G=>graupel -!*** Set the appropriate value for the logical F_ variables. -!*** For each species that is .TRUE., set the integer P_ variable -!*** to monotonically increasing values STARTING WITH 2. -!*** For the excluded species (F_*=.FALSE.), set the P_ variable to 1. -!----------------------------------------------------------------------- -! - int_state%D_SS=1 - int_state%has_reqc=0 - int_state%has_reqi=0 - int_state%has_reqs=0 - - int_state%NUM_WATER=0 - int_state%P_QC=0 - int_state%P_QI=0 - int_state%P_QR=0 - int_state%P_QS=0 - int_state%P_QG=0 - int_state%P_NI=0 - int_state%P_NR=0 - int_state%F_QC=.FALSE. - int_state%F_QR=.FALSE. - int_state%F_QS=.FALSE. - int_state%F_QI=.FALSE. - int_state%F_QG=.FALSE. - int_state%F_NI=.FALSE. - int_state%F_NR=.FALSE. - - IF(TRIM(int_state%MICROPHYSICS)=='fer'.OR. & - TRIM(int_state%MICROPHYSICS)=='fer_hires')THEN - int_state%NUM_WATER=4 - int_state%P_QC=1 - int_state%P_QR=2 - int_state%P_QS=3 - int_state%P_QG=4 - int_state%F_QC=.TRUE. - int_state%F_QR=.TRUE. - int_state%F_QS=.TRUE. - int_state%F_QG=.TRUE. - if(int_state%lmprate) int_state%D_SS=24 - ELSEIF(TRIM(int_state%MICROPHYSICS)=='wsm6')THEN - int_state%NUM_WATER=5 - int_state%P_QC=1 - int_state%P_QR=2 - int_state%P_QS=3 - int_state%P_QI=4 - int_state%P_QG=5 - int_state%F_QC=.TRUE. - int_state%F_QR=.TRUE. - int_state%F_QS=.TRUE. - int_state%F_QI=.TRUE. - int_state%F_QG=.TRUE. - if(int_state%lmprate) int_state%D_SS=41 - ELSEIF(TRIM(int_state%MICROPHYSICS)=='thompson')THEN - int_state%NUM_WATER=7 - int_state%P_QC=1 - int_state%P_QI=2 - int_state%P_QR=3 - int_state%P_QS=4 - int_state%P_QG=5 - int_state%P_NI=6 - int_state%P_NR=7 - int_state%F_QC=.TRUE. - int_state%F_QR=.TRUE. - int_state%F_QS=.TRUE. - int_state%F_QI=.TRUE. - int_state%F_QG=.TRUE. - int_state%F_NI=.TRUE. - int_state%F_NR=.TRUE. - if(int_state%lmprate) int_state%D_SS=15 - IF(TRIM(int_state%LONGWAVE)=='rrtm'.AND.TRIM(int_state%SHORTWAVE)=='rrtm') THEN - write(6,*) 'DEBUG-GT: combined Thompson MP and RRTM radiation, therefore using coupled effective radii' - int_state%has_reqc=1 - int_state%has_reqi=1 - int_state%has_reqs=1 - ELSE - write(6,*) 'DEBUG-GT: found Thompson MP but not RRTM radiation' - write(6,*) ' this is not advised. Should use RRTM radiation' - write(6,*) 'DEBUG-GT: Long/short-wave set to: ', TRIM(int_state%LONGWAVE), TRIM(int_state%SHORTWAVE) - ENDIF - ELSEIF(TRIM(int_state%MICROPHYSICS)=='gfs')THEN - int_state%NUM_WATER=2 - int_state%P_QC=1 - int_state%P_QI=2 - int_state%F_QC=.TRUE. - int_state%F_QI=.TRUE. - ELSE - write(0,*) 'Unknown microphysics : ',TRIM(int_state%MICROPHYSICS) - stop - ENDIF -! - int_state%NUM_TRACERS_MET=3 - int_state%NUM_TRACERS_TOTAL= & !<-- # of 3-D arrays in 4-D TRACERS array - int_state%NUM_TRACERS_MET & !<-- # of water, etc. tracers specified now (see below) - +int_state%NUM_TRACERS_CHEM & !<-- # of specified scalars (chem, aerosol, etc.) - +int_state%NUM_WATER !<-- # of water types -! -!------------------------------------------------ -!*** Read and store the specifications for each -!*** internal state variable listed by the user -!*** in the Solver text file. -!------------------------------------------------ -! - CALL READ_CONFIG('solver_state.txt' & - ,MYPE & - ,int_state%VARS & - ,int_state%NUM_VARS & - ,RC ) - IF (RC /= 0) RETURN -! -!------------------------------------------------------------------- -!*** Allocate appropriate memory within the Solver's composite -!*** VARS array for all internal state variables that are 'Owned' -!*** and point those variables into that memory. -!------------------------------------------------------------------- -! - NV=int_state%NUM_VARS - - CALL SET_VAR_PTR(int_state%VARS,NV,'IM' ,int_state%IM ) - CALL SET_VAR_PTR(int_state%VARS,NV,'JM' ,int_state%JM ) - CALL SET_VAR_PTR(int_state%VARS,NV,'LM' ,int_state%LM ) - CALL SET_VAR_PTR(int_state%VARS,NV,'IHRST' ,int_state%IHRST ) - CALL SET_VAR_PTR(int_state%VARS,NV,'I_PAR_STA' ,int_state%I_PAR_STA ) - CALL SET_VAR_PTR(int_state%VARS,NV,'J_PAR_STA' ,int_state%J_PAR_STA ) - CALL SET_VAR_PTR(int_state%VARS,NV,'LAST_STEP_MOVED' ,int_state%LAST_STEP_MOVED ) - CALL SET_VAR_PTR(int_state%VARS,NV,'LPT2' ,int_state%LPT2 ) - CALL SET_VAR_PTR(int_state%VARS,NV,'NMTS' ,int_state%NMTS ) - - CALL SET_VAR_PTR(int_state%VARS,NV,'MDRMINout' ,int_state%MDRMINout ) - CALL SET_VAR_PTR(int_state%VARS,NV,'MDRMAXout' ,int_state%MDRMAXout ) - CALL SET_VAR_PTR(int_state%VARS,NV,'MDIMINout' ,int_state%MDIMINout ) - CALL SET_VAR_PTR(int_state%VARS,NV,'MDIMAXout' ,int_state%MDIMAXout ) - - IF(TRIM(int_state%MICROPHYSICS)=='fer') THEN - int_state%MDRMINout=50 - int_state%MDRMAXout=450 - int_state%MDIMINout=50 - int_state%MDIMAXout=1000 - ELSEIF (TRIM(int_state%MICROPHYSICS)=='fer_hires')THEN - int_state%MDRMINout=50 - int_state%MDRMAXout=1000 - int_state%MDIMINout=50 - int_state%MDIMAXout=1000 - ENDIF - - CALL SET_VAR_PTR(int_state%VARS,NV,'NSOIL' ,int_state%NSOIL ) - CALL SET_VAR_PTR(int_state%VARS,NV,'NPHS' ,int_state%NPHS ) - CALL SET_VAR_PTR(int_state%VARS,NV,'NCLOD' ,int_state%NCLOD ) - CALL SET_VAR_PTR(int_state%VARS,NV,'NHEAT' ,int_state%NHEAT ) - CALL SET_VAR_PTR(int_state%VARS,NV,'NPREC' ,int_state%NPREC ) - CALL SET_VAR_PTR(int_state%VARS,NV,'NRDLW' ,int_state%NRDLW ) - CALL SET_VAR_PTR(int_state%VARS,NV,'NRDSW' ,int_state%NRDSW ) - CALL SET_VAR_PTR(int_state%VARS,NV,'NSRFC' ,int_state%NSRFC ) - CALL SET_VAR_PTR(int_state%VARS,NV,'AVGMAXLEN' ,int_state%AVGMAXLEN ) - CALL SET_VAR_PTR(int_state%VARS,NV,'IVEGSRC' ,int_state%IVEGSRC ) - CALL SET_VAR_PTR(int_state%VARS,NV,'CU_PHYSICS' ,int_state%CU_PHYSICS ) - CALL SET_VAR_PTR(int_state%VARS,NV,'MP_PHYSICS' ,int_state%MP_PHYSICS ) - CALL SET_VAR_PTR(int_state%VARS,NV,'LSM_PHYSICS',int_state%LSM_PHYSICS ) - - CALL SET_VAR_PTR(int_state%VARS,NV,'DT' ,int_state%DT ) - CALL SET_VAR_PTR(int_state%VARS,NV,'DYH' ,int_state%DYH ) - CALL SET_VAR_PTR(int_state%VARS,NV,'PDTOP' ,int_state%PDTOP ) - CALL SET_VAR_PTR(int_state%VARS,NV,'PT' ,int_state%PT ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TLM0D' ,int_state%TLM0D ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TPH0D' ,int_state%TPH0D ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TSTART' ,int_state%TSTART ) - CALL SET_VAR_PTR(int_state%VARS,NV,'DPHD' ,int_state%DPHD ) - CALL SET_VAR_PTR(int_state%VARS,NV,'DLMD' ,int_state%DLMD ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SBD' ,int_state%SBD ) - CALL SET_VAR_PTR(int_state%VARS,NV,'WBD' ,int_state%WBD ) - - CALL SET_VAR_PTR(int_state%VARS,NV,'IDAT' ,int_state%IDAT ,1 ,3 ) - - CALL SET_VAR_PTR(int_state%VARS,NV,'DXH' ,int_state%DXH ,JDS, JDE ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SG1' ,int_state%SG1 ,1, LM+1 ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SG2' ,int_state%SG2 ,1, LM+1 ) - CALL SET_VAR_PTR(int_state%VARS,NV,'DSG1' ,int_state%DSG1 ,1, LM ) - CALL SET_VAR_PTR(int_state%VARS,NV,'DSG2' ,int_state%DSG2 ,1, LM ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SGML1' ,int_state%SGML1 ,1, LM ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SGML2' ,int_state%SGML2 ,1, LM ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SGM' ,int_state%SGM ,1, LM+1 ) - CALL SET_VAR_PTR(int_state%VARS,NV,'EPSL' ,int_state%EPSL ,1, LM-1 ) - CALL SET_VAR_PTR(int_state%VARS,NV,'EPSQ2' ,int_state%EPSQ2 ,1, LM ) - - CALL SET_VAR_PTR(int_state%VARS,NV,'NTSCM' ,int_state%NTSCM ,1, NUM_DOMAINS_MAX ) - - CALL SET_VAR_PTR(int_state%VARS,NV,'MASSRout' ,int_state%MASSRout ,1, int_state%MDRMAXout-int_state%MDRMINout+1 ) - CALL SET_VAR_PTR(int_state%VARS,NV,'MASSIout' ,int_state%MASSIout ,1, int_state%MDIMAXout-int_state%MDIMINout+1 ) - - CALL SET_VAR_PTR(int_state%VARS,NV,'ISLTYP' ,int_state%ISLTYP ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'IVGTYP' ,int_state%IVGTYP ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'NCFRCV' ,int_state%NCFRCV ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'NCFRST' ,int_state%NCFRST ,(/ IMS,JMS /),(/ IME,JME /) ) - - CALL SET_VAR_PTR(int_state%VARS,NV,'SLDPTH' ,int_state%SLDPTH ,1 ,NUM_SOIL_LAYERS ) - CALL SET_VAR_PTR(int_state%VARS,NV,'MP_RESTART' ,int_state%MP_RESTART_STATE ,1 ,MICRO_RESTART ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TBPVS_STAT' ,int_state%TBPVS_STATE ,1 ,MICRO_RESTART ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TBPVS0_STA' ,int_state%TBPVS0_STATE ,1 ,MICRO_RESTART ) - - CALL SET_VAR_PTR(int_state%VARS,NV,'BARO' ,int_state%BARO ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'F' ,int_state%F ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'GLAT' ,int_state%GLAT ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'GLON' ,int_state%GLON ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'HDACX' ,int_state%HDACX ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'HDACY' ,int_state%HDACY ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'VLAT' ,int_state%VLAT ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'VLON' ,int_state%VLON ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'HDACVX' ,int_state%HDACVX ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'HDACVY' ,int_state%HDACVY ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'PDO' ,int_state%PDO ,(/ IMS,JMS /),(/ IME,JME /) ) - - CALL SET_VAR_PTR(int_state%VARS,NV,'T' ,int_state%T ,(/ IMS,JMS,1 /),(/ IME,JME,LM /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'Q' ,int_state%Q ,(/ IMS,JMS,1 /),(/ IME,JME,LM /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'U' ,int_state%U ,(/ IMS,JMS,1 /),(/ IME,JME,LM /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'V' ,int_state%V ,(/ IMS,JMS,1 /),(/ IME,JME,LM /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'Q2' ,int_state%Q2 ,(/ IMS,JMS,1 /),(/ IME,JME,LM /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'CW' ,int_state%CW ,(/ IMS,JMS,1 /),(/ IME,JME,LM /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'W' ,int_state%W ,(/ IMS,JMS,1 /),(/ IME,JME,LM /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'W_TOT' ,int_state%W_TOT ,(/ IMS,JMS,1 /),(/ IME,JME,LM /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'DWDT' ,int_state%DWDT ,(/ IMS,JMS,1 /),(/ IME,JME,LM /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'PINT' ,int_state%PINT ,(/ IMS,JMS,1 /),(/ IME,JME,LM+1 /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'OMGALF' ,int_state%OMGALF ,(/ IMS,JMS,1 /),(/ IME,JME,LM /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'O3' ,int_state%O3 ,(/ IMS,JMS,1 /),(/ IME,JME,LM /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'DIV' ,int_state%DIV ,(/ IMS,JMS,1 /),(/ IME,JME,LM /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TCU' ,int_state%TCU ,(/ IMS,JMS,1 /),(/ IME,JME,LM /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TCV' ,int_state%TCV ,(/ IMS,JMS,1 /),(/ IME,JME,LM /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TCT' ,int_state%TCT ,(/ IMS,JMS,1 /),(/ IME,JME,LM /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TP' ,int_state%TP ,(/ IMS,JMS,1 /),(/ IME,JME,LM /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'UP' ,int_state%UP ,(/ IMS,JMS,1 /),(/ IME,JME,LM /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'VP' ,int_state%VP ,(/ IMS,JMS,1 /),(/ IME,JME,LM /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'PSGDT' ,int_state%PSGDT ,(/ IMS,JMS,1 /),(/ IME,JME,LM-1 /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'Z' ,int_state%Z ,(/ IMS,JMS,1 /),(/ IME,JME,LM /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'Told' ,int_state%Told ,(/ IMS,JMS,1 /),(/ IME,JME,LM /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'Tadj' ,int_state%Tadj ,(/ IMS,JMS,1 /),(/ IME,JME,LM /) ) - -!..Added by G. Thompson for multiple water species. Truly not declared -!.. new memory but rather pointers into TRACERS array. - CALL SET_VAR_PTR(int_state%VARS,NV,'QC' ,int_state%QC ,(/ IMS,JMS,1 /),(/ IME,JME,LM /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'QI' ,int_state%QI ,(/ IMS,JMS,1 /),(/ IME,JME,LM /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'QR' ,int_state%QR ,(/ IMS,JMS,1 /),(/ IME,JME,LM /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'QS' ,int_state%QS ,(/ IMS,JMS,1 /),(/ IME,JME,LM /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'QG' ,int_state%QG ,(/ IMS,JMS,1 /),(/ IME,JME,LM /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'NI' ,int_state%NI ,(/ IMS,JMS,1 /),(/ IME,JME,LM /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'NR' ,int_state%NR ,(/ IMS,JMS,1 /),(/ IME,JME,LM /) ) - - CALL SET_VAR_PTR(int_state%VARS,NV,'ACFRCV' ,int_state%ACFRCV ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'ACFRST' ,int_state%ACFRST ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'ACPREC' ,int_state%ACPREC ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'ACPREC_TOT' ,int_state%ACPREC_TOT,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'ACSNOM' ,int_state%ACSNOM ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'ACSNOW' ,int_state%ACSNOW ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'ACPCP_RA' ,int_state%acpcp_ra ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'ACPCP_SN' ,int_state%acpcp_sn ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'ACPCP_GR' ,int_state%acpcp_gr ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'AKHS_OUT' ,int_state%AKHS_OUT ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'AKHSAVG' ,int_state%AKHSAVG ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'AKMS_OUT' ,int_state%AKMS_OUT ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'AKMSAVG' ,int_state%AKMSAVG ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'ALBASE' ,int_state%ALBASE ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'ALBEDO' ,int_state%ALBEDO ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'ALWIN' ,int_state%ALWIN ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'ALWOUT' ,int_state%ALWOUT ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'ALWTOA' ,int_state%ALWTOA ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'ASWIN' ,int_state%ASWIN ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'ASWOUT' ,int_state%ASWOUT ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'ASWTOA' ,int_state%ASWTOA ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'BGROFF' ,int_state%BGROFF ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'CFRACH' ,int_state%CFRACH ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'CFRACL' ,int_state%CFRACL ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'CFRACM' ,int_state%CFRACM ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'CLDEFI' ,int_state%CLDEFI ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'CMC' ,int_state%CMC ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'CNVBOT' ,int_state%CNVBOT ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'CNVTOP' ,int_state%CNVTOP ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'CPRATE' ,int_state%CPRATE ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'CUPPT' ,int_state%CUPPT ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'CUPREC' ,int_state%CUPREC ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'CZEN' ,int_state%CZEN ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'CZMEAN' ,int_state%CZMEAN ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'DNVVELMAX' ,int_state%DNVVELMAX,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'EPSR' ,int_state%EPSR ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'FIS' ,int_state%FIS ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'GRNFLX' ,int_state%GRNFLX ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'HBOTD' ,int_state%HBOTD ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'HBOTS' ,int_state%HBOTS ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'HTOPD' ,int_state%HTOPD ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'HTOPS' ,int_state%HTOPS ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'MIXHT' ,int_state%MIXHT ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'MXSNAL' ,int_state%MXSNAL ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'PBLH' ,int_state%PBLH ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'PD' ,int_state%PD ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'POTEVP' ,int_state%POTEVP ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'PREC' ,int_state%PREC ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'PSFCAVG' ,int_state%PSFCAVG ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'PSHLTR' ,int_state%PSHLTR ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'P10' ,int_state%P10 ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'Q10' ,int_state%Q10 ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'QSH' ,int_state%QSH ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'QSHLTR' ,int_state%QSHLTR ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'QWBS' ,int_state%QWBS ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'QZ0' ,int_state%QZ0 ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'RADOT' ,int_state%RADOT ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'PRATEMAX' ,int_state%PRATEMAX ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'FPRATEMAX' ,int_state%FPRATEMAX,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'REFDMAX' ,int_state%REFDMAX ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'RH02MAX' ,int_state%RH02MAX ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'RH02MIN' ,int_state%RH02MIN ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'RLWIN' ,int_state%RLWIN ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'RLWTOA' ,int_state%RLWTOA ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'RSWIN' ,int_state%RSWIN ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'RSWINC' ,int_state%RSWINC ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'RSWOUT' ,int_state%RSWOUT ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SFCEVP' ,int_state%SFCEVP ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SFCEXC' ,int_state%SFCEXC ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SFCLHX' ,int_state%SFCLHX ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SFCSHX' ,int_state%SFCSHX ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SI' ,int_state%SI ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SICE' ,int_state%SICE ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SIGT4' ,int_state%SIGT4 ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SM' ,int_state%SM ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SMSTAV' ,int_state%SMSTAV ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SMSTOT' ,int_state%SMSTOT ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SNO' ,int_state%SNO ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SNOWC' ,int_state%SNOWC ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SNOAVG' ,int_state%SNOAVG ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SNOPCX' ,int_state%SNOPCX ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SOILTB' ,int_state%SOILTB ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SPD10MAX' ,int_state%SPD10MAX ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SR' ,int_state%SR ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SSROFF' ,int_state%SSROFF ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SST' ,int_state%SST ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SUBSHX' ,int_state%SUBSHX ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'T02MAX' ,int_state%T02MAX ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'T02MIN' ,int_state%T02MIN ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'T10' ,int_state%T10 ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'T10AVG' ,int_state%T10AVG ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TAUX' ,int_state%TAUX ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TAUY' ,int_state%TAUY ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TG' ,int_state%TG ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TH10' ,int_state%TH10 ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'THS' ,int_state%THS ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'THZ0' ,int_state%THZ0 ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TSHLTR' ,int_state%TSHLTR ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TWBS' ,int_state%TWBS ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'UPHLMAX' ,int_state%UPHLMAX ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'UPVVELMAX' ,int_state%UPVVELMAX,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'U10' ,int_state%U10 ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'U10MAX' ,int_state%U10MAX ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'USTAR' ,int_state%USTAR ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'UZ0' ,int_state%UZ0 ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'V10' ,int_state%V10 ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'V10MAX' ,int_state%V10MAX ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'VEGFRC' ,int_state%VEGFRC ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'VZ0' ,int_state%VZ0 ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'Z0' ,int_state%Z0 ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TSKIN' ,int_state%TSKIN ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'AKHS' ,int_state%AKHS ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'AKMS' ,int_state%AKMS ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'HBOT' ,int_state%HBOT ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'HTOP' ,int_state%HTOP ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'RSWTOA' ,int_state%RSWTOA ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'POTFLX' ,int_state%POTFLX ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'RMOL' ,int_state%RMOL ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'T2' ,int_state%T2 ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'Z0BASE' ,int_state%Z0BASE ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'PSFC' ,int_state%PSFC ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TLMIN' ,int_state%TLMIN ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TLMAX' ,int_state%TLMAX ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'LSPA' ,int_state%LSPA ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'ACUTIM' ,int_state%ACUTIM ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'APHTIM' ,int_state%APHTIM ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'ARDLW' ,int_state%ARDLW ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'ARDSW' ,int_state%ARDSW ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'ASRFC' ,int_state%ASRFC ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'AVRAIN' ,int_state%AVRAIN ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'AVCNVC' ,int_state%AVCNVC ,(/ IMS,JMS /),(/ IME,JME /) ) - - ! 3D Reals: - CALL SET_VAR_PTR(int_state%VARS,NV,'RLWTT' ,int_state%RLWTT ,(/ IMS,JMS,1 /),(/ IME,JME,LM /)) - CALL SET_VAR_PTR(int_state%VARS,NV,'RSWTT' ,int_state%RSWTT ,(/ IMS,JMS,1 /),(/ IME,JME,LM /)) - CALL SET_VAR_PTR(int_state%VARS,NV,'EXCH_H' ,int_state%EXCH_H ,(/ IMS,JMS,1 /),(/ IME,JME,LM /)) - CALL SET_VAR_PTR(int_state%VARS,NV,'CLDFRA' ,int_state%CLDFRA ,(/ IMS,JMS,1 /),(/ IME,JME,LM /)) - CALL SET_VAR_PTR(int_state%VARS,NV,'DFI_TTEN' ,int_state%DFI_TTEN ,(/ IMS,JMS,1 /),(/ IME,JME,LM /)) - CALL SET_VAR_PTR(int_state%VARS,NV,'F_ICE' ,int_state%F_ICE ,(/ IMS,JMS,1 /),(/ IME,JME,LM /)) - CALL SET_VAR_PTR(int_state%VARS,NV,'F_RAIN' ,int_state%F_RAIN ,(/ IMS,JMS,1 /),(/ IME,JME,LM /)) - CALL SET_VAR_PTR(int_state%VARS,NV,'F_RIMEF' ,int_state%F_RIMEF ,(/ IMS,JMS,1 /),(/ IME,JME,LM /)) - CALL SET_VAR_PTR(int_state%VARS,NV,'REFL_10CM' ,int_state%refl_10cm,(/ IMS,JMS,1 /),(/ IME,JME,LM /)) - CALL SET_VAR_PTR(int_state%VARS,NV,'RE_CLOUD' ,int_state%re_cloud ,(/ IMS,JMS,1 /),(/ IME,JME,LM /)) - CALL SET_VAR_PTR(int_state%VARS,NV,'RE_ICE' ,int_state%re_ice ,(/ IMS,JMS,1 /),(/ IME,JME,LM /)) - CALL SET_VAR_PTR(int_state%VARS,NV,'RE_SNOW' ,int_state%re_snow ,(/ IMS,JMS,1 /),(/ IME,JME,LM /)) - CALL SET_VAR_PTR(int_state%VARS,NV,'TRAIN' ,int_state%TRAIN ,(/ IMS,JMS,1 /),(/ IME,JME,LM /)) - CALL SET_VAR_PTR(int_state%VARS,NV,'XLEN_MIX' ,int_state%XLEN_MIX ,(/ IMS,JMS,1 /),(/ IME,JME,LM /)) - CALL SET_VAR_PTR(int_state%VARS,NV,'TCUCN' ,int_state%TCUCN ,(/ IMS,JMS,1 /),(/ IME,JME,LM /)) - CALL SET_VAR_PTR(int_state%VARS,NV,'SMC' ,int_state%SMC ,(/ IMS,JMS,1 /),(/ IME,JME,NUM_SOIL_LAYERS /)) - CALL SET_VAR_PTR(int_state%VARS,NV,'STC' ,int_state%STC ,(/ IMS,JMS,1 /),(/ IME,JME,NUM_SOIL_LAYERS /)) - CALL SET_VAR_PTR(int_state%VARS,NV,'SH2O' ,int_state%SH2O ,(/ IMS,JMS,1 /),(/ IME,JME,NUM_SOIL_LAYERS /)) - - CALL SET_VAR_PTR(int_state%VARS,NV,'TRACERS' ,int_state%TRACERS ,(/ IMS,JMS,1,1 /),(/ IME,JME,LM,int_state%NUM_TRACERS_TOTAL /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TRACERS_PREV',int_state%TRACERS_PREV ,(/ IMS,JMS,1,1 /),(/ IME,JME,LM,int_state%NUM_TRACERS_TOTAL /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'MPRATES' ,int_state%MPRATES ,(/ IMS,JMS,1,1 /),(/ IME,JME,LM,int_state%D_SS /) ) - - !----------------------------------------------------------------------- - ! TRACKER VARIABLES ---------------------------------------------------- - - ! These variables are for the inline vortex tracker. They're in - ! a separate section since there are so many of them. We're - ! hoping, in a future release, to allocate them only if the - ! tracker is in use (ntrack>0). However, the framework does not - ! support this yet. - - CALL SET_VAR_PTR(int_state%VARS,NV,'NTRACK' ,int_state%NTRACK ) - int_state%NTRACK = int_state%NTRACK_trigger - - !if_tracker: if(int_state%NTRACK > 0) then - ! write(0,*) 'Allocate tracker variables.' - ! Tracker integer scalars: - CALL SET_VAR_PTR(int_state%VARS,NV,'TRACK_HAVE_GUESS',int_state%TRACK_HAVE_GUESS ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TRACK_N_OLD',int_state%TRACK_N_OLD ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TRACKER_HAVEFIX',int_state%TRACKER_HAVEFIX ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TRACKER_GAVE_UP',int_state%TRACKER_GAVE_UP ) - !CALL SET_VAR_PTR(int_state%VARS,NV,'VORTEX_TRACKER',int_state%VORTEX_TRACKER ) - - ! Tracker real scalars: - CALL SET_VAR_PTR(int_state%VARS,NV,'TRACK_LAST_HOUR',int_state%TRACK_LAST_HOUR ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TRACK_GUESS_LAT',int_state%TRACK_GUESS_LAT ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TRACK_GUESS_LON',int_state%TRACK_GUESS_LON ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TRACK_EDGE_DIST',int_state%TRACK_EDGE_DIST ) - !CALL SET_VAR_PTR(int_state%VARS,NV,'TRACK_ANGLE',int_state%TRACK_ANGLE ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TRACK_STDERR_M1',int_state%TRACK_STDERR_M1 ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TRACK_STDERR_M2',int_state%TRACK_STDERR_M2 ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TRACK_STDERR_M3',int_state%TRACK_STDERR_M3 ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TRACKER_FIXLAT',int_state%TRACKER_FIXLAT ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TRACKER_FIXLON',int_state%TRACKER_FIXLON ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TRACKER_IFIX',int_state%TRACKER_IFIX ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TRACKER_JFIX',int_state%TRACKER_JFIX ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TRACKER_RMW',int_state%TRACKER_RMW ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TRACKER_PMIN',int_state%TRACKER_PMIN ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TRACKER_VMAX',int_state%TRACKER_VMAX ) - - ! Tracker 1D integers: - CALL SET_VAR_PTR(int_state%VARS,NV,'TRACK_OLD_NTSD',int_state%TRACK_OLD_NTSD, 1, TRACK_MAX_OLD ) - - ! Tracker 1D reals: - CALL SET_VAR_PTR(int_state%VARS,NV,'TRACK_OLD_LAT',int_state%TRACK_OLD_LAT,1, TRACK_MAX_OLD) - CALL SET_VAR_PTR(int_state%VARS,NV,'TRACK_OLD_LON',int_state%TRACK_OLD_LON,1, TRACK_MAX_OLD) - - ! Tracker 2D integers: - CALL SET_VAR_PTR(int_state%VARS,NV,'TRACKER_FIXES',int_state%TRACKER_FIXES, (/ IMS,JMS /),(/ IME,JME /) ) - !CALL SET_VAR_PTR(int_state%VARS,NV,'GROUND_LEVEL', int_state%GROUND_LEVEL, (/ IMS,JMS /),(/ IME,JME /) ) - - ! Tracker 2D reals: - CALL SET_VAR_PTR(int_state%VARS,NV,'MEMBRANE_MSLP',int_state%MEMBRANE_MSLP,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'P850RV' ,int_state%P850RV ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'P700RV' ,int_state%P700RV ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'P850WIND' ,int_state%P850WIND ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'P700WIND' ,int_state%P700WIND ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'P500U' ,int_state%P500U ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'P500V' ,int_state%P500V ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'P700U' ,int_state%P700U ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'P700V' ,int_state%P700V ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'P850U' ,int_state%P850U ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'P850V' ,int_state%P850V ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'P850Z' ,int_state%P850Z ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'P700Z' ,int_state%P700Z ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'M10WIND' ,int_state%M10WIND ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'M10RV' ,int_state%M10RV ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SP850RV' ,int_state%SP850RV ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SP700RV' ,int_state%SP700RV ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SP850WIND' ,int_state%SP850WIND,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SP700WIND' ,int_state%SP700WIND,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SP850Z' ,int_state%SP850Z ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SP700Z' ,int_state%SP700Z ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SM10WIND' ,int_state%SM10WIND ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SM10RV' ,int_state%SM10RV ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'SMSLP' ,int_state%SMSLP ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TRACKER_DISTSQ', int_state%TRACKER_DISTSQ ,(/ IMS,JMS /),(/ IME,JME /) ) - CALL SET_VAR_PTR(int_state%VARS,NV,'TRACKER_ANGLE', int_state%TRACKER_ANGLE ,(/ IMS,JMS /),(/ IME,JME /) ) - !else - ! write(0,*) 'Do not allocate tracker variables.' - !endif if_tracker - - ! END OF TRACKER VARIABLES --------------------------------------------- - !----------------------------------------------------------------------- - - DO N=1,NV - IF (int_state%VARS(N)%TKR==0) THEN - write(0,*)' Error in SET_DYN_VAR_PTR. ' - write(0,*)' Variable ',TRIM(int_state%VARS(N)%VBL_NAME),' is not associated to an internal state fortran pointer' - STOP - END IF - END DO - -! -!----------------------------------------------------------------------- -!*** Calculate the size of the storage needed for one tracer variable (TRACER_SIZE_1) -!*** and the size for all tracers (TRACER_SIZE). Then allocate one-dimensional -!*** arrays that will serve as actual storage. The actual storage -!*** array must be 1-D because multi-dimensional pointers are used -!*** to represent the actual tracer variables. Fortran will allow -!*** a multi-dimensional pointer to point only into a 1-D target -!*** when remapping the memory to the pointer's dimensions. -!----------------------------------------------------------------------- -! - TRACER_SIZE_1 = (IME-IMS+1)*(JME-JMS+1)*LM - TRACER_SIZE = TRACER_SIZE_1*int_state%NUM_TRACERS_TOTAL - - ALLOCATE(int_state%TRACERS_ARR (tracer_size)) ;int_state%TRACERS_ARR = R4_IN - ALLOCATE(int_state%TRACERS_PREV_ARR(tracer_size)) ;int_state%TRACERS_PREV_ARR = R4_IN -! -!----------------------------------------------------------------------- -!*** Point TRACERS as 4D array at the TRACERS_ARR (one-dimensional storage array) -!----------------------------------------------------------------------- -! - CALL FIND_VAR_INDX('TRACERS',int_state%VARS,int_state%NUM_VARS,I) - int_state%VARS(I)%R4D (IMS:IME,JMS:JME,1:LM,1:int_state%NUM_TRACERS_TOTAL) => int_state%TRACERS_ARR - int_state%TRACERS=>int_state%VARS(I)%R4D -! -!----------------------------------------------------------------------- -!*** Point TRACERS_PREV as 4D array at the TRACERS_PREV_ARR (one-dimensional storage array) -!----------------------------------------------------------------------- -! - CALL FIND_VAR_INDX('TRACERS_PREV',int_state%VARS,int_state%NUM_VARS,I) - int_state%VARS(I)%R4D (IMS:IME,JMS:JME,1:LM,1:int_state%NUM_TRACERS_TOTAL) => int_state%TRACERS_PREV_ARR - int_state%TRACERS_PREV=>int_state%VARS(I)%R4D -! -!----------------------------------------------------------------------- -!*** Point Q at level 1(INDX_Q) of the Tracers array. -!----------------------------------------------------------------------- -! - int_state%INDX_Q=1 - CALL FIND_VAR_INDX('Q',int_state%VARS,int_state%NUM_VARS,I) - int_state%VARS(I)%R3D(IMS:IME,JMS:JME,1:LM) => int_state%TRACERS_ARR( (int_state%INDX_Q-1)*TRACER_SIZE_1+1 : int_state%INDX_Q*TRACER_SIZE_1) - int_state%Q=>int_state%VARS(I)%R3D -! -!----------------------------------------------------------------------- -!*** Point CW (Combined cloud water array) at level 2(INDX_CW) of the Tracers array. -!----------------------------------------------------------------------- -! - int_state%INDX_CW=2 - CALL FIND_VAR_INDX('CW',int_state%VARS,int_state%NUM_VARS,I) - int_state%VARS(I)%R3D(IMS:IME,JMS:JME,1:LM) => int_state%TRACERS_ARR( (int_state%INDX_CW-1)*TRACER_SIZE_1+1 : int_state%INDX_CW*TRACER_SIZE_1) - int_state%CW=>int_state%VARS(I)%R3D -! -!----------------------------------------------------------------------- -!*** Point Q2 (Turbulence kinetic energy) at level 3(INDX_Q2) of the Tracers array. -!----------------------------------------------------------------------- -! - int_state%INDX_Q2=3 - CALL FIND_VAR_INDX('Q2',int_state%VARS,int_state%NUM_VARS,I) - int_state%VARS(I)%R3D(IMS:IME,JMS:JME,1:LM) => int_state%TRACERS_ARR( (int_state%INDX_Q2-1)*TRACER_SIZE_1+1 : int_state%INDX_Q2*TRACER_SIZE_1) - int_state%Q2=>int_state%VARS(I)%R3D -! -!-------------------------------- -!*** Water tracers (condensate only; water vapor is calculated from specific humidity) -!-------------------------------- -! - int_state%INDX_WATER_START = int_state%NUM_TRACERS_MET + int_state%NUM_TRACERS_CHEM + 1 - int_state%INDX_WATER_END = int_state%INDX_WATER_START + int_state%NUM_WATER - 1 - - if (int_state%P_QC .gt. 0) then - int_state%INDX_QC = int_state%INDX_WATER_START-1 + int_state%P_QC - CALL FIND_VAR_INDX('QC',int_state%VARS,int_state%NUM_VARS,I) - int_state%VARS(I)%R3D(IMS:IME,JMS:JME,1:LM) => int_state%TRACERS_ARR( (int_state%INDX_QC-1)*TRACER_SIZE_1+1 : int_state%INDX_QC*TRACER_SIZE_1) - int_state%QC=>int_state%VARS(I)%R3D - endif - if (int_state%P_QI .gt. 0) then - int_state%INDX_QI = int_state%INDX_WATER_START-1 + int_state%P_QI - CALL FIND_VAR_INDX('QI',int_state%VARS,int_state%NUM_VARS,I) - int_state%VARS(I)%R3D(IMS:IME,JMS:JME,1:LM) => int_state%TRACERS_ARR( (int_state%INDX_QI-1)*TRACER_SIZE_1+1 : int_state%INDX_QI*TRACER_SIZE_1) - int_state%QI=>int_state%VARS(I)%R3D - endif - if (int_state%P_QR .gt. 0) then - int_state%INDX_QR = int_state%INDX_WATER_START-1 + int_state%P_QR - CALL FIND_VAR_INDX('QR',int_state%VARS,int_state%NUM_VARS,I) - int_state%VARS(I)%R3D(IMS:IME,JMS:JME,1:LM) => int_state%TRACERS_ARR( (int_state%INDX_QR-1)*TRACER_SIZE_1+1 : int_state%INDX_QR*TRACER_SIZE_1) - int_state%QR=>int_state%VARS(I)%R3D - endif - if (int_state%P_QS .gt. 0) then - int_state%INDX_QS = int_state%INDX_WATER_START-1 + int_state%P_QS - CALL FIND_VAR_INDX('QS',int_state%VARS,int_state%NUM_VARS,I) - int_state%VARS(I)%R3D(IMS:IME,JMS:JME,1:LM) => int_state%TRACERS_ARR( (int_state%INDX_QS-1)*TRACER_SIZE_1+1 : int_state%INDX_QS*TRACER_SIZE_1) - int_state%QS=>int_state%VARS(I)%R3D - endif - if (int_state%P_QG .gt. 0) then - int_state%INDX_QG = int_state%INDX_WATER_START-1 + int_state%P_QG - CALL FIND_VAR_INDX('QG',int_state%VARS,int_state%NUM_VARS,I) - int_state%VARS(I)%R3D(IMS:IME,JMS:JME,1:LM) => int_state%TRACERS_ARR( (int_state%INDX_QG-1)*TRACER_SIZE_1+1 : int_state%INDX_QG*TRACER_SIZE_1) - int_state%QG=>int_state%VARS(I)%R3D - endif - if (int_state%P_NI .gt. 0) then - int_state%INDX_NI = int_state%INDX_WATER_START-1 + int_state%P_NI - CALL FIND_VAR_INDX('NI',int_state%VARS,int_state%NUM_VARS,I) - int_state%VARS(I)%R3D(IMS:IME,JMS:JME,1:LM) => int_state%TRACERS_ARR( (int_state%INDX_NI-1)*TRACER_SIZE_1+1 : int_state%INDX_NI*TRACER_SIZE_1) - int_state%NI=>int_state%VARS(I)%R3D - endif - if (int_state%P_NR .gt. 0) then - int_state%INDX_NR = int_state%INDX_WATER_START-1 + int_state%P_NR - CALL FIND_VAR_INDX('NR',int_state%VARS,int_state%NUM_VARS,I) - int_state%VARS(I)%R3D(IMS:IME,JMS:JME,1:LM) => int_state%TRACERS_ARR( (int_state%INDX_NR-1)*TRACER_SIZE_1+1 : int_state%INDX_NR*TRACER_SIZE_1) - int_state%NR=>int_state%VARS(I)%R3D - endif -! -!----------------------------------------------------------------------- -!*** We can retrieve LM from the internal state since it was -!*** placed there already from the config file. -!----------------------------------------------------------------------- -! - I_CYCLE=IDE-3 -! - LNSH=int_state%LNSH - LNSV=int_state%LNSV -! - int_state%TSTART=0.0 -! -!----------------------------------------------------------------------- -!*** Explicitly allocate standard arrays in the Solver internal state. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Grid-related constants. -!----------------------------------------------------------------------- -! - ALLOCATE(int_state%PDSG1 (1:LM)) ;int_state%PDSG1 = R4_IN !<-- Thicknesses of pressure layers in press. range - ALLOCATE(int_state%PSGML1(1:LM)) ;int_state%PSGML1 = R4_IN !<-- Pressure at midlayers in pressure range -! - ALLOCATE(int_state%PSG1(1:LM+1)) ;int_state%PSG1 = R4_IN !<-- Pressure at interfaces in pressure range (Pa) -! - ALLOCATE(int_state%KHFILT(JDS:JDE)) ;int_state%KHFILT = I4_IN !<-- Polar filter, truncation wave #, h points - ALLOCATE(int_state%KVFILT(JDS:JDE)) ;int_state%KVFILT = I4_IN !<-- Polar filter, truncation wave #, v points - ALLOCATE(int_state%NHSMUD(JMS:JME)) ;int_state%NHSMUD = I4_IN !<-- Polar smoother for unfiltered variables -! - ALLOCATE(int_state%HFILT(IDS:IDE,JDS:JDE)) ;int_state%HFILT = R4_IN !<-- Polar filter, h points - ALLOCATE(int_state%VFILT(IDS:IDE,JDS:JDE)) ;int_state%VFILT = R4_IN !<-- Polar filter, v points -! - ALLOCATE(int_state%CURV (JDS:JDE)) ;int_state%CURV = R4_IN !<-- Curvature term in coriolis force (m-1) - ALLOCATE(int_state%DARE (JDS:JDE)) ;int_state%DARE = R4_IN !<-- Gridbox area (m2) - ALLOCATE(int_state%DDMPU(JDS:JDE)) ;int_state%DDMPU = R4_IN !<-- Divergence damping coefficient, x direction (m) - ALLOCATE(int_state%DDV (JDS:JDE)) ;int_state%DDV = R4_IN !<-- Gridbox diagonal distance (m) - ALLOCATE(int_state%DXV (JDS:JDE)) ;int_state%DXV = R4_IN !<-- Delta x, v points (m) - ALLOCATE(int_state%FAD (JDS:JDE)) ;int_state%FAD = R4_IN !<-- Momentum advection factor - ALLOCATE(int_state%FAH (JDS:JDE)) ;int_state%FAH = R4_IN !<-- z, w advection factor - ALLOCATE(int_state%FCP (JDS:JDE)) ;int_state%FCP = R4_IN !<-- Temperature advection factor - ALLOCATE(int_state%FDIV (JDS:JDE)) ;int_state%FDIV = R4_IN !<-- Divergence factor - ALLOCATE(int_state%RARE (JDS:JDE)) ;int_state%RARE = R4_IN !<-- 1 / gridbox area (m-2) - ALLOCATE(int_state%RDDV (JDS:JDE)) ;int_state%RDDV = R4_IN !<-- 1 / gridbox diagonal distance (m-1) - ALLOCATE(int_state%RDXH (JDS:JDE)) ;int_state%RDXH = R4_IN !<-- 1 / delta x, h points (m-1) - ALLOCATE(int_state%RDXV (JDS:JDE)) ;int_state%RDXV = R4_IN !<-- 1 / delta x, v points (m-1) - ALLOCATE(int_state%WPDAR(JDS:JDE)) ;int_state%WPDAR = R4_IN !<-- Weight of grid separation filter -! - ALLOCATE(int_state%WFFTRH(1:2*I_CYCLE)) ;int_state%WFFTRH = R4_IN !<-- FFT working field, h points - ALLOCATE(int_state%WFFTRW(1:2*I_CYCLE)) ;int_state%WFFTRW = R4_IN !<-- FFT working field, v points - ALLOCATE(int_state%NFFTRH(1:15)) ;int_state%NFFTRH = I4_IN !<-- FFT working field, h points - ALLOCATE(int_state%NFFTRW(1:15)) ;int_state%NFFTRW = I4_IN !<-- FFT working field, v points -! -!----------------------------------------------------------------------- -!*** Local horizontal subdomain limits for all forecast tasks. -!----------------------------------------------------------------------- -! - ALLOCATE(int_state%LOCAL_ISTART(0:int_state%NUM_PES-1)) ;int_state%LOCAL_ISTART = I4_IN - ALLOCATE(int_state%LOCAL_IEND (0:int_state%NUM_PES-1)) ;int_state%LOCAL_IEND = I4_IN - ALLOCATE(int_state%LOCAL_JSTART(0:int_state%NUM_PES-1)) ;int_state%LOCAL_JSTART = I4_IN - ALLOCATE(int_state%LOCAL_JEND (0:int_state%NUM_PES-1)) ;int_state%LOCAL_JEND = I4_IN -! - int_state%IMS=IMS - int_state%IME=IME - int_state%JMS=JMS - int_state%JME=JME - int_state%IDS=IDS - int_state%IDE=IDE - int_state%JDS=JDS - int_state%JDE=JDE -! - int_state%IHALO=IHALO - int_state%JHALO=JHALO -! -!----------------------------------------------------------------------- -!*** Atmospheric variables, hydrostatic (mostly) -!----------------------------------------------------------------------- -! - ALLOCATE(int_state%PSDT(IMS:IME,JMS:JME)) ;int_state%PSDT = R4_IN !<-- Hydrostatic surface pressure tendency (Pa s-1) -! -!----------------------------------------------------------------------- -!*** The TRACERS array holds all general "tracer" variables including -!*** water. Place the desired variables at the top of the TRACERS -!*** array, level 1 through NUM_TRACERS_MET. All other scalar variables -!*** (e.g., chemistry and aerosols) will follow. -!----------------------------------------------------------------------- -! - ALLOCATE(int_state%TRACERS_SQRT(IMS:IME,JMS:JME,1:LM,1:int_state%NUM_TRACERS_TOTAL)) ;int_state%TRACERS_SQRT = R4_IN !<-- Sqrt of tracers (for advection) - ALLOCATE(int_state%TRACERS_TEND(IMS:IME,JMS:JME,1:LM,1:int_state%NUM_TRACERS_TOTAL)) ;int_state%TRACERS_TEND = R4_IN !<-- Tendency of tracers (for advection) -! -!----------------------------------------------------------------------- -!*** Atmospheric variables, nonhydrostatic -!----------------------------------------------------------------------- -! - ALLOCATE(int_state%PDWDT(IMS:IME,JMS:JME,1:LM)) ;int_state%PDWDT = R4_IN !<-- Correction factor, previous step (m s-2) -! -!----------------------------------------------------------------------- -!*** Working arrays passed as arguments between subroutines. -!----------------------------------------------------------------------- -! - ALLOCATE(int_state%DEF (IMS:IME,JMS:JME,1:LM)) ;int_state%DEF = R4_IN !<-- Horizontal flow deformation - ALLOCATE(int_state%PCNE(IMS:IME,JMS:JME,1:LM)) ;int_state%PCNE = R4_IN !<-- 2nd term of pgf, NE direction - ALLOCATE(int_state%PCNW(IMS:IME,JMS:JME,1:LM)) ;int_state%PCNW = R4_IN !<-- 2nd term of pgf, NW direction - ALLOCATE(int_state%PCX (IMS:IME,JMS:JME,1:LM)) ;int_state%PCX = R4_IN !<-- 2nd term of pgf, X direction - ALLOCATE(int_state%PCY (IMS:IME,JMS:JME,1:LM)) ;int_state%PCY = R4_IN !<-- 2nd term of pgf, Y direction - ALLOCATE(int_state%PFNE(IMS:IME,JMS:JME,1:LM)) ;int_state%PFNE = R4_IN !<-- Mass flux, NE direction - ALLOCATE(int_state%PFNW(IMS:IME,JMS:JME,1:LM)) ;int_state%PFNW = R4_IN !<-- Mass flux, NW direction - ALLOCATE(int_state%PFX (IMS:IME,JMS:JME,1:LM)) ;int_state%PFX = R4_IN !<-- Mass flux, X direction - ALLOCATE(int_state%PFY (IMS:IME,JMS:JME,1:LM)) ;int_state%PFY = R4_IN !<-- Mass flux, Y direction - ALLOCATE(int_state%TDIV(IMS:IME,JMS:JME,1:LM)) ;int_state%TDIV = R4_IN !<-- Integrated horizontal mass divergence -! -!----------------------------------------------------------------------- -!*** Prognostic arrays -!----------------------------------------------------------------------- -! - ALLOCATE(int_state%DUDT(IMS:IME,JMS:JME,1:LM)) ;int_state%DUDT = R4_IN ! U wind component tendency (m s-2) - ALLOCATE(int_state%DVDT(IMS:IME,JMS:JME,1:LM)) ;int_state%DVDT = R4_IN ! V wind component tendency (m s-2) -! - ALLOCATE(int_state%W0AVG(IMS:IME,1:LM+1,JMS:JME)) ;int_state%W0AVG = R4_IN ! Time-averaged vertical velocity (for K-F) (m s-1) -! - ALLOCATE(int_state%RTOP(IMS:IME,JMS:JME,1:LM)) ;int_state%RTOP = R4_IN ! RT/P, specific volume (m3 kg-1) -! - ALLOCATE(int_state%PPTDAT(IMS:IME,JMS:JME,1:int_state%PCPHR)) ;int_state%PPTDAT = R4_IN -! -!----------------------------------------------------------------------- -!*** GFS microphysics, wang, 11-22-2010 -!----------------------------------------------------------------------- -! - ALLOCATE(int_state%TP1(IMS:IME,JMS:JME,1:LM)) - ALLOCATE(int_state%QP1(IMS:IME,JMS:JME,1:LM)) - ALLOCATE(int_state%PSP1(IMS:IME,JMS:JME)) - DO I=IMS,IME - DO J=JMS,JME - int_state%PSP1(I,J) = -999.0 - DO L=1,LM - int_state%TP1(I,J,L) = -999.0 - int_state%QP1(I,J,L) = -999.0 - ENDDO - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** Only for GFS physics -!----------------------------------------------------------------------- -! - IF ( int_state%GFS ) THEN - REWIND (KOZPL) - READ (KOZPL) PL_COEFF, LATSOZP, LEVOZP, TIMEOZ - ALLOCATE(int_state%OZPLIN(LATSOZP,LEVOZP,PL_COEFF,TIMEOZ)) ;int_state%OZPLIN = R8_IN - ENDIF -! -!----------------------------------------------------------------------- -! - ALLOCATE(int_state%LPBL(IMS:IME,JMS:JME)) ;int_state%LPBL = I4_IN ! Model layer containing top of the PBL - ALLOCATE(int_state%DDATA(IMS:IME,JMS:JME)) ;int_state%DDATA = R4_IN ! Observed precip to each physics timestep (kg m-2) - ALLOCATE(int_state%MAVAIL(IMS:IME,JMS:JME)) ;int_state%MAVAIL = R4_IN ! Moisture availability - ALLOCATE(int_state%SHDMAX(IMS:IME,JMS:JME)) ;int_state%SHDMAX = R4_IN ! Maximum areal fractional coverage of annual green vegetation - ALLOCATE(int_state%SHDMIN(IMS:IME,JMS:JME)) ;int_state%SHDMIN = R4_IN ! Minimum areal fractional coverage of annual green vegetation - ALLOCATE(int_state%STDH(IMS:IME,JMS:JME)) ;int_state%STDH = R4_IN ! Standard deviation of topography height (m) !zj - ALLOCATE(int_state%CROT(IMS:IME,JMS:JME)) ;int_state%CROT = R4_IN ! Cosine of the angle between Earth and model coordinates - ALLOCATE(int_state%SROT(IMS:IME,JMS:JME)) ;int_state%SROT = R4_IN ! Sine of the angle between Earth and model coordinates - ALLOCATE(int_state%HSTDV(IMS:IME,JMS:JME)) ;int_state%HSTDV = R4_IN ! Standard deviation of the height (m) - ALLOCATE(int_state%HCNVX(IMS:IME,JMS:JME)) ;int_state%HCNVX = R4_IN ! Orographic convexity - ALLOCATE(int_state%HASYW(IMS:IME,JMS:JME)) ;int_state%HASYW = R4_IN ! Orographic asymmetry, west wind direction - ALLOCATE(int_state%HASYS(IMS:IME,JMS:JME)) ;int_state%HASYS = R4_IN ! Orographic asymmetry, south wind direction - ALLOCATE(int_state%HASYSW(IMS:IME,JMS:JME)) ;int_state%HASYSW = R4_IN ! Orographic asymmetry, southwest wind direction - ALLOCATE(int_state%HASYNW(IMS:IME,JMS:JME)) ;int_state%HASYNW = R4_IN ! Orographic asymmetry, northwest wind direction - ALLOCATE(int_state%HLENW(IMS:IME,JMS:JME)) ;int_state%HLENW = R4_IN ! Orographic length scale, west wind direction - ALLOCATE(int_state%HLENS(IMS:IME,JMS:JME)) ;int_state%HLENS = R4_IN ! Orographic length scale, south wind direction - ALLOCATE(int_state%HLENSW(IMS:IME,JMS:JME)) ;int_state%HLENSW = R4_IN ! Orographic length scale, southwest wind direction - ALLOCATE(int_state%HLENNW(IMS:IME,JMS:JME)) ;int_state%HLENNW = R4_IN ! Orographic length scale, northwest wind direction - ALLOCATE(int_state%HANGL(IMS:IME,JMS:JME)) ;int_state%HANGL = R4_IN ! Angle of mountain range with respect to east - ALLOCATE(int_state%HANIS(IMS:IME,JMS:JME)) ;int_state%HANIS = R4_IN ! Anisotropy/aspect ratio - ALLOCATE(int_state%HSLOP(IMS:IME,JMS:JME)) ;int_state%HSLOP = R4_IN ! Slope of orography - ALLOCATE(int_state%HZMAX(IMS:IME,JMS:JME)) ;int_state%HZMAX = R4_IN ! Maximum height about mean terrain - ALLOCATE(int_state%Q02(IMS:IME,JMS:JME)) ;int_state%Q02 = R4_IN ! Specific humidity at 2-m (kg k-1) - ALLOCATE(int_state%TH02(IMS:IME,JMS:JME)) ;int_state%TH02 = R4_IN ! Theta at 2-m (K) -! -!----------------------------------------------------------------------- -!*** GFS physics -!----------------------------------------------------------------------- -! - gfs_physics: IF(int_state%GFS)THEN -! - ALLOCATE(int_state%DDY (JTS:JTE)) ;int_state%DDY = R8_IN ! - ALLOCATE(int_state%JINDX1 (JTS:JTE)) ;int_state%JINDX1 = I4_IN ! - ALLOCATE(int_state%JINDX2 (JTS:JTE)) ;int_state%JINDX2 = I4_IN ! -! - ALLOCATE(int_state%DUGWD (IMS:IME,JMS:JME)) ;int_state%DUGWD = R8_IN ! U comp. GWD tend (m s-1) - ALLOCATE(int_state%DVGWD (IMS:IME,JMS:JME)) ;int_state%DVGWD = R8_IN ! V comp. GWD tend (m s-1) -! - ALLOCATE(int_state%TMPMIN (IMS:IME,JMS:JME)) ;int_state%TMPMIN = R8_IN ! Max temp (K) - ALLOCATE(int_state%TMPMAX (IMS:IME,JMS:JME)) ;int_state%TMPMAX = R8_IN ! Min temp (K) -! - ALLOCATE(int_state%SFALB (IMS:IME,JMS:JME)) ;int_state%SFALB = R8_IN ! - ALLOCATE(int_state%TSFLW (IMS:IME,JMS:JME)) ;int_state%TSFLW = R8_IN ! - ALLOCATE(int_state%SEMIS (IMS:IME,JMS:JME)) ;int_state%SEMIS = R8_IN ! - ALLOCATE(int_state%SFCDLW (IMS:IME,JMS:JME)) ;int_state%SFCDLW = R8_IN ! - ALLOCATE(int_state%SFCDSW (IMS:IME,JMS:JME)) ;int_state%SFCDSW = R8_IN ! - ALLOCATE(int_state%SFCNSW (IMS:IME,JMS:JME)) ;int_state%SFCNSW = R8_IN ! -! - ALLOCATE(int_state%ZORFCS (IMS:IME,JMS:JME)) ;int_state%ZORFCS = R8_IN ! - ALLOCATE(int_state%SIHFCS (IMS:IME,JMS:JME)) ;int_state%SIHFCS = R8_IN ! - ALLOCATE(int_state%SICFCS (IMS:IME,JMS:JME)) ;int_state%SICFCS = R8_IN ! - ALLOCATE(int_state%SLPFCS (IMS:IME,JMS:JME)) ;int_state%SLPFCS = R8_IN ! - ALLOCATE(int_state%TG3FCS (IMS:IME,JMS:JME)) ;int_state%TG3FCS = R8_IN ! - ALLOCATE(int_state%VEGFCS (IMS:IME,JMS:JME)) ;int_state%VEGFCS = R8_IN ! - ALLOCATE(int_state%VETFCS (IMS:IME,JMS:JME)) ;int_state%VETFCS = R8_IN ! - ALLOCATE(int_state%SOTFCS (IMS:IME,JMS:JME)) ;int_state%SOTFCS = R8_IN ! -! - ALLOCATE(int_state%ALBFC1 (IMS:IME,JMS:JME,4)) ;int_state%ALBFC1 = R8_IN ! - ALLOCATE(int_state%ALFFC1 (IMS:IME,JMS:JME,2)) ;int_state%ALFFC1 = R8_IN ! -! - ALLOCATE(int_state%PHY_F2DV (IMS:IME,JMS:JME,3)) ;int_state%PHY_F2DV = R8_IN ! for Zhao =3, Ferr=1 - ALLOCATE(int_state%PHY_F3DV (IMS:IME,JMS:JME,LM,4)) ;int_state%PHY_F3DV = R8_IN ! for Zhao =4, Ferr=3 -! - ENDIF gfs_physics -! -!----------------------------------------------------------------------- -! - END SUBROUTINE SET_INTERNAL_STATE_SOLVER -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - END MODULE MODULE_SOLVER_INTERNAL_STATE -! -!----------------------------------------------------------------------- diff --git a/src/nmm/module_TIMESERIES.F90 b/src/nmm/module_TIMESERIES.F90 deleted file mode 100644 index d620c74..0000000 --- a/src/nmm/module_TIMESERIES.F90 +++ /dev/null @@ -1,612 +0,0 @@ -!----------------------------------------------------------------------- - module module_timeseries -!----------------------------------------------------------------------- - - use module_kinds - use module_constants - use module_my_domain_specs - use module_vars - -!----------------------------------------------------------------------- - - implicit none - -!----------------------------------------------------------------------- - - private - - public :: timeseries_initialize, timeseries_run, timeseries_finalize - - integer, parameter :: max_point=20 - logical, save :: initialized=.false. - integer, save :: npoints - real, dimension(max_point), save :: points_lon, points_lat - integer, dimension(max_point), save :: ipnt, jpnt - real, dimension(max_point), save :: pnt_lon, pnt_lat - - real, parameter :: rtd=180.0/pi - - real, allocatable, dimension(:,:) :: zint ! height of full levels - real, allocatable, dimension(:,:) :: zmid ! height of half levels - - integer, dimension(max_point), save :: tsunit - - integer :: var2d_number - character(len=8), dimension(1000) :: var2d_name - character(len=24), dimension(1000) :: var2d_units - character(len=64), dimension(1000) :: var2d_description - integer :: var3d_number - character(len=8), dimension(1000) :: var3d_name - character(len=24), dimension(1000) :: var3d_units - character(len=64), dimension(1000) :: var3d_description - character(len=4), dimension(1000) :: var3d_lvlind - - logical :: nml_exist - - integer, parameter :: max_fulllevel_vars = 10 - character(len=8), dimension(max_fulllevel_vars) :: fulllevel_vars & - = reshape ( (/ & - 'PINT ' & - /) & - ,(/max_fulllevel_vars/) & - ,(/'********'/) & - ) -!----------------------------------------------------------------------- - - contains - -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- - - subroutine timeseries_initialize(solver_state,ntsd,ierr) - - use module_solver_internal_state, only : solver_internal_state - - implicit none - - type(solver_internal_state),intent(in) :: solver_state - integer, intent(in) :: ntsd - integer, intent(out) :: ierr - - integer :: ios - - integer :: im, jm, lm - real :: tlm0d,tph0d,dlmd,dphd,wbd,sbd - real :: tlmd,tphd - integer :: i,k,j, np, var, inrs,jnrs, nvar, n, l - logical :: inside - integer, dimension(8) :: modelstarttime - character(len=3) :: trnum - - integer year, month, day, hour, minute, second, ten_thousandth - integer :: ihr - integer :: nf_hours,nf_minutes - real :: nf_seconds - real :: secfcst - integer :: idatv(3),ihrv,idaywk - - character*128 :: filename - - namelist /ts_locations/ npoints, points_lon, points_lat - - - ierr = 0 - - if (initialized) return - - inquire ( file='ts_locations.nml', exist=nml_exist) - - if (.not.nml_exist) then - if (mype == 0) then - write(0,*) ' ts_locations.nml does not exist. will skip timeseries output' - end if - return - end if - - open ( unit=80, file='ts_locations.nml', status='old', iostat = ios) - if (ios /= 0) then - write(0,*) 'error missing ts_locations.nml' - ierr = -1 - return - end if - read ( unit=80, nml=ts_locations, iostat = ios) - if (ios /= 0) then - write(0,*) 'error reading ts_locations.nml' - ierr = -1 - return - end if - close(unit=80,iostat=ios) - if (ios /= 0) then - write(0,*) 'error closing ts_locations.nml' - ierr = -1 - return - end if - - im = solver_state%im - jm = solver_state%jm - lm = solver_state%lm - tlm0d = solver_state%tlm0d - tph0d = solver_state%tph0d - dlmd = solver_state%dlmd - dphd = solver_state%dphd - wbd = solver_state%wbd - sbd = solver_state%sbd - -!! calculate forecast time for this time step - - secfcst = solver_state%dt * ntsd - nf_hours = int(secfcst/3600) - ihr = nf_hours - nf_minutes = int( mod(secfcst,3600.0)/60.0 ) - nf_seconds = (secfcst - nf_hours*3600.0) - nf_minutes*60.0 - if (nf_seconds< 0.000001) nf_seconds=0.0 - ten_thousandth = nint((secfcst-int(secfcst))*10000) - - call valid(solver_state%idat,solver_state%ihrst,nf_hours,idatv,ihrv,idaywk) - - year = idatv(3) - month = idatv(2) - day = idatv(1) - hour = ihrv - minute = nf_minutes - second = nf_seconds - - modelstarttime(1) = year - modelstarttime(2) = month - modelstarttime(3) = day - modelstarttime(4) = hour - modelstarttime(5) = minute - modelstarttime(6) = second - modelstarttime(7) = 0 - modelstarttime(8) = ntsd - - allocate(zint(npoints,lm+1)) - allocate(zmid(npoints,lm)) - - var2d_number = 0 - var3d_number = 0 - - -!! loop over all solver state variables and find which ones are selected for timeseries output. -!! currently only 2d and 3d real variables are supported. this is due to limitations of used -!! timeseries binary file format - - do n=1,solver_state%num_vars - if (solver_state%vars(n)%tseries) then - select case(solver_state%vars(n)%tkr) - case(tkr_r2d) - var2d_number = var2d_number + 1 - var2d_name(var2d_number) = trim(solver_state%vars(n)%vbl_name) - var2d_units(var2d_number) = "" - var2d_description(var2d_number) = trim(solver_state%vars(n)%description) - case(tkr_r3d) - var3d_number = var3d_number + 1 - var3d_name(var3d_number) = trim(solver_state%vars(n)%vbl_name) - var3d_units(var3d_number) = "" - var3d_description(var3d_number) = trim(solver_state%vars(n)%description) - var3d_lvlind(var3d_number) = 'H ' - - !! for 3d variables, level indicator is set to 'H' by default which means 'half' level - !! variable, or variable located at the middle of the layer in vertical. if the variable name - !! is included in the list of "full" level (or interface) variables then - !! level indicator is reset to 'F' - - do l=1,max_fulllevel_vars - if (trim(fulllevel_vars(l))==trim(var3d_name(var3d_number))) then - var3d_lvlind(var3d_number) = 'F ' - exit - end if - end do - case default - write(0,*)' unknown tkr = ', solver_state%vars(n)%tkr, trim(solver_state%vars(n)%vbl_name) - ierr = -1 - return - end select - end if - end do - -!! loop over number of points specified in ts_locations namelist and calculate i,j -!! indexes of the nearest H point - - np_loop: do np=1,npoints - - call tll(points_lon(np),points_lat(np),tlmd,tphd,tph0d,tlm0d) - call ijnrs(tlmd,tphd,dlmd,dphd,wbd,sbd,im,jm,inrs,jnrs,inside) - if (inside) then - ipnt(np)=inrs - jpnt(np)=jnrs - end if - -!! if this point, with i,j indexes ipnt(np),jpnt(np) is inside the tile (its:ite,jts:jte) -!! located on this PE then proceed and create output file and write out file header - - inside_if: if (its <= ipnt(np) .and. ipnt(np) <= ite .and. jts <= jpnt(np) .and. jpnt(np) <= jte ) then - - i = ipnt(np) - j = jpnt(np) - zint(np,lm+1)=solver_state%fis(i,j)/g - - do k=lm,1,-1 - zint(np,k)=zint(np,k+1)+solver_state%t(i,j,k)*(0.608*max(solver_state%q(i,j,k),epsq)+1.)*r_d & - *(solver_state%pint(i,j,k+1)-solver_state%pint(i,j,k)) & - /((solver_state%sgml2(k)*solver_state%pd(i,j)+solver_state%psgml1(k))*g) - zmid(np,k)=0.5*(zint(np,k+1)+zint(np,k)) - end do - -!! open the timeseries output file - tsunit(np) = 90 + np - write(filename,fmt='(a,i2.2,a,i2.2,a)') "ts_p",np,"_d",my_domain_id,".bin" - write(0,*) ' open file:', np,tsunit(np),filename - open(unit=tsunit(np), file=filename, form='unformatted', iostat=ios) - if (ios /= 0) then - write(0,*) 'error opening file '//trim(filename)//' in timeseries_initialize' - ierr = -1 - return - end if - -!! header - write(tsunit(np)) solver_state%dt - write(tsunit(np)) modelstarttime - write(tsunit(np)) 0 ! avgyn - write(tsunit(np)) 0 ! avgfrq - write(tsunit(np)) 0 ! avglen - write(tsunit(np)) 0 ! avgfirst - write(tsunit(np)) var2d_number - do nvar=1,var2d_number - write(tsunit(np)) nvar,var2d_name(nvar),var2d_units(nvar),var2d_description(nvar) - write(0,*) nvar,var2d_name(nvar),var2d_units(nvar),var2d_description(nvar) - end do - write(tsunit(np)) var3d_number - do nvar=1,var3d_number - write(tsunit(np)) nvar,var3d_name(nvar),var3d_lvlind(nvar),var3d_units(nvar),var3d_description(nvar) - write(0,*) nvar,var3d_name(nvar),var3d_lvlind(nvar),var3d_units(nvar),var3d_description(nvar) - end do - write(tsunit(np)) 1 - write(tsunit(np)) ipnt(np),jpnt(np), points_lat(np),points_lon(np) - write(tsunit(np)) lm+1 ! number of full levels - do k=1,lm+1 - write(tsunit(np)) zint(np,k) - end do - write(tsunit(np)) lm ! number of half levels - do k=1,lm - write(tsunit(np)) zmid(np,k) - end do -!! end of header - -!! close the file - close(unit=tsunit(np), iostat=ios) - if (ios /= 0) then - write(0,*) 'error closing '//filename - end if - - end if inside_if - - end do np_loop - - initialized=.true. - - end subroutine timeseries_initialize - -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- - - subroutine timeseries_run(solver_state,ntsd,ierr) - - use module_solver_internal_state, only : solver_internal_state - - implicit none - - type(solver_internal_state),intent(in) :: solver_state - integer,intent(in) :: ntsd - integer, intent(out) :: ierr - - integer i,j,k, lm, lmax, l - integer n, np, var - integer year, month, day, hour, minute, second, ten_thousandth - real :: tlm0d,tph0d - real :: pus,pvs - - integer :: ihr - integer :: nf_hours,nf_minutes - real :: nf_seconds - real :: secfcst - - integer :: idatv(3),ihrv,idaywk - - integer :: ios - character*128 :: filename - -!! - if (.not.nml_exist) then - ierr = 0 - return - end if - - tlm0d = solver_state%tlm0d - tph0d = solver_state%tph0d - lm = solver_state%lm - -!! calculate forecast time for this time step - - secfcst = solver_state%dt * ntsd - nf_hours = int(secfcst/3600) - ihr = nf_hours - nf_minutes = int( mod(secfcst,3600.0)/60.0 ) - nf_seconds = (secfcst - nf_hours*3600.0) - nf_minutes*60.0 - if (nf_seconds< 0.000001) nf_seconds=0.0 - ten_thousandth = nint((secfcst-int(secfcst))*10000) - - call valid(solver_state%idat,solver_state%ihrst,nf_hours,idatv,ihrv,idaywk) - - year = idatv(3) - month = idatv(2) - day = idatv(1) - hour = ihrv - minute = nf_minutes - second = nf_seconds - - - j_loop: do j = jts, jte - i_loop: do i = its, ite - - np_loop: do np = 1, npoints - - if (i.eq.ipnt(np) .and. j.eq.jpnt(np)) then - - tsunit(np) = 90 + np - write(filename,fmt='(a,i2.2,a,i2.2,a)') "ts_p",np,"_d",my_domain_id,".bin" - write(0,*) ' open file:', np,tsunit(np),filename - open(unit=tsunit(np), file=filename, form='unformatted', position='append', iostat=ios) - if (ios /= 0) then - write(0,*) 'error opening file '//trim(filename)//' in timeseries_run' - ierr = -1 - return - end if - - write(tsunit(np)) year,month,day,hour,minute,second,ten_thousandth,ntsd - -! 2d - do n=1,solver_state%num_vars - if (solver_state%vars(n)%tseries .and. solver_state%vars(n)%tkr==tkr_r2d) then - write(tsunit(np)) solver_state%vars(n)%r2d(i,j) - end if - end do - -!3d - do n=1,solver_state%num_vars - if (solver_state%vars(n)%tseries .and. solver_state%vars(n)%tkr==tkr_r3d) then - lmax = lm - do l=1,max_fulllevel_vars - if (trim(fulllevel_vars(l))==trim(solver_state%vars(n)%vbl_name)) then - lmax = lm+1 - exit - end if - end do - do k=1,lmax - write(tsunit(np)) solver_state%vars(n)%r3d(i,j,k) - end do - if(lmax==lm) write(tsunit(np)) 0.0 - end if - end do - - close(unit=tsunit(np), iostat=ios) - if (ios /= 0) then - write(0,*) 'error closing '//filename - end if - - end if - - end do np_loop - - end do i_loop - end do j_loop - - end subroutine timeseries_run - -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- - - subroutine timeseries_finalize - end subroutine timeseries_finalize - -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- - - subroutine tll(almd,aphd,tlmd,tphd,tph0d,tlm0d) -!----------------------------------------------------------------------- - real, intent(in) :: almd, aphd - real, intent(out) :: tlmd, tphd - real, intent(in) :: tph0d, tlm0d -!----------------------------------------------------------------------- - real, parameter :: pi=3.141592654 - real, parameter :: dtr=pi/180.0 -! - real :: tph0, ctph0, stph0, relm, srlm, crlm - real :: aph, sph, cph, cc, anum, denom -!----------------------------------------------------------------------- - - tph0=tph0d*dtr - ctph0=cos(tph0) - stph0=sin(tph0) - - relm=(almd-tlm0d)*dtr - srlm=sin(relm) - crlm=cos(relm) - aph=aphd*dtr - sph=sin(aph) - cph=cos(aph) - cc=cph*crlm - anum=cph*srlm - denom=ctph0*cc+stph0*sph - - tlmd=atan2(anum,denom)/dtr - tphd=asin(ctph0*sph-stph0*cc)/dtr - - return - - end subroutine tll - -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- - - subroutine ijnrs(tlmpt,tphpt,dlmd,dphd,wbd,sbd,im,jm,inrs,jnrs,inside) - -! ****************************************************************** -! * * -! * code to: * -! * - find the i and j indices of nearest h point of the b * -! * grid box containing point tlmpt,tphpt * -! * * -! * ictp version - d.jovic * -! ****************************************************************** - - real, intent(in) :: tlmpt,tphpt,dlmd,dphd,wbd,sbd - integer, intent(in) :: im,jm - integer, intent(out) :: inrs,jnrs - logical, intent(out) :: inside - -!----------------------------------------------------------------------- - - inrs=nint((tlmpt-wbd)/dlmd)+1 - jnrs=nint((tphpt-sbd)/dphd)+1 - - if (jnrs >= 1 .and. jnrs <= jm .and. inrs >= 1 .and. inrs <= im ) then - inside=.true. - else - inside=.false. - endif - - return - - end subroutine ijnrs - -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- - - subroutine tllwin(almd,aphd,tph0d,tlm0d,pus,pvs) - -! ****************************************************************** -! * * -! * ll to tll transformation of velocity * -! * * -! * programer: z.janjic, yugoslav fed. hydromet. inst., * -! * beograd, 1982 * -! * * -! ****************************************************************** - - real, intent (in) :: almd, aphd - real, intent (in) :: tph0d, tlm0d - real, intent (inout) :: pus,pvs - - real, parameter :: pi=3.141592654 - real, parameter :: dtr=pi/180.0 - - real :: relm,ctph0,stph0,tph0,srlm,crlm,ph,sph,cph,cc,tph - real :: rctph,cray,dray - real :: tpus,tpvs - real :: rdenom - -!----------------------------------------------------------------------- - - tph0=tph0d*dtr - - ctph0=cos(tph0) - stph0=sin(tph0) - - relm=(almd-tlm0d)*dtr - srlm=sin(relm) - crlm=cos(relm) - - ph=aphd*dtr - sph=sin(ph) - cph=cos(ph) - - cc=cph*crlm - tph=asin(ctph0*sph-stph0*cc) - rctph=1.0/cos(tph) - - cray=stph0*srlm*rctph - dray=(ctph0*cph+stph0*sph*crlm)*rctph - - tpus=pus - tpvs=pvs - rdenom=1.0/(dray*dray + cray*cray) - pus=(dray*tpus+cray*tpvs)*rdenom - pvs=(-cray*tpus+dray*tpvs)*rdenom - - return - - end subroutine tllwin - -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- - - subroutine valid(idat,ihrst,ihr,idatv,ihrv,idaywk) - integer idat(3),ihrst,ihr,idatv(3),ihrv,idaywk - - integer :: ijulian,iadd,iadday,idayyr - - ijulian=iw3jdn(idat(3),idat(2),idat(1)) - iadd=ihrst+ihr - iadday=int((ihrst+ihr)/24) - ihrv=iadd-24*iadday - ijulian=ijulian+iadday - call w3fs26(ijulian,idatv(3),idatv(2),idatv(1),idaywk,idayyr) - return - end subroutine valid - -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- - - integer function iw3jdn(iyear,month,iday) - - integer, intent(in) :: iyear,month,iday - - iw3jdn = iday - 32075 & - + 1461 * (iyear + 4800 + (month - 14) / 12) / 4 & - + 367 * (month - 2 - (month -14) / 12 * 12) / 12 & - - 3 * ((iyear + 4900 + (month - 14) / 12) / 100) / 4 - return - end function iw3jdn - -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- - - subroutine w3fs26(jldayn,iyear,month,iday,idaywk,idayyr) - - integer, intent(in) :: jldayn - integer, intent(out) :: iyear, month, iday,idaywk,idayyr - - integer :: l,n,i,j - - l = jldayn + 68569 - n = 4 * l / 146097 - l = l - (146097 * n + 3) / 4 - i = 4000 * (l + 1) / 1461001 - l = l - 1461 * i / 4 + 31 - j = 80 * l / 2447 - iday = l - 2447 * j / 80 - l = j / 11 - month = j + 2 - 12 * l - iyear = 100 * (n - 49) + i + l - idaywk = mod((jldayn + 1),7) + 1 - idayyr = jldayn - (-31739 +1461 * (iyear+4799) / 4 - 3 * ((iyear+4899)/100)/4) - return - end subroutine w3fs26 - -!----------------------------------------------------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------------------------------------------------------- - - end module module_timeseries - -!----------------------------------------------------------------------- diff --git a/src/nmm/module_TRACKER.F90 b/src/nmm/module_TRACKER.F90 deleted file mode 100644 index 16b1ed1..0000000 --- a/src/nmm/module_TRACKER.F90 +++ /dev/null @@ -1,1985 +0,0 @@ -module module_tracker - use MODULE_SOLVER_INTERNAL_STATE, only : SOLVER_INTERNAL_STATE,TRACK_MAX_OLD - use MODULE_REDUCTION - use MODULE_RELAX4E - - implicit none - private - public :: tracker_center, tracker_init, update_tracker_post_move - - real, parameter :: invE=0.36787944117 ! 1/e - - ! Copied from tracker: - real,parameter :: searchrad_6=250.0 ! km - ignore data more than this far from domain center - real,parameter :: searchrad_7=200.0 ! km - ignore data more than this far from domain center - integer, parameter :: maxtp=11 ! number of tracker parameters - real, parameter :: uverrmax = 225.0 ! For use in get_uv_guess - real, parameter :: ecircum = 40030.2 ! Earth's circumference - ! (km) using erad=6371.e3 - real, parameter :: rads_vmag=120.0 ! max search radius for wind minimum - real, parameter :: err_reg_init=300.0 ! max err at initial time (km) - real, parameter :: err_reg_max=225.0 ! max err at other times (km) - - real, parameter :: errpmax=485.0 ! max stddev of track parameters - real, parameter :: errpgro=1.25 ! stddev multiplier - - real, parameter :: max_wind_search_radius=searchrad_7 ! max radius for vmax search - real, parameter :: min_mlsp_search_radius=searchrad_7 ! max radius for pmin search - - ! Also used: - real, parameter :: km2nmi = 0.539957, kn2mps=0.514444, mps2kn=1./kn2mps, pi180=0.01745329251 - integer :: tracker_debug_level=-1 ! Disable all messages by default - ! 0=tracker_message only - ! 1=most tracker_debug calls - logical :: tracker_diagnostics=.true. ! Extra diagnostic prints -contains - - !---------------------------------------------------------------------------------- - ! These two simple routines return an N, S, E or W for the - ! hemisphere of a latitude or longitude. They are copied from - ! module_HIFREQ to avoid a relatively pointless compiler dependency. - - character(1) function get_lat_ns(lat) - ! This could be written simply as merge('N','S',lat>=0) in Fortran 95 - implicit none ; real lat - if(lat>=0) then - get_lat_ns='N' - else - get_lat_ns='S' - endif - end function get_lat_ns - character(1) function get_lon_ew(lon) - ! This could be written simply as merge('E','W',lon>=0) in Fortran 95 - implicit none ; real lon - if(lon>=0) then - get_lon_ew='E' - else - get_lon_ew='W' - endif - end function get_lon_ew - - subroutine tracker_message(what) - character*(*), intent(in) :: what - if(0<=tracker_debug_level) then - print "('Tracker: ',A)",trim(what) - endif - end subroutine tracker_message - - subroutine tracker_debug(level,what) - character*(*), intent(in) :: what - integer, intent(in) :: level - if(level<=tracker_debug_level) then - print "('Tracker debug: ',A)",trim(what) - endif - end subroutine tracker_debug - - subroutine tracker_abort(why) - use mpi - character*(*), intent(in) :: why - integer :: ierr -308 format('Tracker abort: ',A) - print 308,trim(why) - write(0,308) trim(why) - call MPI_Abort(MPI_COMM_WORLD,2,ierr) - end subroutine tracker_abort - - subroutine tracker_close(grid) - type(solver_internal_state), intent(inout) :: grid - ! Flush and close output files. - if(grid%HIFREQ_unit>0) then - flush(grid%HIFREQ_unit) - close(grid%HIFREQ_unit) - endif - if(grid%PATCF_unit>0) then - flush(grid%PATCF_unit) - close(grid%PATCF_unit) - endif - end subroutine tracker_close - - subroutine tracker_init(grid) - ! Initialize tracker variables in the grid structure. - - implicit none - integer :: i,ifile,iunit,j - type(solver_internal_state), intent(inout) :: grid - - integer :: IMS,IME,JMS,JME - - ims=grid%ims ; jms=grid%jms - ime=grid%ime ; jme=grid%jme - - if(.not.grid%restart)then - !grid%ntrack=1 ! 1=move every nphys, 2=every other nphys, etc. - grid%track_last_hour=0 - grid%track_edge_dist=0 - - grid%track_stderr_m1=-99.9 - grid%track_stderr_m2=-99.9 - grid%track_stderr_m3=-99.9 - grid%track_n_old=0 - grid%track_old_lon=0 - grid%track_old_lat=0 - grid%track_old_ntsd=0 - - grid%tracker_angle=0 - grid%tracker_distsq=0 - grid%tracker_fixlon=-999.0 - grid%tracker_fixlat=-999.0 - grid%tracker_ifix=-99 - grid%tracker_jfix=-99 - grid%tracker_havefix=0 - grid%tracker_gave_up=0 - grid%tracker_pmin=-99999. - grid%tracker_vmax=-99. - grid%tracker_rmw=-99. - - grid%track_have_guess=0 - grid%track_guess_lat=-999.0 - grid%track_guess_lon=-999.0 - -! grid%vortex_tracker=7 ! Do not change. - - do j=jms,jme - do i=ims,ime - grid%m10rv(i,j)=0. - grid%m10wind(i,j)=0. -! - grid%sm10rv(i,j)=0. - grid%sm10wind(i,j)=0. - grid%smslp(i,j)=0. - grid%membrane_mslp(i,j)=0. -! - grid%sp700rv(i,j)=0. - grid%sp700wind(i,j)=0. - grid%sp700z(i,j)=0. - grid%sp850rv(i,j)=0. - grid%sp850wind(i,j)=0. - grid%sp850z(i,j)=0. -! - grid%p500u(i,j)=0. - grid%p500v(i,j)=0. - grid%p700u(i,j)=0. - grid%p700v(i,j)=0. - grid%p700rv(i,j)=0. - grid%p700wind(i,j)=0. - grid%p700z(i,j)=0. - grid%p850u(i,j)=0. - grid%p850v(i,j)=0. - grid%p850rv(i,j)=0. - grid%p850wind(i,j)=0. - grid%p850z(i,j)=0. - enddo - enddo - - endif - - call tracker_open_append(grid%hifreq_file,grid%hifreq_unit) - if(grid%hifreq_unit==0) then - call tracker_message('HIFREQ is disabled (no filename)') - elseif(grid%hifreq_unit<0) then - call tracker_abort('No units available for HIFREQ file.') - endif - call tracker_open_append(grid%patcf_file,grid%patcf_unit) - if(grid%patcf_unit==0) then - call tracker_message('PATCF is disabled (no filename)') - elseif(grid%patcf_unit<0) then - call tracker_abort('No units available for PATCF file.') - endif - end subroutine tracker_init - - subroutine tracker_open_append(filename,unit) - integer, intent(inout) :: unit - character(len=*), intent(in) :: filename - integer :: n - logical :: opened - if(trim(filename) == trim(' ')) then - unit=0 ! Return 0 if filename is unspecified. - return - endif - do n=51,99 - INQUIRE(n,opened=opened) - if(.not.opened) then - open(unit=n,file=trim(filename),form='formatted',position='append') - unit=n - return - endif - enddo - unit=-99 - end subroutine tracker_open_append - - subroutine hifreq_step(grid) - type(solver_internal_state), intent(inout) :: grid - if(grid%hifreq_unit>0) & - call tracker_abort('HIFREQ is not supported yet. Aborting.') - end subroutine hifreq_step - - subroutine tracker_center(grid) - ! Top-level entry to the inline ncep tracker. Finds the center of - ! the storm in the specified grid and updates the grid variables. - ! Will do nothing and return immediately if - ! grid%tracker_gave_up=.true. - implicit none - type(solver_internal_state), intent(inout) :: grid - character*255 :: message - - integer :: IDS,IDE,JDS,JDE,KDS,KDE - integer :: IMS,IME,JMS,JME,KMS,KME - integer :: IPS,IPE,JPS,JPE,KPS,KPE - - ids=grid%ids ; jds=grid%jds ; kds=1 - ide=grid%ide ; jde=grid%jde ; kde=grid%LM - ims=grid%ims ; jms=grid%jms ; kms=1 - ime=grid%ime ; jme=grid%jme ; kme=grid%LM - ips=grid%its ; jps=grid%jts ; kps=1 - ipe=grid%ite ; jpe=grid%jte ; kpe=grid%LM - - if(grid%MYPE==0) then - tracker_debug_level=0 ! 0=only tracker_message() - else - tracker_debug_level=-1 ! -1=no messages - endif - tracker_diagnostics=.true. - - call ntc_impl(grid, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - ips, ipe, jps, jpe, kps, kpe ) - end subroutine tracker_center - - subroutine ntc_impl(grid, & - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - IPS,IPE,JPS,JPE,KPS,KPE) - ! This is the main entry point to the tracker. It is most similar - ! to the function "tracker" in the GFDL/NCEP vortex tracker. - implicit none - type(solver_internal_state), intent(inout) :: grid - integer, intent(in) :: IDS,IDE,JDS,JDE,KDS,KDE - integer, intent(in) :: IMS,IME,JMS,JME,KMS,KME - integer, intent(in) :: IPS,IPE,JPS,JPE,KPS,KPE - - real :: dxdymean, sum - integer :: i,j, iweights,ip - - - integer :: iguess, jguess ! first guess location - real :: latguess, longuess ! same, but in lat & lon - - integer :: iuvguess, juvguess ! "second guess" location using everything except wind maxima - real :: srsq - integer :: ifinal,jfinal - real :: latfinal,lonfinal - integer :: ierr - integer :: icen(maxtp), jcen(maxtp) ! center locations for each parameter - real :: loncen(maxtp), latcen(maxtp) ! lat, lon locations in degrees - logical :: calcparm(maxtp) ! do we have a valid center location for this parameter? - real :: max_wind,min_pres ! for ATCF output - real :: rcen(maxtp) ! center value (max wind, min mslp, etc.) - character*255 :: message - logical :: north_hemi ! true = northern hemisphere - logical :: have_guess ! first guess is available - real :: guessdist,guessdeg ! first guess distance to nearest point on grid - real :: latnear, lonnear ! nearest point in grid to first guess - character(len=31) :: strparm(maxtp) - strparm(:) = 'Not currently used' - - ! icen,jcen: Same meaning as clon, clat in tracker, but uses i and - ! j indexes of the center instead of lat/lon. Tracker comment: - ! Holds the coordinates for the center positions for - ! all storms at all times for all parameters. - ! (max_#_storms, max_fcst_times, max_#_parms). - ! For the third position (max_#_parms), here they are: - strparm (1)='Relative vorticity at 850 mb' - strparm (2)='Relative vorticity at 700 mb' - strparm (3)='Vector wind magnitude at 850 mb' - strparm (4)='Not currently used' - strparm (5)='Vector wind magnitude at 700 mb' - strparm (6)='Not currently used' - strparm (7)='Geopotential height at 850 mb' - strparm (8)='Geopotential height at 700 mb' - strparm (9)='Mean Sea Level Pressure' - strparm (10)='Vector wind magnitude at 10 m' - strparm (11)='Relative vorticity at 10 m' - - call tracker_debug(1,'tracker_center') - - ! Initialize center information to invalid values for all centers: - icen=-99 - jcen=-99 - latcen=9e9 - loncen=9e9 - rcen=9e9 - calcparm=.false. - srsq=searchrad_7*searchrad_7*1e6 - - ! Get the first guess from the prior nest motion timestep: - have_guess=grid%track_have_guess/=0 - if(have_guess) then - ! We have a first guess center. We have to translate it to gridpoint space. - call tracker_message('First guess is available. Will translate to gridpoint space.') - longuess=grid%track_guess_lon - latguess=grid%track_guess_lat - call get_nearest_lonlat(grid,iguess,jguess,ierr,longuess,latguess, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - ips,ipe, jps,jpe, kps,kpe, lonnear, latnear) - if(ierr==0) then - call calcdist(longuess,latguess, lonnear,latnear, guessdist,guessdeg) - if(guessdist*1e3>3*grid%DYH) then -108 format('WARNING: guess lon=',F0.3,',lat=',F0.3, & - ' too far (',F0.3,'km) from nearest point lon=',F0.3,',lat=',F0.3, & - '. Will use domain center as first guess.') - write(message,108) grid%track_guess_lon,grid%track_guess_lat, & - guessdist,lonnear,latnear - call tracker_message(message) - have_guess=.false. ! indicate that the first guess is unusable - else - latguess=latnear - longuess=lonnear - endif - else - have_guess=.false. ! indicate that the first guess is unusable. -109 format('WARNING: guess lon=',F0.3,',lat=',F0.3, & - ' does not exist in this domain. Will use domain center as first guess.') - write(message,109) grid%track_guess_lon,grid%track_guess_lat - call tracker_message(message) - endif - endif - - ! If we could not get the first guess from the prior nest motion - ! timestep, then use the default first guess: the domain center. - if(.not.have_guess) then - ! vt=6: hard coded first-guess center is domain center: - ! vt=7: first guess comes from prior timestep - ! Initial first guess is domain center. - ! Backup first guess is domain center if first guess is unusable. - iguess=ide/2 - jguess=jde/2 - call tracker_message('Using domain center as first guess since no valid first guess is available.') - call get_lonlat(grid,iguess,jguess,longuess,latguess,ierr, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - ips,ipe, jps,jpe, kps,kpe) - if(ierr/=0) then - call tracker_abort("ERROR: center of domain is not inside the domain") - else - write(message,308) iguess,jguess,latguess,longuess - call tracker_debug(1,message) -308 format('Center of domain is at ',I0,',',I0,' = ',F0.3,'N ',F0.3,'E') - endif - have_guess=.true. - endif - - if(.not.have_guess) then - call tracker_abort("INTERNAL ERROR: No first guess is available (should never happen).") - else - write(message,410) grid%NTSD,iguess,jguess,latguess,longuess -410 format('At timestep ',I0,', first guess center is at ',I0,',',I0,' = ',F0.3,'N ',F0.3,'E') - call tracker_message(message) - endif - - north_hemi = latguess>0.0 - - ! Get the mean V-to-H point-to-point distance: - dxdymean = 0.5*(grid%DYH + sum(grid%DXH)/( (ide-ids) * (jde-jds) )) & - /1000.0 - - ! Find the centers of all fields except the wind minima: - call find_center(grid,grid%p850rv,grid%sp850rv,srsq, & - icen(1),jcen(1),rcen(1),calcparm(1),loncen(1),latcen(1),dxdymean,'zeta', & - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - IPS,IPE,JPS,JPE,KPS,KPE, north_hemi=north_hemi) - call find_center(grid,grid%p700rv,grid%sp700rv,srsq, & - icen(2),jcen(2),rcen(2),calcparm(2),loncen(2),latcen(2),dxdymean,'zeta', & - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - IPS,IPE,JPS,JPE,KPS,KPE, north_hemi=north_hemi) - call find_center(grid,grid%p850z,grid%sp850z,srsq, & - icen(7),jcen(7),rcen(7),calcparm(7),loncen(7),latcen(7),dxdymean,'hgt', & - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - IPS,IPE,JPS,JPE,KPS,KPE) - call find_center(grid,grid%p700z,grid%sp700z,srsq, & - icen(8),jcen(8),rcen(8),calcparm(8),loncen(8),latcen(8),dxdymean,'hgt', & - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - IPS,IPE,JPS,JPE,KPS,KPE) - call find_center(grid,grid%membrane_mslp,grid%smslp,srsq, & - icen(9),jcen(9),rcen(9),calcparm(9),loncen(9),latcen(9),dxdymean,'slp', & - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - IPS,IPE,JPS,JPE,KPS,KPE) - call find_center(grid,grid%m10rv,grid%sm10rv,srsq, & - icen(11),jcen(11),rcen(11),calcparm(11),loncen(11),latcen(11),dxdymean,'zeta', & - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - IPS,IPE,JPS,JPE,KPS,KPE, north_hemi=north_hemi) - - ! Get a guess center location for the wind minimum searches: - call get_uv_guess(grid,icen,jcen,loncen,latcen,calcparm, & - iguess,jguess,longuess,latguess,iuvguess,juvguess, & - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - IPS,IPE,JPS,JPE,KPS,KPE) - - ! Find wind minima. Requires a first guess center: - call get_uv_center(grid,grid%p850wind, & - icen(3),jcen(3),rcen(3),calcparm(3),loncen(3),latcen(3),dxdymean,'wind', & - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - IPS,IPE,JPS,JPE,KPS,KPE, & - iuvguess=iuvguess, juvguess=juvguess) - call get_uv_center(grid,grid%p700wind, & - icen(5),jcen(5),rcen(5),calcparm(5),loncen(5),latcen(5),dxdymean,'wind', & - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - IPS,IPE,JPS,JPE,KPS,KPE, & - iuvguess=iuvguess, juvguess=juvguess) - call get_uv_center(grid,grid%m10wind, & - icen(10),jcen(10),rcen(10),calcparm(10),loncen(10),latcen(10),dxdymean,'wind', & - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - IPS,IPE,JPS,JPE,KPS,KPE, & - iuvguess=iuvguess, juvguess=juvguess) - - print_fixes: if(tracker_diagnostics) then - do i=1,maxtp - if(i==4 .or. i==6) then ! Don't print non-fixes for unused fields. -3837 format("Fix ",I0," (",A,")") - write(message,3837) i,strparm(i) - elseif(i==1 .or. i==2 .or. i==11) then ! high precision for vorticity -3839 format("Fix ",I0," (",A,"): at (",I0,',',I0,') = ',F0.3,'N ',F0.3,'E calc=',I0,' value=',F0.7) - write(message,3839) i,strparm(i),icen(i),jcen(i),latcen(i),loncen(i),merge(1,0,calcparm(i)),rcen(i) - - else ! Print lower precision for other fields -3838 format("Fix ",I0," (",A,"): at (",I0,',',I0,') = ',F0.3,'N ',F0.3,'E calc=',I0,' value=',F0.3) - write(message,3838) i,strparm(i),icen(i),jcen(i),latcen(i),loncen(i),merge(1,0,calcparm(i)),rcen(i) - endif - call tracker_message(message) - enddo - endif print_fixes - - ! Get a final guess center location: - call fixcenter(grid,icen,jcen,calcparm,loncen,latcen, & - iguess,jguess,longuess,latguess, & - ifinal,jfinal,lonfinal,latfinal, & - north_hemi, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - ips,ipe, jps,jpe, kps,kpe) - - grid%tracker_fixes=0 - do ip=1,maxtp - if(calcparm(ip)) then -300 format('Parameter ',I0,': i=',I0,' j=',I0,' lon=',F0.2,' lat=',F0.2) - !write(0,300) ip,icen(ip),jcen(ip),loncen(ip),latcen(ip) - if(icen(ip)>=ips .and. icen(ip)<=ipe & - .and. jcen(ip)>=jps .and. jcen(ip)<=jpe) then - grid%tracker_fixes(icen(ip),jcen(ip))=ip - endif - else -301 format('Parameter ',I0,' invalid') - !write(0,301) ip - endif - enddo - - if(iguess>=ips .and. iguess<=ipe .and. jguess>=jps .and. jguess<=jpe) then - grid%tracker_fixes(iguess,jguess)=-1 -201 format('First guess: i=',I0,' j=',I0,' lon=',F0.2,' lat=',F0.2) - !write(0,201) iguess,jguess,longuess,latguess - endif - - if(iuvguess>=ips .and. iuvguess<=ipe .and. juvguess>=jps .and. juvguess<=jpe) then - grid%tracker_fixes(iuvguess,juvguess)=-2 -202 format('UV guess: i=',I0,' j=',I0) - !write(0,202) iguess,jguess - endif - -1000 format('Back with final lat/lon at i=',I0,' j=',I0,' lon=',F0.3,' lat=',F0.3) - !write(0,1000) ifinal,jfinal,lonfinal,latfinal - - if(ifinal>=ips .and. ifinal<=ipe .and. jfinal>=jps .and. jfinal<=jpe) then - grid%tracker_fixes(ifinal,jfinal)=-3 -203 format('Final fix: i=',I0,' j=',I0,' lon=',F0.2,' lat=',F0.2) - !write(0,201) ifinal,jfinal,lonfinal,latfinal - endif - - call get_tracker_distsq(grid, & - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - IPS,IPE,JPS,JPE,KPS,KPE) - - call get_wind_pres_intensity(grid, & - grid%tracker_pmin,grid%tracker_vmax,grid%tracker_rmw, & - max_wind_search_radius, min_mlsp_search_radius, & - lonfinal,latfinal, & - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - IPS,IPE,JPS,JPE,KPS,KPE) - - if(grid%MYPE==0 .and. tracker_diagnostics) then - call output_partial_atcfunix(grid, & - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - IPS,IPE,JPS,JPE,KPS,KPE) - endif - - call get_first_ges(grid,iguess,jguess,longuess,latguess, & - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - IPS,IPE,JPS,JPE,KPS,KPE) - call store_old_fixes(grid, & - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - IPS,IPE,JPS,JPE,KPS,KPE) - - ! Store the first guess: - grid%track_have_guess=1 - grid%track_guess_lat=latguess - grid%track_guess_lon=longuess -3011 format('First guess: lon=',F0.3,' lat=',F0.3) - write(message,3011) grid%track_guess_lon,grid%track_guess_lat - call tracker_message(message) - - end subroutine ntc_impl - - subroutine get_first_ges(grid, & - iguess,jguess,longuess,latguess, & - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - IPS,IPE,JPS,JPE,KPS,KPE) - ! This replicates the functionality of the tracker get_first_ges - ! routine, whose purpose is to analyze the storm and guess where - ! it will be at the next nest motion timestep. It does that using - ! two different methods, similar to the GFDL/NCEP Tracker's - ! methods: - ! - ! 1. Use the present, and past few, fix locations and extrapolate - ! to the next location. - ! - ! 2. Calculate the mean motion and extrapolate to get the - ! location at the next nest motion timestep. - ! - ! The average of the two results is used. - - implicit none - type(solver_internal_state), intent(inout) :: grid - integer, intent(in) :: IDS,IDE,JDS,JDE,KDS,KDE - integer, intent(in) :: IMS,IME,JMS,JME,KMS,KME - integer, intent(in) :: IPS,IPE,JPS,JPE,KPS,KPE - integer, intent(out) :: iguess,jguess - real, intent(out) :: longuess,latguess - - character*255 message - integer :: iold, inew, jold, jnew - integer :: ifix,jfix,jrot,irot,ierr, pinky,brain, n, tsum, ntsd_plus_1, i, told - real :: motion_grideast, motion_gridnorth, fixdx - real :: dxeast,dynorth, xeast, ynorth - real :: dxrot, dyrot, tracker_dt, xsum, ysum, ytsum, xtsum, xxsum, yysum, ttsum - real :: mx, my, bx, by ! x=mx*t+bx ; y=my*t+by - real :: xrot,yrot - logical :: have_motion_guess, have_line_guess - - have_motion_guess=.false. - have_line_guess=.false. - - if(grid%tracker_havefix/=0) then - ifix=grid%tracker_ifix - jfix=grid%tracker_jfix - - call mean_motion(grid, motion_grideast, motion_gridnorth, & - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - IPS,IPE,JPS,JPE,KPS,KPE) - - fixdx=0 - if(ifix>=ips .and. ifix<=ipe .and. jfix>=jps .and. jfix<=jpe) then - fixdx=grid%DXH(jfix) - endif - call max_real(grid,fixdx) - - ! Rotated east and north motion in gridpoints per second, on the combined H+V grid: - tracker_dt=grid%dt*grid%nphs*grid%ntrack - dxeast = motion_grideast * tracker_dt / fixdx - dynorth = motion_gridnorth * tracker_dt / grid%DYH - iguess=ifix+dxeast - jguess=jfix+dynorth - - ! Abort motion if the storm leaves the grid. This can happen - ! if a moving domain approaches a stationary domain boundary. - have_motion_guess = .not.(iguesside*3/4 .or. jguessjde*3/4) - write(message,*)'got have_motion_guess=',have_motion_guess - call tracker_debug(1,message) - endif - - if(.not.have_motion_guess) then - ! Could not find the storm, so give the domain center as the - ! next first guess location. - iguess=ide/2 - jguess=jde/2 - call tracker_message('Cannot find storm, so using domain center for motion guess.') - endif - - if(grid%track_n_old>0) then - call tracker_debug(1,'Line guess: have old.') - n=1 - xrot=grid%tracker_ifix - yrot=grid%tracker_jfix - xsum=xrot - ysum=yrot - tsum=grid%ntsd ! Bug in wrf original: should be grid%nphys*grid%ntrack - xtsum=xsum*tsum - xxsum=xsum*xsum - yysum=ysum*ysum - ytsum=ysum*tsum - ttsum=tsum*tsum - - do i=1,grid%track_n_old - call get_nearest_lonlat(grid,iold,jold,ierr, & - grid%track_old_lon(i),grid%track_old_lat(i), & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - ips,ipe, jps,jpe, kps,kpe) - if(ierr==0) then - !write(message,*) 'insert: i=',iold,' j=',jold,' lon=',grid%track_old_lon(i),' lat=',grid%track_old_lat(i),' t=',grid%track_old_ntsd(i) - !call tracker_debug(1,message) - n=n+1 - xrot=iold - yrot=jold - xsum=xsum+xrot - ysum=ysum+yrot - told=grid%track_old_ntsd(i) - tsum=tsum+told - xtsum=xtsum+xrot*told - xxsum=xxsum+xrot*xrot - ytsum=ytsum+yrot*told - yysum=xxsum+yrot*yrot - ttsum=ttsum+told*told - endif - enddo - !write(message,*) 'line guess: n=',n - !call tracker_debug(1,message) - - if(n>1) then - ntsd_plus_1 = grid%ntsd + grid%ntrack*grid%nphs - mx=(xtsum-(xsum*tsum)/real(n))/(ttsum-(tsum*tsum)/real(n)) - my=(ytsum-(ysum*tsum)/real(n))/(ttsum-(tsum*tsum)/real(n)) - bx=(xsum-mx*tsum)/real(n) - by=(ysum-my*tsum)/real(n) - !write(message,*) 'mx=',mx,' my=',my,' bx=',bx,' by=',by,' t+1=',ntsd_plus_1 - !call tracker_debug(1,message) - xrot=nint(mx*ntsd_plus_1+bx) - yrot=nint(my*ntsd_plus_1+by) - inew=xrot - jnew=yrot - !write(message,*) 'inew=',inew,' jnew=',jnew,' xrot=',xrot,' yrot=',yrot - !call tracker_debug(1,message) - have_line_guess=.not.(inewide*3/4 & - .or. jnewjde*3/4) - else - have_line_guess=.false. - endif - endif - - print_locs: if(tracker_diagnostics) then - call get_lonlat(grid,iguess,jguess,longuess,latguess,ierr, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - ips,ipe, jps,jpe, kps,kpe) - if(ierr==0) then - if(have_motion_guess) then -3088 format('Motion Guess: lon=',F0.3,' lat=',F0.3) - write(message,3088) longuess,latguess - call tracker_message(message) - else -3089 format('Motion Guess failed; use domain center: lon=',F0.3,' lat=',F0.3) - write(message,3089) longuess,latguess - call tracker_message(message) - endif - else -3090 format('Motion guess failed: guess is not in domain (ierr=',I0,')') - write(message,3090) ierr - call tracker_message(message) - endif - if(have_line_guess) then - call get_lonlat(grid,inew,jnew,longuess,latguess,ierr, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - ips,ipe, jps,jpe, kps,kpe) - if(ierr==0) then -3091 format('Line guess: lon=',F0.3,' lat=',F0.3) - write(message,3091) longuess,latguess - call tracker_message(message) - else -3092 format('Line guess failed: guess is not in domain (ierr=',I0,')') - write(message,3092) ierr - call tracker_message(message) - endif - endif - end if print_locs - - if(have_line_guess) then - if(have_motion_guess) then - if(tracker_diagnostics) & - call tracker_message('get_first_ges: have MOTION and LINE guesses') - iguess=(iguess+inew)/2 - jguess=(jguess+jnew)/2 - else - if(tracker_diagnostics) & - call tracker_message('get_first_ges: have LINE guess only') - iguess=inew - jguess=jnew - endif - elseif(have_motion_guess) then - if(tracker_diagnostics) & - call tracker_message('get_first_ges: have MOTION guess only') - else - if(tracker_diagnostics) & - call tracker_message('get_first_ges: have no guesses; will use domain center') - endif - - ! Now get lats & lons: - latguess=-999.9 - longuess=-999.9 - ierr=-999 - call get_lonlat(grid,iguess,jguess,longuess,latguess,ierr, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - ips,ipe, jps,jpe, kps,kpe) - if(ierr/=0) then - ! Should never get here due to max/min check before. - call tracker_abort("ERROR: domain is not inside the domain in get_first_ges (!?)") - endif - -38 format('First guess: i=',I0,' j=',I0,' lat=',F8.3,' lon=',F8.3) - write(message,38) iguess,jguess,latguess,longuess - call tracker_message(message) - end subroutine get_first_ges - - subroutine store_old_fixes(grid, & - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - IPS,IPE,JPS,JPE,KPS,KPE) - ! This stores old fix locations for later use in the get_first_ges - ! routine's line of best fit. - implicit none - type(solver_internal_state), intent(inout) :: grid - integer, intent(in) :: IDS,IDE,JDS,JDE,KDS,KDE - integer, intent(in) :: IMS,IME,JMS,JME,KMS,KME - integer, intent(in) :: IPS,IPE,JPS,JPE,KPS,KPE - integer i - character*(255) message - if(grid%tracker_havefix/=0) then - call tracker_message('Storing fix location in track_old_* vars.') - if(grid%track_n_old>0) then - call tracker_debug(1,'in store old, shifting old') - do i=1,track_max_old-1 - grid%track_old_lon(i+1)=grid%track_old_lon(i) - grid%track_old_lat(i+1)=grid%track_old_lat(i) - grid%track_old_ntsd(i+1)=grid%track_old_ntsd(i) - enddo - endif - grid%track_old_lon(1)=grid%tracker_fixlon - grid%track_old_lat(1)=grid%tracker_fixlat - grid%track_old_ntsd(1)=grid%ntsd - grid%track_n_old=min(track_max_old,grid%track_n_old+1) - write(message,*) 'in store old, now have ',grid%track_n_old - call tracker_debug(1,message) - else - call tracker_message('No fix location to store.') - endif - end subroutine store_old_fixes - - subroutine get_nearest_lonlat(grid,iloc,jloc,ierr,lon,lat, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - ips,ipe, jps,jpe, kps,kpe, & - lonnear, latnear) - ! Finds the nearest point in the domain to the specified lon,lat - ! location. - implicit none - type(solver_internal_state), intent(inout) :: grid - integer, intent(in) :: IDS,IDE,JDS,JDE,KDS,KDE - integer, intent(in) :: IMS,IME,JMS,JME,KMS,KME - integer, intent(in) :: IPS,IPE,JPS,JPE,KPS,KPE - integer, intent(out) :: iloc,jloc,ierr - real, intent(in) :: lon,lat - real :: dx,dy,d,dmin, zdummy, latmin,lonmin - integer :: i,j,imin,jmin - real, intent(out), optional :: latnear, lonnear - - zdummy=42 - dmin=9e9 - imin=-99 - jmin=-99 - latmin=9e9 - lonmin=9e9 - ierr=0 - do j=jps,jpe - do i=ips,ipe - dy=abs(lat-grid%glat(i,j)/pi180) - dx=abs(mod(3600.+180.+(lon-grid%glon(i,j)/pi180),360.)-180.) - d=dx*dx+dy*dy - if(d0) then - ! Write to file if one is specified. - write(grid%patcf_unit,313) grid%dt*grid%ntsd, & - grid%tracker_vmax*mps2kn,grid%tracker_pmin/100., & - abs(grid%tracker_fixlat),get_lat_ns(grid%tracker_fixlat), & - abs(grid%tracker_fixlon),get_lon_ew(grid%tracker_fixlon), & - grid%tracker_rmw*km2nmi - else - ! Write to stdout if no file is specified for PATCF. - write(message,313) grid%dt*grid%ntsd, & - grid%tracker_vmax*mps2kn,grid%tracker_pmin/100., & - abs(grid%tracker_fixlat),get_lat_ns(grid%tracker_fixlat), & - abs(grid%tracker_fixlon),get_lon_ew(grid%tracker_fixlon), & - grid%tracker_rmw*km2nmi - call tracker_message(message) - endif - ! write(message,313) grid%dt*grid%ntsd, & - ! grid%tracker_vmax*mps2kn,grid%tracker_pmin/100., & - ! abs(grid%tracker_fixlat),get_lat_ns(grid%tracker_fixlat), & - ! abs(grid%tracker_fixlon),get_lon_ew(grid%tracker_fixlon), & - ! grid%tracker_rmw*km2nmi - ! call tracker_message(message) - end subroutine output_partial_atcfunix - - subroutine get_wind_pres_intensity(grid, & - min_mslp,max_wind,rmw, & - max_wind_search_radius, min_mlsp_search_radius, clon,clat, & - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - ITS,ITE,JTS,JTE,KTS,KTE) - ! This determines the maximum wind, RMW and minimum mslp in the domain. - implicit none - type(solver_internal_state), intent(inout) :: grid - real, intent(out) :: min_mslp,max_wind,rmw - real, intent(in) :: max_wind_search_radius, min_mlsp_search_radius,clon,clat - integer, intent(in) :: IDS,IDE,JDS,JDE,KDS,KDE - integer, intent(in) :: IMS,IME,JMS,JME,KMS,KME - integer, intent(in) :: ITS,ITE,JTS,JTE,KTS,KTE - - real :: localextreme,globalextreme, sdistsq,windsq - real :: globallat,globallon,degrees - integer :: locali,localj,globali,globalj,ierr,i,j - - ! Get the MSLP minimum location and determine if what we found is - ! still a storm: - localextreme=9e9 - locali=-1 - localj=-1 - sdistsq=min_mlsp_search_radius*min_mlsp_search_radius*1e6 - do j=jts,jte - do i=its,ite - if(grid%membrane_mslp(i,j)localextreme) then - localextreme=windsq - locali=i - localj=j - endif - endif - enddo - enddo - if(localextreme>0) localextreme=sqrt(localextreme) - - globalextreme=localextreme - globali=locali - globalj=localj - call maxloc_real(grid,globalextreme,globali,globalj) - - call get_lonlat(grid,globali,globalj,globallon,globallat,ierr, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - if(ierr/=0) then - call tracker_message("WARNING: Unable to find location of wind maximum.") - rmw=-99 - else - call calcdist(clon,clat,globallon,globallat,rmw,degrees) - end if - - ! Get the guess location for the next time: - max_wind=globalextreme - if(globali<0 .or. globalj<0) then - call tracker_message("WARNING: No wind values found that were greater than -9*10^9.") - min_mslp=-999 - endif - - end subroutine get_wind_pres_intensity - - subroutine mean_motion(grid,motion_grideast,motion_gridnorth, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - ! This calculates the mean motion of the storm by calculating the - ! average wind vector at 850, 700 and 500 mbars. - use mpi - implicit none - integer, intent(in) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - type(solver_internal_state), intent(in) :: grid - real, intent(out) :: motion_grideast,motion_gridnorth - integer :: count,i,j,ierr - real :: distsq, dist - double precision :: e,n, inreduce(3),outreduce(3) - double precision, parameter :: zero=0 - character(len=255) :: message - - e=0 ; n=0 ; count=0 ! east sum, north sum, count - - dist = min(grid%track_edge_dist, max(50e3, 3e3*grid%tracker_rmw)) - distsq = dist * dist - - write(message,*) 'motion search radius (m) = ',dist - call tracker_debug(2,message) - write(message,*) ' considered edge dist = ',grid%track_edge_dist - call tracker_debug(2,message) - write(message,*) ' considered 3e3*rmw = ',3e3*grid%tracker_rmw - call tracker_debug(2,message) - call tracker_debug(2,' considered 50e3.') - - do j=jts,jte - do i=its,ite - if(grid%tracker_distsq(i,j) 2 .and. ip < 7) .or. ip == 10) then - cycle ! because 3-6 are for 850 & 700 u & v and 10 is - ! for surface wind magnitude. - elseif(calcparm(ip)) then - call calcdist (longuess,latguess,loncen(ip),latcen(ip),dist,degrees) - if(dist90.) then - ylat1=180.-ylat1 - xlon1=mod(xlon1+360.,360.)-180. - elseif(ylat1<-90.) then - ylat1=-180. - ylat1 - xlon1=mod(xlon1+360.,360.)-180. - endif - end subroutine clean_lon_lat - - subroutine calcdist(rlonb,rlatb,rlonc,rlatc,xdist,degrees) - ! Copied from gettrk_main.f - ! - ! ABSTRACT: This subroutine computes the distance between two - ! lat/lon points by using spherical coordinates to - ! calculate the great circle distance between the points. - ! Figure out the angle (a) between pt.B and pt.C, - ! N. Pole then figure out how much of a % of a great - ! x circle distance that angle represents. - ! / \ - ! b/ \ cos(a) = (cos b)(cos c) + (sin b)(sin c)(cos A) - ! / \ . - ! pt./<--A-->\c NOTE: The latitude arguments passed to the - ! B / \ subr are the actual lat vals, but in - ! \ the calculation we use 90-lat. - ! a \ . - ! \pt. NOTE: You may get strange results if you: - ! C (1) use positive values for SH lats AND - ! you try computing distances across the - ! equator, or (2) use lon values of 0 to - ! -180 for WH lons AND you try computing - ! distances across the 180E meridian. - ! - ! NOTE: In the diagram above, (a) is the angle between pt. B and - ! pt. C (with pt. x as the vertex), and (A) is the difference in - ! longitude (in degrees, absolute value) between pt. B and pt. C. - ! - ! !!! NOTE !!! -- THE PARAMETER ecircum IS DEFINED (AS OF THE - ! ORIGINAL WRITING OF THIS SYSTEM) IN KM, NOT M, SO BE AWARE THAT - ! THE DISTANCE RETURNED FROM THIS SUBROUTINE IS ALSO IN KM. - ! - implicit none - - real, intent(inout) :: degrees - real, intent(out) :: xdist - real, intent(in) :: rlonb,rlatb,rlonc,rlatc - real, parameter :: dtr = 0.0174532925199433 - real :: distlatb,distlatc,pole,difflon,cosanga,circ_fract - ! - if (rlatb < 0.0 .or. rlatc < 0.0) then - pole = -90. - else - pole = 90. - endif - ! - distlatb = (pole - rlatb) * dtr - distlatc = (pole - rlatc) * dtr - difflon = abs( (rlonb - rlonc)*dtr ) - ! - cosanga = ( cos(distlatb) * cos(distlatc) + & - sin(distlatb) * sin(distlatc) * cos(difflon)) - - ! This next check of cosanga is needed since I have had ACOS crash - ! when calculating the distance between 2 identical points (should - ! = 0), but the input for ACOS was just slightly over 1 - ! (e.g., 1.00000000007), due to (I'm guessing) rounding errors. - - if (cosanga > 1.0) then - cosanga = 1.0 - endif - - degrees = acos(cosanga) / dtr - circ_fract = degrees / 360. - xdist = circ_fract * ecircum - ! - ! NOTE: whether this subroutine returns the value of the distance - ! in km or m depends on the scale of the parameter ecircum. - ! At the original writing of this subroutine (7/97), ecircum - ! was given in km. - ! - return - end subroutine calcdist - - subroutine get_lonlat(grid,iguess,jguess,longuess,latguess,ierr, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - ips,ipe, jps,jpe, kps,kpe) - ! Returns the latitude (latguess) and longitude (longuess) of the - ! specified location (iguess,jguess) in the specified grid. - implicit none - integer, intent(in) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - ips,ipe, jps,jpe, kps,kpe - integer, intent(out) :: ierr - type(solver_internal_state), intent(inout) :: grid - integer, intent(in) :: iguess,jguess - real, intent(inout) :: longuess,latguess - real :: weight,zjunk - integer :: itemp,jtemp - - ierr=0 - zjunk=1 - if(iguess>=ips .and. iguess<=ipe .and. jguess>=jps .and. jguess<=jpe) then - weight=1 - longuess=grid%glon(iguess,jguess)/pi180 - latguess=grid%glat(iguess,jguess)/pi180 - itemp=iguess - jtemp=jguess -!308 format(A,' weight ',F0.1,' at ',F0.2,'N ',F0.2,'E at ',I0,',',I0) -! write(0,308) 'Local',weight,latguess,longuess,iguess,jguess - else - weight=0 - longuess=-999.9 - latguess=-999.9 - itemp=-99 - jtemp=-99 - endif - - call maxloc_real(grid,weight,latguess,longuess,zjunk,itemp,jtemp) -! if(grid%mype==0) & -! write(0,308) 'Global',weight,latguess,longuess,iguess,jguess - - if(itemp==-99 .and. jtemp==-99) then - ierr=95 - endif - end subroutine get_lonlat - - subroutine update_tracker_post_move(grid) - ! This updates the tracker i/j fix location and square of the - ! distance to the tracker center after a nest move. - type(solver_internal_state), intent(inout) :: grid - integer :: ierr, & - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - IPS,IPE,JPS,JPE,KPS,KPE - - if(grid%MYPE==0) then - tracker_debug_level=0 ! 0=only tracker_message() - else - tracker_debug_level=-1 ! -1=no messages - endif - tracker_diagnostics=.true. - - ! Get the grid bounds: - ids=grid%ids ; jds=grid%jds ; kds=1 - ide=grid%ide ; jde=grid%jde ; kde=grid%LM - ims=grid%ims ; jms=grid%jms ; kms=1 - ime=grid%ime ; jme=grid%jme ; kme=grid%LM - ips=grid%its ; jps=grid%jts ; kps=1 - ipe=grid%ite ; jpe=grid%jte ; kpe=grid%LM - - ! Get the i/j center location from the fix location: - ierr=0 - call get_nearest_lonlat(grid,grid%tracker_ifix,grid%tracker_jfix, & - ierr,grid%tracker_fixlon,grid%tracker_fixlat, & - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - IPS,IPE,JPS,JPE,KPS,KPE) - - ! Get the square of the approximate distance to the tracker center - ! at all points: - if(ierr==0) & - call get_tracker_distsq(grid, & - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - IPS,IPE,JPS,JPE,KPS,KPE) - end subroutine update_tracker_post_move -end module module_tracker diff --git a/src/nmm/module_TURBULENCE.F90 b/src/nmm/module_TURBULENCE.F90 deleted file mode 100644 index ac3765d..0000000 --- a/src/nmm/module_TURBULENCE.F90 +++ /dev/null @@ -1,1470 +0,0 @@ -!----------------------------------------------------------------------- -! - MODULE MODULE_TURBULENCE -! -!----------------------------------------------------------------------- -! -!*** THE OUTER DRIVER FOR THE SFC LAYER, LSM, AND FULL 3-D TURBULENCE -!*** PLUS THE WRF TURBULENCE DRIVER AND THE VARIOUS TURBULENCE SCHEMES. -! -!----------------------------------------------------------------------- -! HISTORY LOG: -! -! 2008-07-28 Vasic - Turned off counters (now computed in -! SET_INTERNAL_STATE_PHY). -! 2009-10-26 Jovic - Remove WRF driver from TURBL -! 2010-09-10 Weiguo Wang - add GFS PBL option -! 2010-10-06 Weiguo Wang - add RSWTT, RLWTT, used by GFS PBL -! 2014-06-24 Weiguo Wang - add GFDL surface layer -! 2014-06-25 Weiguo Wang - add GFSPBL for Hurricane option -! 2016-08-29 Weiguo Wang - add GFSPBLEDMF version for Hurrican applications -!----------------------------------------------------------------------- -! - USE MODULE_KINDS -! - USE MODULE_MY_DOMAIN_SPECS -! - USE MODULE_LS_NOAHLSM - USE MODULE_LS_LISS - USE MODULE_GWD -! - USE MODULE_CONSTANTS,ONLY : CP,ELIV,ELWV,EPSQ & - ,G,P608,PI,PQ0,R_D,R_V,RHOWATER & - ,STBOLT,CAPPA & - ,EP_1,EP_2 -! - USE MODULE_CONTROL,ONLY : NMMB_FINALIZE -! - USE MODULE_SF_JSFC,ONLY : JSFC - USE MODULE_SF_GFDL,ONLY : SF_GFDL - USE MODULE_BL_MYJPBL,ONLY : MYJPBL - USE MODULE_BL_GFSPBL,ONLY : GFSPBL - USE MODULE_BL_GFSPBLHUR,ONLY : GFSPBLHUR - USE MODULE_BL_GFSPBLEDMFHUR,ONLY : GFSPBLEDMFHUR -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: TURBL - PUBLIC :: LSMSCHEME, LISSSCHEME, GFDLSLABSCHEME -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** THE TURBULENCE OPTIONS -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - INTEGER(kind=KINT),PARAMETER :: MYJPBLSCHEME=2 - INTEGER(kind=KINT),PARAMETER :: GFSPBLSCHEME=9 - INTEGER(kind=KINT),PARAMETER :: GFSPBLHURSCHEME=93 - INTEGER(kind=KINT),PARAMETER :: GFSPBLEDMFHURSCHEME=94 -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** THE SURFACE LAYER OPTIONS -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - INTEGER(kind=KINT),PARAMETER :: JSFCSCHEME=2 & - ,GFDLSFCSCHEME=88 -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** THE LANDSURFACE OPTIONS -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - INTEGER(kind=KINT),PARAMETER :: LSMSCHEME =2 & - ,LISSSCHEME =101 & - ,GFDLSLABSCHEME=0 -! -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- - SUBROUTINE TURBL(NTSD,DT,NPHS & - ,NSOIL,SLDPTH,DZSOIL & - ,DSG2,SGML2,SG2,PDSG1,PSGML1,PSG1,PT & - ,EPSL,EPSQ2 & - ,SM,CZEN,CZMEAN,SIGT4,RLWIN,RSWIN,RADOT & - ,RLWTT,RSWTT & - ,PD,T,Q,CWM,F_ICE,F_RAIN,F_RIMEF,SR & - ,Q2,U,V,DUDT,DVDT & - ,THS,TSFC,SST,PREC,SNO,SNOWC & - ,QC,QR,QI,QS,QG & - ,F_QC,F_QR,F_QI,F_QS,F_QG & - ,FIS,Z0,Z0BASE,USTAR,PBLH,LPBL,XLEN_MIX,RMOL & - ,EXCH_H,AKHS,AKMS,AKHS_OUT,AKMS_OUT & - ,THZ0,QZ0,UZ0,VZ0,QSH,MAVAIL & - ,STC,SMC,CMC,SMSTAV,SMSTOT,SSROFF,BGROFF & - ,IVGTYP,ISLTYP,VEGFRC,GRNFLX & - ,SFCEXC,ACSNOW,ACSNOM,SNOPCX,SICE,TG,SOILTB & - ,ALBASE,MXSNAL,ALBEDO,SH2O,SI,EPSR & - ,U10,V10,TH10,Q10,TSHLTR,QSHLTR,PSHLTR,PSFC_OUT & - ,T2,TWBS,QWBS,SFCSHX,SFCLHX,SFCEVP & - ,TAUX,TAUY & - ,POTEVP,POTFLX,SUBSHX & - ,APHTIM,ARDSW,ARDLW,ASRFC & - ,CROT,SROT,MIXHT & - ,HSTDV,HCNVX,HASYW,HASYS,HASYSW,HASYNW,HLENW & - ,HLENS,HLENSW,HLENNW,HANGL,HANIS,HSLOP,HZMAX & - ,CDMB,CLEFF,SIGFAC,FACTOP,RLOLEV,DPMIN & - ,RSWOUT,RSWTOA,RLWTOA & - ,ASWIN,ASWOUT,ASWTOA,ALWIN,ALWOUT,ALWTOA & - ,GWDFLG & - ,PCPFLG,DDATA & ! PRECIP ASSIM - ,UCMCALL,IVEGSRC & - ,TURBULENCE,SFC_LAYER & - ,LAND_SURFACE & - ,MICROPHYSICS & - ,LISS_RESTART & - ,GLOBAL & -!!! HURRICANE PBL/SFCLAY - ,VAR_RIC,COEF_RIC_L,COEF_RIC_S,DISHEAT & - ,ALPHA,SFENTH & -!!! HURRICANE - ,IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE) -!*********************************************************************** -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: TURBL TURBULENCE OUTER DRIVER -! PRGRMMR: BLACK ORG: W/NP22 DATE: 02-04-19 -! -! ABSTRACT: -! TURBL DRIVES THE TURBULENCE SCHEMES -! -! PROGRAM HISTORY LOG (with changes to called routines) : -! 95-03-15 JANJIC - ORIGINATOR OF THE SUBROUTINES CALLED -! BLACK & JANJIC - ORIGINATORS OF THE DRIVER -! 95-03-28 BLACK - CONVERSION FROM 1-D TO 2-D IN HORIZONTAL -! 96-03-29 BLACK - ADDED EXTERNAL EDGE; REMOVED SCRCH COMMON -! 96-07-19 MESINGER - ADDED Z0 EFFECTIVE -! 98-??-?? TUCCILLO - MODIFIED FOR CLASS VIII PARALLELISM -! 98-10-27 BLACK - PARALLEL CHANGES INTO MOST RECENT CODE -! 02-01-10 JANJIC - MOIST TURBULENCE (DRIVER, MIXLEN, VDIFH) -! 02-01-10 JANJIC - VERT. DIF OF Q2 INCREASED (Grenier & Bretherton) -! 02-02-02 JANJIC - NEW SFCDIF -! 02-04-19 BLACK - ORIGINATOR OF THIS OUTER DRIVER FOR WRF -! 02-05-03 JANJIC - REMOVAL OF SUPERSATURATION AT 2m AND 10m -! 04-11-18 BLACK - THREADED -! 06-10-25 BLACK - BUILT INTO NMMB PHYSICS COMPONENT -! 08-07-28 VASIC - Turned off counters (now computed in -! SET_INTERNAL_STATE_PHY). -! 08-08 JANJIC - Synchronize WATER array and Q. -! -! -! USAGE: CALL TURBL FROM PHY_RUN -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE : IBM -!$$$ -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - INTEGER(kind=KINT),INTENT(IN) :: IDS,IDE,JDS,JDE,LM & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE & - ,NPHS,NSOIL,NTSD & - ,UCMCALL,IVEGSRC -! - INTEGER(kind=KINT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: ISLTYP & - ,IVGTYP -! - INTEGER(kind=KINT),DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: LPBL -! - REAL(kind=KFPT),INTENT(IN) :: DT,PT,CDMB,CLEFF,SIGFAC,FACTOP,RLOLEV,DPMIN -! - REAL(kind=KFPT),DIMENSION(1:LM),INTENT(IN) :: DSG2,PDSG1,PSGML1 & - ,SGML2 -! - REAL(kind=KFPT),DIMENSION(1:LM+1),INTENT(IN) :: PSG1,SG2 -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: ALBASE & - ,MXSNAL -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: CROT,SROT & - ,HSTDV,HCNVX,HASYW,HASYS,HASYSW,HASYNW,HLENW & - ,HLENS,HLENSW,HLENNW,HANGL,HANIS,HSLOP,HZMAX -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: CZEN & - ,CZMEAN & - ,FIS,PD & - ,RLWIN & - ,RLWTOA & - ,RSWIN & - ,RSWOUT & - ,RSWTOA & - ,SICE & - ,SIGT4 & - ,SST,TG & - ,VEGFRC -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: EPSR & - ,SM,SR -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: GRNFLX,QWBS,RADOT & - ,SFCEXC,SMSTAV & - ,SOILTB,TWBS & - ,TAUX,TAUY -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: ACSNOM,ACSNOW & - ,AKHS,AKMS & - ,ALBEDO & - ,ALWIN,ALWOUT & - ,ALWTOA,ASWIN & - ,ASWOUT,ASWTOA & - ,MAVAIL & - ,BGROFF,CMC & - ,PBLH,POTEVP & - ,POTFLX,PREC & - ,QSH,QZ0,RMOL & - ,SFCEVP & - ,SFCLHX,SFCSHX & - ,SI,SMSTOT & - ,SNO,SNOPCX & - ,SNOWC & - ,SSROFF,SUBSHX & - ,T2,THS,THZ0 & - ,TSFC & - ,USTAR,UZ0,VZ0 & - ,Z0,Z0BASE & - ,APHTIM,ARDSW & !<-- Were scalars - ,ARDLW,ASRFC !<-- Were scalars -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: AKHS_OUT,AKMS_OUT & - ,MIXHT,PSHLTR & - ,Q10,QSHLTR & - ,TH10,TSHLTR & - ,U10,V10 -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(INOUT) :: CWM & - ,EXCH_H & - ,Q,Q2 & - ,T,U,V -! - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER,INTENT(INOUT) :: QC,QI,QR,QS,QG -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(INOUT) :: F_ICE & - ,F_RAIN -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(OUT) :: DUDT,DVDT & - ,XLEN_MIX -! - REAL(kind=KFPT),DIMENSION(NSOIL),INTENT(IN) :: DZSOIL,SLDPTH -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME,NSOIL),INTENT(INOUT) :: SH2O,SMC,STC -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(IN) :: RSWTT, RLWTT & - ,F_RIMEF -! - LOGICAL(kind=KLOG),INTENT(IN) :: GLOBAL -! - LOGICAL(kind=KLOG),INTENT(INOUT) :: LISS_RESTART -! - CHARACTER(99),INTENT(IN) :: LAND_SURFACE,MICROPHYSICS & - ,SFC_LAYER,TURBULENCE -! -! For precip assimilation: -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DDATA - LOGICAL(kind=KLOG),INTENT(IN) :: F_QC,F_QR,F_QI,F_QS,F_QG - LOGICAL(kind=KLOG),INTENT(IN) :: GWDFLG,PCPFLG - -! FOR Hurricane PBL/SFCLAY - REAL(kind=KFPT),INTENT(IN) :: SFENTH, ALPHA,VAR_RIC, COEF_RIC_L & - ,COEF_RIC_S ! from namelist - LOGICAL(kind=KLOG),INTENT(IN) :: DISHEAT ! should be from namelist - - -! -!--------------------- -!*** Local Variables -!--------------------- -! - REAL(kind=KFPT),PARAMETER :: XLV=ELWV -! - INTEGER(kind=KINT) :: I,IEND,IJ,ISTR,IW,J,K,KOUNT_ALL & - ,LENGTH_ROW,N,NRDL,NRL,NWL,SST_UPDATE -! - INTEGER(kind=KINT) :: PBL_PHYSICS,SFCLAY_PHYSICS,SURFACE_PHYSICS -! - INTEGER(kind=KINT) :: NUM_ROAD_LAYERS & - ,NUM_ROOF_LAYERS & - ,NUM_WALL_LAYERS -! - INTEGER(kind=KINT),DIMENSION(IMS:IME,JMS:JME) :: UTYPE_URB2D -! - REAL(kind=KFPT) :: ALTITUDE,DECLIN_URB,DTBL,DTMIN,DTPHS,DZHALF & - ,FACTOR,FACTRL,G_INV,PDSL,PLM,PLYR,PSFC & - ,QL,QLOWX,QCW,QRain,QCI,QSnow,QGraup & - ,RDTPHS,ROG,RXNER,SNO_FACTR & - ,TL,TLMH,TSFC2,XLVRW -! - REAL(kind=KFPT),DIMENSION(1:LM-1) :: EPSL - REAL(kind=KFPT),DIMENSION(1:LM) :: EPSQ2 -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME) ::CHKLOWQ,CHS,CHS2,CPM,CQS2 & - ,CT,CWMLOW & - ,ELFLX,EXNSFC,FACTRS,FLHC,FLQC & - ,GZ1OZ0,ONE,PSFC_OUT,PSIH,PSIM & - ,Q2X,QGH,QLOW,RAIN,RAINBL & - ,RLW_DN_SFC,RSW_NET_SFC & - ,RSW_DN_SFC,RIMEF & - ,SFCEVPX,SFCZ,SNOW,SNOWH & - ,TH2X,THLOW,TLOW & - ,VGFRCK,XLAND - -!! added for hwrf, tentatively - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME) :: MZNT,WSPD & - ,RC2D - INTEGER(kind=KINT),DIMENSION(IMS:IME,JMS:JME) :: KPBL2D - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM) :: EXCH_M - INTEGER(kind=KINT) :: NTSFLG - -!! hwrf - -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM) :: DELP & - ,DZ,EXNER,PHMID,RR,U_PHY,V_PHY,TH -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM+1) :: PHINT,Z -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM) :: RTHBLTEN & - ,RQBLTEN & - ,RQCBLTEN & - ,RQIBLTEN -! - REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM) :: DUDT_GWD,DVDT_GWD - - REAL(kind=KFPT),DIMENSION(1:NSOIL) :: DZB,DZR,DZG -! - REAL(kind=KFPT),DIMENSION(IMS:IME,1:NSOIL,JMS:JME) :: TBL_URB3D & - ,TGL_URB3D & - ,TRL_URB3D -! - REAL(kind=KFPT), DIMENSION( IMS:IME, JMS:JME ) :: AKMS_URB2D & - ,COSZ_URB2D & - ,FRC_URB2D & - ,G_URB2D & - ,GZ1OZ0_URB2D & - ,LH_URB2D & - ,OMG_URB2D & - ,PSIH_URB2D & - ,PSIM_URB2D & - ,Q2_URB2D & - ,QC_URB2D & - ,RN_URB2D & - ,SH_URB2D & - ,TB_URB2D & - ,TC_URB2D & - ,TG_URB2D & - ,TH2_URB2D & - ,TR_URB2D & - ,TS_URB2D & - ,U10_URB2D & - ,UC_URB2D & - ,UST_URB2D & - ,V10_URB2D & - ,XLAT_URB2D & - ,XXXB_URB2D & - ,XXXC_URB2D & - ,XXXG_URB2D & - ,XXXR_URB2D - - REAL(kind=KFPT), DIMENSION( IMS:IME, JMS:JME ) :: RIB ! Bulk Richardson Number -! - LOGICAL(kind=KLOG) :: FRPCPN,MYJ,WARM_RAIN,FER_MIC - LOGICAL(kind=KLOG) :: E_BDY,N_BDY,S_BDY,W_BDY -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -!*** Translate the package options in the config file needed by -!*** the Turbulence to their analogs in the WRF Registry so that -!*** the WRF surface and PBL drivers remain untouched. -!----------------------------------------------------------------------- -! - -! write(0,*)'select PBL=',TURBULENCE - SELECT CASE (TRIM(TURBULENCE)) - CASE ('myj') - PBL_PHYSICS=MYJPBLSCHEME - CASE ('gfs') - PBL_PHYSICS=GFSPBLSCHEME - CASE ('gfshur') - PBL_PHYSICS=GFSPBLHURSCHEME - CASE ('gfsedmfhur') - PBL_PHYSICS=GFSPBLEDMFHURSCHEME - CASE DEFAULT - WRITE(0,*)' User selected TURBULENCE=',TRIM(TURBULENCE) - WRITE(0,*)' Improper selection of Turbulence scheme in TURBL' - CALL NMMB_FINALIZE - END SELECT -! - SELECT CASE (TRIM(SFC_LAYER)) - CASE ('myj') - SFCLAY_PHYSICS=JSFCSCHEME - CASE ('gfs') - SFCLAY_PHYSICS=JSFCSCHEME - CASE ('gfdl') - SFCLAY_PHYSICS=GFDLSFCSCHEME - CASE DEFAULT - WRITE(0,*)' User selected SFC_LAYER=',TRIM(SFC_LAYER) - WRITE(0,*)' Improper selection of Surface Layer scheme in TURBL' - CALL NMMB_FINALIZE - END SELECT -! - SELECT CASE (TRIM(LAND_SURFACE)) - CASE ('noah') - SURFACE_PHYSICS=LSMSCHEME - case ('liss') - surface_physics=LISSSCHEME - case ('gfdlslab') - surface_physics=GFDLSLABSCHEME - CASE DEFAULT - WRITE(0,*)' User selected LAND_SURFACE=',TRIM(LAND_SURFACE) - WRITE(0,*)' Improper selection of Land Surface scheme in TURBL' - CALL NMMB_FINALIZE - END SELECT -! - IF(TRIM(MICROPHYSICS)=='fer' .OR. TRIM(MICROPHYSICS)=='fer_hires')THEN - FER_MIC=.TRUE. - ELSE - FER_MIC=.FALSE. - ENDIF -! -!....................................................................... -!$omp parallel do private(j,k,i) -!....................................................................... - DO K=1,LM - DO J=JMS,JME - DO I=IMS,IME - U_PHY(I,J,K)=0. - V_PHY(I,J,K)=0. - DUDT(I,J,K)=0. - DVDT(I,J,K)=0. - ENDDO - ENDDO - ENDDO -!....................................................................... -!$omp end parallel do -!....................................................................... -! - DTPHS=NPHS*DT - RDTPHS=1./DTPHS - G_INV=1./G - ROG=R_D*G_INV - FACTOR=-XLV*RHOWATER/DTPHS -! - SST_UPDATE=0 -! -!$omp parallel do private(j,i) - DO J=JMS,JME - DO I=IMS,IME - ONE(I,J)=1. - RMOL(I,J)=0. !Reciprocal of Monin-Obukhov length - SFCEVPX(I,J)=0. !Dummy for accumulated latent energy, not flux - ENDDO - ENDDO -!$omp end parallel do -! - W_BDY=(ITS==IDS) - E_BDY=(ITE==IDE) - S_BDY=(JTS==JDS) - N_BDY=(JTE==JDE) -! - IF(SURFACE_PHYSICS==99.OR.SURFACE_PHYSICS==LISSSCHEME)THEN - SNO_FACTR=1. -!$omp parallel do private(j,i) - DO J=JTS,JTE - DO I=ITS,ITE - SNOWC(I,J)=0. - IF(SNO(I,J)>0.) SNOWC(I,J)=1. - ENDDO - ENDDO -!$omp end parallel do - ELSE - SNO_FACTR=0.001 - ENDIF -! -!$omp parallel do private(j,i) - DO J=JTS,JTE - DO I=ITS,ITE - VGFRCK(I,J)=100.*VEGFRC(I,J) - SNOW(I,J)=SNO(I,J) - SNOWH(I,J)=SI(I,J)*SNO_FACTR - XLAND(I,J)=SM(I,J)+1. - T2(I,J)=TSFC(I,J) - ENDDO - ENDDO -!$omp end parallel do -! - IF(NTSD==0)THEN -!$omp parallel do private(j,i) - DO J=JTS,JTE - DO I=ITS,ITE - Z0BASE(I,J)=Z0(I,J) - IF(SM(I,J)>0.5.AND.SICE(I,J)>0.5)THEN !Bandaid - SM(I,J)=0. - ENDIF - ENDDO - ENDDO -!$omp end parallel do - ENDIF -! -!$omp parallel do private(k,j,i) - DO K=1,LM - DO J=JTS,JTE - DO I=ITS,ITE - Q2(i,j,k)=MAX(Q2(i,j,k),EPSQ2(K)) - EXCH_H(I,J,K)=0. - DZ(I,J,K)=0. - ENDDO - ENDDO - ENDDO -!$omp end parallel do -! -!$omp parallel do private(k,j,i) - DO K=1,LM+1 - DO J=JTS,JTE - DO I=ITS,ITE - Z(I,J,K)=0. - ENDDO - ENDDO - ENDDO -!$omp end parallel do - -!----------------------------------------------------------------------- -!*** Prepare needed arrays -!----------------------------------------------------------------------- -! -!....................................................................... -!$omp parallel do & -!$omp private(j,i,pdsl,psfc,plm,tlmh,factrl,k,plyr,ql,tl & -!$omp ,rxner),SCHEDULE(dynamic) -!....................................................................... - DO J=JTS,JTE - DO I=ITS,ITE -! - PDSL=PD(I,J) - PSFC=SG2(LM+1)*PDSL+PSG1(LM+1) - PHINT(I,J,LM+1)=PSFC - EXNSFC(I,J)=(1.E5/PSFC)**CAPPA - THS(I,J)=(SST(I,J)*EXNSFC(I,J))*SM(I,J)+THS(I,J)*(1.-SM(I,J)) - TSFC(I,J)=THS(I,J)/EXNSFC(I,J) - SFCZ(I,J)=FIS(I,J)*G_INV -!YL -! RAIN(I,J)=PREC(I,J)*RHOWATER - IF(PCPFLG.AND.DDATA(I,J).LT.100.)THEN - RAIN(I,J)=DDATA(I,J)*RHOWATER - ELSE - RAIN(I,J)=PREC(I,J)*RHOWATER - ENDIF -!YL - RAINBL(I,J)=0. -!+++++++++++++++++++++++++++++++++++++++++++++ -! IF(SNO(I,J)>0.)SNOWC(I,J)=1. !2013 comment out -!+++++++++++++++++++++++++++++++++++++++++++++ - PLM=SGML2(LM)*PDSL+PSGML1(LM) - TH2X(I,J)=T(I,J,LM)*(1.E5/PLM)**CAPPA - Q2X(I,J)=Q(I,J,LM) - RIMEF(I,J)=MAX(1., F_RIMEF(I,J,LM)) -! -!----------------------------------------------------------------------- -!*** Modify z0 if snow on the ground -!----------------------------------------------------------------------- -! -! if(snow(i,j).gt.0.) then !zj -! z0(i,j)=0.0013 !zj -! else !zj -! z0(i,j)=z0base(i,j) !zj -! endif !zj -! -!----------------------------------------------------------------------- -!*** Long and shortwave flux at ground surface -!----------------------------------------------------------------------- -! - IF(CZMEAN(I,J)>0.)THEN - FACTRS(I,J)=CZEN(I,J)/CZMEAN(I,J) - ELSE - FACTRS(I,J)=0. - ENDIF -! - IF(SIGT4(I,J)>0.)THEN - TLMH=T(I,J,LM) - FACTRL=STBOLT*TLMH*TLMH*TLMH*TLMH/SIGT4(I,J) - ELSE - FACTRL=0. - ENDIF -! -!- RLWIN/RSWIN - downward longwave/shortwave at the surface -! - RLW_DN_SFC(I,J)=RLWIN(I,J)*FACTRL - RSW_NET_SFC(I,J)=(RSWIN(I,J)-RSWOUT(I,J))*FACTRS(I,J) -! -!- Instantaneous downward solar for NMM_LSM -! - RSW_DN_SFC(I,J)=RSWIN(I,J)*FACTRS(I,J) -! -!----------------------------------------------------------------------- -!*** Fill the arrays for calling the inner driver. -!----------------------------------------------------------------------- -! - Z(I,J,LM+1)=SFCZ(I,J) -! -!----------------------------------------------------------------------- -!*** Fill vertical working arrays. -!----------------------------------------------------------------------- -! - DO K=LM,1,-1 -! - PLYR=SGML2(K)*PDSL+PSGML1(K) - QL=MAX(Q(I,J,K),EPSQ) - TL=T(I,J,K) -! - RR(I,J,K)=PLYR/(R_D*TL) - RXNER=(1.E5/PLYR)**CAPPA - EXNER(I,J,K)=1./RXNER - TH(I,J,K)=TL*RXNER - PHINT(I,J,K)=SG2(K)*PD(I,J)+PSG1(K) - PHMID(I,J,K)=PLYR -! - RQCBLTEN(I,J,K)=0. - RQIBLTEN(I,J,K)=0. - RTHBLTEN(I,J,K)=0. - RQBLTEN(I,J,K)=0. -! - DZ(I,J,K)=T(I,J,K)*(P608*QL+1.)*R_D & - *(PHINT(I,J,K+1)-PHINT(I,J,K)) & - /(PLYR*G) - Z(I,J,K)=Z(I,J,K+1)+DZ(I,J,K) -! - DELP(I,J,K)=PHINT(I,J,K+1)-PHINT(I,J,K) -! - ENDDO - ENDDO - ENDDO - -!....................................................................... -!$omp end parallel do -!....................................................................... -! -!....................................................................... -!$omp parallel do & -!$omp& private(i,j,qlowx) -!....................................................................... - DO J=JTS,JTE - DO I=ITS,ITE - TWBS(I,J)=0. - QWBS(I,J)=0. - THLOW(I,J)=TH(I,J,LM) - TLOW(I,J)=T(I,J,LM) - QLOW(I,J)=MAX(Q(I,J,LM),EPSQ) - QLOWX=QLOW(I,J)/(1.-QLOW(I,J)) - QLOW(I,J)=QLOWX/(1.+QLOWX) - CWMLOW(I,J)=CWM(I,J,LM) - PBLH(I,J)=MAX(PBLH(I,J),0.) - PBLH(I,J)=MIN(PBLH(I,J),Z(I,J,LM)) - ENDDO - ENDDO -!....................................................................... -!$omp end parallel do -!....................................................................... -! -!----------------------------------------------------------------------- -!*** Compute velocity components at mass points. -!----------------------------------------------------------------------- -! -!....................................................................... -!$omp parallel do & -!$omp& private(k,j,i) -!....................................................................... - DO K=1,LM - DO J=JTS_B1,JTE_B1 - DO I=ITS_B1,ITE_B1 - U_PHY(I,J,K)=(U(I,J ,K)+U(I-1,J ,K) & - +U(I,J-1,K)+U(I-1,J-1,K))*0.25 - V_PHY(I,J,K)=(V(I,J ,K)+V(I-1,J ,K) & - +V(I,J-1,K)+V(I-1,J-1,K))*0.25 - ENDDO - ENDDO - ENDDO -!....................................................................... -!$omp end parallel do -!....................................................................... -!----------------------------------------------------------------------- -!*** Moisture availability -!----------------------------------------------------------------------- -! - IF(TRIM(LAND_SURFACE)=='nmm')THEN - DO J=JTS,JTE - DO I=ITS,ITE - ONE(I,J)=1. - ENDDO - ENDDO - ELSE - DO J=JTS,JTE - DO I=ITS,ITE - ONE(I,J)=MAVAIL(I,J) - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -! -!*** Call surface layer and land surface physics. -! -!----------------------------------------------------------------------- -! - DTMIN = 0. - DTBL = 0. -! - DO J=JTS_B1,JTE_B1 - DO I=ITS_B1,ITE_B1 - QGH(I,J) = 0. - CHS(I,J) = 0. - CPM(I,J) = 0. - CHS2(I,J) = 0. - RAINBL(I,J) = RAINBL(I,J) + RAIN(I,J) - RAINBL(I,J) = MAX (RAINBL(I,J), 0.0) - ENDDO - ENDDO -! -!------------ -! Update SST -!------------ -! - IF (SST_UPDATE == 1) THEN - DO J=JTS_B1,JTE_B1 - DO I=ITS_B1,ITE_B1 - IF(XLAND(I,J)>1.5)TSFC(I,J)=SST(I,J) - ENDDO - ENDDO - ENDIF - -!----------------------------------------------------------------------- - sfc_and_sfclyr: IF (NTSD==1 .OR. MOD(NTSD,NPHS)==0) THEN -!----------------------------------------------------------------------- -! - MYJ = .FALSE. - FRPCPN = .FALSE. - DTMIN=DT/60. -!----------------------------------------------------------------------- -! Surface schemes need PBL time step for updates and accumulations. -! Assume these schemes provide no tendencies. -!----------------------------------------------------------------------- -! - DTBL=DT*NPHS -! -!-------------------- -!*** Save old values -!-------------------- -! - DO J=JTS_B1,JTE_B1 - DO I=ITS_B1,ITE_B1 - PSFC_OUT(I,J)=PHINT(I,J,LM+1) - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** SFCLAY_PHYSICS -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- - - sfclay_select: SELECT CASE(SFCLAY_PHYSICS) - - CASE (JSFCSCHEME) - - MYJ =.TRUE. - CALL JSFC(NTSD,EPSQ2,SFCZ,DZ, & - PHMID,PHINT,TH,T, & - Q,QC, & - U_PHY,V_PHY,Q2, & - TSFC,QSH,THZ0,QZ0,UZ0,VZ0, & - XLAND, & - VEGFRC,SNOWC, & !added 5/17/2013 - USTAR,Z0,Z0BASE,PBLH,ONE,RMOL, & - AKHS,AKMS, & - CHS,CHS2,CQS2,TWBS,QWBS,ELFLX,FLHC,FLQC, & - QGH,CPM,CT, & - U10,V10,T2,TH2X,TSHLTR,TH10,Q2X,QSHLTR,Q10, & - PSHLTR,RIB, & - IDS,IDE,JDS,JDE,1,LM+1, & - IMS,IME,JMS,JME,1,LM+1, & - ITS_B1,ITE_B1,JTS_B1,JTE_B1,1,LM) - - CASE (GFDLSFCSCHEME) - - MYJ =.FALSE. -! not sure why this if-block is needed, just copied from hwrf - NTSFLG=0 -!20140813 if (SFCLAY_PHYSICS == 88 ) NTSFLG=1 -!20140813 IF we use GFDL sfc, we have to set NTSFLG=1, meaning update TSK -!20140813 IF NOT, then some other surface model may take care of updating TSK - if( surface_physics == GFDLSLABSCHEME ) NTSFLG=1 -! - CALL SF_GFDL(U3D=U_PHY,V3D=V_PHY,T3D=T,QV3D=Q, & - P3D=PHMID,CP=CP, ROVCP=R_D/CP,R=R_D, & - XLV=XLV,PSFC=PSFC_OUT,CHS=CHS,CHS2=CHS2, & - CQS2=CQS2, CPM=CPM, & - DT=DTBL, SMOIS=SMC,num_soil_layers=NSOIL, & - ISLTYP=ISLTYP,ZNT=z0, & -!#if (HWRF==1) - MZNT=MZNT, & -!#endif - UST=USTAR,PSIM=PSIM,PSIH=PSIH, & - XLAND=XLAND,HFX=TWBS,QFX=QWBS, & - TAUX=TAUX,TAUY=TAUY,LH=ELFLX, & - GSW=RSW_DN_SFC,GLW=RLW_DN_SFC,TSK=TSFC, & - FLHC=FLHC,FLQC=FLQC, & ! gopal's doingfor Ocean coupling - QGH=QGH,QSFC=QSH,U10=U10,V10=V10, & - GZ1OZ0=GZ1OZ0,WSPD=WSPD,BR=RIB,ISFFLX=1, & - EP1=EP_1,EP2=EP_2,KARMAN=0.4,NTSFLG=NTSFLG, & - SFENTH=SFENTH,& - ids=ids,ide=ide, jds=jds,jde=jde, kds=1,kde=LM, & - ims=ims,ime=ime, jms=jms,jme=jme, kms=1,kme=LM, & - its=its_B1,ite=ite_b1, jts=jts_b1,jte=jte_B1, & - kts=1,kte=LM ) - DO I=its_B1,ite_B1 - DO J=jts_b1,jte_B1 - CHKLOWQ(I,J)=1.0 - enddo - enddo - CASE DEFAULT - - WRITE(0,*)'The sfclay option does not exist: SFCLAY_PHYSICS = ', SFCLAY_PHYSICS - - END SELECT sfclay_select - -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** SURFACE_PHYSICS -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- - - sfc_select: SELECT CASE(SURFACE_PHYSICS) - - CASE (LISSSCHEME) - - CALL LISS(DZ,Q,PHINT,RR, & - T,TH,TSFC,CHS, & - TWBS,QWBS,QGH,RSW_DN_SFC,RLW_DN_SFC,ELFLX,RMOL, & - SMSTAV,SMSTOT,SSROFF, & - BGROFF,IVGTYP,ISLTYP,VGFRCK,SFCEVPX,POTEVP, & - GRNFLX,SFCEXC,ACSNOW,ACSNOM,SNOPCX, & - ALBASE,TG,XLAND,SICE,QZ0, & - TH2X,Q2X,SNOWC,CQS2,QSH,SOILTB,CHKLOWQ,RAINBL, & - NSOIL,DTBL,DZSOIL,NTSD, & - SMC,STC,SNOW,CMC,CPM,CAPPA,SR, & - ALBEDO,MXSNAL,SH2O,SNOWH, & - LISS_RESTART, & - IDS,IDE, JDS,JDE, 1,LM+1, & - IMS,IME, JMS,JME, 1,LM+1, & - ITS_B1,ITE_B1,JTS_B1,JTE_B1, 1,LM ) - - CASE (LSMSCHEME) - - FRPCPN=.TRUE. - NRL=1 - NWL=1 - NRDL=1 - FRC_URB2D=0.0 - - CALL NOAHLSM(DZ,Q,PHINT,T,TSFC, & - TWBS,QWBS,ELFLX,GRNFLX,QGH, & - RSW_NET_SFC,RSW_DN_SFC,RLW_DN_SFC, & - SMSTAV,SMSTOT, & - SSROFF,BGROFF,IVGTYP,ISLTYP,VGFRCK, & - ALBEDO,ALBASE,Z0,Z0BASE,TG,XLAND,SICE,EPSR, & - SNOWC,QSH,RAINBL, & - NSOIL,DTBL,DZSOIL,NTSD, & - SMC,STC,SNOW,CMC, & - CHS, CHS2, CQS2, CPM,CAPPA, & - SR,RIMEF, CHKLOWQ,QZ0, & - MYJ,FRPCPN, & - SH2O,SNOWH, & !H - U_PHY,V_PHY, & !I - MXSNAL, & !I - ACSNOM,ACSNOW, & !O - SNOPCX, & !O - POTEVP, RIB, & !O Added Bulk Richardson No. - IDS,IDE,JDS,JDE,1,LM+1, & - IMS,IME,JMS,JME,1,LM+1, & - ITS_B1,ITE_B1,JTS_B1,JTE_B1, 1,LM, & - UCMCALL,IVEGSRC, & -! Optional urban - TR_URB2D,TB_URB2D,TG_URB2D,TC_URB2D, & !H urban - QC_URB2D,UC_URB2D, & !H urban - XXXR_URB2D,XXXB_URB2D,XXXG_URB2D,XXXC_URB2D, & !H urban - TRL_URB3D,TBL_URB3D,TGL_URB3D, & !H urban - SH_URB2D,LH_URB2D,G_URB2D,RN_URB2D,TS_URB2D, & !H urban - PSIM_URB2D,PSIH_URB2D,U10_URB2D,V10_URB2D, & !O urban - GZ1OZ0_URB2D, AKMS_URB2D, & !O urban - TH2_URB2D,Q2_URB2D,USTAR, & !O urban - DECLIN_URB,COSZ_URB2D,OMG_URB2D, & !I urban - XLAT_URB2D, & !I urban - NRL, NWL, & !I urban - NRDL, DZR, DZB, DZG, & !I urban - FRC_URB2D, UTYPE_URB2D & ! urban - ) - - DO J=JTS_B1,JTE_B1 - DO I=ITS_B1,ITE_B1 - SFCEVPX(I,J)= SFCEVPX(I,J) + QWBS(I,J)*DTBL - SFCEXC(I,J)= CHS(I,J) - SOILTB(I,J)= STC(I,J,NSOIL) ! nmmlsm vrbl., here only for output - ENDDO - ENDDO - - CALL SFCDIAGS(TWBS,QWBS,TSFC,QSH,CHS2,CQS2,T2,TH2X,Q2X, & - PSFC_OUT,CP,R_d,CAPPA, & - IDS,IDE, JDS,JDE, 1,LM+1, & - IMS,IME, JMS,JME, 1,LM+1, & - ITS_B1,ITE_B1,JTS_B1,JTE_B1, 1,LM) - - urban: IF(UCMCALL==1) THEN -! - IW = 1 - IF( IVEGSRC == 1 ) IW = 13 -! - DO J=JTS_B1,JTE_B1 - DO I=ITS_B1,ITE_B1 - IF( IVGTYP(I,J) == IW .OR. IVGTYP(I,J) == 31 .OR. & - IVGTYP(I,J) == 32 .OR. IVGTYP(I,J) == 33 ) THEN -! - T2(I,J) = FRC_URB2D(I,J)*TH2_URB2D(I,J) & - +(1-FRC_URB2D(I,J))*T2(I,J) - TH2X(I,J) = T2(I,J)*(1.E5/PSFC_OUT(I,J))**CAPPA - Q2X(I,J) = FRC_URB2D(i,j)*Q2_URB2D(I,J) & - +(1-FRC_URB2D(I,J))* Q2X(I,J) - U10(I,J) = U10_URB2D(I,J) - V10(I,J) = V10_URB2D(I,J) - PSIM(I,J) = PSIM_URB2D(I,J) - PSIH(I,J) = PSIH_URB2D(I,J) - GZ1OZ0(I,J) = GZ1OZ0_URB2D(I,J) - AKHS(I,J) = CHS(I,J) - AKMS(I,J) = AKMS_URB2D(I,J) -! - END IF - ENDDO - ENDDO - ENDIF urban - - CASE(GFDLSLABSCHEME) -! write(0,*)'GFDL SLAB LSM model is selected, whcih is included in GFDLSURFACE module' - - CASE DEFAULT - - WRITE(0,*) 'The surface option not exist: SURFACE_PHYSICS = ', SURFACE_PHYSICS - - END SELECT sfc_select - -!----------------------------------------------------- -! Reset RAINBL in mm (Accumulation between PBL calls) -!----------------------------------------------------- - DO J=JTS_B1,JTE_B1 - DO I=ITS_B1,ITE_B1 - RAINBL(I,J) = 0. - ENDDO - ENDDO - -! -!----------------------------------------------------------------------- - ENDIF sfc_and_sfclyr -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! -!*** CALL FREE ATMOSPHERE TURBULENCE -! -!----------------------------------------------------------------------- -! -!*** The surface exchange coefficients AKHS and AKMS are actually -!*** multiplied by half the depth of the lowest layer. We must retain -!*** those values for the next timestep so use auxilliary arrays for -!*** the output. -! - DO J=JTS,JTE - DO I=ITS,ITE - DZHALF=0.5*DZ(I,J,LM) - AKHS_OUT(I,J)=AKHS(I,J)*DZHALF - AKMS_OUT(I,J)=AKMS(I,J)*DZHALF - ENDDO - ENDDO - -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** PBL_PHYSICS -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- - - pbl_select: SELECT CASE(PBL_PHYSICS) - - CASE (MYJPBLSCHEME) - - IF (NTSD == 1 .OR. MOD(NTSD,NPHS) == 0) THEN - - CALL MYJPBL(DT=DT,NPHS=NPHS,EPSL=EPSL,EPSQ2=EPSQ2 & - ,HT=SFCZ,STDH=HSTDV,DZ=DZ & - ,PMID=PHMID,PINH=PHINT,TH=TH,T=T,EXNER=EXNER & - ,Q=Q & - ,CWM=QC & - ,U=U_PHY,V=V_PHY & - ,TSK=TSFC,QSFC=QSH,CHKLOWQ=CHKLOWQ,THZ0=THZ0 & - ,QZ0=QZ0,UZ0=UZ0,VZ0=VZ0 & - ,XLAND=XLAND,SICE=SICE,SNOW=SNOW & - ,Q2=Q2,EXCH_H=EXCH_H,USTAR=USTAR,Z0=Z0 & - ,EL_MYJ=XLEN_MIX,PBLH=PBLH,KPBL=LPBL,CT=CT & - ,AKHS=AKHS,AKMS=AKMS,ELFLX=ELFLX,MIXHT=MIXHT & - ,RUBLTEN=DUDT & - ,RVBLTEN=DVDT & - ,RTHBLTEN=RTHBLTEN & - ,RQBLTEN=RQBLTEN & - ,RQCBLTEN=RQCBLTEN & - ,IDS=IDS,IDE=IDE,JDS=JDS,JDE=JDE & - ,IMS=IMS,IME=IME,JMS=JMS,JME=JME & - ,ITS=ITS_B1,ITE=ITE_B1 & - ,JTS=JTS_B1,JTE=JTE_B1 & - ,LM=LM) - - END IF - - CASE (GFSPBLSCHEME) !! Wang 09-10-2010 added GFS PBL driver - - IF (NTSD == 1 .OR. MOD(NTSD,NPHS) == 0) THEN - - CALL GFSPBL(DT=DT,NPHS=NPHS,DP=DELP,AIRDEN=RR & - ,RIB=RIB & - ,PHMID=PHMID,PHINT=PHINT,T=T,ZINT=Z & - ,Q=Q,QC=QC,QI=QI & - ,F_QC=F_QC,F_QI=F_QI & - ,U=U_PHY,V=V_PHY & - ,USTAR=USTAR & - ,SHEAT=TWBS, LHEAT=QWBS*XLV*CHKLOWQ & - ! ,SHEAT=TWBS, LHEAT=QWBS*XLV*CHKLOWQ & !! After testing, TWBS is regular - !surface heat flux (i.e., up is +) - ,XLAND=XLAND & - ,AKHS=AKHS,AKMS=AKMS & - ,THZ0=THZ0,QZ0=QZ0 & - ,QSFC=QSH & - ,TSK=TSFC,SNOW=SNOW,SICE=SICE,CHKLOWQ=CHKLOWQ & - ,FACTRS=FACTRS,RSWTT=RSWTT,RLWTT=RLWTT & !! radiative heating - ,PBLH=PBLH,PBLK=LPBL & - ,MIXHT=MIXHT & - ,RUBLTEN=DUDT & - ,RVBLTEN=DVDT & - ,RTHBLTEN=RTHBLTEN & - ,RQBLTEN=RQBLTEN & - ,RQCBLTEN=RQCBLTEN & - ,RQIBLTEN=RQIBLTEN & - ,IDS=IDS,IDE=IDE,JDS=JDS,JDE=JDE,KDS=1,KDE=LM+1 & - ,IMS=IMS,IME=IME,JMS=JMS,JME=JME,KMS=1,KME=LM+1 & - ,ITS=ITS_B1,ITE=ITE_B1 & - ,JTS=JTS_B1,JTE=JTE_B1 & - ,KTS=1,KTE=LM ) - - END IF - - CASE(GFSPBLHURSCHEME) - - IF (NTSD == 1 .OR. MOD(NTSD,NPHS) == 0) THEN -! write(0,*)'F_QC=',F_QC ,'QC=',maxval(QC),'QC=',QC(its_b1+2,jts_b1+2,30) -! write(0,*)'F_QS=',F_QS ,'QS=',maxval(QS),'QS=',QS(its_b1+2,jts_b1+2,30) -! write(0,*)'F_QI=',F_QI !,'QI=',maxval(QI),'QI=',QI(its_b1+2,jts_b1+2,30) - CALL GFSPBLHUR(U3D=U_PHY,V3D=V_PHY,TH3D=TH,T3D=T & -! ,QV3D=Q,QC3D=QC,QI3D=QI,P3D=PHMID,PI3D=EXNER & -! in Fer scheme, F_QI=false - ,QV3D=Q,QC3D=QC,QI3D=QS*0.0,P3D=PHMID,PI3D=EXNER & - ,RUBLTEN=DUDT & - ,RVBLTEN=DVDT & - ,RTHBLTEN=RTHBLTEN & - ,RQVBLTEN=RQBLTEN & - ,RQCBLTEN=RQCBLTEN & - ,RQIBLTEN=RQIBLTEN & - ,CP=CP,G=G,ROVCP=CAPPA,R=R_D,ROVG=R_D/G & - ,F_QC=F_QC,F_QI=F_QI & - - ,dz8w=DZ,z=Z,PSFC=PSFC_OUT & - - ,UST=USTAR,PBL=PBLH,PSIM=PSIM,PSIH=PSIH & - - ,HFX=TWBS,QFX=QWBS,TSK=TSFC& - ,GZ1OZ0=GZ1OZ0,WSPD=WSPD,BR=RIB & - - ,DT=DT*NPHS,KPBL2D=KPBL2D,EP1=EP_1,KARMAN=0.4 & - -!!#if (NMM_CORE==1) - ,DISHEAT=DISHEAT & - ,ALPHA=ALPHA & - ,VAR_RIC=VAR_RIC & -!!#endif - ,U10=U10,V10=V10,ZNT=z0,MZNT=MZNT,rc2d=rc2d & - ,DKU3D=EXCH_M,DKT3D=EXCH_H & - ,coef_ric_l=coef_ric_l & - ,coef_ric_s=coef_ric_s & - ,xland=xland & - ,ids=ids,ide=ide, jds=jds,jde=jde, kds=1,kde=LM & - ,ims=ims,ime=ime, jms=jms,jme=jme, kms=1,kme=LM & - , its=its_b1,ite=ite_b1, jts=jts_b1,jte=jte_b1 & - , kts=1,kte=LM ) - ENDIF - - CASE(GFSPBLEDMFHURSCHEME) - IF (NTSD == 1 .OR. MOD(NTSD,NPHS) == 0) THEN - CALL GFSPBLEDMFHUR(U3D=U_PHY,V3D=V_PHY,TH3D=TH,T3D=T & - ,QV3D=Q,QC3D=QC,QI3D=QS*0.0,P3D=PHMID,PI3D=EXNER & - ,RUBLTEN=DUDT & - ,RVBLTEN=DVDT & - ,RTHBLTEN=RTHBLTEN & - ,RQVBLTEN=RQBLTEN & - ,RQCBLTEN=RQCBLTEN & - ,RQIBLTEN=RQIBLTEN & - ,CP=CP,G=G,ROVCP=CAPPA,R=R_D,ROVG=R_D/G & - ,F_QC=F_QC,F_QI=F_QI & - ,dz8w=DZ,z=Z,PSFC=PSFC_OUT & - ,UST=USTAR,PBL=PBLH,PSIM=PSIM,PSIH=PSIH & - ,HFX=TWBS,QFX=QWBS,TSK=TSFC & - !,GZ1OZ0=GZ1OZ0,WSPD=WSPD,BR=BR & - ,GZ1OZ0=GZ1OZ0,WSPD=WSPD,BR=RIB & - ,DT=DT*NPHS,KPBL2D=KPBL2D,EP1=EP_1,KARMAN=0.4 & - ,DISHEAT=DISHEAT & - ,ALPHA=ALPHA & - ,VAR_RIC=VAR_RIC & - ,U10=U10,V10=V10,ZNT=z0,MZNT=MZNT & !,rc2d=rc2d & - ,DKU3D=EXCH_M,DKT3D=EXCH_H & - ,coef_ric_l=coef_ric_l & - ,coef_ric_s=coef_ric_s & - ,xland=xland & - ,rswtt=rswtt,rlwtt=rlwtt & - ,ids=ids,ide=ide, jds=jds,jde=jde, kds=1,kde=LM & - ,ims=ims,ime=ime, jms=jms,jme=jme, kms=1,kme=LM & - , its=its_b1,ite=ite_b1, jts=jts_b1,jte=jte_b1 & - , kts=1,kte=LM ) - ENDIF - - CASE DEFAULT - - WRITE(0,*)'The pbl option does not exist: pbl_physics = ', pbl_physics - - END SELECT pbl_select - -!----------------------------------------------------------------------- -!*** Note that the exchange coefficients for heat EXCH_H coming out of -!*** PBL_DRIVER are defined at the tops of the layers KTS to KTE-1 -!*** if MODULE_BL_MYJPBL was invoked. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Uncomputed locations must be filled in for the post-processor. -!----------------------------------------------------------------------- -! -!*** Western global boundary -! - IF(W_BDY)THEN - DO J=JDS,JDE - IF(J>=JTS.AND.J<=JTE)THEN - TH10(IDS,J)=TH10(IDS+1,J) - Q10(IDS,J)=Q10(IDS+1,J) - U10(IDS,J)=U10(IDS+1,J) - V10(IDS,J)=V10(IDS+1,J) - TSHLTR(IDS,J)=TSHLTR(IDS+1,J) - QSHLTR(IDS,J)=QSHLTR(IDS+1,J) - ENDIF - ENDDO - ENDIF -! -!*** Eastern global boundary -! - IF(E_BDY)THEN - DO J=JDS,JDE - IF(J>=JTS.AND.J<=JTE)THEN - TH10(IDE,J)=TH10(IDE-1,J) - Q10(IDE,J)=Q10(IDE-1,J) - U10(IDE,J)=U10(IDE-1,J) - V10(IDE,J)=V10(IDE-1,J) - TSHLTR(IDE,J)=TSHLTR(IDE-1,J) - QSHLTR(IDE,J)=QSHLTR(IDE-1,J) - ENDIF - ENDDO - ENDIF -! -!*** Southern global boundary -! - IF(S_BDY)THEN - DO I=IDS,IDE - IF(I>=ITS.AND.I<=ITE)THEN - TH10(I,JDS)=TH10(I,JDS+1) - Q10(I,JDS)=Q10(I,JDS+1) - U10(I,JDS)=U10(I,JDS+1) - V10(I,JDS)=V10(I,JDS+1) - TSHLTR(I,JDS)=TSHLTR(I,JDS+1) - QSHLTR(I,JDS)=QSHLTR(I,JDS+1) - ENDIF - ENDDO - ENDIF -! -!*** Northern global boundary -! - IF(N_BDY)THEN - DO I=IDS,IDE - IF(I>=ITS.AND.I<=ITE)THEN - TH10(I,JDE)=TH10(I,JDE-1) - Q10(I,JDE)=Q10(I,JDE-1) - U10(I,JDE)=U10(I,JDE-1) - V10(I,JDE)=V10(I,JDE-1) - TSHLTR(I,JDE)=TSHLTR(I,JDE-1) - QSHLTR(I,JDE)=QSHLTR(I,JDE-1) - ENDIF - ENDDO - ENDIF -! - IF(TRIM(SFC_LAYER)/='myj')THEN - DO J=JTS_B1,JTE_B1 - DO I=ITS_B1,ITE_B1 -! TSHLTR(I,J)=TSHLTR(I,J)*(1.E5/PSHLTR(I,J))**CAPPA - IF(TSHLTR(I,J)<200..OR.TSHLTR(I,J)>350.)THEN - WRITE(0,*)'Troublesome TSHLTR...I,J,TSHLTR,PSHLTR: ', & - I,J,TSHLTR(I,J),PSHLTR(I,J) - ENDIF - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Compute model layer containing the top of the boundary layer. -!----------------------------------------------------------------------- -! - IF(TRIM(TURBULENCE)/='myj')THEN - LENGTH_ROW=ITE_B1-ITS_B1+1 - DO J=JTS_B1,JTE_B1 - DO I=ITS_B1,ITE_B1 - LPBL(I,J)=-1000 - ENDDO - ENDDO -! -!....................................................................... -!$omp parallel do & -!$omp& private(j,kount_all,k,i,altitude) -!....................................................................... - DO J=JTS_B1,JTE_B1 - KOUNT_ALL=0 - find_Lpbl : DO K=LM,1,-1 - DO I=ITS_B1,ITE_B1 - ALTITUDE=Z(I,J,K)-SFCZ(I,J) - IF(PBLH(I,J)<=ALTITUDE.AND.LPBL(I,J)<0)THEN - LPBL(I,J)=K - KOUNT_ALL=KOUNT_ALL+1 - ENDIF - IF(KOUNT_ALL==LENGTH_ROW)EXIT find_Lpbl - ENDDO - ENDDO find_Lpbl - ENDDO -!....................................................................... -!$omp end parallel do -!....................................................................... - ENDIF -! - IF(SURFACE_PHYSICS==99 .OR. SURFACE_PHYSICS==LISSSCHEME)THEN - SNO_FACTR=1. - ELSE - SNO_FACTR=1000. - ENDIF - -!$omp parallel do private(j,i) - DO J=JTS_B1,JTE_B1 - DO I=ITS_B1,ITE_B1 - SNO(I,J)=SNOW(I,J) - SI(I,J)=SNOWH(I,J)*SNO_FACTR - ENDDO - ENDDO -!$omp end parallel do - -! -!----------------------------------------------------------------------- -!*** Diagnostic radiation accumulation. -!----------------------------------------------------------------------- -! -!....................................................................... -!$omp parallel do private(j,i,tsfc2) -!....................................................................... - DO J=JTS_B1,JTE_B1 - DO I=ITS_B1,ITE_B1 -!-- Remove the next 2 lines and uncomment "!was" lines below if not correct - TSFC2=TSFC(I,J)*TSFC(I,J) - RADOT(I,J)=EPSR(I,J)*STBOLT*TSFC2*TSFC2 -! - ASWIN (I,J)=ASWIN (I,J)+RSWIN(I,J)*FACTRS(I,J) - ASWOUT(I,J)=ASWOUT(I,J)-RSWOUT(I,J)*FACTRS(I,J) - ASWTOA(I,J)=ASWTOA(I,J)+RSWTOA(I,J)*FACTRS(I,J) - ALWIN (I,J)=ALWIN (I,J)+RLW_DN_SFC(I,J) - ALWOUT(I,J)=ALWOUT(I,J)-RADOT (I,J) - ALWTOA(I,J)=ALWTOA(I,J)+RLWTOA(I,J) -!was TSFC2=TSFC(I,J)*TSFC(I,J) -!was RADOT(I,J)=EPSR(I,J)*STBOLT*TSFC2*TSFC2 - THS(I,J)=TSFC(I,J)*EXNSFC(I,J) - PREC(I,J)=0. - ENDDO - ENDDO -!....................................................................... -!$omp end parallel do -!....................................................................... -! -!======================================================================= -!=== Begin gravity wave drag (GWD) and mountain blocking (MB) ======== -!======================================================================= -! - IF(GWDFLG) THEN - - CALL GWD_DRIVER(DTPHS,U_PHY,V_PHY,T,Q & - ,Z,DELP & - ,PHINT,PHMID,EXNER & - ,LPBL & - ,HSTDV,HCNVX,HASYW,HASYS & - ,HASYSW,HASYNW,HLENW & - ,HLENS,HLENSW,HLENNW & - ,HANGL,HANIS,HSLOP,HZMAX & - ,CROT,SROT & - ,CDMB,CLEFF,SIGFAC,FACTOP,RLOLEV,DPMIN & - ,DUDT_GWD,DVDT_GWD & - ,GLOBAL & - ,IDS,IDE,JDS,JDE & - ,IMS,IME,JMS,JME & - ,ITS,ITE,JTS,JTE,LM ) - -!$omp parallel do private(k,j,i) - DO K=1,LM - DO J=JMS,JME - DO I=IMS,IME - DUDT(I,J,K)=DUDT(I,J,K)+DUDT_GWD(I,J,K) - DVDT(I,J,K)=DVDT(I,J,K)+DVDT_GWD(I,J,K) - ENDDO - ENDDO - ENDDO -!$omp end parallel do - - ENDIF -! -!======================================================================= -!===== End gravity wave drag (GWD) and mountain blocking (MB) ======== -!======================================================================= -! -!----------------------------------------------------------------------- -!*** Update temperature, specific humidity, cloud, and q2. -!----------------------------------------------------------------------- -! - -!....................................................................... -!$omp parallel do & -!$omp& private(j,k,i,QCW,QRain,QCI,QSnow,QGraup) -!....................................................................... - DO K=1,LM - DO J=JTS_B1,JTE_B1 - DO I=ITS_B1,ITE_B1 - T(I,J,K)=T(I,J,K)+DTPHS*RTHBLTEN(I,J,K)*EXNER(I,J,K) - Q(I,J,K)=Q(I,J,K)+RQBLTEN(I,J,K)*DTPHS -! Q(I,J,K)=MAX(Q(I,J,K),EPSQ) - QC(I,J,K)=MAX(0.,QC(I,J,K)+RQCBLTEN(I,J,K)*DTPHS ) - QCW=QC(I,J,K) - QRain=0. - QCI=0. - QSnow=0. - QGraup=0. - IF(F_QR) QRain=QR(I,J,K) - IF(F_QI) THEN - QCI=MAX(0.,QI(I,J,K)+RQIBLTEN(I,J,K)*DTPHS ) - QI(I,J,K)=QCI - ENDIF - IF(F_QS) QSnow=QS(I,J,K) - IF(F_QG .AND. .NOT.FER_MIC) QGraup=QG(I,J,K) -!-- Couple CWM, F_ice, & F_rain arrays - CWM(I,J,K)=QCW+QRain+QCI+QSnow+QGraup - F_ICE(I,J,K)=0. - F_RAIN(I,J,K)=0. - IF(CWM(I,J,K)>EPSQ) F_ICE(I,J,K)=(QCI+QSnow+QGraup)/CWM(I,J,K) - IF(QRain>EPSQ) F_RAIN(I,J,K)=QRain/(QCW+QRain) - ENDDO - ENDDO - - ENDDO -!....................................................................... -!$omp end parallel do -!....................................................................... -! -!----------------------------------------------------------------------- -!*** -!*** Save surface-related fields. -!*** -!----------------------------------------------------------------------- -! - XLVRW=DTPHS/(XLV*RHOWATER) -!....................................................................... -!$omp parallel do private(j,i) -!....................................................................... - DO J=JTS_B1,JTE_B1 - DO I=ITS_B1,ITE_B1 -! -!----------------------------------------------------------------------- -!*** Instantaneous sensible and latent heat fluX -!----------------------------------------------------------------------- -! - TWBS(I,J)=-TWBS(I,J) - QWBS(I,J)= -QWBS(I,J)*XLV*CHKLOWQ(I,J) -! -!----------------------------------------------------------------------- -!*** Accumulated quantities. -!*** In opnl LSM, SFCEVP appears to be in units of -!*** meters of liquid water. It is coming from -!*** WRF module as kg/m**2. -!----------------------------------------------------------------------- -! - SFCSHX(I,J)=SFCSHX(I,J)+TWBS(I,J) - SFCLHX(I,J)=SFCLHX(I,J)+QWBS(I,J) - SFCEVP(I,J)=SFCEVP(I,J)-QWBS(I,J)*XLVRW - POTEVP(I,J)=POTEVP(I,J)-QWBS(I,J)*SM(I,J)*XLVRW - POTFLX(I,J)=POTEVP(I,J)*FACTOR - SUBSHX(I,J)=SUBSHX(I,J)+GRNFLX(I,J) - ENDDO - ENDDO -!....................................................................... -!$omp end parallel do -!....................................................................... -! -!----------------------------------------------------------------------- -!*** COUNTERS (need to make 2D arrays so fields can be updated in ESMF) -!----------------------------------------------------------------------- -! -!$omp parallel do private(j,i) - DO J=JTS,JTE - DO I=ITS,ITE - APHTIM(I,J)=APHTIM(I,J)+1. - ARDSW(I,J) =ARDSW(I,J) +1. - ARDLW(I,J) =ARDLW(I,J) +1. - ASRFC(I,J) =ASRFC(I,J) +1. - ENDDO - ENDDO -!$omp end parallel do - - END SUBROUTINE TURBL -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - END MODULE MODULE_TURBULENCE -! -!----------------------------------------------------------------------- diff --git a/src/nmm/module_VARS.F90 b/src/nmm/module_VARS.F90 deleted file mode 100644 index 5b4bc41..0000000 --- a/src/nmm/module_VARS.F90 +++ /dev/null @@ -1,509 +0,0 @@ -!----------------------------------------------------------------------- - - MODULE MODULE_VARS - -!----------------------------------------------------------------------- -!*** This module contains the routine that reads in the text files -!*** in which the user has specified internal state variables from -!*** the Solver component to be: -!*** (1) In the history output -!*** (2) In the restart output -!*** (3) 'Owned' (allocated) by the component -!*** (4) In the component's import state -!*** (5) In the component's export state -! -!*** and contains the routines that allocate memory within the -!*** general VARS composite variable and then point the 'Owned' -!*** internal state variables into that memory. -!----------------------------------------------------------------------- - - USE MODULE_KINDS - -!----------------------------------------------------------------------- - IMPLICIT NONE - - PRIVATE - PUBLIC :: VAR - PUBLIC :: TKR_I0D,TKR_I1D,TKR_I2D,TKR_R0D,TKR_R1D,TKR_R2D,TKR_R3D,TKR_R4D - PUBLIC :: READ_CONFIG - PUBLIC :: SET_VAR_PTR - PUBLIC :: DEALLOC_VARS - PUBLIC :: FIND_VAR_INDX - - TYPE VAR - - CHARACTER(LEN=32) :: VBL_NAME = '' - LOGICAL :: HISTORY = .FALSE. - LOGICAL :: HISTORY_P= .FALSE. - LOGICAL :: RESTART = .FALSE. - LOGICAL :: RESTART_P= .FALSE. - LOGICAL :: OWNED = .FALSE. - LOGICAL :: IMPORT = .FALSE. - LOGICAL :: EXPORT = .FALSE. - LOGICAL :: TSERIES = .FALSE. - LOGICAL :: TSERIES_P= .FALSE. - CHARACTER(LEN=128) :: DESCRIPTION = '' - - INTEGER :: TKR = 0 - - INTEGER ,POINTER :: I0D => NULL() - INTEGER,DIMENSION(:) ,POINTER :: I1D => NULL() - INTEGER,DIMENSION(:,:) ,POINTER :: I2D => NULL() - REAL ,POINTER :: R0D => NULL() - REAL ,DIMENSION(:) ,POINTER :: R1D => NULL() - REAL ,DIMENSION(:,:) ,POINTER :: R2D => NULL() - REAL ,DIMENSION(:,:,:) ,POINTER :: R3D => NULL() - REAL ,DIMENSION(:,:,:,:),POINTER :: R4D => NULL() - - END TYPE VAR - - INTEGER,PARAMETER :: TKR_I0D =1000 !<-- These are simply codes that designate - INTEGER,PARAMETER :: TKR_I1D =1001 ! whether an internal state variable - INTEGER,PARAMETER :: TKR_I2D =1002 ! inside of the VARS array is integer - INTEGER,PARAMETER :: TKR_R0D =1003 ! scalar, 1-d integer array, etc. - INTEGER,PARAMETER :: TKR_R1D =1004 ! so the type can be referred to easily. - INTEGER,PARAMETER :: TKR_R2D =1005 ! - INTEGER,PARAMETER :: TKR_R3D =1006 ! - INTEGER,PARAMETER :: TKR_R4D =1007 !<-- - - INTERFACE SET_VAR_PTR - MODULE PROCEDURE SET_VAR_PTR_I0D - MODULE PROCEDURE SET_VAR_PTR_I1D - MODULE PROCEDURE SET_VAR_PTR_I2D - MODULE PROCEDURE SET_VAR_PTR_R1D - MODULE PROCEDURE SET_VAR_PTR_R0D - MODULE PROCEDURE SET_VAR_PTR_R2D - MODULE PROCEDURE SET_VAR_PTR_R3D - MODULE PROCEDURE SET_VAR_PTR_R4D - END INTERFACE SET_VAR_PTR - - CONTAINS - -!####################################################################### - - SUBROUTINE READ_CONFIG(FNAME,MYPE,VARS,NUM_VARS,RC) - -!----------------------------------------------------------------------- -!*** Read the text file for the Solver component that specifies -!*** internal state variables for History, Restart, Import, or -!*** eXport. -!----------------------------------------------------------------------- - - IMPLICIT NONE - INTEGER, INTENT(IN) :: MYPE - CHARACTER(LEN=*), INTENT(IN) :: FNAME - TYPE(VAR), DIMENSION(:), INTENT(INOUT) :: VARS - INTEGER, INTENT(OUT) :: NUM_VARS - INTEGER, INTENT(OUT) :: RC - - INTEGER :: IERR,N,IOS,NVARS - CHARACTER(LEN=256) :: STRING - CHARACTER(LEN=1) :: CH_H,CH_R,CH_O,CH_I,CH_X,CH_T - -!----------------------------------------------------------------------- - - RC = 0 - - NVARS = SIZE(VARS) !<-- Max # of variables MAX_VARS set in internal state modules - N = 0 - OPEN(UNIT=10,FILE=FNAME,STATUS='OLD',ACTION='READ',IOSTAT=IERR) !<-- Open the text file with user specifications - IF(IERR/=0)THEN - WRITE(0,*)' Unable to open file ',TRIM(FNAME) & - ,' in READ_CONFIG' - RC = -1 - RETURN - ENDIF - - read_specs: DO WHILE(.TRUE.) - - READ(UNIT=10,FMT="(A)",IOSTAT=ios) STRING !<-- Insert each variable's specification line into STRING - IF (IOS/=0) EXIT !<-- We have now read specification lines for all variables - IF (STRING(1:1)=='#') CYCLE - IF (TRIM(STRING)=='') CYCLE - N = N + 1 - IF (N > NVARS) THEN !<-- # of variables exceeds MAX_VARS - WRITE(0,*)' increase the size of VARS array ', NVARS - STOP - END IF -! -!--------------------------------------------------------------------- -!*** Read the text line containing the specifications for variable N -!--------------------------------------------------------------------- -! - READ(UNIT=STRING,FMT=*,IOSTAT=ios) VARS(N)%VBL_NAME,CH_H,CH_R,CH_O,CH_I,CH_X,CH_T,VARS(N)%DESCRIPTION - - IF (IOS/=0) THEN - IF (IOS>0) THEN - WRITE(0,*)' error while reading ',FNAME,' on line : ',TRIM(STRING),' iostat = ',ios - STOP - ELSE - N = N - 1 - EXIT - END IF - END IF -! -!------------------------------------------------ -!*** 'Turn on' and store the those qualities -!*** that the user specified in the text file -!*** for variable N. -!------------------------------------------------ - - IF (CH_H=='H') VARS(N)%HISTORY=.TRUE. - IF (CH_H=='P') VARS(N)%HISTORY_P=.TRUE. - IF (CH_R=='R') VARS(N)%RESTART=.TRUE. - IF (CH_R=='S') VARS(N)%RESTART_P=.TRUE. - IF (CH_O=='O') VARS(N)%OWNED =.TRUE. - IF (CH_I=='I') VARS(N)%IMPORT =.TRUE. - IF (CH_X=='X') VARS(N)%EXPORT =.TRUE. - IF (CH_T=='T') VARS(N)%TSERIES=.TRUE. - IF (CH_T=='t') VARS(N)%TSERIES_P=.TRUE. - - END DO read_specs - - NUM_VARS = N - IF (MYPE==0) THEN - WRITE(0,*)' NUM_VARS in ',TRIM(FNAME),' ',NUM_VARS - ENDIF - - CLOSE(UNIT=10) - - END SUBROUTINE READ_CONFIG - -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - - SUBROUTINE SET_VAR_PTR_I0D (VARS,NUM_VARS,VBL_NAME,I0D) - -!-------------------------------------------------------------------- -!*** Allocate memory for 'Owned' integer scalars in the Solver -!*** internal state if so directed by ALLOC_FLAG and point those -!*** variables into that memory. -!-------------------------------------------------------------------- - - IMPLICIT NONE - TYPE(VAR), DIMENSION(:), INTENT(INOUT) :: VARS - INTEGER, INTENT(IN) :: NUM_VARS - CHARACTER(LEN=*), INTENT(IN) :: VBL_NAME - INTEGER ,POINTER :: I0D - - INTEGER :: INDX - -!----------------------------------------------------------------------- - - CALL FIND_VAR_INDX(VBL_NAME,VARS,NUM_VARS,INDX) - IF (VARS(INDX)%OWNED) THEN - ALLOCATE(VARS(INDX)%I0D) !<-- Allocate an integer scalar pointer for input I0D - VARS(INDX)%I0D=I4_IN - END IF - I0D => VARS(INDX)%I0D !<-- Internal state variable I0D uses the newly allocated space - VARS(INDX)%TKR = TKR_I0D - - END SUBROUTINE SET_VAR_PTR_I0D - -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - - SUBROUTINE SET_VAR_PTR_R0D (VARS,NUM_VARS,VBL_NAME,R0D) - -!-------------------------------------------------------------------- -!*** Allocate memory for 'Owned' real scalars in the Solver -!*** internal state if so directed by ALLOC_FLAG and point -!*** those variables into that memory. -!-------------------------------------------------------------------- - - IMPLICIT NONE - TYPE(VAR), DIMENSION(:), INTENT(INOUT) :: VARS - INTEGER, INTENT(IN) :: NUM_VARS - CHARACTER(LEN=*), INTENT(IN) :: VBL_NAME - REAL ,POINTER :: R0D - - INTEGER :: INDX - -!----------------------------------------------------------------------- - - CALL FIND_VAR_INDX(VBL_NAME,VARS,NUM_VARS,INDX) - IF (VARS(INDX)%OWNED) THEN - ALLOCATE(VARS(INDX)%R0D) - VARS(INDX)%R0D=R4_IN - END IF - R0D => VARS(INDX)%R0D - VARS(INDX)%TKR = TKR_R0D - - END SUBROUTINE SET_VAR_PTR_R0D - -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - - SUBROUTINE SET_VAR_PTR_I1D (VARS,NUM_VARS,VBL_NAME,I1D,lowbound,upbound) - -!----------------------------------------------------------------------- -!*** Allocate memory for 'Owned' integer 1-D arrays in the Solver -!*** internal state if so directed by ALLOC_FLAG and point those -!*** variables into that memory. -!----------------------------------------------------------------------- - - IMPLICIT NONE - TYPE(VAR), DIMENSION(:), INTENT(INOUT) :: VARS - INTEGER, INTENT(IN) :: NUM_VARS - CHARACTER(LEN=*), INTENT(IN) :: VBL_NAME - INTEGER, DIMENSION(:), POINTER :: I1D - INTEGER, INTENT(IN) :: lowbound,upbound - - INTEGER :: INDX - -!----------------------------------------------------------------------- - - CALL FIND_VAR_INDX(VBL_NAME,VARS,NUM_VARS,INDX) - IF (VARS(INDX)%OWNED) THEN - ALLOCATE (VARS(INDX)%I1D(lowbound:upbound)) - VARS(INDX)%I1D=I4_IN - END IF - I1D => VARS(INDX)%I1D - VARS(INDX)%TKR = TKR_I1D - - END SUBROUTINE SET_VAR_PTR_I1D - -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - - SUBROUTINE SET_VAR_PTR_I2D (VARS,NUM_VARS,VBL_NAME,I2D,lowbound,upbound) - -!----------------------------------------------------------------------- -!*** Allocate memory for 'Owned' integer 2-D arrays in the Solver -!*** internal state if so directed by ALLOC_FLAG and point those -!*** variables into that memory. -!----------------------------------------------------------------------- - - IMPLICIT NONE - TYPE(VAR), DIMENSION(:), INTENT(INOUT) :: VARS - INTEGER, INTENT(IN) :: NUM_VARS - CHARACTER(LEN=*), INTENT(IN) :: VBL_NAME - INTEGER,DIMENSION(:,:) ,POINTER :: I2D - INTEGER, DIMENSION(2), INTENT(IN) :: lowbound,upbound - - INTEGER :: INDX - -!----------------------------------------------------------------------- - - CALL FIND_VAR_INDX(VBL_NAME,VARS,NUM_VARS,INDX) - IF (VARS(INDX)%OWNED) THEN - ALLOCATE (VARS(INDX)%I2D(lowbound(1):upbound(1), & - lowbound(2):upbound(2) )) - VARS(INDX)%I2D=I4_IN - END IF - I2D => VARS(INDX)%I2D - VARS(INDX)%TKR = TKR_I2D - - END SUBROUTINE SET_VAR_PTR_I2D - -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - - SUBROUTINE SET_VAR_PTR_R1D (VARS,NUM_VARS,VBL_NAME,R1D,lowbound,upbound) - -!----------------------------------------------------------------------- -!*** Allocate memory for 'Owned' real 1-D arrays in the Solver -!*** internal state if so directed by ALLOC_FLAG and point those -!*** variables into that memory. -!----------------------------------------------------------------------- - - IMPLICIT NONE - TYPE(VAR), DIMENSION(:), INTENT(INOUT) :: VARS - INTEGER, INTENT(IN) :: NUM_VARS - CHARACTER(LEN=*), INTENT(IN) :: VBL_NAME - REAL, DIMENSION(:), POINTER :: R1D - INTEGER, INTENT(IN) :: lowbound,upbound - - INTEGER :: INDX - -!----------------------------------------------------------------------- - - CALL FIND_VAR_INDX(VBL_NAME,VARS,NUM_VARS,INDX) - IF (VARS(INDX)%OWNED) THEN - ALLOCATE (VARS(INDX)%R1D(lowbound:upbound)) - VARS(INDX)%R1D=R4_IN - END IF - R1D => VARS(INDX)%R1D - VARS(INDX)%TKR = TKR_R1D - - END SUBROUTINE SET_VAR_PTR_R1D - -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - - SUBROUTINE SET_VAR_PTR_R2D (VARS,NUM_VARS,VBL_NAME,R2D,lowbound,upbound) - -!----------------------------------------------------------------------- -!*** Allocate memory for 'Owned' real 2-D arrays in the Solver -!*** internal state if so directed by ALLOC_FLAG and point those -!*** variables into that memory. -!----------------------------------------------------------------------- - - IMPLICIT NONE - TYPE(VAR), DIMENSION(:), INTENT(INOUT) :: VARS - INTEGER, INTENT(IN) :: NUM_VARS - CHARACTER(LEN=*), INTENT(IN) :: VBL_NAME - REAL ,DIMENSION(:,:) ,POINTER :: R2D - INTEGER, DIMENSION(2), INTENT(IN) :: lowbound,upbound - - INTEGER :: INDX - -!----------------------------------------------------------------------- - - CALL FIND_VAR_INDX(VBL_NAME,VARS,NUM_VARS,INDX) - IF (VARS(INDX)%OWNED) THEN - ALLOCATE (VARS(INDX)%R2D(lowbound(1):upbound(1), & - lowbound(2):upbound(2) )) - VARS(INDX)%R2D=R4_IN - END IF - R2D => VARS(INDX)%R2D - VARS(INDX)%TKR = TKR_R2D - - END SUBROUTINE SET_VAR_PTR_R2D - -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - - SUBROUTINE SET_VAR_PTR_R3D (VARS,NUM_VARS,VBL_NAME,R3D,lowbound,upbound) - -!----------------------------------------------------------------------- -!*** Allocate memory for 'Owned' real 3-D arrays in the Solver -!*** internal state if so directed by ALLOC_FLAG and point those -!*** variables into that memory. -!----------------------------------------------------------------------- - - IMPLICIT NONE - TYPE(VAR), DIMENSION(:), INTENT(INOUT) :: VARS - INTEGER, INTENT(IN) :: NUM_VARS - CHARACTER(LEN=*), INTENT(IN) :: VBL_NAME - REAL ,DIMENSION(:,:,:),POINTER :: R3D - INTEGER, DIMENSION(3), INTENT(IN) :: lowbound,upbound - - INTEGER :: INDX - -!----------------------------------------------------------------------- - - CALL FIND_VAR_INDX(VBL_NAME,VARS,NUM_VARS,INDX) - IF (VARS(INDX)%OWNED) THEN - ALLOCATE (VARS(INDX)%R3D(lowbound(1):upbound(1), & - lowbound(2):upbound(2), & - lowbound(3):upbound(3) )) - VARS(INDX)%R3D=R4_IN - END IF - R3D => VARS(INDX)%R3D - VARS(INDX)%TKR = TKR_R3D - - END SUBROUTINE SET_VAR_PTR_R3D - -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - - SUBROUTINE SET_VAR_PTR_R4D (VARS,NUM_VARS,VBL_NAME,R4D,lowbound,upbound) - -!----------------------------------------------------------------------- -!*** Allocate memory for 'Owned' real 4-D arrays in the Solver -!*** internal state if so directed by ALLOC_FLAG and point those -!*** variables into that memory. -!----------------------------------------------------------------------- - - IMPLICIT NONE - TYPE(VAR), DIMENSION(:), INTENT(INOUT) :: VARS - INTEGER, INTENT(IN) :: NUM_VARS - CHARACTER(LEN=*), INTENT(IN) :: VBL_NAME - REAL ,DIMENSION(:,:,:,:),POINTER :: R4D - INTEGER, DIMENSION(4), INTENT(IN) :: lowbound,upbound - - INTEGER :: INDX - -!----------------------------------------------------------------------- - - CALL FIND_VAR_INDX(VBL_NAME,VARS,NUM_VARS,INDX) - IF (VARS(INDX)%OWNED) THEN - ALLOCATE (VARS(INDX)%R4D(lowbound(1):upbound(1), & - lowbound(2):upbound(2), & - lowbound(3):upbound(3), & - lowbound(4):upbound(4) )) - VARS(INDX)%R4D=R4_IN - END IF - R4D => VARS(INDX)%R4D - VARS(INDX)%TKR = TKR_R4D - - END SUBROUTINE SET_VAR_PTR_R4D - -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - - SUBROUTINE DEALLOC_VARS(VARS,NUM_VARS) - -!---------------------------------------------------------------------- -!*** Deallocate the memory that had been allocated within the VARS -!*** composite array into which Solver internal state variables are -!*** pointing. -!---------------------------------------------------------------------- - - IMPLICIT NONE - - TYPE(VAR), DIMENSION(:), INTENT(INOUT) :: VARS - INTEGER, INTENT(IN) :: NUM_VARS - - INTEGER :: N - INTEGER :: ISTAT - -!----------------------------------------------------------------------- - - DO N=1,NUM_VARS - IF (VARS(N)%OWNED) THEN - SELECT CASE(VARS(N)%TKR) - CASE(TKR_I0D) - DEALLOCATE(VARS(N)%I0D,STAT=ISTAT) - CASE(TKR_I1D) - DEALLOCATE(VARS(N)%I1D,STAT=ISTAT) - CASE(TKR_I2D) - DEALLOCATE(VARS(N)%I2D,STAT=ISTAT) - CASE(TKR_R0D) - DEALLOCATE(VARS(N)%R0D,STAT=ISTAT) - CASE(TKR_R1D) - DEALLOCATE(VARS(N)%R1D,STAT=ISTAT) - CASE(TKR_R2D) - DEALLOCATE(VARS(N)%R2D,STAT=ISTAT) - CASE(TKR_R3D) - DEALLOCATE(VARS(N)%R3D,STAT=ISTAT) - CASE(TKR_R4D) - DEALLOCATE(VARS(N)%R4D,STAT=ISTAT) - CASE DEFAULT - write(0,*)' Unknown TKR in DEALLOC_VARS ', VARS(N)%VBL_NAME, VARS(N)%TKR - stop 9 - END SELECT - END IF - END DO - - END SUBROUTINE DEALLOC_VARS - -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - - SUBROUTINE FIND_VAR_INDX(VBL_NAME,VARS,NUM_VARS,INDX) - -!---------------------------------------------------------------- -!*** Find the location (index) within the VARS array with which -!*** the internal state variable called VBL_NAME is associated. -!---------------------------------------------------------------- - USE MPI - IMPLICIT NONE - - CHARACTER(LEN=*), INTENT(IN) :: VBL_NAME - TYPE(VAR), DIMENSION(:), INTENT(IN) :: VARS - INTEGER, INTENT(IN) :: NUM_VARS - INTEGER, INTENT(OUT) :: INDX - - INTEGER :: I,IERR - - INDX = 0 - DO I=1,NUM_VARS - IF (TRIM(VBL_NAME) == TRIM(VARS(I)%VBL_NAME) ) THEN - INDX = I - EXIT - END IF - END DO - IF (INDX == 0) THEN -138 format(' can not find |',A,'| in solver state text file.') - write(0,138) trim(VBL_NAME) - call MPI_Abort(MPI_COMM_WORLD,2,ierr) - stop 2 - END IF - - END SUBROUTINE FIND_VAR_INDX - -!####################################################################### - - END MODULE MODULE_VARS diff --git a/src/nmm/module_VARS_STATE.F90 b/src/nmm/module_VARS_STATE.F90 deleted file mode 100644 index 92fd766..0000000 --- a/src/nmm/module_VARS_STATE.F90 +++ /dev/null @@ -1,927 +0,0 @@ -!------------------------------------------------------------------------------- - - MODULE MODULE_VARS_STATE - -!------------------------------------------------------------------------------- - - USE ESMF - USE MODULE_VARS - USE module_CONTROL,ONLY: TIMEF - - IMPLICIT NONE - - PRIVATE - PUBLIC :: PUT_VARS_IN_STATE - PUBLIC :: GET_VARS_FROM_STATE - PUBLIC :: DELETE_FIELDS_FROM_STATE - PUBLIC :: PUT_VARS_IN_BUNDLES - - integer,parameter :: double=selected_real_kind(p=13,r=200) - integer,parameter:: kdbl=double - real(kind=kdbl) :: btim,btim0 - - CONTAINS - -!############################################################################### - - SUBROUTINE PUT_VARS_IN_STATE(VARS, NUM_VARS, STATE_TYPE, GRID, STATE) - -!------------------------------------------------------------------------------- -!*** Put pointers of variables in the composite VARS array into a given -!*** ESMF import/export state. -!------------------------------------------------------------------------------- - - IMPLICIT NONE - - TYPE(VAR), DIMENSION(:), INTENT(IN) :: VARS - INTEGER, INTENT(IN) :: NUM_VARS - CHARACTER(LEN=1), INTENT(IN) :: STATE_TYPE - TYPE(ESMF_Grid), INTENT(IN) :: GRID - TYPE(ESMF_State ), INTENT(INOUT) :: STATE - - TYPE(ESMF_StateItem_Flag):: stateItemType - TYPE(ESMF_Field) :: FIELD - INTEGER :: KOUNT,N, RC - INTEGER :: IHALO,JHALO - -!------------------------------------------------------------------------------- - -!!!!!!!!! FIX this later -!!!!!!!!! FIX this later - IHALO = 3 - JHALO = 3 -!!!!!!!!! FIX this later -!!!!!!!!! FIX this later - - DO N=1,NUM_VARS - IF (( (STATE_TYPE == 'I') .AND. VARS(N)%IMPORT ) .OR. & - ( (STATE_TYPE == 'X') .AND. VARS(N)%EXPORT ) ) THEN - - SELECT CASE(VARS(N)%TKR) - CASE(TKR_I0D) - CALL ESMF_AttributeSet(state=STATE ,name=VARS(N)%VBL_NAME, value=VARS(N)%I0D, rc=RC) - CASE(TKR_I1D) - CASE(TKR_I2D) - CASE(TKR_R0D) - CALL ESMF_AttributeSet(state=STATE ,name=VARS(N)%VBL_NAME, value=VARS(N)%R0D, rc=RC) - CASE(TKR_R1D) - KOUNT=SIZE(VARS(N)%R1D) - CALL ESMF_AttributeSet(state=STATE ,name=VARS(N)%VBL_NAME, itemCount=KOUNT, valueList=VARS(N)%R1D, rc=RC) - CASE(TKR_R2D) - CALL ESMF_StateGet(STATE ,VARS(N)%VBL_NAME , stateItemType, rc=RC) - IF (stateItemType==ESMF_STATEITEM_NOTFOUND) THEN - FIELD = ESMF_FieldCreate(grid =GRID & - ,farray =VARS(N)%R2D & - ,totalUWidth=(/IHALO,JHALO/) & !<-- Upper bound of halo region - ,totalLWidth=(/IHALO,JHALO/) & !<-- Lower bound of halo region - ,name =VARS(N)%VBL_NAME & - ,indexFlag =ESMF_INDEX_GLOBAL & - ,rc =RC) - CALL ESMF_StateAddReplace(STATE ,(/FIELD/) ,rc=RC) - ENDIF - CASE(TKR_R3D) - CALL ESMF_StateGet(STATE ,VARS(N)%VBL_NAME ,stateItemType, rc=RC) - IF (stateItemType==ESMF_STATEITEM_NOTFOUND .and. ASSOCIATED(VARS(N)%R3D)) THEN - FIELD = ESMF_FieldCreate(grid =GRID & - ,farray =VARS(N)%R3D & - ,totalUWidth =(/IHALO,JHALO/) & !<-- Upper bound of halo region - ,totalLWidth =(/IHALO,JHALO/) & !<-- Lower bound of halo region - ,ungriddedLBound =(/ lbound(VARS(N)%R3D,dim=3) /) & - ,ungriddedUBound =(/ ubound(VARS(N)%R3D,dim=3) /) & - ,name =VARS(N)%VBL_NAME & - ,indexFlag =ESMF_INDEX_GLOBAL & - ,rc =RC) - CALL ESMF_StateAddReplace(STATE ,(/FIELD/) ,rc=RC) - ENDIF - CASE(TKR_R4D) - CALL ESMF_StateGet(STATE ,VARS(N)%VBL_NAME ,stateItemType, rc=RC) - IF (stateItemType==ESMF_STATEITEM_NOTFOUND) THEN - FIELD = ESMF_FieldCreate(grid =GRID & - ,farray =VARS(N)%R4D & - ,totalUWidth =(/IHALO,JHALO/) & !<-- Upper bound of halo region - ,totalLWidth =(/IHALO,JHALO/) & !<-- Lower bound of halo region - ,ungriddedLBound =(/ lbound(VARS(N)%R4D,dim=3),lbound(VARS(N)%R4D,dim=4) /) & - ,ungriddedUBound =(/ ubound(VARS(N)%R4D,dim=3),ubound(VARS(N)%R4D,dim=4) /) & - ,name =VARS(N)%VBL_NAME & - ,indexFlag =ESMF_INDEX_GLOBAL & - ,rc =RC) - CALL ESMF_StateAddReplace(STATE ,(/FIELD/),rc=RC) - ENDIF - CASE DEFAULT - write(0,*)' TKR = ', VARS(N)%TKR, TRIM(VARS(N)%VBL_NAME) - write(0,*)' This TKR Case not available in PUT_VARS_IN_STATE' - write(0,*)' ABORTING!' - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT & - ,rc =RC) - END SELECT - - ENDIF - END DO - - END SUBROUTINE PUT_VARS_IN_STATE - -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - - SUBROUTINE GET_VARS_FROM_STATE(VARS, NUM_VARS, STATE) - -!------------------------------------------------------------------------------- -!*** Take allocated pointers from a given ESMF state and point VARS -!*** locations at them if the VARS variable is unowned/unallocated -!*** or move the pointer data into the VARS location if owned by -!*** multiple components. -!------------------------------------------------------------------------------- - - IMPLICIT NONE - - TYPE(VAR), DIMENSION(:), INTENT(INOUT) :: VARS - INTEGER, INTENT(IN) :: NUM_VARS - - TYPE(ESMF_State ), INTENT(INOUT) :: STATE - - TYPE(ESMF_Field) :: FIELD - INTEGER :: KOUNT,N, RC - INTEGER :: HOLD_I0D - INTEGER,DIMENSION(:) ,POINTER :: HOLD_I1D - INTEGER,DIMENSION(:,:) ,POINTER :: HOLD_I2D - REAL :: HOLD_R0D - REAL ,DIMENSION(:) ,POINTER :: HOLD_R1D - REAL ,DIMENSION(:,:) ,POINTER :: HOLD_R2D - REAL ,DIMENSION(:,:,:) ,POINTER :: HOLD_R3D - REAL ,DIMENSION(:,:,:,:),POINTER :: HOLD_R4D - CHARACTER(LEN=32) :: VBL_NAME - -!------------------------------------------------------------------------------- - - DO N=1,NUM_VARS - IF ( VARS(N)%IMPORT ) THEN - VBL_NAME = TRIM(VARS(N)%VBL_NAME) - SELECT CASE(VARS(N)%TKR) - CASE(TKR_I0D) - CALL ESMF_AttributeGet(state=STATE ,name=VARS(N)%VBL_NAME, value=VARS(N)%I0D, rc=RC) - if (rc/=ESMF_SUCCESS) then - write(0,*)' Unable to get VBL_NAME for CASE(TKR_I0D) in GET_VARS_FROM_STATE' - write(0,*)' ABORTING!' - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT & - ,rc =RC) - end if - CASE(TKR_I1D) - write(0,*)' not implemented TKR_I1D in GET_VARS_FROM_STATE ' - write(0,*)' ABORTING!' - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT & - ,rc =RC) - CASE(TKR_I2D) - CALL ESMF_StateGet(STATE ,VBL_NAME ,FIELD ,rc=RC) - if (rc/=ESMF_SUCCESS) then - write(0,*)' Unable to get VBL_NAME for CASE(TKR_I2D) in GET_VARS_FROM_STATE' - write(0,*)' ABORTING!' - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT & - ,rc =RC) - end if - - CALL ESMF_FieldGet(field=FIELD ,localDe=0 ,farrayPtr=HOLD_I2D ,rc=RC) - - if (rc/=ESMF_SUCCESS) then - write(0,*)' Unable to get 2D integer array from Field in GET_VARS_FROM_STATE' - write(0,*)' ABORTING!' - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT & - ,rc =RC) - end if - IF (VARS(N)%OWNED ) THEN - if (size(VARS(N)%I2D) /= size(HOLD_I2D) ) then - write(0,*)' size(VARS(N)%I2D) /= size(HOLD_I2D) in GET_VARS_FROM_STATE' - write(0,*)' ABORTING!' - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT & - ,rc =RC) - end if - VARS(N)%I2D = HOLD_I2D !<-- Transfer data since multiply owned - ELSE - VARS(N)%I2D => HOLD_I2D !<-- Point the appropriate unallocated VARS location at allocated pointer - END IF - CASE(TKR_R0D) - CALL ESMF_AttributeGet(state=STATE ,name=VARS(N)%VBL_NAME, value=VARS(N)%R0D, rc=RC) - if (rc/=ESMF_SUCCESS) then - write(0,*)' Unable to get VBL_NAME for CASE(TKR_R0D) in GET_VARS_FROM_STATE' - write(0,*)' ABORTING!' - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT & - ,rc =RC) - end if - CASE(TKR_R1D) - KOUNT=SIZE(VARS(N)%R1D) - CALL ESMF_AttributeGet(state=STATE ,name=VARS(N)%VBL_NAME, itemCount=KOUNT, valueList=VARS(N)%R1D, rc=RC) -!!! write(0,*)' not implemented TKR_R1D in UPDATE_VARS ' -!!! stop - CASE(TKR_R2D) - CALL ESMF_StateGet(state=STATE ,itemName=VBL_NAME ,field=FIELD ,rc=RC) - if (rc/=ESMF_SUCCESS) then - write(0,*)' Unable to get ',trim(VBL_NAME),' for CASE(TKR_R2D) in GET_VARS_FROM_STATE' - write(0,*)' ABORTING!' - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT & - ,rc =RC) - end if - - CALL ESMF_FieldGet(field=FIELD ,localDe=0 ,farrayPtr=HOLD_R2D ,rc=RC) - - if (rc/=ESMF_SUCCESS) then - write(0,*)' Unable to get 2D real array from Field in GET_VARS_FROM_STATE' - write(0,*)' ABORTING!' - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT & - ,rc =RC) - end if - IF (VARS(N)%OWNED ) THEN - if (size(VARS(N)%R2D) /= size(HOLD_R2D) ) then - write(0,*)' size(VARS(N)%R2D) /= size(HOLD_R2D) in GET_VARS_FROM_STATE' - write(0,*)' ABORTING!' - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT & - ,rc =RC) - end if - VARS(N)%R2D = HOLD_R2D !<-- Transfer data since multiply owned - ELSE - VARS(N)%R2D => HOLD_R2D !<-- Point the appropriate unallocated VARS location at allocated pointer - END IF - CASE(TKR_R3D) - CALL ESMF_StateGet(STATE ,VBL_NAME ,FIELD ,rc=RC) - if (rc/=ESMF_SUCCESS) then - write(0,*)' Unable to get VBL_NAME for CASE(TKR_R3D) in GET_VARS_FROM_STATE' - write(0,*)' ABORTING!' - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT & - ,rc =RC) - end if - - CALL ESMF_FieldGet(field=FIELD ,localDe=0 ,farrayPtr=HOLD_R3D ,rc=RC) - - if (rc/=ESMF_SUCCESS) then - write(0,*)' Unable to get 3D real array from Field in GET_VARS_FROM_STATE' - write(0,*)' ABORTING!' - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT & - ,rc =RC) - end if - IF (VARS(N)%OWNED ) THEN - if (size(VARS(N)%R3D) /= size(HOLD_R3D) ) then - write(0,*)TRIM(VARS(N)%VBL_NAME), size(VARS(N)%R3D), size(HOLD_R3D) - write(0,*)TRIM(VARS(N)%VBL_NAME), 'lbound ',lbound(VARS(N)%R3D), lbound(HOLD_R3D) - write(0,*)TRIM(VARS(N)%VBL_NAME), 'ubound ',ubound(VARS(N)%R3D), ubound(HOLD_R3D) - write(0,*)' VARS(N)%R3D) /= size(HOLD_R3D in GET_VARS_FROM_STATE' - write(0,*)' ABORTING!' - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT & - ,rc =RC) - end if - VARS(N)%R3D = HOLD_R3D !<-- Transfer data since multiply owned - ELSE - VARS(N)%R3D => HOLD_R3D !<-- Point the appropriate unallocated VARS location at allocated pointer - END IF - CASE(TKR_R4D) - CALL ESMF_StateGet(STATE ,VBL_NAME ,FIELD ,rc=RC) - if (rc/=ESMF_SUCCESS) then - write(0,*)' Unable to get VBL_NAME for CASE(TKR_R4D) in GET_VARS_FROM_STATE' - write(0,*)' ABORTING!' - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT & - ,rc =RC) - end if - - CALL ESMF_FieldGet(field=FIELD ,localDe=0 ,farrayPtr=HOLD_R4D ,rc=RC) - - if (rc/=ESMF_SUCCESS) then - write(0,*)' Unable to get 4D real array from Field in GET_VARS_FROM_STATE' - write(0,*)' ABORTING!' - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT & - ,rc =RC) - end if - IF (VARS(N)%OWNED ) THEN - if (size(VARS(N)%R4D) /= size(HOLD_R4D) ) then - write(0,*)TRIM(VARS(N)%VBL_NAME), size(VARS(N)%R4D), size(HOLD_R4D) - write(0,*)TRIM(VARS(N)%VBL_NAME), 'lbound ',lbound(VARS(N)%R4D), lbound(HOLD_R4D) - write(0,*)TRIM(VARS(N)%VBL_NAME), 'ubound ',ubound(VARS(N)%R4D), ubound(HOLD_R4D) - write(0,*)' size(VARS(N)%R4D) /= size(HOLD_R4D) in GET_VARS_FROM_STATE' - write(0,*)' ABORTING!' - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT & - ,rc =RC) - end if - VARS(N)%R4D = HOLD_R4D !<-- Transfer data since multiply owned - ELSE - VARS(N)%R4D => HOLD_R4D !<-- Point the appropriate unallocated VARS location at allocated pointer - END IF - CASE DEFAULT - write(0,*)' TKR = ', VARS(N)%TKR, TRIM(VARS(N)%VBL_NAME) - write(0,*)' This TKR Case is not available in GET_VARS_FROM_STATE' - write(0,*)' ABORTING!' - CALL ESMF_FINALIZE(endflag=ESMF_END_ABORT & - ,rc =RC) - END SELECT - - END IF - END DO - - END SUBROUTINE GET_VARS_FROM_STATE - -!------------------------------------------------------------------------------- -!############################################################################### -!------------------------------------------------------------------------------- - - SUBROUTINE DELETE_FIELDS_FROM_STATE(STATE) - - IMPLICIT NONE - - TYPE(ESMF_State ), INTENT(INOUT) :: STATE - - INTEGER :: RC - INTEGER :: i, itemcount - TYPE(ESMF_Field) :: FIELD - - CHARACTER(LEN=10), DIMENSION(:), ALLOCATABLE :: itemNameList - - CALL ESMF_StateGet(STATE,itemcount=itemcount, rc=RC) - ALLOCATE(itemNameList(itemcount)) - CALL ESMF_StateGet(STATE,itemcount=itemcount,itemNameList=itemNameList, rc=RC) - DO i=1,itemcount - CALL ESMF_StateGet(STATE ,itemNameList(i) ,FIELD ,rc=RC) - CALL ESMF_FieldDestroy(field=FIELD, rc=RC) - END DO - DEALLOCATE(itemNameList) - - END SUBROUTINE DELETE_FIELDS_FROM_STATE - -!------------------------------------------------------------------------------- -!############################################################################### -!------------------------------------------------------------------------------- - - SUBROUTINE PUT_VARS_IN_BUNDLES(VARS & - ,NUM_VARS & - ,GRID & - ,HISTORY_BUNDLE & - ,RESTART_BUNDLE) - - USE MODULE_ERROR_MSG,ONLY: ERR_MSG,MESSAGE_CHECK - - IMPLICIT NONE - -!------------------------ -!*** Argument Variables -!------------------------ - - TYPE(VAR), DIMENSION(:), INTENT(IN) :: VARS - INTEGER, INTENT(IN) :: NUM_VARS - TYPE(ESMF_Grid), INTENT(IN) :: GRID - TYPE(ESMF_FieldBundle), INTENT(INOUT) :: HISTORY_BUNDLE - TYPE(ESMF_FieldBundle), INTENT(INOUT) :: RESTART_BUNDLE - -!--------------------- -!*** Local variables -!--------------------- - - INTEGER :: K,LENGTH & - ,N,M,NDIM3,NFIND & - ,RC,RC_OUT - - INTEGER :: IHALO,JHALO - - INTEGER :: LDIM1,LDIM2,LDIM3,LDIM4,UDIM1,UDIM2,UDIM3,UDIM4 - - CHARACTER(3) :: MODEL_LEVEL - CHARACTER(3) :: TRACERS_KIND - CHARACTER(6) :: FMT3='(I3.3)' - CHARACTER(6) :: FMT2='(I2.2)' - CHARACTER(ESMF_MAXSTR) :: VBL_NAME,VBL_NAME_X - - TYPE(ESMF_Field) :: FIELD - - TYPE(ESMF_DataCopy_Flag) :: COPYFLAG=ESMF_DATACOPY_REFERENCE -! TYPE(ESMF_DataCopy_Flag) :: COPYFLAG=ESMF_DATA_COPY - - INTEGER :: INDX_Q2 !! FIXME - -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Begin with the integer scalars. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert Integer Scalars into History Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DO N=1,NUM_VARS - IF (VARS(N)%TKR == TKR_I0D) THEN - - IF (VARS(N)%HISTORY) THEN !<-- Take integer scalar data specified for history output - CALL ESMF_AttributeSet(FIELDBUNDLE=HISTORY_BUNDLE & !<-- The Write component output history Bundle - ,name =VARS(N)%VBL_NAME & !<-- Name of the integer scalar - ,value =VARS(N)%I0D & !<-- The scalar being inserted into the import state - ,rc =RC) - END IF - IF (VARS(N)%RESTART) THEN !<-- Take integer scalar data specified for restart output - CALL ESMF_AttributeSet(FIELDBUNDLE=RESTART_BUNDLE & !<-- The Write component output restart Bundle - ,name =VARS(N)%VBL_NAME & !<-- Name of the integer scalar - ,value =VARS(N)%I0D & !<-- The scalar being inserted into the import state - ,rc =RC) - END IF - - END IF - END DO -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_OUT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** The real scalars. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert Real Scalars into History Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DO N=1,NUM_VARS - IF (VARS(N)%TKR == TKR_R0D) THEN - - IF (VARS(N)%HISTORY) THEN !<-- Take real scalar data specified for history output - CALL ESMF_AttributeSet(FIELDBUNDLE=HISTORY_BUNDLE & !<-- The Write component output history Bundle - ,name =VARS(N)%VBL_NAME & !<-- Name of the real scalar - ,value =VARS(N)%R0D & !<-- The scalar being inserted into the history Bundle - ,rc =RC) - END IF - IF (VARS(N)%RESTART) THEN !<-- Take real scalar data specified for restart output - CALL ESMF_AttributeSet(FIELDBUNDLE=RESTART_BUNDLE & !<-- The Write component output restart Bundle - ,name =VARS(N)%VBL_NAME & !<-- Name of the real scalar - ,value =VARS(N)%R0D & !<-- The scalar being inserted into the restart Bundle - ,rc =RC) - END IF - - END IF - END DO -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_OUT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** The 1-D integer arrays. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert 1-D Integer Arrays into History Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DO N=1,NUM_VARS - IF (VARS(N)%TKR == TKR_I1D) THEN - LENGTH=SIZE(VARS(N)%I1D) - - IF (VARS(N)%HISTORY) THEN !<-- Take 1D integer array data specified for history output - CALL ESMF_AttributeSet(FIELDBUNDLE =HISTORY_BUNDLE & !<-- The Write component output history Bundle - ,name =VARS(N)%VBL_NAME & !<-- Name of the integer array - ,itemCount =LENGTH & !<-- # of elements in this attribute - ,valueList =VARS(N)%I1D & !<-- The 1D integer being inserted into the history Bundle - ,rc =RC) - END IF - IF (VARS(N)%RESTART) THEN !<-- Take 1D integer array data specified for restart output - CALL ESMF_AttributeSet(FIELDBUNDLE =RESTART_BUNDLE & !<-- The Write component output restart Bundle - ,name =VARS(N)%VBL_NAME & !<-- Name of the integer array - ,itemCount =LENGTH & !<-- # of elements in this attribute - ,valueList =VARS(N)%I1D & !<-- The 1D integer being inserted into the restart Bundle - ,rc =RC) - END IF - - END IF - END DO -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_OUT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** The 1-D real arrays. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert 1-D Real Arrays into History Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DO N=1,NUM_VARS - IF (VARS(N)%TKR == TKR_R1D) THEN - LENGTH=SIZE(VARS(N)%R1D) - - IF (VARS(N)%HISTORY) THEN !<-- Take 1D real array data specified for history output - CALL ESMF_AttributeSet(FIELDBUNDLE =HISTORY_BUNDLE & !<-- The Write component output history Bundle - ,name =VARS(N)%VBL_NAME & !<-- Name of the real array - ,itemCount =LENGTH & !<-- # of elements in this attribute - ,valueList =VARS(N)%R1D & !<-- The 1D real being inserted into the history Bundle - ,rc =RC) - END IF - IF (VARS(N)%RESTART) THEN !<-- Take 1D real array data specified for restart output - CALL ESMF_AttributeSet(FIELDBUNDLE =RESTART_BUNDLE & !<-- The Write component output restart Bundle - ,name =VARS(N)%VBL_NAME & !<-- Name of the real array - ,itemCount =LENGTH & !<-- # of elements in this attribute - ,valueList =VARS(N)%R1D & !<-- The 1D real being inserted into the restart Bundle - ,rc =RC) - END IF - - END IF - END DO -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_OUT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** The 2-D integer arrays. -!----------------------------------------------------------------------- -! - IHALO=3 - JHALO=3 -! - DO N=1,NUM_VARS - IF (VARS(N)%TKR == TKR_I2D) THEN - IF (VARS(N)%HISTORY) THEN !<-- Take 2D integer array data specified for history output -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert 2-D Integer Data into Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - FIELD=ESMF_FieldCreate(grid =GRID & !<-- The ESMF grid - ,farray =VARS(N)%I2D & !<-- The 2D integer array being inserted into history Bundle - ,datacopyflag =COPYFLAG & - ,totalUWidth =(/IHALO,JHALO/) & - ,totalLWidth =(/IHALO,JHALO/) & - ,name =VARS(N)%VBL_NAME & !<-- Name of the 2D real array - ,indexFlag =ESMF_INDEX_GLOBAL & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_OUT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert Solver 2-D Integer Field into History Bundles" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleAdd( HISTORY_BUNDLE & !<-- The Write component output history Bundle - , (/FIELD/) & !<-- ESMF Field holding the 2D real array - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_OUT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - END IF - IF (VARS(N)%RESTART) THEN !<-- Take 2D integer array data specified for restart output -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert 2-D Integer Data into Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - FIELD=ESMF_FieldCreate(grid =GRID & !<-- The ESMF grid - ,farray =VARS(N)%I2D & !<-- The 2D integer array being inserted into restart Bundle - ,datacopyflag =COPYFLAG & - ,totalUWidth =(/IHALO,JHALO/) & - ,totalLWidth =(/IHALO,JHALO/) & - ,name =VARS(N)%VBL_NAME & !<-- Name of the 2D real array - ,indexFlag =ESMF_INDEX_GLOBAL & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_OUT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert 2-D Integer Field into Restart Bundles" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleAdd( RESTART_BUNDLE & !<-- The Write component output restart Bundle - , (/FIELD/) & !<-- ESMF Field holding the 2D real array - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_OUT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - END IF - END IF - END DO - -! -!----------------------------------------------------------------------- -!*** The 2-D real arrays. -!----------------------------------------------------------------------- -! - DO N=1,NUM_VARS - IF (VARS(N)%TKR == TKR_R2D) THEN - IF (VARS(N)%HISTORY) THEN !<-- Take 2D real array data specified for history output -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert Solver 2-D Real Data into Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - FIELD=ESMF_FieldCreate(grid =GRID & !<-- The ESMF grid - ,farray =VARS(N)%R2D & !<-- The 2D real array being inserted into history Bundle - ,datacopyflag =COPYFLAG & - ,totalUWidth =(/IHALO,JHALO/) & - ,totalLWidth =(/IHALO,JHALO/) & - ,name =VARS(N)%VBL_NAME & !<-- Name of the 2D real array - ,indexFlag =ESMF_INDEX_GLOBAL & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_OUT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert Solver 2-D Real Field into History Bundles" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleAdd( HISTORY_BUNDLE & !<-- The Write component output history Bundle - , (/FIELD/) & !<-- ESMF Field holding the 2D real array - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_OUT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - END IF - IF (VARS(N)%RESTART) THEN !<-- Take 2D real array data specified for restart output -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert Solver 2-D Real Data into Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - FIELD=ESMF_FieldCreate(grid =GRID & !<-- The ESMF grid - ,farray =VARS(N)%R2D & !<-- The 2D real array being inserted into restart Bundle - ,datacopyflag =COPYFLAG & - ,totalUWidth =(/IHALO,JHALO/) & - ,totalLWidth =(/IHALO,JHALO/) & - ,name =VARS(N)%VBL_NAME & !<-- Name of the 2D real array - ,indexFlag =ESMF_INDEX_GLOBAL & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_OUT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert Solver 2-D Real Field into Restart Bundles" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleAdd( RESTART_BUNDLE & !<-- The Write component output restart Bundle - , (/FIELD/) & !<-- ESMF Field holding the 2D real array - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_OUT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - END IF - END IF - END DO -! -!----------------------------------------------------------------------- -!*** The 3-D real arrays. -!*** We are working with 3-D arrays but they are loaded layer by layer -!*** into 2-D Fields. -!----------------------------------------------------------------------- -! - DO N=1,NUM_VARS - IF (VARS(N)%TKR == TKR_R3D .and. ASSOCIATED(VARS(N)%R3D)) THEN - IF (VARS(N)%HISTORY) THEN !<-- Take 3D real array data specified for history output - NDIM3=UBOUND(VARS(N)%R3D,3) - LDIM1=LBOUND(VARS(N)%R3D,1) - UDIM1=UBOUND(VARS(N)%R3D,1) - LDIM2=LBOUND(VARS(N)%R3D,2) - UDIM2=UBOUND(VARS(N)%R3D,2) -! - DO K=1,NDIM3 - WRITE(MODEL_LEVEL,FMT3)K - VBL_NAME=TRIM(VARS(N)%VBL_NAME)//'_'//MODEL_LEVEL//'_2D' -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Fill 2-D Fields with Each Level of 3-D Data" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - FIELD=ESMF_FieldCreate(grid =GRID & !<-- The ESMF grid - ,farray =VARS(N)%R3D(:,:,K) & !<-- Level K of 3D real array being inserted into history Bundle - ,datacopyflag =COPYFLAG & - ,totalUWidth =(/IHALO,JHALO/) & - ,totalLWidth =(/IHALO,JHALO/) & - ,name =VBL_NAME & !<-- Name of this level of the 3D real array - ,indexFlag =ESMF_INDEX_GLOBAL & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_OUT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert 3-D Data into History Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleAdd( HISTORY_BUNDLE & !<-- The Write component output history Bundle - , (/FIELD/) & !<-- ESMF Field holding the 3D real array - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_OUT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDDO -! - END IF - IF (VARS(N)%RESTART) THEN !<-- Take 3D real array data specified for restart output - NDIM3=UBOUND(VARS(N)%R3D,3) - LDIM1=LBOUND(VARS(N)%R3D,1) - UDIM1=UBOUND(VARS(N)%R3D,1) - LDIM2=LBOUND(VARS(N)%R3D,2) - UDIM2=UBOUND(VARS(N)%R3D,2) -! - DO K=1,NDIM3 - WRITE(MODEL_LEVEL,FMT3)K - VBL_NAME=TRIM(VARS(N)%VBL_NAME)//'_'//MODEL_LEVEL//'_2D' -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Fill 2-D Fields with Each Level of 3-D Data" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - FIELD=ESMF_FieldCreate(grid =GRID & !<-- The ESMF grid - ,farray =VARS(N)%R3D(:,:,K) & !<-- Level K of 3D real array being inserted into restart Bundle - ,datacopyflag =COPYFLAG & - ,totalUWidth =(/IHALO,JHALO/) & - ,totalLWidth =(/IHALO,JHALO/) & - ,name =VBL_NAME & !<-- Name of this level of the 3D real array - ,indexFlag =ESMF_INDEX_GLOBAL & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_OUT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert 3-D Data into Restart Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleAdd( RESTART_BUNDLE & !<-- The Write component output restart Bundle - , (/FIELD/) & !<-- ESMF Field holding the 3D real array - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_OUT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDDO -! - END IF - END IF - END DO -! -!----------------------------------------------------------------------- -!*** The 4-D real arrays. -!*** We are working with 4-D arrays but they are loaded layer by layer -!*** into 2-D Fields. -!----------------------------------------------------------------------- -! -!!!!!!!!! FIX this later -!!!!!!!!! FIX this later - INDX_Q2 = 3 -!!!!!!!!! FIX this later -!!!!!!!!! FIX this later - - DO N=1,NUM_VARS - IF (VARS(N)%TKR == TKR_R4D) THEN - IF (VARS(N)%HISTORY) THEN !<-- Take 4D real array data specified for history output - LDIM1=LBOUND(VARS(N)%R4D,1) - UDIM1=UBOUND(VARS(N)%R4D,1) - LDIM2=LBOUND(VARS(N)%R4D,2) - UDIM2=UBOUND(VARS(N)%R4D,2) - LDIM3=LBOUND(VARS(N)%R4D,3) - UDIM3=UBOUND(VARS(N)%R4D,3) - LDIM4=LBOUND(VARS(N)%R4D,4) - UDIM4=UBOUND(VARS(N)%R4D,4) -! - IF(TRIM(VARS(N)%VBL_NAME)=='TRACERS_PREV' .OR. & - TRIM(VARS(N)%VBL_NAME)=='TRACERS') THEN - LDIM4=INDX_Q2+1 !<-- TRACERS bounds: INDX_Q2+1 - UDIM4 - ENDIF - - DO M=LDIM4,UDIM4 !<-- Loop through the tracers (skip unallocated pointers) - DO K=LDIM3,UDIM3 !<-- Loop through the levels of the array - WRITE(TRACERS_KIND,FMT3)M - WRITE(MODEL_LEVEL,FMT3)K -! - VBL_NAME=TRIM(VARS(N)%VBL_NAME)//'_'//TRACERS_KIND//'_'//MODEL_LEVEL//'_2D' -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Fill 2-D Fields with Each Level of 4-D Data" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - FIELD=ESMF_FieldCreate(grid =GRID & !<-- The ESMF grid - ,farray =VARS(N)%R4D(:,:,K,M) & !<-- Level K of 4D real array being inserted into history Bundle - ,datacopyflag =COPYFLAG & - ,totalUWidth =(/IHALO,JHALO/) & - ,totalLWidth =(/IHALO,JHALO/) & - ,name =VBL_NAME & !<-- Name of this level of the 4D real array - ,indexFlag =ESMF_INDEX_GLOBAL & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_OUT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert 4-D Data into History Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleAdd( HISTORY_BUNDLE & !<-- The Write component output history Bundle - , (/FIELD/) & !<-- ESMF Field holding the 4D real array - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_OUT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDDO - ENDDO -! - END IF - IF (VARS(N)%RESTART) THEN !<-- Take 4D real array data specified for restart output - LDIM1=LBOUND(VARS(N)%R4D,1) - UDIM1=UBOUND(VARS(N)%R4D,1) - LDIM2=LBOUND(VARS(N)%R4D,2) - UDIM2=UBOUND(VARS(N)%R4D,2) - LDIM3=LBOUND(VARS(N)%R4D,3) - UDIM3=UBOUND(VARS(N)%R4D,3) - LDIM4=LBOUND(VARS(N)%R4D,4) - UDIM4=UBOUND(VARS(N)%R4D,4) -! - IF( TRIM(VARS(N)%VBL_NAME)=='TRACERS') THEN - LDIM4=INDX_Q2+1 !<-- TRACERS bounds: INDX_Q2+1 - UDIM4 - ENDIF -! - DO M=LDIM4,UDIM4 !<-- Loop through the tracers (skip unallocated pointers) - DO K=LDIM3,UDIM3 !<-- Loop through the levels of the array - WRITE(TRACERS_KIND,FMT3)M - WRITE(MODEL_LEVEL,FMT3)K -! - VBL_NAME=TRIM(VARS(N)%VBL_NAME)//'_'//TRACERS_KIND//'_'//MODEL_LEVEL//'_2D' -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Fill 2-D Fields with Each Level of 4-D Data" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - FIELD=ESMF_FieldCreate(grid =GRID & !<-- The ESMF grid - ,farray =VARS(N)%R4D(:,:,K,M) & !<-- Level K of 4D real array being inserted into restart Bundle - ,datacopyflag =COPYFLAG & - ,totalUWidth =(/IHALO,JHALO/) & - ,totalLWidth =(/IHALO,JHALO/) & - ,name =VBL_NAME & !<-- Name of this level of the 4D real array - ,indexFlag =ESMF_INDEX_GLOBAL & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_OUT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert 4-D Data into Restart Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleAdd( RESTART_BUNDLE & !<-- The Write component output restart Bundle - , (/FIELD/) & !<-- ESMF Field holding the 4D real array - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_OUT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDDO - ENDDO -! - END IF - END IF - END DO -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PUT_VARS_IN_BUNDLES - -!------------------------------------------------------------------------------- -!############################################################################### -!------------------------------------------------------------------------------- - - END MODULE MODULE_VARS_STATE diff --git a/src/nmm/module_WRITE_GRID_COMP.F90 b/src/nmm/module_WRITE_GRID_COMP.F90 deleted file mode 100644 index 3466e1c..0000000 --- a/src/nmm/module_WRITE_GRID_COMP.F90 +++ /dev/null @@ -1,5941 +0,0 @@ -!----------------------------------------------------------------------- -! - MODULE MODULE_WRITE_GRID_COMP -! -!----------------------------------------------------------------------- -!*** The Write gridded component. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Data was put into this component's import state destined for -!*** history output. This component extracts that information -!*** from the import state whose contents are seen only by the -!*** forecast tasks and transfers 2-D data to groups of write tasks -!*** where it is partially reassembled. The write tasks then -!*** transfer their subsections to the lead write task which -!*** assembles the 2-D data onto the full domain and writes out -!*** all scalar/1-D/2-D data to a history file. -!----------------------------------------------------------------------- -!*** -!*** HISTORY -!*** -! xx Feb 2007: W. Yang - Originator -! 13 Jun 2007: T. Black - Name revisions in CPL_REGISTER -! and CPL_INITIALIZE -! 14 Aug 2007: T. Black - Revised CPL_RUN for general output -! selection and added documentation -! for users. -! 12 Sep 2007: T. Black - Replaced the write component and the -! write gridded component with only -! a gridded component that contains -! quilting. -! Mar 2008: R. Vasic - Convert from ESMF 3.0.1 to 3.1.0 -! 15 Aug 2008: J. Wang - Revised for addition of NEMS-IO -! 16 Sep 2008: J. Wang - Output array reverts from 3-D to 2-D -! 14 Oct 2008: R. Vasic - Add restart capability -! 05 Jan 2009: J. Wang - Add 10-m wind factor into NMMB -! runhistory and restart files -! 02 Jul 2009: J. Wang - Added fcstdone/restartdone files -! 04 Sep 2009: T. Black - Merged trunk and NMM-B nesting -! versions. -! 07 May 2010: T. Black - Change output frequency to minutes. -! 16 Dec 2010: J. Wang - Change to nemsio library -! Feb 2011: W. Yang - Updated to use both the ESMF 4.0.0rp2 library, -! ESMF 5 library and the the ESMF 3.1.0rp2 library. -! 12 May 2011 W. Yang - Modified for using the ESMF 5.2.0r_beta_snapshot_07. -! 23 May 2011 J. Wang - add do post option -! 27 SEP 2011 W. Yang - Modified for using the ESMF 5.2.0r library. -! 26 JAN 2016 J. Carley - Add error checking after calls to nemsio_writerec -!--------------------------------------------------------------------------------- -! - USE MPI - USE ESMF - USE MODULE_WRITE_INTERNAL_STATE - USE MODULE_WRITE_ROUTINES,ONLY : OPEN_HST_FILE & - ,OPEN_RST_FILE & - ,WRITE_RUNHISTORY_OPEN & - ,SEND_UPDATED_ATTRIBUTES & - ,WRITE_NEMSIO_RUNHISTORY_OPEN & - ,WRITE_RUNRESTART_OPEN & - ,WRITE_NEMSIO_RUNRESTART_OPEN & - ,TIME_FOR_HISTORY & - ,TIME_FOR_RESTART -! - USE MODULE_DM_PARALLEL,ONLY : PARA_RANGE & - ,MAX_GROUPS & - ,MPI_COMM_COMP & - ,MPI_INTERCOMM_ARRAY -! - USE MODULE_CONTROL,ONLY : TIMEF - USE MODULE_GET_CONFIG_WRITE - USE MODULE_ERROR_MSG,ONLY : ERR_MSG,MESSAGE_CHECK - USE MODULE_KINDS - USE MODULE_CONSTANTS,ONLY : G - USE NEMSIO_MODULE - USE MODULE_BGRID_INTERP,ONLY: V_TO_H_BGRID -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- - - PRIVATE -! - PUBLIC :: WRITE_REGISTER & - ,WRITE_SETUP & - ,WRITE_DESTROY -! - PUBLIC :: write_init_tim & - ,write_run_tim & - ,write_first_tim & - ,write_recv_outp_tim & - ,write_send_outp_tim & - ,write_get_fields_tim -! -!----------------------------------------------------------------------- -! - INTEGER(kind=KINT),PARAMETER :: MAX_LENGTH_I1D=5000 & !<-- Max words in all 1-D integer history variables - ,MAX_LENGTH_R1D=25000 & !<-- Max words in all 1-D real history variables - ,MAX_LENGTH_LOG=MAX_DATA_LOG !<-- Max logical variables -! - INTEGER(kind=KINT),SAVE :: ITS,ITE,JTS,JTE & !<-- Integration grid limits on each task subdomain - ,IDS,IDE,JDS,JDE & !<-- Full domain horizontal index limits - ,LAST_FCST_TASK & !<-- Rank of the last Forecast task - ,LEAD_WRITE_TASK & !<-- Rank of the lead (first) Write task in this Write group - ,LAST_WRITE_TASK & !<-- Rank of the last Write task the Write group - ,LM & !<-- # of model layers - ,LNSH & !<-- H Rows in boundary region - ,LNSV & !<-- V Rows in boundary region - ,NLEV_H & !<-- Total # of levels in H-pt boundary variables - ,NLEV_V & !<-- Total # of levels in V-pt boundary variables - ,NTASKS & !<-- # of Write tasks in the current group + all Fcst tasks - ,NVARS_BC_2D_H & !<-- # of 2-D H-pt boundary variables - ,NVARS_BC_3D_H & !<-- # of 3-D H-pt boundary variables - ,NVARS_BC_4D_H & !<-- # of 4-D H-pt boundary variables - ,NVARS_BC_2D_V & !<-- # of 2-D V-pt boundary variables - ,NVARS_BC_3D_V & !<-- # of 3-D V-pt boundary variables - ,NUM_DOMAINS_TOTAL & !<-- Total # of domains - ,NUM_PES_FCST & !<-- # of Fcst tasks in the current group + all Fcst tasks - ,NWTPG !<-- # of Write tasks (servers) per group -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE,SAVE :: NCURRENT_GROUP !<-- The currently active write group -! - CHARACTER(len=17) :: CONFIGFILE_01_NAME !<-- The name of domain #1's configure file -! - TYPE(ESMF_Config),SAVE :: CF !<-- The configure object for a domain -! - TYPE(WRITE_INTERNAL_STATE),POINTER :: WRT_INT_STATE ! The internal state pointer. -! - TYPE(ESMF_Config),SAVE :: CF_1 !<-- The uppermost domain's (#1's) configure file object -! -!----------------------------------------------------------------------- -! - REAL(kind=KDBL) :: btim,btim0 -! - REAL(kind=KDBL),SAVE :: write_init_tim & - ,write_run_tim & - ,write_first_tim & - ,write_recv_outp_tim & - ,write_send_outp_tim & - ,write_get_fields_tim -! -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE WRITE_REGISTER(WRITE_COMP,RC_WRT) -! -!----------------------------------------------------------------------- -!*** Register the Write component's Initialize, Run, and Finalize -!*** subroutine names. -!----------------------------------------------------------------------- -! -!*** HISTORY -! xx Feb 2007: W. Yang - Originator -! 30 Jun 2007: T. Black - Modified to share same traits as -! rest of code. -! -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument variables -!------------------------ -! - TYPE(ESMF_GridComp) :: WRITE_COMP ! The write component -! - INTEGER,INTENT(OUT) :: RC_WRT ! Final return code -! -!--------------------- -!*** Local variables -!--------------------- -! - INTEGER :: RC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC_WRT=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for Initialize Step of Write Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSetEntryPoint(WRITE_COMP & !<-- The write component - ,ESMF_METHOD_INITIALIZE & !<-- Predefined subroutine type (INIT) - ,WRITE_INITIALIZE & !<-- User's subroutineName - ,phase=1 & - ,rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_WRT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for Run Step of Write Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSetEntryPoint(WRITE_COMP & !<-- The write component - ,ESMF_METHOD_RUN & !<-- Predefined subroutine type (RUN) - ,WRITE_RUN & !<-- User's subroutineName - ,phase=1 & - ,rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_WRT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set Entry Point for Finalize Step of Write Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSetEntryPoint(WRITE_COMP & !<-- The write component - ,ESMF_METHOD_FINALIZE & !<-- Predefined subroutine type (FINALIZE) - ,WRITE_FINALIZE & !<-- User's subroutineName - ,phase=1 & - ,rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_WRT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -!----------------------------------------------------------------------- -! - IF(RC_WRT==ESMF_SUCCESS)THEN -! WRITE(6,*)"PASS: Write_Register." - ELSE - WRITE(0,*)"FAIL: Write_Register." - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE WRITE_REGISTER -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE WRITE_INITIALIZE(WRITE_COMP & - ,IMP_STATE_WRITE & - ,EXP_STATE_WRITE & - ,CLOCK & - ,RC_INIT) -! -!----------------------------------------------------------------------- -!*** Initialize the Write gridded component. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument variables -!------------------------ -! - TYPE(ESMF_State) :: IMP_STATE_WRITE & !<-- The Write component import state - ,EXP_STATE_WRITE !<-- The Write component export state -! - TYPE(ESMF_GridComp) :: WRITE_COMP !<-- The Write component -! - TYPE(ESMF_Clock) :: CLOCK !<-- The Write component Clock -! - INTEGER,INTENT(OUT) :: RC_INIT -! -!--------------------- -!*** Local variables -!--------------------- -! - INTEGER(kind=KINT) :: ID_DOMAIN,IEND,IM & - ,INTERCOMM_WRITE_GROUP,IONE & - ,JEND,JM,LB,LBND,MYPE & - ,N,NL,NUM_WORDS_TOT,NV,UB,UBND -! - INTEGER(kind=KINT) :: IERR,ISTAT,RC -! - INTEGER(kind=KINT),DIMENSION(MPI_STATUS_SIZE) :: JSTAT -! - TYPE(WRITE_WRAP) :: WRAP -! - TYPE(WRITE_INTERNAL_STATE),POINTER :: WRT_INT_STATE -! - TYPE(ESMF_VM) :: VM -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - btim0=timef() -! -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RC_INIT=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** Initialize the Write component timers. -!----------------------------------------------------------------------- -! - write_init_tim=0. - write_run_tim=0. - write_first_tim=0. - write_recv_outp_tim=0. - write_send_outp_tim=0. - write_get_fields_tim=0. -! -!----------------------------------------------------------------------- -!*** Allocate the Write component's internal state. -!----------------------------------------------------------------------- -! - ALLOCATE(WRT_INT_STATE,stat=RC) -! -!----------------------------------------------------------------------- -!*** Attach the internal state to the Write component. -!----------------------------------------------------------------------- -! - wrap%WRITE_INT_STATE=>WRT_INT_STATE -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Attach the Write Component's Internal State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSetInternalState(WRITE_COMP & !<-- The write component - ,WRAP & !<-- Pointer to the internal state - ,RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Retrieve the local VM. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Retrieve the Local VM" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_VMGetCurrent(vm=VM & !<-- The ESMF virtual machine for this group of tasks - ,rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** We must keep track of the currently active Write group. -!*** The value pertinent to the current domain is the one we -!*** are interested in now therefore we need to extract the -!*** current domain ID from this domain's configure file and -!*** save the ID in the Write component's internal state. -!----------------------------------------------------------------------- -! - IF(.NOT.ALLOCATED(NCURRENT_GROUP))THEN -! - ALLOCATE(NCURRENT_GROUP(1:NUM_DOMAINS_TOTAL),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate NCURRENT_GROUP in Write Initialize' - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(rc=RC,endflag=ESMF_END_ABORT) - ENDIF -! - DO N=1,NUM_DOMAINS_TOTAL - NCURRENT_GROUP(N)=0 - ENDDO - ENDIF -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The current domain's configure file object - ,value =wrt_int_state%ID_DOMAIN & !<-- Extract the current domain's ID and save it - ,label ='my_domain_id:' & !<-- The quantity's label in the configure file - ,rc =RC) -! - ID_DOMAIN=wrt_int_state%ID_DOMAIN -! -!----------------------------------------------------------------------- -!*** Extract the task IDs and the number of tasks present. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get MPI Task IDs and Count from VM" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_VMGet(vm =VM & !<-- The local VM - ,localPet=wrt_int_state%MYPE & !<-- My task ID - ,petCount=wrt_int_state%NTASKS & !<-- Number of MPI tasks present in current group (fcst+write) - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - MYPE=wrt_int_state%MYPE - NTASKS=wrt_int_state%NTASKS -! -!----------------------------------------------------------------------- -!*** All tasks allocate buffer data arrays that will hold scalar/1-D -!*** history/restart data and will be used to Send/Recv that data -!*** between the forecast tasks that know it initially to the -!*** write tasks that obtain it from the forecast tasks for writing. -!*** Logical data buffers are also handled here. -!----------------------------------------------------------------------- -! - IF(.NOT.ASSOCIATED(wrt_int_state%ALL_DATA_I1D))THEN - ALLOCATE(wrt_int_state%ALL_DATA_I1D(MAX_LENGTH_I1D),stat=ISTAT) - ENDIF -! - IF(.NOT.ASSOCIATED(wrt_int_state%ALL_DATA_R1D))THEN - ALLOCATE(wrt_int_state%ALL_DATA_R1D(MAX_LENGTH_R1D),stat=ISTAT) - ENDIF -! - IF(.NOT.ASSOCIATED(wrt_int_state%ALL_DATA_LOG))THEN - ALLOCATE(wrt_int_state%ALL_DATA_LOG(MAX_LENGTH_LOG),stat=ISTAT) - ENDIF -! - IF(.NOT.ASSOCIATED(wrt_int_state%RST_ALL_DATA_I1D))THEN - ALLOCATE(wrt_int_state%RST_ALL_DATA_I1D(MAX_LENGTH_I1D),stat=ISTAT) - ENDIF -! - IF(.NOT.ASSOCIATED(wrt_int_state%RST_ALL_DATA_R1D))THEN - ALLOCATE(wrt_int_state%RST_ALL_DATA_R1D(MAX_LENGTH_R1D),stat=ISTAT) - ENDIF -! - IF(.NOT.ASSOCIATED(wrt_int_state%RST_ALL_DATA_LOG))THEN - ALLOCATE(wrt_int_state%RST_ALL_DATA_LOG(MAX_LENGTH_LOG),stat=ISTAT) - ENDIF -! -!----------------------------------------------------------------------- -!*** Allocate dimensions as 1-WORD arrays since ESMF needs -!*** contiguous data arrays for ESMF_Sends/ESMF_Recvs when -!*** those dimensions are transmitted to the write tasks. -!----------------------------------------------------------------------- -! - IF(.NOT.ALLOCATED(wrt_int_state%IM))THEN - ALLOCATE(wrt_int_state%IM(1) & - ,wrt_int_state%IDS(1) & - ,wrt_int_state%IDE(1) & - ,wrt_int_state%JM(1) & - ,wrt_int_state%JDS(1) & - ,wrt_int_state%JDE(1) & - ,wrt_int_state%LM(1)) - ENDIF -! -!----------------------------------------------------------------------- -!*** The number of Attributes (for scalars and 1-D arrays) and -!*** Fields (for gridded 2-D arrays) in the Write component's -!*** import state are not known a priori. -! -!*** Even though these counts are just scalar integers we must -!*** allocate their pointers to length 1 since they will be -!*** used in ESMF_Send/Recv which require them to be contiguous -!*** data arrays. -!----------------------------------------------------------------------- -! - IF(.NOT.ASSOCIATED(wrt_int_state%NCOUNT_FIELDS))THEN -! - ALLOCATE(wrt_int_state%NCOUNT_FIELDS(1),stat=ISTAT) -! - ALLOCATE(wrt_int_state%KOUNT_I1D(1),stat=ISTAT) - ALLOCATE(wrt_int_state%KOUNT_I2D(1),stat=ISTAT) -! - ALLOCATE(wrt_int_state%KOUNT_R1D(1),stat=ISTAT) - ALLOCATE(wrt_int_state%KOUNT_R2D(1),stat=ISTAT) -! - ALLOCATE(wrt_int_state%KOUNT_LOG(1),stat=ISTAT) -! - ALLOCATE(wrt_int_state%RST_NCOUNT_FIELDS(1),stat=ISTAT) -! - ALLOCATE(wrt_int_state%RST_KOUNT_I1D(1),stat=ISTAT) - ALLOCATE(wrt_int_state%RST_KOUNT_I2D(1),stat=ISTAT) -! - ALLOCATE(wrt_int_state%RST_KOUNT_R1D(1),stat=ISTAT) - ALLOCATE(wrt_int_state%RST_KOUNT_R2D(1),stat=ISTAT) -! - ALLOCATE(wrt_int_state%RST_KOUNT_LOG(1),stat=ISTAT) -! -!----------------------------------------------------------------------- -!*** All integer quantities (as 1-D arrays) and 1-D and 2-D real -!*** quantities will be strung together in single arrays of -!*** each particular type. We need to allocate the arrays that will -!*** hold the length of each of the quantities in these 'strings' -!*** as the 'strings' themselves. -!----------------------------------------------------------------------- -! - ALLOCATE(wrt_int_state%LENGTH_DATA_I1D(100),stat=ISTAT) !<-- Lengths of each individual 1-D integer array - ALLOCATE(wrt_int_state%LENGTH_DATA_R1D(100),stat=ISTAT) !<-- Lengths of each individual 1-D real array - ALLOCATE(wrt_int_state%LENGTH_SUM_I1D(1),stat=ISTAT) !<-- Length of string of data of ALL 1-D integer arrays - ALLOCATE(wrt_int_state%LENGTH_SUM_R1D(1),stat=ISTAT) !<-- Length of string of data of ALL 1-D real arrays - ALLOCATE(wrt_int_state%LENGTH_SUM_LOG(1),stat=ISTAT) !<-- Length of string of data of ALL logical variables -! - ALLOCATE(wrt_int_state%RST_LENGTH_DATA_I1D(100),stat=ISTAT) !<-- Lengths of each restart individual 1-D integer array - ALLOCATE(wrt_int_state%RST_LENGTH_DATA_R1D(100),stat=ISTAT) !<-- Lengths of each restart individual 1-D real array - ALLOCATE(wrt_int_state%RST_LENGTH_SUM_I1D(1),stat=ISTAT) !<-- Length of string of restart data of ALL 1-D integer arrays - ALLOCATE(wrt_int_state%RST_LENGTH_SUM_R1D(1),stat=ISTAT) !<-- Length of string of restart data of ALL 1-D real arrays - ALLOCATE(wrt_int_state%RST_LENGTH_SUM_LOG(1),stat=ISTAT) !<-- Length of string of restart data of ALL logical variables -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Retrieve information regarding output from the configuration file. -!*** Values include write tasks per group, the number of write groups, -!*** output channels, and names of disk files. -!----------------------------------------------------------------------- -! - CALL GET_CONFIG_WRITE(WRITE_COMP,WRT_INT_STATE,RC) !<-- User's routine to extract configfile data -! -!----------------------------------------------------------------------- -!*** The MPI intracommunicator for the forecast and quilt tasks -!*** associated with this Write component is naturally valid only -!*** for the domain (i.e., the Domain component) in whose internal -!*** state the Write component lies. A task can lie on more than -!*** one domain in 2-way nesting therefore save the current intracomm -!*** in this Write component's internal state for use whenever it is -!*** active. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Write Initialize: Get the Current Intercomm" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!!! CALL ESMF_VMGet(vm =VM & !<-- The local VM -!!! ,mpiCommunicator=INTERCOMM_WRITE_GROUP & !<-- This Write groups's (component's) intercommunicator -!!! ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Increment the value of the current Write group. -!----------------------------------------------------------------------- -! - NCURRENT_GROUP(ID_DOMAIN)=NCURRENT_GROUP(ID_DOMAIN)+1 -! -!----------------------------------------------------------------------- -!*** The forecast tasks enter WRITE_INITIALIZE for every Write group -!*** but quilt tasks enter it only once. The lead forecast task -!*** broadcasts the value of the group counter so all the quilt -!*** tasks have the correct value. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Write_Initialize: Broadcast Current Write Group Number" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_VMBroadcast(VM & !<-- The local VM - ,NCURRENT_GROUP & !<-- The array of current active write groups - ,NUM_DOMAINS_TOTAL & !<-- # of elements in the array - ,0 & !<-- Root sender is fcst task 0 - ,rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Now we can save this Write group's intercommunicator and the -!*** local intracommunicator between fcst tasks among themselves -!*** and quilt tasks among themselves. -!*** NOTE: We must use the value of the intercommunicator that was -!*** just generated in SETUP_SERVERS called from DOMAIN_SETUP -!*** called from DOMAIN_INITIALIZE prior to WRITE_INITIALIZE -!*** being called from WRITE_INIT called by DOMAIN_INITIALIZE. -!----------------------------------------------------------------------- -! - IF(.NOT.ALLOCATED(wrt_int_state%MPI_INTERCOMM_ARRAY))THEN - ALLOCATE(wrt_int_state%MPI_INTERCOMM_ARRAY(1:MAX_GROUPS)) - ENDIF -! - INTERCOMM_WRITE_GROUP=MPI_INTERCOMM_ARRAY(NCURRENT_GROUP(ID_DOMAIN)) !<-- The intercommunicator from SETUP_SERVERS -! - wrt_int_state%MPI_INTERCOMM_ARRAY(NCURRENT_GROUP(ID_DOMAIN))= & - INTERCOMM_WRITE_GROUP -! - wrt_int_state%MPI_COMM_COMP=MPI_COMM_COMP -! -!----------------------------------------------------------------------- -! - NWTPG=wrt_int_state%WRITE_TASKS_PER_GROUP - wrt_int_state%LAST_FCST_TASK=NTASKS-NWTPG-1 - wrt_int_state%LEAD_WRITE_TASK=wrt_int_state%LAST_FCST_TASK+1 - wrt_int_state%LAST_WRITE_TASK=NTASKS-1 -! - LAST_FCST_TASK=wrt_int_state%LAST_FCST_TASK - LEAD_WRITE_TASK=wrt_int_state%LEAD_WRITE_TASK - LAST_WRITE_TASK=wrt_int_state%LAST_WRITE_TASK -! -!----------------------------------------------------------------------- -!*** The forecast tasks now reset the current group to zero since -!*** that value will cycle through each group during the Run step. -!*** The quilt tasks only know about their own Write group so -!*** their value for the current group can be saved since it will -!*** never change. -!----------------------------------------------------------------------- -! - IF(MYPE<=LAST_FCST_TASK)THEN -! - IF(NCURRENT_GROUP(ID_DOMAIN)==wrt_int_state%WRITE_GROUPS)THEN - NCURRENT_GROUP(ID_DOMAIN)=0 !<-- Reset this counter for the Run step - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Allocate the pointers that hold the local limits -!*** of all the forecast tasks' subdomains then fill -!*** them with the values inserted into the Write -!*** import state in POINT_DYNAMICS_OUTPUT. -!----------------------------------------------------------------------- -! - IF(.NOT.ALLOCATED(wrt_int_state%LOCAL_ISTART))THEN - ALLOCATE(wrt_int_state%LOCAL_ISTART(0:LAST_FCST_TASK),stat=ISTAT) !<-- Local starting I for each fcst task's subdomain - ALLOCATE(wrt_int_state%LOCAL_IEND (0:LAST_FCST_TASK),stat=ISTAT) !<-- Local ending I for each fcst task's subdomain - ALLOCATE(wrt_int_state%LOCAL_JSTART(0:LAST_FCST_TASK),stat=ISTAT) !<-- Local starting J for each fcst task's subdomain - ALLOCATE(wrt_int_state%LOCAL_JEND (0:LAST_FCST_TASK),stat=ISTAT) !<-- Local ending J for each fcst task's subdomain - ENDIF -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="WRITE_INITIALIZE: Extract Local Domain Limits" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(MYPE<=LAST_FCST_TASK)THEN -! - CALL ESMF_AttributeGet(state =IMP_STATE_WRITE & !<-- The Write component's import state - ,name ='LOCAL_ISTART' & !<-- Name of the Attribute to extract - ,valueList=wrt_int_state%LOCAL_ISTART & !<-- Extract local subdomain starting I's - ,rc=RC) -! - CALL ESMF_AttributeGet(state =IMP_STATE_WRITE & !<-- The Write component's import state - ,name ='LOCAL_IEND' & !<-- Name of the Attribute to extract - ,valueList=wrt_int_state%LOCAL_IEND & !<-- Extract local subdomain ending I's - ,rc=RC) -! - CALL ESMF_AttributeGet(state =IMP_STATE_WRITE & !<-- The Write component's import state - ,name ='LOCAL_JSTART' & !<-- Name of the Attribute to extract - ,valueList=wrt_int_state%LOCAL_JSTART & !<-- Extract local subdomain starting J's - ,rc=RC) -! - CALL ESMF_AttributeGet(state =IMP_STATE_WRITE & !<-- The Write component's import state - ,name ='LOCAL_JEND' & !<-- Name of the Attribute to extract - ,valueList=wrt_int_state%LOCAL_JEND & !<-- Extract local subdomain ending J's - ,rc=RC) -! - ENDIF -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="WRITE_INITIALIZE: Extract Full Domain Limits" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IONE = 1 -! - IF(MYPE<=LAST_FCST_TASK)THEN -! - CALL ESMF_AttributeGet(state =IMP_STATE_WRITE & !<-- The Write component's import state - ,name ='IDS' & !<-- Name of the Attribute to extract - ,valueList=wrt_int_state%IDS & !<-- Extract full subdomain starting I - ,rc=RC) -! - CALL ESMF_AttributeGet(state =IMP_STATE_WRITE & !<-- The Write component's import state - ,name ='IDE' & !<-- Name of the Attribute to extract - ,valueList=wrt_int_state%IDE & !<-- Extract full subdomain ending I - ,rc=RC) -! - CALL ESMF_AttributeGet(state =IMP_STATE_WRITE & !<-- The Write component's import state - ,name ='JDS' & !<-- Name of the Attribute to extract - ,valueList=wrt_int_state%JDS & !<-- Extract full subdomain starting J - ,rc=RC) -! - CALL ESMF_AttributeGet(state =IMP_STATE_WRITE & !<-- The Write component's import state - ,name ='JDE' & !<-- Name of the Attribute to extract - ,valueList=wrt_int_state%JDE & !<-- Extract full subdomain ending J - ,rc=RC) -! - IDS=wrt_int_state%IDS(1) - IDE=wrt_int_state%IDE(1) - JDS=wrt_int_state%JDS(1) - JDE=wrt_int_state%JDE(1) -! - ENDIF -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Boundary data is required in the restart file. Because it must -!*** come from the Solver component via export/import states and -!*** because it is not on the ESMF computational grid, it must be -!*** handled as ESMF Attributes which will be 1-D data strings. -!*** They must be 1-D data strings because ESMF Attributes can have -!*** no more than 1 dimension. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** First, what are the domain dimensions? -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="IM,JM,LM from Config Object for Write Initialize" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The ESMF configure object - ,value =wrt_int_state%IM(1) & !<-- I dimension of full domain - ,label ='im:' & !<-- Label in configure file - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The ESMF configure object - ,value =wrt_int_state%JM(1) & !<-- J dimension of full domain - ,label ='jm:' & !<-- Label in configure file - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The ESMF configure object - ,value =wrt_int_state%LM(1) & !<-- # of model layers - ,label ='lm:' & !<-- Label in configure file - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IM=wrt_int_state%IM(1) - JM=wrt_int_state%JM(1) - LM=wrt_int_state%LM(1) -! -!----------------------------------------------------------------------- -!*** # of words in BC data on each side of the domain on this -!*** forecast task. -!----------------------------------------------------------------------- -! - fcst_tasks: IF(MYPE<=LAST_FCST_TASK)THEN -! -!----------------------------------------------------------------------- -! - ALLOCATE(wrt_int_state%NUM_WORDS_BC_SOUTH(0:NUM_PES_FCST-1)) - ALLOCATE(wrt_int_state%NUM_WORDS_BC_NORTH(0:NUM_PES_FCST-1)) - ALLOCATE(wrt_int_state%NUM_WORDS_BC_WEST(0:NUM_PES_FCST-1)) - ALLOCATE(wrt_int_state%NUM_WORDS_BC_EAST(0:NUM_PES_FCST-1)) -! - DO N=0,NUM_PES_FCST-1 - wrt_int_state%NUM_WORDS_BC_SOUTH(N)=-1 - wrt_int_state%NUM_WORDS_BC_NORTH(N)=-1 - wrt_int_state%NUM_WORDS_BC_WEST(N) =-1 - wrt_int_state%NUM_WORDS_BC_EAST(N) =-1 - ENDDO -! - ITS=wrt_int_state%LOCAL_ISTART(MYPE) - ITE=wrt_int_state%LOCAL_IEND(MYPE) - JTS=wrt_int_state%LOCAL_JSTART(MYPE) - JTE=wrt_int_state%LOCAL_JEND(MYPE) -! - IEND=ITE - JEND=JTE -! -!----------------------------------------------------------------------- -!*** And how many boundary rows for H and V points? -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract LNSH from Write Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE_WRITE & !<-- The Write component import state - ,name ='LNSH' & !<-- Name of the Attribute to extract - ,value=wrt_int_state%LNSH & !<-- Extract this Attribute from import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - LNSH=wrt_int_state%LNSH -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract LNSV from Write Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE_WRITE & !<-- The Write component import state - ,name ='LNSV' & !<-- Name of the Attribute to extract - ,value=wrt_int_state%LNSV & !<-- Extract this Attribute from import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - LNSV=wrt_int_state%LNSV -! -!----------------------------------------------------------------------- -!*** How many 2-D,3-D,4-D H-pt and 2-D,3-D V-pt boundary variables? -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract BC Vbl Dim Counts from Write Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE_WRITE & !<-- The Write component import state - ,name ='NVARS_BC_2D_H' & !<-- Name of the Attribute to extract - ,value=wrt_int_state%NVARS_BC_2D_H & !<-- Extract this Attribute from import state - ,rc =RC) -! - NVARS_BC_2D_H=wrt_int_state%NVARS_BC_2D_H -! - CALL ESMF_AttributeGet(state=IMP_STATE_WRITE & !<-- The Write component import state - ,name ='NVARS_BC_3D_H' & !<-- Name of the Attribute to extract - ,value=wrt_int_state%NVARS_BC_3D_H & !<-- Extract this Attribute from import state - ,rc =RC) -! - NVARS_BC_3D_H=wrt_int_state%NVARS_BC_3D_H -! - CALL ESMF_AttributeGet(state=IMP_STATE_WRITE & !<-- The Write component import state - ,name ='NVARS_BC_4D_H' & !<-- Name of the Attribute to extract - ,value=wrt_int_state%NVARS_BC_4D_H & !<-- Extract this Attribute from import state - ,rc =RC) -! - NVARS_BC_4D_H=wrt_int_state%NVARS_BC_4D_H -! - CALL ESMF_AttributeGet(state=IMP_STATE_WRITE & !<-- The Write component import state - ,name ='NVARS_BC_2D_V' & !<-- Name of the Attribute to extract - ,value=wrt_int_state%NVARS_BC_2D_V & !<-- Extract this Attribute from import state - ,rc =RC) -! - NVARS_BC_2D_V=wrt_int_state%NVARS_BC_2D_V -! - CALL ESMF_AttributeGet(state=IMP_STATE_WRITE & !<-- The Write component import state - ,name ='NVARS_BC_3D_V' & !<-- Name of the Attribute to extract - ,value=wrt_int_state%NVARS_BC_3D_V & !<-- Extract this Attribute from import state - ,rc =RC) -! - NVARS_BC_3D_V=wrt_int_state%NVARS_BC_3D_V -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Lower/upper bounds of the count of the # of 3-D arrays within -!*** each 4-D variable. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_4D_H==0)THEN - ALLOCATE(wrt_int_state%LBND_4D(1:1)) - ALLOCATE(wrt_int_state%UBND_4D(1:1)) -! -! - ELSEIF(NVARS_BC_4D_H>0)THEN -! - ALLOCATE(wrt_int_state%LBND_4D(1:NVARS_BC_4D_H)) - ALLOCATE(wrt_int_state%UBND_4D(1:NVARS_BC_4D_H)) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Lower Bnds of 3-D Arrays in 4-D Vbls" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE_WRITE & !<-- The Write component import state - ,name ='LBND_4D' & !<-- Name of the Attribute to extract - ,valueList=wrt_int_state%LBND_4D & !<-- Lower bounds of 3-D array count in each 4-D vbl - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Upper Bnds of 3-D Arrays in 4-D Vbls" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state =IMP_STATE_WRITE & !<-- The Write component import state - ,name ='UBND_4D' & !<-- Name of the Attribute to extract - ,valueList=wrt_int_state%UBND_4D & !<-- Upper bounds of 3-D array count in each 4-D vbl - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! -!----------------------------------------------------------------------- -!*** How many total levels in H-pt and V-pt boundary variables? -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract NLEV_H from Write Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE_WRITE & !<-- The Write component import state - ,name ='NLEV_H' & !<-- Name of the Attribute to extract - ,value=wrt_int_state%NLEV_H & !<-- Extract this Attribute from import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NLEV_H=wrt_int_state%NLEV_H -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract NLEV_V from Write Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE_WRITE & !<-- The Write component import state - ,name ='NLEV_V' & !<-- Name of the Attribute to extract - ,value=wrt_int_state%NLEV_V & !<-- Extract this Attribute from import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NLEV_V=wrt_int_state%NLEV_V -! -!----------------------------------------------------------------------- -!*** Compute the number of boundary words on boundary tasks then -!*** send the information to forecast task 0 who will ultimately -!*** assemble the full-domain boundary data. -!----------------------------------------------------------------------- -! - IF(JTS==JDS)THEN !<-- Fcst tasks on south boundary - wrt_int_state%NUM_WORDS_BC_SOUTH(MYPE)=(NLEV_H*LNSH & - +NLEV_V*LNSV) & - *2*(ITE-ITS+1) - ALLOCATE(wrt_int_state%RST_BC_DATA_SOUTH(1:wrt_int_state%NUM_WORDS_BC_SOUTH(MYPE)),stat=ISTAT) - IF(ISTAT/=0)WRITE(0,*)' Failed to allocate RST_BC_DATA_SOUTH' -! - IF(MYPE/=0)THEN - CALL MPI_SEND(wrt_int_state%NUM_WORDS_BC_SOUTH(MYPE) & !<-- Send this data - ,1 & !<-- Number of words sent - ,MPI_INTEGER & !<-- Datatype - ,0 & !<-- Send to fcst task 0 - ,MYPE & !<-- An MPI tag - ,MPI_COMM_COMP & !<-- MPI communicator - ,IERR) - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -! - IF(JTE==JDE)THEN !<-- Fcst tasks on north boundary - wrt_int_state%NUM_WORDS_BC_NORTH(MYPE)=(NLEV_H*LNSH & - +NLEV_V*LNSV) & - *2*(ITE-ITS+1) - ALLOCATE(wrt_int_state%RST_BC_DATA_NORTH(1:wrt_int_state%NUM_WORDS_BC_NORTH(MYPE)),stat=ISTAT) - IF(ISTAT/=0)WRITE(0,*)' Failed to allocate RST_BC_DATA_NORTH' -! - IF(MYPE/=0)THEN - CALL MPI_SEND(wrt_int_state%NUM_WORDS_BC_NORTH(MYPE) & !<-- Send this data - ,1 & !<-- Number of words sent - ,MPI_INTEGER & !<-- Datatype - ,0 & !<-- Send to fcst task 0 - ,MYPE & !<-- An MPI tag - ,MPI_COMM_COMP & !<-- MPI communicator - ,IERR) - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -! - IF(ITS==IDS)THEN !<-- Fcst tasks on west boundary - wrt_int_state%NUM_WORDS_BC_WEST(MYPE)=(NLEV_H*LNSH & - +NLEV_V*LNSV) & - *2*(JTE-JTS+1) - ALLOCATE(wrt_int_state%RST_BC_DATA_WEST(1:wrt_int_state%NUM_WORDS_BC_WEST(MYPE)),stat=ISTAT) - IF(ISTAT/=0)WRITE(0,*)' Failed to allocate RST_BC_DATA_WEST' -! - IF(MYPE/=0)THEN - CALL MPI_SEND(wrt_int_state%NUM_WORDS_BC_WEST(MYPE) & !<-- Send this data - ,1 & !<-- Number of words sent - ,MPI_INTEGER & !<-- Datatype - ,0 & !<-- Send to fcst task 0 - ,MYPE & !<-- An MPI tag - ,MPI_COMM_COMP & !<-- MPI communicator - ,IERR) - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -! - IF(ITE==IDE)THEN !<-- Fcst tasks on east boundary - wrt_int_state%NUM_WORDS_BC_EAST(MYPE)=(NLEV_H*LNSH & - +NLEV_V*LNSV) & - *2*(JTE-JTS+1) - ALLOCATE(wrt_int_state%RST_BC_DATA_EAST(1:wrt_int_state%NUM_WORDS_BC_EAST(MYPE)),stat=ISTAT) - IF(ISTAT/=0)WRITE(0,*)' Failed to allocate RST_BC_DATA_EAST' -! - IF(MYPE/=0)THEN - CALL MPI_SEND(wrt_int_state%NUM_WORDS_BC_EAST(MYPE) & !<-- Send this data - ,1 & !<-- Number of words sent - ,MPI_INTEGER & !<-- Datatype - ,0 & !<-- Send to fcst task 0 - ,MYPE & !<-- An MPI tag - ,MPI_COMM_COMP & !<-- MPI communicator - ,IERR) - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Forecast task 0 receives local BC word counts. -!----------------------------------------------------------------------- -! - IF(MYPE==0.AND.NUM_PES_FCST>1)THEN -! - DO N=1,LAST_FCST_TASK -! - IF(wrt_int_state%LOCAL_JSTART(N)==1)THEN !<-- Recv from south bndry tasks - CALL MPI_RECV(wrt_int_state%NUM_WORDS_BC_SOUTH(N) & !<-- Recv this data - ,1 & !<-- Words received - ,MPI_INTEGER & !<-- Datatype - ,N & !<-- Recv from fcst task N - ,N & !<-- An MPI tag - ,MPI_COMM_COMP & !<-- MPI communicator - ,JSTAT & !<-- MPI status object - ,IERR) - ENDIF -! - IF(wrt_int_state%LOCAL_JEND(N)==JDE)THEN !<-- Recv from north bndry tasks - CALL MPI_RECV(wrt_int_state%NUM_WORDS_BC_NORTH(N) & !<-- Recv this data - ,1 & !<-- Words received - ,MPI_INTEGER & !<-- Datatype - ,N & !<-- Recv from fcst task N - ,N & !<-- An MPI tag - ,MPI_COMM_COMP & !<-- MPI communicator - ,JSTAT & !<-- MPI status object - ,IERR) - ENDIF -! - IF(wrt_int_state%LOCAL_ISTART(N)==1)THEN !<-- Recv from west bndry tasks - CALL MPI_RECV(wrt_int_state%NUM_WORDS_BC_WEST(N) & !<-- Recv this data - ,1 & !<-- Words received - ,MPI_INTEGER & !<-- Datatype - ,N & !<-- Recv from fcst task N - ,N & !<-- An MPI tag - ,MPI_COMM_COMP & !<-- MPI communicator - ,JSTAT & !<-- MPI status object - ,IERR) - ENDIF -! - IF(wrt_int_state%LOCAL_IEND(N)==IDE)THEN !<-- Recv from east bndry tasks - CALL MPI_RECV(wrt_int_state%NUM_WORDS_BC_EAST(N) & !<-- Recv this data - ,1 & !<-- Words received - ,MPI_INTEGER & !<-- Datatype - ,N & !<-- Recv from fcst task N - ,N & !<-- An MPI tag - ,MPI_COMM_COMP & !<-- MPI communicator - ,JSTAT & !<-- MPI status object - ,IERR) - ENDIF -! - ENDDO -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF fcst_tasks -! -!----------------------------------------------------------------------- -!*** Full-domain boundary data. -!----------------------------------------------------------------------- -! - IF(MYPE==0)THEN !<-- Fcst task 0 needs all the full arrays -! -!------------------------- -!*** Each side of domain -!------------------------- -! - IF(NVARS_BC_2D_H>0)THEN -! - ALLOCATE(wrt_int_state%BND_VARS_H%VAR_2D(1:NVARS_BC_2D_H)) -! - DO NV=1,NVARS_BC_2D_H - ALLOCATE(wrt_int_state%BND_VARS_H%VAR_2D(NV)%SOUTH(1:IDE,1:LNSH,1:2)) - ALLOCATE(wrt_int_state%BND_VARS_H%VAR_2D(NV)%NORTH(1:IDE,1:LNSH,1:2)) - ALLOCATE(wrt_int_state%BND_VARS_H%VAR_2D(NV)%WEST(1:LNSH,1:JDE,1:2)) - ALLOCATE(wrt_int_state%BND_VARS_H%VAR_2D(NV)%EAST(1:LNSH,1:JDE,1:2)) - ENDDO - ENDIF -! - IF(NVARS_BC_3D_H>0)THEN -! - ALLOCATE(wrt_int_state%BND_VARS_H%VAR_3D(1:NVARS_BC_3D_H)) -! - DO NV=1,NVARS_BC_3D_H - ALLOCATE(wrt_int_state%BND_VARS_H%VAR_3D(NV)%SOUTH(1:IDE,1:LNSH,1:LM,1:2)) - ALLOCATE(wrt_int_state%BND_VARS_H%VAR_3D(NV)%NORTH(1:IDE,1:LNSH,1:LM,1:2)) - ALLOCATE(wrt_int_state%BND_VARS_H%VAR_3D(NV)%WEST(1:LNSH,1:JDE,1:LM,1:2)) - ALLOCATE(wrt_int_state%BND_VARS_H%VAR_3D(NV)%EAST(1:LNSH,1:JDE,1:LM,1:2)) - ENDDO - ENDIF -! - IF(NVARS_BC_4D_H>0)THEN -! - ALLOCATE(wrt_int_state%BND_VARS_H%VAR_4D(1:NVARS_BC_4D_H)) -! - DO NV=1,NVARS_BC_4D_H - LB=wrt_int_state%LBND_4D(NV) - UB=wrt_int_state%UBND_4D(NV) - DO NL=LB,UB - ALLOCATE(wrt_int_state%BND_VARS_H%VAR_4D(NV)%SOUTH(1:IDE,1:LNSH,1:LM,1:2,NL)) - ALLOCATE(wrt_int_state%BND_VARS_H%VAR_4D(NV)%NORTH(1:IDE,1:LNSH,1:LM,1:2,NL)) - ALLOCATE(wrt_int_state%BND_VARS_H%VAR_4D(NV)%WEST(1:LNSH,1:JDE,1:LM,1:2,NL)) - ALLOCATE(wrt_int_state%BND_VARS_H%VAR_4D(NV)%EAST(1:LNSH,1:JDE,1:LM,1:2,NL)) - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_2D_V>0)THEN -! - ALLOCATE(wrt_int_state%BND_VARS_V%VAR_2D(1:NVARS_BC_2D_V)) -! - DO NV=1,NVARS_BC_2D_V - ALLOCATE(wrt_int_state%BND_VARS_V%VAR_2D(NV)%SOUTH(1:IDE,1:LNSV,1:2)) - ALLOCATE(wrt_int_state%BND_VARS_V%VAR_2D(NV)%NORTH(1:IDE,1:LNSV,1:2)) - ALLOCATE(wrt_int_state%BND_VARS_V%VAR_2D(NV)%WEST(1:LNSV,1:JDE,1:2)) - ALLOCATE(wrt_int_state%BND_VARS_V%VAR_2D(NV)%EAST(1:LNSV,1:JDE,1:2)) - ENDDO - ENDIF -! - IF(NVARS_BC_3D_V>0)THEN -! - ALLOCATE(wrt_int_state%BND_VARS_V%VAR_3D(1:NVARS_BC_3D_V)) -! - DO NV=1,NVARS_BC_3D_V - ALLOCATE(wrt_int_state%BND_VARS_V%VAR_3D(NV)%SOUTH(1:IDE,1:LNSV,1:LM,1:2)) - ALLOCATE(wrt_int_state%BND_VARS_V%VAR_3D(NV)%NORTH(1:IDE,1:LNSV,1:LM,1:2)) - ALLOCATE(wrt_int_state%BND_VARS_V%VAR_3D(NV)%WEST(1:LNSV,1:JDE,1:LM,1:2)) - ALLOCATE(wrt_int_state%BND_VARS_V%VAR_3D(NV)%EAST(1:LNSV,1:JDE,1:LM,1:2)) - ENDDO - ENDIF -! -!----------------- -!*** Full domain -!----------------- -! - NUM_WORDS_TOT=(NLEV_H*LNSH & !<-- Total # of words - +NLEV_V*LNSV) & ! in full-domain - *2*2*(IDE-IDS+JDE-JDS+2) !<-- boundary arrays -! - ALLOCATE(wrt_int_state%NUM_WORDS_SEND_BC(1)) - wrt_int_state%NUM_WORDS_SEND_BC(1)=NUM_WORDS_TOT -! - ALLOCATE(wrt_int_state%RST_ALL_BC_DATA(1:NUM_WORDS_TOT),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate RST_ALL_BC_DATA in Write Initialize' - WRITE(0,*)' Aborting!' - CALL ESMF_Finalize(rc=RC,endflag=ESMF_END_ABORT) - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Set the IO_BaseTime to the initial Clock time. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Set the Output Base Time to the Initial Clock Time" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock =CLOCK & !<-- The ESMF Clock - ,startTime=wrt_int_state%IO_BASETIME & !<-- The Clock's starting time - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Set the first history file's time index. -!----------------------------------------------------------------------- -! - wrt_int_state%NFHOURS=0 -! -!----------------------------------------------------------------------- -! - IF(RC_INIT==ESMF_SUCCESS)THEN -!!! WRITE(0,*)"PASS: Write_Initialize." - ELSE - WRITE(0,*)"FAIL: Write_Initialize." - ENDIF -! - write_init_tim=(timef()-btim0) -! -!----------------------------------------------------------------------- -! - END SUBROUTINE WRITE_INITIALIZE -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE WRITE_RUN(WRITE_COMP & - ,IMP_STATE_WRITE & - ,EXP_STATE_WRITE & - ,CLOCK & - ,RC_RUN) -! -!----------------------------------------------------------------------- -!*** The Run step for the Write gridded component. -!*** Move data intended for history output from the import state -!*** to the Write tasks. -!----------------------------------------------------------------------- -! - USE ESMF_FieldGetMOD -! -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument variables -!------------------------ -! - TYPE(ESMF_GridComp) :: WRITE_COMP !<-- The Write component -! - TYPE(ESMF_Clock) :: CLOCK !<-- The Write component Clock -! - TYPE(ESMF_State) :: IMP_STATE_WRITE & !<-- The Write component import state - ,EXP_STATE_WRITE !<-- The Write component export state. -! - INTEGER(kind=KINT),INTENT(OUT) :: RC_RUN -! -!--------------------- -!*** Local variables -!--------------------- -! - INTEGER(kind=KINT),SAVE :: IH_INT =MPI_REQUEST_NULL & - ,IH_REAL=MPI_REQUEST_NULL -! - INTEGER(kind=KINT),SAVE :: RST_IH_BC =MPI_REQUEST_NULL & - ,RST_IH_INT =MPI_REQUEST_NULL & - ,RST_IH_REAL=MPI_REQUEST_NULL -! - INTEGER(kind=KINT),SAVE :: IMS,IME,JMS,JME & - ,IHALO,JHALO & - ,INTERCOMM_WRITE_GROUP & - ,MPI_COMM_COMP & - ,N_START,N_END & - ,NPOSN_1,NPOSN_2 & - ,NSUM_WORDS -! - INTEGER(kind=KINT),SAVE :: NSUM_WORDS_NEW=0 -! - INTEGER(kind=KINT) :: I,I1,IJ,IJG,IM,IMJM & - ,J,JM,K,KOUNT & - ,L,LB,LEAD_TASK_DOMAIN & - ,MY_LOCAL_ID,MY_RANK & - ,MYPE,MYPE_ROW & - ,N,N1,N2,NF,NN,NX & - ,NN_INTEGER,NN_REAL & - ,N_POSITION & - ,NA,NB,NC,ND,NL & - ,NT,NTASK & - ,NUM_ATTRIB,NV & - ,UB,WRITE_GROUP -! - INTEGER(kind=KINT) :: DIM1 & - ,DIM2 & - ,FIELDSIZE & - ,NBDR -! - INTEGER(kind=KINT) :: IYEAR_FCST & - ,IMONTH_FCST & - ,IDAY_FCST & - ,IHOUR_FCST & - ,IMINUTE_FCST & - ,ISECOND_FCST & - ,ISECOND_NUM & - ,ISECOND_DEN -! - INTEGER(kind=KINT) :: NTIMESTEP -! - INTEGER(kind=KINT) :: FRAC_SEC & - ,INT_SEC & - ,NF_HOURS & - ,NF_MINUTES & - ,NSECONDS & - ,NSECONDS_NUM & - ,NSECONDS_DEN -! - INTEGER(kind=KINT) :: ID_DUMMY & - ,ID_RECV & - ,ID_SEND & - ,NFCST_TASKS & - ,NFIELD & - ,NPE_WRITE & - ,NUM_FIELD_NAMES -! - INTEGER(kind=KINT) :: ID_START,ID_END & - ,ISTART,IEND & - ,JSTART,JEND -! - INTEGER(kind=KINT) :: JROW_FIRST,JROW_LAST & - ,JSTA_WRITE,JEND_WRITE -! - INTEGER(kind=KINT) :: KOUNT_I2D & - ,KOUNT_I2D_DATA & - ,KOUNT_R2D & - ,KOUNT_R2D_DATA -! - INTEGER(kind=KINT) :: RST_KOUNT_I2D & - ,RST_KOUNT_I2D_DATA & - ,RST_KOUNT_R2D & - ,RST_KOUNT_R2D_DATA -! - INTEGER(kind=KINT) :: ID_DOMAIN,LENGTH & - ,MPI_COMM,MPI_COMM2 -! - INTEGER(kind=KINT) :: IO_HST_UNIT,IO_RST_UNIT,FFSYNC -! - INTEGER(kind=KINT) :: IERR,ISTAT,RC -! -!--posts - INTEGER(kind=KINT) :: IEOF,NSOIL,POST_MAPTYPE - CHARACTER(1) :: POST_GRIDTYPE - LOGICAL(kind=KLOG) :: LOG_PESET - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: JSTAGRP,JENDGRP - INTEGER(kind=KINT) :: KPO,KTH,KPV - real(kind=KFPT),dimension(70) :: PO,TH,PV -!--posts -! - INTEGER(kind=ESMF_KIND_I8) :: NTIMESTEP_ESMF -! - INTEGER(kind=KINT),DIMENSION(1) :: NCURRENT_GROUP_BCAST -! - INTEGER(kind=KINT),DIMENSION(MPI_STATUS_SIZE) :: JSTAT -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: WORK_ARRAY_I1D -! - INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: WORK_ARRAY_I2D -! - REAL(kind=KFPT) :: NF_SECONDS & - ,SECOND_FCST -! - REAL(kind=KFPT),DIMENSION(:),POINTER :: GLAT1D,GLON1D,TMP & - ,WORK_ARRAY_R1D -! - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: WORK_ARRAY_R2D -! - REAL(KIND=KFPT),DIMENSION(:),ALLOCATABLE:: BUFF_NTASK & - ,HOLD_RST_DATA_R1D -! - REAL(kind=KFPT),DIMENSION(:,:),ALLOCATABLE:: FACT10 & - ,FACT10TMPU & - ,FACT10TMPV & - ,HGT -! - real(esmf_kind_i8) :: RUN_TIMESTEP_COUNT -! - LOGICAL(kind=KLOG) :: GLOBAL & - ,OPENED & - ,WRITE_LOGICAL -! - LOGICAL(kind=KLOG),SAVE :: FIRST=.TRUE. & - ,HST_FIRST=.TRUE. & - ,RST_FIRST=.TRUE. -! - CHARACTER(3) :: MODEL_LEVEL - CHARACTER(ESMF_MAXSTR) :: FILENAME,GFNAME,NAME -! - TYPE(WRITE_WRAP) :: WRAP - TYPE(WRITE_INTERNAL_STATE),POINTER :: WRT_INT_STATE -! - TYPE(ESMF_VM) :: VM - TYPE(ESMF_Grid),SAVE :: GRID1 - TYPE(ESMF_DELayout) :: MY_DE_LAYOUT - TYPE(ESMF_Field) :: FIELD_WORK1 -! - TYPE(ESMF_Time) :: CURRTIME -! - TYPE(ESMF_TypeKind_Flag) :: DATATYPE -! - TYPE(ESMF_LOGICAL),DIMENSION(:),POINTER :: FIRST_IO_PE -! - TYPE(ESMF_FieldBundle) :: HISTORY_BUNDLE & !<-- The history output data Bundle - ,RESTART_BUNDLE !<-- The restart output data Bundle -! - TYPE(NEMSIO_GFILE) :: NEMSIOFILE -! -!----------------------------------------------------------------------- -! - real(kind=kfpt) :: wait_time -! - integer(kind=kint),dimension(8) :: values -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - btim0=timef() -! - RC =ESMF_SUCCESS - RC_RUN=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** It is important to note that while the tasks executing this -!*** step include all forecast tasks plus those write tasks in -!*** this write group, the import state was filled in the Solver -!*** component only by the forecast tasks. Therefore any information -!*** extracted from the import state that is needed by the write -!*** tasks must be sent to them by the forecast tasks. -! -!*** Also note that history data consisting of scalars or 1D arrays -!*** are present in the Write component's import state as Attributes. -!*** All 2D (gridded) history data are present as Fields. -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Retrieve the Write component's ESMF internal state. -!----------------------------------------------------------------------- -! - btim=timef() -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Retrieve Write Component's Internal State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGetInternalState(WRITE_COMP & !<-- The write component - ,WRAP & !<-- Pointer to internal state - ,RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - WRT_INT_STATE=>wrap%WRITE_INT_STATE !<-- Local working pointer to internal state -! -!----------------------------------------------------------------------- -!*** Get the current local VM. -!*** This comes from the PetList used to create -!*** the Write components in DOMAIN_INITIALIZE. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Retrieve the Current VM for WRITE_RUN" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_VMGetCurrent(VM,rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - MYPE=wrt_int_state%MYPE - ID_DOMAIN=wrt_int_state%ID_DOMAIN -! -!----------------------------------------------------------------------- -! - IM=wrt_int_state%IM(1) - JM=wrt_int_state%JM(1) -! - KOUNT_I2D=wrt_int_state%KOUNT_I2D(1) - KOUNT_R2D=wrt_int_state%KOUNT_R2D(1) -! - LAST_FCST_TASK=wrt_int_state%LAST_FCST_TASK - LEAD_WRITE_TASK=wrt_int_state%LEAD_WRITE_TASK - LAST_WRITE_TASK=wrt_int_state%LAST_WRITE_TASK -! - NWTPG=wrt_int_state%WRITE_TASKS_PER_GROUP -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Lead Fcst Task from Write Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=IMP_STATE_WRITE & - ,name ='Lead Task Domain' & - ,value=LEAD_TASK_DOMAIN & - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** The forecast tasks increment the write group so they know -!*** which one is active. Only the forecast tasks enter the -!*** Run step of the Write component every output time therefore -!*** only they need to increment the number of the current write -!*** group. The quilt tasks belong to only a single write group -!*** so if they present here then it must be their write group -!*** that is active. -!----------------------------------------------------------------------- -! - IF(MYPE<=LAST_FCST_TASK)THEN -! - NCURRENT_GROUP(ID_DOMAIN)=NCURRENT_GROUP(ID_DOMAIN)+1 - IF(NCURRENT_GROUP(ID_DOMAIN)>wrt_int_state%WRITE_GROUPS)THEN - NCURRENT_GROUP(ID_DOMAIN)=1 - ENDIF -! - NCURRENT_GROUP_BCAST(1)=NCURRENT_GROUP(ID_DOMAIN) - NCURRENT_GROUP(ID_DOMAIN)=NCURRENT_GROUP_BCAST(1) -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Take the relevant intercommunicator for this Write group. -!----------------------------------------------------------------------- -! - INTERCOMM_WRITE_GROUP=wrt_int_state%MPI_INTERCOMM_ARRAY(NCURRENT_GROUP(ID_DOMAIN)) -! -!----------------------------------------------------------------------- -!*** Take the relevant intracommunicator for these fcst/quilt tasks. -!----------------------------------------------------------------------- -! - MPI_COMM_COMP=wrt_int_state%MPI_COMM_COMP -! -!----------------------------------------------------------------------- -! - write_first_tim=write_first_tim+(timef()-btim) -! -!----------------------------------------------------------------------- -!*** The elapsed forecast time (hours) will be appended to the name -!*** of each history output file. Extract that value now. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Current Time for Output" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock =CLOCK & !<-- The ESMF Clock - ,currTime=CURRTIME & !<-- The current time (ESMF) on the clock - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** The ESMF time difference between start time and current time. -!----------------------------------------------------------------------- -! - wrt_int_state%IO_CURRTIMEDIFF=CURRTIME-wrt_int_state%IO_BASETIME -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Elapsed Forecast Time for Output" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeIntervalGet(timeinterval=wrt_int_state%IO_CURRTIMEDIFF & - ,h =wrt_int_state%NFHOURS & !<-- The elapsed time in hours (REAL) - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Now pull the 2d history data from the import state. -!*** This includes all individual 2D history quantities as well as -!*** all model levels of the 3D Real history arrays. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- - hst_fcst_tasks: IF(TIME_FOR_HISTORY.AND.MYPE<=LAST_FCST_TASK)THEN !<-- Only the forecast tasks can see this data so far -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Extract the history data Bundle from the import state. -!*** The Bundle was created during the Init step of the SOLVER -!*** since subroutine POINT_OUTPUT must have it available for -!*** inserting data pointers into it. Only the forecast tasks -!*** can extract it properly since it was they who inserted it. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract History Bundle from Write Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =IMP_STATE_WRITE & !<-- The write component's import state - ,itemName ='History Bundle' & !<-- The name of the history data Bundle - ,fieldbundle=HISTORY_BUNDLE & !<-- The history data Bundle inside the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NN_INTEGER=0 - NN_REAL =0 -! - ITS=wrt_int_state%LOCAL_ISTART(MYPE) !<-- Starting I of this task's integration region - ITE=wrt_int_state%LOCAL_IEND(MYPE) !<-- Ending I of this task's integration region - JTS=wrt_int_state%LOCAL_JSTART(MYPE) !<-- Starting J of this task's integration region - JTE=wrt_int_state%LOCAL_JEND(MYPE) !<-- Ending J of this task's integration region -! - IHALO=wrt_int_state%IHALO !<-- Halo depth in I - JHALO=wrt_int_state%JHALO !<-- Halo depth in J -! - IDE=wrt_int_state%IDE(1) - JDE=wrt_int_state%JDE(1) -! -!----------------------------------------------------------------------- -!*** Collect and send the updated Attributes (scalars and 1-D arrays) -!*** to the lead Write task for history output. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Attribute Count from History Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(FIELDBUNDLE=HISTORY_BUNDLE & !<-- The history data Bundle - ,count =NUM_ATTRIB & !<-- # of Attributes in the history Bundle - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(MYPE==0)THEN - WRITE_GROUP=NCURRENT_GROUP(ID_DOMAIN) - CALL SEND_UPDATED_ATTRIBUTES(HISTORY_BUNDLE & - ,wrt_int_state%ALL_DATA_I1D & - ,wrt_int_state%ALL_DATA_R1D & - ,wrt_int_state%ALL_DATA_LOG & - ,MAX_LENGTH_I1D & - ,MAX_LENGTH_R1D & - ,MAX_LENGTH_LOG & - ,MAX_GROUPS & - ,WRITE_GROUP & - ,INTERCOMM_WRITE_GROUP ) - ENDIF -! -!----------------------------------------------------------------------- -!*** Be sure the Integer and Real buffers are available for ISends. -!----------------------------------------------------------------------- -! - btim=timef() - CALL MPI_WAIT(IH_INT,JSTAT,IERR) - wait_time=(timef()-btim) - if(wait_time>1.e3)write(0,*)' Long integer buffer WAIT =',wait_time*1.e-3 -! call date_and_time(values=values) -! write(0,555)values(5),values(6),values(7),values(8) - 555 format(' Write Run after Wait IH_INT at ',i2.2,':',i2.2,':',i2.2,'.',i3.3) -! - btim=timef() - CALL MPI_WAIT(IH_REAL,JSTAT,IERR) - wait_time=(timef()-btim) - if(wait_time>1.e3)write(0,*)' Long real buffer WAIT =',wait_time*1.e-3 -! call date_and_time(values=values) -! write(0,556)values(5),values(6),values(7),values(8) - 556 format(' Write Run after Wait IH_REAL at ',i2.2,':',i2.2,':',i2.2,'.',i3.3) -! -!----------------------------------------------------------------------- -! - btim=timef() -! - field_block: DO N=1,wrt_int_state%NCOUNT_FIELDS(1) !<-- Loop through all Fields in the import state -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract 2-D Fields from History Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=HISTORY_BUNDLE & !<-- The write component's history data Bundle - ,fieldName =wrt_int_state%FIELD_NAME(N) & !<-- The ESMF Field's name - ,field =FIELD_WORK1 & !<-- The ESMF Field data pointer - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Does this extracted Field hold Integer or Real data? -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Check Datatype of Field from History Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =FIELD_WORK1 & !<-- The ESMF Field - ,typekind=DATATYPE & !<-- ESMF specifier of variable type and kind - ,rc =RC) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!-------------------------------------------------------------------- -! -- INTEGER FIELDS -- -!-------------------------------------------------------------------- -! - IF(DATATYPE==ESMF_TYPEKIND_I4)THEN !<-- Extract integer gridded data from each ESMF Field -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Pointer from 2-D Integer Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_FieldGet(field =FIELD_WORK1 & !<-- The ESMF Field - ,localDe =0 & !<-- # of DEs in this grid - ,farrayPtr =WORK_ARRAY_I2D & !<-- Put the 2D integer data from the Field here - ,rc =RC) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ISTART=LBOUND(WORK_ARRAY_I2D,1) - IEND =UBOUND(WORK_ARRAY_I2D,1) - JSTART=LBOUND(WORK_ARRAY_I2D,2) - JEND =UBOUND(WORK_ARRAY_I2D,2) -! - IF(NN_INTEGER+(IEND-ISTART+1)*(JEND-JSTART+1)>wrt_int_state%NUM_WORDS_SEND_I2D_HST)THEN - WRITE(0,*)' WARNING: THE NUMBER OF INTEGER WORDS YOU' & - ,' ARE SENDING FROM FCST TO WRITE TASKS HAS' & - ,' EXCEEDED THE ORIGINAL COUNT WHICH SHOULD' & - ,' NOT CHANGE. CHECK YOUR WORK' - ENDIF -! - DO J=JSTART,JEND - DO I=ISTART,IEND - NN_INTEGER=NN_INTEGER+1 - wrt_int_state%ALL_DATA_I2D(NN_INTEGER)=WORK_ARRAY_I2D(I,J) !<-- String together this task's 2D integer data - ENDDO - ENDDO -! -!-------------------------------------------------------------------- -! -- REAL FIELDS -- -!-------------------------------------------------------------------- -! - ELSEIF(DATATYPE==ESMF_TYPEKIND_R4)THEN !<-- Extract real gridded data from each ESMF Field -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Pointer from 2-D Real Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_FieldGet(field =FIELD_WORK1 & !<-- The ESMF Field - ,localDe =0 & !<-- # of DEs in this grid - ,farrayPtr =WORK_ARRAY_R2D & !<-- Put the 2D real data from the Field here - ,rc =RC) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ISTART=LBOUND(WORK_ARRAY_R2D,1) - IEND =UBOUND(WORK_ARRAY_R2D,1) - JSTART=LBOUND(WORK_ARRAY_R2D,2) - JEND =UBOUND(WORK_ARRAY_R2D,2) -! - IF(NN_REAL+(IEND-ISTART+1)*(JEND-JSTART+1)>wrt_int_state%NUM_WORDS_SEND_R2D_HST)THEN - WRITE(0,*)' WARNING: THE NUMBER OF REAL WORDS YOU' & - ,' ARE SENDING FROM FCST TO WRITE TASKS HAS' & - ,' EXCEEDED THE ORIGINAL COUNT WHICH SHOULD' & - ,' NOT CHANGE. CHECK YOUR WORK' - ENDIF -! - DO J=JSTART,JEND - DO I=ISTART,IEND - NN_REAL=NN_REAL+1 - wrt_int_state%ALL_DATA_R2D(NN_REAL)=WORK_ARRAY_R2D(I,J) !<-- String together this task's 2D real data - ENDDO - ENDDO -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO field_block -! - write_get_fields_tim=write_get_fields_tim+(timef()-btim) -! - btim=timef() -! -!----------------------------------------------------------------------- -!*** All forecast tasks now send their strings of 2D history data -!*** to the appropriate write tasks. -!----------------------------------------------------------------------- -! - KOUNT_I2D_DATA=wrt_int_state%NUM_WORDS_SEND_I2D_HST !<-- Total #of words in 2D integer history data on this fcst task - KOUNT_R2D_DATA=wrt_int_state%NUM_WORDS_SEND_R2D_HST !<-- Total #of words in 2D real history data on this fcst task -! - MYPE_ROW=MYPE/wrt_int_state%INPES+1 !<-- Each fcst task's row among all rows of fcst tasks -! - DO N=1,NWTPG !<-- Loop through the write tasks in this group - CALL PARA_RANGE(wrt_int_state%JNPES,NWTPG,N & !<-- Find each write task's first and last rows of - ,JROW_FIRST,JROW_LAST) !<-- fcst tasks from which it will recv -! - NPE_WRITE=N-1 !<-- Consider the write task with this local ID - ! beginning with 0 -! - IF(MYPE_ROW>=JROW_FIRST.AND.MYPE_ROW<=JROW_LAST)THEN !<-- This fcst task associated with this write task -! -!----------------------------------------------------------------------- -!*** First the 2-D Integer data. -!----------------------------------------------------------------------- -! - IF(KOUNT_I2D>0)THEN - CALL MPI_ISSEND(wrt_int_state%ALL_DATA_I2D & !<-- Fcst tasks' string of 2D integer history data - ,KOUNT_I2D_DATA & !<-- #of words in the data string - ,MPI_INTEGER & !<-- The datatype - ,NPE_WRITE & !<-- The target write task - ,wrt_int_state%NFHOURS & !<-- An MPI tag - ,INTERCOMM_WRITE_GROUP & !<-- The MPI intercommunicator between fcst and quilt tasks - ,IH_INT & !<-- MPI communication request handle - ,IERR ) -! - IF(IERR/=0)WRITE(0,*)' ISend of integer data by fcst task 0 has failed. IERR=',IERR - ENDIF -! -!----------------------------------------------------------------------- -!*** Then the 2-D Real data. -!----------------------------------------------------------------------- -! - IF(KOUNT_R2D>0)THEN - CALL MPI_ISSEND(wrt_int_state%ALL_DATA_R2D & !<-- Fcst tasks' string of 2D real history data - ,KOUNT_R2D_DATA & !<-- #of words in the data string - ,MPI_REAL & !<-- The datatype - ,NPE_WRITE & !<-- The target write task - ,wrt_int_state%NFHOURS & !<-- An MPI tag - ,INTERCOMM_WRITE_GROUP & !<-- The MPI intercommunicator between fcst and quilt tasks - ,IH_REAL & !<-- MPI communication request handle - ,IERR ) -! - IF(IERR/=0)WRITE(0,*)' ISend of real data by fcst task 0 has failed. IERR=',IERR - ENDIF -! - ENDIF -! - ENDDO -! - write_send_outp_tim=write_send_outp_tim+timef()-btim -! -!----------------------------------------------------------------------- -! - ENDIF hst_fcst_tasks -! -!----------------------------------------------------------------------- -!*** Now pull the 2D restart data from the import state. -!*** This includes all individual 2D restart quantities as well as -!*** all model levels of the 3D Real restart arrays. -!----------------------------------------------------------------------- -! - RST_KOUNT_I2D=wrt_int_state%RST_KOUNT_I2D(1) - RST_KOUNT_R2D=wrt_int_state%RST_KOUNT_R2D(1) -! -!----------------------------------------------------------------------- - rst_fcst_tasks: IF(TIME_FOR_RESTART.AND.MYPE<=LAST_FCST_TASK)THEN !<-- Only the forecast tasks can see this data so far -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Extract the restart data Bundle from the import state. -!*** The Bundle was created during the Init step of the Solver -!*** since subroutine POINT_OUTPUT must have it available for -!*** inserting data pointers into it. Only the forecast tasks -!*** can extract it properly since it was they who inserted it. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Restart Bundle from Write Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =IMP_STATE_WRITE & !<-- The write component's import state - ,itemName ='Restart Bundle' & !<-- The name of the restart data Bundle - ,fieldbundle=RESTART_BUNDLE & !<-- The restart data Bundle inside the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NN_INTEGER=0 - NN_REAL =0 -! - ITS=wrt_int_state%LOCAL_ISTART(MYPE) !<-- Starting I of this task's integration region - ITE=wrt_int_state%LOCAL_IEND(MYPE) !<-- Ending I of this task's integration region - JTS=wrt_int_state%LOCAL_JSTART(MYPE) !<-- Starting J of this task's integration region - JTE=wrt_int_state%LOCAL_JEND(MYPE) !<-- Ending J of this task's integration region -! - IHALO=wrt_int_state%IHALO !<-- Halo depth in I - JHALO=wrt_int_state%JHALO !<-- Halo depth in J -! - IDE=wrt_int_state%IDE(1) - JDE=wrt_int_state%JDE(1) -! -!----------------------------------------------------------------------- -!*** Collect and send the updated Attributes (scalars and 1-D arrays) -!*** to the lead Write task for restart output. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Attribute Count from Restart Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(FIELDBUNDLE=RESTART_BUNDLE & !<-- The restart data Bundle - ,count =NUM_ATTRIB & !<-- # of Attributes in the restart Bundle - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(MYPE==0)THEN - WRITE_GROUP=NCURRENT_GROUP(ID_DOMAIN) - CALL SEND_UPDATED_ATTRIBUTES(RESTART_BUNDLE & - ,wrt_int_state%RST_ALL_DATA_I1D & - ,wrt_int_state%RST_ALL_DATA_R1D & - ,wrt_int_state%RST_ALL_DATA_LOG & - ,MAX_LENGTH_I1D & - ,MAX_LENGTH_R1D & - ,MAX_LENGTH_LOG & - ,MAX_GROUPS & - ,WRITE_GROUP & - ,INTERCOMM_WRITE_GROUP ) - ENDIF -! -!----------------------------------------------------------------------- -!*** Be sure the Integer and Real buffers are available for ISends. -!----------------------------------------------------------------------- -! - btim=timef() - CALL MPI_WAIT(RST_IH_INT,JSTAT,IERR) - wait_time=(timef()-btim) - if(wait_time>1.e3)write(0,*)' Long integer buffer WAIT =',wait_time*1.e-3 -! - btim=timef() - CALL MPI_WAIT(RST_IH_REAL,JSTAT,IERR) - wait_time=(timef()-btim) - if(wait_time>1.e3)write(0,*)' Long real buffer WAIT =',wait_time*1.e-3 -! -!----------------------------------------------------------------------- -! - btim=timef() -! - rst_field_block: DO N=1,wrt_int_state%RST_NCOUNT_FIELDS(1) !<-- Loop through all Fields in the import state -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract 2-D Fields from Restart Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=RESTART_BUNDLE & !<-- The write component's restart data Bundle - ,fieldName =wrt_int_state%RST_FIELD_NAME(N) & !<-- The ESMF Field's name - ,field =FIELD_WORK1 & !<-- The ESMF Field data pointer - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Does this extracted Field hold Integer or Real restart data? -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Check Datatype of Field from Restart Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =FIELD_WORK1 & !<-- The ESMF Field - ,typekind=DATATYPE & !<-- ESMF specifier of variable type and kind - ,rc =RC) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!-------------------------------------------------------------------- -! -- INTEGER FIELDS -- -!-------------------------------------------------------------------- -! - IF(DATATYPE==ESMF_TYPEKIND_I4)THEN !<-- Extract integer gridded data from each ESMF Field -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Pointer from 2-D Integer Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_FieldGet(field =FIELD_WORK1 & !<-- The ESMF Field - ,localDe =0 & !<-- # of DEs in this grid - ,farrayPtr =WORK_ARRAY_I2D & !<-- Put the 2D integer data from the Field here - ,rc =RC) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ISTART=LBOUND(WORK_ARRAY_I2D,1) - IEND =UBOUND(WORK_ARRAY_I2D,1) - JSTART=LBOUND(WORK_ARRAY_I2D,2) - JEND =UBOUND(WORK_ARRAY_I2D,2) -! - IF(NN_INTEGER+(IEND-ISTART+1)*(JEND-JSTART+1)>wrt_int_state%NUM_WORDS_SEND_I2D_RST)THEN - WRITE(0,*)' WARNING: THE NUMBER OF INTEGER WORDS YOU' & - ,' ARE SENDING FROM FCST TO WRITE TASKS HAS' & - ,' EXCEEDED THE ORIGINAL COUNT WHICH SHOULD' & - ,' NOT CHANGE. CHECK YOUR WORK' - ENDIF -! - DO J=JSTART,JEND - DO I=ISTART,IEND - NN_INTEGER=NN_INTEGER+1 - wrt_int_state%RST_ALL_DATA_I2D(NN_INTEGER)=WORK_ARRAY_I2D(I,J) !<-- String together this task's 2D integer data - ENDDO - ENDDO -! -!-------------------------------------------------------------------- -! -- REAL FIELDS -- -!-------------------------------------------------------------------- -! - ELSEIF(DATATYPE==ESMF_TYPEKIND_R4)THEN !<-- Extract real gridded data from each ESMF Field -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Pointer from 2-D Real Field" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - - CALL ESMF_FieldGet(field =FIELD_WORK1 & !<-- The ESMF Field - ,localDe =0 & !<-- # of DEs in this grid - ,farrayPtr =WORK_ARRAY_R2D & !<-- Put the 2D real data from the Field here - ,rc =RC) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - RST_KOUNT_R2D=RST_KOUNT_R2D+1 !<-- Count # of 2D real Fields (as opposed to 2D integer Fields) -! - ISTART=LBOUND(WORK_ARRAY_R2D,1) - IEND =UBOUND(WORK_ARRAY_R2D,1) - JSTART=LBOUND(WORK_ARRAY_R2D,2) - JEND =UBOUND(WORK_ARRAY_R2D,2) -! - IF(NN_REAL+(IEND-ISTART+1)*(JEND-JSTART+1)>wrt_int_state%NUM_WORDS_SEND_R2D_RST)THEN - WRITE(0,*)' WARNING: THE NUMBER OF REAL WORDS YOU' & - ,' ARE SENDING FROM FCST TO WRITE TASKS HAS' & - ,' EXCEEDED THE ORIGINAL COUNT WHICH SHOULD' & - ,' NOT CHANGE. CHECK YOUR WORK' - ENDIF -! - DO J=JSTART,JEND - DO I=ISTART,IEND - NN_REAL=NN_REAL+1 - wrt_int_state%RST_ALL_DATA_R2D(NN_REAL)=WORK_ARRAY_R2D(I,J) !<-- String together this task's 2D real data - ENDDO - ENDDO -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO rst_field_block -! - write_get_fields_tim=write_get_fields_tim+(timef()-btim) -! - btim=timef() -! -!----------------------------------------------------------------------- -!*** All forecast tasks now send their strings of 2D restart data -!*** to the appropriate write tasks. -!----------------------------------------------------------------------- -! - RST_KOUNT_I2D_DATA=wrt_int_state%NUM_WORDS_SEND_I2D_RST !<-- # of words in 2D integer restart data on this fcst task - RST_KOUNT_R2D_DATA=wrt_int_state%NUM_WORDS_SEND_R2D_RST !<-- # of words in 2D real restart data on this fcst task -! - MYPE_ROW=MYPE/wrt_int_state%INPES+1 !<-- Each fcst task's row among all rows of fcst tasks -! - DO N=1,NWTPG !<-- Loop through the write tasks in this group - CALL PARA_RANGE(wrt_int_state%JNPES,NWTPG,N & !<-- Find each write task's first and last rows of - ,JROW_FIRST,JROW_LAST) !<-- fcst tasks from which it will recv -! - NPE_WRITE=N-1 !<-- Consider the write task with this local ID - ! beginning with 0 -! - IF(MYPE_ROW>=JROW_FIRST.AND.MYPE_ROW<=JROW_LAST)THEN !<-- This fcst task associated with this write task -! -!----------------------------------------------------------------------- -!*** First the 2-D Integer restart data. -!----------------------------------------------------------------------- -! - IF(RST_KOUNT_I2D>0)THEN - CALL MPI_ISSEND(wrt_int_state%RST_ALL_DATA_I2D & !<-- Fcst tasks' string of 2D integer restart data - ,RST_KOUNT_I2D_DATA & !<-- # of words in the data string - ,MPI_INTEGER & !<-- The datatype - ,NPE_WRITE & !<-- The target write task - ,wrt_int_state%NFHOURS & !<-- An MPI tag - ,INTERCOMM_WRITE_GROUP & !<-- The MPI intercommunicator between fcst and quilt tasks - ,RST_IH_INT & !<-- MPI communication request handle - ,IERR ) -! - IF(IERR/=0)WRITE(0,*)' ISend of integer data by fcst task 0 has failed. IERR=',IERR - ENDIF -! -!----------------------------------------------------------------------- -!*** Then the 2-D Real restart data. -!----------------------------------------------------------------------- -! - IF(RST_KOUNT_R2D>0)THEN - CALL MPI_ISSEND(wrt_int_state%RST_ALL_DATA_R2D & !<-- Fcst tasks' string of 2D real restart data - ,RST_KOUNT_R2D_DATA & !<-- # of words in the data string - ,MPI_REAL & !<-- The datatype - ,NPE_WRITE & !<-- The target write task - ,wrt_int_state%NFHOURS & !<-- An MPI tag - ,INTERCOMM_WRITE_GROUP & !<-- The MPI intercommunicator between fcst and quilt tasks - ,RST_IH_REAL & !<-- MPI communication request handle - ,IERR ) -! - IF(IERR/=0)WRITE(0,*)' ISend of real data by fcst task 0 has failed. IERR=',IERR - ENDIF -! - ENDIF -! - ENDDO -! - write_send_outp_tim=write_send_outp_tim+timef()-btim -! -!----------------------------------------------------------------------- -!*** The restart files need to contain the full-domain BC data -!*** in order for nests to produce bitwise identical results when -!*** restarting as compared to their free forecasts. -!*** Thus all boundary forecast tasks need to unload their pieces -!*** of the data from the Write import state and send them to task 0 -!*** for assembly. -!----------------------------------------------------------------------- -! -!-------------------------- -!*** South Boundary Tasks -!-------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Local Pieces of South BC Wind Data" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(wrt_int_state%NUM_WORDS_BC_SOUTH(MYPE)>0)THEN !<-- Fcst tasks along south boundary -! - CALL ESMF_AttributeGet(state =IMP_STATE_WRITE & !<-- The Write component import state - ,name ='RST_BC_DATA_SOUTH' & !<-- Name of south BC data on this task - ,valueList=wrt_int_state%RST_BC_DATA_SOUTH & !<-- Place the data here - ,rc =RC) -! - IF(MYPE/=0)THEN - CALL MPI_SEND(wrt_int_state%RST_BC_DATA_SOUTH & !<-- Send this string of subdomain data - ,wrt_int_state%NUM_WORDS_BC_SOUTH(MYPE) & !<-- Number of words sent - ,MPI_REAL & !<-- Datatype - ,0 & !<-- Send the data to fcst task 0 - ,MYPE & !<-- An MPI tag - ,MPI_COMM_COMP & !<-- MPI communicator - ,IERR ) - ENDIF -! - ENDIF -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!-------------------------- -!*** North Boundary Tasks -!-------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Unload Local Pieces of North BC Wind Data" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(wrt_int_state%NUM_WORDS_BC_NORTH(MYPE)>0)THEN !<-- Fcst tasks along north boundary -! - CALL ESMF_AttributeGet(state =IMP_STATE_WRITE & !<-- The Write component import state - ,name ='RST_BC_DATA_NORTH' & !<-- Name of north BC data on this task - ,valueList=wrt_int_state%RST_BC_DATA_NORTH & !<-- Place the data here - ,rc =RC) -! - IF(MYPE/=0)THEN - CALL MPI_SEND(wrt_int_state%RST_BC_DATA_NORTH & !<-- Send this string of subdomain data - ,wrt_int_state%NUM_WORDS_BC_NORTH(MYPE) & !<-- Number of words sent - ,MPI_REAL & !<-- Datatype - ,0 & !<-- Send the data to the fcst task 0 - ,MYPE & !<-- An MPI tag - ,MPI_COMM_COMP & !<-- MPI communicator - ,IERR ) - ENDIF -! - ENDIF -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!------------------------- -!*** West Boundary Tasks -!------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Local Pieces of West BC Wind Data" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(wrt_int_state%NUM_WORDS_BC_WEST(MYPE)>0)THEN !<-- Fcst tasks along west boundary -! - CALL ESMF_AttributeGet(state =IMP_STATE_WRITE & !<-- The Write component import state - ,name ='RST_BC_DATA_WEST' & !<-- Name of west BC data on this task - ,valueList=wrt_int_state%RST_BC_DATA_WEST & !<-- Place the data here - ,rc =RC) -! - IF(MYPE/=0)THEN - CALL MPI_SEND(wrt_int_state%RST_BC_DATA_WEST & !<-- Send this string of subdomain data - ,wrt_int_state%NUM_WORDS_BC_WEST(MYPE) & !<-- Number of words sent - ,MPI_REAL & !<-- Datatype - ,0 & !<-- Send the data to the fcst task 0 - ,MYPE & !<-- An MPI tag - ,MPI_COMM_COMP & !<-- MPI communicator - ,IERR ) - ENDIF -! - ENDIF -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!------------------------- -!*** East Boundary Tasks -!------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Local Pieces of East BC Wind Data" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(wrt_int_state%NUM_WORDS_BC_EAST(MYPE)>0)THEN !<-- Fcst tasks along east boundary -! - CALL ESMF_AttributeGet(state =IMP_STATE_WRITE & !<-- The Write component import state - ,name ='RST_BC_DATA_EAST' & !<-- Name of west BC data on this task - ,valueList=wrt_int_state%RST_BC_DATA_EAST & !<-- Place the data here - ,rc =RC) -! - IF(MYPE/=0)THEN - CALL MPI_SEND(wrt_int_state%RST_BC_DATA_EAST & !<-- Send this string of subdomain data - ,wrt_int_state%NUM_WORDS_BC_EAST(MYPE) & !<-- Number of words sent - ,MPI_REAL & !<-- Datatype - ,0 & !<-- Send the data to the fcst task 0 - ,MYPE & !<-- An MPI tag - ,MPI_COMM_COMP & !<-- MPI communicator - ,IERR ) - ENDIF -! - ENDIF -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Forecast task 0 receives the boundary data from the -!*** boundary tasks and assembles it into full-domain arrays. -!----------------------------------------------------------------------- -! - fcst_task0: IF(MYPE==0)THEN -! -!----------------------------------------------------------------------- -! -!------------------------------------ -!*** Recv from South boundary tasks -!------------------------------------ -! - recv_south: IF(wrt_int_state%INPES>1)THEN -! - N1=1 - N2=wrt_int_state%INPES-1 -! - DO NTASK=N1,N2 !<-- Task IDs of south boundary tasks - ALLOCATE(BUFF_NTASK(1:wrt_int_state%NUM_WORDS_BC_SOUTH(NTASK))) -! - CALL MPI_RECV(BUFF_NTASK & !<-- Fcst tasks' string of local BC data - ,wrt_int_state%NUM_WORDS_BC_SOUTH(NTASK) & !<-- # of integer words in the local BC data string - ,MPI_REAL & !<-- Datatype - ,NTASK & !<-- Recv from this fcst task - ,NTASK & !<-- An MPI tag - ,MPI_COMM_COMP & !<-- The MPI intercommunicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - NX=0 -! -!----------------------------------------------------------------------- -!*** Extract south boundary points for 2-D H-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_2D_H>0)THEN - DO NV=1,NVARS_BC_2D_H - DO NT=1,2 - DO NB=1,LNSH - DO NA=wrt_int_state%LOCAL_ISTART(NTASK),wrt_int_state%LOCAL_IEND(NTASK) - NX=NX+1 - wrt_int_state%BND_VARS_H%VAR_2D(NV)%SOUTH(NA,NB,NT)=BUFF_NTASK(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract south boundary points for 3-D H-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - DO NT=1,2 - DO NC=1,LM - DO NB=1,LNSH - DO NA=wrt_int_state%LOCAL_ISTART(NTASK),wrt_int_state%LOCAL_IEND(NTASK) - NX=NX+1 - wrt_int_state%BND_VARS_H%VAR_3D(NV)%SOUTH(NA,NB,NC,NT)=BUFF_NTASK(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract south boundary points for 4-D H-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - LB=wrt_int_state%LBND_4D(NV) - UB=wrt_int_state%UBND_4D(NV) - DO NL=LB,UB - DO NT=1,2 - DO NC=1,LM - DO NB=1,LNSH - DO NA=wrt_int_state%LOCAL_ISTART(NTASK),wrt_int_state%LOCAL_IEND(NTASK) - NX=NX+1 - wrt_int_state%BND_VARS_H%VAR_4D(NV)%SOUTH(NA,NB,NC,NT,NL)=BUFF_NTASK(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract south boundary points for 2-D V-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - DO NT=1,2 - DO NB=1,LNSV - DO NA=wrt_int_state%LOCAL_ISTART(NTASK),wrt_int_state%LOCAL_IEND(NTASK) - NX=NX+1 - wrt_int_state%BND_VARS_V%VAR_2D(NV)%SOUTH(NA,NB,NT)=BUFF_NTASK(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract south boundary points for 3-D V-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - DO NT=1,2 - DO NC=1,LM - DO NB=1,LNSV - DO NA=wrt_int_state%LOCAL_ISTART(NTASK),wrt_int_state%LOCAL_IEND(NTASK) - NX=NX+1 - wrt_int_state%BND_VARS_V%VAR_3D(NV)%SOUTH(NA,NB,NC,NT)=BUFF_NTASK(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - DEALLOCATE(BUFF_NTASK) - ENDDO -! - ENDIF recv_south -! -!----------------------------------------------------------------------- -! -!------------------------------------ -!*** Recv from North boundary tasks -!------------------------------------ -! - recv_north: IF(LAST_FCST_TASK>0)THEN - - IF(wrt_int_state%JNPES>1)THEN - N1=(wrt_int_state%JNPES-1)*wrt_int_state%INPES - N2=N1+wrt_int_state%INPES-1 - ELSEIF(wrt_int_state%JNPES==1)THEN - N1=1 - N2=LAST_FCST_TASK - ENDIF -! - DO NTASK=N1,N2 !<-- Task IDs of north boundary tasks - ALLOCATE(BUFF_NTASK(1:wrt_int_state%NUM_WORDS_BC_NORTH(NTASK))) -! - CALL MPI_RECV(BUFF_NTASK & !<-- Fcst tasks' string of local BC data - ,wrt_int_state%NUM_WORDS_BC_NORTH(NTASK) & !<-- # of integer words in the local BC data string - ,MPI_REAL & !<-- Datatype - ,NTASK & !<-- Recv from this fcst task - ,NTASK & !<-- An MPI tag - ,MPI_COMM_COMP & !<-- The MPI intercommunicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - NX=0 -! -!----------------------------------------------------------------------- -!*** Extract north boundary points for 2-D H-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_2D_H>0)THEN - DO NV=1,NVARS_BC_2D_H - DO NT=1,2 - DO NB=1,LNSH - DO NA=wrt_int_state%LOCAL_ISTART(NTASK),wrt_int_state%LOCAL_IEND(NTASK) - NX=NX+1 - wrt_int_state%BND_VARS_H%VAR_2D(NV)%NORTH(NA,NB,NT)=BUFF_NTASK(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract north boundary points for 3-D H-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - DO NT=1,2 - DO NC=1,LM - DO NB=1,LNSH - DO NA=wrt_int_state%LOCAL_ISTART(NTASK),wrt_int_state%LOCAL_IEND(NTASK) - NX=NX+1 - wrt_int_state%BND_VARS_H%VAR_3D(NV)%NORTH(NA,NB,NC,NT)=BUFF_NTASK(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract north boundary points for 4-D H-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - LB=wrt_int_state%LBND_4D(NV) - UB=wrt_int_state%UBND_4D(NV) - DO NL=LB,UB - DO NT=1,2 - DO NC=1,LM - DO NB=1,LNSH - DO NA=wrt_int_state%LOCAL_ISTART(NTASK),wrt_int_state%LOCAL_IEND(NTASK) - NX=NX+1 - wrt_int_state%BND_VARS_H%VAR_4D(NV)%NORTH(NA,NB,NC,NT,NL)=BUFF_NTASK(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract north boundary points for 2-D V-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - DO NT=1,2 - DO NB=1,LNSV - DO NA=wrt_int_state%LOCAL_ISTART(NTASK),wrt_int_state%LOCAL_IEND(NTASK) - NX=NX+1 - wrt_int_state%BND_VARS_V%VAR_2D(NV)%NORTH(NA,NB,NT)=BUFF_NTASK(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract north boundary points for 3-D V-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - DO NT=1,2 - DO NC=1,LM - DO NB=1,LNSV - DO NA=wrt_int_state%LOCAL_ISTART(NTASK),wrt_int_state%LOCAL_IEND(NTASK) - NX=NX+1 - wrt_int_state%BND_VARS_V%VAR_3D(NV)%NORTH(NA,NB,NC,NT)=BUFF_NTASK(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - DEALLOCATE(BUFF_NTASK) - ENDDO -! - ENDIF recv_north -! -!----------------------------------------------------------------------- -! -!----------------------------------- -!*** Recv from West boundary tasks -!----------------------------------- -! - recv_west: IF(wrt_int_state%JNPES>1)THEN -! - N1=wrt_int_state%INPES - N2=(wrt_int_state%JNPES-1)*wrt_int_state%INPES -! - DO NTASK=N1,N2,wrt_int_state%INPES !<-- Task IDs of west boundary tasks - ALLOCATE(BUFF_NTASK(1:wrt_int_state%NUM_WORDS_BC_WEST(NTASK))) -! - CALL MPI_RECV(BUFF_NTASK & !<-- Fcst tasks' string of local BC data - ,wrt_int_state%NUM_WORDS_BC_WEST(NTASK) & !<-- # of integer words in the local BC data string - ,MPI_REAL & !<-- Datatype - ,NTASK & !<-- Recv from this fcst task - ,NTASK & !<-- An MPI tag - ,MPI_COMM_COMP & !<-- The MPI intercommunicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - NX=0 -! -!----------------------------------------------------------------------- -!*** Extract west boundary points for 2-D H-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_2D_H>0)THEN - DO NV=1,NVARS_BC_2D_H - DO NT=1,2 - DO NB=wrt_int_state%LOCAL_JSTART(NTASK),wrt_int_state%LOCAL_JEND(NTASK) - DO NA=1,LNSH - NX=NX+1 - wrt_int_state%BND_VARS_H%VAR_2D(NV)%WEST(NA,NB,NT)=BUFF_NTASK(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract west boundary points for 3-D H-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - DO NT=1,2 - DO NC=1,LM - DO NB=wrt_int_state%LOCAL_JSTART(NTASK),wrt_int_state%LOCAL_JEND(NTASK) - DO NA=1,LNSH - NX=NX+1 - wrt_int_state%BND_VARS_H%VAR_3D(NV)%WEST(NA,NB,NC,NT)=BUFF_NTASK(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract west boundary points for 4-D H-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - LB=wrt_int_state%LBND_4D(NV) - UB=wrt_int_state%UBND_4D(NV) - DO NL=LB,UB - DO NT=1,2 - DO NC=1,LM - DO NB=wrt_int_state%LOCAL_JSTART(NTASK),wrt_int_state%LOCAL_JEND(NTASK) - DO NA=1,LNSH - NX=NX+1 - wrt_int_state%BND_VARS_H%VAR_4D(NV)%WEST(NA,NB,NC,NT,NL)=BUFF_NTASK(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract west boundary points for 2-D V-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - DO NT=1,2 - DO NB=wrt_int_state%LOCAL_JSTART(NTASK),wrt_int_state%LOCAL_JEND(NTASK) - DO NA=1,LNSV - NX=NX+1 - wrt_int_state%BND_VARS_V%VAR_2D(NV)%WEST(NA,NB,NT)=BUFF_NTASK(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract west boundary points for 3-D V-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - DO NT=1,2 - DO NC=1,LM - DO NB=wrt_int_state%LOCAL_JSTART(NTASK),wrt_int_state%LOCAL_JEND(NTASK) - DO NA=1,LNSV - NX=NX+1 - wrt_int_state%BND_VARS_V%VAR_3D(NV)%WEST(NA,NB,NC,NT)=BUFF_NTASK(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - DEALLOCATE(BUFF_NTASK) - ENDDO -! - ENDIF recv_west -! -!----------------------------------------------------------------------- -! -!----------------------------------- -!*** Recv from East boundary tasks -!----------------------------------- -! - recv_east: IF(LAST_FCST_TASK>0)THEN -! - IF(wrt_int_state%INPES>1)THEN - N1=wrt_int_state%INPES-1 - N2=wrt_int_state%JNPES*wrt_int_state%INPES-1 - ELSEIF(wrt_int_state%INPES==1)THEN - N1=1 - N2=LAST_FCST_TASK - ENDIF -! - DO NTASK=N1,N2,wrt_int_state%INPES !<-- Task IDs of east boundary tasks - ALLOCATE(BUFF_NTASK(1:wrt_int_state%NUM_WORDS_BC_EAST(NTASK))) -! - CALL MPI_RECV(BUFF_NTASK & !<-- Fcst tasks' string of local BC data - ,wrt_int_state%NUM_WORDS_BC_EAST(NTASK) & !<-- # of integer words in the local BC data string - ,MPI_REAL & !<-- Datatype - ,NTASK & !<-- Recv from this fcst task - ,NTASK & !<-- An MPI tag - ,MPI_COMM_COMP & !<-- The MPI intercommunicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - NX=0 -! -!----------------------------------------------------------------------- -!*** Extract east boundary points for 2-D H-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_2D_H>0)THEN - DO NV=1,NVARS_BC_2D_H - DO NT=1,2 - DO NB=wrt_int_state%LOCAL_JSTART(NTASK),wrt_int_state%LOCAL_JEND(NTASK) - DO NA=1,LNSH - NX=NX+1 - wrt_int_state%BND_VARS_H%VAR_2D(NV)%EAST(NA,NB,NT)=BUFF_NTASK(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract east boundary points for 3-D H-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - DO NT=1,2 - DO NC=1,LM - DO NB=wrt_int_state%LOCAL_JSTART(NTASK),wrt_int_state%LOCAL_JEND(NTASK) - DO NA=1,LNSH - NX=NX+1 - wrt_int_state%BND_VARS_H%VAR_3D(NV)%EAST(NA,NB,NC,NT)=BUFF_NTASK(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract east boundary points for 4-D H-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - LB=wrt_int_state%LBND_4D(NV) - UB=wrt_int_state%UBND_4D(NV) - DO NL=LB,UB - DO NT=1,2 - DO NC=1,LM - DO NB=wrt_int_state%LOCAL_JSTART(NTASK),wrt_int_state%LOCAL_JEND(NTASK) - DO NA=1,LNSH - NX=NX+1 - wrt_int_state%BND_VARS_H%VAR_4D(NV)%EAST(NA,NB,NC,NT,NL)=BUFF_NTASK(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract east boundary points for 2-D V-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - DO NT=1,2 - DO NB=wrt_int_state%LOCAL_JSTART(NTASK),wrt_int_state%LOCAL_JEND(NTASK) - DO NA=1,LNSV - NX=NX+1 - wrt_int_state%BND_VARS_V%VAR_2D(NV)%EAST(NA,NB,NT)=BUFF_NTASK(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract east boundary points for 3-D V-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - DO NT=1,2 - DO NC=1,LM - DO NB=wrt_int_state%LOCAL_JSTART(NTASK),wrt_int_state%LOCAL_JEND(NTASK) - DO NA=1,LNSV - NX=NX+1 - wrt_int_state%BND_VARS_V%VAR_3D(NV)%EAST(NA,NB,NC,NT)=BUFF_NTASK(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - DEALLOCATE(BUFF_NTASK) - ENDDO -! - ENDIF recv_east -! -!----------------------------------------------------------------------- -!*** Forecast task 0's own BC data. First the south boundary. -!----------------------------------------------------------------------- -! - IF(JTS==JDS)THEN -! - NX=0 -! -!----------------------------------------------------------------------- -!*** Extract south boundary points for 2-D H-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_2D_H>0)THEN - DO NV=1,NVARS_BC_2D_H - DO NT=1,2 - DO NB=1,LNSH - DO NA=ITS,ITE - NX=NX+1 - wrt_int_state%BND_VARS_H%VAR_2D(NV)%SOUTH(NA,NB,NT)= & - wrt_int_state%RST_BC_DATA_SOUTH(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract south boundary points for 3-D H-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - DO NT=1,2 - DO NC=1,LM - DO NB=1,LNSH - DO NA=ITS,ITE - NX=NX+1 - wrt_int_state%BND_VARS_H%VAR_3D(NV)%SOUTH(NA,NB,NC,NT)= & - wrt_int_state%RST_BC_DATA_SOUTH(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract south boundary points for 4-D H-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - LB=wrt_int_state%LBND_4D(NV) - UB=wrt_int_state%UBND_4D(NV) - DO NL=LB,UB - DO NT=1,2 - DO NC=1,LM - DO NB=1,LNSH - DO NA=ITS,ITE - NX=NX+1 - wrt_int_state%BND_VARS_H%VAR_4D(NV)%SOUTH(NA,NB,NC,NT,NL)= & - wrt_int_state%RST_BC_DATA_SOUTH(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract south boundary points for 2-D V-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - DO NT=1,2 - DO NB=1,LNSV - DO NA=ITS,ITE - NX=NX+1 - wrt_int_state%BND_VARS_V%VAR_2D(NV)%SOUTH(NA,NB,NT)= & - wrt_int_state%RST_BC_DATA_SOUTH(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract south boundary points for 3-D V-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - DO NT=1,2 - DO NC=1,LM - DO NB=1,LNSV - DO NA=ITS,ITE - NX=NX+1 - wrt_int_state%BND_VARS_V%VAR_3D(NV)%SOUTH(NA,NB,NC,NT)= & - wrt_int_state%RST_BC_DATA_SOUTH(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Forecast task 0's north boundary. -!----------------------------------------------------------------------- -! - IF(JTE==JDE)THEN -! - NX=0 -! -!----------------------------------------------------------------------- -!*** Extract north boundary points for 2-D H-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_2D_H>0)THEN - DO NV=1,NVARS_BC_2D_H - DO NT=1,2 - DO NB=1,LNSH - DO NA=ITS,ITE - NX=NX+1 - wrt_int_state%BND_VARS_H%VAR_2D(NV)%NORTH(NA,NB,NT)= & - wrt_int_state%RST_BC_DATA_NORTH(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract north boundary points for 3-D H-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - DO NT=1,2 - DO NC=1,LM - DO NB=1,LNSH - DO NA=ITS,ITE - NX=NX+1 - wrt_int_state%BND_VARS_H%VAR_3D(NV)%NORTH(NA,NB,NC,NT)= & - wrt_int_state%RST_BC_DATA_NORTH(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract north boundary points for 4-D H-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - LB=wrt_int_state%LBND_4D(NV) - UB=wrt_int_state%UBND_4D(NV) - DO NL=LB,UB - DO NT=1,2 - DO NC=1,LM - DO NB=1,LNSH - DO NA=ITS,ITE - NX=NX+1 - wrt_int_state%BND_VARS_H%VAR_4D(NV)%NORTH(NA,NB,NC,NT,NL)= & - wrt_int_state%RST_BC_DATA_NORTH(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract north boundary points for 2-D V-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - DO NT=1,2 - DO NB=1,LNSV - DO NA=ITS,ITE - NX=NX+1 - wrt_int_state%BND_VARS_V%VAR_2D(NV)%NORTH(NA,NB,NT)= & - wrt_int_state%RST_BC_DATA_NORTH(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract north boundary points for 3-D V-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - DO NT=1,2 - DO NC=1,LM - DO NB=1,LNSV - DO NA=ITS,ITE - NX=NX+1 - wrt_int_state%BND_VARS_V%VAR_3D(NV)%NORTH(NA,NB,NC,NT)= & - wrt_int_state%RST_BC_DATA_NORTH(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Forecast task 0's west boundary. -!----------------------------------------------------------------------- -! - IF(ITS==IDS)THEN -! - NX=0 -! -!----------------------------------------------------------------------- -!*** Extract west boundary points for 2-D H-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_2D_H>0)THEN - DO NV=1,NVARS_BC_2D_H - DO NT=1,2 - DO NB=JTS,JTE - DO NA=1,LNSH - NX=NX+1 - wrt_int_state%BND_VARS_H%VAR_2D(NV)%WEST(NA,NB,NT)= & - wrt_int_state%RST_BC_DATA_WEST(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract west boundary points for 3-D H-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - DO NT=1,2 - DO NC=1,LM - DO NB=JTS,JTE - DO NA=1,LNSH - NX=NX+1 - wrt_int_state%BND_VARS_H%VAR_3D(NV)%WEST(NA,NB,NC,NT)= & - wrt_int_state%RST_BC_DATA_WEST(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract west boundary points for 4-D H-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - LB=wrt_int_state%LBND_4D(NV) - UB=wrt_int_state%UBND_4D(NV) - DO NL=LB,UB - DO NT=1,2 - DO NC=1,LM - DO NB=JTS,JTE - DO NA=1,LNSH - NX=NX+1 - wrt_int_state%BND_VARS_H%VAR_4D(NV)%WEST(NA,NB,NC,NT,NL)= & - wrt_int_state%RST_BC_DATA_WEST(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract west boundary points for 2-D V-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - DO NT=1,2 - DO NB=JTS,JTE - DO NA=1,LNSV - NX=NX+1 - wrt_int_state%BND_VARS_V%VAR_2D(NV)%WEST(NA,NB,NT)= & - wrt_int_state%RST_BC_DATA_WEST(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract west boundary points for 3-D V-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - DO NT=1,2 - DO NC=1,LM - DO NB=JTS,JTE - DO NA=1,LNSV - NX=NX+1 - wrt_int_state%BND_VARS_V%VAR_3D(NV)%WEST(NA,NB,NC,NT)= & - wrt_int_state%RST_BC_DATA_WEST(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Forecast task 0's east boundary. -!----------------------------------------------------------------------- -! - IF(ITE==IDE)THEN -! - NX=0 -! -!----------------------------------------------------------------------- -!*** Extract east boundary points for 2-D H-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_2D_H>0)THEN - DO NV=1,NVARS_BC_2D_H - DO NT=1,2 - DO NB=JTS,JTE - DO NA=1,LNSH - NX=NX+1 - wrt_int_state%BND_VARS_H%VAR_2D(NV)%EAST(NA,NB,NT)= & - wrt_int_state%RST_BC_DATA_EAST(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract east boundary points for 3-D H-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - DO NT=1,2 - DO NC=1,LM - DO NB=JTS,JTE - DO NA=1,LNSH - NX=NX+1 - wrt_int_state%BND_VARS_H%VAR_3D(NV)%EAST(NA,NB,NC,NT)= & - wrt_int_state%RST_BC_DATA_EAST(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract east boundary points for 4-D H-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - LB=wrt_int_state%LBND_4D(NV) - UB=wrt_int_state%UBND_4D(NV) - DO NL=LB,UB - DO NT=1,2 - DO NC=1,LM - DO NB=JTS,JTE - DO NA=1,LNSH - NX=NX+1 - wrt_int_state%BND_VARS_H%VAR_4D(NV)%EAST(NA,NB,NC,NT,NL)= & - wrt_int_state%RST_BC_DATA_EAST(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract east boundary points for 2-D V-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - DO NT=1,2 - DO NB=JTS,JTE - DO NA=1,LNSV - NX=NX+1 - wrt_int_state%BND_VARS_V%VAR_2D(NV)%EAST(NA,NB,NT)= & - wrt_int_state%RST_BC_DATA_EAST(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Extract east boundary points for 3-D V-pt variables. -!----------------------------------------------------------------------- -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - DO NT=1,2 - DO NC=1,LM - DO NB=JTS,JTE - DO NA=1,LNSV - NX=NX+1 - wrt_int_state%BND_VARS_V%VAR_3D(NV)%EAST(NA,NB,NC,NT)= & - wrt_int_state%RST_BC_DATA_EAST(NX) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Forecast task 0 renders all the boundary data into -!*** a single 1-D string to send to the lead write task. -!*** Be sure the BC data buffer for the ISend to the lead -!*** quilt task is clear. -!----------------------------------------------------------------------- -! - btim=timef() - CALL MPI_WAIT(RST_IH_BC,JSTAT,IERR) - wait_time=timef()-btim - if(wait_time>1.e3)write(0,*)' Long BC buffer WAIT =',wait_time*1.e-3 -! - KOUNT=0 -! -!-------------------- -!*** South Boundary -!-------------------- -! - IF(NVARS_BC_2D_H>0)THEN - DO NV=1,NVARS_BC_2D_H - DO NT=1,2 - DO NB=1,LNSH - DO NA=1,IDE - KOUNT=KOUNT+1 - wrt_int_state%RST_ALL_BC_DATA(KOUNT)= & - wrt_int_state%BND_VARS_H%VAR_2D(NV)%SOUTH(NA,NB,NT) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - DO NT=1,2 - DO NC=1,LM - DO NB=1,LNSH - DO NA=1,IDE - KOUNT=KOUNT+1 - wrt_int_state%RST_ALL_BC_DATA(KOUNT)= & - wrt_int_state%BND_VARS_H%VAR_3D(NV)%SOUTH(NA,NB,NC,NT) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - LB=wrt_int_state%LBND_4D(NV) - UB=wrt_int_state%UBND_4D(NV) - DO NL=LB,UB - DO NT=1,2 - DO NC=1,LM - DO NB=1,LNSH - DO NA=1,IDE - KOUNT=KOUNT+1 - wrt_int_state%RST_ALL_BC_DATA(KOUNT)= & - wrt_int_state%BND_VARS_H%VAR_4D(NV)%SOUTH(NA,NB,NC,NT,NL) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - DO NT=1,2 - DO NB=1,LNSV - DO NA=1,IDE - KOUNT=KOUNT+1 - wrt_int_state%RST_ALL_BC_DATA(KOUNT)= & - wrt_int_state%BND_VARS_V%VAR_2D(NV)%SOUTH(NA,NB,NT) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - DO NT=1,2 - DO NC=1,LM - DO NB=1,LNSV - DO NA=1,IDE - KOUNT=KOUNT+1 - wrt_int_state%RST_ALL_BC_DATA(KOUNT)= & - wrt_int_state%BND_VARS_V%VAR_3D(NV)%SOUTH(NA,NB,NC,NT) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!-------------------- -!*** North Boundary -!-------------------- -! - IF(NVARS_BC_2D_H>0)THEN - DO NV=1,NVARS_BC_2D_H - DO NT=1,2 - DO NB=1,LNSH - DO NA=1,IDE - KOUNT=KOUNT+1 - wrt_int_state%RST_ALL_BC_DATA(KOUNT)= & - wrt_int_state%BND_VARS_H%VAR_2D(NV)%NORTH(NA,NB,NT) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - DO NT=1,2 - DO NC=1,LM - DO NB=1,LNSH - DO NA=1,IDE - KOUNT=KOUNT+1 - wrt_int_state%RST_ALL_BC_DATA(KOUNT)= & - wrt_int_state%BND_VARS_H%VAR_3D(NV)%NORTH(NA,NB,NC,NT) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - LB=wrt_int_state%LBND_4D(NV) - UB=wrt_int_state%UBND_4D(NV) - DO NL=LB,UB - DO NT=1,2 - DO NC=1,LM - DO NB=1,LNSH - DO NA=1,IDE - KOUNT=KOUNT+1 - wrt_int_state%RST_ALL_BC_DATA(KOUNT)= & - wrt_int_state%BND_VARS_H%VAR_4D(NV)%NORTH(NA,NB,NC,NT,NL) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - DO NT=1,2 - DO NB=1,LNSV - DO NA=1,IDE - KOUNT=KOUNT+1 - wrt_int_state%RST_ALL_BC_DATA(KOUNT)= & - wrt_int_state%BND_VARS_V%VAR_2D(NV)%NORTH(NA,NB,NT) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - DO NT=1,2 - DO NC=1,LM - DO NB=1,LNSV - DO NA=1,IDE - KOUNT=KOUNT+1 - wrt_int_state%RST_ALL_BC_DATA(KOUNT)= & - wrt_int_state%BND_VARS_V%VAR_3D(NV)%NORTH(NA,NB,NC,NT) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!------------------- -!*** West Boundary -!------------------- -! - IF(NVARS_BC_2D_H>0)THEN - DO NV=1,NVARS_BC_2D_H - DO NT=1,2 - DO NB=1,JDE - DO NA=1,LNSH - KOUNT=KOUNT+1 - wrt_int_state%RST_ALL_BC_DATA(KOUNT)= & - wrt_int_state%BND_VARS_H%VAR_2D(NV)%WEST(NA,NB,NT) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - DO NT=1,2 - DO NC=1,LM - DO NB=1,JDE - DO NA=1,LNSH - KOUNT=KOUNT+1 - wrt_int_state%RST_ALL_BC_DATA(KOUNT)= & - wrt_int_state%BND_VARS_H%VAR_3D(NV)%WEST(NA,NB,NC,NT) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - LB=wrt_int_state%LBND_4D(NV) - UB=wrt_int_state%UBND_4D(NV) - DO NL=LB,UB - DO NT=1,2 - DO NC=1,LM - DO NB=1,JDE - DO NA=1,LNSH - KOUNT=KOUNT+1 - wrt_int_state%RST_ALL_BC_DATA(KOUNT)= & - wrt_int_state%BND_VARS_H%VAR_4D(NV)%WEST(NA,NB,NC,NT,NL) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - DO NT=1,2 - DO NB=1,JDE - DO NA=1,LNSV - KOUNT=KOUNT+1 - wrt_int_state%RST_ALL_BC_DATA(KOUNT)= & - wrt_int_state%BND_VARS_V%VAR_2D(NV)%WEST(NA,NB,NT) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - DO NT=1,2 - DO NC=1,LM - DO NB=1,JDE - DO NA=1,LNSV - KOUNT=KOUNT+1 - wrt_int_state%RST_ALL_BC_DATA(KOUNT)= & - wrt_int_state%BND_VARS_V%VAR_3D(NV)%WEST(NA,NB,NC,NT) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!------------------- -!*** East Boundary -!------------------- -! - IF(NVARS_BC_2D_H>0)THEN - DO NV=1,NVARS_BC_2D_H - DO NT=1,2 - DO NB=1,JDE - DO NA=1,LNSH - KOUNT=KOUNT+1 - wrt_int_state%RST_ALL_BC_DATA(KOUNT)= & - wrt_int_state%BND_VARS_H%VAR_2D(NV)%EAST(NA,NB,NT) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_H>0)THEN - DO NV=1,NVARS_BC_3D_H - DO NT=1,2 - DO NC=1,LM - DO NB=1,JDE - DO NA=1,LNSH - KOUNT=KOUNT+1 - wrt_int_state%RST_ALL_BC_DATA(KOUNT)= & - wrt_int_state%BND_VARS_H%VAR_3D(NV)%EAST(NA,NB,NC,NT) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_4D_H>0)THEN - DO NV=1,NVARS_BC_4D_H - LB=wrt_int_state%LBND_4D(NV) - UB=wrt_int_state%UBND_4D(NV) - DO NL=LB,UB - DO NT=1,2 - DO NC=1,LM - DO NB=1,JDE - DO NA=1,LNSH - KOUNT=KOUNT+1 - wrt_int_state%RST_ALL_BC_DATA(KOUNT)= & - wrt_int_state%BND_VARS_H%VAR_4D(NV)%EAST(NA,NB,NC,NT,NL) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_2D_V>0)THEN - DO NV=1,NVARS_BC_2D_V - DO NT=1,2 - DO NB=1,JDE - DO NA=1,LNSV - KOUNT=KOUNT+1 - wrt_int_state%RST_ALL_BC_DATA(KOUNT)= & - wrt_int_state%BND_VARS_V%VAR_2D(NV)%EAST(NA,NB,NT) - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! - IF(NVARS_BC_3D_V>0)THEN - DO NV=1,NVARS_BC_3D_V - DO NT=1,2 - DO NC=1,LM - DO NB=1,JDE - DO NA=1,LNSV - KOUNT=KOUNT+1 - wrt_int_state%RST_ALL_BC_DATA(KOUNT)= & - wrt_int_state%BND_VARS_V%VAR_3D(NV)%EAST(NA,NB,NC,NT) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Now forecast task 0 must send the full-domain boundary data -!*** to the lead write task for inserting it into the restart file. -!----------------------------------------------------------------------- -! - CALL MPI_ISSEND(wrt_int_state%RST_ALL_BC_DATA & !<-- 1-D String of full domain BC data - ,wrt_int_state%NUM_WORDS_SEND_BC(1) & !<-- # of words in the BC data string - ,MPI_REAL & !<-- The datatype - ,0 & !<-- Local ID of lead write task - ,wrt_int_state%NFHOURS & !<-- An MPI tag - ,INTERCOMM_WRITE_GROUP & !<-- The MPI intercommunicator between fcst and quilt tasks - ,RST_IH_BC & !<-- MPI communication request handle - ,IERR ) -! - IF(IERR/=0)WRITE(0,*)' ISend of BC data by fcst task 0 has failed. IERR=',IERR -! - ENDIF fcst_task0 -! -!----------------------------------------------------------------------- -! - ENDIF rst_fcst_tasks -! - write_run_tim=write_run_tim+(timef()-btim0) -! -!----------------------------------------------------------------------- -!*** The forecast tasks are completely finished with history and -!*** restart output now so they will exit the routine and resume -!*** the integration. -!----------------------------------------------------------------------- -! - IF(MYPE<=LAST_FCST_TASK)RETURN -! -!----------------------------------------------------------------------- -! - btim0=timef() -! - history_time: IF(TIME_FOR_HISTORY) THEN -! -!----------------------------------------------------------------------- -!*** The lead Write task receives the latest Attributes from the -!*** lead fcst task. -!----------------------------------------------------------------------- -! - IF(MYPE==LEAD_WRITE_TASK)THEN -! - WRITE_GROUP=NCURRENT_GROUP(ID_DOMAIN) -! -!-------------- -!*** Integers -!-------------- -! - IF(wrt_int_state%LENGTH_SUM_I1D(1)>0)THEN -! - CALL MPI_RECV(wrt_int_state%ALL_DATA_I1D & !<-- Recv string of integer history Attributes - ,wrt_int_state%LENGTH_SUM_I1D(1) & !<-- Words received - ,MPI_INTEGER & !<-- Data is integer - ,0 & !<-- Sending task (lead fcst task) - ,WRITE_GROUP & !<-- MPI tag - ,INTERCOMM_WRITE_GROUP & !<-- MPI domain commumicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - ENDIF -! -!----------- -!*** Reals -!----------- -! - IF(wrt_int_state%LENGTH_SUM_R1D(1)>0)THEN -! - CALL MPI_RECV(wrt_int_state%ALL_DATA_R1D & !<-- Recv string of real history Attributes - ,wrt_int_state%LENGTH_SUM_R1D(1) & !<-- Words received - ,MPI_REAL & !<-- Data is real - ,0 & !<-- Sending task (lead fcst task) - ,WRITE_GROUP & !<-- MPI tag - ,INTERCOMM_WRITE_GROUP & !<-- MPI domain commumicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - ENDIF -! -!-------------- -!*** Logicals -!-------------- -! - IF(wrt_int_state%LENGTH_SUM_LOG(1)>0)THEN -! - CALL MPI_RECV(wrt_int_state%ALL_DATA_LOG & !<-- Recv string of logical history Attributes - ,wrt_int_state%LENGTH_SUM_LOG(1) & !<-- Words received - ,MPI_LOGICAL & !<-- Data is logical - ,0 & !<-- Sending task (lead fcst task) - ,WRITE_GROUP & !<-- MPI tag - ,INTERCOMM_WRITE_GROUP & !<-- MPI domain commumicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Each write task in the active write group receives the -!*** strings of 2D history data from the appropriate fcst tasks. -!----------------------------------------------------------------------- -! - ID_START=wrt_int_state%ID_FTASK_RECV_STA(MYPE) !<-- First fcst task that sends to this write task - ID_END =wrt_int_state%ID_FTASK_RECV_END(MYPE) !<-- Last fcst task that sends to this write task - NFCST_TASKS=ID_END-ID_START+1 !<-- Number of fcst tasks sending to this write task -! -!----------------------------------------------------------------------- - hst_from_fcst_tasks: DO N=1,NFCST_TASKS !<-- Loop through fcst tasks sending to this write task -!----------------------------------------------------------------------- -! - ID_RECV=ID_START+N-1 -! -!----------------------------------------------------------------------- -!*** Receive 2-D Integer history data if there is any. -!----------------------------------------------------------------------- -! - IF(KOUNT_I2D>0)THEN - CALL MPI_RECV(wrt_int_state%ALL_DATA_I2D & !<-- Fcst tasks' string of 2D integer history data - ,wrt_int_state%NUM_WORDS_RECV_I2D_HST(ID_RECV) & !<-- # of integer words in the data string - ,MPI_INTEGER & !<-- The datatype - ,ID_RECV & !<-- Recv from this fcst task - ,wrt_int_state%NFHOURS & !<-- An MPI tag - ,INTERCOMM_WRITE_GROUP & !<-- The MPI intercommunicator between fcst and quilt tasks - ,JSTAT & !<-- MPI status object - ,IERR ) -! - IF(IERR/=0)WRITE(0,*)' Recv by write task from fcst task has failed. IERR=',IERR - ENDIF -! -!----------------------------------------------------------------------- -!*** Receive 2-D Real history data if there is any. -!----------------------------------------------------------------------- -! - IF(KOUNT_R2D>0)THEN - CALL MPI_RECV(wrt_int_state%ALL_DATA_R2D & !<-- Fcst tasks' string of 2D real history data - ,wrt_int_state%NUM_WORDS_RECV_R2D_HST(ID_RECV) & !<-- # of real words in the data string - ,MPI_REAL & !<-- The datatype - ,ID_RECV & !<-- Recv from this fcst task - ,wrt_int_state%NFHOURS & !<-- An MPI tag - ,INTERCOMM_WRITE_GROUP & !<-- The MPI intercommunicator between fcst and quilt tasks - ,JSTAT & !<-- MPI status object - ,IERR ) -! - IF(IERR/=0)WRITE(0,*)' Recv by write task from fcst task has failed. IERR=',IERR - ENDIF - write_recv_outp_tim=write_recv_outp_tim+timef()-btim -! -!----------------------------------------------------------------------- -!*** Each write task needs to insert the pieces of the various -!*** 2D history arrays received from the individual fcst tasks -!*** into arrays that span the write tasks' own subsection of -!*** the full 2D domain. That subsection always spans the -!*** entire east-west dimension of the full domain (since full -!*** rows of fcst tasks always send to write tasks, never -!*** partial rows) and as much of the north-south dimension of -!*** the full domain as covered by those fcst tasks sending to -!*** a given write task. -!----------------------------------------------------------------------- -! - ITS=wrt_int_state%LOCAL_ISTART(ID_RECV) !<-- Local domain integration limits of sending fcst task - ITE=wrt_int_state%LOCAL_IEND(ID_RECV) !<-- - JTS=wrt_int_state%LOCAL_JSTART(ID_RECV) !<-- - JTE=wrt_int_state%LOCAL_JEND(ID_RECV) !<-- -! - IHALO=wrt_int_state%IHALO !<-- Subdomain halo depth in I - JHALO=wrt_int_state%JHALO !<-- Subdomain halo depth in J -! - IMS=ITS-IHALO - IME=ITE+IHALO - JMS=JTS-JHALO - JME=JTE+JHALO -! - NN=0 -! - DO NF=1,KOUNT_I2D !<-- Loop through all the 2D integer fields -! - DO J=JMS,JME - DO I=IMS,IME - NN=NN+1 - IF(IITE.OR.JJTE)CYCLE !<-- Exclude halo points - wrt_int_state%WRITE_SUBSET_I(I,J,NF)=wrt_int_state%ALL_DATA_I2D(NN) !<-- Put data into write task's domain subsection - ENDDO - ENDDO - ENDDO -! - NN=0 -! - DO NF=1,KOUNT_R2D !<-- Loop through all the 2D real fields -! - DO J=JMS,JME - DO I=IMS,IME - NN=NN+1 - IF(IITE.OR.JJTE)CYCLE !<-- Exclude halo points - wrt_int_state%WRITE_SUBSET_R(I,J,NF)=wrt_int_state%ALL_DATA_R2D(NN) !<-- Put data into write task's domain subsection - ENDDO - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -! - ENDDO hst_from_fcst_tasks -! -!----------------------------------------------------------------------- -!*** At this point, all write tasks have received all of the history -!*** data from their associated fcst tasks and assembled it onto -!*** their own subsections of the full 2D domain. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** The lead write task obtains the current forecast time and -!*** the elapsed forecast time for its writing of output. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** For dopost, all write tasks need to know the time. -!----------------------------------------------------------------------- -! - - IF(wrt_int_state%WRITE_DOPOST) THEN - LOG_PESET=MYPE>=LEAD_WRITE_TASK - ELSE - LOG_PESET=MYPE==LEAD_WRITE_TASK - ENDIF -! -!----------------------------------------------------------------------- - hst_time_get: IF(LOG_PESET)THEN !<-- The lead write task -!----------------------------------------------------------------------- -! - IF(wrt_int_state%WRITE_HST_BIN.OR. & - wrt_int_state%WRITE_HST_NEMSIO)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Lead Write Task Gets Current ESMF Time from Clock" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock =CLOCK & !<-- The ESMF Clock - ,currTime =CURRTIME & !<-- The current time (ESMF) on the clock - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** The current forecast time. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Lead Write Task Gets Actual Current Time from Clock" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeGet(time=CURRTIME & !<-- The cuurent forecast time (ESMF) - ,yy =IYEAR_FCST & !<-- The current forecast year (integer) - ,mm =IMONTH_FCST & !<-- The current forecast month (integer) - ,dd =IDAY_FCST & !<-- The current forecast day (integer) - ,h =IHOUR_FCST & !<-- The current forecast hour (integer) - ,m =IMINUTE_FCST & !<-- The current forecast minute (integer) - ,s =ISECOND_FCST & !<-- The current forecast second (integer) - ,sN =ISECOND_NUM & !<-- Numerator of current fractional second (integer) - ,sD =ISECOND_DEN & !<-- Denominator of current fractional second (integer) - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - SECOND_FCST=ISECOND_FCST+REAL(ISECOND_NUM)/REAL(ISECOND_DEN) !<-- Current forecast seconds (real) -! -!----------------------------------------------------------------------- -!*** The elapsed forecast time. -!----------------------------------------------------------------------- -! - wrt_int_state%IO_CURRTIMEDIFF=CURRTIME-wrt_int_state%IO_BASETIME -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Lead Write Task Gets Actual Elapsed Fcst Time" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeIntervalGet(timeinterval=wrt_int_state%IO_CURRTIMEDIFF & - ,h =NF_HOURS & !<-- Hours of elapsed time - ,m =NF_MINUTES & !<-- Minutes of elapsed time - ,s =NSECONDS & !<-- Seconds of elapsed time - ,sN =NSECONDS_NUM & !<-- Numerator of fractional elapsed seconds - ,sD =NSECONDS_DEN & !<-- Denominator of fractional elapsed seconds - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NF_SECONDS=NSECONDS+REAL(NSECONDS_NUM)/REAL(NSECONDS_DEN) -! - wrt_int_state%NFHOURS =NF_HOURS - wrt_int_state%NFMINUTES=NF_MINUTES - wrt_int_state%NFSECONDS=NF_SECONDS -! - ENDIF -! - ENDIF hst_time_get -! -!----------------------------------------------------------------------- -!*** DO POST: -!*** Call post processors to compute post variables -!---------------------------------------------------------------------- -! -!----------------------------------------------------------------------- - hst_dopost: IF(wrt_int_state%WRITE_DOPOST.and. & - wrt_int_state%WRITE_HST_NEMSIO.and.NF_HOURS>0 )THEN !<-- do post -!----------------------------------------------------------------------- -! - - IF(LOG_PESET)THEN !<-- The write tasks -! - POST_gridtype='B' - POST_MAPTYPE=205 - NSOIL=4 -! - CALL POST_RUN_NMM(wrt_int_state,MYPE,MPI_COMM_COMP, & - LEAD_WRITE_TASK,post_gridtype, & - post_maptype,NSOIL,NF_HOURS,NF_MINUTES) - print *,'af post_run_nmm,NF_HOURS=',NF_HOURS -! - ENDIF - - ENDIF hst_dopost -! -!----------------------------------------------------------------------- -!*** The lead Write task now opens the history file(s) and writes -!*** the scalar/1D quantities. -!----------------------------------------------------------------------- -! - IF(MYPE==LEAD_WRITE_TASK)THEN -! - IF(wrt_int_state%WRITE_HST_BIN)THEN -! - CALL WRITE_RUNHISTORY_OPEN(WRT_INT_STATE & - ,IYEAR_FCST & - ,IMONTH_FCST & - ,IDAY_FCST & - ,IHOUR_FCST & - ,IMINUTE_FCST & - ,SECOND_FCST & - ,NF_HOURS & - ,NF_MINUTES & - ,NF_SECONDS & - ,HST_FIRST & - ,LEAD_WRITE_TASK) - ENDIF -! - IF(wrt_int_state%WRITE_HST_NEMSIO)THEN -! - CALL WRITE_NEMSIO_RUNHISTORY_OPEN(WRT_INT_STATE & - ,NEMSIOFILE & - ,IYEAR_FCST & - ,IMONTH_FCST & - ,IDAY_FCST & - ,IHOUR_FCST & - ,IMINUTE_FCST & - ,SECOND_FCST & - ,NF_HOURS & - ,NF_MINUTES & - ,NF_SECONDS & - ,DIM1,DIM2,NBDR,GLOBAL & - ,LEAD_WRITE_TASK,ID_DOMAIN) -! - FIELDSIZE=(DIM1+2*NBDR)*(DIM2+2*NBDR) - ALLOCATE(TMP(FIELDSIZE)) - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** We will now assemble the full domain 2-D history data onto -!*** the lead Write task from the subsections on all Write tasks -!*** then the lead task will write each 2D field to the history -!*** file(s). -! -!*** NOTE: The lead Write task assembles and writes to history only -!*** one 2-D Field at a time. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** First loop through all of the integer Fields. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- - field_loop_int: DO NFIELD=1,KOUNT_I2D !<-- Loop through all 2D integer gridded history data -!----------------------------------------------------------------------- -! - IF(MYPE>LEAD_WRITE_TASK)THEN !<-- All write tasks except the lead one - JSTA_WRITE=wrt_int_state%LOCAL_JSTART(wrt_int_state%ID_FTASK_RECV_STA(MYPE)) !<-- Starting J of this write task's subsection - JEND_WRITE=wrt_int_state%LOCAL_JEND (wrt_int_state%ID_FTASK_RECV_END(MYPE)) !<-- Ending J of this write task's subsection -! - NN=0 -! - DO J=JSTA_WRITE,JEND_WRITE - DO I=1,IM - NN=NN+1 - wrt_int_state%BUFF_INT(NN)=wrt_int_state%WRITE_SUBSET_I(I,J,NFIELD) - ENDDO - ENDDO -! - CALL MPI_RECV(ID_DUMMY & !<-- Blocking Recv keeps the following sends in line - ,1 & !<-- Length of ID_DUMMY - ,MPI_INTEGER & !<-- Datatype - ,0 & !<-- The lead write task sent this - ,0 & !<-- An MPI tag - ,MPI_COMM_COMP & !<-- The communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - MY_LOCAL_ID=MYPE-LAST_FCST_TASK-1 !<-- This write task's local ID (between 0 and NWTPG-1) -! - CALL MPI_SEND(wrt_int_state%BUFF_INT & !<-- Send this string of subsection data - ,NN & !<-- Number of words sent - ,MPI_INTEGER & !<-- Datatype - ,0 & !<-- Send the data to the lead write task with local ID of 0 - ,MY_LOCAL_ID & !<-- An MPI tag - ,MPI_COMM_COMP & !<-- MPI communicator - ,IERR ) -! -!----------------------------------------------------------------------- -! - ELSEIF(MYPE==LEAD_WRITE_TASK)THEN !<-- The lead write task -! - JSTA_WRITE=wrt_int_state%LOCAL_JSTART(wrt_int_state%ID_FTASK_RECV_STA(MYPE)) !<-- Starting J of lead write task's subsection - JEND_WRITE=wrt_int_state%LOCAL_JEND (wrt_int_state%ID_FTASK_RECV_END(MYPE)) !<-- Ending J of lead write task's subsection -! - DO J=JSTA_WRITE,JEND_WRITE - DO I=1,IM - wrt_int_state%OUTPUT_ARRAY_I2D(I,J)=wrt_int_state%WRITE_SUBSET_I(I,J,NFIELD) !<-- Lead write task fills its part of full domain - ENDDO - ENDDO -! - IF(LAST_WRITE_TASK>LEAD_WRITE_TASK)THEN !<-- Recv output subsections if more than 1 write task - DO N=1,NWTPG-1 !<-- Loop through local IDs of all other write tasks - ! that send to the lead task -! - ID_SEND=N+LEAD_WRITE_TASK - CALL MPI_SEND(N & !<-- Send to other write tasks to keep their sends in line - ,1 & !<-- Number of words sent - ,MPI_INTEGER & !<-- Datatype - ,N & !<-- Send to each of the other write tasks - ,0 & !<-- An MPI tag - ,MPI_COMM_COMP & !<-- MPI communicator - ,IERR ) -! - ID_RECV=ID_SEND - CALL MPI_RECV(wrt_int_state%BUFF_INT & !<-- Recv string of subsection data from other write tasks - ,IM*JM & !<-- Maximum number of words sent - ,MPI_INTEGER & !<-- Datatype - ,N & !<-- Recv from this write task - ,N & !<-- An MPI tag - ,MPI_COMM_COMP & !<-- MPI communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - NN=0 - JSTA_WRITE=wrt_int_state%LOCAL_JSTART(wrt_int_state%ID_FTASK_RECV_STA(N+LEAD_WRITE_TASK)) !<-- Starting J of sending write task - JEND_WRITE=wrt_int_state%LOCAL_JEND (wrt_int_state%ID_FTASK_RECV_END(N+LEAD_WRITE_TASK)) !<-- Ending J of sending write task -! - DO J=JSTA_WRITE,JEND_WRITE - DO I=1,IM - NN=NN+1 - wrt_int_state%OUTPUT_ARRAY_I2D(I,J)=wrt_int_state%BUFF_INT(NN) !<-- Insert other write tasks' subsections into full domain - ENDDO - ENDDO -! - ENDDO - ENDIF -! - NPOSN_1=(NFIELD-1)*ESMF_MAXSTR+1 - NPOSN_2=NFIELD*ESMF_MAXSTR - NAME=wrt_int_state%NAMES_I2D_STRING(NPOSN_1:NPOSN_2) !<-- The name of this 2D integer history quantity -! - IF(wrt_int_state%WRITE_HST_BIN)THEN -! - WRITE(wrt_int_state%IO_HST_UNIT,iostat=RC)wrt_int_state%OUTPUT_ARRAY_I2D !<-- Lead write task writes out the 2D real data -! - IF(HST_FIRST .AND. (wrt_int_state%PRINT_OUTPUT .OR. wrt_int_state%PRINT_ALL) )THEN - WRITE(0,*)'Wrote ',TRIM(NAME),' to history file unit ',wrt_int_state%IO_HST_UNIT - ENDIF - ENDIF -! -!----------------------------------------------------------------------- -!*** For the NEMSIO history file. -!----------------------------------------------------------------------- -! - IF(wrt_int_state%WRITE_HST_NEMSIO)THEN -! - IF(FIELDSIZE/=IM*JM)THEN - WRITE(0,*)'WRONG: input data dimension ',IM*JM, & - ' does not match data size in NEMSIO file ',FIELDSIZE - ENDIF -! - TMP=RESHAPE(wrt_int_state%OUTPUT_ARRAY_I2D(1:IM,1:JM) & - ,(/FIELDSIZE/)) -! - CALL NEMSIO_WRITEREC(NEMSIOFILE,NFIELD,TMP,IRET=IERR) !<-- Lead write task writes out the 2D int data! - IF(IERR/=0)THEN - WRITE(0,*)' Failed to write output to file! Aborting!' - CALL ESMF_Finalize(rc=RC,endflag=ESMF_END_ABORT) - ENDIF -! - ENDIF -!----------------------------------------------------------------------- -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO field_loop_int -! -!----------------------------------------------------------------------- -!*** Now loop through all the real Fields. -!----------------------------------------------------------------------- -! - WRITE(MODEL_LEVEL,'(I3.3)')wrt_int_state%LM(1) -! -!----------------------------------------------------------------------- -! - field_loop_real: DO NFIELD=1,KOUNT_R2D !<-- Loop through all 2D real gridded history data -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- - IF(MYPE>LEAD_WRITE_TASK)THEN !<-- All write tasks except the lead one -!----------------------------------------------------------------------- -! - JSTA_WRITE=wrt_int_state%LOCAL_JSTART(wrt_int_state%ID_FTASK_RECV_STA(MYPE)) !<-- Starting J of this write task's subsection - JEND_WRITE=wrt_int_state%LOCAL_JEND (wrt_int_state%ID_FTASK_RECV_END(MYPE)) !<-- Ending J of this write task's subsection -! - NN=0 -! - DO J=JSTA_WRITE,JEND_WRITE - DO I=1,IM - NN=NN+1 - wrt_int_state%BUFF_REAL(NN)=wrt_int_state%WRITE_SUBSET_R(I,J,NFIELD) - ENDDO - ENDDO -! - CALL MPI_RECV(ID_DUMMY & !<-- Blocking Recv keeps the following sends in line - ,1 & !<-- Length of ID_DUMMY - ,MPI_INTEGER & !<-- Datatype - ,0 & !<-- The lead write task sent this - ,0 & !<-- An MPI tag - ,MPI_COMM_COMP & !<-- The communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - MY_LOCAL_ID=MYPE-LAST_FCST_TASK-1 !<-- This write task's local ID (between 0 and NWTPG-1) -! - CALL MPI_SEND(wrt_int_state%BUFF_REAL & !<-- Send this string of subsection data - ,NN & !<-- Number of words sent - ,MPI_REAL & !<-- Datatype - ,0 & !<-- Send the data to the lead write task with local ID of 0 - ,MY_LOCAL_ID & !<-- An MPI tag - ,MPI_COMM_COMP & !<-- MPI communicator - ,IERR ) -! -!----------------------------------------------------------------------- - ELSEIF(MYPE==LEAD_WRITE_TASK)THEN !<-- The lead write task -!----------------------------------------------------------------------- -! - JSTA_WRITE=wrt_int_state%LOCAL_JSTART(wrt_int_state%ID_FTASK_RECV_STA(MYPE)) !<-- Starting J of lead write task's subsection - JEND_WRITE=wrt_int_state%LOCAL_JEND (wrt_int_state%ID_FTASK_RECV_END(MYPE)) !<-- Ending J of lead write task's subsection -! - DO J=JSTA_WRITE,JEND_WRITE - DO I=1,IM - wrt_int_state%OUTPUT_ARRAY_R2D(I,J)=wrt_int_state%WRITE_SUBSET_R(I,J,NFIELD) !<-- Lead write task fills its part of full domain - ENDDO - ENDDO -! - IF(LAST_WRITE_TASK>LEAD_WRITE_TASK)THEN !<-- Recv output subsections if more than 1 write task - DO N=1,NWTPG-1 !<-- Loop through local IDs of all other write tasks - ! that send to the lead task -! - ID_SEND=N+LEAD_WRITE_TASK - CALL MPI_SEND(N & !<-- Send to other write tasks to keep their sends in line - ,1 & !<-- Number of words sent - ,MPI_INTEGER & !<-- Datatype - ,N & !<-- Send to each of the other write tasks - ,0 & !<-- An MPI tag - ,MPI_COMM_COMP & !<-- MPI communicator - ,IERR ) -! - ID_RECV=ID_SEND - CALL MPI_RECV(wrt_int_state%BUFF_REAL & !<-- Recv string of subsection data from other write tasks - ,IM*JM & !<-- Maximum number of words sent - ,MPI_REAL & !<-- Datatype - ,N & !<-- Recv from this write task - ,N & !<-- An MPI tag - ,MPI_COMM_COMP & !<-- MPI communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - NN=0 - JSTA_WRITE=wrt_int_state%LOCAL_JSTART(wrt_int_state%ID_FTASK_RECV_STA(N+LEAD_WRITE_TASK)) !<-- Starting J of sending write task - JEND_WRITE=wrt_int_state%LOCAL_JEND (wrt_int_state%ID_FTASK_RECV_END(N+LEAD_WRITE_TASK)) !<-- Ending J of sending write task -! - DO J=JSTA_WRITE,JEND_WRITE - DO I=1,IM - NN=NN+1 - wrt_int_state%OUTPUT_ARRAY_R2D(I,J)=wrt_int_state%BUFF_REAL(NN) !<-- Insert other write tasks' subsections into full domain - ENDDO - ENDDO -! - ENDDO - ENDIF -! - NPOSN_1=(NFIELD-1)*ESMF_MAXSTR+1 - NPOSN_2=NFIELD*ESMF_MAXSTR - NAME=wrt_int_state%NAMES_R2D_STRING(NPOSN_1:NPOSN_2) !<-- The name of this 2D real history quantity -! -!----------------------------------------------------------------------- -!*** Begin computation of the 10-m wind factor for GSI. -!----------------------------------------------------------------------- -! - IF(TRIM(NAME)=='U10') THEN - IF(.NOT.ALLOCATED(FACT10)) THEN - ALLOCATE(FACT10(1:IM,1:JM)) -! - DO J=1,JM - DO I=1,IM - FACT10(I,J)=0. - ENDDO - ENDDO - ENDIF -! - DO J=1,JM - DO I=1,IM - FACT10(I,J)=FACT10(I,J)+ & - wrt_int_state%OUTPUT_ARRAY_R2D(I,J)* & - wrt_int_state%OUTPUT_ARRAY_R2D(I,J) - ENDDO - ENDDO - ENDIF -! - IF(TRIM(NAME)=='V10') THEN - IF(.NOT.ALLOCATED(FACT10)) THEN - ALLOCATE(FACT10(1:IM,1:JM)) - FACT10=0. - ENDIF -! - DO J=1,JM - DO I=1,IM - FACT10(I,J)=FACT10(I,J)+ & - wrt_int_state%OUTPUT_ARRAY_R2D(I,J)* & - wrt_int_state%OUTPUT_ARRAY_R2D(I,J) - ENDDO - ENDDO - ENDIF -! - IF(TRIM(NAME)=='U_'//MODEL_LEVEL//'_2D') THEN - ALLOCATE(FACT10TMPU(1:IM,1:JM)) - CALL V_TO_H_BGRID(wrt_int_state%OUTPUT_ARRAY_R2D(1:IM,1:JM) & - ,IM,JM,GLOBAL,FACT10TMPU) - ENDIF -! - IF(TRIM(NAME)=='V_'//MODEL_LEVEL//'_2D') THEN - ALLOCATE(FACT10TMPV(1:IM,1:JM)) - CALL V_TO_H_BGRID(wrt_int_state%OUTPUT_ARRAY_R2D(1:IM,1:JM) & - ,IM,JM,GLOBAL,FACT10TMPV) - ENDIF -! - IF(wrt_int_state%WRITE_HST_BIN)THEN -! - WRITE(wrt_int_state%IO_HST_UNIT,iostat=RC)wrt_int_state%OUTPUT_ARRAY_R2D !<-- Lead write task writes out the 2D real data -! - IF(HST_FIRST .AND. (wrt_int_state%PRINT_OUTPUT .OR. wrt_int_state%PRINT_ALL) )THEN - WRITE(0,*)'Wrote ',TRIM(NAME) & - ,' to history file unit ',wrt_int_state%IO_HST_UNIT & - ,MAXVAL(wrt_int_state%OUTPUT_ARRAY_R2D) & - ,MINVAL(wrt_int_state%OUTPUT_ARRAY_R2D) - ENDIF - ENDIF -! -!----------------------------------------------------------------------- -!*** The same for the NEMSIO history file. -!----------------------------------------------------------------------- -! - IF(wrt_int_state%WRITE_HST_NEMSIO)THEN -! - IF(FIELDSIZE/=IM*JM)THEN - WRITE(0,*)'WRONG: data dimension ',IM*JM, & - ' does not match data size in NEMSIO file,',FIELDSIZE - ENDIF -! - IF(TRIM(NAME)=='FIS')wrt_int_state%OUTPUT_ARRAY_R2D(1:IM,1:JM)= & - wrt_int_state%OUTPUT_ARRAY_R2D(1:IM,1:JM)/G -! - IF(TRIM(NAME)=='GLAT')THEN - ALLOCATE(GLAT1D(FIELDSIZE)) - GLAT1D(1:FIELDSIZE)=RESHAPE(wrt_int_state%OUTPUT_ARRAY_R2D(1:IM,1:JM),(/FIELDSIZE/)) - ENDIF -! - IF(TRIM(NAME)=='GLON')THEN - ALLOCATE(GLON1D(FIELDSIZE)) - GLON1D(1:FIELDSIZE)=RESHAPE(wrt_int_state%OUTPUT_ARRAY_R2D(1:IM,1:JM),(/FIELDSIZE/)) - ENDIF -! - N=NFIELD+wrt_int_state%KOUNT_I2D(1) - TMP=RESHAPE(wrt_int_state%OUTPUT_ARRAY_R2D(1:IM,1:JM),(/FIELDSIZE/)) -! - CALL NEMSIO_WRITEREC(NEMSIOFILE,N,TMP,IRET=IERR) - IF(IERR/=0)THEN - WRITE(0,*)' Failed to write output to file! Aborting!' - CALL ESMF_Finalize(rc=RC,endflag=ESMF_END_ABORT) - ENDIF -! -! IF(HST_FIRST)THEN -! WRITE(0,*)'Wrote ',TRIM(NAME),' to nemsio history file iret=',ierr -! ENDIF -! - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO field_loop_real -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Complete computation of 10-m wind factor and write it out. -!----------------------------------------------------------------------- -! - IF( MYPE==LEAD_WRITE_TASK )THEN - IF(ALLOCATED(FACT10).AND.ALLOCATED(FACT10TMPU).AND.ALLOCATED(FACT10TMPV)) THEN - DO J=1,JM - DO I=1,IM - FACT10TMPV(I,J)=SQRT(FACT10TMPU(I,J)*FACT10TMPU(I,J)+ & - FACT10TMPV(I,J)*FACT10TMPV(I,J)) - ENDDO - ENDDO -! -! write(0,*)'wind mgn=',maxval(FACT10TMPV(1:IM,1:JM)),minval(FACT10TMPV(1:IM,1:JM)) -! write(0,*)'wind10 mgn=',maxval(sqrt(FACT10(1:IM,1:JM))),minval(sqrt(FACT10(1:IM,1:JM))) -! - DO J=1,JM - DO I=1,IM - IF(FACT10TMPV(I,J)/=0) THEN - FACT10(I,J)=SQRT(FACT10(I,J))/FACT10TMPV(I,J) - ELSE - FACT10(I,J)=1. - ENDIF - ENDDO - ENDDO -! - DEALLOCATE(FACT10TMPU) - DEALLOCATE(FACT10TMPV) -! - IF(wrt_int_state%WRITE_HST_BIN)THEN - WRITE(wrt_int_state%IO_HST_UNIT,iostat=RC)FACT10 !<-- Lead write task writes out the 2D real data - IF(HST_FIRST .AND. (wrt_int_state%PRINT_OUTPUT .OR. wrt_int_state%PRINT_ALL) )THEN - WRITE(0,*)'Wrote FACT10 to history file unit ',wrt_int_state%IO_HST_UNIT & - ,maxval(fact10),minval(fact10) - ENDIF - ENDIF -! - IF(wrt_int_state%WRITE_HST_NEMSIO)THEN - N=N+1 - TMP=RESHAPE(FACT10(1:IM,1:JM),(/FIELDSIZE/)) - CALL NEMSIO_WRITEREC(NEMSIOFILE,N,TMP,IRET=IERR) - IF(IERR/=0)THEN - WRITE(0,*)' Failed to write output to file! Aborting!' - CALL ESMF_Finalize(rc=RC,endflag=ESMF_END_ABORT) - ENDIF -! write(0,*)'after nemsio_writerec,n=',n,'fact10=',maxval(tmp),minval(tmp),'iret=',ierr - ENDIF -! - DEALLOCATE(FACT10) -! - ENDIF -! - ENDIF -! - HST_FIRST=.FALSE. -! -!----------------------------------------------------------------------- -!*** Close the history file if needed. -!----------------------------------------------------------------------- -! - IF(wrt_int_state%WRITE_HST_BIN.and.MYPE==LEAD_WRITE_TASK)THEN - CLOSE(wrt_int_state%IO_HST_UNIT) -! write(0,*)' Closed history file with unit=',wrt_int_state%IO_HST_UNIT - ENDIF -! -!----------------------------------------------------------------------- -!*** Close the NEMSIO history file. -!----------------------------------------------------------------------- -! - IF(wrt_int_state%WRITE_HST_NEMSIO.AND.wrt_int_state%MYPE==LEAD_WRITE_TASK)THEN -! - IF(ASSOCIATED(GLAT1D).AND.ASSOCIATED(GLON1D)) THEN - CALL NEMSIO_SETFILEHEAD(NEMSIOFILE,IERR,GLAT1D,GLON1D) - DEALLOCATE(GLAT1D,GLON1D) - ENDIF -! - CALL NEMSIO_GETFILEHEAD(NEMSIOFILE,IERR,gfname=GFNAME) -! - DEALLOCATE(TMP) -! - CALL NEMSIO_CLOSE(NEMSIOFILE) -! WRITE(0,*)' Closed nemsio_history file, ', gfname -! - CALL NEMSIO_FINALIZE() -! -! ffsync - IF(WRT_INT_STATE%WRITE_FSYNCFLAG) THEN - DO N=51,99 - INQUIRE(N,opened=OPENED) - IF(.NOT.OPENED)THEN - IO_HST_UNIT=N - EXIT - ENDIF - ENDDO -! - OPEN(unit=IO_HST_UNIT, file=trim(GFNAME) ) -! - RC=FFSYNC(IO_HST_UNIT) - -! Handle possible error - IF (RC.NE.0) THEN - print *,"Error returned from ffsync, file=", & - & trim(GFNAME),"rc=",RC - ENDIF -! - CLOSE(IO_HST_UNIT) -! - ENDIF -! -!ffsync end -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Get this domain's configure object. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Config Object for Write Setup" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGet(gridcomp=WRITE_COMP & !<-- The Write component - ,config =CF & !<-- The configure object on this domain - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!------------------- -!*** Fcstdone file -!------------------- -! - IF(wrt_int_state%WRITE_DONEFILEFLAG & - .AND. & - wrt_int_state%MYPE==LEAD_WRITE_TASK & - .AND. & - (wrt_int_state%WRITE_HST_BIN & - .OR. & - wrt_int_state%WRITE_HST_NEMSIO))THEN -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =ID_DOMAIN & !<-- Put extracted quantity here - ,label ='my_domain_id:' & !<-- The quantity's label in the configure file - ,rc =RC) -! - INT_SEC=INT(NF_SECONDS) - FRAC_SEC=NINT((NF_SECONDS-INT_SEC)*100.) -! - WRITE(FILENAME,'(A,I2.2,A,I4.4,A,I2.2,A,I2.2,A,I2.2,A)' ) & - 'fcstdone.',ID_DOMAIN,'.' & !<-- Insert the domain ID for nests - ,NF_HOURS,'h_' & - ,NF_MINUTES,'m_' & - ,INT_SEC,'.',FRAC_SEC,'s' -! - DO N=51,99 - INQUIRE(N,opened=OPENED) - IF(.NOT.OPENED)THEN - IO_HST_UNIT=N - EXIT - ENDIF - ENDDO -! - OPEN(unit =IO_HST_UNIT & - ,file =trim(FILENAME) & - ,form ='formatted' & - ,status='REPLACE') -! - WRITE(IO_HST_UNIT,'(A4)')'DONE' - CLOSE(IO_HST_UNIT) -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF history_time -! -!----------------------------------------------------------------------- -! - restart_time: IF(TIME_FOR_RESTART) THEN -! -!----------------------------------------------------------------------- -!*** The lead Write task receives the latest Attributes from the -!*** lead fcst task for restart output. -!----------------------------------------------------------------------- -! - IF(MYPE==LEAD_WRITE_TASK)THEN -! - WRITE_GROUP=NCURRENT_GROUP(ID_DOMAIN) -! -!-------------- -!*** Integers -!-------------- -! - IF(wrt_int_state%RST_LENGTH_SUM_I1D(1)>0)THEN -! - CALL MPI_RECV(wrt_int_state%RST_ALL_DATA_I1D & !<-- Recv string of integer restart Attributes - ,wrt_int_state%RST_LENGTH_SUM_I1D(1) & !<-- Words received - ,MPI_INTEGER & !<-- Data is integer - ,0 & !<-- Sending task (lead fcst task) - ,WRITE_GROUP & !<-- MPI tag - ,INTERCOMM_WRITE_GROUP & !<-- MPI domain commumicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! write(0,*)' Write Run lead write task recvd RST_ALL_DATA_I1D with length=',wrt_int_state%RST_LENGTH_SUM_I1D(1) -! write(0,*)' NMTS=wrt_int_state%RST_ALL_DATA_I1D(10)=',wrt_int_state%RST_ALL_DATA_I1D(10) -! - ENDIF -! -!----------- -!*** Reals -!----------- -! - IF(wrt_int_state%RST_LENGTH_SUM_R1D(1)>0)THEN -! - CALL MPI_RECV(wrt_int_state%RST_ALL_DATA_R1D & !<-- Recv string of real restart Attributes - ,wrt_int_state%RST_LENGTH_SUM_R1D(1) & !<-- Words received - ,MPI_REAL & !<-- Data is real - ,0 & !<-- Sending task (lead fcst task) - ,WRITE_GROUP & !<-- MPI tag - ,INTERCOMM_WRITE_GROUP & !<-- MPI domain commumicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - ENDIF -! -!-------------- -!*** Logicals -!-------------- -! - IF(wrt_int_state%RST_LENGTH_SUM_LOG(1)>0)THEN -! - CALL MPI_RECV(wrt_int_state%RST_ALL_DATA_LOG & !<-- Recv string of logical restart Attributes - ,wrt_int_state%RST_LENGTH_SUM_LOG(1) & !<-- Words received - ,MPI_LOGICAL & !<-- Data is logical - ,0 & !<-- Sending task (lead fcst task) - ,WRITE_GROUP & !<-- MPI tag - ,INTERCOMM_WRITE_GROUP & !<-- MPI domain commumicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Each Write task in the active Write group receives the -!*** strings of 2D restart data from the appropriate fcst tasks. -!----------------------------------------------------------------------- -! - ID_START=wrt_int_state%ID_FTASK_RECV_STA(MYPE) !<-- First fcst task that sends to this write task - ID_END =wrt_int_state%ID_FTASK_RECV_END(MYPE) !<-- Last fcst task that sends to this write task - NFCST_TASKS=ID_END-ID_START+1 !<-- Number of fcst tasks sending to this write task -! -!----------------------------------------------------------------------- - rst_from_fcst_tasks: DO N=1,NFCST_TASKS !<-- Loop through fcst tasks sending to this write task -!----------------------------------------------------------------------- -! - ID_RECV=ID_START+N-1 -! -!----------------------------------------------------------------------- -!*** Receive 2-D integer data if there is any. -!----------------------------------------------------------------------- -! - IF(RST_KOUNT_I2D>0)THEN - CALL MPI_RECV(wrt_int_state%RST_ALL_DATA_I2D & !<-- Fcst tasks' string of 2D integer restart data - ,wrt_int_state%NUM_WORDS_RECV_I2D_RST(ID_RECV) & !<-- # of words in the data string - ,MPI_INTEGER & !<-- The datatype - ,ID_RECV & !<-- Recv from this fcst task - ,wrt_int_state%NFHOURS & !<-- An MPI tag - ,INTERCOMM_WRITE_GROUP & !<-- The MPI intercommunicator between fcst and quilt tasks - ,JSTAT & !<-- MPI status object - ,IERR ) -! - IF(IERR/=0)WRITE(0,*)' Recv by write task from fcst task has failed. IERR=',IERR - ENDIF -! -!----------------------------------------------------------------------- -!*** Receive 2-D real data if there is any. -!----------------------------------------------------------------------- -! - IF(RST_KOUNT_R2D>0)THEN - CALL MPI_RECV(wrt_int_state%RST_ALL_DATA_R2D & !<-- Fcst tasks' string of 2D real restart data - ,wrt_int_state%NUM_WORDS_RECV_R2D_RST(ID_RECV) & !<-- # of words in the data string - ,MPI_REAL & !<-- The datatype - ,ID_RECV & !<-- Recv from this fcst task - ,wrt_int_state%NFHOURS & !<-- An MPI tag - ,INTERCOMM_WRITE_GROUP & !<-- The MPI intercommunicator between fcst and quilt tasks - ,JSTAT & !<-- MPI status object - ,IERR ) -! - IF(IERR/=0)WRITE(0,*)' Recv by write task from fcst task has failed. IERR=',IERR - ENDIF -! -!----------------------------------------------------------------------- -!*** Each Write task needs to insert the pieces of the various -!*** 2D restart arrays received from the individual fcst tasks -!*** into arrays that span the Write tasks' own subsection of -!*** the full 2D domain. That subsection always spans the -!*** entire East-West dimension of the full domain (since full -!*** rows of Fcst tasks always send to Write tasks, never -!*** partial rows) and as much of the North-South dimension of -!*** the full domain as covered by those Fcst tasks sending to -!*** a given Write task. -!----------------------------------------------------------------------- -! - ITS=wrt_int_state%LOCAL_ISTART(ID_RECV) !<-- Local domain integration limits of sending fcst task - ITE=wrt_int_state%LOCAL_IEND(ID_RECV) !<-- - JTS=wrt_int_state%LOCAL_JSTART(ID_RECV) !<-- - JTE=wrt_int_state%LOCAL_JEND(ID_RECV) !<-- -! - IHALO=wrt_int_state%IHALO !<-- Subdomain halo depth in I - JHALO=wrt_int_state%JHALO !<-- Subdomain halo depth in J -! - IMS=ITS-IHALO - IME=ITE+IHALO - JMS=JTS-JHALO - JME=JTE+JHALO -! - NN=0 -! - DO NF=1,RST_KOUNT_I2D !<-- Loop through all the 2D integer fields -! - DO J=JMS,JME - DO I=IMS,IME - NN=NN+1 - IF(IITE.OR.JJTE)CYCLE !<-- Exclude halo points - wrt_int_state%RST_WRITE_SUBSET_I(I,J,NF)=wrt_int_state%RST_ALL_DATA_I2D(NN) !<-- Put data into write task's domain subsection - ENDDO - ENDDO - ENDDO -! - NN=0 -! - DO NF=1,RST_KOUNT_R2D !<-- Loop through all the 2D real fields -! - DO J=JMS,JME - DO I=IMS,IME - NN=NN+1 - IF(IITE.OR.JJTE)CYCLE !<-- Exclude halo points - wrt_int_state%RST_WRITE_SUBSET_R(I,J,NF)=wrt_int_state%RST_ALL_DATA_R2D(NN) !<-- Put data into write task's domain subsection - ENDDO - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -! - ENDDO rst_from_fcst_tasks -! -!----------------------------------------------------------------------- -!*** The lead Write task must receive the full-domain boundary -!*** data from the lead Forecast task. The data is required in -!*** the restart files when nests are present. -!----------------------------------------------------------------------- -! - insert_bc_data: IF(MYPE==LEAD_WRITE_TASK)THEN !<-- The lead write task -! - CALL MPI_RECV(wrt_int_state%RST_ALL_BC_DATA & !<-- 1-D string of BC data for restart - ,wrt_int_state%NUM_WORDS_SEND_BC(1) & !<-- # of words in the data string - ,MPI_REAL & !<-- The datatype - ,0 & !<-- Recv from this fcst task - ,wrt_int_state%NFHOURS & !<-- An MPI tag - ,INTERCOMM_WRITE_GROUP & !<-- The MPI intercommunicator between fcst and quilt tasks - ,JSTAT & !<-- MPI status object - ,IERR ) -! - IF(IERR/=0)WRITE(0,*)' Recv by write task of fcst task BC data has failed. IERR=',IERR -! -!----------------------------------------------------------------------- -!*** Add the BC data, word count, and name into the appropriate arrays. -!----------------------------------------------------------------------- -! - once: IF(NSUM_WORDS_NEW==0)THEN !<-- Increase size of RST_ALL_DATA_R1D only once - NSUM_WORDS=0 - DO NX=1,wrt_int_state%RST_KOUNT_R1D(1) !<-- Loop through all 1-D Real items in string - NSUM_WORDS=NSUM_WORDS+wrt_int_state%RST_LENGTH_DATA_R1D(NX) !<-- # of words so far in 1-D real data string - ENDDO -! - ALLOCATE(HOLD_RST_DATA_R1D(1:NSUM_WORDS)) - DO NX=1,NSUM_WORDS - HOLD_RST_DATA_R1D(NX)=wrt_int_state%RST_ALL_DATA_R1D(NX) !<-- Save those words temporarily - ENDDO -! - NSUM_WORDS_NEW=NSUM_WORDS+wrt_int_state%NUM_WORDS_SEND_BC(1) !<-- # of 1-D real words including the BC data - DEALLOCATE(wrt_int_state%RST_ALL_DATA_R1D) - ALLOCATE(wrt_int_state%RST_ALL_DATA_R1D(1:NSUM_WORDS_NEW) & !<-- Reallocate the 1-D real storage to new length - ,stat=ISTAT) !<-- -! - DO NX=1,NSUM_WORDS - wrt_int_state%RST_ALL_DATA_R1D(NX)=HOLD_RST_DATA_R1D(NX) !<-- Transfer the original data back - ENDDO -! - wrt_int_state%RST_KOUNT_R1D(1)=wrt_int_state%RST_KOUNT_R1D(1)+1 !<-- Increment the 1-D real item count by 1 -! - wrt_int_state%RST_LENGTH_DATA_R1D(wrt_int_state%RST_KOUNT_R1D)= & !<-- Insert the BC data's word count - wrt_int_state%NUM_WORDS_SEND_BC(1) -! - NPOSN_2=wrt_int_state%RST_KOUNT_R1D(1)*ESMF_MAXSTR - NPOSN_1=NPOSN_2-ESMF_MAXSTR+1 - wrt_int_state%RST_NAMES_R1D_STRING(NPOSN_1:NPOSN_2)='ALL_BC_DATA' !<-- Insert the data's name -! - ENDIF once -! - KOUNT=0 - DO NX=NSUM_WORDS+1,NSUM_WORDS_NEW - KOUNT=KOUNT+1 - wrt_int_state%RST_ALL_DATA_R1D(NX)=wrt_int_state%RST_ALL_BC_DATA(KOUNT) !<-- Insert the new BC data - ENDDO -! - ENDIF insert_bc_data -! -!----------------------------------------------------------------------- -!*** At this point, all Write tasks have received all of the restart -!*** data from their associated Fcst tasks and assembled it onto -!*** their own subsections of the full 2D domain. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** The lead Write task obtains the current and elapsed forecast -!*** times for its writing of the restart output. -!----------------------------------------------------------------------- -! - rst_write_begin: IF(MYPE==LEAD_WRITE_TASK)THEN !<-- The lead write task -! -!----------------------------------------------------------------------- -! - IF(wrt_int_state%WRITE_RST_BIN.OR. & - wrt_int_state%WRITE_RST_NEMSIO)THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Lead Write Task Gets Current ESMF Time from Clock" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock =CLOCK & !<-- The ESMF Clock - ,currTime =CURRTIME & !<-- The current time (ESMF) on the clock - ,runTimeStepCount=RUN_TIMESTEP_COUNT & !<-- # of times the clock has advanced - ,rc =RC) -! - NTIMESTEP=NINT(RUN_TIMESTEP_COUNT)-1 -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** The current forecast time. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Lead Write Task Gets Actual Current Time from Clock" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeGet(time=CURRTIME & !<-- The cuurent forecast time (ESMF) - ,yy =IYEAR_FCST & !<-- The current forecast year (integer) - ,mm =IMONTH_FCST & !<-- The current forecast month (integer) - ,dd =IDAY_FCST & !<-- The current forecast day (integer) - ,h =IHOUR_FCST & !<-- The current forecast hour (integer) - ,m =IMINUTE_FCST & !<-- The current forecast minute (integer) - ,s =ISECOND_FCST & !<-- The current forecast second (integer) - ,sN =ISECOND_NUM & !<-- Numerator of current fractional second (integer) - ,sD =ISECOND_DEN & !<-- Denominator of current fractional second (integer) - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - SECOND_FCST=ISECOND_FCST+REAL(ISECOND_NUM)/REAL(ISECOND_DEN) !<-- Current forecast seconds (real) -! -!----------------------------------------------------------------------- -!*** Elapsed forecast time. -!----------------------------------------------------------------------- -! - wrt_int_state%IO_CURRTIMEDIFF=CURRTIME-wrt_int_state%IO_BASETIME -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Lead Write Task Gets Actual Elapsed Fcst Time" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeIntervalGet(timeinterval=wrt_int_state%IO_CURRTIMEDIFF & - ,h =NF_HOURS & !<-- Hours of elapsed time - ,m =NF_MINUTES & !<-- Minutes of elapsed time - ,s =NSECONDS & !<-- Seconds of elapsed time - ,sN =NSECONDS_NUM & !<-- Numerator of fractional elapsed seconds - ,sD =NSECONDS_DEN & !<-- denominator of fractional elapsed seconds - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_RUN) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NF_SECONDS=NSECONDS+REAL(NSECONDS_NUM)/REAL(NSECONDS_DEN) -! - wrt_int_state%NFHOURS =NF_HOURS - wrt_int_state%NFMINUTES=NF_MINUTES - wrt_int_state%NFSECONDS=NF_SECONDS -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF rst_write_begin -! -!----------------------------------------------------------------------- -!*** The lead Write task opens the restart file(s) and writes out -!*** scalar/1D quantities. -!----------------------------------------------------------------------- -! - IF(MYPE==LEAD_WRITE_TASK)THEN -! - IF(wrt_int_state%WRITE_RST_BIN)THEN -! - CALL WRITE_RUNRESTART_OPEN(WRT_INT_STATE & - ,IYEAR_FCST & - ,IMONTH_FCST & - ,IDAY_FCST & - ,IHOUR_FCST & - ,IMINUTE_FCST & - ,SECOND_FCST & - ,NTIMESTEP & - ,NF_HOURS & - ,NF_MINUTES & - ,NF_SECONDS & - ,RST_FIRST & - ,LEAD_WRITE_TASK) - ENDIF -! - IF(wrt_int_state%WRITE_RST_NEMSIO)THEN -! - CALL WRITE_NEMSIO_RUNRESTART_OPEN(WRT_INT_STATE & - ,NEMSIOFILE & - ,IYEAR_FCST & - ,IMONTH_FCST & - ,IDAY_FCST & - ,IHOUR_FCST & - ,IMINUTE_FCST & - ,SECOND_FCST & - ,NTIMESTEP & - ,NF_HOURS & - ,NF_MINUTES & - ,NF_SECONDS & - ,DIM1,DIM2,NBDR,GLOBAL & - ,ID_DOMAIN & - ,LEAD_WRITE_TASK) -! - FIELDSIZE=(DIM1+2*NBDR)*(DIM2+2*NBDR) - ALLOCATE(TMP(FIELDSIZE)) - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** We will now assemble the full domain 2-D restart data onto -!*** the lead Write task from the subsections on all Write tasks -!*** then the lead task will write each 2D Field to the restart -!*** file(s). -! -!*** NOTE: The lead Write task assembles and writes to restart only -!*** one 2-D Field at a time. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** First loop through all of the integer Fields. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! - rst_field_loop_int: DO NFIELD=1,RST_KOUNT_I2D !<-- Loop through all 2D integer gridded restart data -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- - IF(MYPE>LEAD_WRITE_TASK)THEN !<-- All write tasks except the lead one -!----------------------------------------------------------------------- -! - JSTA_WRITE=wrt_int_state%LOCAL_JSTART(wrt_int_state%ID_FTASK_RECV_STA(MYPE)) !<-- Starting J of this write task's subsection - JEND_WRITE=wrt_int_state%LOCAL_JEND (wrt_int_state%ID_FTASK_RECV_END(MYPE)) !<-- Ending J of this write task's subsection -! - NN=0 -! - DO J=JSTA_WRITE,JEND_WRITE - DO I=1,IM - NN=NN+1 - wrt_int_state%RST_BUFF_INT(NN)=wrt_int_state%RST_WRITE_SUBSET_I(I,J,NFIELD) - ENDDO - ENDDO -! - CALL MPI_RECV(ID_DUMMY & !<-- Blocking Recv keeps the following sends in line - ,1 & !<-- Length of ID_DUMMY - ,MPI_INTEGER & !<-- Datatype - ,0 & !<-- The lead write task sent this - ,0 & !<-- An MPI tag - ,MPI_COMM_COMP & !<-- The communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - MY_LOCAL_ID=MYPE-LAST_FCST_TASK-1 !<-- This write task's local ID (between 0 and NWTPG-1) -! - CALL MPI_SEND(wrt_int_state%RST_BUFF_INT & !<-- Send this string of subsection data - ,NN & !<-- Number of words sent - ,MPI_INTEGER & !<-- Datatype - ,0 & !<-- Send the data to the lead write task with local ID of 0 - ,MY_LOCAL_ID & !<-- An MPI tag - ,MPI_COMM_COMP & !<-- MPI communicator - ,IERR ) -! -!----------------------------------------------------------------------- - ELSEIF(MYPE==LEAD_WRITE_TASK)THEN !<-- The lead write task -!----------------------------------------------------------------------- -! -! write(0,*)'RST lead_write_task, send and recv,LAST_WRITE_TASK=', & -! 'LEAD_WRITE_TASK=',LEAD_WRITE_TASK -! - JSTA_WRITE=wrt_int_state%LOCAL_JSTART(wrt_int_state%ID_FTASK_RECV_STA(MYPE)) !<-- Starting J of lead write task's subsection - JEND_WRITE=wrt_int_state%LOCAL_JEND (wrt_int_state%ID_FTASK_RECV_END(MYPE)) !<-- Ending J of lead write task's subsection -! - DO J=JSTA_WRITE,JEND_WRITE - DO I=1,IM - wrt_int_state%RST_OUTPUT_ARRAY_I2D(I,J)=wrt_int_state%RST_WRITE_SUBSET_I(I,J,NFIELD) !<-- Lead write task fills its part - ! of full domain - ENDDO - ENDDO -! - IF(LAST_WRITE_TASK>LEAD_WRITE_TASK)THEN !<-- Recv output subsections if more than 1 write task - DO N=1,NWTPG-1 !<-- Loop through local IDs of all other write tasks - ! that send to the lead task -! - CALL MPI_SEND(N & !<-- Send to other write tasks to keep their sends in line - ,1 & !<-- Number of words sent - ,MPI_INTEGER & !<-- Datatype - ,N & !<-- Send to each of the other write tasks - ,0 & !<-- An MPI tag - ,MPI_COMM_COMP & !<-- MPI communicator - ,IERR ) -! - CALL MPI_RECV(wrt_int_state%RST_BUFF_INT & !<-- Recv string of subsection data from other write tasks - ,IM*JM & !<-- Maximum number of words sent - ,MPI_INTEGER & !<-- Datatype - ,N & !<-- Recv from this write task - ,N & !<-- An MPI tag - ,MPI_COMM_COMP & !<-- MPI communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - NN=0 - JSTA_WRITE=wrt_int_state%LOCAL_JSTART(wrt_int_state%ID_FTASK_RECV_STA(N+LEAD_WRITE_TASK)) !<-- Starting J of sending write task - JEND_WRITE=wrt_int_state%LOCAL_JEND (wrt_int_state%ID_FTASK_RECV_END(N+LEAD_WRITE_TASK)) !<-- Ending J of sending write task -! - DO J=JSTA_WRITE,JEND_WRITE - DO I=1,IM - NN=NN+1 - wrt_int_state%RST_OUTPUT_ARRAY_I2D(I,J)=wrt_int_state%RST_BUFF_INT(NN) !<-- Insert other write tasks' subsections - ! into full domain - ENDDO - ENDDO -! - ENDDO - ENDIF -! - NPOSN_1=(NFIELD-1)*ESMF_MAXSTR+1 - NPOSN_2=NFIELD*ESMF_MAXSTR - NAME=wrt_int_state%RST_NAMES_I2D_STRING(NPOSN_1:NPOSN_2) !<-- The name of this 2D integer restart quantity -! - IF(wrt_int_state%WRITE_RST_BIN)THEN -! - WRITE(wrt_int_state%IO_RST_UNIT,iostat=RC)wrt_int_state%RST_OUTPUT_ARRAY_I2D !<-- Lead write task writes out the 2D integer data -! - IF(RST_FIRST .AND. (wrt_int_state%PRINT_OUTPUT .OR. wrt_int_state%PRINT_ALL) )THEN - WRITE(0,*)'Wrote ',TRIM(NAME),' to restart file unit ',wrt_int_state%IO_RST_UNIT, & - maxval(wrt_int_state%RST_OUTPUT_ARRAY_I2D),minval(wrt_int_state%RST_OUTPUT_ARRAY_I2D) - ENDIF - ENDIF -! -!----------------------------------------------------------------------- -!*** For the NEMSIO restart file -!----------------------------------------------------------------------- -! - IF(wrt_int_state%WRITE_RST_NEMSIO)THEN -! - IF(FIELDSIZE/=IM*JM)THEN - WRITE(0,*)'WRONG: input data dimension ',IM*JM, & - ' does not match data size in NEMSIO file ',FIELDSIZE - ENDIF - TMP=RESHAPE(wrt_int_state%RST_OUTPUT_ARRAY_I2D(1:IM,1:JM),(/FIELDSIZE/)) -! - CALL NEMSIO_WRITEREC(NEMSIOFILE,NFIELD,TMP,IRET=IERR) !<-- Lead write task writes out the 2D int data! - IF(IERR/=0)THEN - WRITE(0,*)' Failed to write output to file! Aborting!' - CALL ESMF_Finalize(rc=RC,endflag=ESMF_END_ABORT) - ENDIF -! - ENDIF -!----------------------------------------------------------------------- -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO rst_field_loop_int -! -!----------------------------------------------------------------------- -!*** Now loop through all the real Fields. -!----------------------------------------------------------------------- -! - WRITE(MODEL_LEVEL,'(I3.3)')wrt_int_state%LM(1) -! -!----------------------------------------------------------------------- -! - rst_field_loop_real: DO NFIELD=1,wrt_int_state%RST_KOUNT_R2D(1) !<-- Loop through all 2D real gridded restart data -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- - IF(MYPE>LEAD_WRITE_TASK)THEN !<-- All write tasks except the lead one -!----------------------------------------------------------------------- -! - JSTA_WRITE=wrt_int_state%LOCAL_JSTART(wrt_int_state%ID_FTASK_RECV_STA(MYPE)) !<-- Starting J of this write task's subsection - JEND_WRITE=wrt_int_state%LOCAL_JEND (wrt_int_state%ID_FTASK_RECV_END(MYPE)) !<-- Ending J of this write task's subsection -! - NN=0 -! - DO J=JSTA_WRITE,JEND_WRITE - DO I=1,IM - NN=NN+1 - wrt_int_state%RST_BUFF_REAL(NN)=wrt_int_state%RST_WRITE_SUBSET_R(I,J,NFIELD) - ENDDO - ENDDO -! - CALL MPI_RECV(ID_DUMMY & !<-- Blocking Recv keeps the following sends in line - ,1 & !<-- Length of ID_DUMMY - ,MPI_INTEGER & !<-- Datatype - ,0 & !<-- The lead write task sent this - ,0 & !<-- An MPI tag - ,MPI_COMM_COMP & !<-- The communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - MY_LOCAL_ID=MYPE-LAST_FCST_TASK-1 !<-- This write task's local ID (between 0 and NWTPG-1) -! - CALL MPI_SEND(wrt_int_state%RST_BUFF_REAL & !<-- Send this string of subsection data - ,NN & !<-- Number of words sent - ,MPI_REAL & !<-- Datatype - ,0 & !<-- Send the data to the lead write task with local ID of 0 - ,MY_LOCAL_ID & !<-- An MPI tag - ,MPI_COMM_COMP & !<-- MPI communicator - ,IERR ) -! -!----------------------------------------------------------------------- - ELSEIF(MYPE==LEAD_WRITE_TASK)THEN !<-- The lead write task -!----------------------------------------------------------------------- -! - JSTA_WRITE=wrt_int_state%LOCAL_JSTART(wrt_int_state%ID_FTASK_RECV_STA(MYPE)) !<-- Starting J of lead write task's subsection - JEND_WRITE=wrt_int_state%LOCAL_JEND (wrt_int_state%ID_FTASK_RECV_END(MYPE)) !<-- Ending J of lead write task's subsection -! - DO J=JSTA_WRITE,JEND_WRITE - DO I=1,IM - wrt_int_state%RST_OUTPUT_ARRAY_R2D(I,J)=wrt_int_state%RST_WRITE_SUBSET_R(I,J,NFIELD) !<-- Lead write task fills its part - ! of full domain - ENDDO - ENDDO -! - IF(LAST_WRITE_TASK>LEAD_WRITE_TASK)THEN !<-- Recv output subsections if more than 1 write task - DO N=1,NWTPG-1 !<-- Loop through local IDs of all other write tasks - ! that send to the lead task -! - CALL MPI_SEND(N & !<-- Send to other write tasks to keep their sends in line - ,1 & !<-- Number of words sent - ,MPI_INTEGER & !<-- Datatype - ,N & !<-- Send to each of the other write tasks - ,0 & !<-- An MPI tag - ,MPI_COMM_COMP & !<-- MPI communicator - ,IERR ) -! - CALL MPI_RECV(wrt_int_state%RST_BUFF_REAL & !<-- Recv string of subsection data from other write tasks - ,IM*JM & !<-- Maximum number of words sent - ,MPI_REAL & !<-- Datatype - ,N & !<-- Recv from this write task - ,N & !<-- An MPI tag - ,MPI_COMM_COMP & !<-- MPI communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - NN=0 - JSTA_WRITE=wrt_int_state%LOCAL_JSTART(wrt_int_state%ID_FTASK_RECV_STA(N+LEAD_WRITE_TASK)) !<-- Starting J of sending write task - JEND_WRITE=wrt_int_state%LOCAL_JEND (wrt_int_state%ID_FTASK_RECV_END(N+LEAD_WRITE_TASK)) !<-- Ending J of sending write task -! - DO J=JSTA_WRITE,JEND_WRITE - DO I=1,IM - NN=NN+1 - wrt_int_state%RST_OUTPUT_ARRAY_R2D(I,J)=wrt_int_state%RST_BUFF_REAL(NN) !<-- Insert other write tasks' subsections - ! into full domain - ENDDO - ENDDO -! - ENDDO - ENDIF -! -! - NPOSN_1=(NFIELD-1)*ESMF_MAXSTR+1 - NPOSN_2=NFIELD*ESMF_MAXSTR - NAME=wrt_int_state%RST_NAMES_R2D_STRING(NPOSN_1:NPOSN_2) !<-- The name of this 2D real restart quantity -! -!----------------------------------------------------------------------- -!*** Begin computation of the 10-m wind factor for GSI. -!----------------------------------------------------------------------- -! - IF(TRIM(NAME)=='U10') THEN - IF(.NOT.ALLOCATED(FACT10)) THEN - ALLOCATE(FACT10(1:IM,1:JM)) -! - DO J=1,JM - DO I=1,IM - FACT10(I,J)=0. - ENDDO - ENDDO - ENDIF -! - DO J=1,JM - DO I=1,IM - FACT10(I,J)=FACT10(I,J)+ & - wrt_int_state%RST_OUTPUT_ARRAY_R2D(I,J)* & - wrt_int_state%RST_OUTPUT_ARRAY_R2D(I,J) - ENDDO - ENDDO - ENDIF -! - IF(TRIM(NAME)=='V10') THEN - IF(.NOT.ALLOCATED(FACT10)) THEN - ALLOCATE(FACT10(1:IM,1:JM)) - FACT10=0. - ENDIF -! - DO J=1,JM - DO I=1,IM - FACT10(I,J)=FACT10(I,J)+ & - wrt_int_state%RST_OUTPUT_ARRAY_R2D(I,J)* & - wrt_int_state%RST_OUTPUT_ARRAY_R2D(I,J) - ENDDO - ENDDO - ENDIF -! - IF(TRIM(NAME)=='U_'//MODEL_LEVEL//'_2D') THEN - ALLOCATE(FACT10TMPU(1:IM,1:JM)) - CALL V_TO_H_BGRID(wrt_int_state%RST_OUTPUT_ARRAY_R2D(1:IM,1:JM) & - ,IM,JM,GLOBAL,FACT10TMPU) - ENDIF -! - IF(TRIM(NAME)=='V_'//MODEL_LEVEL//'_2D') THEN - ALLOCATE(FACT10TMPV(1:IM,1:JM)) - CALL V_TO_H_BGRID(wrt_int_state%RST_OUTPUT_ARRAY_R2D(1:IM,1:JM) & - ,IM,JM,GLOBAL,FACT10TMPV) - ENDIF - -! - IF(wrt_int_state%WRITE_RST_BIN)THEN -! - WRITE(wrt_int_state%IO_RST_UNIT,iostat=RC)wrt_int_state%RST_OUTPUT_ARRAY_R2D !<-- Lead write task writes out the 2D real data -! - IF(RST_FIRST .AND. (wrt_int_state%PRINT_OUTPUT .OR. wrt_int_state%PRINT_ALL) )THEN - WRITE(0,*)'Wrote ',TRIM(NAME) & - ,' to restart file unit ',wrt_int_state%IO_RST_UNIT & - ,MAXVAL(wrt_int_state%RST_OUTPUT_ARRAY_R2D) & - ,MINVAL(wrt_int_state%RST_OUTPUT_ARRAY_R2D) - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** The same for the NEMSIO restart file. -!----------------------------------------------------------------------- -! - IF(wrt_int_state%WRITE_RST_NEMSIO)THEN -! - IF(FIELDSIZE/=IM*JM)THEN - WRITE(0,*)'WRONG: data dimension ',IM*JM, & - ' does not match data size in NEMSIO file,',FIELDSIZE - ENDIF - IF(TRIM(NAME)=='FIS') THEN - IF(.NOT.ALLOCATED(HGT)) ALLOCATE(HGT(1:IM,1:JM)) - HGT(1:IM,1:JM)=wrt_int_state%RST_OUTPUT_ARRAY_R2D(1:IM,1:JM)/G - ENDIF -! - IF(TRIM(NAME)=='GLAT')THEN - ALLOCATE(GLAT1D(FIELDSIZE)) - GLAT1D(1:FIELDSIZE)=RESHAPE(wrt_int_state%RST_OUTPUT_ARRAY_R2D(1:IM,1:JM),(/FIELDSIZE/)) - ENDIF -! - IF(TRIM(NAME)=='GLON')THEN - ALLOCATE(GLON1D(FIELDSIZE)) - GLON1D(1:FIELDSIZE)=RESHAPE(wrt_int_state%RST_OUTPUT_ARRAY_R2D(1:IM,1:JM),(/FIELDSIZE/)) - ENDIF -! - N=NFIELD+wrt_int_state%RST_KOUNT_I2D(1) - TMP=RESHAPE(wrt_int_state%RST_OUTPUT_ARRAY_R2D(1:IM,1:JM),(/FIELDSIZE/)) -! - CALL NEMSIO_WRITEREC(NEMSIOFILE,N,TMP,IRET=IERR) - IF(IERR/=0)THEN - WRITE(0,*)' Failed to write output to file! Aborting!' - CALL ESMF_Finalize(rc=RC,endflag=ESMF_END_ABORT) - ENDIF -! -! IF(RST_FIRST)THEN -! WRITE(0,*)'Wrote ',TRIM(NAME),' to nemsio restart file iret=',ierr -! ENDIF - - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO rst_field_loop_real -! -!----------------------------------------------------------------------- -!*** Complete the computation of 10-m wind factor and write out -!*** FACT10 AND HGT. -!----------------------------------------------------------------------- -! - IF(MYPE==LEAD_WRITE_TASK) THEN - IF(ALLOCATED(FACT10).AND.ALLOCATED(FACT10TMPU).AND.ALLOCATED(FACT10TMPV)) THEN -! - DO J=1,JM - DO I=1,IM - FACT10TMPV(I,J)=SQRT(FACT10TMPU(I,J)*FACT10TMPU(I,J)+ & - FACT10TMPV(I,J)*FACT10TMPV(I,J) ) -! - IF(FACT10TMPV(I,J)/=0) THEN - FACT10(I,J)=SQRT(FACT10(I,J))/FACT10TMPV(I,J) - ELSE - FACT10(I,J)=1. - ENDIF - ENDDO - ENDDO -! - DEALLOCATE(FACT10TMPU) - DEALLOCATE(FACT10TMPV) -! - IF(wrt_int_state%WRITE_RST_BIN)THEN - WRITE(wrt_int_state%IO_RST_UNIT,iostat=RC)FACT10 !<-- Lead write task writes out the 2D real data - IF(RST_FIRST .AND. (wrt_int_state%PRINT_OUTPUT .OR. wrt_int_state%PRINT_ALL) )THEN - WRITE(0,*)'Wrote FACT10 to restart file unit ',wrt_int_state%IO_RST_UNIT & - ,maxval(fact10),minval(fact10) - ENDIF - ENDIF - - IF(wrt_int_state%WRITE_RST_NEMSIO)THEN - N=N+1 - TMP=RESHAPE(FACT10(1:IM,1:JM),(/FIELDSIZE/)) - CALL NEMSIO_WRITEREC(NEMSIOFILE,N,TMP,IRET=IERR) - IF(IERR/=0)THEN - WRITE(0,*)' Failed to write output to file! Aborting!' - CALL ESMF_Finalize(rc=RC,endflag=ESMF_END_ABORT) - ENDIF -! write(0,*)'after nemsio_writerec,n=',n,'fact10=',maxval(tmp),minval(tmp),'iret=',ierr -! WRITE(0,*)'Wrote FACT10 to nemsio restart file iret=',ierr - ENDIF -! - DEALLOCATE(FACT10) - - ENDIF -! - IF( wrt_int_state%WRITE_RST_NEMSIO)THEN - N=N+1 - TMP=RESHAPE(HGT(1:IM,1:JM),(/FIELDSIZE/)) - CALL NEMSIO_WRITEREC(NEMSIOFILE,N,TMP,IRET=IERR) - IF(IERR/=0)THEN - WRITE(0,*)' Failed to write output to file! Aborting!' - CALL ESMF_Finalize(rc=RC,endflag=ESMF_END_ABORT) - ENDIF - DEALLOCATE(HGT) - ENDIF -! - ENDIF -! - RST_FIRST=.FALSE. -! -!----------------------------------------------------------------------- -!*** Close the restart file. -!----------------------------------------------------------------------- -! - IF(wrt_int_state%WRITE_RST_BIN.and.MYPE==LEAD_WRITE_TASK)THEN - CLOSE(wrt_int_state%IO_RST_UNIT) -! write(0,*)' Closed restart file with unit=',wrt_int_state%IO_RST_UNIT - ENDIF -! -!----------------------------------------------------------------------- -!*** Close the NEMSIO restart file. -!----------------------------------------------------------------------- -! - IF(wrt_int_state%WRITE_RST_NEMSIO.AND.wrt_int_state%MYPE==LEAD_WRITE_TASK)THEN -! - IF(ASSOCIATED(GLAT1D).AND.ASSOCIATED(GLON1D)) THEN - CALL NEMSIO_SETFILEHEAD(NEMSIOFILE,IERR,GLAT1D,GLON1D) - DEALLOCATE(GLAT1D,GLON1D) - ENDIF -! - CALL NEMSIO_GETFILEHEAD(NEMSIOFILE,IERR,gfname=GFNAME) -! - DEALLOCATE(TMP) -! - CALL NEMSIO_CLOSE(NEMSIOFILE) -! WRITE(0,*)' Closed nemsio_restart file, ', gfname -! - CALL NEMSIO_FINALIZE() -! - ENDIF -! -!---------------------- -!*** Restartdone file -!---------------------- -! -!----------------------------------------------------------------------- - IF(wrt_int_state%WRITE_DONEFILEFLAG & - .and. & - wrt_int_state%MYPE==LEAD_WRITE_TASK & - .and. & - (wrt_int_state%WRITE_RST_BIN & - .or. & - wrt_int_state%WRITE_RST_NEMSIO))THEN -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file object - ,value =ID_DOMAIN & !<-- Put extracted quantity here - ,label ='my_domain_id:' & !<-- The quantity's label in the configure file - ,rc =RC) -! - INT_SEC=INT(NF_SECONDS) - FRAC_SEC=NINT((NF_SECONDS-INT_SEC)*100.) -! - WRITE(FILENAME,'(A,I2.2,A,I4.4,A,I2.2,A,I2.2,A,I2.2,A)' ) & - 'restartdone.',ID_DOMAIN,'.' & !<-- Insert domain ID for nests - ,NF_HOURS,'h_' & - ,NF_MINUTES,'m_' & - ,INT_SEC,'.',FRAC_SEC,'s' -! - DO N=51,99 - INQUIRE(N,opened=OPENED) - IF(.NOT.OPENED)THEN - IO_RST_UNIT=N - EXIT - ENDIF - ENDDO -! - OPEN(unit =IO_RST_UNIT & - ,file =trim(FILENAME) & - ,form ='formatted' & - ,status='REPLACE') -! - WRITE(IO_RST_UNIT,'(A4)')'DONE' - CLOSE(IO_RST_UNIT) -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF restart_time -! -!----------------------------------------------------------------------- -! - IF(RC_RUN==ESMF_SUCCESS)THEN -! WRITE(0,*)"PASS: WRITE_RUN" - ELSE - WRITE(0,*)"FAIL: WRITE_RUN" - ENDIF -! - write_run_tim=write_run_tim+(timef()-btim0) -! - IF(MYPE==LEAD_WRITE_TASK)THEN - IF(wrt_int_state%PRINT_OUTPUT .OR. wrt_int_state%PRINT_ALL) & - WRITE(0,*)' Write Time is ',write_run_tim*1.e-3 & - ,' at Fcst ',NF_HOURS,':',NF_MINUTES,':',NF_SECONDS - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE WRITE_RUN -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE WRITE_FINALIZE(WRITE_COMP & - ,IMP_STATE_WRITE & - ,EXP_STATE_WRITE & - ,CLOCK & - ,RCFINAL) -! -!----------------------------------------------------------------------- -!*** Finalize the Write gridded component. -!----------------------------------------------------------------------- -! -!*** HISTORY -! xx Feb 2007: W. Yang - Originator -! 13 Jun 2007: T. Black - Name revisions -! -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_GridComp) :: WRITE_COMP !<-- The Write component -! - TYPE(ESMF_State) :: IMP_STATE_WRITE & !<-- The Write component import state - ,EXP_STATE_WRITE !<-- The Write component export state -! - TYPE(ESMF_Clock) :: CLOCK !<-- The Write component Clock -! - INTEGER,INTENT(OUT) :: RCFINAL -! -!--------------------- -!*** Local Variables -!--------------------- -! - TYPE(WRITE_WRAP) :: WRAP -! - INTEGER :: RC -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RCFINAL=ESMF_SUCCESS -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Retrieve Write Component's Internal State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGetInternalState(WRITE_COMP & !<-- The write component - ,WRAP & !<-- Pointer to internal state - ,RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RCFINAL) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DEALLOCATE(WRAP%WRITE_INT_STATE) -! -!----------------------------------------------------------------------- -! - IF(RCFINAL==ESMF_SUCCESS)THEN -! WRITE(0,*)'PASS: Write_Finalize.' - ELSE - WRITE(0,*)'FAIL: Write_Finalize.' - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE WRITE_FINALIZE -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE WRITE_SETUP(DOMAIN_GRID_COMP & - ,DOMAIN_INT_STATE & - ,CLOCK_DOMAIN) -! -!----------------------------------------------------------------------- -!*** Set up the Write components with the forecast tasks and -!*** the groups of write tasks needed for quilting the output -!*** and writing it to history/restart files. -!----------------------------------------------------------------------- -! - USE MODULE_DOMAIN_INTERNAL_STATE,ONLY: DOMAIN_INTERNAL_STATE -! -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_GridComp),INTENT(INOUT) :: DOMAIN_GRID_COMP !<-- The DOMAIN component -! - TYPE(DOMAIN_INTERNAL_STATE),INTENT(INOUT) :: DOMAIN_INT_STATE !<-- The DOMAIN component's Internal State -! - TYPE(ESMF_Clock),INTENT(INOUT) :: CLOCK_DOMAIN !<-- The DOMAIN component's ESMF Clock -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: INPES,JNPES & !<-- Number of fcst tasks in I and J directions - ,MYPE & !<-- My task ID - ,WRITE_GROUPS & !<-- Number of groups of write tasks - ,WRITE_TASKS_PER_GROUP !<-- #of tasks in each write group -! - INTEGER(kind=KINT) :: I,ISTAT,J,K,RC,RC_SETUP -! - CHARACTER(2) :: MY_WRITE_GROUP - CHARACTER(6) :: FMT='(I2.2)' - CHARACTER(ESMF_MAXSTR) :: WRITE_NAME -! - TYPE(ESMF_VM) :: VM !<-- The ESMF virtual machine. -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Save the total number of domains. This is always given in -!*** domain #1's configure file. -!----------------------------------------------------------------------- -! - CF_1=ESMF_ConfigCreate(rc=RC) !<-- Create the confure object for domain #1 - CONFIGFILE_01_NAME='configure_file_01' -! - CALL ESMF_ConfigLoadFile(config =CF_1 & !<-- Load the configure file object for domain #1 - ,filename=CONFIGFILE_01_NAME & !<-- The configure file's name - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF_1 & !<-- The configure file object for domain #1 - ,value =NUM_DOMAINS_TOTAL & !<-- Extract the total # of domains - ,label ='num_domains_total:' & !<-- The quantity's label in the configure file - ,rc =RC) -! -!----------------------------------------------------------------------- -!*** Retrieve the config object CF from the DOMAIN component for -!*** this domain. Save it in the Write component's internal state. -!*** This will allow a given task to reference it for any of the -!*** multiple domains a given task may lie on. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Config Object for Write Setup" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGet(gridcomp=DOMAIN_GRID_COMP & !<-- The DOMAIN component - ,config =CF & !<-- The configure object on this domain - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_SETUP) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Retrieve task and group counts from the config file. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Write Tasks and Groups from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(CF & !<-- The configure file - ,WRITE_GROUPS & !<-- Number of write groups from config file - ,label ='write_groups:' & - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(CF & !<-- The configure file - ,WRITE_TASKS_PER_GROUP & !<-- Number of write tasks per group from config file - ,label ='write_tasks_per_group:' & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_SETUP) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - domain_int_state%WRITE_GROUPS=WRITE_GROUPS !<-- Save for the DOMAIN's Finalize step - domain_int_state%WRITE_TASKS_PER_GROUP=WRITE_TASKS_PER_GROUP !<-- Save for the DOMAIN's Finalize step -! -!----------------------------------------------------------------------- -!*** How many forecast tasks do we have? -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="INPES/JNPES from Config Object for Write Setup" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The ESMF configure object - ,value =INPES & !<-- # of fcst tasks in I direction - ,label ='inpes:' & !<-- Give the value of this label to INPES - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The ESMF configure object - ,value =JNPES & !<-- # of fcst tasks in J direction - ,label ='jnpes:' & !<-- Give the value of this label to JNPES - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_SETUP) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NUM_PES_FCST=INPES*JNPES !<-- Total number of forecast tasks -! -!----------------------------------------------------------------------- -!*** Retrieve the current VM. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Retrieve the Local VM" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_VMGetCurrent(vm=VM & !<-- The ESMF virtual machine - ,rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_SETUP) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** What is my MPI task ID? -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get MPI Task IDs for Write Setup" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_VMGet(vm =VM & !<-- The virtual machine - ,localpet=MYPE & !<-- Local PE rank - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_SETUP) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Associate all of the forecast tasks with the write tasks -!*** in each write group. -!----------------------------------------------------------------------- -! - ALLOCATE(domain_int_state%PETLIST_WRITE(NUM_PES_FCST+WRITE_TASKS_PER_GROUP,WRITE_GROUPS)) !<-- Task IDs of all fcst tasks - ! plus the write tasks - ! by write group -! -!----------------------------------------------------------------------- -!*** Collect the task IDs for the write tasks and the associated -!*** forecast-write tasks. -!----------------------------------------------------------------------- -! - DO I=0,NUM_PES_FCST-1 - DO J=1,WRITE_GROUPS - domain_int_state%PETLIST_WRITE(I+1,J)=I !<-- Collect forecast task IDs to be associated with - ! write tasks by write group - ENDDO -! - ENDDO -! - K=NUM_PES_FCST -! - DO J=1,WRITE_GROUPS - DO I=1,WRITE_TASKS_PER_GROUP - domain_int_state%PETLIST_WRITE(NUM_PES_FCST+I,J)=K !<-- Append Write task IDs to associated forecast task IDs by group - K=K+1 - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** Create the Write gridded component(s). -!*** There are as many Write components as there are groups of -!*** write tasks specified in the configure file. -!*** Register their Init, Run, and Finalize steps. -!----------------------------------------------------------------------- -! - IF(WRITE_GROUPS>0)THEN - ALLOCATE(domain_int_state%WRITE_COMPS(WRITE_GROUPS)) !<-- The Write gridded components - ENDIF -! -!--------------------------------- -!*** Create the Write components -!--------------------------------- -! - DO I=1,WRITE_GROUPS - WRITE(MY_WRITE_GROUP,FMT)I - WRITE_NAME='write_GridComp_'//MY_WRITE_GROUP -! - domain_int_state%WRITE_COMPS(I)=ESMF_GridCompCreate( & - name =WRITE_NAME & !<-- Name of this group's Write gridded component - ,config =CF & !<-- The configure file for writes - ,petList=domain_int_state%PETLIST_WRITE(:,I) & !<-- The task IDs of the write tasks in this group - ! provide the local VM information per component. - ,rc =RC) -! - ENDDO -! -!----------------------------------- -!*** Register the Write components -!----------------------------------- -! - DO I=1,WRITE_GROUPS -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Register Write Components" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompSetServices(domain_int_state%WRITE_COMPS(I) & !<-- The Write gridded components - ,WRITE_REGISTER & !<-- The user's subroutine name - ,rc = RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_SETUP) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDDO -! -!------------------------------------------------------------------------ -!*** Create empty Import and Export states for the Write subcomponent(s) -!------------------------------------------------------------------------ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Create Empty Import/Export States for Write Components" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - domain_int_state%IMP_STATE_WRITE=ESMF_StateCreate(name ='Write Import State' & !<-- Import state name for writes - ,stateintent= ESMF_STATEINTENT_IMPORT & - ,rc = RC) -! - domain_int_state%EXP_STATE_WRITE=ESMF_StateCreate(name ='Write Export State' & !<-- Export state names for writes - ,stateintent= ESMF_STATEINTENT_EXPORT & - ,rc = RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_SETUP) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Insert the Write components' import state into the -!*** Solver export state since history data itself must -!*** come from the Solver. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Insert Write Import State into Solver Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateAddReplace(domain_int_state%EXP_STATE_SOLVER & !<-- Solver export state receives a state - ,(/domain_int_state%IMP_STATE_WRITE/) & !<-- Add the write components' import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_SETUP) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - END SUBROUTINE WRITE_SETUP -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE WRITE_DESTROY(DOMAIN_GRID_COMP & - ,DOMAIN_INT_STATE & - ,CLOCK_DOMAIN) -! -!----------------------------------------------------------------------- -!*** Destroy all objects related to the Write components. -!----------------------------------------------------------------------- -! - USE MODULE_DOMAIN_INTERNAL_STATE,ONLY: DOMAIN_INTERNAL_STATE -! -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_GridComp),INTENT(INOUT) :: DOMAIN_GRID_COMP !<-- The DOMAIN component -! - TYPE(DOMAIN_INTERNAL_STATE),INTENT(INOUT) :: DOMAIN_INT_STATE !<-- The Domain component's Internal State -! - TYPE(ESMF_Clock),INTENT(INOUT) :: CLOCK_DOMAIN !<-- The DOMAIN component's ESMF Clock -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER :: I,J,MYPE,N,RC,RC_DES -! - TYPE(ESMF_VM) :: VM -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - RC =ESMF_SUCCESS - RC_DES=ESMF_SUCCESS -! -!----------------------------------------------------------------------- -!*** Retrieve the current VM. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Retrieve the Local VM in Write Destroy" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_VMGetCurrent(vm=VM & !<-- The ESMF virtual machine - ,rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_DES) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** What is my MPI task ID? -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get MPI Task IDs for Write Destroy" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_VMGet(vm =VM & !<-- The virtual machine - ,localpet=MYPE & !<-- Local PE rank - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_DES) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Finalize the Write gridded components in each write group. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Finalize Write Components" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DO N=1,domain_int_state%WRITE_GROUPS - IF(MYPE>=domain_int_state%PETLIST_WRITE(1,N).AND. & - MYPE<=domain_int_state%PETLIST_WRITE(domain_int_state%WRITE_TASKS_PER_GROUP,N))THEN -! - CALL ESMF_GridCompFinalize(gridcomp =domain_int_state%WRITE_COMPS(N) & - ,importstate=domain_int_state%EXP_STATE_WRITE & - ,exportstate=domain_int_state%IMP_STATE_WRITE & - ,clock =CLOCK_DOMAIN & - ,rc =RC) - ENDIF - ENDDO -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_DES) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Destroy the Write components' import/export states. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Destroy Write Component Import/Export States" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateDestroy(domain_int_state%IMP_STATE_WRITE,rc=RC) - CALL ESMF_StateDestroy(domain_int_state%EXP_STATE_WRITE,rc=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_DES) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Destroy the Write components. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Destroy Write Components" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DO J=1,domain_int_state%WRITE_GROUPS -! - CALL ESMF_VMBarrier(vm=VM,rc=RC) -! - DO I=1,domain_int_state%NUM_PES_FCST+domain_int_state%WRITE_TASKS_PER_GROUP -! - IF(MYPE==domain_int_state%PETLIST_WRITE(I,J))THEN - CALL ESMF_GridCompDestroy(gridcomp=domain_int_state%WRITE_COMPS(J) & - ,rc =RC) - ENDIF -! - ENDDO -! - ENDDO -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_DES) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** The final error signal information. -!----------------------------------------------------------------------- -! - IF(RC_DES==ESMF_SUCCESS)THEN -! WRITE(0,*)' WRITE Finalize step succeeded' - ELSE - WRITE(0,*)' WRITE Finalize step failed RC_DES=',RC_DES - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE WRITE_DESTROY -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - END MODULE MODULE_WRITE_GRID_COMP -! -!----------------------------------------------------------------------- diff --git a/src/nmm/module_WRITE_INTERNAL_STATE.F90 b/src/nmm/module_WRITE_INTERNAL_STATE.F90 deleted file mode 100644 index db71a97..0000000 --- a/src/nmm/module_WRITE_INTERNAL_STATE.F90 +++ /dev/null @@ -1,324 +0,0 @@ -!----------------------------------------------------------------------- -! - MODULE MODULE_WRITE_INTERNAL_STATE -! -!----------------------------------------------------------------------- -!*** The internal state of the Write component. -!----------------------------------------------------------------------- -!*** -!*** HISTORY -!*** -! xx Feb 2007: W. Yang - Originator -! 14 Jun 2007: T. Black - Name revisions -! 14 Aug 2007: T. Black - Some pointers changed to arrays -! 11 Sep 2007: T. Black - Updates for quilting -! 15 Aug 2008: J. Wang - Add NEMSIO variables -! 16 Sep 2008: J. Wang - 3-D output arrays revert to 2-D -! 04 Sep 2009: T. Black - Add the 1-D boundary restart arrays -! 22 Apr 2010: T. Black - Add minutes and seconds to elapsed -! forecast time. -! 15 Sep 2010: T. Black - Changed many components to pointers -! Feb 2011: W. Yang - Updated to use both the ESMF 4.0.0rp2 library, -! ESMF 5 library and the the ESMF 3.1.0rp2 library. -! May 2011: J. Wang - add dopost and post_gribversion option to run post -! 27 SEP 2011 W. Yang, - Modified for using the ESMF 5.2.0r library. -! -!--------------------------------------------------------------------------------- -! - USE ESMF - USE MODULE_KINDS - USE MODULE_DERIVED_TYPES,ONLY: BC_H_ALL,BC_V_ALL -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- -! - PRIVATE -! - PUBLIC :: WRITE_INTERNAL_STATE,WRITE_WRAP & - ,MAX_DATA_I1D,MAX_DATA_I2D & - ,MAX_DATA_R1D,MAX_DATA_R2D & - ,MAX_DATA_LOG -! -!----------------------------------------------------------------------- -! - INTEGER(kind=KINT),PARAMETER :: MAX_DATA_I1D=50 !<-- Max # of 1D integer arrays - INTEGER(kind=KINT),PARAMETER :: MAX_DATA_I2D=50 !<-- Max # of 2D integer arrays - INTEGER(kind=KINT),PARAMETER :: MAX_DATA_R1D=50 !<-- Max # of 1D real arrays - INTEGER(kind=KINT),PARAMETER :: MAX_DATA_R2D=10000 !<-- Max # of 2D real arrays and layers - ! of all real 3D arrays combined - INTEGER(kind=KINT),PARAMETER :: MAX_DATA_LOG=10 -! -!----------------------------------------------------------------------- - - TYPE WRITE_INTERNAL_STATE - -!------------------------------------ -!*** PE information and task layout -!------------------------------------ -! - INTEGER(kind=KINT) :: MYPE - INTEGER(kind=KINT) :: INPES,JNPES - INTEGER(kind=KINT) :: IHALO,JHALO - INTEGER(kind=KINT) :: LAST_FCST_TASK,LAST_WRITE_TASK - INTEGER(kind=KINT) :: LEAD_WRITE_TASK - INTEGER(kind=KINT) :: NTASKS - INTEGER(kind=KINT) :: WRITE_GROUPS,WRITE_TASKS_PER_GROUP -! -!----------------------------- -!*** Full domain information -!----------------------------- -! - INTEGER(kind=KINT) :: ID_DOMAIN -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: IM - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: IDS - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: IDE - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: JM - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: JDS - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: JDE - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: LM -! - LOGICAL(kind=KLOG) :: GLOBAL -! -!---------------------------------------------------- -!*** The forecast or quilt tasks' intracommunicator -!---------------------------------------------------- -! - INTEGER(kind=KINT) :: MPI_COMM_COMP -! -!--------------------------------------------- -!*** Array of Write group intercommunicators -!--------------------------------------------- -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: MPI_INTERCOMM_ARRAY -! -!-------------------- -!*** Subdomain size -!-------------------- -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: LOCAL_ISTART & - ,LOCAL_IEND & - ,LOCAL_JSTART & - ,LOCAL_JEND -! -!---------------------------------------------------- -!*** IDs of fcst tasks that send to each write task -!---------------------------------------------------- -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: ID_FTASK_RECV_STA & - ,ID_FTASK_RECV_END -! -!---------------------------------------------------- -!*** # of words sent by each forecast task -!*** to its designated write task. -!---------------------------------------------------- -! - INTEGER(kind=KINT),POINTER :: NUM_WORDS_SEND_I2D_HST & - ,NUM_WORDS_SEND_R2D_HST & - ,NUM_WORDS_SEND_I2D_RST & - ,NUM_WORDS_SEND_R2D_RST -! -!---------------------------------------------------- -!*** # of words received by each write task from -!*** all of its designated forecast tasks. -!---------------------------------------------------- -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: NUM_WORDS_RECV_I2D_HST =>NULL() & - ,NUM_WORDS_RECV_R2D_HST =>NULL() & - ,NUM_WORDS_RECV_I2D_RST =>NULL() & - ,NUM_WORDS_RECV_R2D_RST =>NULL() -! -!-------------------------------------- -!*** History/restart data information -!-------------------------------------- -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: KOUNT_I1D =>NULL() & - ,KOUNT_I2D =>NULL() & - ,KOUNT_R1D =>NULL() & - ,KOUNT_R2D =>NULL() & - ,KOUNT_LOG =>NULL() -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: RST_KOUNT_I1D =>NULL() & - ,RST_KOUNT_I2D =>NULL() & - ,RST_KOUNT_R1D =>NULL() & - ,RST_KOUNT_R2D =>NULL() & - ,RST_KOUNT_LOG =>NULL() -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: LENGTH_DATA_I1D =>NULL() & - ,LENGTH_DATA_R1D =>NULL() & - ,LENGTH_DATA_R2D =>NULL() -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: RST_LENGTH_DATA_I1D =>NULL() & - ,RST_LENGTH_DATA_R1D =>NULL() & - ,RST_LENGTH_DATA_R2D =>NULL() -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: LENGTH_SUM_I1D =>NULL() & - ,LENGTH_SUM_R1D =>NULL() & - ,LENGTH_SUM_R2D =>NULL() & - ,LENGTH_SUM_LOG =>NULL() -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: RST_LENGTH_SUM_I1D =>NULL() & - ,RST_LENGTH_SUM_R1D =>NULL() & - ,RST_LENGTH_SUM_R2D =>NULL() & - ,RST_LENGTH_SUM_LOG =>NULL() -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: NCOUNT_FIELDS =>NULL() & - ,RST_NCOUNT_FIELDS =>NULL() -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: ALL_DATA_I1D =>NULL() & - ,ALL_DATA_I2D =>NULL() -! - INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: OUTPUT_ARRAY_I2D =>NULL() -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: RST_ALL_DATA_I1D =>NULL() & - ,RST_ALL_DATA_I2D =>NULL() -! - INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: RST_OUTPUT_ARRAY_I2D =>NULL() -! - REAL(kind=KFPT),DIMENSION(:),POINTER :: ALL_DATA_R1D =>NULL() & - ,ALL_DATA_R2D =>NULL() -! - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: OUTPUT_ARRAY_R2D =>NULL() -! - REAL(kind=KFPT),DIMENSION(:),POINTER :: RST_ALL_DATA_R1D =>NULL() & - ,RST_ALL_DATA_R2D =>NULL() -! - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: RST_OUTPUT_ARRAY_R2D =>NULL() -! -!---------------------- -!*** Boundary restart -!---------------------- -! - INTEGER(kind=KINT) :: LNSH,LNSV !<-- # of H,V bndry rows, respectively - INTEGER(kind=KINT) :: NLEV_H,NLEV_V !<-- Total # of 2-D levels in all H-pt,V-pt bndry vbls -! -!----------- -!*** Local -!----------- -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: NUM_WORDS_BC_SOUTH & !<-- Word counts of 1-D boundary data strings - ,NUM_WORDS_BC_NORTH & ! for each side of the domain. - ,NUM_WORDS_BC_WEST & ! - ,NUM_WORDS_BC_EAST !<-- -! - REAL(kind=KFPT),DIMENSION(:),ALLOCATABLE :: RST_BC_DATA_SOUTH & !<-- 1-D strings of boundary data - ,RST_BC_DATA_NORTH & ! for each side of the domain. - ,RST_BC_DATA_WEST & ! - ,RST_BC_DATA_EAST !<-- -! -!----------------- -!*** Full-domain -!----------------- -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: NUM_WORDS_SEND_BC !<-- Word count of full-domain 1-D boundary data string -! - INTEGER(kind=KINT) :: NVARS_BC_2D_H & !<-- # of 2-D H-pt boundary variables - ,NVARS_BC_3D_H & !<-- # of 3-D H-pt boundary variables - ,NVARS_BC_4D_H & !<-- # of 4-D H-pt boundary variables - ,NVARS_BC_2D_V & !<-- # of 2-D V-pt boundary variables - ,NVARS_BC_3D_V !<-- # of 3-D V-pt boundary variables -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: LBND_4D & !<-- Lower,upper bounds of the counts of the # of - ,UBND_4D ! 3-D arrays in each 4-D boundary variable -! - REAL(kind=KFPT),DIMENSION(:),ALLOCATABLE :: RST_ALL_BC_DATA !<-- 1-D string of full-domain boundary data -! - TYPE(BC_H_ALL) :: BND_VARS_H !<-- All H-pt boundary data/tendencies -! - TYPE(BC_V_ALL) :: BND_VARS_V !<-- All V-pt boundary data/tendencies -! -!-------------------- -!*** Storage arrays -!-------------------- -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: BUFF_INT =>NULL() & - ,RST_BUFF_INT =>NULL() -! - INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: WRITE_SUBSET_I =>NULL() & - ,RST_WRITE_SUBSET_I=>NULL() -! - REAL(kind=KFPT),DIMENSION(:),POINTER :: BUFF_REAL =>NULL() & - ,RST_BUFF_REAL=>NULL() -! - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: WRITE_SUBSET_R =>NULL() & - ,RST_WRITE_SUBSET_R=>NULL() -! - LOGICAL, DIMENSION(:),POINTER :: ALL_DATA_LOG =>NULL() - LOGICAL, DIMENSION(:),POINTER :: RST_ALL_DATA_LOG=>NULL() -! - CHARACTER(ESMF_MAXSTR),DIMENSION(:),POINTER :: FIELD_NAME=>NULL() & - ,RST_FIELD_NAME=>NULL() -! - CHARACTER(ESMF_MAXSTR*MAX_DATA_I1D),POINTER :: NAMES_I1D_STRING - CHARACTER(ESMF_MAXSTR*MAX_DATA_I2D),POINTER :: NAMES_I2D_STRING - CHARACTER(ESMF_MAXSTR*MAX_DATA_R1D),POINTER :: NAMES_R1D_STRING - CHARACTER(ESMF_MAXSTR*MAX_DATA_R2D),POINTER :: NAMES_R2D_STRING - CHARACTER(ESMF_MAXSTR*MAX_DATA_LOG),POINTER :: NAMES_LOG_STRING -! - CHARACTER(ESMF_MAXSTR*MAX_DATA_I1D),POINTER :: RST_NAMES_I1D_STRING - CHARACTER(ESMF_MAXSTR*MAX_DATA_I2D),POINTER :: RST_NAMES_I2D_STRING - CHARACTER(ESMF_MAXSTR*MAX_DATA_R1D),POINTER :: RST_NAMES_R1D_STRING - CHARACTER(ESMF_MAXSTR*MAX_DATA_R2D),POINTER :: RST_NAMES_R2D_STRING - CHARACTER(ESMF_MAXSTR*MAX_DATA_LOG),POINTER :: RST_NAMES_LOG_STRING -! -!--------------------- -!*** The output file -!--------------------- -! - INTEGER(kind=KINT) :: IO_HST_UNIT,IO_RST_UNIT - INTEGER(kind=KINT) :: IO_RECL - INTEGER(kind=KINT) :: NFHOURS - INTEGER(kind=KINT) :: NFMINUTES -! - REAL(kind=KFPT) :: NFSECONDS -! - CHARACTER(ESMF_MAXSTR) :: HST_NAME_BASE,RST_NAME_BASE -! - CHARACTER(ESMF_MAXSTR) :: POST_GRIBVERSION -! -!------------------------------------- -!*** Times used in history filenames -!------------------------------------- -! - TYPE(ESMF_Time) :: IO_BASETIME - TYPE(ESMF_TimeInterval) :: IO_CURRTIMEDIFF -! -!----------------------------------------- -!*** I/O direction flags (Read or Write) -!----------------------------------------- -! - LOGICAL(kind=KLOG) :: WRITE_HST_BIN,WRITE_HST_NEMSIO - LOGICAL(kind=KLOG) :: WRITE_RST_BIN,WRITE_RST_NEMSIO - LOGICAL(kind=KLOG) :: WRITE_NEMSIOCTL - LOGICAL(kind=KLOG) :: WRITE_FSYNCFLAG - LOGICAL(kind=KLOG) :: WRITE_DONEFILEFLAG - LOGICAL(kind=KLOG) :: WRITE_DOPOST - LOGICAL(kind=KLOG) :: PRINT_ALL - LOGICAL(kind=KLOG) :: PRINT_DIAG - LOGICAL(kind=KLOG) :: PRINT_OUTPUT - LOGICAL(kind=KLOG) :: PRINT_ESMF - - integer :: nlunit ! post namelist unit number - Moorthi - character(80) :: post_namelist - -!----------------------------------------------------------------------- -! - END TYPE WRITE_INTERNAL_STATE -! -!----------------------------------------------------------------------- -!*** This state is supported by C pointers but not F90 pointers -!*** therefore we need this wrap. -!----------------------------------------------------------------------- -! - TYPE WRITE_WRAP - TYPE(WRITE_INTERNAL_STATE),POINTER :: WRITE_INT_STATE - END TYPE WRITE_WRAP - -!----------------------------------------------------------- -! - END MODULE MODULE_WRITE_INTERNAL_STATE -! -!----------------------------------------------------------- diff --git a/src/nmm/module_WRITE_ROUTINES.F90 b/src/nmm/module_WRITE_ROUTINES.F90 deleted file mode 100644 index 3853643..0000000 --- a/src/nmm/module_WRITE_ROUTINES.F90 +++ /dev/null @@ -1,5248 +0,0 @@ -!----------------------------------------------------------------------- -! - MODULE MODULE_WRITE_ROUTINES -! -!----------------------------------------------------------------------- -!*** This module contains routines needed by the Run step of the -!*** Write gridded component in which history output data from -!*** the forecast tasks are assembled and written to history files -!*** by the write tasks. -!----------------------------------------------------------------------- -!*** -!*** HISTORY -!*** -! 06 Sep 2007: T. Black - Created module. -! Moved the FIRST block from the old -! Write component here for clarity. -! 15 Aug 2008: J. Wang - Revised for NEMS-IO -! 20 Aug 2008: J. Wang - Output start date first instead of -! forecast date. -! 16 Sep 2008: J. Wang - WRITE_NEMSIO_RUNHISTORY_OPEN only -! opens file and writes metadata. -! 30 Sep 2008: E. Colon - Generalize counts for nemsio -! 14 Oct 2008: R. Vasic - Added restart capability -! 05 Jan 2009: J. Wang - Added 10-m wind factor to NMMB -! runhistory and restart files. -! 06 Jan 2009: T. Black - Replace Max # of words recv'd by -! Write tasks with actual # of words. -! 03 Sep 2009: T. Black - Merged with NMM-B nesting code. -! 24 Mar 2010: T. Black - Revised for NEMS restructing. -! 07 May 2010: T. Black - Change output frequency to minutes. -! 16 Dec 2010: J. Wang - Change to nemsio library -! Feb 2011: W. Yang - Updated to use both the ESMF 4.0.0rp2 library, -! ESMF 5 library and the the ESMF 3.1.0rp2 library. -! May 2011: J. Wang - add run post on quilt option -! 27 SEP 2011: W. Yang - Modified for using the ESMF 5.2.0r library. -! -!--------------------------------------------------------------------------------- -! - USE MPI - USE ESMF -! - USE MODULE_WRITE_INTERNAL_STATE,ONLY: WRITE_INTERNAL_STATE & - ,WRITE_WRAP & - ,MAX_DATA_I1D & - ,MAX_DATA_I2D & - ,MAX_DATA_R1D & - ,MAX_DATA_R2D & - ,MAX_DATA_LOG -! - USE MODULE_DOMAIN_INTERNAL_STATE,ONLY: DOMAIN_INTERNAL_STATE -! - USE MODULE_DM_PARALLEL,ONLY : PARA_RANGE & - ,MPI_COMM_COMP -! - USE MODULE_CONTROL,ONLY : TIMEF -! - USE MODULE_KINDS -! - USE MODULE_ERROR_MSG,ONLY: ERR_MSG,MESSAGE_CHECK -! - USE NEMSIO_MODULE -! - USE MODULE_CONSTANTS,ONLY : A,PI,G -! -!----------------------------------------------------------------------- -! - IMPLICIT NONE -! -!----------------------------------------------------------------------- - - PRIVATE -! - PUBLIC :: SEND_UPDATED_ATTRIBUTES & - ,WRITE_ASYNC & - ,WRITE_INIT & - ,WRITE_NEMSIO_RUNHISTORY_OPEN & - ,WRITE_NEMSIO_RUNRESTART_OPEN & - ,WRITE_NEMSIOCTL & - ,WRITE_RUNHISTORY_OPEN & - ,WRITE_RUNRESTART_OPEN & - ,OPEN_HST_FILE & - ,OPEN_RST_FILE -! -!----------------------------------------------------------------------- -! - LOGICAL,PUBLIC,SAVE :: TIME_FOR_HISTORY = .FALSE. & - ,TIME_FOR_RESTART = .FALSE. -! -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE PRELIM_INFO_FOR_OUTPUT(OUTPUT_FLAG & - ,NUM_PES_FCST & - ,NUM_WRITE_GROUPS & - ,WRITE_COMPS & - ,IMP_STATE_WRITE ) -! -!----------------------------------------------------------------------- -!*** This routine will perform certain computations and operations -!*** that only need to be done once for each Write group. Data that -!*** does not change with forecast time is unloaded from the Write -!*** components' import state. The data that is unloaded consists -!*** of everything except the 2D/3D gridded forecast arrays (whose -!*** contents do change with time). Also basic information is -!*** provided to forecast and write tasks that will be necessary in -!*** the quilting of local 2-D gridded history data into full domain -!*** arrays. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - CHARACTER(len=7),INTENT(IN) :: OUTPUT_FLAG -! - INTEGER(kind=KINT),INTENT(INOUT) :: NUM_PES_FCST & !<-- # of forecast tasks - ,NUM_WRITE_GROUPS !<-- # of write groups -! - TYPE(ESMF_GridComp),DIMENSION(NUM_WRITE_GROUPS),INTENT(IN) :: & - WRITE_COMPS !<-- The array of Write components -! - TYPE(ESMF_State),INTENT(INOUT) :: IMP_STATE_WRITE !<-- The import state of the Write components -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KDIN) :: NUM_WORDS_TOT -! - INTEGER(kind=KINT) :: COMM_MY_DOMAIN & - ,MYPE_DOMAIN -! - INTEGER(kind=KINT),SAVE :: ITS,ITE,JTS,JTE & - ,NCHAR_I1D & - ,NCHAR_R1D & - ,NCHAR_LOG -! - INTEGER(kind=KINT) :: I,IERR,IM,ISTAT,J,JM,L,M1,M2 & - ,N,N1,N2,NN,NUM_ATTRIB,NWTPG,NX,NY & - ,RC,RC_WRT -! - INTEGER(kind=KINT) :: JROW_FIRST,JROW_LAST,JROWS & - ,LAST_FCST_TASK & - ,LOCAL_ID & - ,N_END & - ,N_STA -! - INTEGER(kind=KINT) :: JEND_WRITE,JSTA_WRITE -! - INTEGER(kind=KINT) :: KOUNT_I1D_X & - ,KOUNT_I2D_X & - ,KOUNT_R1D_X & - ,KOUNT_R2D_X & - ,KOUNT_LOG_X -! - INTEGER(kind=KINT) :: LENGTH & - ,LENGTH_SUM_I1D_X & - ,LENGTH_SUM_R1D_X & - ,LENGTH_SUM_LOG_X -! - INTEGER(kind=KINT) :: MAX_WORDS & - ,NPOSN_START,NPOSN_END & - ,NUM_FIELD_NAMES & - ,NUM_WORDS -! - INTEGER(kind=KINT),DIMENSION(NUM_WRITE_GROUPS) :: LEAD_WRITE_TASK & - ,LAST_WRITE_TASK -! - INTEGER(kind=KINT),DIMENSION(MPI_STATUS_SIZE) :: JSTAT -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: IHALO,INPES & - ,JHALO,JNPES & - ,LOCAL_ISTART & - ,LOCAL_IEND & - ,LOCAL_JSTART & - ,LOCAL_JEND -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: NCHAR_I2D & - ,NCHAR_R2D & - ,WORK_ARRAY_I1D -! - REAL(kind=KFPT),DIMENSION(:),POINTER :: WORK_ARRAY_R1D -! - CHARACTER(len=14) :: BUNDLE_NAME -! - CHARACTER(ESMF_MAXSTR) :: ATTRIB_NAME -! - LOGICAL(kind=KLOG) :: NO_FIELDS -! - TYPE(WRITE_WRAP) :: WRAP -! - TYPE(WRITE_INTERNAL_STATE),POINTER :: WRT_INT_STATE -! - TYPE(ESMF_TypeKind_Flag) :: DATATYPE -! - TYPE(ESMF_Field) :: FIELD_WORK1 -! - LOGICAL(kind=KLOG) :: WORK_LOGICAL -! - TYPE(ESMF_VM) :: VM_DOMAIN -! - TYPE(ESMF_FieldBundle) :: OUTPUT_BUNDLE -! - TYPE :: TEMP_INT_STATE - TYPE(WRITE_INTERNAL_STATE),POINTER :: LOC_INT_STATE - END TYPE -! - TYPE(TEMP_INT_STATE),DIMENSION(:),ALLOCATABLE :: WRT_INT_STATE_X -! -!---------------------------------------------------- -!*** Local pointers to History or Restart variables -!*** in the Write component's internal state. -!---------------------------------------------------- -! - INTEGER(kind=KINT),POINTER :: NUM_WORDS_SEND_I2D & - ,NUM_WORDS_SEND_R2D -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: KOUNT_I1D & - ,KOUNT_I2D & - ,KOUNT_R1D & - ,KOUNT_R2D & - ,KOUNT_LOG -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: LENGTH_DATA_I1D & - ,LENGTH_DATA_R1D & - ,LENGTH_DATA_R2D -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: LENGTH_SUM_I1D & - ,LENGTH_SUM_R1D & - ,LENGTH_SUM_R2D & - ,LENGTH_SUM_LOG -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: NUM_WORDS_RECV_I2D & - ,NUM_WORDS_RECV_R2D -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: NCOUNT_FIELDS -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: ALL_DATA_I1D & - ,ALL_DATA_I2D -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: BUFF_INT -! - INTEGER(kind=KINT),DIMENSION(:,:),POINTER :: OUTPUT_ARRAY_I2D -! - INTEGER(kind=KINT),DIMENSION(:,:,:),POINTER :: WRITE_SUBSET_I -! - REAL(kind=KFPT),DIMENSION(:),POINTER :: ALL_DATA_R1D & - ,ALL_DATA_R2D -! - REAL(kind=KFPT),DIMENSION(:),POINTER :: BUFF_REAL -! - REAL(kind=KFPT),DIMENSION(:,:),POINTER :: OUTPUT_ARRAY_R2D -! - REAL(kind=KFPT),DIMENSION(:,:,:),POINTER :: WRITE_SUBSET_R -! - CHARACTER(ESMF_MAXSTR),DIMENSION(:),POINTER :: FIELD_NAME -! - CHARACTER(ESMF_MAXSTR*MAX_DATA_I1D),POINTER :: NAMES_I1D_STRING - CHARACTER(ESMF_MAXSTR*MAX_DATA_I2D),POINTER :: NAMES_I2D_STRING - CHARACTER(ESMF_MAXSTR*MAX_DATA_R1D),POINTER :: NAMES_R1D_STRING - CHARACTER(ESMF_MAXSTR*MAX_DATA_R2D),POINTER :: NAMES_R2D_STRING - CHARACTER(ESMF_MAXSTR*MAX_DATA_LOG),POINTER :: NAMES_LOG_STRING -! - LOGICAL, DIMENSION(:),POINTER :: ALL_DATA_LOG - -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Get this domain's VM (ESMF Virtual Machine) and the domain's -!*** MPI communicator so we can address all the tasks as needed. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="PRELIM_INFO_FOR_HISTORY: Get the Global VM" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! - CALL ESMF_VMGetCurrent(vm=VM_DOMAIN & !<-- The VM for all tasks on this domain - ,rc=RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_WRT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract the Communicator from the Global VM" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_VMGet(vm =VM_DOMAIN & - ,mpiCommunicator=COMM_MY_DOMAIN & !<-- The communicator for all tasks on this domain - ,localPet =MYPE_DOMAIN & !<-- Each task's full-domain rank - ,rc =RC ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_WRT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Let the forecast tasks do all the work they need to do first. -!*** While the number of Write components is equal to WRITE_GROUPS -!*** the contents of the internal state of each of those components -!*** is identical for the forecast tasks. The forecast tasks begin -!*** by extracting the internal state from the Write component for -!*** write group #1. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** NOTE: All the forecast tasks are part of ALL write groups -!*** while each write task belongs to only one of the write -!*** groups. In the work below the forecast tasks will -!*** fill all their relevant variables within the internal -!*** state of the Write component for write group #1 while -!*** providing the write tasks the quantities they need for -!*** the their variables within the internal state of the -!*** Write component associated for their particular write -!*** group. At the end of this subroutine the forecast -!*** tasks then need to set the same internal state variables -!*** for each of the other Write components with which they -!*** are associated. -!----------------------------------------------------------------------- -! - LAST_FCST_TASK=NUM_PES_FCST-1 !<-- The rank of the final forecast task -! -!----------------------------------------------------------------------- -! - fcst_tasks_1: IF(MYPE_DOMAIN<=LAST_FCST_TASK)THEN !<-- Select only the forecast tasks -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="PRELIM_INFO: Fcst Tasks Get the Write Internal State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGetInternalState(WRITE_COMPS(1) & - ,WRAP & - ,RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_WRT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - WRT_INT_STATE=>wrap%WRITE_INT_STATE !<-- Local working pointer to internal state -! -!----------------------------------------------------------------------- -!*** Extract the number of Write tasks in each group. -!----------------------------------------------------------------------- -! - NWTPG=wrt_int_state%WRITE_TASKS_PER_GROUP -! - ENDIF fcst_tasks_1 -! -!----------------------------------------------------------------------- -! - CALL MPI_BCAST(NWTPG & !<-- Broadcast the # of write tasks per group - ,1 & !<-- It is a scalar - ,MPI_INTEGER & !<-- It is an integer - ,0 & !<-- The lead forecast task broadcasts - ,COMM_MY_DOMAIN & !<-- The domain communicator - ,IERR) -! -!----------------------------------------------------------------------- -!*** The ranks of key forecast and write tasks. -!----------------------------------------------------------------------- -! - LEAD_WRITE_TASK(1)=LAST_FCST_TASK+1 !<-- The rank of the lead write task in group 1 - LAST_WRITE_TASK(1)=LAST_FCST_TASK+NWTPG !<-- The rank of the last write task in group 1 -! - IF(NUM_WRITE_GROUPS>=2)THEN - DO N=2,NUM_WRITE_GROUPS - LEAD_WRITE_TASK(N)=LEAD_WRITE_TASK(N-1)+NWTPG !<-- The rank of the lead write task in group N - LAST_WRITE_TASK(N)=LEAD_WRITE_TASK(N)+NWTPG-1 !<-- The rank of the final write task in group N - ENDDO - ENDIF -! -!----------------------------------------------------------------------- -!*** Now all the tasks in each Write group can extract the -!*** internal state from their respective Write component. -!----------------------------------------------------------------------- -! - DO N=1,NUM_WRITE_GROUPS -! - IF(MYPE_DOMAIN>=LEAD_WRITE_TASK(N).AND. & - MYPE_DOMAIN<=LAST_WRITE_TASK(N))THEN -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="PRELIM_INFO: Write Tasks Get the Write Internal State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGetInternalState(WRITE_COMPS(N) & - ,WRAP & - ,RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_WRT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - WRT_INT_STATE=>wrap%WRITE_INT_STATE !<-- Local working pointer to internal state -! - ENDIF -! - ENDDO -! -!----------------------------------------------------------------------- -!*** Now that all forecast and write tasks can see the internal state -!*** of their Write component, point the local working pointers at the -!*** appropriate components within the internal state depending upon -!*** whether we are preparing work for History or Restart output. -!*** In that way the following code can be used for both cases -!*** without a huge number of IF tests. -!----------------------------------------------------------------------- -! - CALL POINT_LOCAL -! -!----------------------------------------------------------------------- -! - ALLOCATE(INPES(1)) - ALLOCATE(JNPES(1)) - ALLOCATE(IHALO(1)) - ALLOCATE(JHALO(1)) - ALLOCATE(NCHAR_I2D(1)) - ALLOCATE(NCHAR_R2D(1)) -! -!----------------------------------------------------------------------- -!*** Extract the appropriate output Bundle from the Write component's -!*** import state and then from it extract the full domain limits. -!*** These are needed for allocating the working arrays that will -!*** move the 2-D and 3-D Fields from the import to the export state. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! - domain_limits: IF(MYPE_DOMAIN<=LAST_FCST_TASK)THEN !<-- This selects only forecast tasks to do extractions - ! since only they know what is in the import state. -!----------------------------------------------------------------------- -! - IF(OUTPUT_FLAG=='History')THEN - BUNDLE_NAME='History Bundle' - ELSEIF(OUTPUT_FLAG=='Restart')THEN - BUNDLE_NAME='Restart Bundle' - ENDIF -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract the History Bundle from the Write Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =IMP_STATE_WRITE & !<-- The Write component's import state - ,itemName =BUNDLE_NAME & !<-- The name of the data Bundle - ,fieldbundle=OUTPUT_BUNDLE & !<-- The data Bundle inside the import state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_WRT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Allocate the arrays that hold all start and end points in I,J -!*** for all forecast tasks. -!----------------------------------------------------------------------- -! - ALLOCATE(LOCAL_ISTART(0:LAST_FCST_TASK),stat=RC) - ALLOCATE(LOCAL_IEND (0:LAST_FCST_TASK),stat=RC) - ALLOCATE(LOCAL_JSTART(0:LAST_FCST_TASK),stat=RC) - ALLOCATE(LOCAL_JEND (0:LAST_FCST_TASK),stat=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Global Parameters from Output Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(FIELDBUNDLE=OUTPUT_BUNDLE & !<-- The Bundle of output data - ,name ='IM' & !<-- Name of the Attribute to extract - ,valueList =wrt_int_state%IM & !<-- Extract this Attribute from History Bundle - ,rc =RC) -! - CALL ESMF_AttributeGet(FIELDBUNDLE=OUTPUT_BUNDLE & !<-- The Bundle of output data - ,name ='JM' & !<-- Name of the Attribute to extract - ,valueList =wrt_int_state%JM & !<-- Extract this Attribute from History Bundle - ,rc =RC) -! - CALL ESMF_AttributeGet(FIELDBUNDLE=OUTPUT_BUNDLE & !<-- The Bundle of output data - ,name ='LM' & !<-- Name of the Attribute to extract - ,valueList =wrt_int_state%LM & !<-- Extract this Attribute from History Bundle - ,rc =RC) -! - CALL ESMF_AttributeGet(FIELDBUNDLE=OUTPUT_BUNDLE & !<-- The Bundle of output data - ,name ='GLOBAL' & !<-- Name of the Attribute to extract - ,value =wrt_int_state%GLOBAL & !<-- Extract this Attribute from History Bundle - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_WRT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(wrt_int_state%GLOBAL) THEN !<-- Increase lateral dimensions by 2 for global runs - wrt_int_state%IM(1)=wrt_int_state%IM(1)+2 - wrt_int_state%JM(1)=wrt_int_state%JM(1)+2 - ENDIF -! -!----------------------------------------------------------------------- -!*** Now extract local subdomain limits. -!*** These will be used to allocate the working array to hold fields -!*** on each subdomain prior to quilting them together. -!*** We first need the number of forecast tasks since that -!*** determines the size of the arrays holding the local -!*** subdomain limits. -! -!*** Also extract the halo depths since they are needed for -!*** excluding halo points from the final output data. -! -!*** These values are not to be written to the output files so -!*** they were not inserted into the data Bundles inside the -!*** Write component's import state. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Local Quilting Info from Write Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - - CALL ESMF_AttributeGet(state=IMP_STATE_WRITE & !<-- The Write component's import state - ,name ='INPES' & !<-- Name of the Attribute to extract - ,value=INPES(1) & !<-- Extract this Attribute from import state - ,rc =RC) -! - CALL ESMF_AttributeGet(state=IMP_STATE_WRITE & !<-- The Write component's import state - ,name ='JNPES' & !<-- Name of the Attribute to extract - ,value=JNPES(1) & !<-- Extract this Attribute from import state - ,rc =RC) -! - wrt_int_state%INPES=INPES(1) !<-- Place in internal state for later use - wrt_int_state%JNPES=JNPES(1) !<-- Place in internal state for later use -! - CALL ESMF_AttributeGet(state=IMP_STATE_WRITE & !<-- The Write component's import state - ,name ='IHALO' & !<-- Name of the Attribute to extract - ,value=IHALO(1) & !<-- Extract this Attribute from import state - ,rc =RC) -! - CALL ESMF_AttributeGet(state=IMP_STATE_WRITE & !<-- The Write component's import state - ,name ='JHALO' & !<-- Name of the Attribute to extract - ,value=JHALO(1) & !<-- Extract this Attribute from import state - ,rc =RC) -! - wrt_int_state%IHALO=IHALO(1) !<-- Place in internal state for later use - wrt_int_state%JHALO=JHALO(1) !<-- Place in internal state for later use -! - CALL ESMF_AttributeGet(state =IMP_STATE_WRITE & !<-- The Write component's import state - ,name ='LOCAL_ISTART' & !<-- Name of the Attribute to extract - ,valueList=LOCAL_ISTART & !<-- Extract local subdomain starting I's - ,itemCount=NUM_PES_FCST & !<-- Length of Attribute - ,rc =RC) -! - CALL ESMF_AttributeGet(state =IMP_STATE_WRITE & !<-- The Write component's import state - ,name ='LOCAL_IEND' & !<-- Name of the Attribute to extract - ,valueList= LOCAL_IEND & !<-- Extract local subdomain ending I's - ,itemCount=NUM_PES_FCST & !<-- Length of Attribute - ,rc =RC) -! - CALL ESMF_AttributeGet(state =IMP_STATE_WRITE & !<-- The Write component's import state - ,name ='LOCAL_JSTART' & !<-- Name of the Attribute to extract - ,valueList=LOCAL_JSTART & !<-- Extract local subdomain starting J's - ,itemCount=NUM_PES_FCST & !<-- Length of Attribute - ,rc =RC) -! - CALL ESMF_AttributeGet(state =IMP_STATE_WRITE & !<-- The Write component's import state - ,name ='LOCAL_JEND' & !<-- Name of the Attribute to extract - ,valueList=LOCAL_JEND & !<-- Extract local subdomain ending J's - ,itemCount=NUM_PES_FCST & !<-- Length of Attribute - ,rc =RC) - -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_WRT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DO N=0,LAST_FCST_TASK - wrt_int_state%LOCAL_ISTART(N)=LOCAL_ISTART(N) - wrt_int_state%LOCAL_IEND (N)=LOCAL_IEND(N) - wrt_int_state%LOCAL_JSTART(N)=LOCAL_JSTART(N) - wrt_int_state%LOCAL_JEND (N)=LOCAL_JEND(N) - ENDDO -! - ITS=LOCAL_ISTART(MYPE_DOMAIN) - ITE=LOCAL_IEND(MYPE_DOMAIN) - JTS=LOCAL_JSTART(MYPE_DOMAIN) - JTE=LOCAL_JEND(MYPE_DOMAIN) -! - DEALLOCATE(LOCAL_ISTART) - DEALLOCATE(LOCAL_IEND ) - DEALLOCATE(LOCAL_JSTART) - DEALLOCATE(LOCAL_JEND ) -! -!----------------------------------------------------------------------- -! - ENDIF domain_limits -! -!----------------------------------------------------------------------- -!*** Forecast task 0 sends the domain size information -!*** to the first Write task in each Write group because -!*** the Write tasks need to know this to assemble the -!*** final gridded data. -!----------------------------------------------------------------------- -! - n_groups_1: DO N=1,NUM_WRITE_GROUPS -! -!----------------------------------------------------------------------- -! - N1=LEAD_WRITE_TASK(N) - N2=LAST_WRITE_TASK(N) -! -!----------------------------------------------------------------------- -! -- IM -- -!----------------------------------------------------------------------- -! - IF(MYPE_DOMAIN==0)THEN !<-- Forecast task 0 sends - DO NN=N1,N2 - CALL MPI_SEND(wrt_int_state%IM & !<-- Send this data - ,1 & !<-- Number of words sent - ,MPI_INTEGER & !<-- Datatype - ,NN & !<-- Send to each of the write tasks (domain IDs) - ,0 & !<-- An MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,IERR) -! - IF(IERR/=0)WRITE(0,*)' Failed to send IM from fcst task 0 to write tasks' -! - ENDDO - ENDIF -! - IF(MYPE_DOMAIN>=N1.AND.MYPE_DOMAIN<=N2)THEN !<-- Write tasks in this group receive - CALL MPI_RECV(wrt_int_state%IM & !<-- Recv this data - ,1 & !<-- Words received - ,MPI_INTEGER & !<-- Datatype - ,0 & !<-- Recv from fcst task 0 - ,0 & !<-- An MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,JSTAT & !<-- MPI status object - ,IERR) -! - IF(IERR/=0)WRITE(0,*)' Write tasks failed to receive IM from fcst task0' -! - ENDIF -! -!----------------------------------------------------------------------- -! -- JM -- -!----------------------------------------------------------------------- -! - IF(MYPE_DOMAIN==0)THEN !<-- Forecast task 0 sends - DO NN=N1,N2 - CALL MPI_SEND(wrt_int_state%JM & !<-- Send this data - ,1 & !<-- Number of words sent - ,MPI_INTEGER & !<-- Datatype - ,NN & !<-- Send to each of the write tasks (local IDs) - ,0 & !<-- An MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,IERR) -! - IF(IERR/=0)WRITE(0,*)' Failed to send JM from fcst task0 to write tasks' -! - ENDDO - ENDIF -! - IF(MYPE_DOMAIN>=N1.AND.MYPE_DOMAIN<=N2)THEN !<-- Write tasks in this group receive - CALL MPI_RECV(wrt_int_state%JM & !<-- Recv this data - ,1 & !<-- Words received - ,MPI_INTEGER & !<-- Datatype - ,0 & !<-- Recv from fcst task 0 - ,0 & !<-- An MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,JSTAT & !<-- MPI status object - ,IERR) -! - IF(IERR/=0)WRITE(0,*)' Write tasks failed to receive JM from fcst task0' -! - ENDIF -! -!----------------------------------------------------------------------- -! -- LM -- -!----------------------------------------------------------------------- -! - IF(MYPE_DOMAIN==0)THEN !<-- Forecast task 0 sends - DO NN=N1,N2 - CALL MPI_SEND(wrt_int_state%LM & !<-- Send this data - ,1 & !<-- Number of words sent - ,MPI_INTEGER & !<-- Datatype - ,NN & !<-- Send to each of the write tasks (local IDs) - ,0 & !<-- An MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,IERR) -! - IF(IERR/=0)WRITE(0,*)' Failed to send LM from fcst task0 to write tasks' -! - ENDDO - ENDIF -! - IF(MYPE_DOMAIN>=N1.AND.MYPE_DOMAIN<=N2)THEN !<-- Write tasks in this group receive - CALL MPI_RECV(wrt_int_state%LM & !<-- Recv this data - ,1 & !<-- Words received - ,MPI_INTEGER & !<-- Datatype - ,0 & !<-- Recv from fcst task 0 - ,0 & !<-- An MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,JSTAT & !<-- MPI status object - ,IERR) -! - IF(IERR/=0)WRITE(0,*)' Write tasks failed to receive LM from fcst task0' -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO n_groups_1 -! -!----------------------------------------------------------------------- -! - IM=wrt_int_state%IM(1) - JM=wrt_int_state%JM(1) -! -!----------------------------------------------------------------------- -!*** The number of Attributes (for scalars and 1D arrays) and -!*** Fields (for gridded 2D arrays) in the Write component's -!*** import state are not known a priori. In order to transfer -!*** them to the Write tasks, extract the number of each of -!*** them along with their names. The scalars can be lumped in -!*** with the 1D arrays at this point. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** All integer quantities (as 1D arrays) and 1D and 2D real -!*** quantities will be strung together in single arrays of -!*** each particular type. Arrays that will hold the length of -!*** each of the quantities in these 'strings' were allocated -!*** in WRT_INIT. -!----------------------------------------------------------------------- -! - KOUNT_I1D_X=0 - KOUNT_R1D_X=0 - KOUNT_LOG_X=0 -! - LENGTH_SUM_I1D_X=0 - LENGTH_SUM_R1D_X=0 - LENGTH_SUM_LOG_X=0 -! - NCHAR_I1D=0 - NCHAR_R1D=0 - NCHAR_LOG=0 -! -!----------------------------------------------------------------------- -! - fcst_tasks_2: IF(MYPE_DOMAIN<=LAST_FCST_TASK)THEN !<-- Only forecast tasks will extract output information - ! from the import state because only they participated - ! in filling the import state in the Solver component. -! -!----------------------------------------------------------------------- -!*** First find the number of Attributes in the output data Bundle -!*** in the import state and then find their names, lengths, and -!*** datatypes. -!*** Extract the integer and real data and pack it into integer -!*** and real buffers. Later the buffers will be sent from the -!*** Forecast tasks (the only ones who can see the original -!*** data) to the write tasks. -! -!*** The fact that the Attribute output data is being collected -!*** here in a block that executes only once per Write group -!*** implies the assumption that only the 2D/3D data -!*** associated with the forecast grid can change with time. -!*** If any scalar/1D Attribute data change with time then -!*** this must be moved out of this routine and into the Run step. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Attribute Count from "//BUNDLE_NAME -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(FIELDBUNDLE=OUTPUT_BUNDLE & !<-- The write component's history data Bundle - ,count =NUM_ATTRIB & !<-- # of Attributes in the history data Bundle - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_WRT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- - attribute_loop: DO N=1,NUM_ATTRIB !<-- Loop through all the Attributes -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Attribute Names, Datatypes, Lengths" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(FIELDBUNDLE =OUTPUT_BUNDLE & !<-- The write component's history data Bundle - ,attributeIndex=N & !<-- Index of each Attribute - ,name =ATTRIB_NAME & !<-- Each Attribute's name - ,typekind =DATATYPE & !<-- Each Attribute's ESMF Datatype - ,itemCount =LENGTH & !<-- Each Attribute's length - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_WRT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -- Scalar and 1-D Integer Output Data -- -!----------------------------------------------------------------------- -! - IF(DATATYPE==ESMF_TYPEKIND_I4)THEN !<-- Extract integer data with rank <2 -! - ALLOCATE(WORK_ARRAY_I1D(LENGTH),stat=RC) !<-- This length is from the preceding call -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Scalar/1-D Integer Data from "//BUNDLE_NAME -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(FIELDBUNDLE=OUTPUT_BUNDLE & !<-- The write component's history data Bundle - ,name =ATTRIB_NAME & !<-- Name of the Attribute to extract - ,itemCount =LENGTH & !<-- Length of Attribute - ,valueList =WORK_ARRAY_I1D & !<-- Place the Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_WRT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - KOUNT_I1D_X=KOUNT_I1D_X+1 !<-- Count # of integer Attributes -! - NPOSN_END=KOUNT_I1D_X*ESMF_MAXSTR - NPOSN_START=NPOSN_END-ESMF_MAXSTR+1 - NCHAR_I1D=NCHAR_I1D+ESMF_MAXSTR !<-- Save #of characters in all scalar/1D integer names. - ! Note that each name is being given - ! EMSF_MAXSTR total spaces. -! - DO L=1,LENGTH - ALL_DATA_I1D(LENGTH_SUM_I1D_X+L)=WORK_ARRAY_I1D(L) !<-- String together the integer data - ENDDO -! - LENGTH_SUM_I1D_X=LENGTH_SUM_I1D_X+LENGTH !<-- Total word sum of scalar/1D integer data -! - NAMES_I1D_STRING(NPOSN_START:NPOSN_END)=ATTRIB_NAME !<-- Save the 1D integer names - LENGTH_DATA_I1D(KOUNT_I1D_X)=LENGTH !<-- Store length of each individual integer variable -! - DEALLOCATE(WORK_ARRAY_I1D) -! -!----------------------------------------------------------------------- -! -- Scalar and 1-D Real Output Data -- -!----------------------------------------------------------------------- -! - ELSEIF(DATATYPE==ESMF_TYPEKIND_R4)THEN ! <-- Extract real data with rank <2 as Attributes -! - ALLOCATE(WORK_ARRAY_R1D(LENGTH),stat=RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Scalar/1-D Real Data from "//BUNDLE_NAME -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(FIELDBUNDLE=OUTPUT_BUNDLE & !<-- The write component's history data Bundle - ,name =ATTRIB_NAME & !<-- Name of the Attribute to extract - ,itemCount =LENGTH & !<-- Length of Attribute - ,valueList =WORK_ARRAY_R1D & !<-- Place the Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_WRT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - KOUNT_R1D_X=KOUNT_R1D_X+1 !<-- Count # of real Attributes -! - NPOSN_END=KOUNT_R1D_X*ESMF_MAXSTR - NPOSN_START=NPOSN_END-ESMF_MAXSTR+1 - NCHAR_R1D=NCHAR_R1D+ESMF_MAXSTR !<-- Save #of characters in all scalar/1D real names - ! Note that each name is being given - ! EMSF_MAXSTR total spaces -! - DO L=1,LENGTH - ALL_DATA_R1D(LENGTH_SUM_R1D_X+L)=WORK_ARRAY_R1D(L) !<-- String together the real data - ENDDO -! - LENGTH_SUM_R1D_X=LENGTH_SUM_R1D_X+LENGTH !<-- Total word sum of scalar/1D real data -! - NAMES_R1D_STRING(NPOSN_START:NPOSN_END)=ATTRIB_NAME !<-- Save the scalar/1D real names - LENGTH_DATA_R1D(KOUNT_R1D_X)=LENGTH !<-- Store length of each individual real variable -! - DEALLOCATE(WORK_ARRAY_R1D) -! -!----------------------------------------------------------------------- -! -- Logical Data -- -!----------------------------------------------------------------------- -! -!ratko ELSEIF(DATATYPE==ESMF_DATA_LOGICAL)THEN ! <-- Extract logical data -! --- nothing else than I4 and R4; should FIX later - ELSE -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Logical Data from "//BUNDLE_NAME -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(FIELDBUNDLE=OUTPUT_BUNDLE & !<-- The write component's history data Bundle - ,name =ATTRIB_NAME & !<-- Name of the Attribute to extract - ,value =WORK_LOGICAL & !<-- Place the Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_WRT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - KOUNT_LOG_X=KOUNT_LOG_X+1 !<-- Count # of logical Attributes -! - NPOSN_END=KOUNT_LOG_X*ESMF_MAXSTR - NPOSN_START=NPOSN_END-ESMF_MAXSTR+1 - NCHAR_LOG=NCHAR_LOG+ESMF_MAXSTR !<-- Save #of characters in all logical names - ! Note that each name is being given - ! EMSF_MAXSTR total spaces -! - LENGTH_SUM_LOG_X=LENGTH_SUM_LOG_X+1 !<-- Total length of all logical data variables -! - NAMES_LOG_STRING(NPOSN_START:NPOSN_END)=ATTRIB_NAME !<-- Save the logical names -! - ALL_DATA_LOG(KOUNT_LOG_X)=WORK_LOGICAL !<-- String together the logical data -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO attribute_loop -! -!----------------------------------------------------------------------- -!*** Insert number and lengths of scalar/1D integer and real quantities -!*** and logicals into the Write component's internal state. -!----------------------------------------------------------------------- -! - KOUNT_I1D(1)=KOUNT_I1D_X - KOUNT_R1D(1)=KOUNT_R1D_X - KOUNT_LOG(1)=KOUNT_LOG_X -! - LENGTH_SUM_I1D(1)=LENGTH_SUM_I1D_X - LENGTH_SUM_R1D(1)=LENGTH_SUM_R1D_X - LENGTH_SUM_LOG(1)=LENGTH_SUM_LOG_X -! -!----------------------------------------------------------------------- -!*** Now extract the number of ESMF Fields in the output data Bundle -!*** along with their names. Save the Field information of the 2-D -!*** data since it will be needed for extraction from the import -!*** state and the transfer to the write tasks. -!*** Then extract the names of all the Fields in the bundle. -!*** Also, the number of Field names returned should equal -!*** the Field count in the preceding call. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Field Count from "//BUNDLE_NAME -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleGet( OUTPUT_BUNDLE & !<-- The write component's data Bundle - ,fieldCount=NCOUNT_FIELDS(1) & !<-- Get total # of Fields in the data Bundle - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_WRT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Field Names from "//BUNDLE_NAME -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleGet( OUTPUT_BUNDLE & !<-- The write component's data Bundle - ,fieldNameList=FIELD_NAME & !<-- Array of ESMF Field names in the Bundle - ,fieldCount =NUM_FIELD_NAMES & !<-- Number of Field names in the Bundle - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_WRT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - IF(NUM_FIELD_NAMES/=NCOUNT_FIELDS(1))THEN - WRITE(0,*)' WARNING: Number of Fields in '//BUNDLE_NAME & - ,' output does not equal the number of Field names' - WRITE(0,*)' They are ',NUM_FIELD_NAMES,' and ' & - ,NCOUNT_FIELDS(1),', respectively' - ENDIF -! -!----------------------------------------------------------------------- -!*** Do a preliminary extraction of the Fields themselves in order to -!*** count the number of real and integer 2D arrays. -!----------------------------------------------------------------------- -! - KOUNT_R2D_X=0 - KOUNT_I2D_X=0 - NCHAR_I2D(1)=0 - NCHAR_R2D(1)=0 -! - DO N=1,NCOUNT_FIELDS(1) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Extract Fields from Output Bundle for Counting" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE=OUTPUT_BUNDLE & !<-- The write component's data Bundle - ,fieldName =FIELD_NAME(N) & !<-- The ESMF Field's name - ,field =FIELD_WORK1 & !<-- The ESMF Field taken from the Bundle - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_WRT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Datatype of Fields for Counting Real/Integer" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldGet(field =FIELD_WORK1 & !<-- The ESMF 2D Field - ,typekind=DATATYPE & !<-- The Field's ESMF Datatype - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_WRT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(DATATYPE==ESMF_TYPEKIND_I4)THEN - KOUNT_I2D_X=KOUNT_I2D_X+1 !<-- Add up the total number of integer 2D Fields -! - IF(KOUNT_I2D_X>MAX_DATA_I2D)THEN - WRITE(0,*)' FATAL: YOU HAVE EXCEEDED MAX NUMBER OF INTEGER 2D FIELDS FOR OUTPUT' - WRITE(0,*)' YOU MUST INCREASE VALUE OF MAX_DATA_I2D WHICH NOW EQUALS ',MAX_DATA_I2D - ENDIF -! - NPOSN_END =KOUNT_I2D_X*ESMF_MAXSTR - NPOSN_START=NPOSN_END-ESMF_MAXSTR+1 - NAMES_I2D_STRING(NPOSN_START:NPOSN_END)=FIELD_NAME(N) !<-- Save the 2D integer Field names - ! in one long string. - NCHAR_I2D(1)=NCHAR_I2D(1)+ESMF_MAXSTR -! - ELSEIF(DATATYPE==ESMF_TYPEKIND_R4)THEN - KOUNT_R2D_X=KOUNT_R2D_X+1 !<-- Add up the total number of real 2D Fields -! - IF(KOUNT_R2D_X>MAX_DATA_R2D)THEN - WRITE(0,*)' FATAL: YOU HAVE EXCEEDED MAX NUMBER OF REAL 2D FIELDS FOR OUTPUT' - WRITE(0,*)' YOU MUST INCREASE VALUE OF MAX_DATA_R2D WHICH NOW EQUALS ',MAX_DATA_R2D - CALL ESMF_Finalize(endflag=ESMF_END_ABORT & - ,rc =RC ) - ENDIF -! - NPOSN_END =KOUNT_R2D_X*ESMF_MAXSTR - NPOSN_START=NPOSN_END-ESMF_MAXSTR+1 - NAMES_R2D_STRING(NPOSN_START:NPOSN_END)=FIELD_NAME(N) !<-- Save the 2D real Field names - ! in one long string. - NCHAR_R2D(1)=NCHAR_R2D(1)+ESMF_MAXSTR -! - ENDIF -! - ENDDO -! - KOUNT_R2D(1)=KOUNT_R2D_X - KOUNT_I2D(1)=KOUNT_I2D_X -! -!----------------------------------------------------------------------- -!*** Compute the total number of words for all 2D and 3D real data -!*** and allocate a datastring to that length. It will transfer -!*** the 2D/3D real data from forecast to Write tasks. -!----------------------------------------------------------------------- -! - NUM_WORDS_TOT=(ITE-ITS+1+2*IHALO(1))*(JTE-JTS+1+2*JHALO(1)) & - *KOUNT_R2D_X -! - IF(NUM_WORDS_TOT>2147483647)THEN - WRITE(0,*)' You have TOO MANY words in your datastring.' - WRITE(0,*)' You must increase the number of tasks.' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT & - ,rc =RC ) - ELSE - NUM_WORDS_SEND_R2D=NUM_WORDS_TOT - NUM_WORDS=NUM_WORDS_SEND_R2D -! - IF(OUTPUT_FLAG=='History')THEN - IF(.NOT.ASSOCIATED(wrt_int_state%ALL_DATA_R2D))THEN - ALLOCATE(wrt_int_state%ALL_DATA_R2D(NUM_WORDS),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Fcst task FAILED to allocate ALL_DATA_R2D' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT & - ,rc =RC ) - ENDIF - ALL_DATA_R2D=>wrt_int_state%ALL_DATA_R2D - ENDIF -! - ELSEIF(OUTPUT_FLAG=='Restart')THEN - IF(.NOT.ASSOCIATED(wrt_int_state%RST_ALL_DATA_R2D))THEN - ALLOCATE(wrt_int_state%RST_ALL_DATA_R2D(NUM_WORDS),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Fcst task FAILED to allocate RST_ALL_DATA_R2D' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT & - ,rc =RC ) - ENDIF - ALL_DATA_R2D=>wrt_int_state%RST_ALL_DATA_R2D - ENDIF -! - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Likewise for 2D integer data. -!----------------------------------------------------------------------- -! - NUM_WORDS_TOT=(ITE-ITS+1+2*IHALO(1))*(JTE-JTS+1+2*JHALO(1)) & - *KOUNT_I2D_X -! - IF(NUM_WORDS_TOT>2147483647)THEN - WRITE(0,*)' You have TOO MANY words in your datastring.' - WRITE(0,*)' You must increase the number of tasks.' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT & - ,rc =RC ) - ELSE - NUM_WORDS_SEND_I2D=NUM_WORDS_TOT - NUM_WORDS=NUM_WORDS_SEND_I2D -! - IF(OUTPUT_FLAG=='History')THEN - IF(.NOT.ASSOCIATED(wrt_int_state%ALL_DATA_I2D))THEN - ALLOCATE(wrt_int_state%ALL_DATA_I2D(NUM_WORDS),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Fcst task FAILED to allocate ALL_DATA_I2D' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT & - ,rc =RC ) - ENDIF - ALL_DATA_I2D=>wrt_int_state%ALL_DATA_I2D - ENDIF -! - ELSEIF(OUTPUT_FLAG=='Restart')THEN - IF(.NOT.ASSOCIATED(wrt_int_state%RST_ALL_DATA_I2D))THEN - ALLOCATE(wrt_int_state%RST_ALL_DATA_I2D(NUM_WORDS),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Fcst task FAILED to allocate RST_ALL_DATA_I2D' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT & - ,rc =RC ) - ENDIF - ALL_DATA_I2D=>wrt_int_state%RST_ALL_DATA_I2D - ENDIF -! - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDIF fcst_tasks_2 -! -!----------------------------------------------------------------------- -!*** If there are no quantities specified for history output, -!*** forecast task 0 will inform the write tasks and then -!*** everyone will return. -!----------------------------------------------------------------------- -! - NO_FIELDS=.FALSE. -! -!----------------------------------------------------------------------- - n_groups_2: DO N=1,NUM_WRITE_GROUPS -!----------------------------------------------------------------------- -! - N1=LEAD_WRITE_TASK(N) !<-- The lead write task in group N - N2=LAST_WRITE_TASK(N) !<-- The last write task in group N -! - IF(MYPE_DOMAIN==0)THEN - IF(NCOUNT_FIELDS(1)==0)NO_FIELDS=.TRUE. !<-- Reset flag saying there are no history quantities -! - DO NN=N1,N2 !<-- Loop through all the write tasks in the write group -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Fcst Task0 Informs All That There Are No Fields" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL MPI_SEND(NO_FIELDS & !<-- Send flag that there is no history data - ,1 & !<-- The flag is a scalar - ,MPI_LOGICAL & !<-- The flag is logical - ,NN & !<-- Receiving task in write group N - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,IERR ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_WRT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDDO -! - ENDIF -! - IF(MYPE_DOMAIN>=N1.AND.MYPE_DOMAIN<=N2)THEN !<-- All write tasks in this group receive -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Write Tasks Told By Fcst Task0 There Are No Fields" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL MPI_RECV(NO_FIELDS & !<-- Recv flag that there is no history data - ,1 & !<-- The flag is a scalar - ,MPI_LOGICAL & !<-- The flag is logicallar - ,0 & !<-- Sending task (forecast task 0) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_WRT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! - ENDDO n_groups_2 -! -!----------------------------------------------------------------------- -! - IF(NO_FIELDS)THEN - IF(MYPE_DOMAIN==0)THEN - WRITE(6,*)'WARNING: No Import ESMF quantities for the Write Component' - WRITE(0,*)'WARNING: No Import ESMF quantities for the Write Component' - ENDIF -! - RETURN !<-- All tasks return if there is no history output -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Forecast task 0 sends all the write tasks the number of -!*** real and integer 2D gridded quantities plus all of the -!*** local horizontal domain limits in preparation for the -!*** Write tasks' receiving and assembling the local history -!*** data they receive from the Forecast tasks. -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- - n_groups_3: DO N=1,NUM_WRITE_GROUPS -!----------------------------------------------------------------------- -! - N1=LEAD_WRITE_TASK(N) - N2=LAST_WRITE_TASK(N) -! -!----------------------------------------------------------------------- -! - task_0: IF(MYPE_DOMAIN==0)THEN !<-- Forecast task 0 sends -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Fcst Task0 Sends Write Tasks Info for Quilting" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DO NN=N1,N2 !<-- Loop through all the write tasks in the write group -! - CALL MPI_SEND(INPES & !<-- Send # of fcst tasks in I - ,1 & !<-- Number is one word - ,MPI_INTEGER & !<-- Data is integer - ,NN & !<-- Receiving task in active write group - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,IERR ) -! - CALL MPI_SEND(JNPES & !<-- Send # of fcst tasks in J - ,1 & !<-- Number is one word - ,MPI_INTEGER & !<-- Data is integer - ,NN & !<-- Receiving task in active write group - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,IERR ) -! - CALL MPI_SEND(IHALO & !<-- Send # of points in the east-west halo - ,1 & !<-- Number is one word - ,MPI_INTEGER & !<-- Data is integer - ,NN & !<-- Receiving task in active write group - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,IERR ) -! - CALL MPI_SEND(JHALO & !<-- Send # of points in the south-north halo - ,1 & !<-- Number is one word - ,MPI_INTEGER & !<-- Data is integer - ,NN & !<-- Receiving task in active write group - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,IERR ) -! - CALL MPI_SEND(NCOUNT_FIELDS & !<-- Send # of Fields in history data - ,1 & !<-- Number is one word - ,MPI_INTEGER & !<-- Data is integer - ,NN & !<-- Receiving task in active write group - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,IERR ) -! - CALL MPI_SEND(KOUNT_R2D & !<-- Send # of real Fields in history data - ,1 & !<-- Number is one word - ,MPI_INTEGER & !<-- Data is integer - ,NN & !<-- Receiving task in active write group - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,IERR ) -! - CALL MPI_SEND(KOUNT_I2D & !<-- Send # of integer Fields in history data - ,1 & !<-- Number is one word - ,MPI_INTEGER & !<-- Data is integer - ,NN & !<-- Receiving task in active write group - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,IERR ) -! - CALL MPI_SEND(wrt_int_state%LOCAL_ISTART & !<-- Send starting I for all fcst task subdomains - ,NUM_PES_FCST & !<-- Number of words - ,MPI_INTEGER & !<-- Data is integer - ,NN & !<-- Receiving task in active write group - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,IERR ) -! - CALL MPI_SEND(wrt_int_state%LOCAL_IEND & !<-- Send ending I for all fcst task subdomains - ,NUM_PES_FCST & !<-- Number of words - ,MPI_INTEGER & !<-- Data is integer - ,NN & !<-- Receiving task in active write group - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,IERR ) -! - CALL MPI_SEND(wrt_int_state%LOCAL_JSTART & !<-- Send starting J for all fcst task subdomains - ,NUM_PES_FCST & !<-- Number of words - ,MPI_INTEGER & !<-- Data is integer - ,NN & !<-- Receiving task in active write group - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,IERR ) -! - CALL MPI_SEND(wrt_int_state%LOCAL_JEND & !<-- Send starting J for all fcst task subdomains - ,NUM_PES_FCST & !<-- Number of words - ,MPI_INTEGER & !<-- Data is integer - ,NN & !<-- Receiving task in active write group - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,IERR ) -! - ENDDO -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_WRT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Fcst Task0 Sends Lead Write Task # of BC Words" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL MPI_SEND(wrt_int_state%NUM_WORDS_SEND_BC & !<-- Send # of words in BC data - ,1 & !<-- Send one word - ,MPI_INTEGER & !<-- Data is integer - ,N1 & !<-- Receiving task in active write group - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,IERR ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_WRT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! - ENDIF task_0 -! -!----------------------------------------------------------------------- -! -! - IF(MYPE_DOMAIN>=N1.AND.MYPE_DOMAIN<=N2)THEN !<-- All write tasks in this group receive -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Write Tasks Recv Quilting Info From Fcst Task0" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL MPI_RECV(INPES & !<-- Recv # of fcst tasks in I - ,1 & !<-- Data is a scalar - ,MPI_INTEGER & !<-- Data is integer - ,0 & !<-- Sending task (forecast task 0) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - CALL MPI_RECV(JNPES & !<-- Recv # of fcst tasks in J - ,1 & !<-- Data is a scalar - ,MPI_INTEGER & !<-- Data is integer - ,0 & !<-- Sending task (forecast task 0) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - CALL MPI_RECV(IHALO & !<-- Recv width of halo in I - ,1 & !<-- Data is a scalar - ,MPI_INTEGER & !<-- Data is integer - ,0 & !<-- Sending task (forecast task 0) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - CALL MPI_RECV(JHALO & !<-- Recv width of halo in J - ,1 & !<-- Data is a scalar - ,MPI_INTEGER & !<-- Data is integer - ,0 & !<-- Sending task (forecast task 0) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - wrt_int_state%IHALO=IHALO(1) - wrt_int_state%JHALO=JHALO(1) -! - CALL MPI_RECV(NCOUNT_FIELDS & !<-- Recv # of Fields in history data - ,1 & !<-- Data is a scalar - ,MPI_INTEGER & !<-- Data is integer - ,0 & !<-- Sending task (forecast task 0) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - CALL MPI_RECV(KOUNT_R2D & !<-- Recv # of real Fields in history data - ,1 & !<-- Data is a scalar - ,MPI_INTEGER & !<-- Data is integer - ,0 & !<-- Sending task (forecast task 0) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - CALL MPI_RECV(KOUNT_I2D & !<-- Recv # of integer Fields in history data - ,1 & !<-- Data is a scalar - ,MPI_INTEGER & !<-- Data is integer - ,0 & !<-- Sending task (forecast task 0) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - CALL MPI_RECV(wrt_int_state%LOCAL_ISTART & !<-- Recv starting I of each fcst task subdomain - ,NUM_PES_FCST & !<-- # of words in data - ,MPI_INTEGER & !<-- Data is integer - ,0 & !<-- Sending task (forecast task 0) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - CALL MPI_RECV(wrt_int_state%LOCAL_IEND & !<-- Recv ending I of each fcst task subdomain - ,NUM_PES_FCST & !<-- # of words in data - ,MPI_INTEGER & !<-- Data is integer - ,0 & !<-- Sending task (forecast task 0) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - CALL MPI_RECV(wrt_int_state%LOCAL_JSTART & !<-- Recv starting J of each fcst task subdomain - ,NUM_PES_FCST & !<-- # of words in data - ,MPI_INTEGER & !<-- Data is integer - ,0 & !<-- Sending task (forecast task 0) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - CALL MPI_RECV(wrt_int_state%LOCAL_JEND & !<-- Recv ending J of each fcst task subdomain - ,NUM_PES_FCST & !<-- # of words in data - ,MPI_INTEGER & !<-- Data is integer - ,0 & !<-- Sending task (forecast task 0) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_WRT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(MYPE_DOMAIN==N1)THEN !<-- Lead write task in each group must recv BC word count -! - IF(ALLOCATED(wrt_int_state%NUM_WORDS_SEND_BC))THEN -! write(0,*)' PRELIM_INFO wrt_int_state%NUM_WORDS_SEND_BC already allocated for write group ',n - ELSE -! WRITE(0,*)' PRELIM_INFO must allocate wrt_int_state%NUM_WORDS_SEND_BC' - ALLOCATE(wrt_int_state%NUM_WORDS_SEND_BC(1),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate wrt_int_state%NUM_WORDS_SEND_BC in PRELIM_INFO' - ENDIF - ENDIF -! - CALL MPI_RECV(wrt_int_state%NUM_WORDS_SEND_BC & !<-- Recv # of BC words - ,1 & !<-- Data is a scalar - ,MPI_INTEGER & !<-- Data is integer - ,0 & !<-- Sending task (forecast task 0) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - IF(ALLOCATED(wrt_int_state%RST_ALL_BC_DATA))THEN -! WRITE(0,*)' PRELIM_INFO wrt_int_state%RST_ALL_BC_DATA already allocated for write group ',n - ELSE -! WRITE(0,*)' PRELIM_INFO must allocate wrt_int_state%RST_ALL_BC_DATA' - ALLOCATE(wrt_int_state%RST_ALL_BC_DATA(1:wrt_int_state%NUM_WORDS_SEND_BC(1)),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Failed to allocate wrt_int_state%wrt_int_state%RST_ALL_BC_DATA in PRELIM_INFO' - ENDIF - ENDIF -! - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Forecast task 0 sends the 2D data names to the lead Write task. -!----------------------------------------------------------------------- -! - IF(MYPE_DOMAIN==0)THEN !<-- Fcst task 0 sends data names -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Fcst Task0 Sends Lead Write Task 2D Data Names" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL MPI_SEND(NCHAR_I2D & !<-- Send total length of the names of 2D integer data - ,1 & !<-- Words sent - ,MPI_INTEGER & !<-- Data is integer - ,N1 & !<-- Receiving task (lead write task in group) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,IERR ) -! - CALL MPI_SEND(NAMES_I2D_STRING & !<-- Send names of 2D integer history variables - ,NCHAR_I2D(1) & !<-- Words sent - ,MPI_CHARACTER & !<-- Data is character - ,N1 & !<-- Receiving task (lead write task in group) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,IERR ) -! - CALL MPI_SEND(NCHAR_R2D & !<-- Send total length of the names of 2D real data - ,1 & !<-- Words sent - ,MPI_INTEGER & !<-- Data is integer - ,N1 & !<-- Receiving task (lead write task in group) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,IERR ) -! - CALL MPI_SEND(NAMES_R2D_STRING & !<-- Send names of 2D real history variables - ,NCHAR_R2D(1) & !<-- Words sent - ,MPI_CHARACTER & !<-- Data is character - ,N1 & !<-- Receiving task (lead write task in group) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,IERR ) -! - ELSEIF(MYPE_DOMAIN==N1)THEN !<-- Lead write task receives 2D preliminary info -! - CALL MPI_RECV(NCHAR_I2D & !<-- Recv total length of the names of 2D integer data - ,1 & !<-- Words sent - ,MPI_INTEGER & !<-- Data is integer - ,0 & !<-- Sending task (lead fcst task) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - CALL MPI_RECV(NAMES_I2D_STRING & !<-- Recv names of 2D integer history variables - ,NCHAR_I2D(1) & !<-- Words sent - ,MPI_CHARACTER & !<-- Data is character - ,0 & !<-- Sending task (lead fcst task) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - CALL MPI_RECV(NCHAR_R2D & !<-- Recv total length of the names of 2D real data - ,1 & !<-- Words sent - ,MPI_INTEGER & !<-- Data is integer - ,0 & !<-- Sending task (lead fcst task) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - CALL MPI_RECV(NAMES_R2D_STRING & !<-- Recv names of 2D real history variables - ,NCHAR_R2D(1) & !<-- Words sent - ,MPI_CHARACTER & !<-- Data is character - ,0 & !<-- Sending task (lead fcst task) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_WRT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Each Write task must know the IDs of the Forecast tasks -!*** from which it will receive 2D gridded history data. -!----------------------------------------------------------------------- -! - IF(MYPE_DOMAIN>=N1.AND.MYPE_DOMAIN<=N2)THEN !<-- The write tasks -! - M1=LEAD_WRITE_TASK(1) !<-- Local rank of lead write task - M2=LAST_WRITE_TASK(1) !<-- Local rank of last write task - LOCAL_ID=M1+MYPE_DOMAIN-LEAD_WRITE_TASK(N) !<-- Local rank of every write task -! - IF(.NOT.ALLOCATED(wrt_int_state%ID_FTASK_RECV_STA))THEN - ALLOCATE(wrt_int_state%ID_FTASK_RECV_STA(M1:M2)) - ALLOCATE(wrt_int_state%ID_FTASK_RECV_END(M1:M2)) - ENDIF -! - NY=0 - DO NX=M1,M2 - NY=NY+1 - CALL PARA_RANGE(JNPES(1),NWTPG,NY & !<-- Find each write task's first and last rows of - ,JROW_FIRST,JROW_LAST) ! fcst tasks from which it will recv. -! - wrt_int_state%ID_FTASK_RECV_STA(NX)=(JROW_FIRST-1)*INPES(1) !<-- First fcst task that sends to this write task - wrt_int_state%ID_FTASK_RECV_END(NX)=JROW_LAST*INPES(1)-1 !<-- Last fcst task that sends to this write task - ENDDO -! -!----------------------------------------------------------------------- -!*** Each write task computes the number of words in the datastring -!*** of 2D/3D real history data it will receive from each Forecast -!*** task it is associated with. Then allocate that datastring. -!----------------------------------------------------------------------- -! - IF(OUTPUT_FLAG=='History')THEN - IF(.NOT.ASSOCIATED(wrt_int_state%NUM_WORDS_RECV_R2D_HST))THEN - N_STA=wrt_int_state%ID_FTASK_RECV_STA(LOCAL_ID) - N_END=wrt_int_state%ID_FTASK_RECV_END(LOCAL_ID) - ALLOCATE(wrt_int_state%NUM_WORDS_RECV_R2D_HST(N_STA:N_END)) - NUM_WORDS_RECV_R2D=>wrt_int_state%NUM_WORDS_RECV_R2D_HST - ENDIF -! - ELSEIF(OUTPUT_FLAG=='Restart')THEN - IF(.NOT.ASSOCIATED(wrt_int_state%NUM_WORDS_RECV_R2D_RST))THEN - N_STA=wrt_int_state%ID_FTASK_RECV_STA(LOCAL_ID) - N_END=wrt_int_state%ID_FTASK_RECV_END(LOCAL_ID) - ALLOCATE(wrt_int_state%NUM_WORDS_RECV_R2D_RST(N_STA:N_END)) - NUM_WORDS_RECV_R2D=>wrt_int_state%NUM_WORDS_RECV_R2D_RST - ENDIF -! - ENDIF -! - MAX_WORDS=0 -! - DO NX=wrt_int_state%ID_FTASK_RECV_STA(LOCAL_ID) & !<-- The fcst tasks sending to this write task - ,wrt_int_state%ID_FTASK_RECV_END(LOCAL_ID) !<-- -! - ITS=wrt_int_state%LOCAL_ISTART(NX) - ITE=wrt_int_state%LOCAL_IEND (NX) - JTS=wrt_int_state%LOCAL_JSTART(NX) - JTE=wrt_int_state%LOCAL_JEND (NX) -! - NUM_WORDS_TOT=(ITE-ITS+1+2*IHALO(1))*(JTE-JTS+1+2*JHALO(1)) & !<-- # of words of 2D/3D real history data from fcst task NX - *KOUNT_R2D(1) -! - NUM_WORDS_RECV_R2D(NX)=NUM_WORDS_TOT - MAX_WORDS=MAX(MAX_WORDS & !<-- Max # of integer words from any fcst tasks - ,NUM_WORDS_RECV_R2D(NX)) ! - ENDDO -! - IF(OUTPUT_FLAG=='History')THEN - IF(.NOT.ASSOCIATED(wrt_int_state%ALL_DATA_R2D))THEN - ALLOCATE(wrt_int_state%ALL_DATA_R2D(MAX_WORDS),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Write task FAILED to allocate ALL_DATA_R2D' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT & - ,rc =RC ) - ENDIF - ALL_DATA_R2D=>wrt_int_state%ALL_DATA_R2D - ENDIF -! - ELSEIF(OUTPUT_FLAG=='Restart')THEN - IF(.NOT.ASSOCIATED(wrt_int_state%RST_ALL_DATA_R2D))THEN - ALLOCATE(wrt_int_state%RST_ALL_DATA_R2D(MAX_WORDS),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Write task FAILED to allocate RST_ALL_DATA_R2D' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT & - ,rc =RC ) - ENDIF - ALL_DATA_R2D=>wrt_int_state%RST_ALL_DATA_R2D - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Likewise for the 2-D integer data. -!----------------------------------------------------------------------- -! - N_STA=wrt_int_state%ID_FTASK_RECV_STA(LOCAL_ID) - N_END=wrt_int_state%ID_FTASK_RECV_END(LOCAL_ID) -! - IF(OUTPUT_FLAG=='History')THEN - IF(.NOT.ASSOCIATED(wrt_int_state%NUM_WORDS_RECV_I2D_HST))THEN - ALLOCATE(wrt_int_state%NUM_WORDS_RECV_I2D_HST(N_STA:N_END)) - NUM_WORDS_RECV_I2D=>wrt_int_state%NUM_WORDS_RECV_I2D_HST - ENDIF - ELSEIF(OUTPUT_FLAG=='Restart')THEN - IF(.NOT.ASSOCIATED(wrt_int_state%NUM_WORDS_RECV_I2D_RST))THEN - ALLOCATE(wrt_int_state%NUM_WORDS_RECV_I2D_RST(N_STA:N_END)) - NUM_WORDS_RECV_I2D=>wrt_int_state%NUM_WORDS_RECV_I2D_RST - ENDIF - ENDIF -! - MAX_WORDS=0 -! - DO NX=wrt_int_state%ID_FTASK_RECV_STA(LOCAL_ID) & !<-- The fcst tasks sending to this write task - ,wrt_int_state%ID_FTASK_RECV_END(LOCAL_ID) ! -! - ITS=wrt_int_state%LOCAL_ISTART(NX) - ITE=wrt_int_state%LOCAL_IEND (NX) - JTS=wrt_int_state%LOCAL_JSTART(NX) - JTE=wrt_int_state%LOCAL_JEND (NX) -! - NUM_WORDS_TOT=(ITE-ITS+1+2*IHALO(1))*(JTE-JTS+1+2*JHALO(1)) & !<-- # of words of 2D integer history data from fcst task NX - *KOUNT_I2D(1) -! - NUM_WORDS_RECV_I2D(NX)=NUM_WORDS_TOT - MAX_WORDS=MAX(MAX_WORDS & !<-- Max # of real words from all fcst tasks - ,NUM_WORDS_RECV_I2D(NX)) ! - ENDDO -! - IF(OUTPUT_FLAG=='History')THEN - IF(.NOT.ASSOCIATED(wrt_int_state%ALL_DATA_I2D))THEN - ALLOCATE(wrt_int_state%ALL_DATA_I2D(MAX_WORDS),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Write task FAILED to allocate ALL_DATA_I2D' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT & - ,rc =RC ) - ENDIF - ALL_DATA_I2D=>wrt_int_state%ALL_DATA_I2D - ENDIF -! - ELSEIF(OUTPUT_FLAG=='Restart')THEN - IF(.NOT.ASSOCIATED(wrt_int_state%RST_ALL_DATA_I2D))THEN - ALLOCATE(wrt_int_state%RST_ALL_DATA_I2D(MAX_WORDS),stat=ISTAT) - IF(ISTAT/=0)THEN - WRITE(0,*)' Write task FAILED to allocate RST_ALL_DATA_I2D' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT & - ,rc =RC ) - ENDIF - ALL_DATA_I2D=>wrt_int_state%RST_ALL_DATA_I2D - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Each Write task also must know the North-South extent of the -!*** full 2D domain that it will handle. This is determined by -!*** the coverage of the Fcst tasks that send to it. -!----------------------------------------------------------------------- -! - JSTA_WRITE=wrt_int_state%LOCAL_JSTART(wrt_int_state%ID_FTASK_RECV_STA(LOCAL_ID)) !<-- JTS/JTE of the first fcst task - JEND_WRITE=wrt_int_state%LOCAL_JEND (wrt_int_state%ID_FTASK_RECV_END(LOCAL_ID)) ! that sends to this write task. -! -!----------------------------------------------------------------------- -!*** Now each Write task allocates its own section of the 2D domain -!*** for all the 2D variables it will receive and its 1D equivalent -!*** used to transfer the data to the lead Write task. -!----------------------------------------------------------------------- -! - LENGTH=IM*(JEND_WRITE-JSTA_WRITE+1) -! - IF(OUTPUT_FLAG=='History')THEN -! - ALLOCATE(wrt_int_state%WRITE_SUBSET_I(1:IM,JSTA_WRITE:JEND_WRITE & - ,KOUNT_I2D(1))) - ALLOCATE(wrt_int_state%BUFF_INT(LENGTH)) - WRITE_SUBSET_I=>wrt_int_state%WRITE_SUBSET_I - BUFF_INT=>wrt_int_state%BUFF_INT -! - ALLOCATE(wrt_int_state%WRITE_SUBSET_R(1:IM,JSTA_WRITE:JEND_WRITE & - ,KOUNT_R2D(1))) - ALLOCATE(wrt_int_state%BUFF_REAL(LENGTH)) - WRITE_SUBSET_R=>wrt_int_state%WRITE_SUBSET_R - BUFF_REAL=>wrt_int_state%BUFF_REAL -! - ELSEIF(OUTPUT_FLAG=='Restart')THEN -! - ALLOCATE(wrt_int_state%RST_WRITE_SUBSET_I(1:IM,JSTA_WRITE:JEND_WRITE & - ,KOUNT_I2D(1))) - ALLOCATE(wrt_int_state%RST_BUFF_INT(LENGTH)) - WRITE_SUBSET_I=>wrt_int_state%RST_WRITE_SUBSET_I - BUFF_INT=>wrt_int_state%RST_BUFF_INT -! - ALLOCATE(wrt_int_state%RST_WRITE_SUBSET_R(1:IM,JSTA_WRITE:JEND_WRITE & - ,KOUNT_R2D(1))) - ALLOCATE(wrt_int_state%RST_BUFF_REAL(LENGTH)) - WRITE_SUBSET_R=>wrt_int_state%RST_WRITE_SUBSET_R - BUFF_REAL=>wrt_int_state%RST_BUFF_REAL -! - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** The lead write task allocates its working arrays into which -!*** it will assemble each individual 2D field that will be -!*** written to the history files. -!----------------------------------------------------------------------- -! - IF(MYPE_DOMAIN==LEAD_WRITE_TASK(N))THEN -! - IF(OUTPUT_FLAG=='History')THEN - ALLOCATE(wrt_int_state%OUTPUT_ARRAY_I2D(1:IM,1:JM)) - ALLOCATE(wrt_int_state%OUTPUT_ARRAY_R2D(1:IM,1:JM)) - OUTPUT_ARRAY_I2D=>wrt_int_state%OUTPUT_ARRAY_I2D - OUTPUT_ARRAY_R2D=>wrt_int_state%OUTPUT_ARRAY_R2D -! - ELSEIF(OUTPUT_FLAG=='Restart')THEN - ALLOCATE(wrt_int_state%RST_OUTPUT_ARRAY_I2D(1:IM,1:JM)) - ALLOCATE(wrt_int_state%RST_OUTPUT_ARRAY_R2D(1:IM,1:JM)) - OUTPUT_ARRAY_I2D=>wrt_int_state%RST_OUTPUT_ARRAY_I2D - OUTPUT_ARRAY_R2D=>wrt_int_state%RST_OUTPUT_ARRAY_R2D -! - ENDIF -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Since all scalar/1D data is identical on all forecast tasks, -!*** task 0 alone can send the information to the lead write task -!*** that will later write it to the history file. -!-------------------------------------------------------------------- -! -!-------------------------------------------------------------------- - task_0_sends: IF(MYPE_DOMAIN==0)THEN !<-- Forecast task 0 sends -!-------------------------------------------------------------------- -! -!------------------------------------------------ -!*** Send scalar/1D integer history information. -!------------------------------------------------ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Fcst Task0 Sends Scalar/1D Integer History Data" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL MPI_SEND(KOUNT_I1D & !<-- Send # of scalar/1D integer history variables - ,1 & !<-- Words sent - ,MPI_INTEGER & !<-- Data is integer - ,LEAD_WRITE_TASK(N) & !<-- Receiving task (1st write task in group) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain communicator - ,IERR ) -! - CALL MPI_SEND(LENGTH_SUM_I1D & !<-- Send length of string of all such integer history variables - ,1 & !<-- Words sent - ,MPI_INTEGER & !<-- Data is integer - ,LEAD_WRITE_TASK(N) & !<-- Receiving task (1st write task in group) -! ,0 & !<-- MPI tag - ,678 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain commumicator - ,IERR ) -! - CALL MPI_SEND(LENGTH_DATA_I1D & !<-- Send lengths of each scalar/1D integer history variable - ,KOUNT_I1D(1) & !<-- Words sent - ,MPI_INTEGER & !<-- Data is integer - ,LEAD_WRITE_TASK(N) & !<-- Receiving task (1st write task in group) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain commumicator - ,IERR ) -! - CALL MPI_SEND(NAMES_I1D_STRING & !<-- Send names of each scalar/1D integer history variable - ,NCHAR_I1D & !<-- Words sent - ,MPI_CHARACTER & !<-- Words are character - ,LEAD_WRITE_TASK(N) & !<-- Receiving task (1st write task in group) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain commumicator - ,IERR ) -! - CALL MPI_SEND(ALL_DATA_I1D & !<-- Send the full string of all scalar/1D integer history data - ,LENGTH_SUM_I1D(1) & !<-- Words sent - ,MPI_INTEGER & !<-- Data is integer - ,LEAD_WRITE_TASK(N) & !<-- Receiving task (1st write task in group) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain commumicator - ,IERR ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_WRT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!--------------------------------------------- -!*** Send scalar/1D real history information. -!--------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Fcst Task 0 Sends Scalar/1D Real History Data" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL MPI_SEND(KOUNT_R1D & !<-- Send # of scalar/1D real history variables - ,1 & !<-- Words sent - ,MPI_INTEGER & !<-- Data is integer - ,LEAD_WRITE_TASK(N) & !<-- Receiving task (1st write task in group) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain commumicator - ,IERR ) -! - CALL MPI_SEND(LENGTH_SUM_R1D & !<-- Send length of string of all such real history variables - ,1 & !<-- Words sent - ,MPI_INTEGER & !<-- Data is integer - ,LEAD_WRITE_TASK(N) & !<-- Receiving task (1st write task in group) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain commumicator - ,IERR ) -! - CALL MPI_SEND(LENGTH_DATA_R1D & !<-- Send lengths of each scalar/1D real history variable - ,KOUNT_R1D(1) & !<-- Words sent - ,MPI_INTEGER & !<-- Data is integer - ,LEAD_WRITE_TASK(N) & !<-- Receiving task (1st write task in group) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain commumicator - ,IERR ) -! - CALL MPI_SEND(NAMES_R1D_STRING & !<-- Send names of each scalar/1D real history variable - ,NCHAR_R1D & !<-- Words sent - ,MPI_CHARACTER & !<-- Words are character - ,LEAD_WRITE_TASK(N) & !<-- Receiving task (1st write task in group) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain commumicator - ,IERR ) -! - CALL MPI_SEND(ALL_DATA_R1D & !<-- Send the full string of all scalar/1D real history data - ,LENGTH_SUM_R1D(1) & !<-- Words sent - ,MPI_REAL & !<-- Words are real - ,LEAD_WRITE_TASK(N) & !<-- Receiving task (1st write task in group) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain commumicator - ,IERR ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_WRT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!-------------------------------------- -!*** Send logical history information. -!-------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Fcst Task0 Sends Logical History Data" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL MPI_SEND(KOUNT_LOG & !<-- Send # of logical history variables - ,1 & !<-- Words sent - ,MPI_INTEGER & !<-- Data is integer - ,LEAD_WRITE_TASK(N) & !<-- Receiving task (1st write task in group) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain commumicator - ,IERR ) -! - CALL MPI_SEND(LENGTH_SUM_LOG & !<-- Send length of string of all logical variables - ,1 & !<-- Words sent - ,MPI_INTEGER & !<-- Data is integer - ,LEAD_WRITE_TASK(N) & !<-- Receiving task (1st write task in group) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain commumicator - ,IERR ) -! - CALL MPI_SEND(NAMES_LOG_STRING & !<-- Send names of each logical history variable - ,NCHAR_LOG & !<-- Words sent - ,MPI_CHARACTER & !<-- Data is character - ,LEAD_WRITE_TASK(N) & !<-- Receiving task (1st write task in group) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain commumicator - ,IERR ) -! - CALL MPI_SEND(ALL_DATA_LOG & !<-- Send the full string of all logical history data - ,LENGTH_SUM_LOG(1) & !<-- Words sent - ,MPI_LOGICAL & !<-- Data is logical - ,LEAD_WRITE_TASK(N) & !<-- Receiving task (1st write task in group) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain commumicator - ,IERR ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_WRT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- - ENDIF task_0_sends -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! - write_task_recvs: IF(MYPE_DOMAIN==LEAD_WRITE_TASK(N))THEN !<-- 1st write task in this group receives - ! all of the data just sent to it by - ! fcst task 0. -!----------------------------------------------------------------------- -!*** Receive scalar/1D integer history information -!*** from Forecast task 0. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Write Tasks Recv Scalar/1D Integer History Data" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL MPI_RECV(KOUNT_I1D & !<-- Recv # of scalar/1D integer history variables - ,1 & !<-- Words received - ,MPI_INTEGER & !<-- Data is integer - ,0 & !<-- Sending task (lead fcst task) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain commumicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - CALL MPI_RECV(LENGTH_SUM_I1D & !<-- Recv length of string of all such integer history variables - ,1 & !<-- Words received - ,MPI_INTEGER & !<-- Data is integer - ,0 & !<-- Sending task (lead fcst task) - ,678 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain commumicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - CALL MPI_RECV(LENGTH_DATA_I1D & !<-- Recv lengths of each scalar/1D integer history variable - ,KOUNT_I1D(1) & !<-- Words received - ,MPI_INTEGER & !<-- Data is integer - ,0 & !<-- Sending task (lead fcst task) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain commumicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - NCHAR_I1D=KOUNT_I1D(1)*ESMF_MAXSTR -! - CALL MPI_RECV(NAMES_I1D_STRING & !<-- Recv names of each scalar/1D integer history variable - ,NCHAR_I1D & !<-- Words received - ,MPI_CHARACTER & !<-- Words are character - ,0 & !<-- Sending task (lead fcst task) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain commumicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - CALL MPI_RECV(ALL_DATA_I1D & !<-- Recv the full string of all scalar/1D integer history data - ,LENGTH_SUM_I1D(1) & !<-- Words received - ,MPI_INTEGER & !<-- Data is integer - ,0 & !<-- Sending task (lead fcst task) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain commumicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_WRT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Receive scalar/1D real history information. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Write Tasks Recv Scalar/1D Real History Data" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL MPI_RECV(KOUNT_R1D & !<-- Recv # of scalar/1D real history variables - ,1 & !<-- Words received - ,MPI_INTEGER & !<-- Data is integer - ,0 & !<-- Sending task (lead fcst task) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain commumicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - CALL MPI_RECV(LENGTH_SUM_R1D & !<-- Recv length of string of all such real history variables - ,1 & !<-- Words received - ,MPI_INTEGER & !<-- Data is integer - ,0 & !<-- Sending task (lead fcst task) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain commumicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - CALL MPI_RECV(LENGTH_DATA_R1D & !<-- Recv lengths of each scalar/1D real history variable - ,KOUNT_R1D(1) & !<-- Words received - ,MPI_INTEGER & !<-- Data is integer - ,0 & !<-- Sending task (lead fcst task) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain commumicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - NCHAR_R1D=KOUNT_R1D(1)*ESMF_MAXSTR - CALL MPI_RECV(NAMES_R1D_STRING & !<-- Recv names of scalar/1D real history variables - ,NCHAR_R1D & !<-- Words received - ,MPI_CHARACTER & !<-- Data is character - ,0 & !<-- Sending task (lead fcst task) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain commumicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - CALL MPI_RECV(ALL_DATA_R1D & !<-- Recv the string of all scalar/1D real history data - ,LENGTH_SUM_R1D(1) & !<-- Words received - ,MPI_REAL & !<-- Data is real - ,0 & !<-- Sending task (lead fcst task) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain commumicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_WRT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Receive logical history information. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Write Tasks Recv Logical Real History Data" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL MPI_RECV(KOUNT_LOG & !<-- Recv # of logical history variables - ,1 & !<-- Words received - ,MPI_INTEGER & !<-- Data is integer - ,0 & !<-- Sending task (lead fcst task) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain commumicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - CALL MPI_RECV(LENGTH_SUM_LOG & !<-- Recv length of string of all logical history variables - ,1 & !<-- Words received - ,MPI_INTEGER & !<-- Data is integer - ,0 & !<-- Sending task (lead fcst task) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain commumicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - NCHAR_LOG=KOUNT_LOG(1)*ESMF_MAXSTR - CALL MPI_RECV(NAMES_LOG_STRING & !<-- Recv names of logical history variables - ,NCHAR_LOG & !<-- Words received - ,MPI_CHARACTER & !<-- Data is character - ,0 & !<-- Sending task (lead fcst task) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain commumicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! - CALL MPI_RECV(ALL_DATA_LOG & !<-- Recv the string of all logical history data - ,LENGTH_SUM_LOG(1) & !<-- Words received - ,MPI_LOGICAL & !<-- Data is logical - ,0 & !<-- Sending task (lead fcst task) - ,0 & !<-- MPI tag - ,COMM_MY_DOMAIN & !<-- MPI domain commumicator - ,JSTAT & !<-- MPI status object - ,IERR ) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_WRT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! - ENDIF write_task_recvs -! -!----------------------------------------------------------------------- -! - ENDDO n_groups_3 -! -!----------------------------------------------------------------------- -!*** When run post on quilt, all the write tasks need to know the -!*** variables in history bundle that first forecast task sent to -!*** lead write tasks. -!----------------------------------------------------------------------- -! - IF(WRT_INT_STATE%WRITE_DOPOST.and.OUTPUT_FLAG=='History')THEN -! - n_groups_4: DO N=1,NUM_WRITE_GROUPS -!----------------------------------------------------------------------- -! - N1=LEAD_WRITE_TASK(N) - N2=LAST_WRITE_TASK(N) -! - IF(MYPE_DOMAIN>=N1.AND.MYPE_DOMAIN<=N2)THEN - -! write(0,*)'bf broadcast NCHAR_I2D' - CALL MPI_BCAST(NCHAR_I2D,1,MPI_INTEGER,0,MPI_COMM_COMP,IERR) -! write(0,*)'af broadcast NCHAR_I2D=',NCHAR_I2D - CALL MPI_BCAST(NAMES_I2D_STRING,NCHAR_I2D(1),MPI_CHARACTER,0, & - MPI_COMM_COMP,IERR) -! write(0,*)'af broadcast NAMES_I2D_STRING=',NAMES_I2D_STRING(1:30) - CALL MPI_BCAST(NCHAR_R2D,1,MPI_INTEGER,0,MPI_COMM_COMP,IERR) -! write(0,*)'af broadcast NCHAR_R2D=',NCHAR_R2D - CALL MPI_BCAST(NAMES_R2D_STRING,NCHAR_R2D(1),MPI_CHARACTER,0, & - MPI_COMM_COMP,IERR) -!integer - CALL MPI_BCAST(KOUNT_I1D,1,MPI_INTEGER,0,MPI_COMM_COMP,IERR) - CALL MPI_BCAST(LENGTH_SUM_I1D,1,MPI_INTEGER,0,MPI_COMM_COMP, & - IERR) -! write(0,*)'af broadcast LENGTH_SUM_I1D=',LENGTH_SUM_I1D(1) - CALL MPI_BCAST(LENGTH_DATA_I1D,KOUNT_I1D(1),MPI_INTEGER,0, & - MPI_COMM_COMP,IERR) -! write(0,*)'af broadcast LENGTH_DATA_I1D=',LENGTH_DATA_I1D(1) - NCHAR_I1D=KOUNT_I1D(1)*ESMF_MAXSTR - CALL MPI_BCAST(NAMES_I1D_STRING,NCHAR_I1D,MPI_CHARACTER,0, & - MPI_COMM_COMP,IERR) -! write(0,*)'af broadcast NAMES_I1D_STRING=',NAMES_I1D_STRING(1:30) - CALL MPI_BCAST(ALL_DATA_I1D,LENGTH_SUM_I1D(1),MPI_LOGICAL,0, & - MPI_COMM_COMP,IERR) -! write(0,*)'af broadcast ALL_DATA_I1D=',ALL_DATA_I1D(1:5) -!real - CALL MPI_BCAST(KOUNT_R1D,1,MPI_INTEGER,0,MPI_COMM_COMP,IERR) -! write(0,*)'af broadcast NCHAR_R1D=',KOUNT_R1D - CALL MPI_BCAST(LENGTH_SUM_R1D,1,MPI_INTEGER,0,MPI_COMM_COMP, & - IERR) - CALL MPI_BCAST(LENGTH_DATA_R1D,KOUNT_R1D(1),MPI_INTEGER,0, & - MPI_COMM_COMP,IERR) - NCHAR_R1D=KOUNT_R1D(1)*ESMF_MAXSTR - CALL MPI_BCAST(NAMES_R1D_STRING,NCHAR_R1D,MPI_CHARACTER,0, & - MPI_COMM_COMP,IERR) - CALL MPI_BCAST(ALL_DATA_R1D,LENGTH_SUM_R1D(1),MPI_LOGICAL,0, & - MPI_COMM_COMP,IERR) -!logical - CALL MPI_BCAST(KOUNT_LOG,1,MPI_INTEGER,0,MPI_COMM_COMP,IERR) -! write(0,*)'af broadcast NCHAR_LOG=',KOUNT_LOG - CALL MPI_BCAST(LENGTH_SUM_LOG,1,MPI_INTEGER,0,MPI_COMM_COMP, & - IERR) - NCHAR_LOG=KOUNT_LOG(1)*ESMF_MAXSTR - CALL MPI_BCAST(NAMES_LOG_STRING,NCHAR_LOG,MPI_CHARACTER,0, & - MPI_COMM_COMP,IERR) - CALL MPI_BCAST(ALL_DATA_LOG,LENGTH_SUM_LOG(1),MPI_LOGICAL,0, & - MPI_COMM_COMP,IERR) -! - ENDIF -! - ENDDO n_groups_4 -! - ENDIF -! -!----------------------------------------------------------------------- -! - DEALLOCATE(INPES) - DEALLOCATE(JNPES) - DEALLOCATE(IHALO) - DEALLOCATE(JHALO) - DEALLOCATE(NCHAR_I2D) - DEALLOCATE(NCHAR_R2D) -! -!----------------------------------------------------------------------- -!*** All the write tasks now have everything they need with respect to -!*** the nature of the data they will be writing out whenever their -!*** particular write group is invoked. However for the forecast -!*** tasks only the variables in the internal state of the Write -!*** component associated with write group #1 have been filled. -!*** So now the write tasks fill those same variables in each of -!*** the other internal states of the Write components associated -!*** with the remaining write groups. -!----------------------------------------------------------------------- -! - IF(MYPE_DOMAIN<=LAST_FCST_TASK & !<-- Select only the forecast tasks - .AND. & - NUM_WRITE_GROUPS>1)THEN !<-- Variables in write group #1 already done -! -!----------------------------------------------------------------------- -! - ALLOCATE(WRT_INT_STATE_X(2:NUM_WRITE_GROUPS),stat=RC) !<-- Allocate working array of internal states -! - IF(RC/=0)THEN - WRITE(0,*)' Failed to allocate working array of' & - ,' internal state pointers!' - WRITE(0,*)' ABORT!' - CALL ESMF_Finalize(endflag=ESMF_END_ABORT & - ,rc =RC ) - ENDIF -! -!----------------------------------------------------------------------- -! - DO N=2,NUM_WRITE_GROUPS !<-- Loop through remaining write groups -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="PRELIM_INFO: Fcst Tasks Get Nth Write Internal State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGetInternalState(WRITE_COMPS(N) & - ,WRAP & - ,RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_WRT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - WRT_INT_STATE_X(N)%LOC_INT_STATE=>wrap%WRITE_INT_STATE !<-- Pointer to internal state of Nth Write component -! -!----------------------------------------------------------------------- -! - CALL FILL_GROUP_STATES !<-- Fill variables in internal state N from state #1 -! -!----------------------------------------------------------------------- -! - ENDDO -! - DEALLOCATE(WRT_INT_STATE_X) -! - ENDIF -! -!----------------------------------------------------------------------- -! - CONTAINS -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - SUBROUTINE POINT_LOCAL -! -!----------------------------------------------------------------------- -! - IF(OUTPUT_FLAG=='History')THEN -! - ALLOCATE(wrt_int_state%NUM_WORDS_SEND_I2D_HST) - ALLOCATE(wrt_int_state%NUM_WORDS_SEND_R2D_HST) - ALLOCATE(wrt_int_state%FIELD_NAME(1:5000)) - ALLOCATE(wrt_int_state%NAMES_I1D_STRING) - ALLOCATE(wrt_int_state%NAMES_I2D_STRING) - ALLOCATE(wrt_int_state%NAMES_R1D_STRING) - ALLOCATE(wrt_int_state%NAMES_R2D_STRING) - ALLOCATE(wrt_int_state%NAMES_LOG_STRING) -! - NUM_WORDS_SEND_I2D=>wrt_int_state%NUM_WORDS_SEND_I2D_HST - NUM_WORDS_SEND_R2D=>wrt_int_state%NUM_WORDS_SEND_R2D_HST - KOUNT_I1D=>wrt_int_state%KOUNT_I1D - KOUNT_I2D=>wrt_int_state%KOUNT_I2D - KOUNT_R1D=>wrt_int_state%KOUNT_R1D - KOUNT_R2D=>wrt_int_state%KOUNT_R2D - KOUNT_LOG=>wrt_int_state%KOUNT_LOG - LENGTH_DATA_I1D=>wrt_int_state%LENGTH_DATA_I1D - LENGTH_DATA_R1D=>wrt_int_state%LENGTH_DATA_R1D - LENGTH_DATA_R2D=>wrt_int_state%LENGTH_DATA_R2D - LENGTH_SUM_I1D=>wrt_int_state%LENGTH_SUM_I1D - LENGTH_SUM_R1D=>wrt_int_state%LENGTH_SUM_R1D - LENGTH_SUM_R2D=>wrt_int_state%LENGTH_SUM_R2D - LENGTH_SUM_LOG=>wrt_int_state%LENGTH_SUM_LOG - NCOUNT_FIELDS=>wrt_int_state%NCOUNT_FIELDS - ALL_DATA_I1D=>wrt_int_state%ALL_DATA_I1D - ALL_DATA_R1D=>wrt_int_state%ALL_DATA_R1D - FIELD_NAME=>wrt_int_state%FIELD_NAME - NAMES_I1D_STRING=>wrt_int_state%NAMES_I1D_STRING - NAMES_I2D_STRING=>wrt_int_state%NAMES_I2D_STRING - NAMES_R1D_STRING=>wrt_int_state%NAMES_R1D_STRING - NAMES_R2D_STRING=>wrt_int_state%NAMES_R2D_STRING - NAMES_LOG_STRING=>wrt_int_state%NAMES_LOG_STRING - ALL_DATA_LOG=>wrt_int_state%ALL_DATA_LOG -! - ELSEIF(OUTPUT_FLAG=='Restart')THEN -! - ALLOCATE(wrt_int_state%NUM_WORDS_SEND_I2D_RST) - ALLOCATE(wrt_int_state%NUM_WORDS_SEND_R2D_RST) - ALLOCATE(wrt_int_state%RST_FIELD_NAME(1:5000)) - ALLOCATE(wrt_int_state%RST_NAMES_I1D_STRING) - ALLOCATE(wrt_int_state%RST_NAMES_I2D_STRING) - ALLOCATE(wrt_int_state%RST_NAMES_R1D_STRING) - ALLOCATE(wrt_int_state%RST_NAMES_R2D_STRING) - ALLOCATE(wrt_int_state%RST_NAMES_LOG_STRING) -! - NUM_WORDS_SEND_I2D=>wrt_int_state%NUM_WORDS_SEND_I2D_RST - NUM_WORDS_SEND_R2D=>wrt_int_state%NUM_WORDS_SEND_R2D_RST - KOUNT_I1D=>wrt_int_state%RST_KOUNT_I1D - KOUNT_I2D=>wrt_int_state%RST_KOUNT_I2D - KOUNT_R1D=>wrt_int_state%RST_KOUNT_R1D - KOUNT_R2D=>wrt_int_state%RST_KOUNT_R2D - KOUNT_LOG=>wrt_int_state%RST_KOUNT_LOG - LENGTH_DATA_I1D=>wrt_int_state%RST_LENGTH_DATA_I1D - LENGTH_DATA_R1D=>wrt_int_state%RST_LENGTH_DATA_R1D - LENGTH_DATA_R2D=>wrt_int_state%RST_LENGTH_DATA_R2D - LENGTH_SUM_I1D=>wrt_int_state%RST_LENGTH_SUM_I1D - LENGTH_SUM_R1D=>wrt_int_state%RST_LENGTH_SUM_R1D - LENGTH_SUM_R2D=>wrt_int_state%RST_LENGTH_SUM_R2D - LENGTH_SUM_LOG=>wrt_int_state%RST_LENGTH_SUM_LOG - NCOUNT_FIELDS=>wrt_int_state%RST_NCOUNT_FIELDS - ALL_DATA_I1D=>wrt_int_state%RST_ALL_DATA_I1D - ALL_DATA_R1D=>wrt_int_state%RST_ALL_DATA_R1D - FIELD_NAME=>wrt_int_state%RST_FIELD_NAME - NAMES_I1D_STRING=>wrt_int_state%RST_NAMES_I1D_STRING - NAMES_I2D_STRING=>wrt_int_state%RST_NAMES_I2D_STRING - NAMES_R1D_STRING=>wrt_int_state%RST_NAMES_R1D_STRING - NAMES_R2D_STRING=>wrt_int_state%RST_NAMES_R2D_STRING - NAMES_LOG_STRING=>wrt_int_state%RST_NAMES_LOG_STRING - ALL_DATA_LOG=>wrt_int_state%RST_ALL_DATA_LOG -! - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE POINT_LOCAL -! -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -! - SUBROUTINE FILL_GROUP_STATES -! -!----------------------------------------------------------------------- -! - IF(OUTPUT_FLAG=='History')THEN -! - ALLOCATE(wrt_int_state_x(N)%loc_int_state%NUM_WORDS_SEND_I2D_HST) - ALLOCATE(wrt_int_state_x(N)%loc_int_state%NUM_WORDS_SEND_R2D_HST) - ALLOCATE(wrt_int_state_x(N)%loc_int_state%FIELD_NAME(1:5000)) - ALLOCATE(wrt_int_state_x(N)%loc_int_state%NAMES_I1D_STRING) - ALLOCATE(wrt_int_state_x(N)%loc_int_state%NAMES_I2D_STRING) - ALLOCATE(wrt_int_state_x(N)%loc_int_state%NAMES_R1D_STRING) - ALLOCATE(wrt_int_state_x(N)%loc_int_state%NAMES_R2D_STRING) - ALLOCATE(wrt_int_state_x(N)%loc_int_state%NAMES_LOG_STRING) - ALLOCATE(wrt_int_state_x(N)%loc_int_state%ALL_DATA_I2D(wrt_int_state%NUM_WORDS_SEND_I2D_HST),stat=ISTAT) - ALLOCATE(wrt_int_state_x(N)%loc_int_state%ALL_DATA_R2D(wrt_int_state%NUM_WORDS_SEND_R2D_HST),stat=ISTAT) -! - wrt_int_state_x(N)%loc_int_state%INPES=wrt_int_state%INPES - wrt_int_state_x(N)%loc_int_state%JNPES=wrt_int_state%JNPES - wrt_int_state_x(N)%loc_int_state%IHALO=wrt_int_state%IHALO - wrt_int_state_x(N)%loc_int_state%JHALO=wrt_int_state%JHALO - wrt_int_state_x(N)%loc_int_state%NUM_WORDS_SEND_I2D_HST=wrt_int_state%NUM_WORDS_SEND_I2D_HST - wrt_int_state_x(N)%loc_int_state%NUM_WORDS_SEND_R2D_HST=wrt_int_state%NUM_WORDS_SEND_R2D_HST - wrt_int_state_x(N)%loc_int_state%KOUNT_I1D=wrt_int_state%KOUNT_I1D - wrt_int_state_x(N)%loc_int_state%KOUNT_I2D=wrt_int_state%KOUNT_I2D - wrt_int_state_x(N)%loc_int_state%KOUNT_R1D=wrt_int_state%KOUNT_R1D - wrt_int_state_x(N)%loc_int_state%KOUNT_R2D=wrt_int_state%KOUNT_R2D - wrt_int_state_x(N)%loc_int_state%KOUNT_LOG=wrt_int_state%KOUNT_LOG - wrt_int_state_x(N)%loc_int_state%LENGTH_DATA_I1D=wrt_int_state%LENGTH_DATA_I1D - wrt_int_state_x(N)%loc_int_state%LENGTH_DATA_R1D=wrt_int_state%LENGTH_DATA_R1D -! wrt_int_state_x(N)%loc_int_state%LENGTH_DATA_R2D=wrt_int_state%LENGTH_DATA_R2D - wrt_int_state_x(N)%loc_int_state%LENGTH_SUM_I1D=wrt_int_state%LENGTH_SUM_I1D - wrt_int_state_x(N)%loc_int_state%LENGTH_SUM_R1D=wrt_int_state%LENGTH_SUM_R1D -! wrt_int_state_x(N)%loc_int_state%LENGTH_SUM_R2D=wrt_int_state%LENGTH_SUM_R2D - wrt_int_state_x(N)%loc_int_state%LENGTH_SUM_LOG=wrt_int_state%LENGTH_SUM_LOG - wrt_int_state_x(N)%loc_int_state%NCOUNT_FIELDS=wrt_int_state%NCOUNT_FIELDS - wrt_int_state_x(N)%loc_int_state%ALL_DATA_I1D=wrt_int_state%ALL_DATA_I1D - wrt_int_state_x(N)%loc_int_state%ALL_DATA_R1D=wrt_int_state%ALL_DATA_R1D - wrt_int_state_x(N)%loc_int_state%FIELD_NAME=wrt_int_state%FIELD_NAME - wrt_int_state_x(N)%loc_int_state%NAMES_I1D_STRING=wrt_int_state%NAMES_I1D_STRING - wrt_int_state_x(N)%loc_int_state%NAMES_I2D_STRING=wrt_int_state%NAMES_I2D_STRING - wrt_int_state_x(N)%loc_int_state%NAMES_R1D_STRING=wrt_int_state%NAMES_R1D_STRING - wrt_int_state_x(N)%loc_int_state%NAMES_R2D_STRING=wrt_int_state%NAMES_R2D_STRING - wrt_int_state_x(N)%loc_int_state%NAMES_LOG_STRING=wrt_int_state%NAMES_LOG_STRING - wrt_int_state_x(N)%loc_int_state%ALL_DATA_LOG=wrt_int_state%ALL_DATA_LOG -! - DO NN=0,LAST_FCST_TASK - wrt_int_state_x(N)%loc_int_state%LOCAL_ISTART(NN)=wrt_int_state%LOCAL_ISTART(NN) - wrt_int_state_x(N)%loc_int_state%LOCAL_IEND(NN)=wrt_int_state%LOCAL_IEND(NN) - wrt_int_state_x(N)%loc_int_state%LOCAL_JSTART(NN)=wrt_int_state%LOCAL_JSTART(NN) - wrt_int_state_x(N)%loc_int_state%LOCAL_JEND(NN)=wrt_int_state%LOCAL_JEND(NN) - ENDDO -! - ELSEIF(OUTPUT_FLAG=='Restart')THEN -! - wrt_int_state_x(N)%loc_int_state%INPES=wrt_int_state%INPES - wrt_int_state_x(N)%loc_int_state%JNPES=wrt_int_state%JNPES - wrt_int_state_x(N)%loc_int_state%IHALO=wrt_int_state%IHALO - wrt_int_state_x(N)%loc_int_state%JHALO=wrt_int_state%JHALO - ALLOCATE(wrt_int_state_x(N)%loc_int_state%NUM_WORDS_SEND_I2D_RST) - ALLOCATE(wrt_int_state_x(N)%loc_int_state%NUM_WORDS_SEND_R2D_RST) - ALLOCATE(wrt_int_state_x(N)%loc_int_state%RST_FIELD_NAME(1:5000)) - ALLOCATE(wrt_int_state_x(N)%loc_int_state%RST_NAMES_I1D_STRING) - ALLOCATE(wrt_int_state_x(N)%loc_int_state%RST_NAMES_I2D_STRING) - ALLOCATE(wrt_int_state_x(N)%loc_int_state%RST_NAMES_R1D_STRING) - ALLOCATE(wrt_int_state_x(N)%loc_int_state%RST_NAMES_R2D_STRING) - ALLOCATE(wrt_int_state_x(N)%loc_int_state%RST_NAMES_LOG_STRING) - ALLOCATE(wrt_int_state_x(N)%loc_int_state%RST_ALL_DATA_I2D(wrt_int_state%NUM_WORDS_SEND_I2D_RST),stat=ISTAT) - ALLOCATE(wrt_int_state_x(N)%loc_int_state%RST_ALL_DATA_R2D(wrt_int_state%NUM_WORDS_SEND_R2D_RST),stat=ISTAT) -! - wrt_int_state_x(N)%loc_int_state%NUM_WORDS_SEND_I2D_RST=wrt_int_state%NUM_WORDS_SEND_I2D_RST - wrt_int_state_x(N)%loc_int_state%NUM_WORDS_SEND_R2D_RST=wrt_int_state%NUM_WORDS_SEND_R2D_RST - wrt_int_state_x(N)%loc_int_state%RST_KOUNT_I1D=wrt_int_state%RST_KOUNT_I1D - wrt_int_state_x(N)%loc_int_state%RST_KOUNT_I2D=wrt_int_state%RST_KOUNT_I2D - wrt_int_state_x(N)%loc_int_state%RST_KOUNT_R1D=wrt_int_state%RST_KOUNT_R1D - wrt_int_state_x(N)%loc_int_state%RST_KOUNT_R2D=wrt_int_state%RST_KOUNT_R2D - wrt_int_state_x(N)%loc_int_state%RST_KOUNT_LOG=wrt_int_state%RST_KOUNT_LOG - wrt_int_state_x(N)%loc_int_state%RST_LENGTH_DATA_I1D=wrt_int_state%RST_LENGTH_DATA_I1D - wrt_int_state_x(N)%loc_int_state%RST_LENGTH_DATA_R1D=wrt_int_state%RST_LENGTH_DATA_R1D -! wrt_int_state_x(N)%loc_int_state%RST_LENGTH_DATA_R2D=wrt_int_state%RST_LENGTH_DATA_R2D - wrt_int_state_x(N)%loc_int_state%RST_LENGTH_SUM_I1D=wrt_int_state%RST_LENGTH_SUM_I1D - wrt_int_state_x(N)%loc_int_state%RST_LENGTH_SUM_R1D=wrt_int_state%RST_LENGTH_SUM_R1D -! wrt_int_state_x(N)%loc_int_state%RST_LENGTH_SUM_R2D=wrt_int_state%RST_LENGTH_SUM_R2D - wrt_int_state_x(N)%loc_int_state%RST_LENGTH_SUM_LOG=wrt_int_state%RST_LENGTH_SUM_LOG - wrt_int_state_x(N)%loc_int_state%RST_NCOUNT_FIELDS=wrt_int_state%RST_NCOUNT_FIELDS - wrt_int_state_x(N)%loc_int_state%RST_ALL_DATA_I1D=wrt_int_state%RST_ALL_DATA_I1D - wrt_int_state_x(N)%loc_int_state%RST_ALL_DATA_R1D=wrt_int_state%RST_ALL_DATA_R1D - wrt_int_state_x(N)%loc_int_state%RST_FIELD_NAME=wrt_int_state%RST_FIELD_NAME - wrt_int_state_x(N)%loc_int_state%RST_NAMES_I1D_STRING=wrt_int_state%RST_NAMES_I1D_STRING - wrt_int_state_x(N)%loc_int_state%RST_NAMES_I2D_STRING=wrt_int_state%RST_NAMES_I2D_STRING - wrt_int_state_x(N)%loc_int_state%RST_NAMES_R1D_STRING=wrt_int_state%RST_NAMES_R1D_STRING - wrt_int_state_x(N)%loc_int_state%RST_NAMES_R2D_STRING=wrt_int_state%RST_NAMES_R2D_STRING - wrt_int_state_x(N)%loc_int_state%RST_NAMES_LOG_STRING=wrt_int_state%RST_NAMES_LOG_STRING - wrt_int_state_x(N)%loc_int_state%RST_ALL_DATA_LOG=wrt_int_state%RST_ALL_DATA_LOG -! - DO NN=0,LAST_FCST_TASK - wrt_int_state_x(N)%loc_int_state%LOCAL_ISTART(NN)=wrt_int_state%LOCAL_ISTART(NN) - wrt_int_state_x(N)%loc_int_state%LOCAL_IEND(NN)=wrt_int_state%LOCAL_IEND(NN) - wrt_int_state_x(N)%loc_int_state%LOCAL_JSTART(NN)=wrt_int_state%LOCAL_JSTART(NN) - wrt_int_state_x(N)%loc_int_state%LOCAL_JEND(NN)=wrt_int_state%LOCAL_JEND(NN) - ENDDO -! - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE FILL_GROUP_STATES -! -!----------------------------------------------------------------------- -! - END SUBROUTINE PRELIM_INFO_FOR_OUTPUT -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE OPEN_HST_FILE(WRT_INT_STATE) -! -!----------------------------------------------------------------------- -!*** Open a history disk file. -!----------------------------------------------------------------------- -! -!----------------------- -!*** Argument variables -!----------------------- -! - TYPE(WRITE_INTERNAL_STATE),INTENT(INOUT) :: WRT_INT_STATE !<-- The I/O component's internal state -! -!--------------------- -!*** Local variables -!--------------------- -! - INTEGER :: FRAC_SEC,INT_SEC,N,RC -! - LOGICAL :: OPENED -! - CHARACTER(ESMF_MAXSTR) :: FILENAME -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Specifying 'DEFERRED' as the filename in the configure file -!*** means that we want to construct the output filename from -!*** HST_NAME_BASE (from the config file) appended with the -!*** forecast hour. -!----------------------------------------------------------------------- -! - INT_SEC=INT(wrt_int_state%NFSECONDS) - FRAC_SEC=NINT((wrt_int_state%NFSECONDS-INT_SEC)*100.) - WRITE(FILENAME,100)TRIM(wrt_int_state%HST_NAME_BASE)//'_bin_' & - ,wrt_int_state%NFHOURS,'h_' & - ,wrt_int_state%NFMINUTES,'m_' & - ,INT_SEC,'.',FRAC_SEC,'s' - 100 FORMAT(A,I4.4,A,I2.2,A,I2.2,A,I2.2,A) -! -!----------------------------------------------------------------------- -!*** Find an unopened unit number if one was not designated in -!*** the configure file. -!----------------------------------------------------------------------- -! - DO N=51,99 - INQUIRE(N,opened=OPENED) - IF(.NOT.OPENED)THEN - wrt_int_state%IO_HST_UNIT=N - EXIT - ENDIF - ENDDO -! -!----------------------------------------------------------------------- -!*** Open the file now. -!----------------------------------------------------------------------- -! - OPEN(unit =wrt_int_state%IO_HST_UNIT & - ,file =FILENAME & - ,status='REPLACE' & - ,access='SEQUENTIAL' & - ,form ='UNFORMATTED' & - ,iostat=RC) -! - IF(RC==0)THEN - IF(wrt_int_state%PRINT_OUTPUT .OR. wrt_int_state%PRINT_ALL) THEN - WRITE(0,*)' Opened IO_HST_UNIT=',wrt_int_state%IO_HST_UNIT,' for history' - write(0,*)' iostat=',rc,' file=',trim(filename) - ENDIF - ELSE - WRITE(0,*)' Failed to OPEN IO_HST_UNIT=',wrt_int_state%IO_HST_UNIT,' for history' - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE OPEN_HST_FILE -! -!----------------------------------------------------------------------- -!####################################################################### -! -!----------------------------------------------------------------------- -! - SUBROUTINE OPEN_RST_FILE(WRT_INT_STATE) -! -!----------------------------------------------------------------------- -!*** Open a restart disk file. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument variables -!------------------------ -! - TYPE(WRITE_INTERNAL_STATE),INTENT(INOUT) :: WRT_INT_STATE !<-- The I/O component's internal state -! -!--------------------- -!*** Local variables -!--------------------- -! - INTEGER :: FRAC_SEC,INT_SEC,N,RC -! - LOGICAL :: OPENED -! - CHARACTER(ESMF_MAXSTR) :: FILENAME -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Specifying 'DEFERRED' as the filename in the configure file -!*** means that we want to construct the output filename from -!*** RST_NAME_BASE (from the config file) appended with the -!*** forecast hour. -!----------------------------------------------------------------------- -! - INT_SEC=INT(wrt_int_state%NFSECONDS) - FRAC_SEC=NINT((wrt_int_state%NFSECONDS-INT_SEC)*100.) - WRITE(FILENAME,100)TRIM(wrt_int_state%RST_NAME_BASE)//'_bin_' & - ,wrt_int_state%NFHOURS,'h_' & - ,wrt_int_state%NFMINUTES,'m_' & - ,INT_SEC,'.',FRAC_SEC,'s' - 100 FORMAT(A,I4.4,A,I2.2,A,I2.2,A,I2.2,A) -! -!----------------------------------------------------------------------- -!*** Find an unopened unit number if one was not designated in -!*** the configure file. -!----------------------------------------------------------------------- -! - DO N=51,99 - INQUIRE(N,opened=OPENED) - IF(.NOT.OPENED)THEN - wrt_int_state%IO_RST_UNIT=N - EXIT - ENDIF - ENDDO -! -!----------------------------------------------------------------------- -!*** Open the file now. -!----------------------------------------------------------------------- -! - OPEN(unit =wrt_int_state%IO_RST_UNIT & - ,file =FILENAME & - ,status='REPLACE' & - ,access='SEQUENTIAL' & - ,form ='UNFORMATTED' & - ,iostat=RC) -! - IF(RC==0) THEN - IF(wrt_int_state%PRINT_OUTPUT .OR. wrt_int_state%PRINT_ALL) THEN - WRITE(0,*)' Opened IO_RST_UNIT=',wrt_int_state%IO_RST_UNIT,' for restart' - write(0,*)' iostat=',rc,' file=',trim(filename) - ENDIF - ELSE - WRITE(0,*)' Failed to OPEN IO_RST_UNIT=',wrt_int_state%IO_RST_UNIT,' for restart' - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE OPEN_RST_FILE -! -!----------------------------------------------------------------------- -!####################################################################### -!----------------------------------------------------------------------- -! - SUBROUTINE WRITE_INIT(DOMAIN_GRID_COMP & - ,DOMAIN_INT_STATE & - ,DOMAIN_IMP_STATE & - ,CLOCK_DOMAIN & - ,MYPE) -! -!----------------------------------------------------------------------- -!*** Execute the Initialize step of the Write components. -!----------------------------------------------------------------------- -! -!----------------------- -!*** Argument Variables -!----------------------- -! - TYPE(ESMF_GridComp),INTENT(INOUT) :: DOMAIN_GRID_COMP !<-- The DOMAIN component -! - TYPE(DOMAIN_INTERNAL_STATE),INTENT(INOUT) :: DOMAIN_INT_STATE !<-- The DOMAIN Internal State -! - TYPE(ESMF_State),INTENT(INOUT) :: DOMAIN_IMP_STATE !<-- The DOMAIN import state -! - TYPE(ESMF_Clock),INTENT(INOUT) :: CLOCK_DOMAIN !<-- The DOMAIN Component's ESMF Clock -! - INTEGER,INTENT(IN) :: MYPE -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER(kind=KINT) :: I,INPES,J,JNPES,LEAD_TASK,NUM_PES_FCST -! - INTEGER(kind=KINT) :: RC,RC_INIT -! - TYPE(ESMF_Config) :: CF !<-- The config object -! - TYPE(ESMF_VM) :: VM !<-- The ESMF virtual machine. -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Retrieve the config object CF from the DOMAIN component. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Config Object from DOMAIN Component in Write Init" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGet(gridcomp=DOMAIN_GRID_COMP & !<-- The DOMAIN component - ,config =CF & !<-- The config object (~namelist) - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** How many forecast tasks do we have? -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Write Init: Get INPES from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The ESMF configure object - ,value =INPES & !<-- # of fcst tasks in I direction - ,label ='inpes:' & !<-- Give the value of this label to INPES - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Write Init: Get JNPES from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The ESMF configure object - ,value =JNPES & !<-- # of fcst tasks in J direction - ,label ='jnpes:' & !<-- Give the value of this label to JNPES - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NUM_PES_FCST=INPES*JNPES !<-- Total number of forecast tasks -! -!----------------------------------------------------------------------- -!*** Transfer the rank of the lead task on each domain into the -!*** Write component import states since that component needs -!*** this information. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Write Init: Extract Lead Task on Domain from Domain Import" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(state=DOMAIN_IMP_STATE & !<-- The Domain component's import state - ,name ='Lead Task Domain' & !<-- Name of the Attribute to extract - ,value=LEAD_TASK & !<-- Global rank of lead task on this domain - ,defaultValue=0 & !<-- The default value - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Write Init: Insert Lead Task into Write Import State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeSet(state=domain_int_state%IMP_STATE_WRITE & !<-- The Write component's import state - ,name ='Lead Task Domain' & !<-- Name of the Attribute to extract - ,value=LEAD_TASK & !<-- Global rank of lead task on this domain - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** Execute the Initialize step for the Write components. -!*** These are the Initialize subroutines specified in the -!*** register routines called in ESMF_GridCompSetServices. -!----------------------------------------------------------------------- -! - DO J=1,domain_int_state%WRITE_GROUPS -! -!!!! CALL ESMF_VMBarrier(VM,rc=RC) ! Insert barrier since fcst tasks are involved in each iteration of write groups -! - DO I=1,NUM_PES_FCST+domain_int_state%WRITE_TASKS_PER_GROUP - IF(MYPE==domain_int_state%PETLIST_WRITE(I,J))THEN !<-- Forecast tasks plus the Write tasks in each write group -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Execute Initialize Step of Write Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompInitialize(gridcomp =domain_int_state%WRITE_COMPS(J) & !<-- The Write gridded components - ,importState=domain_int_state%IMP_STATE_WRITE & !<-- The Write import state - ,exportState=domain_int_state%EXP_STATE_WRITE & !<-- The Write export state - ,clock =CLOCK_DOMAIN & !<-- The ESMF clock of the DOMAIN component - ,rc =RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_INIT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - ENDIF - ENDDO - ENDDO -! -!----------------------------------------------------------------------- -!*** Some aspects of the output data do not change with forecast time -!*** for both the forecast and the quilt tasks. Determine all such -!*** information now and save it. Do this work once for history -!*** and once for restart output. -!----------------------------------------------------------------------- -! - CALL PRELIM_INFO_FOR_OUTPUT('History' & - ,NUM_PES_FCST & - ,domain_int_state%WRITE_GROUPS & - ,domain_int_state%WRITE_COMPS & - ,domain_int_state%IMP_STATE_WRITE ) -! - CALL PRELIM_INFO_FOR_OUTPUT('Restart' & - ,NUM_PES_FCST & - ,domain_int_state%WRITE_GROUPS & - ,domain_int_state%WRITE_COMPS & - ,domain_int_state%IMP_STATE_WRITE ) -! -!----------------------------------------------------------------------- -!*** Set the first Write group as the first one to act. -!----------------------------------------------------------------------- -! - domain_int_state%WRITE_GROUP_READY_TO_GO=1 -! -!----------------------------------------------------------------------- -! - END SUBROUTINE WRITE_INIT -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE SEND_UPDATED_ATTRIBUTES(OUTPUT_BUNDLE & - ,ALL_DATA_INT_ATT & - ,ALL_DATA_REAL_ATT & - ,ALL_DATA_LOG_ATT & - ,LENGTH_INT_DATA & - ,LENGTH_REAL_DATA & - ,LENGTH_LOG_DATA & - ,MAX_GROUPS & - ,WRITE_GROUP & - ,INTERCOMM ) -! -!----------------------------------------------------------------------- -!*** The lead forecast task sends the updated ESMF Attributes in -!*** the input Bundle to the lead quilt task. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - INTEGER(kind=KINT),INTENT(IN) :: INTERCOMM & !<-- Intercommunicator between fcst/quilt tasks - ,LENGTH_INT_DATA & !<-- Length of integer Attribute datastring - ,LENGTH_LOG_DATA & !<-- Length of logical Attribute datastring - ,LENGTH_REAL_DATA & !<-- Length of real Attribute datastring - ,MAX_GROUPS & !<-- Max # of Write groups - ,WRITE_GROUP !<-- The current Write group -! - INTEGER(kind=KINT),DIMENSION(1:LENGTH_INT_DATA),INTENT(OUT) :: & - ALL_DATA_INT_ATT !<-- The integer Attributes in the output Bundle -! - REAL(kind=KFPT),DIMENSION(1:LENGTH_REAL_DATA),INTENT(OUT) :: & - ALL_DATA_REAL_ATT !<-- The real Attributes in the output Bundle -! - LOGICAL(kind=KLOG),DIMENSION(1:LENGTH_LOG_DATA),INTENT(OUT) :: & - ALL_DATA_LOG_ATT !<-- The logical Attributes in the output Bundle -! - TYPE(ESMF_FieldBundle),INTENT(INOUT) :: OUTPUT_BUNDLE !<-- The ESMF output data Bundle (history/restart) -! -!--------------------- -!*** Local variables -!--------------------- -! - INTEGER(kind=KINT) :: KOUNT_INT_ATT,KOUNT_LOG_ATT,KOUNT_REAL_ATT & - ,L,LENGTH,LENGTH_SUM_INT_ATT & - ,LENGTH_SUM_LOG_ATT,LENGTH_SUM_REAL_ATT & - ,N,NUM_ATTRIB -! - INTEGER(kind=KINT) :: IERR,RC,RC_ATT -! - INTEGER(kind=KINT),DIMENSION(MPI_STATUS_SIZE) :: JSTAT -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE :: WORK_ARRAY_INT_ATT -! - INTEGER(kind=KINT),DIMENSION(:),POINTER :: HANDLE_INT_ATT & - ,HANDLE_LOG_ATT & - ,HANDLE_REAL_ATT -! - INTEGER(kind=KINT),DIMENSION(:),ALLOCATABLE,TARGET,SAVE :: & - HANDLE_INT_ATT_HST & - ,HANDLE_INT_ATT_RST & - ,HANDLE_LOG_ATT_HST & - ,HANDLE_LOG_ATT_RST & - ,HANDLE_REAL_ATT_HST & - ,HANDLE_REAL_ATT_RST -! - REAL(kind=KFPT),DIMENSION(:),ALLOCATABLE :: WORK_ARRAY_REAL_ATT -! - LOGICAL(kind=KLOG) :: WORK_LOGICAL -! - CHARACTER(len=14) :: BUNDLE_NAME -! - CHARACTER(ESMF_MAXSTR) :: ATTRIB_NAME -! - TYPE(ESMF_TypeKind_Flag) :: DATATYPE -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Name of the Output Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_FieldBundleGet(FIELDBUNDLE =OUTPUT_BUNDLE & - ,name =BUNDLE_NAME & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_ATT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Attribute Count from Output Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(FIELDBUNDLE=OUTPUT_BUNDLE & !<-- The write component's history data Bundle - ,count =NUM_ATTRIB & !<-- # of Attributes in the history data Bundle - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_ATT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - KOUNT_INT_ATT=0 !<-- Initialize counter of integer Attributes - KOUNT_REAL_ATT=0 !<-- Initialize counter of real Attributes - KOUNT_LOG_ATT=0 !<-- Initialize counter of logical Attributes -! - LENGTH_SUM_INT_ATT=0 !<-- Initialize length of the integer Attribute datastring - LENGTH_SUM_REAL_ATT=0 !<-- Initialize length of the real Attribute datastring - LENGTH_SUM_LOG_ATT=0 !<-- Initialize length of the logical Attribute datastring -! -!----------------------------------------------------------------------- -!*** Allocate the ISend handles if not done already. -!----------------------------------------------------------------------- -! - IF(BUNDLE_NAME=='History Bundle')THEN -! - IF(.NOT.ALLOCATED(HANDLE_INT_ATT_HST))THEN -! - ALLOCATE(HANDLE_INT_ATT_HST(1:MAX_GROUPS)) - ALLOCATE(HANDLE_REAL_ATT_HST(1:MAX_GROUPS)) - ALLOCATE(HANDLE_LOG_ATT_HST(1:MAX_GROUPS)) -! - DO N=1,MAX_GROUPS - HANDLE_INT_ATT_HST(N)=MPI_REQUEST_NULL - HANDLE_REAL_ATT_HST(N)=MPI_REQUEST_NULL - HANDLE_LOG_ATT_HST(N)=MPI_REQUEST_NULL - ENDDO -! - ENDIF -! - HANDLE_INT_ATT=>HANDLE_INT_ATT_HST - HANDLE_REAL_ATT=>HANDLE_REAL_ATT_HST - HANDLE_LOG_ATT=>HANDLE_LOG_ATT_HST -! - ELSEIF(BUNDLE_NAME=='Restart Bundle')THEN -! - IF(.NOT.ALLOCATED(HANDLE_INT_ATT_RST))THEN -! - ALLOCATE(HANDLE_INT_ATT_RST(1:MAX_GROUPS)) - ALLOCATE(HANDLE_REAL_ATT_RST(1:MAX_GROUPS)) - ALLOCATE(HANDLE_LOG_ATT_RST(1:MAX_GROUPS)) -! - DO N=1,MAX_GROUPS - HANDLE_INT_ATT_RST(N)=MPI_REQUEST_NULL - HANDLE_REAL_ATT_RST(N)=MPI_REQUEST_NULL - HANDLE_LOG_ATT_RST(N)=MPI_REQUEST_NULL - ENDDO -! - ENDIF -! - HANDLE_INT_ATT=>HANDLE_INT_ATT_RST - HANDLE_REAL_ATT=>HANDLE_REAL_ATT_RST - HANDLE_LOG_ATT=>HANDLE_LOG_ATT_RST -! - ENDIF -! -!----------------------------------------------------------------------- -! - attrib_loop: DO N=1,NUM_ATTRIB -! -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Attribute Names, Datatypes, and Lengths" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(FIELDBUNDLE =OUTPUT_BUNDLE & !<-- The history data Bundle - ,attributeIndex=N & !<-- Index of each Attribute - ,name =ATTRIB_NAME & !<-- Each Attribute's name - ,typekind =DATATYPE & !<-- Each Attribute's ESMF Datatype - ,itemCount =LENGTH & !<-- Each Attribute's length - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_ATT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -! -- Scalar and 1-D Integer Output Data -- -!----------------------------------------------------------------------- -! - IF(DATATYPE==ESMF_TYPEKIND_I4)THEN !<-- Extract integer data with rank <2 -! - ALLOCATE(WORK_ARRAY_INT_ATT(LENGTH),stat=RC) !<-- Allocate array to hold integer Attribute N -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Scalar/1-D Integer Data from Output Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(FIELDBUNDLE=OUTPUT_BUNDLE & !<-- The history data Bundle - ,name =ATTRIB_NAME & !<-- Name of the Attribute to extract - ,itemCount =LENGTH & !<-- Length of Attribute - ,valueList =WORK_ARRAY_INT_ATT & !<-- Place the Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_ATT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - KOUNT_INT_ATT=KOUNT_INT_ATT+1 !<-- Count # of integer Attributes -! - DO L=1,LENGTH - ALL_DATA_INT_ATT(LENGTH_SUM_INT_ATT+L)=WORK_ARRAY_INT_ATT(L) !<-- String together the integer Attributes - ENDDO -! - LENGTH_SUM_INT_ATT=LENGTH_SUM_INT_ATT+LENGTH !<-- Total word sum of integer Attributesd - DEALLOCATE(WORK_ARRAY_INT_ATT) -! -!----------------------------------------------------------------------- -! -- Scalar and 1-D Real Output Data -- -!----------------------------------------------------------------------- -! - ELSEIF(DATATYPE==ESMF_TYPEKIND_R4)THEN !<-- Extract real data with rank <2 -! - ALLOCATE(WORK_ARRAY_REAL_ATT(LENGTH),stat=RC) !<-- Allocate array to hold real Attribute N -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Scalar/1-D Real Data from Output Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(FIELDBUNDLE=OUTPUT_BUNDLE & !<-- The history data Bundle - ,name =ATTRIB_NAME & !<-- Name of the Attribute to extract - ,itemCount =LENGTH & !<-- Length of Attribute - ,valueList =WORK_ARRAY_REAL_ATT & !<-- Place the Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_ATT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - KOUNT_REAL_ATT=KOUNT_REAL_ATT+1 !<-- Count # of real Attributes -! - DO L=1,LENGTH - ALL_DATA_REAL_ATT(LENGTH_SUM_REAL_ATT+L)=WORK_ARRAY_REAL_ATT(L) !<-- String together the real Attributes - ENDDO -! - LENGTH_SUM_REAL_ATT=LENGTH_SUM_REAL_ATT+LENGTH !<-- Total word sum of real Attributes - DEALLOCATE(WORK_ARRAY_REAL_ATT) -! -!----------------------------------------------------------------------- -! -- Logical Output Data -- -!----------------------------------------------------------------------- -! -!!! ELSEIF(DATATYPE==ESMF_TYPEKIND_LOGICAL)THEN !<-- Extract logical data - ELSE !<-- Extract logical data -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="Get Scalar/1-D Logical Data from Output Bundle" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_AttributeGet(FIELDBUNDLE=OUTPUT_BUNDLE & !<-- The history data Bundle - ,name =ATTRIB_NAME & !<-- Name of the Attribute to extract - ,value =WORK_LOGICAL & !<-- Place the Attribute here - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_ATT) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - KOUNT_LOG_ATT=KOUNT_LOG_ATT+1 !<-- Count # of logical Attributes -! - ALL_DATA_LOG_ATT(LENGTH_SUM_LOG_ATT+1)=WORK_LOGICAL !<-- String together the logical Attributes -! - LENGTH_SUM_LOG_ATT=LENGTH_SUM_LOG_ATT+1 !<-- Total word sum of logical Attributes -! -!----------------------------------------------------------------------- -! - ENDIF -! -!----------------------------------------------------------------------- -! - ENDDO attrib_loop -! -!----------------------------------------------------------------------- -!*** Lead fcst task sends the integer Attributes to the lead -!*** quilt task. -!----------------------------------------------------------------------- -! - IF(LENGTH_SUM_INT_ATT>0)THEN -! - CALL MPI_WAIT(HANDLE_INT_ATT(WRITE_GROUP),JSTAT,IERR) -! - CALL MPI_ISSEND(ALL_DATA_INT_ATT & !<-- String of integer Attribute output data - ,LENGTH_SUM_INT_ATT & !<-- # of words in the data string - ,MPI_INTEGER & !<-- The datatype - ,0 & !<-- Send to the lead Write task in the group - ,WRITE_GROUP & !<-- Use the Write group as the tag - ,INTERCOMM & !<-- The MPI intercommunicator between fcst and quilt tasks - ,HANDLE_INT_ATT(WRITE_GROUP) & !<-- MPI communication request handle - ,IERR ) -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Lead fcst task sends the real Attributes to the lead quilt task. -!----------------------------------------------------------------------- -! - IF(LENGTH_SUM_REAL_ATT>0)THEN -! - CALL MPI_WAIT(HANDLE_REAL_ATT(WRITE_GROUP),JSTAT,IERR) -! - CALL MPI_ISSEND(ALL_DATA_REAL_ATT & !<-- String of real Attribute output data - ,LENGTH_SUM_REAL_ATT & !<-- # of words in the data string - ,MPI_REAL & !<-- The datatype - ,0 & !<-- Send to the lead Write task in the group - ,WRITE_GROUP & !<-- Use the Write group as the tag - ,INTERCOMM & !<-- The MPI intercommunicator between fcst and quilt tasks - ,HANDLE_REAL_ATT(WRITE_GROUP) & !<-- MPI communication request handle - ,IERR ) -! - ENDIF -! -!----------------------------------------------------------------------- -!*** Lead fcst task sends the logical Attributes to the -!*** lead quilt task. -!----------------------------------------------------------------------- -! - IF(LENGTH_SUM_LOG_ATT>0)THEN -! - CALL MPI_WAIT(HANDLE_LOG_ATT(WRITE_GROUP),JSTAT,IERR) -! - CALL MPI_ISSEND(ALL_DATA_LOG_ATT & !<-- String of logical Attribute output data - ,LENGTH_SUM_LOG_ATT & !<-- # of words in the data string - ,MPI_LOGICAL & !<-- The datatype - ,0 & !<-- Send to the lead Write task in the group - ,WRITE_GROUP & !<-- Use the Write group as the tag - ,INTERCOMM & !<-- The MPI intercommunicator between fcst and quilt tasks - ,HANDLE_LOG_ATT(WRITE_GROUP) & !<-- MPI communication request handle - ,IERR ) -! - ENDIF -! -!----------------------------------------------------------------------- -! - END SUBROUTINE SEND_UPDATED_ATTRIBUTES -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE WRITE_ASYNC(DOMAIN_GRID_COMP & - ,DOMAIN_INT_STATE & - ,CLOCK_DOMAIN & - ,MYPE & - ,CWRT) -! -!----------------------------------------------------------------------- -!*** Write out a history file using the asynchronous quilting. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(ESMF_GridComp),INTENT(INOUT) :: DOMAIN_GRID_COMP !<-- The DOMAIN component -! - TYPE(DOMAIN_INTERNAL_STATE),INTENT(INOUT) :: DOMAIN_INT_STATE !<-- The DOMAIN Internal State -! - TYPE(ESMF_Clock),INTENT(INOUT) :: CLOCK_DOMAIN !<-- The DOMAIN Component's ESMF Clock -! - CHARACTER(ESMF_MAXSTR),INTENT(IN) :: CWRT !<-- Restart/History label -! -!--------------------- -!*** Local Variables -!--------------------- -! - TYPE(ESMF_Config) :: CF !<-- The configure object (~namelist) -! - TYPE(ESMF_Time) :: CURRTIME !<-- The current forecast time (ESMF) -! - INTEGER,INTENT(IN) :: MYPE -! - INTEGER :: YY,MM,DD,H,M,S !<-- Year, Month, Day, Hour, Minute, Second (integer) -! - INTEGER :: I,INPES,JNPES,N_GROUP,NUM_PES_FCST & - ,WRITE_GROUPS,WRITE_TASKS_PER_GROUP & - ,RC,RC_ASYNC -! - LOGICAL :: PRINT_OUTPUT, PRINT_ALL !<-- Prints to err file flags -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Check whether this is history or restart call. -!----------------------------------------------------------------------- -! - IF(CWRT=='History') TIME_FOR_HISTORY = .TRUE. - IF(CWRT=='Restart') TIME_FOR_RESTART = .TRUE. -! write(0,*)' enter WRITE_ASYNC time_for_history=',time_for_history,' time_for_restart=',time_for_restart -! -!----------------------------------------------------------------------- -!*** Extract the configure object in order to know the number -!*** of forecast tasks, Write groups, and write tasks per group. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="WRITE_ASYNC: Extract Config Object from DOMAIN Component" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_GridCompGet(gridcomp=DOMAIN_GRID_COMP & !<-- The DOMAIN component - ,config =CF & !<-- The config object (~namelist) - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_ASYNC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="WRITE_ASYNC: Get General Info from Config File" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ConfigGetAttribute(config=CF & - ,value =INPES & !<-- # of fcst tasks in I direction - ,label ='inpes:' & - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF & - ,value =JNPES & !<-- # of fcst tasks in J direction - ,label ='jnpes:' & - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file - ,value =WRITE_GROUPS & !<-- Number of write groups - ,label ='write_groups:' & - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file - ,value =WRITE_TASKS_PER_GROUP & !<-- Number of write tasks per group - ,label ='write_tasks_per_group:' & - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file - ,value =PRINT_OUTPUT & !<-- Print output flag - ,label ='print_output:' & - ,rc =RC) -! - CALL ESMF_ConfigGetAttribute(config=CF & !<-- The configure file - ,value =PRINT_ALL & !<-- Print output flag - ,label ='print_all:' & - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_ASYNC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - NUM_PES_FCST=INPES*JNPES !<-- Number of forecast tasks -! -!----------------------------------------------------------------------- -!*** What is the current forecast time? -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="WRITE_ASYNC: Get Current Time from DOMAIN Clock" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_ClockGet(clock =CLOCK_DOMAIN & !<-- The DOMAIN component's ESMF Clock - ,currTime=CURRTIME & !<-- The current forecast time (ESMF) - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_ASYNC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="WRITE_ASYNC: Convert ESMF Time to Real Time" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_TimeGet (time=CURRTIME & !<-- The current forecast time (ESMF) - ,yy =YY & !<-- The current year (integer) - ,mm =MM & !<-- The current month (integer) - ,dd =DD & !<-- The current day (integer) - ,h =H & !<-- The current hour (integer) - ,m =M & !<-- The current minute (integer) - ,s =S & !<-- The current second (integer) - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_ASYNC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!----------------------------------------------------------------------- -!*** The export state of the SOLVER component lies within the -!*** internal state of the DOMAIN component and holds the -!*** import state of the Write component. -!*** Extract that Write component's import state since we are -!*** about to execute the Run step of the Write component. -!----------------------------------------------------------------------- -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="WRITE_ASYNC: Extract Write Import State from Dyn Export State" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - CALL ESMF_StateGet(state =domain_int_state%EXP_STATE_SOLVER & !<-- The Solver component's export state - ,itemName ="Write Import State" & !<-- Name of state to be extracted - ,nestedState=domain_int_state%IMP_STATE_WRITE & !<-- The extracted state - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_ASYNC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! -!!! CALL ESMF_VMBarrier(vm=VM,rc=RC) -! -!----------------------------------------------------------------------- -!*** All forecast tasks plus those write tasks in the appropriate -!*** Write group execute the Run step of a Write component. -!----------------------------------------------------------------------- -! - N_GROUP=domain_int_state%WRITE_GROUP_READY_TO_GO !<-- The active write group -! write(0,*)' WRITE_ASYNC calling WRITE_RUN for write group ',n_group & -! ,' num_pes_fcst=',num_pes_fcst,' write_tasks_per_group=',write_tasks_per_group -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - MESSAGE_CHECK="WRITE_ASYNC: Execute Run Step of Write Components" -! CALL ESMF_LogWrite(MESSAGE_CHECK,ESMF_LOGMSG_INFO,rc=RC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - DO I=1,NUM_PES_FCST+WRITE_TASKS_PER_GROUP - IF(MYPE==domain_int_state%PETLIST_WRITE(I,N_GROUP))THEN - CALL ESMF_GridCompRun(gridcomp=domain_int_state%WRITE_COMPS(N_GROUP) & !<-- The write gridded component - ,importState=domain_int_state%IMP_STATE_WRITE & !<-- Its import state - ,exportState=domain_int_state%EXP_STATE_WRITE & !<-- Its export state - ,clock =CLOCK_DOMAIN & !<-- The DOMAIN Clock - ,rc =RC) -! -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - CALL ERR_MSG(RC,MESSAGE_CHECK,RC_ASYNC) -! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -! - IF(I==NUM_PES_FCST+1)THEN !<-- The first write task tells us the history output time - IF(PRINT_OUTPUT .OR. PRINT_ALL) & - WRITE(0,101)TRIM(CWRT),YY,MM,DD,H,M,S - 101 FORMAT(' Wrote ',A7,' File at ',I4.4,'_',I2.2,'_',I2.2,'_',I2.2,':',I2.2,':',I2.2) - ENDIF -! - ENDIF -! - ENDDO -! -!----------------------------------------------------------------------- -!*** Prepare to use the next write group at the next output time. -!*** Return to the 1st group if we have cycled through all of them. -!----------------------------------------------------------------------- -! - IF(domain_int_state%WRITE_GROUP_READY_TO_GO==WRITE_GROUPS)THEN - domain_int_state%WRITE_GROUP_READY_TO_GO=1 - ELSE - domain_int_state%WRITE_GROUP_READY_TO_GO=domain_int_state%WRITE_GROUP_READY_TO_GO+1 - ENDIF -! -!----------------------------------------------------------------------- -!*** Restore TIME_FOR_HISTORY and TIME_FOR_RESTART to false. -!----------------------------------------------------------------------- -! - TIME_FOR_HISTORY = .FALSE. - TIME_FOR_RESTART = .FALSE. -! -!----------------------------------------------------------------------- -! - END SUBROUTINE WRITE_ASYNC -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE WRITE_RUNHISTORY_OPEN(WRT_INT_STATE & - ,IYEAR_FCST & - ,IMONTH_FCST & - ,IDAY_FCST & - ,IHOUR_FCST & - ,IMINUTE_FCST & - ,SECOND_FCST & - ,NF_HOURS & - ,NF_MINUTES & - ,NF_SECONDS & - ,HST_FIRST & - ,LEAD_WRITE_TASK ) -! -!----------------------------------------------------------------------- -!*** Write out a binary run history file. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument variables -!------------------------ -! - TYPE(WRITE_INTERNAL_STATE),INTENT(INOUT) :: WRT_INT_STATE !<-- The Write component's internal state -! - INTEGER,INTENT(IN) :: IYEAR_FCST & - ,IMONTH_FCST & - ,IDAY_FCST & - ,IHOUR_FCST & - ,IMINUTE_FCST & - ,NF_HOURS & - ,NF_MINUTES & - ,LEAD_WRITE_TASK -! - REAL,INTENT(IN) :: NF_SECONDS,SECOND_FCST -! - LOGICAL,INTENT(IN) :: HST_FIRST -! -!--------------------- -!*** Local variables -!--------------------- -! - INTEGER :: N,N1,N2,NPOSN_1,NPOSN_2,LENGTH - INTEGER :: NFIELD,RC - CHARACTER(ESMF_MAXSTR) :: NAME - INTEGER,DIMENSION(:),POINTER :: WORK_ARRAY_I1D - REAL(4),DIMENSION(:),POINTER :: WORK_ARRAY_R1D - LOGICAL :: WRITE_LOGICAL - LOGICAL :: WORK_LOGICAL - -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Open the history file and write the current forecast time -!*** and elapsed time. -!----------------------------------------------------------------------- -! - CALL OPEN_HST_FILE(WRT_INT_STATE) -! - WRITE(wrt_int_state%IO_HST_UNIT,iostat=RC)IYEAR_FCST - WRITE(wrt_int_state%IO_HST_UNIT,iostat=RC)IMONTH_FCST - WRITE(wrt_int_state%IO_HST_UNIT,iostat=RC)IDAY_FCST - WRITE(wrt_int_state%IO_HST_UNIT,iostat=RC)IHOUR_FCST - WRITE(wrt_int_state%IO_HST_UNIT,iostat=RC)IMINUTE_FCST - WRITE(wrt_int_state%IO_HST_UNIT,iostat=RC)SECOND_FCST - WRITE(wrt_int_state%IO_HST_UNIT,iostat=RC)NF_HOURS - WRITE(wrt_int_state%IO_HST_UNIT,iostat=RC)NF_MINUTES - WRITE(wrt_int_state%IO_HST_UNIT,iostat=RC)NF_SECONDS -! - IF(HST_FIRST .AND. (wrt_int_state%PRINT_OUTPUT .OR. wrt_int_state%PRINT_ALL) )THEN - WRITE(0,*)' Wrote IYEAR_FCST to history file unit ',wrt_int_state%IO_HST_UNIT - WRITE(0,*)' Wrote IMONTH_FCST to history file unit ',wrt_int_state%IO_HST_UNIT - WRITE(0,*)' Wrote IDAY_FCST to history file unit ',wrt_int_state%IO_HST_UNIT - WRITE(0,*)' Wrote IHOUR_FCST to history file unit ',wrt_int_state%IO_HST_UNIT - WRITE(0,*)' Wrote IMINUTE_FCST to history file unit ',wrt_int_state%IO_HST_UNIT - WRITE(0,*)' Wrote SECOND_FCST to history file unit ',wrt_int_state%IO_HST_UNIT - WRITE(0,*)' Wrote NF_HOURS to history file unit ',wrt_int_state%IO_HST_UNIT - WRITE(0,*)' Wrote NF_MINUTES to history file unit ',wrt_int_state%IO_HST_UNIT - WRITE(0,*)' Wrote NF_SECONDS to history file unit ',wrt_int_state%IO_HST_UNIT - ENDIF -! -!----------------------------------------------------------------------- -!*** Integer scalar/1-D history variables -!----------------------------------------------------------------------- -! - N2=0 !<-- Word counter for full string of integer scalar/1D data -! - DO N=1,wrt_int_state%KOUNT_I1D(1) !<-- Loop through all scalar/1D integer data -! - NPOSN_1=(N-1)*ESMF_MAXSTR+1 - NPOSN_2=N*ESMF_MAXSTR - NAME=wrt_int_state%NAMES_I1D_STRING(NPOSN_1:NPOSN_2) !<-- The variable's name - LENGTH=wrt_int_state%LENGTH_DATA_I1D(N) !<-- The variable's length in words - ALLOCATE(WORK_ARRAY_I1D(LENGTH),stat=RC) -! - DO N1=1,LENGTH - N2=N2+1 - WORK_ARRAY_I1D(N1)=wrt_int_state%ALL_DATA_I1D(N2) !<-- Extract the individual data from the data string - ENDDO -! - WRITE(wrt_int_state%IO_HST_UNIT,iostat=RC)WORK_ARRAY_I1D !<-- Write out the data -! - IF(HST_FIRST .AND. (wrt_int_state%PRINT_OUTPUT .OR. wrt_int_state%PRINT_ALL) )THEN - WRITE(0,*)'Wrote ',TRIM(NAME),' to history file unit ',wrt_int_state%IO_HST_UNIT - ENDIF -! - DEALLOCATE(WORK_ARRAY_I1D) -! - ENDDO -! -!----------------------------------------------------------------------- -!*** Real scalar/1-D history variables -!----------------------------------------------------------------------- -! - N2=0 !<-- Word counter for full string of real scalar/1D data -! - DO N=1,wrt_int_state%KOUNT_R1D(1) !<-- Loop through all scalar/1D real data -! - NPOSN_1=(N-1)*ESMF_MAXSTR+1 - NPOSN_2=N*ESMF_MAXSTR - NAME=wrt_int_state%NAMES_R1D_STRING(NPOSN_1:NPOSN_2) !<-- The variable's name - LENGTH=wrt_int_state%LENGTH_DATA_R1D(N) !<-- The variable's length - ALLOCATE(WORK_ARRAY_R1D(LENGTH),stat=RC) -! - DO N1=1,LENGTH - N2=N2+1 - WORK_ARRAY_R1D(N1)=wrt_int_state%ALL_DATA_R1D(N2) !<-- Extract the individual data from the data string - ENDDO -! - WRITE(wrt_int_state%IO_HST_UNIT,iostat=RC)WORK_ARRAY_R1D !<-- Write out the data -! - IF(HST_FIRST .AND. (wrt_int_state%PRINT_OUTPUT .OR. wrt_int_state%PRINT_ALL) )THEN - WRITE(0,*)'Wrote ',TRIM(NAME),' to history file unit ',wrt_int_state%IO_HST_UNIT - ENDIF -! - DEALLOCATE(WORK_ARRAY_R1D) -! - ENDDO -! -!----------------------------------------------------------------------- -!*** Logical history variables -!----------------------------------------------------------------------- -! - N2=0 !<-- Counter for full string of logical data -! - DO N=1,wrt_int_state%KOUNT_LOG(1) !<-- Loop through all logical data -! - NPOSN_1=(N-1)*ESMF_MAXSTR+1 - NPOSN_2=N*ESMF_MAXSTR - NAME=wrt_int_state%NAMES_LOG_STRING(NPOSN_1:NPOSN_2) !<-- The variable's name -! - N2=N2+1 - - WORK_LOGICAL = wrt_int_state%ALL_DATA_LOG(N2) - WRITE_LOGICAL=WORK_LOGICAL !<-- Convert from ESMF_Logical to F90 logical -! - WRITE(wrt_int_state%IO_HST_UNIT,iostat=RC)WRITE_LOGICAL !<-- Write out the data -! - IF(HST_FIRST .AND. (wrt_int_state%PRINT_OUTPUT .OR. wrt_int_state%PRINT_ALL) )THEN - WRITE(0,*)'Wrote ',TRIM(NAME),' to history file unit ',wrt_int_state%IO_HST_UNIT - ENDIF -! - ENDDO -! -!----------------------------------------------------------------------- -! - END SUBROUTINE WRITE_RUNHISTORY_OPEN -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE WRITE_NEMSIO_RUNHISTORY_OPEN(WRT_INT_STATE & - ,NEMSIOFILE & - ,IYEAR_FCST & - ,IMONTH_FCST & - ,IDAY_FCST & - ,IHOUR_FCST & - ,IMINUTE_FCST & - ,SECOND_FCST & - ,NF_HOURS & - ,NF_MINUTES & - ,NF_SECONDS & - ,DIM1,DIM2,NFRAME,GLOBAL & - ,LEAD_WRITE_TASK & - ,ID_DOMAIN) -! -!----------------------------------------------------------------------- -!*** Write out a NEMSIO binary run history file. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument variables -!------------------------ -! - TYPE(WRITE_INTERNAL_STATE),INTENT(INOUT) :: WRT_INT_STATE !<-- The Write component's internal state -! - TYPE(NEMSIO_GFILE),INTENT(INOUT) :: NEMSIOFILE !<-- The nemsio file handler -! - INTEGER,INTENT(IN) :: IYEAR_FCST & - ,IMONTH_FCST & - ,IDAY_FCST & - ,IHOUR_FCST & - ,IMINUTE_FCST & - ,ID_DOMAIN & - ,NF_HOURS & - ,NF_MINUTES & - ,LEAD_WRITE_TASK - - INTEGER,INTENT(OUT) :: DIM1,DIM2,NFRAME - LOGICAL,INTENT(OUT) :: GLOBAL -! - REAL,INTENT(IN) :: NF_SECONDS & - ,SECOND_FCST -! -!--------------------- -!*** Local variables -!--------------------- -! - INTEGER :: I,J,N,N1,N2,NPOSN_1,NPOSN_2,LENGTH,MAXLENGTH -! - INTEGER :: FIELDSIZE,IM,JM,LM,IDATE(7),FCSTDATE(7) & - ,INDX_2D,IRET,IND1,IND2,IND3,IND4,CNT & - ,INI1,INI2,INI3 & - ,N2ISCALAR,N2IARY,N2RSCALAR,N2RARY,N2LSCALAR & - ,NMETA,NSOIL,TLMETA,VLEV -! - INTEGER :: FRAC_SEC,INT_SEC,NFIELD,RC -! - INTEGER,DIMENSION(:),POINTER :: ARYILEN & - ,ARYRLEN & - ,RECLEV & - ,VARIVAL -! - INTEGER,DIMENSION(:,:),POINTER :: ARYIVAL -! - REAL(4) :: DEGRAD,DXCTL,DYCTL,TPH0D,TLM0D -! - REAL(4),DIMENSION(:),POINTER :: DX,DY,DXH & - ,GLAT1D,GLON1D -! - REAL(4),DIMENSION(:,:,:),POINTER :: VCOORD -! - REAL(KIND=KFPT),DIMENSION(:) ,POINTER :: VARRVAL - REAL(KIND=KFPT),DIMENSION(:,:),POINTER :: ARYRVAL -! - LOGICAL,DIMENSION(:),POINTER :: VARLVAL -! - CHARACTER(6) :: MODEL_LEVEL - CHARACTER(16) :: VLEVTYP,FILE_ENDIAN -! - CHARACTER(16),DIMENSION(:),POINTER :: ARYINAME & - ,ARYRNAME & - ,RECNAME & - ,VARINAME & - ,VARRNAME & - ,VARLNAME -! - CHARACTER(16),DIMENSION(:),POINTER :: RECLEVTYP -! - CHARACTER(ESMF_MAXSTR) :: NAME,FILENAME -! - LOGICAL :: WORK_LOGICAL -! - INTEGER :: NDYH=0,NDXH=0,NPT=0,NPDTOP=0,NREC=0 & - ,NSG1=0,NSG2=0,NSGML1=0,NSGML2=0 -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - FCSTDATE(1)=IYEAR_FCST - FCSTDATE(2)=IMONTH_FCST - FCSTDATE(3)=IDAY_FCST - FCSTDATE(4)=IHOUR_FCST - FCSTDATE(5)=IMINUTE_FCST - FCSTDATE(6)=NINT(SECOND_FCST*100.) - FCSTDATE(7)=100 -! -!----------------------------------------------------------------------- -!*** Integer scalar/1-D history variables -!----------------------------------------------------------------------- -! -!------------------------------------------------------------- -!*** Find out the total number of int scalars and int arrays. -!------------------------------------------------------------- -! - N2ISCALAR=0 - N2IARY=0 - MAXLENGTH=1 -! - DO N=1,wrt_int_state%KOUNT_I1D(1) !<-- Loop through all scalar/1D integer data - LENGTH=wrt_int_state%LENGTH_DATA_I1D(N) -! - IF(LENGTH==1)THEN - N2ISCALAR=N2ISCALAR+1 - ELSE - N2IARY=N2IARY+1 - MAXLENGTH=MAX(LENGTH,MAXLENGTH) - ENDIF -! - ENDDO -! - N2IARY=N2IARY+1 - MAXLENGTH=MAX(MAXLENGTH,7) - ALLOCATE(VARINAME(N2ISCALAR),VARIVAL(N2ISCALAR)) - ALLOCATE(ARYINAME(N2IARY),ARYILEN(N2IARY),ARYIVAL(MAXLENGTH,N2IARY)) -! -!--------------------------------------- -!*** Set value to AVRIVAL and ARYIVAL. -!--------------------------------------- -! - N2=0 !<-- Word counter for full string of integer scalar/1D data - N2ISCALAR=0 - N2IARY=0 - IDATE=0 -! - DO N=1,wrt_int_state%KOUNT_I1D(1) !<-- Loop through all scalar/1D integer data -! - NPOSN_1=(N-1)*ESMF_MAXSTR+1 - NPOSN_2=N*ESMF_MAXSTR - NAME=wrt_int_state%NAMES_I1D_STRING(NPOSN_1:NPOSN_2) !<-- The variable's name - LENGTH=wrt_int_state%LENGTH_DATA_I1D(N) !<-- The variable's length in words -! - IF(LENGTH==1)THEN - N2=N2+1 - N2ISCALAR=N2ISCALAR+1 - VARINAME(N2ISCALAR)=TRIM(NAME) - VARIVAL(N2ISCALAR)=wrt_int_state%ALL_DATA_I1D(N2) - IF(VARINAME(N2ISCALAR)=='IHRST') then - IDATE(4)=VARIVAL(N2ISCALAR) - ENDIF - ELSE - N2IARY=N2IARY+1 - ARYINAME(N2IARY)=TRIM(NAME) - ARYILEN(N2IARY)=LENGTH -! write(0,*)'in I1D array,aryiname=',aryiname(N2IARY),'len=',aryilen(N2IARY), & -! wrt_int_state%ALL_DATA_I1D(N2+1:N2+length) -! - DO N1=1,LENGTH - N2=N2+1 - ARYIVAL(N1,N2IARY)=wrt_int_state%ALL_DATA_I1D(N2) !<-- Extract the individual data from the data string - ENDDO - - IF(ARYINAME(N2IARY)=='IDAT') THEN - IDATE(1)=ARYIVAL(3,N2IARY) - IDATE(2)=ARYIVAL(2,N2IARY) - IDATE(3)=ARYIVAL(1,N2IARY) - IDATE(7)=100. - ENDIF -! -! write(0,*)'in I1D array,aryival=',aryival(:,N2IARY) - ENDIF -! - ENDDO -! -!----------------------------- -!*** Add fcst_date into ARYI -!----------------------------- -! - N2IARY=N2IARY+1 - ARYINAME(N2IARY)='FCSTDATE' - ARYILEN(N2IARY)=7 - ARYIVAL(1:7,N2IARY)=FCSTDATE(1:7) -! -!----------------------------------------------------------------------- -!*** Real scalar/1-D history variables -!----------------------------------------------------------------------- -! -!------------------------------------------------------------ -!*** Find the total number of real scalars and real arrays. -!------------------------------------------------------------ -! - N2RSCALAR=0 - N2RARY=0 - MAXLENGTH=1 -! - DO N=1,wrt_int_state%KOUNT_R1D(1) !<-- Loop through all scalar/1D real data - LENGTH=wrt_int_state%LENGTH_DATA_R1D(N) !<-- The variable's length - IF(LENGTH==1)THEN - N2RSCALAR=N2RSCALAR+1 - ELSE - N2RARY=N2RARY+1 - MAXLENGTH=MAX(LENGTH,MAXLENGTH) - ENDIF - ENDDO -! - ALLOCATE(VARRNAME(N2RSCALAR),VARRVAL(N2RSCALAR)) - ALLOCATE(ARYRNAME(N2RARY),ARYRLEN(N2RARY),ARYRVAL(MAXLENGTH,N2RARY)) -! -!------------------------------------------------------ -!*** Set values for the real scalars and real arrays. -!------------------------------------------------------ - N2=0 !<-- Word counter for full string of real scalar/1D data - N2RSCALAR=0 - N2RARY=0 -! - DO N=1,wrt_int_state%KOUNT_R1D(1) !<-- Loop through all scalar/1D real data -! - NPOSN_1=(N-1)*ESMF_MAXSTR+1 - NPOSN_2=N*ESMF_MAXSTR - NAME=wrt_int_state%NAMES_R1D_STRING(NPOSN_1:NPOSN_2) !<-- The variable's name - LENGTH=wrt_int_state%LENGTH_DATA_R1D(N) !<-- The variable's length -! - IF(LENGTH==1)THEN - N2=N2+1 - N2RSCALAR=N2RSCALAR+1 - VARRNAME(N2RSCALAR)=TRIM(NAME) - VARRVAL(N2RSCALAR)=wrt_int_state%ALL_DATA_R1D(N2) -! - IF( TRIM(NAME)=='PT') THEN - NPT=N2RSCALAR - ELSEIF ( TRIM(NAME)=='PDTOP') THEN - NPDTOP=N2RSCALAR - ELSEIF ( TRIM(NAME)=='DYH') THEN - NDYH=N2RSCALAR - ELSEIF ( TRIM(NAME)=='TPH0D') THEN - TPH0D=VARRVAL(N2RSCALAR) - ELSEIF ( trim(NAME)=='TLM0D') THEN - TLM0D=VARRVAL(N2RSCALAR) - ENDIF -! - ELSE - N2RARY=N2RARY+1 - ARYRNAME(N2RARY)=TRIM(NAME) - ARYRLEN(N2RARY)=LENGTH -! - DO N1=1,LENGTH - N2=N2+1 - ARYRVAL(N1,N2RARY)=wrt_int_state%ALL_DATA_R1D(N2) !<-- Extract the individual data from the data string - ENDDO -! - IF( TRIM(NAME)=='SG1') THEN - NSG1=N2RARY - ELSEIF ( TRIM(NAME)=='SG2') THEN - NSG2=N2RARY - ELSEIF ( TRIM(NAME)=='SGML1' ) THEN - NSGML1=N2RARY - ELSEIF (TRIM(NAME)=='SGML2') THEN - NSGML2=N2RARY - ELSEIF (TRIM(NAME)=='DXH') THEN - NDXH=N2RARY - ENDIF - - ENDIF -! - ENDDO -! -!----------------------------------------------------------------------- -!*** Logical history variables -!----------------------------------------------------------------------- -! - N2LSCALAR=wrt_int_state%KOUNT_LOG(1) !<-- Counter for full string of logical data -! - ALLOCATE(VARLNAME(N2LSCALAR),VARLVAL(N2LSCALAR)) - N2LSCALAR=0 -! - DO N=1,wrt_int_state%KOUNT_LOG(1) !<-- Loop through all logical data -! - NPOSN_1=(N-1)*ESMF_MAXSTR+1 - NPOSN_2=N*ESMF_MAXSTR - NAME=wrt_int_state%NAMES_LOG_STRING(NPOSN_1:NPOSN_2) !<-- The variable's name -! - N2LSCALAR=N2LSCALAR+1 - WORK_LOGICAL = wrt_int_state%ALL_DATA_LOG(N2LSCALAR) - - VARLNAME(N2LSCALAR)=NAME - - VARLVAL(N2LSCALAR)=wrt_int_state%ALL_DATA_LOG(N2LSCALAR) - - IF(TRIM(NAME)=='GLOBAL') GLOBAL=WORK_LOGICAL -! - ENDDO -! -!----------------------------------------------------------------------- -!*** Now open NEMSIO file. -!----------------------------------------------------------------------- -! - N=LEN_TRIM(wrt_int_state%HST_NAME_BASE) - INT_SEC=INT(wrt_int_state%NFSECONDS) - FRAC_SEC=NINT((wrt_int_state%NFSECONDS-INT_SEC)*100.) - WRITE(FILENAME,100)wrt_int_state%HST_NAME_BASE(1:N)//'_nio_' & - ,wrt_int_state%NFHOURS,'h_' & - ,wrt_int_state%NFMINUTES,'m_' & - ,INT_SEC,'.',FRAC_SEC,'s' - IF(wrt_int_state%PRINT_OUTPUT .OR. wrt_int_state%PRINT_ALL) & - write(0,*)'FILENAME=',trim(FILENAME),'n=',n - 100 FORMAT(A,I4.4,A,I2.2,A,I2.2,A,I2.2,A) -! -!---------------------------------------------------- -!*** Prepare variables needed by the nemsip header: -!---------------------------------------------------- -! -!dimension - IF(GLOBAL) THEN -!for global im/jm for data field - NFRAME=1 - ELSE -!for regional - NFRAME=0 - ENDIF - IM=wrt_int_state%im(1) - JM=wrt_int_state%jm(1) - DIM1=wrt_int_state%im(1)-2*NFRAME - DIM2=wrt_int_state%jm(1)-2*NFRAME -! - LM=wrt_int_state%LM(1) -! -!for nmmb whole domain - FIELDSIZE=IM*JM - NREC=wrt_int_state%kount_I2D(1)+wrt_int_state%kount_R2D(1)+1 !add fact10 for GSI -! -!vcoord - ALLOCATE(VCOORD(LM+1,3,2)) - VCOORD=0. - IF(NSG1>0.and.NSG2>0.and.NPDTOP>0.and.NPT>0) then - VCOORD(1:LM+1,1,1)=0.1*(ARYRVAL(1:LM+1,NSG1)*VARRVAL(NPDTOP) & - -ARYRVAL(1:LM+1,NSG2)*(VARRVAL(NPDTOP)+VARRVAL(NPT)) & - +VARRVAL(NPT) ) - VCOORD(1:LM+1,2,1)=ARYRVAL(1:LM+1,NSG2) - VCOORD(1:LM+1,3,1)=0 - ENDIF - IF(NSGML1>0.and.NSGML2>0.and.NPDTOP>0.and.NPT>0) then - VCOORD(1:LM,1,2)=0.1*(ARYRVAL(1:LM,NSGML1)*VARRVAL(NPDTOP) & - -ARYRVAL(1:LM,NSGML2)*(VARRVAL(NPDTOP)+VARRVAL(NPT)) & - +VARRVAL(NPT) ) - VCOORD(1:LM,2,2)=ARYRVAL(1:LM,NSGML2) - VCOORD(1:LM,3,2)=0 - ENDIF -!!! write(0,*)'after vcoord,count_I2d=',wrt_int_state%kount_I2D(1),'nrec=',nrec -! -!----------------------------------------------------------------------- -!*** Cut the output I2D array. -!----------------------------------------------------------------------- -! - ALLOCATE(RECNAME(NREC),RECLEVTYP(NREC),RECLEV(NREC)) - NREC=0 - INI1=0 !<-- # of 1 layer vars - INI2=0 !<-- # of total layers of vars with lm layer - INI3=0 !<-- # of total layers of vars with lm+1 layer -! - DO NFIELD=1,wrt_int_state%KOUNT_I2D(1) -! - NREC=NREC+1 - NPOSN_1=(NFIELD-1)*ESMF_MAXSTR+1 - NPOSN_2=NFIELD*ESMF_MAXSTR - NAME=wrt_int_state%NAMES_I2D_STRING(NPOSN_1:NPOSN_2) !<-- The name of this 2D integer history quantity - INDX_2D=index(NAME,"_2D") -! - IF (INDX_2D > 0) THEN - MODEL_LEVEL=NAME(INDX_2D-3:INDX_2D-1) - RECLEV(NREC)=(ICHAR(MODEL_LEVEL(1:1))-48)*100+(ICHAR(MODEL_LEVEL(2:2))-48)*10+ICHAR(MODEL_LEVEL(3:3))-48 - RECNAME(NREC)=NAME(1:INDX_2D-5) - RECLEVTYP(NREC)='mid_layer' - IF (RECLEV(NREC)==LM+1) THEN - RECLEVTYP(NREC-LM:NREC)='layer' - INI3=INI3+LM+1 - INI2=INI2-(LM+1) - ENDIF - INI2=INI2+1 - ELSE - RECNAME(NREC)=TRIM(NAME) - RECLEV(NREC)=1 - RECLEVTYP(NREC)='sfc' - INI1=INI1+1 - ENDIF -! - IF (RECNAME(NREC)=='ISLTYP') RECNAME(NREC)='sltyp' - IF (RECNAME(NREC)=='IVGTYP') RECNAME(NREC)='vgtyp' - IF (RECNAME(NREC)=='NCFRCV') RECNAME(NREC)='cfrcv' - IF (RECNAME(NREC)=='NCFRST') RECNAME(NREC)='cfrst' - CALL LOWERCASE(RECNAME(NREC)) - ENDDO -! -!!! write(0,*)'after I2D,nrec=',nrec -! -!----------------------------------------------------------------------- -!*** Cut the output R2D array. -!----------------------------------------------------------------------- -! - NSOIL=0 - IND1=0 !<-- # of 1-layer vars - IND2=0 !<-- # of total layers for vars with lm layers - IND3=0 !<-- # of total layers for vars with lm+1 layers - IND4=0 !<-- # of total layers for vars with nsoil layers -! - DO NFIELD=1,wrt_int_state%KOUNT_R2D(1) -! - NREC=NREC+1 - NPOSN_1=(NFIELD-1)*ESMF_MAXSTR+1 - NPOSN_2=NFIELD*ESMF_MAXSTR - NAME=wrt_int_state%NAMES_R2D_STRING(NPOSN_1:NPOSN_2) !<-- The name of this 2D integer history quantity - INDX_2D=INDEX(NAME,"_2D") -! - IF (INDX_2D > 0) THEN - MODEL_LEVEL=NAME(INDX_2D-3:INDX_2D-1) - RECLEV(NREC)=(ICHAR(MODEL_LEVEL(1:1))-48)*100+(ICHAR(MODEL_LEVEL(2:2))-48)*10+ICHAR(MODEL_LEVEL(3:3))-48 - RECNAME(NREC)=NAME(1:INDX_2D-5) - RECLEVTYP(NREC)='mid layer' - IF (RECNAME(NREC)=='SMC') NSOIL=NSOIL+1 - IF (RECNAME(NREC)=='W_TOT') RECNAME(NREC)='vvel' - IF (RECNAME(NREC)=='CW') RECNAME(NREC)='clwmr' - IF (RECNAME(NREC)=='U') RECNAME(NREC)='ugrd' - IF (RECNAME(NREC)=='V') RECNAME(NREC)='vgrd' - IF (RECNAME(NREC)=='T') RECNAME(NREC)='tmp' - IF (RECNAME(NREC)=='Q') RECNAME(NREC)='spfh' - IF (RECNAME(NREC)=='O3') RECNAME(NREC)='o3mr' - IF (RECLEV(NREC)==LM+1) THEN - RECLEVTYP(NREC-LM:NREC)='layer' - IND3=IND3+LM+1 - IND2=IND2-(LM+1) - ENDIF - IF (RECNAME(NREC)=='PINT') THEN - RECNAME(NREC)='pres' - ELSE IF (RECNAME(NREC)=='SMC'.OR.RECNAME(NREC)=='SH2O'.or.RECNAME(NREC)=='STC') THEN - RECLEVTYP(NREC)='soil layer' - IND4=IND4+1 - IND2=IND2-1 - ENDIF - IND2=IND2+1 - ELSE - RECLEV(NREC)=1 - RECNAME(NREC)=TRIM(NAME) - RECLEVTYP(NREC)='sfc' -! - IF (INDEX(RECNAME(NREC),"10")>0) RECLEVTYP(NREC)='10 m above gnd' - IF (RECNAME(NREC)=='PD') THEN - RECNAME(NREC)='dpres' - RECLEVTYP(NREC)='hybrid sig lev' - ENDIF -! - IF (RECNAME(NREC)=='SST') RECNAME(NREC)='tsea' - IF (RECNAME(NREC)=='FIS') RECNAME(NREC)='hgt' - IF (RECNAME(NREC)=='USTAR') RECNAME(NREC)='uustar' - IF (RECNAME(NREC)=='Z0') RECNAME(NREC)='zorl' - IND1=IND1+1 - ENDIF -! - CALL LOWERCASE(RECNAME(NREC)) - ENDDO -! -!for fact10 - NREC=NREC+1 - RECNAME(NREC)='fact10' - RECLEVTYP(NREC)='10 m above gnd' - RECLEV(NREC)=1 - -!glat1d and glon1d - ALLOCATE(GLAT1D(FIELDSIZE),GLON1D(FIELDSIZE)) - DEGRAD=90./ASIN(1.) - glon1d=0. - glat1d=0. - NMETA=12 -! -!dx and dy - ALLOCATE(DX(FIELDSIZE),DY(FIELDSIZE)) -! - if(NDXH>0) then - DO J=1,JM - DO I=1,IM - DX(I+(J-1)*IM)=ARYRVAL(J,NDXH) - ENDDO - ENDDO -! write(0,*)'after dx=',maxval(dx),minval(dx) - else - NMETA=7 - endif -! - if(NDYH>0) then - DO I=1,FIELDSIZE - DY(I)=VARRVAL(NDYH) - ENDDO -! write(0,*)'after dy=',maxval(dy),minval(dy) - endif -! -!----------------------------------------------------------------------- -! SET UP NEMSIO WRITE -!----------------------------------------------------------------------- -! - CALL NEMSIO_INIT(IRET=IRET) -! -!----------------------------------------------------------------------- -!*** Open NEMSIO run history file. -!----------------------------------------------------------------------- -! - CALL NEMSIO_OPEN(NEMSIOFILE,trim(FILENAME),'write',iret, & - modelname="NMMB", gdatatype="bin4", idate=IDATE,nfhour=NF_HOURS, & - nfminute=NF_MINUTES,nfsecondn=nint(NF_SECONDS*100), & - nfsecondd=100,dimx=DIM1,dimy=DIM2,dimz=LM,nframe=NFRAME, & - nmeta=NMETA, & - nsoil=NSOIL,ntrac=3,nrec=nrec, ncldt=1,rlon_min=minval(glon1d), & - rlon_max=maxval(glon1d), rlat_max=maxval(glat1d), & - rlat_min=minval(glat1d),vcoord=vcoord,lon=glon1d,lat=glat1d, & - dx=dx,dy=dy,extrameta=.true.,nmetavari=N2ISCALAR, & - nmetavarr=N2RSCALAR,nmetavarl=N2LSCALAR,nmetaaryi=N2IARY, & - nmetaaryr=N2RARY,variname=VARINAME,varival=VARIVAL, & - varrname=VARRNAME,varrval=VARRVAL,varlname=VARLNAME, & - varlval=VARLVAL,aryiname=ARYINAME,aryilen=ARYILEN, & - aryival=ARYIVAL,aryrname=ARYRNAME,aryrlen=ARYRLEN, & - aryrval=ARYRVAL,recname=RECNAME,reclevtyp=RECLEVTYP,reclev=RECLEV) -! -!----------------------------------------------------------------------- -!*** Get variables needed by the .ctl file. -!----------------------------------------------------------------------- -! - IF(wrt_int_state%WRITE_NEMSIOCTL.AND.wrt_int_state%MYPE==LEAD_WRITE_TASK)THEN - CALL NEMSIO_GETFILEHEAD(NEMSIOFILE,TLMETA=TLMETA,FILE_ENDIAN=FILE_ENDIAN) - DXCTL=MAXVAL(DX)*180./(A*PI) - DYCTL=MAXVAL(DY)*180./(A*PI) - CNT=INI1 & ! # of integer 1-layer fields - +(INI2/LM) & ! # of integer lm-layer fields - +(INI3/(LM+1)) & ! # of integer lm+1-layer fields - +IND1 & ! # of real 1-layer fields - +(IND2/LM) & ! # of real lm-layer fields - +(IND3/(LM+1)) & ! # of real lm+1-layer fields - +(IND4/NSOIL) & ! # of real nsoil-layer fields - +1 ! fact10 -! -!----------------------------------------------------------------------- -!*** Write out NEMSIO ctl file. -!----------------------------------------------------------------------- -! - CALL WRITE_NEMSIOCTL(GLOBAL,IHOUR_FCST,IDAY_FCST,IMONTH_FCST, & - IYEAR_FCST,FILENAME,TLMETA,IM,JM,LM,NSOIL,TLM0D,TPH0D,DXCTL, & - DYCTL,NF_HOURS,NREC,RECNAME,RECLEVTYP,CNT,FILE_ENDIAN, & - ID_DOMAIN) - ENDIF -! -!----------------------------------------------------------------------- -!*** Clean up -!----------------------------------------------------------------------- -! - DEALLOCATE(VCOORD,DX,DY) - DEALLOCATE(VARINAME,VARIVAL,ARYINAME,ARYILEN,ARYIVAL) - DEALLOCATE(VARRNAME,VARRVAL,ARYRNAME,ARYRLEN,ARYRVAL) - DEALLOCATE(VARLNAME,VARLVAL) -! -!----------------------------------------------------------------------- -! - END SUBROUTINE WRITE_NEMSIO_RUNHISTORY_OPEN -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE WRITE_RUNRESTART_OPEN(WRT_INT_STATE & - ,IYEAR_FCST & - ,IMONTH_FCST & - ,IDAY_FCST & - ,IHOUR_FCST & - ,IMINUTE_FCST & - ,SECOND_FCST & - ,NTIMESTEP & - ,NF_HOURS & - ,NF_MINUTES & - ,NF_SECONDS & - ,RST_FIRST & - ,LEAD_WRITE_TASK ) -! -!----------------------------------------------------------------------- -!*** Write out a binary run restart file. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(WRITE_INTERNAL_STATE),INTENT(INOUT) :: WRT_INT_STATE !<-- The Write component's internal state -! - INTEGER,INTENT(IN) :: IYEAR_FCST & - ,IMONTH_FCST & - ,IDAY_FCST & - ,IHOUR_FCST & - ,IMINUTE_FCST & - ,LEAD_WRITE_TASK & - ,NF_HOURS & - ,NF_MINUTES & - ,NTIMESTEP -! - LOGICAL,INTENT(IN) :: RST_FIRST -! - REAL,INTENT(IN) :: NF_SECONDS,SECOND_FCST -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER :: N,N1,N2,NPOSN_1,NPOSN_2,LENGTH - INTEGER :: NFIELD,RC - CHARACTER(ESMF_MAXSTR) :: NAME - INTEGER,DIMENSION(:),POINTER :: WORK_ARRAY_I1D - REAL(4),DIMENSION(:),POINTER :: WORK_ARRAY_R1D - LOGICAL :: WRITE_LOGICAL - LOGICAL :: WORK_LOGICAL -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!----------------------------------------------------------------------- -!*** Open the restart file and write the current forecast time -!*** and elapsed time. -!----------------------------------------------------------------------- -! - CALL OPEN_RST_FILE(WRT_INT_STATE) -! - WRITE(wrt_int_state%IO_RST_UNIT,iostat=RC)IYEAR_FCST - WRITE(wrt_int_state%IO_RST_UNIT,iostat=RC)IMONTH_FCST - WRITE(wrt_int_state%IO_RST_UNIT,iostat=RC)IDAY_FCST - WRITE(wrt_int_state%IO_RST_UNIT,iostat=RC)IHOUR_FCST - WRITE(wrt_int_state%IO_RST_UNIT,iostat=RC)IMINUTE_FCST - WRITE(wrt_int_state%IO_RST_UNIT,iostat=RC)SECOND_FCST - WRITE(wrt_int_state%IO_RST_UNIT,iostat=RC)NTIMESTEP -! - IF(RST_FIRST .AND. (wrt_int_state%PRINT_OUTPUT .OR. wrt_int_state%PRINT_ALL) )THEN - WRITE(0,*)' Wrote IYEAR_FCST to restart file unit ',wrt_int_state%IO_RST_UNIT - WRITE(0,*)' Wrote IMONTH_FCST to restart file unit ',wrt_int_state%IO_RST_UNIT - WRITE(0,*)' Wrote IDAY_FCST to restart file unit ',wrt_int_state%IO_RST_UNIT - WRITE(0,*)' Wrote IHOUR_FCST to restart file unit ',wrt_int_state%IO_RST_UNIT - WRITE(0,*)' Wrote IMINUTE_FCST to restart file unit ',wrt_int_state%IO_RST_UNIT - WRITE(0,*)' Wrote SECOND_FCST to restart file unit ',wrt_int_state%IO_RST_UNIT - WRITE(0,*)' Wrote NTIMESTEP to restart file unit ',wrt_int_state%IO_RST_UNIT - ENDIF -! -!----------------------------------------------------------------------- -!*** Integer scalar/1-D restart variables -!----------------------------------------------------------------------- -! - N2=0 !<-- Word counter for full string of integer scalar/1D data -! - DO N=1,wrt_int_state%RST_KOUNT_I1D(1) !<-- Loop through all scalar/1D integer data -! - NPOSN_1=(N-1)*ESMF_MAXSTR+1 - NPOSN_2=N*ESMF_MAXSTR - NAME=wrt_int_state%RST_NAMES_I1D_STRING(NPOSN_1:NPOSN_2) !<-- The variable's name - LENGTH=wrt_int_state%RST_LENGTH_DATA_I1D(N) !<-- The variable's length in words - ALLOCATE(WORK_ARRAY_I1D(LENGTH),stat=RC) -! - DO N1=1,LENGTH - N2=N2+1 - WORK_ARRAY_I1D(N1)=wrt_int_state%RST_ALL_DATA_I1D(N2) !<-- Extract the individual data from the data string - ENDDO -! - WRITE(wrt_int_state%IO_RST_UNIT,iostat=RC)WORK_ARRAY_I1D !<-- Write out the data -! - IF(RST_FIRST .AND. (wrt_int_state%PRINT_OUTPUT .OR. wrt_int_state%PRINT_ALL) )THEN - WRITE(0,*)'Wrote ',TRIM(NAME),' to restart file unit ',wrt_int_state%IO_RST_UNIT - ENDIF -! - DEALLOCATE(WORK_ARRAY_I1D) -! - ENDDO -! -!----------------------------------------------------------------------- -!*** Real scalar/1-D restart variables -!----------------------------------------------------------------------- -! - N2=0 !<-- Word counter for full string of real scalar/1D data -! - DO N=1,wrt_int_state%RST_KOUNT_R1D(1) !<-- Loop through all scalar/1D real data -! - NPOSN_1=(N-1)*ESMF_MAXSTR+1 - NPOSN_2=N*ESMF_MAXSTR - NAME=wrt_int_state%RST_NAMES_R1D_STRING(NPOSN_1:NPOSN_2) !<-- The variable's name - LENGTH=wrt_int_state%RST_LENGTH_DATA_R1D(N) !<-- The variable's length - ALLOCATE(WORK_ARRAY_R1D(LENGTH),stat=RC) -! - DO N1=1,LENGTH - N2=N2+1 - WORK_ARRAY_R1D(N1)=wrt_int_state%RST_ALL_DATA_R1D(N2) !<-- Extract the individual data from the data string - ENDDO -! - WRITE(wrt_int_state%IO_RST_UNIT,iostat=RC)WORK_ARRAY_R1D !<-- Write out the data -! - IF(RST_FIRST .AND. (wrt_int_state%PRINT_OUTPUT .OR. wrt_int_state%PRINT_ALL) )THEN - WRITE(0,*)'Wrote ',TRIM(NAME),' to restart file unit ',wrt_int_state%IO_RST_UNIT - ENDIF -! - DEALLOCATE(WORK_ARRAY_R1D) -! - ENDDO -! -!----------------------------------------------------------------------- -!*** Logical restart variables -!----------------------------------------------------------------------- -! - N2=0 !<-- Counter for full string of logical data -! - DO N=1,wrt_int_state%RST_KOUNT_LOG(1) !<-- Loop through all logical data -! - NPOSN_1=(N-1)*ESMF_MAXSTR+1 - NPOSN_2=N*ESMF_MAXSTR - NAME=wrt_int_state%RST_NAMES_LOG_STRING(NPOSN_1:NPOSN_2) !<-- The variable's name -! - N2=N2+1 - WORK_LOGICAL = wrt_int_state%RST_ALL_DATA_LOG(N2) - WRITE_LOGICAL=WORK_LOGICAL !<-- Convert from ESMF_Logical to F90 logical -! - WRITE(wrt_int_state%IO_RST_UNIT,iostat=RC)WRITE_LOGICAL !<-- Write out the data -! - IF(RST_FIRST .AND. (wrt_int_state%PRINT_OUTPUT .OR. wrt_int_state%PRINT_ALL) )THEN - WRITE(0,*)'Wrote ',TRIM(NAME),' to restart file unit ',wrt_int_state%IO_RST_UNIT - ENDIF -! - ENDDO -! -!----------------------------------------------------------------------- -! - END SUBROUTINE WRITE_RUNRESTART_OPEN -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE WRITE_NEMSIO_RUNRESTART_OPEN(WRT_INT_STATE & - ,NEMSIOFILE & - ,IYEAR_FCST & - ,IMONTH_FCST & - ,IDAY_FCST & - ,IHOUR_FCST & - ,IMINUTE_FCST & - ,SECOND_FCST & - ,NTIMESTEP & - ,NF_HOURS & - ,NF_MINUTES & - ,NF_SECONDS & - ,DIM1,DIM2,NFRAME,GLOBAL & - ,ID_DOMAIN & - ,LEAD_WRITE_TASK) -! -!----------------------------------------------------------------------- -!*** Write out a NEMSIO binary run history file. -!----------------------------------------------------------------------- -! -!------------------------ -!*** Argument Variables -!------------------------ -! - TYPE(WRITE_INTERNAL_STATE),INTENT(INOUT) :: WRT_INT_STATE !<-- The Write component's internal state -! - TYPE(NEMSIO_GFILE),INTENT(INOUT) :: NEMSIOFILE !<-- The nemsio file handler -! - INTEGER,INTENT(IN) :: IYEAR_FCST & - ,IMONTH_FCST & - ,IDAY_FCST & - ,IHOUR_FCST & - ,IMINUTE_FCST & - ,NF_HOURS & - ,NF_MINUTES & - ,ID_DOMAIN & - ,LEAD_WRITE_TASK & - ,NTIMESTEP - - INTEGER,INTENT(OUT) :: DIM1,DIM2,NFRAME - LOGICAL,INTENT(OUT) :: GLOBAL -! - REAL,INTENT(IN) :: NF_SECONDS & - ,SECOND_FCST -! -!--------------------- -!*** Local Variables -!--------------------- -! - INTEGER :: I,J,N,N1,N2,NPOSN_1,NPOSN_2,LENGTH,MAXLENGTH -! - INTEGER :: FIELDSIZE,IM,JM,LM,IDATE(7),FCSTDATE(7) & - ,INDX_2D,IRET,IND1,IND2,IND3,IND4,IND5,CNT & - ,INI1,INI2,INI3 & - ,N2ISCALAR,N2IARY,N2RSCALAR,N2RARY,N2LSCALAR & - ,NMETA,NSOIL,TLMETA,VLEV -! - INTEGER :: FRAC_SEC,INT_SEC,NFIELD,RC -! - INTEGER,DIMENSION(:),POINTER :: ARYILEN & - ,ARYRLEN & - ,RECLEV & - ,VARIVAL -! - INTEGER,DIMENSION(:,:),POINTER :: ARYIVAL -! - REAL(4) :: DEGRAD,DXCTL,DYCTL,TPH0D,TLM0D -! - REAL(4),DIMENSION(:),POINTER :: DX,DY,DXH & - ,GLAT1D,GLON1D -! - REAL(4),DIMENSION(:,:,:),POINTER :: VCOORD -! - REAL(KIND=KFPT),DIMENSION(:) ,POINTER :: VARRVAL - REAL(KIND=KFPT),DIMENSION(:,:),POINTER :: ARYRVAL -! - LOGICAL,DIMENSION(:),POINTER :: VARLVAL -! - CHARACTER(6) :: MODEL_LEVEL - CHARACTER(16) :: VLEVTYP,FILE_ENDIAN -! - CHARACTER(16),DIMENSION(:),POINTER :: ARYINAME & - ,ARYRNAME & - ,RECNAME & - ,VARINAME & - ,VARRNAME & - ,VARLNAME -! - CHARACTER(16),DIMENSION(:),POINTER :: RECLEVTYP -! - CHARACTER(ESMF_MAXSTR) :: NAME,FILENAME - - LOGICAL :: WORK_LOGICAL - - INTEGER :: NDYH=0,NDXH=0,NPT=0,NPDTOP=0,NREC=0 & - ,NSG1=0,NSG2=0,NSGML1=0,NSGML2=0 -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! - FCSTDATE(1)=IYEAR_FCST - FCSTDATE(2)=IMONTH_FCST - FCSTDATE(3)=IDAY_FCST - FCSTDATE(4)=IHOUR_FCST - FCSTDATE(5)=IMINUTE_FCST - FCSTDATE(6)=NINT(SECOND_FCST*100.) - FCSTDATE(7)=100 -! -!----------------------------------------------------------------------- -!*** Integer scalar/1-D history variables -!----------------------------------------------------------------------- -! -!------------------------------------------------------------- -!*** Find out the total number of int scalars and int arrays. -!------------------------------------------------------------- -! - N2ISCALAR=0 - N2IARY=0 - MAXLENGTH=1 -! - DO N=1,wrt_int_state%RST_KOUNT_I1D(1) !<-- Loop through all scalar/1D integer data - LENGTH=wrt_int_state%RST_LENGTH_DATA_I1D(N) -! - IF(LENGTH==1)THEN - N2ISCALAR=N2ISCALAR+1 - ELSE - N2IARY=N2IARY+1 - MAXLENGTH=MAX(LENGTH,MAXLENGTH) - ENDIF -! - ENDDO -! - N2ISCALAR=N2ISCALAR+1 - N2IARY=N2IARY+1 - MAXLENGTH=MAX(MAXLENGTH,7) - ALLOCATE(VARINAME(N2ISCALAR),VARIVAL(N2ISCALAR)) - ALLOCATE(ARYINAME(N2IARY),ARYILEN(N2IARY),ARYIVAL(MAXLENGTH,N2IARY)) -! -!--------------------------------------- -!*** Set value to AVRIVAL and ARYIVAL. -!--------------------------------------- -! - N2=0 !<-- Word counter for full string of integer scalar/1D data - N2ISCALAR=0 - N2IARY=0 - IDATE=0 -! - DO N=1,wrt_int_state%RST_KOUNT_I1D(1) !<-- Loop through all scalar/1D integer data -! - NPOSN_1=(N-1)*ESMF_MAXSTR+1 - NPOSN_2=N*ESMF_MAXSTR - NAME=wrt_int_state%RST_NAMES_I1D_STRING(NPOSN_1:NPOSN_2) !<-- The variable's name - LENGTH=wrt_int_state%RST_LENGTH_DATA_I1D(N) !<-- The variable's length in words -! - IF(LENGTH==1)THEN - N2=N2+1 - N2ISCALAR=N2ISCALAR+1 - VARINAME(N2ISCALAR)=TRIM(NAME) - VARIVAL(N2ISCALAR)=wrt_int_state%RST_ALL_DATA_I1D(N2) -! if(n2==10)then -! write(0,*)' WRITE_NEMSIO_RUNRESTART_OPEN n2iscalar=',n2iscalar & -! ,' VARIVAL(N2ISCALAR)=',VARIVAL(N2ISCALAR),' variname=',variname(n2iscalar) -! endif - IF(VARINAME(N2ISCALAR)=='IHRST') then - IDATE(4)=VARIVAL(N2ISCALAR) - ENDIF - ELSE - N2IARY=N2IARY+1 - ARYINAME(N2IARY)=TRIM(NAME) - ARYILEN(N2IARY)=LENGTH -! write(0,*)'in I1D array,aryiname=',aryiname(N2IARY),'len=',aryilen(N2IARY), & -! wrt_int_state%RST_ALL_DATA_I1D(N2+1:N2+length) -! - DO N1=1,LENGTH - N2=N2+1 - ARYIVAL(N1,N2IARY)=wrt_int_state%RST_ALL_DATA_I1D(N2) !<-- Extract the individual data from the data string - ENDDO - - IF(ARYINAME(N2IARY)=='IDAT') THEN - IDATE(1)=ARYIVAL(3,N2IARY) - IDATE(2)=ARYIVAL(2,N2IARY) - IDATE(3)=ARYIVAL(1,N2IARY) - IDATE(7)=100. - ENDIF -! -! write(0,*)'in I1D array,aryival=',aryival(:,N2IARY) - ENDIF -! - ENDDO -!------------------------------ -!*** Add ntimestep into VARI. -!------------------------------ -! - N2ISCALAR= N2ISCALAR+1 - VARINAME(N2ISCALAR)='NTIMESTEP' - VARIVAL(N2ISCALAR)=NTIMESTEP -! write(0,*)'in I1D scalar,varival=',varival,'varname=',variname -! -! -!------------------------------ -!*** Add fcst_date into ARYI. -!------------------------------ -! - N2IARY=N2IARY+1 - ARYINAME(N2IARY)='FCSTDATE' - ARYILEN(N2IARY)=7 - ARYIVAL(1:7,N2IARY)=FCSTDATE(1:7) -! -!----------------------------------------------------------------------- -!*** Real scalar/1-D history variables -!----------------------------------------------------------------------- -! -!------------------------------------------------------------ -!*** Find the total number of real scalars and real arrays. -!------------------------------------------------------------ -! - N2RSCALAR=0 - N2RARY=0 - MAXLENGTH=1 -! - DO N=1,wrt_int_state%RST_KOUNT_R1D(1) !<-- Loop through all scalar/1D real data - LENGTH=wrt_int_state%RST_LENGTH_DATA_R1D(N) !<-- The variable's length - IF(LENGTH==1)THEN - N2RSCALAR=N2RSCALAR+1 - ELSE - N2RARY=N2RARY+1 - MAXLENGTH=MAX(LENGTH,MAXLENGTH) - ENDIF - ENDDO -! - ALLOCATE(VARRNAME(N2RSCALAR),VARRVAL(N2RSCALAR)) - ALLOCATE(ARYRNAME(N2RARY),ARYRLEN(N2RARY),ARYRVAL(MAXLENGTH,N2RARY)) -! -!------------------------------------------------------ -!*** Set values for the real scalars and real arrays. -!------------------------------------------------------ - N2=0 !<-- Word counter for full string of real scalar/1D data - N2RSCALAR=0 - N2RARY=0 -! - DO N=1,wrt_int_state%RST_KOUNT_R1D(1) !<-- Loop through all scalar/1D real data -! - NPOSN_1=(N-1)*ESMF_MAXSTR+1 - NPOSN_2=N*ESMF_MAXSTR - NAME=wrt_int_state%RST_NAMES_R1D_STRING(NPOSN_1:NPOSN_2) !<-- The variable's name - LENGTH=wrt_int_state%RST_LENGTH_DATA_R1D(N) !<-- The variable's length -! - IF(LENGTH==1)THEN - N2=N2+1 - N2RSCALAR=N2RSCALAR+1 - VARRNAME(N2RSCALAR)=TRIM(NAME) - VARRVAL(N2RSCALAR)=wrt_int_state%RST_ALL_DATA_R1D(N2) -! - IF( TRIM(NAME)=='PT') THEN - NPT=N2RSCALAR - ELSEIF ( TRIM(NAME)=='PDTOP') THEN - NPDTOP=N2RSCALAR - ELSEIF ( TRIM(NAME)=='DYH') THEN - NDYH=N2RSCALAR - ELSEIF ( TRIM(NAME)=='TPH0D') THEN - TPH0D=VARRVAL(N2RSCALAR) - ELSEIF ( trim(NAME)=='TLM0D') THEN - TLM0D=VARRVAL(N2RSCALAR) - ENDIF -! - ELSE - N2RARY=N2RARY+1 - ARYRNAME(N2RARY)=TRIM(NAME) - ARYRLEN(N2RARY)=LENGTH -! - DO N1=1,LENGTH - N2=N2+1 - ARYRVAL(N1,N2RARY)=wrt_int_state%RST_ALL_DATA_R1D(N2) !<-- Extract the individual data from the data string - ENDDO -! - IF( TRIM(NAME)=='SG1') THEN - NSG1=N2RARY - ELSEIF ( TRIM(NAME)=='SG2') THEN - NSG2=N2RARY - ELSEIF ( TRIM(NAME)=='SGML1' ) THEN - NSGML1=N2RARY - ELSEIF (TRIM(NAME)=='SGML2') THEN - NSGML2=N2RARY - ELSEIF (TRIM(NAME)=='DXH') THEN - NDXH=N2RARY - ENDIF - - ENDIF -! - ENDDO -! -!----------------------------------------------------------------------- -!*** Logical history variables -!----------------------------------------------------------------------- -! - N2LSCALAR=wrt_int_state%RST_KOUNT_LOG(1) !<-- Counter for full string of logical data -! - ALLOCATE(VARLNAME(N2LSCALAR),VARLVAL(N2LSCALAR)) - N2LSCALAR=0 -! - DO N=1,wrt_int_state%RST_KOUNT_LOG(1) !<-- Loop through all logical data -! - NPOSN_1=(N-1)*ESMF_MAXSTR+1 - NPOSN_2=N*ESMF_MAXSTR - NAME=wrt_int_state%RST_NAMES_LOG_STRING(NPOSN_1:NPOSN_2) !<-- The variable's name -! - N2LSCALAR=N2LSCALAR+1 - - WORK_LOGICAL = wrt_int_state%RST_ALL_DATA_LOG(N2LSCALAR) - - VARLNAME(N2LSCALAR)=NAME - - VARLVAL(N2LSCALAR)=wrt_int_state%RST_ALL_DATA_LOG(N2LSCALAR) - - IF(TRIM(NAME)=='GLOBAL') GLOBAL=WORK_LOGICAL -! - ENDDO -! -!----------------------------------------------------------------------- -!*** Now open NEMSIO file. -!----------------------------------------------------------------------- -! - N=LEN_TRIM(wrt_int_state%RST_NAME_BASE) - INT_SEC=INT(wrt_int_state%NFSECONDS) - FRAC_SEC=NINT((wrt_int_state%NFSECONDS-INT_SEC)*100.) - WRITE(FILENAME,100)wrt_int_state%RST_NAME_BASE(1:N)//'_nio_' & - ,wrt_int_state%NFHOURS,'h_' & - ,wrt_int_state%NFMINUTES,'m_' & - ,INT_SEC,'.',FRAC_SEC,'s' - IF(wrt_int_state%PRINT_OUTPUT .OR. wrt_int_state%PRINT_ALL) & - write(0,*)'FILENAME=',trim(FILENAME),'n=',n - 100 FORMAT(A,I4.4,A,I2.2,A,I2.2,A,I2.2,A) -! -!---------------------------------------------------- -!*** Prepare variables needed by the nemsip header: -!---------------------------------------------------- -! -!dimension - IF(GLOBAL) THEN -!for global im/jm for data field - NFRAME=1 - ELSE -!for regional - NFRAME=0 - ENDIF - IM=wrt_int_state%im(1) - JM=wrt_int_state%jm(1) - DIM1=wrt_int_state%im(1)-2*NFRAME - DIM2=wrt_int_state%jm(1)-2*NFRAME -! - LM=wrt_int_state%LM(1) -! -!for nmmb trimmed domain - FIELDSIZE=IM*JM - NREC=wrt_int_state%RST_KOUNT_I2D(1)+wrt_int_state%RST_KOUNT_R2D(1)+2 !add fact10 for GSI - !add hgt for unified code -! -!vcoord - ALLOCATE(VCOORD(LM+1,3,2)) - VCOORD=0. - if(NSG1>0.and.NSG2>0.and.NPT>0.and.NPDTOP>0 ) THEN - VCOORD(1:LM+1,1,1)=0.1*(ARYRVAL(1:LM+1,NSG1)*VARRVAL(NPDTOP) & - -ARYRVAL(1:LM+1,NSG2)*(VARRVAL(NPDTOP)+VARRVAL(NPT)) & - +VARRVAL(NPT) ) - VCOORD(1:LM+1,2,1)=ARYRVAL(1:LM+1,NSG2) - VCOORD(1:LM+1,3,1)=0 - ENDIF - if(NSGML1>0.and.NSGML2>0.and.NPT>0.and.NPDTOP>0 ) THEN - VCOORD(1:LM,1,2)=0.1*(ARYRVAL(1:LM,NSGML1)*VARRVAL(NPDTOP) & - -ARYRVAL(1:LM,NSGML2)*(VARRVAL(NPDTOP)+VARRVAL(NPT)) & - +VARRVAL(NPT) ) - VCOORD(1:LM,2,2)=ARYRVAL(1:LM,NSGML2) - VCOORD(1:LM,3,2)=0 - ENDIF -!!! write(0,*)'after vcoord,count_I2d=',wrt_int_state%rst_kount_I2D(1),'nrec=',nrec -! -!----------------------------------------------------------------------- -!*** Cut the output I2D array. -!----------------------------------------------------------------------- -! - ALLOCATE(RECNAME(NREC),RECLEVTYP(NREC),RECLEV(NREC)) - NREC=0 - INI1=0 !<-- # of 1-layer vars - INI2=0 !<-- # of total layes of vars with lm layers - INI3=0 !<-- # of total layes of vars with lm+1 layers -! - DO NFIELD=1,wrt_int_state%RST_KOUNT_I2D(1) -! - NREC=NREC+1 - NPOSN_1=(NFIELD-1)*ESMF_MAXSTR+1 - NPOSN_2=NFIELD*ESMF_MAXSTR - NAME=wrt_int_state%RST_NAMES_I2D_STRING(NPOSN_1:NPOSN_2) !<-- The name of this 2D integer history quantity - INDX_2D=index(NAME,"_2D") -! - IF (INDX_2D > 0) THEN - MODEL_LEVEL=NAME(INDX_2D-3:INDX_2D-1) - RECLEV(NREC)=(ICHAR(MODEL_LEVEL(1:1))-48)*100+(ICHAR(MODEL_LEVEL(2:2))-48)*10+ICHAR(MODEL_LEVEL(3:3))-48 - RECNAME(NREC)=NAME(1:INDX_2D-5) - RECLEVTYP(NREC)='mid_layer' - IF (RECLEV(NREC)==LM+1) THEN - RECLEVTYP(NREC-LM:NREC)='layer' - INI3=INI3+LM+1 - INI2=INI2-(LM+1) - ENDIF - INI2=INI2+1 - ELSE - RECNAME(NREC)=TRIM(NAME) - RECLEV(NREC)=1 - RECLEVTYP(NREC)='sfc' - INI1=INI1+1 - ENDIF -! - IF (RECNAME(NREC)=='ISLTYP') RECNAME(NREC)='sltyp' - IF (RECNAME(NREC)=='IVGTYP') RECNAME(NREC)='vgtyp' - IF (RECNAME(NREC)=='NCFRCV') RECNAME(NREC)='cfrcv' - IF (RECNAME(NREC)=='NCFRST') RECNAME(NREC)='cfrst' - CALL LOWERCASE(RECNAME(NREC)) - ENDDO -! -! write(0,*)'after I2D,nrec=',nrec -! -!----------------------------------------------------------------------- -!*** Cut the output R2D array. -!----------------------------------------------------------------------- -! - NSOIL=0 - IND1=0 !<-- # of 1-layer vars - IND2=0 !<-- # of total layers for vars with lm layers - IND3=0 !<-- # of total layers for vars with lm+1 layers - IND4=0 !<-- # of total layers for vars with nsoil layers - IND5=0 !<-- # of total layers for vars with lm-1 layers -! - DO NFIELD=1,wrt_int_state%RST_KOUNT_R2D(1) -! - NREC=NREC+1 - NPOSN_1=(NFIELD-1)*ESMF_MAXSTR+1 - NPOSN_2=NFIELD*ESMF_MAXSTR - NAME=wrt_int_state%RST_NAMES_R2D_STRING(NPOSN_1:NPOSN_2) !<-- The name of this 2D integer history quantity - INDX_2D=INDEX(NAME,"_2D") -! - IF (INDX_2D > 0) THEN - MODEL_LEVEL=NAME(INDX_2D-3:INDX_2D-1) - RECLEV(NREC)=(ICHAR(MODEL_LEVEL(1:1))-48)*100+(ICHAR(MODEL_LEVEL(2:2))-48)*10+ICHAR(MODEL_LEVEL(3:3))-48 - RECNAME(NREC)=NAME(1:INDX_2D-5) - RECLEVTYP(NREC)='mid layer' - IF (RECNAME(NREC)=='SMC') NSOIL=NSOIL+1 - IF (RECNAME(NREC)=='W') RECNAME(NREC)='vvel' - IF (RECNAME(NREC)=='CW') RECNAME(NREC)='clwmr' - IF (RECNAME(NREC)=='U') RECNAME(NREC)='ugrd' - IF (RECNAME(NREC)=='V') RECNAME(NREC)='vgrd' - IF (RECNAME(NREC)=='T') RECNAME(NREC)='tmp' - IF (RECNAME(NREC)=='Q') RECNAME(NREC)='spfh' - IF (RECNAME(NREC)=='O3') RECNAME(NREC)='o3mr' - IF (RECLEV(NREC)==LM+1) THEN - RECLEVTYP(NREC-LM:NREC)='layer' - IND3=IND3+LM+1 - IND2=IND2-(LM+1) - ENDIF - IF (RECNAME(NREC)=='PSGDT') THEN - RECLEVTYP(NREC)='layerm1' - IF (RECLEV(NREC)==LM-1) THEN - IND5=IND5+LM-1 - IND2=IND2-(LM-1) - ENDIF - ENDIF - IF (RECNAME(NREC)=='PINT') THEN - RECNAME(NREC)='pres' - ELSE IF (RECNAME(NREC)=='SMC'.OR.RECNAME(NREC)=='SH2O'.or.RECNAME(NREC)=='STC') THEN - RECLEVTYP(NREC)='soil layer' - IND4=IND4+1 - IND2=IND2-1 - ENDIF - IND2=IND2+1 - ELSE - RECLEV(NREC)=1 - RECNAME(NREC)=TRIM(NAME) - RECLEVTYP(NREC)='sfc' -! - IF (INDEX(RECNAME(NREC),"10")>0) RECLEVTYP(NREC)='10 m above gnd' - IF (RECNAME(NREC)=='PD') THEN - RECNAME(NREC)='dpres' - RECLEVTYP(NREC)='hybrid sig lev' - ENDIF -! - IF (RECNAME(NREC)=='SST') RECNAME(NREC)='tsea' - IF (RECNAME(NREC)=='USTAR') RECNAME(NREC)='uustar' - IF (RECNAME(NREC)=='Z0') RECNAME(NREC)='zorl' - IND1=IND1+1 - ENDIF -! - CALL LOWERCASE(RECNAME(NREC)) - ENDDO -! write(0,*)'after R2D,nrec=',nrec,'kount_r2d=',wrt_int_state%RST_KOUNT_R2D(1) -! -!for fact10 - NREC=NREC+1 - RECNAME(NREC)='fact10' - RECLEVTYP(NREC)='10 m above gnd' - RECLEV(NREC)=1 -!for hgt - NREC=NREC+1 - RECNAME(NREC)='hgt' - RECLEVTYP(NREC)='sfc' - RECLEV(NREC)=1 -! -!glat1d and glon1d - ALLOCATE(GLAT1D(FIELDSIZE),GLON1D(FIELDSIZE)) - DEGRAD=90./ASIN(1.) - glon1d=0. - glat1d=0. - NMETA=12 -! write(0,*)'after glat1d,NDYH=',ndyh -! -!dx and dy - ALLOCATE(DX(FIELDSIZE),DY(FIELDSIZE)) -! - if(NDXH>0) then - DO J=1,JM - DO I=1,IM - DX(I+(J-1)*IM)=ARYRVAL(J,NDXH) - ENDDO - ENDDO -! write(0,*)'after dx=',maxval(dx),minval(dx),'dy=',maxval(dy),minval(dy) - else - NMETA=7 - endif -! - if(NDYH>0) then - DO I=1,FIELDSIZE - DY(I)=VARRVAL(NDYH) - ENDDO - endif -! write(0,*)'after DY,nrec=',nrec - -! -!----------------------------------------------------------------------- -! SET UP NEMSIO WRITE -!----------------------------------------------------------------------- -! - CALL NEMSIO_INIT(IRET=IRET) -! -!----------------------------------------------------------------------- -!*** Open NEMSIO file -!----------------------------------------------------------------------- -! - CALL NEMSIO_OPEN(NEMSIOFILE,trim(FILENAME),'write',iret, & - modelname="NMMB", gdatatype="bin4", idate=IDATE,nfhour=NF_HOURS, & - nfminute=NF_MINUTES,nfsecondn=nint(NF_SECONDS*100), & - nfsecondd=100,dimx=DIM1,dimy=DIM2,dimz=LM,nframe=NFRAME, & - nmeta=NMETA, & - nsoil=NSOIL,ntrac=3,nrec=nrec, ncldt=1,rlon_min=minval(glon1d), & - rlon_max=maxval(glon1d), rlat_max=maxval(glat1d), & - rlat_min=minval(glat1d),vcoord=vcoord,lon=glon1d,lat=glat1d, & - dx=dx,dy=dy,extrameta=.true.,nmetavari=N2ISCALAR, & - nmetavarr=N2RSCALAR,nmetavarl=N2LSCALAR,nmetaaryi=N2IARY, & - nmetaaryr=N2RARY,variname=VARINAME,varival=VARIVAL, & - varrname=VARRNAME,varrval=VARRVAL,varlname=VARLNAME, & - varlval=VARLVAL,aryiname=ARYINAME,aryilen=ARYILEN, & - aryival=ARYIVAL,aryrname=ARYRNAME,aryrlen=ARYRLEN, & - aryrval=ARYRVAL,recname=RECNAME,reclevtyp=RECLEVTYP,reclev=RECLEV) -! -! write(0,*)' WRITE_NEMSIO_RUNRESTART_OPEN after NEMSIO_OPEN variname(10)=',variname(10) & -! ,' varival(10)=',varival(10) -!----------------------------------------------------------------------- -!*** Get variables needed by the .ctl file. -!----------------------------------------------------------------------- -! - IF(wrt_int_state%WRITE_NEMSIOCTL.AND.wrt_int_state%MYPE==LEAD_WRITE_TASK)THEN - CALL NEMSIO_GETFILEHEAD(NEMSIOFILE,TLMETA=TLMETA,FILE_ENDIAN=FILE_ENDIAN) - DXCTL=MAXVAL(DX)*180./(A*PI) - DYCTL=MAXVAL(DY)*180./(A*PI) - CNT=INI1 & ! # of integer 1-layer fields - +(INI2/LM) & ! # of integer lm-layer fields - +(INI3/(LM+1)) & ! # of integer lm+1-layer fields - +IND1 & ! # of real 1-layer fields - +(IND2/LM) & ! # of real lm-layer fields - +(IND3/(LM+1)) & ! # of real lm+1-layer fields - +(IND4/NSOIL) & ! # of real nsoil-layer fields - +(IND5/(LM-1)) & ! # of real lm-1-layer fields - +2 ! fact10 and hgt -! -!----------------------------------------------------------------------- -!*** Write out NEMSIO ctl file. -!----------------------------------------------------------------------- -! - CALL WRITE_NEMSIOCTL(GLOBAL,IHOUR_FCST,IDAY_FCST,IMONTH_FCST, & - IYEAR_FCST,FILENAME,TLMETA,IM,JM,LM,NSOIL,TLM0D,TPH0D,DXCTL, & - DYCTL,NF_HOURS,NREC,RECNAME,RECLEVTYP,CNT,FILE_ENDIAN, & - ID_DOMAIN) - ENDIF -! -!----------------------------------------------------------------------- -!*** Clean up -!----------------------------------------------------------------------- -! - DEALLOCATE(VCOORD,DX,DY) - DEALLOCATE(VARINAME,VARIVAL,ARYINAME,ARYILEN,ARYIVAL) - DEALLOCATE(VARRNAME,VARRVAL,ARYRNAME,ARYRLEN,ARYRVAL) - DEALLOCATE(VARLNAME,VARLVAL) -! -!----------------------------------------------------------------------- -! - END SUBROUTINE WRITE_NEMSIO_RUNRESTART_OPEN -! -!----------------------------------------------------------------------- -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!----------------------------------------------------------------------- -! - SUBROUTINE WRITE_NEMSIOCTL(GLOBAL,IHOUR_FCST,IDAY_FCST,IMONTH_FCST, & - IYEAR_FCST,FILENAME,TLMETA,DIM1,DIM2,LM,NSOIL,TLM0D,TPH0D,DXCTL, & - DYCTL,NF_HOURS,NREC,RECNAME,RECLEVTYP,KOUNT_R2D,FILE_ENDIAN, & - ID_DOMAIN) -! -!----------------------------------------------------------------------- -!*** Write out ctl file. -!----------------------------------------------------------------------- -! -!----------------------- -!*** Argument Variables -!----------------------- -! - INTEGER,INTENT(IN) :: DIM1,DIM2 & - ,IHOUR_FCST,IDAY_FCST,IMONTH_FCST,IYEAR_FCST & - ,LM,NF_HOURS,NREC,NSOIL,TLMETA,KOUNT_R2D -! - REAL,INTENT(IN) :: DXCTL,DYCTL,TLM0D,TPH0D -! - LOGICAL,INTENT(IN) :: GLOBAL -! - CHARACTER(*) ,INTENT(IN) :: FILENAME - CHARACTER(16),INTENT(IN) :: RECNAME(:) - CHARACTER(16),INTENT(IN) :: RECLEVTYP(:) - CHARACTER(16),INTENT(IN) :: FILE_ENDIAN -! -!--------------------- -!*** Local Variables -!--------------------- -! -! - INTEGER(KIND=KINT) :: IERR,RC - INTEGER ID_DOMAIN,N,NEWDIM1,NEWDIM2,IO_UNIT -! - REAL CRSDXCTL,CRSDYCTL,RATIO,XBARLON,YBARLAT,MAXLAT,MAXLON,MINLAT,MINLON -! - CHARACTER(3) CMON - CHARACTER(32) DATE - CHARACTER(64) INFILE -! - LOGICAL OPENED -! -!----------------------------------------------------------------------- -!*********************************************************************** -!----------------------------------------------------------------------- -! -!--------------------- -!*** Get unit number -!--------------------- -! - DO N=51,99 - INQUIRE(N,opened=OPENED) - IF(.NOT.OPENED)THEN - IO_UNIT=N - EXIT - ENDIF - ENDDO -! - CALL CMONTH(IMONTH_FCST,CMON) - WRITE(DATE,'(I2.2,A,I2.2,A3,I4.4)')IHOUR_FCST,'Z',IDAY_FCST & - ,CMON,IYEAR_FCST - OPEN(IO_UNIT,file=TRIM(FILENAME)//'.ctl',form='formatted') -! - WRITE(IO_UNIT,105)TRIM(FILENAME) - WRITE(IO_UNIT,106) - WRITE(IO_UNIT,107)FILE_ENDIAN - WRITE(IO_UNIT,108)TLMETA - WRITE(IO_UNIT,109) -! - IF (GLOBAL) THEN - WRITE(IO_UNIT,121)DIM1,DXCTL - WRITE(IO_UNIT,122)DIM2,DYCTl - ELSE - WRITE(IO_UNIT,110)DIM1,DIM2,TLM0D,TPH0D,DXCTL,DYCTL -! -!** Read min and max lat and lon values for each grid from a file -! - WRITE(INFILE,'(A,I2.2)')'lat_lon_bnds_',ID_DOMAIN - OPEN(UNIT=178,FILE=INFILE,STATUS='OLD',FORM='UNFORMATTED') - READ (178)MINLAT,MAXLAT,MINLON,MAXLON - CLOSE(178) -! -!** Create proper nx(newdim1) and ny(newdim2) values for nests -! - IF(ID_DOMAIN.GT.1)THEN - XBARLON=(MAXLON*(180./pi)-MINLON*(180./pi))/2. - YBARLAT=(MAXLAT*(180./pi)-MINLAT*(180./pi))/2. - NEWDIM1=(MAXLON*(180./pi)-MINLON*(180./pi))/DXCTL - NEWDIM2=(MAXLAT*(180./pi)-MINLAT*(180./pi))/DYCTL - WRITE(IO_UNIT,131)NEWDIM1,TLM0D-XBARLON,DXCTL - WRITE(IO_UNIT,132)NEWDIM2,TPH0D-YBARLAT,DYCTL - ELSE -! -!** Create proper nx(newdim1) and ny(newdim2) values for parent domain -! - NEWDIM1=(MAXLON*(180./pi)-MINLON*(180./pi))/DXCTL - NEWDIM2=(MAXLAT*(180./pi)-MINLAT*(180./pi))/DYCTL -! -!** If parent domain nx and ny values are too big, reduce their values, -!** and force either nx or ny to be 1500 depending on which dimension is -!** the largest. This also requires a coarser resolution. Keep the aspect -!** ratio of the domain the same (nx/ny). -! -! IF(NEWDIM1.GT.1500.OR.NEWDIM2.GT.1500)THEN -! IF(NEWDIM1.GT.NEWDIM2)THEN -! RATIO=REAL(NEWDIM1)/REAL(NEWDIM2) -! CRSDXCTL=(NEWDIM1*DXCTL)/1500. -! CRSDYCTL=(NEWDIM2*DYCTL)/(1500./RATIO) -! NEWDIM1=1500 -! NEWDIM2=REAL(NEWDIM1)/RATIO -! ELSEIF(NEWDIM2.GE.NEWDIM1)THEN -! RATIO=REAL(NEWDIM2)/REAL(NEWDIM1) -! CRSDYCTL=(REAL(NEWDIM2)*DYCTL)/1500. -! CRSDXCTL=(REAL(NEWDIM1)*DXCTL)/(1500./RATIO) -! NEWDIM2=1500 -! NEWDIM1=REAL(NEWDIM2)/RATIO -! ENDIF -! WRITE(IO_UNIT,131)NEWDIM1,MINLON*(180./pi),CRSDXCTL -! WRITE(IO_UNIT,132)NEWDIM2,MINLAT*(180./pi),CRSDYCTL -! ELSE - WRITE(IO_UNIT,131)NEWDIM1,MINLON*(180./pi),DXCTL - WRITE(IO_UNIT,132)NEWDIM2,MINLAT*(180./pi),DYCTL -! ENDIF - ENDIF - ENDIF ! global/regional -! - WRITE(IO_UNIT,113)LM - WRITE(IO_UNIT,114)1,TRIM(DATE) -! - 105 FORMAT('dset ^',A) - 106 FORMAT('undef -9.E+20') - 107 FORMAT('options ',A16,' sequential') - 108 FORMAT('fileheader',I12.0) - 109 FORMAT('title EXP1') - - 110 FORMAT('pdef ',I6,I6,' eta.u ',f8.1,f8.1,f12.6,f12.6) - 121 FORMAT('xdef ',I6,' linear -180.000 ',f12.6) - 122 FORMAT('ydef ',I6,' linear -90.000 ',f12.6) - 131 FORMAT('xdef ',I6,' linear ',f8.3,' ',f12.6) - 132 FORMAT('ydef ',I6,' linear ',f8.3,' ',f12.6) - 113 FORMAT('zdef ',I6,' linear 1 1 ') - 114 FORMAT('tdef ',I6,' linear ',A12,' 6hr') -! - WRITE(IO_UNIT,'(A,I6)')'VARS ',KOUNT_R2D - - N=1 - - DO WHILE (N<=NREC) - IF(RECLEVTYP(N)=='mid layer') THEN - WRITE(IO_UNIT,'(A16,I3,A)')RECNAME(N),LM,' 99 mid layer' - N=N+LM - ELSEIF(RECLEVTYP(N)=='layerm1') THEN - WRITE(IO_UNIT,'(A16,I3,A)')RECNAME(N),LM-1,' 99 layer' - N=N+LM-1 - ELSEIF(RECLEVTYP(N)=='layer') THEN - WRITE(IO_UNIT,'(A16,I3,A)')RECNAME(N),LM+1,' 99 layer' - N=N+LM+1 - ELSEIF(RECLEVTYP(N)=='soil layer') THEN - WRITE(IO_UNIT,'(A16,I3,A)')RECNAME(N),NSOIL,' 99 soil layer' - N=N+NSOIL - ELSE - WRITE(IO_UNIT,'(A16,A)')RECNAME(N),' 0 99 sfc' - N=N+1 - ENDIF - ENDDO - - WRITE(IO_UNIT,'(A8)')'endvars' - CLOSE(IO_UNIT) -! -!----------------------------------------------------------------------- -! - END SUBROUTINE WRITE_NEMSIOCTL -! -!----------------------------------------------------------------------- -! - elemental subroutine lowercase(word) -! -!----------------------------------------------------------------------- -!*** convert a word to lower case -!----------------------------------------------------------------------- -! - character (len=*) , intent(inout) :: word - integer :: i,ic,nlen - nlen = len(word) -! - do i=1,nlen - ic = ichar(word(i:i)) - if (ic >= 65 .and. ic < 91) word(i:i) = char(ic+32) - end do -! -! -!----------------------------------------------------------------------- -! - end subroutine lowercase -! -!----------------------------------------------------------------------- -! - SUBROUTINE CMONTH(IMON,CMON) -! -!----------------------------------------------------------------------- -!*** Convert month -!----------------------------------------------------------------------- -! - INTEGER,INTENT(IN) :: IMON - CHARACTER(LEN=3) :: CMON -! -!----------------------------------------------------------------------- -! - SELECT CASE (IMON) - CASE(1) - CMON='Jan' - CASE(2) - CMON='Feb' - CASE(3) - CMON='Mar' - CASE(4) - CMON='Apr' - CASE(5) - CMON='May' - CASE(6) - CMON='Jun' - CASE(7) - CMON='Jul' - CASE(8) - CMON='Aug' - CASE(9) - CMON='Sep' - CASE(10) - CMON='Oct' - CASE(11) - CMON='Nov' - CASE(12) - CMON='Dec' - END SELECT -! -!----------------------------------------------------------------------- -! - END SUBROUTINE CMONTH -! -!----------------------------------------------------------------------- -! - END MODULE MODULE_WRITE_ROUTINES -! -!----------------------------------------------------------------------- diff --git a/src/nmm/n_compns_physics.f b/src/nmm/n_compns_physics.f deleted file mode 100644 index f30a377..0000000 --- a/src/nmm/n_compns_physics.f +++ /dev/null @@ -1,415 +0,0 @@ -!----------------------------------------------------------------------- - subroutine n_compns_physics(deltim, iret, - & ntrac, nxpt, nypt, jintmx, jcap, -! & ntrac, jcap, - & levs, levr, lonr, latr, - & ntoz, ntcw, ncld, lsoil, nmtvr, - & num_p3d, num_p2d, - & thermodyn_id, sfcpress_id, - & nlunit, me, gfs_phy_namelist) -! -!$$$ Subprogram Documentation Block -! -! Subprogram: compns Check and compute namelist frequencies -! Prgmmr: Iredell Org: NP23 Date: 1999-01-26 -! -! Abstract: This subprogram checks global spectral model namelist -! frequencies in hour units for validity. If they are valid, -! then the frequencies are computed in timestep units. -! The following rules are applied: -! 1. the timestep must be positive; -! 2. the output frequency must be positive and -! a multiple of the timestep to within tolerance; -! 3. the shortwave frequency must be positive and -! a multiple of the timestep to within tolerance; -! 4. the longwave frequency must be positive and -! a multiple of the timestep to within tolerance and -! a multiple of the shortwave frequency; -! 5. the zeroing frequency must be positive and -! a multiple of the timestep to within tolerance and -! a multiple of the output frequency; -! 6. the restart frequency must be positive and -! a multiple of the timestep to within tolerance and -! a multiple of the longwave frequency and -! a multiple of the zeroing frequency; -! 7. the initialization window must be non-negative and -! a multiple of the timestep to within tolerance and -! a multiple of the longwave frequency and -! no longer than the restart frequency; -! 8. the cycling frequency must be non-negative and -! a multiple of the timestep to within tolerance and -! a multiple of the longwave frequency. -! -! Program History Log: -! 1999-01-26 Iredell -! 2009-05-04 Moorthi -! 2009-10-12 Sarah Lu, add grid_aldata (default to F) -! 2010-01-12 Sarah Lu, add fdaer (default to 0) -! 2010-08-03 Jun Wang, add fhdfi (default to 0) -! 2010-jul/augMoorthi added many physics options -! -! Usage: call compns(deltim, -! & fhout,fhswr,fhlwr,fhzer,fhres,fhcyc, -! & nsout,nsswr,nslwr,nszer,nsres,nscyc, -! & iret) -! Input Arguments: -! tol - real error tolerance allowed for input frequencies -! (e.g. 0.01 for 1% of timestep maximum error allowed) -! deltim - real timestep in seconds -! fhout - real output frequency in hours -! fhswr - real shortwave frequency in hours -! fhlwr - real longwave frequency in hours -! fhzer - real zeroing frequency in hours -! fhres - real restart frequency in hours -! fhcyc - real cycling frequency in hours -! Output Arguments: -! nsout - integer output frequency in timesteps -! nsswr - integer shortwave frequency in timesteps -! nslwr - integer longwave frequency in timesteps -! nszer - integer zeroing frequency in timesteps -! nsres - integer restart frequency in timesteps -! nscyc - integer cycling frequency in timesteps -! iret - integer return code (0 if successful or -! between 1 and 8 for which rule above was broken) -! LDIAG3D - switch for 3D diagnostic- (default = false) -!hchuang code change [+1L] -! LGGFS3D - switch for 3D GFS-GOCARRT fields (default = false) -! -! -! Attributes: -! Language: Fortran 90 -! -!$$$ - - - use n_namelist_physics_def -!cmy mpi_def holds liope - use n_mpi_def, only : liope - implicit none - - real tol - - character (len=*), intent(in) :: gfs_phy_namelist - integer, intent(in) :: me, nlunit - real,intent(inout) :: deltim - integer,intent(out) :: iret - integer ntrac,nxpt,nypt,jintmx,jcap,levs,lonr,latr -! integer ntrac,jcap,levs,lonr,latr - integer levr - integer ntoz,ntcw,ncld,lsoil,nmtvr,num_p3d,num_p2d,member_num - integer thermodyn_id, sfcpress_id - real tfiltc - logical lgoc3d - -!sela - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! if output (fhout) more frequently than zeroing ,get partial rains - - namelist /nam_phy/FHMAX,FHOUT,FHRES,FHZER,FHSEG,FHROT,DELTIM,IGEN, - & NGPTC,fhswr,fhlwr,fhcyc,ras,LGOC3D,FHGOC3D,LDIAG3D,reduced_grid, - & shuff_lats_r,thermodyn_id,sfcpress_id,fhdfi, - & pre_rad,hybrid,gen_coord_hybrid,random_clds,liope, - & ntrac,nxpt,nypt,jintmx,jcap,levs,lonr,latr,levr, - & ntoz,ntcw,ncld,lsoil,nmtvr,zhao_mic,nsout,lsm,tfiltc, - & isol, ico2, ialb, iems, iaer, iovr_sw, iovr_lw,ictm, - & fdaer, - & ncw, crtrh,old_monin,flgmin,cnvgwd, -! & ncw, crtrh,old_monin,flgmin,gfsio_in,gfsio_out,cnvgwd, - & ccwf,shal_cnv,sashal,newsas,crick_proof,ccnorm,ctei_rm,mom4ice, -! & ccwf,sashal,newsas,zflxtvd,crick_proof,ccnorm,ctei_rm,mom4ice, - & norad_precip,num_reduce,mstrat,trans_trac,dlqf,moist_adj, - & nst_fcst,nst_spinup,lsea,cal_pre,psautco,prautco,evpco,wminco, - & fhout_hf,fhmax_hf,cdmbgwd,bkgd_vdif_m,bkgd_vdif_h,hdif_fac - &,grid_aldata,bkgd_vdif_s -! - shuff_lats_r = .true. -! reshuff_lats_r = .false. - - num_reduce = -4 -! - fhmax = 0 - fhout = 0 - fhzer = 0 - fhseg = 0 - fhrot = 0 - fhout_hf = 1 - fhmax_hf = 0 - deltim = 0 - igen = 0 - fhswr = 0 - fhlwr = 0 - fhcyc = 0 - fhdfi = 0 - tfiltc = 0.85 - ccwf = 1.0 - dlqf = 0.0 - ctei_rm = 10.0 - NGPTC = lonr -! - bkgd_vdif_m = 3.0 - bkgd_vdif_h = 1.0 - bkgd_vdif_s = 0.2 - hdif_fac = 1.0 -! - ras = .false. - zhao_mic = .true. - LDIAG3D = .false. - LGGFS3D = .false. !hchuang code change [+1L] - LGOC3D = .false. - fhgoc3d = 72.0 - shal_cnv = .true. - sashal = .true. - crick_proof = .false. - ccnorm = .false. - newsas = .true. - norad_precip = .false. ! This is effective only for Ferrier/Moorthi - mom4ice = .false. ! True when coupled to MOM4 OM - mstrat = .false. - trans_trac = .true. ! This is effective only for RAS - moist_adj = .false. ! Must be true to turn on moist convective - cal_pre = .false. ! true for huiya's precip type algorithm -! - reduced_grid = .true. -! - pre_rad = .false. - hybrid = .true. - gen_coord_hybrid = .false. !hmhj - random_clds = .false. - liope = .true. -! - old_monin = .false. - cnvgwd = .false. -! zflxtvd = .true. -! - thermodyn_id = 1 - sfcpress_id = 1 -! -! ncw(1) = 75 - ncw(1) = 50 - ncw(2) = 150 - crtrh(:) = 0.85 - flgmin(:) = 0.20 -! - psautco(:) = 4.0E-4 ! Zhao scheme default opr value - prautco(:) = 1.0E-4 ! Zhao scheme default opr value - evpco = 2.0E-5 - wminco(:) = 1.0E-5 ! Zhao scheme default water and ice floor value - cdmbgwd(:) = 1.0 ! Mtn Blking and GWD tuning factors - -! For NST model - nst_fcst = 0 - nst_spinup = .false. - lsea = 0 -! -! gfsio_in = .true. -! gfsio_out = .true. -! - nsout = 0 - nsout_hf = 0 - lsm = 1 ! NOAH LSM is the default when lsm=1 - levr = 0 -! Default values for some radiation controls - isol = 0 ! use prescribed solar constant - ico2 = 0 ! prescribed global mean value (old opernl) - ialb = 0 ! use climatology alb, based on sfc type -! ialb = 1 ! use modis based alb - iems = 0 ! use fixed value of 1.0 - iaer = 1 ! default aerosol - iovr_sw = 1 ! sw: max-random overlap clouds - iovr_lw = 1 ! lw: max-random overlap clouds - ictm = 1 ! ictm=0 => use data at initial cond time, if not - ! available, use latest, no extrapolation. - ! ictm=1 => use data at the forecast time, if not - ! available, use latest and extrapolation. - ! ictm=yyyy0 => use yyyy data for the forecast time, - ! no further data extrapolation. - ! ictm=yyyy1 = > use yyyy data for the fcst. - ! if needed, do extrapolation to match the fcst time. - ! ictm=-1 => use user provided external data for - ! the fcst time, no extrapolation. - ! ictm=-2 => same as ictm=0, but add seasonal cycle - ! from climatology. no extrapolation. -! -! The copy/pointer option (Sarah Lu) -! 3D fields are allocated only in DYN; -! pointer is used to associate 3D fields in PHY back to DYN - grid_aldata = .false. -! -! The relaxation time in days to gocart forecast (Sarah Lu) -! default is 0 (use clim/anal fields) - fdaer = 0. -! - print *,' nlunit=',nlunit,' gfs_phy_namelist=',gfs_phy_namelist -c$$$ read(5,nam_phy) - open(unit=nlunit,file=gfs_phy_namelist) - rewind (nlunit) -! read(nlunit,nam_phy,err=999) - read(nlunit,nam_phy) - print *,' fhmax=',fhmax -! - print *,' fhmax=',fhmax,' nst_fcst =',nst_fcst,' - & nst_spinup =',nst_spinup, 'lsea =',lsea -! - LGGFS3D = LGOC3D -! - if (me == 0) then - write(6,nam_phy) - if (lsm == 1) then - print *,' NOAH Land Surface Model used' - elseif (lsm == 0) then - print *,' OSU Land Surface Model used' - else - print *,' Unsupported LSM type - job aborted' - &, ' - lsm=',lsm - call n_mpi_quit(2222) - endif -! - if (ras) then - print *,' RAS Convection scheme used with ccwf=',ccwf - else - if (newsas) then - print *,' New modified SAS Convection scheme used' - else - print *,' OPR SAS Convection scheme used' - endif - endif - print *,' The time filter coefficient tfiltc=',tfiltc - if (.not. old_monin) print *,' New PBL scheme used' - if (.not. shal_cnv) print *,' No shallow convection used' - if (sashal) print *,' New Massflux based shallow convection' - &, ' used' - if (cnvgwd) print *,' Convective GWD parameterization used' - if (crick_proof) print *,' CRICK-Proof cloud water used in' - &, ' radiation ' - if (ccnorm) print *,' Cloud condensate normalized by cloud' - &, ' cover for radiation' - endif -! - if (levr == 0) then - levr = levs - endif - if (me .eq. 0) then - print *,' Radiative heating calculated at',levr, ' layers' - if (iovr_sw == 0) then - print *,' random cloud overlap for Shortwave IOVR_SW=' - &, iovr_sw - else - print *,' max-random cloud overlap for Shortwave IOVR_SW=' - &, iovr_sw - endif - if (iovr_lw == 0) then - print *,' random cloud overlap for Longwave IOVR_LW=' - &, iovr_lw - else - print *,' max-random cloud overlap for Longwave IOVR_LW=' - &, iovr_lw - endif - endif -! - if (zhao_mic) then ! default setup for Zhao Microphysics - num_p3d = 4 - num_p2d = 3 - if (me .eq. 0) print *,' Using Zhao Microphysics : nump3d=' - &, num_p3d,' num_p2d=',num_p2d,' crtrh=',crtrh - else ! Brad Ferrier's Microphysics - num_p3d = 3 - num_p2d = 1 - if (me .eq. 0) print *,' Using Ferrier Microphysics : nump3d=' - &, num_p3d,' num_p2d=',num_p2d - &, ' crtrh=',crtrh,' ncw=',ncw,' flgmin=',flgmin - endif -! -!sela - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - tol=0.01 -! Check rule 1. - if(deltim.le.0) then - iret=1 - return - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Compute nsout and check rule 2. - if(nsout.gt.0) fhout=nsout*deltim/3600. - nsout=nint(fhout*3600./deltim) - if(nsout.le.0.or.abs(nsout-fhout*3600./deltim).gt.tol) then - iret=2 - return - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Compute nsout_hf and check rule 21. -! if(nsout_hf.gt.0) fhout=nsout_hf*deltim/3600. - nsout_hf=nint(fhout_hf*3600./deltim) - if(nsout_hf <= 0.or.abs(nsout_hf-fhout_hf*3600./deltim)>tol) then - iret=9 - return - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Compute nsswr and check rule 3. - nsswr=nint(fhswr*3600./deltim) - if(nsswr.le.0.or.abs(nsswr-fhswr*3600./deltim).gt.tol) then - iret=3 - return - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Compute nslwr and check rule 4. - nslwr=nint(fhlwr*3600./deltim) - if(nslwr.le.0.or.abs(nslwr-fhlwr*3600./deltim).gt.tol.or. - & mod(nslwr,nsswr).ne.0) then - iret=4 - return - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Compute nszer and check rule 5. - nszer=nint(fhzer*3600./deltim) - if(nszer.le.0.or.abs(nszer-fhzer*3600./deltim).gt.tol.or. - & mod(nszer,nsout).ne.0) then - iret=5 - return - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Compute nsres and check rule 6. - nsres=nint(fhres*3600./deltim) - if(nsres.le.0.or.abs(nsres-fhres*3600./deltim).gt.tol.or. - & mod(nsres,nslwr).ne.0.or.mod(nsres,nszer).ne.0) then - iret=6 - return - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Compute ndfi and check rule 7. - if(fhdfi.eq.0.) then - ndfi=0 - ldfi=.false. - else - ndfi=nint(2*fhdfi*3600./deltim) - ldfi=.true. - if(ndfi.le.0.or.abs(ndfi-2*fhdfi*3600./deltim).gt.tol.or. - & ndfi.gt.nsres) then - print *,'ndfi=',ndfi,'is not equal to',2*fhdfi*3600./deltim - iret=7 - return - endif - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Compute nscyc and check rule 8. - if(fhcyc.eq.0.) then - nscyc=0 - else - nscyc=nint(fhcyc*3600./deltim) - if(nscyc.le.0.or.abs(nscyc-fhcyc*3600./deltim).gt.tol.or. - & mod(nscyc,nslwr).ne.0) then - iret=8 - return - endif - endif -!! - IF (NGPTC.GT.LONR) THEN - NGPTC=LONR - WRITE(0,*) "NGPTC IS TOO BIG, RESET NGPTC TO LONR",NGPTC - ENDIF - IF (ME.EQ.0) WRITE(0,*) "NGPTC IS SET TO NGPTC :",NGPTC -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! All checks are successful. - iret=0 - return - 999 print *,' error reading namelist - execution terminated by user' - call n_mpi_quit(999) -! - end diff --git a/src/nmm/n_layout1.f b/src/nmm/n_layout1.f deleted file mode 100644 index 8be55a3..0000000 --- a/src/nmm/n_layout1.f +++ /dev/null @@ -1,23 +0,0 @@ - module n_layout1 - implicit none - -cc - integer nodes, nodes_comp,nodes_io, - x me, - x ls_dim, - x ls_max_node, - x lats_dim_r, - x lats_dim_ext, - x lats_node_r, - x lats_node_r_max, - x lats_node_ext, - x ipt_lats_node_r, - x ipt_lats_node_ext, -! x lonf, latg, - x len_trio_ls, len_trie_ls, - x me_l_0 -cc - integer idrt !jw:for flx file outfile - - integer ,allocatable :: lon_dims_r(:),lon_dims_ext(:) - end module n_layout1 diff --git a/src/nmm/n_module_gfs_mpi_def.f b/src/nmm/n_module_gfs_mpi_def.f deleted file mode 100644 index 791d9f4..0000000 --- a/src/nmm/n_module_gfs_mpi_def.f +++ /dev/null @@ -1,20 +0,0 @@ - module n_module_gfs_mpi_def -! - include 'mpif.h' -! - integer,parameter :: max_inter_groups=100 !max number of quilt server groups -! - integer stat(MPI_STATUS_SIZE),info - INTEGER :: MC_COMP, MC_IO, MPI_COMM_ALL, MPI_COMM_ALL_DUP - INTEGER :: N_GROUP - logical LIOPE -! - INTEGER :: num_pes,num_pes_fcst,first_fcst_pe,last_fcst_pe - INTEGER :: write_tasks_per_group, write_groups - INTEGER :: mpi_comm_inter,mpi_comm_comp,mpi_inter_b - INTEGER,allocatable :: petlist_fcst(:),petlist_write(:,:) - INTEGER,dimension(max_inter_groups) :: mpi_comm_inter_array - logical QUILTING - character*20 ensmem_name - - end module n_module_gfs_mpi_def diff --git a/src/nmm/n_mpi_def.f b/src/nmm/n_mpi_def.f deleted file mode 100644 index 1db5fae..0000000 --- a/src/nmm/n_mpi_def.f +++ /dev/null @@ -1,40 +0,0 @@ - module n_mpi_def -! - use machine, ONLY: KIND_io4, KIND_ior - use n_module_gfs_mpi_def -!jw include 'mpif.h' -!jw integer stat(MPI_STATUS_SIZE),info -!jw INTEGER :: icolor -!jw INTEGER :: MC_COMP, MC_IO, MPI_COMM_ALL, MPI_COMM_ALL_DUP -!jw logical LIOPE - - integer MPI_R_IO, MPI_R_MPI, MPI_R_DEF, MPI_A_DEF - &, MPI_R_IO_R,MPI_R_MPI_R - PARAMETER (MPI_R_IO =MPI_REAL4) - PARAMETER (MPI_R_IO_R=MPI_REAL8) - -ccmr PARAMETER (MPI_R_MPI=MPI_REAL8) - PARAMETER (MPI_R_MPI=MPI_REAL4) - PARAMETER (MPI_R_MPI_R=MPI_REAL8) - - PARAMETER (MPI_R_DEF=MPI_REAL8) - PARAMETER (MPI_A_DEF=MPI_REAL8) - - integer kind_mpi,kind_sum,kind_mpi_r -ccmr PARAMETER (kind_mpi=8,kind_sum=8) - PARAMETER (kind_mpi=4,kind_sum=4,kind_mpi_r=8) - integer ngrids_sfc,ngrid_global - parameter(ngrids_sfc=100) - -! REAL(KIND=KIND_io4) ,ALLOCATABLE, target :: buf_sig(:,:) -! &, buff_grid(:,:) -! &, buf_sig_n(:,:,:) -! REAL(KIND=KIND_ior) ,ALLOCATABLE, target :: buf_sig_r(:,:) -! REAL(KIND=KIND_ior) ,ALLOCATABLE, target :: buf_sig_r(:,:) -! &, buf_sig_rn(:,:,:) -! &, buf_grd_r(:,:,:) - REAL(KIND=KIND_io4) ,POINTER :: buff_mult(:,:,:) -! REAL(KIND=KIND_io4) ,POINTER :: buff_multg(:,:) - REAL(KIND=KIND_io4) ,allocatable :: buff_multg(:,:) - real tmm(10,10) - end module n_mpi_def diff --git a/src/nmm/n_mpi_quit.f b/src/nmm/n_mpi_quit.f deleted file mode 100644 index e66836f..0000000 --- a/src/nmm/n_mpi_quit.f +++ /dev/null @@ -1,12 +0,0 @@ - SUBROUTINE n_mpi_quit(iret) - use n_mpi_def - implicit none -! - integer iret - - write(0,*) 'CALL stop mpi_quit ',iret - CALL MPI_ABORT(MC_COMP,iret,info) - - RETURN - END -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/src/nmm/n_namelist_physics_def.f b/src/nmm/n_namelist_physics_def.f deleted file mode 100644 index bbf6add..0000000 --- a/src/nmm/n_namelist_physics_def.f +++ /dev/null @@ -1,46 +0,0 @@ - module n_namelist_physics_def - -!! Code Revision -!! oct 12 2009 Sarah Lu, add grid_aldata -!! Jan 12 2010 Sarah Lu, add fdaer -!! June 2010 Shrinivas Moorthi - upgrade GFS physics -!! Aug 03 2010 Jun Wang, add fhdfi,ndfi,ldfi - - use machine, ONLY: kind_evod - implicit none - - integer nszer,nsres,nslwr,nsout,nsswr,nscyc,ndfi,igen,jo3,ngptc - &, lsm,ens_mem,ncw(2),lsea,nsout_hf,num_reduce - real(kind=kind_evod) fhswr,fhlwr,fhrot,fhseg,fhmax,fhout,fhres, - & fhzer,fhini,fhcyc,fhdfi,crtrh(3),flgmin(2), - & ccwf(2),dlqf(2),ctei_rm(2),fhgoc3d,fhout_hf,fhmax_hf,cdmbgwd(2), - & bkgd_vdif_m, bkgd_vdif_h, hdif_fac, psautco(2), prautco(2), evpco - &,bkgd_vdif_s,wminco(2) - logical ldiag3d,ras,zhao_mic,sashal,newsas,crick_proof,ccnorm - logical shal_cnv - logical mom4ice,mstrat,trans_trac,moist_adj,lggfs3d,cal_pre - logical lsfwd,lssav,lscca,lsswr,lslwr,ldfi - logical shuff_lats_r,reshuff_lats_r,reduced_grid - logical hybrid,gen_coord_hybrid -! logical hybrid,gen_coord_hybrid,zflxtvd - logical pre_rad,random_clds,old_monin,cnvgwd - logical restart -! logical restart, gfsio_in, gfsio_out - character*20 ens_nam - - integer nst_fcst - logical nst_spinup -! -! Radiation control parameters -! - logical norad_precip - integer isol, ico2, ialb, iems, iaer, iovr_sw, iovr_lw, ictm - - integer isubc_sw, isubc_lw -! -! Chemistry control parameters -! - logical grid_aldata ! option to allocate grid_fld - real(kind=kind_evod) fdaer ! relaxation time in days to gocart anal/clim -! - end module n_namelist_physics_def diff --git a/src/nmm/n_resol_def.f b/src/nmm/n_resol_def.f deleted file mode 100644 index 8d4bd77..0000000 --- a/src/nmm/n_resol_def.f +++ /dev/null @@ -1,47 +0,0 @@ - module n_resol_def - - implicit none - - integer jcap,jcap1,jcap2,latg,latg2,latr,latr2 - integer levh,levm1,levp1,levs,lnt,lnt2,lnt22,levr - integer lnte,lnted,lnto,lntod,lnuv - integer lonf,lonfx,lonr,lonrx -! -!jw integer ntrac - integer,target :: ntrac - integer nxpt,nypt,jintmx,latrd - integer ntoz,ntcw - integer lsoil,nmtvr,ncld,num_p3d,num_p2d,nrcm - integer ngrids_sfcc, ngrids_flx, nfxr - integer ngrids_aer ! for g2d_fld - integer ngrids_nst,nr_nst,nf_nst -!jws integer ivsupa, ivssfc, ivssfc_restart, ivsinp - integer ivsupa, ivssfc_restart, ivsinp - integer ivsnst - integer,target :: thermodyn_id, sfcpress_id ! hmhj - integer,target :: ivssfc - integer,target :: ngrids_gg - integer ngrids_sfcc2d,ngrids_sfcc3d - integer idvt -!jwe -! - integer nlunit -!jw integer thermodyn_id, sfcpress_id ! hmhj -! - integer g_gz, g_ps, g_t, g_u, g_v, g_q, g_p, g_dp, g_dpdt - integer lotgr - - integer kwq,kwte,kwdz,kwrq - -! For Ensemble concurrency run. Weiyu -! INTEGER :: Ensemble_Id, Total_member - -! The option to add 2d/3d diag fields to physics export state - logical :: lgocart - -! For GOCART mapping - integer, allocatable :: scatter_lats(:) - integer, allocatable :: scatter_lons(:) - - end module n_resol_def -! diff --git a/src/phys/idea_ion_input.f b/src/phys/idea_ion_input.f index 688ee6e..e1ba5ec 100644 --- a/src/phys/idea_ion_input.f +++ b/src/phys/idea_ion_input.f @@ -351,7 +351,7 @@ SUBROUTINE tiros_init(emaps,cmaps,djspectra) do iband=1,21 read(UNIT7,fmt=*) string_dum read(UNIT7,fmt=*) - read(UNIT=UNIT7,fmt='(1X,5e10.4)')(djspectra(iflux,iband), + read(UNIT=UNIT7,fmt='(1X,5e10.3)')(djspectra(iflux,iband), & iflux=1,15) read(UNIT7,fmt=*) enddo diff --git a/src/wamCap.F90 b/src/wamCap.F90 index b52b326..9712f8b 100644 --- a/src/wamCap.F90 +++ b/src/wamCap.F90 @@ -25,7 +25,7 @@ MODULE wamCap ! | | ! | (MOM5, HYCOM, etc.) ! | -! CORE component (GSM, NMM, FIM, GEN, etc.) +! CORE component (GSM, GEN, etc.) ! !----------------------------------------------------------------------- ! 2011-05-11 Theurich & Yang - Modified for using the ESMF 5.2.0r_beta_snapshot_07. @@ -46,9 +46,7 @@ MODULE wamCap USE module_ATM_INTERNAL_STATE,ONLY: ATM_INTERNAL_STATE & ,WRAP_ATM_INTERNAL_STATE - USE module_NMM_GRID_COMP,ONLY: NMM_REGISTER USE module_GFS_GRID_COMP,ONLY: GFS_REGISTER - USE module_FIM_GRID_COMP,ONLY: FIM_REGISTER USE module_GEN_GRID_COMP,ONLY: GEN_REGISTER ! For the "Generic Core" gridded component. USE module_ERR_MSG,ONLY: ERR_MSG,MESSAGE_CHECK @@ -582,11 +580,6 @@ SUBROUTINE ATM_INITIALIZE(ATM_GRID_COMP & ! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ! SELECT CASE(atm_int_state%CORE) -! - CASE('nmm') - CALL ESMF_GridCompSetServices (atm_int_state%CORE_GRID_COMP & - ,NMM_REGISTER & - ,rc=RC) ! CASE('gfs') CALL ESMF_GridCompSetServices (atm_int_state%CORE_GRID_COMP & @@ -598,11 +591,6 @@ SUBROUTINE ATM_INITIALIZE(ATM_GRID_COMP & ,GFS_REGISTER & ,rc=RC) ! - CASE('fim') - CALL ESMF_GridCompSetServices (atm_int_state%CORE_GRID_COMP & - ,FIM_REGISTER & - ,rc=RC) - CASE('gen') CALL ESMF_GridCompSetServices (atm_int_state%CORE_GRID_COMP & ,GEN_REGISTER & From 192dc56ca258f47264d88335c4950a7a68d8a903 Mon Sep 17 00:00:00 2001 From: akubaryk <31134616+akubaryk@users.noreply.github.com> Date: Wed, 29 Mar 2023 14:50:44 -0600 Subject: [PATCH 4/6] Delete indlmod.f --- src/gsm/dyn/indlmod.f | 15 --------------- 1 file changed, 15 deletions(-) delete mode 100644 src/gsm/dyn/indlmod.f diff --git a/src/gsm/dyn/indlmod.f b/src/gsm/dyn/indlmod.f deleted file mode 100644 index de070dd..0000000 --- a/src/gsm/dyn/indlmod.f +++ /dev/null @@ -1,15 +0,0 @@ -! input forcing parameter module - module indlmod - - implicit none - - contains - - subroutine get_indl(jba, n, l, indlsev) - integer, intent(in) :: jba, n, l - integer, intent(out) :: indl - - indl = jba + (n-l)/2 + 1 - end subroutine get_indl - - end module indlmod From 12bfe5939da25d65a51004348a56f9761a1c3f19 Mon Sep 17 00:00:00 2001 From: akubaryk <31134616+akubaryk@users.noreply.github.com> Date: Wed, 29 Mar 2023 14:51:37 -0600 Subject: [PATCH 5/6] Delete indlmod.f --- src/gsm/phys/indlmod.f | 9 --------- 1 file changed, 9 deletions(-) delete mode 100644 src/gsm/phys/indlmod.f diff --git a/src/gsm/phys/indlmod.f b/src/gsm/phys/indlmod.f deleted file mode 100644 index 428624a..0000000 --- a/src/gsm/phys/indlmod.f +++ /dev/null @@ -1,9 +0,0 @@ -! input forcing parameter module - module indlmod - - implicit none - - integer indlsev, indlsod - - - end module indlmod From e6a2d4e017c3d42021e6ec2e0af2e9e21b64a250 Mon Sep 17 00:00:00 2001 From: akubaryk Date: Wed, 19 Apr 2023 01:10:20 +0000 Subject: [PATCH 6/6] build system change for esmf 8.4.1 on wcoss2 --- INSTALL | 322 +++++++++++++++--------------- Makefile.in | 63 +++--- aclocal.m4 | 173 ++++++++++++++--- build-aux/ar-lib | 2 +- build-aux/config.guess | 377 ++++++++++++++---------------------- build-aux/config.sub | 126 ++++++++---- build-aux/install-sh | 368 ++++++++++++++++------------------- build-aux/missing | 8 +- configure | 124 +++++++++++- m4/ax_lib_esmf.m4 | 2 +- src/Makefile.in | 22 ++- src/fim/Makefile.in | 22 ++- src/gen/Makefile.in | 22 ++- src/gsm/Makefile.in | 22 ++- src/gsm/dyn/Makefile.in | 22 ++- src/gsm/libutil/Makefile.in | 22 ++- src/gsm/phys/Makefile.in | 22 ++- src/io/Makefile.in | 22 ++- src/nmm/Makefile.in | 22 ++- src/phys/Makefile.in | 22 ++- src/post/Makefile.in | 22 ++- src/share/Makefile.in | 22 ++- 22 files changed, 1080 insertions(+), 749 deletions(-) diff --git a/INSTALL b/INSTALL index 007e939..8865734 100644 --- a/INSTALL +++ b/INSTALL @@ -1,8 +1,8 @@ Installation Instructions ************************* -Copyright (C) 1994-1996, 1999-2002, 2004-2013 Free Software Foundation, -Inc. + Copyright (C) 1994-1996, 1999-2002, 2004-2016 Free Software +Foundation, Inc. Copying and distribution of this file, with or without modification, are permitted in any medium without royalty provided the copyright @@ -12,97 +12,96 @@ without warranty of any kind. Basic Installation ================== - Briefly, the shell commands `./configure; make; make install' should -configure, build, and install this package. The following -more-detailed instructions are generic; see the `README' file for + Briefly, the shell command './configure && make && make install' +should configure, build, and install this package. The following +more-detailed instructions are generic; see the 'README' file for instructions specific to this package. Some packages provide this -`INSTALL' file but do not implement all of the features documented +'INSTALL' file but do not implement all of the features documented below. The lack of an optional feature in a given package is not necessarily a bug. More recommendations for GNU packages can be found in *note Makefile Conventions: (standards)Makefile Conventions. - The `configure' shell script attempts to guess correct values for + The 'configure' shell script attempts to guess correct values for various system-dependent variables used during compilation. It uses -those values to create a `Makefile' in each directory of the package. -It may also create one or more `.h' files containing system-dependent -definitions. Finally, it creates a shell script `config.status' that +those values to create a 'Makefile' in each directory of the package. +It may also create one or more '.h' files containing system-dependent +definitions. Finally, it creates a shell script 'config.status' that you can run in the future to recreate the current configuration, and a -file `config.log' containing compiler output (useful mainly for -debugging `configure'). +file 'config.log' containing compiler output (useful mainly for +debugging 'configure'). - It can also use an optional file (typically called `config.cache' -and enabled with `--cache-file=config.cache' or simply `-C') that saves -the results of its tests to speed up reconfiguring. Caching is -disabled by default to prevent problems with accidental use of stale -cache files. + It can also use an optional file (typically called 'config.cache' and +enabled with '--cache-file=config.cache' or simply '-C') that saves the +results of its tests to speed up reconfiguring. Caching is disabled by +default to prevent problems with accidental use of stale cache files. If you need to do unusual things to compile the package, please try -to figure out how `configure' could check whether to do them, and mail -diffs or instructions to the address given in the `README' so they can +to figure out how 'configure' could check whether to do them, and mail +diffs or instructions to the address given in the 'README' so they can be considered for the next release. If you are using the cache, and at -some point `config.cache' contains results you don't want to keep, you +some point 'config.cache' contains results you don't want to keep, you may remove or edit it. - The file `configure.ac' (or `configure.in') is used to create -`configure' by a program called `autoconf'. You need `configure.ac' if -you want to change it or regenerate `configure' using a newer version -of `autoconf'. + The file 'configure.ac' (or 'configure.in') is used to create +'configure' by a program called 'autoconf'. You need 'configure.ac' if +you want to change it or regenerate 'configure' using a newer version of +'autoconf'. The simplest way to compile this package is: - 1. `cd' to the directory containing the package's source code and type - `./configure' to configure the package for your system. + 1. 'cd' to the directory containing the package's source code and type + './configure' to configure the package for your system. - Running `configure' might take a while. While running, it prints + Running 'configure' might take a while. While running, it prints some messages telling which features it is checking for. - 2. Type `make' to compile the package. + 2. Type 'make' to compile the package. - 3. Optionally, type `make check' to run any self-tests that come with + 3. Optionally, type 'make check' to run any self-tests that come with the package, generally using the just-built uninstalled binaries. - 4. Type `make install' to install the programs and any data files and + 4. Type 'make install' to install the programs and any data files and documentation. When installing into a prefix owned by root, it is recommended that the package be configured and built as a regular - user, and only the `make install' phase executed with root + user, and only the 'make install' phase executed with root privileges. - 5. Optionally, type `make installcheck' to repeat any self-tests, but + 5. Optionally, type 'make installcheck' to repeat any self-tests, but this time using the binaries in their final installed location. This target does not install anything. Running this target as a - regular user, particularly if the prior `make install' required + regular user, particularly if the prior 'make install' required root privileges, verifies that the installation completed correctly. 6. You can remove the program binaries and object files from the - source code directory by typing `make clean'. To also remove the - files that `configure' created (so you can compile the package for - a different kind of computer), type `make distclean'. There is - also a `make maintainer-clean' target, but that is intended mainly + source code directory by typing 'make clean'. To also remove the + files that 'configure' created (so you can compile the package for + a different kind of computer), type 'make distclean'. There is + also a 'make maintainer-clean' target, but that is intended mainly for the package's developers. If you use it, you may have to get all sorts of other programs in order to regenerate files that came with the distribution. - 7. Often, you can also type `make uninstall' to remove the installed + 7. Often, you can also type 'make uninstall' to remove the installed files again. In practice, not all packages have tested that uninstallation works correctly, even though it is required by the GNU Coding Standards. - 8. Some packages, particularly those that use Automake, provide `make + 8. Some packages, particularly those that use Automake, provide 'make distcheck', which can by used by developers to test that all other - targets like `make install' and `make uninstall' work correctly. + targets like 'make install' and 'make uninstall' work correctly. This target is generally not run by end users. Compilers and Options ===================== Some systems require unusual options for compilation or linking that -the `configure' script does not know about. Run `./configure --help' +the 'configure' script does not know about. Run './configure --help' for details on some of the pertinent environment variables. - You can give `configure' initial values for configuration parameters -by setting variables in the command line or in the environment. Here -is an example: + You can give 'configure' initial values for configuration parameters +by setting variables in the command line or in the environment. Here is +an example: ./configure CC=c99 CFLAGS=-g LIBS=-lposix @@ -113,21 +112,21 @@ Compiling For Multiple Architectures You can compile the package for more than one kind of computer at the same time, by placing the object files for each architecture in their -own directory. To do this, you can use GNU `make'. `cd' to the +own directory. To do this, you can use GNU 'make'. 'cd' to the directory where you want the object files and executables to go and run -the `configure' script. `configure' automatically checks for the -source code in the directory that `configure' is in and in `..'. This -is known as a "VPATH" build. +the 'configure' script. 'configure' automatically checks for the source +code in the directory that 'configure' is in and in '..'. This is known +as a "VPATH" build. - With a non-GNU `make', it is safer to compile the package for one + With a non-GNU 'make', it is safer to compile the package for one architecture at a time in the source code directory. After you have -installed the package for one architecture, use `make distclean' before +installed the package for one architecture, use 'make distclean' before reconfiguring for another architecture. On MacOS X 10.5 and later systems, you can create libraries and executables that work on multiple system types--known as "fat" or -"universal" binaries--by specifying multiple `-arch' options to the -compiler but only a single `-arch' option to the preprocessor. Like +"universal" binaries--by specifying multiple '-arch' options to the +compiler but only a single '-arch' option to the preprocessor. Like this: ./configure CC="gcc -arch i386 -arch x86_64 -arch ppc -arch ppc64" \ @@ -136,105 +135,104 @@ this: This is not guaranteed to produce working output in all cases, you may have to build one architecture at a time and combine the results -using the `lipo' tool if you have problems. +using the 'lipo' tool if you have problems. Installation Names ================== - By default, `make install' installs the package's commands under -`/usr/local/bin', include files under `/usr/local/include', etc. You -can specify an installation prefix other than `/usr/local' by giving -`configure' the option `--prefix=PREFIX', where PREFIX must be an + By default, 'make install' installs the package's commands under +'/usr/local/bin', include files under '/usr/local/include', etc. You +can specify an installation prefix other than '/usr/local' by giving +'configure' the option '--prefix=PREFIX', where PREFIX must be an absolute file name. You can specify separate installation prefixes for architecture-specific files and architecture-independent files. If you -pass the option `--exec-prefix=PREFIX' to `configure', the package uses +pass the option '--exec-prefix=PREFIX' to 'configure', the package uses PREFIX as the prefix for installing programs and libraries. Documentation and other data files still use the regular prefix. In addition, if you use an unusual directory layout you can give -options like `--bindir=DIR' to specify different values for particular -kinds of files. Run `configure --help' for a list of the directories -you can set and what kinds of files go in them. In general, the -default for these options is expressed in terms of `${prefix}', so that -specifying just `--prefix' will affect all of the other directory +options like '--bindir=DIR' to specify different values for particular +kinds of files. Run 'configure --help' for a list of the directories +you can set and what kinds of files go in them. In general, the default +for these options is expressed in terms of '${prefix}', so that +specifying just '--prefix' will affect all of the other directory specifications that were not explicitly provided. The most portable way to affect installation locations is to pass the -correct locations to `configure'; however, many packages provide one or +correct locations to 'configure'; however, many packages provide one or both of the following shortcuts of passing variable assignments to the -`make install' command line to change installation locations without +'make install' command line to change installation locations without having to reconfigure or recompile. The first method involves providing an override variable for each -affected directory. For example, `make install +affected directory. For example, 'make install prefix=/alternate/directory' will choose an alternate location for all directory configuration variables that were expressed in terms of -`${prefix}'. Any directories that were specified during `configure', -but not in terms of `${prefix}', must each be overridden at install -time for the entire installation to be relocated. The approach of -makefile variable overrides for each directory variable is required by -the GNU Coding Standards, and ideally causes no recompilation. -However, some platforms have known limitations with the semantics of -shared libraries that end up requiring recompilation when using this -method, particularly noticeable in packages that use GNU Libtool. - - The second method involves providing the `DESTDIR' variable. For -example, `make install DESTDIR=/alternate/directory' will prepend -`/alternate/directory' before all installation names. The approach of -`DESTDIR' overrides is not required by the GNU Coding Standards, and +'${prefix}'. Any directories that were specified during 'configure', +but not in terms of '${prefix}', must each be overridden at install time +for the entire installation to be relocated. The approach of makefile +variable overrides for each directory variable is required by the GNU +Coding Standards, and ideally causes no recompilation. However, some +platforms have known limitations with the semantics of shared libraries +that end up requiring recompilation when using this method, particularly +noticeable in packages that use GNU Libtool. + + The second method involves providing the 'DESTDIR' variable. For +example, 'make install DESTDIR=/alternate/directory' will prepend +'/alternate/directory' before all installation names. The approach of +'DESTDIR' overrides is not required by the GNU Coding Standards, and does not work on platforms that have drive letters. On the other hand, it does better at avoiding recompilation issues, and works well even -when some directory options were not specified in terms of `${prefix}' -at `configure' time. +when some directory options were not specified in terms of '${prefix}' +at 'configure' time. Optional Features ================= If the package supports it, you can cause programs to be installed -with an extra prefix or suffix on their names by giving `configure' the -option `--program-prefix=PREFIX' or `--program-suffix=SUFFIX'. - - Some packages pay attention to `--enable-FEATURE' options to -`configure', where FEATURE indicates an optional part of the package. -They may also pay attention to `--with-PACKAGE' options, where PACKAGE -is something like `gnu-as' or `x' (for the X Window System). The -`README' should mention any `--enable-' and `--with-' options that the +with an extra prefix or suffix on their names by giving 'configure' the +option '--program-prefix=PREFIX' or '--program-suffix=SUFFIX'. + + Some packages pay attention to '--enable-FEATURE' options to +'configure', where FEATURE indicates an optional part of the package. +They may also pay attention to '--with-PACKAGE' options, where PACKAGE +is something like 'gnu-as' or 'x' (for the X Window System). The +'README' should mention any '--enable-' and '--with-' options that the package recognizes. - For packages that use the X Window System, `configure' can usually + For packages that use the X Window System, 'configure' can usually find the X include and library files automatically, but if it doesn't, -you can use the `configure' options `--x-includes=DIR' and -`--x-libraries=DIR' to specify their locations. +you can use the 'configure' options '--x-includes=DIR' and +'--x-libraries=DIR' to specify their locations. Some packages offer the ability to configure how verbose the -execution of `make' will be. For these packages, running `./configure +execution of 'make' will be. For these packages, running './configure --enable-silent-rules' sets the default to minimal output, which can be -overridden with `make V=1'; while running `./configure +overridden with 'make V=1'; while running './configure --disable-silent-rules' sets the default to verbose, which can be -overridden with `make V=0'. +overridden with 'make V=0'. Particular systems ================== - On HP-UX, the default C compiler is not ANSI C compatible. If GNU -CC is not installed, it is recommended to use the following options in + On HP-UX, the default C compiler is not ANSI C compatible. If GNU CC +is not installed, it is recommended to use the following options in order to use an ANSI C compiler: ./configure CC="cc -Ae -D_XOPEN_SOURCE=500" and if that doesn't work, install pre-built binaries of GCC for HP-UX. - HP-UX `make' updates targets which have the same time stamps as -their prerequisites, which makes it generally unusable when shipped -generated files such as `configure' are involved. Use GNU `make' -instead. + HP-UX 'make' updates targets which have the same time stamps as their +prerequisites, which makes it generally unusable when shipped generated +files such as 'configure' are involved. Use GNU 'make' instead. On OSF/1 a.k.a. Tru64, some versions of the default C compiler cannot -parse its `' header file. The option `-nodtk' can be used as -a workaround. If GNU CC is not installed, it is therefore recommended -to try +parse its '' header file. The option '-nodtk' can be used as a +workaround. If GNU CC is not installed, it is therefore recommended to +try ./configure CC="cc" @@ -242,26 +240,26 @@ and if that doesn't work, try ./configure CC="cc -nodtk" - On Solaris, don't put `/usr/ucb' early in your `PATH'. This + On Solaris, don't put '/usr/ucb' early in your 'PATH'. This directory contains several dysfunctional programs; working variants of -these programs are available in `/usr/bin'. So, if you need `/usr/ucb' -in your `PATH', put it _after_ `/usr/bin'. +these programs are available in '/usr/bin'. So, if you need '/usr/ucb' +in your 'PATH', put it _after_ '/usr/bin'. - On Haiku, software installed for all users goes in `/boot/common', -not `/usr/local'. It is recommended to use the following options: + On Haiku, software installed for all users goes in '/boot/common', +not '/usr/local'. It is recommended to use the following options: ./configure --prefix=/boot/common Specifying the System Type ========================== - There may be some features `configure' cannot figure out + There may be some features 'configure' cannot figure out automatically, but needs to determine by the type of machine the package will run on. Usually, assuming the package is built to be run on the -_same_ architectures, `configure' can figure that out, but if it prints +_same_ architectures, 'configure' can figure that out, but if it prints a message saying it cannot guess the machine type, give it the -`--build=TYPE' option. TYPE can either be a short name for the system -type, such as `sun4', or a canonical name which has the form: +'--build=TYPE' option. TYPE can either be a short name for the system +type, such as 'sun4', or a canonical name which has the form: CPU-COMPANY-SYSTEM @@ -270,101 +268,101 @@ where SYSTEM can have one of these forms: OS KERNEL-OS - See the file `config.sub' for the possible values of each field. If -`config.sub' isn't included in this package, then this package doesn't + See the file 'config.sub' for the possible values of each field. If +'config.sub' isn't included in this package, then this package doesn't need to know the machine type. If you are _building_ compiler tools for cross-compiling, you should -use the option `--target=TYPE' to select the type of system they will +use the option '--target=TYPE' to select the type of system they will produce code for. If you want to _use_ a cross compiler, that generates code for a platform different from the build platform, you should specify the "host" platform (i.e., that on which the generated programs will -eventually be run) with `--host=TYPE'. +eventually be run) with '--host=TYPE'. Sharing Defaults ================ - If you want to set default values for `configure' scripts to share, -you can create a site shell script called `config.site' that gives -default values for variables like `CC', `cache_file', and `prefix'. -`configure' looks for `PREFIX/share/config.site' if it exists, then -`PREFIX/etc/config.site' if it exists. Or, you can set the -`CONFIG_SITE' environment variable to the location of the site script. -A warning: not all `configure' scripts look for a site script. + If you want to set default values for 'configure' scripts to share, +you can create a site shell script called 'config.site' that gives +default values for variables like 'CC', 'cache_file', and 'prefix'. +'configure' looks for 'PREFIX/share/config.site' if it exists, then +'PREFIX/etc/config.site' if it exists. Or, you can set the +'CONFIG_SITE' environment variable to the location of the site script. +A warning: not all 'configure' scripts look for a site script. Defining Variables ================== Variables not defined in a site shell script can be set in the -environment passed to `configure'. However, some packages may run +environment passed to 'configure'. However, some packages may run configure again during the build, and the customized values of these variables may be lost. In order to avoid this problem, you should set -them in the `configure' command line, using `VAR=value'. For example: +them in the 'configure' command line, using 'VAR=value'. For example: ./configure CC=/usr/local2/bin/gcc -causes the specified `gcc' to be used as the C compiler (unless it is +causes the specified 'gcc' to be used as the C compiler (unless it is overridden in the site shell script). -Unfortunately, this technique does not work for `CONFIG_SHELL' due to -an Autoconf limitation. Until the limitation is lifted, you can use -this workaround: +Unfortunately, this technique does not work for 'CONFIG_SHELL' due to an +Autoconf limitation. Until the limitation is lifted, you can use this +workaround: CONFIG_SHELL=/bin/bash ./configure CONFIG_SHELL=/bin/bash -`configure' Invocation +'configure' Invocation ====================== - `configure' recognizes the following options to control how it + 'configure' recognizes the following options to control how it operates. -`--help' -`-h' - Print a summary of all of the options to `configure', and exit. +'--help' +'-h' + Print a summary of all of the options to 'configure', and exit. -`--help=short' -`--help=recursive' +'--help=short' +'--help=recursive' Print a summary of the options unique to this package's - `configure', and exit. The `short' variant lists options used - only in the top level, while the `recursive' variant lists options - also present in any nested packages. + 'configure', and exit. The 'short' variant lists options used only + in the top level, while the 'recursive' variant lists options also + present in any nested packages. -`--version' -`-V' - Print the version of Autoconf used to generate the `configure' +'--version' +'-V' + Print the version of Autoconf used to generate the 'configure' script, and exit. -`--cache-file=FILE' +'--cache-file=FILE' Enable the cache: use and save the results of the tests in FILE, - traditionally `config.cache'. FILE defaults to `/dev/null' to + traditionally 'config.cache'. FILE defaults to '/dev/null' to disable caching. -`--config-cache' -`-C' - Alias for `--cache-file=config.cache'. +'--config-cache' +'-C' + Alias for '--cache-file=config.cache'. -`--quiet' -`--silent' -`-q' +'--quiet' +'--silent' +'-q' Do not print messages saying which checks are being made. To - suppress all normal output, redirect it to `/dev/null' (any error + suppress all normal output, redirect it to '/dev/null' (any error messages will still be shown). -`--srcdir=DIR' +'--srcdir=DIR' Look for the package's source code in directory DIR. Usually - `configure' can determine that directory automatically. + 'configure' can determine that directory automatically. -`--prefix=DIR' - Use DIR as the installation prefix. *note Installation Names:: - for more details, including other options available for fine-tuning - the installation locations. +'--prefix=DIR' + Use DIR as the installation prefix. *note Installation Names:: for + more details, including other options available for fine-tuning the + installation locations. -`--no-create' -`-n' +'--no-create' +'-n' Run the configure checks, but stop before creating any output files. -`configure' also accepts some other, not widely useful, options. Run -`configure --help' for more details. +'configure' also accepts some other, not widely useful, options. Run +'configure --help' for more details. diff --git a/Makefile.in b/Makefile.in index 341d9a9..9d9f741 100644 --- a/Makefile.in +++ b/Makefile.in @@ -1,7 +1,7 @@ -# Makefile.in generated by automake 1.13.4 from Makefile.am. +# Makefile.in generated by automake 1.15.1 from Makefile.am. # @configure_input@ -# Copyright (C) 1994-2013 Free Software Foundation, Inc. +# Copyright (C) 1994-2017 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -16,7 +16,17 @@ VPATH = @srcdir@ -am__is_gnu_make = test -n '$(MAKEFILE_LIST)' && test -n '$(MAKELEVEL)' +am__is_gnu_make = { \ + if test -z '$(MAKELEVEL)'; then \ + false; \ + elif test -n '$(MAKE_HOST)'; then \ + true; \ + elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ + true; \ + else \ + false; \ + fi; \ +} am__make_running_with_option = \ case $${target_option-} in \ ?) ;; \ @@ -80,17 +90,6 @@ POST_UNINSTALL = : build_triplet = @build@ host_triplet = @host@ subdir = . -DIST_COMMON = INSTALL NEWS README AUTHORS ChangeLog \ - $(srcdir)/Makefile.in $(srcdir)/Makefile.am \ - $(top_srcdir)/configure $(am__configure_deps) $(dist_doc_DATA) \ - $(include_HEADERS) COPYING build-aux/ar-lib \ - build-aux/config.guess build-aux/config.sub build-aux/depcomp \ - build-aux/install-sh build-aux/missing \ - $(top_srcdir)/build-aux/ar-lib \ - $(top_srcdir)/build-aux/config.guess \ - $(top_srcdir)/build-aux/config.sub \ - $(top_srcdir)/build-aux/install-sh \ - $(top_srcdir)/build-aux/missing ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/m4/ax_blas.m4 \ $(top_srcdir)/m4/ax_check_compile_flags.m4 \ @@ -102,6 +101,9 @@ am__aclocal_m4_deps = $(top_srcdir)/m4/ax_blas.m4 \ $(top_srcdir)/m4/ax_lib_netcdf4.m4 $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) +DIST_COMMON = $(srcdir)/Makefile.am $(top_srcdir)/configure \ + $(am__configure_deps) $(dist_doc_DATA) $(include_HEADERS) \ + $(am__DIST_COMMON) am__CONFIG_DISTCLEAN_FILES = config.status config.cache config.log \ configure.lineno config.status.lineno mkinstalldirs = $(install_sh) -d @@ -194,6 +196,15 @@ ETAGS = etags CTAGS = ctags CSCOPE = cscope DIST_SUBDIRS = $(SUBDIRS) +am__DIST_COMMON = $(srcdir)/Makefile.in $(top_srcdir)/build-aux/ar-lib \ + $(top_srcdir)/build-aux/compile \ + $(top_srcdir)/build-aux/config.guess \ + $(top_srcdir)/build-aux/config.sub \ + $(top_srcdir)/build-aux/install-sh \ + $(top_srcdir)/build-aux/missing AUTHORS COPYING ChangeLog \ + INSTALL NEWS README build-aux/ar-lib build-aux/compile \ + build-aux/config.guess build-aux/config.sub build-aux/depcomp \ + build-aux/install-sh build-aux/missing DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) distdir = $(PACKAGE)-$(VERSION) top_distdir = $(distdir) @@ -411,7 +422,6 @@ $(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__confi echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --gnu Makefile -.PRECIOUS: Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ @@ -686,7 +696,7 @@ distdir: $(DISTFILES) ! -type d ! -perm -444 -exec $(install_sh) -c -m a+r {} {} \; \ || chmod -R a+r "$(distdir)" dist-gzip: distdir - tardir=$(distdir) && $(am__tar) | GZIP=$(GZIP_ENV) gzip -c >$(distdir).tar.gz + tardir=$(distdir) && $(am__tar) | eval GZIP= gzip $(GZIP_ENV) -c >$(distdir).tar.gz $(am__post_remove_distdir) dist-bzip2: distdir @@ -702,11 +712,17 @@ dist-xz: distdir $(am__post_remove_distdir) dist-tarZ: distdir + @echo WARNING: "Support for distribution archives compressed with" \ + "legacy program 'compress' is deprecated." >&2 + @echo WARNING: "It will be removed altogether in Automake 2.0" >&2 tardir=$(distdir) && $(am__tar) | compress -c >$(distdir).tar.Z $(am__post_remove_distdir) dist-shar: distdir - shar $(distdir) | GZIP=$(GZIP_ENV) gzip -c >$(distdir).shar.gz + @echo WARNING: "Support for shar distribution archives is" \ + "deprecated." >&2 + @echo WARNING: "It will be removed altogether in Automake 2.0" >&2 + shar $(distdir) | eval GZIP= gzip $(GZIP_ENV) -c >$(distdir).shar.gz $(am__post_remove_distdir) dist-zip: distdir @@ -724,7 +740,7 @@ dist dist-all: distcheck: dist case '$(DIST_ARCHIVES)' in \ *.tar.gz*) \ - GZIP=$(GZIP_ENV) gzip -dc $(distdir).tar.gz | $(am__untar) ;;\ + eval GZIP= gzip $(GZIP_ENV) -dc $(distdir).tar.gz | $(am__untar) ;;\ *.tar.bz2*) \ bzip2 -dc $(distdir).tar.bz2 | $(am__untar) ;;\ *.tar.lz*) \ @@ -734,22 +750,23 @@ distcheck: dist *.tar.Z*) \ uncompress -c $(distdir).tar.Z | $(am__untar) ;;\ *.shar.gz*) \ - GZIP=$(GZIP_ENV) gzip -dc $(distdir).shar.gz | unshar ;;\ + eval GZIP= gzip $(GZIP_ENV) -dc $(distdir).shar.gz | unshar ;;\ *.zip*) \ unzip $(distdir).zip ;;\ esac chmod -R a-w $(distdir) chmod u+w $(distdir) - mkdir $(distdir)/_build $(distdir)/_inst + mkdir $(distdir)/_build $(distdir)/_build/sub $(distdir)/_inst chmod a-w $(distdir) test -d $(distdir)/_build || exit 0; \ dc_install_base=`$(am__cd) $(distdir)/_inst && pwd | sed -e 's,^[^:\\/]:[\\/],/,'` \ && dc_destdir="$${TMPDIR-/tmp}/am-dc-$$$$/" \ && am__cwd=`pwd` \ - && $(am__cd) $(distdir)/_build \ - && ../configure --srcdir=.. --prefix="$$dc_install_base" \ + && $(am__cd) $(distdir)/_build/sub \ + && ../../configure \ $(AM_DISTCHECK_CONFIGURE_FLAGS) \ $(DISTCHECK_CONFIGURE_FLAGS) \ + --srcdir=../.. --prefix="$$dc_install_base" \ && $(MAKE) $(AM_MAKEFLAGS) \ && $(MAKE) $(AM_MAKEFLAGS) dvi \ && $(MAKE) $(AM_MAKEFLAGS) check \ @@ -935,6 +952,8 @@ uninstall-am: uninstall-dist_docDATA uninstall-includeHEADERS \ uninstall-local uninstall-nodist_dataDATA \ uninstall-nodist_includeHEADERS +.PRECIOUS: Makefile + wam.mk: @echo "# ESMF self-describing build dependency makefile fragment" > $(@) diff --git a/aclocal.m4 b/aclocal.m4 index 4da2f9a..f76af5b 100644 --- a/aclocal.m4 +++ b/aclocal.m4 @@ -1,6 +1,6 @@ -# generated automatically by aclocal 1.13.4 -*- Autoconf -*- +# generated automatically by aclocal 1.15.1 -*- Autoconf -*- -# Copyright (C) 1996-2013 Free Software Foundation, Inc. +# Copyright (C) 1996-2017 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -20,7 +20,7 @@ You have another version of autoconf. It may work, but is not guaranteed to. If you have problems, you may need to regenerate the build system entirely. To do so, use the procedure documented by the package, typically 'autoreconf'.])]) -# Copyright (C) 2002-2013 Free Software Foundation, Inc. +# Copyright (C) 2002-2017 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -32,10 +32,10 @@ To do so, use the procedure documented by the package, typically 'autoreconf'.]) # generated from the m4 files accompanying Automake X.Y. # (This private macro should not be called outside this file.) AC_DEFUN([AM_AUTOMAKE_VERSION], -[am__api_version='1.13' +[am__api_version='1.15' dnl Some users find AM_AUTOMAKE_VERSION and mistake it for a way to dnl require some minimum version. Point them to the right macro. -m4_if([$1], [1.13.4], [], +m4_if([$1], [1.15.1], [], [AC_FATAL([Do not call $0, use AM_INIT_AUTOMAKE([$1]).])])dnl ]) @@ -51,12 +51,12 @@ m4_define([_AM_AUTOCONF_VERSION], []) # Call AM_AUTOMAKE_VERSION and AM_AUTOMAKE_VERSION so they can be traced. # This function is AC_REQUIREd by AM_INIT_AUTOMAKE. AC_DEFUN([AM_SET_CURRENT_AUTOMAKE_VERSION], -[AM_AUTOMAKE_VERSION([1.13.4])dnl +[AM_AUTOMAKE_VERSION([1.15.1])dnl m4_ifndef([AC_AUTOCONF_VERSION], [m4_copy([m4_PACKAGE_VERSION], [AC_AUTOCONF_VERSION])])dnl _AM_AUTOCONF_VERSION(m4_defn([AC_AUTOCONF_VERSION]))]) -# Copyright (C) 2011-2013 Free Software Foundation, Inc. +# Copyright (C) 2011-2017 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -76,7 +76,8 @@ AC_CHECK_TOOLS([AR], [ar lib "link -lib"], [false]) : ${AR=ar} AC_CACHE_CHECK([the archiver ($AR) interface], [am_cv_ar_interface], - [am_cv_ar_interface=ar + [AC_LANG_PUSH([C]) + am_cv_ar_interface=ar AC_COMPILE_IFELSE([AC_LANG_SOURCE([[int some_variable = 0;]])], [am_ar_try='$AR cru libconftest.a conftest.$ac_objext >&AS_MESSAGE_LOG_FD' AC_TRY_EVAL([am_ar_try]) @@ -93,7 +94,7 @@ AC_CACHE_CHECK([the archiver ($AR) interface], [am_cv_ar_interface], fi rm -f conftest.lib libconftest.a ]) - ]) + AC_LANG_POP([C])]) case $am_cv_ar_interface in ar) @@ -117,7 +118,7 @@ AC_SUBST([AR])dnl # AM_AUX_DIR_EXPAND -*- Autoconf -*- -# Copyright (C) 2001-2013 Free Software Foundation, Inc. +# Copyright (C) 2001-2017 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -169,7 +170,7 @@ am_aux_dir=`cd "$ac_aux_dir" && pwd` # AM_CONDITIONAL -*- Autoconf -*- -# Copyright (C) 1997-2013 Free Software Foundation, Inc. +# Copyright (C) 1997-2017 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -200,7 +201,7 @@ AC_CONFIG_COMMANDS_PRE( Usually this means the macro was only invoked conditionally.]]) fi])]) -# Copyright (C) 1999-2013 Free Software Foundation, Inc. +# Copyright (C) 1999-2017 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -391,7 +392,7 @@ _AM_SUBST_NOTMAKE([am__nodep])dnl # Generate code to set up dependency tracking. -*- Autoconf -*- -# Copyright (C) 1999-2013 Free Software Foundation, Inc. +# Copyright (C) 1999-2017 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -467,7 +468,7 @@ AC_DEFUN([AM_OUTPUT_DEPENDENCY_COMMANDS], # Do all the work for Automake. -*- Autoconf -*- -# Copyright (C) 1996-2013 Free Software Foundation, Inc. +# Copyright (C) 1996-2017 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -476,6 +477,12 @@ AC_DEFUN([AM_OUTPUT_DEPENDENCY_COMMANDS], # This macro actually does too much. Some checks are only needed if # your package does certain things. But this isn't really a big deal. +dnl Redefine AC_PROG_CC to automatically invoke _AM_PROG_CC_C_O. +m4_define([AC_PROG_CC], +m4_defn([AC_PROG_CC]) +[_AM_PROG_CC_C_O +]) + # AM_INIT_AUTOMAKE(PACKAGE, VERSION, [NO-DEFINE]) # AM_INIT_AUTOMAKE([OPTIONS]) # ----------------------------------------------- @@ -551,8 +558,8 @@ AC_REQUIRE([AC_PROG_MKDIR_P])dnl # # AC_SUBST([mkdir_p], ['$(MKDIR_P)']) -# We need awk for the "check" target. The system "awk" is bad on -# some platforms. +# We need awk for the "check" target (and possibly the TAP driver). The +# system "awk" is bad on some platforms. AC_REQUIRE([AC_PROG_AWK])dnl AC_REQUIRE([AC_PROG_MAKE_SET])dnl AC_REQUIRE([AM_SET_LEADING_DOT])dnl @@ -584,6 +591,51 @@ dnl macro is hooked onto _AC_COMPILER_EXEEXT early, see below. AC_CONFIG_COMMANDS_PRE(dnl [m4_provide_if([_AM_COMPILER_EXEEXT], [AM_CONDITIONAL([am__EXEEXT], [test -n "$EXEEXT"])])])dnl + +# POSIX will say in a future version that running "rm -f" with no argument +# is OK; and we want to be able to make that assumption in our Makefile +# recipes. So use an aggressive probe to check that the usage we want is +# actually supported "in the wild" to an acceptable degree. +# See automake bug#10828. +# To make any issue more visible, cause the running configure to be aborted +# by default if the 'rm' program in use doesn't match our expectations; the +# user can still override this though. +if rm -f && rm -fr && rm -rf; then : OK; else + cat >&2 <<'END' +Oops! + +Your 'rm' program seems unable to run without file operands specified +on the command line, even when the '-f' option is present. This is contrary +to the behaviour of most rm programs out there, and not conforming with +the upcoming POSIX standard: + +Please tell bug-automake@gnu.org about your system, including the value +of your $PATH and any error possibly output before this message. This +can help us improve future automake versions. + +END + if test x"$ACCEPT_INFERIOR_RM_PROGRAM" = x"yes"; then + echo 'Configuration will proceed anyway, since you have set the' >&2 + echo 'ACCEPT_INFERIOR_RM_PROGRAM variable to "yes"' >&2 + echo >&2 + else + cat >&2 <<'END' +Aborting the configuration process, to ensure you take notice of the issue. + +You can download and install GNU coreutils to get an 'rm' implementation +that behaves properly: . + +If you want to complete the configuration process using your problematic +'rm' anyway, export the environment variable ACCEPT_INFERIOR_RM_PROGRAM +to "yes", and re-run configure. + +END + AC_MSG_ERROR([Your 'rm' program is bad, sorry.]) + fi +fi +dnl The trailing newline in this macro's definition is deliberate, for +dnl backward compatibility and to allow trailing 'dnl'-style comments +dnl after the AM_INIT_AUTOMAKE invocation. See automake bug#16841. ]) dnl Hook into '_AC_COMPILER_EXEEXT' early to learn its expansion. Do not @@ -592,7 +644,6 @@ dnl mangled by Autoconf and run in a shell conditional statement. m4_define([_AC_COMPILER_EXEEXT], m4_defn([_AC_COMPILER_EXEEXT])[m4_provide([_AM_COMPILER_EXEEXT])]) - # When config.status generates a header, we must update the stamp-h file. # This file resides in the same directory as the config header # that is generated. The stamp files are numbered to have different names. @@ -614,7 +665,7 @@ for _am_header in $config_headers :; do done echo "timestamp for $_am_arg" >`AS_DIRNAME(["$_am_arg"])`/stamp-h[]$_am_stamp_count]) -# Copyright (C) 2001-2013 Free Software Foundation, Inc. +# Copyright (C) 2001-2017 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -625,7 +676,7 @@ echo "timestamp for $_am_arg" >`AS_DIRNAME(["$_am_arg"])`/stamp-h[]$_am_stamp_co # Define $install_sh. AC_DEFUN([AM_PROG_INSTALL_SH], [AC_REQUIRE([AM_AUX_DIR_EXPAND])dnl -if test x"${install_sh}" != xset; then +if test x"${install_sh+set}" != xset; then case $am_aux_dir in *\ * | *\ *) install_sh="\${SHELL} '$am_aux_dir/install-sh'" ;; @@ -635,7 +686,7 @@ if test x"${install_sh}" != xset; then fi AC_SUBST([install_sh])]) -# Copyright (C) 2003-2013 Free Software Foundation, Inc. +# Copyright (C) 2003-2017 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -657,7 +708,7 @@ AC_SUBST([am__leading_dot])]) # Add --enable-maintainer-mode option to configure. -*- Autoconf -*- # From Jim Meyering -# Copyright (C) 1996-2013 Free Software Foundation, Inc. +# Copyright (C) 1996-2017 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -692,7 +743,7 @@ AC_MSG_CHECKING([whether to enable maintainer-specific portions of Makefiles]) # Check to see how 'make' treats includes. -*- Autoconf -*- -# Copyright (C) 2001-2013 Free Software Foundation, Inc. +# Copyright (C) 2001-2017 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -742,7 +793,7 @@ rm -f confinc confmf # Fake the existence of programs that GNU maintainers use. -*- Autoconf -*- -# Copyright (C) 1997-2013 Free Software Foundation, Inc. +# Copyright (C) 1997-2017 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -781,7 +832,7 @@ fi # Helper functions for option handling. -*- Autoconf -*- -# Copyright (C) 2001-2013 Free Software Foundation, Inc. +# Copyright (C) 2001-2017 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -810,9 +861,73 @@ AC_DEFUN([_AM_SET_OPTIONS], AC_DEFUN([_AM_IF_OPTION], [m4_ifset(_AM_MANGLE_OPTION([$1]), [$2], [$3])]) +# Copyright (C) 1999-2017 Free Software Foundation, Inc. +# +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# _AM_PROG_CC_C_O +# --------------- +# Like AC_PROG_CC_C_O, but changed for automake. We rewrite AC_PROG_CC +# to automatically call this. +AC_DEFUN([_AM_PROG_CC_C_O], +[AC_REQUIRE([AM_AUX_DIR_EXPAND])dnl +AC_REQUIRE_AUX_FILE([compile])dnl +AC_LANG_PUSH([C])dnl +AC_CACHE_CHECK( + [whether $CC understands -c and -o together], + [am_cv_prog_cc_c_o], + [AC_LANG_CONFTEST([AC_LANG_PROGRAM([])]) + # Make sure it works both with $CC and with simple cc. + # Following AC_PROG_CC_C_O, we do the test twice because some + # compilers refuse to overwrite an existing .o file with -o, + # though they will create one. + am_cv_prog_cc_c_o=yes + for am_i in 1 2; do + if AM_RUN_LOG([$CC -c conftest.$ac_ext -o conftest2.$ac_objext]) \ + && test -f conftest2.$ac_objext; then + : OK + else + am_cv_prog_cc_c_o=no + break + fi + done + rm -f core conftest* + unset am_i]) +if test "$am_cv_prog_cc_c_o" != yes; then + # Losing compiler, so override with the script. + # FIXME: It is wrong to rewrite CC. + # But if we don't then we get into trouble of one sort or another. + # A longer-term fix would be to have automake use am__CC in this case, + # and then we could set am__CC="\$(top_srcdir)/compile \$(CC)" + CC="$am_aux_dir/compile $CC" +fi +AC_LANG_POP([C])]) + +# For backward compatibility. +AC_DEFUN_ONCE([AM_PROG_CC_C_O], [AC_REQUIRE([AC_PROG_CC])]) + +# Copyright (C) 2001-2017 Free Software Foundation, Inc. +# +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# AM_RUN_LOG(COMMAND) +# ------------------- +# Run COMMAND, save the exit status in ac_status, and log it. +# (This has been adapted from Autoconf's _AC_RUN_LOG macro.) +AC_DEFUN([AM_RUN_LOG], +[{ echo "$as_me:$LINENO: $1" >&AS_MESSAGE_LOG_FD + ($1) >&AS_MESSAGE_LOG_FD 2>&AS_MESSAGE_LOG_FD + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&AS_MESSAGE_LOG_FD + (exit $ac_status); }]) + # Check to make sure that the build environment is sane. -*- Autoconf -*- -# Copyright (C) 1996-2013 Free Software Foundation, Inc. +# Copyright (C) 1996-2017 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -893,7 +1008,7 @@ AC_CONFIG_COMMANDS_PRE( rm -f conftest.file ]) -# Copyright (C) 2009-2013 Free Software Foundation, Inc. +# Copyright (C) 2009-2017 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -953,7 +1068,7 @@ AC_SUBST([AM_BACKSLASH])dnl _AM_SUBST_NOTMAKE([AM_BACKSLASH])dnl ]) -# Copyright (C) 2001-2013 Free Software Foundation, Inc. +# Copyright (C) 2001-2017 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -981,7 +1096,7 @@ fi INSTALL_STRIP_PROGRAM="\$(install_sh) -c -s" AC_SUBST([INSTALL_STRIP_PROGRAM])]) -# Copyright (C) 2006-2013 Free Software Foundation, Inc. +# Copyright (C) 2006-2017 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -1000,7 +1115,7 @@ AC_DEFUN([AM_SUBST_NOTMAKE], [_AM_SUBST_NOTMAKE($@)]) # Check how to create a tarball. -*- Autoconf -*- -# Copyright (C) 2004-2013 Free Software Foundation, Inc. +# Copyright (C) 2004-2017 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, diff --git a/build-aux/ar-lib b/build-aux/ar-lib index fe2301e..05094d3 100755 --- a/build-aux/ar-lib +++ b/build-aux/ar-lib @@ -4,7 +4,7 @@ me=ar-lib scriptversion=2012-03-01.08; # UTC -# Copyright (C) 2010-2013 Free Software Foundation, Inc. +# Copyright (C) 2010-2017 Free Software Foundation, Inc. # Written by Peter Rosin . # # This program is free software; you can redistribute it and/or modify diff --git a/build-aux/config.guess b/build-aux/config.guess index c6fad2f..1bf683d 100755 --- a/build-aux/config.guess +++ b/build-aux/config.guess @@ -1,8 +1,8 @@ #! /bin/sh # Attempt to guess a canonical system name. -# Copyright 1992-2013 Free Software Foundation, Inc. +# Copyright 1992-2017 Free Software Foundation, Inc. -timestamp='2013-06-10' +timestamp='2017-05-27' # This file is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by @@ -24,12 +24,12 @@ timestamp='2013-06-10' # program. This Exception is an additional permission under section 7 # of the GNU General Public License, version 3 ("GPLv3"). # -# Originally written by Per Bothner. +# Originally written by Per Bothner; maintained since 2000 by Ben Elliston. # # You can get the latest version of this script from: -# http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess;hb=HEAD +# http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess # -# Please send patches with a ChangeLog entry to config-patches@gnu.org. +# Please send patches to . me=`echo "$0" | sed -e 's,.*/,,'` @@ -50,7 +50,7 @@ version="\ GNU config.guess ($timestamp) Originally written by Per Bothner. -Copyright 1992-2013 Free Software Foundation, Inc. +Copyright 1992-2017 Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." @@ -149,7 +149,7 @@ Linux|GNU|GNU/*) LIBC=gnu #endif EOF - eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^LIBC'` + eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^LIBC' | sed 's, ,,g'` ;; esac @@ -178,19 +178,29 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in # Note: NetBSD doesn't particularly care about the vendor # portion of the name. We always set it to "unknown". sysctl="sysctl -n hw.machine_arch" - UNAME_MACHINE_ARCH=`(/sbin/$sysctl 2>/dev/null || \ - /usr/sbin/$sysctl 2>/dev/null || echo unknown)` + UNAME_MACHINE_ARCH=`(uname -p 2>/dev/null || \ + /sbin/$sysctl 2>/dev/null || \ + /usr/sbin/$sysctl 2>/dev/null || \ + echo unknown)` case "${UNAME_MACHINE_ARCH}" in armeb) machine=armeb-unknown ;; arm*) machine=arm-unknown ;; sh3el) machine=shl-unknown ;; sh3eb) machine=sh-unknown ;; sh5el) machine=sh5le-unknown ;; - *) machine=${UNAME_MACHINE_ARCH}-unknown ;; + earmv*) + arch=`echo ${UNAME_MACHINE_ARCH} | sed -e 's,^e\(armv[0-9]\).*$,\1,'` + endian=`echo ${UNAME_MACHINE_ARCH} | sed -ne 's,^.*\(eb\)$,\1,p'` + machine=${arch}${endian}-${VENDOR}-unknown + ;; + *) machine=${UNAME_MACHINE_ARCH}-${VENDOR}-unknown ;; esac # The Operating System including object format, if it has switched - # to ELF recently, or will in the future. + # to ELF recently (or will in the future) and ABI. case "${UNAME_MACHINE_ARCH}" in + earm*) + os=netbsdelf + ;; arm*|i386|m68k|ns32k|sh3*|sparc|vax) eval $set_cc_for_build if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \ @@ -207,6 +217,13 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in os=netbsd ;; esac + # Determine ABI tags. + case "${UNAME_MACHINE_ARCH}" in + earm*) + expr='s/^earmv[0-9]/-eabi/;s/eb$//' + abi=`echo ${UNAME_MACHINE_ARCH} | sed -e "$expr"` + ;; + esac # The OS release # Debian GNU/NetBSD machines have a different userland, and # thus, need a distinct triplet. However, they do not need @@ -217,13 +234,13 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in release='-gnu' ;; *) - release=`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` + release=`echo ${UNAME_RELEASE} | sed -e 's/[-_].*//' | cut -d. -f1,2` ;; esac # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM: # contains redundant information, the shorter form: # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used. - echo "${machine}-${os}${release}" + echo "${machine}-${os}${release}${abi}" exit ;; *:Bitrig:*:*) UNAME_MACHINE_ARCH=`arch | sed 's/Bitrig.//'` @@ -233,6 +250,10 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'` echo ${UNAME_MACHINE_ARCH}-${VENDOR}-openbsd${UNAME_RELEASE} exit ;; + *:LibertyBSD:*:*) + UNAME_MACHINE_ARCH=`arch | sed 's/^.*BSD\.//'` + echo ${UNAME_MACHINE_ARCH}-${VENDOR}-libertybsd${UNAME_RELEASE} + exit ;; *:ekkoBSD:*:*) echo ${UNAME_MACHINE}-${VENDOR}-ekkobsd${UNAME_RELEASE} exit ;; @@ -245,6 +266,9 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in *:MirBSD:*:*) echo ${UNAME_MACHINE}-${VENDOR}-mirbsd${UNAME_RELEASE} exit ;; + *:Sortix:*:*) + echo ${UNAME_MACHINE}-${VENDOR}-sortix + exit ;; alpha:OSF1:*:*) case $UNAME_RELEASE in *4.0) @@ -261,42 +285,42 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in ALPHA_CPU_TYPE=`/usr/sbin/psrinfo -v | sed -n -e 's/^ The alpha \(.*\) processor.*$/\1/p' | head -n 1` case "$ALPHA_CPU_TYPE" in "EV4 (21064)") - UNAME_MACHINE="alpha" ;; + UNAME_MACHINE=alpha ;; "EV4.5 (21064)") - UNAME_MACHINE="alpha" ;; + UNAME_MACHINE=alpha ;; "LCA4 (21066/21068)") - UNAME_MACHINE="alpha" ;; + UNAME_MACHINE=alpha ;; "EV5 (21164)") - UNAME_MACHINE="alphaev5" ;; + UNAME_MACHINE=alphaev5 ;; "EV5.6 (21164A)") - UNAME_MACHINE="alphaev56" ;; + UNAME_MACHINE=alphaev56 ;; "EV5.6 (21164PC)") - UNAME_MACHINE="alphapca56" ;; + UNAME_MACHINE=alphapca56 ;; "EV5.7 (21164PC)") - UNAME_MACHINE="alphapca57" ;; + UNAME_MACHINE=alphapca57 ;; "EV6 (21264)") - UNAME_MACHINE="alphaev6" ;; + UNAME_MACHINE=alphaev6 ;; "EV6.7 (21264A)") - UNAME_MACHINE="alphaev67" ;; + UNAME_MACHINE=alphaev67 ;; "EV6.8CB (21264C)") - UNAME_MACHINE="alphaev68" ;; + UNAME_MACHINE=alphaev68 ;; "EV6.8AL (21264B)") - UNAME_MACHINE="alphaev68" ;; + UNAME_MACHINE=alphaev68 ;; "EV6.8CX (21264D)") - UNAME_MACHINE="alphaev68" ;; + UNAME_MACHINE=alphaev68 ;; "EV6.9A (21264/EV69A)") - UNAME_MACHINE="alphaev69" ;; + UNAME_MACHINE=alphaev69 ;; "EV7 (21364)") - UNAME_MACHINE="alphaev7" ;; + UNAME_MACHINE=alphaev7 ;; "EV7.9 (21364A)") - UNAME_MACHINE="alphaev79" ;; + UNAME_MACHINE=alphaev79 ;; esac # A Pn.n version is a patched version. # A Vn.n version is a released version. # A Tn.n version is a released field test version. # A Xn.n version is an unreleased experimental baselevel. # 1.2 uses "1.2" for uname -r. - echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` + echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz` # Reset EXIT trap before exiting to avoid spurious non-zero exit code. exitcode=$? trap '' 0 @@ -369,16 +393,16 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in exit ;; i86pc:SunOS:5.*:* | i86xen:SunOS:5.*:*) eval $set_cc_for_build - SUN_ARCH="i386" + SUN_ARCH=i386 # If there is a compiler, see if it is configured for 64-bit objects. # Note that the Sun cc does not turn __LP64__ into 1 like gcc does. # This test works for both compilers. - if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then + if [ "$CC_FOR_BUILD" != no_compiler_found ]; then if (echo '#ifdef __amd64'; echo IS_64BIT_ARCH; echo '#endif') | \ - (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ + (CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | \ grep IS_64BIT_ARCH >/dev/null then - SUN_ARCH="x86_64" + SUN_ARCH=x86_64 fi fi echo ${SUN_ARCH}-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` @@ -403,7 +427,7 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in exit ;; sun*:*:4.2BSD:*) UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null` - test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3 + test "x${UNAME_RELEASE}" = x && UNAME_RELEASE=3 case "`/bin/arch`" in sun3) echo m68k-sun-sunos${UNAME_RELEASE} @@ -589,8 +613,9 @@ EOF else IBM_ARCH=powerpc fi - if [ -x /usr/bin/oslevel ] ; then - IBM_REV=`/usr/bin/oslevel` + if [ -x /usr/bin/lslpp ] ; then + IBM_REV=`/usr/bin/lslpp -Lqc bos.rte.libc | + awk -F: '{ print $3 }' | sed s/[0-9]*$/0/` else IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} fi @@ -627,13 +652,13 @@ EOF sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null` sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null` case "${sc_cpu_version}" in - 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0 - 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1 + 523) HP_ARCH=hppa1.0 ;; # CPU_PA_RISC1_0 + 528) HP_ARCH=hppa1.1 ;; # CPU_PA_RISC1_1 532) # CPU_PA_RISC2_0 case "${sc_kernel_bits}" in - 32) HP_ARCH="hppa2.0n" ;; - 64) HP_ARCH="hppa2.0w" ;; - '') HP_ARCH="hppa2.0" ;; # HP-UX 10.20 + 32) HP_ARCH=hppa2.0n ;; + 64) HP_ARCH=hppa2.0w ;; + '') HP_ARCH=hppa2.0 ;; # HP-UX 10.20 esac ;; esac fi @@ -672,11 +697,11 @@ EOF exit (0); } EOF - (CCOPTS= $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy` + (CCOPTS="" $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy` test -z "$HP_ARCH" && HP_ARCH=hppa fi ;; esac - if [ ${HP_ARCH} = "hppa2.0w" ] + if [ ${HP_ARCH} = hppa2.0w ] then eval $set_cc_for_build @@ -689,12 +714,12 @@ EOF # $ CC_FOR_BUILD="cc +DA2.0w" ./config.guess # => hppa64-hp-hpux11.23 - if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | + if echo __LP64__ | (CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | grep -q __LP64__ then - HP_ARCH="hppa2.0w" + HP_ARCH=hppa2.0w else - HP_ARCH="hppa64" + HP_ARCH=hppa64 fi fi echo ${HP_ARCH}-hp-hpux${HPUX_REV} @@ -799,14 +824,14 @@ EOF echo craynv-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*) - FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` - FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` + FUJITSU_PROC=`uname -m | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz` + FUJITSU_SYS=`uname -p | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz | sed -e 's/\///'` FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'` echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" exit ;; 5000:UNIX_System_V:4.*:*) - FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` - FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'` + FUJITSU_SYS=`uname -p | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz | sed -e 's/\///'` + FUJITSU_REL=`echo ${UNAME_RELEASE} | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz | sed -e 's/ /_/'` echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" exit ;; i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*) @@ -822,10 +847,11 @@ EOF UNAME_PROCESSOR=`/usr/bin/uname -p` case ${UNAME_PROCESSOR} in amd64) - echo x86_64-${VENDOR}-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; - *) - echo ${UNAME_PROCESSOR}-${VENDOR}-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; + UNAME_PROCESSOR=x86_64 ;; + i386) + UNAME_PROCESSOR=i586 ;; esac + echo ${UNAME_PROCESSOR}-${VENDOR}-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` exit ;; i*:CYGWIN*:*) echo ${UNAME_MACHINE}-pc-cygwin @@ -836,7 +862,7 @@ EOF *:MINGW*:*) echo ${UNAME_MACHINE}-pc-mingw32 exit ;; - i*:MSYS*:*) + *:MSYS*:*) echo ${UNAME_MACHINE}-pc-msys exit ;; i*:windows32*:*) @@ -888,7 +914,7 @@ EOF exit ;; *:GNU/*:*:*) # other systems with GNU libc and userland - echo ${UNAME_MACHINE}-${VENDOR}-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-${LIBC} + echo ${UNAME_MACHINE}-${VENDOR}-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr "[:upper:]" "[:lower:]"``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-${LIBC} exit ;; i*86:Minix:*:*) echo ${UNAME_MACHINE}-pc-minix @@ -911,7 +937,7 @@ EOF EV68*) UNAME_MACHINE=alphaev68 ;; esac objdump --private-headers /bin/sh | grep -q ld.so.1 - if test "$?" = 0 ; then LIBC="gnulibc1" ; fi + if test "$?" = 0 ; then LIBC=gnulibc1 ; fi echo ${UNAME_MACHINE}-${VENDOR}-linux-${LIBC} exit ;; arc:Linux:*:* | arceb:Linux:*:*) @@ -942,6 +968,9 @@ EOF crisv32:Linux:*:*) echo ${UNAME_MACHINE}-axis-linux-${LIBC} exit ;; + e2k:Linux:*:*) + echo ${UNAME_MACHINE}-${VENDOR}-linux-${LIBC} + exit ;; frv:Linux:*:*) echo ${UNAME_MACHINE}-${VENDOR}-linux-${LIBC} exit ;; @@ -954,6 +983,9 @@ EOF ia64:Linux:*:*) echo ${UNAME_MACHINE}-${VENDOR}-linux-${LIBC} exit ;; + k1om:Linux:*:*) + echo ${UNAME_MACHINE}-${VENDOR}-linux-${LIBC} + exit ;; m32r*:Linux:*:*) echo ${UNAME_MACHINE}-${VENDOR}-linux-${LIBC} exit ;; @@ -979,10 +1011,13 @@ EOF eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^CPU'` test x"${CPU}" != x && { echo "${CPU}-${VENDOR}-linux-${LIBC}"; exit; } ;; - or1k:Linux:*:*) + mips64el:Linux:*:*) echo ${UNAME_MACHINE}-${VENDOR}-linux-${LIBC} exit ;; - or32:Linux:*:*) + openrisc*:Linux:*:*) + echo or1k-${VENDOR}-linux-${LIBC} + exit ;; + or32:Linux:*:* | or1k*:Linux:*:*) echo ${UNAME_MACHINE}-${VENDOR}-linux-${LIBC} exit ;; padre:Linux:*:*) @@ -1011,6 +1046,9 @@ EOF ppcle:Linux:*:*) echo powerpcle-${VENDOR}-linux-${LIBC} exit ;; + riscv32:Linux:*:* | riscv64:Linux:*:*) + echo ${UNAME_MACHINE}-${VENDOR}-linux-${LIBC} + exit ;; s390:Linux:*:* | s390x:Linux:*:*) echo ${UNAME_MACHINE}-ibm-linux-${LIBC} exit ;; @@ -1030,7 +1068,7 @@ EOF echo ${UNAME_MACHINE}-dec-linux-${LIBC} exit ;; x86_64:Linux:*:*) - echo ${UNAME_MACHINE}-${VENDOR}-linux-${LIBC} + echo ${UNAME_MACHINE}-pc-linux-${LIBC} exit ;; xtensa*:Linux:*:*) echo ${UNAME_MACHINE}-${VENDOR}-linux-${LIBC} @@ -1109,7 +1147,7 @@ EOF # uname -m prints for DJGPP always 'pc', but it prints nothing about # the processor, so we play safe by assuming i586. # Note: whatever this is, it MUST be the same as what config.sub - # prints for the "djgpp" host, or else GDB configury will decide that + # prints for the "djgpp" host, or else GDB configure will decide that # this is a cross-build. echo i586-pc-msdosdjgpp exit ;; @@ -1258,6 +1296,9 @@ EOF SX-8R:SUPER-UX:*:*) echo sx8r-nec-superux${UNAME_RELEASE} exit ;; + SX-ACE:SUPER-UX:*:*) + echo sxace-nec-superux${UNAME_RELEASE} + exit ;; Power*:Rhapsody:*:*) echo powerpc-apple-rhapsody${UNAME_RELEASE} exit ;; @@ -1270,22 +1311,39 @@ EOF if test "$UNAME_PROCESSOR" = unknown ; then UNAME_PROCESSOR=powerpc fi - if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then - if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \ - (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ - grep IS_64BIT_ARCH >/dev/null - then - case $UNAME_PROCESSOR in - i386) UNAME_PROCESSOR=x86_64 ;; - powerpc) UNAME_PROCESSOR=powerpc64 ;; - esac + if test `echo "$UNAME_RELEASE" | sed -e 's/\..*//'` -le 10 ; then + if [ "$CC_FOR_BUILD" != no_compiler_found ]; then + if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \ + (CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | \ + grep IS_64BIT_ARCH >/dev/null + then + case $UNAME_PROCESSOR in + i386) UNAME_PROCESSOR=x86_64 ;; + powerpc) UNAME_PROCESSOR=powerpc64 ;; + esac + fi + # On 10.4-10.6 one might compile for PowerPC via gcc -arch ppc + if (echo '#ifdef __POWERPC__'; echo IS_PPC; echo '#endif') | \ + (CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | \ + grep IS_PPC >/dev/null + then + UNAME_PROCESSOR=powerpc + fi fi + elif test "$UNAME_PROCESSOR" = i386 ; then + # Avoid executing cc on OS X 10.9, as it ships with a stub + # that puts up a graphical alert prompting to install + # developer tools. Any system running Mac OS X 10.7 or + # later (Darwin 11 and later) is required to have a 64-bit + # processor. This is not true of the ARM version of Darwin + # that Apple uses in portable devices. + UNAME_PROCESSOR=x86_64 fi echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE} exit ;; *:procnto*:*:* | *:QNX:[0123456789]*:*) UNAME_PROCESSOR=`uname -p` - if test "$UNAME_PROCESSOR" = "x86"; then + if test "$UNAME_PROCESSOR" = x86; then UNAME_PROCESSOR=i386 UNAME_MACHINE=pc fi @@ -1294,15 +1352,18 @@ EOF *:QNX:*:4*) echo i386-pc-qnx exit ;; - NEO-?:NONSTOP_KERNEL:*:*) + NEO-*:NONSTOP_KERNEL:*:*) echo neo-tandem-nsk${UNAME_RELEASE} exit ;; NSE-*:NONSTOP_KERNEL:*:*) echo nse-tandem-nsk${UNAME_RELEASE} exit ;; - NSR-?:NONSTOP_KERNEL:*:*) + NSR-*:NONSTOP_KERNEL:*:*) echo nsr-tandem-nsk${UNAME_RELEASE} exit ;; + NSX-*:NONSTOP_KERNEL:*:*) + echo nsx-tandem-nsk${UNAME_RELEASE} + exit ;; *:NonStop-UX:*:*) echo mips-compaq-nonstopux exit ;; @@ -1316,7 +1377,7 @@ EOF # "uname -m" is not consistent, so use $cputype instead. 386 # is converted to i386 for consistency with other x86 # operating systems. - if test "$cputype" = "386"; then + if test "$cputype" = 386; then UNAME_MACHINE=i386 else UNAME_MACHINE="$cputype" @@ -1358,7 +1419,7 @@ EOF echo i386-pc-xenix exit ;; i*86:skyos:*:*) - echo ${UNAME_MACHINE}-pc-skyos`echo ${UNAME_RELEASE}` | sed -e 's/ .*$//' + echo ${UNAME_MACHINE}-pc-skyos`echo ${UNAME_RELEASE} | sed -e 's/ .*$//'` exit ;; i*86:rdos:*:*) echo ${UNAME_MACHINE}-pc-rdos @@ -1369,171 +1430,25 @@ EOF x86_64:VMkernel:*:*) echo ${UNAME_MACHINE}-${VENDOR}-esx exit ;; -esac - -eval $set_cc_for_build -cat >$dummy.c < -# include -#endif -main () -{ -#if defined (sony) -#if defined (MIPSEB) - /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed, - I don't know.... */ - printf ("mips-sony-bsd\n"); exit (0); -#else -#include - printf ("m68k-sony-newsos%s\n", -#ifdef NEWSOS4 - "4" -#else - "" -#endif - ); exit (0); -#endif -#endif - -#if defined (__arm) && defined (__acorn) && defined (__unix) - printf ("arm-acorn-riscix\n"); exit (0); -#endif - -#if defined (hp300) && !defined (hpux) - printf ("m68k-hp-bsd\n"); exit (0); -#endif - -#if defined (NeXT) -#if !defined (__ARCHITECTURE__) -#define __ARCHITECTURE__ "m68k" -#endif - int version; - version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`; - if (version < 4) - printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version); - else - printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version); - exit (0); -#endif - -#if defined (MULTIMAX) || defined (n16) -#if defined (UMAXV) - printf ("ns32k-encore-sysv\n"); exit (0); -#else -#if defined (CMU) - printf ("ns32k-encore-mach\n"); exit (0); -#else - printf ("ns32k-encore-bsd\n"); exit (0); -#endif -#endif -#endif - -#if defined (__386BSD__) - printf ("i386-pc-bsd\n"); exit (0); -#endif - -#if defined (sequent) -#if defined (i386) - printf ("i386-sequent-dynix\n"); exit (0); -#endif -#if defined (ns32000) - printf ("ns32k-sequent-dynix\n"); exit (0); -#endif -#endif - -#if defined (_SEQUENT_) - struct utsname un; - - uname(&un); - - if (strncmp(un.version, "V2", 2) == 0) { - printf ("i386-sequent-ptx2\n"); exit (0); - } - if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */ - printf ("i386-sequent-ptx1\n"); exit (0); - } - printf ("i386-sequent-ptx\n"); exit (0); - -#endif - -#if defined (vax) -# if !defined (ultrix) -# include -# if defined (BSD) -# if BSD == 43 - printf ("vax-dec-bsd4.3\n"); exit (0); -# else -# if BSD == 199006 - printf ("vax-dec-bsd4.3reno\n"); exit (0); -# else - printf ("vax-dec-bsd\n"); exit (0); -# endif -# endif -# else - printf ("vax-dec-bsd\n"); exit (0); -# endif -# else - printf ("vax-dec-ultrix\n"); exit (0); -# endif -#endif - -#if defined (alliant) && defined (i860) - printf ("i860-alliant-bsd\n"); exit (0); -#endif - - exit (1); -} -EOF - -$CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null && SYSTEM_NAME=`$dummy` && - { echo "$SYSTEM_NAME"; exit; } - -# Apollos put the system type in the environment. - -test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit; } - -# Convex versions that predate uname can use getsysinfo(1) - -if [ -x /usr/convex/getsysinfo ] -then - case `getsysinfo -f cpu_type` in - c1*) - echo c1-convex-bsd + amd64:Isilon\ OneFS:*:*) + echo x86_64-${VENDOR}-onefs exit ;; - c2*) - if getsysinfo -f scalar_acc - then echo c32-convex-bsd - else echo c2-convex-bsd - fi - exit ;; - c34*) - echo c34-convex-bsd - exit ;; - c38*) - echo c38-convex-bsd - exit ;; - c4*) - echo c4-convex-bsd - exit ;; - esac -fi +esac cat >&2 < in order to provide the needed -information to handle your system. +If $0 has already been updated, send the following data and any +information you think might be pertinent to config-patches@gnu.org to +provide the necessary information to handle your system. config.guess timestamp = $timestamp diff --git a/build-aux/config.sub b/build-aux/config.sub index 8b612ab..0399c1a 100755 --- a/build-aux/config.sub +++ b/build-aux/config.sub @@ -1,8 +1,8 @@ #! /bin/sh # Configuration validation subroutine script. -# Copyright 1992-2013 Free Software Foundation, Inc. +# Copyright 1992-2017 Free Software Foundation, Inc. -timestamp='2013-04-24' +timestamp='2017-04-02' # This file is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by @@ -25,7 +25,7 @@ timestamp='2013-04-24' # of the GNU General Public License, version 3 ("GPLv3"). -# Please send patches with a ChangeLog entry to config-patches@gnu.org. +# Please send patches to . # # Configuration subroutine to validate and canonicalize a configuration type. # Supply the specified configuration type as an argument. @@ -33,7 +33,7 @@ timestamp='2013-04-24' # Otherwise, we print the canonical config type on stdout and succeed. # You can get the latest version of this script from: -# http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub;hb=HEAD +# http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub # This file is supposed to be the same for all GNU packages # and recognize all the CPU types, system types and aliases @@ -53,8 +53,7 @@ timestamp='2013-04-24' me=`echo "$0" | sed -e 's,.*/,,'` usage="\ -Usage: $0 [OPTION] CPU-MFR-OPSYS - $0 [OPTION] ALIAS +Usage: $0 [OPTION] CPU-MFR-OPSYS or ALIAS Canonicalize a configuration name. @@ -68,7 +67,7 @@ Report bugs and patches to ." version="\ GNU config.sub ($timestamp) -Copyright 1992-2013 Free Software Foundation, Inc. +Copyright 1992-2017 Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." @@ -117,8 +116,8 @@ maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'` case $maybe_os in nto-qnx* | linux-gnu* | linux-android* | linux-dietlibc | linux-newlib* | \ linux-musl* | linux-uclibc* | uclinux-uclibc* | uclinux-gnu* | kfreebsd*-gnu* | \ - knetbsd*-gnu* | netbsd*-gnu* | \ - kopensolaris*-gnu* | \ + knetbsd*-gnu* | netbsd*-gnu* | netbsd*-eabi* | \ + kopensolaris*-gnu* | cloudabi*-eabi* | \ storm-chaos* | os2-emx* | rtmk-nova*) os=-$maybe_os basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` @@ -255,16 +254,18 @@ case $basic_machine in | arc | arceb \ | arm | arm[bl]e | arme[lb] | armv[2-8] | armv[3-8][lb] | armv7[arm] \ | avr | avr32 \ + | ba \ | be32 | be64 \ | bfin \ - | c4x | clipper \ + | c4x | c8051 | clipper \ | d10v | d30v | dlx | dsp16xx \ - | epiphany \ - | fido | fr30 | frv \ + | e2k | epiphany \ + | fido | fr30 | frv | ft32 \ | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \ | hexagon \ - | i370 | i860 | i960 | ia64 \ + | i370 | i860 | i960 | ia16 | ia64 \ | ip2k | iq2000 \ + | k1om \ | le32 | le64 \ | lm32 \ | m32c | m32r | m32rle | m68000 | m68k | m88k \ @@ -282,8 +283,10 @@ case $basic_machine in | mips64vr5900 | mips64vr5900el \ | mipsisa32 | mipsisa32el \ | mipsisa32r2 | mipsisa32r2el \ + | mipsisa32r6 | mipsisa32r6el \ | mipsisa64 | mipsisa64el \ | mipsisa64r2 | mipsisa64r2el \ + | mipsisa64r6 | mipsisa64r6el \ | mipsisa64sb1 | mipsisa64sb1el \ | mipsisa64sr71k | mipsisa64sr71kel \ | mipsr5900 | mipsr5900el \ @@ -295,14 +298,15 @@ case $basic_machine in | nds32 | nds32le | nds32be \ | nios | nios2 | nios2eb | nios2el \ | ns16k | ns32k \ - | open8 \ - | or1k | or32 \ + | open8 | or1k | or1knd | or32 \ | pdp10 | pdp11 | pj | pjl \ | powerpc | powerpc64 | powerpc64le | powerpcle \ + | pru \ | pyramid \ + | riscv32 | riscv64 \ | rl78 | rx \ | score \ - | sh | sh[1234] | sh[24]a | sh[24]aeb | sh[23]e | sh[34]eb | sheb | shbe | shle | sh[1234]le | sh3ele \ + | sh | sh[1234] | sh[24]a | sh[24]aeb | sh[23]e | sh[234]eb | sheb | shbe | shle | sh[1234]le | sh3ele \ | sh64 | sh64le \ | sparc | sparc64 | sparc64b | sparc64v | sparc86x | sparclet | sparclite \ | sparcv8 | sparcv9 | sparcv9b | sparcv9v \ @@ -310,6 +314,8 @@ case $basic_machine in | tahoe | tic4x | tic54x | tic55x | tic6x | tic80 | tron \ | ubicom32 \ | v850 | v850e | v850e1 | v850e2 | v850es | v850e2v3 \ + | visium \ + | wasm32 \ | we32k \ | x86 | xc16x | xstormy16 | xtensa \ | z8k | z80) @@ -324,7 +330,10 @@ case $basic_machine in c6x) basic_machine=tic6x-unknown ;; - m6811 | m68hc11 | m6812 | m68hc12 | m68hcs12x | picochip) + leon|leon[3-9]) + basic_machine=sparc-$basic_machine + ;; + m6811 | m68hc11 | m6812 | m68hc12 | m68hcs12x | nvptx | picochip) basic_machine=$basic_machine-unknown os=-none ;; @@ -369,18 +378,20 @@ case $basic_machine in | alphapca5[67]-* | alpha64pca5[67]-* | arc-* | arceb-* \ | arm-* | armbe-* | armle-* | armeb-* | armv*-* \ | avr-* | avr32-* \ + | ba-* \ | be32-* | be64-* \ | bfin-* | bs2000-* \ | c[123]* | c30-* | [cjt]90-* | c4x-* \ - | clipper-* | craynv-* | cydra-* \ + | c8051-* | clipper-* | craynv-* | cydra-* \ | d10v-* | d30v-* | dlx-* \ - | elxsi-* \ + | e2k-* | elxsi-* \ | f30[01]-* | f700-* | fido-* | fr30-* | frv-* | fx80-* \ | h8300-* | h8500-* \ | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \ | hexagon-* \ - | i*86-* | i860-* | i960-* | ia64-* \ + | i*86-* | i860-* | i960-* | ia16-* | ia64-* \ | ip2k-* | iq2000-* \ + | k1om-* \ | le32-* | le64-* \ | lm32-* \ | m32c-* | m32r-* | m32rle-* \ @@ -400,8 +411,10 @@ case $basic_machine in | mips64vr5900-* | mips64vr5900el-* \ | mipsisa32-* | mipsisa32el-* \ | mipsisa32r2-* | mipsisa32r2el-* \ + | mipsisa32r6-* | mipsisa32r6el-* \ | mipsisa64-* | mipsisa64el-* \ | mipsisa64r2-* | mipsisa64r2el-* \ + | mipsisa64r6-* | mipsisa64r6el-* \ | mipsisa64sb1-* | mipsisa64sb1el-* \ | mipsisa64sr71k-* | mipsisa64sr71kel-* \ | mipsr5900-* | mipsr5900el-* \ @@ -413,16 +426,19 @@ case $basic_machine in | nios-* | nios2-* | nios2eb-* | nios2el-* \ | none-* | np1-* | ns16k-* | ns32k-* \ | open8-* \ + | or1k*-* \ | orion-* \ | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \ | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* \ + | pru-* \ | pyramid-* \ + | riscv32-* | riscv64-* \ | rl78-* | romp-* | rs6000-* | rx-* \ | sh-* | sh[1234]-* | sh[24]a-* | sh[24]aeb-* | sh[23]e-* | sh[34]eb-* | sheb-* | shbe-* \ | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \ | sparc-* | sparc64-* | sparc64b-* | sparc64v-* | sparc86x-* | sparclet-* \ | sparclite-* \ - | sparcv8-* | sparcv9-* | sparcv9b-* | sparcv9v-* | sv1-* | sx?-* \ + | sparcv8-* | sparcv9-* | sparcv9b-* | sparcv9v-* | sv1-* | sx*-* \ | tahoe-* \ | tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* \ | tile*-* \ @@ -430,6 +446,8 @@ case $basic_machine in | ubicom32-* \ | v850-* | v850e-* | v850e1-* | v850es-* | v850e2-* | v850e2v3-* \ | vax-* \ + | visium-* \ + | wasm32-* \ | we32k-* \ | x86-* | x86_64-* | xc16x-* | xps100-* \ | xstormy16-* | xtensa*-* \ @@ -506,6 +524,9 @@ case $basic_machine in basic_machine=i386-pc os=-aros ;; + asmjs) + basic_machine=asmjs-unknown + ;; aux) basic_machine=m68k-apple os=-aux @@ -626,6 +647,14 @@ case $basic_machine in basic_machine=m68k-bull os=-sysv3 ;; + e500v[12]) + basic_machine=powerpc-unknown + os=$os"spe" + ;; + e500v[12]-*) + basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'` + os=$os"spe" + ;; ebmon29k) basic_machine=a29k-amd os=-ebmon @@ -767,6 +796,9 @@ case $basic_machine in basic_machine=m68k-isi os=-sysv ;; + leon-*|leon[3-9]-*) + basic_machine=sparc-`echo $basic_machine | sed 's/-.*//'` + ;; m68knommu) basic_machine=m68k-unknown os=-linux @@ -794,7 +826,7 @@ case $basic_machine in os=-mingw64 ;; mingw32) - basic_machine=i386-pc + basic_machine=i686-pc os=-mingw32 ;; mingw32ce) @@ -822,6 +854,10 @@ case $basic_machine in basic_machine=powerpc-unknown os=-morphos ;; + moxiebox) + basic_machine=moxie-unknown + os=-moxiebox + ;; msdos) basic_machine=i386-pc os=-msdos @@ -830,7 +866,7 @@ case $basic_machine in basic_machine=`echo $basic_machine | sed -e 's/ms1-/mt-/'` ;; msys) - basic_machine=i386-pc + basic_machine=i686-pc os=-msys ;; mvs) @@ -914,6 +950,9 @@ case $basic_machine in nsr-tandem) basic_machine=nsr-tandem ;; + nsx-tandem) + basic_machine=nsx-tandem + ;; op50n-* | op60c-*) basic_machine=hppa1.1-oki os=-proelf @@ -998,7 +1037,7 @@ case $basic_machine in ppc-* | ppcbe-*) basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'` ;; - ppcle | powerpclittle | ppc-le | powerpc-little) + ppcle | powerpclittle) basic_machine=powerpcle-unknown ;; ppcle-* | powerpclittle-*) @@ -1008,7 +1047,7 @@ case $basic_machine in ;; ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'` ;; - ppc64le | powerpc64little | ppc64-le | powerpc64-little) + ppc64le | powerpc64little) basic_machine=powerpc64le-unknown ;; ppc64le-* | powerpc64little-*) @@ -1039,12 +1078,18 @@ case $basic_machine in rtpc | rtpc-*) basic_machine=romp-ibm ;; - s390 | s390-*) + s390) basic_machine=s390-ibm ;; - s390x | s390x-*) + s390-*) + basic_machine=s390-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + s390x) basic_machine=s390x-ibm ;; + s390x-*) + basic_machine=s390x-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; sa29200) basic_machine=a29k-amd os=-udi @@ -1209,6 +1254,9 @@ case $basic_machine in basic_machine=a29k-wrs os=-vxworks ;; + wasm32) + basic_machine=wasm32-unknown + ;; w65*) basic_machine=w65-wdc os=-none @@ -1354,27 +1402,28 @@ case $os in | -hpux* | -unos* | -osf* | -luna* | -dgux* | -auroraux* | -solaris* \ | -sym* | -kopensolaris* | -plan9* \ | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \ - | -aos* | -aros* \ + | -aos* | -aros* | -cloudabi* | -sortix* \ | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ | -hiux* | -386bsd* | -knetbsd* | -mirbsd* | -netbsd* \ - | -bitrig* | -openbsd* | -solidbsd* \ + | -bitrig* | -openbsd* | -solidbsd* | -libertybsd* \ | -ekkobsd* | -kfreebsd* | -freebsd* | -riscix* | -lynxos* \ | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \ | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ - | -chorusos* | -chorusrdb* | -cegcc* \ + | -chorusos* | -chorusrdb* | -cegcc* | -glidix* \ | -cygwin* | -msys* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ - | -mingw32* | -mingw64* | -linux-gnu* | -linux-android* \ + | -midipix* | -mingw32* | -mingw64* | -linux-gnu* | -linux-android* \ | -linux-newlib* | -linux-musl* | -linux-uclibc* \ - | -uxpv* | -beos* | -mpeix* | -udk* \ + | -uxpv* | -beos* | -mpeix* | -udk* | -moxiebox* \ | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \ | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \ | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \ | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \ | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \ | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly* \ - | -skyos* | -haiku* | -rdos* | -toppers* | -drops* | -es*) + | -skyos* | -haiku* | -rdos* | -toppers* | -drops* | -es* \ + | -onefs* | -tirtos* | -phoenix* | -fuchsia* | -redox*) # Remember, each alternative MUST END IN *, to match a version number. ;; -qnx*) @@ -1506,6 +1555,8 @@ case $os in ;; -nacl*) ;; + -ios) + ;; -none) ;; *) @@ -1546,6 +1597,9 @@ case $basic_machine in c4x-* | tic4x-*) os=-coff ;; + c8051-*) + os=-elf + ;; hexagon-*) os=-elf ;; @@ -1589,9 +1643,6 @@ case $basic_machine in mips*-*) os=-elf ;; - or1k-*) - os=-elf - ;; or32-*) os=-coff ;; @@ -1601,6 +1652,9 @@ case $basic_machine in sparc-* | *-sun) os=-sunos4.1.1 ;; + pru-*) + os=-elf + ;; *-be) os=-beos ;; diff --git a/build-aux/install-sh b/build-aux/install-sh index 377bb86..0360b79 100755 --- a/build-aux/install-sh +++ b/build-aux/install-sh @@ -1,7 +1,7 @@ #!/bin/sh # install - install a program, script, or datafile -scriptversion=2011-11-20.07; # UTC +scriptversion=2016-01-11.22; # UTC # This originates from X11R5 (mit/util/scripts/install.sh), which was # later released in X11R6 (xc/config/util/install.sh) with the @@ -41,19 +41,15 @@ scriptversion=2011-11-20.07; # UTC # This script is compatible with the BSD install script, but was written # from scratch. +tab=' ' nl=' ' -IFS=" "" $nl" +IFS=" $tab$nl" -# set DOITPROG to echo to test this script +# Set DOITPROG to "echo" to test this script. -# Don't use :- since 4.3BSD and earlier shells don't like it. doit=${DOITPROG-} -if test -z "$doit"; then - doit_exec=exec -else - doit_exec=$doit -fi +doit_exec=${doit:-exec} # Put in absolute file names if you don't have them in your path; # or use environment vars. @@ -68,17 +64,6 @@ mvprog=${MVPROG-mv} rmprog=${RMPROG-rm} stripprog=${STRIPPROG-strip} -posix_glob='?' -initialize_posix_glob=' - test "$posix_glob" != "?" || { - if (set -f) 2>/dev/null; then - posix_glob= - else - posix_glob=: - fi - } -' - posix_mkdir= # Desired mode of installed file. @@ -97,7 +82,7 @@ dir_arg= dst_arg= copy_on_change=false -no_target_directory= +is_target_a_directory=possibly usage="\ Usage: $0 [OPTION]... [-T] SRCFILE DSTFILE @@ -137,46 +122,57 @@ while test $# -ne 0; do -d) dir_arg=true;; -g) chgrpcmd="$chgrpprog $2" - shift;; + shift;; --help) echo "$usage"; exit $?;; -m) mode=$2 - case $mode in - *' '* | *' '* | *' -'* | *'*'* | *'?'* | *'['*) - echo "$0: invalid mode: $mode" >&2 - exit 1;; - esac - shift;; + case $mode in + *' '* | *"$tab"* | *"$nl"* | *'*'* | *'?'* | *'['*) + echo "$0: invalid mode: $mode" >&2 + exit 1;; + esac + shift;; -o) chowncmd="$chownprog $2" - shift;; + shift;; -s) stripcmd=$stripprog;; - -t) dst_arg=$2 - # Protect names problematic for 'test' and other utilities. - case $dst_arg in - -* | [=\(\)!]) dst_arg=./$dst_arg;; - esac - shift;; + -t) + is_target_a_directory=always + dst_arg=$2 + # Protect names problematic for 'test' and other utilities. + case $dst_arg in + -* | [=\(\)!]) dst_arg=./$dst_arg;; + esac + shift;; - -T) no_target_directory=true;; + -T) is_target_a_directory=never;; --version) echo "$0 $scriptversion"; exit $?;; - --) shift - break;; + --) shift + break;; - -*) echo "$0: invalid option: $1" >&2 - exit 1;; + -*) echo "$0: invalid option: $1" >&2 + exit 1;; *) break;; esac shift done +# We allow the use of options -d and -T together, by making -d +# take the precedence; this is for compatibility with GNU install. + +if test -n "$dir_arg"; then + if test -n "$dst_arg"; then + echo "$0: target directory not allowed when installing a directory." >&2 + exit 1 + fi +fi + if test $# -ne 0 && test -z "$dir_arg$dst_arg"; then # When -d is used, all remaining arguments are directories to create. # When -t is used, the destination is already specified. @@ -207,6 +203,15 @@ if test $# -eq 0; then exit 0 fi +if test -z "$dir_arg"; then + if test $# -gt 1 || test "$is_target_a_directory" = always; then + if test ! -d "$dst_arg"; then + echo "$0: $dst_arg: Is not a directory." >&2 + exit 1 + fi + fi +fi + if test -z "$dir_arg"; then do_exit='(exit $ret); exit $ret' trap "ret=129; $do_exit" 1 @@ -223,16 +228,16 @@ if test -z "$dir_arg"; then *[0-7]) if test -z "$stripcmd"; then - u_plus_rw= + u_plus_rw= else - u_plus_rw='% 200' + u_plus_rw='% 200' fi cp_umask=`expr '(' 777 - $mode % 1000 ')' $u_plus_rw`;; *) if test -z "$stripcmd"; then - u_plus_rw= + u_plus_rw= else - u_plus_rw=,u+rw + u_plus_rw=,u+rw fi cp_umask=$mode$u_plus_rw;; esac @@ -269,41 +274,15 @@ do # If destination is a directory, append the input filename; won't work # if double slashes aren't ignored. if test -d "$dst"; then - if test -n "$no_target_directory"; then - echo "$0: $dst_arg: Is a directory" >&2 - exit 1 + if test "$is_target_a_directory" = never; then + echo "$0: $dst_arg: Is a directory" >&2 + exit 1 fi dstdir=$dst dst=$dstdir/`basename "$src"` dstdir_status=0 else - # Prefer dirname, but fall back on a substitute if dirname fails. - dstdir=` - (dirname "$dst") 2>/dev/null || - expr X"$dst" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$dst" : 'X\(//\)[^/]' \| \ - X"$dst" : 'X\(//\)$' \| \ - X"$dst" : 'X\(/\)' \| . 2>/dev/null || - echo X"$dst" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q' - ` - + dstdir=`dirname "$dst"` test -d "$dstdir" dstdir_status=$? fi @@ -314,74 +293,74 @@ do if test $dstdir_status != 0; then case $posix_mkdir in '') - # Create intermediate dirs using mode 755 as modified by the umask. - # This is like FreeBSD 'install' as of 1997-10-28. - umask=`umask` - case $stripcmd.$umask in - # Optimize common cases. - *[2367][2367]) mkdir_umask=$umask;; - .*0[02][02] | .[02][02] | .[02]) mkdir_umask=22;; - - *[0-7]) - mkdir_umask=`expr $umask + 22 \ - - $umask % 100 % 40 + $umask % 20 \ - - $umask % 10 % 4 + $umask % 2 - `;; - *) mkdir_umask=$umask,go-w;; - esac - - # With -d, create the new directory with the user-specified mode. - # Otherwise, rely on $mkdir_umask. - if test -n "$dir_arg"; then - mkdir_mode=-m$mode - else - mkdir_mode= - fi - - posix_mkdir=false - case $umask in - *[123567][0-7][0-7]) - # POSIX mkdir -p sets u+wx bits regardless of umask, which - # is incompatible with FreeBSD 'install' when (umask & 300) != 0. - ;; - *) - tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$ - trap 'ret=$?; rmdir "$tmpdir/d" "$tmpdir" 2>/dev/null; exit $ret' 0 - - if (umask $mkdir_umask && - exec $mkdirprog $mkdir_mode -p -- "$tmpdir/d") >/dev/null 2>&1 - then - if test -z "$dir_arg" || { - # Check for POSIX incompatibilities with -m. - # HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or - # other-writable bit of parent directory when it shouldn't. - # FreeBSD 6.1 mkdir -m -p sets mode of existing directory. - ls_ld_tmpdir=`ls -ld "$tmpdir"` - case $ls_ld_tmpdir in - d????-?r-*) different_mode=700;; - d????-?--*) different_mode=755;; - *) false;; - esac && - $mkdirprog -m$different_mode -p -- "$tmpdir" && { - ls_ld_tmpdir_1=`ls -ld "$tmpdir"` - test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1" - } - } - then posix_mkdir=: - fi - rmdir "$tmpdir/d" "$tmpdir" - else - # Remove any dirs left behind by ancient mkdir implementations. - rmdir ./$mkdir_mode ./-p ./-- 2>/dev/null - fi - trap '' 0;; - esac;; + # Create intermediate dirs using mode 755 as modified by the umask. + # This is like FreeBSD 'install' as of 1997-10-28. + umask=`umask` + case $stripcmd.$umask in + # Optimize common cases. + *[2367][2367]) mkdir_umask=$umask;; + .*0[02][02] | .[02][02] | .[02]) mkdir_umask=22;; + + *[0-7]) + mkdir_umask=`expr $umask + 22 \ + - $umask % 100 % 40 + $umask % 20 \ + - $umask % 10 % 4 + $umask % 2 + `;; + *) mkdir_umask=$umask,go-w;; + esac + + # With -d, create the new directory with the user-specified mode. + # Otherwise, rely on $mkdir_umask. + if test -n "$dir_arg"; then + mkdir_mode=-m$mode + else + mkdir_mode= + fi + + posix_mkdir=false + case $umask in + *[123567][0-7][0-7]) + # POSIX mkdir -p sets u+wx bits regardless of umask, which + # is incompatible with FreeBSD 'install' when (umask & 300) != 0. + ;; + *) + tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$ + trap 'ret=$?; rmdir "$tmpdir/d" "$tmpdir" 2>/dev/null; exit $ret' 0 + + if (umask $mkdir_umask && + exec $mkdirprog $mkdir_mode -p -- "$tmpdir/d") >/dev/null 2>&1 + then + if test -z "$dir_arg" || { + # Check for POSIX incompatibilities with -m. + # HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or + # other-writable bit of parent directory when it shouldn't. + # FreeBSD 6.1 mkdir -m -p sets mode of existing directory. + ls_ld_tmpdir=`ls -ld "$tmpdir"` + case $ls_ld_tmpdir in + d????-?r-*) different_mode=700;; + d????-?--*) different_mode=755;; + *) false;; + esac && + $mkdirprog -m$different_mode -p -- "$tmpdir" && { + ls_ld_tmpdir_1=`ls -ld "$tmpdir"` + test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1" + } + } + then posix_mkdir=: + fi + rmdir "$tmpdir/d" "$tmpdir" + else + # Remove any dirs left behind by ancient mkdir implementations. + rmdir ./$mkdir_mode ./-p ./-- 2>/dev/null + fi + trap '' 0;; + esac;; esac if $posix_mkdir && ( - umask $mkdir_umask && - $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir" + umask $mkdir_umask && + $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir" ) then : else @@ -391,53 +370,51 @@ do # directory the slow way, step by step, checking for races as we go. case $dstdir in - /*) prefix='/';; - [-=\(\)!]*) prefix='./';; - *) prefix='';; + /*) prefix='/';; + [-=\(\)!]*) prefix='./';; + *) prefix='';; esac - eval "$initialize_posix_glob" - oIFS=$IFS IFS=/ - $posix_glob set -f + set -f set fnord $dstdir shift - $posix_glob set +f + set +f IFS=$oIFS prefixes= for d do - test X"$d" = X && continue - - prefix=$prefix$d - if test -d "$prefix"; then - prefixes= - else - if $posix_mkdir; then - (umask=$mkdir_umask && - $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break - # Don't fail if two instances are running concurrently. - test -d "$prefix" || exit 1 - else - case $prefix in - *\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;; - *) qprefix=$prefix;; - esac - prefixes="$prefixes '$qprefix'" - fi - fi - prefix=$prefix/ + test X"$d" = X && continue + + prefix=$prefix$d + if test -d "$prefix"; then + prefixes= + else + if $posix_mkdir; then + (umask=$mkdir_umask && + $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break + # Don't fail if two instances are running concurrently. + test -d "$prefix" || exit 1 + else + case $prefix in + *\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;; + *) qprefix=$prefix;; + esac + prefixes="$prefixes '$qprefix'" + fi + fi + prefix=$prefix/ done if test -n "$prefixes"; then - # Don't fail if two instances are running concurrently. - (umask $mkdir_umask && - eval "\$doit_exec \$mkdirprog $prefixes") || - test -d "$dstdir" || exit 1 - obsolete_mkdir_used=true + # Don't fail if two instances are running concurrently. + (umask $mkdir_umask && + eval "\$doit_exec \$mkdirprog $prefixes") || + test -d "$dstdir" || exit 1 + obsolete_mkdir_used=true fi fi fi @@ -472,15 +449,12 @@ do # If -C, don't bother to copy if it wouldn't change the file. if $copy_on_change && - old=`LC_ALL=C ls -dlL "$dst" 2>/dev/null` && - new=`LC_ALL=C ls -dlL "$dsttmp" 2>/dev/null` && - - eval "$initialize_posix_glob" && - $posix_glob set -f && + old=`LC_ALL=C ls -dlL "$dst" 2>/dev/null` && + new=`LC_ALL=C ls -dlL "$dsttmp" 2>/dev/null` && + set -f && set X $old && old=:$2:$4:$5:$6 && set X $new && new=:$2:$4:$5:$6 && - $posix_glob set +f && - + set +f && test "$old" = "$new" && $cmpprog "$dst" "$dsttmp" >/dev/null 2>&1 then @@ -493,24 +467,24 @@ do # to itself, or perhaps because mv is so ancient that it does not # support -f. { - # Now remove or move aside any old file at destination location. - # We try this two ways since rm can't unlink itself on some - # systems and the destination file might be busy for other - # reasons. In this case, the final cleanup might fail but the new - # file should still install successfully. - { - test ! -f "$dst" || - $doit $rmcmd -f "$dst" 2>/dev/null || - { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null && - { $doit $rmcmd -f "$rmtmp" 2>/dev/null; :; } - } || - { echo "$0: cannot unlink or rename $dst" >&2 - (exit 1); exit 1 - } - } && - - # Now rename the file to the real destination. - $doit $mvcmd "$dsttmp" "$dst" + # Now remove or move aside any old file at destination location. + # We try this two ways since rm can't unlink itself on some + # systems and the destination file might be busy for other + # reasons. In this case, the final cleanup might fail but the new + # file should still install successfully. + { + test ! -f "$dst" || + $doit $rmcmd -f "$dst" 2>/dev/null || + { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null && + { $doit $rmcmd -f "$rmtmp" 2>/dev/null; :; } + } || + { echo "$0: cannot unlink or rename $dst" >&2 + (exit 1); exit 1 + } + } && + + # Now rename the file to the real destination. + $doit $mvcmd "$dsttmp" "$dst" } fi || exit 1 @@ -522,6 +496,6 @@ done # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" -# time-stamp-time-zone: "UTC" +# time-stamp-time-zone: "UTC0" # time-stamp-end: "; # UTC" # End: diff --git a/build-aux/missing b/build-aux/missing index cdea514..c6e3795 100755 --- a/build-aux/missing +++ b/build-aux/missing @@ -1,9 +1,9 @@ #! /bin/sh # Common wrapper for a few potentially missing GNU programs. -scriptversion=2012-06-26.16; # UTC +scriptversion=2016-01-11.22; # UTC -# Copyright (C) 1996-2013 Free Software Foundation, Inc. +# Copyright (C) 1996-2017 Free Software Foundation, Inc. # Originally written by Fran,cois Pinard , 1996. # This program is free software; you can redistribute it and/or modify @@ -160,7 +160,7 @@ give_advice () ;; autom4te*) echo "You might have modified some maintainer files that require" - echo "the 'automa4te' program to be rebuilt." + echo "the 'autom4te' program to be rebuilt." program_details 'autom4te' ;; bison*|yacc*) @@ -210,6 +210,6 @@ exit $st # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" -# time-stamp-time-zone: "UTC" +# time-stamp-time-zone: "UTC0" # time-stamp-end: "; # UTC" # End: diff --git a/configure b/configure index 65c350d..59b8e58 100755 --- a/configure +++ b/configure @@ -2336,7 +2336,7 @@ ac_configure="$SHELL $ac_aux_dir/configure" # Please don't use this var. -am__api_version='1.13' +am__api_version='1.15' # Find a good install program. We prefer a C program (faster), # so one script is as good as another. But avoid the broken or @@ -2528,7 +2528,7 @@ else $as_echo "$as_me: WARNING: 'missing' script is too old or missing" >&2;} fi -if test x"${install_sh}" != xset; then +if test x"${install_sh+set}" != xset; then case $am_aux_dir in *\ * | *\ *) install_sh="\${SHELL} '$am_aux_dir/install-sh'" ;; @@ -2856,8 +2856,8 @@ MAKEINFO=${MAKEINFO-"${am_missing_run}makeinfo"} # mkdir_p='$(MKDIR_P)' -# We need awk for the "check" target. The system "awk" is bad on -# some platforms. +# We need awk for the "check" target (and possibly the TAP driver). The +# system "awk" is bad on some platforms. # Always define AMTAR for backward compatibility. Yes, it's still used # in the wild :-( We should find a proper way to deprecate it ... AMTAR='$${TAR-tar}' @@ -2873,6 +2873,48 @@ am__tar='$${TAR-tar} chof - "$$tardir"' am__untar='$${TAR-tar} xf -' +# POSIX will say in a future version that running "rm -f" with no argument +# is OK; and we want to be able to make that assumption in our Makefile +# recipes. So use an aggressive probe to check that the usage we want is +# actually supported "in the wild" to an acceptable degree. +# See automake bug#10828. +# To make any issue more visible, cause the running configure to be aborted +# by default if the 'rm' program in use doesn't match our expectations; the +# user can still override this though. +if rm -f && rm -fr && rm -rf; then : OK; else + cat >&2 <<'END' +Oops! + +Your 'rm' program seems unable to run without file operands specified +on the command line, even when the '-f' option is present. This is contrary +to the behaviour of most rm programs out there, and not conforming with +the upcoming POSIX standard: + +Please tell bug-automake@gnu.org about your system, including the value +of your $PATH and any error possibly output before this message. This +can help us improve future automake versions. + +END + if test x"$ACCEPT_INFERIOR_RM_PROGRAM" = x"yes"; then + echo 'Configuration will proceed anyway, since you have set the' >&2 + echo 'ACCEPT_INFERIOR_RM_PROGRAM variable to "yes"' >&2 + echo >&2 + else + cat >&2 <<'END' +Aborting the configuration process, to ensure you take notice of the issue. + +You can download and install GNU coreutils to get an 'rm' implementation +that behaves properly: . + +If you want to complete the configuration process using your problematic +'rm' anyway, export the environment variable ACCEPT_INFERIOR_RM_PROGRAM +to "yes", and re-run configure. + +END + as_fn_error $? "Your 'rm' program is bad, sorry." "$LINENO" 5 + fi +fi + { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to enable maintainer-specific portions of Makefiles" >&5 $as_echo_n "checking whether to enable maintainer-specific portions of Makefiles... " >&6; } @@ -3887,6 +3929,65 @@ ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC understands -c and -o together" >&5 +$as_echo_n "checking whether $CC understands -c and -o together... " >&6; } +if ${am_cv_prog_cc_c_o+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF + # Make sure it works both with $CC and with simple cc. + # Following AC_PROG_CC_C_O, we do the test twice because some + # compilers refuse to overwrite an existing .o file with -o, + # though they will create one. + am_cv_prog_cc_c_o=yes + for am_i in 1 2; do + if { echo "$as_me:$LINENO: $CC -c conftest.$ac_ext -o conftest2.$ac_objext" >&5 + ($CC -c conftest.$ac_ext -o conftest2.$ac_objext) >&5 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } \ + && test -f conftest2.$ac_objext; then + : OK + else + am_cv_prog_cc_c_o=no + break + fi + done + rm -f core conftest* + unset am_i +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $am_cv_prog_cc_c_o" >&5 +$as_echo "$am_cv_prog_cc_c_o" >&6; } +if test "$am_cv_prog_cc_c_o" != yes; then + # Losing compiler, so override with the script. + # FIXME: It is wrong to rewrite CC. + # But if we don't then we get into trouble of one sort or another. + # A longer-term fix would be to have automake use am__CC in this case, + # and then we could set am__CC="\$(top_srcdir)/compile \$(CC)" + CC="$am_aux_dir/compile $CC" +fi +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + depcc="$CC" am_compiler_list= { $as_echo "$as_me:${as_lineno-$LINENO}: checking dependency style of $depcc" >&5 @@ -4875,7 +4976,7 @@ esac ESMF_FC=`$GREP ESMF_${ax_lib_esmf_compiler}COMPILER $ax_lib_esmf_mk | $SED 's/.*=//'` ESMF_FCFLAGS=`$GREP ESMF_${ax_lib_esmf_compiler}COMPILEPATHS $ax_lib_esmf_mk | $SED 's/.*=//'` - ESMF_LDFLAGS=`$GREP ESMF_${ax_lib_esmf_compiler}LINKPATHS $ax_lib_esmf_mk | $SED 's/.*=//'` + ESMF_LDFLAGS=`$GREP '^ESMF_${ax_lib_esmf_compiler}LINKPATHS' $ax_lib_esmf_mk | $SED 's/.*=//'` ESMF_LIBS=`$GREP ESMF_${ax_lib_esmf_compiler}ESMFLINKLIBS $ax_lib_esmf_mk | $SED 's/.*=//'` ESMF_VERSION=`$GREP ESMF_VERSION_STRING= $ax_lib_esmf_mk | $SED 's/.*=//'` @@ -8928,7 +9029,13 @@ $as_echo_n "checking the archiver ($AR) interface... " >&6; } if ${am_cv_ar_interface+:} false; then : $as_echo_n "(cached) " >&6 else - am_cv_ar_interface=ar + ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + am_cv_ar_interface=ar cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int some_variable = 0; @@ -8959,6 +9066,11 @@ if ac_fn_c_try_compile "$LINENO"; then : fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $am_cv_ar_interface" >&5 diff --git a/m4/ax_lib_esmf.m4 b/m4/ax_lib_esmf.m4 index 9da32a6..a16055e 100644 --- a/m4/ax_lib_esmf.m4 +++ b/m4/ax_lib_esmf.m4 @@ -137,7 +137,7 @@ if test "x$ax_lib_esmf_mk" != x ; then dnl Set output variables for current language ESMF_[]_AC_LANG_PREFIX[]=`$GREP ESMF_${ax_lib_esmf_compiler}COMPILER $ax_lib_esmf_mk | $SED 's/.*=//'` ESMF_[]_AC_LANG_PREFIX[]FLAGS=`$GREP ESMF_${ax_lib_esmf_compiler}COMPILEPATHS $ax_lib_esmf_mk | $SED 's/.*=//'` - ESMF_LDFLAGS=`$GREP ESMF_${ax_lib_esmf_compiler}LINKPATHS $ax_lib_esmf_mk | $SED 's/.*=//'` + ESMF_LDFLAGS=`$GREP '^ESMF_${ax_lib_esmf_compiler}LINKPATHS' $ax_lib_esmf_mk | $SED 's/.*=//'` ESMF_LIBS=`$GREP ESMF_${ax_lib_esmf_compiler}ESMFLINKLIBS $ax_lib_esmf_mk | $SED 's/.*=//'` ESMF_VERSION=`$GREP ESMF_VERSION_STRING= $ax_lib_esmf_mk | $SED 's/.*=//'` diff --git a/src/Makefile.in b/src/Makefile.in index b400637..4f15a3d 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -1,7 +1,7 @@ -# Makefile.in generated by automake 1.13.4 from Makefile.am. +# Makefile.in generated by automake 1.15.1 from Makefile.am. # @configure_input@ -# Copyright (C) 1994-2013 Free Software Foundation, Inc. +# Copyright (C) 1994-2017 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -15,7 +15,17 @@ @SET_MAKE@ VPATH = @srcdir@ -am__is_gnu_make = test -n '$(MAKEFILE_LIST)' && test -n '$(MAKELEVEL)' +am__is_gnu_make = { \ + if test -z '$(MAKELEVEL)'; then \ + false; \ + elif test -n '$(MAKE_HOST)'; then \ + true; \ + elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ + true; \ + else \ + false; \ + fi; \ +} am__make_running_with_option = \ case $${target_option-} in \ ?) ;; \ @@ -79,7 +89,6 @@ POST_UNINSTALL = : build_triplet = @build@ host_triplet = @host@ subdir = src -DIST_COMMON = $(srcdir)/Makefile.in $(srcdir)/Makefile.am ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/m4/ax_blas.m4 \ $(top_srcdir)/m4/ax_check_compile_flags.m4 \ @@ -91,6 +100,7 @@ am__aclocal_m4_deps = $(top_srcdir)/m4/ax_blas.m4 \ $(top_srcdir)/m4/ax_lib_netcdf4.m4 $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) +DIST_COMMON = $(srcdir)/Makefile.am $(am__DIST_COMMON) mkinstalldirs = $(install_sh) -d CONFIG_CLEAN_FILES = CONFIG_CLEAN_VPATH_FILES = @@ -209,6 +219,7 @@ am__define_uniq_tagged_files = \ ETAGS = etags CTAGS = ctags DIST_SUBDIRS = $(SUBDIRS) +am__DIST_COMMON = $(srcdir)/Makefile.in DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) am__relativize = \ dir0=`pwd`; \ @@ -421,7 +432,6 @@ $(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__confi echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu src/Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --gnu src/Makefile -.PRECIOUS: Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ @@ -775,6 +785,8 @@ uninstall-am: uninstall-libLIBRARIES mostlyclean-compile mostlyclean-generic pdf pdf-am ps ps-am \ tags tags-am uninstall uninstall-am uninstall-libLIBRARIES +.PRECIOUS: Makefile + .PHONY: clean-modules diff --git a/src/fim/Makefile.in b/src/fim/Makefile.in index 233a307..f45bddd 100644 --- a/src/fim/Makefile.in +++ b/src/fim/Makefile.in @@ -1,7 +1,7 @@ -# Makefile.in generated by automake 1.13.4 from Makefile.am. +# Makefile.in generated by automake 1.15.1 from Makefile.am. # @configure_input@ -# Copyright (C) 1994-2013 Free Software Foundation, Inc. +# Copyright (C) 1994-2017 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -15,7 +15,17 @@ @SET_MAKE@ VPATH = @srcdir@ -am__is_gnu_make = test -n '$(MAKEFILE_LIST)' && test -n '$(MAKELEVEL)' +am__is_gnu_make = { \ + if test -z '$(MAKELEVEL)'; then \ + false; \ + elif test -n '$(MAKE_HOST)'; then \ + true; \ + elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ + true; \ + else \ + false; \ + fi; \ +} am__make_running_with_option = \ case $${target_option-} in \ ?) ;; \ @@ -79,7 +89,6 @@ POST_UNINSTALL = : build_triplet = @build@ host_triplet = @host@ subdir = src/fim -DIST_COMMON = $(srcdir)/Makefile.in $(srcdir)/Makefile.am ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/m4/ax_blas.m4 \ $(top_srcdir)/m4/ax_check_compile_flags.m4 \ @@ -91,6 +100,7 @@ am__aclocal_m4_deps = $(top_srcdir)/m4/ax_blas.m4 \ $(top_srcdir)/m4/ax_lib_netcdf4.m4 $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) +DIST_COMMON = $(srcdir)/Makefile.am $(am__DIST_COMMON) mkinstalldirs = $(install_sh) -d CONFIG_CLEAN_FILES = CONFIG_CLEAN_VPATH_FILES = @@ -160,6 +170,7 @@ am__define_uniq_tagged_files = \ done | $(am__uniquify_input)` ETAGS = etags CTAGS = ctags +am__DIST_COMMON = $(srcdir)/Makefile.in DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) ACLOCAL = @ACLOCAL@ AMTAR = @AMTAR@ @@ -330,7 +341,6 @@ $(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__confi echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu src/fim/Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --gnu src/fim/Makefile -.PRECIOUS: Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ @@ -574,6 +584,8 @@ uninstall-am: mostlyclean-compile mostlyclean-generic pdf pdf-am ps ps-am \ tags tags-am uninstall uninstall-am +.PRECIOUS: Makefile + .PHONY: clean-modules diff --git a/src/gen/Makefile.in b/src/gen/Makefile.in index 3dd0b1e..bf6e093 100644 --- a/src/gen/Makefile.in +++ b/src/gen/Makefile.in @@ -1,7 +1,7 @@ -# Makefile.in generated by automake 1.13.4 from Makefile.am. +# Makefile.in generated by automake 1.15.1 from Makefile.am. # @configure_input@ -# Copyright (C) 1994-2013 Free Software Foundation, Inc. +# Copyright (C) 1994-2017 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -15,7 +15,17 @@ @SET_MAKE@ VPATH = @srcdir@ -am__is_gnu_make = test -n '$(MAKEFILE_LIST)' && test -n '$(MAKELEVEL)' +am__is_gnu_make = { \ + if test -z '$(MAKELEVEL)'; then \ + false; \ + elif test -n '$(MAKE_HOST)'; then \ + true; \ + elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ + true; \ + else \ + false; \ + fi; \ +} am__make_running_with_option = \ case $${target_option-} in \ ?) ;; \ @@ -79,7 +89,6 @@ POST_UNINSTALL = : build_triplet = @build@ host_triplet = @host@ subdir = src/gen -DIST_COMMON = $(srcdir)/Makefile.in $(srcdir)/Makefile.am ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/m4/ax_blas.m4 \ $(top_srcdir)/m4/ax_check_compile_flags.m4 \ @@ -91,6 +100,7 @@ am__aclocal_m4_deps = $(top_srcdir)/m4/ax_blas.m4 \ $(top_srcdir)/m4/ax_lib_netcdf4.m4 $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) +DIST_COMMON = $(srcdir)/Makefile.am $(am__DIST_COMMON) mkinstalldirs = $(install_sh) -d CONFIG_CLEAN_FILES = CONFIG_CLEAN_VPATH_FILES = @@ -161,6 +171,7 @@ am__define_uniq_tagged_files = \ done | $(am__uniquify_input)` ETAGS = etags CTAGS = ctags +am__DIST_COMMON = $(srcdir)/Makefile.in DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) ACLOCAL = @ACLOCAL@ AMTAR = @AMTAR@ @@ -331,7 +342,6 @@ $(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__confi echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu src/gen/Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --gnu src/gen/Makefile -.PRECIOUS: Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ @@ -581,6 +591,8 @@ uninstall-am: mostlyclean-compile mostlyclean-generic pdf pdf-am ps ps-am \ tags tags-am uninstall uninstall-am +.PRECIOUS: Makefile + .PHONY: clean-modules diff --git a/src/gsm/Makefile.in b/src/gsm/Makefile.in index b45bb5e..ada61f3 100644 --- a/src/gsm/Makefile.in +++ b/src/gsm/Makefile.in @@ -1,7 +1,7 @@ -# Makefile.in generated by automake 1.13.4 from Makefile.am. +# Makefile.in generated by automake 1.15.1 from Makefile.am. # @configure_input@ -# Copyright (C) 1994-2013 Free Software Foundation, Inc. +# Copyright (C) 1994-2017 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -15,7 +15,17 @@ @SET_MAKE@ VPATH = @srcdir@ -am__is_gnu_make = test -n '$(MAKEFILE_LIST)' && test -n '$(MAKELEVEL)' +am__is_gnu_make = { \ + if test -z '$(MAKELEVEL)'; then \ + false; \ + elif test -n '$(MAKE_HOST)'; then \ + true; \ + elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ + true; \ + else \ + false; \ + fi; \ +} am__make_running_with_option = \ case $${target_option-} in \ ?) ;; \ @@ -79,7 +89,6 @@ POST_UNINSTALL = : build_triplet = @build@ host_triplet = @host@ subdir = src/gsm -DIST_COMMON = $(srcdir)/Makefile.in $(srcdir)/Makefile.am ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/m4/ax_blas.m4 \ $(top_srcdir)/m4/ax_check_compile_flags.m4 \ @@ -91,6 +100,7 @@ am__aclocal_m4_deps = $(top_srcdir)/m4/ax_blas.m4 \ $(top_srcdir)/m4/ax_lib_netcdf4.m4 $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) +DIST_COMMON = $(srcdir)/Makefile.am $(am__DIST_COMMON) mkinstalldirs = $(install_sh) -d CONFIG_CLEAN_FILES = CONFIG_CLEAN_VPATH_FILES = @@ -181,6 +191,7 @@ am__define_uniq_tagged_files = \ ETAGS = etags CTAGS = ctags DIST_SUBDIRS = $(SUBDIRS) +am__DIST_COMMON = $(srcdir)/Makefile.in DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) am__relativize = \ dir0=`pwd`; \ @@ -381,7 +392,6 @@ $(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__confi echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu src/gsm/Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --gnu src/gsm/Makefile -.PRECIOUS: Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ @@ -723,6 +733,8 @@ uninstall-am: mostlyclean-generic pdf pdf-am ps ps-am tags tags-am uninstall \ uninstall-am +.PRECIOUS: Makefile + .PHONY: clean-modules diff --git a/src/gsm/dyn/Makefile.in b/src/gsm/dyn/Makefile.in index 2b9319e..1385db6 100644 --- a/src/gsm/dyn/Makefile.in +++ b/src/gsm/dyn/Makefile.in @@ -1,7 +1,7 @@ -# Makefile.in generated by automake 1.13.4 from Makefile.am. +# Makefile.in generated by automake 1.15.1 from Makefile.am. # @configure_input@ -# Copyright (C) 1994-2013 Free Software Foundation, Inc. +# Copyright (C) 1994-2017 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -15,7 +15,17 @@ @SET_MAKE@ VPATH = @srcdir@ -am__is_gnu_make = test -n '$(MAKEFILE_LIST)' && test -n '$(MAKELEVEL)' +am__is_gnu_make = { \ + if test -z '$(MAKELEVEL)'; then \ + false; \ + elif test -n '$(MAKE_HOST)'; then \ + true; \ + elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ + true; \ + else \ + false; \ + fi; \ +} am__make_running_with_option = \ case $${target_option-} in \ ?) ;; \ @@ -79,7 +89,6 @@ POST_UNINSTALL = : build_triplet = @build@ host_triplet = @host@ subdir = src/gsm/dyn -DIST_COMMON = $(srcdir)/Makefile.in $(srcdir)/Makefile.am ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/m4/ax_blas.m4 \ $(top_srcdir)/m4/ax_check_compile_flags.m4 \ @@ -91,6 +100,7 @@ am__aclocal_m4_deps = $(top_srcdir)/m4/ax_blas.m4 \ $(top_srcdir)/m4/ax_lib_netcdf4.m4 $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) +DIST_COMMON = $(srcdir)/Makefile.am $(am__DIST_COMMON) mkinstalldirs = $(install_sh) -d CONFIG_CLEAN_FILES = CONFIG_CLEAN_VPATH_FILES = @@ -327,6 +337,7 @@ am__define_uniq_tagged_files = \ done | $(am__uniquify_input)` ETAGS = etags CTAGS = ctags +am__DIST_COMMON = $(srcdir)/Makefile.in DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) ACLOCAL = @ACLOCAL@ AMTAR = @AMTAR@ @@ -552,7 +563,6 @@ $(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__confi echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu src/gsm/dyn/Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --gnu src/gsm/dyn/Makefile -.PRECIOUS: Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ @@ -2011,6 +2021,8 @@ uninstall-am: mostlyclean-compile mostlyclean-generic pdf pdf-am ps ps-am \ tags tags-am uninstall uninstall-am +.PRECIOUS: Makefile + .PHONY: clean-modules diff --git a/src/gsm/libutil/Makefile.in b/src/gsm/libutil/Makefile.in index 51c1f48..e5cd165 100644 --- a/src/gsm/libutil/Makefile.in +++ b/src/gsm/libutil/Makefile.in @@ -1,7 +1,7 @@ -# Makefile.in generated by automake 1.13.4 from Makefile.am. +# Makefile.in generated by automake 1.15.1 from Makefile.am. # @configure_input@ -# Copyright (C) 1994-2013 Free Software Foundation, Inc. +# Copyright (C) 1994-2017 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -15,7 +15,17 @@ @SET_MAKE@ VPATH = @srcdir@ -am__is_gnu_make = test -n '$(MAKEFILE_LIST)' && test -n '$(MAKELEVEL)' +am__is_gnu_make = { \ + if test -z '$(MAKELEVEL)'; then \ + false; \ + elif test -n '$(MAKE_HOST)'; then \ + true; \ + elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ + true; \ + else \ + false; \ + fi; \ +} am__make_running_with_option = \ case $${target_option-} in \ ?) ;; \ @@ -79,7 +89,6 @@ POST_UNINSTALL = : build_triplet = @build@ host_triplet = @host@ subdir = src/gsm/libutil -DIST_COMMON = $(srcdir)/Makefile.in $(srcdir)/Makefile.am ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/m4/ax_blas.m4 \ $(top_srcdir)/m4/ax_check_compile_flags.m4 \ @@ -91,6 +100,7 @@ am__aclocal_m4_deps = $(top_srcdir)/m4/ax_blas.m4 \ $(top_srcdir)/m4/ax_lib_netcdf4.m4 $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) +DIST_COMMON = $(srcdir)/Makefile.am $(am__DIST_COMMON) mkinstalldirs = $(install_sh) -d CONFIG_CLEAN_FILES = CONFIG_CLEAN_VPATH_FILES = @@ -172,6 +182,7 @@ am__define_uniq_tagged_files = \ done | $(am__uniquify_input)` ETAGS = etags CTAGS = ctags +am__DIST_COMMON = $(srcdir)/Makefile.in DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) ACLOCAL = @ACLOCAL@ AMTAR = @AMTAR@ @@ -347,7 +358,6 @@ $(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__confi echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu src/gsm/libutil/Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --gnu src/gsm/libutil/Makefile -.PRECIOUS: Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ @@ -657,6 +667,8 @@ uninstall-am: mostlyclean-compile mostlyclean-generic pdf pdf-am ps ps-am \ tags tags-am uninstall uninstall-am +.PRECIOUS: Makefile + .PHONY: clean-modules diff --git a/src/gsm/phys/Makefile.in b/src/gsm/phys/Makefile.in index 2ad4f9d..288bc0a 100644 --- a/src/gsm/phys/Makefile.in +++ b/src/gsm/phys/Makefile.in @@ -1,7 +1,7 @@ -# Makefile.in generated by automake 1.13.4 from Makefile.am. +# Makefile.in generated by automake 1.15.1 from Makefile.am. # @configure_input@ -# Copyright (C) 1994-2013 Free Software Foundation, Inc. +# Copyright (C) 1994-2017 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -15,7 +15,17 @@ @SET_MAKE@ VPATH = @srcdir@ -am__is_gnu_make = test -n '$(MAKEFILE_LIST)' && test -n '$(MAKELEVEL)' +am__is_gnu_make = { \ + if test -z '$(MAKELEVEL)'; then \ + false; \ + elif test -n '$(MAKE_HOST)'; then \ + true; \ + elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ + true; \ + else \ + false; \ + fi; \ +} am__make_running_with_option = \ case $${target_option-} in \ ?) ;; \ @@ -79,7 +89,6 @@ POST_UNINSTALL = : build_triplet = @build@ host_triplet = @host@ subdir = src/gsm/phys -DIST_COMMON = $(srcdir)/Makefile.in $(srcdir)/Makefile.am ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/m4/ax_blas.m4 \ $(top_srcdir)/m4/ax_check_compile_flags.m4 \ @@ -91,6 +100,7 @@ am__aclocal_m4_deps = $(top_srcdir)/m4/ax_blas.m4 \ $(top_srcdir)/m4/ax_lib_netcdf4.m4 $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) +DIST_COMMON = $(srcdir)/Makefile.am $(am__DIST_COMMON) mkinstalldirs = $(install_sh) -d CONFIG_CLEAN_FILES = CONFIG_CLEAN_VPATH_FILES = @@ -224,6 +234,7 @@ am__define_uniq_tagged_files = \ done | $(am__uniquify_input)` ETAGS = etags CTAGS = ctags +am__DIST_COMMON = $(srcdir)/Makefile.in DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) ACLOCAL = @ACLOCAL@ AMTAR = @AMTAR@ @@ -417,7 +428,6 @@ $(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__confi echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu src/gsm/phys/Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --gnu src/gsm/phys/Makefile -.PRECIOUS: Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ @@ -1068,6 +1078,8 @@ uninstall-am: mostlyclean-compile mostlyclean-generic pdf pdf-am ps ps-am \ tags tags-am uninstall uninstall-am +.PRECIOUS: Makefile + .PHONY: clean-modules diff --git a/src/io/Makefile.in b/src/io/Makefile.in index bdf27c1..928542b 100644 --- a/src/io/Makefile.in +++ b/src/io/Makefile.in @@ -1,7 +1,7 @@ -# Makefile.in generated by automake 1.13.4 from Makefile.am. +# Makefile.in generated by automake 1.15.1 from Makefile.am. # @configure_input@ -# Copyright (C) 1994-2013 Free Software Foundation, Inc. +# Copyright (C) 1994-2017 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -15,7 +15,17 @@ @SET_MAKE@ VPATH = @srcdir@ -am__is_gnu_make = test -n '$(MAKEFILE_LIST)' && test -n '$(MAKELEVEL)' +am__is_gnu_make = { \ + if test -z '$(MAKELEVEL)'; then \ + false; \ + elif test -n '$(MAKE_HOST)'; then \ + true; \ + elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ + true; \ + else \ + false; \ + fi; \ +} am__make_running_with_option = \ case $${target_option-} in \ ?) ;; \ @@ -79,7 +89,6 @@ POST_UNINSTALL = : build_triplet = @build@ host_triplet = @host@ subdir = src/io -DIST_COMMON = $(srcdir)/Makefile.in $(srcdir)/Makefile.am ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/m4/ax_blas.m4 \ $(top_srcdir)/m4/ax_check_compile_flags.m4 \ @@ -91,6 +100,7 @@ am__aclocal_m4_deps = $(top_srcdir)/m4/ax_blas.m4 \ $(top_srcdir)/m4/ax_lib_netcdf4.m4 $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) +DIST_COMMON = $(srcdir)/Makefile.am $(am__DIST_COMMON) mkinstalldirs = $(install_sh) -d CONFIG_CLEAN_FILES = CONFIG_CLEAN_VPATH_FILES = @@ -166,6 +176,7 @@ am__define_uniq_tagged_files = \ done | $(am__uniquify_input)` ETAGS = etags CTAGS = ctags +am__DIST_COMMON = $(srcdir)/Makefile.in DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) ACLOCAL = @ACLOCAL@ AMTAR = @AMTAR@ @@ -339,7 +350,6 @@ $(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__confi echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu src/io/Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --gnu src/io/Makefile -.PRECIOUS: Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ @@ -619,6 +629,8 @@ uninstall-am: mostlyclean-compile mostlyclean-generic pdf pdf-am ps ps-am \ tags tags-am uninstall uninstall-am +.PRECIOUS: Makefile + .PHONY: clean-modules diff --git a/src/nmm/Makefile.in b/src/nmm/Makefile.in index 503770d..dfa828f 100644 --- a/src/nmm/Makefile.in +++ b/src/nmm/Makefile.in @@ -1,7 +1,7 @@ -# Makefile.in generated by automake 1.13.4 from Makefile.am. +# Makefile.in generated by automake 1.15.1 from Makefile.am. # @configure_input@ -# Copyright (C) 1994-2013 Free Software Foundation, Inc. +# Copyright (C) 1994-2017 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -15,7 +15,17 @@ @SET_MAKE@ VPATH = @srcdir@ -am__is_gnu_make = test -n '$(MAKEFILE_LIST)' && test -n '$(MAKELEVEL)' +am__is_gnu_make = { \ + if test -z '$(MAKELEVEL)'; then \ + false; \ + elif test -n '$(MAKE_HOST)'; then \ + true; \ + elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ + true; \ + else \ + false; \ + fi; \ +} am__make_running_with_option = \ case $${target_option-} in \ ?) ;; \ @@ -79,7 +89,6 @@ POST_UNINSTALL = : build_triplet = @build@ host_triplet = @host@ subdir = src/nmm -DIST_COMMON = $(srcdir)/Makefile.in $(srcdir)/Makefile.am ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/m4/ax_blas.m4 \ $(top_srcdir)/m4/ax_check_compile_flags.m4 \ @@ -91,6 +100,7 @@ am__aclocal_m4_deps = $(top_srcdir)/m4/ax_blas.m4 \ $(top_srcdir)/m4/ax_lib_netcdf4.m4 $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) +DIST_COMMON = $(srcdir)/Makefile.am $(am__DIST_COMMON) mkinstalldirs = $(install_sh) -d CONFIG_CLEAN_FILES = CONFIG_CLEAN_VPATH_FILES = @@ -160,6 +170,7 @@ am__define_uniq_tagged_files = \ done | $(am__uniquify_input)` ETAGS = etags CTAGS = ctags +am__DIST_COMMON = $(srcdir)/Makefile.in DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) ACLOCAL = @ACLOCAL@ AMTAR = @AMTAR@ @@ -330,7 +341,6 @@ $(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__confi echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu src/nmm/Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --gnu src/nmm/Makefile -.PRECIOUS: Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ @@ -574,6 +584,8 @@ uninstall-am: mostlyclean-compile mostlyclean-generic pdf pdf-am ps ps-am \ tags tags-am uninstall uninstall-am +.PRECIOUS: Makefile + .PHONY: clean-modules diff --git a/src/phys/Makefile.in b/src/phys/Makefile.in index 54ef887..82541ff 100644 --- a/src/phys/Makefile.in +++ b/src/phys/Makefile.in @@ -1,7 +1,7 @@ -# Makefile.in generated by automake 1.13.4 from Makefile.am. +# Makefile.in generated by automake 1.15.1 from Makefile.am. # @configure_input@ -# Copyright (C) 1994-2013 Free Software Foundation, Inc. +# Copyright (C) 1994-2017 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -15,7 +15,17 @@ @SET_MAKE@ VPATH = @srcdir@ -am__is_gnu_make = test -n '$(MAKEFILE_LIST)' && test -n '$(MAKELEVEL)' +am__is_gnu_make = { \ + if test -z '$(MAKELEVEL)'; then \ + false; \ + elif test -n '$(MAKE_HOST)'; then \ + true; \ + elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ + true; \ + else \ + false; \ + fi; \ +} am__make_running_with_option = \ case $${target_option-} in \ ?) ;; \ @@ -79,7 +89,6 @@ POST_UNINSTALL = : build_triplet = @build@ host_triplet = @host@ subdir = src/phys -DIST_COMMON = $(srcdir)/Makefile.in $(srcdir)/Makefile.am ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/m4/ax_blas.m4 \ $(top_srcdir)/m4/ax_check_compile_flags.m4 \ @@ -91,6 +100,7 @@ am__aclocal_m4_deps = $(top_srcdir)/m4/ax_blas.m4 \ $(top_srcdir)/m4/ax_lib_netcdf4.m4 $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) +DIST_COMMON = $(srcdir)/Makefile.am $(am__DIST_COMMON) mkinstalldirs = $(install_sh) -d CONFIG_CLEAN_FILES = CONFIG_CLEAN_VPATH_FILES = @@ -284,6 +294,7 @@ am__define_uniq_tagged_files = \ done | $(am__uniquify_input)` ETAGS = etags CTAGS = ctags +am__DIST_COMMON = $(srcdir)/Makefile.in DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) ACLOCAL = @ACLOCAL@ AMTAR = @AMTAR@ @@ -485,7 +496,6 @@ $(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__confi echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu src/phys/Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --gnu src/phys/Makefile -.PRECIOUS: Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ @@ -1423,6 +1433,8 @@ uninstall-am: mostlyclean-compile mostlyclean-generic pdf pdf-am ps ps-am \ tags tags-am uninstall uninstall-am +.PRECIOUS: Makefile + .PHONY: clean-modules diff --git a/src/post/Makefile.in b/src/post/Makefile.in index 4afed2f..e5e50b2 100644 --- a/src/post/Makefile.in +++ b/src/post/Makefile.in @@ -1,7 +1,7 @@ -# Makefile.in generated by automake 1.13.4 from Makefile.am. +# Makefile.in generated by automake 1.15.1 from Makefile.am. # @configure_input@ -# Copyright (C) 1994-2013 Free Software Foundation, Inc. +# Copyright (C) 1994-2017 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -15,7 +15,17 @@ @SET_MAKE@ VPATH = @srcdir@ -am__is_gnu_make = test -n '$(MAKEFILE_LIST)' && test -n '$(MAKELEVEL)' +am__is_gnu_make = { \ + if test -z '$(MAKELEVEL)'; then \ + false; \ + elif test -n '$(MAKE_HOST)'; then \ + true; \ + elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ + true; \ + else \ + false; \ + fi; \ +} am__make_running_with_option = \ case $${target_option-} in \ ?) ;; \ @@ -79,7 +89,6 @@ POST_UNINSTALL = : build_triplet = @build@ host_triplet = @host@ subdir = src/post -DIST_COMMON = $(srcdir)/Makefile.in $(srcdir)/Makefile.am ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/m4/ax_blas.m4 \ $(top_srcdir)/m4/ax_check_compile_flags.m4 \ @@ -91,6 +100,7 @@ am__aclocal_m4_deps = $(top_srcdir)/m4/ax_blas.m4 \ $(top_srcdir)/m4/ax_lib_netcdf4.m4 $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) +DIST_COMMON = $(srcdir)/Makefile.am $(am__DIST_COMMON) mkinstalldirs = $(install_sh) -d CONFIG_CLEAN_FILES = CONFIG_CLEAN_VPATH_FILES = @@ -162,6 +172,7 @@ am__define_uniq_tagged_files = \ done | $(am__uniquify_input)` ETAGS = etags CTAGS = ctags +am__DIST_COMMON = $(srcdir)/Makefile.in DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) ACLOCAL = @ACLOCAL@ AMTAR = @AMTAR@ @@ -332,7 +343,6 @@ $(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__confi echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu src/post/Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --gnu src/post/Makefile -.PRECIOUS: Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ @@ -588,6 +598,8 @@ uninstall-am: mostlyclean-compile mostlyclean-generic pdf pdf-am ps ps-am \ tags tags-am uninstall uninstall-am +.PRECIOUS: Makefile + .PHONY: clean-modules diff --git a/src/share/Makefile.in b/src/share/Makefile.in index db41aab..d98e64e 100644 --- a/src/share/Makefile.in +++ b/src/share/Makefile.in @@ -1,7 +1,7 @@ -# Makefile.in generated by automake 1.13.4 from Makefile.am. +# Makefile.in generated by automake 1.15.1 from Makefile.am. # @configure_input@ -# Copyright (C) 1994-2013 Free Software Foundation, Inc. +# Copyright (C) 1994-2017 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -15,7 +15,17 @@ @SET_MAKE@ VPATH = @srcdir@ -am__is_gnu_make = test -n '$(MAKEFILE_LIST)' && test -n '$(MAKELEVEL)' +am__is_gnu_make = { \ + if test -z '$(MAKELEVEL)'; then \ + false; \ + elif test -n '$(MAKE_HOST)'; then \ + true; \ + elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ + true; \ + else \ + false; \ + fi; \ +} am__make_running_with_option = \ case $${target_option-} in \ ?) ;; \ @@ -79,7 +89,6 @@ POST_UNINSTALL = : build_triplet = @build@ host_triplet = @host@ subdir = src/share -DIST_COMMON = $(srcdir)/Makefile.in $(srcdir)/Makefile.am ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/m4/ax_blas.m4 \ $(top_srcdir)/m4/ax_check_compile_flags.m4 \ @@ -91,6 +100,7 @@ am__aclocal_m4_deps = $(top_srcdir)/m4/ax_blas.m4 \ $(top_srcdir)/m4/ax_lib_netcdf4.m4 $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) +DIST_COMMON = $(srcdir)/Makefile.am $(am__DIST_COMMON) mkinstalldirs = $(install_sh) -d CONFIG_CLEAN_FILES = CONFIG_CLEAN_VPATH_FILES = @@ -193,6 +203,7 @@ am__define_uniq_tagged_files = \ done | $(am__uniquify_input)` ETAGS = etags CTAGS = ctags +am__DIST_COMMON = $(srcdir)/Makefile.in DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) ACLOCAL = @ACLOCAL@ AMTAR = @AMTAR@ @@ -367,7 +378,6 @@ $(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__confi echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu src/share/Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --gnu src/share/Makefile -.PRECIOUS: Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ @@ -671,6 +681,8 @@ uninstall-am: mostlyclean-compile mostlyclean-generic pdf pdf-am ps ps-am \ tags tags-am uninstall uninstall-am +.PRECIOUS: Makefile + .PHONY: clean-modules